diff --git a/Cuis5.0-4975-32.changes b/Cuis5.0-4975-32.changes deleted file mode 100644 index 404f019a..00000000 --- a/Cuis5.0-4975-32.changes +++ /dev/null @@ -1,220418 +0,0 @@ -'From Cuis 5.0 of 7 November 2016 [latest update: #2974] on 7 November 2016 at 2:53:38 pm'! - - -----SNAPSHOT----#(7 November 2016 2:53:55.973029 pm) Cuis5.0-2974-spur.image priorSource: 0! - -----QUIT----#(7 November 2016 2:54:03.110029 pm) Cuis5.0-2974-spur.image priorSource: 92! - -----STARTUP----#(17 November 2016 12:32:23.600889 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-2974-spur.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #2974] on 16 November 2016 at 3:55:25 pm'! -!Integer class methodsFor: 'instance creation' stamp: 'jmv 11/16/2016 15:37:15' prior: 16860879! - readFrom: aStream base: base - "Answer an instance of one of my concrete subclasses. Initial minus sign - accepted, and bases > 10 use letters A-Z. Embedded radix specifiers not - allowed--use Number readFrom: for that. Answer zero (not an error) if - there are no digits." - - | digit value neg cc atLeastOneDigitRead | - neg _ aStream peekFor: $-. - neg ifFalse: [aStream peekFor: $+]. - value _ 0. - atLeastOneDigitRead _ false. - [ aStream atEnd ] - whileFalse: [ - cc _ aStream next. - digit _ cc digitValue. - (digit < 0 or: [digit >= base]) - ifTrue: [ - aStream skip: -1. - atLeastOneDigitRead ifFalse: [self error: 'At least one digit expected here']. - ^neg - ifTrue: [value negated] - ifFalse: [value]]. - value _ value * base + digit. - atLeastOneDigitRead _ true ]. - neg ifTrue: [^ value negated]. - ^ value! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2975-Integer-readFrom-cleanup-JuanVuletich-2016Nov16-15h20m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2975] on 17 November 2016 at 9:08:34 am'! -!PositionableStream methodsFor: 'accessing' stamp: 'jmv 11/17/2016 09:06:59' prior: 16891425! - 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 | - position < readLimit ifTrue: [ - ^collection at: position+1 ]. - self atEnd ifTrue: [^nil]. - nextObject _ self next. - position _ position - 1. - ^nextObject! ! -!StandardFileStream methodsFor: 'read, write, position' stamp: 'jmv 11/17/2016 09:07:20' prior: 16913380! - peek - "Answer what would be returned if the message next were sent to the receiver. If the receiver is at the end, answer nil. " - | next | - position < readLimit ifTrue: [ - ^collection at: position+1 ]. - self atEnd ifTrue: [^ nil]. - next _ self basicNext. - self position: self position - 1. - ^ next! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2976-peek-Optimization-JuanVuletich-2016Nov17-09h06m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2975] on 17 November 2016 at 9:18:37 am'! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:42'! - nextDouble64BigEndian: bigEndian - "Store the given number as a 32 bit Float on this (binary) stream. - - Float pi hex '400921FB54442D18' - Float pi negated hex 'C00921FB54442D18' - - (ByteArray streamContents: [ :strm | - strm nextDouble64Put: Float pi bigEndian: false ]) - readStream nextDouble64BigEndian: false - - (ByteArray streamContents: [ :strm | - strm nextDouble64Put: Float pi bigEndian: true ]) - readStream nextDouble64BigEndian: true - " - | bytes | - bytes _ self next: 8. - ^ bytes doubleAt: 1 bigEndian: bigEndian! ! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:40'! - nextDouble64Put: aFloat bigEndian: bigEndian - "Store the given number as a 32 bit Float on this (binary) stream. - - Float pi hex '400921FB54442D18' - Float pi negated hex 'C00921FB54442D18' - - (ByteArray streamContents: [ :strm | - strm nextDouble64Put: Float pi bigEndian: false ]) hex - - (ByteArray streamContents: [ :strm | - strm nextDouble64Put: Float pi bigEndian: true ]) hex - " - | bytes | - bytes _ ByteArray new: 8. - bytes doubleAt: 1 put: aFloat bigEndian: bigEndian. - self nextPutAll: bytes! ! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:38'! - nextFloat32BigEndian: bigEndian - "Store the given number as a 32 bit Float on this (binary) stream. - - Float pi hex '400921FB54442D18' - Float pi negated hex 'C00921FB54442D18' - Float pi asIEEE32BitWord hex '16r40490FDB' - Float pi negated asIEEE32BitWord hex '16rC0490FDB' - - (ByteArray streamContents: [ :strm | - strm nextFloat32Put: Float pi bigEndian: false ]) - readStream nextFloat32BigEndian: false - - (ByteArray streamContents: [ :strm | - strm nextFloat32Put: Float pi bigEndian: true ]) - readStream nextFloat32BigEndian: true - " - | bytes | - bytes _ self next: 4. - ^ bytes floatAt: 1 bigEndian: bigEndian! ! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:34'! - nextFloat32Put: aFloat bigEndian: bigEndian - "Store the given number as a 32 bit Float on this (binary) stream. - - Float pi hex '400921FB54442D18' - Float pi negated hex 'C00921FB54442D18' - Float pi asIEEE32BitWord hex '16r40490FDB' - Float pi negated asIEEE32BitWord hex '16rC0490FDB' - - (ByteArray streamContents: [ :strm | - strm nextFloat32Put: Float pi bigEndian: false ]) hex 'DB0F4940' - - (ByteArray streamContents: [ :strm | - strm nextFloat32Put: Float pi bigEndian: true ]) hex '40490FDB' - " - | bytes | - bytes _ ByteArray new: 4. - bytes floatAt: 1 put: aFloat bigEndian: bigEndian. - self nextPutAll: bytes! ! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:26'! - nextSignedInt16BigEndian: bigEndian - "Answer the next signed, 16-bit integer from this (binary) stream. - - (ByteArray streamContents: [ :strm | - strm nextSignedInt16Put: -12345 bigEndian: false ]) - readStream nextSignedInt16BigEndian: false - - (ByteArray streamContents: [ :strm | - strm nextSignedInt16Put: -12345 bigEndian: true ]) - readStream nextSignedInt16BigEndian: true - " - | bytes | - bytes _ self next: 2. - ^ bytes shortAt: 1 bigEndian: bigEndian! ! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:26'! - nextSignedInt16Put: aNumber bigEndian: bigEndian - "Store the given number as a signed, 16-bit integer on this (binary) stream. - - (16r10000-12345) hex '16rCFC7' - - (ByteArray streamContents: [ :strm | - strm nextSignedInt16Put: -12345 bigEndian: false ]) hex - - (ByteArray streamContents: [ :strm | - strm nextSignedInt16Put: -12345 bigEndian: true ]) hex - " - | bytes | - bytes _ ByteArray new: 2. - bytes shortAt: 1 put: aNumber bigEndian: bigEndian. - self nextPutAll: bytes! ! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:26'! -nextSignedInt32BigEndian: bigEndian - "Answer the next signed, 32-bit integer from this (binary) stream. - - (ByteArray streamContents: [ :strm | - strm nextSignedInt32Put: -123456 bigEndian: false ]) - readStream nextSignedInt32BigEndian: false - - (ByteArray streamContents: [ :strm | - strm nextSignedInt32Put: -123456 bigEndian: true ]) - readStream nextSignedInt32BigEndian: true - " - | bytes | - bytes _ self next: 4. - ^ bytes longAt: 1 bigEndian: bigEndian! ! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:27'! - nextSignedInt32Put: aNumber bigEndian: bigEndian - "Store the given number as a signed, 32-bit integer on this (binary) stream. - - (16r100000000-123456) hex '16rFFFE1DC0' - - (ByteArray streamContents: [ :strm | - strm nextSignedInt32Put: -123456 bigEndian: false ]) hex - - (ByteArray streamContents: [ :strm | - strm nextSignedInt32Put: -123456 bigEndian: true ]) hex - " - | bytes | - bytes _ ByteArray new: 4. - bytes longAt: 1 put: aNumber bigEndian: bigEndian. - self nextPutAll: bytes! ! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:18'! - nextUnsignedInt16BigEndian: bigEndian - "Answer the next unsigned, 16-bit integer from this (binary) stream. - - (ByteArray streamContents: [ :strm | - strm nextUnsignedInt16Put: 12345 bigEndian: false ]) - readStream nextUnsignedInt16BigEndian: false - - (ByteArray streamContents: [ :strm | - strm nextUnsignedInt16Put: 12345 bigEndian: true ]) - readStream nextUnsignedInt16BigEndian: true - " - | bytes | - bytes _ self next: 2. - ^ bytes unsignedShortAt: 1 bigEndian: bigEndian! ! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:27'! - nextUnsignedInt16Put: aNumber bigEndian: bigEndian - "Store the given number as a unsigned, 16-bit integer on this (binary) stream. - - 12345 hex '16r3039' - - (ByteArray streamContents: [ :strm | - strm nextUnsignedInt16Put: 12345 bigEndian: false ]) hex - - (ByteArray streamContents: [ :strm | - strm nextUnsignedInt16Put: 12345 bigEndian: true ]) hex - " - | bytes | - bytes _ ByteArray new: 2. - bytes unsignedShortAt: 1 put: aNumber bigEndian: bigEndian. - self nextPutAll: bytes! ! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:19'! - nextUnsignedInt32BigEndian: bigEndian - "Answer the next unsigned, 32-bit integer from this (binary) stream. - - (ByteArray streamContents: [ :strm | - strm nextUnsignedInt32Put: 123456 bigEndian: false ]) - readStream nextUnsignedInt32BigEndian: false - - (ByteArray streamContents: [ :strm | - strm nextUnsignedInt32Put: 123456 bigEndian: true ]) - readStream nextUnsignedInt32BigEndian: true - " - | bytes | - bytes _ self next: 4. - ^ bytes unsignedLongAt: 1 bigEndian: bigEndian! ! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:27'! - nextUnsignedInt32Put: aNumber bigEndian: bigEndian - "Store the given number as a unsigned, 32-bit integer on this (binary) stream. - - 123456 hex '16r1E240' - - (ByteArray streamContents: [ :strm | - strm nextUnsignedInt32Put: 123456 bigEndian: false ]) hex - - (ByteArray streamContents: [ :strm | - strm nextUnsignedInt32Put: 123456 bigEndian: true ]) hex - " - | bytes | - bytes _ ByteArray new: 4. - bytes unsignedLongAt: 1 put: aNumber bigEndian: bigEndian. - self nextPutAll: bytes! ! -!Stream methodsFor: 'nonhomogeneous accessing' stamp: 'jmv 6/14/2013 20:02'! - nextNumber - "Answer a number from the stream." - - |element| - [(element := self next) isNil or: [element isDigit or: [element = $- or: [element = $)]]]] whileFalse. - element ifNil: [^nil]. - self skip: -1. - element = $) ifTrue: [^nil]. - ^Number readFrom: self! ! -!Stream methodsFor: 'nonhomogeneous accessing' stamp: 'jmv 2/29/2016 11:04'! - nextNumber: n - "Answer the next n bytes as a positive Integer or LargePositiveInteger. - Currently only for bigEndian. Consider following the convention in category 'normalized access'" - | s | - s _ 0. - 1 to: n do: - [:i | s _ (s bitShift: 8) bitOr: self next asInteger]. - ^ s normalize! ! -!Stream methodsFor: 'nonhomogeneous accessing' stamp: 'jmv 2/29/2016 11:04'! - 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. - Currently only for bigEndian. Consider following the convention in category 'normalized access'" - - 1 to: n do: [:i | self nextPut: (v digitAt: n+1-i)]. - ^ v -! ! -!Stream methodsFor: 'nonhomogeneous accessing' stamp: 'ls 9/14/1998 22:46'! - 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)." - - | aString length | - - "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]]. - aString _ String new: length. - - "read the characters in ASCII mode" - self ascii. - self nextInto: aString. - ^aString! ! -!Stream methodsFor: 'nonhomogeneous accessing' stamp: 'yo 4/16/2001 17:56'! - 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! ! - -DummyStream removeSelector: #nextDouble64BigEndian:! - -DummyStream removeSelector: #nextDouble64BigEndian:! - -DummyStream removeSelector: #nextDouble64Put:bigEndian:! - -DummyStream removeSelector: #nextDouble64Put:bigEndian:! - -DummyStream removeSelector: #nextNumber:put:! - -DummyStream removeSelector: #nextNumber:put:! - -DummyStream removeSelector: #nextSignedInt16BigEndian:! - -DummyStream removeSelector: #nextSignedInt16BigEndian:! - -DummyStream removeSelector: #nextSignedInt16Put:bigEndian:! - -DummyStream removeSelector: #nextSignedInt16Put:bigEndian:! - -DummyStream removeSelector: #nextSignedInt32BigEndian:! - -DummyStream removeSelector: #nextSignedInt32BigEndian:! - -DummyStream removeSelector: #nextSignedInt32Put:bigEndian:! - -DummyStream removeSelector: #nextSignedInt32Put:bigEndian:! - -DummyStream removeSelector: #nextStringPut:! - -DummyStream removeSelector: #nextStringPut:! - -DummyStream removeSelector: #nextUnsignedInt16BigEndian:! - -DummyStream removeSelector: #nextUnsignedInt16BigEndian:! - -DummyStream removeSelector: #nextUnsignedInt16Put:bigEndian:! - -DummyStream removeSelector: #nextUnsignedInt16Put:bigEndian:! - -DummyStream removeSelector: #nextUnsignedInt32BigEndian:! - -DummyStream removeSelector: #nextUnsignedInt32BigEndian:! - -DummyStream removeSelector: #nextUnsignedInt32Put:bigEndian:! - -DummyStream removeSelector: #nextUnsignedInt32Put:bigEndian:! - -DataStream removeSelector: #readStringOld! - -DataStream removeSelector: #readStringOld! - -PositionableStream removeSelector: #nextDouble64BigEndian:! - -PositionableStream removeSelector: #nextDouble64BigEndian:! - -PositionableStream removeSelector: #nextDouble64Put:bigEndian:! - -PositionableStream removeSelector: #nextDouble64Put:bigEndian:! - -PositionableStream removeSelector: #nextFloat32BigEndian:! - -PositionableStream removeSelector: #nextFloat32BigEndian:! - -PositionableStream removeSelector: #nextFloat32Put:bigEndian:! - -PositionableStream removeSelector: #nextFloat32Put:bigEndian:! - -PositionableStream removeSelector: #nextNumber! - -PositionableStream removeSelector: #nextNumber! - -PositionableStream removeSelector: #nextNumber:! - -PositionableStream removeSelector: #nextNumber:! - -PositionableStream removeSelector: #nextNumber:put:! - -PositionableStream removeSelector: #nextNumber:put:! - -PositionableStream removeSelector: #nextSignedInt16BigEndian:! - -PositionableStream removeSelector: #nextSignedInt16BigEndian:! - -PositionableStream removeSelector: #nextSignedInt16Put:bigEndian:! - -PositionableStream removeSelector: #nextSignedInt16Put:bigEndian:! - -PositionableStream removeSelector: #nextSignedInt32BigEndian:! - -PositionableStream removeSelector: #nextSignedInt32BigEndian:! - -PositionableStream removeSelector: #nextSignedInt32Put:bigEndian:! - -PositionableStream removeSelector: #nextSignedInt32Put:bigEndian:! - -PositionableStream removeSelector: #nextString! - -PositionableStream removeSelector: #nextString! - -PositionableStream removeSelector: #nextStringOld! - -PositionableStream removeSelector: #nextStringOld! - -PositionableStream removeSelector: #nextStringPut:! - -PositionableStream removeSelector: #nextStringPut:! - -PositionableStream removeSelector: #nextUnsignedInt16BigEndian:! - -PositionableStream removeSelector: #nextUnsignedInt16BigEndian:! - -PositionableStream removeSelector: #nextUnsignedInt16Put:bigEndian:! - -PositionableStream removeSelector: #nextUnsignedInt16Put:bigEndian:! - -PositionableStream removeSelector: #nextUnsignedInt32BigEndian:! - -PositionableStream removeSelector: #nextUnsignedInt32BigEndian:! - -PositionableStream removeSelector: #nextUnsignedInt32Put:bigEndian:! - -PositionableStream removeSelector: #nextUnsignedInt32Put:bigEndian:! - -Stream removeSelector: #nextStringOld! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2977-Stream-refactor-JuanVuletich-2016Nov17-09h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2977] on 17 November 2016 at 10:29:07 am'! -!PositionableStream methodsFor: 'testing' stamp: 'jmv 11/17/2016 10:28:06' prior: 16891536! - atEnd - "Answer whether the receiver can access any more objects." - - ^position >= readLimit! ! -!ReadStream methodsFor: 'accessing' stamp: 'jmv 11/17/2016 09:59:57' prior: 16897965! - next - "Answer the next object in the Stream represented by the receiver." - - ^position >= readLimit - ifFalse: [collection at: (position _ position + 1)]! ! -!WriteStream methodsFor: 'accessing' stamp: 'jmv 11/17/2016 10:28:35' prior: 16946385! - nextPut: anObject - "Insert the argument at the next position in the Stream represented by the receiver." - - position >= writeLimit - ifTrue: [^ self pastEndPut: anObject] - ifFalse: [ - position _ position + 1. - ^collection at: position put: anObject]! ! -!ReadWriteStream methodsFor: 'accessing' stamp: 'jmv 11/17/2016 10:28:45' prior: 16898094! - next - "Return the next object in the Stream represented by the receiver." - - "treat me as a FIFO" - ^ position >= readLimit - ifFalse: [collection at: (position _ position + 1)]! ! -!StandardFileStream methodsFor: 'read, write, position' stamp: 'jmv 11/17/2016 10:00:56' prior: 16913098! - basicNext - "Answer the next byte from this file, or nil if at the end of the file." - - | count | - collection ifNotNil: [ - position < readLimit - ifFalse: [ - readLimit := self primRead: fileID into: collection startingAt: 1 count: collection size. - position := 0. - readLimit = 0 ifTrue: [ ^nil ] ]. - ^collection at: (position := position + 1) ]. - count _ self primRead: fileID into: buffer1 startingAt: 1 count: 1. - ^count = 1 - ifTrue: [ buffer1 at: 1 ]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2978-RemoveObsoletePrimCalls-JuanVuletich-2016Nov17-10h26m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2977] on 17 November 2016 at 10:31:18 am'! - -Stream subclass: #StdIOReadStream - instanceVariableNames: 'fileID name buffer1' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #StdIOReadStream category: #'System-Support'! -Stream subclass: #StdIOReadStream - instanceVariableNames: 'fileID name buffer1' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! -!StdIOReadStream commentStamp: '' prior: 0! - Standard Input Stream. - -A basic problem/restriction with this code is that currently the VM runs multiple VM threads within a single OS thread. - -This means that waiting on StdIn blocks the VM, suspending all Smalltalk code.! - -Stream subclass: #StdIOWriteStream - instanceVariableNames: 'fileID name buffer1 collection readLimit position' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #StdIOWriteStream category: #'System-Support'! -Stream subclass: #StdIOWriteStream - instanceVariableNames: 'fileID name buffer1 collection readLimit position' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! -!StdIOWriteStream commentStamp: '' prior: 0! - Standard Output/Error Streams.! -!StdIOReadStream methodsFor: 'open / close' stamp: 'jmv 11/17/2016 10:12:24'! - openOnHandle: aFileID name: streamName - "Initialize the instance with the given file handle. - N.B. Do _not_ register the stream. We do not want it to be - closed implicitly (e.g. on GC). There may be multiple instances - accessing the same stream. The stream is not a file." - - fileID _ aFileID. - name _ streamName. - buffer1 _ String new: 1! ! -!StdIOReadStream methodsFor: 'streaming' stamp: 'jmv 11/17/2016 10:01:57'! - next - "Answer the next byte from this stream, or wait until one becomes available. - Warning: all Smalltalk processes are essentially suspended until that happens!!" - - | count | - count _ self primRead: fileID into: buffer1 startingAt: 1 count: 1. - ^count = 1 - ifTrue: [ buffer1 at: 1 ]! ! -!StdIOReadStream methodsFor: 'printing' stamp: 'jmv 11/17/2016 09:47:10'! - printOn: aStream - "Put a printed version of the receiver onto aStream." - - aStream nextPutAll: self class name; nextPutAll: ': '; print: name! ! -!StdIOReadStream methodsFor: 'primitives' stamp: 'jmv 11/17/2016 09:45:28'! - primRead: id into: byteArray startingAt: startIndex count: count - "Read up to count bytes of data from this file into the given string or byte array starting at the given index. Answer the number of bytes actually read." - - - self error: 'File read failed'! ! -!StdIOReadStream class methodsFor: 'instance creation' stamp: 'jmv 11/17/2016 09:46:36'! - stdin - | newSelf | - newSelf _ self basicNew. - newSelf - openOnHandle: self stdinHandle - name: 'stdin'. - ^newSelf! ! -!StdIOReadStream class methodsFor: 'accessing' stamp: 'jmv 11/17/2016 09:26:47'! - stdinHandle - - ^ StdIOWriteStream stdioHandles at: 1! ! -!StdIOWriteStream methodsFor: 'open / close' stamp: 'jmv 11/17/2016 10:14:32'! - openOnHandle: aFileID name: streamName - "Initialize the instance with the given file handle. - N.B. Do _not_ register the stream. We do not want it to be - closed implicitly (e.g. on GC). There may be multiple instances - accessing the same stream. The stream is not a file." - - fileID _ aFileID. - name _ streamName. - buffer1 _ String new: 1! ! -!StdIOWriteStream methodsFor: 'streaming' stamp: 'jmv 11/17/2016 10:19:51'! - flush - "Flush pending changes" - ^self primFlush: fileID! ! -!StdIOWriteStream methodsFor: 'streaming' stamp: 'jmv 11/17/2016 10:18:42'! - nextPut: char - "Write the given character to this file." - - buffer1 at: 1 put: char. - self primWrite: fileID from: buffer1 startingAt: 1 count: 1. - ^ char -! ! -!StdIOWriteStream methodsFor: 'printing' stamp: 'jmv 11/17/2016 09:35:56'! - printOn: aStream - "Put a printed version of the receiver onto aStream. 1/31/96 sw" - - aStream nextPutAll: self class name; nextPutAll: ': '; print: name! ! -!StdIOWriteStream methodsFor: 'primitives' stamp: 'jmv 11/17/2016 10:20:17'! - primFlush: id - "Flush pending changes to the disk" - - ! ! -!StdIOWriteStream methodsFor: 'primitives' stamp: 'jmv 11/17/2016 10:19:14'! - primWrite: id from: stringOrByteArray startingAt: startIndex count: count - "Write count bytes onto this file from the given string or byte array starting at the given index. Answer the number of bytes written." - - - (FileWriteError fileName: name) - signal: (self closed - ifTrue: [ 'File [', name, '] is closed' ] - ifFalse: [ 'File [', name, '] write failed' ])! ! -!StdIOWriteStream class methodsFor: 'instance creation' stamp: 'jmv 11/17/2016 10:15:08'! -stderr - | newSelf | - newSelf _ self basicNew. - newSelf - openOnHandle: self stderrHandle - name: 'stderr'. - ^newSelf! ! -!StdIOWriteStream class methodsFor: 'instance creation' stamp: 'jmv 11/17/2016 10:15:11'! - stdout - | newSelf | - newSelf _ self basicNew. - newSelf - openOnHandle: self stdoutHandle - name: 'stdout'. - ^newSelf! ! -!StdIOWriteStream class methodsFor: 'accessing' stamp: 'jmv 11/17/2016 09:26:20'! - stderrHandle - - ^ self stdioHandles at: 3! ! -!StdIOWriteStream class methodsFor: 'accessing' stamp: 'jmv 11/17/2016 09:26:09'! - stdioHandles -" answer handles: #(stdin stdout stderr) " - - self primitiveFailed! ! -!StdIOWriteStream class methodsFor: 'accessing' stamp: 'jmv 11/17/2016 09:26:12'! - stdoutHandle - - ^ self stdioHandles at: 2! ! - -Smalltalk removeClassNamed: #StdIOFileStream! - -Smalltalk removeClassNamed: #StdIOFileStream! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2979-NewStdIO-JuanVuletich-2016Nov17-10h29m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2979] on 17 November 2016 at 10:51:20 am'! -!StdIOWriteStream methodsFor: 'character writing' stamp: 'jmv 11/17/2016 10:48:18'! - newLine - "Append a newLine character to the receiver. - The Cuis convention is to use lf on output." - - self nextPut: Character newLineCharacter! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2980-stdout-newLine-JuanVuletich-2016Nov17-10h48m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2980] on 17 November 2016 at 11:51:03 am'! - -Stream subclass: #StdIOReadStream - instanceVariableNames: 'fileID name buffer1 peeked ' - classVariableNames: 'StdIn ' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #StdIOReadStream category: #'System-Support'! -Stream subclass: #StdIOReadStream - instanceVariableNames: 'fileID name buffer1 peeked' - classVariableNames: 'StdIn' - poolDictionaries: '' - category: 'System-Support'! - -Stream subclass: #StdIOWriteStream - instanceVariableNames: 'fileID name buffer1 collection readLimit position ' - classVariableNames: 'StdOut StdErr ' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #StdIOWriteStream category: #'System-Support'! -Stream subclass: #StdIOWriteStream - instanceVariableNames: 'fileID name buffer1 collection readLimit position' - classVariableNames: 'StdErr StdOut' - poolDictionaries: '' - category: 'System-Support'! -!StdIOReadStream methodsFor: 'streaming' stamp: 'jmv 11/17/2016 11:28:43'! - peek - "Answer the next byte from this stream, or wait until one becomes available. - Warning: all Smalltalk processes are essentially suspended until that happens!! - - Do not advance the stream!!" - - "Multiple calls to #peek don't make new reads" - peeked ifFalse: [ - self privateRead. - peeked _ true ]. - - "peeked is always true on exit" - ^buffer1 at: 1! ! -!StdIOReadStream methodsFor: 'streaming' stamp: 'jmv 11/17/2016 11:33:22'! - peekFor: aCharacter - "Answer false and do not move over the next element if it is not equal to the argument, aCharacter - Answer true and increment the position for accessing elements, if the next element is equal to anObject." - - | nextChar | - nextChar _ self peek. - aCharacter = nextChar ifTrue: [ - self next. - ^ true]. - ^ false! ! -!StdIOReadStream methodsFor: 'streaming' stamp: 'jmv 11/17/2016 11:24:52'! - privateRead - "Read one Character. - Private." - | count | - count _ self primRead: fileID into: buffer1 startingAt: 1 count: 1. - count = 1 ifFalse: [ buffer1 at: 1 put: nil ]! ! -!StdIOReadStream class methodsFor: 'cached state access' stamp: 'jmv 11/17/2016 11:45:00'! - releaseClassCachedState - - StdIn _ nil! ! -!StdIOWriteStream methodsFor: 'character writing' stamp: 'jmv 11/17/2016 11:08:02'! - space - "Append a space character to the receiver." - - self nextPut: Character space! ! -!StdIOWriteStream class methodsFor: 'cached state access' stamp: 'jmv 11/17/2016 11:44:50'! - releaseClassCachedState - - StdOut _ nil. - StdErr _ nil! ! -!StdIOReadStream methodsFor: 'open / close' stamp: 'jmv 11/17/2016 11:13:30' prior: 50332252! - openOnHandle: aFileID name: streamName - "Initialize the instance with the given file handle. - N.B. Do _not_ register the stream. We do not want it to be - closed implicitly (e.g. on GC). There may be multiple instances - accessing the same stream. The stream is not a file." - - fileID _ aFileID. - name _ streamName. - buffer1 _ String new: 1. - peeked _ false! ! -!StdIOReadStream methodsFor: 'streaming' stamp: 'jmv 11/17/2016 11:28:44' prior: 50332266! - next - "Answer the next byte from this stream, or wait until one becomes available. - Warning: all Smalltalk processes are essentially suspended until that happens!!" - - "If last call was #peek, not #next, then just answer cached value." - peeked - ifFalse: [ self privateRead ] - ifTrue: [ peeked _ false ]. - - "peeked is always false on exit" - ^buffer1 at: 1! ! -!StdIOReadStream class methodsFor: 'instance creation' stamp: 'jmv 11/17/2016 11:45:39' prior: 50332298! - stdin - StdIn ifNil: [ - StdIn _ self basicNew. - StdIn - openOnHandle: self stdinHandle - name: 'stdin' ]. - ^StdIn! ! -!StdIOWriteStream class methodsFor: 'instance creation' stamp: 'jmv 11/17/2016 11:46:13' prior: 50332367! - stderr - StdErr ifNil: [ - StdErr _ self basicNew. - StdErr - openOnHandle: self stderrHandle - name: 'stderr' ]. - ^StdErr! ! -!StdIOWriteStream class methodsFor: 'instance creation' stamp: 'jmv 11/17/2016 11:46:37' prior: 50332374! - stdout - StdOut ifNil: [ - StdOut _ self basicNew. - StdOut - openOnHandle: self stdoutHandle - name: 'stdout' ]. - ^StdOut! ! - -Stream subclass: #StdIOReadStream - instanceVariableNames: 'fileID name buffer1 peeked' - classVariableNames: 'StdIn' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #StdIOReadStream category: #'System-Support'! -Stream subclass: #StdIOReadStream - instanceVariableNames: 'fileID name buffer1 peeked' - classVariableNames: 'StdIn' - poolDictionaries: '' - category: 'System-Support'! - -Stream subclass: #StdIOWriteStream - instanceVariableNames: 'fileID name buffer1' - classVariableNames: 'StdErr StdOut' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #StdIOWriteStream category: #'System-Support'! -Stream subclass: #StdIOWriteStream - instanceVariableNames: 'fileID name buffer1' - classVariableNames: 'StdErr StdOut' - poolDictionaries: '' - category: 'System-Support'! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2981-StdIn-peek-peekFor-JuanVuletich-2016Nov17-11h08m-jmv.1.cs.st----! - -----SNAPSHOT----#(17 November 2016 12:32:56.842092 pm) Cuis5.0-2981-spur.image priorSource: 186! - -----QUIT----#(17 November 2016 12:33:29.990717 pm) Cuis5.0-2981-spur.image priorSource: 29844! - -----STARTUP----#(14 December 2016 2:31:49.510252 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-2981-spur.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #2981] on 17 November 2016 at 5:11:35 pm'! -!SequenceableCollection methodsFor: 'copying' stamp: 'jmv 11/17/2016 17:08:04' prior: 16906186! - copyReplaceFrom: start to: stop with: replacementCollection - "Answer a copy of the receiver satisfying the following conditions: - + 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! ! -!SHTextStylerST80 methodsFor: 'private' stamp: 'jmv 11/17/2016 16:54:39' prior: 16903350! - setAttributesFromRanges: ranges - - formattedText removeAttributesThat: [ :attribute | attribute isForShout ]. - - "Optimize for mutation speed unless method is really large but with very few distict elements: - Source code that includes just big literals is better served by conventional Text+RunArray" - "Do it only if we are not breaking textModel!! (for instance, StyledTextEditor asks for formatting just sections, not whole #actualContents)." - formattedText == textModel actualContents ifTrue: [ - (formattedText size > 2000 and: [ ranges size < 50 ]) ifFalse: [ - formattedText _ formattedText optimizedForMutationSpeed. - textModel basicActualContents: formattedText ]]. - - ranges do: [ :range | - - "Smalltalk text styling" - (self attributesFor: range rangeType) ifNotNil: [ :attributes | - attributes do: [ :each | - formattedText addAttribute: each from: range start to: range end ]]. - - "Show as subscripts if appropriate." - (classOrMetaClass isNil or: [ - classOrMetaClass theNonMetaClass lastUnderscoreMeansSubscript]) ifTrue: [ - (#( instVar classVar globalVar workspaceVar poolConstant - patternArg methodArg patternTempVar tempVar - blockPatternArg blockArg blockPatternTempVar blockTempVar - incompleteIdentifier undefinedIdentifier) pointsTo: range rangeType ) - ifTrue: [ - formattedText lastIndexOf: $_ startingAt: range end endingAt: range start do: [ :i | - formattedText addAttribute: ShoutTextEmphasis subscript from: i to: range end ] ]]]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2982-CodeColorizerFix-JuanVuletich-2016Nov17-17h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2981] on 17 November 2016 at 5:18:27 pm'! -!DummyStream methodsFor: 'as yet unclassified' stamp: 'KenD 11/5/2016 16:17:09'! - space! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2983-DummyStream-space-KenDickey-2016Nov17-17h18m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2981] on 18 November 2016 at 10:49:39 am'! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/3/2015 10:19' prior: 16935004! - newMorph - "The user requested 'new morph' from the world menu. Put up a menu that allows many ways of obtaining new morphs. If the preference #classicNewMorphMenu is true, the full form of yore is used; otherwise, a much shortened form is used." - | menu subMenu catDict shortCat class | - menu _ self menu: 'Add a new morph'. - menu - - add: 'From Clipboard' - target: myHand - action: #pasteMorph; - - add: 'From Alphabetical List' - subMenu: self alphabeticalMorphMenu. - menu addLine. - - "Add 'Classic' New Morph menu" - catDict _ Dictionary new. - SystemOrganization categories do: [ :cat | - ((cat beginsWith: 'Morphic-') and: [ (#('Morphic-Menus' 'Morphic-Support' ) includes: cat) not ]) ifTrue: [ - shortCat _ (cat - copyFrom: 'Morphic-' size + 1 - to: cat size). - (SystemOrganization listAtCategoryNamed: cat) do: [ :cName | - class _ Smalltalk at: cName. - ((class inheritsFrom: Morph) and: [ class includeInNewMorphMenu ]) ifTrue: [ - (catDict includesKey: shortCat) - ifTrue: [ (catDict at: shortCat) addLast: class ] - ifFalse: [ - catDict - at: shortCat - put: (OrderedCollection with: class) ]]]]]. - catDict keys sort do: [ :categ | - subMenu _ MenuMorph new. - ((catDict at: categ) asArray sort: [ :c1 :c2 | - c1 name < c2 name ]) do: [ :cl | - subMenu - add: cl name - target: self - selector: #newMorphOfClass:event: - argument: cl ]. - menu - add: categ - subMenu: subMenu ]. - - self doPopUp: menu.! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2984-NewMorphMenuFix-JuanVuletich-2016Nov18-10h34m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2984] on 30 November 2016 at 2:56:21 pm'! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'jmv 11/30/2016 14:52:08'! - with: otherCollection with: thirdCollection collect: threeArgBlock - "Collect and return the result of evaluating twoArgBlock with corresponding elements from this collection and otherCollection." - | n result | - n _ self size. - otherCollection size = n ifFalse: [ self error: 'otherCollection must be the same size' ]. - thirdCollection size = n ifFalse: [ self error: 'thirdCollection must be the same size' ]. - result _ self species new: n. - 1 to: n do: [ :index | - result at: index put: - (threeArgBlock - value: (self at: index) - value: (otherCollection at: index) - value: (thirdCollection at: index) )]. - ^ result! ! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'jmv 11/25/2016 12:15:27'! - with: otherCollection with: thirdCollection do: threeArgBlock - "Evaluate twoArgBlock with corresponding elements from this collection and otherCollection." - | n | - n _ self size. - otherCollection size = n ifFalse: [self error: 'otherCollection must be the same size']. - thirdCollection size = n ifFalse: [self error: 'thirdCollection must be the same size']. - 1 to: n do: [ :index | - threeArgBlock - value: (self at: index) - value: (otherCollection at: index) - value: (thirdCollection at: index)]! ! -!OrderedCollection methodsFor: 'enumerating' stamp: 'jmv 11/30/2016 14:51:19'! - with: otherCollection with: thirdCollection collect: threeArgBlock - "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: - (threeArgBlock - value: (self at: index) - value: (otherCollection at: index) - value: (thirdCollection at: index) )]. - ^ result! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2985-withwithdo-withwithdcollect-JuanVuletich-2016Nov30-14h47m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2984] on 30 November 2016 at 3:22:11 pm'! -!SequenceableCollection methodsFor: 'math functions' stamp: 'jmv 11/30/2016 15:04:11'! - += anObject - ^anObject isNumber - ifTrue: [ self replace: [ :v | v + anObject ]] - ifFalse: [ - self withIndexDo: [ :v :i | - self at: i put: ((self at: i) + (anObject at: i)) ]]! ! -!SequenceableCollection methodsFor: 'math functions' stamp: 'jmv 11/25/2016 11:41:25'! - -= anObject - ^anObject isNumber - ifTrue: [ self replace: [ :v | v - anObject ]] - ifFalse: [ - self withIndexDo: [ :v :i | - self at: i put: ((self at: i) - (anObject at: i)) ]]! ! -!SequenceableCollection methodsFor: 'math functions' stamp: 'jmv 11/30/2016 15:21:00'! - derivative - | displaced answer | - displaced _ self class new: self size. - displaced replaceFrom: 2 to: self size with: self startingAt: 1. - displaced at: 1 put: self first - self first. "Some reasonable zero" - answer _ self copy. - answer -= displaced. - ^answer! ! -!SequenceableCollection methodsFor: 'math functions' stamp: 'jmv 11/29/2016 14:23:32'! - integral - | answer | - answer _ self copy. - 2 to: answer size do: [ :i | - answer at: i put: (answer at: i) + (answer at: i-1) ]. - ^answer! ! - -FloatArray removeSelector: #derivative! - -FloatArray removeSelector: #derivative! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2986-Collection-derivative-integral-JuanVuletich-2016Nov30-14h56m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2974] on 26 November 2016 at 8:42:22 am'! -!HaloMorph methodsFor: 'stepping' stamp: 'len 7/25/2016 21:39'! - step - (target isNil or: [target isInWorld not]) ifTrue: [self delete]! ! -!HaloMorph methodsFor: 'stepping' stamp: 'len 7/25/2016 21:41'! - stepTime - ^ 100! ! -!HaloMorph methodsFor: 'stepping' stamp: 'len 7/25/2016 21:38'! - wantsSteps - ^ true! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2987-DeleteHaloWhenMorphIsDeleted-LucianoEstebanNotarfrancesco-2016Nov26-08h41m-len.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2974] on 26 November 2016 at 8:46:53 am'! -!MenuMorph methodsFor: 'keyboard control' stamp: 'len 6/11/2016 20:40' prior: 16867064! - keyboardFocusChange: aBoolean - "Notify change due to green border for keyboard focus" - - aBoolean ifFalse: [self deleteIfPopUp: nil]. - self redrawNeeded! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2988-AvoidManuesHangingAround-LucianoEstebanNotarfrancesco-2016Nov26-08h42m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2974] on 26 November 2016 at 8:52:37 am'! -!SequenceableCollection methodsFor: 'copying' stamp: 'len 4/18/2016 22:08'! - shuffledBy: aGenerator - "To answer a mutable collection when receiver is, for example, an Interval." - ^ (self collect: [ :each | each ]) shuffleBy: aGenerator! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2989-ShuffledBy-LucianoEstebanNotarfrancesco-2016Nov26-08h46m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2974] on 26 November 2016 at 9:02:48 am'! -!SystemDictionary methodsFor: 'browsing' stamp: 'len 6/9/2016 23:23'! - browseAllPrimitives - self browseAllSelect: [:each| each primitive ~= 0 and: [(each primitive between: 256 and: 291) not]] -! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2990-SmalltalkBrowseAllPrimitives-LucianoEstebanNotarfrancesco-2016Nov26-08h52m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2974] on 26 November 2016 at 9:03:51 am'! -!SystemDictionary methodsFor: 'retrieving' stamp: 'len 11/26/2016 09:03:25' prior: 16921461! - allCallsOn: aLiteral "Smalltalk browseAllCallsOn: #open:label:." - "Answer a Collection of all the methods that call on aLiteral." - | aCollection special aList byte | - - #(23 48 'fred' (new open:label:)) size. -"Example above should find #open:label:, though it is deeply embedded here." - - aCollection _ OrderedCollection new. - special _ self hasSpecialSelector: aLiteral ifTrueSetByte: [:b | byte _ b ]. - self allBehaviorsDo: [:class | - aList _ class whichSelectorsReferTo: aLiteral special: special byte: byte. - aList do: [ :sel | - "For special selectors, look for the literal in the source code. - Otherwise, for example, searching for senders of #== will include senders of #ifNil. - Except for #at:put:, because it has two arguments and won't find it in the source code like that." - (byte isNil or: [aLiteral = #at:put: or: [ - ((class sourceCodeAt: sel) - findString: aLiteral) > 0]]) ifTrue: [ - - aCollection add: ( - MethodReference new - setStandardClass: class - methodSymbol: sel - ) - ] - ] - ]. - ^ aCollection! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2991-SendersOfatput-LucianoEstebanNotarfrancesco-2016Nov26-09h02m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2974] on 26 November 2016 at 9:06:05 am'! -!String methodsFor: 'testing' stamp: 'len 11/26/2016 09:05:35'! - isAlphaNumeric - "Answer true if the receiver contains only letters or digits." - ^ self allSatisfy: [:each| each isAlphaNumeric]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2992-StringisAlphaNumeric-LucianoEstebanNotarfrancesco-2016Nov26-09h03m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2974] on 26 November 2016 at 9:08:39 am'! -!Form methodsFor: 'fileIn/Out' stamp: 'len 8/1/2016 08:13' prior: 16847779! - printOn: aStream - aStream isText - ifTrue: - [aStream withAttribute: (TextAnchor new anchoredFormOrMorph: self) do: [aStream nextPut: $*]. - ^ self]. - aStream - nextPutAll: self class name; - nextPut: $(; print: width; - nextPut: $x; print: height; - nextPut: $x; print: depth; - nextPut: $)! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2993-FormPrintOnTextForWorkspaces-LucianoEstebanNotarfrancesco-2016Nov26-09h06m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2993] on 5 December 2016 at 8:17:22 am'! -!Morph methodsFor: 'printing' stamp: 'jmv 12/5/2016 08:16:19' prior: 16876467! - printOn: aStream - "Add the identity of the receiver to a stream" - aStream isText - ifTrue: [ - aStream - withAttribute: (TextAnchor new anchoredFormOrMorph: (owner ifNil: [self] ifNotNil: [self imageForm:32])) - do: [ aStream nextPut: $* ]. - ^ self]. - super printOn: aStream. "a(n) className" - aStream - nextPut: $(; - print: self identityHash; - nextPut: $). - self valueOfProperty: #morphName ifPresentDo: [ :x | aStream nextPutAll: x asString]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2994-MorphPrintOnTextEnh-JuanVuletich-2016Dec05-08h16m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2994] on 5 December 2016 at 9:46:02 am'! -!Integer methodsFor: 'comparing' stamp: 'len 12/5/2016 09:46:00' prior: 16859447! - hash - "Hash is reimplemented because = is implemented. - | s | - s _ (1 to: 10000) asSet. - [s includes: 123456] bench - " - - ^self hashMultiply! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - -Set rehashAllSets! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2995-Integer-hash-LucianoEstebanNotarfrancesco-2016Dec05-09h39m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2986] on 2 December 2016 at 4:40:51 pm'! -!Form methodsFor: 'scaling, rotation' stamp: 'jmv 12/2/2016 15:47:08' prior: 16848280! - flippedBy: direction - "Return a copy of the receiver flipped either #vertical, #horizontal or #both. (#both is a 180 degrees rotation) - Form lena display. - (Form lena flippedBy: #vertical) display. - (Form lena flippedBy: #horizontal) display. - (Form lena flippedBy: #both) display. - " - | newForm quad | - newForm _ self class extent: self extent depth: depth. - quad _ self boundingBox innerCorners. - quad _ ( - direction caseOf: { - [ #vertical ] -> [#(2 1 4 3)]. - [ #horizontal ] -> [#(4 3 2 1)]. - [ #both ] -> [#(3 4 1 2)]}) - collect: [:i | quad at: i]. - (WarpBlt toForm: newForm) - sourceForm: self; - colorMap: (self colormapIfNeededFor: newForm); - combinationRule: 3; - copyQuad: quad toRect: newForm boundingBox. -" newForm offset: (self offset flippedBy: direction centerAt: aPoint)." - ^ newForm -" -[Sensor isAnyButtonPressed] whileFalse: - [((Form fromDisplay: (Sensor mousePoint extent: 130@66)) - flippedBy: #vertical centerAt: 0@0) display] -" -"Consistency test... - | f f2 p | -[ Sensor isAnyButtonPressed ] whileFalse: [ - f _ Form fromDisplay: ((p _ Sensor mousePoint) extent: 31@41). - Display fillBlack: (p extent: 31@41). - f2 _ f flippedBy: #vertical centerAt: 0@0. - (f2 flippedBy: #vertical centerAt: 0@0) displayAt: p ] -"! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2996-Form-FlippedBy-both-JuanVuletich-2016Dec02-15h42m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2996] on 9 December 2016 at 9:12:18 am'! -!StringMorph methodsFor: 'initialization' stamp: 'jmv 12/9/2016 09:09:45' prior: 16918230! - initialize - super initialize. - font _ nil. - emphasis _ 0. - self contents: 'String Morph' -! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2997-StringMorph-fix-JuanVuletich-2016Dec09-09h07m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2974] on 29 November 2016 at 9:10:32 pm'! -!OrderedCollection methodsFor: 'converting' stamp: 'len 11/29/2016 08:54:14'! - asNewArray - ^ array copyFrom: firstIndex to: lastIndex! ! -!OrderedCollection class methodsFor: 'instance creation' stamp: 'len 11/28/2016 19:18:39'! - newFrom: aCollection - "Create a new collection containing all the elements from aCollection" - - ^(self new: aCollection size) - resetTo: 1; - addAll: aCollection; - yourself! ! -!OrderedCollection methodsFor: 'enumerating' stamp: 'len 11/28/2016 10:50:21' prior: 16883972! - 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. - newCollection resetTo: 1. - firstIndex to: lastIndex do: [ :index | - newCollection addLast: (aBlock value: (array at: index))]. - ^ newCollection! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2998-OrderedCollectionTweaks-LucianoEstebanNotarfrancesco-2016Nov26-09h08m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2995] on 6 December 2016 at 8:16:54 pm'! - -RectangleLikeMorph subclass: #ResizeMorph - instanceVariableNames: 'gridLineWidth gridColor selectionColor outlineMorph grid from to action' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #ResizeMorph category: #'Morphic-Views'! -RectangleLikeMorph subclass: #ResizeMorph - instanceVariableNames: 'gridLineWidth gridColor selectionColor outlineMorph grid from to action' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! -!SystemWindow methodsFor: 'resize/collapse' stamp: 'bp 10/18/2015 12:18'! - resize - | resizeMorph | - resizeMorph _ ResizeMorph new morphExtent: 200@150. - resizeMorph action: [self resize: (resizeMorph selectionRectangle: Display extent)]. - resizeMorph morphPosition: self world activeHand morphPosition. - resizeMorph openInWorld - ! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 22:22'! - action: aBlock - action _ aBlock! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/18/2015 18:00'! - drawGridOn: aCanvas - 0 to: grid x do: [:i | - | x | - x _ i * (extent x - gridLineWidth) / grid x. - aCanvas line: x @ 0 to: x @ (extent y - 2) width: gridLineWidth color: gridColor]. - 0 to: grid y do: [:i | - | y | - y _ i * (extent y - gridLineWidth) / grid y. - aCanvas line: 0 @ y to: (extent x - 2) @ y width: gridLineWidth color: gridColor]! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 23:02'! - drawOn: aCanvas - super drawOn: aCanvas. - from ifNotNil: [aCanvas fillRectangle: (self selectionRectangle: extent) color: selectionColor]. - self drawGridOn: aCanvas! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 19:00'! - grid: aPoint - grid _ aPoint! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 19:00'! - handlesMouseDown: aMouseButtonEvent - ^true! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/17/2015 15:51'! - initialize - super initialize. - extent _ 400@300. - color _ Color white. - grid _ 8@6. - gridLineWidth _ 2. - gridColor _ Color black. - selectionColor _ Color red! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 23:18'! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - from _ self toGridPoint: localEventPosition. - outlineMorph _ BorderedRectMorph new - borderColor: Color black; - color: Color transparent; - openInWorld; - hide. - self selectTo: localEventPosition! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 23:17'! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - self selectTo: localEventPosition. - outlineMorph delete. - action ifNotNil: [ - action value. - self delete]! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 21:32'! - mouseMove: aMouseButtonEvent localPosition: localEventPosition - self selectTo: localEventPosition! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 21:25'! - printOn: aStream - super printOn: aStream. - aStream space; print: from; space; print: to! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 23:14'! - selectTo: localEventPosition - | newTo | - newTo _ self toGridPoint: localEventPosition. - newTo ~= to ifTrue: [ - to _ newTo. - self redrawNeeded. - self updateOutlineMorph]! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/17/2015 15:35'! - selectionRectangle: aRectangle - ^(from corner: to + 1) scaledBy: aRectangle // grid! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/17/2015 15:34'! - toGridPoint: aPoint - ^(aPoint min: extent - 1) // (extent // grid)! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 23:15'! - updateOutlineMorph - | rectangle | - rectangle _ self selectionRectangle: Display extent. - outlineMorph - morphPosition: rectangle origin extent: rectangle extent; - show! ! -!SystemWindow methodsFor: 'menu' stamp: 'bp 10/11/2015 21:42' prior: 16926424! - buildWindowMenu - - | aMenu | - - aMenu _ MenuMorph new defaultTarget: self. - - aMenu - add: 'change title...' action: #relabel; - add: 'window color...' action: #setWindowColor; - addLine; - add: 'send to back' action: #sendToBack; - add: 'make next-to-topmost' action: #makeSecondTopmost; - addLine; - add: (self isSticky ifTrue: [ 'make draggable' ] ifFalse: [ 'make undraggable' ]) action: #toggleStickiness; - addLine; - add: 'close' action: #delete; - add: 'collapse' action: #collapse; - add: 'expand / contract' action: #expandBoxHit; - addLine; - add: 'resize...' action: #resize; - add: 'resize full' action: #resizeFull; - add: 'resize top' action: #resizeTop; - add: 'resize left' action: #resizeLeft; - add: 'resize bottom' action: #resizeBottom; - add: 'resize right' action: #resizeRight; - add: 'resize top left' action: #resizeTopLeft; - add: 'resize top right' action: #resizeTopRight; - add: 'resize bottom left' action: #resizeBottomLeft; - add: 'resize bottom right' action: #resizeBottomRight. - - ^ aMenu! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2999-ResizeMorph-BernhardPieber-2016Dec06-20h13m-bp.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2981] on 9 December 2016 at 10:27:21 am'! -!PasteUpMorph methodsFor: 'printing' stamp: 'jmv 12/9/2016 10:25:13' prior: 16887389! - printOn: aStream - "Reimplemented to add a tag showing that the receiver is currently functioning as a 'world', if it is" - - self isWorldMorph - ifTrue: [aStream nextPutAll: ' [world]'] - ifFalse: [super printOn: aStream]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3000-PasteUpMorph-print-fix-JuanVuletich-2016Dec09-10h25m-jmv.1.cs.st----! - -----SNAPSHOT----#(14 December 2016 2:32:05.602236 pm) Cuis5.0-3000-spur.image priorSource: 29942! - -----QUIT----#(14 December 2016 2:32:40.672866 pm) Cuis5.0-3000-spur.image priorSource: 54545! - -----STARTUP----#(19 December 2016 1:35:02.293384 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3000-spur.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3000] on 15 December 2016 at 12:11:15 pm'! -!Point methodsFor: 'printing' stamp: 'jmv 12/15/2016 10:20:58'! - printStringFractionDigits: placesDesired - ^(x printStringFractionDigits: placesDesired), '@', (y printStringFractionDigits: placesDesired)! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3001-Point-printStringFractionDigits-JuanVuletich-2016Dec15-10h20m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3000] on 16 December 2016 at 3:13:12 pm'! -!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 12/16/2016 15:05:52' prior: 16924259! - browseMyChanges - "Browse only the changes (in the changes file) by the current author. - Smalltalk browseMyChanges - " - self browseAllSelect: [ :method | - method fileIndex > 1 "only look at changes file" - and: [ method timeStamp beginsWith: Utilities authorInitials, ' ' ]]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3002-BrowseMyChanges-fix-JuanVuletich-2016Dec16-15h03m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3002] on 19 December 2016 at 12:44:03 pm'! -!CompiledMethod methodsFor: 'accessing' stamp: 'jmv 12/17/2016 22:38:52' prior: 16819446! - initialPC - "Answer the program counter for the receiver's first bytecode." - ^ (self numLiterals + 1) * Smalltalk wordSize + 1! ! -!SystemDictionary methodsFor: 'memory space' stamp: 'jmv 12/17/2016 22:37:27' prior: 16920388! -lowSpaceThreshold - "Answer the low space threshold. When the amount of free memory (after garbage collection) - falls below this limit, the system is in serious danger of completely exhausting memory and - crashing. This limit should be made high enough to allow the user open a debugger to diagnose - a problem or to save the image. In a stack-based VM such as Cog contexts for activations in - the stack zone will have to be created as the debugger opens, requiring additional headroom." - - | slotsForDebugger slotsForContextsOnStackPages | - slotsForDebugger := 65536. "Arbitrary guess" - slotsForContextsOnStackPages := - (self vmParameterAt: 42) - ifNil: [0] - ifNotNil: - [:numStackPages| | headerSize numActivationsPerPage maxContextSize | - numActivationsPerPage := 40. "Design goal of the Cog VM" - headerSize := 2. "64-bytes for Spur" - maxContextSize := MethodContext instSize + CompiledMethod fullFrameSize + headerSize. - numStackPages * numActivationsPerPage * maxContextSize]. - ^slotsForDebugger + slotsForContextsOnStackPages * self wordSize! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3003-FixFor64BitSpur-JuanVuletich-2016Dec19-12h41m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3002] on 19 December 2016 at 12:54:39 pm'! -!Parser methodsFor: 'primitives' stamp: 'nice 9/6/2013 00:48' prior: 16885817! - externalFunctionDeclaration - "Parse the function declaration for a call to an external library." - | descriptorClass callType modifier retType externalName args argType module fn | - descriptorClass := Smalltalk at: #ExternalFunction ifAbsent: [ ^ false ]. - callType := descriptorClass callingConventionFor: here. - callType == nil ifTrue:[^false]. - [modifier := descriptorClass callingConventionModifierFor: token. - modifier notNil] whileTrue: - [self advance. - callType := callType bitOr: modifier]. - "Parse return type" - self advance. - retType := self externalType: descriptorClass. - retType == nil ifTrue:[^self expected:'return type']. - "Parse function name or index" - externalName := here. - (self match: #string) - ifTrue:[externalName := externalName asSymbol] - ifFalse:[(self match:#number) ifFalse:[^self expected:'function name or index']]. - (self match: #leftParenthesis) ifFalse:[^self expected:'argument list']. - args := WriteStream on: Array new. - [self match: #rightParenthesis] whileFalse:[ - argType := self externalType: descriptorClass. - argType == nil ifTrue:[^self expected:'argument']. - argType isVoid & argType isPointerType not ifFalse:[args nextPut: argType]]. - (self matchToken: 'module:') ifTrue:[ - module := here. - (self match: #string) ifFalse:[^self expected: 'String']. - module := module asSymbol]. - Smalltalk at: #ExternalLibraryFunction ifPresent:[:xfn| - fn := xfn name: externalName - module: module - callType: callType - returnType: retType - argumentTypes: args contents. - self allocateLiteral: fn]. - (self matchToken: 'error:') - ifTrue: - [| errorCodeVariable | - errorCodeVariable := here. - (hereType == #string - or: [hereType == #word]) ifFalse:[^self expected: 'error code (a variable or string)']. - self advance. - self addPragma: (Pragma keyword: #primitive:error: arguments: (Array with: 120 with: errorCodeVariable)). - fn ifNotNil: [fn setErrorCodeName: errorCodeVariable]] - ifFalse: - [self addPragma: (Pragma keyword: #primitive: arguments: #(120))]. - ^true! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3004-externalFunctionDeclaration-JuanVuletich-2016Dec19-12h44m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3002] on 19 December 2016 at 1:08:36 pm'! - -SmallInteger class - instanceVariableNames: 'minVal maxVal '! - -!classDefinition: 'SmallInteger class' category: #'Kernel-Numbers'! -SmallInteger class - instanceVariableNames: 'minVal maxVal'! -!SmallInteger class methodsFor: 'class initialization' stamp: 'jmv 12/19/2016 13:03:09'! - initMinValAndMaxVal - | next val | - val := -32768. "Assume at least 16 bits" - [next := val + val. - next class == self] whileTrue: - [val := next]. - minVal := val. - maxVal := -1 - val! ! -!SystemDictionary methodsFor: 'image' stamp: 'jmv 12/19/2016 13:04:12' prior: 16925538! - wordSize - "Answer the size in bytes of an object pointer or word in the object memory. - The value does not change for a given image, but may be modified by a SystemTracer - when converting the image to another format. The value is cached in WordSize to - avoid the performance overhead of repeatedly consulting the VM." - - "Smalltalk wordSize" - - ^ WordSize ifNil: [ - SmallInteger initMinValAndMaxVal. - WordSize := [self vmParameterAt: 40] on: Error do: [4]]! ! - -SmallInteger class - instanceVariableNames: 'minVal maxVal'! - -!classDefinition: 'SmallInteger class' category: #'Kernel-Numbers'! -SmallInteger class - instanceVariableNames: 'minVal maxVal'! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -SmallInteger initMinValAndMaxVal! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3005-SmallInteger-minVal-maxVal-part1-JuanVuletich-2016Dec19-12h54m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3005] on 19 December 2016 at 1:12:20 pm'! -!SmallInteger class methodsFor: 'constants' stamp: 'jmv 12/19/2016 13:06:38' prior: 16909182! - maxVal - "Answer the maximum value for a SmallInteger." - - "Ensure word size is properly set. If so, maxVal is also set." - Smalltalk wordSize. - ^maxVal! ! -!SmallInteger class methodsFor: 'constants' stamp: 'jmv 12/19/2016 13:07:24' prior: 16909186! - minVal - "Answer the minimum value for a SmallInteger." - - "Ensure word size is properly set. If so, minVal is also set." - Smalltalk wordSize. - ^minVal! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3006-SmallInteger-minVal-maxVal-part2-JuanVuletich-2016Dec19-13h11m-jmv.1.cs.st----! - -----SNAPSHOT----#(19 December 2016 1:35:11.847544 pm) Cuis5.0-3006-spur.image priorSource: 54644! - -----QUIT----#(19 December 2016 1:35:24.272429 pm) Cuis5.0-3006-spur.image priorSource: 62581! - -----STARTUP----#(19 December 2016 1:45:03.353057 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3006-spur.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3006] on 19 December 2016 at 1:42:27 pm'! -!SmallFloat64 commentStamp: '' prior: 16908181! - My instances represent 64-bit Floats whose exponent fits in 8 bits as immediate objects. This representation is only available on 64-bit systems, not 32-bit systems.! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -SmallFloat64 tryPrimitive: 161 withArgs: #(999). -! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3007-SmallFloat64-fixHash-forSpur64Conversion-JuanVuletich-2016Dec19-13h41m-jmv.1.cs.st----! - -----SNAPSHOT----#(19 December 2016 1:45:10.081033 pm) Cuis5.0-3007-spur.image priorSource: 62680! - -----QUIT----#(19 December 2016 1:45:27.503203 pm) Cuis5.0-3007-spur.image priorSource: 63733! - -----STARTUP----#(27 December 2016 12:18:09.525689 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3007-spur.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3007] on 22 December 2016 at 4:05:04 pm'! -!LargePositiveInteger methodsFor: 'testing' stamp: 'nice 8/31/2008 00:07'! - isLarge - ^true! ! -!SmallInteger methodsFor: 'testing' stamp: 'nice 8/31/2008 00:07'! - isLarge - ^false! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/27/2015 23:01'! - long64At: index bigEndian: bigEndian - "Return a 64-bit signed integer quantity starting from the given byte index." - - | value | - value := self unsignedLong64At: index bigEndian: bigEndian. - value digitLength < 8 ifTrue: [ ^value ]. - (value digitAt: 8) < 16r80 ifTrue: [ ^value ]. - ^value - 16r10000000000000000! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/27/2015 22:57'! - long64At: index put: value bigEndian: bigEndian - "Store a 64-bit signed integer quantity starting from the given byte index." - - ^self - unsignedLong64At: index - put: (value negative - ifFalse: [ value ] - ifTrue: [ value + 16r10000000000000000 ]) - bigEndian: bigEndian! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'eem 2/22/2016 09:36'! - unsignedLong64At: index bigEndian: bigEndian - "Return a 64-bit unsigned integer quantity starting from the given byte index. Use #normalize where necessary to ensure compatibility with non-30-bit SmallIntegers." - - | byte | - SmallInteger maxVal > 1073741823 ifTrue: - [bigEndian - ifTrue: "64-bit SmallIntegers have a 3 bit tag and a sign bit, so the most positive value has 16rF as its top byte." - [(byte := self at: index) <= 16rF ifTrue: - [^((((((((byte bitShift: 8) + (self at: index + 1) bitShift: 8) + (self at: index + 2) bitShift: 8) + (self at: index + 3)) bitShift: 8) - + (self at: index + 4) bitShift: 8) + (self at: index + 5) bitShift: 8) + (self at: index + 6) bitShift: 8) + (self at: index + 7)]] - ifFalse: - [(byte := self at: index + 7) <= 16rF ifTrue: - [^((((((((byte bitShift: 8) + (self at: index + 6) bitShift: 8) + (self at: index + 5) bitShift: 8) + (self at: index + 4)) bitShift: 8) - + (self at: index + 3) bitShift: 8) + (self at: index + 2) bitShift: 8) + (self at: index + 1) bitShift: 8) + (self at: index)]]]. - bigEndian ifFalse: [ - (byte := self at: index + 7) = 0 ifFalse: [ - ^(LargePositiveInteger new: 8) - replaceFrom: 1 to: 8 with: self startingAt: index; - normalize ]. - (byte := self at: index + 6) = 0 ifFalse: [ - ^(LargePositiveInteger new: 7) - replaceFrom: 1 to: 7 with: self startingAt: index; - normalize ]. - (byte := self at: index + 5) = 0 ifFalse: [ - ^(LargePositiveInteger new: 6) - replaceFrom: 1 to: 6 with: self startingAt: index; - normalize ]. - (byte := self at: index + 4) = 0 ifFalse: [ - ^(LargePositiveInteger new: 5) - replaceFrom: 1 to: 5 with: self startingAt: index; - normalize ]. - (byte := self at: index + 3) <= 16r3F ifFalse: [ - ^(LargePositiveInteger new: 4) - replaceFrom: 1 to: 4 with: self startingAt: index; - normalize ]. - ^(((byte bitShift: 8) + (self at: index + 2) bitShift: 8) + (self at: index + 1) bitShift: 8) + (self at: index) ]. - (byte := self at: index) = 0 ifFalse: [ - ^(LargePositiveInteger new: 8) - digitAt: 1 put: (self at: index + 7); - digitAt: 2 put: (self at: index + 6); - digitAt: 3 put: (self at: index + 5); - digitAt: 4 put: (self at: index + 4); - digitAt: 5 put: (self at: index + 3); - digitAt: 6 put: (self at: index + 2); - digitAt: 7 put: (self at: index + 1); - digitAt: 8 put: byte; - normalize ]. - (byte := self at: index + 1) = 0 ifFalse: [ - ^(LargePositiveInteger new: 7) - digitAt: 1 put: (self at: index + 7); - digitAt: 2 put: (self at: index + 6); - digitAt: 3 put: (self at: index + 5); - digitAt: 4 put: (self at: index + 4); - digitAt: 5 put: (self at: index + 3); - digitAt: 6 put: (self at: index + 2); - digitAt: 7 put: byte; - normalize ]. - (byte := self at: index + 2) = 0 ifFalse: [ - ^(LargePositiveInteger new: 6) - digitAt: 1 put: (self at: index + 7); - digitAt: 2 put: (self at: index + 6); - digitAt: 3 put: (self at: index + 5); - digitAt: 4 put: (self at: index + 4); - digitAt: 5 put: (self at: index + 3); - digitAt: 6 put: byte; - normalize ]. - (byte := self at: index + 3) = 0 ifFalse: [ - ^(LargePositiveInteger new: 5) - digitAt: 1 put: (self at: index + 7); - digitAt: 2 put: (self at: index + 6); - digitAt: 3 put: (self at: index + 5); - digitAt: 4 put: (self at: index + 4); - digitAt: 5 put: byte; - normalize ]. - (byte := self at: index + 4) <= 16r3F ifFalse: [ - ^(LargePositiveInteger new: 4) - digitAt: 1 put: (self at: index + 7); - digitAt: 2 put: (self at: index + 6); - digitAt: 3 put: (self at: index + 5); - digitAt: 4 put: byte; - normalize ]. - ^(((byte bitShift: 8) + (self at: index + 5) bitShift: 8) + (self at: index + 6) bitShift: 8) + (self at: index + 7)! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/9/2015 20:18'! - unsignedLong64At: index put: value bigEndian: bigEndian - "Store a 64-bit unsigned integer quantity starting from the given byte index" - - | i j | - value isLarge ifTrue: [ - i := value digitLength. - bigEndian ifFalse: [ - self - replaceFrom: index - to: index + i - 1 - with: value - startingAt: 1; - replaceFrom: index + i - to: index + 7 - with: #[0 0 0 0 0 0 0 0] - startingAt: 1. - ^value ]. - j := index + 8. - i <= 7 ifTrue: [ - self - replaceFrom: index - to: j - i - 1 - with: #[0 0 0 0 0 0 0 0] - startingAt: 1 ]. - [ 1 <= i ] whileTrue: [ - self at: j - i put: (value digitAt: i). - i := i - 1 ]. - ^value ]. - bigEndian ifFalse: [ - j := index - 1. - i := value. - [ 1 <= i ] whileTrue: [ - self at: (j := j + 1) put: (i bitAnd: 16rFF). - i := i bitShift: -8 ]. - self replaceFrom: j + 1 - to: index + 7 - with: #[0 0 0 0 0 0 0 0] - startingAt: 1. - ^value ]. - j := index + 8. - i := value. - [ 1 <= i ] whileTrue: [ - self at: (j := j - 1) put: (i bitAnd: 16rFF). - i := i bitShift: -8 ]. - self replaceFrom: index - to: j - 1 - with: #[0 0 0 0 0 0 0 0] - startingAt: 1. - ^value! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/9/2015 20:28' prior: 16793638! - longAt: index bigEndian: bigEndian - "Return a 32-bit integer quantity starting from the given byte index. Use #normalize where necessary to ensure compatibility with non-30-bit SmallIntegers." - - | byte result | - bigEndian ifFalse: [ - (byte := self at: index + 3) <= 16r7F ifTrue: [ "Is the result non-negative?" - byte <= 16r3F ifTrue: [ - ^(((byte bitShift: 8) + (self at: index + 2) bitShift: 8) + (self at: index + 1) bitShift: 8) + (self at: index) ]. - ^(LargePositiveInteger new: 4) - replaceFrom: 1 - to: 4 - with: self - startingAt: index; - normalize ]. - "Negative" - byte >= 16rC0 ifTrue: [ - ^-1 - (((((byte bitShift: 8) + (self at: index + 2) bitShift: 8) + (self at: index + 1) bitXor: 16rFFFFFF) bitShift: 8) + ((self at: index) bitXor: 16rFF)) ]. - (result := LargeNegativeInteger new: 4) - digitAt: 4 put: ((self at: index + 3) bitXor: 16rFF); - digitAt: 3 put: ((self at: index + 2) bitXor: 16rFF); - digitAt: 2 put: ((self at: index + 1) bitXor: 16rFF). - (byte := ((self at: index) bitXor: 16rFF) + 1) <= 16rFF ifTrue: [ - ^result - digitAt: 1 put: byte; - normalize ]. - ^result - digitAt: 1 put: 16rFF; - - 1 "It's tempting to do the subtraction in a loop to avoid the LargeInteger creation, but it's actually slower than this." ]. - (byte := self at: index) <= 16r7F ifTrue: [ "Is the result non-negative?" - byte <= 16r3F ifTrue: [ - ^(((byte bitShift: 8) + (self at: index + 1) bitShift: 8) + (self at: index + 2) bitShift: 8) + (self at: index + 3) ]. - ^(LargePositiveInteger new: 4) - digitAt: 1 put: (self at: index + 3); - digitAt: 2 put: (self at: index + 2); - digitAt: 3 put: (self at: index + 1); - digitAt: 4 put: byte; - normalize ]. - "Negative" - 16rC0 <= byte ifTrue: [ - ^-1 - (((((byte bitShift: 8) + (self at: index + 1) bitShift: 8) + (self at: index + 2) bitXor: 16rFFFFFF) bitShift: 8) + ((self at: index + 3) bitXor: 16rFF)) ]. - (result := LargeNegativeInteger new: 4) - digitAt: 4 put: (byte bitXor: 16rFF); - digitAt: 3 put: ((self at: index + 1) bitXor: 16rFF); - digitAt: 2 put: ((self at: index + 2) bitXor: 16rFF). - (byte := ((self at: index + 3) bitXor: 16rFF) + 1) <= 16rFF ifTrue: [ - ^result - digitAt: 1 put: byte; - normalize ]. - ^result - digitAt: 1 put: 16rFF; - - 1 "It's tempting to do the subtraction in a loop to avoid the LargeInteger creation, but it's actually slower than this."! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/6/2015 17:13' prior: 16793658! - longAt: index put: value bigEndian: bigEndian - "Store a 32-bit signed integer quantity starting from the given byte index" - - | v v2 | - value isLarge ifTrue: [ - bigEndian ifFalse: [ - value positive ifTrue: [ - self - replaceFrom: index - to: index + 3 - with: value - startingAt: 1. - ^value ]. - v := 0. - [ v <= 3 and: [ (v2 := ((value digitAt: v + 1) bitXor: 16rFF) + 1) = 16r100 ] ] whileTrue: [ - self at: index + v put: 0. - v := v + 1 ]. - self at: index + v put: v2. - v := v + 1. - [ v <= 3 ] whileTrue: [ - self at: index + v put: ((value digitAt: (v := v + 1)) bitXor: 16rFF) ]. - ^value ]. - value positive ifTrue: [ - self - at: index put: (value digitAt: 4); - at: index + 1 put: (value digitAt: 3); - at: index + 2 put: (value digitAt: 2); - at: index + 3 put: (value digitAt: 1). - ^value ]. - v := 3. - [ 0 <= v and: [ (v2 := ((value digitAt: 4 - v) bitXor: 16rFF) + 1) = 16r100 ] ] whileTrue: [ - self at: index + v put: 0. - v := v - 1 ]. - self at: index + v put: v2. - [ 0 <= (v := v - 1) ] whileTrue: [ - self at: index + v put: ((value digitAt: 4 - v) bitXor: 16rFF) ]. - ^value ]. - v := value bitShift: -24. - 0 <= (v := (v bitAnd: 16r7F) - (v bitAnd: 16r80)) ifFalse: [ - v := v + 16r100 ]. - bigEndian ifFalse: [ - self - at: index put: (value bitAnd: 16rFF); - at: index + 1 put: ((value bitShift: -8) bitAnd: 16rFF); - at: index + 2 put: ((value bitShift: -16) bitAnd: 16rFF); - at: index + 3 put: v. - ^value ]. - self - at: index put: v; - at: index + 1 put: ((value bitShift: -16) bitAnd: 16rFF); - at: index + 2 put: ((value bitShift: -8) bitAnd: 16rFF); - at: index + 3 put: (value bitAnd: 16rFF). - ^value! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/6/2015 23:16' prior: 16793680! - shortAt: index bigEndian: bigEndian - "Return a 16-bit signed integer quantity starting from the given byte index" - - | result | - result := bigEndian - ifFalse: [ ((self at: index + 1) bitShift: 8) + (self at: index) ] - ifTrue: [ ((self at: index) bitShift: 8) + (self at: index + 1) ]. - result < 16r8000 ifTrue: [ ^result ]. - ^result - 16r10000! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/6/2015 23:16' prior: 16793690! - shortAt: index put: value bigEndian: bigEndian - "Store a 16-bit signed integer quantity starting from the given byte index" - - | unsignedValue | - (unsignedValue := value) < 0 ifTrue: [ - unsignedValue := unsignedValue + 16r10000 ]. - bigEndian ifFalse: [ - self - at: index + 1 put: (unsignedValue bitShift: -8); - at: index put: (unsignedValue bitAnd: 16rFF). - ^value ]. - self - at: index put: (unsignedValue bitShift: -8); - at: index + 1 put: (unsignedValue bitAnd: 16rFF). - ^value! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'eem 2/22/2016 09:20' prior: 16793700! - unsignedLongAt: index bigEndian: bigEndian - "Return a 32-bit unsigned integer quantity starting from the given byte index. Use #normalize where necessary to ensure compatibility with non-30-bit SmallIntegers." - | byte | - bigEndian ifTrue: - [((byte := self at: index) <= 16r3F - or: [SmallInteger maxVal > 1073741823]) ifTrue: - [^(((byte bitShift: 8) + (self at: index + 1) bitShift: 8) + (self at: index + 2) bitShift: 8) + (self at: index + 3)]. - ^(LargePositiveInteger new: 4) - digitAt: 1 put: (self at: index + 3); - digitAt: 2 put: (self at: index + 2); - digitAt: 3 put: (self at: index + 1); - digitAt: 4 put: byte; - normalize]. - ((byte := self at: index + 3) <= 16r3F - or: [SmallInteger maxVal > 1073741823]) ifTrue: - [^(((byte bitShift: 8) + (self at: index + 2) bitShift: 8) + (self at: index + 1) bitShift: 8) + (self at: index)]. - ^(LargePositiveInteger new: 4) - replaceFrom: 1 to: 4 with: self startingAt: index; - normalize! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/3/2015 01:33' prior: 16793720! - unsignedLongAt: index put: value bigEndian: bigEndian - "Store a 32-bit unsigned integer quantity starting from the given byte index" - - value isLarge - ifTrue: [ - bigEndian ifFalse: [ - self - replaceFrom: index - to: index + 3 - with: value - startingAt: 1. - ^value ]. - self - at: index put: (value digitAt: 4); - at: index + 1 put: (value digitAt: 3); - at: index + 2 put: (value digitAt: 2); - at: index +3 put: (value digitAt: 1) ] - ifFalse: [ - bigEndian ifFalse: [ - self - at: index put: (value bitAnd: 16rFF); - at: index + 1 put: ((value bitShift: -8) bitAnd: 16rFF); - at: index + 2 put: ((value bitShift: -16) bitAnd: 16rFF); - at: index + 3 put: (value bitShift: -24). - ^value ]. - self - at: index put: (value bitShift: -24); - at: index + 1 put: ((value bitShift: -16) bitAnd: 16rFF); - at: index + 2 put: ((value bitShift: -8) bitAnd: 16rFF); - at: index + 3 put: (value bitAnd: 16rFF) ]. - ^value! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/3/2015 01:33' prior: 16793740! - unsignedShortAt: index bigEndian: bigEndian - "Return a 16-bit unsigned integer quantity starting from the given byte index" - - bigEndian ifFalse: [ ^((self at: index + 1) bitShift: 8) + (self at: index) ]. - ^((self at: index) bitShift: 8) + (self at: index + 1) - ! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/3/2015 15:29' prior: 16793751! - unsignedShortAt: index put: value bigEndian: bigEndian - "Store a 16-bit unsigned integer quantity starting from the given byte index" - - bigEndian ifFalse: [ - self - at: index + 1 put: (value bitShift: -8); - at: index put: (value bitAnd: 16rFF). - ^value ]. - self - at: index put: (value bitShift: -8); - at: index+1 put: (value bitAnd: 16rFF). - ^value! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3008-ByteArray-UpdateToSqueak-JuanVuletich-2016Dec22-15h54m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3008] on 26 December 2016 at 2:54:38 pm'! -!Float64Array methodsFor: 'accessing' stamp: 'jmv 12/26/2016 14:53:06' prior: 16846088! - floatAt: index put: aFloat - "Store the argument (e.g., 64 bit Float) at the given index - Use the same internal representation as BoxedFloat64. I.e. a BoxedFloat64 and a Float64Array of size 1 hold the same bits. - Allow subclasses to redefine #at:put:" - - "This breaks with SmallFloat64" - "self replaceWordsFrom: index * 2 - 1 to: index * 2 with: aFloat asFloat startingAt: 1." - - "Float >>basicAt: acts as if Floats were stored in big endian format. Our instances are in platform endianess." - Smalltalk isLittleEndian - ifTrue: [ - self basicAt: index * 2 - 1 put: (aFloat basicAt: 2). - self basicAt: index * 2 put: (aFloat basicAt: 1) ] - ifFalse: [ - self basicAt: index * 2 - 1 put: (aFloat basicAt: 1). - self basicAt: index * 2 put: (aFloat basicAt: 2) ]. - ^aFloat! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3009-Float64Array-fixForSmallFloats-JuanVuletich-2016Dec26-14h53m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3009] on 27 December 2016 at 12:14:57 pm'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 12/27/2016 12:14:33' prior: 16922764! - saveAsNewVersion - "Save the image/changes using the next available version number." - " - Smalltalk saveAsNewVersion - " - | fileName newName changesName systemVersion | - self okayToSave ifFalse: [ ^ self ]. - systemVersion _ SystemVersion current. - fileName _ String streamContents: [ :strm | - strm - nextPutAll: 'Cuis'; - print: systemVersion versionMajor; - nextPut: $.; - print: systemVersion versionMinor; - nextPut: $-; - print: systemVersion highestUpdate. - Smalltalk isSpur ifTrue: [ - strm nextPutAll: '-spur'. - Smalltalk wordSize = 8 ifTrue: [ - strm nextPutAll: '-64' ]]]. - newName _ fileName, '.image'. - (DirectoryEntry smalltalkImageDirectory // newName) exists ifTrue: [ - newName _ DirectoryEntry smalltalkImageDirectory - nextNameFor: fileName - extension: 'image' ]. - changesName _ self fullNameForChangesNamed: newName. - "Check to see if there is a .changes file that would cause a problem if we saved a new .image file with the new version number" - changesName asFileEntry exists ifTrue: [ - ^ self inform: -'There is already .changes file of the desired name, -', newName, ' -curiously already present, even though there is -no corresponding .image file. Please remedy -manually and then repeat your request.' ]. - "Try to clear all user state, including all class vars, preferences, etc" - self saveAs: newName andQuit: false clearAllClassState: true! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3010-saveAsNewVersion-spur64-JuanVuletich-2016Dec27-12h14m-jmv.1.cs.st----! - -----SNAPSHOT----#(27 December 2016 12:18:17.352492 pm) Cuis5.0-3010-spur.image priorSource: 63832! - -----QUIT----#(27 December 2016 12:18:31.197719 pm) Cuis5.0-3010-spur.image priorSource: 81559! - -----STARTUP----#(27 December 2016 3:29:30.265752 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3010-spur.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3009] on 27 December 2016 at 9:51:30 am'! -!Float64Array methodsFor: 'accessing' stamp: 'jmv 12/27/2016 09:51:21' prior: 50334113! - floatAt: index put: aNumber - "Store the argument (e.g., 64 bit Float) at the given index - Use the same internal representation as BoxedFloat64. I.e. a BoxedFloat64 and a Float64Array of size 1 hold the same bits. - Allow subclasses to redefine #at:put:" - - "This breaks with SmallFloat64" - "self replaceWordsFrom: index * 2 - 1 to: index * 2 with: aFloat asFloat startingAt: 1." - - "Float >>basicAt: acts as if Floats were stored in big endian format. Our instances are in platform endianess." - | aFloat | - aFloat _ aNumber asFloat. - Smalltalk isLittleEndian - ifTrue: [ - self basicAt: index * 2 - 1 put: (aFloat basicAt: 2). - self basicAt: index * 2 put: (aFloat basicAt: 1) ] - ifFalse: [ - self basicAt: index * 2 - 1 put: (aFloat basicAt: 1). - self basicAt: index * 2 put: (aFloat basicAt: 2) ]. - ^aFloat! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3011-Float64Array-fixForSmallIntegers-JuanVuletich-2016Dec27-09h51m-jmv.1.cs.st----! - -----SNAPSHOT----#(27 December 2016 3:29:38.401581 pm) Cuis5.0-3011-spur.image priorSource: 81659! - -----QUIT----#(27 December 2016 3:29:55.295453 pm) Cuis5.0-3011-spur.image priorSource: 83053! - -----STARTUP----#(18 January 2017 10:34:48.334248 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3011-spur.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3011] on 29 December 2016 at 11:02:24 am'! - -PluggableScrollPane subclass: #HierarchicalListMorph - instanceVariableNames: 'selectedMorph getListSelector keystrokeActionSelector autoDeselect autoExpand sortingSelector getSelectionSelector setSelectionSelector menuGetter mainView highlightedMorph doubleClickSelector ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #HierarchicalListMorph category: #'Morphic-Views'! -PluggableScrollPane subclass: #HierarchicalListMorph - instanceVariableNames: 'selectedMorph getListSelector keystrokeActionSelector autoDeselect autoExpand sortingSelector getSelectionSelector setSelectionSelector menuGetter mainView highlightedMorph doubleClickSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! -!Inspector methodsFor: 'user commands' stamp: 'jmv 12/29/2016 10:58:58'! - inspectSelection - self selection inspect! ! -!ObjectExplorer methodsFor: 'user commands' stamp: 'jmv 12/29/2016 11:01:35'! - inspectSelection - self object inspect! ! -!HierarchicalListMorph methodsFor: 'events' stamp: 'jmv 12/29/2016 10:55:06'! - doubleClick: aMouseButtonEvent localPosition: localEventPosition - - doubleClickSelector ifNil: [ ^super doubleClick: aMouseButtonEvent localPosition: localEventPosition ]. - ^ self model perform: doubleClickSelector! ! -!HierarchicalListMorph methodsFor: 'initialization' stamp: 'jmv 12/29/2016 10:55:42'! - doubleClickSelector: aSymbol - doubleClickSelector _ aSymbol! ! -!PluggableListMorph methodsFor: 'initialization' stamp: 'jmv 12/29/2016 10:41:28'! - doubleClickSelector: aSymbol - doubleClickSelector _ aSymbol! ! -!HierarchicalListMorph methodsFor: 'events' stamp: 'jmv 12/29/2016 10:53:49' prior: 16853080! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - - | itemMorph | - aMouseButtonEvent hand newKeyboardFocus: self. - itemMorph _ self itemFromPoint: localEventPosition. - itemMorph ifNil: [ ^super mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition ]. - self highlightedMorph: itemMorph. - (itemMorph inToggleArea: (itemMorph internalize: (scroller internalize: localEventPosition))) - ifTrue: [ ^self toggleExpandedState: itemMorph event: aMouseButtonEvent ]. - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: #click:localPosition: - clkNHalf: nil - dblClkSel: (doubleClickSelector ifNotNil: [ #doubleClick:localPosition: ]) - dblClkNHalfSel: nil - tripleClkSel: nil! ! -!DebuggerWindow methodsFor: 'GUI building' stamp: 'jmv 12/29/2016 10:59:15' prior: 16831023! - buildMorphicWindow - "Open a full morphic debugger with the given label" - - | upperMorph receiverInspector receiverInspectorText contextVariableInspector contextVariableInspectorText bottomMorph | - - upperMorph _ PluggableListMorph - model: model - listGetter: #contextStackList - indexGetter: #contextStackIndex - indexSetter: #toggleContextStackIndex: - mainView: self - menuGetter: #contextStackMenu - keystrokeAction: #contextStackKey:from:. - - receiverInspector _ PluggableListMorph - model: model receiverInspector - listGetter: #fieldList - indexGetter: #selectionIndex - indexSetter: #toggleIndex: - mainView: self - menuGetter: #receiverFieldListMenu - keystrokeAction: #inspectorKey:from:. - receiverInspector doubleClickSelector: #inspectSelection. - receiverInspectorText _ TextModelMorph - textProvider: model receiverInspector - textGetter: #acceptedContents - textSetter: #accept: - selectionGetter: #contentsSelection. - contextVariableInspector _ PluggableListMorph - model: model contextVariablesInspector - listGetter: #fieldList - indexGetter: #selectionIndex - indexSetter: #toggleIndex: - mainView: self - menuGetter: #contextFieldListMenu - keystrokeAction: #inspectorKey:from:. - contextVariableInspector doubleClickSelector: #inspectSelection. - contextVariableInspectorText _ TextModelMorph - textProvider: model contextVariablesInspector - textGetter: #acceptedContents - textSetter: #accept: - selectionGetter: #contentsSelection. - - bottomMorph _ LayoutMorph newRow. - bottomMorph - addMorph: receiverInspector proportionalWidth: 0.2; - addAdjusterAndMorph: receiverInspectorText proportionalWidth: 0.3; - addAdjusterAndMorph: contextVariableInspector proportionalWidth: 0.2; - addAdjusterAndMorph: contextVariableInspectorText proportionalWidth: 0.3. - - self layoutMorph - addMorph: upperMorph proportionalHeight: 0.25; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.55; - addAdjusterAndMorph: bottomMorph proportionalHeight: 0.2! ! -!InspectorWindow methodsFor: 'GUI building' stamp: 'jmv 12/29/2016 11:00:06' prior: 16857200! - buildMorphicWindow - " Inspector openOn: SystemOrganization " - | contentsText list upperRow evaluatorText label | - "Build widgets. We'll assemble them below." - list _ PluggableListMorph - model: model - listGetter: #fieldList - indexGetter: #selectionIndex - indexSetter: #toggleIndex: - mainView: self - menuGetter: #fieldListMenu - keystrokeAction: #inspectorKey:from:. - list doubleClickSelector: #inspectSelection. - contentsText _ TextModelMorph - textProvider: model - textGetter: #acceptedContents - textSetter: #accept: - selectionGetter: #contentsSelection. - evaluatorText _ (TextModelMorph textProvider: model) - askBeforeDiscardingEdits: false. - "Upper row has two widgets, side by side: the list of variables at the left side, and the variable contents pane at the right side." - upperRow _ LayoutMorph newRow. - upperRow - addMorph: list proportionalWidth: 0.3; - addAdjusterAndMorph: contentsText proportionalWidth: 0.7. - "Inspector Window has two rows: At the top, the one we just bult. Below it, the evaluation pane." - self layoutMorph - addMorph: upperRow proportionalHeight: 0.7; - addAdjusterAndMorph: evaluatorText proportionalHeight: 0.3. - "Set label" - label _ [model object printStringLimitedTo: 64] - on: UnhandledError - do: [:ex | ex return: model object class printString, ' (printing failed)']. - (label includesSubString: model object class name) - ifFalse: [label _ model object class name, ': ', label]. - self setLabel: label! ! -!ObjectExplorerWindow methodsFor: 'GUI building' stamp: 'jmv 12/29/2016 11:00:46' prior: 16883288! -buildMorphicWindow - - | textMorph | - listMorph _ HierarchicalListMorph - model: model - listGetter: #getList - indexGetter: #getCurrentSelection - indexSetter: #noteNewSelection: - mainView: self - menuGetter: #genericMenu - keystrokeAction: #explorerKey:from:. - listMorph autoDeselect: false. - listMorph doubleClickSelector: #inspectSelection. - textMorph _ (TextModelMorph textProvider: model) - askBeforeDiscardingEdits: false. - self layoutMorph - addMorph: listMorph proportionalHeight: 0.8; - addAdjusterAndMorph: textMorph proportionalHeight: 0.2. - self setLabel: (model rootObject printStringLimitedTo: 64)! ! -!ObjectExplorerWindow methodsFor: 'menu commands' stamp: 'jmv 12/29/2016 10:50:28' prior: 16883479! - openWeightExplorer - "Create and schedule a Weight Explorer on the receiver's model's currently selected object." - - ^WeightTracer openExplorerOn: model object! ! - -PluggableScrollPane subclass: #HierarchicalListMorph - instanceVariableNames: 'selectedMorph getListSelector keystrokeActionSelector autoDeselect autoExpand sortingSelector getSelectionSelector setSelectionSelector menuGetter mainView highlightedMorph doubleClickSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #HierarchicalListMorph category: #'Morphic-Views'! -PluggableScrollPane subclass: #HierarchicalListMorph - instanceVariableNames: 'selectedMorph getListSelector keystrokeActionSelector autoDeselect autoExpand sortingSelector getSelectionSelector setSelectionSelector menuGetter mainView highlightedMorph doubleClickSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3012-DoubleClickOpensInspector-JuanVuletich-2016Dec29-10h36m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3012] on 29 December 2016 at 11:30:18 am'! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 12/29/2016 11:29:52' prior: 16902537! - parseExternalCall - self scanNext. - self failWhen: currentToken isNil. - self scanPast: #externalCallType. - currentToken = '*' - ifTrue: [self scanPast: #externalCallTypePointerIndicator]. - currentTokenFirst isDigit - ifTrue: [self scanPast: #integer] - ifFalse: [ - self failUnless: currentTokenFirst == $'. - self parseString]. - self failUnless: currentTokenFirst == $(. - self scanPast: #leftParenthesis. - [currentTokenFirst ~~ $)] - whileTrue: [ - self failWhen: currentToken isNil. - self scanPast: #externalCallType. - currentToken = '*' - ifTrue: [self scanPast: #externalCallTypePointerIndicator]]. - self scanPast: #rightParenthesis. - currentToken = 'module:' - ifTrue: [ - self scanPast: #module. - self failUnless: currentTokenFirst == $'. - self parseString]. - self failUnless: currentToken = '>'. - self scanPast: #primitiveOrExternalCallEnd! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3013-Shout-ExternalCallFix-JuanVuletich-2016Dec29-11h29m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3013] on 29 December 2016 at 3:36:31 pm'! -!CompiledMethod methodsFor: 'file in/out' stamp: 'jmv 12/29/2016 15:25:13' prior: 16820644! - storeDataOn: aDataStream - "Store myself on a DataStream. I am a mixture of objects and raw data bytes. Only use this for blocks. Normal methodDictionaries should not be put out using ReferenceStreams. Their fileOut should be attached to the beginning of the file." - - | byteLength lits | - "No inst vars of the normal type" - byteLength _ self basicSize. - aDataStream - beginInstance: self class - size: byteLength. - lits _ self numLiterals + 1. "counting header" - 1 to: lits do: - [:ii | aDataStream nextPut: (self objectAt: ii)]. - lits*Smalltalk wordSize+1 to: byteLength do: - [:ii | aDataStream byteStream nextPut: (self basicAt: ii)]. - "write bytes straight through to the file"! ! -!DataStream methodsFor: 'write and read' stamp: 'jmv 12/29/2016 15:27:40' prior: 16827456! - readMethod - "PRIVATE -- Read the contents of an arbitrary instance. - ASSUMES: readDataFrom:size: sends me beginReference: after it - instantiates the new object but before reading nested objects. - NOTE: We must restore the current reference position after - recursive calls to next. - Let the instance, not the class read the data. " - | instSize refPosn newClass className xxHeader nLits byteCodeSizePlusTrailer newMethod lits | - - instSize _ (byteStream nextUnsignedInt32BigEndian: true) - 1. - refPosn _ self getCurrentReference. - className _ self next. - newClass _ Smalltalk at: className asSymbol. - - xxHeader _ self next. - "nArgs _ (xxHeader >> 24) bitAnd: 16rF." - "nTemps _ (xxHeader >> 18) bitAnd: 16r3F." - "largeBit _ (xxHeader >> 17) bitAnd: 1." - nLits _ (xxHeader >> 9) bitAnd: 16rFF. - "primBits _ ((xxHeader >> 19) bitAnd: 16r600) + (xxHeader bitAnd: 16r1FF)." - byteCodeSizePlusTrailer _ instSize - (newClass instSize "0") - (nLits + 1 * Smalltalk wordSize). - - newMethod _ newClass - newMethod: byteCodeSizePlusTrailer - header: xxHeader. - - self setCurrentReference: refPosn. "before readDataFrom:size:" - self beginReference: newMethod. - lits _ newMethod numLiterals + 1. "counting header" - 2 to: lits do: - [:ii | newMethod objectAt: ii put: self next]. - lits*Smalltalk wordSize+1 to: newMethod basicSize do: - [:ii | newMethod basicAt: ii put: byteStream next]. - "Get raw bytes directly from the file" - self setCurrentReference: refPosn. "before returning to next" - ^ newMethod! ! -!DataStream methodsFor: 'other' stamp: 'jmv 12/29/2016 15:36:22' prior: 16827907! - vacantRef - "Answer the magic 32-bit constant we use ***ON DISK*** as a stream 'reference - position' to identify a reference that's not yet filled in. This must be a - value that won't be used as an ordinary reference. Cf. outputReference: and - readReference. -- - NOTE: We could use a different type ID for vacant-refs rather than writing - object-references with a magic value. (The type ID and value are - overwritten by ordinary object-references when weak refs are fullfilled.)" - - "In 32 bit Cuis it was:" - "^ SmallInteger maxVal" - - "Use that very same value even if in 64 bit Cuis. - This means that DataStreams are limited to 1GibiBytes in size." - ^16r3FFFFFFF! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3014-DataStream-FixFor64Bits-JuanVuletich-2016Dec29-15h19m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3000] on 10 December 2016 at 10:41:46 am'! -!Scanner methodsFor: 'multi-character scans' stamp: 'jmv 12/10/2016 01:38:21'! - xBacktick - "Smalltalk code evaluated at compile time as a literal." - - self step. - buffer reset. - [hereChar == $` - and: [aheadChar == $` - ifTrue: [self step. false] - ifFalse: [true]]] - whileFalse: [ - buffer nextPut: self step. - (hereChar = Scanner doItCharacterValue asCharacter and: [source atEnd]) - ifTrue: [^self offEnd: 'Unmatched back quote']]. - self step. - token _ Compiler evaluate: buffer contents. - tokenType _ #literal! ! -!Character methodsFor: 'testing' stamp: 'jmv 12/10/2016 01:26:44' prior: 16800539! - isValidInIdentifiers - "Can c be part of an identifier? (unary or keyword selector, or variable name)" - - ^self isAlphaNumeric or: [ #( $_ ) statePointsTo: self ]! ! -!CompiledMethod methodsFor: 'comparing' stamp: 'jmv 12/10/2016 01:27:06' prior: 16819629! - = method - | numLits lit1 lit2 | - - "Any object is equal to itself" - self == method ifTrue: [ ^ true ]. - - "Answer whether the receiver implements the same code as the - argument, method." - (method is: #CompiledMethod) ifFalse: [ ^false ]. - self size = method size ifFalse: [ ^false ]. - self header = method header ifFalse: [ ^false ]. - self initialPC to: self endPC do: [ :i | - (self at: i) = (method at: i) ifFalse: [ ^false ]]. - (numLits _ self numLiterals) ~= method numLiterals ifTrue: [ ^false ]. - - "Dont bother checking FFI and named primitives'' - jmv: Does this make any sense? - (#(117 120) includes: self primitive) ifTrue: [^ true]." - - "properties" - (self properties analogousCodeTo: method properties) ifFalse: [ - ^false ]. - - "#penultimateLiteral is selector (or properties, just compared, above) - Last literal is #methodClass. - Don't compare them. Two methods might be equal even if they have different selector (or none at all) - or are installed in different classes (or none at all)" - 1 to: numLits-2 do: [ :i | - lit1 _ self literalAt: i. - lit2 _ method literalAt: i. - lit1 = lit2 ifFalse: [ - (i = 1 and: [ #(117 120) includes: self primitive ]) - ifTrue: [ - lit1 isArray - ifTrue: [ - (lit2 isArray and: [ lit1 allButLast = lit2 allButLast ]) ifFalse: [ - ^false ]] - ifFalse: [ "ExternalLibraryFunction" - (lit1 analogousCodeTo: lit2) ifFalse: [ - ^false ]]] - ifFalse: [ - lit1 isFloat - ifTrue: [ - "Floats match if values are close, due to roundoff error." - (lit1 closeTo: lit2) ifFalse: [ ^false ]. - self flag: 'just checking'. self halt ] - ifFalse: [ - "any other discrepancy is a failure" - ^ false ]]]]. - ^true! ! -!Scanner class methodsFor: 'cached class state' stamp: 'jmv 12/10/2016 01:26:17' prior: 16904329! - initTypeTable - | newTable | - newTable := Array new: 256 withAll: #xIllegal. "default" - newTable atAll: #(9 10 12 13 32 ) put: #xDelimiter. "tab lf ff cr space" - - 1 to: 255 - do: [:index | - (Character numericValue: index) isValidInIdentifiers - ifTrue: [ - "Digits and $_ are overwritten later" - newTable at: index put: #xLetter ]]. - - newTable atAll: ($0 numericValue to: $9 numericValue) put: #xDigit. - newTable atAll: '!!%&+-*/\±×÷¬­¯,<=>”•–—˜™š›œ«»?@~€‚ƒŽ‘’“žŸ°·' asByteArray put: #xBinary. - - newTable at: Scanner doItCharacterValue put: #doIt. - newTable at: $" numericValue put: #xDoubleQuote. - newTable at: $# numericValue put: #xLitQuote. - newTable at: $$ numericValue put: #xDollar. - newTable at: $' numericValue put: #xSingleQuote. - newTable at: $` numericValue put: #xBacktick. - newTable at: $: numericValue put: #xColon. - newTable at: $( numericValue put: #leftParenthesis. - newTable at: $) numericValue put: #rightParenthesis. - newTable at: $. numericValue put: #period. - newTable at: $; numericValue put: #semicolon. - newTable at: $[ numericValue put: #leftBracket. - newTable at: $] numericValue put: #rightBracket. - newTable at: ${ numericValue put: #leftBrace. - newTable at: $} numericValue put: #rightBrace. - newTable at: $^ numericValue put: #upArrow. - newTable at: $_ numericValue put: #xUnderscore. - newTable at: $| numericValue put: #verticalBar. - TypeTable := newTable "bon voyage!!" - - " - Scanner initTypeTable - "! ! -!SHParserST80 methodsFor: 'scan' stamp: 'jmv 12/10/2016 01:42:02' prior: 16901958! - scanWhitespace - | c | - - [c := self currentChar. - c notNil and: [c isSeparator or: [c == $`]]] - whileTrue: [sourcePosition := sourcePosition + 1]. - c == $" ifTrue: [self scanComment]! ! -!SHParserST80 methodsFor: 'character testing' stamp: 'jmv 12/10/2016 10:24:38' prior: 16902078! - isBinarySelectorCharacter: aCharacter - - aCharacter isValidInIdentifiers ifTrue: [^false]. - aCharacter isSeparator ifTrue: [^false]. - - ('"#$'':().;[]{}_`' includes: aCharacter) - ifTrue:[^false]. - aCharacter numericValue = Scanner doItCharacterValue ifTrue: [^false "the doIt char"]. - aCharacter numericValue = 0 ifTrue: [^false]. - "Any other char is ok as a binary selector char." - ^true! ! - -Scanner removeSelector: #scanStringStruct! - -Scanner removeSelector: #scanStringStruct! - -Scanner removeSelector: #scanStringStruct:! - -Scanner removeSelector: #scanStringStruct:! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Scanner initTypeTable! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3015-Backticks-JuanVuletich-2016Dec10-10h41m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3015] on 29 December 2016 at 4:06:32 pm'! -!LiteralNode methodsFor: 'printing' stamp: 'jmv 12/29/2016 16:06:13' prior: 16865098! - printOn: aStream indent: level - - key isVariableBinding - ifTrue: [ - key key isNil - ifTrue: [ - aStream nextPutAll: '###'; nextPutAll: key value soleInstance name ] - ifFalse: [ - aStream nextPutAll: '##'; nextPutAll: key key ]] - ifFalse: [ - key isLiteral - ifTrue: [ key storeOn: aStream ] - ifFalse: [ - "Need to generate code for stuff that is in a CompiledMethod literal - but is not understood as a literal by the Compiler. - Well, then it is because it was generated using backticks!!" - aStream nextPut: $`. - key storeOn: aStream. - aStream nextPut: $`. - ] - ]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3016-Backticks-SupportInDecompiler-JuanVuletich-2016Dec29-15h57m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3016] on 30 December 2016 at 10:57:00 am'! -!Scanner methodsFor: 'multi-character scans' stamp: 'jmv 12/30/2016 10:29:16' prior: 50334661! - xBacktick - "Smalltalk code evaluated at compile time as a literal." - - self step. - buffer reset. - [hereChar == $` - and: [aheadChar == $` - ifTrue: [self step. false] - ifFalse: [true]]] - whileFalse: [ - buffer nextPut: self step. - (hereChar = Scanner doItCharacterValue asCharacter and: [source atEnd]) - ifTrue: [^self offEnd: 'Unmatched back quote']]. - self step. - token _ [ Compiler evaluate: buffer contents ] - on: SyntaxErrorNotification, UndeclaredVariableReference, Error - do: [ :ex | - ex class caseOf: { - [ SyntaxErrorNotification ] -> [ - self notify: 'Can not compile: ', ex errorMessage at: mark]. - [ UndeclaredVariableReference ] -> [ - self notify: 'Can not compile: Variable ''', ex varName, ''' is not declared' at: mark ] - } otherwise: [ - self notify: 'Can not evaluate code: ', ex description at: mark ]]. - tokenType _ #literal! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3017-Backticks-betterErrorMessages-JuanVuletich-2016Dec30-10h56m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3016] on 30 December 2016 at 11:00:38 am'! -!Editor class methodsFor: 'class initialization' stamp: 'jmv 12/30/2016 11:00:14' prior: 16836909! - initialize - " - Editor initialize - " - self withAllSubclassesDo: [ :c | - c basicInitialize ]! ! -!TextEditor methodsFor: 'editing keys' stamp: 'jmv 12/30/2016 10:34:01' prior: 16931735! - enclose: aKeyboardEvent - "Insert or remove bracket characters around the current selection." - "This is a user command, and generates undo" - - | left right startIndex stopIndex oldSelection which | - startIndex _ self startIndex. - stopIndex _ self stopIndex. - oldSelection _ self selection. - which _ '([<{"''`' indexOf: aKeyboardEvent keyCharacter ifAbsent: [ ^true ]. - left _ '([<{"''`' at: which. - right _ ')]>}"''`' at: which. - ((startIndex > 1 and: [stopIndex <= model textSize]) - and: [ (model actualContents at: startIndex-1) = left and: [(model actualContents at: stopIndex) = right]]) - ifTrue: [ - "already enclosed; strip off brackets" - self selectFrom: startIndex-1 to: stopIndex. - self replaceSelectionWith: oldSelection] - ifFalse: [ - "not enclosed; enclose by matching brackets" - self replaceSelectionWith: - (Text string: (String with: left) attributes: emphasisHere), - oldSelection, - (Text string: (String with: right) attributes: emphasisHere). - self selectFrom: startIndex+1 to: stopIndex]. - ^true! ! -!TextEditor class methodsFor: 'keyboard shortcut tables' stamp: 'jmv 12/30/2016 10:33:45' prior: 16933087! - basicCmdShortcutsSpec - " - Editor initialize - " - - "arranged in QWERTY keyboard order" - ^#( - #( $( #enclose: 'Enclose within ( and ), or remove enclosing ( and )') - #( $[ #enclose: 'Enclose within [ and ], or remove enclosing [ and ]') - #( ${ #enclose: 'Enclose within { and }, or remove enclosing { and }') - #( $' #enclose: 'Enclose within single quotes, or remove enclosing single quotes') - #( $" #enclose: 'Enclose within double quotes, or remove enclosing double quotes') - #( $` #enclose: 'Enclose within backticks, or remove enclosing backticks') - #( $< #enclose: 'Enclose within < and >, or remove enclosing < and >') - - #( $a #selectAll: 'Select all') - #( $f #find: 'Find') - #( $g #findAgain: 'Find again') - #( $h #help: 'Open this help') - #( $j #setSearchString: 'Set selection as search string for find again') - - #( $z #undo: 'Undo (multiple levels)') - #( $x #cut: 'Cut selection and store it in the Clipboard') - #( $c #copySelection: 'Copy selection to the Clipboard') - #( $v #paste: 'Paste Clipboard contents') - - #( $R #indent: 'Indent (move selection one tab-stap right)') - #( $Y #makeUppercase: 'Force selection to uppercase') - #( $U #changeLineEndsToLf: 'Convert line endings to LF characters (Cuis convention) in selection') - - #( $H #cursorTopHome: 'Move cursor to start of text') - #( $L #outdent: 'Outdent (move selection one tab-stop left)') - - #( $Z #redo: 'Redo (multiple levels)') - #( $X #makeLowercase: 'Force selection to lowercase') - #( $C #compareToClipboard: 'Compare argument to clipboard') - - #( $ #selectWord: 'Select the current word as with double clicking') - )! ! -!SmalltalkEditor methodsFor: 'new selection' stamp: 'jmv 12/30/2016 10:36:10' prior: 16910578! - selectWord - "Select delimited text or word--the result of double-clicking." - - | leftDelimiters rightDelimiters | - "Warning. Once me (jmv) added Character crCharacter to the delimiters, to make double-click at and of line select whole line. - This had the bad effect that if a class name is the last word of a line, double-click would correctly select it, but after that, - doing ctrl-b to browse it would select the whole line..." - leftDelimiters _ '([{<|''"`'. - rightDelimiters _ ')]}>|''"`'. - ^self selectWordLeftDelimiters: leftDelimiters rightDelimiters: rightDelimiters! ! - -Editor initialize! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3018-Backticks-editorSupport-JuanVuletich-2016Dec30-10h57m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3016] on 30 December 2016 at 11:01:51 am'! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 12/30/2016 10:51:03'! - parseBacktick - self enterBlock. - self scanPast: #backtick. - currentTokenFirst == $| ifTrue: [self parseBlockTemporaries]. - self parseStatementList. - self failUnless: currentTokenFirst == $`. - self scanPast: #backtick. - self leaveBlock! ! -!SHParserST80 methodsFor: 'scan' stamp: 'tween 2/17/2007 14:51' prior: 50334792! - scanWhitespace - | c | - - [c := self currentChar. - c notNil and: [c isSeparator]] - whileTrue: [sourcePosition := sourcePosition + 1]. - c == $" ifTrue: [self scanComment]! ! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 12/30/2016 10:51:08' prior: 16902861! - parseTerm - self failWhen: currentToken isNil. - currentTokenFirst == $( - ifTrue: [ - bracketDepth := bracketDepth + 1. - self scanPast: #leftParenthesis level: bracketDepth. - self parseExpression. - self failUnless: currentTokenFirst == $). - self scanPast: #rightParenthesis level: bracketDepth. - bracketDepth := bracketDepth - 1. - ^self ]. - currentTokenFirst == $[ ifTrue: [^self parseBlock]. - currentTokenFirst == $` ifTrue: [^self parseBacktick]. - currentTokenFirst == ${ - ifTrue: [ - self scanPast: #leftBrace. - self parseBraceArray. - ^self ]. - self isName ifTrue: [^self scanPast: (self resolve: currentToken)]. - self parseLiteral: false! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3019-Backticks-BetterShoutSupport-JuanVuletich-2016Dec30-11h00m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3019] on 30 December 2016 at 11:46:58 am'! -!SHTextStylerST80 methodsFor: 'private' stamp: 'jmv 12/30/2016 11:44:19' prior: 50332635! - setAttributesFromRanges: ranges - - formattedText removeAttributesThat: [ :attribute | attribute isForShout ]. - - "Optimize for mutation speed unless method is really large but with very few distict elements: - Source code that includes just big literals is better served by conventional Text+RunArray" - "Do it only if we are not breaking textModel!! (for instance, StyledTextEditor asks for formatting just sections, not whole #actualContents)." - formattedText == textModel actualContents ifTrue: [ - (formattedText size > 2000 and: [ ranges size < 50 ]) ifFalse: [ - formattedText _ formattedText optimizedForMutationSpeed. - textModel basicActualContents: formattedText ]]. - - ranges do: [ :range | - - "Smalltalk text styling" - (self attributesFor: range rangeType) ifNotNil: [ :attributes | - attributes do: [ :each | - formattedText addAttribute: each from: range start to: range end ]]. - - "Show as subscripts if appropriate." - classOrMetaClass ifNotNil: [ - classOrMetaClass theNonMetaClass lastUnderscoreMeansSubscript ifTrue: [ - (#( instVar classVar globalVar workspaceVar poolConstant - patternArg methodArg patternTempVar tempVar - blockPatternArg blockArg blockPatternTempVar blockTempVar - incompleteIdentifier undefinedIdentifier) pointsTo: range rangeType ) - ifTrue: [ - formattedText lastIndexOf: $_ startingAt: range end endingAt: range start do: [ :i | - formattedText addAttribute: ShoutTextEmphasis subscript from: i to: range end ] ]]]]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3020-AvoidUnwantedSubscriptInClassDefinitions-JuanVuletich-2016Dec30-11h45m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3020] on 2 January 2017 at 2:27:29 pm'! -!Preferences class methodsFor: 'personalization' stamp: 'jmv 1/2/2017 14:18:06'! - usePreDebugWindow - ^ self - valueOfFlag: #usePreDebugWindow - ifAbsent: [ false ].! ! -!SystemWindow methodsFor: 'open/close' stamp: 'jmv 1/2/2017 14:11:03'! - initialFrameIn: aWorld - ^RealEstateAgent initialFrameFor: self world: aWorld! ! -!DebuggerWindow methodsFor: 'GUI building' stamp: 'jmv 1/2/2017 14:13:23'! - initialFrameIn: aWorld - | e | - e _ self runningWorld morphExtent. - ^(0@0 corner: e) insetBy: e // 10! ! -!SystemWindow methodsFor: 'open/close' stamp: 'jmv 1/2/2017 14:11:12' prior: 16926575! - openInWorld: aWorld - "This msg and its callees result in the window being activeOnlyOnTop" - | frameRect | - frameRect _ self initialFrameIn: aWorld. - self morphExtent: frameRect extent. - aWorld addMorph: self position: frameRect topLeft. - "Do it deferred. Was needed for text cursor to start blinking if (Preferences disable: #focusFollowsMouse) " - WorldState addDeferredUIMessage: [ self activate ]! ! -!PreDebugWindow class methodsFor: 'instance creation' stamp: 'jmv 1/2/2017 14:19:05' prior: 16892694! - open: model label: aString message: messageString - | window | - Preferences usePreDebugWindow - ifTrue: [ - window _ self new. - window - model: model; - buildMorphicWindowMessage: messageString print. - aString ifNotNil: [ window setLabel: aString ]. - window openInWorld ] - ifFalse: [ - model openFullMorphicLabel: aString ]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3021-DebuggerUsabilityEnh-JuanVuletich-2017Jan02-14h27m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3021] on 3 January 2017 at 9:34:24 pm'! -!WriteStream methodsFor: 'accessing' stamp: 'jmv 1/3/2017 21:22:43'! - nextPutAllString: aString withAttributes: attributesArray - - | newEnd | - (self isCompatibleWithContents: aString) - ifFalse: [ ^ super nextPutAllString: aString withAttributes: attributesArray ]. - - newEnd _ position + aString size. - newEnd > writeLimit ifTrue: [ - self growTo: newEnd + 10]. - - collection - replaceFrom: position+1 - to: newEnd - withString: aString - attributes: attributesArray - startingAt: 1. - position _ newEnd! ! -!WriteStream methodsFor: 'private' stamp: 'jmv 1/3/2017 21:21:34'! - isCompatibleWithContents: aCollection - - collection class == aCollection class - ifTrue: [ ^ true ]. - - (aCollection isString and: [ collection is: #Text]) - ifTrue: [ ^ true ]. - - ^ false! ! -!PositionableStream methodsFor: 'testing' stamp: 'jmv 1/3/2017 10:57:48' prior: 16891569! - isText - "Return true if the receiver is a Text stream" - ^collection is: #Text! ! -!WriteStream methodsFor: 'accessing' stamp: 'jmv 1/3/2017 21:22:51' prior: 16946406! - nextPutAll: aCollection - - | newEnd | - (self isCompatibleWithContents: aCollection) - 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.! ! -!WriteStream methodsFor: 'private' stamp: 'jmv 1/3/2017 10:57:15' prior: 16946621! - withAttribute: aTextAttribute do: streamBlock - | pos1 val | - - (collection is: #Text) ifFalse: [ - ^streamBlock value ]. - - pos1 _ self position. - val _ streamBlock value. - collection addAttribute: aTextAttribute from: pos1+1 to: self position. - ^ val! ! -!WriteStream methodsFor: 'private' stamp: 'jmv 1/3/2017 10:57:19' prior: 16946627! - withAttributes: attributes do: streamBlock - | pos1 val | - - (collection is: #Text) ifFalse: [ - ^streamBlock value ]. - - pos1 _ self position. - val _ streamBlock value. - attributes do: [:attribute | - collection - addAttribute: attribute - from: pos1 + 1 - to: self position]. - ^ val! ! - -Text class removeSelector: #streamContents:! - -Text class removeSelector: #streamContents:! - -Smalltalk removeClassNamed: #TextStream! - -Smalltalk removeClassNamed: #TextStream! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3022-TextStream-removal-JuanVuletich-2017Jan03-21h10m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3022] on 4 January 2017 at 10:42:00 am'! -!SmallInteger methodsFor: 'system primitives' stamp: 'jmv 1/4/2017 10:35:09' prior: 16909090! - digitAt: n - "Answer the value of an indexable field in the receiver. LargePositiveInteger uses bytes of base two number, and each is a 'digit' base 256. Fail if the argument (the index) is not an Integer or is out of bounds." - n > Smalltalk wordSize ifTrue: [^ 0]. - self < 0 - ifTrue: - [self = SmallInteger minVal ifTrue: [ - "Can't negate minVal -- treat specially" - ^ Smalltalk wordSize = 4 - ifTrue: [ #(0 0 0 64) at: n ] - ifFalse: [ #(0 0 0 0 0 0 0 16) at: n ]]. - ^ ((0-self) bitShift: (1-n)*8) bitAnd: 16rFF] - ifFalse: [^ (self bitShift: (1-n)*8) bitAnd: 16rFF]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3023-SmallInteger-digitAt-fixFor64Bits-JuanVuletich-2017Jan04-10h41m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3022] on 4 January 2017 at 10:46:32 am'! - -Integer class removeSelector: #byte1:byte2:byte3:byte4:! - -Integer class removeSelector: #byte1:byte2:byte3:byte4:! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3024-Integer-from4Bytes-removal-JuanVuletich-2017Jan04-10h44m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3024] on 6 January 2017 at 10:05:27 am'! -!WeakArray class methodsFor: 'system startup' stamp: 'jmv 1/6/2017 09:56:14'! -startUp - "Do it even if just continuing after image snapshot" - self restartFinalizationProcess! ! -!SystemDictionary methodsFor: 'startup' stamp: 'jmv 1/6/2017 09:59:32'! - doStartUp: isARealStartup - " - isARealStartup - true: system is coming up (VM and image just started) - false: we have just saved an image snapshot, but didn't quit. - " - - "Here, startup begins!!" - Cursor normal activateCursor. - self setGCParameters. - isARealStartup ifTrue: [ - self clearExternalObjects ]. - self readCommandLineArguments. - self processStartUpList: isARealStartup. - isARealStartup ifTrue: [ - self setPlatformPreferences. - self setStartupStamp ]! ! -!Behavior methodsFor: 'system startup' stamp: 'jmv 1/6/2017 09:52:14' prior: 16785037! - startUp - "This message is sent to registered classes when the system is coming up, or after an image save."! ! -!Behavior methodsFor: 'system startup' stamp: 'jmv 1/6/2017 09:53:18' prior: 16785042! - startUp: isARealStartup - "This message is sent to registered classes, with isARealStartup = true when the system is coming up, - and with isARealStartup = false after a snapshot (image save, no quit). - Classes caring about the difference should reimplement this method." - - ^ self startUp! ! -!WeakArray class methodsFor: 'class initialization' stamp: 'jmv 1/6/2017 09:49:16' prior: 16943683! - initialize - " - WeakArray initialize. - SystemDictionary initialize. - " - - self restartFinalizationProcess! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 1/6/2017 09:53:30' prior: 16922685! - processStartUpList: isARealStartup - "Send #startUp to each class that needs to run initialization after a snapshot." - - EndianCache _ self calcEndianness. - self send: #startUp: toClassesNamedIn: StartUpList with: isARealStartup! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 1/6/2017 09:55:41' prior: 16922813! - send: startUpOrShutDown toClassesNamedIn: startUpOrShutDownList with: argument - "Send the message #startUp: or #shutDown: to each class named in the list. - The argument indicates if the system is about to quit (for #shutDown:) or if - the image is ia real startup (or just continue after image save) (for #startUp:). - If any name cannot be found, then remove it from the list." - - | removals class | - removals _ OrderedCollection new. - startUpOrShutDownList do: - [:name | - class _ self at: name ifAbsent: nil. - class - ifNil: [removals add: name] - ifNotNil: [ - class isInMemory ifTrue: [ - class perform: startUpOrShutDown with: argument]]]. - - "Remove any obsolete entries, but after the iteration" - "Well, not. Better just ignore them. Maybe it is stuff, like SoundPlayer, that was moved to optional packages, and can be loaded again anytime." - "startUpOrShutDownList removeAll: removals"! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 1/6/2017 09:59:34' prior: 16922908! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag -"WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " -| activeProc | -activeProc _ Processor activeProcess. -[ - | isARealStartup world reopenTranscript | - self logSapshot: save andQuit: quit. - - reopenTranscript _ false. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | each isInWorld ifTrue: [ each delete. reopenTranscript _ true ]]. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - - - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - - "Cosas que levanto explicitamente abajo" - world _ ProjectX ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "world _ clearAllStateFlag ifFalse: [ ProjectX ui ]." - ProjectX stopUIProcess. - activeProc isTerminated ifFalse: [ - activeProc terminate ]. - - "Clean Globals" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: nil. - Smalltalk closeSourceFiles. Smalltalk at: #SourceFiles put: nil. - Smalltalk allClassesDo: [ :cls | cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ Smalltalk printStuffToCleanOnImageSave ]. - - - "Do image save & quit as apropriate" - Cursor write activateCursor. - save - ifTrue: [ - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - - - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: (DisplayScreen extent: 1024@768 depth: 32). - Smalltalk at: #SourceFiles put: (Array new: 2). - Smalltalk openSourceFiles. - - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - - - ProjectX spawnNewMorphicProcessFor: (world ifNil: [ PasteUpMorph newWorld ]). - - reopenTranscript ifTrue: [ - WorldState addDeferredUIMessage: [ - TranscriptWindow openTranscript ]]. - " - WorldState addDeferredUIMessage: [ - world fullRepaintNeeded ]. - " - - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - WorldState addDeferredUIMessage: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]. - -] forkAt: Processor timingPriority-1 named: 'Startup process'.! ! - -SystemDictionary removeSelector: #startup:! - -SystemDictionary removeSelector: #startup:! - -WeakArray class removeSelector: #startUp:! - -WeakArray class removeSelector: #startUp:! - -WeakArray initialize! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3025-RestartFinalizationAfterImageSave-JuanVuletich-2017Jan06-09h49m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3025] on 13 January 2017 at 9:55:29 am'! -!LargePositiveInteger methodsFor: 'bit manipulation' stamp: 'jmv 1/13/2017 09:39:07'! - bitXor: arg - "Primitive 36 deals with only 64-bit values (up to 8 byte LargeIntegers). - The inherited deals with - arbitrary sized large integers, but is much slower. - This method gives a performance improvement for integers using 32 to 64 bits on 32 bit VMs, - but only for 62 to 64 bits on 64 bits VMs. - See http://forum.world.st/Integer-arithmetic-and-bit-operations-in-Squeak-and-Pharo-32bit-amp-64bit-tc4928994.html#none - " - - - ^super bitXor: arg! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3026-LargeInteger-bitXor-performanceImprov-JuanVuletich-2017Jan13-09h54m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3025] on 13 January 2017 at 9:55:58 am'! -!SHParserST80 methodsFor: 'parse' stamp: 'ul 10/12/2010 02:43'! - parseStringOrSymbol - - currentTokenFirst == $' ifTrue: [ ^self parseString ]. - currentTokenFirst == $# ifTrue: [ ^self parseSymbol ]. - self error! ! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 1/13/2017 09:53:38' prior: 16902728! - parsePrimitive - self scanNext. - currentTokenFirst isDigit - ifTrue: [self scanPast: #integer] - ifFalse: [ - self failUnless: currentTokenFirst == $'. - self parseString. - currentToken = 'module:' - ifTrue: [ - self scanPast: #module. - self failUnless: currentTokenFirst == $'. - self parseString]]. - currentToken = 'error:' ifTrue: [ - self scanPast: #primitive. "there's no rangeType for error" - self isName - ifTrue: [ self scanPast: #patternTempVar ] - ifFalse: [ self parseStringOrSymbol ] ]. - self failUnless: currentToken = '>'. - self scanPast: #primitiveOrExternalCallEnd! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3027-ShoutFix-JuanVuletich-2017Jan13-09h55m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3025] on 13 January 2017 at 9:59:33 am'! -!Float methodsFor: 'private' stamp: 'jmv 1/13/2017 09:57:46' prior: 16845694! - replaceWordsFrom: 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." - - - self primitiveFailed! ! -!LargePositiveInteger methodsFor: 'system primitives' stamp: 'jmv 1/13/2017 09:58:53' prior: 16862796! - replaceFrom: start to: stop with: replacement startingAt: repStart - "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." - - - super replaceFrom: start to: stop with: replacement startingAt: repStart! ! -!String methodsFor: 'private' stamp: 'jmv 1/13/2017 09:58:04' prior: 16917188! - replaceFrom: start to: stop with: replacement startingAt: repStart - "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." - - - super replaceFrom: start to: stop with: replacement startingAt: repStart! ! -!Array methodsFor: 'private' stamp: 'jmv 1/13/2017 09:57:31' prior: 16779882! - replaceFrom: start to: stop with: replacement startingAt: repStart - "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." - - - super replaceFrom: start to: stop with: replacement startingAt: repStart! ! -!ByteArray methodsFor: 'private' stamp: 'jmv 1/13/2017 09:57:38' prior: 16793800! - replaceFrom: start to: stop with: replacement startingAt: repStart - "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." - - - super replaceFrom: start to: stop with: replacement startingAt: repStart! ! -!Float64Array methodsFor: 'private' stamp: 'jmv 1/13/2017 09:57:50' prior: 16846133! - replaceWordsFrom: 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." - - - self primitiveFailed! ! -!FloatArray methodsFor: 'private' stamp: 'jmv 1/13/2017 09:58:24' prior: 16846632! -replaceFrom: start to: stop with: replacement startingAt: repStart - "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." - - - super replaceFrom: start to: stop with: replacement startingAt: repStart! ! -!RunNotArray methodsFor: 'private' stamp: 'jmv 1/13/2017 09:58:00' prior: 16901681! - replaceFrom: start to: stop with: replacement startingAt: repStart - "Copied from Array" - "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." - - - super replaceFrom: start to: stop with: replacement startingAt: repStart! ! -!WordArray methodsFor: 'private' stamp: 'jmv 1/13/2017 09:58:38' prior: 16945290! - replaceFrom: start to: stop with: replacement startingAt: repStart - - - super replaceFrom: start to: stop with: replacement startingAt: repStart ! ! -!Bitmap methodsFor: 'accessing' stamp: 'jmv 1/13/2017 09:57:27' prior: 16787571! -replaceFrom: start to: stop with: replacement startingAt: repStart - "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." - - - super replaceFrom: start to: stop with: replacement startingAt: repStart! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3028-GrabErrorCodeForPrim105-JuanVuletich-2017Jan13-09h55m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3028] on 14 January 2017 at 8:18:04 am'! -!Point commentStamp: 'jmv 12/30/2016 17:39:06' prior: 16890200! - I represent an x-y pair of numbers usually designating a location on the screen. - -When dealing with display coordinates, the y axis is usually considered to increase downwards. However, the standard math convention is to consider it increasing upwards. -Points don't need to know about this. In the first case, theta increases clockwise. In the second case, it increases counter-clockwise, also the standard math convention. - -Any method that doesn't follow this (because it assumes one specific convention) include this fact in the selector and in a comment. - -My instances are immutable. See #privateSetX:setY:! -!Point methodsFor: 'private' stamp: 'jmv 12/11/2016 10:28:44'! - privateSetX: xValue setY: yValue - "Points are immutable. Right now this is by convention, but we'll make this enfoced by VM. - Do not all this method, except from instance creation." - x _ xValue. - y _ yValue! ! -!Point methodsFor: 'copying' stamp: 'pb 10/29/2016 18:18:07'! - shallowCopy - "Immutable" - ^ self.! ! -!Object class methodsFor: 'instance creation' stamp: 'jmv 12/30/2016 17:33:31' prior: 16882941! - unStream: aByteArray - ^ ReferenceStream unStream: aByteArray! ! -!DataStream class methodsFor: 'as yet unclassified' stamp: 'jmv 12/30/2016 17:33:27' prior: 16828091! - unStream: aByteArray - - ^(self on: ((RWBinaryOrTextStream with: aByteArray) reset; binary)) next! ! -!Point class methodsFor: 'instance creation' stamp: 'pb 10/29/2016 17:14:00' prior: 16890866! - r: rho degrees: degrees - "Answer an instance of me with polar coordinates rho and theta." - ^ self - rho: rho - theta: degrees asFloat degreesToRadians.! ! -!Point class methodsFor: 'instance creation' stamp: 'pb 10/29/2016 17:12:53' prior: 16890873! - rho: rho theta: radians - "Answer an instance of me with polar coordinates rho and theta." - ^ self - x: rho asFloat * radians cos - y: rho asFloat * radians sin.! ! -!Point class methodsFor: 'instance creation' stamp: 'jmv 12/11/2016 10:28:50' prior: 16890880! - x: anX y: anY - "Answer an instance of me with supplied coordinates." - - ^self new privateSetX: anX setY: anY! ! - -Point removeSelector: #setR:degrees:! - -Point removeSelector: #setR:degrees:! - -Point removeSelector: #setRho:theta:! - -Point removeSelector: #setRho:theta:! - -Point removeSelector: #setX:setY:! - -Point removeSelector: #setX:setY:! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3029-Point-immutable-PhilBellalouna-2017Jan14-08h15m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3029] on 14 January 2017 at 8:53:02 am'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 1/14/2017 08:52:09' prior: 16920588! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3030-AddHernanAndGeraToKnownAuthors-JuanVuletich-2017Jan14-08h52m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3025] on 10 January 2017 at 8:09:15 pm'! - -Object subclass: #TestResultForDebuggingAndInspection - instanceVariableNames: 'testResult' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Testing'! - -!classDefinition: #TestResultForDebuggingAndInspection category: #'Tools-Testing'! -Object subclass: #TestResultForDebuggingAndInspection - instanceVariableNames: 'testResult' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Testing'! -!CompiledMethod methodsFor: 'testing' stamp: 'HernanWilkinson 1/10/2017 18:22:10'! - isTestMethod - - ^ (self methodClass is: #TestCaseClass) - and: [ ((self selector beginsWith: 'test') or: [ (self selector beginsWith: 'should')]) - and: [ self numArgs isZero ] ]! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HernanWilkinson 1/10/2017 19:35:14'! - acceptAndTest - - ^self acceptThenTestMethodAndSuite: [ :aMethod | self testSuiteOf: aMethod methodClass ]! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HernanWilkinson 1/10/2017 19:35:34'! - acceptAndTestAll - - ^self acceptThenTestMethodAndSuite: [ :aMethod | self testSuiteForCategoryOf: aMethod methodClass ] - - ! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HernanWilkinson 1/10/2017 19:04:06'! - acceptThenTestMethodAndSuite: aSuiteBuilder - - | potencialTestMethod | - - self acceptContents ifFalse: [ ^false ]. - - potencialTestMethod _ model textProvider currentCompiledMethod. - self runAndDebuggIfNecessary: potencialTestMethod. - ^(self runTestSuite: (aSuiteBuilder value: potencialTestMethod)) hasPassed - ! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HernanWilkinson 1/10/2017 18:50:03'! - flashWith: aColor - - ^morph flashWith: aColor! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HernanWilkinson 1/10/2017 18:50:21'! -flashWithGreen - - ^self flashWith: Color green - - - - ! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HernanWilkinson 1/10/2017 19:03:07'! - runAndDebuggIfNecessary: aPotentialTestMethod - - aPotentialTestMethod isTestMethod ifTrue: [ - aPotentialTestMethod methodClass debug: aPotentialTestMethod selector ]! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HernanWilkinson 1/10/2017 19:04:42'! - runTestSuite: aTestSuite - - | suiteRunResult | - - suiteRunResult _ aTestSuite run. - suiteRunResult hasPassed - ifTrue: [self flashWithGreen ] - ifFalse: [ suiteRunResult forDebuggingAndInspection inspect ]. - - ^suiteRunResult - - - - ! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HernanWilkinson 1/10/2017 19:35:52'! - testSuiteForCategoryOf: aClass - - | testCaseClasses | - - testCaseClasses _ (SystemOrganization listAtCategoryNamed: aClass category) - collect: [ :aClassName | Smalltalk classNamed: aClassName ] - thenSelect: [ :aClassInCategory | aClassInCategory is: #TestCaseClass ]. - - - ^testCaseClasses - inject: (TestSuite named: 'Test of Category ', aClass category) - into: [ :suite :testCaseClass | testCaseClass addToSuiteFromSelectors: suite ]! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HernanWilkinson 1/10/2017 19:34:58'! - testSuiteOf: aPotentialTestCaseClass - - ^(aPotentialTestCaseClass is: #TestCaseClass) - ifTrue: [ aPotentialTestCaseClass buildSuite ] - ifFalse: [ TestSuite named: 'Tests of ', aPotentialTestCaseClass name ]! ! -!DisplayScreen methodsFor: 'displaying' stamp: 'HernanWilkinson 1/10/2017 18:45:48'! - flash: aRectangle with: aColor - - self fill: aRectangle fillColor: aColor. - self forceToScreen: aRectangle. - (Delay forMilliseconds: 100) wait. - self fill: aRectangle fillColor: aColor. - self forceToScreen: aRectangle! ! -!Morph methodsFor: 'macpal' stamp: 'HernanWilkinson 1/10/2017 18:49:44'! - flashWith: aColor - - self morphBoundsInWorld ifNotNil: [ :r | Display flash: r with: aColor ]! ! -!InnerTextMorph methodsFor: 'editing' stamp: 'HernanWilkinson 1/10/2017 15:56:51'! - confirmAcceptAnyway - - ^ self confirm: -'Caution!! Contents were saved -elsewhere since you started -editing them here. Accept anyway?'! ! -!TestCase class methodsFor: 'Testing' stamp: 'HernanWilkinson 1/10/2017 16:29:48'! - is: aSymbol - - ^aSymbol == #TestCaseClass or: [ super is: aSymbol ]! ! -!TestResult methodsFor: 'Inspecting' stamp: 'HernanWilkinson 1/10/2017 16:33:03'! - forDebuggingAndInspection - - ^TestResultForDebuggingAndInspection on: self! ! -!TestResultForDebuggingAndInspection methodsFor: 'initialization' stamp: 'HernanWilkinson 1/10/2017 16:34:56'! - initializeOn: aTestResult - - testResult _ aTestResult! ! -!TestResultForDebuggingAndInspection methodsFor: 'printing' stamp: 'HernanWilkinson 1/10/2017 17:49:59'! - print: aCollectionOfTestCases startingWith: header on: aStream - - aCollectionOfTestCases - do: [ :aTestCase | - aStream - nextPutAll: header; - space; - nextPutAll: aTestCase class name; - nextPutAll: ' debug: #'; - nextPutAll: aTestCase selector ] - separatedBy: [ aStream newLine ]. - - ! ! -!TestResultForDebuggingAndInspection methodsFor: 'printing' stamp: 'HernanWilkinson 1/10/2017 17:49:05'! - printOn: aStream - - aStream print: testResult. - aStream newLine. - - self print: testResult errors startingWith: '"E"' on: aStream. - self print: testResult failures startingWith: '"F"' on: aStream. - ! ! -!TestResultForDebuggingAndInspection methodsFor: 'running' stamp: 'HernanWilkinson 1/10/2017 18:14:09'! - reRun - - | suite | - - suite _ TestSuite new. - suite addTests: testResult tests. - - testResult _ suite run.! ! -!TestResultForDebuggingAndInspection class methodsFor: 'instance creation' stamp: 'HernanWilkinson 1/10/2017 16:34:28'! - on: aTestResult - - ^self new initializeOn: aTestResult! ! -!TextEditor methodsFor: 'menu messages' stamp: 'HernanWilkinson 1/10/2017 16:00:24' prior: 16932076! - acceptContents - "Save the current text of the text being edited as the current acceptable version for purposes of canceling. Allow my morph to take appropriate action" - ^morph acceptContents! ! -!SmalltalkEditor class methodsFor: 'keyboard shortcut tables' stamp: 'HernanWilkinson 1/10/2017 19:58:01' prior: 16910705! - initializeMenu - "Initialize the mouseButton2 (right button) pop-up menu and corresponding messages." - " - Editor initialize - " - - menu _ SelectionMenu fromArray: { - {'Help...'. #openHelp}. - #-. - {'Do it (d)'. #doIt}. - {'Print it (p)'. #printIt}. - {'Inspect it (i)'. #inspectIt}. - {'Explore it (I)'. #exploreIt}. - {'Debug it (D)'. #debugIt}. - {'Profile it'. #profileIt}. - #-. - {'Explain'. #explain}. - {'Browse it (b)'. #browseIt}. - {'Senders of it (n)'. #sendersOfIt}. - {'Implementors of it (m)'. #implementorsOfIt}. - {'References to it (N)'. #referencesToIt}. - #-. - {'Method Strings with it (E)'. #methodStringsContainingit}. - {'Method Source with it'. #methodSourceContainingIt}. - {'Class Comments with it'. #classCommentsContainingIt}. - #-. - {'Accept (s)'. #acceptContents}. - {'Cancel (l)'. #cancelEdits}. - {'Accept & Run Test in Class (t)'. #acceptAndTest}. - {'Accept & Run Test in Category (y)'. #acceptAndTestAll}. - #-. - {'More...'. #getMenu2}. - }. - menu2 _ SelectionMenu fromArray: { - {'Find...(f)'. #find}. - {'Find Again (g)'. #findAgain}. - {'Use Selection for Find (j)'. #setSearchString}. - #-. - {'Undo - multiple (z)'. #undo}. - {'Redo - multiple (Z)'. #redo}. - {'Undo / Redo history'. #offerUndoHistory}. - #-. - {'Copy (c)'. #copySelection}. - {'Cut (x)'. #cut}. - {'Paste (v)'. #paste}. - {'Paste without Format'. #pasteString}. - {'Paste...'. #pasteRecent}. - #-. - {'Toggle WordWrap'. #wrapOnOff}. - {'Set Font... (k)'. #offerFontMenu}. - {'Clear Font'. #clearFont}. - {'Set Default Font...'. #offerDefaultFontMenu}. - #-. - {'More...'. #getMenu}. - }! ! -!InspectorWindow methodsFor: 'GUI building' stamp: 'HernanWilkinson 1/10/2017 17:47:44' prior: 16857247! - initialExtent - - ^600@325! ! -!InnerTextMorph methodsFor: 'editing' stamp: 'HernanWilkinson 1/10/2017 19:46:39' prior: 16855583! - acceptContents - "The message is sent when the user hits return or Cmd-S. - Accept the current contents and end editing." - "Inform the model of text to be accepted, and return true if OK." - - | accepted prevSelection prevScrollValue | - - prevSelection _ self editor selectionInterval copy. - prevScrollValue _ owner verticalScrollBar value. - - (self canDiscardEdits and: [(self hasProperty: #alwaysAccept) not]) ifTrue: [self flash. ^true]. - (self hasEditingConflicts and: [ self confirmAcceptAnyway not ]) ifTrue: [self flash. ^false]. - - accepted _ model acceptContentsFrom: owner. - "During the step for the browser, updatePaneIfNeeded is called, and - invariably resets the contents of the code-holding PluggableTextMorph - at that time, resetting the cursor position and scroller in the process. - The following line forces that update without waiting for the step, - then restores the cursor and scrollbar" - - "some implementors of acceptContentsFrom: answer self :(" - ^accepted == true - ifTrue: [ - model refetch. - self editor selectFrom: prevSelection first to: prevSelection last. - WorldState addDeferredUIMessage: [ - self world ifNotNil: [ :w | w activeHand newKeyboardFocus: self ]. - owner verticalScrollBar setValue: prevScrollValue]. - true] - ifFalse: [ false ]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3031-TDDSupport-0-HernanWilkinson.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3025] on 10 January 2017 at 8:09:22 pm'! -!SmalltalkEditor methodsFor: 'editing keys' stamp: 'HernanWilkinson 1/10/2017 20:04:06'! - acceptAndTest: aKeyboardEvent - - ^self acceptAndTest! ! -!SmalltalkEditor methodsFor: 'editing keys' stamp: 'HernanWilkinson 1/10/2017 20:04:34'! - acceptAndTestAll: aKeyboardEvent - - ^self acceptAndTestAll! ! -!SmalltalkEditor methodsFor: 'editing keys' stamp: 'HernanWilkinson 1/10/2017 20:02:27'! - debugIt: aKeyboardEvent - - self debugIt. - ^true! ! -!SmalltalkEditor class methodsFor: 'keyboard shortcut tables' stamp: 'HernanWilkinson 1/10/2017 20:03:23' prior: 16910661! - cmdShortcutsSpec - " - Editor initialize - " - "arranged in QWERTY keyboard order" - ^#( - #( $t #acceptAndTest: 'Saves method, runs it as test and then all tests in class. Opens debugger if error') - #( $y #acceptAndTestAll: 'Saves method, runs it as test and then all tests in class category. Opens debugger if error') - #( $i #inspectIt: 'Inspect it (selection is a valid expression, or selection is over an inspect-ilst)') - #( $p #printIt: 'Print it (selection is a valid expression)') - - #( $s #save: 'Save (i.e. accept)') - #( $d #doIt: 'Do it (selection is a valid expression)') - #( $l #cancelEdits: 'Cancel') - - #( $b #browseIt: 'Browse it (selection is a class name or cursor is over a class-list or message-list)') - #( $n #sendersOfIt: 'Senders of it (selection is a message selector or cursor is over a class-list or message-list)') - #( $m #implementorsOfIt: 'Implementors of it (selection is a message selector or cursor is over a class-list or message-list)') - - #( $E #methodStringsContainingit:'Method strings containing it') - #( $T #displayIfTrue: 'Insert #ifTrue:') - #( $I #exploreIt: 'Inspect via Object Explorer') - - #( $A #argAdvance: 'Advance argument') - #( $D #debugIt: 'Debut it') - #( $F #displayIfFalse: 'Insert #ifFalse:') - #( $G #fileItIn: 'File in selection') - - #( $V #pasteInitials: 'Paste author initials') - #( $N #referencesToIt: 'References to it (selection is a class name, or cursor is over a class-list or message-list)') - )! ! -!SmalltalkEditor class methodsFor: 'keyboard shortcut tables' stamp: 'HernanWilkinson 1/10/2017 19:58:01' prior: 50336246! - initializeMenu - "Initialize the mouseButton2 (right button) pop-up menu and corresponding messages." - " - Editor initialize - " - - menu _ SelectionMenu fromArray: { - {'Help...'. #openHelp}. - #-. - {'Do it (d)'. #doIt}. - {'Print it (p)'. #printIt}. - {'Inspect it (i)'. #inspectIt}. - {'Explore it (I)'. #exploreIt}. - {'Debug it (D)'. #debugIt}. - {'Profile it'. #profileIt}. - #-. - {'Explain'. #explain}. - {'Browse it (b)'. #browseIt}. - {'Senders of it (n)'. #sendersOfIt}. - {'Implementors of it (m)'. #implementorsOfIt}. - {'References to it (N)'. #referencesToIt}. - #-. - {'Method Strings with it (E)'. #methodStringsContainingit}. - {'Method Source with it'. #methodSourceContainingIt}. - {'Class Comments with it'. #classCommentsContainingIt}. - #-. - {'Accept (s)'. #acceptContents}. - {'Cancel (l)'. #cancelEdits}. - {'Accept & Run Test in Class (t)'. #acceptAndTest}. - {'Accept & Run Test in Category (y)'. #acceptAndTestAll}. - #-. - {'More...'. #getMenu2}. - }. - menu2 _ SelectionMenu fromArray: { - {'Find...(f)'. #find}. - {'Find Again (g)'. #findAgain}. - {'Use Selection for Find (j)'. #setSearchString}. - #-. - {'Undo - multiple (z)'. #undo}. - {'Redo - multiple (Z)'. #redo}. - {'Undo / Redo history'. #offerUndoHistory}. - #-. - {'Copy (c)'. #copySelection}. - {'Cut (x)'. #cut}. - {'Paste (v)'. #paste}. - {'Paste without Format'. #pasteString}. - {'Paste...'. #pasteRecent}. - #-. - {'Toggle WordWrap'. #wrapOnOff}. - {'Set Font... (k)'. #offerFontMenu}. - {'Clear Font'. #clearFont}. - {'Set Default Font...'. #offerDefaultFontMenu}. - #-. - {'More...'. #getMenu}. - }! ! -!InnerTextMorph methodsFor: 'editing' stamp: 'HernanWilkinson 1/10/2017 19:46:39' prior: 50336311! - acceptContents - "The message is sent when the user hits return or Cmd-S. - Accept the current contents and end editing." - "Inform the model of text to be accepted, and return true if OK." - - | accepted prevSelection prevScrollValue | - - prevSelection _ self editor selectionInterval copy. - prevScrollValue _ owner verticalScrollBar value. - - (self canDiscardEdits and: [(self hasProperty: #alwaysAccept) not]) ifTrue: [self flash. ^true]. - (self hasEditingConflicts and: [ self confirmAcceptAnyway not ]) ifTrue: [self flash. ^false]. - - accepted _ model acceptContentsFrom: owner. - "During the step for the browser, updatePaneIfNeeded is called, and - invariably resets the contents of the code-holding PluggableTextMorph - at that time, resetting the cursor position and scroller in the process. - The following line forces that update without waiting for the step, - then restores the cursor and scrollbar" - - "some implementors of acceptContentsFrom: answer self :(" - ^accepted == true - ifTrue: [ - model refetch. - self editor selectFrom: prevSelection first to: prevSelection last. - WorldState addDeferredUIMessage: [ - self world ifNotNil: [ :w | w activeHand newKeyboardFocus: self ]. - owner verticalScrollBar setValue: prevScrollValue]. - true] - ifFalse: [ false ]! ! - -Editor initialize! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3032-TDDSupport-1-HernanWilkinson.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3025] on 12 January 2017 at 5:14:29 pm'! -!Debugger methodsFor: 'as yet unclassified' stamp: 'HAW 1/12/2017 17:05:16'! - askForSuperclassOf: aClass toImplement: aSelector ifCancel: cancelBlock - - | classes chosenClassIndex | - - classes _ aClass withAllSuperclasses. - chosenClassIndex _ PopUpMenu - withCaption: 'Define #', aSelector, ' in which class?' - chooseFrom: (classes collect: [:c | c name]). - chosenClassIndex = 0 ifTrue: [^ cancelBlock value]. - - ^ classes at: chosenClassIndex! ! -!Debugger methodsFor: 'as yet unclassified' stamp: 'HAW 1/12/2017 17:09:46'! - create - - self shouldBeAbleToCreateMethod - ifTrue: [ self createMethod ] - ifFalse: [ self inform: 'Only available for doesNotUndertand:' ]! ! -!Debugger methodsFor: 'as yet unclassified' stamp: 'HAW 1/12/2017 17:04:29'! - createMethod - - | message chosenClass interruptedContext | - - interruptedContext _ self interruptedContext. - message _ interruptedContext tempAt: 1. - chosenClass _ self - askForSuperclassOf: interruptedContext receiver class - toImplement: message selector - ifCancel: [^self]. - self implement: message inClass: chosenClass. -! ! -!Debugger methodsFor: 'as yet unclassified' stamp: 'HAW 1/12/2017 17:01:22'! - shouldBeAbleToCreateMethod - - ^self interruptedContext selector == #doesNotUnderstand:! ! -!DebuggerWindow methodsFor: 'GUI building' stamp: 'HAW 1/12/2017 17:04:50' prior: 16831115! - customButtonSpecs - "Answer an array of elements of the form wording, selector, help-message, that characterize the custom button row of a debugger." - - ^#( - ('Restart' restart 'reset this context to its start.') - ('Into' send 'step Into message sends') - ('Over' doStep 'step Over message sends') - ('Through' stepIntoBlock 'step into a block') - ('Full Stack' fullStack 'show full stack') - ('Where' where 'select current pc range') - ('Create' create 'create method'))! ! -!PreDebugWindow methodsFor: 'GUI building' stamp: 'HAW 1/12/2017 17:06:02' prior: 16892577! - buttonRowForPreDebugWindow: aDebugger - | row aButton triads buttons | - buttons _ OrderedCollection new. - triads _ OrderedCollection withAll: self preDebugButtonSpec. - (aDebugger shouldBeAbleToCreateMethod) ifTrue: [ - triads add: { 'Create'. #createMethod. 'create the missing method' } - ]. - triads do: [ :triad | - aButton _ PluggableButtonMorph new model: self. - aButton label: triad first. - aButton action: triad second. - aButton setBalloonText: triad third. - buttons add: aButton]. - - row _ LayoutMorph newRow. - row doAdoptWidgetsColor. - row color: Color transparent. - row separation: 1. - row addMorphs: buttons. - ^row! ! -!PreDebugWindow methodsFor: 'button actions' stamp: 'HAW 1/12/2017 17:06:43' prior: 16892636! - createMethod - "Should only be called when this Debugger was created in response to a - MessageNotUnderstood exception. Create a stub for the method that was - missing and proceed into it." - - model createMethod. - self debug -! ! - -PreDebugWindow removeSelector: #askForSuperclassOf:toImplement:ifCancel:! - -PreDebugWindow removeSelector: #askForSuperclassOf:toImplement:ifCancel:! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3033-CreateMethodSupport-HernanWilkinson-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3025] on 12 January 2017 at 6:54:23 pm'! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'HAW 1/12/2017 18:29:00'! - allSuperclassesUpTo: aSuperclass - - | superclasses | - - ^ superclass = aSuperclass - ifTrue: [ OrderedCollection with: aSuperclass] - ifFalse: [superclasses _ superclass allSuperclassesUpTo: aSuperclass. - superclasses addFirst: superclass. - superclasses]! ! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'HAW 1/12/2017 18:30:53'! - withAllSuperclassesUpTo: aSuperclass - - | classes | - - classes _ self allSuperclassesUpTo: aSuperclass. - classes addFirst: self. - - ^ classes! ! -!ContextPart methodsFor: 'debugger access' stamp: 'HAW 1/12/2017 17:48:35'! - arguments - - | arguments | - - arguments _ Array new: self selector numArgs. - 1 to: arguments size do: [ :index | arguments at: index put: (self tempAt: index)]. - - ^arguments. - - ! ! -!ContextPart methodsFor: 'debugger access' stamp: 'HAW 1/12/2017 17:47:30'! -messageForYourself - - ^Message selector: self selector arguments: self arguments. - ! ! -!Debugger methodsFor: 'method creation' stamp: 'HAW 1/12/2017 18:31:14'! - askForSuperclassOf: aClass upTo: aSuperclass toImplement: aSelector ifCancel: cancelBlock - - | classes chosenClassIndex | - - classes _ aClass withAllSuperclassesUpTo: aSuperclass. - chosenClassIndex _ PopUpMenu - withCaption: 'Define #', aSelector, ' in which class?' - chooseFrom: (classes collect: [:c | c name]). - chosenClassIndex = 0 ifTrue: [^ cancelBlock value]. - - ^ classes at: chosenClassIndex! ! -!Debugger methodsFor: 'method creation' stamp: 'HAW 1/12/2017 18:45:03'! - createMethodOnSubclassResponsibility - - | message chosenClass subclassResponsibilityContext | - - subclassResponsibilityContext _ self interruptedContext sender sender. - message _ subclassResponsibilityContext messageForYourself. - - chosenClass _ self - askForSuperclassOf: subclassResponsibilityContext receiver class - upTo: subclassResponsibilityContext method methodClass - toImplement: message selector - ifCancel: [^self]. - - self implement: message inClass: chosenClass context: subclassResponsibilityContext - -! ! -!Debugger methodsFor: 'method creation' stamp: 'HAW 1/12/2017 18:43:11'! - createMethodWhenDoesNotUndertand - - | message chosenClass interruptedContext | - - interruptedContext _ self interruptedContext. - message _ interruptedContext tempAt: 1. - - chosenClass _ self - askForSuperclassOf: interruptedContext receiver class - toImplement: message selector - ifCancel: [^self]. - - self implement: message inClass: chosenClass context: self selectedContext - -! ! -!Debugger methodsFor: 'method creation' stamp: 'HAW 1/12/2017 18:43:25'! - implement: aMessage inClass: aClass context: aContext - - aClass - compile: aMessage createStubMethod - classified: (self askForCategoryIn: aClass default: 'as yet unclassified'). - - aContext privRefreshWith: (aClass lookupSelector: aMessage selector). - aMessage arguments withIndexDo: [ :arg :index | aContext tempAt: index put: arg ]. - self resetContext: aContext! ! -!Debugger methodsFor: 'method creation' stamp: 'HAW 1/12/2017 17:22:28'! - wasInterrupedOnDoesNotUnderstand - - ^self interruptedContext selector == #doesNotUnderstand:! ! -!Debugger methodsFor: 'method creation' stamp: 'HAW 1/12/2017 17:25:23'! - wasInterruptedOnSubclassResponsibility - - ^self interruptedContext sender ifNil: [ false ] ifNotNil: [ :senderContext | senderContext selector == #subclassResponsibility ]! ! -!Debugger methodsFor: 'method creation' stamp: 'HAW 1/12/2017 18:31:48' prior: 50336542! - askForSuperclassOf: aClass toImplement: aSelector ifCancel: cancelBlock - - ^self askForSuperclassOf: aClass upTo: ProtoObject toImplement: aSelector ifCancel: cancelBlock -! ! -!Debugger methodsFor: 'method creation' stamp: 'HAW 1/12/2017 18:46:00' prior: 50336563! - createMethod - - self wasInterrupedOnDoesNotUnderstand ifTrue: [ ^self createMethodWhenDoesNotUndertand ]. - self wasInterruptedOnSubclassResponsibility ifTrue: [ ^self createMethodOnSubclassResponsibility ]. - - self inform: 'Only available for #doesNotUndertand: and #subclassResponsibility' ! ! -!Debugger methodsFor: 'method creation' stamp: 'HAW 1/12/2017 17:22:47' prior: 50336576! - shouldBeAbleToCreateMethod - - ^self wasInterrupedOnDoesNotUnderstand or: [ self wasInterruptedOnSubclassResponsibility]! ! -!DebuggerWindow methodsFor: 'GUI building' stamp: 'HAW 1/12/2017 18:46:32' prior: 50336582! - customButtonSpecs - "Answer an array of elements of the form wording, selector, help-message, that characterize the custom button row of a debugger." - - ^#( - ('Restart' restart 'reset this context to its start.') - ('Into' send 'step Into message sends') - ('Over' doStep 'step Over message sends') - ('Through' stepIntoBlock 'step into a block') - ('Full Stack' fullStack 'show full stack') - ('Where' where 'select current pc range') - ('Create' createMethod 'create method'))! ! -!PreDebugWindow methodsFor: 'GUI building' stamp: 'HAW 1/12/2017 18:47:35' prior: 50336601! - buttonRowForPreDebugWindow: aDebugger - | row aButton triads buttons | - buttons _ OrderedCollection new. - triads _ OrderedCollection withAll: self preDebugButtonSpec. - aDebugger shouldBeAbleToCreateMethod ifTrue: [ triads add: { 'Create'. #createMethod. 'create the missing method' }]. - - triads do: [ :triad | - aButton _ PluggableButtonMorph new model: self. - aButton label: triad first. - aButton action: triad second. - aButton setBalloonText: triad third. - buttons add: aButton]. - - row _ LayoutMorph newRow. - row doAdoptWidgetsColor. - row color: Color transparent. - row separation: 1. - row addMorphs: buttons. - ^row! ! - -Debugger removeSelector: #create! - -Debugger removeSelector: #create! - -Debugger removeSelector: #implement:inClass:! - -Debugger removeSelector: #implement:inClass:! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3034-CreateMethodSupport-HernanWilkinson-1-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3032] on 14 January 2017 at 9:09:47 am'! -!Theme methodsFor: 'menus' stamp: 'jmv 1/14/2017 09:09:05' prior: 16936064! - miscellaneousIcons - - "Everything else." - - ^ { - #('restore display (r)' 'set display depth...' 'move windows onscreen' 'Utilities saveDisplay.') -> #displayIcon. - #('changes...' 'dual change sorter' 'change sets with this method' 'find a change sorter' 'recent changes in file' 'Undo / Redo history' 'code file contents' 'package file contents') -> #changesIcon. - #('Install New Updates' 'update' 'turn on auto-update (a)' 'update list (u)' 'install code' 'fileIn entire file' 'install package') -> #updateIcon. - #('find again (g)' 'full stack (k)') -> #systemIcon. - #('print it (p)' 'check change set for slips') -> #printIcon. - #('accept (s)' 'make changes go to me (m)') -> #acceptIcon. - #('cancel (l)' 'turn off auto-update (a)') -> #cancelIcon. - #('debug...' 'Debug it (D)' 'toggle break on entry') -> #debugIcon. - #('close' 'close all debuggers' 'close top window') -> #closeIcon. - #('collapse' 'hide taskbar' 'collapse all windows') -> #collapseIcon. - #('expand / contract' 'show taskbar' 'restore all windows') -> #expandIcon. - #('menu') -> #windowMenuIcon. - #('browse all' 'browser' 'browse it (b)' 'MessageTally UI and browse' 'browse recent submissions' 'browse full (b)' 'find changed browsers...' 'browse (b)' 'browse my changes') -> #editFindReplaceIcon. - #('workspace' 'workspace with contents') -> #terminalIcon. - #('styled text editor' 'text editor' 'basic text editor' 'unicode editor' 'edit this list' 'edit postscript...' 'add postscript...') -> #textEditorIcon. - #('file list' 'find a fileList' 'compress file') -> #systemFileManagerIcon. - #('transcript' 'find a transcript' 'Transcript clear.' 'log to transcript') -> #printerIcon. - #('process browser' 'vm statistics' 'MessageTally all Processes') -> #systemMonitorIcon. - #('emergency evaluator' 'conflicts with other change sets' 'check for slips' 'conflicts with change set opposite' 'conflicts with category opposite') -> #emblemImportantIcon. - #('change sorter') -> #halfRefreshIcon. - #('SUnit Test Runner' 'Accept & Run Test in Class (t)' 'Accept & Run Test in Category (y)') -> #weatherFewCloudsIcon. - #('Font Sizes...' 'system fonts...' 'set font... (k)') -> #preferencesDesktopFontIcon. - #('full screen on') -> #viewFullscreenIcon. - #('full screen off') -> #exitFullscreenIcon. - #('set desktop color...') -> #wallpaperIcon. - #('preferences...' 'All preferences...' 'what to show...' 'view as hex') -> #preferencesIcon. - #('Editor keyboard shortcuts') -> #keyboardShortcutsIcon. - #('world menu help') -> #globeIcon. "currently unused, but a neat icon" - #('useful expressions' 'class comments with it' 'check for uncommented methods' 'check for uncommented classes') -> #chatIcon. - #('set code author...' 'check for other authors' 'check for any other authors') -> #usersIcon. - #('space left') -> #removableMediaIcon. - #('start drawing all again' 'window color...') -> #graphicsIcon. - #('start stepping again') -> #mediaPlaybackStartIcon. - #('file out current change set' 'fileOut' 'File out and remove (o)' 'File out and keep (k)') -> #fileOutIcon. - #('recently logged changes...' 'versions (v)' 'recent classes... (r)' 'trim history' 'Profile it') -> #clockIcon. - #('senders of it (n)' 'senders of... (n)' 'local senders of...' 'senders (n)') -> #mailForwardIcon. - #('implementors of it (m)' 'implementors of... (m)' 'implementors of sent messages') -> #developmentIcon. - #('references to it (N)') -> #addressBookIcon. - #('class var refs...' 'class refs (N)' 'class variables' 'class vars' 'local implementors of...' 'subclass template') -> #classIcon. - #('inst var refs...' 'inst var defs...' 'sample instance') -> #instanceIcon. - #('Use Selection for Find (j)' 'rename class ...' 'rename...' 'change title...') -> #saveAsIcon. - #('smalltalk options' 'method source with it' 'browse method (O)' 'check for uncategorized methods') -> #scriptIcon. - #('method strings with it (E)' 'Toggle WordWrap') -> #genericTextIcon. - #('browse hierarchy (h)' 'move to top' 'promote to top of list') -> #goTopIcon. - #('move up' 'make next-to-topmost') -> #goUpIcon. - #('move to bottom' 'send to back' 'send top window to back') -> #goBottomIcon. - #('inheritance (i)' 'move down') -> #goDownIcon. - #('browse protocol (p)' 'spawn sub-protocol') -> #spreadsheetIcon. - #('spawn full protocol') -> #speadsheetTemplateIcon. - #('alphabetize') -> #fontXGenericIcon. - #('Installed Packages' 'browse' 'show category (C)' 'categorize all uncategorized' 'select change set...' 'view affected class categories') -> #packageIcon. - #('remove from current change set' 'remove empty categories' 'subtract other side (-)' 'remove from this browser') -> #listRemoveIcon. - #('add to current change set' 'add all meths to current chgs' 'add preamble (p)' 'More...') -> #listAddIcon. - #('toggle diffing (D)' 'toggle selections') -> #switchIcon. - #('reorganize' 'create inst var accessors' 'ChangeSorter reorderChangeSets.' 'reorder all change sets' 'by name' 'by size' 'by date') -> #sendReceiveIcon. - #('unsent methods' 'unreferenced class vars' 'unreferenced inst vars' 'Undeclared inspect.' 'Undeclared removeUnreferencedKeys; inspect.' 'ChangeSorter removeEmptyUnnamedChangeSets.' 'check for unsent messages') -> #junkIcon. - #('find changed windows...') -> #newWindowIcon. - #('make undraggable') -> #pushPinIcon. - #('Utilities saveScreenshot.') -> #stillCameraIcon. - #('add new directory') -> #newFolderIcon. - #('select all' 'deselect all') -> #selectAllIcon. - #('sort by date') -> #dateIcon. - #('justified') -> #formatJustifyFillIcon. - #('centered') -> #formatJustifyCenterIcon. - #('set alignment...' 'leftFlush') -> #formatJustifyLeftIcon. - #('rightFlush') -> #formatJustifyRightIcon. - #('signal Semaphore (S)') -> #haloHelpIcon. - #('Change Paragraph Style...' 'Change Character Style...' 'Remove Character Style' 'Replace all uses of Paragraph Style...' 'Replace all uses of Character Style...' 'Set Default Font...') -> #fontXGenericIcon. - #('Clear Font') -> #newIcon. - #('code file browser' 'package file browser') -> #findIcon. - }! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Theme current class beCurrent! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3035-AddIconsForTDDSupport-JuanVuletich-2017Jan14-09h07m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3035] on 16 January 2017 at 11:04:32 am'! - -(Smalltalk classNamed: 'Taskbar') ifNotNil: [ :tbClass | - PasteUpMorph allInstancesDo: [ :w | w hideTaskbar ]. - tbClass allInstancesDo: [ :each | each delete ]]! - -StringMorph subclass: #UpdatingStringMorph - instanceVariableNames: 'target getSelector stepTime' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #UpdatingStringMorph category: #'Morphic-Widgets'! -StringMorph subclass: #UpdatingStringMorph - instanceVariableNames: 'target getSelector stepTime' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! -!UpdatingStringMorph commentStamp: 'jmv 1/5/2013 23:49' prior: 0! - UpdatingStringMorph new - target: [self runningWorld activeHand morphPosition asString]; - getSelector: #value; - stepTime: 10; - openInWorld! - -LayoutMorph subclass: #TaskbarMorph - instanceVariableNames: 'viewBox scale' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Taskbar'! - -!classDefinition: #TaskbarMorph category: #'Tools-Taskbar'! -LayoutMorph subclass: #TaskbarMorph - instanceVariableNames: 'viewBox scale' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Taskbar'! -!TaskbarMorph commentStamp: '' prior: 0! - A simple task bar written for Cuis. - -dashBoard contains views/controls -viewBox contains graphic buttons of "iconized" windows/morphs. -scale allows 1x 2x 4x tarkbar height. [scale= 1,2,4]! -!Preferences class methodsFor: 'personalization' stamp: 'jmv 1/15/2017 18:51:02'! - taskbarIncludesAllWindows - " - true: All windows are included in Taskbar - false: Only collapsed windows are included in Taskbar - " - ^ self - valueOfFlag: #taskbarIncludesAllWindows - ifAbsent: [ true ].! ! -!Morph methodsFor: 'accessing' stamp: 'jmv 1/15/2017 18:06:45'! - taskbar - ^self world ifNotNil: [ :w | w taskbar ]! ! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'jmv 1/15/2017 14:52:58'! -showAndComeToFront - - self show; comeToFront! ! -!PasteUpMorph methodsFor: 'change reporting' stamp: 'jmv 1/16/2017 09:56:14'! - addedMorph: aMorph - "Notify the receiver that the given morph was just added." - super addedMorph: aMorph. - self taskbar ifNotNil: [ :tb | - tb wasOpened: aMorph ]! ! -!PasteUpMorph methodsFor: 'change reporting' stamp: 'jmv 1/16/2017 09:56:07'! - removedMorph: aMorph - "Notify the receiver that aMorph was just removed from its children" - super removedMorph: aMorph. - self taskbar ifNotNil: [ :tb | - tb wasDeleted: aMorph ]! ! -!PasteUpMorph methodsFor: 'taskbar' stamp: 'jmv 1/15/2017 18:57:53'! - taskbarDeleted - taskbar _ nil! ! -!UpdatingStringMorph methodsFor: 'accessing' stamp: 'jmv 1/4/2013 13:15'! - getSelector: aSymbol - getSelector _ aSymbol! ! -!UpdatingStringMorph methodsFor: 'accessing' stamp: 'jmv 1/4/2013 13:18'! - stepTime - - ^stepTime! ! -!UpdatingStringMorph methodsFor: 'accessing' stamp: 'jmv 1/4/2013 13:15'! - stepTime: aNumber - stepTime _ aNumber! ! -!UpdatingStringMorph methodsFor: 'accessing' stamp: 'jmv 1/4/2013 13:15'! - target: anObject - target _ anObject! ! -!UpdatingStringMorph methodsFor: 'initialization' stamp: 'jmv 9/13/2013 09:23'! - initialize - super initialize. - target _ self. - getSelector _ #contents. - stepTime _ 50! ! -!UpdatingStringMorph methodsFor: 'stepping' stamp: 'jmv 2/27/2016 20:07'! - stepAt: millisecondSinceLast - - self contents: (target perform: getSelector)! ! -!UpdatingStringMorph methodsFor: 'stepping' stamp: 'jmv 1/4/2013 13:18'! - wantsSteps - "Return true if the receiver wants to its #step or #stepAt: methods be run" - - ^true! ! -!UpdatingStringMorph methodsFor: 'geometry' stamp: 'jmv 1/15/2017 14:25:27'! - fitContents - "Don't shrink each time contents change. - Might shrink during layout" - self morphExtent: (extent max: self measureContents)! ! -!UpdatingStringMorph class methodsFor: 'new-morph participation' stamp: 'jmv 4/15/2014 09:26'! - initializedInstance - "Answer a digital clock" - - | newInst | - newInst := self - contents: '' - font: (AbstractFont familyName: 'DejaVu' pointSize: 22) - emphasis: AbstractFont boldCode. - newInst - stepTime: 500; "half a second" - target: [String streamContents: [ :strm | DateAndTime now printHMSOn: strm]] ; - getSelector: #value. - - ^ newInst! ! -!TaskbarMorph methodsFor: 'accessing' stamp: 'jmv 1/15/2017 14:49:41'! - buttonFor: aMorph - - viewBox ifNotNil: [ - viewBox submorphs do: [ :button | - button model == aMorph - ifTrue: [ ^button ]] - ]. - ^nil! ! -!TaskbarMorph methodsFor: 'accessing' stamp: 'jmv 1/15/2017 14:49:30'! - scale - - ^ scale ifNil: [ self defaultScale ] ifNotNil: [ scale ]! ! -!TaskbarMorph methodsFor: 'events' stamp: 'jmv 1/8/2017 16:48:00'! - notifyDisplayResize - Display - when: #screenSizeChanged - send: #screenSizeChanged - to: self. - self screenSizeChanged! ! -!TaskbarMorph methodsFor: 'events' stamp: 'jmv 1/8/2017 16:48:14'! - screenSizeChanged - "Respond to change in screen size by repositioning self to bottom of screen" - -" Transcript newLine; print: 'Taskbar screenSizeChanged'. -" - | y e | - WorldState addDeferredUIMessage: [ - self world ifNotNil: [ :w | - y _ w morphExtent y - self defaultHeight. - e _ self internalizeDistance: w morphExtent x @ self defaultHeight. - self morphPosition: 0@y extent: e ]]! ! -!TaskbarMorph methodsFor: 'initialization' stamp: 'jmv 1/15/2017 14:49:51'! - defaultHeight - - ^ Preferences windowTitleFont height * 2 * self scale! ! -!TaskbarMorph methodsFor: 'initialization' stamp: 'jmv 1/15/2017 14:49:19'! - defaultScale - - ^ 1! ! -!TaskbarMorph methodsFor: 'initialization' stamp: 'jmv 1/8/2017 16:57:33'! - initialize - super initialize. - viewBox _ LayoutMorph newRow color: self defaultColor. - self - addMorph: UpdatingStringMorph initializedInstance - layoutSpec: (LayoutSpec morphWidthProportionalHeight: 1.0). - self - addMorph: viewBox - layoutSpec: (LayoutSpec - proportionalWidth: 1.0 - proportionalHeight: 1.0 - minorDirectionPadding: #right). - viewBox separation: 5 -! ! -!TaskbarMorph methodsFor: 'testing' stamp: 'jmv 1/8/2017 16:44:53'! - is: aSymbol - ^ aSymbol == #TaskbarMorph or: [ super is: aSymbol ]! ! -!TaskbarMorph methodsFor: 'testing' stamp: 'jmv 1/8/2017 16:47:41'! - isSticky - "answer whether the receiver is Sticky" - ^true! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 1/15/2017 18:42:23'! - addButtonFor: aMorph - - | button | - button _ PluggableButtonMorph - model: aMorph - stateGetter: nil - action: #showAndComeToFront. - button - color: self color; - icon: (aMorph imageForm: 32); - setBalloonText: aMorph label. - viewBox - addMorph: button - fixedWidth: self defaultHeight! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 1/15/2017 18:20:11'! - removeButtonFor: aMorph - - (self buttonFor: aMorph) ifNotNil: [ :b | - b delete ]! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 1/15/2017 18:49:21'! - restoreAll - viewBox ifNotNil: [ - viewBox submorphs do: [ :button | - button model showAndComeToFront ] ]! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 1/15/2017 18:23:09'! - wasCollapsed: aMorph - "Add a button for aMorph if not already there (see #taskbarIncludesAllWindows)" - - (self buttonFor: aMorph) ifNil: [ - self addButtonFor: aMorph ]! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 1/15/2017 18:25:27'! - wasDeleted: aMorph - "aMorph was deleted. Remove button for aMorph" - - self removeButtonFor: aMorph! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 1/15/2017 18:19:22'! - wasMadeVisible: aMorph - "aMorph is now visible. Remove button for aMorph if appropriate (see #taskbarIncludesAllWindows)" - - Preferences taskbarIncludesAllWindows ifFalse: [ - self removeButtonFor: aMorph ]! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 1/15/2017 18:21:15'! - wasOpened: aMorph - "aMorph was added to the world. Add button for aMorph if appropriate (see #taskbarIncludesAllWindows)" - - Preferences taskbarIncludesAllWindows ifTrue: [ - self addButtonFor: aMorph ]! ! -!TaskbarMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 1/15/2017 18:57:58'! -delete - - | w | - self restoreAll. - super delete. - w _ self world ifNil: [ self runningWorld ]. - Display removeActionsWithReceiver: self. - w ifNotNil: [ w taskbarDeleted ]! ! -!TaskbarMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 1/16/2017 09:52:23'! - noteNewOwner: aMorph - "I have just been added as a submorph of aMorph" - super noteNewOwner: aMorph. - Preferences taskbarIncludesAllWindows ifTrue: [ - aMorph submorphsDo: [ :m | - m == self ifFalse: [ - self addButtonFor: m ]]]. - self notifyDisplayResize! ! -!TaskbarMorph methodsFor: 'menus' stamp: 'jmv 1/15/2017 19:14:11'! - handlesMouseDown: aMouseButtonEvent - - ^ true! ! -!TaskbarMorph methodsFor: 'menus' stamp: 'jmv 1/15/2017 19:10:57'! - mouseButton2Activity - - | menu | - menu _ MenuMorph new defaultTarget: self. - menu - addLine; - add: 'Normal Height' action: #scaleNormal; - add: 'Scale x 2' action: #scaleX2; - add: 'Scale x 4' action: #scaleX4. - menu popUpInWorld! ! -!TaskbarMorph methodsFor: 'resize' stamp: 'jmv 1/15/2017 19:01:25'! - scale: anInteger - - (anInteger between: 1 and: 4) ifFalse: [ self error: 'scale should be 1 2 or 4' ]. - scale := anInteger. - self screenSizeChanged. "rescale self" - viewBox ifNotNil: [ "rescale buttons" - viewBox submorphs do: [ :button | - button layoutSpec fixedWidth: self defaultHeight - ] - ]! ! -!TaskbarMorph methodsFor: 'resize' stamp: 'jmv 1/15/2017 19:00:49'! - scaleNormal - - self scale: 1! ! -!TaskbarMorph methodsFor: 'resize' stamp: 'jmv 1/15/2017 19:00:52'! - scaleX2 - - self scale: 2! ! -!TaskbarMorph methodsFor: 'resize' stamp: 'jmv 1/15/2017 19:00:55'! - scaleX4 - - self scale: 4! ! -!TaskbarMorph class methodsFor: 'system startup' stamp: 'jmv 1/8/2017 16:47:17'! - initClassCachedState - - "Should use some other way to find relevant instances" - self flag: #jmvVer2. - self allInstancesDo: [ :each | - each notifyDisplayResize ]! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 1/15/2017 18:24:25' prior: 16874345! - visible: aBoolean - "set the 'visible' attribute of the receiver to aBoolean" - - self visible == aBoolean - ifTrue: [ ^ self ]. - aBoolean ifFalse: [ - self redrawNeeded ]. - self setProperty: #visible toValue: aBoolean. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - aBoolean ifTrue: [ - self redrawNeeded. - self taskbar ifNotNil: [ :tb | - tb wasMadeVisible: self ]]! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 1/15/2017 14:58:58' prior: 16875692! - comeToFrontAndAddHalo - self show. - self comeToFront. - self addHalo! ! -!Morph methodsFor: 'menus' stamp: 'jmv 1/15/2017 18:24:40' prior: 16876276! - collapse - "If taskbar not visible, just hide." - - self hide. - self taskbar - ifNotNil: [ :tb | tb wasCollapsed: self ]! ! -!Morph methodsFor: 'menus' stamp: 'jmv 1/15/2017 14:59:12' prior: 16876281! - expand - - self show. - self comeToFront! ! -!Morph methodsFor: 'testing' stamp: 'jmv 1/15/2017 15:04:18' prior: 16876985! - isCollapsed - - ^ self visible not! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 1/8/2017 16:44:57' prior: 16887743! - allNonWindowRelatedSubmorphs - "Answer all non-window submorphs that are not flap-related" - - ^submorphs - reject: [ :m | (m is: #SystemWindow) or: [ m is: #TaskbarMorph ] ]! ! -!PasteUpMorph methodsFor: 'taskbar' stamp: 'jmv 1/15/2017 14:43:48' prior: 16887920! - showTaskbar - - taskbar ifNil: [ - taskbar _ TaskbarMorph newRow. - taskbar openInWorld: self ]! ! -!StringMorph methodsFor: 'geometry' stamp: 'jmv 1/15/2017 14:22:53' prior: 16918181! - measureContents - | f | - f _ self fontToUse. - ^((f widthOfString: contents) max: 3) @ f height! ! - -TaskbarMorph removeSelector: #intoWorld:! - -PasteUpMorph removeSelector: #isCollapsed:! - -PasteUpMorph removeSelector: #isCollapsed:! - -PasteUpMorph removeSelector: #minimize:! - -PasteUpMorph removeSelector: #minimize:! - -PasteUpMorph removeSelector: #restore:! - -PasteUpMorph removeSelector: #restore:! - -PasteUpMorph removeSelector: #taskbar:! - -PasteUpMorph removeSelector: #taskbar:! - -PasteUpMorph allInstancesDo: [ :w | w showTaskbar ]! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3036-NewTaskbar-JuanVuletich-2017Jan16-10h55m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3036] on 17 January 2017 at 11:13:18 am'! -!DebuggerWindow methodsFor: 'GUI building' stamp: 'jmv 1/17/2017 10:51:52'! - initialExtent - ^ RealEstateAgent standardWindowExtent * 3 // 2! ! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 1/17/2017 11:12:27' prior: 16898269! - maximumUsableAreaInWorld: aWorldOrNil - - | allowedArea | - allowedArea _ Display boundingBox. - aWorldOrNil ifNotNil: [ - allowedArea _ allowedArea intersect: aWorldOrNil viewBox. - aWorldOrNil taskbar ifNotNil: [ :tb | - allowedArea _ (allowedArea areasOutside: tb morphBoundsInWorld) first ]]. - ^allowedArea -! ! -!PasteUpMorph methodsFor: 'geometry' stamp: 'jmv 1/17/2017 11:00:35' prior: 16887247! - privateExtent: newExtent - - ^ (super privateExtent: newExtent) - ifTrue: [ - self buildMagnifiedBackgroundImage. - worldState clearCanvas ]; yourself! ! -!PasteUpMorph methodsFor: 'project state' stamp: 'jmv 1/17/2017 10:56:23' prior: 16887422! - viewBox - - ^ worldState - ifNotNil: [ - 0@0 extent: extent ] - ifNil: [ - self world viewBox ]! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 1/17/2017 11:05:24' prior: 16887834! - restoreMorphicDisplay - DisplayScreen startUp. - self - morphExtent: Display extent; - handsDo: [ :h | h visible: true ]; - fullRepaintNeeded. - WorldState addDeferredUIMessage: [ Cursor normal activateCursor ]! ! -!PasteUpMorph class methodsFor: 'instance creation' stamp: 'jmv 1/17/2017 11:04:44' prior: 16887959! - newWorld - " -[ - ProjectX stopUIProcess. - ProjectX spawnNewMorphicProcessFor: PasteUpMorph newWorld -] fork. - " - | w ws | - w _ self new. - ws _ WorldState new. - w worldState: ws. - w morphPosition: 0@0 extent: Display extent. - ws setCanvas: Display getCanvas. - w borderWidth: 0. - ws handsDo: [ :h | - h privateOwner: w ]. - ^w! ! -!WorldState methodsFor: 'canvas' stamp: 'jmv 1/17/2017 10:57:47' prior: 16945711! - ensureNonDisplayCanvas - (canvas isNil or: [ - canvas drawsOnDisplay or: [ - (canvas extent ~= world morphExtent) or: [ - canvas form depth ~= Display depth]]]) ifTrue: [ - "allocate a new offscreen canvas the size of the window" - self setCanvas: (BitBltCanvas withExtent: world morphExtent depth: Display depth)]! ! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 1/17/2017 11:05:18' prior: 16946039! - tryDeferredUpdatingAndSetCanvasFor: aWorld - "If this platform supports deferred updates, then make my canvas be the Display (or a rectangular portion of it), set the Display to deferred update mode, and answer true. Otherwise, set a non-Disply canvas and answer false.." - | properDisplay | - - "As this is the only sender of #deferUpdates: , this could be done in Morphic or image startup, and never efterwards..." - (Display deferUpdates: true) ifNil: [ - "deferred updates not supported by the VM, do them in the image!!" - self ensureNonDisplayCanvas. - ^ false]. - - "if no canvas, or canvas was offscreen, from a platform that didnt support defers, then fix it" - properDisplay _ canvas notNil and: [canvas drawsOnDisplay]. - properDisplay ifFalse: [ - aWorld morphPosition: 0@0 extent: Display extent. - self setCanvas: Display getCanvas. - ]. - ^ true! ! -!WorldState methodsFor: 'drawing' stamp: 'jmv 7/28/2015 08:35' prior: 16946090! - displayWorld: aWorld submorphs: submorphs - "Update this world's display." - - | deferredUpdateVMMode worldDamageRects handsToDraw allDamage | - self checkIfUpdateNeeded ifFalse: [ ^ self ]. "display is already up-to-date" - "I (jmv) removed the call to 'deferUpdates: false' below. No more need to call this every time." - deferredUpdateVMMode _ self tryDeferredUpdatingAndSetCanvasFor: aWorld. - - "repair world's damage on canvas" - worldDamageRects _ self drawInvalidAreasWorld: aWorld submorphs: submorphs. - - "Check which hands need to be drawn (they are not the hardware mouse pointer)" - handsToDraw _ self selectHandsToDrawForDamage: worldDamageRects. - allDamage _ Array streamContents: [ :strm | - strm nextPutAll: worldDamageRects. - handsToDraw do: [ :h | - h savePatchFrom: canvas appendDamageTo: strm ]]. - - "Draw hands (usually carying morphs) onto world canvas" - canvas newClipRect: nil. - handsToDraw reverseDo: [ :h | canvas fullDrawHand: h ]. - - "quickly copy altered rects of canvas to Display:" - deferredUpdateVMMode ifFalse: [ - "Drawing was done to off-Display canvas. Copy content to Display" - canvas showAt: aWorld viewBox origin invalidRects: allDamage ]. - - "Display deferUpdates: false." - "Display forceDisplayUpdate" - Display forceDamageToScreen: allDamage. - - "Restore world canvas under hands and their carried morphs" - handsToDraw do: [ :h | h restoreSavedPatchOn: canvas ].! ! - -WorldState removeSelector: #viewBox! - -WorldState removeSelector: #viewBox! - -WorldState removeSelector: #viewBox:! - -WorldState removeSelector: #viewBox:! - -DebuggerWindow removeSelector: #initialFrameIn:! - -DebuggerWindow removeSelector: #initialFrameIn:! - -PasteUpMorph removeSelector: #viewBox:! - -PasteUpMorph removeSelector: #viewBox:! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3037-WindowsAvoidTaskbarArea-JuanVuletich-2017Jan17-10h47m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3037] on 18 January 2017 at 10:36:09 am'! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 1/18/2017 10:34:55' prior: 50337249! - addButtonFor: aMorph - - | button | - aMorph == self ifFalse: [ - button _ PluggableButtonMorph - model: aMorph - stateGetter: nil - action: #showAndComeToFront. - button - color: self color; - icon: (aMorph imageForm: 32); - setBalloonText: aMorph label. - viewBox - addMorph: button - fixedWidth: self defaultHeight ]! ! -!TaskbarMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 1/18/2017 10:35:05' prior: 50337312! - noteNewOwner: aMorph - "I have just been added as a submorph of aMorph" - super noteNewOwner: aMorph. - Preferences taskbarIncludesAllWindows ifTrue: [ - aMorph submorphsDo: [ :m | - self addButtonFor: m ]]. - self notifyDisplayResize! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3038-TaskbarTweaks-JuanVuletich-2017Jan18-10h34m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3038] on 18 January 2017 at 7:35:13 pm'! -!DirectoryEntry methodsFor: 'enumeration' stamp: 'jmv 1/18/2017 11:20:57'! - fileMatching: pattern -" - DirectoryEntry smalltalkImageDirectory fileMatching: '*.image'. - DirectoryEntry smalltalkImageDirectory fileMatching: 'x*.image'. -" - self filesDo: [ :file | - (pattern match: file name) - ifTrue: [ ^ file ]]. - ^ nil! ! -!DirectoryEntry methodsFor: 'enumeration' stamp: 'jmv 1/18/2017 11:13:59' prior: 16834484! - directoriesDo: aBlock - self childrenDo: [ :each | - each isFile ifFalse: [ - aBlock value: each ]]! ! -!DirectoryEntry methodsFor: 'enumeration' stamp: 'jmv 1/18/2017 11:19:42' prior: 16834701! - directoryMatching: pattern -" - DirectoryEntry smalltalkImageDirectory directoryMatching: 'C*Pack*'. - DirectoryEntry smalltalkImageDirectory directoryMatching: 'xC*Pack*'. -" - self directoriesDo: [ :directory | - (pattern match: directory name) - ifTrue: [ ^ directory ]]. - ^ nil! ! -!DirectoryEntry methodsFor: 'enumeration' stamp: 'jmv 1/18/2017 11:14:17' prior: 16834493! - filesDo: aBlock - self childrenDo: [ :each | - each isFile ifTrue: [ - aBlock value: each ]]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3039-DirectoryEntryTweaks-JuanVuletich-2017Jan18-19h34m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3039] on 18 January 2017 at 10:26:44 pm'! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 1/18/2017 22:25:29' prior: 50337610! - addButtonFor: aMorph - - | button | - aMorph == self ifFalse: [ - button _ PluggableButtonMorph - model: aMorph - stateGetter: nil - action: #showAndComeToFront. - button - color: self color; - icon: (aMorph imageForm: 32); - setBalloonText: aMorph label. - button icon: button magnifiedIcon. - viewBox - addMorph: button - fixedWidth: self defaultHeight ]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3040-DontWasteMemoryOnTaskbarButtons-JuanVuletich-2017Jan18-22h26m-jmv.1.cs.st----! - -----SNAPSHOT----#(18 January 2017 10:35:08.449455 pm) Cuis5.0-3040-spur.image priorSource: 83152! - -----QUIT----#(18 January 2017 10:35:21.576339 pm) Cuis5.0-3040-spur.image priorSource: 193704! - -----STARTUP----#(20 February 2017 12:21:53.409414 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3040-spur.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3040] on 22 January 2017 at 9:33:48 pm'! -!PasteUpMorph methodsFor: 'geometry' stamp: 'jmv 1/22/2017 21:17:32' prior: 50337465! - privateExtent: newExtent - - ^ (super privateExtent: newExtent) - ifTrue: [ - self buildMagnifiedBackgroundImage. - worldState ifNotNil: [ - worldState clearCanvas ]]; - yourself! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 1/22/2017 21:25:10' prior: 16926091! - drawOn: aCanvas - - | titleColor roundCorners | - - titleColor _ self widgetsColor. - self isTopWindow - ifTrue: [ titleColor _ titleColor lighter ]. - - roundCorners _ Theme current roundWindowCorners. - roundCorners - ifTrue: [ - "Round corners. Optional title gradient." - self drawRoundedFrameOn: aCanvas color: titleColor ] - ifFalse: [ - "No round corners. No title gradient." - self drawClassicFrameOn: aCanvas color: titleColor ]. - Theme current minimalWindows - ifFalse: [ - labelString ifNotNil: [self drawLabelOn: aCanvas]]! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 1/22/2017 21:31:40' prior: 16866779! - popUpInWorld: aWorld - "Present this menu under control of the given hand." - "Needed if not the real world but an inner PasteUpMorph" - | positionInWorld | - positionInWorld _ aWorld internalizeFromWorld: aWorld activeHand morphPosition. - ^self - popUpAt: positionInWorld - forHand: aWorld activeHand - in: aWorld -! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3041-Fix-clearCanvas-DNU-JuanVuletich-2017Jan22-21h17m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2974] on 3 December 2016 at 9:04:32 am'! -!Integer methodsFor: 'private' stamp: 'nice 1/19/2013 03:13'! - montgomeryDigitBase - "Answer the base used by Montgomery algorithm." - ^1 << self montgomeryDigitLength! ! -!Integer methodsFor: 'private' stamp: 'nice 1/19/2013 03:27'! - montgomeryDigitLength - "Answer the number of bits composing a digit in Montgomery algorithm. - Primitive use either 8 or 32 bits digits" - - ^8 "Legacy plugin which did not have this primitive did use 8 bits digits"! ! -!Integer methodsFor: 'private' stamp: 'nice 1/19/2013 03:14'! - montgomeryDigitMax - "Answer the maximum value of a digit used in Montgomery algorithm." - - ^1 << self montgomeryDigitLength - 1! ! -!Integer methodsFor: 'private' stamp: 'nice 1/19/2013 03:16'! - montgomeryNumberOfDigits - "Answer the number of montgomery digits required to represent the receiver." - ^self digitLength * 8 + (self montgomeryDigitLength - 1) // self montgomeryDigitLength! ! -!Integer methodsFor: 'mathematical functions' stamp: 'nice 1/16/2013 18:38' prior: 16859768! - raisedTo: n modulo: m - "Answer the modular exponential. - Note: this implementation is optimized for case of large integers raised to large powers." - | a s mInv | - n = 0 ifTrue: [^1]. - (self >= m or: [self < 0]) ifTrue: [^self \\ m raisedTo: n modulo: m]. - n < 0 ifTrue: [^(self reciprocalModulo: m) raisedTo: n negated modulo: m]. - (n < 4096 or: [m even]) - ifTrue: - ["Overhead of Montgomery method might cost more than naive divisions, use naive" - ^self slidingLeftRightRaisedTo: n modulo: m]. - - mInv := self montgomeryDigitBase - ((m bitAnd: self montgomeryDigitMax) reciprocalModulo: self montgomeryDigitBase). - - "Initialize the result to R=self montgomeryDigitModulo raisedTo: m montgomeryNumberOfDigits" - a := (1 bitShift: m montgomeryNumberOfDigits * m montgomeryDigitLength) \\ m. - - "Montgomerize self (multiply by R)" - (s := self montgomeryTimes: (a*a \\ m) modulo: m mInvModB: mInv) - ifNil: - ["No Montgomery primitive available ? fallback to naive divisions" - ^self slidingLeftRightRaisedTo: n modulo: m]. - - "Exponentiate self*R" - a := s montgomeryRaisedTo: n times: a modulo: m mInvModB: mInv. - - "Demontgomerize the result (divide by R)" - ^a montgomeryTimes: 1 modulo: m mInvModB: mInv! ! -!Integer methodsFor: 'testing' stamp: 'nice 11/14/2011 21:59' prior: 16860231! - isProbablyPrime - "See isProbablyPrimeWithK:andQ: for the algoritm description." - - | k q | - self <= 1 ifTrue: [ ^false ]. - self even ifTrue: [ ^self = 2 ]. - "Factor self into (2 raisedTo: k) * q + 1, where q odd" - q := self bitShift: -1. - k := q lowBit. - q := q bitShift: 1 - k. - "Repeat the probabilistic until false (the probability of false negative is null) or until probability is very low." - 25 timesRepeat: [ (self isProbablyPrimeWithK: k andQ: q) ifFalse: [ ^false ] ]. - "The probability of false positive after 25 iterations is less than (1/4 raisedTo: 25) < 1.0e-15" - ^true! ! -!Integer methodsFor: 'private' stamp: 'nice 11/15/2011 23:13' prior: 16860590! - isProbablyPrimeWithK: k andQ: q - "Algorithm P, probabilistic primality test, from - Knuth, Donald E. 'The Art of Computer Programming', Vol 2, - Third Edition, section 4.5.4, page 395, P1-P5 refer to Knuth description.. - Note that this is a Miller Rabin test which may answer false positives (known as pseudoprimes) for at most 1/4 of the possible bases x." - - | x j y minusOne | - "P1" - x := (self - 2) atRandom + 1. - "P2" - j := 0. - y := x raisedTo: q modulo: self. - minusOne := self - 1. - - ["P3" - y = 1 ifTrue: [^j = 0]. - y = minusOne ifTrue: [^true]. - "P4" - (j := j + 1) < k] - whileTrue: - [y := y squared \\ self]. - "P5" - ^false! ! -!Integer methodsFor: 'private' stamp: 'nice 1/16/2013 18:40' prior: 16860675! - montgomeryTimes: a modulo: m mInvModB: mInv - "Answer the result of a Montgomery multiplication - self * a * (b raisedTo: m montgomeryNumberOfDigits) inv \\ m - NOTE: it is assumed that: - self montgomeryNumberOfDigits <= m montgomeryNumberOfDigits - a montgomeryNumberOfDigits <= m montgomeryNumberOfDigits - mInv * m \\ b = (-1 \\ b) = (b-1) (this implies m odd) - where b = self montgomeryDigitBase - - Answer nil in case of absent plugin or other failure." - - - ^nil! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3042-MontgomeryExponentiationFix-LucianoEstebanNotarfrancesco-2016Nov29-21h10m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3042] on 22 January 2017 at 9:49:56 pm'! -!Integer methodsFor: 'arithmetic' stamp: 'len 12/4/2016 13:11:44'! - reciprocalModulo2: n - "Answer an integer x such that self * x \\ n = 1, with 0 < x < n, or nil if it doesn't exist." - | xgcd | - self == 0 ifTrue: [^ nil]. - self == 1 ifTrue: [^ 1]. - xgcd _ self xgcd: n. - ^ (xgcd at: 1) == 1 ifTrue: [^ (xgcd at: 2) \\ n]! ! -!Integer methodsFor: 'arithmetic' stamp: 'len 12/4/2016 13:07:08'! - xgcd: anInteger - "Extended Euclidean algorithm. - Answer an array {x. u. v} where self * u + (anInteger * v) = x, and x = (self gcd: anInteger)." - | a b s t sp tp r rp | - a _ self. b _ anInteger. - s _ 0. sp _ 1. - t _ 1. tp _ 0. - r _ a abs. rp _ b abs. - [r == 0] - whileFalse: - [ | q temp | - q _ rp // r. - temp _ r. r _ rp - (q * r). rp _ temp. - temp _ s. s _ sp - (q * s). sp _ temp. - temp _ t. t _ tp - (q * t). tp _ temp]. - sp _ sp * b sign. tp _ tp * a sign. - ^ {rp. tp. sp}! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3043-Alternative-gcd-reciprocalModulo-LucianoEstebanNotarfrancesco-2017Jan22-21h46m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3043] on 16 February 2017 at 2:31:35 pm'! -!FileSystemEntry methodsFor: 'accessing-file name' stamp: 'jmv 2/16/2017 11:21:10' prior: 16843823! - baseName - ^self fileAccessor baseNameFor: name! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3044-basename-fix-JuanVuletich-2017Feb16-11h21m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3044] on 17 February 2017 at 3:11:08 pm'! -!PluggableButtonMorph methodsFor: 'private' stamp: 'jmv 2/17/2017 15:10:48' prior: 16888368! - magnifiedIcon - | factor magnifiedExtent w h | - - icon ifNil: [ ^nil ]. - magnifiedIcon ifNil: [ - magnifiedIcon _ icon. - w _ icon width. - h _ icon height. - w*h = 0 ifFalse: [ - factor _ 1.0 * extent x / w min: 1.0 * extent y / h. - (factor < 1 or: [ factor > 1.7 and: [self isRoundButton]]) ifTrue: [ - magnifiedExtent _ (icon extent * factor) rounded. - magnifiedIcon _ icon magnifyTo: magnifiedExtent ]]]. - ^magnifiedIcon! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3045-magnifiedIcon-fix-JuanVuletich-2017Feb17-15h10m-jmv.1.cs.st----! - -----SNAPSHOT----#(20 February 2017 12:22:00.936181 pm) Cuis5.0-3045-spur.image priorSource: 193803! - -----QUIT----#(20 February 2017 12:22:14.041134 pm) Cuis5.0-3045-spur.image priorSource: 202591! - -----STARTUP----#(6 March 2017 10:37:07.905351 am) as C:\Users\Juan-Tuerca\PayloadSoftware\Cuis-Smalltalk-Dev\Cuis5.0-3045-spur.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3042] on 10 February 2017 at 5:39:28 pm'! - -Object subclass: #ProgessiveTestRunner - instanceVariableNames: 'testSuite testsStream progressBar testResult testRunIncrement' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Testing'! - -!classDefinition: #ProgessiveTestRunner category: #'Tools-Testing'! -Object subclass: #ProgessiveTestRunner - instanceVariableNames: 'testSuite testsStream progressBar testResult testRunIncrement' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Testing'! -!Browser methodsFor: 'tdd' stamp: 'HAW 2/10/2017 17:32:22'! -debugMethodTest - - currentCompiledMethod isTestMethod ifTrue: [ - currentCompiledMethod methodClass debugAsFailure: currentCompiledMethod selector ] -! ! -!Browser methodsFor: 'tdd' stamp: 'HAW 2/4/2017 20:33:00'! - runClassTests - - self selectedClassName ifNotNil: [ :aClassName | | selectedClass | - selectedClass _ Smalltalk classNamed: aClassName. - (ProgessiveTestRunner for: (TestSuite forClass: selectedClass)) value ]! ! -!Browser methodsFor: 'tdd' stamp: 'HAW 2/7/2017 10:47:50'! - runMessageCategoryTests - - selectedMessageCategory ifNotNil: [ | selectedClass suite | - selectedClass _ Smalltalk classNamed: selectedClassName. - suite _ TestSuite forMessageCategoryNamed: selectedMessageCategory of: selectedClass categorizedWith: classOrganizer. - (ProgessiveTestRunner for: suite) value ] - - ! ! -!Browser methodsFor: 'tdd' stamp: 'HAW 2/4/2017 21:51:50'! - runMethodTest - - | suite | - - suite _ TestSuite forCompiledMethod: currentCompiledMethod. - (ProgessiveTestRunner for: suite) value - ! ! -!Browser methodsFor: 'tdd' stamp: 'HAW 2/1/2017 19:23:54'! - runSystemCategoryTests - - selectedSystemCategory ifNotNil: [ | suite | - suite _ TestSuite forSystemCategoryNamed: selectedSystemCategory using: systemOrganizer. - (ProgessiveTestRunner for: suite) value ] - - ! ! -!Behavior methodsFor: 'tdd' stamp: 'HAW 2/7/2017 11:55:50'! - testCaseClass - - self subclassResponsibility ! ! -!Behavior methodsFor: 'tdd' stamp: 'HAW 2/7/2017 11:55:40'! - withTestCaseClassDo: aFoundTestCaseClassBlock ifNone: aNoneBlock - - | potentialTestCaseClass | - - potentialTestCaseClass _ self testCaseClass. - - ^potentialTestCaseClass ifNil: aNoneBlock ifNotNil: aFoundTestCaseClassBlock - ! ! -!Class methodsFor: 'tdd' stamp: 'HAW 2/7/2017 10:42:40'! -testCaseClass - - | potentialTestCaseClass | - - potentialTestCaseClass _ Smalltalk classNamed: self name, 'Test'. - - ^potentialTestCaseClass - - ! ! -!Metaclass methodsFor: 'tdd' stamp: 'HAW 2/7/2017 11:56:51'! - testCaseClass - - ^self soleInstance testCaseClass ! ! -!Categorizer methodsFor: 'tdd' stamp: 'HAW 2/7/2017 09:06:13'! - classesAt: aCategoryName - - ^(self listAtCategoryNamed: aCategoryName) collect: [:aClassName | Smalltalk classNamed: aClassName ] - ! ! -!Categorizer methodsFor: 'tdd' stamp: 'HAW 2/7/2017 09:06:34'! - testCaseClassesAt: aCategoryName - - ^(self classesAt: aCategoryName) select: [ :aClass | aClass is: #TestCaseClass ]! ! -!SmalltalkEditor methodsFor: 'editing keys' stamp: 'HAW 2/10/2017 16:03:46'! - acceptAndDebugTest: aKeyboardEvent - - ^self acceptAndDebugTest ! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HAW 2/10/2017 17:34:45'! - acceptAndDebugTest - - ^self acceptAndWithMethodDo: [ :aPotencialTestMethod | - aPotencialTestMethod isTestMethod ifTrue: [ aPotencialTestMethod methodClass debugAsFailure: aPotencialTestMethod selector ]]! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HAW 2/10/2017 17:34:38'! - acceptAndWithMethodDo: aBlock - - | potencialTestMethod | - - self acceptContents ifFalse: [ ^false ]. - - potencialTestMethod _ self codeProvider currentCompiledMethod. - ^potencialTestMethod - ifNil: [ false ] - ifNotNil: [ - aBlock value: potencialTestMethod. - true]! ! -!ProgessiveTestRunner methodsFor: 'initialization' stamp: 'HAW 2/1/2017 19:20:06'! - initializeFor: aTestSuite - - testSuite _ aTestSuite. - ! ! -!ProgessiveTestRunner methodsFor: 'evaluating' stamp: 'HAW 1/31/2017 11:50:37'! - value - - testsStream _ ReadStream on: testSuite tests. - testsStream atEnd - ifTrue: [ self informNoTestToRun ] - ifFalse:[ self createProgressBarAndRun ]! ! -!ProgessiveTestRunner methodsFor: 'progress bar - private' stamp: 'HAW 1/31/2017 10:25:22'! - calculateTestRunIncrement - - testRunIncrement _ 1/testsStream size! ! -!ProgessiveTestRunner methodsFor: 'progress bar - private' stamp: 'HAW 1/31/2017 10:25:31'! - createProgressBar - - progressBar _ ProgressMorph label: testSuite name. - self calculateTestRunIncrement. - self updateProgressBarSubLabel. - ! ! -!ProgessiveTestRunner methodsFor: 'progress bar - private' stamp: 'HAW 1/31/2017 10:25:43'! - updateDoneIncrement - - progressBar incrDone: testRunIncrement - ! ! -!ProgessiveTestRunner methodsFor: 'progress bar - private' stamp: 'HAW 1/31/2017 11:10:25'! - updateProgressBarSubLabel - - testsStream atEnd ifFalse: [ - progressBar subLabel: testsStream next printString, ' (', testsStream position printString, '/', testsStream size printString, ')' ].! ! -!ProgessiveTestRunner methodsFor: 'show result - private' stamp: 'HAW 1/31/2017 20:05:25'! - informAllTestPassed - - PopUpMenu inform: testResult printString. - ! ! -!ProgessiveTestRunner methodsFor: 'show result - private' stamp: 'HAW 1/31/2017 10:05:21'! - informNoTestToRun - - PopUpMenu inform: 'No test to run'! ! -!ProgessiveTestRunner methodsFor: 'show result - private' stamp: 'HAW 2/1/2017 19:26:08'! - openTestResultForDebuggingAndInspection - - testResult forDebuggingAndInspection inspect ! ! -!ProgessiveTestRunner methodsFor: 'show result - private' stamp: 'HAW 1/31/2017 10:10:53'! - showDeffects - - | defects | - - defects _ testResult defects. - defects size = 1 - ifTrue: [ defects anyOne debug ] - ifFalse: [ self openTestResultForDebuggingAndInspection]! ! -!ProgessiveTestRunner methodsFor: 'evaluating - private' stamp: 'HAW 2/1/2017 19:14:08'! - createProgressBarAndRun - - self createProgressBar. - [ self runSuiteShowingProgress ] fork! ! -!ProgessiveTestRunner methodsFor: 'evaluating - private' stamp: 'HAW 2/1/2017 19:26:59'! - registerTestSuiteAction - - testSuite when: #changed: send: #testRun: to: self! ! -!ProgessiveTestRunner methodsFor: 'evaluating - private' stamp: 'HAW 1/31/2017 10:09:41'! - runSuite - - testResult _ testSuite run. - testResult hasPassed - ifTrue: [ self informAllTestPassed ] - ifFalse: [self showDeffects ] - ! ! -!ProgessiveTestRunner methodsFor: 'evaluating - private' stamp: 'HAW 1/31/2017 11:47:58'! - runSuiteShowingProgress - - [ self registerTestSuiteAction. - progressBar openInWorld. - self runSuite ] ensure: [ - self unregisterTestSuiteAction. - WorldState addDeferredUIMessage: [progressBar dismissMorph] ]. - ! ! -!ProgessiveTestRunner methodsFor: 'evaluating - private' stamp: 'HAW 2/1/2017 19:19:28'! - testRun: aTest - - self updateProgressBarSubLabel. - self updateDoneIncrement - - ! ! -!ProgessiveTestRunner methodsFor: 'evaluating - private' stamp: 'HAW 1/31/2017 10:04:32'! - unregisterTestSuiteAction - - testSuite releaseActionMap ! ! -!ProgessiveTestRunner class methodsFor: 'instance creation' stamp: 'HAW 1/31/2017 09:37:34'! - for: aTestSuite - - ^self new initializeFor: aTestSuite! ! -!TestCase class methodsFor: 'Instance Creation' stamp: 'HAW 2/10/2017 16:01:40'! - debugAsFailure: aSymbol - - ^(self selector: aSymbol) debugAsFailure - ! ! -!TestSuite class methodsFor: 'Creation' stamp: 'HAW 2/4/2017 20:31:47'! - forClass: aClass - - ^(aClass is: #TestCaseClass) - ifTrue: [ self forTestCaseClass: aClass ] - ifFalse: [ self forNoTestCaseClass: aClass ] -! ! -!TestSuite class methodsFor: 'Creation' stamp: 'HAW 2/4/2017 21:53:12'! - forCompiledMethod: aCompiledMethod - - ^aCompiledMethod isTestMethod - ifTrue: [ self forTestMethod: aCompiledMethod ] - ifFalse: [ self forNoTestMethod: aCompiledMethod ] - ! ! -!TestSuite class methodsFor: 'Creation' stamp: 'HAW 2/1/2017 18:43:22'! - forMessageCategoryNamed: aMessageCategoryName of: aClass categorizedWith: aClassOrganizer - - | suite | - - suite _ self named: aClass name, ' tests categorized under ',aMessageCategoryName. - (aClassOrganizer listAtCategoryNamed: aMessageCategoryName) do: [ :selector | - (aClass compiledMethodAt: selector) isTestMethod ifTrue: [ suite addTest: (aClass selector: selector) ]]. - - ^suite - ! ! -!TestSuite class methodsFor: 'Creation' stamp: 'HAW 2/7/2017 10:24:12'! - forSystemCategoryNamed: aCategoryName using: aSystemOrganizer - - | testCaseClasses | - - testCaseClasses _ aSystemOrganizer testCaseClassesAt: aCategoryName. - - ^testCaseClasses isEmpty - ifTrue: [ self forClasses: (aSystemOrganizer classesAt: aCategoryName) named: aCategoryName, ' infered tests' ] - ifFalse: [ self forTestCaseClasses: testCaseClasses named: aCategoryName, ' tests' ] - -! ! -!TestSuite class methodsFor: 'Creation - Private' stamp: 'HAW 2/7/2017 10:25:51'! - allTestCaseClassesReferencing: aClass - - ^(aClass allCallsOn - collect: [ :aMethodReference | aMethodReference actualClass ] - thenSelect: [ :aPotentialTestCaseClass | aPotentialTestCaseClass is: #TestCaseClass ]) asSet.! ! -!TestSuite class methodsFor: 'Creation - Private' stamp: 'HAW 2/7/2017 10:27:27'! - allTestsSending: aSelector - - ^(Smalltalk allCallsOn: aSelector) select: [:aMethodReference | - (aMethodReference actualClass is: #TestCaseClass) and: [aMethodReference compiledMethod isTestMethod ]].! ! -!TestSuite class methodsFor: 'Creation - Private' stamp: 'HAW 2/7/2017 09:08:23'! - forClasses: classes named: name - - | suite | - - suite _ classes - inject: (self named: name) - into: [ :partialSuite :aClass | partialSuite addTests: (self forClass: aClass) tests ]. - - ^suite - -! ! -!TestSuite class methodsFor: 'Creation - Private' stamp: 'HAW 2/7/2017 10:32:17'! - forNoTestCaseClass: aClass - - ^aClass - withTestCaseClassDo: [ :aTestCaseClass | self forTestCaseClass: aTestCaseClass ] - ifNone: [ self forReferencesToClass: aClass ] - -! ! -!TestSuite class methodsFor: 'Creation - Private' stamp: 'HAW 2/7/2017 11:28:55'! - forNoTestMethod: aCompiledMethod - - | allTestSenders testCaseClassesReferencingClass reducedTestSenders suite | - - allTestSenders _ self allTestsSending: aCompiledMethod selector. - testCaseClassesReferencingClass _ aCompiledMethod methodClass - withTestCaseClassDo: [:aTestCaseClass | Array with: aTestCaseClass ] - ifNone: [ self allTestCaseClassesReferencing: aCompiledMethod methodClass ]. - - reducedTestSenders _ allTestSenders select: [ :aMethodReference | testCaseClassesReferencingClass includes: aMethodReference actualClass ]. - reducedTestSenders isEmpty - ifTrue: [ suite _ self forClass: aCompiledMethod methodClass ] - ifFalse: [ - suite _ self named: 'Tests senders of ', aCompiledMethod selector. - reducedTestSenders do: [ :aMethodReference | suite addTest: (aMethodReference actualClass selector: aMethodReference selector)]]. - - ^suite! ! -!TestSuite class methodsFor: 'Creation - Private' stamp: 'HAW 2/7/2017 10:33:27'! - forReferencesToClass: aClass - - | testCaseClasses | - - testCaseClasses _ self allTestCaseClassesReferencing: aClass. - - ^testCaseClasses - inject: (self named: aClass name, ' all test references') - into: [ :suite :aTestCaseClass | aTestCaseClass addToSuiteFromSelectors: suite ] - - -! ! -!TestSuite class methodsFor: 'Creation - Private' stamp: 'HAW 2/7/2017 10:34:27'! - forTestCaseClass: aTestCaseClass - - | suite | - - suite _ aTestCaseClass buildSuite. - suite name: aTestCaseClass name, ' tests'. - - ^suite! ! -!TestSuite class methodsFor: 'Creation - Private' stamp: 'HAW 2/7/2017 09:04:48'! - forTestCaseClasses: testCaseClasses named: aName - - | suite | - - suite _ testCaseClasses - inject: (self named: aName) - into: [:partialSuite :aTestCaseClass | aTestCaseClass addToSuiteFromSelectors: partialSuite ]. - - ^suite! ! -!TestSuite class methodsFor: 'Creation - Private' stamp: 'HAW 2/4/2017 21:53:22'! - forTestMethod: aCompiledMethod - - | suite | - - suite _ self named: 'Test'. - suite addTest: (aCompiledMethod methodClass selector: aCompiledMethod selector). - - ^suite - ! ! -!UndefinedObject methodsFor: 'class hierarchy' stamp: 'HAW 2/10/2017 17:37:23'! - allSuperclassesUpTo: aSuperclass - - self error: (self superclassNotValidErrorDescriptionFor: aSuperclass)! ! -!UndefinedObject methodsFor: 'class hierarchy' stamp: 'HAW 2/10/2017 17:37:30'! - superclassNotValidErrorDescriptionFor: aClass - - ^aClass name, ' not in superclasses chain'! ! -!Behavior methodsFor: 'system-support' stamp: 'HAW 2/4/2017 20:51:10' prior: 16785122! - allCallsOn - "Answer a SortedCollection of all the methods that refer to me by name or - as part of an association in a global dict." - " - ^ (Smalltalk - allCallsOn: (Smalltalk associationAt: self theNonMetaClass name)) - , (Smalltalk allCallsOn: self theNonMetaClass name) - " - - ^ Smalltalk allCallsOn: self theNonMetaClass name! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'HAW 2/4/2017 20:49:09' prior: 16923905! - browseAllCallsOnClass: aClass - "Create and schedule a message browser on each method that refers to - aClass. For example, Smalltalk browseAllCallsOnClass: Object." - self - browseMessageList: aClass allCallsOn asArray sort - name: 'Users of class ' , aClass theNonMetaClass name - autoSelect: aClass theNonMetaClass name.! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HAW 2/1/2017 18:51:22' prior: 50336080! - acceptAndTest - - self acceptThenTestMethodAndSuite: [ :aMethod | self testSuiteOf: aMethod methodClass ]. - ^true! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HAW 2/1/2017 18:50:41' prior: 50336086! - acceptAndTestAll - - self acceptThenTestMethodAndSuite: [ :aMethod | self testSuiteForCategoryOf: aMethod methodClass ]. - ^true - - ! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HAW 2/10/2017 17:34:52' prior: 50336093! - acceptThenTestMethodAndSuite: aSuiteBuilder - - self acceptAndWithMethodDo: [ :aPotencialTestMethod | - self runAndDebuggIfNecessary: aPotencialTestMethod. - self runTestSuite: (aSuiteBuilder value: aPotencialTestMethod) ]! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HAW 2/10/2017 16:08:47' prior: 50336115! - runAndDebuggIfNecessary: aPotencialTestMethod - - aPotencialTestMethod isTestMethod ifTrue: [ - aPotencialTestMethod methodClass debug: aPotencialTestMethod selector ]! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HAW 2/1/2017 19:19:02' prior: 50336123! - runTestSuite: aTestSuite - - (ProgessiveTestRunner for: aTestSuite) value - - ! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HAW 2/5/2017 10:49:25' prior: 50336133! - testSuiteForCategoryOf: aClass - - ^TestSuite forSystemCategoryNamed: aClass category using: SystemOrganization -! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HAW 2/5/2017 10:48:27' prior: 50336150! - testSuiteOf: aClass - - ^TestSuite forClass: aClass -! ! -!SmalltalkEditor class methodsFor: 'keyboard shortcut tables' stamp: 'HAW 2/10/2017 15:58:27' prior: 50336377! - cmdShortcutsSpec - " - Editor initialize - " - "arranged in QWERTY keyboard order" - ^#( - #( $r #acceptAndDebugTest: 'Saves method and debugs it') - #( $t #acceptAndTest: 'Saves method, runs it as test and then all tests in class. Opens debugger if error') - #( $y #acceptAndTestAll: 'Saves method, runs it as test and then all tests in class category. Opens debugger if error') - #( $i #inspectIt: 'Inspect it (selection is a valid expression, or selection is over an inspect-ilst)') - #( $p #printIt: 'Print it (selection is a valid expression)') - - #( $s #save: 'Save (i.e. accept)') - #( $d #doIt: 'Do it (selection is a valid expression)') - #( $l #cancelEdits: 'Cancel') - - #( $b #browseIt: 'Browse it (selection is a class name or cursor is over a class-list or message-list)') - #( $n #sendersOfIt: 'Senders of it (selection is a message selector or cursor is over a class-list or message-list)') - #( $m #implementorsOfIt: 'Implementors of it (selection is a message selector or cursor is over a class-list or message-list)') - - #( $E #methodStringsContainingit:'Method strings containing it') - #( $T #displayIfTrue: 'Insert #ifTrue:') - #( $I #exploreIt: 'Inspect via Object Explorer') - - #( $A #argAdvance: 'Advance argument') - #( $D #debugIt: 'Debut it') - #( $F #displayIfFalse: 'Insert #ifFalse:') - #( $G #fileItIn: 'File in selection') - - #( $V #pasteInitials: 'Paste author initials') - #( $N #referencesToIt: 'References to it (selection is a class name, or cursor is over a class-list or message-list)') - )! ! -!SmalltalkEditor class methodsFor: 'keyboard shortcut tables' stamp: 'HAW 2/10/2017 15:57:40' prior: 50336431! - initializeMenu - "Initialize the mouseButton2 (right button) pop-up menu and corresponding messages." - " - Editor initialize - " - - menu _ SelectionMenu fromArray: { - {'Help...'. #openHelp}. - #-. - {'Do it (d)'. #doIt}. - {'Print it (p)'. #printIt}. - {'Inspect it (i)'. #inspectIt}. - {'Explore it (I)'. #exploreIt}. - {'Debug it (D)'. #debugIt}. - {'Profile it'. #profileIt}. - #-. - {'Explain'. #explain}. - {'Browse it (b)'. #browseIt}. - {'Senders of it (n)'. #sendersOfIt}. - {'Implementors of it (m)'. #implementorsOfIt}. - {'References to it (N)'. #referencesToIt}. - #-. - {'Method Strings with it (E)'. #methodStringsContainingit}. - {'Method Source with it'. #methodSourceContainingIt}. - {'Class Comments with it'. #classCommentsContainingIt}. - #-. - {'Accept (s)'. #acceptContents}. - {'Cancel (l)'. #cancelEdits}. - {'Accept & Run Test in Class (t)'. #acceptAndTest}. - {'Accept & Run Test in Category (y)'. #acceptAndTestAll}. - {'Accept & Debug Test (r)'. #acceptAndDebugTest}. - #-. - {'More...'. #getMenu2}. - }. - menu2 _ SelectionMenu fromArray: { - {'Find...(f)'. #find}. - {'Find Again (g)'. #findAgain}. - {'Use Selection for Find (j)'. #setSearchString}. - #-. - {'Undo - multiple (z)'. #undo}. - {'Redo - multiple (Z)'. #redo}. - {'Undo / Redo history'. #offerUndoHistory}. - #-. - {'Copy (c)'. #copySelection}. - {'Cut (x)'. #cut}. - {'Paste (v)'. #paste}. - {'Paste without Format'. #pasteString}. - {'Paste...'. #pasteRecent}. - #-. - {'Toggle WordWrap'. #wrapOnOff}. - {'Set Font... (k)'. #offerFontMenu}. - {'Clear Font'. #clearFont}. - {'Set Default Font...'. #offerDefaultFontMenu}. - #-. - {'More...'. #getMenu}. - }! ! -!CodeWindow methodsFor: 'keyboard shortcuts' stamp: 'HAW 1/31/2017 11:56:31' prior: 16813767! - classListKey: aChar from: view - "Respond to a Command key. I am a model with a list of classes and a - code pane, and I also have a listView that has a list of methods. The - view knows how to get the list and selection." - - aChar == $r ifTrue: [^ model recent]. - aChar == $h ifTrue: [^ self browseHierarchy]. - aChar == $x ifTrue: [^ model removeClass]. - aChar == $t ifTrue: [^ model runClassTests ]. - - ^ self messageListKey: aChar from: view! ! -!CodeWindow methodsFor: 'keyboard shortcuts' stamp: 'HAW 2/10/2017 17:33:25' prior: 16813782! - messageListKey: aChar from: view - "Respond to a Command key. I am a model with a code pane, and I also - have a listView that has a list of methods. The view knows how to get - the list and selection." - - | sel class | - aChar == $D ifTrue: [^ model toggleDiffing]. - - sel _ model selectedMessageName. - aChar == $m ifTrue: [ "These next two put up a type in if no message selected" - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllImplementorsOf: to: Smalltalk]. - aChar == $n ifTrue: [ - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllCallsOn: to: Smalltalk]. - - "The following require a class selection" - (class _ model selectedClassOrMetaClass) ifNil: [^ self ]. - aChar == $b ifTrue: [^ BrowserWindow fullOnClass: class selector: sel]. - aChar == $N ifTrue: [^ self browseClassRefs]. - aChar == $i ifTrue: [^ self methodHierarchy]. - aChar == $h ifTrue: [^ self browseHierarchy]. - aChar == $p ifTrue: [^ self browseFullProtocol]. - - "The following require a method selection" - sel ifNotNil: [ - aChar == $o ifTrue: [^ model fileOutMessage]. - aChar == $c ifTrue: [^ model copySelector]. - aChar == $v ifTrue: [^ self browseVersions]. - aChar == $O ifTrue: [^ self openSingleMessageBrowser]. - aChar == $x ifTrue: [^ model removeMessage]. - aChar == $t ifTrue: [^ model runMethodTest]. - aChar == $r ifTrue: [^ model debugMethodTest]]! ! -!CodeWindow methodsFor: 'keyboard shortcuts' stamp: 'HAW 2/7/2017 10:49:07' prior: 16813824! - systemCatListKey: aChar from: view - "Respond to a Command key. I am a model with a code pane, and I also have a listView that has a list of methods. The view knows how to get the list and selection." - - aChar == $f ifTrue: [^ self findClass]. - aChar == $x ifTrue: [^ model removeSystemCategory]. - aChar == $t ifTrue: [ ^model runSystemCategoryTests ]. - - ^ self classListKey: aChar from: view! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'HAW 1/31/2017 11:32:21' prior: 16793212! - classListMenu - "Set up the menu to apply to the receiver's class list, honoring the #shifted boolean" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addList: #( - ('browse full (b)' browseMethodFull) - ('browse hierarchy (h)' browseHierarchy) - ('browse protocol (p)' browseFullProtocol) - - - ('fileOut' fileOutClass '' model) - - - ('show hierarchy' hierarchy '' model) - ('show definition' editClass '' model) - ('show comment' editComment '' model) - - - ('inst var refs...' browseInstVarRefs) - ('inst var defs...' browseInstVarDefs) - - - ('class var refs...' browseClassVarRefs) - ('class vars' browseClassVariables) - ('class refs (N)' browseClassRefs) - - - ('rename class ...' renameClass '' model) - ('copy class...' copyClass '' model) - ('remove class (x)' removeClass '' model) - - - ('Run tests (t)' runClassTests '' model) - ('more...' offerShiftedClassListMenu)). - ^ aMenu! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'HAW 1/31/2017 19:57:02' prior: 16793244! - messageCategoryMenu - - | aMenu | - aMenu _ MenuMorph new defaultTarget: model. "All the options are for the model." - aMenu addList: #( - ('fileOut' fileOutMessageCategories) - - - ('reorganize' editMessageCategories) - ('alphabetize' alphabetizeMessageCategories) - ('remove empty categories' removeEmptyCategories) - ('categorize all uncategorized' categorizeAllUncategorizedMethods) - ('new category...' addCategory) - - - ('rename...' renameCategory) - ('remove' removeMessageCategory) - - - ('Run tests' runMessageCategoryTests)). - ^aMenu! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'HAW 2/10/2017 17:29:43' prior: 16793264! -messageListMenu - "Answer the message-list menu" - "Changed by emm to include menu-item for breakpoints" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addList:#( - ('what to show...' offerWhatToShowMenu) - ('toggle break on entry' toggleBreakOnEntry '' model) - - - ('browse full (b)' browseMethodFull) - ('browse hierarchy (h)' browseHierarchy) - ('browse method (O)' openSingleMessageBrowser) - ('browse protocol (p)' browseFullProtocol) - - - ('fileOut' fileOutMessage '' model) - - - ('senders of... (n)' browseSendersOfMessages) - ('implementors of... (m)' browseMessages) - ('inheritance (i)' methodHierarchy) - ('versions (v)' browseVersions) - - - ('inst var refs...' browseInstVarRefs) - ('inst var defs...' browseInstVarDefs) - ('class var refs...' browseClassVarRefs) - ('class variables' browseClassVariables) - ('class refs (N)' browseClassRefs) - - - ('remove method (x)' removeMessage '' model) - ('Run test (t)' runMethodTest '' model) - ('Debug test (r)' debugMethodTest '' model) - - - ('more...' openShiftedMessageListMenu)). - ^ aMenu -! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'HAW 1/31/2017 11:52:17' prior: 16793404! - systemCategoryMenu - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - self flag: #renameSystemCategory. "temporarily disabled" - aMenu addList: #( - ('find class... (f)' findClass) - ('recent classes... (r)' recent '' model) - - - ('browse all' browseAllClasses) - ('browse' openSystemCategoryBrowser) - - - ('fileOut' fileOutSystemCategory '' model) - - - ('reorganize' editSystemCategories '' model) - ('alphabetize' alphabetizeSystemCategories '' model) - - - ('update' updateSystemCategories '' model) - ('add item...' addSystemCategory '' model) -" ('rename...' renameSystemCategory '' model)" - ('remove' removeSystemCategory '' model) - - - ('move to top' moveSystemCategoryTop '' model) - ('move up' moveSystemCategoryUp '' model) - ('move down' moveSystemCategoryDown '' model) - ('move to bottom' moveSystemCategoryBottom '' model) - - - ('Run tests (t)' runSystemCategoryTests '' model)). - ^aMenu! ! -!Theme methodsFor: 'menus' stamp: 'HAW 2/10/2017 17:30:49' prior: 50336837! - miscellaneousIcons - - "Everything else." - - ^ { - #('restore display (r)' 'set display depth...' 'move windows onscreen' 'Utilities saveDisplay.') -> #displayIcon. - #('changes...' 'dual change sorter' 'change sets with this method' 'find a change sorter' 'recent changes in file' 'Undo / Redo history' 'code file contents' 'package file contents') -> #changesIcon. - #('Install New Updates' 'update' 'turn on auto-update (a)' 'update list (u)' 'install code' 'fileIn entire file' 'install package') -> #updateIcon. - #('find again (g)' 'full stack (k)') -> #systemIcon. - #('print it (p)' 'check change set for slips') -> #printIcon. - #('accept (s)' 'make changes go to me (m)') -> #acceptIcon. - #('cancel (l)' 'turn off auto-update (a)') -> #cancelIcon. - #('debug...' 'Debug it (D)' 'toggle break on entry') -> #debugIcon. - #('close' 'close all debuggers' 'close top window') -> #closeIcon. - #('collapse' 'hide taskbar' 'collapse all windows') -> #collapseIcon. - #('expand / contract' 'show taskbar' 'restore all windows') -> #expandIcon. - #('menu') -> #windowMenuIcon. - #('browse all' 'browser' 'browse it (b)' 'MessageTally UI and browse' 'browse recent submissions' 'browse full (b)' 'find changed browsers...' 'browse (b)' 'browse my changes') -> #editFindReplaceIcon. - #('workspace' 'workspace with contents') -> #terminalIcon. - #('styled text editor' 'text editor' 'basic text editor' 'unicode editor' 'edit this list' 'edit postscript...' 'add postscript...') -> #textEditorIcon. - #('file list' 'find a fileList' 'compress file') -> #systemFileManagerIcon. - #('transcript' 'find a transcript' 'Transcript clear.' 'log to transcript') -> #printerIcon. - #('process browser' 'vm statistics' 'MessageTally all Processes') -> #systemMonitorIcon. - #('emergency evaluator' 'conflicts with other change sets' 'check for slips' 'conflicts with change set opposite' 'conflicts with category opposite') -> #emblemImportantIcon. - #('change sorter') -> #halfRefreshIcon. - #('SUnit Test Runner' 'Accept & Run Test in Class (t)' 'Accept & Run Test in Category (y)' 'Run tests (t)' 'Run tests' 'Run test (t)' 'Accept & Debug Test (r)' 'Debug test (r)') -> #weatherFewCloudsIcon. - #('Font Sizes...' 'system fonts...' 'set font... (k)') -> #preferencesDesktopFontIcon. - #('full screen on') -> #viewFullscreenIcon. - #('full screen off') -> #exitFullscreenIcon. - #('set desktop color...') -> #wallpaperIcon. - #('preferences...' 'All preferences...' 'what to show...' 'view as hex') -> #preferencesIcon. - #('Editor keyboard shortcuts') -> #keyboardShortcutsIcon. - #('world menu help') -> #globeIcon. "currently unused, but a neat icon" - #('useful expressions' 'class comments with it' 'check for uncommented methods' 'check for uncommented classes') -> #chatIcon. - #('set code author...' 'check for other authors' 'check for any other authors') -> #usersIcon. - #('space left') -> #removableMediaIcon. - #('start drawing all again' 'window color...') -> #graphicsIcon. - #('start stepping again') -> #mediaPlaybackStartIcon. - #('file out current change set' 'fileOut' 'File out and remove (o)' 'File out and keep (k)') -> #fileOutIcon. - #('recently logged changes...' 'versions (v)' 'recent classes... (r)' 'trim history' 'Profile it') -> #clockIcon. - #('senders of it (n)' 'senders of... (n)' 'local senders of...' 'senders (n)') -> #mailForwardIcon. - #('implementors of it (m)' 'implementors of... (m)' 'implementors of sent messages') -> #developmentIcon. - #('references to it (N)') -> #addressBookIcon. - #('class var refs...' 'class refs (N)' 'class variables' 'class vars' 'local implementors of...' 'subclass template') -> #classIcon. - #('inst var refs...' 'inst var defs...' 'sample instance') -> #instanceIcon. - #('Use Selection for Find (j)' 'rename class ...' 'rename...' 'change title...') -> #saveAsIcon. - #('smalltalk options' 'method source with it' 'browse method (O)' 'check for uncategorized methods') -> #scriptIcon. - #('method strings with it (E)' 'Toggle WordWrap') -> #genericTextIcon. - #('browse hierarchy (h)' 'move to top' 'promote to top of list') -> #goTopIcon. - #('move up' 'make next-to-topmost') -> #goUpIcon. - #('move to bottom' 'send to back' 'send top window to back') -> #goBottomIcon. - #('inheritance (i)' 'move down') -> #goDownIcon. - #('browse protocol (p)' 'spawn sub-protocol') -> #spreadsheetIcon. - #('spawn full protocol') -> #speadsheetTemplateIcon. - #('alphabetize') -> #fontXGenericIcon. - #('Installed Packages' 'browse' 'show category (C)' 'categorize all uncategorized' 'select change set...' 'view affected class categories') -> #packageIcon. - #('remove from current change set' 'remove empty categories' 'subtract other side (-)' 'remove from this browser') -> #listRemoveIcon. - #('add to current change set' 'add all meths to current chgs' 'add preamble (p)' 'More...') -> #listAddIcon. - #('toggle diffing (D)' 'toggle selections') -> #switchIcon. - #('reorganize' 'create inst var accessors' 'ChangeSorter reorderChangeSets.' 'reorder all change sets' 'by name' 'by size' 'by date') -> #sendReceiveIcon. - #('unsent methods' 'unreferenced class vars' 'unreferenced inst vars' 'Undeclared inspect.' 'Undeclared removeUnreferencedKeys; inspect.' 'ChangeSorter removeEmptyUnnamedChangeSets.' 'check for unsent messages') -> #junkIcon. - #('find changed windows...') -> #newWindowIcon. - #('make undraggable') -> #pushPinIcon. - #('Utilities saveScreenshot.') -> #stillCameraIcon. - #('add new directory') -> #newFolderIcon. - #('select all' 'deselect all') -> #selectAllIcon. - #('sort by date') -> #dateIcon. - #('justified') -> #formatJustifyFillIcon. - #('centered') -> #formatJustifyCenterIcon. - #('set alignment...' 'leftFlush') -> #formatJustifyLeftIcon. - #('rightFlush') -> #formatJustifyRightIcon. - #('signal Semaphore (S)') -> #haloHelpIcon. - #('Change Paragraph Style...' 'Change Character Style...' 'Remove Character Style' 'Replace all uses of Paragraph Style...' 'Replace all uses of Character Style...' 'Set Default Font...') -> #fontXGenericIcon. - #('Clear Font') -> #newIcon. - #('code file browser' 'package file browser') -> #findIcon. - }! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 2/10/2017 17:37:41'! - should: aBlock raise: anExceptionalType withExceptionDo: assertionsBlock - - ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalType withExceptionDo: assertionsBlock) - ! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 2/10/2017 17:38:10'! - executeShould: aBlock inScopeOf: anExceptionType withExceptionDo: assertionsBlock - - ^[aBlock value. - false] - on: anExceptionType - do: [:exception | - assertionsBlock value: exception. - exception sunitExitWith: true]! ! -!TestCase class methodsFor: 'Testing' stamp: 'HAW 2/10/2017 16:32:10' prior: 50336183! - is: aSymbol - - ^self ~= TestCase - and: [ aSymbol == #TestCaseClass or: [ super is: aSymbol ]]! ! -!TestCase class methodsFor: 'Testing' stamp: 'HAW 2/1/2017 19:35:57' prior: 16927731! - shouldInheritSelectors - "I should inherit from an Abstract superclass but not from a concrete one by default, unless I have no testSelectors in which case I must be expecting to inherit them from my superclass. If a test case with selectors wants to inherit selectors from a concrete superclass, override this to true in that subclass." - - ^self ~= TestCase - and: [ self superclass isAbstract or: [self testSelectors isEmpty]] - -"$QA Ignore:Sends system method(superclass)$" - ! ! -!TestResultForDebuggingAndInspection methodsFor: 'printing' stamp: 'HAW 2/7/2017 10:51:56' prior: 50336200! - print: aCollectionOfTestCases startingWith: header on: aStream - - aCollectionOfTestCases do: [ :aTestCase | - aStream - nextPutAll: header; - space; - nextPutAll: aTestCase class name; - nextPutAll: ' debug: #'; - nextPutAll: aTestCase selector; - newLine ] - - - ! ! - -TestSuite class removeSelector: #allTestCasesReferencing:! - -TestSuite class removeSelector: #allTestReferencesTo:! - -TestSuite class removeSelector: #allTestsReferencing:! - -TestSuite class removeSelector: #from:using:! - -TestSuite class removeSelector: #fromClass:! - -TestSuite class removeSelector: #fromSystemCategoryNamed:using:! - -ProgessiveTestRunner removeSelector: #initializeFor:informingResultUsing:! - -ProgessiveTestRunner removeSelector: #initializeFor:showingTestPassedWith:! - -ProgessiveTestRunner removeSelector: #showProgressBarAndRunSuite! - -SmalltalkEditor removeSelector: #acceptAndWithTestMethodDo:! - -SmalltalkEditor removeSelector: #flashWith:! - -SmalltalkEditor removeSelector: #flashWith:! - -SmalltalkEditor removeSelector: #flashWithGreen! - -SmalltalkEditor removeSelector: #flashWithGreen! - -Categorizer removeSelector: #testCasesAt:! - -Class removeSelector: #withTestCaseClassDo:ifNone:! - -Behavior removeSelector: #withTestClassDo:ifNone:! - -----End fileIn of C:\Users\Juan-Tuerca\PayloadSoftware\Cuis-Smalltalk-Dev\CoreUpdates\3046-TestRunningHelpers-HernanWilkinson-2017Jan31-09h21m-HAW.5.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3046] on 1 March 2017 at 12:34:07 pm'! -!CodeFile methodsFor: 'change record types' stamp: 'jmv 3/1/2017 12:31:23' prior: 16808869! - doIt: chgRec - "See senders of #doIt " - | string | - string := chgRec string. - - "Method classification spec" - (string beginsWith: '(''') ifTrue: [ - ^ doIts add: chgRec ]. - - "Just for compatibility with Squeak, as Cuis always adds the #classDefinition change type marker in the files." - ('*ubclass:*instanceVariableNames:*classVariableNames:*poolDictionaries:*category:*' - match: string) ifTrue:[^self classDefinition: string with: chgRec]. - - "Just for compatibility with Squeak, as Cuis always adds the #classDefinition change type marker in the files." - ('* class*instanceVariableNames:*' - match: string) ifTrue:[^self metaClassDefinition: string with: chgRec]. - - "Just for compatibility with Squeak, as Cuis always adds the #methodRemoval: (or similar) change type marker in the files." - ('* removeSelector: *' - match: string) ifTrue:[^self removedMethod: string with: chgRec]. - - "Just for compatibility with Squeak, as Cuis always adds the #classComment change type marker in the files." - ('* comment:*' - match: string) ifTrue:[^self msgClassComment: string with: chgRec]. - - "Don't add these to a CodeFile. They will be added on save if needed." - ('* initialize' - match: string) ifTrue:[^self]. "Initialization is done based on class>>initialize" - - ('''From *' - match: string) ifTrue:[^self possibleSystemSource: chgRec]. - doIts add: chgRec.! ! - -----End fileIn of C:\Users\Juan-Tuerca\PayloadSoftware\Cuis-Smalltalk-Dev\CoreUpdates\3047-FileCodeBrowserFix-JuanVuletich-2017Mar01-12h33m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3047] on 2 March 2017 at 10:50:58 am'! - -BorderedRectMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp popUpOwner activeSubMenu titleMorph oldKeyboardFocus ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #MenuMorph category: #'Morphic-Menus'! -BorderedRectMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp popUpOwner activeSubMenu titleMorph oldKeyboardFocus' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! -!MenuMorph commentStamp: '' prior: 16866262! - Instance variables: - defaultTarget The default target for creating menu items - selectedItem The currently selected item in the receiver - stayUp True if the receiver should stay up after clicks! -!MenuMorph methodsFor: 'control' stamp: 'jmv 3/2/2017 10:47:30' prior: 16866663! - deleteIfPopUp: evt - "Remove this menu from the screen if stayUp is not true." - - stayUp ifFalse: [ self delete ]. - evt ifNotNil: [ evt hand ifNotNil: [ :h | h releaseMouseFocus: self ]]! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 3/2/2017 10:48:01' prior: 16866680! - popUpAdjacentTo: rightOrLeftPointInWorld from: sourceItem - "Present this menu at the given point under control of the given hand. - Used mostly for submenus." - - | delta tryToPlace selectedOffset | - selectedOffset _ (selectedItem ifNil: [ self items first ]) morphPosition. - sourceItem world addMorphFront: self. - - tryToPlace _ [ :where :mustFit | - self morphPosition: where - selectedOffset. - delta _ self morphFullBoundsInWorld - amountToTranslateWithin: sourceItem world morphBoundsInWorld. - (delta x = 0 | mustFit) ifTrue: [ - delta = (0@0) ifFalse: [ self morphPosition: self morphPosition + delta ]. - ^ self]]. - tryToPlace - value: rightOrLeftPointInWorld first value: false; - value: rightOrLeftPointInWorld last - (extent x @ 0) value: false; - value: rightOrLeftPointInWorld first value: true! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 3/2/2017 10:48:31' prior: 16866709! - popUpAt: aPoint forHand: hand allowKeyboard: aBoolean - "Present this menu at the given point under control of the given hand." - - | evt | - self items isEmpty ifTrue: [^self]. - Theme current decorateMenu: self. - (self submorphs select: [ :m | m is: #UpdatingMenuItemMorph ]) - do: [ :m | m updateContents]. - self runningWorld addMorphFront: self position: aPoint - (2 @ 8). - self fitInWorld. - "Acquire focus for valid pop up behavior" - hand newMouseFocus: self. - aBoolean ifTrue: [ hand newKeyboardFocus: self ]. - evt _ hand lastMouseEvent. - (evt isKeyboard or: [ evt isMouse and: [ evt anyButtonPressed not ]]) - ifTrue: [ - "Select first item if button not down" - self moveSelectionDown: 1 event: evt ]! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 3/2/2017 10:48:26' prior: 16866745! - popUpAt: aPoint forHand: hand in: aWorld allowKeyboard: aBoolean - "Present this menu at the given point under control of the given hand." - - self items isEmpty ifTrue: [ ^self ]. - Theme current decorateMenu: self. - (self submorphs select: [ :m | m is: #UpdatingMenuItemMorph]) - do: [ :m | m updateContents]. - aWorld addMorphFront: self position: aPoint - (2 @ 8). - self fitInWorld. - "Acquire focus for valid pop up behavior" - hand newMouseFocus: self. - aBoolean ifTrue: [ hand newKeyboardFocus: self ]! ! -!MenuMorph methodsFor: 'events' stamp: 'jmv 3/2/2017 10:47:45' prior: 16866819! - keyStroke: aKeyboardEvent - | matchString char asc selectable | - char := aKeyboardEvent keyCharacter. - asc := char numericValue. - aKeyboardEvent isReturnKey - ifTrue: [ - selectedItem ifNotNil: [ - selectedItem hasSubMenu - ifTrue: [ - aKeyboardEvent hand newMouseFocus: selectedItem subMenu. - ^aKeyboardEvent hand newKeyboardFocus: selectedItem subMenu] - ifFalse: [ - "self delete." - ^selectedItem invokeWithEvent: aKeyboardEvent]]. - (selectable := self items) size = 1 - ifTrue: [^selectable first invokeWithEvent: aKeyboardEvent]. - ^self]. - asc = 27 - ifTrue: [ - "escape key" - self - valueOfProperty: #matchString - ifPresentDo: [ :str | - str isEmpty - ifFalse: [ - "If filtered, first ESC removes filter" - self setProperty: #matchString toValue: String new. - self selectItem: nil. - ^self displayFiltered: aKeyboardEvent]]. - "If a stand-alone menu, just delete it" - ^self delete]. - (asc = 28 or: [asc = 29]) - ifTrue: [ - "left or right arrow key" - (selectedItem notNil and: [selectedItem hasSubMenu]) - ifTrue: [ - aKeyboardEvent hand newMouseFocus: selectedItem subMenu. - selectedItem subMenu moveSelectionDown: 1 event: aKeyboardEvent. - ^aKeyboardEvent hand newKeyboardFocus: selectedItem subMenu]]. - asc = 30 ifTrue: [^self moveSelectionDown: -1 event: aKeyboardEvent]. "up arrow key" - asc = 31 ifTrue: [^self moveSelectionDown: 1 event: aKeyboardEvent]. "down arrow key" - asc = 11 ifTrue: [^self moveSelectionDown: -5 event: aKeyboardEvent]. "page up key" - asc = 12 ifTrue: [^self moveSelectionDown: 5 event: aKeyboardEvent]. "page down key" - matchString := self valueOfProperty: #matchString ifAbsent: [String new]. - matchString := char = Character backspace - ifTrue: [ - matchString isEmpty ifTrue: [matchString] ifFalse: [matchString allButLast]] - ifFalse: [matchString copyWith: aKeyboardEvent keyCharacter]. - self setProperty: #matchString toValue: matchString. - self displayFiltered: aKeyboardEvent! ! -!MenuMorph methodsFor: 'events-processing' stamp: 'jmv 3/2/2017 10:47:57' prior: 16866952! - handleFocusEvent: aMorphicEvent - "Handle focus events. Valid menu transitions are determined based on the menu currently holding the focus after the mouse went down on one of its children." - | eventPositionInOurCoordinates | - eventPositionInOurCoordinates _ self internalizeFromWorld: aMorphicEvent eventPosition. - - self dispatchEvent: aMorphicEvent localPosition: eventPositionInOurCoordinates. - - "Need to handle keyboard input if we have the focus." - aMorphicEvent isKeyboard ifTrue: [ ^ aMorphicEvent sentTo: self localPosition: eventPositionInOurCoordinates]. - - "We need to handle button clicks outside and transitions to local popUps so throw away everything else" - (aMorphicEvent isMouseOver or: [aMorphicEvent isMouse not]) ifTrue: [ ^self ]. - "What remains are mouse buttons and moves" - aMorphicEvent isMove ifFalse: [ ^ aMorphicEvent sentTo: self localPosition: eventPositionInOurCoordinates ]. "handle clicks outside by regular means" - "Now it's getting tricky. On #mouseMove we might transfer control to *either* the currently active submenu or the pop up owner, if any. Since the active sub menu is always displayed upfront check it first." - selectedItem ifNotNil:[(selectedItem activateSubmenu: aMorphicEvent) ifTrue: [^self]]! ! -!MenuMorph methodsFor: 'initialization' stamp: 'jmv 3/2/2017 10:47:34' prior: 16867015! - initialize - super initialize. - extent _ 40@10. - defaultTarget _ nil. - selectedItem _ nil. - stayUp _ false! ! -!MenuItemMorph methodsFor: 'events' stamp: 'jmv 3/2/2017 10:45:33' prior: 16866023! - mouseEnter: evt - "The mouse entered the receiver" - owner ifNil: [ ^self ]. - owner selectItem: self! ! -!MenuItemMorph methodsFor: 'selecting' stamp: 'jmv 3/2/2017 10:36:12' prior: 16866139! - deselect - - self isSelected: false. - subMenu ifNotNil: [ - self removeAlarm: #deselectTimeOut ]! ! -!MenuItemMorph methodsFor: 'selecting' stamp: 'jmv 3/2/2017 10:36:17' prior: 16866151! - select - self isSelected: true. - subMenu ifNotNil: [ - subMenu delete. - subMenu - popUpAdjacentTo: (Array with: self morphBoundsInWorld topRight + (10@0) - with: self morphBoundsInWorld topLeft) - from: self. - subMenu selectItem: nil ]! ! - -MenuItemMorph removeSelector: #activateOwnerMenu:! - -MenuItemMorph removeSelector: #activateOwnerMenu:! - -MenuMorph removeSelector: #activeSubmenu:! - -MenuMorph removeSelector: #activeSubmenu:! - -MenuMorph removeSelector: #delete! - -MenuMorph removeSelector: #delete! - -MenuMorph removeSelector: #popUpOwner! - -MenuMorph removeSelector: #popUpOwner! - -BorderedRectMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp titleMorph' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #MenuMorph category: #'Morphic-Menus'! -BorderedRectMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp titleMorph' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -----End fileIn of C:\Users\Juan-Tuerca\PayloadSoftware\Cuis-Smalltalk-Dev\CoreUpdates\3048-MenuSimplification-JuanVuletich-2017Mar02-10h45m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3048] on 2 March 2017 at 4:11:32 pm'! -!Transcripter class methodsFor: 'instance creation' stamp: 'dhn 2/6/2017 13:38:40' prior: 16938922! - newInFrame: frame -" -(Transcripter newInFrame: (0@0 extent: 100@200)) - nextPutAll: 'Hello there'; endEntry; - newLine; print: 355.0/113; endEntry; - readEvalPrint. -" - | transcript | - transcript _ self on: (String new: 100). - transcript initInFrame: frame. - ^ transcript clear! ! - -----End fileIn of C:\Users\Juan-Tuerca\PayloadSoftware\Cuis-Smalltalk-Dev\CoreUpdates\3049-TranscripterCommentFix-DanNorton-2017Mar02-16h10m-dhn.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3049] on 3 March 2017 at 9:17:59 am'! -!WorldState methodsFor: 'stepping' stamp: 'jmv 3/2/2017 19:35:58'! - cleanseStepList - "Remove morphs from the step list that are not in this World. Often were in a flap that has moved on to another world." - - | deletions morphToStep | - deletions _ nil. - stepList do: [:entry | - morphToStep _ entry receiver. - morphToStep world == world ifFalse:[ - deletions ifNil: [deletions _ OrderedCollection new]. - deletions addLast: entry]]. - - deletions ifNotNil:[ - deletions do: [:entry| - self stopSteppingMorph: entry receiver]]. - - self alarms copy do:[:entry| - morphToStep _ entry receiver. - ((morphToStep is: #Morph) and: [ morphToStep world == world ]) - ifFalse: [ self removeAlarm: entry selector for: entry receiver ]].! ! -!WorldState methodsFor: 'stepping' stamp: 'jmv 3/2/2017 19:42:28'! - runStepMethods - "Perform periodic activity inbetween event cycles" - | queue msg | - - queue _ self class deferredUIMessages. - [ (msg _ queue nextOrNil) isNil ] whileFalse: [ - msg value - ]. - self runLocalStepMethods. - - "we are using a normal #step for these now" - "aWorld allLowerWorldsDo: [ :each | each runLocalStepMethods ]." -! ! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 3/2/2017 19:34:41'! - displayWorldSafely - "Update this world's display and keep track of errors during draw methods." - - [world displayWorld] ifError: [:err :rcvr | - "Handle a drawing error" - | errCtx errMorph | - errCtx _ thisContext. - [ - errCtx _ errCtx sender. - "Search the sender chain to find the morph causing the problem" - [errCtx notNil and: [ (errCtx receiver is: #Morph) not ]] - whileTrue:[errCtx _ errCtx sender]. - "If we're at the root of the context chain then we have a fatal drawing problem" - errCtx ifNil:[^self handleFatalDrawingError: err]. - errMorph _ errCtx receiver. - "If the morph causing the problem has already the #drawError flag set, - then search for the next morph above in the caller chain." - errMorph isKnownFailing - ] whileTrue. - errMorph drawingFails. - self clearCanvas. - "Install the old error handler, so we can re-raise the error" - rcvr error: err. - ]! ! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 3/2/2017 19:34:09'! - doOneCycle - "Do one cycle of the interaction loop. This method is called repeatedly when the world is running. - - Make for low cpu usage if the ui is inactive, but quick response when ui is in use. - However, after some inactivity, there will be a larger delay before the ui gets responsive again." - - | wait waitUntil | - waitDelay ifNil: [ waitDelay _ Delay forMilliseconds: 50 ]. - lastCycleHadAnyEvent - ifTrue: [ - pause _ 20. "This value will only be used when there are no more events to serve." - wait _ 0 ] "Don't wait" - ifFalse: [ - pause < 200 "No events processed? Start saving CPU!! But never make the user wait more than 200ms for being responsive again." - ifTrue: [ pause _ pause * 21//20 ]. - waitUntil _ lastCycleTime + pause. - "Earlier if steps" - stepList isEmpty not ifTrue: [ - waitUntil _ waitUntil min: stepList first scheduledTime ]. - "Earlier if alarms" - alarms ifNotNil: [ - alarms isEmpty not ifTrue: [ - waitUntil _ waitUntil min: alarms first scheduledTime ]]. - - wait _ waitUntil - Time localMillisecondClock ]. - Preferences serverMode - ifTrue: [ wait _ wait max: 50 ]. "Always wait at least a bit on servers, even if this makes the UI slow." - wait > 0 ifTrue: [ - waitDelay beingWaitedOn - ifFalse: [ waitDelay setDelay: wait; wait ] - ifTrue: [ - "If we are called from a different process than that of the main UI, we might be called in the main - interCyclePause. In such case, use a new Delay to avoid 'This Delay has already been scheduled' errors" - (Delay forMilliseconds: wait) wait ]]. - - "Record start time of this cycle, and do cycle" - lastCycleTime _ Time localMillisecondClock. - lastCycleHadAnyEvent _ self doOneCycleNow! ! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 3/2/2017 19:34:47'! - doOneCycleNow - "Immediately do one cycle of the interaction loop. - This should not be called directly, but only via doOneCycleFor:" - - | hadAnyEvent | - "See #eventTickler" - Cursor currentCursor = Cursor wait ifTrue: [ - Cursor normal activateCursor ]. - - "Repair visual damage." - DisplayScreen checkForNewScreenSize. - self displayWorldSafely. - - "Run steps, alarms and deferred UI messages" - world runStepMethods. - - "Process user input events. Run all event triggered code." - hadAnyEvent _ false. - self handsDo: [ :h | - activeHand _ h. - hadAnyEvent _ hadAnyEvent | h processEventQueue. - activeHand _ nil ]. - - "The default is the primary hand" - activeHand _ self hands first. - - - ^hadAnyEvent! ! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 3/2/2017 19:43:12'! - tryDeferredUpdatingAndSetCanvas - "If this platform supports deferred updates, then make my canvas be the Display (or a rectangular portion of it), set the Display to deferred update mode, and answer true. Otherwise, set a non-Disply canvas and answer false.." - | properDisplay | - - "As this is the only sender of #deferUpdates: , this could be done in Morphic or image startup, and never efterwards..." - (Display deferUpdates: true) ifNil: [ - "deferred updates not supported by the VM, do them in the image!!" - self ensureNonDisplayCanvas. - ^ false]. - - "if no canvas, or canvas was offscreen, from a platform that didnt support defers, then fix it" - properDisplay _ canvas notNil and: [canvas drawsOnDisplay]. - properDisplay ifFalse: [ - world morphPosition: 0@0 extent: Display extent. - self setCanvas: Display getCanvas. - ]. - ^ true! ! -!WorldState methodsFor: 'drawing' stamp: 'jmv 3/2/2017 19:43:18'! - displayWorldAndSubmorphs: submorphs - "Update this world's display." - - | deferredUpdateVMMode worldDamageRects handsToDraw allDamage | - self checkIfUpdateNeeded ifFalse: [ ^ self ]. "display is already up-to-date" - "I (jmv) removed the call to 'deferUpdates: false' below. No more need to call this every time." - deferredUpdateVMMode _ self tryDeferredUpdatingAndSetCanvas. - - "repair world's damage on canvas" - worldDamageRects _ self drawInvalidAreasSubmorphs: submorphs. - - "Check which hands need to be drawn (they are not the hardware mouse pointer)" - handsToDraw _ self selectHandsToDrawForDamage: worldDamageRects. - allDamage _ Array streamContents: [ :strm | - strm nextPutAll: worldDamageRects. - handsToDraw do: [ :h | - h savePatchFrom: canvas appendDamageTo: strm ]]. - - "Draw hands (usually carying morphs) onto world canvas" - canvas newClipRect: nil. - handsToDraw reverseDo: [ :h | canvas fullDrawHand: h ]. - - "quickly copy altered rects of canvas to Display:" - deferredUpdateVMMode ifFalse: [ - "Drawing was done to off-Display canvas. Copy content to Display" - canvas showAt: world viewBox origin invalidRects: allDamage ]. - - "Display deferUpdates: false." - "Display forceDisplayUpdate" - Display forceDamageToScreen: allDamage. - - "Restore world canvas under hands and their carried morphs" - handsToDraw do: [ :h | h restoreSavedPatchOn: canvas ].! ! -!WorldState methodsFor: 'drawing' stamp: 'jmv 3/2/2017 19:40:12'! - drawInvalidAreasSubmorphs: submorphs - "Redraw the damaged areas of the given canvas and clear the damage list. Return a collection of the areas that were redrawn." - - | initialRectsToRepair currentRectsToRepair newRectsToRepair morphsToDraw rectsForEachMorph thisMorphRects reuse i n morph morphBounds morphClipRect | - - "The simple implementation is slowers as it draws morph areas that will later be covered by other morphs. - But it works, and it is easier to understand. - See en.wikipedia.org/wiki/Painter's_algorithm" - true not ifTrue: [ ^self simpleDrawInvalidAreasSubmorphs: submorphs ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - initialRectsToRepair _ damageRecorder invalidRectsFullBounds: world viewBox. - damageRecorder reset. - currentRectsToRepair _ OrderedCollection new. - newRectsToRepair _ OrderedCollection withAll: initialRectsToRepair. - morphsToDraw _ OrderedCollection new. - rectsForEachMorph _ OrderedCollection new. - thisMorphRects _ OrderedCollection new. - n _ submorphs size. - i _ 1. - - "The idea here is to iterate morphs front to back, i.e. first the ones on top. - For each morph, record the rectangles it affects. And if a morph is opaque, remove the area behind it from the list of rectangles to be repaired. - This means, for example, that morphs completely covered might even not be redrawn. - this is a huge performance gain when there are many morphs on screen, especially if there are more than ten open windows, and Theme uses opaque colors. - See 'A reverse painter's algorithm' at en.wikipedia.org/wiki/Painter's_algorithm" - [ i <= n and: [ newRectsToRepair notEmpty ]] whileTrue: [ - morph _ submorphs at: i. - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - reuse _ currentRectsToRepair. - currentRectsToRepair _ newRectsToRepair. - newRectsToRepair _ reuse removeAll. - currentRectsToRepair do: [ :r | - (morphBounds intersects: r) - ifTrue: [ - morphClipRect _ morphBounds intersect: r. - thisMorphRects add: morphClipRect. "We could perhaps try and join adjacent rectangles in this collection..." - morph addPossiblyUncoveredAreasIn: r to: newRectsToRepair ] - ifFalse: [ - newRectsToRepair add: r ]]. - thisMorphRects ifNotEmpty: [ - morphsToDraw add: morph. - rectsForEachMorph add: thisMorphRects. - thisMorphRects _ OrderedCollection new. - ]]. - i _ i + 1 ]. - - "*make this true to flash damaged areas for testing*" - Preferences debugShowDamage ifTrue: [ world fillRects: initialRectsToRepair color: Color gray ]. - - "Draw world background on those areas that were not completely covered by opaque morphs" - i > n ifTrue: [ - newRectsToRepair do: [ :r | - world drawOn: (canvas newClipRect: r) ]]. - - "Now, draw the recorded areas of selected morphs, back to front." - morphsToDraw with: rectsForEachMorph reverseDo: [ :m :xrects | - "Here we could think about merging all xrects into just one call... - This would mean drawing each morph just once. - But that would mean drawing pixels we were not told to. There could be other morphs in that area that are not even being drawn!! - See WorldState class >> #experiment1" -" rr _ nil." - xrects do: [ :r | -" rr _ rr ifNil: [ r ] ifNotNil: [ r quickMerge: rr ]." - (canvas newClipRect: r) fullDraw: m. - ]. -" (canvas newClipRect: rr) fullDraw: m" - "*make this true to flash damaged areas for testing*" - Preferences debugShowDamage2 ifTrue: [ - world flashRects: xrects color: Color random ]. - ]. - - "Answer a list of rectangles to be updated on the Display. - This usually is not performance critical, drawing morphs is slower than just exposing the Display." - "What should we force on Display? Whatever was asked? Each small rect that was updated? A single bigger rect? - Right now, answer whatever was asked... Maybe this could be changed if that enhances performance... - (think of vnc over slow networks)" - ^ initialRectsToRepair! ! -!WorldState methodsFor: 'drawing' stamp: 'jmv 3/2/2017 19:39:56'! - simpleDrawInvalidAreasSubmorphs: submorphs - - "mover todo esto al canvas, no? - Y ver que hacer con los argumentos, etc.... Toda esta bananarama!!" - - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - This simple implementation just does as requested: No optimizations are done." - - | rectsToRepair morphBounds | - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ damageRecorder invalidRectsFullBounds: world viewBox. - damageRecorder reset. - - "Draw World" - rectsToRepair do: [ :r | - world drawOn: (canvas newClipRect: r) ]. - - "Draw morphs" - submorphs reverseDo: [ :morph | - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - rectsToRepair do: [ :r | - (morphBounds intersects: r) ifTrue: [ - (canvas newClipRect: r) fullDraw: morph ]]]]. - - ^ rectsToRepair! ! -!WorldState methodsFor: 'accessing' stamp: 'jmv 3/2/2017 21:47:15'! - runLocalStepMethods - "Run morph 'step' methods (LOCAL TO THIS WORLD) whose time has come. Purge any morphs that are no longer in this world." - - | now morphToStep scheduledTime | - now _ lastCycleTime. - self triggerAlarmsBefore: now. - stepList isEmpty - ifTrue: [ ^self]. - [ stepList isEmpty not and: [ stepList first scheduledTime <= now ]] - whileTrue: [ - lastStepMessage _ stepList removeFirst. - morphToStep _ lastStepMessage receiver. - (morphToStep shouldGetStepsFrom: world) - ifTrue: [ - scheduledTime _ lastStepMessage scheduledTime. - lastStepMessage valueAtTime: now - scheduledTime + lastStepMessage stepTime. - lastStepMessage ifNotNil: [ - lastStepMessage scheduledTime: (scheduledTime + lastStepMessage stepTime max: now + 1). - stepList add: lastStepMessage ]]. - lastStepMessage _ nil ]! ! -!PasteUpMorph methodsFor: 'interaction loop' stamp: 'jmv 3/2/2017 19:34:01' prior: 16887286! - doOneCycleNow - "see the comment in doOneCycleNowFor: - Only used for a few tests." - worldState doOneCycleNow! ! -!PasteUpMorph methodsFor: 'stepping' stamp: 'jmv 3/2/2017 19:36:23' prior: 16887443! - cleanseStepList - "Remove morphs from the step list that are not in this World. Often were in a flap that has moved on to another world." - - worldState cleanseStepList! ! -!PasteUpMorph methodsFor: 'stepping' stamp: 'jmv 3/2/2017 19:42:32' prior: 16887451! - runStepMethods - - worldState runStepMethods! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 3/2/2017 19:34:54' prior: 16887760! - displayWorldSafely - - worldState displayWorldSafely -! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 3/2/2017 19:33:20' prior: 16887765! - doOneCycle - "see the comment in WorldState >> doOneCycle" - - worldState doOneCycle! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 3/2/2017 19:37:11' prior: 16887829! - privateOuterDisplayWorld - - worldState displayWorldAndSubmorphs: submorphs -! ! -!WorldState class methodsFor: 'sample code' stamp: 'jmv 3/2/2017 19:39:21' prior: 16946320! - experiment1 - "To play with and learn about morphic Display update logic. - Remove the morphs when done!!" - " - WorldState experiment1 - " - | dr morph1 morph2 s w | - morph1 _ RectangleLikeMorph new openInWorld. - morph2 _ RectangleLikeMorph new openInWorld. - morph2 color: Color green. - morph2 morphPosition: 200@800 extent: 50@40. - morph1 morphPosition: 120@720 extent: 220@100. - - w _ self runningWorld. - s _ w instVarNamed: 'worldState'. - dr _ s instVarNamed: 'damageRecorder'. - - dr doFullRepaint. - dr reset; - " recordInvalidRect: (100@700 corner: 400@900);" - recordInvalidRect: (100@700 corner: 150@900); - recordInvalidRect: (300@700 corner: 400@900). - Display fillColor: Color gray. - "Do not draw the area used by the small rectangle, unless it is also drawn!!" - s drawInvalidAreasSubmorphs: {morph1. morph2 }! ! - -WorldState removeSelector: #cleanseStepListForWorld:! - -WorldState removeSelector: #cleanseStepListForWorld:! - -WorldState removeSelector: #displayWorld:submorphs:! - -WorldState removeSelector: #displayWorld:submorphs:! - -WorldState removeSelector: #displayWorldSafely:! - -WorldState removeSelector: #displayWorldSafely:! - -WorldState removeSelector: #doOneCycleFor:! - -WorldState removeSelector: #doOneCycleFor:! - -WorldState removeSelector: #doOneCycleNowFor:! - -WorldState removeSelector: #doOneCycleNowFor:! - -WorldState removeSelector: #drawInvalidAreasWorld:submorphs:! - -WorldState removeSelector: #drawInvalidAreasWorld:submorphs:! - -WorldState removeSelector: #runLocalStepMethodsIn:! - -WorldState removeSelector: #runLocalStepMethodsIn:! - -WorldState removeSelector: #runStepMethodsIn:! - -WorldState removeSelector: #runStepMethodsIn:! - -WorldState removeSelector: #simpleDrawInvalidAreasWorld:submorphs:! - -WorldState removeSelector: #simpleDrawInvalidAreasWorld:submorphs:! - -WorldState removeSelector: #tryDeferredUpdatingAndSetCanvasFor:! - -WorldState removeSelector: #tryDeferredUpdatingAndSetCanvasFor:! - -----End fileIn of C:\Users\Juan-Tuerca\PayloadSoftware\Cuis-Smalltalk-Dev\CoreUpdates\3050-WorldState-refactor-JuanVuletich-2017Mar03-09h17m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3049] on 3 March 2017 at 9:22:19 am'! -!PasteUpMorph methodsFor: 'interaction loop' stamp: 'jmv 3/2/2017 19:58:01' prior: 50339846! - doOneCycleNow - "see the comment in WorldState >> doOneCycleNow - Only used for a few tests." - worldState doOneCycleNow! ! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 3/3/2017 09:21:41' prior: 50339563! - doOneCycleNow - "Immediately do one cycle of the interaction loop." - - | hadAnyEvent | - "See #eventTickler" - Cursor currentCursor = Cursor wait ifTrue: [ - Cursor normal activateCursor ]. - - "Repair visual damage." - DisplayScreen checkForNewScreenSize. - self displayWorldSafely. - - "Run steps, alarms and deferred UI messages" - self runStepMethods. - - "Process user input events. Run all event triggered code." - hadAnyEvent _ false. - self handsDo: [ :h | - activeHand _ h. - hadAnyEvent _ hadAnyEvent | h processEventQueue. - activeHand _ nil ]. - - "The default is the primary hand" - activeHand _ self hands first. - - - ^hadAnyEvent! ! - -PasteUpMorph removeSelector: #runStepMethods! - -PasteUpMorph removeSelector: #runStepMethods! - -----End fileIn of C:\Users\Juan-Tuerca\PayloadSoftware\Cuis-Smalltalk-Dev\CoreUpdates\3051-WorldState-refactor-JuanVuletich-2017Mar03-09h17m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3049] on 3 March 2017 at 9:27:56 am'! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 3/2/2017 20:08:11'! - doOneMinimalCycleNow - "see the comment in WorldState >> doOneMinimalCycleNow" - - worldState doOneMinimalCycleNow! ! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 3/2/2017 20:06:48'! - doOneMinimalCycleNow - "Immediately do one cycle of the interaction loop. - Only repair display and process events. For modal menus and such." - - "Repair visual damage." - self displayWorldSafely. - - "Process user input events. Run all event triggered code." - ^activeHand processEventQueue! ! -!MenuMorph methodsFor: 'modal control' stamp: 'jmv 3/2/2017 20:08:34' prior: 16867177! - invokeModal: allowKeyboardControl - "Invoke this menu and don't return until the user has chosen a value. If the allowKeyboarControl boolean is true, permit keyboard control of the menu - See senders of this method for finding out how to use modal menu morphs." - | w oldFocus actHand | - w _ self runningWorld. - actHand _ w activeHand. - oldFocus _ actHand keyboardFocus. - w doOneMinimalCycleNow. - self - popUpAt: actHand morphPosition - forHand: actHand - allowKeyboard: allowKeyboardControl. - self isModalInvokationDone: false. - [ self isInWorld & self isModalInvokationDone not ] whileTrue: [ w doOneMinimalCycleNow ]. - self delete. - oldFocus ifNotNil: [ actHand newKeyboardFocus: oldFocus ]. - ^ self modalSelection! ! -!MVCMenuMorph methodsFor: 'invoking' stamp: 'jmv 3/2/2017 20:08:29' prior: 16865463! - invokeAt: aPoint allowKeyboard: aBoolean - "Add this menu to the given world centered at the given point. Wait for the user to make a selection and answer it. The selection value returned is an integer in keeping with PopUpMenu, if the menu is converted from an MVC-style menu." - "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop." - |actHand w oldFocus | - self flag: #bob. "is global or local?" - self flag: #arNote. " is local to aWorld" - w _ self runningWorld. - actHand _ w activeHand. - oldFocus _ actHand keyboardFocus. - w doOneMinimalCycleNow. - self - popUpAt: aPoint - forHand: actHand - allowKeyboard: aBoolean. - done _ false. - [ self isInWorld & done not ] whileTrue: [ w doOneMinimalCycleNow ]. - self delete. - oldFocus ifNotNil: [ actHand newKeyboardFocus: oldFocus ]. - ^ mvcSelection ! ! -!FillInTheBlankMorph methodsFor: 'invoking' stamp: 'jmv 3/2/2017 20:08:24' prior: 16844196! - getUserResponse - "Wait for the user to accept or cancel, and answer the result string. Answers the empty string if the user cancels." - "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop." - - | w | - w _ self world. - w ifNil: [^ response]. - done _ false. - textPane focusText. - [done] whileFalse: [w doOneMinimalCycleNow]. - self delete. - w doOneMinimalCycleNow. - ^ response -! ! -!FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'jmv 3/3/2017 09:26:42' prior: 16844289! - request: queryString initialAnswer: defaultAnswer centerAt: aPoint onCancelReturn: returnOnCancel acceptOnCR: acceptBoolean - "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. If the user cancels, answer returnOnCancel." - " - FillInTheBlankMorph - request: 'Type something, then type [Return].' - initialAnswer: 'yo ho ho!!' - " - - | aFillInTheBlankMorph | - aFillInTheBlankMorph _ self new - setQuery: queryString - initialAnswer: defaultAnswer - acceptOnCR: acceptBoolean. - aFillInTheBlankMorph responseUponCancel: returnOnCancel. - self runningWorld addMorph: aFillInTheBlankMorph centeredNear: aPoint. - ^ aFillInTheBlankMorph getUserResponse! ! - -----End fileIn of C:\Users\Juan-Tuerca\PayloadSoftware\Cuis-Smalltalk-Dev\CoreUpdates\3052-MenusDoReducedWorldCycle-JuanVuletich-2017Mar03-09h22m-jmv.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3049] on 3 March 2017 at 9:49:08 am'! -!WorldState methodsFor: 'accessing' stamp: 'jmv 3/3/2017 09:47:13'! - runLocalStepMethods: nowTime - "Run morph 'step' methods (LOCAL TO THIS WORLD) whose time has come. Purge any morphs that are no longer in this world." - - | morphToStep scheduledTime | - [ stepList notEmpty and: [ stepList first scheduledTime <= nowTime ]] - whileTrue: [ - lastStepMessage _ stepList removeFirst. - morphToStep _ lastStepMessage receiver. - (morphToStep shouldGetStepsFrom: world) - ifTrue: [ - scheduledTime _ lastStepMessage scheduledTime. - lastStepMessage valueAtTime: nowTime - scheduledTime + lastStepMessage stepTime. - lastStepMessage ifNotNil: [ - lastStepMessage scheduledTime: (scheduledTime + lastStepMessage stepTime max: nowTime + 1). - stepList add: lastStepMessage ]]. - lastStepMessage _ nil ]! ! -!WorldState methodsFor: 'alarms' stamp: 'jmv 3/3/2017 09:33:59' prior: 16945643! - addAlarm: aSelector withArguments: argArray for: aTarget at: scheduledTime - "Add a new alarm with the given set of parameters" - - alarms add: - (MorphicAlarm - receiver: aTarget - selector: aSelector - arguments: argArray - at: scheduledTime)! ! -!WorldState methodsFor: 'alarms' stamp: 'jmv 3/3/2017 09:34:03' prior: 16945653! - adjustAlarmTimes: nowTime - "Adjust the alarm times after some clock weirdness (such as image-startup etc)" - | deltaTime | - deltaTime _ nowTime - lastAlarmTime. - alarms do: [ :alarm | - alarm scheduledTime: alarm scheduledTime + deltaTime ]! ! -!WorldState methodsFor: 'alarms' stamp: 'jmv 3/3/2017 09:34:21' prior: 16945673! - removeAlarm: aSelector for: aTarget - "Remove the alarm with the given selector" - - | alarm | - alarm := alarms - detect: [ :any | any receiver == aTarget and: [any selector == aSelector]] - ifNone: nil. - alarm ifNotNil: [ alarms remove: alarm ]! ! -!WorldState methodsFor: 'alarms' stamp: 'jmv 3/3/2017 09:35:03' prior: 16945684! - triggerAlarmsBefore: nowTime - "Trigger all pending alarms that are to be executed before nowTime." - - nowTime - lastAlarmTime > 10000 - ifTrue: [ self adjustAlarmTimes: nowTime ]. - [ alarms notEmpty and: [ alarms first scheduledTime < nowTime ]] - whileTrue: [ alarms removeFirst valueAtTime: nowTime ]. - lastAlarmTime _ nowTime! ! -!WorldState methodsFor: 'initialization' stamp: 'jmv 3/3/2017 09:33:53' prior: 16945782! - initialize - - activeHand _ HandMorph new. - hands _ { activeHand }. - damageRecorder _ DamageRecorder new. - stepList _ Heap sortBlock: self stepListSortBlock. - alarms _ Heap sortBlock: self alarmSortBlock. - lastAlarmTime _ 0. - drawingFailingMorphs _ WeakIdentitySet new. - pause _ 20. - lastCycleTime _ Time localMillisecondClock. - lastCycleHadAnyEvent _ false! ! -!WorldState methodsFor: 'stepping' stamp: 'jmv 3/3/2017 09:39:18' prior: 50339440! - cleanseStepList - "Remove morphs from the step list that are not in this World." - - | deletions morphToStep | - deletions _ nil. - stepList do: [:entry | - morphToStep _ entry receiver. - morphToStep world == world ifFalse:[ - deletions ifNil: [deletions _ OrderedCollection new]. - deletions addLast: entry]]. - - deletions ifNotNil:[ - deletions do: [:entry| - self stopSteppingMorph: entry receiver]]. - - alarms copy do: [ :entry | - morphToStep _ entry receiver. - ((morphToStep is: #Morph) and: [ morphToStep world == world ]) - ifFalse: [ self removeAlarm: entry selector for: entry receiver ]]! ! -!WorldState methodsFor: 'stepping' stamp: 'jmv 3/3/2017 09:46:37' prior: 50339463! - runStepMethods - "Perform periodic activity inbetween event cycles" - | queue msg | - - queue _ self class deferredUIMessages. - [ (msg _ queue nextOrNil) isNil ] whileFalse: [ - msg value - ]. - self triggerAlarmsBefore: lastCycleTime. - self runLocalStepMethods: lastCycleTime. - - "we are using a normal #step for these now" - "aWorld allLowerWorldsDo: [ :each | each runLocalStepMethods ]." -! ! - -WorldState removeSelector: #alarms! - -WorldState removeSelector: #alarms! - -WorldState removeSelector: #runLocalStepMethods! - -WorldState removeSelector: #runLocalStepMethods! - -----End fileIn of C:\Users\Juan-Tuerca\PayloadSoftware\Cuis-Smalltalk-Dev\CoreUpdates\3053-WorldState-refactor-JuanVuletich-2017Mar03-09h27m-jmv.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3053] on 3 March 2017 at 11:17:47 am'! - -MorphicAlarm subclass: #StepMessage - instanceVariableNames: 'stepTime lastEvaluationTime ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Events'! - -!classDefinition: #StepMessage category: #'Morphic-Events'! -MorphicAlarm subclass: #StepMessage - instanceVariableNames: 'stepTime lastEvaluationTime' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Events'! -!StepMessage methodsFor: 'evaluating' stamp: 'jmv 3/3/2017 11:14:28'! - valueAtTime: millisecondClock - - | nArgs millisecondsSinceLast | - numArgs ifNil: [numArgs _ selector numArgs]. - nArgs _ arguments ifNil: [0] ifNotNil: [arguments size]. -"OJO!!" -lastEvaluationTime ifNil: [ lastEvaluationTime _ millisecondClock ]. - millisecondsSinceLast _ millisecondClock - lastEvaluationTime. - lastEvaluationTime _ millisecondClock. - nArgs = numArgs ifTrue: [ - "Ignore extra argument" - ^self value ]. - ^arguments - ifNil: [ receiver perform: selector with: millisecondsSinceLast] - ifNotNil: [ receiver perform: selector withArguments: (arguments copyWith: millisecondsSinceLast) ]! ! -!WorldState methodsFor: 'accessing' stamp: 'jmv 3/3/2017 11:16:08' prior: 50340127! - runLocalStepMethods: nowTime - "Run morph 'step' methods (LOCAL TO THIS WORLD) whose time has come. Purge any morphs that are no longer in this world." - - | morphToStep scheduledTime | - [ stepList notEmpty and: [ stepList first scheduledTime <= nowTime ]] - whileTrue: [ - lastStepMessage _ stepList removeFirst. - morphToStep _ lastStepMessage receiver. - (morphToStep shouldGetStepsFrom: world) - ifTrue: [ - scheduledTime _ lastStepMessage scheduledTime. - lastStepMessage valueAtTime: nowTime. - lastStepMessage ifNotNil: [ - lastStepMessage scheduledTime: (scheduledTime + lastStepMessage stepTime max: nowTime + 1). - stepList add: lastStepMessage ]]. - lastStepMessage _ nil ]! ! - -MorphicAlarm subclass: #StepMessage - instanceVariableNames: 'stepTime lastEvaluationTime' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Events'! - -!classDefinition: #StepMessage category: #'Morphic-Events'! -MorphicAlarm subclass: #StepMessage - instanceVariableNames: 'stepTime lastEvaluationTime' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Events'! - -----End fileIn of C:\Users\Juan-Tuerca\PayloadSoftware\Cuis-Smalltalk-Dev\CoreUpdates\3054-StepMessageCleanup-JuanVuletich-2017Mar03-11h11m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3053] on 3 March 2017 at 11:41:31 am'! -!StepMessage methodsFor: 'evaluating' stamp: 'jmv 3/3/2017 11:28:02'! - rescheduleAfter: millisecondTimer - "Schedule next run" - scheduledTime _ scheduledTime + self stepTime max: millisecondTimer + 1! ! -!WorldState methodsFor: 'stepping' stamp: 'jmv 3/3/2017 11:39:34' prior: 16945882! - stopStepping: aMorph selector: aSelector - "Remove the given morph from the step list." - stepList removeAll: (stepList select:[:stepMsg| stepMsg receiver == aMorph and: [ stepMsg selector == aSelector ]])! ! -!WorldState methodsFor: 'stepping' stamp: 'jmv 3/3/2017 11:39:22' prior: 16945896! - stopSteppingMorph: aMorph - "Remove the given morph from the step list." - stepList removeAll: (stepList select: [ :stepMsg | stepMsg receiver == aMorph])! ! -!WorldState methodsFor: 'accessing' stamp: 'jmv 3/3/2017 11:39:10' prior: 50340299! - runLocalStepMethods: nowTime - "Run morph 'step' methods (LOCAL TO THIS WORLD) whose time has come. Purge any morphs that are no longer in this world." - - | stepMessage | - [ stepList notEmpty and: [ stepList first scheduledTime <= nowTime ]] - whileTrue: [ - - stepMessage _ stepList first. - (stepMessage receiver shouldGetStepsFrom: world) - ifTrue: [ - stepMessage valueAtTime: nowTime. - "If it was not removed from the list during its own evaluation" - stepMessage == stepList first ifTrue: [ - stepList removeFirst. - stepMessage rescheduleAfter: nowTime. - stepList add: stepMessage ]] - - ifFalse: [ stepList removeFirst ]. - ]! ! - -----End fileIn of C:\Users\Juan-Tuerca\PayloadSoftware\Cuis-Smalltalk-Dev\CoreUpdates\3055-SteppingCleanup-JuanVuletich-2017Mar03-11h17m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3053] on 3 March 2017 at 11:55:19 am'! -!StepMessage methodsFor: 'evaluating' stamp: 'jmv 3/3/2017 11:55:15' prior: 50340277! - valueAtTime: millisecondClock - - | nArgs millisecondsSinceLast | - numArgs ifNil: [numArgs _ selector numArgs]. - nArgs _ arguments ifNil: [0] ifNotNil: [arguments size]. - lastEvaluationTime ifNil: [ lastEvaluationTime _ millisecondClock ]. - millisecondsSinceLast _ millisecondClock - lastEvaluationTime. - lastEvaluationTime _ millisecondClock. - nArgs = numArgs ifTrue: [ - "Ignore extra argument" - ^self value ]. - ^arguments - ifNil: [ receiver perform: selector with: millisecondsSinceLast] - ifNotNil: [ receiver perform: selector withArguments: (arguments copyWith: millisecondsSinceLast) ]! ! -!PasteUpMorph methodsFor: 'caching' stamp: 'jmv 3/3/2017 11:42:44' prior: 16887042! - releaseCachedState - super releaseCachedState. - backgroundImage _ nil. - self isWorldMorph ifTrue: [ - worldState cleanseStepList. - worldState clearCanvas ]! ! -!WorldState methodsFor: 'alarms' stamp: 'jmv 3/3/2017 11:54:00' prior: 50340176! - removeAlarm: aSelector for: aTarget - "Remove the alarm with the given selector" - - | alarm | - alarm _ alarms - detect: [ :any | any receiver == aTarget and: [any selector == aSelector]] - ifNone: nil. - alarm ifNotNil: [ alarms remove: alarm ]! ! -!WorldState methodsFor: 'stepping' stamp: 'jmv 3/3/2017 11:51:16' prior: 50340215! - cleanseStepList - "Remove morphs from the step list that are not in this World." - - | deletions | - deletions _ OrderedCollection new. - stepList do: [ :entry | - entry receiver world == world ifFalse: [ - deletions add: entry]]. - deletions do: [ :entry| - stepList remove: entry ]. - - deletions _ OrderedCollection new. - alarms do: [ :entry | - ((entry receiver is: #Morph) and: [ entry receiver world == world ]) ifFalse: [ - deletions add: entry]]. - deletions do: [ :entry| - alarms remove: entry ]! ! - -PasteUpMorph removeSelector: #cleanseStepList! - -PasteUpMorph removeSelector: #cleanseStepList! - -----End fileIn of C:\Users\Juan-Tuerca\PayloadSoftware\Cuis-Smalltalk-Dev\CoreUpdates\3056-SteppingCleanup-JuanVuletich-2017Mar03-11h41m-jmv.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3056] on 3 March 2017 at 3:11:05 pm'! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 3/3/2017 15:04:20' prior: 50339507! - doOneCycle - "Do one cycle of the interaction loop. This method is called repeatedly when the world is running. - - Make for low cpu usage if the ui is inactive, but quick response when ui is in use. - However, after some inactivity, there will be a larger delay before the ui gets responsive again." - - | wait waitUntil | - waitDelay ifNil: [ waitDelay _ Delay forMilliseconds: 50 ]. - lastCycleHadAnyEvent - ifTrue: [ - pause _ 20. "This value will only be used when there are no more events to serve." - wait _ 0 ] "Don't wait" - ifFalse: [ - pause < 200 "No events processed? Start saving CPU!! But never make the user wait more than 200ms for being responsive again." - ifTrue: [ pause _ pause * 21//20 ]. - waitUntil _ lastCycleTime + pause. - "Earlier if steps" - stepList isEmpty not ifTrue: [ - waitUntil _ waitUntil min: stepList first scheduledTime ]. - "Earlier if alarms" - alarms ifNotNil: [ - alarms isEmpty not ifTrue: [ - waitUntil _ waitUntil min: alarms first scheduledTime ]]. - - wait _ waitUntil - Time localMillisecondClock ]. - Preferences serverMode - ifTrue: [ wait _ wait max: 50 ]. "Always wait at least a bit on servers, even if this makes the UI slow." - wait > 5 - ifFalse: [ Processor yield ] - ifTrue: [ - waitDelay beingWaitedOn - ifFalse: [ waitDelay setDelay: wait; wait ] - ifTrue: [ - "If we are called from a different process than that of the main UI, we might be called in the main - interCyclePause. In such case, use a new Delay to avoid 'This Delay has already been scheduled' errors" - (Delay forMilliseconds: wait) wait ]]. - - "Record start time of this cycle, and do cycle" - lastCycleTime _ Time localMillisecondClock. - lastCycleHadAnyEvent _ self doOneCycleNow! ! - -----End fileIn of C:\Users\Juan-Tuerca\PayloadSoftware\Cuis-Smalltalk-Dev\CoreUpdates\3057-SteppingHangWorkaround-JuanVuletich-2017Mar03-15h10m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3049] on 3 March 2017 at 7:15:45 pm'! -!TestCase methodsFor: 'Running' stamp: 'HAW 3/3/2017 19:13:13'! - debugAsFailureIfCanNot: handler - - | semaphore | - - self ifCanNotDebugDo: [ ^handler value]. - - semaphore := Semaphore new. - self resources do: [:res | - res isAvailable ifFalse: [^res signalInitializationError]]. - [semaphore wait. - self tearDown. - self resources do: [:each | each reset]] fork. - (self class selector: testSelector) runCaseAsFailure: semaphore.! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 3/3/2017 14:13:09'! - canNotDebugMethodErrorDescription - - ^self class canNotDebugMethodErrorDescription! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 3/3/2017 18:50:08'! - ifCanNotDebugDo: handler - - ^self testMethod isQuick ifTrue: handler! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 3/3/2017 14:13:37'! - signalCanNotDebugMethod - - self error: self canNotDebugMethodErrorDescription! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 3/3/2017 14:10:20'! - testMethod - - ^self class lookupSelector: self selector! ! -!TestCase class methodsFor: 'Instance Creation' stamp: 'HAW 3/3/2017 18:51:38'! - debugAsFailure: aSymbol ifCanNot: handler - - ^(self selector: aSymbol) debugAsFailureIfCanNot: handler - ! ! -!TestCase class methodsFor: 'Error Descriptions' stamp: 'HAW 3/3/2017 16:33:00'! - canNotDebugMethodErrorDescription - - ^'Quick methods can not be debugged'! ! -!Browser methodsFor: 'tdd' stamp: 'HAW 3/3/2017 19:12:25' prior: 50338009! - debugMethodTest - - currentCompiledMethod isTestMethod ifTrue: [ - currentCompiledMethod methodClass debugAsFailure: currentCompiledMethod selector ifCanNot: [ PopUpMenu inform: TestCase canNotDebugMethodErrorDescription ]] -! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HAW 3/3/2017 19:12:39' prior: 50338096! - acceptAndDebugTest - - ^self acceptAndWithMethodDo: [ :aPotencialTestMethod | - aPotencialTestMethod isTestMethod ifTrue: [ - aPotencialTestMethod methodClass debugAsFailure: aPotencialTestMethod selector ifCanNot: [ PopUpMenu inform: TestCase canNotDebugMethodErrorDescription ]]]! ! -!TestCase methodsFor: 'Running' stamp: 'HAW 3/3/2017 18:49:24' prior: 16927491! - debugAsFailure - - ^self debugAsFailureIfCanNot: [ self signalCanNotDebugMethod ]! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 3/3/2017 19:13:40' prior: 16927518! - openDebuggerOnFailingTestMethod - - | guineaPig context compiledMethod debugger | - - compiledMethod _ self testMethod. - guineaPig _ [ self performTest ] newProcess. - context _ guineaPig suspendedContext. - debugger _ Debugger new - process: guineaPig - context: context. - debugger openFullNoSuspendLabel: 'Debug failed test ', self printString. - - [debugger interruptedContext method == compiledMethod] - whileFalse: [debugger send]. -! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 3/3/2017 19:14:27' prior: 16927535! - openDebuggerOnFailingTestMethod: semaphore - - | guineaPig context compiledMethod debugger | - - compiledMethod _ self testMethod. - guineaPig _ [ self performTest ] newProcess. - context _ guineaPig suspendedContext. - debugger _ TestCaseDebugger new - process: guineaPig - context: context. - debugger doneSemaphore: semaphore. - debugger openFullNoSuspendLabel: 'Debug failed test ', self printString. - - [debugger interruptedContext method == compiledMethod] - whileFalse: [debugger send]. -! ! - -TestCase class removeSelector: #debugAsFailure:! - -TestCase class removeSelector: #debugAsFailure:! - -TestCase removeSelector: #assertCanDebugMethod! - -TestCase removeSelector: #canNotDebugQuickMethodErrorDescription! - -TestCase removeSelector: #signalCanNotDebugQuickMethod! - -----End fileIn of C:\Users\Juan-Tuerca\PayloadSoftware\Cuis-Smalltalk-Dev\CoreUpdates\3058-CuisCore-HernanWilkinson-2017Mar02-18h30m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3058] on 6 March 2017 at 10:14:29 am'! -!Delay class methodsFor: 'timer process' stamp: 'jmv 3/6/2017 10:13:34' prior: 16833016! - handleTimerEvent - "Handle a timer event; which can be either: - - a schedule request (ScheduledDelay notNil) - - an unschedule request (FinishedDelay notNil) - - a timer signal (not explicitly specified) - We check for timer expiry every time we get a signal." - | nowTick nextTick afterwardsTick | - "Wait until there is work to do." - TimingSemaphore wait. - - "Process any schedule requests" - ScheduledDelay ifNotNil: [ - "Schedule the given delay" - self scheduleDelay: ScheduledDelay. - ScheduledDelay := nil. - ScheduledDelayNilledSemaphore initSignals. - ScheduledDelayNilledSemaphore signal ]. - - "Process any unschedule requests" - FinishedDelay ifNotNil: [ - self unscheduleDelay: FinishedDelay. - FinishedDelay := nil. - FinishedDelayNilledSemaphore initSignals. - FinishedDelayNilledSemaphore signal ]. - - "Check for clock wrap-around." - nowTick := Time millisecondClockValue. - nowTick < ActiveDelayStartTime ifTrue: [ - "clock wrapped" - self saveResumptionTimes. - self restoreResumptionTimes ]. - ActiveDelayStartTime := nowTick. - - "Signal any expired delays" - [ ActiveDelay notNil and:[ nowTick >= ActiveDelay resumptionTime ]] whileTrue: [ - ActiveDelay signalWaitingProcess. - SuspendedDelays isEmpty - ifTrue: [ ActiveDelay := nil ] - ifFalse:[ ActiveDelay := SuspendedDelays removeFirst ]]. - - "And signal when the next request is due. We sleep at most 1sec here - as a soft busy-loop so that we don't accidentally miss signals." - nextTick := nowTick + 1000. - ActiveDelay ifNotNil: [ - nextTick := nextTick min: ActiveDelay resumptionTime ]. - nextTick := nextTick min: SmallInteger maxVal. - - "Since we have processed all outstanding requests, reset the timing semaphore so - that only new work will wake us up again. Do this RIGHT BEFORE setting the next - wakeup call from the VM because it is only signaled once so we mustn't miss it." - TimingSemaphore initSignals. - Delay primSignal: TimingSemaphore atMilliseconds: nextTick. - - "This test is necessary for the obscure case that the msecs clock rolls over - after nowTick has been computed (unlikely but not impossible). In this case we'd - wait for MillisecondClockMask msecs (roughly six days) or until another delay gets - scheduled (which may not be any time soon). In any case, since handling the - condition is easy, let's just deal with it." - afterwardsTick _ Time millisecondClockValue. - afterwardsTick < nowTick "Means clock rollover." - ifTrue: [ TimingSemaphore signal ]. "retry" - - "It seems that #primSignal:atMilliseconds: might not signal the semaphore if the requested moment is in the past. - This behavior was observed in Linux Spur64 VMs. - If this happens, next delay never finishes. Usual symptom is frozen Morphic. - If there is any risk of this happening, just do another iteration right now." - nextTick < afterwardsTick "We're already late for next signal." - ifTrue: [ TimingSemaphore signal ]. "retry"! ! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 3/5/2017 00:38:27' prior: 50340472! - doOneCycle - "Do one cycle of the interaction loop. This method is called repeatedly when the world is running. - - Make for low cpu usage if the ui is inactive, but quick response when ui is in use. - However, after some inactivity, there will be a larger delay before the ui gets responsive again." - - | wait waitUntil | - waitDelay ifNil: [ waitDelay _ Delay forMilliseconds: 50 ]. - lastCycleHadAnyEvent - ifTrue: [ - pause _ 20. "This value will only be used when there are no more events to serve." - wait _ 0 ] "Don't wait" - ifFalse: [ - pause < 200 "No events processed? Start saving CPU!! But never make the user wait more than 200ms for being responsive again." - ifTrue: [ pause _ pause * 21//20 ]. - waitUntil _ lastCycleTime + pause. - "Earlier if steps" - stepList isEmpty not ifTrue: [ - waitUntil _ waitUntil min: stepList first scheduledTime ]. - "Earlier if alarms" - alarms ifNotNil: [ - alarms isEmpty not ifTrue: [ - waitUntil _ waitUntil min: alarms first scheduledTime ]]. - - wait _ waitUntil - Time localMillisecondClock ]. - Preferences serverMode - ifTrue: [ wait _ wait max: 50 ]. "Always wait at least a bit on servers, even if this makes the UI slow." - wait > 0 - ifFalse: [ Processor yield ] - ifTrue: [ - waitDelay beingWaitedOn - ifFalse: [ waitDelay setDelay: wait; wait ] - ifTrue: [ - "If we are called from a different process than that of the main UI, we might be called in the main - interCyclePause. In such case, use a new Delay to avoid 'This Delay has already been scheduled' errors" - (Delay forMilliseconds: wait) wait ]]. - - "Record start time of this cycle, and do cycle" - lastCycleTime _ Time localMillisecondClock. - lastCycleHadAnyEvent _ self doOneCycleNow! ! - -----End fileIn of C:\Users\Juan-Tuerca\PayloadSoftware\Cuis-Smalltalk-Dev\CoreUpdates\3059-RealFixForSteppingFreeze-JuanVuletich-2017Mar06-10h02m-jmv.1.cs.st----! - -----SNAPSHOT----#(6 March 2017 10:37:24.244351 am) Cuis5.0-3059-spur.image priorSource: 202692! - -----QUIT----#(6 March 2017 10:37:44.404351 am) Cuis5.0-3059-spur.image priorSource: 293363! - -----STARTUP----#(8 March 2017 9:23:04.041449 am) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3059-spur.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3059] on 7 March 2017 at 9:52:45 am'! -!Time class methodsFor: 'primitives' stamp: 'jmv 3/7/2017 09:52:37' prior: 16937622! - primMillisecondClock - "Primitive. Answer the number of milliseconds since the millisecond clock - was last reset or rolled over. No sync to any system clock. - Implemented by all major platforms. - Essential. See Object documentation whatIsAPrimitive. - - Time primMillisecondClock - Time primMillisecondClock / 1000 / 60.0 - - Range is from zero to 16r1FFFFFFF. - The VM defines MillisecondClockMask as 16r1FFFFFFF - - Overflows usually every six days. - Still used in #localMillisecondClock if the VM doesn't implement - Time primLocalMicrosecondClock - " -"Not really a clock, but a timer or ticker" - - - self primitiveFailed! ! -!Delay class methodsFor: 'timer process' stamp: 'jmv 3/7/2017 09:51:10' prior: 50340662! - handleTimerEvent - "Handle a timer event; which can be either: - - a schedule request (ScheduledDelay notNil) - - an unschedule request (FinishedDelay notNil) - - a timer signal (not explicitly specified) - We check for timer expiry every time we get a signal." - | nowTick nextTick afterwardsTick | - "Wait until there is work to do." - TimingSemaphore wait. - - "Process any schedule requests" - ScheduledDelay ifNotNil: [ - "Schedule the given delay" - self scheduleDelay: ScheduledDelay. - ScheduledDelay := nil. - ScheduledDelayNilledSemaphore initSignals. - ScheduledDelayNilledSemaphore signal ]. - - "Process any unschedule requests" - FinishedDelay ifNotNil: [ - self unscheduleDelay: FinishedDelay. - FinishedDelay := nil. - FinishedDelayNilledSemaphore initSignals. - FinishedDelayNilledSemaphore signal ]. - - "Check for clock wrap-around." - nowTick := Time millisecondClockValue. - nowTick < ActiveDelayStartTime ifTrue: [ - "clock wrapped" - self saveResumptionTimes. - self restoreResumptionTimes ]. - ActiveDelayStartTime := nowTick. - - "Signal any expired delays" - [ ActiveDelay notNil and:[ nowTick >= ActiveDelay resumptionTime ]] whileTrue: [ - ActiveDelay signalWaitingProcess. - SuspendedDelays isEmpty - ifTrue: [ ActiveDelay := nil ] - ifFalse:[ ActiveDelay := SuspendedDelays removeFirst ]]. - - "And signal when the next request is due. We sleep at most 1sec here - as a soft busy-loop so that we don't accidentally miss signals." - nextTick := nowTick + 1000. - ActiveDelay ifNotNil: [ - nextTick := nextTick min: ActiveDelay resumptionTime ]. - nextTick := nextTick min: 16r1FFFFFFF. "MillisecondClockMask" - - "Since we have processed all outstanding requests, reset the timing semaphore so - that only new work will wake us up again. Do this RIGHT BEFORE setting the next - wakeup call from the VM because it is only signaled once so we mustn't miss it." - TimingSemaphore initSignals. - Delay primSignal: TimingSemaphore atMilliseconds: nextTick. - - "This test is necessary for the obscure case that the msecs clock rolls over - after nowTick has been computed (unlikely but not impossible). In this case we'd - wait for MillisecondClockMask msecs (roughly six days) or until another delay gets - scheduled (which may not be any time soon). In any case, since handling the - condition is easy, let's just deal with it." - afterwardsTick _ Time millisecondClockValue. - afterwardsTick < nowTick "Means clock rollover." - ifTrue: [ TimingSemaphore signal ]. "retry" - - "It seems that #primSignal:atMilliseconds: might not signal the semaphore if the requested moment is in the past. - This behavior was observed in Linux Spur64 VMs. - If this happens, next delay never finishes. Usual symptom is frozen Morphic. - If there is any risk of this happening, just do another iteration right now." - nextTick < afterwardsTick "We're already late for next signal." - ifTrue: [ TimingSemaphore signal ]. "retry"! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3060-Proper-MillisecondClockMask-JuanVuletich-2017Mar07-09h05m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3061] on 7 March 2017 at 12:20:30 pm'! -!Time class methodsFor: 'primitives' stamp: 'jmv 3/7/2017 12:16:43' prior: 16937642! - primUtcMicrosecondClock - "Answer the number of microseconds since the UTC Smalltalk epoch, - i.e. 00:00 on the morning of January 1, 1901, the start of the 20th century, in UTC time. - The value is derived from the Posix epoch with a constant offset corresponding to elapsed microseconds - between the two epochs according to RFC 868. - Answer is (at least usually) a LargePositiveInteger - Cog VMs implement this. Interpreters might not." - " - Time primUtcMicrosecondClock - Time primUtcMicrosecondClock/ 1000 / 1000 / 60 / 60 / 24 / 365.25 - - (Time primUtcMicrosecondClock / 1000 / 1000 + Time primUtcWithOffset second) / 60 / 60 / 24 / 365.25 - (DateAndTime now - (DateAndTime year: 1901 month: 1 day: 1)) totalSeconds / 60 / 60 / 24 / 365.25 - " - - ^nil! ! -!Delay class methodsFor: 'primitives' stamp: 'jmv 3/7/2017 12:19:39'! - primSignal: aSemaphore atUTCMicroseconds: anInteger - "Signal the semaphore when the UTC microsecond clock reaches the value of the second argument. - Fail if the first argument is neither a Semaphore nor nil. - Fail if the second argument is not an integer (either SmallInteger or LargePositiveInteger). - See #primUtcMicrosecondClock - Essential. See Object documentation whatIsAPrimitive." - - ^self primitiveFailed! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3061-UTCDelayedSignalPrimitive-JuanVuletich-2017Mar07-12h16m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3061] on 7 March 2017 at 2:55:27 pm'! - -BorderedRectMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp titleMorph activeSubMenu popUpOwner ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #MenuMorph category: #'Morphic-Menus'! -BorderedRectMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp titleMorph activeSubMenu popUpOwner' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! -!MenuMorph methodsFor: 'control' stamp: 'ar 9/17/2000 20:38'! - activeSubmenu: aSubmenu - activeSubMenu ifNotNil:[activeSubMenu delete]. - activeSubMenu _ aSubmenu.! ! -!MenuMorph methodsFor: 'initialization' stamp: 'ar 10/10/2000 01:57'! - delete - activeSubMenu ifNotNil:[activeSubMenu delete]. - ^super delete! ! -!MenuItemMorph methodsFor: 'events' stamp: 'jmv 9/20/2012 00:14'! - activateOwnerMenu: evt - "Activate our owner menu; e.g., pass control to it" - owner ifNil: [ ^false ]. "not applicable" - (owner morphContainsPoint: (owner internalizeFromWorld: evt eventPosition)) - ifFalse: [ ^false ]. - owner activate: evt. - ^true! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 3/7/2017 14:37:43' prior: 50339169! - deleteIfPopUp: evt - "Remove this menu from the screen if stayUp is not true. If it is a submenu, also remove its owning menu." - - stayUp ifFalse: [ self delete ]. - popUpOwner ifNotNil: [ - popUpOwner isSelected: false. - popUpOwner deleteIfPopUp: evt ]. - evt ifNotNil: [ evt hand ifNotNil: [ :h | h releaseMouseFocus: self ]]! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 5/9/2016 20:40' prior: 50339178! - popUpAdjacentTo: rightOrLeftPointInWorld from: sourceItem - "Present this menu at the given point under control of the given hand. - Used mostly for submenus." - - | delta tryToPlace selectedOffset | - popUpOwner _ sourceItem. - selectedOffset _ (selectedItem ifNil: [ self items first ]) morphPosition. - sourceItem world addMorphFront: self. - - tryToPlace _ [ :where :mustFit | - self morphPosition: where - selectedOffset. - delta _ self morphFullBoundsInWorld - amountToTranslateWithin: sourceItem world morphBoundsInWorld. - (delta x = 0 | mustFit) ifTrue: [ - delta = (0@0) ifFalse: [ self morphPosition: self morphPosition + delta ]. - ^ self]]. - tryToPlace - value: rightOrLeftPointInWorld first value: false; - value: rightOrLeftPointInWorld last - (extent x @ 0) value: false; - value: rightOrLeftPointInWorld first value: true! ! -!MenuMorph methodsFor: 'events-processing' stamp: 'jmv 8/20/2012 17:50' prior: 50339317! - handleFocusEvent: aMorphicEvent - "Handle focus events. Valid menu transitions are determined based on the menu currently holding the focus after the mouse went down on one of its children." - | eventPositionInOurCoordinates | - eventPositionInOurCoordinates _ self internalizeFromWorld: aMorphicEvent eventPosition. - - self dispatchEvent: aMorphicEvent localPosition: eventPositionInOurCoordinates. - - "Need to handle keyboard input if we have the focus." - aMorphicEvent isKeyboard ifTrue: [ ^ aMorphicEvent sentTo: self localPosition: eventPositionInOurCoordinates]. - - "We need to handle button clicks outside and transitions to local popUps so throw away everything else" - (aMorphicEvent isMouseOver or: [aMorphicEvent isMouse not]) ifTrue: [ ^self ]. - "What remains are mouse buttons and moves" - aMorphicEvent isMove ifFalse: [ ^ aMorphicEvent sentTo: self localPosition: eventPositionInOurCoordinates ]. "handle clicks outside by regular means" - "Now it's getting tricky. On #mouseMove we might transfer control to *either* the currently active submenu or the pop up owner, if any. Since the active sub menu is always displayed upfront check it first." - selectedItem ifNotNil:[(selectedItem activateSubmenu: aMorphicEvent) ifTrue: [^self]]. - "Note: The following does not traverse upwards but it's the best I can do for now" - popUpOwner ifNotNil:[(popUpOwner activateOwnerMenu: aMorphicEvent) ifTrue: [^self]].! ! -!MenuMorph methodsFor: 'initialization' stamp: 'jmv 9/8/2012 20:15' prior: 50339359! - initialize - super initialize. - extent _ 40@10. - defaultTarget _ nil. - selectedItem _ nil. - stayUp _ false. - popUpOwner _ nil! ! -!MenuItemMorph methodsFor: 'selecting' stamp: 'jmv 1/29/2014 23:46' prior: 50339372! - deselect - - self isSelected: false. - subMenu ifNotNil: [ - owner ifNotNil:[ owner activeSubmenu: nil ]. - self removeAlarm: #deselectTimeOut ]! ! -!MenuItemMorph methodsFor: 'selecting' stamp: 'jmv 1/29/2014 23:44' prior: 50339378! - select - self isSelected: true. - owner activeSubmenu: subMenu. - subMenu ifNotNil: [ - subMenu delete. - subMenu - popUpAdjacentTo: (Array with: self morphBoundsInWorld topRight + (10@0) - with: self morphBoundsInWorld topLeft) - from: self. - subMenu selectItem: nil ]! ! - -BorderedRectMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp titleMorph activeSubMenu popUpOwner' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #MenuMorph category: #'Morphic-Menus'! -BorderedRectMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp titleMorph activeSubMenu popUpOwner' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3062-FixRecentMenuBreackage-JuanVuletich-2017Mar07-14h20m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3049] on 7 March 2017 at 3:18:07 pm'! -!TestCase methodsFor: 'Private' stamp: 'HAW 3/6/2017 14:55:23'! - methodForTest - - "Can not call it testMethod because it will be detected as test - Hernan" - - ^self class lookupSelector: self selector! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 3/6/2017 14:55:38' prior: 50340556! - ifCanNotDebugDo: handler - - ^self methodForTest isQuick ifTrue: handler! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 3/6/2017 14:55:45' prior: 50340610! - openDebuggerOnFailingTestMethod - - | guineaPig context compiledMethod debugger | - - compiledMethod _ self methodForTest. - guineaPig _ [ self performTest ] newProcess. - context _ guineaPig suspendedContext. - debugger _ Debugger new - process: guineaPig - context: context. - debugger openFullNoSuspendLabel: 'Debug failed test ', self printString. - - [debugger interruptedContext method == compiledMethod] - whileFalse: [debugger send]. -! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 3/6/2017 14:55:50' prior: 50340627! - openDebuggerOnFailingTestMethod: semaphore - - | guineaPig context compiledMethod debugger | - - compiledMethod _ self methodForTest. - guineaPig _ [ self performTest ] newProcess. - context _ guineaPig suspendedContext. - debugger _ TestCaseDebugger new - process: guineaPig - context: context. - debugger doneSemaphore: semaphore. - debugger openFullNoSuspendLabel: 'Debug failed test ', self printString. - - [debugger interruptedContext method == compiledMethod] - whileFalse: [debugger send]. -! ! - -TestCase removeSelector: #testMethod! - -TestCase removeSelector: #testMethod! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3063-FixForExtraTest-HernanWilkinson-2017Mar03-19h15m-HAW.1.cs.st----! - -----SNAPSHOT----#(8 March 2017 9:23:22.879116 am) Cuis5.0-3063-spur.image priorSource: 293460! - -----QUIT----#(8 March 2017 9:23:36.083407 am) Cuis5.0-3063-spur.image priorSource: 306695! - -----STARTUP----#(13 March 2017 5:40:32.989338 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3063-spur.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3063] on 13 March 2017 at 4:16:45 pm'! -!WriteStream methodsFor: 'accessing' stamp: 'jmv 3/12/2017 18:55:36' prior: 50335199! - nextPutAllString: aString withAttributes: attributesArray - - | newEnd | - (self isCompatibleWithContents: aString) - ifFalse: [ ^ self nextPutAll: aString ]. - - newEnd _ position + aString size. - newEnd > writeLimit ifTrue: [ - self growTo: newEnd + 10]. - - collection - replaceFrom: position+1 - to: newEnd - withString: aString - attributes: attributesArray - startingAt: 1. - position _ newEnd! ! -!WriteStream methodsFor: 'private' stamp: 'jmv 3/12/2017 19:08:07' prior: 16946568! -growTo: anInteger - "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. - - anInteger is the required minimal new size of the collection " - - | oldSize grownCollection newSize | - oldSize _ collection size. - newSize _ anInteger + (oldSize max: 20). - grownCollection _ collection class new: newSize. - collection _ grownCollection replaceFrom: 1 to: oldSize with: collection startingAt: 1. - writeLimit _ collection size! ! -!WriteStream methodsFor: 'private' stamp: 'jmv 3/12/2017 19:07:28' prior: 16946596! - pastEndPut: anObject - "Grow the collection. - Then we put at the current write position." - - self growTo: collection size + 1. - collection at: (position _ position + 1) put: anObject! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3064-WriteStreamTweaks-JuanVuletich-2017Mar13-16h06m-jmv.1.cs.st----! - -----SNAPSHOT----#(13 March 2017 5:40:41.575048 pm) Cuis5.0-3064-spur.image priorSource: 306791! - -----QUIT----#(13 March 2017 5:41:02.939794 pm) Cuis5.0-3064-spur.image priorSource: 308624! - -----STARTUP----#(19 March 2017 8:10:33.701142 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3064-spur.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3064] on 15 March 2017 at 2:07:10 pm'! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 3/15/2017 14:06:54' prior: 50337452! - maximumUsableAreaInWorld: aWorldOrNil - - | allowedArea | - allowedArea _ Display boundingBox. - aWorldOrNil ifNotNil: [ - allowedArea _ allowedArea intersect: aWorldOrNil viewBox. - aWorldOrNil taskbar ifNotNil: [ :tb | - tb morphBoundsInWorld ifNotNil: [ :r | - allowedArea _ (allowedArea areasOutside: r) first ]]]. - ^allowedArea -! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3065-TaskbarFix-JuanVuletich-2017Mar15-14h03m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3064] on 17 March 2017 at 10:25:22 am'! -!Debugger methodsFor: 'method creation' stamp: 'HAW 3/17/2017 10:24:51' prior: 50336711! - createMethodWhenDoesNotUndertand - - | message chosenClass interruptedContext | - - "The doesNotUndertand context must be selected - Hernan" - contextStackIndex = 1 ifFalse: [ self contextStackIndex: 1 oldContextWas: self selectedContext ]. - - interruptedContext _ self interruptedContext. - message _ interruptedContext tempAt: 1. - - chosenClass _ self - askForSuperclassOf: interruptedContext receiver class - toImplement: message selector - ifCancel: [^self]. - - self implement: message inClass: chosenClass context: self selectedContext - -! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3066-CreateMissingMethodInDebuggerFix-HernanWilkinson-2017Mar16-20h05m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3064] on 18 March 2017 at 10:47:28 am'! -!SmalltalkEditor class methodsFor: 'keyboard shortcut tables' stamp: 'HAW 3/18/2017 10:44:48' prior: 50338475! - cmdShortcutsSpec - " - Editor initialize - " - "arranged in QWERTY keyboard order" - ^#( - #( $r #acceptAndDebugTest: 'Saves method and debugs it') - #( $t #acceptAndTest: 'Saves method, runs it as test and then all tests in class. Opens debugger if error') - #( $y #acceptAndTestAll: 'Saves method, runs it as test and then all tests in class category. Opens debugger if error') - #( $i #inspectIt: 'Inspect it (selection is a valid expression, or selection is over an inspect-ilst)') - #( $p #printIt: 'Print it (selection is a valid expression)') - - #( $s #save: 'Save (i.e. accept)') - #( $d #doIt: 'Do it (selection is a valid expression)') - #( $l #cancelEdits: 'Cancel') - - #( $b #browseIt: 'Browse it (selection is a class name or cursor is over a class-list or message-list)') - #( $n #sendersOfIt: 'Senders of it (selection is a message selector or cursor is over a class-list or message-list)') - #( $m #implementorsOfIt: 'Implementors of it (selection is a message selector or cursor is over a class-list or message-list)') - - #( $E #methodStringsContainingit:'Method strings containing it') - #( $T #displayIfTrue: 'Insert #ifTrue:') - #( $I #exploreIt: 'Inspect via Object Explorer') - - #( $A #argAdvance: 'Advance argument') - #( $D #debugIt: 'Debug it') - #( $F #displayIfFalse: 'Insert #ifFalse:') - #( $G #fileItIn: 'File in selection') - - #( $V #pasteInitials: 'Paste author initials') - #( $N #referencesToIt: 'References to it (selection is a class name, or cursor is over a class-list or message-list)') - )! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3067-FixATypo-HernanWilkinson-2017Mar18-10h44m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3064] on 18 March 2017 at 8:30:03 pm'! -!TheWorldMenu methodsFor: 'construction' stamp: 'HAW 3/18/2017 20:26:59' prior: 16934784! - buildWorldMenu - "Build the menu that is put up when the screen-desktop is clicked on" - - | menu | - menu _ MenuMorph new defaultTarget: self. - self colorForDebugging: menu. - menu addStayUpIcons. - self fillIn: menu - from: { - { 'Open...'. { self. #openWindow}}. - { 'New morph...'. { self. #newMorph}. - 'Offers a variety of ways to create new objects'}. - { 'Preferences...'. { self. #preferencesDo}. - 'put up a menu offering many controls over appearance and system preferences.'}. - { 'Windows...'. { self. #windowsDo}}. - { 'Help...'. { self. #helpDo}. - 'puts up a menu of useful items for updating the system, determining what version you are running, and much else'}. - nil. - { 'Changes...'. { self. #changesDo}}. - { 'Debug...'. { self. #debugDo}. - 'a menu of debugging items'}. - { 'Restore Display (r)'. { myWorld. #restoreMorphicDisplay}. - 'repaint the screen -- useful for removing unwanted display artifacts, lingering cursors, etc.'}. - nil. - { 'Save'. { Smalltalk . #saveSession}. - 'save the current version of the image on disk'}. - { 'Save as...'. { Smalltalk . #saveAs}. - 'save the current version of the image on disk under a new name.'}. - { 'Save as New Version'. { Smalltalk . #saveAsNewVersion}. - 'give the current image a new version-stamped name\and save it under that name on disk.\Clear all user preferences and user state (class vars).' withNewLines}. - { 'Save and Quit'. { self. #saveAndQuit}. - 'save the image and quit out of Cuis.'}. - { 'Quit'. { self. #quitSession}. - 'quit out of Cuis.'}}. - ^menu! ! - -TheWorldMenu removeSelector: #saveAndQuitSession! - -TheWorldMenu removeSelector: #saveMenu! - -TheWorldMenu removeSelector: #saveMenu! - -TheWorldMenu removeSelector: #saveOptionsDo! - -TheWorldMenu removeSelector: #saveOptionsDo! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3068-SaveMenuIntegrationInWorldMenu-HernanWilkinson-2017Mar18-10h53m-HAW.1.cs.st----! - -----SNAPSHOT----#(19 March 2017 8:10:42.457638 pm) Cuis5.0-3068-spur.image priorSource: 308721! - -----QUIT----#(19 March 2017 8:10:57.597591 pm) Cuis5.0-3068-spur.image priorSource: 314725! - -----STARTUP----#(16 April 2017 9:01:13.122915 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3068-spur.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3068] on 26 March 2017 at 11:30:12 pm'! -!Theme class methodsFor: 'class initialization' stamp: 'jmv 3/26/2017 23:25:17' prior: 16936878! - currentTheme: aTheme - - CurrentTheme := aTheme new. - SHTextStylerST80 initialize. - self runningWorld ifNotNil: [ :w | - w backgroundImage ifNil: [ - w color: CurrentTheme background ]]. - SystemWindow initialize. - BitBltCanvas releaseClassCachedState. - self runningWorld ifNotNil: [ :w | - CurrentTheme useTaskbar - ifTrue: [w showTaskbar] - ifFalse: [w hideTaskbar]. - w restoreMorphicDisplay ]. - - ^ CurrentTheme! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3069-Theme-fix-JuanVuletich-2017Mar26-23h30m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3064] on 25 March 2017 at 10:48:23 am'! -!BasicClassOrganizer methodsFor: 'accessing' stamp: 'HAW 3/25/2017 10:48:00' prior: 16782575! - classComment: aString - "Store the comment, aString, associated with the object that refers to the - receiver." - - aString ifNil: [ ^classComment _ nil ]. - - aString isRemote - ifTrue: [classComment _ aString] - ifFalse: [aString size = 0 - ifTrue: [classComment _ nil] - ifFalse: [ - self error: 'use aClass classComment:'. - classComment _ RemoteString newString: aString onFileNumber: 2]] - "Later add priorSource and date and initials?"! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3070-ClassCommentSetterFix-HernanWilkinson-2017Mar25-10h47m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3064] on 27 March 2017 at 9:11:54 am'! -!Delay class methodsFor: 'instance creation' stamp: 'HAW 3/27/2017 09:08:00' prior: 16832891! - forDuration: aDuration - - ^ self forMilliseconds: aDuration totalMilliseconds! ! - -Duration removeSelector: #totalMilliSeconds! - -Duration removeSelector: #totalMilliSeconds! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3071-Remove-totalMilliSeconds-HernanWilkinson-2017Mar27-09h08m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3068] on 30 March 2017 at 8:42:47 am'! -!Morph methodsFor: 'user interface' stamp: 'jmv 3/30/2017 08:41:08'! - toggleCollapseOrShow - "If collapsed, show me. - If visible, collapse me." - - self visible - ifTrue: [ self collapse ] - ifFalse: [ self showAndComeToFront ]! ! -!Morph methodsFor: 'user interface' stamp: 'jmv 3/30/2017 08:38:46' prior: 50337389! - collapse - "If taskbar not visible, just hide." - - self hide. - self taskbar - ifNotNil: [ :tb | tb wasCollapsed: self ]! ! -!Morph methodsFor: 'user interface' stamp: 'jmv 3/30/2017 08:38:12' prior: 50337104! - showAndComeToFront - "Make me visible if not, set me on top of all other sibling morphs." - self show; comeToFront! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 3/30/2017 08:41:28' prior: 50337685! - addButtonFor: aMorph - - | button | - aMorph == self ifFalse: [ - button _ PluggableButtonMorph - model: aMorph - stateGetter: nil - action: #toggleCollapseOrShow. - button - color: self color; - icon: (aMorph imageForm: 32); - setBalloonText: aMorph label. - button icon: button magnifiedIcon. - viewBox - addMorph: button - fixedWidth: self defaultHeight ]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3072-taskbarButtonTogglesCollapsing-JuanVuletich-2017Mar30-08h36m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3072] on 30 March 2017 at 8:57:52 am'! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 3/30/2017 08:54:49'! - aboutToCollapse: aMorph - "Add a button for aMorph if not already there (see #taskbarIncludesAllWindows)" - - (self buttonFor: aMorph) ifNil: [ - self addButtonFor: aMorph ]! ! -!Morph methodsFor: 'user interface' stamp: 'jmv 3/30/2017 08:55:31' prior: 50341572! - collapse - "If taskbar not visible, just hide." - - self taskbar - ifNotNil: [ :tb | tb aboutToCollapse: self ]. - self hide! ! - -TaskbarMorph removeSelector: #wasCollapsed:! - -TaskbarMorph removeSelector: #wasCollapsed:! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3073-TaskbarFix-JuanVuletich-2017Mar30-08h57m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3064] on 29 March 2017 at 5:18:04 pm'! - -Object subclass: #ExceptionHandlingCondition - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #ExceptionHandlingCondition category: #'Exceptions Kernel'! -Object subclass: #ExceptionHandlingCondition - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! -!ExceptionHandlingCondition commentStamp: '' prior: 0! - I represent the protocol expected to be as condition on the exception handling message on:do: -I also define the protocol to create and combine exceptions handling conditions. -See methods #, and #- for a complemented documentation! -!ExceptionHandlingCondition commentStamp: '' prior: 50341645! - I represent the protocol expected to be as condition on the exception handling message on:do: -I also define the protocol to create and combine exceptions handling conditions. -See methods #, and #- for a complemented documentation! - -Smalltalk renameClassNamed: #ExceptionFilter as: #FilterExceptionHandlingCondition! - -ExceptionHandlingCondition subclass: #FilterExceptionHandlingCondition - instanceVariableNames: 'handleCondition filterCondition' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #FilterExceptionHandlingCondition category: #'Exceptions Kernel'! -ExceptionHandlingCondition subclass: #FilterExceptionHandlingCondition - instanceVariableNames: 'handleCondition filterCondition' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -Smalltalk renameClassNamed: #ExceptionAdd as: #OrExceptionHandlingCondition! - -ExceptionHandlingCondition subclass: #OrExceptionHandlingCondition - instanceVariableNames: 'leftCondition rightCondition' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #OrExceptionHandlingCondition category: #'Exceptions Kernel'! -ExceptionHandlingCondition subclass: #OrExceptionHandlingCondition - instanceVariableNames: 'leftCondition rightCondition' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! -!BlockClosure methodsFor: 'error handing' stamp: 'HAW 3/29/2017 15:16:01'! - handles: anException - - "This allows a block to be the handling condition of an exception handling. - See Exception class>>handles:" - - ^self value: anException ! ! -!Exception class methodsFor: 'handling condition creation' stamp: 'HAW 3/28/2017 15:48:57' prior: 16840211! - , anExceptionHandlingCondition - - "See ExceptionHandlingCondition>>," - - ^anExceptionHandlingCondition createOrConditionWithExceptionType: self! ! -!Exception class methodsFor: 'handling condition creation' stamp: 'HAW 3/28/2017 15:49:08'! - - anExceptionHandlingCondition - - "See ExceptionHandlingCondition>>-" - - ^anExceptionHandlingCondition createFilterConditionWithExceptionType: self! ! -!Exception class methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 11:23:04'! - createFilterConditionWithExceptionType: anExceptionType - - ^FilterExceptionHandlingCondition handling: anExceptionType filtering: self! ! -!Exception class methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 11:26:42'! - createFilterConditionWithFilterCondition: aFilterExceptionHandlingCondition - - ^FilterExceptionHandlingCondition handling: aFilterExceptionHandlingCondition filtering: self! ! -!Exception class methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 15:40:33'! - createFilterConditionWithOrCondition: anOrExceptionHandlingCondition - - ^FilterExceptionHandlingCondition handling: anOrExceptionHandlingCondition filtering: self! ! -!Exception class methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 15:37:59'! - createOrConditionWithExceptionType: anExceptionType - - ^OrExceptionHandlingCondition handling: anExceptionType or: self -! ! -!Exception class methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 15:48:29'! - createOrConditionWithFilterCondition: aFilterExceptionHandlingCondition - - ^aFilterExceptionHandlingCondition handleCondition, self - aFilterExceptionHandlingCondition filterCondition - - ! ! -!Exception class methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 11:09:54'! - createOrConditionWithOrCondition: anOrExceptionHandlingCondition - - ^OrExceptionHandlingCondition handling: anOrExceptionHandlingCondition or: self! ! -!ExceptionHandlingCondition methodsFor: 'error handling' stamp: 'HAW 3/28/2017 17:29:18'! - handles: anException - - "Must return true if anException must be handle - See also Exception class>>handles: anException" - - self subclassResponsibility ! ! -!ExceptionHandlingCondition methodsFor: 'handling condition creation' stamp: 'HAW 3/28/2017 17:17:36'! - , anExceptionHandlingCondition - - "Creates a handling condition that will return true if either part of the condition handles the exception. - It behaves like an or - The following example will handle the exception - [ Error signal ] - on: Error, Halt - do: [ :anError | ... ] - - The following example will also handle the exception: - [ Halt signal ] - on: Error, Halt - do: [ :anError | ... ]" - - self subclassResponsibility - ! ! -!ExceptionHandlingCondition methodsFor: 'handling condition creation' stamp: 'HAW 3/29/2017 13:59:37'! - - anExceptionHandlingCondition - - "Creates a handling condition that will not handle exceptions that meet the right side of the condition - The following example will not handle the exception - [ 1/0 ] - on: Error - ZeroDivide - do: [ :anError | ... ] - - The following example will handle the exception: - [ Error signal ] - on: Error - ZeroDivide - do: [ :anError | ... ] - - Due to inconsisties that can arrise with combining #, with #- the implementation orders the in such a way that 'or conditions' go first - and 'filter conditions' go last. Doing so (Error - Notification) , (UnhandledError - ZeroDivide) is converted to Error, UnhandledError - Notification - ZeroDivide - Inconsisties can arrise because ZeroDivide is a subclass of Error and therefore if the condition is not ordered correctly a ZeroDivide could be handled. - This inconsisty can be found in Pharo where the condition (Error - Notification) , (UnhandledError - ZeroDivide) does not filter ZeroDivide but - the condition Error, UnhandledError - Notification - ZeroDivide does filter it. - That is the reason the implementation uses double dispatch - " - - self subclassResponsibility - ! ! -!ExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/29/2017 13:31:13'! -createFilterConditionWithExceptionType: anExceptionType - - self subclassResponsibility ! ! -!ExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/29/2017 13:33:31'! - createFilterConditionWithFilterCondition: aFilterExceptionHandlingCondition - - self subclassResponsibility ! ! -!ExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/29/2017 13:33:39'! -createFilterConditionWithOrCondition: anOrExceptionHandlingCondition - - self subclassResponsibility ! ! -!ExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/29/2017 13:33:51'! - createOrConditionWithExceptionType: anExceptionType - - self subclassResponsibility ! ! -!ExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/29/2017 13:34:31'! - createOrConditionWithFilterCondition: aFilterExceptionHandlingCondition - - self subclassResponsibility ! ! -!ExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/29/2017 13:34:42'! - createOrConditionWithOrCondition: anOrExceptionHandlingCondition - - self subclassResponsibility ! ! -!FilterExceptionHandlingCondition methodsFor: 'accessing' stamp: 'HAW 3/28/2017 17:20:21'! - filterCondition - - ^filterCondition ! ! -!FilterExceptionHandlingCondition methodsFor: 'accessing' stamp: 'HAW 3/28/2017 17:20:26'! - handleCondition - - ^handleCondition ! ! -!FilterExceptionHandlingCondition methodsFor: 'error handling' stamp: 'HAW 3/28/2017 17:20:41'! - handles: anException - - ^ (filterCondition handles: anException) not and: [ handleCondition handles: anException ]! ! -!FilterExceptionHandlingCondition methodsFor: 'initialization' stamp: 'HAW 3/29/2017 13:45:21'! - initializeHandling: aHandleCondition filtering: aFilterCondition - - handleCondition _ aHandleCondition. - filterCondition _ aFilterCondition ! ! -!FilterExceptionHandlingCondition methodsFor: 'handling condition creation' stamp: 'HAW 3/29/2017 13:59:08'! - , anExceptionHandlingCondition - - "See ExceptionHandlingCondition>>#- for an explanation of why double dispatch is used as implementation" - - ^anExceptionHandlingCondition createOrConditionWithFilterCondition: self! ! -!FilterExceptionHandlingCondition methodsFor: 'handling condition creation' stamp: 'HAW 3/29/2017 13:59:00'! - - anExceptionHandlingCondition - - "See ExceptionHandlingCondition>>#- for an explanation of why double dispatch is used as implementation" - - ^anExceptionHandlingCondition createFilterConditionWithFilterCondition: self! ! -!FilterExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 17:56:46'! - createFilterConditionWithExceptionType: anExceptionType - - ^self class - handling: anExceptionType, filterCondition - filtering: handleCondition ! ! -!FilterExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 17:19:24'! - createFilterConditionWithFilterCondition: aFilterExceptionHandlingCondition - - ^aFilterExceptionHandlingCondition - handleCondition, filterCondition ! ! -!FilterExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 17:19:48'! - createFilterConditionWithOrCondition: anOrExceptionHandlingCondition - - ^anOrExceptionHandlingCondition, filterCondition - handleCondition ! ! -!FilterExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 17:19:56'! - createOrConditionWithExceptionType: anExceptionType - - ^anExceptionType - handleCondition - filterCondition ! ! -!FilterExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 17:20:04'! - createOrConditionWithFilterCondition: aFilterExceptionHandlingCondition - - ^aFilterExceptionHandlingCondition handleCondition,handleCondition - aFilterExceptionHandlingCondition filterCondition - filterCondition ! ! -!FilterExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/29/2017 15:32:33'! - createOrConditionWithOrCondition: anOrExceptionHandlingCondition - - ^anOrExceptionHandlingCondition, handleCondition - filterCondition ! ! -!FilterExceptionHandlingCondition methodsFor: 'printing' stamp: 'HAW 3/28/2017 17:20:55'! - printOn: aStream - - aStream - print: handleCondition ; - nextPutAll: ' - '; - print: filterCondition ! ! -!FilterExceptionHandlingCondition class methodsFor: 'instance creation' stamp: 'HAW 3/28/2017 17:18:11'! - handling: aHandleCondition filtering: aFilterCondition - - ^self new initializeHandling: aHandleCondition filtering: aFilterCondition -! ! -!OrExceptionHandlingCondition methodsFor: 'accessing' stamp: 'HAW 3/28/2017 17:55:27'! - leftCondition - - ^leftCondition ! ! -!OrExceptionHandlingCondition methodsFor: 'accessing' stamp: 'HAW 3/28/2017 17:56:11'! - rightCondition - - ^rightCondition ! ! -!OrExceptionHandlingCondition methodsFor: 'error handling' stamp: 'HAW 3/28/2017 17:31:39'! - handles: anException - - ^ (leftCondition handles: anException) or: [ rightCondition handles: anException ]! ! -!OrExceptionHandlingCondition methodsFor: 'initialization' stamp: 'HAW 3/28/2017 17:32:20'! - initializeHandling: aLeftCondition or: aRightCondition - - leftCondition _ aLeftCondition. - rightCondition _ aRightCondition ! ! -!OrExceptionHandlingCondition methodsFor: 'handling condition creation' stamp: 'HAW 3/29/2017 13:59:16'! - , anExceptionHandlingCondition - - "See ExceptionHandlingCondition>>#- for an explanation of why double dispatch is used as implementation" - - ^anExceptionHandlingCondition createOrConditionWithOrCondition: self - ! ! -!OrExceptionHandlingCondition methodsFor: 'handling condition creation' stamp: 'HAW 3/29/2017 13:59:22'! -- anExceptionHandlingCondition - - "See ExceptionHandlingCondition>>#- for an explanation of why double dispatch is used as implementation" - - ^anExceptionHandlingCondition createFilterConditionWithOrCondition: self - ! ! -!OrExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 17:32:37'! - createFilterConditionWithExceptionType: anExceptionType - - ^FilterExceptionHandlingCondition - handling: anExceptionType - leftCondition - filtering: rightCondition ! ! -!OrExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 17:33:37'! - createFilterConditionWithFilterCondition: aFilterExceptionHandlingCondition - - ^aFilterExceptionHandlingCondition - leftCondition - rightCondition ! ! -!OrExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 17:34:05'! - createFilterConditionWithOrCondition: anOrExceptionHandlingCondition - - ^ anOrExceptionHandlingCondition - leftCondition - rightCondition ! ! -!OrExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 11:16:37'! - createOrConditionWithExceptionType: anExceptionType - - ^self class handling: anExceptionType or: self! ! -!OrExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 14:56:09'! - createOrConditionWithFilterCondition: aFilterExceptionHandlingCondition - - ^self, aFilterExceptionHandlingCondition ! ! -!OrExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 11:20:32'! - createOrConditionWithOrCondition: anOrExceptionHandlingCondition - - ^self class handling: anOrExceptionHandlingCondition or: self! ! -!OrExceptionHandlingCondition methodsFor: 'printing' stamp: 'HAW 3/28/2017 17:54:46'! - printOn: aStream - - aStream - print: leftCondition; - nextPutAll: ', '; - print: rightCondition ! ! -!OrExceptionHandlingCondition class methodsFor: 'instance creation' stamp: 'HAW 3/27/2017 15:47:32'! - handling: anExceptionClass or: anotherExceptionClass - - ^self new initializeHandling: anExceptionClass or: anotherExceptionClass -! ! - -OrExceptionHandlingCondition removeSelector: #createOrHandlingConditionWithOrHandlingCondition:! - -Exception class removeSelector: #createFilterConditionWithExceptionClass:! - -Exception class removeSelector: #createHandlingConditionWithExceptionClass:! - -Exception class removeSelector: #handling:! - -Exception class removeSelector: #orHandlingExceptionClass:! - -Smalltalk removeClassNamed: #ExceptionSet! - -Smalltalk removeClassNamed: #ExceptionSet! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3074-ExceptionHandlingConditionEnh-HernanWilkinson-2017Mar26-18h04m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3064] on 29 March 2017 at 6:09:56 pm'! -!FilterExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/29/2017 17:59:55' prior: 50341959! - createOrConditionWithExceptionType: anExceptionType - - ^anExceptionType, handleCondition - filterCondition ! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3075-ExceptionHandlingConditionFix-HernanWilkinson-2017Mar29-17h18m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3068] on 16 April 2017 at 7:53:58 pm'! -!TextEditor methodsFor: 'menu messages' stamp: 'jmv 4/16/2017 19:53:14' prior: 16932110! - compareToClipboard - "Check to see if whether the receiver's text is the same as the text currently on the clipboard, and inform the user." - | s1 s2 | - s1 _ self clipboardStringOrText string. - s2 _ self selection ifEmpty: [self privateCurrentString]. - s1 = s2 ifTrue: [^ self inform: 'Exact match']. - - (TextModel new contents: - (DifferenceFinder displayPatchFrom: s1 to: s2 tryWords: true)) - openLabel: 'Comparison to Clipboard Text'! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3076-CompareToClipboardComparesSelection-JuanVuletich-2017Apr16-19h53m-jmv.1.cs.st----! - -----SNAPSHOT----#(16 April 2017 9:01:20.664991 pm) Cuis5.0-3076-spur.image priorSource: 314822! - -----QUIT----#(16 April 2017 9:01:36.688921 pm) Cuis5.0-3076-spur.image priorSource: 336566! - -----STARTUP----#(14 May 2017 7:54:53.882687 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3076-spur.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3076] on 13 May 2017 at 12:54:11 pm'! -!Integer methodsFor: 'printing' stamp: 'jmv 5/9/2017 19:45:38'! - printOn: aStream length: minimum zeroPadded: zeroFlag - " - 7 printOn: Transcript length: 4 padded: true. Transcript newLine. - " - self printOn: aStream base: 10 length: minimum padded: zeroFlag! ! -!Character methodsFor: 'accessing' stamp: 'jmv 5/9/2017 19:49:32' prior: 16800371! - 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. - $0 numericValue = 48 - $9 numericValue = 57 - $A numericValue = 65 - $Z numericValue = 90 - $7 digitValue = 7 - " - - | nv | - nv _ self numericValue. - (nv between: 48 and: 57) - ifTrue: [ ^ nv - 48 ]. - (nv between: 65 and: 90) - ifTrue: [ ^ nv - 55 ]. - ^ -1! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3077-Integer-printPadded-JuanVuletich-2017May13-12h51m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3076] on 13 May 2017 at 1:02:33 pm'! -!Timespan class methodsFor: 'squeak protocol' stamp: 'jmv 5/9/2017 19:54:38'! - fromString: aString - "Please call with specific subclass." - - ^ self readFrom: aString readStream! ! -!Week class methodsFor: 'squeak protocol' stamp: 'jmv 5/12/2017 17:48:37'! - readFrom: aStream - "Read a Week from the stream in any of the forms: - -W (2009-W01) (ISO8601)" - | weekNumber yearNumber firstAsNumber firstAsNumberSign | - firstAsNumberSign := aStream peek = $- ifTrue: [-1] ifFalse: [1]. - [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. - aStream peek isDigit ifTrue: [ - firstAsNumber := (Integer readFrom: aStream) * firstAsNumberSign. - (firstAsNumber < 0 or: [firstAsNumber > 12]) - ifTrue: [yearNumber := firstAsNumber]]. - - [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. - aStream next = $W ifFalse: [ - self error: 'Invalid Format' ]. - - weekNumber _ Integer readFrom: aStream. - weekNumber < 1 ifTrue: [ self error: 'Invalid Format' ]. - (yearNumber < 100 and: [yearNumber >= 0]) ifTrue: [ - yearNumber _ yearNumber < 69 - ifTrue: [2000 + yearNumber] - ifFalse: [1900 + yearNumber]]. - - ^ self yearNumber: yearNumber weekNumber: weekNumber! ! -!Week class methodsFor: 'squeak protocol' stamp: 'jmv 5/13/2017 10:54:55'! - yearNumber: yearNumber weekNumber: weekNumber - - | firstOfJanuary firstThursday thisThursday | - firstOfJanuary _ DateAndTime year: yearNumber month: 1 day: 1. - firstThursday _ firstOfJanuary + (4 - firstOfJanuary dayOfWeek \\ 7) days. - thisThursday _ firstThursday + ((weekNumber-1) * 7) days. - - thisThursday yearNumber = yearNumber - ifFalse: [ self error: 'Week does not exist' ]. - - ^ self including: thisThursday! ! -!Year class methodsFor: 'squeak protocol' stamp: 'jmv 5/12/2017 16:41:15'! - readFrom: aStream - - | year sign | - sign := aStream peek = $- ifTrue: [-1] ifFalse: [1]. - [aStream peek isDigit] whileFalse: [aStream skip: 1]. - year := (Integer readFrom: aStream) * sign. - ^ self yearNumber: year! ! -!String methodsFor: 'converting' stamp: 'jmv 5/12/2017 11:24:09'! - asMonth - "Many allowed forms, see Month>>#readFrom: - 'July 1998' asMonth. - '1998/7'asMonth. - " - - ^ Month fromString: self! ! -!String methodsFor: 'converting' stamp: 'jmv 5/12/2017 16:39:13'! - asWeek - " - '2008-W52' asWeek. - '2008-W53' asWeek. 'Invalid format!!'. - '2009-W01' asWeek - '2009-W02' asWeek - '2009-W53' asWeek - '2010-W01' asWeek - '2010-W02' asWeek - '2008-W52' asWeek start. - '2009-W01' asWeek start - '2009-W02' asWeek start - '2009-W53' asWeek start - '2010-W01' asWeek start - '2010-W02' asWeek start - " - - ^ Week fromString: self! ! -!String methodsFor: 'converting' stamp: 'jmv 5/12/2017 16:37:23'! - asYear - " - '2008' asYear. - '2008' asYear start. - " - - ^ Year fromString: self! ! -!DateAndTime methodsFor: 'ansi protocol' stamp: 'jmv 5/12/2017 10:55:06' prior: 16828675! - dayOfWeek - - " - Sunday=1, ... , Saturday=7 - Monday=1, ... , Sunday=7 - '12 May 2017 ' asDate dayOfWeek = 5 - " - - ^ (jdn rem: 7) + 1! ! -!DateAndTime methodsFor: 'ansi protocol' stamp: 'jmv 5/12/2017 10:53:00' prior: 16828685! - dayOfWeekName - " - '12 May 2017 ' asDate dayOfWeek = 5 - '12 May 2017 ' asDate dayOfWeekName = #Friday - " - - ^ Week nameOfDay: self dayOfWeek -! ! -!Duration methodsFor: 'squeak protocol' stamp: 'jmv 5/12/2017 10:59:51' prior: 16836040! - printOn: aStream - "Format as per ANSI 5.8.2.16: [-]D:HH:MM:SS[.S] - (Duration days: 2 hours: 3 minutes: 16 seconds: 43) printString = '2:03:16:43' - " - | d h m s n | - d _ self days abs. - h _ self hours abs. - m _ self minutes abs. - s _ self seconds abs truncated. - n _ self nanoSeconds abs. self negative ifTrue: [ aStream nextPut: $- ]. - d printOn: aStream. aStream nextPut: $:. - h printOn: aStream length: 2 zeroPadded: true.aStream nextPut: $:. - m printOn: aStream length: 2 zeroPadded: true.aStream nextPut: $:. - s printOn: aStream length: 2 zeroPadded: true. - n = 0 ifFalse: [ - | z ps | - aStream nextPut: $.. - ps _ n printString padded: #left to: 9 with: $0. - z _ ps findLast: [ :c | c digitValue > 0 ]. - ps from: 1 to: z do: [ :c | aStream nextPut: c ] ]! ! -!Date methodsFor: 'smalltalk-80' stamp: 'jmv 5/12/2017 10:54:58' prior: 16828235! - weekdayIndex - "Sunday=1, ... , Saturday=7 - Monday=1, ... , Sunday=7 - '12 May 2017 ' asDate weekdayIndex = 5 - " - - ^ self dayOfWeek! ! -!Date class methodsFor: 'squeak protocol' stamp: 'jmv 5/10/2017 21:56:27' prior: 16828417! -readFrom: aStream - "Read a Date from the stream in any of the forms: - (15 April 1982; 15-APR-82; 15.4.82; 15APR82) - (April 15, 1982; 4/15/82) - -- (1982-04-15) (ISO8601)" - | day month year firstAsNumber firstAsNumberSign | - firstAsNumberSign := aStream peek = $- ifTrue: [-1] ifFalse: [1]. - [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. - aStream peek isDigit ifTrue: [ - firstAsNumber := (Integer readFrom: aStream) * firstAsNumberSign. - (firstAsNumber < 0 or: [firstAsNumber > 31]) - ifTrue: [year := firstAsNumber]]. - - [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. - aStream peek isLetter - ifTrue: ["MonthName-DD-YY or DD-MonthName-YY or YY-MonthName-DD" - month _ String streamContents: [ :strm | - [ aStream peek isLetter ] whileTrue: [ strm nextPut: aStream next ]]. - [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. - firstAsNumber - ifNil: ["MonthName DD YY" - day := Integer readFrom: aStream] - ifNotNil: [ - year ifNil: ["DD MonthName YY" - day := firstAsNumber]]] - ifFalse: ["MM-DD-YY or DD-MM-YY or YY-MM-DD" - year - ifNil: ["MM-DD-YY or DD-MM-YY" - firstAsNumber > 12 - ifTrue: ["DD-MM-YY" - day := firstAsNumber. - month := Month nameOfMonth: (Integer readFrom: aStream)] - ifFalse: ["MM-DD-YY" - month := Month nameOfMonth: firstAsNumber. - day := Integer readFrom: aStream]] - ifNotNil: ["YY-MM-DD" - month := Month nameOfMonth: (Integer readFrom: aStream)]]. - - [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. - year - ifNil: [year := Integer readFrom: aStream] - ifNotNil: [day := Integer readFrom: aStream]. - (year < 100 and: [year >= 0]) ifTrue: [ - year _ year < 69 - ifTrue: [2000 + year] - ifFalse: [1900 + year]]. - - ^ self year: year month: month day: day! ! -!Month class methodsFor: 'squeak protocol' stamp: 'jmv 5/12/2017 11:28:03' prior: 16873841! - readFrom: aStream - "Read a Month from the stream in any of the forms: - (April 1982; APR-82; 4.82; APR82) - (April, 1982; 4/82) - - (1982-04) (ISO8601)" - " - Month readFrom: 'July 1998' readStream - " - | month year firstAsNumber firstAsNumberSign | - firstAsNumberSign := aStream peek = $- ifTrue: [-1] ifFalse: [1]. - [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. - aStream peek isDigit ifTrue: [ - firstAsNumber := (Integer readFrom: aStream) * firstAsNumberSign. - (firstAsNumber < 0 or: [firstAsNumber > 12]) - ifTrue: [year := firstAsNumber]]. - - [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. - aStream peek isLetter - ifTrue: ["MonthName-YY or YY-MonthName" - month _ String streamContents: [ :strm | - [ aStream peek isLetter ] whileTrue: [ strm nextPut: aStream next ]]. - [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]] - ifFalse: ["MM-YY or YY-MM" - month _ year - ifNil: ["MM-YY" - Month nameOfMonth: firstAsNumber ] - ifNotNil: ["YY-MM" - Month nameOfMonth: (Integer readFrom: aStream)]]. - - year ifNil: [ - [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. - year := Integer readFrom: aStream]. - (year < 100 and: [year >= 0]) ifTrue: [ - year _ year < 69 - ifTrue: [2000 + year] - ifFalse: [1900 + year]]. - - ^ self month: month year: year! ! -!Week methodsFor: 'squeak protocol' stamp: 'jmv 5/12/2017 11:53:32' prior: 16944751! - printOn: aStream - " - '2008-W52' asWeek. - '2009-W01' asWeek - '2009-W02' asWeek - '2009-W53' asWeek - '2010-W01' asWeek - '2010-W02' asWeek - " - | thursday | - thursday _ self start + 3 days. - thursday yearNumber printOn: aStream. - aStream nextPutAll: '-W'. - (thursday dayOfYear-1 // 7 + 1) printOn: aStream length: 2 zeroPadded: true! ! -!Week class methodsFor: 'squeak protocol' stamp: 'jmv 5/12/2017 10:54:04' prior: 16944773! - indexOfDay: aSymbol - " - Week indexOfDay: #Sunday = 7 - Week nameOfDay: 7 = #Sunday - " - - ^ self dayNames indexOf: aSymbol! ! -!Week class methodsFor: 'smalltalk-80' stamp: 'jmv 5/12/2017 10:53:55' prior: 16944778! - nameOfDay: anIndex - " - Week indexOfDay: #Sunday = 7 - Week nameOfDay: 7 = #Sunday - " - - ^ self dayNames at: anIndex! ! -!Week class methodsFor: 'inquiries' stamp: 'jmv 5/10/2017 22:25:02' prior: 16944786! - dayNames - - ^ #(Monday Tuesday Wednesday Thursday Friday Saturday Sunday)! ! -!String methodsFor: 'converting' stamp: 'jmv 5/12/2017 11:22:17' prior: 16916294! - asDate - "Many allowed forms, see Date>>#readFrom: - '2014/6/30' asDate. - '70/12/30' asDate. - '12/30/70' asDate. - '30/12/70' asDate. - '4/5/6' asDate. - '15 April 1982' asDate. - " - - ^ Date fromString: self! ! - -Date class removeSelector: #fromString:! - -Date class removeSelector: #fromString:! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3078-WeekStartsOnMonday-NewWeekMonthYearCreationMethods-JuanVuletich-2017May13-12h54m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3076] on 13 May 2017 at 1:02:55 pm'! -!DateAndTime methodsFor: 'double dispatching' stamp: 'jmv 5/12/2017 17:17:21'! - includingTimespanOf: aTimespanClass - - ^ aTimespanClass includingDateAndTime: self! ! -!Timespan methodsFor: 'double displatching' stamp: 'jmv 5/12/2017 17:17:18'! - includingTimespanOf: aTimespanClass - - ^ aTimespanClass includingTimespan: self! ! -!Timespan class methodsFor: 'instance creation' stamp: 'jmv 5/12/2017 16:48:47'! - includingDateAndTime: aDateAndTime - - ^ self starting: aDateAndTime duration: Duration zero! ! -!Timespan class methodsFor: 'instance creation' stamp: 'jmv 5/12/2017 17:22:59'! - includingTimespan: aDateAndTime - - | ending starting | - starting _ self includingDateAndTime: aDateAndTime start. - ending _ self includingDateAndTime: aDateAndTime end. - starting = ending ifTrue: [ ^ starting ]. - self error: aDateAndTime printString, ' can not be included in a ', self name! ! -!Date class methodsFor: 'instance creation' stamp: 'jmv 5/12/2017 16:48:52'! - includingDateAndTime: aDateAndTime - - ^self basicNew - start: aDateAndTime midnight; - duration: (Duration days: 1); - yourself! ! -!Month class methodsFor: 'squeak protocol' stamp: 'jmv 5/12/2017 16:48:55'! - includingDateAndTime: aDateAndTime - "Months start at day 1" - | monthStart days | - monthStart _ DateAndTime - year: aDateAndTime yearNumber - month: aDateAndTime monthIndex - day: 1. - days _ self daysInMonth: monthStart monthIndex forYear: monthStart yearNumber. - ^ self basicNew - start: monthStart; - duration: (Duration days: days); - yourself! ! -!Week class methodsFor: 'squeak protocol' stamp: 'jmv 5/12/2017 18:05:57'! - includingDateAndTime: aDateAndTime - " - Week including: '12 May 2017 ' asDate start - (Week including: '12 May 2017 ' asDate start) start dayOfWeekName = #Monday - " - - | midnight weekStart | - midnight _ aDateAndTime midnight. - weekStart _ midnight - (midnight dayOfWeek - 1) days. - - ^ self basicNew - start: weekStart; - duration: (Duration weeks: 1); - yourself! ! -!Year class methodsFor: 'squeak protocol' stamp: 'jmv 5/12/2017 18:00:49'! - includingDateAndTime: aDateAndTime - "Answer a calendar year" - - ^ self yearNumber: aDateAndTime yearNumber! ! -!Timespan class methodsFor: 'instance creation' stamp: 'jmv 5/12/2017 17:18:23' prior: 16938217! - including: aDateAndTime - - ^ aDateAndTime includingTimespanOf: self! ! -!Year class methodsFor: 'squeak protocol' stamp: 'jmv 5/12/2017 17:43:17' prior: 16946731! - yearNumber: aYear - - | yearStart | - yearStart _ DateAndTime year: aYear month: 1 day: 1. - ^ self basicNew - start: yearStart; - duration: (Duration days: (self daysInYear: yearStart yearNumber)); - yourself! ! - -Year class removeSelector: #including:! - -Year class removeSelector: #including:! - -Week class removeSelector: #including:! - -Week class removeSelector: #including:! - -Month class removeSelector: #including:! - -Month class removeSelector: #including:! - -Date class removeSelector: #including:! - -Date class removeSelector: #including:! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3079-TimespanCreation-includingTimespan-JuanVuletich-2017May13-13h02m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3079] on 13 May 2017 at 2:18:26 pm'! -!DateAndTime methodsFor: 'private' stamp: 'jmv 5/13/2017 10:58:22'! - substractDateAndtime: operand - "operand is a DateAndTime or a Duration" - - | lvalue rvalue | - offset = operand offset - ifTrue: [ - lvalue _ self. - rvalue _ operand ] - ifFalse: [ - lvalue _ self asUTC. - rvalue _ operand asUTC ]. - ^ Duration - seconds: (Time secondsInDay *(lvalue julianDayNumber - rvalue julianDayNumber)) + - (lvalue secondsSinceMidnight - rvalue secondsSinceMidnight) - nanoSeconds: lvalue nanoSecond - rvalue nanoSecond! ! -!DateAndTime methodsFor: 'private' stamp: 'jmv 5/13/2017 10:58:31'! - substractDuration: operand - "operand is a DateAndTime or a Duration" - - ^self + operand negated! ! -!DateAndTime methodsFor: 'double dispatching' stamp: 'jmv 5/13/2017 10:59:45'! - substractFrom: aDateAndTime - - ^ aDateAndTime substractDateAndtime: self! ! -!Duration methodsFor: 'double dispatching' stamp: 'jmv 5/13/2017 11:03:50'! - substractFrom: aDateAndTimeOrDate - - ^aDateAndTimeOrDate substractDuration: self! ! -!Timespan methodsFor: 'private' stamp: 'jmv 5/13/2017 11:09:07'! - substractDuration: aDuration - - ^self class classDefinesDuration - ifTrue: [ self class including: start - aDuration ] - ifFalse: [ self class starting: start - aDuration duration: duration ]! ! -!Timespan methodsFor: 'private' stamp: 'jmv 5/13/2017 11:18:25'! - substractTimespan: aTimespan - - aTimespan duration = self duration ifFalse: [ - self error: 'Can not substract Timespans of different duration' ]. - - ^self start substractDateAndtime: aTimespan start! ! -!Timespan methodsFor: 'double displatching' stamp: 'jmv 5/13/2017 11:08:17'! - substractFrom: aTimespan - - ^ aTimespan substractTimespan: self! ! -!DateAndTime methodsFor: 'ansi protocol' stamp: 'jmv 5/13/2017 11:00:53' prior: 16828596! - - operand - "operand is a DateAndTime or a Duration. - Double dispatch" - - ^ operand substractFrom: self! ! -!Timespan methodsFor: 'ansi protocol' stamp: 'jmv 5/13/2017 14:16:21' prior: 16937995! -- aDurationOrTimespan - - ^ aDurationOrTimespan substractFrom: self! ! -!Timespan methodsFor: 'squeak protocol' stamp: 'jmv 5/13/2017 11:13:39' prior: 16938027! - includes: operand - "Operand might be a Timespan or a DateAndtime" - - ^ (operand is: #Timespan) - ifTrue: [ (self includes: operand start) - and: [ self includes: operand end ] ] - ifFalse: [ operand between: start and: self end ]! ! -!Timespan class methodsFor: 'instance creation' stamp: 'jmv 5/13/2017 11:12:44' prior: 50342531! - includingTimespan: aTimespan - - | ending starting | - starting _ self includingDateAndTime: aTimespan start. - ending _ self includingDateAndTime: aTimespan end. - starting = ending ifTrue: [ ^ starting ]. - self error: aTimespan printString, ' can not be included in a ', self name! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3080-TimespanLessTimespan-JuanVuletich-2017May13-14h12m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3080] on 13 May 2017 at 7:48:17 pm'! -!Week methodsFor: 'public protocol' stamp: 'jmv 5/13/2017 14:37:37'! - weekNumber - - | thursday | - thursday _ self start + 3 days. - ^thursday dayOfYear-1 // 7 + 1! ! -!Week methodsFor: 'public protocol' stamp: 'jmv 5/13/2017 14:37:18'! - yearNumber - - | thursday | - thursday _ self start + 3 days. - ^thursday yearNumber! ! -!Year methodsFor: 'public protocol' stamp: 'jmv 5/13/2017 14:51:58'! - yearNumber - - ^ start yearNumber! ! -!Week methodsFor: 'squeak protocol' stamp: 'jmv 5/13/2017 14:38:20' prior: 50342460! - printOn: aStream - " - '2008-W52' asWeek. - '2009-W01' asWeek - '2009-W02' asWeek - '2009-W53' asWeek - '2010-W01' asWeek - '2010-W02' asWeek - " - self yearNumber printOn: aStream. - aStream nextPutAll: '-W'. - self weekNumber printOn: aStream length: 2 zeroPadded: true! ! -!Week class methodsFor: 'squeak protocol' stamp: 'jmv 5/13/2017 14:59:27' prior: 50342474! - indexOfDay: aSymbol - " - (Week indexOfDay: #Sunday) = 7 - (Week nameOfDay: 7) = #Sunday - " - - ^ self dayNames indexOf: aSymbol! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3081-WeekYearTweaks-JuanVuletich-2017May13-19h46m-jmv.1.cs.st----! - -Smalltalk garbageCollect.! - -Cursor webLink maskForm bits: (Form extent: 16@16 - fromArray: (#(3072 7680 7680 7680 7680 8118 8191 32767 65535 65535 65535 65535 65535 32766 32766 16380 ) collect: [:bits | bits bitShift: 16]) - offset: 0@0) bits. -Smalltalk garbageCollect.! - -Form allInstances! - -----SNAPSHOT----#(14 May 2017 7:55:21.560658 pm) Cuis5.0-3081-spur.image priorSource: 336663! - -----QUIT----#(14 May 2017 7:55:32.533128 pm) Cuis5.0-3081-spur.image priorSource: 355570! - -----STARTUP----#(25 May 2017 10:00:51.36548 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3081-spur.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3081] on 16 May 2017 at 10:43:45 am'! -!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'jmv 5/16/2017 10:43:40' prior: 16896077! - defaultAction - - | delta textFrame barFrame outerFrame result range width filledWidth f h textWidth textForm innerBarFrame oldFilledWidth oldFilledWidth2 prevContents | - f _ AbstractFont default. - h _ f height * 3//2. - textWidth _ (f widthOfString: progressTitle) + h. - width _ 150 max: textWidth. - - textForm _ Form extent: width@h depth: 32. - textForm fillBlack. - textForm fillWhite: (textForm boundingBox insetBy: 2). - progressTitle displayOn: textForm at: (width-textWidth+h//2@4). - barFrame _ Rectangle center: aPoint extent: width@h. - textFrame _ 0@0 extent: width@h. - textFrame _ textFrame - aligned: textFrame bottomCenter - with: barFrame topCenter + (0@2). - outerFrame _ barFrame merge: textFrame. - delta _ outerFrame amountToTranslateWithin: Display boundingBox. - barFrame _ barFrame translatedBy: delta. - textFrame _ textFrame translatedBy: delta. - outerFrame _ outerFrame translatedBy: delta. - prevContents _ Form fromDisplay: outerFrame. - range _ maxVal = minVal ifTrue: [1] ifFalse: [maxVal - minVal]. "Avoid div by 0" - innerBarFrame _ barFrame insetBy: 2. - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - oldFilledWidth _ 0. - oldFilledWidth2 _ 0. - result _ workBlock value: "Supply the bar-update block for evaluation in the work block" - [ :barVal | - barVal - ifNotNil: [ currentVal _ barVal ] - ifNil: [ - currentVal _ currentVal + 1. - currentVal >= maxVal - ifTrue: [ currentVal _ minVal ]]. - filledWidth _ ((barFrame width-4) asFloat * ((currentVal-minVal) asFloat / range min: 1.0)) asInteger. - filledWidth > oldFilledWidth ifTrue: [ - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - Display fillGray: (barFrame topLeft + (2@2) extent: filledWidth@17). - filledWidth -200 > oldFilledWidth2 - ifFalse: [ - "Usually just request an update, to be done asynchronously." - DisplayScreen screenUpdateRequired: outerFrame ] - ifTrue: [ - "Once in a while, force a real screen update (warning: really slow on MacOS if done too often)" - Display forceToScreen: outerFrame. oldFilledWidth2 _ filledWidth ]. - oldFilledWidth _ filledWidth ]]. - prevContents displayAt: outerFrame topLeft. - self resume: result! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3082-displayProgressAt-slownessOnMacFix-JuanVuletich-2017May16-10h38m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3082] on 24 May 2017 at 12:34:49 am'! -!Collection methodsFor: 'sorting' stamp: 'jmv 5/24/2017 00:28:06'! - sorted - "Return a new sequenceable collection which contains the same elements as self but its elements are sorted " - - ^self sorted: nil! ! -!ClassDescription methodsFor: 'instance variables' stamp: 'jmv 5/24/2017 00:29:04' prior: 16805949! - chooseInstVarAlphabeticallyThenDo: aBlock - | allVars index | - "Put up a menu of all the instance variables in the receiver, presented in alphabetical order, and when the user chooses one, evaluate aBlock with the chosen variable as its parameter." - - allVars _ self allInstVarNames sorted. - allVars isEmpty ifTrue: [^ self inform: 'There are no -instance variables']. - - index _ (PopUpMenu labelArray: allVars lines: #()) startUpWithCaption: 'Instance variables in -', self name. - index = 0 ifTrue: [^ self]. - aBlock value: (allVars at: index)! ! -!ClassDescription methodsFor: 'method dictionary' stamp: 'jmv 5/24/2017 00:28:55' prior: 16807219! - allMethodsInCategory: aSymbol - "Answer a list of all the method categories of the receiver and all its superclasses" - - | aColl | - aColl _ OrderedCollection new. - self withAllSuperclasses do: - [:aClass | aColl addAll: - (aSymbol == ClassOrganizer allCategory - ifTrue: - [aClass organization allMethodSelectors] - ifFalse: - [aClass organization listAtCategoryNamed: aSymbol])]. - ^ aColl asSet sorted - -"TileMorph allMethodsInCategory: #initialization"! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 5/24/2017 00:29:09' prior: 16924088! - browseClassesWithNamesContaining: aString caseSensitive: caseSensitive - "Smalltalk browseClassesWithNamesContaining: 'eMorph' caseSensitive: true " - "Launch a class-list list browser on all classes whose names containg aString as a substring." - - | suffix aList | - suffix _ caseSensitive - ifTrue: [' (case-sensitive)'] - ifFalse: [' (use shift for case-sensitive)']. - aList _ OrderedCollection new. - Smalltalk allClassesDo: [ :class | - (class name includesSubstring: aString caseSensitive: caseSensitive) - ifTrue: [aList add: class name]]. - aList size > 0 - ifTrue: [HierarchyBrowserWindow forClassesNamed: aList asSet sorted title: 'Classes whose names contain ' , aString , suffix]! ! -!ChangeSet methodsFor: 'method changes' stamp: 'jmv 5/24/2017 00:28:50' prior: 16797810! - changedMessageList - "Used by a message set browser to access the list view information." - - | messageList | - messageList _ OrderedCollection new. - changeRecords associationsDo: [ :clAssoc | | classNameInFull classNameInParts | - classNameInFull _ clAssoc key asString. - classNameInParts _ classNameInFull findTokens: ' '. - - (clAssoc value allChangeTypes includes: #comment) ifTrue: [ - messageList add: - (MethodReference new - setClassSymbol: classNameInParts first asSymbol - classIsMeta: false - methodSymbol: #Comment - stringVersion: classNameInFull, ' Comment')]. - - clAssoc value methodChangeTypes associationsDo: [ :mAssoc | - (#(remove addedThenRemoved movedToOtherPackage) includes: mAssoc value) ifFalse: [ - messageList add: - (MethodReference new - setClassSymbol: classNameInParts first asSymbol - classIsMeta: classNameInParts size > 1 - methodSymbol: mAssoc key - stringVersion: classNameInFull, ' ' , mAssoc key)]]]. - ^ messageList sorted! ! - -ArrayedCollection removeSelector: #asSortedArray! - -ArrayedCollection removeSelector: #asSortedArray! - -Collection removeSelector: #asSortedArray! - -Collection removeSelector: #asSortedArray! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3083-remove-asSortedArray-JuanVuletich-2017May24-00h34m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3083] on 25 May 2017 at 8:17:34 pm'! -!Integer methodsFor: 'benchmarks' stamp: 'jmv 5/25/2017 20:10:06' prior: 16859018! - tinyBenchmarks - "Report the results of running the two tiny Squeak benchmarks. - ar 9/10/1999: Adjusted to run at least 1 sec to get more stable results - 0 tinyBenchmarks - 292 MHz G3 Mac: 22,727,272 bytecodes/sec; 984,169 sends/sec - 400 MHz PII/Win98: 18,028,169 bytecodes/sec; 1,081,272 sends/sec - - RasPi2 - StackVM: 37,758,112 bytecodes/sec; 2,412,667 sends/sec - Raspi2- CogSSpur: 157,441,574 bytecodes/sec; 10,946,039 sends/sec - - C.H.I.P. (*1) - StackVM: 55,315,471 bytecodes/sec; 3,348,667 sends/sec - C.H.I.P. (*1) - CogSpur: 253,716,551 bytecodes/sec; 16,853,816 sends/sec - - 1.66GHz Atom N450 - Cog: 244,274,809 bytecodes/sec; 28,795,277 sends/sec - 1.66GHz Atom N450 - CogSpur: 469,724,770 bytecodes/sec; 30,754,699 sends/sec - - 1.33GHz Atom 3735G - Cog: 326,114,649 bytecodes/sec; 34,985,976 sends/sec - 1.33GHz Atom 3735G - CogSpur: 632,098,765 bytecodes/sec; 33,692,910 sends/sec - - 1.5GHz AMD A4-5000 APU - Cog: 390,243,902 bytecodes/sec; 47,507,997 sends/sec - 1.5GHz AMD A4-5000 APU - CogSpur: 675,907,590 bytecodes/sec; 40,669,724 sends/sec - 1.5GHz AMD A4-5000 APU - CogSpur64: 659,368,963 bytecodes/sec; 50,338,916 sends/sec - - 2.3GHz Tegra (*2) - StackVM: 258,847,320 bytecodes/sec; 13,014,759 sends/sec - 2.3GHz Tegra (*2) - CogSpur: 1,083,024,854 bytecodes/sec; 64,289,750 sends/sec - - 3.1GHz Core i3-2100 - Cog: 1,203,290,246 bytecodes/sec; 165,723,327 sends/sec - 3.1GHz Core i3-2100 - CogSpur: 2,042,892,768 bytecodes/sec; 127,837,794 sends/sec - - (*1) C.H.I.P. $9 Computer [Next Thing Co], Allwinner R8 Single-Core ARM Cortex-A8 - 1 GHz - (*2) ACER Chromebook CB5-311 - NVIDIA Tegra K1 Quad-Core ARM Cortex-A15 'r3' - 2.3 GHz - - It is interesting to note that Spur for the first time brings ARM hardware (RasPi and C.H.I.P.) into a 'Morphic is confortable and nice to use' level of performance. - " - | t1 t2 r n1 n2 | - n1 _ 1. - [ - t1 _ Time millisecondsToRun: [n1 benchmark]. - t1 < 1000] - whileTrue:[n1 _ n1 * 2]. "Note: #benchmark's runtime is about O(n)" - - n2 _ 28. - [ - t2 _ Time millisecondsToRun: [r _ n2 benchFib]. - t2 < 1000] - whileTrue:[n2 _ n2 + 1]. - "Note: #benchFib's runtime is about O(k^n), - where k is the golden number = (1 + 5 sqrt) / 2 = 1.618...." - - ^ ((n1 * 500000 * 1000) // t1) printStringWithCommas, ' bytecodes/sec; ', - ((r * 1000) // t2) printStringWithCommas, ' sends/sec'! ! -!SystemDictionary methodsFor: 'system attributes' stamp: 'jmv 5/14/2017 23:20:19' prior: 16925038! - isRunningCogit - "Returns true if we're running on the Cog JIT - (vmParameterAt: 46 is the size of the machine code zone) - Smalltalk isRunningCogit - " - - ^(self vmParameterAt: 46) - ifNotNil: [ :machineCodeZoneSize | machineCodeZoneSize > 0 ] - ifNil: [ false ]! ! -!SystemDictionary methodsFor: 'system attributes' stamp: 'jmv 5/14/2017 23:20:40' prior: 16925049! - isSpur - "Answer true if we are a Spur ObjectMemory. - Spur introduces a new format of header for objects, new format for classes, etc. - Smalltalk isSpur - " - - ^ self compactClassesArray isNil! ! -!SystemDictionary class methodsFor: 'copyright' stamp: 'jmv 5/14/2017 23:13:07' prior: 16925610! - copyright - "The Cuis Smalltalk copyright. - Parts are copyright of many contributors to Squeak and Cuis projects." - - ^ -'Portions of Cuis are: -Copyright (c) Xerox Corp. 1981, 1982. -Copyright (c) Apple Computer, Inc. 1985-1996. -Copyright (c) Contributors to Squeak and Cuis projects. 1997-2017.'! ! - -Utilities class removeSelector: #compileUsingClosures! - -Utilities class removeSelector: #compileUsingClosures! - -Utilities class removeSelector: #decommissionTheAllCategory! - -Utilities class removeSelector: #decommissionTheAllCategory! - -Utilities class removeSelector: #initializeClosures! - -Utilities class removeSelector: #initializeClosures! - -SystemVersion class removeSelector: #currentPluginVersion! - -SystemVersion class removeSelector: #currentPluginVersion! - -SystemVersion class removeSelector: #parseVersionString:! - -SystemVersion class removeSelector: #parseVersionString:! - -SystemVersion class removeSelector: #pluginVersion:newerThan:! - -SystemVersion class removeSelector: #pluginVersion:newerThan:! - -SystemDictionary removeSelector: #fixSourceCodeLineEndings! - -SystemDictionary removeSelector: #fixSourceCodeLineEndings! - -SystemDictionary removeSelector: #makeInternalRelease! - -SystemDictionary removeSelector: #makeInternalRelease! - -SystemDictionary removeSelector: #removeTextCode! - -SystemDictionary removeSelector: #removeTextCode! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3084-Cleanup-JuanVuletich-2017May25-20h08m-jmv.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3083] on 25 May 2017 at 8:23:29 pm'! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3085-Cleanup-JuanVuletich-2017May25-20h17m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3085] on 25 May 2017 at 9:56:27 pm'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 5/25/2017 21:56:04' prior: 50334149! - saveAsNewVersion - "Save the image/changes using the next available version number." - " - Smalltalk saveAsNewVersion - " - | fileName newName changesName systemVersion | - self okayToSave ifFalse: [ ^ self ]. - systemVersion _ SystemVersion current. - fileName _ String streamContents: [ :strm | - strm - nextPutAll: 'Cuis'; - print: systemVersion versionMajor; - nextPut: $.; - print: systemVersion versionMinor; - nextPut: $-; - print: systemVersion highestUpdate. - Smalltalk isSpur - ifTrue: [ - Smalltalk wordSize = 4 ifTrue: [ - strm nextPutAll: '-32' ]] - ifFalse: [ - strm nextPutAll: '-v3' ]]. - newName _ fileName, '.image'. - (DirectoryEntry smalltalkImageDirectory // newName) exists ifTrue: [ - newName _ DirectoryEntry smalltalkImageDirectory - nextNameFor: fileName - extension: 'image' ]. - changesName _ self fullNameForChangesNamed: newName. - "Check to see if there is a .changes file that would cause a problem if we saved a new .image file with the new version number" - changesName asFileEntry exists ifTrue: [ - ^ self inform: -'There is already .changes file of the desired name, -', newName, ' -curiously already present, even though there is -no corresponding .image file. Please remedy -manually and then repeat your request.' ]. - "Try to clear all user state, including all class vars, preferences, etc" - self saveAs: newName andQuit: false clearAllClassState: true! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3086-NewImageFlavorNaming-JuanVuletich-2017May25-21h56m-jmv.1.cs.st----! - -----SNAPSHOT----#(25 May 2017 10:00:58.37352 pm) Cuis5.0-3086-32.image priorSource: 355665! - -----QUIT----#(25 May 2017 10:01:10.079622 pm) Cuis5.0-3086-32.image priorSource: 369384! - -----STARTUP----#(14 June 2017 3:47:05.860341 pm) as C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\Cuis5.0-3086-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3086] on 29 May 2017 at 10:56:45 pm'! -!Integer methodsFor: 'benchmarks' stamp: 'jmv 5/29/2017 22:55:50' prior: 50342978! - tinyBenchmarks - "Report the results of running the two tiny Squeak benchmarks. - ar 9/10/1999: Adjusted to run at least 1 sec to get more stable results - 0 tinyBenchmarks - 292 MHz G3 Mac: 22,727,272 bytecodes/sec; 984,169 sends/sec - 400 MHz PII/Win98: 18,028,169 bytecodes/sec; 1,081,272 sends/sec - - RasPi2 - StackVM: 37,758,112 bytecodes/sec; 2,412,667 sends/sec - RasPi2- CogSSpur: 157,441,574 bytecodes/sec; 10,946,039 sends/sec - - C.H.I.P. (*1) - StackVM: 55,315,471 bytecodes/sec; 3,348,667 sends/sec - C.H.I.P. (*1) - CogSpur: 253,716,551 bytecodes/sec; 16,853,816 sends/sec - - RasPi3B - StackSpur 44,107,512 bytecodes/sec; 2,767,863 sends/sec - RasPi3B - CogSpur 281,783,159 bytecodes/sec; 16,404,381 sends/sec - - 1.66GHz Atom N450 - Cog: 244,274,809 bytecodes/sec; 28,795,277 sends/sec - 1.66GHz Atom N450 - CogSpur: 469,724,770 bytecodes/sec; 30,754,699 sends/sec - - 1.33GHz Atom 3735G - Cog: 326,114,649 bytecodes/sec; 34,985,976 sends/sec - 1.33GHz Atom 3735G - CogSpur: 632,098,765 bytecodes/sec; 33,692,910 sends/sec - - 1.5GHz AMD A4-5000 APU - Cog: 390,243,902 bytecodes/sec; 47,507,997 sends/sec - 1.5GHz AMD A4-5000 APU - CogSpur: 675,907,590 bytecodes/sec; 40,669,724 sends/sec - 1.5GHz AMD A4-5000 APU - CogSpur64: 659,368,963 bytecodes/sec; 50,338,916 sends/sec - - 2.3GHz Tegra (*2) - StackVM: 258,847,320 bytecodes/sec; 13,014,759 sends/sec - 2.3GHz Tegra (*2) - CogSpur: 1,083,024,854 bytecodes/sec; 64,289,750 sends/sec - - 3.1GHz Core i3-2100 - Cog: 1,203,290,246 bytecodes/sec; 165,723,327 sends/sec - 3.1GHz Core i3-2100 - CogSpur: 2,042,892,768 bytecodes/sec; 127,837,794 sends/sec - - (*1) C.H.I.P. $9 Computer [Next Thing Co], Allwinner R8 Single-Core ARM Cortex-A8 - 1 GHz - (*2) ACER Chromebook CB5-311 - NVIDIA Tegra K1 Quad-Core ARM Cortex-A15 'r3' - 2.3 GHz - - It is interesting to note that Spur for the first time brings ARM hardware (RasPi and C.H.I.P.) into a 'Morphic is confortable and nice to use' level of performance. - " - | t1 t2 r n1 n2 | - n1 _ 1. - [ - t1 _ Time millisecondsToRun: [n1 benchmark]. - t1 < 1000] - whileTrue:[n1 _ n1 * 2]. "Note: #benchmark's runtime is about O(n)" - - n2 _ 28. - [ - t2 _ Time millisecondsToRun: [r _ n2 benchFib]. - t2 < 1000] - whileTrue:[n2 _ n2 + 1]. - "Note: #benchFib's runtime is about O(k^n), - where k is the golden number = (1 + 5 sqrt) / 2 = 1.618...." - - ^ ((n1 * 500000 * 1000) // t1) printStringWithCommas, ' bytecodes/sec; ', - ((r * 1000) // t2) printStringWithCommas, ' sends/sec'! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3087-RasPi3-tinyBenchmarks-JuanVuletich-2017May29-22h54m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3087] on 30 May 2017 at 2:27:08 pm'! -!Integer methodsFor: 'benchmarks' stamp: 'jmv 5/30/2017 14:24:33' prior: 50343207! - tinyBenchmarks - "Report the results of running the two tiny Squeak benchmarks. - ar 9/10/1999: Adjusted to run at least 1 sec to get more stable results - 0 tinyBenchmarks - 292 MHz G3 Mac: 22,727,272 bytecodes/sec; 984,169 sends/sec - 400 MHz PII/Win98: 18,028,169 bytecodes/sec; 1,081,272 sends/sec - - RasPi2 - StackVM: 37,758,112 bytecodes/sec; 2,412,667 sends/sec - RasPi2- CogSSpur: 157,441,574 bytecodes/sec; 10,946,039 sends/sec - - C.H.I.P. (*1) - StackVM: 55,315,471 bytecodes/sec; 3,348,667 sends/sec - C.H.I.P. (*1) - CogSpur: 253,716,551 bytecodes/sec; 16,853,816 sends/sec - - RasPi3B - StackSpur 44,107,512 bytecodes/sec; 2,767,863 sends/sec - RasPi3B - CogSpur 281,783,159 bytecodes/sec; 16,404,381 sends/sec - - 1.66GHz Atom N450 - Cog: 244,274,809 bytecodes/sec; 28,795,277 sends/sec - 1.66GHz Atom N450 - CogSpur: 469,724,770 bytecodes/sec; 30,754,699 sends/sec - - 1.33GHz Atom 3735G - Cog: 326,114,649 bytecodes/sec; 34,985,976 sends/sec - 1.33GHz Atom 3735G - CogSpur: 632,098,765 bytecodes/sec; 33,692,910 sends/sec - - 1.5GHz AMD A4-5000 APU - Cog: 390,243,902 bytecodes/sec; 47,507,997 sends/sec - 1.5GHz AMD A4-5000 APU - CogSpur: 675,907,590 bytecodes/sec; 40,669,724 sends/sec - 1.5GHz AMD A4-5000 APU - CogSpur64: 659,368,963 bytecodes/sec; 50,338,916 sends/sec - - 2.3GHz Tegra (*2) - StackVM: 258,847,320 bytecodes/sec; 13,014,759 sends/sec - 2.3GHz Tegra (*2) - CogSpur: 1,083,024,854 bytecodes/sec; 64,289,750 sends/sec - - 3.1GHz Core i3-2100 - Cog: 1,203,290,246 bytecodes/sec; 165,723,327 sends/sec - 3.1GHz Core i3-2100 - CogSpur: 2,042,892,768 bytecodes/sec; 127,837,794 sends/sec - - 2.70GHz Core i5-6400 -CogSpur64 3,162,934,362 bytecodes/sec; 243,321,293 sends/sec - - (*1) C.H.I.P. $9 Computer [Next Thing Co], Allwinner R8 Single-Core ARM Cortex-A8 - 1 GHz - (*2) ACER Chromebook CB5-311 - NVIDIA Tegra K1 Quad-Core ARM Cortex-A15 'r3' - 2.3 GHz - - It is interesting to note that Spur for the first time brings ARM hardware (RasPi and C.H.I.P.) into a 'Morphic is confortable and nice to use' level of performance. - " - | t1 t2 r n1 n2 | - n1 _ 1. - [ - t1 _ Time millisecondsToRun: [n1 benchmark]. - t1 < 1000] - whileTrue:[n1 _ n1 * 2]. "Note: #benchmark's runtime is about O(n)" - - n2 _ 28. - [ - t2 _ Time millisecondsToRun: [r _ n2 benchFib]. - t2 < 1000] - whileTrue:[n2 _ n2 + 1]. - "Note: #benchFib's runtime is about O(k^n), - where k is the golden number = (1 + 5 sqrt) / 2 = 1.618...." - - ^ ((n1 * 500000 * 1000) // t1) printStringWithCommas, ' bytecodes/sec; ', - ((r * 1000) // t2) printStringWithCommas, ' sends/sec'! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3088-CoreI5-tinyBenchmarks-JuanVuletich-2017May30-14h24m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3088] on 31 May 2017 at 10:25:43 am'! -!WordArray methodsFor: 'accessing' stamp: 'jmv 5/31/2017 09:48:37'! - bytesAt: index - "Answer a ByteArray of 4 elements. - The 32-bit word is split in 4 bytes, in little endian format - WordArray with: 16rFF32791B :: bytesAt: 1 :: hex - " - - | bytes word | - bytes _ ByteArray new: 4. - word _ self at: index. "Usually a SmallInteger, but may be a Large Integer in 32-bit images" - 1 to: 4 do: [ :i | bytes at: i put: (word digitAt: i) ]. - ^ bytes! ! -!WordArray methodsFor: 'accessing' stamp: 'jmv 5/31/2017 09:53:07'! - bytesAt: index put: aByteArray - "Takes a ByteArray of 4 elements. - Store the 32-bit word made with those byes, in little endian format - WordArray new: 1 :: bytesAt: 1 put: #[16r1B 16r79 16r32 16rFF] :: first hex - " - - | word | - word _ 0. - 4 to: 1 by: -1 do: [ :i | word _ word * 256 + (aByteArray at: i) ]. - self at: index put: word! ! -!Bitmap methodsFor: 'accessing' stamp: 'jmv 5/31/2017 10:16:34'! - bytesAt: index - "Answer a ByteArray of 4 elements. - The 32-bit word is split in 4 bytes, in little endian format - WordArray with: 16rFF32791B :: bytesAt: 1 :: hex - " - - | bytes word | - bytes _ ByteArray new: 4. - word _ self at: index. "Usually a SmallInteger, but may be a Large Integer in 32-bit images" - 1 to: 4 do: [ :i | bytes at: i put: (word digitAt: i) ]. - ^ bytes! ! -!Bitmap methodsFor: 'accessing' stamp: 'jmv 5/31/2017 10:16:38'! - bytesAt: index put: aByteArray - "Takes a ByteArray of 4 elements. - Store the 32-bit word made with those byes, in little endian format - WordArray new: 1 :: bytesAt: 1 put: #[16r1B 16r79 16r32 16rFF] :: first hex - " - - | word | - word _ 0. - 4 to: 1 by: -1 do: [ :i | word _ word * 256 + (aByteArray at: i) ]. - self at: index put: word! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3089-BytesAccessForBitmapAndWordArray-JuanVuletich-2017May31-10h25m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3083] on 28 May 2017 at 8:07:38 pm'! -!TestCase methodsFor: 'Running' stamp: 'HAW 5/28/2017 20:01:43'! - setUpResources - - self resources do: [:res | res isAvailable ifFalse: [^res signalInitializationError]]. -! ! -!TestCase methodsFor: 'Running' stamp: 'HAW 5/28/2017 20:02:07'! - tearDownResources - - self resources do: [:each | each reset]! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 5/28/2017 20:03:22'! - runCaseAsFailure - - self setUpResources. - self setUp. - - self openDebuggerOnFailingTestMethod! ! -!TestSuite methodsFor: 'Running - Private' stamp: 'HAW 5/28/2017 20:04:46'! - setUpResources - - self resources do: [ :res | res isAvailable ifFalse: [^res signalInitializationError]]. - ! ! -!TestSuite methodsFor: 'Running - Private' stamp: 'HAW 5/28/2017 20:05:08'! - tearDownResources - - self resources do: [:each | each reset]! ! -!TestCase methodsFor: 'Running' stamp: 'HAW 5/28/2017 20:01:57' prior: 16927482! - debug - - self setUpResources. - - [(self class selector: testSelector) runCase] ensure: [self tearDownResources] - ! ! -!TestCase methodsFor: 'Running' stamp: 'HAW 5/28/2017 20:06:48' prior: 50340537! - debugAsFailureIfCanNot: handler - - self ifCanNotDebugDo: [ ^handler value]. - - (self class selector: testSelector) runCaseAsFailure! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 5/28/2017 16:11:59' prior: 16927577! - executeShould: aBlock inScopeOf: anExceptonHandlingCondition - - ^self executeShould: aBlock inScopeOf: anExceptonHandlingCondition withExceptionDo: [:anException | ] -! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 5/28/2017 16:12:11' prior: 50339005! - executeShould: aBlock inScopeOf: anExceptonHandlingCondition withExceptionDo: assertionsBlock - - ^[aBlock value. - false] - on: anExceptonHandlingCondition - do: [:exception | - assertionsBlock value: exception. - exception sunitExitWith: true]! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 5/28/2017 20:03:03' prior: 50341193! - openDebuggerOnFailingTestMethod - - | processToDebug context compiledMethod debugger | - - compiledMethod _ self methodForTest. - - processToDebug _ [ [ self performTest ] ensure: [ - self tearDown. - self tearDownResources]] newProcess. - context _ processToDebug suspendedContext. - - debugger _ Debugger new - process: processToDebug - context: context. - debugger openFullNoSuspendLabel: 'Debug failed test ', self printString. - - [debugger interruptedContext method == compiledMethod] whileFalse: [debugger send]. -! ! -!TestSuite methodsFor: 'Running' stamp: 'HAW 5/28/2017 20:04:59' prior: 16928869! - run - - | result | - - result := TestResult new. - self setUpResources. - [self run: result] ensure: [self tearDownResources]. - - ^result - ! ! - -TestCase removeSelector: #openDebuggerOnFailingTestMethod2! - -TestCase removeSelector: #openDebuggerOnFailingTestMethod:! - -TestCase removeSelector: #openDebuggerOnFailingTestMethod:! - -TestCase removeSelector: #runCaseAsFailure:! - -TestCase removeSelector: #runCaseAsFailure:! - -Smalltalk removeClassNamed: #TestCaseDebugger! - -Smalltalk removeClassNamed: #TestCaseDebugger! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3090-SUnitDebugFix-HernanWilkinson-2017May23-19h28m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3083] on 28 May 2017 at 8:55:15 pm'! - -MessageNode removeSelector: #test! - -MessageNode removeSelector: #test! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3091-MessageNode-test-removal-HernanWilkinson-2017May28-20h54m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3083] on 28 May 2017 at 8:56:52 pm'! -!SetInspector methodsFor: 'accessing' stamp: 'HAW 5/28/2017 20:56:40' prior: 16907433! -fieldList - - (object isNil or: [ object array isNil]) ifTrue: [^ Set new]. - - ^ self baseFieldList, (object array withIndexCollect: [:each :i | each ifNotNil: [i printString]]) select: [:each | each notNil]! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3092-SetInspectorFix-HernanWilkinson-2017May28-20h55m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3092] on 2 June 2017 at 11:21:59 am'! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 11:01:27'! - defaultFailDescription - - ^'Test failed'! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 11:02:09'! - fail - - ^self failWith: self defaultFailDescription ! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 11:02:55'! - failWith: aDescription - - self signalFailure: aDescription ! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 10:57:13'! -should: aBlock raise: anExceptonHandlingCondition withExceptionDo: assertionsBlock description: aFailDescription - - ^[aBlock value. - self failWith: aFailDescription ] - on: anExceptonHandlingCondition - do: assertionsBlock ! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 10:58:09' prior: 16927436! - should: aBlock - - self assert: aBlock value - ! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 10:58:16' prior: 16927439! - should: aBlock description: aString - - self assert: aBlock value description: aString - ! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 10:54:56' prior: 16927443! - should: aBlock raise: anExceptonHandlingCondition - - ^self should: aBlock raise: anExceptonHandlingCondition withExceptionDo: [ :anException | ] - ! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 11:00:17' prior: 16927448! - should: aBlock raise: anExceptonHandlingCondition description: aFailDescription - - ^self should: aBlock raise: anExceptonHandlingCondition withExceptionDo: [:anException | ] description: aFailDescription! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 10:57:59' prior: 50338997! -should: aBlock raise: anExceptonHandlingCondition withExceptionDo: assertionsBlock - - ^self should: aBlock raise: anExceptonHandlingCondition withExceptionDo: assertionsBlock description: self defaultFailDescription! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 11:09:25' prior: 16927455! - shouldnt: aBlock - - self deny: aBlock value - ! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 11:09:20' prior: 16927458! - shouldnt: aBlock description: aString - - self deny: aBlock value description: aString - ! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 11:10:31' prior: 16927462! - shouldnt: aBlock raise: anExceptonHandlingCondition - - ^self shouldnt: aBlock raise: anExceptonHandlingCondition description: anExceptonHandlingCondition printString, ' was not expected to be raised'! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 11:06:04' prior: 16927468! - shouldnt: aBlock raise: anExceptonHandlingCondition description: aFailDescription - - ^aBlock - on: anExceptonHandlingCondition - do: [ :anException | self failWith: aFailDescription ] -! ! - -TestCase removeSelector: #executeShould:inScopeOf:! - -TestCase removeSelector: #executeShould:inScopeOf:! - -TestCase removeSelector: #executeShould:inScopeOf:withExceptionDo:! - -TestCase removeSelector: #executeShould:inScopeOf:withExceptionDo:! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3093-TestsDebuggingImprovements-HernanWilkinson-2017Jun02-10h25m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3092] on 2 June 2017 at 4:06:08 pm'! -!Behavior methodsFor: 'user interface' stamp: 'HAW 6/2/2017 16:05:24'! -addTo: aSet referencesTo: aSymbol special: special byte: byte. - - self withAllSuperAndSubclassesDoGently: [ :class | - (class whichSelectorsReferTo: aSymbol special: special byte: byte) - do: [ :sel | aSet add: (MethodReference class: class selector: sel) ]]. - ! ! -!Behavior methodsFor: 'user interface' stamp: 'HAW 6/2/2017 16:05:35' prior: 16784612! - allLocalCallsOn: aSymbol - "Answer a SortedCollection of all the methods that call on aSymbol, anywhere in my class hierarchy." - - | aSet special byte cls | - - aSet _ Set new. - cls _ self theNonMetaClass. - special _ Smalltalk - hasSpecialSelector: aSymbol - ifTrueSetByte: [ :b | byte _ b ]. - - cls addTo: aSet referencesTo: aSymbol special: special byte: byte. - cls class addTo: aSet referencesTo: aSymbol special: special byte: byte. - - ^aSet! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3094-LocalCallsFix-HernanWilkinson-2017Jun02-11h21m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3095] on 7 June 2017 at 10:50:30 am'! -!MessageSetWindow class methodsFor: 'instance creation' stamp: 'jmv 6/7/2017 10:49:13' prior: 16870573! - openMessageList: anArray label: aString - "Create a standard system view for the message set on the list, anArray. - The label of the view is aString." - - ^self open: (MessageSet messageList: anArray) label: aString! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3095-openMessageListlabel-fix-JuanVuletich-2017Jun07-10h47m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3094] on 3 June 2017 at 8:52:25 pm'! - -MessageSetWindow subclass: #TestResultWindow - instanceVariableNames: 'testResult' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Testing'! - -!classDefinition: #TestResultWindow category: #'Tools-Testing'! -MessageSetWindow subclass: #TestResultWindow - instanceVariableNames: 'testResult' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Testing'! -!ProgessiveTestRunner methodsFor: 'show result - private' stamp: 'HAW 6/3/2017 20:40:29'! - openTestResultWindow - - TestResultWindow openFor: testResult - ! ! -!TestCase methodsFor: 'Testing' stamp: 'HAW 6/3/2017 20:26:43'! - isSameAs: aTestCase - - ^self class = aTestCase class and: [ testSelector = aTestCase selector ]! ! -!TestResult methodsFor: 'Accessing' stamp: 'HAW 6/3/2017 20:27:28'! - removeFromDefectsAndAddToPassed: aPassed - - errors - detect: [ :anError | anError isSameAs: aPassed ] - ifFound: [ :anError | errors remove: anError ] - ifNone: [ - failures - detect: [ :aFail | aFail isSameAs: aPassed ] - ifFound: [ :aFail | failures remove: aFail ] - ifNone: [ self error: aPassed printString, ' is not an error nor a failure' ]]. - passed add: aPassed -! ! -!TestResultWindow methodsFor: 'actions' stamp: 'HAW 6/3/2017 20:51:08'! - debug - - model selection ifNotNil: [ :selection | | test | - test := selection actualClass selector: selection selector. - test debug. - testResult removeFromDefectsAndAddToPassed: test. - model removeMessageFromBrowserKeepingLabel. - self setLabel: testResult printString ]! ! -!TestResultWindow methodsFor: 'actions' stamp: 'HAW 6/3/2017 20:51:12'! - runSuite - - | suite | - - suite := TestSuite new. - suite addTests: testResult tests. - self delete. - (ProgessiveTestRunner for: suite) value. - ! ! -!TestResultWindow methodsFor: 'button creation' stamp: 'HAW 6/3/2017 20:51:16'! - createDebugButton - - ^PluggableButtonMorph - model: self - stateGetter: #isMessageSelected - action: #debug - label: 'Debug'. -! ! -!TestResultWindow methodsFor: 'button creation' stamp: 'HAW 6/3/2017 20:51:20'! - createReRunButton - - ^PluggableButtonMorph - model: self - stateGetter: nil - action: #runSuite - label: 'Run Suite'. -! ! -!TestResultWindow methodsFor: 'GUI building' stamp: 'HAW 6/3/2017 20:51:24'! - addButton: button to: row color: buttonColor - - button color: buttonColor. - row addMorph: button proportionalWidth: 10! ! -!TestResultWindow methodsFor: 'GUI building' stamp: 'HAW 6/3/2017 20:51:28'! - addButtonsTo: row color: buttonColor - - self addButton: self createDebugButton to: row color: buttonColor. - self addButton: self createReRunButton to: row color: buttonColor. - ! ! -!TestResultWindow methodsFor: 'GUI building' stamp: 'HAW 6/3/2017 20:51:32'! -buildLowerPanes - - | codeAndButtons | - - codeAndButtons _ LayoutMorph newColumn. - codeAndButtons - addMorph: self buttonsRow fixedHeight: self defaultButtonPaneHeight; - addAdjusterMorph; - addMorph: self buildMorphicCodePane proportionalHeight: 1.0. - - ^codeAndButtons ! ! -!TestResultWindow methodsFor: 'GUI building' stamp: 'HAW 6/3/2017 20:51:36'! - buttonsRow - - | buttonColor row | - - buttonColor := self buttonColor. - row := LayoutMorph newRow. - row doAdoptWidgetsColor. - row color: buttonColor. - - self addButtonsTo: row color: buttonColor. - - ^row - - ! ! -!TestResultWindow methodsFor: 'initialization' stamp: 'HAW 6/3/2017 20:51:40'! - initializeFor: aTestResult - - testResult := aTestResult ! ! -!TestResultWindow methodsFor: 'testing' stamp: 'HAW 6/3/2017 20:51:46'! - isMessageSelected - - ^model selection notNil ! ! -!TestResultWindow class methodsFor: 'instance creation' stamp: 'HAW 6/3/2017 20:50:29'! - methodReferencesOf: tests - - ^tests collect: [:aTest | MethodReference class: aTest class selector: aTest selector]. -! ! -!TestResultWindow class methodsFor: 'instance creation' stamp: 'HAW 6/3/2017 20:50:25'! - openFor: aTestResult - - | window | - - window := self openMessageList: (self methodReferencesOf: aTestResult defects) label: aTestResult printString. - window initializeFor: aTestResult. - - ^window - -! ! -!ProgessiveTestRunner methodsFor: 'show result - private' stamp: 'HAW 6/3/2017 20:40:17' prior: 50338176! - showDeffects - - | defects | - - defects _ testResult defects. - defects size = 1 - ifTrue: [ defects anyOne debug ] - ifFalse: [ self openTestResultWindow]! ! - -TestResult removeSelector: #forDebuggingAndInspection! - -TestResult removeSelector: #forDebuggingAndInspection! - -TestCase removeSelectorIfInBaseSystem: #should:raise:withMessageText:! - -ProgessiveTestRunner removeSelector: #openTestResultForDebuggingAndInspection! - -ProgessiveTestRunner removeSelector: #openTestResultForDebuggingAndInspection! - -Smalltalk removeClassNamed: #TestResultForDebuggingAndInspection! - -Smalltalk removeClassNamed: #TestResultForDebuggingAndInspection! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3096-TestResultWindow-HernanWilkinson-2017May28-21h03m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3094] on 3 June 2017 at 8:55:22 pm'! -!StringMorph methodsFor: 'drawing' stamp: 'HAW 6/3/2017 20:55:08' prior: 16918187! - drawOn: aCanvas - aCanvas - drawString: (contents ifNil: [ '' ]) - at: 0@0 - font: self fontToUse - color: color - ! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3097-StringMorph-fix-HernanWilkinson-2017Jun03-20h52m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3092] on 5 June 2017 at 12:39:46 am'! -!TheWorldMenu methodsFor: 'commands' stamp: 'pb 6/5/2017 00:35:30' prior: 16934691! - splitNewMorphList: list depth: d - | middle c prev next out | - d <= 0 ifTrue: [ ^ Array with: list ]. - middle := list size // 2 + 1. - c := (list at: middle) name first: 3. - prev := middle - 1. - [ - prev > 0 and: [ ((list at: prev) name first: 3) = c ]] whileTrue: [ prev := prev - 1 ]. - next := middle + 1. - [ - next <= list size and: [ ((list at: next) name first: 3) = c ]] whileTrue: [ next := next + 1 ]. - "Choose the better cluster" - middle := middle - prev < (next - middle) - ifTrue: [ prev + 1 ] - ifFalse: [ next ]. - middle = 1 ifTrue: [ middle := next ]. - middle >= list size ifTrue: [ middle := prev + 1 ]. - (middle = 1 or: [ middle >= list size ]) ifTrue: [ ^ Array with: list ]. - out := WriteStream on: Array new. - out nextPutAll: - (self - splitNewMorphList: - (list - copyFrom: 1 - to: middle - 1) - depth: d - 1). - out nextPutAll: - (self - splitNewMorphList: - (list - copyFrom: middle - to: list size) - depth: d - 1). - ^ out contents.! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'pb 6/5/2017 00:38:53' prior: 16934754! - alphabeticalMorphMenu - | list splitLists menu firstChar lastChar subMenu | - list := Morph withAllSubclasses select: [ :m | - m includeInNewMorphMenu ]. - list := list asArray sort: [ :c1 :c2 | - c1 name < c2 name ]. - splitLists := self - splitNewMorphList: list - depth: 4. - menu := MenuMorph new defaultTarget: self. - 1 - to: splitLists size - do: [ :i | - firstChar := i = 1 - ifTrue: [ $A ] - ifFalse: [ - (splitLists at: i) first name first: 3 ]. - lastChar := i = splitLists size - ifTrue: [ $Z ] - ifFalse: [ - (splitLists at: i) last name first: 3 ]. - subMenu := MenuMorph new. - (splitLists at: i) do: [ :cl | - subMenu - add: cl name - target: self - selector: #newMorphOfClass:event: - argument: cl ]. - menu - add: firstChar asString , ' - ' , lastChar asString - subMenu: subMenu ]. - ^ menu.! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3098-MoreGranularAlphaMorphMenu-PhilBellalouna-2017Jun05-00h35m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3086] on 5 June 2017 at 11:53:55 am'! -!CodeProvider methodsFor: 'message list menu' stamp: 'jmv 6/5/2017 11:51:33'! - exploreCompiledMethod - "Open an Explorer on the CompiledMethod itself" - - self selectedMessageName ifNotNil: [ - (self selectedClassOrMetaClass compiledMethodAt: self selectedMessageName) - explore ]! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'jmv 6/5/2017 11:46:27' prior: 50338726! - messageListMenu - "Answer the message-list menu" - "Changed by emm to include menu-item for breakpoints" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addList:#( - ('what to show...' offerWhatToShowMenu) - ('toggle break on entry' toggleBreakOnEntry '' model) - - - ('browse full (b)' browseMethodFull) - ('browse hierarchy (h)' browseHierarchy) - ('browse method (O)' openSingleMessageBrowser) - ('browse protocol (p)' browseFullProtocol) - - - ('fileOut' fileOutMessage '' model) - ('explore CompiledMethod' exploreCompiledMethod '' model) - - - ('senders of... (n)' browseSendersOfMessages) - ('implementors of... (m)' browseMessages) - ('inheritance (i)' methodHierarchy) - ('versions (v)' browseVersions) - - - ('inst var refs...' browseInstVarRefs) - ('inst var defs...' browseInstVarDefs) - ('class var refs...' browseClassVarRefs) - ('class variables' browseClassVariables) - ('class refs (N)' browseClassRefs) - - - ('remove method (x)' removeMessage '' model) - ('Run test (t)' runMethodTest '' model) - ('Debug test (r)' debugMethodTest '' model) - - - ('more...' openShiftedMessageListMenu)). - ^ aMenu -! ! -!Theme methodsFor: 'menus' stamp: 'jmv 6/5/2017 11:46:34' prior: 16935967! - basicIcons - - "Minimal menu scheme. - Theme current class beCurrent - " - - ^ { - #('open...') -> #openIcon. - #('windows...' 'find window' 'Focus follows mouse' 'Click to focus') -> #windowIcon. - #('help...' 'explain' 'about this system...' 'Terse Guide to Cuis' 'Class Comment Browser' 'Code management in Cuis' 'Using GitHub to host Cuis packages' ) -> #helpIcon. - #('themes...') -> #appearanceIcon. - #('do it (d)') -> #doItIcon. - #('new morph...' 'objects (o)' 'save world as morph file') -> #morphsIcon. - #('save' ) -> #saveIcon. - #('Save options...' 'save as...' 'change category...' 'rename change set (r)' 'rename') -> #saveAsIcon. - #('save as new version') -> #saveAsNewVersionIcon. - #('quit') -> #quitIcon. - #('save and quit' ) -> #saveAndQuitIcon. - #('inspect it (i)' 'inspect world' 'inspect model' 'inspect morph' - 'inspect owner chain' 'inspect' 'inspect (i)' 'basic inspect' 'message names' 'find message names' 'inspect instances' 'inspect subinstances' 'inspect change set' 'inspect context (c)' 'inspect receiver (i)' 'start CPUWatcher' 'stop CPUWatcher') - -> #inspectIcon. - #('explore' 'explore it (I)' 'explore world' 'explore morph' 'explore (I)' 'explore context (C)' 'explore receiver (I)' 'references finder' 'weight explorer' 'explore CompiledMethod') -> #exploreIcon. - #('find...(f)' 'find class... (f)' 'find method...' 'find recent submissions' 'show hierarchy' 'show definition' 'show comment' 'filter' 'filter message list...' 'find context... (f)') -> #findIcon. - #('add item...' 'new category...' 'create new change set...' 'new change set... (n)' 'add new file') -> #newIcon. - #('remove method (x)' 'remove' 'remove class (x)' 'remove method from system (x)' 'remove class from system (x)' 'remove postscript') -> #deleteIcon. - #('delete method from changeset (d)' 'delete class from change set (d)' 'destroy change set (X)' 'revert & remove from changes' 'delete unchanged windows' 'delete non windows' 'delete both of the above' 'reset variables' 'remove contained in class categories...' 'clear this change set' 'uninstall this change set' 'delete directory...' 'delete') -> #warningIcon. - #('do again (j)' 'Redo - multiple (Z)') -> #redoIcon. - #('undo (z)' 'revert to previous version' 'Undo - multiple (z)') -> #undoIcon. - #('copy (c)' 'copy class...' 'copy class chgs to other side' 'copy method to other side' 'copy all to other side (c)' 'copy name to clipboard' 'copy selector to clipboard') -> #copyIcon. - #('paste (v)' 'Paste without Format') -> #pasteIcon. - #('cut (x)' 'move class chgs to other side' 'move method to other side' 'submerge into other side') -> #cutIcon. - #('paste...' 'icons...') -> #worldIcon. -}! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - - Theme current class beCurrent! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3099-exploreCompiledMethod-menuOption-JuanVuletich-2017Jun05-11h19m-jmv.1.cs.st----! - -----SNAPSHOT----#(14 June 2017 3:47:16.680341 pm) Cuis5.0-3099-32.image priorSource: 369477! - -----QUIT----#(14 June 2017 3:47:33.592341 pm) Cuis5.0-3099-32.image priorSource: 400453! - -----STARTUP----#(20 June 2017 5:56:19.023457 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3099-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3099] on 9 June 2017 at 12:14:01 am'! -!RectangleLikeMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:47:05'! - categoryInNewMorphMenu - ^ 'Kernel'! ! -!PasteUpMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:51:39'! - categoryInNewMorphMenu - ^ 'Worlds'! ! -!EllipseMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:50:14'! - categoryInNewMorphMenu - ^ 'Basic'! ! -!ProgressBarMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/9/2017 00:05:22'! - categoryInNewMorphMenu - ^ 'Widgets'! ! -!ImageMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:54:09'! - categoryInNewMorphMenu - ^ 'Basic'! ! -!StringMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:55:41'! - categoryInNewMorphMenu - ^ 'Basic'! ! -!UpdatingStringMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/9/2017 00:04:50'! - categoryInNewMorphMenu - ^ 'Widgets'! ! -!LayoutMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:48:35'! - categoryInNewMorphMenu - ^ 'Layouts'! ! -!ProgressMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/9/2017 00:10:17'! - categoryInNewMorphMenu - ^ 'Widgets'! ! -!HaloHandleMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:53:34'! - categoryInNewMorphMenu - ^ 'Halos'! ! -!HaloMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:53:26'! - categoryInNewMorphMenu - ^ 'Halos'! ! -!ResizeMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:56:28'! - categoryInNewMorphMenu - ^ 'Views'! ! -!FillInTheBlankMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:52:51'! - categoryInNewMorphMenu - ^ 'Widgets'! ! -!HoverHelpMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:54:39'! - categoryInNewMorphMenu - ^ 'Widgets'! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'pb 6/9/2017 00:11:33' prior: 50332703! - newMorph - "The user requested 'new morph' from the world menu. Put up a menu that allows many ways of obtaining new morphs. If the preference #classicNewMorphMenu is true, the full form of yore is used; otherwise, a much shortened form is used." - | menu subMenu catDict | - menu _ self menu: 'Add a new morph'. - menu - - add: 'From Clipboard' - target: myHand - action: #pasteMorph; - - add: 'From Alphabetical List' - subMenu: self alphabeticalMorphMenu. - menu addLine. - "Add 'Classic' New Morph menu" - catDict _ Dictionary new. - - Morph allSubclassesDo: [ :eaSubclass | - eaSubclass includeInNewMorphMenu ifTrue: [ | category | - (eaSubclass respondsTo: #categoryInNewMorphMenu) - ifTrue: [ category _ eaSubclass categoryInNewMorphMenu ] - ifFalse: [ category _ 'Unknown' ]. - (catDict includesKey: category) - ifTrue: [ (catDict at: category) add: eaSubclass ] - ifFalse: [ - catDict - at: category - put: (OrderedCollection with: eaSubclass) ]]]. - catDict keys sort do: [ :categ | - subMenu _ MenuMorph new. - ((catDict at: categ) asArray sort: [ :c1 :c2 | - c1 name < c2 name ]) do: [ :cl | - subMenu - add: cl name - target: self - selector: #newMorphOfClass:event: - argument: cl ]. - menu - add: categ - subMenu: subMenu ]. - self doPopUp: menu.! ! - -TheWorldMenu removeSelector: #newMorphOld! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3100-DynamicMorphMenuCategories-PhilBellalouna-2017Jun08-23h33m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3099] on 11 June 2017 at 8:11:06 pm'! -!TestCase class methodsFor: 'Testing' stamp: 'pb 6/11/2017 20:10:43' prior: 16927725! - isAbstract - "Override to true if a TestCase subclass is Abstract and should not have - TestCase instances built from it" - ^ thisContext methodClass == self class.! ! -!TestResource class methodsFor: 'Testing' stamp: 'pb 6/11/2017 20:10:52' prior: 16927869! - isAbstract - "Override to true if a TestResource subclass is Abstract and should not have - TestCase instances built from it" - ^ thisContext methodClass == self class.! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3101-isAbstract-PhilBellalouna-2017Jun11-20h10m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3099] on 9 June 2017 at 1:04:48 am'! -!Preferences class methodsFor: 'halos' stamp: 'pb 6/9/2017 00:46:36' prior: 16893159! -iconicHaloSpecifications - "Answer an array that characterizes the locations, colors, icons, and selectors of the halo handles that may be used in the iconic halo scheme" - - " - Preferences resetHaloSpecifications - " - -^ #( - "selector horiz vert color info icon key balloon help - --------- ------ ----------- ------------------------------- ---------------" - (addCollapseHandle: left topCenter (tan) haloCollapseIcon 'Collapse') - (addDebugHandle: right topCenter (orange) haloDebugIcon 'Debug') - (addDismissHandle: left top (red) haloDismissIcon 'Remove') - "FIXME - Currently non-functional... - (addRotateHandle: left bottom (blue) haloRotateIcon 'Rotate') - " - (addMenuHandle: leftCenter top (blue lighter) haloMenuIcon 'Menu') - (addGrabHandle: center top (black) haloGrabIcon 'Pick up') - (addDragHandle: rightCenter top (brown) haloDragIcon 'Move') - (addDupHandle: right top (green) haloDuplicateIcon 'Duplicate') - (addHelpHandle: center bottom (lightBlue) haloHelpIcon 'Help') - (addGrowHandle: right bottom (yellow) haloScaleIcon 'Change size') - (addFontSizeHandle: leftCenter bottom (lightGreen) haloFontSizeIcon 'Change font') - (addFontEmphHandle: rightCenter bottom (lightBrown darker) haloFontEmphasisIcon 'Emphasis & alignment') - "FIXME - Currently non-functional... - (addRecolorHandle: right bottomCenter (magenta darker) haloColorIcon 'Change color') - " -)! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'pb 6/9/2017 00:52:09' prior: 16875868! - wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph - "Answer whether the receiver would like to offer the halo handle with the given selector (e.g. #addCollapseHandle:)" - - (#(addRotateHandle: addRecolorHandle:) statePointsTo: aSelector) - ifTrue: ["FIXME - hack to disable for non-functional halo items" - ^ false]. - - Preferences selectiveHalos ifFalse: [ - ^true ]. - - (#(#addDismissHandle: ) includes: aSelector) - ifTrue: [ ^ self resistsRemoval not ]. - (#(#addDragHandle: ) includes: aSelector) - ifTrue: [ ^ self okayToBrownDragEasily ]. - (#(#addGrowHandle: ) includes: aSelector) - ifTrue: [ ^ self okayToResizeEasily ]. - (#(#addRotateHandle: ) includes: aSelector) - ifTrue: [ ^ self okayToRotateEasily ]. - (#(#addRecolorHandle: ) includes: aSelector) - ifTrue: [ ^ self wantsRecolorHandle ]. - ^ true! ! -!PasteUpMorph methodsFor: 'halos and balloon help' stamp: 'pb 6/9/2017 00:51:44' prior: 16887852! - wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph - "Answer whether the receiver would like to offer the halo handle with the given selector (e.g. #addCollapseHandle:)" - (#(addHelpHandle: addRotateHandle: addRecolorHandle:) statePointsTo: aSelector) - ifTrue: ["FIXME - hack to disable for non-functional halo items" - ^ false]. - - self isWorldMorph ifFalse: [ - ^super wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph ]. - - ^#(addDebugHandle: addMenuHandle: addHelpHandle:) - statePointsTo: aSelector! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3102-Disable-Nonfunctional-Halos-PhilBellalouna-2017Jun09-00h45m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3099] on 10 June 2017 at 1:39:18 am'! -!Array methodsFor: 'printing' stamp: 'pb 6/10/2017 01:39:04' prior: 16779829! - isLiteral - "Definition from Squeak" - ^ self class == Array and: [ - self allSatisfy: [ :each | - each isLiteral ]].! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3103-Array-isLiteral-compatibility-with-Squeak-PhilBellalouna-2017Jun10-01h39m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3103] on 19 June 2017 at 11:46:49 am'! -!ChangeList methodsFor: 'menu actions' stamp: 'jmv 6/19/2017 11:45:52'! - fileOutCurrentVersionsOfSelections - - (FillInTheBlankMorph - request: 'Enter file name' - initialAnswer: 'Filename.st' - onCancel: [^nil]) - - asFileEntry writeStreamDo: [ :stream | - stream timeStamp. - self currentVersionsOfSelections do: [ :methodRef | - methodRef actualClass - printMethodChunk: methodRef methodSymbol - withPreamble: true - on: stream - moveSource: false - toFile: 0 ]]! ! -!ChangeListWindow methodsFor: 'menu building' stamp: 'jmv 6/19/2017 11:39:03' prior: 16797171! - listMenu - "Fill aMenu up so that it comprises the primary changelist-browser menu" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'change list'. - aMenu addStayUpIcons. - aMenu addList: #( - ('fileIn selections' fileInSelections - 'import the selected items into the image' model) - ('fileOut selections... ' fileOutSelections - 'create a new file containing the selected items' model) - ('fileOut current version of selections...' fileOutCurrentVersionsOfSelections - 'create a new file containing the current (in-image) counterparts of the selected methods' model) - - - ('compare to current' compareToCurrentVersion - 'open a separate window which shows the text differences between the on-file version and the in-image version.' model) - ('toggle diffing (D)' toggleDiffing - 'start or stop showing diffs in the code pane.' model) - - - ('select new methods' selectNewMethods - 'select methods in the file that do not currently exist in the image' model) - ('select changes for absent classes' selectAllForAbsentClasses - 'select methods in the file for classes that are not defined in the image' model) - ('select all changes for this class' selectAllForThisClass - 'select all methods in the file that belong to the currently-selected class' model) - ('select unchanged methods' selectUnchangedMethods - 'select methods in the file whose in-image versions are the same as their in-file counterparts' model) - ('select methods equivalent to current' selectEquivalentMethods - 'select methods in the file whose in-image versions have the same behavior as their in-file counterparts' model) - ('select methods older than current' selectMethodsOlderThanCurrent - 'select methods in the file that are older than the one currently in the image' model) - ('select removals of sent methods' selectRemovalsOfSent - 'select all method removals of methods that have some sender in the image' model) - - - ('select all (a)' selectAll - 'select all the items in the list' model) - ('deselect all' deselectAll - 'deselect all the items in the list' model) - ('invert selections' invertSelections - 'select every item that is not currently selected, and deselect every item that *is* currently selected' model) - - - ('browse class and method' browseMethodFull - 'open a full browser showing the selected method') - ('browse all versions of single selection' browseVersions - 'open a version browser showing the versions of the currently selected method') - ('browse current versions of selections' browseCurrentVersionsOfSelections - 'open a message-list browser showing the current (in-image) counterparts of the selected methods') - ('destroy current methods of selections' destroyCurrentCodeOfSelections - 'remove (*destroy*) the in-image counterparts of all selected methods' model) - - - ('remove doIts' removeDoIts - 'remove all items that are doIts rather than definitions' model) - ('remove older versions' removeOlderMethodVersions - 'remove all but the most recent versions of methods in the list' model) - ('remove up-to-date versions' removeUpToDate - 'remove all items whose code is the same as the counterpart in-image code' model) - ('remove empty class comments' removeEmptyClassComments - 'remove all empty class comments' model) - ('remove selected items' removeSelections - 'remove the selected items from the change-list' model) - ('remove unselected items' removeNonSelections - 'remove all the items not currently selected from the change-list' model)). - ^ aMenu! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3104-fileOutCurrentVersions-JuanVuletich-2017Jun19-11h26m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3103] on 19 June 2017 at 11:07:11 am'! - -FloatArray variableWordSubclass: #Colour - instanceVariableNames: '' - classVariableNames: 'CachedColormaps ColorNamesDict FromGrayColormaps GrayToIndexMap IndexedColors MaskingMap ToGrayColormaps' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -!classDefinition: #Colour category: #'Graphics-Primitives'! -FloatArray variableWordSubclass: #Colour - instanceVariableNames: '' - classVariableNames: 'CachedColormaps ColorNamesDict FromGrayColormaps GrayToIndexMap IndexedColors MaskingMap ToGrayColormaps' - poolDictionaries: '' - category: 'Graphics-Primitives'! -!Colour commentStamp: 'jmv 6/18/2017 20:14:31' prior: 0! - This class represents abstract color, regardless of the depth of bitmap it will be shown in. At the very last moment a Color is converted to a pixelValue that depends on the depth of the actual Bitmap inside the Form it will be used with. The supported depths (in bits) are 1, 2, 4, 8, 16, and 32. The number of actual colors at these depths are: 2, 4, 16, 256, 32768, and 16 million. (See comment in BitBlt.) To change the depth of the Display and set how many colors you can see, execute: (Display newDepth: 8). (See comment in DisplayMedium) - Color is represented as the amount of light in red, green, and blue. White is (1.0, 1.0, 1.0) and black is (0, 0, 0). Pure red is (1.0, 0, 0). These colors are "additive". Think of Color's instance variables as: - r amount of red, a Float between 0.0 and 1.0. - g amount of green, a Float between 0.0 and 1.0. - b amount of blue, a Float between 0.0 and 1.0. - Many colors are named. You find a color by name by sending a message to class Color, for example (Color lightBlue). Also, (Color red: 0.2 green: 0.6 blue: 1.0) or (Color r: 0.2 g: 0.6 b: 1.0) creates a color. (see below) - A color is essentially immutable. Once you set red, green, and blue, you cannot change them. Instead, create a new Color and use it. - Applications such as contour maps and bar graphs will want to display one of a set of shades based on a number. Convert the range of this number to an integer from 1 to N. Then call (Color green lightShades: N) to get an Array of colors from white to green. Use the Array messages at:, atPin:, or atWrap: to pull out the correct color from the array. atPin: gives the first (or last) color if the index is out of range. atWrap: wraps around to the other end if the index is out of range. - Here are some fun things to run in when your screen has color: - Pen new mandala: 30 diameter: Display height-100. - Pen new web "Draw with the mouse, opt-click to end" - Display fillWhite. Pen new hilberts: 5. - Form toothpaste: 30 "Draw with mouse, opt-click to end" - -Messages: - mixed: proportion with: aColor Answer this color mixed with the given color additively. The proportion, a number between 0.0 and 1.0, determines what what fraction of the receiver to use in the mix. - - + add two colors - - subtract two colors - * multiply the values of r, g, b by a number or an Array of factors. ((Color named: #white) * 0.3) gives a darkish gray. (aColor * #(0 0 0.9)) gives a color with slightly less blue. - / divide a color by a factor or an array of three factors. - - hue Returns the hue of the color. On a wheel from 0 to 360 with pure red at 0 and again at 360. - saturation Returns the saturation of the color. 0.0 to 1.0 - brightness Returns the brightness of the color. 0.0 to 1.0 - - name Look to see if this Color has a name. - display Show a swatch of this color tracking the cursor. - - lightShades: thisMany An array of thisMany colors from white to the receiver. - darkShades: thisMany An array of thisMany colors from black to the receiver. Array is of length num. - mix: color2 shades: thisMany An array of thisMany colors from the receiver to color2. - wheel: thisMany An array of thisMany colors around the color wheel starting and ending at the receiver. - - pixelValueForDepth: d Returns the bits that appear be in a Bitmap of this depth for this color. Represents the nearest available color at this depth. Normal users do not need to know which pixelValue is used for which color. - -Messages to Class Color. - red: r green: g blue: b Return a color with the given r, g, and b components. - r: g: b: Same as above, for fast typing. - - hue: h saturation: s brightness: b Create a color with the given hue, saturation, and brightness. - - pink - blue - red ... Many colors have messages that return an instance of Color. - canUnderstand: #brown Returns true if #brown is a defined color. - names An OrderedCollection of the names of the colors. - named: #notAllThatGray put: aColor Add a new color to the list and create an access message and a class variable for it. - fromUser Shows the palette of colors available at this display depth. Click anywhere to return the color you clicked on. - - hotColdShades: thisMany An array of thisMany colors showing temperature from blue to red to white hot. - - stdColorsForDepth: d An Array of colors available at this depth. For 16 bit and 32 bits, returns a ColorGenerator. It responds to at: with a Color for that index, simulating a very big Array. - - colorFromPixelValue: value depth: d Returns a Color whose bit pattern (inside a Bitmap) at this depth is the number specified. Normal users do not need to use this. - -(See also comments in these classes: Form, Bitmap, BitBlt) - -Default colorSpace is #sRGB. Subclasses might use other color spaces! - -Colour variableWordSubclass: #TranslucentColour - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -!classDefinition: #TranslucentColour category: #'Graphics-Primitives'! -Colour variableWordSubclass: #TranslucentColour - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Primitives'! -!TranslucentColour commentStamp: '' prior: 0! - A TranslucentColor behaves just like a normal color, except that it will pack its alpha value into the fourth position. This allows creating forms with translucency for use with the alpha blend function of BitBlt. An alpha of zero is transparent, and 1.0 is opaque.! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:10:00'! - alpha - "Return the opacity ('alpha') value of opaque so that normal colors can be compared to TranslucentColors." - - ^ 1.0 -! ! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:35:34'! - blue - "Return the blue component of this color, a float in the range [0.0..1.0]." - - ^ self at: 3! ! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:33:10'! - brightness - "Return the brightness of this color, a float in the range [0.0..1.0]. - Color red brightness - " - - "Do not include alpha if TranslucentColour" - ^ (self red max: self green) max: self blue! ! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:34:30'! - chroma - "Return the chroma of this color, a value between 0.0 and 1.0, somewhat related to saturation. - See http://en.wikipedia.org/wiki/HSL_and_HSV - Color red chroma - Color gray chroma - " - - | r g b max min | - r _ self red. - g _ self green. - b _ self blue. - max _ (r max: g) max: b. - min _ (r min: g) min: b. - ^max - min! ! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:35:28'! - green - "Return the green component of this color, a float in the range [0.0..1.0]." - - ^ self at: 2! ! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:31:54'! - hue - "Return the hue of this color, an angle in the range [0.0..360.0]. - Color orange hue - " - - | r g b max min span h | - r _ self red. - g _ self green. - b _ self blue. - max _ (r max: g) max: b. - min _ (r min: g) min: b. - span _ (max - min) asFloat. - span = 0.0 ifTrue: [ ^ 0.0 ]. - - r = max ifTrue: [ - h _ ((g - b) asFloat / span) * 60.0. - ] ifFalse: [ - g = max - ifTrue: [ h _ 120.0 + (((b - r) asFloat / span) * 60.0). ] - ifFalse: [ h _ 240.0 + (((r - g) asFloat / span) * 60.0). ]. - ]. - - ^h mod: 360.0! ! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:10:00'! - icon - "Answer a swatch to display in a menu or browser" - ^self swatch! ! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:10:00'! - iconOrThumbnailOfSize: aNumberOrPoint - "Answer an appropiate form to represent the receiver" - | form | - form := Form extent: aNumberOrPoint asPoint asPoint depth: 32. - form fillColor: self. - ^ form! ! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:10:00'! - luminance - "Return the luminance of this color, a brightness value weighted by the human eye's color sensitivity." - - ^ ((299 * self red) + - (587 * self green) + - (114 * self blue)) / 1000! ! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:35:25'! - red - "Return the red component of this color, a float in the range [0.0..1.0]." - - ^ self at: 1! ! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:34:08'! -saturation - "Return the saturation of this color, a value between 0.0 and 1.0. - Color red saturation - Color gray saturation - " - - | r g b max min | - r _ self red. - g _ self green. - b _ self blue. - max _ (r max: g) max: b. - min _ (r min: g) min: b. - max = 0.0 ifTrue: [ ^0.0 ]. - ^max - min / max! ! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:10:00'! - swatch - "Answer a swatch to display in a menu or browser" - ^self iconOrThumbnailOfSize: 16! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:00'! - asNontranslucentColor - ^ self! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:20:07'! - bitPatternForDepth: depth - "Return a Bitmap, that best represents this color at the given depth. BitBlt calls this method to convert colors into Bitmaps." - "See also: pixelValueForDepth: -- value for single pixel - pixelWordForDepth: -- a 32-bit word filled with the pixel value" - - ^ Bitmap with: (self pixelWordForDepth: depth)! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:00'! - bitPatternForGrayForm - "Return a Bitmap, that best represents this color at the given depth. BitBlt calls this method to convert colors into Bitmaps." - "See also: pixelValueForDepth: -- value for single pixel - pixelWordForDepth: -- a 32-bit word filled with the pixel value" - "Details: The pattern for the most recently requested depth is cached." - - ^Bitmap with: (self pixelWordFor: 8 filledWith: (self luminance * 255) rounded)! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:00'! - closestPixelValue1 - "Return the nearest approximation to this color for a monochrome Form." - - "fast special cases" - self isBlack ifTrue: [^ 1]. "black" - self isWhite ifTrue: [^ 0]. "white" - - self luminance > 0.5 - ifTrue: [^ 0] "white" - ifFalse: [^ 1]. "black"! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:00'! - closestPixelValue2 - "Return the nearest approximation to this color for a 2-bit deep Form." - - | lum | - "fast special cases" - self isBlack ifTrue: [^ 1]. "black" - self isWhite ifTrue: [^ 2]. "opaque white" - - lum _ self luminance. - lum < 0.2 ifTrue: [^ 1]. "black" - lum > 0.6 ifTrue: [^ 2]. "opaque white" - ^ 3 "50% gray" -! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:00'! - closestPixelValue4 - "Return the nearest approximation to this color for a 4-bit deep Form." - - | bIndex | - "fast special cases" - self isBlack ifTrue: [^ 1]. "black" - self isWhite ifTrue: [^ 2]. "opaque white" - - self isRed ifTrue: [^ 4]. - self isGreen ifTrue: [^ 5]. - self isBlue ifTrue: [^ 6]. - self isCyan ifTrue: [^ 7]. - self isYellow ifTrue: [^ 8]. - self isMagenta ifTrue: [^ 9]. - - bIndex _ (self luminance * 8.0) rounded. "bIndex in [0..8]" - ^ #( - 1 "black" - 10 "1/8 gray" - 11 "2/8 gray" - 12 "3/8 gray" - 3 "4/8 gray" - 13 "5/8 gray" - 14 "6/8 gray" - 15 "7/8 gray" - 2 "opaque white" - ) at: bIndex + 1. -! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:00'! - closestPixelValue8 - "Return the nearest approximation to this color for an 8-bit deep Form." - - "fast special cases" - self isBlack ifTrue: [^ 1]. "black" - self isWhite ifTrue: [^ 255]. "white" - - ^self saturation < 0.2 - ifTrue: [ - ^ self class grayToIndexMap at:(self green * 255) rounded + 1. "nearest gray" - ] - ifFalse: [ - "compute nearest entry in the color cube" - 40 + - ((self red * 5) rounded * 36) + - ((self blue * 5) rounded * 6) + - (self green * 5) rounded ]! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:00'! - dominantColor - ^ self! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:00'! - indexInMap: aColorMap - "Return the index corresponding to this color in the given color map. RGB colors are truncated to 3-, 4-, or 5-bits per color component when indexing into such a colorMap. " - - aColorMap size = 2 ifTrue: [^ (self pixelValueForDepth: 1) + 1]. - aColorMap size = 4 ifTrue: [^ (self pixelValueForDepth: 2) + 1]. - aColorMap size = 16 ifTrue: [^ (self pixelValueForDepth: 4) + 1]. - aColorMap size = 256 ifTrue: [^ (self pixelValueForDepth: 8) + 1]. - aColorMap size = 512 ifTrue: [^ (self pixelValueForDepth: 9) + 1]. - aColorMap size = 4096 ifTrue: [^ (self pixelValueForDepth: 12) + 1]. - aColorMap size = 32768 ifTrue: [^ (self pixelValueForDepth: 15) + 1]. - self error: 'unknown pixel depth'. -! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:51:40'! - makeForegroundColor - "Make a foreground color contrasting with me" - ^self luminance >= 0.5 - ifTrue: [Colour black] - ifFalse: [Colour white]! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:00'! - pixelValueForDepth: d - "Returns an integer representing the bits that appear in a single pixel of this color in a Form of the given depth. The depth must be one of 1, 2, 4, 8, 16, or 32. Contrast with pixelWordForDepth: and bitPatternForDepth:, which return either a 32-bit word packed with the given pixel value or a multiple-word Bitmap containing a pattern. The inverse is the class message colorFromPixelValue:depth:" - "Details: For depths of 8 or less, the result is a colorMap index. For depths of 16 and 32, it is a direct color value with 5 or 8 bits per color component." - "Transparency: The pixel value zero is reserved for transparent. For depths greater than 8 and less than 32 (no Indexed colors, no real alpha), black maps to the darkest possible blue. - Note that - Color transparent class = TranslucentColor - this special case is handled in TranslucentColor >> #pixelValueForDepth: - " - - | bitBltFakeBlack val | - d = 8 ifTrue: [^ self closestPixelValue8]. "common case" - d < 8 ifTrue: [ - d = 4 ifTrue: [^ self closestPixelValue4]. - d = 2 ifTrue: [^ self closestPixelValue2]. - d = 1 ifTrue: [^ self closestPixelValue1]]. - - d = 32 ifTrue: [ - "eight bits per component; top 8 bits set to all ones (opaque alpha)" - val _ LargePositiveInteger new: 4. - val at: 3 put: (self red * 255) rounded. - val at: 2 put: (self green * 255) rounded. - val at: 1 put: (self blue * 255) rounded. - val at: 4 put: 16rFF. "opaque alpha" - ^ val normalize]. - - "For the depth 16, pixelValue = 0 means transparent, black is represented as 16r8000 (rgb=0, pixelvalue !!= 0)." - (d = 16) | (d = 15) ifTrue: [ - "five bits per component; top bits ignored" - val _ ((self red * 31) rounded bitShift: 10) bitOr: - (((self green * 31) rounded bitShift: 5) bitOr: - ((self blue * 31) rounded)). - ^ val = 0 - ifTrue: [d = 16 ifTrue: [16r8000] ifFalse: [1]] - ifFalse: [val]]. - - "For the rest of the depths, pixelValue = 0 means transparent, and darkest blue is considered to be black." - bitBltFakeBlack := 1. "closest black that is not transparent in RGB - Not for depths <=8 (Indexed) or = 32 (RGBA)" - d = 12 ifTrue: [ "for indexing a color map with 4 bits per color component" - val _ ((self red * 15) rounded bitShift: 8) bitOr: - (((self green * 15) rounded bitShift: 4) bitOr: - ((self blue * 15) rounded)). - ^ val = 0 ifTrue: [bitBltFakeBlack] ifFalse: [val]]. - - d = 9 ifTrue: [ "for indexing a color map with 3 bits per color component" - val _ ((self red * 7) rounded bitShift: 6) bitOr: - (((self green * 7) rounded bitShift: 3) bitOr: - ((self blue * 7) rounded)). - ^ val = 0 ifTrue: [bitBltFakeBlack] ifFalse: [val]]. - - self error: 'unknown pixel depth: ', d printString! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:00'! - pixelWordFor: depth filledWith: pixelValue - "Return to a 32-bit word that concatenates enough copies of the given pixel value to fill the word (i.e., 32/depth copies). Depth should be one of 1, 2, 4, 8, 16, or 32. The pixel value should be an integer in 0..2^depth-1." - | halfword | - depth = 32 ifTrue: [^ pixelValue]. - depth = 16 - ifTrue: [halfword _ pixelValue] - ifFalse: [halfword _ pixelValue * - (#(16rFFFF "replicates at every bit" - 16r5555 - "replicates every 2 bits" - 16r1111 - - - "replicates every 4 bits" - 16r0101) at: depth) "replicates every 8 bits"]. - ^ halfword bitOr: (halfword bitShift: 16)! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:00'! - pixelWordForDepth: depth - "Return to a 32-bit word that concatenates enough copies of the receiver's pixel value to fill the word (i.e., 32/depth copies). Depth should be one of 1, 2, 4, 8, 16, or 32. The pixel value should be an integer in 0..2^depth-1." - - | pixelValue | - pixelValue _ self pixelValueForDepth: depth. - ^ self pixelWordFor: depth filledWith: pixelValue -! ! -!Colour methodsFor: 'equality' stamp: 'jmv 6/18/2017 20:38:11'! - diff: theOther - "Returns a number between 0.0 and 1.0. - Color gray diff: Color red - " - ^(self - theOther ) abs sum / self size! ! -!Colour methodsFor: 'equality' stamp: 'jmv 6/18/2017 20:10:00'! - rgbDistance: otherColor - "Compare two colors in distance" -" - ^ (self hue - otherColor hue) abs + - (self saturation - otherColor saturation) abs *10 + - (self brightness - otherColor brightness) abs -" - "See http://www.compuphase.com/cmetric.htm" - | meanRed deltaRed deltaGreen deltaBlue | - meanRed := (self red + otherColor red) abs / 2. - deltaRed := (self red - otherColor red) abs. - deltaGreen := (self green - otherColor green) abs. - deltaBlue := (self blue - otherColor blue) abs. - - ^ ( ((2 + (meanRed / 256)) * (deltaRed * deltaRed)) + - (4 * deltaGreen) + - ((2 + ((255 - meanRed) / 256)) * deltaBlue) - ) sqrt! ! -!Colour methodsFor: 'groups of shades' stamp: 'jmv 6/18/2017 20:10:00'! - darkShades: thisMany - "An array of thisMany colors from black to the receiver. Array is of length num. Very useful for displaying color based on a variable in your program. " - "Color showColors: (Color red darkShades: 12)" - - ^ self class black mix: self shades: thisMany -! ! -!Colour methodsFor: 'groups of shades' stamp: 'jmv 6/18/2017 20:10:00'! - lightShades: thisMany - "An array of thisMany colors from white to self. Very useful for displaying color based on a variable in your program. " - "Color showColors: (Color red lightShades: 12)" - - ^ self class white mix: self shades: thisMany -! ! -!Colour methodsFor: 'groups of shades' stamp: 'jmv 6/18/2017 20:51:45'! - mix: color2 shades: thisMany - "Return an array of thisMany colors from self to color2. Very useful for displaying color based on a variable in your program. " - "Color showColors: (Color red mix: Color green shades: 12)" - - | redInc greenInc blueInc rr gg bb c out | - thisMany = 1 ifTrue: [^ Array with: color2]. - redInc _ color2 red - self red / (thisMany-1). - greenInc _ color2 green - self green / (thisMany-1). - blueInc _ color2 blue - self blue / (thisMany-1). - rr _ self red. gg _ self green. bb _ self blue. - out _ (1 to: thisMany) collect: [:num | - c _ Colour r: rr g: gg b: bb. - rr _ rr + redInc. - gg _ gg + greenInc. - bb _ bb + blueInc. - c]. - out at: out size put: color2. "hide roundoff errors" - ^ out -! ! -!Colour methodsFor: 'groups of shades' stamp: 'jmv 6/18/2017 20:52:45'! - wheel: thisMany - "An array of thisMany colors around the color wheel starting at self and ending all the way around the hue space just before self. Array is of length thisMany. Very useful for displaying color based on a variable in your program. " - - | sat bri hue step c | - sat _ self saturation. - bri _ self brightness. - hue _ self hue. - step _ 360.0 / (thisMany max: 1). - ^ (1 to: thisMany) collect: [:num | - c _ Colour h: hue s: sat v: bri. "hue is taken mod 360" - hue _ hue + step. - c]. -" -(Colour wheel: 8) withIndexDo: [:c :i | Display fill: (i*10@20 extent: 10@20) fillColor: c] -"! ! -!Colour methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:00'! - closestAssocFrom: aColorDict - "Answer closest associated color in aColorDict" -" - ((Color r: 0.3 g: 0.2 b: 0.8) closestAssocFrom: (Color colorNamesDict)) explore. -" - "Filter values for those close in hue (cheap test) then use rgbDistance" - | closeInHue isClose close distance myHue | - closeInHue := OrderedCollection new. - myHue := self hue. - isClose := [ :assoc | | delta | - delta := ((assoc value hue) - myHue) abs. - (delta < 20) or: [ delta > 340 ] "hues within 20 degrees" - ]. - aColorDict associationsDo: [ :assoc | - (isClose value: assoc) ifTrue: [ closeInHue add: assoc ] - ]. - - close := nil. - distance := 1000. "big" - (closeInHue size > 0) - ifFalse: [ "fallback -- no color really close" - aColorDict associationsDo: [ :assoc | | dist | - dist := self rgbDistance: (assoc value). - (dist < distance) ifTrue: [distance := dist. close := assoc] - ] - ] - ifTrue: [ closeInHue do: [ :assoc | | dist | - dist := self rgbDistance: (assoc value). - (dist < distance) ifTrue: [distance := dist. close := assoc] - ] - ]. - - ^ close! ! -!Colour methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:51:07'! - closestColor - "Answer the closest matching color in the colorNames dictionary" - -" - (Color red lighter lighter) closestColor explore. -" - ^ self closestColorFrom: (Colour colorNamesDict)! ! -!Colour methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:51:11'! -closestColorAssociation - "Answer this color's closest name->color match." - -" - (Color blue lighter lighter) closestColorAssociation explore. -" - ^ self closestAssocFrom: (Colour colorNamesDict)! ! -!Colour methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:00'! - closestColorFrom: aColorDict - "Answer closest associated color" -" - ((Color lightBlue) closestColorFrom: (Color css2NamedColors)) explore.. -" - ^(self closestAssocFrom: aColorDict) value! ! -!Colour methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:51:15'! -closestColorName - "Answer the name symbol of the closest matching color in the colorNames dictionary" -" - (Color red lighter lighter) closestColor name. -" - - ^ self closestNameFrom: (Colour colorNamesDict)! ! -!Colour methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:00'! - closestNameFrom: aColorDict - "Answer closest associated color name" -" - ((Color lightBlue) closestNameFrom: (Color namedColors)) print. -" - ^(self closestAssocFrom: aColorDict) key! ! -!Colour methodsFor: 'other' stamp: 'jmv 6/18/2017 20:51:20'! - colorName - "Return this color's name, or nil if it has no name. Only returns a name if it exactly matches the named color." - - ^(Colour colorNamesDict keyAtValue: self ifAbsent: [nil]) -! ! -!Colour methodsFor: 'other' stamp: 'jmv 6/18/2017 20:10:00'! - name - "Return this color's name, or description if unnamed." - - ^ self printString -! ! -!Colour methodsFor: 'printing' stamp: 'jmv 6/18/2017 20:10:00'! - hexStringRGB - " - Color fromUser hexStringRGB - " - ^String streamContents: [ :strm | - (self red * 255) rounded printOn: strm base: 16 length: 2 padded: true. - (self green * 255) rounded printOn: strm base: 16 length: 2 padded: true. - (self blue * 255) rounded printOn: strm base: 16 length: 2 padded: true ]! ! -!Colour methodsFor: 'printing' stamp: 'jmv 6/18/2017 20:53:07'! - printOn: aStream - self colorName ifNotNil: [ :name | - ^ aStream - nextPutAll: 'Colour '; - nextPutAll: name]. - self storeOn: aStream. -! ! -!Colour methodsFor: 'printing' stamp: 'jmv 6/18/2017 20:10:00'! - printString - "Answer a String whose characters are a description of the receiver." - - ^ String streamContents: [ :stream | self printOn: stream ]! ! -!Colour methodsFor: 'printing' stamp: 'jmv 6/18/2017 20:10:00'! - storeArrayOn: aStream - - aStream nextPutAll: '#('. - self storeArrayValuesOn: aStream. - aStream nextPutAll: ') ' -! ! -!Colour methodsFor: 'printing' stamp: 'jmv 6/18/2017 20:10:00'! - storeArrayValuesOn: aStream - - - self red printOn: aStream fractionDigits: 3. - aStream space. - self green printOn: aStream fractionDigits: 3. - aStream space. - self blue printOn: aStream fractionDigits: 3 - -! ! -!Colour methodsFor: 'printing' stamp: 'jmv 6/18/2017 20:10:00'! - storeOn: aStream - - aStream - nextPut: $(; - nextPutAll: self class name; - nextPutAll: ' r: '. - self red printOn: aStream fractionDigits: 3. - aStream nextPutAll: ' g: '. - self green printOn: aStream fractionDigits: 3. - aStream nextPutAll: ' b: '. - self blue printOn: aStream fractionDigits: 3. - aStream nextPut: $)! ! -!Colour methodsFor: 'queries' stamp: 'jmv 6/18/2017 20:40:55'! - isBlack - "Return true if the receiver represents black" - (self at: 1) = 0.0 ifFalse: [ ^ false ]. - (self at: 2) = 0.0 ifFalse: [ ^ false ]. - (self at: 3) = 0.0 ifFalse: [ ^ false ]. - ^ true! ! -!Colour methodsFor: 'queries' stamp: 'jmv 6/18/2017 20:10:00'! -isOpaque - ^true! ! -!Colour methodsFor: 'queries' stamp: 'jmv 6/18/2017 20:10:00'! - isTransparent - - ^ false -! ! -!Colour methodsFor: 'queries' stamp: 'jmv 6/18/2017 20:40:46'! - isWhite - "Return true if the receiver represents white" - (self at: 1) = 1.0 ifFalse: [ ^ false ]. - (self at: 2) = 1.0 ifFalse: [ ^ false ]. - (self at: 3) = 1.0 ifFalse: [ ^ false ]. - ^ true! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isBlue - "Am I considered Blue?" - - ^self blue > (self green + 0.3) - and: [self blue > (self red + 0.3)] - and: [(self green - self red) abs < 0.4]! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isBlueGreen - "Am I considered BlueGreen ?" - - ^self green > self red - and: [self red < 0.3] - and: [(self green - self blue) abs < 0.1]! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isBright - "Am I considered a Bright color ?" - - ^self brightness > 0.6! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isBrown - "Am I considered Brown ?" - - ^self red >= self green - and: [self green > self blue] - and: [(self red - self green) < 0.5] - and: [(self green - self blue) < 0.3]! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isCyan - "Am I considered Cyan ?" - - ^self red < 0.05 - and: [(self green min: self blue) > 0.5] - and: [(self green - self blue) abs < 0.2]! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isDark - "Am I considered a Dark color ?" - - ^self brightness < 0.5! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isGray - "Am I considered Gray ?" - - ^(self red closeTo: self green) - and: [self blue closeTo: self green ]! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isGreen - "Am I considered Green ?" - - ^self green > (self blue + 0.3) - and: [self blue > (self red + 0.3)]! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isGrey - "Am I considered Grey ?" - - ^self isGray! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isLight - "Am I considered a Light color ?" - - ^self brightness > 0.6! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isMagenta - "Am I considered Magenta ?" - - ^self green < 0.05 - and: [(self red min: self blue) > 0.5] - and: [(self red - self blue) abs < 0.2]! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isOrange - "Am I considered Orange ?" - - ^self red > ((self green max: self blue) + 0.2) - and: [self green > (self blue + 0.2)]! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isPastel - "Am I considered Pastel ?" - - ^self saturation < 0.4! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isPink - "Am I considered Pink ?" - - ^self red > ((self green max: self blue) + 0.3) - and: [self blue > (self green + 0.2)]! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isRed - "Am I considered Red ?" - - ^self red > (self green + 0.4) - and: [self red > (self blue + 0.6)] - and: [(self green - self blue) abs < 0.4]! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isSaturated - "Am I considered to be a Saturated color ?" - - ^self saturation > 0.6! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isYellow - "Am I considered Yellow ?" - - ^self blue < 0.05 - and: [(self red min: self green) > 0.5] - and: [(self red - self green) abs < 0.2]! ! -!Colour methodsFor: 'testing' stamp: 'jmv 6/18/2017 20:10:00'! - is: aSymbol - ^ aSymbol == #Color or: [ super is: aSymbol ]! ! -!Colour methodsFor: 'testing' stamp: 'jmv 6/18/2017 20:10:00'! - mightBeTranslucent - "For Colors, answer if actually translucent or not." - ^self isOpaque not! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:56:14'! - * aNumber - "Answer this color with its RGB multiplied by the given number. " - " - (Colour brown *2) display - " - ^ Colour new - setRed: (self red * aNumber min: 1.0 max: 0.0) - green: (self green * aNumber min: 1.0 max: 0.0) - blue: (self blue * aNumber min: 1.0 max: 0.0)! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:56:18'! - + aColor - "Answer this color mixed with the given color in an additive color space. " - " - (Colour blue + Colour green) display - " - ^ Colour new - setRed: (self red + aColor red min: 1.0 max: 0.0) - green: (self green + aColor green min: 1.0 max: 0.0) - blue: (self blue + aColor blue min: 1.0 max: 0.0)! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:56:22'! - - aColor - "Answer aColor is subtracted from the given color in an additive color space. " - " - (Color white - Color red) display - " - ^ Colour new - setRed: (self red - aColor red min: 1.0 max: 0.0) - green: (self green - aColor green min: 1.0 max: 0.0) - blue: (self blue - aColor blue min: 1.0 max: 0.0)! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:56:26'! - / aNumber - "Answer this color with its RGB divided by the given number. " - " - (Color red / 2) display - " - ^ Colour new - setRed: (self red / aNumber min: 1.0 max: 0.0) - green: (self green / aNumber min: 1.0 max: 0.0) - blue: (self blue / aNumber min: 1.0 max: 0.0)! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:50:50'! - adjustBrightness: brightness - "Adjust the relative brightness of this color. (lowest value is 0.005 so that hue information is not lost)" - - ^ Colour - h: self hue - s: self saturation - v: (self brightness + brightness min: 1.0 max: 0.005) - alpha: self alpha! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:50:53'! - adjustSaturation: saturation brightness: brightness - "Adjust the relative saturation and brightness of this color. (lowest value is 0.005 so that hue information is not lost)" - - ^ Colour - h: self hue - s: (self saturation + saturation min: 1.0 max: 0.005) - v: (self brightness + brightness min: 1.0 max: 0.005) - alpha: self alpha! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:10:41'! - alpha: alphaValue - "Return a new TranslucentColor with the given amount of opacity ('alpha')." - alphaValue = 1.0 ifFalse: [ - ^ TranslucentColour new - setRed: self red - green: self green - blue: self blue - alpha: alphaValue ]! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:50:57'! - alphaMixed: proportion with: aColor - "Answer this color mixed with the given color. The proportion, a number - between 0.0 and 1.0, determines what what fraction of the receiver to - use in the mix. For example, 0.9 would yield a color close to the - receiver. This method uses RGB interpolation; HSV interpolation can lead - to surprises. Mixes the alphas (for transparency) also." - - | frac1 frac2 | - frac1 _ proportion asFloat min: 1.0 max: 0.0. - frac2 _ 1.0 - frac1. - ^ Colour - r: self red * frac1 + (aColor red * frac2) - g: self green * frac1 + (aColor green * frac2) - b: self blue * frac1 + (aColor blue * frac2) - alpha: self alpha * frac1 + (aColor alpha * frac2)! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:10:00'! - atLeastAsLuminentAs: aFloat - - | revisedColor | - revisedColor _ self. - [revisedColor luminance < aFloat] whileTrue: [revisedColor _ revisedColor slightlyLighter]. - ^revisedColor -! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:10:00'! - atMostAsLuminentAs: aFloat - - | revisedColor | - revisedColor _ self. - [revisedColor luminance > aFloat] whileTrue: [revisedColor _ revisedColor slightlyDarker]. - ^revisedColor -! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:51:02'! - blacker - - ^ self alphaMixed: 0.8333 with: Colour black -! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:51:27'! - dansDarker - "Return a darker shade of the same color. - An attempt to do better than the current darker method. - (now obsolete, since darker has been changed to do this. -dew)" - ^ Colour h: self hue s: self saturation - v: (self brightness - 0.16 max: 0.0)! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:10:00'! - darker - "Answer a darker shade of this color." - - ^ self adjustBrightness: -0.08! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:10:00'! - duller - - ^ self adjustSaturation: -0.03 brightness: -0.2! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:10:00'! - lighter - "Answer a lighter shade of this color." - - ^ self adjustSaturation: -0.03 brightness: 0.08! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:51:59'! - mixed: proportion with: aColor - "Mix with another color and do not preserve transpareny. Only use this for extracting the RGB value and mixing it. All other callers should use instead: - aColor alphaMixed: proportion with: anotherColor - " - - | frac1 frac2 | - frac1 _ proportion asFloat min: 1.0 max: 0.0. - frac2 _ 1.0 - frac1. - ^ Colour - r: self red * frac1 + (aColor red * frac2) - g: self green * frac1 + (aColor green * frac2) - b: self blue * frac1 + (aColor blue * frac2)! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:52:03'! - muchDarker - - ^ self alphaMixed: 0.5 with: Colour black -! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:52:07'! - muchLighter - - ^ self alphaMixed: 0.233 with: Colour white -! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:52:12'! - negated - "Return an RGB inverted color" - ^Colour - r: 1.0 - self red - g: 1.0 - self green - b: 1.0 - self blue! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:37:53'! - orColorUnlike: theOther - "If this color is a lot like theOther, then return its complement, otherwide, return self" - - ^ (self diff: theOther) < 0.3 - ifTrue: [theOther negated] - ifFalse: [self]! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:10:00'! - paler - "Answer a paler shade of this color." - - ^ self adjustSaturation: -0.09 brightness: 0.09 -! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:52:16'! - quiteBlacker - - ^ self alphaMixed: 0.8 with: Colour black -! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:52:19'! - quiteWhiter - - ^ self alphaMixed: 0.6 with: Colour white! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:10:00'! - slightlyDarker - - ^ self adjustBrightness: -0.03 -! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:10:00'! - slightlyLighter - - ^ self adjustSaturation: -0.01 brightness: 0.03! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:52:24'! - slightlyWhiter - - ^ self alphaMixed: 0.85 with: Colour white -! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:10:00'! - twiceDarker - "Answer a significantly darker shade of this color." - - ^ self adjustSaturation: 0.076 brightness: -0.15! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:10:01'! - twiceLighter - "Answer a significantly lighter shade of this color." - - ^ self adjustSaturation: -0.06 brightness: 0.15! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:52:27'! -veryMuchDarker - - ^ self alphaMixed: 0.25 with: Colour black -! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:52:32'! - veryMuchLighter - - ^ self alphaMixed: 0.07 with: Colour white! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:02:05'! - whiter - - ^ self alphaMixed: 0.8333 with: Colour white -! ! -!Colour methodsFor: 'private' stamp: 'jmv 6/18/2017 20:10:01'! - attemptToMutateError - "A color is immutable. Once a color's red, green, and blue have been initialized, you cannot change them. Instead, create a new Color and use it." - - self error: 'Color objects are immutable once created' -! ! -!Colour methodsFor: 'private' stamp: 'jmv 6/18/2017 20:29:32'! - basicSetRed: r green: g blue: b - "Initialize this color's r, g, and b components to the given values in the range [0.0..1.0]." - - self - at: 1 put: r; - at: 2 put: g; - at: 3 put: b! ! -!Colour methodsFor: 'private' stamp: 'jmv 6/18/2017 20:15:44'! - setHue: hue chroma: chroma brightness: brightness - "Initialize this color to the given hue, chroma, and luma. See the comment in the instance creation method for details. - http://en.wikipedia.org/wiki/HSL_and_HSV - hue belongs in [0.0, 360.0) - chroma and luma belongs in [0.0, 1.0] - " - - | x hf i r1 g1 b1 m | - hf _ hue \\ 360. - i _ hf // 60. "integer part of hue" - x _ (hf \\ 60) / 60.0 . "fractional part of hue" - x _ x \\ 2 . - i \\ 2 = 1 ifTrue: [ x _ 1.0 - x ]. - x _ chroma * x. - - 0 = i ifTrue: [ r1 _ chroma. g1 _ x. b1 _ 0.0 ]. - 1 = i ifTrue: [ r1 _ x. g1 _ chroma. b1 _ 0.0 ]. - 2 = i ifTrue: [ r1 _ 0.0. g1 _ chroma. b1 _ x ]. - 3 = i ifTrue: [ r1 _ 0.0. g1 _ x. b1 _ chroma ]. - 4 = i ifTrue: [ r1 _ x. g1 _ 0.0. b1 _ chroma ]. - 5 = i ifTrue: [ r1 _ chroma. g1 _ 0.0. b1 _ x ]. - - m _ brightness - ((r1 max: g1) max: b1). - m < 0.0 - ifTrue: [ ^nil ]. "No color exists with required parameters" - r1 _ r1 + m. - r1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - g1 _ g1 + m. - g1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - b1 _ b1 + m. - b1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - self setRed: r1 green: g1 blue: b1! ! -!Colour methodsFor: 'private' stamp: 'jmv 6/18/2017 20:15:49'! - setHue: hue chroma: chroma luminance: luma - "Initialize this color to the given hue, chroma, and luma. See the comment in the instance creation method for details. - http://en.wikipedia.org/wiki/HSL_and_HSV - hue belongs in [0.0, 360.0) - chroma and luma belongs in [0.0, 1.0] - " - - | x hf i r1 g1 b1 m | - - hf _ hue \\ 360. - i _ hf // 60. "integer part of hue" - x _ (hf \\ 60) / 60.0 . "fractional part of hue" - x _ x \\ 2 . - i \\ 2 = 1 ifTrue: [ x _ 1.0 - x ]. - x _ chroma * x. - - 0 = i ifTrue: [ r1 _ chroma. g1 _ x. b1 _ 0.0 ]. - 1 = i ifTrue: [ r1 _ x. g1 _ chroma. b1 _ 0.0 ]. - 2 = i ifTrue: [ r1 _ 0.0. g1 _ chroma. b1 _ x ]. - 3 = i ifTrue: [ r1 _ 0.0. g1 _ x. b1 _ chroma ]. - 4 = i ifTrue: [ r1 _ x. g1 _ 0.0. b1 _ chroma ]. - 5 = i ifTrue: [ r1 _ chroma. g1 _ 0.0. b1 _ x ]. - - m _ luma - (0.299*r1) - (0.587*g1) - (0.114*b1). - m < 0.0 - ifTrue: [ ^nil ]. "No color exists with required parameters" - r1 _ r1 + m. - r1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - g1 _ g1 + m. - g1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - b1 _ b1 + m. - b1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - self setRed: r1 green: g1 blue: b1! ! -!Colour methodsFor: 'private' stamp: 'jmv 6/18/2017 20:16:07'! - setHue: hue saturation: saturation brightness: brightness - "Initialize this color to the given hue, saturation, and brightness. See the comment in the instance creation method for details." - - | s v hf i f p q t | - s _ saturation asFloat min: 1.0 max: 0.0. - v _ brightness asFloat min: 1.0 max: 0.0. - hf _ hue \\ 360. - i _ hf // 60. "integer part of hue" - f _ (hf \\ 60) / 60.0. "fractional part of hue" - - p _ (1.0 - s) * v. - q _ (1.0 - (s * f)) * v. - t _ (1.0 - (s * (1.0 - f))) * v. - - 0 = i ifTrue: [ ^ self setRed: v green: t blue: p ]. - 1 = i ifTrue: [ ^ self setRed: q green: v blue: p ]. - 2 = i ifTrue: [ ^ self setRed: p green: v blue: t ]. - 3 = i ifTrue: [ ^ self setRed: p green: q blue: v ]. - 4 = i ifTrue: [ ^ self setRed: t green: p blue: v ]. - 5 = i ifTrue: [ ^ self setRed: v green: p blue: q ]. - - self error: 'implementation error'! ! -!Colour methodsFor: 'private' stamp: 'jmv 6/18/2017 20:13:04'! - setRed: r green: g blue: b - - self basicSetRed: r green: g blue: b! ! -!Colour methodsFor: 'private' stamp: 'jmv 6/18/2017 20:29:48'! - setRed: r green: g blue: b range: range - "Initialize this color's r, g, and b components to the given values in the range [0..r]." - - self basicSetRed: r green: g blue: b. - self /= range! ! -!Colour methodsFor: 'as yet unclassified' stamp: 'jmv 6/18/2017 20:10:01'! - color - ^ self! ! -!Colour methodsFor: 'please remove' stamp: 'jmv 6/18/2017 21:26:21'! - floatRGB -"to be removed" - ^ self! ! -!Colour methodsFor: 'please remove' stamp: 'jmv 6/18/2017 21:26:07'! - setRed: r green: g blue: b colorSpace: aSymbol - ^ self setRed: r green: g blue: b! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:10:01'! - clipR: r g: g b: b - "Return a color with the given r, g, and b components in the range [0.0..1.0]. - Clip if necessary" - - ^ self - r: (r min: 1.0 max: 0.0) - g: (g min: 1.0 max: 0.0) - b: (b min: 1.0 max: 0.0)! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:10:01'! - colorFrom: parm - "Return an instantiated color from parm. If parm is already a color, return it, else return the result of my performing it if it's a symbol or, if it is a list, it can either be an array of three numbers, which will be interpreted as RGB values, or a list of symbols, the first of which is sent to me and then the others of which are in turn sent to the prior result, thus allowing entries of the form #(blue darker). Else just return the thing" - - | aColor firstParm | - (parm is: #Color) ifTrue: [ ^ parm ]. - parm isSymbol ifTrue: [ ^ self perform: parm ]. - (parm isSequenceableCollection and: [ parm size > 0 ]) - ifTrue: [ - firstParm _ parm first. - firstParm isNumber ifTrue: [ - ^ self fromRgbTriplet: parm]. - aColor _ self colorFrom: firstParm. - parm withIndexDo: [ :sym :ind | - ind > 1 ifTrue: [ - aColor _ aColor perform: sym ]]. - ^ aColor]. - ^ parm - -" -Color colorFrom: #(blue darker) -Color colorFrom: Color blue darker -Color colorFrom: #blue -Color colorFrom: #(0.0 0.0 1.0) -"! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 21:02:20'! - colorFromPixelValue: p depth: d - "Convert a pixel value for the given display depth into a color." - "Details: For depths of 8 or less, the pixel value is simply looked up in a table. For greater depths, the color components are extracted and converted into a color." - "Warning: In BitBlt, a pixel with pixelValue = 0 is transparent. - Squeak usually assumes that r=g=b=0 => transparent. But this is false if we have alpha (opacity). - A color with r=g=b=0 and opacity = 255 is BLACK, not TRANSPARENT. - Squeak also answers darkest possible blue when asked for black. Again, this is not needed in 32 bits (with alpha). It is also not really needed for 16 bits as we have an extra, unused bit: 16r8000 is not zero, but rgb=0, and hence, black. - The real rule is that pixelValue=0 means transparent. - And that darkest blue must be used instead of black, but only for depths >8 and < 16 (no indexed colors, no alpha) - This method is updated to reflect that." - - | r g b alpha | - - d = 1 ifTrue: [^ self indexedColors at: (p bitAnd: 16r01) + 1]. - - "For the rest of the depths, pixelValue = 0 means transparent, and darkest blue is considered to be black." - p = 0 ifTrue: [ ^Colour transparent ]. - - d = 8 ifTrue: [^ self indexedColors at: (p bitAnd: 16rFF) + 1]. - d = 4 ifTrue: [^ self indexedColors at: (p bitAnd: 16r0F) + 1]. - d = 2 ifTrue: [^ self indexedColors at: (p bitAnd: 16r03) + 1]. - - d = 32 ifTrue: [ - "eight bits per component; 8 bits of alpha" - alpha _ p bitShift: -24. - alpha = 0 ifTrue: [ ^Colour transparent ]. - r _ (p bitShift: -16) bitAnd: 16rFF. - g _ (p bitShift: -8) bitAnd: 16rFF. - b _ p bitAnd: 16rFF. - ^alpha < 255 - ifTrue: [ (Colour r: r g: g b: b range: 255) alpha: alpha asFloat / 255.0 ] - ifFalse: [ Colour r: r g: g b: b range: 255 ]]. - - d = 16 ifTrue: [ - "five bits per component. The most significant bit, unused, allows having real black, without p being zero" - r _ (p bitShift: -10) bitAnd: 16r1F. - g _ (p bitShift: -5) bitAnd: 16r1F. - b _ p bitAnd: 16r1F. - ^ Colour r: r g: g b: b range: 31]. - - d = 15 ifTrue: [ - "five bits per component" - r _ (p bitShift: -10) bitAnd: 16r1F. - g _ (p bitShift: -5) bitAnd: 16r1F. - b _ p bitAnd: 16r1F. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Colour black ]. - ^ Colour r: r g: g b: b range: 31]. - - d = 12 ifTrue: [ - "four bits per component" - r _ (p bitShift: -8) bitAnd: 16rF. - g _ (p bitShift: -4) bitAnd: 16rF. - b _ p bitAnd: 16rF. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Colour black ]. - ^ Colour r: r g: g b: b range: 15]. - - d = 9 ifTrue: [ - "three bits per component" - r _ (p bitShift: -6) bitAnd: 16r7. - g _ (p bitShift: -3) bitAnd: 16r7. - b _ p bitAnd: 16r7. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Colour black ]. - ^ Colour r: r g: g b: b range: 7]. - - self error: 'unknown pixel depth: ', d printString! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:10:01'! - fromArray: colorDef - - | answer | - colorDef size = 0 ifTrue: [^self transparent]. - colorDef size between: 3 and: 4 :: ifFalse: [self error: 'Undefined color definition']. - answer _ self r: (colorDef at: 1) g: (colorDef at: 2) b: (colorDef at: 3). - ^colorDef size = 3 - ifTrue: [answer] - ifFalse: [answer alpha: (colorDef at: 4)]! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:10:01'! - fromRgbTriplet: list - ^ self r: list first g: list second b: list last! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:10:01'! - fromString: aString - "For HTML color spec: #FFCCAA. Also support named colors. - See http://www.w3schools.com/cssref/css_colors_legal.asp" - " - Color fromString: '#FFCCAA'. - Color fromString: 'white'. - Color fromString: 'orange' - Color fromString: 'rgb(255,0,98)' - " - (aString size = 7 and: [ aString first = $# ]) ifTrue: [ - | aColorHexU red green blue | - aColorHexU _ aString asUppercase. - red _ ('16r', (aColorHexU copyFrom: 2 to: 3)) asNumber/255. - green _ ('16r', (aColorHexU copyFrom: 4 to: 5)) asNumber/255. - blue _ ('16r', (aColorHexU copyFrom: 6 to: 7)) asNumber/255. - ^ self r: red g: green b: blue]. - - (aString beginsWith: 'rgb') - ifTrue: [|values r g b| - values := (aString allButFirst: 4) allButLast findTokens: ','. - r := (values first includes: $%) - ifTrue: [(values first asNumber min: 100 max: 0) / 100.0] - ifFalse: [(values first asInteger min: 255 max: 0) / 255.0]. - g := (values second includes: $%) - ifTrue: [(values second asNumber min: 100 max: 0) / 100.0] - ifFalse: [(values second asInteger min: 255 max: 0) / 255.0]. - b := (values third includes: $%) - ifTrue: [(values third asNumber min: 100 max: 0) / 100.0] - ifFalse: [(values third asInteger min: 255 max: 0) / 255.0]. - ^self r: r g: g b: b]. - - ^self exactColorNamed: aString! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:29'! - gray: brightness - "Return a gray shade with the given brightness in the range [0.0..1.0]." - - ^ self new - setRed: brightness - green: brightness - blue: brightness! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:31'! - h: hue s: saturation v: brightness - "Create a color with the given hue, saturation, and brightness. Hue is given as the angle in degrees of the color on the color circle where red is zero degrees. Saturation and brightness are numbers in [0.0..1.0] where larger values are more saturated or brighter colors. For example, (Color h: 0 s: 1 v: 1) is pure red." - "Note: By convention, brightness is abbreviated 'v' to to avoid confusion with blue." - - ^ self new setHue: hue saturation: saturation brightness: brightness! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:10:01'! - h: h s: s v: v alpha: alpha - - ^ (self h: h s: s v: v) alpha: alpha! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:34'! - hue: hue chroma: chroma brightness: brightness - ^self new setHue: hue chroma: chroma brightness: brightness! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:37'! - hue: hue chroma: chroma luminance: luma - ^self new setHue: hue chroma: chroma luminance: luma! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:39'! - hue: hue saturation: saturation brightness: brightness - "Create a color with the given hue, saturation, and brightness. Hue is given as the angle in degrees of the color on the color circle where red is zero degrees. Saturation and brightness are numbers in [0.0..1.0] where larger values are more saturated or brighter colors. For example, (Color h: 0 s: 1 v: 1) is pure red." - "Note: By convention, brightness is abbreviated 'v' to to avoid confusion with blue." - - ^ self new setHue: hue saturation: saturation brightness: brightness! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:54:20'! - new - ^ self new: 3! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:41'! - r: r g: g b: b - "Return a color with the given r, g, and b components in the range [0.0..1.0]." - - ^ self new - setRed: r - green: g - blue: b! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:10:01'! -r: r g: g b: b alpha: alpha - - ^ (self r: r g: g b: b) alpha: alpha! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:43'! - r: r g: g b: b range: range - "Return a color with the given r, g, and b components specified as integers in the range [0..r]. This avoids the floating point arithmetic in the red:green:blue: message and is thus a bit faster for certain applications (such as computing a sequence of colors for a palette)." - - ^ self new setRed: r green: g blue: b range: range! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:10:01'! - random - "Return a random color that isn't too dark or under-saturated. - Display fill: (10@10 extent: 200@200) fillColor: Color random - " - - ^ Random withDefaultDo: [ :random | - self random: random ]! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:10:01'! - random2 - "Return a random color with a distribution that spans over all possible colors. - Display fill: (10@10 extent: 200@200) fillColor: Color random2 - " - - ^ Random withDefaultDo: [ :random | - self random2: random ]! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:46'! - random2: aRandom - "Return a random color with a distribution that spans over all possible colors." - - ^ self new - setRed: aRandom next - green: aRandom next - blue: aRandom next! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:48'! - random: aRandom - "Return a random color that isn't too dark or under-saturated." - - ^ self new - setHue: (360.0 * aRandom next) - saturation: (0.3 + (aRandom next * 0.7)) - brightness: (0.4 + (aRandom next * 0.6))! ! -!Colour class methodsFor: 'class initialization' stamp: 'jmv 6/18/2017 20:10:01'! - initializeGrayToIndexMap - "Build an array of gray values available in the 8-bit colormap. This array is indexed by a gray level between black (1) and white (256) and returns the pixel value for the corresponding gray level." - "Note: This method must be called after initializeIndexedColors, since it uses IndexedColors." - " - Color initializeGrayToIndexMap - " - - | grayLevels grayIndices c distToClosest dist indexOfClosest indexedColors | - "record the level and index of each gray in the 8-bit color table" - grayLevels _ OrderedCollection new. - grayIndices _ OrderedCollection new. - indexedColors _ self indexedColors. - "Note: skip the first entry, which is reserved for transparent" - 2 to: indexedColors size do: [:i | - c _ indexedColors at: i. - c saturation = 0.0 ifTrue: [ "c is a gray" - grayLevels add: (c green * 255) rounded. "0 to 255; R, G, and B are the same" - grayIndices add: i - 1]]. "pixel values are zero-based" - grayLevels _ grayLevels asArray. - grayIndices _ grayIndices asArray. - - "for each gray level in [0..255], select the closest match" - GrayToIndexMap _ ByteArray new: 256. - 0 to: 255 do: [ :level | - distToClosest _ 10000. "greater than distance to any real gray" - 1 to: grayLevels size do: [:i | - dist _ (level - (grayLevels at: i)) abs. - dist < distToClosest ifTrue: [ - distToClosest _ dist. - indexOfClosest _ grayIndices at: i]]. - GrayToIndexMap at: (level + 1) put: indexOfClosest]! ! -!Colour class methodsFor: 'class initialization' stamp: 'jmv 6/18/2017 20:59:48'! - initializeIndexedColors - "Build an array of colors corresponding to the fixed colormap used - for display depths of 1, 2, 4, or 8 bits." - "Color initializeIndexedColors" - - | a index grayVal | - a _ Array new: 256. - - "1-bit colors (monochrome)" - a at: 1 put: (Colour r: 1.0 g: 1.0 b: 1.0). "white or transparent" - a at: 2 put: (Colour r: 0.0 g: 0.0 b: 0.0). "black" - - "additional colors for 2-bit color" - a at: 3 put: (Colour r: 1.0 g: 1.0 b: 1.0). "opaque white" - a at: 4 put: (Colour r: 0.5 g: 0.5 b: 0.5). "1/2 gray" - - "additional colors for 4-bit color" - a at: 5 put: (Colour r: 1.0 g: 0.0 b: 0.0). "red" - a at: 6 put: (Colour r: 0.0 g: 1.0 b: 0.0). "green" - a at: 7 put: (Colour r: 0.0 g: 0.0 b: 1.0). "blue" - a at: 8 put: (Colour r: 0.0 g: 1.0 b: 1.0). "cyan" - a at: 9 put: (Colour r: 1.0 g: 1.0 b: 0.0). "yellow" - a at: 10 put: (Colour r: 1.0 g: 0.0 b: 1.0). "magenta" - - a at: 11 put: (Colour r: 0.125 g: 0.125 b: 0.125). "1/8 gray" - a at: 12 put: (Colour r: 0.25 g: 0.25 b: 0.25). "2/8 gray" - a at: 13 put: (Colour r: 0.375 g: 0.375 b: 0.375). "3/8 gray" - a at: 14 put: (Colour r: 0.625 g: 0.625 b: 0.625). "5/8 gray" - a at: 15 put: (Colour r: 0.75 g: 0.75 b: 0.75). "6/8 gray" - a at: 16 put: (Colour r: 0.875 g: 0.875 b: 0.875). "7/8 gray" - - "additional colors for 8-bit color" - "24 more shades of gray (1/32 increments but not repeating 1/8 increments)" - index _ 17. - 1 to: 31 do: [:v | - (v \\ 4) = 0 ifFalse: [ - grayVal _ v / 32.0. - a at: index put: (Colour r: grayVal g: grayVal b: grayVal). - index _ index + 1]]. - - "The remainder of color table defines a color cube with six steps - for each primary color. Note that the corners of this cube repeat - previous colors, but this simplifies the mapping between RGB colors - and color map indices. This color cube spans indices 40 through 255 - (indices 41-256 in this 1-based array)." - 0 to: 5 do: [:r | - 0 to: 5 do: [:g | - 0 to: 5 do: [:b | - index _ 41 + ((36 * r) + (6 * b) + g). - index > 256 ifTrue: [ - self error: 'index out of range in color table compuation']. - a at: index put: (Colour r: r g: g b: b range: 5)]]]. - - IndexedColors _ a. -! ! -!Colour class methodsFor: 'examples' stamp: 'jmv 6/18/2017 20:58:14'! - colorRampForDepth: depth extent: aPoint - "Returns a form of the given size showing R, G, B, and gray ramps for the given depth. Useful for testing color conversions between different depths." - "(Color colorRampForDepth: Display depth extent: 256@80) display" - "(Color colorRampForDepth: 32 extent: 256@80) displayOn: Display at: 0@0 rule: Form paint" - - | f dx dy r | - f _ Form extent: aPoint depth: depth. - dx _ aPoint x // 256. - dy _ aPoint y // 4. - 0 to: 255 do: [:i | - r _ (dx * i)@0 extent: dx@dy. - f fill: r fillColor: (Colour r: i g: 0 b: 0 range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Colour r: 0 g: i b: 0 range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Colour r: 0 g: 0 b: i range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Colour r: i g: i b: i range: 255)]. - ^ f -! ! -!Colour class methodsFor: 'examples' stamp: 'jmv 6/18/2017 21:29:30'! - experimentsTowarsANewColorPalette -" -self experimentsTowarsANewColorPalette -" -| selectedHue selectedSaturation selectedV selectedColor h s v color width height selectedChroma selectedLuminance | -width _ 300. -height _ 120. -selectedColor _ Colour random. -selectedHue _ selectedColor hue. -selectedSaturation _ selectedColor saturation. -selectedChroma _ selectedColor chroma. -selectedV _ selectedColor brightness. -selectedLuminance _ selectedColor luminance. -Display getCanvas fillRectangle: (0@0 extent: height@height) color: selectedColor. -0 to: height do: [ :y | - v _ 1.0 - (y / height). - 0 to: height do: [ :x | - s _ x / height. - color _ Colour new setHue: selectedHue saturation: s brightness: v. - Display colorAt: x@(y+height) put: color - ]. - DisplayScreen screenUpdateRequired: nil -]. -0 to: height do: [ :y | | c | - v _ 1.0 - (y / height). - s _ 1.0 - (y / height). - c _ s. - 0 to: width do: [ :x | - h _ x / width * 360. - - color _ Colour new setHue: h chroma: c luminance: selectedLuminance. -" color _ Colour new setHue: h chroma: c brightness: selectedV." - color ifNil: [ color _ Colour black ]. -" color _ Colour new setHue: h saturation: s brightness: selectedV." - Display colorAt: x+height@y put: color. - - color _ Colour new setHue: h chroma: selectedChroma luminance: v. -" color _ Colour new setHue: h chroma: selectedChroma brightness: v." - color ifNil: [ color _ Colour black ]. -" color _ Colour new setHue: h saturation: selectedSaturation brightness: v." - Display colorAt: x+height@(y+height) put: color. - - ]. - DisplayScreen screenUpdateRequired: nil -].! ! -!Colour class methodsFor: 'examples' stamp: 'jmv 6/18/2017 20:10:01'! - hotColdShades: thisMany - "An array of thisMany colors showing temperature from blue to red to white hot. (Later improve this by swinging in hue.) " - "Color showColors: (Color hotColdShades: 25)" - - | n s1 s2 s3 s4 s5 | - thisMany < 5 ifTrue: [^ self error: 'must be at least 5 shades']. - n _ thisMany // 5. - s1 _ self white mix: self yellow shades: (thisMany - (n*4)). - s2 _ self yellow mix: self red shades: n+1. - s2 _ s2 copyFrom: 2 to: n+1. - s3 _ self red mix: self green darker shades: n+1. - s3 _ s3 copyFrom: 2 to: n+1. - s4 _ self green darker mix: self blue shades: n+1. - s4 _ s4 copyFrom: 2 to: n+1. - s5 _ self blue mix: self black shades: n+1. - s5 _ s5 copyFrom: 2 to: n+1. - ^ s1, s2, s3, s4, s5 -! ! -!Colour class methodsFor: 'examples' stamp: 'jmv 6/18/2017 20:59:58'! - showColorCube - "Show a 12x12x12 color cube." - "Color showColorCube" - - 0 to: 11 do: [:r | - 0 to: 11 do: [:g | - 0 to: 11 do: [:b | - Display fill: (((r*60) + (b*5)) @ (g*5) extent: 5@5) - fillColor: (Colour r: r g: g b: b range: 11)]]]. -! ! -!Colour class methodsFor: 'examples' stamp: 'jmv 6/18/2017 20:10:01'! - showColors: colorList - "Display the given collection of colors across the top of the Display." - - | w r | - w _ Display width // colorList size. - r _ 0@0 extent: w@((w min: 30) max: 10). - colorList do: [:c | - Display fill: r fillColor: c. - r _ r translatedBy: w@0]. -! ! -!Colour class methodsFor: 'examples' stamp: 'jmv 6/18/2017 21:00:03'! - showHSVPalettes - "Shows a palette of hues, varying the saturation and brightness for each one. Best results are with depths 16 and 32." - "Color showHSVPalettes" - - | left top c | - left _ top _ 0. - 0 to: 179 by: 15 do: [:h | - 0 to: 10 do: [:s | - left _ (h * 4) + (s * 4). - 0 to: 10 do: [:v | - c _ Colour h: h s: s asFloat / 10.0 v: v asFloat / 10.0. - top _ (v * 4). - Display fill: (left@top extent: 4@4) fillColor: c. - - c _ Colour h: h + 180 s: s asFloat / 10.0 v: v asFloat / 10.0. - top _ (v * 4) + 50. - Display fill: (left@top extent: 4@4) fillColor: c]]]. -! ! -!Colour class methodsFor: 'examples' stamp: 'jmv 6/18/2017 20:10:01'! - showHuesInteractively - "Shows a palette of hues at a (saturation, brightness) point determined by the mouse position. Click the mouse button to exit and return the selected (saturation, brightness) point." - "Color showHuesInteractively" - - | p s v | - [Sensor isAnyButtonPressed] whileFalse: [ - p _ Sensor mousePoint. - s _ p x asFloat / 300.0. - v _ p y asFloat / 300.0. - self showColors: (self wheel: 12 saturation: s brightness: v)]. - ^ (s min: 1.0) @ (v min: 1.0)! ! -!Colour class methodsFor: 'examples' stamp: 'jmv 6/18/2017 21:01:15'! - wheel: thisMany - "Return a collection of thisMany colors evenly spaced around the color wheel." - "Color showColors: (Color wheel: 12)" - - ^ Colour wheel: thisMany saturation: 0.9 brightness: 0.7 -! ! -!Colour class methodsFor: 'examples' stamp: 'jmv 6/18/2017 21:01:20'! - wheel: thisMany saturation: s brightness: v - "Return a collection of thisMany colors evenly spaced around the color wheel, all of the given saturation and brightness." - "Color showColors: (Color wheel: 12 saturation: 0.4 brightness: 1.0)" - "Color showColors: (Color wheel: 12 saturation: 0.8 brightness: 0.5)" - - ^ (Colour h: 0.0 s: s v: v) wheel: thisMany -! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - aqua - - ^ self colorNamesDict at: #aqua! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - beige - - ^ self colorNamesDict at: #beige! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - black - - ^ self colorNamesDict at: #black! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - blue - - ^ self colorNamesDict at: #blue! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - brightGreen - - ^ self colorNamesDict at: #brightGreen! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - brown - - ^ self colorNamesDict at: #brown! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - cyan - - ^ self colorNamesDict at: #cyan! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - darkBlue - - ^ self colorNamesDict at: #darkBlue! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - darkGray - - ^ self colorNamesDict at: #darkGray! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - darkGreen - - ^ self colorNamesDict at: #darkGreen! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - darkPink - - ^ self colorNamesDict at: #darkPink! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - darkPurple - - ^ self colorNamesDict at: #darkPurple! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! -forestGreen - - ^ self colorNamesDict at: #forestGreen! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - gray - - ^ self colorNamesDict at: #gray! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - green - - ^ self colorNamesDict at: #green! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - grey - - ^ self colorNamesDict at: #grey! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - hotPink - - ^ self colorNamesDict at: #hotPink! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - indigo - - ^ self colorNamesDict at: #indigo! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lavender - - ^ self colorNamesDict at: #lavender! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lightBlue - - ^ self colorNamesDict at: #lightBlue! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lightBrown - - ^ self colorNamesDict at: #lightBrown! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! -lightCyan - - ^ self colorNamesDict at: #lightCyan! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lightGray - - ^ self colorNamesDict at: #lightGray! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lightGreen - - ^ self colorNamesDict at: #lightGreen! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! -lightMagenta - - ^ self colorNamesDict at: #lightMagenta! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lightOrange - - ^ self colorNamesDict at: #lightOrange! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lightPink - - ^ self colorNamesDict at: #lightPink! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lightPurple - - ^ self colorNamesDict at: #lightPurple! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lightRed - - ^ self colorNamesDict at: #lightRed! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lightYellow - - ^ self colorNamesDict at: #lightYellow! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lilac - - ^ self colorNamesDict at: #lilac! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lime - - ^ self colorNamesDict at: #lime! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - limeGreen - - ^ self colorNamesDict at: #limeGreen! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - magenta - - ^ self colorNamesDict at: #magenta! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - maroon - - ^ self colorNamesDict at: #maroon! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - mauve - - ^ self colorNamesDict at: #mauve! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - mustard - - ^ self colorNamesDict at: #mustard! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - navyBlue - - ^ self colorNamesDict at: #navyBlue! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - olive - - ^ self colorNamesDict at: #olive! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - oliveGreen - - ^ self colorNamesDict at: #oliveGreen! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! -orange - - ^ self colorNamesDict at: #orange! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - paleGreen - - ^ self colorNamesDict at: #paleGreen! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - peach - - ^ self colorNamesDict at: #peach! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - periwinkle - - ^ self colorNamesDict at: #periwinkle! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! -pink - - ^ self colorNamesDict at: #pink! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - purple - - ^ self colorNamesDict at: #purple! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - red - - ^ self colorNamesDict at: #red! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - royalBlue - - ^ self colorNamesDict at: #royalBlue! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - salmon - - ^ self colorNamesDict at: #salmon! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - seaGreen - - ^ self colorNamesDict at: #seaGreen! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - skyBlue - - ^ self colorNamesDict at: #skyBlue! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - tan - - ^ self colorNamesDict at: #tan! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - teal - - ^ self colorNamesDict at: #teal! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - transparent - - ^ self colorNamesDict at: #transparent! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - turquoise - - ^ self colorNamesDict at: #turquoise! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - veryDarkGray - - ^ self colorNamesDict at: #veryDarkGray! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - veryLightGray - - ^ self colorNamesDict at: #veryLightGray! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - veryVeryDarkGray - - ^ self colorNamesDict at: #veryVeryDarkGray! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - veryVeryLightGray - - ^ self colorNamesDict at: #veryVeryLightGray! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - violet - - ^ self colorNamesDict at: #violet! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - white - - ^ self colorNamesDict at: #white! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - yellow - - ^ self colorNamesDict at: #yellow! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:10:01'! - cachedColormapForGrayFrom: sourceDepth - "Return a cached colormap for mapping from the given depth to the 8bpp grays. Always return a real colormap, not nil; this allows the client to get an identity colormap that can then be copied and modified to do color transformations." - "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" - "Note: The colormap cache may be cleared by evaluating 'Color shutDown'." - "Note: The color maps for sourceDepth=16 and for sourceDepth=32 are the same" - - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | srcIndex map | - ToGrayColormaps ifNil: [ - ToGrayColormaps _ Array new: 5]. - - srcIndex _ sourceDepth highBit min: 5. - - (ToGrayColormaps at: srcIndex) ifNotNil: [ :m | ^ m ]. - - map _ self computeColormapForGray8bppFrom: sourceDepth. - ToGrayColormaps at: srcIndex put: map. - ^ map! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:10:01'! - cachedColormapFrom: sourceDepth to: destDepth - "Return a cached colormap for mapping between the given depths. Always return a real colormap, not nil; this allows the client to get an identity colormap that can then be copied and modified to do color transformations." - "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" - "Note: The colormap cache may be cleared by evaluating 'Color shutDown'." - "Note: The color maps for sourceDepth=16 and for sourceDepth=32 are the same" - - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | srcIndex dstIndex map | - CachedColormaps - ifNil: [CachedColormaps _ (1 to: 5) collect: [:i | Array new: 6]]. - - srcIndex _ sourceDepth highBit min: 5. - dstIndex _ destDepth highBit. - - ((CachedColormaps at: srcIndex) at: dstIndex) ifNotNil: [ :m | ^ m ]. - - map _ self computeColormapFrom: sourceDepth to: destDepth. - (CachedColormaps at: srcIndex) at: dstIndex put: map. - ^ map! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:10:01'! - cachedColormapFromGrayTo: destDepth - "Return a cached colormap for mapping from 8bpp grays to the given depth. Always return a real colormap, not nil; this allows the client to get an identity colormap that can then be copied and modified to do color transformations." - "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" - "Note: The colormap cache may be cleared by evaluating 'Color shutDown'." - "Note: The color maps for sourceDepth=16 and for sourceDepth=32 are the same" - - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | dstIndex map | - FromGrayColormaps - ifNil: [FromGrayColormaps _ Array new: 6 ]. - - dstIndex _ destDepth highBit. - - (FromGrayColormaps at: dstIndex) ifNotNil: [ :m | ^ m ]. - - map _ self computeColormapFromGray8bppForDepth: destDepth. - FromGrayColormaps at: dstIndex put: map. - ^ map! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:57:57'! - colorMapIfNeededFrom: sourceDepth to: destDepth - "Return a colormap for mapping between the given depths, or nil if no colormap is needed." - "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" - - sourceDepth = destDepth ifTrue: [^ nil]. "not needed if depths are the same" - - (sourceDepth >= 16) & (destDepth >= 16) ifTrue: [ - "mapping is done in BitBlt by zero-filling or truncating each color component" - ^ nil]. - - ^ Colour cachedColormapFrom: sourceDepth to: destDepth -! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:10:01'! - computeColorConvertingMap: targetColor from: sourceDepth to: destDepth keepSubPixelAA: keepSubPix - "Note: The color converting map for sourceDepth=16 and for sourceDepth=32 are the same" - sourceDepth < 16 ifTrue: [ - "source is 1-, 2-, 4-, or 8-bit indexed color. - Assumed not to include subpixelAA" - ^ self computeIndexedColorConvertingMap: targetColor from: sourceDepth to: destDepth - ] ifFalse: [ - "source is 16-bit or 32-bit RGB. - Might include subpixelAA" - ^ self computeRGBColorConvertingMap: targetColor to: destDepth keepSubPixelAA: keepSubPix - ]! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:10:01'! - computeColormapForGray8bppFrom: sourceDepth - "Compute a colorMap for translatingfrom the given depth to the 8bpp grays" - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | map | - sourceDepth < 16 ifTrue: [ - "source is 1-, 2-, 4-, or 8-bit indexed color" - map _ (self indexedColors copyFrom: 1 to: (1 bitShift: sourceDepth)) - collect: [ :c | (c luminance * 255) rounded]. - map _ map as: Bitmap. - ^ map - ] - ifFalse: [ - ^ self computeRGBColormapForGray8 ]! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:10:01'! - computeColormapFrom: sourceDepth to: destDepth - "Compute a colorMap for translating between the given depths. A colormap is a Bitmap whose entries contain the pixel values for the destination depth. Typical clients use cachedColormapFrom:to: instead." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | map bitsPerColor | - sourceDepth < 16 ifTrue: [ - "source is 1-, 2-, 4-, or 8-bit indexed color" - map _ (self indexedColors copyFrom: 1 to: (1 bitShift: sourceDepth)) - collect: [:c | c pixelValueForDepth: destDepth]. - map _ map as: Bitmap. - ] ifFalse: [ - "source is 16-bit or 32-bit RGB" - destDepth > 8 - ifTrue: [bitsPerColor _ 5] "retain maximum color resolution" - ifFalse: [bitsPerColor _ 4]. - map _ self computeRGBColormapFor: destDepth bitsPerColor: bitsPerColor]. - - "Note: zero is transparent except when source depth is one-bit deep" - sourceDepth > 1 ifTrue: [map at: 1 put: 0]. - ^ map -! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:58:29'! - computeColormapFromGray8bppForDepth: destDepth - "Return a colormap for displaying a GrayForm at the given depth" - - | newMap | - newMap _ Bitmap new: 256. - 1 to: 256 do: [ :i | - newMap - at: i - put: ((Colour gray: (i-1) asFloat / 255.0) pixelValueForDepth: destDepth)]. - ^ newMap! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:58:33'! - computeIndexedColorConvertingMap: targetColor from: sourceDepth to: destDepth - | map | - - map _ (self indexedColors copyFrom: 1 to: (1 bitShift: sourceDepth)) collect: [ :cc | | f c | - f _ 1.0 - (cc red + cc green + cc blue / 3.0 ). - c _ targetColor - ifNotNil: [ - destDepth = 32 - ifTrue: [ targetColor * f alpha: f] - ifFalse: [ targetColor alphaMixed: f*1.5 with: Colour white ]] - ifNil: [ cc ]. - destDepth = 32 - ifTrue: [ c pixelValueForDepth: destDepth] - ifFalse: [ - f = 0.0 - ifTrue: [ 0 ] - ifFalse: [ c pixelValueForDepth: destDepth ]]]. - map _ map as: Bitmap. - ^map! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:58:41'! - computeRGBColorConvertingMap: targetColor to: destDepth keepSubPixelAA: keepSubPix - "Builds a colormap intended to convert from subpixelAA black values to targetColor values. - keepSubPix - ifTrue: [ Answer colors that also include subpixelAA ] - ifFalse: [ - Take fullpixel luminance level. Apply it to targetColor. - I.e. answer colors with NO subpixelAA ]" - - | mask map c bitsPerColor r g b f v | - - destDepth > 8 - ifTrue: [bitsPerColor _ 5] "retain maximum color resolution" - ifFalse: [bitsPerColor _ 4]. - "Usually a bit less is enough, but make it configurable" - bitsPerColor _ bitsPerColor min: Preferences aaFontsColormapDepth. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - r _ (i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask. - g _ (i bitShift: 0 - bitsPerColor) bitAnd: mask. - b _ (i bitShift: 0) bitAnd: mask. - f _ 1.0 - (r + g + b / 3.0 / mask). - c _ targetColor - ifNotNil: [ - (keepSubPix and: [destDepth > 8]) ifTrue: [ - Colour - r: 1.0 - (r asFloat/mask) * targetColor red - g: 1.0 - (g asFloat/mask) * targetColor green - b: 1.0 - (b asFloat/mask) * targetColor blue - alpha: f * targetColor alpha "alpha will be ignored below, in #pixelValueForDepth: if destDepth ~= 32" ] - ifFalse: [ - destDepth = 32 - ifTrue: [ targetColor * f alpha: f * targetColor alpha ] - ifFalse: [ targetColor alphaMixed: f*1.5 with: Colour white ]]] - ifNil: [ Colour r: r g: g b: b range: mask]. "This is currently used only to keep some SubPixelAA on destDepth = 8, using a single pass of rule 25" - v _ destDepth = 32 - ifTrue: [ c pixelValueForDepth: destDepth] - ifFalse: [ - f < 0.1 - ifTrue: [ 0 ] - ifFalse: [ c pixelValueForDepth: destDepth ]]. - map at: i + 1 put: v ]. - ^ map! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:58:48'! - computeRGBColormapFor: destDepth bitsPerColor: bitsPerColor - "Compute a colorMap for translating from 16-bit or 32-bit RGB color to the given depth, using the given number of of bits per color component." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | mask map c | - (#(3 4 5) includes: bitsPerColor) - ifFalse: [self error: 'BitBlt only supports 3, 4, or 5 bits per color component']. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - c _ Colour - r: ((i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask) - g: ((i bitShift: 0 - bitsPerColor) bitAnd: mask) - b: ((i bitShift: 0) bitAnd: mask) - range: mask. - map at: i + 1 put: (c pixelValueForDepth: destDepth)]. - - map at: 1 put: (Colour transparent pixelWordForDepth: destDepth). "zero always transparent" - ^ map -! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:58:56'! - computeRGBColormapForGray8 - "Compute a colorMap for translating from 16-bit or 32-bit RGB color to 8bpp grays, using the default number of of bits per color component." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | bitsPerColor mask map c | - bitsPerColor _ 5. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - c _ Colour - r: ((i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask) - g: ((i bitShift: 0 - bitsPerColor) bitAnd: mask) - b: ((i bitShift: 0) bitAnd: mask) - range: mask. - map at: i + 1 put: (c luminance * 255) rounded]. - - ^ map! ! -!Colour class methodsFor: 'other' stamp: 'jmv 6/18/2017 20:10:01'! - maskingMap: depth - "Return a color map that maps all colors except transparent to words of all ones. Used to create a mask for a Form whose transparent pixel value is zero. Cache the most recently used map." - "Warning: The behavior is incorrect if depth = 32. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | sizeNeeded | - depth <= 8 - ifTrue: [sizeNeeded _ 1 bitShift: depth] - ifFalse: [sizeNeeded _ 4096]. - - (MaskingMap == nil or: [MaskingMap size ~= sizeNeeded]) ifTrue: - [MaskingMap _ Bitmap new: sizeNeeded withAll: 16rFFFFFFFF. - MaskingMap at: 1 put: 0. "transparent"]. - - ^ MaskingMap -! ! -!Colour class methodsFor: 'color from user' stamp: 'jmv 6/18/2017 20:58:07'! - colorPaletteForDepth: depth extent: chartExtent - "Display a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." - "Note: It is slow to build this palette, so it should be cached for quick access." - "(Color colorPaletteForDepth: 16 extent: 190@60) display" - - | basicHue x y startHue palette transHt vSteps transCaption grayWidth hSteps | - palette _ Form extent: chartExtent depth: depth. - transCaption _ - (Form extent: 34@9 depth: 1 - fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0) - offset: 0@0). - transHt _ transCaption height. - palette fillWhite: (0@0 extent: palette width@transHt). - palette fillBlack: (0@transHt extent: palette width@1). - transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0). - grayWidth _ 10. - startHue _ 338.0. - vSteps _ palette height - transHt // 2. - hSteps _ palette width - grayWidth. - x _ 0. - startHue to: startHue + 360.0 by: 360.0/hSteps do: [ :h | - basicHue _ Colour h: h asFloat s: 1.0 v: 1.0. - y _ transHt+1. - 0 to: vSteps do: [ :n | | c | - c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Colour white. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - 1 to: vSteps do: [ :n | | c | - c _ Colour black mixed: (n asFloat / vSteps asFloat) with: basicHue. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - x _ x + 1]. - y _ transHt + 1. - 1 to: vSteps * 2 do: [ :n | | c | - c _ Colour black mixed: (n asFloat / (vSteps*2) asFloat) with: Colour white. - palette fill: (x@y extent: 10@1) fillColor: c. - y _ y + 1]. - ^ palette -! ! -!Colour class methodsFor: 'color from user' stamp: 'jmv 6/18/2017 20:58:24'! - colorTest: depth extent: chartExtent colorMapper: colorMapper - "Create a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." - "Note: It is slow to build this palette, so it should be cached for quick access." - "(Color colorTest: 32 extent: 570@180 colorMapper: [:c | c]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 7) asInteger / 7 - g: (c green * 7) asInteger / 7 - b: (c blue * 3) asInteger / 3]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 5) asInteger / 5 - g: (c green * 5) asInteger / 5 - b: (c blue * 5) asInteger / 5]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 15) asInteger / 15 - g: (c green * 15) asInteger / 15 - b: (c blue * 15) asInteger / 15]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 31) asInteger / 31 - g: (c green * 31) asInteger / 31 - b: (c blue * 31) asInteger / 31]) display" - - | basicHue x y c startHue palette transHt vSteps transCaption grayWidth hSteps | - palette _ Form extent: chartExtent depth: depth. - transCaption _ - (Form extent: 34@9 depth: 1 - fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0) - offset: 0@0). - transHt _ transCaption height. - palette fillWhite: (0@0 extent: palette width@transHt). - palette fillBlack: (0@transHt extent: palette width@1). - transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0). - grayWidth _ 10. - startHue _ 338.0. - vSteps _ palette height - transHt // 2. - hSteps _ palette width - grayWidth. - x _ 0. - startHue to: startHue + 360.0 by: 360.0/hSteps do: [:h | - basicHue _ Colour h: h asFloat s: 1.0 v: 1.0. - y _ transHt+1. - 0 to: vSteps do: [:n | - c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Colour white. - c _ colorMapper value: c. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - 1 to: vSteps do: [:n | - c _ Colour black mixed: (n asFloat / vSteps asFloat) with: basicHue. - c _ colorMapper value: c. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - x _ x + 1]. - y _ transHt + 1. - 1 to: vSteps * 2 do: [:n | - c _ Colour black mixed: (n asFloat / (vSteps*2) asFloat) with: Colour white. - c _ colorMapper value: c. - palette fill: (x@y extent: 10@1) fillColor: c. - y _ y + 1]. - ^ palette -! ! -!Colour class methodsFor: 'color name lookup' stamp: 'jmv 6/18/2017 20:10:01'! - colorNames - "Answer the current dictionary of name->color associations." - - ^self colorNamesDict keys! ! -!Colour class methodsFor: 'color name lookup' stamp: 'jmv 6/18/2017 20:59:02'! - defaultColorNamesDictionary - "Answer a amall but useful name->color dictionary" - - | defaultDict | - "Meld most used xkcd colors into traditional colors." - defaultDict := (self traditionalColorNamesDictionary addAll: - self xkcdFirst48ColorNamesDictionary; - yourself). - - "Override traditional names existing in extended XKCD naming" - defaultDict at: #lightYellow put: (Colour r: 1.0 g: 0.996 b: 0.478). - defaultDict at: #lightOrange put: (Colour r: 0.992 g: 0.667 b: 0.283). - defaultDict at: #lightCyan put: (Colour r: 0.674 g: 1.0 b: 0.988). - defaultDict at: #lightRed put: (Colour r: 1.0 g: 0.279 b: 0.298). - defaultDict at: #lightMagenta put: (Colour r: 0.98 g: 0.372 b: 0.969). - - ^defaultDict! ! -!Colour class methodsFor: 'color name lookup' stamp: 'jmv 6/18/2017 20:59:12'! - doesNotUnderstand: aMessage - "Some code takes - Color colorNames - and does - Color perform: aColorname. - - Make this work." - - ^(Colour colorNamesDict) - at: (aMessage selector) - ifAbsent: [super doesNotUnderstand: aMessage]! ! -!Colour class methodsFor: 'color name lookup' stamp: 'jmv 6/18/2017 20:10:01'! - exactColorNamed: aColorName - - "Answer color matching name or nil - from my ColorName->Color Dictionary" - - ^ self colorNamesDict at: (aColorName asSymbol) ifAbsent: [nil]! ! -!Colour class methodsFor: 'color name lookup' stamp: 'jmv 6/18/2017 20:59:55'! - setColorNamesDict: aNameColorDictionary - "Answer the current dictionary of name->color associations." - - "Note: This is a non-standard name because this is a non-standard action!! - Do this if you really, really know what you are doing." - - "Some Colors are required for proper system operation" - Colour defaultColorNamesDictionary keysAndValuesDo: [ :colorName :colorValue | - aNameColorDictionary at: colorName ifAbsentPut: colorValue - ]. - - ColorNamesDict := aNameColorDictionary! ! -!Colour class methodsFor: 'color name lookup' stamp: 'jmv 6/18/2017 21:01:08'! - traditionalColorNamesDictionary - "Answer a dictionary of Squeak traditional name->color associations.." - - | nameDict | - nameDict _ Dictionary new. - nameDict at: #black put: (Colour r: 0 g: 0 b: 0). - nameDict at: #veryVeryDarkGray put: (Colour r: 0.125 g: 0.125 b: 0.125). - nameDict at: #veryDarkGray put: (Colour r: 0.25 g: 0.25 b: 0.25). - nameDict at: #darkGray put: (Colour r: 0.375 g: 0.375 b: 0.375). - nameDict at: #gray put: (Colour r: 0.5 g: 0.5 b: 0.5). - nameDict at: #lightGray put: (Colour r: 0.625 g: 0.625 b: 0.625). - nameDict at: #veryLightGray put: (Colour r: 0.75 g: 0.75 b: 0.75). - nameDict at: #veryVeryLightGray put: (Colour r: 0.875 g: 0.875 b: 0.875). - nameDict at: #white put: (Colour r: 1.0 g: 1.0 b: 1.0). - nameDict at: #red put: (Colour r: 1.0 g: 0 b: 0). - nameDict at: #yellow put: (Colour r: 1.0 g: 1.0 b: 0). - nameDict at: #green put: (Colour r: 0 g: 1.0 b: 0). - nameDict at: #cyan put: (Colour r: 0 g: 1.0 b: 1.0). - nameDict at: #blue put: (Colour r: 0 g: 0 b: 1.0). - nameDict at: #magenta put: (Colour r: 1.0 g: 0 b: 1.0). - nameDict at: #brown put: (Colour r: 0.6 g: 0.2 b: 0). - nameDict at: #orange put: (Colour r: 1.0 g: 0.6 b: 0). - nameDict at: #lightRed put: (Colour r: 1.0 g: 0.8 b: 0.8). - nameDict at: #lightYellow put: (Colour r: 1.0 g: 1.0 b: 0.8). - nameDict at: #lightGreen put: (Colour r: 0.8 g: 1.0 b: 0.6). - nameDict at: #lightCyan put: (Colour r: 0.4 g: 1.0 b: 1.0). - nameDict at: #lightBlue put: (Colour r: 0.8 g: 1.0 b: 1.0). - nameDict at: #lightMagenta put: (Colour r: 1.0 g: 0.8 b: 1.0). - nameDict at: #lightBrown put: (Colour r: 1.0 g: 0.6 b: 0.2). - nameDict at: #lightOrange put: (Colour r: 1.0 g: 0.8 b: 0.4). - nameDict at: #transparent put: (TranslucentColour r: 0.0 g: 0.0 b: 0.0 alpha: 0.0). - - ^nameDict -! ! -!Colour class methodsFor: 'color name lookup' stamp: 'jmv 6/18/2017 21:01:38'! - xkcdFirst48ColorNamesDictionary - "XKCD color names are based on a survey oc colors people call by the same name. - http://blog.xkcd.com/2010/05/03/color-survey-results/" - - "Answer a dictionary of the most agreed upon first 48 xkcd colors" -" - Color xkcdFirst48ColorNamesDictionary explore. -" - | xkcdDict | - xkcdDict := Dictionary new - at: #lightPink put: (Colour fromString: '#ffd1df') ; - at: #mustard put: (Colour fromString: '#ceb301') ; - at: #indigo put: (Colour fromString: '#380282') ; - at: #lime put: (Colour fromString: '#aaff32') ; - at: #seaGreen put: (Colour fromString: '#53fca1') ; - at: #periwinkle put: (Colour fromString: '#8e82fe') ; - at: #darkPink put: (Colour fromString: '#cb416b') ; - at: #oliveGreen put: (Colour fromString: '#677a04') ; - at: #peach put: (Colour fromString: '#ffb07c') ; - at: #paleGreen put: (Colour fromString: '#c7fdb5') ; - at: #lightBrown put: (Colour fromString: '#ad8150') ; - at: #hotPink put: (Colour fromString: '#ff028d') ; - at: #black put: (Colour fromString: '#000000') ; - at: #lilac put: (Colour fromString: '#cea2fd') ; - at: #navyBlue put: (Colour fromString: '#001146') ; - at: #royalBlue put: (Colour fromString: '#0504aa') ; - at: #beige put: (Colour fromString: '#e6daa6') ; - at: #salmon put: (Colour fromString: '#ff796c') ; - at: #olive put: (Colour fromString: '#6e750e') ; - at: #maroon put: (Colour fromString: '#650021') ; - at: #brightGreen put: (Colour fromString: '#01ff07') ; - at: #darkPurple put: (Colour fromString: '#35063e') ; - at: #mauve put: (Colour fromString: '#ae7181') ; - at: #forestGreen put: (Colour fromString: '#06470c') ; - at: #aqua put: (Colour fromString: '#13eac9') ; - at: #cyan put: (Colour fromString: '#00ffff') ; - at: #tan put: (Colour fromString: '#d1b26f') ; - at: #darkBlue put: (Colour fromString: '#00035b') ; - at: #lavender put: (Colour fromString: '#c79fef') ; - at: #turquoise put: (Colour fromString: '#06c2ac') ; - at: #darkGreen put: (Colour fromString: '#033500') ; - at: #violet put: (Colour fromString: '#9a0eea') ; - at: #lightPurple put: (Colour fromString: '#bf77f6') ; - at: #limeGreen put: (Colour fromString: '#89fe05') ; - at: #grey put: (Colour fromString: '#929591') ; - at: #skyBlue put: (Colour fromString: '#75bbfd') ; - at: #yellow put: (Colour fromString: '#ffff14') ; - at: #magenta put: (Colour fromString: '#c20078') ; - at: #lightGreen put: (Colour fromString: '#96f97b') ; - at: #orange put: (Colour fromString: '#f97306') ; - at: #teal put: (Colour fromString: '#029386') ; - at: #lightBlue put: (Colour fromString: '#95d0fc') ; - at: #red put: (Colour fromString: '#e50000') ; - at: #brown put: (Colour fromString: '#653700') ; - at: #pink put: (Colour fromString: '#ff81c0') ; - at: #blue put: (Colour fromString: '#0343df') ; - at: #green put: (Colour fromString: '#15b01a') ; - at: #purple put: (Colour fromString: '#7e1e9c') ; - yourself. - - ^xkcdDict - -! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - blueColorDict - "Answer a dictionary of named colors considered Blue" -" - Color blueColorDict explore. -" - ^self blueColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - blueColorDict: aColorDict - "Answer a dictionary of named colors considered Blue" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isBlue) - or: [assoc key asString asLowercase includesSubString: 'blue']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - blueGreenColorDict - "Answer a dictionary of named colors considered Blue" -" - Color blueGreenColorDict explore. -" - ^self blueGreenColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - blueGreenColorDict: aColorDict - "Answer a dictionary of named colors considered Blue" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isBlueGreen) - or: [assoc key asString asLowercase includesSubString: 'bluegreen']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - brightColorDict - "Answer a dictionary of named colors considered Bright" -" - Color brightColorDict explore. -" - ^self brightColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - brightColorDict: aColorDict - "Answer a dictionary of named colors considered Bright" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - (assoc value isBright) ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - brownColorDict - "Answer a dictionary of named colors considered Brown" -" - Color brownColorDict explore. -" - ^self brownColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - brownColorDict: aColorDict - "Answer a dictionary of named colors considered Brown" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isBrown) - or: [assoc key asString asLowercase includesSubString: 'brown']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - darkColorDict - "Answer a dictionary of named colors considered Dark" -" - Color darkColorDict explore. -" - ^self darkColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - darkColorDict: aColorDict - "Answer a dictionary of named colors considered Dark" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - (assoc value isDark) ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - grayColorDict: aColorDict - "Answer a dictionary of named colors considered Grey" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isGrey) - or: [assoc key asString asLowercase includesSubString: 'grey']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - greenColorDict - "Answer a dictionary of named colors considered Green" -" - Color greenColorDict explore. -" - ^self greenColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - greenColorDict: aColorDict - "Answer a dictionary of named colors considered Green" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isGreen) - or: [assoc key asString asLowercase includesSubString: 'green']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - greyColorDict - "Answer a dictionary of named colors considered Grey" -" - Color greyColorDict explore. -" - ^self greyColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - greyColorDict: aColorDict - "Answer a dictionary of named colors considered Grey" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isGrey) - or: [assoc key asString asLowercase includesSubString: 'grey']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - lightColorDict - "Answer a dictionary of named colors considered light" -" - Color lightColorDict explore. -" - ^self lightColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - lightColorDict: aColorDict - "Answer a dictionary of named colors considered Liight" - - ^self brightColorDict: aColorDict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - orangeColorDict - "Answer a dictionary of named colors considered Orange" -" - Color orangeColorDict explore. -" - ^self orangeColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - orangeColorDict: aColorDict - "Answer a dictionary of named colors considered Orange" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isOrange) - or: [assoc key asString asLowercase includesSubString: 'orange']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - pastelColorDict - "Answer a dictionary of named colors considered Pastel" -" - Color pastelColorDict explore. -" - ^self pastelColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - pastelColorDict: aColorDict - "Answer a dictionary of named colors considered Bright" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - (assoc value isPastel) ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - pinkColorDict - "Answer a dictionary of named colors considered Pink" -" - Color pinkColorDict explore. -" - ^self pinkColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - pinkColorDict: aColorDict - "Answer a dictionary of named colors considered Pink" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isPink) - or: [assoc key asString asLowercase includesSubString: 'pink']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - purpleColorDict - "Answer a dictionary of named colors considered Purple" -" - Color purpleColorDict explore. -" - ^self purpleColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - purpleColorDict: aColorDict - "Answer a dictionary of named colors considered Pink" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc key asString asLowercase includesSubString: 'purple') - or: [assoc key asString asLowercase includesSubString: 'violet']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - redColorDict - "Answer a dictionary of named colors considered Red" -" - Color redColorDict explore. -" - ^self redColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - redColorDict: aColorDict - "Answer a dictionary of named colors considered Red" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isRed) - or: [assoc key asString asLowercase includesSubString: 'red']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - saturatedColorDict - "Answer a dictionary of named colors considered Saturated" -" - Color saturatedColorDict explore. -" - ^self saturatedColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - saturatedColorDict: aColorDict - "Answer a dictionary of named colors considered Saturated" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - (assoc value isSaturated) ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - yellowColorDict - "Answer a dictionary of named colors considered Yellow" -" - Color yellowColorDict explore. -" - ^self yellowColorDict: (self colorNamesDict)! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - yellowColorDict: aColorDict - "Answer a dictionary of named colors considered Yellow" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isYellow) - or: [assoc key asString asLowercase includesSubString: 'yellow']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'color space conversions' stamp: 'jmv 6/18/2017 20:10:01'! - applySimpleGamma: gamma to: value - "Encode / decode Gamma. Typical gamma are 0.4545 ( = 1.0 / 2.2, for encoding) and 2.2 (for decoding) - In a non gamma encoded image, the pixel values are proportional to luminance, i.e. the actual light intensity, the photon count. - In an gamma encoded image, the pixel value is close to the average perceived brightness, or 'lightness'. This optimizes the use of available bits in digital images, and dynamic range in analog images and film. This is like the 'luma' signal in video. - - Usually: - - Images stored in file formats such as jpg, png, tiff and bmp are gamma encoded - (unless they are actually raw images). - - Images sent to a framebuffer (video memory) should be gamma encoded. - - Raw images from sensors are not gamma encoded. - - - Image processing algorithms that simulate the real world, or are applied to real world data should work on unencoded (linear) images. - This includes filtering, resizing, blending, and most operations done on images. - This means that if the images come from jpg photos from a camera, they should be gamma decoded. - - Image processing algorithms that works on human perception should work on gamma encoded images. - This includes histograms, histogram equalization, bit allocation (i.e. quantization), compression, etc. - This also includes detecting objects like a human would do - - - See - http://en.wikipedia.org/wiki/Gamma_correction - http://www.poynton.com/notes/colour_and_gamma/GammaFAQ.html - - Mostly for documentation. - value must be in [0.0 .. 1.0]. - Note that the sRGB standard specifies a function that is close to this, but slightly different. - See #linearTosRGBGamma: and #sRGBGammaToLinear:" - - ^ value raisedTo: gamma! ! -!Colour class methodsFor: 'color space conversions' stamp: 'jmv 6/18/2017 20:10:01'! - linearTosRGBGamma: value - "The sRGB standard specifies a gamma curve that is close to gamma = 2.2, but is actually - built from one stright line segment, and a curve with exponent = 2.4. - This method converts value from linearSpace to gammaSpace, i.e. it 'encodes' with gamma. - This is the operation done when producing an 8bit Form for displaying, or for saving on a JPG, PNG, etc; if source data is in linear space (for example, from raw data a sensor image, or data that was converted previously to linear space for proper image processing). - value must be in [0.0 .. 1.0]. - - See - http://en.wikipedia.org/wiki/Gamma_correction - http://www.poynton.com/notes/colour_and_gamma/GammaFAQ.html - http://entropymine.com/imageworsener/srgbformula - - | r v | - r _ Random new. - 1000 timesRepeat: [ - v _ r next. - self assert: ((Color sRGBGammaToLinear: (Color linearTosRGBGamma: v)) closeTo: v) ] - - | r | - r _ 10@10 extent: 600@400. - Display fill: r fillColor: Color white. - FFT new plot: ((0.0 to: 1.0 count: 100) collect: [ :v | Color linearTosRGBGamma: v ]) in: r color: Color black min: 0.0 max: 1.0. - FFT new plot: ((0.0 to: 1.0 count: 100) collect: [ :v | Color applySimpleGamma: 1/2.2 to: v ]) in: r color: Color blue min: 0.0 max: 1.0. - FFT new plot: ((0.0 to: 1.0 count: 100) collect: [ :v | Color sRGBGammaToLinear: v ]) in: r color: Color black min: 0.0 max: 1.0. - FFT new plot: ((0.0 to: 1.0 count: 100) collect: [ :v | Color applySimpleGamma: 2.2 to: v ]) in: r color: Color blue min: 0.0 max: 1.0. - " - - ^ value <= 0.00313066844250063 - ifTrue: [ value * 12.92 ] - ifFalse: [ (value raisedTo: 1.0/2.4) * 1.055 - 0.055 ]! ! -!Colour class methodsFor: 'color space conversions' stamp: 'jmv 6/18/2017 20:10:01'! - sRGBGammaToLinear: value - "The sRGB standard specifies a gamma curve that is close to gamma = 2.2, but is actually - built from one stright line segment, and a curve with exponent = 2.4. - This method converts value from gammaSpace to linearSpace, i.e. it 'decodes'. - This is the operation done by display screens. It is also needed to convert 8bit Forms (from a frameBuffer, or from PNG, JPG, etc.) to linear space for proper image processing. - value must be in [0.0 .. 1.0]. - - See - http://en.wikipedia.org/wiki/Gamma_correction - http://www.poynton.com/notes/colour_and_gamma/GammaFAQ.html - http://entropymine.com/imageworsener/srgbformula - " - - ^ value <= 0.0404482362771082 - ifTrue: [ value / 12.92 ] - ifFalse: [ value + 0.055 / 1.055 raisedTo: 2.4 ]! ! -!Colour class methodsFor: 'cached state access' stamp: 'jmv 6/18/2017 20:10:01'! - colorNamesDict - "Answer the current dictionary of name->color associations." -" - Color colorNamesDict explore. -" - ColorNamesDict ifNil: [ - self setColorNamesDict: self defaultColorNamesDictionary ]. - ^ColorNamesDict! ! -!Colour class methodsFor: 'cached state access' stamp: 'jmv 6/18/2017 20:10:01'! - grayToIndexMap - " - Color grayToIndexMap explore. - " - GrayToIndexMap ifNil: [ - self initializeGrayToIndexMap ]. - ^GrayToIndexMap! ! -!Colour class methodsFor: 'cached state access' stamp: 'jmv 6/18/2017 20:10:01'! - indexedColors - " - Color indexedColors explore. - " - IndexedColors ifNil: [ - self initializeIndexedColors ]. - ^IndexedColors! ! -!Colour class methodsFor: 'cached state access' stamp: 'jmv 6/18/2017 20:10:01'! - releaseClassCachedState - " - Color releaseClassCachedState - " - CachedColormaps _ nil. "Maps to translate between color depths" - ToGrayColormaps _ nil. "Maps colors to 8bpp grays for various color depths" - FromGrayColormaps _ nil. "Maps from 8bpp grays to colors of various depths" - MaskingMap _ nil. "Maps all colors except transparent to black for creating a mask" - ColorNamesDict _ nil. - IndexedColors _ nil. - GrayToIndexMap _ nil! ! -!TranslucentColour methodsFor: 'accessing' stamp: 'jmv 6/18/2017 20:41:17'! - alpha - "Return my alpha value, a number between 0.0 and 1.0 where 0.0 is completely transparent and 1.0 is completely opaque." - - ^ self at: 4! ! -!TranslucentColour methodsFor: 'printing' stamp: 'jmv 6/18/2017 20:10:08'! - storeArrayValuesOn: aStream - - self isTransparent ifTrue: [ - ^ aStream space]. - super storeArrayValuesOn: aStream. - aStream space. - self alpha printOn: aStream fractionDigits: 3! ! -!TranslucentColour methodsFor: 'printing' stamp: 'jmv 6/18/2017 20:10:08'! -storeOn: aStream - - self isTransparent ifTrue: [^ aStream nextPutAll: '(Color transparent)']. - aStream - nextPut: $(; - nextPutAll: self class name; - nextPutAll: ' r: '. - self red printOn: aStream fractionDigits: 3. - aStream nextPutAll: ' g: '. - self green printOn: aStream fractionDigits: 3. - aStream nextPutAll: ' b: '. - self blue printOn: aStream fractionDigits: 3. - aStream nextPutAll: ' alpha: '. - self alpha printOn: aStream fractionDigits: 3. - aStream nextPutAll: ')'! ! -!TranslucentColour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:55:03'! - alpha: alphaValue - "Return a new TranslucentColor with the given amount of opacity ('alpha')." - alphaValue = 1.0 ifTrue: [ - ^ Colour new - setRed: self red - green: self green - blue: self blue]. - ^ super alpha: alphaValue! ! -!TranslucentColour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:08'! - asNontranslucentColor - ^ self alpha: 1.0! ! -!TranslucentColour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:08'! - bitPatternForDepth: depth - "Return an appropriate bit pattern. This will almost never be meaningful for tranlucentColors, except for the degenerate case of tranparency." - - self isTransparent ifTrue: [ - ^ Bitmap with: 0]. - ^ super bitPatternForDepth: depth! ! -!TranslucentColour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:41:47'! - pixelValueForDepth: d - "Return the pixel value for this color at the given depth. Translucency only works in RGB; this color will appear either opaque or transparent at all other depths." - | basicPixelWord | - "In 32bpp, if alpha = 0, ignore any color components, and answer R=0, G=0, B=0, Alpha=0. - In depths > 8 and < 32, pixelValue zero is the special value used by BitBlt to denote transparent." - self isTransparent ifTrue: [ - ^ 0]. - basicPixelWord _ super pixelValueForDepth: d. - ^d < 32 - ifTrue: [ basicPixelWord ] - ifFalse: [ (basicPixelWord bitAnd: 16rFFFFFF) bitOr: - ((self alpha*255.0) rounded - bitShift: 24) ]! ! -!TranslucentColour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:41:50'! - pixelWordForDepth: depth - "Return the pixel value for this color at the given depth. Translucency only works in RGB; this color will appear either opaque or transparent at all other depths." - - | basicPixelWord | - self isTransparent ifTrue: [^ 0]. - basicPixelWord _ super pixelWordForDepth: depth. - ^depth < 32 - ifTrue: [ basicPixelWord ] - ifFalse: [ (basicPixelWord bitAnd: 16rFFFFFF) bitOr: - ((self alpha*255.0) rounded - bitShift: 24) ]! ! -!TranslucentColour methodsFor: 'private' stamp: 'jmv 6/18/2017 20:42:05'! - setRed: r green: g blue: b alpha: alphaValue - - self basicSetRed: r green: g blue: b. - self at: 4 put: alphaValue! ! -!TranslucentColour methodsFor: 'queries' stamp: 'jmv 6/18/2017 20:41:26'! - isOpaque - - ^self alpha = 1.0! ! -!TranslucentColour methodsFor: 'queries' stamp: 'jmv 6/18/2017 20:41:54'! - isTransparent - ^ self alpha = 0.0! ! -!TranslucentColour methodsFor: 'please remove' stamp: 'jmv 6/18/2017 21:27:51'! - setRed: r green: g blue: b alpha: alphaValue colorSpace: aSymbol - ^ self setRed: r green: g blue: b alpha: alphaValue! ! -!TranslucentColour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:54:35'! - new - ^ self new: 4! ! -!TranslucentColour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:57:08'! - r: r g: g b: b alpha: alphaValue - "Return a color with the given r, g, and b components in the range [0.0..1.0]." - - ^ self new - setRed: r - green: g - blue: b - alpha: alphaValue! ! -!FloatArray methodsFor: 'comparing' stamp: 'jmv 6/18/2017 20:25:14' prior: 16846542! - = another - self == another ifTrue: [ ^ true ]. - self class == another class ifFalse: [ ^ false ]. - ^self primitiveEqual: another! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3105-FloatArrayColour-JuanVuletich-2017Jun19-09h57m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3103] on 19 June 2017 at 11:11:02 am'! -!Integer methodsFor: 'converting' stamp: 'ar 10/31/1998 23:04' prior: 16859466! - asColorOfDepth: d - "Return a color value representing the receiver as color of the given depth" - ^Colour colorFromPixelValue: self depth: d! ! -!InputSensor methodsFor: 'keyboard' stamp: 'jmv 9/2/2016 11:08:09' prior: 16856307! - kbdTest - " - Sensor kbdTest - " - "This test routine will print the unmodified character, its keycode, - and the OR of all its modifier bits, until the character x is typed - -Also useful: - Sensor test - " - | char | - char _ nil. - [ char = $x ] whileFalse: [ - [ self keyboardPressed ] whileFalse. - char _ self keyboard. - Display fill: (5@5 extent: 400@20) fillColor: Colour white. - (String streamContents: [ :s | - s - nextPut: $-; - nextPut: char; - nextPut: $-; - space; - print: char numericValue; - space. - self isMouseButton3Pressed ifTrue: [ s nextPutAll: ' mouseButton3/blue/tertiary/halo ' ]. - self isMouseButton2Pressed ifTrue: [ s nextPutAll: ' mouseButton2/yellow/secondary/menu ' ]. - self isMouseButton1Pressed ifTrue: [ s nextPutAll: ' mouseButton1/red/primary ' ]. - self shiftPressed ifTrue: [ s nextPutAll: ' shift ' ]. - self controlKeyPressed ifTrue: [ s nextPutAll: ' control/ctrl ' ]. - (self primMouseButtons anyMask: 32) ifTrue: [ s nextPutAll: ' macOption ' ]. - self commandAltKeyPressed ifTrue: [ s nextPutAll: ' macCommand/winAlt ' ]]) - displayAt: 10 @ 10 ].! ! -!String methodsFor: 'displaying' stamp: 'jmv 5/12/2015 15:52' prior: 16917036! - 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: Colour black - " - 'Display' displayOn: Display at: 10@10 - "! ! -!SystemDictionary methodsFor: 'shrinking' stamp: 'jmv 4/25/2016 15:31' prior: 16922270! - reduceCuis - " - Smalltalk reduceCuis - " - | keep n unused newDicts oldDicts | - - self nominallyUnsent: #reduceCuis. - - "Remove icons" - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - PasteUpMorph allInstancesDo: [ :w | - w backgroundImageData: nil. - w submorphsDo: [ :a | a delete ]]. - Preferences useNoIcons. - Theme current initialize. - Theme content: nil. - Colour shutDown. - BitBltCanvas releaseClassCachedState. - - Transcript clear. - Clipboard default initialize. - - - "Remove some methods, even if they have senders." -" ColorPickerMorph class removeSelector: #buildEyedropperIcon." - Theme removeSelector: #miscellaneousIcons. - Utilities removeSelector: #vmStatisticsReportString. - SystemDictionary removeSelector: #recreateSpecialObjectsArray. - - StrikeFont removeMostFonts. - StrikeFont saveSpace. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - - keep := OrderedCollection new. - keep addAll: #(SpaceTally). - AppLauncher appGlobalName ifNotNil: [ :any | - keep add: any ]. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - [ - #hereWeGo print. - unused do: [:c | - c print. - (Smalltalk at: c) removeFromSystem]. - n := Smalltalk removeAllUnSentMessages. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - n > 0 or: [ - unused notEmpty ]] whileTrue. - ChangeSet zapAllChangeSets. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - Symbol rehash. - - "Shrink method dictionaries." - Smalltalk garbageCollect. - oldDicts _ MethodDictionary allInstances. - newDicts _ Array new: oldDicts size. - oldDicts withIndexDo: [:d :index | - newDicts at: index put: d rehashWithoutBecome ]. - oldDicts elementsExchangeIdentityWith: newDicts. - oldDicts _ newDicts _ nil. - - SmalltalkCompleter initialize . - - "Sanity checks" -" Undeclared - Smalltalk cleanOutUndeclared - Smalltalk browseUndeclaredReferences - Smalltalk obsoleteClasses - Smalltalk obsoleteBehaviors - Smalltalk browseObsoleteMethodReferences - SmalltalkImage current fixObsoleteReferences - Smalltalk browseAllUnimplementedCalls"! ! -!Transcripter methodsFor: 'accessing' stamp: 'jmv 7/28/2015 08:26' prior: 16938828! - 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]. - textComposition - setModel: (TextModel withText: c asText); - extentForComposing: frame width-8 @9999. - textComposition composeAll. - d _ textComposition usedHeight - frame height. - d > 0 ifTrue: [ - "Scroll up to keep all contents visible" - cb _ textComposition characterBlockAtPoint: - 0@0 + (0@(d+AbstractFont default height)). - self on: (c copyFrom: cb stringIndex to: c size). - readLimit _ position _ collection size. - ^ self endEntry]. - Display fill: (frame insetBy: -2) fillColor: self black; - fill: frame fillColor: self white. - Display getCanvas - textComposition: textComposition - bounds: (4@4 + frame topLeft extent: Display extent) - color: Colour black - selectionColor: Colour blue. - DisplayScreen screenUpdateRequired: nil! ! -!Transcripter methodsFor: 'private' stamp: 'di 8/14/97 12:12' prior: 16938904! - black - Display depth = 1 ifTrue: [^ Bitmap with: 16rFFFFFFFF "Works without color support"]. - ^ Colour black! ! -!Transcripter methodsFor: 'private' stamp: 'di 8/14/97 12:12' prior: 16938910! - white - Display depth = 1 ifTrue: [^ Bitmap with: 0 "Works without color support"]. - ^ Colour white! ! -!DataStream class methodsFor: 'as yet unclassified' stamp: '' prior: 16827931! - example - "An example and test of DataStream/ReferenceStream. - 11/19/92 jhm: Use self testWith:." - "DataStream example" - "ReferenceStream example" - | input sharedPoint | - - "Construct the test data." - input _ Array new: 9. - input at: 1 put: nil. - input at: 2 put: true. - input at: 3 put: (Form extent: 63 @ 50 depth: 8). - (input at: 3) fillWithColor: Colour lightBlue. - input at: 4 put: #(3 3.0 'three'). - input at: 5 put: false. - input at: 6 put: 1024 @ -2048. - input at: 7 put: #x. - input at: 8 put: (Array with: (sharedPoint _ 0 @ -30000)). - input at: 9 put: sharedPoint. - - "Write it out, read it back, and return it for inspection." - ^ self testWith: input! ! -!ReferenceStream class methodsFor: 'as yet unclassified' stamp: '' prior: 16900040! - example2 -"Here is the way to use DataStream and ReferenceStream: - rr _ ReferenceStream fileNamed: ''test.obj''. - rr nextPut: . - rr close. - -To get it back: - rr _ ReferenceStream fileNamed: ''test.obj''. - _ rr next. - rr close. -" -"An example and test of DataStream/ReferenceStream. - 11/19/92 jhm: Use self testWith:." - "ReferenceStream example2" - | input sharedPoint | - - "Construct the test data." - input _ Array new: 9. - input at: 1 put: nil. - input at: 2 put: true. - input at: 3 put: false. - input at: 4 put: #(-4 -4.0 'four' four). - input at: 5 put: (Form extent: 63 @ 50 depth: 8). - (input at: 5) fillWithColor: Colour lightOrange. - input at: 6 put: 1024 @ -2048. - input at: 7 put: input. "a cycle" - input at: 8 put: (Array with: (sharedPoint _ 0 @ -30000)). - input at: 9 put: sharedPoint. - - "Write it out, read it back, and return it for inspection." - ^ self testWith: input -! ! -!TextEditor methodsFor: 'attributes' stamp: 'jmv 6/18/2017 21:32:55' prior: 16931569! - offerColorMenu - "Present a menu of available colors, and if one is chosen, apply it to the current selection." - "This is a user command, and generates undo" - - | attribute colors index thisSel | - thisSel _ self selection. - colors _ #(#black #magenta #red #yellow #green #blue #cyan #white ). - index _ (PopUpMenu - labelArray: colors , #('choose color...' ) - lines: (Array with: colors size + 1)) startUpMenu. - index = 0 ifTrue: [ ^ true ]. - index <= colors size - ifTrue: [ attribute _ TextColor color: (Colour perform: (colors at: index)) ] - ifFalse: [ - index _ index - colors size - 1. - "Re-number!!!!!!" - index = 0 ifTrue: [ attribute _ self chooseColor ]. - thisSel ifNil: [ ^ true ]]. - attribute ifNotNil: [ self applyAttribute: attribute ]. - ^ true.! ! -!TextAction class methodsFor: 'as yet unclassified' stamp: 'jmv 4/19/2015 09:38' prior: 16930008! - textActionColor - ^Colour r: 0.4 g: 0 b: 1.0! ! -!TextColor methodsFor: 'testing' stamp: 'jmv 1/21/2011 11:33' prior: 16930362! - isSet - "Do not include Colour black, as it is the default color." - ^color ~= Colour black! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 16930372! - black - ^ self new color: Colour black! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 16930375! - blue - ^ self new color: Colour blue! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 16930378! - cyan - ^ self new color: Colour cyan! ! -!TextColor class methodsFor: 'constants' stamp: 'ajh 9/10/2002 02:26' prior: 16930382! - gray - ^ self new color: Colour gray! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 16930385! - green - ^ self new color: Colour green! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 16930388! - magenta - ^ self new color: Colour magenta! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 16930391! - red - ^ self new color: Colour red! ! -!TextColor class methodsFor: 'constants' stamp: 'sma 3/24/2000 10:50' prior: 16930395! - white - ^ self new color: Colour white! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 16930398! - yellow - ^ self new color: Colour yellow! ! -!Preferences class methodsFor: 'halos' stamp: 'jmv 6/18/2017 21:33:44' prior: 16893209! - installHaloSpecsFromArray: anArray - - | aColour | - ^ self parameters at: #HaloSpecs put: (anArray collect: [ :each | - aColour _ Colour. - each fourth do: [ :sel | aColour _ aColour perform: sel]. - HaloSpec new - horizontalPlacement: each second - verticalPlacement: each third - color: aColour - iconSymbol: each fifth - addHandleSelector: each first - hoverHelp: each sixth])! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 9/19/2016 20:45:55' prior: 16938476! - displayOn: aForm in: aRectangle - " - Transcript displayOn: Display - " - | font count i string x y fh f canvas innerR | - aForm fill: aRectangle fillColor: Colour white. - font _ AbstractFont default. - - innerR _ aRectangle insetBy: self padding. - fh _ font height. - count _ innerR height // fh-1. - x _ innerR left. - y _ innerR top. - f _ firstIndex-1. - firstIndex > lastIndex ifTrue: [ f _ f - self maxEntries ]. - i _ (lastIndex - count max: f) \\ self maxEntries + 1. - canvas _ aForm getCanvas. - canvas newClipRect: innerR. - [ - string _ entries at: i. - canvas drawString: string at: x@y font: font color: Colour veryDarkGray. - y _ y + fh. - i = lastIndex - ] whileFalse: [ i _ i \\ self maxEntries + 1 ]. - - string _ unfinishedEntry contents. - canvas drawString: string at: x@y font: font color: Colour veryDarkGray! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 9/19/2016 20:53:35' prior: 16938512! - displayUnfinishedEntryOn: aForm - - | font count string x y fh canvas r innerR | - innerR _ bounds insetBy: self padding. - lastDisplayPosition < innerR right ifTrue: [ - font _ AbstractFont default. - fh _ font height. - count _ innerR height // fh-1. - x _ innerR left. - string _ unfinishedEntry contents. - y _ ((lastIndex - firstIndex \\ self maxEntries) min: count-1) + 1 * font height + innerR top. - canvas _ aForm getCanvas. - r _ innerR left: lastDisplayPosition. - canvas newClipRect: r. - (canvas drawString: string at: x@y font: font color: Colour veryDarkGray) ifNotNil: [ :lastPoint | - lastDisplayPosition _ lastPoint x. - ^r ]]. - ^nil! ! -!Form methodsFor: 'analyzing' stamp: 'ar 5/17/2001 15:40' prior: 16846838! - dominantColor - | tally max maxi | - self depth > 16 ifTrue: - [^(self asFormOfDepth: 16) dominantColor]. - tally _ self tallyPixelValues. - max _ maxi _ 0. - tally withIndexDo: [:n :i | n > max ifTrue: [max _ n. maxi _ i]]. - ^ Colour colorFromPixelValue: maxi - 1 depth: self depth! ! -!Form methodsFor: 'bordering' stamp: 'jmv 1/22/2015 10:22' prior: 16847019! - border: aRectangle width: borderWidth - "Paint a border whose rectangular area is defined by aRectangle. The - width of the border of each side is borderWidth. Uses black for - drawing the border." - - self border: aRectangle width: borderWidth fillColor: Colour black! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:20' prior: 16847087! - fillBlack - "Set all bits in the receiver to black (ones)." - - self fill: self boundingBox fillColor: Colour black! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:20' prior: 16847093! - fillBlack: aRectangle - "Set all bits in the receiver's area defined by aRectangle to black (ones)." - - self fill: aRectangle rule: Form over fillColor: Colour black! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:20' prior: 16847109! - fillGray - "Set all bits in the receiver to gray." - - self fill: self boundingBox fillColor: Colour gray! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:20' prior: 16847115! - fillGray: aRectangle - "Set all bits in the receiver's area defined by aRectangle to the gray mask." - - self fill: aRectangle rule: Form over fillColor: Colour gray! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:21' prior: 16847146! - fillWhite - "Set all bits in the form to white." - - self fill: self boundingBox fillColor: Colour white! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:21' prior: 16847152! - fillWhite: aRectangle - "Set all bits in the receiver's area defined by aRectangle to white." - - self fill: aRectangle rule: Form over fillColor: Colour white! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:21' prior: 16847165! - reverse - "Change all the bits in the receiver that are white to black, and the ones - that are black to white. - Display reverse - " - - self fill: self boundingBox rule: Form reverse fillColor: Colour white! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:21' prior: 16847174! - reverse: aRectangle - "Change all the bits in the receiver's area that intersects with aRectangle - that are white to black, and the ones that are black to white." - - self fill: aRectangle rule: Form reverse fillColor: Colour white! ! -!Form methodsFor: 'color mapping' stamp: 'ar 5/17/2001 15:42' prior: 16847212! - colormapIfNeededForDepth: destDepth - "Return a colormap for displaying the receiver at the given depth, or nil if no colormap is needed." - - self depth = destDepth ifTrue: [^ nil]. "not needed if depths are the same" - ^ Colour colorMapIfNeededFrom: self depth to: destDepth -! ! -!Form methodsFor: 'color mapping' stamp: 'jmv 5/12/2016 13:53' prior: 16847223! - colormapIfNeededForGray8bpp - "Return a colormap for displaying the receiver at the given depth. - Note: Uses 5 bits per color component. 32bit Forms will lose information!!" - - ^ Colour cachedColormapForGrayFrom: self depth! ! -!Form methodsFor: 'color mapping' stamp: 'jmv 6/18/2017 21:31:52' prior: 16847240! - mapColor: oldColour to: newColor - "Make all pixels of the given color in this Form to the given new color." - "Warnings: This method modifies the receiver. It may lose some color accuracy on 32-bit Forms, since the transformation uses a color map with only 15-bit resolution." - - | map | - map _ (Colour cachedColormapFrom: self depth to: self depth) copy. - map at: (oldColour indexInMap: map) put: (newColor pixelWordForDepth: self depth). - (BitBlt toForm: self) - sourceForm: self; - sourceOrigin: 0@0; - combinationRule: Form over; - destX: 0 destY: 0 width: width height: height; - colorMap: map; - copyBits. -! ! -!Form methodsFor: 'color mapping' stamp: 'jmv 1/31/2011 09:21' prior: 16847262! - maskingMap - "Return a color map that maps all colors except transparent to words of all ones. Used to create a mask for a Form whose transparent pixel value is zero." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Colour maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - ^Colour maskingMap: self depth! ! -!Form methodsFor: 'converting' stamp: 'jm 11/12/97 19:28' prior: 16847299! - as8BitColorForm - "Simple conversion of zero pixels to transparent. Force it to 8 bits." - - | f map | - f _ ColorForm extent: self extent depth: 8. - self displayOn: f at: self offset negated. - map _ Colour indexedColors copy. - map at: 1 put: Colour transparent. - f colors: map. - f offset: self offset. - ^ f -! ! -!Form methodsFor: 'pixel access' stamp: 'ar 5/17/2001 15:42' prior: 16848158! - colorAt: aPoint - "Return the color in the pixel at the given point. " - - ^ Colour - colorFromPixelValue: (self pixelValueAt: aPoint) - depth: self depth -! ! -!Form methodsFor: 'pixel access' stamp: 'jmv 11/4/2015 12:40' prior: 16848175! - colorInterpolatedAt: aPoint - "Evaluate a bilinear (i.e. cheap) interpolation - Like OpenCV's CV_INTER_LINEAR - Answer Colour transparent if outside image bounds. - Copied almost verbatim from FloatImage. - Answer Colors with float components. Will be rounded to be stored in, for example, a 32-bit Form." - - | x y w interpolated xWeight1 xWeight0 yWeight1 yWeight0 xIndex0 xIndex1 yIndex0 yIndex1 | - x _ aPoint x. - y _ aPoint y. - x < 0.0 ifTrue: [ ^Colour transparent ]. - xIndex0 _ x truncated. "Could be #floor. But as we only care for values >=0, it is the same. But faster." - xIndex0 > (width-1) ifTrue: [ ^Colour transparent ]. - (xIndex0 = (width-1) and: [ x > (width-1) ]) ifTrue: [ ^Colour transparent ]. - xIndex1 _ xIndex0 = (width-1) "Avoid the invalid access if this was true, but don't make it slower the most common, general case." - ifFalse: [ xIndex0 + 1 ] - ifTrue: [ xIndex0 ]. - - y < 0.0 ifTrue: [ ^Colour transparent ]. - yIndex0 _ y truncated. "Could be #floor. But as we only care for values >=0, it is the same. But faster." - yIndex0 > (height-1) ifTrue: [ ^Colour transparent ]. - (yIndex0 = (height-1) and: [ y > (height-1) ]) ifTrue: [ ^Colour transparent ]. - yIndex1 _ yIndex0 = (height-1) "Avoid the invalid access if this was true, but don't make it slower the most common, general case." - ifFalse: [ yIndex0 + 1 ] - ifTrue: [ yIndex0 ]. - - xWeight1 _ x - xIndex0. - xWeight0 _ 1.0 - xWeight1. - - yWeight1 _ y - yIndex0. - yWeight0 _ 1.0 - yWeight1. - - "/* perform interpolation */" - w _ ((self colorAt: xIndex0 @ yIndex0) * xWeight0) + - ((self colorAt: xIndex1 @ yIndex0) * xWeight1). - interpolated _ w * yWeight0. - - w _ ((self colorAt: xIndex0 @ yIndex1) * xWeight0) + - ((self colorAt: xIndex1 @ yIndex1) * xWeight1). - interpolated _ w * yWeight1 + interpolated. - - ^interpolated! ! -!Form methodsFor: 'transitions' stamp: 'jmv 7/28/2015 08:32' prior: 16848519! - pageWarp: otherImage at: topLeft forward: forward - "Produce a page-turning illusion that gradually reveals otherImage - located at topLeft in this form. - forward == true means turn pages toward you, else away. [ignored for now]" - | pageRect oldPage nSteps buffer p leafRect sourceQuad warp oldBottom d | - pageRect _ otherImage boundingBox. - oldPage _ self copy: (pageRect translatedBy: topLeft). - (forward ifTrue: [oldPage] ifFalse: [otherImage]) - border: pageRect - widthRectangle: (Rectangle - left: 0 - right: 2 - top: 1 - bottom: 1) - rule: Form over - fillColor: Colour black. - oldBottom _ self copy: ((pageRect bottomLeft + topLeft) extent: (pageRect width@(pageRect height//4))). - nSteps _ 8. - buffer _ Form extent: otherImage extent + (0@(pageRect height//4)) depth: self depth. - d _ pageRect topLeft + (0@(pageRect height//4)) - pageRect topRight. - 1 to: nSteps-1 do: - [:i | forward - ifTrue: [buffer copy: pageRect from: otherImage to: 0@0 rule: Form over. - p _ pageRect topRight + (d * i // nSteps)] - ifFalse: [buffer copy: pageRect from: oldPage to: 0@0 rule: Form over. - p _ pageRect topRight + (d * (nSteps-i) // nSteps)]. - buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over. - leafRect _ pageRect topLeft corner: p x @ (pageRect bottom + p y). - sourceQuad _ Array with: pageRect topLeft - with: pageRect bottomLeft + (0@p y) - with: pageRect bottomRight - with: pageRect topRight - (0@p y). - warp _ (WarpBlt toForm: buffer) - clipRect: leafRect; - sourceForm: (forward ifTrue: [oldPage] ifFalse: [otherImage]); - combinationRule: Form paint. - warp copyQuad: sourceQuad toRect: leafRect. - self copy: buffer boundingBox from: buffer to: topLeft rule: Form over. - Display forceToScreen. - ]. - - buffer copy: pageRect from: otherImage to: 0@0 rule: Form over. - buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over. - self copy: buffer boundingBox from: buffer to: topLeft rule: Form over. - Display forceToScreen. -" -1 to: 4 do: [:corner | Display pageWarp: - (Form fromDisplay: (10@10 extent: 200@300)) reverse - at: 10@10 forward: false] -" -! ! -!Form class methodsFor: 'instance creation' stamp: 'jmv 9/23/2012 21:44' prior: 16848886! - dotOfSize: diameter - "Create a form which contains a round black dot." - | radius form bb rect centerX centerY centerYBias centerXBias radiusSquared xOverY maxy dx | - radius _ diameter//2. - form _ self extent: diameter@diameter offset: (0@0) - (radius@radius). - bb _ (BitBlt toForm: form) - sourceX: 0; sourceY: 0; - combinationRule: Form over; - fillColor: Colour black. - rect _ form boundingBox. - centerX _ rect center x. - centerY _ rect center y. - centerYBias _ rect height odd ifTrue: [0] ifFalse: [1]. - centerXBias _ rect width odd ifTrue: [0] ifFalse: [1]. - radiusSquared _ (rect height asFloat / 2.0) squared - 0.01. - xOverY _ rect width asFloat / rect height asFloat. - maxy _ rect height - 1 // 2. - - "First do the inner fill, and collect x values" - 0 to: maxy do: - [:dy | - dx _ ((radiusSquared - (dy * dy) asFloat) sqrt * xOverY) truncated. - bb destX: centerX - centerXBias - dx - destY: centerY - centerYBias - dy - width: dx + dx + centerXBias + 1 - height: 1; - copyBits. - bb destY: centerY + dy; - copyBits]. - ^ form -" -Time millisecondsToRun: - [1 to: 20 do: [:i | (Form dotOfSize: i) displayAt: (i*20)@(i*20)]] -"! ! -!Form class methodsFor: 'instance creation' stamp: 'pb 5/4/2016 17:43' prior: 16849005! - fakeSphereAt: aPoint diameter: diameter color: aColor - "Create a form which contains a round black dot." - | bb rect d p | - bb _ GrafPort toForm: Display. - bb fillColor: aColor. - bb combinationRule: Form blend. - rect _ aPoint extent: diameter. - bb fillOval: rect. - p _ (diameter * 2 // 5) asPoint + aPoint. - #(2 3 4 5 6 ) do: [ :i | - "simulate facade by circles of gray" - bb fillColor: (Colour white alpha: 0.3). - d _ i * diameter // 10. - rect _ Rectangle - center: p - extent: d. - bb fillOval: rect ]. - DisplayScreen screenUpdateRequired: nil. -" - Form fakeSphereAt: 50@50 diameter: 30 color: (Colour red alpha: 0.5) -"! ! -!Form class methodsFor: 'examples' stamp: 'jmv 3/20/2013 22:36' prior: 16849178! - toothpaste: diam - " - Display restoreAfter: [Form toothpaste: 30] - " - "Not completely unlike the ST-80 implementation :) - Original comment: - Draws wormlike lines by laying down images of spheres. - See Ken Knowlton, Computer Graphics, vol. 15 no. 4 p352. - Draw with mouse button down; terminate by option-click." - | point queue color q colors colr colr2 | - colors _ Colour red wheel: 12. - color _ 8. - [ true ] whileTrue: [ - queue _ OrderedCollection new: 32. - 16 timesRepeat: [queue addLast: -40@-40]. - Sensor waitButton. - Sensor isMouseButton2Pressed ifTrue: [^ self]. - point _ Sensor mousePoint. - colr _ colors atWrap: (color _ color + 5). "choose increment relatively prime to colors size" - colr2 _ colr alpha: 0.3. - [Sensor isMouseButton1Pressed or: [queue size > 0]] whileTrue: [ - point _ point * 4 + Sensor mousePoint // 5. - point _ point. - Form fakeSphereAt: point diameter: diam color: colr. - (q _ queue removeFirst) ifNil: [^ self]. "exit" - Form fakeSphereAt: q diameter: diam color: colr2. - Sensor isMouseButton1Pressed ifTrue: [queue addLast: point]]]! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 5/15/2015 09:37' prior: 16849256! - bottomLeftCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - "Create and answer a Form for the bottomLeft corner of a rounded rectangle" - | f aaw topColor bottomColor l d c width dy | - topColor _ Colour white * gradientTopFactor. - bottomColor _ Colour white * gradientBottomFactor. - width _ r. - aaw _ 1.3. - f _ Form - extent: width @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: width - 1 - do: [ :x | - dy _ height - r - y. - dy > 0 - ifTrue: [ l _ 1.0 ] - ifFalse: [ - d _ (width - 1 - x @ dy) r. - l _ ((r - d max: 0.0) min: aaw) / aaw ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 5/15/2015 09:47' prior: 16849283! - bottomLeftCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor borderWidth: bw - "Create and answer a Form for the bottomLeft corner of a rounded rectangle" - | f aaw topColor bottomColor l d c width dy l1 l2 | - topColor _ Colour white * gradientTopFactor. - bottomColor _ Colour white * gradientBottomFactor. - width _ r. - aaw _ 1.3. - f _ Form - extent: width @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: width - 1 - do: [ :x | - dy _ height - r - y. - dy > 0 - ifTrue: [ l _ 1.0 ] - ifFalse: [ - d _ (width - 1 - x @ dy) r. - l1 _ ((r - d-1+aaw max: 0.0) min: aaw) / aaw. - l2 _ ((d - r+bw+aaw max: 0.0) min: aaw) / aaw. - l _ l1 min: l2. - ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 5/15/2015 09:38' prior: 16849314! - bottomRightCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - "Create and answer a Form for the bottomRight corner of a rounded rectangle" - | f aaw topColor bottomColor l d c width dy | - topColor _ Colour white * gradientTopFactor. - bottomColor _ Colour white * gradientBottomFactor. - width _ r. - aaw _ 1.3. - f _ Form - extent: width @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: width - 1 - do: [ :x | - dy _ height - r - y. - dy > 0 - ifTrue: [ l _ 1.0 ] - ifFalse: [ - d _ (x @ dy) r. - l _ ((r - d max: 0.0) min: aaw) / aaw ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 5/15/2015 09:41' prior: 16849341! - bottomRightCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor borderWidth: bw - "Create and answer a Form for the bottomLeft corner of a rounded rectangle" - | f aaw topColor bottomColor l d c width dy l1 l2 | - topColor _ Colour white * gradientTopFactor. - bottomColor _ Colour white * gradientBottomFactor. - width _ r. - aaw _ 1.3. - f _ Form - extent: width @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: width - 1 - do: [ :x | - dy _ height - r - y. - dy > 0 - ifTrue: [ l _ 1.0 ] - ifFalse: [ - d _ (x @ dy) r. - l1 _ ((r - d-1+aaw max: 0.0) min: aaw) / aaw. - l2 _ ((d - r+bw+aaw max: 0.0) min: aaw) / aaw. - l _ l1 min: l2. - ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 11/30/2010 10:34' prior: 16849371! - topLeftCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - "Create and answer a Form with a vertical gray gradient as specified for the topLeft corner of a rounded rectangle" - | f bw topColor bottomColor l d c w | - topColor _ Colour white * gradientTopFactor. - bottomColor _ Colour white * gradientBottomFactor. - w _ r. - bw _ 1.3. - f _ Form - extent: w @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: w - 1 - do: [ :x | - l _ 1.0. - y < r ifTrue: [ - d _ (w - 1 - x @ (w - 1 - y)) r. - l _ ((r - d max: 0.0) min: bw) / bw ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 11/30/2010 10:36' prior: 16849397! - topRightCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - "Create and answer a Form with a vertical gray gradient as specified for the topRight corner of a rounded rectangle" - | f bw topColor bottomColor l d c w | - topColor _ Colour white * gradientTopFactor. - bottomColor _ Colour white * gradientBottomFactor. - w _ r. - bw _ 1.3. - f _ Form - extent: w @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: w - 1 - do: [ :x | - l _ 1.0. - y < r ifTrue: [ - d _ (x @ (w - y - 1)) r. - l _ ((r - d max: 0.0) min: bw) / bw ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!ColorForm methodsFor: 'accessing' stamp: 'ar 5/17/2001 15:45' prior: 16818750! - colors: colorList - "Set my color palette to the given collection." - - | colorArray colorCount newColors | - colorList ifNil: [ - colors _ cachedDepth _ cachedColormap _ nil. - ^ self]. - - colorArray _ colorList asArray. - colorCount _ colorArray size. - newColors _ Array new: (1 bitShift: self depth). - 1 to: newColors size do: [:i | - i <= colorCount - ifTrue: [newColors at: i put: (colorArray at: i)] - ifFalse: [newColors at: i put: Colour transparent]]. - - colors _ newColors. - cachedDepth _ nil. - cachedColormap _ nil. -! ! -!ColorForm methodsFor: 'color manipulation' stamp: 'di 11/11/1998 13:20' prior: 16818824! - asGrayScale - "Return a grayscale ColorForm computed by mapping each color into its grayscale equivalent" - ^ self copy colors: - (colors collect: - [:c | c isTransparent ifTrue: [c] - ifFalse: [Colour gray: c luminance]])! ! -!ColorForm methodsFor: 'color manipulation' stamp: 'jmv 3/1/2010 09:41' prior: 16818834! - colormapIfNeededForDepth: destDepth - "Return a colormap for displaying the receiver at the given depth, or nil if no colormap is needed." - - | newMap | - colors ifNil: [ - "use the standard colormap" - ^ Colour colorMapIfNeededFrom: self depth to: destDepth]. - - (destDepth = cachedDepth and:[cachedColormap isColormap not]) - ifTrue: [^ cachedColormap]. - newMap _ Bitmap new: colors size. - 1 to: colors size do: [:i | - newMap - at: i - put: ((colors at: i) pixelValueForDepth: destDepth)]. - - cachedDepth _ destDepth. - ^ cachedColormap _ newMap. -! ! -!ColorForm methodsFor: 'private' stamp: 'ar 5/17/2001 15:44' prior: 16818940! - ensureColorArrayExists - "Return my color palette." - - colors ifNil: [ - self depth > 8 ifTrue: [^ self error: 'ColorForms only support depths up to 8 bits']. - self colors: (Colour indexedColors copyFrom: 1 to: (1 bitShift: self depth))]. -! ! -!ColorForm class methodsFor: 'as yet unclassified' stamp: 'jmv 4/10/2015 23:20' prior: 16819047! - mappingWhiteToTransparentFrom: aFormOrCursor - "Return a ColorForm copied from the given Form or Cursor with white mapped to transparent." - - | f map | - aFormOrCursor depth <= 8 ifFalse: [ - ^ self error: 'argument depth must be 8-bits per pixel or less']. - (aFormOrCursor is: #ColorForm) ifTrue: [ - f _ aFormOrCursor copy. - map _ aFormOrCursor colors. - ] ifFalse: [ - f _ ColorForm extent: aFormOrCursor extent depth: aFormOrCursor depth. - f copyBits: aFormOrCursor boundingBox - from: aFormOrCursor - at: 0@0 - clippingBox: aFormOrCursor boundingBox - rule: Form over. - map _ Colour indexedColors copyFrom: 1 to: (1 bitShift: aFormOrCursor depth)]. - map _ map collect: [:c | - c = Colour white ifTrue: [Colour transparent] ifFalse: [c]]. - f colors: map. - ^ f -! ! -!ColorForm class methodsFor: 'instance creation' stamp: 'jmv 5/4/2016 16:31' prior: 16819074! - grayScaleAndTransparentExtent: aPoint -"Native depth" - "Answer a ColorForm for storing 8bpp gray scale. (do not include any slot for transparent)" - - | grays result | - result _ self extent: aPoint depth: (Smalltalk isLittleEndian ifTrue: [ -8 ] ifFalse: [ 8 ]). - grays _ (0 to: 255) collect: [ :brightness | Colour gray: brightness asFloat / 255.0]. - grays at: 1 put: Colour transparent. - result colors: grays. - ^result! ! -!Cursor methodsFor: 'converting' stamp: 'jmv 2/25/2011 19:47' prior: 16825855! - asCursorForm - | form | - form _ Form extent: self extent depth: 8. - form fillShape: self fillColor: Colour black at: offset negated. - ^ form offset: offset! ! -!CursorWithMask methodsFor: 'converting' stamp: 'jmv 2/25/2011 19:47' prior: 16826695! - asCursorForm - | form | - form _ Form extent: self extent depth: 8. - form fillShape: maskForm fillColor: Colour white. - form fillShape: self fillColor: Colour black at: offset negated. - ^ form offset: offset! ! -!GrayForm methodsFor: 'pixel accessing' stamp: 'jmv 5/11/2016 19:57' prior: 16850335! - grayAt: aPoint - "Return the color of the pixel at aPoint." - - ^Colour gray: (self pixelValueAt: aPoint) asFloat / 255.0! ! -!GrayForm methodsFor: 'color manipulation' stamp: 'jmv 5/12/2016 15:04' prior: 16850359! - colormapIfNeededForDepth: destDepth - "Return a colormap for displaying the receiver at the given depth, or nil if no colormap is needed." - - ^ Colour cachedColormapFromGrayTo: destDepth! ! -!BMPReadWriter methodsFor: 'reading' stamp: 'ar 10/24/2005 20:57' prior: 16781762! - readColorMap - "Read colorCount BMP color map entries from the given binary stream. Answer an array of Colors." - | colorCount colors maxLevel b g r ccStream | - colorCount := (bfOffBits - 54) // 4. - "Note: some programs (e.g. Photoshop 4.0) apparently do not set colorCount; assume that any data between the end of the header and the start of the pixel data is the color map" - biBitCount >= 16 ifTrue:[^nil]. - colorCount = 0 ifTrue: [ "this BMP file does not have a color map" - "default monochrome color map" - biBitCount = 1 ifTrue: [^ Array with: Colour white with: Colour black]. - "default gray-scale color map" - maxLevel := (2 raisedTo: biBitCount) - 1. - ^ (0 to: maxLevel) collect: [:level | Colour gray: (level asFloat / maxLevel)]]. - ccStream := ReadStream on: (stream next: colorCount*4). - colors := Array new: colorCount. - 1 to: colorCount do: [:i | - b := ccStream next. - g := ccStream next. - r := ccStream next. - ccStream next. "skip reserved" - colors at: i put: (Colour r: r g: g b: b range: 255)]. - ^ colors -! ! -!BitBlt methodsFor: 'accessing' stamp: 'jmv 3/20/2013 00:50' prior: 16785567! - fillColor - "Return the current fill color as a Color. - Gives the wrong answer if the halftoneForm is a complex pattern of more than one word." - - halftoneForm ifNil: [^ Colour black]. - ^ Colour colorFromPixelValue: halftoneForm first depth: destForm depth! ! -!BitBlt class methodsFor: 'examples' stamp: 'jmv 7/27/2015 17:07' prior: 16786237! - alphaBlendDemo - "To run this demo, use... - Display restoreAfter: [BitBlt alphaBlendDemo] - Displays 10 alphas, then lets you paint. Option-Click to stop painting." - - "This code exhibits alpha blending in any display depth by performing - the blend in an off-screen buffer with 32-bit pixels, and then copying - the result back onto the screen with an appropriate color map. - tk 3/10/97" - - "This version uses a sliding buffer for painting that keeps pixels in 32 bits - as long as they are in the buffer, so as not to lose info by converting down - to display resolution and back up to 32 bits at each operation. - di 3/15/97" - - | brush buff dispToBuff buffToDisplay mapDto32 map32toD prevP p brushToBuff theta buffRect buffSize buffToBuff brushRect delta newBuffRect updateRect | - - "compute color maps if needed" - Display depth <= 8 ifTrue: [ - mapDto32 _ Colour cachedColormapFrom: Display depth to: 32. - map32toD _ Colour cachedColormapFrom: 32 to: Display depth]. - - "display 10 different alphas, across top of screen" - buff _ Form extent: 500@50 depth: 32. - dispToBuff _ BitBlt toForm: buff. - dispToBuff colorMap: mapDto32. - dispToBuff copyFrom: (50@10 extent: 500@50) in: Display to: 0@0. - 1 to: 10 do: [:i | dispToBuff fill: (50*(i-1)@0 extent: 50@50) - fillColor: (Colour red alpha: i/10) - rule: Form blend]. - buffToDisplay _ BitBlt toForm: Display. - buffToDisplay colorMap: map32toD. - buffToDisplay copyFrom: buff boundingBox in: buff to: 50@10. - DisplayScreen screenUpdateRequired: nil. - - "Create a brush with radially varying alpha" - brush _ Form extent: 30@30 depth: 32. - 1 to: 5 do: - [:i | brush fillShape: (Form dotOfSize: brush width*(6-i)//5) - fillColor: (Colour red alpha: 0.02 * i - 0.01) - at: brush extent // 2]. - - "Now paint with the brush using alpha blending." - buffSize _ 100. - buff _ Form extent: brush extent + buffSize depth: 32. "Travelling 32-bit buffer" - dispToBuff _ BitBlt toForm: buff. "This is from Display to buff" - dispToBuff colorMap: mapDto32. - brushToBuff _ BitBlt toForm: buff. "This is from brush to buff" - brushToBuff sourceForm: brush; sourceOrigin: 0@0. - brushToBuff combinationRule: Form blend. - buffToBuff _ BitBlt toForm: buff. "This is for slewing the buffer" - - [Sensor isMouseButton2Pressed] whileFalse: - [prevP _ nil. - buffRect _ Sensor mousePoint - (buffSize // 2) extent: buff extent. - dispToBuff copyFrom: buffRect in: Display to: 0@0. - [Sensor isMouseButton1Pressed] whileTrue: - ["Here is the painting loop" - p _ Sensor mousePoint - (brush extent // 2). - (prevP == nil or: [prevP ~= p]) ifTrue: - [prevP == nil ifTrue: [prevP _ p]. - (p dist: prevP) > buffSize ifTrue: - ["Stroke too long to fit in buffer -- clip to buffer, - and next time through will do more of it" - theta _ (p-prevP) theta. - p _ ((theta cos@theta sin) * buffSize asFloat + prevP) truncated]. - brushRect _ p extent: brush extent. - (buffRect containsRect: brushRect) ifFalse: - ["Brush is out of buffer region. Scroll the buffer, - and fill vacated regions from the display" - delta _ brushRect amountToTranslateWithin: buffRect. - buffToBuff copyFrom: buff boundingBox in: buff to: delta. - newBuffRect _ buffRect translatedBy: delta negated. - newBuffRect - areasOutside: buffRect - do: [ :r | dispToBuff copyFrom: r in: Display to: r origin - newBuffRect origin ]. - buffRect _ newBuffRect]. - - "Interpolate from prevP to p..." - brushToBuff drawFrom: prevP - buffRect origin - to: p - buffRect origin - withFirstPoint: false. - - "Update (only) the altered pixels of the destination" - updateRect _ (p min: prevP) corner: (p max: prevP) + brush extent. - buffToDisplay copy: updateRect from: updateRect origin - buffRect origin in: buff. - DisplayScreen screenUpdateRequired: updateRect. - prevP _ p]]]! ! -!WarpBlt methodsFor: 'setup' stamp: 'mtf 8/14/2009 18:21' prior: 16942977! - cellSize: s - "Set the number of samples used for averaging" - cellSize := s. - cellSize = 1 ifTrue: [^ self]. - "Install the colorMap to used for mapping the averaged RGBA 32bit pixels to the - destination depth. Note that we need to install the 32->32 color map explicitly because - the VM will substitute a colorMap derived from sourceForm->destForm mapping which - is just plain wrong for <32 source and 32bit dest depth" - (destForm depth = 32 and: [sourceForm notNil] and: [sourceForm depth < 32]) - ifTrue:[colorMap := ColorMap shifts: #(0 0 0 0) masks:#(16rFF0000 16rFF00 16rFF 16rFF000000) colors: nil] - ifFalse:[colorMap := Colour colorMapIfNeededFrom: 32 to: destForm depth]. -! ! -!GrafPort methodsFor: 'text' stamp: 'jmv 6/1/2015 13:28' prior: 16850127! - displayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font color: foregroundColor - "If required, do a second pass with new rule and colorMap. - Answer last affected pixel position - Answer nil if nothing was done - " - - | answer prevRule secondPassMap sourceDepth destDepth | - - "Slight optimization when there's nothing to do." - clipHeight = 0 ifTrue: [^nil]. - clipWidth = 0 ifTrue: [^nil]. - - self installStrikeFont: font foregroundColor: (foregroundColor alpha: 1). - - "If combinationRule is rgbMul, we might need the special two-pass technique for component alpha blending. - If not, do it simply" - combinationRule = 37 "rgbMul" ifFalse: [ - ^self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font ]. - - "We need to do a second pass. The colormap set is for use in the second pass." - secondPassMap _ colorMap. - sourceDepth _ sourceForm depth. - destDepth _ destForm depth. - colorMap _ sourceDepth ~= destDepth - ifTrue: [ Colour cachedColormapFrom: sourceDepth to: destDepth ]. - answer := self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font. - colorMap := secondPassMap. - secondPassMap ifNotNil: [ - prevRule := combinationRule. - combinationRule := 20. "rgbAdd" - self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font. - combinationRule := prevRule ]. - ^answer! ! -!GrafPort methodsFor: 'private' stamp: 'jmv 5/12/2016 14:52' prior: 16850173! - cachedFontColormapFrom1BitTo: destDepth - - | map dstIndex | - CachedFontColorMaps - ifNil: [CachedFontColorMaps _ Array new: 6]. - - dstIndex _ destDepth highBit. - (CachedFontColorMaps at: dstIndex) ifNotNil: [ :m | ^ m ]. - - map _ (Colour cachedColormapFrom: 1 to: destDepth) copy. - CachedFontColorMaps at: dstIndex put: map. - ^ map! ! -!GrafPort methodsFor: 'private' stamp: 'jmv 5/12/2016 14:55' prior: 16850186! - colorConvertingMap: targetColour from: sourceDepth to: destDepth keepSubPixelAA: keepSubPix - "Note: The color converting map for sourceDepth=16 and for sourceDepth=32 are the same" - - | srcIndex dstIndex map mapsForSource mapsForSourceAndDest | - ColorConvertingMaps - ifNil: [ColorConvertingMaps _ (1 to: 6) collect: [:i | Array new: 6]]. - - srcIndex _ sourceDepth highBit. - sourceDepth > 8 ifTrue: [ srcIndex _ keepSubPix ifTrue: [5] ifFalse: [6] ]. - dstIndex _ destDepth highBit. - - mapsForSource _ ColorConvertingMaps at: srcIndex. - (mapsForSourceAndDest _ mapsForSource at: dstIndex) ifNil: [ - mapsForSourceAndDest _ mapsForSource at: dstIndex put: Dictionary new ]. - - map _ mapsForSourceAndDest at: targetColour ifAbsentPut: [ - Colour - computeColorConvertingMap: targetColour - from: sourceDepth - to: destDepth - keepSubPixelAA: keepSubPix ]. - - ^ map! ! -!GrafPort methodsFor: 'private' stamp: 'jmv 4/17/2014 16:57' prior: 16850225! - setRuleAndMapFor: sourceDepth foregroundColor: foregroundColor - - | targetColor destDepth | - destDepth _ destForm depth. - halftoneForm _ nil. "Don't use fillColor. Use a more powerful ColorMap" - - sourceDepth = 1 ifTrue: [ - self combinationRule: Form paint. - "Set up color map for a different source depth (color font)" - "Uses caching for reasonable efficiency" - colorMap _ self cachedFontColormapFrom1BitTo: destDepth. - colorMap at: 1 put: (destForm pixelValueFor: Colour transparent). - colorMap at: 2 put: (destForm pixelValueFor: foregroundColor) ] - - ifFalse: [ - "Enable subpixel rendering if requested, but never for translucent text: - This technique always draws opaque text. This could be added, by using an extra colormap for the rgbMul phase... - So far, no need arised for doing so." - (sourceDepth > 8 and: [ - Preferences subPixelRenderFonts and: [ foregroundColor = Colour black or: [ - Preferences subPixelRenderColorFonts and: [ foregroundColor isOpaque ]]]]) ifTrue: [ - destDepth > 8 ifTrue: [ - "rgbMul is equivalent to component alpha blend if text is black (only faster, hehe)" - self combinationRule: 37. "rgbMul" - colorMap _ (foregroundColor ~= Colour black or: [ - destDepth = 32 and: [ destForm ~~ Display or: [Preferences properDisplayAlphaForFonts] ]]) ifTrue: [ - "rgbMul / rgbAdd IS component alpha blend for any color of text (neat trick, eh!!)" - "This colorMap is to be used on the second pass with rule 20 (rgbAdd) - See #displayString:from:to:at:strikeFont:color:" - "Note: In 32bpp, if we want the correct alpha in the result, we need the second pass, as the destination could have transparent pixels, - and we need to add to the alpha channel" - self colorConvertingMap: foregroundColor from: sourceDepth to: destDepth keepSubPixelAA: true]] - ifFalse: [ - self combinationRule: 25. "Paint" - targetColor _ foregroundColor = Colour black ifFalse: [ foregroundColor ]. - colorMap _ self colorConvertingMap: targetColor from: sourceDepth to: destDepth keepSubPixelAA: true]] - ifFalse: [ - "Do not use rule 34 for 16bpp display. TTCFont uses it, but it builds a glyphs cache for each color used!!" - self combinationRule: (destDepth = 32 ifTrue: [34 "alphaBlendScaled"] ifFalse: [25 "Paint"]). - colorMap _ self colorConvertingMap: foregroundColor from: sourceDepth to: destDepth keepSubPixelAA: false]]! ! -!Color methodsFor: 'conversions' stamp: 'bf 4/18/2001 16:25' prior: 16815566! - makeForegroundColor - "Make a foreground color contrasting with me" - ^self luminance >= 0.5 - ifTrue: [Colour black] - ifFalse: [Colour white]! ! -!Color methodsFor: 'groups of shades' stamp: 'tk 6/18/96' prior: 16815760! - mix: color2 shades: thisMany - "Return an array of thisMany colors from self to color2. Very useful for displaying color based on a variable in your program. " - "Color showColors: (Color red mix: Colour green shades: 12)" - - | redInc greenInc blueInc rr gg bb c out | - thisMany = 1 ifTrue: [^ Array with: color2]. - redInc _ color2 red - self red / (thisMany-1). - greenInc _ color2 green - self green / (thisMany-1). - blueInc _ color2 blue - self blue / (thisMany-1). - rr _ self red. gg _ self green. bb _ self blue. - out _ (1 to: thisMany) collect: [:num | - c _ Colour r: rr g: gg b: bb. - rr _ rr + redInc. - gg _ gg + greenInc. - bb _ bb + blueInc. - c]. - out at: out size put: color2. "hide roundoff errors" - ^ out -! ! -!Color methodsFor: 'groups of shades' stamp: 'di 10/23/2000 09:45' prior: 16815785! - wheel: thisMany - "An array of thisMany colors around the color wheel starting at self and ending all the way around the hue space just before self. Array is of length thisMany. Very useful for displaying color based on a variable in your program. " - - | sat bri hue step c | - sat _ self saturation. - bri _ self brightness. - hue _ self hue. - step _ 360.0 / (thisMany max: 1). - ^ (1 to: thisMany) collect: [:num | - c _ Colour h: hue s: sat v: bri. "hue is taken mod 360" - hue _ hue + step. - c]. -" -(Color wheel: 8) withIndexDo: [:c :i | Display fill: (i*10@20 extent: 10@20) fillColor: c] -"! ! -!Color methodsFor: 'named colors' stamp: 'KenD 1/26/2013 16:33' prior: 16815842! - closestColor - "Answer the closest matching color in the colorNames dictionary" - -" - (Colour red lighter lighter) closestColour explore. -" - ^ self closestColorFrom: (Colour colorNamesDict)! ! -!Color methodsFor: 'named colors' stamp: 'KenD 1/26/2013 16:36' prior: 16815850! - closestColorAssociation - "Answer this color's closest name->color match." - -" - (Colour blue lighter lighter) closestColorAssociation explore. -" - ^ self closestAssocFrom: (Colour colorNamesDict)! ! -!Color methodsFor: 'named colors' stamp: 'KenD 1/26/2013 16:36' prior: 16815867! - closestColorName - "Answer the name symbol of the closest matching color in the colorNames dictionary" -" - (Colour red lighter lighter) closestColour name. -" - - ^ self closestNameFrom: (Colour colorNamesDict)! ! -!Color methodsFor: 'other' stamp: 'KenD 7/18/2015 20:41' prior: 16815891! - colorName - "Return this color's name, or nil if it has no name. Only returns a name if it exactly matches the named color." - - ^(Colour colorNamesDict keyAtValue: self ifAbsent: [nil]) -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:27:03' prior: 16816085! - * aNumber - "Answer this color with its RGB multiplied by the given number. " - " - (Color brown *2) display - " - ^ Colour new - setRed: (self red * aNumber min: 1.0 max: 0.0) - green: (self green * aNumber min: 1.0 max: 0.0) - blue: (self blue * aNumber min: 1.0 max: 0.0) - colorSpace: colorSpace! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:27:06' prior: 16816097! -+ aColor - "Answer this color mixed with the given color in an additive color space. " - " - (Color blue + Color green) display - " - ^ Colour new - setRed: (self red + aColor red min: 1.0 max: 0.0) - green: (self green + aColor green min: 1.0 max: 0.0) - blue: (self blue + aColor blue min: 1.0 max: 0.0) - colorSpace: colorSpace! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:27:09' prior: 16816110! -- aColor - "Answer aColor is subtracted from the given color in an additive color space. " - " - (Color white - Color red) display - " - ^ Colour new - setRed: (self red - aColor red min: 1.0 max: 0.0) - green: (self green - aColor green min: 1.0 max: 0.0) - blue: (self blue - aColor blue min: 1.0 max: 0.0) - colorSpace: colorSpace! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:27:10' prior: 16816123! - / aNumber - "Answer this color with its RGB divided by the given number. " - " - (Color red / 2) display - " - ^ Colour new - setRed: (self red / aNumber min: 1.0 max: 0.0) - green: (self green / aNumber min: 1.0 max: 0.0) - blue: (self blue / aNumber min: 1.0 max: 0.0) - colorSpace: colorSpace! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:34:18' prior: 16816135! - adjustBrightness: brightness - "Adjust the relative brightness of this color. (lowest value is 0.005 so that hue information is not lost)" - - ^ Colour - h: self hue - s: self saturation - v: (self brightness + brightness min: 1.0 max: 0.005) - alpha: self alpha! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:34:22' prior: 16816146! - adjustSaturation: saturation brightness: brightness - "Adjust the relative saturation and brightness of this color. (lowest value is 0.005 so that hue information is not lost)" - - ^ Colour - h: self hue - s: (self saturation + saturation min: 1.0 max: 0.005) - v: (self brightness + brightness min: 1.0 max: 0.005) - alpha: self alpha! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:28:01' prior: 16816159! - alpha: alphaValue - "Return a new TranslucentColor with the given amount of opacity ('alpha')." - alphaValue = 1.0 ifFalse: [ - ^ TranslucentColour new - setRed: self red - green: self green - blue: self blue - alpha: alphaValue - colorSpace: colorSpace ]! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:34:26' prior: 16816170! - alphaMixed: proportion with: aColour - "Answer this color mixed with the given color. The proportion, a number - between 0.0 and 1.0, determines what what fraction of the receiver to - use in the mix. For example, 0.9 would yield a color close to the - receiver. This method uses RGB interpolation; HSV interpolation can lead - to surprises. Mixes the alphas (for transparency) also." - - | frac1 frac2 | - frac1 _ proportion asFloat min: 1.0 max: 0.0. - frac2 _ 1.0 - frac1. - ^ Colour - r: self red * frac1 + (aColour red * frac2) - g: self green * frac1 + (aColour green * frac2) - b: self blue * frac1 + (aColour blue * frac2) - alpha: self alpha * frac1 + (aColour alpha * frac2)! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/23/2002 01:38' prior: 16816210! - blacker - - ^ self alphaMixed: 0.8333 with: Colour black -! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:54' prior: 16816214! - dansDarker - "Return a darker shade of the same color. - An attempt to do better than the current darker method. - (now obsolete, since darker has been changed to do this. -dew)" - ^ Colour h: self hue s: self saturation - v: (self brightness - 0.16 max: 0.0)! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:34:30' prior: 16816240! - mixed: proportion with: aColour - "Mix with another color and do not preserve transpareny. Only use this for extracting the RGB value and mixing it. All other callers should use instead: - aColour alphaMixed: proportion with: anotherColor - " - - | frac1 frac2 | - frac1 _ proportion asFloat min: 1.0 max: 0.0. - frac2 _ 1.0 - frac1. - ^ Colour - r: self red * frac1 + (aColour red * frac2) - g: self green * frac1 + (aColour green * frac2) - b: self blue * frac1 + (aColour blue * frac2)! ! -!Color methodsFor: 'transformations' stamp: 'dew 1/19/2002 01:29' prior: 16816258! - muchDarker - - ^ self alphaMixed: 0.5 with: Colour black -! ! -!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 12:07' prior: 16816262! - muchLighter - - ^ self alphaMixed: 0.233 with: Colour white -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:34:33' prior: 16816266! - negated - "Return an RGB inverted color" - ^Colour - r: 1.0 - self red - g: 1.0 - self green - b: 1.0 - self blue! ! -!Color methodsFor: 'transformations' stamp: 'jmv 9/10/2009 18:41' prior: 16816287! - quiteBlacker - - ^ self alphaMixed: 0.8 with: Colour black -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 9/10/2009 18:44' prior: 16816291! - quiteWhiter - - ^ self alphaMixed: 0.6 with: Colour white! ! -!Color methodsFor: 'transformations' stamp: 'dew 1/19/2002 01:25' prior: 16816304! - slightlyWhiter - - ^ self alphaMixed: 0.85 with: Colour white -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 8/23/2009 23:24' prior: 16816321! - veryMuchDarker - - ^ self alphaMixed: 0.25 with: Colour black -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 7/28/2016 15:43:04' prior: 16816326! - veryMuchLighter - - ^ self alphaMixed: 0.07 with: Colour white! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/23/2002 01:38' prior: 16816331! - whiter - - ^ self alphaMixed: 0.8333 with: Colour white -! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/2/2016 15:04' prior: 16816547! - colorFromPixelValue: p depth: d - "Convert a pixel value for the given display depth into a color." - "Details: For depths of 8 or less, the pixel value is simply looked up in a table. For greater depths, the color components are extracted and converted into a color." - "Warning: In BitBlt, a pixel with pixelValue = 0 is transparent. - Squeak usually assumes that r=g=b=0 => transparent. But this is false if we have alpha (opacity). - A color with r=g=b=0 and opacity = 255 is BLACK, not TRANSPARENT. - Squeak also answers darkest possible blue when asked for black. Again, this is not needed in 32 bits (with alpha). It is also not really needed for 16 bits as we have an extra, unused bit: 16r8000 is not zero, but rgb=0, and hence, black. - The real rule is that pixelValue=0 means transparent. - And that darkest blue must be used instead of black, but only for depths >8 and < 16 (no indexed colors, no alpha) - This method is updated to reflect that." - - | r g b alpha | - - d = 1 ifTrue: [^ self indexedColors at: (p bitAnd: 16r01) + 1]. - - "For the rest of the depths, pixelValue = 0 means transparent, and darkest blue is considered to be black." - p = 0 ifTrue: [ ^Colour transparent ]. - - d = 8 ifTrue: [^ self indexedColors at: (p bitAnd: 16rFF) + 1]. - d = 4 ifTrue: [^ self indexedColors at: (p bitAnd: 16r0F) + 1]. - d = 2 ifTrue: [^ self indexedColors at: (p bitAnd: 16r03) + 1]. - - d = 32 ifTrue: [ - "eight bits per component; 8 bits of alpha" - alpha _ p bitShift: -24. - alpha = 0 ifTrue: [ ^Colour transparent ]. - r _ (p bitShift: -16) bitAnd: 16rFF. - g _ (p bitShift: -8) bitAnd: 16rFF. - b _ p bitAnd: 16rFF. - ^alpha < 255 - ifTrue: [ (Colour r: r g: g b: b range: 255) alpha: alpha asFloat / 255.0 ] - ifFalse: [ Colour r: r g: g b: b range: 255 ]]. - - d = 16 ifTrue: [ - "five bits per component. The most significant bit, unused, allows having real black, without p being zero" - r _ (p bitShift: -10) bitAnd: 16r1F. - g _ (p bitShift: -5) bitAnd: 16r1F. - b _ p bitAnd: 16r1F. - ^ Colour r: r g: g b: b range: 31]. - - d = 15 ifTrue: [ - "five bits per component" - r _ (p bitShift: -10) bitAnd: 16r1F. - g _ (p bitShift: -5) bitAnd: 16r1F. - b _ p bitAnd: 16r1F. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Colour black ]. - ^ Colour r: r g: g b: b range: 31]. - - d = 12 ifTrue: [ - "four bits per component" - r _ (p bitShift: -8) bitAnd: 16rF. - g _ (p bitShift: -4) bitAnd: 16rF. - b _ p bitAnd: 16rF. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Colour black ]. - ^ Colour r: r g: g b: b range: 15]. - - d = 9 ifTrue: [ - "three bits per component" - r _ (p bitShift: -6) bitAnd: 16r7. - g _ (p bitShift: -3) bitAnd: 16r7. - b _ p bitAnd: 16r7. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Colour black ]. - ^ Colour r: r g: g b: b range: 7]. - - self error: 'unknown pixel depth: ', d printString! ! -!Color class methodsFor: 'class initialization' stamp: '' prior: 16816881! -initializeIndexedColors - "Build an array of colors corresponding to the fixed colormap used - for display depths of 1, 2, 4, or 8 bits." - "Colour initializeIndexedColors" - - | a index grayVal | - a _ Array new: 256. - - "1-bit colors (monochrome)" - a at: 1 put: (Colour r: 1.0 g: 1.0 b: 1.0). "white or transparent" - a at: 2 put: (Colour r: 0.0 g: 0.0 b: 0.0). "black" - - "additional colors for 2-bit color" - a at: 3 put: (Colour r: 1.0 g: 1.0 b: 1.0). "opaque white" - a at: 4 put: (Colour r: 0.5 g: 0.5 b: 0.5). "1/2 gray" - - "additional colors for 4-bit color" - a at: 5 put: (Colour r: 1.0 g: 0.0 b: 0.0). "red" - a at: 6 put: (Colour r: 0.0 g: 1.0 b: 0.0). "green" - a at: 7 put: (Colour r: 0.0 g: 0.0 b: 1.0). "blue" - a at: 8 put: (Colour r: 0.0 g: 1.0 b: 1.0). "cyan" - a at: 9 put: (Colour r: 1.0 g: 1.0 b: 0.0). "yellow" - a at: 10 put: (Colour r: 1.0 g: 0.0 b: 1.0). "magenta" - - a at: 11 put: (Colour r: 0.125 g: 0.125 b: 0.125). "1/8 gray" - a at: 12 put: (Colour r: 0.25 g: 0.25 b: 0.25). "2/8 gray" - a at: 13 put: (Colour r: 0.375 g: 0.375 b: 0.375). "3/8 gray" - a at: 14 put: (Colour r: 0.625 g: 0.625 b: 0.625). "5/8 gray" - a at: 15 put: (Colour r: 0.75 g: 0.75 b: 0.75). "6/8 gray" - a at: 16 put: (Colour r: 0.875 g: 0.875 b: 0.875). "7/8 gray" - - "additional colors for 8-bit color" - "24 more shades of gray (1/32 increments but not repeating 1/8 increments)" - index _ 17. - 1 to: 31 do: [:v | - (v \\ 4) = 0 ifFalse: [ - grayVal _ v / 32.0. - a at: index put: (Colour r: grayVal g: grayVal b: grayVal). - index _ index + 1]]. - - "The remainder of color table defines a color cube with six steps - for each primary color. Note that the corners of this cube repeat - previous colors, but this simplifies the mapping between RGB colors - and color map indices. This color cube spans indices 40 through 255 - (indices 41-256 in this 1-based array)." - 0 to: 5 do: [:r | - 0 to: 5 do: [:g | - 0 to: 5 do: [:b | - index _ 41 + ((36 * r) + (6 * b) + g). - index > 256 ifTrue: [ - self error: 'index out of range in color table compuation']. - a at: index put: (Colour r: r g: g b: b range: 5)]]]. - - IndexedColors _ a. -! ! -!Color class methodsFor: 'examples' stamp: 'jmv 8/17/2012 18:48' prior: 16816950! - colorRampForDepth: depth extent: aPoint - "Returns a form of the given size showing R, G, B, and gray ramps for the given depth. Useful for testing color conversions between different depths." - "(Colour colorRampForDepth: Display depth extent: 256@80) display" - "(Colour colorRampForDepth: 32 extent: 256@80) displayOn: Display at: 0@0 rule: Form paint" - - | f dx dy r | - f _ Form extent: aPoint depth: depth. - dx _ aPoint x // 256. - dy _ aPoint y // 4. - 0 to: 255 do: [:i | - r _ (dx * i)@0 extent: dx@dy. - f fill: r fillColor: (Colour r: i g: 0 b: 0 range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Colour r: 0 g: i b: 0 range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Colour r: 0 g: 0 b: i range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Colour r: i g: i b: i range: 255)]. - ^ f -! ! -!Color class methodsFor: 'examples' stamp: 'jmv 6/18/2017 21:30:09' prior: 16816978! - experimentsTowarsANewColorPalette -" -self experimentsTowarsANewColorPalette -" -| selectedHue selectedSaturation selectedV selectedColor h s v color width height selectedChroma selectedLuminance | -width _ 300. -height _ 120. -selectedColor _ Colour random. -selectedHue _ selectedColor hue. -selectedSaturation _ selectedColor saturation. -selectedChroma _ selectedColor chroma. -selectedV _ selectedColor brightness. -selectedLuminance _ selectedColor luminance. -Display getCanvas fillRectangle: (0@0 extent: height@height) color: selectedColor. -0 to: height do: [ :y | - v _ 1.0 - (y / height). - 0 to: height do: [ :x | - s _ x / height. - color _ Colour new setHue: selectedHue saturation: s brightness: v. - Display colorAt: x@(y+height) put: color - ]. - DisplayScreen screenUpdateRequired: nil -]. -0 to: height do: [ :y | | c | - v _ 1.0 - (y / height). - s _ 1.0 - (y / height). - c _ s. - 0 to: width do: [ :x | - h _ x / width * 360. - - color _ Colour new setHue: h chroma: c luminance: selectedLuminance. -" color _ Colour new setHue: h chroma: c brightness: selectedV." - color ifNil: [ color _ Colour black ]. -" color _ Colour new setHue: h saturation: s brightness: selectedV." - Display colorAt: x+height@y put: color. - - color _ Colour new setHue: h chroma: selectedChroma luminance: v. -" color _ Colour new setHue: h chroma: selectedChroma brightness: v." - color ifNil: [ color _ Colour black ]. -" color _ Colour new setHue: h saturation: selectedSaturation brightness: v." - Display colorAt: x+height@(y+height) put: color. - - ]. - DisplayScreen screenUpdateRequired: nil -].! ! -!Color class methodsFor: 'examples' stamp: '' prior: 16817055! - showColorCube - "Show a 12x12x12 color cube." - "Colour showColorCube" - - 0 to: 11 do: [:r | - 0 to: 11 do: [:g | - 0 to: 11 do: [:b | - Display fill: (((r*60) + (b*5)) @ (g*5) extent: 5@5) - fillColor: (Colour r: r g: g b: b range: 11)]]]. -! ! -!Color class methodsFor: 'examples' stamp: '' prior: 16817075! - showHSVPalettes - "Shows a palette of hues, varying the saturation and brightness for each one. Best results are with depths 16 and 32." - "Color showHSVPalettes" - - | left top c | - left _ top _ 0. - 0 to: 179 by: 15 do: [:h | - 0 to: 10 do: [:s | - left _ (h * 4) + (s * 4). - 0 to: 10 do: [:v | - c _ Colour h: h s: s asFloat / 10.0 v: v asFloat / 10.0. - top _ (v * 4). - Display fill: (left@top extent: 4@4) fillColor: c. - - c _ Colour h: h + 180 s: s asFloat / 10.0 v: v asFloat / 10.0. - top _ (v * 4) + 50. - Display fill: (left@top extent: 4@4) fillColor: c]]]. -! ! -!Color class methodsFor: 'examples' stamp: '' prior: 16817112! - wheel: thisMany - "Return a collection of thisMany colors evenly spaced around the color wheel." - "Color showColors: (Color wheel: 12)" - - ^ Colour wheel: thisMany saturation: 0.9 brightness: 0.7 -! ! -!Color class methodsFor: 'examples' stamp: '' prior: 16817120! - wheel: thisMany saturation: s brightness: v - "Return a collection of thisMany colors evenly spaced around the color wheel, all of the given saturation and brightness." - "Colour showColors: (Colour wheel: 12 saturation: 0.4 brightness: 1.0)" - "Colour showColors: (Colour wheel: 12 saturation: 0.8 brightness: 0.5)" - - ^ (Colour h: 0.0 s: s v: v) wheel: thisMany -! ! -!Color class methodsFor: 'colormaps' stamp: '' prior: 16817522! - colorMapIfNeededFrom: sourceDepth to: destDepth - "Return a colormap for mapping between the given depths, or nil if no colormap is needed." - "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" - - sourceDepth = destDepth ifTrue: [^ nil]. "not needed if depths are the same" - - (sourceDepth >= 16) & (destDepth >= 16) ifTrue: [ - "mapping is done in BitBlt by zero-filling or truncating each color component" - ^ nil]. - - ^ Colour cachedColormapFrom: sourceDepth to: destDepth -! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 5/12/2016 15:56' prior: 16817637! - computeColormapFromGray8bppForDepth: destDepth - "Return a colormap for displaying a GrayForm at the given depth" - - | newMap | - newMap _ Bitmap new: 256. - 1 to: 256 do: [ :i | - newMap - at: i - put: ((Colour gray: (i-1) asFloat / 255.0) pixelValueForDepth: destDepth)]. - ^ newMap! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 4/17/2015 15:05' prior: 16817648! - computeIndexedColorConvertingMap: targetColor from: sourceDepth to: destDepth - | map | - - map _ (self indexedColors copyFrom: 1 to: (1 bitShift: sourceDepth)) collect: [ :cc | | f c | - f _ 1.0 - (cc red + cc green + cc blue / 3.0 ). - c _ targetColor - ifNotNil: [ - destDepth = 32 - ifTrue: [ targetColor * f alpha: f] - ifFalse: [ targetColor alphaMixed: f*1.5 with: Colour white ]] - ifNil: [ cc ]. - destDepth = 32 - ifTrue: [ c pixelValueForDepth: destDepth] - ifFalse: [ - f = 0.0 - ifTrue: [ 0 ] - ifFalse: [ c pixelValueForDepth: destDepth ]]]. - map _ map as: Bitmap. - ^map! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 21:34:38' prior: 16817670! - computeRGBColorConvertingMap: targetColour to: destDepth keepSubPixelAA: keepSubPix - "Builds a colormap intended to convert from subpixelAA black values to targetColour values. - keepSubPix - ifTrue: [ Answer colors that also include subpixelAA ] - ifFalse: [ - Take fullpixel luminance level. Apply it to targetColor. - I.e. answer colors with NO subpixelAA ]" - - | mask map c bitsPerColour r g b f v | - - destDepth > 8 - ifTrue: [bitsPerColour _ 5] "retain maximum color resolution" - ifFalse: [bitsPerColour _ 4]. - "Usually a bit less is enough, but make it configurable" - bitsPerColour _ bitsPerColour min: Preferences aaFontsColormapDepth. - mask _ (1 bitShift: bitsPerColour) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColour)). - 0 to: map size - 1 do: [:i | - r _ (i bitShift: 0 - (2 * bitsPerColour)) bitAnd: mask. - g _ (i bitShift: 0 - bitsPerColour) bitAnd: mask. - b _ (i bitShift: 0) bitAnd: mask. - f _ 1.0 - (r + g + b / 3.0 / mask). - c _ targetColour - ifNotNil: [ - (keepSubPix and: [destDepth > 8]) ifTrue: [ - Colour - r: 1.0 - (r asFloat/mask) * targetColour red - g: 1.0 - (g asFloat/mask) * targetColour green - b: 1.0 - (b asFloat/mask) * targetColour blue - alpha: f * targetColour alpha "alpha will be ignored below, in #pixelValueForDepth: if destDepth ~= 32" ] - ifFalse: [ - destDepth = 32 - ifTrue: [ targetColour * f alpha: f * targetColour alpha ] - ifFalse: [ targetColour alphaMixed: f*1.5 with: Colour white ]]] - ifNil: [ Colour r: r g: g b: b range: mask]. "This is currently used only to keep some SubPixelAA on destDepth = 8, using a single pass of rule 25" - v _ destDepth = 32 - ifTrue: [ c pixelValueForDepth: destDepth] - ifFalse: [ - f < 0.1 - ifTrue: [ 0 ] - ifFalse: [ c pixelValueForDepth: destDepth ]]. - map at: i + 1 put: v ]. - ^ map! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 21:34:42' prior: 16817730! - computeRGBColormapFor: destDepth bitsPerColor: bitsPerColor - "Compute a colorMap for translating from 16-bit or 32-bit RGB color to the given depth, using the given number of of bits per color component." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Colour maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | mask map c | - (#(3 4 5) includes: bitsPerColor) - ifFalse: [self error: 'BitBlt only supports 3, 4, or 5 bits per color component']. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - c _ Colour - r: ((i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask) - g: ((i bitShift: 0 - bitsPerColor) bitAnd: mask) - b: ((i bitShift: 0) bitAnd: mask) - range: mask. - map at: i + 1 put: (c pixelValueForDepth: destDepth)]. - - map at: 1 put: (Colour transparent pixelWordForDepth: destDepth). "zero always transparent" - ^ map -! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 21:34:46' prior: 16817772! - computeRGBColormapForGray8 - "Compute a colorMap for translating from 16-bit or 32-bit RGB color to 8bpp grays, using the default number of of bits per color component." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Colour maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | bitsPerColor mask map c | - bitsPerColor _ 5. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - c _ Colour - r: ((i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask) - g: ((i bitShift: 0 - bitsPerColor) bitAnd: mask) - b: ((i bitShift: 0) bitAnd: mask) - range: mask. - map at: i + 1 put: (c luminance * 255) rounded]. - - ^ map! ! -!Color class methodsFor: 'color from user' stamp: 'jmv 3/1/2010 15:13' prior: 16817838! - colorPaletteForDepth: depth extent: chartExtent - "Display a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." - "Note: It is slow to build this palette, so it should be cached for quick access." - "(Color colorPaletteForDepth: 16 extent: 190@60) display" - - | basicHue x y startHue palette transHt vSteps transCaption grayWidth hSteps | - palette _ Form extent: chartExtent depth: depth. - transCaption _ - (Form extent: 34@9 depth: 1 - fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0) - offset: 0@0). - transHt _ transCaption height. - palette fillWhite: (0@0 extent: palette width@transHt). - palette fillBlack: (0@transHt extent: palette width@1). - transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0). - grayWidth _ 10. - startHue _ 338.0. - vSteps _ palette height - transHt // 2. - hSteps _ palette width - grayWidth. - x _ 0. - startHue to: startHue + 360.0 by: 360.0/hSteps do: [ :h | - basicHue _ Colour h: h asFloat s: 1.0 v: 1.0. - y _ transHt+1. - 0 to: vSteps do: [ :n | | c | - c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Colour white. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - 1 to: vSteps do: [ :n | | c | - c _ Colour black mixed: (n asFloat / vSteps asFloat) with: basicHue. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - x _ x + 1]. - y _ transHt + 1. - 1 to: vSteps * 2 do: [ :n | | c | - c _ Colour black mixed: (n asFloat / (vSteps*2) asFloat) with: Colour white. - palette fill: (x@y extent: 10@1) fillColor: c. - y _ y + 1]. - ^ palette -! ! -!Color class methodsFor: 'color from user' stamp: 'jmv 7/27/2009 11:32' prior: 16817895! - colorTest: depth extent: chartExtent colorMapper: colorMapper - "Create a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." - "Note: It is slow to build this palette, so it should be cached for quick access." - "(Color colorTest: 32 extent: 570@180 colorMapper: [:c | c]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 7) asInteger / 7 - g: (c green * 7) asInteger / 7 - b: (c blue * 3) asInteger / 3]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 5) asInteger / 5 - g: (c green * 5) asInteger / 5 - b: (c blue * 5) asInteger / 5]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 15) asInteger / 15 - g: (c green * 15) asInteger / 15 - b: (c blue * 15) asInteger / 15]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 31) asInteger / 31 - g: (c green * 31) asInteger / 31 - b: (c blue * 31) asInteger / 31]) display" - - | basicHue x y c startHue palette transHt vSteps transCaption grayWidth hSteps | - palette _ Form extent: chartExtent depth: depth. - transCaption _ - (Form extent: 34@9 depth: 1 - fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0) - offset: 0@0). - transHt _ transCaption height. - palette fillWhite: (0@0 extent: palette width@transHt). - palette fillBlack: (0@transHt extent: palette width@1). - transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0). - grayWidth _ 10. - startHue _ 338.0. - vSteps _ palette height - transHt // 2. - hSteps _ palette width - grayWidth. - x _ 0. - startHue to: startHue + 360.0 by: 360.0/hSteps do: [:h | - basicHue _ Colour h: h asFloat s: 1.0 v: 1.0. - y _ transHt+1. - 0 to: vSteps do: [:n | - c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Colour white. - c _ colorMapper value: c. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - 1 to: vSteps do: [:n | - c _ Colour black mixed: (n asFloat / vSteps asFloat) with: basicHue. - c _ colorMapper value: c. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - x _ x + 1]. - y _ transHt + 1. - 1 to: vSteps * 2 do: [:n | - c _ Colour black mixed: (n asFloat / (vSteps*2) asFloat) with: Colour white. - c _ colorMapper value: c. - palette fill: (x@y extent: 10@1) fillColor: c. - y _ y + 1]. - ^ palette -! ! -!Color class methodsFor: 'color name lookup' stamp: 'KenD 1/28/2013 20:34' prior: 16817983! - defaultColorNamesDictionary - "Answer a amall but useful name->color dictionary" - - | defaultDict | - "Meld most used xkcd colors into traditional colors." - defaultDict := (self traditionalColorNamesDictionary addAll: - self xkcdFirst48ColorNamesDictionary; - yourself). - - "Override traditional names existing in extended XKCD naming" - defaultDict at: #lightYellow put: (Colour r: 1.0 g: 0.996 b: 0.478). - defaultDict at: #lightOrange put: (Colour r: 0.992 g: 0.667 b: 0.283). - defaultDict at: #lightCyan put: (Colour r: 0.674 g: 1.0 b: 0.988). - defaultDict at: #lightRed put: (Colour r: 1.0 g: 0.279 b: 0.298). - defaultDict at: #lightMagenta put: (Colour r: 0.98 g: 0.372 b: 0.969). - - ^defaultDict! ! -!Color class methodsFor: 'color name lookup' stamp: 'KenD 2/1/2013 14:39' prior: 16818009! - doesNotUnderstand: aMessage - "Some code takes - Colour colorNames - and does - Colour perform: aColorname. - - Make this work." - - ^(Colour colorNamesDict) - at: (aMessage selector) - ifAbsent: [super doesNotUnderstand: aMessage]! ! -!Color class methodsFor: 'color name lookup' stamp: 'KenD 7/25/2014 21:22' prior: 16818027! - setColorNamesDict: aNameColorDictionary - "Answer the current dictionary of name->color associations." - - "Note: This is a non-standard name because this is a non-standard action!! - Do this if you really, really know what you are doing." - - "Some Colors are required for proper system operation" - Colour defaultColorNamesDictionary keysAndValuesDo: [ :colorName :colorValue | - aNameColorDictionary at: colorName ifAbsentPut: colorValue - ]. - - ColorNamesDict := aNameColorDictionary! ! -!Color class methodsFor: 'color name lookup' stamp: 'sqr 10/21/2016 12:44:48' prior: 16818045! - traditionalColorNamesDictionary - "Answer a dictionary of Squeak traditional name->color associations.." - - | nameDict | - nameDict _ Dictionary new. - nameDict at: #black put: (Colour r: 0 g: 0 b: 0). - nameDict at: #veryVeryDarkGray put: (Colour r: 0.125 g: 0.125 b: 0.125). - nameDict at: #veryDarkGray put: (Colour r: 0.25 g: 0.25 b: 0.25). - nameDict at: #darkGray put: (Colour r: 0.375 g: 0.375 b: 0.375). - nameDict at: #gray put: (Colour r: 0.5 g: 0.5 b: 0.5). - nameDict at: #lightGray put: (Colour r: 0.625 g: 0.625 b: 0.625). - nameDict at: #veryLightGray put: (Colour r: 0.75 g: 0.75 b: 0.75). - nameDict at: #veryVeryLightGray put: (Colour r: 0.875 g: 0.875 b: 0.875). - nameDict at: #white put: (Colour r: 1.0 g: 1.0 b: 1.0). - nameDict at: #red put: (Colour r: 1.0 g: 0 b: 0). - nameDict at: #yellow put: (Colour r: 1.0 g: 1.0 b: 0). - nameDict at: #green put: (Colour r: 0 g: 1.0 b: 0). - nameDict at: #cyan put: (Colour r: 0 g: 1.0 b: 1.0). - nameDict at: #blue put: (Colour r: 0 g: 0 b: 1.0). - nameDict at: #magenta put: (Colour r: 1.0 g: 0 b: 1.0). - nameDict at: #brown put: (Colour r: 0.6 g: 0.2 b: 0). - nameDict at: #orange put: (Colour r: 1.0 g: 0.6 b: 0). - nameDict at: #lightRed put: (Colour r: 1.0 g: 0.8 b: 0.8). - nameDict at: #lightYellow put: (Colour r: 1.0 g: 1.0 b: 0.8). - nameDict at: #lightGreen put: (Colour r: 0.8 g: 1.0 b: 0.6). - nameDict at: #lightCyan put: (Colour r: 0.4 g: 1.0 b: 1.0). - nameDict at: #lightBlue put: (Colour r: 0.8 g: 1.0 b: 1.0). - nameDict at: #lightMagenta put: (Colour r: 1.0 g: 0.8 b: 1.0). - nameDict at: #lightBrown put: (Colour r: 1.0 g: 0.6 b: 0.2). - nameDict at: #lightOrange put: (Colour r: 1.0 g: 0.8 b: 0.4). - nameDict at: #transparent put: (TranslucentColour r: 0.0 g: 0.0 b: 0.0 alpha: 0.0). - - ^nameDict -! ! -!Color class methodsFor: 'color name lookup' stamp: 'jmv 6/30/2014 15:22' prior: 16818102! - xkcdFirst48ColorNamesDictionary - "XKCD color names are based on a survey oc colors people call by the same name. - http://blog.xkcd.com/2010/05/03/color-survey-results/" - - "Answer a dictionary of the most agreed upon first 48 xkcd colors" -" - Colour xkcdFirst48ColorNamesDictionary explore. -" - | xkcdDict | - xkcdDict := Dictionary new - at: #lightPink put: (Colour fromString: '#ffd1df') ; - at: #mustard put: (Colour fromString: '#ceb301') ; - at: #indigo put: (Colour fromString: '#380282') ; - at: #lime put: (Colour fromString: '#aaff32') ; - at: #seaGreen put: (Colour fromString: '#53fca1') ; - at: #periwinkle put: (Colour fromString: '#8e82fe') ; - at: #darkPink put: (Colour fromString: '#cb416b') ; - at: #oliveGreen put: (Colour fromString: '#677a04') ; - at: #peach put: (Colour fromString: '#ffb07c') ; - at: #paleGreen put: (Colour fromString: '#c7fdb5') ; - at: #lightBrown put: (Colour fromString: '#ad8150') ; - at: #hotPink put: (Colour fromString: '#ff028d') ; - at: #black put: (Colour fromString: '#000000') ; - at: #lilac put: (Colour fromString: '#cea2fd') ; - at: #navyBlue put: (Colour fromString: '#001146') ; - at: #royalBlue put: (Colour fromString: '#0504aa') ; - at: #beige put: (Colour fromString: '#e6daa6') ; - at: #salmon put: (Colour fromString: '#ff796c') ; - at: #olive put: (Colour fromString: '#6e750e') ; - at: #maroon put: (Colour fromString: '#650021') ; - at: #brightGreen put: (Colour fromString: '#01ff07') ; - at: #darkPurple put: (Colour fromString: '#35063e') ; - at: #mauve put: (Colour fromString: '#ae7181') ; - at: #forestGreen put: (Colour fromString: '#06470c') ; - at: #aqua put: (Colour fromString: '#13eac9') ; - at: #cyan put: (Colour fromString: '#00ffff') ; - at: #tan put: (Colour fromString: '#d1b26f') ; - at: #darkBlue put: (Colour fromString: '#00035b') ; - at: #lavender put: (Colour fromString: '#c79fef') ; - at: #turquoise put: (Colour fromString: '#06c2ac') ; - at: #darkGreen put: (Colour fromString: '#033500') ; - at: #violet put: (Colour fromString: '#9a0eea') ; - at: #lightPurple put: (Colour fromString: '#bf77f6') ; - at: #limeGreen put: (Colour fromString: '#89fe05') ; - at: #grey put: (Colour fromString: '#929591') ; - at: #skyBlue put: (Colour fromString: '#75bbfd') ; - at: #yellow put: (Colour fromString: '#ffff14') ; - at: #magenta put: (Colour fromString: '#c20078') ; - at: #lightGreen put: (Colour fromString: '#96f97b') ; - at: #orange put: (Colour fromString: '#f97306') ; - at: #teal put: (Colour fromString: '#029386') ; - at: #lightBlue put: (Colour fromString: '#95d0fc') ; - at: #red put: (Colour fromString: '#e50000') ; - at: #brown put: (Colour fromString: '#653700') ; - at: #pink put: (Colour fromString: '#ff81c0') ; - at: #blue put: (Colour fromString: '#0343df') ; - at: #green put: (Colour fromString: '#15b01a') ; - at: #purple put: (Colour fromString: '#7e1e9c') ; - yourself. - - ^xkcdDict - -! ! -!TranslucentColor methodsFor: 'conversions' stamp: 'jmv 6/18/2017 21:28:31' prior: 16939024! - alpha: alphaValue - "Return a new TranslucentColor with the given amount of opacity ('alpha')." - alphaValue = 1.0 ifTrue: [ - ^ Colour new - setRed: self red - green: self green - blue: self blue - colorSpace: colorSpace]. - ^ super alpha: alphaValue! ! -!Rectangle methodsFor: 'transforming' stamp: 'jmv 9/24/2013 22:36' prior: 16898974! - newRectFrom: newRectBlock - "Track the outline of a new rectangle until mouse button changes. - newFrameBlock produces each new rectangle from the previous" - | rect newRect buttonStart buttonNow aHand delay | - delay _ Delay forMilliseconds: 10. - buttonStart _ buttonNow _ Sensor isAnyButtonPressed. - rect _ self. - Display border: rect width: 2 rule: Form reverse fillColor: Colour gray. - [buttonNow == buttonStart] whileTrue: - [delay wait. - buttonNow _ Sensor isAnyButtonPressed. - newRect _ newRectBlock value: rect. - newRect = rect ifFalse: - [Display border: rect width: 2 rule: Form reverse fillColor: Colour gray. - Display border: newRect width: 2 rule: Form reverse fillColor: Colour gray. - rect _ newRect]]. - Display border: rect width: 2 rule: Form reverse fillColor: Colour gray. - " pay the price for reading the sensor directly ; get this party started " - aHand _ self runningWorld activeHand. - aHand - newMouseFocus: nil; - flushEvents. - Sensor processSensorEvent: Sensor createMouseEvent discardingMouseEvents: false. - ^ rect! ! -!StrikeFont methodsFor: 'emphasis' stamp: 'jmv 4/10/2015 23:21' prior: 16914485! - makeBoldGlyphs - "Make a bold set of glyphs with same widths by ORing 1 bit to the right - (requires at least 1 pixel of intercharacter space)" - | g bonkForm | - g _ glyphs copy. - bonkForm _ (Form extent: 1@16) fillBlack offset: -1@0. - self bonk: g with: bonkForm. - glyphs depth = 1 ifTrue: [ - g copyBits: g boundingBox from: g at: (1@0) - clippingBox: g boundingBox rule: Form under ] - ifFalse: [ - 0 to: g width - 2 do: [ :x | 0 to: g height-1 do: [ :y | - (glyphs colorAt: x@y) = Colour white ifFalse: [ - g colorAt: x+1@y put: - ((glyphs colorAt: x+1@y) = Colour white - ifTrue: [glyphs colorAt: x@y] - ifFalse: [Colour black])]]]]. - glyphs _ g. - self isSynthetic: true! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 9/2/2016 11:03:22' prior: 16914725! - makeControlCharsVisible - | glyph | - self characterToGlyphMap. - glyph _ self glyphAt: (Character space). - glyph border: glyph boundingBox width: 1 fillColor: Colour blue. - self glyphAt: (Character numericValue: 134) put: glyph. - - "Keep tab(9), lf(10), cr(13) and space(32) transparent or whatever the user chose" - #(0 1 2 3 4 5 6 7 8 11 12 14 15 16 17 18 19 20 21 22 23 24 25 26 27) - do: [ :ascii | - characterToGlyphMap at: ascii + 1 put: 134 ]! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 9/2/2016 11:03:27' prior: 16914749! - makeCrVisible - | glyph | - self characterToGlyphMap. - glyph _ self glyphAt: (Character numericValue: 182). - glyph border: glyph boundingBox width: 1 fillColor: Colour blue. -" glyph _ glyph reverse." - self glyphAt: (Character numericValue: 133) put: glyph. - characterToGlyphMap at: 14 put: 133! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 9/2/2016 11:03:31' prior: 16914768! - makeLfVisible - | glyph | - self characterToGlyphMap. - glyph _ self glyphAt: (Character numericValue: 163). - glyph border: glyph boundingBox width: 1 fillColor: Colour blue. -" glyph _ glyph reverse." - self glyphAt: (Character numericValue: 132) put: glyph. - characterToGlyphMap at: 11 put: 132! ! -!Morph methodsFor: 'accessing' stamp: 'jmv 8/21/2012 20:40' prior: 16873946! - color - - ^ Colour blue! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 4/14/2015 08:53' prior: 16874298! - drawOn: aCanvas - "A canvas is already set with a proper transformation from our coordinates to those of the Canvas target." - aCanvas - fillRectangle: self morphLocalBounds - color: Colour blue! ! -!RectangleLikeMorph methodsFor: 'initialization' stamp: 'jmv 8/21/2012 18:46' prior: 16899196! - defaultColor - ^ Colour orange! ! -!BorderedRectMorph methodsFor: 'initialization' stamp: 'jmv 8/17/2014 21:28' prior: 16790410! - defaultBorderColor - "answer the default border color/fill style for the receiver" - ^ Colour gray! ! -!PasteUpMorph methodsFor: 'initialization' stamp: 'jmv 6/18/2017 21:33:36' prior: 16887268! -defaultBorderColor - "answer the default border color/fill style for the receiver" - ^ Colour - r: 0.861 - g: 1.0 - b: 0.722! ! -!PasteUpMorph methodsFor: 'initialization' stamp: 'jmv 6/18/2017 21:33:40' prior: 16887280! - defaultColor - "answer the default color/fill style for the receiver" - ^ Colour - r: 0.8 - g: 1.0 - b: 0.6! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 11/10/2013 19:32' prior: 16887655! - findWindow: evt - "Present a menu names of windows and naked morphs, and activate the one that gets chosen. Collapsed windows appear below line, expand if chosen; naked morphs appear below second line; if any of them has been given an explicit name, that is what's shown, else the class-name of the morph shows; if a naked morph is chosen, bring it to front and have it don a halo." - | menu expanded collapsed nakedMorphs | - menu _ MenuMorph new. - expanded _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed not ]. - collapsed _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed ]. - nakedMorphs _ self submorphsSatisfying: [ :m | - (m is: #SystemWindow) not ]. - expanded isEmpty & (collapsed isEmpty & nakedMorphs isEmpty) ifTrue: [ ^ Smalltalk beep ]. - (expanded asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #activateAndForceLabelToShow. - w canDiscardEdits ifFalse: [ menu lastItem color: Colour red ]]. - expanded isEmpty | (collapsed isEmpty & nakedMorphs isEmpty) ifFalse: [ menu addLine ]. - (collapsed asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #expand. - w canDiscardEdits ifFalse: [ menu lastItem color: Colour red ]]. - nakedMorphs isEmpty ifFalse: [ menu addLine ]. - (nakedMorphs asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #comeToFrontAndAddHalo ]. - menu addTitle: 'find window'. - menu popUpInWorld: self! ! -!EllipseMorph methodsFor: 'visual properties' stamp: 'ar 6/25/1999 11:14' prior: 16837113! - defaultColor - "Return the default fill style for the receiver" - ^Colour yellow! ! -!PluggableMorph methodsFor: 'initialization' stamp: 'jmv 8/6/2014 09:15' prior: 16889451! - defaultColor - "answer the default color/fill style for the receiver" - ^ Colour lightGray! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 9/9/2012 23:50' prior: 16888164! - drawRoundGradientLookOn: aCanvas - | r colorForButton rect bottomFactor topFactor | - - self isPressed - ifFalse: [ - topFactor _ Theme current buttonGradientTopFactor. - bottomFactor _ Theme current buttonGradientBottomFactor. - self mouseIsOver - ifTrue: [ - colorForButton _ Colour h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ - colorForButton _ color ]] - ifTrue: [ - topFactor _ Theme current buttonGradientBottomFactor. - bottomFactor _ Theme current buttonGradientTopFactor. - colorForButton _ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - Theme current useButtonGradient - ifTrue: [ - rect _ (0@0 extent: extent) insetBy: 1@3. - aCanvas - roundRect: rect - color: colorForButton - radius: r - gradientTop: topFactor - gradientBottom: bottomFactor - gradientHeight: Theme current buttonGradientHeight ] - ifFalse: [ - rect _ (0@0 extent: extent) insetBy: 1@3. - aCanvas roundRect: rect color: colorForButton radius: r ] - ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawEmbossedLabelOn: aCanvas ] - ifFalse: [ self drawRegularLabelOn: aCanvas ]! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 4/12/2012 22:37' prior: 16888215! - iconColor - - ^ self isPressed - ifTrue: [ Colour gray: 0.75 ] - ifFalse: [ - self mouseIsOver - ifTrue: [ Colour gray: 0.75 ] - ifFalse: [ Colour white ]].! ! -!PluggableButtonMorph class methodsFor: 'example' stamp: 'jmv 1/4/2013 13:31' prior: 16888484! - example - " - PluggableButtonMorph example openInWorld - " - - | s1 s2 s3 b1 b2 b3 row | - s1 _ Switch new. - s2 _ Switch new turnOn. - s3 _ Switch new. - s2 onAction: [s3 turnOff]. - s3 onAction: [s2 turnOff]. - b1 _ (PluggableButtonMorph model: s1 stateGetter: #isOn action: #switch) label: 'S1'. - b2 _ (PluggableButtonMorph model: s2 stateGetter: #isOn action: #turnOn) label: 'S2'. - b3 _ (PluggableButtonMorph model: s3 stateGetter: #isOn action: #turnOn) label: 'S3'. - b1 color: Colour lightRed. - b2 color: Colour lightRed. - b3 color: Colour lightRed. - row _ LayoutMorph newRow - addMorphs: (Array with: b1 with: b2 with: b3); - morphExtent: 120@35. - ^ row -! ! -!TextModelMorph methodsFor: 'drawing' stamp: 'cbr 10/10/2012 23:04' prior: 16933987! - drawOn: aCanvas - "Include a thin red inset border for unaccepted edits, or, if the unaccepted edits are known to conflict with a change made somewhere else to the same method (typically), put a thick red frame" - - - | bw bc | - - self flag: #todo. "Integrate this method with the Theme system. --cbr" - - - super drawOn: aCanvas. - bw _ Preferences focusIndicatorWidth. - bc _ nil. - self wantsFrameAdornments ifTrue: [ - model refusesToAccept - ifTrue: [ "Put up feedback showing that code cannot be submitted in this state" - bc _ Colour tan] - ifFalse: [ - self textMorph hasEditingConflicts - ifTrue: [ - bw _ 3. - bc _ Colour red ] - ifFalse: [ - self textMorph hasUnacceptedEdits - ifTrue: [ - bc _ Colour red]]]]. - - (drawKeyboardFocusIndicator and: [ self textMorph hasKeyboardFocus ]) ifTrue: [ - bc ifNil: [ - bc _ Theme current focusIndicator ]] - ifFalse: [ - bc ifNotNil: [ - bc _ bc alphaMixed: 0.4 with: Colour white ]]. - bc ifNotNil: [ - aCanvas frameRectangle: self focusIndicatorRectangle borderWidth: bw color: bc ]! ! -!SystemWindow methodsFor: 'initialization' stamp: 'cbr 11/7/2010 18:58' prior: 16926270! - defaultColor - "answer the default color/fill style for the receiver" - ^ Colour white! ! -!SystemWindow methodsFor: 'menu' stamp: 'jmv 6/7/2013 23:23' prior: 16926535! - setWindowColor: incomingColor - | existingColor aColor | - incomingColor ifNil: [^ self]. "it happens" - aColor _ incomingColor asNontranslucentColor. - aColor = Colour black ifTrue: [^ self]. - existingColor _ self widgetsColor. - existingColor ifNil: [^ Smalltalk beep]. - self widgetsColor: aColor. - self redrawNeeded! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'KenD 8/27/2015 14:39' prior: 16811424! - buildMorphicWindow - " - CodePackageListWindow open: CodePackageList new - " - | dirtyFlags names fileNames upperRow description summary backColor labelBackground textHeigth | - backColor := self textBackgroundColor. - labelBackground := Theme current background. - textHeigth := AbstractFont default height. - - dirtyFlags := PluggableListMorph - model: model - listGetter: #packageDirtyFlags - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - dirtyFlags color: backColor. - dirtyFlags := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Colour transparent) fixedHeight: 4; - addMorph: (StringMorph new contents: ' Unsaved?') fixedHeight: textHeigth; - addMorphUseAll: dirtyFlags. - - names := PluggableListMorph - model: model - listGetter: #packageNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - names color: backColor. - names := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Colour transparent) fixedHeight: 4; - addMorph: (StringMorph new contents: ' Package Name') fixedHeight: textHeigth; - addMorphUseAll: names. - - fileNames := PluggableListMorph - model: model - listGetter: #packageFullNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - fileNames color: backColor. - fileNames := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Colour transparent) fixedHeight: 4; - addMorph: (StringMorph new contents: ' File Name') fixedHeight: textHeigth; - addMorphUseAll: fileNames. - - upperRow := LayoutMorph newRow. - upperRow - addMorph: dirtyFlags proportionalWidth: 0.13; - addAdjusterAndMorph: names proportionalWidth: 0.27; - addAdjusterAndMorph: fileNames proportionalWidth: 0.6. - - description := TextModelMorph - textProvider: model - textGetter: #description - textSetter: #description:. - - summary := TextModelMorph - textProvider: model - textGetter: #summary. - - self layoutMorph - addMorph: upperRow proportionalHeight: 0.5; - addAdjusterAndMorph: self buildButtonPane proportionalHeight: 0.1; - addAdjusterAndMorph: summary proportionalHeight: 0.18; - addAdjusterAndMorph: description proportionalHeight: 0.22; - addAdjusterAndMorph: self buildRequirementsPane proportionalHeight: 0.2. - self setLabel: 'Installed Packages'! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'len 5/27/2016 21:51' prior: 16811499! - buildRequirementsPane - - | requirements deleteReqButton "editReqButton" reqLayout buttonLayout | - requirements := PluggableListMorph - model: (PackageRequirementsList fromCodePackageList: model) - listGetter: #requirementsStrings - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - requirements color: Theme current textPane. - - deleteReqButton := PluggableButtonMorph - model: requirements model - action: #deleteSelectedRequirement - label: 'delete'. - deleteReqButton color: self widgetsColor. - - buttonLayout := LayoutMorph newColumn. - buttonLayout addMorph: deleteReqButton - layoutSpec: (LayoutSpec - proportionalWidth: 1.0 - proportionalHeight: 1.0 - minorDirectionPadding: #top); - color: self widgetsColor quiteWhiter. - - model when: #changed: send: #updateRequirementsFromPackageList to: requirements model. - self when: #changed: send: #updateRequirementsFromPackageList to: requirements model. - requirements model when: #changed: send: #verifyContents to: requirements. - self when: #changed: send: #verifyContents to: requirements. - - reqLayout := LayoutMorph newRow. - ^ reqLayout - doAdoptWidgetsColor; - addMorph: requirements - layoutSpec: (LayoutSpec - proportionalWidth: 0.9 - proportionalHeight: 1.0 - minorDirectionPadding: #left); - addMorph: buttonLayout - layoutSpec: (LayoutSpec - proportionalWidth: 0.1 - proportionalHeight: 1.0 - minorDirectionPadding: #right); - color: Colour transparent; - yourself - ! ! -!CodeWindow methodsFor: 'updating' stamp: 'jmv 6/18/2017 21:32:16' prior: 16813173! - decorateForInheritance - "Check to see if the currently-viewed method has a super send or an override, and if so, change screen feedback, unless the #decorateBrowserButtons says not to." - - | cm aColour aButton flags buttonColour | - (aButton _ self inheritanceButton) ifNil: [^ self]. - buttonColour _ self buttonColor. - - Preferences decorateBrowserButtons - ifFalse: [ ^aButton color: buttonColour ]. - cm _ model currentCompiledMethod. - (cm is: #CompiledMethod) - ifFalse: [ ^aButton color: buttonColour ]. - - flags _ 0. - model isThisAnOverride ifTrue: [ flags _ flags bitOr: 4 ]. - cm sendsToSuper ifTrue: [ flags _ flags bitOr: 2 ]. - model isThereAnOverride ifTrue: [ flags _ flags bitOr: 1 ]. - aColour _ { - - "This is NOTan override. There is no super implementation." - buttonColour. "no sends to super. there is not override in any subclass" - Colour tan. "no sends to super. there is an override in some subclass" - Colour red. "sends to super. there is no override in any subclass. Error: no super to call (or calls super with a different message)" - Colour red. "sends to super. there is an override in some subclass. Error: no super to call (or calls super with a different message)" - - "This is an override. There is some super implementation" - Colour red muchLighter. "doesn't have sub; has super but doesn't call it" - Colour r: 0.94 g: 0.823 b: 0.673. "has sub; has super but doesn't call it" - Colour green muchLighter. "doesn't have sub; has super and callsl it" - Colour blue muchLighter. "has sub; has super and callsl it" - - } at: flags + 1. - aButton color: buttonColour! ! -!ChangeSorterWindow methodsFor: 'GUI building' stamp: 'DM 8/22/2015 12:34' prior: 16799978! - buildMorphicWindow - "Add a set of change sorter views to the given top view offset by the given amount. To create a single change sorter, call this once with an offset of 0@0. To create a dual change sorter, call it twice with offsets of 0@0 and 0.5@0." - - | dirtyFlags changeSetList classList messageList upperPanes backColor labelBackground | - backColor _ self textBackgroundColor. - labelBackground _ Theme current background. - model myChangeSet ifNil: [ - self flag: #ojo. "Or whatever was last changed, or is top of list, or whatever" - model myChangeSet: ChangeSet changeSetForBaseSystem ]. - - dirtyFlags _ PluggableListMorph - model: model - listGetter: #changeSetDirtyFlags - indexGetter: nil - indexSetter: nil. - dirtyFlags color: backColor. - dirtyFlags _ LayoutMorph newColumn - color: Theme current background; - addMorph: (RectangleLikeMorph new color: Colour transparent) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: ' Unsaved?'); - addMorphUseAll: dirtyFlags. - - changeSetList _ (PluggableListMorphByItem - model: model - listGetter: #changeSetList - indexGetter: #currentCngSet - indexSetter: #showChangeSetNamed: - mainView: self - menuGetter: #changeSetMenu - keystrokeAction: #changeSetListKey:from:) - autoDeselect: false. - changeSetList color: backColor. - changeSetList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Colour transparent) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: 'Change Set name'); - addMorphUseAll: changeSetList. - - classList _ PluggableListMorphByItem - model: model - listGetter: #classList - indexGetter: #currentClassName - indexSetter: #currentClassName: - mainView: self - menuGetter: #classListMenu - keystrokeAction: #classListKey:from:. - classList color: backColor. - classList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Colour transparent) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: 'Classes'); - addMorphUseAll: classList. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: dirtyFlags proportionalWidth: 0.13; - addAdjusterAndMorph: changeSetList proportionalWidth: 0.47; - addAdjusterAndMorph: classList proportionalWidth: 0.4. - - messageList _ PluggableListMorphByItem - model: model - listGetter: #messageList - indexGetter: #currentSelector - indexSetter: #currentSelector: - mainView: self - menuGetter: #messageMenu - keystrokeAction: #messageListKey:from:. - messageList color: backColor. - messageList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Colour transparent) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: 'Methods'); - addMorphUseAll: messageList. - - self layoutMorph - addMorph: upperPanes proportionalHeight: 0.25; - addAdjusterAndMorph: messageList proportionalHeight: 0.2; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.55. - - self setLabel: model labelString! ! -!PreDebugWindow methodsFor: 'GUI building' stamp: 'HAW 1/12/2017 18:47:35' prior: 50336802! - buttonRowForPreDebugWindow: aDebugger - | row aButton triads buttons | - buttons _ OrderedCollection new. - triads _ OrderedCollection withAll: self preDebugButtonSpec. - aDebugger shouldBeAbleToCreateMethod ifTrue: [ triads add: { 'Create'. #createMethod. 'create the missing method' }]. - - triads do: [ :triad | - aButton _ PluggableButtonMorph new model: self. - aButton label: triad first. - aButton action: triad second. - aButton setBalloonText: triad third. - buttons add: aButton]. - - row _ LayoutMorph newRow. - row doAdoptWidgetsColor. - row color: Colour transparent. - row separation: 1. - row addMorphs: buttons. - ^row! ! -!TestRunnerWindow methodsFor: 'constants' stamp: 'jmv 4/16/2011 13:57' prior: 16928704! - runButtonColor - ^ Colour green lighter duller! ! -!ProgressBarMorph methodsFor: 'initialization' stamp: 'jmv 12/2/2011 10:52' prior: 16896023! - defaultColor - ^Colour white! ! -!ProgressBarMorph methodsFor: 'initialization' stamp: 'jmv 12/2/2011 10:53' prior: 16896027! - initialize - super initialize. - progressColor _ Colour gray. - value _ 0.0! ! -!MenuMorph methodsFor: 'construction' stamp: 'len 11/16/2015 02:52' prior: 16866472! - addStayUpIcons - | closeBox pinBox w | - Preferences optionalButtons ifFalse: [ ^self ]. - (self valueOfProperty: #hasStayUpIcons ifAbsent: [ false ]) - ifTrue: [ - self removeProperty: #needsStayUpIcons. - ^self ]. - titleMorph ifNil: [ - "Title not yet there. Flag ourself, so this method is called again when adding title." - self setProperty: #needsStayUpIcons toValue: true. - ^ self]. - closeBox _ PluggableButtonMorph model: self action: #delete. - closeBox icon: Theme current closeIcon; color: Colour transparent. - pinBox _ PluggableButtonMorph model: self action: #stayUp. - pinBox icon: Theme current pushPinIcon; color: Colour transparent. - w _ (titleMorph hasSubmorphs ifTrue: [ titleMorph firstSubmorph morphWidth ] ifFalse: [ 0 ]) + 60. - self addMorphFront: - (LayoutMorph newRow - "Make room for buttons" - morphExtent: w @ (titleMorph morphHeight max: 19); - color: Colour transparent; - addMorph: closeBox fixedWidth: 20; - addMorph: (RectangleLikeMorph new color: Colour transparent) fixedWidth: 4; - addMorph: titleMorph proportionalWidth: 1; - addMorph: (RectangleLikeMorph new color: Colour transparent) fixedWidth: 4; - addMorph: pinBox fixedWidth: 20). - - self setProperty: #hasStayUpIcons toValue: true. - self removeProperty: #needsStayUpIcons! ! -!MenuMorph methodsFor: 'keyboard control' stamp: 'jmv 6/8/2014 20:32' prior: 16867035! - displayFiltered: evt - | matchStr allItems isMatch matches feedbackMorph | - matchStr _ self valueOfProperty: #matchString. - allItems _ self submorphs select: [ :m | - m is: #MenuItemMorph ]. - matches _ allItems select: [ :m | - isMatch _ matchStr isEmpty or: [ - m contents - includesSubstring: matchStr - caseSensitive: false ]. - m isEnabled: isMatch. - isMatch ]. - feedbackMorph _ self valueOfProperty: #feedbackMorph. - feedbackMorph ifNil: [ - feedbackMorph _ StringMorph new color: Colour veryDarkGray. - self addMorphBack: feedbackMorph lock position: (0@ -20). - self - setProperty: #feedbackMorph - toValue: feedbackMorph ]. - feedbackMorph contents: '<' , matchStr , '>'. - matchStr isEmpty ifTrue: [ - feedbackMorph delete. - self removeProperty: #feedbackMorph ]. - matches notEmpty ifTrue: [ - self selectItem: matches first ]! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'jmv 4/14/2016 15:10' prior: 16781489! - drawOn: aCanvas - | rectangle w y0 h y1 y2 scrollbarThickness | - aCanvas frameAndFillRectangle: (0@0 extent: extent) fillColor: self color borderWidth: borderWidth borderColor: borderColor. - y0 _ 1. - w _ extent x-2. - scrollbarThickness _ ScrollBar scrollbarThickness. - completer entryCount > self class itemsPerPage ifTrue: [ - w _ w - scrollbarThickness. - aCanvas - frameRectangle: (extent x - scrollbarThickness@0 - extent: scrollbarThickness @ extent y) - borderWidth: 1 - color: borderColor. - aCanvas - image: (BitBltCanvas arrowOfDirection: #up size: scrollbarThickness) - at: self upButtonPosition. - aCanvas - image: (BitBltCanvas arrowOfDirection: #down size: scrollbarThickness) - at: self downButtonPosition. - h _ extent y - (2 * scrollbarThickness). - y1 _ (1.0 * self firstVisible-1 / completer entryCount * h) ceiling + y0 + scrollbarThickness-1. - y2 _ (1.0 * self lastVisible / completer entryCount * h) floor + y0 + scrollbarThickness -1. - aCanvas - fillRectangle: (extent x - scrollbarThickness+2@y1 corner: extent x-2 @ y2) - color: Colour veryLightGray ]. - self firstVisible - to: self lastVisible - do: [ :index | - rectangle _ 1@y0 extent: w@self class itemHeight. - index = self selected - ifTrue: [ - aCanvas fillRectangle: rectangle color: (Theme current listHighlightFocused: true) ]. - aCanvas - drawString: (completer entries at: index) asString - at: rectangle topLeft - font: self class listFont - color: Theme current text. - y0 _ y0 + self itemHeight ]! ! -!AutoCompleterMorph methodsFor: 'initialization' stamp: 'jmv 12/2/2011 10:09' prior: 16781571! - defaultBorderColor - ^ Colour gray! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 9/9/2012 23:59' prior: 16851609! - drawOn: aCanvas - "Draw the hand itself (i.e., the cursor)." - "This method is only called when we are carrying morphs around..." - aCanvas - stencil: Cursor move - at: 0@0 - color: Colour black! ! -!ImageMorph methodsFor: 'accessing' stamp: 'jmv 6/18/2017 21:32:59' prior: 16854101! - color: aColor - super color: aColor. - (image depth = 1 and: [aColor is: #Color]) ifTrue: [ - image colors: {Colour transparent. aColor}. - self redrawNeeded]! ! -!MenuItemMorph methodsFor: 'accessing' stamp: 'jmv 3/13/2009 10:04' prior: 16865863! - isEnabled: aBoolean - - isEnabled = aBoolean ifTrue: [^ self]. - isEnabled _ aBoolean. - self color: (aBoolean ifTrue: [Colour black] ifFalse: [Colour gray]). -! ! -!MenuItemMorph methodsFor: 'private' stamp: 'jmv 9/9/2012 23:55' prior: 16866162! - offImage - "Return the form to be used for indicating an '' marker" - | form | - form _ Form extent: (self fontToUse ascent-2) asPoint depth: 16. - form getCanvas - frameAndFillRectangle: form boundingBox fillColor: (Colour gray: 0.9) - borderWidth: 1 borderColor: Colour black. - ^form! ! -!MenuItemMorph methodsFor: 'private' stamp: 'jmv 9/9/2012 23:55' prior: 16866174! - onImage - "Return the form to be used for indicating an '' marker" - | form | - form _ Form extent: (self fontToUse ascent-2) asPoint depth: 16. - form getCanvas - frameAndFillRectangle: form boundingBox fillColor: (Colour gray: 0.8) - borderWidth: 1 borderColor: Colour black; - fillRectangle: (form boundingBox insetBy: 2) color: Colour black. - ^form! ! -!LayoutMorph methodsFor: 'accessing' stamp: 'jmv 12/1/2015 09:53' prior: 16863001! - adoptWidgetsColor: paneColor - super adoptWidgetsColor: paneColor. - doAdoptWidgetsColor - ifTrue: [ self color: (Theme current buttonColorFrom: paneColor) ] - ifFalse: [ self color: Colour transparent ]! ! -!LayoutMorph methodsFor: 'initialization' stamp: 'jmv 8/17/2014 21:38' prior: 16863302! - defaultColor - ^Colour gray! ! -!LayoutMorph class methodsFor: 'instance creation' stamp: 'jmv 4/3/2011 22:59' prior: 16863603! - initializedInstance - "Answer a row by default so the 'new morph' menu doesn't fail..." - ^self newRow color: (Colour red alpha: 0.2)! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/5/2015 10:57' prior: 16863624! - example1 -" - self example1 -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example1. -pane color: Colour red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addMorph: (BorderedRectMorph new color: (Colour blue); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addMorph: (BorderedRectMorph new color: (Colour h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 20). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #G) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8); - addMorph: (BorderedRectMorph new color: (Colour h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (BorderedRectMorph new color: (Colour h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -pane morphPosition: 150@130 extent: 400@300. -pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/12/2015 16:42' prior: 16863690! - example10 -" - self example10 openInWorld -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example10. -pane color: Colour red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Colour blue); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Colour h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 20). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #G) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8); - addMorph: (BorderedRectMorph new color: (Colour h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (BorderedRectMorph new color: (Colour h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -^ pane! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/5/2015 10:55' prior: 16863758! -example11 -" - self example11 -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example11. -pane color: Colour red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Colour blue); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Colour h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 20). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #G) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8); - addMorph: (BorderedRectMorph new color: (Colour h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (BorderedRectMorph new color: (Colour h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -pane morphPosition: 150@130 extent: 400@300. -pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/5/2015 11:08' prior: 16863827! - example13 - " - self example13 - " - | pane row innerRow | -pane _ (LayoutMorph newColumn separation: 5) name: #example13. - pane color: Colour red. - row _ (LayoutMorph newRow separation: 5) name: #Row. - innerRow _ (LayoutMorph newRow separation: 5) name: #InnerRow; - color: Colour red. - innerRow - addMorph: (BorderedRectMorph new name: #Box1) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (BorderedRectMorph new name: #Box2) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (BorderedRectMorph new name: #Bar) - layoutSpec: (LayoutSpec proportionalWidth: 1.0 fixedHeight: 10). - row - color: (Colour h: 270 s: 0.2 v: 0.6); - addMorph: innerRow - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 30 minorDirectionPadding: #center); - addMorph: LayoutAdjustingMorph new layoutSpec: (LayoutSpec fixedWidth: 5); - addMorph: (BorderedRectMorph new color: (Colour h: 90 s: 0.6 v: 0.6); name: #Rect1) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40 minorDirectionPadding: #top); - addMorph: LayoutAdjustingMorph new layoutSpec: (LayoutSpec fixedWidth: 5); - addMorph: (BorderedRectMorph new color: (Colour h: 150 s: 0.6 v: 0.6); name: #Rect2) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). - pane addMorph: row layoutSpec: (LayoutSpec proportionalHeight: 0.9). - pane morphPosition: 250@130 extent: 400@300. - pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 2/16/2016 13:27' prior: 16863874! - example1b -" -Based on #example1, but using some Morph instead of RectangleLikeMorph -> extent is not adjustable - self example1b -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example1. -pane color: Colour red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addMorph: (Morph new name: #B); - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addMorph: (BorderedRectMorph new color: (Colour h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 20). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (Morph new name: #G); - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Colour red; - addMorph: (Morph new name: #J); - addMorph: (BorderedRectMorph new color: (Colour h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (BorderedRectMorph new color: (Colour h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -pane morphPosition: 150@130 extent: 400@300. -pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/5/2015 11:25' prior: 16863934! - example2 - " - self example2 - " - | pane row | - pane _ (LayoutMorph newColumn separation: 5) name: #example2. - pane color: Colour red. - row _ (LayoutMorph newRow separation: 5) name: #Row. - row - color: (Colour h: 270 s: 0.2 v: 0.6); - addMorph: (BorderedRectMorph new color: (Colour h: 120 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8 minorDirectionPadding: #bottom); - addMorph: (BorderedRectMorph new color: (Colour h: 90 s: 0.6 v: 0.6); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8 fixedHeight: 40 minorDirectionPadding: #top); - addMorph: (BorderedRectMorph new color: (Colour h: 150 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 0.7 minorDirectionPadding: #center). - pane addMorph: row layoutSpec: (LayoutSpec proportionalHeight: 0.9). - pane morphPosition: 200@180 extent: 400@300. - pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 11/18/2015 09:45' prior: 16863965! - example20 -" - self example20 -" -| column | - -column _ (LayoutMorph newColumn separation: 5) name: #Column. -column - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec proportionalWidth: 0.8 fixedHeight: 20); - addMorph: (BorderedRectMorph new color: (Colour h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec fixedWidth: 40 proportionalHeight: 0.5); - addMorph: (BorderedRectMorph new color: (Colour h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec proportionalWidth: 1.0 fixedHeight: 30). -column morphPosition: 150@130 extent: 400@300. -column openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/5/2015 11:13' prior: 16863988! - example3 - " - self example3 - " - | pane row innerRow | -pane _ (LayoutMorph newColumn separation: 5) name: #example3. - pane color: Colour red. - row _ (LayoutMorph newRow separation: 5) name: #Row. - innerRow _ (LayoutMorph newRow separation: 5) name: #InnerRow; - color: Colour red. - innerRow - addMorph: (BorderedRectMorph new name: #Box1) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (BorderedRectMorph new name: #Box2) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (BorderedRectMorph new name: #Bar) - layoutSpec: (LayoutSpec proportionalWidth: 1.0 fixedHeight: 10). - row - color: (Colour h: 270 s: 0.2 v: 0.6); - addMorph: innerRow - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 30 minorDirectionPadding: #center); - addMorph: (BorderedRectMorph new color: (Colour h: 90 s: 0.6 v: 0.6); name: #Rect1) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40 minorDirectionPadding: #top); - addMorph: (BorderedRectMorph new color: (Colour h: 150 s: 0.6 v: 0.6); name: #Rect2) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). - pane addMorph: row layoutSpec: (LayoutSpec proportionalHeight: 0.9). - pane morphPosition: 250@130 extent: 400@300. - pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 6/8/2014 20:03' prior: 16864030! - example6 - " - Useful example contributed by Ken Dickey - All these should look the same, right? (mmmh this should be a test...) - self example6 - " -| pane rect1 rect2 | -pane _ LayoutMorph newRow separation: 5. "1" -pane addMorph: (StringMorph contents: '1'). - -rect1 := BorderedRectMorph new color: (Colour lightOrange); - morphExtent: 20 @ 30. -pane addMorphFront: rect1. -rect2 := BorderedRectMorph new color: (Colour cyan); - morphExtent: 20 @ 30. -pane addMorphFront: rect2. -pane - color: Colour lightGreen; - morphPosition: 120 @ 50 extent: 180 @ 100; - openInWorld. - -pane _ LayoutMorph newRow separation: 5. "2" -pane addMorph: (StringMorph contents: '2'). - -rect1 := BorderedRectMorph new color: (Colour lightOrange); - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 minorDirectionPadding: #center). -pane addMorph: rect1. -rect2 := BorderedRectMorph new color: (Colour cyan). -pane addMorph: rect2 - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 minorDirectionPadding: #center). -pane - color: Colour lightGreen; - morphPosition: 320 @ 50 extent: 180 @ 100; - openInWorld. - - -pane _ LayoutMorph newRow separation: 5. "3" -pane addMorph: (StringMorph contents: '3'). - -rect1 := BorderedRectMorph new color: (Colour lightOrange). -pane addMorph: rect1 - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 minorDirectionPadding: #center). -rect2 := BorderedRectMorph new color: (Colour cyan); - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 minorDirectionPadding: #center). -pane addMorph: rect2. -pane - color: Colour lightGreen; - morphPosition: 520 @ 50 extent: 180 @ 100; - openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 1/4/2013 13:42' prior: 16864106! - launcherExample - " - self launcherExample - " - | b1 b2 b3 row b4 random buttons | - random _ Random new. - b1 _ PluggableButtonMorph model: [ Date today print ] action: #value label: 'Date'. - b2 _ PluggableButtonMorph model: [ Time now print ] action: #value label: 'Time'. - b3 _ PluggableButtonMorph model: [ SystemVersion current print ] action: #value label: 'Version'. - b4 _ PluggableButtonMorph model: [ random next print ] action: #value label: 'Random'. - buttons _ {b1. b2. b3. b4}. - buttons do: [ :button | - button color: Colour lightRed ]. - row _ LayoutMorph newRow - color: Colour red; - addMorphs: buttons; - morphExtent: 300 @ 40. - ^ row openInWorld! ! -!ProgressMorph methodsFor: 'initialization' stamp: 'jmv 12/2/2011 10:55' prior: 16896260! - defaultColor - ^Colour veryLightGray! ! -!HaloHandleMorph class methodsFor: 'accessing' stamp: 'jmv 11/18/2010 09:44' prior: 16850573! - circleForm: extent - " - CircleForm _ nil - " - | r d l bw center | - (CircleForm isNil or: [ CircleForm extent ~= extent ]) ifTrue: [ - center _ extent -1 * 0.5. - r _ center r * 0.75. - bw _ 1.3. - CircleForm _ Form extent: extent depth: 32. - 0 to: extent y - 1 do: [ :y | - 0 to: extent x - 1 do: [ :x | - d _ (x@y - center) r. - l _ (r - d max: 0.0) min: bw. - CircleForm - colorAt: x @ y - put: (Colour white alpha: (l / bw)) - ]]. - ]. - ^CircleForm! ! -!HaloMorph methodsFor: 'initialization' stamp: 'jmv 6/18/2017 21:33:32' prior: 16850854! - defaultColor - "answer the default color/fill style for the receiver" - ^ Colour - r: 0.6 - g: 0.8 - b: 1.0! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 5/27/2015 13:42' prior: 16850874! - addHandle: handleSpec - "Add a handle within the halo box as per the haloSpec, and set it up to respond to the given event by sending the given selector to the given recipient. Return the handle." - - | handle aPoint colorToUse form icon | - aPoint _ self - positionIn: haloBox - horizontalPlacement: handleSpec horizontalPlacement - verticalPlacement: handleSpec verticalPlacement. - colorToUse _ Colour colorFrom: handleSpec color. - handle _ HaloHandleMorph new color: colorToUse. - self addMorph: handle. - handle morphBoundsInWorld: (Rectangle center: aPoint extent: self class handleSize asPoint). - handleSpec iconSymbol ifNotNil: [ :iconName | - form _ self class icons at: iconName ifAbsent: [self class perform: iconName]. - form ifNotNil: [ - icon _ ImageMorph new - image: form; - color: colorToUse makeForegroundColor; - lock. - handle addMorphFront: icon position: 0@0 ]]. - handle mouseUpSelector: #endInteraction. - handle setBalloonText: handleSpec hoverHelp. - ^handle! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/4/2016 22:14' prior: 16850920! - addNameString: aString - "Add a name display centered beneath the bottom of the outer rectangle. Return the handle." - - | nameMorph namePosition nameBackground | - nameBackground _ RectangleLikeMorph new - color: ((target is: #SystemWindow) ifTrue: [target windowColor] ifFalse: [Colour lightBlue alpha: 0.9]). - nameMorph _ StringMorph contents: aString. - nameMorph color: Colour black. - nameBackground morphExtent: nameMorph morphExtent + 4. - namePosition _ haloBox width - nameMorph morphWidth // 2 @ (haloBox height). - self addMorph: nameBackground position: namePosition - 2. - self addMorph: nameMorph position: namePosition. - ^nameMorph! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 9/22/2012 15:18' prior: 16851047! - doRot: evt with: rotHandle - "Update the rotation of my target if it is rotatable. Keep the relevant command object up to date." - - | degrees | -self revisar. - self flag: #jmvVer2. - evt hand obtainHalo: self. - degrees _ (evt eventPosition - target referencePosition) degrees. - degrees _ degrees - angleOffset degrees. - degrees _ degrees detentBy: 10.0 atMultiplesOf: 90.0 snap: false. - degrees = 0.0 - ifTrue: [rotHandle color: Colour lightBlue] - ifFalse: [rotHandle color: Colour blue]. - rotHandle submorphsDo: - [:m | m color: rotHandle color makeForegroundColor]. - self removeAllHandlesBut: rotHandle. - - target rotationDegrees: degrees. - - rotHandle morphPositionInWorld: evt eventPosition - (rotHandle morphExtent // 2)! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 9/20/2012 00:01' prior: 16851135! - setDismissColor: evt with: dismissHandle - "Called on mouseStillDown in the dismiss handle; set the color appropriately." - - | colorToUse | - evt hand obtainHalo: self. - colorToUse _ (dismissHandle morphContainsPoint: (dismissHandle internalizeFromWorld: evt eventPosition)) - ifFalse: [ Colour red muchLighter ] - ifTrue: [ Colour lightGray ]. - dismissHandle color: colorToUse! ! -!InnerListMorph methodsFor: 'initialization' stamp: 'jmv 5/27/2013 09:39' prior: 16855063! - initialize - super initialize. - self color: Colour black. - font _ Preferences standardListFont. - listItems _ #(). - selectedRow _ nil. - selectedRows _ Set new. - highlightedRow _ nil! ! -!InnerTextMorph methodsFor: 'drawing' stamp: 'jmv 10/16/2013 19:55' prior: 16855561! - debugDrawLineRectsOn: aCanvas - "Shows where text line rectangles are" - - self textComposition lines do: [ :line | - aCanvas - frameRectangle: line rectangle - borderWidth: 1 - color: Colour brown ] -! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/17/2015 15:51' prior: 50333232! - initialize - super initialize. - extent _ 400@300. - color _ Colour white. - grid _ 8@6. - gridLineWidth _ 2. - gridColor _ Colour black. - selectionColor _ Colour red! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 23:18' prior: 50333240! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - from _ self toGridPoint: localEventPosition. - outlineMorph _ BorderedRectMorph new - borderColor: Colour black; - color: Colour transparent; - openInWorld; - hide. - self selectTo: localEventPosition! ! -!HoverHelpMorph methodsFor: 'initialization' stamp: 'jmv 9/25/2011 23:12' prior: 16853831! - defaultColor - - ^Colour r: 1.0 g: 1.0 b: 0.7! ! -!HoverHelpMorph methodsFor: 'drawing' stamp: 'jmv 12/20/2014 15:09' prior: 16853866! - drawOn: aCanvas - - | r | - r _ self morphLocalBounds. - aCanvas roundRect: r color: self color radius: 4. - aCanvas - textComposition: textComposition - bounds: (r insetBy: 4) - color: Colour black - selectionColor: (Theme current textHighlightFocused: false)! ! -!WorldState methodsFor: 'drawing' stamp: 'jmv 3/2/2017 19:40:12' prior: 50339661! - drawInvalidAreasSubmorphs: submorphs - "Redraw the damaged areas of the given canvas and clear the damage list. Return a collection of the areas that were redrawn." - - | initialRectsToRepair currentRectsToRepair newRectsToRepair morphsToDraw rectsForEachMorph thisMorphRects reuse i n morph morphBounds morphClipRect | - - "The simple implementation is slowers as it draws morph areas that will later be covered by other morphs. - But it works, and it is easier to understand. - See en.wikipedia.org/wiki/Painter's_algorithm" - true not ifTrue: [ ^self simpleDrawInvalidAreasSubmorphs: submorphs ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - initialRectsToRepair _ damageRecorder invalidRectsFullBounds: world viewBox. - damageRecorder reset. - currentRectsToRepair _ OrderedCollection new. - newRectsToRepair _ OrderedCollection withAll: initialRectsToRepair. - morphsToDraw _ OrderedCollection new. - rectsForEachMorph _ OrderedCollection new. - thisMorphRects _ OrderedCollection new. - n _ submorphs size. - i _ 1. - - "The idea here is to iterate morphs front to back, i.e. first the ones on top. - For each morph, record the rectangles it affects. And if a morph is opaque, remove the area behind it from the list of rectangles to be repaired. - This means, for example, that morphs completely covered might even not be redrawn. - this is a huge performance gain when there are many morphs on screen, especially if there are more than ten open windows, and Theme uses opaque colors. - See 'A reverse painter's algorithm' at en.wikipedia.org/wiki/Painter's_algorithm" - [ i <= n and: [ newRectsToRepair notEmpty ]] whileTrue: [ - morph _ submorphs at: i. - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - reuse _ currentRectsToRepair. - currentRectsToRepair _ newRectsToRepair. - newRectsToRepair _ reuse removeAll. - currentRectsToRepair do: [ :r | - (morphBounds intersects: r) - ifTrue: [ - morphClipRect _ morphBounds intersect: r. - thisMorphRects add: morphClipRect. "We could perhaps try and join adjacent rectangles in this collection..." - morph addPossiblyUncoveredAreasIn: r to: newRectsToRepair ] - ifFalse: [ - newRectsToRepair add: r ]]. - thisMorphRects ifNotEmpty: [ - morphsToDraw add: morph. - rectsForEachMorph add: thisMorphRects. - thisMorphRects _ OrderedCollection new. - ]]. - i _ i + 1 ]. - - "*make this true to flash damaged areas for testing*" - Preferences debugShowDamage ifTrue: [ world fillRects: initialRectsToRepair color: Colour gray ]. - - "Draw world background on those areas that were not completely covered by opaque morphs" - i > n ifTrue: [ - newRectsToRepair do: [ :r | - world drawOn: (canvas newClipRect: r) ]]. - - "Now, draw the recorded areas of selected morphs, back to front." - morphsToDraw with: rectsForEachMorph reverseDo: [ :m :xrects | - "Here we could think about merging all xrects into just one call... - This would mean drawing each morph just once. - But that would mean drawing pixels we were not told to. There could be other morphs in that area that are not even being drawn!! - See WorldState class >> #experiment1" -" rr _ nil." - xrects do: [ :r | -" rr _ rr ifNil: [ r ] ifNotNil: [ r quickMerge: rr ]." - (canvas newClipRect: r) fullDraw: m. - ]. -" (canvas newClipRect: rr) fullDraw: m" - "*make this true to flash damaged areas for testing*" - Preferences debugShowDamage2 ifTrue: [ - world flashRects: xrects color: Colour random ]. - ]. - - "Answer a list of rectangles to be updated on the Display. - This usually is not performance critical, drawing morphs is slower than just exposing the Display." - "What should we force on Display? Whatever was asked? Each small rect that was updated? A single bigger rect? - Right now, answer whatever was asked... Maybe this could be changed if that enhances performance... - (think of vnc over slow networks)" - ^ initialRectsToRepair! ! -!WorldState class methodsFor: 'sample code' stamp: 'jmv 3/2/2017 19:39:21' prior: 50339883! - experiment1 - "To play with and learn about morphic Display update logic. - Remove the morphs when done!!" - " - WorldState experiment1 - " - | dr morph1 morph2 s w | - morph1 _ RectangleLikeMorph new openInWorld. - morph2 _ RectangleLikeMorph new openInWorld. - morph2 color: Colour green. - morph2 morphPosition: 200@800 extent: 50@40. - morph1 morphPosition: 120@720 extent: 220@100. - - w _ self runningWorld. - s _ w instVarNamed: 'worldState'. - dr _ s instVarNamed: 'damageRecorder'. - - dr doFullRepaint. - dr reset; - " recordInvalidRect: (100@700 corner: 400@900);" - recordInvalidRect: (100@700 corner: 150@900); - recordInvalidRect: (300@700 corner: 400@900). - Display fillColor: Colour gray. - "Do not draw the area used by the small rectangle, unless it is also drawn!!" - s drawInvalidAreasSubmorphs: {morph1. morph2 }! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 12/20/2014 15:35' prior: 16877458! - drawCurrentAsError - "The morph (or one of its submorphs) had an error in its drawing method." - | r w | - r _ currentMorph morphLocalBounds. - w _ r extent > (50@50) - ifTrue: [ 6 ] - ifFalse: [ 2 ]. - self - frameAndFillRectangle: r - fillColor: Colour red - borderWidth: w - borderColor: Colour yellow. - self line: r topLeft to: r bottomRight-w width: w color: Colour yellow. - self line: r topRight -(w@0) to: r bottomLeft -(0@w)width: w color: Colour yellow! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 6/1/2015 13:30' prior: 16877630! - drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - aColor = Colour black ifFalse: [ | topColor | - topColor _ aColor alphaMixed: 0.25 with: Colour black. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint - font: fontOrNil - color: topColor ]. - aColor = Colour white ifFalse: [ | bottomColor | - bottomColor _ aColor alphaMixed: 0.22 with: Colour white. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + (0@2) - font: fontOrNil - color: bottomColor ]. - ^self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + (0@1) - font: fontOrNil - color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 11/29/2015 18:01' prior: 16786666! - fillRectangle: aRectangle color: aColor - "Fill the given rectangle." - - aColor isTransparent ifFalse: [ - self - frameAndFillRectangle: aRectangle - fillColor: aColor - borderWidth: 0 - borderColor: Colour transparent ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 11/29/2015 18:14' prior: 16786789! - reverseRectangleBorder: r borderWidth: borderWidth - " - Display getCanvas - reverseRectangleBorder: (10@10 extent: 300@200) - borderWidth: 20. - Display forceToScreen - " - | rect | - rect _ currentTransformation displayBoundsOfTransformOf: r. - port - sourceForm: nil; - fillColor: Colour gray; - combinationRule: Form reverse; - frameRect: rect borderWidth: borderWidth! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 4/9/2015 09:46' prior: 16787146! - setPaintColor: aColor - "Install a new color used for filling." - | paintColor | - paintColor _ aColor ifNil: [ Colour transparent ]. - (paintColor is: #Color) ifFalse: [ - ^self error: 'Cannot install color' ]. - - "Okay, so paintColor really *is* a color" - port sourceForm: nil. - (paintColor isOpaque or: [ self depth < 32]) ifTrue: [ - port fillColor: paintColor. - port combinationRule: Form paint. - ^self ]. - - "BitBlt setup for alpha mapped transfer" - port fillColor: paintColor. - port combinationRule: Form blend! ! -!BitBltCanvas class methodsFor: 'cached forms' stamp: 'jmv 4/17/2015 12:16' prior: 16787260! - steButtonForm: extent - ^self cachedForms - at: { #steButton . extent } - ifAbsentPut: [ - | form canvas | - form _ Form extent: extent depth: 32. - canvas _ form getCanvas. - canvas - roundRect: (0@0 extent: extent) - color: (Colour gray: 0.4) - radius: 4. - canvas - roundRect: (1@1 extent: extent-2) - color: Colour white - radius: 4 - gradientTop: 1.0 - gradientCenter: 0.73 - gradientBottom: 0.94 - gradient1Height: (extent y-8+1 max: extent y//2). - form]! ! -!BitBltCanvas class methodsFor: 'cached forms' stamp: 'jmv 4/17/2015 12:16' prior: 16787305! - verticalGrayGradient: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - ^self cachedForms - at: { #vertical. height. gradientTopFactor . gradientBottomFactor } - ifAbsentPut: [ - Form - verticalGradient: height - topColor: (Colour gray: gradientTopFactor) - bottomColor: (Colour gray: gradientBottomFactor) ]! ! -!BitBltCanvas class methodsFor: 'cached arrow forms' stamp: 'jmv 1/7/2015 08:12' prior: 16787328! - buildArrowOfDirection: aSymbolDirection size: finalSizeInteger - "PRIVATE - create an arrow with aSymbolDirectionDirection, - finalSizeInteger and aColor - - aSymbolDirectionDirection = #up, #down. #left or #right - (self buildArrowOfDirection: #down size: 120) display - (self buildArrowOfDirection: #up size: 120) display - " - - | resizeFactor resizedForm f e c bottomMargin topMargin | - resizeFactor _ 4. - e _ finalSizeInteger@finalSizeInteger*resizeFactor. - f _ Form extent: e depth: 32. - c _ Colour gray: 0.5. - topMargin _ finalSizeInteger * 3//4. - bottomMargin _ finalSizeInteger * 4//4. - 0 to: e y-1-bottomMargin do: [ :y | - 0 to: e x -1 do: [ :x | - (e x / 2 - 1 - x) abs * 2 + topMargin < y ifTrue: [ - f colorAt: x@y put: c - ] - ] - ]. - resizedForm _ f - magnify: f boundingBox - by: 1 / resizeFactor - smoothing: 4. - - aSymbolDirection == #right ifTrue: [ - resizedForm _ resizedForm rotatedByDegrees: 90 ]. - aSymbolDirection == #down ifTrue: [ - resizedForm _ resizedForm rotatedByDegrees: 180 ]. - aSymbolDirection == #left ifTrue: [ - resizedForm _ resizedForm rotatedByDegrees: 270 ]. - - aSymbolDirection == #up ifFalse: [ - resizedForm _ resizedForm - copy: (resizedForm boundingBox insetBy: (resizedForm width - finalSizeInteger/ 2.0) rounded) ]. - - ^resizedForm! ! -!BitBltCanvas class methodsFor: 'cached arrow forms' stamp: 'jmv 10/9/2014 23:02' prior: 16787371! - buildArrowWith: insideForm borderForm: borderForm - | extent translucentForm color insideSpec borderSpec border background alpha| - " - Display getCanvas - image: (BitBltCanvas buildArrowWith: BitBltCanvas downInsideForm borderForm: BitBltCanvas downBorderForm) - at: 20@20 - Display getCanvas - image: (BitBltCanvas buildArrowWith:BitBltCanvas upInsideForm borderForm: BitBltCanvas upBorderForm) - at: 40@20 - " - extent _ insideForm extent - (1@2). - translucentForm _ Form extent: insideForm extent depth: 32. - 0 to: extent x-1 do: [ :x | - 0 to: extent y-1 do: [ :y | - insideSpec _ insideForm colorAt: x@(y+1). - borderSpec _ borderForm colorAt: x@(y+1). - insideSpec = (Colour r: 0.0 g: 0.0 b: 1.0) - ifTrue: [ color _ Colour transparent ] - ifFalse: [ - borderSpec = (Colour r: 1.0 g: 0.0 b: 0.0) - ifTrue: [ color _ insideSpec ] - ifFalse: [ - border _ x < (extent x//2) - ifTrue: [Colour white] - ifFalse: [Colour black]. - background _ borderForm colorAt: extent x@(y+1). - alpha _ borderSpec red asFloat - background red / (border red - background red). - color _ border alpha: (alpha min: 1 max: 0) ]]. - translucentForm colorAt: x@y put: color ]]. - ^translucentForm! ! -!Theme methodsFor: 'colors' stamp: 'jmv 11/19/2010 14:06' prior: 16935417! - background - ^ Colour r: 0.7 g: 0.72 b: 0.83! ! -!Theme methodsFor: 'colors' stamp: 'jmv 11/23/2010 09:42' prior: 16935421! - buttonColorFrom: aColor - ^ Display depth <= 8 - ifTrue: [ Colour transparent ] - ifFalse: [ aColor paler ]! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/14/2011 08:50' prior: 16935427! - buttonLabel - ^Colour gray: 0.18! ! -!Theme methodsFor: 'colors' stamp: 'len 6/9/2016 17:38' prior: 16935430! - errorColor - ^ Colour red lighter! ! -!Theme methodsFor: 'colors' stamp: 'len 6/9/2016 17:40' prior: 16935433! - failureColor - ^ Colour yellow lighter! ! -!Theme methodsFor: 'colors' stamp: 'len 11/14/2015 02:34' prior: 16935453! - scrollbarButtonColor - ^Colour gray: 0.95! ! -!Theme methodsFor: 'colors' stamp: 'len 11/17/2015 23:55' prior: 16935457! - scrollbarColor - ^Colour white! ! -!Theme methodsFor: 'colors' stamp: 'len 11/14/2015 02:34' prior: 16935460! - scrollbarSliderShadowColor - ^Colour white! ! -!Theme methodsFor: 'colors' stamp: 'len 6/9/2016 17:38' prior: 16935464! - successColor - ^ Colour green lighter! ! -!Theme methodsFor: 'colors' stamp: 'cbr 11/7/2010 18:00' prior: 16935468! - text - ^ Colour black! ! -!Theme methodsFor: 'colors' stamp: 'jmv 10/16/2013 22:08' prior: 16935471! - textCursor - ^ Display depth <= 2 - ifTrue: [ Colour black ] - ifFalse: [ self text ]! ! -!Theme methodsFor: 'colors' stamp: 'jmv 5/30/2011 14:31' prior: 16935476! - textHighlight - "A nice light blue." - " - ^ Colour r: 0.71 g: 0.835 b: 1.0 - ^ Colour hue: 214 chroma: 0.29 luminance: 0.816 - " - ^Colour hue: 204 chroma: 0.29 luminance: 0.77! ! -!Theme methodsFor: 'colors' stamp: 'jmv 11/23/2010 09:58' prior: 16935484! - textHighlightFocused: focused - "A nice light blue." - | textHighlight | - Display depth = 1 ifTrue: [^ Colour veryLightGray]. - Display depth = 2 ifTrue: [^ Colour gray: 0.87]. - textHighlight _ self textHighlight. - ^focused - ifTrue: [ textHighlight ] - ifFalse: [ self unfocusedTextHighlightFrom: textHighlight ]! ! -!Theme methodsFor: 'colors' stamp: 'cbr 12/6/2010 20:08' prior: 16935501! - windowLabel - ^Colour gray: 0.3! ! -!Theme methodsFor: 'menu colors' stamp: 'jmv 5/26/2011 09:07' prior: 16935505! - menu - Display depth <= 2 ifTrue: [^ Colour white]. - ^Colour r: 0.75 g: 0.75 b: 0.75 alpha: 0.93! ! -!Theme methodsFor: 'menu colors' stamp: 'jmv 11/23/2010 09:45' prior: 16935511! - menuHighlight - ^ Display depth < 8 - ifTrue: [ Colour veryLightGray ] - ifFalse: [ self textHighlight ]! ! -!Theme methodsFor: 'menu colors' stamp: 'cbr 11/7/2010 18:28' prior: 16935517! - menuText - ^ Colour black! ! -!Theme methodsFor: 'menu colors' stamp: 'jmv 11/28/2010 08:04' prior: 16935520! - menuTitleBar - Display depth = 1 ifTrue: [^ Colour white]. - Display depth = 2 ifTrue: [^ Colour gray]. - ^ self menu darker! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 4/15/2011 14:59' prior: 16935526! - browser - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Colour r: 0.5 g: 0.7 b: 0.4]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 2/14/2013 11:05' prior: 16935539! - debugger - ^Colour h: 0.0 s: 0.6 v: 0.7! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 11/23/2010 09:16' prior: 16935543! - defaultWindowColor - ^ Colour lightGray! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 11/18/2010 12:44' prior: 16935551! - fileContentsBrowser - ^Colour tan duller! ! -!Theme methodsFor: 'tool colors' stamp: 'cbr 12/4/2010 18:44' prior: 16935555! - fileList - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Colour r: 0.7 g: 0.55 b: 0.7 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 5/23/2012 19:23' prior: 16935561! - messageNames - - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Colour r: 0.53 g: 0.77 b: 0.382 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'cbr 12/4/2010 18:45' prior: 16935567! - messageSet - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Colour r: 0.45 g: 0.6 b: 0.85 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 11/18/2010 12:44' prior: 16935573! - object - ^Colour white duller! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/28/2012 09:41' prior: 16935576! - packageList - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Colour r: 0.63 g: 0.47 b: 0.08 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 11/23/2010 09:17' prior: 16935582! - testRunner - ^ self useUniformColors - ifTrue: [ self defaultWindowColour ] - ifFalse: [ (Colour r: 0.650 g: 0.753 b: 0.976) duller ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/16/2011 08:15' prior: 16935589! - textEditor - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Colour gray: 0.6 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'cbr 12/4/2010 18:45' prior: 16935595! - transcript - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Colour r: 0.8 g: 0.6 b: 0.3 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'cbr 12/18/2010 17:56' prior: 16935601! - versionsBrowser - ^ self useUniformColors - ifTrue: [ self defaultWindowColour ] - ifFalse: [ (Colour r: 0.869 g: 0.753 b: 1.0) duller ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/16/2011 08:13' prior: 16935608! - workspace - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Colour h: 60.0 s: 0.73 v: 0.72 ]! ! -!Theme methodsFor: 'widget colors' stamp: 'jmv 5/23/2012 18:49' prior: 16935614! - acceptButton - - ^ self buttonColorFrom: - (self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Colour r: 0.2 g: 0.6 b: 0.1 ])! ! -!Theme methodsFor: 'widget colors' stamp: 'jmv 5/23/2012 18:51' prior: 16935621! - cancelButton - - ^ self buttonColorFrom: - (self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Colour r: 0.8 g: 0.2 b: 0.2 ])! ! -!Theme methodsFor: 'widget colors' stamp: 'cbr 10/10/2012 23:36' prior: 16935647! - textPane - ^Colour white! ! -!SHTextStylerST80 class methodsFor: 'style table' stamp: 'pb 5/4/2016 17:44' prior: 16903544! - initialTextAttributes - | d element color emphasis attrArray | - d _ IdentityDictionary new. - self styleTable do: [ :each | - element _ each first. - color _ each at: 2 ifAbsent: nil. - color _ color ifNotNil: [ Colour colorFrom: color ]. - emphasis _ each at: 3 ifAbsent: nil. - attrArray _ self attributeArrayForColor: color emphasis: emphasis. - attrArray notEmpty ifTrue: [ - d at: element put: attrArray ]]. - ^ d! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3106-ChangeReferencesToColour-JuanVuletich-2017Jun19-11h07m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3106] on 19 June 2017 at 12:18:58 pm'! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/19/2017 12:18:51' prior: 50345518! - * aNumber - "Answer this color with its RGB multiplied by the given number. " - " - (Colour brown *2) display - " - ^ (Colour new - setRed: (self red * aNumber min: 1.0 max: 0.0) - green: (self green * aNumber min: 1.0 max: 0.0) - blue: (self blue * aNumber min: 1.0 max: 0.0)) - alpha: self alpha! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/19/2017 12:18:50' prior: 50349795! - * aNumber - "Answer this color with its RGB multiplied by the given number. " - " - (Color brown *2) display - " - ^ (Colour new - setRed: (self red * aNumber min: 1.0 max: 0.0) - green: (self green * aNumber min: 1.0 max: 0.0) - blue: (self blue * aNumber min: 1.0 max: 0.0) - colorSpace: colorSpace) - alpha: self alpha! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3107-KeepAlphaOnColorMultiply-JuanVuletich-2017Jun19-12h18m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3106] on 19 June 2017 at 11:52:30 am'! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - -| all | -all := Color allInstances. -all elementsForwardIdentityTo: (all collect: [ :c | c * 1 ]). -all := TranslucentColor allInstances. -all elementsForwardIdentityTo: (all collect: [ :c | c * 1 ]).! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3108-MigrateInstancesToColour-JuanVuletich-2017Jun19-11h51m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3103] on 19 June 2017 at 11:15:55 am'! - -TranslucentColour removeSelector: #setRed:green:blue:alpha:colorSpace:! - -TranslucentColour removeSelector: #setRed:green:blue:alpha:colorSpace:! - -Colour removeSelector: #floatRGB! - -Colour removeSelector: #floatRGB! - -Colour removeSelector: #setRed:green:blue:colorSpace:! - -Colour removeSelector: #setRed:green:blue:colorSpace:! - -Smalltalk removeClassNamed: #Color! - -Smalltalk removeClassNamed: #Color! - -Smalltalk removeClassNamed: #TranslucentColor! - -Smalltalk removeClassNamed: #TranslucentColor! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3109-removeColor-JuanVuletich-2017Jun19-11h11m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3108] on 19 June 2017 at 11:58:54 am'! - -FloatArray variableWordSubclass: #Color - instanceVariableNames: '' - classVariableNames: 'CachedColormaps ColorNamesDict FromGrayColormaps GrayToIndexMap IndexedColors MaskingMap ToGrayColormaps' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -!classDefinition: #Color category: #'Graphics-Primitives'! -FloatArray variableWordSubclass: #Color - instanceVariableNames: '' - classVariableNames: 'CachedColormaps ColorNamesDict FromGrayColormaps GrayToIndexMap IndexedColors MaskingMap ToGrayColormaps' - poolDictionaries: '' - category: 'Graphics-Primitives'! -!Color commentStamp: 'jmv 6/18/2017 20:14:31' prior: 0! - This class represents abstract color, regardless of the depth of bitmap it will be shown in. At the very last moment a Color is converted to a pixelValue that depends on the depth of the actual Bitmap inside the Form it will be used with. The supported depths (in bits) are 1, 2, 4, 8, 16, and 32. The number of actual colors at these depths are: 2, 4, 16, 256, 32768, and 16 million. (See comment in BitBlt.) To change the depth of the Display and set how many colors you can see, execute: (Display newDepth: 8). (See comment in DisplayMedium) - Color is represented as the amount of light in red, green, and blue. White is (1.0, 1.0, 1.0) and black is (0, 0, 0). Pure red is (1.0, 0, 0). These colors are "additive". Think of Color's instance variables as: - r amount of red, a Float between 0.0 and 1.0. - g amount of green, a Float between 0.0 and 1.0. - b amount of blue, a Float between 0.0 and 1.0. - Many colors are named. You find a color by name by sending a message to class Color, for example (Color lightBlue). Also, (Color red: 0.2 green: 0.6 blue: 1.0) or (Color r: 0.2 g: 0.6 b: 1.0) creates a color. (see below) - A color is essentially immutable. Once you set red, green, and blue, you cannot change them. Instead, create a new Color and use it. - Applications such as contour maps and bar graphs will want to display one of a set of shades based on a number. Convert the range of this number to an integer from 1 to N. Then call (Color green lightShades: N) to get an Array of colors from white to green. Use the Array messages at:, atPin:, or atWrap: to pull out the correct color from the array. atPin: gives the first (or last) color if the index is out of range. atWrap: wraps around to the other end if the index is out of range. - Here are some fun things to run in when your screen has color: - Pen new mandala: 30 diameter: Display height-100. - Pen new web "Draw with the mouse, opt-click to end" - Display fillWhite. Pen new hilberts: 5. - Form toothpaste: 30 "Draw with mouse, opt-click to end" - -Messages: - mixed: proportion with: aColor Answer this color mixed with the given color additively. The proportion, a number between 0.0 and 1.0, determines what what fraction of the receiver to use in the mix. - - + add two colors - - subtract two colors - * multiply the values of r, g, b by a number or an Array of factors. ((Color named: #white) * 0.3) gives a darkish gray. (aColor * #(0 0 0.9)) gives a color with slightly less blue. - / divide a color by a factor or an array of three factors. - - hue Returns the hue of the color. On a wheel from 0 to 360 with pure red at 0 and again at 360. - saturation Returns the saturation of the color. 0.0 to 1.0 - brightness Returns the brightness of the color. 0.0 to 1.0 - - name Look to see if this Color has a name. - display Show a swatch of this color tracking the cursor. - - lightShades: thisMany An array of thisMany colors from white to the receiver. - darkShades: thisMany An array of thisMany colors from black to the receiver. Array is of length num. - mix: color2 shades: thisMany An array of thisMany colors from the receiver to color2. - wheel: thisMany An array of thisMany colors around the color wheel starting and ending at the receiver. - - pixelValueForDepth: d Returns the bits that appear be in a Bitmap of this depth for this color. Represents the nearest available color at this depth. Normal users do not need to know which pixelValue is used for which color. - -Messages to Class Color. - red: r green: g blue: b Return a color with the given r, g, and b components. - r: g: b: Same as above, for fast typing. - - hue: h saturation: s brightness: b Create a color with the given hue, saturation, and brightness. - - pink - blue - red ... Many colors have messages that return an instance of Color. - canUnderstand: #brown Returns true if #brown is a defined color. - names An OrderedCollection of the names of the colors. - named: #notAllThatGray put: aColor Add a new color to the list and create an access message and a class variable for it. - fromUser Shows the palette of colors available at this display depth. Click anywhere to return the color you clicked on. - - hotColdShades: thisMany An array of thisMany colors showing temperature from blue to red to white hot. - - stdColorsForDepth: d An Array of colors available at this depth. For 16 bit and 32 bits, returns a ColorGenerator. It responds to at: with a Color for that index, simulating a very big Array. - - colorFromPixelValue: value depth: d Returns a Color whose bit pattern (inside a Bitmap) at this depth is the number specified. Normal users do not need to use this. - -(See also comments in these classes: Form, Bitmap, BitBlt) - -Default colorSpace is #sRGB. Subclasses might use other color spaces! - -Color variableWordSubclass: #TranslucentColor - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -!classDefinition: #TranslucentColor category: #'Graphics-Primitives'! -Color variableWordSubclass: #TranslucentColor - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Primitives'! -!TranslucentColor commentStamp: '' prior: 0! - A TranslucentColor behaves just like a normal color, except that it will pack its alpha value into the fourth position. This allows creating forms with translucency for use with the alpha blend function of BitBlt. An alpha of zero is transparent, and 1.0 is opaque.! -!Color methodsFor: 'access' stamp: 'jmv 1/31/2011 09:25'! - alpha - "Return the opacity ('alpha') value of opaque so that normal colors can be compared to TranslucentColors." - - ^ 1.0 -! ! -!Color methodsFor: 'access' stamp: 'jmv 6/18/2017 20:35:34'! - blue - "Return the blue component of this color, a float in the range [0.0..1.0]." - - ^ self at: 3! ! -!Color methodsFor: 'access' stamp: 'jmv 6/18/2017 20:33:10'! - brightness - "Return the brightness of this color, a float in the range [0.0..1.0]. - Color red brightness - " - - "Do not include alpha if TranslucentColor" - ^ (self red max: self green) max: self blue! ! -!Color methodsFor: 'access' stamp: 'jmv 6/18/2017 20:34:30'! - chroma - "Return the chroma of this color, a value between 0.0 and 1.0, somewhat related to saturation. - See http://en.wikipedia.org/wiki/HSL_and_HSV - Color red chroma - Color gray chroma - " - - | r g b max min | - r _ self red. - g _ self green. - b _ self blue. - max _ (r max: g) max: b. - min _ (r min: g) min: b. - ^max - min! ! -!Color methodsFor: 'access' stamp: 'jmv 6/18/2017 20:35:28'! - green - "Return the green component of this color, a float in the range [0.0..1.0]." - - ^ self at: 2! ! -!Color methodsFor: 'access' stamp: 'jmv 6/18/2017 20:31:54'! - hue - "Return the hue of this color, an angle in the range [0.0..360.0]. - Color orange hue - " - - | r g b max min span h | - r _ self red. - g _ self green. - b _ self blue. - max _ (r max: g) max: b. - min _ (r min: g) min: b. - span _ (max - min) asFloat. - span = 0.0 ifTrue: [ ^ 0.0 ]. - - r = max ifTrue: [ - h _ ((g - b) asFloat / span) * 60.0. - ] ifFalse: [ - g = max - ifTrue: [ h _ 120.0 + (((b - r) asFloat / span) * 60.0). ] - ifFalse: [ h _ 240.0 + (((r - g) asFloat / span) * 60.0). ]. - ]. - - ^h mod: 360.0! ! -!Color methodsFor: 'access' stamp: 'KenD 1/23/2013 18:19'! - icon - "Answer a swatch to display in a menu or browser" - ^self swatch! ! -!Color methodsFor: 'access' stamp: 'KenD 1/23/2013 18:17'! - iconOrThumbnailOfSize: aNumberOrPoint - "Answer an appropiate form to represent the receiver" - | form | - form := Form extent: aNumberOrPoint asPoint asPoint depth: 32. - form fillColor: self. - ^ form! ! -!Color methodsFor: 'access' stamp: 'jmv 4/19/2013 16:46'! - luminance - "Return the luminance of this color, a brightness value weighted by the human eye's color sensitivity." - - ^ ((299 * self red) + - (587 * self green) + - (114 * self blue)) / 1000! ! -!Color methodsFor: 'access' stamp: 'jmv 6/18/2017 20:35:25'! - red - "Return the red component of this color, a float in the range [0.0..1.0]." - - ^ self at: 1! ! -!Color methodsFor: 'access' stamp: 'jmv 6/18/2017 20:34:08'! - saturation - "Return the saturation of this color, a value between 0.0 and 1.0. - Color red saturation - Color gray saturation - " - - | r g b max min | - r _ self red. - g _ self green. - b _ self blue. - max _ (r max: g) max: b. - min _ (r min: g) min: b. - max = 0.0 ifTrue: [ ^0.0 ]. - ^max - min / max! ! -!Color methodsFor: 'access' stamp: 'KenD 1/23/2013 18:18'! - swatch - "Answer a swatch to display in a menu or browser" - ^self iconOrThumbnailOfSize: 16! ! -!Color methodsFor: 'conversions' stamp: 'sw 10/27/1999 10:51'! - asNontranslucentColor - ^ self! ! -!Color methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:20:07'! - bitPatternForDepth: depth - "Return a Bitmap, that best represents this color at the given depth. BitBlt calls this method to convert colors into Bitmaps." - "See also: pixelValueForDepth: -- value for single pixel - pixelWordForDepth: -- a 32-bit word filled with the pixel value" - - ^ Bitmap with: (self pixelWordForDepth: depth)! ! -!Color methodsFor: 'conversions' stamp: 'jmv 6/3/2016 17:28'! - bitPatternForGrayForm - "Return a Bitmap, that best represents this color at the given depth. BitBlt calls this method to convert colors into Bitmaps." - "See also: pixelValueForDepth: -- value for single pixel - pixelWordForDepth: -- a 32-bit word filled with the pixel value" - "Details: The pattern for the most recently requested depth is cached." - - ^Bitmap with: (self pixelWordFor: 8 filledWith: (self luminance * 255) rounded)! ! -!Color methodsFor: 'conversions' stamp: 'jmv 4/19/2013 16:17'! - closestPixelValue1 - "Return the nearest approximation to this color for a monochrome Form." - - "fast special cases" - self isBlack ifTrue: [^ 1]. "black" - self isWhite ifTrue: [^ 0]. "white" - - self luminance > 0.5 - ifTrue: [^ 0] "white" - ifFalse: [^ 1]. "black"! ! -!Color methodsFor: 'conversions' stamp: 'jmv 12/13/2014 16:18'! - closestPixelValue2 - "Return the nearest approximation to this color for a 2-bit deep Form." - - | lum | - "fast special cases" - self isBlack ifTrue: [^ 1]. "black" - self isWhite ifTrue: [^ 2]. "opaque white" - - lum _ self luminance. - lum < 0.2 ifTrue: [^ 1]. "black" - lum > 0.6 ifTrue: [^ 2]. "opaque white" - ^ 3 "50% gray" -! ! -!Color methodsFor: 'conversions' stamp: 'jmv 12/13/2014 16:17'! - closestPixelValue4 - "Return the nearest approximation to this color for a 4-bit deep Form." - - | bIndex | - "fast special cases" - self isBlack ifTrue: [^ 1]. "black" - self isWhite ifTrue: [^ 2]. "opaque white" - - self isRed ifTrue: [^ 4]. - self isGreen ifTrue: [^ 5]. - self isBlue ifTrue: [^ 6]. - self isCyan ifTrue: [^ 7]. - self isYellow ifTrue: [^ 8]. - self isMagenta ifTrue: [^ 9]. - - bIndex _ (self luminance * 8.0) rounded. "bIndex in [0..8]" - ^ #( - 1 "black" - 10 "1/8 gray" - 11 "2/8 gray" - 12 "3/8 gray" - 3 "4/8 gray" - 13 "5/8 gray" - 14 "6/8 gray" - 15 "7/8 gray" - 2 "opaque white" - ) at: bIndex + 1. -! ! -!Color methodsFor: 'conversions' stamp: 'jmv 4/21/2015 09:57'! - closestPixelValue8 - "Return the nearest approximation to this color for an 8-bit deep Form." - - "fast special cases" - self isBlack ifTrue: [^ 1]. "black" - self isWhite ifTrue: [^ 255]. "white" - - ^self saturation < 0.2 - ifTrue: [ - ^ self class grayToIndexMap at:(self green * 255) rounded + 1. "nearest gray" - ] - ifFalse: [ - "compute nearest entry in the color cube" - 40 + - ((self red * 5) rounded * 36) + - ((self blue * 5) rounded * 6) + - (self green * 5) rounded ]! ! -!Color methodsFor: 'conversions' stamp: 'di 9/2/97 20:21'! - dominantColor - ^ self! ! -!Color methodsFor: 'conversions' stamp: 'jmv 6/2/2016 14:48'! - indexInMap: aColorMap - "Return the index corresponding to this color in the given color map. RGB colors are truncated to 3-, 4-, or 5-bits per color component when indexing into such a colorMap. " - - aColorMap size = 2 ifTrue: [^ (self pixelValueForDepth: 1) + 1]. - aColorMap size = 4 ifTrue: [^ (self pixelValueForDepth: 2) + 1]. - aColorMap size = 16 ifTrue: [^ (self pixelValueForDepth: 4) + 1]. - aColorMap size = 256 ifTrue: [^ (self pixelValueForDepth: 8) + 1]. - aColorMap size = 512 ifTrue: [^ (self pixelValueForDepth: 9) + 1]. - aColorMap size = 4096 ifTrue: [^ (self pixelValueForDepth: 12) + 1]. - aColorMap size = 32768 ifTrue: [^ (self pixelValueForDepth: 15) + 1]. - self error: 'unknown pixel depth'. -! ! -!Color methodsFor: 'conversions' stamp: 'bf 4/18/2001 16:25'! - makeForegroundColor - "Make a foreground color contrasting with me" - ^self luminance >= 0.5 - ifTrue: [Color black] - ifFalse: [Color white]! ! -!Color methodsFor: 'conversions' stamp: 'jmv 6/2/2016 14:50'! - pixelValueForDepth: d - "Returns an integer representing the bits that appear in a single pixel of this color in a Form of the given depth. The depth must be one of 1, 2, 4, 8, 16, or 32. Contrast with pixelWordForDepth: and bitPatternForDepth:, which return either a 32-bit word packed with the given pixel value or a multiple-word Bitmap containing a pattern. The inverse is the class message colorFromPixelValue:depth:" - "Details: For depths of 8 or less, the result is a colorMap index. For depths of 16 and 32, it is a direct color value with 5 or 8 bits per color component." - "Transparency: The pixel value zero is reserved for transparent. For depths greater than 8 and less than 32 (no Indexed colors, no real alpha), black maps to the darkest possible blue. - Note that - Color transparent class = TranslucentColor - this special case is handled in TranslucentColor >> #pixelValueForDepth: - " - - | bitBltFakeBlack val | - d = 8 ifTrue: [^ self closestPixelValue8]. "common case" - d < 8 ifTrue: [ - d = 4 ifTrue: [^ self closestPixelValue4]. - d = 2 ifTrue: [^ self closestPixelValue2]. - d = 1 ifTrue: [^ self closestPixelValue1]]. - - d = 32 ifTrue: [ - "eight bits per component; top 8 bits set to all ones (opaque alpha)" - val _ LargePositiveInteger new: 4. - val at: 3 put: (self red * 255) rounded. - val at: 2 put: (self green * 255) rounded. - val at: 1 put: (self blue * 255) rounded. - val at: 4 put: 16rFF. "opaque alpha" - ^ val normalize]. - - "For the depth 16, pixelValue = 0 means transparent, black is represented as 16r8000 (rgb=0, pixelvalue !!= 0)." - (d = 16) | (d = 15) ifTrue: [ - "five bits per component; top bits ignored" - val _ ((self red * 31) rounded bitShift: 10) bitOr: - (((self green * 31) rounded bitShift: 5) bitOr: - ((self blue * 31) rounded)). - ^ val = 0 - ifTrue: [d = 16 ifTrue: [16r8000] ifFalse: [1]] - ifFalse: [val]]. - - "For the rest of the depths, pixelValue = 0 means transparent, and darkest blue is considered to be black." - bitBltFakeBlack := 1. "closest black that is not transparent in RGB - Not for depths <=8 (Indexed) or = 32 (RGBA)" - d = 12 ifTrue: [ "for indexing a color map with 4 bits per color component" - val _ ((self red * 15) rounded bitShift: 8) bitOr: - (((self green * 15) rounded bitShift: 4) bitOr: - ((self blue * 15) rounded)). - ^ val = 0 ifTrue: [bitBltFakeBlack] ifFalse: [val]]. - - d = 9 ifTrue: [ "for indexing a color map with 3 bits per color component" - val _ ((self red * 7) rounded bitShift: 6) bitOr: - (((self green * 7) rounded bitShift: 3) bitOr: - ((self blue * 7) rounded)). - ^ val = 0 ifTrue: [bitBltFakeBlack] ifFalse: [val]]. - - self error: 'unknown pixel depth: ', d printString! ! -!Color methodsFor: 'conversions' stamp: 'di 11/30/1998 09:03'! - pixelWordFor: depth filledWith: pixelValue - "Return to a 32-bit word that concatenates enough copies of the given pixel value to fill the word (i.e., 32/depth copies). Depth should be one of 1, 2, 4, 8, 16, or 32. The pixel value should be an integer in 0..2^depth-1." - | halfword | - depth = 32 ifTrue: [^ pixelValue]. - depth = 16 - ifTrue: [halfword _ pixelValue] - ifFalse: [halfword _ pixelValue * - (#(16rFFFF "replicates at every bit" - 16r5555 - "replicates every 2 bits" - 16r1111 - - - "replicates every 4 bits" - 16r0101) at: depth) "replicates every 8 bits"]. - ^ halfword bitOr: (halfword bitShift: 16)! ! -!Color methodsFor: 'conversions'! - pixelWordForDepth: depth - "Return to a 32-bit word that concatenates enough copies of the receiver's pixel value to fill the word (i.e., 32/depth copies). Depth should be one of 1, 2, 4, 8, 16, or 32. The pixel value should be an integer in 0..2^depth-1." - - | pixelValue | - pixelValue _ self pixelValueForDepth: depth. - ^ self pixelWordFor: depth filledWith: pixelValue -! ! -!Color methodsFor: 'equality' stamp: 'jmv 6/18/2017 20:38:11'! - diff: theOther - "Returns a number between 0.0 and 1.0. - Color gray diff: Color red - " - ^(self - theOther ) abs sum / self size! ! -!Color methodsFor: 'equality' stamp: 'KenD 12/8/2013 08:35'! - rgbDistance: otherColor - "Compare two colors in distance" -" - ^ (self hue - otherColor hue) abs + - (self saturation - otherColor saturation) abs *10 + - (self brightness - otherColor brightness) abs -" - "See http://www.compuphase.com/cmetric.htm" - | meanRed deltaRed deltaGreen deltaBlue | - meanRed := (self red + otherColor red) abs / 2. - deltaRed := (self red - otherColor red) abs. - deltaGreen := (self green - otherColor green) abs. - deltaBlue := (self blue - otherColor blue) abs. - - ^ ( ((2 + (meanRed / 256)) * (deltaRed * deltaRed)) + - (4 * deltaGreen) + - ((2 + ((255 - meanRed) / 256)) * deltaBlue) - ) sqrt! ! -!Color methodsFor: 'groups of shades' stamp: 'tk 6/18/96'! - darkShades: thisMany - "An array of thisMany colors from black to the receiver. Array is of length num. Very useful for displaying color based on a variable in your program. " - "Color showColors: (Color red darkShades: 12)" - - ^ self class black mix: self shades: thisMany -! ! -!Color methodsFor: 'groups of shades' stamp: 'tk 6/18/96'! - lightShades: thisMany - "An array of thisMany colors from white to self. Very useful for displaying color based on a variable in your program. " - "Color showColors: (Color red lightShades: 12)" - - ^ self class white mix: self shades: thisMany -! ! -!Color methodsFor: 'groups of shades' stamp: 'tk 6/18/96'! - mix: color2 shades: thisMany - "Return an array of thisMany colors from self to color2. Very useful for displaying color based on a variable in your program. " - "Color showColors: (Color red mix: Color green shades: 12)" - - | redInc greenInc blueInc rr gg bb c out | - thisMany = 1 ifTrue: [^ Array with: color2]. - redInc _ color2 red - self red / (thisMany-1). - greenInc _ color2 green - self green / (thisMany-1). - blueInc _ color2 blue - self blue / (thisMany-1). - rr _ self red. gg _ self green. bb _ self blue. - out _ (1 to: thisMany) collect: [:num | - c _ Color r: rr g: gg b: bb. - rr _ rr + redInc. - gg _ gg + greenInc. - bb _ bb + blueInc. - c]. - out at: out size put: color2. "hide roundoff errors" - ^ out -! ! -!Color methodsFor: 'groups of shades' stamp: 'di 10/23/2000 09:45'! - wheel: thisMany - "An array of thisMany colors around the color wheel starting at self and ending all the way around the hue space just before self. Array is of length thisMany. Very useful for displaying color based on a variable in your program. " - - | sat bri hue step c | - sat _ self saturation. - bri _ self brightness. - hue _ self hue. - step _ 360.0 / (thisMany max: 1). - ^ (1 to: thisMany) collect: [:num | - c _ Color h: hue s: sat v: bri. "hue is taken mod 360" - hue _ hue + step. - c]. -" -(Color wheel: 8) withIndexDo: [:c :i | Display fill: (i*10@20 extent: 10@20) fillColor: c] -"! ! -!Color methodsFor: 'named colors' stamp: 'KenD 12/8/2013 14:59'! - closestAssocFrom: aColorDict - "Answer closest associated color in aColorDict" -" - ((Color r: 0.3 g: 0.2 b: 0.8) closestAssocFrom: (Color colorNamesDict)) explore. -" - "Filter values for those close in hue (cheap test) then use rgbDistance" - | closeInHue isClose close distance myHue | - closeInHue := OrderedCollection new. - myHue := self hue. - isClose := [ :assoc | | delta | - delta := ((assoc value hue) - myHue) abs. - (delta < 20) or: [ delta > 340 ] "hues within 20 degrees" - ]. - aColorDict associationsDo: [ :assoc | - (isClose value: assoc) ifTrue: [ closeInHue add: assoc ] - ]. - - close := nil. - distance := 1000. "big" - (closeInHue size > 0) - ifFalse: [ "fallback -- no color really close" - aColorDict associationsDo: [ :assoc | | dist | - dist := self rgbDistance: (assoc value). - (dist < distance) ifTrue: [distance := dist. close := assoc] - ] - ] - ifTrue: [ closeInHue do: [ :assoc | | dist | - dist := self rgbDistance: (assoc value). - (dist < distance) ifTrue: [distance := dist. close := assoc] - ] - ]. - - ^ close! ! -!Color methodsFor: 'named colors' stamp: 'KenD 1/26/2013 16:33'! - closestColor - "Answer the closest matching color in the colorNames dictionary" - -" - (Color red lighter lighter) closestColor explore. -" - ^ self closestColorFrom: (Color colorNamesDict)! ! -!Color methodsFor: 'named colors' stamp: 'KenD 1/26/2013 16:36'! - closestColorAssociation - "Answer this color's closest name->color match." - -" - (Color blue lighter lighter) closestColorAssociation explore. -" - ^ self closestAssocFrom: (Color colorNamesDict)! ! -!Color methodsFor: 'named colors' stamp: 'KenD 1/25/2013 14:31'! - closestColorFrom: aColorDict - "Answer closest associated color" -" - ((Color lightBlue) closestColorFrom: (Color css2NamedColors)) explore.. -" - ^(self closestAssocFrom: aColorDict) value! ! -!Color methodsFor: 'named colors' stamp: 'KenD 1/26/2013 16:36'! - closestColorName - "Answer the name symbol of the closest matching color in the colorNames dictionary" -" - (Color red lighter lighter) closestColor name. -" - - ^ self closestNameFrom: (Color colorNamesDict)! ! -!Color methodsFor: 'named colors' stamp: 'KenD 1/26/2013 16:36'! - closestNameFrom: aColorDict - "Answer closest associated color name" -" - ((Color lightBlue) closestNameFrom: (Color namedColors)) print. -" - ^(self closestAssocFrom: aColorDict) key! ! -!Color methodsFor: 'other' stamp: 'KenD 7/18/2015 20:41'! - colorName - "Return this color's name, or nil if it has no name. Only returns a name if it exactly matches the named color." - - ^(Color colorNamesDict keyAtValue: self ifAbsent: [nil]) -! ! -!Color methodsFor: 'other' stamp: 'KenD 7/18/2015 20:46'! - name - "Return this color's name, or description if unnamed." - - ^ self printString -! ! -!Color methodsFor: 'printing' stamp: 'jmv 2/13/2014 13:41'! - hexStringRGB - " - Color fromUser hexStringRGB - " - ^String streamContents: [ :strm | - (self red * 255) rounded printOn: strm base: 16 length: 2 padded: true. - (self green * 255) rounded printOn: strm base: 16 length: 2 padded: true. - (self blue * 255) rounded printOn: strm base: 16 length: 2 padded: true ]! ! -!Color methodsFor: 'printing' stamp: 'KenD 7/18/2015 20:42'! - printOn: aStream - self colorName ifNotNil: [ :name | - ^ aStream - nextPutAll: 'Color '; - nextPutAll: name]. - self storeOn: aStream. -! ! -!Color methodsFor: 'printing' stamp: 'KenD 7/18/2015 20:44'! - printString - "Answer a String whose characters are a description of the receiver." - - ^ String streamContents: [ :stream | self printOn: stream ]! ! -!Color methodsFor: 'printing' stamp: 'mir 7/21/1999 11:41'! - storeArrayOn: aStream - - aStream nextPutAll: '#('. - self storeArrayValuesOn: aStream. - aStream nextPutAll: ') ' -! ! -!Color methodsFor: 'printing' stamp: 'jmv 1/5/2014 21:04'! - storeArrayValuesOn: aStream - - - self red printOn: aStream fractionDigits: 3. - aStream space. - self green printOn: aStream fractionDigits: 3. - aStream space. - self blue printOn: aStream fractionDigits: 3 - -! ! -!Color methodsFor: 'printing' stamp: 'jmv 1/5/2014 21:01'! - storeOn: aStream - - aStream - nextPut: $(; - nextPutAll: self class name; - nextPutAll: ' r: '. - self red printOn: aStream fractionDigits: 3. - aStream nextPutAll: ' g: '. - self green printOn: aStream fractionDigits: 3. - aStream nextPutAll: ' b: '. - self blue printOn: aStream fractionDigits: 3. - aStream nextPut: $)! ! -!Color methodsFor: 'queries' stamp: 'jmv 6/18/2017 20:40:55'! - isBlack - "Return true if the receiver represents black" - (self at: 1) = 0.0 ifFalse: [ ^ false ]. - (self at: 2) = 0.0 ifFalse: [ ^ false ]. - (self at: 3) = 0.0 ifFalse: [ ^ false ]. - ^ true! ! -!Color methodsFor: 'queries' stamp: 'ar 4/20/2001 04:33'! - isOpaque - ^true! ! -!Color methodsFor: 'queries'! - isTransparent - - ^ false -! ! -!Color methodsFor: 'queries' stamp: 'jmv 6/18/2017 20:40:46'! - isWhite - "Return true if the receiver represents white" - (self at: 1) = 1.0 ifFalse: [ ^ false ]. - (self at: 2) = 1.0 ifFalse: [ ^ false ]. - (self at: 3) = 1.0 ifFalse: [ ^ false ]. - ^ true! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:35'! - isBlue - "Am I considered Blue?" - - ^self blue > (self green + 0.3) - and: [self blue > (self red + 0.3)] - and: [(self green - self red) abs < 0.4]! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:37'! - isBlueGreen - "Am I considered BlueGreen ?" - - ^self green > self red - and: [self red < 0.3] - and: [(self green - self blue) abs < 0.1]! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:50'! - isBright - "Am I considered a Bright color ?" - - ^self brightness > 0.6! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:40'! - isBrown - "Am I considered Brown ?" - - ^self red >= self green - and: [self green > self blue] - and: [(self red - self green) < 0.5] - and: [(self green - self blue) < 0.3]! ! -!Color methodsFor: 'selection' stamp: 'jmv 4/19/2013 17:14'! - isCyan - "Am I considered Cyan ?" - - ^self red < 0.05 - and: [(self green min: self blue) > 0.5] - and: [(self green - self blue) abs < 0.2]! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:50'! - isDark - "Am I considered a Dark color ?" - - ^self brightness < 0.5! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:42'! - isGray - "Am I considered Gray ?" - - ^(self red closeTo: self green) - and: [self blue closeTo: self green ]! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:38'! - isGreen - "Am I considered Green ?" - - ^self green > (self blue + 0.3) - and: [self blue > (self red + 0.3)]! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:40'! - isGrey - "Am I considered Grey ?" - - ^self isGray! ! -!Color methodsFor: 'selection' stamp: 'jmv 4/19/2013 17:06'! - isLight - "Am I considered a Light color ?" - - ^self brightness > 0.6! ! -!Color methodsFor: 'selection' stamp: 'jmv 4/19/2013 17:13'! - isMagenta - "Am I considered Magenta ?" - - ^self green < 0.05 - and: [(self red min: self blue) > 0.5] - and: [(self red - self blue) abs < 0.2]! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:44'! - isOrange - "Am I considered Orange ?" - - ^self red > ((self green max: self blue) + 0.2) - and: [self green > (self blue + 0.2)]! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:45'! - isPastel - "Am I considered Pastel ?" - - ^self saturation < 0.4! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:46'! - isPink - "Am I considered Pink ?" - - ^self red > ((self green max: self blue) + 0.3) - and: [self blue > (self green + 0.2)]! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:47'! - isRed - "Am I considered Red ?" - - ^self red > (self green + 0.4) - and: [self red > (self blue + 0.6)] - and: [(self green - self blue) abs < 0.4]! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:55'! - isSaturated - "Am I considered to be a Saturated color ?" - - ^self saturation > 0.6! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:49'! - isYellow - "Am I considered Yellow ?" - - ^self blue < 0.05 - and: [(self red min: self green) > 0.5] - and: [(self red - self green) abs < 0.2]! ! -!Color methodsFor: 'testing' stamp: 'jmv 12/2/2010 08:38'! - is: aSymbol - ^ aSymbol == #Color or: [ super is: aSymbol ]! ! -!Color methodsFor: 'testing' stamp: 'jmv 2/10/2011 21:46'! - mightBeTranslucent - "For Colors, answer if actually translucent or not." - ^self isOpaque not! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:56:14'! - * aNumber - "Answer this color with its RGB multiplied by the given number. " - " - (Color brown *2) display - " - ^ (Color new - setRed: (self red * aNumber min: 1.0 max: 0.0) - green: (self green * aNumber min: 1.0 max: 0.0) - blue: (self blue * aNumber min: 1.0 max: 0.0)) - alpha: self alpha! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:56:18'! - + aColor - "Answer this color mixed with the given color in an additive color space. " - " - (Color blue + Color green) display - " - ^ Color new - setRed: (self red + aColor red min: 1.0 max: 0.0) - green: (self green + aColor green min: 1.0 max: 0.0) - blue: (self blue + aColor blue min: 1.0 max: 0.0)! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:56:22'! - - aColor - "Answer aColor is subtracted from the given color in an additive color space. " - " - (Color white - Color red) display - " - ^ Color new - setRed: (self red - aColor red min: 1.0 max: 0.0) - green: (self green - aColor green min: 1.0 max: 0.0) - blue: (self blue - aColor blue min: 1.0 max: 0.0)! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:56:26'! - / aNumber - "Answer this color with its RGB divided by the given number. " - " - (Color red / 2) display - " - ^ Color new - setRed: (self red / aNumber min: 1.0 max: 0.0) - green: (self green / aNumber min: 1.0 max: 0.0) - blue: (self blue / aNumber min: 1.0 max: 0.0)! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:50'! - adjustBrightness: brightness - "Adjust the relative brightness of this color. (lowest value is 0.005 so that hue information is not lost)" - - ^ Color - h: self hue - s: self saturation - v: (self brightness + brightness min: 1.0 max: 0.005) - alpha: self alpha! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:51'! - adjustSaturation: saturation brightness: brightness - "Adjust the relative saturation and brightness of this color. (lowest value is 0.005 so that hue information is not lost)" - - ^ Color - h: self hue - s: (self saturation + saturation min: 1.0 max: 0.005) - v: (self brightness + brightness min: 1.0 max: 0.005) - alpha: self alpha! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:10:41'! - alpha: alphaValue - "Return a new TranslucentColor with the given amount of opacity ('alpha')." - alphaValue = 1.0 ifFalse: [ - ^ TranslucentColor new - setRed: self red - green: self green - blue: self blue - alpha: alphaValue ]! ! -!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 11:55'! - alphaMixed: proportion with: aColor - "Answer this color mixed with the given color. The proportion, a number - between 0.0 and 1.0, determines what what fraction of the receiver to - use in the mix. For example, 0.9 would yield a color close to the - receiver. This method uses RGB interpolation; HSV interpolation can lead - to surprises. Mixes the alphas (for transparency) also." - - | frac1 frac2 | - frac1 _ proportion asFloat min: 1.0 max: 0.0. - frac2 _ 1.0 - frac1. - ^ Color - r: self red * frac1 + (aColor red * frac2) - g: self green * frac1 + (aColor green * frac2) - b: self blue * frac1 + (aColor blue * frac2) - alpha: self alpha * frac1 + (aColor alpha * frac2)! ! -!Color methodsFor: 'transformations' stamp: 'RAA 6/2/2000 08:47'! - atLeastAsLuminentAs: aFloat - - | revisedColor | - revisedColor _ self. - [revisedColor luminance < aFloat] whileTrue: [revisedColor _ revisedColor slightlyLighter]. - ^revisedColor -! ! -!Color methodsFor: 'transformations' stamp: 'nk 3/8/2004 09:43'! - atMostAsLuminentAs: aFloat - - | revisedColor | - revisedColor _ self. - [revisedColor luminance > aFloat] whileTrue: [revisedColor _ revisedColor slightlyDarker]. - ^revisedColor -! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/23/2002 01:38'! - blacker - - ^ self alphaMixed: 0.8333 with: Color black -! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:54'! - dansDarker - "Return a darker shade of the same color. - An attempt to do better than the current darker method. - (now obsolete, since darker has been changed to do this. -dew)" - ^ Color h: self hue s: self saturation - v: (self brightness - 0.16 max: 0.0)! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:40'! - darker - "Answer a darker shade of this color." - - ^ self adjustBrightness: -0.08! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/8/2002 00:13'! - duller - - ^ self adjustSaturation: -0.03 brightness: -0.2! ! -!Color methodsFor: 'transformations' stamp: 'dew 1/23/2002 20:19'! - lighter - "Answer a lighter shade of this color." - - ^ self adjustSaturation: -0.03 brightness: 0.08! ! -!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 12:00'! - mixed: proportion with: aColor - "Mix with another color and do not preserve transpareny. Only use this for extracting the RGB value and mixing it. All other callers should use instead: - aColor alphaMixed: proportion with: anotherColor - " - - | frac1 frac2 | - frac1 _ proportion asFloat min: 1.0 max: 0.0. - frac2 _ 1.0 - frac1. - ^ Color - r: self red * frac1 + (aColor red * frac2) - g: self green * frac1 + (aColor green * frac2) - b: self blue * frac1 + (aColor blue * frac2)! ! -!Color methodsFor: 'transformations' stamp: 'dew 1/19/2002 01:29'! - muchDarker - - ^ self alphaMixed: 0.5 with: Color black -! ! -!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 12:07'! - muchLighter - - ^ self alphaMixed: 0.233 with: Color white -! ! -!Color methodsFor: 'transformations' stamp: 'ar 6/19/1999 00:36'! - negated - "Return an RGB inverted color" - ^Color - r: 1.0 - self red - g: 1.0 - self green - b: 1.0 - self blue! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:37:53'! - orColorUnlike: theOther - "If this color is a lot like theOther, then return its complement, otherwide, return self" - - ^ (self diff: theOther) < 0.3 - ifTrue: [theOther negated] - ifFalse: [self]! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:42'! - paler - "Answer a paler shade of this color." - - ^ self adjustSaturation: -0.09 brightness: 0.09 -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 9/10/2009 18:41'! - quiteBlacker - - ^ self alphaMixed: 0.8 with: Color black -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 9/10/2009 18:44'! - quiteWhiter - - ^ self alphaMixed: 0.6 with: Color white! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:43'! - slightlyDarker - - ^ self adjustBrightness: -0.03 -! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:43'! - slightlyLighter - - ^ self adjustSaturation: -0.01 brightness: 0.03! ! -!Color methodsFor: 'transformations' stamp: 'dew 1/19/2002 01:25'! - slightlyWhiter - - ^ self alphaMixed: 0.85 with: Color white -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 5/7/2012 15:05'! - twiceDarker - "Answer a significantly darker shade of this color." - - ^ self adjustSaturation: 0.076 brightness: -0.15! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:45'! - twiceLighter - "Answer a significantly lighter shade of this color." - - ^ self adjustSaturation: -0.06 brightness: 0.15! ! -!Color methodsFor: 'transformations' stamp: 'jmv 8/23/2009 23:24'! - veryMuchDarker - - ^ self alphaMixed: 0.25 with: Color black -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 7/28/2016 15:43:04'! - veryMuchLighter - - ^ self alphaMixed: 0.07 with: Color white! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/23/2002 01:38'! - whiter - - ^ self alphaMixed: 0.8333 with: Color white -! ! -!Color methodsFor: 'private'! - attemptToMutateError - "A color is immutable. Once a color's red, green, and blue have been initialized, you cannot change them. Instead, create a new Color and use it." - - self error: 'Color objects are immutable once created' -! ! -!Color methodsFor: 'private' stamp: 'jmv 6/18/2017 20:29:32'! - basicSetRed: r green: g blue: b - "Initialize this color's r, g, and b components to the given values in the range [0.0..1.0]." - - self - at: 1 put: r; - at: 2 put: g; - at: 3 put: b! ! -!Color methodsFor: 'private' stamp: 'jmv 6/18/2017 20:15:44'! - setHue: hue chroma: chroma brightness: brightness - "Initialize this color to the given hue, chroma, and luma. See the comment in the instance creation method for details. - http://en.wikipedia.org/wiki/HSL_and_HSV - hue belongs in [0.0, 360.0) - chroma and luma belongs in [0.0, 1.0] - " - - | x hf i r1 g1 b1 m | - hf _ hue \\ 360. - i _ hf // 60. "integer part of hue" - x _ (hf \\ 60) / 60.0 . "fractional part of hue" - x _ x \\ 2 . - i \\ 2 = 1 ifTrue: [ x _ 1.0 - x ]. - x _ chroma * x. - - 0 = i ifTrue: [ r1 _ chroma. g1 _ x. b1 _ 0.0 ]. - 1 = i ifTrue: [ r1 _ x. g1 _ chroma. b1 _ 0.0 ]. - 2 = i ifTrue: [ r1 _ 0.0. g1 _ chroma. b1 _ x ]. - 3 = i ifTrue: [ r1 _ 0.0. g1 _ x. b1 _ chroma ]. - 4 = i ifTrue: [ r1 _ x. g1 _ 0.0. b1 _ chroma ]. - 5 = i ifTrue: [ r1 _ chroma. g1 _ 0.0. b1 _ x ]. - - m _ brightness - ((r1 max: g1) max: b1). - m < 0.0 - ifTrue: [ ^nil ]. "No color exists with required parameters" - r1 _ r1 + m. - r1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - g1 _ g1 + m. - g1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - b1 _ b1 + m. - b1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - self setRed: r1 green: g1 blue: b1! ! -!Color methodsFor: 'private' stamp: 'jmv 6/18/2017 20:15:49'! - setHue: hue chroma: chroma luminance: luma - "Initialize this color to the given hue, chroma, and luma. See the comment in the instance creation method for details. - http://en.wikipedia.org/wiki/HSL_and_HSV - hue belongs in [0.0, 360.0) - chroma and luma belongs in [0.0, 1.0] - " - - | x hf i r1 g1 b1 m | - - hf _ hue \\ 360. - i _ hf // 60. "integer part of hue" - x _ (hf \\ 60) / 60.0 . "fractional part of hue" - x _ x \\ 2 . - i \\ 2 = 1 ifTrue: [ x _ 1.0 - x ]. - x _ chroma * x. - - 0 = i ifTrue: [ r1 _ chroma. g1 _ x. b1 _ 0.0 ]. - 1 = i ifTrue: [ r1 _ x. g1 _ chroma. b1 _ 0.0 ]. - 2 = i ifTrue: [ r1 _ 0.0. g1 _ chroma. b1 _ x ]. - 3 = i ifTrue: [ r1 _ 0.0. g1 _ x. b1 _ chroma ]. - 4 = i ifTrue: [ r1 _ x. g1 _ 0.0. b1 _ chroma ]. - 5 = i ifTrue: [ r1 _ chroma. g1 _ 0.0. b1 _ x ]. - - m _ luma - (0.299*r1) - (0.587*g1) - (0.114*b1). - m < 0.0 - ifTrue: [ ^nil ]. "No color exists with required parameters" - r1 _ r1 + m. - r1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - g1 _ g1 + m. - g1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - b1 _ b1 + m. - b1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - self setRed: r1 green: g1 blue: b1! ! -!Color methodsFor: 'private' stamp: 'jmv 6/18/2017 20:16:07'! - setHue: hue saturation: saturation brightness: brightness - "Initialize this color to the given hue, saturation, and brightness. See the comment in the instance creation method for details." - - | s v hf i f p q t | - s _ saturation asFloat min: 1.0 max: 0.0. - v _ brightness asFloat min: 1.0 max: 0.0. - hf _ hue \\ 360. - i _ hf // 60. "integer part of hue" - f _ (hf \\ 60) / 60.0. "fractional part of hue" - - p _ (1.0 - s) * v. - q _ (1.0 - (s * f)) * v. - t _ (1.0 - (s * (1.0 - f))) * v. - - 0 = i ifTrue: [ ^ self setRed: v green: t blue: p ]. - 1 = i ifTrue: [ ^ self setRed: q green: v blue: p ]. - 2 = i ifTrue: [ ^ self setRed: p green: v blue: t ]. - 3 = i ifTrue: [ ^ self setRed: p green: q blue: v ]. - 4 = i ifTrue: [ ^ self setRed: t green: p blue: v ]. - 5 = i ifTrue: [ ^ self setRed: v green: p blue: q ]. - - self error: 'implementation error'! ! -!Color methodsFor: 'private' stamp: 'jmv 6/18/2017 20:13:04'! - setRed: r green: g blue: b - - self basicSetRed: r green: g blue: b! ! -!Color methodsFor: 'private' stamp: 'jmv 6/18/2017 20:29:48'! - setRed: r green: g blue: b range: range - "Initialize this color's r, g, and b components to the given values in the range [0..r]." - - self basicSetRed: r green: g blue: b. - self /= range! ! -!Color methodsFor: 'as yet unclassified' stamp: 'jmv 8/15/2015 18:23'! - color - ^ self! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 9/17/2015 15:22'! - clipR: r g: g b: b - "Return a color with the given r, g, and b components in the range [0.0..1.0]. - Clip if necessary" - - ^ self - r: (r min: 1.0 max: 0.0) - g: (g min: 1.0 max: 0.0) - b: (b min: 1.0 max: 0.0)! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 4/2/2016 23:05'! - colorFrom: parm - "Return an instantiated color from parm. If parm is already a color, return it, else return the result of my performing it if it's a symbol or, if it is a list, it can either be an array of three numbers, which will be interpreted as RGB values, or a list of symbols, the first of which is sent to me and then the others of which are in turn sent to the prior result, thus allowing entries of the form #(blue darker). Else just return the thing" - - | aColor firstParm | - (parm is: #Color) ifTrue: [ ^ parm ]. - parm isSymbol ifTrue: [ ^ self perform: parm ]. - (parm isSequenceableCollection and: [ parm size > 0 ]) - ifTrue: [ - firstParm _ parm first. - firstParm isNumber ifTrue: [ - ^ self fromRgbTriplet: parm]. - aColor _ self colorFrom: firstParm. - parm withIndexDo: [ :sym :ind | - ind > 1 ifTrue: [ - aColor _ aColor perform: sym ]]. - ^ aColor]. - ^ parm - -" -Color colorFrom: #(blue darker) -Color colorFrom: Color blue darker -Color colorFrom: #blue -Color colorFrom: #(0.0 0.0 1.0) -"! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/2/2016 15:04'! - colorFromPixelValue: p depth: d - "Convert a pixel value for the given display depth into a color." - "Details: For depths of 8 or less, the pixel value is simply looked up in a table. For greater depths, the color components are extracted and converted into a color." - "Warning: In BitBlt, a pixel with pixelValue = 0 is transparent. - Squeak usually assumes that r=g=b=0 => transparent. But this is false if we have alpha (opacity). - A color with r=g=b=0 and opacity = 255 is BLACK, not TRANSPARENT. - Squeak also answers darkest possible blue when asked for black. Again, this is not needed in 32 bits (with alpha). It is also not really needed for 16 bits as we have an extra, unused bit: 16r8000 is not zero, but rgb=0, and hence, black. - The real rule is that pixelValue=0 means transparent. - And that darkest blue must be used instead of black, but only for depths >8 and < 16 (no indexed colors, no alpha) - This method is updated to reflect that." - - | r g b alpha | - - d = 1 ifTrue: [^ self indexedColors at: (p bitAnd: 16r01) + 1]. - - "For the rest of the depths, pixelValue = 0 means transparent, and darkest blue is considered to be black." - p = 0 ifTrue: [ ^Color transparent ]. - - d = 8 ifTrue: [^ self indexedColors at: (p bitAnd: 16rFF) + 1]. - d = 4 ifTrue: [^ self indexedColors at: (p bitAnd: 16r0F) + 1]. - d = 2 ifTrue: [^ self indexedColors at: (p bitAnd: 16r03) + 1]. - - d = 32 ifTrue: [ - "eight bits per component; 8 bits of alpha" - alpha _ p bitShift: -24. - alpha = 0 ifTrue: [ ^Color transparent ]. - r _ (p bitShift: -16) bitAnd: 16rFF. - g _ (p bitShift: -8) bitAnd: 16rFF. - b _ p bitAnd: 16rFF. - ^alpha < 255 - ifTrue: [ (Color r: r g: g b: b range: 255) alpha: alpha asFloat / 255.0 ] - ifFalse: [ Color r: r g: g b: b range: 255 ]]. - - d = 16 ifTrue: [ - "five bits per component. The most significant bit, unused, allows having real black, without p being zero" - r _ (p bitShift: -10) bitAnd: 16r1F. - g _ (p bitShift: -5) bitAnd: 16r1F. - b _ p bitAnd: 16r1F. - ^ Color r: r g: g b: b range: 31]. - - d = 15 ifTrue: [ - "five bits per component" - r _ (p bitShift: -10) bitAnd: 16r1F. - g _ (p bitShift: -5) bitAnd: 16r1F. - b _ p bitAnd: 16r1F. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Color black ]. - ^ Color r: r g: g b: b range: 31]. - - d = 12 ifTrue: [ - "four bits per component" - r _ (p bitShift: -8) bitAnd: 16rF. - g _ (p bitShift: -4) bitAnd: 16rF. - b _ p bitAnd: 16rF. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Color black ]. - ^ Color r: r g: g b: b range: 15]. - - d = 9 ifTrue: [ - "three bits per component" - r _ (p bitShift: -6) bitAnd: 16r7. - g _ (p bitShift: -3) bitAnd: 16r7. - b _ p bitAnd: 16r7. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Color black ]. - ^ Color r: r g: g b: b range: 7]. - - self error: 'unknown pixel depth: ', d printString! ! -!Color class methodsFor: 'instance creation' stamp: 'sqr 10/15/2016 20:41:04'! - fromArray: colorDef - - | answer | - colorDef size = 0 ifTrue: [^self transparent]. - colorDef size between: 3 and: 4 :: ifFalse: [self error: 'Undefined color definition']. - answer _ self r: (colorDef at: 1) g: (colorDef at: 2) b: (colorDef at: 3). - ^colorDef size = 3 - ifTrue: [answer] - ifFalse: [answer alpha: (colorDef at: 4)]! ! -!Color class methodsFor: 'instance creation' stamp: 'sw 8/8/97 22:03'! - fromRgbTriplet: list - ^ self r: list first g: list second b: list last! ! -!Color class methodsFor: 'instance creation' stamp: 'pb 10/16/2016 18:42:44'! - fromString: aString - "For HTML color spec: #FFCCAA. Also support named colors. - See http://www.w3schools.com/cssref/css_colors_legal.asp" - " - Color fromString: '#FFCCAA'. - Color fromString: 'white'. - Color fromString: 'orange' - Color fromString: 'rgb(255,0,98)' - " - (aString size = 7 and: [ aString first = $# ]) ifTrue: [ - | aColorHexU red green blue | - aColorHexU _ aString asUppercase. - red _ ('16r', (aColorHexU copyFrom: 2 to: 3)) asNumber/255. - green _ ('16r', (aColorHexU copyFrom: 4 to: 5)) asNumber/255. - blue _ ('16r', (aColorHexU copyFrom: 6 to: 7)) asNumber/255. - ^ self r: red g: green b: blue]. - - (aString beginsWith: 'rgb') - ifTrue: [|values r g b| - values := (aString allButFirst: 4) allButLast findTokens: ','. - r := (values first includes: $%) - ifTrue: [(values first asNumber min: 100 max: 0) / 100.0] - ifFalse: [(values first asInteger min: 255 max: 0) / 255.0]. - g := (values second includes: $%) - ifTrue: [(values second asNumber min: 100 max: 0) / 100.0] - ifFalse: [(values second asInteger min: 255 max: 0) / 255.0]. - b := (values third includes: $%) - ifTrue: [(values third asNumber min: 100 max: 0) / 100.0] - ifFalse: [(values third asInteger min: 255 max: 0) / 255.0]. - ^self r: r g: g b: b]. - - ^self exactColorNamed: aString! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:29'! - gray: brightness - "Return a gray shade with the given brightness in the range [0.0..1.0]." - - ^ self new - setRed: brightness - green: brightness - blue: brightness! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:31'! - h: hue s: saturation v: brightness - "Create a color with the given hue, saturation, and brightness. Hue is given as the angle in degrees of the color on the color circle where red is zero degrees. Saturation and brightness are numbers in [0.0..1.0] where larger values are more saturated or brighter colors. For example, (Color h: 0 s: 1 v: 1) is pure red." - "Note: By convention, brightness is abbreviated 'v' to to avoid confusion with blue." - - ^ self new setHue: hue saturation: saturation brightness: brightness! ! -!Color class methodsFor: 'instance creation' stamp: 'dew 3/19/2002 23:49'! - h: h s: s v: v alpha: alpha - - ^ (self h: h s: s v: v) alpha: alpha! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:34'! - hue: hue chroma: chroma brightness: brightness - ^self new setHue: hue chroma: chroma brightness: brightness! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:37'! - hue: hue chroma: chroma luminance: luma - ^self new setHue: hue chroma: chroma luminance: luma! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:39'! - hue: hue saturation: saturation brightness: brightness - "Create a color with the given hue, saturation, and brightness. Hue is given as the angle in degrees of the color on the color circle where red is zero degrees. Saturation and brightness are numbers in [0.0..1.0] where larger values are more saturated or brighter colors. For example, (Color h: 0 s: 1 v: 1) is pure red." - "Note: By convention, brightness is abbreviated 'v' to to avoid confusion with blue." - - ^ self new setHue: hue saturation: saturation brightness: brightness! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:54:20'! - new - ^ self new: 3! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:41'! - r: r g: g b: b - "Return a color with the given r, g, and b components in the range [0.0..1.0]." - - ^ self new - setRed: r - green: g - blue: b! ! -!Color class methodsFor: 'instance creation'! - r: r g: g b: b alpha: alpha - - ^ (self r: r g: g b: b) alpha: alpha! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:43'! - r: r g: g b: b range: range - "Return a color with the given r, g, and b components specified as integers in the range [0..r]. This avoids the floating point arithmetic in the red:green:blue: message and is thus a bit faster for certain applications (such as computing a sequence of colors for a palette)." - - ^ self new setRed: r green: g blue: b range: range! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 4/4/2015 20:30'! - random - "Return a random color that isn't too dark or under-saturated. - Display fill: (10@10 extent: 200@200) fillColor: Color random - " - - ^ Random withDefaultDo: [ :random | - self random: random ]! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 4/4/2015 20:30'! - random2 - "Return a random color with a distribution that spans over all possible colors. - Display fill: (10@10 extent: 200@200) fillColor: Color random2 - " - - ^ Random withDefaultDo: [ :random | - self random2: random ]! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:46'! - random2: aRandom - "Return a random color with a distribution that spans over all possible colors." - - ^ self new - setRed: aRandom next - green: aRandom next - blue: aRandom next! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:48'! - random: aRandom - "Return a random color that isn't too dark or under-saturated." - - ^ self new - setHue: (360.0 * aRandom next) - saturation: (0.3 + (aRandom next * 0.7)) - brightness: (0.4 + (aRandom next * 0.6))! ! -!Color class methodsFor: 'class initialization' stamp: 'jmv 4/17/2015 15:06'! - initializeGrayToIndexMap - "Build an array of gray values available in the 8-bit colormap. This array is indexed by a gray level between black (1) and white (256) and returns the pixel value for the corresponding gray level." - "Note: This method must be called after initializeIndexedColors, since it uses IndexedColors." - " - Color initializeGrayToIndexMap - " - - | grayLevels grayIndices c distToClosest dist indexOfClosest indexedColors | - "record the level and index of each gray in the 8-bit color table" - grayLevels _ OrderedCollection new. - grayIndices _ OrderedCollection new. - indexedColors _ self indexedColors. - "Note: skip the first entry, which is reserved for transparent" - 2 to: indexedColors size do: [:i | - c _ indexedColors at: i. - c saturation = 0.0 ifTrue: [ "c is a gray" - grayLevels add: (c green * 255) rounded. "0 to 255; R, G, and B are the same" - grayIndices add: i - 1]]. "pixel values are zero-based" - grayLevels _ grayLevels asArray. - grayIndices _ grayIndices asArray. - - "for each gray level in [0..255], select the closest match" - GrayToIndexMap _ ByteArray new: 256. - 0 to: 255 do: [ :level | - distToClosest _ 10000. "greater than distance to any real gray" - 1 to: grayLevels size do: [:i | - dist _ (level - (grayLevels at: i)) abs. - dist < distToClosest ifTrue: [ - distToClosest _ dist. - indexOfClosest _ grayIndices at: i]]. - GrayToIndexMap at: (level + 1) put: indexOfClosest]! ! -!Color class methodsFor: 'class initialization'! - initializeIndexedColors - "Build an array of colors corresponding to the fixed colormap used - for display depths of 1, 2, 4, or 8 bits." - "Color initializeIndexedColors" - - | a index grayVal | - a _ Array new: 256. - - "1-bit colors (monochrome)" - a at: 1 put: (Color r: 1.0 g: 1.0 b: 1.0). "white or transparent" - a at: 2 put: (Color r: 0.0 g: 0.0 b: 0.0). "black" - - "additional colors for 2-bit color" - a at: 3 put: (Color r: 1.0 g: 1.0 b: 1.0). "opaque white" - a at: 4 put: (Color r: 0.5 g: 0.5 b: 0.5). "1/2 gray" - - "additional colors for 4-bit color" - a at: 5 put: (Color r: 1.0 g: 0.0 b: 0.0). "red" - a at: 6 put: (Color r: 0.0 g: 1.0 b: 0.0). "green" - a at: 7 put: (Color r: 0.0 g: 0.0 b: 1.0). "blue" - a at: 8 put: (Color r: 0.0 g: 1.0 b: 1.0). "cyan" - a at: 9 put: (Color r: 1.0 g: 1.0 b: 0.0). "yellow" - a at: 10 put: (Color r: 1.0 g: 0.0 b: 1.0). "magenta" - - a at: 11 put: (Color r: 0.125 g: 0.125 b: 0.125). "1/8 gray" - a at: 12 put: (Color r: 0.25 g: 0.25 b: 0.25). "2/8 gray" - a at: 13 put: (Color r: 0.375 g: 0.375 b: 0.375). "3/8 gray" - a at: 14 put: (Color r: 0.625 g: 0.625 b: 0.625). "5/8 gray" - a at: 15 put: (Color r: 0.75 g: 0.75 b: 0.75). "6/8 gray" - a at: 16 put: (Color r: 0.875 g: 0.875 b: 0.875). "7/8 gray" - - "additional colors for 8-bit color" - "24 more shades of gray (1/32 increments but not repeating 1/8 increments)" - index _ 17. - 1 to: 31 do: [:v | - (v \\ 4) = 0 ifFalse: [ - grayVal _ v / 32.0. - a at: index put: (Color r: grayVal g: grayVal b: grayVal). - index _ index + 1]]. - - "The remainder of color table defines a color cube with six steps - for each primary color. Note that the corners of this cube repeat - previous colors, but this simplifies the mapping between RGB colors - and color map indices. This color cube spans indices 40 through 255 - (indices 41-256 in this 1-based array)." - 0 to: 5 do: [:r | - 0 to: 5 do: [:g | - 0 to: 5 do: [:b | - index _ 41 + ((36 * r) + (6 * b) + g). - index > 256 ifTrue: [ - self error: 'index out of range in color table compuation']. - a at: index put: (Color r: r g: g b: b range: 5)]]]. - - IndexedColors _ a. -! ! -!Color class methodsFor: 'examples' stamp: 'jmv 8/17/2012 18:48'! - colorRampForDepth: depth extent: aPoint - "Returns a form of the given size showing R, G, B, and gray ramps for the given depth. Useful for testing color conversions between different depths." - "(Color colorRampForDepth: Display depth extent: 256@80) display" - "(Color colorRampForDepth: 32 extent: 256@80) displayOn: Display at: 0@0 rule: Form paint" - - | f dx dy r | - f _ Form extent: aPoint depth: depth. - dx _ aPoint x // 256. - dy _ aPoint y // 4. - 0 to: 255 do: [:i | - r _ (dx * i)@0 extent: dx@dy. - f fill: r fillColor: (Color r: i g: 0 b: 0 range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Color r: 0 g: i b: 0 range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Color r: 0 g: 0 b: i range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Color r: i g: i b: i range: 255)]. - ^ f -! ! -!Color class methodsFor: 'examples' stamp: 'jmv 6/18/2017 21:29:30'! - experimentsTowarsANewColorPalette -" -self experimentsTowarsANewColorPalette -" -| selectedHue selectedSaturation selectedV selectedColor h s v color width height selectedChroma selectedLuminance | -width _ 300. -height _ 120. -selectedColor _ Color random. -selectedHue _ selectedColor hue. -selectedSaturation _ selectedColor saturation. -selectedChroma _ selectedColor chroma. -selectedV _ selectedColor brightness. -selectedLuminance _ selectedColor luminance. -Display getCanvas fillRectangle: (0@0 extent: height@height) color: selectedColor. -0 to: height do: [ :y | - v _ 1.0 - (y / height). - 0 to: height do: [ :x | - s _ x / height. - color _ Color new setHue: selectedHue saturation: s brightness: v. - Display colorAt: x@(y+height) put: color - ]. - DisplayScreen screenUpdateRequired: nil -]. -0 to: height do: [ :y | | c | - v _ 1.0 - (y / height). - s _ 1.0 - (y / height). - c _ s. - 0 to: width do: [ :x | - h _ x / width * 360. - - color _ Color new setHue: h chroma: c luminance: selectedLuminance. -" color _ Color new setHue: h chroma: c brightness: selectedV." - color ifNil: [ color _ Color black ]. -" color _ Color new setHue: h saturation: s brightness: selectedV." - Display colorAt: x+height@y put: color. - - color _ Color new setHue: h chroma: selectedChroma luminance: v. -" color _ Color new setHue: h chroma: selectedChroma brightness: v." - color ifNil: [ color _ Color black ]. -" color _ Color new setHue: h saturation: selectedSaturation brightness: v." - Display colorAt: x+height@(y+height) put: color. - - ]. - DisplayScreen screenUpdateRequired: nil -].! ! -!Color class methodsFor: 'examples' stamp: 'tk 6/19/96'! -hotColdShades: thisMany - "An array of thisMany colors showing temperature from blue to red to white hot. (Later improve this by swinging in hue.) " - "Color showColors: (Color hotColdShades: 25)" - - | n s1 s2 s3 s4 s5 | - thisMany < 5 ifTrue: [^ self error: 'must be at least 5 shades']. - n _ thisMany // 5. - s1 _ self white mix: self yellow shades: (thisMany - (n*4)). - s2 _ self yellow mix: self red shades: n+1. - s2 _ s2 copyFrom: 2 to: n+1. - s3 _ self red mix: self green darker shades: n+1. - s3 _ s3 copyFrom: 2 to: n+1. - s4 _ self green darker mix: self blue shades: n+1. - s4 _ s4 copyFrom: 2 to: n+1. - s5 _ self blue mix: self black shades: n+1. - s5 _ s5 copyFrom: 2 to: n+1. - ^ s1, s2, s3, s4, s5 -! ! -!Color class methodsFor: 'examples'! - showColorCube - "Show a 12x12x12 color cube." - "Color showColorCube" - - 0 to: 11 do: [:r | - 0 to: 11 do: [:g | - 0 to: 11 do: [:b | - Display fill: (((r*60) + (b*5)) @ (g*5) extent: 5@5) - fillColor: (Color r: r g: g b: b range: 11)]]]. -! ! -!Color class methodsFor: 'examples' stamp: 'jmv 8/17/2012 18:48'! - showColors: colorList - "Display the given collection of colors across the top of the Display." - - | w r | - w _ Display width // colorList size. - r _ 0@0 extent: w@((w min: 30) max: 10). - colorList do: [:c | - Display fill: r fillColor: c. - r _ r translatedBy: w@0]. -! ! -!Color class methodsFor: 'examples'! - showHSVPalettes - "Shows a palette of hues, varying the saturation and brightness for each one. Best results are with depths 16 and 32." - "Color showHSVPalettes" - - | left top c | - left _ top _ 0. - 0 to: 179 by: 15 do: [:h | - 0 to: 10 do: [:s | - left _ (h * 4) + (s * 4). - 0 to: 10 do: [:v | - c _ Color h: h s: s asFloat / 10.0 v: v asFloat / 10.0. - top _ (v * 4). - Display fill: (left@top extent: 4@4) fillColor: c. - - c _ Color h: h + 180 s: s asFloat / 10.0 v: v asFloat / 10.0. - top _ (v * 4) + 50. - Display fill: (left@top extent: 4@4) fillColor: c]]]. -! ! -!Color class methodsFor: 'examples' stamp: 'jmv 1/14/2013 21:12'! - showHuesInteractively - "Shows a palette of hues at a (saturation, brightness) point determined by the mouse position. Click the mouse button to exit and return the selected (saturation, brightness) point." - "Color showHuesInteractively" - - | p s v | - [Sensor isAnyButtonPressed] whileFalse: [ - p _ Sensor mousePoint. - s _ p x asFloat / 300.0. - v _ p y asFloat / 300.0. - self showColors: (self wheel: 12 saturation: s brightness: v)]. - ^ (s min: 1.0) @ (v min: 1.0)! ! -!Color class methodsFor: 'examples'! - wheel: thisMany - "Return a collection of thisMany colors evenly spaced around the color wheel." - "Color showColors: (Color wheel: 12)" - - ^ Color wheel: thisMany saturation: 0.9 brightness: 0.7 -! ! -!Color class methodsFor: 'examples'! - wheel: thisMany saturation: s brightness: v - "Return a collection of thisMany colors evenly spaced around the color wheel, all of the given saturation and brightness." - "Color showColors: (Color wheel: 12 saturation: 0.4 brightness: 1.0)" - "Color showColors: (Color wheel: 12 saturation: 0.8 brightness: 0.5)" - - ^ (Color h: 0.0 s: s v: v) wheel: thisMany -! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:58'! - aqua - - ^ self colorNamesDict at: #aqua! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:58'! - beige - - ^ self colorNamesDict at: #beige! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:58'! - black - - ^ self colorNamesDict at: #black! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:58'! - blue - - ^ self colorNamesDict at: #blue! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:58'! - brightGreen - - ^ self colorNamesDict at: #brightGreen! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:58'! - brown - - ^ self colorNamesDict at: #brown! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - cyan - - ^ self colorNamesDict at: #cyan! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - darkBlue - - ^ self colorNamesDict at: #darkBlue! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - darkGray - - ^ self colorNamesDict at: #darkGray! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - darkGreen - - ^ self colorNamesDict at: #darkGreen! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - darkPink - - ^ self colorNamesDict at: #darkPink! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - darkPurple - - ^ self colorNamesDict at: #darkPurple! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - forestGreen - - ^ self colorNamesDict at: #forestGreen! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - gray - - ^ self colorNamesDict at: #gray! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - green - - ^ self colorNamesDict at: #green! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - grey - - ^ self colorNamesDict at: #grey! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - hotPink - - ^ self colorNamesDict at: #hotPink! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - indigo - - ^ self colorNamesDict at: #indigo! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - lavender - - ^ self colorNamesDict at: #lavender! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - lightBlue - - ^ self colorNamesDict at: #lightBlue! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - lightBrown - - ^ self colorNamesDict at: #lightBrown! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - lightCyan - - ^ self colorNamesDict at: #lightCyan! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - lightGray - - ^ self colorNamesDict at: #lightGray! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - lightGreen - - ^ self colorNamesDict at: #lightGreen! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - lightMagenta - - ^ self colorNamesDict at: #lightMagenta! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! -lightOrange - - ^ self colorNamesDict at: #lightOrange! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - lightPink - - ^ self colorNamesDict at: #lightPink! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - lightPurple - - ^ self colorNamesDict at: #lightPurple! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - lightRed - - ^ self colorNamesDict at: #lightRed! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - lightYellow - - ^ self colorNamesDict at: #lightYellow! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - lilac - - ^ self colorNamesDict at: #lilac! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - lime - - ^ self colorNamesDict at: #lime! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - limeGreen - - ^ self colorNamesDict at: #limeGreen! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - magenta - - ^ self colorNamesDict at: #magenta! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - maroon - - ^ self colorNamesDict at: #maroon! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - mauve - - ^ self colorNamesDict at: #mauve! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - mustard - - ^ self colorNamesDict at: #mustard! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - navyBlue - - ^ self colorNamesDict at: #navyBlue! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - olive - - ^ self colorNamesDict at: #olive! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - oliveGreen - - ^ self colorNamesDict at: #oliveGreen! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - orange - - ^ self colorNamesDict at: #orange! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - paleGreen - - ^ self colorNamesDict at: #paleGreen! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - peach - - ^ self colorNamesDict at: #peach! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - periwinkle - - ^ self colorNamesDict at: #periwinkle! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - pink - - ^ self colorNamesDict at: #pink! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - purple - - ^ self colorNamesDict at: #purple! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - red - - ^ self colorNamesDict at: #red! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - royalBlue - - ^ self colorNamesDict at: #royalBlue! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - salmon - - ^ self colorNamesDict at: #salmon! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - seaGreen - - ^ self colorNamesDict at: #seaGreen! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - skyBlue - - ^ self colorNamesDict at: #skyBlue! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - tan - - ^ self colorNamesDict at: #tan! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - teal - - ^ self colorNamesDict at: #teal! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - transparent - - ^ self colorNamesDict at: #transparent! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - turquoise - - ^ self colorNamesDict at: #turquoise! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - veryDarkGray - - ^ self colorNamesDict at: #veryDarkGray! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! -veryLightGray - - ^ self colorNamesDict at: #veryLightGray! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - veryVeryDarkGray - - ^ self colorNamesDict at: #veryVeryDarkGray! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - veryVeryLightGray - - ^ self colorNamesDict at: #veryVeryLightGray! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - violet - - ^ self colorNamesDict at: #violet! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - white - - ^ self colorNamesDict at: #white! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - yellow - - ^ self colorNamesDict at: #yellow! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 5/12/2016 15:49'! - cachedColormapForGrayFrom: sourceDepth - "Return a cached colormap for mapping from the given depth to the 8bpp grays. Always return a real colormap, not nil; this allows the client to get an identity colormap that can then be copied and modified to do color transformations." - "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" - "Note: The colormap cache may be cleared by evaluating 'Color shutDown'." - "Note: The color maps for sourceDepth=16 and for sourceDepth=32 are the same" - - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | srcIndex map | - ToGrayColormaps ifNil: [ - ToGrayColormaps _ Array new: 5]. - - srcIndex _ sourceDepth highBit min: 5. - - (ToGrayColormaps at: srcIndex) ifNotNil: [ :m | ^ m ]. - - map _ self computeColormapForGray8bppFrom: sourceDepth. - ToGrayColormaps at: srcIndex put: map. - ^ map! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 5/12/2016 14:50'! - cachedColormapFrom: sourceDepth to: destDepth - "Return a cached colormap for mapping between the given depths. Always return a real colormap, not nil; this allows the client to get an identity colormap that can then be copied and modified to do color transformations." - "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" - "Note: The colormap cache may be cleared by evaluating 'Color shutDown'." - "Note: The color maps for sourceDepth=16 and for sourceDepth=32 are the same" - - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | srcIndex dstIndex map | - CachedColormaps - ifNil: [CachedColormaps _ (1 to: 5) collect: [:i | Array new: 6]]. - - srcIndex _ sourceDepth highBit min: 5. - dstIndex _ destDepth highBit. - - ((CachedColormaps at: srcIndex) at: dstIndex) ifNotNil: [ :m | ^ m ]. - - map _ self computeColormapFrom: sourceDepth to: destDepth. - (CachedColormaps at: srcIndex) at: dstIndex put: map. - ^ map! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 5/12/2016 15:49'! - cachedColormapFromGrayTo: destDepth - "Return a cached colormap for mapping from 8bpp grays to the given depth. Always return a real colormap, not nil; this allows the client to get an identity colormap that can then be copied and modified to do color transformations." - "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" - "Note: The colormap cache may be cleared by evaluating 'Color shutDown'." - "Note: The color maps for sourceDepth=16 and for sourceDepth=32 are the same" - - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | dstIndex map | - FromGrayColormaps - ifNil: [FromGrayColormaps _ Array new: 6 ]. - - dstIndex _ destDepth highBit. - - (FromGrayColormaps at: dstIndex) ifNotNil: [ :m | ^ m ]. - - map _ self computeColormapFromGray8bppForDepth: destDepth. - FromGrayColormaps at: dstIndex put: map. - ^ map! ! -!Color class methodsFor: 'colormaps'! - colorMapIfNeededFrom: sourceDepth to: destDepth - "Return a colormap for mapping between the given depths, or nil if no colormap is needed." - "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" - - sourceDepth = destDepth ifTrue: [^ nil]. "not needed if depths are the same" - - (sourceDepth >= 16) & (destDepth >= 16) ifTrue: [ - "mapping is done in BitBlt by zero-filling or truncating each color component" - ^ nil]. - - ^ Color cachedColormapFrom: sourceDepth to: destDepth -! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 8/27/2009 08:47'! - computeColorConvertingMap: targetColor from: sourceDepth to: destDepth keepSubPixelAA: keepSubPix - "Note: The color converting map for sourceDepth=16 and for sourceDepth=32 are the same" - sourceDepth < 16 ifTrue: [ - "source is 1-, 2-, 4-, or 8-bit indexed color. - Assumed not to include subpixelAA" - ^ self computeIndexedColorConvertingMap: targetColor from: sourceDepth to: destDepth - ] ifFalse: [ - "source is 16-bit or 32-bit RGB. - Might include subpixelAA" - ^ self computeRGBColorConvertingMap: targetColor to: destDepth keepSubPixelAA: keepSubPix - ]! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 5/12/2016 15:55'! - computeColormapForGray8bppFrom: sourceDepth - "Compute a colorMap for translatingfrom the given depth to the 8bpp grays" - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | map | - sourceDepth < 16 ifTrue: [ - "source is 1-, 2-, 4-, or 8-bit indexed color" - map _ (self indexedColors copyFrom: 1 to: (1 bitShift: sourceDepth)) - collect: [ :c | (c luminance * 255) rounded]. - map _ map as: Bitmap. - ^ map - ] - ifFalse: [ - ^ self computeRGBColormapForGray8 ]! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 4/17/2015 15:05'! - computeColormapFrom: sourceDepth to: destDepth - "Compute a colorMap for translating between the given depths. A colormap is a Bitmap whose entries contain the pixel values for the destination depth. Typical clients use cachedColormapFrom:to: instead." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | map bitsPerColor | - sourceDepth < 16 ifTrue: [ - "source is 1-, 2-, 4-, or 8-bit indexed color" - map _ (self indexedColors copyFrom: 1 to: (1 bitShift: sourceDepth)) - collect: [:c | c pixelValueForDepth: destDepth]. - map _ map as: Bitmap. - ] ifFalse: [ - "source is 16-bit or 32-bit RGB" - destDepth > 8 - ifTrue: [bitsPerColor _ 5] "retain maximum color resolution" - ifFalse: [bitsPerColor _ 4]. - map _ self computeRGBColormapFor: destDepth bitsPerColor: bitsPerColor]. - - "Note: zero is transparent except when source depth is one-bit deep" - sourceDepth > 1 ifTrue: [map at: 1 put: 0]. - ^ map -! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 5/12/2016 15:56'! - computeColormapFromGray8bppForDepth: destDepth - "Return a colormap for displaying a GrayForm at the given depth" - - | newMap | - newMap _ Bitmap new: 256. - 1 to: 256 do: [ :i | - newMap - at: i - put: ((Color gray: (i-1) asFloat / 255.0) pixelValueForDepth: destDepth)]. - ^ newMap! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 4/17/2015 15:05'! - computeIndexedColorConvertingMap: targetColor from: sourceDepth to: destDepth - | map | - - map _ (self indexedColors copyFrom: 1 to: (1 bitShift: sourceDepth)) collect: [ :cc | | f c | - f _ 1.0 - (cc red + cc green + cc blue / 3.0 ). - c _ targetColor - ifNotNil: [ - destDepth = 32 - ifTrue: [ targetColor * f alpha: f] - ifFalse: [ targetColor alphaMixed: f*1.5 with: Color white ]] - ifNil: [ cc ]. - destDepth = 32 - ifTrue: [ c pixelValueForDepth: destDepth] - ifFalse: [ - f = 0.0 - ifTrue: [ 0 ] - ifFalse: [ c pixelValueForDepth: destDepth ]]]. - map _ map as: Bitmap. - ^map! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 12/26/2011 13:49'! - computeRGBColorConvertingMap: targetColor to: destDepth keepSubPixelAA: keepSubPix - "Builds a colormap intended to convert from subpixelAA black values to targetColor values. - keepSubPix - ifTrue: [ Answer colors that also include subpixelAA ] - ifFalse: [ - Take fullpixel luminance level. Apply it to targetColor. - I.e. answer colors with NO subpixelAA ]" - - | mask map c bitsPerColor r g b f v | - - destDepth > 8 - ifTrue: [bitsPerColor _ 5] "retain maximum color resolution" - ifFalse: [bitsPerColor _ 4]. - "Usually a bit less is enough, but make it configurable" - bitsPerColor _ bitsPerColor min: Preferences aaFontsColormapDepth. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - r _ (i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask. - g _ (i bitShift: 0 - bitsPerColor) bitAnd: mask. - b _ (i bitShift: 0) bitAnd: mask. - f _ 1.0 - (r + g + b / 3.0 / mask). - c _ targetColor - ifNotNil: [ - (keepSubPix and: [destDepth > 8]) ifTrue: [ - Color - r: 1.0 - (r asFloat/mask) * targetColor red - g: 1.0 - (g asFloat/mask) * targetColor green - b: 1.0 - (b asFloat/mask) * targetColor blue - alpha: f * targetColor alpha "alpha will be ignored below, in #pixelValueForDepth: if destDepth ~= 32" ] - ifFalse: [ - destDepth = 32 - ifTrue: [ targetColor * f alpha: f * targetColor alpha ] - ifFalse: [ targetColor alphaMixed: f*1.5 with: Color white ]]] - ifNil: [ Color r: r g: g b: b range: mask]. "This is currently used only to keep some SubPixelAA on destDepth = 8, using a single pass of rule 25" - v _ destDepth = 32 - ifTrue: [ c pixelValueForDepth: destDepth] - ifFalse: [ - f < 0.1 - ifTrue: [ 0 ] - ifFalse: [ c pixelValueForDepth: destDepth ]]. - map at: i + 1 put: v ]. - ^ map! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 1/30/2011 23:10'! - computeRGBColormapFor: destDepth bitsPerColor: bitsPerColor - "Compute a colorMap for translating from 16-bit or 32-bit RGB color to the given depth, using the given number of of bits per color component." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | mask map c | - (#(3 4 5) includes: bitsPerColor) - ifFalse: [self error: 'BitBlt only supports 3, 4, or 5 bits per color component']. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - c _ Color - r: ((i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask) - g: ((i bitShift: 0 - bitsPerColor) bitAnd: mask) - b: ((i bitShift: 0) bitAnd: mask) - range: mask. - map at: i + 1 put: (c pixelValueForDepth: destDepth)]. - - map at: 1 put: (Color transparent pixelWordForDepth: destDepth). "zero always transparent" - ^ map -! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 5/12/2016 15:57'! - computeRGBColormapForGray8 - "Compute a colorMap for translating from 16-bit or 32-bit RGB color to 8bpp grays, using the default number of of bits per color component." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | bitsPerColor mask map c | - bitsPerColor _ 5. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - c _ Color - r: ((i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask) - g: ((i bitShift: 0 - bitsPerColor) bitAnd: mask) - b: ((i bitShift: 0) bitAnd: mask) - range: mask. - map at: i + 1 put: (c luminance * 255) rounded]. - - ^ map! ! -!Color class methodsFor: 'other' stamp: 'jmv 1/31/2011 09:30'! - maskingMap: depth - "Return a color map that maps all colors except transparent to words of all ones. Used to create a mask for a Form whose transparent pixel value is zero. Cache the most recently used map." - "Warning: The behavior is incorrect if depth = 32. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | sizeNeeded | - depth <= 8 - ifTrue: [sizeNeeded _ 1 bitShift: depth] - ifFalse: [sizeNeeded _ 4096]. - - (MaskingMap == nil or: [MaskingMap size ~= sizeNeeded]) ifTrue: - [MaskingMap _ Bitmap new: sizeNeeded withAll: 16rFFFFFFFF. - MaskingMap at: 1 put: 0. "transparent"]. - - ^ MaskingMap -! ! -!Color class methodsFor: 'color from user' stamp: 'jmv 3/1/2010 15:13'! - colorPaletteForDepth: depth extent: chartExtent - "Display a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." - "Note: It is slow to build this palette, so it should be cached for quick access." - "(Color colorPaletteForDepth: 16 extent: 190@60) display" - - | basicHue x y startHue palette transHt vSteps transCaption grayWidth hSteps | - palette _ Form extent: chartExtent depth: depth. - transCaption _ - (Form extent: 34@9 depth: 1 - fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0) - offset: 0@0). - transHt _ transCaption height. - palette fillWhite: (0@0 extent: palette width@transHt). - palette fillBlack: (0@transHt extent: palette width@1). - transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0). - grayWidth _ 10. - startHue _ 338.0. - vSteps _ palette height - transHt // 2. - hSteps _ palette width - grayWidth. - x _ 0. - startHue to: startHue + 360.0 by: 360.0/hSteps do: [ :h | - basicHue _ Color h: h asFloat s: 1.0 v: 1.0. - y _ transHt+1. - 0 to: vSteps do: [ :n | | c | - c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Color white. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - 1 to: vSteps do: [ :n | | c | - c _ Color black mixed: (n asFloat / vSteps asFloat) with: basicHue. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - x _ x + 1]. - y _ transHt + 1. - 1 to: vSteps * 2 do: [ :n | | c | - c _ Color black mixed: (n asFloat / (vSteps*2) asFloat) with: Color white. - palette fill: (x@y extent: 10@1) fillColor: c. - y _ y + 1]. - ^ palette -! ! -!Color class methodsFor: 'color from user' stamp: 'jmv 7/27/2009 11:32'! - colorTest: depth extent: chartExtent colorMapper: colorMapper - "Create a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." - "Note: It is slow to build this palette, so it should be cached for quick access." - "(Color colorTest: 32 extent: 570@180 colorMapper: [:c | c]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 7) asInteger / 7 - g: (c green * 7) asInteger / 7 - b: (c blue * 3) asInteger / 3]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 5) asInteger / 5 - g: (c green * 5) asInteger / 5 - b: (c blue * 5) asInteger / 5]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 15) asInteger / 15 - g: (c green * 15) asInteger / 15 - b: (c blue * 15) asInteger / 15]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 31) asInteger / 31 - g: (c green * 31) asInteger / 31 - b: (c blue * 31) asInteger / 31]) display" - - | basicHue x y c startHue palette transHt vSteps transCaption grayWidth hSteps | - palette _ Form extent: chartExtent depth: depth. - transCaption _ - (Form extent: 34@9 depth: 1 - fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0) - offset: 0@0). - transHt _ transCaption height. - palette fillWhite: (0@0 extent: palette width@transHt). - palette fillBlack: (0@transHt extent: palette width@1). - transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0). - grayWidth _ 10. - startHue _ 338.0. - vSteps _ palette height - transHt // 2. - hSteps _ palette width - grayWidth. - x _ 0. - startHue to: startHue + 360.0 by: 360.0/hSteps do: [:h | - basicHue _ Color h: h asFloat s: 1.0 v: 1.0. - y _ transHt+1. - 0 to: vSteps do: [:n | - c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Color white. - c _ colorMapper value: c. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - 1 to: vSteps do: [:n | - c _ Color black mixed: (n asFloat / vSteps asFloat) with: basicHue. - c _ colorMapper value: c. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - x _ x + 1]. - y _ transHt + 1. - 1 to: vSteps * 2 do: [:n | - c _ Color black mixed: (n asFloat / (vSteps*2) asFloat) with: Color white. - c _ colorMapper value: c. - palette fill: (x@y extent: 10@1) fillColor: c. - y _ y + 1]. - ^ palette -! ! -!Color class methodsFor: 'color name lookup' stamp: 'KenD 1/26/2013 20:13'! - colorNames - "Answer the current dictionary of name->color associations." - - ^self colorNamesDict keys! ! -!Color class methodsFor: 'color name lookup' stamp: 'KenD 1/28/2013 20:34'! - defaultColorNamesDictionary - "Answer a amall but useful name->color dictionary" - - | defaultDict | - "Meld most used xkcd colors into traditional colors." - defaultDict := (self traditionalColorNamesDictionary addAll: - self xkcdFirst48ColorNamesDictionary; - yourself). - - "Override traditional names existing in extended XKCD naming" - defaultDict at: #lightYellow put: (Color r: 1.0 g: 0.996 b: 0.478). - defaultDict at: #lightOrange put: (Color r: 0.992 g: 0.667 b: 0.283). - defaultDict at: #lightCyan put: (Color r: 0.674 g: 1.0 b: 0.988). - defaultDict at: #lightRed put: (Color r: 1.0 g: 0.279 b: 0.298). - defaultDict at: #lightMagenta put: (Color r: 0.98 g: 0.372 b: 0.969). - - ^defaultDict! ! -!Color class methodsFor: 'color name lookup' stamp: 'KenD 2/1/2013 14:39'! - doesNotUnderstand: aMessage - "Some code takes - Color colorNames - and does - Color perform: aColorname. - - Make this work." - - ^(Color colorNamesDict) - at: (aMessage selector) - ifAbsent: [super doesNotUnderstand: aMessage]! ! -!Color class methodsFor: 'color name lookup' stamp: 'KenD 1/26/2013 20:51'! - exactColorNamed: aColorName - - "Answer color matching name or nil - from my ColorName->Color Dictionary" - - ^ self colorNamesDict at: (aColorName asSymbol) ifAbsent: [nil]! ! -!Color class methodsFor: 'color name lookup' stamp: 'KenD 7/25/2014 21:22'! - setColorNamesDict: aNameColorDictionary - "Answer the current dictionary of name->color associations." - - "Note: This is a non-standard name because this is a non-standard action!! - Do this if you really, really know what you are doing." - - "Some Colors are required for proper system operation" - Color defaultColorNamesDictionary keysAndValuesDo: [ :colorName :colorValue | - aNameColorDictionary at: colorName ifAbsentPut: colorValue - ]. - - ColorNamesDict := aNameColorDictionary! ! -!Color class methodsFor: 'color name lookup' stamp: 'sqr 10/21/2016 12:44:48'! - traditionalColorNamesDictionary - "Answer a dictionary of Squeak traditional name->color associations.." - - | nameDict | - nameDict _ Dictionary new. - nameDict at: #black put: (Color r: 0 g: 0 b: 0). - nameDict at: #veryVeryDarkGray put: (Color r: 0.125 g: 0.125 b: 0.125). - nameDict at: #veryDarkGray put: (Color r: 0.25 g: 0.25 b: 0.25). - nameDict at: #darkGray put: (Color r: 0.375 g: 0.375 b: 0.375). - nameDict at: #gray put: (Color r: 0.5 g: 0.5 b: 0.5). - nameDict at: #lightGray put: (Color r: 0.625 g: 0.625 b: 0.625). - nameDict at: #veryLightGray put: (Color r: 0.75 g: 0.75 b: 0.75). - nameDict at: #veryVeryLightGray put: (Color r: 0.875 g: 0.875 b: 0.875). - nameDict at: #white put: (Color r: 1.0 g: 1.0 b: 1.0). - nameDict at: #red put: (Color r: 1.0 g: 0 b: 0). - nameDict at: #yellow put: (Color r: 1.0 g: 1.0 b: 0). - nameDict at: #green put: (Color r: 0 g: 1.0 b: 0). - nameDict at: #cyan put: (Color r: 0 g: 1.0 b: 1.0). - nameDict at: #blue put: (Color r: 0 g: 0 b: 1.0). - nameDict at: #magenta put: (Color r: 1.0 g: 0 b: 1.0). - nameDict at: #brown put: (Color r: 0.6 g: 0.2 b: 0). - nameDict at: #orange put: (Color r: 1.0 g: 0.6 b: 0). - nameDict at: #lightRed put: (Color r: 1.0 g: 0.8 b: 0.8). - nameDict at: #lightYellow put: (Color r: 1.0 g: 1.0 b: 0.8). - nameDict at: #lightGreen put: (Color r: 0.8 g: 1.0 b: 0.6). - nameDict at: #lightCyan put: (Color r: 0.4 g: 1.0 b: 1.0). - nameDict at: #lightBlue put: (Color r: 0.8 g: 1.0 b: 1.0). - nameDict at: #lightMagenta put: (Color r: 1.0 g: 0.8 b: 1.0). - nameDict at: #lightBrown put: (Color r: 1.0 g: 0.6 b: 0.2). - nameDict at: #lightOrange put: (Color r: 1.0 g: 0.8 b: 0.4). - nameDict at: #transparent put: (TranslucentColor r: 0.0 g: 0.0 b: 0.0 alpha: 0.0). - - ^nameDict -! ! -!Color class methodsFor: 'color name lookup' stamp: 'jmv 6/30/2014 15:22'! - xkcdFirst48ColorNamesDictionary - "XKCD color names are based on a survey oc colors people call by the same name. - http://blog.xkcd.com/2010/05/03/color-survey-results/" - - "Answer a dictionary of the most agreed upon first 48 xkcd colors" -" - Color xkcdFirst48ColorNamesDictionary explore. -" - | xkcdDict | - xkcdDict := Dictionary new - at: #lightPink put: (Color fromString: '#ffd1df') ; - at: #mustard put: (Color fromString: '#ceb301') ; - at: #indigo put: (Color fromString: '#380282') ; - at: #lime put: (Color fromString: '#aaff32') ; - at: #seaGreen put: (Color fromString: '#53fca1') ; - at: #periwinkle put: (Color fromString: '#8e82fe') ; - at: #darkPink put: (Color fromString: '#cb416b') ; - at: #oliveGreen put: (Color fromString: '#677a04') ; - at: #peach put: (Color fromString: '#ffb07c') ; - at: #paleGreen put: (Color fromString: '#c7fdb5') ; - at: #lightBrown put: (Color fromString: '#ad8150') ; - at: #hotPink put: (Color fromString: '#ff028d') ; - at: #black put: (Color fromString: '#000000') ; - at: #lilac put: (Color fromString: '#cea2fd') ; - at: #navyBlue put: (Color fromString: '#001146') ; - at: #royalBlue put: (Color fromString: '#0504aa') ; - at: #beige put: (Color fromString: '#e6daa6') ; - at: #salmon put: (Color fromString: '#ff796c') ; - at: #olive put: (Color fromString: '#6e750e') ; - at: #maroon put: (Color fromString: '#650021') ; - at: #brightGreen put: (Color fromString: '#01ff07') ; - at: #darkPurple put: (Color fromString: '#35063e') ; - at: #mauve put: (Color fromString: '#ae7181') ; - at: #forestGreen put: (Color fromString: '#06470c') ; - at: #aqua put: (Color fromString: '#13eac9') ; - at: #cyan put: (Color fromString: '#00ffff') ; - at: #tan put: (Color fromString: '#d1b26f') ; - at: #darkBlue put: (Color fromString: '#00035b') ; - at: #lavender put: (Color fromString: '#c79fef') ; - at: #turquoise put: (Color fromString: '#06c2ac') ; - at: #darkGreen put: (Color fromString: '#033500') ; - at: #violet put: (Color fromString: '#9a0eea') ; - at: #lightPurple put: (Color fromString: '#bf77f6') ; - at: #limeGreen put: (Color fromString: '#89fe05') ; - at: #grey put: (Color fromString: '#929591') ; - at: #skyBlue put: (Color fromString: '#75bbfd') ; - at: #yellow put: (Color fromString: '#ffff14') ; - at: #magenta put: (Color fromString: '#c20078') ; - at: #lightGreen put: (Color fromString: '#96f97b') ; - at: #orange put: (Color fromString: '#f97306') ; - at: #teal put: (Color fromString: '#029386') ; - at: #lightBlue put: (Color fromString: '#95d0fc') ; - at: #red put: (Color fromString: '#e50000') ; - at: #brown put: (Color fromString: '#653700') ; - at: #pink put: (Color fromString: '#ff81c0') ; - at: #blue put: (Color fromString: '#0343df') ; - at: #green put: (Color fromString: '#15b01a') ; - at: #purple put: (Color fromString: '#7e1e9c') ; - yourself. - - ^xkcdDict - -! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:26'! - blueColorDict - "Answer a dictionary of named colors considered Blue" -" - Color blueColorDict explore. -" - ^self blueColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:24'! - blueColorDict: aColorDict - "Answer a dictionary of named colors considered Blue" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isBlue) - or: [assoc key asString asLowercase includesSubString: 'blue']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:28'! - blueGreenColorDict - "Answer a dictionary of named colors considered Blue" -" - Color blueGreenColorDict explore. -" - ^self blueGreenColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:29'! - blueGreenColorDict: aColorDict - "Answer a dictionary of named colors considered Blue" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isBlueGreen) - or: [assoc key asString asLowercase includesSubString: 'bluegreen']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:31'! - brightColorDict - "Answer a dictionary of named colors considered Bright" -" - Color brightColorDict explore. -" - ^self brightColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:31'! - brightColorDict: aColorDict - "Answer a dictionary of named colors considered Bright" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - (assoc value isBright) ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:34'! - brownColorDict - "Answer a dictionary of named colors considered Brown" -" - Color brownColorDict explore. -" - ^self brownColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:33'! - brownColorDict: aColorDict - "Answer a dictionary of named colors considered Brown" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isBrown) - or: [assoc key asString asLowercase includesSubString: 'brown']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:36'! - darkColorDict - "Answer a dictionary of named colors considered Dark" -" - Color darkColorDict explore. -" - ^self darkColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:37'! - darkColorDict: aColorDict - "Answer a dictionary of named colors considered Dark" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - (assoc value isDark) ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:41'! - grayColorDict: aColorDict - "Answer a dictionary of named colors considered Grey" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isGrey) - or: [assoc key asString asLowercase includesSubString: 'grey']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:38'! - greenColorDict - "Answer a dictionary of named colors considered Green" -" - Color greenColorDict explore. -" - ^self greenColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:38'! - greenColorDict: aColorDict - "Answer a dictionary of named colors considered Green" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isGreen) - or: [assoc key asString asLowercase includesSubString: 'green']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:41'! - greyColorDict - "Answer a dictionary of named colors considered Grey" -" - Color greyColorDict explore. -" - ^self greyColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:40'! - greyColorDict: aColorDict - "Answer a dictionary of named colors considered Grey" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isGrey) - or: [assoc key asString asLowercase includesSubString: 'grey']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:44'! - lightColorDict - "Answer a dictionary of named colors considered light" -" - Color lightColorDict explore. -" - ^self lightColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:43'! - lightColorDict: aColorDict - "Answer a dictionary of named colors considered Liight" - - ^self brightColorDict: aColorDict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:46'! - orangeColorDict - "Answer a dictionary of named colors considered Orange" -" - Color orangeColorDict explore. -" - ^self orangeColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:46'! - orangeColorDict: aColorDict - "Answer a dictionary of named colors considered Orange" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isOrange) - or: [assoc key asString asLowercase includesSubString: 'orange']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:48'! - pastelColorDict - "Answer a dictionary of named colors considered Pastel" -" - Color pastelColorDict explore. -" - ^self pastelColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:48'! - pastelColorDict: aColorDict - "Answer a dictionary of named colors considered Bright" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - (assoc value isPastel) ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:50'! - pinkColorDict - "Answer a dictionary of named colors considered Pink" -" - Color pinkColorDict explore. -" - ^self pinkColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:50'! - pinkColorDict: aColorDict - "Answer a dictionary of named colors considered Pink" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isPink) - or: [assoc key asString asLowercase includesSubString: 'pink']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:52'! - purpleColorDict - "Answer a dictionary of named colors considered Purple" -" - Color purpleColorDict explore. -" - ^self purpleColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:52'! - purpleColorDict: aColorDict - "Answer a dictionary of named colors considered Pink" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc key asString asLowercase includesSubString: 'purple') - or: [assoc key asString asLowercase includesSubString: 'violet']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:54'! - redColorDict - "Answer a dictionary of named colors considered Red" -" - Color redColorDict explore. -" - ^self redColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:53'! - redColorDict: aColorDict - "Answer a dictionary of named colors considered Red" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isRed) - or: [assoc key asString asLowercase includesSubString: 'red']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:56'! - saturatedColorDict - "Answer a dictionary of named colors considered Saturated" -" - Color saturatedColorDict explore. -" - ^self saturatedColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:55'! - saturatedColorDict: aColorDict - "Answer a dictionary of named colors considered Saturated" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - (assoc value isSaturated) ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:26'! - yellowColorDict - "Answer a dictionary of named colors considered Yellow" -" - Color yellowColorDict explore. -" - ^self yellowColorDict: (self colorNamesDict)! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:19'! - yellowColorDict: aColorDict - "Answer a dictionary of named colors considered Yellow" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isYellow) - or: [assoc key asString asLowercase includesSubString: 'yellow']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'color space conversions' stamp: 'jmv 4/24/2013 10:55'! - applySimpleGamma: gamma to: value - "Encode / decode Gamma. Typical gamma are 0.4545 ( = 1.0 / 2.2, for encoding) and 2.2 (for decoding) - In a non gamma encoded image, the pixel values are proportional to luminance, i.e. the actual light intensity, the photon count. - In an gamma encoded image, the pixel value is close to the average perceived brightness, or 'lightness'. This optimizes the use of available bits in digital images, and dynamic range in analog images and film. This is like the 'luma' signal in video. - - Usually: - - Images stored in file formats such as jpg, png, tiff and bmp are gamma encoded - (unless they are actually raw images). - - Images sent to a framebuffer (video memory) should be gamma encoded. - - Raw images from sensors are not gamma encoded. - - - Image processing algorithms that simulate the real world, or are applied to real world data should work on unencoded (linear) images. - This includes filtering, resizing, blending, and most operations done on images. - This means that if the images come from jpg photos from a camera, they should be gamma decoded. - - Image processing algorithms that works on human perception should work on gamma encoded images. - This includes histograms, histogram equalization, bit allocation (i.e. quantization), compression, etc. - This also includes detecting objects like a human would do - - - See - http://en.wikipedia.org/wiki/Gamma_correction - http://www.poynton.com/notes/colour_and_gamma/GammaFAQ.html - - Mostly for documentation. - value must be in [0.0 .. 1.0]. - Note that the sRGB standard specifies a function that is close to this, but slightly different. - See #linearTosRGBGamma: and #sRGBGammaToLinear:" - - ^ value raisedTo: gamma! ! -!Color class methodsFor: 'color space conversions' stamp: 'jmv 4/24/2013 10:49'! - linearTosRGBGamma: value - "The sRGB standard specifies a gamma curve that is close to gamma = 2.2, but is actually - built from one stright line segment, and a curve with exponent = 2.4. - This method converts value from linearSpace to gammaSpace, i.e. it 'encodes' with gamma. - This is the operation done when producing an 8bit Form for displaying, or for saving on a JPG, PNG, etc; if source data is in linear space (for example, from raw data a sensor image, or data that was converted previously to linear space for proper image processing). - value must be in [0.0 .. 1.0]. - - See - http://en.wikipedia.org/wiki/Gamma_correction - http://www.poynton.com/notes/colour_and_gamma/GammaFAQ.html - http://entropymine.com/imageworsener/srgbformula - - | r v | - r _ Random new. - 1000 timesRepeat: [ - v _ r next. - self assert: ((Color sRGBGammaToLinear: (Color linearTosRGBGamma: v)) closeTo: v) ] - - | r | - r _ 10@10 extent: 600@400. - Display fill: r fillColor: Color white. - FFT new plot: ((0.0 to: 1.0 count: 100) collect: [ :v | Color linearTosRGBGamma: v ]) in: r color: Color black min: 0.0 max: 1.0. - FFT new plot: ((0.0 to: 1.0 count: 100) collect: [ :v | Color applySimpleGamma: 1/2.2 to: v ]) in: r color: Color blue min: 0.0 max: 1.0. - FFT new plot: ((0.0 to: 1.0 count: 100) collect: [ :v | Color sRGBGammaToLinear: v ]) in: r color: Color black min: 0.0 max: 1.0. - FFT new plot: ((0.0 to: 1.0 count: 100) collect: [ :v | Color applySimpleGamma: 2.2 to: v ]) in: r color: Color blue min: 0.0 max: 1.0. - " - - ^ value <= 0.00313066844250063 - ifTrue: [ value * 12.92 ] - ifFalse: [ (value raisedTo: 1.0/2.4) * 1.055 - 0.055 ]! ! -!Color class methodsFor: 'color space conversions' stamp: 'jmv 4/24/2013 10:50'! - sRGBGammaToLinear: value - "The sRGB standard specifies a gamma curve that is close to gamma = 2.2, but is actually - built from one stright line segment, and a curve with exponent = 2.4. - This method converts value from gammaSpace to linearSpace, i.e. it 'decodes'. - This is the operation done by display screens. It is also needed to convert 8bit Forms (from a frameBuffer, or from PNG, JPG, etc.) to linear space for proper image processing. - value must be in [0.0 .. 1.0]. - - See - http://en.wikipedia.org/wiki/Gamma_correction - http://www.poynton.com/notes/colour_and_gamma/GammaFAQ.html - http://entropymine.com/imageworsener/srgbformula - " - - ^ value <= 0.0404482362771082 - ifTrue: [ value / 12.92 ] - ifFalse: [ value + 0.055 / 1.055 raisedTo: 2.4 ]! ! -!Color class methodsFor: 'cached state access' stamp: 'jmv 4/17/2015 14:58'! - colorNamesDict - "Answer the current dictionary of name->color associations." -" - Color colorNamesDict explore. -" - ColorNamesDict ifNil: [ - self setColorNamesDict: self defaultColorNamesDictionary ]. - ^ColorNamesDict! ! -!Color class methodsFor: 'cached state access' stamp: 'jmv 4/17/2015 15:08'! - grayToIndexMap - " - Color grayToIndexMap explore. - " - GrayToIndexMap ifNil: [ - self initializeGrayToIndexMap ]. - ^GrayToIndexMap! ! -!Color class methodsFor: 'cached state access' stamp: 'jmv 4/17/2015 15:04'! - indexedColors - " - Color indexedColors explore. - " - IndexedColors ifNil: [ - self initializeIndexedColors ]. - ^IndexedColors! ! -!Color class methodsFor: 'cached state access' stamp: 'jmv 5/12/2016 14:58'! - releaseClassCachedState - " - Color releaseClassCachedState - " - CachedColormaps _ nil. "Maps to translate between color depths" - ToGrayColormaps _ nil. "Maps colors to 8bpp grays for various color depths" - FromGrayColormaps _ nil. "Maps from 8bpp grays to colors of various depths" - MaskingMap _ nil. "Maps all colors except transparent to black for creating a mask" - ColorNamesDict _ nil. - IndexedColors _ nil. - GrayToIndexMap _ nil! ! -!TranslucentColor methodsFor: 'accessing' stamp: 'jmv 6/18/2017 20:41:17'! - alpha - "Return my alpha value, a number between 0.0 and 1.0 where 0.0 is completely transparent and 1.0 is completely opaque." - - ^ self at: 4! ! -!TranslucentColor methodsFor: 'printing' stamp: 'jmv 1/5/2014 21:06'! - storeArrayValuesOn: aStream - - self isTransparent ifTrue: [ - ^ aStream space]. - super storeArrayValuesOn: aStream. - aStream space. - self alpha printOn: aStream fractionDigits: 3! ! -!TranslucentColor methodsFor: 'printing' stamp: 'jmv 1/5/2014 21:20'! - storeOn: aStream - - self isTransparent ifTrue: [^ aStream nextPutAll: '(Color transparent)']. - aStream - nextPut: $(; - nextPutAll: self class name; - nextPutAll: ' r: '. - self red printOn: aStream fractionDigits: 3. - aStream nextPutAll: ' g: '. - self green printOn: aStream fractionDigits: 3. - aStream nextPutAll: ' b: '. - self blue printOn: aStream fractionDigits: 3. - aStream nextPutAll: ' alpha: '. - self alpha printOn: aStream fractionDigits: 3. - aStream nextPutAll: ')'! ! -!TranslucentColor methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:55:03'! - alpha: alphaValue - "Return a new TranslucentColor with the given amount of opacity ('alpha')." - alphaValue = 1.0 ifTrue: [ - ^ Color new - setRed: self red - green: self green - blue: self blue]. - ^ super alpha: alphaValue! ! -!TranslucentColor methodsFor: 'conversions' stamp: 'sw 10/27/1999 10:51'! - asNontranslucentColor - ^ self alpha: 1.0! ! -!TranslucentColor methodsFor: 'conversions' stamp: 'jmv 4/19/2013 16:10'! - bitPatternForDepth: depth - "Return an appropriate bit pattern. This will almost never be meaningful for tranlucentColors, except for the degenerate case of tranparency." - - self isTransparent ifTrue: [ - ^ Bitmap with: 0]. - ^ super bitPatternForDepth: depth! ! -!TranslucentColor methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:41:47'! - pixelValueForDepth: d - "Return the pixel value for this color at the given depth. Translucency only works in RGB; this color will appear either opaque or transparent at all other depths." - | basicPixelWord | - "In 32bpp, if alpha = 0, ignore any color components, and answer R=0, G=0, B=0, Alpha=0. - In depths > 8 and < 32, pixelValue zero is the special value used by BitBlt to denote transparent." - self isTransparent ifTrue: [ - ^ 0]. - basicPixelWord _ super pixelValueForDepth: d. - ^d < 32 - ifTrue: [ basicPixelWord ] - ifFalse: [ (basicPixelWord bitAnd: 16rFFFFFF) bitOr: - ((self alpha*255.0) rounded - bitShift: 24) ]! ! -!TranslucentColor methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:41:50'! - pixelWordForDepth: depth - "Return the pixel value for this color at the given depth. Translucency only works in RGB; this color will appear either opaque or transparent at all other depths." - - | basicPixelWord | - self isTransparent ifTrue: [^ 0]. - basicPixelWord _ super pixelWordForDepth: depth. - ^depth < 32 - ifTrue: [ basicPixelWord ] - ifFalse: [ (basicPixelWord bitAnd: 16rFFFFFF) bitOr: - ((self alpha*255.0) rounded - bitShift: 24) ]! ! -!TranslucentColor methodsFor: 'private' stamp: 'jmv 6/18/2017 20:42:05'! - setRed: r green: g blue: b alpha: alphaValue - - self basicSetRed: r green: g blue: b. - self at: 4 put: alphaValue! ! -!TranslucentColor methodsFor: 'queries' stamp: 'jmv 6/18/2017 20:41:26'! - isOpaque - - ^self alpha = 1.0! ! -!TranslucentColor methodsFor: 'queries' stamp: 'jmv 6/18/2017 20:41:54'! - isTransparent - ^ self alpha = 0.0! ! -!TranslucentColor class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:54:35'! - new - ^ self new: 4! ! -!TranslucentColor class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:57:08'! - r: r g: g b: b alpha: alphaValue - "Return a color with the given r, g, and b components in the range [0.0..1.0]." - - ^ self new - setRed: r - green: g - blue: b - alpha: alphaValue! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3110-CallItColorAgain-JuanVuletich-2017Jun19-11h54m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3109] on 19 June 2017 at 12:07:06 pm'! -!Integer methodsFor: 'converting' stamp: 'ar 10/31/1998 23:04' prior: 50348255! - asColorOfDepth: d - "Return a color value representing the receiver as color of the given depth" - ^Color colorFromPixelValue: self depth: d! ! -!InputSensor methodsFor: 'keyboard' stamp: 'jmv 9/2/2016 11:08:09' prior: 50348263! - kbdTest - " - Sensor kbdTest - " - "This test routine will print the unmodified character, its keycode, - and the OR of all its modifier bits, until the character x is typed - -Also useful: - Sensor test - " - | char | - char _ nil. - [ char = $x ] whileFalse: [ - [ self keyboardPressed ] whileFalse. - char _ self keyboard. - Display fill: (5@5 extent: 400@20) fillColor: Color white. - (String streamContents: [ :s | - s - nextPut: $-; - nextPut: char; - nextPut: $-; - space; - print: char numericValue; - space. - self isMouseButton3Pressed ifTrue: [ s nextPutAll: ' mouseButton3/blue/tertiary/halo ' ]. - self isMouseButton2Pressed ifTrue: [ s nextPutAll: ' mouseButton2/yellow/secondary/menu ' ]. - self isMouseButton1Pressed ifTrue: [ s nextPutAll: ' mouseButton1/red/primary ' ]. - self shiftPressed ifTrue: [ s nextPutAll: ' shift ' ]. - self controlKeyPressed ifTrue: [ s nextPutAll: ' control/ctrl ' ]. - (self primMouseButtons anyMask: 32) ifTrue: [ s nextPutAll: ' macOption ' ]. - self commandAltKeyPressed ifTrue: [ s nextPutAll: ' macCommand/winAlt ' ]]) - displayAt: 10 @ 10 ].! ! -!String methodsFor: 'displaying' stamp: 'jmv 5/12/2015 15:52' prior: 50348301! - 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 - " - 'Display' displayOn: Display at: 10@10 - "! ! -!Color methodsFor: 'conversions' stamp: 'bf 4/18/2001 16:25' prior: 50353449! - makeForegroundColor - "Make a foreground color contrasting with me" - ^self luminance >= 0.5 - ifTrue: [Color black] - ifFalse: [Color white]! ! -!Color methodsFor: 'groups of shades' stamp: 'tk 6/18/96' prior: 50353629! - mix: color2 shades: thisMany - "Return an array of thisMany colors from self to color2. Very useful for displaying color based on a variable in your program. " - "Color showColors: (Color red mix: Color green shades: 12)" - - | redInc greenInc blueInc rr gg bb c out | - thisMany = 1 ifTrue: [^ Array with: color2]. - redInc _ color2 red - self red / (thisMany-1). - greenInc _ color2 green - self green / (thisMany-1). - blueInc _ color2 blue - self blue / (thisMany-1). - rr _ self red. gg _ self green. bb _ self blue. - out _ (1 to: thisMany) collect: [:num | - c _ Color r: rr g: gg b: bb. - rr _ rr + redInc. - gg _ gg + greenInc. - bb _ bb + blueInc. - c]. - out at: out size put: color2. "hide roundoff errors" - ^ out -! ! -!Color methodsFor: 'groups of shades' stamp: 'di 10/23/2000 09:45' prior: 50353654! - wheel: thisMany - "An array of thisMany colors around the color wheel starting at self and ending all the way around the hue space just before self. Array is of length thisMany. Very useful for displaying color based on a variable in your program. " - - | sat bri hue step c | - sat _ self saturation. - bri _ self brightness. - hue _ self hue. - step _ 360.0 / (thisMany max: 1). - ^ (1 to: thisMany) collect: [:num | - c _ Color h: hue s: sat v: bri. "hue is taken mod 360" - hue _ hue + step. - c]. -" -(Color wheel: 8) withIndexDo: [:c :i | Display fill: (i*10@20 extent: 10@20) fillColor: c] -"! ! -!Color methodsFor: 'named colors' stamp: 'KenD 1/26/2013 16:33' prior: 50353711! - closestColor - "Answer the closest matching color in the colorNames dictionary" - -" - (Color red lighter lighter) closestColor explore. -" - ^ self closestColorFrom: (Color colorNamesDict)! ! -!Color methodsFor: 'named colors' stamp: 'KenD 1/26/2013 16:36' prior: 50353719! - closestColorAssociation - "Answer this color's closest name->color match." - -" - (Color blue lighter lighter) closestColorAssociation explore. -" - ^ self closestAssocFrom: (Color colorNamesDict)! ! -!Color methodsFor: 'named colors' stamp: 'KenD 1/26/2013 16:36' prior: 50353736! - closestColorName - "Answer the name symbol of the closest matching color in the colorNames dictionary" -" - (Color red lighter lighter) closestColor name. -" - - ^ self closestNameFrom: (Color colorNamesDict)! ! -!Color methodsFor: 'other' stamp: 'KenD 7/18/2015 20:41' prior: 50353753! - colorName - "Return this color's name, or nil if it has no name. Only returns a name if it exactly matches the named color." - - ^(Color colorNamesDict keyAtValue: self ifAbsent: [nil]) -! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:50' prior: 50354000! - adjustBrightness: brightness - "Adjust the relative brightness of this color. (lowest value is 0.005 so that hue information is not lost)" - - ^ Color - h: self hue - s: self saturation - v: (self brightness + brightness min: 1.0 max: 0.005) - alpha: self alpha! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:51' prior: 50354011! - adjustSaturation: saturation brightness: brightness - "Adjust the relative saturation and brightness of this color. (lowest value is 0.005 so that hue information is not lost)" - - ^ Color - h: self hue - s: (self saturation + saturation min: 1.0 max: 0.005) - v: (self brightness + brightness min: 1.0 max: 0.005) - alpha: self alpha! ! -!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 11:55' prior: 50354034! -alphaMixed: proportion with: aColor - "Answer this color mixed with the given color. The proportion, a number - between 0.0 and 1.0, determines what what fraction of the receiver to - use in the mix. For example, 0.9 would yield a color close to the - receiver. This method uses RGB interpolation; HSV interpolation can lead - to surprises. Mixes the alphas (for transparency) also." - - | frac1 frac2 | - frac1 _ proportion asFloat min: 1.0 max: 0.0. - frac2 _ 1.0 - frac1. - ^ Color - r: self red * frac1 + (aColor red * frac2) - g: self green * frac1 + (aColor green * frac2) - b: self blue * frac1 + (aColor blue * frac2) - alpha: self alpha * frac1 + (aColor alpha * frac2)! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/23/2002 01:38' prior: 50354074! - blacker - - ^ self alphaMixed: 0.8333 with: Color black -! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:54' prior: 50354078! - dansDarker - "Return a darker shade of the same color. - An attempt to do better than the current darker method. - (now obsolete, since darker has been changed to do this. -dew)" - ^ Color h: self hue s: self saturation - v: (self brightness - 0.16 max: 0.0)! ! -!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 12:00' prior: 50354104! - mixed: proportion with: aColor - "Mix with another color and do not preserve transpareny. Only use this for extracting the RGB value and mixing it. All other callers should use instead: - aColor alphaMixed: proportion with: anotherColor - " - - | frac1 frac2 | - frac1 _ proportion asFloat min: 1.0 max: 0.0. - frac2 _ 1.0 - frac1. - ^ Color - r: self red * frac1 + (aColor red * frac2) - g: self green * frac1 + (aColor green * frac2) - b: self blue * frac1 + (aColor blue * frac2)! ! -!Color methodsFor: 'transformations' stamp: 'dew 1/19/2002 01:29' prior: 50354122! - muchDarker - - ^ self alphaMixed: 0.5 with: Color black -! ! -!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 12:07' prior: 50354126! - muchLighter - - ^ self alphaMixed: 0.233 with: Color white -! ! -!Color methodsFor: 'transformations' stamp: 'ar 6/19/1999 00:36' prior: 50354130! - negated - "Return an RGB inverted color" - ^Color - r: 1.0 - self red - g: 1.0 - self green - b: 1.0 - self blue! ! -!Color methodsFor: 'transformations' stamp: 'jmv 9/10/2009 18:41' prior: 50354151! - quiteBlacker - - ^ self alphaMixed: 0.8 with: Color black -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 9/10/2009 18:44' prior: 50354155! - quiteWhiter - - ^ self alphaMixed: 0.6 with: Color white! ! -!Color methodsFor: 'transformations' stamp: 'dew 1/19/2002 01:25' prior: 50354168! - slightlyWhiter - - ^ self alphaMixed: 0.85 with: Color white -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 8/23/2009 23:24' prior: 50354185! - veryMuchDarker - - ^ self alphaMixed: 0.25 with: Color black -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 7/28/2016 15:43:04' prior: 50354190! - veryMuchLighter - - ^ self alphaMixed: 0.07 with: Color white! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/23/2002 01:38' prior: 50354195! - whiter - - ^ self alphaMixed: 0.8333 with: Color white -! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/2/2016 15:04' prior: 50354388! - colorFromPixelValue: p depth: d - "Convert a pixel value for the given display depth into a color." - "Details: For depths of 8 or less, the pixel value is simply looked up in a table. For greater depths, the color components are extracted and converted into a color." - "Warning: In BitBlt, a pixel with pixelValue = 0 is transparent. - Squeak usually assumes that r=g=b=0 => transparent. But this is false if we have alpha (opacity). - A color with r=g=b=0 and opacity = 255 is BLACK, not TRANSPARENT. - Squeak also answers darkest possible blue when asked for black. Again, this is not needed in 32 bits (with alpha). It is also not really needed for 16 bits as we have an extra, unused bit: 16r8000 is not zero, but rgb=0, and hence, black. - The real rule is that pixelValue=0 means transparent. - And that darkest blue must be used instead of black, but only for depths >8 and < 16 (no indexed colors, no alpha) - This method is updated to reflect that." - - | r g b alpha | - - d = 1 ifTrue: [^ self indexedColors at: (p bitAnd: 16r01) + 1]. - - "For the rest of the depths, pixelValue = 0 means transparent, and darkest blue is considered to be black." - p = 0 ifTrue: [ ^Color transparent ]. - - d = 8 ifTrue: [^ self indexedColors at: (p bitAnd: 16rFF) + 1]. - d = 4 ifTrue: [^ self indexedColors at: (p bitAnd: 16r0F) + 1]. - d = 2 ifTrue: [^ self indexedColors at: (p bitAnd: 16r03) + 1]. - - d = 32 ifTrue: [ - "eight bits per component; 8 bits of alpha" - alpha _ p bitShift: -24. - alpha = 0 ifTrue: [ ^Color transparent ]. - r _ (p bitShift: -16) bitAnd: 16rFF. - g _ (p bitShift: -8) bitAnd: 16rFF. - b _ p bitAnd: 16rFF. - ^alpha < 255 - ifTrue: [ (Color r: r g: g b: b range: 255) alpha: alpha asFloat / 255.0 ] - ifFalse: [ Color r: r g: g b: b range: 255 ]]. - - d = 16 ifTrue: [ - "five bits per component. The most significant bit, unused, allows having real black, without p being zero" - r _ (p bitShift: -10) bitAnd: 16r1F. - g _ (p bitShift: -5) bitAnd: 16r1F. - b _ p bitAnd: 16r1F. - ^ Color r: r g: g b: b range: 31]. - - d = 15 ifTrue: [ - "five bits per component" - r _ (p bitShift: -10) bitAnd: 16r1F. - g _ (p bitShift: -5) bitAnd: 16r1F. - b _ p bitAnd: 16r1F. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Color black ]. - ^ Color r: r g: g b: b range: 31]. - - d = 12 ifTrue: [ - "four bits per component" - r _ (p bitShift: -8) bitAnd: 16rF. - g _ (p bitShift: -4) bitAnd: 16rF. - b _ p bitAnd: 16rF. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Color black ]. - ^ Color r: r g: g b: b range: 15]. - - d = 9 ifTrue: [ - "three bits per component" - r _ (p bitShift: -6) bitAnd: 16r7. - g _ (p bitShift: -3) bitAnd: 16r7. - b _ p bitAnd: 16r7. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Color black ]. - ^ Color r: r g: g b: b range: 7]. - - self error: 'unknown pixel depth: ', d printString! ! -!Color class methodsFor: 'class initialization' stamp: '' prior: 50354719! - initializeIndexedColors - "Build an array of colors corresponding to the fixed colormap used - for display depths of 1, 2, 4, or 8 bits." - "Color initializeIndexedColors" - - | a index grayVal | - a _ Array new: 256. - - "1-bit colors (monochrome)" - a at: 1 put: (Color r: 1.0 g: 1.0 b: 1.0). "white or transparent" - a at: 2 put: (Color r: 0.0 g: 0.0 b: 0.0). "black" - - "additional colors for 2-bit color" - a at: 3 put: (Color r: 1.0 g: 1.0 b: 1.0). "opaque white" - a at: 4 put: (Color r: 0.5 g: 0.5 b: 0.5). "1/2 gray" - - "additional colors for 4-bit color" - a at: 5 put: (Color r: 1.0 g: 0.0 b: 0.0). "red" - a at: 6 put: (Color r: 0.0 g: 1.0 b: 0.0). "green" - a at: 7 put: (Color r: 0.0 g: 0.0 b: 1.0). "blue" - a at: 8 put: (Color r: 0.0 g: 1.0 b: 1.0). "cyan" - a at: 9 put: (Color r: 1.0 g: 1.0 b: 0.0). "yellow" - a at: 10 put: (Color r: 1.0 g: 0.0 b: 1.0). "magenta" - - a at: 11 put: (Color r: 0.125 g: 0.125 b: 0.125). "1/8 gray" - a at: 12 put: (Color r: 0.25 g: 0.25 b: 0.25). "2/8 gray" - a at: 13 put: (Color r: 0.375 g: 0.375 b: 0.375). "3/8 gray" - a at: 14 put: (Color r: 0.625 g: 0.625 b: 0.625). "5/8 gray" - a at: 15 put: (Color r: 0.75 g: 0.75 b: 0.75). "6/8 gray" - a at: 16 put: (Color r: 0.875 g: 0.875 b: 0.875). "7/8 gray" - - "additional colors for 8-bit color" - "24 more shades of gray (1/32 increments but not repeating 1/8 increments)" - index _ 17. - 1 to: 31 do: [:v | - (v \\ 4) = 0 ifFalse: [ - grayVal _ v / 32.0. - a at: index put: (Color r: grayVal g: grayVal b: grayVal). - index _ index + 1]]. - - "The remainder of color table defines a color cube with six steps - for each primary color. Note that the corners of this cube repeat - previous colors, but this simplifies the mapping between RGB colors - and color map indices. This color cube spans indices 40 through 255 - (indices 41-256 in this 1-based array)." - 0 to: 5 do: [:r | - 0 to: 5 do: [:g | - 0 to: 5 do: [:b | - index _ 41 + ((36 * r) + (6 * b) + g). - index > 256 ifTrue: [ - self error: 'index out of range in color table compuation']. - a at: index put: (Color r: r g: g b: b range: 5)]]]. - - IndexedColors _ a. -! ! -!Color class methodsFor: 'examples' stamp: 'jmv 8/17/2012 18:48' prior: 50354788! - colorRampForDepth: depth extent: aPoint - "Returns a form of the given size showing R, G, B, and gray ramps for the given depth. Useful for testing color conversions between different depths." - "(Color colorRampForDepth: Display depth extent: 256@80) display" - "(Color colorRampForDepth: 32 extent: 256@80) displayOn: Display at: 0@0 rule: Form paint" - - | f dx dy r | - f _ Form extent: aPoint depth: depth. - dx _ aPoint x // 256. - dy _ aPoint y // 4. - 0 to: 255 do: [:i | - r _ (dx * i)@0 extent: dx@dy. - f fill: r fillColor: (Color r: i g: 0 b: 0 range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Color r: 0 g: i b: 0 range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Color r: 0 g: 0 b: i range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Color r: i g: i b: i range: 255)]. - ^ f -! ! -!Color class methodsFor: 'examples' stamp: '' prior: 50354892! - showColorCube - "Show a 12x12x12 color cube." - "Color showColorCube" - - 0 to: 11 do: [:r | - 0 to: 11 do: [:g | - 0 to: 11 do: [:b | - Display fill: (((r*60) + (b*5)) @ (g*5) extent: 5@5) - fillColor: (Color r: r g: g b: b range: 11)]]]. -! ! -!Color class methodsFor: 'examples' stamp: '' prior: 50354912! - showHSVPalettes - "Shows a palette of hues, varying the saturation and brightness for each one. Best results are with depths 16 and 32." - "Color showHSVPalettes" - - | left top c | - left _ top _ 0. - 0 to: 179 by: 15 do: [:h | - 0 to: 10 do: [:s | - left _ (h * 4) + (s * 4). - 0 to: 10 do: [:v | - c _ Color h: h s: s asFloat / 10.0 v: v asFloat / 10.0. - top _ (v * 4). - Display fill: (left@top extent: 4@4) fillColor: c. - - c _ Color h: h + 180 s: s asFloat / 10.0 v: v asFloat / 10.0. - top _ (v * 4) + 50. - Display fill: (left@top extent: 4@4) fillColor: c]]]. -! ! -!Color class methodsFor: 'examples' stamp: '' prior: 50354949! - wheel: thisMany - "Return a collection of thisMany colors evenly spaced around the color wheel." - "Color showColors: (Color wheel: 12)" - - ^ Color wheel: thisMany saturation: 0.9 brightness: 0.7 -! ! -!Color class methodsFor: 'examples' stamp: '' prior: 50354957! - wheel: thisMany saturation: s brightness: v - "Return a collection of thisMany colors evenly spaced around the color wheel, all of the given saturation and brightness." - "Color showColors: (Color wheel: 12 saturation: 0.4 brightness: 1.0)" - "Color showColors: (Color wheel: 12 saturation: 0.8 brightness: 0.5)" - - ^ (Color h: 0.0 s: s v: v) wheel: thisMany -! ! -!Color class methodsFor: 'colormaps' stamp: '' prior: 50355357! - colorMapIfNeededFrom: sourceDepth to: destDepth - "Return a colormap for mapping between the given depths, or nil if no colormap is needed." - "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" - - sourceDepth = destDepth ifTrue: [^ nil]. "not needed if depths are the same" - - (sourceDepth >= 16) & (destDepth >= 16) ifTrue: [ - "mapping is done in BitBlt by zero-filling or truncating each color component" - ^ nil]. - - ^ Color cachedColormapFrom: sourceDepth to: destDepth -! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 5/12/2016 15:56' prior: 50355472! - computeColormapFromGray8bppForDepth: destDepth - "Return a colormap for displaying a GrayForm at the given depth" - - | newMap | - newMap _ Bitmap new: 256. - 1 to: 256 do: [ :i | - newMap - at: i - put: ((Color gray: (i-1) asFloat / 255.0) pixelValueForDepth: destDepth)]. - ^ newMap! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 4/17/2015 15:05' prior: 50355483! - computeIndexedColorConvertingMap: targetColor from: sourceDepth to: destDepth - | map | - - map _ (self indexedColors copyFrom: 1 to: (1 bitShift: sourceDepth)) collect: [ :cc | | f c | - f _ 1.0 - (cc red + cc green + cc blue / 3.0 ). - c _ targetColor - ifNotNil: [ - destDepth = 32 - ifTrue: [ targetColor * f alpha: f] - ifFalse: [ targetColor alphaMixed: f*1.5 with: Color white ]] - ifNil: [ cc ]. - destDepth = 32 - ifTrue: [ c pixelValueForDepth: destDepth] - ifFalse: [ - f = 0.0 - ifTrue: [ 0 ] - ifFalse: [ c pixelValueForDepth: destDepth ]]]. - map _ map as: Bitmap. - ^map! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 12/26/2011 13:49' prior: 50355505! - computeRGBColorConvertingMap: targetColor to: destDepth keepSubPixelAA: keepSubPix - "Builds a colormap intended to convert from subpixelAA black values to targetColor values. - keepSubPix - ifTrue: [ Answer colors that also include subpixelAA ] - ifFalse: [ - Take fullpixel luminance level. Apply it to targetColor. - I.e. answer colors with NO subpixelAA ]" - - | mask map c bitsPerColor r g b f v | - - destDepth > 8 - ifTrue: [bitsPerColor _ 5] "retain maximum color resolution" - ifFalse: [bitsPerColor _ 4]. - "Usually a bit less is enough, but make it configurable" - bitsPerColor _ bitsPerColor min: Preferences aaFontsColormapDepth. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - r _ (i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask. - g _ (i bitShift: 0 - bitsPerColor) bitAnd: mask. - b _ (i bitShift: 0) bitAnd: mask. - f _ 1.0 - (r + g + b / 3.0 / mask). - c _ targetColor - ifNotNil: [ - (keepSubPix and: [destDepth > 8]) ifTrue: [ - Color - r: 1.0 - (r asFloat/mask) * targetColor red - g: 1.0 - (g asFloat/mask) * targetColor green - b: 1.0 - (b asFloat/mask) * targetColor blue - alpha: f * targetColor alpha "alpha will be ignored below, in #pixelValueForDepth: if destDepth ~= 32" ] - ifFalse: [ - destDepth = 32 - ifTrue: [ targetColor * f alpha: f * targetColor alpha ] - ifFalse: [ targetColor alphaMixed: f*1.5 with: Color white ]]] - ifNil: [ Color r: r g: g b: b range: mask]. "This is currently used only to keep some SubPixelAA on destDepth = 8, using a single pass of rule 25" - v _ destDepth = 32 - ifTrue: [ c pixelValueForDepth: destDepth] - ifFalse: [ - f < 0.1 - ifTrue: [ 0 ] - ifFalse: [ c pixelValueForDepth: destDepth ]]. - map at: i + 1 put: v ]. - ^ map! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 1/30/2011 23:10' prior: 50355565! - computeRGBColormapFor: destDepth bitsPerColor: bitsPerColor - "Compute a colorMap for translating from 16-bit or 32-bit RGB color to the given depth, using the given number of of bits per color component." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | mask map c | - (#(3 4 5) includes: bitsPerColor) - ifFalse: [self error: 'BitBlt only supports 3, 4, or 5 bits per color component']. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - c _ Color - r: ((i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask) - g: ((i bitShift: 0 - bitsPerColor) bitAnd: mask) - b: ((i bitShift: 0) bitAnd: mask) - range: mask. - map at: i + 1 put: (c pixelValueForDepth: destDepth)]. - - map at: 1 put: (Color transparent pixelWordForDepth: destDepth). "zero always transparent" - ^ map -! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 5/12/2016 15:57' prior: 50355607! - computeRGBColormapForGray8 - "Compute a colorMap for translating from 16-bit or 32-bit RGB color to 8bpp grays, using the default number of of bits per color component." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | bitsPerColor mask map c | - bitsPerColor _ 5. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - c _ Color - r: ((i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask) - g: ((i bitShift: 0 - bitsPerColor) bitAnd: mask) - b: ((i bitShift: 0) bitAnd: mask) - range: mask. - map at: i + 1 put: (c luminance * 255) rounded]. - - ^ map! ! -!Color class methodsFor: 'color from user' stamp: 'jmv 3/1/2010 15:13' prior: 50355673! - colorPaletteForDepth: depth extent: chartExtent - "Display a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." - "Note: It is slow to build this palette, so it should be cached for quick access." - "(Color colorPaletteForDepth: 16 extent: 190@60) display" - - | basicHue x y startHue palette transHt vSteps transCaption grayWidth hSteps | - palette _ Form extent: chartExtent depth: depth. - transCaption _ - (Form extent: 34@9 depth: 1 - fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0) - offset: 0@0). - transHt _ transCaption height. - palette fillWhite: (0@0 extent: palette width@transHt). - palette fillBlack: (0@transHt extent: palette width@1). - transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0). - grayWidth _ 10. - startHue _ 338.0. - vSteps _ palette height - transHt // 2. - hSteps _ palette width - grayWidth. - x _ 0. - startHue to: startHue + 360.0 by: 360.0/hSteps do: [ :h | - basicHue _ Color h: h asFloat s: 1.0 v: 1.0. - y _ transHt+1. - 0 to: vSteps do: [ :n | | c | - c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Color white. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - 1 to: vSteps do: [ :n | | c | - c _ Color black mixed: (n asFloat / vSteps asFloat) with: basicHue. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - x _ x + 1]. - y _ transHt + 1. - 1 to: vSteps * 2 do: [ :n | | c | - c _ Color black mixed: (n asFloat / (vSteps*2) asFloat) with: Color white. - palette fill: (x@y extent: 10@1) fillColor: c. - y _ y + 1]. - ^ palette -! ! -!Color class methodsFor: 'color from user' stamp: 'jmv 7/27/2009 11:32' prior: 50355730! - colorTest: depth extent: chartExtent colorMapper: colorMapper - "Create a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." - "Note: It is slow to build this palette, so it should be cached for quick access." - "(Color colorTest: 32 extent: 570@180 colorMapper: [:c | c]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 7) asInteger / 7 - g: (c green * 7) asInteger / 7 - b: (c blue * 3) asInteger / 3]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 5) asInteger / 5 - g: (c green * 5) asInteger / 5 - b: (c blue * 5) asInteger / 5]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 15) asInteger / 15 - g: (c green * 15) asInteger / 15 - b: (c blue * 15) asInteger / 15]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 31) asInteger / 31 - g: (c green * 31) asInteger / 31 - b: (c blue * 31) asInteger / 31]) display" - - | basicHue x y c startHue palette transHt vSteps transCaption grayWidth hSteps | - palette _ Form extent: chartExtent depth: depth. - transCaption _ - (Form extent: 34@9 depth: 1 - fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0) - offset: 0@0). - transHt _ transCaption height. - palette fillWhite: (0@0 extent: palette width@transHt). - palette fillBlack: (0@transHt extent: palette width@1). - transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0). - grayWidth _ 10. - startHue _ 338.0. - vSteps _ palette height - transHt // 2. - hSteps _ palette width - grayWidth. - x _ 0. - startHue to: startHue + 360.0 by: 360.0/hSteps do: [:h | - basicHue _ Color h: h asFloat s: 1.0 v: 1.0. - y _ transHt+1. - 0 to: vSteps do: [:n | - c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Color white. - c _ colorMapper value: c. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - 1 to: vSteps do: [:n | - c _ Color black mixed: (n asFloat / vSteps asFloat) with: basicHue. - c _ colorMapper value: c. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - x _ x + 1]. - y _ transHt + 1. - 1 to: vSteps * 2 do: [:n | - c _ Color black mixed: (n asFloat / (vSteps*2) asFloat) with: Color white. - c _ colorMapper value: c. - palette fill: (x@y extent: 10@1) fillColor: c. - y _ y + 1]. - ^ palette -! ! -!Color class methodsFor: 'color name lookup' stamp: 'KenD 1/28/2013 20:34' prior: 50355818! - defaultColorNamesDictionary - "Answer a amall but useful name->color dictionary" - - | defaultDict | - "Meld most used xkcd colors into traditional colors." - defaultDict := (self traditionalColorNamesDictionary addAll: - self xkcdFirst48ColorNamesDictionary; - yourself). - - "Override traditional names existing in extended XKCD naming" - defaultDict at: #lightYellow put: (Color r: 1.0 g: 0.996 b: 0.478). - defaultDict at: #lightOrange put: (Color r: 0.992 g: 0.667 b: 0.283). - defaultDict at: #lightCyan put: (Color r: 0.674 g: 1.0 b: 0.988). - defaultDict at: #lightRed put: (Color r: 1.0 g: 0.279 b: 0.298). - defaultDict at: #lightMagenta put: (Color r: 0.98 g: 0.372 b: 0.969). - - ^defaultDict! ! -!Color class methodsFor: 'color name lookup' stamp: 'KenD 2/1/2013 14:39' prior: 50355844! - doesNotUnderstand: aMessage - "Some code takes - Color colorNames - and does - Color perform: aColorname. - - Make this work." - - ^(Color colorNamesDict) - at: (aMessage selector) - ifAbsent: [super doesNotUnderstand: aMessage]! ! -!Color class methodsFor: 'color name lookup' stamp: 'KenD 7/25/2014 21:22' prior: 50355862! - setColorNamesDict: aNameColorDictionary - "Answer the current dictionary of name->color associations." - - "Note: This is a non-standard name because this is a non-standard action!! - Do this if you really, really know what you are doing." - - "Some Colors are required for proper system operation" - Color defaultColorNamesDictionary keysAndValuesDo: [ :colorName :colorValue | - aNameColorDictionary at: colorName ifAbsentPut: colorValue - ]. - - ColorNamesDict := aNameColorDictionary! ! -!Color class methodsFor: 'color name lookup' stamp: 'sqr 10/21/2016 12:44:48' prior: 50355880! - traditionalColorNamesDictionary - "Answer a dictionary of Squeak traditional name->color associations.." - - | nameDict | - nameDict _ Dictionary new. - nameDict at: #black put: (Color r: 0 g: 0 b: 0). - nameDict at: #veryVeryDarkGray put: (Color r: 0.125 g: 0.125 b: 0.125). - nameDict at: #veryDarkGray put: (Color r: 0.25 g: 0.25 b: 0.25). - nameDict at: #darkGray put: (Color r: 0.375 g: 0.375 b: 0.375). - nameDict at: #gray put: (Color r: 0.5 g: 0.5 b: 0.5). - nameDict at: #lightGray put: (Color r: 0.625 g: 0.625 b: 0.625). - nameDict at: #veryLightGray put: (Color r: 0.75 g: 0.75 b: 0.75). - nameDict at: #veryVeryLightGray put: (Color r: 0.875 g: 0.875 b: 0.875). - nameDict at: #white put: (Color r: 1.0 g: 1.0 b: 1.0). - nameDict at: #red put: (Color r: 1.0 g: 0 b: 0). - nameDict at: #yellow put: (Color r: 1.0 g: 1.0 b: 0). - nameDict at: #green put: (Color r: 0 g: 1.0 b: 0). - nameDict at: #cyan put: (Color r: 0 g: 1.0 b: 1.0). - nameDict at: #blue put: (Color r: 0 g: 0 b: 1.0). - nameDict at: #magenta put: (Color r: 1.0 g: 0 b: 1.0). - nameDict at: #brown put: (Color r: 0.6 g: 0.2 b: 0). - nameDict at: #orange put: (Color r: 1.0 g: 0.6 b: 0). - nameDict at: #lightRed put: (Color r: 1.0 g: 0.8 b: 0.8). - nameDict at: #lightYellow put: (Color r: 1.0 g: 1.0 b: 0.8). - nameDict at: #lightGreen put: (Color r: 0.8 g: 1.0 b: 0.6). - nameDict at: #lightCyan put: (Color r: 0.4 g: 1.0 b: 1.0). - nameDict at: #lightBlue put: (Color r: 0.8 g: 1.0 b: 1.0). - nameDict at: #lightMagenta put: (Color r: 1.0 g: 0.8 b: 1.0). - nameDict at: #lightBrown put: (Color r: 1.0 g: 0.6 b: 0.2). - nameDict at: #lightOrange put: (Color r: 1.0 g: 0.8 b: 0.4). - nameDict at: #transparent put: (TranslucentColor r: 0.0 g: 0.0 b: 0.0 alpha: 0.0). - - ^nameDict -! ! -!Color class methodsFor: 'color name lookup' stamp: 'jmv 6/30/2014 15:22' prior: 50355937! - xkcdFirst48ColorNamesDictionary - "XKCD color names are based on a survey oc colors people call by the same name. - http://blog.xkcd.com/2010/05/03/color-survey-results/" - - "Answer a dictionary of the most agreed upon first 48 xkcd colors" -" - Color xkcdFirst48ColorNamesDictionary explore. -" - | xkcdDict | - xkcdDict := Dictionary new - at: #lightPink put: (Color fromString: '#ffd1df') ; - at: #mustard put: (Color fromString: '#ceb301') ; - at: #indigo put: (Color fromString: '#380282') ; - at: #lime put: (Color fromString: '#aaff32') ; - at: #seaGreen put: (Color fromString: '#53fca1') ; - at: #periwinkle put: (Color fromString: '#8e82fe') ; - at: #darkPink put: (Color fromString: '#cb416b') ; - at: #oliveGreen put: (Color fromString: '#677a04') ; - at: #peach put: (Color fromString: '#ffb07c') ; - at: #paleGreen put: (Color fromString: '#c7fdb5') ; - at: #lightBrown put: (Color fromString: '#ad8150') ; - at: #hotPink put: (Color fromString: '#ff028d') ; - at: #black put: (Color fromString: '#000000') ; - at: #lilac put: (Color fromString: '#cea2fd') ; - at: #navyBlue put: (Color fromString: '#001146') ; - at: #royalBlue put: (Color fromString: '#0504aa') ; - at: #beige put: (Color fromString: '#e6daa6') ; - at: #salmon put: (Color fromString: '#ff796c') ; - at: #olive put: (Color fromString: '#6e750e') ; - at: #maroon put: (Color fromString: '#650021') ; - at: #brightGreen put: (Color fromString: '#01ff07') ; - at: #darkPurple put: (Color fromString: '#35063e') ; - at: #mauve put: (Color fromString: '#ae7181') ; - at: #forestGreen put: (Color fromString: '#06470c') ; - at: #aqua put: (Color fromString: '#13eac9') ; - at: #cyan put: (Color fromString: '#00ffff') ; - at: #tan put: (Color fromString: '#d1b26f') ; - at: #darkBlue put: (Color fromString: '#00035b') ; - at: #lavender put: (Color fromString: '#c79fef') ; - at: #turquoise put: (Color fromString: '#06c2ac') ; - at: #darkGreen put: (Color fromString: '#033500') ; - at: #violet put: (Color fromString: '#9a0eea') ; - at: #lightPurple put: (Color fromString: '#bf77f6') ; - at: #limeGreen put: (Color fromString: '#89fe05') ; - at: #grey put: (Color fromString: '#929591') ; - at: #skyBlue put: (Color fromString: '#75bbfd') ; - at: #yellow put: (Color fromString: '#ffff14') ; - at: #magenta put: (Color fromString: '#c20078') ; - at: #lightGreen put: (Color fromString: '#96f97b') ; - at: #orange put: (Color fromString: '#f97306') ; - at: #teal put: (Color fromString: '#029386') ; - at: #lightBlue put: (Color fromString: '#95d0fc') ; - at: #red put: (Color fromString: '#e50000') ; - at: #brown put: (Color fromString: '#653700') ; - at: #pink put: (Color fromString: '#ff81c0') ; - at: #blue put: (Color fromString: '#0343df') ; - at: #green put: (Color fromString: '#15b01a') ; - at: #purple put: (Color fromString: '#7e1e9c') ; - yourself. - - ^xkcdDict - -! ! -!SystemDictionary methodsFor: 'shrinking' stamp: 'jmv 4/25/2016 15:31' prior: 50348313! - reduceCuis - " - Smalltalk reduceCuis - " - | keep n unused newDicts oldDicts | - - self nominallyUnsent: #reduceCuis. - - "Remove icons" - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - PasteUpMorph allInstancesDo: [ :w | - w backgroundImageData: nil. - w submorphsDo: [ :a | a delete ]]. - Preferences useNoIcons. - Theme current initialize. - Theme content: nil. - Color shutDown. - BitBltCanvas releaseClassCachedState. - - Transcript clear. - Clipboard default initialize. - - - "Remove some methods, even if they have senders." -" ColorPickerMorph class removeSelector: #buildEyedropperIcon." - Theme removeSelector: #miscellaneousIcons. - Utilities removeSelector: #vmStatisticsReportString. - SystemDictionary removeSelector: #recreateSpecialObjectsArray. - - StrikeFont removeMostFonts. - StrikeFont saveSpace. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - - keep := OrderedCollection new. - keep addAll: #(SpaceTally). - AppLauncher appGlobalName ifNotNil: [ :any | - keep add: any ]. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - [ - #hereWeGo print. - unused do: [:c | - c print. - (Smalltalk at: c) removeFromSystem]. - n := Smalltalk removeAllUnSentMessages. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - n > 0 or: [ - unused notEmpty ]] whileTrue. - ChangeSet zapAllChangeSets. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - Symbol rehash. - - "Shrink method dictionaries." - Smalltalk garbageCollect. - oldDicts _ MethodDictionary allInstances. - newDicts _ Array new: oldDicts size. - oldDicts withIndexDo: [:d :index | - newDicts at: index put: d rehashWithoutBecome ]. - oldDicts elementsExchangeIdentityWith: newDicts. - oldDicts _ newDicts _ nil. - - SmalltalkCompleter initialize . - - "Sanity checks" -" Undeclared - Smalltalk cleanOutUndeclared - Smalltalk browseUndeclaredReferences - Smalltalk obsoleteClasses - Smalltalk obsoleteBehaviors - Smalltalk browseObsoleteMethodReferences - SmalltalkImage current fixObsoleteReferences - Smalltalk browseAllUnimplementedCalls"! ! -!Transcripter methodsFor: 'accessing' stamp: 'jmv 7/28/2015 08:26' prior: 50348384! - 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]. - textComposition - setModel: (TextModel withText: c asText); - extentForComposing: frame width-8 @9999. - textComposition composeAll. - d _ textComposition usedHeight - frame height. - d > 0 ifTrue: [ - "Scroll up to keep all contents visible" - cb _ textComposition characterBlockAtPoint: - 0@0 + (0@(d+AbstractFont default height)). - self on: (c copyFrom: cb stringIndex to: c size). - readLimit _ position _ collection size. - ^ self endEntry]. - Display fill: (frame insetBy: -2) fillColor: self black; - fill: frame fillColor: self white. - Display getCanvas - textComposition: textComposition - bounds: (4@4 + frame topLeft extent: Display extent) - color: Color black - selectionColor: Color blue. - DisplayScreen screenUpdateRequired: nil! ! -!Transcripter methodsFor: 'private' stamp: 'di 8/14/97 12:12' prior: 50348418! - black - Display depth = 1 ifTrue: [^ Bitmap with: 16rFFFFFFFF "Works without color support"]. - ^ Color black! ! -!Transcripter methodsFor: 'private' stamp: 'di 8/14/97 12:12' prior: 50348424! - white - Display depth = 1 ifTrue: [^ Bitmap with: 0 "Works without color support"]. - ^ Color white! ! -!DataStream class methodsFor: 'as yet unclassified' stamp: '' prior: 50348430! - example - "An example and test of DataStream/ReferenceStream. - 11/19/92 jhm: Use self testWith:." - "DataStream example" - "ReferenceStream example" - | input sharedPoint | - - "Construct the test data." - input _ Array new: 9. - input at: 1 put: nil. - input at: 2 put: true. - input at: 3 put: (Form extent: 63 @ 50 depth: 8). - (input at: 3) fillWithColor: Color lightBlue. - input at: 4 put: #(3 3.0 'three'). - input at: 5 put: false. - input at: 6 put: 1024 @ -2048. - input at: 7 put: #x. - input at: 8 put: (Array with: (sharedPoint _ 0 @ -30000)). - input at: 9 put: sharedPoint. - - "Write it out, read it back, and return it for inspection." - ^ self testWith: input! ! -!ReferenceStream class methodsFor: 'as yet unclassified' stamp: '' prior: 50348456! - example2 -"Here is the way to use DataStream and ReferenceStream: - rr _ ReferenceStream fileNamed: ''test.obj''. - rr nextPut: . - rr close. - -To get it back: - rr _ ReferenceStream fileNamed: ''test.obj''. - _ rr next. - rr close. -" -"An example and test of DataStream/ReferenceStream. - 11/19/92 jhm: Use self testWith:." - "ReferenceStream example2" - | input sharedPoint | - - "Construct the test data." - input _ Array new: 9. - input at: 1 put: nil. - input at: 2 put: true. - input at: 3 put: false. - input at: 4 put: #(-4 -4.0 'four' four). - input at: 5 put: (Form extent: 63 @ 50 depth: 8). - (input at: 5) fillWithColor: Color lightOrange. - input at: 6 put: 1024 @ -2048. - input at: 7 put: input. "a cycle" - input at: 8 put: (Array with: (sharedPoint _ 0 @ -30000)). - input at: 9 put: sharedPoint. - - "Write it out, read it back, and return it for inspection." - ^ self testWith: input -! ! -!TextEditor methodsFor: 'attributes' stamp: 'jmv 12/12/2014 15:53' prior: 50348488! - offerColorMenu - "Present a menu of available colors, and if one is chosen, apply it to the current selection." - "This is a user command, and generates undo" - - | attribute colors index thisSel | - thisSel _ self selection. - colors _ #(#black #magenta #red #yellow #green #blue #cyan #white ). - index _ (PopUpMenu - labelArray: colors , #('choose color...' ) - lines: (Array with: colors size + 1)) startUpMenu. - index = 0 ifTrue: [ ^ true ]. - index <= colors size - ifTrue: [ attribute _ TextColor color: (Color perform: (colors at: index)) ] - ifFalse: [ - index _ index - colors size - 1. - "Re-number!!!!!!" - index = 0 ifTrue: [ attribute _ self chooseColor ]. - thisSel ifNil: [ ^ true ]]. - attribute ifNotNil: [ self applyAttribute: attribute ]. - ^ true.! ! -!TextAction class methodsFor: 'as yet unclassified' stamp: 'jmv 4/19/2015 09:38' prior: 50348516! -textActionColor - ^Color r: 0.4 g: 0 b: 1.0! ! -!TextColor methodsFor: 'testing' stamp: 'jmv 1/21/2011 11:33' prior: 50348520! - isSet - "Do not include Color black, as it is the default color." - ^color ~= Color black! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 50348526! - black - ^ self new color: Color black! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 50348530! - blue - ^ self new color: Color blue! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 50348534! - cyan - ^ self new color: Color cyan! ! -!TextColor class methodsFor: 'constants' stamp: 'ajh 9/10/2002 02:26' prior: 50348538! - gray - ^ self new color: Color gray! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 50348542! - green - ^ self new color: Color green! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 50348546! - magenta - ^ self new color: Color magenta! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 50348550! - red - ^ self new color: Color red! ! -!TextColor class methodsFor: 'constants' stamp: 'sma 3/24/2000 10:50' prior: 50348554! - white - ^ self new color: Color white! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 50348558! - yellow - ^ self new color: Color yellow! ! -!Preferences class methodsFor: 'halos' stamp: 'jmv 4/20/2015 16:17' prior: 50348563! - installHaloSpecsFromArray: anArray - - | aColor | - ^ self parameters at: #HaloSpecs put: (anArray collect: [ :each | - aColor _ Color. - each fourth do: [ :sel | aColor _ aColor perform: sel]. - HaloSpec new - horizontalPlacement: each second - verticalPlacement: each third - color: aColor - iconSymbol: each fifth - addHandleSelector: each first - hoverHelp: each sixth])! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 9/19/2016 20:45:55' prior: 50348579! - displayOn: aForm in: aRectangle - " - Transcript displayOn: Display - " - | font count i string x y fh f canvas innerR | - aForm fill: aRectangle fillColor: Color white. - font _ AbstractFont default. - - innerR _ aRectangle insetBy: self padding. - fh _ font height. - count _ innerR height // fh-1. - x _ innerR left. - y _ innerR top. - f _ firstIndex-1. - firstIndex > lastIndex ifTrue: [ f _ f - self maxEntries ]. - i _ (lastIndex - count max: f) \\ self maxEntries + 1. - canvas _ aForm getCanvas. - canvas newClipRect: innerR. - [ - string _ entries at: i. - canvas drawString: string at: x@y font: font color: Color veryDarkGray. - y _ y + fh. - i = lastIndex - ] whileFalse: [ i _ i \\ self maxEntries + 1 ]. - - string _ unfinishedEntry contents. - canvas drawString: string at: x@y font: font color: Color veryDarkGray! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 9/19/2016 20:53:35' prior: 50348608! - displayUnfinishedEntryOn: aForm - - | font count string x y fh canvas r innerR | - innerR _ bounds insetBy: self padding. - lastDisplayPosition < innerR right ifTrue: [ - font _ AbstractFont default. - fh _ font height. - count _ innerR height // fh-1. - x _ innerR left. - string _ unfinishedEntry contents. - y _ ((lastIndex - firstIndex \\ self maxEntries) min: count-1) + 1 * font height + innerR top. - canvas _ aForm getCanvas. - r _ innerR left: lastDisplayPosition. - canvas newClipRect: r. - (canvas drawString: string at: x@y font: font color: Color veryDarkGray) ifNotNil: [ :lastPoint | - lastDisplayPosition _ lastPoint x. - ^r ]]. - ^nil! ! -!Form methodsFor: 'analyzing' stamp: 'ar 5/17/2001 15:40' prior: 50348631! - dominantColor - | tally max maxi | - self depth > 16 ifTrue: - [^(self asFormOfDepth: 16) dominantColor]. - tally _ self tallyPixelValues. - max _ maxi _ 0. - tally withIndexDo: [:n :i | n > max ifTrue: [max _ n. maxi _ i]]. - ^ Color colorFromPixelValue: maxi - 1 depth: self depth! ! -!Form methodsFor: 'bordering' stamp: 'jmv 1/22/2015 10:22' prior: 50348643! - border: aRectangle width: borderWidth - "Paint a border whose rectangular area is defined by aRectangle. The - width of the border of each side is borderWidth. Uses black for - drawing the border." - - self border: aRectangle width: borderWidth fillColor: Color black! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:20' prior: 50348654! - fillBlack - "Set all bits in the receiver to black (ones)." - - self fill: self boundingBox fillColor: Color black! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:20' prior: 50348660! - fillBlack: aRectangle - "Set all bits in the receiver's area defined by aRectangle to black (ones)." - - self fill: aRectangle rule: Form over fillColor: Color black! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:20' prior: 50348668! - fillGray - "Set all bits in the receiver to gray." - - self fill: self boundingBox fillColor: Color gray! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:20' prior: 50348674! - fillGray: aRectangle - "Set all bits in the receiver's area defined by aRectangle to the gray mask." - - self fill: aRectangle rule: Form over fillColor: Color gray! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:21' prior: 50348682! - fillWhite - "Set all bits in the form to white." - - self fill: self boundingBox fillColor: Color white! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:21' prior: 50348688! - fillWhite: aRectangle - "Set all bits in the receiver's area defined by aRectangle to white." - - self fill: aRectangle rule: Form over fillColor: Color white! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:21' prior: 50348696! - reverse - "Change all the bits in the receiver that are white to black, and the ones - that are black to white. - Display reverse - " - - self fill: self boundingBox rule: Form reverse fillColor: Color white! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:21' prior: 50348705! - reverse: aRectangle - "Change all the bits in the receiver's area that intersects with aRectangle - that are white to black, and the ones that are black to white." - - self fill: aRectangle rule: Form reverse fillColor: Color white! ! -!Form methodsFor: 'color mapping' stamp: 'ar 5/17/2001 15:42' prior: 50348715! - colormapIfNeededForDepth: destDepth - "Return a colormap for displaying the receiver at the given depth, or nil if no colormap is needed." - - self depth = destDepth ifTrue: [^ nil]. "not needed if depths are the same" - ^ Color colorMapIfNeededFrom: self depth to: destDepth -! ! -!Form methodsFor: 'color mapping' stamp: 'jmv 5/12/2016 13:53' prior: 50348727! - colormapIfNeededForGray8bpp - "Return a colormap for displaying the receiver at the given depth. - Note: Uses 5 bits per color component. 32bit Forms will lose information!!" - - ^ Color cachedColormapForGrayFrom: self depth! ! -!Form methodsFor: 'color mapping' stamp: 'jmv 9/23/2012 21:42' prior: 50348737! - mapColor: oldColor to: newColor - "Make all pixels of the given color in this Form to the given new color." - "Warnings: This method modifies the receiver. It may lose some color accuracy on 32-bit Forms, since the transformation uses a color map with only 15-bit resolution." - - | map | - map _ (Color cachedColormapFrom: self depth to: self depth) copy. - map at: (oldColor indexInMap: map) put: (newColor pixelWordForDepth: self depth). - (BitBlt toForm: self) - sourceForm: self; - sourceOrigin: 0@0; - combinationRule: Form over; - destX: 0 destY: 0 width: width height: height; - colorMap: map; - copyBits. -! ! -!Form methodsFor: 'color mapping' stamp: 'jmv 1/31/2011 09:21' prior: 50348759! - maskingMap - "Return a color map that maps all colors except transparent to words of all ones. Used to create a mask for a Form whose transparent pixel value is zero." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - ^Color maskingMap: self depth! ! -!Form methodsFor: 'converting' stamp: 'jm 11/12/97 19:28' prior: 50348782! - as8BitColorForm - "Simple conversion of zero pixels to transparent. Force it to 8 bits." - - | f map | - f _ ColorForm extent: self extent depth: 8. - self displayOn: f at: self offset negated. - map _ Color indexedColors copy. - map at: 1 put: Color transparent. - f colors: map. - f offset: self offset. - ^ f -! ! -!Form methodsFor: 'pixel access' stamp: 'ar 5/17/2001 15:42' prior: 50348795! - colorAt: aPoint - "Return the color in the pixel at the given point. " - - ^ Color - colorFromPixelValue: (self pixelValueAt: aPoint) - depth: self depth -! ! -!Form methodsFor: 'pixel access' stamp: 'jmv 11/4/2015 12:40' prior: 50348803! - colorInterpolatedAt: aPoint - "Evaluate a bilinear (i.e. cheap) interpolation - Like OpenCV's CV_INTER_LINEAR - Answer Color transparent if outside image bounds. - Copied almost verbatim from FloatImage. - Answer Colors with float components. Will be rounded to be stored in, for example, a 32-bit Form." - - | x y w interpolated xWeight1 xWeight0 yWeight1 yWeight0 xIndex0 xIndex1 yIndex0 yIndex1 | - x _ aPoint x. - y _ aPoint y. - x < 0.0 ifTrue: [ ^Color transparent ]. - xIndex0 _ x truncated. "Could be #floor. But as we only care for values >=0, it is the same. But faster." - xIndex0 > (width-1) ifTrue: [ ^Color transparent ]. - (xIndex0 = (width-1) and: [ x > (width-1) ]) ifTrue: [ ^Color transparent ]. - xIndex1 _ xIndex0 = (width-1) "Avoid the invalid access if this was true, but don't make it slower the most common, general case." - ifFalse: [ xIndex0 + 1 ] - ifTrue: [ xIndex0 ]. - - y < 0.0 ifTrue: [ ^Color transparent ]. - yIndex0 _ y truncated. "Could be #floor. But as we only care for values >=0, it is the same. But faster." - yIndex0 > (height-1) ifTrue: [ ^Color transparent ]. - (yIndex0 = (height-1) and: [ y > (height-1) ]) ifTrue: [ ^Color transparent ]. - yIndex1 _ yIndex0 = (height-1) "Avoid the invalid access if this was true, but don't make it slower the most common, general case." - ifFalse: [ yIndex0 + 1 ] - ifTrue: [ yIndex0 ]. - - xWeight1 _ x - xIndex0. - xWeight0 _ 1.0 - xWeight1. - - yWeight1 _ y - yIndex0. - yWeight0 _ 1.0 - yWeight1. - - "/* perform interpolation */" - w _ ((self colorAt: xIndex0 @ yIndex0) * xWeight0) + - ((self colorAt: xIndex1 @ yIndex0) * xWeight1). - interpolated _ w * yWeight0. - - w _ ((self colorAt: xIndex0 @ yIndex1) * xWeight0) + - ((self colorAt: xIndex1 @ yIndex1) * xWeight1). - interpolated _ w * yWeight1 + interpolated. - - ^interpolated! ! -!Form methodsFor: 'transitions' stamp: 'jmv 7/28/2015 08:32' prior: 50348862! - pageWarp: otherImage at: topLeft forward: forward - "Produce a page-turning illusion that gradually reveals otherImage - located at topLeft in this form. - forward == true means turn pages toward you, else away. [ignored for now]" - | pageRect oldPage nSteps buffer p leafRect sourceQuad warp oldBottom d | - pageRect _ otherImage boundingBox. - oldPage _ self copy: (pageRect translatedBy: topLeft). - (forward ifTrue: [oldPage] ifFalse: [otherImage]) - border: pageRect - widthRectangle: (Rectangle - left: 0 - right: 2 - top: 1 - bottom: 1) - rule: Form over - fillColor: Color black. - oldBottom _ self copy: ((pageRect bottomLeft + topLeft) extent: (pageRect width@(pageRect height//4))). - nSteps _ 8. - buffer _ Form extent: otherImage extent + (0@(pageRect height//4)) depth: self depth. - d _ pageRect topLeft + (0@(pageRect height//4)) - pageRect topRight. - 1 to: nSteps-1 do: - [:i | forward - ifTrue: [buffer copy: pageRect from: otherImage to: 0@0 rule: Form over. - p _ pageRect topRight + (d * i // nSteps)] - ifFalse: [buffer copy: pageRect from: oldPage to: 0@0 rule: Form over. - p _ pageRect topRight + (d * (nSteps-i) // nSteps)]. - buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over. - leafRect _ pageRect topLeft corner: p x @ (pageRect bottom + p y). - sourceQuad _ Array with: pageRect topLeft - with: pageRect bottomLeft + (0@p y) - with: pageRect bottomRight - with: pageRect topRight - (0@p y). - warp _ (WarpBlt toForm: buffer) - clipRect: leafRect; - sourceForm: (forward ifTrue: [oldPage] ifFalse: [otherImage]); - combinationRule: Form paint. - warp copyQuad: sourceQuad toRect: leafRect. - self copy: buffer boundingBox from: buffer to: topLeft rule: Form over. - Display forceToScreen. - ]. - - buffer copy: pageRect from: otherImage to: 0@0 rule: Form over. - buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over. - self copy: buffer boundingBox from: buffer to: topLeft rule: Form over. - Display forceToScreen. -" -1 to: 4 do: [:corner | Display pageWarp: - (Form fromDisplay: (10@10 extent: 200@300)) reverse - at: 10@10 forward: false] -" -! ! -!Form class methodsFor: 'instance creation' stamp: 'jmv 9/23/2012 21:44' prior: 50348933! - dotOfSize: diameter - "Create a form which contains a round black dot." - | radius form bb rect centerX centerY centerYBias centerXBias radiusSquared xOverY maxy dx | - radius _ diameter//2. - form _ self extent: diameter@diameter offset: (0@0) - (radius@radius). - bb _ (BitBlt toForm: form) - sourceX: 0; sourceY: 0; - combinationRule: Form over; - fillColor: Color black. - rect _ form boundingBox. - centerX _ rect center x. - centerY _ rect center y. - centerYBias _ rect height odd ifTrue: [0] ifFalse: [1]. - centerXBias _ rect width odd ifTrue: [0] ifFalse: [1]. - radiusSquared _ (rect height asFloat / 2.0) squared - 0.01. - xOverY _ rect width asFloat / rect height asFloat. - maxy _ rect height - 1 // 2. - - "First do the inner fill, and collect x values" - 0 to: maxy do: - [:dy | - dx _ ((radiusSquared - (dy * dy) asFloat) sqrt * xOverY) truncated. - bb destX: centerX - centerXBias - dx - destY: centerY - centerYBias - dy - width: dx + dx + centerXBias + 1 - height: 1; - copyBits. - bb destY: centerY + dy; - copyBits]. - ^ form -" -Time millisecondsToRun: - [1 to: 20 do: [:i | (Form dotOfSize: i) displayAt: (i*20)@(i*20)]] -"! ! -!Form class methodsFor: 'instance creation' stamp: 'pb 5/4/2016 17:43' prior: 50348972! - fakeSphereAt: aPoint diameter: diameter color: aColor - "Create a form which contains a round black dot." - | bb rect d p | - bb _ GrafPort toForm: Display. - bb fillColor: aColor. - bb combinationRule: Form blend. - rect _ aPoint extent: diameter. - bb fillOval: rect. - p _ (diameter * 2 // 5) asPoint + aPoint. - #(2 3 4 5 6 ) do: [ :i | - "simulate facade by circles of gray" - bb fillColor: (Color white alpha: 0.3). - d _ i * diameter // 10. - rect _ Rectangle - center: p - extent: d. - bb fillOval: rect ]. - DisplayScreen screenUpdateRequired: nil. -" - Form fakeSphereAt: 50@50 diameter: 30 color: (Color red alpha: 0.5) -"! ! -!Form class methodsFor: 'examples' stamp: 'jmv 3/20/2013 22:36' prior: 50348995! - toothpaste: diam - " - Display restoreAfter: [Form toothpaste: 30] - " - "Not completely unlike the ST-80 implementation :) - Original comment: - Draws wormlike lines by laying down images of spheres. - See Ken Knowlton, Computer Graphics, vol. 15 no. 4 p352. - Draw with mouse button down; terminate by option-click." - | point queue color q colors colr colr2 | - colors _ Color red wheel: 12. - color _ 8. - [ true ] whileTrue: [ - queue _ OrderedCollection new: 32. - 16 timesRepeat: [queue addLast: -40@-40]. - Sensor waitButton. - Sensor isMouseButton2Pressed ifTrue: [^ self]. - point _ Sensor mousePoint. - colr _ colors atWrap: (color _ color + 5). "choose increment relatively prime to colors size" - colr2 _ colr alpha: 0.3. - [Sensor isMouseButton1Pressed or: [queue size > 0]] whileTrue: [ - point _ point * 4 + Sensor mousePoint // 5. - point _ point. - Form fakeSphereAt: point diameter: diam color: colr. - (q _ queue removeFirst) ifNil: [^ self]. "exit" - Form fakeSphereAt: q diameter: diam color: colr2. - Sensor isMouseButton1Pressed ifTrue: [queue addLast: point]]]! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 5/15/2015 09:37' prior: 50349032! - bottomLeftCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - "Create and answer a Form for the bottomLeft corner of a rounded rectangle" - | f aaw topColor bottomColor l d c width dy | - topColor _ Color white * gradientTopFactor. - bottomColor _ Color white * gradientBottomFactor. - width _ r. - aaw _ 1.3. - f _ Form - extent: width @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: width - 1 - do: [ :x | - dy _ height - r - y. - dy > 0 - ifTrue: [ l _ 1.0 ] - ifFalse: [ - d _ (width - 1 - x @ dy) r. - l _ ((r - d max: 0.0) min: aaw) / aaw ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 5/15/2015 09:47' prior: 50349060! - bottomLeftCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor borderWidth: bw - "Create and answer a Form for the bottomLeft corner of a rounded rectangle" - | f aaw topColor bottomColor l d c width dy l1 l2 | - topColor _ Color white * gradientTopFactor. - bottomColor _ Color white * gradientBottomFactor. - width _ r. - aaw _ 1.3. - f _ Form - extent: width @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: width - 1 - do: [ :x | - dy _ height - r - y. - dy > 0 - ifTrue: [ l _ 1.0 ] - ifFalse: [ - d _ (width - 1 - x @ dy) r. - l1 _ ((r - d-1+aaw max: 0.0) min: aaw) / aaw. - l2 _ ((d - r+bw+aaw max: 0.0) min: aaw) / aaw. - l _ l1 min: l2. - ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 5/15/2015 09:38' prior: 50349091! - bottomRightCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - "Create and answer a Form for the bottomRight corner of a rounded rectangle" - | f aaw topColor bottomColor l d c width dy | - topColor _ Color white * gradientTopFactor. - bottomColor _ Color white * gradientBottomFactor. - width _ r. - aaw _ 1.3. - f _ Form - extent: width @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: width - 1 - do: [ :x | - dy _ height - r - y. - dy > 0 - ifTrue: [ l _ 1.0 ] - ifFalse: [ - d _ (x @ dy) r. - l _ ((r - d max: 0.0) min: aaw) / aaw ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 5/15/2015 09:41' prior: 50349118! - bottomRightCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor borderWidth: bw - "Create and answer a Form for the bottomLeft corner of a rounded rectangle" - | f aaw topColor bottomColor l d c width dy l1 l2 | - topColor _ Color white * gradientTopFactor. - bottomColor _ Color white * gradientBottomFactor. - width _ r. - aaw _ 1.3. - f _ Form - extent: width @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: width - 1 - do: [ :x | - dy _ height - r - y. - dy > 0 - ifTrue: [ l _ 1.0 ] - ifFalse: [ - d _ (x @ dy) r. - l1 _ ((r - d-1+aaw max: 0.0) min: aaw) / aaw. - l2 _ ((d - r+bw+aaw max: 0.0) min: aaw) / aaw. - l _ l1 min: l2. - ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 11/30/2010 10:34' prior: 50349149! - topLeftCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - "Create and answer a Form with a vertical gray gradient as specified for the topLeft corner of a rounded rectangle" - | f bw topColor bottomColor l d c w | - topColor _ Color white * gradientTopFactor. - bottomColor _ Color white * gradientBottomFactor. - w _ r. - bw _ 1.3. - f _ Form - extent: w @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: w - 1 - do: [ :x | - l _ 1.0. - y < r ifTrue: [ - d _ (w - 1 - x @ (w - 1 - y)) r. - l _ ((r - d max: 0.0) min: bw) / bw ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 11/30/2010 10:36' prior: 50349176! - topRightCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - "Create and answer a Form with a vertical gray gradient as specified for the topRight corner of a rounded rectangle" - | f bw topColor bottomColor l d c w | - topColor _ Color white * gradientTopFactor. - bottomColor _ Color white * gradientBottomFactor. - w _ r. - bw _ 1.3. - f _ Form - extent: w @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: w - 1 - do: [ :x | - l _ 1.0. - y < r ifTrue: [ - d _ (x @ (w - y - 1)) r. - l _ ((r - d max: 0.0) min: bw) / bw ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!ColorForm methodsFor: 'accessing' stamp: 'ar 5/17/2001 15:45' prior: 50349202! - colors: colorList - "Set my color palette to the given collection." - - | colorArray colorCount newColors | - colorList ifNil: [ - colors _ cachedDepth _ cachedColormap _ nil. - ^ self]. - - colorArray _ colorList asArray. - colorCount _ colorArray size. - newColors _ Array new: (1 bitShift: self depth). - 1 to: newColors size do: [:i | - i <= colorCount - ifTrue: [newColors at: i put: (colorArray at: i)] - ifFalse: [newColors at: i put: Color transparent]]. - - colors _ newColors. - cachedDepth _ nil. - cachedColormap _ nil. -! ! -!ColorForm methodsFor: 'color manipulation' stamp: 'di 11/11/1998 13:20' prior: 50349222! - asGrayScale - "Return a grayscale ColorForm computed by mapping each color into its grayscale equivalent" - ^ self copy colors: - (colors collect: - [:c | c isTransparent ifTrue: [c] - ifFalse: [Color gray: c luminance]])! ! -!ColorForm methodsFor: 'color manipulation' stamp: 'jmv 3/1/2010 09:41' prior: 50349232! - colormapIfNeededForDepth: destDepth - "Return a colormap for displaying the receiver at the given depth, or nil if no colormap is needed." - - | newMap | - colors ifNil: [ - "use the standard colormap" - ^ Color colorMapIfNeededFrom: self depth to: destDepth]. - - (destDepth = cachedDepth and:[cachedColormap isColormap not]) - ifTrue: [^ cachedColormap]. - newMap _ Bitmap new: colors size. - 1 to: colors size do: [:i | - newMap - at: i - put: ((colors at: i) pixelValueForDepth: destDepth)]. - - cachedDepth _ destDepth. - ^ cachedColormap _ newMap. -! ! -!ColorForm methodsFor: 'private' stamp: 'ar 5/17/2001 15:44' prior: 50349252! - ensureColorArrayExists - "Return my color palette." - - colors ifNil: [ - self depth > 8 ifTrue: [^ self error: 'ColorForms only support depths up to 8 bits']. - self colors: (Color indexedColors copyFrom: 1 to: (1 bitShift: self depth))]. -! ! -!ColorForm class methodsFor: 'as yet unclassified' stamp: 'jmv 4/10/2015 23:20' prior: 50349263! - mappingWhiteToTransparentFrom: aFormOrCursor - "Return a ColorForm copied from the given Form or Cursor with white mapped to transparent." - - | f map | - aFormOrCursor depth <= 8 ifFalse: [ - ^ self error: 'argument depth must be 8-bits per pixel or less']. - (aFormOrCursor is: #ColorForm) ifTrue: [ - f _ aFormOrCursor copy. - map _ aFormOrCursor colors. - ] ifFalse: [ - f _ ColorForm extent: aFormOrCursor extent depth: aFormOrCursor depth. - f copyBits: aFormOrCursor boundingBox - from: aFormOrCursor - at: 0@0 - clippingBox: aFormOrCursor boundingBox - rule: Form over. - map _ Color indexedColors copyFrom: 1 to: (1 bitShift: aFormOrCursor depth)]. - map _ map collect: [:c | - c = Color white ifTrue: [Color transparent] ifFalse: [c]]. - f colors: map. - ^ f -! ! -!ColorForm class methodsFor: 'instance creation' stamp: 'jmv 5/4/2016 16:31' prior: 50349291! - grayScaleAndTransparentExtent: aPoint -"Native depth" - "Answer a ColorForm for storing 8bpp gray scale. (do not include any slot for transparent)" - - | grays result | - result _ self extent: aPoint depth: (Smalltalk isLittleEndian ifTrue: [ -8 ] ifFalse: [ 8 ]). - grays _ (0 to: 255) collect: [ :brightness | Color gray: brightness asFloat / 255.0]. - grays at: 1 put: Color transparent. - result colors: grays. - ^result! ! -!Cursor methodsFor: 'converting' stamp: 'jmv 2/25/2011 19:47' prior: 50349307! - asCursorForm - | form | - form _ Form extent: self extent depth: 8. - form fillShape: self fillColor: Color black at: offset negated. - ^ form offset: offset! ! -!CursorWithMask methodsFor: 'converting' stamp: 'jmv 2/25/2011 19:47' prior: 50349315! - asCursorForm - | form | - form _ Form extent: self extent depth: 8. - form fillShape: maskForm fillColor: Color white. - form fillShape: self fillColor: Color black at: offset negated. - ^ form offset: offset! ! -!GrayForm methodsFor: 'pixel accessing' stamp: 'jmv 5/11/2016 19:57' prior: 50349325! - grayAt: aPoint - "Return the color of the pixel at aPoint." - - ^Color gray: (self pixelValueAt: aPoint) asFloat / 255.0! ! -!GrayForm methodsFor: 'color manipulation' stamp: 'jmv 5/12/2016 15:04' prior: 50349332! - colormapIfNeededForDepth: destDepth - "Return a colormap for displaying the receiver at the given depth, or nil if no colormap is needed." - - ^ Color cachedColormapFromGrayTo: destDepth! ! -!BMPReadWriter methodsFor: 'reading' stamp: 'ar 10/24/2005 20:57' prior: 50349341! - readColorMap - "Read colorCount BMP color map entries from the given binary stream. Answer an array of Colors." - | colorCount colors maxLevel b g r ccStream | - colorCount := (bfOffBits - 54) // 4. - "Note: some programs (e.g. Photoshop 4.0) apparently do not set colorCount; assume that any data between the end of the header and the start of the pixel data is the color map" - biBitCount >= 16 ifTrue:[^nil]. - colorCount = 0 ifTrue: [ "this BMP file does not have a color map" - "default monochrome color map" - biBitCount = 1 ifTrue: [^ Array with: Color white with: Color black]. - "default gray-scale color map" - maxLevel := (2 raisedTo: biBitCount) - 1. - ^ (0 to: maxLevel) collect: [:level | Color gray: (level asFloat / maxLevel)]]. - ccStream := ReadStream on: (stream next: colorCount*4). - colors := Array new: colorCount. - 1 to: colorCount do: [:i | - b := ccStream next. - g := ccStream next. - r := ccStream next. - ccStream next. "skip reserved" - colors at: i put: (Color r: r g: g b: b range: 255)]. - ^ colors -! ! -!BitBlt methodsFor: 'accessing' stamp: 'jmv 3/20/2013 00:50' prior: 50349376! - fillColor - "Return the current fill color as a Color. - Gives the wrong answer if the halftoneForm is a complex pattern of more than one word." - - halftoneForm ifNil: [^ Color black]. - ^ Color colorFromPixelValue: halftoneForm first depth: destForm depth! ! -!BitBlt class methodsFor: 'examples' stamp: 'jmv 7/27/2015 17:07' prior: 50349387! - alphaBlendDemo - "To run this demo, use... - Display restoreAfter: [BitBlt alphaBlendDemo] - Displays 10 alphas, then lets you paint. Option-Click to stop painting." - - "This code exhibits alpha blending in any display depth by performing - the blend in an off-screen buffer with 32-bit pixels, and then copying - the result back onto the screen with an appropriate color map. - tk 3/10/97" - - "This version uses a sliding buffer for painting that keeps pixels in 32 bits - as long as they are in the buffer, so as not to lose info by converting down - to display resolution and back up to 32 bits at each operation. - di 3/15/97" - - | brush buff dispToBuff buffToDisplay mapDto32 map32toD prevP p brushToBuff theta buffRect buffSize buffToBuff brushRect delta newBuffRect updateRect | - - "compute color maps if needed" - Display depth <= 8 ifTrue: [ - mapDto32 _ Color cachedColormapFrom: Display depth to: 32. - map32toD _ Color cachedColormapFrom: 32 to: Display depth]. - - "display 10 different alphas, across top of screen" - buff _ Form extent: 500@50 depth: 32. - dispToBuff _ BitBlt toForm: buff. - dispToBuff colorMap: mapDto32. - dispToBuff copyFrom: (50@10 extent: 500@50) in: Display to: 0@0. - 1 to: 10 do: [:i | dispToBuff fill: (50*(i-1)@0 extent: 50@50) - fillColor: (Color red alpha: i/10) - rule: Form blend]. - buffToDisplay _ BitBlt toForm: Display. - buffToDisplay colorMap: map32toD. - buffToDisplay copyFrom: buff boundingBox in: buff to: 50@10. - DisplayScreen screenUpdateRequired: nil. - - "Create a brush with radially varying alpha" - brush _ Form extent: 30@30 depth: 32. - 1 to: 5 do: - [:i | brush fillShape: (Form dotOfSize: brush width*(6-i)//5) - fillColor: (Color red alpha: 0.02 * i - 0.01) - at: brush extent // 2]. - - "Now paint with the brush using alpha blending." - buffSize _ 100. - buff _ Form extent: brush extent + buffSize depth: 32. "Travelling 32-bit buffer" - dispToBuff _ BitBlt toForm: buff. "This is from Display to buff" - dispToBuff colorMap: mapDto32. - brushToBuff _ BitBlt toForm: buff. "This is from brush to buff" - brushToBuff sourceForm: brush; sourceOrigin: 0@0. - brushToBuff combinationRule: Form blend. - buffToBuff _ BitBlt toForm: buff. "This is for slewing the buffer" - - [Sensor isMouseButton2Pressed] whileFalse: - [prevP _ nil. - buffRect _ Sensor mousePoint - (buffSize // 2) extent: buff extent. - dispToBuff copyFrom: buffRect in: Display to: 0@0. - [Sensor isMouseButton1Pressed] whileTrue: - ["Here is the painting loop" - p _ Sensor mousePoint - (brush extent // 2). - (prevP == nil or: [prevP ~= p]) ifTrue: - [prevP == nil ifTrue: [prevP _ p]. - (p dist: prevP) > buffSize ifTrue: - ["Stroke too long to fit in buffer -- clip to buffer, - and next time through will do more of it" - theta _ (p-prevP) theta. - p _ ((theta cos@theta sin) * buffSize asFloat + prevP) truncated]. - brushRect _ p extent: brush extent. - (buffRect containsRect: brushRect) ifFalse: - ["Brush is out of buffer region. Scroll the buffer, - and fill vacated regions from the display" - delta _ brushRect amountToTranslateWithin: buffRect. - buffToBuff copyFrom: buff boundingBox in: buff to: delta. - newBuffRect _ buffRect translatedBy: delta negated. - newBuffRect - areasOutside: buffRect - do: [ :r | dispToBuff copyFrom: r in: Display to: r origin - newBuffRect origin ]. - buffRect _ newBuffRect]. - - "Interpolate from prevP to p..." - brushToBuff drawFrom: prevP - buffRect origin - to: p - buffRect origin - withFirstPoint: false. - - "Update (only) the altered pixels of the destination" - updateRect _ (p min: prevP) corner: (p max: prevP) + brush extent. - buffToDisplay copy: updateRect from: updateRect origin - buffRect origin in: buff. - DisplayScreen screenUpdateRequired: updateRect. - prevP _ p]]]! ! -!WarpBlt methodsFor: 'setup' stamp: 'mtf 8/14/2009 18:21' prior: 50349510! - cellSize: s - "Set the number of samples used for averaging" - cellSize := s. - cellSize = 1 ifTrue: [^ self]. - "Install the colorMap to used for mapping the averaged RGBA 32bit pixels to the - destination depth. Note that we need to install the 32->32 color map explicitly because - the VM will substitute a colorMap derived from sourceForm->destForm mapping which - is just plain wrong for <32 source and 32bit dest depth" - (destForm depth = 32 and: [sourceForm notNil] and: [sourceForm depth < 32]) - ifTrue:[colorMap := ColorMap shifts: #(0 0 0 0) masks:#(16rFF0000 16rFF00 16rFF 16rFF000000) colors: nil] - ifFalse:[colorMap := Color colorMapIfNeededFrom: 32 to: destForm depth]. -! ! -!GrafPort methodsFor: 'text' stamp: 'jmv 6/1/2015 13:28' prior: 50349534! - displayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font color: foregroundColor - "If required, do a second pass with new rule and colorMap. - Answer last affected pixel position - Answer nil if nothing was done - " - - | answer prevRule secondPassMap sourceDepth destDepth | - - "Slight optimization when there's nothing to do." - clipHeight = 0 ifTrue: [^nil]. - clipWidth = 0 ifTrue: [^nil]. - - self installStrikeFont: font foregroundColor: (foregroundColor alpha: 1). - - "If combinationRule is rgbMul, we might need the special two-pass technique for component alpha blending. - If not, do it simply" - combinationRule = 37 "rgbMul" ifFalse: [ - ^self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font ]. - - "We need to do a second pass. The colormap set is for use in the second pass." - secondPassMap _ colorMap. - sourceDepth _ sourceForm depth. - destDepth _ destForm depth. - colorMap _ sourceDepth ~= destDepth - ifTrue: [ Color cachedColormapFrom: sourceDepth to: destDepth ]. - answer := self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font. - colorMap := secondPassMap. - secondPassMap ifNotNil: [ - prevRule := combinationRule. - combinationRule := 20. "rgbAdd" - self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font. - combinationRule := prevRule ]. - ^answer! ! -!GrafPort methodsFor: 'private' stamp: 'jmv 5/12/2016 14:52' prior: 50349581! - cachedFontColormapFrom1BitTo: destDepth - - | map dstIndex | - CachedFontColorMaps - ifNil: [CachedFontColorMaps _ Array new: 6]. - - dstIndex _ destDepth highBit. - (CachedFontColorMaps at: dstIndex) ifNotNil: [ :m | ^ m ]. - - map _ (Color cachedColormapFrom: 1 to: destDepth) copy. - CachedFontColorMaps at: dstIndex put: map. - ^ map! ! -!GrafPort methodsFor: 'private' stamp: 'jmv 5/12/2016 14:55' prior: 50349594! - colorConvertingMap: targetColor from: sourceDepth to: destDepth keepSubPixelAA: keepSubPix - "Note: The color converting map for sourceDepth=16 and for sourceDepth=32 are the same" - - | srcIndex dstIndex map mapsForSource mapsForSourceAndDest | - ColorConvertingMaps - ifNil: [ColorConvertingMaps _ (1 to: 6) collect: [:i | Array new: 6]]. - - srcIndex _ sourceDepth highBit. - sourceDepth > 8 ifTrue: [ srcIndex _ keepSubPix ifTrue: [5] ifFalse: [6] ]. - dstIndex _ destDepth highBit. - - mapsForSource _ ColorConvertingMaps at: srcIndex. - (mapsForSourceAndDest _ mapsForSource at: dstIndex) ifNil: [ - mapsForSourceAndDest _ mapsForSource at: dstIndex put: Dictionary new ]. - - map _ mapsForSourceAndDest at: targetColor ifAbsentPut: [ - Color - computeColorConvertingMap: targetColor - from: sourceDepth - to: destDepth - keepSubPixelAA: keepSubPix ]. - - ^ map! ! -!GrafPort methodsFor: 'private' stamp: 'jmv 4/17/2014 16:57' prior: 50349624! - setRuleAndMapFor: sourceDepth foregroundColor: foregroundColor - - | targetColor destDepth | - destDepth _ destForm depth. - halftoneForm _ nil. "Don't use fillColor. Use a more powerful ColorMap" - - sourceDepth = 1 ifTrue: [ - self combinationRule: Form paint. - "Set up color map for a different source depth (color font)" - "Uses caching for reasonable efficiency" - colorMap _ self cachedFontColormapFrom1BitTo: destDepth. - colorMap at: 1 put: (destForm pixelValueFor: Color transparent). - colorMap at: 2 put: (destForm pixelValueFor: foregroundColor) ] - - ifFalse: [ - "Enable subpixel rendering if requested, but never for translucent text: - This technique always draws opaque text. This could be added, by using an extra colormap for the rgbMul phase... - So far, no need arised for doing so." - (sourceDepth > 8 and: [ - Preferences subPixelRenderFonts and: [ foregroundColor = Color black or: [ - Preferences subPixelRenderColorFonts and: [ foregroundColor isOpaque ]]]]) ifTrue: [ - destDepth > 8 ifTrue: [ - "rgbMul is equivalent to component alpha blend if text is black (only faster, hehe)" - self combinationRule: 37. "rgbMul" - colorMap _ (foregroundColor ~= Color black or: [ - destDepth = 32 and: [ destForm ~~ Display or: [Preferences properDisplayAlphaForFonts] ]]) ifTrue: [ - "rgbMul / rgbAdd IS component alpha blend for any color of text (neat trick, eh!!)" - "This colorMap is to be used on the second pass with rule 20 (rgbAdd) - See #displayString:from:to:at:strikeFont:color:" - "Note: In 32bpp, if we want the correct alpha in the result, we need the second pass, as the destination could have transparent pixels, - and we need to add to the alpha channel" - self colorConvertingMap: foregroundColor from: sourceDepth to: destDepth keepSubPixelAA: true]] - ifFalse: [ - self combinationRule: 25. "Paint" - targetColor _ foregroundColor = Color black ifFalse: [ foregroundColor ]. - colorMap _ self colorConvertingMap: targetColor from: sourceDepth to: destDepth keepSubPixelAA: true]] - ifFalse: [ - "Do not use rule 34 for 16bpp display. TTCFont uses it, but it builds a glyphs cache for each color used!!" - self combinationRule: (destDepth = 32 ifTrue: [34 "alphaBlendScaled"] ifFalse: [25 "Paint"]). - colorMap _ self colorConvertingMap: foregroundColor from: sourceDepth to: destDepth keepSubPixelAA: false]]! ! -!Rectangle methodsFor: 'transforming' stamp: 'jmv 9/24/2013 22:36' prior: 50350837! - newRectFrom: newRectBlock - "Track the outline of a new rectangle until mouse button changes. - newFrameBlock produces each new rectangle from the previous" - | rect newRect buttonStart buttonNow aHand delay | - delay _ Delay forMilliseconds: 10. - buttonStart _ buttonNow _ Sensor isAnyButtonPressed. - rect _ self. - Display border: rect width: 2 rule: Form reverse fillColor: Color gray. - [buttonNow == buttonStart] whileTrue: - [delay wait. - buttonNow _ Sensor isAnyButtonPressed. - newRect _ newRectBlock value: rect. - newRect = rect ifFalse: - [Display border: rect width: 2 rule: Form reverse fillColor: Color gray. - Display border: newRect width: 2 rule: Form reverse fillColor: Color gray. - rect _ newRect]]. - Display border: rect width: 2 rule: Form reverse fillColor: Color gray. - " pay the price for reading the sensor directly ; get this party started " - aHand _ self runningWorld activeHand. - aHand - newMouseFocus: nil; - flushEvents. - Sensor processSensorEvent: Sensor createMouseEvent discardingMouseEvents: false. - ^ rect! ! -!StrikeFont methodsFor: 'emphasis' stamp: 'jmv 4/10/2015 23:21' prior: 50350873! - makeBoldGlyphs - "Make a bold set of glyphs with same widths by ORing 1 bit to the right - (requires at least 1 pixel of intercharacter space)" - | g bonkForm | - g _ glyphs copy. - bonkForm _ (Form extent: 1@16) fillBlack offset: -1@0. - self bonk: g with: bonkForm. - glyphs depth = 1 ifTrue: [ - g copyBits: g boundingBox from: g at: (1@0) - clippingBox: g boundingBox rule: Form under ] - ifFalse: [ - 0 to: g width - 2 do: [ :x | 0 to: g height-1 do: [ :y | - (glyphs colorAt: x@y) = Color white ifFalse: [ - g colorAt: x+1@y put: - ((glyphs colorAt: x+1@y) = Color white - ifTrue: [glyphs colorAt: x@y] - ifFalse: [Color black])]]]]. - glyphs _ g. - self isSynthetic: true! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 9/2/2016 11:03:22' prior: 50350898! - makeControlCharsVisible - | glyph | - self characterToGlyphMap. - glyph _ self glyphAt: (Character space). - glyph border: glyph boundingBox width: 1 fillColor: Color blue. - self glyphAt: (Character numericValue: 134) put: glyph. - - "Keep tab(9), lf(10), cr(13) and space(32) transparent or whatever the user chose" - #(0 1 2 3 4 5 6 7 8 11 12 14 15 16 17 18 19 20 21 22 23 24 25 26 27) - do: [ :ascii | - characterToGlyphMap at: ascii + 1 put: 134 ]! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 9/2/2016 11:03:27' prior: 50350915! - makeCrVisible - | glyph | - self characterToGlyphMap. - glyph _ self glyphAt: (Character numericValue: 182). - glyph border: glyph boundingBox width: 1 fillColor: Color blue. -" glyph _ glyph reverse." - self glyphAt: (Character numericValue: 133) put: glyph. - characterToGlyphMap at: 14 put: 133! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 9/2/2016 11:03:31' prior: 50350927! - makeLfVisible - | glyph | - self characterToGlyphMap. - glyph _ self glyphAt: (Character numericValue: 163). - glyph border: glyph boundingBox width: 1 fillColor: Color blue. -" glyph _ glyph reverse." - self glyphAt: (Character numericValue: 132) put: glyph. - characterToGlyphMap at: 11 put: 132! ! -!Morph methodsFor: 'accessing' stamp: 'jmv 8/21/2012 20:40' prior: 50350939! - color - - ^ Color blue! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 4/14/2015 08:53' prior: 50350943! - drawOn: aCanvas - "A canvas is already set with a proper transformation from our coordinates to those of the Canvas target." - aCanvas - fillRectangle: self morphLocalBounds - color: Color blue! ! -!RectangleLikeMorph methodsFor: 'initialization' stamp: 'jmv 8/21/2012 18:46' prior: 50350953! - defaultColor - ^ Color orange! ! -!BorderedRectMorph methodsFor: 'initialization' stamp: 'jmv 8/17/2014 21:28' prior: 50350957! - defaultBorderColor - "answer the default border color/fill style for the receiver" - ^ Color gray! ! -!PasteUpMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:35' prior: 50350963! - defaultBorderColor - "answer the default border color/fill style for the receiver" - ^ Color - r: 0.861 - g: 1.0 - b: 0.722! ! -!PasteUpMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:29' prior: 50350970! - defaultColor - "answer the default color/fill style for the receiver" - ^ Color - r: 0.8 - g: 1.0 - b: 0.6! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 11/10/2013 19:32' prior: 50350977! - findWindow: evt - "Present a menu names of windows and naked morphs, and activate the one that gets chosen. Collapsed windows appear below line, expand if chosen; naked morphs appear below second line; if any of them has been given an explicit name, that is what's shown, else the class-name of the morph shows; if a naked morph is chosen, bring it to front and have it don a halo." - | menu expanded collapsed nakedMorphs | - menu _ MenuMorph new. - expanded _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed not ]. - collapsed _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed ]. - nakedMorphs _ self submorphsSatisfying: [ :m | - (m is: #SystemWindow) not ]. - expanded isEmpty & (collapsed isEmpty & nakedMorphs isEmpty) ifTrue: [ ^ Smalltalk beep ]. - (expanded asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #activateAndForceLabelToShow. - w canDiscardEdits ifFalse: [ menu lastItem color: Color red ]]. - expanded isEmpty | (collapsed isEmpty & nakedMorphs isEmpty) ifFalse: [ menu addLine ]. - (collapsed asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #expand. - w canDiscardEdits ifFalse: [ menu lastItem color: Color red ]]. - nakedMorphs isEmpty ifFalse: [ menu addLine ]. - (nakedMorphs asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #comeToFrontAndAddHalo ]. - menu addTitle: 'find window'. - menu popUpInWorld: self! ! -!EllipseMorph methodsFor: 'visual properties' stamp: 'ar 6/25/1999 11:14' prior: 50351031! - defaultColor - "Return the default fill style for the receiver" - ^Color yellow! ! -!PluggableMorph methodsFor: 'initialization' stamp: 'jmv 8/6/2014 09:15' prior: 50351037! - defaultColor - "answer the default color/fill style for the receiver" - ^ Color lightGray! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 9/9/2012 23:50' prior: 50351043! - drawRoundGradientLookOn: aCanvas - | r colorForButton rect bottomFactor topFactor | - - self isPressed - ifFalse: [ - topFactor _ Theme current buttonGradientTopFactor. - bottomFactor _ Theme current buttonGradientBottomFactor. - self mouseIsOver - ifTrue: [ - colorForButton _ Color h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ - colorForButton _ color ]] - ifTrue: [ - topFactor _ Theme current buttonGradientBottomFactor. - bottomFactor _ Theme current buttonGradientTopFactor. - colorForButton _ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - Theme current useButtonGradient - ifTrue: [ - rect _ (0@0 extent: extent) insetBy: 1@3. - aCanvas - roundRect: rect - color: colorForButton - radius: r - gradientTop: topFactor - gradientBottom: bottomFactor - gradientHeight: Theme current buttonGradientHeight ] - ifFalse: [ - rect _ (0@0 extent: extent) insetBy: 1@3. - aCanvas roundRect: rect color: colorForButton radius: r ] - ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawEmbossedLabelOn: aCanvas ] - ifFalse: [ self drawRegularLabelOn: aCanvas ]! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 4/12/2012 22:37' prior: 50351084! - iconColor - - ^ self isPressed - ifTrue: [ Color gray: 0.75 ] - ifFalse: [ - self mouseIsOver - ifTrue: [ Color gray: 0.75 ] - ifFalse: [ Color white ]].! ! -!PluggableButtonMorph class methodsFor: 'example' stamp: 'jmv 1/4/2013 13:31' prior: 50351093! - example - " - PluggableButtonMorph example openInWorld - " - - | s1 s2 s3 b1 b2 b3 row | - s1 _ Switch new. - s2 _ Switch new turnOn. - s3 _ Switch new. - s2 onAction: [s3 turnOff]. - s3 onAction: [s2 turnOff]. - b1 _ (PluggableButtonMorph model: s1 stateGetter: #isOn action: #switch) label: 'S1'. - b2 _ (PluggableButtonMorph model: s2 stateGetter: #isOn action: #turnOn) label: 'S2'. - b3 _ (PluggableButtonMorph model: s3 stateGetter: #isOn action: #turnOn) label: 'S3'. - b1 color: Color lightRed. - b2 color: Color lightRed. - b3 color: Color lightRed. - row _ LayoutMorph newRow - addMorphs: (Array with: b1 with: b2 with: b3); - morphExtent: 120@35. - ^ row -! ! -!TextModelMorph methodsFor: 'drawing' stamp: 'cbr 10/10/2012 23:04' prior: 50351117! - drawOn: aCanvas - "Include a thin red inset border for unaccepted edits, or, if the unaccepted edits are known to conflict with a change made somewhere else to the same method (typically), put a thick red frame" - - - | bw bc | - - self flag: #todo. "Integrate this method with the Theme system. --cbr" - - - super drawOn: aCanvas. - bw _ Preferences focusIndicatorWidth. - bc _ nil. - self wantsFrameAdornments ifTrue: [ - model refusesToAccept - ifTrue: [ "Put up feedback showing that code cannot be submitted in this state" - bc _ Color tan] - ifFalse: [ - self textMorph hasEditingConflicts - ifTrue: [ - bw _ 3. - bc _ Color red ] - ifFalse: [ - self textMorph hasUnacceptedEdits - ifTrue: [ - bc _ Color red]]]]. - - (drawKeyboardFocusIndicator and: [ self textMorph hasKeyboardFocus ]) ifTrue: [ - bc ifNil: [ - bc _ Theme current focusIndicator ]] - ifFalse: [ - bc ifNotNil: [ - bc _ bc alphaMixed: 0.4 with: Color white ]]. - bc ifNotNil: [ - aCanvas frameRectangle: self focusIndicatorRectangle borderWidth: bw color: bc ]! ! -!SystemWindow methodsFor: 'initialization' stamp: 'cbr 11/7/2010 18:58' prior: 50351154! - defaultColor - "answer the default color/fill style for the receiver" - ^ Color white! ! -!SystemWindow methodsFor: 'menu' stamp: 'jmv 6/7/2013 23:23' prior: 50351160! - setWindowColor: incomingColor - | existingColor aColor | - incomingColor ifNil: [^ self]. "it happens" - aColor _ incomingColor asNontranslucentColor. - aColor = Color black ifTrue: [^ self]. - existingColor _ self widgetsColor. - existingColor ifNil: [^ Smalltalk beep]. - self widgetsColor: aColor. - self redrawNeeded! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'KenD 8/27/2015 14:39' prior: 50351173! - buildMorphicWindow - " - CodePackageListWindow open: CodePackageList new - " - | dirtyFlags names fileNames upperRow description summary backColor labelBackground textHeigth | - backColor := self textBackgroundColor. - labelBackground := Theme current background. - textHeigth := AbstractFont default height. - - dirtyFlags := PluggableListMorph - model: model - listGetter: #packageDirtyFlags - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - dirtyFlags color: backColor. - dirtyFlags := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorph: (StringMorph new contents: ' Unsaved?') fixedHeight: textHeigth; - addMorphUseAll: dirtyFlags. - - names := PluggableListMorph - model: model - listGetter: #packageNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - names color: backColor. - names := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorph: (StringMorph new contents: ' Package Name') fixedHeight: textHeigth; - addMorphUseAll: names. - - fileNames := PluggableListMorph - model: model - listGetter: #packageFullNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - fileNames color: backColor. - fileNames := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorph: (StringMorph new contents: ' File Name') fixedHeight: textHeigth; - addMorphUseAll: fileNames. - - upperRow := LayoutMorph newRow. - upperRow - addMorph: dirtyFlags proportionalWidth: 0.13; - addAdjusterAndMorph: names proportionalWidth: 0.27; - addAdjusterAndMorph: fileNames proportionalWidth: 0.6. - - description := TextModelMorph - textProvider: model - textGetter: #description - textSetter: #description:. - - summary := TextModelMorph - textProvider: model - textGetter: #summary. - - self layoutMorph - addMorph: upperRow proportionalHeight: 0.5; - addAdjusterAndMorph: self buildButtonPane proportionalHeight: 0.1; - addAdjusterAndMorph: summary proportionalHeight: 0.18; - addAdjusterAndMorph: description proportionalHeight: 0.22; - addAdjusterAndMorph: self buildRequirementsPane proportionalHeight: 0.2. - self setLabel: 'Installed Packages'! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'len 5/27/2016 21:51' prior: 50351249! - buildRequirementsPane - - | requirements deleteReqButton "editReqButton" reqLayout buttonLayout | - requirements := PluggableListMorph - model: (PackageRequirementsList fromCodePackageList: model) - listGetter: #requirementsStrings - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - requirements color: Theme current textPane. - - deleteReqButton := PluggableButtonMorph - model: requirements model - action: #deleteSelectedRequirement - label: 'delete'. - deleteReqButton color: self widgetsColor. - - buttonLayout := LayoutMorph newColumn. - buttonLayout addMorph: deleteReqButton - layoutSpec: (LayoutSpec - proportionalWidth: 1.0 - proportionalHeight: 1.0 - minorDirectionPadding: #top); - color: self widgetsColor quiteWhiter. - - model when: #changed: send: #updateRequirementsFromPackageList to: requirements model. - self when: #changed: send: #updateRequirementsFromPackageList to: requirements model. - requirements model when: #changed: send: #verifyContents to: requirements. - self when: #changed: send: #verifyContents to: requirements. - - reqLayout := LayoutMorph newRow. - ^ reqLayout - doAdoptWidgetsColor; - addMorph: requirements - layoutSpec: (LayoutSpec - proportionalWidth: 0.9 - proportionalHeight: 1.0 - minorDirectionPadding: #left); - addMorph: buttonLayout - layoutSpec: (LayoutSpec - proportionalWidth: 0.1 - proportionalHeight: 1.0 - minorDirectionPadding: #right); - color: Color transparent; - yourself - ! ! -!CodeWindow methodsFor: 'updating' stamp: 'jmv 9/2/2013 10:25' prior: 50351300! - decorateForInheritance - "Check to see if the currently-viewed method has a super send or an override, and if so, change screen feedback, unless the #decorateBrowserButtons says not to." - - | cm aColor aButton flags buttonColor | - (aButton _ self inheritanceButton) ifNil: [^ self]. - buttonColor _ self buttonColor. - - Preferences decorateBrowserButtons - ifFalse: [ ^aButton color: buttonColor ]. - cm _ model currentCompiledMethod. - (cm is: #CompiledMethod) - ifFalse: [ ^aButton color: buttonColor ]. - - flags _ 0. - model isThisAnOverride ifTrue: [ flags _ flags bitOr: 4 ]. - cm sendsToSuper ifTrue: [ flags _ flags bitOr: 2 ]. - model isThereAnOverride ifTrue: [ flags _ flags bitOr: 1 ]. - aColor _ { - - "This is NOTan override. There is no super implementation." - buttonColor. "no sends to super. there is not override in any subclass" - Color tan. "no sends to super. there is an override in some subclass" - Color red. "sends to super. there is no override in any subclass. Error: no super to call (or calls super with a different message)" - Color red. "sends to super. there is an override in some subclass. Error: no super to call (or calls super with a different message)" - - "This is an override. There is some super implementation" - Color red muchLighter. "doesn't have sub; has super but doesn't call it" - Color r: 0.94 g: 0.823 b: 0.673. "has sub; has super but doesn't call it" - Color green muchLighter. "doesn't have sub; has super and callsl it" - Color blue muchLighter. "has sub; has super and callsl it" - - } at: flags + 1. - aButton color: aColor! ! -!ChangeSorterWindow methodsFor: 'GUI building' stamp: 'DM 8/22/2015 12:34' prior: 50351354! - buildMorphicWindow - "Add a set of change sorter views to the given top view offset by the given amount. To create a single change sorter, call this once with an offset of 0@0. To create a dual change sorter, call it twice with offsets of 0@0 and 0.5@0." - - | dirtyFlags changeSetList classList messageList upperPanes backColor labelBackground | - backColor _ self textBackgroundColor. - labelBackground _ Theme current background. - model myChangeSet ifNil: [ - self flag: #ojo. "Or whatever was last changed, or is top of list, or whatever" - model myChangeSet: ChangeSet changeSetForBaseSystem ]. - - dirtyFlags _ PluggableListMorph - model: model - listGetter: #changeSetDirtyFlags - indexGetter: nil - indexSetter: nil. - dirtyFlags color: backColor. - dirtyFlags _ LayoutMorph newColumn - color: Theme current background; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: ' Unsaved?'); - addMorphUseAll: dirtyFlags. - - changeSetList _ (PluggableListMorphByItem - model: model - listGetter: #changeSetList - indexGetter: #currentCngSet - indexSetter: #showChangeSetNamed: - mainView: self - menuGetter: #changeSetMenu - keystrokeAction: #changeSetListKey:from:) - autoDeselect: false. - changeSetList color: backColor. - changeSetList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: 'Change Set name'); - addMorphUseAll: changeSetList. - - classList _ PluggableListMorphByItem - model: model - listGetter: #classList - indexGetter: #currentClassName - indexSetter: #currentClassName: - mainView: self - menuGetter: #classListMenu - keystrokeAction: #classListKey:from:. - classList color: backColor. - classList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: 'Classes'); - addMorphUseAll: classList. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: dirtyFlags proportionalWidth: 0.13; - addAdjusterAndMorph: changeSetList proportionalWidth: 0.47; - addAdjusterAndMorph: classList proportionalWidth: 0.4. - - messageList _ PluggableListMorphByItem - model: model - listGetter: #messageList - indexGetter: #currentSelector - indexSetter: #currentSelector: - mainView: self - menuGetter: #messageMenu - keystrokeAction: #messageListKey:from:. - messageList color: backColor. - messageList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: 'Methods'); - addMorphUseAll: messageList. - - self layoutMorph - addMorph: upperPanes proportionalHeight: 0.25; - addAdjusterAndMorph: messageList proportionalHeight: 0.2; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.55. - - self setLabel: model labelString! ! -!PreDebugWindow methodsFor: 'GUI building' stamp: 'HAW 1/12/2017 18:47:35' prior: 50351452! - buttonRowForPreDebugWindow: aDebugger - | row aButton triads buttons | - buttons _ OrderedCollection new. - triads _ OrderedCollection withAll: self preDebugButtonSpec. - aDebugger shouldBeAbleToCreateMethod ifTrue: [ triads add: { 'Create'. #createMethod. 'create the missing method' }]. - - triads do: [ :triad | - aButton _ PluggableButtonMorph new model: self. - aButton label: triad first. - aButton action: triad second. - aButton setBalloonText: triad third. - buttons add: aButton]. - - row _ LayoutMorph newRow. - row doAdoptWidgetsColor. - row color: Color transparent. - row separation: 1. - row addMorphs: buttons. - ^row! ! -!TestRunnerWindow methodsFor: 'constants' stamp: 'jmv 4/16/2011 13:57' prior: 50351475! - runButtonColor - ^ Color green lighter duller! ! -!ProgressBarMorph methodsFor: 'initialization' stamp: 'jmv 12/2/2011 10:52' prior: 50351480! - defaultColor - ^Color white! ! -!ProgressBarMorph methodsFor: 'initialization' stamp: 'jmv 12/2/2011 10:53' prior: 50351484! - initialize - super initialize. - progressColor _ Color gray. - value _ 0.0! ! -!MenuMorph methodsFor: 'construction' stamp: 'len 11/16/2015 02:52' prior: 50351490! -addStayUpIcons - | closeBox pinBox w | - Preferences optionalButtons ifFalse: [ ^self ]. - (self valueOfProperty: #hasStayUpIcons ifAbsent: [ false ]) - ifTrue: [ - self removeProperty: #needsStayUpIcons. - ^self ]. - titleMorph ifNil: [ - "Title not yet there. Flag ourself, so this method is called again when adding title." - self setProperty: #needsStayUpIcons toValue: true. - ^ self]. - closeBox _ PluggableButtonMorph model: self action: #delete. - closeBox icon: Theme current closeIcon; color: Color transparent. - pinBox _ PluggableButtonMorph model: self action: #stayUp. - pinBox icon: Theme current pushPinIcon; color: Color transparent. - w _ (titleMorph hasSubmorphs ifTrue: [ titleMorph firstSubmorph morphWidth ] ifFalse: [ 0 ]) + 60. - self addMorphFront: - (LayoutMorph newRow - "Make room for buttons" - morphExtent: w @ (titleMorph morphHeight max: 19); - color: Color transparent; - addMorph: closeBox fixedWidth: 20; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedWidth: 4; - addMorph: titleMorph proportionalWidth: 1; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedWidth: 4; - addMorph: pinBox fixedWidth: 20). - - self setProperty: #hasStayUpIcons toValue: true. - self removeProperty: #needsStayUpIcons! ! -!MenuMorph methodsFor: 'keyboard control' stamp: 'jmv 6/8/2014 20:32' prior: 50351533! - displayFiltered: evt - | matchStr allItems isMatch matches feedbackMorph | - matchStr _ self valueOfProperty: #matchString. - allItems _ self submorphs select: [ :m | - m is: #MenuItemMorph ]. - matches _ allItems select: [ :m | - isMatch _ matchStr isEmpty or: [ - m contents - includesSubstring: matchStr - caseSensitive: false ]. - m isEnabled: isMatch. - isMatch ]. - feedbackMorph _ self valueOfProperty: #feedbackMorph. - feedbackMorph ifNil: [ - feedbackMorph _ StringMorph new color: Color veryDarkGray. - self addMorphBack: feedbackMorph lock position: (0@ -20). - self - setProperty: #feedbackMorph - toValue: feedbackMorph ]. - feedbackMorph contents: '<' , matchStr , '>'. - matchStr isEmpty ifTrue: [ - feedbackMorph delete. - self removeProperty: #feedbackMorph ]. - matches notEmpty ifTrue: [ - self selectItem: matches first ]! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'jmv 4/14/2016 15:10' prior: 50351563! - drawOn: aCanvas - | rectangle w y0 h y1 y2 scrollbarThickness | - aCanvas frameAndFillRectangle: (0@0 extent: extent) fillColor: self color borderWidth: borderWidth borderColor: borderColor. - y0 _ 1. - w _ extent x-2. - scrollbarThickness _ ScrollBar scrollbarThickness. - completer entryCount > self class itemsPerPage ifTrue: [ - w _ w - scrollbarThickness. - aCanvas - frameRectangle: (extent x - scrollbarThickness@0 - extent: scrollbarThickness @ extent y) - borderWidth: 1 - color: borderColor. - aCanvas - image: (BitBltCanvas arrowOfDirection: #up size: scrollbarThickness) - at: self upButtonPosition. - aCanvas - image: (BitBltCanvas arrowOfDirection: #down size: scrollbarThickness) - at: self downButtonPosition. - h _ extent y - (2 * scrollbarThickness). - y1 _ (1.0 * self firstVisible-1 / completer entryCount * h) ceiling + y0 + scrollbarThickness-1. - y2 _ (1.0 * self lastVisible / completer entryCount * h) floor + y0 + scrollbarThickness -1. - aCanvas - fillRectangle: (extent x - scrollbarThickness+2@y1 corner: extent x-2 @ y2) - color: Color veryLightGray ]. - self firstVisible - to: self lastVisible - do: [ :index | - rectangle _ 1@y0 extent: w@self class itemHeight. - index = self selected - ifTrue: [ - aCanvas fillRectangle: rectangle color: (Theme current listHighlightFocused: true) ]. - aCanvas - drawString: (completer entries at: index) asString - at: rectangle topLeft - font: self class listFont - color: Theme current text. - y0 _ y0 + self itemHeight ]! ! -!AutoCompleterMorph methodsFor: 'initialization' stamp: 'jmv 12/2/2011 10:09' prior: 50351614! - defaultBorderColor - ^ Color gray! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 9/9/2012 23:59' prior: 50351618! - drawOn: aCanvas - "Draw the hand itself (i.e., the cursor)." - "This method is only called when we are carrying morphs around..." - aCanvas - stencil: Cursor move - at: 0@0 - color: Color black! ! -!ImageMorph methodsFor: 'accessing' stamp: 'jmv 3/14/2011 09:15' prior: 50351627! - color: aColor - super color: aColor. - (image depth = 1 and: [aColor is: #Color]) ifTrue: [ - image colors: {Color transparent. aColor}. - self redrawNeeded]! ! -!MenuItemMorph methodsFor: 'accessing' stamp: 'jmv 3/13/2009 10:04' prior: 50351636! - isEnabled: aBoolean - - isEnabled = aBoolean ifTrue: [^ self]. - isEnabled _ aBoolean. - self color: (aBoolean ifTrue: [Color black] ifFalse: [Color gray]). -! ! -!MenuItemMorph methodsFor: 'private' stamp: 'jmv 9/9/2012 23:55' prior: 50351644! - offImage - "Return the form to be used for indicating an '' marker" - | form | - form _ Form extent: (self fontToUse ascent-2) asPoint depth: 16. - form getCanvas - frameAndFillRectangle: form boundingBox fillColor: (Color gray: 0.9) - borderWidth: 1 borderColor: Color black. - ^form! ! -!MenuItemMorph methodsFor: 'private' stamp: 'jmv 9/9/2012 23:55' prior: 50351656! - onImage - "Return the form to be used for indicating an '' marker" - | form | - form _ Form extent: (self fontToUse ascent-2) asPoint depth: 16. - form getCanvas - frameAndFillRectangle: form boundingBox fillColor: (Color gray: 0.8) - borderWidth: 1 borderColor: Color black; - fillRectangle: (form boundingBox insetBy: 2) color: Color black. - ^form! ! -!LayoutMorph methodsFor: 'accessing' stamp: 'jmv 12/1/2015 09:53' prior: 50351670! - adoptWidgetsColor: paneColor - super adoptWidgetsColor: paneColor. - doAdoptWidgetsColor - ifTrue: [ self color: (Theme current buttonColorFrom: paneColor) ] - ifFalse: [ self color: Color transparent ]! ! -!LayoutMorph methodsFor: 'initialization' stamp: 'jmv 8/17/2014 21:38' prior: 50351680! - defaultColor - ^Color gray! ! -!LayoutMorph class methodsFor: 'instance creation' stamp: 'jmv 4/3/2011 22:59' prior: 50351684! - initializedInstance - "Answer a row by default so the 'new morph' menu doesn't fail..." - ^self newRow color: (Color red alpha: 0.2)! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/5/2015 10:57' prior: 50351691! - example1 -" - self example1 -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example1. -pane color: Color red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addMorph: (BorderedRectMorph new color: (Color blue); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addMorph: (BorderedRectMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 20). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #G) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8); - addMorph: (BorderedRectMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (BorderedRectMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -pane morphPosition: 150@130 extent: 400@300. -pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/12/2015 16:42' prior: 50351758! - example10 -" - self example10 openInWorld -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example10. -pane color: Color red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Color blue); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 20). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #G) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8); - addMorph: (BorderedRectMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (BorderedRectMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -^ pane! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/5/2015 10:55' prior: 50351826! - example11 -" - self example11 -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example11. -pane color: Color red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Color blue); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 20). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #G) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8); - addMorph: (BorderedRectMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (BorderedRectMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -pane morphPosition: 150@130 extent: 400@300. -pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/5/2015 11:08' prior: 50351896! - example13 - " - self example13 - " - | pane row innerRow | -pane _ (LayoutMorph newColumn separation: 5) name: #example13. - pane color: Color red. - row _ (LayoutMorph newRow separation: 5) name: #Row. - innerRow _ (LayoutMorph newRow separation: 5) name: #InnerRow; - color: Color red. - innerRow - addMorph: (BorderedRectMorph new name: #Box1) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (BorderedRectMorph new name: #Box2) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (BorderedRectMorph new name: #Bar) - layoutSpec: (LayoutSpec proportionalWidth: 1.0 fixedHeight: 10). - row - color: (Color h: 270 s: 0.2 v: 0.6); - addMorph: innerRow - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 30 minorDirectionPadding: #center); - addMorph: LayoutAdjustingMorph new layoutSpec: (LayoutSpec fixedWidth: 5); - addMorph: (BorderedRectMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #Rect1) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40 minorDirectionPadding: #top); - addMorph: LayoutAdjustingMorph new layoutSpec: (LayoutSpec fixedWidth: 5); - addMorph: (BorderedRectMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #Rect2) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). - pane addMorph: row layoutSpec: (LayoutSpec proportionalHeight: 0.9). - pane morphPosition: 250@130 extent: 400@300. - pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 2/16/2016 13:27' prior: 50351944! - example1b -" -Based on #example1, but using some Morph instead of RectangleLikeMorph -> extent is not adjustable - self example1b -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example1. -pane color: Color red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addMorph: (Morph new name: #B); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addMorph: (BorderedRectMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 20). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (Morph new name: #G); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Color red; - addMorph: (Morph new name: #J); - addMorph: (BorderedRectMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (BorderedRectMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -pane morphPosition: 150@130 extent: 400@300. -pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/5/2015 11:25' prior: 50352005! - example2 - " - self example2 - " - | pane row | - pane _ (LayoutMorph newColumn separation: 5) name: #example2. - pane color: Color red. - row _ (LayoutMorph newRow separation: 5) name: #Row. - row - color: (Color h: 270 s: 0.2 v: 0.6); - addMorph: (BorderedRectMorph new color: (Color h: 120 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8 minorDirectionPadding: #bottom); - addMorph: (BorderedRectMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8 fixedHeight: 40 minorDirectionPadding: #top); - addMorph: (BorderedRectMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 0.7 minorDirectionPadding: #center). - pane addMorph: row layoutSpec: (LayoutSpec proportionalHeight: 0.9). - pane morphPosition: 200@180 extent: 400@300. - pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 11/18/2015 09:45' prior: 50352037! - example20 -" - self example20 -" -| column | - -column _ (LayoutMorph newColumn separation: 5) name: #Column. -column - color: Color red; - addMorph: (BorderedRectMorph new color: (Color h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec proportionalWidth: 0.8 fixedHeight: 20); - addMorph: (BorderedRectMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec fixedWidth: 40 proportionalHeight: 0.5); - addMorph: (BorderedRectMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec proportionalWidth: 1.0 fixedHeight: 30). -column morphPosition: 150@130 extent: 400@300. -column openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/5/2015 11:13' prior: 50352060! - example3 - " - self example3 - " - | pane row innerRow | -pane _ (LayoutMorph newColumn separation: 5) name: #example3. - pane color: Color red. - row _ (LayoutMorph newRow separation: 5) name: #Row. - innerRow _ (LayoutMorph newRow separation: 5) name: #InnerRow; - color: Color red. - innerRow - addMorph: (BorderedRectMorph new name: #Box1) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (BorderedRectMorph new name: #Box2) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (BorderedRectMorph new name: #Bar) - layoutSpec: (LayoutSpec proportionalWidth: 1.0 fixedHeight: 10). - row - color: (Color h: 270 s: 0.2 v: 0.6); - addMorph: innerRow - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 30 minorDirectionPadding: #center); - addMorph: (BorderedRectMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #Rect1) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40 minorDirectionPadding: #top); - addMorph: (BorderedRectMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #Rect2) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). - pane addMorph: row layoutSpec: (LayoutSpec proportionalHeight: 0.9). - pane morphPosition: 250@130 extent: 400@300. - pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 6/8/2014 20:03' prior: 50352103! - example6 - " - Useful example contributed by Ken Dickey - All these should look the same, right? (mmmh this should be a test...) - self example6 - " -| pane rect1 rect2 | -pane _ LayoutMorph newRow separation: 5. "1" -pane addMorph: (StringMorph contents: '1'). - -rect1 := BorderedRectMorph new color: (Color lightOrange); - morphExtent: 20 @ 30. -pane addMorphFront: rect1. -rect2 := BorderedRectMorph new color: (Color cyan); - morphExtent: 20 @ 30. -pane addMorphFront: rect2. -pane - color: Color lightGreen; - morphPosition: 120 @ 50 extent: 180 @ 100; - openInWorld. - -pane _ LayoutMorph newRow separation: 5. "2" -pane addMorph: (StringMorph contents: '2'). - -rect1 := BorderedRectMorph new color: (Color lightOrange); - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 minorDirectionPadding: #center). -pane addMorph: rect1. -rect2 := BorderedRectMorph new color: (Color cyan). -pane addMorph: rect2 - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 minorDirectionPadding: #center). -pane - color: Color lightGreen; - morphPosition: 320 @ 50 extent: 180 @ 100; - openInWorld. - - -pane _ LayoutMorph newRow separation: 5. "3" -pane addMorph: (StringMorph contents: '3'). - -rect1 := BorderedRectMorph new color: (Color lightOrange). -pane addMorph: rect1 - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 minorDirectionPadding: #center). -rect2 := BorderedRectMorph new color: (Color cyan); - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 minorDirectionPadding: #center). -pane addMorph: rect2. -pane - color: Color lightGreen; - morphPosition: 520 @ 50 extent: 180 @ 100; - openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 1/4/2013 13:42' prior: 50352156! - launcherExample - " - self launcherExample - " - | b1 b2 b3 row b4 random buttons | - random _ Random new. - b1 _ PluggableButtonMorph model: [ Date today print ] action: #value label: 'Date'. - b2 _ PluggableButtonMorph model: [ Time now print ] action: #value label: 'Time'. - b3 _ PluggableButtonMorph model: [ SystemVersion current print ] action: #value label: 'Version'. - b4 _ PluggableButtonMorph model: [ random next print ] action: #value label: 'Random'. - buttons _ {b1. b2. b3. b4}. - buttons do: [ :button | - button color: Color lightRed ]. - row _ LayoutMorph newRow - color: Color red; - addMorphs: buttons; - morphExtent: 300 @ 40. - ^ row openInWorld! ! -!ProgressMorph methodsFor: 'initialization' stamp: 'jmv 12/2/2011 10:55' prior: 50352180! - defaultColor - ^Color veryLightGray! ! -!HaloHandleMorph class methodsFor: 'accessing' stamp: 'jmv 11/18/2010 09:44' prior: 50352185! - circleForm: extent - " - CircleForm _ nil - " - | r d l bw center | - (CircleForm isNil or: [ CircleForm extent ~= extent ]) ifTrue: [ - center _ extent -1 * 0.5. - r _ center r * 0.75. - bw _ 1.3. - CircleForm _ Form extent: extent depth: 32. - 0 to: extent y - 1 do: [ :y | - 0 to: extent x - 1 do: [ :x | - d _ (x@y - center) r. - l _ (r - d max: 0.0) min: bw. - CircleForm - colorAt: x @ y - put: (Color white alpha: (l / bw)) - ]]. - ]. - ^CircleForm! ! -!HaloMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:28' prior: 50352203! - defaultColor - "answer the default color/fill style for the receiver" - ^ Color - r: 0.6 - g: 0.8 - b: 1.0! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 5/27/2015 13:42' prior: 50352209! - addHandle: handleSpec - "Add a handle within the halo box as per the haloSpec, and set it up to respond to the given event by sending the given selector to the given recipient. Return the handle." - - | handle aPoint colorToUse form icon | - aPoint _ self - positionIn: haloBox - horizontalPlacement: handleSpec horizontalPlacement - verticalPlacement: handleSpec verticalPlacement. - colorToUse _ Color colorFrom: handleSpec color. - handle _ HaloHandleMorph new color: colorToUse. - self addMorph: handle. - handle morphBoundsInWorld: (Rectangle center: aPoint extent: self class handleSize asPoint). - handleSpec iconSymbol ifNotNil: [ :iconName | - form _ self class icons at: iconName ifAbsent: [self class perform: iconName]. - form ifNotNil: [ - icon _ ImageMorph new - image: form; - color: colorToUse makeForegroundColor; - lock. - handle addMorphFront: icon position: 0@0 ]]. - handle mouseUpSelector: #endInteraction. - handle setBalloonText: handleSpec hoverHelp. - ^handle! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/4/2016 22:14' prior: 50352243! - addNameString: aString - "Add a name display centered beneath the bottom of the outer rectangle. Return the handle." - - | nameMorph namePosition nameBackground | - nameBackground _ RectangleLikeMorph new - color: ((target is: #SystemWindow) ifTrue: [target windowColor] ifFalse: [Color lightBlue alpha: 0.9]). - nameMorph _ StringMorph contents: aString. - nameMorph color: Color black. - nameBackground morphExtent: nameMorph morphExtent + 4. - namePosition _ haloBox width - nameMorph morphWidth // 2 @ (haloBox height). - self addMorph: nameBackground position: namePosition - 2. - self addMorph: nameMorph position: namePosition. - ^nameMorph! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 9/22/2012 15:18' prior: 50352266! - doRot: evt with: rotHandle - "Update the rotation of my target if it is rotatable. Keep the relevant command object up to date." - - | degrees | -self revisar. - self flag: #jmvVer2. - evt hand obtainHalo: self. - degrees _ (evt eventPosition - target referencePosition) degrees. - degrees _ degrees - angleOffset degrees. - degrees _ degrees detentBy: 10.0 atMultiplesOf: 90.0 snap: false. - degrees = 0.0 - ifTrue: [rotHandle color: Color lightBlue] - ifFalse: [rotHandle color: Color blue]. - rotHandle submorphsDo: - [:m | m color: rotHandle color makeForegroundColor]. - self removeAllHandlesBut: rotHandle. - - target rotationDegrees: degrees. - - rotHandle morphPositionInWorld: evt eventPosition - (rotHandle morphExtent // 2)! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 9/20/2012 00:01' prior: 50352292! - setDismissColor: evt with: dismissHandle - "Called on mouseStillDown in the dismiss handle; set the color appropriately." - - | colorToUse | - evt hand obtainHalo: self. - colorToUse _ (dismissHandle morphContainsPoint: (dismissHandle internalizeFromWorld: evt eventPosition)) - ifFalse: [ Color red muchLighter ] - ifTrue: [ Color lightGray ]. - dismissHandle color: colorToUse! ! -!InnerListMorph methodsFor: 'initialization' stamp: 'jmv 5/27/2013 09:39' prior: 50352307! - initialize - super initialize. - self color: Color black. - font _ Preferences standardListFont. - listItems _ #(). - selectedRow _ nil. - selectedRows _ Set new. - highlightedRow _ nil! ! -!InnerTextMorph methodsFor: 'drawing' stamp: 'jmv 10/16/2013 19:55' prior: 50352316! - debugDrawLineRectsOn: aCanvas - "Shows where text line rectangles are" - - self textComposition lines do: [ :line | - aCanvas - frameRectangle: line rectangle - borderWidth: 1 - color: Color brown ] -! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/17/2015 15:51' prior: 50352326! - initialize - super initialize. - extent _ 400@300. - color _ Color white. - grid _ 8@6. - gridLineWidth _ 2. - gridColor _ Color black. - selectionColor _ Color red! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 23:18' prior: 50352335! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - from _ self toGridPoint: localEventPosition. - outlineMorph _ BorderedRectMorph new - borderColor: Color black; - color: Color transparent; - openInWorld; - hide. - self selectTo: localEventPosition! ! -!HoverHelpMorph methodsFor: 'initialization' stamp: 'jmv 9/25/2011 23:12' prior: 50352347! - defaultColor - - ^Color r: 1.0 g: 1.0 b: 0.7! ! -!HoverHelpMorph methodsFor: 'drawing' stamp: 'jmv 12/20/2014 15:09' prior: 50352352! - drawOn: aCanvas - - | r | - r _ self morphLocalBounds. - aCanvas roundRect: r color: self color radius: 4. - aCanvas - textComposition: textComposition - bounds: (r insetBy: 4) - color: Color black - selectionColor: (Theme current textHighlightFocused: false)! ! -!WorldState methodsFor: 'drawing' stamp: 'jmv 3/2/2017 19:40:12' prior: 50352363! - drawInvalidAreasSubmorphs: submorphs - "Redraw the damaged areas of the given canvas and clear the damage list. Return a collection of the areas that were redrawn." - - | initialRectsToRepair currentRectsToRepair newRectsToRepair morphsToDraw rectsForEachMorph thisMorphRects reuse i n morph morphBounds morphClipRect | - - "The simple implementation is slowers as it draws morph areas that will later be covered by other morphs. - But it works, and it is easier to understand. - See en.wikipedia.org/wiki/Painter's_algorithm" - true not ifTrue: [ ^self simpleDrawInvalidAreasSubmorphs: submorphs ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - initialRectsToRepair _ damageRecorder invalidRectsFullBounds: world viewBox. - damageRecorder reset. - currentRectsToRepair _ OrderedCollection new. - newRectsToRepair _ OrderedCollection withAll: initialRectsToRepair. - morphsToDraw _ OrderedCollection new. - rectsForEachMorph _ OrderedCollection new. - thisMorphRects _ OrderedCollection new. - n _ submorphs size. - i _ 1. - - "The idea here is to iterate morphs front to back, i.e. first the ones on top. - For each morph, record the rectangles it affects. And if a morph is opaque, remove the area behind it from the list of rectangles to be repaired. - This means, for example, that morphs completely covered might even not be redrawn. - this is a huge performance gain when there are many morphs on screen, especially if there are more than ten open windows, and Theme uses opaque colors. - See 'A reverse painter's algorithm' at en.wikipedia.org/wiki/Painter's_algorithm" - [ i <= n and: [ newRectsToRepair notEmpty ]] whileTrue: [ - morph _ submorphs at: i. - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - reuse _ currentRectsToRepair. - currentRectsToRepair _ newRectsToRepair. - newRectsToRepair _ reuse removeAll. - currentRectsToRepair do: [ :r | - (morphBounds intersects: r) - ifTrue: [ - morphClipRect _ morphBounds intersect: r. - thisMorphRects add: morphClipRect. "We could perhaps try and join adjacent rectangles in this collection..." - morph addPossiblyUncoveredAreasIn: r to: newRectsToRepair ] - ifFalse: [ - newRectsToRepair add: r ]]. - thisMorphRects ifNotEmpty: [ - morphsToDraw add: morph. - rectsForEachMorph add: thisMorphRects. - thisMorphRects _ OrderedCollection new. - ]]. - i _ i + 1 ]. - - "*make this true to flash damaged areas for testing*" - Preferences debugShowDamage ifTrue: [ world fillRects: initialRectsToRepair color: Color gray ]. - - "Draw world background on those areas that were not completely covered by opaque morphs" - i > n ifTrue: [ - newRectsToRepair do: [ :r | - world drawOn: (canvas newClipRect: r) ]]. - - "Now, draw the recorded areas of selected morphs, back to front." - morphsToDraw with: rectsForEachMorph reverseDo: [ :m :xrects | - "Here we could think about merging all xrects into just one call... - This would mean drawing each morph just once. - But that would mean drawing pixels we were not told to. There could be other morphs in that area that are not even being drawn!! - See WorldState class >> #experiment1" -" rr _ nil." - xrects do: [ :r | -" rr _ rr ifNil: [ r ] ifNotNil: [ r quickMerge: rr ]." - (canvas newClipRect: r) fullDraw: m. - ]. -" (canvas newClipRect: rr) fullDraw: m" - "*make this true to flash damaged areas for testing*" - Preferences debugShowDamage2 ifTrue: [ - world flashRects: xrects color: Color random ]. - ]. - - "Answer a list of rectangles to be updated on the Display. - This usually is not performance critical, drawing morphs is slower than just exposing the Display." - "What should we force on Display? Whatever was asked? Each small rect that was updated? A single bigger rect? - Right now, answer whatever was asked... Maybe this could be changed if that enhances performance... - (think of vnc over slow networks)" - ^ initialRectsToRepair! ! -!WorldState class methodsFor: 'sample code' stamp: 'jmv 3/2/2017 19:39:21' prior: 50352489! - experiment1 - "To play with and learn about morphic Display update logic. - Remove the morphs when done!!" - " - WorldState experiment1 - " - | dr morph1 morph2 s w | - morph1 _ RectangleLikeMorph new openInWorld. - morph2 _ RectangleLikeMorph new openInWorld. - morph2 color: Color green. - morph2 morphPosition: 200@800 extent: 50@40. - morph1 morphPosition: 120@720 extent: 220@100. - - w _ self runningWorld. - s _ w instVarNamed: 'worldState'. - dr _ s instVarNamed: 'damageRecorder'. - - dr doFullRepaint. - dr reset; - " recordInvalidRect: (100@700 corner: 400@900);" - recordInvalidRect: (100@700 corner: 150@900); - recordInvalidRect: (300@700 corner: 400@900). - Display fillColor: Color gray. - "Do not draw the area used by the small rectangle, unless it is also drawn!!" - s drawInvalidAreasSubmorphs: {morph1. morph2 }! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 12/20/2014 15:35' prior: 50352518! - drawCurrentAsError - "The morph (or one of its submorphs) had an error in its drawing method." - | r w | - r _ currentMorph morphLocalBounds. - w _ r extent > (50@50) - ifTrue: [ 6 ] - ifFalse: [ 2 ]. - self - frameAndFillRectangle: r - fillColor: Color red - borderWidth: w - borderColor: Color yellow. - self line: r topLeft to: r bottomRight-w width: w color: Color yellow. - self line: r topRight -(w@0) to: r bottomLeft -(0@w)width: w color: Color yellow! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 6/1/2015 13:30' prior: 50352536! - drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - aColor = Color black ifFalse: [ | topColor | - topColor _ aColor alphaMixed: 0.25 with: Color black. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint - font: fontOrNil - color: topColor ]. - aColor = Color white ifFalse: [ | bottomColor | - bottomColor _ aColor alphaMixed: 0.22 with: Color white. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + (0@2) - font: fontOrNil - color: bottomColor ]. - ^self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + (0@1) - font: fontOrNil - color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 11/29/2015 18:01' prior: 50352563! - fillRectangle: aRectangle color: aColor - "Fill the given rectangle." - - aColor isTransparent ifFalse: [ - self - frameAndFillRectangle: aRectangle - fillColor: aColor - borderWidth: 0 - borderColor: Color transparent ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 11/29/2015 18:14' prior: 50352574! -reverseRectangleBorder: r borderWidth: borderWidth - " - Display getCanvas - reverseRectangleBorder: (10@10 extent: 300@200) - borderWidth: 20. - Display forceToScreen - " - | rect | - rect _ currentTransformation displayBoundsOfTransformOf: r. - port - sourceForm: nil; - fillColor: Color gray; - combinationRule: Form reverse; - frameRect: rect borderWidth: borderWidth! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 4/9/2015 09:46' prior: 50352589! - setPaintColor: aColor - "Install a new color used for filling." - | paintColor | - paintColor _ aColor ifNil: [ Color transparent ]. - (paintColor is: #Color) ifFalse: [ - ^self error: 'Cannot install color' ]. - - "Okay, so paintColor really *is* a color" - port sourceForm: nil. - (paintColor isOpaque or: [ self depth < 32]) ifTrue: [ - port fillColor: paintColor. - port combinationRule: Form paint. - ^self ]. - - "BitBlt setup for alpha mapped transfer" - port fillColor: paintColor. - port combinationRule: Form blend! ! -!BitBltCanvas class methodsFor: 'cached forms' stamp: 'jmv 4/17/2015 12:16' prior: 50352609! - steButtonForm: extent - ^self cachedForms - at: { #steButton . extent } - ifAbsentPut: [ - | form canvas | - form _ Form extent: extent depth: 32. - canvas _ form getCanvas. - canvas - roundRect: (0@0 extent: extent) - color: (Color gray: 0.4) - radius: 4. - canvas - roundRect: (1@1 extent: extent-2) - color: Color white - radius: 4 - gradientTop: 1.0 - gradientCenter: 0.73 - gradientBottom: 0.94 - gradient1Height: (extent y-8+1 max: extent y//2). - form]! ! -!BitBltCanvas class methodsFor: 'cached forms' stamp: 'jmv 4/17/2015 12:16' prior: 50352628! - verticalGrayGradient: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - ^self cachedForms - at: { #vertical. height. gradientTopFactor . gradientBottomFactor } - ifAbsentPut: [ - Form - verticalGradient: height - topColor: (Color gray: gradientTopFactor) - bottomColor: (Color gray: gradientBottomFactor) ]! ! -!BitBltCanvas class methodsFor: 'cached arrow forms' stamp: 'jmv 1/7/2015 08:12' prior: 50352642! - buildArrowOfDirection: aSymbolDirection size: finalSizeInteger - "PRIVATE - create an arrow with aSymbolDirectionDirection, - finalSizeInteger and aColor - - aSymbolDirectionDirection = #up, #down. #left or #right - (self buildArrowOfDirection: #down size: 120) display - (self buildArrowOfDirection: #up size: 120) display - " - - | resizeFactor resizedForm f e c bottomMargin topMargin | - resizeFactor _ 4. - e _ finalSizeInteger@finalSizeInteger*resizeFactor. - f _ Form extent: e depth: 32. - c _ Color gray: 0.5. - topMargin _ finalSizeInteger * 3//4. - bottomMargin _ finalSizeInteger * 4//4. - 0 to: e y-1-bottomMargin do: [ :y | - 0 to: e x -1 do: [ :x | - (e x / 2 - 1 - x) abs * 2 + topMargin < y ifTrue: [ - f colorAt: x@y put: c - ] - ] - ]. - resizedForm _ f - magnify: f boundingBox - by: 1 / resizeFactor - smoothing: 4. - - aSymbolDirection == #right ifTrue: [ - resizedForm _ resizedForm rotatedByDegrees: 90 ]. - aSymbolDirection == #down ifTrue: [ - resizedForm _ resizedForm rotatedByDegrees: 180 ]. - aSymbolDirection == #left ifTrue: [ - resizedForm _ resizedForm rotatedByDegrees: 270 ]. - - aSymbolDirection == #up ifFalse: [ - resizedForm _ resizedForm - copy: (resizedForm boundingBox insetBy: (resizedForm width - finalSizeInteger/ 2.0) rounded) ]. - - ^resizedForm! ! -!BitBltCanvas class methodsFor: 'cached arrow forms' stamp: 'jmv 10/9/2014 23:02' prior: 50352686! - buildArrowWith: insideForm borderForm: borderForm - | extent translucentForm color insideSpec borderSpec border background alpha| - " - Display getCanvas - image: (BitBltCanvas buildArrowWith: BitBltCanvas downInsideForm borderForm: BitBltCanvas downBorderForm) - at: 20@20 - Display getCanvas - image: (BitBltCanvas buildArrowWith:BitBltCanvas upInsideForm borderForm: BitBltCanvas upBorderForm) - at: 40@20 - " - extent _ insideForm extent - (1@2). - translucentForm _ Form extent: insideForm extent depth: 32. - 0 to: extent x-1 do: [ :x | - 0 to: extent y-1 do: [ :y | - insideSpec _ insideForm colorAt: x@(y+1). - borderSpec _ borderForm colorAt: x@(y+1). - insideSpec = (Color r: 0.0 g: 0.0 b: 1.0) - ifTrue: [ color _ Color transparent ] - ifFalse: [ - borderSpec = (Color r: 1.0 g: 0.0 b: 0.0) - ifTrue: [ color _ insideSpec ] - ifFalse: [ - border _ x < (extent x//2) - ifTrue: [Color white] - ifFalse: [Color black]. - background _ borderForm colorAt: extent x@(y+1). - alpha _ borderSpec red asFloat - background red / (border red - background red). - color _ border alpha: (alpha min: 1 max: 0) ]]. - translucentForm colorAt: x@y put: color ]]. - ^translucentForm! ! -!Theme methodsFor: 'colors' stamp: 'jmv 11/19/2010 14:06' prior: 50352727! - background - ^ Color r: 0.7 g: 0.72 b: 0.83! ! -!Theme methodsFor: 'colors' stamp: 'jmv 11/23/2010 09:42' prior: 50352731! - buttonColorFrom: aColor - ^ Display depth <= 8 - ifTrue: [ Color transparent ] - ifFalse: [ aColor paler ]! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/14/2011 08:50' prior: 50352737! - buttonLabel - ^Color gray: 0.18! ! -!Theme methodsFor: 'colors' stamp: 'len 6/9/2016 17:38' prior: 50352741! - errorColor - ^ Color red lighter! ! -!Theme methodsFor: 'colors' stamp: 'len 6/9/2016 17:40' prior: 50352745! - failureColor - ^ Color yellow lighter! ! -!Theme methodsFor: 'colors' stamp: 'len 11/14/2015 02:34' prior: 50352749! - scrollbarButtonColor - ^Color gray: 0.95! ! -!Theme methodsFor: 'colors' stamp: 'len 11/17/2015 23:55' prior: 50352753! - scrollbarColor - ^Color white! ! -!Theme methodsFor: 'colors' stamp: 'len 11/14/2015 02:34' prior: 50352757! - scrollbarSliderShadowColor - ^Color white! ! -!Theme methodsFor: 'colors' stamp: 'len 6/9/2016 17:38' prior: 50352761! - successColor - ^ Color green lighter! ! -!Theme methodsFor: 'colors' stamp: 'cbr 11/7/2010 18:00' prior: 50352765! - text - ^ Color black! ! -!Theme methodsFor: 'colors' stamp: 'jmv 10/16/2013 22:08' prior: 50352769! - textCursor - ^ Display depth <= 2 - ifTrue: [ Color black ] - ifFalse: [ self text ]! ! -!Theme methodsFor: 'colors' stamp: 'jmv 5/30/2011 14:31' prior: 50352775! - textHighlight - "A nice light blue." - " - ^ Color r: 0.71 g: 0.835 b: 1.0 - ^ Color hue: 214 chroma: 0.29 luminance: 0.816 - " - ^Color hue: 204 chroma: 0.29 luminance: 0.77! ! -!Theme methodsFor: 'colors' stamp: 'jmv 11/23/2010 09:58' prior: 50352783! - textHighlightFocused: focused - "A nice light blue." - | textHighlight | - Display depth = 1 ifTrue: [^ Color veryLightGray]. - Display depth = 2 ifTrue: [^ Color gray: 0.87]. - textHighlight _ self textHighlight. - ^focused - ifTrue: [ textHighlight ] - ifFalse: [ self unfocusedTextHighlightFrom: textHighlight ]! ! -!Theme methodsFor: 'colors' stamp: 'cbr 12/6/2010 20:08' prior: 50352796! - windowLabel - ^Color gray: 0.3! ! -!Theme methodsFor: 'menu colors' stamp: 'jmv 5/26/2011 09:07' prior: 50352800! - menu - Display depth <= 2 ifTrue: [^ Color white]. - ^Color r: 0.75 g: 0.75 b: 0.75 alpha: 0.93! ! -!Theme methodsFor: 'menu colors' stamp: 'jmv 11/23/2010 09:45' prior: 50352806! - menuHighlight - ^ Display depth < 8 - ifTrue: [ Color veryLightGray ] - ifFalse: [ self textHighlight ]! ! -!Theme methodsFor: 'menu colors' stamp: 'cbr 11/7/2010 18:28' prior: 50352812! - menuText - ^ Color black! ! -!Theme methodsFor: 'menu colors' stamp: 'jmv 11/28/2010 08:04' prior: 50352816! - menuTitleBar - Display depth = 1 ifTrue: [^ Color white]. - Display depth = 2 ifTrue: [^ Color gray]. - ^ self menu darker! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 4/15/2011 14:59' prior: 50352823! - browser - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Color r: 0.5 g: 0.7 b: 0.4]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 2/14/2013 11:05' prior: 50352830! - debugger - ^Color h: 0.0 s: 0.6 v: 0.7! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 11/23/2010 09:16' prior: 50352834! - defaultWindowColor - ^ Color lightGray! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 11/18/2010 12:44' prior: 50352838! - fileContentsBrowser - ^Color tan duller! ! -!Theme methodsFor: 'tool colors' stamp: 'cbr 12/4/2010 18:44' prior: 50352842! - fileList - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Color r: 0.7 g: 0.55 b: 0.7 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 5/23/2012 19:23' prior: 50352849! - messageNames - - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Color r: 0.53 g: 0.77 b: 0.382 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'cbr 12/4/2010 18:45' prior: 50352856! - messageSet - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Color r: 0.45 g: 0.6 b: 0.85 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 11/18/2010 12:44' prior: 50352863! - object - ^Color white duller! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/28/2012 09:41' prior: 50352867! - packageList - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Color r: 0.63 g: 0.47 b: 0.08 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 11/23/2010 09:17' prior: 50352874! - testRunner - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ (Color r: 0.650 g: 0.753 b: 0.976) duller ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/16/2011 08:15' prior: 50352881! - textEditor - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Color gray: 0.6 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'cbr 12/4/2010 18:45' prior: 50352887! - transcript - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Color r: 0.8 g: 0.6 b: 0.3 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'cbr 12/18/2010 17:56' prior: 50352894! - versionsBrowser - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ (Color r: 0.869 g: 0.753 b: 1.0) duller ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/16/2011 08:13' prior: 50352901! - workspace - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Color h: 60.0 s: 0.73 v: 0.72 ]! ! -!Theme methodsFor: 'widget colors' stamp: 'jmv 5/23/2012 18:49' prior: 50352908! - acceptButton - - ^ self buttonColorFrom: - (self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Color r: 0.2 g: 0.6 b: 0.1 ])! ! -!Theme methodsFor: 'widget colors' stamp: 'jmv 5/23/2012 18:51' prior: 50352916! - cancelButton - - ^ self buttonColorFrom: - (self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Color r: 0.8 g: 0.2 b: 0.2 ])! ! -!Theme methodsFor: 'widget colors' stamp: 'cbr 10/10/2012 23:36' prior: 50352924! - textPane - ^Color white! ! -!SHTextStylerST80 class methodsFor: 'style table' stamp: 'pb 5/4/2016 17:44' prior: 50352928! - initialTextAttributes - | d element color emphasis attrArray | - d _ IdentityDictionary new. - self styleTable do: [ :each | - element _ each first. - color _ each at: 2 ifAbsent: nil. - color _ color ifNotNil: [ Color colorFrom: color ]. - emphasis _ each at: 3 ifAbsent: nil. - attrArray _ self attributeArrayForColor: color emphasis: emphasis. - attrArray notEmpty ifTrue: [ - d at: element put: attrArray ]]. - ^ d! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3111-ChangeReferencesBackToColor-JuanVuletich-2017Jun19-12h05m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3106] on 19 June 2017 at 11:52:30 am'! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/19/2017 12:10:13' prior: 50352952! - * aNumber - "Answer this color with its RGB multiplied by the given number. " - " - (Colour brown *2) display - " - ^ (Color new - setRed: (self red * aNumber min: 1.0 max: 0.0) - green: (self green * aNumber min: 1.0 max: 0.0) - blue: (self blue * aNumber min: 1.0 max: 0.0)) - alpha: self alpha! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - -| all | -all := Colour allInstances. -all elementsForwardIdentityTo: (all collect: [ :c | c * 1 ]). -all := TranslucentColour allInstances. -all elementsForwardIdentityTo: (all collect: [ :c | c * 1 ]).! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3112-MigrateInstancesToColor-JuanVuletich-2017Jun19-11h51m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3111] on 19 June 2017 at 12:11:51 pm'! - -Smalltalk removeClassNamed: #Colour! - -Smalltalk removeClassNamed: #Colour! - -Smalltalk removeClassNamed: #TranslucentColour! - -Smalltalk removeClassNamed: #TranslucentColour! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3113-RemoveColour-JuanVuletich-2017Jun19-12h11m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3113] on 19 June 2017 at 3:22:14 pm'! - -InnerPluggableMorph subclass: #InnerListMorph - instanceVariableNames: 'listItems font selectedRow selectedRows highlightedRow ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #InnerListMorph category: #'Morphic-Views'! -InnerPluggableMorph subclass: #InnerListMorph - instanceVariableNames: 'listItems font selectedRow selectedRows highlightedRow' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! -!InnerListMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 15:21:44' prior: 50360540! - initialize - super initialize. - self color: Color black. - font _ Preferences standardListFont. - listItems _ #(). - selectedRow _ nil. - highlightedRow _ nil! ! -!InnerListMorph methodsFor: 'list management' stamp: 'jmv 6/19/2017 15:21:40' prior: 16855089! - listChanged - "set newList to be the list of strings to display" - listItems _ Array new: self getListSize withAll: nil. - selectedRow _ nil. - self adjustExtent! ! -!InnerListMorph methodsFor: 'private' stamp: 'jmv 6/19/2017 15:21:48' prior: 16855308! - noSelection - selectedRow _ nil. - highlightedRow _ nil! ! - -InnerPluggableMorph subclass: #InnerListMorph - instanceVariableNames: 'listItems font selectedRow highlightedRow' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #InnerListMorph category: #'Morphic-Views'! -InnerPluggableMorph subclass: #InnerListMorph - instanceVariableNames: 'listItems font selectedRow highlightedRow' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3114-removeAnUnusedIvar-JuanVuletich-2017Jun19-15h21m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3113] on 19 June 2017 at 4:40:20 pm'! -!Object methodsFor: 'private' stamp: 'jmv 6/19/2017 16:14:39' prior: 16882717! - primitiveError: aString - "This method is called when the error handling results in a recursion in - calling on error: or halt or halt:." - - | context emergencyEvaluator lines r | - r _ `10@10` extent: (Display extent -20 min: `700@1000`). - lines _ r height // AbstractFont default height. - emergencyEvaluator _ Transcripter newInFrame: r. - emergencyEvaluator - nextPutAll: '***System error handling failed***'; newLine; - nextPutAll: aString; newLine; - nextPutAll: '-------------------------------'; newLine. - context _ thisContext sender sender. - (30 min: lines - 10) timesRepeat: [context ifNotNil: [emergencyEvaluator print: (context _ context sender); newLine]]. - emergencyEvaluator - nextPutAll: '-------------------------------'; newLine; - nextPutAll: 'Type ''revert'' to revert your last method change.'; newLine; - nextPutAll: 'Type ''exit'' to exit the emergency evaluator.'; newLine. - emergencyEvaluator readEvalPrint! ! -!InputSensor methodsFor: 'private' stamp: 'jmv 6/19/2017 15:53:29' prior: 16856661! - primMousePt - "Primitive. Poll the mouse to find out its position. Return a Point. Fail if - event-driven tracking is used instead of polling. Optional. See Object - documentation whatIsAPrimitive." - - - ^ `0@0`! ! -!EventSensor methodsFor: 'initialization' stamp: 'jmv 6/19/2017 15:48:40' prior: 16839804! - initialize - "Run the I/O process" - mouseButtons _ 0. - mousePosition _ `0@0`. - self setInterruptKey: (interruptKey ifNil: [$. numericValue bitOr: 16r0800 ]). "cmd-." - interruptSemaphore _ (Smalltalk specialObjectsArray at: 31) ifNil: [Semaphore new]. - self flushAllButDandDEvents. - inputSemaphore _ Semaphore new. - hasInputSemaphore _ false. - - self primSetInputSemaphore: (Smalltalk registerExternalObject: inputSemaphore). - self installInterruptWatcher. - self installEventTickler. - self flushAllButDandDEvents. - - "Attempt to discover whether the input semaphore is actually being signaled." - hasInputSemaphore _ false. - inputSemaphore initSignals! ! -!String methodsFor: 'displaying' stamp: 'jmv 6/19/2017 16:12:23' prior: 16917029! - displayOn: aDisplayMedium - "Display the receiver on the given DisplayMedium. 5/16/96 sw" - - self displayOn: aDisplayMedium at: `0 @ 0`! ! -!Bitmap methodsFor: 'as yet unclassified' stamp: 'jmv 6/19/2017 15:45:57' prior: 16787594! - asByteArray - "Faster way to make a byte array from me. - copyFromByteArray:, if receiver is BigEndian makes equal Bitmap. - Assume receiver bytes-in-word mapping is BigEndian: - Most significant bye of first word in self goes to first position in result. - This means that for a BigEndian 8bpp Form, pixels are in the right order in the ByteArray - - Form lena asGrayForm bits asByteArray copyFrom: 1 to: 4. - (Form lena asGrayForm asFormOfDepth: 8) bits asByteArray copyFrom: 1 to: 4. - (0 to: 3) collect: [ :x | ((Form lena asGrayForm colorAt: x@0) luminance * 255) rounded ]. - " - | f bytes hack | - f _ Form extent: 4@self size depth: 8 bits: self. - bytes _ ByteArray new: self size * 4. - hack _ Form new hackBits: bytes. - Smalltalk isLittleEndian ifTrue: [hack swapEndianness]. - hack copyBits: f boundingBox - from: f - at: `0@0` - clippingBox: hack boundingBox - rule: Form over. - - "f displayOn: hack." - ^ bytes! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 6/19/2017 16:12:37' prior: 50335414! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag -"WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " -| activeProc | -activeProc _ Processor activeProcess. -[ - | isARealStartup world reopenTranscript | - self logSapshot: save andQuit: quit. - - reopenTranscript _ false. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | each isInWorld ifTrue: [ each delete. reopenTranscript _ true ]]. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - - - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - - "Cosas que levanto explicitamente abajo" - world _ ProjectX ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "world _ clearAllStateFlag ifFalse: [ ProjectX ui ]." - ProjectX stopUIProcess. - activeProc isTerminated ifFalse: [ - activeProc terminate ]. - - "Clean Globals" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: nil. - Smalltalk closeSourceFiles. Smalltalk at: #SourceFiles put: nil. - Smalltalk allClassesDo: [ :cls | cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ Smalltalk printStuffToCleanOnImageSave ]. - - - "Do image save & quit as apropriate" - Cursor write activateCursor. - save - ifTrue: [ - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - - - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: (DisplayScreen extent: `1024@768` depth: 32). - Smalltalk at: #SourceFiles put: (Array new: 2). - Smalltalk openSourceFiles. - - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - - - ProjectX spawnNewMorphicProcessFor: (world ifNil: [ PasteUpMorph newWorld ]). - - reopenTranscript ifTrue: [ - WorldState addDeferredUIMessage: [ - TranscriptWindow openTranscript ]]. - " - WorldState addDeferredUIMessage: [ - world fullRepaintNeeded ]. - " - - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - WorldState addDeferredUIMessage: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]. - -] forkAt: Processor timingPriority-1 named: 'Startup process'.! ! -!Transcripter methodsFor: 'accessing' stamp: 'jmv 6/19/2017 16:13:36' prior: 50357762! - 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]. - textComposition - setModel: (TextModel withText: c asText); - extentForComposing: frame width-8 @9999. - textComposition composeAll. - d _ textComposition usedHeight - frame height. - d > 0 ifTrue: [ - "Scroll up to keep all contents visible" - cb _ textComposition characterBlockAtPoint: - `0@0` + (0@(d+AbstractFont default height)). - self on: (c copyFrom: cb stringIndex to: c size). - readLimit _ position _ collection size. - ^ self endEntry]. - Display fill: (frame insetBy: -2) fillColor: self black; - fill: frame fillColor: self white. - Display getCanvas - textComposition: textComposition - bounds: (`4@4` + frame topLeft extent: Display extent) - color: Color black - selectionColor: Color blue. - DisplayScreen screenUpdateRequired: nil! ! -!Transcripter class methodsFor: 'utilities' stamp: 'jmv 6/19/2017 15:58:42' prior: 16938949! - emergencyEvaluator - (Transcripter newInFrame: `0@0 corner: 320@200`) - show: 'Type ''exit'' to exit the emergency evaluator.'; - readEvalPrint! ! -!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'jmv 6/19/2017 16:15:27' prior: 50342776! - defaultAction - - | delta textFrame barFrame outerFrame result range width filledWidth f h textWidth textForm innerBarFrame oldFilledWidth oldFilledWidth2 prevContents | - f _ AbstractFont default. - h _ f height * 3//2. - textWidth _ (f widthOfString: progressTitle) + h. - width _ 150 max: textWidth. - - textForm _ Form extent: width@h depth: 32. - textForm fillBlack. - textForm fillWhite: (textForm boundingBox insetBy: 2). - progressTitle displayOn: textForm at: (width-textWidth+h//2@4). - barFrame _ Rectangle center: aPoint extent: width@h. - textFrame _ `0@0` extent: width@h. - textFrame _ textFrame - aligned: textFrame bottomCenter - with: barFrame topCenter + `0@2`. - outerFrame _ barFrame merge: textFrame. - delta _ outerFrame amountToTranslateWithin: Display boundingBox. - barFrame _ barFrame translatedBy: delta. - textFrame _ textFrame translatedBy: delta. - outerFrame _ outerFrame translatedBy: delta. - prevContents _ Form fromDisplay: outerFrame. - range _ maxVal = minVal ifTrue: [1] ifFalse: [maxVal - minVal]. "Avoid div by 0" - innerBarFrame _ barFrame insetBy: 2. - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - oldFilledWidth _ 0. - oldFilledWidth2 _ 0. - result _ workBlock value: "Supply the bar-update block for evaluation in the work block" - [ :barVal | - barVal - ifNotNil: [ currentVal _ barVal ] - ifNil: [ - currentVal _ currentVal + 1. - currentVal >= maxVal - ifTrue: [ currentVal _ minVal ]]. - filledWidth _ ((barFrame width-4) asFloat * ((currentVal-minVal) asFloat / range min: 1.0)) asInteger. - filledWidth > oldFilledWidth ifTrue: [ - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - Display fillGray: (barFrame topLeft + `2@2` extent: filledWidth@17). - filledWidth -200 > oldFilledWidth2 - ifFalse: [ - "Usually just request an update, to be done asynchronously." - DisplayScreen screenUpdateRequired: outerFrame ] - ifTrue: [ - "Once in a while, force a real screen update (warning: really slow on MacOS if done too often)" - Display forceToScreen: outerFrame. oldFilledWidth2 _ filledWidth ]. - oldFilledWidth _ filledWidth ]]. - prevContents displayAt: outerFrame topLeft. - self resume: result! ! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 6/19/2017 16:10:37' prior: 16898287! - staggerOffset - ^`6 @ 20`! ! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 6/19/2017 16:10:46' prior: 16898320! - standardWindowExtent - "Answer the standard default extent for new windows. " - - | effectiveExtent width strips height grid allowedArea maxLevel | - effectiveExtent _ self maximumUsableArea extent - - (self scrollBarSetback @ self screenTopSetback). - Preferences reverseWindowStagger ifTrue: - ["NOTE: following copied from strictlyStaggeredInitialFrameFor:" - allowedArea _ self maximumUsableArea insetBy: ( - self scrollBarSetback @ self screenTopSetback extent: `0@0` - ). - "Number to be staggered at each corner (less on small screens)" - maxLevel _ allowedArea area > 700000 ifTrue: [3] ifFalse: [2]. - "Amount by which to stagger (less on small screens)" - grid _ allowedArea area > 700000 ifTrue: [40] ifFalse: [20]. - ^ (allowedArea extent - (grid*(maxLevel+1*2) + (grid//2))) min: `52@40` * Preferences standardCodeFont height ]. - width _ (strips _ self windowColumnsDesired) > 1 - ifTrue: - [effectiveExtent x // strips] - ifFalse: - [(3 * effectiveExtent x) // 4]. - height _ (strips _ self windowRowsDesired) > 1 - ifTrue: - [effectiveExtent y // strips] - ifFalse: - [(3 * effectiveExtent y) //4]. - ^ width @ height - -"RealEstateAgent standardWindowExtent"! ! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 6/19/2017 16:10:58' prior: 16898360! - strictlyStaggeredInitialFrameFor: aStandardSystemView initialExtent: initialExtent world: aWorld - "This method implements a staggered window placement policy that I (di) like. - Basically it provides for up to 4 windows, staggered from each of the 4 corners. - The windows are staggered so that there will always be a corner visible." - - | allowedArea grid initialFrame otherFrames cornerSel corner delta putativeCorner free maxLevel | - allowedArea := (self maximumUsableAreaInWorld: aWorld) - insetBy: (self scrollBarSetback @ self screenTopSetback extent: `0 @ 0`). - "Number to be staggered at each corner (less on small screens)" - maxLevel := allowedArea area > 300000 ifTrue: [3] ifFalse: [2]. - "Amount by which to stagger (less on small screens)" - grid := allowedArea area > 500000 ifTrue: [40] ifFalse: [20]. - initialFrame := `0 @ 0` extent: initialExtent. - "min: (allowedArea extent - (grid*(maxLevel+1*2) + (grid//2)))) - min: 600@400" - otherFrames := (SystemWindow windowsIn: aWorld satisfying: [ :w | w visible and: [w isCollapsed not]]) - collect: [:w | w morphBoundsInWorld]. - otherFrames _ otherFrames reject: [ :f | f isNil ]. - 0 to: maxLevel do: [ :level | - 1 to: 4 do: [:ci | - cornerSel := #(#topLeft #topRight #bottomRight #bottomLeft) at: ci. - corner := allowedArea perform: cornerSel. - "The extra grid//2 in delta helps to keep title tabs distinct" - delta := ((maxLevel - level) * grid + (grid // 2)) @ (level * grid). - 1 to: ci - 1 do: [ :i | delta _ delta y negated @ delta x ]. "slow way" - putativeCorner := corner + delta. - free := true. - otherFrames do: [ :w | - free := free & ((w perform: cornerSel) ~= putativeCorner)]. - free - ifTrue: [ - ^(initialFrame aligned: (initialFrame perform: cornerSel) - with: putativeCorner) translatedAndSquishedToBeWithin: allowedArea]]]. - "If all else fails..." - ^(self scrollBarSetback @ self screenTopSetback - extent: initialFrame extent) translatedAndSquishedToBeWithin: allowedArea! ! -!Form methodsFor: 'accessing' stamp: 'jmv 6/19/2017 15:50:37' prior: 16846782! - offset - ^offset ifNil:[`0@0`]! ! -!Form methodsFor: 'analyzing' stamp: 'jmv 6/19/2017 15:51:14' prior: 16846919! - primCountBits - "Count the non-zero pixels of this form." - self depth > 8 ifTrue: - [^(self asFormOfDepth: 8) primCountBits]. - ^ (BitBlt toForm: self) - fillColor: (Bitmap with: 0); - destRect: (`0@0` extent: width@height); - combinationRule: 32; - copyBits! ! -!Form methodsFor: 'analyzing' stamp: 'jmv 6/19/2017 15:51:36' prior: 16846929! - tallyPixelValuesInRect: destRect into: valueTable - "Tally the selected pixels of this Form into valueTable, a Bitmap of depth 2^depth similar to a color map. Answer valueTable." - - (BitBlt toForm: self) - sourceForm: self; "src must be given for color map ops" - sourceOrigin: `0@0`; - colorMap: valueTable; - combinationRule: 33; - destRect: destRect; - copyBits. - ^ valueTable - -" -Move a little rectangle around the screen and print its tallies... - | r tallies nonZero | -Cursor blank showWhile: [ -[Sensor isAnyButtonPressed] whileFalse: - [r _ Sensor mousePoint extent: 10@10. - Display border: (r expandBy: 2) width: 2 rule: Form reverse fillColor: nil. - tallies _ (Display copy: r) tallyPixelValues. - nonZero _ (1 to: tallies size) select: [:i | (tallies at: i) > 0] - thenCollect: [:i | (tallies at: i) -> (i-1)]. - Display fill: (0@0 extent: Display width@20) fillColor: Color white. - nonZero printString , ' ' displayAt: 0@0. - Display border: (r expandBy: 2) width: 2 rule: Form reverse fillColor: nil]] -"! ! -!Form methodsFor: 'analyzing' stamp: 'jmv 6/19/2017 15:51:54' prior: 16846963! - xTallyPixelValue: pv orNot: not - "Return an array of the number of pixels with value pv by x-value. - Note that if not is true, then this will tally those different from pv." - | cm slice countBlt copyBlt | - cm _ self newColorMap. "Map all colors but pv to zero" - not ifTrue: [cm atAllPut: 1]. "... or all but pv to one" - cm at: pv+1 put: 1 - (cm at: pv+1). - slice _ Form extent: 1@height. - copyBlt _ (BitBlt destForm: slice sourceForm: self - combinationRule: Form over - destOrigin: `0@0` sourceOrigin: `0@0` extent: 1 @ slice height - clipRect: slice boundingBox) - colorMap: cm. - countBlt _ (BitBlt toForm: slice) - fillColor: (Bitmap with: 0); - destRect: (`0@0` extent: slice extent); - combinationRule: 32. - ^ (0 to: width-1) collect: - [:x | - copyBlt sourceOrigin: x@0; copyBits. - countBlt copyBits]! ! -!Form methodsFor: 'analyzing' stamp: 'jmv 6/19/2017 15:52:04' prior: 16846991! - yTallyPixelValue: pv orNot: not - "Return an array of the number of pixels with value pv by y-value. - Note that if not is true, then this will tally those different from pv." - | cm slice copyBlt countBlt | - cm _ self newColorMap. "Map all colors but pv to zero" - not ifTrue: [cm atAllPut: 1]. "... or all but pv to one" - cm at: pv+1 put: 1 - (cm at: pv+1). - slice _ Form extent: width@1. - copyBlt _ (BitBlt destForm: slice sourceForm: self - combinationRule: Form over - destOrigin: `0@0` sourceOrigin: `0@0` extent: slice width @ 1 - clipRect: slice boundingBox) - colorMap: cm. - countBlt _ (BitBlt toForm: slice) - fillColor: (Bitmap with: 0); - destRect: (`0@0` extent: slice extent); - combinationRule: 32. - ^ (0 to: height-1) collect: - [:y | - copyBlt sourceOrigin: 0@y; copyBits. - countBlt copyBits]! ! -!Form methodsFor: 'coloring' stamp: 'jmv 6/19/2017 15:50:16' prior: 16847123! - fillShape: aShapeForm fillColor: aColor - "Fill a region corresponding to 1 bits in aShapeForm with aColor" - - ^ self fillShape: aShapeForm fillColor: aColor at: `0@0`! ! -!Form methodsFor: 'coloring' stamp: 'jmv 6/19/2017 15:50:23' prior: 16847131! - fillShape: aShapeForm fillColor: aColor at: location - "Fill a region corresponding to 1 bits in aShapeForm with aColor" - - ((BitBlt destForm: self sourceForm: aShapeForm fillColor: aColor - combinationRule: Form paint - destOrigin: location + aShapeForm offset sourceOrigin: `0@0` - extent: self extent clipRect: self boundingBox) - colorMap: (Bitmap with: 0 with: 16rFFFFFFFF)) - copyBits! ! -!Form methodsFor: 'color mapping' stamp: 'jmv 6/19/2017 15:50:33' prior: 50358112! - mapColor: oldColor to: newColor - "Make all pixels of the given color in this Form to the given new color." - "Warnings: This method modifies the receiver. It may lose some color accuracy on 32-bit Forms, since the transformation uses a color map with only 15-bit resolution." - - | map | - map _ (Color cachedColormapFrom: self depth to: self depth) copy. - map at: (oldColor indexInMap: map) put: (newColor pixelWordForDepth: self depth). - (BitBlt toForm: self) - sourceForm: self; - sourceOrigin: `0@0`; - combinationRule: Form over; - destX: 0 destY: 0 width: width height: height; - colorMap: map; - copyBits. -! ! -!Form methodsFor: 'converting' stamp: 'jmv 6/19/2017 15:49:08' prior: 16847321! - asFormOfDepth: d - | newForm source | - d = depth ifTrue: [ ^self ]. - source _ (self depth = 32 and: [ d abs < 32 ]) - ifTrue: [ self copy convertAlphaToZeroValueTransparency ] - ifFalse: [ self ]. - newForm _ Form extent: source extent depth: d. - (BitBlt toForm: newForm) - colorMap: (source colormapIfNeededFor: newForm); - copy: source boundingBox - from: `0@0` in: source - fillColor: nil rule: Form over. - "If we build a 32bpp from one of smaller depth, - it will have zero in the alpha channel (until BitBlt is fixed!!)" - (newForm depth = 32 and: [self depth < 32]) ifTrue: [ - newForm fixAlpha ]. - ^newForm! ! -!Form methodsFor: 'converting' stamp: 'jmv 6/19/2017 15:49:12' prior: 16847342! - asGrayForm - | answer map | - - "For lower bit depths, the 15 bit ColorMap loses no information, - and answers the real #luminance of each pixel." - self depth < 32 ifTrue: [ - answer _ GrayForm extent: width@height. - map _ self colormapIfNeededForGray8bpp. - (BitBlt toForm: answer) - colorMap: map; - copy: self boundingBox - from: `0@0` in: self - fillColor: nil rule: Form over. - answer offset: self offset. - ^ answer ]. - - "For 32bpp, the approach below would use just 5bits per component. - Generally it is best to extract a component in full 8bpp and keep full dynamic range. - Green usually is a good choice." - ^ self asGrayForm: 3! ! -!Form methodsFor: 'converting' stamp: 'jmv 6/19/2017 15:49:19' prior: 16847364! - asGrayForm: componentIndex -"Native depth" - "Assume the receiver is a grayscale image. Return a GrayForm computed by extracting the brightness levels of one color component. This technique allows a 32-bit Form to be converted to an 8-bit GrayForm to save space while retaining a full 255 levels of gray. (The usual colormapping technique quantizes to 8, 16, or 32 levels, which loses information.) - - If component = 1, take the alpha component - If component = 2, take the red component - If component = 3, take the green component - If component = 4, take the blue component - " - | f32 result map mask shift | - self depth = 32 ifFalse: [ - f32 _ Form extent: width@height depth: 32. - self displayOn: f32. - ^ f32 asGrayForm: componentIndex ]. - - result _ GrayForm extent: width@height. - shift _ #(-24 -16 -8 0) at: componentIndex. - mask _ #(16rFF000000 16rFF0000 16rFF00 16rFF) at: componentIndex. - map _ ColorMap masks: { mask. 0. 0. 0 } shifts: { shift. 0. 0. 0 }. - (BitBlt toForm: result) - sourceForm: self; - combinationRule: Form over; - colorMap: map; - sourceRect: (`0@0` extent: width@height); - destOrigin: `0@0`; - copyBits. - ^ result! ! -!Form methodsFor: 'converting' stamp: 'jmv 6/19/2017 15:49:38' prior: 16847425! - asGrayScaleAndTransparent: componentIndex -"Native depth" - "Assume the receiver is a grayscale image. Return a grayscale ColorForm computed by extracting the brightness levels of one color component. This technique allows a 32-bit Form to be converted to an 8-bit ColorForm to save space while retaining a full 255 levels of gray. (The usual colormapping technique quantizes to 8, 16, or 32 levels, which loses information.) - - If component = 1, take the alpha component - If component = 2, take the red component - If component = 3, take the green component - If component = 4, take the blue component - " - | f32 result map mask shift | - self depth = 32 ifFalse: [ - f32 _ Form extent: width@height depth: 32. - self displayOn: f32. - ^ f32 asGrayScaleAndTransparent: componentIndex ]. - - result _ ColorForm grayScaleAndTransparentExtent: width@height. - shift _ #(-24 -16 -8 0) at: componentIndex. - mask _ #(16rFF000000 16rFF0000 16rFF00 16rFF) at: componentIndex. - map _ ColorMap masks: { mask. 0. 0. 0 } shifts: { shift. 0. 0. 0 }. - (BitBlt toForm: result) - sourceForm: self; - combinationRule: Form over; - colorMap: map; - sourceRect: (`0@0` extent: width@height); - destOrigin: `0@0`; - copyBits. - - "final BitBlt to zero-out pixels that were truely transparent in the original" - map _ Bitmap new: 512. - map at: 1 put: 16rFF. - (BitBlt toForm: result) - sourceForm: self; - sourceRect: self boundingBox; - destOrigin: `0@0`; - combinationRule: Form erase; - colorMap: map; - copyBits. - ^ result! ! -!Form methodsFor: 'converting' stamp: 'jmv 6/19/2017 16:04:17' prior: 16847525! - icon - "Answer a 16 x 16 icon of myself" - - ^self magnifyTo: `16 @ 16`! ! -!Form methodsFor: 'copying' stamp: 'jmv 6/19/2017 15:49:47' prior: 16847584! - contentsOfArea: aRect into: newForm - "Return a new form which derives from the portion of the original form delineated by aRect." - ^ newForm copyBits: aRect from: self at: `0@0` - clippingBox: newForm boundingBox rule: Form over! ! -!Form methodsFor: 'copying' stamp: 'jmv 6/19/2017 15:49:55' prior: 16847594! - copy: aRect - "Return a new form which derives from the portion of the original form delineated by aRect." - | newForm | - newForm _ self class extent: aRect extent depth: depth. - ^ newForm copyBits: aRect from: self at: `0@0` - clippingBox: newForm boundingBox rule: Form over! ! -!Form methodsFor: 'copying' stamp: 'jmv 6/19/2017 15:50:02' prior: 16847621! - copyBits: sourceForm at: destOrigin translucent: factor - "Make up a BitBlt table and copy the bits with the given colorMap." - (BitBlt - destForm: self - sourceForm: sourceForm - combinationRule: 30 - destOrigin: destOrigin - sourceOrigin: `0@0` - extent: sourceForm extent - clipRect: self boundingBox) - copyBitsTranslucent: ((0 max: (factor*255.0) asInteger) min: 255) -" - | f f2 f3 | f _ Form fromUser. f2 _ Form fromDisplay: (0@0 extent: f extent). f3 _ f2 copy. -0.0 to: 1.0 by: 1.0/32 do: - [:t | f3 _ f2 copy. f3 copyBits: f at: 0@0 translucent: t. - f3 displayAt: 0@0. (Delay forMilliseconds: 100) wait]. -"! ! -!Form methodsFor: 'display box access' stamp: 'jmv 6/19/2017 16:04:01' prior: 16847674! -boundingBox - ^ Rectangle - origin: `0 @ 0` - corner: width @ height! ! -!Form methodsFor: 'displaying' stamp: 'jmv 6/19/2017 15:51:05' prior: 16847690! - paintBits: sourceForm at: destOrigin translucent: factor - "Make up a BitBlt table and copy the bits with the given colorMap." - (BitBlt destForm: self - sourceForm: sourceForm - combinationRule: 31 - destOrigin: destOrigin - sourceOrigin: `0@0` - extent: sourceForm extent - clipRect: self boundingBox) - copyBitsTranslucent: ((0 max: (factor*255.0) asInteger) min: 255) -" - | f f2 f3 | f _ Form fromUser. f replaceColor: f dominantColor withColor: Color transparent. -f2 _ Form fromDisplay: (0@0 extent: f extent). f3 _ f2 copy. -0.0 to: 1.0 by: 1.0/32 do: - [:t | f3 _ f2 copy. f3 paintBits: f at: 0@0 translucent: t. - f3 displayAt: 0@0. (Delay forMilliseconds: 100) wait]. -"! ! -!Form methodsFor: 'displaying-generic' stamp: 'jmv 6/19/2017 16:04:09' prior: 16847730! - displayOn: aDisplayMedium - "Simple default display in order to see the receiver in the upper left - corner of screen." - - self displayOn: aDisplayMedium at: `0 @ 0`! ! -!Form methodsFor: 'filling' stamp: 'jmv 6/19/2017 15:50:07' prior: 16847937! - eraseShape: bwForm - "use bwForm as a mask to clear all pixels where bwForm has 1's" - ((BitBlt destForm: self sourceForm: bwForm - combinationRule: Form erase1bitShape "Cut a hole in the picture with my mask" - destOrigin: bwForm offset - sourceOrigin: `0@0` - extent: self extent clipRect: self boundingBox) - colorMap: (Bitmap with: 0 with: 16rFFFFFFFF)) - copyBits. -! ! -!Form methodsFor: 'filling' stamp: 'jmv 6/19/2017 15:50:12' prior: 16847951! - fill: aRectangle rule: anInteger fillColor: aForm - "Replace a rectangular area of the receiver with the pattern described by aForm - according to the rule anInteger." - (BitBlt toForm: self) - copy: aRectangle - from: `0@0` in: nil - fillColor: aForm rule: anInteger! ! -!Form methodsFor: 'image manipulation' stamp: 'jmv 6/19/2017 15:51:26' prior: 16848014! - smear: dir distance: dist - "Smear any black pixels in this form in the direction dir in Log N steps" - | skew bb | - bb _ BitBlt destForm: self sourceForm: self - combinationRule: Form under destOrigin: `0@0` sourceOrigin: `0@0` - extent: self extent clipRect: self boundingBox. - skew _ 1. - [skew < dist] whileTrue: - [bb destOrigin: dir*skew; copyBits. - skew _ skew+skew]! ! -!Form methodsFor: 'transitions' stamp: 'jmv 6/19/2017 15:50:50' prior: 50358237! - pageWarp: otherImage at: topLeft forward: forward - "Produce a page-turning illusion that gradually reveals otherImage - located at topLeft in this form. - forward == true means turn pages toward you, else away. [ignored for now]" - | pageRect oldPage nSteps buffer p leafRect sourceQuad warp oldBottom d | - pageRect _ otherImage boundingBox. - oldPage _ self copy: (pageRect translatedBy: topLeft). - (forward ifTrue: [oldPage] ifFalse: [otherImage]) - border: pageRect - widthRectangle: (Rectangle - left: 0 - right: 2 - top: 1 - bottom: 1) - rule: Form over - fillColor: Color black. - oldBottom _ self copy: ((pageRect bottomLeft + topLeft) extent: (pageRect width@(pageRect height//4))). - nSteps _ 8. - buffer _ Form extent: otherImage extent + (0@(pageRect height//4)) depth: self depth. - d _ pageRect topLeft + (0@(pageRect height//4)) - pageRect topRight. - 1 to: nSteps-1 do: - [:i | forward - ifTrue: [buffer copy: pageRect from: otherImage to: `0@0` rule: Form over. - p _ pageRect topRight + (d * i // nSteps)] - ifFalse: [buffer copy: pageRect from: oldPage to: `0@0` rule: Form over. - p _ pageRect topRight + (d * (nSteps-i) // nSteps)]. - buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over. - leafRect _ pageRect topLeft corner: p x @ (pageRect bottom + p y). - sourceQuad _ Array with: pageRect topLeft - with: pageRect bottomLeft + (0@p y) - with: pageRect bottomRight - with: pageRect topRight - (0@p y). - warp _ (WarpBlt toForm: buffer) - clipRect: leafRect; - sourceForm: (forward ifTrue: [oldPage] ifFalse: [otherImage]); - combinationRule: Form paint. - warp copyQuad: sourceQuad toRect: leafRect. - self copy: buffer boundingBox from: buffer to: topLeft rule: Form over. - Display forceToScreen. - ]. - - buffer copy: pageRect from: otherImage to: `0@0` rule: Form over. - buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over. - self copy: buffer boundingBox from: buffer to: topLeft rule: Form over. - Display forceToScreen. -" -1 to: 4 do: [:corner | Display pageWarp: - (Form fromDisplay: (10@10 extent: 200@300)) reverse - at: 10@10 forward: false] -" -! ! -!Form methodsFor: 'private' stamp: 'jmv 6/19/2017 16:04:06' prior: 16848740! - copyFromByteArray: bigEndianByteArray - "This method should work with either byte orderings. - See comment at Bitmap>>#asByteArray - Also see #copyFromByteArray2:to:" - - | myHack byteHack | - myHack := Form new hackBits: bits. - byteHack := Form new hackBits: bigEndianByteArray. - "We are passing a ByteArray instead of a Words object. Will be accessed according to native endianness." - Smalltalk isLittleEndian = self isLittleEndian ifFalse: [byteHack swapEndianness]. - byteHack displayOn: myHack at: `0 @ 0` rule: Form over! ! -!Form methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:04:13' prior: 16848849! - fromDisplay: aRectangle - "Create a virtual bit map from a user specified rectangular area on the - display screen. Reallocates bitmap only if aRectangle ~= the receiver's - extent." - - (width = aRectangle width and: [height = aRectangle height]) - ifFalse: [self setExtent: aRectangle extent depth: depth]. - self - copyBits: (aRectangle origin extent: self extent) - from: Display - at: `0 @ 0` - clippingBox: self boundingBox - rule: Form over! ! -!Form methodsFor: 'encoding' stamp: 'jmv 6/19/2017 15:49:02' prior: 16848870! - addDeltasFrom: previousForm - - (BitBlt - destForm: self - sourceForm: previousForm - fillColor: nil - combinationRule: Form reverse - destOrigin: `0@0` - sourceOrigin: `0@0` - extent: self extent - clipRect: self boundingBox) copyBits. - ^self! ! -!Form class methodsFor: 'instance creation' stamp: 'jmv 6/19/2017 16:37:08' prior: 50358308! - dotOfSize: diameter - "Create a form which contains a round black dot." - | radius form bb rect centerX centerY centerYBias centerXBias radiusSquared xOverY maxy dx | - radius _ diameter//2. - form _ self extent: diameter@diameter offset: `0@0` - radius. - bb _ (BitBlt toForm: form) - sourceX: 0; sourceY: 0; - combinationRule: Form over; - fillColor: Color black. - rect _ form boundingBox. - centerX _ rect center x. - centerY _ rect center y. - centerYBias _ rect height odd ifTrue: [0] ifFalse: [1]. - centerXBias _ rect width odd ifTrue: [0] ifFalse: [1]. - radiusSquared _ (rect height asFloat / 2.0) squared - 0.01. - xOverY _ rect width asFloat / rect height asFloat. - maxy _ rect height - 1 // 2. - - "First do the inner fill, and collect x values" - 0 to: maxy do: - [:dy | - dx _ ((radiusSquared - (dy * dy) asFloat) sqrt * xOverY) truncated. - bb destX: centerX - centerXBias - dx - destY: centerY - centerYBias - dy - width: dx + dx + centerXBias + 1 - height: 1; - copyBits. - bb destY: centerY + dy; - copyBits]. - ^ form -" -Time millisecondsToRun: - [1 to: 20 do: [:i | (Form dotOfSize: i) displayAt: (i*20)@(i*20)]] -"! ! -!Form class methodsFor: 'examples' stamp: 'jmv 6/19/2017 16:04:23' prior: 50358370! - toothpaste: diam - " - Display restoreAfter: [Form toothpaste: 30] - " - "Not completely unlike the ST-80 implementation :) - Original comment: - Draws wormlike lines by laying down images of spheres. - See Ken Knowlton, Computer Graphics, vol. 15 no. 4 p352. - Draw with mouse button down; terminate by option-click." - | point queue color q colors colr colr2 | - colors _ Color red wheel: 12. - color _ 8. - [ true ] whileTrue: [ - queue _ OrderedCollection new: 32. - 16 timesRepeat: [queue addLast: `-40@-40`]. - Sensor waitButton. - Sensor isMouseButton2Pressed ifTrue: [^ self]. - point _ Sensor mousePoint. - colr _ colors atWrap: (color _ color + 5). "choose increment relatively prime to colors size" - colr2 _ colr alpha: 0.3. - [Sensor isMouseButton1Pressed or: [queue size > 0]] whileTrue: [ - point _ point * 4 + Sensor mousePoint // 5. - point _ point. - Form fakeSphereAt: point diameter: diam color: colr. - (q _ queue removeFirst) ifNil: [^ self]. "exit" - Form fakeSphereAt: q diameter: diam color: colr2. - Sensor isMouseButton1Pressed ifTrue: [queue addLast: point]]]! ! -!ColorForm methodsFor: 'color manipulation' stamp: 'jmv 6/19/2017 15:47:08' prior: 16818811! - asGrayForm - "Build an optimal GrayForm, - for any color palette in the receiver." - | answer map | - answer _ GrayForm extent: width@height. - map _ self colormapIfNeededForGray8bpp. - (BitBlt toForm: answer) - colorMap: map; - copy: self boundingBox - from: `0@0` in: self - fillColor: nil rule: Form over. - ^ answer! ! -!ColorForm methodsFor: 'copying' stamp: 'jmv 6/19/2017 15:47:12' prior: 16818912! - copy: aRect - "Return a new ColorForm containing the portion of the receiver delineated by aRect." - - | newForm | - newForm _ self class extent: aRect extent depth: depth. - ((BitBlt - destForm: newForm - sourceForm: self - combinationRule: Form over - destOrigin: `0@0` - sourceOrigin: aRect origin - extent: aRect extent - clipRect: newForm boundingBox) - colorMap: nil) copyBits. - colors ifNotNil: [newForm colors: colors copy]. - ^ newForm -! ! -!ColorForm class methodsFor: 'as yet unclassified' stamp: 'jmv 6/19/2017 15:47:16' prior: 50358637! -mappingWhiteToTransparentFrom: aFormOrCursor - "Return a ColorForm copied from the given Form or Cursor with white mapped to transparent." - - | f map | - aFormOrCursor depth <= 8 ifFalse: [ - ^ self error: 'argument depth must be 8-bits per pixel or less']. - (aFormOrCursor is: #ColorForm) ifTrue: [ - f _ aFormOrCursor copy. - map _ aFormOrCursor colors. - ] ifFalse: [ - f _ ColorForm extent: aFormOrCursor extent depth: aFormOrCursor depth. - f copyBits: aFormOrCursor boundingBox - from: aFormOrCursor - at: `0@0` - clippingBox: aFormOrCursor boundingBox - rule: Form over. - map _ Color indexedColors copyFrom: 1 to: (1 bitShift: aFormOrCursor depth)]. - map _ map collect: [:c | - c = Color white ifTrue: [Color transparent] ifFalse: [c]]. - f colors: map. - ^ f -! ! -!Cursor methodsFor: 'converting' stamp: 'jmv 6/19/2017 15:47:21' prior: 16825862! - enlargedBy: scale - "Big cursors are 32 bits deep (ARGB premultiplied)" - | big | - scale = 1 ifTrue: [^self]. - big := CursorWithAlpha extent: self extent * scale depth: 32. - (self asCursorForm magnifyBy: scale) displayOn: big. - big offset: (self offset - 0.5 * scale min: `0@0` max: big extent negated) asIntegerPoint. - big fallback: self. - ^big! ! -!DisplayScreen class methodsFor: 'snapshots' stamp: 'jmv 6/19/2017 16:02:49' prior: 16835519! - actualScreenSize - - ^ `640@480`! ! -!DisplayScreen class methodsFor: 'snapshots' stamp: 'jmv 6/19/2017 16:02:57' prior: 16835523! - shutDown - "Minimize Display memory saved in image" - Display setExtent: `240@120` depth: Display nativeDepth. - ScreenUpdaterProcess ifNotNil: [ - ScreenUpdaterProcess terminate. - ScreenUpdaterProcess _ nil ]! ! -!GrayForm methodsFor: 'copying' stamp: 'jmv 6/19/2017 15:52:16' prior: 16850389! - copy: aRect - "Return a new instance containing the portion of the receiver delineated by aRect." - - | newForm | - newForm _ self class extent: aRect extent depth: depth. - ((BitBlt - destForm: newForm - sourceForm: self - combinationRule: Form over - destOrigin: `0@0` - sourceOrigin: aRect origin - extent: aRect extent - clipRect: newForm boundingBox) - colorMap: nil) copyBits. - ^ newForm! ! -!BitBlt class methodsFor: 'instance creation' stamp: 'jmv 6/19/2017 15:45:22' prior: 16786163! - bitPeekerFromForm: sourceForm - "Answer an instance to be used extract individual pixels from the given Form. The destination for a 1x1 copyBits will be the low order bits of (bits at: 1)." - | pixPerWord answer | - pixPerWord _ sourceForm pixelsPerWord. - answer _ self destForm: (Form extent: pixPerWord@1 depth: sourceForm depth) - sourceForm: nil "To ensure no colormap set" - combinationRule: Form over - destOrigin: (pixPerWord - 1)@0 - sourceOrigin: `0@0` - extent: `1@1` - clipRect: (`0@0` extent: pixPerWord@1). - "To ensure no colormap set" - answer sourceForm: sourceForm. - ^ answer! ! -!BitBlt class methodsFor: 'instance creation' stamp: 'jmv 6/19/2017 15:45:33' prior: 16786184! - bitPokerToForm: destForm - "Answer an instance to be used for valueAt: aPoint put: pixValue. - The source for a 1x1 copyBits will be the low order of (bits at: 1)" - | pixPerWord answer | - pixPerWord _ 32//destForm depth. - answer _ self destForm: destForm - sourceForm: nil "To ensure no colormap set" - combinationRule: Form over - destOrigin: `0@0` - sourceOrigin: (pixPerWord-1)@0 - extent: `1@1` - clipRect: (`0@0` extent: destForm extent). - "To ensure no colormap set" - answer sourceForm: (Form extent: pixPerWord@1 depth: destForm depth). - ^ answer! ! -!AffineTransformation methodsFor: 'converting coordinates' stamp: 'jmv 6/19/2017 15:43:10' prior: 16778110! - internalizeDelta: aPoint - "Internalize a distance vector. A distance is not a position. It is a magnitude with a direction. - It is usually used as a delta to be added to a position to obtain some other position." - - | x y det a11 a12 a21 a22 detX detY | - x _ aPoint x. - y _ aPoint y. - a11 _ self a11. - a12 _ self a12. - a21 _ self a21. - a22 _ self a22. - det _ (a11 * a22) - (a12 * a21). - det = 0.0 ifTrue: [ ^`0@0` ]. "So we have at least a valid result" - det _ 1.0 / det. - detX _ (x * a22) - (a12 * y). - detY _ (a11 * y) - (x * a21). - ^(detX * det) @ (detY * det)! ! -!AffineTransformation methodsFor: 'converting coordinates' stamp: 'jmv 6/19/2017 15:43:16' prior: 16778149! - inverseTransform: aPoint - "Apply the inverse transformation to aPoint, i.e. multiply our inverse by aPoint. - Use Smalltalk code, and not Matrix2x3Plugin, because we want Float conversion." - | x y det a11 a12 a21 a22 detX detY | - - x _ aPoint x - self a13. - y _ aPoint y - self a23. - a11 _ self a11. - a12 _ self a12. - a21 _ self a21. - a22 _ self a22. - det _ (a11 * a22) - (a12 * a21). - det = 0.0 ifTrue: [ ^`0@0` ]. "So we have at least a valid result" - det _ 1.0 / det. - detX _ (x * a22) - (a12 * y). - detY _ (a11 * y) - (x * a21). - ^(detX * det) @ (detY * det)! ! -!AffineTransformation methodsFor: 'accessing' stamp: 'jmv 6/19/2017 15:43:25' prior: 16778231! - inverseTransformation - "Return the inverse transformation of the receiver. - The inverse transformation is computed by first calculating - the inverse offset and then computing transformations - for the two identity vectors (1@0) and (0@1)" - | r1 r2 r3 m | - r3 _ self inverseTransform: `0@0`. - r1 _ (self inverseTransform: `1@0`) - r3. - r2 _ (self inverseTransform: `0@1`) - r3. - m _ self species new. - m - a11: r1 x; a12: r2 x; a13: r3 x; - a21: r1 y; a22: r2 y; a23: r3 y. - ^m! ! -!AffineTransformation methodsFor: 'transforming rects' stamp: 'jmv 6/19/2017 15:43:02' prior: 16778783! - displayBoundsOfTransformOf: aRectangle - "Externalize aRectangle, and find a bounding rectangle with horizontal - and vertical bounds and integer coordinates (i.e. adisplayBounds). - Primitive rounds and answers integers. - Warning: if answer from primitive is not strictly positive, it is off by one. Fix it here." - - | dstRect | - dstRect _ Rectangle new. - (self primDisplayBoundsOfTransformOf: aRectangle into: dstRect) ifNotNil: [ - dstRect topLeft > `0@0` ifTrue: [ ^dstRect ]]. - ^Rectangle encompassing: (aRectangle corners collect: [ :pt | - (self transform: pt) rounded ])! ! -!Point methodsFor: 'point functions' stamp: 'jmv 6/19/2017 16:10:05' prior: 16890518! - eightNeighbors - ^ (Array with: self + `1@0` - with: self + `1@1` - with: self + `0@1` - with: self + `-1@1`) , - (Array with: self + `-1@0` - with: self + `-1@-1` - with: self + `0@-1` - with: self + `1@-1`) -! ! -!Point methodsFor: 'point functions' stamp: 'jmv 6/19/2017 16:10:18' prior: 16890538! - fourNeighbors - ^ Array with: self + `1@0` - with: self + `0@1` - with: self + `-1@0` - with: self + `0@-1` -! ! -!Rectangle methodsFor: 'accessing' stamp: 'jmv 6/19/2017 16:11:04' prior: 16898560! - innerCorners - "Return an array of inner corner points, - ie, the most extreme pixels included, - in the order of a quadrilateral spec for WarpBlt" - | r1 | - r1 _ self topLeft corner: self bottomRight - `1@1`. - ^ Array with: r1 topLeft with: r1 bottomLeft with: r1 bottomRight with: r1 topRight! ! -!Morph methodsFor: 'events-processing' stamp: 'jmv 6/19/2017 15:54:30' prior: 16875129! - processUnknownEvent: aMorphicEvent localPosition: localEventPosition - "An event of an unknown type was sent to the receiver. What shall we do?!!" - - Smalltalk beep. - aMorphicEvent printString displayAt: `0@0`. - aMorphicEvent wasHandled: true! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 6/19/2017 16:08:34' prior: 16875336! - minimumExtent - "This returns the minimum extent that the morph may be shrunk to. Not honored in too many places yet, but respected by the resizeToFit feature, at least" - - self flag: #jmvVer2. "in owner's coordinates?" - ^self valueOfProperty: #minimumExtent ifAbsent: [`1@1`]! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 6/19/2017 16:08:41' prior: 16875397! - morphExtent - "In our own coordinates!!" -"Quizas eventualmente borrar este tambien? (no se usa mucho...)" - self flag: #jmvVer2. - ^`50 @ 40`! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 6/19/2017 15:54:22' prior: 16875457! - morphPositionInWorld - - self flag: #jmvVer2. - "Most likely we don't want to use global coordinates... - In fact, we could be in many frames of reference at the same time... - This method makes no sense at all!!" - - ^self externalizeToWorld: `0@0`! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 6/19/2017 15:54:26' prior: 16875515! - morphTopLeft - "By default, morphs occupy a rectangle specified by #morphTopLef and #morphExtent" - ^`0@0`! ! -!Morph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:08:46' prior: 16875946! - openInWorld: aWorld - "Add this morph to the requested World." - (location = MorphicTranslation new) - ifTrue: [ aWorld addMorph: self position: `50@50` ] - ifFalse: [ aWorld addMorph: self ]! ! -!RectangleLikeMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:11:08' prior: 16899200! - initialize - super initialize. - extent _ `50@40`. - color _ self defaultColor! ! -!PasteUpMorph methodsFor: 'change reporting' stamp: 'jmv 6/19/2017 15:55:13' prior: 16887050! - invalidateDisplayRect: damageRect from: aMorph - "Clip damage reports to my bounds, since drawing is clipped to my bounds." - - self == self world - ifTrue: [ worldState recordDamagedRect: (damageRect intersect: ( `0@0` extent: extent) ) ] - ifFalse: [ super invalidateDisplayRect: damageRect from: aMorph ] -! ! -!PasteUpMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:55:00' prior: 16887077! - drawOn: aCanvas - - "draw background image." - backgroundImage - ifNotNil: [ - aCanvas image: backgroundImage at: `0@0` ] - ifNil: [ - "draw background fill" - (self isWorldMorph and: [ aCanvas drawsOnDisplay ] and: [ color mightBeTranslucent ]) - ifTrue: [ - "Special case so a translucent background on the Display allows you to see through the main Cuis Window. - Requires proper handling of translucent Display in the VM. - Seems to work only on Linux when using a composing window manager." - (BitBlt toForm: Display) clipRect: aCanvas clipRect; - copy: Display boundingBox - from: `0@0` in: nil - fillColor: color rule: Form over. - Display forceToScreen] - ifFalse: [ super drawOn: aCanvas ]]! ! -!PasteUpMorph methodsFor: 'geometry' stamp: 'jmv 6/19/2017 15:55:18' prior: 16887238! - morphPositionInWorld - - self flag: #jmvVer2. "Solo para evitar los warning por falta de owner... pensar despues este caso" - self isWorldMorph ifTrue: [ ^ `0@0` ]. - ^super morphPositionInWorld! ! -!PasteUpMorph methodsFor: 'project state' stamp: 'jmv 6/19/2017 15:55:22' prior: 50337473! - viewBox - - ^ worldState - ifNotNil: [ - `0@0` extent: extent ] - ifNil: [ - self world viewBox ]! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 6/19/2017 15:55:05' prior: 16887770! - fillRects: rectangleList color: aColor - "For testing. Flashes the given list of rectangles on the Display so you can watch incremental redisplay at work." - - - | blt screenRect | - blt _ (BitBlt toForm: Display) - sourceForm: nil; - sourceOrigin: `0@0`; - clipRect: self viewBox; - fillColor: aColor; - combinationRule: Form over. - - rectangleList do: [:r | - screenRect _ r translatedBy: self viewBox origin. - blt destRect: screenRect; copyBits. - Display forceToScreen: screenRect ]. - - (Delay forMilliseconds: 150) wait! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 6/19/2017 15:55:09' prior: 16887789! - flashRects: rectangleList color: aColor - "For testing. Flashes the given list of rectangles on the Display so you can watch incremental redisplay at work." - "Details: Uses two reverses so that the display is restored to its original state. This is necessary when in deferred update mode." - - | blt screenRect | - blt _ (BitBlt toForm: Display) - sourceForm: nil; - sourceOrigin: `0@0`; - clipRect: self viewBox; - fillColor: aColor; - combinationRule: Form reverse. - - rectangleList do: [:r | - screenRect _ r translatedBy: self viewBox origin. - blt destRect: screenRect; copyBits. - Display forceToScreen: screenRect ]. - - (Delay forMilliseconds: 250) wait. - - rectangleList do: [:r | - screenRect _ r translatedBy: self viewBox origin. - blt destRect: screenRect; copyBits. - Display forceToScreen: screenRect ]! ! -!PasteUpMorph class methodsFor: 'instance creation' stamp: 'jmv 6/19/2017 15:55:26' prior: 50337489! - newWorld - " -[ - ProjectX stopUIProcess. - ProjectX spawnNewMorphicProcessFor: PasteUpMorph newWorld -] fork. - " - | w ws | - w _ self new. - ws _ WorldState new. - w worldState: ws. - w morphPosition: `0@0` extent: Display extent. - ws setCanvas: Display getCanvas. - w borderWidth: 0. - ws handsDo: [ :h | - h privateOwner: w ]. - ^w! ! -!EllipseMorph methodsFor: 'geometry testing' stamp: 'jmv 6/19/2017 16:03:06' prior: 16837091! - morphContainsPoint: aLocalPoint - - | radius other delta xOverY | - ((`0@0` extent: extent) containsPoint: aLocalPoint) ifFalse: [^ false]. "quick elimination" - extent > `1@1` - ifFalse: [^ true]. "Degenerate case -- code below fails by a bit" - - radius _ extent y asFloat / 2. - other _ extent x asFloat / 2. - delta _ aLocalPoint - (other@radius). - xOverY _ extent x asFloat / extent y asFloat. - ^ (delta x asFloat / xOverY) squared + delta y squared <= radius squared! ! -!HandleMorph methodsFor: 'events' stamp: 'jmv 6/19/2017 16:05:03' prior: 16852419! - keyStroke: aKeyboardEvent - "Check for cursor keys" - | keyValue | - (owner is: #HandMorph) ifFalse: [ ^self ]. - keyValue _ aKeyboardEvent keyValue. - keyValue = 28 ifTrue: [ ^self morphPosition: self morphPosition - `1@0` ]. - keyValue = 29 ifTrue: [ ^self morphPosition: self morphPosition + `1@0` ]. - keyValue = 30 ifTrue: [ ^self morphPosition: self morphPosition - `0@1` ]. - keyValue = 31 ifTrue: [ ^self morphPosition: self morphPosition + `0@1` ]. - "Special case for return" - aKeyboardEvent isReturnKey ifTrue:[ - "Drop the receiver and be done" - self flag: #arNote. "Probably unnecessary" - owner releaseKeyboardFocus: self. - self delete ]! ! -!HandleMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:04:48' prior: 16852446! - initialize - "initialize the state of the receiver" - super initialize. - extent _ `12@12`! ! -!PluggableMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:09:25' prior: 16889457! - initialize - super initialize. - extent _ `200@100`! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:55:30' prior: 16888083! - draw3DLookOn: aCanvas - - | borderStyleSymbol c | - borderStyleSymbol _ self isPressed ifFalse: [ #raised ] ifTrue: [ #inset ]. - c _ color. - self mouseIsOver ifTrue: [ c _ c lighter ]. - aCanvas - fillRectangle: (`0@0` extent: extent) - color: c - borderWidth: borderWidth - borderStyleSymbol: borderStyleSymbol - baseColorForBorder: c. - - self drawRegularLabelOn: aCanvas! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:55:46' prior: 50359281! - drawRoundGradientLookOn: aCanvas - | r colorForButton rect bottomFactor topFactor | - - self isPressed - ifFalse: [ - topFactor _ Theme current buttonGradientTopFactor. - bottomFactor _ Theme current buttonGradientBottomFactor. - self mouseIsOver - ifTrue: [ - colorForButton _ Color h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ - colorForButton _ color ]] - ifTrue: [ - topFactor _ Theme current buttonGradientBottomFactor. - bottomFactor _ Theme current buttonGradientTopFactor. - colorForButton _ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - Theme current useButtonGradient - ifTrue: [ - rect _ (`0@0` extent: extent) insetBy: `1@3`. - aCanvas - roundRect: rect - color: colorForButton - radius: r - gradientTop: topFactor - gradientBottom: bottomFactor - gradientHeight: Theme current buttonGradientHeight ] - ifFalse: [ - rect _ (`0@0` extent: extent) insetBy: `1@3`. - aCanvas roundRect: rect color: colorForButton radius: r ] - ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawEmbossedLabelOn: aCanvas ] - ifFalse: [ self drawRegularLabelOn: aCanvas ]! ! -!PluggableButtonMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:09:15' prior: 16888316! - initialize - "initialize the state of the receiver" - super initialize. - - roundButtonStyle _ nil. "nil: honor Theme. true: draw as round button. false: draw as classic 3d border square button" - model _ nil. - getStateSelector _ nil. - actionSelector _ nil. - isPressed _ false. - mouseIsOver _ false. - actWhen _ #buttonUp. - extent _ `20 @ 15`! ! -!PluggableButtonMorph methodsFor: 'geometry testing' stamp: 'jmv 6/19/2017 15:55:52' prior: 16888418! - morphContainsPoint: aLocalPoint - - | iconOrigin | - ((`0@0` extent: extent) containsPoint: aLocalPoint) ifFalse: [ ^false ]. - ^ self isOrthoRectangularMorph or: [ - magnifiedIcon isNil or: [ - iconOrigin _ extent - magnifiedIcon extent // 2. - (magnifiedIcon isTransparentAt: (aLocalPoint - iconOrigin) rounded) not ]]! ! -!PluggableButtonMorph class methodsFor: 'example' stamp: 'jmv 6/19/2017 16:09:19' prior: 50359330! - example - " - PluggableButtonMorph example openInWorld - " - - | s1 s2 s3 b1 b2 b3 row | - s1 _ Switch new. - s2 _ Switch new turnOn. - s3 _ Switch new. - s2 onAction: [s3 turnOff]. - s3 onAction: [s2 turnOff]. - b1 _ (PluggableButtonMorph model: s1 stateGetter: #isOn action: #switch) label: 'S1'. - b2 _ (PluggableButtonMorph model: s2 stateGetter: #isOn action: #turnOn) label: 'S2'. - b3 _ (PluggableButtonMorph model: s3 stateGetter: #isOn action: #turnOn) label: 'S3'. - b1 color: Color lightRed. - b2 color: Color lightRed. - b3 color: Color lightRed. - row _ LayoutMorph newRow - addMorphs: (Array with: b1 with: b2 with: b3); - morphExtent: `120@35`. - ^ row -! ! -!PluggableScrollPane methodsFor: 'access' stamp: 'jmv 6/19/2017 15:56:26' prior: 16889497! - addToScroller: aMorph - - scroller - addMorph: aMorph position: `0@0`; - morphExtent: aMorph morphExtent! ! -!PluggableScrollPane methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:09:31' prior: 16889865! - initialize - - "initialize the state of the receiver" - super initialize. - hideScrollBars _ false. - - "initialize the receiver's scrollBars" - scrollBar _ self scrollBarClass new model: self setValueSelector: #vScrollBarValue:. - hScrollBar _ self scrollBarClass new model: self setValueSelector: #hScrollBarValue:. - drawKeyboardFocusIndicator _ true. - - scroller _ self innerMorphClass new. - self addMorph: scroller. - self scrollerOffset: `0@ 0`. - self addMorph: scrollBar. - self addMorph: hScrollBar.! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'jmv 6/19/2017 15:56:31' prior: 16889992! - scrollToShow: aRectangle - "scroll to include as much of aRectangle as possible, where aRectangle is in the scroller's local space. - This means that 0@0 is scrolling all the way top and all the way left" - | delta | - (aRectangle top >= 0 and: [ - aRectangle bottom <= self viewableHeight ]) - ifTrue: [ - "already visible" - ^self ]. - - "Scroll end of selection into view if necessary" - delta _ aRectangle amountToTranslateWithin: (`0@0` extent: self viewableExtent). - delta y ~= 0 ifTrue: [ - self scrollBy: 0@delta y ]! ! -!PluggableListMorphOfMany methodsFor: 'events' stamp: 'jmv 6/19/2017 15:55:58' prior: 16889279! - mouseMove: aMouseMoveEvent localPosition: localEventPosition - "The mouse has moved, as characterized by the event provided. Adjust the scrollbar, and alter the selection as appropriate" - - | oldIndex oldVal row | - row _ (localEventPosition y < 0 and: [ scrollBar value > 0.0 ]) - ifTrue: [ - scrollBar scrollUp: 1. - "Leave at least one visible item unaffected, for better visual feedback to the user." - (self rowAtLocation: `0@0`) + 2 ] - ifFalse: [ - (localEventPosition y > extent y and: [ scrollBar value < 1.0 ]) - ifTrue: [ - scrollBar scrollDown: 1. - "Leave at least one visible item unaffected, for better visual feedback to the user." - (self rowAtLocation: 0@extent y) - 3 ] - ifFalse: [ self rowAtLocation: localEventPosition ]]. - row = 0 ifTrue: [ ^ self ]. - - "No change if model is locked" - self owningWindow ifNotNil: [ :w | - w okToChange ifFalse: [^ self]]. - - dragOnOrOff ifNil: [ - "Was not set at mouse down, which means the mouse must have gone down in an area where there was no list item" - dragOnOrOff _ (self listSelectionAt: row) not. - dragStartRow _ row ]. - - "Set meaning for subsequent dragging of selection" - oldIndex _ self getCurrentSelectionIndex. - oldIndex ~= 0 ifTrue: [ oldVal _ self listSelectionAt: oldIndex ]. - - "Set or clear new primary selection (listIndex)" - dragOnOrOff - ifTrue: [ self changeModelSelection: row ] - ifFalse: [ self changeModelSelection: 0 ]. - - "Need to restore the old one, due to how model works, and set new one." - oldIndex ~= 0 ifTrue: [ self listSelectionAt: oldIndex put: oldVal ]. - - "Select all in between if drag was too fast" - "self listSelectionAt: row put: dragOnOrOff." - (row min: dragStartRow) to: (row max: dragStartRow) do: [ :r | - self listSelectionAt: r put: dragOnOrOff ]! ! -!SystemWindow methodsFor: 'change reporting' stamp: 'jmv 6/19/2017 15:58:02' prior: 16926004! - invalidateTitleArea - - "not really pretty... also invalidating the top border, regardless of it being above or below the title area - (Different themes use various looks, this covers them all)" - self invalidateLocalRect: (`0@0` extent: extent x @ (self labelHeight + borderWidth))! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:57:54' prior: 16926054! - drawClassicFrameOn: aCanvas color: titleColor - "Window border encompasses title area. No round corners. No title gradient." - - aCanvas fillRectangle: (`0@0` extent: extent) color: color borderWidth: borderWidth borderStyleSymbol: #simple baseColorForBorder: self widgetsColor. - - "A border was drawn at the left, top and right of the title area. - The look is that the title area is inside the window" - aCanvas fillRectangle: (borderWidth@borderWidth extent: extent x - (2*borderWidth)@ self labelHeight) color: titleColor! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:57:58' prior: 16926109! -drawRoundedFrameOn: aCanvas color: widgetsColor - "Title area is not inside window borders" - | bottomFactor topFactor | - Theme current useWindowTitleGradient - ifTrue: [ - topFactor _ Theme current titleGradientTopFactor. - bottomFactor _ Theme current titleGradientBottomFactor ] - ifFalse: [ - topFactor _ 1. - bottomFactor _ 1 ]. - aCanvas - windowFrame: (`0@0` extent: extent) - color: widgetsColor * Theme current titleGradientExtraLightness - radius: Theme current roundedWindowRadius - border: borderWidth - labelHeight: self labelHeight + borderWidth - gradientTop: topFactor - gradientBottom: bottomFactor - insideColor: color! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 6/19/2017 16:37:43' prior: 16926132! - makeMeFullyVisible - - self world morphExtent > `0@0` ifFalse: [^ self]. - - (self morphPosition >= `0@0` and: [ self morphPosition < (self world morphExtent-self morphExtent)]) ifTrue: [ - ^ self "OK -- visible"]. - - self morphPosition: (RealEstateAgent initialFrameFor: self initialExtent: self morphExtentInWorld world: self world) topLeft! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 6/19/2017 16:37:53' prior: 16926145! - makeMeVisible - - self world morphExtent > `0@0` ifFalse: [^ self]. - - (self morphPosition >= `0@0` and: [ self morphPosition < (self world morphExtent-self labelHeight)]) ifTrue: [ - ^ self "OK -- at least my top left is visible"]. - - "window not on screen (probably due to reframe) -- move it now" - self morphPosition: (RealEstateAgent initialFrameFor: self initialExtent: extent world: self world) topLeft! ! -!SystemWindow methodsFor: 'geometry' stamp: 'jmv 6/19/2017 16:12:56' prior: 16926196! - minimumExtent - - ^`160@80`! ! -!SystemWindow methodsFor: 'geometry' stamp: 'jmv 6/19/2017 16:13:07' prior: 16926199! - rescaleButtons - "boxExtent changed. Update my buttons." - | buttonExtent buttonPos buttonDelta | - buttonExtent := self boxExtent. - buttonPos := `2@2`. - buttonDelta := self boxExtent x + 2. - self submorphsReverseDo: [ :aMorph | - (aMorph is: #PluggableButtonMorph) - ifTrue: [ - aMorph morphExtent: buttonExtent. - aMorph morphPosition: buttonPos. - buttonPos := (buttonPos x + buttonDelta) @ 2. - ]. - ]. -! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 6/19/2017 15:57:49' prior: 16926215! -boxExtent - "answer the extent to use in all the buttons. - - the label height is used to be proportional to the fonts preferences" - | e | - Theme current minimalWindows ifTrue: [^`0@0`]. - e _ Preferences windowTitleFont height. - ^e@e! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:12:42' prior: 16926276! - initialize - "Initialize a system window. Add label, stripes, etc., if desired" - - super initialize. - labelString ifNil: [ labelString _ 'Untitled Window']. - - self initializeLabelArea. - extent _ `300 @ 200`. - - adjusters _ Dictionary new. - adjusters at: #topAdjuster put: WindowEdgeAdjustingMorph forTop. - adjusters at: #bottomAdjuster put: WindowEdgeAdjustingMorph forBottom. - adjusters at: #leftAdjuster put: WindowEdgeAdjustingMorph forLeft. - adjusters at: #rightAdjuster put: WindowEdgeAdjustingMorph forRight. - adjusters at: #topLeftAdjuster put: WindowEdgeAdjustingMorph forTopLeft. - adjusters at: #bottomLeftAdjuster put: WindowEdgeAdjustingMorph forBottomLeft. - adjusters at: #topRightAdjuster put: WindowEdgeAdjustingMorph forTopRight. - adjusters at: #bottomRightAdjuster put: WindowEdgeAdjustingMorph forBottomRight. - adjusters do: [ :m | - self addMorphFront: m ]. - - "by default" - self beColumn! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:12:52' prior: 16926307! - initializeLabelArea - "Initialize the label area (titlebar) for the window." - - | spacing | - spacing _ self boxExtent x + 2. - self addMorph: self createCloseBox position: `2@2`. - self addMorph: self createCollapseBox position: spacing+2@2. - self addMorph: self createExpandBox position: spacing*2+2@2. - self addMorph: self createMenuBox position: spacing*3+2@2! ! -!SystemWindow methodsFor: 'layout' stamp: 'jmv 6/19/2017 15:58:05' prior: 16926374! - layoutSubmorphs - "Compute a new layout of submorphs based on the given layout bounds." - - | h thickness w cornerExtent wh ww pos | - thickness _ 4. - cornerExtent _ 20. - ww _ extent x. - wh _ extent y. - w _ ww - cornerExtent - cornerExtent. - h _ wh - cornerExtent - cornerExtent. - (adjusters at: #topAdjuster) morphPosition: cornerExtent@0 extent: w@thickness. - (adjusters at: #bottomAdjuster) morphPosition: cornerExtent@(wh-thickness) extent: w@thickness. - (adjusters at: #leftAdjuster) morphPosition: 0@cornerExtent extent: thickness@h. - (adjusters at: #rightAdjuster) morphPosition: ww-thickness@cornerExtent extent: thickness@h. - (adjusters at: #topLeftAdjuster) morphPosition: `0@0` extent: cornerExtent@cornerExtent. - (adjusters at: #bottomLeftAdjuster) morphPosition: 0@(wh-cornerExtent) extent: cornerExtent@cornerExtent. - (adjusters at: #topRightAdjuster) morphPosition: ww-cornerExtent@0 extent: cornerExtent@cornerExtent. - (adjusters at: #bottomRightAdjuster) morphPosition: ww@wh-cornerExtent extent: cornerExtent@cornerExtent. - - layoutMorph ifNotNil: [ - pos _ borderWidth @ (borderWidth + self labelHeight). - layoutMorph - morphPosition: pos - extent: extent - pos - borderWidth ]. - - layoutNeeded _ false! ! -!SystemWindow methodsFor: 'resize/collapse' stamp: 'jmv 6/19/2017 16:13:13' prior: 50333187! - resize - | resizeMorph | - resizeMorph _ ResizeMorph new morphExtent: `200@150`. - resizeMorph action: [self resize: (resizeMorph selectionRectangle: Display extent)]. - resizeMorph morphPosition: self world activeHand morphPosition. - resizeMorph openInWorld - ! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'jmv 6/19/2017 16:01:26' prior: 16811550! - initialExtent - - ^`540@400`! ! -!ChangeSorterWindow methodsFor: 'GUI building' stamp: 'jmv 6/19/2017 16:01:18' prior: 16800076! - initialExtent - ^`540@300`! ! -!PreDebugWindow methodsFor: 'GUI building' stamp: 'jmv 6/19/2017 16:01:38' prior: 16892600! - initialExtent - ^ `640 @ 320`! ! -!InspectorWindow methodsFor: 'GUI building' stamp: 'jmv 6/19/2017 16:01:32' prior: 50336307! - initialExtent - - ^`600@325`! ! -!ObjectExplorerWindow methodsFor: 'GUI building' stamp: 'jmv 6/19/2017 16:01:35' prior: 16883318! -initialExtent - - ^`300@500`! ! -!TestRunnerWindow methodsFor: 'GUI building' stamp: 'jmv 6/19/2017 16:13:18' prior: 16928555! - buildMorphicWindow - - self layoutMorph - addMorph: self buildUpperControls proportionalHeight: 0.25; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.75. - self setLabel: 'SUnit Test Runner'. - self refreshWindow. - self morphExtent: `460 @ 400`! ! -!ScrollBar methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:57:09' prior: 16904515! - drawOn: aCanvas - - aCanvas - fillRectangle: (`0@0` extent: extent) - color: (color alphaMixed: 0.3 with: Theme current scrollbarColor) - borderWidth: borderWidth - borderStyleSymbol: #simple - baseColorForBorder: borderColor! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 6/19/2017 16:07:49' prior: 16866514! - addTitle: aString - "Add a title line at the top of this menu Make aString its initial - contents. - If aSelector is not nil, then periodically obtain fresh values for its - contents by sending aSelector to aTarget.." - - | s pp w | - - titleMorph _ RectangleLikeMorph new. - titleMorph color: Theme current menuTitleBar. - pp _ `8@2`. - aString asString linesDo: [ :line | - s _ StringMorph new - contents: line; - font: Preferences standardMenuFont bold. - titleMorph addMorphBack: s position: pp. - pp _ pp + (0@(s morphHeight+2)) ]. - w _ titleMorph submorphs inject: 0 into: [ :prev :each | - prev max: each morphWidth ]. - titleMorph morphExtent: (w + 16) @ (pp y). - self addMorphFront: titleMorph. - - (self hasProperty: #needsStayUpIcons) ifTrue: [ self addStayUpIcons ]! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 6/19/2017 16:37:20' prior: 50341056! - popUpAdjacentTo: rightOrLeftPointInWorld from: sourceItem - "Present this menu at the given point under control of the given hand. - Used mostly for submenus." - - | delta tryToPlace selectedOffset | - popUpOwner _ sourceItem. - selectedOffset _ (selectedItem ifNil: [ self items first ]) morphPosition. - sourceItem world addMorphFront: self. - - tryToPlace _ [ :where :mustFit | - self morphPosition: where - selectedOffset. - delta _ self morphFullBoundsInWorld - amountToTranslateWithin: sourceItem world morphBoundsInWorld. - (delta x = 0 | mustFit) ifTrue: [ - delta = `0@0` ifFalse: [ self morphPosition: self morphPosition + delta ]. - ^ self]]. - tryToPlace - value: rightOrLeftPointInWorld first value: false; - value: rightOrLeftPointInWorld last - (extent x @ 0) value: false; - value: rightOrLeftPointInWorld first value: true! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 6/19/2017 16:08:25' prior: 50339206! - popUpAt: aPoint forHand: hand allowKeyboard: aBoolean - "Present this menu at the given point under control of the given hand." - - | evt | - self items isEmpty ifTrue: [^self]. - Theme current decorateMenu: self. - (self submorphs select: [ :m | m is: #UpdatingMenuItemMorph ]) - do: [ :m | m updateContents]. - self runningWorld addMorphFront: self position: aPoint - `2 @ 8`. - self fitInWorld. - "Acquire focus for valid pop up behavior" - hand newMouseFocus: self. - aBoolean ifTrue: [ hand newKeyboardFocus: self ]. - evt _ hand lastMouseEvent. - (evt isKeyboard or: [ evt isMouse and: [ evt anyButtonPressed not ]]) - ifTrue: [ - "Select first item if button not down" - self moveSelectionDown: 1 event: evt ]! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 6/19/2017 16:08:29' prior: 50339231! - popUpAt: aPoint forHand: hand in: aWorld allowKeyboard: aBoolean - "Present this menu at the given point under control of the given hand." - - self items isEmpty ifTrue: [ ^self ]. - Theme current decorateMenu: self. - (self submorphs select: [ :m | m is: #UpdatingMenuItemMorph]) - do: [ :m | m updateContents]. - aWorld addMorphFront: self position: aPoint - `2 @ 8`. - self fitInWorld. - "Acquire focus for valid pop up behavior" - hand newMouseFocus: self. - aBoolean ifTrue: [ hand newKeyboardFocus: self ]! ! -!MenuMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:08:18' prior: 50341132! - initialize - super initialize. - extent _ `40@10`. - defaultTarget _ nil. - selectedItem _ nil. - stayUp _ false. - popUpOwner _ nil! ! -!MenuMorph methodsFor: 'keyboard control' stamp: 'jmv 6/19/2017 16:08:04' prior: 50359767! - displayFiltered: evt - | matchStr allItems isMatch matches feedbackMorph | - matchStr _ self valueOfProperty: #matchString. - allItems _ self submorphs select: [ :m | - m is: #MenuItemMorph ]. - matches _ allItems select: [ :m | - isMatch _ matchStr isEmpty or: [ - m contents - includesSubstring: matchStr - caseSensitive: false ]. - m isEnabled: isMatch. - isMatch ]. - feedbackMorph _ self valueOfProperty: #feedbackMorph. - feedbackMorph ifNil: [ - feedbackMorph _ StringMorph new color: Color veryDarkGray. - self addMorphBack: feedbackMorph lock position: `0@ -20`. - self - setProperty: #feedbackMorph - toValue: feedbackMorph ]. - feedbackMorph contents: '<' , matchStr , '>'. - matchStr isEmpty ifTrue: [ - feedbackMorph delete. - self removeProperty: #feedbackMorph ]. - matches notEmpty ifTrue: [ - self selectItem: matches first ]! ! -!MenuMorph methodsFor: 'private' stamp: 'jmv 6/19/2017 16:07:56' prior: 16867223! - adjustSubmorphsLayout - "Enlarge the width of submorphs as needed - so all of them are have the same width, and no less than #minWidth. - Also adjust their vertical position. - Finally, set our own extent." - - | w p h | - - submorphs isEmpty ifTrue: [ ^self ]. - w _ submorphs inject: 0 into: [ :prev :each | - prev max: each minItemWidth]. - - w _ w + 1. - p _ `5 @ 5`. - submorphs do: [ :m | - h _ m morphHeight. - m morphPosition: p extent: w@h. - p _ p + (0@(h + 1)) ]. - - self morphExtent: w+4 @ p y + 5! ! -!MenuMorph methodsFor: 'private' stamp: 'jmv 6/19/2017 16:08:14' prior: 16867241! - fitInWorld - "Note: items may not be laid out yet (I found them all to be at 0@0), - so we have to add up heights of items above the selected item." - - | delta | - "If it doesn't fit, show it to the left, not to the right of the hand." - self morphBoundsInWorld right > owner world morphBoundsInWorld right - ifTrue: [ - self morphPosition: ((self morphPosition x + 10 - extent x) @ self morphPosition y) ]. - - "Make sure that the menu fits in the world." - delta _ self morphBoundsInWorld amountToTranslateWithin: - (owner world morphBoundsInWorld withHeight: - ((owner world morphExtentInWorld y) max: (self morphPosition y) + 1)). - delta = `0 @ 0` ifFalse: [ self morphPosition: self morphPosition + delta ]! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:43:48' prior: 16781484! - downButtonPosition - ^`0@0` + (extent - ScrollBar scrollbarThickness)! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:43:54' prior: 50359797! - drawOn: aCanvas - | rectangle w y0 h y1 y2 scrollbarThickness | - aCanvas frameAndFillRectangle: (`0@0` extent: extent) fillColor: self color borderWidth: borderWidth borderColor: borderColor. - y0 _ 1. - w _ extent x-2. - scrollbarThickness _ ScrollBar scrollbarThickness. - completer entryCount > self class itemsPerPage ifTrue: [ - w _ w - scrollbarThickness. - aCanvas - frameRectangle: (extent x - scrollbarThickness@0 - extent: scrollbarThickness @ extent y) - borderWidth: 1 - color: borderColor. - aCanvas - image: (BitBltCanvas arrowOfDirection: #up size: scrollbarThickness) - at: self upButtonPosition. - aCanvas - image: (BitBltCanvas arrowOfDirection: #down size: scrollbarThickness) - at: self downButtonPosition. - h _ extent y - (2 * scrollbarThickness). - y1 _ (1.0 * self firstVisible-1 / completer entryCount * h) ceiling + y0 + scrollbarThickness-1. - y2 _ (1.0 * self lastVisible / completer entryCount * h) floor + y0 + scrollbarThickness -1. - aCanvas - fillRectangle: (extent x - scrollbarThickness+2@y1 corner: extent x-2 @ y2) - color: Color veryLightGray ]. - self firstVisible - to: self lastVisible - do: [ :index | - rectangle _ 1@y0 extent: w@self class itemHeight. - index = self selected - ifTrue: [ - aCanvas fillRectangle: rectangle color: (Theme current listHighlightFocused: true) ]. - aCanvas - drawString: (completer entries at: index) asString - at: rectangle topLeft - font: self class listFont - color: Theme current text. - y0 _ y0 + self itemHeight ]! ! -!AutoCompleterMorph class methodsFor: 'instance creation' stamp: 'jmv 6/19/2017 16:00:57' prior: 16781686! - initializedInstance - | completer m | - completer _ SmalltalkCompleter withModel: (TextModel withText: 'Small'). - completer - instVarNamed: 'position' - put: 5. - completer computeEntries. - m _ AutoCompleterMorph - completer: completer - position: `200 @ 200`. - completer instVarNamed: 'menuMorph' put: m. - ^m! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:52:36' prior: 50359852! - drawOn: aCanvas - "Draw the hand itself (i.e., the cursor)." - "This method is only called when we are carrying morphs around..." - aCanvas - stencil: Cursor move - at: `0@0` - color: Color black! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:52:45' prior: 16851711! - savePatchFrom: aCanvas appendDamageTo: aStream - "Save the part of the given canvas under this hand as a Form and return its bounding rectangle." - - "Details: The previously used patch Form is recycled when possible to reduce the burden on storage management." - - | fullBounds | - fullBounds _ self morphFullBoundsInWorld. - fullBounds ifNil: [ ^self ]. - - fullBounds _ fullBounds intersect: (`0@0` extent: aCanvas extent). - (savedPatch isNil or: [savedPatch extent ~= fullBounds extent]) - ifTrue: [ - "allocate new patch form if needed" - savedPatch _ Form extent: fullBounds extent depth: aCanvas depth ]. - aCanvas - contentsOfArea: fullBounds - into: savedPatch. - savedPatch offset: fullBounds topLeft. - prevFullBounds - ifNil: [ aStream nextPut: fullBounds ] - ifNotNil: [ aStream nextPut: (fullBounds merge: prevFullBounds)]. - prevFullBounds _ fullBounds! ! -!HandMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 15:52:41' prior: 16852160! - initForEvents - mouseOverHandler _ nil. - lastMouseEvent _ MouseEvent new setType: #mouseMove position: `0@0` buttons: 0 hand: self. - lastMouseEventTime _ Time localMillisecondClock. - lastEventBuffer _ {1. 0. 0. 0. 0. 0. nil. nil}. - self dontWaitForMoreClicks! ! -!ImageMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:52:49' prior: 16854128! - drawOn: aCanvas - - aCanvas image: image at: `0@0`! ! -!StringMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:57:40' prior: 50343923! - drawOn: aCanvas - aCanvas - drawString: (contents ifNil: [ '' ]) - at: `0@0` - font: self fontToUse - color: color - ! ! -!StringMorph methodsFor: 'geometry' stamp: 'jmv 6/19/2017 15:57:44' prior: 16918155! - fitContents - "Measures contents later at #minimumExtent" - self morphExtent: `0@0`! ! -!IndentingListItemMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:53:00' prior: 16854676! - drawOn: aCanvas - - | tRect colorToUse sLeft aForm centeringOffset | - isHighlighted ifTrue: [ - aCanvas - fillRectangle: (`0@0` extent: extent) - color: (Theme current - listHighlightFocused: owner owner hasKeyboardFocus) duller ]. - isSelected ifTrue: [ - aCanvas - fillRectangle: (`0@0` extent: extent) - color: (Theme current - listHighlightFocused: owner owner hasKeyboardFocus) ]. - - tRect _ self toggleRectangle. - aForm _ isExpanded - ifTrue: [ container expandedForm ] - ifFalse: [ container notExpandedForm ]. - centeringOffset _ ((tRect height - aForm extent y) / 2.0) rounded. - - complexContents hasContents ifTrue: [ - aCanvas - image: aForm - at: (tRect topLeft translatedBy: 0 @ centeringOffset) ]. - - icon isNil - ifFalse: [ - aCanvas - image: icon - at: (tRect topLeft translatedBy: icon width @ centeringOffset). - sLeft _ indentLevel * 12 + 16 + (icon width + 2). - ] - ifTrue: [ - sLeft _ indentLevel * 12 + 16. - ]. - colorToUse _ complexContents preferredColor ifNil: [ color ]. - - aCanvas - drawString: contents asString - at: sLeft@0 - font: self fontToUse - color: colorToUse! ! -!MenuItemMorph methodsFor: 'accessing' stamp: 'jmv 6/19/2017 16:06:04' prior: 16865800! - contents: aString withMarkers: aBool inverse: inverse - "Set the menu item entry. If aBool is true, parse aString for embedded markers." - - | markerIndex marker | - self contentString: nil. "get rid of old" - aBool ifFalse: [^super contents: aString]. - self removeAllMorphs. "get rid of old markers if updating" - self hasIcon ifTrue: [ self icon: nil ]. - (aString notEmpty and: [aString first = $<]) - ifFalse: [^super contents: aString]. - markerIndex := aString indexOf: $>. - markerIndex = 0 ifTrue: [^super contents: aString]. - marker := (aString copyFrom: 1 to: markerIndex) asLowercase. - (#('' '' '' '') includes: marker) - ifFalse: [^super contents: aString]. - self contentString: aString. "remember actual string" - marker := (marker = '' or: [marker = '']) ~= inverse - ifTrue: [self onImage] - ifFalse: [self offImage]. - super contents: (aString copyFrom: markerIndex + 1 to: aString size). - "And set the marker" - marker := ImageMorph new image: marker. - self addMorphFront: marker position: `0@2`! ! -!MenuItemMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:53:42' prior: 16865892! - drawOn: aCanvas - | stringColor leftEdge | - - stringColor _ color. - isSelected & isEnabled - ifTrue: [ - aCanvas fillRectangle: (`0@0` extent: extent) color: Theme current menuHighlight]. - leftEdge _ 0. - - self hasMarker ifTrue: [ - leftEdge _ leftEdge + submorphs first morphWidth + 8 ]. - - self hasIcon - ifTrue: [| iconForm | - iconForm _ isEnabled ifTrue: [ self icon ] ifFalse: [ self icon asGrayScaleAndTransparent ]. - aCanvas image: iconForm at: leftEdge+1 @ (extent y - iconForm height // 2). - leftEdge _ leftEdge + iconForm width + self iconSeparation]. - - aCanvas - drawString: contents - at: leftEdge @ 1 - font: self fontToUse - color: stringColor. - subMenu ifNotNil: [ - aCanvas - image: self class subMenuMarker - at: extent x - 8 @ (extent y - self class subMenuMarker height // 2) ]! ! -!MenuItemMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:06:09' prior: 16866103! - initialize - "initialize the state of the receiver" - super initialize. - "" - extent _ `10@10`. - contents _ ''. - isEnabled _ true. - subMenu _ nil. - isSelected _ false. - target _ nil. - selector _ nil. - arguments _ nil. - font _ Preferences standardMenuFont! ! -!MenuItemMorph methodsFor: 'layout' stamp: 'jmv 6/19/2017 16:06:26' prior: 16866117! - measureContents - | e | - e _ super measureContents. - ^e y > 12 - ifTrue: [e+`2@2`] - ifFalse: [e+`2@1`]! ! -!MenuItemMorph methodsFor: 'selecting' stamp: 'jmv 6/19/2017 15:53:59' prior: 50341147! - select - self isSelected: true. - owner activeSubmenu: subMenu. - subMenu ifNotNil: [ - subMenu delete. - subMenu - popUpAdjacentTo: (Array with: self morphBoundsInWorld topRight + `10@0` - with: self morphBoundsInWorld topLeft) - from: self. - subMenu selectItem: nil ]! ! -!MenuItemMorph class methodsFor: 'cached state access' stamp: 'jmv 6/19/2017 16:06:33' prior: 16866204! - subMenuMarker - - | f | - SubMenuMarker ifNotNil: [ ^SubMenuMarker ]. - f _ Form - extent: `5@9` - fromArray: #(2147483648 3221225472 3758096384 4026531840 4160749568 4026531840 3758096384 3221225472 2147483648) - offset: `0@0`. - SubMenuMarker _ ColorForm mappingWhiteToTransparentFrom: f. - ^SubMenuMarker! ! -!LayoutAdjustingMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:53:34' prior: 16862884! - drawOn: aCanvas - - aCanvas - fillRectangle: (`0@0` extent: extent) - color: color! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 6/19/2017 15:53:38' prior: 16863315! - layoutBounds - "Return the bounds for laying out children of the receiver" - - ^`0@0` extent: extent! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 6/19/2017 16:05:36' prior: 16863335! - layoutSubmorphsHorizontallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - | xSep ySep usableWidth sumOfFixed normalizationFactor availableForPropWidth - fractionalWidths integerWidths theLeft usableHeight boundsTop boundsRight theTop minWidth submorphsToLayout - nextMorph ht wd ls theRight boundsBottom theBottom alternativeWidths count diff i | - - boundsForLayout extent > `2@2` "self minimumExtent" - ifFalse: [ ^self ]. "Too small. Don't bother!!" - - submorphsToLayout := self submorphsToLayout. - xSep := self xSeparation. - ySep := self ySeparation. - usableWidth := boundsForLayout width - ((submorphsToLayout size + 1) * xSep). - sumOfFixed := submorphsToLayout sum: [ :m | m layoutSpec fixedWidth ]. - availableForPropWidth := usableWidth - sumOfFixed max: 0. - normalizationFactor := self proportionalWidthNormalizationFactor. - availableForPropWidth := availableForPropWidth * normalizationFactor. - - fractionalWidths := submorphsToLayout collect: [ :m | m layoutSpec widthFor: availableForPropWidth ]. - "Compute integer widths, mostly rounding but with occasional #floor or #ceiling as needed to keep sum" - integerWidths _ fractionalWidths collect: [ :w | w rounded ]. - diff _ integerWidths sum - fractionalWidths sum rounded. - alternativeWidths _ diff > 0 ifTrue: [ fractionalWidths collect: [ :w | w floor ]] ifFalse: [ fractionalWidths collect: [ :w | w ceiling ]]. - count _ diff abs. - i _ 1. - [ count > 0] whileTrue: [ - (integerWidths at: i) = (alternativeWidths at: i) ifFalse: [ - integerWidths at: i put: (alternativeWidths at: i). - count _ count -1 ]. - i _ i + 1 ]. - minWidth := integerWidths sum. - theLeft := ((usableWidth - minWidth) * (padding ifNil: [0]) max: 0) + boundsForLayout left + xSep. - usableHeight := boundsForLayout height - (ySep * 2) max: 0. - boundsTop := boundsForLayout top + ySep. - boundsRight := boundsForLayout right - xSep. - boundsBottom := boundsForLayout bottom - ySep. - - submorphsToLayout size to: 1 by: -1 do: [ :index | - nextMorph := submorphsToLayout at: index. - "major direction" - wd := integerWidths at: index. - "minor direction" - ls := nextMorph layoutSpec. - ht := (ls heightFor: usableHeight) min: usableHeight. - theTop := ((usableHeight - ht) * ls minorDirectionPadding) floor + boundsTop. - theBottom := (theTop + ht) ceiling min: boundsBottom. - theRight := (theLeft + (wd min: minWidth)) "ceiling "min: boundsRight. - "Set bounds and adjust major direction for next step" - self flag: #jmvVer2. "should extent be set in m's coordinate system? what if its scale is not 1?" - ls usesMorphExtent - ifTrue: [ - nextMorph morphPosition: theLeft floor @ theTop floor ] - ifFalse: [ - nextMorph morphPosition: theLeft floor @ theTop floor extent: theRight - theLeft @ (theBottom - theTop) ]. - theLeft := theRight + xSep - ]! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 6/19/2017 16:05:46' prior: 16863426! - layoutSubmorphsVerticallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - | xSep ySep usableHeight sumOfFixed normalizationFactor availableForPropHeight - fractionalHeights integerHeights theTop usableWidth boundsLeft boundsBottom theLeft minHeight submorphsToLayout - nextMorph ht wd ls theBottom boundsRight theRight alternativeHeights count diff i | - - boundsForLayout extent > `2@2` "self minimumExtent" - ifFalse: [ ^self ]. "Too small. Don't bother!!" - - submorphsToLayout := self submorphsToLayout. - xSep := self xSeparation. - ySep := self ySeparation. - usableHeight := boundsForLayout height - ((submorphsToLayout size + 1) * ySep). - sumOfFixed := submorphsToLayout sum: [ :m | m layoutSpec fixedHeight ]. - availableForPropHeight := usableHeight - sumOfFixed max: 0. - normalizationFactor := self proportionalHeightNormalizationFactor. - availableForPropHeight := availableForPropHeight * normalizationFactor. - - fractionalHeights := submorphsToLayout collect: [ :m | m layoutSpec heightFor: availableForPropHeight ]. - "Compute integer widths, mostly rounding but with occasional #floor or #ceiling as needed to keep sum" - integerHeights _ fractionalHeights collect: [ :w | w rounded ]. - diff _ integerHeights sum - fractionalHeights sum rounded. - alternativeHeights _ diff > 0 ifTrue: [ fractionalHeights collect: [ :w | w floor ]] ifFalse: [ fractionalHeights collect: [ :w | w ceiling ]]. - count _ diff abs. - i _ 1. - [ count > 0] whileTrue: [ - (integerHeights at: i) = (alternativeHeights at: i) ifFalse: [ - integerHeights at: i put: (alternativeHeights at: i). - count _ count -1 ]. - i _ i + 1 ]. - minHeight := integerHeights sum. - theTop := ((usableHeight - minHeight) * (padding ifNil: [0]) max: 0) + boundsForLayout top + ySep. - usableWidth := boundsForLayout width - (xSep * 2) max: 0. - boundsLeft := boundsForLayout left + xSep. - boundsBottom := boundsForLayout bottom - ySep. - boundsRight := boundsForLayout right - xSep. - - submorphsToLayout size to: 1 by: -1 do: [ :index | - nextMorph := submorphsToLayout at: index. - "major direction" - ht := integerHeights at: index. - "minor direction" - ls := nextMorph layoutSpec. - wd := (ls widthFor: usableWidth) min: usableWidth. - theLeft := ((usableWidth - wd) * ls minorDirectionPadding) floor + boundsLeft. - theRight := (theLeft + wd) ceiling min: boundsRight. - theBottom := (theTop + (ht min: minHeight)) "ceiling" min: boundsBottom. - "Set bounds and adjust major direction for next step" - self flag: #jmvVer2. "should extent be set in m's coordinate system? what if its scale is not 1?" - ls usesMorphExtent - ifTrue: [ - nextMorph morphPosition: theLeft floor @ theTop floor ] - ifFalse: [ - nextMorph morphPosition: theLeft floor @ theTop floor extent: theRight - theLeft @ (theBottom - theTop) ]. - theTop := theBottom + ySep - ]! ! -!ProgressMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:10:33' prior: 16896264! - initialize - super initialize. - self separation: 0. - labelMorph _ StringMorph contents: '' font: AbstractFont default. - subLabelMorph _ StringMorph contents: '' font: AbstractFont default. - progress _ ProgressBarMorph new. - progress morphExtent: `200 @ 15`. - self addMorphFront: labelMorph. - self addMorphFront: subLabelMorph. - self addMorph: progress fixedHeight: 15.! ! -!HaloHandleMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:52:21' prior: 16850527! - drawOn: aCanvas - - aCanvas - image: (self class circleForm: extent) - multipliedBy: color - at: `0@0`! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 6/19/2017 15:52:25' prior: 50360442! - addHandle: handleSpec - "Add a handle within the halo box as per the haloSpec, and set it up to respond to the given event by sending the given selector to the given recipient. Return the handle." - - | handle aPoint colorToUse form icon | - aPoint _ self - positionIn: haloBox - horizontalPlacement: handleSpec horizontalPlacement - verticalPlacement: handleSpec verticalPlacement. - colorToUse _ Color colorFrom: handleSpec color. - handle _ HaloHandleMorph new color: colorToUse. - self addMorph: handle. - handle morphBoundsInWorld: (Rectangle center: aPoint extent: self class handleSize asPoint). - handleSpec iconSymbol ifNotNil: [ :iconName | - form _ self class icons at: iconName ifAbsent: [self class perform: iconName]. - form ifNotNil: [ - icon _ ImageMorph new - image: form; - color: colorToUse makeForegroundColor; - lock. - handle addMorphFront: icon position: `0@0` ]]. - handle mouseUpSelector: #endInteraction. - handle setBalloonText: handleSpec hoverHelp. - ^handle! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 6/19/2017 16:04:44' prior: 16850943! - basicBox - | aBox minSide anExtent w | - minSide _ 4 * self class handleSize. - anExtent _ ((extent x + self class handleSize + 8) max: minSide) @ - ((extent y + self class handleSize + 8) max: minSide). - aBox _ Rectangle center: self morphBoundsInWorld center extent: anExtent. - w _ self world ifNil: [ target world ]. - ^ w - ifNil: - [ aBox ] - ifNotNil: - [ aBox intersect: (w viewBox insetBy: `8@8`) ]! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 6/19/2017 15:52:32' prior: 16851149! - startGrow: evt with: growHandle - "Initialize resizing of my target. Launch a command representing it, to support Undo" - - | botRt | - evt hand obtainHalo: self. "Make sure the event's hand correlates with the receiver" - self removeAllHandlesBut: growHandle. "remove all other handles" - botRt _ target morphPositionInWorld + target morphExtentInWorld. - positionOffset _ (self world viewBox containsPoint: botRt) - ifTrue: [evt eventPosition - botRt] - ifFalse: [`0@0`]! ! -!InnerHierarchicalListMorph methodsFor: 'geometry' stamp: 'jmv 6/19/2017 16:36:31' prior: 16854885! - itemFromPoint: aPoint - "Return the list element (morph) at the given point or nil if outside" - | ptY last | - self hasSubmorphs ifFalse: [ ^nil ]. - (aPoint > `0@0` and: [ aPoint < extent ]) ifFalse: [ ^nil ]. - ptY _ aPoint y. - "note: following assumes that submorphs are vertical, non-overlapping, and ordered" - self firstSubmorph morphPosition y > ptY ifTrue: [ ^nil ]. - last _ self lastSubmorph. - last morphPosition y + last morphHeight < ptY ifTrue: [ ^nil ]. - "now use binary search" - ^self - findSubmorphBinary: [ :m | - (m morphPosition y <= ptY and: [ m morphPosition y + m morphHeight >= ptY ]) - ifTrue: [ 0 ] "found" - ifFalse: [ m morphPosition y + (m morphHeight // 2) > ptY ifTrue: [-1] ifFalse: [1]]]! ! -!InnerListMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:53:10' prior: 16855151! - drawBackgroundForMulti: row on: aCanvas - | selectionDrawBounds c | - "shade the background darker, if this row is selected" - selectionDrawBounds _ self drawBoundsForRow: row. - selectionDrawBounds _ selectionDrawBounds intersect: (`0@0` extent: extent). - c _ (selectedRow notNil and: [ row = selectedRow]) - ifTrue: [ Theme current listHighlightFocused: owner hasKeyboardFocus ] - ifFalse: [ Theme current listMultiHighlightFocused: owner hasKeyboardFocus ]. - aCanvas fillRectangle: selectionDrawBounds color: c! ! -!InnerListMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:53:15' prior: 16855170! - drawHighlightOn: aCanvas -"Ademas, poner el mouse pointer de relojito si tarda... Detectarlo automaticamente, etc. Aunque no estoy seguro de como hacerlo... quizas colgar un cachito de codigo en un proceso de mayor prioridad, onda 'si pasa 1 segundo, y todavia no te resetee este flag, entonces pone el relojito'" - | selectionDrawBounds | - highlightedRow ifNil: [ ^self ]. - highlightedRow = 0 ifTrue: [ ^self ]. - selectionDrawBounds _ self drawBoundsForRow: highlightedRow. - selectionDrawBounds _ selectionDrawBounds intersect: (`0@0` extent: extent). - aCanvas - fillRectangle: selectionDrawBounds - color: (Theme current listHighlightFocused: owner hasKeyboardFocus) duller! ! -!InnerListMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:53:20' prior: 16855209! - drawSelectionOn: aCanvas - | selectionDrawBounds | - selectedRow ifNil: [ ^self ]. - selectedRow = 0 ifTrue: [ ^self ]. - selectionDrawBounds _ self drawBoundsForRow: selectedRow. - selectionDrawBounds _ selectionDrawBounds intersect: (`0@0` extent: extent). - aCanvas - fillRectangle: selectionDrawBounds - color: (Theme current listHighlightFocused: owner hasKeyboardFocus)! ! -!InnerTextMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:53:24' prior: 16855570! - drawOn: aCanvas - "Draw the receiver on a canvas" - - false ifTrue: [ self debugDrawLineRectsOn: aCanvas ]. "show line rects for debugging" - - aCanvas - textComposition: self textComposition - bounds: (`0@0` extent: extent) - color: color - selectionColor: (Theme current textHighlightFocused: self hasKeyboardFocus)! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'jmv 6/19/2017 16:15:44' prior: 50360559! - initialize - super initialize. - extent _ `400@300`. - color _ Color white. - grid _ `8@6`. - gridLineWidth _ 2. - gridColor _ Color black. - selectionColor _ Color red! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:03:19' prior: 16844103! - createAcceptButton - "create the [accept] button" - | result | - result _ PluggableButtonMorph new - model: self; - color: Theme current acceptButton; - label: 'Accept'; - action: #acceptClicked. - result morphExtent: `6@2` * self sizeUnit. - self addMorph: result position: `2@7.5` * self sizeUnit // 1. - ^ result! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:03:31' prior: 16844116! -createCancelButton - "create the [cancel] button" - | result | - result _ PluggableButtonMorph new - model: self; - color: Theme current cancelButton; - label: 'Cancel'; - action: #cancelClicked. - result morphExtent: `6@2` * self sizeUnit. - self addMorph: result position: `12@7.5` * self sizeUnit // 1. - ^ result! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:03:37' prior: 16844129! - createQueryTextMorph: queryString - "create the queryTextMorph" - | result | - result _ StringMorph new contents: queryString. - result lock. - result morphExtent: `24@2` * self sizeUnit. - self addMorph: result position: `2@0.5` * self sizeUnit // 1. - ^ result! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:03:44' prior: 16844140! - createTextPaneAcceptOnCR: acceptBoolean - "create the textPane" - | result | - - self flag: #todo. "Integrate this method with the Theme system. --cbr" - - result _ TextModelMorph - textProvider: self - textGetter: #response - textSetter: #response: - selectionGetter: #selectionInterval. - result hasUnacceptedEdits: true. - result acceptOnCR: acceptBoolean. - result morphExtent: `18@5` * self sizeUnit. - self addMorph: result position: `1@2` * self sizeUnit. - ^ result! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:03:48' prior: 16844169! - initialize - - super initialize. - extent _ `20@10` * self sizeUnit. - responseUponCancel _ ''! ! -!FillInTheBlankMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:48:53' prior: 16844226! - drawOn: aCanvas - - Theme current roundWindowCorners - ifTrue: [ - aCanvas - roundRect: (`0@0` extent: extent) - color: color - radius: Theme current roundedWindowRadius ] - ifFalse: [ super drawOn: aCanvas ]! ! -!TranscriptMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:58:30' prior: 16938600! - drawOn: aCanvas - Transcript - showOnDisplay: true; - displayOn: form in: (`0@0` extent: extent). - aCanvas image: form at: `0@0`. - Transcript - bounds: self morphBoundsInWorld; - showOnDisplay: doImmediateUpdates. - self updateWorkspace! ! -!MenuLineMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:54:11' prior: 16866232! - drawOn: aCanvas - | baseColor | - baseColor _ owner color. - aCanvas - fillRectangle: (`0@0` corner: extent x @ (extent y / 2)) - color: baseColor twiceDarker. - - aCanvas - fillRectangle: (0 @ (extent y / 2) corner: extent) - color: baseColor twiceLighter! ! -!MenuLineMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:06:38' prior: 16866243! -initialize - super initialize. - extent _ `50 @ 2`! ! -!MenuLineMorph methodsFor: 'geometry' stamp: 'jmv 6/19/2017 16:07:43' prior: 16866250! - minimumExtent - - ^`10@2`! ! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 6/19/2017 15:59:45' prior: 50339587! - tryDeferredUpdatingAndSetCanvas - "If this platform supports deferred updates, then make my canvas be the Display (or a rectangular portion of it), set the Display to deferred update mode, and answer true. Otherwise, set a non-Disply canvas and answer false.." - | properDisplay | - - "As this is the only sender of #deferUpdates: , this could be done in Morphic or image startup, and never efterwards..." - (Display deferUpdates: true) ifNil: [ - "deferred updates not supported by the VM, do them in the image!!" - self ensureNonDisplayCanvas. - ^ false]. - - "if no canvas, or canvas was offscreen, from a platform that didnt support defers, then fix it" - properDisplay _ canvas notNil and: [canvas drawsOnDisplay]. - properDisplay ifFalse: [ - world morphPosition: `0@0` extent: Display extent. - self setCanvas: Display getCanvas. - ]. - ^ true! ! -!MorphicEvent methodsFor: 'dispatching' stamp: 'jmv 6/19/2017 15:54:47' prior: 16877833! - startDispatchFrom: aHand - "double dispatch the event dispatch" - "An event of an unknown type was sent. What shall we do?!!" - - Smalltalk beep. - self printString displayAt: `0@0`. - self wasHandled: true! ! -!MorphicCanvas methodsFor: 'accessing' stamp: 'jmv 6/19/2017 15:54:34' prior: 16877393! - newClipRect: aRectangleOrNil - "aRectangle is in world coordinates. - But ivar clipRect is relative to the form, - For example, if we had previously been built like - aCanvas on: someForm over: (100@100 extent 200@100) - then our origin would be -100 @ -100. - Then, a clipRect argument like (120@120 extent: 40@30) would mean affecting - only (20@20 extent: 40@30) in our form" - - self setClipRect: (aRectangleOrNil - ifNil: [ `0@0` corner: form extent ] - ifNotNil: [ aRectangleOrNil translatedBy: self canvasOrigin ])! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 6/19/2017 16:08:51' prior: 50360750! - drawCurrentAsError - "The morph (or one of its submorphs) had an error in its drawing method." - | r w | - r _ currentMorph morphLocalBounds. - w _ r extent > `50@50` - ifTrue: [ 6 ] - ifFalse: [ 2 ]. - self - frameAndFillRectangle: r - fillColor: Color red - borderWidth: w - borderColor: Color yellow. - self line: r topLeft to: r bottomRight-w width: w color: Color yellow. - self line: r topRight -(w@0) to: r bottomLeft -(0@w)width: w color: Color yellow! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 6/19/2017 16:09:00' prior: 50360767! - drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - aColor = Color black ifFalse: [ | topColor | - topColor _ aColor alphaMixed: 0.25 with: Color black. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint - font: fontOrNil - color: topColor ]. - aColor = Color white ifFalse: [ | bottomColor | - bottomColor _ aColor alphaMixed: 0.22 with: Color white. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + `0@2` - font: fontOrNil - color: bottomColor ]. - ^self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + `0@1` - font: fontOrNil - color: aColor! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 6/19/2017 15:54:38' prior: 16877657! - textComposition: aTextComposition bounds: boundsRect color: c selectionColor: sc - | displayScanner leftInRun line boundsInWorld tl | - - tl _ boundsRect topLeft. - boundsInWorld _ currentTransformation displayBoundsOfTransformOf: boundsRect. - - displayScanner _ MorphicScanner new - defaultFont: aTextComposition defaultFont; - text: aTextComposition textComposed - foreground: c. - displayScanner canvas: self. - - leftInRun _ 0. - "Take clipRect into account. Extrememly fast scrolls and redraws of huge files (like .sources)" - (aTextComposition lineIndexForPoint: (`0@0` max: (clipLeft@clipTop)- boundsInWorld origin)) - to: (aTextComposition lineIndexForPoint: (boundsInWorld extent min: (clipRight@clipBottom+1) - boundsInWorld origin)) - do: [ :i | - line _ aTextComposition lines at: i. - aTextComposition - displaySelectionInLine: line - on: self - textTopLeft: tl - selectionColor: sc. - leftInRun _ displayScanner displayLine: line textTopLeft: tl leftInRun: leftInRun ]! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 6/19/2017 15:54:43' prior: 16877740! - onForm: aForm - - ^ self basicNew - initializeWith: aForm origin: `0@0`! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 6/19/2017 15:45:38' prior: 16787053! - fillRectangle: aRectangle tilingWith: aForm sourceRect: patternBox rule: aCombinationRule - "aRectangle is in form coordinates, no transformation is done." - | displayRectangle additionalOffset clippedPort targetTopLeft clipOffset ex - targetBox savedMap top left | - - ex _ patternBox extent. - ex x = 0 ifTrue: [ ^self ]. - ex y = 0 ifTrue: [ ^self ]. - displayRectangle _ currentTransformation displayBoundsOfTransformOf: aRectangle. - - "this is a bit of a kludge to get the form to be aligned where I *think* it should be. - something better is needed, but not now" - - additionalOffset _ `0@0`. - clippedPort _ port clippedBy: displayRectangle. - targetTopLeft _ clippedPort clipRect topLeft truncateTo: ex. - clipOffset _ displayRectangle topLeft - targetTopLeft. - additionalOffset _ (clipOffset \\ ex) - ex. - - "do it iteratively" - targetBox _ clippedPort clipRect. - savedMap _ clippedPort colorMap. - clippedPort sourceForm: aForm; - fillColor: nil; - combinationRule: aCombinationRule; - sourceRect: patternBox; - colorMap: (aForm colormapIfNeededFor: clippedPort destForm). - top _ (targetBox top truncateTo: patternBox height) + additionalOffset y. - left _ (targetBox left truncateTo: patternBox width) + additionalOffset x. - - left to: (targetBox right - 1) by: patternBox width do: [:x | - top to: (targetBox bottom - 1) by: patternBox height do: [:y | - clippedPort destOrigin: x@y; copyBits]]. - clippedPort colorMap: savedMap! ! -!BitBltCanvas class methodsFor: 'cached forms' stamp: 'jmv 6/19/2017 15:45:51' prior: 50360839! - steButtonForm: extent - ^self cachedForms - at: { #steButton . extent } - ifAbsentPut: [ - | form canvas | - form _ Form extent: extent depth: 32. - canvas _ form getCanvas. - canvas - roundRect: (`0@0` extent: extent) - color: (Color gray: 0.4) - radius: 4. - canvas - roundRect: (`1@1` extent: extent-2) - color: Color white - radius: 4 - gradientTop: 1.0 - gradientCenter: 0.73 - gradientBottom: 0.94 - gradient1Height: (extent y-8+1 max: extent y//2). - form]! ! -!BitBltCanvas class methodsFor: 'cached arrow forms' stamp: 'jmv 6/19/2017 16:01:13' prior: 50360916! - buildArrowWith: insideForm borderForm: borderForm - | extent translucentForm color insideSpec borderSpec border background alpha| - " - Display getCanvas - image: (BitBltCanvas buildArrowWith: BitBltCanvas downInsideForm borderForm: BitBltCanvas downBorderForm) - at: 20@20 - Display getCanvas - image: (BitBltCanvas buildArrowWith:BitBltCanvas upInsideForm borderForm: BitBltCanvas upBorderForm) - at: 40@20 - " - extent _ insideForm extent - `1@2`. - translucentForm _ Form extent: insideForm extent depth: 32. - 0 to: extent x-1 do: [ :x | - 0 to: extent y-1 do: [ :y | - insideSpec _ insideForm colorAt: x@(y+1). - borderSpec _ borderForm colorAt: x@(y+1). - insideSpec = (Color r: 0.0 g: 0.0 b: 1.0) - ifTrue: [ color _ Color transparent ] - ifFalse: [ - borderSpec = (Color r: 1.0 g: 0.0 b: 0.0) - ifTrue: [ color _ insideSpec ] - ifFalse: [ - border _ x < (extent x//2) - ifTrue: [Color white] - ifFalse: [Color black]. - background _ borderForm colorAt: extent x@(y+1). - alpha _ borderSpec red asFloat - background red / (border red - background red). - color _ border alpha: (alpha min: 1 max: 0) ]]. - translucentForm colorAt: x@y put: color ]]. - ^translucentForm! ! -!TextComposition methodsFor: 'selection' stamp: 'jmv 6/19/2017 16:13:22' prior: 16931067! - defaultCharacterBlock - ^ CharacterBlock - stringIndex: 1 - text: model actualContents - topLeft: lines first topLeft - extent: `0 @ 0` - textLine: lines first! ! -!DifferenceFinder methodsFor: 'private' stamp: 'jmv 6/19/2017 16:02:44' prior: 16834082! - maxLengthPoints - | max points | - max := self maxLength. - max = 0 ifTrue: [^Array with: `0 @ 0`]. - points := OrderedCollection new. - tally withIndexesDo: [:i :j :t | t = max ifTrue: [points add: i @ j]]. - ^points! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3115-UseLiteralPoints-JuanVuletich-2017Jun19-16h29m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3115] on 20 June 2017 at 5:50:34 pm'! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 6/20/2017 13:47:09' prior: 16919543! - browseObsoleteMethodReferences - "Open a browser on all referenced behaviors that are obsolete - Smalltalk browseObsoleteMethodReferences - Remember that if no methods reference obsoletes, but - Smalltalk obsoleteBehaviors inspect - still finds them, maybe they are referenced by ChangeSets!! - " - | list | - list _ self obsoleteMethodReferences. - self browseMessageList: list name:'Method referencing obsoletes' autoSelect: nil! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 6/20/2017 13:46:17' prior: 16919851! - obsoleteBehaviors - " - Smalltalk obsoleteBehaviors inspect - Find all obsolete behaviors including meta classes - " - | obs | - obs _ OrderedCollection new. - Smalltalk garbageCollect. - self allObjectsDo: [ :cl | - (cl isBehavior and: [cl isObsolete]) ifTrue: [obs add: cl]]. - ^ obs asArray! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 6/20/2017 13:46:10' prior: 16919891! - obsoleteMethodReferences - " - Smalltalk obsoleteMethodReferences - Smalltalk browseObsoleteMethodReferences - Open a browser on all referenced behaviors that are obsolete" - | obsClasses obsRefs references | - references _ WriteStream on: Array new. - obsClasses _ self obsoleteBehaviors. - 'Scanning for methods referencing obsolete classes' displayProgressAt: Sensor mousePoint - from: 1 to: obsClasses size during: [ :bar | - obsClasses keysAndValuesDo: [ :index :each | - bar value: index. - obsRefs _ self pointersTo: each except: obsClasses. - obsRefs do: [ :ref | - "Figure out if it may be a global" - (ref isVariableBinding and: [ ref key isString "or Symbol" ]) ifTrue: [ - (self pointersTo: ref) do: [ :meth | - (meth is: #CompiledMethod) ifTrue: [ - meth methodReference ifNotNil: [ :mref | - (mref isValid and: [ mref compiledMethod == meth]) ifTrue: [ - references nextPut: mref ]]]]]]]. - ]. - ^references contents! ! -!MethodReference methodsFor: 'queries' stamp: 'jmv 6/20/2017 13:30:02' prior: 16873082! - printOn: aStream - "Print the receiver on a stream" - - super printOn: aStream. - aStream - space; - nextPutAll: classSymbol. - classIsMeta ifTrue: [ aStream nextPutAll: ' class' ]. - aStream - nextPutAll: ' >> '; - nextPutAll: methodSymbol! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3116-obsoleteMethodRefs-fix-JuanVuletich-2017Jun20-17h49m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3115] on 20 June 2017 at 5:51:43 pm'! -!Color methodsFor: 'conversions' stamp: 'jmv 6/20/2017 17:46:14' prior: 50353457! - pixelValueForDepth: d - "Returns an integer representing the bits that appear in a single pixel of this color in a Form of the given depth. The depth must be one of 1, 2, 4, 8, 16, or 32. Contrast with pixelWordForDepth: and bitPatternForDepth:, which return either a 32-bit word packed with the given pixel value or a multiple-word Bitmap containing a pattern. The inverse is the class message colorFromPixelValue:depth:" - "Details: For depths of 8 or less, the result is a colorMap index. For depths of 16 and 32, it is a direct color value with 5 or 8 bits per color component." - "Transparency: The pixel value zero is reserved for transparent. For depths greater than 8 and less than 32 (no Indexed colors, no real alpha), black maps to the darkest possible blue. - Note that - Color transparent class = TranslucentColor - this special case is handled in TranslucentColor >> #pixelValueForDepth: - " - - | bitBltFakeBlack val | - "Most common case" - "eight bits per component; top 8 bits set to all ones (opaque alpha)" - d = 32 ifTrue: [ - ^ 16rFF000000 bitOr: - ((((self at: 1) * 255.999) truncated bitShift: 16) bitOr: - ((((self at: 2) * 255.999) truncated bitShift: 8) bitOr: - (((self at: 3) * 255.999) truncated))) ]. - -"Faster in 32 bit systems, but slower in 64 bits" -" d = 32 ifTrue: [ - val _ LargePositiveInteger new: 4. - val at: 3 put: ((self at: 1) * 255.999) truncated. - val at: 2 put: ((self at: 2) * 255.999) truncated. - val at: 1 put: ((self at: 3) * 255.999) truncated. - val at: 4 put: 16rFF. - ^ val normalize]." - - d = 8 ifTrue: [^ self closestPixelValue8]. "common case" - d < 8 ifTrue: [ - d = 4 ifTrue: [^ self closestPixelValue4]. - d = 2 ifTrue: [^ self closestPixelValue2]. - d = 1 ifTrue: [^ self closestPixelValue1]]. - - "For the depth 16, pixelValue = 0 means transparent, black is represented as 16r8000 (rgb=0, pixelvalue !!= 0)." - (d = 16) | (d = 15) ifTrue: [ - "five bits per component; top bits ignored" - val _ ((self red * 31) rounded bitShift: 10) bitOr: - (((self green * 31) rounded bitShift: 5) bitOr: - ((self blue * 31) rounded)). - ^ val = 0 - ifTrue: [d = 16 ifTrue: [16r8000] ifFalse: [1]] - ifFalse: [val]]. - - "For the rest of the depths, pixelValue = 0 means transparent, and darkest blue is considered to be black." - bitBltFakeBlack := 1. "closest black that is not transparent in RGB - Not for depths <=8 (Indexed) or = 32 (RGBA)" - d = 12 ifTrue: [ "for indexing a color map with 4 bits per color component" - val _ ((self red * 15) rounded bitShift: 8) bitOr: - (((self green * 15) rounded bitShift: 4) bitOr: - ((self blue * 15) rounded)). - ^ val = 0 ifTrue: [bitBltFakeBlack] ifFalse: [val]]. - - d = 9 ifTrue: [ "for indexing a color map with 3 bits per color component" - val _ ((self red * 7) rounded bitShift: 6) bitOr: - (((self green * 7) rounded bitShift: 3) bitOr: - ((self blue * 7) rounded)). - ^ val = 0 ifTrue: [bitBltFakeBlack] ifFalse: [val]]. - - self error: 'unknown pixel depth: ', d printString! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3117-pixelValueForDepth-speedup-JuanVuletich-2017Jun20-17h50m-jmv.1.cs.st----! - -----SNAPSHOT----#(20 June 2017 5:56:37.441617 pm) Cuis5.0-3117-32.image priorSource: 400547! - -----QUIT----#(20 June 2017 5:56:58.843421 pm) Cuis5.0-3117-32.image priorSource: 1058399! - -----STARTUP----#(27 June 2017 7:11:29.483259 am) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3117-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3117] on 20 June 2017 at 11:19:24 pm'! -!WorldState methodsFor: 'initialization' stamp: 'jmv 6/20/2014 20:24:55' prior: 16945777! - clearWaitDelay - waitDelay ifNotNil: [ - waitDelay unschedule. - waitDelay _ nil ]. - "Needed if for some reason Cuis is started with an earlier DateTime than the image was saved. - Might happen, especially on RasPi or other systems without an RTC" - lastCycleTime _ Time localMillisecondClock. - lastAlarmTime _ 0.! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3118-FixHangWhenStartupInThePast-JuanVuletich-2017Jun20-23h18m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3103] on 18 June 2017 at 5:34:41 am'! -!Browser methodsFor: 'class comment pane' stamp: 'pb 6/18/2017 05:34:23' prior: 16791499! - newClassComment: aText - "The user has just entered aText. - It may be all red (a side-effect of replacing the default comment), so remove the color if it is." - | theClass | - theClass _ self selectedClassOrMetaClass theNonMetaClass. - theClass ifNotNil: [ - theClass classComment: aText asString ]. - self changed: #classCommentText. - ^ true! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3119-Class-comment-editor-fix-PhilBellalouna-2017Jun18-05h34m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3119] on 22 June 2017 at 12:54:43 pm'! -!Color methodsFor: 'as yet unclassified' stamp: 'jmv 6/22/2017 12:54:10'! - convertToCurrentVersion: varDict refStream: smartRefStrm - - "subclasses should implement if they wish to convert old instances to modern ones" - self size = 0 ifTrue: [ - ^ Color new copyFrom: (varDict at: 'floatRGB') ]. - ^ self! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3120-MigrateColorInstancesInSmartRefStream-JuanVuletich-2017Jun22-12h43m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3120] on 26 June 2017 at 8:03:37 pm'! -!ReadStream methodsFor: 'accessing' stamp: 'jmv 6/26/2017 19:34:17'! - readInto: byteArray startingAt: startIndex count: count - "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: count. - byteArray - replaceFrom: startIndex - to: startIndex+max-1 - with: collection - startingAt: position+1. - position _ position + max. - ^max! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3121-ReadStream-readInto-JuanVuletich-2017Jun26-19h32m-jmv.1.cs.st----! - -----SNAPSHOT----#(27 June 2017 7:11:36.972198 am) Cuis5.0-3121-32.image priorSource: 1058493! - -----QUIT----#(27 June 2017 7:11:48.912622 am) Cuis5.0-3121-32.image priorSource: 1061351! - -----STARTUP----#(2 August 2017 3:56:46.808957 pm) as C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\Cuis5.0-3121-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3121] on 6 July 2017 at 3:13:37 am'! -!ScrollBar methodsFor: 'access' stamp: 'pb 7/6/2017 02:44:45'! - scrollValue - ^ value! ! -!ScrollBar methodsFor: 'model access' stamp: 'pb 7/6/2017 02:53:19'! - internalScrollValue: newValue - "Called internally for propagation to model" - self scrollValue: newValue. - setValueSelector ifNotNil: [ - model perform: setValueSelector with: value ]! ! -!ScrollBar methodsFor: 'model access' stamp: 'pb 7/6/2017 02:45:15'! - scrollValue: newValue - "Drive the slider position externally..." - value _ newValue min: 1.0 max: 0.0. - self computeSlider! ! -!ProgressBarMorph methodsFor: 'accessing' stamp: 'pb 7/6/2017 02:42:04'! - progressValue - ^value! ! -!ProgressBarMorph methodsFor: 'accessing' stamp: 'pb 7/6/2017 02:42:12'! - progressValue: aValue - value _ aValue. - self redrawNeeded! ! -!PositionableStream methodsFor: 'fileIn/Out' stamp: 'jmv 10/10/2015 23:26' prior: 16891768! - 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 | - announcement - displayProgressAt: Sensor mousePoint - from: 0 - to: self size - during: [ :bar | - [ self atEnd ] whileFalse: [ - bar value: self position. - self skipSeparators. - - [ - val := (self peekFor: $!!) - ifTrue: [ - chunk := self nextChunk. - "These are the ones that should do nothing, - because next line is a doit that does the stuff - (or because it is handled elsewhere)" - (chunk beginsWith: 'description: ') - | (chunk beginsWith: 'provides: ') - | (chunk beginsWith: 'requires: ') - | (chunk beginsWith: 'classDefinition: ') - | (chunk beginsWith: 'classRemoval: ') - | (chunk beginsWith: 'methodRemoval: ') - | (chunk beginsWith: 'classMoveToSomePackage: ') - | (chunk beginsWith: 'methodMoveToSomePackage: ') - ifFalse: [(Compiler evaluate: chunk logged: false) scanFrom: self]] - ifFalse: [ - chunk := self nextChunk. - self checkForPreamble: chunk. - [ Compiler evaluate: chunk logged: true ] - on: Error - do: [ :ex | - ex print. - ('while evaluating: ', chunk) print. - ex pass ] - ]] - on: InMidstOfFileinNotification - do: [ :ex | ex resume: true ] ]. - ]. - "Note: The main purpose of this banner is to flush the changes file." - Smalltalk logChange: '----End fileIn of ' , self name , '----'. - ^val! ! -!PositionableStream methodsFor: 'gui' stamp: 'pb 7/6/2017 02:51:46' prior: 16892012! - untilEnd: aBlock displayingProgress: aString - aString - displayProgressAt: Sensor mousePoint - from: 0 to: self size - during: [ :bar | - [ self atEnd ] whileFalse: [ - bar scrollValue: self position. - aBlock value ]]! ! -!ProgressInitiationException class methodsFor: 'examples and tests' stamp: 'pb 7/6/2017 02:52:33' prior: 16896176! - testInnermost - - "test the progress code WITHOUT special handling" - - ^'Now here''s some Real Progress' - displayProgressAt: Sensor mousePoint - from: 0 - to: 10 - during: [ :bar | - 1 to: 10 do: [ :x | - bar scrollValue: x. - (Delay forMilliseconds: 500) wait. - x = 5 ifTrue: [1/0]. "just to make life interesting" - ]. - 'done' - ]. - -! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'pb 7/6/2017 02:46:41' prior: 16889660! - hSetScrollDelta - "Set the ScrollBar deltas, value and interval, based on the current scroll pane size, offset and range." - | range delta w | - - delta _ self scrollDeltaWidth * 1.0. "avoid Fraction arithmetic" - range _ self hLeftoverScrollRange. - range = 0 ifTrue: [ - ^hScrollBar scrollDelta: 0.02 pageDelta: 0.2; interval: 1.0; internalScrollValue: 0 ]. - - "Set up for one line (for arrow scrolling), or a full pane less one line (for paging)." - w _ self viewableWidth * 1.0. "avoid Fraction arithmetic" - hScrollBar scrollDelta: delta / range pageDelta: w - delta / range. - hScrollBar interval: w / self hTotalScrollRange. - hScrollBar internalScrollValue: hScrollBar scrollValue! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'pb 7/6/2017 02:48:25' prior: 16889801! - vSetScrollDelta - "Set the ScrollBar deltas, value and interval, based on the current scroll pane size, offset and range." - | range delta h | - - delta _ self scrollDeltaHeight * 1.0. "avoid Fraction arithmetic" - range _ self vLeftoverScrollRange. - range = 0 ifTrue: [ - ^ scrollBar scrollDelta: 0.02 pageDelta: 0.2; interval: 1.0; internalScrollValue: 0 ]. - - "Set up for one line (for arrow scrolling), or a full pane less one line (for paging)." - h _ self viewableHeight * 1.0. "avoid Fraction arithmetic" - scrollBar scrollDelta: delta / range pageDelta: h - delta / range. - scrollBar interval: h / self vTotalScrollRange. - scrollBar internalScrollValue: scrollBar scrollValue! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'pb 7/6/2017 02:48:00' prior: 16889930! - hideOrShowScrollBars - - "Assume for a moment we don't need an horizontal scrollbar" - self hHideScrollBar. - - "Add or remove vertical scrollbar, asuming for a monent there's no horizontal scrollbar, - to determine need of horizontal scrollbar..." - self vIsScrollbarNeeded - ifTrue: [ self vShowScrollBar ] - ifFalse: [ self vHideScrollBar ]. - - "If we need an horizontal scrollbar, add it." - self hIsScrollbarNeeded ifTrue: [ - self hShowScrollBar. - - "If horizontal scrollbar is needed, maybe vertical scrollbar will be needed too (even if we previously thoutht it wouldn't be needed)." - "Note that there is no chance of modifying the need of horizontal scrollbar: it was already needed. Therefore, there is no circularity here." - self vIsScrollbarNeeded ifTrue: [ - self vShowScrollBar ]]. - - "Ensure that if no scrollbars are needed, whole contents are visible" - self vIsScrollbarShowing ifFalse: [ - scrollBar internalScrollValue: 0 ]. - self hIsScrollbarShowing ifFalse: [ - hScrollBar internalScrollValue: 0 ]. - - self updateScrollBarsBounds! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'pb 7/6/2017 02:51:24' prior: 16889965! - scrollBy: delta - "Move the contents in the direction delta." - - | newYoffset r newXoffset | - - "Set the offset on the scroller" - newYoffset _ self scrollerOffset y - delta y max: 0. - newXoffset _ self scrollerOffset x - delta x max: 0. - - self scrollerOffset: newXoffset@ newYoffset. - - "Update the scrollBars" - (r _ self vLeftoverScrollRange) = 0 - ifTrue: [ scrollBar scrollValue: 0.0 ] - ifFalse: [ scrollBar scrollValue: newYoffset asFloat / r ]. - (r _ self hLeftoverScrollRange) = 0 - ifTrue: [ hScrollBar scrollValue: 0.0 ] - ifFalse: [ hScrollBar scrollValue: newXoffset asFloat / r ]! ! -!PluggableListMorph methodsFor: 'selection' stamp: 'pb 7/6/2017 02:47:04' prior: 16889020! - scrollSelectionIntoView - "make sure that the current selection is visible" - | row r | - row _ self getCurrentSelectionIndex. - row = 0 - ifTrue: [ - "Value is 0, but we need to propagate it to model" - scrollBar internalScrollValue: scrollBar scrollValue ] - ifFalse: [ - self flag: #jmvVer2. - r _ self listMorph drawBoundsForRow: row. - r _ ((self listMorph externalize: r origin) extent: r extent). - self scrollToShow: r ]! ! -!PluggableListMorphOfMany methodsFor: 'events' stamp: 'pb 7/6/2017 02:56:44' prior: 50362992! - mouseMove: aMouseMoveEvent localPosition: localEventPosition - "The mouse has moved, as characterized by the event provided. Adjust the scrollbar, and alter the selection as appropriate" - - | oldIndex oldVal row | - row _ (localEventPosition y < 0 and: [ scrollBar scrollValue > 0.0 ]) - ifTrue: [ - scrollBar scrollUp: 1. - "Leave at least one visible item unaffected, for better visual feedback to the user." - (self rowAtLocation: `0@0`) + 2 ] - ifFalse: [ - (localEventPosition y > extent y and: [ scrollBar scrollValue < 1.0 ]) - ifTrue: [ - scrollBar scrollDown: 1. - "Leave at least one visible item unaffected, for better visual feedback to the user." - (self rowAtLocation: 0@extent y) - 3 ] - ifFalse: [ self rowAtLocation: localEventPosition ]]. - row = 0 ifTrue: [ ^ self ]. - - "No change if model is locked" - self owningWindow ifNotNil: [ :w | - w okToChange ifFalse: [^ self]]. - - dragOnOrOff ifNil: [ - "Was not set at mouse down, which means the mouse must have gone down in an area where there was no list item" - dragOnOrOff _ (self listSelectionAt: row) not. - dragStartRow _ row ]. - - "Set meaning for subsequent dragging of selection" - oldIndex _ self getCurrentSelectionIndex. - oldIndex ~= 0 ifTrue: [ oldVal _ self listSelectionAt: oldIndex ]. - - "Set or clear new primary selection (listIndex)" - dragOnOrOff - ifTrue: [ self changeModelSelection: row ] - ifFalse: [ self changeModelSelection: 0 ]. - - "Need to restore the old one, due to how model works, and set new one." - oldIndex ~= 0 ifTrue: [ self listSelectionAt: oldIndex put: oldVal ]. - - "Select all in between if drag was too fast" - "self listSelectionAt: row put: dragOnOrOff." - (row min: dragStartRow) to: (row max: dragStartRow) do: [ :r | - self listSelectionAt: r put: dragOnOrOff ]! ! -!ScrollBar methodsFor: 'scrolling' stamp: 'pb 7/6/2017 02:48:48' prior: 16904721! - scrollByPage - "Scroll automatically while mouse is down" - nextPageDirection - ifTrue: [self internalScrollValue: (value + pageDelta min: 1.0)] - ifFalse: [self internalScrollValue: (value - pageDelta max: 0.0)] -! ! -!ScrollBar methodsFor: 'scrolling' stamp: 'pb 7/6/2017 02:48:59' prior: 16904734! - scrollDown: count - self internalScrollValue: (value + (scrollDelta * count) + 0.000001 min: 1.0)! ! -!ScrollBar methodsFor: 'scrolling' stamp: 'pb 7/6/2017 02:49:09' prior: 16904739! - scrollTo: handPositionRelativeToSlider - | v handPositionRelativeToUs | - grabPosition ifNotNil: [ - handPositionRelativeToUs _ slider externalize: handPositionRelativeToSlider. - v _ (self isHorizontal - ifTrue: [ handPositionRelativeToUs x - grabPosition x ] - ifFalse: [ handPositionRelativeToUs y - grabPosition y ]) - - borderWidth - self buttonExtent * 1.0 - / self freeSliderRoom. - self internalScrollValue: v ]! ! -!ScrollBar methodsFor: 'scrolling' stamp: 'pb 7/6/2017 02:49:21' prior: 16904758! - scrollUp: count - self internalScrollValue: (value - (scrollDelta * count) - 0.000001 max: 0.0)! ! -!ProgressBarMorph methodsFor: 'menu' stamp: 'pb 7/6/2017 02:57:29' prior: 16896049! - changeProgressValue: evt - | answer | - answer _ FillInTheBlankMorph - request: 'Enter new value (0 - 1.0)' - initialAnswer: self progressValue contents asString. - answer isEmptyOrNil ifTrue: [^ self]. - self progressValue: answer asNumber! ! -!ProgressMorph methodsFor: 'accessing' stamp: 'pb 7/6/2017 02:57:41' prior: 16896233! - done - ^progress progressValue! ! -!ProgressMorph methodsFor: 'accessing' stamp: 'pb 7/6/2017 02:52:47' prior: 16896236! - done: amountDone - progress progressValue: ((amountDone min: 1.0) max: 0.0)! ! -!InnerTextMorph methodsFor: 'editing' stamp: 'pb 7/6/2017 02:47:26' prior: 50336492! - acceptContents - "The message is sent when the user hits return or Cmd-S. - Accept the current contents and end editing." - "Inform the model of text to be accepted, and return true if OK." - - | accepted prevSelection prevScrollValue | - - prevSelection _ self editor selectionInterval copy. - prevScrollValue _ owner verticalScrollBar scrollValue. - - (self canDiscardEdits and: [(self hasProperty: #alwaysAccept) not]) ifTrue: [self flash. ^true]. - (self hasEditingConflicts and: [ self confirmAcceptAnyway not ]) ifTrue: [self flash. ^false]. - - accepted _ model acceptContentsFrom: owner. - "During the step for the browser, updatePaneIfNeeded is called, and - invariably resets the contents of the code-holding PluggableTextMorph - at that time, resetting the cursor position and scroller in the process. - The following line forces that update without waiting for the step, - then restores the cursor and scrollbar" - - "some implementors of acceptContentsFrom: answer self :(" - ^accepted == true - ifTrue: [ - model refetch. - self editor selectFrom: prevSelection first to: prevSelection last. - WorldState addDeferredUIMessage: [ - self world ifNotNil: [ :w | w activeHand newKeyboardFocus: self ]. - owner verticalScrollBar internalScrollValue: prevScrollValue]. - true] - ifFalse: [ false ]! ! - -ProgressBarMorph removeSelector: #value! - -ProgressBarMorph removeSelector: #value! - -ProgressBarMorph removeSelector: #value:! - -ProgressBarMorph removeSelector: #value:! - -ScrollBar removeSelector: #setValue:! - -ScrollBar removeSelector: #setValue:! - -ScrollBar removeSelector: #value! - -ScrollBar removeSelector: #value! - -ScrollBar removeSelector: #value:! - -ScrollBar removeSelector: #value:! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3122-Morphs-Distinct-value-Methods-PhilBellalouna-2017Jul06-02h42m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3121] on 15 July 2017 at 10:07:51 pm'! -!UpdatingStringMorph methodsFor: 'stepping' stamp: 'pb 7/15/2017 22:07:40' prior: 50337150! - stepAt: millisecondSinceLast - - self contents: (target perform: getSelector) asString! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3123-UpdatingStringMorph-Squeak-compatibility-PhilBellalouna-2017Jul15-22h07m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3121] on 15 July 2017 at 11:19:17 pm'! -!PluggableButtonMorph methodsFor: 'as yet unclassified' stamp: 'pb 7/15/2017 23:15:35'! - morphExtent - "Use extent if it has already been manually set, otherwise try to set it by computing from the label text and font, otherwise try using the icon extent, or finally fall back to the default value." - ^ extent ifNil: [ - extent := (self fontToUse notNil and: [ label notNil ]) - ifTrue: [ "Add a bit of padding" - (self fontToUse widthOfString: label) + 10 @ (self fontToUse height + 10) ] - ifFalse: [ - icon - ifNil: [ `20@15` ] - ifNotNil: [ icon extent ]]].! ! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'pb 7/15/2017 22:34:12' prior: 16899252! - morphHeight - -"Ensure everybody wants our coordinates!!" - self flag: #jmvVer2. - ^ self morphExtent y! ! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'pb 7/15/2017 22:34:52' prior: 16899265! - morphPosition: newPos extent: newExtent - "Change the position of this morph. Argument is in owner's coordinates." - - | oldBoundsInWorld someChange | - - "Ask for the old bounds before updating them, but ask for repair only if extent or position has really changed." - oldBoundsInWorld _ self morphBoundsInWorld. - someChange _ false. - (location isTranslation: newPos) ifFalse: [ - location _ location withTranslation: newPos. - someChange _ true ]. - - self morphExtent = newExtent ifFalse: [ - (self privateExtent: newExtent) ifTrue: [ - someChange _ true ]]. - - someChange ifTrue: [ - "Ask for the old bounds before updating them, but ask for repair only if extent or position has really changed." - oldBoundsInWorld ifNotNil: [ - self invalidateDisplayRect: oldBoundsInWorld from: nil ]. - self someSubmorphPositionOrExtentChanged. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]! ! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'pb 7/15/2017 22:34:20' prior: 16899296! - morphWidth - -"Ensure everybody wants our coordinates!!" - self flag: #jmvVer2. - ^ self morphExtent x! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'pb 7/15/2017 22:40:30' prior: 50362837! - draw3DLookOn: aCanvas - - | borderStyleSymbol c | - borderStyleSymbol _ self isPressed ifFalse: [ #raised ] ifTrue: [ #inset ]. - c _ color. - self mouseIsOver ifTrue: [ c _ c lighter ]. - aCanvas - fillRectangle: (`0@0` extent: self morphExtent) - color: c - borderWidth: borderWidth - borderStyleSymbol: borderStyleSymbol - baseColorForBorder: c. - - self drawRegularLabelOn: aCanvas! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'pb 7/15/2017 22:40:17' prior: 16888097! - drawEmbossedLabelOn: aCanvas - - | availableW center colorForLabel f l labelMargin targetSize w x y | - label ifNotNil: [ - colorForLabel _ Theme current buttonLabel. - self isPressed - ifFalse: [ - self mouseIsOver - ifFalse: [ colorForLabel _ colorForLabel adjustSaturation: -0.10 brightness: 0.10 ]] - ifTrue: [ colorForLabel _ colorForLabel adjustSaturation: 0.0 brightness: -0.07 ]. - f _ self fontToUse. - center _ self morphExtent // 2. - labelMargin _ 3. - w _ f widthOfString: label. - availableW _ self morphExtent x - labelMargin - labelMargin. - availableW >= w - ifTrue: [ - l _ label ] - ifFalse: [ - x _ labelMargin. - targetSize _ label size * availableW // w. - l _ label squeezedTo: targetSize. - (f widthOfString: l) > availableW ifTrue: [ - targetSize _ targetSize - 1. - l _ label squeezedTo: targetSize ]]. - - w _ f widthOfString: l. - x _ center x - (w // 2). - y _ center y - (f height // 2). - aCanvas - drawString: l - at: x@y - font: f - color: colorForLabel - embossed: true ]! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'pb 7/15/2017 22:39:57' prior: 16888142! - drawRegularLabelOn: aCanvas - - | w f center x y availableW l labelMargin | - - f _ self fontToUse. - center _ self morphExtent // 2. - - label ifNotNil: [ - labelMargin _ 4. - w _ f widthOfString: label. - availableW _ self morphExtent x - labelMargin - labelMargin - 1. - availableW >= w - ifTrue: [ - x _ center x - (w // 2). - l _ label ] - ifFalse: [ - x _ labelMargin. - l _ label squeezedTo: (label size * availableW / w) rounded ]. - y _ center y - (f height // 2). - self isPressed ifTrue: [ - x _ x + 1. - y _ y + 1 ]. - aCanvas - drawString: l - at: x@y - font: f - color: Theme current buttonLabel ]! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'pb 7/15/2017 22:39:34' prior: 50362852! - drawRoundGradientLookOn: aCanvas - | r colorForButton rect bottomFactor topFactor | - - self isPressed - ifFalse: [ - topFactor _ Theme current buttonGradientTopFactor. - bottomFactor _ Theme current buttonGradientBottomFactor. - self mouseIsOver - ifTrue: [ - colorForButton _ Color h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ - colorForButton _ color ]] - ifTrue: [ - topFactor _ Theme current buttonGradientBottomFactor. - bottomFactor _ Theme current buttonGradientTopFactor. - colorForButton _ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - Theme current useButtonGradient - ifTrue: [ - rect _ (`0@0` extent: self morphExtent) insetBy: `1@3`. - aCanvas - roundRect: rect - color: colorForButton - radius: r - gradientTop: topFactor - gradientBottom: bottomFactor - gradientHeight: Theme current buttonGradientHeight ] - ifFalse: [ - rect _ (`0@0` extent: self morphExtent) insetBy: `1@3`. - aCanvas roundRect: rect color: colorForButton radius: r ] - ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawEmbossedLabelOn: aCanvas ] - ifFalse: [ self drawRegularLabelOn: aCanvas ]! ! -!PluggableButtonMorph methodsFor: 'initialization' stamp: 'pb 7/15/2017 22:36:46' prior: 50362894! - initialize - "initialize the state of the receiver" - super initialize. - - roundButtonStyle := nil. "nil: honor Theme. true: draw as round button. false: draw as classic 3d border square button" - model := nil. - getStateSelector := nil. - actionSelector := nil. - isPressed := false. - mouseIsOver := false. - actWhen := #buttonUp. - "We are overriding any value populated in extent by our superclass with nil so we know to perform the inital morph extent calculation" - extent := nil! ! -!PluggableButtonMorph methodsFor: 'private' stamp: 'pb 7/15/2017 22:36:28' prior: 50337961! - magnifiedIcon - | factor magnifiedExtent w h | - - icon ifNil: [ ^nil ]. - magnifiedIcon ifNil: [ - magnifiedIcon := icon. - w := icon width. - h := icon height. - w*h = 0 ifFalse: [ - factor _ 1.0 * self morphExtent x / w min: 1.0 * self morphExtent y / h. - (factor < 1 or: [ factor > 1.7 and: [self isRoundButton]]) ifTrue: [ - magnifiedExtent := (icon extent * factor) rounded. - magnifiedIcon := icon magnifyTo: magnifiedExtent ]]]. - ^magnifiedIcon! ! -!PluggableButtonMorph methodsFor: 'geometry testing' stamp: 'pb 7/15/2017 22:38:44' prior: 50362908! - morphContainsPoint: aLocalPoint - - | iconOrigin | - ((`0@0` extent: self morphExtent) containsPoint: aLocalPoint) ifFalse: [ ^false ]. - ^ self isOrthoRectangularMorph or: [ - magnifiedIcon isNil or: [ - iconOrigin := self morphExtent - magnifiedIcon extent // 2. - (magnifiedIcon isTransparentAt: (aLocalPoint - iconOrigin) rounded) not ]]! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3124-PluggableButtonMorph-initial-extent-PhilBellalouna-2017Jul15-22h29m-pb.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3121] on 16 July 2017 at 3:33:18 pm'! -!Morph methodsFor: 'events' stamp: 'pb 7/16/2017 15:06:53'! - mouseHover: aMouseMoveEvent localPosition: localEventPosition - "Handle a mouse move event. - This message will only be sent to Morphs that answer true to #handlesMouseHover for events that have not been previously handled. - We can query aMouseMoveEvent to know about pressed mouse buttons." - "Allow instances to dynamically use properties for handling common events." - self - valueOfProperty: #mouseHover:localPosition: - ifPresentDo: [ :handler | - handler - value: aMouseMoveEvent - value: localEventPosition ].! ! -!Morph methodsFor: 'event handling testing' stamp: 'pb 7/16/2017 15:00:51'! - handlesMouseHover - "Do I want to receive unhandled mouseMove events when the button is up and the hand is empty? The default response is false." - "Use a property test to allow individual instances to specify this." - ^ self hasProperty: #handlesMouseHover.! ! -!Morph methodsFor: 'events-processing' stamp: 'pb 7/16/2017 15:31:38' prior: 16875080! - processMouseOver: aMouseEvent localPosition: localEventPosition - "System level event handling." - self hasMouseFocus ifTrue: [ - "Got this directly through #handleFocusEvent: so check explicitly" - (self containsPoint: localEventPosition event: aMouseEvent) ifFalse: [ - ^self ]]. - aMouseEvent hand noticeMouseOver: self event: aMouseEvent. - "Open question: should any unhandled mouse move events be filtered out? (i.e. should mouseHover:localPosition: be called when a mouse button is pressed but the morph doesn't have mouse button handlers? Essentially, what are the limits of what is considered 'hovering'?" - (self handlesMouseHover and: [aMouseEvent wasHandled not]) ifTrue: [ - self - mouseHover: aMouseEvent - localPosition: localEventPosition ].! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3125-Morph-hovering-PhilBellalouna-2017Jul16-15h00m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3122] on 17 July 2017 at 3:52:45 pm'! -!ChangeList methodsFor: 'scanning' stamp: 'jmv 7/17/2017 15:44:04' prior: 16795940! - scanFile: aFile from: startPosition to: stopPosition - - file _ aFile. - changeList _ OrderedCollection new. - list _ OrderedCollection new. - listIndex _ 0. - file position: startPosition. - 'Scanning ', aFile localName, '...' - displayProgressAt: Sensor mousePoint - from: startPosition to: stopPosition - during: [ :barBlock | - [file position < stopPosition] whileTrue: [ | prevChar | - barBlock value: file position. - [file atEnd not and: [file peek isSeparator]] - whileTrue: [prevChar _ file next]. - (file peekFor: $!!) - ifTrue: [ - "A line starting with $!! means a specific ChangeRecord type" - (prevChar notNil and: [ prevChar isLineSeparator ]) - ifTrue: [self scanSpecificChangeRecordType]] - ifFalse: [ - "Otherwise, interpret it with #doIt:" - | itemPosition item | - itemPosition _ file position. - item _ file nextChunk. - item size > 0 ifTrue: [ - self - addItem: (ChangeRecord new file: file position: itemPosition type: #doIt) - text: 'do it: ' , (item contractTo: 160)]]]]. - self clearSelections! ! -!ClassBuilder methodsFor: 'private' stamp: 'jmv 7/17/2017 15:48:14' prior: 16803943! - informUserDuring: aBlock - self class isSilent ifTrue:[^aBlock value]. - Utilities informUserDuring:[:barBlock| - progress _ barBlock. - aBlock value]. - progress _ nil.! ! -!Integer class methodsFor: 'prime numbers' stamp: 'jmv 7/17/2017 15:44:55' prior: 16861068! - verbosePrimesUpTo: max do: aBlock - "Integer verbosePrimesUpTo: SmallInteger maxVal" "<- heh, heh" - "Compute primes up to max, but be verbose about it" - | lastTime | - lastTime := Time localMillisecondClock. - Utilities informUserDuring: [ :barBlock| - barBlock value:'Computing primes...'. - self primesUpTo: max do: [ :prime| | nowTime | - aBlock value: prime. - nowTime := Time localMillisecondClock. - (nowTime - lastTime > 1000) ifTrue:[ - lastTime := nowTime. - barBlock value: 'Last prime found: ', prime printString]]].! ! -!LookupKey methodsFor: 'bindings' stamp: 'jmv 7/17/2017 15:45:04' prior: 16865388! - recompileBindingsAnnouncing: aBool - "Make the receiver (a global read-write binding) be a read-only binding" - aBool ifTrue:[ - Utilities informUserDuring: [ :barBlock | - (Smalltalk allCallsOn: self) do: [ :mref | - barBlock value: 'Recompiling ', mref stringVersion. - mref actualClass recompile: mref methodSymbol ]. - ]. - ] ifFalse:[ - (Smalltalk allCallsOn: self) do: [ :mref | - mref actualClass recompile: mref methodSymbol ] - ]! ! -!SequenceableCollection methodsFor: 'gui' stamp: 'jmv 7/17/2017 15:45:17' prior: 16906997! - do: aBlock displayingProgress: aString - aString - displayProgressAt: Sensor mousePoint - from: 0 to: self size - during: [ :barBlock | - self withIndexDo: [ :each :i | - barBlock value: i. - aBlock value: each]]! ! -!String methodsFor: 'displaying' stamp: 'jmv 7/17/2017 15:41:46' prior: 16917058! - 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 mousePoint - from: 0 to: 100 - during: [:barBlock | - 1 to: 100 do: [:x | - (Delay forMilliseconds: 10) wait. - barBlock value: x.]]. - -['Now here''s some Real Progress' - displayProgressAt: Sensor mousePoint - from: 0 to: 100 - during: [:barBlock | - 1 to: 100 do: [:x | barBlock value: x. - (Delay forMilliseconds: 100) wait]].] fork - -['Now here''s some Real Progress' - displayProgressAt: Sensor mousePoint - from: 0 to: 10 - during: [:barBlock | - 1 to: 30 do: [:x | barBlock value: x \\ 11. - (Delay forMilliseconds: 100) wait]]] fork - -'Now here''s some Real Progress' - displayProgressAt: Sensor mousePoint - from: 0 to: 10 - during: [:barBlock | - 1 to: 30 do: [:x | barBlock value: nil. - (Delay forMilliseconds: 200) 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. - -The use of ProgressInitiationException allows for avoiding actual -progress display, by catching the exception. -" - ^ProgressInitiationException - display: self - at: aPoint - from: minVal - to: maxVal - during: workBlock! ! -!Set class methodsFor: 'initialization' stamp: 'jmv 7/17/2017 15:40:16' prior: 16907390! - quickRehashAllSets "Set rehashAllSets" - | insts | - self withAllSubclassesDo: - [:c | - insts _ c allInstances. - (insts isEmpty or: [c = MethodDictionary]) ifFalse: - ['Rehashing instances of ' , c name - displayProgressAt: Sensor mousePoint - from: 1 to: insts size - during: [ :barBlock | 1 to: insts size do: [:x | barBlock value: x. (insts at: x) rehash]] - ] - ]! ! -!Set class methodsFor: 'initialization' stamp: 'jmv 7/17/2017 15:40:27' prior: 16907404! - rehashAllSets "Set rehashAllSets" - | insts | - self withAllSubclassesDo: - [:c | insts _ c allInstances. - insts isEmpty ifFalse: - ['Rehashing instances of ' , c name - displayProgressAt: Sensor mousePoint - from: 1 to: insts size - during: [ :barBlock | - 1 to: insts size do: - [ :x | barBlock value: x. - (insts at: x) rehash]]]]! ! -!Dictionary methodsFor: 'removing' stamp: 'jmv 7/17/2017 15:44:29' prior: 16833635! - unreferencedKeys - "| uk | (Time millisecondsToRun: [uk := TextConstants unreferencedKeys]) -> uk" - - ^'Scanning for references . . .' - displayProgressAt: Sensor mousePoint - from: 0 - to: Smalltalk classNames size * 2 - during: - [:barBlock | | currentClass n associations referencedAssociations | - currentClass := nil. - n := 0. - associations := self associations asIdentitySet. - referencedAssociations := IdentitySet new: associations size. - Smalltalk allSelect: - [:m| - m methodClass ~~ currentClass ifTrue: - [currentClass := m methodClass. - barBlock value: (n := n + 1)]. - m literalsDo: - [:l| - (l isVariableBinding and: [associations includes: l]) ifTrue: - [referencedAssociations add: l]]. - false]. - ((associations reject: [:assoc | referencedAssociations includes: assoc]) collect: [:assoc| assoc key]) asSet]! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 7/17/2017 15:46:10' prior: 16919601! -condenseChanges - "Move all the changes onto a compacted sources file." - " - Smalltalk condenseChanges - " - - | oldChanges classCount oldChangesLocalName oldChangesPathName | - DirectoryEntry smalltalkImageDirectory // 'ST80.temp' forceWriteStreamDo: [ :f | - f timeStamp. - 'Condensing Changes File...' - displayProgressAt: Sensor mousePoint - from: 0 to: Smalltalk classNames size - during: [ :barBlock | - classCount _ 0. - Smalltalk allClassesDo: [ :class | - barBlock value: (classCount _ classCount + 1). - class moveChangesTo: f. - class putClassCommentToCondensedChangesFile: f. - class class moveChangesTo: f ]]. - LastQuitLogPosition _ f position ]. - - CompiledMethod allInstancesDo: [ :e | - e isInstalled ifFalse: [ e destroySourcePointer ] ]. - - oldChanges _ SourceFiles at: 2. - oldChangesPathName _ oldChanges name. - oldChangesLocalName _ oldChanges localName. - oldChanges close. - (oldChangesPathName, '.old') asFileEntry delete. - oldChangesPathName asFileEntry rename: oldChangesLocalName, '.old'. - DirectoryEntry smalltalkImageDirectory // 'ST80.temp' rename: oldChangesLocalName. - - SourceFiles - at: 2 put: oldChangesPathName asFileEntry appendStream. - - self inform: 'Changes file has been rewritten!! - -Check that all is well, and then save/quit. - -Otherwise, remove new changes, -replace it with the former one, and -exit without saving the image. - '! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 7/17/2017 15:46:14' prior: 16919647! - condenseSources - "Move all the changes onto a compacted sources file." - "Smalltalk condenseSources" - - | classCount newVersionString oldChanges oldChangesLocalName oldChangesPathName newChangesPathName newSourcesName | - newVersionString _ FillInTheBlankMorph request: 'Please name the new sources file' initialAnswer: SourceFileVersionString. - newVersionString ifNil: [^ self]. - newVersionString = SourceFileVersionString ifTrue: [ - ^ self error: 'The new source file must not be the same as the old.']. - SourceFileVersionString _ newVersionString. - - "Write all sources with fileIndex 1" - newSourcesName _ self defaultSourcesName. - newSourcesName asFileEntry writeStreamDo: [ :f | - f timeStamp. - 'Condensing Sources File...' - displayProgressAt: Sensor mousePoint - from: 0 to: Smalltalk classNames size - during: [ :barBlock | - classCount _ 0. - Smalltalk allClassesDo: [ :class | - barBlock value: (classCount _ classCount + 1). - class fileOutOn: f moveSource: true toFile: 1]]]. - - CompiledMethod allInstancesDo: [ :e | - e isInstalled ifFalse: [ e destroySourcePointer ] ]. - - "Make a new empty changes file" - oldChanges _ SourceFiles at: 2. - oldChangesPathName _ oldChanges name. - oldChangesLocalName _ oldChanges localName. - self closeSourceFiles. - oldChangesPathName ifNotNil: [ - (oldChangesPathName, '.old') asFileEntry delete. - oldChangesPathName asFileEntry rename: oldChangesLocalName, '.old' ]. - newChangesPathName _ self defaultChangesName. - newChangesPathName asFileEntry writeStreamDo: [ :stream | - stream timeStamp ]. - LastQuitLogPosition _ 0. - - self openSourceFiles. - self inform: 'Source files have been rewritten!! - -Check that all is well, and then save/quit. - -Otherwise, remove new sources/changes, -replace them with the former ones, and -exit without saving the image. - '! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 7/17/2017 15:41:56' prior: 16919755! - macroBenchmark1 "Smalltalk macroBenchmark1" - "Decompiles and prettyPrints the source for every method in the system (or less depending on the *FILTER*, and then compiles that source and verifies that it generates (and decompiles to) identical code. This currently fails in a number of places because some different patterns (esp involving conditionals where the first branch returns) decompile the same. Because it never installs the new method, it should not cause any flusing of the method cache." - | methodNode oldMethod newMethod badOnes oldCodeString n classes | - classes _ Smalltalk allClasses select: [:c | c name < 'B3']. - badOnes _ OrderedCollection new. -'Decompiling and recompiling...' -displayProgressAt: Sensor mousePoint -from: 0 to: (classes detectSum: [:c | c selectors size]) -during: [:barBlock | n _ 0. - classes do: - [:cls | - "Transcript cr; show: cls name." - cls selectors do: - [:selector | barBlock value: (n _ n+1). - oldMethod _ cls compiledMethodAt: selector. - oldCodeString _ (cls decompilerClass new - decompile: selector in: cls method: oldMethod) - decompileString. - methodNode _ cls compilerClass new - compile: oldCodeString - in: cls notifying: nil ifFail: nil. - newMethod _ methodNode generate: #(0 0 0 0). - oldCodeString = (cls decompilerClass new - decompile: selector in: cls method: newMethod) - decompileString ifFalse: [badOnes add: cls name , ' ' , selector]]]. -]. - ^ badOnes size! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 7/17/2017 15:46:19' prior: 16919804! - macroBenchmark3 "Smalltalk macroBenchmark3" - | testBlock tallies prev receiver | - "Runs the stepping simulator with the messageTally tree (like tallySends)." - testBlock _ - ['Running the context step simulator' - displayProgressAt: Sensor mousePoint - from: 0 to: 200 - during: - [:barBlock | - 1 to: 200 do: - [:x | barBlock value: x. - Float pi printString. - 15 factorial printString]]]. - tallies _ MessageTally new class: testBlock receiver class - method: testBlock method. - receiver _ nil. - prev _ testBlock. - thisContext sender - runSimulated: testBlock - contextAtEachStep: - [:current | - current == prev ifFalse: [ - "call or return" - prev sender ifNotNil: [ - "call only" - (receiver == nil or: [current receiver == receiver]) - ifTrue: [tallies tally: current by: 1]]. - prev _ current]]. -! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 7/17/2017 15:46:24' prior: 50364574! - obsoleteMethodReferences - " - Smalltalk obsoleteMethodReferences - Smalltalk browseObsoleteMethodReferences - Open a browser on all referenced behaviors that are obsolete" - | obsClasses obsRefs references | - references _ WriteStream on: Array new. - obsClasses _ self obsoleteBehaviors. - 'Scanning for methods referencing obsolete classes' displayProgressAt: Sensor mousePoint - from: 1 to: obsClasses size during: [ :barBlock | - obsClasses keysAndValuesDo: [ :index :each | - barBlock value: index. - obsRefs _ self pointersTo: each except: obsClasses. - obsRefs do: [ :ref | - "Figure out if it may be a global" - (ref isVariableBinding and: [ ref key isString "or Symbol" ]) ifTrue: [ - (self pointersTo: ref) do: [ :meth | - (meth is: #CompiledMethod) ifTrue: [ - meth methodReference ifNotNil: [ :mref | - (mref isValid and: [ mref compiledMethod == meth]) ifTrue: [ - references nextPut: mref ]]]]]]]. - ]. - ^references contents! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 7/17/2017 15:46:30' prior: 16919989! - testDecompiler - " - Smalltalk testDecompiler - " - "Decompiles the source for every method in the system, and then compiles that source and verifies that it generates (and decompiles to) identical code. This currently fails in a number of places because some different patterns (esp involving conditionals where the first branch returns) decompile the same." - | methodNode oldMethod newMethod badOnes oldCodeString n | - badOnes _ OrderedCollection new. - 'Decompiling all classes...' - displayProgressAt: Sensor mousePoint - from: 0 - to: CompiledMethod instanceCount - during: [ :barBlock | - n _ 0. - Smalltalk allBehaviorsDo: [ :cls | - "Transcript cr; show: cls name." - cls selectors do: [ :selector | - (n _ n + 1) \\ 100 = 0 ifTrue: [ barBlock value: n ]. - oldMethod _ cls compiledMethodAt: selector. - oldCodeString _ (cls decompilerClass new - decompile: selector - in: cls - method: oldMethod) decompileString. - methodNode _ cls compilerClass new - compile: oldCodeString - in: cls - notifying: nil - ifFail: nil. - newMethod _ methodNode generate: #(0 0 0 0 ). - oldCodeString = - (cls decompilerClass new - decompile: selector - in: cls - method: newMethod) decompileString ifFalse: [ - Transcript - newLine; - show: '***' , cls name , ' ' , selector. - badOnes add: (MethodReference class: cls selector: selector) ]]]]. - Smalltalk - browseMessageList: badOnes asArray sort - name: 'Decompiler Discrepancies'.! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 7/17/2017 15:46:37' prior: 16920039! - testFormatter - "Smalltalk testFormatter" - "Reformats the source for every method in the system, and then compiles that source and verifies that it generates identical code. - The formatting used will be classic monochrome." - | newCodeString methodNode oldMethod newMethod badOnes n | - badOnes _ OrderedCollection new. - 'Formatting all classes...' - displayProgressAt: Sensor mousePoint - from: 0 - to: CompiledMethod instanceCount - during: [ :barBlock | - n _ 0. - Smalltalk allBehaviorsDo: [ :cls | - "Transcript cr; show: cls name." - cls selectors do: [ :selector | - (n _ n + 1) \\ 100 = 0 ifTrue: [ barBlock value: n ]. - newCodeString _ cls compilerClass new - format: (cls sourceCodeAt: selector) - in: cls - notifying: nil. - methodNode _ cls compilerClass new - compile: newCodeString - in: cls - notifying: nil - ifFail: nil. - newMethod _ methodNode generate: #(0 0 0 0 ). - oldMethod _ cls compiledMethodAt: selector. - oldMethod = newMethod ifFalse: [ - Transcript - newLine; - show: '***' , cls name , ' ' , selector. - badOnes add: cls name , ' ' , selector ]]]]. - Smalltalk - browseMessageList: badOnes asArray sort - name: 'Formatter Discrepancies'.! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 7/17/2017 15:46:43' prior: 16920080! - testFormatter2 - "Smalltalk testFormatter2" - "Reformats the source for every method in the system, and then verifies that the order of source tokens is unchanged. - The formatting used will be classic monochrome" - | newCodeString badOnes n oldCodeString oldTokens newTokens | - badOnes _ OrderedCollection new. - 'Formatting all classes...' - displayProgressAt: Sensor mousePoint - from: 0 - to: CompiledMethod instanceCount - during: [ :barBlock | - n _ 0. - Smalltalk allBehaviorsDo: [ :cls | - "Transcript cr; show: cls name." - cls selectors do: [ :selector | - (n _ n + 1) \\ 100 = 0 ifTrue: [ barBlock value: n ]. - oldCodeString _ (cls sourceCodeAt: selector) asString. - newCodeString _ cls compilerClass new - format: oldCodeString - in: cls - notifying: nil. - oldTokens _ oldCodeString findTokens: Character separators. - newTokens _ newCodeString findTokens: Character separators. - oldTokens = newTokens ifFalse: [ - Transcript - newLine; - show: '***' , cls name , ' ' , selector. - badOnes add: cls name , ' ' , selector ]]]]. - Smalltalk - browseMessageList: badOnes asArray sort - name: 'Formatter Discrepancies'.! ! -!SystemDictionary methodsFor: 'retrieving' stamp: 'jmv 7/17/2017 15:45:58' prior: 16921677! - allMethodsSourceStringMatching: aString - "Answer a sorted Collection of all the methods that contain, in source code, aString as a substring. - Search the class comments also. - Argument might include $*, that matches any subsequence. - For example, try: - ensure:*[*close*] - " - | list classCount adder | - list _ Set new. - adder _ [ :mrClass :mrSel | - list add: - (MethodReference new - setStandardClass: mrClass - methodSymbol: mrSel) ]. - 'Searching all source code...' - displayProgressAt: Sensor mousePoint - from: 0 - to: Smalltalk classNames size - during: [ :barBlock | - classCount _ 0. - Smalltalk allClassesDo: [ :class | - barBlock value: (classCount _ classCount + 1). - (Array - with: class - with: class class) do: [ :cl | - cl selectorsDo: [ :sel | - (aString match: (cl sourceCodeAt: sel)) ifTrue: [ - adder - value: cl - value: sel ]]. - - (aString match: cl organization classComment asString) ifTrue: [ - adder - value: cl - value: #Comment ]]]]. - ^ list asArray sort.! ! -!SystemDictionary methodsFor: 'retrieving' stamp: 'jmv 7/17/2017 15:46:02' prior: 16921712! - allMethodsWithSourceString: aString matchCase: caseSensitive - "Answer a sorted Collection of all the methods that contain, in source code, aString as a substring. Search the class comments also" - | list classCount adder | - list _ Set new. - adder _ [ :mrClass :mrSel | - list add: - (MethodReference new - setStandardClass: mrClass - methodSymbol: mrSel) ]. - 'Searching all source code...' - displayProgressAt: Sensor mousePoint - from: 0 - to: Smalltalk classNames size - during: [ :barBlock | - classCount _ 0. - Smalltalk allClassesDo: [ :class | - barBlock value: (classCount _ classCount + 1). - (Array - with: class - with: class class) do: [ :cl | - cl selectorsDo: [ :sel | - ((cl sourceCodeAt: sel) - findString: aString - startingAt: 1 - caseSensitive: caseSensitive) > 0 ifTrue: [ - adder - value: cl - value: sel ]]. - (cl organization classComment asString - findString: aString - startingAt: 1 - caseSensitive: caseSensitive) > 0 ifTrue: [ - adder - value: cl - value: #Comment ]]]]. - ^ list asArray sort.! ! -!SystemDictionary methodsFor: 'shrinking' stamp: 'jmv 7/17/2017 15:45:48' prior: 16922180! - abandonSources - " - Smalltalk abandonSources - " - | m bTotal bCount | - (self confirm: -'This method will detach the image fom source code. -A fresh changes file will be created to record further changes. --- CAUTION -- -If you have backed up your system and -are prepared to face the consequences of -abandoning source code files, choose Yes. -If you have any doubts, you may choose No -to back out with no harm done.') - == true ifFalse: [^ self inform: 'Okay - no harm done']. - bTotal _ 0. bCount _ 0. - Smalltalk allBehaviorsDo: [: b | bTotal _ bTotal + 1]. -'Doing #destroySourcePointer ...' - displayProgressAt: Sensor mousePoint - from: 0 to: bTotal - during: [ :barBlock | - Smalltalk allBehaviorsDo: [ :cl | - "for testing" - "{ EllipseMorph } do: [ :cl |" - barBlock value: (bCount _ bCount + 1). - cl selectors do: [:selector | - m _ cl compiledMethodAt: selector. - m destroySourcePointer ]]]. - Smalltalk allBehaviorsDo: [:b | b zapOrganization]. - Smalltalk closeSourceFiles. - Preferences disable: #warnIfNoChangesFile. - Preferences disable: #warnIfNoSourcesFile! ! -!SystemDictionary methodsFor: 'shrinking' stamp: 'jmv 7/17/2017 15:42:02' prior: 16922340! - removeAllUnSentMessages - "Smalltalk removeAllUnSentMessages" - "[Smalltalk unusedClasses do: [:c | (Smalltalk at: c) removeFromSystem]. - Smalltalk removeAllUnSentMessages > 0] whileTrue." - "Remove all implementations of unsent messages." - | sels n | - sels _ self allUnSentMessages. - self presumedSentMessages - do: [:sel | sels - remove: sel - ifAbsent: nil]. - sels size = 0 - ifTrue: [^ 0]. - n _ 0. - Smalltalk - allBehaviorsDo: [:x | n _ n + 1]. - 'Removing ' , sels size printString , ' messages . . .' - displayProgressAt: Sensor mousePoint - from: 0 - to: n - during: [:barBlock | - n _ 0. - self - allBehaviorsDo: [:class | - barBlock value: (n _ n + 1). - sels - do: [:sel | class removeSelector: sel]]]. - ^ sels size! ! -!PositionableStream methodsFor: 'fileIn/Out' stamp: 'jmv 7/17/2017 15:45:10' prior: 50364858! - 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 | - announcement - displayProgressAt: Sensor mousePoint - from: 0 - to: self size - during: [ :barBlock | - [ self atEnd ] whileFalse: [ - barBlock value: self position. - self skipSeparators. - - [ - val := (self peekFor: $!!) - ifTrue: [ - chunk := self nextChunk. - "These are the ones that should do nothing, - because next line is a doit that does the stuff - (or because it is handled elsewhere)" - (chunk beginsWith: 'description: ') - | (chunk beginsWith: 'provides: ') - | (chunk beginsWith: 'requires: ') - | (chunk beginsWith: 'classDefinition: ') - | (chunk beginsWith: 'classRemoval: ') - | (chunk beginsWith: 'methodRemoval: ') - | (chunk beginsWith: 'classMoveToSomePackage: ') - | (chunk beginsWith: 'methodMoveToSomePackage: ') - ifFalse: [(Compiler evaluate: chunk logged: false) scanFrom: self]] - ifFalse: [ - chunk := self nextChunk. - self checkForPreamble: chunk. - [ Compiler evaluate: chunk logged: true ] - on: Error - do: [ :ex | - ex print. - ('while evaluating: ', chunk) print. - ex pass ] - ]] - on: InMidstOfFileinNotification - do: [ :ex | ex resume: true ] ]. - ]. - "Note: The main purpose of this banner is to flush the changes file." - Smalltalk logChange: '----End fileIn of ' , self name , '----'. - ^val! ! -!PositionableStream methodsFor: 'gui' stamp: 'jmv 7/17/2017 15:38:57' prior: 50364916! - untilEnd: aBlock displayingProgress: aString - aString - displayProgressAt: Sensor mousePoint - from: 0 to: self size - during: [ :barBlock | - [ self atEnd ] whileFalse: [ - barBlock value: self position. - aBlock value ]]! ! -!ReferenceStream methodsFor: 'statistics' stamp: 'jmv 7/17/2017 15:40:06' prior: 16899982! - statisticsOfRefs - "Analyze the information in references, the objects being written out" - - | parents n kids nm ownerBags tallies owners objParent normalReferences | - normalReferences _ self references. "Exclude unrealized weaks" - parents _ IdentityDictionary new: normalReferences size * 2. - n _ 0. - 'Finding Owners...' - displayProgressAt: Sensor mousePoint - from: 0 to: normalReferences size - during: [ :barBlock | - normalReferences keysDo: - [ :parent | barBlock value: (n _ n+1). - kids _ parent class isFixed - ifTrue: [(1 to: parent class instSize) collect: [:i | parent instVarAt: i]] - ifFalse: [parent class isBits ifTrue: [Array new] - ifFalse: [(1 to: parent basicSize) collect: [:i | parent basicAt: i]]]. - (kids select: [:x | normalReferences includesKey: x]) - do: [:child | parents at: child put: parent]]]. - ownerBags _ Dictionary new. - tallies _ Bag new. - n _ 0. - 'Tallying Owners...' - displayProgressAt: Sensor mousePoint - from: 0 to: normalReferences size - during: [ :barBlock | - normalReferences keysDo: "For each class of obj, tally a bag of owner classes" - [ :obj | barBlock value: (n _ n+1). - nm _ obj class name. - tallies add: nm. - owners _ ownerBags at: nm ifAbsent: [ownerBags at: nm put: Bag new]. - (objParent _ parents at: obj ifAbsent: nil) ifNotNil: [ - owners add: objParent class name]]]. - ^ String streamContents: [ :strm | - tallies sortedCounts do: [ :assn | - n _ assn key. nm _ assn value. - owners _ ownerBags at: nm. - strm newLine; nextPutAll: nm; space; print: n. - owners size > 0 ifTrue: [ - strm newLine; tab; print: owners sortedCounts]]]! ! -!SmartRefStream methodsFor: 'read write' stamp: 'jmv 7/17/2017 15:40:37' prior: 16911182! - nextPut: anObject - "Really write three objects: (version, class structure, object). But only when called from the outside. If any instance-specific classes are present, prepend their source code. byteStream will be in fileOut format. - You can see an analysis of which objects are written out by doing: - (SmartRefStream statsOfSubObjects: anObject) - (SmartRefStream tallyOfSubObjects: anObject) - (SmartRefStream subObjects: anObject ofClass: aClass)" - -| info | -topCall - ifNil: [ - topCall _ anObject. - 'Please wait while objects are counted' - displayProgressAt: Sensor mousePoint - from: 0 to: 10 - during: [ :barBlock | info _ self instVarInfo: anObject]. - byteStream binary. - 'Writing an object file' displayProgressAt: Sensor mousePoint - from: 0 to: objCount*4 "estimate" - during: [ :barBlock | - objCount _ 0. - progressBar _ barBlock. - self setStream: byteStream reading: false. - "set basePos, but keep any class renames" - super nextPut: ReferenceStream versionCode. - super nextPut: info. - super nextPut: anObject. "<- the real writing" - ]. - "Note: the terminator, $!!, is not doubled inside object data" - "references is an IDict of every object that got written" - byteStream ascii. - byteStream nextPutAll: '!!'; newLine; newLine. - byteStream padToEndWith: $ . "really want to truncate file, but can't" - topCall _ progressBar _ nil] "reset it" - ifNotNil: [ - super nextPut: anObject. - progressBar ifNotNil: [progressBar value: (objCount _ objCount + 1)]]. -! ! -!SmartRefStream methodsFor: 'read write' stamp: 'jmv 7/17/2017 15:40:57' prior: 16911232! - nextPutObjOnly: anObject - "Really write three objects: (version, class structure, object). But only when called from the outside. Not in fileOut format. No class definitions will be written for instance-specific classes. Error if find one. (Use nextPut: instead)" - - | info | - topCall - ifNil: [ - topCall _ anObject. - super nextPut: ReferenceStream versionCode. - 'Please wait while objects are counted' displayProgressAt: Sensor mousePoint - from: 0 to: 10 - during: [ :barBlock | - info _ self instVarInfo: anObject]. - 'Writing an object file' displayProgressAt: Sensor mousePoint - from: 0 to: objCount*4 "estimate" - during: [ :barBlock | - objCount _ 0. - progressBar _ barBlock. - super nextPut: info. - super nextPut: anObject. "<- the real writing" - "Class inst vars not written here!!"]. - "references is an IDict of every object that got written - (in case you want to take statistics)" - "Transcript cr; show: structures keys printString." "debug" - topCall _ progressBar _ nil] "reset it" - ifNotNil: [ - super nextPut: anObject. - progressBar ifNotNil: [progressBar value: (objCount _ objCount + 1)]].! ! -!ProgressInitiationException class methodsFor: 'examples and tests' stamp: 'jmv 7/17/2017 15:39:39' prior: 50364927! -testInnermost - - " - test the progress code WITHOUT special handling - - ProgressInitiationException testInnermost - " - - ^'Now here''s some Real Progress' - displayProgressAt: Sensor mousePoint - from: 0 - to: 10 - during: [ :barBlock | - 1 to: 10 do: [ :x | - barBlock value: x. - (Delay forMilliseconds: 500) wait. - x = 5 ifTrue: [1/0]. "just to make life interesting" - ]. - 'done' - ]. - -! ! -!Utilities class methodsFor: 'user interface' stamp: 'jmv 7/17/2017 15:48:35' prior: 16941514! - informUserDuring: barBlock - "Display a message above (or below if insufficient room) the cursor during execution of the given block." - - "Utilities informUserDuring:[:barBlock| - #(one two three) do:[:info| - barBlock value: info. - (Delay forSeconds: 1) wait]]" - - (MVCMenuMorph from: (SelectionMenu labels: '') title: ' ') - informUserAt: Sensor mousePoint - during: barBlock! ! -!CodeFile methodsFor: 'reading' stamp: 'jmv 7/17/2017 15:44:20' prior: 16808992! - buildFrom: aStream - | chgRec changes | - changes _ (ChangeList new scanFile: aStream from: 0 to: aStream size) changeList. - ('Processing ', self name) - displayProgressAt: Sensor mousePoint - from: 1 - to: changes size - during: [ :barBlock | - 1 to: changes size do:[:i| - barBlock value: i. - chgRec := changes at: i. - chgRec class == MethodDeletionChangeRecord - ifTrue: [ self removedMethod: chgRec command with: chgRec ] - ifFalse: [ self perform: (chgRec changeType copyWith: $:) asSymbol with: chgRec ]. - ]. - ]! ! -!SpaceTally methodsFor: 'fileOut' stamp: 'jmv 7/17/2017 15:45:36' prior: 16912516! - printSpaceAnalysis: threshold on: aStream - " - SpaceTally new printSpaceAnalysis: 1 on:(FileStream forceNewFileNamed: 'STspace.text') - " - "sd-This method should be rewrote to be more coherent within the rest of the class - ie using preAllocate and spaceForInstanceOf:" - - "If threshold > 0, then only those classes with more than that number - of instances will be shown, and they will be sorted by total instance space. - If threshold = 0, then all classes will appear, sorted by name." - - | codeSpace instCount instSpace totalCodeSpace totalInstCount totalInstSpace eltSize n totalPercent percent | - Smalltalk garbageCollect. - totalCodeSpace _ totalInstCount _ totalInstSpace _ n _ 0. - results _ OrderedCollection new: Smalltalk classNames size. - 'Taking statistics...' - displayProgressAt: Sensor mousePoint - from: 0 to: Smalltalk classNames size - during: [ :barBlock | - Smalltalk allClassesDo: [ :cl | - codeSpace _ cl spaceUsed. - barBlock value: (n _ n+1). - Smalltalk garbageCollectMost. - instCount _ cl instanceCount. - instSpace _ (cl indexIfCompact > 0 ifTrue: [4] ifFalse: [8]) * instCount. "Object headers""Warning: The 3rd header word for big objects is not considered!!" - cl isVariable - ifTrue: [ - eltSize _ cl isBytes ifTrue: [1] ifFalse: [4]. - cl allInstancesDo: [ :x | - instSpace _ instSpace + (x basicSize * eltSize)]] - ifFalse: [instSpace _ instSpace + (cl instSize * instCount * 4)]. - results add: (SpaceTallyItem analyzedClassName: cl name codeSize: codeSpace instanceCount: instCount spaceForInstances: instSpace). - totalCodeSpace _ totalCodeSpace + codeSpace. - totalInstCount _ totalInstCount + instCount. - totalInstSpace _ totalInstSpace + instSpace]]. - totalPercent _ 0.0. - - aStream timeStamp. - aStream - nextPutAll: ('Class' padded: #right to: 30 with: $ ); - nextPutAll: ('code space' padded: #left to: 12 with: $ ); - nextPutAll: ('# instances' padded: #left to: 12 with: $ ); - nextPutAll: ('inst space' padded: #left to: 12 with: $ ); - nextPutAll: ('percent' padded: #left to: 8 with: $ ); newLine. - - threshold > 0 ifTrue: [ - "If inst count threshold > 0, then sort by space" - results _ (results select: [:s | s instanceCount >= threshold or: [s spaceForInstances > (totalInstSpace // 500)]]) - asArray sort: [:s :s2 | s spaceForInstances > s2 spaceForInstances]]. - - results do: [:s | - aStream - nextPutAll: (s analyzedClassName padded: #right to: 30 with: $ ); - nextPutAll: (s codeSize printString padded: #left to: 12 with: $ ); - nextPutAll: (s instanceCount printString padded: #left to: 12 with: $ ); - nextPutAll: (s spaceForInstances printString padded: #left to: 14 with: $ ). - percent _ s spaceForInstances*100.0/totalInstSpace. - totalPercent _ totalPercent + percent. - percent >= 0.1 ifTrue: [ - percent printOn: aStream integerDigits: 6 padWith: $ fractionDigits: 1 positiveIndicator: nil ]. - aStream newLine]. - - aStream - newLine; nextPutAll: ('Total' padded: #right to: 30 with: $ ); - nextPutAll: (totalCodeSpace printString padded: #left to: 12 with: $ ); - nextPutAll: (totalInstCount printString padded: #left to: 12 with: $ ); - nextPutAll: (totalInstSpace printString padded: #left to: 14 with: $ ). - totalPercent printOn: aStream integerDigits: 6 padWith: $ fractionDigits: 1 positiveIndicator: nil! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3126-ProgressArgumentIsABlock-JuanVuletich-2017Jul17-15h32m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3121] on 12 July 2017 at 1:50:53 pm'! -!Float64Array methodsFor: 'testing' stamp: 'jmv 7/11/2017 14:04:20'! -isLiteral - "so that - #(1 #[1.0 2 3] 5) - prints itself" - ^self class == Float64Array! ! -!Float64Array methodsFor: 'printing' stamp: 'jmv 7/11/2017 14:10:44'! - printOn: aStream - - self storeOn: aStream! ! -!Float64Array methodsFor: 'printing' stamp: 'jmv 7/11/2017 14:10:41'! - storeOn: aStream - - aStream nextPutAll: '#['. - self - do: [ :each | each storeOn: aStream ] - separatedBy: [ aStream nextPut: $ ]. - aStream nextPut: $]! ! -!ByteArray methodsFor: 'printing' stamp: 'jmv 7/11/2017 14:09:10' prior: 16793833! - printOn: aStream - self storeOn: aStream! ! -!Scanner methodsFor: 'expression types' stamp: 'jmv 7/12/2017 13:50:30' prior: 16903764! - scanLitByteVec - "Also accept Floats besides bytes!! - #[1 2 3 255] - #[1.0 0.2 1.0] - #[1.0 -0.2e-23 1.0e4] - " - | stream | - stream _ nil. - [ tokenType == #rightBracket or: [ tokenType == #doIt ] ] whileFalse: [ - (token == #- and: [(self typeTableAt: hereChar) == #xDigit]) ifTrue: [ - self scanToken. - token _ token negated ]. - ((token isInteger and: [ token between: 0 and: 255 ]) or: [token isFloat]) - ifFalse: [ ^ self offEnd: '8-bit integer, floating point number, or right bracket expected' ]. - stream ifNil: [ - stream _ ((token isFloat ifTrue: [Float64Array] ifFalse: [ByteArray]) new: 16) writeStream ]. - stream nextPut: token. - self scanToken ]. - token _ stream contents! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3127-LiteralFloatArrays-JuanVuletich-2017Jul12-13h50m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3127] on 17 July 2017 at 5:00:00 pm'! -!Collection methodsFor: 'converting' stamp: 'jmv 7/17/2017 16:59:02'! - asFloat64Array - "Answer a Float64Array whose elements are the elements of the receiver" - - ^self as: Float64Array! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3128-asFloat64Array-JuanVuletich-2017Jul17-16h59m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3128] on 18 July 2017 at 10:23:11 am'! -!PluggableButtonMorph methodsFor: 'as yet unclassified' stamp: 'jmv 7/18/2017 10:22:53' prior: 50365264! - morphExtent - "Use extent if it has already been manually set, otherwise try to set it by computing from the label text and font, otherwise try using the icon extent, or finally fall back to the default value." - ^ extent ifNil: [ - extent := (self fontToUse notNil and: [ label notNil ]) - ifTrue: [ "Add a bit of padding" - (self fontToUse widthOfString: label) + 10 @ (self fontToUse height + 10) ] - ifFalse: [ - `20@15` - "Usually button extent should not depend on icon extent. Icons are many times very big. - For example, the icons in buttons in Taskbar are full size captures of the windows" - "icon - ifNil: [ `20@15` ] - ifNotNil: [ icon extent ]" - ]].! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3129-AvoidHugeButtons-JuanVuletich-2017Jul18-10h22m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3128] on 19 July 2017 at 2:45:06 am'! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'pb 7/19/2017 02:42:16'! - moveEnd - self gotoPage: self pageCount. - self selected: completer entryCount. - self redrawNeeded.! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'pb 7/19/2017 02:42:22'! - moveHome - self gotoPage: 1. - self redrawNeeded.! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'pb 7/19/2017 02:43:17' prior: 16781410! - moveDown - self selected = completer entryCount - ifTrue: [ self moveHome ] - ifFalse: [ - self selected: self selected + 1. - (self selected > self lastVisible and: [ self selected <= completer entryCount ]) ifTrue: [ firstVisible _ firstVisible + 1 ]]. - self redrawNeeded.! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'pb 7/19/2017 02:42:32' prior: 16781419! - moveUp - (self selected = 0 and: [ self firstVisible = 1 ]) ifTrue: [ ^ self ]. - self selected = 1 - ifTrue: [ - self moveEnd ] - ifFalse: [ - self selected: self selected - 1. - self selected < self firstVisible ifTrue: [ firstVisible _ firstVisible - 1 ]]. - self redrawNeeded.! ! -!AutoCompleter methodsFor: 'keyboard' stamp: 'pb 7/19/2017 02:42:44' prior: 16781174! - handleKeystrokeBefore: kbEvent - "I return a boolean. true when I have handled the event and no futher processing is needed by the caller." - | currentPos currentCharIsAlphaNumeric keyValue ctrl cmd tab colon alphanum backspace esc space return keyChar | - currentPos _ textMorph editor startIndex-1. - currentCharIsAlphaNumeric _ currentPos > 0 and: [ model textSize >= currentPos and: [ - (model actualContents at: currentPos) isAlphaNumeric ]]. - keyValue _ kbEvent keyValue. - keyChar _ kbEvent keyCharacter. - ctrl _ kbEvent controlKeyPressed. - cmd _ kbEvent commandAltKeyPressed. - tab _ keyChar = Character tab. - colon _ keyChar = $:. - alphanum _ kbEvent keyCharacter isAlphaNumeric. - backspace _ keyValue = 8. - esc _ keyValue = 27. - space _ #(0 32 160) includes: keyValue. - return _ kbEvent isReturnKey. - - "Stuff to do if the menu is not open" - menuMorph ifNil: [ - "Ctrl-Space or Tab for open" - "Mac specific note: Using option-space (actually option+160) effectively disables the non-breaking space character 160" - (space & (ctrl | kbEvent rawMacOptionKeyPressed) or: [ - (self opensWithTab and: [tab]) and: [ currentCharIsAlphaNumeric ]]) - ifTrue: [ self openCompletionMenu. ^ true]. - "Auto-open - currently deactivated" -" (ctrl not & cmd not & alphanum) - ifTrue: [ self openCompletionMenu ]." - ^ false]. - - "Starting here, stuff to do if the menu is open" - menuMorph stillActive. - "Escape" - esc ifTrue: [ self closeMenu. ^ true]. - "Backspace" - backspace ifTrue: [ - currentCharIsAlphaNumeric ifFalse: [ self closeMenu ]. - ^ false]. - "Home" - keyValue = 1 ifTrue: [ menuMorph moveHome. ^ true ]. - "End" - keyValue = 4 ifTrue: [ menuMorph moveEnd. ^ true]. - "?" - keyChar = $? ifTrue: [ menuMorph help. ^true]. - "Arrow up" - keyValue = 30 ifTrue: [ menuMorph moveUp. ^ true]. - "Arrow down" - keyValue = 31 ifTrue: [ menuMorph moveDown. ^ true]. - "Page up" - keyValue = 11 ifTrue: [ menuMorph pageUp. ^ true]. - "Page down" - keyValue = 12 ifTrue: [ menuMorph pageDown. ^ true]. - "Return, Tab or Ctrl-Space" - (return or: [ space & (ctrl | kbEvent rawMacOptionKeyPressed) or: [ tab]]) ifTrue: [ - self insertSelected - ifTrue: [^ true]]. - "All keys but the alphanumeric chars (without command and control ) - and the backspace key do close the menu" - (ctrl not & cmd not and: [ alphanum | colon]) - ifFalse: [ self closeMenu ]. - ^false! ! - -AutoCompleterMorph removeSelector: #end! - -AutoCompleterMorph removeSelector: #end! - -AutoCompleterMorph removeSelector: #ensureVisible! - -AutoCompleterMorph removeSelector: #home! - -AutoCompleterMorph removeSelector: #home! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3130-AutoCompleterMorph-wrapping-PhilBellalouna-2017Jul19-02h20m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3130] on 2 August 2017 at 12:48:23 pm'! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'jmv 8/2/2017 12:45:12'! - goDown - self selected: self selected + 1. - (self selected > self lastVisible - and: [self selected <= completer entryCount]) - ifTrue: [firstVisible := firstVisible + 1]. - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'jmv 8/2/2017 12:45:38'! - goHome - firstVisible := 1. - self selected: firstVisible. - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'jmv 8/2/2017 12:47:05'! - goPageDown - (self gotoPage: self currentPage + 1) - ifFalse: [ self goToEnd ]. - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'jmv 8/2/2017 12:45:54'! - goPageUp - self gotoPage: self currentPage - 1. - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'jmv 8/2/2017 12:45:32'! - goToEnd - self selected: completer entryCount. - firstVisible := selected - self class itemsPerPage + 1 max: 1. - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'jmv 8/2/2017 12:45:45'! - goUp - (self selected = 0 - and: [self firstVisible = 1]) - ifTrue: [^ self]. - self selected: self selected - 1. - self selected < self firstVisible - ifTrue: [firstVisible := firstVisible - 1]. - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'events' stamp: 'jmv 8/2/2017 12:46:45' prior: 16781544! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - (self morphContainsPoint: localEventPosition) - ifTrue: [ - ((self upButtonPosition extent: ScrollBar scrollbarThickness) containsPoint: localEventPosition) - ifTrue: [ ^self stillActive; goUp ]. - ((self downButtonPosition extent: ScrollBar scrollbarThickness) containsPoint: localEventPosition) - ifTrue: [ ^self stillActive; goDown ]. - self selected: (localEventPosition y // self class itemHeight) + self firstVisible. - completer insertSelected ] - ifFalse: [ self delete. completer menuClosed ]! ! -!AutoCompleterMorph methodsFor: 'paging' stamp: 'jmv 8/2/2017 12:38:44' prior: 16781597! -gotoPage: anInteger - | item | - item := ((anInteger - 1) * self class itemsPerPage) + 1. - item >= completer entryCount ifTrue: [^false]. - item < 1 ifTrue: [item := 1]. - firstVisible := item. - self selected: firstVisible. - ^ true! ! -!AutoCompleter methodsFor: 'keyboard' stamp: 'jmv 8/2/2017 12:47:30' prior: 50366781! - handleKeystrokeBefore: kbEvent - "I return a boolean. true when I have handled the event and no futher processing is needed by the caller." - | currentPos currentCharIsAlphaNumeric keyValue ctrl cmd tab colon alphanum backspace esc space return keyChar | - currentPos _ textMorph editor startIndex-1. - currentCharIsAlphaNumeric _ currentPos > 0 and: [ model textSize >= currentPos and: [ - (model actualContents at: currentPos) isAlphaNumeric ]]. - keyValue _ kbEvent keyValue. - keyChar _ kbEvent keyCharacter. - ctrl _ kbEvent controlKeyPressed. - cmd _ kbEvent commandAltKeyPressed. - tab _ keyChar = Character tab. - colon _ keyChar = $:. - alphanum _ kbEvent keyCharacter isAlphaNumeric. - backspace _ keyValue = 8. - esc _ keyValue = 27. - space _ #(0 32 160) includes: keyValue. - return _ kbEvent isReturnKey. - - "Stuff to do if the menu is not open" - menuMorph ifNil: [ - "Ctrl-Space or Tab for open" - "Mac specific note: Using option-space (actually option+160) effectively disables the non-breaking space character 160" - (space & (ctrl | kbEvent rawMacOptionKeyPressed) or: [ - (self opensWithTab and: [tab]) and: [ currentCharIsAlphaNumeric ]]) - ifTrue: [ self openCompletionMenu. ^ true]. - "Auto-open - currently deactivated" -" (ctrl not & cmd not & alphanum) - ifTrue: [ self openCompletionMenu ]." - ^ false]. - - "Starting here, stuff to do if the menu is open" - menuMorph stillActive. - "Escape" - esc ifTrue: [ self closeMenu. ^ true]. - "Backspace" - backspace ifTrue: [ - currentCharIsAlphaNumeric ifFalse: [ self closeMenu ]. - ^ false]. - "Home" - keyValue = 1 ifTrue: [ menuMorph goHome. ^ true ]. - "End" - keyValue = 4 ifTrue: [ menuMorph goToEnd. ^ true]. - "?" - keyChar = $? ifTrue: [ menuMorph help. ^true]. - "Arrow up" - keyValue = 30 ifTrue: [ menuMorph goUp. ^ true]. - "Arrow down" - keyValue = 31 ifTrue: [ menuMorph goDown. ^ true]. - "Page up" - keyValue = 11 ifTrue: [ menuMorph goPageUp. ^ true]. - "Page down" - keyValue = 12 ifTrue: [ menuMorph goPageDown. ^ true]. - "Return, Tab or Ctrl-Space" - (return or: [ space & (ctrl | kbEvent rawMacOptionKeyPressed) or: [ tab]]) ifTrue: [ - self insertSelected - ifTrue: [^ true]]. - "All keys but the alphanumeric chars (without command and control ) - and the backspace key do close the menu" - (ctrl not & cmd not and: [ alphanum | colon]) - ifFalse: [ self closeMenu ]. - ^false! ! - -AutoCompleterMorph removeSelector: #moveDown! - -AutoCompleterMorph removeSelector: #moveDown! - -AutoCompleterMorph removeSelector: #moveEnd! - -AutoCompleterMorph removeSelector: #moveEnd! - -AutoCompleterMorph removeSelector: #moveHome! - -AutoCompleterMorph removeSelector: #moveHome! - -AutoCompleterMorph removeSelector: #moveUp! - -AutoCompleterMorph removeSelector: #moveUp! - -AutoCompleterMorph removeSelector: #pageDown! - -AutoCompleterMorph removeSelector: #pageDown! - -AutoCompleterMorph removeSelector: #pageUp! - -AutoCompleterMorph removeSelector: #pageUp! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3131-AutoCompletterMorph-removeWrapping-JuanVuletich-2017Aug02-12h43m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3131] on 2 August 2017 at 12:59:24 pm'! -!Scanner methodsFor: 'expression types' stamp: 'jmv 8/2/2017 12:59:08' prior: 50366667! - scanLitByteVec - "Also accept Floats besides bytes!! - #[1 2 3 255] - #[1.0 0.2 1.0] - #[1.0 -0.2e-23 1.0e4] - " - | stream | - stream _ nil. - [ tokenType == #rightBracket or: [ tokenType == #doIt ] ] whileFalse: [ - (token == #- and: [(self typeTableAt: hereChar) == #xDigit]) ifTrue: [ - self scanToken. - token _ token negated ]. - ((token isInteger and: [ token between: 0 and: 255 ]) or: [token isFloat]) - ifFalse: [ ^ self offEnd: '8-bit integer, floating point number, or right bracket expected' ]. - stream ifNil: [ - stream _ ((token isFloat ifTrue: [Float64Array] ifFalse: [ByteArray]) new: 16) writeStream ]. - stream nextPut: token. - self scanToken ]. - token _ stream - ifNotNil: [ stream contents ] - ifNil: [ - "For back compatibility, if empty, assume ByteArray" - ByteArray new ]! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3132-EmptyLiteralByteArrayFix-JuanVuletich-2017Aug02-12h59m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3094] on 29 July 2017 at 9:36:44 pm'! -!Exception methodsFor: 'debug support' stamp: 'HAW 7/29/2017 15:47:08'! - canSearchForSignalerContext - "This method is /only/ to support the debugger's catching of exceptions in stepIntoBlock." - ^signalContext isContext! ! -!Debugger methodsFor: 'context stack menu' stamp: 'HAW 7/29/2017 20:49:55' prior: 16829808! - doStep - "Send the selected message in the accessed method, and regain control - after the invoked method returns." - - | currentContext newContext | - - currentContext := self selectedContext. - newContext := self handleLabelUpdatesIn: [interruptedProcess completeStep: currentContext] - whenExecuting: currentContext. - newContext == currentContext ifTrue: - [newContext := interruptedProcess stepToSendOrReturn]. - self contextStackIndex > 1 - ifTrue: [self resetContext: newContext] - ifFalse: - [newContext == currentContext - ifTrue: [self changed: #contentsSelection. - self updateInspectors] - ifFalse: [self resetContext: newContext]]. -! ! -!Debugger methodsFor: 'context stack menu' stamp: 'HAW 7/29/2017 20:50:01'! - handleLabelUpdatesIn: aBlock whenExecuting: aContext - "Send the selected message in the accessed method, and regain control - after the invoked method returns." - - ^aBlock - on: Notification - do: [:ex| - (ex tag isArray - and: [ex tag size = 2 - and: [(ex tag first == aContext or: [ex tag first hasSender: aContext])]]) - ifTrue: - [self labelString: ex tag second description. - ex resume] - ifFalse: - [ex pass]]! ! -!Debugger methodsFor: 'context stack menu' stamp: 'HAW 7/29/2017 20:50:15' prior: 16829946! - stepIntoBlock - "Send messages until you return to the present method context. - Used to step into a block in the method." - - self - handleLabelUpdatesIn: [interruptedProcess stepToHome: self selectedContext] - whenExecuting: self selectedContext. - self resetContext: interruptedProcess stepToSendOrReturn! ! -!Inspector methodsFor: 'initialization' stamp: 'HAW 7/29/2017 15:28:27' prior: 16857112! - inspect: anObject - "Initialize the receiver so that it is inspecting anObject. There is no current selection. - - Normally the receiver will be of the correct class (as defined by anObject inspectorClass), - because it will have just been created by sedning inspect to anObject. However, the - debugger uses two embedded inspectors, which are re-targetted on the current receiver - each time the stack frame changes. The left-hand inspector in the debugger has its - class changed by the code here. Care should be taken if this method is overridden to - ensure that the overriding code calls 'super inspect: anObject', or otherwise ensures that - the class of these embedded inspectors are changed back." - - | c | - c := anObject inspectorClass. - self class ~= c ifTrue: [ - self class format = c format - ifTrue: [self primitiveChangeClassTo: c basicNew] - ifFalse: [self becomeForward: (c basicNew copyFrom: self)]]. - - "Set 'object' before sending the initialize message, because some implementations - of initialize (e.g., in DictionaryInspector) require 'object' to be non-nil." - - object := anObject. - self initialize! ! -!OrderedCollectionInspector methodsFor: 'as yet unclassified' stamp: 'HAW 7/29/2017 15:13:36' prior: 16884334! - fieldList - - | fieldsHere | - object isNil ifTrue: [^OrderedCollection new]. - fieldsHere _ - [ - (object size <= (self i1 + self i2) - ifTrue: [(1 to: object size) collect: [:i | i printString]] - ifFalse: [(1 to: self i1) , (object size-(self i2-1) to: object size) collect: [:i | i printString]]) - ] on: Error do: [:ex | ex return: OrderedCollection new]. - ^self baseFieldList , fieldsHere -" -OrderedCollection new inspect -(OrderedCollection newFrom: #(3 5 7 123)) inspect -(OrderedCollection newFrom: (1 to: 1000)) inspect -"! ! -!Process methodsFor: 'changing suspended state' stamp: 'HAW 7/29/2017 16:00:49' prior: 16894360! - stepToHome: aContext - "Resume self until the home of top context is aContext. Top context may be a block context. - Catch any UnhandledErrors that are created while stepping, answering the relevant signalerContext - if so. Note that this will cause weird effects if using through to step through UnhandledError - code, but as the doctor ordered, don't do that; use over or into instead." - - | home anError | - - home := aContext home. - [suspendedContext := suspendedContext step. - home == suspendedContext home or: [home isDead]] whileFalse: - [(suspendedContext selector == #signalForException: - and: [(suspendedContext receiver isBehavior - and: [suspendedContext receiver includesBehavior: UnhandledError]) - and: [anError := suspendedContext tempAt: 1. - ((suspendedContext objectClass: anError) includesBehavior: Exception) - and: [anError canSearchForSignalerContext]]]) ifTrue: - [anError signalerContext ifNotNil: [:unhandledErrorSignalerContext| - [unhandledErrorSignalerContext == suspendedContext] whileFalse: - [self completeStep: suspendedContext]. - "Give a debugger a chance to update its title to reflect the new exception" - Notification new - tag: {unhandledErrorSignalerContext. anError}; - signal. - ^unhandledErrorSignalerContext]]]. - - ^suspendedContext! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3133-DebuggerFixes-HernanWilkinson-2017Jun03-20h55m-HAW.1.cs.st----! - -----SNAPSHOT----#(2 August 2017 3:57:07.645957 pm) Cuis5.0-3133-32.image priorSource: 1061446! - -----QUIT----#(2 August 2017 3:57:33.364957 pm) Cuis5.0-3133-32.image priorSource: 1139236! - -----STARTUP----#(17 August 2017 10:42:01.667074 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3133-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3133] on 3 August 2017 at 12:49:11 pm'! -!Number methodsFor: 'intervals' stamp: 'jmv 8/3/2017 11:57:08'! - to: stop do: elementBlock separatedBy: separatorBlock - " - String streamContents: [ :strm | - 1 to: 10 do: [ :i | i printOn: strm ] separatedBy: [ strm nextPutAll: ' -- ' ]] - " - | beforeFirst | - "Evaluate the elementBlock for all elements in the receiver, - and evaluate the separatorBlock between." - - beforeFirst _ true. - self to: stop do: [ :element | - beforeFirst - ifTrue: [beforeFirst _ false] - ifFalse: [separatorBlock value]. - elementBlock value: element]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3134-to_do_separatedBy-JuanVuletich-2017Aug03-11h50m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3129] on 24 July 2017 at 4:30:44 pm'! -!TextEditor methodsFor: 'typing/selecting keys' stamp: 'jmv 7/24/2017 09:10:47' prior: 16932568! - forwardDelete: aKeyboardEvent - "Delete forward over the next character." - "This is a user command, and generates undo" - - | startIndex stopIndex | - - "If there was a selection" - self hasSelection ifTrue: [ - self replaceSelectionWith: self nullText. - ^ false]. - - "Exit if at end" - startIndex _ self markIndex. - startIndex > model textSize ifTrue: [ - ^ false]. - - "Null selection - do the delete forward" - stopIndex _ startIndex. - (aKeyboardEvent keyValue = 127 and: [ aKeyboardEvent shiftPressed ]) - ifTrue: [stopIndex := (self nextWordStart: stopIndex) - 1]. - self selectFrom: startIndex to: stopIndex. - self replaceSelectionWith: self nullText. - self deselectAndPlaceCursorAt: startIndex. - ^false! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3135-DeleteSelectionAtEndOfText-fix-JuanVuletich-2017Jul24-16h25m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3134] on 9 August 2017 at 11:37:48 am'! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 8/9/2017 11:37:34' prior: 16786577! - image: aForm at: aPoint sourceRect: sourceRect - "Draw a translucent image using the best available way of representing translucency. - Note: This will be fixed in the future." - | r p | - p _ (currentTransformation transform: aPoint) rounded. - r _ (self depth < 32 or: [ aForm mightBeTranslucent not ]) - ifTrue: [ - "Rule Form paint treats pixels with a value of zero as transparent" - Form paint ] - ifFalse: [ Form blend ]. - port colorMap: (aForm colormapIfNeededFor: form); fillColor: nil. - port image: aForm at: p sourceRect: sourceRect rule: r. - (self depth = 32 and: [ aForm depth < 32 ]) ifTrue: [ - "If we blit to 32bpp from one of smaller depth, - it will have zero in the alpha channel (until BitBlt is fixed!!) - This is the same workaround as in #asFormOfDepth:" - port sourceForm: nil. - port combinationRule: 40. "fixAlpha:with:" - port copyBits ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3136-BitBltCanvas-fix-JuanVuletich-2017Aug08-16h59m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3134] on 17 August 2017 at 1:06:03 pm'! -!PluggableListMorph methodsFor: 'events' stamp: 'jmv 8/17/2017 13:05:27' prior: 16888588! - doubleClick: aMouseButtonEvent localPosition: localEventPosition - | index | - doubleClickSelector ifNil: [ ^super doubleClick: aMouseButtonEvent localPosition: localEventPosition ]. - index _ self rowAtLocation: localEventPosition. - index = 0 ifTrue: [ ^super doubleClick: aMouseButtonEvent localPosition: localEventPosition ]. - index == self selectionIndex - ifFalse: [ self changeModelSelection: index ]. - ^ self model perform: doubleClickSelector! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3137-DoubleClickOnSelection-Inspector-Fix-JuanVuletich-2017Aug17-12h45m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3137] on 17 August 2017 at 5:00:13 pm'! -!Inspector methodsFor: 'user interface support' stamp: 'jmv 8/17/2017 16:28:29'! - textStylerClassFor: textGetter - - ^SHTextStylerST80! ! -!Inspector methodsFor: 'shout styling' stamp: 'jmv 8/17/2017 16:51:54'! - bindingNamesDo: aBlock - object class allInstVarNames do: aBlock! ! -!Inspector methodsFor: 'shout styling' stamp: 'jmv 8/17/2017 16:52:08'! - hasBindingOf: aString - ^ object class allInstVarNames includes: aString! ! -!Inspector methodsFor: 'shout styling' stamp: 'jmv 8/17/2017 16:48:11'! - shoutAboutToStyle: aSHTextStyler - "This is a notification that aSHTextStyler is about to re-style its text. - Set the classOrMetaClass in aSHTextStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - - aSHTextStyler -"No. Impica que es un metodo!! - classOrMetaClass: self selectedClassOrMetaClass." - - workspace: self. - ^true! ! -!ContextVariablesInspector methodsFor: 'shout styling' stamp: 'jmv 8/17/2017 16:58:45'! - bindingNamesDo: aBlock - fieldList do: aBlock! ! -!ContextVariablesInspector methodsFor: 'shout styling' stamp: 'jmv 8/17/2017 16:58:56'! - hasBindingOf: aString - ^ fieldList includes: aString! ! -!ObjectExplorer methodsFor: 'user interface support' stamp: 'jmv 8/17/2017 16:28:32'! - textStylerClassFor: textGetter - - ^SHTextStylerST80! ! -!ObjectExplorer methodsFor: 'shout styling' stamp: 'jmv 8/17/2017 16:54:38'! - bindingNamesDo: aBlock - self doItReceiver class allInstVarNames do: aBlock! ! -!ObjectExplorer methodsFor: 'shout styling' stamp: 'jmv 8/17/2017 16:54:33'! - hasBindingOf: aString - ^ self doItReceiver class allInstVarNames includes: aString! ! -!ObjectExplorer methodsFor: 'shout styling' stamp: 'jmv 8/17/2017 16:48:02'! - shoutAboutToStyle: aSHTextStyler - "This is a notification that aSHTextStyler is about to re-style its text. - Set the classOrMetaClass in aSHTextStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - - aSHTextStyler -"No. Impica que es un metodo!! - classOrMetaClass: self selectedClassOrMetaClass." - - workspace: self. - ^true! ! -!Inspector methodsFor: 'accessing' stamp: 'jmv 8/17/2017 16:47:26' prior: 16856921! - selectedClassOrMetaClass -"NOOOOOO" - ^ self selectedClass "I don't know any better"! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3138-ShoutInInspectorsAndExplorers-JuanVuletich-2017Aug17-16h27m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3137] on 17 August 2017 at 5:07:41 pm'! -!SmalltalkCompleter methodsFor: 'entries' stamp: 'jmv 8/17/2017 17:06:33' prior: 16909227! - computeEntries - - | allSource contextClass id specificModel last3Ranges range prevRange receiverClass prevPrevRange | - allSource _ model actualContents string. - specificModel _ (model is: #hasTextProvider) - ifTrue: [ model textProvider ] - ifFalse: [ model ]. - contextClass _ (specificModel is: #CodeProvider) ifTrue: [ - specificModel selectedClassOrMetaClass ]. - - "Instead of creating a new string, maybe we could pass the last position to parse to Shout..." - parser _ SHParserST80 new. - parser - workspace: specificModel; - classOrMetaClass: contextClass; - source: (allSource copyFrom: 1 to: position). - parser parse. - last3Ranges _ parser last3Ranges. - range _ last3Ranges third. - range ifNil: [ ^entries _ #() ]. - - "If parsing breaks before position, then we don't know what to suggest, therefore don't open Completion" - range end = position ifFalse: [ ^entries _ #() ]. - - prefix _ allSource copyFrom: range start to: range end. - - (parser isMessage: range rangeType) ifTrue: [ - "If previous range is a constant or a well known identifier, we might filter messages" - prevRange _ last3Ranges second. - prevPrevRange _ last3Ranges first. - receiverClass _ nil. - "3 if -> ifNil: but not ifTrue: - 3=4 -> ifNil: or ifTrue:" - (prevRange notNil and: [ prevPrevRange isNil or: [ (#(binary keyword) includes: prevPrevRange rangeType) not]]) ifTrue: [ - id _ (allSource copyFrom: prevRange start to: prevRange end). - receiverClass _ prevRange rangeType caseOf: { - [ #globalVar ] -> [ (Smalltalk at: id asSymbol) class ]. - [ #self ] -> [ contextClass ]. - [ #super ] -> [ contextClass superclass ]. - [ #true ] -> [ True ]. - [ #false ] -> [ False ]. - [ #nil ] -> [ UndefinedObject ]. - [ #character ] -> [ id first class ]. - [ #number ] -> [ (Compiler evaluate: id) class ]. - [ #string ] -> [ (Compiler evaluate: id) class ]. - [ #symbol ] -> [ (Compiler evaluate: id) class ]. - [ #stringSymbol ] -> [ (Compiler evaluate: id) class ]. - "thisContext could mean ContextPart or BlockClosure..." - "[ #thisContext ] -> [ ContextPart ]" - } otherwise: [ nil ] - ]. - ^self computeMessageEntries: receiverClass ]. - - (parser isPartialOrFullIdentifier: range rangeType) ifTrue: [ - ^self computeIdentifierEntries ]. - - "If we don't know what to do, do nothing" - entries _ #()! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3139-AutocompleterInInspectorsAndExplorers-JuanVuletich-2017Aug17-17h00m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3139] on 17 August 2017 at 9:26:32 pm'! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'jmv 9/22/2012 14:56' prior: 50365283! - morphHeight - -"Ensure everybody wants our coordinates!!" - self flag: #jmvVer2. - ^ extent y! ! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'jmv 2/16/2016 12:58' prior: 50365290! - morphPosition: newPos extent: newExtent - "Change the position of this morph. Argument is in owner's coordinates." - - | oldBoundsInWorld someChange | - - "Ask for the old bounds before updating them, but ask for repair only if extent or position has really changed." - oldBoundsInWorld _ self morphBoundsInWorld. - someChange _ false. - (location isTranslation: newPos) ifFalse: [ - location _ location withTranslation: newPos. - someChange _ true ]. - - extent = newExtent ifFalse: [ - (self privateExtent: newExtent) ifTrue: [ - someChange _ true ]]. - - someChange ifTrue: [ - "Ask for the old bounds before updating them, but ask for repair only if extent or position has really changed." - oldBoundsInWorld ifNotNil: [ - self invalidateDisplayRect: oldBoundsInWorld from: nil ]. - self someSubmorphPositionOrExtentChanged. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]! ! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'jmv 9/22/2012 14:57' prior: 50365322! - morphWidth - -"Ensure everybody wants our coordinates!!" - self flag: #jmvVer2. - ^ extent x! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:55:30' prior: 50365329! - draw3DLookOn: aCanvas - - | borderStyleSymbol c | - borderStyleSymbol _ self isPressed ifFalse: [ #raised ] ifTrue: [ #inset ]. - c _ color. - self mouseIsOver ifTrue: [ c _ c lighter ]. - aCanvas - fillRectangle: (`0@0` extent: extent) - color: c - borderWidth: borderWidth - borderStyleSymbol: borderStyleSymbol - baseColorForBorder: c. - - self drawRegularLabelOn: aCanvas! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 5/1/2015 16:20' prior: 50365344! - drawEmbossedLabelOn: aCanvas - - | availableW center colorForLabel f l labelMargin targetSize w x y | - label ifNotNil: [ - colorForLabel _ Theme current buttonLabel. - self isPressed - ifFalse: [ - self mouseIsOver - ifFalse: [ colorForLabel _ colorForLabel adjustSaturation: -0.10 brightness: 0.10 ]] - ifTrue: [ colorForLabel _ colorForLabel adjustSaturation: 0.0 brightness: -0.07 ]. - f _ self fontToUse. - center _ extent // 2. - labelMargin _ 3. - w _ f widthOfString: label. - availableW _ extent x - labelMargin - labelMargin. - availableW >= w - ifTrue: [ - l _ label ] - ifFalse: [ - x _ labelMargin. - targetSize _ label size * availableW // w. - l _ label squeezedTo: targetSize. - (f widthOfString: l) > availableW ifTrue: [ - targetSize _ targetSize - 1. - l _ label squeezedTo: targetSize ]]. - - w _ f widthOfString: l. - x _ center x - (w // 2). - y _ center y - (f height // 2). - aCanvas - drawString: l - at: x@y - font: f - color: colorForLabel - embossed: true ]! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 7/10/2014 22:43' prior: 50365380! - drawRegularLabelOn: aCanvas - - | w f center x y availableW l labelMargin | - - f _ self fontToUse. - center _ extent // 2. - - label ifNotNil: [ - labelMargin _ 4. - w _ f widthOfString: label. - availableW _ extent x - labelMargin - labelMargin - 1. - availableW >= w - ifTrue: [ - x _ center x - (w // 2). - l _ label ] - ifFalse: [ - x _ labelMargin. - l _ label squeezedTo: (label size * availableW / w) rounded ]. - y _ center y - (f height // 2). - self isPressed ifTrue: [ - x _ x + 1. - y _ y + 1 ]. - aCanvas - drawString: l - at: x@y - font: f - color: Theme current buttonLabel ]! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:55:46' prior: 50365403! - drawRoundGradientLookOn: aCanvas - | r colorForButton rect bottomFactor topFactor | - - self isPressed - ifFalse: [ - topFactor _ Theme current buttonGradientTopFactor. - bottomFactor _ Theme current buttonGradientBottomFactor. - self mouseIsOver - ifTrue: [ - colorForButton _ Color h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ - colorForButton _ color ]] - ifTrue: [ - topFactor _ Theme current buttonGradientBottomFactor. - bottomFactor _ Theme current buttonGradientTopFactor. - colorForButton _ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - Theme current useButtonGradient - ifTrue: [ - rect _ (`0@0` extent: extent) insetBy: `1@3`. - aCanvas - roundRect: rect - color: colorForButton - radius: r - gradientTop: topFactor - gradientBottom: bottomFactor - gradientHeight: Theme current buttonGradientHeight ] - ifFalse: [ - rect _ (`0@0` extent: extent) insetBy: `1@3`. - aCanvas roundRect: rect color: colorForButton radius: r ] - ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawEmbossedLabelOn: aCanvas ] - ifFalse: [ self drawRegularLabelOn: aCanvas ]! ! -!PluggableButtonMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:09:15' prior: 50365446! - initialize - "initialize the state of the receiver" - super initialize. - - roundButtonStyle _ nil. "nil: honor Theme. true: draw as round button. false: draw as classic 3d border square button" - model _ nil. - getStateSelector _ nil. - actionSelector _ nil. - isPressed _ false. - mouseIsOver _ false. - actWhen _ #buttonUp. - extent _ `20 @ 15`! ! -!PluggableButtonMorph methodsFor: 'private' stamp: 'jmv 2/17/2017 15:10:48' prior: 50365464! - magnifiedIcon - | factor magnifiedExtent w h | - - icon ifNil: [ ^nil ]. - magnifiedIcon ifNil: [ - magnifiedIcon _ icon. - w _ icon width. - h _ icon height. - w*h = 0 ifFalse: [ - factor _ 1.0 * extent x / w min: 1.0 * extent y / h. - (factor < 1 or: [ factor > 1.7 and: [self isRoundButton]]) ifTrue: [ - magnifiedExtent _ (icon extent * factor) rounded. - magnifiedIcon _ icon magnifyTo: magnifiedExtent ]]]. - ^magnifiedIcon! ! -!PluggableButtonMorph methodsFor: 'geometry testing' stamp: 'jmv 6/19/2017 15:55:52' prior: 50365482! - morphContainsPoint: aLocalPoint - - | iconOrigin | - ((`0@0` extent: extent) containsPoint: aLocalPoint) ifFalse: [ ^false ]. - ^ self isOrthoRectangularMorph or: [ - magnifiedIcon isNil or: [ - iconOrigin _ extent - magnifiedIcon extent // 2. - (magnifiedIcon isTransparentAt: (aLocalPoint - iconOrigin) rounded) not ]]! ! - -PluggableButtonMorph removeSelector: #morphExtent! - -PluggableButtonMorph removeSelector: #morphExtent! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3140-Revert-3124-BreaksExistingPackages-JuanVuletich-2017Aug17-21h24m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3140] on 17 August 2017 at 9:45:47 pm'! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 8/17/2017 21:37:11'! - raisedToFraction: aFraction - self isZero ifTrue: [ - aFraction negative ifTrue: [ - ^ (ZeroDivide dividend: 1) signal ]. - ^ self ]. - self negative ifFalse: [ - ^ (self ln * aFraction) exp ]. - aFraction denominator even ifTrue: [ - ^ ArithmeticError signal: 'nth root only defined for positive Integer n.' ]. - ^ (self negated ln * aFraction) exp negated! ! -!Fraction methodsFor: 'mathematical functions' stamp: 'jmv 8/17/2017 21:37:35'! - raisedToFraction: aFraction - | root | - root _ (self numerator nthRootTruncated: aFraction denominator) / - (self denominator nthRootTruncated: aFraction denominator). - (root raisedToInteger: aFraction denominator) = self ifTrue: [ - ^ root raisedToInteger: aFraction numerator ]. - ^ super raisedToFraction: aFraction! ! -!Integer methodsFor: 'mathematical functions' stamp: 'jmv 8/17/2017 21:37:42'! - raisedToFraction: aFraction - | root | - root _ self nthRootTruncated: aFraction denominator. - (root raisedToInteger: aFraction denominator) = self ifTrue: [ - ^ root raisedToInteger: aFraction numerator ]. - ^ super raisedToFraction: aFraction! ! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 8/17/2017 21:44:25' prior: 16880173! - raisedTo: aNumber - "Answer the receiver raised to aNumber." - - aNumber isInteger ifTrue: [ - "Do the special case of integer power" - ^ self raisedToInteger: aNumber]. - aNumber isFraction ifTrue: [ - "Special case for fraction power by Nicolas Cellier: - If aNumber is a fraction, but result must be a Float, learn it as quickly as possible, and give quick Float answer - Allows evaluating: - (2009/2000) raisedTo: (3958333/100000) - " - ^ self raisedToFraction: aNumber]. - self < 0 ifTrue: [ - ^ ArithmeticError signal: 'Negative numbers can''t be raised to float powers.' ]. - 0 = aNumber ifTrue: [^ self class one]. "Special case of exponent=0" - 1 = aNumber ifTrue: [^ self]. "Special case of exponent=1" - 0 = self ifTrue: [ "Special case of self = 0" - aNumber < 0 - ifTrue: [^ (ZeroDivide dividend: self) signal] - ifFalse: [^ self]]. - ^ (aNumber * self ln) exp "Otherwise use logarithms"! ! -!Fraction methodsFor: 'mathematical functions' stamp: 'jmv 8/17/2017 21:38:55' prior: 16849696! - nthRoot: aPositiveInteger - "Answer the nth root of the receiver." - | guess | - guess _ (numerator nthRootTruncated: aPositiveInteger) / - (denominator nthRootTruncated: aPositiveInteger). - (guess raisedTo: aPositiveInteger) = self ifTrue: [ - ^ guess ]. - "There is no exact nth root, so answer a Float approximation" - ^ (self abs ln / aPositiveInteger) exp * self sign! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3141-raisedTo-fix-NicolasCellier-2017Aug17-21h28m-jmv.1.cs.st----! - -----SNAPSHOT----#(17 August 2017 10:42:08.245774 pm) Cuis5.0-3141-32.image priorSource: 1139332! - -----QUIT----#(17 August 2017 10:42:19.431076 pm) Cuis5.0-3141-32.image priorSource: 1158521! - -----STARTUP----#(18 August 2017 6:05:53.559318 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3141-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3138] on 18 August 2017 at 3:36:55 pm'! -!Debugger methodsFor: 'code pane' stamp: 'jmv 8/18/2017 15:36:20' prior: 16829971! - contentsSelection - - "If we are just creating the method in the debugger, help the user by selecting the method body." - currentCompiledMethod ifNotNil: [ - ((currentCompiledMethod hasLiteral: #shouldBeImplemented) and: [ - (self selectedContext debuggerMap method abstractPCForConcretePC: self selectedContext pc) = 1]) ifTrue: [ - ^currentCompiledMethod selector size + 3 to: currentCompiledMethod getSource size ]]. - - ^self pcRange! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3142-autoSelectBodyIfCreateInDebugger-JuanVuletich-2017Aug18-15h00m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3141] on 18 August 2017 at 5:43:59 pm'! -!Workspace methodsFor: 'testing' stamp: 'jmv 8/18/2017 17:42:35'! - is: aSymbol - ^ aSymbol == #providesBindings or: [ super is: aSymbol ]! ! -!Debugger methodsFor: 'testing' stamp: 'jmv 8/18/2017 17:41:49'! - is: aSymbol - ^ aSymbol == #providesBindings or: [ super is: aSymbol ]! ! -!Inspector methodsFor: 'testing' stamp: 'jmv 8/18/2017 17:42:07'! - is: aSymbol - ^ aSymbol == #providesBindings or: [ super is: aSymbol ]! ! -!ObjectExplorer methodsFor: 'testing' stamp: 'jmv 8/18/2017 17:42:19'! - is: aSymbol - ^ aSymbol == #providesBindings or: [ super is: aSymbol ]! ! -!Inspector methodsFor: 'accessing' stamp: 'jmv 9/21/2009 15:16' prior: 50367456! - selectedClassOrMetaClass - - ^ self selectedClass "I don't know any better"! ! -!SmalltalkCompleter methodsFor: 'entries' stamp: 'jmv 8/18/2017 17:43:14' prior: 50367470! - computeEntries - - | allSource contextClass id specificModel last3Ranges range prevRange receiverClass prevPrevRange | - allSource _ model actualContents string. - specificModel _ (model is: #hasTextProvider) - ifTrue: [ model textProvider ] - ifFalse: [ model ]. - contextClass _ (specificModel is: #CodeProvider) ifTrue: [ - specificModel selectedClassOrMetaClass ]. - - "Instead of creating a new string, maybe we could pass the last position to parse to Shout..." - parser _ SHParserST80 new. - parser - workspace: ((specificModel is: #providesBindings) ifTrue: [specificModel]); - classOrMetaClass: contextClass; - source: (allSource copyFrom: 1 to: position). - parser parse. - last3Ranges _ parser last3Ranges. - range _ last3Ranges third. - range ifNil: [ ^entries _ #() ]. - - "If parsing breaks before position, then we don't know what to suggest, therefore don't open Completion" - range end = position ifFalse: [ ^entries _ #() ]. - - prefix _ allSource copyFrom: range start to: range end. - - (parser isMessage: range rangeType) ifTrue: [ - "If previous range is a constant or a well known identifier, we might filter messages" - prevRange _ last3Ranges second. - prevPrevRange _ last3Ranges first. - receiverClass _ nil. - "3 if -> ifNil: but not ifTrue: - 3=4 -> ifNil: or ifTrue:" - (prevRange notNil and: [ prevPrevRange isNil or: [ (#(binary keyword) includes: prevPrevRange rangeType) not]]) ifTrue: [ - id _ (allSource copyFrom: prevRange start to: prevRange end). - receiverClass _ prevRange rangeType caseOf: { - [ #globalVar ] -> [ (Smalltalk at: id asSymbol) class ]. - [ #self ] -> [ contextClass ]. - [ #super ] -> [ contextClass superclass ]. - [ #true ] -> [ True ]. - [ #false ] -> [ False ]. - [ #nil ] -> [ UndefinedObject ]. - [ #character ] -> [ id first class ]. - [ #number ] -> [ (Compiler evaluate: id) class ]. - [ #string ] -> [ (Compiler evaluate: id) class ]. - [ #symbol ] -> [ (Compiler evaluate: id) class ]. - [ #stringSymbol ] -> [ (Compiler evaluate: id) class ]. - "thisContext could mean ContextPart or BlockClosure..." - "[ #thisContext ] -> [ ContextPart ]" - } otherwise: [ nil ] - ]. - ^self computeMessageEntries: receiverClass ]. - - (parser isPartialOrFullIdentifier: range rangeType) ifTrue: [ - ^self computeIdentifierEntries ]. - - "If we don't know what to do, do nothing" - entries _ #()! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3143-fixRecentAutocompleteBug-JuanVuletich-2017Aug18-17h34m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3129] on 18 August 2017 at 9:07:32 am'! -!Message methodsFor: 'stub creation' stamp: 'HAW 8/18/2017 09:04:10'! - addGetterCodeOn: stream - - stream - newLine; tab; - nextPut: $^; - nextPutAll: selector ! ! -!Message methodsFor: 'stub creation' stamp: 'HAW 8/18/2017 09:04:52'! - addSetterCodeOn: stream with: argumentName - - stream - newLine; tab; - nextPutAll: selector allButLast; - nextPutAll: ' := '; - nextPutAll: argumentName ! ! -!Message methodsFor: 'stub creation' stamp: 'HAW 8/18/2017 07:43:09'! - writeShouldBeImplementedOn: stream. - - stream - nextPutAll: 'self '; - nextPutAll: #shouldBeImplemented; - nextPut: $.! ! -!Message methodsFor: 'testing' stamp: 'HAW 8/18/2017 07:40:37'! - isGetter - - ^selector isUnary and: [ lookupClass instVarNames includes: selector ]! ! -!Message methodsFor: 'testing' stamp: 'HAW 8/18/2017 07:44:22'! - isSetter - - ^selector isKeyword and: [ self numArgs = 1 and: [ lookupClass instVarNames includes: selector allButLast ]]! ! -!Message methodsFor: 'stub creation' stamp: 'HAW 8/18/2017 09:03:49' prior: 16867424! - createStubMethod - | argNames aOrAn argName arg argClassName | - - argNames _ Set new. - ^ String streamContents: [ :s | - self selector keywords withIndexDo: [ :key :i | - s nextPutAll: key. - ((key last = $:) or: [self selector isInfix]) ifTrue: [ - arg _ self arguments at: i. - argClassName _ (arg class isMeta) ifTrue: ['Class'] ifFalse: [arg class name]. - aOrAn _ argClassName first isVowel ifTrue: ['an'] ifFalse: ['a']. - argName _ aOrAn, argClassName. - [argNames includes: argName] whileTrue: [argName _ argName, i asString]. - argNames add: argName. - s nextPutAll: ' '; nextPutAll: argName; space - ]. - ]. - s newLine; tab. - self writeShouldBeImplementedOn: s. - self isGetter ifTrue: [ self addGetterCodeOn: s ]. - self isSetter ifTrue: [ self addSetterCodeOn: s with: argName ]. - ]! ! - -Message removeSelector: #createGetterStub! - -Message removeSelector: #createSetterStub! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3144-CreateAccessorsInDebugger-HernanWilkinson-2017Aug17-20h05m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3144] on 18 August 2017 at 6:03:22 pm'! -!Debugger methodsFor: 'code pane' stamp: 'jmv 8/18/2017 18:02:55' prior: 50367867! - contentsSelection - - "If we are just creating the method in the debugger, help the user by selecting the method body." - | sendInterval | - currentCompiledMethod ifNotNil: [ - ((currentCompiledMethod hasLiteral: #shouldBeImplemented) and: [ - (currentCompiledMethod abstractPCForConcretePC: self selectedContext pc) = 1]) ifTrue: [ - sendInterval _ (self selectedContext debuggerMap abstractSourceMap at: 2 ifAbsent: [nil]). - sendInterval ifNotNil: [ ^ sendInterval first - 5 to: sendInterval last + 1 ]]]. - - ^self pcRange! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3145-autoSelectOnCreateInDebugger-update-JuanVuletich-2017Aug18-17h52m-jmv.1.cs.st----! - -----SNAPSHOT----#(18 August 2017 6:06:00.467662 pm) Cuis5.0-3145-32.image priorSource: 1158619! - -----QUIT----#(18 August 2017 6:06:09.559904 pm) Cuis5.0-3145-32.image priorSource: 1166250! - -----STARTUP----#(28 August 2017 9:44:07.326256 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3145-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3145] on 22 August 2017 at 11:23:45 am'! -!Object methodsFor: 'message handling' stamp: 'HAW 8/22/2017 10:17:59'! -argumentName - - ^self argumentNameSufix prefixedWithAOrAn ! ! -!Object methodsFor: 'message handling' stamp: 'HAW 8/22/2017 10:16:01'! - argumentNameSufix - - ^self class isMeta ifTrue: ['Class'] ifFalse: [self class name]! ! -!String methodsFor: 'converting' stamp: 'HAW 8/22/2017 10:14:02'! - aOrAnPrefix - - ^self isEmpty - ifTrue: [ self ] - ifFalse: [ self first isVowel ifTrue: ['an'] ifFalse: ['a'] ] -! ! -!String methodsFor: 'converting' stamp: 'HAW 8/22/2017 10:14:46'! - prefixedWithAOrAn - - ^self aOrAnPrefix, self! ! -!Debugger methodsFor: 'method creation' stamp: 'HAW 8/22/2017 11:22:30' prior: 50336726! - implement: aMessage inClass: aClass context: aContext - - aClass - compile: (aMessage createStubMethodFor: aClass) - classified: (self askForCategoryIn: aClass default: 'as yet unclassified'). - - aContext privRefreshWith: (aClass lookupSelector: aMessage selector). - aMessage arguments withIndexDo: [ :arg :index | aContext tempAt: index put: arg ]. - self resetContext: aContext! ! -!Message methodsFor: 'stub creation' stamp: 'HAW 8/22/2017 11:23:03' prior: 50368001! - addGetterCodeOn: stream - - stream - newLine; tab; - nextPut: $^; - nextPutAll: selector ! ! -!Message methodsFor: 'stub creation' stamp: 'HAW 8/22/2017 11:23:07' prior: 50368007! - addSetterCodeOn: stream with: argumentName - - stream - newLine; tab; - nextPutAll: selector allButLast; - nextPutAll: ' := '; - nextPutAll: argumentName ! ! -!Message methodsFor: 'stub creation' stamp: 'HAW 8/22/2017 11:22:53'! - createStubMethodFor: aClass - - | argNames argName arg | - - argNames _ Set new. - ^ String streamContents: [ :s | - self selector keywords withIndexDo: [ :key :i | - s nextPutAll: key. - ((key last = $:) or: [self selector isInfix]) ifTrue: [ - arg _ self arguments at: i. - argName _ arg argumentName. - [argNames includes: argName] whileTrue: [argName _ argName, i asString]. - argNames add: argName. - s nextPutAll: ' '; nextPutAll: argName; space - ]. - ]. - - s newLine; tab. - self writeShouldBeImplementedOn: s. - (self isGetterFor: aClass) ifTrue: [ self addGetterCodeOn: s ]. - (self isSetterFor: aClass) ifTrue: [ self addSetterCodeOn: s with: argName ]. - ]! ! -!Message methodsFor: 'stub creation' stamp: 'HAW 8/22/2017 11:23:11' prior: 50368015! - writeShouldBeImplementedOn: stream. - - stream - nextPutAll: 'self '; - nextPutAll: #shouldBeImplemented; - nextPut: $.! ! -!Message methodsFor: 'testing' stamp: 'HAW 8/22/2017 11:22:40'! - isGetterFor: aClass - - ^selector isUnary and: [ aClass instVarNames includes: selector ]! ! -!Message methodsFor: 'testing' stamp: 'HAW 8/22/2017 11:22:43'! - isSetterFor: aClass - - ^selector isKeyword and: [ self numArgs = 1 and: [ aClass instVarNames includes: selector allButLast ]]! ! - -Message removeSelector: #createStubMethod! - -Message removeSelector: #createStubMethod! - -Message removeSelector: #isGetter! - -Message removeSelector: #isGetter! - -Message removeSelector: #isSetter! - -Message removeSelector: #isSetter! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3146-CreateAccessorsInDebuggerFix-HernanWilkinson-2017Aug19-20h52m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3145] on 23 August 2017 at 2:35:44 pm'! -!TextModelMorph methodsFor: 'accessing' stamp: 'HAW 8/23/2017 14:22:17'! - enableEdition - - self textMorph enableEdition! ! -!InnerTextMorph methodsFor: 'accessing' stamp: 'HAW 8/23/2017 14:23:36'! - enableEdition - - self removeProperty: #disablesEdition! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3147-textMorph-enableEdition-HernanWilkinson-2017Aug23-12h52m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3147] on 25 August 2017 at 10:56:35 am'! -!Object methodsFor: 'printing' stamp: 'jmv 8/25/2017 10:55:31' prior: 16882206! - printOn: aStream - "Append to the argument, aStream, a sequence of characters that - identifies the receiver." - - | title | - title _ self class name. - aStream - nextPutAll: title aOrAnPrefix; - space; - nextPutAll: title! ! -!Object methodsFor: 'printing' stamp: 'jmv 8/25/2017 10:55:49' prior: 16882255! - printWithClosureAnalysisOn: aStream - "Append to the argument, aStream, a sequence of characters that - identifies the receiver." - - | title | - title _ self class name. - aStream - nextPutAll: title aOrAnPrefix; - space; - nextPutAll: title! ! -!ContextPart methodsFor: 'debugger access' stamp: 'jmv 8/25/2017 10:55:54' prior: 16824084! - print: anObject on: aStream - "Safely print anObject in the face of direct ProtoObject subclasses." - | objClass title | - objClass _ self objectClass: anObject. - (objClass canUnderstand: #printOn:) ifTrue: [ - ^anObject printOn: aStream]. - title _ objClass name. - aStream - nextPutAll: title aOrAnPrefix; - space; - nextPutAll: title! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3148-Use-aOrAnPrefix-JuanVuletich-2017Aug25-10h53m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3128] on 23 July 2017 at 1:07:52 am'! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'pb 7/23/2017 00:53:45' prior: 50359409! - buildMorphicWindow - " - CodePackageListWindow open: CodePackageList new - " - | dirtyFlags names fileNames upperRow description summary backColor labelBackground textHeigth | - backColor := self textBackgroundColor. - labelBackground := Theme current background. - textHeigth := AbstractFont default height. - - dirtyFlags := PluggableListMorph - model: model - listGetter: #packageDirtyFlags - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - dirtyFlags color: backColor. - dirtyFlags := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorph: (StringMorph new contents: ' Unsaved?') fixedHeight: textHeigth; - addMorphUseAll: dirtyFlags. - - names := PluggableListMorph - model: model - listGetter: #packageNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - names color: backColor. - names := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorph: (StringMorph new contents: ' Package Name') fixedHeight: textHeigth; - addMorphUseAll: names. - - fileNames := PluggableListMorph - model: model - listGetter: #packageFullNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - fileNames color: backColor. - fileNames := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorph: (StringMorph new contents: ' File Name') fixedHeight: textHeigth; - addMorphUseAll: fileNames. - - upperRow := LayoutMorph newRow. - upperRow - addMorph: dirtyFlags proportionalWidth: 0.13; - addAdjusterAndMorph: names proportionalWidth: 0.27; - addAdjusterAndMorph: fileNames proportionalWidth: 0.6. - - description := TextModelMorph - textProvider: model - textGetter: #description - textSetter: #description:. - - summary := TextModelMorph - textProvider: model - textGetter: #summary. - - self layoutMorph - addMorph: upperRow proportionalHeight: 0.6; - addAdjusterAndMorph: self buildButtonPane fixedHeight: Theme current buttonPaneHeight; - addAdjusterAndMorph: summary fixedHeight: 60; - addAdjusterAndMorph: description proportionalHeight: 0.25; - addAdjusterAndMorph: self buildRequirementsPane proportionalHeight: 0.15. - self setLabel: 'Installed Packages'! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3149-CodePackageWindow-layout-tweak-PhilBellalouna-2017Jul23-00h53m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3128] on 23 July 2017 at 1:47:54 pm'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3150-category-cleanup-PhilBellalouna-2017Jul23-13h39m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3131] on 27 July 2017 at 3:27:46 am'! -!Debugger class methodsFor: 'opening' stamp: 'pb 7/27/2017 03:27:10' prior: 16830456! -openOn: process context: context label: title fullView: bool - "Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger." - | w | - Preferences logDebuggerStackToFile ifTrue: [ - Smalltalk - logError: title - inContext: context - to: 'CuisDebug.log' ]. - w := ProjectX newProcessIfUIX: process. - "schedule debugger in deferred UI message to address redraw - problems after opening a debugger e.g. from the testrunner." - WorldState addDeferredUIMessage: [ - [ | debugger | - "In case an error in Morphic code got us here, ensure mouse focus has been released" - true runningWorld ifNotNil: [ :rWorld | - rWorld activeHand ifNotNil: [ :aHand | - aHand releaseMouseFocus ]]. - debugger := self new - process: process - context: context. - debugger interruptedProcessUI: w. - bool - ifTrue: [ debugger openFullMorphicLabel: title ] - ifFalse: [ - PreDebugWindow - open: debugger - label: title - message: nil ]] - on: UnhandledError - do: [ :exOuter | | errorDescription | - errorDescription := 'Error while trying to open Debugger' , String newLineString , 'Orginal error: ' , title asString , '.' , String newLineString , ' Debugger error: ' , - ([ exOuter description ] - on: UnhandledError - do: [ :exInner | - exInner return: 'a ' , exInner class printString ]) , ':'. - self primitiveError: errorDescription ]]. - process suspend.! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3151-Debugger-ensure-focus-released-fix-PhilBellalouna-2017Jul27-03h27m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3130] on 27 July 2017 at 2:24:40 pm'! -!HierarchicalListMorph methodsFor: 'commands' stamp: 'pb 7/27/2017 14:24:23' prior: 16852992! - toggleExpandedState: aMorph event: event - - "self setSelectedMorph: aMorph." - ((self autoExpand or: [event shiftPressed]) and: [aMorph isExpanded not]) - ifTrue: [aMorph beFullyExpanded] - ifFalse: [aMorph toggleExpandedState]. - scroller adjustExtent. - self setScrollDeltas! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3152-HierarchicalListMorph-shift-key-fully-expands-PhilBellalouna-2017Jul27-14h17m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3130] on 27 July 2017 at 6:26:56 am'! - -TextProvider subclass: #FileList - instanceVariableNames: 'acceptedContentsCache fileName directory list listIndex pattern sortMode brevityState sortAscending showDirsInFileList currentDirectorySelected ' - classVariableNames: 'FileReaderRegistry ' - poolDictionaries: '' - category: 'Tools-FileList'! - -!classDefinition: #FileList category: #'Tools-FileList'! -TextProvider subclass: #FileList - instanceVariableNames: 'acceptedContentsCache fileName directory list listIndex pattern sortMode brevityState sortAscending showDirsInFileList currentDirectorySelected' - classVariableNames: 'FileReaderRegistry' - poolDictionaries: '' - category: 'Tools-FileList'! -!FileList class methodsFor: 'file reader registration' stamp: 'pb 7/27/2017 06:05:51' prior: 16843241! - itemsForFile: filename - "Answer a list of services appropriate for a file of the given name" - | services suffix classList | - suffix _ (FileIOAccessor default extensionFor: filename) asLowercase. - services _ OrderedCollection new. - "Build the list dynamically for all implementers of the appropriate class method... registration no longer required" - classList _ (Smalltalk allClassesImplementing: #fileReaderServicesForFile:suffix:) - collect: [ :item | - item class == Metaclass ifTrue: [ item soleInstance ]] - thenSelect: [ :item | - item notNil ]. - classList do: [ :reader | - reader ifNotNil: [ - services addAll: - (reader - fileReaderServicesForFile: filename - suffix: suffix) ]]. - ^ services.! ! -!FileList class methodsFor: 'file reader registration' stamp: 'pb 7/27/2017 06:02:20' prior: 16843256! - registerFileReader: aProviderClass - "For compatibility... no longer necessary"! ! -!FileList class methodsFor: 'file reader registration' stamp: 'pb 7/27/2017 06:02:32' prior: 16843266! - unregisterFileReader: aProviderClass - "For compatibility... no longer necessary"! ! - -Morph class removeSelector: #unload! - -Morph class removeSelector: #unload! - -Form class removeSelector: #unload! - -Form class removeSelector: #unload! - -FileList class removeSelector: #initialize! - -FileList class removeSelector: #initialize! - -ChangeSorter class removeSelector: #unload! - -ChangeSorter class removeSelector: #unload! - -ChangeList class removeSelector: #unload! - -ChangeList class removeSelector: #unload! - -CodeFileBrowser class removeSelector: #unload! - -CodeFileBrowser class removeSelector: #unload! - -MessageNames class removeSelector: #unload! - -MessageNames class removeSelector: #unload! - -TextProvider subclass: #FileList - instanceVariableNames: 'acceptedContentsCache fileName directory list listIndex pattern sortMode brevityState sortAscending showDirsInFileList currentDirectorySelected' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-FileList'! - -!classDefinition: #FileList category: #'Tools-FileList'! -TextProvider subclass: #FileList - instanceVariableNames: 'acceptedContentsCache fileName directory list listIndex pattern sortMode brevityState sortAscending showDirsInFileList currentDirectorySelected' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-FileList'! - -FileList initialize! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3153-FileList-dynamic-registration-PhilBellalouna-2017Jul27-05h59m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3153] on 25 August 2017 at 1:01:32 pm'! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'jmv 8/25/2017 13:00:40' prior: 50366872! - goDown - self selected = completer entryCount ifTrue: [ - "Wrap around" - ^ self goHome ]. - self selected: self selected + 1. - (self selected > self lastVisible - and: [self selected <= completer entryCount]) - ifTrue: [firstVisible := firstVisible + 1]. - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'jmv 8/25/2017 13:00:48' prior: 50366904! - goUp - (self selected = 0 - and: [self firstVisible = 1]) - ifTrue: [^ self]. - self selected = 1 ifTrue: [ - "Wrap around" - ^self goToEnd ]. - self selected: self selected - 1. - self selected < self firstVisible - ifTrue: [firstVisible := firstVisible - 1]. - self redrawNeeded! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3154-WraparoundAutoComplete-JuanVuletich-2017Aug25-12h57m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3145] on 28 August 2017 at 1:59:42 pm'! -!CompiledMethod class methodsFor: 'method encoding' stamp: 'HAW 8/28/2017 13:59:31' prior: 16821632! - headerFlagForEncoder: anEncoder - - (anEncoder class includesBehavior: PrimaryBytecodeSetEncoderClass) ifTrue: [^0]. - (anEncoder class includesBehavior: SecondaryBytecodeSetEncoderClass) ifTrue: [^SmallInteger minVal]. - - self error: 'The encoder is not one of the two installed bytecode sets'! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3155-AllowOtherMethodEncoders-HernanWilkinson-2017Aug28-13h56m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3145] on 28 August 2017 at 1:50:13 pm'! - -CodeWindow subclass: #BrowserWindow - instanceVariableNames: 'codePane ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Tools'! - -!classDefinition: #BrowserWindow category: #'Morphic-Tools'! -CodeWindow subclass: #BrowserWindow - instanceVariableNames: 'codePane' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Tools'! -!BrowserWindow methodsFor: 'updating' stamp: 'HAW 8/28/2017 13:44:30'! - disableCodePaneEdition - - codePane ifNotNil: [ codePane disableEdition ]! ! -!BrowserWindow methodsFor: 'updating' stamp: 'HAW 8/28/2017 13:41:24'! - editSelectionChanged - - self isEditSelectionNone - ifTrue: [ self disableCodePaneEdition ] - ifFalse: [ self enableCodePaneEdition]! ! -!BrowserWindow methodsFor: 'updating' stamp: 'HAW 8/28/2017 13:43:20'! - enableCodePaneEdition - - codePane ifNotNil: [ codePane enableEdition ]! ! -!BrowserWindow methodsFor: 'updating' stamp: 'HAW 8/28/2017 13:43:44'! - isEditSelectionNone - - ^ model editSelection = #none! ! -!BrowserWindow methodsFor: 'updating' stamp: 'HAW 8/28/2017 13:41:51'! -update: anEvent - super update: anEvent. - anEvent = #editSelection ifTrue: [self editSelectionChanged ] ! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'HAW 8/28/2017 13:39:41'! - buildMorphicCodePane - "Construct the pane that shows the code. - Respect the Preference for standardCodeFont." - - codePane _ super buildMorphicCodePane. - ^codePane! ! - -CodeWindow subclass: #BrowserWindow - instanceVariableNames: 'codePane' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Tools'! - -!classDefinition: #BrowserWindow category: #'Morphic-Tools'! -CodeWindow subclass: #BrowserWindow - instanceVariableNames: 'codePane' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Tools'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3156-DisableEditionIfNoSysCatSelected-HernanWilkinson-2017Aug23-14h35m-HAW.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3156] on 28 August 2017 at 5:05:29 pm'! -!MessageSet methodsFor: 'private' stamp: 'jmv 8/28/2017 17:05:18' prior: 16870086! - initializeMessageList: anArray - - messageList _ anArray. - messageList isEmpty - ifTrue: [ selectedMessage _ nil ] - ifFalse: [ - selectedMessage _ messageList first. - self editSelection: #editMessage ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3157-MessageSetFix-JuanVuletich-2017Aug28-16h59m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3157] on 28 August 2017 at 5:16:24 pm'! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 8/28/2017 17:06:34'! - reservedNames - - ^Theme current pseudoVariables! ! -!ClassBuilder methodsFor: 'private' stamp: 'jmv 8/28/2017 16:58:40' prior: 16804009! - reservedNames - "Return a list of names that must not be used for variables" - ^#(#self #super #true #false #nil #thisContext)! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 8/28/2017 16:51:25' prior: 16902210! -isIncompleteReservedName: aString - "Answer true if aString is the start of a reserved name, false otherwise" - - self reservedNames do: [ :arg | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 8/28/2017 16:53:14' prior: 16902288! - resolve: aString - - self reservedNames do: [ :symbol | aString = symbol ifTrue: [^symbol]]. - (self isBlockTempName: aString) ifTrue: [^#blockTempVar]. - (self isBlockArgName: aString) ifTrue: [^#blockArg]. - (self isMethodTempName: aString) ifTrue: [^#tempVar]. - (self isMethodArgName: aString) ifTrue: [^#methodArg]. - (self isInstVarName: aString) ifTrue: [^#instVar]. - (self isWorkspaceVarName: aString) ifTrue: [^#workspaceVar]. - Symbol hasInterned: aString ifTrue: [ :symbol | - (self isClassVarName: symbol) ifTrue: [ ^#classVar ]. - (self isPoolConstantName: symbol) ifTrue: [ ^#poolConstant]. - (self isGlobal: symbol) ifTrue: [^#globalVar]]. - ^self resolvePartial: aString! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 8/28/2017 16:52:46' prior: 16902979! - nonGlobalNamesDo: aBlock - "Evaluate aBlock over all available names, except for globals" - - self - blockArgNamesDo: aBlock; - blockTempNamesDo: aBlock; - methodArgNamesDo: aBlock; - methodTempNamesDo: aBlock; - instVarNamesDo: aBlock; - classVarNamesDo: aBlock; - poolConstantNamesDo: aBlock; - workspaceNamesDo: aBlock. - self - reservedNames do: aBlock! ! -!SHParserST80 methodsFor: 'testing' stamp: 'jmv 8/28/2017 17:14:20' prior: 16903020! - isPartialOrFullIdentifier: aSymbol - - (#(#incompleteIdentifier - #blockTempVar #blockArg #tempVar #methodArg - #instVar #classVar - #workspaceVar #poolConstant #globalVar ) - statePointsTo:aSymbol) ifTrue: [ ^ true ]. - (self reservedNames statePointsTo: aSymbol) ifTrue: [ ^ true ]. - ^ false! ! - -SHParserST80 removeSelector: #isReservedName:! - -SHParserST80 removeSelector: #isReservedName:! - -SHParserST80 removeSelector: #reservedNamesDo:! - -SHParserST80 removeSelector: #reservedNamesDo:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3158-AllowNewReservedNamesInSHParserST80-JuanVuletich-2017Aug28-17h12m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3158] on 28 August 2017 at 5:26:35 pm'! -!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jmv 8/25/2017 15:05:56' prior: 16888064! -label: aStringOrNil font: aFontOrNil - "Label this button with the given string." - label _ aStringOrNil. - font _ aFontOrNil. - (self fontToUse notNil and: [ label notNil ]) - ifTrue: [ "Add a bit of padding" - extent := (self fontToUse widthOfString: label) + 10 @ (self fontToUse height + 10) ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3159-SetAppropriateButtonExtent-JuanVuletich-2017Aug28-17h25m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3154] on 26 August 2017 at 7:48:09 pm'! -!TextModel methodsFor: 'user interface support' stamp: 'jmv 8/26/2017 19:19:29'! - formatAndStyleIfNeededWith: anSHTextStyler - anSHTextStyler ifNotNil: [ - (self shouldStyle: self actualContents with: anSHTextStyler) ifTrue: [ - anSHTextStyler formatAndStyle: self actualContents allowBackgroundStyleProcess: true. - self basicActualContents: anSHTextStyler formattedText ]]! ! -!PluggableTextModel methodsFor: 'shout styling' stamp: 'jmv 8/26/2017 19:21:51'! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text. - Set the classOrMetaClass in anSHTextStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - ^textProvider shouldStyle: text with: anSHTextStyler! ! -!Workspace methodsFor: 'shout styling' stamp: 'jmv 8/26/2017 19:21:53'! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text." - - self shouldStyle ifFalse: [ ^false ]. - anSHTextStyler - classOrMetaClass: nil; - workspace: self. - ^true! ! -!CodeProvider methodsFor: 'shout styling' stamp: 'jmv 8/26/2017 19:21:32'! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text. - Answer false if showing difs, to veto the styling." - - ^self showingAnyKindOfDiffs not! ! -!Browser methodsFor: 'shout styling' stamp: 'jmv 8/26/2017 19:21:20'! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text. - Set the classOrMetaClass in anSHTextStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - | type | - - self isModeStyleable ifFalse: [^false]. - type _ self editSelection. - (#(newMessage editMessage editClass newClass) includes: type) ifFalse:[^false]. - anSHTextStyler classOrMetaClass: (type = #editClass ifFalse:[self selectedClassOrMetaClass]). - ^true! ! -!MessageSet methodsFor: 'shout styling' stamp: 'jmv 8/26/2017 19:21:44'! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text. - Set the classOrMetaClass in anSHTextStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - - self isModeStyleable ifFalse: [^false]. - anSHTextStyler classOrMetaClass: self selectedClassOrMetaClass. - ^true! ! -!CodeFileBrowser methodsFor: 'shout styling' stamp: 'jmv 8/26/2017 19:21:30'! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text. - Set the classOrMetaClass in anSHTextStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - - self isModeStyleable ifFalse: [^false]. - anSHTextStyler classOrMetaClass: self selectedClassOrMetaClass. - ^true! ! -!ChangeList methodsFor: 'shout styling' stamp: 'jmv 8/26/2017 19:21:23'! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text. - Set the classOrMetaClass in anSHTextStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - - self isModeStyleable ifFalse: [^false]. - listIndex = 0 ifFalse: [ - (changeList at: listIndex) changeType = #method ifTrue: [ - self selectedClassOrMetaClass ifNotNil: [ :cl | - anSHTextStyler classOrMetaClass: cl. - ^true ]]]. - ^false! ! -!ChangeSorter methodsFor: 'shout styling' stamp: 'jmv 8/26/2017 19:21:27'! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text. - Set the classOrMetaClass in anSHTextStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - - self isModeStyleable ifFalse: [^false]. - self currentSelector ifNil: [^false]. - anSHTextStyler classOrMetaClass: self selectedClassOrMetaClass. - ^true! ! -!Debugger methodsFor: 'shout styling' stamp: 'jmv 8/26/2017 19:21:36'! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text. - Set the classOrMetaClass in anSHTextStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - - self isModeStyleable ifFalse: [^false]. - anSHTextStyler - classOrMetaClass: self selectedClassOrMetaClass; - disableFormatAndConvert; - workspace: self. - ^true! ! -!Inspector methodsFor: 'shout styling' stamp: 'jmv 8/26/2017 19:42:36'! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text. - Answer true to allow styling to proceed, or false to veto the styling" - - anSHTextStyler workspace: self. - ^(text = self acceptedContents) not! ! -!ObjectExplorer methodsFor: 'shout styling' stamp: 'jmv 8/26/2017 19:27:12'! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text. - Answer true to allow styling to proceed, or false to veto the styling" - - anSHTextStyler workspace: self. - ^true! ! -!Inspector methodsFor: 'contents' stamp: 'jmv 8/26/2017 19:40:39' prior: 16857103! - acceptedStringOrText - "We need our cache not to be modified by user editions" - ^acceptedContentsCache copy! ! -!InnerTextMorph methodsFor: 'editing' stamp: 'jmv 8/26/2017 19:07:20' prior: 16855670! - hasUnacceptedEdits: aBoolean - "Set the hasUnacceptedEdits flag to the given value. " - aBoolean == hasUnacceptedEdits ifFalse: [ - hasUnacceptedEdits _ aBoolean. - owner redrawNeeded]. - aBoolean ifFalse: [ hasEditingConflicts _ false]. - - "shout: re-style the text iff aBoolean is true - Do not apply any formatting (i.e. changes to the characters in the text), - just styling (i.e. TextAttributes)" - aBoolean ifTrue: [ - self formatAndStyleIfNeeded ]! ! -!InnerTextMorph methodsFor: 'shout' stamp: 'jmv 8/26/2017 19:14:13' prior: 16856199! - formatAndStyleIfNeeded - "Apply both formatting (changes to the characters in the text, such as - preferred assignment operators), and styling (TextAttributes to make - Smalltalk code easier to understand)" - - model formatAndStyleIfNeededWith: styler! ! - -InnerTextMorph removeSelector: #okToStyle! - -InnerTextMorph removeSelector: #okToStyle! - -ObjectExplorer removeSelector: #shoutAboutToStyle:! - -ObjectExplorer removeSelector: #shoutAboutToStyle:! - -Inspector removeSelector: #shoutAboutToStyle:! - -Inspector removeSelector: #shoutAboutToStyle:! - -Debugger removeSelector: #shoutAboutToStyle:! - -Debugger removeSelector: #shoutAboutToStyle:! - -ChangeSorter removeSelector: #shoutAboutToStyle:! - -ChangeSorter removeSelector: #shoutAboutToStyle:! - -ChangeList removeSelector: #shoutAboutToStyle:! - -ChangeList removeSelector: #shoutAboutToStyle:! - -CodeFileBrowser removeSelector: #shoutAboutToStyle:! - -CodeFileBrowser removeSelector: #shoutAboutToStyle:! - -MessageSet removeSelector: #shoutAboutToStyle:! - -MessageSet removeSelector: #shoutAboutToStyle:! - -Browser removeSelector: #shoutAboutToStyle:! - -Browser removeSelector: #shoutAboutToStyle:! - -CodeProvider removeSelector: #shoutAboutToStyle:! - -CodeProvider removeSelector: #shoutAboutToStyle:! - -Workspace removeSelector: #shoutAboutToStyle:! - -Workspace removeSelector: #shoutAboutToStyle:! - -PluggableTextModel removeSelector: #shoutAboutToStyle:! - -PluggableTextModel removeSelector: #shoutAboutToStyle:! - -TextModel removeSelector: #formatAndStyleWith:! - -TextModel removeSelector: #formatAndStyleWith:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3160-AvoidStylingInIspectorUntilEdit-JuanVuletich-2017Aug26-19h42m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3160] on 28 August 2017 at 9:40:53 pm'! - -ActiveModel subclass: #SimpleServiceEntry - instanceVariableNames: 'provider label selector useLineAfter stateSelector description argumentGetter buttonLabel argumentProvider triggerFileListChanged sortOrder ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-FileList'! - -!classDefinition: #SimpleServiceEntry category: #'Tools-FileList'! -ActiveModel subclass: #SimpleServiceEntry - instanceVariableNames: 'provider label selector useLineAfter stateSelector description argumentGetter buttonLabel argumentProvider triggerFileListChanged sortOrder' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-FileList'! -!SimpleServiceEntry methodsFor: 'accessing' stamp: 'jmv 8/28/2017 21:35:11'! - sortOrder - ^sortOrder! ! -!SimpleServiceEntry methodsFor: 'accessing' stamp: 'jmv 8/28/2017 21:28:07'! - sortOrder: aNumber - sortOrder _ aNumber! ! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'jmv 8/28/2017 21:40:08' prior: 16809512! - serviceBrowseCode - "Answer the service of opening a file-contents browser" - - ^ (SimpleServiceEntry - provider: self - label: 'code file browser' - selector: #browseCode: - description: 'open a "file-contents browser" on this file, allowing you to view and selectively load its code' - buttonLabel: 'code') - sortOrder: 10; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'jmv 8/28/2017 21:40:05' prior: 16809527! - serviceBrowsePackage - "Answer the service of opening a file-contents browser" - - ^ (SimpleServiceEntry - provider: self - label: 'package file browser' - selector: #browsePackage: - description: 'open a "package file browser" on this file, allowing you to view and selectively load its code' - buttonLabel: 'package browser') - sortOrder: 10; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!ChangeList class methodsFor: 'fileIn/Out' stamp: 'jmv 8/28/2017 21:39:59' prior: 16796992! - serviceContents - "Answer a service for opening a changelist browser on a file" - - ^ (SimpleServiceEntry - provider: self - label: 'code file contents' - selector: #browseContents: - description: 'open a code file contents tool on this file' - buttonLabel: 'contents') - sortOrder: 20; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!ChangeList class methodsFor: 'fileIn/Out' stamp: 'jmv 8/28/2017 21:39:55' prior: 16797005! - servicePackageContents - "Answer a service for opening a changelist browser on a file" - - ^ (SimpleServiceEntry - provider: self - label: 'package file contents' - selector: #browsePackageContents: - description: 'open a code file contents tool on this package file' - buttonLabel: 'pck contents') - sortOrder: 20; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!FileList class methodsFor: 'file reader registration' stamp: 'jmv 8/28/2017 21:39:36' prior: 50368462! - itemsForFile: filename - "Answer a list of services appropriate for a file of the given name" - | services suffix classList | - suffix _ (FileIOAccessor default extensionFor: filename) asLowercase. - "Build the list dynamically for all implementers of the appropriate class method... registration no longer required" - classList _ (Smalltalk allClassesImplementing: #fileReaderServicesForFile:suffix:) - collect: [ :item | - item class == Metaclass ifTrue: [ item soleInstance ]] - thenSelect: [ :item | - item notNil ]. - services _ OrderedCollection new. - classList do: [ :reader | - services addAll: - (reader - fileReaderServicesForFile: filename - suffix: suffix) ]. - services sort: [ :a :b | a sortOrder < b sortOrder ]. - ^ services.! ! -!ChangeSet class methodsFor: 'file list services' stamp: 'jmv 8/28/2017 21:28:59' prior: 16799248! - serviceFileIn - "Answer a service for filing in an entire file" - - ^ (SimpleServiceEntry - provider: self - label: 'fileIn entire file' - selector: #fileIn: - description: 'file in the entire contents of the file, which is expected to contain Smalltalk code in fileout ("chunk") format' - buttonLabel: 'filein') - sortOrder: 100; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!ChangeSet class methodsFor: 'file list services' stamp: 'jmv 8/28/2017 21:29:05' prior: 16799263! - serviceInstall - "Answer a service for filing in an entire file" - - ^ (SimpleServiceEntry - provider: self - label: 'install code' - selector: #install: - description: 'install change set' - buttonLabel: 'install') - sortOrder: 100; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!CodePackageFile class methodsFor: 'file list services' stamp: 'jmv 8/28/2017 21:29:39' prior: 16811207! - serviceInstallPackage - "Answer the service of installing a CodePackageFile (a chunk format file for a CodePackage)" - - ^ (SimpleServiceEntry - provider: self - label: 'install package' - selector: #installPackageStream: - description: 'install the package, replacing all existing code in the package (if any); create a new change set just for the installation' - buttonLabel: 'install package') - sortOrder: 100; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! - -ActiveModel subclass: #SimpleServiceEntry - instanceVariableNames: 'provider label selector useLineAfter stateSelector description argumentGetter buttonLabel argumentProvider triggerFileListChanged sortOrder' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-FileList'! - -!classDefinition: #SimpleServiceEntry category: #'Tools-FileList'! -ActiveModel subclass: #SimpleServiceEntry - instanceVariableNames: 'provider label selector useLineAfter stateSelector description argumentGetter buttonLabel argumentProvider triggerFileListChanged sortOrder' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-FileList'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3161-RestoreFileListButtonsOrder-JuanVuletich-2017Aug28-21h38m-jmv.1.cs.st----! - -----SNAPSHOT----#(28 August 2017 9:44:14.609051 pm) Cuis5.0-3161-32.image priorSource: 1166347! - -----QUIT----#(28 August 2017 9:44:28.524997 pm) Cuis5.0-3161-32.image priorSource: 1202379! - -----STARTUP----#(10 September 2017 6:04:43.903507 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3161-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3161] on 29 August 2017 at 3:54:37 pm'! -!Theme methodsFor: 'keyboard shortcuts' stamp: 'jmv 8/29/2017 15:53:47' prior: 16936827! - keyStroke: aKeyboardEvent morph: aMorph - aKeyboardEvent controlKeyPressed ifTrue: [^false]. - aKeyboardEvent commandAltKeyPressed ifFalse: [^false]. - - aKeyboardEvent keyValue = $w numericValue ifTrue: [ - aMorph owningWindow ifNotNil: [ :w | - (w morphContainsPoint: (w internalizeFromWorld: aKeyboardEvent eventPosition)) ifTrue: [ - w delete. - ^true ] ]]. -" aKeyboardEvent keyValue = $f numericValue - ifTrue: [aMorph owningWindow ifNotNil: [ :w | w fullScreen. ^true ]]. -" - ^ false! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3162-OnlyCloseWindowIfContainsMousePointer-JuanVuletich-2017Aug29-15h49m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3121] on 9 July 2017 at 7:49:17 pm'! -!Interval class methodsFor: 'instance creation' stamp: 'jmv 7/9/2017 16:59:23' prior: 16861363! - 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). - (newInterval hasEqualElements: aCollection) - ifFalse: [ 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 -"! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3163-IntervalFix-JuanVuletich-2017Jul09-16h58m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3163] on 31 August 2017 at 10:20:55 am'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3164-CategorizePinningProtocol-JuanVuletich-2017Aug31-10h17m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3164] on 6 September 2017 at 9:59:44 am'! -!SimpleServiceEntry methodsFor: 'initialization' stamp: 'jmv 9/6/2017 09:56:01' prior: 16908010! -initialize - triggerFileListChanged _ false. - sortOrder _ 1! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3165-FileListFix-JuanVuletich-2017Sep06-09h43m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3165] on 6 September 2017 at 10:08:50 am'! -!ReparseAfterSourceEditing commentStamp: 'jmv 9/6/2017 10:05:54' prior: 16900979! - A ReparseAfterSourceEditing is a Notification used to restart the syntax parsing phase of a compilation after a change in source code.! -!TextModelMorph methodsFor: 'accessing' stamp: 'jmv 9/6/2017 10:01:18'! - disableEditing - self textMorph disableEditing! ! -!TextModelMorph methodsFor: 'accessing' stamp: 'jmv 9/6/2017 10:03:26'! - enableEditing - - self textMorph enableEditing! ! -!BrowserWindow methodsFor: 'updating' stamp: 'jmv 9/6/2017 10:04:36'! - disableCodePaneEditing - - codePane ifNotNil: [ codePane disableEditing ]! ! -!BrowserWindow methodsFor: 'updating' stamp: 'jmv 9/6/2017 10:04:48'! - enableCodePaneEditing - - codePane ifNotNil: [ codePane enableEditing ]! ! -!InnerTextMorph methodsFor: 'accessing' stamp: 'jmv 9/6/2017 10:01:59'! - disableEditing - self setProperty: #disablesEditing toValue: true. - self stopBlinking! ! -!InnerTextMorph methodsFor: 'accessing' stamp: 'jmv 9/6/2017 10:03:03'! -enableEditing - - self removeProperty: #disablesEditing! ! -!InnerTextMorph methodsFor: 'event handling testing' stamp: 'jmv 9/6/2017 10:02:01'! - disablesEditing - - ^self hasProperty: #disablesEditing! ! -!Inspector methodsFor: 'contents' stamp: 'jmv 9/6/2017 10:05:31' prior: 50368953! - acceptedStringOrText - "We need our cache not to be modified by user changes" - ^acceptedContentsCache copy! ! -!TextEditor methodsFor: 'accessing' stamp: 'jmv 9/6/2017 10:02:22' prior: 16931330! - replaceSelectionWith: aTextOrString - "Deselect, and replace the selection text by aText." - "This is a user command, and generates undo" - - | start stop replacement | - - morph disablesEditing ifTrue: [ - ^ self ]. - - start _ self startIndex. - stop _ self stopIndex. - (aTextOrString isEmpty and: [stop > start]) ifTrue: [ - "If deleting, then set emphasisHere from 1st character of the deletion" - emphasisHere _ (model actualContents attributesAt: start) select: [:att | - att mayBeExtended]]. - - (start = stop and: [ aTextOrString isEmpty ]) ifFalse: [ - replacement _ self addAttributesForPasting: aTextOrString. - model logUndoAndReplaceFrom: start to: stop - 1 with: replacement. - textComposition - recomposeFrom: start - to: start + replacement size - 1 - delta: replacement size - (stop-start). - self deselectAndPlaceCursorAt: start + replacement size. - selectionStartBlocks _ #(). - selectionStopBlocks _ #(). - self userHasEdited " -- note text now dirty" ]. - - morph possiblyChanged! ! -!TextEditor methodsFor: 'private' stamp: 'jmv 9/6/2017 10:02:19' prior: 16932614! - applyAttribute: aTextAttribute - "The user selected aTextAttribute via shortcut, menu or other means. - If there is a selection, apply the attribute to the selection. - In any case use the attribute for the user input (emphasisHere)" - "This generates undo" - | anythingDone | - - morph disablesEditing ifTrue: [ - ^ self ]. - - anythingDone _ false. - emphasisHere _ Text addAttribute: aTextAttribute toArray: emphasisHere. - self selectionIntervalsDo: [ :interval | - (interval notEmpty or: [ aTextAttribute isParagraphAttribute ]) - ifTrue: [ - anythingDone _ true. - model logUndoAndAddAttribute: aTextAttribute from: interval first to: interval last. - textComposition recomposeFrom: interval first to: interval last delta: 0 ]]. - anythingDone ifTrue: [ - self recomputeSelection. "Needed so visible selection is updated to reflect new visual extent of selection" - self userHasEdited ]. - - "Even if nothing done, emphasisHere might have changed" - morph possiblyChanged! ! -!TextEditor methodsFor: 'undo & redo' stamp: 'jmv 9/6/2017 10:02:20' prior: 16933011! - redo - - morph disablesEditing ifTrue: [ - ^ self ]. - - model redoAndEvaluate: [ :modelUpdated :newCursorPos | - newCursorPos - ifNil: [ self recomputeSelection ] - ifNotNil: [ self markIndex: newCursorPos pointIndex: newCursorPos ]. - modelUpdated ifTrue: [ - self userHasEdited. - textComposition composeAll. "this could be made more specific..." - morph possiblyChanged ]]! ! -!TextEditor methodsFor: 'undo & redo' stamp: 'jmv 9/6/2017 10:02:24' prior: 16933031! - undo - - morph disablesEditing ifTrue: [ - ^ self ]. - - model undoAndEvaluate: [ :modelUpdated :newCursorPos | - newCursorPos - ifNil: [ self recomputeSelection ] - ifNotNil: [ self markIndex: newCursorPos pointIndex: newCursorPos ]. - modelUpdated ifTrue: [ - self userHasEdited. - textComposition composeAll. "this could be made more specific..." - morph possiblyChanged ]]! ! -!BrowserWindow methodsFor: 'updating' stamp: 'jmv 9/6/2017 10:04:55' prior: 50368613! - editSelectionChanged - - self isEditSelectionNone - ifTrue: [ self disableCodePaneEditing ] - ifFalse: [ self enableCodePaneEditing]! ! -!InnerTextMorph methodsFor: 'blinking cursor' stamp: 'jmv 9/6/2017 10:02:07' prior: 16856157! - showsBlinkingCursor - - ^self handlesKeyboard and: [ self disablesEditing not ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3166-ItIsEditingNotEdition-JuanVuletich-2017Sep06-10h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3165] on 6 September 2017 at 10:09:36 am'! - -InnerTextMorph removeSelector: #disableEdition! - -InnerTextMorph removeSelector: #disableEdition! - -InnerTextMorph removeSelector: #disablesEdition! - -InnerTextMorph removeSelector: #disablesEdition! - -InnerTextMorph removeSelector: #enableEdition! - -InnerTextMorph removeSelector: #enableEdition! - -BrowserWindow removeSelector: #disableCodePaneEdition! - -BrowserWindow removeSelector: #disableCodePaneEdition! - -BrowserWindow removeSelector: #enableCodePaneEdition! - -BrowserWindow removeSelector: #enableCodePaneEdition! - -TextModelMorph removeSelector: #disableEdition! - -TextModelMorph removeSelector: #disableEdition! - -TextModelMorph removeSelector: #enableEdition! - -TextModelMorph removeSelector: #enableEdition! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3167-EditionMisnomerCleanup-JuanVuletich-2017Sep06-10h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3162] on 4 September 2017 at 5:01:33 pm'! - -ChangeList subclass: #ChangeListWithFileInErrors - instanceVariableNames: 'errors' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #ChangeListWithFileInErrors category: #'Tools-Changes'! -ChangeList subclass: #ChangeListWithFileInErrors - instanceVariableNames: 'errors' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! -!ChangeListWithFileInErrors commentStamp: 'HAW 9/4/2017 10:23:05' prior: 0! - This class is used to keep errors when filing in changes. -I could have use ChangeList directly, selecting changes with errors, then removing them, etc., but it had some problems and that solution is more a hack. -So, instances of this class will keep errors when filing in a change, and it allows the posibility to show the change with the error in a change list window. - -A doit change that signaled a MessageNotUnderstood is assume to not be an error becuase those kinds of things are evaluations in specific contexts that will obiously generate errors. -All doits with errors could be assume not to be errors, but I limited to MNU type of errors to avoid filtering errors that should be shown.! -!ChangeListWithFileInErrors methodsFor: 'filing in' stamp: 'HAW 9/4/2017 09:34:35'! - fileInAllKeepingErrors - - errors := Dictionary new. - changeList do: [ :change | self fileInKeepingError: change ]. -! ! -!ChangeListWithFileInErrors methodsFor: 'filing in' stamp: 'HAW 9/4/2017 16:36:13'! - fileInKeepingError: change - - [ change fileIn ] - on: Error - do: [ :anError | (self hasToKeep: anError for: change) ifTrue: [ errors at: change put: anError ]]! ! -!ChangeListWithFileInErrors methodsFor: 'initialization-release' stamp: 'HAW 9/4/2017 09:34:20'! - initialize - - super initialize. - errors := Dictionary new.! ! -!ChangeListWithFileInErrors methodsFor: 'testing' stamp: 'HAW 9/4/2017 09:37:00'! - hasFileInErrors - - ^errors notEmpty! ! -!ChangeListWithFileInErrors methodsFor: 'testing' stamp: 'HAW 9/4/2017 16:37:07'! - hasToKeep: anError for: change - - ^(change isDoIt and: [ anError isKindOf: MessageNotUnderstood ]) not! ! -!ChangeListWithFileInErrors methodsFor: 'showing filein errors' stamp: 'HAW 9/4/2017 10:01:06'! - failedFileInChangesLabel - - ^'Changes that failed to file in'! ! -!ChangeListWithFileInErrors methodsFor: 'showing filein errors' stamp: 'HAW 9/4/2017 10:45:43'! -ifFiledInWithErrorAdd: aChange at: anIndex to: newChangeList and: newList - - (self wasFiledInWithError: aChange) ifTrue: [ - newChangeList add: aChange. - newList add: ((list at: anIndex) contractTo: 40), ' | ', (errors at: aChange) printString ]! ! -!ChangeListWithFileInErrors methodsFor: 'showing filein errors' stamp: 'HAW 9/4/2017 10:04:47'! - removeSucessfullyFiledInChanges - - | newChangeList newList | - - newChangeList := OrderedCollection new. - newList := OrderedCollection new. - - changeList withIndexDo: [ :aChange :anIndex | self ifFiledInWithErrorAdd: aChange at: anIndex to: newChangeList and: newList ]. - - changeList _ newChangeList. - list _ newList. - listIndex _ 0. - self clearSelections. - self changed: #list.! ! -!ChangeListWithFileInErrors methodsFor: 'showing filein errors' stamp: 'HAW 9/4/2017 10:02:20'! - showChangesWithFileInErrors - - self removeSucessfullyFiledInChanges. - ChangeListWindow open: self label: self failedFileInChangesLabel - -! ! -!ChangeListWithFileInErrors methodsFor: 'showing filein errors' stamp: 'HAW 9/4/2017 10:46:01'! - wasFiledInWithError: aChange - - ^errors includesKey: aChange! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:48:40'! - logSnapshot: save andQuit: quit - "Log quitting to changes file" - | msg | - (SourceFiles at: 2) ifNotNil: [ - msg _ self snapshotMessageFor: save andQuit: quit. - self assureStartupStampLogged. - save ifTrue: [ - LastQuitLogPosition _ (SourceFiles at: 2) - setToEnd; - position ]. - self logChange: msg. - Transcript - newLine; - show: msg; - newLine ]! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:42:57'! - nopTag - - ^ 'NOP'! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:42:27'! - quitNoSaveTag - - ^ 'QUIT/NOSAVE' ! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:40:45'! - quitTag - - ^'QUIT'! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:51:51'! - snapshotMessageFor: save andQuit: quit - - ^String streamContents: [ :stream | - stream - nextPutAll: self tagHeader; - nextPutAll: (self snapshotTagFor: save andQuit: quit); - nextPutAll: self tagTail; - print: Date dateAndTimeNow; - space; - nextPutAll: self imageName asFileEntry name; - nextPutAll: ' priorSource: '; - print: LastQuitLogPosition ].! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:41:19'! - snapshotTag - - ^'SNAPSHOT'! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:51:20'! - snapshotTagFor: save andQuit: quit - - ^save - ifTrue: [ quit - ifTrue: [ self quitTag ] - ifFalse: [ self snapshotTag ]] - ifFalse: [ quit - ifTrue: [ self quitNoSaveTag ] - ifFalse: [ self nopTag ]]! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:45:54'! - tagHeader - - ^ '----'! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:46:02'! - tagTail - - ^ self tagHeader! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:11:51'! - hasToRestoreChanges - - ^self withChangesFileDo: [ :changesFile | - changesFile position: self lastQuitLogPosition. - self hasToRestoreChangesFrom: changesFile ]. - ! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 16:41:24'! - hasToRestoreChangesFrom: changesFile - - | chunk | - - [ changesFile atEnd ] whileFalse: [ chunk := changesFile nextChunk ]. - - ^(self isSnapshotQuitOrQuitNoSaveRecord: chunk) not -! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 08:56:02'! - isQuitNoSaveRecord: chunk - - ^chunk beginsWith: self tagHeader, self quitNoSaveTag - ! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 08:55:51'! - isQuitRecord: chunk - - ^chunk beginsWith: self tagHeader, self quitTag ! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 16:34:34'! - isSnapshotQuitOrQuitNoSaveRecord: chunk - - ^(self isSnapshotRecord: chunk) - or: [ (self isQuitRecord: chunk) - or: [ self isQuitNoSaveRecord: chunk ]]! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 08:57:09'! - isSnapshotRecord: chunk - - ^chunk beginsWith: self tagHeader, self snapshotTag - ! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 09:07:35'! - lostChangesDetectedCaption - - ^ -'Last changes may have been lost -(maybe the VM crashed or you had to kill it) -What do you want to do?'! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:25:45'! - restoreLostChanges - - | decision | - - decision := PopUpMenu withCaption: self lostChangesDetectedCaption chooseFrom: self restoreLostChangesOptions. - - decision = 1 ifTrue: [ ^self restoreLostChangesAutomatically ]. - decision = 2 ifTrue: [ ^self restoreLostChangesManually ]! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:13:01'! - restoreLostChangesAutomatically - - self withChangesFileDo: [ :aChangesFile | self restoreLostChangesAutomaticallyFrom: aChangesFile ]! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 10:15:16'! - restoreLostChangesAutomaticallyFrom: aChangesFile - - | changeList | - - changeList := ChangeListWithFileInErrors new. - changeList scanFile: aChangesFile from: LastQuitLogPosition to: aChangesFile size. - changeList fileInAllKeepingErrors. - (changeList hasFileInErrors and: [ self shouldShowFileInErrors ]) ifTrue: [ changeList showChangesWithFileInErrors ] -! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:09:39'! - restoreLostChangesIfNecessary - - " - Smalltalk restoreLostChangesIfNecessary - " - - self hasToRestoreChanges ifTrue: [ WorldState addDeferredUIMessage: [self restoreLostChanges ]]. -! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/1/2017 17:28:22'! - restoreLostChangesManually - - ChangeList browseRecentLog! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:25:55'! - restoreLostChangesOptions - - ^{'Restore lost changes automatically'. 'Restore lost changes manually'. 'Nothing'}.! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:29:46'! - restoringChangesHasErrorsCaption - - ^'There were errors filing in the lost changes. Do you want to see them?'! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 09:37:34'! - shouldShowFileInErrors - - ^self confirm: self restoringChangesHasErrorsCaption - ! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:11:39'! - withChangesFileDo: aBlock - - ^self currentChangesName asFileEntry readStreamDo: aBlock! ! -!ChangeRecord methodsFor: 'testing' stamp: 'HAW 9/4/2017 06:32:29'! - isDoIt - - ^type = #doIt! ! -!ChangeList methodsFor: 'menu actions' stamp: 'HAW 9/4/2017 10:26:32' prior: 16796254! - removeDoIts - "Remove doits from the receiver, other than initializes. 1/26/96 sw" - - | newChangeList newList | - newChangeList _ OrderedCollection new. - newList _ OrderedCollection new. - - changeList with: list do: [ :chRec :str | - (chRec isDoIt not or: [str endsWith: 'initialize']) - ifTrue: [ - newChangeList add: chRec. - newList add: str]]. - newChangeList size < changeList size - ifTrue: [ - changeList _ newChangeList. - list _ newList. - listIndex _ 0. - self clearSelections ]. - self changed: #list. - - ! ! -!ChangeList methodsFor: 'menu actions' stamp: 'HAW 9/4/2017 10:26:50' prior: 16796515! - selectRemovalsOfSent - "Selects all method removal for sent methods" - - 1 to: changeList size do: [ :i | | change | - change _ changeList at: i. - listSelections at: i put: - (change isDoIt and: [ - change string includesSubString: 'removeSelector: #' ] and: [ - Smalltalk isThereAReferenceTo: (change string copyAfterLast: $#) asSymbol ]) ]. - self changed: #allSelections. - self changed: #annotation! ! -!ChangeList class methodsFor: 'public access' stamp: 'HAW 9/4/2017 10:32:00' prior: 16796892! - browseRecentLogOn: origChangesFileName - "figure out where the last snapshot or quit was, then browse the recent entries." - - | end done block positions prevBlock | - origChangesFileName asFileEntry readStreamDo: [ :changesFile | - positions _ SortedCollection new. - end _ changesFile size. - prevBlock _ end. - block _ end - 1024 max: 0. - done _ false. - [ done or: [ positions size > 0 ]] - whileFalse: [ - changesFile position: block. - "ignore first fragment" - changesFile nextChunk. - [ changesFile position < prevBlock ] - whileTrue: [ - | pos chunk | - pos _ changesFile position. - chunk _ changesFile nextChunk. - ((Smalltalk isQuitRecord: chunk) or: [ Smalltalk isSnapshotRecord: chunk ]) - ifTrue: [ positions add: pos ]]. - block = 0 - ifTrue: [done _ true] - ifFalse: [ - prevBlock _ block. - block _ block - 1024 max: 0]]. - ]. - positions isEmpty - ifTrue: [self inform: 'File ' , origChangesFileName , ' does not appear to be a changes file'] - ifFalse: [self browseRecentLogOn: origChangesFileName startingFrom: positions last]! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:46:37' prior: 50361391! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag -"WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " -| activeProc | -activeProc _ Processor activeProcess. -[ - | isARealStartup world reopenTranscript | - self logSnapshot: save andQuit: quit. - - reopenTranscript _ false. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | each isInWorld ifTrue: [ each delete. reopenTranscript _ true ]]. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - - - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - - "Cosas que levanto explicitamente abajo" - world _ ProjectX ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "world _ clearAllStateFlag ifFalse: [ ProjectX ui ]." - ProjectX stopUIProcess. - activeProc isTerminated ifFalse: [ - activeProc terminate ]. - - "Clean Globals" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: nil. - Smalltalk closeSourceFiles. Smalltalk at: #SourceFiles put: nil. - Smalltalk allClassesDo: [ :cls | cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ Smalltalk printStuffToCleanOnImageSave ]. - - - "Do image save & quit as apropriate" - Cursor write activateCursor. - save - ifTrue: [ - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - - - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: (DisplayScreen extent: `1024@768` depth: 32). - Smalltalk at: #SourceFiles put: (Array new: 2). - Smalltalk openSourceFiles. - - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - - - ProjectX spawnNewMorphicProcessFor: (world ifNil: [ PasteUpMorph newWorld ]). - - reopenTranscript ifTrue: [ - WorldState addDeferredUIMessage: [ - TranscriptWindow openTranscript ]]. - " - WorldState addDeferredUIMessage: [ - world fullRepaintNeeded ]. - " - - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - WorldState addDeferredUIMessage: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]. - -] forkAt: Processor timingPriority-1 named: 'Startup process'.! ! -!SystemDictionary methodsFor: 'startup' stamp: 'HAW 9/4/2017 06:14:44' prior: 50335326! - doStartUp: isARealStartup - " - isARealStartup - true: system is coming up (VM and image just started) - false: we have just saved an image snapshot, but didn't quit. - " - - "Here, startup begins!!" - Cursor normal activateCursor. - self setGCParameters. - isARealStartup ifTrue: [ - self clearExternalObjects ]. - self readCommandLineArguments. - self processStartUpList: isARealStartup. - isARealStartup ifTrue: [ - self setPlatformPreferences. - self setStartupStamp. - self restoreLostChangesIfNecessary ]! ! -!ChangeRecord methodsFor: 'initialization' stamp: 'HAW 9/4/2017 10:27:15' prior: 16797438! - fileIn - "File the receiver in. If I represent a method or a class-comment, file the method in and make a note of it in the recent-submissions list; if I represent a do-it, then, well, do it." - | s | - type == #method ifTrue: [ - self changeClass ifNotNil: [ :methodClass | - methodClass - compile: self text - classified: category - withStamp: stamp - notifying: nil ]]. - self isDoIt ifTrue: [ - ((s _ self string) beginsWith: '----') ifFalse: [ Compiler evaluate: s ]]. - type == #classDefinition ifTrue: [ Compiler evaluate: self string ]. - type == #classComment ifTrue: [ - (Smalltalk at: class asSymbol) - comment: self text - stamp: stamp ]! ! - -SystemDictionary removeSelector: #logSapshot:andQuit:! - -SystemDictionary removeSelector: #logSapshot:andQuit:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3168-AidInRecoveringChanges-HernanWilkinson-2017Sep01-13h49m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3168] on 10 September 2017 at 4:47:52 pm'! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'jmv 9/10/2017 16:44:03'! - withNextDo: twoArgBlock - "Evaluate the block with each element and the one following it. - For the last element, next is nil - (1 to: 10) asArray withNextDo: [ :each :next | {each. next} print ] - #() withNextDo: [ :a :b | {a. b} print ] - " - | first previous | - first _ true. - self do: [ :each | - first ifTrue: [ - first _ false ] - ifFalse: [ - twoArgBlock value: previous value: each ]. - previous _ each ]. - first ifFalse: [ - twoArgBlock value: previous value: nil ]! ! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'jmv 9/10/2017 16:44:25'! - withPreviousDo: twoArgBlock - "Evaluate the block with each element and the one before it. - For the first element, previous is nil - (1 to: 10) asArray withPreviousDo: [ :each :previous | {previous. each} print ] - #() withPreviousDo: [ :a :b | {a. b} print ] - " - | previous | - previous _ nil. - self do: [ :each | - twoArgBlock value: each value: previous. - previous _ each ].! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3169-withNextDo-withPreviousDo-JuanVuletich-2017Sep10-16h47m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3168] on 10 September 2017 at 4:29:09 pm'! - -TextAttribute subclass: #TextBackgroundColor - instanceVariableNames: 'color' - classVariableNames: '' - poolDictionaries: '' - category: 'System-TextAttributes'! - -!classDefinition: #TextBackgroundColor category: #'System-TextAttributes'! -TextAttribute subclass: #TextBackgroundColor - instanceVariableNames: 'color' - classVariableNames: '' - poolDictionaries: '' - category: 'System-TextAttributes'! -!TextBackgroundColor commentStamp: '' prior: 0! - A TextBackgroundColor encodes a highlight (background) color change applicable over a given range of text.! - -TextBackgroundColor subclass: #ShoutTextBackgroundColor - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'System-TextAttributes'! - -!classDefinition: #ShoutTextBackgroundColor category: #'System-TextAttributes'! -TextBackgroundColor subclass: #ShoutTextBackgroundColor - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'System-TextAttributes'! -!ShoutTextBackgroundColor commentStamp: '' prior: 0! - Just for code styler (Shout)! - -CharacterScanner subclass: #MorphicScanner - instanceVariableNames: 'canvas lineY foregroundColor defaultColor topLeft ignoreColorChanges backgroundColor ' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Text'! - -!classDefinition: #MorphicScanner category: #'Graphics-Text'! -CharacterScanner subclass: #MorphicScanner - instanceVariableNames: 'canvas lineY foregroundColor defaultColor topLeft ignoreColorChanges backgroundColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Text'! -!TextAttribute methodsFor: 'iterating' stamp: 'jmv 9/7/2017 16:45:20'! - forTextBackgroundColorDo: aBlock - "No action is the default"! ! -!TextBackgroundColor methodsFor: 'accessing' stamp: 'jmv 9/7/2017 16:41:55'! - color - ^ color! ! -!TextBackgroundColor methodsFor: 'accessing' stamp: 'jmv 9/7/2017 16:41:55'! - color: aColor - color _ aColor! ! -!TextBackgroundColor methodsFor: 'comparing' stamp: 'jmv 9/7/2017 16:41:55'! - = other - self == other ifTrue: [ ^ true ]. - ^ (other class == self class) - and: [other color = color]! ! -!TextBackgroundColor methodsFor: 'comparing' stamp: 'jmv 9/7/2017 16:41:55'! - hash - ^ color hash! ! -!TextBackgroundColor methodsFor: 'printing' stamp: 'jmv 9/7/2017 16:41:55'! - printOn: strm - super printOn: strm. - strm nextPutAll: ' code: '; print: color! ! -!TextBackgroundColor methodsFor: 'scanning' stamp: 'jmv 9/7/2017 16:41:55'! - dominates: other - ^ other class == self class! ! -!TextBackgroundColor methodsFor: 'iterating' stamp: 'jmv 9/7/2017 16:45:12'! - forTextBackgroundColorDo: aBlock - aBlock value: color! ! -!TextBackgroundColor methodsFor: 'testing' stamp: 'jmv 9/7/2017 16:44:40'! - isSet - "Do not include Color black, as it is the default color." - ^color isTransparent not! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - black - ^ self new color: Color black! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - blue - ^ self new color: Color blue! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - cyan - ^ self new color: Color cyan! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - gray - ^ self new color: Color gray! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - green - ^ self new color: Color green! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - magenta - ^ self new color: Color magenta! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - red - ^ self new color: Color red! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - white - ^ self new color: Color white! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - yellow - ^ self new color: Color yellow! ! -!TextBackgroundColor class methodsFor: 'instance creation' stamp: 'jmv 9/7/2017 16:41:55'! - color: aColor - ^ self new color: aColor! ! -!ShoutTextBackgroundColor methodsFor: 'testing' stamp: 'jmv 9/7/2017 16:42:03'! - isForShout - "True if to be removed from code before styling" - ^true! ! -!CharacterScanner methodsFor: 'private' stamp: 'jmv 9/7/2017 17:00:23'! - backgroundColor: ignored - "Overridden in MorphicScanner"! ! -!MorphicScanner methodsFor: 'private' stamp: 'jmv 9/7/2017 16:56:38'! - backgroundColor: aColor - backgroundColor _ aColor! ! -!Text methodsFor: 'emphasis' stamp: 'jmv 9/10/2017 16:28:51' prior: 16929486! - withAttributeValues: attributes do: aBlock - "Evaluate aBlock with the values of various attributes that affect text formatting, applied in the correct order - The order is (each overwriting the previous one) - 1) basic defaults - 2) ParagraphStyleReferene - 3) CharacterStyleReference - 4) TextFontReference - 5) TextEmphasis" - - | paragraphStyle characterStyle familyName pointSize emphasis alignment color backgroundColor | - paragraphStyle _ nil. - characterStyle _ nil. - familyName _ nil. - pointSize _ nil. - emphasis _ 0. - alignment _ 0. - color _ nil. - backgroundColor _ nil. - - "ParagraphStyle is the first to set several values" - attributes do: [ :attribute | - attribute forParagraphStyleReferenceDo: [ :s | - paragraphStyle _ s. - familyName _ s familyName. - pointSize _ s pointSize. - emphasis _ s emphasis. - alignment _ s alignment. - s color ifNotNil: [ :c | color _ c ]]]. - - "CharacterStyle, if present, can override font and color" - attributes do: [ :attribute | - attribute forCharacterStyleReferenceDo: [ :s | - characterStyle _ s. - familyName _ s familyName. - pointSize _ s pointSize. - emphasis _ s emphasis. - s color ifNotNil: [ :c | color _ c ]]]. - - "These will not interfere with each other, and all of them take precedence over previous values" - attributes do: [ :attribute | - attribute forFontFamilyAndSizeDo: [ :fn :ps | familyName _ fn. pointSize _ ps ]. - attribute forTextEmphasisDo: [ :e | emphasis _ emphasis bitOr: e ]. - attribute forTextColorDo: [ :c | color _ c ]. - attribute forTextBackgroundColorDo: [ :c | backgroundColor _ c ]. - attribute forTextAlignmentDo: [ :a | alignment _ a ]. - ]. - - "Done. Now evaluate the block." -"change all senders!!!!!!!!!!!!" - aBlock numArgs = 8 ifTrue: [ - ^aBlock valueWithArguments: { familyName. pointSize. emphasis. color. alignment. characterStyle. paragraphStyle. backgroundColor } - ]. - ^aBlock valueWithArguments: { familyName. pointSize. emphasis. color. alignment. characterStyle. paragraphStyle }! ! -!BitBlt methodsFor: 'accessing' stamp: 'jmv 9/6/2017 20:40:02' prior: 16785548! - destX: x destY: y width: w height: h - destX _ x. - destY _ y. - width _ w. - height _ h.! ! -!CharacterScanner methodsFor: 'private' stamp: 'jmv 9/7/2017 17:19:12' prior: 16801954! - setFont - | attributes | - "Set the font and other emphasis. - In fact set actual ParagraphStyle (or nil), alignment, font and emphasis" - - self setActualFont: (text fontAt: lastIndex default: defaultFont). - attributes _ text attributesAt: lastIndex. - text - withAttributeValues: attributes - do: [ :familyNameInText :pointSizeInText :emphasisInText :colorInText :alignmentInText :characterStyleInText :paragraphStyleInText :backgroundColorInText | - colorInText ifNotNil: [ self textColor: colorInText ]. - self backgroundColor: backgroundColorInText. - alignment _ alignmentInText. - paragraphStyle _ paragraphStyleInText ]. - - "Hardcoded color for TextAction" - attributes do: [ :attribute | - attribute forTextActionInfoDo: [ :info | - self textColor: TextAction textActionColor ]]. - - "Install various parameters from the font." - spaceWidth _ font widthOf: Character space. - tabWidth _ (font widthOf: $a) * 3. - xTable _ font xTable. - map _ font characterToGlyphMap! ! -!CharacterScanner methodsFor: 'private' stamp: 'jmv 9/6/2017 20:40:09' prior: 16801989! - textColor: ignored - "Overridden in MorphicScanner"! ! -!MorphicScanner methodsFor: 'scanning' stamp: 'jmv 9/10/2017 16:28:26' prior: 16877966! - displayLine: textLine textTopLeft: textTopLeft leftInRun: leftInRun - "The call on the primitive (scanCharactersFrom:to:in:rightX:) will be interrupted according to an array of stop conditions passed to the scanner at which time the code to handle the stop condition is run and the call on the primitive continued until a stop condition returns true (which means the line has terminated). leftInRun is the # of characters left to scan in the current run; when 0, it is time to call setStopConditions." - - "textTopLeft is relative to the morph currently being drawn" - | stopCondition nowLeftInRun startIndex string lastPos | - - topLeft _ textTopLeft. - line _ textLine. - lineY _ line top + textTopLeft y. - rightMargin _ line rightMargin + textTopLeft x. - lastIndex _ line first. - leftInRun <= 0 ifTrue: [ - self setFont. - self setStopConditions ]. - leftMargin _ (line leftMarginForAlignment: alignment) + textTopLeft x. - destX _ leftMargin. - destY _ lineY + line baseline - font ascent. - - textLine isEmptyLine ifTrue: [ - textLine paragraphStyle ifNotNil: [ :ps | - ps = paragraphStyle ifFalse: [ - foregroundColor _ defaultColor. - self setActualFont: ps font. - ps color ifNotNil: [ :color | self textColor: color ]. - alignment _ ps alignment. - paragraphStyle _ ps. - spaceWidth _ font widthOf: Character space. - tabWidth _ (font widthOf: $a) * 3. - xTable _ font xTable. - map _ font characterToGlyphMap. - self setStopConditions. - text ifNotNil: [ destY _ lineY + line baseline - font ascent ]]]. - self displayBulletIfAppropriateFor: textLine textLeft: textTopLeft x. - ^leftInRun ]. - - self displayBulletIfAppropriateFor: textLine textLeft: textTopLeft x. - - lastIndex _ line first. - leftInRun <= 0 - ifTrue: [nowLeftInRun _ text runLengthFor: lastIndex] - ifFalse: [nowLeftInRun _ leftInRun]. - runStopIndex _ lastIndex + (nowLeftInRun - 1) min: line last. - spaceCount _ 0. - string _ text string. - - self placeEmbeddedObject. - [ - startIndex _ lastIndex. - lastPos _ destX@destY. - stopCondition _ self - scanCharactersFrom: lastIndex to: runStopIndex - in: string rightX: rightMargin stopConditions: stopConditions - kern: font baseKern. - backgroundColor ifNotNil: [ - canvas - fillRectangle: (lastPos corner: destX @ (line bottom + textTopLeft y)) - color: backgroundColor ]. - lastIndex >= startIndex ifTrue: [ - canvas - drawString: string - from: startIndex - to: lastIndex - at: lastPos - font: font - color: foregroundColor ]. - "see setStopConditions for stopping conditions for displaying." - (self perform: stopCondition) ifTrue: [ - "Number of characters remaining in the current run" - ^ runStopIndex - lastIndex ] - ] repeat! ! - -CharacterScanner subclass: #MorphicScanner - instanceVariableNames: 'canvas lineY foregroundColor defaultColor topLeft backgroundColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Text'! - -!classDefinition: #MorphicScanner category: #'Graphics-Text'! -CharacterScanner subclass: #MorphicScanner - instanceVariableNames: 'canvas lineY foregroundColor defaultColor topLeft backgroundColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Text'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3170-TextBackgroundColor-JuanVuletich-2017Sep10-16h23m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3168] on 10 September 2017 at 4:36:05 pm'! -!Text methodsFor: 'emphasis' stamp: 'jmv 9/10/2017 16:32:21' prior: 16929265! - alignmentAt: characterIndex - - self - withAttributeValues: (self attributesAt: characterIndex) - do: [ :familyName :pointSize :emphasis :color :alignment :characterStyle :paragraphStyle :backgroundColor | - ^ alignment ]! ! -!Text methodsFor: 'emphasis' stamp: 'jmv 9/10/2017 16:33:17' prior: 16929295! - characterStyleOrNilAt: characterIndex - - self - withAttributeValues: (self attributesAt: characterIndex) - do: [ :familyName :pointSize :emphasis :color :alignment :characterStyle :paragraphStyle :backgroundColor | - ^ characterStyle ]! ! -!Text methodsFor: 'emphasis' stamp: 'jmv 9/10/2017 16:33:23' prior: 16929304! - characterStyleOrNilIfApplying: textAttributes - "Answer the ParagraphStyle for characters as specified by the argument." - - self withAttributeValues: textAttributes do: [ :familyName :pointSize :emphasis :color :alignment :characterStyle :paragraphStyle :backgroundColor | - ^characterStyle ]! ! -!Text methodsFor: 'emphasis' stamp: 'jmv 9/10/2017 16:33:30' prior: 16929363! - emphasisAt: characterIndex - "Answer the emphasis for characters in the run beginning at characterIndex." - - self - withAttributeValues: (self attributesAt: characterIndex) - do: [ :familyName :pointSize :emphasis :color :alignment :characterStyle :paragraphStyle :backgroundColor | - ^ emphasis ]! ! -!Text methodsFor: 'emphasis' stamp: 'jmv 9/10/2017 16:33:36' prior: 16929398! - fontIfApplying: textAttributes default: defaultFont - "Answer the font for characters as specified by the argument." - - self withAttributeValues: textAttributes do: [ :familyName :pointSize :emphasis :color :alignment :characterStyle :paragraphStyle :backgroundColor | - ^((AbstractFont familyName: familyName pointSize: pointSize) ifNil: [ defaultFont baseFont ]) - emphasized: emphasis ]! ! -!Text methodsFor: 'emphasis' stamp: 'jmv 9/10/2017 16:33:42' prior: 16929443! - paragraphStyleOrNilAt: characterIndex - - self - withAttributeValues: (self attributesAt: characterIndex) - do: [ :familyName :pointSize :emphasis :color :alignment :characterStyle :paragraphStyle :backgroundColor | - ^ paragraphStyle ]! ! -!Text methodsFor: 'emphasis' stamp: 'jmv 9/10/2017 16:33:48' prior: 16929452! - paragraphStyleOrNilIfApplying: textAttributes - "Answer the ParagraphStyle for characters as specified by the argument." - - self - withAttributeValues: textAttributes - do: [ :familyName :pointSize :emphasis :color :alignment :characterStyle :paragraphStyle :backgroundColor | - ^paragraphStyle ]! ! -!Text methodsFor: 'emphasis' stamp: 'jmv 9/10/2017 16:34:25' prior: 50370248! - withAttributeValues: attributes do: aBlock - "Evaluate aBlock with the values of various attributes that affect text formatting, applied in the correct order - The order is (each overwriting the previous one) - 1) basic defaults - 2) ParagraphStyleReferene - 3) CharacterStyleReference - 4) TextFontReference - 5) TextEmphasis" - - | paragraphStyle characterStyle familyName pointSize emphasis alignment color backgroundColor | - paragraphStyle _ nil. - characterStyle _ nil. - familyName _ nil. - pointSize _ nil. - emphasis _ 0. - alignment _ 0. - color _ nil. - backgroundColor _ nil. - - "ParagraphStyle is the first to set several values" - attributes do: [ :attribute | - attribute forParagraphStyleReferenceDo: [ :s | - paragraphStyle _ s. - familyName _ s familyName. - pointSize _ s pointSize. - emphasis _ s emphasis. - alignment _ s alignment. - s color ifNotNil: [ :c | color _ c ]]]. - - "CharacterStyle, if present, can override font and color" - attributes do: [ :attribute | - attribute forCharacterStyleReferenceDo: [ :s | - characterStyle _ s. - familyName _ s familyName. - pointSize _ s pointSize. - emphasis _ s emphasis. - s color ifNotNil: [ :c | color _ c ]]]. - - "These will not interfere with each other, and all of them take precedence over previous values" - attributes do: [ :attribute | - attribute forFontFamilyAndSizeDo: [ :fn :ps | familyName _ fn. pointSize _ ps ]. - attribute forTextEmphasisDo: [ :e | emphasis _ emphasis bitOr: e ]. - attribute forTextColorDo: [ :c | color _ c ]. - attribute forTextBackgroundColorDo: [ :c | backgroundColor _ c ]. - attribute forTextAlignmentDo: [ :a | alignment _ a ]. - ]. - - "Done. Now evaluate the block." - ^aBlock valueWithArguments: { familyName. pointSize. emphasis. color. alignment. characterStyle. paragraphStyle. backgroundColor }! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3171-Cleanup-JuanVuletich-2017Sep10-16h32m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3168] on 10 September 2017 at 4:45:51 pm'! - -Object subclass: #SHRange - instanceVariableNames: 'start end type blockDepth ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -!classDefinition: #SHRange category: #'Tools-Syntax Highlighting'! -Object subclass: #SHRange - instanceVariableNames: 'start end type blockDepth' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! -!Preferences class methodsFor: 'shout' stamp: 'jmv 9/10/2017 16:40:28'! - highlightBlockNesting - ^ self - valueOfFlag: #highlightBlockNesting - ifAbsent: [true]! ! -!SHRange methodsFor: 'accessing' stamp: 'jmv 9/6/2017 20:25:10'! - blockDepth - ^blockDepth! ! -!SHRange methodsFor: 'accessing' stamp: 'jmv 9/6/2017 20:22:45'! - blockDepth: anInteger - blockDepth := anInteger! ! -!SHParserST80 methodsFor: 'recording ranges' stamp: 'jmv 9/9/2017 15:21:28' prior: 16902916! - rangeType: aSymbol start: s end: e - ^ranges add: ((SHRange start: s end: e type: aSymbol) blockDepth: blockDepth)! ! -!SHTextStylerST80 methodsFor: 'private' stamp: 'jmv 9/10/2017 16:41:27' prior: 50335088! - setAttributesFromRanges: ranges - - | alpha start end | - formattedText removeAttributesThat: [ :attribute | attribute isForShout ]. - - "Optimize for mutation speed unless method is really large but with very few distict elements: - Source code that includes just big literals is better served by conventional Text+RunArray" - "Do it only if we are not breaking textModel!! (for instance, StyledTextEditor asks for formatting just sections, not whole #actualContents)." - formattedText == textModel actualContents ifTrue: [ - (formattedText size > 2000 and: [ ranges size < 50 ]) ifFalse: [ - formattedText _ formattedText optimizedForMutationSpeed. - textModel basicActualContents: formattedText ]]. - - ranges withNextDo: [ :range :nextRangeOrNil | - - "Smalltalk text styling" - (self attributesFor: range rangeType) ifNotNil: [ :attributes | - attributes do: [ :each | - formattedText addAttribute: each from: range start to: range end ]]. - - Preferences highlightBlockNesting ifTrue: [ - alpha _ range blockDepth / 16.0 min: 0.5. - start _ range start. - end _ nextRangeOrNil ifNotNil: [ nextRangeOrNil start - 1 ] ifNil: [ range end ]. - formattedText - addAttribute: (ShoutTextBackgroundColor - color: (Theme current text alpha: alpha) ) from: start to: end ]. - - "Show as subscripts if appropriate." - classOrMetaClass ifNotNil: [ - classOrMetaClass theNonMetaClass lastUnderscoreMeansSubscript ifTrue: [ - (#( instVar classVar globalVar workspaceVar poolConstant - patternArg methodArg patternTempVar tempVar - blockPatternArg blockArg blockPatternTempVar blockTempVar - incompleteIdentifier undefinedIdentifier) pointsTo: range rangeType ) - ifTrue: [ - formattedText lastIndexOf: $_ startingAt: range end endingAt: range start do: [ :i | - formattedText addAttribute: ShoutTextEmphasis subscript from: i to: range end ] ]]]. - ]! ! - -Object subclass: #SHRange - instanceVariableNames: 'start end type blockDepth' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -!classDefinition: #SHRange category: #'Tools-Syntax Highlighting'! -Object subclass: #SHRange - instanceVariableNames: 'start end type blockDepth' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3172-ShoutShowBlockDepth-JuanVuletich-2017Sep10-16h36m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3168] on 9 September 2017 at 12:15:04 pm'! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/9/2017 12:09:32' prior: 50369686! - hasToRestoreChanges - - ^Preferences checkLostChangesOnStartUp and: [ - self withChangesFileDo: [ :changesFile | self hasToRestoreChangesFrom: changesFile ]]. - ! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/9/2017 12:09:46' prior: 50369695! - hasToRestoreChangesFrom: changesFile - - | chunk | - - changesFile position: self lastQuitLogPosition. - [ changesFile atEnd ] whileFalse: [ chunk := changesFile nextChunk ]. - - ^(self isSnapshotQuitOrQuitNoSaveRecord: chunk) not -! ! -!Preferences class methodsFor: 'start up' stamp: 'HAW 9/9/2017 12:07:37'! - checkLostChangesOnStartUp - ^ self - valueOfFlag: #checkLostChangesOnStartUp - ifAbsent: [ true ].! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3173-RestoreLostChangesPreference-HernanWilkinson-2017Sep09-12h03m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3161] on 6 September 2017 at 8:02:36 pm'! -!ChangeList class methodsFor: 'public access' stamp: 'HAW 9/6/2017 19:58:01'! - browseFrom: startPosition on: aChangesFileName labeled: aLabel - - " - ChangeList browseFrom: Smalltalk lastQuitLogPosition on: Smalltalk currentChangesName labeled: 'Lost changes' - " - - | changeList end | - - aChangesFileName asFileEntry readStreamDo: [ :changesFile | - end _ changesFile size. - changeList _ self new - scanFile: changesFile - from: startPosition - to: end. - ]. - - ChangeListWindow open: changeList label: aLabel! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/6/2017 19:59:40' prior: 50369782! - restoreLostChangesManually - - ChangeList browseFrom: LastQuitLogPosition on: self currentChangesName labeled: 'Lost changes' -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3174-RestoreChangesOnlySinceLastSnapshot-HernanWilkinson-2017Sep04-16h55m-HAW.1.cs.st----! - -----SNAPSHOT----#(10 September 2017 6:04:50.837756 pm) Cuis5.0-3174-32.image priorSource: 1202476! - -----QUIT----#(10 September 2017 6:05:04.576786 pm) Cuis5.0-3174-32.image priorSource: 1252476! - -----STARTUP----#(18 September 2017 11:05:37.292465 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3174-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3138] on 29 July 2017 at 10:49:50 pm'! -!Dictionary class methodsFor: 'instance creation' stamp: 'pb 7/29/2017 22:47:17' prior: 16833878! - 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 copy]]. - ^ 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 -"! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3175-Dictionary-newFrom-compatibility-with-Squeak-PhilBellalouna-2017Jul29-22h47m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3163] on 31 August 2017 at 5:46:33 am'! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'pb 8/31/2017 05:46:22' prior: 16853225! - arrowKey: aChar - "Handle a keyboard navigation character. Answer true if handled, false if not." - | keyEvent answer nextSelection oldSelection | - answer := false. - keyEvent := aChar numericValue. - oldSelection := self getSelectionIndex. - nextSelection := oldSelection. - keyEvent = 31 ifTrue: [ - "down" - nextSelection := oldSelection + 1. - nextSelection > self maximumSelection ifTrue: [ nextSelection := self minimumSelection ]]. - keyEvent = 30 ifTrue: [ - "up" - nextSelection := oldSelection - 1. - nextSelection < self minimumSelection ifTrue: [ nextSelection := self maximumSelection ]]. - keyEvent = 1 ifTrue: [ "home" - nextSelection := 1 ]. - keyEvent = 4 ifTrue: [ "end" - nextSelection := scroller submorphs size ]. - keyEvent = 11 ifTrue: [ "page up" - nextSelection := oldSelection - self numSelectionsInView max: 1 ]. - keyEvent = 12 ifTrue: [ "page down" - nextSelection := oldSelection + self numSelectionsInView ]. - keyEvent = 29 ifTrue: [ - "right" - selectedMorph ifNotNil: [ - (selectedMorph canExpand and: [ selectedMorph isExpanded not ]) - ifTrue: [ - self toggleExpandedState: selectedMorph. - answer := true ] - ifFalse: [ nextSelection := oldSelection + 1 ]]]. - keyEvent = 28 ifTrue: [ - "left" - selectedMorph ifNotNil: [ - selectedMorph isExpanded - ifTrue: [ - self toggleExpandedState: selectedMorph. - answer := true ] - ifFalse: [ nextSelection := oldSelection - 1 max: 1 ]]. - ^ true ]. - nextSelection = oldSelection ifFalse: [ - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self highlightedMorph: (self listMorphAt: nextSelection). - "Update the model in next world cycle, so user gets the immediate feedback." - WorldState addDeferredUIMessage: [ self setSelectionIndex: nextSelection ]. - answer := true ]. - ^ answer.! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3176-HierarchicalListMorph-keyboard-navigation-wrapping-PhilBellalouna-2017Aug31-05h46m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3168] on 9 September 2017 at 3:07:54 am'! -!BraceNode methodsFor: 'as yet unclassified' stamp: 'pb 9/9/2017 03:05:08'! - isComplex - ^ true.! ! -!BraceNode methodsFor: 'printing' stamp: 'pb 9/9/2017 03:05:21' prior: 16791076! - printOn: aStream indent: level - | isComplex useLevel | - useLevel := level. - isComplex := elements anySatisfy: [ :ea | - ea isComplex ]. - isComplex ifTrue: [ useLevel := useLevel + 1 ]. - aStream nextPut: ${. - 1 - to: elements size - do: [ :i | - isComplex ifTrue: [ aStream newLineTab: (1 max: useLevel) ]. - (elements at: i) - printOn: aStream - indent: useLevel. - i < elements size ifTrue: [ aStream nextPutAll: '. ' ]]. - isComplex ifTrue: [ aStream newLineTab: (1 max: level) ]. - aStream nextPut: $}.! ! -!LiteralNode methodsFor: 'printing' stamp: 'pb 9/9/2017 03:06:57' prior: 50334839! - printOn: aStream indent: level - key isVariableBinding - ifTrue: [ - key key isNil - ifTrue: [ - aStream - nextPutAll: '###'; - nextPutAll: key value soleInstance name ] - ifFalse: [ - aStream - nextPutAll: '##'; - nextPutAll: key key ]] - ifFalse: [ - key isLiteral - ifTrue: [ | isComplex | - isComplex := false. - key isArray ifTrue: [ - isComplex := key anySatisfy: [ :ea | - ea isArray ]]. - "Is it complex? (i.e. array of arrays)" - isComplex - ifTrue: [ - aStream - nextPut: $#; - nextPut: $(. - key do: [ :ea | - aStream newLineTab: (1 max: level + 1). - ea storeOn: aStream ]. - aStream newLineTab: (1 max: level). - aStream nextPut: $) ] - ifFalse: [ key storeOn: aStream ]] - ifFalse: [ - "Need to generate code for stuff that is in a CompiledMethod literal - but is not understood as a literal by the Compiler. - Well, then it is because it was generated using backticks!!" - aStream nextPut: $`. - key storeOn: aStream. - aStream nextPut: $` ]].! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3177-PrettyPrint-complex-arrays-PhilBellalouna-2017Sep09-03h05m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3168] on 9 September 2017 at 12:50:57 am'! -!FileList commentStamp: '' prior: 16842300! - I am model that can be used to navigate the host file system. By omitting the volume list, file list, and template panes from the view, I can also be used as the model for an editor on an individual file. - -The FileList provides a dynamic extension mechanism. To extend FileList functionality, tools should implement the following class-side method (look for implementors in the image): - -#fileReaderServicesForFile:suffix: (appropriate services for given file, takes a file name and a lowercased suffix) - -This method returns a collection of SimpleServiceEntry instances. These contain a class, a menu label and a method selector having one argument. They may also provide separate button labels and description. - -The argument to the specified method will be a string representing the full name of a file when one is selected or the file list itself when there is no selected file.! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3178-FileList-class-comment-PhilBellalouna-2017Sep09-00h27m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3174] on 13 September 2017 at 3:48:54 pm'! -!UndeclaredVariableWarning methodsFor: 'accessing' stamp: 'HAW 9/13/2017 15:16:19'! - classImplementingSelector - - ^class ! ! -!UndeclaredVariableWarning methodsFor: 'accessing' stamp: 'HAW 9/13/2017 15:15:44'! - selector - - ^selector ! ! -!UndeclaredVariableWarning methodsFor: 'accessing' stamp: 'HAW 9/13/2017 15:15:34'! - variableName - - ^name ! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3179-UndeclaredVariableWarning-accessors-HernanWilkinson-2017Sep11-18h54m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3179] on 15 September 2017 at 3:38:52 pm'! - -Object subclass: #SHRange - instanceVariableNames: 'start end type blockDepth ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -!classDefinition: #SHRange category: #'Tools-Syntax Highlighting'! -Object subclass: #SHRange - instanceVariableNames: 'start end type blockDepth' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! -!SHParserST80 methodsFor: 'recording ranges' stamp: 'tween 4/28/2004 10:20' prior: 50370639! -rangeType: aSymbol start: s end: e - ^ranges add: (SHRange start: s end: e type: aSymbol)! ! -!SHTextStylerST80 methodsFor: 'private' stamp: 'jmv 12/30/2016 11:44:19' prior: 50370646! - setAttributesFromRanges: ranges - - formattedText removeAttributesThat: [ :attribute | attribute isForShout ]. - - "Optimize for mutation speed unless method is really large but with very few distict elements: - Source code that includes just big literals is better served by conventional Text+RunArray" - "Do it only if we are not breaking textModel!! (for instance, StyledTextEditor asks for formatting just sections, not whole #actualContents)." - formattedText == textModel actualContents ifTrue: [ - (formattedText size > 2000 and: [ ranges size < 50 ]) ifFalse: [ - formattedText _ formattedText optimizedForMutationSpeed. - textModel basicActualContents: formattedText ]]. - - ranges do: [ :range | - - "Smalltalk text styling" - (self attributesFor: range rangeType) ifNotNil: [ :attributes | - attributes do: [ :each | - formattedText addAttribute: each from: range start to: range end ]]. - - "Show as subscripts if appropriate." - classOrMetaClass ifNotNil: [ - classOrMetaClass theNonMetaClass lastUnderscoreMeansSubscript ifTrue: [ - (#( instVar classVar globalVar workspaceVar poolConstant - patternArg methodArg patternTempVar tempVar - blockPatternArg blockArg blockPatternTempVar blockTempVar - incompleteIdentifier undefinedIdentifier) pointsTo: range rangeType ) - ifTrue: [ - formattedText lastIndexOf: $_ startingAt: range end endingAt: range start do: [ :i | - formattedText addAttribute: ShoutTextEmphasis subscript from: i to: range end ] ]]]]! ! - -SHRange removeSelector: #blockDepth! - -SHRange removeSelector: #blockDepth! - -SHRange removeSelector: #blockDepth:! - -SHRange removeSelector: #blockDepth:! - -Object subclass: #SHRange - instanceVariableNames: 'start end type' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -!classDefinition: #SHRange category: #'Tools-Syntax Highlighting'! -Object subclass: #SHRange - instanceVariableNames: 'start end type' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3180-goBackWith-3172-JuanVuletich-2017Sep15-15h36m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3180] on 17 September 2017 at 9:22:40 pm'! - -Object subclass: #SHParserST80 - instanceVariableNames: 'classOrMetaClass source workspace arguments sourcePosition currentToken currentTokenFirst temporaries instanceVariables errorBlock currentTokenSourcePosition blockDepth bracketDepth ranges blockDepthsStartIndexes blockDepths ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -!classDefinition: #SHParserST80 category: #'Tools-Syntax Highlighting'! -Object subclass: #SHParserST80 - instanceVariableNames: 'classOrMetaClass source workspace arguments sourcePosition currentToken currentTokenFirst temporaries instanceVariables errorBlock currentTokenSourcePosition blockDepth bracketDepth ranges blockDepthsStartIndexes blockDepths' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! -!SHParserST80 methodsFor: 'accessing' stamp: 'jmv 9/13/2017 22:00:57'! - blockDepths - ^blockDepths! ! -!SHParserST80 methodsFor: 'accessing' stamp: 'jmv 9/13/2017 22:01:05'! - blockDepthsStartIndexes - ^blockDepthsStartIndexes! ! -!SHParserST80 methodsFor: 'accessing' stamp: 'jmv 9/13/2017 20:51:24'! - ranges - ^ ranges! ! -!SHTextStylerST80 methodsFor: 'private' stamp: 'jmv 9/17/2017 18:29:22'! - parseSetWorkspace: aBoolean - "Answer a collection of SHRanges by parsing aText. - When formatting it is not necessary to set the workspace, and this can make the parse take less time, so aBoolean specifies whether the parser should be given the workspace" - - parser ifNil: [parser _ SHParserST80 new]. - parser - workspace: (aBoolean ifTrue: [workspace]); - classOrMetaClass: classOrMetaClass; - source: formattedText asString. - parser parse! ! -!SHParserST80 methodsFor: 'parse support' stamp: 'jmv 9/17/2017 19:04:26' prior: 16901977! - enterBlock - blockDepth _ blockDepth + 1. - bracketDepth _ bracketDepth + 1. - blockDepths add: blockDepth. - blockDepthsStartIndexes add: sourcePosition-1! ! -!SHParserST80 methodsFor: 'parse support' stamp: 'jmv 9/17/2017 19:02:56' prior: 16901989! - leaveBlock - arguments removeKey: blockDepth ifAbsent: nil. - temporaries removeKey: blockDepth ifAbsent: nil. - blockDepth _ blockDepth - 1. - bracketDepth _ bracketDepth - 1. - blockDepths add: blockDepth. - blockDepthsStartIndexes add: sourcePosition! ! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 9/17/2017 19:03:23' prior: 16902395! - parse: isAMethod - "Parse the receiver's text. If isAMethod is true - then treat text as a method, if false as an - expression with no message pattern" - - self initializeInstanceVariables. - sourcePosition _ 1. - arguments _ Dictionary new. - temporaries _ Dictionary new. - blockDepth _ bracketDepth := 0. - blockDepths _ OrderedCollection with: blockDepth. - blockDepthsStartIndexes _ OrderedCollection with: sourcePosition. - ranges ifNil: [ ranges := OrderedCollection new: 100] ifNotNil: [ ranges reset]. - errorBlock _ [^false]. - [ - self scanNext. - isAMethod - ifTrue: [ - self parseMessagePattern. - self parsePragmaSequence]. - self parseMethodTemporaries. - isAMethod ifTrue: [self parsePragmaSequence]. - self parseStatementList. - currentToken ifNotNil: [self error] - ] ensure: [errorBlock _ nil]. - ^true! ! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 9/17/2017 19:05:25' prior: 50335037! - parseBacktick - self enterBlock. - self scanPast: #backtick. - currentTokenFirst == $| ifTrue: [self parseBlockTemporaries]. - self parseStatementList. - self failUnless: currentTokenFirst == $`. - self leaveBlock. - self scanPast: #backtick! ! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 9/17/2017 18:40:55' prior: 16902449! - parseBlock - self enterBlock. - self scanPast: #blockStart level: bracketDepth. - currentTokenFirst == $: ifTrue: [self parseBlockArguments]. - currentTokenFirst == $| ifTrue: [self parseBlockTemporaries]. - self parseStatementList. - self failUnless: currentTokenFirst == $]. - self leaveBlock. - self scanPast: #blockEnd level: bracketDepth.! ! -!SHTextStylerST80 methodsFor: 'private' stamp: 'jmv 9/17/2017 21:20:07' prior: 16903299! - privateStyle - - | alpha end start count startIndexes | - self parseSetWorkspace: true. - parser ranges ifNotNil: [ :ranges | - self setAttributesFromRanges: ranges ]. - - Preferences highlightBlockNesting ifTrue: [ - startIndexes _ parser blockDepthsStartIndexes. - count _ startIndexes size. - parser blockDepths withIndexDo: [ :depth :idx | - start _ startIndexes at: idx. - end _ idx = count ifTrue: [formattedText size] ifFalse: [ (startIndexes at: idx+1)-1]. - alpha _ depth / 16.0 min: 0.5. - formattedText - addAttribute: (ShoutTextBackgroundColor - color: (Theme current text alpha: alpha) ) from: start to: end ]]! ! -!SHTextStylerST80 methodsFor: 'private' stamp: 'jmv 9/17/2017 18:30:50' prior: 16903322! - replaceStringForRangesWithType: aSymbol with: aString - "Answer aText if no replacements, or a copy of aText with - each range with a type of aSymbol replaced by aString" - | toReplace increaseInLength | - - "We don't handle format and conversion for debuggers" - disableFormatAndConvert ifTrue: [ ^self ]. - - self parseSetWorkspace: false. - toReplace _ parser ranges select: [ :each | - each rangeType = aSymbol ]. - toReplace isEmpty ifTrue: [ ^self ]. - increaseInLength := 0. - - (toReplace asArray sort: [ :a :b | a start <= b start ]) - do: [ :each | | end start thisIncrease | - start := each start + increaseInLength. - end := each end + increaseInLength. - formattedText replaceFrom: start to: end with: aString. - thisIncrease := aString size - each length. - increaseInLength := increaseInLength + thisIncrease ]! ! - -SHTextStylerST80 removeSelector: #rangesSetWorkspace:! - -SHTextStylerST80 removeSelector: #rangesSetWorkspace:! - -SHParserST80 removeSelector: #rangesIn:classOrMetaClass:workspace:! - -SHParserST80 removeSelector: #rangesIn:classOrMetaClass:workspace:! - -Object subclass: #SHParserST80 - instanceVariableNames: 'classOrMetaClass source workspace arguments sourcePosition currentToken currentTokenFirst temporaries instanceVariables errorBlock currentTokenSourcePosition blockDepth bracketDepth ranges blockDepths blockDepthsStartIndexes' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -!classDefinition: #SHParserST80 category: #'Tools-Syntax Highlighting'! -Object subclass: #SHParserST80 - instanceVariableNames: 'classOrMetaClass source workspace arguments sourcePosition currentToken currentTokenFirst temporaries instanceVariables errorBlock currentTokenSourcePosition blockDepth bracketDepth ranges blockDepths blockDepthsStartIndexes' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3181-ShoutShowsBlockDepth-Take2-JuanVuletich-2017Sep17-21h16m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3180] on 17 September 2017 at 9:29:15 pm'! -!Preferences class methodsFor: 'shout' stamp: 'jmv 9/17/2017 21:27:39'! - backgroundColorFillsAllBackground - "I.e. do fill all whitespace (tabs and space at right of end of text) with backgroundColor" - ^ self - valueOfFlag: #backgroundColorFillsAllBackground - ifAbsent: [true]! ! -!MorphicScanner methodsFor: 'scanning' stamp: 'jmv 9/17/2017 21:27:43' prior: 50370358! - displayLine: textLine textTopLeft: textTopLeft leftInRun: leftInRun - "The call on the primitive (scanCharactersFrom:to:in:rightX:) will be interrupted according to an array of stop conditions passed to the scanner at which time the code to handle the stop condition is run and the call on the primitive continued until a stop condition returns true (which means the line has terminated). leftInRun is the # of characters left to scan in the current run; when 0, it is time to call setStopConditions." - - "textTopLeft is relative to the morph currently being drawn" - | stopCondition nowLeftInRun startIndex string lastPos x1 | - - topLeft _ textTopLeft. - line _ textLine. - lineY _ line top + textTopLeft y. - rightMargin _ line rightMargin + textTopLeft x. - lastIndex _ line first. - leftInRun <= 0 ifTrue: [ - self setFont. - self setStopConditions ]. - leftMargin _ (line leftMarginForAlignment: alignment) + textTopLeft x. - destX _ leftMargin. - destY _ lineY + line baseline - font ascent. - - textLine isEmptyLine ifTrue: [ - textLine paragraphStyle ifNotNil: [ :ps | - ps = paragraphStyle ifFalse: [ - foregroundColor _ defaultColor. - self setActualFont: ps font. - ps color ifNotNil: [ :color | self textColor: color ]. - alignment _ ps alignment. - paragraphStyle _ ps. - spaceWidth _ font widthOf: Character space. - tabWidth _ (font widthOf: $a) * 3. - xTable _ font xTable. - map _ font characterToGlyphMap. - self setStopConditions. - text ifNotNil: [ destY _ lineY + line baseline - font ascent ]]]. - self displayBulletIfAppropriateFor: textLine textLeft: textTopLeft x. - ^leftInRun ]. - - self displayBulletIfAppropriateFor: textLine textLeft: textTopLeft x. - - lastIndex _ line first. - leftInRun <= 0 - ifTrue: [nowLeftInRun _ text runLengthFor: lastIndex] - ifFalse: [nowLeftInRun _ leftInRun]. - runStopIndex _ lastIndex + (nowLeftInRun - 1) min: line last. - spaceCount _ 0. - string _ text string. - - self placeEmbeddedObject. - [ - startIndex _ lastIndex. - lastPos _ destX@destY. - stopCondition _ self - scanCharactersFrom: lastIndex to: runStopIndex - in: string rightX: rightMargin stopConditions: stopConditions - kern: font baseKern. - backgroundColor ifNotNil: [ - x1 _ destX. - (Preferences backgroundColorFillsAllBackground and: [startIndex > line last]) ifTrue: [ - x1 _ rightMargin ]. - canvas - fillRectangle: (lastPos corner: x1 @ (line bottom + textTopLeft y)) - color: backgroundColor. - (Preferences backgroundColorFillsAllBackground and: [stopCondition = #tab]) ifTrue: [ - canvas - fillRectangle: (destX @ lastPos y corner: self tabDestX @ (line bottom + textTopLeft y)) - color: backgroundColor ]]. - lastIndex >= startIndex ifTrue: [ - canvas - drawString: string - from: startIndex - to: lastIndex - at: lastPos - font: font - color: foregroundColor ]. - "see setStopConditions for stopping conditions for displaying." - (self perform: stopCondition) ifTrue: [ - "Number of characters remaining in the current run" - ^ runStopIndex - lastIndex ] - ] repeat! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3182-BlockHighlightFillAllBackground-JuanVuletich-2017Sep17-21h22m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3174] on 13 September 2017 at 6:23:32 am'! -!DateAndTime methodsFor: 'private' stamp: 'pb 9/13/2017 06:17:35'! - subtractDateAndtime: operand - "operand is a DateAndTime or a Duration" - - | lvalue rvalue | - offset = operand offset - ifTrue: [ - lvalue _ self. - rvalue _ operand ] - ifFalse: [ - lvalue _ self asUTC. - rvalue _ operand asUTC ]. - ^ Duration - seconds: (Time secondsInDay *(lvalue julianDayNumber - rvalue julianDayNumber)) + - (lvalue secondsSinceMidnight - rvalue secondsSinceMidnight) - nanoSeconds: lvalue nanoSecond - rvalue nanoSecond! ! -!DateAndTime methodsFor: 'private' stamp: 'pb 9/13/2017 06:17:41'! - subtractDuration: operand - "operand is a DateAndTime or a Duration" - - ^self + operand negated! ! -!DateAndTime methodsFor: 'double dispatching' stamp: 'pb 9/13/2017 06:20:33'! - subtractFrom: aDateAndTime - - ^ aDateAndTime subtractDateAndtime: self! ! -!Duration methodsFor: 'double dispatching' stamp: 'pb 9/13/2017 06:21:11'! - subtractFrom: aDateAndTimeOrDate - - ^aDateAndTimeOrDate subtractDuration: self! ! -!Timespan methodsFor: 'private' stamp: 'pb 9/13/2017 06:18:08'! - subtractDuration: aDuration - - ^self class classDefinesDuration - ifTrue: [ self class including: start - aDuration ] - ifFalse: [ self class starting: start - aDuration duration: duration ]! ! -!Timespan methodsFor: 'private' stamp: 'pb 9/13/2017 06:19:33'! - subtractTimespan: aTimespan - ^self start subtractDateAndtime: aTimespan start! ! -!Timespan methodsFor: 'double dispatching' stamp: 'pb 9/13/2017 06:21:26'! - subtractFrom: aTimespan - - ^ aTimespan subtractTimespan: self! ! -!DateAndTime methodsFor: 'ansi protocol' stamp: 'pb 9/13/2017 06:20:43' prior: 50342674! - - operand - "operand is a DateAndTime or a Duration. - Double dispatch" - - ^ operand subtractFrom: self! ! -!Timespan methodsFor: 'ansi protocol' stamp: 'pb 9/13/2017 06:20:49' prior: 50342680! - - aDurationOrTimespan - - ^ aDurationOrTimespan subtractFrom: self! ! -!ScrollBar methodsFor: 'geometry' stamp: 'pb 9/13/2017 06:22:10' prior: 16904581! - freeSliderRoom - "Answer the length or height of the free slider area, i.e. subtract the slider itself. - If we are really too short of room, lie a little bit. Answering at least 4, even when the - free space might be actually negative, makes the scrollbar somewhat usable." - - | buttonsRoom | - buttonsRoom _ Theme current minimalWindows ifTrue: [0] ifFalse: [self buttonExtent * 2]. - ^ ((self isHorizontal - ifTrue: [ extent x - slider morphWidth] - ifFalse: [ extent y - slider morphHeight]) - - (borderWidth * 2) - buttonsRoom) max: 4! ! - -Timespan removeSelector: #substractDuration:! - -Timespan removeSelector: #substractDuration:! - -Timespan removeSelector: #substractFrom:! - -Timespan removeSelector: #substractFrom:! - -Timespan removeSelector: #substractTimespan:! - -Timespan removeSelector: #substractTimespan:! - -Duration removeSelector: #substractFrom:! - -Duration removeSelector: #substractFrom:! - -DateAndTime removeSelector: #substractDateAndtime:! - -DateAndTime removeSelector: #substractDateAndtime:! - -DateAndTime removeSelector: #substractDuration:! - -DateAndTime removeSelector: #substractDuration:! - -DateAndTime removeSelector: #substractFrom:! - -DateAndTime removeSelector: #substractFrom:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3183-fix-typos-and-remove-Timespan-error-message-PhilBellalouna-2017Sep13-06h16m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3183] on 18 September 2017 at 6:29:35 pm'! -!Timespan methodsFor: 'private' stamp: 'jmv 9/18/2017 18:27:11'! - subtractMonth: aYear - - ^ self subtractTimespan: aYear! ! -!Timespan methodsFor: 'private' stamp: 'jmv 9/18/2017 17:22:56'! - subtractYear: aYear - - ^ self subtractTimespan: aYear! ! -!Month methodsFor: 'double dispatching' stamp: 'jmv 9/18/2017 18:26:57'! - subtractFrom: aTimespan - - ^ aTimespan subtractMonth: self! ! -!Month methodsFor: 'double dispatching' stamp: 'jmv 9/18/2017 18:26:44'! - subtractMonth: aMonth - "Months can be subtracted even they have different length." - - ^self start subtractDateAndtime: aMonth start! ! -!Year methodsFor: 'double displatching' stamp: 'jmv 9/18/2017 17:23:04'! - subtractFrom: aTimespan - - ^ aTimespan subtractYear: self! ! -!Year methodsFor: 'double displatching' stamp: 'jmv 9/18/2017 17:24:41'! - subtractYear: aYear - "Years can be subtracted even if one of them is leap and the other isn't." - - ^self start subtractDateAndtime: aYear start! ! -!Timespan methodsFor: 'private' stamp: 'jmv 9/18/2017 18:29:20' prior: 50371493! - subtractTimespan: aTimespan - " - (Month month: 'March' year: 2017) - (Month month: 'January' year: 2017) - (Month month: 'February' year: 2017) - (Month month: 'January' year: 2017) - - (Year yearNumber: 2016) - (Year yearNumber: 2015). - (Year yearNumber: 2017) - (Year yearNumber: 2016). - (Year yearNumber: 2017) - (Year yearNumber: 2015). - - (Year yearNumber: 2018) - (Date today). 'Error'. - " - aTimespan duration = self duration ifFalse: [ - self error: 'Can not subtract Timespans of different duration' ]. - - ^self start subtractDateAndtime: aTimespan start! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3184-AddTimespanErrorMessageBack-JuanVuletich-2017Sep18-18h25m-jmv.1.cs.st----! - -----SNAPSHOT----#(18 September 2017 11:05:45.70737 pm) Cuis5.0-3184-32.image priorSource: 1252576! - -----QUIT----#(18 September 2017 11:06:08.830649 pm) Cuis5.0-3184-32.image priorSource: 1279047! - -----STARTUP----#(24 September 2017 10:20:01.675697 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3184-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3184] on 19 September 2017 at 10:18:24 pm'! -!Number methodsFor: 'printing' stamp: 'jmv 9/19/2017 21:48:57'! - withBinaryUnitPrefixAndValue: aBlock - " - As in https://en.wikipedia.org/wiki/Binary_prefix - { 0.123456. 1.23456. 12.3456. 123.456. 1234.56. 12345.6. 123456. 1234560. 12345600 } do: [ :n | n withBinaryUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | {value printString, ' ', unitPrefixSymbol. unitPrefixName} print]] - " - | prefixIndex factor nameAndSymbol | - prefixIndex _ self log floor // 3. - prefixIndex _ prefixIndex min: 8 max: 0. - factor _ 1024 raisedToInteger: prefixIndex. - nameAndSymbol _ { - {''. ''}. - {'kibi'. 'Ki'}. - {'mebi'. 'Mi'}. - {'gibi'. 'Gi'}. - {'tebi'. 'Ti'}. - {'pebi'. 'Pi'}. - {'exbi'. 'Ei'}. - {'zebi'. 'Zi'}. - {'yobi'. 'Yi'} - } at: prefixIndex+1. - aBlock value: (self / factor) asIntegerOrFloat value: nameAndSymbol second value: nameAndSymbol first! ! -!Number methodsFor: 'printing' stamp: 'jmv 9/19/2017 21:48:12'! - withDecimalUnitPrefixAndValue: aBlock - " - As in https://en.wikipedia.org/wiki/Metric_prefix - { 0.00000123456. 0.0000123456. 0.000123456. 0.00123456. 0.0123456. 0.123456. 1.23456. 12.3456. 123.456. 1234.56. 12345.6. 123456. 1234560. 12345600 } do: [ :n | n withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | {value printString, ' ', unitPrefixSymbol. unitPrefixName} print]] - " - | prefixIndex factor nameAndSymbol | - prefixIndex _ self log floor // 3. - prefixIndex _ prefixIndex min: 6 max: -6. - factor _ 1000 raisedToInteger: prefixIndex. - nameAndSymbol _ { - {'atto'. 'a'}. - {'femto'. 'f'}. - {'pico'. 'p'}. - {'nano'. 'n'}. - {'micro'. 'µ'}. - {'milli'. 'm'}. - {''. ''}. - {'kilo'. 'k'}. - {'mega'. 'M'}. - {'giga'. 'G'}. - {'tera'. 'T'}. - {'peta'. 'P'}. - {'exa'. 'E'} - } at: prefixIndex+7. - aBlock value: self asFloat / factor value: nameAndSymbol second value: nameAndSymbol first! ! -!Integer methodsFor: 'benchmarks' stamp: 'jmv 9/19/2017 21:59:09' prior: 50343304! - tinyBenchmarks - "Report the results of running the two tiny Squeak benchmarks. - ar 9/10/1999: Adjusted to run at least 1 sec to get more stable results - 0 tinyBenchmarks - 292 MHz G3 Mac: 22,727,272 bytecodes/sec; 984,169 sends/sec - 400 MHz PII/Win98: 18,028,169 bytecodes/sec; 1,081,272 sends/sec - - RasPi2 - StackVM: 37,758,112 bytecodes/sec; 2,412,667 sends/sec - RasPi2- CogSSpur: 157,441,574 bytecodes/sec; 10,946,039 sends/sec - - C.H.I.P. (*1) - StackVM: 55,315,471 bytecodes/sec; 3,348,667 sends/sec - C.H.I.P. (*1) - CogSpur: 253,716,551 bytecodes/sec; 16,853,816 sends/sec - - RasPi3B - StackSpur 44,107,512 bytecodes/sec; 2,767,863 sends/sec - RasPi3B - CogSpur 281,783,159 bytecodes/sec; 16,404,381 sends/sec - - 1.66GHz Atom N450 - Cog: 244,274,809 bytecodes/sec; 28,795,277 sends/sec - 1.66GHz Atom N450 - CogSpur: 469,724,770 bytecodes/sec; 30,754,699 sends/sec - - 1.33GHz Atom 3735G - Cog: 326,114,649 bytecodes/sec; 34,985,976 sends/sec - 1.33GHz Atom 3735G - CogSpur: 632,098,765 bytecodes/sec; 33,692,910 sends/sec - - 1.5GHz AMD A4-5000 APU - Cog: 390,243,902 bytecodes/sec; 47,507,997 sends/sec - 1.5GHz AMD A4-5000 APU - CogSpur: 675,907,590 bytecodes/sec; 40,669,724 sends/sec - 1.5GHz AMD A4-5000 APU - CogSpur64: 659,368,963 bytecodes/sec; 50,338,916 sends/sec - - 2.3GHz Tegra (*2) - StackVM: 258,847,320 bytecodes/sec; 13,014,759 sends/sec - 2.3GHz Tegra (*2) - CogSpur: 1,083,024,854 bytecodes/sec; 64,289,750 sends/sec - - 3.1GHz Core i3-2100 - Cog: 1,203,290,246 bytecodes/sec; 165,723,327 sends/sec - 3.1GHz Core i3-2100 - CogSpur: 2,042,892,768 bytecodes/sec; 127,837,794 sends/sec - - 2.70GHz Core i5-6400 -CogSpur64 3,162,934,362 bytecodes/sec; 243,321,293 sends/sec - - (*1) C.H.I.P. $9 Computer [Next Thing Co], Allwinner R8 Single-Core ARM Cortex-A8 - 1 GHz - (*2) ACER Chromebook CB5-311 - NVIDIA Tegra K1 Quad-Core ARM Cortex-A15 'r3' - 2.3 GHz - - It is interesting to note that Spur for the first time brings ARM hardware (RasPi and C.H.I.P.) into a 'Morphic is confortable and nice to use' level of performance. - " - | t1 t2 r n1 n2 | - n1 _ 1. - [ - t1 _ Time millisecondsToRun: [n1 benchmark]. - t1 < 1000] - whileTrue: [n1 _ n1 * 2]. "Note: #benchmark's runtime is about O(n)" - - n2 _ 28. - [ - t2 _ Time millisecondsToRun: [r _ n2 benchFib]. - t2 < 1000] - whileTrue: [n2 _ n2 + 1]. - "Note: #benchFib's runtime is about O(k^n), - where k is the golden number = (1 + 5 sqrt) / 2 = 1.618...." - - ^String streamContents: [ :strm | - (n1 * 500000 * 1000) // t1 withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixName; - nextPutAll: 'Bytecodes/second; ' ]. - (r * 1000) // t2 withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixName; - nextPutAll: 'Sends/second' ]]! ! -!Integer methodsFor: 'printing' stamp: 'jmv 9/19/2017 21:42:27' prior: 16860030! - printStringAsBytes - "Answer a terse, easily-readable representation of this Integer reprsenting a number of bytes. Useful for file-browsers. - 123 printStringAsBytes - 1024 printStringAsBytes - (12*1024) printStringAsBytes - (1024*1024) printStringAsBytes - (1024*1024*1024) printStringAsBytes - (1024*1024*1024*1024) printStringAsBytes - (30 factorial) printStringAsBytes - - See https://en.wikipedia.org/wiki/Kibibyte - See #printStringAsBytesDecimal - " - self withBinaryUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - ^String streamContents: [ :strm | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixSymbol; - nextPut: $B]]! ! -!Integer methodsFor: 'printing' stamp: 'jmv 9/19/2017 21:48:23' prior: 16860061! - printStringAsBytesDecimal - "Answer a terse, easily-readable representation of this Integer reprsenting a number of bytes. Useful for file-browsers. - 123 printStringAsBytesDecimal - (12*1000) printStringAsBytesDecimal - (1000*1000) printStringAsBytesDecimal - - 1024 printStringAsBytesDecimal - (12*1024) printStringAsBytesDecimal - (1024*1024) printStringAsBytesDecimal - (1024*1024*1024) printStringAsBytesDecimal - (1024*1024*1024*1024) printStringAsBytesDecimal - (30 factorial) printStringAsBytesDecimal - - See https://en.wikipedia.org/wiki/Kibibyte - See #printStringAsBytes - " - self withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - ^String streamContents: [ :strm | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixSymbol; - nextPut: $B]]! ! -!BlockClosure methodsFor: 'evaluating' stamp: 'jmv 9/19/2017 22:16:51' prior: 16787838! - bench - "See how many times I can value in 5 seconds. I'll answer a meaningful description. - [ Float pi printString ] bench print. - [ 80000 factorial printString ] bench print. - " - - | startTime endTime count run | - count _ 0. - run _ true. - [ (Delay forSeconds: 5) wait. run _ false ] forkAt: Processor timingPriority - 1. - startTime _ Time localMillisecondClock. - [ run ] whileTrue: [ self value. count _ count + 1 ]. - endTime _ Time localMillisecondClock. - count = 1 - ifTrue: [ - (endTime - startTime) / 1000 withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - ^String streamContents: [ :strm | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixSymbol; - nextPutAll: ' seconds per run']] - ] - ifFalse: [ - (count * 1000) / (endTime - startTime) withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - ^String streamContents: [ :strm | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixSymbol; - nextPutAll: ' runs per second' ]] - ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3185-benchImprovements-NumberUnitprefixPrint-JuanVuletich-2017Sep19-20h14m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3185] on 19 September 2017 at 10:42:44 pm'! -!SHTextStylerST80 methodsFor: 'private' stamp: 'jmv 9/19/2017 22:40:08' prior: 50371244! - privateStyle - - | alpha end start count startIndexes c hue | - self parseSetWorkspace: true. - parser ranges ifNotNil: [ :ranges | - self setAttributesFromRanges: ranges ]. - - Preferences highlightBlockNesting ifTrue: [ - startIndexes _ parser blockDepthsStartIndexes. - count _ startIndexes size. - parser blockDepths withIndexDo: [ :depth :idx | - start _ startIndexes at: idx. - end _ idx = count ifTrue: [formattedText size] ifFalse: [ (startIndexes at: idx+1)-1]. - alpha _ depth / 10.0 min: 1.0. - hue _ depth * 60. - c _ Color h: hue s: 0.2 v: 0.5 alpha: alpha. - formattedText - addAttribute: (ShoutTextBackgroundColor - color: c ) from: start to: end ]]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3186-BlockNestingHighlightWithColor-JuanVuletich-2017Sep19-22h41m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3186] on 24 September 2017 at 10:13:16 pm'! -!Character class methodsFor: 'accessing untypeable characters' stamp: 'jmv 9/24/2017 20:34:05'! - shortUnderscore - "Answer the Character representing very short (or invisible) underscore. - Used to optionally mark subscript in code." - - ^ Character numericValue: 127! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'jmv 9/24/2017 20:13:24' prior: 16801432! - infinity - " - Character infinity - " - ^ $…! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 9/24/2017 22:08:45' prior: 16914742! - makeCrInvisible - | glyph | - glyph _ self glyphAt: Character cr. - glyph fillWhite. - self glyphAt: Character cr put: glyph! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 9/24/2017 22:07:50' prior: 50359153! - makeCrVisible - | glyph | - glyph _ self glyphAt: (Character numericValue: 182). - glyph border: glyph boundingBox width: 1 fillColor: Color blue. -" glyph _ glyph reverse." - self glyphAt: Character cr put: glyph! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 9/24/2017 22:09:18' prior: 16914761! - makeLfInvisible - | glyph | - glyph _ self glyphAt: Character lf. - glyph fillWhite. - self glyphAt: Character lf put: glyph! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 9/24/2017 22:07:44' prior: 50359165! - makeLfVisible - | glyph | - glyph _ self glyphAt: (Character numericValue: 163). - glyph border: glyph boundingBox width: 1 fillColor: Color blue. -" glyph _ glyph reverse." - self glyphAt: Character lf put: glyph! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 9/24/2017 20:24:03' prior: 16914780! - makeTabInvisible - self characterToGlyphMap. - characterToGlyphMap at: 10 put: (10 < minAscii ifFalse: [10] ifTrue: [maxAscii+1])! ! -!StrikeFont methodsFor: 'building' stamp: 'jmv 9/24/2017 20:49:47' prior: 16914852! - buildFromForm: allGlyphs data: data name: aString - - | x shortUnderscore firstGlyphInFiles | - pointSize _ data first asNumber. - ascent _ data second asNumber. - descent _ data third asNumber. - - firstGlyphInFiles _ 257-(data size-3). - minAscii _ 1. - maxAscii _ 255. - name _ aString. - type _ 0. "ignored for now" - superscript _ ascent - descent // 3. - subscript _ descent - ascent // 3. - emphasis _ 0. - - xTable _ (Array new: 258) atAllPut: 0. - maxWidth _ 0. - glyphs _ allGlyphs depth > 16 ifTrue: [ allGlyphs asFormOfDepth: 16 ] ifFalse: [ allGlyphs ]. - x _ 0. - 4 to: data size do: [ :i | - x _ (data at: i) asNumber. - xTable at: i+firstGlyphInFiles+1-4 put: x]. - xTable at: 258 put: x. - self reset. - derivativeFonts _ nil. - - self makeCrVisible. - - "Replace glyph for 127 (a box) with a short version of the underscore (used to optionally mark subscript in code)" - shortUnderscore _ self glyphAt: $_. - shortUnderscore _ shortUnderscore copy: (0@0 extent: 1@shortUnderscore height). - self glyphAt: (Character numericValue: 127) put: shortUnderscore! ! -!StrikeFont class methodsFor: 'instance creation' stamp: 'jmv 9/24/2017 20:08:30' prior: 16915044! - create: fontName size: pointSize bold: includeBold italic: includeItalic boldItalic: includeBoldItalic - " - self create: 'DejaVu Sans Mono' size: 12 bold: true italic: true boldItalic: true - " - | folder basename base bold oblique boldOblique point | - folder _ DirectoryEntry smalltalkImageDirectory / 'AdditionalFontData'. - basename _ fontName = 'DejaVu' ifTrue: ['DejaVu Sans'] ifFalse: [fontName]. - point _ pointSize asString. - base _ [ (StrikeFont new - buildFromForm: ((Form fromFileEntry: folder // (basename, '-0-', point, '.bmp')) asFormOfDepth: 16) - data: (folder // (basename, '-0-', point, '.txt')) fileContents substrings - name: fontName, ' ', point) - pointSize: pointSize ] on: FileDoesNotExistException do: [ : ex | ex print. nil ]. - includeBold ifTrue: [ - bold _ [ (StrikeFont new - buildFromForm: ((Form fromFileEntry: folder // (basename, '-1-', point, '.bmp')) asFormOfDepth: 16) - data: (folder // (basename, '-1-', point, '.txt')) fileContents substrings - name: fontName, ' ', point, 'B') - emphasis: 1; - pointSize: pointSize ] on: FileDoesNotExistException do: [ : ex | ex print. nil ]]. - includeItalic ifTrue: [ - oblique _ [ (StrikeFont new - buildFromForm: ((Form fromFileEntry: folder // (basename, '-2-', point, '.bmp')) asFormOfDepth: 16) - data: (folder // (basename, '-2-', point, '.txt')) fileContents substrings - name: fontName, ' ', point, 'I') - emphasis: 2; - pointSize: pointSize ] on: FileDoesNotExistException do: [ : ex | ex print. nil ]]. - includeBoldItalic ifTrue: [ - boldOblique _ [ (StrikeFont new - buildFromForm: ((Form fromFileEntry: folder // (basename, '-3-', point, '.bmp')) asFormOfDepth: 16) - data: (folder // (basename, '-3-', point, '.txt')) fileContents substrings - name: fontName, ' ', point, 'BI') - emphasis: 3; - pointSize: pointSize ] on: FileDoesNotExistException do: [ : ex | ex print. nil ]]. - "We have a regular, base font. Make others derivatives of it" - base ifNotNil: [ - bold ifNotNil: [ - base derivativeFont: bold at: 1 ]. - oblique ifNotNil: [ - base derivativeFont: oblique at: 2]. - boldOblique ifNotNil: [ - base derivativeFont: boldOblique at: 3 ]. - ^base ]. - "We don't have a base, regular font." - oblique ifNotNil: [ - oblique emphasis: 0. "Hacky. Non regular fonts can not have derivatives. Should change this?" - bold ifNotNil: [ - oblique derivativeFont: bold at: 1 ]. - boldOblique ifNotNil: [ - oblique derivativeFont: boldOblique at: 3 ]. - ^oblique ]. - bold ifNotNil: [ - bold emphasis: 0. "Hacky. Non regular fonts can not have derivatives. Should change this?" - boldOblique ifNotNil: [ - bold derivativeFont: boldOblique at: 3 ]. - ^bold ]. - boldOblique ifNotNil: [ - ^boldOblique ]. - ^nil! ! -!StrikeFont class methodsFor: 'instance creation' stamp: 'jmv 9/24/2017 20:15:42' prior: 16915129! - install: aString -" -StrikeFont install: 'DejaVu'. -StrikeFont buildLargerPunctuation: 'DejaVu'. -Character initialize - -StrikeFont install: 'DejaVu Sans Mono'. -StrikeFont buildLargerPunctuation: 'DejaVu Sans Mono'. -Character initialize -" -" -StrikeFont install: 'Inconsolata' -StrikeFont install: '#PilGi' -StrikeFont install: 'Optima' -StrikeFont install: 'Herculanum' -StrikeFont install: 'Papyrus' -StrikeFont install: 'Handwriting - Dakota' -StrikeFont install: 'Times New Roman' -StrikeFont install: 'Apple Chancery' -StrikeFont install: 'Cochin' -StrikeFont install: 'Cracked' -StrikeFont install: 'Zapfino' -StrikeFont install: 'Brush Script MT' -StrikeFont install: 'Chalkboard' -" - | fontDict | - fontDict _ Dictionary new. - #(5 6 7 8 9 10 11 12 14 17 22) do: [ :s | - (self create: aString size: s bold: true italic: true boldItalic: false) ifNotNil: [ :font | - fontDict - at: s - put: font ]]. - fontDict notEmpty ifTrue: [ - AvailableFonts at: aString put: fontDict ]. - Preferences restoreDefaultFonts! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3187-FontsFixes-JuanVuletich-2017Sep24-22h12m-jmv.1.cs.st----! - -StrikeFont install: 'DejaVu'. -StrikeFont buildLargerPunctuation: 'DejaVu'. -Character initialize! - -----SNAPSHOT----#(24 September 2017 10:20:23.574736 pm) Cuis5.0-3187-32.image priorSource: 1279147! - -----QUIT----#(24 September 2017 10:20:42.585896 pm) Cuis5.0-3187-32.image priorSource: 1295852! - -----STARTUP----#(24 September 2017 10:26:57.691137 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3187-32.image! - - -actualContents edit! - -----QUIT----#(24 September 2017 10:27:42.204716 pm) Cuis5.0-3187-32.image priorSource: 1295953! - -----STARTUP----#(1 October 2017 4:31:55.273864 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3187-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3187] on 25 September 2017 at 10:56:05 pm'! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 9/25/2017 20:23:26'! - defaultFontFamily - "Answer the default font family name" - - ^self parameters at: #defaultFontFamily ifAbsentPut: [ AbstractFont familyNames first ]! ! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 9/25/2017 20:33:41'! - setDefaultFont: fontFamilyName spec: defaultFontsSpec - - | font | - defaultFontsSpec do: [ :triplet | - font _ AbstractFont familyName: fontFamilyName pointSize: triplet second. - font ifNil: [ font _ AbstractFont default ]. - triplet size > 2 ifTrue: [ - font _ font emphasized: triplet third ]. - self - perform: triplet first - with: font]! ! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 9/25/2017 20:22:40'! - setDefaultFontFamilyTo: aString - - self parameters at: #defaultFontFamily put: aString! ! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 9/25/2017 20:40:23' prior: 16892936! - restoreDefaultFonts - "Since this is called from menus, we can take the opportunity to prompt for missing font styles. - Preferences restoreDefaultFonts - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 9) - (setListFontTo: 9) - (setMenuFontTo: 10) - (setWindowTitleFontTo: 12) - (setCodeFontTo: 9) - (setButtonFontTo: 9))! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/25/2017 20:40:14' prior: 16893908! - bigFonts - "Sets not only fonts but other GUI elements - to fit high resolution or large screens - Preferences bigFonts - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 11) - (setListFontTo: 11) - (setMenuFontTo: 12) - (setWindowTitleFontTo: 14) - (setCodeFontTo: 11) - (setButtonFontTo: 11)). - Preferences enable: #biggerCursors! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/25/2017 20:40:20' prior: 16893923! - hugeFonts - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences hugeFonts - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 17) - (setListFontTo: 17) - (setMenuFontTo: 17) - (setWindowTitleFontTo: 22) - (setCodeFontTo: 17) - (setButtonFontTo: 17)). - Preferences enable: #biggerCursors! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/25/2017 20:40:26' prior: 16893939! - smallFonts - "Sets not only fonts but other GUI elements - to fit low resolution or small screens - Preferences smallFonts - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 8) - (setListFontTo: 8) - (setMenuFontTo: 8) - (setWindowTitleFontTo: 11) - (setCodeFontTo: 8) - (setButtonFontTo: 8)). - Preferences disable: #biggerCursors! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/25/2017 20:40:30' prior: 16893954! - standardFonts - "Sets not only fonts but other GUI elements - to fit regular resolution and size screens - Preferences standardFonts - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 9) - (setListFontTo: 9) - (setMenuFontTo: 10) - (setWindowTitleFontTo: 12) - (setCodeFontTo: 9) - (setButtonFontTo: 9)). - Preferences disable: #biggerCursors! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/25/2017 20:40:32' prior: 16893970! - tinyFonts - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences tinyFonts - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 7) - (setListFontTo: 5) - (setMenuFontTo: 5) - (setWindowTitleFontTo: 7) - (setCodeFontTo: 5) - (setButtonFontTo: 5)). - Preferences disable: #biggerCursors! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/25/2017 20:40:36' prior: 16893986! - veryBigFonts - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences veryBigFonts - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 14) - (setListFontTo: 14) - (setMenuFontTo: 14) - (setWindowTitleFontTo: 17) - (setCodeFontTo: 14) - (setButtonFontTo: 14)). - Preferences enable: #biggerCursors! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/25/2017 20:40:39' prior: 16894002! - verySmallFonts - "Sets not only fonts but other GUI elements - to fit low resolution or small screens - Preferences verySmallFonts - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 8) - (setListFontTo: 7) - (setMenuFontTo: 7) - (setWindowTitleFontTo: 9) - (setCodeFontTo: 7) - (setButtonFontTo: 7)). - Preferences disable: #biggerCursors! ! -!AbstractFont methodsFor: 'displaying' stamp: 'jmv 9/25/2017 20:24:32' prior: 16777361! - on: aGrafPort displayString: aString from: firstIndex to: lastIndex at: p color: color - "Answer last affected pixel position - Answer nil if nothing was done" - - | char fallbackFont x y answer | - fallbackFont _ (AbstractFont - familyName: Preferences defaultFontFamily - aroundPointSize: self pointSize*0.9) - emphasized: self emphasis. - x _ p x. - y _ p y. - firstIndex to: lastIndex do: [ :i | - char _ aString at: i. - answer _ aGrafPort displayString: char asString from: 1 to: 1 at: x@y strikeFont: fallbackFont color: color. - x _ x + (self widthOf: char) ]. - ^answer! ! -!AbstractFont class methodsFor: 'instance accessing' stamp: 'jmv 9/25/2017 20:25:27' prior: 16777395! - familyName: aString aroundPointSize: aNumber - " - AbstractFont familyName: Preferences defaultFontFamily aroundPointSize: 120 - " - | familyDictionary found | - familyDictionary _ AvailableFonts at: aString ifAbsent: [^nil]. - ^familyDictionary at: aNumber ifAbsent: [ - familyDictionary do: [ :font | - (found isNil or: [ (found pointSize - aNumber) abs > (font pointSize - aNumber) abs ]) - ifTrue: [ found _ font ]]. - found - ]! ! -!AbstractFont class methodsFor: 'instance accessing' stamp: 'jmv 9/25/2017 20:25:34' prior: 16777411! - familyName: aString pointSize: aNumber - " - AbstractFont familyName: Preferences defaultFontFamily pointSize: 12 - " - | familyDictionary | - familyDictionary _ AvailableFonts at: aString ifAbsent: [^nil]. - ^familyDictionary at: aNumber ifAbsent: nil! ! -!AbstractFont class methodsFor: 'instance accessing' stamp: 'jmv 9/25/2017 20:25:58' prior: 16777469! -pointSizesFor: aString - " - AbstractFont pointSizesFor: Preferences defaultFontFamily - " - | familyDictionary | - familyDictionary _ AvailableFonts at: aString ifAbsent: [^#()]. - ^familyDictionary keys sort! ! -!AbstractFont class methodsFor: 'class initialization' stamp: 'jmv 9/25/2017 20:25:47' prior: 16777478! - initialize - "AvailableFonts is a dictionary whose keys are family names, such as 'DejaVu Sans' and values are family dictionaries - family dictionaries have keys that are integers (point sizes such as 10 or 12) and values instances of the Font hierarcy - - Fonts with emphasis (such as bold or italic) are derivative fonts of the one found in the family dictionary" - - AvailableFonts _ Dictionary new! ! -!StrikeFont methodsFor: 'accessing' stamp: 'jmv 9/25/2017 20:45:55' prior: 16914200! - baseKern - "Return the base kern value to be used for all characters. - What follows is some 'random' text used to visually adjust this method. - HaHbHcHdHeHfHgHhHiHjHkHlHmHnHoHpHqHrHsHtHuHvHwHxHyHzH - HAHBHCHDHEHFHGHHHIHJHKHLHMHNHOHPHQHRHSHTHUHVHWHXHYHXZH - wok yuyo wuwu vuvu rucu tucu WUWU VUVU huevo HUEVO to - k y mate runico ridiculo ARABICO AAAAA TOMATE - TUTU - tatadalajafua - abacadafagahaqawaearatayauaiaoapasadafagahajakalazaxacavabanama - kUxUxa - q?d?h?l?t?f?j?" - - | italic baseKern | - italic _ self isItalic. - - "Assume synthetic will not affect kerning (i.e. synthetic italics are not used)" - "After all, DejaVu Sans are the only StrikeFonts used in Cuis..." -" self familyName = 'DejaVu Sans' - ifTrue: [" - baseKern _ (italic or: [ pointSize < 9 ]) - ifTrue: [ -1 ] - ifFalse: [ 0 ]. - pointSize >= 13 ifTrue: [ - baseKern _ baseKern +1 ]. - pointSize >= 20 ifTrue: [ - baseKern _ baseKern +1 ]"] - ifFalse: [ - baseKern _ pointSize < 12 - ifTrue: [ -1 ] - ifFalse: [ 0 ]. - italic ifTrue: [ - baseKern _ baseKern - 1]]". - - "If synthetic italic" - "See makeItalicGlyphs" - (self isSynthetic and: [ italic and: [ self isBold ]]) ifTrue: [ - baseKern _ baseKern - ((self height-1-self ascent+4)//4 max: 0) - - (((self ascent-5+4)//4 max: 0)) ]. - ^baseKern! ! -!StrikeFont methodsFor: 'synthetic derivatives' stamp: 'jmv 9/25/2017 20:44:21' prior: 16914975! - syntheticSubscript - "Build and answer a derivative that is Subscript." - - | derivative | - derivative _ ((AbstractFont familyName: Preferences defaultFontFamily aroundPointSize: pointSize * 0.58) - emphasized: emphasis) - copy. - derivative useShortUnderscore. - ^ derivative - -" -StrikeFont allInstances do: [ :a | a reset ]. -('Hi ', (Text string: 'there' attribute: TextEmphasis superscript), ' how ', (Text string: 'are' attribute: TextEmphasis subscript), ' you?') edit. - -que todos, menos estos, tengan superscript y subscript en cero. Y en estos, apropiado. y en 'aca' usarlo. y listo -"! ! -!StrikeFont methodsFor: 'synthetic derivatives' stamp: 'jmv 9/25/2017 20:44:26' prior: 16914996! - syntheticSuperscript - "Build and answer a derivative that is Superscript." - - | derivative | - derivative _ ((AbstractFont familyName: Preferences defaultFontFamily aroundPointSize: pointSize * 0.58) - emphasized: emphasis) - copy. - derivative name: self name , 'Sup'. - ^ derivative - -" -StrikeFont allInstances do: [ :a | a reset ]. -('Hi ', (Text string: 'there' attribute: TextEmphasis superscript), ' how ', (Text string: 'are' attribute: TextEmphasis subscript), ' you?') edit. -"! ! -!StrikeFont class methodsFor: 'instance creation' stamp: 'jmv 9/25/2017 20:17:15' prior: 50372017! - create: fontName size: pointSize bold: includeBold italic: includeItalic boldItalic: includeBoldItalic - " - self create: 'DejaVu Sans Mono' size: 12 bold: true italic: true boldItalic: true - " - | folder base bold oblique boldOblique point | - folder _ DirectoryEntry smalltalkImageDirectory / 'AdditionalFontData'. - point _ pointSize asString. - base _ [ (StrikeFont new - buildFromForm: ((Form fromFileEntry: folder // (fontName, '-0-', point, '.bmp')) asFormOfDepth: 16) - data: (folder // (fontName, '-0-', point, '.txt')) fileContents substrings - name: fontName, ' ', point) - pointSize: pointSize ] on: FileDoesNotExistException do: [ : ex | ex print. nil ]. - includeBold ifTrue: [ - bold _ [ (StrikeFont new - buildFromForm: ((Form fromFileEntry: folder // (fontName, '-1-', point, '.bmp')) asFormOfDepth: 16) - data: (folder // (fontName, '-1-', point, '.txt')) fileContents substrings - name: fontName, ' ', point, 'B') - emphasis: 1; - pointSize: pointSize ] on: FileDoesNotExistException do: [ : ex | ex print. nil ]]. - includeItalic ifTrue: [ - oblique _ [ (StrikeFont new - buildFromForm: ((Form fromFileEntry: folder // (fontName, '-2-', point, '.bmp')) asFormOfDepth: 16) - data: (folder // (fontName, '-2-', point, '.txt')) fileContents substrings - name: fontName, ' ', point, 'I') - emphasis: 2; - pointSize: pointSize ] on: FileDoesNotExistException do: [ : ex | ex print. nil ]]. - includeBoldItalic ifTrue: [ - boldOblique _ [ (StrikeFont new - buildFromForm: ((Form fromFileEntry: folder // (fontName, '-3-', point, '.bmp')) asFormOfDepth: 16) - data: (folder // (fontName, '-3-', point, '.txt')) fileContents substrings - name: fontName, ' ', point, 'BI') - emphasis: 3; - pointSize: pointSize ] on: FileDoesNotExistException do: [ : ex | ex print. nil ]]. - "We have a regular, base font. Make others derivatives of it" - base ifNotNil: [ - bold ifNotNil: [ - base derivativeFont: bold at: 1 ]. - oblique ifNotNil: [ - base derivativeFont: oblique at: 2]. - boldOblique ifNotNil: [ - base derivativeFont: boldOblique at: 3 ]. - ^base ]. - "We don't have a base, regular font." - oblique ifNotNil: [ - oblique emphasis: 0. "Hacky. Non regular fonts can not have derivatives. Should change this?" - bold ifNotNil: [ - oblique derivativeFont: bold at: 1 ]. - boldOblique ifNotNil: [ - oblique derivativeFont: boldOblique at: 3 ]. - ^oblique ]. - bold ifNotNil: [ - bold emphasis: 0. "Hacky. Non regular fonts can not have derivatives. Should change this?" - boldOblique ifNotNil: [ - bold derivativeFont: boldOblique at: 3 ]. - ^bold ]. - boldOblique ifNotNil: [ - ^boldOblique ]. - ^nil! ! -!StrikeFont class methodsFor: 'instance creation' stamp: 'jmv 9/25/2017 20:48:55' prior: 50372105! - install: aString -" -StrikeFont install: 'DejaVu Sans'. -StrikeFont buildLargerPunctuation: 'DejaVu Sans'. -Preferences setDefaultFontFamilyTo: 'DejaVu Sans'. -Preferences standardFonts. -Character initialize. -" -" -StrikeFont install: 'DejaVu Sans Mono'. -Preferences setDefaultFontFamilyTo: 'DejaVu Sans Mono'. -Preferences bigFonts. -Character initialize. -" -" -StrikeFont install: 'Inconsolata' -StrikeFont install: '#PilGi' -StrikeFont install: 'Optima' -StrikeFont install: 'Herculanum' -StrikeFont install: 'Papyrus' -StrikeFont install: 'Handwriting - Dakota' -StrikeFont install: 'Times New Roman' -StrikeFont install: 'Apple Chancery' -StrikeFont install: 'Cochin' -StrikeFont install: 'Cracked' -StrikeFont install: 'Zapfino' -StrikeFont install: 'Brush Script MT' -StrikeFont install: 'Chalkboard' -" - | fontDict | - fontDict _ Dictionary new. - #(5 6 7 8 9 10 11 12 14 17 22) do: [ :s | - (self create: aString size: s bold: true italic: true boldItalic: false) ifNotNil: [ :font | - fontDict - at: s - put: font ]]. - fontDict notEmpty ifTrue: [ - AvailableFonts at: aString put: fontDict ]. - Preferences restoreDefaultFonts! ! -!StrikeFont class methodsFor: 'removing' stamp: 'jmv 9/25/2017 20:41:27' prior: 16915172! - removeForPDA -" -StrikeFont removeForPDA -" - | familyDict | - familyDict _ AvailableFonts at: Preferences defaultFontFamily. - familyDict keys do: [ :k | - (#(5 6 7 8 9) includes: k) - ifTrue: [ - (familyDict at: k) derivativeFont: nil at: 0 ] - ifFalse: [ - familyDict removeKey: k ]]. - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 8) - (setListFontTo: 6) - (setMenuFontTo: 7) - (setWindowTitleFontTo: 9) - (setCodeFontTo: 7) - (setButtonFontTo: 7))! ! -!StrikeFont class methodsFor: 'removing' stamp: 'jmv 9/25/2017 20:42:25' prior: 16915190! - removeMostFonts -" -StrikeFont removeMostFonts -" - | familyDict | - Preferences disable: #italicsInShout. - SHTextStylerST80 initialize. - familyDict _ AvailableFonts at: Preferences defaultFontFamily. - familyDict keys do: [ :k | - (#(8 10 12) includes: k) - ifTrue: [ - (familyDict at: k) derivativeFont: nil at: 0 ] - ifFalse: [ - familyDict removeKey: k ]]. - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 10) - (setListFontTo: 10) - (setMenuFontTo: 10) - (setWindowTitleFontTo: 12) - (setCodeFontTo: 10) - (setButtonFontTo: 10))! ! -!StrikeFont class methodsFor: 'removing' stamp: 'jmv 9/25/2017 20:42:49' prior: 16915211! - removeSomeFonts -" -StrikeFont removeSomeFonts -" - | familyDict | - familyDict _ AvailableFonts at: Preferences defaultFontFamily. - familyDict keys do: [ :k | - "No boldItalic for the followint" - (#(5 6 7 8 9 10 11 12 14 17 22) includes: k) - ifTrue: [ (familyDict at: k) derivativeFont: nil at: 3 ]. - "No derivatives at all for the following" - (#() includes: k) - ifTrue: [ (familyDict at: k) derivativeFont: nil at: 0 ]. - "Sizes to keep" - (#(5 6 7 8 9 10 11 12 14 17 22) includes: k) - ifFalse: [ familyDict removeKey: k ]]. - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 9) - (setListFontTo: 9) - (setMenuFontTo: 10) - (setWindowTitleFontTo: 12) - (setCodeFontTo: 9) - (setButtonFontTo: 9))! ! -!StrikeFont class methodsFor: 'character shapes' stamp: 'jmv 9/25/2017 20:45:01' prior: 16915250! - buildLargerPunctuation: familyName - " - StrikeFont buildLargerPunctuation: 'DejaVu Sans' - " - | form form2 f10 f11 f12 f9 | - - f9 _ AbstractFont familyName: familyName pointSize: 9. - f10 _ AbstractFont familyName: familyName pointSize: 10. - f11 _ AbstractFont familyName: familyName pointSize: 11. - f12 _ AbstractFont familyName: familyName pointSize: 12. - - - f9 takeGlyphFor: $. from: $. in: f12. - f9 takeGlyphFor: $, from: $, in: f12. - - form _ f9 glyphAt: $.. - form copy: (0@9 extent: 3@14) from: form to: 0@4 rule: Form and. - f9 glyphAt: $: put: form. - - form _ f9 glyphAt: $,. - form2 _ f9 glyphAt: $.. - form copy: (0@9 extent: 3@14) from: form2 to: 1@4 rule: Form and. - f9 glyphAt: $; put: form. - - - - f10 takeGlyphFor: $. from: $. in: f12. - f10 takeGlyphFor: $, from: $, in: f12. - - form _ f10 glyphAt: $. . - form copy: (0@9 extent: 3@14) from: form to: 0@4 rule: Form and. - f10 glyphAt: $: put: form. - - form _ f10 glyphAt: $,. - form2 _ f10 glyphAt: $.. - form copy: (0@9 extent: 3@14) from: form2 to: 1@4 rule: Form and. - f10 glyphAt: $; put: form. - - - - f11 takeGlyphFor: $. from: $. in: f12. - f11 takeGlyphFor: $, from: $, in: f12. - f11 takeGlyphFor: $: from: $: in: f12. - f11 takeGlyphFor: $; from: $; in: f12! ! -!UpdatingStringMorph class methodsFor: 'new-morph participation' stamp: 'jmv 9/25/2017 20:44:33' prior: 50337169! - initializedInstance - "Answer a digital clock" - - | newInst | - newInst := self - contents: '' - font: (AbstractFont familyName: Preferences defaultFontFamily pointSize: 22) - emphasis: AbstractFont boldCode. - newInst - stepTime: 500; "half a second" - target: [String streamContents: [ :strm | DateAndTime now printHMSOn: strm]] ; - getSelector: #value. - - ^ newInst! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3188-FontInstallEnhancements-JuanVuletich-2017Sep25-20h30m-jmv.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3188] on 29 September 2017 at 5:43:16 pm'! -!Form methodsFor: 'bordering' stamp: 'jmv 9/29/2017 16:59:58'! - border: aRectangle width: borderWidth borderHeight: borderHeight fillColor: aColor - "Paint a border whose rectangular area is defined by aRectangle. The - width of the border of each side is borderWidth@borderHeight. Uses aHalfTone for - drawing the border." - - self border: aRectangle - widthRectangle: - (Rectangle - left: borderWidth - right: borderWidth - top: borderHeight - bottom: borderHeight) - rule: Form over - fillColor: aColor! ! -!Form methodsFor: 'bordering' stamp: 'jmv 9/29/2017 16:59:43'! - borderWidth: borderWidth borderHeight: borderHeight fillColor: aColor - self border: self boundingBox width: borderWidth borderHeight: borderHeight fillColor: aColor! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3189-Form-2borderMethods-JuanVuletich-2017Sep29-12h42m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3187] on 28 September 2017 at 1:44:54 pm'! -!Float64Array methodsFor: 'interpolating' stamp: 'jmv 9/28/2017 13:39:15'! - interpolateValues: valuesArray at: x - "Interpret self as a domain and valuesArray as a function samples." - - ^self - findBinaryIndex: [ :arg | x - arg ] - do: [ :i | valuesArray at: i ] - ifNone: [ :i :j | - ((valuesArray at: i) interpolateTo: (valuesArray at: j) at: (x - (self at: i)) / ((self at: j) - (self at: i)))]! ! -!Float64Array methodsFor: 'interpolating' stamp: 'jmv 9/28/2017 13:39:12'! - interpolatedValueAt: floatIndex - "Do a linear interpolation. - Gives usual error if argument outside bounds: - #[ 4 5 ] asFloatArray interpolatedValueAt: 0.999 - #[ 4 5 ] asFloatArray interpolatedValueAt: 1.0 - #[ 4 5 ] asFloatArray interpolatedValueAt: 1.5 - #[ 4 5 ] asFloatArray interpolatedValueAt: 2.0 - #[ 4 5 ] asFloatArray interpolatedValueAt: 2.000001 - #[ 4 5 ] asFloatArray interpolatedValueAt: 3 - " - | size index0 index1 weight0 weight1 | - - size _ self size. - index0 _ floatIndex truncated. "Could be #floor. But as we only care for values >=1, it is the same. But faster." - - weight1 _ floatIndex - index0. - weight0 _ 1.0 - weight1. - - index1 _ (index0 = size and: [ weight1 = 0.0 ]) "Avoid the invalid access if this was true, but don't make it slower the most common, general case." - ifFalse: [ index0 + 1 ] - ifTrue: [ index0 ]. - - "/* perform interpolation */" - ^ (weight0 * (self at: index0)) + (weight1 * (self at: index1))! ! -!FloatArray methodsFor: 'interpolating' stamp: 'jmv 9/28/2017 13:36:31'! - interpolateValues: valuesArray at: x - "Interpret self as a domain and valuesArray as a function samples." - - ^self - findBinaryIndex: [ :arg | x - arg ] - do: [ :i | valuesArray at: i ] - ifNone: [ :i :j | - ((valuesArray at: i) interpolateTo: (valuesArray at: j) at: (x - (self at: i)) / ((self at: j) - (self at: i)))]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3190-interpolation-enh-JuanVuletich-2017Sep28-13h36m-jmv.1.cs.st----! - -----SNAPSHOT----#(1 October 2017 4:32:24.38897 pm) Cuis5.0-3190-32.image priorSource: 1296190! - -----QUIT----#(1 October 2017 4:32:52.066601 pm) Cuis5.0-3190-32.image priorSource: 1317773! - -----STARTUP----#(1 October 2017 4:45:34.809567 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3190-32.image! - - -----QUIT----#(1 October 2017 4:54:58.139866 pm) Cuis5.0-3190-32.image priorSource: 1317869! - -----STARTUP----#(22 October 2017 9:25:04.114886 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3190-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3190] on 1 October 2017 at 5:11:37 pm'! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 10/1/2017 17:11:24' prior: 50372166! - defaultFontFamily - "Answer the default font family name" - - ^self parameters at: #defaultFontFamily ifAbsentPut: [ AbstractFont familyNames first ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3191-JustInCase-JuanVuletich-2017Oct01-17h11m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3186] on 30 September 2017 at 3:32:06 pm'! -!SHTextStylerST80 methodsFor: 'private' stamp: 'pb 9/30/2017 15:31:56' prior: 50371154! - parseSetWorkspace: aBoolean - "Answer a collection of SHRanges by parsing aText. - When formatting it is not necessary to set the workspace, and this can make the parse take less time, so aBoolean specifies whether the parser should be given the workspace" - parser ifNil: [ parser := SHParserST80 new ]. - parser - workspace: - (aBoolean ifTrue: [ workspace ]); - classOrMetaClass: classOrMetaClass; - source: formattedText asString. - parser parse. - ^ parser ranges.! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3192-SHTextStylerST80-parseSetWorkspace-PhilBellalouna-2017Sep30-15h31m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3192] on 7 October 2017 at 4:29:18 pm'! -!Float commentStamp: 'jmv 10/7/2017 16:27:55' prior: 16844366! - A note About Floating Point numbers and Floating Point Arithmetic. - -The following is not specific to Cuis or Smalltalk at all. This is about the properties of Float numbers in any computer implementation. - -If you haven't done so already, read https://en.wikipedia.org/wiki/Floating-point_arithmetic - -But if you find the Wikipedia article too detailed, or hard to read, then try http://fabiensanglard.net/floating_point_visually_explained/ (get past "How Floating Point are usually explained" and read "A different way to explain..."). - -Other great reads are: - "Why don't my numbers add up?": - http://floating-point-gui.de/ -and - "What Every Computer Scientist Should Know About Floating-Point Arithmetic": - http://docs.oracle.com/cd/E19957-01/806-3568/ncg_goldberg.html -and also maybe - "Comparing floating point numbers" - https://randomascii.wordpress.com/2012/02/25/comparing-floating-point-numbers-2012-edition/ - -Now that you read them, and we are on the same boat, some further comments (from jmv): - -Floats are (conceptually) approximate real numbers. That's why trig and other trascendental functions always answer Floats. That's why it is ok to round the result of operations. That's why Float is considered more general than Fraction in ST-80 and most Smalltalks. So, when we have a Float value, we must not think about it as a Rational but as a Real (actually as some unknown Real that could hopefully be close to the Rational we can actually represent). Keep this in mind when dealing with Floats, and especially avoid comparing them for equality. - -(If you want exact arithmetic, can live in the limited world of Rational numbers, and can afford a slight performance penalty, use Fraction instead.) - -There are some things that can be done to increase the confidence you can have on Float results. One is to do an error propagation analysis on the code you are running. This is not easy, but it is done for any widely used numerical method. Then, you can know real bounds and/or estimates of the errors made. - -Perhaps you have heard about "interval arithmetic". It is a bit better than simple Float, but doesn't really fix the problems. - -The ultimate solution is to do Monte Carlo analysis, with random contamination of inputs. After the Monte Carlo run, it is needed to do statistical analysis of possible correlations between the distributions of the random noise added to imputs and the result of the algorithm. - -Additional food for thought: http://www.cs.berkeley.edu/~wkahan/Mindless.pdf . According to this, doing Monte Carlo as described above attacks a slightly different problem. This might be yet another reason (besides performance) to try something like the next paragraph. I (jmv) came up with it, and I don't really know if it has been described and or tried before or not. Mhhh. Maybe a defensive publication is in order. - -A possibility that could be a practical solution, being much cheaper than Monte Carlo, but better than interval arithmetic, is to represent each value by 2 Floats: an estimation of the real value (i.e. an estimation of the mean value of the distribution of the corresponding Monte Carlo result), and an estimation of the error (i.e. an estimation of the standard deviation of the corresponding Monte Carlo result). Or perhaps even 3 of them. In addition to the estimation of the real value and an estimation of the error, we could add a hard bound on the error. In many cases it will be useless, because the error can not really be bound. But in those cases where it is possible to bound it, applications could really know about the quality of computed values. - -======================================================================= - -My instances represent IEEE-754 floating-point double-precision numbers. They have about 16 digits of accuracy and their range is between plus and minus 10^307. Some valid examples are: - - 8.0 13.3 0.3 2.5e6 1.27e-30 1.27e-31 -12.987654e12 - -Mainly: no embedded blanks, little e for tens power, and a digit on both sides of the decimal point. It is actually possible to specify a radix for Squeak Float constants. This is great for teaching about numbers, but may be confusing to the average reader: - - 3r20.2 --> 6.66666666666667 - 8r20.2 --> 16.25 - -If you don't have access to the definition of IEEE-754, you can figure out what is going on by printing various simple values in Float hex. It may help you to know that the basic format is... - sign 1 bit - exponent 11 bits with bias of 1023 (16r3FF) to produce an exponent - in the range -1023 .. +1024 - - 16r000: - significand = 0: Float zero - significand ~= 0: Denormalized number (exp = -1024, no hidden '1' bit) - - 16r7FF: - significand = 0: Infinity - significand ~= 0: Not A Number (NaN) representation - mantissa 53 bits, but only 52 are stored (20 in the first word, 32 in the second). This is because a normalized mantissa, by definition, has a 1 to the right of its floating point, and IEEE-754 omits this redundant bit to gain an extra bit of precision instead. People talk about the mantissa without its leading one as the FRACTION, and with its leading 1 as the SIGNFICAND. - -The single-precision format is... - sign 1 bit - exponent 8 bits, with bias of 127, to represent -126 to +127 - - 0x0 and 0xFF reserved for Float zero (mantissa is ignored) - - 16r7F reserved for Float underflow/overflow (mantissa is ignored) - mantissa 24 bits, but only 23 are stored -This format is used in FloatArray (qv), and much can be learned from the conversion routines, Float asIEEE32BitWord, and Float class fromIEEE32Bit:. - -You might also check https://en.wikipedia.org/wiki/IEEE_754_revision - -Other great reads (covering broader but interesting issues): -https://randomascii.wordpress.com/2013/07/16/floating-point-determinism/ -http://www.ima.umn.edu/2010-2011/W1.10-14.11/activities/Leeser-Miriam/Leeser-GPU-IMA-Jan2011.pdf! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3193-FloatClassCommentTweaks-JuanVuletich-2017Oct07-16h14m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3193] on 8 October 2017 at 6:43:01 pm'! -!WriteStream methodsFor: 'services' stamp: 'jmv 10/8/2017 17:58:45'! - padToEndIfCantTruncate - "Only makes sense for file streams with existing content. - See inheritance"! ! -!StandardFileStream methodsFor: 'read, write, position' stamp: 'jmv 10/8/2017 17:58:13'! -padToEndIfCantTruncate - "Only makes sense for file streams with existing content. - On file systems that don't support truncating this is needed. - If truncating is supported, try that first" - - "On the Mac, files do not truncate. One can delete the old file and write a new one, but sometime deletion fails (file still open? file stale?). This is a sad compromise. Just let the file be the same length but pad it with a harmless character." - - | pad | - self atEnd ifTrue: [^ self]. - self truncate. - self atEnd ifTrue: [^ self]. - pad := self isBinary - ifTrue: [Character space numericValue] - ifFalse: [Character space ]. - self nextPutAll: (self collectionSpecies new: ((self size - self position) min: 20000) - withAll: pad)! ! -!StandardFileStream methodsFor: 'read, write, position' stamp: 'jmv 10/8/2017 17:02:10' prior: 50332189! - basicNext - "Answer the next byte or character (depending on mode) from this file, or nil if at the end of the file." - - | count | - collection ifNotNil: [ - position < readLimit - ifFalse: [ - readLimit := self primRead: fileID into: collection startingAt: 1 count: collection size. - position := 0. - readLimit = 0 ifTrue: [ ^nil ] ]. - ^collection at: (position := position + 1) ]. - count _ self primRead: fileID into: buffer1 startingAt: 1 count: 1. - ^count = 1 - ifTrue: [ buffer1 at: 1 ]! ! -!StandardFileStream methodsFor: 'read, write, position' stamp: 'jmv 10/8/2017 17:02:58' prior: 16913325! - nextPut: char - "Write the given byte or character (depending on mode) to this file." - - rwmode ifFalse: [^ self error: 'Cannot write a read-only file']. - collection ifNotNil: [ - position < readLimit ifTrue: [ self flushReadBuffer ] ]. - buffer1 at: 1 put: char. - self primWrite: fileID from: buffer1 startingAt: 1 count: 1. - ^ char -! ! -!StandardFileStream methodsFor: 'private' stamp: 'jmv 10/8/2017 17:04:44' prior: 16913668! - collectionSpecies - "Answer the species of collection into which the receiver can stream. - This is ByteArray or String, depending on the mode." - - ^buffer1 species! ! -!SmartRefStream methodsFor: 'read write' stamp: 'jmv 10/8/2017 17:59:09' prior: 50366389! -nextPut: anObject - "Really write three objects: (version, class structure, object). But only when called from the outside. If any instance-specific classes are present, prepend their source code. byteStream will be in fileOut format. - You can see an analysis of which objects are written out by doing: - (SmartRefStream statsOfSubObjects: anObject) - (SmartRefStream tallyOfSubObjects: anObject) - (SmartRefStream subObjects: anObject ofClass: aClass)" - -| info | -topCall - ifNil: [ - topCall _ anObject. - 'Please wait while objects are counted' - displayProgressAt: Sensor mousePoint - from: 0 to: 10 - during: [ :barBlock | info _ self instVarInfo: anObject]. - byteStream binary. - 'Writing an object file' displayProgressAt: Sensor mousePoint - from: 0 to: objCount*4 "estimate" - during: [ :barBlock | - objCount _ 0. - progressBar _ barBlock. - self setStream: byteStream reading: false. - "set basePos, but keep any class renames" - super nextPut: ReferenceStream versionCode. - super nextPut: info. - super nextPut: anObject. "<- the real writing" - ]. - "Note: the terminator, $!!, is not doubled inside object data" - "references is an IDict of every object that got written" - byteStream ascii. - byteStream nextPutAll: '!!'; newLine; newLine. - byteStream padToEndIfCantTruncate. - topCall _ progressBar _ nil] "reset it" - ifNotNil: [ - super nextPut: anObject. - progressBar ifNotNil: [progressBar value: (objCount _ objCount + 1)]]. -! ! - -DummyStream removeSelector: #padToEndWith:! - -DummyStream removeSelector: #padToEndWith:! - -StandardFileStream removeSelector: #padToEndWith:! - -StandardFileStream removeSelector: #padToEndWith:! - -FileStream removeSelector: #text! - -FileStream removeSelector: #text! - -RWBinaryOrTextStream removeSelector: #padToEndWith:! - -RWBinaryOrTextStream removeSelector: #padToEndWith:! - -RWBinaryOrTextStream removeSelector: #text! - -RWBinaryOrTextStream removeSelector: #text! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3194-FileStream-cleanup-JuanVuletich-2017Oct08-18h39m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3194] on 11 October 2017 at 12:29:51 pm'! -!SHParserST80 methodsFor: 'parse support' stamp: 'tween 4/28/2004 09:48' prior: 50371171! - enterBlock - blockDepth := blockDepth + 1. - bracketDepth := bracketDepth + 1! ! -!SHParserST80 methodsFor: 'parse support' stamp: 'jmv 3/2/2010 10:06' prior: 50371179! - leaveBlock - arguments removeKey: blockDepth ifAbsent: nil. - temporaries removeKey: blockDepth ifAbsent: nil. - blockDepth := blockDepth - 1. - bracketDepth := bracketDepth - 1! ! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 12/30/2016 10:51:03' prior: 50371219! - parseBacktick - self enterBlock. - self scanPast: #backtick. - currentTokenFirst == $| ifTrue: [self parseBlockTemporaries]. - self parseStatementList. - self failUnless: currentTokenFirst == $`. - self scanPast: #backtick. - self leaveBlock! ! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 10/11/2017 12:27:51' prior: 50371230! - parseBlock - - "Just read $[" - blockDepths add: blockDepth+1. - blockDepthsStartIndexes add: sourcePosition-1. - - self enterBlock. - self scanPast: #blockStart level: bracketDepth. - currentTokenFirst == $: ifTrue: [self parseBlockArguments]. - currentTokenFirst == $| ifTrue: [self parseBlockTemporaries]. - self parseStatementList. - self failUnless: currentTokenFirst == $]. - - "Just read $]" - blockDepths add: blockDepth-1. - blockDepthsStartIndexes add: sourcePosition. - - self scanPast: #blockEnd level: bracketDepth. - self leaveBlock! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3195-FixShoutBracketColoring-JuanVuletich-2017Oct11-12h29m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3195] on 21 October 2017 at 10:12:27 pm'! -!ContextPart methodsFor: 'debugger access' stamp: 'jmv 10/21/2017 22:04:04'! - shortErrorReportOn: strm - "Write a short error report on the stack (above me) on a stream. For both the error file, and emailing a bug report. " - - | cnt aContext | - strm print: Date today; space; print: Time now; newLine. - aContext _ self. - cnt _ 0. - [aContext notNil and: [(cnt _ cnt + 1) < 20]] whileTrue: [ - strm print: aContext; newLine. "just class>>selector" - aContext _ aContext sender]! ! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jmv 10/19/2017 23:20:22'! - isHeadless - "Answer true if any of this VM options was specified in the commandline: - -nodisplay - -vm-display-null - - Smalltalk isHeadless - " - self vmOptionsDo: [ :vmOption :i | - vmOption = '-vm-display-null' ifTrue: [ ^ true ]. - vmOption = '-nodisplay' ifTrue: [ ^ true ] ]. - ^ false! ! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jmv 10/19/2017 23:14:08'! - vmOptionsDo: aBlock - "Repeatedly evaluate aBlock for each vm option specified by the commandline that started Cuis. - aBlock has two arguments: the vm option itself and the index (position) - - Smalltalk vmOptionsDo: [ :option :i | {i. option} print ] - " - | i vmOption | - i _ -1. - [vmOption _ Smalltalk getSystemAttribute: i. - vmOption notNil ] whileTrue: [ - aBlock value: vmOption value: i. - i _ i-1 ]! ! -!UnhandledError methodsFor: 'priv handling' stamp: 'jmv 10/21/2017 22:07:43'! - standaloneAppDefaultAction - "Dump the stack trace to a log file, then exit the program (image)." - - Smalltalk logError: self description inContext: self signalerContext to: 'CuisDebug'. - Smalltalk quitPrimitive: 1! ! -!Debugger class methodsFor: 'class initialization' stamp: 'jmv 10/21/2017 21:54:51' prior: 16830340! - openContext: aContext label: aString contents: contentsStringOrNil - "Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger." - "Simulation guard" - self errorRecursion not & Preferences logDebuggerStackToFile ifTrue: - [Smalltalk logError: aString inContext: aContext to: 'CuisDebug']. - ErrorRecursion ifTrue: [ - ErrorRecursion _ false. - contentsStringOrNil - ifNil: [ - self primitiveError: 'Can not open debugger due to recursion error.', - String newLineString, aString] - ifNotNil: [ - self primitiveError: 'Can not open debugger due to recursion error.', - String newLineString, aString, String newLineString, contentsStringOrNil ]]. - ErrorRecursion _ true. - self informExistingDebugger: aContext label: aString. - (Debugger context: aContext) - openNotifierContents: contentsStringOrNil - label: aString. - ErrorRecursion _ false. - Processor activeProcess suspend. -! ! -!Debugger class methodsFor: 'opening' stamp: 'jmv 10/21/2017 21:54:56' prior: 16830430! - openInterrupt: aString onProcess: interruptedProcess - "Open a notifier in response to an interrupt. An interrupt occurs when the user types the interrupt key (cmd-. on Macs, ctrl-c or alt-. on other systems) or when the low-space watcher detects that memory is low." - | debugger | - "Simulation guard" - debugger _ self new. - debugger - process: interruptedProcess - context: interruptedProcess suspendedContext. - debugger externalInterrupt: true. - -Preferences logDebuggerStackToFile ifTrue: - [(aString includesSubString: 'Space') & - (aString includesSubString: 'low') ifTrue: [ - Smalltalk logError: aString inContext: debugger interruptedContext to: 'LowSpaceDebug']]. - - ^ debugger - openNotifierContents: nil - label: aString -! ! -!Debugger class methodsFor: 'opening' stamp: 'jmv 10/21/2017 21:55:00' prior: 50368363! - openOn: process context: context label: title fullView: bool - "Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger." - | w | - Preferences logDebuggerStackToFile ifTrue: [ - Smalltalk - logError: title - inContext: context - to: 'CuisDebug' ]. - w := ProjectX newProcessIfUIX: process. - "schedule debugger in deferred UI message to address redraw - problems after opening a debugger e.g. from the testrunner." - WorldState addDeferredUIMessage: [ - [ | debugger | - "In case an error in Morphic code got us here, ensure mouse focus has been released" - true runningWorld ifNotNil: [ :rWorld | - rWorld activeHand ifNotNil: [ :aHand | - aHand releaseMouseFocus ]]. - debugger := self new - process: process - context: context. - debugger interruptedProcessUI: w. - bool - ifTrue: [ debugger openFullMorphicLabel: title ] - ifFalse: [ - PreDebugWindow - open: debugger - label: title - message: nil ]] - on: UnhandledError - do: [ :exOuter | | errorDescription | - errorDescription := 'Error while trying to open Debugger' , String newLineString , 'Orginal error: ' , title asString , '.' , String newLineString , ' Debugger error: ' , - ([ exOuter description ] - on: UnhandledError - do: [ :exInner | - exInner return: 'a ' , exInner class printString ]) , ':'. - self primitiveError: errorDescription ]]. - process suspend.! ! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jmv 10/21/2017 22:12:20' prior: 16921052! - logError: errMsg inContext: aContext to: baseFilename - "Log the error message and a stack trace to the given file. - Smalltalk logError: 'test error message' inContext: thisContext to: 'testErr.txt' - " - - | localFilename file | - localFilename _ Preferences debugLogTimestamp - ifTrue: [ baseFilename, '-', Utilities dateTimeSuffix, '.log' ] - ifFalse: [ baseFilename, '.log' ]. - file _ DirectoryEntry smalltalkImageDirectory // localFilename. - [ - file forceWriteStreamDo: [ :stream | - stream nextPutAll: errMsg; newLine. - aContext errorReportOn: stream ] - ] on: UnhandledError do: [ :ex | ex return]. "avoid recursive errors" - [ - StdIOWriteStream stdout newLine; nextPutAll: errMsg. - StdIOWriteStream stdout newLine; nextPutAll: 'See '; nextPutAll: file pathName. - StdIOWriteStream stdout newLine. - aContext shortErrorReportOn: StdIOWriteStream stdout. - StdIOWriteStream stdout flush - ] on: UnhandledError do: [ :ex | ex return]. "avoid recursive errors"! ! -!UnhandledError methodsFor: 'priv handling' stamp: 'jmv 10/21/2017 21:17:43' prior: 16940304! - defaultAction - "The current computation is terminated. The cause of the error should be logged or reported to the user. If the program is operating in an interactive debugging environment the computation should be suspended and the debugger activated." - - self isDevelopmentEnvironmentPresent - ifTrue: [ self devDefaultAction ] - ifFalse: [ self standaloneAppDefaultAction ]! ! -!UnhandledError methodsFor: 'priv handling' stamp: 'jmv 10/19/2017 23:20:13' prior: 16940324! - isDevelopmentEnvironmentPresent - - ^ Smalltalk isHeadless not and: [Smalltalk includesKey: #Debugger]! ! -!Preferences class methodsFor: 'standard queries' stamp: 'jmv 10/19/2017 23:30:02' prior: 16893585! - debugLogTimestamp - ^ self - valueOfFlag: #debugLogTimestamp - ifAbsent: [true]! ! -!Utilities class methodsFor: 'identification' stamp: 'jmv 10/21/2017 21:52:54' prior: 16940682! - dateTimeSuffix - "Answer a string which indicates the date and time, intended for use in building fileout filenames, etc. - - Utilities dateTimeSuffix - " - | n | - n _ DateAndTime now. - ^ String streamContents: [ :strm | - n printYMDOn: strm withLeadingSpace: false. - strm nextPut: $_. - n printHMSOn: strm separator: $. ]! ! -!DisplayScreen methodsFor: 'private' stamp: 'jmv 10/21/2017 21:55:10' prior: 16835312! - findAnyDisplayDepth - "Return any display depth that is supported on this system." - ^self findAnyDisplayDepthIfNone: [ - "Ugh .... now this is a biggie - a system that does not support - any of the Squeak display depths at all." - Smalltalk - logError: 'Fatal error: This system has no support for any display depth at all.' - inContext: thisContext - to: 'CuisDebug'. - Smalltalk quitPrimitive. "There is no way to continue from here" - ]! ! - -Utilities class removeSelector: #monthDayTime24StringFrom:! - -Utilities class removeSelector: #monthDayTime24StringFrom:! - -Utilities class removeSelector: #monthDayTimeStringFrom:! - -Utilities class removeSelector: #monthDayTimeStringFrom:! - -Preferences class removeSelector: #twentyFourHourFileStamps! - -Preferences class removeSelector: #twentyFourHourFileStamps! - -Debugger removeSelector: #storeLog! - -Debugger removeSelector: #storeLog! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3196-StandaloneApps-ExitOnError-JuanVuletich-2017Oct21-22h09m-jmv.1.cs.st----! - -----SNAPSHOT----#(22 October 2017 9:25:10.21694 pm) Cuis5.0-3196-32.image priorSource: 1318076! - -----QUIT----#(22 October 2017 9:25:24.373831 pm) Cuis5.0-3196-32.image priorSource: 1341122! - -----STARTUP----#(3 November 2017 11:15:01.375966 am) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3196-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3196] on 26 October 2017 at 12:41:44 pm'! - -UnhandledError removeSelector: #runtimeDefaultAction! - -UnhandledError removeSelector: #runtimeDefaultAction! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3197-remove-runtimeDefaultAction-JuanVuletich-2017Oct26-12h41m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3197] on 26 October 2017 at 4:59:57 pm'! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'dhn 10/25/2017 16:48:11' prior: 16909778! - browseIt - "Launch a browser for the current selection, if appropriate" - - | aSymbol anEntry browser | - Preferences alternativeBrowseIt ifTrue: [^ self browseClassFromIt]. - - self wordSelectAndEmptyCheck: [^ self]. - (aSymbol _ self selectedSymbol) ifNil: [^ morph flash]. - - aSymbol first isUppercase - ifTrue: [ - anEntry _ (Smalltalk - at: aSymbol - ifAbsent: [ - Smalltalk browseAllImplementorsOf: aSymbol. - ^ nil]). - anEntry ifNil: [^ morph flash]. - (anEntry isKindOf: Class) - ifFalse: [anEntry _ anEntry class]. - browser _ Browser new. - browser setClass: anEntry selector: nil. - BrowserWindow open: browser label:'System Browser: ', aSymbol] - ifFalse: - [Smalltalk browseAllImplementorsOf: aSymbol]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3198-BrowseIt-includeClassName-DanNorton-2017Oct26-16h59m-dhn.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3198] on 27 October 2017 at 9:25:00 am'! -!Preferences class methodsFor: 'standard queries' stamp: 'jmv 10/27/2017 09:24:28' prior: 0! - logDebuggerStackToFile - ^ self - valueOfFlag: #logDebuggerStackToFile - ifAbsent: [ false ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3199-DontLogWalkbacksToDiskByDefault-JuanVuletich-2017Oct27-09h24m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3195] on 22 October 2017 at 4:02:34 pm'! - -MouseEvent subclass: #MouseScrollEvent - instanceVariableNames: 'direction eventHandler' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Events'! - -!classDefinition: #MouseScrollEvent category: #'Morphic-Events'! -MouseEvent subclass: #MouseScrollEvent - instanceVariableNames: 'direction eventHandler' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Events'! -!MouseScrollEvent commentStamp: '' prior: 0! - A MouseScrollEvent can be any type of secondary pointer movement (typically via a scroll wheel on a traditional mouse or a gesture on a trackpad). Currently, events are extracted from KeyboardEvents (which is how the VM currently communicates things like scroll wheel events via ctl+arrow up/down)! -!Morph methodsFor: 'events' stamp: 'pb 10/22/2017 02:55:55'! - mouseScroll: aMouseScrollEvent localPosition: localEventPosition - "Handle a mouse scroll event. - This message will only be sent to Morphs that answer true to #handlesMouseScroll: - We can query aMouseScrollEvent to know about pressed mouse buttons." - - "Allow instances to dynamically use properties for handling common events." - self - valueOfProperty: #mouseScroll:localPosition: - ifPresentDo: [ :handler | handler value: aMouseScrollEvent value: localEventPosition ]! ! -!Morph methodsFor: 'event handling testing' stamp: 'pb 10/22/2017 02:53:48'! - handlesMouseScroll: aMouseScrollEvent - ^ self hasProperty: #'handlesMouseScroll:'! ! -!Morph methodsFor: 'events-processing' stamp: 'pb 10/22/2017 15:49:56'! - processMouseScroll: aMouseEvent localPosition: localEventPosition - ((self handlesMouseScroll: aMouseEvent) and: [ aMouseEvent wasHandled not ]) ifTrue: [ - self - mouseScroll: aMouseEvent - localPosition: localEventPosition. - aMouseEvent wasHandled: true ].! ! -!Morph methodsFor: 'private' stamp: 'pb 10/22/2017 05:19:27'! - privateAnyOwnerHandlesMouseScroll: aMouseScrollEvent - | foundHandler | - foundHandler _ false. - (self ownerChain allButFirst anySatisfy: [ :anOwner | - anOwner isWorldMorph not and: [ anOwner handlesMouseScroll: aMouseScrollEvent ]]) ifTrue: [ foundHandler _ true ]. - ^ foundHandler.! ! -!PluggableScrollPane methodsFor: 'events' stamp: 'pb 10/22/2017 15:52:25'! - mouseScroll: aMouseEvent localPosition: localEventPosition - aMouseEvent direction = #up - ifTrue: [ scrollBar scrollUp: 1 ] - ifFalse: [ scrollBar scrollDown: 1 ].! ! -!PluggableScrollPane methodsFor: 'event handling testing' stamp: 'pb 10/22/2017 16:00:50'! - handlesMouseScroll: aMouseScrollEvent - "Only accept if we can actually do something useful with the event (i.e. not scrolling up when already at the top or down when already at the bottom) or if my owner chain doesn't want it" - | canUse | - canUse _ (aMouseScrollEvent direction = #up and: [ scrollBar scrollValue > 0 ]) or: [ - aMouseScrollEvent direction = #down and: [ scrollBar scrollValue < 1 ]]. - "Even if I don't want it, one of my owners might. (i.e. nested scroll panes) If my owners don't want it, accept the event to make sure that morphs behind me doesn't get the event." - canUse ifFalse: [ - (self privateAnyOwnerHandlesMouseScroll: aMouseScrollEvent) ifFalse: [ canUse _ true ]]. - ^ canUse.! ! -!MouseEvent methodsFor: 'testing' stamp: 'pb 10/22/2017 02:19:31'! - isMouseScroll - ^ type == #mouseScroll! ! -!MouseScrollEvent methodsFor: 'private' stamp: 'pb 10/22/2017 02:17:18'! - setType: evtType position: evtPos direction: evtDir buttons: evtButtons hand: evtHand stamp: stamp - type _ evtType. - position _ evtPos. - buttons _ evtButtons. - source _ evtHand. - wasHandled _ false. - direction _ evtDir. - timeStamp _ stamp.! ! -!MouseScrollEvent methodsFor: 'comparing' stamp: 'pb 10/22/2017 02:18:29'! - hash - ^ position hash + buttons hash + direction hash! ! -!MouseScrollEvent methodsFor: 'dispatching' stamp: 'pb 10/22/2017 15:51:28'! - dispatchWith: aMorph localPosition: positionInAMorph - "Find the appropriate receiver for the event and let it handle it. Default rules: - * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. - * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. - * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. - * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. - " - "Try to get out quickly" - | aMorphHandlesIt handledByInner eventPositionInChild focus| - focus := self hand keyboardFocus. - "FIXME - this works in all tested cases but one: when the window directly under the mouse doesn't have keyboard focus (i.e. a Transcript window)" - ((aMorph fullContainsPoint: positionInAMorph) and: [(aMorph = focus) or: [focus notNil and: [aMorph notNil and: [focus hasOwner: aMorph]]]]) ifFalse: [ ^ #rejected ]. - "Install the prospective handler for the receiver" - aMorphHandlesIt _ false. - (aMorph handlesMouseScroll: self) ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]. - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild - dispatchEvent: self - localPosition: eventPositionInChild) == #rejected ifFalse: [ "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - (handledByInner or: [ - aMorph - containsPoint: positionInAMorph - event: self ]) ifTrue: [ - "aMorph is in the top-most unlocked, visible morph in the chain." - aMorphHandlesIt ifTrue: [ ^ self - sentTo: aMorph - localPosition: positionInAMorph ]]. - handledByInner ifTrue: [ ^ self ]. - "Mouse was not on aMorph nor any of its children" - ^ #rejected.! ! -!MouseScrollEvent methodsFor: 'dispatching' stamp: 'pb 10/22/2017 03:04:54'! - sentTo: aMorph localPosition: positionInAMorph - "Dispatch the receiver into anObject" - ^ aMorph - processMouseScroll: self - localPosition: positionInAMorph.! ! -!MouseScrollEvent methodsFor: 'accessing' stamp: 'pb 10/22/2017 03:15:50'! - direction - ^ direction ! ! -!HandMorph methodsFor: 'events-processing' stamp: 'pb 10/22/2017 14:44:34' prior: 16851817! - startMouseDispatch: aMouseEvent - - aMouseEvent isMouseOver ifTrue: [ - ^self mouseFocus - ifNotNil: [ mouseFocus handleFocusEvent: aMouseEvent ] - ifNil: [ owner dispatchEvent: aMouseEvent localPosition: aMouseEvent eventPosition ]]. - - "any mouse event but mouseOver" - lastMouseEvent _ aMouseEvent. - lastMouseEventTime _ Time localMillisecondClock. - - "Check for pending drag or double click operations." - mouseClickState ifNotNil: [ - (mouseClickState handleEvent: aMouseEvent from: self) ifTrue: [ - "Possibly dispatched #click: or something. Do not further process this event." - ^self mouseOverHandler processMouseOver: lastMouseEvent ]]. - - aMouseEvent isMove - ifTrue: [ - self morphPosition: aMouseEvent eventPosition. - self mouseFocus - ifNotNil: [ mouseFocus handleFocusEvent: aMouseEvent ] - ifNil: [ owner dispatchEvent: aMouseEvent localPosition: aMouseEvent eventPosition ] - ] ifFalse: [ - aMouseEvent isMouseScroll ifTrue: [ - owner dispatchEvent: aMouseEvent localPosition: aMouseEvent eventPosition] ifFalse: [ - "Issue a synthetic move event if we're not at the position of the event" - aMouseEvent eventPosition = self morphPosition ifFalse: [ - "Issue a mouse move event to make the receiver appear at the given position" - self startMouseDispatch: (MouseMoveEvent new - setType: #mouseMove - position: aMouseEvent eventPosition - buttons: aMouseEvent buttons - hand: self - stamp: aMouseEvent timeStamp) ]. - "Drop submorphs on button events" - self hasSubmorphs - ifTrue: [ - "Not if we are grabbing them" - mouseClickState ifNil: [self dropMorphs: aMouseEvent ]] - ifFalse: [ - self mouseFocus - ifNotNil: [ mouseFocus handleFocusEvent: aMouseEvent ] - ifNil: [ owner dispatchEvent: aMouseEvent localPosition: aMouseEvent eventPosition ]]]]. - self mouseOverHandler processMouseOver: self lastMouseEvent! ! -!HandMorph methodsFor: 'private events' stamp: 'pb 10/22/2017 14:48:02' prior: 16852220! - generateKeyboardEvent: evtBuf - "Generate the appropriate mouse event for the given raw event buffer" - | buttons modifiers type keyValue pressType stamp | - stamp _ evtBuf second. - stamp = 0 ifTrue: [ stamp _ Time localMillisecondClock ]. - (evtBuf sixth <= 0 or: [ (keyValue _ Character iso8859s15CodeForUnicodeCodePoint: evtBuf sixth) isNil ]) ifTrue: [ keyValue _ Character macRomanToLatin1: evtBuf third ]. - Sensor peekEvent ifNotNil: [ :nxt | - "start: Combining diacritical marks (i.e. accents in the Linux VM)" - (nxt fourth = EventSensor eventKeyDown and: [ nxt third > 255 ]) ifTrue: [ - keyValue _ ((Character numericValue: keyValue) withDiacriticalMark: nxt third) iso8859s15Code. - Sensor - nextEvent; - nextEvent; - nextEvent ]. - "end: Combining diacritical marks (i.e. accents in the Linux VM)" - "start: Spurious LF after CR on Ctrl-Enter on Windows VM" - ((evtBuf fourth = EventSensor eventKeyChar and: [ evtBuf third = 13 ]) and: [ - nxt fourth = EventSensor eventKeyChar and: [ nxt third = 10 ]]) ifTrue: [ Sensor nextEvent - "print " ]]. - modifiers _ evtBuf fifth. - pressType _ evtBuf fourth. - pressType = EventSensor eventKeyDown ifTrue: [ - type _ #keyDown. - lastKeyDownValue _ keyValue ]. - pressType = EventSensor eventKeyUp ifTrue: [ type _ #keyUp ]. - pressType = EventSensor eventKeyChar ifTrue: [ - type _ #keystroke. - "If Control key pressed, and the VM answers a code below 27, - it means it did the translation, convert it back to regular character: - We want to handle the meaning of ctrl ourselves." - (modifiers anyMask: 2) ifTrue: [ - "Control key pressed" - keyValue < 27 ifTrue: [ - "But we don't want to do it for Home/End/PgUp/PgDn, just for alphabetic keys" - lastKeyDownValue = keyValue ifFalse: [ - "If equal, real Home/End/PgUp/PgDn in Windows => don't translate" - (keyValue + 64 = lastKeyDownValue or: [ "If Equal, Ctrl-alphabetic in Windows => do translate" - lastKeyDownValue < 47 ]) ifTrue: [ - "Not on windows. If less (not sure about the bound, but do not translate 48: tab on Mac), alphabetic on Mac => do translate" - keyValue _ (modifiers anyMask: 1) - ifTrue: [ keyValue + 64 ] - ifFalse: [ keyValue + 96 - "shift not pressed: conver to lowercase letter" ]]]]. - "Act as if command/alt was pressed for some usual Windows ctrl-key combinations" - (self shouldControlEmulateAltFor: keyValue) ifTrue: [ modifiers _ modifiers bitOr: 8 ]]]. - buttons _ modifiers bitShift: 3. - (modifiers = 2 and: [ - keyValue = 30 or: [ keyValue = 31 ]]) - ifTrue: [ "We're hijacking ctl-up/down arrow since that is what the VM sends us for scroll events. We're going to convert these to MouseScrollEvent and throw away the keyboard event" - ^ MouseScrollEvent new - setType: #mouseScroll - position: self morphPosition - direction: - (keyValue caseOf: { - [ "Implementing as a caseof to allow for easy adding of left/right/other events should they become available" - 30 ] -> [ #up ]. - [ 31 ] -> [ #down ]}) - buttons: buttons - hand: self - stamp: stamp ] - ifFalse: [ ^ KeyboardEvent new - setType: type - buttons: buttons - position: self morphPosition - keyValue: keyValue - hand: self - stamp: stamp ].! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3200-Morph-Scroll-Events-PhilBellalouna-2017Oct22-02h07m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3200] on 27 October 2017 at 9:38:49 am'! -!PluggableScrollPane methodsFor: 'events' stamp: 'jmv 10/27/2017 09:38:25' prior: 16889541! - keyStroke: aKeyboardEvent - - (Theme current keyStroke: aKeyboardEvent morph: self) - ifTrue: [^ self]. - ( self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - super keyStroke: aKeyboardEvent. - scroller keyStroke: aKeyboardEvent! ! -!HierarchicalListMorph methodsFor: 'events' stamp: 'jmv 10/27/2017 09:38:10' prior: 16853054! - keyStroke: aKeyboardEvent - "Process potential command keys" - - | args aCharacter | - (Theme current keyStroke: aKeyboardEvent morph: self) - ifTrue: [^ self]. - (self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - aCharacter _ aKeyboardEvent keyCharacter. - (self arrowKey: aCharacter) - ifTrue: [ ^self ]. - keystrokeActionSelector ifNil: [^self]. - (args _ keystrokeActionSelector numArgs) = 1 - ifTrue: [^mainView perform: keystrokeActionSelector with: aCharacter]. - args = 2 - ifTrue: [ - ^mainView - perform: keystrokeActionSelector - with: aCharacter - with: self]. - ^self error: 'The keystrokeActionSelector must be a 1- or 2-keyword symbol'! ! -!PluggableListMorph methodsFor: 'events' stamp: 'jmv 10/27/2017 09:38:21' prior: 16888604! - keyStroke: aKeyboardEvent - "Process keys" - - | aCharacter | - (Theme current keyStroke: aKeyboardEvent morph: self) - ifTrue: [^ self]. - (self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - aCharacter _ aKeyboardEvent keyCharacter. - (self arrowKey: aCharacter) - ifTrue: [ ^self ]. - aCharacter numericValue = 27 ifTrue: [ " escape key" - ^ self mouseButton2Activity]. - aKeyboardEvent anyModifierKeyPressed - ifTrue: [ - (self keystrokeAction: aCharacter) - ifTrue: [ ^self ]]. - ^ self keyboardSearch: aCharacter! ! -!HandMorph methodsFor: 'private events' stamp: 'jmv 10/27/2017 09:36:10' prior: 50373900! - generateKeyboardEvent: evtBuf - "Generate the appropriate mouse event for the given raw event buffer" - | buttons modifiers type keyValue pressType stamp | - stamp _ evtBuf second. - stamp = 0 ifTrue: [ stamp _ Time localMillisecondClock ]. - (evtBuf sixth <= 0 or: [ (keyValue _ Character iso8859s15CodeForUnicodeCodePoint: evtBuf sixth) isNil ]) ifTrue: [ keyValue _ Character macRomanToLatin1: evtBuf third ]. - Sensor peekEvent ifNotNil: [ :nxt | - "start: Combining diacritical marks (i.e. accents in the Linux VM)" - (nxt fourth = EventSensor eventKeyDown and: [ nxt third > 255 ]) ifTrue: [ - keyValue _ ((Character numericValue: keyValue) withDiacriticalMark: nxt third) iso8859s15Code. - Sensor - nextEvent; - nextEvent; - nextEvent ]. - "end: Combining diacritical marks (i.e. accents in the Linux VM)" - "start: Spurious LF after CR on Ctrl-Enter on Windows VM" - ((evtBuf fourth = EventSensor eventKeyChar and: [ evtBuf third = 13 ]) and: [ - nxt fourth = EventSensor eventKeyChar and: [ nxt third = 10 ]]) ifTrue: [ Sensor nextEvent - "print " ]]. - modifiers _ evtBuf fifth. - pressType _ evtBuf fourth. - pressType = EventSensor eventKeyDown ifTrue: [ - type _ #keyDown. - lastKeyDownValue _ keyValue ]. - pressType = EventSensor eventKeyUp ifTrue: [ type _ #keyUp ]. - pressType = EventSensor eventKeyChar ifTrue: [ - type _ #keystroke. - "If Control key pressed, and the VM answers a code below 27, - it means it did the translation, convert it back to regular character: - We want to handle the meaning of ctrl ourselves." - (modifiers anyMask: 2) ifTrue: [ - "Control key pressed" - keyValue < 27 ifTrue: [ - "But we don't want to do it for Home/End/PgUp/PgDn, just for alphabetic keys" - lastKeyDownValue = keyValue ifFalse: [ - "If equal, real Home/End/PgUp/PgDn in Windows => don't translate" - (keyValue + 64 = lastKeyDownValue or: [ "If Equal, Ctrl-alphabetic in Windows => do translate" - lastKeyDownValue < 47 ]) ifTrue: [ - "Not on windows. If less (not sure about the bound, but do not translate 48: tab on Mac), alphabetic on Mac => do translate" - keyValue _ (modifiers anyMask: 1) - ifTrue: [ keyValue + 64 ] - ifFalse: [ keyValue + 96 - "shift not pressed: conver to lowercase letter" ]]]]. - "Act as if command/alt was pressed for some usual Windows ctrl-key combinations" - (self shouldControlEmulateAltFor: keyValue) ifTrue: [ modifiers _ modifiers bitOr: 8 ]]]. - buttons _ modifiers bitShift: 3. - (modifiers = 2 and: [ - keyValue = 30 or: [ keyValue = 31 ]]) - ifTrue: [ "We're hijacking ctl-up/down arrow since that is what the VM sends us for scroll events. We're going to convert these to MouseScrollEvent and throw away the keyboard event" - "ThisPrecludes the use of up and down arrows with control, that are standard keystrokes in Windows to control the cursor. - But as Linux, Mac and Windows VMs generate ctrl-up and ctrl-down for mouse wheel events, we must honor them. - Some day, it would be good for the VMs to report mouse wheel events differently fom ctrl-up & ctrl-down..." - ^ MouseScrollEvent new - setType: #mouseScroll - position: self morphPosition - direction: - (keyValue caseOf: { - [ "Implementing as a caseof to allow for easy adding of left/right/other events should they become available" - 30 ] -> [ #up ]. - [ 31 ] -> [ #down ]}) - buttons: buttons - hand: self - stamp: stamp ] - ifFalse: [ ^ KeyboardEvent new - setType: type - buttons: buttons - position: self morphPosition - keyValue: keyValue - hand: self - stamp: stamp ].! ! -!InnerTextMorph methodsFor: 'events' stamp: 'jmv 10/27/2017 09:38:16' prior: 16855703! - keyStroke: aKeyboardEvent - - (Theme current keyStroke: aKeyboardEvent morph: self) - ifTrue: [^ self]. - (self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - - autoCompleter - ifNil: [ self processKeyStroke: aKeyboardEvent ] - ifNotNil: [ - autoCompleter - autoCompletionAround: [ self processKeyStroke: aKeyboardEvent ] - keyStroke: aKeyboardEvent ]! ! - -PluggableScrollPane removeSelector: #scrollByKeyboard:! - -PluggableScrollPane removeSelector: #scrollByKeyboard:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3201-Cleanup-JuanVuletich-2017Oct27-09h31m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3201] on 27 October 2017 at 9:58:10 am'! -!MouseScrollEvent commentStamp: '' prior: 50373644! - A MouseScrollEvent can be any type of secondary pointer movement (typically via a scroll wheel on a traditional mouse or a gesture on a trackpad). Currently, events are extracted from KeyboardEvents (which is how the VM currently communicates things like scroll wheel events via ctl+arrow up/down). - -It is also possible to generate these events with a keyboard, pressing ctrl-down or ctrl-up. Given this, we also added ctrl-left and ctrl-right, that can only be generated with a keyboard, to control horizontal scroll.! -!PluggableScrollPane methodsFor: 'events' stamp: 'jmv 10/27/2017 09:56:48' prior: 50373702! - mouseScroll: aMouseEvent localPosition: localEventPosition - aMouseEvent direction - caseOf: { - [ #up ] -> [ scrollBar scrollUp: 1 ]. - [ #down ] -> [ scrollBar scrollDown: 1 ]. - [ #left ] -> [ hScrollBar scrollUp: 1 ]. - [ #right ] -> [ hScrollBar scrollDown: 1 ] }! ! -!PluggableScrollPane methodsFor: 'event handling testing' stamp: 'jmv 10/27/2017 09:47:51' prior: 50373711! - handlesMouseScroll: aMouseScrollEvent - "Only accept if we can actually do something useful with the event (i.e. not scrolling up when already at the top or down when already at the bottom) or if my owner chain doesn't want it" - - (aMouseScrollEvent direction = #up and: [ scrollBar scrollValue > 0 ]) - ifTrue: [ ^ true ]. - (aMouseScrollEvent direction = #down and: [ scrollBar scrollValue < 1 ]) - ifTrue: [ ^ true ]. - (aMouseScrollEvent direction = #left and: [ hScrollBar scrollValue > 0 ]) - ifTrue: [ ^ true ]. - (aMouseScrollEvent direction = #right and: [ hScrollBar scrollValue < 1 ]) - ifTrue: [ ^ true ]. - "Even if I don't want it, one of my owners might. (i.e. nested scroll panes) If my owners don't want it, accept the event to make sure that morphs behind me doesn't get the event." - (self privateAnyOwnerHandlesMouseScroll: aMouseScrollEvent) - ifFalse: [ ^ true ]. - ^ false! ! -!HandMorph methodsFor: 'private events' stamp: 'jmv 10/27/2017 09:57:46' prior: 50374067! - generateKeyboardEvent: evtBuf - "Generate the appropriate mouse event for the given raw event buffer" - | buttons modifiers type keyValue pressType stamp | - stamp _ evtBuf second. - stamp = 0 ifTrue: [ stamp _ Time localMillisecondClock ]. - (evtBuf sixth <= 0 or: [ (keyValue _ Character iso8859s15CodeForUnicodeCodePoint: evtBuf sixth) isNil ]) ifTrue: [ keyValue _ Character macRomanToLatin1: evtBuf third ]. - Sensor peekEvent ifNotNil: [ :nxt | - "start: Combining diacritical marks (i.e. accents in the Linux VM)" - (nxt fourth = EventSensor eventKeyDown and: [ nxt third > 255 ]) ifTrue: [ - keyValue _ ((Character numericValue: keyValue) withDiacriticalMark: nxt third) iso8859s15Code. - Sensor - nextEvent; - nextEvent; - nextEvent ]. - "end: Combining diacritical marks (i.e. accents in the Linux VM)" - "start: Spurious LF after CR on Ctrl-Enter on Windows VM" - ((evtBuf fourth = EventSensor eventKeyChar and: [ evtBuf third = 13 ]) and: [ - nxt fourth = EventSensor eventKeyChar and: [ nxt third = 10 ]]) ifTrue: [ Sensor nextEvent - "print " ]]. - modifiers _ evtBuf fifth. - pressType _ evtBuf fourth. - pressType = EventSensor eventKeyDown ifTrue: [ - type _ #keyDown. - lastKeyDownValue _ keyValue ]. - pressType = EventSensor eventKeyUp ifTrue: [ type _ #keyUp ]. - pressType = EventSensor eventKeyChar ifTrue: [ - type _ #keystroke. - "If Control key pressed, and the VM answers a code below 27, - it means it did the translation, convert it back to regular character: - We want to handle the meaning of ctrl ourselves." - (modifiers anyMask: 2) ifTrue: [ - "Control key pressed" - keyValue < 27 ifTrue: [ - "But we don't want to do it for Home/End/PgUp/PgDn, just for alphabetic keys" - lastKeyDownValue = keyValue ifFalse: [ - "If equal, real Home/End/PgUp/PgDn in Windows => don't translate" - (keyValue + 64 = lastKeyDownValue or: [ "If Equal, Ctrl-alphabetic in Windows => do translate" - lastKeyDownValue < 47 ]) ifTrue: [ - "Not on windows. If less (not sure about the bound, but do not translate 48: tab on Mac), alphabetic on Mac => do translate" - keyValue _ (modifiers anyMask: 1) - ifTrue: [ keyValue + 64 ] - ifFalse: [ keyValue + 96 - "shift not pressed: conver to lowercase letter" ]]]]. - "Act as if command/alt was pressed for some usual Windows ctrl-key combinations" - (self shouldControlEmulateAltFor: keyValue) ifTrue: [ modifiers _ modifiers bitOr: 8 ]]]. - buttons _ modifiers bitShift: 3. - (modifiers = 2 and: [ - keyValue between: 28 and: 31]) - ifTrue: [ "We're hijacking ctl-up/down arrow since that is what the VM sends us for scroll events. We're going to convert these to MouseScrollEvent and throw away the keyboard event" - "ThisPrecludes the use of up and down arrows with control, that are standard keystrokes in Windows to control the cursor. - But as Linux, Mac and Windows VMs generate ctrl-up and ctrl-down for mouse wheel events, we must honor them. - Some day, it would be good for the VMs to report mouse wheel events differently fom ctrl-up & ctrl-down..." - "Also do ctrl-left and ctrl-right for horizontal scroll." - ^ MouseScrollEvent new - setType: #mouseScroll - position: self morphPosition - direction: - (keyValue caseOf: { - "Implementing as a caseof to allow for easy adding of left/right/other events should they become available" - [ 30 ] -> [ #up ]. - [ 31 ] -> [ #down ]. - [ 28 ] -> [ #left ]. - [ 29 ] -> [ #right ]. - }) - buttons: buttons - hand: self - stamp: stamp ] - ifFalse: [ ^ KeyboardEvent new - setType: type - buttons: buttons - position: self morphPosition - keyValue: keyValue - hand: self - stamp: stamp ].! ! -!MouseEvent methodsFor: 'comparing' stamp: 'jmv 10/27/2017 09:42:20' prior: 16879126! - hash - ^ type hash bitXor: (position hash bitXor: buttons hash)! ! -!MouseMoveEvent methodsFor: 'comparing' stamp: 'jmv 10/27/2017 09:42:03' prior: 16879243! - hash - ^ position hash bitXor: buttons hash! ! -!MouseScrollEvent methodsFor: 'comparing' stamp: 'jmv 10/27/2017 09:41:31' prior: 50373750! - hash - ^ position hash bitXor: (buttons hash bitXor: direction hash)! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3202-HorizontalScrollEvents-JuanVuletich-2017Oct27-09h52m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3202] on 30 October 2017 at 10:28:09 am'! -!Timespan methodsFor: 'smalltalk-80' stamp: 'jmv 10/30/2017 10:26:58' prior: 16938162! - previous - " - (Month month: 10 year: 2017) previous - (Year yearNumber: 2016) previous - " - ^self class classDefinesDuration - ifTrue: [ self class including: self end - duration ] - ifFalse: [ self class starting: start - duration duration: duration ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3203-Month-Year-previous-fix-JuanVuletich-2017Oct30-10h24m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3202] on 30 October 2017 at 10:37:01 am'! -!Preferences class methodsFor: 'standard queries' stamp: 'jmv 10/30/2017 10:36:16'! - ctrlArrowsScrollHorizontally - ^ self - valueOfFlag: #ctrlArrowsScrollHorizontally - ifAbsent: [ false ]! ! -!HandMorph methodsFor: 'private events' stamp: 'jmv 10/30/2017 10:35:34' prior: 50374270! - generateKeyboardEvent: evtBuf - "Generate the appropriate mouse event for the given raw event buffer" - | buttons modifiers type keyValue pressType stamp | - stamp _ evtBuf second. - stamp = 0 ifTrue: [ stamp _ Time localMillisecondClock ]. - (evtBuf sixth <= 0 or: [ (keyValue _ Character iso8859s15CodeForUnicodeCodePoint: evtBuf sixth) isNil ]) ifTrue: [ keyValue _ Character macRomanToLatin1: evtBuf third ]. - Sensor peekEvent ifNotNil: [ :nxt | - "start: Combining diacritical marks (i.e. accents in the Linux VM)" - (nxt fourth = EventSensor eventKeyDown and: [ nxt third > 255 ]) ifTrue: [ - keyValue _ ((Character numericValue: keyValue) withDiacriticalMark: nxt third) iso8859s15Code. - Sensor - nextEvent; - nextEvent; - nextEvent ]. - "end: Combining diacritical marks (i.e. accents in the Linux VM)" - "start: Spurious LF after CR on Ctrl-Enter on Windows VM" - ((evtBuf fourth = EventSensor eventKeyChar and: [ evtBuf third = 13 ]) and: [ - nxt fourth = EventSensor eventKeyChar and: [ nxt third = 10 ]]) ifTrue: [ Sensor nextEvent - "print " ]]. - modifiers _ evtBuf fifth. - pressType _ evtBuf fourth. - pressType = EventSensor eventKeyDown ifTrue: [ - type _ #keyDown. - lastKeyDownValue _ keyValue ]. - pressType = EventSensor eventKeyUp ifTrue: [ type _ #keyUp ]. - pressType = EventSensor eventKeyChar ifTrue: [ - type _ #keystroke. - "If Control key pressed, and the VM answers a code below 27, - it means it did the translation, convert it back to regular character: - We want to handle the meaning of ctrl ourselves." - (modifiers anyMask: 2) ifTrue: [ - "Control key pressed" - keyValue < 27 ifTrue: [ - "But we don't want to do it for Home/End/PgUp/PgDn, just for alphabetic keys" - lastKeyDownValue = keyValue ifFalse: [ - "If equal, real Home/End/PgUp/PgDn in Windows => don't translate" - (keyValue + 64 = lastKeyDownValue or: [ "If Equal, Ctrl-alphabetic in Windows => do translate" - lastKeyDownValue < 47 ]) ifTrue: [ - "Not on windows. If less (not sure about the bound, but do not translate 48: tab on Mac), alphabetic on Mac => do translate" - keyValue _ (modifiers anyMask: 1) - ifTrue: [ keyValue + 64 ] - ifFalse: [ keyValue + 96 - "shift not pressed: conver to lowercase letter" ]]]]. - "Act as if command/alt was pressed for some usual Windows ctrl-key combinations" - (self shouldControlEmulateAltFor: keyValue) ifTrue: [ modifiers _ modifiers bitOr: 8 ]]]. - buttons _ modifiers bitShift: 3. - (modifiers = 2 and: [ - keyValue - between: (Preferences ctrlArrowsScrollHorizontally ifTrue: [28] ifFalse: [30]) - and: 31]) - ifTrue: [ "We're hijacking ctl-up/down arrow since that is what the VM sends us for scroll events. We're going to convert these to MouseScrollEvent and throw away the keyboard event" - "ThisPrecludes the use of up and down arrows with control, that are standard keystrokes in Windows to control the cursor. - But as Linux, Mac and Windows VMs generate ctrl-up and ctrl-down for mouse wheel events, we must honor them. - Some day, it would be good for the VMs to report mouse wheel events differently fom ctrl-up & ctrl-down..." - "Also do ctrl-left and ctrl-right for horizontal scroll." - ^ MouseScrollEvent new - setType: #mouseScroll - position: self morphPosition - direction: - (keyValue caseOf: { - "Implementing as a caseof to allow for easy adding of left/right/other events should they become available" - [ 30 ] -> [ #up ]. - [ 31 ] -> [ #down ]. - [ 28 ] -> [ #left ]. - [ 29 ] -> [ #right ]. - }) - buttons: buttons - hand: self - stamp: stamp ] - ifFalse: [ ^ KeyboardEvent new - setType: type - buttons: buttons - position: self morphPosition - keyValue: keyValue - hand: self - stamp: stamp ].! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3204-ByDefault-ctrlLeftRight-jumpsWords-JuanVuletich-2017Oct30-10h28m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3204] on 1 November 2017 at 3:31:08 pm'! -!Character methodsFor: 'accessing' stamp: 'jmv 8/11/2016 09:46:09' prior: 16800406! - nonImmediateNumericValue - "Answer the numeric value of the receiver, if instances happen to be regular (i.e. not in Spur)" - - ^self instVarAt: 1! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3205-Dummy-JuanVuletich-2017Nov01-15h29m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3205] on 1 November 2017 at 4:07:42 pm'! - -MessageSet subclass: #ProtocolBrowser - instanceVariableNames: 'selectiveClassListIndex selectiveClassList baseClass selectedName exclude ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Browser'! - -!classDefinition: #ProtocolBrowser category: #'Tools-Browser'! -MessageSet subclass: #ProtocolBrowser - instanceVariableNames: 'selectiveClassListIndex selectiveClassList baseClass selectedName exclude' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Browser'! - -MessageSetWindow subclass: #ProtocolBrowserWindow - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Tools'! - -!classDefinition: #ProtocolBrowserWindow category: #'Morphic-Tools'! -MessageSetWindow subclass: #ProtocolBrowserWindow - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Tools'! -!ProtocolBrowserWindow commentStamp: '' prior: 0! - A view of the messages available to a class from itself upward through the class hierarchy. The viewed protocol can be pruned by selecting a superclass in the class hierchy pane.! -!ProtocolBrowser methodsFor: 'accessing' stamp: 'dhn 10/31/2017 17:06:51'! - labelString - "Answer the string for the window title" - - ^ 'Protocol for: ', baseClass name, ' up to: ', selectedName! ! -!ProtocolBrowser methodsFor: 'private' stamp: 'dhn 10/31/2017 17:38:39'! - hierarchyForClass: aClass - "Set the class hierarchy for the list pane" - | tab | - - selectiveClassList _ OrderedCollection new. - tab _ ''. - aClass withAllSuperclasses reverse do: [:ea | - selectiveClassList add: tab , ea name. - tab _ tab , ' ']. - self classListIndex: 0! ! -!ProtocolBrowser methodsFor: 'private' stamp: 'dhn 10/31/2017 16:56:42'! - protocolFor: anIndex - "Change the listed protocol" - - exclude _ OrderedCollection new. - anIndex > 0 - ifTrue: [ - selectedName _ (selectiveClassList at: anIndex) withBlanksTrimmed. - (1 to: anIndex - 1) do: [:ix | - exclude addLast: (selectiveClassList at: ix) withBlanksTrimmed]] - ifFalse: [ - selectedName _ nil. - ]. - self on: baseClass. - self changed: #relabel! ! -!ProtocolBrowser methodsFor: 'private' stamp: 'dhn 10/30/2017 15:40:07'! - selectiveClassList - "Answer the value of selectiveClassList" - - ^ selectiveClassList! ! -!ProtocolBrowser methodsFor: 'private' stamp: 'dhn 10/30/2017 17:02:13'! -selectiveClassListIndex - "Answer the value of selectiveClassListIndex" - - selectiveClassListIndex ifNil: [selectiveClassListIndex _ 0]. - ^ selectiveClassListIndex! ! -!ProtocolBrowser methodsFor: 'private' stamp: 'dhn 10/30/2017 17:02:28'! - selectiveClassListIndex: anObject - "Set the value of selectiveClassListIndex" - - selectiveClassListIndex _ anObject. - self protocolFor: selectiveClassListIndex -! ! -!ProtocolBrowser methodsFor: 'initialization' stamp: 'dhn 10/31/2017 15:03:26'! - initialize - - exclude _ OrderedCollection new! ! -!ProtocolBrowserWindow methodsFor: 'GUI building' stamp: 'dhn 10/30/2017 17:28:22'! - buildMorphicWindow - "Answer a morphic window that can display the receiver with a class hierarchy" - | topRow | - - topRow _ LayoutMorph newRow. - topRow - addMorph: self buildSelectiveClassList proportionalWidth: 0.3; - addAdjusterMorph; - addMorph: self buildMorphicMessageList proportionalWidth: 0.7. - self layoutMorph - addMorph: topRow proportionalHeight: 0.2; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.8. - model changed: #editSelection! ! -!ProtocolBrowserWindow methodsFor: 'GUI building' stamp: 'dhn 10/30/2017 16:56:49'! - buildSelectiveClassList - "Define the class hierarchy list pane" - - ^PluggableListMorph - model: model - listGetter: #selectiveClassList - indexGetter: #selectiveClassListIndex - indexSetter: #selectiveClassListIndex:! ! -!ProtocolBrowserWindow methodsFor: 'updating' stamp: 'dhn 10/30/2017 19:23:00'! - update: aSymbol - "Respond to events of the Dependency Mechanism" - - super update: aSymbol. - aSymbol == #relabel - ifTrue: [self setLabel: model labelString]! ! -!ProtocolBrowser methodsFor: 'private' stamp: 'dhn 10/31/2017 16:33:52' prior: 16896671! - initListFrom: selectorCollection highlighting: aClass - "Make up the messageList with items from aClass in boldface." - | defClass item | - - messageList _ OrderedCollection new. - selectorCollection do: [ :selector | - defClass _ aClass whichClassIncludesSelector: selector. - item _ selector, ' (' , defClass name , ')'. - defClass == aClass ifTrue: [item _ item asText allBold]. - messageList add: ( - MethodReference new - setClass: defClass - methodSymbol: selector - stringVersion: item)]. - self hierarchyForClass: (baseClass _ aClass)! ! -!ProtocolBrowser methodsFor: 'private' stamp: 'dhn 10/31/2017 18:08:50' prior: 16896690! - on: aClass - "Initialize the protocol for the class, aClass." - "Optionally, the upper part of the protocol is excluded." - | selectors | - - selectors _ Set new. - aClass withAllSuperclasses do: [ :each | - (exclude includes: each name) ifFalse: [selectors addAll: each selectors]]. - self - initListFrom: selectors asArray sort - highlighting: aClass! ! -!CodeWindow methodsFor: 'menu commands' stamp: 'dhn 10/30/2017 16:28:04' prior: 16813280! - browseFullProtocol - "Create and schedule a new protocol browser on the currently selected class or meta." - - | aPBrowser label | - model selectedClassOrMetaClass ifNotNil: [ :classOrMetaclass | - aPBrowser _ ProtocolBrowser new on: classOrMetaclass. - label _ 'Entire protocol of: ', classOrMetaclass name. - ProtocolBrowserWindow open: aPBrowser label: label ]! ! - -MessageSet subclass: #ProtocolBrowser - instanceVariableNames: 'baseClass selectiveClassList selectiveClassListIndex selectedName exclude' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Browser'! - -!classDefinition: #ProtocolBrowser category: #'Tools-Browser'! -MessageSet subclass: #ProtocolBrowser - instanceVariableNames: 'baseClass selectiveClassList selectiveClassListIndex selectedName exclude' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Browser'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3206-EnhancedProtocolBrowser-DanNorton-2017Nov01-16h05m-dhn.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3206] on 3 November 2017 at 10:42:58 am'! -!Object methodsFor: 'system primitives' stamp: 'jmv 12/31/1969 21:14:14'! - instVarAtPrim73: index - "Primitive. Answer a fixed variable in an object. The numbering of the - variables corresponds to the named instance variables. Fail if the index - is not an Integer or is not the index of a fixed variable. Essential. See - Object documentation whatIsAPrimitive." - - - "Access beyond fixed variables." - ^self basicAt: index - self class instSize! ! -!Object methodsFor: 'system primitives' stamp: 'jmv 12/31/1969 21:15:46'! - instVarAtPrim74: anInteger put: anObject - "Primitive. Store a value into a fixed variable in the receiver. The - numbering of the variables corresponds to the named instance variables. - Fail if the index is not an Integer or is not the index of a fixed variable. - Answer the value stored as the result. Using this message violates the - principle that each object has sovereign control over the storing of - values into its instance variables. Essential. See Object documentation - whatIsAPrimitive." - - - "Access beyond fixed fields" - ^self basicAt: anInteger - self class instSize put: anObject! ! -!Object methodsFor: 'system primitives' stamp: 'jmv 12/31/1969 21:17:57' prior: 16882332! - instVarAt: index - "Primitive. Answer a fixed variable in an object. The numbering of the variables - corresponds to the named instance variables, followed by the indexed instance - variables. Fail if the index is not an Integer or is not the index of a fixed variable. - Essential. See Object documentation whatIsAPrimitive." - - - "The classic InterpreterVMs don't support primitives 173 and 174. - See http://forum.world.st/Some-test-where-Spur-more-slow-than-Cog-td4867810.html#a4867888 - Use primitives 73 and 74 in such case." - Smalltalk isRunningCog ifFalse: [ - ^ self instVarAtPrim73: index ]. - self primitiveFailed! ! -!Object methodsFor: 'system primitives' stamp: 'jmv 12/31/1969 21:17:51' prior: 16882347! - instVarAt: index put: anObject - "Primitive. Store a value into a fixed variable in an object. The numbering of the - variables corresponds to the named instance variables, followed by the indexed - instance variables. Fail if the index is not an Integer or is not the index of a fixed - variable. Essential. See Object documentation whatIsAPrimitive." - - - "The classic InterpreterVMs don't support primitives 173 and 174. - See http://forum.world.st/Some-test-where-Spur-more-slow-than-Cog-td4867810.html#a4867888 - Use primitives 73 and 74 in such case." - Smalltalk isRunningCog ifFalse: [ - ^ self instVarAtPrim74: index put: anObject ]. - self primitiveFailed! ! -!Character methodsFor: 'accessing' stamp: 'jmv 8/11/2016 09:46:09' prior: 50374566! - nonImmediateNumericValue - "Answer the numeric value of the receiver, if instances happen to be regular (i.e. not in Spur)" - - ^self instVarAt: 1! ! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jmv 12/31/1969 21:13:09' prior: 16920989! - interpreterClass - "Interpreter class (Cog VM only) - nil for classic Interpreter VM - " - ^self getSystemAttribute: 1007! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3207-MakeCuisWorkOnInterpreterVM-JuanVuletich-2017Nov03-10h42m-jmv.1.cs.st----! - -----SNAPSHOT----#(3 November 2017 11:15:08.951567 am) Cuis5.0-3207-32.image priorSource: 1341219! - -----QUIT----#(3 November 2017 11:15:27.868511 am) Cuis5.0-3207-32.image priorSource: 1383562! - -----STARTUP----#(28 November 2017 3:35:19.509418 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3207-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3207] on 10 November 2017 at 11:08:35 am'! -!HandMorph methodsFor: 'private events' stamp: 'jmv 11/10/2017 11:07:46' prior: 50374437! - generateKeyboardEvent: evtBuf - "Generate the appropriate mouse event for the given raw event buffer" - | buttons modifiers type keyValue pressType stamp | - stamp _ evtBuf second. - stamp = 0 ifTrue: [ stamp _ Time localMillisecondClock ]. - (evtBuf sixth <= 0 or: [ (keyValue _ Character iso8859s15CodeForUnicodeCodePoint: evtBuf sixth) isNil ]) ifTrue: [ keyValue _ Character macRomanToLatin1: evtBuf third ]. - Sensor peekEvent ifNotNil: [ :nxt | - "start: Combining diacritical marks (i.e. accents in the Linux VM)" - (nxt fourth = EventSensor eventKeyDown and: [ nxt third > 255 ]) ifTrue: [ - keyValue _ ((Character numericValue: keyValue) withDiacriticalMark: nxt third) iso8859s15Code. - Sensor - nextEvent; - nextEvent; - nextEvent ]. - "end: Combining diacritical marks (i.e. accents in the Linux VM)" - "start: Spurious LF after CR on Ctrl-Enter on Windows VM" - ((evtBuf fourth = EventSensor eventKeyChar and: [ evtBuf third = 13 ]) and: [ - nxt fourth = EventSensor eventKeyChar and: [ nxt third = 10 ]]) ifTrue: [ Sensor nextEvent - "print " ]]. - modifiers _ evtBuf fifth. - pressType _ evtBuf fourth. - pressType = EventSensor eventKeyDown ifTrue: [ - type _ #keyDown. - lastKeyDownValue _ keyValue ]. - pressType = EventSensor eventKeyUp ifTrue: [ type _ #keyUp ]. - pressType = EventSensor eventKeyChar ifTrue: [ - type _ #keystroke. - "If Control key pressed, and the VM answers a code below 27, - it means it did the translation, convert it back to regular character: - We want to handle the meaning of ctrl ourselves." - (modifiers anyMask: 2) ifTrue: [ - "Control key pressed" - keyValue < 27 ifTrue: [ - "But we don't want to do it for Home/End/PgUp/PgDn, just for alphabetic keys" - lastKeyDownValue = keyValue ifFalse: [ - "If equal, real Home/End/PgUp/PgDn in Windows => don't translate" - (keyValue + 64 = lastKeyDownValue or: [ "If Equal, Ctrl-alphabetic in Windows => do translate" - lastKeyDownValue < 47 ]) ifTrue: [ - "Not on windows. If less (not sure about the bound, but do not translate 48: tab on Mac), alphabetic on Mac => do translate" - keyValue _ (modifiers anyMask: 1) - ifTrue: [ keyValue + 64 ] - ifFalse: [ keyValue + 96 - "shift not pressed: conver to lowercase letter" ]]]]. - "Act as if command/alt was pressed for some usual Windows ctrl-key combinations" - (self shouldControlEmulateAltFor: keyValue) ifTrue: [ modifiers _ modifiers bitOr: 8 ]]]. - buttons _ modifiers bitShift: 3. - ((modifiers anyMask: 2) and: [ - keyValue - between: (Preferences ctrlArrowsScrollHorizontally ifTrue: [28] ifFalse: [30]) - and: 31]) - ifTrue: [ "We're hijacking ctl-up/down arrow since that is what the VM sends us for scroll events. We're going to convert these to MouseScrollEvent and throw away the keyboard event" - "ThisPrecludes the use of up and down arrows with control, that are standard keystrokes in Windows to control the cursor. - But as Linux, Mac and Windows VMs generate ctrl-up and ctrl-down for mouse wheel events, we must honor them. - Some day, it would be good for the VMs to report mouse wheel events differently fom ctrl-up & ctrl-down..." - "Also do ctrl-left and ctrl-right for horizontal scroll." - ^ MouseScrollEvent new - setType: #mouseScroll - position: self morphPosition - direction: - (keyValue caseOf: { - "Implementing as a caseof to allow for easy adding of left/right/other events should they become available" - [ 30 ] -> [ #up ]. - [ 31 ] -> [ #down ]. - [ 28 ] -> [ #left ]. - [ 29 ] -> [ #right ]. - }) - buttons: buttons - hand: self - stamp: stamp ] - ifFalse: [ ^ KeyboardEvent new - setType: type - buttons: buttons - position: self morphPosition - keyValue: keyValue - hand: self - stamp: stamp ].! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3208-MouseScrollOnMacFix-JuanVuletich-2017Nov10-11h07m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3207] on 10 November 2017 at 11:19:54 am'! - -SystemWindow subclass: #WorkspaceWindow - instanceVariableNames: 'acceptDroppedMorphs ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Tools'! - -!classDefinition: #WorkspaceWindow category: #'Morphic-Tools'! -SystemWindow subclass: #WorkspaceWindow - instanceVariableNames: 'acceptDroppedMorphs' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Tools'! -!Morph methodsFor: 'accessing - properties' stamp: 'jmv 11/10/2017 11:14:34'! -objectForWorkspace - ^self! ! -!InspectorWindow methodsFor: 'accessing' stamp: 'jmv 11/10/2017 11:15:23'! - objectForWorkspace - ^model object! ! -!ObjectExplorerWindow methodsFor: 'accessing' stamp: 'jmv 11/10/2017 11:19:10'! - objectForWorkspace - ^model rootObject! ! -!Morph methodsFor: 'accessing - properties' stamp: 'jmv 11/10/2017 11:16:44' prior: 16874017! - nameForWorkspace - "Answer a name suitable for a Workspace variable" - | displayName object | - object _ self objectForWorkspace. - displayName := object name. - ^ displayName - ifNotNil: [ | name | - name := displayName asIdentifier: false. - (name size < 1) - ifTrue: [ object class name asLowercase , object identityHash asString ] - ifFalse: [ name at: 1 put: (name at: 1) asLowercase. name ] - ] - ifNil: [ object class name asLowercase , object identityHash asString ]! ! -!WorkspaceWindow methodsFor: 'menu' stamp: 'jmv 11/10/2017 11:10:18' prior: 16945502! - addCustomMenuItems: aCustomMenu hand: aHandMorph - super addCustomMenuItems: aCustomMenu hand: aHandMorph. - aCustomMenu addLine. - aCustomMenu - add: 'reset variables' - target: model - action: #initializeBindings. - aCustomMenu - addUpdating: #mustDeclareVariableWording - target: model - action: #toggleVariableDeclarationMode. - aCustomMenu - addUpdating: #toggleStylingLabel - target: model - action: #toggleStyling! ! -!WorkspaceWindow methodsFor: 'menu' stamp: 'jmv 11/10/2017 11:10:38' prior: 16945530! - offerWindowMenu - | aMenu | - aMenu _ self buildWindowMenu. - aMenu addLine. - aMenu - add: 'reset variables' - target: model - action: #initializeBindings. - aMenu - addUpdating: #mustDeclareVariableWording - target: model - action: #toggleVariableDeclarationMode. - aMenu - addUpdating: #toggleStylingLabel - target: model - action: #toggleStyling. - aMenu popUpInWorld: self world! ! -!WorkspaceWindow methodsFor: 'drag n drop' stamp: 'jmv 11/10/2017 11:09:41' prior: 16945548! - allowsMorphDrop - "Answer whether we accept dropping morphs. By default answer false." - - ^ true! ! -!WorkspaceWindow methodsFor: 'drag n drop' stamp: 'jmv 11/10/2017 11:17:29' prior: 16945554! - wantsDroppedMorph: aMorph event: evt - "Dropping a morph on my window means: - display exteral name for aMorph in Workspace - add a binding from name to aMorph - and rejecting the drop." - - | objectName textModelMorph object | - objectName := aMorph nameForWorkspace. - object _ aMorph objectForWorkspace. - textModelMorph := self layoutMorph submorphs at: 1. - - (self model bindingOf: objectName) value: object. - textModelMorph editor afterSelectionInsertAndSelect: objectName , ' '. - "send aMorph back to original position" - evt isNil ifFalse: [ evt wasHandled: true ]. - "Short circuit" - aMorph rejectDropMorphEvent: evt. - - ^ false ! ! - -WorkspaceWindow removeSelector: #allowsMorphDropWording! - -WorkspaceWindow removeSelector: #allowsMorphDropWording! - -WorkspaceWindow removeSelector: #initialize! - -WorkspaceWindow removeSelector: #initialize! - -WorkspaceWindow removeSelector: #toggleAcceptDroppedMorphs! - -WorkspaceWindow removeSelector: #toggleAcceptDroppedMorphs! - -SystemWindow subclass: #WorkspaceWindow - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Tools'! - -!classDefinition: #WorkspaceWindow category: #'Morphic-Tools'! -SystemWindow subclass: #WorkspaceWindow - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Tools'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3209-InspectorExplorerDnDOnWorkspace-JuanVuletich-2017Nov10-11h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3209] on 12 November 2017 at 9:07:35 pm'! -!Morph methodsFor: 'accessing - properties' stamp: 'jmv 11/12/2017 20:56:19'! - objectsForWorkspace - ^{self}! ! -!InspectorWindow methodsFor: 'accessing' stamp: 'jmv 11/12/2017 21:00:55'! - objectsForWorkspace - ^{self. model object. model selection}! ! -!ObjectExplorerWindow methodsFor: 'accessing' stamp: 'jmv 11/12/2017 21:00:29'! - objectsForWorkspace - ^{self. model rootObject. model object}! ! -!WorkspaceWindow methodsFor: 'drag n drop' stamp: 'jmv 11/12/2017 20:57:38'! - nameForObject: object - "Answer a name suitable for a Workspace variable" - object name ifNotNil: [ :displayName | - ^displayName asIdentifier: false ]. - ^ object class name asLowercase , object identityHash asString! ! -!WorkspaceWindow methodsFor: 'drag n drop' stamp: 'jmv 11/12/2017 20:44:49' prior: 50375102! - allowsMorphDrop - "Answer whether we accept dropping morphs. Workspaces always accept drops. - Regular morphs are inserted in the text. - Inspectors and Explorers generate workspace variables referencing the inspected object(s.)" - - ^ true! ! -!WorkspaceWindow methodsFor: 'drag n drop' stamp: 'jmv 11/12/2017 21:05:37' prior: 50375108! - wantsDroppedMorph: aMorph event: evt - "Dropping a morph on my window means: - display exteral name for aMorph in Workspace - add a binding from name to aMorph - and rejecting the drop." - - | textModelMorph | - textModelMorph := self layoutMorph submorphs at: 1. - aMorph objectsForWorkspace do: [ :object | | objectName | - objectName _ self nameForObject: object. - (self model bindingOf: objectName) value: object. - textModelMorph editor afterSelectionInsertAndSelect: String newLineString, objectName , '. ' ]. - "send aMorph back to original position" - evt isNil ifFalse: [ evt wasHandled: true ]. - "Short circuit" - aMorph rejectDropMorphEvent: evt. - - ^ false ! ! - -ObjectExplorerWindow removeSelector: #objectForWorkspace! - -ObjectExplorerWindow removeSelector: #objectForWorkspace! - -InspectorWindow removeSelector: #objectForWorkspace! - -InspectorWindow removeSelector: #objectForWorkspace! - -Morph removeSelector: #nameForWorkspace! - -Morph removeSelector: #nameForWorkspace! - -Morph removeSelector: #objectForWorkspace! - -Morph removeSelector: #objectForWorkspace! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3210-DnDOnWorkspaceEnhancements-JuanVuletich-2017Nov12-20h44m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3210] on 12 November 2017 at 10:28:26 pm'! -!BlockClosure methodsFor: 'lambda calculus' stamp: 'jmv 11/12/2017 22:27:40'! - curried - " - https://en.wikipedia.org/wiki/Currying - [ :a :b | a + b ] value: 1 value: 2 - [ :a :b | a + b ] curried value: 1 :: value: 2 - " - ^self argumentCount caseOf: { - [ 1] -> [[ :arg1 | [ self value: arg1 ]]]. - [ 2] -> [[ :arg1 | [ :arg2 | self value: arg1 value: arg2 ]]]. - [ 3] -> [[ :arg1 | [ :arg2 :arg3 | self value: arg1 value: arg2 value: arg3 ]]]. - [ 4] -> [[ :arg1 | [ :arg2 :arg3 :arg4 | self value: arg1 value: arg2 value: arg3 value: arg4 ]]] } - otherwise: [ self halt ]! ! -!BlockClosure methodsFor: 'lambda calculus' stamp: 'jmv 11/12/2017 22:27:57'! - withFirstArg: arg1 - " - https://en.wikipedia.org/wiki/Partial_application - - [ :a :b | a + b ] value: 1 value: 2 - [ :a :b | a + b ] withFirstArg: 1 - ([ :a :b | a + b ] withFirstArg: 1) value: 2 - ([ :a :b | a + b ] withFirstArg: 1) withFirstArg: 2 - (([ :a :b | a + b ] withFirstArg: 1) withFirstArg: 2) value - - ([ :a :b | a - b ] withFirstArg: 1) value: 2 - " - ^self argumentCount caseOf: { - [ 1] -> [[ self value: arg1 ]]. - [ 2] -> [[ :arg2 | self value: arg1 value: arg2 ]]. - [ 3] -> [[ :arg2 :arg3 | self value: arg1 value: arg2 value: arg3 ]]. - [ 4] -> [[ :arg2 :arg3 :arg4 | self value: arg1 value: arg2 value: arg3 value: arg4 ]] } - otherwise: [ self halt ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3211-lambdaCalculusToys-JuanVuletich-2017Nov12-22h27m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3211] on 14 November 2017 at 2:06:38 pm'! -!DisplayScreen methodsFor: 'other' stamp: 'jmv 11/14/2017 14:04:10' prior: 16835265! - restoreAfter: aBlock - " - - Evaluate the block - - Update host OS Display - - Wait for a mouse click - - And then restore the Morphic World" - - aBlock value. - self forceToScreen. - Sensor waitButton. - self runningWorld ifNotNil: [ :w | w fullRepaintNeeded ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3212-restoreAfter-fix-JuanVuletich-2017Nov14-14h04m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3212] on 19 November 2017 at 11:38:44 am'! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'jmv 11/19/2017 11:33:31' prior: 50363266! - initialExtent - - ^`540@400` * Preferences standardCodeFont height // 14! ! -!ChangeSorterWindow methodsFor: 'GUI building' stamp: 'jmv 11/19/2017 11:34:12' prior: 50363270! - initialExtent - ^`540@300` * Preferences standardCodeFont height // 14! ! -!PreDebugWindow methodsFor: 'GUI building' stamp: 'jmv 11/19/2017 11:36:45' prior: 50363274! - initialExtent - ^ `640 @ 320` * Preferences standardCodeFont height // 14! ! -!InspectorWindow methodsFor: 'GUI building' stamp: 'jmv 11/19/2017 11:36:58' prior: 50363278! - initialExtent - - ^`600@325` * Preferences standardCodeFont height // 14! ! -!ObjectExplorerWindow methodsFor: 'GUI building' stamp: 'jmv 11/19/2017 11:37:06' prior: 50363282! - initialExtent - - ^`300@500` * Preferences standardCodeFont height // 14! ! -!LayoutMorph methodsFor: 'adjust' stamp: 'jmv 11/19/2017 11:25:32' prior: 16863061! - adjustHorizontallyBy: aLayoutAdjustMorph at: aPoint - | delta l ls r rs lNewWidth rNewWidth i lCurrentWidth rCurrentWidth | - i _ submorphs indexOf: aLayoutAdjustMorph. - l _ self submorphs at: i +1. - ls _ l layoutSpec. - lCurrentWidth _ l morphWidth max: 1. "avoid division by zero" - r _ self submorphs at: i - 1. - rs _ r layoutSpec. - rCurrentWidth _ r morphWidth max: 1. "avoid division by zero" - delta _ aPoint x - aLayoutAdjustMorph referencePosition x. - delta _ delta max: l minPaneWidthForReframe - lCurrentWidth. - delta _ delta min: rCurrentWidth - r minPaneWidthForReframe. - delta = 0 ifTrue: [ ^self ]. - rNewWidth _ rCurrentWidth - delta. - lNewWidth _ lCurrentWidth + delta. - (ls isProportionalWidth and: [ rs isProportionalWidth ]) - ifTrue: [ "If both proportional, update them" - ls setProportionalWidth: (1.0 * lNewWidth / lCurrentWidth * ls proportionalWidth). - rs setProportionalWidth: (1.0 * rNewWidth / rCurrentWidth * rs proportionalWidth) ] - ifFalse: ["If at least one is fixed, update only the fixed" - ls isProportionalWidth ifFalse: [ - ls fixedOrMorphWidth: lNewWidth ]. - rs isProportionalWidth ifFalse: [ - rs fixedOrMorphWidth: rNewWidth ]]. - self layoutSubmorphs.! ! -!LayoutMorph methodsFor: 'private' stamp: 'jmv 11/19/2017 11:27:34' prior: 16863565! - minPaneWidthForReframe - - ^(self submorphs collect: [ :m | m minimumExtent x ]) max! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3213-FixColumnarResize-JuanVuletich-2017Nov19-11h10m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3213] on 19 November 2017 at 11:43:25 am'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 11/19/2017 11:43:05' prior: 50335860! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3214-AddJavierAsKnownAuthor-JuanVuletich-2017Nov19-11h43m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3207] on 18 November 2017 at 2:30:36 pm'! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'JO 11/18/2017 14:28:55' prior: 50368273! - buildMorphicWindow - " - CodePackageListWindow open: CodePackageList new - " - | dirtyFlags names fileNames upperRow description summary backColor labelBackground | - backColor := self textBackgroundColor. - labelBackground := Theme current background. - - dirtyFlags := PluggableListMorph - model: model - listGetter: #packageDirtyFlags - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - dirtyFlags color: backColor. - dirtyFlags := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: ' Unsaved?'); - addMorphUseAll: dirtyFlags. - - names := PluggableListMorph - model: model - listGetter: #packageNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - names color: backColor. - names := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: ' Package Name'); - addMorphUseAll: names. - - fileNames := PluggableListMorph - model: model - listGetter: #packageFullNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - fileNames color: backColor. - fileNames := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: ' File Name'); - addMorphUseAll: fileNames. - - upperRow := LayoutMorph newRow. - upperRow - addMorph: dirtyFlags proportionalWidth: 0.13; - addAdjusterAndMorph: names proportionalWidth: 0.27; - addAdjusterAndMorph: fileNames proportionalWidth: 0.6. - - description := TextModelMorph - textProvider: model - textGetter: #description - textSetter: #description:. - - summary := TextModelMorph - textProvider: model - textGetter: #summary. - - self layoutMorph - addMorph: upperRow proportionalHeight: 0.6; - addAdjusterAndMorph: self buildButtonPane fixedHeight: Theme current buttonPaneHeight; - addAdjusterAndMorph: summary fixedHeight: 60; - addAdjusterAndMorph: description proportionalHeight: 0.25; - addAdjusterAndMorph: self buildRequirementsPane proportionalHeight: 0.15. - self setLabel: 'Installed Packages'! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3215-CodePackageListWindow-cleanup-JavierOlaechea-2017Nov18-14h22m-JO.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3208] on 19 November 2017 at 12:34:29 am'! -!ChangeSorterWindow class methodsFor: 'instance creation' stamp: 'JO 11/18/2017 23:13:44' prior: 16800331! - openChangeSorter - self - open: ChangeSorter new - label: nil.! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'JO 11/18/2017 22:23:10' prior: 16934823! - changesMenu - "Build the changes menu for the world." - - | menu | - menu _ self menu: 'Changes...'. - self fillIn: menu from: { - { 'Change Sorter' . {ChangeSorterWindow. #openChangeSorter}. 'Open a 3-paned changed-set viewing tool'}. - nil. - - { 'Install New Updates' . { ChangeSet. #installNewUpdates }. -'Install in the current image the new updates available -in directory named ./CoreUpdates -or in directory named ../Cuis-Smalltalk-Dev/CoreUpdates'}. - nil. - - { 'Browse my Changes' . { Smalltalk . #browseMyChanges }. - 'Browse all of my changes since the last time #condenseSources was run.'}. - { 'Recently logged Changes...' . { ChangeList . #browseRecentLog}.'Open a change-list browser on the latter part of the changes log. You can use this browser to recover logged changes which were not saved in your image, in the event of a crash or other interruption.'}. - - nil. - { 'Save World as morph file' . {self. #saveWorldInFile}. 'Save a file that, when reloaded, reconstitutes the current World.'}. - }. - ^ menu! ! - -TheWorldMenu removeSelector: #openChangeSorter1! - -TheWorldMenu removeSelector: #openChangeSorter1! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3216-WorldMenu-cleanup-JavierOlaechea-2017Nov18-22h23m-JO.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3212] on 21 November 2017 at 3:19:55 am'! - -Object immediateSubclass: #Character - instanceVariableNames: 'value ' - classVariableNames: 'CharacterTable ClassificationTable LetterBits LowercaseBit UnaccentedTable UnicodeCodePoints UppercaseBit LetterTruthTable UppercaseTruthTable LowercaseTruthTable LowercaseMappingTable UppercaseMappingTable ' - poolDictionaries: '' - category: 'Kernel-Text'! -!Character class methodsFor: 'class initialization' stamp: 'pb 11/21/2017 02:38:24'! - initializeLookupTables - LowercaseMappingTable _ Array new: 256. - LowercaseTruthTable _ Array new: 256. - UppercaseMappingTable _ Array new: 256. - UppercaseTruthTable _ Array new: 256. - LetterTruthTable _ Array new: 256. - UnaccentedTable _ ByteArray new: 256. - 0 - to: 255 - do: [ :idx | | char | - "Default to an identity mapping with a false truth mapping" - char _ self numericValue: idx. - LowercaseMappingTable - at: idx + 1 - put: char. - LowercaseTruthTable - at: idx + 1 - put: false. - UppercaseMappingTable - at: idx + 1 - put: char. - UppercaseTruthTable - at: idx + 1 - put: false. - LetterTruthTable - at: idx + 1 - put: false. - UnaccentedTable at: idx + 1 put: idx]. - "Now override as needed" - Character uppercaseLowercaseAndUnaccentedLetters do: [ :group | | uppercase lowercase | - group size > 1 - ifTrue: [ | lowercaseChar uppercaseChar | - uppercase _ group first numericValue. - lowercase _ group second numericValue. - lowercaseChar _ self numericValue: lowercase. - uppercaseChar _ self numericValue: uppercase. - LowercaseMappingTable - at: lowercase + 1 - put: lowercaseChar. - LowercaseMappingTable - at: uppercase + 1 - put: lowercaseChar. - LowercaseTruthTable - at: lowercase + 1 - put: true. - LetterTruthTable - at: lowercase + 1 - put: true. - UppercaseMappingTable - at: lowercase + 1 - put: uppercaseChar. - UppercaseMappingTable - at: uppercase + 1 - put: uppercaseChar. - UppercaseTruthTable - at: uppercase + 1 - put: true. - LetterTruthTable - at: uppercase + 1 - put: true. - group size > 2 - ifTrue: [|unaccentedUppercase unaccentedLowercase| - unaccentedUppercase _ group third numericValue. - unaccentedLowercase _ group fourth numericValue. - UnaccentedTable at: uppercase+1 put: unaccentedUppercase. - UnaccentedTable at: lowercase+1 put: unaccentedLowercase]] - ifFalse: [ | lowercaseChar | - lowercase _ group first numericValue. - lowercaseChar _ self numericValue: lowercase. - LowercaseMappingTable - at: lowercase + 1 - put: lowercaseChar. - UppercaseMappingTable - at: lowercase + 1 - put: lowercaseChar. - LowercaseTruthTable - at: lowercase + 1 - put: true. - UppercaseTruthTable - at: lowercase + 1 - put: false. - LetterTruthTable - at: lowercase + 1 - put: true ]].! ! -!Character class methodsFor: 'class initialization' stamp: 'pb 11/21/2017 02:24:51' prior: 16800735! - initClassCachedState - "Create the table of unique Characters. - Character initialize - " - self initializeClassificationTable. - self initializeLookupTables . - self initializeUnicodeCodePoints.! ! -!Character class methodsFor: 'fileIn/Out' stamp: 'pb 11/21/2017 02:26:23' prior: 16801502! - definition - "Special class definition for Character, SmallInteger and SmallFloat64 - Required to have the same definition both for preSpur and Spur, and to be compatible with both." - ^ -'Object immediateSubclass: #Character - instanceVariableNames: ''value'' - classVariableNames: ''CharacterTable ClassificationTable LetterBits LowercaseBit UnaccentedTable UnicodeCodePoints UppercaseBit LowercaseMappingTable LowercaseTruthTable UppercaseMappingTable UppercaseTruthTable LetterTruthTable'' - poolDictionaries: '''' - category: ''Kernel-Text'''! ! - -Object immediateSubclass: #Character - instanceVariableNames: 'value' - classVariableNames: 'CharacterTable ClassificationTable LetterBits LowercaseBit UnaccentedTable UnicodeCodePoints UppercaseBit LowercaseMappingTable LowercaseTruthTable UppercaseMappingTable UppercaseTruthTable LetterTruthTable' - poolDictionaries: '' - category: 'Kernel-Text'! - -Character initialize! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3217-Character-lookup-tables-stage1-PhilBellalouna-2017Nov21-00h32m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3212] on 21 November 2017 at 3:19:55 am'! -!Character methodsFor: 'testing' stamp: 'pb 11/21/2017 02:29:43' prior: 16800489! - isLetter - "Answer whether the receiver is a letter." - ^ LetterTruthTable at: self numericValue + 1! ! -!Character methodsFor: 'testing' stamp: 'pb 11/21/2017 02:24:10' prior: 16800504! - isLowercase - "Answer whether the receiver is a lowercase letter." - ^ LowercaseTruthTable at: self numericValue + 1.! ! -!Character methodsFor: 'testing' stamp: 'pb 11/21/2017 02:24:25' prior: 16800531! - isUppercase - "Answer whether the receiver is an uppercase letter." - ^ UppercaseTruthTable at: self numericValue + 1.! ! -!Character methodsFor: 'converting' stamp: 'pb 11/21/2017 02:22:41' prior: 16800596! - asLowercase - ^ LowercaseMappingTable at: self numericValue + 1.! ! -!Character methodsFor: 'converting' stamp: 'pb 11/21/2017 02:23:38' prior: 16800628! - asUppercase - "If the receiver is lowercase, answer its matching uppercase Character." - ^ UppercaseMappingTable at: self numericValue + 1.! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3218-Character-lookup-tables-stage2-PhilBellalouna-2017Nov21-00h32m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3214] on 21 November 2017 at 3:34:57 am'! -!Character class methodsFor: 'class initialization' stamp: 'pb 11/21/2017 03:33:45' prior: 50375811! - initClassCachedState - "Create the table of unique Characters. - Character initialize - " - self initializeLookupTables . - self initializeUnicodeCodePoints.! ! - -Character class removeSelector: #initializeClassificationTable! - -Character class removeSelector: #initializeClassificationTable! -!Character class methodsFor: 'fileIn/Out' stamp: 'pb 11/21/2017 03:34:29' prior: 50375820! - definition - "Special class definition for Character, SmallInteger and SmallFloat64 - Required to have the same definition both for preSpur and Spur, and to be compatible with both." - ^ -'Object immediateSubclass: #Character - instanceVariableNames: ''value'' - classVariableNames: ''CharacterTable UnaccentedTable UnicodeCodePoints LowercaseMappingTable LowercaseTruthTable UppercaseMappingTable UppercaseTruthTable LetterTruthTable'' - poolDictionaries: '''' - category: ''Kernel-Text'''! ! - -Object immediateSubclass: #Character - instanceVariableNames: 'value' - classVariableNames: 'CharacterTable UnaccentedTable UnicodeCodePoints LowercaseMappingTable LowercaseTruthTable UppercaseMappingTable UppercaseTruthTable LetterTruthTable' - poolDictionaries: '' - category: 'Kernel-Text'! - -Character initialize! - -Smalltalk recreateSpecialObjectsArray! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3219-Character-lookup-tables-stage3-PhilBellalouna-2017Nov21-03h32m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3207] on 19 November 2017 at 12:42:52 pm'! -!Float commentStamp: 'jmv 11/19/2017 12:42:42' prior: 50372891! - A note About Floating Point numbers and Floating Point Arithmetic. - -The following is not specific to Cuis or Smalltalk at all. This is about the properties of Float numbers in any computer implementation. - -If you haven't done so already, read https://en.wikipedia.org/wiki/Floating-point_arithmetic - -But if you find the Wikipedia article too detailed, or hard to read, then try http://fabiensanglard.net/floating_point_visually_explained/ (get past "How Floating Point are usually explained" and read "A different way to explain..."). - -Other great reads are: - "Why don't my numbers add up?": - http://floating-point-gui.de/ -and - "What Every Computer Scientist Should Know About Floating-Point Arithmetic": - http://docs.oracle.com/cd/E19957-01/806-3568/ncg_goldberg.html -and also maybe - "Comparing floating point numbers" - https://randomascii.wordpress.com/2012/02/25/comparing-floating-point-numbers-2012-edition/ - -Now that you read them, and we are on the same boat, some further comments (from jmv): - -Floats are (conceptually) approximate real numbers. That's why trig and other trascendental functions always answer Floats. That's why it is ok to round the result of operations. That's why Float is considered more general than Fraction in ST-80 and most Smalltalks. So, when we have a Float value, we must not think about it as a Rational but as a Real (actually as some unknown Real that could hopefully be close to the Rational we can actually represent). Keep this in mind when dealing with Floats, and especially avoid comparing them for equality. - -When doing mixed operations with Floats and Fractions, Cuis, as most other Smalltalks, converts all values to Floats. Some other systems, including Pharo Smalltalk, Scheme and Lisp have two rules: when the answer is a Number, they convert to Float. But when the answer is a boolean (#<, #=, #<=, etc.) they convert to Fraction. We think this is a mistake. There should never be implicit conversions from Float to Fraction. Fractions are to hold exact values, and people expect Fractions to be exact. On the other hand, Floats are to hold approximations (and people should be aware of that!!). But an implicit conversion from Float to Fraction would give a Fraction that should not be considered an exact value (the value comes from an inexact Float), but that knowledge is lost, as it is an instance of Fraction. - -If you want exact arithmetic, usual mathematical properties (like transitivity of equality), can live in the limited world of Rational numbers, and can afford a slight performance penalty, use Fraction instead. Avoid trascendental functions and never convert to Float. - -In any case, most numeric computation is done on Float numbers. There are good reasons for that. One is that in most cases we don't need an exact answer. And in many cases we can't really have it: the inputs to algorithms already have a limited precision, or they use trascendental functions. And even when exact arithmetic possible, if we are doing sound synthesis, 24 bits of resolution is enough. For image processing and graphics, the result is never more than 16 bits per channel. So, these fields don't really need 64 bit Doubles. 32 bit Floats are enough. Other fields do need 64 bit Doubles, like physics simulations and geometry. Games usually prefer special, faster 32 bit Float operations in GPUs that have greater errors but are faster. - -There are some things that can be done to increase the confidence you can have on Float results. One is to do an error propagation analysis on the code you are running. This is not easy, but it is done for any widely used numerical method. Then, you can know real bounds and/or estimates of the errors made. So, understanding your inputs and your algorithms (for example error propagation, condition number, numeric stability), and using Float number if appropriate, is the usual advice. - -Perhaps you have heard about "interval arithmetic". It is a bit better than simple Float, but doesn't really fix the problems. - -The ultimate solution is to do Monte Carlo analysis, with random perturbation of inputs. After the Monte Carlo run, it is needed to do statistical analysis of possible correlations between the distributions of the random noise added to imputs and the result of the algorithm. - -Additional food for thought: http://www.cs.berkeley.edu/~wkahan/Mindless.pdf . According to this, doing Monte Carlo as described above attacks a slightly different problem. This might be yet another reason (besides performance) to try something like the next paragraph. I (jmv) came up with it, and I don't really know if it has been described and or tried before or not. Mhhh. Maybe a defensive publication is in order. - -A possibility that could be a practical solution, being much cheaper than Monte Carlo, but better than interval arithmetic, is to represent each value by 2 Floats: an estimation of the real value (i.e. an estimation of the mean value of the distribution of the corresponding Monte Carlo result), and an estimation of the error (i.e. an estimation of the standard deviation of the corresponding Monte Carlo result). Or perhaps even 3 of them. In addition to the estimation of the real value and an estimation of the error, we could add a hard bound on the error. In many cases it will be useless, because the error can not really be bound. But in those cases where it is possible to bound it, applications could really know about the quality of computed values. - -======================================================================= - -My instances represent IEEE-754 floating-point double-precision numbers. They have about 16 decimal digits of accuracy and their range is between plus and minus 10^307. Some valid examples are: - - 8.0 13.3 0.3 2.5e6 1.27e-30 1.27e-31 -12.987654e12 - -Mainly: no embedded blanks, little e for tens power, and a digit on both sides of the decimal point. It is actually possible to specify a radix for Squeak Float constants. This is great for teaching about numbers, but may be confusing to the average reader: - - 3r20.2 --> 6.66666666666667 - 8r20.2 --> 16.25 - -If you don't have access to the definition of IEEE-754, you can figure out what is going on by printing various simple values in Float hex. It may help you to know that the basic format is... - sign 1 bit - exponent 11 bits with bias of 1023 (16r3FF) to produce an exponent - in the range -1023 .. +1024 - - 16r000: - significand = 0: Float zero - significand ~= 0: Denormalized number (exp = -1024, no hidden '1' bit) - - 16r7FF: - significand = 0: Infinity - significand ~= 0: Not A Number (NaN) representation - mantissa 53 bits, but only 52 are stored (20 in the first word, 32 in the second). This is because a normalized mantissa, by definition, has a 1 to the right of its floating point, and IEEE-754 omits this redundant bit to gain an extra bit of precision instead. People talk about the mantissa without its leading one as the FRACTION, and with its leading 1 as the SIGNFICAND. - -The single-precision format is... - sign 1 bit - exponent 8 bits, with bias of 127, to represent -126 to +127 - - 0x0 and 0xFF reserved for Float zero (mantissa is ignored) - - 16r7F reserved for Float underflow/overflow (mantissa is ignored) - mantissa 24 bits, but only 23 are stored -This format is used in FloatArray (qv), and much can be learned from the conversion routines, Float asIEEE32BitWord, and Float class fromIEEE32Bit:. - -You might also check https://en.wikipedia.org/wiki/IEEE_754_revision - -Other great reads (covering broader but interesting issues): -https://randomascii.wordpress.com/2013/07/16/floating-point-determinism/ -http://www.ima.umn.edu/2010-2011/W1.10-14.11/activities/Leeser-Miriam/Leeser-GPU-IMA-Jan2011.pdf! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3220-FloatCommentTweaks-JuanVuletich-2017Nov19-12h24m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3220] on 24 November 2017 at 12:18:25 pm'! -!SystemWindow methodsFor: 'accessing' stamp: 'jmv 11/24/2017 12:06:15'! - objectsForWorkspace - ^{}! ! -!InspectorWindow methodsFor: 'accessing' stamp: 'jmv 11/24/2017 12:16:02' prior: 50375164! - objectsForWorkspace - | root sel | - root _ model object. - sel _ model selection. - (root == sel or: [ model contentsIsString ]) ifTrue: [ - ^{root} ]. - ^{root. sel }! ! -!ObjectExplorerWindow methodsFor: 'accessing' stamp: 'jmv 11/24/2017 12:17:16' prior: 50375169! - objectsForWorkspace - | root sel | - root _ model rootObject. - sel _ model object. - (root == sel or: [ sel isNil ]) ifTrue: [ - ^{root} ]. - ^{root. sel }! ! -!WorkspaceWindow methodsFor: 'drag n drop' stamp: 'jmv 11/24/2017 12:08:35' prior: 50375195! - wantsDroppedMorph: aMorph event: evt - "Dropping a morph on my window means: - display exteral name for aMorph in Workspace - add a binding from name to aMorph - and rejecting the drop." - - | textModelMorph addedBindings | - textModelMorph := self layoutMorph submorphs at: 1. - addedBindings _ false. - aMorph objectsForWorkspace do: [ :object | | objectName | - addedBindings _ true. - objectName _ self nameForObject: object. - (self model bindingOf: objectName) value: object. - textModelMorph editor afterSelectionInsertAndSelect: String newLineString, objectName , '. ' ]. - addedBindings ifTrue: [ - "send aMorph back to original position" - evt isNil ifFalse: [ evt wasHandled: true ]. - "Short circuit" - aMorph rejectDropMorphEvent: evt ]. - - ^ false ! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3221-DropOnWorkspaceEnh-JuanVuletich-2017Nov24-12h06m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3221] on 26 November 2017 at 5:12:13 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 11/26/2017 17:11:34'! - minPaneWidthForReframe - ^ self minimumExtent x! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3222-FixDNUOnColumnResize-JuanVuletich-2017Nov26-17h10m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3222] on 28 November 2017 at 3:11:44 pm'! -!Object methodsFor: 'inspecting' stamp: 'jmv 11/28/2017 15:08:54'! - copyToClipboard - "Create and schedule an Inspector in which the user can examine the receiver's variables." - - Clipboard storeObject: self! ! -!TextModel methodsFor: 'testing' stamp: 'jmv 11/28/2017 14:52:16'! - canBindVariables - ^ false! ! -!Workspace methodsFor: 'variable declarations' stamp: 'jmv 11/28/2017 14:56:27'! - nameForObject: object - "Answer a name suitable for a Workspace variable" - object name ifNotNil: [ :displayName | - ^displayName asIdentifier: false ]. - ^ object class name asLowercase , object identityHash asString! ! -!Workspace methodsFor: 'testing' stamp: 'jmv 11/28/2017 14:52:28'! - canBindVariables - ^ true! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'jmv 11/28/2017 14:57:38'! - paste - | object objectName | - model canBindVariables ifTrue: [ - object _ Clipboard retrieveObject. - objectName _ model nameForObject: object. - (model bindingOf: objectName) value: object. - self replaceSelectionWith: objectName. - ^ self ]. - ^ super paste! ! -!InspectorWindow methodsFor: 'menu commands' stamp: 'jmv 11/28/2017 14:47:12'! - copySelectionToClipboard - "For example, for pasting a reference in a Workspace" - - Clipboard storeObject: model selection! ! -!ObjectExplorerWindow methodsFor: 'menu commands' stamp: 'jmv 11/28/2017 14:47:30'! - copySelectionToClipboard - "For example, for pasting a reference in a Workspace" - - Clipboard storeObject: model object! ! -!Editor methodsFor: 'menu messages' stamp: 'jmv 12/19/2011 12:24' prior: 16836376! - paste - "Paste the text from the shared buffer over the current selection and - redisplay if necessary." - - self replaceSelectionWith: self clipboardStringOrText! ! -!Morph methodsFor: 'debug and other' stamp: 'jmv 11/28/2017 15:07:24' prior: 16874207! - buildDebugMenu: aHand - "Answer a debugging menu for the receiver. The hand argument is seemingly historical and plays no role presently" - - | aMenu | - aMenu := MenuMorph new defaultTarget: self. - aMenu addStayUpIcons. - self isKnownFailing - ifTrue: [ - aMenu add: 'start drawing again' action: #resumeAfterDrawError. - aMenu addLine]. - (self hasProperty: #errorOnStep) - ifTrue: [ - aMenu add: 'start stepping again' action: #resumeAfterStepError. - aMenu addLine]. - aMenu add: 'inspect morph' action: #inspect. - aMenu add: 'inspect owner chain' action: #inspectOwnerChain. - self hasModel - ifTrue: [ - aMenu - add: 'inspect model' - target: self model - action: #inspect]. - aMenu - add: 'explore morph' - target: self - selector: #explore. - aMenu - add: 'copy to clipboard (c)' - target: self - selector: #copyToClipboard. - aMenu addLine. - aMenu - add: 'browse morph class' - target: self - selector: #browseClassHierarchy. - self hasModel - ifTrue: [ - aMenu - add: 'browse model class' - target: self model - selector: #browseClassHierarchy]. - aMenu addLine. - aMenu - add: 'edit balloon help' action: #editBalloonHelpText. - ^aMenu! ! -!InspectorWindow methodsFor: 'menu building' stamp: 'jmv 11/28/2017 14:44:33' prior: 16857251! - fieldListMenu - "Arm the supplied menu with items for the field-list of the receiver" - - | aMenu object | - aMenu _ MenuMorph new defaultTarget: self. - - aMenu addList: #( - ('inspect (i)' inspectSelection) - ('explore (I)' exploreSelection) - ('copy to clipboard (c)' copySelectionToClipboard) - ('basic inspect' inspectBasic) - ('references finder' openReferencesFinder) - ('weight explorer' openWeightExplorer)). - - object _ model object. - (object is: #Dictionary) ifTrue: [ aMenu addList: #( - - - ('senders of this key' sendersOfSelectedKey) - ('add key' addEntry) - ('rename key' renameEntry) - ('remove' removeSelection '' model)) ] - - ifFalse: [ (object is: #Set) ifTrue: [ aMenu addList: #( - - - ('remove' removeSelection '' model))]]. - - aMenu addList: #( - - - ('browse full (b)' browseMethodFull) - ('browse hierarchy (h)' browseHierarchy) - ('browse protocol (p)' browseFullProtocol)). - ^ aMenu! ! -!ObjectExplorerWindow methodsFor: 'building menus' stamp: 'jmv 11/28/2017 14:45:17' prior: 16883322! - genericMenu - "Borrow a menu from my inspector" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - model getCurrentSelection - ifNil: [ - aMenu - add: '*nothing selected*' - target: self - selector: #yourself] - ifNotNil: [ - aMenu addList: #( - ('inspect (i)' inspectSelection) - ('explore (I)' exploreSelection) - ('copy to clipboard (c)' copySelectionToClipboard) - ('basic inspect' inspectBasic) - ('references finder' openReferencesFinder) - ('weight explorer' openWeightExplorer) - - - ('browse full (b)' browseMethodFull) - ('browse hierarchy (h)' browseHierarchy) - ('browse protocol (p)' browseFullProtocol)). - aMenu addLine; - add: 'monitor changes' - target: self - selector: #monitor: - argument: model getCurrentSelection. - model class == ReferencesExplorer ifTrue: [ - aMenu addLine; - add: 'rescan' - target: self - selector: #rescan ]]. - model basicMonitorList isEmptyOrNil - ifFalse: [ - aMenu addLine; - add: 'stop monitoring all' - target: self - selector: #stopMonitoring ]. - ^ aMenu! ! -!Theme methodsFor: 'menus' stamp: 'jmv 11/28/2017 14:43:40' prior: 50344063! - basicIcons - - "Minimal menu scheme. - Theme current class beCurrent - " - - ^ { - #('open...') -> #openIcon. - #('windows...' 'find window' 'Focus follows mouse' 'Click to focus') -> #windowIcon. - #('help...' 'explain' 'about this system...' 'Terse Guide to Cuis' 'Class Comment Browser' 'Code management in Cuis' 'Using GitHub to host Cuis packages' ) -> #helpIcon. - #('themes...') -> #appearanceIcon. - #('do it (d)') -> #doItIcon. - #('new morph...' 'objects (o)' 'save world as morph file') -> #morphsIcon. - #('save' ) -> #saveIcon. - #('Save options...' 'save as...' 'change category...' 'rename change set (r)' 'rename') -> #saveAsIcon. - #('save as new version') -> #saveAsNewVersionIcon. - #('quit') -> #quitIcon. - #('save and quit' ) -> #saveAndQuitIcon. - #('inspect it (i)' 'inspect world' 'inspect model' 'inspect morph' - 'inspect owner chain' 'inspect' 'inspect (i)' 'basic inspect' 'message names' 'find message names' 'inspect instances' 'inspect subinstances' 'inspect change set' 'inspect context (c)' 'inspect receiver (i)' 'start CPUWatcher' 'stop CPUWatcher') - -> #inspectIcon. - #('explore' 'explore it (I)' 'explore world' 'explore morph' 'explore (I)' 'explore context (C)' 'explore receiver (I)' 'references finder' 'weight explorer' 'explore CompiledMethod') -> #exploreIcon. - #('find...(f)' 'find class... (f)' 'find method...' 'find recent submissions' 'show hierarchy' 'show definition' 'show comment' 'filter' 'filter message list...' 'find context... (f)') -> #findIcon. - #('add item...' 'new category...' 'create new change set...' 'new change set... (n)' 'add new file') -> #newIcon. - #('remove method (x)' 'remove' 'remove class (x)' 'remove method from system (x)' 'remove class from system (x)' 'remove postscript') -> #deleteIcon. - #('delete method from changeset (d)' 'delete class from change set (d)' 'destroy change set (X)' 'revert & remove from changes' 'delete unchanged windows' 'delete non windows' 'delete both of the above' 'reset variables' 'remove contained in class categories...' 'clear this change set' 'uninstall this change set' 'delete directory...' 'delete') -> #warningIcon. - #('do again (j)' 'Redo - multiple (Z)') -> #redoIcon. - #('undo (z)' 'revert to previous version' 'Undo - multiple (z)') -> #undoIcon. - #('copy to clipboard (c)' 'copy (c)' 'copy class...' 'copy class chgs to other side' 'copy method to other side' 'copy all to other side (c)' 'copy name to clipboard' 'copy selector to clipboard') -> #copyIcon. - #('paste (v)' 'Paste without Format') -> #pasteIcon. - #('cut (x)' 'move class chgs to other side' 'move method to other side' 'submerge into other side') -> #cutIcon. - #('paste...' 'icons...') -> #worldIcon. -}! ! - -WorkspaceWindow removeSelector: #allowsMorphDrop! - -WorkspaceWindow removeSelector: #allowsMorphDrop! - -WorkspaceWindow removeSelector: #nameForObject:! - -WorkspaceWindow removeSelector: #nameForObject:! - -WorkspaceWindow removeSelector: #wantsDroppedMorph:event:! - -WorkspaceWindow removeSelector: #wantsDroppedMorph:event:! - -ObjectExplorerWindow removeSelector: #objectsForWorkspace! - -ObjectExplorerWindow removeSelector: #objectsForWorkspace! - -InspectorWindow removeSelector: #objectsForWorkspace! - -InspectorWindow removeSelector: #objectsForWorkspace! - -SystemWindow removeSelector: #objectsForWorkspace! - -SystemWindow removeSelector: #objectsForWorkspace! - -Morph removeSelector: #objectsForWorkspace! - -Morph removeSelector: #objectsForWorkspace! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Theme current class beCurrent! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3223-UseClipboardToAddObjectsToWorkspaces-JuanVuletich-2017Nov28-14h43m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3223] on 28 November 2017 at 3:28:20 pm'! -!FeatureRequirement methodsFor: 'private' stamp: 'jmv 11/28/2017 15:27:34' prior: 16840895! - inPackagesSubtreeOf: aDirectoryEntry do: aBlock - - | pckDir morphicExamplesPckDir compatPckDir | - - "Look in the requested directory" - aBlock value: aDirectoryEntry. - - "Look in the usual Packages subfolders" - pckDir _ aDirectoryEntry / 'Packages'. - pckDir exists ifTrue: [ - aBlock value: pckDir ]. - morphicExamplesPckDir _ pckDir / 'MorphicExamples'. - morphicExamplesPckDir exists ifTrue: [ - aBlock value: morphicExamplesPckDir ]. - compatPckDir _ aDirectoryEntry / 'CompatibilityPackages'. - compatPckDir exists ifTrue: [ - aBlock value: compatPckDir ]. - - "Finally look in folders that follow the convention of naming package repositories - with the 'Cuis-Smalltalk' prefix, and their possible 'Packages' subdir." - aDirectoryEntry children do: [ :entry | - (entry isDirectory and: [ entry name beginsWith: 'Cuis-Smalltalk' ]) ifTrue: [ - aBlock value: entry. - pckDir _ entry / 'Packages'. - pckDir exists ifTrue: [ - aBlock value: pckDir ]. - morphicExamplesPckDir _ pckDir / 'MorphicExamples'. - morphicExamplesPckDir exists ifTrue: [ - aBlock value: morphicExamplesPckDir ]. - compatPckDir _ entry / 'CompatibilityPackages'. - compatPckDir exists ifTrue: [ - aBlock value: compatPckDir ]]]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3224-AutoFindMorphicExamples-JuanVuletich-2017Nov28-15h27m-jmv.1.cs.st----! - -----SNAPSHOT----#(28 November 2017 3:35:28.627372 pm) Cuis5.0-3224-32.image priorSource: 1383661! - -----QUIT----#(28 November 2017 3:35:39.122677 pm) Cuis5.0-3224-32.image priorSource: 1438692! - -----STARTUP----#(29 November 2017 12:05:26.659458 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3224-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3224] on 29 November 2017 at 11:59:54 am'! - -Object subclass: #Clipboard - instanceVariableNames: 'contents recent contentsOriginalObjectWeakly ' - classVariableNames: 'Default ' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #Clipboard category: #'System-Support'! -Object subclass: #Clipboard - instanceVariableNames: 'contents recent contentsOriginalObjectWeakly' - classVariableNames: 'Default' - poolDictionaries: '' - category: 'System-Support'! -!Clipboard methodsFor: 'accessing' stamp: 'jmv 11/29/2017 11:42:16'! - contentsOriginalObject - "If not nil, the original object (not a copy!!) of what was stored in the clipboard. See #storeObject: Use with care" - - ^ contentsOriginalObjectWeakly at: 1! ! -!Clipboard class methodsFor: 'default clipboard' stamp: 'jmv 11/29/2017 11:42:25'! - contentsOriginalObject - "If not nil, the original object (not a copy!!) of what was stored in the clipboard. See #storeObject: Use with care" - - ^ self default contentsOriginalObject! ! -!Object methodsFor: 'inspecting' stamp: 'jmv 11/29/2017 11:49:58' prior: 50376267! - copyToClipboard - - Clipboard storeObject: self! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'jmv 11/29/2017 11:55:10' prior: 50376291! - paste - | objectName | - - model canBindVariables ifTrue: [ - "Not a copy!!!!!!" - Clipboard contentsOriginalObject ifNotNil: [ :object | - objectName _ model nameForObject: object. - (model bindingOf: objectName) value: object. - self replaceSelectionWith: objectName. - ^ self ]]. - ^ super paste! ! -!Clipboard methodsFor: 'accessing' stamp: 'jmv 11/29/2017 11:36:45' prior: 16807752! - storeObject: anObject - "Set new contents on the clipboard. Also export to OS. - anObject can be a: - String - Text - Form - Morph - Object. - OS clipboard supports String. Other formats might be supported if ExtendedClipboardInterface is present and operative." - - | primitiveFormat id | - - "Store a copy of the object. This is appropriate in case the original object is modified after being copied to the clipboard. - Another copy must be made again when pasting, as the same object could be pasted many times. - Besides, store the original object, but weakly (so we don't prevent it GCed). The original object might be used in workspaces." - (anObject isString or: [ anObject is: #Text]) - ifTrue: [ - contents _ anObject withCuisLineEndings. - contentsOriginalObjectWeakly at: 1 put: nil ] - ifFalse: [ - contents _ anObject copyForClipboard. - contentsOriginalObjectWeakly at: 1 put: anObject ]. - - self noteRecentClipping: contents. - - "Store on OS clipboard using ExtendedClipboardInterface if present" - self extendedClipboardInterface ifNotNil: [ :interface | - interface canStore ifTrue: [ - id _ self idFor: contents. - contents isString - ifTrue: [ ^interface storeString: contents id: id ]. - (contents is: #Text) - ifTrue: [ ^interface storeText: contents id: id ]. - (contents is: #Form) - ifTrue: [ ^interface storeForm: contents id: id ]. - (contents is: #Morph) - ifTrue: [ ^interface storeForm: (contents imageForm: 32) id: id ]. - ^interface storeString: contents asString id: id ]]. - - "Otherwise use the clipboard primitives in the VM" - "The VM uses UTF-8 for clipboard" - primitiveFormat _ (self stringOrIdFor: contents) asUtf8: true. - self primitiveClipboardString: primitiveFormat! ! -!Clipboard methodsFor: 'initialization' stamp: 'jmv 11/29/2017 11:34:38' prior: 16807881! - initialize - contents _ nil. - contentsOriginalObjectWeakly _ WeakArray new: 1. - recent _ OrderedCollection new.! ! -!Morph methodsFor: 'copying' stamp: 'jmv 11/29/2017 11:51:04' prior: 16874187! - copyForClipboard - "Some subclasses might need specific behavior..." - - self okayToDuplicate ifFalse: [ ^ nil ]. - ^self copy! ! -!Morph methodsFor: 'menus' stamp: 'jmv 11/29/2017 11:52:10' prior: 16876121! - addCopyItemsTo: aMenu - "Add copy-like items to the halo menu" - - | subMenu | - subMenu := MenuMorph new defaultTarget: self. - subMenu add: 'copy to clipboard (c)' action: #copyToClipboard:. - aMenu add: 'copy & print...' subMenu: subMenu! ! -!Morph methodsFor: 'meta-actions' stamp: 'jmv 11/29/2017 11:46:23' prior: 16876400! - copyToClipboard: evt - self copyToClipboard! ! - -Object subclass: #Clipboard - instanceVariableNames: 'contents recent contentsOriginalObjectWeakly' - classVariableNames: 'Default' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #Clipboard category: #'System-Support'! -Object subclass: #Clipboard - instanceVariableNames: 'contents recent contentsOriginalObjectWeakly' - classVariableNames: 'Default' - poolDictionaries: '' - category: 'System-Support'! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Clipboard releaseClassCachedState! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3225-PasteOnWorkspaceFixes-JuanVuletich-2017Nov29-11h56m-jmv.1.cs.st----! - -----SNAPSHOT----#(29 November 2017 12:05:32.332977 pm) Cuis5.0-3225-32.image priorSource: 1438791! - -----QUIT----#(29 November 2017 12:05:43.63678 pm) Cuis5.0-3225-32.image priorSource: 1444313! - -----STARTUP----#(15 December 2017 12:45:45.647961 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3225-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3225] on 30 November 2017 at 11:45:29 am'! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jmv 11/30/2017 11:44:27'! - isDevelopmentEnvironmentPresent - "Or we can't open a Smalltalk debugger" - - ^ Smalltalk isHeadless not and: [Smalltalk includesKey: #Debugger]! ! -!UnhandledError methodsFor: 'priv handling' stamp: 'jmv 11/30/2017 11:44:53' prior: 50373485! - defaultAction - "The current computation is terminated. The cause of the error should be logged or reported to the user. If the program is operating in an interactive debugging environment the computation should be suspended and the debugger activated." - - Smalltalk isDevelopmentEnvironmentPresent - ifTrue: [ self devDefaultAction ] - ifFalse: [ self standaloneAppDefaultAction ]! ! - -UnhandledError removeSelector: #isDevelopmentEnvironmentPresent! - -UnhandledError removeSelector: #isDevelopmentEnvironmentPresent! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3226-isDevelopmentEnvironmentPresent-to-Smalltalk-JuanVuletich-2017Nov30-11h44m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3226] on 4 December 2017 at 10:51:49 am'! -!Form methodsFor: 'private' stamp: 'jmv 12/4/2017 10:09:15'! - hackBits64: bitThing - "This method provides an initialization so that BitBlt may be used, eg, to - copy ByteArrays and other non-pointer objects efficiently. - The resulting form looks 8 wide, 8 deep, and bitThing-size-in-words high." - width _ 8. - depth _ 8. - bitThing class isBits ifFalse: [self error: 'bitThing must be a non-pointer object']. - bitThing class isBytes - ifTrue: [height _ bitThing basicSize // 8] - ifFalse: [height _ bitThing basicSize // 2]. - bits _ bitThing! ! -!BitBlt class methodsFor: 'byte and word utilities' stamp: 'jmv 12/4/2017 10:14:38'! - swapBytesIn64BitWords: aNonPointerThing - "Perform a bigEndian/littleEndian byte reversal of my 64 bit words. - We only intend this for non-pointer arrays. Do nothing if I contain pointers. - - | ba | - ba := #[1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16] copy. - BitBlt swapBytesIn64BitWords: ba. - ba - " - - self swapBytesIn64BitWords: aNonPointerThing from: 1 to: aNonPointerThing basicSize! ! -!BitBlt class methodsFor: 'byte and word utilities' stamp: 'jmv 12/4/2017 10:13:45'! - swapBytesIn64BitWords: aNonPointerThing from: start to: stop - "Perform a bigEndian/littleEndian byte reversal of my 64 bit words. - We only intend this for non-pointer arrays. Do nothing if I contain pointers." - - | hack blt | - "The implementation is a hack, but fast for large ranges" - hack _ Form new hackBits64: aNonPointerThing. - blt _ (BitBlt toForm: hack) sourceForm: hack. - blt combinationRule: Form reverse. "XOR" - blt sourceY: start-1; destY: start-1; height: stop-start+1; width: 1. - - "Exchange bytes 0 and 7" - blt sourceX: 0; destX: 7; copyBits. - blt sourceX: 7; destX: 0; copyBits. - blt sourceX: 0; destX: 7; copyBits. - - "Exchange bytes 1 and 6" - blt sourceX: 1; destX: 6; copyBits. - blt sourceX: 6; destX: 1; copyBits. - blt sourceX: 1; destX: 6; copyBits. - - "Exchange bytes 2 and 5" - blt sourceX: 2; destX: 5; copyBits. - blt sourceX: 5; destX: 2; copyBits. - blt sourceX: 2; destX: 5; copyBits. - - "Exchange bytes 3 and 4" - blt sourceX: 3; destX: 4; copyBits. - blt sourceX: 4; destX: 3; copyBits. - blt sourceX: 3; destX: 4; copyBits.! ! -!BitBlt class methodsFor: 'byte and word utilities' stamp: 'jmv 12/4/2017 10:15:23'! - swapHalvesIn64BitWords: aNonPointerThing - "Swap 32 bit halves in each 64 bit word. - We only intend this for non-pointer arrays. Do nothing if I contain pointers. - - | ba | - ba := #[1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16] copy. - BitBlt swapHalvesIn64BitWords: ba. - ba - " - - self swapHalvesIn64BitWords: aNonPointerThing from: 1 to: aNonPointerThing basicSize! ! -!BitBlt class methodsFor: 'byte and word utilities' stamp: 'jmv 12/4/2017 10:16:27'! - swapHalvesIn64BitWords: aNonPointerThing from: start to: stop - "Swap 32 bit halves in each 64 bit word. - We only intend this for non-pointer arrays. Do nothing if I contain pointers." - - | hack blt | - "The implementation is a hack, but fast for large ranges" - hack _ Form new hackBits64: aNonPointerThing. - blt _ (BitBlt toForm: hack) sourceForm: hack. - blt combinationRule: Form reverse. "XOR" - blt sourceY: start-1; destY: start-1; height: stop-start+1; width: 8. - - "Exchange bytes 0123 with 4567" - blt sourceX: 0; destX: 4; copyBits. - blt sourceX: 4; destX: 0; copyBits. - blt sourceX: 0; destX: 4; copyBits! ! -!Float64Array methodsFor: 'private' stamp: 'jmv 12/4/2017 10:51:19' prior: 16846148! - swapWords - "This could call #swapHalvesIn64BitWords:" - | tmp | - 1 to: self size do: [ :i | - tmp _ self rawBasicAt: i*2. - self rawBasicAt: i*2 put: (self rawBasicAt: i*2-1). - self rawBasicAt: i*2-1 put: tmp ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3227-byte-word-utilities-JuanVuletich-2017Dec04-10h00m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3227] on 4 December 2017 at 3:17:12 pm'! -!Float64Array commentStamp: '' prior: 16846050! - FloatArrays store 64bit IEEE floating point numbers, i.e. instances of the Float class. -Some support is included for subclasses in the style of Balloon3D-Math. - -Uses the same internal representation as Float. I.e. a Float and a Float64Array of size 1 hold the same bits. See #floatAt: and #floatAt:put:! -!Workspace methodsFor: 'variable declarations' stamp: 'jmv 12/4/2017 15:15:31' prior: 50376278! - nameForObject: object - "Answer a name suitable for a Workspace variable" - ^ object class name asLowercase , object identityHash asString! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3228-nameForObject-tweak-JuanVuletich-2017Dec04-15h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3228] on 6 December 2017 at 3:56:49 pm'! -!BitBltCanvas methodsFor: 'drawing-roundedRectangles' stamp: 'jmv 12/6/2017 15:41:29' prior: 16786942! - windowFrame: aRectangle color: aColor radius: r border: bw labelHeight: lh gradientTop: topFactor gradientBottom: bottomFactor insideColor: insideColor - " - BitBltCanvas releaseClassCachedState. - Display getCanvas windowFrame: (10@10 extent: 200@100) color: Color red radius: 10 border: 5 labelHeight: 25 gradientTop: 1.0 gradientBottom: 0.5 insideColor: Color green. - Display forceToScreen - " - "top stripe" - | bottomColor he tl tr | - self - image: (self class topLeftCorner: r height: lh gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: aRectangle topLeft. - self - image: (self class topRightCorner: r height: lh gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: aRectangle topRight - (r@0). - self - fillRectangle: ((aRectangle withHeight: lh) insetBy: r@0) - tilingWith: (self class verticalGrayGradient: lh gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor. - - bottomColor _ aColor * bottomFactor. - - "left and right borders" - tl _ aRectangle topLeft + (0@lh). - tr _ aRectangle topRight + (bw negated@lh). - he _ bw@(aRectangle height - lh - r). - self fillRectangle: (tl extent: he) color: bottomColor. - self fillRectangle: (tr extent: he) color: bottomColor. - - "bottom stripe" - self - image: (self class bottomLeftCorner: r height: r gradientTop: 1 gradientBottom: 1 borderWidth: bw) - multipliedBy: bottomColor - at: aRectangle bottomLeft - (0@r). - self - image: (self class bottomRightCorner: r height: r gradientTop: 1 gradientBottom: 1 borderWidth: bw) - multipliedBy: bottomColor - at: aRectangle bottomRight - (r@r) . - self fillRectangle: ((aRectangle bottomLeft + (r@bw negated)) extent: (aRectangle width - r - r@bw)) color: bottomColor. - - "inside" - self fillRectangle: (aRectangle insetBy: (bw@lh corner: bw@bw)) color: insideColor! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3229-CommentTweak-JuanVuletich-2017Dec06-15h29m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3229] on 11 December 2017 at 11:54:23 am'! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 11/2/2017 15:56:23' prior: 50370833! - arrowKey: aChar - "Handle a keyboard navigation character. Answer true if handled, false if not." - | keyEvent answer nextSelection oldSelection | - answer := false. - keyEvent := aChar numericValue. - oldSelection := self getSelectionIndex. - nextSelection := oldSelection. - keyEvent = 31 ifTrue: [ - "down" - nextSelection := oldSelection + 1. - nextSelection > self maximumSelection ifTrue: [ nextSelection := self minimumSelection ]]. - keyEvent = 30 ifTrue: [ - "up" - nextSelection := oldSelection - 1. - nextSelection < self minimumSelection ifTrue: [ nextSelection := self maximumSelection ]]. - keyEvent = 1 ifTrue: [ "home" - nextSelection := 1 ]. - keyEvent = 4 ifTrue: [ "end" - nextSelection := scroller submorphs size ]. - keyEvent = 11 ifTrue: [ "page up" - nextSelection := oldSelection - self numSelectionsInView max: 1 ]. - keyEvent = 12 ifTrue: [ "page down" - nextSelection := oldSelection + self numSelectionsInView ]. - keyEvent = 29 ifTrue: [ - "right" - selectedMorph ifNotNil: [ - (selectedMorph canExpand and: [ selectedMorph isExpanded not ]) - ifTrue: [ - self toggleExpandedState: selectedMorph. - self scrollSelectionIntoView. - answer := true ] - ifFalse: [ nextSelection := oldSelection + 1 ]]]. - keyEvent = 28 ifTrue: [ - "left" - selectedMorph ifNotNil: [ - selectedMorph isExpanded - ifTrue: [ - self toggleExpandedState: selectedMorph. - self scrollSelectionIntoView. - answer := true ] - ifFalse: [ - oldSelection > self minimumSelection ifTrue: [ - nextSelection _ (oldSelection-1 to: 1 by: -1) detect: [ :i | ( scroller submorphs at: i) indentLevel < selectedMorph indentLevel ]]. - ]]]. - nextSelection = oldSelection ifFalse: [ - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self highlightedMorph: (self listMorphAt: nextSelection). - "Update the model in next world cycle, so user gets the immediate feedback." - WorldState addDeferredUIMessage: [ self setSelectionIndex: nextSelection ]. - answer := true ]. - ^ answer.! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3230-TreeView-keyboardNavigationEng-JuanVuletich-2017Dec11-11h51m-jmv.1.cs.st----! - -----SNAPSHOT----#(15 December 2017 12:45:51.674005 pm) Cuis5.0-3230-32.image priorSource: 1444413! - -----QUIT----#(15 December 2017 12:46:11.51526 pm) Cuis5.0-3230-32.image priorSource: 1455107! - -----STARTUP----#(4 January 2018 5:56:45.944902 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3230-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3230] on 16 December 2017 at 6:16:14 pm'! -!MorphicCanvas commentStamp: 'jmv 12/16/2017 18:15:31' prior: 16877314! - A MorphicCanvas offers 2D drawing services. It works on a 'form', usually the Display. These services are used, for example, in #drawOn: methods. - -Subclasses are specific implementations. BitBltCanvas is based on BitBlt, the raster operation invented by Dan Ingalls for Smalltalk, and included in Smalltalk-80 and Squeak. VectorCanvas is based on its VectorEngine, using a novel technique for the rasterization (sampling) of vector graphics, invented by Juan Vuletich.! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3231-MorphicCanvasComment-JuanVuletich-2017Dec16-18h14m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3231] on 26 December 2017 at 9:21:34 am'! -!CodePackage methodsFor: 'enumerating' stamp: 'jmv 12/26/2017 08:36:49'! - coreMethodsOf: aClass do: aBlock - "Evaluate aBlock with the actual method objects in this package." - - aClass organization categories do: [ :cat | - (self isForeignClassExtension: cat) ifFalse: [ - (aClass organization listAtCategoryNamed: cat) do: [ :s | - aBlock value: (self referenceForMethod: s ofClass: aClass) ]]]! ! -!CodePackage methodsFor: 'saving' stamp: 'jmv 12/26/2017 08:39:58'! - writeCoreMethodsOf: aClass on: aStream - - self coreMethodsOf: aClass do: [ :methodReference | - methodReference isValid - ifTrue: [ - self writeMethod: methodReference on: aStream ]]! ! -!CodePackage methodsFor: 'saving' stamp: 'jmv 12/26/2017 08:52:22' prior: 16810579! - write: classes methodsOn: aStream - - classes - do: [ :class | - self writeCoreMethodsOf: class on: aStream. - self writeCoreMethodsOf: class class on: aStream ] - displayingProgress: 'Saving methods...'! ! -!CodePackage methodsFor: 'saving' stamp: 'jmv 12/26/2017 09:07:44' prior: 16810632! - writeOnStream: aStream - - | sortedClasses | - aStream - nextChunkPut: ('Description ', description) printString; - newLine. - self writeFeatureSpecOn: aStream. - self writeSystemCategoriesOn: aStream. - sortedClasses _ Array streamContents: [ :strm | - self classesInSafeOrderDo: [ :cls | - strm nextPut: cls ]]. - self - write: sortedClasses classDefinitionsOn: aStream; - write: sortedClasses classCommentsOn: aStream; - write: sortedClasses methodsOn: aStream. - self - sortedExtensionMethodsDo: [ :methodReference | - methodReference isValid ifTrue: [ - self writeMethod: methodReference on: aStream ]] - displayingProgress: 'Saving extension methods...'. - self - write: sortedClasses initializersOn: aStream! ! - -CodePackage removeSelector: #actualMethodsDo:! - -CodePackage removeSelector: #actualMethodsDo:! - -CodePackage removeSelector: #addCoreMethod:! - -CodePackage removeSelector: #addCoreMethod:! - -CodePackage removeSelector: #addExtensionMethod:! - -CodePackage removeSelector: #addExtensionMethod:! - -CodePackage removeSelector: #addMethod:! - -CodePackage removeSelector: #addMethod:! - -CodePackage removeSelector: #allOverriddenMethods! - -CodePackage removeSelector: #allOverriddenMethods! - -CodePackage removeSelector: #allOverriddenMethodsDo:! - -CodePackage removeSelector: #allOverriddenMethodsDo:! - -CodePackage removeSelector: #baseCategoryOfMethod:! - -CodePackage removeSelector: #baseCategoryOfMethod:! - -CodePackage removeSelector: #changeRecordForOverriddenMethod:! - -CodePackage removeSelector: #changeRecordForOverriddenMethod:! - -CodePackage removeSelector: #coreCategoriesForClass:! - -CodePackage removeSelector: #coreCategoriesForClass:! - -CodePackage removeSelector: #extensionClasses! - -CodePackage removeSelector: #extensionClasses! - -CodePackage removeSelector: #externalCallers! - -CodePackage removeSelector: #externalCallers! - -CodePackage removeSelector: #externalRefsSelect:thenCollect:! - -CodePackage removeSelector: #externalRefsSelect:thenCollect:! - -CodePackage removeSelector: #externalSubclasses! - -CodePackage removeSelector: #externalSubclasses! - -CodePackage removeSelector: #externalUsers! - -CodePackage removeSelector: #externalUsers! - -CodePackage removeSelector: #foreignClasses! - -CodePackage removeSelector: #foreignClasses! - -CodePackage removeSelector: #foreignSystemCategories! - -CodePackage removeSelector: #foreignSystemCategories! - -CodePackage removeSelector: #includesChangeRecord:! - -CodePackage removeSelector: #includesChangeRecord:! - -CodePackage removeSelector: #includesClassNamed:! - -CodePackage removeSelector: #includesClassNamed:! - -CodePackage removeSelector: #includesMethodCategory:ofClassNamed:! - -CodePackage removeSelector: #includesMethodCategory:ofClassNamed:! - -CodePackage removeSelector: #isOverrideCategory:! - -CodePackage removeSelector: #isOverrideCategory:! - -CodePackage removeSelector: #isOverrideMethod:! - -CodePackage removeSelector: #isOverrideMethod:! - -CodePackage removeSelector: #isOverrideOfYourMethod:! - -CodePackage removeSelector: #isOverrideOfYourMethod:! - -CodePackage removeSelector: #overriddenMethods! - -CodePackage removeSelector: #overriddenMethods! - -CodePackage removeSelector: #overriddenMethodsDo:! - -CodePackage removeSelector: #overriddenMethodsDo:! - -CodePackage removeSelector: #overriddenMethodsInClass:! - -CodePackage removeSelector: #overriddenMethodsInClass:! - -CodePackage removeSelector: #overriddenMethodsInClass:do:! - -CodePackage removeSelector: #overriddenMethodsInClass:do:! - -CodePackage removeSelector: #overrideCategoriesForClass:! - -CodePackage removeSelector: #overrideCategoriesForClass:! - -CodePackage removeSelector: #overrideCategoriesForClass:do:! - -CodePackage removeSelector: #overrideCategoriesForClass:do:! - -CodePackage removeSelector: #overrideMethods! - -CodePackage removeSelector: #overrideMethods! - -CodePackage removeSelector: #writeMethodsOf:on:! - -CodePackage removeSelector: #writeMethodsOf:on:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3232-CodePackage-cleanupAndEnhancements-JuanVuletich-2017Dec26-09h12m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3232] on 27 December 2017 at 12:03:07 pm'! -!Theme class methodsFor: 'class initialization' stamp: 'jmv 12/27/2017 11:14:22' prior: 50341499! - currentTheme: aTheme - - CurrentTheme := aTheme new. - SHTextStylerST80 releaseClassCachedState. - self runningWorld ifNotNil: [ :w | - w backgroundImage ifNil: [ - w color: CurrentTheme background ]]. - SystemWindow initialize. - BitBltCanvas releaseClassCachedState. - self runningWorld ifNotNil: [ :w | - CurrentTheme useTaskbar - ifTrue: [w showTaskbar] - ifFalse: [w hideTaskbar]. - w restoreMorphicDisplay ]. - - ^ CurrentTheme! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3233-DoNotResetShoutPreferencesOnthemeChange-JuanVuletich-2017Dec27-12h02m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3226] on 11 December 2017 at 2:44:07 pm'! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'pb 12/11/2017 14:37:42'! - privateMorphicTopLevelRendererClass - "The class controlling the outermost rendering process for Morphic and other critical methods for handling interrupts. Dangerous to change as any bugs will effectively crash the UI for the entire image. - - Using 'private' prefix to reflect the danger even though it will likely be called externally." - ^ ProjectX! ! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'pb 12/11/2017 14:37:54'! - privateMorphicWorldClass - "The class to be used for Morphic Worlds. Dangerous to change as any bugs will effectively crash the UI for the entire image. - - Using 'private' prefix to reflect the danger even though it will likely be called externally." - ^ PasteUpMorph ! ! -!Debugger methodsFor: 'initialization' stamp: 'pb 12/11/2017 14:41:18' prior: 16830276! - openFullNoSuspendLabel: aString - "Create and schedule a full debugger with the given label. Do not terminate the current active process." - - self openFullMorphicLabel: aString. - interruptedProcessUI _ Smalltalk privateMorphicTopLevelRendererClass newProcessIfUIX: interruptedProcess! ! -!Debugger methodsFor: 'initialization' stamp: 'pb 12/11/2017 14:41:28' prior: 16830286! - openNotifierContents: msgString label: label - "Create and schedule a notifier view with the given label and message. A notifier view shows just the message or the first several lines of the stack, with a menu that allows the user to open a full debugger if so desired." - "NOTE: When this method returns, a new process has been scheduled to run the windows, and thus this notifier, but the previous active porcess has not been suspended. The sender will do this." - | msg | - Sensor flushKeyboard. - savedCursor _ Cursor currentCursor. - Cursor normal activateCursor. - msg _ (label beginsWith: 'Space is low') - ifTrue: [ self lowSpaceChoices, (msgString ifNil: ['']) ] - ifFalse: [ msgString ]. - - interruptedProcessUI _ Smalltalk privateMorphicTopLevelRendererClass newProcessIfUIX: interruptedProcess. - WorldState addDeferredUIMessage: [ - PreDebugWindow open: self label: label message: msg ]. - ^self! ! -!Debugger class methodsFor: 'opening' stamp: 'pb 12/11/2017 14:41:38' prior: 50373401! - openOn: process context: context label: title fullView: bool - "Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger." - | w | - Preferences logDebuggerStackToFile ifTrue: [ - Smalltalk - logError: title - inContext: context - to: 'CuisDebug' ]. - w := Smalltalk privateMorphicTopLevelRendererClass newProcessIfUIX: process. - "schedule debugger in deferred UI message to address redraw - problems after opening a debugger e.g. from the testrunner." - WorldState addDeferredUIMessage: [ - [ | debugger | - "In case an error in Morphic code got us here, ensure mouse focus has been released" - true runningWorld ifNotNil: [ :rWorld | - rWorld activeHand ifNotNil: [ :aHand | - aHand releaseMouseFocus ]]. - debugger := self new - process: process - context: context. - debugger interruptedProcessUI: w. - bool - ifTrue: [ debugger openFullMorphicLabel: title ] - ifFalse: [ - PreDebugWindow - open: debugger - label: title - message: nil ]] - on: UnhandledError - do: [ :exOuter | | errorDescription | - errorDescription := 'Error while trying to open Debugger' , String newLineString , 'Orginal error: ' , title asString , '.' , String newLineString , ' Debugger error: ' , - ([ exOuter description ] - on: UnhandledError - do: [ :exInner | - exInner return: 'a ' , exInner class printString ]) , ':'. - self primitiveError: errorDescription ]]. - process suspend.! ! -!SystemDictionary methodsFor: 'memory space' stamp: 'pb 12/11/2017 14:42:30' prior: 16920405! - lowSpaceWatcher - "Wait until the low space semaphore is signalled, then take appropriate actions." - - self garbageCollectMost <= self lowSpaceThreshold ifTrue: [ - self garbageCollect <= self lowSpaceThreshold ifTrue: [ - "free space must be above threshold before starting low space watcher" - ^ Smalltalk primitiveBeep ]]. - - LowSpaceSemaphore _ Semaphore new. - self primLowSpaceSemaphore: LowSpaceSemaphore. - self primSignalAtBytesLeft: self lowSpaceThreshold. "enable low space interrupts" - - LowSpaceSemaphore wait. "wait for a low space condition..." - - self primSignalAtBytesLeft: 0. "disable low space interrupts" - self primLowSpaceSemaphore: nil. - LowSpaceProcess _ nil. - "Note: user now unprotected until the low space watcher is re-installed" - - self privateMorphicTopLevelRendererClass currentInterruptNameX: 'Space is low'! ! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'pb 12/11/2017 14:42:18' prior: 16920982! - handleUserInterrupt - Preferences cmdDotEnabled ifTrue: [ - [self privateMorphicTopLevelRendererClass currentInterruptNameX: 'User Interrupt'] fork]! ! -!SystemDictionary methodsFor: 'shrinking' stamp: 'pb 12/11/2017 14:39:37' prior: 50357691! - reduceCuis - " - Smalltalk reduceCuis - " - | keep n unused newDicts oldDicts | - - self nominallyUnsent: #reduceCuis. - - "Remove icons" - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - self privateMorphicWorldClass allInstancesDo: [ :w | - w backgroundImageData: nil. - w submorphsDo: [ :a | a delete ]]. - Preferences useNoIcons. - Theme current initialize. - Theme content: nil. - Color shutDown. - BitBltCanvas releaseClassCachedState. - - Transcript clear. - Clipboard default initialize. - - - "Remove some methods, even if they have senders." -" ColorPickerMorph class removeSelector: #buildEyedropperIcon." - Theme removeSelector: #miscellaneousIcons. - Utilities removeSelector: #vmStatisticsReportString. - SystemDictionary removeSelector: #recreateSpecialObjectsArray. - - StrikeFont removeMostFonts. - StrikeFont saveSpace. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - - keep := OrderedCollection new. - keep addAll: #(SpaceTally). - AppLauncher appGlobalName ifNotNil: [ :any | - keep add: any ]. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - [ - #hereWeGo print. - unused do: [:c | - c print. - (Smalltalk at: c) removeFromSystem]. - n := Smalltalk removeAllUnSentMessages. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - n > 0 or: [ - unused notEmpty ]] whileTrue. - ChangeSet zapAllChangeSets. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - Symbol rehash. - - "Shrink method dictionaries." - Smalltalk garbageCollect. - oldDicts _ MethodDictionary allInstances. - newDicts _ Array new: oldDicts size. - oldDicts withIndexDo: [:d :index | - newDicts at: index put: d rehashWithoutBecome ]. - oldDicts elementsExchangeIdentityWith: newDicts. - oldDicts _ newDicts _ nil. - - SmalltalkCompleter initialize . - - "Sanity checks" -" Undeclared - Smalltalk cleanOutUndeclared - Smalltalk browseUndeclaredReferences - Smalltalk obsoleteClasses - Smalltalk obsoleteBehaviors - Smalltalk browseObsoleteMethodReferences - SmalltalkImage current fixObsoleteReferences - Smalltalk browseAllUnimplementedCalls"! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'pb 12/11/2017 14:43:32' prior: 50369890! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag -"WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " -| activeProc | -activeProc _ Processor activeProcess. -[ - | isARealStartup world reopenTranscript | - self logSnapshot: save andQuit: quit. - - reopenTranscript _ false. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | each isInWorld ifTrue: [ each delete. reopenTranscript _ true ]]. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - - - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - - "Cosas que levanto explicitamente abajo" - world _ self privateMorphicTopLevelRendererClass ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "world _ clearAllStateFlag ifFalse: [ self privateMorphicTopLevelRendererClass ui ]." - self privateMorphicTopLevelRendererClass stopUIProcess. - activeProc isTerminated ifFalse: [ - activeProc terminate ]. - - "Clean Globals" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: nil. - Smalltalk closeSourceFiles. Smalltalk at: #SourceFiles put: nil. - Smalltalk allClassesDo: [ :cls | cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ Smalltalk printStuffToCleanOnImageSave ]. - - - "Do image save & quit as apropriate" - Cursor write activateCursor. - save - ifTrue: [ - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - - - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: (DisplayScreen extent: `1024@768` depth: 32). - Smalltalk at: #SourceFiles put: (Array new: 2). - Smalltalk openSourceFiles. - - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - - - self privateMorphicTopLevelRendererClass spawnNewMorphicProcessFor: (world ifNil: [ self privateMorphicWorldClass newWorld ]). - - reopenTranscript ifTrue: [ - WorldState addDeferredUIMessage: [ - TranscriptWindow openTranscript ]]. - " - WorldState addDeferredUIMessage: [ - world fullRepaintNeeded ]. - " - - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - WorldState addDeferredUIMessage: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]. - -] forkAt: Processor timingPriority-1 named: 'Startup process'.! ! -!ProjectX class methodsFor: 'as yet unclassified' stamp: 'pb 12/11/2017 14:42:05' prior: 16896342! - interruptNameX: labelString - "Create a Notifier on the active scheduling process with the given label." - | preemptedProcess label | - preemptedProcess _ Processor preemptedProcess. - - "Only debug preempted process if its priority is >= UIProcess' priority" - preemptedProcess priority < UIProcess priority ifTrue: [ - preemptedProcess _ UIProcess ]. - - label _ labelString, - ' - Process: ', preemptedProcess name, - ' - Priority: ', preemptedProcess priority printString. - preemptedProcess isTerminated - ifTrue: [ - self newProcessIfUIX: preemptedProcess. - self notify: 'Can not debug a terminated process: ', label ] - ifFalse: [ - preemptedProcess suspend. - Debugger - openInterrupt: label - onProcess: preemptedProcess ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3234-Morphic-globals-PhilBellalouna-2017Dec11-14h37m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3227] on 11 December 2017 at 5:30:58 pm'! -!PasteUpMorph methodsFor: 'world state' stamp: 'pb 12/11/2017 15:25:45'! - addDeferredUIMessage: valuableObject - "This will be safe to call directly in a multi-world environment (as opposed to the WorldState class-side method)" - WorldState addDeferredUIMessage: valuableObject ! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'pb 12/11/2017 17:07:49' prior: 50377579! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag -"WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " -| activeProc | -activeProc _ Processor activeProcess. -[ - | isARealStartup world reopenTranscript | - self logSnapshot: save andQuit: quit. - - reopenTranscript _ false. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | each isInWorld ifTrue: [ each delete. reopenTranscript _ true ]]. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - - - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - - "Cosas que levanto explicitamente abajo" - world _ self privateMorphicTopLevelRendererClass ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "world _ clearAllStateFlag ifFalse: [ self privateMorphicTopLevelRendererClass ui ]." - self privateMorphicTopLevelRendererClass stopUIProcess. - activeProc isTerminated ifFalse: [ - activeProc terminate ]. - - "Clean Globals" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: nil. - Smalltalk closeSourceFiles. Smalltalk at: #SourceFiles put: nil. - Smalltalk allClassesDo: [ :cls | cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ Smalltalk printStuffToCleanOnImageSave ]. - - - "Do image save & quit as apropriate" - Cursor write activateCursor. - save - ifTrue: [ - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - - - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: (DisplayScreen extent: `1024@768` depth: 32). - Smalltalk at: #SourceFiles put: (Array new: 2). - Smalltalk openSourceFiles. - - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - - - self privateMorphicTopLevelRendererClass spawnNewMorphicProcessFor: (world ifNil: [ world:=self privateMorphicWorldClass newWorld ]). - - reopenTranscript ifTrue: [ - world addDeferredUIMessage: [ - TranscriptWindow openTranscript ]]. - " - world addDeferredUIMessage: [ - world fullRepaintNeeded ]. - " - - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - world addDeferredUIMessage: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]. - -] forkAt: Processor timingPriority-1 named: 'Startup process'.! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'pb 12/11/2017 15:29:32' prior: 16875813! -showBalloon: msgString hand: aHand - "Pop up a balloon containing the given string, - first removing any existing BalloonMorphs in the world." - - | w balloon h | - (w _ self world) ifNil: [^ self]. - h _ aHand. - h ifNil:[ - h _ w activeHand]. - balloon _ HoverHelpMorph contents: msgString. - - "Do it in a while. In some cases, processing the event that might have triggered us might also remove any Help Balloon" - self world addDeferredUIMessage: [ - balloon popUpForHand: h ]! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'pb 12/11/2017 15:30:12' prior: 50337479! - restoreMorphicDisplay - DisplayScreen startUp. - self - morphExtent: Display extent; - handsDo: [ :h | h visible: true ]; - fullRepaintNeeded. - self addDeferredUIMessage: [ Cursor normal activateCursor ]! ! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'pb 12/11/2017 15:26:29' prior: 50377051! - arrowKey: aChar - "Handle a keyboard navigation character. Answer true if handled, false if not." - | keyEvent answer nextSelection oldSelection | - answer := false. - keyEvent := aChar numericValue. - oldSelection := self getSelectionIndex. - nextSelection := oldSelection. - keyEvent = 31 ifTrue: [ - "down" - nextSelection := oldSelection + 1. - nextSelection > self maximumSelection ifTrue: [ nextSelection := self minimumSelection ]]. - keyEvent = 30 ifTrue: [ - "up" - nextSelection := oldSelection - 1. - nextSelection < self minimumSelection ifTrue: [ nextSelection := self maximumSelection ]]. - keyEvent = 1 ifTrue: [ "home" - nextSelection := 1 ]. - keyEvent = 4 ifTrue: [ "end" - nextSelection := scroller submorphs size ]. - keyEvent = 11 ifTrue: [ "page up" - nextSelection := oldSelection - self numSelectionsInView max: 1 ]. - keyEvent = 12 ifTrue: [ "page down" - nextSelection := oldSelection + self numSelectionsInView ]. - keyEvent = 29 ifTrue: [ - "right" - selectedMorph ifNotNil: [ - (selectedMorph canExpand and: [ selectedMorph isExpanded not ]) - ifTrue: [ - self toggleExpandedState: selectedMorph. - answer := true ] - ifFalse: [ nextSelection := oldSelection + 1 ]]]. - keyEvent = 28 ifTrue: [ - "left" - selectedMorph ifNotNil: [ - selectedMorph isExpanded - ifTrue: [ - self toggleExpandedState: selectedMorph. - answer := true ] - ifFalse: [ nextSelection := oldSelection - 1 max: 1 ]]. - ^ true ]. - nextSelection = oldSelection ifFalse: [ - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self highlightedMorph: (self listMorphAt: nextSelection). - "Update the model in next world cycle, so user gets the immediate feedback." - self world addDeferredUIMessage: [ self setSelectionIndex: nextSelection ]. - answer := true ]. - ^ answer.! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'pb 12/11/2017 15:30:36' prior: 16888803! -arrowKey: aChar - "Process the up and down arrows in a list pane. Note that the listView tells us what index variable, how to get the list, and how to move the index." - | keyEvent oldSelection nextSelection max min howMany answer w | - answer _ false. - keyEvent _ aChar numericValue. - oldSelection _ self getCurrentSelectionIndex. - nextSelection _ oldSelection. - max _ self maximumSelection. - min _ self minimumSelection. - howMany _ self numSelectionsInView. "get this exactly??" - - keyEvent = 31 ifTrue: [ - "down-arrow; move down one, wrapping to top if needed" - nextSelection _ oldSelection + 1. - nextSelection > max ifTrue: [ nextSelection _ 1 ]]. - - keyEvent = 30 ifTrue: [ - "up arrow; move up one, wrapping to bottom if needed" - nextSelection _ oldSelection - 1. - nextSelection < 1 ifTrue: [ nextSelection _ max ]]. - - keyEvent = 1 ifTrue: [ nextSelection _ 1 ]. "home" - keyEvent = 4 ifTrue: [ nextSelection _ max ]. "end" - keyEvent = 11 ifTrue: [ nextSelection _ min max: oldSelection - howMany ]. "page up" - keyEvent = 12 ifTrue: [ nextSelection _ oldSelection + howMany min: max ]. "page down" - nextSelection = oldSelection ifFalse: [ - w _ self owningWindow. - (w isNil or: [ w okToChange ]) ifTrue: [ "No change if model is locked" - - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self listMorph highlightedRow: nextSelection. - - "Update the model in next world cycle, so user gets the immediate feedback." - self world addDeferredUIMessage: [ - self changeModelSelection: nextSelection ]. - answer _ true ]]. - ^answer! ! -!PluggableListMorphOfMany methodsFor: 'events' stamp: 'pb 12/11/2017 15:30:48' prior: 16889213! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - - | oldIndex oldVal row w | - self hasKeyboardFocus ifFalse: [ - aMouseButtonEvent hand newKeyboardFocus: self ]. - - row _ self rowAtLocation: localEventPosition. - - row = 0 ifTrue: [ - ^super mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition ]. - - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self listMorph highlightedRow: row. - - w _ self owningWindow. - (w isNil or: [ w okToChange ]) ifTrue: [ "No change if model is locked" - - "Set meaning for subsequent dragging of selection" - dragOnOrOff _ (self listSelectionAt: row) not. - dragStartRow _ row. - oldIndex _ self getCurrentSelectionIndex. - oldIndex ~= 0 ifTrue: [oldVal _ self listSelectionAt: oldIndex]. - - "Different from PluggableListMorph. There, we highlight on mouse down, and act on mouse up. - Here, we act on mouse down, because we support dragging of selection, so mouse up will - only happen after user is finished dragging. In order to get the highlight visible for the user, - update the model on next world cycle." - self world addDeferredUIMessage: [ - "Set or clear new primary selection (listIndex)" - dragOnOrOff - ifTrue: [self changeModelSelection: row] - ifFalse: [self changeModelSelection: 0]. - "Need to restore the old one, due to how model works, and set new one." - oldIndex ~= 0 ifTrue: [self listSelectionAt: oldIndex put: oldVal]. - self listSelectionAt: row put: dragOnOrOff ]. - ]. - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: nil - clkNHalf: nil - dblClkSel: #doubleClick:localPosition: - dblClkNHalfSel: nil - tripleClkSel: nil! ! -!SystemWindow methodsFor: 'open/close' stamp: 'pb 12/11/2017 15:31:54' prior: 50335162! - openInWorld: aWorld - "This msg and its callees result in the window being activeOnlyOnTop" - | frameRect | - frameRect _ self initialFrameIn: aWorld. - self morphExtent: frameRect extent. - aWorld addMorph: self position: frameRect topLeft. - "Do it deferred. Was needed for text cursor to start blinking if (Preferences disable: #focusFollowsMouse) " - aWorld addDeferredUIMessage: [ self activate ]! ! -!TaskbarMorph methodsFor: 'events' stamp: 'pb 12/11/2017 15:32:05' prior: 50337201! - screenSizeChanged - "Respond to change in screen size by repositioning self to bottom of screen" - -" Transcript newLine; print: 'Taskbar screenSizeChanged'. -" - | y e | - self world addDeferredUIMessage: [ - self world ifNotNil: [ :w | - y _ w morphExtent y - self defaultHeight. - e _ self internalizeDistance: w morphExtent x @ self defaultHeight. - self morphPosition: 0@y extent: e ]]! ! -!InnerTextMorph methodsFor: 'editing' stamp: 'pb 12/11/2017 15:29:07' prior: 50365184! - acceptContents - "The message is sent when the user hits return or Cmd-S. - Accept the current contents and end editing." - "Inform the model of text to be accepted, and return true if OK." - - | accepted prevSelection prevScrollValue | - - prevSelection _ self editor selectionInterval copy. - prevScrollValue _ owner verticalScrollBar scrollValue. - - (self canDiscardEdits and: [(self hasProperty: #alwaysAccept) not]) ifTrue: [self flash. ^true]. - (self hasEditingConflicts and: [ self confirmAcceptAnyway not ]) ifTrue: [self flash. ^false]. - - accepted _ model acceptContentsFrom: owner. - "During the step for the browser, updatePaneIfNeeded is called, and - invariably resets the contents of the code-holding PluggableTextMorph - at that time, resetting the cursor position and scroller in the process. - The following line forces that update without waiting for the step, - then restores the cursor and scrollbar" - - "some implementors of acceptContentsFrom: answer self :(" - ^accepted == true - ifTrue: [ - model refetch. - self editor selectFrom: prevSelection first to: prevSelection last. - "FIXME - is there actually a case where world will be nil here?" - self world addDeferredUIMessage: [ - self world ifNotNil: [ :w | w activeHand newKeyboardFocus: self ]. - owner verticalScrollBar internalScrollValue: prevScrollValue]. - true] - ifFalse: [ false ]! ! -!WorldState class methodsFor: 'class initialization' stamp: 'pb 12/11/2017 15:33:57' prior: 16946300! - addDeferredUIMessage: valuableObject - "Objects should not be calling directly as this will disappear from this location!! From the sender, instead to schedule on the currently running world use: - self runningWorld addDeferredUIMessage: ... - And to schedule on the world a given Morph exists in use: - self world addDeferredUIMessage: ..." - self deferredUIMessages nextPut: valuableObject! ! -!AndreasSystemProfiler methodsFor: 'reporting' stamp: 'pb 12/11/2017 15:33:07' prior: 16779085! - doReport - "Report the results of this profiler run" - self runningWorld addDeferredUIMessage: [ - SystemWindow - editText: (Workspace withText: self report) - label: 'Spy Results' - wrap: false ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3235-Morphic-addDeferredUIMessage-PhilBellalouna-2017Dec11-14h52m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3232] on 15 December 2017 at 9:24:34 pm'! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'pb 12/15/2017 21:24:22' prior: 50377889! - arrowKey: aChar - "Handle a keyboard navigation character. Answer true if handled, false if not." - | keyEvent answer nextSelection oldSelection | - answer := false. - keyEvent := aChar numericValue. - oldSelection := self getSelectionIndex. - nextSelection := oldSelection. - keyEvent = 31 ifTrue: [ - "down" - nextSelection := oldSelection + 1. - nextSelection > self maximumSelection ifTrue: [ nextSelection := self minimumSelection ]]. - keyEvent = 30 ifTrue: [ - "up" - nextSelection := oldSelection - 1. - nextSelection < self minimumSelection ifTrue: [ nextSelection := self maximumSelection ]]. - keyEvent = 1 ifTrue: [ "home" - nextSelection := 1 ]. - keyEvent = 4 ifTrue: [ "end" - nextSelection := scroller submorphs size ]. - keyEvent = 11 ifTrue: [ "page up" - nextSelection := oldSelection - self numSelectionsInView max: 1 ]. - keyEvent = 12 ifTrue: [ "page down" - nextSelection := oldSelection + self numSelectionsInView ]. - keyEvent = 29 ifTrue: [ - "right" - selectedMorph ifNotNil: [ - (selectedMorph canExpand and: [ selectedMorph isExpanded not ]) - ifTrue: [ - self toggleExpandedState: selectedMorph. - self scrollSelectionIntoView. - answer := true ] - ifFalse: [ nextSelection := oldSelection + 1 ]]]. - keyEvent = 28 ifTrue: [ - "left" - selectedMorph ifNotNil: [ - selectedMorph isExpanded - ifTrue: [ - self toggleExpandedState: selectedMorph. - self scrollSelectionIntoView. - answer := true ] - ifFalse: [ - oldSelection > self minimumSelection ifTrue: [ - nextSelection _ (oldSelection-1 to: 1 by: -1) detect: [ :i | ( scroller submorphs at: i) indentLevel < selectedMorph indentLevel ]]. - ]]]. - nextSelection = oldSelection ifFalse: [ - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self highlightedMorph: (self listMorphAt: nextSelection). - "Update the model in next world cycle, so user gets the immediate feedback." - self world addDeferredUIMessage: [ self setSelectionIndex: nextSelection ]. - answer := true ]. - ^ answer.! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3236-reapply-HierarchicalListMorph-change-PhilBellalouna-2017Dec15-21h23m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3236] on 28 December 2017 at 10:50:51 am'! - -Object subclass: #AndreasSystemProfiler - instanceVariableNames: 'semaphore ticks profilerProcess tallyRoot vmStats totalTally totalTime startTime ticksPerMSec totalTicks observedProcess ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Profiling'! - -!classDefinition: #AndreasSystemProfiler category: #'Tools-Profiling'! -Object subclass: #AndreasSystemProfiler - instanceVariableNames: 'semaphore ticks profilerProcess tallyRoot vmStats totalTally totalTime startTime ticksPerMSec totalTicks observedProcess' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Profiling'! -!Time class methodsFor: 'general inquiries' stamp: 'jmv 12/28/2017 09:52:08'! - highResTimerTicksPerMillisecond - " - Time highResTimerTicksPerMillisecond - " - | t0 ticks0 ticks1 ticksPerMSec | - t0 _ Time millisecondClockValue + 2. - [Time millisecondClockValue >= t0] whileFalse. - ticks0 := Time primHighResClock. - [Time millisecondClockValue >= (t0 + 100)] whileFalse. - ticks1 := Time primHighResClock. - ticksPerMSec := (ticks1 - ticks0) - // (Time millisecondClockValue - t0). - "Retry if rollover!!" - ^ ticksPerMSec < 0 - ifTrue: [ self highResTimerTicksPerMillisecond ] - ifFalse: [ ticksPerMSec ]! ! -!AndreasSystemProfiler methodsFor: 'testing' stamp: 'jmv 12/28/2017 07:45:21'! - isProfiling - ^ profilerProcess notNil! ! -!Time class methodsFor: 'primitives' stamp: 'jmv 12/28/2017 09:53:17' prior: 16937554! -primHighResClock - "Primitive. Answer the value of the high resolution clock if this computer has one. - Usually, this should be the highest resolution value available, for example on Intel - it will be the value of the time stamp counter register. - Answer is (at least usually) a LargePositiveInteger. - Implemented on Cog, but not in standard interpreter VMs." - " - Time primHighResClock - On Cog on Linux, OS-X and Windows, this gives sub nano second ticks!! - - Time highResTimerTicksPerMillisecond - " - "Not really a clock, but a timer or ticker" - - - ^0! ! -!SystemDictionary methodsFor: 'AndreasProfiler-profiling' stamp: 'jmv 12/28/2017 09:45:25' prior: 16925386! - profileStart: counter - "Primitive. Begin profiling execution every by using the interrupt check-counter instead of a time-based process (which is limited to timing resolution and triggers off the same signal that many of the processes being profiled trigger off leading to consistently wrong results). - The argument is the number of interrupt checks (method activations) to let go by before taking a sample. The sample is being stored in the profileSample iVar which can be retrieved by executing primitiveProfileSample. When a sample is taken, it signals the semaphore specified in primitiveProfileSemaphore. - If the argument is less or equal to zero, it disables profiling." - "Not an interrupt check-counter, but #primHighResClock" - - ^self primitiveFailed! ! -!QSystemTally methodsFor: 'report' stamp: 'jmv 12/28/2017 10:04:11' prior: 16897464! - printOn: textStream linesOn: linesStream talliesOn: talliesStreams tabs: tabsAndTreeLines total: total totalTime: totalTime parent: parentTally - - | aSelector aClass percentage line | - line _ String streamContents: [ :lineStream | - tabsAndTreeLines do: [ :tabOrLineChar | lineStream nextPutAll: tabOrLineChar ]. - percentage _ tally asFloat / total * 100.0. - percentage printOn: lineStream fractionDigits: 2. - lineStream nextPutAll: '% ('. - percentage * totalTime printOn: lineStream fractionDigits: 1. - lineStream nextPutAll: ' ms) '. - aSelector _ class selectorAtMethod: method setClass: [ :c | aClass _ c]. - blockNesting > 0 ifTrue: [ - lineStream - next: blockNesting put: $[; - next: blockNesting put: $]; - space ]. - lineStream - nextPutAll: class name; - nextPutAll: (aClass == class - ifTrue: ['>>'] - ifFalse: ['(' , aClass name , ')>>']); - nextPutAll: aSelector. - wasInPrimitive ifTrue: [ - self flag: #profilerFriendlyCall:. - parentTally methodSymbol == #profilerFriendlyCall: - ifTrue: [ - lineStream nextPutAll: ' -- primitive (reported properly)' ] - ifFalse: [ - lineStream nextPutAll: ' -- primitive (real sender possibly omitted, see #profilerFriendlyCall:)' ] - ]. - ]. - textStream nextPutAll: line; newLine. - linesStream nextPut: line. - talliesStreams nextPut: self! ! -!AndreasSystemProfiler methodsFor: 'reporting' stamp: 'jmv 12/28/2017 07:52:24' prior: 50378156! - doReport - "Report the results of this profiler run" - | report | - report _ self report. - WorldState addDeferredUIMessage: [ - SystemWindow - editText: (Workspace withText: report) - label: 'Spy Results' - wrap: false ]! ! -!AndreasSystemProfiler methodsFor: 'profiling' stamp: 'jmv 12/28/2017 10:45:37' prior: 16779284! - runProfilerProcess - "Run the profiler process" - - | process tallyStart tallyTicks methodForPrimitiveWhileTakingSample parentNode contextToTally | - totalTally _ 0. - Smalltalk profileSemaphore: semaphore. - totalTicks _ 0. - [ true ] - whileTrue: [ - tallyStart _ Time primHighResClock. - Smalltalk profileStart: ticks. "run for n ticks" - semaphore wait. - tallyTicks _ Time primHighResClock - tallyStart. - "In the extremely unlikely event of high res clock rollover, just ignore this tally" - tallyTicks > 0 ifTrue: [ - totalTicks _ totalTicks + tallyTicks. - process _ Smalltalk profileSample. - methodForPrimitiveWhileTakingSample _ Smalltalk profilePrimitive. - totalTally _ totalTally + 1. - process - ifNotNil: [ - methodForPrimitiveWhileTakingSample - ifNil: [ - tallyRoot - tally: (process suspendedContext ifNil: [ thisContext ]) - inProcess: process - by: tallyTicks. - ] - ifNotNil: [ - "The intention of this code is record which primitive was running when the VM took the sample." - "In Eliot Miranda's words: - AndreasSystemProfiler is more accurate because it uses VM support to tell it which primitive was running when it took a sample. - MessageTally simply ascribes a primitive's cost to the method at the next suspension point, which, in some contexts, - can yield wildly misleading results." - "The problem is that knowing just the primitive and the process doesn't give us the complete call stack. - So, this is, in a sense, approximate." - " - AndreasSystemProfiler spyOn: [ - [ #((1 2 3)) do: [ :each | - each findLast: [ :ea | - ea squared = ea ] ] ] bench ]. - Without asking #sender to the context, for this example - AndreasSystemProfiler spyOn:[10000 timesRepeat: [3.14159 printString]] - gave: - | 2.9% (7 ms) (Number>>#raisedToInteger:) - | 2.2% (5 ms) (Float>>#timesTwoPower: ) - but #raisedToInteger: does NOT send #timesTwoPower: - Approach taken: Add to parent node, but print with a note that specifies this is primitives, and maybe parent node is missing. - Additionally, add a note, suggesting #profilerFriendlyCall: - - For example - AndreasSystemProfiler spyOn:[1000000 timesRepeat: [3.14159 timesTwoPower: 10000]]. - Here, the real parent node is missing. - - AndreasSystemProfiler spyOn:[1000000 timesRepeat: [3.14159 profilerFriendlyTimesTwoPower: 1000]]. - Here, the proper tree is shown. - - See profilerFriendlyCall: - " - contextToTally _ process suspendedContext ifNil: [ thisContext ]. - contextToTally method selector == #profilerFriendlyCall: ifFalse: [ - contextToTally _ contextToTally sender ]. - parentNode _ tallyRoot - tally: contextToTally - inProcess: process - by: tallyTicks. - parentNode - tallyPrimInMethod: methodForPrimitiveWhileTakingSample by: tallyTicks - ]]]]! ! -!AndreasSystemProfiler methodsFor: 'profiling' stamp: 'jmv 12/28/2017 10:23:54' prior: 16779396! - startProfiling - "Start the profiler process taking samplesPerMsec samples per *milli* second" - semaphore _ Semaphore new. - "Try to get 10 samples per msec... Not really sure how this parameter is used, nor the meaning and relevance of #interruptChecksPerMSec" - "ticks _ Time highResTimerTicksPerMillisecond // Smalltalk interruptChecksPerMSec." - ticks _ Time highResTimerTicksPerMillisecond // 10. - vmStats _ Smalltalk getVMParameters. - startTime _ Time localMillisecondClock. - profilerProcess := [self runProfilerProcess] newProcess. - tallyRoot process: nil. - profilerProcess priority: Processor timingPriority-1. - profilerProcess name: 'AndreasSystemProfiler'. - profilerProcess resume! ! -!AndreasSystemProfiler methodsFor: 'profiling' stamp: 'jmv 12/28/2017 07:47:24' prior: 16779425! - stopProfiling - "Stop the profiler process" - Smalltalk profileSemaphore: nil. - Smalltalk profileStart: 0. "<- profile stops now" - totalTime _ Time localMillisecondClock - startTime. - Smalltalk getVMParameters keysAndValuesDo: [ :idx :value | - value isNumber ifTrue: [ - vmStats at: idx put: (value - (vmStats at: idx)) ]]. - profilerProcess ifNotNil: [ - profilerProcess terminate. - profilerProcess _ nil ]! ! -!AndreasSystemProfiler class methodsFor: 'spying' stamp: 'jmv 12/28/2017 07:51:36' prior: 16779565! -spyOn: aBlock includeAllProcesses: aBoolean - " - Spy on aBlock, in the current process. Can include or not statistics on other processes in the report. - [1000 timesRepeat: [ - 100 timesRepeat: [120 factorial]. - (Delay forMilliseconds: 10) wait - ]] forkAt: 45 named: '45'. - AndreasSystemProfiler spyOn: [10000 timesRepeat: [1.23 printString]] includeAllProcesses: true - " - | profiler | - self allInstancesDo: [ :p | - p isProfiling ifTrue: [ - ^ self inform: 'Must first wait for running profiler, or kill it in Process Browser' ]]. - profiler _ self new. - profiler observedProcess: (aBoolean ifFalse: [Processor activeProcess]). - [ ^ profiler spyOn: aBlock] ensure: [ profiler doReport ]. -! ! - -Object subclass: #AndreasSystemProfiler - instanceVariableNames: 'semaphore ticks profilerProcess tallyRoot vmStats totalTally totalTime startTime totalTicks observedProcess' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Profiling'! - -!classDefinition: #AndreasSystemProfiler category: #'Tools-Profiling'! -Object subclass: #AndreasSystemProfiler - instanceVariableNames: 'semaphore ticks profilerProcess tallyRoot vmStats totalTally totalTime startTime totalTicks observedProcess' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Profiling'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3237-ProfilerFixes-JuanVuletich-2017Dec28-10h41m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3237] on 28 December 2017 at 12:21:11 pm'! -!AndreasSystemProfiler methodsFor: 'reporting' stamp: 'jmv 12/28/2017 12:20:41' prior: 50378386! - doReport - "Report the results of this profiler run" - | report | - report _ self report. - self runningWorld addDeferredUIMessage: [ - SystemWindow - editText: (Workspace withText: report) - label: 'Spy Results' - wrap: false ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3238-MergeWith3235-JuanVuletich-2017Dec28-12h20m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3237] on 28 December 2017 at 2:26:10 pm'! - -Smalltalk renameClassNamed: #ProjectX as: #UISupervisor! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jmv 12/28/2017 14:25:52' prior: 50377349! - privateMorphicTopLevelRendererClass - "The class controlling the outermost rendering process for Morphic and other critical methods for handling interrupts. Dangerous to change as any bugs will effectively crash the UI for the entire image. - - Using 'private' prefix to reflect the danger even though it will likely be called externally." - ^ UISupervisor! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3239-UISupervisor-JuanVuletich-2017Dec28-14h25m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3239] on 28 December 2017 at 3:15:30 pm'! -!UISupervisor commentStamp: '' prior: 0! - UISupervisor is an interface to User Interface services not tied to any specific GUI. There could even be no GUI. -All state and behavior is on the class side! -!Debugger class methodsFor: 'opening' stamp: 'jmv 12/28/2017 15:02:53'! - interruptProcess: aProcess label: labelString - "Create a Notifier on aProcess with the given label." - | label | - - label _ labelString, - ' - Process: ', aProcess name, - ' - Priority: ', aProcess priority printString. - aProcess isTerminated - ifTrue: [ - UISupervisor newProcessIfUI: aProcess. - self notify: 'Can not debug a terminated process: ', label ] - ifFalse: [ - aProcess suspend. - self - openInterrupt: label - onProcess: aProcess ]! ! -!UISupervisor class methodsFor: 'gui process' stamp: 'jmv 12/28/2017 14:50:40'! - newProcessIfUI: suspendedProcess - "Answer the UI we created a new process for" - - suspendedProcess animatedUI ifNotNil: [ :guiRootObject | - self spawnNewMorphicProcessFor: guiRootObject. - ^guiRootObject ]. - ^nil! ! -!UISupervisor class methodsFor: 'gui process' stamp: 'jmv 12/28/2017 15:04:16'! - userInterrupt - "Create a Notifier on the active scheduling process with the given label." - | preemptedProcess | - preemptedProcess _ Processor preemptedProcess. - - "Only debug preempted process if its priority is >= UIProcess' priority" - preemptedProcess priority < UIProcess priority ifTrue: [ - preemptedProcess _ UIProcess ]. - - Debugger interruptProcess: preemptedProcess label: 'User Interrupt'! ! -!PasteUpMorph methodsFor: 'interaction loop' stamp: 'jmv 12/28/2017 14:38:23'! -mainLoop - - - self clearWaitDelay. - self clearCanvas. - [ - self doOneCycle. - Processor yield. - true ] - whileTrue: []! ! -!PasteUpMorph methodsFor: 'interaction loop' stamp: 'jmv 12/28/2017 14:40:22'! - runProcess - | process | - process _ [ self mainLoop ] - newProcess. - process - priority: Processor userSchedulingPriority; - name: 'Morphic UI'; - animatedUI: self. - ^ process! ! -!Debugger methodsFor: 'initialization' stamp: 'jmv 12/28/2017 14:43:57' prior: 50377375! - openFullNoSuspendLabel: aString - "Create and schedule a full debugger with the given label. Do not terminate the current active process." - - self openFullMorphicLabel: aString. - interruptedProcessUI _ UISupervisor newProcessIfUI: interruptedProcess! ! -!Debugger methodsFor: 'initialization' stamp: 'jmv 12/28/2017 14:44:04' prior: 50377387! - openNotifierContents: msgString label: label - "Create and schedule a notifier view with the given label and message. A notifier view shows just the message or the first several lines of the stack, with a menu that allows the user to open a full debugger if so desired." - "NOTE: When this method returns, a new process has been scheduled to run the windows, and thus this notifier, but the previous active porcess has not been suspended. The sender will do this." - | msg | - Sensor flushKeyboard. - savedCursor _ Cursor currentCursor. - Cursor normal activateCursor. - msg _ (label beginsWith: 'Space is low') - ifTrue: [ self lowSpaceChoices, (msgString ifNil: ['']) ] - ifFalse: [ msgString ]. - - interruptedProcessUI _ UISupervisor newProcessIfUI: interruptedProcess. - WorldState addDeferredUIMessage: [ - PreDebugWindow open: self label: label message: msg ]. - ^self! ! -!Debugger class methodsFor: 'opening' stamp: 'jmv 12/28/2017 14:44:13' prior: 50377418! - openOn: process context: context label: title fullView: bool - "Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger." - | w | - Preferences logDebuggerStackToFile ifTrue: [ - Smalltalk - logError: title - inContext: context - to: 'CuisDebug' ]. - w := UISupervisor newProcessIfUI: process. - "schedule debugger in deferred UI message to address redraw - problems after opening a debugger e.g. from the testrunner." - WorldState addDeferredUIMessage: [ - [ | debugger | - "In case an error in Morphic code got us here, ensure mouse focus has been released" - true runningWorld ifNotNil: [ :rWorld | - rWorld activeHand ifNotNil: [ :aHand | - aHand releaseMouseFocus ]]. - debugger := self new - process: process - context: context. - debugger interruptedProcessUI: w. - bool - ifTrue: [ debugger openFullMorphicLabel: title ] - ifFalse: [ - PreDebugWindow - open: debugger - label: title - message: nil ]] - on: UnhandledError - do: [ :exOuter | | errorDescription | - errorDescription := 'Error while trying to open Debugger' , String newLineString , 'Orginal error: ' , title asString , '.' , String newLineString , ' Debugger error: ' , - ([ exOuter description ] - on: UnhandledError - do: [ :exInner | - exInner return: 'a ' , exInner class printString ]) , ':'. - self primitiveError: errorDescription ]]. - process suspend.! ! -!SystemDictionary methodsFor: 'memory space' stamp: 'jmv 12/28/2017 15:00:19' prior: 50377469! - lowSpaceWatcher - "Wait until the low space semaphore is signalled, then take appropriate actions." - - self garbageCollectMost <= self lowSpaceThreshold ifTrue: [ - self garbageCollect <= self lowSpaceThreshold ifTrue: [ - "free space must be above threshold before starting low space watcher" - ^ Smalltalk primitiveBeep ]]. - - LowSpaceSemaphore _ Semaphore new. - self primLowSpaceSemaphore: LowSpaceSemaphore. - self primSignalAtBytesLeft: self lowSpaceThreshold. "enable low space interrupts" - - LowSpaceSemaphore wait. "wait for a low space condition..." - - self primSignalAtBytesLeft: 0. "disable low space interrupts" - self primLowSpaceSemaphore: nil. - LowSpaceProcess _ nil. - "Note: user now unprotected until the low space watcher is re-installed" - - Debugger interruptProcess: Processor preemptedProcess label: 'Space is low'! ! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jmv 12/28/2017 15:04:08' prior: 50377499! - handleUserInterrupt - Preferences cmdDotEnabled ifTrue: [ - [ UISupervisor userInterrupt ] fork]! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 12/28/2017 14:48:02' prior: 50377742! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag -"WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " -| activeProc | -activeProc _ Processor activeProcess. -[ - | isARealStartup guiRootObject reopenTranscript | - self logSnapshot: save andQuit: quit. - - reopenTranscript _ false. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | each isInWorld ifTrue: [ each delete. reopenTranscript _ true ]]. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - - - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - - "Cosas que levanto explicitamente abajo" - guiRootObject _ UISupervisor ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "guiRootObject _ clearAllStateFlag ifFalse: [ UISupervisor ui ]." - UISupervisor stopUIProcess. - activeProc isTerminated ifFalse: [ - activeProc terminate ]. - - "Clean Globals" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: nil. - Smalltalk closeSourceFiles. Smalltalk at: #SourceFiles put: nil. - Smalltalk allClassesDo: [ :cls | cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ Smalltalk printStuffToCleanOnImageSave ]. - - - "Do image save & quit as apropriate" - Cursor write activateCursor. - save - ifTrue: [ - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - - - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: (DisplayScreen extent: `1024@768` depth: 32). - Smalltalk at: #SourceFiles put: (Array new: 2). - Smalltalk openSourceFiles. - - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - - UISupervisor spawnNewMorphicProcessFor: (guiRootObject ifNil: [ guiRootObject _ self privateMorphicWorldClass newWorld ]). - - reopenTranscript ifTrue: [ - guiRootObject addDeferredUIMessage: [ - TranscriptWindow openTranscript ]]. - " - world addDeferredUIMessage: [ - world fullRepaintNeeded ]. - " - - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - guiRootObject addDeferredUIMessage: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]. - -] forkAt: Processor timingPriority-1 named: 'Startup process'.! ! -!UISupervisor class methodsFor: 'gui process' stamp: 'jmv 12/28/2017 14:50:33' prior: 16896377! - spawnNewMorphicProcessFor: guiRootObject - - UIProcess ifNotNil: [ UIProcess animatedUI: nil ]. - UIProcess _ guiRootObject runProcess. - UIProcess resume! ! -!UISupervisor class methodsFor: 'gui process' stamp: 'jmv 12/28/2017 15:10:48' prior: 16896390! - stopUIProcess - UIProcess ifNotNil: [ - UIProcess animatedUI: nil. - UIProcess terminate ]. - UIProcess _ nil! ! -!UISupervisor class methodsFor: 'gui process' stamp: 'jmv 12/28/2017 15:09:33' prior: 16896397! - ui - ^UIProcess animatedUI! ! - -UISupervisor class removeSelector: #currentInterruptNameX:! - -UISupervisor class removeSelector: #currentInterruptNameX:! - -UISupervisor class removeSelector: #interruptNameX:! - -UISupervisor class removeSelector: #interruptNameX:! - -UISupervisor class removeSelector: #newProcessIfUIX:! - -UISupervisor class removeSelector: #newProcessIfUIX:! - -SystemDictionary removeSelector: #privateMorphicTopLevelRendererClass! - -SystemDictionary removeSelector: #privateMorphicTopLevelRendererClass! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3240-UISupervisor-cleanup-JuanVuletich-2017Dec28-15h06m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3239] on 28 December 2017 at 3:20:41 pm'! -!SystemDictionary methodsFor: 'shrinking' stamp: 'jmv 4/25/2016 15:31' prior: 50377507! - reduceCuis - " - Smalltalk reduceCuis - " - | keep n unused newDicts oldDicts | - - self nominallyUnsent: #reduceCuis. - - "Remove icons" - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - PasteUpMorph allInstancesDo: [ :w | - w backgroundImageData: nil. - w submorphsDo: [ :a | a delete ]]. - Preferences useNoIcons. - Theme current initialize. - Theme content: nil. - Color shutDown. - BitBltCanvas releaseClassCachedState. - - Transcript clear. - Clipboard default initialize. - - - "Remove some methods, even if they have senders." -" ColorPickerMorph class removeSelector: #buildEyedropperIcon." - Theme removeSelector: #miscellaneousIcons. - Utilities removeSelector: #vmStatisticsReportString. - SystemDictionary removeSelector: #recreateSpecialObjectsArray. - - StrikeFont removeMostFonts. - StrikeFont saveSpace. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - - keep := OrderedCollection new. - keep addAll: #(SpaceTally). - AppLauncher appGlobalName ifNotNil: [ :any | - keep add: any ]. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - [ - #hereWeGo print. - unused do: [:c | - c print. - (Smalltalk at: c) removeFromSystem]. - n := Smalltalk removeAllUnSentMessages. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - n > 0 or: [ - unused notEmpty ]] whileTrue. - ChangeSet zapAllChangeSets. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - Symbol rehash. - - "Shrink method dictionaries." - Smalltalk garbageCollect. - oldDicts _ MethodDictionary allInstances. - newDicts _ Array new: oldDicts size. - oldDicts withIndexDo: [:d :index | - newDicts at: index put: d rehashWithoutBecome ]. - oldDicts elementsExchangeIdentityWith: newDicts. - oldDicts _ newDicts _ nil. - - SmalltalkCompleter initialize . - - "Sanity checks" -" Undeclared - Smalltalk cleanOutUndeclared - Smalltalk browseUndeclaredReferences - Smalltalk obsoleteClasses - Smalltalk obsoleteBehaviors - Smalltalk browseObsoleteMethodReferences - SmalltalkImage current fixObsoleteReferences - Smalltalk browseAllUnimplementedCalls"! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 12/28/2017 15:19:25' prior: 50378822! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag -"WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " -| activeProc | -activeProc _ Processor activeProcess. -[ - | isARealStartup guiRootObject guiRootObjectClass reopenTranscript | - self logSnapshot: save andQuit: quit. - - reopenTranscript _ false. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | each isInWorld ifTrue: [ each delete. reopenTranscript _ true ]]. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - - - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - - "Cosas que levanto explicitamente abajo" - guiRootObjectClass _ UISupervisor ui class. - guiRootObject _ UISupervisor ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "guiRootObject _ clearAllStateFlag ifFalse: [ UISupervisor ui ]." - UISupervisor stopUIProcess. - activeProc isTerminated ifFalse: [ - activeProc terminate ]. - - "Clean Globals" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: nil. - Smalltalk closeSourceFiles. Smalltalk at: #SourceFiles put: nil. - Smalltalk allClassesDo: [ :cls | cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ Smalltalk printStuffToCleanOnImageSave ]. - - - "Do image save & quit as apropriate" - Cursor write activateCursor. - save - ifTrue: [ - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - - - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: (DisplayScreen extent: `1024@768` depth: 32). - Smalltalk at: #SourceFiles put: (Array new: 2). - Smalltalk openSourceFiles. - - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - - UISupervisor spawnNewMorphicProcessFor: (guiRootObject ifNil: [ guiRootObject _ guiRootObjectClass newWorld ]). - - reopenTranscript ifTrue: [ - guiRootObject addDeferredUIMessage: [ - TranscriptWindow openTranscript ]]. - " - world addDeferredUIMessage: [ - world fullRepaintNeeded ]. - " - - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - guiRootObject addDeferredUIMessage: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]. - -] forkAt: Processor timingPriority-1 named: 'Startup process'.! ! -!PasteUpMorph class methodsFor: 'instance creation' stamp: 'jmv 12/28/2017 15:19:42' prior: 50362770! - newWorld - " -[ - UISupervisor stopUIProcess. - UISupervisor spawnNewMorphicProcessFor: PasteUpMorph newWorld -] fork. - " - | w ws | - w _ self new. - ws _ WorldState new. - w worldState: ws. - w morphPosition: `0@0` extent: Display extent. - ws setCanvas: Display getCanvas. - w borderWidth: 0. - ws handsDo: [ :h | - h privateOwner: w ]. - ^w! ! - -SystemDictionary removeSelector: #privateMorphicWorldClass! - -SystemDictionary removeSelector: #privateMorphicWorldClass! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3241-dontAskForWorldClass-JuanVuletich-2017Dec28-15h15m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3239] on 28 December 2017 at 3:45:45 pm'! -!BlockClosure commentStamp: 'jmv 12/28/2017 15:42:10' prior: 16787685! - I am a block closure for Eliot's closure implementation. Not to be confused with the old BlockClosure (they were never part of Cuis anyway). - -This is a closure converted image. With full closure support, you can finally use recursive blocks like here: - -| fac | - fac := [:n| n > 1 ifTrue:[n * (fac value: n-1)] ifFalse:[1]]. - fac value: 5. "120" - -and close over temps correctly, such as here: - - (1 to: 10) do:[:i| UISupervisor whenUIinSafeState:[Transcript newLine; show: i]]. - -Another good example: - -| fib | -fib := [:n| n < 2 ifTrue:[1] ifFalse:[(fib value:n-1) + (fib value:n-2)]]. -fib value: 10. "89"! -!UISupervisor class methodsFor: 'services' stamp: 'jmv 12/28/2017 15:36:24'! - restoreDisplay - DisplayScreen startUp. - self ui ifNotNil: [ :guiRootObject | - guiRootObject restoreDisplay ]. - UISupervisor whenUIinSafeState: [ Cursor normal activateCursor ]! ! -!UISupervisor class methodsFor: 'services' stamp: 'jmv 12/28/2017 15:29:34'! - whenUIinSafeState: evaluableObject - "If there is an UI present, evaluate argument when such UI is in a safe state. - If not, just evaluate the argument right now." - self ui - ifNotNil: [ :guiRootObject | guiRootObject whenUIinSafeState: evaluableObject ] - ifNil: evaluableObject! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 12/28/2017 15:36:22'! - restoreDisplay - self - morphExtent: Display extent; - handsDo: [ :h | h visible: true ]; - fullRepaintNeeded! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 12/28/2017 15:30:26'! - whenUIinSafeState: evaluableObject - "Please call - UISupervisor whenUIinSafeState: evaluableObject - " - WorldState addDeferredUIMessage: evaluableObject ! ! -!Debugger methodsFor: 'initialization' stamp: 'jmv 12/28/2017 15:31:17' prior: 50378705! - openNotifierContents: msgString label: label - "Create and schedule a notifier view with the given label and message. A notifier view shows just the message or the first several lines of the stack, with a menu that allows the user to open a full debugger if so desired." - "NOTE: When this method returns, a new process has been scheduled to run the windows, and thus this notifier, but the previous active porcess has not been suspended. The sender will do this." - | msg | - Sensor flushKeyboard. - savedCursor _ Cursor currentCursor. - Cursor normal activateCursor. - msg _ (label beginsWith: 'Space is low') - ifTrue: [ self lowSpaceChoices, (msgString ifNil: ['']) ] - ifFalse: [ msgString ]. - - interruptedProcessUI _ UISupervisor newProcessIfUI: interruptedProcess. - UISupervisor whenUIinSafeState: [ - PreDebugWindow open: self label: label message: msg ]. - ^self! ! -!Debugger class methodsFor: 'opening' stamp: 'jmv 12/28/2017 15:31:22' prior: 50378735! - openOn: process context: context label: title fullView: bool - "Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger." - | w | - Preferences logDebuggerStackToFile ifTrue: [ - Smalltalk - logError: title - inContext: context - to: 'CuisDebug' ]. - w := UISupervisor newProcessIfUI: process. - "schedule debugger in deferred UI message to address redraw - problems after opening a debugger e.g. from the testrunner." - UISupervisor whenUIinSafeState: [ - [ | debugger | - "In case an error in Morphic code got us here, ensure mouse focus has been released" - true runningWorld ifNotNil: [ :rWorld | - rWorld activeHand ifNotNil: [ :aHand | - aHand releaseMouseFocus ]]. - debugger := self new - process: process - context: context. - debugger interruptedProcessUI: w. - bool - ifTrue: [ debugger openFullMorphicLabel: title ] - ifFalse: [ - PreDebugWindow - open: debugger - label: title - message: nil ]] - on: UnhandledError - do: [ :exOuter | | errorDescription | - errorDescription := 'Error while trying to open Debugger' , String newLineString , 'Orginal error: ' , title asString , '.' , String newLineString , ' Debugger error: ' , - ([ exOuter description ] - on: UnhandledError - do: [ :exInner | - exInner return: 'a ' , exInner class printString ]) , ':'. - self primitiveError: errorDescription ]]. - process suspend.! ! -!TestRunner methodsFor: 'processing' stamp: 'jmv 12/28/2017 15:41:46' prior: 16928246! - runSuite: suite - running ifNotNil: [ ^self inform: 'already running' ]. - suite addDependent: self. - totalTests _ suite tests size. - completedTests _ 0. - running _ [ - [ result _ suite run ] - ensure: [ - running _ nil. - suite removeDependent: self. - runSemaphore signal. - UISupervisor whenUIinSafeState: [ - self updateWindow: result. - self changed: #runTests. - self changed: #runOneTest. - ]. - ]. - ] newProcess. - self runWindow. - self changed: #runTests. - self changed: #runOneTest. - running - name: 'TestRunner'; -" priority: Processor userBackgroundPriority;" - resume. -! ! -!TestRunner methodsFor: 'processing' stamp: 'jmv 12/28/2017 15:41:57' prior: 16928270! - runSuiteProfiled: suite - running ifNotNil: [ ^self inform: 'already running' ]. - suite addDependent: self. - totalTests _ suite tests size. - completedTests _ 0. - running _ [ - [ result _ MessageTally spyOn: [suite run] ] - ensure: [ - running _ nil. - suite removeDependent: self. - runSemaphore signal. - UISupervisor whenUIinSafeState: [ - self updateWindow: result. - self changed: #runTests. - self changed: #runOneTest. - ]. - ]. - ] newProcess. - self runWindow. - self changed: #runTests. - self changed: #runOneTest. - running - name: 'TestRunner'; -" priority: Processor userBackgroundPriority;" - resume. -! ! -!TestRunner methodsFor: 'updating' stamp: 'jmv 12/28/2017 15:41:51' prior: 16928371! - update: aParameter - "updates come in from another thread" - (aParameter is: #TestCase) - ifTrue: [ - UISupervisor whenUIinSafeState: [ - completedTests _ completedTests + 1. - progressLabel _ aParameter printString. - self changed: #progress ]] - ifFalse: [ super update: aParameter ]! ! -!CPUWatcher methodsFor: 'porcine capture' stamp: 'jmv 12/28/2017 15:31:10' prior: 16795052! - openWindowForSuspendedProcess: aProcess - - UISupervisor whenUIinSafeState: [self openMorphicWindowForSuspendedProcess: aProcess]! ! -!ProcessBrowser class methodsFor: 'CPU utilization' stamp: 'jmv 12/28/2017 15:42:34' prior: 16895203! - dumpPigStackOn: aStream - "Must run forked on its own process, so the monitored behavior is not affected too much" - - | promise tally process depth stack suspendedContext | - promise := Processor tallyCPUUsageFor: 1 every: 10. - tally := promise value. - "UISupervisor whenUIinSafeState: [self dumpTallyOnTranscript: tally]." - aStream nextPutAll: '====Al processes===='; newLine. - self dumpTally: tally on: aStream. - aStream newLine; nextPutAll: '====Process using most CPU===='; newLine. - process _ tally sortedCounts first value. - (100.0 * (tally occurrencesOf: process) / tally size) rounded printOn: aStream. - aStream - nextPutAll: ' % '; - nextPutAll: (process browserPrintStringFull: false); - newLine. - depth _ 20. - stack _ process == Processor activeProcess - ifTrue: [thisContext stackOfSize: depth] - ifFalse: [suspendedContext _ process suspendedContext. - suspendedContext - ifNotNil: [suspendedContext stackOfSize: depth]]. - stack - ifNil: [ aStream nextPutAll: 'No context'; newLine] - ifNotNil: [ - stack do: [ :c | - c printOn: aStream. - aStream newLine ]]! ! -!MessageTally class methodsFor: 'spying' stamp: 'jmv 12/28/2017 15:31:52' prior: 16870883! - tallySendsTo: receiver inBlock: aBlock - " - MessageTally tallySends: [3.14159 printString] - " - "This method uses the simulator to count the number of calls on each method - invoked in evaluating aBlock. If receiver is not nil, then only sends - to that receiver are tallied. - Results are presented as leaves, sorted by frequency, - preceded, optionally, by the whole tree." - | prev tallies startTime totalTime | - startTime _ Time localMillisecondClock. - tallies _ self new class: aBlock receiver class method: aBlock method. - prev _ aBlock. - thisContext sender - runSimulated: aBlock - contextAtEachStep: [ :current | - current == prev ifFalse: [ "call or return" - prev sender ifNotNil: [ "call only" - (receiver == nil or: [ current receiver == receiver ]) - ifTrue: [ tallies tally: current by: 1 ]]. - prev _ current]]. - - totalTime _ Time localMillisecondClock - startTime / 1000.0. - UISupervisor whenUIinSafeState: [ - SystemWindow - editText: (Workspace withText: (String streamContents: [ :s | - s - nextPutAll: 'This simulation took '; - nextPutAll: totalTime printString; - nextPutAll: ' seconds.'; - newLine. - tallies fullPrintExactOn: s ])) - label: 'Spy Results' - wrap: false ]! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 12/28/2017 15:42:48' prior: 50379053! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag -"WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " -| activeProc | -activeProc _ Processor activeProcess. -[ - | isARealStartup guiRootObject guiRootObjectClass reopenTranscript | - self logSnapshot: save andQuit: quit. - - reopenTranscript _ false. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | each isInWorld ifTrue: [ each delete. reopenTranscript _ true ]]. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - - - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - - "Cosas que levanto explicitamente abajo" - guiRootObjectClass _ UISupervisor ui class. - guiRootObject _ UISupervisor ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "guiRootObject _ clearAllStateFlag ifFalse: [ UISupervisor ui ]." - UISupervisor stopUIProcess. - activeProc isTerminated ifFalse: [ - activeProc terminate ]. - - "Clean Globals" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: nil. - Smalltalk closeSourceFiles. Smalltalk at: #SourceFiles put: nil. - Smalltalk allClassesDo: [ :cls | cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ Smalltalk printStuffToCleanOnImageSave ]. - - - "Do image save & quit as apropriate" - Cursor write activateCursor. - save - ifTrue: [ - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - - - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: (DisplayScreen extent: `1024@768` depth: 32). - Smalltalk at: #SourceFiles put: (Array new: 2). - Smalltalk openSourceFiles. - - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - - UISupervisor spawnNewMorphicProcessFor: (guiRootObject ifNil: [ guiRootObject _ guiRootObjectClass newWorld ]). - - reopenTranscript ifTrue: [ - UISupervisor whenUIinSafeState: [ - TranscriptWindow openTranscript ]]. - " - UISupervisor whenUIinSafeState: [ - guiRootObject fullRepaintNeeded ]. - " - - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - UISupervisor whenUIinSafeState: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]. - -] forkAt: Processor timingPriority-1 named: 'Startup process'.! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'jmv 12/28/2017 15:40:12' prior: 50369773! - restoreLostChangesIfNecessary - - " - Smalltalk restoreLostChangesIfNecessary - " - - self hasToRestoreChanges ifTrue: [ UISupervisor whenUIinSafeState: [self restoreLostChanges ]]. -! ! -!UISupervisor class methodsFor: 'gui process' stamp: 'jmv 12/28/2017 15:26:47' prior: 50378955! - ui - ^UIProcess ifNotNil: [ UIProcess animatedUI ]! ! -!UISupervisor class methodsFor: 'gui process' stamp: 'jmv 12/28/2017 15:27:03' prior: 50378663! - userInterrupt - "Create a Notifier on the active scheduling process with the given label." - | preemptedProcess | - preemptedProcess _ Processor preemptedProcess. - - "Only debug preempted process if its priority is >= UIProcess' priority" - UIProcess ifNotNil: [ - preemptedProcess priority < UIProcess priority ifTrue: [ - preemptedProcess _ UIProcess ]]. - - Debugger interruptProcess: preemptedProcess label: 'User Interrupt'! ! -!DisplayScreen methodsFor: 'other' stamp: 'jmv 12/28/2017 15:22:40' prior: 16835232! -newDepth: pixelSize -" - Display newDepth: 8. - Display newDepth: 1. -" - (self supportsDisplayDepth: pixelSize) - ifFalse: [ ^self inform:'Display depth ', pixelSize printString, ' is not supported on this system' ]. - self newDepthNoRestore: pixelSize. - self runningWorld ifNotNil: [ :w | w buildMagnifiedBackgroundImage ]. - self restore.! ! -!DisplayScreen class methodsFor: 'display box access' stamp: 'jmv 12/28/2017 15:37:02' prior: 16835493! - checkForNewScreenSize - "Check whether the screen size has changed and if so take appropriate actions" - - Display extent = DisplayScreen actualScreenSize ifTrue: [^ self]. - UISupervisor restoreDisplay! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 12/28/2017 15:33:32' prior: 50377861! - showBalloon: msgString hand: aHand - "Pop up a balloon containing the given string, - first removing any existing BalloonMorphs in the world." - - | w balloon h | - (w _ self world) ifNil: [^ self]. - h _ aHand. - h ifNil:[ - h _ w activeHand]. - balloon _ HoverHelpMorph contents: msgString. - - "Do it in a while. In some cases, processing the event that might have triggered us might also remove any Help Balloon" - UISupervisor whenUIinSafeState: [ - balloon popUpForHand: h ]! ! -!Morph methodsFor: 'initialization' stamp: 'jmv 12/28/2017 15:32:34' prior: 16875939! - openInWorld - - self runningWorld - ifNil: [ UISupervisor whenUIinSafeState: [ self openInWorld ]] - ifNotNil: [ :w | self openInWorld: w ]! ! -!PasteUpMorph class methodsFor: 'system startup' stamp: 'jmv 12/28/2017 15:37:37' prior: 16887941! - initClassCachedState - - "Should use some other way to find relevant instances" - self flag: #jmvVer2. - self allInstancesDo: [ :each | - each buildMagnifiedBackgroundImage. - each isWorldMorph ifTrue: [ - each restoreDisplay ]]. - Cursor normal activateCursor! ! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 12/28/2017 15:31:28' prior: 50378174! - arrowKey: aChar - "Handle a keyboard navigation character. Answer true if handled, false if not." - | keyEvent answer nextSelection oldSelection | - answer := false. - keyEvent := aChar numericValue. - oldSelection := self getSelectionIndex. - nextSelection := oldSelection. - keyEvent = 31 ifTrue: [ - "down" - nextSelection := oldSelection + 1. - nextSelection > self maximumSelection ifTrue: [ nextSelection := self minimumSelection ]]. - keyEvent = 30 ifTrue: [ - "up" - nextSelection := oldSelection - 1. - nextSelection < self minimumSelection ifTrue: [ nextSelection := self maximumSelection ]]. - keyEvent = 1 ifTrue: [ "home" - nextSelection := 1 ]. - keyEvent = 4 ifTrue: [ "end" - nextSelection := scroller submorphs size ]. - keyEvent = 11 ifTrue: [ "page up" - nextSelection := oldSelection - self numSelectionsInView max: 1 ]. - keyEvent = 12 ifTrue: [ "page down" - nextSelection := oldSelection + self numSelectionsInView ]. - keyEvent = 29 ifTrue: [ - "right" - selectedMorph ifNotNil: [ - (selectedMorph canExpand and: [ selectedMorph isExpanded not ]) - ifTrue: [ - self toggleExpandedState: selectedMorph. - self scrollSelectionIntoView. - answer := true ] - ifFalse: [ nextSelection := oldSelection + 1 ]]]. - keyEvent = 28 ifTrue: [ - "left" - selectedMorph ifNotNil: [ - selectedMorph isExpanded - ifTrue: [ - self toggleExpandedState: selectedMorph. - self scrollSelectionIntoView. - answer := true ] - ifFalse: [ - oldSelection > self minimumSelection ifTrue: [ - nextSelection _ (oldSelection-1 to: 1 by: -1) detect: [ :i | ( scroller submorphs at: i) indentLevel < selectedMorph indentLevel ]]. - ]]]. - nextSelection = oldSelection ifFalse: [ - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self highlightedMorph: (self listMorphAt: nextSelection). - "Update the model in next world cycle, so user gets the immediate feedback." - UISupervisor whenUIinSafeState: [ self setSelectionIndex: nextSelection ]. - answer := true ]. - ^ answer.! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 12/28/2017 15:39:41' prior: 50377950! - arrowKey: aChar - "Process the up and down arrows in a list pane. Note that the listView tells us what index variable, how to get the list, and how to move the index." - | keyEvent oldSelection nextSelection max min howMany answer w | - answer _ false. - keyEvent _ aChar numericValue. - oldSelection _ self getCurrentSelectionIndex. - nextSelection _ oldSelection. - max _ self maximumSelection. - min _ self minimumSelection. - howMany _ self numSelectionsInView. "get this exactly??" - - keyEvent = 31 ifTrue: [ - "down-arrow; move down one, wrapping to top if needed" - nextSelection _ oldSelection + 1. - nextSelection > max ifTrue: [ nextSelection _ 1 ]]. - - keyEvent = 30 ifTrue: [ - "up arrow; move up one, wrapping to bottom if needed" - nextSelection _ oldSelection - 1. - nextSelection < 1 ifTrue: [ nextSelection _ max ]]. - - keyEvent = 1 ifTrue: [ nextSelection _ 1 ]. "home" - keyEvent = 4 ifTrue: [ nextSelection _ max ]. "end" - keyEvent = 11 ifTrue: [ nextSelection _ min max: oldSelection - howMany ]. "page up" - keyEvent = 12 ifTrue: [ nextSelection _ oldSelection + howMany min: max ]. "page down" - nextSelection = oldSelection ifFalse: [ - w _ self owningWindow. - (w isNil or: [ w okToChange ]) ifTrue: [ "No change if model is locked" - - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self listMorph highlightedRow: nextSelection. - - "Update the model in next world cycle, so user gets the immediate feedback." - UISupervisor whenUIinSafeState: [ - self changeModelSelection: nextSelection ]. - answer _ true ]]. - ^answer! ! -!PluggableListMorphOfMany methodsFor: 'events' stamp: 'jmv 12/28/2017 15:39:45' prior: 50378004! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - - | oldIndex oldVal row w | - self hasKeyboardFocus ifFalse: [ - aMouseButtonEvent hand newKeyboardFocus: self ]. - - row _ self rowAtLocation: localEventPosition. - - row = 0 ifTrue: [ - ^super mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition ]. - - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self listMorph highlightedRow: row. - - w _ self owningWindow. - (w isNil or: [ w okToChange ]) ifTrue: [ "No change if model is locked" - - "Set meaning for subsequent dragging of selection" - dragOnOrOff _ (self listSelectionAt: row) not. - dragStartRow _ row. - oldIndex _ self getCurrentSelectionIndex. - oldIndex ~= 0 ifTrue: [oldVal _ self listSelectionAt: oldIndex]. - - "Different from PluggableListMorph. There, we highlight on mouse down, and act on mouse up. - Here, we act on mouse down, because we support dragging of selection, so mouse up will - only happen after user is finished dragging. In order to get the highlight visible for the user, - update the model on next world cycle." - UISupervisor whenUIinSafeState: [ - "Set or clear new primary selection (listIndex)" - dragOnOrOff - ifTrue: [self changeModelSelection: row] - ifFalse: [self changeModelSelection: 0]. - "Need to restore the old one, due to how model works, and set new one." - oldIndex ~= 0 ifTrue: [self listSelectionAt: oldIndex put: oldVal]. - self listSelectionAt: row put: dragOnOrOff ]. - ]. - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: nil - clkNHalf: nil - dblClkSel: #doubleClick:localPosition: - dblClkNHalfSel: nil - tripleClkSel: nil! ! -!SystemWindow methodsFor: 'open/close' stamp: 'jmv 12/28/2017 15:41:35' prior: 50378062! - openInWorld: aWorld - "This msg and its callees result in the window being activeOnlyOnTop" - | frameRect | - frameRect _ self initialFrameIn: aWorld. - self morphExtent: frameRect extent. - aWorld addMorph: self position: frameRect topLeft. - "Do it deferred. Was needed for text cursor to start blinking if (Preferences disable: #focusFollowsMouse) " - UISupervisor whenUIinSafeState: [ self activate ]! ! -!TaskbarMorph methodsFor: 'events' stamp: 'jmv 12/28/2017 15:41:40' prior: 50378078! - screenSizeChanged - "Respond to change in screen size by repositioning self to bottom of screen" - -" Transcript newLine; print: 'Taskbar screenSizeChanged'. -" - | y e | - UISupervisor whenUIinSafeState: [ - self world ifNotNil: [ :w | - y _ w morphExtent y - self defaultHeight. - e _ self internalizeDistance: w morphExtent x @ self defaultHeight. - self morphPosition: 0@y extent: e ]]! ! -!InnerTextMorph methodsFor: 'editing' stamp: 'jmv 12/28/2017 15:31:44' prior: 50378093! - acceptContents - "The message is sent when the user hits return or Cmd-S. - Accept the current contents and end editing." - "Inform the model of text to be accepted, and return true if OK." - - | accepted prevSelection prevScrollValue | - - prevSelection _ self editor selectionInterval copy. - prevScrollValue _ owner verticalScrollBar scrollValue. - - (self canDiscardEdits and: [(self hasProperty: #alwaysAccept) not]) ifTrue: [self flash. ^true]. - (self hasEditingConflicts and: [ self confirmAcceptAnyway not ]) ifTrue: [self flash. ^false]. - - accepted _ model acceptContentsFrom: owner. - "During the step for the browser, updatePaneIfNeeded is called, and - invariably resets the contents of the code-holding PluggableTextMorph - at that time, resetting the cursor position and scroller in the process. - The following line forces that update without waiting for the step, - then restores the cursor and scrollbar" - - "some implementors of acceptContentsFrom: answer self :(" - ^accepted == true - ifTrue: [ - model refetch. - self editor selectFrom: prevSelection first to: prevSelection last. - UISupervisor whenUIinSafeState: [ - self world ifNotNil: [ :w | w activeHand newKeyboardFocus: self ]. - owner verticalScrollBar internalScrollValue: prevScrollValue]. - true] - ifFalse: [ false ]! ! -!WorldState class methodsFor: 'class initialization' stamp: 'jmv 12/28/2017 15:26:18' prior: 50378140! - addDeferredUIMessage: evaluableObject - "Objects should not be calling directly as this will disappear from this location!! From the sender, instead to schedule on the currently running world use: - self runningWorld addDeferredUIMessage: ... - And to schedule on the world a given Morph exists in use: - self world addDeferredUIMessage: ..." - self deferredUIMessages nextPut: evaluableObject! ! -!TheWorldMenu methodsFor: 'commands' stamp: 'jmv 12/28/2017 15:38:38' prior: 16934600! -fullScreenOff - - Display fullScreenMode: false. - DisplayScreen checkForNewScreenSize. - myWorld restoreDisplay! ! -!TheWorldMenu methodsFor: 'commands' stamp: 'jmv 12/28/2017 15:38:40' prior: 16934606! - fullScreenOn - - Display fullScreenMode: true. - DisplayScreen checkForNewScreenSize. - myWorld restoreDisplay! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 12/28/2017 15:37:53' prior: 50341421! - buildWorldMenu - "Build the menu that is put up when the screen-desktop is clicked on" - - | menu | - menu _ MenuMorph new defaultTarget: self. - self colorForDebugging: menu. - menu addStayUpIcons. - self fillIn: menu - from: { - { 'Open...'. { self. #openWindow}}. - { 'New morph...'. { self. #newMorph}. - 'Offers a variety of ways to create new objects'}. - { 'Preferences...'. { self. #preferencesDo}. - 'put up a menu offering many controls over appearance and system preferences.'}. - { 'Windows...'. { self. #windowsDo}}. - { 'Help...'. { self. #helpDo}. - 'puts up a menu of useful items for updating the system, determining what version you are running, and much else'}. - nil. - { 'Changes...'. { self. #changesDo}}. - { 'Debug...'. { self. #debugDo}. - 'a menu of debugging items'}. - { 'Restore Display (r)'. { myWorld. #restoreDisplay}. - 'repaint the screen -- useful for removing unwanted display artifacts, lingering cursors, etc.'}. - nil. - { 'Save'. { Smalltalk . #saveSession}. - 'save the current version of the image on disk'}. - { 'Save as...'. { Smalltalk . #saveAs}. - 'save the current version of the image on disk under a new name.'}. - { 'Save as New Version'. { Smalltalk . #saveAsNewVersion}. - 'give the current image a new version-stamped name\and save it under that name on disk.\Clear all user preferences and user state (class vars).' withNewLines}. - { 'Save and Quit'. { self. #saveAndQuit}. - 'save the image and quit out of Cuis.'}. - { 'Quit'. { self. #quitSession}. - 'quit out of Cuis.'}}. - ^menu! ! -!Theme class methodsFor: 'class initialization' stamp: 'jmv 12/28/2017 15:38:58' prior: 50377325! - currentTheme: aTheme - - CurrentTheme := aTheme new. - SHTextStylerST80 releaseClassCachedState. - self runningWorld ifNotNil: [ :w | - w backgroundImage ifNil: [ - w color: CurrentTheme background ]]. - SystemWindow initialize. - BitBltCanvas releaseClassCachedState. - self runningWorld ifNotNil: [ :w | - CurrentTheme useTaskbar - ifTrue: [w showTaskbar] - ifFalse: [w hideTaskbar]. - w restoreDisplay ]. - - ^ CurrentTheme! ! -!ProgessiveTestRunner methodsFor: 'evaluating - private' stamp: 'jmv 12/28/2017 15:40:01' prior: 50338205! - runSuiteShowingProgress - - [ self registerTestSuiteAction. - progressBar openInWorld. - self runSuite ] ensure: [ - self unregisterTestSuiteAction. - UISupervisor whenUIinSafeState: [progressBar dismissMorph] ]. - ! ! -!AndreasSystemProfiler methodsFor: 'reporting' stamp: 'jmv 12/28/2017 15:31:01' prior: 50378588! - doReport - "Report the results of this profiler run" - | report | - report _ self report. - UISupervisor whenUIinSafeState: [ - SystemWindow - editText: (Workspace withText: report) - label: 'Spy Results' - wrap: false ]! ! -!SHTextStyler methodsFor: 'styling' stamp: 'jmv 12/28/2017 15:40:06' prior: 16903157! - styleInBackgroundProcess - "Do the styling on a copy of the provided text (and in a separate process). - After finishing, send it to the model, by triggering #shoutStyled - The the model should grab the TextAttributes we added to the copy, as appropriate." - self terminateBackgroundStylingProcess. - - self mutex critical: [ - "This part runs at low priority, and signals sem when finished" - backgroundProcess _ [ - self privateStyle. - UISupervisor whenUIinSafeState: [ - textModel changed: #shoutStyled ]. - ] newProcess. - backgroundProcess - priority: Processor userBackgroundPriority; - name: 'Shout format'; - resume - ]! ! -!PopUpMenu class methodsFor: 'dialogs' stamp: 'jmv 12/28/2017 15:39:54' prior: 16891167! - inform: aString - "PopUpMenu inform: 'I like Cuis'" - - UISupervisor whenUIinSafeState: [ (PopUpMenu labels: ' OK ') startUpWithCaption: aString ]! ! - -PasteUpMorph removeSelector: #addDeferredUIMessage:! - -PasteUpMorph removeSelector: #addDeferredUIMessage:! - -PasteUpMorph removeSelector: #restoreMorphicDisplay! - -PasteUpMorph removeSelector: #restoreMorphicDisplay! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3242-UISupervisor-whenUIinSafeState-JuanVuletich-2017Dec28-15h20m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3242] on 28 December 2017 at 3:56:57 pm'! -!UISupervisor class methodsFor: 'gui process' stamp: 'jmv 12/28/2017 15:54:48' prior: 50379613! - ui - ^UIProcess ifNotNil: [ - UIProcess isSuspended ifFalse: [ - UIProcess animatedUI ]]! ! -!UISupervisor class methodsFor: 'services' stamp: 'jmv 12/28/2017 15:56:12' prior: 50379219! - restoreDisplay - DisplayScreen startUp. - self ui ifNotNil: [ :guiRootObject | - guiRootObject restoreDisplay ]. - self whenUIinSafeState: [ Cursor normal activateCursor ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3243-answerUIonlyIfActive-JuanVuletich-2017Dec28-15h54m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3243] on 29 December 2017 at 10:30:48 am'! -!HierarchicalListMorph methodsFor: 'selection' stamp: 'jmv 12/29/2017 10:29:16'! - privateVisualSelection: item - "Called internally to set a new selection. - Does not update model" - - self privateVisualSelectionIndex: (self indexForItem: item)! ! -!HierarchicalListMorph methodsFor: 'selection' stamp: 'jmv 12/29/2017 10:19:02'! - privateVisualSelectionIndex: idx - "Called internally to select the index-th item. - Does not update model" - self selectedMorph: (self listMorphAt: idx). - self scrollSelectionIntoView! ! -!HierarchicalListMorph methodsFor: 'selection' stamp: 'jmv 12/29/2017 09:42:44'! - visualSelectionIndex - ^scroller submorphs indexOf: selectedMorph! ! -!HierarchicalListMorph methodsFor: 'private' stamp: 'jmv 12/29/2017 10:28:53'! - indexForItem: item - | i | - item ifNil: [ - ^ 0 ]. - i _ scroller submorphs findFirst: [ :m | m complexContents == item ]. - i > 0 ifTrue: [ - ^ i ]. - i _ scroller submorphs findFirst: [ :m | m withoutListWrapper = item withoutListWrapper ]. - ^ i! ! -!PluggableListMorph methodsFor: 'model access' stamp: 'jmv 12/29/2017 09:32:10'! - setSelectionIndex: anInteger - "Change the model's selected item index to be anInteger." - - setIndexSelector ifNotNil: [ - model perform: setIndexSelector with: anInteger. - self update: getIndexSelector. - ^ true ]. - ^ false! ! -!PluggableListMorph methodsFor: 'selection' stamp: 'jmv 12/29/2017 09:05:26'! - privateVisualSelection: item - "Called internally to set a new selection. - Does not update model" - - self privateVisualSelectionIndex: (list indexOf: item)! ! -!PluggableListMorph methodsFor: 'selection' stamp: 'jmv 12/29/2017 08:57:30'! - privateVisualSelectionIndex: index - "Called internally to select the index-th item. - Does not update model" - | row | - row _ index ifNil: [ 0 ]. - row _ row min: self getListSize. "make sure we don't select past the end" - self listMorph selectedRow: row. - self scrollSelectionIntoView! ! -!PluggableListMorph methodsFor: 'selection' stamp: 'jmv 12/29/2017 08:59:40'! - visualSelection - self visualSelectionIndex = 0 ifTrue: [ ^nil ]. - list ifNotNil: [ ^list at: self visualSelectionIndex ]. - ^ self getListItem: self visualSelectionIndex! ! -!PluggableListMorph methodsFor: 'selection' stamp: 'jmv 12/29/2017 08:54:40'! - visualSelectionIndex - "return the index we have currently selected, or 0 if none" - ^self listMorph selectedRow ifNil: [ 0 ]! ! -!PluggableListMorphByItem methodsFor: 'model access' stamp: 'jmv 12/29/2017 09:32:13'! - setSelectionIndex: anInteger - "Change the model's selected item to be the one at the given index." - - | item | - setIndexSelector ifNotNil: [ - item _ (anInteger = 0 ifTrue: [nil] ifFalse: [itemList at: anInteger]). - model perform: setIndexSelector with: item. - self update: getIndexSelector. - ^ true ]. - ^false - ! ! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 12/29/2017 09:18:40' prior: 50379696! - arrowKey: aChar - "Handle a keyboard navigation character. Answer true if handled, false if not." - | keyEvent answer nextSelection oldSelection | - answer := false. - keyEvent := aChar numericValue. - oldSelection := self visualSelectionIndex. - nextSelection := oldSelection. - keyEvent = 31 ifTrue: [ - "down" - nextSelection := oldSelection + 1. - nextSelection > self maximumSelection ifTrue: [ nextSelection := self minimumSelection ]]. - keyEvent = 30 ifTrue: [ - "up" - nextSelection := oldSelection - 1. - nextSelection < self minimumSelection ifTrue: [ nextSelection := self maximumSelection ]]. - keyEvent = 1 ifTrue: [ "home" - nextSelection := 1 ]. - keyEvent = 4 ifTrue: [ "end" - nextSelection := scroller submorphs size ]. - keyEvent = 11 ifTrue: [ "page up" - nextSelection := oldSelection - self numSelectionsInView max: 1 ]. - keyEvent = 12 ifTrue: [ "page down" - nextSelection := oldSelection + self numSelectionsInView ]. - keyEvent = 29 ifTrue: [ - "right" - selectedMorph ifNotNil: [ - (selectedMorph canExpand and: [ selectedMorph isExpanded not ]) - ifTrue: [ - self toggleExpandedState: selectedMorph. - self scrollSelectionIntoView. - answer := true ] - ifFalse: [ nextSelection := oldSelection + 1 ]]]. - keyEvent = 28 ifTrue: [ - "left" - selectedMorph ifNotNil: [ - selectedMorph isExpanded - ifTrue: [ - self toggleExpandedState: selectedMorph. - self scrollSelectionIntoView. - answer := true ] - ifFalse: [ - oldSelection > self minimumSelection ifTrue: [ - nextSelection _ (oldSelection-1 to: 1 by: -1) detect: [ :i | ( scroller submorphs at: i) indentLevel < selectedMorph indentLevel ]]. - ]]]. - nextSelection = oldSelection ifFalse: [ - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self highlightedMorph: (self listMorphAt: nextSelection). - "Update the model in next world cycle, so user gets the immediate feedback." - UISupervisor whenUIinSafeState: [ self setSelectionIndex: nextSelection ]. - answer := true ]. - ^ answer.! ! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 12/29/2017 10:15:47' prior: 16853285! - setSelectionIndex: idx - "Change the model's selected item index to be anInteger." - - ^self setSelectedMorph: (self listMorphAt: idx)! ! -!HierarchicalListMorph methodsFor: 'selection' stamp: 'jmv 12/29/2017 10:30:10' prior: 16853374! - selection: item - "Called to set a new selection. - Updates both model and view." - "Assumes scroller submorphs is exactly our list. - Note: MAY NOT work right if list includes repeated items" - - self selectionIndex: (self indexForItem: item)! ! -!HierarchicalListMorph methodsFor: 'selection' stamp: 'jmv 12/29/2017 10:23:15' prior: 16853391! - selectionIndex: anInteger - "Public. Call to set selection. - Usually, view is updated from model updates. - If model updating fails (no model index setter defined) then just update visuals." - - (self setSelectionIndex: anInteger) ifFalse: [ - self privateVisualSelectionIndex: anInteger ]! ! -!HierarchicalListMorph methodsFor: 'selection' stamp: 'jmv 12/29/2017 10:16:19' prior: 16853399! - setSelectedMorph: aMorph - setSelectionSelector ifNil: [ ^ false ]. - model - perform: setSelectionSelector - with: aMorph complexContents ."leave last wrapper in place" - ^ true - - ! ! -!HierarchicalListMorph methodsFor: 'updating' stamp: 'jmv 12/29/2017 10:20:49' prior: 16853407! - update: aSymbol - super update: aSymbol. - aSymbol == getSelectionSelector - ifTrue: [ - self privateVisualSelection: self getCurrentSelectionItem. - ^self ]. - aSymbol == getListSelector - ifTrue: [ - self list: self getList. - ^self ]. - - "Indeed not pretty" - ( aSymbol notEmpty and: [aSymbol first == #openPath]) - ifTrue: [ - ^(scroller submorphs at: 1 ifAbsent: [^self]) - openPath: aSymbol allButFirst adaptor: #asString compare: #=]! ! -!HierarchicalListMorph methodsFor: 'private' stamp: 'jmv 12/29/2017 10:20:41' prior: 16853481! - insertNewMorphs: morphList - - scroller addAllMorphs: morphList. - scroller adjustExtent. - self setScrollDeltas. - self privateVisualSelection: self getCurrentSelectionItem! ! -!PluggableListMorph methodsFor: 'events' stamp: 'jmv 12/29/2017 09:43:57' prior: 50367359! - doubleClick: aMouseButtonEvent localPosition: localEventPosition - | index | - doubleClickSelector ifNil: [ ^super doubleClick: aMouseButtonEvent localPosition: localEventPosition ]. - index _ self rowAtLocation: localEventPosition. - index = 0 ifTrue: [ ^super doubleClick: aMouseButtonEvent localPosition: localEventPosition ]. - index == self visualSelectionIndex - ifFalse: [ self setSelectionIndex: index ]. - ^ self model perform: doubleClickSelector! ! -!PluggableListMorph methodsFor: 'events' stamp: 'jmv 12/29/2017 09:44:01' prior: 16888657! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - "The mouse came up within the list; take appropriate action" - - | row | - row _ self rowAtLocation: localEventPosition. - self owningWindow ifNotNil: [ :w | - w okToChange ifFalse: [ ^ self ]]. - (autoDeselect == false and: [row = 0 ]) ifTrue: [ ^ self ]. "work-around the no-mans-land bug" - "No change if model is locked" - (autoDeselect and: [ row == self visualSelectionIndex ]) - ifTrue: [ - aMouseButtonEvent mouseButton1Changed ifTrue: [ - self setSelectionIndex: 0 ]] - ifFalse: [ self setSelectionIndex: row ]! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 12/29/2017 09:38:13' prior: 50379764! - arrowKey: aChar - "Process the up and down arrows in a list pane. Note that the listView tells us what index variable, how to get the list, and how to move the index." - | keyEvent oldSelection nextSelection max min howMany answer w | - answer _ false. - keyEvent _ aChar numericValue. - oldSelection _ self getCurrentSelectionIndex. - nextSelection _ oldSelection. - max _ self maximumSelection. - min _ self minimumSelection. - howMany _ self numSelectionsInView. "get this exactly??" - - keyEvent = 31 ifTrue: [ - "down-arrow; move down one, wrapping to top if needed" - nextSelection _ oldSelection + 1. - nextSelection > max ifTrue: [ nextSelection _ 1 ]]. - - keyEvent = 30 ifTrue: [ - "up arrow; move up one, wrapping to bottom if needed" - nextSelection _ oldSelection - 1. - nextSelection < 1 ifTrue: [ nextSelection _ max ]]. - - keyEvent = 1 ifTrue: [ nextSelection _ 1 ]. "home" - keyEvent = 4 ifTrue: [ nextSelection _ max ]. "end" - keyEvent = 11 ifTrue: [ nextSelection _ min max: oldSelection - howMany ]. "page up" - keyEvent = 12 ifTrue: [ nextSelection _ oldSelection + howMany min: max ]. "page down" - nextSelection = oldSelection ifFalse: [ - w _ self owningWindow. - (w isNil or: [ w okToChange ]) ifTrue: [ "No change if model is locked" - - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self listMorph highlightedRow: nextSelection. - - "Update the model in next world cycle, so user gets the immediate feedback." - UISupervisor whenUIinSafeState: [ - self setSelectionIndex: nextSelection ]. - answer _ true ]]. - ^answer! ! -!PluggableListMorph methodsFor: 'menus' stamp: 'jmv 12/29/2017 09:50:46' prior: 16888894! - copySelectionToClipboard - "Copy my selected item to the clipboard as a string" - - self visualSelection - ifNotNil: [ :sel | - Clipboard storeObject: sel asString ] - ifNil: [ - self flash ]! ! -!PluggableListMorph methodsFor: 'model access' stamp: 'jmv 12/29/2017 09:38:18' prior: 16888950! - keyboardSearch: aChar - | oldSelection nextSelection max milliSeconds nextSelectionList nextSelectionText | - nextSelection _ oldSelection _ self getCurrentSelectionIndex. - max _ self maximumSelection. - milliSeconds _ Time localMillisecondClock. - milliSeconds - lastKeystrokeTime > 300 ifTrue: ["just use the one current character for selecting" - lastKeystrokes _ '']. - lastKeystrokes _ lastKeystrokes , aChar asLowercase asString. - lastKeystrokeTime _ milliSeconds. - nextSelectionList _ OrderedCollection newFrom: (list copyFrom: oldSelection + 1 to: max). - nextSelectionList addAll: (list copyFrom: 1 to: oldSelection). - "Get rid of blanks and style used in some lists" - nextSelectionText _ nextSelectionList detect: [:a | a asString withBlanksTrimmed asLowercase beginsWith: lastKeystrokes] - ifNone: [^ self flash"match not found"]. - self owningWindow ifNotNil: [ :w | - w okToChange ifFalse: [^ self]]. - nextSelection _ list findFirst: [:a | a == nextSelectionText]. - "No change if model is locked" - oldSelection == nextSelection ifTrue: [^ self flash]. - ^ self setSelectionIndex: nextSelection! ! -!PluggableListMorph methodsFor: 'selection' stamp: 'jmv 12/29/2017 10:05:11' prior: 16889043! - selection: item - "Public. Call to set selection. - Usually, view is updated from model updates. - If model updating fails (no model index setter defined) then just update visuals." - - self selectionIndex: (list indexOf: item)! ! -!PluggableListMorph methodsFor: 'selection' stamp: 'jmv 12/29/2017 09:32:29' prior: 16889057! -selectionIndex: anInteger - "Public. Call to set selection. - Usually, view is updated from model updates. - If model updating fails (no model index setter defined) then just update visuals." - - (self setSelectionIndex: anInteger) ifFalse: [ - self privateVisualSelectionIndex: anInteger ]! ! -!PluggableListMorph methodsFor: 'updating' stamp: 'jmv 12/29/2017 09:46:24' prior: 16889068! - update: aSymbol - "Refer to the comment in View|update:." - - super update: aSymbol. - aSymbol == getListSelector ifTrue: [ - self updateList. - ^ self]. - aSymbol == getIndexSelector ifTrue: [ - self privateVisualSelectionIndex: self getCurrentSelectionIndex ]! ! -!PluggableListMorph methodsFor: 'updating' stamp: 'jmv 12/29/2017 09:46:28' prior: 16889079! - updateList - | index | - "the list has changed -- update from the model" - self getList. - self listMorph listChanged. - self setScrollDeltas. - index _ self getCurrentSelectionIndex. - self privateVisualSelectionIndex: index! ! -!PluggableListMorphOfMany methodsFor: 'events' stamp: 'jmv 12/29/2017 09:38:30' prior: 50379818! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - - | oldIndex oldVal row w | - self hasKeyboardFocus ifFalse: [ - aMouseButtonEvent hand newKeyboardFocus: self ]. - - row _ self rowAtLocation: localEventPosition. - - row = 0 ifTrue: [ - ^super mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition ]. - - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self listMorph highlightedRow: row. - - w _ self owningWindow. - (w isNil or: [ w okToChange ]) ifTrue: [ "No change if model is locked" - - "Set meaning for subsequent dragging of selection" - dragOnOrOff _ (self listSelectionAt: row) not. - dragStartRow _ row. - oldIndex _ self getCurrentSelectionIndex. - oldIndex ~= 0 ifTrue: [oldVal _ self listSelectionAt: oldIndex]. - - "Different from PluggableListMorph. There, we highlight on mouse down, and act on mouse up. - Here, we act on mouse down, because we support dragging of selection, so mouse up will - only happen after user is finished dragging. In order to get the highlight visible for the user, - update the model on next world cycle." - UISupervisor whenUIinSafeState: [ - "Set or clear new primary selection (listIndex)" - dragOnOrOff - ifTrue: [self setSelectionIndex: row] - ifFalse: [self setSelectionIndex: 0]. - "Need to restore the old one, due to how model works, and set new one." - oldIndex ~= 0 ifTrue: [self listSelectionAt: oldIndex put: oldVal]. - self listSelectionAt: row put: dragOnOrOff ]. - ]. - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: nil - clkNHalf: nil - dblClkSel: #doubleClick:localPosition: - dblClkNHalfSel: nil - tripleClkSel: nil! ! -!PluggableListMorphOfMany methodsFor: 'events' stamp: 'jmv 12/29/2017 09:38:32' prior: 50365066! - mouseMove: aMouseMoveEvent localPosition: localEventPosition - "The mouse has moved, as characterized by the event provided. Adjust the scrollbar, and alter the selection as appropriate" - - | oldIndex oldVal row | - row _ (localEventPosition y < 0 and: [ scrollBar scrollValue > 0.0 ]) - ifTrue: [ - scrollBar scrollUp: 1. - "Leave at least one visible item unaffected, for better visual feedback to the user." - (self rowAtLocation: `0@0`) + 2 ] - ifFalse: [ - (localEventPosition y > extent y and: [ scrollBar scrollValue < 1.0 ]) - ifTrue: [ - scrollBar scrollDown: 1. - "Leave at least one visible item unaffected, for better visual feedback to the user." - (self rowAtLocation: 0@extent y) - 3 ] - ifFalse: [ self rowAtLocation: localEventPosition ]]. - row = 0 ifTrue: [ ^ self ]. - - "No change if model is locked" - self owningWindow ifNotNil: [ :w | - w okToChange ifFalse: [^ self]]. - - dragOnOrOff ifNil: [ - "Was not set at mouse down, which means the mouse must have gone down in an area where there was no list item" - dragOnOrOff _ (self listSelectionAt: row) not. - dragStartRow _ row ]. - - "Set meaning for subsequent dragging of selection" - oldIndex _ self getCurrentSelectionIndex. - oldIndex ~= 0 ifTrue: [ oldVal _ self listSelectionAt: oldIndex ]. - - "Set or clear new primary selection (listIndex)" - dragOnOrOff - ifTrue: [ self setSelectionIndex: row ] - ifFalse: [ self setSelectionIndex: 0 ]. - - "Need to restore the old one, due to how model works, and set new one." - oldIndex ~= 0 ifTrue: [ self listSelectionAt: oldIndex put: oldVal ]. - - "Select all in between if drag was too fast" - "self listSelectionAt: row put: dragOnOrOff." - (row min: dragStartRow) to: (row max: dragStartRow) do: [ :r | - self listSelectionAt: r put: dragOnOrOff ]! ! -!PluggableListMorphOfMany methodsFor: 'updating' stamp: 'jmv 12/29/2017 09:46:31' prior: 16889359! - update: aSymbol - super update: aSymbol. - aSymbol == #allSelections ifTrue: [ - self privateVisualSelectionIndex: self getCurrentSelectionIndex. - self redrawNeeded]! ! - -PluggableListMorphByItem removeSelector: #changeModelSelection:! - -PluggableListMorphByItem removeSelector: #changeModelSelection:! - -PluggableListMorph removeSelector: #changeModelSelection:! - -PluggableListMorph removeSelector: #changeModelSelection:! - -PluggableListMorph removeSelector: #getListSelector! - -PluggableListMorph removeSelector: #getListSelector! - -PluggableListMorph removeSelector: #selection! - -PluggableListMorph removeSelector: #selection! - -PluggableListMorph removeSelector: #selectionIndex! - -PluggableListMorph removeSelector: #selectionIndex! - -HierarchicalListMorph removeSelector: #getSelectionIndex! - -HierarchicalListMorph removeSelector: #getSelectionIndex! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3244-PluggableLists-protocolCleanup-JuanVuletich-2017Dec29-10h09m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3244] on 4 January 2018 at 3:38:22 pm'! -!SequenceableCollection methodsFor: 'math functions' stamp: 'jmv 1/4/2018 15:37:17'! - incrementFraction - " - #(10 12.5 15 20) incrementFraction - " - | displaced answer | - displaced _ self class new: self size. - displaced replaceFrom: 2 to: self size with: self startingAt: 1. - displaced at: 1 put: self first. - answer _ self copy. - answer -= displaced. - ^answer / displaced! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3245-IncrementFraction-JuanVuletich-2018Jan04-13h50m-jmv.1.cs.st----! - -----SNAPSHOT----#(4 January 2018 5:56:51.560928 pm) Cuis5.0-3245-32.image priorSource: 1455207! - -----QUIT----#(4 January 2018 5:57:02.002925 pm) Cuis5.0-3245-32.image priorSource: 1570312! - -----STARTUP----#(19 January 2018 10:33:42.45503 am) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3245-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3245] on 11 January 2018 at 11:01:17 am'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 1/11/2018 00:15:12' prior: 50379484! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag -"WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " -| activeProc | -activeProc _ Processor activeProcess. -[ - | isARealStartup guiRootObject guiRootObjectClass reopenTranscript | - self logSnapshot: save andQuit: quit. - - reopenTranscript _ false. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | each isInWorld ifTrue: [ each delete. reopenTranscript _ true ]]. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - - - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - - "Cosas que levanto explicitamente abajo" - guiRootObjectClass _ UISupervisor ui class. - guiRootObject _ UISupervisor ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "guiRootObject _ clearAllStateFlag ifFalse: [ UISupervisor ui ]." - UISupervisor stopUIProcess. - activeProc isTerminated ifFalse: [ - activeProc terminate ]. - - "Clean Globals" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: nil. - Smalltalk closeSourceFiles. Smalltalk at: #SourceFiles put: nil. - Smalltalk allClassesDo: [ :cls | cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ Smalltalk printStuffToCleanOnImageSave ]. - - - "Do image save & quit as apropriate" - Cursor write activateCursor. - save - ifTrue: [ - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - - - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: (DisplayScreen extent: `1024@768` depth: 32). - Smalltalk at: #SourceFiles put: (Array new: 2). - Smalltalk openSourceFiles. - - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - - UISupervisor spawnNewMorphicProcessFor: (guiRootObject ifNil: [ guiRootObject _ guiRootObjectClass newWorld ]). - Display triggerEvent: #screenSizeChanged. - - reopenTranscript ifTrue: [ - UISupervisor whenUIinSafeState: [ - TranscriptWindow openTranscript ]]. - " - UISupervisor whenUIinSafeState: [ - guiRootObject fullRepaintNeeded ]. - " - - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - UISupervisor whenUIinSafeState: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]. - -] forkAt: Processor timingPriority-1 named: 'Startup process'.! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3246-FixTaskbarBugOnImageSave-JuanVuletich-2018Jan11-11h00m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3246] on 12 January 2018 at 9:18:55 am'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 1/12/2018 09:16:22' prior: 50380736! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag -"WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " -| activeProc | -activeProc _ Processor activeProcess. -[ - | isARealStartup guiRootObject guiRootObjectClass reopenTranscript | - self logSnapshot: save andQuit: quit. - - reopenTranscript _ false. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | each isInWorld ifTrue: [ each delete. reopenTranscript _ true ]]. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - - - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - - "Cosas que levanto explicitamente abajo" - guiRootObjectClass _ UISupervisor ui class. - guiRootObject _ UISupervisor ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "guiRootObject _ clearAllStateFlag ifFalse: [ UISupervisor ui ]." - UISupervisor stopUIProcess. - activeProc isTerminated ifFalse: [ - activeProc terminate ]. - - "Clean Globals" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: nil. - Smalltalk closeSourceFiles. Smalltalk at: #SourceFiles put: nil. - Smalltalk allClassesDo: [ :cls | cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ Smalltalk printStuffToCleanOnImageSave ]. - - - "Do image save & quit as apropriate" - Cursor write activateCursor. - save - ifTrue: [ - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - - - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: (DisplayScreen extent: `1024@768` depth: 32). - Smalltalk at: #SourceFiles put: (Array new: 2). - Smalltalk openSourceFiles. - - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - - UISupervisor spawnNewMorphicProcessFor: (guiRootObject ifNil: [ guiRootObject _ guiRootObjectClass newWorld ]). - - Display triggerEvent: #screenSizeChanged. - - UISupervisor whenUIinSafeState: [ - "guiRootObject fullRepaintNeeded." - reopenTranscript ifTrue: [ - TranscriptWindow openTranscript ]]. - - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - UISupervisor whenUIinSafeState: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]. - -] forkAt: Processor timingPriority-1 named: 'Startup process'.! ! -!PasteUpMorph class methodsFor: 'system startup' stamp: 'jmv 1/12/2018 09:17:41' prior: 50379684! - initClassCachedState - - "Should use some other way to find relevant instances" - self flag: #jmvVer2. - self allInstancesDo: [ :each | - each buildMagnifiedBackgroundImage. - each isWorldMorph ifTrue: [ - each redrawNeeded ]]. - Cursor normal activateCursor! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3247-AvoidWindowRepositionOnImageSave-JuanVuletich-2018Jan12-09h13m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3247] on 12 January 2018 at 9:26:33 am'! -!CodeWindow methodsFor: 'menu commands' stamp: 'jmv 1/12/2018 09:24:56' prior: 16813375! - browseProtocol - "Create and schedule a new protocol browser on the currently selected class or meta." - | aPBrowser label | - model selectedClassOrMetaClass ifNotNil: [ :classOrMetaclass | - aPBrowser _ ProtocolBrowser new onSubProtocolOf: classOrMetaclass. - label _'Sub-protocol of: ', classOrMetaclass name. - ProtocolBrowserWindow open: aPBrowser label: label ]! ! -!DebuggerWindow methodsFor: 'keyboard shortcuts' stamp: 'jmv 1/12/2018 09:25:29' prior: 16831235! - browseFullProtocolIn: anInspector - "Spawn a window showing full protocol for the receiver's selection" - - ProtocolBrowserWindow - openFullProtocolForClass: anInspector selectedClassOrMetaClass! ! -!InspectorWindow methodsFor: 'menu commands' stamp: 'jmv 1/12/2018 09:23:23' prior: 16857301! - browseFullProtocol - "Spawn a window showing full protocol for the receiver's selection" - - ProtocolBrowserWindow openFullProtocolForClass: model selectedClassOrMetaClass! ! -!ObjectExplorerWindow methodsFor: 'menu commands' stamp: 'jmv 1/12/2018 09:23:27' prior: 16883379! - browseFullProtocol - "Spawn a window showing full protocol for the receiver's selection" - - ProtocolBrowserWindow openFullProtocolForClass: model selectedClass! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3248-UseProtocolBrowserWindow-JuanVuletich-2018Jan12-09h23m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3248] on 13 January 2018 at 3:55:27 pm'! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 1/13/2018 15:49:22'! - fillRects: rectangleList - "For testing. Flashes the given list of rectangles on the Display so you can watch incremental redisplay at work." - - - | blt screenRect | - blt _ (BitBlt toForm: Display) - sourceForm: nil; - sourceOrigin: `0@0`; - clipRect: self viewBox; - combinationRule: Form over. - - rectangleList do: [:r | - screenRect _ r translatedBy: self viewBox origin. - blt fillColor: Color random. - blt destRect: screenRect; copyBits. - Display forceToScreen: screenRect ]. - - (Delay forMilliseconds: 50) wait! ! -!WorldState methodsFor: 'drawing' stamp: 'jmv 1/13/2018 15:47:59' prior: 50360595! - drawInvalidAreasSubmorphs: submorphs - "Redraw the damaged areas of the given canvas and clear the damage list. Return a collection of the areas that were redrawn." - - | initialRectsToRepair currentRectsToRepair newRectsToRepair morphsToDraw rectsForEachMorph thisMorphRects reuse i n morph morphBounds morphClipRect | - - "The simple implementation is slowers as it draws morph areas that will later be covered by other morphs. - But it works, and it is easier to understand. - See en.wikipedia.org/wiki/Painter's_algorithm" - true not ifTrue: [ ^self simpleDrawInvalidAreasSubmorphs: submorphs ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - initialRectsToRepair _ damageRecorder invalidRectsFullBounds: world viewBox. - damageRecorder reset. - currentRectsToRepair _ OrderedCollection new. - newRectsToRepair _ OrderedCollection withAll: initialRectsToRepair. - morphsToDraw _ OrderedCollection new. - rectsForEachMorph _ OrderedCollection new. - thisMorphRects _ OrderedCollection new. - n _ submorphs size. - i _ 1. - - "The idea here is to iterate morphs front to back, i.e. first the ones on top. - For each morph, record the rectangles it affects. And if a morph is opaque, remove the area behind it from the list of rectangles to be repaired. - This means, for example, that morphs completely covered might even not be redrawn. - this is a huge performance gain when there are many morphs on screen, especially if there are more than ten open windows, and Theme uses opaque colors. - See 'A reverse painter's algorithm' at en.wikipedia.org/wiki/Painter's_algorithm" - [ i <= n and: [ newRectsToRepair notEmpty ]] whileTrue: [ - morph _ submorphs at: i. - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - reuse _ currentRectsToRepair. - currentRectsToRepair _ newRectsToRepair. - newRectsToRepair _ reuse removeAll. - currentRectsToRepair do: [ :r | - (morphBounds intersects: r) - ifTrue: [ - morphClipRect _ morphBounds intersect: r. - thisMorphRects add: morphClipRect. "We could perhaps try and join adjacent rectangles in this collection..." - morph addPossiblyUncoveredAreasIn: r to: newRectsToRepair ] - ifFalse: [ - newRectsToRepair add: r ]]. - thisMorphRects ifNotEmpty: [ - morphsToDraw add: morph. - rectsForEachMorph add: thisMorphRects. - thisMorphRects _ OrderedCollection new. - ]]. - i _ i + 1 ]. - - "*make this true to flash damaged areas for testing*" - Preferences debugShowDamage ifTrue: [ world fillRects: initialRectsToRepair ]. - - "Draw world background on those areas that were not completely covered by opaque morphs" - i > n ifTrue: [ - newRectsToRepair do: [ :r | - world drawOn: (canvas newClipRect: r) ]]. - - "Now, draw the recorded areas of selected morphs, back to front." - morphsToDraw with: rectsForEachMorph reverseDo: [ :m :xrects | - "Here we could think about merging all xrects into just one call... - This would mean drawing each morph just once. - But that would mean drawing pixels we were not told to. There could be other morphs in that area that are not even being drawn!! - See WorldState class >> #experiment1" - "*make this true to flash damaged areas for testing*" - Preferences debugShowDamage2 ifTrue: [ - world fillRects: xrects ]. -" rr _ nil." - xrects do: [ :r | -" rr _ rr ifNil: [ r ] ifNotNil: [ r quickMerge: rr ]." - (canvas newClipRect: r) fullDraw: m. - ]. -" (canvas newClipRect: rr) fullDraw: m" - ]. - - "Answer a list of rectangles to be updated on the Display. - This usually is not performance critical, drawing morphs is slower than just exposing the Display." - "What should we force on Display? Whatever was asked? Each small rect that was updated? A single bigger rect? - Right now, answer whatever was asked... Maybe this could be changed if that enhances performance... - (think of vnc over slow networks)" - ^ initialRectsToRepair! ! - -PasteUpMorph removeSelector: #fillRects:color:! - -PasteUpMorph removeSelector: #fillRects:color:! - -PasteUpMorph removeSelector: #flashRects:color:! - -PasteUpMorph removeSelector: #flashRects:color:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3249-MorphicInvalidationAidsEnh-JuanVuletich-2018Jan13-15h40m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3249] on 13 January 2018 at 5:18:44 pm'! -!PasteUpMorph methodsFor: 'project state' stamp: 'jmv 1/13/2018 17:03:34'! - setCanvas: aCanvas - - ^ worldState ifNotNil: [ worldState setCanvas: aCanvas ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3250-setCanvas-JuanVuletich-2018Jan13-17h18m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3250] on 14 January 2018 at 11:26:34 am'! -!WorldState methodsFor: 'stepping' stamp: 'jmv 1/14/2018 11:26:09' prior: 50340237! - runStepMethods - "Perform periodic activity inbetween event cycles" - | queue readyToProcess | - - queue _ self class deferredUIMessages. - "Processing the queue until empty is wrong if a block in it calls #addDeferredUIMessage: itself, because this loop will never end. - Instead, process no more than entries already in queue befor we start iterating!!" - readyToProcess _ queue size. - readyToProcess timesRepeat: [ - queue nextOrNil ifNotNil: [ :block | - block value - ] - ]. - self triggerAlarmsBefore: lastCycleTime. - self runLocalStepMethods: lastCycleTime. - - "we are using a normal #step for these now" - "aWorld allLowerWorldsDo: [ :each | each runLocalStepMethods ]." -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3251-DeferredMorphicProcessingFix-JuanVuletich-2018Jan14-11h18m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3251] on 14 January 2018 at 7:37:37 pm'! -!InnerTextMorph methodsFor: 'event handling' stamp: 'jmv 1/14/2018 19:19:58' prior: 16855794! - keyboardFocusChange: aBoolean - - "The message is sent to a morph when its keyboard focus changes. - The given argument indicates that the receiver is gaining (versus losing) the keyboard focus. - In this case, all we need to do is to redraw border feedback" - aBoolean - ifTrue: [ - "A hand is wanting to send us characters..." - editor ifNil: [ self editor storeSelectionInComposition ]. "Forces install" - self showsBlinkingCursor ifTrue: [ - editor hasSelection ifFalse: [ - self startBlinking ]]] - ifFalse: [ self stopBlinking ]. - "Selection might be shown differently when focused" - owner - ifNotNil: [ owner redrawNeeded ] - ifNil: [ self redrawNeeded ] "Or at least redraw us"! ! -!InnerTextMorph methodsFor: 'private' stamp: 'jmv 1/14/2018 19:14:30' prior: 16856065! - selectionChanged - - self textComposition selectionRects do: [ :r | self invalidateLocalRect: r ]. - editor hasSelection - ifTrue: [ self stopBlinking ] - ifFalse: [ self startBlinking ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3252-InnerTextMorph-avoidUnnededStepping-JuanVuletich-2018Jan14-19h37m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3251] on 14 January 2018 at 7:38:44 pm'! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 1/14/2018 19:31:36' prior: 50340756! - doOneCycle - "Do one cycle of the interaction loop. This method is called repeatedly when the world is running. - - Make for low cpu usage if the ui is inactive, but quick response when ui is in use. - However, after some inactivity, there will be a larger delay before the ui gets responsive again." - - | wait waitUntil | - waitDelay ifNil: [ waitDelay _ Delay forMilliseconds: 50 ]. - lastCycleHadAnyEvent | self class deferredUIMessages isEmpty not - ifTrue: [ - pause _ 20. "This value will only be used when there are no more events to serve." - wait _ 0 ] "Don't wait" - ifFalse: [ - pause < 200 "No events processed? Start saving CPU!! But never make the user wait more than 200ms for being responsive again." - ifTrue: [ pause _ pause * 21//20 ]. - waitUntil _ lastCycleTime + pause. - "Earlier if steps" - stepList isEmpty not ifTrue: [ - waitUntil _ waitUntil min: stepList first scheduledTime ]. - "Earlier if alarms" - alarms ifNotNil: [ - alarms isEmpty not ifTrue: [ - waitUntil _ waitUntil min: alarms first scheduledTime ]]. - - wait _ waitUntil - Time localMillisecondClock ]. - Preferences serverMode - ifTrue: [ wait _ wait max: 50 ]. "Always wait at least a bit on servers, even if this makes the UI slow." - wait > 0 - ifFalse: [ Processor yield ] - ifTrue: [ - waitDelay beingWaitedOn - ifFalse: [ waitDelay setDelay: wait; wait ] - ifTrue: [ - "If we are called from a different process than that of the main UI, we might be called in the main - interCyclePause. In such case, use a new Delay to avoid 'This Delay has already been scheduled' errors" - (Delay forMilliseconds: wait) wait ]]. - - "Record start time of this cycle, and do cycle" - lastCycleTime _ Time localMillisecondClock. - lastCycleHadAnyEvent _ self doOneCycleNow! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3253-MorphicMaxFPSifDeferredBlocks-JuanVuletich-2018Jan14-19h37m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3253] on 15 January 2018 at 4:47:07 pm'! -!DisplayScreen methodsFor: 'initialization' stamp: 'jmv 1/15/2018 15:51:20'! - initialize - self - setExtent: self class actualScreenSize - depth: (self class actualScreenDepth ifNil: [ 32 ])! ! -!CompiledMethod methodsFor: 'source code management' stamp: 'jmv 1/15/2018 16:08:16' prior: 16820423! - getPreambleFrom: aFileStream at: position - | writeStream c p | - writeStream _ String new writeStream. - p _ position. - c _ nil. - [ p >= 0 and: [ c ~~ $!! ]] whileTrue: [ - aFileStream position: p. - c _ aFileStream basicNext. - p _ p - 1 ]. - [ p >= 0] whileTrue: [ - aFileStream position: p. - c _ aFileStream basicNext. - c == $!! - ifTrue: [^ writeStream contents reverse ] - ifFalse: [ writeStream nextPut: c ]. - p _ p - 1 ]. - ^ nil! ! -!CompiledMethod methodsFor: 'time stamp' stamp: 'jmv 1/15/2018 16:08:53' prior: 16821137! - timeStamp - "Answer the authoring time-stamp for the given method, retrieved from the sources or changes file. Answer the empty string if no time stamp is available." - - "(CompiledMethod compiledMethodAt: #timeStamp) timeStamp" - - | file preamble stamp tokens tokenCount | - self fileIndex = 0 ifTrue: [^ String new]. "no source pointer for this method" - file _ SourceFiles at: self fileIndex. - file ifNil: [^ String new]. "sources file not available" - "file does not exist happens in secure mode" - file _ [file name asFileEntry readStream] on: FileDoesNotExistException do: [ :ex| nil ]. - file ifNil: [^ String new]. - preamble _ self getPreambleFrom: file at: (0 max: self filePosition). - preamble ifNil: [ ^ '' ]. - stamp _ String new. - tokens _ (preamble findString: 'methodsFor:' startingAt: 1) > 0 - ifTrue: [Scanner new scanTokens: preamble] - ifFalse: [Array new "ie cant be back ref"]. - (((tokenCount _ tokens size) between: 7 and: 8) and: [(tokens at: tokenCount - 5) = #methodsFor:]) - ifTrue: - [(tokens at: tokenCount - 3) = #stamp: - ifTrue: ["New format gives change stamp and unified prior pointer" - stamp _ tokens at: tokenCount - 2]]. - ((tokenCount between: 5 and: 6) and: [(tokens at: tokenCount - 3) = #methodsFor:]) - ifTrue: - [(tokens at: tokenCount - 1) = #stamp: - ifTrue: ["New format gives change stamp and unified prior pointer" - stamp _ tokens at: tokenCount]]. - file close. - ^ stamp! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 1/15/2018 16:45:44' prior: 50380864! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag -"WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " -| activeProc | -activeProc _ Processor activeProcess. -[ - | isARealStartup guiRootObject guiRootObjectClass reopenTranscript | - self logSnapshot: save andQuit: quit. - - reopenTranscript _ false. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | each isInWorld ifTrue: [ each delete. reopenTranscript _ true ]]. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - - - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - - "Cosas que levanto explicitamente abajo" - guiRootObjectClass _ UISupervisor ui class. - guiRootObject _ UISupervisor ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "guiRootObject _ clearAllStateFlag ifFalse: [ UISupervisor ui ]." - UISupervisor stopUIProcess. - activeProc isTerminated ifFalse: [ - activeProc terminate ]. - - "Clean Globals" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: nil. - Smalltalk closeSourceFiles. Smalltalk at: #SourceFiles put: nil. - Smalltalk allClassesDo: [ :cls | cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ Smalltalk printStuffToCleanOnImageSave ]. - - - "Do image save & quit as apropriate" - Cursor write activateCursor. - save - ifTrue: [ - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - - - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: DisplayScreen new. - Smalltalk at: #SourceFiles put: (Array new: 2). - Smalltalk openSourceFiles. - - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - - UISupervisor spawnNewMorphicProcessFor: (guiRootObject ifNil: [ guiRootObject _ guiRootObjectClass newWorld ]). - Display triggerEvent: #screenSizeChanged. - - self restoreLostChangesIfNecessary. - - UISupervisor whenUIinSafeState: [ - "guiRootObject fullRepaintNeeded." - reopenTranscript ifTrue: [ - TranscriptWindow openTranscript ]]. - - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - UISupervisor whenUIinSafeState: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]. - -] forkAt: Processor timingPriority-1 named: 'Startup process'.! ! -!SystemDictionary methodsFor: 'startup' stamp: 'jmv 1/6/2017 09:59:32' prior: 50370005! - doStartUp: isARealStartup - " - isARealStartup - true: system is coming up (VM and image just started) - false: we have just saved an image snapshot, but didn't quit. - " - - "Here, startup begins!!" - Cursor normal activateCursor. - self setGCParameters. - isARealStartup ifTrue: [ - self clearExternalObjects ]. - self readCommandLineArguments. - self processStartUpList: isARealStartup. - isARealStartup ifTrue: [ - self setPlatformPreferences. - self setStartupStamp ]! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'jmv 1/15/2018 16:17:47' prior: 50370737! - hasToRestoreChangesFrom: changesFile - - | chunk | - - changesFile position: self lastQuitLogPosition. - [ changesFile atEnd ] whileFalse: [ chunk := changesFile nextChunk ]. - - ^chunk notNil and: [(self isSnapshotQuitOrQuitNoSaveRecord: chunk) not] -! ! -!DisplayScreen class methodsFor: 'snapshots' stamp: 'jmv 1/15/2018 15:51:11' prior: 16835515! - actualScreenDepth - - ^ Display ifNotNil: [ Display depth ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3254-fixStartupFreezeWhenBrokenChanges-JuanVuletich-2018Jan15-16h43m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3254] on 19 January 2018 at 10:28:10 am'! -!Collection methodsFor: 'enumerating' stamp: 'jmv 1/19/2018 08:57:00'! - select: selectBlock thenDo: doBlock - "Equivalent to - (self select: selectBlock) do: doBlock - but avoid creating an extra collection." - - self do: [ :each | (selectBlock value: each) ifTrue: [ doBlock value ]]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3255-selectthenDo-JuanVuletich-2018Jan19-10h27m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3254] on 19 January 2018 at 10:28:40 am'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 1/19/2018 10:12:45'! - snapshot: save andQuit: quit - - self snapshot: save andQuit: quit embedded: false clearAllClassState: false! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 1/19/2018 08:53:57'! - snapshot: save andQuit: quit embedded: embeddedFlag - - self snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: false! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3256-quitProtocol-JuanVuletich-2018Jan19-10h28m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3254] on 19 January 2018 at 10:28:58 am'! -!SystemDictionary class methodsFor: 'copyright' stamp: 'jmv 1/19/2018 10:25:24' prior: 50343084! - copyright - "The Cuis Smalltalk copyright. - Parts are copyright of many contributors to Squeak and Cuis projects." - - ^ -'Portions of Cuis are: -Copyright (c) Xerox Corp. 1981, 1982. -Copyright (c) Apple Computer, Inc. 1985-1996. -Copyright (c) Contributors to Squeak and Cuis projects. 1997-2018.'! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3257-updateCopyrightNotice-JuanVuletich-2018Jan19-10h28m-jmv.1.cs.st----! - -----SNAPSHOT----#(19 January 2018 10:33:57.968071 am) Cuis5.0-3257-32.image priorSource: 1570409! - -----QUIT----#(19 January 2018 10:34:14.633653 am) Cuis5.0-3257-32.image priorSource: 1600051! - -----STARTUP----#(26 February 2018 3:42:19.914807 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3257-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3257] on 22 January 2018 at 5:54:08 pm'! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 1/22/2018 17:53:13' prior: 50357954! - displayOn: aForm in: aRectangle - " - Transcript displayOn: Display - " - | font count i string x y fh f canvas innerR | - aForm fill: aRectangle fillColor: Color white. - font _ AbstractFont default. - - innerR _ aRectangle insetBy: self padding. - fh _ font height. - count _ innerR height // fh. - x _ innerR left. - y _ innerR top. - f _ firstIndex-1. - firstIndex > lastIndex ifTrue: [ f _ f - self maxEntries ]. - i _ (lastIndex - count max: f) \\ self maxEntries + 1. - canvas _ aForm getCanvas. - canvas newClipRect: innerR. - [ i <= lastIndex ] whileTrue: [ - string _ entries at: i. - canvas drawString: string at: x@y font: font color: Color veryDarkGray. - y _ y + fh. - i _ i \\ self maxEntries + 1 ]. - - string _ unfinishedEntry contents. - canvas drawString: string at: x@y font: font color: Color veryDarkGray! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3258-FixTranscriptResizeOnHugeFonts-JuanVuletich-2018Jan22-17h42m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3257] on 6 February 2018 at 11:27:37 am'! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 2/6/2018 11:27:31' prior: 16902489! - parseByteArray - "Literal ByteArray or literal FloatArray" - [currentTokenFirst == $]] whileFalse: [ - currentTokenFirst isDigit | (currentTokenFirst = $-) - ifTrue: [ - "do not parse the number, can be time consuming" - self scanPast: #number] - ifFalse: [ - self failWhen: currentTokenFirst == $. . - self error]]. - self scanPast: #arrayEnd! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3259-ShoutLiteralFloatArrays-JuanVuletich-2018Feb06-11h27m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3259] on 11 February 2018 at 6:51:44 pm'! -!Color methodsFor: 'testing' stamp: 'jmv 2/11/2018 18:50:54'! - isCollection - ^ false! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3260-Color-is-not-collection-JuanVuletich-2018Feb11-18h51m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3260] on 23 February 2018 at 3:19:20 pm'! -!TextModelMorph methodsFor: 'events' stamp: 'jmv 2/23/2018 14:55:30'! - clickAndHalf: aMouseButtonEvent localPosition: localEventPosition - - self textMorph clickAndHalf: aMouseButtonEvent localPosition: localEventPosition! ! -!TextModelMorph methodsFor: 'events' stamp: 'jmv 2/23/2018 14:56:20'! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - - scroller mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition. - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: nil - clkNHalf: #clickAndHalf:localPosition: - dblClkSel: #doubleClick:localPosition: - dblClkNHalfSel: #doubleClickAndHalf:localPosition: - tripleClkSel: nil! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3261-ClickNHalf-SelectAll-OnEmptyTextArea-JuanVuletich-2018Feb23-15h18m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3260] on 23 February 2018 at 3:00:53 pm'! -!Editor methodsFor: 'typing/selecting keys' stamp: 'jmv 2/23/2018 15:00:36' prior: 16836736! - selectAll: aKeyboardEvent - "select everything, invoked by cmd-a. 1/17/96 sw" - - self selectAll. - ^ true! ! - -TextEditor removeSelector: #selectAll:! - -TextEditor removeSelector: #selectAll:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3262-SelectAll-cleanup-JuanVuletich-2018Feb23-14h56m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3262] on 23 February 2018 at 3:46:21 pm'! -!HandMorph methodsFor: 'private events' stamp: 'jmv 2/23/2018 15:43:19' prior: 16852387! - shouldControlEmulateAltFor: keyValue - "At least on Linux Windows, command key is usually ctrl, not alt." - - ^ true! ! -!Theme methodsFor: 'keyboard shortcuts' stamp: 'jmv 2/23/2018 15:42:17' prior: 50369238! - keyStroke: aKeyboardEvent morph: aMorph - - aKeyboardEvent commandAltKeyPressed | aKeyboardEvent controlKeyPressed - ifFalse: [ ^ false ]. - - aKeyboardEvent keyValue = $w numericValue ifTrue: [ - aMorph owningWindow ifNotNil: [ :w | - (w morphContainsPoint: (w internalizeFromWorld: aKeyboardEvent eventPosition)) ifTrue: [ - w delete. - ^true ] ]]. -" aKeyboardEvent keyValue = $f numericValue - ifTrue: [aMorph owningWindow ifNotNil: [ :w | w fullScreen. ^true ]]. -" - ^ false! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3263-Ctrl-means-Command-JuanVuletich-2018Feb23-15h41m-jmv.1.cs.st----! - -----SNAPSHOT----#(26 February 2018 3:43:10.984842 pm) Cuis5.0-3263-32.image priorSource: 1600150! - -----QUIT----#(26 February 2018 3:43:22.200504 pm) Cuis5.0-3263-32.image priorSource: 1605131! - -----STARTUP----#(9 March 2018 11:46:48.885194 am) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3263-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3263] on 1 March 2018 at 4:59:38 pm'! -!HandMorph methodsFor: 'private events' stamp: 'jmv 3/1/2018 16:59:14' prior: 50381782! - shouldControlEmulateAltFor: keyValue - "At least on Linux Windows, command key is usually ctrl, not alt. - But not for arrow keys!! ctrl-left ~~ alt-left" - ^ keyValue > 32! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3264-Fix-ctrl-ArrowKeys-JuanVuletich-2018Mar01-16h57m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3264] on 4 March 2018 at 12:09:15 pm'! -!Integer methodsFor: 'benchmarks' stamp: 'jmv 3/4/2018 12:06:08' prior: 50371694! - tinyBenchmarks - "Report the results of running the two tiny Squeak benchmarks. - ar 9/10/1999: Adjusted to run at least 1 sec to get more stable results - - - Performance of early 80's experimental Smalltalk systems. - Estimations from http://wiki.c2.com/?GreenBook and http://www.wirfs-brock.com/allen/things/smalltalk-things/tektronix-smalltalk-document-archive - - DEC PDP-11/23 5,000 bytecodes/sec (Green Book, p.128) - Apple 5MHz 68000 9,000 to 11,000 bytecodes/sec (Green Book, p.187, 1982-qtr4-magnolia-perf-graph.pdf) - VAX-11/780 C HP Smalltalk 5,000 to 25,000 bytecodes/sec (Green Book, p.235) - VAX-11/780 C Berkeley Smalltalk 12,000 to 23000 bytecodes/sec (Green Book, p.203, 1982-qtr4-magnolia-perf-graph.pdf) - DEC VAX-11/780 assembly 20,000 to 25,000 bytecodes/sec (Green Book, p.149, 1982-qtr4-magnolia-perf-graph.pdf) - Xerox Dolphin µcode 20,000 to 40,000 bytecodes/sec (Green Book, p.44, p.203, 1982-qtr4-magnolia-perf-graph.pdf) - TEK Magnolia 10MHz 68000 50,000 bytecodes/sec (1983-Magnolia-st-perf.pdf) - Xerox Dorado 14MHz µcode 400,000 to 500,000 bytecodes/sec (Green book, p.44, p.203, 1982-qtr4-magnolia-perf-graph.pdf) - - - 0 tinyBenchmarks - - 292 MHz G3 Mac: 22,727,272 bytecodes/sec; 984,169 sends/sec - 400 MHz PII/Win98: 18,028,169 bytecodes/sec; 1,081,272 sends/sec - - RasPi2 - StackVM: 37,758,112 bytecodes/sec; 2,412,667 sends/sec - RasPi2- CogSSpur: 157,441,574 bytecodes/sec; 10,946,039 sends/sec - - C.H.I.P. (*1) - StackVM: 55,315,471 bytecodes/sec; 3,348,667 sends/sec - C.H.I.P. (*1) - CogSpur: 253,716,551 bytecodes/sec; 16,853,816 sends/sec - - RasPi3B - StackSpur 44,107,512 bytecodes/sec; 2,767,863 sends/sec - RasPi3B - CogSpur 281,783,159 bytecodes/sec; 16,404,381 sends/sec - - 1.66GHz Atom N450 - Cog: 244,274,809 bytecodes/sec; 28,795,277 sends/sec - 1.66GHz Atom N450 - CogSpur: 469,724,770 bytecodes/sec; 30,754,699 sends/sec - - 1.33GHz Atom 3735G - Cog: 326,114,649 bytecodes/sec; 34,985,976 sends/sec - 1.33GHz Atom 3735G - CogSpur: 632,098,765 bytecodes/sec; 33,692,910 sends/sec - - 1.5GHz AMD A4-5000 APU - Cog: 390,243,902 bytecodes/sec; 47,507,997 sends/sec - 1.5GHz AMD A4-5000 APU - CogSpur: 675,907,590 bytecodes/sec; 40,669,724 sends/sec - 1.5GHz AMD A4-5000 APU - CogSpur64: 659,368,963 bytecodes/sec; 50,338,916 sends/sec - - 2.3GHz Tegra (*2) - StackVM: 258,847,320 bytecodes/sec; 13,014,759 sends/sec - 2.3GHz Tegra (*2) - CogSpur: 1,083,024,854 bytecodes/sec; 64,289,750 sends/sec - - 3.1GHz Core i3-2100 - Cog: 1,203,290,246 bytecodes/sec; 165,723,327 sends/sec - 3.1GHz Core i3-2100 - CogSpur: 2,042,892,768 bytecodes/sec; 127,837,794 sends/sec - - 2.70GHz Core i5-6400 -CogSpur64 3,162,934,362 bytecodes/sec; 243,321,293 sends/sec - - (*1) C.H.I.P. $9 Computer [Next Thing Co], Allwinner R8 Single-Core ARM Cortex-A8 - 1 GHz - (*2) ACER Chromebook CB5-311 - NVIDIA Tegra K1 Quad-Core ARM Cortex-A15 'r3' - 2.3 GHz - - It is interesting to note that Spur for the first time brings ARM hardware (RasPi and C.H.I.P.) into a 'Morphic is confortable and nice to use' level of performance. - " - | t1 t2 r n1 n2 | - n1 _ 1. - [ - t1 _ Time millisecondsToRun: [n1 benchmark]. - t1 < 1000] - whileTrue: [n1 _ n1 * 2]. "Note: #benchmark's runtime is about O(n)" - - n2 _ 28. - [ - t2 _ Time millisecondsToRun: [r _ n2 benchFib]. - t2 < 1000] - whileTrue: [n2 _ n2 + 1]. - "Note: #benchFib's runtime is about O(k^n), - where k is the golden number = (1 + 5 sqrt) / 2 = 1.618...." - - ^String streamContents: [ :strm | - (n1 * 500000 * 1000) // t1 withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixName; - nextPutAll: 'Bytecodes/second; ' ]. - (r * 1000) // t2 withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixName; - nextPutAll: 'Sends/second' ]]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3265-EarlySmalltalkPerformanceNumbers-JuanVuletich-2018Mar04-12h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3265] on 4 March 2018 at 12:46:18 pm'! -!Integer methodsFor: 'benchmarks' stamp: 'jmv 3/4/2018 12:44:36' prior: 50381840! - tinyBenchmarks - "Report the results of running the two tiny Squeak benchmarks. - ar 9/10/1999: Adjusted to run at least 1 sec to get more stable results - - - Performance of early 80's experimental Smalltalk systems. - Estimations from - http://wiki.c2.com/?GreenBook - http://www.wirfs-brock.com/allen/things/smalltalk-things/tektronix-smalltalk-document-archive/1982-qtr4-magnolia-perf-graph.pdf - http://www.wirfs-brock.com/allen/things/smalltalk-things/tektronix-smalltalk-document-archive/1983-Magnolia-st-perf.pdf - - DEC PDP-11/23 5,000 bytecodes/sec (Green Book, p.128) - Apple 5MHz 68000 9,000 to 11,000 bytecodes/sec (Green Book, p.187, awb) 5000 clocks/bytecode - VAX-11/780 5MHz C HP Smalltalk 5,000 to 25,000 bytecodes/sec (Green Book, p.235) 330 clocks/bytecode - VAX-11/780 5MHz C Berkeley Smalltalk 12,000 to 23000 bytecodes/sec (Green Book, p.203, awb) 300 clocks/bytecode - DEC VAX-11/780 5MHz assembly 20,000 to 25,000 bytecodes/sec (Green Book, p.149, awb) 200 clocks/bytecode - Xerox Dolphin µcode 20,000 to 40,000 bytecodes/sec (Green Book, p.44, p.203, awb) - TEK Magnolia 10MHz 68000 50,000 bytecodes/sec (awb) 200 clocks/bytecode - Xerox Dorado 14MHz µcode 400,000 to 500,000 bytecodes/sec (Green book, p.44, p.203, awb) 28 clocks/bytecode - - - 0 tinyBenchmarks - - 292 MHz G3 Mac: 22,727,272 bytecodes/sec; 984,169 sends/sec 12.8 clocks/bytecode - 400 MHz PII/Win98: 18,028,169 bytecodes/sec; 1,081,272 sends/sec 22.2 clocks/bytecode - - 900MHz RasPi2 - StackVM: 37,758,112 bytecodes/sec; 2,412,667 sends/sec 16.2 clocks/bytecode - 900MHz RasPi2- CogSSpur: 157,441,574 bytecodes/sec; 10,946,039 sends/sec 5.7 clocks/bytecode - - 1GHz C.H.I.P. (*1) - StackVM: 55,315,471 bytecodes/sec; 3,348,667 sends/sec 18.1 clocks/bytecode - 1GHz C.H.I.P. (*1) - CogSpur: 253,716,551 bytecodes/sec; 16,853,816 sends/sec 3.9 clocks/bytecode - - 1.2GHz RasPi3B - StackSpur 44,107,512 bytecodes/sec; 2,767,863 sends/sec 27.2 clocks/bytecode - 1.2GHz RasPi3B - CogSpur 281,783,159 bytecodes/sec; 16,404,381 sends/sec 6.6 clocks/bytecode - - 1.66GHz Atom N450 - Cog: 244,274,809 bytecodes/sec; 28,795,277 sends/sec 6.8 clocks/bytecode - 1.66GHz Atom N450 - CogSpur: 469,724,770 bytecodes/sec; 30,754,699 sends/sec 3.5 clocks/bytecode - - 1.33GHz Atom 3735G - Cog: 326,114,649 bytecodes/sec; 34,985,976 sends/sec 4.1 clocks/bytecode - 1.33GHz Atom 3735G - CogSpur: 632,098,765 bytecodes/sec; 33,692,910 sends/sec 2.1 clocks/bytecode - - 1.5GHz AMD A4-5000 APU - Cog: 390,243,902 bytecodes/sec; 47,507,997 sends/sec 3.8 clocks/bytecode - 1.5GHz AMD A4-5000 APU - CogSpur: 675,907,590 bytecodes/sec; 40,669,724 sends/sec 2.2 clocks/bytecode - 1.5GHz AMD A4-5000 APU - CogSpur64: 659,368,963 bytecodes/sec; 50,338,916 sends/sec 2.2 clocks/bytecode - - 2.3GHz Tegra (*2) - StackVM: 258,847,320 bytecodes/sec; 13,014,759 sends/sec 8.9 clocks/bytecode - 2.3GHz Tegra (*2) - CogSpur: 1,083,024,854 bytecodes/sec; 64,289,750 sends/sec 2.1 clocks/bytecode - - 3.1GHz Core i3-2100 - Cog: 1,203,290,246 bytecodes/sec; 165,723,327 sends/sec 2.6 clocks/bytecode - 3.1GHz Core i3-2100 - CogSpur: 2,042,892,768 bytecodes/sec; 127,837,794 sends/sec 1.5 clocks/bytecode - - 2.70GHz Core i5-6400 -CogSpur64 3,162,934,362 bytecodes/sec; 243,321,293 sends/sec 0.85 clocks/bytecode - - (*1) C.H.I.P. $9 Computer [Next Thing Co], Allwinner R8 Single-Core ARM Cortex-A8 - 1 GHz - (*2) ACER Chromebook CB5-311 - NVIDIA Tegra K1 Quad-Core ARM Cortex-A15 'r3' - 2.3 GHz - - It is interesting to note that Spur for the first time brings ARM hardware (RasPi and C.H.I.P.) into a 'Morphic is confortable and nice to use' level of performance. - " - | t1 t2 r n1 n2 | - n1 _ 1. - [ - t1 _ Time millisecondsToRun: [n1 benchmark]. - t1 < 1000] - whileTrue: [n1 _ n1 * 2]. "Note: #benchmark's runtime is about O(n)" - - n2 _ 28. - [ - t2 _ Time millisecondsToRun: [r _ n2 benchFib]. - t2 < 1000] - whileTrue: [n2 _ n2 + 1]. - "Note: #benchFib's runtime is about O(k^n), - where k is the golden number = (1 + 5 sqrt) / 2 = 1.618...." - - ^String streamContents: [ :strm | - (n1 * 500000 * 1000) // t1 withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixName; - nextPutAll: 'Bytecodes/second; ' ]. - (r * 1000) // t2 withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixName; - nextPutAll: 'Sends/second' ]]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3266-ClocksPerBytecodeEstimation-JuanVuletich-2018Mar04-12h45m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3266] on 6 March 2018 at 5:42:11 pm'! -!String methodsFor: 'converting' stamp: 'jmv 3/6/2018 17:40:38'! - asValidInstanceVariableName - | answer | - answer _ self asIdentifier: false. - (Scanner pseudoVariableNames includes: answer) - ifTrue: [ answer _ answer , 'x' ]. - ^ answer - -" -'234znak 43 ) 2' asValidInstanceVariableName -'234 xx\ Uml /ler42342380-4' asValidInstanceVariableName -"! ! -!String methodsFor: 'converting' stamp: 'jmv 3/6/2018 17:32:02'! - asValidSelector - ^ self asIdentifier: false - -" -'234znak 43 ) 2' asValidSelector -"! ! -!String methodsFor: 'converting' stamp: 'jmv 3/6/2018 17:15:13'! - uncapitalized - "Answer an object like the receiver but with first character downshifted if necesary" - "'MElViN' uncapitalized" - "#Will uncapitalized" - | answer | - self isEmpty ifTrue: [^ self]. - answer _ self isString - ifTrue: ["don't modify receiver" - self copy] - ifFalse: [self asString]. - answer at: 1 put: (answer at: 1) asLowercase. - ^ self isString - ifTrue: [answer] - ifFalse: [answer as: self class]! ! -!Scanner class methodsFor: 'testing' stamp: 'jmv 3/6/2018 17:38:01'! - isValidInstanceVariableName: aString - "Answer whether aString is a legal instance variable name." - - ^ ((self isLiteralSymbol: aString) and: [(aString includes: $:) not]) and: - [(self pseudoVariableNames includes: aString) not]! ! -!Scanner class methodsFor: 'testing' stamp: 'jmv 3/6/2018 17:36:55'! - pseudoVariableNames - "Answer a list of Smalltalk pseudo-varialbes" - ^ #('nil' 'true' 'false' 'self' 'super' 'thisContext')! ! -!Workspace methodsFor: 'variable declarations' stamp: 'jmv 3/6/2018 17:28:10' prior: 50376968! - nameForObject: object - "Answer a name suitable for a Workspace variable" - ^ (object class name, object identityHash asString) asIdentifier: false! ! -!String methodsFor: 'converting' stamp: 'jmv 3/6/2018 17:19:56' prior: 16916313! - 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 | - aString _ self select: [ :el | el isValidInIdentifiers ]. - (aString size = 0 or: [aString first isValidStartOfIdentifiers not]) - ifTrue: [aString _ 'a', aString]. - ^ shouldBeCapitalized ifTrue: [ aString capitalized ] ifFalse: [ aString uncapitalized ] - -" -'234Fred987' asIdentifier: false -'235Fred987' asIdentifier: true -'' asIdentifier: true -'()87234' asIdentifier: false -'())z>=PPve889 U >' asIdentifier: false -"! ! -!Symbol class methodsFor: 'access' stamp: 'jmv 3/6/2018 17:15:26' prior: 16918609! - 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 numericValue. - ascii < 128 ifTrue: [selectorList add: (OneCharacterSymbols at: ascii+1)] - ]. - - aString first isValidInIdentifiers 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 uncapitalized numArgs < 0]]. - -"Symbol selectorsContaining: 'scon'"! ! -!Symbol class methodsFor: 'access' stamp: 'jmv 3/6/2018 17:15:29' prior: 16918646! - selectorsMatching: aStringPattern - "Answer a list of selectors that match aStringPattern within them. Case-insensitive. - Does return symbols that begin with a capital letter." - - | selectorList | - - selectorList := OrderedCollection new. - - aStringPattern isEmpty ifTrue: [^selectorList]. - - self allSymbolTablesDo: - [:each | (aStringPattern match: each) ifTrue: [selectorList add: each]]. - - ^selectorList reject: "reject non-selectors, but keep ones that begin with an uppercase" - [:each | each numArgs < 0 and: [each asString uncapitalized numArgs < 0]] - - "Symbol selectorsMatching: 'parse:*'"! ! -!Morph methodsFor: 'menus' stamp: 'jmv 3/6/2018 16:58:49' prior: 50376743! - addCopyItemsTo: aMenu - "Add copy-like items to the halo menu" - - aMenu add: 'copy to clipboard (c)' action: #copyToClipboard:! ! - -Utilities class removeSelector: #inviolateInstanceVariableNames! - -Utilities class removeSelector: #inviolateInstanceVariableNames! - -Utilities class removeSelector: #isLegalInstVarName:! - -Utilities class removeSelector: #isLegalInstVarName:! - -Utilities class removeSelector: #wellFormedInstanceVariableNameFrom:! - -Utilities class removeSelector: #wellFormedInstanceVariableNameFrom:! - -Scanner class removeSelector: #inviolateInstanceVariableNames! - -Scanner class removeSelector: #inviolateInstanceVariableNames! - -Scanner class removeSelector: #isLegalInstVarName:! - -Scanner class removeSelector: #isLegalInstVarName:! - -Scanner class removeSelector: #wellFormedInstanceVariableNameFrom:! - -Scanner class removeSelector: #wellFormedInstanceVariableNameFrom:! - -String removeSelector: #asLegalSelector! - -String removeSelector: #asLegalSelector! - -String removeSelector: #withFirstCharacterDownshifted! - -String removeSelector: #withFirstCharacterDownshifted! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3267-Cleanup-JuanVuletich-2018Mar06-17h39m-jmv.1.cs.st----! - -----SNAPSHOT----#(9 March 2018 11:46:56.912654 am) Cuis5.0-3267-32.image priorSource: 1605230! - -----QUIT----#(9 March 2018 11:47:18.892605 am) Cuis5.0-3267-32.image priorSource: 1621750! - -----STARTUP----#(13 March 2018 3:19:59.183656 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3267-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3267] on 11 March 2018 at 9:05:37 am'! -!Feature methodsFor: 'testing' stamp: 'jmv 3/11/2018 09:03:09' prior: 16840526! - satisfies: featureRequirement - "Does this provided Feature satisfy the FeatureRequirement?" - - "Must match name." - ^ (name sameAs: featureRequirement name) and: [ - - "If no specific version req, we are done. Ok." - featureRequirement minVersion isNil or: [ - - "If our version is exactly the min req version, we must also satisfy minRevision" - version = featureRequirement minVersion and: [ - featureRequirement minRevision isNil or: [ revision >= featureRequirement minRevision ]]] or: [ - - "If we are past min req version, ignore minRevision, but check we are not beyond max req version" - version > featureRequirement minVersion and: [ - featureRequirement maxVersion isNil or: [ version <= featureRequirement maxVersion ]]]]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3268-CaseInsensitiveFeatureMatching-JuanVuletich-2018Mar11-09h03m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3268] on 12 March 2018 at 12:16:15 pm'! -!CodeProvider methodsFor: 'message list' stamp: 'jmv 3/11/2018 15:52:08' prior: 16812753! - sourceStringPrettifiedAndDiffed - "Answer a copy of the source code for the selected message, transformed by diffing and pretty-printing exigencies" - | class selector sourceString | - class _ self selectedClassOrMetaClass. - selector _ self selectedMessageName. - (class isNil or: [ selector isNil ]) ifTrue: [ ^ 'missing' ]. - sourceString _ class - ultimateSourceCodeAt: selector - ifAbsent: [ ^ 'error' ]. - (self showingPrettyPrint or: [ self showingAnyKindOfPrettyDiffs ]) ifTrue: [ - sourceString _ class compilerClass new - format: sourceString - in: class - notifying: nil ]. - self showingAnyKindOfDiffs ifTrue: [ - sourceString _ self diffFromPriorSourceFor: sourceString ]. - ^ sourceString! ! -!Browser methodsFor: 'message functions' stamp: 'jmv 3/12/2018 12:15:33' prior: 16792281! - defineMessageFrom: aString notifying: aRequestor - "Compile the expressions in aString. Notify aRequestor if a syntax error occurs. Install the compiled method in the selected class classified under the currently selected message category name. Answer the selector obtained if compilation succeeds, nil otherwise." - | selectedMessageName selector category oldMessageList | - selectedMessageName _ self selectedMessageName. - oldMessageList _ self messageList. - self metaClassIndicated ifTrue: [ - selector _ self selectedClassOrMetaClass parserClass selectorFrom: aString. - ((self selectedClassOrMetaClass includesSelector: selector) not - and: [Metaclass isScarySelector: selector]) - ifTrue: ["A frist-time definition overlaps the protocol of Metaclasses" - (self confirm: (selector bold, ' is used in the existing class system. -Overriding it could cause serious problems. -Is this really what you want to do?')) - ifFalse: [^nil]]]. - selector _ self selectedClassOrMetaClass - compile: aString - classified: (category _ self selectedMessageCategoryName) - notifying: aRequestor. - selector - ifNil: [^ nil]. - selector ~~ selectedMessageName - ifTrue: [ - category = ClassOrganizer nullCategory - ifTrue: [self changed: #classSelectionChanged. - self changed: #classList. - self messageCategoryListIndex: 1]. - self setClassOrganizer. "In case organization not cached" - (oldMessageList includes: selector) - ifFalse: [self changed: #messageList]. - self messageListIndex: (self messageList indexOf: selector)]. - ^ selector! ! -!Compiler methodsFor: 'public access' stamp: 'jmv 3/12/2018 09:04:09' prior: 16821855! - compile: textOrStream in: aClass classified: aCategory notifying: aRequestor ifFail: failBlock - "Answer a MethodNode for the argument, textOrStream. If the - MethodNode can not be created, notify the argument, aRequestor; if - aRequestor is nil, evaluate failBlock instead. The MethodNode is the root - of a parse tree. It can be told to generate a CompiledMethod to be - installed in the method dictionary of the argument, aClass." - - | methodNode | - self from: textOrStream - class: aClass - context: nil - notifying: aRequestor. - category _ aCategory. - methodNode _ self translate: sourceStream noPattern: false ifFail: failBlock. - methodNode encoder requestor: requestor. - ^methodNode! ! -!Compiler methodsFor: 'public access' stamp: 'jmv 3/12/2018 09:08:56' prior: 16821922! - evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock logged: doLog profiled: doProfile - "Compiles the sourceStream into a parse tree, then generates code into - a method. If aContext is not nil, the text can refer to temporaries in that - context (the Debugger uses this). If aRequestor is not nil, then it will receive - a notify:at: message before the attempt to evaluate is aborted. Finally, the - compiled method is invoked from here via withArgs:executeMethod:, hence - the system no longer creates Doit method litter on errors." - - | methodNode method value toLog itsSelection itsSelectionString | - class _ (aContext ifNil: [ receiver ] ifNotNil: [ aContext receiver ]) class. - methodNode _ self compileNoPattern: textOrStream in: class context: aContext notifying: aRequestor ifFail: [^failBlock value]. - method _ methodNode generate. - - "(jmv) Log before evaluating. This way, if the evaluation is halted by whatever reason, it is logged anyway" - doLog ifTrue: [ - toLog _ ((requestor respondsTo: #selection) - and: [ (itsSelection _ requestor selection) notNil - and: [ (itsSelectionString _ itsSelection asString) isEmptyOrNil not ]]) - ifTrue: [ itsSelectionString ] - ifFalse: [ sourceStream contents ]. - SystemChangeNotifier uniqueInstance evaluated: toLog context: aContext]. - - "Evaluate now." - doProfile - ifTrue: [ - AndreasSystemProfiler spyOn: [ - value _ receiver - withArgs: (context ifNil: [#()] ifNotNil: [{context}]) - executeMethod: method ]] - ifFalse: [ - value _ receiver - withArgs: (context ifNil: [#()] ifNotNil: [{context}]) - executeMethod: method ]. - - ^ value! ! - -Compiler removeSelector: #from:class:classified:context:notifying:! - -Compiler removeSelector: #from:class:classified:context:notifying:! - -CodeProvider removeSelector: #validateMessageSource:forSelector:inClass:! - -CodeProvider removeSelector: #validateMessageSource:forSelector:inClass:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3269-CompilationCleanup-JuanVuletich-2018Mar12-12h04m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3269] on 12 March 2018 at 3:44:27 pm'! - -Object subclass: #Scanner - instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable isForTokenization sentInLiterals ' - classVariableNames: 'TypeTable ' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #Scanner category: #'Compiler-Kernel'! -Object subclass: #Scanner - instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable isForTokenization sentInLiterals' - classVariableNames: 'TypeTable' - poolDictionaries: '' - category: 'Compiler-Kernel'! -!Scanner methodsFor: 'multi-character scans' stamp: 'jmv 3/12/2018 15:37:29' prior: 50334869! - xBacktick - "Smalltalk code evaluated at compile time as a literal." - - self step. - buffer reset. - [hereChar == $` - and: [aheadChar == $` - ifTrue: [self step. false] - ifFalse: [true]]] - whileFalse: [ - buffer nextPut: self step. - (hereChar = Scanner doItCharacterValue asCharacter and: [source atEnd]) - ifTrue: [^self offEnd: 'Unmatched back quote']]. - self step. - [ | compiler method methodNode | - compiler _ Compiler new. - methodNode _ compiler compileNoPattern: buffer contents in: UndefinedObject context: nil notifying: nil ifFail: []. - method _ methodNode generate. - "Grab all messages sent while evaluating literal, so the main method will be shown as senders of them" - sentInLiterals addAll: method messages. - "Evaluate now." - token _ nil withArgs: #() executeMethod: method. - ] - on: SyntaxErrorNotification, UndeclaredVariableReference, Error - do: [ :ex | - ex class caseOf: { - [ SyntaxErrorNotification ] -> [ - self notify: 'Can not compile: ', ex errorMessage at: mark]. - [ UndeclaredVariableReference ] -> [ - self notify: 'Can not compile: Variable ''', ex varName, ''' is not declared' at: mark ] - } otherwise: [ - self notify: 'Can not evaluate code: ', ex description at: mark ]]. - tokenType _ #literal! ! -!Scanner methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:05:15' prior: 16904195! - initScanner - - buffer := WriteStream on: (String new: 40). - typeTable := Scanner typeTable. - isForTokenization := false. - sentInLiterals := Set new! ! -!Parser methodsFor: 'public access' stamp: 'jmv 3/12/2018 15:39:43' prior: 16886804! - parse: sourceStream class: class category: aCategory noPattern: noPattern context: ctxt notifying: req ifFail: aBlock - "Answer a MethodNode for the argument, sourceStream, that is the root of - a parse tree. Parsing is done with respect to the argument, class, to find - instance, class, and pool variables; and with respect to the argument, - ctxt, to find temporary variables. Errors in parsing are reported to the - argument, req, if not nil; otherwise aBlock is evaluated. The argument - noPattern is a Boolean that is true if the the sourceStream does not - contain a method header (i.e., for DoIts)." - | methNode repeatNeeded myStream s p | - category _ aCategory. - myStream _ sourceStream. - [ - repeatNeeded _ false. - p _ myStream position. - s _ myStream upToEnd. - myStream position: p. - self encoder init: class context: ctxt notifying: self. - self init: myStream notifying: req failBlock: [ - ^ aBlock value ]. - doitFlag _ noPattern. - failBlock _ aBlock. - [ methNode _ self method: noPattern context: ctxt ] - on: ReparseAfterSourceEditing - do: [ :ex | - repeatNeeded _ true. - myStream _ sourceStreamGetter notNil "Cuis specific. Do not remove!!" - ifTrue: [ requestor perform: sourceStreamGetter ] - ifFalse: [ ReadStream on: requestor text string ]]. - repeatNeeded - ] whileTrue: [ - encoder _ self encoder class new ]. - methNode sourceText: s. - "See #xBacktick" - sentInLiterals do: [ :sym | encoder noteOptimizedSelector: sym ]. - ^ methNode! ! - -Parser removeSelector: #method:context:encoder:! - -Parser removeSelector: #method:context:encoder:! - -Object subclass: #Scanner - instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable isForTokenization sentInLiterals' - classVariableNames: 'TypeTable' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #Scanner category: #'Compiler-Kernel'! -Object subclass: #Scanner - instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable isForTokenization sentInLiterals' - classVariableNames: 'TypeTable' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3270-FixSendersInsideBackticks-JuanVuletich-2018Mar12-15h43m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3269] on 12 March 2018 at 3:58:27 pm'! -!Object methodsFor: 'private' stamp: 'jmv 3/12/2018 15:54:19' prior: 50361286! - primitiveError: aString - "This method is called when the error handling results in a recursion in - calling on error: or halt or halt:." - - | context emergencyEvaluator lines r | - r _ `10@10` extent: (Display extent -20 min: `700@1000`). - lines _ r height // AbstractFont default height. - emergencyEvaluator _ Transcripter newInFrame: r. - emergencyEvaluator - nextPutAll: '***System error handling failed***'; newLine; - nextPutAll: aString; newLine; - nextPutAll: '-------------------------------'; newLine. - context _ thisContext sender sender. - (30 min: lines - 10) timesRepeat: [context ifNotNil: [emergencyEvaluator print: (context _ context sender); newLine]]. - emergencyEvaluator - nextPutAll: '-------------------------------'; newLine; - nextPutAll: 'Type ''revert'' to revert your last method change.'; newLine; - nextPutAll: 'Type ''exit'' to exit the emergency evaluator.'; newLine. - emergencyEvaluator readEvalPrint! ! -!Character methodsFor: 'converting' stamp: 'jmv 3/12/2018 15:47:49' prior: 16800645! - withDiacriticalMark: anUnicodeCodePoint - "Answer the character resulting from adding a diacritical mark (accent) to a letter. - If the result is unsupported in ISO 8859-15, answer the receiver. - Supported diacritical marks are: - U+0300 COMBINING GRAVE ACCENT - U+0301 COMBINING ACUTE ACCENT - U+0302 COMBINING CIRCUMFLEX ACCENT - U+0303 COMBINING TILDE - U+0308 COMBINING DIAERESIS - U+030A COMBINING RING ABOVE - U+030C COMBINING CARON - $a withDiacriticalMark: 16r301 - $N withDiacriticalMark: $~ - $Z withDiacriticalMark: $v - - invalid: - $9 withDiacriticalMark:$v - $A withDiacriticalMark: $v - $Á withDiacriticalMark: $v - $A withDiacriticalMark: 1244 - " - | answer i | - i _ ((anUnicodeCodePoint isNumber - ifTrue: [#(16r300 16r301 16r302 16r303 16r308 16r30A 16r30C)] - ifFalse: [#($` $' $^ $~ $" $° $v)]) indexOf: anUnicodeCodePoint - ) + 1. - answer _ (Character accentedLetters detect: [ :group | group first = self ] ifNone: [ ^self ]) at: i. - ^answer = $- ifFalse: [answer] ifTrue: [self]! ! -!InputSensor methodsFor: 'private' stamp: 'jmv 3/12/2018 15:52:20' prior: 50361318! - primMousePt - "Primitive. Poll the mouse to find out its position. Return a Point. Fail if - event-driven tracking is used instead of polling. Optional. See Object - documentation whatIsAPrimitive." - - - ^ `0@0`! ! -!EventSensor methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:48:41' prior: 50361328! - initialize - "Run the I/O process" - mouseButtons _ 0. - mousePosition _ `0@0`. - self setInterruptKey: (interruptKey ifNil: [$. numericValue bitOr: 16r0800 ]). "cmd-." - interruptSemaphore _ (Smalltalk specialObjectsArray at: 31) ifNil: [Semaphore new]. - self flushAllButDandDEvents. - inputSemaphore _ Semaphore new. - hasInputSemaphore _ false. - - self primSetInputSemaphore: (Smalltalk registerExternalObject: inputSemaphore). - self installInterruptWatcher. - self installEventTickler. - self flushAllButDandDEvents. - - "Attempt to discover whether the input semaphore is actually being signaled." - hasInputSemaphore _ false. - inputSemaphore initSignals! ! -!String methodsFor: 'displaying' stamp: 'jmv 3/12/2018 15:56:28' prior: 50361351! - displayOn: aDisplayMedium - "Display the receiver on the given DisplayMedium. 5/16/96 sw" - - self displayOn: aDisplayMedium at: `0 @ 0`! ! -!Bitmap methodsFor: 'as yet unclassified' stamp: 'jmv 3/12/2018 15:47:42' prior: 50361359! - asByteArray - "Faster way to make a byte array from me. - copyFromByteArray:, if receiver is BigEndian makes equal Bitmap. - Assume receiver bytes-in-word mapping is BigEndian: - Most significant bye of first word in self goes to first position in result. - This means that for a BigEndian 8bpp Form, pixels are in the right order in the ByteArray - - Form lena asGrayForm bits asByteArray copyFrom: 1 to: 4. - (Form lena asGrayForm asFormOfDepth: 8) bits asByteArray copyFrom: 1 to: 4. - (0 to: 3) collect: [ :x | ((Form lena asGrayForm colorAt: x@0) luminance * 255) rounded ]. - " - | f bytes hack | - f _ Form extent: 4@self size depth: 8 bits: self. - bytes _ ByteArray new: self size * 4. - hack _ Form new hackBits: bytes. - Smalltalk isLittleEndian ifTrue: [hack swapEndianness]. - hack copyBits: f boundingBox - from: f - at: `0@0` - clippingBox: hack boundingBox - rule: Form over. - - "f displayOn: hack." - ^ bytes! ! -!Transcripter methodsFor: 'accessing' stamp: 'jmv 3/12/2018 15:57:40' prior: 50361506! - 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]. - textComposition - setModel: (TextModel withText: c asText); - extentForComposing: frame width-8 @9999. - textComposition composeAll. - d _ textComposition usedHeight - frame height. - d > 0 ifTrue: [ - "Scroll up to keep all contents visible" - cb _ textComposition characterBlockAtPoint: - `0@0` + (0@(d+AbstractFont default height)). - self on: (c copyFrom: cb stringIndex to: c size). - readLimit _ position _ collection size. - ^ self endEntry]. - Display fill: (frame insetBy: -2) fillColor: self black; - fill: frame fillColor: self white. - Display getCanvas - textComposition: textComposition - bounds: (`4@4` + frame topLeft extent: Display extent) - color: Color black - selectionColor: Color blue. - DisplayScreen screenUpdateRequired: nil! ! -!Transcripter class methodsFor: 'utilities' stamp: 'jmv 3/12/2018 15:57:42' prior: 50361541! - emergencyEvaluator - (Transcripter newInFrame: `0@0 corner: 320@200`) - show: 'Type ''exit'' to exit the emergency evaluator.'; - readEvalPrint! ! -!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'jmv 3/12/2018 15:55:35' prior: 50361550! - defaultAction - - | delta textFrame barFrame outerFrame result range width filledWidth f h textWidth textForm innerBarFrame oldFilledWidth oldFilledWidth2 prevContents | - f _ AbstractFont default. - h _ f height * 3//2. - textWidth _ (f widthOfString: progressTitle) + h. - width _ 150 max: textWidth. - - textForm _ Form extent: width@h depth: 32. - textForm fillBlack. - textForm fillWhite: (textForm boundingBox insetBy: 2). - progressTitle displayOn: textForm at: (width-textWidth+h//2@4). - barFrame _ Rectangle center: aPoint extent: width@h. - textFrame _ `0@0` extent: width@h. - textFrame _ textFrame - aligned: textFrame bottomCenter - with: barFrame topCenter + `0@2`. - outerFrame _ barFrame merge: textFrame. - delta _ outerFrame amountToTranslateWithin: Display boundingBox. - barFrame _ barFrame translatedBy: delta. - textFrame _ textFrame translatedBy: delta. - outerFrame _ outerFrame translatedBy: delta. - prevContents _ Form fromDisplay: outerFrame. - range _ maxVal = minVal ifTrue: [1] ifFalse: [maxVal - minVal]. "Avoid div by 0" - innerBarFrame _ barFrame insetBy: 2. - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - oldFilledWidth _ 0. - oldFilledWidth2 _ 0. - result _ workBlock value: "Supply the bar-update block for evaluation in the work block" - [ :barVal | - barVal - ifNotNil: [ currentVal _ barVal ] - ifNil: [ - currentVal _ currentVal + 1. - currentVal >= maxVal - ifTrue: [ currentVal _ minVal ]]. - filledWidth _ ((barFrame width-4) asFloat * ((currentVal-minVal) asFloat / range min: 1.0)) asInteger. - filledWidth > oldFilledWidth ifTrue: [ - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - Display fillGray: (barFrame topLeft + `2@2` extent: filledWidth@17). - filledWidth -200 > oldFilledWidth2 - ifFalse: [ - "Usually just request an update, to be done asynchronously." - DisplayScreen screenUpdateRequired: outerFrame ] - ifTrue: [ - "Once in a while, force a real screen update (warning: really slow on MacOS if done too often)" - Display forceToScreen: outerFrame. oldFilledWidth2 _ filledWidth ]. - oldFilledWidth _ filledWidth ]]. - prevContents displayAt: outerFrame topLeft. - self resume: result! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'jmv 3/12/2018 15:56:15' prior: 50382568! - xBacktick - "Smalltalk code evaluated at compile time as a literal." - - self step. - buffer reset. - [hereChar == $` - and: [aheadChar == $` - ifTrue: [self step. false] - ifFalse: [true]]] - whileFalse: [ - buffer nextPut: self step. - (hereChar = Scanner doItCharacterValue asCharacter and: [source atEnd]) - ifTrue: [^self offEnd: 'Unmatched back quote']]. - self step. - [ | compiler method methodNode | - compiler _ Compiler new. - methodNode _ compiler compileNoPattern: buffer contents in: UndefinedObject context: nil notifying: nil ifFail: []. - method _ methodNode generate. - "Grab all messages sent while evaluating literal, so the main method will be shown as senders of them" - sentInLiterals addAll: method messages. - "Evaluate now." - token _ nil withArgs: #() executeMethod: method. - ] - on: SyntaxErrorNotification, UndeclaredVariableReference, Error - do: [ :ex | - ex class caseOf: { - [ SyntaxErrorNotification ] -> [ - self notify: 'Can not compile: ', ex errorMessage at: mark]. - [ UndeclaredVariableReference ] -> [ - self notify: 'Can not compile: Variable ''', ex varName, ''' is not declared' at: mark ] - } otherwise: [ - self notify: 'Can not evaluate code: ', ex description at: mark ]]. - tokenType _ #literal! ! -!Scanner class methodsFor: 'cached class state' stamp: 'jmv 3/12/2018 15:56:19' prior: 50334743! - initTypeTable - | newTable | - newTable := Array new: 256 withAll: #xIllegal. "default" - newTable atAll: #(9 10 12 13 32 ) put: #xDelimiter. "tab lf ff cr space" - - 1 to: 255 - do: [:index | - (Character numericValue: index) isValidInIdentifiers - ifTrue: [ - "Digits and $_ are overwritten later" - newTable at: index put: #xLetter ]]. - - newTable atAll: ($0 numericValue to: $9 numericValue) put: #xDigit. - newTable atAll: '!!%&+-*/\±×÷¬­¯,<=>”•–—˜™š›œ«»?@~€‚ƒŽ‘’“žŸ°·' asByteArray put: #xBinary. - - newTable at: Scanner doItCharacterValue put: #doIt. - newTable at: $" numericValue put: #xDoubleQuote. - newTable at: $# numericValue put: #xLitQuote. - newTable at: $$ numericValue put: #xDollar. - newTable at: $' numericValue put: #xSingleQuote. - newTable at: $` numericValue put: #xBacktick. - newTable at: $: numericValue put: #xColon. - newTable at: $( numericValue put: #leftParenthesis. - newTable at: $) numericValue put: #rightParenthesis. - newTable at: $. numericValue put: #period. - newTable at: $; numericValue put: #semicolon. - newTable at: $[ numericValue put: #leftBracket. - newTable at: $] numericValue put: #rightBracket. - newTable at: ${ numericValue put: #leftBrace. - newTable at: $} numericValue put: #rightBrace. - newTable at: $^ numericValue put: #upArrow. - newTable at: $_ numericValue put: #xUnderscore. - newTable at: $| numericValue put: #verticalBar. - TypeTable := newTable "bon voyage!!" - - " - Scanner initTypeTable - "! ! -!LiteralNode methodsFor: 'printing' stamp: 'jmv 3/12/2018 15:52:43' prior: 50370925! - printOn: aStream indent: level - key isVariableBinding - ifTrue: [ - key key isNil - ifTrue: [ - aStream - nextPutAll: '###'; - nextPutAll: key value soleInstance name ] - ifFalse: [ - aStream - nextPutAll: '##'; - nextPutAll: key key ]] - ifFalse: [ - key isLiteral - ifTrue: [ | isComplex | - isComplex := false. - key isArray ifTrue: [ - isComplex := key anySatisfy: [ :ea | - ea isArray ]]. - "Is it complex? (i.e. array of arrays)" - isComplex - ifTrue: [ - aStream - nextPut: $#; - nextPut: $(. - key do: [ :ea | - aStream newLineTab: (1 max: level + 1). - ea storeOn: aStream ]. - aStream newLineTab: (1 max: level). - aStream nextPut: $) ] - ifFalse: [ key storeOn: aStream ]] - ifFalse: [ - "Need to generate code for stuff that is in a CompiledMethod literal - but is not understood as a literal by the Compiler. - Well, then it is because it was generated using backticks!!" - aStream nextPut: $`. - key storeOn: aStream. - aStream nextPut: $` ]]! ! -!TextEditor methodsFor: 'editing keys' stamp: 'jmv 3/12/2018 15:57:29' prior: 50334914! - enclose: aKeyboardEvent - "Insert or remove bracket characters around the current selection." - "This is a user command, and generates undo" - - | left right startIndex stopIndex oldSelection which | - startIndex _ self startIndex. - stopIndex _ self stopIndex. - oldSelection _ self selection. - which _ '([<{"''`' indexOf: aKeyboardEvent keyCharacter ifAbsent: [ ^true ]. - left _ '([<{"''`' at: which. - right _ ')]>}"''`' at: which. - ((startIndex > 1 and: [stopIndex <= model textSize]) - and: [ (model actualContents at: startIndex-1) = left and: [(model actualContents at: stopIndex) = right]]) - ifTrue: [ - "already enclosed; strip off brackets" - self selectFrom: startIndex-1 to: stopIndex. - self replaceSelectionWith: oldSelection] - ifFalse: [ - "not enclosed; enclose by matching brackets" - self replaceSelectionWith: - (Text string: (String with: left) attributes: emphasisHere), - oldSelection, - (Text string: (String with: right) attributes: emphasisHere). - self selectFrom: startIndex+1 to: stopIndex]. - ^ true! ! -!TextEditor class methodsFor: 'keyboard shortcut tables' stamp: 'jmv 3/12/2018 15:57:33' prior: 50334950! - basicCmdShortcutsSpec - " - Editor initialize - " - - "arranged in QWERTY keyboard order" - ^#( - #( $( #enclose: 'Enclose within ( and ), or remove enclosing ( and )') - #( $[ #enclose: 'Enclose within [ and ], or remove enclosing [ and ]') - #( ${ #enclose: 'Enclose within { and }, or remove enclosing { and }') - #( $' #enclose: 'Enclose within single quotes, or remove enclosing single quotes') - #( $" #enclose: 'Enclose within double quotes, or remove enclosing double quotes') - #( $` #enclose: 'Enclose within backticks, or remove enclosing backticks') - #( $< #enclose: 'Enclose within < and >, or remove enclosing < and >') - - #( $a #selectAll: 'Select all') - #( $f #find: 'Find') - #( $g #findAgain: 'Find again') - #( $h #help: 'Open this help') - #( $j #setSearchString: 'Set selection as search string for find again') - - #( $z #undo: 'Undo (multiple levels)') - #( $x #cut: 'Cut selection and store it in the Clipboard') - #( $c #copySelection: 'Copy selection to the Clipboard') - #( $v #paste: 'Paste Clipboard contents') - - #( $R #indent: 'Indent (move selection one tab-stap right)') - #( $Y #makeUppercase: 'Force selection to uppercase') - #( $U #changeLineEndsToLf: 'Convert line endings to LF characters (Cuis convention) in selection') - - #( $H #cursorTopHome: 'Move cursor to start of text') - #( $L #outdent: 'Outdent (move selection one tab-stop left)') - - #( $Z #redo: 'Redo (multiple levels)') - #( $X #makeLowercase: 'Force selection to lowercase') - #( $C #compareToClipboard: 'Compare argument to clipboard') - - #( $ #selectWord: 'Select the current word as with double clicking') - )! ! -!SmalltalkEditor methodsFor: 'new selection' stamp: 'jmv 3/12/2018 15:56:25' prior: 50335008! - selectWord - "Select delimited text or word--the result of double-clicking." - - | leftDelimiters rightDelimiters | - "Warning. Once me (jmv) added Character crCharacter to the delimiters, to make double-click at and of line select whole line. - This had the bad effect that if a class name is the last word of a line, double-click would correctly select it, but after that, - doing ctrl-b to browse it would select the whole line..." - leftDelimiters _ '([{<|''"`'. - rightDelimiters _ ')]}>|''"`'. - ^self selectWordLeftDelimiters: leftDelimiters rightDelimiters: rightDelimiters! ! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 3/12/2018 15:55:41' prior: 50361625! - staggerOffset - ^`6 @ 20`! ! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 3/12/2018 15:55:48' prior: 50361630! - standardWindowExtent - "Answer the standard default extent for new windows. " - - | effectiveExtent width strips height grid allowedArea maxLevel | - effectiveExtent _ self maximumUsableArea extent - - (self scrollBarSetback @ self screenTopSetback). - Preferences reverseWindowStagger ifTrue: - ["NOTE: following copied from strictlyStaggeredInitialFrameFor:" - allowedArea _ self maximumUsableArea insetBy: ( - self scrollBarSetback @ self screenTopSetback extent: `0@0` - ). - "Number to be staggered at each corner (less on small screens)" - maxLevel _ allowedArea area > 700000 ifTrue: [3] ifFalse: [2]. - "Amount by which to stagger (less on small screens)" - grid _ allowedArea area > 700000 ifTrue: [40] ifFalse: [20]. - ^ (allowedArea extent - (grid*(maxLevel+1*2) + (grid//2))) min: `52@40` * Preferences standardCodeFont height ]. - width _ (strips _ self windowColumnsDesired) > 1 - ifTrue: - [effectiveExtent x // strips] - ifFalse: - [(3 * effectiveExtent x) // 4]. - height _ (strips _ self windowRowsDesired) > 1 - ifTrue: - [effectiveExtent y // strips] - ifFalse: - [(3 * effectiveExtent y) //4]. - ^ width @ height - -" -RealEstateAgent standardWindowExtent -"! ! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 3/12/2018 15:55:52' prior: 50361671! - strictlyStaggeredInitialFrameFor: aStandardSystemView initialExtent: initialExtent world: aWorld - "This method implements a staggered window placement policy that I (di) like. - Basically it provides for up to 4 windows, staggered from each of the 4 corners. - The windows are staggered so that there will always be a corner visible." - - | allowedArea grid initialFrame otherFrames cornerSel corner delta putativeCorner free maxLevel | - allowedArea := (self maximumUsableAreaInWorld: aWorld) - insetBy: (self scrollBarSetback @ self screenTopSetback extent: `0 @ 0`). - "Number to be staggered at each corner (less on small screens)" - maxLevel := allowedArea area > 300000 ifTrue: [3] ifFalse: [2]. - "Amount by which to stagger (less on small screens)" - grid := allowedArea area > 500000 ifTrue: [40] ifFalse: [20]. - initialFrame := `0 @ 0` extent: initialExtent. - "min: (allowedArea extent - (grid*(maxLevel+1*2) + (grid//2)))) - min: 600@400" - otherFrames := (SystemWindow windowsIn: aWorld satisfying: [ :w | w visible and: [w isCollapsed not]]) - collect: [:w | w morphBoundsInWorld]. - otherFrames _ otherFrames reject: [ :f | f isNil ]. - 0 to: maxLevel do: [ :level | - 1 to: 4 do: [:ci | - cornerSel := #(#topLeft #topRight #bottomRight #bottomLeft) at: ci. - corner := allowedArea perform: cornerSel. - "The extra grid//2 in delta helps to keep title tabs distinct" - delta := ((maxLevel - level) * grid + (grid // 2)) @ (level * grid). - 1 to: ci - 1 do: [ :i | delta _ delta y negated @ delta x ]. "slow way" - putativeCorner := corner + delta. - free := true. - otherFrames do: [ :w | - free := free & ((w perform: cornerSel) ~= putativeCorner)]. - free - ifTrue: [ - ^(initialFrame aligned: (initialFrame perform: cornerSel) - with: putativeCorner) translatedAndSquishedToBeWithin: allowedArea]]]. - "If all else fails..." - ^(self scrollBarSetback @ self screenTopSetback - extent: initialFrame extent) translatedAndSquishedToBeWithin: allowedArea! ! -!Form methodsFor: 'accessing' stamp: 'jmv 3/12/2018 15:50:15' prior: 50361737! - offset - ^offset ifNil: [`0@0`]! ! -!Form methodsFor: 'analyzing' stamp: 'jmv 3/12/2018 15:50:32' prior: 50361741! - primCountBits - "Count the non-zero pixels of this form." - self depth > 8 ifTrue: [ - ^(self asFormOfDepth: 8) primCountBits]. - ^ (BitBlt toForm: self) - fillColor: (Bitmap with: 0); - destRect: (`0@0` extent: width@height); - combinationRule: 32; - copyBits! ! -!Form methodsFor: 'analyzing' stamp: 'jmv 3/12/2018 15:50:49' prior: 50361752! - tallyPixelValuesInRect: destRect into: valueTable - "Tally the selected pixels of this Form into valueTable, a Bitmap of depth 2^depth similar to a color map. Answer valueTable." - - (BitBlt toForm: self) - sourceForm: self; "src must be given for color map ops" - sourceOrigin: `0@0`; - colorMap: valueTable; - combinationRule: 33; - destRect: destRect; - copyBits. - ^ valueTable - -" -Move a little rectangle around the screen and print its tallies... - | r tallies nonZero | -Cursor blank showWhile: [ -[Sensor isAnyButtonPressed] whileFalse: - [r _ Sensor mousePoint extent: 10@10. - Display border: (r expandBy: 2) width: 2 rule: Form reverse fillColor: nil. - tallies _ (Display copy: r) tallyPixelValues. - nonZero _ (1 to: tallies size) select: [:i | (tallies at: i) > 0] - thenCollect: [:i | (tallies at: i) -> (i-1)]. - Display fill: (0@0 extent: Display width@20) fillColor: Color white. - nonZero printString , ' ' displayAt: 0@0. - Display border: (r expandBy: 2) width: 2 rule: Form reverse fillColor: nil]] -"! ! -!Form methodsFor: 'analyzing' stamp: 'jmv 3/12/2018 15:50:58' prior: 50361787! - xTallyPixelValue: pv orNot: not - "Return an array of the number of pixels with value pv by x-value. - Note that if not is true, then this will tally those different from pv." - | cm slice countBlt copyBlt | - cm _ self newColorMap. "Map all colors but pv to zero" - not ifTrue: [cm atAllPut: 1]. "... or all but pv to one" - cm at: pv+1 put: 1 - (cm at: pv+1). - slice _ Form extent: 1@height. - copyBlt _ (BitBlt destForm: slice sourceForm: self - combinationRule: Form over - destOrigin: `0@0` sourceOrigin: `0@0` extent: 1 @ slice height - clipRect: slice boundingBox) - colorMap: cm. - countBlt _ (BitBlt toForm: slice) - fillColor: (Bitmap with: 0); - destRect: (`0@0` extent: slice extent); - combinationRule: 32. - ^ (0 to: width-1) collect: [ :x | - copyBlt sourceOrigin: x@0; copyBits. - countBlt copyBits]! ! -!Form methodsFor: 'analyzing' stamp: 'jmv 3/12/2018 15:51:05' prior: 50361816! - yTallyPixelValue: pv orNot: not - "Return an array of the number of pixels with value pv by y-value. - Note that if not is true, then this will tally those different from pv." - | cm slice copyBlt countBlt | - cm _ self newColorMap. "Map all colors but pv to zero" - not ifTrue: [cm atAllPut: 1]. "... or all but pv to one" - cm at: pv+1 put: 1 - (cm at: pv+1). - slice _ Form extent: width@1. - copyBlt _ (BitBlt destForm: slice sourceForm: self - combinationRule: Form over - destOrigin: `0@0` sourceOrigin: `0@0` extent: slice width @ 1 - clipRect: slice boundingBox) - colorMap: cm. - countBlt _ (BitBlt toForm: slice) - fillColor: (Bitmap with: 0); - destRect: (`0@0` extent: slice extent); - combinationRule: 32. - ^ (0 to: height-1) collect: [ :y | - copyBlt sourceOrigin: 0@y; copyBits. - countBlt copyBits]! ! -!Form methodsFor: 'coloring' stamp: 'jmv 3/12/2018 15:49:54' prior: 50361845! - fillShape: aShapeForm fillColor: aColor - "Fill a region corresponding to 1 bits in aShapeForm with aColor" - - ^ self fillShape: aShapeForm fillColor: aColor at: `0@0`! ! -!Form methodsFor: 'coloring' stamp: 'jmv 3/12/2018 15:49:58' prior: 50361853! - fillShape: aShapeForm fillColor: aColor at: location - "Fill a region corresponding to 1 bits in aShapeForm with aColor" - - ((BitBlt destForm: self sourceForm: aShapeForm fillColor: aColor - combinationRule: Form paint - destOrigin: location + aShapeForm offset sourceOrigin: `0@0` - extent: self extent clipRect: self boundingBox) - colorMap: (Bitmap with: 0 with: 16rFFFFFFFF)) - copyBits! ! -!Form methodsFor: 'color mapping' stamp: 'jmv 3/12/2018 15:50:08' prior: 50361868! - mapColor: oldColor to: newColor - "Make all pixels of the given color in this Form to the given new color." - "Warnings: This method modifies the receiver. It may lose some color accuracy on 32-bit Forms, since the transformation uses a color map with only 15-bit resolution." - - | map | - map _ (Color cachedColormapFrom: self depth to: self depth) copy. - map at: (oldColor indexInMap: map) put: (newColor pixelWordForDepth: self depth). - (BitBlt toForm: self) - sourceForm: self; - sourceOrigin: `0@0`; - combinationRule: Form over; - destX: 0 destY: 0 width: width height: height; - colorMap: map; - copyBits! ! -!Form methodsFor: 'converting' stamp: 'jmv 3/12/2018 15:49:08' prior: 50361890! - asFormOfDepth: d - | newForm source | - d = depth ifTrue: [ ^self ]. - source _ (self depth = 32 and: [ d abs < 32 ]) - ifTrue: [ self copy convertAlphaToZeroValueTransparency ] - ifFalse: [ self ]. - newForm _ Form extent: source extent depth: d. - (BitBlt toForm: newForm) - colorMap: (source colormapIfNeededFor: newForm); - copy: source boundingBox - from: `0@0` in: source - fillColor: nil rule: Form over. - "If we build a 32bpp from one of smaller depth, - it will have zero in the alpha channel (until BitBlt is fixed!!)" - (newForm depth = 32 and: [self depth < 32]) ifTrue: [ - newForm fixAlpha ]. - ^ newForm! ! -!Form methodsFor: 'converting' stamp: 'jmv 3/12/2018 15:49:11' prior: 50361912! - asGrayForm - | answer map | - - "For lower bit depths, the 15 bit ColorMap loses no information, - and answers the real #luminance of each pixel." - self depth < 32 ifTrue: [ - answer _ GrayForm extent: width@height. - map _ self colormapIfNeededForGray8bpp. - (BitBlt toForm: answer) - colorMap: map; - copy: self boundingBox - from: `0@0` in: self - fillColor: nil rule: Form over. - answer offset: self offset. - ^ answer ]. - - "For 32bpp, the approach below would use just 5bits per component. - Generally it is best to extract a component in full 8bpp and keep full dynamic range. - Green usually is a good choice." - ^ self asGrayForm: 3! ! -!Form methodsFor: 'converting' stamp: 'jmv 3/12/2018 15:49:14' prior: 50361935! - asGrayForm: componentIndex -"Native depth" - "Assume the receiver is a grayscale image. Return a GrayForm computed by extracting the brightness levels of one color component. This technique allows a 32-bit Form to be converted to an 8-bit GrayForm to save space while retaining a full 255 levels of gray. (The usual colormapping technique quantizes to 8, 16, or 32 levels, which loses information.) - - If component = 1, take the alpha component - If component = 2, take the red component - If component = 3, take the green component - If component = 4, take the blue component - " - | f32 result map mask shift | - self depth = 32 ifFalse: [ - f32 _ Form extent: width@height depth: 32. - self displayOn: f32. - ^ f32 asGrayForm: componentIndex ]. - - result _ GrayForm extent: width@height. - shift _ #(-24 -16 -8 0) at: componentIndex. - mask _ #(16rFF000000 16rFF0000 16rFF00 16rFF) at: componentIndex. - map _ ColorMap masks: { mask. 0. 0. 0 } shifts: { shift. 0. 0. 0 }. - (BitBlt toForm: result) - sourceForm: self; - combinationRule: Form over; - colorMap: map; - sourceRect: (`0@0` extent: width@height); - destOrigin: `0@0`; - copyBits. - ^ result! ! -!Form methodsFor: 'converting' stamp: 'jmv 3/12/2018 15:49:21' prior: 50361974! - asGrayScaleAndTransparent: componentIndex -"Native depth" - "Assume the receiver is a grayscale image. Return a grayscale ColorForm computed by extracting the brightness levels of one color component. This technique allows a 32-bit Form to be converted to an 8-bit ColorForm to save space while retaining a full 255 levels of gray. (The usual colormapping technique quantizes to 8, 16, or 32 levels, which loses information.) - - If component = 1, take the alpha component - If component = 2, take the red component - If component = 3, take the green component - If component = 4, take the blue component - " - | f32 result map mask shift | - self depth = 32 ifFalse: [ - f32 _ Form extent: width@height depth: 32. - self displayOn: f32. - ^ f32 asGrayScaleAndTransparent: componentIndex ]. - - result _ ColorForm grayScaleAndTransparentExtent: width@height. - shift _ #(-24 -16 -8 0) at: componentIndex. - mask _ #(16rFF000000 16rFF0000 16rFF00 16rFF) at: componentIndex. - map _ ColorMap masks: { mask. 0. 0. 0 } shifts: { shift. 0. 0. 0 }. - (BitBlt toForm: result) - sourceForm: self; - combinationRule: Form over; - colorMap: map; - sourceRect: (`0@0` extent: width@height); - destOrigin: `0@0`; - copyBits. - - "final BitBlt to zero-out pixels that were truely transparent in the original" - map _ Bitmap new: 512. - map at: 1 put: 16rFF. - (BitBlt toForm: result) - sourceForm: self; - sourceRect: self boundingBox; - destOrigin: `0@0`; - combinationRule: Form erase; - colorMap: map; - copyBits. - ^ result! ! -!Form methodsFor: 'converting' stamp: 'jmv 3/12/2018 15:50:03' prior: 50362024! - icon - "Answer a 16 x 16 icon of myself" - - ^self magnifyTo: `16 @ 16`! ! -!Form methodsFor: 'copying' stamp: 'jmv 3/12/2018 15:49:28' prior: 50362029! - contentsOfArea: aRect into: newForm - "Return a new form which derives from the portion of the original form delineated by aRect." - ^ newForm copyBits: aRect from: self at: `0@0` - clippingBox: newForm boundingBox rule: Form over! ! -!Form methodsFor: 'copying' stamp: 'jmv 3/12/2018 15:49:31' prior: 50362039! - copy: aRect - "Return a new form which derives from the portion of the original form delineated by aRect." - | newForm | - newForm _ self class extent: aRect extent depth: depth. - ^ newForm copyBits: aRect from: self at: `0@0` - clippingBox: newForm boundingBox rule: Form over! ! -!Form methodsFor: 'copying' stamp: 'jmv 3/12/2018 15:49:34' prior: 50362051! - copyBits: sourceForm at: destOrigin translucent: factor - "Make up a BitBlt table and copy the bits with the given colorMap." - (BitBlt - destForm: self - sourceForm: sourceForm - combinationRule: 30 - destOrigin: destOrigin - sourceOrigin: `0@0` - extent: sourceForm extent - clipRect: self boundingBox) - copyBitsTranslucent: ((0 max: (factor*255.0) asInteger) min: 255) -" - | f f2 f3 | f _ Form fromUser. f2 _ Form fromDisplay: (0@0 extent: f extent). f3 _ f2 copy. -0.0 to: 1.0 by: 1.0/32 do: - [:t | f3 _ f2 copy. f3 copyBits: f at: 0@0 translucent: t. - f3 displayAt: 0@0. (Delay forMilliseconds: 100) wait]. -"! ! -!Form methodsFor: 'display box access' stamp: 'jmv 3/12/2018 15:49:24' prior: 50362073! -boundingBox - ^ Rectangle - origin: `0 @ 0` - corner: width @ height! ! -!Form methodsFor: 'displaying' stamp: 'jmv 3/12/2018 15:50:23' prior: 50362078! - paintBits: sourceForm at: destOrigin translucent: factor - "Make up a BitBlt table and copy the bits with the given colorMap." - (BitBlt destForm: self - sourceForm: sourceForm - combinationRule: 31 - destOrigin: destOrigin - sourceOrigin: `0@0` - extent: sourceForm extent - clipRect: self boundingBox) - copyBitsTranslucent: ((0 max: (factor*255.0) asInteger) min: 255) -" - | f f2 f3 | f _ Form fromUser. f replaceColor: f dominantColor withColor: Color transparent. -f2 _ Form fromDisplay: (0@0 extent: f extent). f3 _ f2 copy. -0.0 to: 1.0 by: 1.0/32 do: - [:t | f3 _ f2 copy. f3 paintBits: f at: 0@0 translucent: t. - f3 displayAt: 0@0. (Delay forMilliseconds: 100) wait]. -"! ! -!Form methodsFor: 'displaying-generic' stamp: 'jmv 3/12/2018 15:49:40' prior: 50362102! - displayOn: aDisplayMedium - "Simple default display in order to see the receiver in the upper left - corner of screen." - - self displayOn: aDisplayMedium at: `0 @ 0`! ! -!Form methodsFor: 'filling' stamp: 'jmv 3/12/2018 15:49:45' prior: 50362110! - eraseShape: bwForm - "use bwForm as a mask to clear all pixels where bwForm has 1's" - ((BitBlt destForm: self sourceForm: bwForm - combinationRule: Form erase1bitShape "Cut a hole in the picture with my mask" - destOrigin: bwForm offset - sourceOrigin: `0@0` - extent: self extent clipRect: self boundingBox) - colorMap: (Bitmap with: 0 with: 16rFFFFFFFF)) - copyBits! ! -!Form methodsFor: 'filling' stamp: 'jmv 3/12/2018 15:49:51' prior: 50362125! -fill: aRectangle rule: anInteger fillColor: aForm - "Replace a rectangular area of the receiver with the pattern described by aForm - according to the rule anInteger." - (BitBlt toForm: self) - copy: aRectangle - from: `0@0` in: nil - fillColor: aForm rule: anInteger! ! -!Form methodsFor: 'image manipulation' stamp: 'jmv 3/12/2018 15:50:44' prior: 50362137! - smear: dir distance: dist - "Smear any black pixels in this form in the direction dir in Log N steps" - | skew bb | - bb _ BitBlt destForm: self sourceForm: self - combinationRule: Form under destOrigin: `0@0` sourceOrigin: `0@0` - extent: self extent clipRect: self boundingBox. - skew _ 1. - [skew < dist] whileTrue: [ - bb destOrigin: dir*skew; copyBits. - skew _ skew+skew]! ! -!Form methodsFor: 'transitions' stamp: 'jmv 3/12/2018 15:50:19' prior: 50362152! - pageWarp: otherImage at: topLeft forward: forward - "Produce a page-turning illusion that gradually reveals otherImage - located at topLeft in this form. - forward == true means turn pages toward you, else away. [ignored for now]" - | pageRect oldPage nSteps buffer p leafRect sourceQuad warp oldBottom d | - pageRect _ otherImage boundingBox. - oldPage _ self copy: (pageRect translatedBy: topLeft). - (forward ifTrue: [oldPage] ifFalse: [otherImage]) - border: pageRect - widthRectangle: (Rectangle - left: 0 - right: 2 - top: 1 - bottom: 1) - rule: Form over - fillColor: Color black. - oldBottom _ self copy: ((pageRect bottomLeft + topLeft) extent: (pageRect width@(pageRect height//4))). - nSteps _ 8. - buffer _ Form extent: otherImage extent + (0@(pageRect height//4)) depth: self depth. - d _ pageRect topLeft + (0@(pageRect height//4)) - pageRect topRight. - 1 to: nSteps-1 do: - [:i | forward - ifTrue: [buffer copy: pageRect from: otherImage to: `0@0` rule: Form over. - p _ pageRect topRight + (d * i // nSteps)] - ifFalse: [buffer copy: pageRect from: oldPage to: `0@0` rule: Form over. - p _ pageRect topRight + (d * (nSteps-i) // nSteps)]. - buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over. - leafRect _ pageRect topLeft corner: p x @ (pageRect bottom + p y). - sourceQuad _ Array with: pageRect topLeft - with: pageRect bottomLeft + (0@p y) - with: pageRect bottomRight - with: pageRect topRight - (0@p y). - warp _ (WarpBlt toForm: buffer) - clipRect: leafRect; - sourceForm: (forward ifTrue: [oldPage] ifFalse: [otherImage]); - combinationRule: Form paint. - warp copyQuad: sourceQuad toRect: leafRect. - self copy: buffer boundingBox from: buffer to: topLeft rule: Form over. - Display forceToScreen. - ]. - - buffer copy: pageRect from: otherImage to: `0@0` rule: Form over. - buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over. - self copy: buffer boundingBox from: buffer to: topLeft rule: Form over. - Display forceToScreen. -" -1 to: 4 do: [:corner | Display pageWarp: - (Form fromDisplay: (10@10 extent: 200@300)) reverse - at: 10@10 forward: false] -"! ! -!Form methodsFor: 'private' stamp: 'jmv 3/12/2018 15:49:37' prior: 50362223! - copyFromByteArray: bigEndianByteArray - "This method should work with either byte orderings. - See comment at Bitmap>>#asByteArray - Also see #copyFromByteArray2:to:" - - | myHack byteHack | - myHack := Form new hackBits: bits. - byteHack := Form new hackBits: bigEndianByteArray. - "We are passing a ByteArray instead of a Words object. Will be accessed according to native endianness." - Smalltalk isLittleEndian = self isLittleEndian ifFalse: [byteHack swapEndianness]. - byteHack displayOn: myHack at: `0 @ 0` rule: Form over! ! -!Form methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:50:00' prior: 50362242! - fromDisplay: aRectangle - "Create a virtual bit map from a user specified rectangular area on the - display screen. Reallocates bitmap only if aRectangle ~= the receiver's - extent." - - (width = aRectangle width and: [height = aRectangle height]) - ifFalse: [self setExtent: aRectangle extent depth: depth]. - self - copyBits: (aRectangle origin extent: self extent) - from: Display - at: `0 @ 0` - clippingBox: self boundingBox - rule: Form over! ! -!Form methodsFor: 'encoding' stamp: 'jmv 3/12/2018 15:49:03' prior: 50362259! - addDeltasFrom: previousForm - - (BitBlt - destForm: self - sourceForm: previousForm - fillColor: nil - combinationRule: Form reverse - destOrigin: `0@0` - sourceOrigin: `0@0` - extent: self extent - clipRect: self boundingBox) copyBits. - ^self! ! -!Form class methodsFor: 'instance creation' stamp: 'jmv 3/12/2018 15:51:12' prior: 50362270! - dotOfSize: diameter - "Create a form which contains a round black dot." - | radius form bb rect centerX centerY centerYBias centerXBias radiusSquared xOverY maxy dx | - radius _ diameter//2. - form _ self extent: diameter@diameter offset: `0@0` - radius. - bb _ (BitBlt toForm: form) - sourceX: 0; sourceY: 0; - combinationRule: Form over; - fillColor: Color black. - rect _ form boundingBox. - centerX _ rect center x. - centerY _ rect center y. - centerYBias _ rect height odd ifTrue: [0] ifFalse: [1]. - centerXBias _ rect width odd ifTrue: [0] ifFalse: [1]. - radiusSquared _ (rect height asFloat / 2.0) squared - 0.01. - xOverY _ rect width asFloat / rect height asFloat. - maxy _ rect height - 1 // 2. - - "First do the inner fill, and collect x values" - 0 to: maxy do: [ :dy | - dx _ ((radiusSquared - (dy * dy) asFloat) sqrt * xOverY) truncated. - bb destX: centerX - centerXBias - dx - destY: centerY - centerYBias - dy - width: dx + dx + centerXBias + 1 - height: 1; - copyBits. - bb destY: centerY + dy; - copyBits]. - ^ form -" -Time millisecondsToRun: - [1 to: 20 do: [:i | (Form dotOfSize: i) displayAt: (i*20)@(i*20)]] -"! ! -!Form class methodsFor: 'examples' stamp: 'jmv 3/12/2018 15:51:17' prior: 50362308! - toothpaste: diam - " - Display restoreAfter: [Form toothpaste: 30] - " - "Not completely unlike the ST-80 implementation :) - Original comment: - Draws wormlike lines by laying down images of spheres. - See Ken Knowlton, Computer Graphics, vol. 15 no. 4 p352. - Draw with mouse button down; terminate by option-click." - | point queue color q colors colr colr2 | - colors _ Color red wheel: 12. - color _ 8. - [ true ] whileTrue: [ - queue _ OrderedCollection new: 32. - 16 timesRepeat: [queue addLast: `-40@-40`]. - Sensor waitButton. - Sensor isMouseButton2Pressed ifTrue: [^ self]. - point _ Sensor mousePoint. - colr _ colors atWrap: (color _ color + 5). "choose increment relatively prime to colors size" - colr2 _ colr alpha: 0.3. - [Sensor isMouseButton1Pressed or: [queue size > 0]] whileTrue: [ - point _ point * 4 + Sensor mousePoint // 5. - point _ point. - Form fakeSphereAt: point diameter: diam color: colr. - (q _ queue removeFirst) ifNil: [^ self]. "exit" - Form fakeSphereAt: q diameter: diam color: colr2. - Sensor isMouseButton1Pressed ifTrue: [queue addLast: point]]]! ! -!ColorForm methodsFor: 'color manipulation' stamp: 'jmv 3/12/2018 15:47:55' prior: 50362345! - asGrayForm - "Build an optimal GrayForm, - for any color palette in the receiver." - | answer map | - answer _ GrayForm extent: width@height. - map _ self colormapIfNeededForGray8bpp. - (BitBlt toForm: answer) - colorMap: map; - copy: self boundingBox - from: `0@0` in: self - fillColor: nil rule: Form over. - ^ answer! ! -!ColorForm methodsFor: 'copying' stamp: 'jmv 3/12/2018 15:47:59' prior: 50362358! - copy: aRect - "Return a new ColorForm containing the portion of the receiver delineated by aRect." - - | newForm | - newForm _ self class extent: aRect extent depth: depth. - ((BitBlt - destForm: newForm - sourceForm: self - combinationRule: Form over - destOrigin: `0@0` - sourceOrigin: aRect origin - extent: aRect extent - clipRect: newForm boundingBox) - colorMap: nil) copyBits. - colors ifNotNil: [newForm colors: colors copy]. - ^ newForm! ! -!ColorForm class methodsFor: 'as yet unclassified' stamp: 'jmv 3/12/2018 15:48:04' prior: 50362375! - mappingWhiteToTransparentFrom: aFormOrCursor - "Return a ColorForm copied from the given Form or Cursor with white mapped to transparent." - - | f map | - aFormOrCursor depth <= 8 ifFalse: [ - ^ self error: 'argument depth must be 8-bits per pixel or less']. - (aFormOrCursor is: #ColorForm) ifTrue: [ - f _ aFormOrCursor copy. - map _ aFormOrCursor colors. - ] ifFalse: [ - f _ ColorForm extent: aFormOrCursor extent depth: aFormOrCursor depth. - f copyBits: aFormOrCursor boundingBox - from: aFormOrCursor - at: `0@0` - clippingBox: aFormOrCursor boundingBox - rule: Form over. - map _ Color indexedColors copyFrom: 1 to: (1 bitShift: aFormOrCursor depth)]. - map _ map collect: [:c | - c = Color white ifTrue: [Color transparent] ifFalse: [c]]. - f colors: map. - ^ f! ! -!Cursor methodsFor: 'converting' stamp: 'jmv 3/12/2018 15:48:08' prior: 50362402! - enlargedBy: scale - "Big cursors are 32 bits deep (ARGB premultiplied)" - | big | - scale = 1 ifTrue: [^self]. - big := CursorWithAlpha extent: self extent * scale depth: 32. - (self asCursorForm magnifyBy: scale) displayOn: big. - big offset: (self offset - 0.5 * scale min: `0@0` max: big extent negated) asIntegerPoint. - big fallback: self. - ^ big! ! -!DisplayScreen class methodsFor: 'snapshots' stamp: 'jmv 3/12/2018 15:48:15' prior: 50362416! - actualScreenSize - - ^ `640@480`! ! -!DisplayScreen class methodsFor: 'snapshots' stamp: 'jmv 3/12/2018 15:48:18' prior: 50362421! - shutDown - "Minimize Display memory saved in image" - Display setExtent: `240@120` depth: Display nativeDepth. - ScreenUpdaterProcess ifNotNil: [ - ScreenUpdaterProcess terminate. - ScreenUpdaterProcess _ nil ]! ! -!GrayForm methodsFor: 'copying' stamp: 'jmv 3/12/2018 15:51:21' prior: 50362431! - copy: aRect - "Return a new instance containing the portion of the receiver delineated by aRect." - - | newForm | - newForm _ self class extent: aRect extent depth: depth. - ((BitBlt - destForm: newForm - sourceForm: self - combinationRule: Form over - destOrigin: `0@0` - sourceOrigin: aRect origin - extent: aRect extent - clipRect: newForm boundingBox) - colorMap: nil) copyBits. - ^ newForm! ! -!BitBlt class methodsFor: 'instance creation' stamp: 'jmv 3/12/2018 15:47:23' prior: 50362447! - bitPeekerFromForm: sourceForm - "Answer an instance to be used extract individual pixels from the given Form. The destination for a 1x1 copyBits will be the low order bits of (bits at: 1)." - | pixPerWord answer | - pixPerWord _ sourceForm pixelsPerWord. - answer _ self destForm: (Form extent: pixPerWord@1 depth: sourceForm depth) - sourceForm: nil "To ensure no colormap set" - combinationRule: Form over - destOrigin: (pixPerWord - 1)@0 - sourceOrigin: `0@0` - extent: `1@1` - clipRect: (`0@0` extent: pixPerWord@1). - "To ensure no colormap set" - answer sourceForm: sourceForm. - ^ answer! ! -!BitBlt class methodsFor: 'instance creation' stamp: 'jmv 3/12/2018 15:47:27' prior: 50362469! - bitPokerToForm: destForm - "Answer an instance to be used for valueAt: aPoint put: pixValue. - The source for a 1x1 copyBits will be the low order of (bits at: 1)" - | pixPerWord answer | - pixPerWord _ 32//destForm depth. - answer _ self destForm: destForm - sourceForm: nil "To ensure no colormap set" - combinationRule: Form over - destOrigin: `0@0` - sourceOrigin: (pixPerWord-1)@0 - extent: `1@1` - clipRect: (`0@0` extent: destForm extent). - "To ensure no colormap set" - answer sourceForm: (Form extent: pixPerWord@1 depth: destForm depth). - ^ answer! ! -!AffineTransformation methodsFor: 'converting coordinates' stamp: 'jmv 3/12/2018 15:46:56' prior: 50362490! - internalizeDelta: aPoint - "Internalize a distance vector. A distance is not a position. It is a magnitude with a direction. - It is usually used as a delta to be added to a position to obtain some other position." - - | x y det a11 a12 a21 a22 detX detY | - x _ aPoint x. - y _ aPoint y. - a11 _ self a11. - a12 _ self a12. - a21 _ self a21. - a22 _ self a22. - det _ (a11 * a22) - (a12 * a21). - det = 0.0 ifTrue: [ ^`0@0` ]. "So we have at least a valid result" - det _ 1.0 / det. - detX _ (x * a22) - (a12 * y). - detY _ (a11 * y) - (x * a21). - ^ (detX * det) @ (detY * det)! ! -!AffineTransformation methodsFor: 'converting coordinates' stamp: 'jmv 3/12/2018 15:47:00' prior: 50362512! - inverseTransform: aPoint - "Apply the inverse transformation to aPoint, i.e. multiply our inverse by aPoint. - Use Smalltalk code, and not Matrix2x3Plugin, because we want Float conversion." - | x y det a11 a12 a21 a22 detX detY | - - x _ aPoint x - self a13. - y _ aPoint y - self a23. - a11 _ self a11. - a12 _ self a12. - a21 _ self a21. - a22 _ self a22. - det _ (a11 * a22) - (a12 * a21). - det = 0.0 ifTrue: [ ^`0@0` ]. "So we have at least a valid result" - det _ 1.0 / det. - detX _ (x * a22) - (a12 * y). - detY _ (a11 * y) - (x * a21). - ^ (detX * det) @ (detY * det)! ! -!AffineTransformation methodsFor: 'accessing' stamp: 'jmv 3/12/2018 15:47:03' prior: 50362533! - inverseTransformation - "Return the inverse transformation of the receiver. - The inverse transformation is computed by first calculating - the inverse offset and then computing transformations - for the two identity vectors (1@0) and (0@1)" - | r1 r2 r3 m | - r3 _ self inverseTransform: `0@0`. - r1 _ (self inverseTransform: `1@0`) - r3. - r2 _ (self inverseTransform: `0@1`) - r3. - m _ self species new. - m - a11: r1 x; a12: r2 x; a13: r3 x; - a21: r1 y; a22: r2 y; a23: r3 y. - ^ m! ! -!AffineTransformation methodsFor: 'transforming rects' stamp: 'jmv 3/12/2018 15:46:50' prior: 50362552! - displayBoundsOfTransformOf: aRectangle - "Externalize aRectangle, and find a bounding rectangle with horizontal - and vertical bounds and integer coordinates (i.e. adisplayBounds). - Primitive rounds and answers integers. - Warning: if answer from primitive is not strictly positive, it is off by one. Fix it here." - - | dstRect | - dstRect _ Rectangle new. - (self primDisplayBoundsOfTransformOf: aRectangle into: dstRect) ifNotNil: [ - dstRect topLeft > `0@0` ifTrue: [ ^dstRect ]]. - ^Rectangle encompassing: (aRectangle corners collect: [ :pt | - (self transform: pt) rounded ])! ! -!Point methodsFor: 'point functions' stamp: 'jmv 3/12/2018 15:55:24' prior: 50362573! - eightNeighbors - ^ (Array with: self + `1@0` - with: self + `1@1` - with: self + `0@1` - with: self + `-1@1`) , - (Array with: self + `-1@0` - with: self + `-1@-1` - with: self + `0@-1` - with: self + `1@-1`)! ! -!Point methodsFor: 'point functions' stamp: 'jmv 3/12/2018 15:55:28' prior: 50362583! - fourNeighbors - ^ Array with: self + `1@0` - with: self + `0@1` - with: self + `-1@0` - with: self + `0@-1`! ! -!Rectangle methodsFor: 'accessing' stamp: 'jmv 3/12/2018 15:55:55' prior: 50362590! - innerCorners - "Return an array of inner corner points, - ie, the most extreme pixels included, - in the order of a quadrilateral spec for WarpBlt" - | r1 | - r1 _ self topLeft corner: self bottomRight - `1@1`. - ^ Array with: r1 topLeft with: r1 bottomLeft with: r1 bottomRight with: r1 topRight! ! -!Morph methodsFor: 'events-processing' stamp: 'jmv 3/12/2018 15:53:54' prior: 50362602! - processUnknownEvent: aMorphicEvent localPosition: localEventPosition - "An event of an unknown type was sent to the receiver. What shall we do?!!" - - Smalltalk beep. - aMorphicEvent printString displayAt: `0@0`. - aMorphicEvent wasHandled: true! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 3/12/2018 15:53:40' prior: 50362613! - minimumExtent - "This returns the minimum extent that the morph may be shrunk to. Not honored in too many places yet, but respected by the resizeToFit feature, at least" - - self flag: #jmvVer2. "in owner's coordinates?" - ^self valueOfProperty: #minimumExtent ifAbsent: [`1@1`]! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 3/12/2018 15:53:42' prior: 50362625! - morphExtent - "In our own coordinates!!" -"Quizas eventualmente borrar este tambien? (no se usa mucho...)" - self flag: #jmvVer2. - ^`50 @ 40`! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 3/12/2018 15:53:45' prior: 50362632! - morphPositionInWorld - - self flag: #jmvVer2. - "Most likely we don't want to use global coordinates... - In fact, we could be in many frames of reference at the same time... - This method makes no sense at all!!" - - ^self externalizeToWorld: `0@0`! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 3/12/2018 15:53:48' prior: 50362643! - morphTopLeft - "By default, morphs occupy a rectangle specified by #morphTopLef and #morphExtent" - ^`0@0`! ! -!Morph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:53:51' prior: 50362650! - openInWorld: aWorld - "Add this morph to the requested World." - (location = MorphicTranslation new) - ifTrue: [ aWorld addMorph: self position: `50@50` ] - ifFalse: [ aWorld addMorph: self ]! ! -!RectangleLikeMorph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:55:58' prior: 50362660! - initialize - super initialize. - extent _ `50@40`. - color _ self defaultColor! ! -!PasteUpMorph methodsFor: 'change reporting' stamp: 'jmv 3/12/2018 15:54:34' prior: 50362666! - invalidateDisplayRect: damageRect from: aMorph - "Clip damage reports to my bounds, since drawing is clipped to my bounds." - - self == self world - ifTrue: [ worldState recordDamagedRect: (damageRect intersect: ( `0@0` extent: extent) ) ] - ifFalse: [ super invalidateDisplayRect: damageRect from: aMorph ]! ! -!PasteUpMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:54:27' prior: 50362680! - drawOn: aCanvas - - "draw background image." - backgroundImage - ifNotNil: [ - aCanvas image: backgroundImage at: `0@0` ] - ifNil: [ - "draw background fill" - (self isWorldMorph and: [ aCanvas drawsOnDisplay ] and: [ color mightBeTranslucent ]) - ifTrue: [ - "Special case so a translucent background on the Display allows you to see through the main Cuis Window. - Requires proper handling of translucent Display in the VM. - Seems to work only on Linux when using a composing window manager." - (BitBlt toForm: Display) clipRect: aCanvas clipRect; - copy: Display boundingBox - from: `0@0` in: nil - fillColor: color rule: Form over. - Display forceToScreen] - ifFalse: [ super drawOn: aCanvas ]]! ! -!PasteUpMorph methodsFor: 'geometry' stamp: 'jmv 3/12/2018 15:54:38' prior: 50362706! - morphPositionInWorld - - self flag: #jmvVer2. "Solo para evitar los warning por falta de owner... pensar despues este caso" - self isWorldMorph ifTrue: [ ^ `0@0` ]. - ^ super morphPositionInWorld! ! -!PasteUpMorph methodsFor: 'project state' stamp: 'jmv 3/12/2018 15:54:43' prior: 50362715! - viewBox - - ^ worldState - ifNotNil: [ - `0@0` extent: extent ] - ifNil: [ - self world viewBox ]! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 3/12/2018 15:54:30' prior: 50381052! - fillRects: rectangleList - "For testing. Flashes the given list of rectangles on the Display so you can watch incremental redisplay at work." - - - | blt screenRect | - blt _ (BitBlt toForm: Display) - sourceForm: nil; - sourceOrigin: `0@0`; - clipRect: self viewBox; - combinationRule: Form over. - - rectangleList do: [:r | - screenRect _ r translatedBy: self viewBox origin. - blt fillColor: Color random. - blt destRect: screenRect; copyBits. - Display forceToScreen: screenRect ]. - - (Delay forMilliseconds: 50) wait! ! -!PasteUpMorph class methodsFor: 'instance creation' stamp: 'jmv 3/12/2018 15:54:48' prior: 50379173! - newWorld - " -[ - UISupervisor stopUIProcess. - UISupervisor spawnNewMorphicProcessFor: PasteUpMorph newWorld -] fork. - " - | w ws | - w _ self new. - ws _ WorldState new. - w worldState: ws. - w morphPosition: `0@0` extent: Display extent. - ws setCanvas: Display getCanvas. - w borderWidth: 0. - ws handsDo: [ :h | - h privateOwner: w ]. - ^w! ! -!EllipseMorph methodsFor: 'geometry testing' stamp: 'jmv 3/12/2018 15:48:22' prior: 50362784! - morphContainsPoint: aLocalPoint - - | radius other delta xOverY | - ((`0@0` extent: extent) containsPoint: aLocalPoint) ifFalse: [^ false]. "quick elimination" - extent > `1@1` - ifFalse: [^ true]. "Degenerate case -- code below fails by a bit" - - radius _ extent y asFloat / 2. - other _ extent x asFloat / 2. - delta _ aLocalPoint - (other@radius). - xOverY _ extent x asFloat / extent y asFloat. - ^ (delta x asFloat / xOverY) squared + delta y squared <= radius squared! ! -!HandleMorph methodsFor: 'events' stamp: 'jmv 3/12/2018 15:51:54' prior: 50362802! - keyStroke: aKeyboardEvent - "Check for cursor keys" - | keyValue | - (owner is: #HandMorph) ifFalse: [ ^self ]. - keyValue _ aKeyboardEvent keyValue. - keyValue = 28 ifTrue: [ ^self morphPosition: self morphPosition - `1@0` ]. - keyValue = 29 ifTrue: [ ^self morphPosition: self morphPosition + `1@0` ]. - keyValue = 30 ifTrue: [ ^self morphPosition: self morphPosition - `0@1` ]. - keyValue = 31 ifTrue: [ ^self morphPosition: self morphPosition + `0@1` ]. - "Special case for return" - aKeyboardEvent isReturnKey ifTrue:[ - "Drop the receiver and be done" - self flag: #arNote. "Probably unnecessary" - owner releaseKeyboardFocus: self. - self delete ]! ! -!HandleMorph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:51:51' prior: 50362826! - initialize - "initialize the state of the receiver" - super initialize. - extent _ `12@12`! ! -!PluggableMorph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:55:13' prior: 50362832! - initialize - super initialize. - extent _ `200@100`! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:54:51' prior: 50367597! - draw3DLookOn: aCanvas - - | borderStyleSymbol c | - borderStyleSymbol _ self isPressed ifFalse: [ #raised ] ifTrue: [ #inset ]. - c _ color. - self mouseIsOver ifTrue: [ c _ c lighter ]. - aCanvas - fillRectangle: (`0@0` extent: extent) - color: c - borderWidth: borderWidth - borderStyleSymbol: borderStyleSymbol - baseColorForBorder: c. - - self drawRegularLabelOn: aCanvas! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:54:54' prior: 50367669! - drawRoundGradientLookOn: aCanvas - | r colorForButton rect bottomFactor topFactor | - - self isPressed - ifFalse: [ - topFactor _ Theme current buttonGradientTopFactor. - bottomFactor _ Theme current buttonGradientBottomFactor. - self mouseIsOver - ifTrue: [ - colorForButton _ Color h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ - colorForButton _ color ]] - ifTrue: [ - topFactor _ Theme current buttonGradientBottomFactor. - bottomFactor _ Theme current buttonGradientTopFactor. - colorForButton _ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - Theme current useButtonGradient - ifTrue: [ - rect _ (`0@0` extent: extent) insetBy: `1@3`. - aCanvas - roundRect: rect - color: colorForButton - radius: r - gradientTop: topFactor - gradientBottom: bottomFactor - gradientHeight: Theme current buttonGradientHeight ] - ifFalse: [ - rect _ (`0@0` extent: extent) insetBy: `1@3`. - aCanvas roundRect: rect color: colorForButton radius: r ] - ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawEmbossedLabelOn: aCanvas ] - ifFalse: [ self drawRegularLabelOn: aCanvas ]! ! -!PluggableButtonMorph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:54:57' prior: 50367711! - initialize - "initialize the state of the receiver" - super initialize. - - roundButtonStyle _ nil. "nil: honor Theme. true: draw as round button. false: draw as classic 3d border square button" - model _ nil. - getStateSelector _ nil. - actionSelector _ nil. - isPressed _ false. - mouseIsOver _ false. - actWhen _ #buttonUp. - extent _ `20 @ 15`! ! -!PluggableButtonMorph methodsFor: 'geometry testing' stamp: 'jmv 3/12/2018 15:55:00' prior: 50367742! - morphContainsPoint: aLocalPoint - - | iconOrigin | - ((`0@0` extent: extent) containsPoint: aLocalPoint) ifFalse: [ ^false ]. - ^ self isOrthoRectangularMorph or: [ - magnifiedIcon isNil or: [ - iconOrigin _ extent - magnifiedIcon extent // 2. - (magnifiedIcon isTransparentAt: (aLocalPoint - iconOrigin) rounded) not ]]! ! -!PluggableButtonMorph class methodsFor: 'example' stamp: 'jmv 3/12/2018 15:55:05' prior: 50362922! - example - " - PluggableButtonMorph example openInWorld - " - - | s1 s2 s3 b1 b2 b3 row | - s1 _ Switch new. - s2 _ Switch new turnOn. - s3 _ Switch new. - s2 onAction: [s3 turnOff]. - s3 onAction: [s2 turnOff]. - b1 _ (PluggableButtonMorph model: s1 stateGetter: #isOn action: #switch) label: 'S1'. - b2 _ (PluggableButtonMorph model: s2 stateGetter: #isOn action: #turnOn) label: 'S2'. - b3 _ (PluggableButtonMorph model: s3 stateGetter: #isOn action: #turnOn) label: 'S3'. - b1 color: Color lightRed. - b2 color: Color lightRed. - b3 color: Color lightRed. - row _ LayoutMorph newRow - addMorphs: (Array with: b1 with: b2 with: b3); - morphExtent: `120@35`. - ^ row! ! -!PluggableScrollPane methodsFor: 'access' stamp: 'jmv 3/12/2018 15:55:16' prior: 50362946! - addToScroller: aMorph - - scroller - addMorph: aMorph position: `0@0`; - morphExtent: aMorph morphExtent! ! -!PluggableScrollPane methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:55:18' prior: 50362953! - initialize - - "initialize the state of the receiver" - super initialize. - hideScrollBars _ false. - - "initialize the receiver's scrollBars" - scrollBar _ self scrollBarClass new model: self setValueSelector: #vScrollBarValue:. - hScrollBar _ self scrollBarClass new model: self setValueSelector: #hScrollBarValue:. - drawKeyboardFocusIndicator _ true. - - scroller _ self innerMorphClass new. - self addMorph: scroller. - self scrollerOffset: `0@ 0`. - self addMorph: scrollBar. - self addMorph: hScrollBar! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'jmv 3/12/2018 15:55:21' prior: 50362972! - scrollToShow: aRectangle - "scroll to include as much of aRectangle as possible, where aRectangle is in the scroller's local space. - This means that 0@0 is scrolling all the way top and all the way left" - | delta | - (aRectangle top >= 0 and: [ - aRectangle bottom <= self viewableHeight ]) - ifTrue: [ - "already visible" - ^self ]. - - "Scroll end of selection into view if necessary" - delta _ aRectangle amountToTranslateWithin: (`0@0` extent: self viewableExtent). - delta y ~= 0 ifTrue: [ - self scrollBy: 0@delta y ]! ! -!PluggableListMorphOfMany methodsFor: 'events' stamp: 'jmv 3/12/2018 15:55:10' prior: 50380611! - mouseMove: aMouseMoveEvent localPosition: localEventPosition - "The mouse has moved, as characterized by the event provided. Adjust the scrollbar, and alter the selection as appropriate" - - | oldIndex oldVal row | - row _ (localEventPosition y < 0 and: [ scrollBar scrollValue > 0.0 ]) - ifTrue: [ - scrollBar scrollUp: 1. - "Leave at least one visible item unaffected, for better visual feedback to the user." - (self rowAtLocation: `0@0`) + 2 ] - ifFalse: [ - (localEventPosition y > extent y and: [ scrollBar scrollValue < 1.0 ]) - ifTrue: [ - scrollBar scrollDown: 1. - "Leave at least one visible item unaffected, for better visual feedback to the user." - (self rowAtLocation: 0@extent y) - 3 ] - ifFalse: [ self rowAtLocation: localEventPosition ]]. - row = 0 ifTrue: [ ^ self ]. - - "No change if model is locked" - self owningWindow ifNotNil: [ :w | - w okToChange ifFalse: [^ self]]. - - dragOnOrOff ifNil: [ - "Was not set at mouse down, which means the mouse must have gone down in an area where there was no list item" - dragOnOrOff _ (self listSelectionAt: row) not. - dragStartRow _ row ]. - - "Set meaning for subsequent dragging of selection" - oldIndex _ self getCurrentSelectionIndex. - oldIndex ~= 0 ifTrue: [ oldVal _ self listSelectionAt: oldIndex ]. - - "Set or clear new primary selection (listIndex)" - dragOnOrOff - ifTrue: [ self setSelectionIndex: row ] - ifFalse: [ self setSelectionIndex: 0 ]. - - "Need to restore the old one, due to how model works, and set new one." - oldIndex ~= 0 ifTrue: [ self listSelectionAt: oldIndex put: oldVal ]. - - "Select all in between if drag was too fast" - "self listSelectionAt: row put: dragOnOrOff." - (row min: dragStartRow) to: (row max: dragStartRow) do: [ :r | - self listSelectionAt: r put: dragOnOrOff ]! ! -!SystemWindow methodsFor: 'change reporting' stamp: 'jmv 3/12/2018 15:56:57' prior: 50363051! - invalidateTitleArea - - "not really pretty... also invalidating the top border, regardless of it being above or below the title area - (Different themes use various looks, this covers them all)" - self invalidateLocalRect: (`0@0` extent: extent x @ (self labelHeight + borderWidth))! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:56:43' prior: 50363063! - drawClassicFrameOn: aCanvas color: titleColor - "Window border encompasses title area. No round corners. No title gradient." - - aCanvas fillRectangle: (`0@0` extent: extent) color: color borderWidth: borderWidth borderStyleSymbol: #simple baseColorForBorder: self widgetsColor. - - "A border was drawn at the left, top and right of the title area. - The look is that the title area is inside the window" - aCanvas fillRectangle: (borderWidth@borderWidth extent: extent x - (2*borderWidth)@ self labelHeight) color: titleColor! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:56:47' prior: 50363082! -drawRoundedFrameOn: aCanvas color: widgetsColor - "Title area is not inside window borders" - | bottomFactor topFactor | - Theme current useWindowTitleGradient - ifTrue: [ - topFactor _ Theme current titleGradientTopFactor. - bottomFactor _ Theme current titleGradientBottomFactor ] - ifFalse: [ - topFactor _ 1. - bottomFactor _ 1 ]. - aCanvas - windowFrame: (`0@0` extent: extent) - color: widgetsColor * Theme current titleGradientExtraLightness - radius: Theme current roundedWindowRadius - border: borderWidth - labelHeight: self labelHeight + borderWidth - gradientTop: topFactor - gradientBottom: bottomFactor - insideColor: color! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:57:04' prior: 50363105! - makeMeFullyVisible - - self world morphExtent > `0@0` ifFalse: [^ self]. - - (self morphPosition >= `0@0` and: [ self morphPosition < (self world morphExtent-self morphExtent)]) ifTrue: [ - ^ self "OK -- visible"]. - - self morphPosition: (RealEstateAgent initialFrameFor: self initialExtent: self morphExtentInWorld world: self world) topLeft! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:57:07' prior: 50363119! - makeMeVisible - - self world morphExtent > `0@0` ifFalse: [^ self]. - - (self morphPosition >= `0@0` and: [ self morphPosition < (self world morphExtent-self labelHeight)]) ifTrue: [ - ^ self "OK -- at least my top left is visible"]. - - "window not on screen (probably due to reframe) -- move it now" - self morphPosition: (RealEstateAgent initialFrameFor: self initialExtent: extent world: self world) topLeft! ! -!SystemWindow methodsFor: 'geometry' stamp: 'jmv 3/12/2018 15:57:09' prior: 50363135! - minimumExtent - - ^`160@80`! ! -!SystemWindow methodsFor: 'geometry' stamp: 'jmv 3/12/2018 15:57:13' prior: 50363139! - rescaleButtons - "boxExtent changed. Update my buttons." - | buttonExtent buttonPos buttonDelta | - buttonExtent := self boxExtent. - buttonPos := `2@2`. - buttonDelta := self boxExtent x + 2. - self submorphsReverseDo: [ :aMorph | - (aMorph is: #PluggableButtonMorph) - ifTrue: [ - aMorph morphExtent: buttonExtent. - aMorph morphPosition: buttonPos. - buttonPos := (buttonPos x + buttonDelta) @ 2. - ]. - ]! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:56:39' prior: 50363155! - boxExtent - "answer the extent to use in all the buttons. - - the label height is used to be proportional to the fonts preferences" - | e | - Theme current minimalWindows ifTrue: [^`0@0`]. - e _ Preferences windowTitleFont height. - ^e@e! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:56:51' prior: 50363166! - initialize - "Initialize a system window. Add label, stripes, etc., if desired" - - super initialize. - labelString ifNil: [ labelString _ 'Untitled Window']. - - self initializeLabelArea. - extent _ `300 @ 200`. - - adjusters _ Dictionary new. - adjusters at: #topAdjuster put: WindowEdgeAdjustingMorph forTop. - adjusters at: #bottomAdjuster put: WindowEdgeAdjustingMorph forBottom. - adjusters at: #leftAdjuster put: WindowEdgeAdjustingMorph forLeft. - adjusters at: #rightAdjuster put: WindowEdgeAdjustingMorph forRight. - adjusters at: #topLeftAdjuster put: WindowEdgeAdjustingMorph forTopLeft. - adjusters at: #bottomLeftAdjuster put: WindowEdgeAdjustingMorph forBottomLeft. - adjusters at: #topRightAdjuster put: WindowEdgeAdjustingMorph forTopRight. - adjusters at: #bottomRightAdjuster put: WindowEdgeAdjustingMorph forBottomRight. - adjusters do: [ :m | - self addMorphFront: m ]. - - "by default" - self beColumn! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:56:54' prior: 50363198! - initializeLabelArea - "Initialize the label area (titlebar) for the window." - - | spacing | - spacing _ self boxExtent x + 2. - self addMorph: self createCloseBox position: `2@2`. - self addMorph: self createCollapseBox position: spacing+2@2. - self addMorph: self createExpandBox position: spacing*2+2@2. - self addMorph: self createMenuBox position: spacing*3+2@2! ! -!SystemWindow methodsFor: 'layout' stamp: 'jmv 3/12/2018 15:57:00' prior: 50363212! - layoutSubmorphs - "Compute a new layout of submorphs based on the given layout bounds." - - | h thickness w cornerExtent wh ww pos | - thickness _ 4. - cornerExtent _ 20. - ww _ extent x. - wh _ extent y. - w _ ww - cornerExtent - cornerExtent. - h _ wh - cornerExtent - cornerExtent. - (adjusters at: #topAdjuster) morphPosition: cornerExtent@0 extent: w@thickness. - (adjusters at: #bottomAdjuster) morphPosition: cornerExtent@(wh-thickness) extent: w@thickness. - (adjusters at: #leftAdjuster) morphPosition: 0@cornerExtent extent: thickness@h. - (adjusters at: #rightAdjuster) morphPosition: ww-thickness@cornerExtent extent: thickness@h. - (adjusters at: #topLeftAdjuster) morphPosition: `0@0` extent: cornerExtent@cornerExtent. - (adjusters at: #bottomLeftAdjuster) morphPosition: 0@(wh-cornerExtent) extent: cornerExtent@cornerExtent. - (adjusters at: #topRightAdjuster) morphPosition: ww-cornerExtent@0 extent: cornerExtent@cornerExtent. - (adjusters at: #bottomRightAdjuster) morphPosition: ww@wh-cornerExtent extent: cornerExtent@cornerExtent. - - layoutMorph ifNotNil: [ - pos _ borderWidth @ (borderWidth + self labelHeight). - layoutMorph - morphPosition: pos - extent: extent - pos - borderWidth ]. - - layoutNeeded _ false! ! -!SystemWindow methodsFor: 'resize/collapse' stamp: 'jmv 3/12/2018 15:57:17' prior: 50363254! - resize - | resizeMorph | - resizeMorph _ ResizeMorph new morphExtent: `200@150`. - resizeMorph action: [self resize: (resizeMorph selectionRectangle: Display extent)]. - resizeMorph morphPosition: self world activeHand morphPosition. - resizeMorph openInWorld! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'jmv 3/12/2018 15:47:52' prior: 50375307! - initialExtent - - ^`540@400` * Preferences standardCodeFont height // 14! ! -!ChangeSorterWindow methodsFor: 'GUI building' stamp: 'jmv 3/12/2018 15:47:45' prior: 50375313! - initialExtent - ^`540@300` * Preferences standardCodeFont height // 14! ! -!PreDebugWindow methodsFor: 'GUI building' stamp: 'jmv 3/12/2018 15:55:30' prior: 50375319! - initialExtent - ^ `640 @ 320` * Preferences standardCodeFont height // 14! ! -!InspectorWindow methodsFor: 'GUI building' stamp: 'jmv 3/12/2018 15:52:24' prior: 50375325! - initialExtent - - ^`600@325` * Preferences standardCodeFont height // 14! ! -!ObjectExplorerWindow methodsFor: 'GUI building' stamp: 'jmv 3/12/2018 15:54:22' prior: 50375331! - initialExtent - - ^`300@500` * Preferences standardCodeFont height // 14! ! -!TestRunnerWindow methodsFor: 'GUI building' stamp: 'jmv 3/12/2018 15:57:20' prior: 50363286! - buildMorphicWindow - - self layoutMorph - addMorph: self buildUpperControls proportionalHeight: 0.25; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.75. - self setLabel: 'SUnit Test Runner'. - self refreshWindow. - self morphExtent: `460 @ 400`! ! -!ScrollBar methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:56:22' prior: 50363297! - drawOn: aCanvas - - aCanvas - fillRectangle: (`0@0` extent: extent) - color: (color alphaMixed: 0.3 with: Theme current scrollbarColor) - borderWidth: borderWidth - borderStyleSymbol: #simple - baseColorForBorder: borderColor! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 3/12/2018 15:53:14' prior: 50363307! - addTitle: aString - "Add a title line at the top of this menu Make aString its initial - contents. - If aSelector is not nil, then periodically obtain fresh values for its - contents by sending aSelector to aTarget.." - - | s pp w | - - titleMorph _ RectangleLikeMorph new. - titleMorph color: Theme current menuTitleBar. - pp _ `8@2`. - aString asString linesDo: [ :line | - s _ StringMorph new - contents: line; - font: Preferences standardMenuFont bold. - titleMorph addMorphBack: s position: pp. - pp _ pp + (0@(s morphHeight+2)) ]. - w _ titleMorph submorphs inject: 0 into: [ :prev :each | - prev max: each morphWidth ]. - titleMorph morphExtent: (w + 16) @ (pp y). - self addMorphFront: titleMorph. - - (self hasProperty: #needsStayUpIcons) ifTrue: [ self addStayUpIcons ]! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 3/12/2018 15:53:30' prior: 50363334! - popUpAdjacentTo: rightOrLeftPointInWorld from: sourceItem - "Present this menu at the given point under control of the given hand. - Used mostly for submenus." - - | delta tryToPlace selectedOffset | - popUpOwner _ sourceItem. - selectedOffset _ (selectedItem ifNil: [ self items first ]) morphPosition. - sourceItem world addMorphFront: self. - - tryToPlace _ [ :where :mustFit | - self morphPosition: where - selectedOffset. - delta _ self morphFullBoundsInWorld - amountToTranslateWithin: sourceItem world morphBoundsInWorld. - (delta x = 0 | mustFit) ifTrue: [ - delta = `0@0` ifFalse: [ self morphPosition: self morphPosition + delta ]. - ^ self]]. - tryToPlace - value: rightOrLeftPointInWorld first value: false; - value: rightOrLeftPointInWorld last - (extent x @ 0) value: false; - value: rightOrLeftPointInWorld first value: true! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 3/12/2018 15:53:34' prior: 50363363! - popUpAt: aPoint forHand: hand allowKeyboard: aBoolean - "Present this menu at the given point under control of the given hand." - - | evt | - self items isEmpty ifTrue: [^self]. - Theme current decorateMenu: self. - (self submorphs select: [ :m | m is: #UpdatingMenuItemMorph ]) - do: [ :m | m updateContents]. - self runningWorld addMorphFront: self position: aPoint - `2 @ 8`. - self fitInWorld. - "Acquire focus for valid pop up behavior" - hand newMouseFocus: self. - aBoolean ifTrue: [ hand newKeyboardFocus: self ]. - evt _ hand lastMouseEvent. - (evt isKeyboard or: [ evt isMouse and: [ evt anyButtonPressed not ]]) - ifTrue: [ - "Select first item if button not down" - self moveSelectionDown: 1 event: evt ]! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 3/12/2018 15:53:37' prior: 50363388! - popUpAt: aPoint forHand: hand in: aWorld allowKeyboard: aBoolean - "Present this menu at the given point under control of the given hand." - - self items isEmpty ifTrue: [ ^self ]. - Theme current decorateMenu: self. - (self submorphs select: [ :m | m is: #UpdatingMenuItemMorph]) - do: [ :m | m updateContents]. - aWorld addMorphFront: self position: aPoint - `2 @ 8`. - self fitInWorld. - "Acquire focus for valid pop up behavior" - hand newMouseFocus: self. - aBoolean ifTrue: [ hand newKeyboardFocus: self ]! ! -!MenuMorph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:53:27' prior: 50363407! - initialize - super initialize. - extent _ `40@10`. - defaultTarget _ nil. - selectedItem _ nil. - stayUp _ false. - popUpOwner _ nil! ! -!MenuMorph methodsFor: 'keyboard control' stamp: 'jmv 3/12/2018 15:53:21' prior: 50363414! - displayFiltered: evt - | matchStr allItems isMatch matches feedbackMorph | - matchStr _ self valueOfProperty: #matchString. - allItems _ self submorphs select: [ :m | - m is: #MenuItemMorph ]. - matches _ allItems select: [ :m | - isMatch _ matchStr isEmpty or: [ - m contents - includesSubstring: matchStr - caseSensitive: false ]. - m isEnabled: isMatch. - isMatch ]. - feedbackMorph _ self valueOfProperty: #feedbackMorph. - feedbackMorph ifNil: [ - feedbackMorph _ StringMorph new color: Color veryDarkGray. - self addMorphBack: feedbackMorph lock position: `0@ -20`. - self - setProperty: #feedbackMorph - toValue: feedbackMorph ]. - feedbackMorph contents: '<' , matchStr , '>'. - matchStr isEmpty ifTrue: [ - feedbackMorph delete. - self removeProperty: #feedbackMorph ]. - matches notEmpty ifTrue: [ - self selectItem: matches first ]! ! -!MenuMorph methodsFor: 'private' stamp: 'jmv 3/12/2018 15:53:17' prior: 50363443! - adjustSubmorphsLayout - "Enlarge the width of submorphs as needed - so all of them are have the same width, and no less than #minWidth. - Also adjust their vertical position. - Finally, set our own extent." - - | w p h | - - submorphs isEmpty ifTrue: [ ^self ]. - w _ submorphs inject: 0 into: [ :prev :each | - prev max: each minItemWidth]. - - w _ w + 1. - p _ `5 @ 5`. - submorphs do: [ :m | - h _ m morphHeight. - m morphPosition: p extent: w@h. - p _ p + (0@(h + 1)) ]. - - self morphExtent: w+4 @ p y + 5! ! -!MenuMorph methodsFor: 'private' stamp: 'jmv 3/12/2018 15:53:24' prior: 50363462! - fitInWorld - "Note: items may not be laid out yet (I found them all to be at 0@0), - so we have to add up heights of items above the selected item." - - | delta | - "If it doesn't fit, show it to the left, not to the right of the hand." - self morphBoundsInWorld right > owner world morphBoundsInWorld right - ifTrue: [ - self morphPosition: ((self morphPosition x + 10 - extent x) @ self morphPosition y) ]. - - "Make sure that the menu fits in the world." - delta _ self morphBoundsInWorld amountToTranslateWithin: - (owner world morphBoundsInWorld withHeight: - ((owner world morphExtentInWorld y) max: (self morphPosition y) + 1)). - delta = `0 @ 0` ifFalse: [ self morphPosition: self morphPosition + delta ]! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:47:08' prior: 50363488! - downButtonPosition - ^ `0@0` + (extent - ScrollBar scrollbarThickness)! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:47:14' prior: 50363494! - drawOn: aCanvas - | rectangle w y0 h y1 y2 scrollbarThickness | - aCanvas frameAndFillRectangle: (`0@0` extent: extent) fillColor: self color borderWidth: borderWidth borderColor: borderColor. - y0 _ 1. - w _ extent x-2. - scrollbarThickness _ ScrollBar scrollbarThickness. - completer entryCount > self class itemsPerPage ifTrue: [ - w _ w - scrollbarThickness. - aCanvas - frameRectangle: (extent x - scrollbarThickness@0 - extent: scrollbarThickness @ extent y) - borderWidth: 1 - color: borderColor. - aCanvas - image: (BitBltCanvas arrowOfDirection: #up size: scrollbarThickness) - at: self upButtonPosition. - aCanvas - image: (BitBltCanvas arrowOfDirection: #down size: scrollbarThickness) - at: self downButtonPosition. - h _ extent y - (2 * scrollbarThickness). - y1 _ (1.0 * self firstVisible-1 / completer entryCount * h) ceiling + y0 + scrollbarThickness-1. - y2 _ (1.0 * self lastVisible / completer entryCount * h) floor + y0 + scrollbarThickness -1. - aCanvas - fillRectangle: (extent x - scrollbarThickness+2@y1 corner: extent x-2 @ y2) - color: Color veryLightGray ]. - self firstVisible - to: self lastVisible - do: [ :index | - rectangle _ 1@y0 extent: w@self class itemHeight. - index = self selected - ifTrue: [ - aCanvas fillRectangle: rectangle color: (Theme current listHighlightFocused: true) ]. - aCanvas - drawString: (completer entries at: index) asString - at: rectangle topLeft - font: self class listFont - color: Theme current text. - y0 _ y0 + self itemHeight ]! ! -!AutoCompleterMorph class methodsFor: 'instance creation' stamp: 'jmv 3/12/2018 15:47:19' prior: 50363545! - initializedInstance - | completer m | - completer _ SmalltalkCompleter withModel: (TextModel withText: 'Small'). - completer - instVarNamed: 'position' - put: 5. - completer computeEntries. - m _ AutoCompleterMorph - completer: completer - position: `200 @ 200`. - completer instVarNamed: 'menuMorph' put: m. - ^m! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:51:41' prior: 50363558! - drawOn: aCanvas - "Draw the hand itself (i.e., the cursor)." - "This method is only called when we are carrying morphs around..." - aCanvas - stencil: Cursor move - at: `0@0` - color: Color black! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:51:48' prior: 50363567! - savePatchFrom: aCanvas appendDamageTo: aStream - "Save the part of the given canvas under this hand as a Form and return its bounding rectangle." - - "Details: The previously used patch Form is recycled when possible to reduce the burden on storage management." - - | fullBounds | - fullBounds _ self morphFullBoundsInWorld. - fullBounds ifNil: [ ^self ]. - - fullBounds _ fullBounds intersect: (`0@0` extent: aCanvas extent). - (savedPatch isNil or: [savedPatch extent ~= fullBounds extent]) - ifTrue: [ - "allocate new patch form if needed" - savedPatch _ Form extent: fullBounds extent depth: aCanvas depth ]. - aCanvas - contentsOfArea: fullBounds - into: savedPatch. - savedPatch offset: fullBounds topLeft. - prevFullBounds - ifNil: [ aStream nextPut: fullBounds ] - ifNotNil: [ aStream nextPut: (fullBounds merge: prevFullBounds)]. - prevFullBounds _ fullBounds! ! -!HandMorph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:51:44' prior: 50363597! - initForEvents - mouseOverHandler _ nil. - lastMouseEvent _ MouseEvent new setType: #mouseMove position: `0@0` buttons: 0 hand: self. - lastMouseEventTime _ Time localMillisecondClock. - lastEventBuffer _ {1. 0. 0. 0. 0. 0. nil. nil}. - self dontWaitForMoreClicks! ! -!ImageMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:51:57' prior: 50363608! - drawOn: aCanvas - - aCanvas image: image at: `0@0`! ! -!StringMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:56:33' prior: 50363613! - drawOn: aCanvas - aCanvas - drawString: (contents ifNil: [ '' ]) - at: `0@0` - font: self fontToUse - color: color! ! -!StringMorph methodsFor: 'geometry' stamp: 'jmv 3/12/2018 15:56:36' prior: 50363620! - fitContents - "Measures contents later at #minimumExtent" - self morphExtent: `0@0`! ! -!IndentingListItemMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:52:00' prior: 50363626! - drawOn: aCanvas - - | tRect colorToUse sLeft aForm centeringOffset | - isHighlighted ifTrue: [ - aCanvas - fillRectangle: (`0@0` extent: extent) - color: (Theme current - listHighlightFocused: owner owner hasKeyboardFocus) duller ]. - isSelected ifTrue: [ - aCanvas - fillRectangle: (`0@0` extent: extent) - color: (Theme current - listHighlightFocused: owner owner hasKeyboardFocus) ]. - - tRect _ self toggleRectangle. - aForm _ isExpanded - ifTrue: [ container expandedForm ] - ifFalse: [ container notExpandedForm ]. - centeringOffset _ ((tRect height - aForm extent y) / 2.0) rounded. - - complexContents hasContents ifTrue: [ - aCanvas - image: aForm - at: (tRect topLeft translatedBy: 0 @ centeringOffset) ]. - - icon isNil - ifFalse: [ - aCanvas - image: icon - at: (tRect topLeft translatedBy: icon width @ centeringOffset). - sLeft _ indentLevel * 12 + 16 + (icon width + 2). - ] - ifTrue: [ - sLeft _ indentLevel * 12 + 16. - ]. - colorToUse _ complexContents preferredColor ifNil: [ color ]. - - aCanvas - drawString: contents asString - at: sLeft@0 - font: self fontToUse - color: colorToUse! ! -!MenuItemMorph methodsFor: 'accessing' stamp: 'jmv 3/12/2018 15:52:47' prior: 50363664! - contents: aString withMarkers: aBool inverse: inverse - "Set the menu item entry. If aBool is true, parse aString for embedded markers." - - | markerIndex marker | - self contentString: nil. "get rid of old" - aBool ifFalse: [^super contents: aString]. - self removeAllMorphs. "get rid of old markers if updating" - self hasIcon ifTrue: [ self icon: nil ]. - (aString notEmpty and: [aString first = $<]) - ifFalse: [^super contents: aString]. - markerIndex := aString indexOf: $>. - markerIndex = 0 ifTrue: [^super contents: aString]. - marker := (aString copyFrom: 1 to: markerIndex) asLowercase. - (#('' '' '' '') includes: marker) - ifFalse: [^super contents: aString]. - self contentString: aString. "remember actual string" - marker := (marker = '' or: [marker = '']) ~= inverse - ifTrue: [self onImage] - ifFalse: [self offImage]. - super contents: (aString copyFrom: markerIndex + 1 to: aString size). - "And set the marker" - marker := ImageMorph new image: marker. - self addMorphFront: marker position: `0@2`! ! -!MenuItemMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:52:51' prior: 50363700! - drawOn: aCanvas - | stringColor leftEdge | - - stringColor _ color. - isSelected & isEnabled - ifTrue: [ - aCanvas fillRectangle: (`0@0` extent: extent) color: Theme current menuHighlight]. - leftEdge _ 0. - - self hasMarker ifTrue: [ - leftEdge _ leftEdge + submorphs first morphWidth + 8 ]. - - self hasIcon - ifTrue: [| iconForm | - iconForm _ isEnabled ifTrue: [ self icon ] ifFalse: [ self icon asGrayScaleAndTransparent ]. - aCanvas image: iconForm at: leftEdge+1 @ (extent y - iconForm height // 2). - leftEdge _ leftEdge + iconForm width + self iconSeparation]. - - aCanvas - drawString: contents - at: leftEdge @ 1 - font: self fontToUse - color: stringColor. - subMenu ifNotNil: [ - aCanvas - image: self class subMenuMarker - at: extent x - 8 @ (extent y - self class subMenuMarker height // 2) ]! ! -!MenuItemMorph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:52:54' prior: 50363729! - initialize - "initialize the state of the receiver" - super initialize. - "" - extent _ `10@10`. - contents _ ''. - isEnabled _ true. - subMenu _ nil. - isSelected _ false. - target _ nil. - selector _ nil. - arguments _ nil. - font _ Preferences standardMenuFont! ! -!MenuItemMorph methodsFor: 'layout' stamp: 'jmv 3/12/2018 15:52:57' prior: 50363740! - measureContents - | e | - e _ super measureContents. - ^e y > 12 - ifTrue: [e+`2@2`] - ifFalse: [e+`2@1`]! ! -!MenuItemMorph methodsFor: 'selecting' stamp: 'jmv 3/12/2018 15:52:59' prior: 50363747! - select - self isSelected: true. - owner activeSubmenu: subMenu. - subMenu ifNotNil: [ - subMenu delete. - subMenu - popUpAdjacentTo: (Array with: self morphBoundsInWorld topRight + `10@0` - with: self morphBoundsInWorld topLeft) - from: self. - subMenu selectItem: nil ]! ! -!MenuItemMorph class methodsFor: 'cached state access' stamp: 'jmv 3/12/2018 15:53:02' prior: 50363760! - subMenuMarker - - | f | - SubMenuMarker ifNotNil: [ ^SubMenuMarker ]. - f _ Form - extent: `5@9` - fromArray: #(2147483648 3221225472 3758096384 4026531840 4160749568 4026531840 3758096384 3221225472 2147483648) - offset: `0@0`. - SubMenuMarker _ ColorForm mappingWhiteToTransparentFrom: f. - ^SubMenuMarker! ! -!LayoutAdjustingMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:52:28' prior: 50363773! - drawOn: aCanvas - - aCanvas - fillRectangle: (`0@0` extent: extent) - color: color! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 3/12/2018 15:52:31' prior: 50363779! - layoutBounds - "Return the bounds for laying out children of the receiver" - - ^`0@0` extent: extent! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 3/12/2018 15:52:35' prior: 50363785! - layoutSubmorphsHorizontallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - | xSep ySep usableWidth sumOfFixed normalizationFactor availableForPropWidth - fractionalWidths integerWidths theLeft usableHeight boundsTop boundsRight theTop minWidth submorphsToLayout - nextMorph ht wd ls theRight boundsBottom theBottom alternativeWidths count diff i | - - boundsForLayout extent > `2@2` "self minimumExtent" - ifFalse: [ ^self ]. "Too small. Don't bother!!" - - submorphsToLayout := self submorphsToLayout. - xSep := self xSeparation. - ySep := self ySeparation. - usableWidth := boundsForLayout width - ((submorphsToLayout size + 1) * xSep). - sumOfFixed := submorphsToLayout sum: [ :m | m layoutSpec fixedWidth ]. - availableForPropWidth := usableWidth - sumOfFixed max: 0. - normalizationFactor := self proportionalWidthNormalizationFactor. - availableForPropWidth := availableForPropWidth * normalizationFactor. - - fractionalWidths := submorphsToLayout collect: [ :m | m layoutSpec widthFor: availableForPropWidth ]. - "Compute integer widths, mostly rounding but with occasional #floor or #ceiling as needed to keep sum" - integerWidths _ fractionalWidths collect: [ :w | w rounded ]. - diff _ integerWidths sum - fractionalWidths sum rounded. - alternativeWidths _ diff > 0 ifTrue: [ fractionalWidths collect: [ :w | w floor ]] ifFalse: [ fractionalWidths collect: [ :w | w ceiling ]]. - count _ diff abs. - i _ 1. - [ count > 0] whileTrue: [ - (integerWidths at: i) = (alternativeWidths at: i) ifFalse: [ - integerWidths at: i put: (alternativeWidths at: i). - count _ count -1 ]. - i _ i + 1 ]. - minWidth := integerWidths sum. - theLeft := ((usableWidth - minWidth) * (padding ifNil: [0]) max: 0) + boundsForLayout left + xSep. - usableHeight := boundsForLayout height - (ySep * 2) max: 0. - boundsTop := boundsForLayout top + ySep. - boundsRight := boundsForLayout right - xSep. - boundsBottom := boundsForLayout bottom - ySep. - - submorphsToLayout size to: 1 by: -1 do: [ :index | - nextMorph := submorphsToLayout at: index. - "major direction" - wd := integerWidths at: index. - "minor direction" - ls := nextMorph layoutSpec. - ht := (ls heightFor: usableHeight) min: usableHeight. - theTop := ((usableHeight - ht) * ls minorDirectionPadding) floor + boundsTop. - theBottom := (theTop + ht) ceiling min: boundsBottom. - theRight := (theLeft + (wd min: minWidth)) "ceiling "min: boundsRight. - "Set bounds and adjust major direction for next step" - self flag: #jmvVer2. "should extent be set in m's coordinate system? what if its scale is not 1?" - ls usesMorphExtent - ifTrue: [ - nextMorph morphPosition: theLeft floor @ theTop floor ] - ifFalse: [ - nextMorph morphPosition: theLeft floor @ theTop floor extent: theRight - theLeft @ (theBottom - theTop) ]. - theLeft := theRight + xSep - ]! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 3/12/2018 15:52:39' prior: 50363876! - layoutSubmorphsVerticallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - | xSep ySep usableHeight sumOfFixed normalizationFactor availableForPropHeight - fractionalHeights integerHeights theTop usableWidth boundsLeft boundsBottom theLeft minHeight submorphsToLayout - nextMorph ht wd ls theBottom boundsRight theRight alternativeHeights count diff i | - - boundsForLayout extent > `2@2` "self minimumExtent" - ifFalse: [ ^self ]. "Too small. Don't bother!!" - - submorphsToLayout := self submorphsToLayout. - xSep := self xSeparation. - ySep := self ySeparation. - usableHeight := boundsForLayout height - ((submorphsToLayout size + 1) * ySep). - sumOfFixed := submorphsToLayout sum: [ :m | m layoutSpec fixedHeight ]. - availableForPropHeight := usableHeight - sumOfFixed max: 0. - normalizationFactor := self proportionalHeightNormalizationFactor. - availableForPropHeight := availableForPropHeight * normalizationFactor. - - fractionalHeights := submorphsToLayout collect: [ :m | m layoutSpec heightFor: availableForPropHeight ]. - "Compute integer widths, mostly rounding but with occasional #floor or #ceiling as needed to keep sum" - integerHeights _ fractionalHeights collect: [ :w | w rounded ]. - diff _ integerHeights sum - fractionalHeights sum rounded. - alternativeHeights _ diff > 0 ifTrue: [ fractionalHeights collect: [ :w | w floor ]] ifFalse: [ fractionalHeights collect: [ :w | w ceiling ]]. - count _ diff abs. - i _ 1. - [ count > 0] whileTrue: [ - (integerHeights at: i) = (alternativeHeights at: i) ifFalse: [ - integerHeights at: i put: (alternativeHeights at: i). - count _ count -1 ]. - i _ i + 1 ]. - minHeight := integerHeights sum. - theTop := ((usableHeight - minHeight) * (padding ifNil: [0]) max: 0) + boundsForLayout top + ySep. - usableWidth := boundsForLayout width - (xSep * 2) max: 0. - boundsLeft := boundsForLayout left + xSep. - boundsBottom := boundsForLayout bottom - ySep. - boundsRight := boundsForLayout right - xSep. - - submorphsToLayout size to: 1 by: -1 do: [ :index | - nextMorph := submorphsToLayout at: index. - "major direction" - ht := integerHeights at: index. - "minor direction" - ls := nextMorph layoutSpec. - wd := (ls widthFor: usableWidth) min: usableWidth. - theLeft := ((usableWidth - wd) * ls minorDirectionPadding) floor + boundsLeft. - theRight := (theLeft + wd) ceiling min: boundsRight. - theBottom := (theTop + (ht min: minHeight)) "ceiling" min: boundsBottom. - "Set bounds and adjust major direction for next step" - self flag: #jmvVer2. "should extent be set in m's coordinate system? what if its scale is not 1?" - ls usesMorphExtent - ifTrue: [ - nextMorph morphPosition: theLeft floor @ theTop floor ] - ifFalse: [ - nextMorph morphPosition: theLeft floor @ theTop floor extent: theRight - theLeft @ (theBottom - theTop) ]. - theTop := theBottom + ySep - ]! ! -!ProgressMorph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:55:38' prior: 50363969! - initialize - super initialize. - self separation: 0. - labelMorph _ StringMorph contents: '' font: AbstractFont default. - subLabelMorph _ StringMorph contents: '' font: AbstractFont default. - progress _ ProgressBarMorph new. - progress morphExtent: `200 @ 15`. - self addMorphFront: labelMorph. - self addMorphFront: subLabelMorph. - self addMorph: progress fixedHeight: 15! ! -!HaloHandleMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:51:24' prior: 50363984! - drawOn: aCanvas - - aCanvas - image: (self class circleForm: extent) - multipliedBy: color - at: `0@0`! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 3/12/2018 15:51:29' prior: 50363990! - addHandle: handleSpec - "Add a handle within the halo box as per the haloSpec, and set it up to respond to the given event by sending the given selector to the given recipient. Return the handle." - - | handle aPoint colorToUse form icon | - aPoint _ self - positionIn: haloBox - horizontalPlacement: handleSpec horizontalPlacement - verticalPlacement: handleSpec verticalPlacement. - colorToUse _ Color colorFrom: handleSpec color. - handle _ HaloHandleMorph new color: colorToUse. - self addMorph: handle. - handle morphBoundsInWorld: (Rectangle center: aPoint extent: self class handleSize asPoint). - handleSpec iconSymbol ifNotNil: [ :iconName | - form _ self class icons at: iconName ifAbsent: [self class perform: iconName]. - form ifNotNil: [ - icon _ ImageMorph new - image: form; - color: colorToUse makeForegroundColor; - lock. - handle addMorphFront: icon position: `0@0` ]]. - handle mouseUpSelector: #endInteraction. - handle setBalloonText: handleSpec hoverHelp. - ^ handle! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 3/12/2018 15:51:35' prior: 50364024! - basicBox - | aBox minSide anExtent w | - minSide _ 4 * self class handleSize. - anExtent _ ((extent x + self class handleSize + 8) max: minSide) @ - ((extent y + self class handleSize + 8) max: minSide). - aBox _ Rectangle center: self morphBoundsInWorld center extent: anExtent. - w _ self world ifNil: [ target world ]. - ^ w - ifNil: - [ aBox ] - ifNotNil: - [ aBox intersect: (w viewBox insetBy: `8@8`) ]! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 3/12/2018 15:51:38' prior: 50364040! - startGrow: evt with: growHandle - "Initialize resizing of my target. Launch a command representing it, to support Undo" - - | botRt | - evt hand obtainHalo: self. "Make sure the event's hand correlates with the receiver" - self removeAllHandlesBut: growHandle. "remove all other handles" - botRt _ target morphPositionInWorld + target morphExtentInWorld. - positionOffset _ (self world viewBox containsPoint: botRt) - ifTrue: [evt eventPosition - botRt] - ifFalse: [`0@0`]! ! -!InnerHierarchicalListMorph methodsFor: 'geometry' stamp: 'jmv 3/12/2018 15:52:04' prior: 50364058! - itemFromPoint: aPoint - "Return the list element (morph) at the given point or nil if outside" - | ptY last | - self hasSubmorphs ifFalse: [ ^nil ]. - (aPoint > `0@0` and: [ aPoint < extent ]) ifFalse: [ ^nil ]. - ptY _ aPoint y. - "note: following assumes that submorphs are vertical, non-overlapping, and ordered" - self firstSubmorph morphPosition y > ptY ifTrue: [ ^nil ]. - last _ self lastSubmorph. - last morphPosition y + last morphHeight < ptY ifTrue: [ ^nil ]. - "now use binary search" - ^self - findSubmorphBinary: [ :m | - (m morphPosition y <= ptY and: [ m morphPosition y + m morphHeight >= ptY ]) - ifTrue: [ 0 ] "found" - ifFalse: [ m morphPosition y + (m morphHeight // 2) > ptY ifTrue: [-1] ifFalse: [1]]]! ! -!InnerListMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:52:08' prior: 50364084! - drawBackgroundForMulti: row on: aCanvas - | selectionDrawBounds c | - "shade the background darker, if this row is selected" - selectionDrawBounds _ self drawBoundsForRow: row. - selectionDrawBounds _ selectionDrawBounds intersect: (`0@0` extent: extent). - c _ (selectedRow notNil and: [ row = selectedRow]) - ifTrue: [ Theme current listHighlightFocused: owner hasKeyboardFocus ] - ifFalse: [ Theme current listMultiHighlightFocused: owner hasKeyboardFocus ]. - aCanvas fillRectangle: selectionDrawBounds color: c! ! -!InnerListMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:52:11' prior: 50364103! - drawHighlightOn: aCanvas -"Ademas, poner el mouse pointer de relojito si tarda... Detectarlo automaticamente, etc. Aunque no estoy seguro de como hacerlo... quizas colgar un cachito de codigo en un proceso de mayor prioridad, onda 'si pasa 1 segundo, y todavia no te resetee este flag, entonces pone el relojito'" - | selectionDrawBounds | - highlightedRow ifNil: [ ^self ]. - highlightedRow = 0 ifTrue: [ ^self ]. - selectionDrawBounds _ self drawBoundsForRow: highlightedRow. - selectionDrawBounds _ selectionDrawBounds intersect: (`0@0` extent: extent). - aCanvas - fillRectangle: selectionDrawBounds - color: (Theme current listHighlightFocused: owner hasKeyboardFocus) duller! ! -!InnerListMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:52:14' prior: 50364127! - drawSelectionOn: aCanvas - | selectionDrawBounds | - selectedRow ifNil: [ ^self ]. - selectedRow = 0 ifTrue: [ ^self ]. - selectionDrawBounds _ self drawBoundsForRow: selectedRow. - selectionDrawBounds _ selectionDrawBounds intersect: (`0@0` extent: extent). - aCanvas - fillRectangle: selectionDrawBounds - color: (Theme current listHighlightFocused: owner hasKeyboardFocus)! ! -!InnerTextMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:52:17' prior: 50364142! - drawOn: aCanvas - "Draw the receiver on a canvas" - - false ifTrue: [ self debugDrawLineRectsOn: aCanvas ]. "show line rects for debugging" - - aCanvas - textComposition: self textComposition - bounds: (`0@0` extent: extent) - color: color - selectionColor: (Theme current textHighlightFocused: self hasKeyboardFocus)! ! -!ResizeMorph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:56:01' prior: 50364155! - initialize - super initialize. - extent _ `400@300`. - color _ Color white. - grid _ `8@6`. - gridLineWidth _ 2. - gridColor _ Color black. - selectionColor _ Color red! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:48:45' prior: 50364164! - createAcceptButton - "create the [accept] button" - | result | - result _ PluggableButtonMorph new - model: self; - color: Theme current acceptButton; - label: 'Accept'; - action: #acceptClicked. - result morphExtent: `6@2` * self sizeUnit. - self addMorph: result position: `2@7.5` * self sizeUnit // 1. - ^ result! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:48:48' prior: 50364177! -createCancelButton - "create the [cancel] button" - | result | - result _ PluggableButtonMorph new - model: self; - color: Theme current cancelButton; - label: 'Cancel'; - action: #cancelClicked. - result morphExtent: `6@2` * self sizeUnit. - self addMorph: result position: `12@7.5` * self sizeUnit // 1. - ^ result! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:48:51' prior: 50364191! - createQueryTextMorph: queryString - "create the queryTextMorph" - | result | - result _ StringMorph new contents: queryString. - result lock. - result morphExtent: `24@2` * self sizeUnit. - self addMorph: result position: `2@0.5` * self sizeUnit // 1. - ^ result! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:48:54' prior: 50364203! - createTextPaneAcceptOnCR: acceptBoolean - "create the textPane" - | result | - - self flag: #todo. "Integrate this method with the Theme system. --cbr" - - result _ TextModelMorph - textProvider: self - textGetter: #response - textSetter: #response: - selectionGetter: #selectionInterval. - result hasUnacceptedEdits: true. - result acceptOnCR: acceptBoolean. - result morphExtent: `18@5` * self sizeUnit. - self addMorph: result position: `1@2` * self sizeUnit. - ^ result! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:49:00' prior: 50364221! - initialize - - super initialize. - extent _ `20@10` * self sizeUnit. - responseUponCancel _ ''! ! -!FillInTheBlankMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:48:57' prior: 50364227! - drawOn: aCanvas - - Theme current roundWindowCorners - ifTrue: [ - aCanvas - roundRect: (`0@0` extent: extent) - color: color - radius: Theme current roundedWindowRadius ] - ifFalse: [ super drawOn: aCanvas ]! ! -!TranscriptMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:57:36' prior: 50364237! - drawOn: aCanvas - Transcript - showOnDisplay: true; - displayOn: form in: (`0@0` extent: extent). - aCanvas image: form at: `0@0`. - Transcript - bounds: self morphBoundsInWorld; - showOnDisplay: doImmediateUpdates. - self updateWorkspace! ! -!MenuLineMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:53:05' prior: 50364248! - drawOn: aCanvas - | baseColor | - baseColor _ owner color. - aCanvas - fillRectangle: (`0@0` corner: extent x @ (extent y / 2)) - color: baseColor twiceDarker. - - aCanvas - fillRectangle: (0 @ (extent y / 2) corner: extent) - color: baseColor twiceLighter! ! -!MenuLineMorph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:53:08' prior: 50364259! -initialize - super initialize. - extent _ `50 @ 2`! ! -!MenuLineMorph methodsFor: 'geometry' stamp: 'jmv 3/12/2018 15:53:10' prior: 50364264! - minimumExtent - - ^`10@2`! ! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 3/12/2018 15:57:46' prior: 50364268! - tryDeferredUpdatingAndSetCanvas - "If this platform supports deferred updates, then make my canvas be the Display (or a rectangular portion of it), set the Display to deferred update mode, and answer true. Otherwise, set a non-Disply canvas and answer false.." - | properDisplay | - - "As this is the only sender of #deferUpdates: , this could be done in Morphic or image startup, and never efterwards..." - (Display deferUpdates: true) ifNil: [ - "deferred updates not supported by the VM, do them in the image!!" - self ensureNonDisplayCanvas. - ^ false]. - - "if no canvas, or canvas was offscreen, from a platform that didnt support defers, then fix it" - properDisplay _ canvas notNil and: [canvas drawsOnDisplay]. - properDisplay ifFalse: [ - world morphPosition: `0@0` extent: Display extent. - self setCanvas: Display getCanvas. - ]. - ^ true! ! -!MorphicEvent methodsFor: 'dispatching' stamp: 'jmv 3/12/2018 15:54:16' prior: 50364298! - startDispatchFrom: aHand - "double dispatch the event dispatch" - "An event of an unknown type was sent. What shall we do?!!" - - Smalltalk beep. - self printString displayAt: `0@0`. - self wasHandled: true! ! -!MorphicCanvas methodsFor: 'accessing' stamp: 'jmv 3/12/2018 15:54:04' prior: 50364308! - newClipRect: aRectangleOrNil - "aRectangle is in world coordinates. - But ivar clipRect is relative to the form, - For example, if we had previously been built like - aCanvas on: someForm over: (100@100 extent 200@100) - then our origin would be -100 @ -100. - Then, a clipRect argument like (120@120 extent: 40@30) would mean affecting - only (20@20 extent: 40@30) in our form" - - self setClipRect: (aRectangleOrNil - ifNil: [ `0@0` corner: form extent ] - ifNotNil: [ aRectangleOrNil translatedBy: self canvasOrigin ])! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 3/12/2018 15:53:57' prior: 50364327! - drawCurrentAsError - "The morph (or one of its submorphs) had an error in its drawing method." - | r w | - r _ currentMorph morphLocalBounds. - w _ r extent > `50@50` - ifTrue: [ 6 ] - ifFalse: [ 2 ]. - self - frameAndFillRectangle: r - fillColor: Color red - borderWidth: w - borderColor: Color yellow. - self line: r topLeft to: r bottomRight-w width: w color: Color yellow. - self line: r topRight -(w@0) to: r bottomLeft -(0@w)width: w color: Color yellow! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/12/2018 15:54:00' prior: 50364345! - drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - aColor = Color black ifFalse: [ | topColor | - topColor _ aColor alphaMixed: 0.25 with: Color black. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint - font: fontOrNil - color: topColor ]. - aColor = Color white ifFalse: [ | bottomColor | - bottomColor _ aColor alphaMixed: 0.22 with: Color white. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + `0@2` - font: fontOrNil - color: bottomColor ]. - ^self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + `0@1` - font: fontOrNil - color: aColor! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/12/2018 15:54:10' prior: 50364372! - textComposition: aTextComposition bounds: boundsRect color: c selectionColor: sc - | displayScanner leftInRun line boundsInWorld tl | - - tl _ boundsRect topLeft. - boundsInWorld _ currentTransformation displayBoundsOfTransformOf: boundsRect. - - displayScanner _ MorphicScanner new - defaultFont: aTextComposition defaultFont; - text: aTextComposition textComposed - foreground: c. - displayScanner canvas: self. - - leftInRun _ 0. - "Take clipRect into account. Extrememly fast scrolls and redraws of huge files (like .sources)" - (aTextComposition lineIndexForPoint: (`0@0` max: (clipLeft@clipTop)- boundsInWorld origin)) - to: (aTextComposition lineIndexForPoint: (boundsInWorld extent min: (clipRight@clipBottom+1) - boundsInWorld origin)) - do: [ :i | - line _ aTextComposition lines at: i. - aTextComposition - displaySelectionInLine: line - on: self - textTopLeft: tl - selectionColor: sc. - leftInRun _ displayScanner displayLine: line textTopLeft: tl leftInRun: leftInRun ]! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 3/12/2018 15:54:13' prior: 50364407! - onForm: aForm - - ^ self basicNew - initializeWith: aForm origin: `0@0`! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 3/12/2018 15:47:31' prior: 50364412! - fillRectangle: aRectangle tilingWith: aForm sourceRect: patternBox rule: aCombinationRule - "aRectangle is in form coordinates, no transformation is done." - | displayRectangle additionalOffset clippedPort targetTopLeft clipOffset ex - targetBox savedMap top left | - - ex _ patternBox extent. - ex x = 0 ifTrue: [ ^self ]. - ex y = 0 ifTrue: [ ^self ]. - displayRectangle _ currentTransformation displayBoundsOfTransformOf: aRectangle. - - "this is a bit of a kludge to get the form to be aligned where I *think* it should be. - something better is needed, but not now" - - additionalOffset _ `0@0`. - clippedPort _ port clippedBy: displayRectangle. - targetTopLeft _ clippedPort clipRect topLeft truncateTo: ex. - clipOffset _ displayRectangle topLeft - targetTopLeft. - additionalOffset _ (clipOffset \\ ex) - ex. - - "do it iteratively" - targetBox _ clippedPort clipRect. - savedMap _ clippedPort colorMap. - clippedPort sourceForm: aForm; - fillColor: nil; - combinationRule: aCombinationRule; - sourceRect: patternBox; - colorMap: (aForm colormapIfNeededFor: clippedPort destForm). - top _ (targetBox top truncateTo: patternBox height) + additionalOffset y. - left _ (targetBox left truncateTo: patternBox width) + additionalOffset x. - - left to: (targetBox right - 1) by: patternBox width do: [:x | - top to: (targetBox bottom - 1) by: patternBox height do: [:y | - clippedPort destOrigin: x@y; copyBits]]. - clippedPort colorMap: savedMap! ! -!BitBltCanvas class methodsFor: 'cached forms' stamp: 'jmv 3/12/2018 15:47:38' prior: 50364460! - steButtonForm: extent - ^self cachedForms - at: { #steButton . extent } - ifAbsentPut: [ - | form canvas | - form _ Form extent: extent depth: 32. - canvas _ form getCanvas. - canvas - roundRect: (`0@0` extent: extent) - color: (Color gray: 0.4) - radius: 4. - canvas - roundRect: (`1@1` extent: extent-2) - color: Color white - radius: 4 - gradientTop: 1.0 - gradientCenter: 0.73 - gradientBottom: 0.94 - gradient1Height: (extent y-8+1 max: extent y//2). - form]! ! -!BitBltCanvas class methodsFor: 'cached arrow forms' stamp: 'jmv 3/12/2018 15:47:35' prior: 50364479! - buildArrowWith: insideForm borderForm: borderForm - | extent translucentForm color insideSpec borderSpec border background alpha| - " - Display getCanvas - image: (BitBltCanvas buildArrowWith: BitBltCanvas downInsideForm borderForm: BitBltCanvas downBorderForm) - at: 20@20 - Display getCanvas - image: (BitBltCanvas buildArrowWith:BitBltCanvas upInsideForm borderForm: BitBltCanvas upBorderForm) - at: 40@20 - " - extent _ insideForm extent - `1@2`. - translucentForm _ Form extent: insideForm extent depth: 32. - 0 to: extent x-1 do: [ :x | - 0 to: extent y-1 do: [ :y | - insideSpec _ insideForm colorAt: x@(y+1). - borderSpec _ borderForm colorAt: x@(y+1). - insideSpec = (Color r: 0.0 g: 0.0 b: 1.0) - ifTrue: [ color _ Color transparent ] - ifFalse: [ - borderSpec = (Color r: 1.0 g: 0.0 b: 0.0) - ifTrue: [ color _ insideSpec ] - ifFalse: [ - border _ x < (extent x//2) - ifTrue: [Color white] - ifFalse: [Color black]. - background _ borderForm colorAt: extent x@(y+1). - alpha _ borderSpec red asFloat - background red / (border red - background red). - color _ border alpha: (alpha min: 1 max: 0) ]]. - translucentForm colorAt: x@y put: color ]]. - ^translucentForm! ! -!TextComposition methodsFor: 'selection' stamp: 'jmv 3/12/2018 15:57:22' prior: 50364520! - defaultCharacterBlock - ^ CharacterBlock - stringIndex: 1 - text: model actualContents - topLeft: lines first topLeft - extent: `0 @ 0` - textLine: lines first! ! -!SHParserST80 methodsFor: 'character testing' stamp: 'jmv 3/12/2018 15:56:04' prior: 50334801! - isBinarySelectorCharacter: aCharacter - - aCharacter isValidInIdentifiers ifTrue: [^false]. - aCharacter isSeparator ifTrue: [^false]. - - ('"#$'':().;[]{}_`' includes: aCharacter) - ifTrue:[^false]. - aCharacter numericValue = Scanner doItCharacterValue ifTrue: [^false "the doIt char"]. - aCharacter numericValue = 0 ifTrue: [^false]. - "Any other char is ok as a binary selector char." - ^ true! ! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 3/12/2018 15:56:08' prior: 50373247! - parseBacktick - self enterBlock. - self scanPast: #backtick. - currentTokenFirst == $| ifTrue: [self parseBlockTemporaries]. - self parseStatementList. - self failUnless: currentTokenFirst == $`. - self scanPast: #backtick. - self leaveBlock! ! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 3/12/2018 15:56:12' prior: 50335056! - parseTerm - self failWhen: currentToken isNil. - currentTokenFirst == $( - ifTrue: [ - bracketDepth := bracketDepth + 1. - self scanPast: #leftParenthesis level: bracketDepth. - self parseExpression. - self failUnless: currentTokenFirst == $). - self scanPast: #rightParenthesis level: bracketDepth. - bracketDepth := bracketDepth - 1. - ^self ]. - currentTokenFirst == $[ ifTrue: [^self parseBlock]. - currentTokenFirst == $` ifTrue: [^self parseBacktick]. - currentTokenFirst == ${ - ifTrue: [ - self scanPast: #leftBrace. - self parseBraceArray. - ^self ]. - self isName ifTrue: [^self scanPast: (self resolve: currentToken)]. - self parseLiteral: false! ! -!DifferenceFinder methodsFor: 'private' stamp: 'jmv 3/12/2018 15:48:12' prior: 50364528! - maxLengthPoints - | max points | - max := self maxLength. - max = 0 ifTrue: [^Array with: `0 @ 0`]. - points := OrderedCollection new. - tally withIndexesDo: [:i :j :t | t = max ifTrue: [points add: i @ j]]. - ^ points! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3271-RefreshAllMethodsUsingBacktick-JuanVuletich-2018Mar12-15h44m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3271] on 12 March 2018 at 4:50:33 pm'! -!Color class methodsFor: 'instance creation' stamp: 'jmv 3/7/2018 10:37:22'! - jet: fraction - "Answer a suitable color for a HeatMap using the 'jet' color scheme. - See https://en.wikipedia.org/wiki/Heat_map - - Color showColors: ((0.0 to: 1.0 count: 100) collect: [ :f | Color jet: f ]) - " - - | hue | - hue _ Color blue hue interpolateTo: Color red hue at: fraction. - ^ Color h: hue s: 1 v: 1! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3272-jet-heatmap-colors-JuanVuletich-2018Mar12-16h48m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3272] on 12 March 2018 at 6:02:58 pm'! -!InputSensor methodsFor: 'keyboard' stamp: 'jmv 3/10/2018 22:22:45' prior: 50356638! - kbdTest - " - Sensor kbdTest - " - "This test routine will print the unmodified character, its keycode, - and the OR of all its modifier bits, until the character x is typed - -Also useful: - Sensor test - " - | char | - char _ nil. - [ char = $x ] whileFalse: [ - [ self keyboardPressed ] whileFalse. - char _ self keyboard. - Display fill: `5@5 extent: 400@20` fillColor: `Color white`. - (String streamContents: [ :s | - s - nextPut: $-; - nextPut: char; - nextPut: $-; - space; - print: char numericValue; - space. - self isMouseButton3Pressed ifTrue: [ s nextPutAll: ' mouseButton3/blue/tertiary/halo ' ]. - self isMouseButton2Pressed ifTrue: [ s nextPutAll: ' mouseButton2/yellow/secondary/menu ' ]. - self isMouseButton1Pressed ifTrue: [ s nextPutAll: ' mouseButton1/red/primary ' ]. - self shiftPressed ifTrue: [ s nextPutAll: ' shift ' ]. - self controlKeyPressed ifTrue: [ s nextPutAll: ' control/ctrl ' ]. - (self primMouseButtons anyMask: 32) ifTrue: [ s nextPutAll: ' macOption ' ]. - self commandAltKeyPressed ifTrue: [ s nextPutAll: ' macCommand/winAlt ' ]]) - displayAt: 10 @ 10 ].! ! -!String methodsFor: 'displaying' stamp: 'jmv 3/10/2018 21:32:34' prior: 50356676! - 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` - " - 'Display' displayOn: Display at: 10@10 - "! ! -!Color methodsFor: 'conversions' stamp: 'jmv 3/10/2018 21:25:40' prior: 50356688! - makeForegroundColor - "Make a foreground color contrasting with me" - ^self luminance >= 0.5 - ifTrue: [`Color black`] - ifFalse: [`Color white`]! ! -!Color methodsFor: 'transformations' stamp: 'jmv 3/10/2018 21:25:46' prior: 50356863! - muchDarker - - ^ self alphaMixed: 0.5 with: `Color black` -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 3/10/2018 22:17:55' prior: 50356868! - muchLighter - - ^ self alphaMixed: 0.233 with: `Color white`! ! -!Color methodsFor: 'transformations' stamp: 'jmv 3/10/2018 21:25:51' prior: 50356880! - quiteBlacker - - ^ self alphaMixed: 0.8 with: `Color black` -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 3/10/2018 22:18:15' prior: 50356885! - quiteWhiter - - ^ self alphaMixed: 0.6 with: `Color white`! ! -!Color methodsFor: 'transformations' stamp: 'jmv 3/10/2018 21:26:03' prior: 50356895! - veryMuchDarker - - ^ self alphaMixed: 0.25 with: `Color black`! ! -!Color methodsFor: 'transformations' stamp: 'jmv 3/10/2018 22:18:31' prior: 50356900! - veryMuchLighter - - ^ self alphaMixed: 0.07 with: `Color white`! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 3/10/2018 21:27:30' prior: 50356910! - colorFromPixelValue: p depth: d - "Convert a pixel value for the given display depth into a color." - "Details: For depths of 8 or less, the pixel value is simply looked up in a table. For greater depths, the color components are extracted and converted into a color." - "Warning: In BitBlt, a pixel with pixelValue = 0 is transparent. - Squeak usually assumes that r=g=b=0 => transparent. But this is false if we have alpha (opacity). - A color with r=g=b=0 and opacity = 255 is BLACK, not TRANSPARENT. - Squeak also answers darkest possible blue when asked for black. Again, this is not needed in 32 bits (with alpha). It is also not really needed for 16 bits as we have an extra, unused bit: 16r8000 is not zero, but rgb=0, and hence, black. - The real rule is that pixelValue=0 means transparent. - And that darkest blue must be used instead of black, but only for depths >8 and < 16 (no indexed colors, no alpha) - This method is updated to reflect that." - - | r g b alpha | - - d = 1 ifTrue: [^ self indexedColors at: (p bitAnd: 16r01) + 1]. - - "For the rest of the depths, pixelValue = 0 means transparent, and darkest blue is considered to be black." - p = 0 ifTrue: [ ^ `Color transparent` ]. - - d = 8 ifTrue: [^ self indexedColors at: (p bitAnd: 16rFF) + 1]. - d = 4 ifTrue: [^ self indexedColors at: (p bitAnd: 16r0F) + 1]. - d = 2 ifTrue: [^ self indexedColors at: (p bitAnd: 16r03) + 1]. - - d = 32 ifTrue: [ - "eight bits per component; 8 bits of alpha" - alpha _ p bitShift: -24. - alpha = 0 ifTrue: [ ^`Color transparent` ]. - r _ (p bitShift: -16) bitAnd: 16rFF. - g _ (p bitShift: -8) bitAnd: 16rFF. - b _ p bitAnd: 16rFF. - ^alpha < 255 - ifTrue: [ (Color r: r g: g b: b range: 255) alpha: alpha asFloat / 255.0 ] - ifFalse: [ Color r: r g: g b: b range: 255 ]]. - - d = 16 ifTrue: [ - "five bits per component. The most significant bit, unused, allows having real black, without p being zero" - r _ (p bitShift: -10) bitAnd: 16r1F. - g _ (p bitShift: -5) bitAnd: 16r1F. - b _ p bitAnd: 16r1F. - ^ Color r: r g: g b: b range: 31]. - - d = 15 ifTrue: [ - "five bits per component" - r _ (p bitShift: -10) bitAnd: 16r1F. - g _ (p bitShift: -5) bitAnd: 16r1F. - b _ p bitAnd: 16r1F. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^`Color black` ]. - ^ Color r: r g: g b: b range: 31]. - - d = 12 ifTrue: [ - "four bits per component" - r _ (p bitShift: -8) bitAnd: 16rF. - g _ (p bitShift: -4) bitAnd: 16rF. - b _ p bitAnd: 16rF. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^`Color black` ]. - ^ Color r: r g: g b: b range: 15]. - - d = 9 ifTrue: [ - "three bits per component" - r _ (p bitShift: -6) bitAnd: 16r7. - g _ (p bitShift: -3) bitAnd: 16r7. - b _ p bitAnd: 16r7. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^`Color black` ]. - ^ Color r: r g: g b: b range: 7]. - - self error: 'unknown pixel depth: ', d printString! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 3/10/2018 20:53:35' prior: 50354479! - fromArray: colorDef - - | answer | - colorDef size = 0 ifTrue: [^ `Color transparent` ]. - colorDef size between: 3 and: 4 :: ifFalse: [self error: 'Undefined color definition']. - answer _ self r: (colorDef at: 1) g: (colorDef at: 2) b: (colorDef at: 3). - ^colorDef size = 3 - ifTrue: [answer] - ifFalse: [answer alpha: (colorDef at: 4)]! ! -!Color class methodsFor: 'class initialization' stamp: 'jmv 3/10/2018 20:57:43' prior: 50357001! - initializeIndexedColors - "Build an array of colors corresponding to the fixed colormap used - for display depths of 1, 2, 4, or 8 bits." - "Color initializeIndexedColors" - - | a index grayVal | - a _ Array new: 256. - - "1-bit colors (monochrome)" - a at: 1 put: `Color r: 1.0 g: 1.0 b: 1.0`. "white or transparent" - a at: 2 put: `Color r: 0.0 g: 0.0 b: 0.0`. "black" - - "additional colors for 2-bit color" - a at: 3 put: `Color r: 1.0 g: 1.0 b: 1.0`. "opaque white" - a at: 4 put: `Color r: 0.5 g: 0.5 b: 0.5`. "1/2 gray" - - "additional colors for 4-bit color" - a at: 5 put: `Color r: 1.0 g: 0.0 b: 0.0`. "red" - a at: 6 put: `Color r: 0.0 g: 1.0 b: 0.0`. "green" - a at: 7 put: `Color r: 0.0 g: 0.0 b: 1.0`. "blue" - a at: 8 put: `Color r: 0.0 g: 1.0 b: 1.0`. "cyan" - a at: 9 put: `Color r: 1.0 g: 1.0 b: 0.0`. "yellow" - a at: 10 put: `Color r: 1.0 g: 0.0 b: 1.0`. "magenta" - - a at: 11 put: `Color r: 0.125 g: 0.125 b: 0.125`. "1/8 gray" - a at: 12 put: `Color r: 0.25 g: 0.25 b: 0.25`. "2/8 gray" - a at: 13 put: `Color r: 0.375 g: 0.375 b: 0.375`. "3/8 gray" - a at: 14 put: `Color r: 0.625 g: 0.625 b: 0.625`. "5/8 gray" - a at: 15 put: `Color r: 0.75 g: 0.75 b: 0.75`. "6/8 gray" - a at: 16 put: `Color r: 0.875 g: 0.875 b: 0.875`. "7/8 gray" - - "additional colors for 8-bit color" - "24 more shades of gray (1/32 increments but not repeating 1/8 increments)" - index _ 17. - 1 to: 31 do: [:v | - (v \\ 4) = 0 ifFalse: [ - grayVal _ v / 32.0. - a at: index put: (Color r: grayVal g: grayVal b: grayVal). - index _ index + 1]]. - - "The remainder of color table defines a color cube with six steps - for each primary color. Note that the corners of this cube repeat - previous colors, but this simplifies the mapping between RGB colors - and color map indices. This color cube spans indices 40 through 255 - (indices 41-256 in this 1-based array)." - 0 to: 5 do: [:r | - 0 to: 5 do: [:g | - 0 to: 5 do: [:b | - index _ 41 + ((36 * r) + (6 * b) + g). - index > 256 ifTrue: [ - self error: 'index out of range in color table compuation']. - a at: index put: (Color r: r g: g b: b range: 5)]]]. - - IndexedColors _ a. -! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 3/10/2018 22:18:42' prior: 50357186! - computeIndexedColorConvertingMap: targetColor from: sourceDepth to: destDepth - | map | - - map _ (self indexedColors copyFrom: 1 to: (1 bitShift: sourceDepth)) collect: [ :cc | | f c | - f _ 1.0 - (cc red + cc green + cc blue / 3.0 ). - c _ targetColor - ifNotNil: [ - destDepth = 32 - ifTrue: [ targetColor * f alpha: f] - ifFalse: [ targetColor alphaMixed: f*1.5 with: `Color white` ]] - ifNil: [ cc ]. - destDepth = 32 - ifTrue: [ c pixelValueForDepth: destDepth] - ifFalse: [ - f = 0.0 - ifTrue: [ 0 ] - ifFalse: [ c pixelValueForDepth: destDepth ]]]. - map _ map as: Bitmap. - ^map! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 3/10/2018 21:59:30' prior: 50357208! - computeRGBColorConvertingMap: targetColor to: destDepth keepSubPixelAA: keepSubPix - "Builds a colormap intended to convert from subpixelAA black values to targetColor values. - keepSubPix - ifTrue: [ Answer colors that also include subpixelAA ] - ifFalse: [ - Take fullpixel luminance level. Apply it to targetColor. - I.e. answer colors with NO subpixelAA ]" - - | mask map c bitsPerColor r g b f v | - - destDepth > 8 - ifTrue: [bitsPerColor _ 5] "retain maximum color resolution" - ifFalse: [bitsPerColor _ 4]. - "Usually a bit less is enough, but make it configurable" - bitsPerColor _ bitsPerColor min: Preferences aaFontsColormapDepth. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - r _ (i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask. - g _ (i bitShift: 0 - bitsPerColor) bitAnd: mask. - b _ (i bitShift: 0) bitAnd: mask. - f _ 1.0 - (r + g + b / 3.0 / mask). - c _ targetColor - ifNotNil: [ - (keepSubPix and: [destDepth > 8]) ifTrue: [ - Color - r: 1.0 - (r asFloat/mask) * targetColor red - g: 1.0 - (g asFloat/mask) * targetColor green - b: 1.0 - (b asFloat/mask) * targetColor blue - alpha: f * targetColor alpha "alpha will be ignored below, in #pixelValueForDepth: if destDepth ~= 32" ] - ifFalse: [ - destDepth = 32 - ifTrue: [ targetColor * f alpha: f * targetColor alpha ] - ifFalse: [ targetColor alphaMixed: f*1.5 with: `Color white` ]]] - ifNil: [ Color r: r g: g b: b range: mask]. "This is currently used only to keep some SubPixelAA on destDepth = 8, using a single pass of rule 25" - v _ destDepth = 32 - ifTrue: [ c pixelValueForDepth: destDepth] - ifFalse: [ - f < 0.1 - ifTrue: [ 0 ] - ifFalse: [ c pixelValueForDepth: destDepth ]]. - map at: i + 1 put: v ]. - ^ map! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 3/10/2018 22:09:19' prior: 50357268! - computeRGBColormapFor: destDepth bitsPerColor: bitsPerColor - "Compute a colorMap for translating from 16-bit or 32-bit RGB color to the given depth, using the given number of of bits per color component." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | mask map c | - (#(3 4 5) includes: bitsPerColor) - ifFalse: [self error: 'BitBlt only supports 3, 4, or 5 bits per color component']. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - c _ Color - r: ((i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask) - g: ((i bitShift: 0 - bitsPerColor) bitAnd: mask) - b: ((i bitShift: 0) bitAnd: mask) - range: mask. - map at: i + 1 put: (c pixelValueForDepth: destDepth)]. - - map at: 1 put: (`Color transparent` pixelWordForDepth: destDepth). "zero always transparent" - ^ map -! ! -!Color class methodsFor: 'color name lookup' stamp: 'jmv 3/10/2018 20:42:11' prior: 50357542! - traditionalColorNamesDictionary - "Answer a dictionary of Squeak traditional name->color associations.." - - | nameDict | - nameDict _ Dictionary new. - nameDict at: #black put: `Color r: 0 g: 0 b: 0`. - nameDict at: #veryVeryDarkGray put: `Color r: 0.125 g: 0.125 b: 0.125`. - nameDict at: #veryDarkGray put: `Color r: 0.25 g: 0.25 b: 0.25`. - nameDict at: #darkGray put: `Color r: 0.375 g: 0.375 b: 0.375`. - nameDict at: #gray put: `Color r: 0.5 g: 0.5 b: 0.5`. - nameDict at: #lightGray put: `Color r: 0.625 g: 0.625 b: 0.625`. - nameDict at: #veryLightGray put: `Color r: 0.75 g: 0.75 b: 0.75`. - nameDict at: #veryVeryLightGray put: `Color r: 0.875 g: 0.875 b: 0.875`. - nameDict at: #white put: `Color r: 1.0 g: 1.0 b: 1.0`. - nameDict at: #red put: `Color r: 1.0 g: 0 b: 0`. - nameDict at: #yellow put: `Color r: 1.0 g: 1.0 b: 0`. - nameDict at: #green put: `Color r: 0 g: 1.0 b: 0`. - nameDict at: #cyan put: `Color r: 0 g: 1.0 b: 1.0`. - nameDict at: #blue put: `Color r: 0 g: 0 b: 1.0`. - nameDict at: #magenta put: `Color r: 1.0 g: 0 b: 1.0`. - nameDict at: #brown put: `Color r: 0.6 g: 0.2 b: 0`. - nameDict at: #orange put: `Color r: 1.0 g: 0.6 b: 0`. - nameDict at: #lightRed put: `Color r: 1.0 g: 0.8 b: 0.8`. - nameDict at: #lightYellow put: `Color r: 1.0 g: 1.0 b: 0.8`. - nameDict at: #lightGreen put: `Color r: 0.8 g: 1.0 b: 0.6`. - nameDict at: #lightCyan put: `Color r: 0.4 g: 1.0 b: 1.0`. - nameDict at: #lightBlue put: `Color r: 0.8 g: 1.0 b: 1.0`. - nameDict at: #lightMagenta put: `Color r: 1.0 g: 0.8 b: 1.0`. - nameDict at: #lightBrown put: `Color r: 1.0 g: 0.6 b: 0.2`. - nameDict at: #lightOrange put: `Color r: 1.0 g: 0.8 b: 0.4`. - nameDict at: #transparent put: `TranslucentColor r: 0.0 g: 0.0 b: 0.0 alpha: 0.0`. - - ^nameDict -! ! -!Transcripter methodsFor: 'accessing' stamp: 'jmv 3/12/2018 17:57:31' prior: 50382836! - 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]. - textComposition - setModel: (TextModel withText: c asText); - extentForComposing: frame width-8 @9999. - textComposition composeAll. - d _ textComposition usedHeight - frame height. - d > 0 ifTrue: [ - "Scroll up to keep all contents visible" - cb _ textComposition characterBlockAtPoint: - `0@0` + (0@(d+AbstractFont default height)). - self on: (c copyFrom: cb stringIndex to: c size). - readLimit _ position _ collection size. - ^ self endEntry]. - Display fill: (frame insetBy: -2) fillColor: self black; - fill: frame fillColor: self white. - Display getCanvas - textComposition: textComposition - bounds: (`4@4` + frame topLeft extent: Display extent) - color: `Color black` - selectionColor: `Color blue`. - DisplayScreen screenUpdateRequired: nil! ! -!Transcripter methodsFor: 'private' stamp: 'jmv 3/10/2018 21:34:26' prior: 50357796! - black - Display depth = 1 ifTrue: [^ Bitmap with: 16rFFFFFFFF "Works without color support"]. - ^ `Color black`! ! -!Transcripter methodsFor: 'private' stamp: 'jmv 3/10/2018 22:23:58' prior: 50357802! - white - Display depth = 1 ifTrue: [^ Bitmap with: 0 "Works without color support"]. - ^ `Color white`! ! -!DataStream class methodsFor: 'as yet unclassified' stamp: 'jmv 3/10/2018 21:53:12' prior: 50357808! - example - "An example and test of DataStream/ReferenceStream. - 11/19/92 jhm: Use self testWith:." - "DataStream example" - "ReferenceStream example" - | input sharedPoint | - - "Construct the test data." - input _ Array new: 9. - input at: 1 put: nil. - input at: 2 put: true. - input at: 3 put: (Form extent: 63 @ 50 depth: 8). - (input at: 3) fillWithColor: `Color lightBlue`. - input at: 4 put: #(3 3.0 'three'). - input at: 5 put: false. - input at: 6 put: 1024 @ -2048. - input at: 7 put: #x. - input at: 8 put: (Array with: (sharedPoint _ 0 @ -30000)). - input at: 9 put: sharedPoint. - - "Write it out, read it back, and return it for inspection." - ^ self testWith: input! ! -!ReferenceStream class methodsFor: 'as yet unclassified' stamp: 'jmv 3/10/2018 21:54:43' prior: 50357834! - example2 -"Here is the way to use DataStream and ReferenceStream: - rr _ ReferenceStream fileNamed: ''test.obj''. - rr nextPut: . - rr close. - -To get it back: - rr _ ReferenceStream fileNamed: ''test.obj''. - _ rr next. - rr close. -" -"An example and test of DataStream/ReferenceStream. - 11/19/92 jhm: Use self testWith:." - "ReferenceStream example2" - | input sharedPoint | - - "Construct the test data." - input _ Array new: 9. - input at: 1 put: nil. - input at: 2 put: true. - input at: 3 put: false. - input at: 4 put: #(-4 -4.0 'four' four). - input at: 5 put: (Form extent: 63 @ 50 depth: 8). - (input at: 5) fillWithColor: `Color lightOrange`. - input at: 6 put: 1024 @ -2048. - input at: 7 put: input. "a cycle" - input at: 8 put: (Array with: (sharedPoint _ 0 @ -30000)). - input at: 9 put: sharedPoint. - - "Write it out, read it back, and return it for inspection." - ^ self testWith: input -! ! -!TextAction class methodsFor: 'as yet unclassified' stamp: 'jmv 3/10/2018 20:58:51' prior: 50357893! - textActionColor - ^ `Color r: 0.4 g: 0 b: 1.0`! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:33:13' prior: 50370192! - black - ^ self new color: `Color black`! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:41:12' prior: 50370196! - blue - ^ self new color: `Color blue`! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:41:25' prior: 50370200! - cyan - ^ self new color: `Color cyan`! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:41:30' prior: 50370204! - gray - ^ self new color: `Color gray`! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:41:34' prior: 50370208! - green - ^ self new color: `Color green`! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:41:39' prior: 50370212! - magenta - ^ self new color: `Color magenta`! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:42:40' prior: 50370216! - red - ^ self new color: `Color red`! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:42:46' prior: 50370220! - white - ^ self new color: `Color white`! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:42:50' prior: 50370224! - yellow - ^ self new color: `Color yellow`! ! -!TextColor methodsFor: 'testing' stamp: 'jmv 3/10/2018 21:33:19' prior: 50357897! - isSet - "Do not include Color black, as it is the default color." - ^color ~= `Color black`! ! -!TextColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:33:25' prior: 50357902! - black - ^ self new color: `Color black`! ! -!TextColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:38:56' prior: 50357906! - blue - ^ self new color: `Color blue`! ! -!TextColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:39:20' prior: 50357910! - cyan - ^ self new color: `Color cyan`! ! -!TextColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:39:25' prior: 50357914! - gray - ^ self new color: `Color gray`! ! -!TextColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:39:29' prior: 50357918! - green - ^ self new color: `Color green`! ! -!TextColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:39:33' prior: 50357922! - magenta - ^ self new color: `Color magenta`! ! -!TextColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:39:38' prior: 50357926! - red - ^ self new color: `Color red`! ! -!TextColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:39:45' prior: 50357930! -white - ^ self new color: `Color white`! ! -!TextColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:39:51' prior: 50357934! - yellow - ^ self new color: `Color yellow`! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 3/10/2018 22:15:21' prior: 50381666! - displayOn: aForm in: aRectangle - " - Transcript displayOn: Display - " - | font count i string x y fh f canvas innerR | - aForm fill: aRectangle fillColor: `Color white`. - font _ AbstractFont default. - - innerR _ aRectangle insetBy: self padding. - fh _ font height. - count _ innerR height // fh. - x _ innerR left. - y _ innerR top. - f _ firstIndex-1. - firstIndex > lastIndex ifTrue: [ f _ f - self maxEntries ]. - i _ (lastIndex - count max: f) \\ self maxEntries + 1. - canvas _ aForm getCanvas. - canvas newClipRect: innerR. - [ i <= lastIndex ] whileTrue: [ - string _ entries at: i. - canvas drawString: string at: x@y font: font color: `Color veryDarkGray`. - y _ y + fh. - i _ i \\ self maxEntries + 1 ]. - - string _ unfinishedEntry contents. - canvas drawString: string at: x@y font: font color: `Color veryDarkGray`! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 3/10/2018 22:15:54' prior: 50357983! - displayUnfinishedEntryOn: aForm - - | font count string x y fh canvas r innerR | - innerR _ bounds insetBy: self padding. - lastDisplayPosition < innerR right ifTrue: [ - font _ AbstractFont default. - fh _ font height. - count _ innerR height // fh-1. - x _ innerR left. - string _ unfinishedEntry contents. - y _ ((lastIndex - firstIndex \\ self maxEntries) min: count-1) + 1 * font height + innerR top. - canvas _ aForm getCanvas. - r _ innerR left: lastDisplayPosition. - canvas newClipRect: r. - (canvas drawString: string at: x@y font: font color: `Color veryDarkGray`) ifNotNil: [ :lastPoint | - lastDisplayPosition _ lastPoint x. - ^r ]]. - ^nil! ! -!Form methodsFor: 'bordering' stamp: 'jmv 3/10/2018 21:28:34' prior: 50358018! - border: aRectangle width: borderWidth - "Paint a border whose rectangular area is defined by aRectangle. The - width of the border of each side is borderWidth. Uses black for - drawing the border." - - self border: aRectangle width: borderWidth fillColor: `Color black`! ! -!Form methodsFor: 'coloring' stamp: 'jmv 3/10/2018 21:28:39' prior: 50358029! - fillBlack - "Set all bits in the receiver to black (ones)." - - self fill: self boundingBox fillColor: `Color black`! ! -!Form methodsFor: 'coloring' stamp: 'jmv 3/10/2018 21:28:44' prior: 50358035! - fillBlack: aRectangle - "Set all bits in the receiver's area defined by aRectangle to black (ones)." - - self fill: aRectangle rule: Form over fillColor: `Color black`! ! -!Form methodsFor: 'coloring' stamp: 'jmv 3/10/2018 21:45:56' prior: 50358043! - fillGray - "Set all bits in the receiver to gray." - - self fill: self boundingBox fillColor: `Color gray`! ! -!Form methodsFor: 'coloring' stamp: 'jmv 3/10/2018 21:46:03' prior: 50358049! - fillGray: aRectangle - "Set all bits in the receiver's area defined by aRectangle to the gray mask." - - self fill: aRectangle rule: Form over fillColor: `Color gray`! ! -!Form methodsFor: 'coloring' stamp: 'jmv 3/10/2018 22:18:53' prior: 50358057! - fillWhite - "Set all bits in the form to white." - - self fill: self boundingBox fillColor: `Color white`! ! -!Form methodsFor: 'coloring' stamp: 'jmv 3/10/2018 22:19:16' prior: 50358063! - fillWhite: aRectangle - "Set all bits in the receiver's area defined by aRectangle to white." - - self fill: aRectangle rule: Form over fillColor: `Color white`! ! -!Form methodsFor: 'coloring' stamp: 'jmv 3/10/2018 22:19:25' prior: 50358071! - reverse - "Change all the bits in the receiver that are white to black, and the ones - that are black to white. - Display reverse - " - - self fill: self boundingBox rule: Form reverse fillColor: `Color white`! ! -!Form methodsFor: 'coloring' stamp: 'jmv 3/10/2018 22:19:31' prior: 50358080! - reverse: aRectangle - "Change all the bits in the receiver's area that intersects with aRectangle - that are white to black, and the ones that are black to white." - - self fill: aRectangle rule: Form reverse fillColor: `Color white`! ! -!Form methodsFor: 'converting' stamp: 'jmv 3/10/2018 22:10:25' prior: 50358157! - as8BitColorForm - "Simple conversion of zero pixels to transparent. Force it to 8 bits." - - | f map | - f _ ColorForm extent: self extent depth: 8. - self displayOn: f at: self offset negated. - map _ Color indexedColors copy. - map at: 1 put: `Color transparent`. - f colors: map. - f offset: self offset. - ^ f -! ! -!Form methodsFor: 'pixel access' stamp: 'jmv 3/10/2018 22:11:31' prior: 50358178! - colorInterpolatedAt: aPoint - "Evaluate a bilinear (i.e. cheap) interpolation - Like OpenCV's CV_INTER_LINEAR - Answer Color transparent if outside image bounds. - Copied almost verbatim from FloatImage. - Answer Colors with float components. Will be rounded to be stored in, for example, a 32-bit Form." - - | x y w interpolated xWeight1 xWeight0 yWeight1 yWeight0 xIndex0 xIndex1 yIndex0 yIndex1 | - x _ aPoint x. - y _ aPoint y. - x < 0.0 ifTrue: [ ^ `Color transparent` ]. - xIndex0 _ x truncated. "Could be #floor. But as we only care for values >=0, it is the same. But faster." - xIndex0 > (width-1) ifTrue: [ ^ `Color transparent` ]. - (xIndex0 = (width-1) and: [ x > (width-1) ]) ifTrue: [ ^ `Color transparent` ]. - xIndex1 _ xIndex0 = (width-1) "Avoid the invalid access if this was true, but don't make it slower the most common, general case." - ifFalse: [ xIndex0 + 1 ] - ifTrue: [ xIndex0 ]. - - y < 0.0 ifTrue: [ ^ `Color transparent` ]. - yIndex0 _ y truncated. "Could be #floor. But as we only care for values >=0, it is the same. But faster." - yIndex0 > (height-1) ifTrue: [ ^ `Color transparent` ]. - (yIndex0 = (height-1) and: [ y > (height-1) ]) ifTrue: [ ^ `Color transparent` ]. - yIndex1 _ yIndex0 = (height-1) "Avoid the invalid access if this was true, but don't make it slower the most common, general case." - ifFalse: [ yIndex0 + 1 ] - ifTrue: [ yIndex0 ]. - - xWeight1 _ x - xIndex0. - xWeight0 _ 1.0 - xWeight1. - - yWeight1 _ y - yIndex0. - yWeight0 _ 1.0 - yWeight1. - - "/* perform interpolation */" - w _ ((self colorAt: xIndex0 @ yIndex0) * xWeight0) + - ((self colorAt: xIndex1 @ yIndex0) * xWeight1). - interpolated _ w * yWeight0. - - w _ ((self colorAt: xIndex0 @ yIndex1) * xWeight0) + - ((self colorAt: xIndex1 @ yIndex1) * xWeight1). - interpolated _ w * yWeight1 + interpolated. - - ^interpolated! ! -!Form methodsFor: 'transitions' stamp: 'jmv 3/12/2018 17:58:14' prior: 50383726! - pageWarp: otherImage at: topLeft forward: forward - "Produce a page-turning illusion that gradually reveals otherImage - located at topLeft in this form. - forward == true means turn pages toward you, else away. [ignored for now]" - | pageRect oldPage nSteps buffer p leafRect sourceQuad warp oldBottom d | - pageRect _ otherImage boundingBox. - oldPage _ self copy: (pageRect translatedBy: topLeft). - (forward ifTrue: [oldPage] ifFalse: [otherImage]) - border: pageRect - widthRectangle: (Rectangle - left: 0 - right: 2 - top: 1 - bottom: 1) - rule: Form over - fillColor: `Color black`. - oldBottom _ self copy: ((pageRect bottomLeft + topLeft) extent: (pageRect width@(pageRect height//4))). - nSteps _ 8. - buffer _ Form extent: otherImage extent + (0@(pageRect height//4)) depth: self depth. - d _ pageRect topLeft + (0@(pageRect height//4)) - pageRect topRight. - 1 to: nSteps-1 do: - [:i | forward - ifTrue: [buffer copy: pageRect from: otherImage to: `0@0` rule: Form over. - p _ pageRect topRight + (d * i // nSteps)] - ifFalse: [buffer copy: pageRect from: oldPage to: `0@0` rule: Form over. - p _ pageRect topRight + (d * (nSteps-i) // nSteps)]. - buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over. - leafRect _ pageRect topLeft corner: p x @ (pageRect bottom + p y). - sourceQuad _ Array with: pageRect topLeft - with: pageRect bottomLeft + (0@p y) - with: pageRect bottomRight - with: pageRect topRight - (0@p y). - warp _ (WarpBlt toForm: buffer) - clipRect: leafRect; - sourceForm: (forward ifTrue: [oldPage] ifFalse: [otherImage]); - combinationRule: Form paint. - warp copyQuad: sourceQuad toRect: leafRect. - self copy: buffer boundingBox from: buffer to: topLeft rule: Form over. - Display forceToScreen. - ]. - - buffer copy: pageRect from: otherImage to: `0@0` rule: Form over. - buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over. - self copy: buffer boundingBox from: buffer to: topLeft rule: Form over. - Display forceToScreen. -" -1 to: 4 do: [:corner | Display pageWarp: - (Form fromDisplay: (10@10 extent: 200@300)) reverse - at: 10@10 forward: false] -"! ! -!Form class methodsFor: 'instance creation' stamp: 'jmv 3/12/2018 17:58:22' prior: 50383844! - dotOfSize: diameter - "Create a form which contains a round black dot." - | radius form bb rect centerX centerY centerYBias centerXBias radiusSquared xOverY maxy dx | - radius _ diameter//2. - form _ self extent: diameter@diameter offset: `0@0` - radius. - bb _ (BitBlt toForm: form) - sourceX: 0; sourceY: 0; - combinationRule: Form over; - fillColor: `Color black`. - rect _ form boundingBox. - centerX _ rect center x. - centerY _ rect center y. - centerYBias _ rect height odd ifTrue: [0] ifFalse: [1]. - centerXBias _ rect width odd ifTrue: [0] ifFalse: [1]. - radiusSquared _ (rect height asFloat / 2.0) squared - 0.01. - xOverY _ rect width asFloat / rect height asFloat. - maxy _ rect height - 1 // 2. - - "First do the inner fill, and collect x values" - 0 to: maxy do: [ :dy | - dx _ ((radiusSquared - (dy * dy) asFloat) sqrt * xOverY) truncated. - bb destX: centerX - centerXBias - dx - destY: centerY - centerYBias - dy - width: dx + dx + centerXBias + 1 - height: 1; - copyBits. - bb destY: centerY + dy; - copyBits]. - ^ form -" -Time millisecondsToRun: - [1 to: 20 do: [:i | (Form dotOfSize: i) displayAt: (i*20)@(i*20)]] -"! ! -!Form class methodsFor: 'instance creation' stamp: 'jmv 3/10/2018 22:20:49' prior: 50358347! - fakeSphereAt: aPoint diameter: diameter color: aColor - "Create a form which contains a round black dot." - | bb rect d p | - bb _ GrafPort toForm: Display. - bb fillColor: aColor. - bb combinationRule: Form blend. - rect _ aPoint extent: diameter. - bb fillOval: rect. - p _ (diameter * 2 // 5) asPoint + aPoint. - #(2 3 4 5 6 ) do: [ :i | - "simulate facade by circles of gray" - bb fillColor: `Color white alpha: 0.3`. - d _ i * diameter // 10. - rect _ Rectangle - center: p - extent: d. - bb fillOval: rect ]. - DisplayScreen screenUpdateRequired: nil. -" - Form fakeSphereAt: 50@50 diameter: 30 color: (Color red alpha: 0.5) -"! ! -!Form class methodsFor: 'examples' stamp: 'jmv 3/12/2018 17:58:38' prior: 50383882! - toothpaste: diam - " - Display restoreAfter: [Form toothpaste: 30] - " - "Not completely unlike the ST-80 implementation :) - Original comment: - Draws wormlike lines by laying down images of spheres. - See Ken Knowlton, Computer Graphics, vol. 15 no. 4 p352. - Draw with mouse button down; terminate by option-click." - | point queue color q colors colr colr2 | - colors _ `Color red wheel: 12`. - color _ 8. - [ true ] whileTrue: [ - queue _ OrderedCollection new: 32. - 16 timesRepeat: [queue addLast: `-40@-40`]. - Sensor waitButton. - Sensor isMouseButton2Pressed ifTrue: [^ self]. - point _ Sensor mousePoint. - colr _ colors atWrap: (color _ color + 5). "choose increment relatively prime to colors size" - colr2 _ colr alpha: 0.3. - [Sensor isMouseButton1Pressed or: [queue size > 0]] whileTrue: [ - point _ point * 4 + Sensor mousePoint // 5. - point _ point. - Form fakeSphereAt: point diameter: diam color: colr. - (q _ queue removeFirst) ifNil: [^ self]. "exit" - Form fakeSphereAt: q diameter: diam color: colr2. - Sensor isMouseButton1Pressed ifTrue: [queue addLast: point]]]! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 3/10/2018 22:19:44' prior: 50358407! - bottomLeftCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - "Create and answer a Form for the bottomLeft corner of a rounded rectangle" - | f aaw topColor bottomColor l d c width dy | - topColor _ `Color white` * gradientTopFactor. - bottomColor _ `Color white` * gradientBottomFactor. - width _ r. - aaw _ 1.3. - f _ Form - extent: width @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: width - 1 - do: [ :x | - dy _ height - r - y. - dy > 0 - ifTrue: [ l _ 1.0 ] - ifFalse: [ - d _ (width - 1 - x @ dy) r. - l _ ((r - d max: 0.0) min: aaw) / aaw ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 3/10/2018 22:19:58' prior: 50358434! - bottomLeftCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor borderWidth: bw - "Create and answer a Form for the bottomLeft corner of a rounded rectangle" - | f aaw topColor bottomColor l d c width dy l1 l2 | - topColor _ `Color white` * gradientTopFactor. - bottomColor _ `Color white` * gradientBottomFactor. - width _ r. - aaw _ 1.3. - f _ Form - extent: width @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: width - 1 - do: [ :x | - dy _ height - r - y. - dy > 0 - ifTrue: [ l _ 1.0 ] - ifFalse: [ - d _ (width - 1 - x @ dy) r. - l1 _ ((r - d-1+aaw max: 0.0) min: aaw) / aaw. - l2 _ ((d - r+bw+aaw max: 0.0) min: aaw) / aaw. - l _ l1 min: l2. - ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 3/10/2018 22:20:11' prior: 50358465! - bottomRightCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - "Create and answer a Form for the bottomRight corner of a rounded rectangle" - | f aaw topColor bottomColor l d c width dy | - topColor _ `Color white` * gradientTopFactor. - bottomColor _ `Color white` * gradientBottomFactor. - width _ r. - aaw _ 1.3. - f _ Form - extent: width @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: width - 1 - do: [ :x | - dy _ height - r - y. - dy > 0 - ifTrue: [ l _ 1.0 ] - ifFalse: [ - d _ (x @ dy) r. - l _ ((r - d max: 0.0) min: aaw) / aaw ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 3/10/2018 22:20:37' prior: 50358492! - bottomRightCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor borderWidth: bw - "Create and answer a Form for the bottomLeft corner of a rounded rectangle" - | f aaw topColor bottomColor l d c width dy l1 l2 | - topColor _ `Color white` * gradientTopFactor. - bottomColor _ `Color white` * gradientBottomFactor. - width _ r. - aaw _ 1.3. - f _ Form - extent: width @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: width - 1 - do: [ :x | - dy _ height - r - y. - dy > 0 - ifTrue: [ l _ 1.0 ] - ifFalse: [ - d _ (x @ dy) r. - l1 _ ((r - d-1+aaw max: 0.0) min: aaw) / aaw. - l2 _ ((d - r+bw+aaw max: 0.0) min: aaw) / aaw. - l _ l1 min: l2. - ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 3/10/2018 22:21:11' prior: 50358523! - topLeftCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - "Create and answer a Form with a vertical gray gradient as specified for the topLeft corner of a rounded rectangle" - | f bw topColor bottomColor l d c w | - topColor _ `Color white` * gradientTopFactor. - bottomColor _ `Color white` * gradientBottomFactor. - w _ r. - bw _ 1.3. - f _ Form - extent: w @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: w - 1 - do: [ :x | - l _ 1.0. - y < r ifTrue: [ - d _ (w - 1 - x @ (w - 1 - y)) r. - l _ ((r - d max: 0.0) min: bw) / bw ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 3/10/2018 22:21:32' prior: 50358550! - topRightCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - "Create and answer a Form with a vertical gray gradient as specified for the topRight corner of a rounded rectangle" - | f bw topColor bottomColor l d c w | - topColor _ `Color white` * gradientTopFactor. - bottomColor _ `Color white` * gradientBottomFactor. - w _ r. - bw _ 1.3. - f _ Form - extent: w @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: w - 1 - do: [ :x | - l _ 1.0. - y < r ifTrue: [ - d _ (x @ (w - y - 1)) r. - l _ ((r - d max: 0.0) min: bw) / bw ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!ColorForm methodsFor: 'accessing' stamp: 'jmv 3/10/2018 22:09:40' prior: 50358576! - colors: colorList - "Set my color palette to the given collection." - - | colorArray colorCount newColors | - colorList ifNil: [ - colors _ cachedDepth _ cachedColormap _ nil. - ^ self]. - - colorArray _ colorList asArray. - colorCount _ colorArray size. - newColors _ Array new: (1 bitShift: self depth). - 1 to: newColors size do: [:i | - i <= colorCount - ifTrue: [newColors at: i put: (colorArray at: i)] - ifFalse: [newColors at: i put: `Color transparent` ]]. - - colors _ newColors. - cachedDepth _ nil. - cachedColormap _ nil. -! ! -!ColorForm class methodsFor: 'as yet unclassified' stamp: 'jmv 3/12/2018 17:58:56' prior: 50383949! - mappingWhiteToTransparentFrom: aFormOrCursor - "Return a ColorForm copied from the given Form or Cursor with white mapped to transparent." - - | f map | - aFormOrCursor depth <= 8 ifFalse: [ - ^ self error: 'argument depth must be 8-bits per pixel or less']. - (aFormOrCursor is: #ColorForm) ifTrue: [ - f _ aFormOrCursor copy. - map _ aFormOrCursor colors. - ] ifFalse: [ - f _ ColorForm extent: aFormOrCursor extent depth: aFormOrCursor depth. - f copyBits: aFormOrCursor boundingBox - from: aFormOrCursor - at: `0@0` - clippingBox: aFormOrCursor boundingBox - rule: Form over. - map _ Color indexedColors copyFrom: 1 to: (1 bitShift: aFormOrCursor depth)]. - map _ map collect: [:c | - c = `Color white` ifTrue: [`Color transparent`] ifFalse: [c]]. - f colors: map. - ^ f! ! -!ColorForm class methodsFor: 'instance creation' stamp: 'jmv 3/10/2018 22:09:53' prior: 50358664! - grayScaleAndTransparentExtent: aPoint -"Native depth" - "Answer a ColorForm for storing 8bpp gray scale. (do not include any slot for transparent)" - - | grays result | - result _ self extent: aPoint depth: (Smalltalk isLittleEndian ifTrue: [ -8 ] ifFalse: [ 8 ]). - grays _ (0 to: 255) collect: [ :brightness | Color gray: brightness asFloat / 255.0]. - grays at: 1 put: `Color transparent`. - result colors: grays. - ^result! ! -!Cursor methodsFor: 'converting' stamp: 'jmv 3/10/2018 21:28:10' prior: 50358680! - asCursorForm - | form | - form _ Form extent: self extent depth: 8. - form fillShape: self fillColor: `Color black` at: offset negated. - ^ form offset: offset! ! -!CursorWithMask methodsFor: 'converting' stamp: 'jmv 3/10/2018 21:28:27' prior: 50358688! - asCursorForm - | form | - form _ Form extent: self extent depth: 8. - form fillShape: maskForm fillColor: `Color white`. - form fillShape: self fillColor: `Color black` at: offset negated. - ^ form offset: offset! ! -!BMPReadWriter methodsFor: 'reading' stamp: 'jmv 3/10/2018 22:17:39' prior: 50358714! - readColorMap - "Read colorCount BMP color map entries from the given binary stream. Answer an array of Colors." - | colorCount colors maxLevel b g r ccStream | - colorCount := (bfOffBits - 54) // 4. - "Note: some programs (e.g. Photoshop 4.0) apparently do not set colorCount; assume that any data between the end of the header and the start of the pixel data is the color map" - biBitCount >= 16 ifTrue:[^nil]. - colorCount = 0 ifTrue: [ "this BMP file does not have a color map" - "default monochrome color map" - biBitCount = 1 ifTrue: [^ `Array with: Color white with: Color black`]. - "default gray-scale color map" - maxLevel := (2 raisedTo: biBitCount) - 1. - ^ (0 to: maxLevel) collect: [:level | Color gray: (level asFloat / maxLevel)]]. - ccStream := ReadStream on: (stream next: colorCount*4). - colors := Array new: colorCount. - 1 to: colorCount do: [:i | - b := ccStream next. - g := ccStream next. - r := ccStream next. - ccStream next. "skip reserved" - colors at: i put: (Color r: r g: g b: b range: 255)]. - ^ colors -! ! -!BitBlt methodsFor: 'accessing' stamp: 'jmv 3/10/2018 21:25:25' prior: 50358749! - fillColor - "Return the current fill color as a Color. - Gives the wrong answer if the halftoneForm is a complex pattern of more than one word." - - halftoneForm ifNil: [^ `Color black` ]. - ^ Color colorFromPixelValue: halftoneForm first depth: destForm depth! ! -!GrafPort methodsFor: 'private' stamp: 'jmv 3/10/2018 22:12:11' prior: 50358997! - setRuleAndMapFor: sourceDepth foregroundColor: foregroundColor - - | targetColor destDepth | - destDepth _ destForm depth. - halftoneForm _ nil. "Don't use fillColor. Use a more powerful ColorMap" - - sourceDepth = 1 ifTrue: [ - self combinationRule: Form paint. - "Set up color map for a different source depth (color font)" - "Uses caching for reasonable efficiency" - colorMap _ self cachedFontColormapFrom1BitTo: destDepth. - colorMap at: 1 put: (destForm pixelValueFor: `Color transparent`). - colorMap at: 2 put: (destForm pixelValueFor: foregroundColor) ] - - ifFalse: [ - "Enable subpixel rendering if requested, but never for translucent text: - This technique always draws opaque text. This could be added, by using an extra colormap for the rgbMul phase... - So far, no need arised for doing so." - (sourceDepth > 8 and: [ - Preferences subPixelRenderFonts and: [ foregroundColor = `Color black` or: [ - Preferences subPixelRenderColorFonts and: [ foregroundColor isOpaque ]]]]) ifTrue: [ - destDepth > 8 ifTrue: [ - "rgbMul is equivalent to component alpha blend if text is black (only faster, hehe)" - self combinationRule: 37. "rgbMul" - colorMap _ (foregroundColor ~= `Color black` or: [ - destDepth = 32 and: [ destForm ~~ Display or: [Preferences properDisplayAlphaForFonts] ]]) ifTrue: [ - "rgbMul / rgbAdd IS component alpha blend for any color of text (neat trick, eh!!)" - "This colorMap is to be used on the second pass with rule 20 (rgbAdd) - See #displayString:from:to:at:strikeFont:color:" - "Note: In 32bpp, if we want the correct alpha in the result, we need the second pass, as the destination could have transparent pixels, - and we need to add to the alpha channel" - self colorConvertingMap: foregroundColor from: sourceDepth to: destDepth keepSubPixelAA: true]] - ifFalse: [ - self combinationRule: 25. "Paint" - targetColor _ foregroundColor = `Color black` ifFalse: [ foregroundColor ]. - colorMap _ self colorConvertingMap: targetColor from: sourceDepth to: destDepth keepSubPixelAA: true]] - ifFalse: [ - "Do not use rule 34 for 16bpp display. TTCFont uses it, but it builds a glyphs cache for each color used!!" - self combinationRule: (destDepth = 32 ifTrue: [34 "alphaBlendScaled"] ifFalse: [25 "Paint"]). - colorMap _ self colorConvertingMap: foregroundColor from: sourceDepth to: destDepth keepSubPixelAA: false]]! ! -!Rectangle methodsFor: 'transforming' stamp: 'jmv 3/10/2018 21:46:43' prior: 50359075! - newRectFrom: newRectBlock - "Track the outline of a new rectangle until mouse button changes. - newFrameBlock produces each new rectangle from the previous" - | rect newRect buttonStart buttonNow aHand delay | - delay _ Delay forMilliseconds: 10. - buttonStart _ buttonNow _ Sensor isAnyButtonPressed. - rect _ self. - Display border: rect width: 2 rule: Form reverse fillColor: `Color gray`. - [buttonNow == buttonStart] whileTrue: - [delay wait. - buttonNow _ Sensor isAnyButtonPressed. - newRect _ newRectBlock value: rect. - newRect = rect ifFalse: - [Display border: rect width: 2 rule: Form reverse fillColor: `Color gray`. - Display border: newRect width: 2 rule: Form reverse fillColor: `Color gray`. - rect _ newRect]]. - Display border: rect width: 2 rule: Form reverse fillColor: `Color gray`. - " pay the price for reading the sensor directly ; get this party started " - aHand _ self runningWorld activeHand. - aHand - newMouseFocus: nil; - flushEvents. - Sensor processSensorEvent: Sensor createMouseEvent discardingMouseEvents: false. - ^ rect! ! -!StrikeFont methodsFor: 'emphasis' stamp: 'jmv 3/10/2018 21:32:21' prior: 50359111! - makeBoldGlyphs - "Make a bold set of glyphs with same widths by ORing 1 bit to the right - (requires at least 1 pixel of intercharacter space)" - | g bonkForm | - g _ glyphs copy. - bonkForm _ (Form extent: 1@16) fillBlack offset: -1@0. - self bonk: g with: bonkForm. - glyphs depth = 1 ifTrue: [ - g copyBits: g boundingBox from: g at: (1@0) - clippingBox: g boundingBox rule: Form under ] - ifFalse: [ - 0 to: g width - 2 do: [ :x | 0 to: g height-1 do: [ :y | - (glyphs colorAt: x@y) = `Color white` ifFalse: [ - g colorAt: x+1@y put: - ((glyphs colorAt: x+1@y) = `Color white` - ifTrue: [glyphs colorAt: x@y] - ifFalse: [`Color black`])]]]]. - glyphs _ g. - self isSynthetic: true! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 3/10/2018 21:40:06' prior: 50359136! - makeControlCharsVisible - | glyph | - self characterToGlyphMap. - glyph _ self glyphAt: (Character space). - glyph border: glyph boundingBox width: 1 fillColor: `Color blue`. - self glyphAt: (Character numericValue: 134) put: glyph. - - "Keep tab(9), lf(10), cr(13) and space(32) transparent or whatever the user chose" - #(0 1 2 3 4 5 6 7 8 11 12 14 15 16 17 18 19 20 21 22 23 24 25 26 27) - do: [ :ascii | - characterToGlyphMap at: ascii + 1 put: 134 ]! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 3/10/2018 21:40:54' prior: 50371947! - makeCrVisible - | glyph | - glyph _ self glyphAt: (Character numericValue: 182). - glyph border: glyph boundingBox width: 1 fillColor: `Color blue`. -" glyph _ glyph reverse." - self glyphAt: Character cr put: glyph! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 3/10/2018 21:40:59' prior: 50371964! - makeLfVisible - | glyph | - glyph _ self glyphAt: (Character numericValue: 163). - glyph border: glyph boundingBox width: 1 fillColor: `Color blue`. -" glyph _ glyph reverse." - self glyphAt: Character lf put: glyph! ! -!Morph methodsFor: 'accessing' stamp: 'jmv 3/10/2018 21:38:27' prior: 50359177! - color - - ^ `Color blue`! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 3/10/2018 21:38:33' prior: 50359181! - drawOn: aCanvas - "A canvas is already set with a proper transformation from our coordinates to those of the Canvas target." - aCanvas - fillRectangle: self morphLocalBounds - color: `Color blue`! ! -!RectangleLikeMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 21:56:39' prior: 50359191! - defaultColor - ^ `Color orange`! ! -!BorderedRectMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 21:45:32' prior: 50359195! - defaultBorderColor - "answer the default border color/fill style for the receiver" - ^ `Color gray`! ! -!PasteUpMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 20:58:35' prior: 50359201! - defaultBorderColor - "answer the default border color/fill style for the receiver" - ^ `Color - r: 0.861 - g: 1.0 - b: 0.722`! ! -!PasteUpMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 20:58:44' prior: 50359208! - defaultColor - "answer the default color/fill style for the receiver" - ^ `Color - r: 0.8 - g: 1.0 - b: 0.6`! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 3/10/2018 22:02:53' prior: 50359215! - findWindow: evt - "Present a menu names of windows and naked morphs, and activate the one that gets chosen. Collapsed windows appear below line, expand if chosen; naked morphs appear below second line; if any of them has been given an explicit name, that is what's shown, else the class-name of the morph shows; if a naked morph is chosen, bring it to front and have it don a halo." - | menu expanded collapsed nakedMorphs | - menu _ MenuMorph new. - expanded _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed not ]. - collapsed _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed ]. - nakedMorphs _ self submorphsSatisfying: [ :m | - (m is: #SystemWindow) not ]. - expanded isEmpty & (collapsed isEmpty & nakedMorphs isEmpty) ifTrue: [ ^ Smalltalk beep ]. - (expanded asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #activateAndForceLabelToShow. - w canDiscardEdits ifFalse: [ menu lastItem color: `Color red` ]]. - expanded isEmpty | (collapsed isEmpty & nakedMorphs isEmpty) ifFalse: [ menu addLine ]. - (collapsed asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #expand. - w canDiscardEdits ifFalse: [ menu lastItem color: `Color red` ]]. - nakedMorphs isEmpty ifFalse: [ menu addLine ]. - (nakedMorphs asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #comeToFrontAndAddHalo ]. - menu addTitle: 'find window'. - menu popUpInWorld: self! ! -!EllipseMorph methodsFor: 'visual properties' stamp: 'jmv 3/10/2018 22:24:29' prior: 50359269! - defaultColor - "Return the default fill style for the receiver" - ^ `Color yellow`! ! -!PluggableMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 21:53:56' prior: 50359275! - defaultColor - "answer the default color/fill style for the receiver" - ^ `Color lightGray`! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 3/10/2018 21:23:14' prior: 50359322! - iconColor - - ^ self isPressed - ifTrue: [ `Color gray: 0.75` ] - ifFalse: [ - self mouseIsOver - ifTrue: [ `Color gray: 0.75` ] - ifFalse: [ `Color white` ]].! ! -!PluggableButtonMorph class methodsFor: 'example' stamp: 'jmv 3/12/2018 17:59:10' prior: 50384467! - example - " - PluggableButtonMorph example openInWorld - " - - | s1 s2 s3 b1 b2 b3 row | - s1 _ Switch new. - s2 _ Switch new turnOn. - s3 _ Switch new. - s2 onAction: [s3 turnOff]. - s3 onAction: [s2 turnOff]. - b1 _ (PluggableButtonMorph model: s1 stateGetter: #isOn action: #switch) label: 'S1'. - b2 _ (PluggableButtonMorph model: s2 stateGetter: #isOn action: #turnOn) label: 'S2'. - b3 _ (PluggableButtonMorph model: s3 stateGetter: #isOn action: #turnOn) label: 'S3'. - b1 color: `Color lightRed`. - b2 color: `Color lightRed`. - b3 color: `Color lightRed`. - row _ LayoutMorph newRow - addMorphs: (Array with: b1 with: b2 with: b3); - morphExtent: `120@35`. - ^ row! ! -!TextModelMorph methodsFor: 'drawing' stamp: 'jmv 3/10/2018 22:03:53' prior: 50359354! - drawOn: aCanvas - "Include a thin red inset border for unaccepted edits, or, if the unaccepted edits are known to conflict with a change made somewhere else to the same method (typically), put a thick red frame" - - - | bw bc | - - self flag: #todo. "Integrate this method with the Theme system. --cbr" - - - super drawOn: aCanvas. - bw _ Preferences focusIndicatorWidth. - bc _ nil. - self wantsFrameAdornments ifTrue: [ - model refusesToAccept - ifTrue: [ "Put up feedback showing that code cannot be submitted in this state" - bc _ `Color tan` ] - ifFalse: [ - self textMorph hasEditingConflicts - ifTrue: [ - bw _ 3. - bc _ `Color red` ] - ifFalse: [ - self textMorph hasUnacceptedEdits - ifTrue: [ - bc _ `Color red` ]]]]. - - (drawKeyboardFocusIndicator and: [ self textMorph hasKeyboardFocus ]) ifTrue: [ - bc ifNil: [ - bc _ Theme current focusIndicator ]] - ifFalse: [ - bc ifNotNil: [ - bc _ bc alphaMixed: 0.4 with: `Color white` ]]. - bc ifNotNil: [ - aCanvas frameRectangle: self focusIndicatorRectangle borderWidth: bw color: bc ]! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 3/10/2018 22:23:04' prior: 50359390! - defaultColor - "answer the default color/fill style for the receiver" - ^ `Color white`! ! -!SystemWindow methodsFor: 'menu' stamp: 'jmv 3/10/2018 21:32:46' prior: 50359396! - setWindowColor: incomingColor - | existingColor aColor | - incomingColor ifNil: [^ self]. "it happens" - aColor _ incomingColor asNontranslucentColor. - aColor = `Color black` ifTrue: [^ self]. - existingColor _ self widgetsColor. - existingColor ifNil: [^ Smalltalk beep]. - self widgetsColor: aColor. - self redrawNeeded! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'jmv 3/10/2018 22:08:36' prior: 50375589! - buildMorphicWindow - " - CodePackageListWindow open: CodePackageList new - " - | dirtyFlags names fileNames upperRow description summary backColor labelBackground | - backColor := self textBackgroundColor. - labelBackground := Theme current background. - - dirtyFlags := PluggableListMorph - model: model - listGetter: #packageDirtyFlags - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - dirtyFlags color: backColor. - dirtyFlags := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: ' Unsaved?'); - addMorphUseAll: dirtyFlags. - - names := PluggableListMorph - model: model - listGetter: #packageNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - names color: backColor. - names := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: ' Package Name'); - addMorphUseAll: names. - - fileNames := PluggableListMorph - model: model - listGetter: #packageFullNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - fileNames color: backColor. - fileNames := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: ' File Name'); - addMorphUseAll: fileNames. - - upperRow := LayoutMorph newRow. - upperRow - addMorph: dirtyFlags proportionalWidth: 0.13; - addAdjusterAndMorph: names proportionalWidth: 0.27; - addAdjusterAndMorph: fileNames proportionalWidth: 0.6. - - description := TextModelMorph - textProvider: model - textGetter: #description - textSetter: #description:. - - summary := TextModelMorph - textProvider: model - textGetter: #summary. - - self layoutMorph - addMorph: upperRow proportionalHeight: 0.6; - addAdjusterAndMorph: self buildButtonPane fixedHeight: Theme current buttonPaneHeight; - addAdjusterAndMorph: summary fixedHeight: 60; - addAdjusterAndMorph: description proportionalHeight: 0.25; - addAdjusterAndMorph: self buildRequirementsPane proportionalHeight: 0.15. - self setLabel: 'Installed Packages'! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'jmv 3/10/2018 22:09:02' prior: 50359485! - buildRequirementsPane - - | requirements deleteReqButton "editReqButton" reqLayout buttonLayout | - requirements := PluggableListMorph - model: (PackageRequirementsList fromCodePackageList: model) - listGetter: #requirementsStrings - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - requirements color: Theme current textPane. - - deleteReqButton := PluggableButtonMorph - model: requirements model - action: #deleteSelectedRequirement - label: 'delete'. - deleteReqButton color: self widgetsColor. - - buttonLayout := LayoutMorph newColumn. - buttonLayout addMorph: deleteReqButton - layoutSpec: (LayoutSpec - proportionalWidth: 1.0 - proportionalHeight: 1.0 - minorDirectionPadding: #top); - color: self widgetsColor quiteWhiter. - - model when: #changed: send: #updateRequirementsFromPackageList to: requirements model. - self when: #changed: send: #updateRequirementsFromPackageList to: requirements model. - requirements model when: #changed: send: #verifyContents to: requirements. - self when: #changed: send: #verifyContents to: requirements. - - reqLayout := LayoutMorph newRow. - ^ reqLayout - doAdoptWidgetsColor; - addMorph: requirements - layoutSpec: (LayoutSpec - proportionalWidth: 0.9 - proportionalHeight: 1.0 - minorDirectionPadding: #left); - addMorph: buttonLayout - layoutSpec: (LayoutSpec - proportionalWidth: 0.1 - proportionalHeight: 1.0 - minorDirectionPadding: #right); - color: `Color transparent`; - yourself - ! ! -!CodeWindow methodsFor: 'updating' stamp: 'jmv 3/10/2018 20:51:37' prior: 50359536! - decorateForInheritance - "Check to see if the currently-viewed method has a super send or an override, and if so, change screen feedback, unless the #decorateBrowserButtons says not to." - - | cm aColor aButton flags buttonColor | - (aButton _ self inheritanceButton) ifNil: [^ self]. - buttonColor _ self buttonColor. - - Preferences decorateBrowserButtons - ifFalse: [ ^aButton color: buttonColor ]. - cm _ model currentCompiledMethod. - (cm is: #CompiledMethod) - ifFalse: [ ^aButton color: buttonColor ]. - - flags _ 0. - model isThisAnOverride ifTrue: [ flags _ flags bitOr: 4 ]. - cm sendsToSuper ifTrue: [ flags _ flags bitOr: 2 ]. - model isThereAnOverride ifTrue: [ flags _ flags bitOr: 1 ]. - aColor _ { - - "This is NOTan override. There is no super implementation." - buttonColor. "no sends to super. there is not override in any subclass" - `Color tan`. "no sends to super. there is an override in some subclass" - `Color red`. "sends to super. there is no override in any subclass. Error: no super to call (or calls super with a different message)" - `Color red`. "sends to super. there is an override in some subclass. Error: no super to call (or calls super with a different message)" - - "This is an override. There is some super implementation" - `Color red muchLighter`. "doesn't have sub; has super but doesn't call it" - `Color r: 0.94 g: 0.823 b: 0.673`. "has sub; has super but doesn't call it" - `Color green muchLighter`. "doesn't have sub; has super and callsl it" - `Color blue muchLighter`. "has sub; has super and callsl it" - - } at: flags + 1. - aButton color: aColor! ! -!ChangeSorterWindow methodsFor: 'GUI building' stamp: 'jmv 3/10/2018 22:07:53' prior: 50359589! - buildMorphicWindow - "Add a set of change sorter views to the given top view offset by the given amount. To create a single change sorter, call this once with an offset of 0@0. To create a dual change sorter, call it twice with offsets of 0@0 and 0.5@0." - - | dirtyFlags changeSetList classList messageList upperPanes backColor labelBackground | - backColor _ self textBackgroundColor. - labelBackground _ Theme current background. - model myChangeSet ifNil: [ - self flag: #ojo. "Or whatever was last changed, or is top of list, or whatever" - model myChangeSet: ChangeSet changeSetForBaseSystem ]. - - dirtyFlags _ PluggableListMorph - model: model - listGetter: #changeSetDirtyFlags - indexGetter: nil - indexSetter: nil. - dirtyFlags color: backColor. - dirtyFlags _ LayoutMorph newColumn - color: Theme current background; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: ' Unsaved?'); - addMorphUseAll: dirtyFlags. - - changeSetList _ (PluggableListMorphByItem - model: model - listGetter: #changeSetList - indexGetter: #currentCngSet - indexSetter: #showChangeSetNamed: - mainView: self - menuGetter: #changeSetMenu - keystrokeAction: #changeSetListKey:from:) - autoDeselect: false. - changeSetList color: backColor. - changeSetList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: 'Change Set name'); - addMorphUseAll: changeSetList. - - classList _ PluggableListMorphByItem - model: model - listGetter: #classList - indexGetter: #currentClassName - indexSetter: #currentClassName: - mainView: self - menuGetter: #classListMenu - keystrokeAction: #classListKey:from:. - classList color: backColor. - classList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: 'Classes'); - addMorphUseAll: classList. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: dirtyFlags proportionalWidth: 0.13; - addAdjusterAndMorph: changeSetList proportionalWidth: 0.47; - addAdjusterAndMorph: classList proportionalWidth: 0.4. - - messageList _ PluggableListMorphByItem - model: model - listGetter: #messageList - indexGetter: #currentSelector - indexSetter: #currentSelector: - mainView: self - menuGetter: #messageMenu - keystrokeAction: #messageListKey:from:. - messageList color: backColor. - messageList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: 'Methods'); - addMorphUseAll: messageList. - - self layoutMorph - addMorph: upperPanes proportionalHeight: 0.25; - addAdjusterAndMorph: messageList proportionalHeight: 0.2; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.55. - - self setLabel: model labelString! ! -!PreDebugWindow methodsFor: 'GUI building' stamp: 'jmv 3/10/2018 22:13:32' prior: 50359687! -buttonRowForPreDebugWindow: aDebugger - | row aButton triads buttons | - buttons _ OrderedCollection new. - triads _ OrderedCollection withAll: self preDebugButtonSpec. - aDebugger shouldBeAbleToCreateMethod ifTrue: [ triads add: { 'Create'. #createMethod. 'create the missing method' }]. - - triads do: [ :triad | - aButton _ PluggableButtonMorph new model: self. - aButton label: triad first. - aButton action: triad second. - aButton setBalloonText: triad third. - buttons add: aButton]. - - row _ LayoutMorph newRow. - row doAdoptWidgetsColor. - row color: `Color transparent`. - row separation: 1. - row addMorphs: buttons. - ^row! ! -!TestRunnerWindow methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:52:20' prior: 50359710! - runButtonColor - ^ `Color green lighter duller`! ! -!ProgressBarMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 22:22:59' prior: 50359715! - defaultColor - ^ `Color white`! ! -!ProgressBarMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 21:46:24' prior: 50359719! - initialize - super initialize. - progressColor _ `Color gray`. - value _ 0.0! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 3/10/2018 22:13:23' prior: 50359724! - addStayUpIcons - | closeBox pinBox w | - Preferences optionalButtons ifFalse: [ ^self ]. - (self valueOfProperty: #hasStayUpIcons ifAbsent: [ false ]) - ifTrue: [ - self removeProperty: #needsStayUpIcons. - ^self ]. - titleMorph ifNil: [ - "Title not yet there. Flag ourself, so this method is called again when adding title." - self setProperty: #needsStayUpIcons toValue: true. - ^ self]. - closeBox _ PluggableButtonMorph model: self action: #delete. - closeBox icon: Theme current closeIcon; color: `Color transparent`. - pinBox _ PluggableButtonMorph model: self action: #stayUp. - pinBox icon: Theme current pushPinIcon; color: `Color transparent`. - w _ (titleMorph hasSubmorphs ifTrue: [ titleMorph firstSubmorph morphWidth ] ifFalse: [ 0 ]) + 60. - self addMorphFront: - (LayoutMorph newRow - "Make room for buttons" - morphExtent: w @ (titleMorph morphHeight max: 19); - color: `Color transparent`; - addMorph: closeBox fixedWidth: 20; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedWidth: 4; - addMorph: titleMorph proportionalWidth: 1; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedWidth: 4; - addMorph: pinBox fixedWidth: 20). - - self setProperty: #hasStayUpIcons toValue: true. - self removeProperty: #needsStayUpIcons! ! -!MenuMorph methodsFor: 'keyboard control' stamp: 'jmv 3/12/2018 17:59:17' prior: 50384969! - displayFiltered: evt - | matchStr allItems isMatch matches feedbackMorph | - matchStr _ self valueOfProperty: #matchString. - allItems _ self submorphs select: [ :m | - m is: #MenuItemMorph ]. - matches _ allItems select: [ :m | - isMatch _ matchStr isEmpty or: [ - m contents - includesSubstring: matchStr - caseSensitive: false ]. - m isEnabled: isMatch. - isMatch ]. - feedbackMorph _ self valueOfProperty: #feedbackMorph. - feedbackMorph ifNil: [ - feedbackMorph _ StringMorph new color: `Color veryDarkGray`. - self addMorphBack: feedbackMorph lock position: `0@ -20`. - self - setProperty: #feedbackMorph - toValue: feedbackMorph ]. - feedbackMorph contents: '<' , matchStr , '>'. - matchStr isEmpty ifTrue: [ - feedbackMorph delete. - self removeProperty: #feedbackMorph ]. - matches notEmpty ifTrue: [ - self selectItem: matches first ]! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 17:59:29' prior: 50385049! - drawOn: aCanvas - | rectangle w y0 h y1 y2 scrollbarThickness | - aCanvas frameAndFillRectangle: (`0@0` extent: extent) fillColor: self color borderWidth: borderWidth borderColor: borderColor. - y0 _ 1. - w _ extent x-2. - scrollbarThickness _ ScrollBar scrollbarThickness. - completer entryCount > self class itemsPerPage ifTrue: [ - w _ w - scrollbarThickness. - aCanvas - frameRectangle: (extent x - scrollbarThickness@0 - extent: scrollbarThickness @ extent y) - borderWidth: 1 - color: borderColor. - aCanvas - image: (BitBltCanvas arrowOfDirection: #up size: scrollbarThickness) - at: self upButtonPosition. - aCanvas - image: (BitBltCanvas arrowOfDirection: #down size: scrollbarThickness) - at: self downButtonPosition. - h _ extent y - (2 * scrollbarThickness). - y1 _ (1.0 * self firstVisible-1 / completer entryCount * h) ceiling + y0 + scrollbarThickness-1. - y2 _ (1.0 * self lastVisible / completer entryCount * h) floor + y0 + scrollbarThickness -1. - aCanvas - fillRectangle: (extent x - scrollbarThickness+2@y1 corner: extent x-2 @ y2) - color: `Color veryLightGray` ]. - self firstVisible - to: self lastVisible - do: [ :index | - rectangle _ 1@y0 extent: w@self class itemHeight. - index = self selected - ifTrue: [ - aCanvas fillRectangle: rectangle color: (Theme current listHighlightFocused: true) ]. - aCanvas - drawString: (completer entries at: index) asString - at: rectangle topLeft - font: self class listFont - color: Theme current text. - y0 _ y0 + self itemHeight ]! ! -!AutoCompleterMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 21:45:20' prior: 50359848! - defaultBorderColor - ^ `Color gray`! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 17:59:34' prior: 50385113! - drawOn: aCanvas - "Draw the hand itself (i.e., the cursor)." - "This method is only called when we are carrying morphs around..." - aCanvas - stencil: Cursor move - at: `0@0` - color: `Color black`! ! -!ImageMorph methodsFor: 'accessing' stamp: 'jmv 3/10/2018 22:12:19' prior: 50359861! - color: aColor - super color: aColor. - (image depth = 1 and: [aColor is: #Color]) ifTrue: [ - image colors: {`Color transparent`. aColor}. - self redrawNeeded]! ! -!MenuItemMorph methodsFor: 'accessing' stamp: 'jmv 3/10/2018 21:30:52' prior: 50359870! - isEnabled: aBoolean - - isEnabled = aBoolean ifTrue: [^ self]. - isEnabled _ aBoolean. - self color: (aBoolean ifTrue: [`Color black`] ifFalse: [`Color gray`]). -! ! -!MenuItemMorph methodsFor: 'private' stamp: 'jmv 3/10/2018 21:22:24' prior: 50359878! - offImage - "Return the form to be used for indicating an '' marker" - | form | - form _ Form extent: (self fontToUse ascent-2) asPoint depth: 16. - form getCanvas - frameAndFillRectangle: form boundingBox fillColor: `(Color gray: 0.9)` - borderWidth: 1 borderColor: `Color black`. - ^form! ! -!MenuItemMorph methodsFor: 'private' stamp: 'jmv 3/10/2018 21:22:55' prior: 50359890! - onImage - "Return the form to be used for indicating an '' marker" - | form | - form _ Form extent: (self fontToUse ascent-2) asPoint depth: 16. - form getCanvas - frameAndFillRectangle: form boundingBox fillColor: `Color gray: 0.8` - borderWidth: 1 borderColor: `Color black`; - fillRectangle: (form boundingBox insetBy: 2) color: `Color black`. - ^form! ! -!LayoutMorph methodsFor: 'accessing' stamp: 'jmv 3/10/2018 22:12:27' prior: 50359904! - adoptWidgetsColor: paneColor - super adoptWidgetsColor: paneColor. - doAdoptWidgetsColor - ifTrue: [ self color: (Theme current buttonColorFrom: paneColor) ] - ifFalse: [ self color: `Color transparent` ]! ! -!LayoutMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 21:46:16' prior: 50359914! - defaultColor - ^ `Color gray`! ! -!LayoutMorph class methodsFor: 'instance creation' stamp: 'jmv 3/10/2018 22:01:15' prior: 50359918! - initializedInstance - "Answer a row by default so the 'new morph' menu doesn't fail..." - ^self newRow color: `(Color red alpha: 0.2)`! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 3/10/2018 22:01:26' prior: 50360389! - launcherExample - " - self launcherExample - " - | b1 b2 b3 row b4 random buttons | - random _ Random new. - b1 _ PluggableButtonMorph model: [ Date today print ] action: #value label: 'Date'. - b2 _ PluggableButtonMorph model: [ Time now print ] action: #value label: 'Time'. - b3 _ PluggableButtonMorph model: [ SystemVersion current print ] action: #value label: 'Version'. - b4 _ PluggableButtonMorph model: [ random next print ] action: #value label: 'Random'. - buttons _ {b1. b2. b3. b4}. - buttons do: [ :button | - button color: `Color lightRed` ]. - row _ LayoutMorph newRow - color: `Color red`; - addMorphs: buttons; - morphExtent: 300 @ 40. - ^ row openInWorld! ! -!ProgressMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 22:16:44' prior: 50360413! - defaultColor - ^ `Color veryLightGray`! ! -!HaloHandleMorph class methodsFor: 'accessing' stamp: 'jmv 3/10/2018 22:21:42' prior: 50360418! - circleForm: extent - " - CircleForm _ nil - " - | r d l bw center | - (CircleForm isNil or: [ CircleForm extent ~= extent ]) ifTrue: [ - center _ extent -1 * 0.5. - r _ center r * 0.75. - bw _ 1.3. - CircleForm _ Form extent: extent depth: 32. - 0 to: extent y - 1 do: [ :y | - 0 to: extent x - 1 do: [ :x | - d _ (x@y - center) r. - l _ (r - d max: 0.0) min: bw. - CircleForm - colorAt: x @ y - put: (`Color white` alpha: (l / bw)) - ]]. - ]. - ^CircleForm! ! -!HaloMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 20:58:21' prior: 50360436! - defaultColor - "answer the default color/fill style for the receiver" - ^ `Color - r: 0.6 - g: 0.8 - b: 1.0`! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 3/10/2018 21:30:16' prior: 50360476! -addNameString: aString - "Add a name display centered beneath the bottom of the outer rectangle. Return the handle." - - | nameMorph namePosition nameBackground | - nameBackground _ RectangleLikeMorph new - color: ((target is: #SystemWindow) ifTrue: [target windowColor] ifFalse: [`Color lightBlue alpha: 0.9`]). - nameMorph _ StringMorph contents: aString. - nameMorph color: `Color black`. - nameBackground morphExtent: nameMorph morphExtent + 4. - namePosition _ haloBox width - nameMorph morphWidth // 2 @ (haloBox height). - self addMorph: nameBackground position: namePosition - 2. - self addMorph: nameMorph position: namePosition. - ^nameMorph! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 3/10/2018 21:38:00' prior: 50360499! - doRot: evt with: rotHandle - "Update the rotation of my target if it is rotatable. Keep the relevant command object up to date." - - | degrees | -self revisar. - self flag: #jmvVer2. - evt hand obtainHalo: self. - degrees _ (evt eventPosition - target referencePosition) degrees. - degrees _ degrees - angleOffset degrees. - degrees _ degrees detentBy: 10.0 atMultiplesOf: 90.0 snap: false. - degrees = 0.0 - ifTrue: [rotHandle color: `Color lightBlue`] - ifFalse: [rotHandle color: `Color blue`]. - rotHandle submorphsDo: - [:m | m color: rotHandle color makeForegroundColor]. - self removeAllHandlesBut: rotHandle. - - target rotationDegrees: degrees. - - rotHandle morphPositionInWorld: evt eventPosition - (rotHandle morphExtent // 2)! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 3/10/2018 21:53:51' prior: 50360525! - setDismissColor: evt with: dismissHandle - "Called on mouseStillDown in the dismiss handle; set the color appropriately." - - | colorToUse | - evt hand obtainHalo: self. - colorToUse _ (dismissHandle morphContainsPoint: (dismissHandle internalizeFromWorld: evt eventPosition)) - ifFalse: [ `Color red muchLighter` ] - ifTrue: [ `Color lightGray` ]. - dismissHandle color: colorToUse! ! -!InnerListMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 21:30:39' prior: 50361244! - initialize - super initialize. - self color: `Color black`. - font _ Preferences standardListFont. - listItems _ #(). - selectedRow _ nil. - highlightedRow _ nil! ! -!InnerTextMorph methodsFor: 'drawing' stamp: 'jmv 3/10/2018 21:44:18' prior: 50360549! - debugDrawLineRectsOn: aCanvas - "Shows where text line rectangles are" - - self textComposition lines do: [ :line | - aCanvas - frameRectangle: line rectangle - borderWidth: 1 - color: `Color brown` ] -! ! -!ResizeMorph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 17:59:45' prior: 50385710! - initialize - super initialize. - extent _ `400@300`. - color _ `Color white`. - grid _ `8@6`. - gridLineWidth _ 2. - gridColor _ `Color black`. - selectionColor _ `Color red`! ! -!ResizeMorph methodsFor: 'events' stamp: 'jmv 3/10/2018 21:31:55' prior: 50360567! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - from _ self toGridPoint: localEventPosition. - outlineMorph _ BorderedRectMorph new - borderColor: `Color black`; - color: `Color transparent`; - openInWorld; - hide. - self selectTo: localEventPosition! ! -!HoverHelpMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 20:58:28' prior: 50360579! - defaultColor - - ^ `Color r: 1.0 g: 1.0 b: 0.7`! ! -!HoverHelpMorph methodsFor: 'drawing' stamp: 'jmv 3/10/2018 21:30:31' prior: 50360584! - drawOn: aCanvas - - | r | - r _ self morphLocalBounds. - aCanvas roundRect: r color: self color radius: 4. - aCanvas - textComposition: textComposition - bounds: (r insetBy: 4) - color: `Color black` - selectionColor: (Theme current textHighlightFocused: false)! ! -!WorldState class methodsFor: 'sample code' stamp: 'jmv 3/10/2018 21:48:37' prior: 50360721! - experiment1 - "To play with and learn about morphic Display update logic. - Remove the morphs when done!!" - " - WorldState experiment1 - " - | dr morph1 morph2 s w | - morph1 _ RectangleLikeMorph new openInWorld. - morph2 _ RectangleLikeMorph new openInWorld. - morph2 color: `Color green`. - morph2 morphPosition: 200@800 extent: 50@40. - morph1 morphPosition: 120@720 extent: 220@100. - - w _ self runningWorld. - s _ w instVarNamed: 'worldState'. - dr _ s instVarNamed: 'damageRecorder'. - - dr doFullRepaint. - dr reset; - " recordInvalidRect: (100@700 corner: 400@900);" - recordInvalidRect: (100@700 corner: 150@900); - recordInvalidRect: (300@700 corner: 400@900). - Display fillColor: `Color gray`. - "Do not draw the area used by the small rectangle, unless it is also drawn!!" - s drawInvalidAreasSubmorphs: {morph1. morph2 }! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 3/12/2018 17:59:57' prior: 50385882! - drawCurrentAsError - "The morph (or one of its submorphs) had an error in its drawing method." - | r w | - r _ currentMorph morphLocalBounds. - w _ r extent > `50@50` - ifTrue: [ 6 ] - ifFalse: [ 2 ]. - self - frameAndFillRectangle: r - fillColor: `Color red` - borderWidth: w - borderColor: `Color yellow`. - self line: r topLeft to: r bottomRight-w width: w color: `Color yellow`. - self line: r topRight -(w@0) to: r bottomLeft -(0@w)width: w color: `Color yellow`! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/12/2018 18:00:11' prior: 50385900! - drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - aColor = `Color black` ifFalse: [ | topColor | - topColor _ aColor alphaMixed: 0.25 with: `Color black`. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint - font: fontOrNil - color: topColor ]. - aColor = `Color white` ifFalse: [ | bottomColor | - bottomColor _ aColor alphaMixed: 0.22 with: `Color white`. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + `0@2` - font: fontOrNil - color: bottomColor ]. - ^self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + `0@1` - font: fontOrNil - color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 3/10/2018 22:06:13' prior: 50360794! - fillRectangle: aRectangle color: aColor - "Fill the given rectangle." - - aColor isTransparent ifFalse: [ - self - frameAndFillRectangle: aRectangle - fillColor: aColor - borderWidth: 0 - borderColor: `Color transparent` ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 3/10/2018 21:45:27' prior: 50360804! - reverseRectangleBorder: r borderWidth: borderWidth - " - Display getCanvas - reverseRectangleBorder: (10@10 extent: 300@200) - borderWidth: 20. - Display forceToScreen - " - | rect | - rect _ currentTransformation displayBoundsOfTransformOf: r. - port - sourceForm: nil; - fillColor: `Color gray`; - combinationRule: Form reverse; - frameRect: rect borderWidth: borderWidth! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 3/10/2018 22:06:54' prior: 50360819! - setPaintColor: aColor - "Install a new color used for filling." - | paintColor | - paintColor _ aColor ifNil: [ `Color transparent` ]. - (paintColor is: #Color) ifFalse: [ - ^ self error: 'Cannot install color' ]. - - "Okay, so paintColor really *is* a color" - port sourceForm: nil. - (paintColor isOpaque or: [ self depth < 32]) ifTrue: [ - port fillColor: paintColor. - port combinationRule: Form paint. - ^ self ]. - - "BitBlt setup for alpha mapped transfer" - port fillColor: paintColor. - port combinationRule: Form blend! ! -!BitBltCanvas class methodsFor: 'cached forms' stamp: 'jmv 3/12/2018 18:00:43' prior: 50386015! - steButtonForm: extent - ^self cachedForms - at: { #steButton . extent } - ifAbsentPut: [ - | form canvas | - form _ Form extent: extent depth: 32. - canvas _ form getCanvas. - canvas - roundRect: (`0@0` extent: extent) - color: `Color gray: 0.4` - radius: 4. - canvas - roundRect: (`1@1` extent: extent-2) - color: `Color white` - radius: 4 - gradientTop: 1.0 - gradientCenter: 0.73 - gradientBottom: 0.94 - gradient1Height: (extent y-8+1 max: extent y//2). - form]! ! -!BitBltCanvas class methodsFor: 'cached arrow forms' stamp: 'jmv 3/10/2018 21:21:27' prior: 50360872! - buildArrowOfDirection: aSymbolDirection size: finalSizeInteger - "PRIVATE - create an arrow with aSymbolDirectionDirection, - finalSizeInteger and aColor - - aSymbolDirectionDirection = #up, #down. #left or #right - (self buildArrowOfDirection: #down size: 120) display - (self buildArrowOfDirection: #up size: 120) display - " - - | resizeFactor resizedForm f e c bottomMargin topMargin | - resizeFactor _ 4. - e _ finalSizeInteger@finalSizeInteger*resizeFactor. - f _ Form extent: e depth: 32. - c _ `Color gray: 0.5`. - topMargin _ finalSizeInteger * 3//4. - bottomMargin _ finalSizeInteger * 4//4. - 0 to: e y-1-bottomMargin do: [ :y | - 0 to: e x -1 do: [ :x | - (e x / 2 - 1 - x) abs * 2 + topMargin < y ifTrue: [ - f colorAt: x@y put: c - ] - ] - ]. - resizedForm _ f - magnify: f boundingBox - by: 1 / resizeFactor - smoothing: 4. - - aSymbolDirection == #right ifTrue: [ - resizedForm _ resizedForm rotatedByDegrees: 90 ]. - aSymbolDirection == #down ifTrue: [ - resizedForm _ resizedForm rotatedByDegrees: 180 ]. - aSymbolDirection == #left ifTrue: [ - resizedForm _ resizedForm rotatedByDegrees: 270 ]. - - aSymbolDirection == #up ifFalse: [ - resizedForm _ resizedForm - copy: (resizedForm boundingBox insetBy: (resizedForm width - finalSizeInteger/ 2.0) rounded) ]. - - ^resizedForm! ! -!BitBltCanvas class methodsFor: 'cached arrow forms' stamp: 'jmv 3/12/2018 18:01:37' prior: 50386034! - buildArrowWith: insideForm borderForm: borderForm - | extent translucentForm color insideSpec borderSpec border background alpha| - " - Display getCanvas - image: (BitBltCanvas buildArrowWith: BitBltCanvas downInsideForm borderForm: BitBltCanvas downBorderForm) - at: 20@20 - Display getCanvas - image: (BitBltCanvas buildArrowWith:BitBltCanvas upInsideForm borderForm: BitBltCanvas upBorderForm) - at: 40@20 - " - extent _ insideForm extent - `1@2`. - translucentForm _ Form extent: insideForm extent depth: 32. - 0 to: extent x-1 do: [ :x | - 0 to: extent y-1 do: [ :y | - insideSpec _ insideForm colorAt: x@(y+1). - borderSpec _ borderForm colorAt: x@(y+1). - insideSpec = `Color r: 0.0 g: 0.0 b: 1.0` - ifTrue: [ color _ `Color transparent` ] - ifFalse: [ - borderSpec = `Color r: 1.0 g: 0.0 b: 0.0` - ifTrue: [ color _ insideSpec ] - ifFalse: [ - border _ x < (extent x//2) - ifTrue: [`Color white`] - ifFalse: [`Color black`]. - background _ borderForm colorAt: extent x@(y+1). - alpha _ borderSpec red asFloat - background red / (border red - background red). - color _ border alpha: (alpha min: 1 max: 0) ]]. - translucentForm colorAt: x@y put: color ]]. - ^translucentForm! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/10/2018 20:59:15' prior: 50360957! - background - ^ `Color r: 0.7 g: 0.72 b: 0.83`! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/10/2018 22:13:58' prior: 50360961! - buttonColorFrom: aColor - ^ Display depth <= 8 - ifTrue: [ `Color transparent` ] - ifFalse: [ aColor paler ]! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/10/2018 21:23:25' prior: 50360967! - buttonLabel - ^ `Color gray: 0.18`! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/10/2018 22:03:59' prior: 50360971! - errorColor - ^ `Color red lighter`! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/10/2018 22:24:39' prior: 50360975! - failureColor - ^ `Color yellow lighter`! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/10/2018 21:23:34' prior: 50360979! - scrollbarButtonColor - ^ `Color gray: 0.95`! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/10/2018 22:23:27' prior: 50360983! - scrollbarColor - ^ `Color white`! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/10/2018 22:23:32' prior: 50360987! - scrollbarSliderShadowColor - ^ `Color white`! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/10/2018 21:52:43' prior: 50360991! - successColor - ^ `Color green lighter`! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/10/2018 21:34:04' prior: 50360995! - text - ^ `Color black`! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/10/2018 21:34:14' prior: 50360999! - textCursor - ^ Display depth <= 2 - ifTrue: [ `Color black` ] - ifFalse: [ self text ]! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/10/2018 21:19:22' prior: 50361005! - textHighlight - "A nice light blue." - " - ^ Color r: 0.71 g: 0.835 b: 1.0 - ^ Color hue: 214 chroma: 0.29 luminance: 0.816 - " - ^ `Color hue: 204 chroma: 0.29 luminance: 0.77`! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/10/2018 21:24:07' prior: 50361013! - textHighlightFocused: focused - "A nice light blue." - | textHighlight | - Display depth = 1 ifTrue: [^ `Color veryLightGray` ]. - Display depth = 2 ifTrue: [^ `Color gray: 0.87` ]. - textHighlight _ self textHighlight. - ^focused - ifTrue: [ textHighlight ] - ifFalse: [ self unfocusedTextHighlightFrom: textHighlight ]! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/10/2018 21:24:18' prior: 50361026! - windowLabel - ^ `Color gray: 0.3`! ! -!Theme methodsFor: 'menu colors' stamp: 'jmv 3/10/2018 20:42:33' prior: 50361030! - menu - Display depth <= 2 ifTrue: [^ `Color white` ]. - ^ `Color r: 0.75 g: 0.75 b: 0.75 alpha: 0.93`! ! -!Theme methodsFor: 'menu colors' stamp: 'jmv 3/10/2018 22:16:53' prior: 50361036! - menuHighlight - ^ Display depth < 8 - ifTrue: [ `Color veryLightGray` ] - ifFalse: [ self textHighlight ]! ! -!Theme methodsFor: 'menu colors' stamp: 'jmv 3/10/2018 21:33:40' prior: 50361042! - menuText - ^ `Color black`! ! -!Theme methodsFor: 'menu colors' stamp: 'jmv 3/10/2018 21:47:13' prior: 50361046! - menuTitleBar - Display depth = 1 ifTrue: [^ `Color white`]. - Display depth = 2 ifTrue: [^ `Color gray`]. - ^ self menu darker! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/10/2018 20:59:31' prior: 50361053! - browser - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ `Color r: 0.5 g: 0.7 b: 0.4`]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/10/2018 21:20:34' prior: 50361060! - debugger - ^ `Color h: 0.0 s: 0.6 v: 0.7`! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/10/2018 20:59:08' prior: 50361064! - defaultWindowColor - ^ `Color lightGray`! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/10/2018 22:05:56' prior: 50361068! - fileContentsBrowser - ^ `Color tan duller`! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/10/2018 20:59:58' prior: 50361072! - fileList - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ `Color r: 0.7 g: 0.55 b: 0.7` ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/10/2018 21:00:04' prior: 50361079! - messageNames - - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ `Color r: 0.53 g: 0.77 b: 0.382` ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/10/2018 21:00:12' prior: 50361086! - messageSet - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ `Color r: 0.45 g: 0.6 b: 0.85` ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/10/2018 22:23:19' prior: 50361093! - object - ^ `Color white duller`! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/10/2018 21:00:19' prior: 50361097! - packageList - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ `Color r: 0.63 g: 0.47 b: 0.08` ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/10/2018 21:00:28' prior: 50361104! - testRunner - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ `(Color r: 0.650 g: 0.753 b: 0.976) duller` ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/10/2018 21:23:40' prior: 50361111! - textEditor - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ `Color gray: 0.6` ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/10/2018 21:01:02' prior: 50361117! -transcript - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ `Color r: 0.8 g: 0.6 b: 0.3` ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/10/2018 21:01:08' prior: 50361124! - versionsBrowser - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ `(Color r: 0.869 g: 0.753 b: 1.0) duller` ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/10/2018 21:20:41' prior: 50361131! - workspace - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ `Color h: 60.0 s: 0.73 v: 0.72` ]! ! -!Theme methodsFor: 'widget colors' stamp: 'jmv 3/10/2018 20:59:00' prior: 50361138! - acceptButton - - ^ self buttonColorFrom: - (self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ `Color r: 0.2 g: 0.6 b: 0.1` ])! ! -!Theme methodsFor: 'widget colors' stamp: 'jmv 3/10/2018 20:59:50' prior: 50361146! - cancelButton - - ^ self buttonColorFrom: - (self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ `Color r: 0.8 g: 0.2 b: 0.2` ])! ! -!Theme methodsFor: 'widget colors' stamp: 'jmv 3/10/2018 22:23:38' prior: 50361154! - textPane - ^ `Color white`! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3273-UseALotOfLiteralColors-JuanVuletich-2018Mar12-17h49m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3272] on 12 March 2018 at 6:05:59 pm'! -!ChangeListElement methodsFor: 'testing' stamp: 'jmv 3/12/2018 18:05:54'! - isDoIt - - ^false! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3274-ChangeListElement-isDoit-JuanVuletich-2018Mar12-18h02m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3274] on 12 March 2018 at 7:21:38 pm'! -!Color methodsFor: 'other' stamp: 'jmv 3/12/2018 19:20:35' prior: 50356772! - colorName - "Return this color's name, or nil if it has no name. Only returns a name if it exactly matches the named color. - Return nil if named color support is not present" - - ^ ColorNamesDict ifNotNil: [ :dict| - dict keyAtValue: self ifAbsent: [nil]]! ! -!Color methodsFor: 'selection' stamp: 'jmv 3/12/2018 19:15:42' prior: 50353885! - isGreen - "Am I considered Green ?" - - ^self green > (self blue + 0.3) - and: [self green > (self red + 0.3)]! ! -!Color methodsFor: 'selection' stamp: 'jmv 3/12/2018 19:16:29' prior: 50353900! - isMagenta - "Am I considered Magenta ?" - - ^self green < 0.05 - and: [(self red min: self blue) > 0.4] - and: [(self red - self blue) abs < 0.3]! ! -!Color methodsFor: 'selection' stamp: 'jmv 3/12/2018 19:17:05' prior: 50353936! - isYellow - "Am I considered Yellow ?" - - ^self blue < 0.1 - and: [(self red min: self green) > 0.5] - and: [(self red - self green) abs < 0.2]! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 18:48:04' prior: 50354979! - black - ^`Color r: 0 g: 0 b: 0`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:01:23' prior: 50354983! - blue - "Override traditional names existing in XKCD naming" - ^ `Color r: 0.012 g: 0.263 b: 0.875`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 18:59:10' prior: 50354991! - brown - "Override traditional names existing in XKCD naming" - ^ `Color r: 0.396 g: 0.216 b: 0.0`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 18:49:47' prior: 50354995! - cyan - ^ `Color r: 0 g: 1.0 b: 1.0`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:03:42' prior: 50355003! - darkGray - ^ `Color r: 0.375 g: 0.375 b: 0.375`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:03:57' prior: 50355023! - gray - ^ `Color r: 0.5 g: 0.5 b: 0.5`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:02:25' prior: 50355027! - green - "Override traditional names existing in XKCD naming" - ^ `Color r: 0.082 g: 0.690 b: 0.102`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 18:57:12' prior: 50355047! - lightBlue - "Override traditional names existing in XKCD naming" - ^ `Color r: 0.584 g: 0.816 b: 0.988`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 18:47:23' prior: 50355051! - lightBrown - "Override traditional names existing in XKCD naming" - ^ `Color r: 0.678 g: 0.506 b: 0.314`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 18:40:26' prior: 50355055! - lightCyan - "Override traditional names existing in extended XKCD naming" - ^ `Color r: 0.674 g: 1.0 b: 0.988`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:04:01' prior: 50355059! - lightGray - ^ `Color r: 0.625 g: 0.625 b: 0.625`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 18:54:54' prior: 50355063! - lightGreen - "Override traditional names existing in XKCD naming" - ^ `Color r: 0.588 g: 0.976 b: 0.482`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 18:40:33' prior: 50355067! - lightMagenta - "Override traditional names existing in extended XKCD naming" - ^ `Color r: 0.98 g: 0.372 b: 0.969`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 18:40:22' prior: 50355071! - lightOrange - "Override traditional names existing in extended XKCD naming" - ^ `Color r: 0.992 g: 0.667 b: 0.283`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 18:40:30' prior: 50355083! - lightRed - "Override traditional names existing in extended XKCD naming" - ^ `Color r: 1.0 g: 0.279 b: 0.298`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 18:40:18' prior: 50355087! - lightYellow - "Override traditional names existing in extended XKCD naming" - ^ `Color r: 1.0 g: 0.996 b: 0.478`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 18:53:42' prior: 50355103! - magenta - "Override traditional names existing in XKCD naming" - ^ `Color r: 0.760 g: 0.0 b: 0.471`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 18:55:57' prior: 50355131! - orange - "Override traditional names existing in XKCD naming" - ^ `Color r: 0.976 g: 0.451 b: 0.024`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:00:11' prior: 50355147! - pink - "Override traditional names existing in XKCD naming" - ^ `Color r: 1.0 g: 0.506 b: 0.753`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:03:18' prior: 50355151! - purple - "Override traditional names existing in XKCD naming" - ^ `Color r: 0.494 g: 0.118 b: 0.612`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 18:58:04' prior: 50355155! - red - "Override traditional names existing in XKCD naming" - ^ `Color r: 0.898 g: 0 b: 0`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:05:22' prior: 50355175! - tan - ^ `Color r: 0.820 g: 0.698 b: 0.435`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:04:45' prior: 50355183! - transparent - ^ `TranslucentColor r: 0.0 g: 0.0 b: 0.0 alpha: 0.0`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:04:05' prior: 50355191! - veryDarkGray - ^ `Color r: 0.25 g: 0.25 b: 0.25`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:04:10' prior: 50355195! - veryLightGray - ^ `Color r: 0.75 g: 0.75 b: 0.75`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:05:08' prior: 50355200! - veryVeryDarkGray - ^ `Color r: 0.125 g: 0.125 b: 0.125`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:04:18' prior: 50355205! - veryVeryLightGray - ^ `Color r: 0.875 g: 0.875 b: 0.875`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:04:24' prior: 50355214! - white - ^ `Color r: 1.0 g: 1.0 b: 1.0`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 18:52:36' prior: 50355218! - yellow - "Override traditional names existing in XKCD naming" - ^ `Color r: 1.0 g: 1.0 b: 0.078`! ! -!Color class methodsFor: 'cached state access' stamp: 'jmv 5/12/2016 14:58' prior: 50356481! - releaseClassCachedState - " - Color releaseClassCachedState - " - CachedColormaps _ nil. "Maps to translate between color depths" - ToGrayColormaps _ nil. "Maps colors to 8bpp grays for various color depths" - FromGrayColormaps _ nil. "Maps from 8bpp grays to colors of various depths" - MaskingMap _ nil. "Maps all colors except transparent to black for creating a mask" - ColorNamesDict _ nil. - IndexedColors _ nil. - GrayToIndexMap _ nil! ! - -Color class removeSelector: #aqua! - -Color class removeSelector: #aqua! - -Color class removeSelector: #beige! - -Color class removeSelector: #beige! - -Color class removeSelector: #blueColorDict! - -Color class removeSelector: #blueColorDict! - -Color class removeSelector: #blueColorDict:! - -Color class removeSelector: #blueColorDict:! - -Color class removeSelector: #blueGreenColorDict! - -Color class removeSelector: #blueGreenColorDict! - -Color class removeSelector: #blueGreenColorDict:! - -Color class removeSelector: #blueGreenColorDict:! - -Color class removeSelector: #brightColorDict! - -Color class removeSelector: #brightColorDict! - -Color class removeSelector: #brightColorDict:! - -Color class removeSelector: #brightColorDict:! - -Color class removeSelector: #brightGreen! - -Color class removeSelector: #brightGreen! - -Color class removeSelector: #brownColorDict! - -Color class removeSelector: #brownColorDict! - -Color class removeSelector: #brownColorDict:! - -Color class removeSelector: #brownColorDict:! - -Color class removeSelector: #colorNames! - -Color class removeSelector: #colorNames! - -Color class removeSelector: #colorNamesDict! - -Color class removeSelector: #colorNamesDict! - -Color class removeSelector: #darkBlue! - -Color class removeSelector: #darkBlue! - -Color class removeSelector: #darkColorDict! - -Color class removeSelector: #darkColorDict! - -Color class removeSelector: #darkColorDict:! - -Color class removeSelector: #darkColorDict:! - -Color class removeSelector: #darkGreen! - -Color class removeSelector: #darkGreen! - -Color class removeSelector: #darkPink! - -Color class removeSelector: #darkPink! - -Color class removeSelector: #darkPurple! - -Color class removeSelector: #darkPurple! - -Color class removeSelector: #defaultColorNamesDictionary! - -Color class removeSelector: #defaultColorNamesDictionary! - -Color class removeSelector: #doesNotUnderstand:! - -Color class removeSelector: #doesNotUnderstand:! - -Color class removeSelector: #exactColorNamed:! - -Color class removeSelector: #exactColorNamed:! - -Color class removeSelector: #forestGreen! - -Color class removeSelector: #forestGreen! - -Color class removeSelector: #fromString:! - -Color class removeSelector: #fromString:! - -Color class removeSelector: #grayColorDict:! - -Color class removeSelector: #grayColorDict:! - -Color class removeSelector: #greenColorDict! - -Color class removeSelector: #greenColorDict! - -Color class removeSelector: #greenColorDict:! - -Color class removeSelector: #greenColorDict:! - -Color class removeSelector: #grey! - -Color class removeSelector: #grey! - -Color class removeSelector: #greyColorDict! - -Color class removeSelector: #greyColorDict! - -Color class removeSelector: #greyColorDict:! - -Color class removeSelector: #greyColorDict:! - -Color class removeSelector: #hotPink! - -Color class removeSelector: #hotPink! - -Color class removeSelector: #indigo! - -Color class removeSelector: #indigo! - -Color class removeSelector: #lavender! - -Color class removeSelector: #lavender! - -Color class removeSelector: #lightColorDict! - -Color class removeSelector: #lightColorDict! - -Color class removeSelector: #lightColorDict:! - -Color class removeSelector: #lightColorDict:! - -Color class removeSelector: #lightPink! - -Color class removeSelector: #lightPink! - -Color class removeSelector: #lightPurple! - -Color class removeSelector: #lightPurple! - -Color class removeSelector: #lilac! - -Color class removeSelector: #lilac! - -Color class removeSelector: #lime! - -Color class removeSelector: #lime! - -Color class removeSelector: #limeGreen! - -Color class removeSelector: #limeGreen! - -Color class removeSelector: #maroon! - -Color class removeSelector: #maroon! - -Color class removeSelector: #mauve! - -Color class removeSelector: #mauve! - -Color class removeSelector: #mustard! - -Color class removeSelector: #mustard! - -Color class removeSelector: #navyBlue! - -Color class removeSelector: #navyBlue! - -Color class removeSelector: #olive! - -Color class removeSelector: #olive! - -Color class removeSelector: #oliveGreen! - -Color class removeSelector: #oliveGreen! - -Color class removeSelector: #orangeColorDict! - -Color class removeSelector: #orangeColorDict! - -Color class removeSelector: #orangeColorDict:! - -Color class removeSelector: #orangeColorDict:! - -Color class removeSelector: #paleGreen! - -Color class removeSelector: #paleGreen! - -Color class removeSelector: #pastelColorDict! - -Color class removeSelector: #pastelColorDict! - -Color class removeSelector: #pastelColorDict:! - -Color class removeSelector: #pastelColorDict:! - -Color class removeSelector: #peach! - -Color class removeSelector: #peach! - -Color class removeSelector: #periwinkle! - -Color class removeSelector: #periwinkle! - -Color class removeSelector: #pinkColorDict! - -Color class removeSelector: #pinkColorDict! - -Color class removeSelector: #pinkColorDict:! - -Color class removeSelector: #pinkColorDict:! - -Color class removeSelector: #purpleColorDict! - -Color class removeSelector: #purpleColorDict! - -Color class removeSelector: #purpleColorDict:! - -Color class removeSelector: #purpleColorDict:! - -Color class removeSelector: #redColorDict! - -Color class removeSelector: #redColorDict! - -Color class removeSelector: #redColorDict:! - -Color class removeSelector: #redColorDict:! - -Color class removeSelector: #royalBlue! - -Color class removeSelector: #royalBlue! - -Color class removeSelector: #salmon! - -Color class removeSelector: #salmon! - -Color class removeSelector: #saturatedColorDict! - -Color class removeSelector: #saturatedColorDict! - -Color class removeSelector: #saturatedColorDict:! - -Color class removeSelector: #saturatedColorDict:! - -Color class removeSelector: #seaGreen! - -Color class removeSelector: #seaGreen! - -Color class removeSelector: #setColorNamesDict:! - -Color class removeSelector: #setColorNamesDict:! - -Color class removeSelector: #skyBlue! - -Color class removeSelector: #skyBlue! - -Color class removeSelector: #teal! - -Color class removeSelector: #teal! - -Color class removeSelector: #traditionalColorNamesDictionary! - -Color class removeSelector: #traditionalColorNamesDictionary! - -Color class removeSelector: #turquoise! - -Color class removeSelector: #turquoise! - -Color class removeSelector: #violet! - -Color class removeSelector: #violet! - -Color class removeSelector: #xkcdFirst48ColorNamesDictionary! - -Color class removeSelector: #xkcdFirst48ColorNamesDictionary! - -Color class removeSelector: #yellowColorDict! - -Color class removeSelector: #yellowColorDict! - -Color class removeSelector: #yellowColorDict:! - -Color class removeSelector: #yellowColorDict:! - -Color removeSelector: #closestAssocFrom:! - -Color removeSelector: #closestAssocFrom:! - -Color removeSelector: #closestColor! - -Color removeSelector: #closestColor! - -Color removeSelector: #closestColorAssociation! - -Color removeSelector: #closestColorAssociation! - -Color removeSelector: #closestColorFrom:! - -Color removeSelector: #closestColorFrom:! - -Color removeSelector: #closestColorName! - -Color removeSelector: #closestColorName! - -Color removeSelector: #closestNameFrom:! - -Color removeSelector: #closestNameFrom:! - -Color removeSelector: #isBlueGreen! - -Color removeSelector: #isBlueGreen! - -Color removeSelector: #isBright! - -Color removeSelector: #isBright! - -Color removeSelector: #isBrown! - -Color removeSelector: #isBrown! - -Color removeSelector: #isDark! - -Color removeSelector: #isDark! - -Color removeSelector: #isGray! - -Color removeSelector: #isGray! - -Color removeSelector: #isGrey! - -Color removeSelector: #isGrey! - -Color removeSelector: #isLight! - -Color removeSelector: #isLight! - -Color removeSelector: #isOrange! - -Color removeSelector: #isOrange! - -Color removeSelector: #isPastel! - -Color removeSelector: #isPastel! - -Color removeSelector: #isPink! - -Color removeSelector: #isPink! - -Color removeSelector: #isSaturated! - -Color removeSelector: #isSaturated! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3275-MakeNamedColorsOptional-JuanVuletich-2018Mar12-18h18m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3275] on 12 March 2018 at 8:29:55 pm'! -!Color class methodsFor: 'instance creation' stamp: 'jmv 3/12/2018 19:29:16'! - fromHexString: aString - "For HTML color spec: #FFCCAA. - See http://www.w3schools.com/cssref/css_colors_legal.asp" - " - Color fromHexString: '#FFCCAA'. - " - (aString size = 7 and: [ aString first = $# ]) ifTrue: [ - | aColorHexU red green blue | - aColorHexU _ aString asUppercase. - red _ ('16r', (aColorHexU copyFrom: 2 to: 3)) asNumber/255. - green _ ('16r', (aColorHexU copyFrom: 4 to: 5)) asNumber/255. - blue _ ('16r', (aColorHexU copyFrom: 6 to: 7)) asNumber/255. - ^ self r: red g: green b: blue]. - ^ nil! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 20:28:53' prior: 50389031! - black - "Override traditional names existing in XKCD naming" - ^`Color fromHexString: '#000000'`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:30:14' prior: 50389035! - blue - "Override traditional names existing in XKCD naming" - ^ `Color fromHexString: '#0343df'`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:31:13' prior: 50389041! - brown - "Override traditional names existing in XKCD naming" - ^ `Color fromHexString: '#653700'`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 20:28:59' prior: 50389047! - cyan - "Override traditional names existing in XKCD naming" - ^ `Color fromHexString: '#00ffff'`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:33:50' prior: 50389061! - green - "Override traditional names existing in XKCD naming" - ^ `Color fromHexString: '#15b01a'`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:34:21' prior: 50389067! - lightBlue - "Override traditional names existing in XKCD naming" - ^ `Color fromHexString: '#95d0fc'`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 20:12:45' prior: 50389074! -lightBrown - "Override traditional names existing in XKCD naming" - ^ `Color fromHexString: '#ad8150'`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 20:13:44' prior: 50389093! - lightGreen - "Override traditional names existing in XKCD naming" - ^ `Color fromHexString: '#96f97b'`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 20:14:56' prior: 50389128! - magenta - "Override traditional names existing in XKCD naming" - ^ `Color fromHexString: '#c20078'`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 20:15:20' prior: 50389134! - orange - "Override traditional names existing in XKCD naming" - ^ `Color fromHexString: '#f97306'`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 20:16:35' prior: 50389140! - pink - "Override traditional names existing in XKCD naming" - ^ `Color fromHexString: '#ff81c0'`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 20:16:53' prior: 50389146! - purple - "Override traditional names existing in XKCD naming" - ^ `Color fromHexString: '#7e1e9c'`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 20:17:13' prior: 50389152! - red - "Override traditional names existing in XKCD naming" - ^ `Color fromHexString: '#e50000'`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 20:28:47' prior: 50389158! - tan - "Override traditional names existing in XKCD naming" - ^ `Color fromHexString: '#d1b26f'`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 20:18:33' prior: 50389193! - yellow - "Override traditional names existing in XKCD naming" - ^ `Color fromHexString: '#ffff14'`! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3276-TweaksToColor-JuanVuletich-2018Mar12-20h27m-jmv.1.cs.st----! - -----SNAPSHOT----#(13 March 2018 3:20:07.17413 pm) Cuis5.0-3276-32.image priorSource: 1621846! - -----QUIT----#(13 March 2018 3:20:21.331203 pm) Cuis5.0-3276-32.image priorSource: 1853671! - -----STARTUP----#(13 March 2018 4:39:44.136444 pm) as /home/juan/Rectifier/Cuis-Smalltalk-Dev/Cuis5.0-3276-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3276] on 13 March 2018 at 3:37:57 pm'! -!StdIOReadStream methodsFor: 'streaming' stamp: 'jmv 3/13/2018 15:37:34'! - atEnd - ^ false! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3277-StdIOReadStream-atEnd-JuanVuletich-2018Mar13-15h37m-jmv.1.cs.st----! - -----SNAPSHOT----#(13 March 2018 4:39:50.132743 pm) Cuis5.0-3277-32.image priorSource: 1853766! - -----QUIT----#(13 March 2018 4:40:02.046541 pm) Cuis5.0-3277-32.image priorSource: 1854306! - -----STARTUP----#(28 March 2018 9:15:09.735978 am) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3277-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3277] on 19 March 2018 at 3:33:10 pm'! -!Message methodsFor: 'stub creation' stamp: 'HAW 3/19/2018 15:29:03'! - addSetterCodeOn: stream - - stream - newLine; tab; - nextPutAll: selector allButLast; - nextPutAll: ' := '; - nextPutAll: self arguments first argumentName ! ! -!Message methodsFor: 'stub creation' stamp: 'HAW 3/19/2018 15:20:08'! - argumentNameAt: anIndex havingNamed: alreadyNamedArguments - - | argumentName | - - argumentName _ (self arguments at: anIndex) argumentName. - [alreadyNamedArguments includes: argumentName] whileTrue: [argumentName _ argumentName, anIndex asString]. - alreadyNamedArguments add: argumentName. - - ^argumentName! ! -!Message methodsFor: 'stub creation' stamp: 'HAW 3/19/2018 15:26:18'! - writeMessageNameOn: aStream - - | alreadyNamedArguments | - - alreadyNamedArguments _ Set new. - self selector keywords withIndexDo: [ :keyword :index | - aStream nextPutAll: keyword. - self hasArguments ifTrue: [ self writeOn: aStream argumentNameAt: index havingNamed: alreadyNamedArguments ]]. - - ! ! -!Message methodsFor: 'stub creation' stamp: 'HAW 3/19/2018 15:27:23'! - writeOn: aStream argumentNameAt: index havingNamed: alreadyNamedArguments - - | argumentName | - - argumentName _ self argumentNameAt: index havingNamed: alreadyNamedArguments. - - aStream - nextPutAll: ' '; - nextPutAll: argumentName; - space - - ! ! -!Message methodsFor: 'stub creation' stamp: 'HAW 3/19/2018 15:28:33' prior: 50368158! - createStubMethodFor: aClass - - ^ String streamContents: [ :stream | - self writeMessageNameOn: stream. - stream newLine; tab. - self writeShouldBeImplementedOn: stream. - (self isGetterFor: aClass) ifTrue: [ self addGetterCodeOn: stream ]. - (self isSetterFor: aClass) ifTrue: [ self addSetterCodeOn: stream ]. - ]! ! - -Message removeSelector: #addSetterCodeOn:with:! - -Message removeSelector: #addSetterCodeOn:with:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3278-autoGetterAndSetterTweaks-HernanWilkinson-2018Mar19-15h07m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3277] on 22 March 2018 at 12:42:03 pm'! -!Browser methodsFor: 'class list' stamp: 'HAW 3/22/2018 12:40:03' prior: 16791821! -classListIndex: anInteger - "Set anInteger to be the index of the current class selection." - - | className recent canSelectClass | - - canSelectClass _ anInteger between: 1 and: self classList size. - selectedClassName _ canSelectClass ifTrue: [ self classList at: anInteger ]. - self setClassOrganizer. - selectedMessageCategory _ nil. - selectedMessage _ nil. - - self classCommentIndicated ifFalse: [ - self editSelection: (canSelectClass - ifTrue: [#editClass] - ifFalse: [ metaClassIndicated | selectedSystemCategory isNil - ifTrue: [#none] - ifFalse: [#newClass]])]. - - self selectedClass ifNotNil: [ - recent _ self class recentClasses. - className _ self selectedClass name. - (recent includes: className) ifTrue: [recent remove: className]. - recent addFirst: className. - recent size > 16 ifTrue: [recent removeLast]]. - - "We have to refresh the class list if somebody wants to select a class that does not exist anymore - Hernan" - anInteger > self classList size ifTrue: [ self changed: #classList ]. - self changed: #classSelectionChanged. - self changed: #classCommentText. - self changed: #classListIndex. "update my selection" - self changed: #messageCategoryList. - self changed: #messageList. - self changed: #relabel. - self acceptedContentsChanged! ! -!SystemDictionary methodsFor: 'class names' stamp: 'HAW 3/22/2018 12:37:37' prior: 16919340! - forgetClass: aClass logged: aBool - "Delete the class, aClass, from the system. - Note that this doesn't do everything required to dispose of a class - to do that use Class>>removeFromSystem." - - SystemOrganization removeElement: aClass name. - aBool ifTrue: [SystemChangeNotifier uniqueInstance classRemoved: aClass fromCategory: aClass category]. - self removeFromStartUpList: aClass. - self removeFromShutDownList: aClass. - self removeKey: aClass name ifAbsent: nil. - self flushClassNameCache! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3279-ClassRemovalFix-HernanWilkinson-2018Mar22-12h07m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3277] on 22 March 2018 at 3:07:52 pm'! -!SystemDictionary methodsFor: 'class names' stamp: 'HAW 3/22/2018 15:07:34' prior: 50389719! - forgetClass: aClass logged: aBool - "Delete the class, aClass, from the system. - Note that this doesn't do everything required to dispose of a class - to do that use Class>>removeFromSystem." - - | classCategory | - - "I have to keep the cateogory becuase it is nil after removing the class -Hernan" - classCategory _ aClass category. - - SystemOrganization removeElement: aClass name. - aBool ifTrue: [SystemChangeNotifier uniqueInstance classRemoved: aClass fromCategory: classCategory]. - self removeFromStartUpList: aClass. - self removeFromShutDownList: aClass. - self removeKey: aClass name ifAbsent: nil. - self flushClassNameCache! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3280-ClassRemovalFix-HernanWilkinson-2018Mar22-12h42m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3277] on 27 March 2018 at 10:42:25 am'! -!CodePackage methodsFor: 'saving' stamp: 'jmv 3/27/2018 10:31:21'! - writeInitializerExtensionMethods: extensionInitializers on: aStream - "Write the call to package initialization methods in clases not defined in the - package (usually, classes in base system that requires specific init - of stuff that is package extensions)" - - extensionInitializers do: [ :methodReference | - aStream nextChunkPut: methodReference classSymbol asString, ' ' , methodReference selector asString; newLine ]! ! -!CodePackage methodsFor: 'saving' stamp: 'jmv 3/27/2018 10:20:51' prior: 16810570! - write: classes initializersOn: aStream - "Write the call to #initialize method of classes defined in us." - - Smalltalk hierarchySorted: classes do: [ :class | - (class class includesSelector: #initialize) ifTrue: [ - aStream nextChunkPut: class name, ' initialize'; newLine ]]! ! -!CodePackage methodsFor: 'saving' stamp: 'jmv 3/27/2018 10:40:34' prior: 50377192! - writeOnStream: aStream - - | sortedClasses initExtensions | - aStream - nextChunkPut: ('Description ', description) printString; - newLine. - self writeFeatureSpecOn: aStream. - self writeSystemCategoriesOn: aStream. - sortedClasses _ Array streamContents: [ :strm | - self classesInSafeOrderDo: [ :cls | - strm nextPut: cls ]]. - self - write: sortedClasses classDefinitionsOn: aStream; - write: sortedClasses classCommentsOn: aStream; - write: sortedClasses methodsOn: aStream. - initExtensions _ OrderedCollection new. - self - sortedExtensionMethodsDo: [ :methodReference | - methodReference isValid ifTrue: [ - self writeMethod: methodReference on: aStream. - (methodReference selector beginsWith: 'initialize') - ifTrue: [ initExtensions add: methodReference ]]] - displayingProgress: 'Saving extension methods...'. - self write: sortedClasses initializersOn: aStream. - self writeInitializerExtensionMethods: initExtensions on: aStream! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3281-PackageExtensionsInitializers-JuanVuletich-2018Mar27-10h19m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3281] on 28 March 2018 at 9:05:04 am'! - -Object subclass: #StackSizeWatcher - instanceVariableNames: 'watcher timeBetweenChecks stackSizeThreashold' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Profiling'! - -!classDefinition: #StackSizeWatcher category: #'Tools-Profiling'! -Object subclass: #StackSizeWatcher - instanceVariableNames: 'watcher timeBetweenChecks stackSizeThreashold' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Profiling'! - -StackSizeWatcher class - instanceVariableNames: 'current'! - -!classDefinition: 'StackSizeWatcher class' category: #'Tools-Profiling'! -StackSizeWatcher class - instanceVariableNames: 'current'! -!ProcessBrowser methodsFor: 'initialization' stamp: 'jmv 3/28/2018 08:57:18'! -startStackSizeWatcher - - StackSizeWatcher isWatching ifFalse: [ - StackSizeWatcher startWatchingWithDefaults ]! ! -!ProcessBrowser methodsFor: 'initialization' stamp: 'jmv 3/28/2018 08:56:50'! - stopStackSizeWatcher - - StackSizeWatcher stopWatching. - self updateProcessList! ! -!ContextPart methodsFor: 'accessing' stamp: 'HAW 3/27/2018 14:02:09'! - depthBelow - - ^self depthBelow: nil! ! -!ProcessBrowserWindow methodsFor: 'menu commands' stamp: 'jmv 3/28/2018 08:55:53'! - startStackSizeWatcher - - model startStackSizeWatcher! ! -!ProcessBrowserWindow methodsFor: 'menu commands' stamp: 'jmv 3/28/2018 08:56:08'! - stopStackSizeWatcher - model stopStackSizeWatcher! ! -!StackSizeWatcher methodsFor: 'assertions' stamp: 'HAW 3/27/2018 14:16:52'! -assertIsNotWatching - - self isNotWatching ifFalse: [ self error: 'Already watching' ].! ! -!StackSizeWatcher methodsFor: 'assertions' stamp: 'HAW 3/27/2018 14:16:43'! - assertIsWatching - - self isWatching ifFalse: [ self error: 'It is not watching' ]! ! -!StackSizeWatcher methodsFor: 'configuration changing' stamp: 'HAW 3/27/2018 14:21:02'! - changeStackSizeThresholdTo: aThreshold - - stackSizeThreashold _ aThreshold ! ! -!StackSizeWatcher methodsFor: 'configuration changing' stamp: 'HAW 3/27/2018 14:21:17'! - changeTimeBetweenChecksTo: aTimeBetweenChecks - - "time in milliseconds - Hernan" - - timeBetweenChecks _ aTimeBetweenChecks ! ! -!StackSizeWatcher methodsFor: 'testing' stamp: 'HAW 3/27/2018 14:49:41'! - canDebug: aProcess - - ^(ProcessBrowser rulesFor: aProcess) second - -! ! -!StackSizeWatcher methodsFor: 'testing' stamp: 'HAW 3/27/2018 13:51:35'! - isNotWatching - - ^self isWatching not! ! -!StackSizeWatcher methodsFor: 'testing' stamp: 'HAW 3/27/2018 14:55:20'! - isStackTooDeepAt: aProcess - - "aProcess suspendedContext should never be nil under this circunstances but checking that just in case - Hernan" - ^aProcess suspendedContext - ifNil: [ false ] - ifNotNil: [ :topContext | topContext depthBelow > stackSizeThreashold ] - ! ! -!StackSizeWatcher methodsFor: 'testing' stamp: 'HAW 3/27/2018 13:51:28'! - isWatching - - ^watcher notNil ! ! -!StackSizeWatcher methodsFor: 'testing' stamp: 'HAW 3/27/2018 14:49:21'! - shouldStopAndDebug: aProcess - - ^(self isStackTooDeepAt: aProcess) and: [self canDebug: aProcess] - -! ! -!StackSizeWatcher methodsFor: 'start/stop' stamp: 'jmv 3/28/2018 08:50:08'! - startWatching - - self assertIsNotWatching. - - watcher _ [ [self watch] repeat ] newProcess. - watcher priority: Processor lowIOPriority. - watcher name: 'StackSizeWatcher monitor'. - watcher resume. - Processor yield! ! -!StackSizeWatcher methodsFor: 'start/stop' stamp: 'HAW 3/27/2018 14:19:22'! - startWatchingAt: aTimeBetweenChecks informingWhenStackSizeBiggerThan: aThreshold - - self assertIsNotWatching. - - self changeTimeBetweenChecksTo: aTimeBetweenChecks. - self changeStackSizeThresholdTo: aThreshold. - self startWatching ! ! -!StackSizeWatcher methodsFor: 'start/stop' stamp: 'HAW 3/27/2018 13:50:21'! - stopWatching - - self assertIsWatching. - - watcher terminate. - watcher _ nil! ! -!StackSizeWatcher methodsFor: 'private' stamp: 'HAW 3/27/2018 14:53:56'! - debug: aProcess - - aProcess debugFullWithTitle: 'Interrupted - Stack too deep'. -! ! -!StackSizeWatcher methodsFor: 'private' stamp: 'HAW 3/27/2018 14:47:26'! - watch - - | processToWatch | - - (Delay forMilliseconds: timeBetweenChecks) wait. - processToWatch := Processor nextReadyProcess. - (self shouldStopAndDebug: processToWatch) ifTrue: [ self debug: processToWatch ] -! ! -!StackSizeWatcher class methodsFor: 'current' stamp: 'HAW 3/27/2018 14:12:49'! - current - - current isNil ifTrue: [ current _ self new ]. - ^current! ! -!StackSizeWatcher class methodsFor: 'current' stamp: 'HAW 3/27/2018 14:15:30'! - resetCurrent - - current _ nil! ! -!StackSizeWatcher class methodsFor: 'defaults' stamp: 'HAW 3/27/2018 14:20:12'! - defaultStackSizeThreshold - - ^2000! ! -!StackSizeWatcher class methodsFor: 'defaults' stamp: 'HAW 3/27/2018 14:07:34'! - defaultTimeBetweenChecks - - "Time in milliseconds - Hernan" - ^10! ! -!StackSizeWatcher class methodsFor: 'start/stop' stamp: 'jmv 3/28/2018 08:54:09'! - isWatching - ^ current notNil and: [ current isWatching ]! ! -!StackSizeWatcher class methodsFor: 'start/stop' stamp: 'HAW 3/27/2018 14:19:58'! - startWatchingAt: aTimeBetweenChecks informingWhenStackSizeBiggerThan: aThreshold - - ^self current startWatchingAt: aTimeBetweenChecks informingWhenStackSizeBiggerThan: aThreshold -! ! -!StackSizeWatcher class methodsFor: 'start/stop' stamp: 'HAW 3/27/2018 14:20:22'! - startWatchingWithDefaults - - ^self startWatchingAt: self defaultTimeBetweenChecks informingWhenStackSizeBiggerThan: self defaultStackSizeThreshold! ! -!StackSizeWatcher class methodsFor: 'start/stop' stamp: 'HAW 3/27/2018 14:15:17'! - stopWatching - - self current stopWatching. - self resetCurrent ! ! -!ProcessBrowserWindow methodsFor: 'menu building' stamp: 'jmv 3/28/2018 08:58:40' prior: 16895341! - processListMenu - | menu rules | - menu _ MenuMorph new defaultTarget: self. - - model selectedProcess - ifNotNil: [ :selectedProcess | - rules _ model class rulesFor: model selectedProcess. - menu addList: #( - ('inspect (i)' #inspectProcess) - ('explore (I)' #exploreProcess) - ('references finder' #openReferencesFinder)). - rules first - ifTrue: [ - menu add: 'terminate (t)' target: model action: #terminateProcess. - selectedProcess isSuspended - ifTrue: [menu add: 'resume (r)' target: model action: #resumeProcess] - ifFalse: [menu add: 'suspend (s)' target: model action: #suspendProcess]]. - rules second - ifTrue: [ - menu addList: #( - ('change priority (p)' #changePriority) - ('debug (d)' #debugProcess))]. - (selectedProcess suspendingList isKindOf: Semaphore) - ifTrue: [menu add: 'signal Semaphore (S)' target: model action: #signalSemaphore]. - menu add: 'full stack (k)' target: model action: #moreStack. - menu addLine]. - - menu addList: #( - ('find context... (f)' #findContext) - ('find again (g)' #nextContext '' model)). - menu addLine. - - menu - add: (isStepping - ifTrue: ['turn off auto-update (a)'] - ifFalse: ['turn on auto-update (a)']) - action: #toggleAutoUpdate. - menu add: 'update list (u)' target: model action: #updateProcessList. - - menu addLine. - CPUWatcher isMonitoring - ifTrue: [ menu add: 'stop CPUWatcher' action: #stopCPUWatcher ] - ifFalse: [ menu add: 'start CPUWatcher' action: #startCPUWatcher ]. - StackSizeWatcher isWatching - ifTrue: [ menu add: 'stop StackSizeWatcher' action: #stopStackSizeWatcher ] - ifFalse: [ menu add: 'start StackSizeWatcher' action: #startStackSizeWatcher ]. - - ^ menu! ! -!Theme methodsFor: 'menus' stamp: 'jmv 3/28/2018 09:03:29' prior: 50376436! - basicIcons - - "Minimal menu scheme. - Theme current class beCurrent - " - - ^ { - #('open...') -> #openIcon. - #('windows...' 'find window' 'Focus follows mouse' 'Click to focus') -> #windowIcon. - #('help...' 'explain' 'about this system...' 'Terse Guide to Cuis' 'Class Comment Browser' 'Code management in Cuis' 'Using GitHub to host Cuis packages' ) -> #helpIcon. - #('themes...') -> #appearanceIcon. - #('do it (d)') -> #doItIcon. - #('new morph...' 'objects (o)' 'save world as morph file') -> #morphsIcon. - #('save' ) -> #saveIcon. - #('Save options...' 'save as...' 'change category...' 'rename change set (r)' 'rename') -> #saveAsIcon. - #('save as new version') -> #saveAsNewVersionIcon. - #('quit') -> #quitIcon. - #('save and quit' ) -> #saveAndQuitIcon. - #('inspect it (i)' 'inspect world' 'inspect model' 'inspect morph' - 'inspect owner chain' 'inspect' 'inspect (i)' 'basic inspect' 'message names' 'find message names' 'inspect instances' 'inspect subinstances' 'inspect change set' 'inspect context (c)' 'inspect receiver (i)' 'start CPUWatcher' 'stop CPUWatcher') - -> #inspectIcon. - #('explore' 'explore it (I)' 'explore world' 'explore morph' 'explore (I)' 'explore context (C)' 'explore receiver (I)' 'references finder' 'weight explorer' 'explore CompiledMethod') -> #exploreIcon. - #('find...(f)' 'find class... (f)' 'find method...' 'find recent submissions' 'show hierarchy' 'show definition' 'show comment' 'filter' 'filter message list...' 'find context... (f)') -> #findIcon. - #('add item...' 'new category...' 'create new change set...' 'new change set... (n)' 'add new file') -> #newIcon. - #('remove method (x)' 'remove' 'remove class (x)' 'remove method from system (x)' 'remove class from system (x)' 'remove postscript''stop StackSizeWatcher' ) -> #deleteIcon. - #('delete method from changeset (d)' 'delete class from change set (d)' 'destroy change set (X)' 'revert & remove from changes' 'delete unchanged windows' 'delete non windows' 'delete both of the above' 'reset variables' 'remove contained in class categories...' 'clear this change set' 'uninstall this change set' 'delete directory...' 'delete' 'start StackSizeWatcher') -> #warningIcon. - #('do again (j)' 'Redo - multiple (Z)') -> #redoIcon. - #('undo (z)' 'revert to previous version' 'Undo - multiple (z)') -> #undoIcon. - #('copy to clipboard (c)' 'copy (c)' 'copy class...' 'copy class chgs to other side' 'copy method to other side' 'copy all to other side (c)' 'copy name to clipboard' 'copy selector to clipboard') -> #copyIcon. - #('paste (v)' 'Paste without Format') -> #pasteIcon. - #('cut (x)' 'move class chgs to other side' 'move method to other side' 'submerge into other side') -> #cutIcon. - #('paste...' 'icons...') -> #worldIcon. -}! ! -!Theme methodsFor: 'menus' stamp: 'jmv 3/28/2018 09:03:59' prior: 50338802! - miscellaneousIcons - - "Everything else." - - ^ { - #('restore display (r)' 'set display depth...' 'move windows onscreen' 'Utilities saveDisplay.') -> #displayIcon. - #('changes...' 'dual change sorter' 'change sets with this method' 'find a change sorter' 'recent changes in file' 'Undo / Redo history' 'code file contents' 'package file contents') -> #changesIcon. - #('Install New Updates' 'update' 'turn on auto-update (a)' 'update list (u)' 'install code' 'fileIn entire file' 'install package') -> #updateIcon. - #('find again (g)' 'full stack (k)') -> #systemIcon. - #('print it (p)' 'check change set for slips') -> #printIcon. - #('accept (s)' 'make changes go to me (m)') -> #acceptIcon. - #('cancel (l)' 'turn off auto-update (a)' 'stop StackSizeWatcher') -> #cancelIcon. - #('debug...' 'Debug it (D)' 'toggle break on entry') -> #debugIcon. - #('close' 'close all debuggers' 'close top window') -> #closeIcon. - #('collapse' 'hide taskbar' 'collapse all windows') -> #collapseIcon. - #('expand / contract' 'show taskbar' 'restore all windows') -> #expandIcon. - #('menu') -> #windowMenuIcon. - #('browse all' 'browser' 'browse it (b)' 'MessageTally UI and browse' 'browse recent submissions' 'browse full (b)' 'find changed browsers...' 'browse (b)' 'browse my changes') -> #editFindReplaceIcon. - #('workspace' 'workspace with contents') -> #terminalIcon. - #('styled text editor' 'text editor' 'basic text editor' 'unicode editor' 'edit this list' 'edit postscript...' 'add postscript...') -> #textEditorIcon. - #('file list' 'find a fileList' 'compress file') -> #systemFileManagerIcon. - #('transcript' 'find a transcript' 'Transcript clear.' 'log to transcript') -> #printerIcon. - #('process browser' 'vm statistics' 'MessageTally all Processes') -> #systemMonitorIcon. - #('emergency evaluator' 'conflicts with other change sets' 'check for slips' 'conflicts with change set opposite' 'conflicts with category opposite') -> #emblemImportantIcon. - #('change sorter') -> #halfRefreshIcon. - #('SUnit Test Runner' 'Accept & Run Test in Class (t)' 'Accept & Run Test in Category (y)' 'Run tests (t)' 'Run tests' 'Run test (t)' 'Accept & Debug Test (r)' 'Debug test (r)') -> #weatherFewCloudsIcon. - #('Font Sizes...' 'system fonts...' 'set font... (k)') -> #preferencesDesktopFontIcon. - #('full screen on') -> #viewFullscreenIcon. - #('full screen off') -> #exitFullscreenIcon. - #('set desktop color...') -> #wallpaperIcon. - #('preferences...' 'All preferences...' 'what to show...' 'view as hex') -> #preferencesIcon. - #('Editor keyboard shortcuts') -> #keyboardShortcutsIcon. - #('world menu help') -> #globeIcon. "currently unused, but a neat icon" - #('useful expressions' 'class comments with it' 'check for uncommented methods' 'check for uncommented classes') -> #chatIcon. - #('set code author...' 'check for other authors' 'check for any other authors') -> #usersIcon. - #('space left') -> #removableMediaIcon. - #('start drawing all again' 'window color...') -> #graphicsIcon. - #('start stepping again') -> #mediaPlaybackStartIcon. - #('file out current change set' 'fileOut' 'File out and remove (o)' 'File out and keep (k)') -> #fileOutIcon. - #('recently logged changes...' 'versions (v)' 'recent classes... (r)' 'trim history' 'Profile it') -> #clockIcon. - #('senders of it (n)' 'senders of... (n)' 'local senders of...' 'senders (n)') -> #mailForwardIcon. - #('implementors of it (m)' 'implementors of... (m)' 'implementors of sent messages') -> #developmentIcon. - #('references to it (N)') -> #addressBookIcon. - #('class var refs...' 'class refs (N)' 'class variables' 'class vars' 'local implementors of...' 'subclass template') -> #classIcon. - #('inst var refs...' 'inst var defs...' 'sample instance') -> #instanceIcon. - #('Use Selection for Find (j)' 'rename class ...' 'rename...' 'change title...') -> #saveAsIcon. - #('smalltalk options' 'method source with it' 'browse method (O)' 'check for uncategorized methods') -> #scriptIcon. - #('method strings with it (E)' 'Toggle WordWrap') -> #genericTextIcon. - #('browse hierarchy (h)' 'move to top' 'promote to top of list') -> #goTopIcon. - #('move up' 'make next-to-topmost') -> #goUpIcon. - #('move to bottom' 'send to back' 'send top window to back') -> #goBottomIcon. - #('inheritance (i)' 'move down') -> #goDownIcon. - #('browse protocol (p)' 'spawn sub-protocol') -> #spreadsheetIcon. - #('spawn full protocol') -> #speadsheetTemplateIcon. - #('alphabetize') -> #fontXGenericIcon. - #('Installed Packages' 'browse' 'show category (C)' 'categorize all uncategorized' 'select change set...' 'view affected class categories') -> #packageIcon. - #('remove from current change set' 'remove empty categories' 'subtract other side (-)' 'remove from this browser') -> #listRemoveIcon. - #('add to current change set' 'add all meths to current chgs' 'add preamble (p)' 'More...') -> #listAddIcon. - #('toggle diffing (D)' 'toggle selections') -> #switchIcon. - #('reorganize' 'create inst var accessors' 'ChangeSorter reorderChangeSets.' 'reorder all change sets' 'by name' 'by size' 'by date') -> #sendReceiveIcon. - #('unsent methods' 'unreferenced class vars' 'unreferenced inst vars' 'Undeclared inspect.' 'Undeclared removeUnreferencedKeys; inspect.' 'ChangeSorter removeEmptyUnnamedChangeSets.' 'check for unsent messages') -> #junkIcon. - #('find changed windows...') -> #newWindowIcon. - #('make undraggable') -> #pushPinIcon. - #('Utilities saveScreenshot.') -> #stillCameraIcon. - #('add new directory') -> #newFolderIcon. - #('select all' 'deselect all') -> #selectAllIcon. - #('sort by date') -> #dateIcon. - #('justified') -> #formatJustifyFillIcon. - #('centered') -> #formatJustifyCenterIcon. - #('set alignment...' 'leftFlush') -> #formatJustifyLeftIcon. - #('rightFlush') -> #formatJustifyRightIcon. - #('signal Semaphore (S)') -> #haloHelpIcon. - #('Change Paragraph Style...' 'Change Character Style...' 'Remove Character Style' 'Replace all uses of Paragraph Style...' 'Replace all uses of Character Style...' 'Set Default Font...') -> #fontXGenericIcon. - #('Clear Font') -> #newIcon. - #('code file browser' 'package file browser') -> #findIcon. - }! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3282-StackGrowthAlert-HernanWilkinson-2018Mar28-08h47m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3282] on 27 March 2018 at 5:11:12 pm'! -!InspectorWindow methodsFor: 'accessing' stamp: 'HAW 3/27/2018 17:07:55'! - classDefinitionChangedFrom: oldClass to: newClass - - model ifNotNil: [ model object class = newClass ifTrue: [ model changed: #fieldList ]]! ! -!InspectorWindow methodsFor: 'accessing' stamp: 'HAW 3/27/2018 17:07:24'! - model: aModel - - super model: aModel. - model ifNotNil: [ - SystemChangeNotifier uniqueInstance - when: #classDefinitionChanged send: #classDefinitionChangedFrom:to: to: self ] -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3283-UpdateInspectorOnClassShapeChange-HernanWilkinson-2018Mar19-15h33m-HAW.2.cs.st----! - -----SNAPSHOT----#(28 March 2018 9:15:16.2917 am) Cuis5.0-3283-32.image priorSource: 1854402! - -----QUIT----#(28 March 2018 9:15:28.753021 am) Cuis5.0-3283-32.image priorSource: 1879823! - -----STARTUP----#(15 April 2018 7:34:19.936681 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3283-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3283] on 31 March 2018 at 11:34:13 pm'! -!SequenceableCollection methodsFor: 'testing' stamp: 'HAW 3/31/2018 23:26:34'! - ifInBounds: anIndex ifNot: aValuable - - ^(self isInBounds: anIndex) ifTrue: [ anIndex ] ifFalse: aValuable ! ! -!SequenceableCollection methodsFor: 'testing' stamp: 'HAW 3/31/2018 23:26:24'! - isInBounds: anIndex - - ^anIndex between: 1 and: self size! ! -!SequenceableCollection methodsFor: 'accessing' stamp: 'HAW 3/31/2018 23:26:53' prior: 16905458! - 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." - - (self isInBounds: index) ifTrue: [^self at: index]. - ^exceptionBlock value! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3284-SequenceableCollection-boundsChecking-HernanWilkinson-2018Mar31-23h26m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3283] on 31 March 2018 at 11:37:37 pm'! -!Browser methodsFor: 'class list' stamp: 'HAW 3/31/2018 23:34:42' prior: 50389676! - classListIndex: anInteger - "Set anInteger to be the index of the current class selection." - - | className recent canSelectClass classList | - - classList _ self classList. - canSelectClass _ classList isInBounds: anInteger. - selectedClassName _ canSelectClass ifTrue: [ classList at: anInteger ]. - self setClassOrganizer. - selectedMessageCategory _ nil. - selectedMessage _ nil. - - self classCommentIndicated ifFalse: [ - self editSelection: (canSelectClass - ifTrue: [#editClass] - ifFalse: [ metaClassIndicated | selectedSystemCategory isNil - ifTrue: [#none] - ifFalse: [#newClass]])]. - - self selectedClass ifNotNil: [ - recent _ self class recentClasses. - className _ self selectedClass name. - (recent includes: className) ifTrue: [recent remove: className]. - recent addFirst: className. - recent size > 16 ifTrue: [recent removeLast]]. - - "We have to refresh the class list if somebody wants to select a class that does not exist anymore - Hernan" - anInteger > classList size ifTrue: [ self changed: #classList ]. - self changed: #classSelectionChanged. - self changed: #classCommentText. - self changed: #classListIndex. "update my selection" - self changed: #messageCategoryList. - self changed: #messageList. - self changed: #relabel. - self acceptedContentsChanged! ! -!Browser methodsFor: 'message category list' stamp: 'HAW 3/31/2018 23:35:18' prior: 16792196! - messageCategoryListIndex: anInteger - "Set the selected message category to be the one indexed by anInteger." - - | index messageCategoryList | - - messageCategoryList _ self messageCategoryList. - index _ messageCategoryList ifInBounds: anInteger ifNot: 0. - - selectedMessageCategory _ index = 0 ifFalse: [messageCategoryList at: index ]. - selectedMessage _ nil. - self changed: #messageCategorySelectionChanged. - self changed: #messageCategoryListIndex. "update my selection" - self changed: #messageList. - self editSelection: (index > 0 - ifTrue: [#newMessage] - ifFalse: [self classListIndex > 0 - ifTrue: [#editClass] - ifFalse: [#newClass]]). - self acceptedContentsChanged.! ! -!Browser methodsFor: 'message list' stamp: 'HAW 3/31/2018 23:35:30' prior: 16792405! - messageListIndex: anInteger - "Set the selected message selector to be the one indexed by anInteger." - - | index messageList | - - messageList _ self messageList. - index _ messageList ifInBounds: anInteger ifNot: 0. - - selectedMessage _ index = 0 ifFalse: [ messageList at: index ]. - self editSelection: (index > 0 - ifTrue: [#editMessage] - ifFalse: [self messageCategoryListIndex > 0 - ifTrue: [#newMessage] - ifFalse: [self classListIndex > 0 - ifTrue: [#editClass] - ifFalse: [#newClass]]]). - self changed: #messageListIndex. "update my selection" - self acceptedContentsChanged! ! -!Browser methodsFor: 'system category list' stamp: 'HAW 3/31/2018 23:35:42' prior: 16792786! - systemCategoryListIndex: anInteger - "Set the selected system category index to be anInteger. Update all other - selections to be deselected." - - | index systemCategoryList | - - systemCategoryList _ self systemCategoryList. - index _ systemCategoryList ifInBounds: anInteger ifNot: 0. - - selectedSystemCategory _ index = 0 ifFalse: [ systemCategoryList at: index ]. - selectedClassName _ nil. - selectedMessageCategory _ nil. - selectedMessage _ nil. - self editSelection: ( index = 0 ifTrue: [#none] ifFalse: [#newClass]). - metaClassIndicated _ false. - self setClassOrganizer. - self changed: #systemCategorySelectionChanged. - self changed: #systemCategoryListIndex. "update my selection" - self changed: #classList. - self changed: #messageCategoryList. - self changed: #messageList. - self changed: #relabel. - self changed: #instanceMessagesIndicated. - self changed: #classCommentIndicated. - self changed: #classMessagesIndicated. - self acceptedContentsChanged! ! -!HierarchyBrowser methodsFor: 'initialization' stamp: 'HAW 3/31/2018 23:36:09' prior: 16853533! - classListIndex: newIndex - - "Cause system organization to reflect appropriate category" - - | newClassName ind i | - - (classList isInBounds: newIndex) ifTrue: [ - newClassName _ (classList at: newIndex) copyWithout: $ . - i _ systemOrganizer numberOfCategoryOfElement: newClassName. - selectedSystemCategory _ i = 0 ifFalse: [ self systemCategoryList at: i]]. - ind _ super classListIndex: newIndex. - self changed: #systemCategorySingleton. - ^ ind! ! -!MessageSet methodsFor: 'message list' stamp: 'HAW 3/31/2018 23:36:45' prior: 16869855! - messageListIndex: anInteger - - "Set the index of the selected item to be anInteger." - - | list | - - list _ self messageList. - selectedMessage _ (list isInBounds: anInteger) ifTrue: [ list at: anInteger ]. - self changed: #messageListIndex. "update my selection" - self editSelection: #editMessage. - self acceptedContentsChanged! ! -!TimeProfileBrowser methodsFor: 'message list' stamp: 'HAW 3/31/2018 23:37:17' prior: 16937837! - messageListIndex: anInteger - - "Set the index of the selected item to be anInteger." - - selectedMessage _ (talliesList isInBounds: anInteger) ifTrue: [ talliesList at: anInteger ]. - self changed: #messageListIndex. "update my selection" - self editSelection: #editMessage. - self acceptedContentsChanged! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3285-Browser-SelectionIndexChecks-HernanWilkinson-2018Mar31-23h34m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3285] on 4 April 2018 at 3:16:11 pm'! -!AbstractFont methodsFor: 'measuring' stamp: 'jmv 4/4/2018 14:46:40'! - normalizedWidthOf: aCharacter - "Return the width of the given character, irrespective of point size." - ^ (self widthOf: aCharacter) / self pointSize! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3286-normalizedWidthOf-JuanVuletich-2018Apr04-14h46m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3286] on 4 April 2018 at 4:53:28 pm'! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipLeft clipTop clipRight clipBottom shadowColor transformations currentTransformation cti currentMorph ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipLeft clipTop clipRight clipBottom shadowColor transformations currentTransformation cti currentMorph' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3287-removeUnusedIvar-JuanVuletich-2018Apr04-16h43m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3285] on 5 April 2018 at 2:33:05 pm'! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 4/5/2018 13:35:59' prior: 50343611! - should: aBlock raise: anExceptionHandlingCondition withExceptionDo: assertionsBlock description: aFailDescription - - | result | - - [result := aBlock value ] - on: anExceptionHandlingCondition - do: [ :anException | - assertionsBlock value: anException. - ^result ]. - - self failWith: aFailDescription! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3288-shouldraise-fix-HernanWilkinson-2018Apr05-14h11m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3283] on 13 April 2018 at 4:53:18 pm'! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 4/13/2018 16:51:04' prior: 50386823! - displayOn: aForm in: aRectangle - " - 1 to: 2000 do: [ :i | i print ]. - 1 to: 750 do: [ :i | i print ]. - Transcript displayOn: Display in: bounds - " - | font count string x y fh canvas innerR index | - aForm fill: aRectangle fillColor: `Color white`. - font _ AbstractFont default. - - innerR _ aRectangle insetBy: self padding. - canvas _ aForm getCanvas. - canvas newClipRect: innerR. - x _ innerR left. - y _ innerR top. - fh _ font height. - count _ lastIndex - firstIndex \\ self maxEntries + 1 min: innerR height // fh - 1. - index _ lastIndex - count \\ self maxEntries + 1. - count timesRepeat: [ - string _ entries at: index. - canvas drawString: string at: x@y font: font color: `Color veryDarkGray`. - y _ y + fh. - index _ index \\ self maxEntries + 1 ]. - string _ unfinishedEntry contents. - canvas drawString: string at: x@y font: font color: `Color veryDarkGray`! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3289-Transcript-fix-JuanVuletich-2018Apr13-16h20m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3285] on 12 April 2018 at 1:37:31 pm'! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'HAW 4/12/2018 13:36:40' prior: 16806621! - definition - "Answer a String that defines the receiver." - - ^String streamContents: [ :strm | - strm - nextPutAll: (superclass ifNotNil: [ superclass name ] ifNil: [ 'ProtoObject' ]); - nextPutAll: self kindOfSubclass; - store: self name. - strm - newLine; - tab; - nextPutAll: 'instanceVariableNames: '; - store: self instanceVariablesString. - strm - newLine; - tab; - nextPutAll: 'classVariableNames: '; - store: self classVariablesString. - strm - newLine; - tab; - nextPutAll: 'poolDictionaries: '; - store: self sharedPoolsString. - strm - newLine; - tab; - nextPutAll: 'category: '; - store: self category asString. - - superclass ifNil: [ - strm nextPutAll: '.'; newLine. - strm nextPutAll: self name. - strm space; nextPutAll: 'superclass: nil' ]]! ! -!SmallFloat64 class methodsFor: 'fileIn/Out' stamp: 'HAW 4/12/2018 13:35:41' prior: 16908567! - definition - "Special class definition for Character, SmallInteger and SmallFloat64 - Required to have the same definition both for preSpur and Spur, and to be compatible with both." - ^ -'Float immediateSubclass: #SmallFloat64 - instanceVariableNames: '''' - classVariableNames: '''' - poolDictionaries: '''' - category: ''', self category, '''' -! ! -!SmallInteger class methodsFor: 'fileIn/Out' stamp: 'HAW 4/12/2018 13:35:04' prior: 16909202! - definition - "Special class definition for Character, SmallInteger and SmallFloat64 - Required to have the same definition both for preSpur and Spur, and to be compatible with both." - ^ -'Integer immediateSubclass: #SmallInteger - instanceVariableNames: '''' - classVariableNames: '''' - poolDictionaries: '''' - category: ''', self category, ''''! ! -!Character class methodsFor: 'fileIn/Out' stamp: 'HAW 4/12/2018 13:36:49' prior: 50375912! - definition - "Special class definition for Character, SmallInteger and SmallFloat64 - Required to have the same definition both for preSpur and Spur, and to be compatible with both." - ^ -'Object immediateSubclass: #Character - instanceVariableNames: ''value'' - classVariableNames: ''CharacterTable UnaccentedTable UnicodeCodePoints LowercaseMappingTable LowercaseTruthTable UppercaseMappingTable UppercaseTruthTable LetterTruthTable'' - poolDictionaries: '''' - category: ''', self category, '''' -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3290-ImmediateClasses-definition-HernanWilkinson-2018Apr12-13h34m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3285] on 14 April 2018 at 7:50:08 pm'! -!Theme methodsFor: 'menus - private' stamp: 'HAW 4/12/2018 15:53:55'! - basicIconsTypeSelector - - ^#addBasicIconsTo:! ! -!Theme methodsFor: 'menus - private' stamp: 'HAW 4/14/2018 19:47:32'! - iconDefinersFor: anIconTypeSelector - - ^(Smalltalk allClassesImplementing: anIconTypeSelector) - select: [ :aClass | aClass isMeta ] - thenCollect: [ :aClass | aClass soleInstance ]. - ! ! -!Theme methodsFor: 'menus - private' stamp: 'HAW 4/14/2018 19:47:39'! - iconsDefinitionFor: anIconTypeSelector - - ^(self iconDefinersFor: anIconTypeSelector) - inject: OrderedCollection new - into: [ :definition :iconDefiner | - iconDefiner perform: anIconTypeSelector with: definition. - definition ]! ! -!Theme methodsFor: 'menus - private' stamp: 'HAW 4/12/2018 16:00:19'! - miscellaneousIconsTypeSelector - - ^#addMiscellaneousIconsTo: -! ! -!Theme class methodsFor: 'icons by menu' stamp: 'HAW 4/14/2018 19:44:24'! - addBasicIconsTo: aCollectorCollection - - aCollectorCollection - add: #('open...') -> #openIcon; - add: #('windows...' 'find window' 'Focus follows mouse' 'Click to focus') -> #windowIcon; - add: #('help...' 'explain' 'about this system...' 'Terse Guide to Cuis' 'Class Comment Browser' 'Code management in Cuis' 'Using GitHub to host Cuis packages' ) -> #helpIcon; - add: #('themes...') -> #appearanceIcon; - add: #('do it (d)') -> #doItIcon; - add: #('new morph...' 'objects (o)' 'save world as morph file') -> #morphsIcon; - add: #('save' ) -> #saveIcon; - add: #('Save options...' 'save as...' 'change category...' 'rename change set (r)' 'rename') -> #saveAsIcon; - add: #('save as new version') -> #saveAsNewVersionIcon; - add: #('quit') -> #quitIcon; - add: #('save and quit' ) -> #saveAndQuitIcon; - add: #('inspect it (i)' 'inspect world' 'inspect model' 'inspect morph' - 'inspect owner chain' 'inspect' 'inspect (i)' 'basic inspect' 'message names' 'find message names' 'inspect instances' 'inspect subinstances' 'inspect change set' 'inspect context (c)' 'inspect receiver (i)' 'start CPUWatcher' 'stop CPUWatcher') - -> #inspectIcon; - add: #('explore' 'explore it (I)' 'explore world' 'explore morph' 'explore (I)' 'explore context (C)' 'explore receiver (I)' 'references finder' 'weight explorer' 'explore CompiledMethod') -> #exploreIcon; - add: #('find...(f)' 'find class... (f)' 'find method...' 'find recent submissions' 'show hierarchy' 'show definition' 'show comment' 'filter' 'filter message list...' 'find context... (f)') -> #findIcon; - add: #('add item...' 'new category...' 'create new change set...' 'new change set... (n)' 'add new file') -> #newIcon; - add: #('remove method (x)' 'remove' 'remove class (x)' 'remove method from system (x)' 'remove class from system (x)' 'remove postscript''stop StackSizeWatcher' ) -> #deleteIcon; - add: #('delete method from changeset (d)' 'delete class from change set (d)' 'destroy change set (X)' 'revert & remove from changes' 'delete unchanged windows' 'delete non windows' 'delete both of the above' 'reset variables' 'remove contained in class categories...' 'clear this change set' 'uninstall this change set' 'delete directory...' 'delete' 'start StackSizeWatcher') -> #warningIcon; - add: #('do again (j)' 'Redo - multiple (Z)') -> #redoIcon; - add: #('undo (z)' 'revert to previous version' 'Undo - multiple (z)') -> #undoIcon; - add: #('copy to clipboard (c)' 'copy (c)' 'copy class...' 'copy class chgs to other side' 'copy method to other side' 'copy all to other side (c)' 'copy name to clipboard' 'copy selector to clipboard') -> #copyIcon; - add: #('paste (v)' 'Paste without Format') -> #pasteIcon; - add: #('cut (x)' 'move class chgs to other side' 'move method to other side' 'submerge into other side') -> #cutIcon; - add: #('paste...' 'icons...') -> #worldIcon -! ! -!Theme class methodsFor: 'icons by menu' stamp: 'HAW 4/14/2018 19:42:09'! - addMiscellaneousIconsTo: aCollectorCollection - - aCollectorCollection - add: #('restore display (r)' 'set display depth...' 'move windows onscreen' 'Utilities saveDisplay.') -> #displayIcon; - add: #('changes...' 'dual change sorter' 'change sets with this method' 'find a change sorter' 'recent changes in file' 'Undo / Redo history' 'code file contents' 'package file contents') -> #changesIcon; - add: #('Install New Updates' 'update' 'turn on auto-update (a)' 'update list (u)' 'install code' 'fileIn entire file' 'install package') -> #updateIcon; - add: #('find again (g)' 'full stack (k)') -> #systemIcon; - add: #('print it (p)' 'check change set for slips') -> #printIcon; - add: #('accept (s)' 'make changes go to me (m)') -> #acceptIcon; - add: #('cancel (l)' 'turn off auto-update (a)' 'stop StackSizeWatcher') -> #cancelIcon; - add: #('debug...' 'Debug it (D)' 'toggle break on entry') -> #debugIcon; - add: #('close' 'close all debuggers' 'close top window') -> #closeIcon; - add: #('collapse' 'hide taskbar' 'collapse all windows') -> #collapseIcon; - add: #('expand / contract' 'show taskbar' 'restore all windows') -> #expandIcon; - add: #('menu') -> #windowMenuIcon; - add: #('browse all' 'browser' 'browse it (b)' 'MessageTally UI and browse' 'browse recent submissions' 'browse full (b)' 'find changed browsers...' 'browse (b)' 'browse my changes') -> #editFindReplaceIcon; - add: #('workspace' 'workspace with contents') -> #terminalIcon; - add: #('styled text editor' 'text editor' 'basic text editor' 'unicode editor' 'edit this list' 'edit postscript...' 'add postscript...') -> #textEditorIcon; - add: #('file list' 'find a fileList' 'compress file') -> #systemFileManagerIcon; - add: #('transcript' 'find a transcript' 'Transcript clear.' 'log to transcript') -> #printerIcon; - add: #('process browser' 'vm statistics' 'MessageTally all Processes') -> #systemMonitorIcon; - add: #('emergency evaluator' 'conflicts with other change sets' 'check for slips' 'conflicts with change set opposite' 'conflicts with category opposite') -> #emblemImportantIcon; - add: #('change sorter') -> #halfRefreshIcon; - add: #('SUnit Test Runner' 'Accept & Run Test in Class (t)' 'Accept & Run Test in Category (y)' 'Run tests (t)' 'Run tests' 'Run test (t)' 'Accept & Debug Test (r)' 'Debug test (r)') -> #weatherFewCloudsIcon; - add: #('Font Sizes...' 'system fonts...' 'set font... (k)') -> #preferencesDesktopFontIcon; - add: #('full screen on') -> #viewFullscreenIcon; - add: #('full screen off') -> #exitFullscreenIcon; - add: #('set desktop color...') -> #wallpaperIcon; - add: #('preferences...' 'All preferences...' 'what to show...' 'view as hex') -> #preferencesIcon; - add: #('Editor keyboard shortcuts') -> #keyboardShortcutsIcon; - add: #('world menu help') -> #globeIcon; "currently unused, but a neat icon" - add: #('useful expressions' 'class comments with it' 'check for uncommented methods' 'check for uncommented classes') -> #chatIcon; - add: #('set code author...' 'check for other authors' 'check for any other authors') -> #usersIcon; - add: #('space left') -> #removableMediaIcon; - add: #('start drawing all again' 'window color...') -> #graphicsIcon; - add: #('start stepping again') -> #mediaPlaybackStartIcon; - add: #('file out current change set' 'fileOut' 'File out and remove (o)' 'File out and keep (k)') -> #fileOutIcon; - add: #('recently logged changes...' 'versions (v)' 'recent classes... (r)' 'trim history' 'Profile it') -> #clockIcon; - add: #('senders of it (n)' 'senders of... (n)' 'local senders of...' 'senders (n)') -> #mailForwardIcon; - add: #('implementors of it (m)' 'implementors of... (m)' 'implementors of sent messages') -> #developmentIcon; - add: #('references to it (N)') -> #addressBookIcon; - add: #('class var refs...' 'class refs (N)' 'class variables' 'class vars' 'local implementors of...' 'subclass template') -> #classIcon; - add: #('inst var refs...' 'inst var defs...' 'sample instance') -> #instanceIcon; - add: #('Use Selection for Find (j)' 'rename class ...' 'rename...' 'change title...') -> #saveAsIcon; - add: #('smalltalk options' 'method source with it' 'browse method (O)' 'check for uncategorized methods') -> #scriptIcon; - add: #('method strings with it (E)' 'Toggle WordWrap') -> #genericTextIcon; - add: #('browse hierarchy (h)' 'move to top' 'promote to top of list') -> #goTopIcon; - add: #('move up' 'make next-to-topmost') -> #goUpIcon; - add: #('move to bottom' 'send to back' 'send top window to back') -> #goBottomIcon; - add: #('inheritance (i)' 'move down') -> #goDownIcon; - add: #('browse protocol (p)' 'spawn sub-protocol') -> #spreadsheetIcon; - add: #('spawn full protocol') -> #speadsheetTemplateIcon; - add: #('alphabetize') -> #fontXGenericIcon; - add: #('Installed Packages' 'browse' 'show category (C)' 'categorize all uncategorized' 'select change set...' 'view affected class categories') -> #packageIcon; - add: #('remove from current change set' 'remove empty categories' 'subtract other side (-)' 'remove from this browser') -> #listRemoveIcon; - add: #('add to current change set' 'add all meths to current chgs' 'add preamble (p)' 'More...') -> #listAddIcon; - add: #('toggle diffing (D)' 'toggle selections') -> #switchIcon; - add: #('reorganize' 'create inst var accessors' 'ChangeSorter reorderChangeSets.' 'reorder all change sets' 'by name' 'by size' 'by date') -> #sendReceiveIcon; - add: #('unsent methods' 'unreferenced class vars' 'unreferenced inst vars' 'Undeclared inspect.' 'Undeclared removeUnreferencedKeys; inspect.' 'ChangeSorter removeEmptyUnnamedChangeSets.' 'check for unsent messages') -> #junkIcon; - add: #('find changed windows...') -> #newWindowIcon; - add: #('make undraggable') -> #pushPinIcon; - add: #('Utilities saveScreenshot.') -> #stillCameraIcon; - add: #('add new directory') -> #newFolderIcon; - add: #('select all' 'deselect all') -> #selectAllIcon; - add: #('sort by date') -> #dateIcon; - add: #('justified') -> #formatJustifyFillIcon; - add: #('centered') -> #formatJustifyCenterIcon; - add: #('set alignment...' 'leftFlush') -> #formatJustifyLeftIcon; - add: #('rightFlush') -> #formatJustifyRightIcon; - add: #('signal Semaphore (S)') -> #haloHelpIcon; - add: #('Change Paragraph Style...' 'Change Character Style...' 'Remove Character Style' 'Replace all uses of Paragraph Style...' 'Replace all uses of Character Style...' 'Set Default Font...') -> #fontXGenericIcon; - add: #('Clear Font') -> #newIcon; - add: #('code file browser' 'package file browser') -> #findIcon. - ! ! -!Theme methodsFor: 'menus' stamp: 'HAW 4/12/2018 15:56:21' prior: 50390083! - basicIcons - - "Minimal menu scheme. - Theme current class beCurrent - " - - ^self iconsDefinitionFor: self basicIconsTypeSelector -! ! -!Theme methodsFor: 'menus' stamp: 'HAW 4/12/2018 16:00:06' prior: 50390172! - miscellaneousIcons - - ^self iconsDefinitionFor: self miscellaneousIconsTypeSelector -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3291-IconSpecEnhancements-HernanWilkinson-2018Apr12-13h37m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3285] on 14 April 2018 at 8:01:56 pm'! -!PluggableListMorphByItem methodsFor: 'model access' stamp: 'HAW 4/14/2018 19:27:47' prior: 50380217! - setSelectionIndex: anInteger - "Change the model's selected item to be the one at the given index." - - | item | - setIndexSelector ifNotNil: [ - item _ itemList at: anInteger ifAbsent: [ nil ]. - model perform: setIndexSelector with: item. - self update: getIndexSelector. - ^ true ]. - ^false - ! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3292-PluggableListMorphByItem-fix-HernanWilkinson-2018Apr14-19h50m-HAW.1.cs.st----! - -----SNAPSHOT----#(15 April 2018 7:34:27.338555 pm) Cuis5.0-3292-32.image priorSource: 1879917! - -----QUIT----#(15 April 2018 7:34:44.589203 pm) Cuis5.0-3292-32.image priorSource: 1904636! - -----STARTUP----#(18 April 2018 5:27:10.366836 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3292-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3292] on 18 April 2018 at 5:21:46 pm'! -!String class methodsFor: 'primitives' stamp: 'jmv 4/18/2018 17:21:32' prior: 16918032! - indexOfByte: anInteger inString: aString startingAt: start - - | stringSize | - - - self var: #aCharacter declareC: 'int anInteger'. - self var: #aString declareC: 'unsigned char *aString'. - - start > 0 ifFalse: [ ^ 0 ]. - stringSize _ aString size. - start to: stringSize do: [:pos | - (aString at: pos) asciiValue = anInteger ifTrue: [^ pos]]. - ^ 0 -! ! -!CompiledMethod class methodsFor: 'services' stamp: 'jmv 4/18/2018 17:19:33' prior: 16821574! - timeStamp: aStamp partsDo: aBlock - " - CompiledMethod>>#timeStampPartsDo: timeStampPartsDo: [ :authorInitials :dateAndTime | - ('*',authorInitials,'*') print. dateAndTime print ] - " - | stamp dateIndex aux dateAndTimePart | - stamp _ aStamp. - "Account for some unfortunately hacked stamps such as this: 'cwp 10/17/2007 23:29/eem 9/5/2009 11:10 - => :=' " - aux _ stamp lastIndexOf: $/. - aux _ stamp indexOf: $: startingAt: (aux max:1) ifAbsent: [ 0 ]. - aux > 0 ifTrue: [ - (aux > 0 and: [ aux + 2 ~= stamp size]) ifTrue: [ - stamp _ stamp copyFrom: 1 to: aux + 2 ]]. - - "Find start of date, if not possible, consider the whole stamp the author, and no date" - aux _ stamp - lastIndexOf: $/ - startingAt: stamp size - ifAbsent: [ ^ aBlock value: stamp value: nil ]. - aux _ stamp - lastIndexOf: $/ - startingAt: aux - ifAbsent: [ ^ aBlock value: stamp value: nil ]. - dateIndex _ stamp - lastIndexOf: $ - startingAt: aux - ifAbsent: [ ^ aBlock value: stamp value: nil ]. - "If only date, no time, add midnight time" - dateAndTimePart _ stamp copyFrom: dateIndex + 1 to: stamp size. - (dateAndTimePart indexOf: $:) = 0 ifTrue:[ - dateAndTimePart _ dateAndTimePart, ' 00:00' ]. - "Done" - ^aBlock - value: (stamp copyFrom: 1 to: dateIndex-1) - value: (DateAndTime fromString: dateAndTimePart)! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3293-PackageLoadHang-fix-JuanVuletich-2018Apr18-17h20m-jmv.1.cs.st----! - -----SNAPSHOT----#(18 April 2018 5:27:16.526989 pm) Cuis5.0-3293-32.image priorSource: 1904732! - -----QUIT----#(18 April 2018 5:27:27.668295 pm) Cuis5.0-3293-32.image priorSource: 1907083! - -----STARTUP----#(25 May 2018 2:09:24.009922 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3293-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3293] on 21 April 2018 at 4:54:48 pm'! - -CodeWindow subclass: #DebuggerWindow - instanceVariableNames: 'receiverInspector codePane receiverInspectorText stackList contextVariableInspector contextVariableInspectorText ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Tools'! - -!classDefinition: #DebuggerWindow category: #'Morphic-Tools'! -CodeWindow subclass: #DebuggerWindow - instanceVariableNames: 'receiverInspector codePane receiverInspectorText stackList contextVariableInspector contextVariableInspectorText' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Tools'! -!SystemWindow methodsFor: 'user interface' stamp: 'HAW 4/21/2018 16:46:39'! - canDiscardEditsOf: aMorphWithChanges - - | okToLooseChanges | - - aMorphWithChanges canDiscardEdits ifTrue: [ ^true ]. - - okToLooseChanges _ self isItOkToLooseChanges. - okToLooseChanges ifTrue: [ aMorphWithChanges disregardUnacceptedEdits ]. - - ^okToLooseChanges - - ! ! -!SystemWindow methodsFor: 'user interface' stamp: 'HAW 4/21/2018 16:03:28'! - isItOkToLooseChanges - - ^ self confirm: -'Changes have not been saved. -Is it OK to cancel those changes?'.! ! -!SystemWindow methodsFor: 'user interface' stamp: 'HAW 4/21/2018 12:09:13'! - okToChangeDueTo: aMorph - - ^self okToChange! ! -!DebuggerWindow methodsFor: 'GUI building' stamp: 'HAW 4/21/2018 12:11:38'! - buildMorphicCodePane - - codePane _ super buildMorphicCodePane. - ^codePane! ! -!DebuggerWindow methodsFor: 'user interface' stamp: 'HAW 4/21/2018 16:47:36'! - okToChangeCodePane - - | okToLooseChanges | - - okToLooseChanges _ self canDiscardEditsOf: codePane. - okToLooseChanges ifTrue: [ - receiverInspectorText disregardUnacceptedEdits. - contextVariableInspectorText disregardUnacceptedEdits ]. - - ^okToLooseChanges ! ! -!DebuggerWindow methodsFor: 'user interface' stamp: 'HAW 4/21/2018 16:47:50'! - okToChangeContextVariableInspectorText - - ^self canDiscardEditsOf: contextVariableInspectorText! ! -!DebuggerWindow methodsFor: 'user interface' stamp: 'HAW 4/21/2018 16:40:50'! - okToChangeDueTo: aMorph - - aMorph = stackList ifTrue: [ ^self okToChangeCodePane ]. - aMorph = receiverInspector ifTrue: [ ^self okToChangeReceiverInspectorText ]. - aMorph = contextVariableInspector ifTrue: [ ^self okToChangeContextVariableInspectorText ]. - - ^super okToChangeDueTo: aMorph - - - ! ! -!DebuggerWindow methodsFor: 'user interface' stamp: 'HAW 4/21/2018 16:47:56'! - okToChangeReceiverInspectorText - - ^self canDiscardEditsOf: receiverInspectorText! ! -!PluggableListMorph methodsFor: 'events' stamp: 'HAW 4/21/2018 12:09:58' prior: 50380385! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - "The mouse came up within the list; take appropriate action" - - | row | - row _ self rowAtLocation: localEventPosition. - self owningWindow ifNotNil: [ :w | - (w okToChangeDueTo: self) ifFalse: [ ^ self ]]. - (autoDeselect == false and: [row = 0 ]) ifTrue: [ ^ self ]. "work-around the no-mans-land bug" - "No change if model is locked" - (autoDeselect and: [ row == self visualSelectionIndex ]) - ifTrue: [ - aMouseButtonEvent mouseButton1Changed ifTrue: [ - self setSelectionIndex: 0 ]] - ifFalse: [ self setSelectionIndex: row ]! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'HAW 4/21/2018 12:09:32' prior: 50380407! - arrowKey: aChar - "Process the up and down arrows in a list pane. Note that the listView tells us what index variable, how to get the list, and how to move the index." - | keyEvent oldSelection nextSelection max min howMany answer w | - answer _ false. - keyEvent _ aChar numericValue. - oldSelection _ self getCurrentSelectionIndex. - nextSelection _ oldSelection. - max _ self maximumSelection. - min _ self minimumSelection. - howMany _ self numSelectionsInView. "get this exactly??" - - keyEvent = 31 ifTrue: [ - "down-arrow; move down one, wrapping to top if needed" - nextSelection _ oldSelection + 1. - nextSelection > max ifTrue: [ nextSelection _ 1 ]]. - - keyEvent = 30 ifTrue: [ - "up arrow; move up one, wrapping to bottom if needed" - nextSelection _ oldSelection - 1. - nextSelection < 1 ifTrue: [ nextSelection _ max ]]. - - keyEvent = 1 ifTrue: [ nextSelection _ 1 ]. "home" - keyEvent = 4 ifTrue: [ nextSelection _ max ]. "end" - keyEvent = 11 ifTrue: [ nextSelection _ min max: oldSelection - howMany ]. "page up" - keyEvent = 12 ifTrue: [ nextSelection _ oldSelection + howMany min: max ]. "page down" - nextSelection = oldSelection ifFalse: [ - w _ self owningWindow. - (w isNil or: [ w okToChangeDueTo: self ]) ifTrue: [ "No change if model is locked" - - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self listMorph highlightedRow: nextSelection. - - "Update the model in next world cycle, so user gets the immediate feedback." - UISupervisor whenUIinSafeState: [ - self setSelectionIndex: nextSelection ]. - answer _ true ]]. - ^answer! ! -!PluggableListMorph methodsFor: 'model access' stamp: 'HAW 4/21/2018 12:09:49' prior: 50380471! - keyboardSearch: aChar - | oldSelection nextSelection max milliSeconds nextSelectionList nextSelectionText | - nextSelection _ oldSelection _ self getCurrentSelectionIndex. - max _ self maximumSelection. - milliSeconds _ Time localMillisecondClock. - milliSeconds - lastKeystrokeTime > 300 ifTrue: ["just use the one current character for selecting" - lastKeystrokes _ '']. - lastKeystrokes _ lastKeystrokes , aChar asLowercase asString. - lastKeystrokeTime _ milliSeconds. - nextSelectionList _ OrderedCollection newFrom: (list copyFrom: oldSelection + 1 to: max). - nextSelectionList addAll: (list copyFrom: 1 to: oldSelection). - "Get rid of blanks and style used in some lists" - nextSelectionText _ nextSelectionList detect: [:a | a asString withBlanksTrimmed asLowercase beginsWith: lastKeystrokes] - ifNone: [^ self flash"match not found"]. - self owningWindow ifNotNil: [ :w | - (w okToChangeDueTo: self) ifFalse: [^ self]]. - nextSelection _ list findFirst: [:a | a == nextSelectionText]. - "No change if model is locked" - oldSelection == nextSelection ifTrue: [^ self flash]. - ^ self setSelectionIndex: nextSelection! ! -!SystemWindow methodsFor: 'user interface' stamp: 'HAW 4/21/2018 16:46:56' prior: 16926859! - okToChange - - ^self canDiscardEditsOf: self! ! -!DebuggerWindow methodsFor: 'GUI building' stamp: 'HAW 4/21/2018 12:08:29' prior: 50334338! - buildMorphicWindow - "Open a full morphic debugger with the given label" - - | bottomMorph | - - stackList _ PluggableListMorph - model: model - listGetter: #contextStackList - indexGetter: #contextStackIndex - indexSetter: #toggleContextStackIndex: - mainView: self - menuGetter: #contextStackMenu - keystrokeAction: #contextStackKey:from:. - - receiverInspector _ PluggableListMorph - model: model receiverInspector - listGetter: #fieldList - indexGetter: #selectionIndex - indexSetter: #toggleIndex: - mainView: self - menuGetter: #receiverFieldListMenu - keystrokeAction: #inspectorKey:from:. - receiverInspector doubleClickSelector: #inspectSelection. - receiverInspectorText _ TextModelMorph - textProvider: model receiverInspector - textGetter: #acceptedContents - textSetter: #accept: - selectionGetter: #contentsSelection. - contextVariableInspector _ PluggableListMorph - model: model contextVariablesInspector - listGetter: #fieldList - indexGetter: #selectionIndex - indexSetter: #toggleIndex: - mainView: self - menuGetter: #contextFieldListMenu - keystrokeAction: #inspectorKey:from:. - contextVariableInspector doubleClickSelector: #inspectSelection. - contextVariableInspectorText _ TextModelMorph - textProvider: model contextVariablesInspector - textGetter: #acceptedContents - textSetter: #accept: - selectionGetter: #contentsSelection. - - bottomMorph _ LayoutMorph newRow. - bottomMorph - addMorph: receiverInspector proportionalWidth: 0.2; - addAdjusterAndMorph: receiverInspectorText proportionalWidth: 0.3; - addAdjusterAndMorph: contextVariableInspector proportionalWidth: 0.2; - addAdjusterAndMorph: contextVariableInspectorText proportionalWidth: 0.3. - - self layoutMorph - addMorph: stackList proportionalHeight: 0.25; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.55; - addAdjusterAndMorph: bottomMorph proportionalHeight: 0.2! ! - -DebuggerWindow removeSelector: #canDiscardEditsFrom:! - -DebuggerWindow removeSelector: #canDiscardEditsFrom:disregarding:! - -DebuggerWindow removeSelector: #okToChangeStackList! - -SystemWindow removeSelector: #askShouldSaveChanges! - -CodeWindow subclass: #DebuggerWindow - instanceVariableNames: 'stackList receiverInspector receiverInspectorText contextVariableInspector contextVariableInspectorText codePane' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Tools'! - -!classDefinition: #DebuggerWindow category: #'Morphic-Tools'! -CodeWindow subclass: #DebuggerWindow - instanceVariableNames: 'stackList receiverInspector receiverInspectorText contextVariableInspector contextVariableInspectorText codePane' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Tools'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3294-DebuggerEnhancements-HernanWilkinson-2018Apr21-12h07m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3293] on 22 April 2018 at 5:32:30 pm'! -!DebuggerWindow methodsFor: 'user interface' stamp: 'HAW 4/21/2018 20:43:49'! - ifOkToChangeCodePaneDo: aBlock - - ^self okToChangeCodePane ifTrue: aBlock -! ! -!DebuggerWindow methodsFor: 'context stack menu' stamp: 'HAW 4/22/2018 17:30:34'! -createMethod - - ^ self ifOkToChangeCodePaneDo: [ model createMethod ]! ! -!DebuggerWindow methodsFor: 'context stack menu' stamp: 'HAW 4/21/2018 20:44:10'! - doStep - - ^ self ifOkToChangeCodePaneDo: [ model doStep ]! ! -!DebuggerWindow methodsFor: 'context stack menu' stamp: 'HAW 4/21/2018 20:45:19'! - fullStack - - ^ self ifOkToChangeCodePaneDo: [ model fullStack ]! ! -!DebuggerWindow methodsFor: 'context stack menu' stamp: 'HAW 4/21/2018 20:45:26'! - proceed - - ^ self ifOkToChangeCodePaneDo: [ model proceed ]! ! -!DebuggerWindow methodsFor: 'context stack menu' stamp: 'HAW 4/21/2018 20:45:36'! - restart - - ^ self ifOkToChangeCodePaneDo: [ model restart ]! ! -!DebuggerWindow methodsFor: 'context stack menu' stamp: 'HAW 4/22/2018 17:31:44'! - send - - ^ self ifOkToChangeCodePaneDo: [ model send ]! ! -!DebuggerWindow methodsFor: 'context stack menu' stamp: 'HAW 4/21/2018 20:45:56'! - stepIntoBlock - - ^ self ifOkToChangeCodePaneDo: [ model stepIntoBlock ]! ! -!DebuggerWindow methodsFor: 'context stack menu' stamp: 'HAW 4/21/2018 20:46:06'! - where - - ^ self ifOkToChangeCodePaneDo: [ model where ]! ! -!DebuggerWindow methodsFor: 'GUI building' stamp: 'HAW 4/21/2018 20:41:02' prior: 16831080! - customButtonRow - "Answer a button pane affording the user one-touch access to certain functions; the pane is given the formal name 'customButtonPane' by which it can be retrieved by code wishing to send messages to widgets residing on the pane" - - | button buttons row buttonColor | - - buttons _ OrderedCollection new. - buttonColor _ self buttonColor. - "button with target = self" - button _ PluggableButtonMorph - model: self - stateGetter: nil - action: #proceed. - button color: buttonColor. - button label: 'Proceed'. - button setBalloonText: 'close the debugger and proceed.'. - buttons add: button. - "buttons with model target" - self customButtonSpecs do: [ :tuple | - button _ PluggableButtonMorph - model: self - stateGetter: nil - action: tuple second. - button color: buttonColor. - button label: tuple first asString. - tuple size > 2 ifTrue: [button setBalloonText: tuple third]. - buttons add: button]. - - row _ LayoutMorph newRow. - row doAdoptWidgetsColor. - row color: buttonColor. - row addMorphs: buttons. - ^row! ! -!DebuggerWindow methodsFor: 'menu building' stamp: 'HAW 4/21/2018 20:39:59' prior: 16831155! - contextStackMenu - "Set up the menu appropriately for the context-stack-list, either shifted or unshifted as per the parameter provided" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addList: #( - ('fullStack (f)' fullStack ) - ('restart (r)' restarl) - ('proceed (p)' proceed) - ('step (t)' doStep) - ('step through (T)' stepIntoBlock) - ('send (e)' send) - ('where (w)' where) - ('peel to first like this' peelToFirst) - - - ('return entered value' returnValue) - ('toggle break on entry' toggleBreakOnEntry '' model) - ). - ^aMenu! ! -!DebuggerWindow methodsFor: 'keyboard shortcuts' stamp: 'HAW 4/21/2018 20:38:49' prior: 16831264! - contextStackKey: aChar from: view - "Respond to a keystroke in the context list" - - aChar == $e ifTrue: [^ self send]. - aChar == $t ifTrue: [^ self doStep]. - aChar == $T ifTrue: [^ self stepIntoBlock]. - aChar == $p ifTrue: [^ self proceed]. - aChar == $r ifTrue: [^ self restart]. - aChar == $f ifTrue: [^ self fullStack]. - aChar == $w ifTrue: [^ self where]. - - ^ self messageListKey: aChar from: view! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3295-DebuggerEnhancements-HernanWilkinson-2018Apr21-16h54m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3295] on 26 April 2018 at 1:38:13 pm'! -!Object methodsFor: 'evaluating' stamp: 'jmv 4/26/2018 13:11:27'! - valueWithPossibleArgument: anArg - - ^self! ! -!Collection methodsFor: 'enumerating' stamp: 'jmv 4/26/2018 13:33:07'! - collect: aBlock andFold: aTwoArgBlock ifEmpty: emptyBlockOrValue - "Evaluate the block with the first two elements of the receiver, - then with the result of the first evaluation and the next element, - and so on. Answer the result of the final evaluation. If the receiver - is empty, raise an error. If the receiver has a single element, answer - that element." - " - #('if' 'it' 'is' 'to' 'be' 'it' 'is' 'up' 'to' 'me') collect: [ :each | each ] andFold: [:a :b | a, ' ', b] ifEmpty:nil - #('if' 'it' 'is' 'to' 'be' 'it' 'is' 'up' 'to' 'me') collect: [ :each | each size] andFold: [:a :b | a + b] ifEmpty: nil - #() collect: [ :each | each ] andFold: [:a :b | a, ' ', b] ifEmpty:nil - " - - | first eachValue answer | - first _ true. - self do: [ :each | - eachValue _ aBlock value: each. - first - ifTrue: [ - first _ false. - answer _ eachValue ] - ifFalse: [ - answer _ aTwoArgBlock - value: answer - value: eachValue ]]. - first ifTrue: [ answer _ emptyBlockOrValue valueWithPossibleArgument: self ]. - ^ answer! ! -!Collection methodsFor: 'enumerating' stamp: 'jmv 4/26/2018 13:17:08'! - fold: aTwoArgBlock ifEmpty: emptyBlockOrValue - "Evaluate the block with the first two elements of the receiver, - then with the result of the first evaluation and the next element, - and so on. Answer the result of the final evaluation. If the receiver - is empty, raise an error. If the receiver has a single element, answer - that element." - " - #('if' 'it' 'is' 'to' 'be' 'it' 'is' 'up' 'to' 'me') fold: [:a :b | a, ' ', b] ifEmpty: [ :coll | coll errorEmptyCollection ] - #() fold: [:a :b | a, ' ', b] ifEmpty: [ :coll | coll errorEmptyCollection ] - #() fold: [:a :b | a, ' ', b] ifEmpty: 7 - " - - ^self - collect: [ :each | each ] - andFold: aTwoArgBlock - ifEmpty: emptyBlockOrValue! ! -!Collection methodsFor: 'statistics' stamp: 'jmv 4/26/2018 13:30:54'! - sum: aBlock ifEmpty: emptyBlockOrValue - "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." - ^self collect: aBlock andFold: [ :a :b | a + b ] ifEmpty: emptyBlockOrValue! ! -!Collection methodsFor: 'enumerating' stamp: 'jmv 4/26/2018 13:16:40' prior: 16814204! - collect: aBlock andFold: aTwoArgBlock - "Evaluate the block with the first two elements of the receiver, - then with the result of the first evaluation and the next element, - and so on. Answer the result of the final evaluation. If the receiver - is empty, raise an error. If the receiver has a single element, answer - that element." - " - #('if' 'it' 'is' 'to' 'be' 'it' 'is' 'up' 'to' 'me') collect: [ :each | each ] andFold: [:a :b | a, ' ', b] - #('if' 'it' 'is' 'to' 'be' 'it' 'is' 'up' 'to' 'me') collect: [ :each | each size] andFold: [:a :b | a + b] - " - - ^ self - collect: aBlock - andFold: aTwoArgBlock - ifEmpty: [ self errorEmptyCollection ]! ! -!Collection methodsFor: 'enumerating' stamp: 'jmv 4/26/2018 13:16:51' prior: 16814381! - fold: aTwoArgBlock - "Evaluate the block with the first two elements of the receiver, - then with the result of the first evaluation and the next element, - and so on. Answer the result of the final evaluation. If the receiver - is empty, raise an error. If the receiver has a single element, answer - that element." - " - #('if' 'it' 'is' 'to' 'be' 'it' 'is' 'up' 'to' 'me') fold: [:a :b | a, ' ', b] - " - - ^self - collect: [ :each | each ] - andFold: aTwoArgBlock - ifEmpty: [ self errorEmptyCollection ]! ! -!Collection methodsFor: 'enumerating' stamp: 'jmv 4/26/2018 13:22:28' prior: 16814447! - reduce: aTwoArgBlock - "Apply the argument, binaryBlock cumulatively to the elements of the receiver. - For sequenceable collections the elements will be used in order, for unordered - collections the order is unspecified." - - ^self fold: aTwoArgBlock! ! -!Collection methodsFor: 'statistics' stamp: 'jmv 4/26/2018 13:27:14' prior: 16815012! - product - "Compute the product of all the elements in the receiver" - - ^self fold: [ :a :b | a * b] ifEmpty: 1! ! -!Collection methodsFor: 'statistics' stamp: 'jmv 4/26/2018 13:30:08' prior: 16815065! - sum - "Compute the sum of all the elements in the receiver" - - ^self fold: [ :a :b | a + b]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3296-sum_ifEmpty-foldProtocolTweaks-JuanVuletich-2018Apr26-13h36m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3296] on 2 May 2018 at 6:33:04 pm'! -!Scanner methodsFor: 'multi-character scans' stamp: 'jmv 5/2/2018 18:28:52' prior: 50382955! - xBacktick - "Smalltalk code evaluated at compile time as a literal." - - self step. - buffer reset. - [hereChar == $` - and: [aheadChar == $` - ifTrue: [self step. false] - ifFalse: [true]]] - whileFalse: [ - buffer nextPut: self step. - (hereChar = Scanner doItCharacterValue asCharacter and: [source atEnd]) - ifTrue: [^self offEnd: 'Unmatched back quote']]. - self step. - [ | compiler method methodNode | - compiler _ Compiler new. - methodNode _ compiler compileNoPattern: buffer contents in: UndefinedObject context: nil notifying: nil ifFail: []. - method _ methodNode generate. - "Grab all messages sent while evaluating literal, so the main method will be shown as senders of them" - sentInLiterals addAll: method messages. - method literalsDo: [ :literal | literal isSymbol ifTrue: [ sentInLiterals add: literal ]]. - "Evaluate now." - token _ nil withArgs: #() executeMethod: method. - ] - on: SyntaxErrorNotification, UndeclaredVariableReference, Error - do: [ :ex | - ex class caseOf: { - [ SyntaxErrorNotification ] -> [ - self notify: 'Can not compile: ', ex errorMessage at: mark]. - [ UndeclaredVariableReference ] -> [ - self notify: 'Can not compile: Variable ''', ex varName, ''' is not declared' at: mark ] - } otherwise: [ - self notify: 'Can not evaluate code: ', ex description at: mark ]]. - tokenType _ #literal! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3297-FixSendersInComplexLiterals-JuanVuletich-2018May02-18h31m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3296] on 30 April 2018 at 8:28:45 pm'! -!Preferences class methodsFor: 'menu icons' stamp: 'jmv 4/30/2018 20:13:31'! - useMenuIcons - - self setPreference: #wantsMenuIcons toValue: true! ! -!Preferences class methodsFor: 'menu icons' stamp: 'jmv 4/30/2018 20:13:34'! - useNoMenuIcons - - self setPreference: #wantsMenuIcons toValue: false! ! -!Preferences class methodsFor: 'menu icons' stamp: 'jmv 4/30/2018 20:13:53'! - wantsMenuIcons - ^ self - valueOfFlag: #wantsMenuIcons - ifAbsent: [ true ]! ! -!SystemDictionary methodsFor: 'shrinking' stamp: 'jmv 4/30/2018 20:26:39' prior: 50378982! - reduceCuis - " - Smalltalk reduceCuis - " - | keep n unused newDicts oldDicts | - - self nominallyUnsent: #reduceCuis. - - "Remove icons" - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - PasteUpMorph allInstancesDo: [ :w | - w backgroundImageData: nil. - w submorphsDo: [ :a | a delete ]]. - Preferences useNoMenuIcons. - Theme current initialize. - Theme content: nil. - Color shutDown. - BitBltCanvas releaseClassCachedState. - - Transcript clear. - Clipboard default initialize. - - - "Remove some methods, even if they have senders." - Utilities removeSelector: #vmStatisticsReportString. - SystemDictionary removeSelector: #recreateSpecialObjectsArray. - - StrikeFont removeMostFonts. - StrikeFont saveSpace. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - - keep := OrderedCollection new. - keep addAll: #(SpaceTally). - AppLauncher appGlobalName ifNotNil: [ :any | - keep add: any ]. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - [ - #hereWeGo print. - unused do: [:c | - c print. - (Smalltalk at: c) removeFromSystem]. - n := Smalltalk removeAllUnSentMessages. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - n > 0 or: [ - unused notEmpty ]] whileTrue. - ChangeSet zapAllChangeSets. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - Symbol rehash. - - "Shrink method dictionaries." - Smalltalk garbageCollect. - oldDicts _ MethodDictionary allInstances. - newDicts _ Array new: oldDicts size. - oldDicts withIndexDo: [:d :index | - newDicts at: index put: d rehashWithoutBecome ]. - oldDicts elementsExchangeIdentityWith: newDicts. - oldDicts _ newDicts _ nil. - - SmalltalkCompleter initialize . - - "Sanity checks" -" Undeclared - Smalltalk cleanOutUndeclared - Smalltalk browseUndeclaredReferences - Smalltalk obsoleteClasses - Smalltalk obsoleteBehaviors - Smalltalk browseObsoleteMethodReferences - SmalltalkImage current fixObsoleteReferences - Smalltalk browseAllUnimplementedCalls"! ! -!Preferences class methodsFor: 'themes' stamp: 'jmv 4/30/2018 20:22:36' prior: 16893781! - cuisDefaults - " - Preferences cuisDefaults - " - self setPreferencesFrom: - - #( - (balloonHelpEnabled true) - (browseWithPrettyPrint false) - (caseSensitiveFinds false) - (checkForSlips true) - (cmdDotEnabled true) - (diffsInChangeList true) - (diffsWithPrettyPrint false) - (menuKeyboardControl true) - (optionalButtons true) - (extraDebuggerButtons true) - (subPixelRenderFonts true) - (thoroughSenders true) - (cheapWindowReframe false) - (syntaxHighlightingAsYouType true) - (tapAndHoldEmulatesButton2 true) - (clickGrabsMorphs false) - - (syntaxHighlightingAsYouTypeAnsiAssignment false) - (syntaxHighlightingAsYouTypeLeftArrowAssignment false) - ). - self useMenuIcons - ". - Theme beCurrent. - Taskbar showTaskbar - "! ! -!Preferences class methodsFor: 'themes' stamp: 'jmv 4/30/2018 20:24:54' prior: 16893825! - slowMachine - " - Preferences slowMachine - " - self setPreferencesFrom: #( - (balloonHelpEnabled false) - (browseWithPrettyPrint false) - (caseSensitiveFinds true) - (checkForSlips false) - (cmdDotEnabled true) - (diffsInChangeList true) - (diffsWithPrettyPrint false) - (menuKeyboardControl false) - (optionalButtons false) - (subPixelRenderFonts true) - (thoroughSenders true) - (cheapWindowReframe true) - (syntaxHighlightingAsYouType false) - (tapAndHoldEmulatesButton2 false) - (clickGrabsMorphs true) - ). - self useNoMenuIcons. - self runningWorld backgroundImageData: nil. - " - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - Taskbar hideTaskbar - "! ! -!Preferences class methodsFor: 'themes' stamp: 'jmv 4/30/2018 20:24:56' prior: 16893849! - smalltalk80 - "A traditional monochrome Smalltalk-80 look and feel, clean and austere, and lacking many features added to Squeak and Cuis in recent years. Caution: turns off the 'smartUpdating' feature that keeps multiple browsers in synch, and much more. - - Preferences smalltalk80 - " - - self setPreferencesFrom: - - #( - (balloonHelpEnabled false) - (browseWithPrettyPrint false) - (caseSensitiveFinds true) - (checkForSlips false) - (cmdDotEnabled true) - (diffsInChangeList false) - (diffsWithPrettyPrint false) - (menuKeyboardControl false) - (optionalButtons false) - (subPixelRenderFonts true) - (thoroughSenders false) - (cheapWindowReframe true) - (syntaxHighlightingAsYouType false) - (tapAndHoldEmulatesButton2 false) - (clickGrabsMorphs true) - ). - self useNoMenuIcons. - " - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - Taskbar hideTaskbar - "! ! -!Theme methodsFor: 'menus' stamp: 'jmv 4/30/2018 20:06:28' prior: 50391133! - basicIcons - - "Minimal menu scheme. - Theme current class beCurrent - " - - ^self iconsDefinitionFor: #addBasicIconsTo:! ! -!Theme methodsFor: 'menus' stamp: 'jmv 4/30/2018 20:17:26' prior: 16936052! - menuDecorations - - "build a dictionary wordings -> icon to decorate the menus all over the image" - - ^Preferences wantsMenuIcons - ifTrue: [ self allIcons ] - ifFalse: [#() ]! ! -!Theme methodsFor: 'menus' stamp: 'jmv 4/30/2018 20:06:14' prior: 50391140! - miscellaneousIcons - - ^self iconsDefinitionFor: #addMiscellaneousIconsTo:! ! -!Theme class methodsFor: 'user interface' stamp: 'jmv 4/30/2018 20:22:02' prior: 16936913! - changeIcons - - | menu selector | - - menu _ SelectionMenu - fromArray: #( - #( 'Use icons for menu entries' #useMenuIcons ) - #( 'Don''t use icons for menu entries' #useNoMenuIcons ) - ). - - selector _ menu startUpWithCaption: 'Menu Icons'. - - selector ifNotNil: [ - Preferences perform: selector. - Theme current class beCurrent ] -! ! - -Theme removeSelector: #basicIconsTypeSelector! - -Theme removeSelector: #basicIconsTypeSelector! - -Theme removeSelector: #miscellaneousIconsTypeSelector! - -Theme removeSelector: #miscellaneousIconsTypeSelector! - -Theme removeSelector: #noIcons! - -Theme removeSelector: #noIcons! - -Preferences class removeSelector: #menuIcons! - -Preferences class removeSelector: #menuIcons! - -Preferences class removeSelector: #useAllIcons! - -Preferences class removeSelector: #useAllIcons! - -Preferences class removeSelector: #useBasicIcons! - -Preferences class removeSelector: #useBasicIcons! - -Preferences class removeSelector: #useNoIcons! - -Preferences class removeSelector: #useNoIcons! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3298-BigMenuRefactor-p1-JuanVuletich-2018Apr30-19h58m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3296] on 1 May 2018 at 1:15:46 am'! - -StringMorph subclass: #MenuItemMorph - instanceVariableNames: 'isEnabled subMenu isSelected target selector arguments icon contentString ' - classVariableNames: 'SubMenuMarker ' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #MenuItemMorph category: #'Morphic-Menus'! -StringMorph subclass: #MenuItemMorph - instanceVariableNames: 'isEnabled subMenu isSelected target selector arguments icon contentString' - classVariableNames: 'SubMenuMarker' - poolDictionaries: '' - category: 'Morphic-Menus'! -!MenuItemMorph methodsFor: 'accessing' stamp: 'jmv 5/1/2018 01:15:02' prior: 50385219! - contents: aString withMarkers: aBool inverse: inverse - "Set the menu item entry. If aBool is true, parse aString for embedded markers." - - | markerIndex marker | - contentString _ nil. "get rid of old" - aBool ifFalse: [^super contents: aString]. - self removeAllMorphs. "get rid of old markers if updating" - self hasIcon ifTrue: [ self icon: nil ]. - (aString notEmpty and: [aString first = $<]) - ifFalse: [^super contents: aString]. - markerIndex := aString indexOf: $>. - markerIndex = 0 ifTrue: [^super contents: aString]. - marker := (aString copyFrom: 1 to: markerIndex) asLowercase. - (#('' '' '' '') includes: marker) - ifFalse: [^super contents: aString]. - contentString _ aString. "remember actual string" - marker := (marker = '' or: [marker = '']) ~= inverse - ifTrue: [self onImage] - ifFalse: [self offImage]. - super contents: (aString copyFrom: markerIndex + 1 to: aString size). - "And set the marker" - marker := ImageMorph new image: marker. - self addMorphFront: marker position: `0@2`! ! -!MenuItemMorph methodsFor: 'events' stamp: 'jmv 5/1/2018 01:14:28' prior: 16865998! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - "Handle a mouse up event. Menu items get activated when the mouse is over them. Do nothing if we're not in a 'valid menu transition', meaning that the current hand focus must be aimed at the owning menu." - owner hasMouseFocus ifFalse: [ ^self ]. - "This will happen if the menu has toggles in it. (for instance, the 'show...' button) - Update the look, refresh the world and wait a bit, - to give the user some visual feedback" - contentString ifNotNil: [ - self contents: contentString withMarkers: true inverse: true. - self refreshWorld. - (Delay forMilliseconds: 200) wait]. - self deselect. - self invokeWithEvent: aMouseButtonEvent! ! -!UpdatingMenuItemMorph methodsFor: 'world' stamp: 'jmv 5/1/2018 01:14:34' prior: 16940489! - updateContents - "Update the receiver's contents" - - | newString enablement nArgs | - ((wordingProvider isNil) or: [wordingSelector isNil]) ifFalse: [ - nArgs _ wordingSelector numArgs. - newString _ nArgs = 0 - ifTrue: [ - wordingProvider perform: wordingSelector] - ifFalse: [ - (nArgs = 1 and: [wordingArgument notNil]) - ifTrue: [ - wordingProvider perform: wordingSelector with: wordingArgument] - ifFalse: [ - nArgs = arguments size ifTrue: [ - wordingProvider perform: wordingSelector withArguments: arguments]]]. - newString = (contentString ifNil: [ contents ]) - ifFalse: [ - self contents: newString. - Theme current decorateMenu: owner ]]. - enablementSelector ifNotNil: [ - (enablement _ self enablement) == isEnabled - ifFalse: [self isEnabled: enablement]]! ! - -MenuItemMorph removeSelector: #contentString! - -MenuItemMorph removeSelector: #contentString! - -MenuItemMorph removeSelector: #contentString:! - -MenuItemMorph removeSelector: #contentString:! - -StringMorph subclass: #MenuItemMorph - instanceVariableNames: 'isEnabled subMenu isSelected target selector arguments icon contentString' - classVariableNames: 'SubMenuMarker' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #MenuItemMorph category: #'Morphic-Menus'! -StringMorph subclass: #MenuItemMorph - instanceVariableNames: 'isEnabled subMenu isSelected target selector arguments icon contentString' - classVariableNames: 'SubMenuMarker' - poolDictionaries: '' - category: 'Morphic-Menus'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3299-BigMenuRefactor-p2-JuanVuletich-2018May01-01h11m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3296] on 1 May 2018 at 1:26:50 am'! -!MenuMorph methodsFor: 'accessing' stamp: 'jmv 5/1/2018 01:22:28'! - addBlankIconsIfNecessary - "If any of my items have an icon, ensure that all do by using anIcon for those that don't" - - | withIcons withoutIcons blankIcon | - withIcons _ Set new. - withoutIcons _ Set new. - self items do: [ :item | - item hasIcon | item hasMarker - ifTrue: [ withIcons add: item ] - ifFalse: [ withoutIcons add: item ]. - item hasSubMenu ifTrue: [ item subMenu addBlankIconsIfNecessary ]]. - (withIcons isEmpty or: [ withoutIcons isEmpty ]) ifTrue: [ ^self ]. - blankIcon _ Theme current blankIcon. - withoutIcons do: [ :item | item set_icon: blankIcon ].! ! -!MenuItemMorph methodsFor: 'accessing' stamp: 'jmv 5/1/2018 01:20:01'! - contentsWithMarkers: aString inverse: inverse - "Set the menu item entry. If aBool is true, parse aString for embedded markers." - - | markerIndex marker | - contentString _ nil. "get rid of old" - self removeAllMorphs. "get rid of old markers if updating" - icon _ nil. - (aString notEmpty and: [aString first = $<]) - ifFalse: [^super contents: aString]. - markerIndex := aString indexOf: $>. - markerIndex = 0 ifTrue: [^super contents: aString]. - marker := (aString copyFrom: 1 to: markerIndex) asLowercase. - (#('' '' '' '') includes: marker) - ifFalse: [^super contents: aString]. - contentString _ aString. "remember actual string" - marker := (marker = '' or: [marker = '']) ~= inverse - ifTrue: [self onImage] - ifFalse: [self offImage]. - super contents: (aString copyFrom: markerIndex + 1 to: aString size). - "And set the marker" - marker := ImageMorph new image: marker. - self addMorphFront: marker position: `0@2`! ! -!MenuItemMorph methodsFor: 'accessing' stamp: 'jmv 4/30/2018 20:54:05'! - set_icon: aForm - "change the the receiver's icon" - icon := aForm! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 4/30/2018 21:04:03' prior: 16866372! - add: aString subMenu: aMenuMorph - "Append the given submenu with the given label." - - | item | - item _ MenuItemMorph new. - item - contents: aString; - subMenu: aMenuMorph. - self addMorphBack: item! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 4/30/2018 21:04:08' prior: 16866410! - add: aString target: target selector: aSymbol argumentList: argList - "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument. Answer the appended menu item." - - | item | - item _ MenuItemMorph new - contents: aString; - target: target; - selector: aSymbol; - arguments: argList asArray. - self addMorphBack: item. - ^ item! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 4/30/2018 20:51:33' prior: 50384918! - popUpAt: aPoint forHand: hand allowKeyboard: aBoolean - "Present this menu at the given point under control of the given hand." - - | evt | - self items isEmpty ifTrue: [^self]. - Theme current decorateMenu: self. - self addBlankIconsIfNecessary. - (self submorphs select: [ :m | m is: #UpdatingMenuItemMorph ]) - do: [ :m | m updateContents]. - self runningWorld addMorphFront: self position: aPoint - `2 @ 8`. - self fitInWorld. - "Acquire focus for valid pop up behavior" - hand newMouseFocus: self. - aBoolean ifTrue: [ hand newKeyboardFocus: self ]. - evt _ hand lastMouseEvent. - (evt isKeyboard or: [ evt isMouse and: [ evt anyButtonPressed not ]]) - ifTrue: [ - "Select first item if button not down" - self moveSelectionDown: 1 event: evt ]! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 4/30/2018 20:51:37' prior: 50384943! - popUpAt: aPoint forHand: hand in: aWorld allowKeyboard: aBoolean - "Present this menu at the given point under control of the given hand." - - self items isEmpty ifTrue: [ ^self ]. - Theme current decorateMenu: self. - self addBlankIconsIfNecessary. - (self submorphs select: [ :m | m is: #UpdatingMenuItemMorph]) - do: [ :m | m updateContents]. - aWorld addMorphFront: self position: aPoint - `2 @ 8`. - self fitInWorld. - "Acquire focus for valid pop up behavior" - hand newMouseFocus: self. - aBoolean ifTrue: [ hand newKeyboardFocus: self ]! ! -!MenuItemMorph methodsFor: 'accessing' stamp: 'jmv 5/1/2018 01:19:11' prior: 16865789! - contents: aString - ^self contentsWithMarkers: aString inverse: false! ! -!MenuItemMorph methodsFor: 'events' stamp: 'jmv 5/1/2018 01:19:31' prior: 50392164! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - "Handle a mouse up event. Menu items get activated when the mouse is over them. Do nothing if we're not in a 'valid menu transition', meaning that the current hand focus must be aimed at the owning menu." - owner hasMouseFocus ifFalse: [ ^self ]. - "This will happen if the menu has toggles in it. (for instance, the 'show...' button) - Update the look, refresh the world and wait a bit, - to give the user some visual feedback" - contentString ifNotNil: [ - self contentsWithMarkers: contentString inverse: true. - self refreshWorld. - (Delay forMilliseconds: 200) wait]. - self deselect. - self invokeWithEvent: aMouseButtonEvent! ! -!UpdatingMenuItemMorph methodsFor: 'world' stamp: 'jmv 5/1/2018 01:24:02' prior: 50392189! - updateContents - "Update the receiver's contents" - - | newString enablement nArgs | - ((wordingProvider isNil) or: [wordingSelector isNil]) ifFalse: [ - nArgs _ wordingSelector numArgs. - newString _ nArgs = 0 - ifTrue: [ - wordingProvider perform: wordingSelector] - ifFalse: [ - (nArgs = 1 and: [wordingArgument notNil]) - ifTrue: [ - wordingProvider perform: wordingSelector with: wordingArgument] - ifFalse: [ - nArgs = arguments size ifTrue: [ - wordingProvider perform: wordingSelector withArguments: arguments]]]. - newString = (contentString ifNil: [ contents ]) - ifFalse: [ - self contents: newString ]]. - enablementSelector ifNotNil: [ - (enablement _ self enablement) == isEnabled - ifFalse: [self isEnabled: enablement]]! ! -!Theme methodsFor: 'accessing' stamp: 'jmv 4/30/2018 20:56:48' prior: 16936767! - decorateMenu: aMenu - - "decorate aMenu with icons" - - self flag: #todo. "Do I really belong on Theme, and not some menu class somewhere?" - - menuItemIcons ifEmpty: [ - ^ self ]. - - aMenu items do: [ :item | - | decoration | - decoration _ menuItemIcons - at: item contents asString asLowercase - ifAbsent: nil. - - decoration ifNotNil: [ - item set_icon: decoration ]]! ! - -MenuItemMorph removeSelector: #contents:withMarkers:! - -MenuItemMorph removeSelector: #contents:withMarkers:! - -MenuItemMorph removeSelector: #contents:withMarkers:inverse:! - -MenuItemMorph removeSelector: #contents:withMarkers:inverse:! - -MenuItemMorph removeSelector: #icon:! - -MenuItemMorph removeSelector: #icon:! - -MenuMorph removeSelector: #addBlankIconsIfNecessary:! - -MenuMorph removeSelector: #addBlankIconsIfNecessary:! - -MenuMorph removeSelector: #addWithLabel:enablement:action:! - -MenuMorph removeSelector: #addWithLabel:enablement:action:! - -MenuMorph removeSelector: #addWithLabel:enablementSelector:target:selector:argumentList:! - -MenuMorph removeSelector: #addWithLabel:enablementSelector:target:selector:argumentList:! - -MenuMorph removeSelector: #defaultTarget! - -MenuMorph removeSelector: #defaultTarget! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3300-BigMenuRefactor-p3-JuanVuletich-2018May01-01h15m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3296] on 1 May 2018 at 1:29:48 am'! - -MenuItemMorph subclass: #UpdatingMenuItemMorph - instanceVariableNames: 'wordingProvider wordingSelector enablementSelector wordingArgument ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #UpdatingMenuItemMorph category: #'Morphic-Menus'! -MenuItemMorph subclass: #UpdatingMenuItemMorph - instanceVariableNames: 'wordingProvider wordingSelector enablementSelector wordingArgument' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! -!UpdatingMenuItemMorph methodsFor: 'world' stamp: 'jmv 4/30/2018 21:36:20' prior: 50392410! - updateContents - "Update the receiver's contents" - - | newString enablement nArgs | - ((wordingProvider isNil) or: [wordingSelector isNil]) ifFalse: [ - nArgs _ wordingSelector numArgs. - newString _ nArgs = 0 - ifTrue: [ - wordingProvider perform: wordingSelector] - ifFalse: [ - nArgs = arguments size ifTrue: [ - wordingProvider perform: wordingSelector withArguments: arguments]]. - newString = (contentString ifNil: [ contents ]) - ifFalse: [ - self contents: newString ]]. - enablementSelector ifNotNil: [ - (enablement _ self enablement) == isEnabled - ifFalse: [self isEnabled: enablement]]! ! - -UpdatingMenuItemMorph removeSelector: #wordingArgument:! - -UpdatingMenuItemMorph removeSelector: #wordingArgument:! - -MenuItemMorph subclass: #UpdatingMenuItemMorph - instanceVariableNames: 'wordingProvider wordingSelector enablementSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #UpdatingMenuItemMorph category: #'Morphic-Menus'! -MenuItemMorph subclass: #UpdatingMenuItemMorph - instanceVariableNames: 'wordingProvider wordingSelector enablementSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3301-BigMenuRefactor-p4-JuanVuletich-2018May01-01h26m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3300] on 1 May 2018 at 10:29:54 am'! -!MenuItemMorph methodsFor: 'accessing' stamp: 'jmv 4/30/2018 21:22:56'! - setBlankIcon - "change the the receiver's icon" - icon := Theme current blankIcon! ! -!MenuItemMorph methodsFor: 'accessing' stamp: 'jmv 4/30/2018 21:26:57'! - target: anObject selector: aSymbol arguments: aCollection - - target _ anObject. - selector _ aSymbol. - arguments _ aCollection! ! -!MenuMorph methodsFor: 'accessing' stamp: 'jmv 5/1/2018 10:27:02' prior: 50392246! - addBlankIconsIfNecessary - "If any of my items have an icon, ensure that all do by using anIcon for those that don't" - - | withIcons withoutIcons | - withIcons _ Set new. - withoutIcons _ Set new. - self items do: [ :item | - item hasIcon | item hasMarker - ifTrue: [ withIcons add: item ] - ifFalse: [ withoutIcons add: item ]. - item hasSubMenu ifTrue: [ item subMenu addBlankIconsIfNecessary ]]. - (withIcons isEmpty or: [ withoutIcons isEmpty ]) ifTrue: [ ^self ]. - withoutIcons do: [ :item | item setBlankIcon ]! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:15:20' prior: 50392313! - add: aString target: target selector: aSymbol argumentList: argList - "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument. Answer the appended menu item." - - | item | - item _ MenuItemMorph new - contents: aString; - target: target selector: aSymbol arguments: argList asArray. - self addMorphBack: item. - ^ item! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:15:48' prior: 16866555! - addUpdating: wordingSelector target: target selector: aSymbol argumentList: argList - "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument. In this variant, the wording of the menu item is obtained by sending the wordingSelector to the target, Answer the item added." - - | item | - item _ UpdatingMenuItemMorph new - target: target selector: aSymbol arguments: argList asArray; - wordingProvider: target wordingSelector: wordingSelector. - self addMorphBack: item. - ^ item! ! -!MenuItemMorph methodsFor: 'accessing' stamp: 'jmv 5/1/2018 10:23:05' prior: 50392267! - contentsWithMarkers: aString inverse: inverse - "Set the menu item entry. Parse aString for embedded markers." - - | markerIndex marker | - contentString _ nil. "get rid of old" - self removeAllMorphs. "get rid of old markers if updating" - icon _ nil. - (aString notEmpty and: [aString first = $<]) - ifFalse: [^super contents: aString]. - markerIndex := aString indexOf: $>. - markerIndex = 0 ifTrue: [^super contents: aString]. - marker := (aString copyFrom: 1 to: markerIndex) asLowercase. - (#('' '' '' '') includes: marker) - ifFalse: [^super contents: aString]. - contentString _ aString. "remember actual string" - marker := (marker = '' or: [marker = '']) ~= inverse - ifTrue: [self onImage] - ifFalse: [self offImage]. - super contents: (aString copyFrom: markerIndex + 1 to: aString size). - "And set the marker" - marker := ImageMorph new image: marker. - self addMorphFront: marker position: `0@2`! ! -!MenuItemMorph methodsFor: 'drawing' stamp: 'jmv 5/1/2018 10:25:29' prior: 50385255! - drawOn: aCanvas - | stringColor leftEdge | - - stringColor _ color. - isSelected & isEnabled - ifTrue: [ - aCanvas fillRectangle: (`0@0` extent: extent) color: Theme current menuHighlight]. - leftEdge _ 0. - - self hasMarker ifTrue: [ - leftEdge _ leftEdge + submorphs first morphWidth + 8 ]. - - icon ifNotNil: [ - | iconForm | - iconForm _ isEnabled ifTrue: [ icon ] ifFalse: [ icon asGrayScaleAndTransparent ]. - aCanvas image: iconForm at: leftEdge+1 @ (extent y - iconForm height // 2). - leftEdge _ leftEdge + iconForm width + self iconSeparation]. - - aCanvas - drawString: contents - at: leftEdge @ 1 - font: self fontToUse - color: stringColor. - subMenu ifNotNil: [ - aCanvas - image: self class subMenuMarker - at: extent x - 8 @ (extent y - self class subMenuMarker height // 2) ]! ! -!MenuItemMorph methodsFor: 'layout' stamp: 'jmv 5/1/2018 10:25:03' prior: 16866123! - minItemWidth - | fontToUse iconWidth subMenuWidth markerWidth | - fontToUse _ self fontToUse. - subMenuWidth _ self hasSubMenu - ifFalse: [0] - ifTrue: [10]. - iconWidth _ icon - ifNotNil: [icon width + self iconSeparation] - ifNil: [0]. - markerWidth _ self hasMarker - ifTrue: [ submorphs first morphWidth + 8 ] - ifFalse: [ 0 ]. - ^ (fontToUse widthOfString: contents) - + subMenuWidth + iconWidth + markerWidth.! ! - -MenuItemMorph removeSelector: #arguments! - -MenuItemMorph removeSelector: #arguments! - -MenuItemMorph removeSelector: #arguments:! - -MenuItemMorph removeSelector: #arguments:! - -MenuItemMorph removeSelector: #icon! - -MenuItemMorph removeSelector: #icon! - -MenuItemMorph removeSelector: #selector! - -MenuItemMorph removeSelector: #selector! - -MenuItemMorph removeSelector: #selector:! - -MenuItemMorph removeSelector: #selector:! - -MenuItemMorph removeSelector: #target! - -MenuItemMorph removeSelector: #target! - -MenuItemMorph removeSelector: #target:! - -MenuItemMorph removeSelector: #target:! - -MenuMorph removeSelector: #target:! - -MenuMorph removeSelector: #target:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3302-BigMenuRefactor-p5-JuanVuletich-2018May01-10h14m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3300] on 1 May 2018 at 10:51:01 am'! -!ChangeSorterWindow methodsFor: 'menu building' stamp: 'jmv 5/1/2018 10:35:14' prior: 16800084! - changeSetMenu - "Set up aMenu to hold commands for the change-set-list pane. This could be for a single or double changeSorter" - - | aMenu isForBaseSystem | - isForBaseSystem _ model changeSet isForBaseSystem. - aMenu _ MenuMorph new defaultTarget: model. - aMenu title: 'Change Set'. - aMenu addStayUpIcons. - - (aMenu add: 'File out and remove (o)' action: #fileOutAndRemove) isEnabled: isForBaseSystem. - aMenu add: 'File out and keep (k)' action: #fileOutAndKeep. - aMenu addLine. - - (aMenu add: 'Rename change set (r)' action: #rename) isEnabled: isForBaseSystem. - (aMenu add: 'Destroy change set (x)' action: #remove) isEnabled: isForBaseSystem. - aMenu addLine. - model currentCanHavePreambleAndPostscript ifTrue: [ - aMenu addLine. - model currentHasPreamble - ifTrue: [ - aMenu add: 'Edit preamble (p)' action: #addPreamble. - aMenu add: 'Remove preamble' action: #removePreamble] - ifFalse: [ - aMenu add: 'Add preamble (p)' action: #addPreamble]. - model currentHasPostscript - ifTrue: [ - aMenu add: 'Edit postscript...' action: #editPostscript. - aMenu add: 'Remove postscript' action: #removePostscript] - ifFalse: [ - aMenu add: 'Add postscript...' action: #editPostscript]. - ]. - aMenu addLine. - - "CONFLICTS SECTION" - aMenu add: 'conflicts with other change sets' target: self action: #browseMethodConflicts. - aMenu balloonTextForLastItem: 'Browse all methods that occur both in this change set and in at least one other change set.'. - aMenu addLine. - - "CHECKS SECTION" - (aMenu add: 'trim history' action: #trimHistory) isEnabled: isForBaseSystem. - aMenu balloonTextForLastItem: ' Drops any methods added and then removed, as well as renaming and reorganization of newly-added classes. ', - 'NOTE: can cause confusion if later filed in over an earlier version of these changes'. - - aMenu add: 'view affected class categories' action: #viewAffectedClassCategories. - aMenu balloonTextForLastItem: ' Show class categories affected by any contained change'. - - ^ aMenu! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:43:21' prior: 16866322! - add: aString action: aSymbol - "Append a menu item with the given label. If the item is selected, it will send the given selector to the default target object." - "Details: Note that the menu item added captures the default target object at the time the item is added; the default target can later be changed before added additional items without affecting the targets of previously added entries. The model is that each entry is like a button that knows everything it needs to perform its action." - - ^self add: aString - target: defaultTarget - selector: aSymbol - argumentList: #()! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:44:00' prior: 16866365! - add: aString selector: aSymbol argument: arg - - ^self add: aString - target: defaultTarget - selector: aSymbol - argumentList: (Array with: arg) -! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:44:36' prior: 50392304! - add: aString subMenu: aMenuMorph - "Append the given submenu with the given label." - - | item | - item _ MenuItemMorph new. - item - contents: aString; - subMenu: aMenuMorph. - self addMorphBack: item. - ^item! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:44:10' prior: 16866381! - add: aString target: aTarget action: aSymbol - ^self add: aString - target: aTarget - selector: aSymbol - argumentList: #()! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:44:15' prior: 16866388! - add: aString target: anObject selector: aSymbol - "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object." - - ^self add: aString - target: anObject - selector: aSymbol - argumentList: #()! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:48:29' prior: 16866398! - add: aString target: target selector: aSymbol argument: arg - "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given argument." - - ^self add: aString - target: target - selector: aSymbol - argumentList: { arg }! ! -!CustomMenu methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:47:21' prior: 16826787! - addList: listOfTuplesAndDashes - "Add a menu item to the receiver for each tuple in the given list of the form ( ). Add a line for each dash (-) in the list." - - listOfTuplesAndDashes do: [:aTuple | - aTuple == #- - ifTrue: [self addLine] - ifFalse: [self add: aTuple first action: aTuple second]] - - " - CustomMenu new addList: #( - ('apples' buyApples) - ('oranges' buyOranges) - - - ('milk' buyMilk)); startUpMenu - " - -! ! - -CustomMenu removeSelector: #add:target:selector:! - -CustomMenu removeSelector: #add:target:selector:! - -CustomMenu removeSelector: #add:target:selector:argument:! - -CustomMenu removeSelector: #add:target:selector:argument:! - -CustomMenu removeSelector: #add:target:selector:argumentList:! - -CustomMenu removeSelector: #add:target:selector:argumentList:! - -CustomMenu removeSelector: #addStayUpIcons! - -CustomMenu removeSelector: #addStayUpIcons! - -MenuMorph removeSelector: #add:action:enabled:! - -MenuMorph removeSelector: #add:action:enabled:! - -MenuMorph removeSelector: #add:target:selector:arguments:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3303-BigMenuRefactor-p6-JuanVuletich-2018May01-10h29m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3300] on 1 May 2018 at 11:01:26 am'! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:59:27'! - add: aString target: target action: aSymbol argument: arg - "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given argument." - - ^self add: aString - target: target - action: aSymbol - argumentList: { arg }! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:58:49'! - add: aString target: target action: aSymbol argumentList: argList - "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument. Answer the appended menu item." - - | item | - item _ MenuItemMorph new - contents: aString; - target: target selector: aSymbol arguments: argList asArray. - self addMorphBack: item. - ^ item! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:58:11'! - addUpdating: wordingSelector target: target action: aSymbol argumentList: argList - "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument. In this variant, the wording of the menu item is obtained by sending the wordingSelector to the target, Answer the item added." - - | item | - item _ UpdatingMenuItemMorph new - target: target selector: aSymbol arguments: argList asArray; - wordingProvider: target wordingSelector: wordingSelector. - self addMorphBack: item. - ^ item! ! -!SimpleServiceEntry methodsFor: 'services menu' stamp: 'jmv 5/1/2018 10:55:06' prior: 16907962! - addServiceFor: served toMenu: aMenu - argumentProvider _ served. - aMenu add: self label - target: self - action: #performService. - self useLineAfter ifTrue: [ aMenu addLine ].! ! -!CPUWatcher methodsFor: 'porcine capture' stamp: 'jmv 5/1/2018 11:00:03' prior: 16795021! - openMorphicWindowForSuspendedProcess: aProcess - | menu rule | - menu _ MenuMorph new. - "nickname allow-stop allow-debug" - rule _ (ProcessBrowser rulesFor: aProcess) second. - menu add: 'Dismiss this menu' target: menu action: #delete; addLine. - menu add: 'Open Process Browser' target: ProcessBrowserWindow action: #openProcessBrowser. - menu add: 'Resume' - target: self - action: #resumeProcess:fromMenu: - argumentList: { aProcess . menu }. - menu add: 'Terminate' - target: self - action: #terminateProcess:fromMenu: - argumentList: { aProcess . menu }. - rule ifTrue: [ - menu add: 'Debug at a lower priority' - target: self - action: #debugProcess:fromMenu: - argumentList: { aProcess . menu }. - ]. - menu addTitle: aProcess identityHash asString, - ' ', aProcess name, - ' is taking too much time and has been suspended. -What do you want to do with it?'. - menu stayUp. - menu popUpInWorld -! ! -!AbstractFont class methodsFor: 'instance accessing' stamp: 'jmv 5/1/2018 10:56:07' prior: 16777431! - fromUser: priorFont - " - AbstractFont fromUser - " - "Present a menu of available fonts, and if one is chosen, return it. - Otherwise return nil. - Show only baseFonts i.e. FamilyName, pointSize (but do not include emphasis, such as italic or bold)" - - | fontList fontMenu active ptMenu label spec | - fontList := AbstractFont familyNames. - fontMenu := MenuMorph new defaultTarget: self. - fontList do: [:fontName | - active := priorFont familyName sameAs: fontName. - ptMenu := MenuMorph new defaultTarget: self. - (AbstractFont pointSizesFor:fontName ) do: [ :pt | - (active and: [pt = priorFont pointSize]) - ifTrue: [label := ''] - ifFalse: [label := '']. - label := label , pt printString , ' pt'. - ptMenu - add: label - target: fontMenu - action: #modalSelection: - argument: { - fontName. - pt}]. - active ifTrue: [label := ''] ifFalse: [label := '']. - label := label , fontName. - fontMenu add: label subMenu: ptMenu]. - spec := fontMenu invokeModal. - spec ifNil: [^nil]. - ^AbstractFont familyName: spec first pointSize: spec last! ! -!Morph methodsFor: 'debug and other' stamp: 'jmv 5/1/2018 10:55:33' prior: 50376324! - buildDebugMenu: aHand - "Answer a debugging menu for the receiver. The hand argument is seemingly historical and plays no role presently" - - | aMenu | - aMenu := MenuMorph new defaultTarget: self. - aMenu addStayUpIcons. - self isKnownFailing - ifTrue: [ - aMenu add: 'start drawing again' action: #resumeAfterDrawError. - aMenu addLine]. - (self hasProperty: #errorOnStep) - ifTrue: [ - aMenu add: 'start stepping again' action: #resumeAfterStepError. - aMenu addLine]. - aMenu add: 'inspect morph' action: #inspect. - aMenu add: 'inspect owner chain' action: #inspectOwnerChain. - self hasModel - ifTrue: [ - aMenu - add: 'inspect model' - target: self model - action: #inspect]. - aMenu - add: 'explore morph' - target: self - action: #explore. - aMenu - add: 'copy to clipboard (c)' - target: self - action: #copyToClipboard. - aMenu addLine. - aMenu - add: 'browse morph class' - target: self - action: #browseClassHierarchy. - self hasModel - ifTrue: [ - aMenu - add: 'browse model class' - target: self model - action: #browseClassHierarchy]. - aMenu addLine. - aMenu - add: 'edit balloon help' action: #editBalloonHelpText. - ^aMenu! ! -!Morph methodsFor: 'meta-actions' stamp: 'jmv 5/1/2018 10:59:32' prior: 16876336! - addEmbeddingMenuItemsTo: aMenu hand: aHandMorph - | menu | - menu _ MenuMorph new defaultTarget: self. - self potentialEmbeddingTargets reverseDo: [:m | - menu - add: m class name asString - target: m - action: #addMorphFrontFromWorldPosition: - argumentList: {self}]. - aMenu ifNotNil:[ - menu submorphCount > 0 - ifTrue:[aMenu add:'embed into' subMenu: menu]. - ]. - ^menu! ! -!ObjectExplorerWindow methodsFor: 'building menus' stamp: 'jmv 5/1/2018 10:56:13' prior: 50376398! - genericMenu - "Borrow a menu from my inspector" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - model getCurrentSelection - ifNil: [ - aMenu - add: '*nothing selected*' - target: self - action: #yourself] - ifNotNil: [ - aMenu addList: #( - ('inspect (i)' inspectSelection) - ('explore (I)' exploreSelection) - ('copy to clipboard (c)' copySelectionToClipboard) - ('basic inspect' inspectBasic) - ('references finder' openReferencesFinder) - ('weight explorer' openWeightExplorer) - - - ('browse full (b)' browseMethodFull) - ('browse hierarchy (h)' browseHierarchy) - ('browse protocol (p)' browseFullProtocol)). - aMenu addLine; - add: 'monitor changes' - target: self - action: #monitor: - argument: model getCurrentSelection. - model class == ReferencesExplorer ifTrue: [ - aMenu addLine; - add: 'rescan' - target: self - action: #rescan ]]. - model basicMonitorList isEmptyOrNil - ifFalse: [ - aMenu addLine; - add: 'stop monitoring all' - target: self - action: #stopMonitoring ]. - ^ aMenu! ! -!TestRunnerWindow methodsFor: 'menu building' stamp: 'jmv 5/1/2018 10:56:21' prior: 16928753! - listMenu - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu title: 'Test Cases'. - aMenu add: 'select all' target: model action: #selectAll. - aMenu add: 'deselect all' target: model action: #deselectAll. - aMenu add: 'toggle selections' target: model action: #invertSelections. - aMenu add: 'filter' target: model action: #setFilter. - model runButtonState ifTrue: [ - aMenu add: 'stop' target: model action: #terminateRun - ]. - model selectedSuite > 0 ifTrue: [ | cls | - cls _ (model tests at: model selectedSuite ifAbsent: ['']) copyUpTo: Character space. - cls _ cls asSymbol. - cls _ (Smalltalk at: cls ifAbsent: nil). - cls ifNotNil: [ - aMenu addLine. - aMenu add: 'browse' target: self action: #browse: argument: cls. - ]. - ]. - aMenu addLine. - aMenu add: 'log to Transcript' target: model action: #showResult. - ^aMenu! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:59:08' prior: 50392796! - add: aString action: aSymbol - "Append a menu item with the given label. If the item is selected, it will send the given selector to the default target object." - "Details: Note that the menu item added captures the default target object at the time the item is added; the default target can later be changed before added additional items without affecting the targets of previously added entries. The model is that each entry is like a button that knows everything it needs to perform its action." - - ^self add: aString - target: defaultTarget - action: aSymbol - argumentList: #()! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:59:21' prior: 50392817! - add: aString selector: aSymbol argument: arg - - ^self add: aString - target: defaultTarget - action: aSymbol - argumentList: { arg }! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:59:24' prior: 50392835! - add: aString target: aTarget action: aSymbol - ^self add: aString - target: aTarget - action: aSymbol - argumentList: #()! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:58:24' prior: 16866541! - addUpdating: aWordingSelector action: aSymbol - - self addUpdating: aWordingSelector target: defaultTarget action: aSymbol argumentList: #()! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:58:30' prior: 16866548! - addUpdating: aWordingSelector target: aTarget action: aSymbol - - self addUpdating: aWordingSelector target: aTarget action: aSymbol argumentList: #()! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:56:28' prior: 50343972! - alphabeticalMorphMenu - | list splitLists menu firstChar lastChar subMenu | - list := Morph withAllSubclasses select: [ :m | - m includeInNewMorphMenu ]. - list := list asArray sort: [ :c1 :c2 | - c1 name < c2 name ]. - splitLists := self - splitNewMorphList: list - depth: 4. - menu := MenuMorph new defaultTarget: self. - 1 - to: splitLists size - do: [ :i | - firstChar := i = 1 - ifTrue: [ $A ] - ifFalse: [ - (splitLists at: i) first name first: 3 ]. - lastChar := i = splitLists size - ifTrue: [ $Z ] - ifFalse: [ - (splitLists at: i) last name first: 3 ]. - subMenu := MenuMorph new. - (splitLists at: i) do: [ :cl | - subMenu - add: cl name - target: self - action: #newMorphOfClass:event: - argument: cl ]. - menu - add: firstChar asString , ' - ' , lastChar asString - subMenu: subMenu ]. - ^ menu.! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:59:35' prior: 16934888! - fillIn: aMenu from: dataForMenu - "A menu constructor utility by RAA. dataForMenu is a list of items which mean: - nil Indicates to add a line - - first element is symbol Add updating item with the symbol as the wording selector - second element is a list second element has the receiver and selector - - first element is a string Add menu item with the string as its wording - second element is a list second element has the receiver and selector - - a third element exists Use it as the balloon text - a fourth element exists Use it as the enablement selector (updating case only)" - - | item | - - dataForMenu do: [ :itemData | - itemData ifNil: [aMenu addLine] ifNotNil: [ - item _ itemData first isSymbol - ifTrue: [ - aMenu - addUpdating: itemData first - target: self - action: #doMenuItem:with: - argumentList: {itemData second}] - ifFalse: [ - aMenu - add: itemData first - target: self - action: #doMenuItem:with: - argumentList: {itemData second}]. - itemData size >= 3 ifTrue: [ - aMenu balloonTextForLastItem: itemData third. - itemData size >= 4 ifTrue: [ - item enablementSelector: itemData fourth ]]]]. - - ^ aMenu! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:59:42' prior: 16934928! - fillIn: aMenu fromDictionaries: dataForMenuDicts - "A menu constructor utility that uses Dictionaries with elements: - #label - the name that displays in the menu - #object - the target object - #selector - the selector called on object when the menu item is selected - #arguments - optional collection of arguments passed to the selector - #balloonText - optional 'tool tip' style help text - - note, nil elements will add a line." - dataForMenuDicts do: [ :dict | - dict - ifNil: [ aMenu addLine ] - ifNotNil: [ - (dict at: #label) isSymbol - ifTrue: [ - aMenu - addUpdating: (dict at: #label) - target: (dict at: #object) - action: (dict at: #selector) - argumentList: - (dict - at: #arguments - ifAbsent: [ #() ]) ] - ifFalse: [ - aMenu - add: (dict at: #label) - target: (dict at: #object) - action: (dict at: #selector) - argumentList: - (dict - at: #arguments - ifAbsent: [ #() ]) ]. - dict - at: #balloonText - ifPresent: [ :balloonText | - aMenu balloonTextForLastItem: balloonText ]]]. - ^ aMenu.! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:56:32' prior: 50344240! - newMorph - "The user requested 'new morph' from the world menu. Put up a menu that allows many ways of obtaining new morphs. If the preference #classicNewMorphMenu is true, the full form of yore is used; otherwise, a much shortened form is used." - | menu subMenu catDict | - menu _ self menu: 'Add a new morph'. - menu - - add: 'From Clipboard' - target: myHand - action: #pasteMorph; - - add: 'From Alphabetical List' - subMenu: self alphabeticalMorphMenu. - menu addLine. - "Add 'Classic' New Morph menu" - catDict _ Dictionary new. - - Morph allSubclassesDo: [ :eaSubclass | - eaSubclass includeInNewMorphMenu ifTrue: [ | category | - (eaSubclass respondsTo: #categoryInNewMorphMenu) - ifTrue: [ category _ eaSubclass categoryInNewMorphMenu ] - ifFalse: [ category _ 'Unknown' ]. - (catDict includesKey: category) - ifTrue: [ (catDict at: category) add: eaSubclass ] - ifFalse: [ - catDict - at: category - put: (OrderedCollection with: eaSubclass) ]]]. - catDict keys sort do: [ :categ | - subMenu _ MenuMorph new. - ((catDict at: categ) asArray sort: [ :c1 :c2 | - c1 name < c2 name ]) do: [ :cl | - subMenu - add: cl name - target: self - action: #newMorphOfClass:event: - argument: cl ]. - menu - add: categ - subMenu: subMenu ]. - self doPopUp: menu.! ! - -MenuMorph removeSelector: #add:target:selector:! - -MenuMorph removeSelector: #add:target:selector:! - -MenuMorph removeSelector: #add:target:selector:argument:! - -MenuMorph removeSelector: #add:target:selector:argument:! - -MenuMorph removeSelector: #add:target:selector:argumentList:! - -MenuMorph removeSelector: #add:target:selector:argumentList:! - -MenuMorph removeSelector: #addUpdating:target:selector:argumentList:! - -MenuMorph removeSelector: #addUpdating:target:selector:argumentList:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3304-BigMenuRefactor-p7-JuanVuletich-2018May01-10h51m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3303] on 1 May 2018 at 12:46:35 pm'! -!Morph methodsFor: 'menus' stamp: 'jmv 5/1/2018 11:26:39' prior: 16876165! - addHaloActionsTo: aMenu - "Add items to aMenu representing actions requestable via halo" - - | subMenu | - subMenu := MenuMorph new defaultTarget: self. - subMenu addTitle: (self printStringLimitedTo: 40). - subMenu addStayUpIcons. - subMenu addLine. - (subMenu add: 'delete' action: #dismissViaHalo) - setBalloonText: 'Delete this object -- warning -- can be destructive!!' . - self maybeAddCollapseItemTo: subMenu. - (subMenu add: 'grab' action: #openInHand) - setBalloonText: 'Pick this object up -- warning, since this removes it from its container, it can have adverse effects.' . - subMenu addLine. - (subMenu add: 'resize' action: #resizeFromMenu) - setBalloonText: 'Change the size of this object'. - (subMenu add: 'duplicate' action: #maybeDuplicateMorph) - setBalloonText: 'Hand me a copy of this object'. - (subMenu - add: 'set color' - target: self - action: #changeColor) - setBalloonText: 'Change the color of this object'. - (subMenu - add: 'inspect' - target: self - action: #inspect) - setBalloonText: 'Open an Inspector on this object'. - aMenu add: 'halo actions...' subMenu: subMenu! ! -!Morph methodsFor: 'menus' stamp: 'jmv 5/1/2018 11:26:53' prior: 16876246! - addToggleItemsToHaloMenu: aMenu - "Add standard true/false-checkbox items to the memu" - - #( - (stickinessString toggleStickiness 'whether I should be resistant to a drag done by mousing down on me') - (lockedString lockUnlockMorph 'when "locked", I am inert to all user interactions') - ) do: [ :trip | - (aMenu addUpdating: trip first action: trip second) - setBalloonText: trip third ]! ! -!CodeWindow methodsFor: 'menu building' stamp: 'jmv 5/1/2018 11:24:50' prior: 16813594! - addContentsTogglesTo: aMenu - "Add updating menu toggles governing contents to aMenu." - - model contentsSymbolQuints do: [ :aQuint | - aQuint == #- - ifTrue: [ - aMenu addLine] - ifFalse: [ - (aMenu addUpdating: aQuint third target: model action: aQuint second) - setBalloonText: aQuint fifth ]]! ! -!ChangeSorterWindow methodsFor: 'menu building' stamp: 'jmv 5/1/2018 11:24:14' prior: 50392729! - changeSetMenu - "Set up aMenu to hold commands for the change-set-list pane. This could be for a single or double changeSorter" - - | aMenu isForBaseSystem | - isForBaseSystem _ model changeSet isForBaseSystem. - aMenu _ MenuMorph new defaultTarget: model. - aMenu title: 'Change Set'. - aMenu addStayUpIcons. - - (aMenu add: 'File out and remove (o)' action: #fileOutAndRemove) isEnabled: isForBaseSystem. - aMenu add: 'File out and keep (k)' action: #fileOutAndKeep. - aMenu addLine. - - (aMenu add: 'Rename change set (r)' action: #rename) isEnabled: isForBaseSystem. - (aMenu add: 'Destroy change set (x)' action: #remove) isEnabled: isForBaseSystem. - aMenu addLine. - model currentCanHavePreambleAndPostscript ifTrue: [ - aMenu addLine. - model currentHasPreamble - ifTrue: [ - aMenu add: 'Edit preamble (p)' action: #addPreamble. - aMenu add: 'Remove preamble' action: #removePreamble] - ifFalse: [ - aMenu add: 'Add preamble (p)' action: #addPreamble]. - model currentHasPostscript - ifTrue: [ - aMenu add: 'Edit postscript...' action: #editPostscript. - aMenu add: 'Remove postscript' action: #removePostscript] - ifFalse: [ - aMenu add: 'Add postscript...' action: #editPostscript]. - ]. - aMenu addLine. - - "CONFLICTS SECTION" - (aMenu add: 'conflicts with other change sets' target: self action: #browseMethodConflicts) - setBalloonText: 'Browse all methods that occur both in this change set and in at least one other change set.'. - aMenu addLine. - - "CHECKS SECTION" - (aMenu add: 'trim history' action: #trimHistory) - isEnabled: isForBaseSystem; - setBalloonText: ' Drops any methods added and then removed, as well as renaming and reorganization of newly-added classes. ', - 'NOTE: can cause confusion if later filed in over an earlier version of these changes'. - - (aMenu add: 'view affected class categories' action: #viewAffectedClassCategories) - setBalloonText: ' Show class categories affected by any contained change'. - - ^ aMenu! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 11:25:14' prior: 16866439! - addList: aList - "Add the given items to this menu, where each item is a pair ( ).. If an element of the list is simply the symobl $-, add a line to the receiver. The optional third element of each entry, if present, provides balloon help." - - | target item | - aList do: [:tuple | - tuple == #- - ifTrue: [ self addLine ] - ifFalse: [ - target _ tuple size > 3 - ifTrue: [ defaultTarget perform: tuple fourth ] - ifFalse: [ defaultTarget ]. - item _ self add: tuple first target: target action: tuple second. - tuple size > 2 ifTrue: [ - item setBalloonText: tuple third]]]! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 11:24:38' prior: 50393201! -addUpdating: aWordingSelector action: aSymbol - - ^self addUpdating: aWordingSelector target: defaultTarget action: aSymbol argumentList: #()! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 11:24:33' prior: 50393209! - addUpdating: aWordingSelector target: aTarget action: aSymbol - - ^self addUpdating: aWordingSelector target: aTarget action: aSymbol argumentList: #()! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/1/2018 12:45:58' prior: 50393247! - fillIn: aMenu from: dataForMenu - "A menu constructor utility by RAA. dataForMenu is a list of items which mean: - nil Indicates to add a line - - first element is symbol Add updating item with the symbol as the wording selector - second element is a list second element has the receiver and selector - - first element is a string Add menu item with the string as its wording - second element is a list second element has the receiver and selector - - a third element exists Use it as the balloon text - a fourth element exists Use it as the enablement selector (updating case only)" - - | item | - - dataForMenu do: [ :itemData | - itemData ifNil: [aMenu addLine] ifNotNil: [ - item _ aMenu - add: itemData first - target: self - action: #doMenuItem:with: - argumentList: {itemData second}. - itemData size >= 3 ifTrue: [ - item setBalloonText: itemData third. - itemData size >= 4 ifTrue: [ - item enablementSelector: itemData fourth ]]]]. - - ^ aMenu! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/1/2018 11:27:29' prior: 50393288! - fillIn: aMenu fromDictionaries: dataForMenuDicts - "A menu constructor utility that uses Dictionaries with elements: - #label - the name that displays in the menu - #object - the target object - #selector - the selector called on object when the menu item is selected - #arguments - optional collection of arguments passed to the selector - #balloonText - optional 'tool tip' style help text - - note, nil elements will add a line." - | item | - dataForMenuDicts do: [ :dict | - dict - ifNil: [ aMenu addLine ] - ifNotNil: [ - item _ (dict at: #label) isSymbol - ifTrue: [ - aMenu - addUpdating: (dict at: #label) - target: (dict at: #object) - action: (dict at: #selector) - argumentList: - (dict - at: #arguments - ifAbsent: [ #() ]) ] - ifFalse: [ - aMenu - add: (dict at: #label) - target: (dict at: #object) - action: (dict at: #selector) - argumentList: - (dict - at: #arguments - ifAbsent: [ #() ]) ]. - dict - at: #balloonText - ifPresent: [ :balloonText | - item setBalloonText: balloonText ]]]. - ^ aMenu! ! - -CustomMenu removeSelector: #balloonTextForLastItem:! - -CustomMenu removeSelector: #balloonTextForLastItem:! - -MenuMorph removeSelector: #balloonTextForLastItem:! - -MenuMorph removeSelector: #balloonTextForLastItem:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3305-BigMenuRefactor-p8-JuanVuletich-2018May01-12h43m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3304] on 1 May 2018 at 9:11:14 pm'! -!Collection methodsFor: 'converting' stamp: 'jmv 5/1/2018 14:28:51'! - asDictionary - "Answer a Dictionary. Assume our elements are Associations. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Browser'. - #object -> BrowserWindow. - #selector -> #openBrowser. - #icon -> #editFindReplaceIcon. - #balloonText -> 'A Smalltalk code browser, for studying and modifying the system'. - } asDictionary - " - - ^ self as: Dictionary! ! -!MenuItemMorph methodsFor: 'accessing' stamp: 'jmv 5/1/2018 14:17:12'! - setIcon: symbolOrFormOrNil - "Argument can be a Form, a Symbol (to be sent to Theme current) or nil." - - icon _ symbolOrFormOrNil isSymbol - ifTrue: [Theme current perform: symbolOrFormOrNil] - ifFalse: [ symbolOrFormOrNil ]! ! -!Workspace class methodsFor: 'menu-world' stamp: 'jmv 5/1/2018 21:07:43' prior: 16945473! - worldMenuForOpenGroup - ^ `{ - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'Workspace'. - #object -> Workspace. - #selector -> #openWorkspace. - #icon -> #terminalIcon. - #balloonText -> 'A window for evaluating Smalltalk expressions'. - } asDictionary`! ! -!Transcripter class methodsFor: 'menu-world' stamp: 'jmv 5/1/2018 21:06:41' prior: 16938956! - worldMenuForOpenGroup - ^ `{ - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Emergency Evaluator'. - #object -> Transcripter. - #selector -> #emergencyEvaluator. - #icon -> #emblemImportantIcon. - #balloonText -> 'When all else fails...'. - } asDictionary`! ! -!TextEditor class methodsFor: 'menu-world' stamp: 'jmv 5/1/2018 21:04:48' prior: 16933249! - worldMenuForOpenGroup - ^ `{ - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Text Editor'. - #object -> TextEditor. - #selector -> #openTextEditor. - #icon -> #textEditorIcon. - #balloonText -> 'A window for composing text'. - } asDictionary`! ! -!CodePackageListWindow class methodsFor: 'menu-world' stamp: 'jmv 5/1/2018 14:38:08' prior: 16811663! - worldMenuForOpenGroup - ^ `{ - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Installed Packages'. - #object -> CodePackageListWindow. - #selector -> #openPackageList. - #icon -> #packageIcon. - #balloonText -> 'A tool for managing Packages (optional units of code) installed in the system'. - } asDictionary`! ! -!BrowserWindow class methodsFor: 'menu-world' stamp: 'jmv 5/1/2018 14:36:38' prior: 16793528! - worldMenuForOpenGroup - ^ `{ - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Browser'. - #object -> BrowserWindow. - #selector -> #openBrowser. - #icon -> #editFindReplaceIcon. - #balloonText -> 'A Smalltalk code browser, for studying and modifying the system'. - } asDictionary`! ! -!MessageNamesWindow class methodsFor: 'menu-world' stamp: 'jmv 5/1/2018 21:01:20' prior: 16867850! - worldMenuForOpenGroup - ^ `{ - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'Message Names'. - #object -> MessageNamesWindow. - #selector -> #openMessageNames. - #icon -> #inspectIcon. - #balloonText -> 'A tool for finding and editing methods that contain any given keyword in their names.'. - } asDictionary`! ! -!ChangeSorterWindow class methodsFor: 'menu-world' stamp: 'jmv 5/1/2018 14:36:47' prior: 16800316! - worldMenuForOpenGroup - ^ `{ - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Change Sorter'. - #object -> ChangeSorterWindow. - #selector -> #openChangeSorter. - #icon -> #halfRefreshIcon. - #balloonText -> 'A tool allowing you to view the methods in a Change Set, especially changes to the Base System'. - } asDictionary`! ! -!FileListWindow class methodsFor: 'menu-world' stamp: 'jmv 5/1/2018 21:00:10' prior: 16843460! - worldMenuForOpenGroup - ^ `{ - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'File List'. - #object -> FileListWindow. - #selector -> #openFileList. - #icon -> #systemFileManagerIcon. - #balloonText -> 'An explorer of the File System'. - } asDictionary`! ! -!ProcessBrowserWindow class methodsFor: 'menu-world' stamp: 'jmv 5/1/2018 21:02:47' prior: 16895580! - worldMenuForOpenGroup - ^ `{ - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Process Browser'. - #object -> ProcessBrowserWindow. - #selector -> #openProcessBrowser. - #icon -> #systemMonitorIcon. - #balloonText -> 'A tool to monitor and manage Smalltalk processes'. - } asDictionary`! ! -!TestRunnerWindow class methodsFor: 'menu-world' stamp: 'jmv 5/1/2018 21:03:55' prior: 16928799! - worldMenuForOpenGroup - ^ `{ - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'SUnit Test Runner'. - #object -> TestRunnerWindow. - #selector -> #openTestRunner. - #icon -> #weatherFewCloudsIcon. - #balloonText -> 'Smalltalk''s testing framework'. - } asDictionary`! ! -!TranscriptWindow class methodsFor: 'menu-world' stamp: 'jmv 5/1/2018 21:05:41' prior: 16938780! - worldMenuForOpenGroup - ^ `{ - #itemGroup -> 10. - #itemOrder -> 50. - #label -> 'Transcript'. - #object -> TranscriptWindow. - #selector -> #openTranscript. - #icon -> #printerIcon. - #balloonText -> 'A window showing contents of the System Transcript'. - } asDictionary`! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/1/2018 14:18:59' prior: 50393595! - fillIn: aMenu fromDictionaries: dataForMenuDicts - "A menu constructor utility that uses Dictionaries with elements: - #label - the name that displays in the menu - #object - the target object - #selector - the selector called on object when the menu item is selected - #arguments - optional collection of arguments passed to the selector - #balloonText - optional 'tool tip' style help text - #icon- optional icon selector or Form - - note, nil elements will add a line." - | item | - dataForMenuDicts do: [ :dict | - dict - ifNil: [ aMenu addLine ] - ifNotNil: [ - item _ (dict at: #label) isSymbol - ifTrue: [ - aMenu - addUpdating: (dict at: #label) - target: (dict at: #object) - action: (dict at: #selector) - argumentList: - (dict - at: #arguments - ifAbsent: [ #() ]) ] - ifFalse: [ - aMenu - add: (dict at: #label) - target: (dict at: #object) - action: (dict at: #selector) - argumentList: - (dict - at: #arguments - ifAbsent: [ #() ]) ]. - dict - at: #icon - ifPresent: [ :symbolOrFormOrNil | - item setIcon: symbolOrFormOrNil ]. - dict - at: #balloonText - ifPresent: [ :balloonText | - item setBalloonText: balloonText ]. - ]]. - ^ aMenu! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3306-BigMenuRefactor-p9-JuanVuletich-2018May01-21h10m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3306] on 2 May 2018 at 2:33:08 pm'! -!TheWorldMenu methodsFor: 'popups' stamp: 'jmv 5/1/2018 21:47:43'! - openChangesMenu - "Build the changes menu for the world." - - self doPopUp: self changesMenu! ! -!TheWorldMenu methodsFor: 'popups' stamp: 'jmv 5/1/2018 21:48:18'! -openDebugMenu - - self doPopUp: self debugMenu! ! -!TheWorldMenu methodsFor: 'popups' stamp: 'jmv 5/1/2018 21:45:28'! - openHelpMenu - "Build and show the help menu for the world." - - self doPopUp: self helpMenu! ! -!TheWorldMenu methodsFor: 'popups' stamp: 'jmv 5/1/2018 21:30:15'! -openOpenMenu - - self doPopUp: self openMenu! ! -!TheWorldMenu methodsFor: 'popups' stamp: 'jmv 5/1/2018 21:43:44'! - openPreferencesMenu - "Build and show the preferences menu for the world." - - self doPopUp: self preferencesMenu! ! -!TheWorldMenu methodsFor: 'popups' stamp: 'jmv 5/1/2018 21:45:06'! - openWindowsMenu - "Build the windows menu for the world." - - self doPopUp: self windowsMenu! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/2/2018 14:32:47' prior: 50379981! - buildWorldMenu - "Build the menu that is put up when the screen-desktop is clicked on" - - | menu | - menu _ MenuMorph new defaultTarget: self. - menu addStayUpIcons. - self - fillIn: menu - fromDictionaries: `{ - { - #label -> 'Open...'. - #object -> #theWorldMenu. - #selector -> #openOpenMenu. - #icon -> #openIcon. - #balloonText -> 'Submenu to open various system tools'. - } asDictionary. - { - #label -> 'New morph...'. - #object -> #theWorldMenu. - #selector -> #newMorph. - #icon -> #morphsIcon. - #balloonText -> 'Offers a variety of ways to create new objects'. - } asDictionary. - { - #label -> 'Preferences...'. - #object -> #theWorldMenu. - #selector -> #openPreferencesMenu. - #icon -> #preferencesIcon. - #balloonText -> 'Opens a menu offering many controls over appearance and system preferences.'. - } asDictionary. - { - #label -> 'Windows...'. - #object -> #theWorldMenu. - #selector -> #openWindowsMenu. - #icon -> #windowIcon. - #balloonText -> 'Manage open windows'. - } asDictionary. - { - #label -> 'Help...'. - #object -> #theWorldMenu. - #selector -> #openHelpMenu. - #icon -> #helpIcon. - #balloonText -> 'Opens a menu of useful items for updating the system, determining what version you are running, and much else'. - } asDictionary. - nil. - { - #label -> 'Changes...'. - #object -> #theWorldMenu. - #selector -> #openChangesMenu. - #icon -> #changesIcon. - #balloonText -> 'Opens a menu of useful tools for dealing with changes'. - } asDictionary. - { - #label -> 'Debug...'. - #object -> #theWorldMenu. - #selector -> #openDebugMenu. - #icon -> #debugIcon. - #balloonText -> 'a menu of debugging items'. - } asDictionary. - { - #label -> 'Restore Display (r)'. - #object -> #myWorld. - #selector -> #restoreDisplay. - #icon -> #displayIcon. - #balloonText -> 'Repaint the screen -- useful for removing unwanted display artifacts, lingering cursors, etc.'. - } asDictionary. - nil. - { - #label -> 'Save'. - #object -> Smalltalk. - #selector -> #saveSession. - #icon -> #saveIcon. - #balloonText -> 'Save the current version of the image on disk'. - } asDictionary. - { - #label -> 'Save as...'. - #object -> Smalltalk. - #selector -> #saveAs. - #icon -> #saveAsIcon. - #balloonText -> 'Save the current version of the image on disk under a new name.'. - } asDictionary. - { - #label -> 'Save as New Version'. - #object -> Smalltalk. - #selector -> #saveAsNewVersion. - #icon -> #saveAsNewVersionIcon. - #balloonText -> 'Save the current image a new version-stamped name\and save it under that name on disk.\Clear all user preferences and user state (class vars).' withNewLines. - } asDictionary. - { - #label -> 'Save and Quit'. - #object -> #theWorldMenu. - #selector -> #saveAndQuit. - #icon -> #saveAndQuitIcon. - #balloonText -> 'Save the image and quit out of Cuis.'. - } asDictionary. - { - #label -> 'Quit'. - #object -> #theWorldMenu. - #selector -> #quitSession. - #icon -> #quitIcon. - #balloonText -> 'Quit out of Cuis.'. - } asDictionary. - }`. - ^menu! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/1/2018 21:38:18' prior: 50393821! - fillIn: aMenu fromDictionaries: dataForMenuDicts - "A menu constructor utility that uses Dictionaries with elements: - #label - the name that displays in the menu - #object - the target object - #selector - the selector called on object when the menu item is selected - #arguments - optional collection of arguments passed to the selector - #balloonText - optional 'tool tip' style help text - #icon- optional icon selector or Form - - note, nil elements will add a line." - | item | - dataForMenuDicts do: [ :dict | - dict - ifNil: [ aMenu addLine ] - ifNotNil: [ | realTarget | - realTarget _ dict at: #object. - realTarget == #myWorld ifTrue: [realTarget _ myWorld]. - realTarget == #theWorldMenu ifTrue: [realTarget _ self]. - item _ (dict at: #label) isSymbol - ifTrue: [ - aMenu - addUpdating: (dict at: #label) - target: realTarget - action: (dict at: #selector) - argumentList: - (dict - at: #arguments - ifAbsent: [ #() ]) ] - ifFalse: [ - aMenu - add: (dict at: #label) - target: realTarget - action: (dict at: #selector) - argumentList: - (dict - at: #arguments - ifAbsent: [ #() ]) ]. - dict - at: #icon - ifPresent: [ :symbolOrFormOrNil | - item setIcon: symbolOrFormOrNil ]. - dict - at: #balloonText - ifPresent: [ :balloonText | - item setBalloonText: balloonText ]. - ]]. - ^ aMenu! ! -!TheWorldMenu methodsFor: 'mechanics' stamp: 'jmv 5/1/2018 21:24:40' prior: 16935161! - menu: titleString - "Create a menu with the given title, ready for filling" - - | menu | - (menu _ MenuMorph entitled: titleString) - defaultTarget: self; - addStayUpIcons. - ^ menu -! ! - -TheWorldMenu removeSelector: #changesDo! - -TheWorldMenu removeSelector: #changesDo! - -TheWorldMenu removeSelector: #colorForDebugging:! - -TheWorldMenu removeSelector: #colorForDebugging:! - -TheWorldMenu removeSelector: #debugDo! - -TheWorldMenu removeSelector: #debugDo! - -TheWorldMenu removeSelector: #helpDo! - -TheWorldMenu removeSelector: #helpDo! - -TheWorldMenu removeSelector: #openWindow! - -TheWorldMenu removeSelector: #openWindow! - -TheWorldMenu removeSelector: #preferencesDo! - -TheWorldMenu removeSelector: #preferencesDo! - -TheWorldMenu removeSelector: #windowsDo! - -TheWorldMenu removeSelector: #windowsDo! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3307-BigMenuRefactor-p10-JuanVuletich-2018May02-14h21m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3307] on 2 May 2018 at 5:47:44 pm'! - -MenuItemMorph subclass: #UpdatingMenuItemMorph - instanceVariableNames: 'wordingProvider wordingSelector enablementSelector ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #UpdatingMenuItemMorph category: #'Morphic-Menus'! -MenuItemMorph subclass: #UpdatingMenuItemMorph - instanceVariableNames: 'wordingProvider wordingSelector enablementSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! -!UpdatingMenuItemMorph methodsFor: 'world' stamp: 'jmv 5/2/2018 17:46:11' prior: 50392500! - updateContents - "Update the receiver's contents" - - | newString nArgs | - ((wordingProvider isNil) or: [wordingSelector isNil]) ifFalse: [ - nArgs _ wordingSelector numArgs. - newString _ nArgs = 0 - ifTrue: [ - wordingProvider perform: wordingSelector] - ifFalse: [ - nArgs = arguments size ifTrue: [ - wordingProvider perform: wordingSelector withArguments: arguments]]. - newString = (contentString ifNil: [ contents ]) - ifFalse: [ - self contents: newString ]]! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/2/2018 16:57:32' prior: 50375676! - changesMenu - "Build the changes menu for the world." - - ^ self - fillIn: (self menu: 'Changes...') - fromDictionaries: `{ - { - #label -> 'Change Sorter'. - #object -> ChangeSorterWindow. - #selector -> #openChangeSorter. - #icon -> #halfRefreshIcon. - #balloonText -> 'Open a 3-paned changed-set viewing tool'. - } asDictionary. - nil. - { - #label -> 'Install New Updates'. - #object -> ChangeSet. - #selector -> #installNewUpdates. - #icon -> #updateIcon. - #balloonText -> 'Install in the current image the new updates available -in directory named ./CoreUpdates -or in directory named ../Cuis-Smalltalk-Dev/CoreUpdates'. - } asDictionary. - nil. - { - #label -> 'Browse my Changes'. - #object -> Smalltalk. - #selector -> #browseMyChanges. - #icon -> #editFindReplaceIcon. - #balloonText -> 'Browse all of my changes since the last time #condenseSources was run.'. - } asDictionary. - { - #label -> 'Recently logged Changes...'. - #object -> ChangeList. - #selector -> #browseRecentLog. - #icon -> #clockIcon. - #balloonText -> 'Open a change-list browser on the latter part of the changes log. You can use this browser to recover logged changes which were not saved in your image, in the event of a crash or other interruption.'. - } asDictionary. - nil. - { - #label -> 'Save World as morph file'. - #object -> #theWorldMenu. - #selector -> #saveWorldInFile. - #icon -> #morphsIcon. - #balloonText -> 'Save a file that, when reloaded, reconstitutes the current World.'. - } asDictionary. - }`! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/2/2018 16:58:03' prior: 16934864! - debugMenu - - ^ self - fillIn: (self menu: 'Debug...') - fromDictionaries: `{ - { - #label -> 'Inspect World'. - #object -> #myWorld. - #selector -> #inspect. - #icon -> #inspectIcon. - } asDictionary. - { - #label -> 'Explore World'. - #object -> #myWorld. - #selector -> #explore. - #icon -> #exploreIcon. - } asDictionary. - { - #label -> 'MessageTally all Processes'. - #object -> #theWorldMenu. - #selector -> #startMessageTally. - #icon -> #systemMonitorIcon. - } asDictionary. - { - #label -> 'MessageTally UI and Browse'. - #object -> #theWorldMenu. - #selector -> #startThenBrowseMessageTally. - #icon -> #editFindReplaceIcon. - } asDictionary. - nil. - { - #label -> 'Start drawing all again'. - #object -> #myWorld. - #selector -> #removeAllKnownFailing. - #icon -> #graphicsIcon. - } asDictionary. - { - #label -> 'Start stepping again'. - #object -> #myWorld. - #selector -> #resumeAfterStepError. - #icon -> #mediaPlaybackStartIcon. - } asDictionary. - { - #label -> 'Close all Debuggers'. - #object -> DebuggerWindow. - #selector -> #closeAllDebuggers. - #icon -> #closeIcon. - } asDictionary. - }`! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/2/2018 17:16:07' prior: 50394014! -fillIn: aMenu fromDictionaries: dataForMenuDicts - "A menu constructor utility that uses Dictionaries with elements: - #label - the name that displays in the menu - #object - the target object - #selector - the selector called on object when the menu item is selected - #arguments - optional collection of arguments passed to the selector - #balloonText - optional 'tool tip' style help text - #icon- optional icon selector or Form - - note, nil elements will add a line." - | item wantsIcons | - wantsIcons _ Preferences wantsMenuIcons. - dataForMenuDicts do: [ :dict | - dict - ifNil: [ aMenu addLine ] - ifNotNil: [ | realTarget | - realTarget _ dict at: #object. - realTarget == #myWorld ifTrue: [realTarget _ myWorld]. - realTarget == #theWorldMenu ifTrue: [realTarget _ self]. - item _ (dict at: #label) isSymbol - ifTrue: [ - aMenu - addUpdating: (dict at: #label) - target: realTarget - action: (dict at: #selector) - argumentList: - (dict - at: #arguments - ifAbsent: [ #() ]) ] - ifFalse: [ - aMenu - add: (dict at: #label) - target: realTarget - action: (dict at: #selector) - argumentList: - (dict - at: #arguments - ifAbsent: [ #() ]) ]. - wantsIcons ifTrue: [ - dict - at: #icon - ifPresent: [ :symbolOrFormOrNil | - item setIcon: symbolOrFormOrNil ]]. - dict - at: #balloonText - ifPresent: [ :balloonText | - item setBalloonText: balloonText ]. - ]]. - ^ aMenu! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/2/2018 16:56:08' prior: 16934966! - helpMenu - "Build the help menu for the world." - - ^ self - fillIn: (self menu: 'Help...') - fromDictionaries: `{ - { - #label -> 'About this System...'. - #object -> Smalltalk. - #selector -> #aboutThisSystem. - #icon -> #helpIcon. - #balloonText -> 'current version information.' - } asDictionary. - { - #label -> 'Terse Guide to Cuis'. - #object -> #theWorldMenu. - #selector -> #openTerseGuide. - #icon -> #helpIcon. - #balloonText -> 'explore Cuis Smalltalk' - } asDictionary. - { - #label -> 'Class Comment Browser'. - #object -> #theWorldMenu. - #selector -> #openCommentGuide. - #icon -> #helpIcon. - #balloonText -> 'search & explore Cuis Class Comments' - } asDictionary. - { - #label -> 'Code management in Cuis'. - #object -> Utilities. - #selector -> #openCodeManagementInCuis. - #icon -> #helpIcon. - #balloonText -> 'Features are kept in Packages.' - } asDictionary. - { - #label -> 'Using GitHub to host Cuis packages'. - #object -> Utilities. - #selector -> #openCuisAndGitHub. - #icon -> #helpIcon. - #balloonText -> 'GitHub usage pattern.' - } asDictionary. - nil. - { - #label -> 'Editor keyboard shortcuts'. - #object -> SmalltalkEditor. - #selector -> #openHelp. - #icon -> #keyboardShortcutsIcon. - #balloonText -> 'summary of keyboard shortcuts in editors for Smalltalk code.' - } asDictionary. - { - #label -> 'Useful Expressions'. - #object -> Utilities. - #selector -> #openUsefulExpressions. - #icon -> #chatIcon. - #balloonText -> 'a window full of useful expressions.' - } asDictionary. - nil. - { - #label -> 'VM Statistics'. - #object -> #theWorldMenu. - #selector -> #vmStatistics. - #icon -> #systemMonitorIcon. - #balloonText -> 'obtain some intriguing data about the vm.' - } asDictionary. - { - #label -> 'Space Left'. - #object -> #theWorldMenu. - #selector -> #garbageCollect. - #icon -> #removableMediaIcon. - #balloonText -> 'perform a full garbage-collection and report how many bytes of space remain in the image.' - } asDictionary. - }`! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/2/2018 17:12:47' prior: 16935088! - preferencesMenu - "Build the preferences menu for the world." - - ^ self - fillIn: (self menu: 'Preferences...') - fromDictionaries: `{ - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Font Sizes...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #object -> #theWorldMenu. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #object -> #theWorldMenu. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set display depth...'. - #object -> #theWorldMenu. - #selector -> #setDisplayDepth. - #icon -> #displayIcon. - #balloonText -> 'choose how many bits per pixel.' - } asDictionary. - { - #label -> 'Set desktop color...'. - #object -> #theWorldMenu. - #selector -> #changeBackgroundColor. - #icon -> #wallpaperIcon. - #balloonText -> 'choose a uniform color to use as desktop background.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }`! ! -!TheWorldMenu methodsFor: 'windows & flaps menu' stamp: 'jmv 5/2/2018 17:42:52' prior: 16935213! - windowsMenu - "Build the windows menu for the world." - - ^ self - fillIn: (self menu: 'Windows') - fromDictionaries: `{ - { - #label -> 'Find Window'. - #object -> #myWorld. - #selector -> #findWindow:. - #icon -> #windowIcon. - #balloonText -> 'Presents a list of all windows; if you choose one from the list, it becomes the active window.' - } asDictionary. - { - #label -> 'Find changed Browsers...'. - #object -> #myWorld. - #selector -> #findDirtyBrowsers:. - #icon -> #editFindReplaceIcon. - #balloonText -> 'Presents a list of browsers that have unsubmitted changes; if you choose one from the list, it becomes the active window.' - } asDictionary. - { - #label -> 'Find changed Windows...'. - #object -> #myWorld. - #selector -> #findDirtyWindows:. - #icon -> #newWindowIcon. - #balloonText -> 'Presents a list of all windows that have unsubmitted changes; if you choose one from the list, it becomes the active window.' - } asDictionary. - nil. - { - #label -> 'Find a Transcript'. - #object -> #myWorld. - #selector -> #findATranscript:. - #icon -> #printerIcon. - #balloonText -> 'Brings an open Transcript to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find a FileList'. - #object -> #myWorld. - #selector -> #findAFileList:. - #icon -> #systemFileManagerIcon. - #balloonText -> 'Brings an open fileList to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find a Change Sorter'. - #object -> #myWorld. - #selector -> #findAChangeSorter:. - #icon -> #changesIcon. - #balloonText -> 'Brings an open change sorter to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find Message Names'. - #object -> #myWorld. - #selector -> #findAMessageNamesWindow:. - #icon -> #inspectIcon. - #balloonText -> 'Brings an open MessageNames window to the front, creating one if necessary, and makes it the active window' - } asDictionary. - nil. - { - #label -> 'Collapse all Windows'. - #object -> #myWorld. - #selector -> #collapseAll. - #icon -> #collapseIcon. - #balloonText -> 'Reduce all open windows to collapsed forms that only show titles.' - } asDictionary. - { - #label -> 'Restore all Windows'. - #object -> #myWorld. - #selector -> #restoreAll. - #icon -> #expandIcon. - #balloonText -> 'Restore all collapsed windows back to their previous forms.' - } asDictionary. - { - #label -> 'Close top Window'. - #object -> SystemWindow. - #selector -> #closeTopWindow. - #icon -> #closeIcon. - #balloonText -> 'Close the topmost window if possible.' - } asDictionary. - { - #label -> 'Send top Window to back'. - #object -> SystemWindow. - #selector -> #sendTopWindowToBack. - #icon -> #goBottomIcon. - #balloonText -> 'Make the topmost window become the backmost one, and activate the window just beneath it.' - } asDictionary. - { - #label -> 'Move Windows onscreen'. - #object -> #myWorld. - #selector -> #bringWindowsFullOnscreen. - #icon -> #displayIcon. - #balloonText -> 'Make all windows fully visible on the screen' - } asDictionary. - nil. - { - #label -> 'Delete unchanged Windows'. - #object -> #myWorld. - #selector -> #closeUnchangedWindows. - #icon -> #warningIcon. - #balloonText -> 'Deletes all windows that do not have unsaved text edits.' - } asDictionary. - { - #label -> 'Delete non Windows'. - #object -> #myWorld. - #selector -> #deleteNonWindows. - #icon -> #warningIcon. - #balloonText -> 'Deletes all non-window morphs lying on the world.' - } asDictionary. - { - #label -> 'Delete Both of the Above'. - #object -> #theWorldMenu. - #selector -> #cleanUpWorld. - #icon -> #warningIcon. - #balloonText -> 'Deletes all unchanged windows and also all non-window morphs lying on the world, other than flaps.' - } asDictionary. - }`! ! - -TheWorldMenu removeSelector: #doMenuItem:with:! - -TheWorldMenu removeSelector: #doMenuItem:with:! - -TheWorldMenu removeSelector: #fillIn:from:! - -TheWorldMenu removeSelector: #fillIn:from:! - -UpdatingMenuItemMorph removeSelector: #enablement! - -UpdatingMenuItemMorph removeSelector: #enablement! - -UpdatingMenuItemMorph removeSelector: #enablementSelector:! - -UpdatingMenuItemMorph removeSelector: #enablementSelector:! - -MenuItemMorph subclass: #UpdatingMenuItemMorph - instanceVariableNames: 'wordingProvider wordingSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #UpdatingMenuItemMorph category: #'Morphic-Menus'! -MenuItemMorph subclass: #UpdatingMenuItemMorph - instanceVariableNames: 'wordingProvider wordingSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3308-BigMenuRefactor-p11-JuanVuletich-2018May02-16h53m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3307] on 2 May 2018 at 5:54:32 pm'! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 5/2/2018 17:48:28' prior: 16898194! - initialFrameFor: aView initialExtent: initialExtent world: aWorld - "Find a plausible initial screen area for the supplied view, which should be a StandardSystemView, taking into account the 'reverseWindowStagger' Preference, the size needed, and other windows currently on the screen." - - ^ self - strictlyStaggeredInitialFrameFor: aView - initialExtent: initialExtent - world: aWorld! ! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 5/2/2018 17:49:23' prior: 50383205! - standardWindowExtent - "Answer the standard default extent for new windows. " - - | grid allowedArea maxLevel | - "NOTE: following copied from strictlyStaggeredInitialFrameFor:" - allowedArea _ self maximumUsableArea insetBy: ( - self scrollBarSetback @ self screenTopSetback extent: `0@0` - ). - "Number to be staggered at each corner (less on small screens)" - maxLevel _ allowedArea area > 700000 ifTrue: [3] ifFalse: [2]. - "Amount by which to stagger (less on small screens)" - grid _ allowedArea area > 700000 ifTrue: [40] ifFalse: [20]. - ^ (allowedArea extent - (grid*(maxLevel+1*2) + (grid//2))) min: `52@40` * Preferences standardCodeFont height! ! - -TheWorldMenu removeSelector: #staggerPolicyString! - -TheWorldMenu removeSelector: #staggerPolicyString! - -TheWorldMenu removeSelector: #toggleWindowPolicy! - -TheWorldMenu removeSelector: #toggleWindowPolicy! - -RealEstateAgent class removeSelector: #staggerOffset! - -RealEstateAgent class removeSelector: #staggerOffset! - -RealEstateAgent class removeSelector: #standardPositionsInWorld:! - -RealEstateAgent class removeSelector: #standardPositionsInWorld:! - -RealEstateAgent class removeSelector: #windowColumnsDesired! - -RealEstateAgent class removeSelector: #windowColumnsDesired! - -RealEstateAgent class removeSelector: #windowRowsDesired! - -RealEstateAgent class removeSelector: #windowRowsDesired! - -Preferences class removeSelector: #reverseWindowStagger! - -Preferences class removeSelector: #reverseWindowStagger! - -Preferences class removeSelector: #staggerPolicyString! - -Preferences class removeSelector: #staggerPolicyString! - -Preferences class removeSelector: #toggleWindowPolicy! - -Preferences class removeSelector: #toggleWindowPolicy! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3309-RealEstateAgent-simplification-JuanVuletich-2018May02-17h47m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3309] on 5 May 2018 at 5:09:03 pm'! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/5/2018 16:57:30'! - buildFromDictionaries: dataForMenuDicts - "A menu constructor utility that uses Dictionaries with elements: - #label - the name that displays in the menu - #object - the target object. If nil, use defaultTarget. If a Symbol, send it as message to defaultTarget to get real target. - #selector - the selector called on object when the menu item is selected - #arguments - optional collection of arguments passed to the selector - #balloonText - optional 'tool tip' style help text - #icon- optional icon selector or Form - - note, nil elements will add a line." - | item wantsIcons | - wantsIcons _ Preferences wantsMenuIcons. - dataForMenuDicts do: [ :dict | - dict - ifNil: [ self addLine ] - ifNotNil: [ | realTarget | - realTarget _ dict at: #object ifAbsent: [defaultTarget]. - realTarget isSymbol ifTrue: [ realTarget _ defaultTarget perform: realTarget ]. - item _ (dict at: #label) isSymbol - ifTrue: [ - self - addUpdating: (dict at: #label) - target: realTarget - action: (dict at: #selector) - argumentList: - (dict - at: #arguments - ifAbsent: [ #() ]) ] - ifFalse: [ - self - add: (dict at: #label) - target: realTarget - action: (dict at: #selector) - argumentList: - (dict - at: #arguments - ifAbsent: [ #() ]) ]. - wantsIcons ifTrue: [ - dict - at: #icon - ifPresent: [ :symbolOrFormOrNil | - item setIcon: symbolOrFormOrNil ]]. - dict - at: #balloonText - ifPresent: [ :balloonText | - item setBalloonText: balloonText ]. - ]]! ! -!TheWorldMenu methodsFor: 'mechanics' stamp: 'jmv 5/5/2018 17:03:51'! - myWorld - ^ myWorld! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/5/2018 17:03:26' prior: 50393900! - buildWorldMenu - "Build the menu that is put up when the screen-desktop is clicked on" - - ^(MenuMorph new defaultTarget: self) - addStayUpIcons; - buildFromDictionaries: `{ - { - #label -> 'Open...'. - #selector -> #openOpenMenu. - #icon -> #openIcon. - #balloonText -> 'Submenu to open various system tools'. - } asDictionary. - { - #label -> 'New morph...'. - #selector -> #newMorph. - #icon -> #morphsIcon. - #balloonText -> 'Offers a variety of ways to create new objects'. - } asDictionary. - { - #label -> 'Preferences...'. - #selector -> #openPreferencesMenu. - #icon -> #preferencesIcon. - #balloonText -> 'Opens a menu offering many controls over appearance and system preferences.'. - } asDictionary. - { - #label -> 'Windows...'. - #selector -> #openWindowsMenu. - #icon -> #windowIcon. - #balloonText -> 'Manage open windows'. - } asDictionary. - { - #label -> 'Help...'. - #selector -> #openHelpMenu. - #icon -> #helpIcon. - #balloonText -> 'Opens a menu of useful items for updating the system, determining what version you are running, and much else'. - } asDictionary. - nil. - { - #label -> 'Changes...'. - #selector -> #openChangesMenu. - #icon -> #changesIcon. - #balloonText -> 'Opens a menu of useful tools for dealing with changes'. - } asDictionary. - { - #label -> 'Debug...'. - #selector -> #openDebugMenu. - #icon -> #debugIcon. - #balloonText -> 'a menu of debugging items'. - } asDictionary. - { - #label -> 'Restore Display (r)'. - #object -> #myWorld. - #selector -> #restoreDisplay. - #icon -> #displayIcon. - #balloonText -> 'Repaint the screen -- useful for removing unwanted display artifacts, lingering cursors, etc.'. - } asDictionary. - nil. - { - #label -> 'Save'. - #object -> Smalltalk. - #selector -> #saveSession. - #icon -> #saveIcon. - #balloonText -> 'Save the current version of the image on disk'. - } asDictionary. - { - #label -> 'Save as...'. - #object -> Smalltalk. - #selector -> #saveAs. - #icon -> #saveAsIcon. - #balloonText -> 'Save the current version of the image on disk under a new name.'. - } asDictionary. - { - #label -> 'Save as New Version'. - #object -> Smalltalk. - #selector -> #saveAsNewVersion. - #icon -> #saveAsNewVersionIcon. - #balloonText -> ('Save the current image a new version-stamped name\and save it under that name on disk.\', - 'Clear all user preferences and user state (class vars).') withNewLines. - } asDictionary. - { - #label -> 'Save and Quit'. - #selector -> #saveAndQuit. - #icon -> #saveAndQuitIcon. - #balloonText -> 'Save the image and quit out of Cuis.'. - } asDictionary. - { - #label -> 'Quit'. - #selector -> #quitSession. - #icon -> #quitIcon. - #balloonText -> 'Quit out of Cuis.'. - } asDictionary. - }`! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/5/2018 17:01:58' prior: 50394130! - changesMenu - "Build the changes menu for the world." - - ^ (self menu: 'Changes...') - buildFromDictionaries: `{ - { - #label -> 'Change Sorter'. - #object -> ChangeSorterWindow. - #selector -> #openChangeSorter. - #icon -> #halfRefreshIcon. - #balloonText -> 'Open a 3-paned changed-set viewing tool'. - } asDictionary. - nil. - { - #label -> 'Install New Updates'. - #object -> ChangeSet. - #selector -> #installNewUpdates. - #icon -> #updateIcon. - #balloonText -> 'Install in the current image the new updates available -in directory named ./CoreUpdates -or in directory named ../Cuis-Smalltalk-Dev/CoreUpdates'. - } asDictionary. - nil. - { - #label -> 'Browse my Changes'. - #object -> Smalltalk. - #selector -> #browseMyChanges. - #icon -> #editFindReplaceIcon. - #balloonText -> 'Browse all of my changes since the last time #condenseSources was run.'. - } asDictionary. - { - #label -> 'Recently logged Changes...'. - #object -> ChangeList. - #selector -> #browseRecentLog. - #icon -> #clockIcon. - #balloonText -> 'Open a change-list browser on the latter part of the changes log. You can use this browser to recover logged changes which were not saved in your image, in the event of a crash or other interruption.'. - } asDictionary. - nil. - { - #label -> 'Save World as morph file'. - #selector -> #saveWorldInFile. - #icon -> #morphsIcon. - #balloonText -> 'Save a file that, when reloaded, reconstitutes the current World.'. - } asDictionary. - }`! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/5/2018 17:04:31' prior: 50394186! - debugMenu - - ^ (self menu: 'Debug...') - buildFromDictionaries: `{ - { - #label -> 'Inspect World'. - #object -> #myWorld. - #selector -> #inspect. - #icon -> #inspectIcon. - } asDictionary. - { - #label -> 'Explore World'. - #object -> #myWorld. - #selector -> #explore. - #icon -> #exploreIcon. - } asDictionary. - { - #label -> 'MessageTally all Processes'. - #selector -> #startMessageTally. - #icon -> #systemMonitorIcon. - } asDictionary. - { - #label -> 'MessageTally UI and Browse'. - #selector -> #startThenBrowseMessageTally. - #icon -> #editFindReplaceIcon. - } asDictionary. - nil. - { - #label -> 'Start drawing all again'. - #object -> #myWorld. - #selector -> #removeAllKnownFailing. - #icon -> #graphicsIcon. - } asDictionary. - { - #label -> 'Start stepping again'. - #object -> #myWorld. - #selector -> #resumeAfterStepError. - #icon -> #mediaPlaybackStartIcon. - } asDictionary. - { - #label -> 'Close all Debuggers'. - #object -> DebuggerWindow. - #selector -> #closeAllDebuggers. - #icon -> #closeIcon. - } asDictionary. - }`! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/5/2018 17:05:32' prior: 50394280! - helpMenu - "Build the help menu for the world." - - ^ (self menu: 'Help...') - buildFromDictionaries: `{ - { - #label -> 'About this System...'. - #object -> Smalltalk. - #selector -> #aboutThisSystem. - #icon -> #helpIcon. - #balloonText -> 'current version information.' - } asDictionary. - { - #label -> 'Terse Guide to Cuis'. - #selector -> #openTerseGuide. - #icon -> #helpIcon. - #balloonText -> 'explore Cuis Smalltalk' - } asDictionary. - { - #label -> 'Class Comment Browser'. - #selector -> #openCommentGuide. - #icon -> #helpIcon. - #balloonText -> 'search & explore Cuis Class Comments' - } asDictionary. - { - #label -> 'Code management in Cuis'. - #object -> Utilities. - #selector -> #openCodeManagementInCuis. - #icon -> #helpIcon. - #balloonText -> 'Features are kept in Packages.' - } asDictionary. - { - #label -> 'Using GitHub to host Cuis packages'. - #object -> Utilities. - #selector -> #openCuisAndGitHub. - #icon -> #helpIcon. - #balloonText -> 'GitHub usage pattern.' - } asDictionary. - nil. - { - #label -> 'Editor keyboard shortcuts'. - #object -> SmalltalkEditor. - #selector -> #openHelp. - #icon -> #keyboardShortcutsIcon. - #balloonText -> 'summary of keyboard shortcuts in editors for Smalltalk code.' - } asDictionary. - { - #label -> 'Useful Expressions'. - #object -> Utilities. - #selector -> #openUsefulExpressions. - #icon -> #chatIcon. - #balloonText -> 'a window full of useful expressions.' - } asDictionary. - nil. - { - #label -> 'VM Statistics'. - #selector -> #vmStatistics. - #icon -> #systemMonitorIcon. - #balloonText -> 'obtain some intriguing data about the vm.' - } asDictionary. - { - #label -> 'Space Left'. - #selector -> #garbageCollect. - #icon -> #removableMediaIcon. - #balloonText -> 'perform a full garbage-collection and report how many bytes of space remain in the image.' - } asDictionary. - }`! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/5/2018 17:06:38' prior: 16935052! - openMenu - "Build the open window menu for the world." - | menu items groups firstGroup itemsSorted itemsBase | - menu _ self menu: 'Open...'. - itemsBase _ (Smalltalk allClassesImplementing: #worldMenuForOpenGroup) - collect: [ :item | - item class == Metaclass ifTrue: [ - item soleInstance - worldMenuForOpenGroup ] ] - thenSelect: [ :item | - item notNil ]. - items _ OrderedCollection new. - "A single class may add more than one item to a menu" - itemsBase do: [ :item | - item class == Dictionary - ifTrue: [ items add: item ] - ifFalse: [ items addAll: item ]]. - groups _ (items collect: [ :item | - item at: #itemGroup ]) asSet asSortedCollection. - itemsSorted _ OrderedCollection new. - firstGroup _ true. - groups do: [ :group | - firstGroup - ifTrue: [ firstGroup _ false ] - ifFalse: [ itemsSorted add: nil ]. - ((items select: [ :item | - (item at: #itemGroup) = group ]) sort: [ :item1 :item2 | - (item1 at: #itemOrder) < (item2 at: #itemOrder) ]) do: [ :item | - itemsSorted add: item ]]. - menu buildFromDictionaries: itemsSorted. - ^ menu.! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/5/2018 17:07:28' prior: 50394355! - preferencesMenu - "Build the preferences menu for the world." - - ^ (self menu: 'Preferences...') - buildFromDictionaries: `{ - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Font Sizes...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set display depth...'. - #selector -> #setDisplayDepth. - #icon -> #displayIcon. - #balloonText -> 'choose how many bits per pixel.' - } asDictionary. - { - #label -> 'Set desktop color...'. - #selector -> #changeBackgroundColor. - #icon -> #wallpaperIcon. - #balloonText -> 'choose a uniform color to use as desktop background.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }`! ! -!TheWorldMenu methodsFor: 'windows & flaps menu' stamp: 'jmv 5/5/2018 17:08:12' prior: 50394460! - windowsMenu - "Build the windows menu for the world." - - ^ (self menu: 'Windows') - buildFromDictionaries: `{ - { - #label -> 'Find Window'. - #object -> #myWorld. - #selector -> #findWindow:. - #icon -> #windowIcon. - #balloonText -> 'Presents a list of all windows; if you choose one from the list, it becomes the active window.' - } asDictionary. - { - #label -> 'Find changed Browsers...'. - #object -> #myWorld. - #selector -> #findDirtyBrowsers:. - #icon -> #editFindReplaceIcon. - #balloonText -> 'Presents a list of browsers that have unsubmitted changes; if you choose one from the list, it becomes the active window.' - } asDictionary. - { - #label -> 'Find changed Windows...'. - #object -> #myWorld. - #selector -> #findDirtyWindows:. - #icon -> #newWindowIcon. - #balloonText -> 'Presents a list of all windows that have unsubmitted changes; if you choose one from the list, it becomes the active window.' - } asDictionary. - nil. - { - #label -> 'Find a Transcript'. - #object -> #myWorld. - #selector -> #findATranscript:. - #icon -> #printerIcon. - #balloonText -> 'Brings an open Transcript to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find a FileList'. - #object -> #myWorld. - #selector -> #findAFileList:. - #icon -> #systemFileManagerIcon. - #balloonText -> 'Brings an open fileList to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find a Change Sorter'. - #object -> #myWorld. - #selector -> #findAChangeSorter:. - #icon -> #changesIcon. - #balloonText -> 'Brings an open change sorter to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find Message Names'. - #object -> #myWorld. - #selector -> #findAMessageNamesWindow:. - #icon -> #inspectIcon. - #balloonText -> 'Brings an open MessageNames window to the front, creating one if necessary, and makes it the active window' - } asDictionary. - nil. - { - #label -> 'Collapse all Windows'. - #object -> #myWorld. - #selector -> #collapseAll. - #icon -> #collapseIcon. - #balloonText -> 'Reduce all open windows to collapsed forms that only show titles.' - } asDictionary. - { - #label -> 'Restore all Windows'. - #object -> #myWorld. - #selector -> #restoreAll. - #icon -> #expandIcon. - #balloonText -> 'Restore all collapsed windows back to their previous forms.' - } asDictionary. - { - #label -> 'Close top Window'. - #object -> SystemWindow. - #selector -> #closeTopWindow. - #icon -> #closeIcon. - #balloonText -> 'Close the topmost window if possible.' - } asDictionary. - { - #label -> 'Send top Window to back'. - #object -> SystemWindow. - #selector -> #sendTopWindowToBack. - #icon -> #goBottomIcon. - #balloonText -> 'Make the topmost window become the backmost one, and activate the window just beneath it.' - } asDictionary. - { - #label -> 'Move Windows onscreen'. - #object -> #myWorld. - #selector -> #bringWindowsFullOnscreen. - #icon -> #displayIcon. - #balloonText -> 'Make all windows fully visible on the screen' - } asDictionary. - nil. - { - #label -> 'Delete unchanged Windows'. - #object -> #myWorld. - #selector -> #closeUnchangedWindows. - #icon -> #warningIcon. - #balloonText -> 'Deletes all windows that do not have unsaved text edits.' - } asDictionary. - { - #label -> 'Delete non Windows'. - #object -> #myWorld. - #selector -> #deleteNonWindows. - #icon -> #warningIcon. - #balloonText -> 'Deletes all non-window morphs lying on the world.' - } asDictionary. - { - #label -> 'Delete Both of the Above'. - #selector -> #cleanUpWorld. - #icon -> #warningIcon. - #balloonText -> 'Deletes all unchanged windows and also all non-window morphs lying on the world, other than flaps.' - } asDictionary. - }`! ! - -TheWorldMenu removeSelector: #fillIn:fromDictionaries:! - -TheWorldMenu removeSelector: #fillIn:fromDictionaries:! - -TheWorldMenu removeSelector: #world! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3310-BigMenuRefactor-p12-JuanVuletich-2018May05-16h48m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3309] on 5 May 2018 at 5:51:50 pm'! - -TextEditor class - instanceVariableNames: 'menu '! - -!classDefinition: 'TextEditor class' category: #'System-Text'! -TextEditor class - instanceVariableNames: 'menu'! - -SmalltalkEditor class - instanceVariableNames: 'menu2 '! - -!classDefinition: 'SmalltalkEditor class' category: #'System-Text'! -SmalltalkEditor class - instanceVariableNames: 'menu2'! -!SmalltalkEditor methodsFor: 'menu' stamp: 'jmv 5/5/2018 17:40:51'! - getMenu - - ^(MenuMorph new defaultTarget: self) - addTitle: self class name; - addStayUpIcons; - buildFromDictionaries: `{ - { - #label -> 'Help...'. - #selector -> #openHelp. - #icon -> #helpIcon - } asDictionary. - nil. - { - #label -> 'Do it (d)'. - #selector -> #doIt. - #icon -> #doItIcon - } asDictionary. - { - #label -> 'Print it (p)'. - #selector -> #printIt. - #icon -> #printIcon - } asDictionary. - { - #label -> 'Inspect it (i)'. - #selector -> #inspectIt. - #icon -> #inspectIcon - } asDictionary. - { - #label -> 'Explore it (I)'. - #selector -> #exploreIt. - #icon -> #exploreIcon - } asDictionary. - { - #label -> 'Debug it (D)'. - #selector -> #debugIt. - #icon -> #debugIcon - } asDictionary. - { - #label -> 'Profile it'. - #selector -> #profileIt. - #icon -> #clockIcon - } asDictionary. - nil. - { - #label -> 'Explain'. - #selector -> #explain. - #icon -> #helpIcon - } asDictionary. - { - #label -> 'Browse it (b)'. - #selector -> #browseIt. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'Senders of it (n)'. - #selector -> #sendersOfIt. - #icon -> #mailForwardIcon - } asDictionary. - { - #label -> 'Implementors of it (m)'. - #selector -> #implementorsOfIt. - #icon -> #developmentIcon - } asDictionary. - { - #label -> 'References to it (N)'. - #selector -> #referencesToIt. - #icon -> #addressBookIcon - } asDictionary. - nil. - { - #label -> 'Method Strings with it (E)'. - #selector -> #methodStringsContainingit. - #icon -> #genericTextIcon - } asDictionary. - { - #label -> 'Method Source with it'. - #selector -> #methodSourceContainingIt. - #icon -> #scriptIcon - } asDictionary. - { - #label -> 'Class Comments with it'. - #selector -> #classCommentsContainingIt. - #icon -> #chatIcon - } asDictionary. - nil. - { - #label -> 'Accept (s)'. - #selector -> #acceptContents. - #icon -> #acceptIcon - } asDictionary. - { - #label -> 'Cancel (l)'. - #selector -> #cancelEdits. - #icon -> #cancelIcon - } asDictionary. - { - #label -> 'Accept & Run Test in Class (t)'. - #selector -> #acceptAndTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #label -> 'Accept & Run Test in Category (y)'. - #selector -> #acceptAndTestAll. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #label -> 'Accept & Debug Test (r)'. - #selector -> #acceptAndDebugTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - nil. - { - #label -> 'More...'. - #selector -> #openMenu2. - #icon -> #listAddIcon - } asDictionary. - }`! ! -!SmalltalkEditor methodsFor: 'menu' stamp: 'jmv 5/5/2018 17:42:25'! - openMenu - - self getMenu popUpInWorld: morph world! ! -!SmalltalkEditor methodsFor: 'menu' stamp: 'jmv 5/5/2018 17:45:22'! - openMenu2 - - (MenuMorph new defaultTarget: self) - addTitle: self class name; - addStayUpIcons; - buildFromDictionaries: `{ - { - #label -> 'Find...(f)'. - #selector -> #find. - #icon -> #findIcon - } asDictionary. - { - #label -> 'Find Again (g)'. - #selector -> #findAgain. - #icon -> #systemIcon - } asDictionary. - { - #label -> 'Use Selection for Find (j)'. - #selector -> #setSearchString. - #icon -> #saveAsIcon - } asDictionary. - nil. - { - #label -> 'Undo - multiple (z)'. - #selector -> #undo. - #icon -> #undoIcon - } asDictionary. - { - #label -> 'Redo - multiple (Z)'. - #selector -> #redo. - #icon -> #redoIcon - } asDictionary. - { - #label -> 'Undo / Redo history'. - #selector -> #offerUndoHistory. - #icon -> #changesIcon - } asDictionary. - nil. - { - #label -> 'Copy (c)'. - #selector -> #copySelection. - #icon -> #copyIcon - } asDictionary. - { - #label -> 'Cut (x)'. - #selector -> #cut. - #icon -> #cutIcon - } asDictionary. - { - #label -> 'Paste (v)'. - #selector -> #paste. - #icon -> #pasteIcon - } asDictionary. - { - #label -> 'Paste without Format'. - #selector -> #pasteString. - #icon -> #pasteIcon - } asDictionary. - { - #label -> 'Paste...'. - #selector -> #pasteRecent. - #icon -> #worldIcon - } asDictionary. - nil. - { - #label -> 'Toggle WordWrap'. - #selector -> #wrapOnOff. - #icon -> #genericTextIcon - } asDictionary. - { - #label -> 'Set Font... (k)'. - #selector -> #offerFontMenu. - #icon -> #preferencesDesktopFontIcon - } asDictionary. - { - #label -> 'Clear Font'. - #selector -> #clearFont. - #icon -> #newIcon - } asDictionary. - { - #label -> 'Set Default Font...'. - #selector -> #offerDefaultFontMenu. - #icon -> #fontXGenericIcon - } asDictionary. - nil. - { - #label -> 'More...'. - #selector -> #openMenu. - #icon -> #listAddIcon - } asDictionary. - }`; - popUpInWorld: morph world.! ! -!TextEditor methodsFor: 'menu' stamp: 'jmv 5/5/2018 17:40:36' prior: 16933045! - getMenu - - ^(MenuMorph new defaultTarget: self) - addTitle: self class name; - addStayUpIcons; - buildFromDictionaries: `{ - { - #label -> 'Help...'. - #selector -> #openHelp. - #icon -> #helpIcon - } asDictionary. - nil. - { - #label -> 'Find...(f)'. - #selector -> #find. - #icon -> #findIcon - } asDictionary. - { - #label -> 'Find Again (g)'. - #selector -> #findAgain. - #icon -> #systemIcon - } asDictionary. - { - #label -> 'Use Selection for Find (j)'. - #selector -> #setSearchString. - #icon -> #saveAsIcon - } asDictionary. - nil. - { - #label -> 'Undo - multiple (z)'. - #selector -> #undo. - #icon -> #undoIcon - } asDictionary. - { - #label -> 'Redo - multiple (Z)'. - #selector -> #redo. - #icon -> #redoIcon - } asDictionary. - { - #label -> 'Undo / Redo history'. - #selector -> #offerUndoHistory. - #icon -> #changesIcon - } asDictionary. - nil. - { - #label -> 'Copy (c)'. - #selector -> #copySelection. - #icon -> #copyIcon - } asDictionary. - { - #label -> 'Cut (x)'. - #selector -> #cut. - #icon -> #cutIcon - } asDictionary. - { - #label -> 'Paste (v)'. - #selector -> #paste. - #icon -> #pasteIcon - } asDictionary. - { - #label -> 'Paste without Format'. - #selector -> #pasteString. - #icon -> #pasteIcon - } asDictionary. - { - #label -> 'Paste...'. - #selector -> #pasteRecent. - #icon -> #worldIcon - } asDictionary. - nil. - { - #label -> 'Toggle WordWrap'. - #selector -> #wrapOnOff. - #icon -> #genericTextIcon - } asDictionary. - { - #label -> 'Set Font... (k)'. - #selector -> #offerFontMenu. - #icon -> #preferencesDesktopFontIcon - } asDictionary. - { - #label -> 'Clear Font'. - #selector -> #clearFont. - #icon -> #newIcon - } asDictionary. - { - #label -> 'Set Default Font...'. - #selector -> #offerDefaultFontMenu. - #icon -> #fontXGenericIcon - } asDictionary. - { - #label -> 'Set Alignment...'. - #selector -> #chooseAlignment. - #icon -> #formatJustifyLeftIcon - } asDictionary. - }`! ! -!TextEditor class methodsFor: 'cached state access' stamp: 'jmv 5/5/2018 17:50:04' prior: 16933239! - releaseClassCachedState - - FindText _ nil. - ChangeText _ nil. - "We are not calling super to avoid cleansing class vars many times. - So, repeat inherited class instVars!!" - shortcuts _ nil. - cmdShortcuts _ nil! ! -!SmalltalkEditor class methodsFor: 'cached state access' stamp: 'jmv 5/5/2018 17:50:09' prior: 16910772! - releaseClassCachedState - - "We are not calling super to avoid cleansing class vars many times. - So, repeat inherited class instVars!!" - shortcuts _ nil. - cmdShortcuts _ nil! ! - -SmalltalkEditor class removeSelector: #initializeMenu! - -SmalltalkEditor class removeSelector: #initializeMenu! - -SmalltalkEditor class removeSelector: #menu2! - -SmalltalkEditor class removeSelector: #menu2! - -SmalltalkEditor class removeSelector: #paneMenu2:! - -SmalltalkEditor class removeSelector: #paneMenu2:! - -SmalltalkEditor removeSelector: #getMenu2! - -SmalltalkEditor removeSelector: #getMenu2! - -TextEditor class removeSelector: #basicInitialize! - -TextEditor class removeSelector: #basicInitialize! - -TextEditor class removeSelector: #initializeMenu! - -TextEditor class removeSelector: #initializeMenu! - -TextEditor class removeSelector: #menu! - -TextEditor class removeSelector: #menu! - -TextEditor class removeSelector: #paneMenu:! - -TextEditor class removeSelector: #paneMenu:! - -TextEditor class - instanceVariableNames: ''! - -!classDefinition: 'TextEditor class' category: #'System-Text'! -TextEditor class - instanceVariableNames: ''! - -SmalltalkEditor class - instanceVariableNames: ''! - -!classDefinition: 'SmalltalkEditor class' category: #'System-Text'! -SmalltalkEditor class - instanceVariableNames: ''! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3311-BigMenuRefactor-p13-JuanVuletich-2018May05-17h09m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3311] on 5 May 2018 at 7:22:00 pm'! - -SelectionMenu removeSelector: #selections! - -SelectionMenu removeSelector: #selections! - -MenuMorph removeSelector: #addCustomMenuItems:hand:! - -MenuMorph removeSelector: #addCustomMenuItems:hand:! - -MenuMorph removeSelector: #addItem! - -MenuMorph removeSelector: #addItem! - -MenuMorph removeSelector: #addTitle! - -MenuMorph removeSelector: #addTitle! - -MenuMorph removeSelector: #sightTarget:! - -MenuMorph removeSelector: #sightTarget:! - -Smalltalk removeClassNamed: #CustomMenu! - -Smalltalk removeClassNamed: #CustomMenu! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3312-BigMenuRefactor-p14-JuanVuletich-2018May05-19h11m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3311] on 5 May 2018 at 7:48:24 pm'! -!MenuMorph methodsFor: 'modal progress dialog' stamp: 'jmv 5/5/2018 19:37:23'! - displayAt: aPoint during: aBlock - "Add this menu to the Morphic world during the execution of the given block." - - self runningWorld ifNotNil: [ :w | - w addMorph: self centeredNear: aPoint. - self world ifNotNil: [ w displayWorld ]. "show myself" - ]. - aBlock value. - self delete! ! -!MenuMorph methodsFor: 'modal progress dialog' stamp: 'jmv 5/5/2018 19:37:19'! - informUserAt: aPoint during: aBlock - "Add this menu to the Morphic world during the execution of the given block." - - | w titleString | - - titleString _ titleMorph submorphs first. - self visible: false. - w _ self world ifNil: [ self runningWorld ]. - aBlock value: [ :string | - self visible ifFalse: [ - w addMorph: self centeredNear: aPoint. - self visible: true]. - titleString contents: string. - titleMorph morphWidth: titleString morphWidth + 8. - self morphPosition: w activeHand morphPosition. - self adjustSubmorphsLayout. - self redrawNeeded. - w ifNotNil: [ - w displayWorld ]. "show myself" - ]. - self delete. - w ifNotNil: [ - w displayWorld ]! ! -!Utilities class methodsFor: 'user interface' stamp: 'jmv 5/5/2018 19:31:18' prior: 16941500! - informUser: aString during: aBlock - "Display a message above (or below if insufficient room) the cursor during execution of the given block." - - " - Utilities informUser: 'Just a sec!!' during: [(Delay forSeconds: 1) wait] - " - - (MenuMorph entitled: aString) - displayAt: Sensor mousePoint + 60 - during: aBlock! ! -!Utilities class methodsFor: 'user interface' stamp: 'jmv 5/5/2018 19:31:32' prior: 50366496! - informUserDuring: barBlock - "Display a message above (or below if insufficient room) the cursor during execution of the given block." - - " - Utilities informUserDuring:[:barBlock| - #(one two three) do:[:info| - barBlock value: info. - (Delay forSeconds: 1) wait]] - " - - (MenuMorph entitled: ' ') - informUserAt: Sensor mousePoint - during: barBlock! ! -!MenuMorph methodsFor: 'modal control' stamp: 'jmv 5/5/2018 19:34:12' prior: 16867158! - invokeModal - "Invoke this menu and don't return until the user has chosen a value. - See example below on how to use modal menu morphs." - ^ self invokeModal: Preferences menuKeyboardControl - - " - | menu sub entry | - menu _ MenuMorph new. - 1 to: 3 do: [:i | - entry _ 'Line', i printString. - sub _ MenuMorph new. - menu add: entry subMenu: sub. - #('Item A' 'Item B' 'Item C') do:[:subEntry| - sub add: subEntry target: menu - action: #modalSelection: argument: {entry. subEntry}]]. - menu invokeModal. - "! ! -!MVCMenuMorph methodsFor: 'invoking' stamp: 'jmv 3/2/2017 20:08:29' prior: 50340038! - invokeAt: aPoint allowKeyboard: aBoolean - "Add this menu to the given world centered at the given point. Wait for the user to make a selection and answer it. The selection value returned is an integer in keeping with PopUpMenu, if the menu is converted from an MVC-style menu." - "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop." - |actHand w oldFocus | - self flag: #bob. "is global or local?" - self flag: #arNote. " is local to aWorld" - w _ self runningWorld. - actHand _ w activeHand. - oldFocus _ actHand keyboardFocus. - w doOneMinimalCycleNow. - self - popUpAt: aPoint - forHand: actHand - allowKeyboard: aBoolean. - done _ false. - [ self isInWorld & done not ] whileTrue: [ w doOneMinimalCycleNow ]. - self delete. - oldFocus ifNotNil: [ actHand newKeyboardFocus: oldFocus ]. - ^ mvcSelection ! ! -!PopUpMenu class methodsFor: 'dialogs' stamp: 'jmv 5/5/2018 19:38:51' prior: 16891113! - confirm: queryString - "Put up a yes/no menu with caption queryString. Answer true if the - response is yes, false if no. This is a modal question--the user must - respond yes or no." - - " - PopUpMenu confirm: 'Are you hungry?' - " - - ^ self confirm: queryString trueChoice: 'Yes' falseChoice: 'No'! ! - -MVCMenuMorph removeSelector: #displayAt:during:! - -MVCMenuMorph removeSelector: #displayAt:during:! - -MVCMenuMorph removeSelector: #informUserAt:during:! - -MVCMenuMorph removeSelector: #informUserAt:during:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3313-BigMenuRefactor-p15-JuanVuletich-2018May05-19h22m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3311] on 5 May 2018 at 8:47:10 pm'! -!VersionsBrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/5/2018 20:45:15' prior: 16942771! - classCommentVersionsMenu - | aMenu | - aMenu _ MenuMorph new defaultTarget: model. "all commands are implemented by the model, not the view" - aMenu addTitle: 'versions'. - aMenu addStayUpIcons. - aMenu buildFromDictionaries: `{ - { - #label -> 'compare to current'. - #selector -> #compareToCurrentVersion. - #balloonText -> 'compare selected version to the current version' - } asDictionary. - { - #label -> 'revert to selected version'. - #selector -> #fileInSelections. - #balloonText -> 'resubmit the selected version, so that it becomes the current version' - } asDictionary. - nil. - { - #label -> 'toggle diffing (D)'. - #selector -> #toggleDiffing. - #balloonText -> 'toggle whether or not diffs should be shown here' - } asDictionary. - { - #label -> 'update list'. - #selector -> #reformulateList. - #balloonText -> 'reformulate the list of versions, in case it somehow got out of synch with reality' - } asDictionary. - nil. - { - #label -> 'help...'. - #selector -> #offerVersionsHelp. - #balloonText -> 'provide an explanation of the use of this tool' - } asDictionary. - }`. - ^aMenu! ! -!VersionsBrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/5/2018 20:45:08' prior: 16942805! - methodVersionsMenu - "Fill aMenu with menu items appropriate to the receiver" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Versions'. - aMenu addStayUpIcons. - model listIndex > 0 ifTrue:[ - (model list size > 1 ) ifTrue: [ - aMenu buildFromDictionaries: `{ - { - #label -> 'compare to current'. - #object -> #model. - #selector -> #compareToCurrentVersion. - #balloonText -> 'compare selected version to the current version' - } asDictionary. - { - #label -> 'compare to version...'. - #object -> #model. - #selector -> #compareToOtherVersion. - #balloonText -> 'compare selected version to another selected version' - } asDictionary. - }` ]. - "Note: Revert to selected should be visible for lists of length one for having the ability to revert to an accidentally deleted method" - aMenu buildFromDictionaries: `{ - { - #label -> 'revert to selected version'. - #object -> #model. - #selector -> #fileInSelections. - #balloonText -> 'resubmit the selected version, so that it becomes the current version' - } asDictionary. - }` ]. - - aMenu buildFromDictionaries: `{ - { - #label -> 'edit current method (O)'. - #selector -> #openSingleMessageBrowser. - #balloonText -> 'open a single-message browser on the current version of this method' - } asDictionary. - nil. - { - #label -> 'toggle diffing (D)'. - #object -> #model. - #selector -> #toggleDiffing. - #balloonText -> 'toggle whether or not diffs should be shown here' - } asDictionary. - { - #label -> 'update list'. - #object -> #model. - #selector -> #reformulateList. - #balloonText -> 'reformulate the list of versions, in case it somehow got out of synch with reality' - } asDictionary. - nil. - { - #label -> 'senders (n)'. - #selector -> #browseSenders. - #balloonText -> 'browse all senders of this selector' - } asDictionary. - { - #label -> 'implementors (m)'. - #selector -> #browseImplementors. - #balloonText -> 'browse all implementors of this selector' - } asDictionary. - nil. - { - #label -> 'help...'. - #object -> #model. - #selector -> #offerVersionsHelp. - #balloonText -> 'provide an explanation of the use of this tool' - } asDictionary. - }`. - ^aMenu! ! -!ChangeSorterWindow methodsFor: 'menu building' stamp: 'jmv 5/5/2018 20:27:50' prior: 50393458! - changeSetMenu - "Set up aMenu to hold commands for the change-set-list pane. This could be for a single or double changeSorter" - - | aMenu isForBaseSystem | - isForBaseSystem _ model changeSet isForBaseSystem. - aMenu _ MenuMorph new defaultTarget: model. - aMenu addTitle: 'Change Set'. - aMenu addStayUpIcons. - - (aMenu add: 'File out and remove (o)' action: #fileOutAndRemove) isEnabled: isForBaseSystem. - aMenu add: 'File out and keep (k)' action: #fileOutAndKeep. - aMenu addLine. - - (aMenu add: 'Rename change set (r)' action: #rename) isEnabled: isForBaseSystem. - (aMenu add: 'Destroy change set (x)' action: #remove) isEnabled: isForBaseSystem. - aMenu addLine. - model currentCanHavePreambleAndPostscript ifTrue: [ - aMenu addLine. - model currentHasPreamble - ifTrue: [ - aMenu add: 'Edit preamble (p)' action: #addPreamble. - aMenu add: 'Remove preamble' action: #removePreamble] - ifFalse: [ - aMenu add: 'Add preamble (p)' action: #addPreamble]. - model currentHasPostscript - ifTrue: [ - aMenu add: 'Edit postscript...' action: #editPostscript. - aMenu add: 'Remove postscript' action: #removePostscript] - ifFalse: [ - aMenu add: 'Add postscript...' action: #editPostscript]. - ]. - aMenu addLine. - - "CONFLICTS SECTION" - (aMenu add: 'conflicts with other change sets' target: self action: #browseMethodConflicts) - setBalloonText: 'Browse all methods that occur both in this change set and in at least one other change set.'. - aMenu addLine. - - "CHECKS SECTION" - (aMenu add: 'trim history' action: #trimHistory) - isEnabled: isForBaseSystem; - setBalloonText: ' Drops any methods added and then removed, as well as renaming and reorganization of newly-added classes. ', - 'NOTE: can cause confusion if later filed in over an earlier version of these changes'. - - (aMenu add: 'view affected class categories' action: #viewAffectedClassCategories) - setBalloonText: ' Show class categories affected by any contained change'. - - ^ aMenu! ! -!ChangeSorterWindow methodsFor: 'menu building' stamp: 'jmv 5/5/2018 20:27:52' prior: 16800150! - classListMenu - "Fill aMenu with items appropriate for the class list" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'class list'. - aMenu addStayUpIcons. - aMenu addList: #( - - - ('delete class from change set (d)' forgetClass '' model) - ('remove class from system (x)' removeClass '' model) - - - ('browse full (b)' browseMethodFull) - ('browse hierarchy (h)' browseHierarchy) - ('browse protocol (p)' browseFullProtocol) - - - ('inst var refs...' browseInstVarRefs) - ('inst var defs...' browseInstVarDefs) - ('class var refs...' browseClassVarRefs) - ('class vars' browseClassVariables) - ('class refs (N)' browseClassRefs)). - ^ aMenu! ! -!ChangeSorterWindow methodsFor: 'menu building' stamp: 'jmv 5/5/2018 20:27:55' prior: 16800176! - messageMenu - "Fill aMenu with items appropriate for the message list; could be for a single or double changeSorter" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'message list'. - aMenu addStayUpIcons. - aMenu addList: #( - ('delete method from changeSet (d)' forget '' model) - - - ('remove method from system (x)' removeMessage '' model) - - - ('browse full (b)' browseMethodFull) - ('browse hierarchy (h)' browseHierarchy) - ('browse method (O)' openSingleMessageBrowser) - ('browse protocol (p)' browseFullProtocol) - - - ('fileOut' fileOutMessage '' model) - - - ('senders of... (n)' browseSendersOfMessages) - ('implementors of... (m)' browseMessages) - ('inheritance (i)' methodHierarchy) - ('versions (v)' browseVersions)). - ^ aMenu! ! -!TestRunnerWindow methodsFor: 'menu building' stamp: 'jmv 5/5/2018 20:27:58' prior: 50393137! - listMenu - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Test Cases'. - aMenu add: 'select all' target: model action: #selectAll. - aMenu add: 'deselect all' target: model action: #deselectAll. - aMenu add: 'toggle selections' target: model action: #invertSelections. - aMenu add: 'filter' target: model action: #setFilter. - model runButtonState ifTrue: [ - aMenu add: 'stop' target: model action: #terminateRun - ]. - model selectedSuite > 0 ifTrue: [ | cls | - cls _ (model tests at: model selectedSuite ifAbsent: ['']) copyUpTo: Character space. - cls _ cls asSymbol. - cls _ (Smalltalk at: cls ifAbsent: nil). - cls ifNotNil: [ - aMenu addLine. - aMenu add: 'browse' target: self action: #browse: argument: cls. - ]. - ]. - aMenu addLine. - aMenu add: 'log to Transcript' target: model action: #showResult. - ^aMenu! ! - -MenuMorph removeSelector: #title:! - -MenuMorph removeSelector: #title:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3314-BigMenuRefactor-p16-JuanVuletich-2018May05-20h24m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3311] on 5 May 2018 at 8:58:04 pm'! -!CodeWindow methodsFor: 'menu building' stamp: 'jmv 5/5/2018 20:54:23'! - offerClassListMenu - "Offer the shifted class-list menu." - - ^ self classListMenu popUpInWorld! ! -!CodeWindow methodsFor: 'menu building' stamp: 'jmv 5/5/2018 20:53:04'! - offerClassListMenu2 - "Offer the shifted class-list menu." - - ^ self classListMenu2 popUpInWorld! ! -!CodeWindow methodsFor: 'menu building' stamp: 'jmv 5/5/2018 20:50:27'! - openMessageListMenu2 - "Offer the additional selector-list menu" - - ^ self messageListMenu2 popUpInWorld! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/5/2018 20:56:29'! - addExtraMenu2ItemsTo: aMenu - "The shifted selector-list menu is being built; some menu items are appropriate only for certain kinds of browsers, and this gives a hook for them to be added as approrpiate. If any is added here, a line should be added first -- browse reimplementors of this message for examples."! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/5/2018 20:55:04'! - classListMenu2 - "Set up the menu to apply to the receiver's class list when the shift key is down" - - | aMenu | - aMenu := MenuMorph new defaultTarget: self. - aMenu addList: #( - - - ('unsent methods' browseUnusedMethods - 'browse all methods defined by this class that have no senders') - ('unreferenced inst vars' showUnreferencedInstVars - 'show a list of all instance variables that are not referenced in methods') - ('unreferenced class vars' showUnreferencedClassVars - 'show a list of all class variables that are not referenced in methods') - ('subclass template' makeNewSubclass - 'put a template into the code pane for defining of a subclass of this class' model) - - - ('sample instance' makeSampleInstance - 'give me a sample instance of this class, if possible') - ('inspect instances' inspectInstances - 'open an inspector on all the extant instances of this class') - ('inspect subinstances' inspectSubInstances - 'open an inspector on all the extant instances of this class and of all of its subclasses') - - - ('create inst var accessors' createInstVarAccessors - 'compile instance-variable access methods for any instance variables that do not yet have them' model) - - - ('more...' offerClassListMenu - 'return to the standard class-list menu')). - ^ aMenu! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/5/2018 20:56:50'! - messageListMenu2 - "Fill aMenu with the items appropriate when the shift key is held down" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addStayUpIcons. - aMenu addList: #( - ('toggle diffing (D)' toggleDiffing '' model) - ('implementors of sent messages' browseAllMessages) - - - ('local senders of...' browseLocalSendersOfMessages) - ('local implementors of...' browseLocalImplementors) - - - ('spawn sub-protocol' browseProtocol) - ('spawn full protocol' browseFullProtocol) - - - ('sample instance' makeSampleInstance) - ('inspect instances' inspectInstances) - ('inspect subinstances' inspectSubInstances)). - - self addExtraMenu2ItemsTo: aMenu. - aMenu addList: #( - - - ('change category...' changeCategory '' model)). - - model canShowMultipleMessageCategories ifTrue: [ aMenu addList: #( - ('show category (C)' showHomeCategory '' model))]. - aMenu addList: #( - - - ('change sets with this method' findMethodInChangeSets) - ('revert to previous version' revertToPreviousVersion '' model) - - - ('more...' openMessageListMenu)). - ^ aMenu! ! -!MessageSetWindow methodsFor: 'menu building' stamp: 'jmv 5/5/2018 20:56:34'! - addExtraMenu2ItemsTo: aMenu - "The shifted selector-list menu is being built. Add items specific to MessageSet" - - model growable ifTrue: [ - aMenu addList: #( - - - ('remove from this browser' removeMessageFromBrowser '' model) - ('filter message list...' filterMessageList))]. - aMenu add: 'sort by date' target: model action: #sortByDate! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/5/2018 20:53:09' prior: 50338671! - classListMenu - "Set up the menu to apply to the receiver's class list, honoring the #shifted boolean" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addList: #( - ('browse full (b)' browseMethodFull) - ('browse hierarchy (h)' browseHierarchy) - ('browse protocol (p)' browseFullProtocol) - - - ('fileOut' fileOutClass '' model) - - - ('show hierarchy' hierarchy '' model) - ('show definition' editClass '' model) - ('show comment' editComment '' model) - - - ('inst var refs...' browseInstVarRefs) - ('inst var defs...' browseInstVarDefs) - - - ('class var refs...' browseClassVarRefs) - ('class vars' browseClassVariables) - ('class refs (N)' browseClassRefs) - - - ('rename class ...' renameClass '' model) - ('copy class...' copyClass '' model) - ('remove class (x)' removeClass '' model) - - - ('Run tests (t)' runClassTests '' model) - ('more...' offerClassListMenu2)). - ^ aMenu! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/5/2018 20:50:00' prior: 50344020! - messageListMenu - "Answer the message-list menu" - "Changed by emm to include menu-item for breakpoints" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addList:#( - ('what to show...' offerWhatToShowMenu) - ('toggle break on entry' toggleBreakOnEntry '' model) - - - ('browse full (b)' browseMethodFull) - ('browse hierarchy (h)' browseHierarchy) - ('browse method (O)' openSingleMessageBrowser) - ('browse protocol (p)' browseFullProtocol) - - - ('fileOut' fileOutMessage '' model) - ('explore CompiledMethod' exploreCompiledMethod '' model) - - - ('senders of... (n)' browseSendersOfMessages) - ('implementors of... (m)' browseMessages) - ('inheritance (i)' methodHierarchy) - ('versions (v)' browseVersions) - - - ('inst var refs...' browseInstVarRefs) - ('inst var defs...' browseInstVarDefs) - ('class var refs...' browseClassVarRefs) - ('class variables' browseClassVariables) - ('class refs (N)' browseClassRefs) - - - ('remove method (x)' removeMessage '' model) - ('Run test (t)' runMethodTest '' model) - ('Debug test (r)' debugMethodTest '' model) - - - ('more...' openMessageListMenu2)). - ^ aMenu -! ! - -MessageSetWindow removeSelector: #addExtraShiftedItemsTo:! - -MessageSetWindow removeSelector: #addExtraShiftedItemsTo:! - -BrowserWindow removeSelector: #addExtraShiftedItemsTo:! - -BrowserWindow removeSelector: #addExtraShiftedItemsTo:! - -BrowserWindow removeSelector: #shiftedClassListMenu! - -BrowserWindow removeSelector: #shiftedClassListMenu! - -BrowserWindow removeSelector: #shiftedMessageListMenu! - -BrowserWindow removeSelector: #shiftedMessageListMenu! - -CodeWindow removeSelector: #offerShiftedClassListMenu! - -CodeWindow removeSelector: #offerShiftedClassListMenu! - -CodeWindow removeSelector: #offerUnshiftedClassListMenu! - -CodeWindow removeSelector: #offerUnshiftedClassListMenu! - -CodeWindow removeSelector: #openShiftedMessageListMenu! - -CodeWindow removeSelector: #openShiftedMessageListMenu! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3315-BigMenuRefactor-p17-JuanVuletich-2018May05-20h47m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3315] on 6 May 2018 at 10:33:27 am'! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/6/2018 10:32:34'! - addItemsFromDictionaries: dataForMenuDicts - "A menu constructor utility that uses Dictionaries with elements: - #label - the name that displays in the menu - #object - the target object. If nil, use defaultTarget. If a Symbol, send it as message to defaultTarget to get real target. - #selector - the selector called on object when the menu item is selected - #arguments - optional collection of arguments passed to the selector - #balloonText - optional 'tool tip' style help text - #icon- optional icon selector or Form - - note, nil elements will add a line." - | item wantsIcons | - wantsIcons _ Preferences wantsMenuIcons. - dataForMenuDicts do: [ :dict | - dict - ifNil: [ self addLine ] - ifNotNil: [ | realTarget | - realTarget _ dict at: #object ifAbsent: [defaultTarget]. - realTarget isSymbol ifTrue: [ realTarget _ defaultTarget perform: realTarget ]. - item _ (dict at: #label) isSymbol - ifTrue: [ - self - addUpdating: (dict at: #label) - target: realTarget - action: (dict at: #selector) - argumentList: - (dict - at: #arguments - ifAbsent: [ #() ]) ] - ifFalse: [ - self - add: (dict at: #label) - target: realTarget - action: (dict at: #selector) - argumentList: - (dict - at: #arguments - ifAbsent: [ #() ]) ]. - wantsIcons ifTrue: [ - dict - at: #icon - ifPresent: [ :symbolOrFormOrNil | - item setIcon: symbolOrFormOrNil ]]. - dict - at: #balloonText - ifPresent: [ :balloonText | - item setBalloonText: balloonText ]. - ]]! ! -!TextEditor methodsFor: 'menu' stamp: 'jmv 5/6/2018 10:32:42' prior: 50395506! - getMenu - - ^(MenuMorph new defaultTarget: self) - addTitle: self class name; - addStayUpIcons; - addItemsFromDictionaries: `{ - { - #label -> 'Help...'. - #selector -> #openHelp. - #icon -> #helpIcon - } asDictionary. - nil. - { - #label -> 'Find...(f)'. - #selector -> #find. - #icon -> #findIcon - } asDictionary. - { - #label -> 'Find Again (g)'. - #selector -> #findAgain. - #icon -> #systemIcon - } asDictionary. - { - #label -> 'Use Selection for Find (j)'. - #selector -> #setSearchString. - #icon -> #saveAsIcon - } asDictionary. - nil. - { - #label -> 'Undo - multiple (z)'. - #selector -> #undo. - #icon -> #undoIcon - } asDictionary. - { - #label -> 'Redo - multiple (Z)'. - #selector -> #redo. - #icon -> #redoIcon - } asDictionary. - { - #label -> 'Undo / Redo history'. - #selector -> #offerUndoHistory. - #icon -> #changesIcon - } asDictionary. - nil. - { - #label -> 'Copy (c)'. - #selector -> #copySelection. - #icon -> #copyIcon - } asDictionary. - { - #label -> 'Cut (x)'. - #selector -> #cut. - #icon -> #cutIcon - } asDictionary. - { - #label -> 'Paste (v)'. - #selector -> #paste. - #icon -> #pasteIcon - } asDictionary. - { - #label -> 'Paste without Format'. - #selector -> #pasteString. - #icon -> #pasteIcon - } asDictionary. - { - #label -> 'Paste...'. - #selector -> #pasteRecent. - #icon -> #worldIcon - } asDictionary. - nil. - { - #label -> 'Toggle WordWrap'. - #selector -> #wrapOnOff. - #icon -> #genericTextIcon - } asDictionary. - { - #label -> 'Set Font... (k)'. - #selector -> #offerFontMenu. - #icon -> #preferencesDesktopFontIcon - } asDictionary. - { - #label -> 'Clear Font'. - #selector -> #clearFont. - #icon -> #newIcon - } asDictionary. - { - #label -> 'Set Default Font...'. - #selector -> #offerDefaultFontMenu. - #icon -> #fontXGenericIcon - } asDictionary. - { - #label -> 'Set Alignment...'. - #selector -> #chooseAlignment. - #icon -> #formatJustifyLeftIcon - } asDictionary. - }`! ! -!SmalltalkEditor methodsFor: 'menu' stamp: 'jmv 5/6/2018 10:32:39' prior: 50395335! - getMenu - - ^(MenuMorph new defaultTarget: self) - addTitle: self class name; - addStayUpIcons; - addItemsFromDictionaries: `{ - { - #label -> 'Help...'. - #selector -> #openHelp. - #icon -> #helpIcon - } asDictionary. - nil. - { - #label -> 'Do it (d)'. - #selector -> #doIt. - #icon -> #doItIcon - } asDictionary. - { - #label -> 'Print it (p)'. - #selector -> #printIt. - #icon -> #printIcon - } asDictionary. - { - #label -> 'Inspect it (i)'. - #selector -> #inspectIt. - #icon -> #inspectIcon - } asDictionary. - { - #label -> 'Explore it (I)'. - #selector -> #exploreIt. - #icon -> #exploreIcon - } asDictionary. - { - #label -> 'Debug it (D)'. - #selector -> #debugIt. - #icon -> #debugIcon - } asDictionary. - { - #label -> 'Profile it'. - #selector -> #profileIt. - #icon -> #clockIcon - } asDictionary. - nil. - { - #label -> 'Explain'. - #selector -> #explain. - #icon -> #helpIcon - } asDictionary. - { - #label -> 'Browse it (b)'. - #selector -> #browseIt. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'Senders of it (n)'. - #selector -> #sendersOfIt. - #icon -> #mailForwardIcon - } asDictionary. - { - #label -> 'Implementors of it (m)'. - #selector -> #implementorsOfIt. - #icon -> #developmentIcon - } asDictionary. - { - #label -> 'References to it (N)'. - #selector -> #referencesToIt. - #icon -> #addressBookIcon - } asDictionary. - nil. - { - #label -> 'Method Strings with it (E)'. - #selector -> #methodStringsContainingit. - #icon -> #genericTextIcon - } asDictionary. - { - #label -> 'Method Source with it'. - #selector -> #methodSourceContainingIt. - #icon -> #scriptIcon - } asDictionary. - { - #label -> 'Class Comments with it'. - #selector -> #classCommentsContainingIt. - #icon -> #chatIcon - } asDictionary. - nil. - { - #label -> 'Accept (s)'. - #selector -> #acceptContents. - #icon -> #acceptIcon - } asDictionary. - { - #label -> 'Cancel (l)'. - #selector -> #cancelEdits. - #icon -> #cancelIcon - } asDictionary. - { - #label -> 'Accept & Run Test in Class (t)'. - #selector -> #acceptAndTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #label -> 'Accept & Run Test in Category (y)'. - #selector -> #acceptAndTestAll. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #label -> 'Accept & Debug Test (r)'. - #selector -> #acceptAndDebugTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - nil. - { - #label -> 'More...'. - #selector -> #openMenu2. - #icon -> #listAddIcon - } asDictionary. - }`! ! -!SmalltalkEditor methodsFor: 'menu' stamp: 'jmv 5/6/2018 10:32:41' prior: 50395434! - openMenu2 - - (MenuMorph new defaultTarget: self) - addTitle: self class name; - addStayUpIcons; - addItemsFromDictionaries: `{ - { - #label -> 'Find...(f)'. - #selector -> #find. - #icon -> #findIcon - } asDictionary. - { - #label -> 'Find Again (g)'. - #selector -> #findAgain. - #icon -> #systemIcon - } asDictionary. - { - #label -> 'Use Selection for Find (j)'. - #selector -> #setSearchString. - #icon -> #saveAsIcon - } asDictionary. - nil. - { - #label -> 'Undo - multiple (z)'. - #selector -> #undo. - #icon -> #undoIcon - } asDictionary. - { - #label -> 'Redo - multiple (Z)'. - #selector -> #redo. - #icon -> #redoIcon - } asDictionary. - { - #label -> 'Undo / Redo history'. - #selector -> #offerUndoHistory. - #icon -> #changesIcon - } asDictionary. - nil. - { - #label -> 'Copy (c)'. - #selector -> #copySelection. - #icon -> #copyIcon - } asDictionary. - { - #label -> 'Cut (x)'. - #selector -> #cut. - #icon -> #cutIcon - } asDictionary. - { - #label -> 'Paste (v)'. - #selector -> #paste. - #icon -> #pasteIcon - } asDictionary. - { - #label -> 'Paste without Format'. - #selector -> #pasteString. - #icon -> #pasteIcon - } asDictionary. - { - #label -> 'Paste...'. - #selector -> #pasteRecent. - #icon -> #worldIcon - } asDictionary. - nil. - { - #label -> 'Toggle WordWrap'. - #selector -> #wrapOnOff. - #icon -> #genericTextIcon - } asDictionary. - { - #label -> 'Set Font... (k)'. - #selector -> #offerFontMenu. - #icon -> #preferencesDesktopFontIcon - } asDictionary. - { - #label -> 'Clear Font'. - #selector -> #clearFont. - #icon -> #newIcon - } asDictionary. - { - #label -> 'Set Default Font...'. - #selector -> #offerDefaultFontMenu. - #icon -> #fontXGenericIcon - } asDictionary. - nil. - { - #label -> 'More...'. - #selector -> #openMenu. - #icon -> #listAddIcon - } asDictionary. - }`; - popUpInWorld: morph world.! ! -!VersionsBrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/6/2018 10:32:59' prior: 50395807! - classCommentVersionsMenu - | aMenu | - aMenu _ MenuMorph new defaultTarget: model. "all commands are implemented by the model, not the view" - aMenu addTitle: 'versions'. - aMenu addStayUpIcons. - aMenu addItemsFromDictionaries: `{ - { - #label -> 'compare to current'. - #selector -> #compareToCurrentVersion. - #balloonText -> 'compare selected version to the current version' - } asDictionary. - { - #label -> 'revert to selected version'. - #selector -> #fileInSelections. - #balloonText -> 'resubmit the selected version, so that it becomes the current version' - } asDictionary. - nil. - { - #label -> 'toggle diffing (D)'. - #selector -> #toggleDiffing. - #balloonText -> 'toggle whether or not diffs should be shown here' - } asDictionary. - { - #label -> 'update list'. - #selector -> #reformulateList. - #balloonText -> 'reformulate the list of versions, in case it somehow got out of synch with reality' - } asDictionary. - nil. - { - #label -> 'help...'. - #selector -> #offerVersionsHelp. - #balloonText -> 'provide an explanation of the use of this tool' - } asDictionary. - }`. - ^aMenu! ! -!VersionsBrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/6/2018 10:33:10' prior: 50395848! - methodVersionsMenu - "Fill aMenu with menu items appropriate to the receiver" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Versions'. - aMenu addStayUpIcons. - model listIndex > 0 ifTrue:[ - (model list size > 1 ) ifTrue: [ - aMenu addItemsFromDictionaries: `{ - { - #label -> 'compare to current'. - #object -> #model. - #selector -> #compareToCurrentVersion. - #balloonText -> 'compare selected version to the current version' - } asDictionary. - { - #label -> 'compare to version...'. - #object -> #model. - #selector -> #compareToOtherVersion. - #balloonText -> 'compare selected version to another selected version' - } asDictionary. - }` ]. - "Note: Revert to selected should be visible for lists of length one for having the ability to revert to an accidentally deleted method" - aMenu addItemsFromDictionaries: `{ - { - #label -> 'revert to selected version'. - #object -> #model. - #selector -> #fileInSelections. - #balloonText -> 'resubmit the selected version, so that it becomes the current version' - } asDictionary. - }` ]. - - aMenu addItemsFromDictionaries: `{ - { - #label -> 'edit current method (O)'. - #selector -> #openSingleMessageBrowser. - #balloonText -> 'open a single-message browser on the current version of this method' - } asDictionary. - nil. - { - #label -> 'toggle diffing (D)'. - #object -> #model. - #selector -> #toggleDiffing. - #balloonText -> 'toggle whether or not diffs should be shown here' - } asDictionary. - { - #label -> 'update list'. - #object -> #model. - #selector -> #reformulateList. - #balloonText -> 'reformulate the list of versions, in case it somehow got out of synch with reality' - } asDictionary. - nil. - { - #label -> 'senders (n)'. - #selector -> #browseSenders. - #balloonText -> 'browse all senders of this selector' - } asDictionary. - { - #label -> 'implementors (m)'. - #selector -> #browseImplementors. - #balloonText -> 'browse all implementors of this selector' - } asDictionary. - nil. - { - #label -> 'help...'. - #object -> #model. - #selector -> #offerVersionsHelp. - #balloonText -> 'provide an explanation of the use of this tool' - } asDictionary. - }`. - ^aMenu! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/6/2018 10:32:44' prior: 50394768! - buildWorldMenu - "Build the menu that is put up when the screen-desktop is clicked on" - - ^(MenuMorph new defaultTarget: self) - addStayUpIcons; - addItemsFromDictionaries: `{ - { - #label -> 'Open...'. - #selector -> #openOpenMenu. - #icon -> #openIcon. - #balloonText -> 'Submenu to open various system tools'. - } asDictionary. - { - #label -> 'New morph...'. - #selector -> #newMorph. - #icon -> #morphsIcon. - #balloonText -> 'Offers a variety of ways to create new objects'. - } asDictionary. - { - #label -> 'Preferences...'. - #selector -> #openPreferencesMenu. - #icon -> #preferencesIcon. - #balloonText -> 'Opens a menu offering many controls over appearance and system preferences.'. - } asDictionary. - { - #label -> 'Windows...'. - #selector -> #openWindowsMenu. - #icon -> #windowIcon. - #balloonText -> 'Manage open windows'. - } asDictionary. - { - #label -> 'Help...'. - #selector -> #openHelpMenu. - #icon -> #helpIcon. - #balloonText -> 'Opens a menu of useful items for updating the system, determining what version you are running, and much else'. - } asDictionary. - nil. - { - #label -> 'Changes...'. - #selector -> #openChangesMenu. - #icon -> #changesIcon. - #balloonText -> 'Opens a menu of useful tools for dealing with changes'. - } asDictionary. - { - #label -> 'Debug...'. - #selector -> #openDebugMenu. - #icon -> #debugIcon. - #balloonText -> 'a menu of debugging items'. - } asDictionary. - { - #label -> 'Restore Display (r)'. - #object -> #myWorld. - #selector -> #restoreDisplay. - #icon -> #displayIcon. - #balloonText -> 'Repaint the screen -- useful for removing unwanted display artifacts, lingering cursors, etc.'. - } asDictionary. - nil. - { - #label -> 'Save'. - #object -> Smalltalk. - #selector -> #saveSession. - #icon -> #saveIcon. - #balloonText -> 'Save the current version of the image on disk'. - } asDictionary. - { - #label -> 'Save as...'. - #object -> Smalltalk. - #selector -> #saveAs. - #icon -> #saveAsIcon. - #balloonText -> 'Save the current version of the image on disk under a new name.'. - } asDictionary. - { - #label -> 'Save as New Version'. - #object -> Smalltalk. - #selector -> #saveAsNewVersion. - #icon -> #saveAsNewVersionIcon. - #balloonText -> ('Save the current image a new version-stamped name\and save it under that name on disk.\', - 'Clear all user preferences and user state (class vars).') withNewLines. - } asDictionary. - { - #label -> 'Save and Quit'. - #selector -> #saveAndQuit. - #icon -> #saveAndQuitIcon. - #balloonText -> 'Save the image and quit out of Cuis.'. - } asDictionary. - { - #label -> 'Quit'. - #selector -> #quitSession. - #icon -> #quitIcon. - #balloonText -> 'Quit out of Cuis.'. - } asDictionary. - }`! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/6/2018 10:32:45' prior: 50394871! - changesMenu - "Build the changes menu for the world." - - ^ (self menu: 'Changes...') - addItemsFromDictionaries: `{ - { - #label -> 'Change Sorter'. - #object -> ChangeSorterWindow. - #selector -> #openChangeSorter. - #icon -> #halfRefreshIcon. - #balloonText -> 'Open a 3-paned changed-set viewing tool'. - } asDictionary. - nil. - { - #label -> 'Install New Updates'. - #object -> ChangeSet. - #selector -> #installNewUpdates. - #icon -> #updateIcon. - #balloonText -> 'Install in the current image the new updates available -in directory named ./CoreUpdates -or in directory named ../Cuis-Smalltalk-Dev/CoreUpdates'. - } asDictionary. - nil. - { - #label -> 'Browse my Changes'. - #object -> Smalltalk. - #selector -> #browseMyChanges. - #icon -> #editFindReplaceIcon. - #balloonText -> 'Browse all of my changes since the last time #condenseSources was run.'. - } asDictionary. - { - #label -> 'Recently logged Changes...'. - #object -> ChangeList. - #selector -> #browseRecentLog. - #icon -> #clockIcon. - #balloonText -> 'Open a change-list browser on the latter part of the changes log. You can use this browser to recover logged changes which were not saved in your image, in the event of a crash or other interruption.'. - } asDictionary. - nil. - { - #label -> 'Save World as morph file'. - #selector -> #saveWorldInFile. - #icon -> #morphsIcon. - #balloonText -> 'Save a file that, when reloaded, reconstitutes the current World.'. - } asDictionary. - }`! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/6/2018 10:32:47' prior: 50394925! -debugMenu - - ^ (self menu: 'Debug...') - addItemsFromDictionaries: `{ - { - #label -> 'Inspect World'. - #object -> #myWorld. - #selector -> #inspect. - #icon -> #inspectIcon. - } asDictionary. - { - #label -> 'Explore World'. - #object -> #myWorld. - #selector -> #explore. - #icon -> #exploreIcon. - } asDictionary. - { - #label -> 'MessageTally all Processes'. - #selector -> #startMessageTally. - #icon -> #systemMonitorIcon. - } asDictionary. - { - #label -> 'MessageTally UI and Browse'. - #selector -> #startThenBrowseMessageTally. - #icon -> #editFindReplaceIcon. - } asDictionary. - nil. - { - #label -> 'Start drawing all again'. - #object -> #myWorld. - #selector -> #removeAllKnownFailing. - #icon -> #graphicsIcon. - } asDictionary. - { - #label -> 'Start stepping again'. - #object -> #myWorld. - #selector -> #resumeAfterStepError. - #icon -> #mediaPlaybackStartIcon. - } asDictionary. - { - #label -> 'Close all Debuggers'. - #object -> DebuggerWindow. - #selector -> #closeAllDebuggers. - #icon -> #closeIcon. - } asDictionary. - }`! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/6/2018 10:32:49' prior: 50394967! - helpMenu - "Build the help menu for the world." - - ^ (self menu: 'Help...') - addItemsFromDictionaries: `{ - { - #label -> 'About this System...'. - #object -> Smalltalk. - #selector -> #aboutThisSystem. - #icon -> #helpIcon. - #balloonText -> 'current version information.' - } asDictionary. - { - #label -> 'Terse Guide to Cuis'. - #selector -> #openTerseGuide. - #icon -> #helpIcon. - #balloonText -> 'explore Cuis Smalltalk' - } asDictionary. - { - #label -> 'Class Comment Browser'. - #selector -> #openCommentGuide. - #icon -> #helpIcon. - #balloonText -> 'search & explore Cuis Class Comments' - } asDictionary. - { - #label -> 'Code management in Cuis'. - #object -> Utilities. - #selector -> #openCodeManagementInCuis. - #icon -> #helpIcon. - #balloonText -> 'Features are kept in Packages.' - } asDictionary. - { - #label -> 'Using GitHub to host Cuis packages'. - #object -> Utilities. - #selector -> #openCuisAndGitHub. - #icon -> #helpIcon. - #balloonText -> 'GitHub usage pattern.' - } asDictionary. - nil. - { - #label -> 'Editor keyboard shortcuts'. - #object -> SmalltalkEditor. - #selector -> #openHelp. - #icon -> #keyboardShortcutsIcon. - #balloonText -> 'summary of keyboard shortcuts in editors for Smalltalk code.' - } asDictionary. - { - #label -> 'Useful Expressions'. - #object -> Utilities. - #selector -> #openUsefulExpressions. - #icon -> #chatIcon. - #balloonText -> 'a window full of useful expressions.' - } asDictionary. - nil. - { - #label -> 'VM Statistics'. - #selector -> #vmStatistics. - #icon -> #systemMonitorIcon. - #balloonText -> 'obtain some intriguing data about the vm.' - } asDictionary. - { - #label -> 'Space Left'. - #selector -> #garbageCollect. - #icon -> #removableMediaIcon. - #balloonText -> 'perform a full garbage-collection and report how many bytes of space remain in the image.' - } asDictionary. - }`! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/6/2018 10:32:52' prior: 50395037! - openMenu - "Build the open window menu for the world." - | menu items groups firstGroup itemsSorted itemsBase | - menu _ self menu: 'Open...'. - itemsBase _ (Smalltalk allClassesImplementing: #worldMenuForOpenGroup) - collect: [ :item | - item class == Metaclass ifTrue: [ - item soleInstance - worldMenuForOpenGroup ] ] - thenSelect: [ :item | - item notNil ]. - items _ OrderedCollection new. - "A single class may add more than one item to a menu" - itemsBase do: [ :item | - item class == Dictionary - ifTrue: [ items add: item ] - ifFalse: [ items addAll: item ]]. - groups _ (items collect: [ :item | - item at: #itemGroup ]) asSet asSortedCollection. - itemsSorted _ OrderedCollection new. - firstGroup _ true. - groups do: [ :group | - firstGroup - ifTrue: [ firstGroup _ false ] - ifFalse: [ itemsSorted add: nil ]. - ((items select: [ :item | - (item at: #itemGroup) = group ]) sort: [ :item1 :item2 | - (item1 at: #itemOrder) < (item2 at: #itemOrder) ]) do: [ :item | - itemsSorted add: item ]]. - menu addItemsFromDictionaries: itemsSorted. - ^ menu.! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/6/2018 10:32:55' prior: 50395074! - preferencesMenu - "Build the preferences menu for the world." - - ^ (self menu: 'Preferences...') - addItemsFromDictionaries: `{ - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Font Sizes...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set display depth...'. - #selector -> #setDisplayDepth. - #icon -> #displayIcon. - #balloonText -> 'choose how many bits per pixel.' - } asDictionary. - { - #label -> 'Set desktop color...'. - #selector -> #changeBackgroundColor. - #icon -> #wallpaperIcon. - #balloonText -> 'choose a uniform color to use as desktop background.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }`! ! -!TheWorldMenu methodsFor: 'windows & flaps menu' stamp: 'jmv 5/6/2018 10:32:56' prior: 50395175! - windowsMenu - "Build the windows menu for the world." - - ^ (self menu: 'Windows') - addItemsFromDictionaries: `{ - { - #label -> 'Find Window'. - #object -> #myWorld. - #selector -> #findWindow:. - #icon -> #windowIcon. - #balloonText -> 'Presents a list of all windows; if you choose one from the list, it becomes the active window.' - } asDictionary. - { - #label -> 'Find changed Browsers...'. - #object -> #myWorld. - #selector -> #findDirtyBrowsers:. - #icon -> #editFindReplaceIcon. - #balloonText -> 'Presents a list of browsers that have unsubmitted changes; if you choose one from the list, it becomes the active window.' - } asDictionary. - { - #label -> 'Find changed Windows...'. - #object -> #myWorld. - #selector -> #findDirtyWindows:. - #icon -> #newWindowIcon. - #balloonText -> 'Presents a list of all windows that have unsubmitted changes; if you choose one from the list, it becomes the active window.' - } asDictionary. - nil. - { - #label -> 'Find a Transcript'. - #object -> #myWorld. - #selector -> #findATranscript:. - #icon -> #printerIcon. - #balloonText -> 'Brings an open Transcript to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find a FileList'. - #object -> #myWorld. - #selector -> #findAFileList:. - #icon -> #systemFileManagerIcon. - #balloonText -> 'Brings an open fileList to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find a Change Sorter'. - #object -> #myWorld. - #selector -> #findAChangeSorter:. - #icon -> #changesIcon. - #balloonText -> 'Brings an open change sorter to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find Message Names'. - #object -> #myWorld. - #selector -> #findAMessageNamesWindow:. - #icon -> #inspectIcon. - #balloonText -> 'Brings an open MessageNames window to the front, creating one if necessary, and makes it the active window' - } asDictionary. - nil. - { - #label -> 'Collapse all Windows'. - #object -> #myWorld. - #selector -> #collapseAll. - #icon -> #collapseIcon. - #balloonText -> 'Reduce all open windows to collapsed forms that only show titles.' - } asDictionary. - { - #label -> 'Restore all Windows'. - #object -> #myWorld. - #selector -> #restoreAll. - #icon -> #expandIcon. - #balloonText -> 'Restore all collapsed windows back to their previous forms.' - } asDictionary. - { - #label -> 'Close top Window'. - #object -> SystemWindow. - #selector -> #closeTopWindow. - #icon -> #closeIcon. - #balloonText -> 'Close the topmost window if possible.' - } asDictionary. - { - #label -> 'Send top Window to back'. - #object -> SystemWindow. - #selector -> #sendTopWindowToBack. - #icon -> #goBottomIcon. - #balloonText -> 'Make the topmost window become the backmost one, and activate the window just beneath it.' - } asDictionary. - { - #label -> 'Move Windows onscreen'. - #object -> #myWorld. - #selector -> #bringWindowsFullOnscreen. - #icon -> #displayIcon. - #balloonText -> 'Make all windows fully visible on the screen' - } asDictionary. - nil. - { - #label -> 'Delete unchanged Windows'. - #object -> #myWorld. - #selector -> #closeUnchangedWindows. - #icon -> #warningIcon. - #balloonText -> 'Deletes all windows that do not have unsaved text edits.' - } asDictionary. - { - #label -> 'Delete non Windows'. - #object -> #myWorld. - #selector -> #deleteNonWindows. - #icon -> #warningIcon. - #balloonText -> 'Deletes all non-window morphs lying on the world.' - } asDictionary. - { - #label -> 'Delete Both of the Above'. - #selector -> #cleanUpWorld. - #icon -> #warningIcon. - #balloonText -> 'Deletes all unchanged windows and also all non-window morphs lying on the world, other than flaps.' - } asDictionary. - }`! ! - -MenuMorph removeSelector: #buildFromDictionaries:! - -MenuMorph removeSelector: #buildFromDictionaries:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3316-BigMenuRefactor-p18-JuanVuletich-2018May06-10h32m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3315] on 6 May 2018 at 11:21:29 am'! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/6/2018 10:51:49'! - add: aString action: aSymbol icon: symbolOrFormOrNil - "Append a menu item with the given label. If the item is selected, it will send the given selector to the default target object." - "Details: Note that the menu item added captures the default target object at the time the item is added; the default target can later be changed before added additional items without affecting the targets of previously added entries. The model is that each entry is like a button that knows everything it needs to perform its action." - - ^(self add: aString - target: defaultTarget - action: aSymbol - argumentList: #()) - setIcon: symbolOrFormOrNil! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/6/2018 10:51:24'! - add: aString action: aSymbol icon: symbolOrFormOrNil enabled: aBoolean - "Append a menu item with the given label. If the item is selected, it will send the given selector to the default target object." - "Details: Note that the menu item added captures the default target object at the time the item is added; the default target can later be changed before added additional items without affecting the targets of previously added entries. The model is that each entry is like a button that knows everything it needs to perform its action." - - (self add: aString - target: defaultTarget - action: aSymbol - argumentList: #()) - setIcon: symbolOrFormOrNil; - isEnabled: aBoolean! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/6/2018 10:56:22'! - add: aString target: aTarget action: aSymbol icon: symbolOrFormOrNil - ^(self add: aString - target: aTarget - action: aSymbol - argumentList: #()) - setIcon: symbolOrFormOrNil! ! -!ChangeSorterWindow methodsFor: 'menu building' stamp: 'jmv 5/6/2018 10:56:43' prior: 50395926! - changeSetMenu - "Set up aMenu to hold commands for the change-set-list pane. This could be for a single or double changeSorter" - - | aMenu isForBaseSystem | - isForBaseSystem _ model changeSet isForBaseSystem. - aMenu _ MenuMorph new defaultTarget: model. - aMenu addTitle: 'Change Set'. - aMenu addStayUpIcons. - - aMenu add: 'File out and remove (o)' action: #fileOutAndRemove icon: #fileOutIcon enabled: isForBaseSystem. - aMenu add: 'File out and keep (k)' action: #fileOutAndKeep icon: #fileOutIcon. - aMenu addLine. - - aMenu add: 'Rename change set (r)' action: #rename icon: #saveAsIcon enabled: isForBaseSystem. - aMenu add: 'Destroy change set (x)' action: #remove icon: #warningIcon enabled: isForBaseSystem. - aMenu addLine. - model currentCanHavePreambleAndPostscript ifTrue: [ - aMenu addLine. - model currentHasPreamble - ifTrue: [ - aMenu add: 'Edit preamble (p)' action: #addPreamble icon: #textEditorIcon. - aMenu add: 'Remove preamble' action: #removePreamble icon: #listRemoveIcon ] - ifFalse: [ - aMenu add: 'Add preamble (p)' action: #addPreamble icon: #listAddIcon ]. - model currentHasPostscript - ifTrue: [ - aMenu add: 'Edit postscript...' action: #editPostscript icon: #textEditorIcon . - aMenu add: 'Remove postscript' action: #removePostscript icon: #listRemoveIcon ] - ifFalse: [ - aMenu add: 'Add postscript...' action: #editPostscript icon: #listAddIcon ]. - ]. - aMenu addLine. - - "CONFLICTS SECTION" - (aMenu add: 'conflicts with other change sets' target: self action: #browseMethodConflicts icon: #emblemImportantIcon) - setBalloonText: 'Browse all methods that occur both in this change set and in at least one other change set.'. - aMenu addLine. - - "CHECKS SECTION" - (aMenu add: 'trim history' action: #trimHistory icon: #clockIcon enabled: isForBaseSystem) - setBalloonText: ' Drops any methods added and then removed, as well as renaming and reorganization of newly-added classes. ', - 'NOTE: can cause confusion if later filed in over an earlier version of these changes'. - - (aMenu add: 'view affected class categories' action: #viewAffectedClassCategories icon: #clockIcon) - setBalloonText: ' Show class categories affected by any contained change'. - - ^ aMenu! ! -!ChangeSorterWindow methodsFor: 'menu building' stamp: 'jmv 5/6/2018 11:20:40' prior: 50395992! - classListMenu - "Fill aMenu with items appropriate for the class list" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'class list'. - aMenu addStayUpIcons. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'delete class from change set (d)'. - #object -> #model. - #selector -> #forgetClass. - #icon -> #warningIcon - } asDictionary. - { - #label -> 'remove class from system (x)'. - #object -> #model. - #selector -> #removeClass. - #icon -> #deleteIcon - } asDictionary. - nil. - { - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - nil. - { - #label -> 'inst var refs...'. - #selector -> #browseInstVarRefs. - #icon -> #instanceIcon - } asDictionary. - { - #label -> 'inst var defs...'. - #selector -> #browseInstVarDefs. - #icon -> #instanceIcon - } asDictionary. - { - #label -> 'class var refs...'. - #selector -> #browseClassVarRefs. - #icon -> #classIcon - } asDictionary. - { - #label -> 'class vars'. - #selector -> #browseClassVariables. - #icon -> #classIcon - } asDictionary. - { - #label -> 'class refs (N)'. - #selector -> #browseClassRefs. - #icon -> #classIcon - } asDictionary. - }`. - ^ aMenu! ! -!ChangeSorterWindow methodsFor: 'menu building' stamp: 'jmv 5/6/2018 11:12:18' prior: 50396018! - messageMenu - "Fill aMenu with items appropriate for the message list; could be for a single or double changeSorter" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'message list'. - aMenu addStayUpIcons. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'delete method from changeSet (d)'. - #object -> #model. - #selector -> #forget. - #icon -> #warningIcon - } asDictionary. - nil. - { - #label -> 'remove method from system (x)'. - #object -> #model. - #selector -> #removeMessage. - #icon -> #deleteIcon - } asDictionary. - nil. - { - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #label -> 'browse method (O)'. - #selector -> #openSingleMessageBrowser. - #icon -> #scriptIcon - } asDictionary. - { - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - nil. - { - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutMessage. - #icon -> #fileOutIcon - } asDictionary. - nil. - { - #label -> 'senders of... (n)'. - #selector -> #browseSendersOfMessages. - #icon -> #mailForwardIcon - } asDictionary. - { - #label -> 'implementors of... (m)'. - #selector -> #browseMessages. - #icon -> #developmentIcon - } asDictionary. - { - #label -> 'inheritance (i)'. - #selector -> #methodHierarchy. - #icon -> #goDownIcon - } asDictionary. - { - #label -> 'versions (v)'. - #selector -> #browseVersions. - #icon -> #clockIcon - } asDictionary. - }`. - ^ aMenu! ! -!MenuMorph methodsFor: 'accessing' stamp: 'jmv 5/6/2018 09:38:40' prior: 50392559! - addBlankIconsIfNecessary - "If any of my items have an icon, ensure that all do by using anIcon for those that don't" - - | withIcons withoutIcons | - withIcons _ Set new. - withoutIcons _ Set new. - self items do: [ :item | - item hasIcon | item hasMarker - ifTrue: [ withIcons add: item ] - ifFalse: [ withoutIcons add: item ]. - item hasSubMenu ifTrue: [ item subMenu addBlankIconsIfNecessary ]]. -" (withIcons isEmpty or: [ withoutIcons isEmpty ]) ifTrue: [ ^self ]." - withoutIcons do: [ :item | item setBlankIcon ]! ! - -MenuMorph removeSelector: #add:action:enabled:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3317-BigMenuRefactor-p19-JuanVuletich-2018May06-10h33m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3317] on 6 May 2018 at 11:55:36 am'! -!MVCMenuMorph class methodsFor: 'instance creation' stamp: 'jmv 5/6/2018 11:54:04' prior: 16865516! - from: aPopupMenu title: titleStringOrNil - "Answer a MenuMorph constructed from the given PopUpMenu. Used to simulate MVC-style menus in a Morphic-only world." - - | menu items lines selections labelString j emphasis | - menu _ self new. - titleStringOrNil ifNotNil: [ - titleStringOrNil isEmpty ifFalse: [menu addTitle: titleStringOrNil]]. - labelString _ aPopupMenu labelString. - items _ labelString asString lines. - (labelString is: #Text) ifTrue: [ - "Pass along text emphasis if present" - j _ 1. - items _ items collect: [ :item | - j _ labelString asString findString: item startingAt: j. - emphasis _ TextEmphasis new emphasisCode: (labelString emphasisAt: j). - item asText addAttribute: emphasis]]. - lines _ aPopupMenu lineArray. - lines ifNil: [lines _ #()]. - menu cancelValue: 0. - menu defaultTarget: menu. - selections _ (1 to: items size) asArray. - 1 to: items size do: [ :i | - menu add: (items at: i) target: menu action: #selectMVCItem: argument: (selections at: i). - (lines includes: i) ifTrue: [menu addLine]]. - ^ menu -! ! - -MenuMorph removeSelector: #add:selector:argument:! - -MenuMorph removeSelector: #add:selector:argument:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3318-BigMenuRefactor-p20-JuanVuletich-2018May06-11h53m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3318] on 6 May 2018 at 4:50:12 pm'! -!TextEditor methodsFor: 'attributes' stamp: 'jmv 5/6/2018 16:14:40' prior: 16931498! - changeEmphasisOrAlignment - "This is a user command, and generates undo" - - | menuStrings aList reply code align menuList startIndex attribute | - startIndex _ self startIndex. - aList _ #(normal bold italic underlined struckThrough leftFlush centered rightFlush justified). - align _ model actualContents alignmentAt: startIndex. - code _ model actualContents emphasisAt: startIndex. - menuList _ WriteStream on: Array new. - menuList nextPut: (code isZero ifTrue:[''] ifFalse:['']), 'normal'. - menuList nextPutAll: (#(bold italic underlined struckThrough superscript subscript withST80Glyphs) collect: [ :emph | - (code anyMask: (TextEmphasis perform: emph) emphasisCode) - ifTrue: [ '', emph asString ] - ifFalse: [ '', emph asString ]]). - menuList nextPutAll: (#(leftFlush centered rightFlush justified) withIndexCollect: [ :type :i | - align = (i-1) - ifTrue: [ '', type asString ] - ifFalse: [ '', type asString ]]). - menuStrings _ menuList contents. - aList _ #(normal bold italic underlined struckThrough superscript subscript withST80Glyphs leftFlush centered rightFlush justified). - reply _ (SelectionMenu labelList: menuStrings lines: #(1 8) selections: aList) startUpMenu. - reply ifNotNil: [ - (#(leftFlush centered rightFlush justified) includes: reply) - ifTrue: [ - attribute _ TextAlignment perform: reply] - ifFalse: [ - attribute _ TextEmphasis perform: reply]. - ((menuStrings at: (aList indexOf: reply)) beginsWith: '') - ifTrue: [ self unapplyAttributes: {attribute} ] - ifFalse: [ self applyAttribute: attribute ]]. - ^ true! ! -!Preferences class methodsFor: 'menu icons' stamp: 'jmv 5/6/2018 16:43:04' prior: 50391886! - useMenuIcons - - self setPreference: #wantsMenuIcons toValue: true. - Theme current class beCurrent! ! -!Preferences class methodsFor: 'menu icons' stamp: 'jmv 5/6/2018 16:43:10' prior: 50391891! -useNoMenuIcons - - self setPreference: #wantsMenuIcons toValue: false. - Theme current class beCurrent! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/6/2018 16:38:18' prior: 50372209! - bigFonts - "Sets not only fonts but other GUI elements - to fit high resolution or large screens - Preferences bigFonts - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 11) - (setListFontTo: 11) - (setMenuFontTo: 12) - (setWindowTitleFontTo: 14) - (setCodeFontTo: 11) - (setButtonFontTo: 11)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/6/2018 16:38:21' prior: 50372225! - hugeFonts - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences hugeFonts - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 17) - (setListFontTo: 17) - (setMenuFontTo: 17) - (setWindowTitleFontTo: 22) - (setCodeFontTo: 17) - (setButtonFontTo: 17)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/6/2018 16:38:23' prior: 50372241! - smallFonts - "Sets not only fonts but other GUI elements - to fit low resolution or small screens - Preferences smallFonts - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 8) - (setListFontTo: 8) - (setMenuFontTo: 8) - (setWindowTitleFontTo: 11) - (setCodeFontTo: 8) - (setButtonFontTo: 8)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/6/2018 16:38:26' prior: 50372257! - standardFonts - "Sets not only fonts but other GUI elements - to fit regular resolution and size screens - Preferences standardFonts - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 9) - (setListFontTo: 9) - (setMenuFontTo: 10) - (setWindowTitleFontTo: 12) - (setCodeFontTo: 9) - (setButtonFontTo: 9)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/6/2018 16:38:28' prior: 50372273! - tinyFonts - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences tinyFonts - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 7) - (setListFontTo: 5) - (setMenuFontTo: 5) - (setWindowTitleFontTo: 7) - (setCodeFontTo: 5) - (setButtonFontTo: 5)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/6/2018 16:38:30' prior: 50372289! - veryBigFonts - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences veryBigFonts - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 14) - (setListFontTo: 14) - (setMenuFontTo: 14) - (setWindowTitleFontTo: 17) - (setCodeFontTo: 14) - (setButtonFontTo: 14)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/6/2018 16:38:32' prior: 50372305! - verySmallFonts - "Sets not only fonts but other GUI elements - to fit low resolution or small screens - Preferences verySmallFonts - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 8) - (setListFontTo: 7) - (setMenuFontTo: 7) - (setWindowTitleFontTo: 9) - (setCodeFontTo: 7) - (setButtonFontTo: 7)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!TheWorldMenu methodsFor: 'commands' stamp: 'jmv 5/6/2018 16:04:24' prior: 16934722! - startMessageTally - "Tally on all the processes in the system, and not only the UI" - - | d | - (self confirm: 'MessageTally all the processes in -the system, until the mouse pointer -goes to the top of the screen') ifTrue: [ - [ - d _ Delay forMilliseconds: 100. - AndreasSystemProfiler spyAllOn: [ - [Sensor peekMousePt y > 10] whileTrue: [d wait]] - ] forkAt: Processor userInterruptPriority - ]! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/6/2018 16:07:49' prior: 50396894! - debugMenu - - ^ (self menu: 'Debug...') - addItemsFromDictionaries: `{ - { - #label -> 'Inspect World'. - #object -> #myWorld. - #selector -> #inspect. - #icon -> #inspectIcon. - } asDictionary. - { - #label -> 'Explore World'. - #object -> #myWorld. - #selector -> #explore. - #icon -> #exploreIcon. - } asDictionary. - { - #label -> 'MessageTally all Processes'. - #selector -> #startMessageTally. - #icon -> #systemMonitorIcon. - } asDictionary. - nil. - { - #label -> 'Start drawing all again'. - #object -> #myWorld. - #selector -> #removeAllKnownFailing. - #icon -> #graphicsIcon. - } asDictionary. - { - #label -> 'Start stepping again'. - #object -> #myWorld. - #selector -> #resumeAfterStepError. - #icon -> #mediaPlaybackStartIcon. - } asDictionary. - { - #label -> 'Close all Debuggers'. - #object -> DebuggerWindow. - #selector -> #closeAllDebuggers. - #icon -> #closeIcon. - } asDictionary. - }`! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/6/2018 16:21:32' prior: 50397043! - preferencesMenu - "Build the preferences menu for the world." - - ^ (self menu: 'Preferences...') - addItemsFromDictionaries: `{ - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Font Sizes...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }`! ! -!Theme class methodsFor: 'instance creation' stamp: 'jmv 5/6/2018 16:45:50' prior: 16936855! - beCurrent - self currentTheme: self. - self inform: 'Please close and reopen all windows'! ! -!Theme class methodsFor: 'user interface' stamp: 'jmv 5/6/2018 16:42:00' prior: 16936893! - changeFontSizes - - (MenuMorph new defaultTarget: Preferences) - addTitle: 'Choose a size'; - addStayUpIcons; - add: 'Huge Fonts' action: #hugeFonts; - add: 'Very big Fonts' action: #veryBigFonts; - add: 'Big Fonts' action: #bigFonts; - add: 'Standard Fonts' action: #standardFonts; - add: 'Small Fonts' action: #smallFonts; - add: 'Very small Fonts'action: #verySmallFonts; - add: 'Tiny Fonts'action: #tinyFonts; - popUpInWorld: self runningWorld! ! -!Theme class methodsFor: 'user interface' stamp: 'jmv 5/6/2018 16:43:14' prior: 50392071! - changeIcons - - (MenuMorph new defaultTarget: Preferences) - addTitle: 'Menu Icons'; - addStayUpIcons; - add: 'Use icons for menu entries' action: #useMenuIcons; - add: 'Don''t use icons for menu entries' action: #useNoMenuIcons; - popUpInWorld: self runningWorld! ! -!Theme class methodsFor: 'user interface' stamp: 'jmv 5/6/2018 16:49:26' prior: 16936926! - changeTheme - - | menu | - menu _ MenuMorph new. - menu - addTitle: 'Choose a theme'; - addStayUpIcons. - Theme withAllSubclassesDo: [ :themeClass | - menu add: themeClass name target: themeClass action: #beCurrent ]. - menu popUpInWorld: self runningWorld! ! -!Theme class methodsFor: 'icons by menu' stamp: 'jmv 5/6/2018 16:44:00' prior: 50390834! - addBasicIconsTo: aCollectorCollection - - aCollectorCollection - add: #('save' ) -> #saveIcon; - add: #('change category...' 'rename') -> #saveAsIcon; - add: #('quit') -> #quitIcon; - add: #('inspect it (i)' 'inspect world' 'inspect model' 'inspect morph' - 'inspect owner chain' 'inspect' 'inspect (i)' 'basic inspect' 'message names' 'find message names' 'inspect instances' 'inspect subinstances' 'inspect change set' 'inspect context (c)' 'inspect receiver (i)' 'start CPUWatcher' 'stop CPUWatcher') - -> #inspectIcon; - add: #('explore' 'explore it (I)' 'explore morph' 'explore (I)' 'explore context (C)' 'explore receiver (I)' 'references finder' 'weight explorer' 'explore CompiledMethod') -> #exploreIcon; - add: #('find...(f)' 'find class... (f)' 'find method...' 'show hierarchy' 'show definition' 'show comment' 'filter' 'filter message list...' 'find context... (f)') -> #findIcon; - add: #('add item...' 'new category...' 'create new change set...' 'new change set... (n)' 'add new file') -> #newIcon; - add: #('remove method (x)' 'remove' 'remove class (x)' 'remove method from system (x)' 'remove class from system (x)' 'remove postscript''stop StackSizeWatcher' ) -> #deleteIcon; - add: #('delete method from changeset (d)' 'delete class from change set (d)' 'revert & remove from changes' 'reset variables' 'remove contained in class categories...' 'clear this change set' 'uninstall this change set' 'delete directory...' 'delete' 'start StackSizeWatcher') -> #warningIcon; - add: #('revert to previous version') -> #undoIcon; - add: #('copy to clipboard (c)' 'copy class...' 'copy name to clipboard') -> #copyIcon -! ! -!PopUpMenu methodsFor: 'basic control sequence' stamp: 'jmv 5/6/2018 16:27:31' prior: 16890977! - startUpWithCaption: captionOrNil - "Display the menu, slightly offset from the cursor, - so that a slight tweak is required to confirm any action." - ^ self startUpWithCaption: captionOrNil at: Sensor mousePoint allowKeyboard: Preferences menuKeyboardControl! ! - -PopUpMenu removeSelector: #startUpWithCaption:at:! - -PopUpMenu removeSelector: #startUpWithCaption:at:! - -PopUpMenu removeSelector: #startUpWithoutKeyboard! - -PopUpMenu removeSelector: #startUpWithoutKeyboard! - -TheWorldMenu removeSelector: #changeBackgroundColor! - -TheWorldMenu removeSelector: #changeBackgroundColor! - -TheWorldMenu removeSelector: #setDisplayDepth! - -TheWorldMenu removeSelector: #setDisplayDepth! - -TheWorldMenu removeSelector: #startThenBrowseMessageTally! - -TheWorldMenu removeSelector: #startThenBrowseMessageTally! - -ProgressBarMorph removeSelector: #addCustomMenuItems:hand:! - -ProgressBarMorph removeSelector: #addCustomMenuItems:hand:! - -ProgressBarMorph removeSelector: #changeProgressColor:! - -ProgressBarMorph removeSelector: #changeProgressColor:! - -ProgressBarMorph removeSelector: #changeProgressValue:! - -ProgressBarMorph removeSelector: #changeProgressValue:! - -ProgressBarMorph removeSelector: #progressColor! - -ProgressBarMorph removeSelector: #progressColor! - -ProgressBarMorph removeSelector: #progressColor:! - -ProgressBarMorph removeSelector: #progressColor:! - -Morph removeSelector: #changeColorTarget:selector:originalColor:hand:! - -Morph removeSelector: #changeColorTarget:selector:originalColor:hand:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3319-BigMenuRefactor-p21-JuanVuletich-2018May06-15h53m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3293] on 10 May 2018 at 8:53:39 pm'! -!ColorForm class methodsFor: 'as yet unclassified' stamp: 'jmv 5/10/2018 20:52:39'! - extent: aPoint - "Native depth" - - ^self extent: aPoint depth: (Smalltalk isLittleEndian ifTrue: [ -8 ] ifFalse: [ 8 ])! ! -!Color class methodsFor: 'class initialization' stamp: 'jmv 5/10/2018 20:43:18' prior: 50386366! - initializeIndexedColors - "Build an array of colors corresponding to the fixed colormap used - for display depths of 1, 2, 4, or 8 bits." - " - Color initializeIndexedColors - " - " -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: (Color r: 1 g: 0 b: 0); display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: (Color r: 0 g: 1 b: 0); display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: (Color r: 0 g: 0 b: 1); display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: (Color r: 0.5 g: 0.5 b: 0.5); display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: Color blue; display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: Color green; display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: Color red; display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: Color cyan; display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: Color yellow; display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: Color magenta; display. - " - - | a index grayVal | - a _ Array new: 256. - - "1-bit colors (monochrome)" - a at: 1 put: `Color r: 1.0 g: 1.0 b: 1.0`. "white or transparent" - a at: 2 put: `Color r: 0.0 g: 0.0 b: 0.0`. "black" - - "additional colors for 2-bit color" - a at: 3 put: `Color r: 1.0 g: 1.0 b: 1.0`. "opaque white" - a at: 4 put: `Color r: 0.5 g: 0.5 b: 0.5`. "1/2 gray" - - "additional colors for 4-bit color" - a at: 5 put: Color red. - a at: 6 put: Color green. - a at: 7 put: Color blue. - a at: 8 put: Color cyan. - a at: 9 put: Color yellow. - a at: 10 put: Color magenta. - - a at: 11 put: `Color r: 0.125 g: 0.125 b: 0.125`. "1/8 gray" - a at: 12 put: `Color r: 0.25 g: 0.25 b: 0.25`. "2/8 gray" - a at: 13 put: `Color r: 0.375 g: 0.375 b: 0.375`. "3/8 gray" - a at: 14 put: `Color r: 0.625 g: 0.625 b: 0.625`. "5/8 gray" - a at: 15 put: `Color r: 0.75 g: 0.75 b: 0.75`. "6/8 gray" - a at: 16 put: `Color r: 0.875 g: 0.875 b: 0.875`. "7/8 gray" - - "additional colors for 8-bit color" - "24 more shades of gray (1/32 increments but not repeating 1/8 increments)" - index _ 17. - 1 to: 31 do: [:v | - (v \\ 4) = 0 ifFalse: [ - grayVal _ v / 32.0. - a at: index put: (Color r: grayVal g: grayVal b: grayVal). - index _ index + 1]]. - - "The remainder of color table defines a color cube with six steps - for each primary color. Note that the corners of this cube may repeat - previous colors, but this simplifies the mapping between RGB colors - and color map indices. This color cube spans indices 40 through 255 - (indices 41-256 in this 1-based array)." - 0 to: 5 do: [:r | - 0 to: 5 do: [:g | - 0 to: 5 do: [:b | - index _ 41 + ((36 * r) + (6 * b) + g). - index > 256 ifTrue: [ - self error: 'index out of range in color table compuation']. - a at: index put: (Color r: r g: g b: b range: 5)]]]. - - IndexedColors _ a. -! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - Color initializeIndexedColors! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3320-ColorForm-fix-JuanVuletich-2018May10-20h43m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3319] on 13 May 2018 at 3:03:58 pm'! -!BrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/7/2018 18:53:59' prior: 50396215! - classListMenu - "Set up the menu to apply to the receiver's class list, honoring the #shifted boolean" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Class List'. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - nil. - { - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutClass. - #icon -> #fileOutIcon - } asDictionary. - nil. - { - #label -> 'show hierarchy'. - #object -> #model. - #selector -> #hierarchy. - #icon -> #findIcon - } asDictionary. - { - #label -> 'show definition'. - #object -> #model. - #selector -> #editClass. - #icon -> #findIcon - } asDictionary. - { - #label -> 'show comment'. - #object -> #model. - #selector -> #editComment. - #icon -> #findIcon - } asDictionary. - nil. - { - #label -> 'inst var refs...'. - #selector -> #browseInstVarRefs. - #icon -> #instanceIcon - } asDictionary. - { - #label -> 'inst var defs...'. - #selector -> #browseInstVarDefs. - #icon -> #instanceIcon - } asDictionary. - nil. - { - #label -> 'class var refs...'. - #selector -> #browseClassVarRefs. - #icon -> #classIcon - } asDictionary. - { - #label -> 'class vars'. - #selector -> #browseClassVariables. - #icon -> #classIcon - } asDictionary. - { - #label -> 'class refs (N)'. - #selector -> #browseClassRefs. - #icon -> #classIcon - } asDictionary. - nil. - { - #label -> 'rename class ...'. - #object -> #model. - #selector -> #renameClass. - #icon -> #saveAsIcon - } asDictionary. - { - #label -> 'copy class...'. - #object -> #model. - #selector -> #copyClass. - #icon -> #copyIcon - } asDictionary. - { - #label -> 'remove class (x)'. - #object -> #model. - #selector -> #removeClass. - #icon -> #deleteIcon - } asDictionary. - nil. - { - #label -> 'Run tests (t)'. - #object -> #model. - #selector -> #runClassTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #label -> 'more...'. - #selector -> #offerClassListMenu2. - #icon -> #listAddIcon - } asDictionary. - }`. - ^ aMenu! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/7/2018 18:42:05' prior: 50396117! - classListMenu2 - "Set up the menu to apply to the receiver's class list when the shift key is down" - - | aMenu | - aMenu := MenuMorph new defaultTarget: self. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'unsent methods'. - #selector -> #browseUnusedMethods. - #icon -> #junkIcon. - #balloonText -> 'browse all methods defined by this class that have no senders' - } asDictionary. - { - #label -> 'unreferenced inst vars'. - #selector -> #showUnreferencedInstVars. - #icon -> #junkIcon. - #balloonText -> 'show a list of all instance variables that are not referenced in methods' - } asDictionary. - { - #label -> 'unreferenced class vars'. - #selector -> #showUnreferencedClassVars. - #icon -> #junkIcon. - #balloonText -> 'show a list of all class variables that are not referenced in methods' - } asDictionary. - { - #label -> 'subclass template'. - #object -> #model. - #selector -> #makeNewSubclass. - #icon -> #classIcon. - #balloonText -> 'put a template into the code pane for defining of a subclass of this class' - } asDictionary. - nil. - { - #label -> 'sample instance'. - #selector -> #makeSampleInstance. - #icon -> #instanceIcon. - #balloonText -> 'give me a sample instance of this class, if possible' - } asDictionary. - { - #label -> 'inspect instances'. - #selector -> #inspectInstances. - #icon -> #inspectIcon. - #balloonText -> 'open an inspector on all the extant instances of this class' - } asDictionary. - { - #label -> 'inspect subinstances'. - #selector -> #inspectSubInstances. - #icon -> #inspectIcon. - #balloonText -> 'open an inspector on all the extant instances of this class and of all of its subclasses' - } asDictionary. - nil. - { - #label -> 'create inst var accessors'. - #object -> #model. - #selector -> #createInstVarAccessors. - #icon -> #sendReceiveIcon. - #balloonText -> 'compile instance-variable access methods for any instance variables that do not yet have them' - } asDictionary. - nil. - { - #label -> 'more...'. - #selector -> #offerClassListMenu. - #icon -> #listAddIcon. - #balloonText -> 'return to the standard class-list menu' - } asDictionary. - }`. - ^ aMenu! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/7/2018 18:59:39' prior: 50338705! - messageCategoryMenu - - | aMenu | - aMenu _ MenuMorph new defaultTarget: model. "All the options are for the model." - aMenu addTitle: 'Message Category'. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'fileOut'. - #selector -> #fileOutMessageCategories. - #icon -> #fileOutIcon - } asDictionary. - nil. - { - #label -> 'reorganize'. - #selector -> #editMessageCategories. - #icon -> #sendReceiveIcon - } asDictionary. - { - #label -> 'alphabetize'. - #selector -> #alphabetizeMessageCategories. - #icon -> #fontXGenericIcon - } asDictionary. - { - #label -> 'remove empty categories'. - #selector -> #removeEmptyCategories. - #icon -> #listRemoveIcon - } asDictionary. - { - #label -> 'categorize all uncategorized'. - #selector -> #categorizeAllUncategorizedMethods. - #icon -> #packageIcon - } asDictionary. - { - #label -> 'new category...'. - #selector -> #addCategory. - #icon -> #newIcon - } asDictionary. - nil. - { - #label -> 'rename...'. - #selector -> #renameCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #label -> 'remove'. - #selector -> #removeMessageCategory. - #icon -> #deleteIcon - } asDictionary. - nil. - { - #label -> 'Run tests'. - #selector -> #runMessageCategoryTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - }`. - ^ aMenu! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/7/2018 20:10:56' prior: 50396249! - messageListMenu - "Answer the message-list menu" - "Changed by emm to include menu-item for breakpoints" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Message List'. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'what to show...'. - #selector -> #offerWhatToShowMenu. - #icon -> #preferencesIcon - } asDictionary. - { - #label -> 'toggle break on entry'. - #object -> #model. - #selector -> #toggleBreakOnEntry. - #icon -> #debugIcon - } asDictionary. - nil. - { - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #label -> 'browse method (O)'. - #selector -> #openSingleMessageBrowser. - #icon -> #scriptIcon - } asDictionary. - { - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - nil. - { - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutMessage. - #icon -> #fileOutIcon - } asDictionary. - { - #label -> 'explore CompiledMethod'. - #object -> #model. - #selector -> #exploreCompiledMethod. - #icon -> #exploreIcon - } asDictionary. - nil. - { - #label -> 'senders of... (n)'. - #selector -> #browseSendersOfMessages. - #icon -> #mailForwardIcon - } asDictionary. - { - #label -> 'implementors of... (m)'. - #selector -> #browseMessages. - #icon -> #developmentIcon - } asDictionary. - { - #label -> 'inheritance (i)'. - #selector -> #methodHierarchy. - #icon -> #goDownIcon - } asDictionary. - { - #label -> 'versions (v)'. - #selector -> #browseVersions. - #icon -> #clockIcon - } asDictionary. - nil. - { - #label -> 'inst var refs...'. - #selector -> #browseInstVarRefs. - #icon -> #instanceIcon - } asDictionary. - { - #label -> 'inst var defs...'. - #selector -> #browseInstVarDefs. - #icon -> #instanceIcon - } asDictionary. - { - #label -> 'class var refs...'. - #selector -> #browseClassVarRefs. - #icon -> #classIcon - } asDictionary. - { - #label -> 'class variables'. - #selector -> #browseClassVariables. - #icon -> #classIcon - } asDictionary. - { - #label -> 'class refs (N)'. - #selector -> #browseClassRefs. - #icon -> #classIcon - } asDictionary. - nil. - { - #label -> 'remove method (x)'. - #object -> #model. - #selector -> #removeMessage. - #icon -> #deleteIcon - } asDictionary. - { - #label -> 'Run test (t)'. - #object -> #model. - #selector -> #runMethodTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #label -> 'Debug test (r)'. - #object -> #model. - #selector -> #debugMethodTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - nil. - { - #label -> 'more...'. - #selector -> #openMessageListMenu2. - #icon -> #listAddIcon - } asDictionary. - }`. - ^ aMenu! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/7/2018 20:25:02' prior: 50396162! - messageListMenu2 - "Fill aMenu with the items appropriate when the shift key is held down" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Message List'. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'toggle diffing (D)'. - #object -> #model. - #selector -> #toggleDiffing. - #icon -> #switchIcon - } asDictionary. - { - #label -> 'implementors of sent messages'. - #selector -> #browseAllMessages. - #icon -> #developmentIcon - } asDictionary. - nil. - { - #label -> 'local senders of...'. - #selector -> #browseLocalSendersOfMessages. - #icon -> #mailForwardIcon - } asDictionary. - { - #label -> 'local implementors of...'. - #selector -> #browseLocalImplementors. - #icon -> #classIcon - } asDictionary. - nil. - { - #label -> 'spawn sub-protocol'. - #selector -> #browseProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - { - #label -> 'spawn full protocol'. - #selector -> #browseFullProtocol. - #icon -> #speadsheetTemplateIcon - } asDictionary. - nil. - { - #label -> 'sample instance'. - #selector -> #makeSampleInstance. - #icon -> #instanceIcon - } asDictionary. - { - #label -> 'inspect instances'. - #selector -> #inspectInstances. - #icon -> #inspectIcon - } asDictionary. - { - #label -> 'inspect subinstances'. - #selector -> #inspectSubInstances. - #icon -> #inspectIcon - } asDictionary. - }`. - - self addExtraMenu2ItemsTo: aMenu. - aMenu add: 'change category...' target: model action: #changeCategory icon: #saveAsIcon. - - model canShowMultipleMessageCategories ifTrue: [ - aMenu add: 'show category (C)' target: model action: #showHomeCategory icon: #packageIcon ]. - aMenu - add: 'change sets with this method' action: #findMethodInChangeSets icon: #changesIcon; - add: 'revert to previous version' target: model action: #revertToPreviousVersion icon: #undoIcon; - addLine; - add: 'more...' action: #openMessageListMenu icon: #listAddIcon. - ^ aMenu! ! -!CodeFileBrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/7/2018 18:53:57' prior: 16809604! - classListMenu - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Class List'. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'definition'. - #object -> #model. - #selector -> #editClass. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'comment'. - #object -> #model. - #selector -> #editComment. - #icon -> #editFindReplaceIcon - } asDictionary. - nil. - { - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'class refs (N)'. - #selector -> #browseClassRefs. - #icon -> #classIcon - } asDictionary. - nil. - { - #label -> 'fileIn'. - #object -> #model. - #selector -> #fileInClass. - #icon -> #updateIcon - } asDictionary. - { - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutClass. - #icon -> #fileOutIcon - } asDictionary. - nil. - { - #label -> 'rename...'. - #object -> #model. - #selector -> #renameClass. - #icon -> #saveAsIcon - } asDictionary. - { - #label -> 'remove'. - #object -> #model. - #selector -> #removeClass. - #icon -> #listRemoveIcon - } asDictionary. - nil. - { - #label -> 'remove existing'. - #object -> #model. - #selector -> #removeUnmodifiedCategories. - #icon -> #deleteIcon - } asDictionary. - }`. - ^aMenu! ! -!CodeFileBrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/7/2018 19:03:29' prior: 16809635! - messageCategoryMenu - - | aMenu | - aMenu _ MenuMorph new defaultTarget: model. "All the options are for the model." - aMenu addTitle: 'Message Category'. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'fileIn'. - #selector -> #fileInMessageCategories. - #icon -> #updateIcon - } asDictionary. - { - #label -> 'fileOut'. - #selector -> #fileOutMessageCategories. - #icon -> #fileOutIcon - } asDictionary. - nil. - { - #label -> 'reorganize'. - #selector -> #editMessageCategories. - #icon -> #sendReceiveIcon - } asDictionary. - nil. - { - #label -> 'add item...'. - #selector -> #addCategory. - #icon -> #newIcon - } asDictionary. - nil. - { - #label -> 'rename...'. - #selector -> #renameCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #label -> 'remove'. - #selector -> #removeMessageCategory. - #icon -> #listRemoveIcon - } asDictionary. - nil. - { - #label -> 'remove existing'. - #selector -> #removeUnmodifiedMethods. - #icon -> #deleteIcon - } asDictionary. - }`. - ^ aMenu! ! -!CodeFileBrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/7/2018 20:10:06' prior: 16809652! - messageListMenu - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Message List'. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'fileIn'. - #object -> #model. - #selector -> #fileInMessage. - #icon -> #updateIcon - } asDictionary. - { - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutMessage. - #icon -> #fileOutIcon - } asDictionary. - nil. - { - #label -> 'senders (n)'. - #selector -> #browseSenders. - #icon -> #mailForwardIcon - } asDictionary. - { - #label -> 'implementors (m)'. - #selector -> #browseImplementors. - #icon -> #developmentIcon - } asDictionary. - { - #label -> 'method inheritance (h)'. - #selector -> #methodHierarchy. - #icon -> #goDownIcon - } asDictionary. - { - #label -> 'versions (v)'. - #selector -> #browseVersions. - #icon -> #clockIcon - } asDictionary. - nil. - { - #label -> 'remove method (x)'. - #object -> #model. - #selector -> #removeMessage. - #icon -> #deleteIcon - } asDictionary. - }`. - ^ aMenu! ! -!MessageSetWindow methodsFor: 'menu building' stamp: 'jmv 5/7/2018 20:22:14' prior: 50396201! - addExtraMenu2ItemsTo: aMenu - "The shifted selector-list menu is being built. Add items specific to MessageSet" - - model growable ifTrue: [ - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'remove from this browser'. - #object -> #model. - #selector -> #removeMessageFromBrowser. - #icon -> #listRemoveIcon - } asDictionary. - { - #label -> 'filter message list...'. - #selector -> #filterMessageList. - #icon -> #findIcon - } asDictionary. - }`. - ]. - aMenu add: 'sort by date' target: model action: #sortByDate icon: #dateIcon! ! -!ChangeSorterWindow methodsFor: 'menu building' stamp: 'jmv 5/7/2018 18:53:45' prior: 50397423! - classListMenu - "Fill aMenu with items appropriate for the class list" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Class List'. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'delete class from change set (d)'. - #object -> #model. - #selector -> #forgetClass. - #icon -> #warningIcon - } asDictionary. - { - #label -> 'remove class from system (x)'. - #object -> #model. - #selector -> #removeClass. - #icon -> #deleteIcon - } asDictionary. - nil. - { - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - nil. - { - #label -> 'inst var refs...'. - #selector -> #browseInstVarRefs. - #icon -> #instanceIcon - } asDictionary. - { - #label -> 'inst var defs...'. - #selector -> #browseInstVarDefs. - #icon -> #instanceIcon - } asDictionary. - { - #label -> 'class var refs...'. - #selector -> #browseClassVarRefs. - #icon -> #classIcon - } asDictionary. - { - #label -> 'class vars'. - #selector -> #browseClassVariables. - #icon -> #classIcon - } asDictionary. - { - #label -> 'class refs (N)'. - #selector -> #browseClassRefs. - #icon -> #classIcon - } asDictionary. - }`. - ^ aMenu! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3321-BigMenuRefactor-p22-JuanVuletich-2018May13-14h50m-jmv.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3319] on 13 May 2018 at 3:33:06 pm'! -!BrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/13/2018 15:28:48' prior: 16793385! - systemCatSingletonMenu - - | aMenu | - self flag: #renameSystemCategory. "temporarily disabled" - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Class category'. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'find class... (f)'. - #selector -> #findClass. - #icon -> #findIcon - } asDictionary. - nil. - { - #label -> 'browse all'. - #selector -> #browseAllClasses. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'browse'. - #selector -> #openSystemCategoryBrowser. - #icon -> #packageIcon - } asDictionary. - nil. - { - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutSystemCategory. - #icon -> #fileOutIcon - } asDictionary. - nil. - { - #label -> 'update'. - #object -> #model. - #selector -> #updateSystemCategories. - #icon -> #updateIcon - } asDictionary. - { - #label -> 'rename...'. - #object -> #model. - #selector -> #renameSystemCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #label -> 'remove'. - #object -> #model. - #selector -> #removeSystemCategory. - #icon -> #deleteIcon - } asDictionary. - }`. - ^aMenu! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/13/2018 15:32:04' prior: 50338767! - systemCategoryMenu - - | aMenu | - self flag: #renameSystemCategory. "temporarily disabled" - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Class category'. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'find class... (f)'. - #selector -> #findClass. - #icon -> #findIcon - } asDictionary. - { - #label -> 'recent classes... (r)'. - #object -> #model. - #selector -> #recent. - #icon -> #clockIcon - } asDictionary. - nil. - { - #label -> 'browse all'. - #selector -> #browseAllClasses. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'browse'. - #selector -> #openSystemCategoryBrowser. - #icon -> #packageIcon - } asDictionary. - nil. - { - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutSystemCategory. - #icon -> #fileOutIcon - } asDictionary. - nil. - { - #label -> 'reorganize'. - #object -> #model. - #selector -> #editSystemCategories. - #icon -> #sendReceiveIcon - } asDictionary. - { - #label -> 'alphabetize'. - #object -> #model. - #selector -> #alphabetizeSystemCategories. - #icon -> #fontXGenericIcon - } asDictionary. - nil. - { - #label -> 'update'. - #object -> #model. - #selector -> #updateSystemCategories. - #icon -> #updateIcon - } asDictionary. - { - #label -> 'add item...'. - #object -> #model. - #selector -> #addSystemCategory. - #icon -> #newIcon - } asDictionary. - { - #label -> 'rename...'. - #object -> #model. - #selector -> #renameSystemCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #label -> 'remove'. - #object -> #model. - #selector -> #removeSystemCategory. - #icon -> #deleteIcon - } asDictionary. - nil. - { - #label -> 'move to top'. - #object -> #model. - #selector -> #moveSystemCategoryTop. - #icon -> #goTopIcon - } asDictionary. - { - #label -> 'move up'. - #object -> #model. - #selector -> #moveSystemCategoryUp. - #icon -> #goUpIcon - } asDictionary. - { - #label -> 'move down'. - #object -> #model. - #selector -> #moveSystemCategoryDown. - #icon -> #goDownIcon - } asDictionary. - { - #label -> 'move to bottom'. - #object -> #model. - #selector -> #moveSystemCategoryBottom. - #icon -> #goBottomIcon - } asDictionary. - nil. - { - #label -> 'Run tests (t)'. - #object -> #model. - #selector -> #runSystemCategoryTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - }`. - ^aMenu! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3322-BigMenuRefactor-p23-JuanVuletich-2018May13-15h03m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3319] on 13 May 2018 at 4:26:25 pm'! -!CodeFileBrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/13/2018 15:58:47' prior: 16809623! - codeFileListMenu - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Code File'. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'find class... (f)'. - #selector -> #findClass - } asDictionary. - nil. - { - #label -> 'fileIn'. - #object -> #model. - #selector -> #fileIn - } asDictionary. - { - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOut - } asDictionary. - { - #label -> 'remove existing'. - #object -> #model. - #selector -> #removeUnmodifiedClasses - } asDictionary. - }`. - ^ aMenu! ! -!ChangeListWindow methodsFor: 'menu building' stamp: 'jmv 5/13/2018 15:53:28' prior: 50344457! - listMenu - "Fill aMenu up so that it comprises the primary changelist-browser menu" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Change List'. - aMenu addStayUpIcons. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'fileIn selections'. - #object -> #model. - #selector -> #fileInSelections. - #balloonText -> 'import the selected items into the image'. - } asDictionary. - { - #label -> 'fileOut selections... '. - #object -> #model. - #selector -> #fileOutSelections. - #balloonText -> 'create a new file containing the selected items'. - } asDictionary. - { - #label -> 'fileOut current version of selections...'. - #object -> #model. - #selector -> #fileOutCurrentVersionsOfSelections. - #balloonText -> 'create a new file containing the current (in-image) counterparts of the selected methods'. - } asDictionary. - nil. - { - #label -> 'compare to current'. - #object -> #model. - #selector -> #compareToCurrentVersion. - #balloonText -> 'open a separate window which shows the text differences between the on-file version and the in-image version.'. - } asDictionary. - { - #label -> 'toggle diffing (D)'. - #object -> #model. - #selector -> #toggleDiffing. - #balloonText -> 'start or stop showing diffs in the code pane.'. - } asDictionary. - nil. - { - #label -> 'select new methods'. - #object -> #model. - #selector -> #selectNewMethods. - #balloonText -> 'select methods in the file that do not currently exist in the image'. - } asDictionary. - { - #label -> 'select changes for absent classes'. - #object -> #model. - #selector -> #selectAllForAbsentClasses. - #balloonText -> 'select methods in the file for classes that are not defined in the image'. - } asDictionary. - { - #label -> 'select all changes for this class'. - #object -> #model. - #selector -> #selectAllForThisClass. - #balloonText -> 'select all methods in the file that belong to the currently-selected class'. - } asDictionary. - { - #label -> 'select unchanged methods'. - #object -> #model. - #selector -> #selectUnchangedMethods. - #balloonText -> 'select methods in the file whose in-image versions are the same as their in-file counterparts'. - } asDictionary. - { - #label -> 'select methods equivalent to current'. - #object -> #model. - #selector -> #selectEquivalentMethods. - #balloonText -> 'select methods in the file whose in-image versions have the same behavior as their in-file counterparts'. - } asDictionary. - { - #label -> 'select methods older than current'. - #object -> #model. - #selector -> #selectMethodsOlderThanCurrent. - #balloonText -> 'select methods in the file that are older than the one currently in the image'. - } asDictionary. - { - #label -> 'select removals of sent methods'. - #object -> #model. - #selector -> #selectRemovalsOfSent. - #balloonText -> 'select all method removals of methods that have some sender in the image'. - } asDictionary. - nil. - { - #label -> 'select all (a)'. - #object -> #model. - #selector -> #selectAll. - #balloonText -> 'select all the items in the list'. - } asDictionary. - { - #label -> 'deselect all'. - #object -> #model. - #selector -> #deselectAll. - #balloonText -> 'deselect all the items in the list'. - } asDictionary. - { - #label -> 'invert selections'. - #object -> #model. - #selector -> #invertSelections. - #balloonText -> 'select every item that is not currently selected, and deselect every item that *is* currently selected'. - } asDictionary. - nil. - { - #label -> 'browse class and method'. - #selector -> #browseMethodFull. - #balloonText -> 'open a full browser showing the selected method'. - } asDictionary. - { - #label -> 'browse all versions of single selection'. - #selector -> #browseVersions. - #balloonText -> 'open a version browser showing the versions of the currently selected method'. - } asDictionary. - { - #label -> 'browse current versions of selections'. - #selector -> #browseCurrentVersionsOfSelections. - #balloonText -> 'open a message-list browser showing the current (in-image) counterparts of the selected methods'. - } asDictionary. - { - #label -> 'destroy current methods of selections'. - #object -> #model. - #selector -> #destroyCurrentCodeOfSelections. - #balloonText -> 'remove (*destroy*) the in-image counterparts of all selected methods'. - } asDictionary. - nil. - { - #label -> 'remove doIts'. - #object -> #model. - #selector -> #removeDoIts. - #balloonText -> 'remove all items that are doIts rather than definitions'. - } asDictionary. - { - #label -> 'remove older versions'. - #object -> #model. - #selector -> #removeOlderMethodVersions. - #balloonText -> 'remove all but the most recent versions of methods in the list'. - } asDictionary. - { - #label -> 'remove up-to-date versions'. - #object -> #model. - #selector -> #removeUpToDate. - #balloonText -> 'remove all items whose code is the same as the counterpart in-image code'. - } asDictionary. - { - #label -> 'remove empty class comments'. - #object -> #model. - #selector -> #removeEmptyClassComments. - #balloonText -> 'remove all empty class comments'. - } asDictionary. - { - #label -> 'remove selected items'. - #object -> #model. - #selector -> #removeSelections. - #balloonText -> 'remove the selected items from the change-list'. - } asDictionary. - { - #label -> 'remove unselected items'. - #object -> #model. - #selector -> #removeNonSelections. - #balloonText -> 'remove all the items not currently selected from the change-list'. - } asDictionary. - }`. - ^ aMenu! ! -!DebuggerWindow methodsFor: 'menu building' stamp: 'jmv 5/13/2018 16:02:25' prior: 16831143! - contextFieldListMenu - "Arm the supplied menu with items for the field-list of the receiver" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'explore (I)'. - #selector -> #exploreContextSelection - } asDictionary. - nil. - { - #label -> 'browse hierarchy (h)'. - #selector -> #contextClassHierarchy - } asDictionary. - }`. - ^ aMenu! ! -!DebuggerWindow methodsFor: 'menu building' stamp: 'jmv 5/13/2018 16:05:17' prior: 50391633! - contextStackMenu - "Set up the menu appropriately for the context-stack-list, either shifted or unshifted as per the parameter provided" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'fullStack (f)'. - #selector -> #fullStack - } asDictionary. - { - #label -> 'restart (r)'. - #selector -> #restarl - } asDictionary. - { - #label -> 'proceed (p)'. - #selector -> #proceed - } asDictionary. - { - #label -> 'step (t)'. - #selector -> #doStep - } asDictionary. - { - #label -> 'step through (T)'. - #selector -> #stepIntoBlock - } asDictionary. - { - #label -> 'send (e)'. - #selector -> #send - } asDictionary. - { - #label -> 'where (w)'. - #selector -> #where - } asDictionary. - { - #label -> 'peel to first like this'. - #selector -> #peelToFirst - } asDictionary. - nil. - { - #label -> 'return entered value'. - #selector -> #returnValue - } asDictionary. - { - #label -> 'toggle break on entry'. - #object -> #model. - #selector -> #toggleBreakOnEntry - } asDictionary. - }`. - ^aMenu! ! -!DebuggerWindow methodsFor: 'menu building' stamp: 'jmv 5/13/2018 16:01:41' prior: 16831180! - receiverFieldListMenu - "Arm the supplied menu with items for the field-list of the receiver" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'explore (I)'. - #selector -> #exploreReceiverSelection - } asDictionary. - nil. - { - #label -> 'browse hierarchy (h)'. - #selector -> #receiverClassHierarchy - } asDictionary. - }`. - ^ aMenu! ! -!FileListWindow methodsFor: 'menu building' stamp: 'jmv 5/13/2018 16:07:20' prior: 16843430! - volumeMenu - | aMenu | - aMenu _ MenuMorph new defaultTarget: model. - aMenu - add: 'delete directory...' - action: #deleteDirectory. - ^ aMenu! ! -!InspectorWindow methodsFor: 'menu building' stamp: 'jmv 5/13/2018 16:19:22' prior: 50376364! - fieldListMenu - "Arm the supplied menu with items for the field-list of the receiver" - - | aMenu object | - aMenu _ MenuMorph new defaultTarget: self. - - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'inspect (i)'. - #selector -> #inspectSelection. - #icon -> #inspectIcon - } asDictionary. - { - #label -> 'explore (I)'. - #selector -> #exploreSelection. - #icon -> #exploreIcon - } asDictionary. - { - #label -> 'copy to clipboard (c)'. - #selector -> #copySelectionToClipboard. - #icon -> #copyIcon - } asDictionary. - { - #label -> 'basic inspect'. - #selector -> #inspectBasic. - #icon -> #inspectIcon - } asDictionary. - { - #label -> 'references finder'. - #selector -> #openReferencesFinder. - #icon -> #exploreIcon - } asDictionary. - { - #label -> 'weight explorer'. - #selector -> #openWeightExplorer. - #icon -> #exploreIcon - } asDictionary. - }`. - - object _ model object. - (object is: #Dictionary) ifTrue: [ - aMenu addItemsFromDictionaries: `{ - nil. - { - #label -> 'senders of this key'. - #selector -> #sendersOfSelectedKey. - } asDictionary. - { - #label -> 'add key'. - #selector -> #addEntry. - } asDictionary. - { - #label -> 'rename key'. - #selector -> #renameEntry. - } asDictionary. - { - #label -> 'remove'. - #object -> #model. - #selector -> #removeSelection. - } asDictionary. - }` ] - - ifFalse: [ (object is: #Set) ifTrue: [ - aMenu addItemsFromDictionaries: `{ - nil. - { - #label -> 'remove'. - #object -> #model. - #selector -> #removeSelection. - #icon -> #listRemoveIcon - } asDictionary. - }` ]]. - - aMenu - addItemsFromDictionaries: `{ - nil. - { - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - }`. - ^ aMenu! ! -!ObjectExplorerWindow methodsFor: 'building menus' stamp: 'jmv 5/13/2018 16:25:51' prior: 50393099! - genericMenu - "Borrow a menu from my inspector" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - model getCurrentSelection - ifNil: [ - aMenu - add: '*nothing selected*' - target: self - action: #yourself] - ifNotNil: [ - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'inspect (i)'. - #selector -> #inspectSelection. - #icon -> #inspectIcon - } asDictionary. - { - #label -> 'explore (I)'. - #selector -> #exploreSelection. - #icon -> #exploreIcon - } asDictionary. - { - #label -> 'copy to clipboard (c)'. - #selector -> #copySelectionToClipboard. - #icon -> #copyIcon - } asDictionary. - { - #label -> 'basic inspect'. - #selector -> #inspectBasic. - #icon -> #inspectIcon - } asDictionary. - { - #label -> 'references finder'. - #selector -> #openReferencesFinder. - #icon -> #exploreIcon - } asDictionary. - { - #label -> 'weight explorer'. - #selector -> #openWeightExplorer. - #icon -> #exploreIcon - } asDictionary. - nil. - { - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - }`. - aMenu addLine; - add: 'monitor changes' - target: self - action: #monitor: - argument: model getCurrentSelection. - model class == ReferencesExplorer ifTrue: [ - aMenu addLine; - add: 'rescan' - target: self - action: #rescan ]]. - model basicMonitorList isEmptyOrNil - ifFalse: [ - aMenu addLine; - add: 'stop monitoring all' - target: self - action: #stopMonitoring ]. - ^ aMenu! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3323-BigMenuRefactor-p24-JuanVuletich-2018May13-15h33m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3323] on 13 May 2018 at 6:14:25 pm'! -!AbstractFont class methodsFor: 'instance accessing' stamp: 'jmv 5/13/2018 18:14:09'! - availableFonts - ^AvailableFonts! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3324-availableFonts-JuanVuletich-2018May13-18h14m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3323] on 13 May 2018 at 6:53:04 pm'! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/13/2018 18:48:20'! - add: aString action: aSymbol balloonText: stringOrText - "Append a menu item with the given label. If the item is selected, it will send the given selector to the default target object." - "Details: Note that the menu item added captures the default target object at the time the item is added; the default target can later be changed before added additional items without affecting the targets of previously added entries. The model is that each entry is like a button that knows everything it needs to perform its action." - - ^(self add: aString - target: defaultTarget - action: aSymbol - argumentList: #()) - setBalloonText: stringOrText! ! -!MessageSetWindow methodsFor: 'menu commands' stamp: 'jmv 5/13/2018 18:52:01' prior: 16870467! - filterMessageList - "Allow the user to refine the list of messages." - - | aMenu | - model messageList size <= 1 - ifTrue: [ ^self inform: 'this is not a propitious filtering situation' ]. - - aMenu _ MenuMorph new defaultTarget: model. - aMenu addTitle: 'Filter by only showing...'. - aMenu addStayUpIcons. - aMenu - add: 'unsent messages' action: #filterToUnsentMessages balloonText: 'filter to show only messages that have no senders'; - addLine; - add: 'messages that send...' action: #filterToSendersOf balloonText: 'filter to show only messages that send a selector I specify'; - add: 'messages that do not send...' action: #filterToNotSendersOf balloonText: 'filter to show only messages that do not send a selector I specify'; - addLine; - add: 'messages whose selector is...' action: #filterToImplementorsOf balloonText: 'filter to show only messages with a given selector I specify'; - add: 'messages whose selector is NOT...' action: #filterToNotImplementorsOf balloonText: 'filter to show only messages whose selector is NOT a seletor I specify'; - addLine; - add: 'messages in any change set' action: #filterToAnyChangeSet balloonText: 'filter to show only messages that occur in at least one change set'; - add: 'messages not in any change set' action: #filterToNotAnyChangeSet balloonText: 'filter to show only messages that do not occur in any change set in the system'; - addLine; - add: 'messages authored by me' action: #filterToCurrentAuthor balloonText: 'filter to show only messages whose authoring stamp has my initials'; - add: 'messages not authored by me' action: #filterToNotCurrentAuthor balloonText: 'filter to show only messages whose authoring stamp does not have my initials'; - addLine; - add: 'messages logged in .changes file' action: #filterToMessagesInChangesFile balloonText: 'filter to show only messages whose latest source code is logged in the .changes file'; - add: 'messages only in .sources file' action: #filterToMessagesInSourcesFile balloonText: 'filter to show only messages whose latest source code is logged in the .sources file'; - addLine; - add: 'messages with prior versions' action: #filterToMessagesWithPriorVersions balloonText: 'filter to show only messages that have at least one prior version'; - add: 'messages without prior versions' action: #filterToMessagesWithoutPriorVersions balloonText: 'filter to show only messages that have no prior versions'; - addLine; - add: 'uncommented messages' action: #filterToUncommentedMethods balloonText: 'filter to show only messages that do not have comments at the beginning'; - add: 'commented messages' action: #filterToCommentedMethods balloonText: 'filter to show only messages that have comments at the beginning'. - aMenu popUpInWorld: self world! ! -!MessageNamesWindow methodsFor: 'menu building' stamp: 'jmv 5/13/2018 18:17:58' prior: 16867824! - selectorListMenu - "Answer the menu associated with the selectorList" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - (aMenu add: 'senders (n)' action: #browseSenders icon: #mailForwardIcon) - setBalloonText: 'browse senders of the chosen selector'. - ^ aMenu! ! -!ProcessBrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/13/2018 18:44:18' prior: 50390027! - processListMenu - | menu rules | - menu _ MenuMorph new defaultTarget: self. - - model selectedProcess - ifNotNil: [ :selectedProcess | - rules _ model class rulesFor: model selectedProcess. - menu - add: 'inspect (i)' action: #inspectProcess icon: #inspectIcon; - add: 'explore (I)' action: #exploreProcess icon: #exploreIcon; - add: 'references finder' action: #openReferencesFinder icon: #exploreIcon. - rules first - ifTrue: [ - menu add: 'terminate (t)' target: model action: #terminateProcess icon: #cancelIcon. - selectedProcess isSuspended - ifTrue: [menu add: 'resume (r)' target: model action: #resumeProcess icon: #mediaPlaybackStartIcon] - ifFalse: [menu add: 'suspend (s)' target: model action: #suspendProcess icon: #chatIcon]]. - rules second - ifTrue: [ - menu - add: 'change priority (p)' action: #changePriority icon: #systemMonitorIcon; - add: 'debug (d)' action: #debugProcess icon: #debugIcon ]. - (selectedProcess suspendingList isKindOf: Semaphore) - ifTrue: [menu add: 'signal Semaphore (S)' target: model action: #signalSemaphore icon: #haloHelpIcon ]. - menu add: 'full stack (k)' target: model action: #moreStack icon: #systemIcon. - menu addLine]. - - menu - add: 'find context... (f)' action: #findContext icon: #findIcon; - add: 'find again (g)' target: model action: #nextContext icon: #systemIcon. - menu addLine. - - isStepping - ifTrue: [ menu add: 'turn off auto-update (a)' action: #toggleAutoUpdate icon: #cancelIcon ] - ifFalse: [ menu add: 'turn on auto-update (a)' action: #toggleAutoUpdate icon: #updateIcon ]. - - menu add: 'update list (u)' target: model action: #updateProcessList icon: #updateIcon. - - menu addLine. - CPUWatcher isMonitoring - ifTrue: [ menu add: 'stop CPUWatcher' action: #stopCPUWatcher icon: #inspectIcon ] - ifFalse: [ menu add: 'start CPUWatcher' action: #startCPUWatcher icon: #inspectIcon ]. - StackSizeWatcher isWatching - ifTrue: [ menu add: 'stop StackSizeWatcher' action: #stopStackSizeWatcher icon: #inspectIcon ] - ifFalse: [ menu add: 'start StackSizeWatcher' action: #startStackSizeWatcher icon: #inspectIcon ]. - - ^ menu! ! -!ProcessBrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/13/2018 18:25:38' prior: 16895392! - stackListMenu - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - model selectedContext - ifNil: [^ aMenu]. - aMenu - add: 'inspect context (c)' action: #inspectContext icon: #inspectIcon; - add: 'explore context (C)' action: #exploreContext icon: #exploreIcon; - add: 'inspect receiver (i)' action: #inspectReceiver icon: #inspectIcon; - add: 'explore receiver (I)' action: #exploreReceiver icon: #exploreIcon; - add: 'browse (b)' action: #browseContext icon: #editFindReplaceIcon. - ^aMenu! ! -!TranscriptMorph methodsFor: 'menus' stamp: 'jmv 5/13/2018 18:22:44' prior: 16938623! - getMenu - "Set up the menu to apply to the receiver" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - doImmediateUpdates - ifTrue: [ aMenu add: 'Only update in the regular Morphic cycle' action: #doRegularUpdates ] - ifFalse: [ aMenu add: 'Immediately show each entry' action: #doImmediateUpdates ]. - aMenu - addLine; - add: 'Workspace with Contents' action: #editContents; - addLine; - add: 'Clear Transcript' action: #clearInternal; - add: 'Clear Transcript File' action: #clearFile; - add: 'Clear Both' action: #clearAll; - addLine. - Transcript logsToFile - ifTrue: [ aMenu add: 'Stop logging to File' action: #dontLogToFile ] - ifFalse: [ aMenu add: 'Start logging to File' action: #logToFile ]. - ^ aMenu! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3325-BigMenuRefactor-p25-JuanVuletich-2018May13-18h14m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3325] on 13 May 2018 at 7:42:11 pm'! -!SmallFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 5/13/2018 19:25:31'! - profilerFriendlyPrimTimesTwoPower: anInteger - " - This is an example on proper primitive reporting in AndreasSystemProfiler. - See senders. - " - - - ^nil! ! -!SmallFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 5/13/2018 19:25:53'! - profilerFriendlyTimesTwoPower: anInteger - - "This is an example on proper primitive reporting in AndreasSystemProfiler. - It is a reimplementation of #timesTwoPower: in a Profiler friendly way. - - Compare the results of - AndreasSystemProfiler spyOn:[1000000 timesRepeat: [3.14159 timesTwoPower: 10000]]. - and - AndreasSystemProfiler spyOn:[1000000 timesRepeat: [3.14159 profilerFriendlyTimesTwoPower: 10000]]. - - See #profilerFriendlyCall: - " - - | primResult | - primResult _ self profilerFriendlyCall: [ - self profilerFriendlyPrimTimesTwoPower: anInteger ]. - primResult ifNotNil: [ :result | ^result ]. - - "Make sure that (2.0 raisedTo: Integer) can be safely used without overflow - For example: - Float fminNormalized * (2.0 raisedTo: 2000) = Float infinity. - while: - (Float fminNormalized timesTwoPower: 2000) = (2.0 raisedTo: 2000+Float emin)." - anInteger > Float emax ifTrue: [^(self timesTwoPower: Float emax) timesTwoPower: anInteger - Float emax]. - - "In case of gradual underflow, timesTwoPower: is not exact, so greatest care must be taken - because two consecutive timesTwoPower: might differ from a single one" - anInteger < Float emin - ifTrue: - [| deltaToUnderflow | - deltaToUnderflow := Float emin - self exponent max: Float emin. - deltaToUnderflow >= 0 ifTrue: - ["self is already near or past underflow, so don't care, result will be zero" - deltaToUnderflow := Float emin]. - ^(self timesTwoPower: deltaToUnderflow) timesTwoPower: anInteger - deltaToUnderflow]. - - "If (2.0 raisedToInteger: anInteger) fit in a positive SmallInteger, then use faster SmallInteger conversion. - Note that SmallInteger maxVal highBit = 30 in a 32 bits image, so 1 can be shifted 29 times." - anInteger > -29 ifTrue: [ - anInteger < 0 ifTrue: [^ self / (1 bitShift: (0 - anInteger)) asFloat]. - anInteger < 30 ifTrue: [^ self * (1 bitShift: anInteger) asFloat]]. - - ^ self * (2.0 raisedToInteger: anInteger)! ! - -BoxedFloat64 removeSelector: #profilerFriendlyPrimTimesTwoPower:! - -BoxedFloat64 removeSelector: #profilerFriendlyPrimTimesTwoPower:! - -BoxedFloat64 removeSelector: #profilerFriendlyTimesTwoPower:! - -BoxedFloat64 removeSelector: #profilerFriendlyTimesTwoPower:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3326-ProfilerDemoCodeFix-JuanVuletich-2018May13-19h41m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3325] on 13 May 2018 at 7:42:58 pm'! - -Object subclass: #Theme - instanceVariableNames: 'menuItemIcons ' - classVariableNames: 'Content CurrentTheme ' - poolDictionaries: '' - category: 'Theme-Core'! - -!classDefinition: #Theme category: #'Theme-Core'! -Object subclass: #Theme - instanceVariableNames: 'menuItemIcons' - classVariableNames: 'Content CurrentTheme' - poolDictionaries: '' - category: 'Theme-Core'! -!MenuMorph methodsFor: 'control' stamp: 'jmv 5/13/2018 19:12:18' prior: 50392334! - popUpAt: aPoint forHand: hand allowKeyboard: aBoolean - "Present this menu at the given point under control of the given hand." - - | evt | - self items isEmpty ifTrue: [^self]. - self addBlankIconsIfNecessary. - (self submorphs select: [ :m | m is: #UpdatingMenuItemMorph ]) - do: [ :m | m updateContents]. - self runningWorld addMorphFront: self position: aPoint - `2 @ 8`. - self fitInWorld. - "Acquire focus for valid pop up behavior" - hand newMouseFocus: self. - aBoolean ifTrue: [ hand newKeyboardFocus: self ]. - evt _ hand lastMouseEvent. - (evt isKeyboard or: [ evt isMouse and: [ evt anyButtonPressed not ]]) - ifTrue: [ - "Select first item if button not down" - self moveSelectionDown: 1 event: evt ]! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 5/13/2018 19:12:24' prior: 50392360! - popUpAt: aPoint forHand: hand in: aWorld allowKeyboard: aBoolean - "Present this menu at the given point under control of the given hand." - - self items isEmpty ifTrue: [ ^self ]. - self addBlankIconsIfNecessary. - (self submorphs select: [ :m | m is: #UpdatingMenuItemMorph]) - do: [ :m | m updateContents]. - aWorld addMorphFront: self position: aPoint - `2 @ 8`. - self fitInWorld. - "Acquire focus for valid pop up behavior" - hand newMouseFocus: self. - aBoolean ifTrue: [ hand newKeyboardFocus: self ]! ! - -Theme class removeSelector: #addBasicIconsTo:! - -Theme class removeSelector: #addBasicIconsTo:! - -Theme class removeSelector: #addMiscellaneousIconsTo:! - -Theme class removeSelector: #addMiscellaneousIconsTo:! - -Theme removeSelector: #allIcons! - -Theme removeSelector: #allIcons! - -Theme removeSelector: #basicIcons! - -Theme removeSelector: #basicIcons! - -Theme removeSelector: #decorateMenu:! - -Theme removeSelector: #decorateMenu:! - -Theme removeSelector: #iconDefinersFor:! - -Theme removeSelector: #iconDefinersFor:! - -Theme removeSelector: #iconsDefinitionFor:! - -Theme removeSelector: #iconsDefinitionFor:! - -Theme removeSelector: #initialize! - -Theme removeSelector: #initialize! - -Theme removeSelector: #menuDecorations! - -Theme removeSelector: #menuDecorations! - -Theme removeSelector: #miscellaneousIcons! - -Theme removeSelector: #miscellaneousIcons! - -MenuItemMorph removeSelector: #set_icon:! - -MenuItemMorph removeSelector: #set_icon:! - -MenuMorph removeSelector: #addList:! - -MenuMorph removeSelector: #addList:! - -Object subclass: #Theme - instanceVariableNames: '' - classVariableNames: 'Content CurrentTheme' - poolDictionaries: '' - category: 'Theme-Core'! - -!classDefinition: #Theme category: #'Theme-Core'! -Object subclass: #Theme - instanceVariableNames: '' - classVariableNames: 'Content CurrentTheme' - poolDictionaries: '' - category: 'Theme-Core'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3327-removeOldStyleMenuDecorations-JuanVuletich-2018May13-19h42m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3327] on 13 May 2018 at 7:48:23 pm'! -!ContentPack methodsFor: 'accessing' stamp: 'jmv 5/13/2018 19:47:44'! - from: key get: anArray - -" - Theme content from: #Theme get: #('16x16' 'actions' 'view-refresh.png' ) - Answer nil when the object isn't found. - --cbr " - - | object | object _ self at: key ifAbsent: [ ^ nil ]. - - anArray do: [ :i | object _ object at: i ifAbsent: [ ^ nil ]]. - - ^ object! ! -!Theme methodsFor: 'icon lookup' stamp: 'jmv 5/13/2018 19:47:13' prior: 16936742! - fetch: aTuple " #( 'resolution' 'context' 'filename' ) " - - "Get an icon from Content. See icons protocol." - - | contentSpecifier icon themeGuess | - - icon _ nil. - themeGuess _ self class. - contentSpecifier _ self appendExtensionToContentSpec: aTuple. - - [ icon isNil ] - whileTrue: [ - icon _ self class content - from: themeGuess name - get: contentSpecifier. - - icon ifNotNil: [ ^ icon ]. - - themeGuess = Theme content - ifTrue: [ ^ nil "See comment in ContentPack>>get: --cbr" ]. - - themeGuess _ themeGuess superclass - ]! ! - -ContentPack removeSelector: #get:! - -ContentPack removeSelector: #get:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3328-IconRetrievalOptimization-JuanVuletich-2018May13-19h45m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3328] on 14 May 2018 at 1:02:23 pm'! -!SystemWindow methodsFor: 'menu' stamp: 'jmv 5/14/2018 11:54:07' prior: 50333299! - buildWindowMenu - - | aMenu | - - aMenu _ MenuMorph new defaultTarget: self. - - aMenu - add: 'change title...' action: #relabel icon: #saveAsIcon; - add: 'window color...' action: #setWindowColor icon: #graphicsIcon; - addLine; - add: 'send to back' action: #sendToBack icon: #goBottomIcon; - add: 'make next-to-topmost' action: #makeSecondTopmost icon: #goUpIcon; - addLine; - add: (self isSticky ifTrue: [ 'make draggable' ] ifFalse: [ 'make undraggable' ]) - action: #toggleStickiness icon: (self isSticky ifFalse: [#pushPinIcon]); - addLine; - add: 'close' action: #delete icon: #closeIcon; - add: 'collapse' action: #collapse icon: #collapseIcon; - add: 'expand / contract' action: #expandBoxHit icon: #expandIcon; - addLine; - add: 'resize...' action: #resize; - add: 'resize full' action: #resizeFull; - add: 'resize top' action: #resizeTop; - add: 'resize left' action: #resizeLeft; - add: 'resize bottom' action: #resizeBottom; - add: 'resize right' action: #resizeRight; - add: 'resize top left' action: #resizeTopLeft; - add: 'resize top right' action: #resizeTopRight; - add: 'resize bottom left' action: #resizeBottomLeft; - add: 'resize bottom right' action: #resizeBottomRight. - - ^ aMenu! ! -!ChangeSorterWindow methodsFor: 'menu building' stamp: 'jmv 5/14/2018 10:56:45' prior: 50397348! - changeSetMenu - "Set up aMenu to hold commands for the change-set-list pane. This could be for a single or double changeSorter" - - | aMenu isForBaseSystem | - isForBaseSystem _ model changeSet isForBaseSystem. - aMenu _ MenuMorph new defaultTarget: model. - aMenu addTitle: 'Change Set'. - aMenu addStayUpIcons. - - aMenu add: 'File out and remove (o)' action: #fileOutAndRemove icon: #fileOutIcon enabled: isForBaseSystem. - aMenu add: 'File out and keep (k)' action: #fileOutAndKeep icon: #fileOutIcon. - aMenu addLine. - - aMenu add: 'Rename change set (r)' action: #rename icon: #saveAsIcon enabled: isForBaseSystem. - aMenu add: 'Destroy change set (x)' action: #remove icon: #warningIcon enabled: isForBaseSystem. - aMenu addLine. - model currentCanHavePreambleAndPostscript ifTrue: [ - aMenu addLine. - model currentHasPreamble - ifTrue: [ - aMenu add: 'Edit preamble (p)' action: #addPreamble icon: #textEditorIcon. - aMenu add: 'Remove preamble' action: #removePreamble icon: #listRemoveIcon ] - ifFalse: [ - aMenu add: 'Add preamble (p)' action: #addPreamble icon: #listAddIcon ]. - model currentHasPostscript - ifTrue: [ - aMenu add: 'Edit postscript...' action: #editPostscript icon: #textEditorIcon . - aMenu add: 'Remove postscript' action: #removePostscript icon: #listRemoveIcon ] - ifFalse: [ - aMenu add: 'Add postscript...' action: #editPostscript icon: #listAddIcon ]. - ]. - aMenu addLine. - - "CONFLICTS SECTION" - (aMenu add: 'conflicts with other change sets' target: self action: #browseMethodConflicts icon: #emblemImportantIcon) - setBalloonText: 'Browse all methods that occur both in this change set and in at least one other change set.'. - aMenu addLine. - - "CHECKS SECTION" - (aMenu add: 'trim history' action: #trimHistory icon: #clockIcon enabled: isForBaseSystem) - setBalloonText: ' Drops any methods added and then removed, as well as renaming and reorganization of newly-added classes. ', - 'NOTE: can cause confusion if later filed in over an earlier version of these changes'. - - (aMenu add: 'view affected class categories' action: #viewAffectedClassCategories icon: #packageIcon) - setBalloonText: ' Show class categories affected by any contained change'. - - ^ aMenu! ! -!FileListWindow methodsFor: 'menu building' stamp: 'jmv 5/14/2018 10:28:53' prior: 50399275! - volumeMenu - | aMenu | - aMenu _ MenuMorph new defaultTarget: model. - aMenu - add: 'delete directory...' - action: #deleteDirectory - icon: #warningIcon. - ^ aMenu! ! -!TestRunnerWindow methodsFor: 'menu building' stamp: 'jmv 5/14/2018 11:10:46' prior: 50396048! - listMenu - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Test Cases'. - aMenu add: 'select all' target: model action: #selectAll icon: #selectAllIcon. - aMenu add: 'deselect all' target: model action: #deselectAll icon: #selectAllIcon. - aMenu add: 'toggle selections' target: model action: #invertSelections icon: #switchIcon. - aMenu add: 'filter' target: model action: #setFilter icon: #findIcon. - model runButtonState ifTrue: [ - aMenu add: 'stop' target: model action: #terminateRun icon: #cancelIcon ]. - model selectedSuite > 0 ifTrue: [ | cls | - cls _ (model tests at: model selectedSuite ifAbsent: ['']) copyUpTo: Character space. - cls _ cls asSymbol. - cls _ (Smalltalk at: cls ifAbsent: nil). - cls ifNotNil: [ - aMenu addLine. - (aMenu add: 'browse' target: self action: #browse: argument: cls) - setIcon: #editFindReplaceIcon. - ]. - ]. - aMenu addLine. - aMenu add: 'log to Transcript' target: model action: #showResult icon: #printerIcon. - ^aMenu! ! -!WorkspaceWindow methodsFor: 'menu' stamp: 'jmv 5/14/2018 11:55:00' prior: 50375087! - offerWindowMenu - | aMenu | - aMenu _ self buildWindowMenu. - aMenu addLine. - aMenu - add: 'reset variables' - target: model - action: #initializeBindings - icon: #warningIcon. - aMenu - addUpdating: #mustDeclareVariableWording - target: model - action: #toggleVariableDeclarationMode. - aMenu - addUpdating: #toggleStylingLabel - target: model - action: #toggleStyling. - aMenu popUpInWorld: self world! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3329-BigMenuRefactor-p26-JuanVuletich-2018May14-13h01m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3329] on 22 May 2018 at 4:38:46 pm'! -!DebuggerWindow methodsFor: 'menu building' stamp: 'jmv 5/22/2018 16:16:36' prior: 50399217! - contextStackMenu - "Set up the menu appropriately for the context-stack-list, either shifted or unshifted as per the parameter provided" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'fullStack (f)'. - #selector -> #fullStack - } asDictionary. - { - #label -> 'restart (r)'. - #selector -> #restart - } asDictionary. - { - #label -> 'proceed (p)'. - #selector -> #proceed - } asDictionary. - { - #label -> 'step (t)'. - #selector -> #doStep - } asDictionary. - { - #label -> 'step through (T)'. - #selector -> #stepIntoBlock - } asDictionary. - { - #label -> 'send (e)'. - #selector -> #send - } asDictionary. - { - #label -> 'where (w)'. - #selector -> #where - } asDictionary. - { - #label -> 'peel to first like this'. - #selector -> #peelToFirst - } asDictionary. - nil. - { - #label -> 'return entered value'. - #selector -> #returnValue - } asDictionary. - { - #label -> 'toggle break on entry'. - #object -> #model. - #selector -> #toggleBreakOnEntry - } asDictionary. - }`. - ^aMenu! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3330-DebugMenuFix-JuanVuletich-2018May22-16h16m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3331] on 23 May 2018 at 11:33:10 am'! -!Form methodsFor: 'analyzing' stamp: 'jmv 5/23/2018 11:28:54'! - isAnyPixel: pv - "Return an array of the number of pixels with value pv by y-value. - Note that if not is true, then this will tally those different from pv. - Based on #yTallyPixelValue:orNot: - Form lena isAnyPixel: 0 - Form lena isAnyPixel: 100 - " - | cm slice copyBlt countBlt | - cm _ self newColorMap. "Map all colors but pv to zero" - cm at: pv+1 put: 1 - (cm at: pv+1). - slice _ Form extent: width@1. - copyBlt _ (BitBlt destForm: slice sourceForm: self - combinationRule: Form over - destOrigin: `0@0` sourceOrigin: `0@0` extent: slice width @ 1 - clipRect: slice boundingBox) - colorMap: cm. - countBlt _ (BitBlt toForm: slice) - fillColor: (Bitmap with: 0); - destRect: (`0@0` extent: slice extent); - combinationRule: 32. - (0 to: height-1) do: [ :y | - copyBlt sourceOrigin: 0@y; copyBits. - countBlt copyBits > 0 ifTrue: [ ^ true ]]. - ^ false! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3331-isAnyPixel-JuanVuletich-2018May23-10h38m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3331] on 25 May 2018 at 10:41:35 am'! - -Dictionary subclass: #OrderedDictionary - instanceVariableNames: 'orderedKeys' - classVariableNames: '' - poolDictionaries: '' - category: 'Collections-Sequenceable'! - -!classDefinition: #OrderedDictionary category: #'Collections-Sequenceable'! -Dictionary subclass: #OrderedDictionary - instanceVariableNames: 'orderedKeys' - classVariableNames: '' - poolDictionaries: '' - category: 'Collections-Sequenceable'! -!OrderedDictionary commentStamp: '' prior: 0! - Like Python's OrderedDict! -!OrderedDictionary methodsFor: 'removing' stamp: 'jmv 3/9/2018 14:33:08'! - removeKey: key ifAbsent: aBlock - - super removeKey: key ifAbsent: [ - ^ aBlock value ]. - orderedKeys remove: key! ! -!OrderedDictionary methodsFor: 'enumerating' stamp: 'jmv 3/9/2018 14:45:35'! - associationsDo: aBlock - "Evaluate aBlock for each of the receiver's elements (key/value - associations)." - - orderedKeys do: [ :key | - aBlock value: (self associationAt: key ifAbsent: nil) ]! ! -!OrderedDictionary methodsFor: 'enumerating' stamp: 'jmv 3/9/2018 14:45:31'! - do: aBlock - "Evaluate aBlock for each of the receiver's values." - - orderedKeys do: [ :key | - aBlock value: (self at: key ifAbsent: nil) ]! ! -!OrderedDictionary methodsFor: 'enumerating' stamp: 'jmv 3/9/2018 14:45:24'! - keysDo: aBlock - "Evaluate aBlock for each of the receiver's keys." - - orderedKeys do: aBlock ! ! -!OrderedDictionary methodsFor: 'accessing' stamp: 'jmv 5/25/2018 10:36:46'! - keysSortedSafely - "Answer a sorted Collection containing the receiver's keys. - Redefined from Dictionary: for us, propery sorted keys are keys in the order they were added." - ^ orderedKeys! ! -!OrderedDictionary methodsFor: 'private' stamp: 'jmv 3/9/2018 14:33:17'! - atNewIndex: index put: anAssociation - - super atNewIndex: index put: anAssociation. - orderedKeys add: anAssociation key! ! -!OrderedDictionary methodsFor: 'private' stamp: 'jmv 3/9/2018 14:33:19'! - init: n - - super init: n. - orderedKeys _ OrderedCollection new: n! ! -!Dictionary methodsFor: 'accessing' stamp: 'jmv 5/25/2018 10:35:25' prior: 16833451! - keysSortedSafely - "Answer a sorted Collection containing the receiver's keys." - | sortedKeys | - sortedKeys _ OrderedCollection new: self size. - self keysDo: [:each | sortedKeys addLast: each]. - sortedKeys sort: - [ :x :y | "Should really be use 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]]]. - ^ sortedKeys! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3332-OrderedDictionary-JuanVuletich-2018May25-10h13m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3332] on 25 May 2018 at 2:06:45 pm'! -!Theme class methodsFor: 'instance creation' stamp: 'cbr 12/14/2010 01:55' prior: 50397951! - beCurrent - ^ self currentTheme: self! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3333-fixHangOnImageSave-JuanVuletich-2018May25-14h06m-jmv.1.cs.st----! - -----SNAPSHOT----#(25 May 2018 2:09:31.732859 pm) Cuis5.0-3333-32.image priorSource: 1907179! - -----QUIT----#(25 May 2018 2:09:54.421366 pm) Cuis5.0-3333-32.image priorSource: 2196528! - -----STARTUP----#(15 June 2018 11:05:33.97682 am) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3333-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3333] on 26 May 2018 at 5:40:37 pm'! -!Complex methodsFor: 'testing' stamp: 'jmv 5/20/2018 21:10:51'! - isInfinite - ^real isInfinite or: [ imaginary isInfinite ]! ! -!Complex methodsFor: 'private' stamp: 'jmv 5/20/2018 20:29:34'! - setReal: aNumber1 imaginary: aNumber2 - "Private - initialize the real and imaginary parts of a Complex" - real _ aNumber1. - imaginary _ aNumber2! ! -!Complex class methodsFor: 'instance creation' stamp: 'jmv 5/20/2018 20:32:34'! - basicReal: realPart imaginary: imaginaryPart - "Answer a Complex even if imaginary part is zero. Usually you don't want this and just call #real:imaginary:" - ^self basicNew setReal: realPart imaginary: imaginaryPart! ! -!Number methodsFor: 'converting' stamp: 'jmv 5/20/2018 20:33:20' prior: 16879859! - asComplex - "Answer a Complex number that represents value of the the receiver." - - ^ Complex basicReal: self imaginary: 0! ! -!Complex methodsFor: 'arithmetic' stamp: 'jmv 5/20/2018 20:30:21' prior: 16822388! - absSecure - "Answer the distance of the receiver from zero (0 + 0 i). - Try avoiding overflow and/or underflow" - - | scale | - scale := real abs max: imaginary abs. - ^scale isZero - ifTrue: [scale] - ifFalse: [(self class basicReal: real / scale imaginary: imaginary / scale) squaredNorm sqrt * scale]! ! -!Complex class methodsFor: 'instance creation' stamp: 'jmv 5/20/2018 20:27:23' prior: 16822850! - abs: rho arg: theta - | theta1 | - "So that if theta is any integer multiple of twoPi, answer is real" - theta1 _ theta \\ Float twoPi. - ^ self - real: rho * theta1 cos - imaginary: rho * theta1 sin! ! -!Complex class methodsFor: 'instance creation' stamp: 'jmv 5/20/2018 17:14:55' prior: 16822864! - real: realPart imaginary: imaginaryPart - ^ imaginaryPart isZero - ifTrue: [ realPart ] - ifFalse: [ self basicReal: realPart imaginary: imaginaryPart ]! ! - -Complex removeSelector: #real:imaginary:! - -Complex removeSelector: #real:imaginary:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3334-Complex-Creation-JuanVuletich-2018May26-17h32m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3334] on 26 May 2018 at 11:10:23 pm'! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 5/26/2018 17:51:33'! - sqrt - "Answer the square root of the receiver. - Optional. See Object documentation whatIsAPrimitive." - | exp guess eps delta prim | - prim _ self primSqrt. - prim isNaN ifFalse: [ ^prim ]. - - "Newton-Raphson" - self <= 0.0 - ifTrue: [ - ^self = 0.0 - ifTrue: [0.0] - ifFalse: [ - (0.0 - self) sqrt i ]]. - "first guess is half the exponent" - exp := self exponent // 2. - guess := self timesTwoPower: 0 - exp. - "get eps value" - eps := guess * Epsilon. - eps := eps * eps. - delta := self - (guess * guess) / (guess * 2.0). - [delta * delta > eps] - whileTrue: - [guess := guess + delta. - delta := self - (guess * guess) / (guess * 2.0)]. - ^ guess! ! -!BoxedFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 5/21/2018 18:02:08'! - primSqrt - "Answer the square root of the receiver. - Optional. See Object documentation whatIsAPrimitive." - - - ^Float nan! ! -!SmallFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 5/21/2018 18:02:14'! - primSqrt - "Answer the square root of the receiver. - Optional. See Object documentation whatIsAPrimitive." - - - ^Float nan! ! -!Complex methodsFor: 'testing' stamp: 'jmv 5/26/2018 23:00:13'! - isNaN - ^real isNaN or: [ imaginary isNaN ]! ! -!Fraction methodsFor: 'mathematical functions' stamp: 'jmv 5/26/2018 23:01:31' prior: 16849723! - sqrt - | d n answer | - n _ numerator sqrt. - d _ denominator sqrt. - "The #sqrt method in integer will only answer a Float if there's no exact square root. - So, we need a float anyway." - (n isInfinite or: [ d isInfinite ]) ifTrue: [ - ^self asFloat sqrt ]. - answer _ n / d. - answer isNaN ifTrue: [ - ^self asFloat sqrt ]. - ^ answer! ! -!LargeNegativeInteger methodsFor: 'mathematical functions' stamp: 'jmv 5/26/2018 17:52:29' prior: 16862205! - sqrt - "Answer the square root of the receiver." - ^ self negated sqrt i! ! -!SmallInteger methodsFor: 'mathematical functions' stamp: 'jmv 5/26/2018 17:52:59' prior: 16909161! - sqrt - self negative ifTrue: [ - ^ self negated sqrt i ]. - ^ super sqrt! ! - -SmallFloat64 removeSelector: #sqrt! - -SmallFloat64 removeSelector: #sqrt! - -BoxedFloat64 removeSelector: #sqrt! - -BoxedFloat64 removeSelector: #sqrt! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3335-Complex-sqrt-JuanVuletich-2018May26-23h09m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3335] on 26 May 2018 at 6:10:15 pm'! - -SmallInteger class removeSelector: #guideToDivision! - -SmallInteger class removeSelector: #guideToDivision! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3336-RemoveOldGuideToDivision-JuanVuletich-2018May26-18h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3336] on 26 May 2018 at 11:05:24 pm'! -!Complex methodsFor: 'mathematical functions' stamp: 'jmv 5/26/2018 22:57:33'! - nthRoot: aPositiveInteger - - aPositiveInteger = 2 ifTrue: [ - ^ self sqrt ]. - - (aPositiveInteger isInteger not or: [ aPositiveInteger negative ]) - ifTrue: [^ ArithmeticError signal: 'nth root only defined for positive Integer n.']. - - ^ Complex abs: (self abs nthRoot: aPositiveInteger) arg: self arg / aPositiveInteger! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 5/26/2018 21:52:19' prior: 16844676! - nthRoot: aPositiveInteger - "Answer the nth root of the receiver." - aPositiveInteger = 2 ifTrue: [ - ^self sqrt ]. - - (aPositiveInteger isInteger not or: [ aPositiveInteger negative ]) - ifTrue: [^ ArithmeticError signal: 'nth root only defined for positive Integer n.']. - - ^self negative - ifTrue: [ - aPositiveInteger even - ifTrue: [ (Complex basicReal: self imaginary: 0) nthRoot: aPositiveInteger ] - ifFalse: [ (self negated nthRoot: aPositiveInteger) negated ]] - ifFalse: [ self raisedTo: 1.0 / aPositiveInteger ]! ! -!Fraction methodsFor: 'mathematical functions' stamp: 'jmv 5/26/2018 22:57:41' prior: 50367836! - nthRoot: aPositiveInteger - "Answer the nth root of the receiver." - | guess | - aPositiveInteger = 2 ifTrue: [ - ^ self sqrt ]. - - (aPositiveInteger isInteger not or: [ aPositiveInteger negative ]) - ifTrue: [^ ArithmeticError signal: 'nth root only defined for positive Integer n.']. - - (self negative and: [ aPositiveInteger even ]) ifTrue: [ - ^(Complex basicReal: self imaginary: 0) nthRoot: aPositiveInteger ]. - - guess _ (numerator nthRootTruncated: aPositiveInteger) / - (denominator nthRootTruncated: aPositiveInteger). - (guess raisedTo: aPositiveInteger) = self ifTrue: [ - ^ guess ]. - "There is no exact nth root, so answer a Float approximation" - ^ (self abs ln / aPositiveInteger) exp * self sign! ! -!Integer methodsFor: 'mathematical functions' stamp: 'jmv 5/26/2018 22:57:47' prior: 16859661! - nthRoot: aPositiveInteger - "Answer the nth root of the receiver. - Answer an Integer if root is exactly this Integer, else answer the Float nearest the exact root." - - | guess excess scaled nBits | - self = 0 ifTrue: [ ^0 ]. - - aPositiveInteger = 2 ifTrue: [ - ^ self sqrt ]. - - (aPositiveInteger isInteger not or: [ aPositiveInteger negative ]) - ifTrue: [^ ArithmeticError signal: 'nth root only defined for positive Integer n.']. - - (self negative and: [ aPositiveInteger even ]) ifTrue: [ - ^ (Complex basicReal: self imaginary: 0) nthRoot: aPositiveInteger ]. - - guess _ self nthRootRounded: aPositiveInteger. - excess _ (guess raisedTo: aPositiveInteger) - self. - excess = 0 ifTrue: [ ^ guess ]. - - nBits _ Float precision - guess highBitOfMagnitude. - nBits <= 0 ifTrue: [ ^(Fraction numerator: guess * 4 - excess sign denominator: 4) asFloat]. - - scaled _ self << (nBits * aPositiveInteger). - guess _ scaled nthRootRounded: aPositiveInteger. - excess _ (guess raisedTo: aPositiveInteger) - scaled. - ^(Fraction numerator: guess * 4 - excess sign denominator: 1 << (nBits + 2)) asFloat! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3337-Complex-nthRoot-JuanVuletich-2018May26-23h04m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3336] on 26 May 2018 at 10:48:43 pm'! -!Complex methodsFor: 'mathematical functions' stamp: 'jmv 5/26/2018 22:20:24'! - raisedToFraction: aFraction - ^ (self nthRoot: aFraction denominator) raisedToInteger: aFraction numerator! ! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 5/26/2018 22:28:10' prior: 50367804! - raisedTo: aNumber - "Answer the receiver raised to aNumber." - - aNumber isInteger ifTrue: [ - "Do the special case of integer power" - ^ self raisedToInteger: aNumber]. - aNumber isFraction ifTrue: [ - "Special case for fraction power by Nicolas Cellier: - If aNumber is a fraction, but result must be a Float, learn it as quickly as possible, and give quick Float answer - Allows evaluating: - (2009/2000) raisedTo: (3958333/100000) - " - ^ self raisedToFraction: aNumber]. - self < 0 ifTrue: [ - ^(Complex basicReal: self imaginary: 0) raisedTo: aNumber ]. - 0 = aNumber ifTrue: [^ self class one]. "Special case of exponent=0" - 1 = aNumber ifTrue: [^ self]. "Special case of exponent=1" - 0 = self ifTrue: [ "Special case of self = 0" - aNumber < 0 - ifTrue: [^ (ZeroDivide dividend: self) signal] - ifFalse: [^ self]]. - ^ (aNumber * self ln) exp "Otherwise use logarithms"! ! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 5/26/2018 22:22:44' prior: 50367766! - raisedToFraction: aFraction - self isZero ifTrue: [ - aFraction negative ifTrue: [ - ^ (ZeroDivide dividend: 1) signal ]. - ^ self ]. - self negative ifFalse: [ - ^ (self ln * aFraction) exp ]. - aFraction denominator = 2 ifTrue: [ - ^ self sqrt raisedToInteger: aFraction numerator ]. - (self negative and: [ aFraction denominator even ]) ifTrue: [ - ^ (Complex basicReal: self imaginary: 0) raisedToFraction: aFraction]. - ^ (self negated ln * aFraction) exp negated! ! -!Fraction methodsFor: 'mathematical functions' stamp: 'jmv 5/26/2018 22:21:48' prior: 50367780! - raisedToFraction: aFraction - | root | - aFraction denominator = 2 ifTrue: [ - ^ self sqrt raisedToInteger: aFraction numerator ]. - (self negative and: [ aFraction denominator even ]) ifTrue: [ - ^ (Complex basicReal: self imaginary: 0) raisedToFraction: aFraction]. - root _ (self numerator nthRootTruncated: aFraction denominator) / - (self denominator nthRootTruncated: aFraction denominator). - (root raisedToInteger: aFraction denominator) = self ifTrue: [ - ^ root raisedToInteger: aFraction numerator ]. - ^ super raisedToFraction: aFraction! ! -!Integer methodsFor: 'mathematical functions' stamp: 'jmv 5/26/2018 22:19:10' prior: 50367793! - raisedToFraction: aFraction - | root | - self = 0 ifTrue: [ ^0 ]. - aFraction denominator = 2 ifTrue: [ - ^ self sqrt raisedToInteger: aFraction numerator ]. - (self negative and: [ aFraction denominator even ]) ifTrue: [ - ^ (Complex basicReal: self imaginary: 0) raisedToFraction: aFraction]. - root _ self nthRootTruncated: aFraction denominator. - (root raisedToInteger: aFraction denominator) = self ifTrue: [ - ^ root raisedToInteger: aFraction numerator ]. - ^ super raisedToFraction: aFraction! ! -!Complex methodsFor: 'mathematical functions' stamp: 'jmv 5/26/2018 22:24:56' prior: 16822720! - raisedTo: aNumber - "Answer the receiver raised to aNumber." - - aNumber isInteger ifTrue: [ - "Do the special case of integer power" - ^ self raisedToInteger: aNumber]. - aNumber isFraction ifTrue: [ - ^ self raisedToFraction: aNumber]. - - 0 = aNumber ifTrue: [^ self class one]. "Special case of exponent=0" - 1 = aNumber ifTrue: [^ self]. "Special case of exponent=1" - 0 = self ifTrue: [ "Special case of self = 0" - aNumber < 0 - ifTrue: [^ (ZeroDivide dividend: self) signal] - ifFalse: [^ self]]. - ^ (aNumber * self ln) exp "Otherwise use logarithms"! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3338-Complex-raisedTo-JuanVuletich-2018May26-22h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3338] on 27 May 2018 at 7:35:34 pm'! -!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 5/27/2018 19:35:13' prior: 16924221! - browseMethodsWithString: aString - "Launch a browser on all methods that contain string literals with aString as a substring. The search is case-insensitive, unless the shift key is pressed, in which case the search is case-sensitive." - - ^ self browseMethodsWithString: aString matchCase: false - - "Smalltalk browseMethodsWithString: 'Testing' matchCase: false" - "Smalltalk browseMethodsWithString: 'Testing' matchCase: true"! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3339-StringFind-CaseInsensituve-JuanVuletich-2018May27-19h31m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3339] on 1 June 2018 at 8:07:08 pm'! -!PseudoClass methodsFor: 'accessing' stamp: 'jmv 5/31/2018 21:51:33'! - superclassName - ^definition copyUpTo: Character space! ! -!Utilities class methodsFor: 'support windows' stamp: 'jmv 5/31/2018 19:23:46' prior: 16941075! - codeManagementInCuisContents - ^ self class firstCommentAt: #codeManagementInCuisContents - -" -(from http://jvuletich.org/Cuis/CodeManagementInCuis4.html ) - -Starting with version 4.0, Cuis includes tools and suggested procedures for managing Smalltalk code. Code that is not part of the Cuis Core image itself, like applications, frameworks and libraries, should be stored in Packages. New code that is meant as patches, fixes or additions; that could eventually become part of Cuis itself, is not part of any Package, and is therefore automatically stored in Change Sets. - - -Packages ------------- - -Let's start with Packages. The Package implementation in Cuis is based on PackageInfo, the standard way to specify packages in Squeak and its derivatives, and used, for example, by Monticello. It uses Package names, to specify prefixes for Class and Method categories. Classes and Methods whose categories match a Package's prefixes belong in that Package. More details about how PackageInfo decides what code belongs in a package are available at http://wiki.squeak.org/squeak/3329 . - -To install packages (.pck.st files) in Cuis, use the FileList, navigate to the appropriate directory (on disk, or in a GitHub repository, etc), select the package file and click on [Install Package]. - -Cuis includes a tool to manage installed Packages. It is at World / Open / Installed Packages. To create a new package (instead of installing an existing one from a file), click on [Create Package] This creates a new package, and associates with it all the existing code in the image that matches the package name. - -The operations available on installed or newly created packages are: - -[Save] Saves a package on the file system. Overwrites any existing version. It is good to save package from time to time, to reduce the risk of losing code. - -[Delete] Removes the Package instance from the image. Does not remove any code. This means, effectively, to merge back the code into Cuis. - -[Browse unsaved Changes] This opens a ChangeSorter on the ChangeSet that captures all the changes done to the Package since it was last saved. Therefore it shows the work done on the package that would be lost if the package is not saved. - -[Browse Package Code] This opens a Class Browser that only shows the code that belongs in the package. This is useful for working on a package, or studying it. - -The tool shows, for each Package, the name, whether it is dirty (has unsaved changes) and the file it was installed from / saved to. - -Handling Packages like this, Cuis behaves as a sort of document editor (like, for example a regular text editor) whose documents are Package files (.pck.st). Cuis doesn't handle Package versions, ancestries, etc. If versioning of Packages is desired, the best is to use a versioning file repository, such as Git or Mercurial. The recommendation is to use a GitHub repository with a name beginning with 'Cuis-Smalltalk', so it will be easy for anybody to find it. Cuis Package files (.pck.st) are uncompressed, use Lf (ASCII 10) as newLine, and are encoded in ISO 8859-15. This means that they are Git friendly, and Git/GitHub can diff and merge them, and browse them with syntax highlighting. - -This is not unlike using Git or GitHub with a more conventional development environment such as Eclipse or a text editor. Like Cuis 4, these tools don't do version handling themselves, they just load and save files; and let Git do its magic. - - -Changes to the Cuis base image --------------------------------------- - -The way ChangeSets are created and managed in Cuis 4 is very different from previous versions of Cuis (and Squeak & derivatives). This was done to make ChangeSets a good way to manage changes to the base Cuis Core image, while keeping code in Packages out of the way, so they don't get mixed together. - -What is not in a Package belongs (at least temporarily) in the Cuis Core image. Such code is automatically captured in a ChangeSet. The ChangeSet for Core changes is created automatically and named like '1243-CuisCore-JuanVuletich-2012Apr03-22h50m'. The number at the beginning is the next number for the Cuis update stream, and is provided only as a suggestion. The 'CuisCore' part is to reveal that the code belongs in the base image and not in some package. Then we have author name and date / time of creation. These ChangeSets are created automatically. There is no longer a way to manually create them, or make them 'current' or 'active'. It is best not to rename them. These ChangeSets will not capture any code that belongs in a Package. - -Opening a Change Sorter will show the CuisCore change set. This is useful, for example, to check that no code that was intended for a Package ends here by mistake (because of the wrong class or method category). But it is also useful when doing changes to the base system. Now, we can do changes both to the base system and to a number of packages, all in the same session, without having to be careful about selecting the proper change set before saving a method: The code is automatically added to the proper Package or ChangeSet, simply following the class or method category. Gone are the days of messed up change sets and lost code!! - -When the changes to the base system are complete, it is a good time to review the CuisCore change set and, maybe remove from it changes that we don't want to keep (for example, experiments, halts, etc). Then, just do right click / File out and remove. This saves the ChangeSet on disk. It also removes it from the ChangeSorter (but it doesn't remove any code). This is good, because the next changes done will end in a new CuisCore change set, and there's no risk of having undesired changes in the old one. As changes to the base image progress, and several CuisCore change sets are saved to disk, these numbered files are created in sequence. They will be ready to be loaded back in proper order in a fresh Cuis image, or to be sent to Cuis maintainers for integration in the update stream and in next releases of Cuis. - - -Loading ChangeSet files into Cuis ---------------------------------------- - -There are two ways to load ChangeSet files (.cs): [FileIn] and [Install]. - -[FileIn] loads the code without creating a new ChangeSet object. This means that changes that belong in the base image (and not in a package) will be added to the current ChangeSet for Cuis core changes, as if they were done by the user. This is appropriate when we are combining code from more than one source into a single ChangeSet. Any change that belongs in an installed package will be added to it, and the package will appear as dirty. - -[Install] loads the code into a separate ChangeSet object (viewable in the ChangeSorter tool). This is appropriate for loading Cuis updates, or other code that we are not authoring, as it doesn't add new items (class or method definitions) to the current ChangeSet for our changes to Cuis. Usually any ChangeSets should be installed before doing changes to the image. The reason is that an installed ChangeSet could overwrite changes done by you, or packages you have installed. If this is the case, the affected packages would appear as dirty, and your change set would include any installed changes (that don't belong in a package). Be careful when saving packages or change sets if this was the case!! -" - -" -Utilities codeManagementInCuisContents edit -"! ! -!PseudoClass methodsFor: 'fileIn/fileOut' stamp: 'jmv 5/31/2018 21:51:47' prior: 16896967! - fileInDefinition - (self makeSureSuperClassExists: self superclassName) ifFalse:[^self]. - self hasDefinition ifTrue:[ - Transcript newLine; show:'Defining ', self name. - self evaluate: self definition]. - self exists ifFalse:[^self]. - self hasComment ifTrue:[self realClass classComment: self comment].! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3340-tweaks-JuanVuletich-2018Jun01-20h06m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3341] on 1 June 2018 at 8:59:47 pm'! -!CodePackage class methodsFor: 'installing' stamp: 'jmv 6/1/2018 20:59:14'! - postPackageInstall - "This gets called after installing all the package code. - Redefine as appropriate"! ! -!CodePackage class methodsFor: 'installing' stamp: 'jmv 6/1/2018 20:59:33'! - prePackageInstall - "This gets called after creating the package class and installing its code, but before installing the rest of the package code - Redefine as appropriate"! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3341-pre-post-packageInstall-CuisCore-JuanVuletich-2018Jun01-20h58m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3341] on 2 June 2018 at 5:00:22 pm'! -!CodePackage methodsFor: 'accessing' stamp: 'jmv 6/2/2018 16:58:49'! - codePackageClass - "Answer the specific CodePackage subclass to use." - - self class == CodePackage ifFalse: [ - ^ self class ]. - self classesDo: [ :cls | - (cls inheritsFrom: CodePackage) - ifTrue: [ ^ cls ]]. - ^ nil! ! -!CodePackage methodsFor: 'saving' stamp: 'jmv 6/2/2018 16:59:03' prior: 50389803! - writeOnStream: aStream - - | sortedClasses | - aStream - nextChunkPut: ('Description ', description) printString; - newLine. - self writeFeatureSpecOn: aStream. - self writeSystemCategoriesOn: aStream. - - self codePackageClass ifNotNil: [ :codePackageClass | - self - write: {codePackageClass} classDefinitionsOn: aStream; - write: {codePackageClass} classCommentsOn: aStream; - write: {codePackageClass} methodsOn: aStream. - aStream nextChunkPut: codePackageClass name, ' prePackageInstall'; newLine ]. - - sortedClasses _ Array streamContents: [ :strm | - self classesInSafeOrderDo: [ :cls | - cls == self class ifFalse: [ - strm nextPut: cls ]]]. - self - write: sortedClasses classDefinitionsOn: aStream; - write: sortedClasses classCommentsOn: aStream; - write: sortedClasses methodsOn: aStream. - - self - sortedExtensionMethodsDo: [ :methodReference | - methodReference isValid ifTrue: [ - self writeMethod: methodReference on: aStream ]] - displayingProgress: 'Saving extension methods...'. - self write: sortedClasses initializersOn: aStream. - - self codePackageClass ifNotNil: [ :codePackageClass | - self write: { codePackageClass } initializersOn: aStream. - aStream nextChunkPut: codePackageClass name, ' postPackageInstall'; newLine ]! ! -!CodePackageFile methodsFor: 'services' stamp: 'jmv 6/2/2018 16:59:49' prior: 16810879! - install: aFileStream - "Installs the package. Replace all existing code in the CodePackage, removing any code that is not included in us." - | localName newCodePackage pckClass | - - "Give reasonable warnings if there is stuff that can't be properly cleaned. Give the user the chance to abort." - '=============' print. - classesToRemove notEmpty ifTrue: [ - ('classesToRemove: ', classesToRemove printString) print. - '=============' print ]. - methodsToRemove notEmpty ifTrue: [ - 'methodsToRemove: ' print. - methodsToRemove do: [ :methodReference | methodReference print ]. - '=============' print ]. - - "Tirar warning si hay que borrar cosas que no se puede, si hay referencias, etc. Quizas si vamos a borrar el ultimo implementor de un mensaje enviado?" - - localName _ fullName asFileEntry name. - ChangeSet installing: packageName do: [ - aFileStream fileInAnnouncing: 'Installing ', localName, '...'. - methodsToRemove do: [ :methodReference | methodReference actualClass removeSelector: methodReference selector ]. - classesToRemove do: [ :className | (Smalltalk at: className) removeFromSystem ]. - "Create, install and answer an instance of CodePackage" - pckClass _ CodePackage. - classes do: [ :ee | (ee hasDefinition and: [ee superclassName = 'CodePackage']) ifTrue: [ - pckClass _ Smalltalk at: ee name ]]. - newCodePackage _ pckClass - named: packageName - createIfAbsent: true - registerIfNew: true. - newCodePackage - fullFileName: fullName; - sourceSystem: sourceSystem; - description: description; - featureSpec: featureSpec. - ]. - newCodePackage hasUnsavedChanges: false; triggerEvent: #dirtyFlagChanged. - DataStream initialize. "Just in case" - "If we are installing an already installed package, zap the change set with possible changes done, - as they are irrelevant now: we have the package from disk" - ChangeSet removeChangeSet: (ChangeSet existingOrNewChangeSetForPackage: newCodePackage). - Transcript newLine; show: 'Package ', packageName, ' successfully installed'; newLine. - - "Tirar undeclared al transcript. warning si quedaron undeclared - Es feo que tire an transcript undeclareds que despues no lo son..." - Smalltalk cleanOutUndeclared. - Undeclared notEmpty ifTrue: [ - ('Undeclared: ', Undeclared printString) print ]. - - "Descartar la instancia de CodePackageFile" - ^newCodePackage! ! - -CodePackage removeSelector: #writeInitializerExtensionMethods:on:! - -CodePackage removeSelector: #writeInitializerExtensionMethods:on:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3342-supportFor-CodePackage-subclasses-JuanVuletich-2018Jun02-16h57m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3341] on 1 June 2018 at 8:56:07 pm'! - -FloatArray variableWordSubclass: #Color - instanceVariableNames: '' - classVariableNames: 'CachedColormaps ColorNamesDict FromGrayColormaps GrayToIndexMap IndexedColors MaskingMap ToGrayColormaps ' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -!classDefinition: #Color category: #'Graphics-Primitives'! -FloatArray variableWordSubclass: #Color - instanceVariableNames: '' - classVariableNames: 'CachedColormaps ColorNamesDict FromGrayColormaps GrayToIndexMap IndexedColors MaskingMap ToGrayColormaps' - poolDictionaries: '' - category: 'Graphics-Primitives'! -!Color methodsFor: 'other' stamp: 'jmv 6/1/2018 20:55:02' prior: 50388998! - colorName - "Return this color's name, or nil if it has no name. Only returns a name if it exactly matches the named color. - Return nil if named color support is not present" - - Color classPool - at: #ColorNamesDict - ifPresent: [ :dict | ^dict keyAtValue: self ifAbsent: [nil]]. - ^nil! ! -!Color class methodsFor: 'cached state access' stamp: 'jmv 6/1/2018 20:55:34' prior: 50389199! - releaseClassCachedState - " - Color releaseClassCachedState - " - CachedColormaps _ nil. "Maps to translate between color depths" - ToGrayColormaps _ nil. "Maps colors to 8bpp grays for various color depths" - FromGrayColormaps _ nil. "Maps from 8bpp grays to colors of various depths" - MaskingMap _ nil. "Maps all colors except transparent to black for creating a mask" - IndexedColors _ nil. - GrayToIndexMap _ nil! ! - -FloatArray variableWordSubclass: #Color - instanceVariableNames: '' - classVariableNames: 'CachedColormaps FromGrayColormaps GrayToIndexMap IndexedColors MaskingMap ToGrayColormaps' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -!classDefinition: #Color category: #'Graphics-Primitives'! -FloatArray variableWordSubclass: #Color - instanceVariableNames: '' - classVariableNames: 'CachedColormaps FromGrayColormaps GrayToIndexMap IndexedColors MaskingMap ToGrayColormaps' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3343-RemoveUnused-Color-classVar-JuanVuletich-2018Jun01-20h54m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3343] on 2 June 2018 at 5:24:58 pm'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 6/2/2018 17:24:20' prior: 50375390! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3344-Add-NahuelGarbezza-asAuthor-JuanVuletich-2018Jun02-17h23m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3333] on 27 May 2018 at 1:46:20 am'! -!CodeWindow methodsFor: 'keyboard shortcuts' stamp: 'RNG 5/27/2018 01:44:26'! - messageCatListKey: aChar from: view - - aChar == $o ifTrue: [^ model fileOutMessageCategories ]. - aChar == $t ifTrue: [^ model runMessageCategoryTests ]. - aChar == $x ifTrue: [^ model removeMessageCategory ].! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'RNG 5/27/2018 01:43:23' prior: 16793073! - buildMorphicMessageCatList - - ^PluggableListMorph - model: model - listGetter: #messageCategoryList - indexGetter: #messageCategoryListIndex - indexSetter: #messageCategoryListIndex: - mainView: self - menuGetter: #messageCategoryMenu - keystrokeAction: #messageCatListKey:from:! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'RNG 5/27/2018 01:43:51' prior: 50398397! - messageCategoryMenu - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Message Category'. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'fileOut (o)'. - #object -> #model. - #selector -> #fileOutMessageCategories. - #icon -> #fileOutIcon - } asDictionary. - nil. - { - #label -> 'reorganize'. - #object -> #model. - #selector -> #editMessageCategories. - #icon -> #sendReceiveIcon - } asDictionary. - { - #label -> 'alphabetize'. - #object -> #model. - #selector -> #alphabetizeMessageCategories. - #icon -> #fontXGenericIcon - } asDictionary. - { - #label -> 'remove empty categories'. - #object -> #model. - #selector -> #removeEmptyCategories. - #icon -> #listRemoveIcon - } asDictionary. - { - #label -> 'categorize all uncategorized'. - #object -> #model. - #selector -> #categorizeAllUncategorizedMethods. - #icon -> #packageIcon - } asDictionary. - { - #label -> 'new category...'. - #object -> #model. - #selector -> #addCategory. - #icon -> #newIcon - } asDictionary. - nil. - { - #label -> 'rename...'. - #object -> #model. - #selector -> #renameCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #label -> 'remove (x)'. - #object -> #model. - #selector -> #removeMessageCategory. - #icon -> #deleteIcon - } asDictionary. - nil. - { - #label -> 'Run tests (t)'. - #object -> #model. - #selector -> #runMessageCategoryTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - }`. - ^ aMenu! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3345-KeyboardShortcutForMessageCategories-NahuelGarbezza-2018May27-01h24m-RNG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3345] on 14 June 2018 at 2:11:19 pm'! -!CompiledMethod methodsFor: 'source code management' stamp: 'jmv 6/14/2018 14:06:32' prior: 50381369! - getPreambleFrom: aFileStream at: position - | writeStream c p | - writeStream _ String new writeStream. - p _ position. - c _ nil. - aFileStream position: p. - aFileStream atEnd ifTrue: [ ^ nil ]. - [ p >= 0 and: [ c ~~ $!! ]] whileTrue: [ - aFileStream position: p. - c _ aFileStream basicNext. - p _ p - 1 ]. - [ p >= 0] whileTrue: [ - aFileStream position: p. - c _ aFileStream basicNext. - c == $!! - ifTrue: [^ writeStream contents reverse ] - ifFalse: [ writeStream nextPut: c ]. - p _ p - 1 ]. - ^ nil! ! -!RemoteString methodsFor: 'accessing' stamp: 'jmv 6/14/2018 14:11:09' prior: 16900625! - string - "Answer the receiver's string if remote files are enabled." - | theFile answer | - (sourceFileNumber == nil or: [(SourceFiles at: sourceFileNumber) == nil]) ifTrue: [^nil]. - theFile _ SourceFiles at: sourceFileNumber. - theFile position: filePositionHi. - answer _ theFile nextChunk. - ^answer isEmpty ifTrue: [nil] ifFalse: [answer]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3346-FixSlowdownsWhenMissingChangesFile-JuanVuletich-2018Jun14-14h10m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3345] on 5 June 2018 at 11:03:34 am'! -!CodePackage methodsFor: 'naming' stamp: 'jmv 6/5/2018 11:02:21' prior: 16810412! - packageName: aString - packageName _ aString. - description _ 'Please enter a description for this package'. - featureSpec _ FeatureSpec new. - featureSpec provides: (Feature name: packageName version: 1 revision: 0). - hasUnsavedChanges _ self includesAnyCode. - "But reset revision if it was incremented because of marking it dirty!!" - featureSpec provides name: packageName version: 1 revision: 0! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3347-PackageInstallFix-JuanVuletich-2018Jun05-11h03m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3347] on 15 June 2018 at 10:10:07 am'! -!PseudoClass methodsFor: 'fileIn/fileOut' stamp: 'jmv 6/15/2018 10:06:19'! - fileInDefinitionAndMetaclass - self fileInDefinition. - metaClass ifNotNil: [ metaClass fileInDefinition ]! ! -!CodePackageFile methodsFor: 'services' stamp: 'jmv 6/15/2018 10:09:12' prior: 50401046! - install: aFileStream - "Installs the package. Replace all existing code in the CodePackage, removing any code that is not included in us." - | localName newCodePackage pckClass | - - "Give reasonable warnings if there is stuff that can't be properly cleaned. Give the user the chance to abort." - '=============' print. - classesToRemove notEmpty ifTrue: [ - ('classesToRemove: ', classesToRemove printString) print. - '=============' print ]. - methodsToRemove notEmpty ifTrue: [ - 'methodsToRemove: ' print. - methodsToRemove do: [ :methodReference | methodReference print ]. - '=============' print ]. - - "Tirar warning si hay que borrar cosas que no se puede, si hay referencias, etc. Quizas si vamos a borrar el ultimo implementor de un mensaje enviado?" - - "Create, install and answer a (sub)instance of CodePackage" - pckClass _ CodePackage. - classes do: [ :ee | - (ee hasDefinition and: [ee superclassName = 'CodePackage']) ifTrue: [ - ee fileInDefinitionAndMetaclass. - pckClass _ Smalltalk at: ee name ]]. - newCodePackage _ pckClass - named: packageName - createIfAbsent: true - registerIfNew: true. - - localName _ fullName asFileEntry name. - ChangeSet installing: packageName do: [ - newCodePackage - fullFileName: fullName; - sourceSystem: sourceSystem; - description: description; - featureSpec: featureSpec. - aFileStream fileInAnnouncing: 'Installing ', localName, '...'. - methodsToRemove do: [ :methodReference | methodReference actualClass removeSelector: methodReference selector ]. - classesToRemove do: [ :className | (Smalltalk at: className) removeFromSystem ]]. - newCodePackage hasUnsavedChanges: false; triggerEvent: #dirtyFlagChanged. - DataStream initialize. "Just in case" - "If we are installing an already installed package, zap the change set with possible changes done, - as they are irrelevant now: we have the package from disk" - ChangeSet removeChangeSet: (ChangeSet existingOrNewChangeSetForPackage: newCodePackage). - Transcript newLine; show: 'Package ', packageName, ' successfully installed'; newLine. - - "Tirar undeclared al transcript. warning si quedaron undeclared - Es feo que tire an transcript undeclareds que despues no lo son..." - Smalltalk cleanOutUndeclared. - Undeclared notEmpty ifTrue: [ - ('Undeclared: ', Undeclared printString) print ]. - - "Descartar la instancia de CodePackageFile" - ^newCodePackage! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3348-CreatePackageInstance-beforeInstall-JuanVuletich-2018Jun15-10h00m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3345] on 13 June 2018 at 4:12:00 pm'! -!BrowserWindow methodsFor: 'keyboard shortcuts' stamp: 'HAW 6/13/2018 16:07:19'! - systemCatListKey: aChar from: view - - aChar == $r ifTrue: [^ model recent ]. - - ^super systemCatListKey: aChar from: view! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3349-recentClasses-shortcutFix-HernanWilkinson-2018Jun13-15h21m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3345] on 14 June 2018 at 12:30:21 pm'! - -Object subclass: #PopUpMenu - instanceVariableNames: 'labelString lineArray icons ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Menus'! - -!classDefinition: #PopUpMenu category: #'Tools-Menus'! -Object subclass: #PopUpMenu - instanceVariableNames: 'labelString lineArray icons' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Menus'! -!MenuMorph methodsFor: 'construction' stamp: 'HAW 6/14/2018 12:12:12'! - add: aString target: target action: aSymbol argument: arg icon: symbolOrFormOrNil - - ^(self add: aString - target: target - action: aSymbol - argumentList: { arg }) - setIcon: symbolOrFormOrNil; - yourself -! ! -!PopUpMenu methodsFor: 'accessing' stamp: 'HAW 6/14/2018 12:13:38'! - iconAt: aPosition - - ^icons at: aPosition ifAbsent: [ nil ]! ! -!PopUpMenu methodsFor: 'private' stamp: 'HAW 6/14/2018 11:56:15'! -labels: aString lines: anArray icons: iconCollection - - labelString _ aString. - lineArray _ anArray. - icons _ iconCollection -! ! -!PopUpMenu class methodsFor: 'instance creation' stamp: 'HAW 6/14/2018 12:25:34'! - labelArray: labelArray lines: lineArray icons: icons - "Answer an instance of me whose items are in labelArray, with lines - drawn after each item indexed by anArray. 2/1/96 sw" - - labelArray isEmpty ifTrue: [self error: 'Menu must not be zero size']. - ^ self - labels: (String streamContents: - [:stream | - labelArray do: [:each | stream nextPutAll: each; newLine]. - stream skip: -1 "remove last newline"]) - lines: lineArray - icons: icons - -"Example: - (PopUpMenu labelArray: #('frog' 'and' 'toad') lines: #() icons: #()) startUpWithCaption: 'Please pick one.' -"! ! -!PopUpMenu class methodsFor: 'instance creation' stamp: 'HAW 6/14/2018 12:04:54'! - labels: aString lines: anArray icons: icons - "Answer an instance of me whose items are in aString, with lines drawn - after each item indexed by anArray and icons per item." - - ^ self new labels: aString lines: anArray icons: icons! ! -!PopUpMenu class methodsFor: 'dialogs' stamp: 'HAW 6/14/2018 12:21:38'! - confirm: queryString trueChoice: trueChoice falseChoice: falseChoice icons: icons - "Put up a yes/no menu with caption queryString. The actual wording - for the two choices will be as provided in the trueChoice and - falseChoice parameters. Answer true if the response is the true-choice, - false if it's the false-choice. - This is a modal question -- the user must respond one way or the other." - - "PopUpMenu confirm: 'Are you hungry?' trueChoice: 'yes, I''m famished' falseChoice: 'no, I just ate'" - - "PopUpMenu confirm: 'Are you hungry?' trueChoice: 'yes, I''m famished' falseChoice: 'no, I just ate' icons: #(acceptIcon cancelIcon)" - - | menu choice | - menu _ self labelArray: {trueChoice. falseChoice} lines: nil icons: icons. - [(choice _ menu startUpWithCaption: queryString) isNil] whileTrue. - ^ choice = 1! ! -!MVCMenuMorph class methodsFor: 'instance creation' stamp: 'HAW 6/14/2018 12:13:56' prior: 50397570! - from: aPopupMenu title: titleStringOrNil - "Answer a MenuMorph constructed from the given PopUpMenu. Used to simulate MVC-style menus in a Morphic-only world." - - | menu items lines selections labelString j emphasis | - menu _ self new. - titleStringOrNil ifNotNil: [ - titleStringOrNil isEmpty ifFalse: [menu addTitle: titleStringOrNil]]. - labelString _ aPopupMenu labelString. - items _ labelString asString lines. - (labelString is: #Text) ifTrue: [ - "Pass along text emphasis if present" - j _ 1. - items _ items collect: [ :item | - j _ labelString asString findString: item startingAt: j. - emphasis _ TextEmphasis new emphasisCode: (labelString emphasisAt: j). - item asText addAttribute: emphasis]]. - lines _ aPopupMenu lineArray. - lines ifNil: [lines _ #()]. - menu cancelValue: 0. - menu defaultTarget: menu. - selections _ (1 to: items size) asArray. - 1 to: items size do: [ :i | - menu add: (items at: i) target: menu action: #selectMVCItem: argument: (selections at: i) icon: (aPopupMenu iconAt: i). - (lines includes: i) ifTrue: [menu addLine]]. - ^ menu -! ! -!PopUpMenu methodsFor: 'private' stamp: 'HAW 6/14/2018 11:56:37' prior: 16891046! - labels: aString lines: anArray - - self labels: aString lines: anArray icons: #()! ! -!PopUpMenu class methodsFor: 'instance creation' stamp: 'HAW 6/14/2018 12:02:45' prior: 16891064! - labelArray: labelArray lines: lineArray - - ^self labelArray: labelArray lines: lineArray icons: #()! ! -!PopUpMenu class methodsFor: 'instance creation' stamp: 'HAW 6/14/2018 12:04:21' prior: 16891089! - labels: aString lines: anArray - "Answer an instance of me whose items are in aString, with lines drawn - after each item indexed by anArray." - - ^ self labels: aString lines: anArray icons: #()! ! -!PopUpMenu class methodsFor: 'dialogs' stamp: 'HAW 6/14/2018 12:18:59' prior: 50395781! - confirm: queryString - "Put up a yes/no menu with caption queryString. Answer true if the - response is yes, false if no. This is a modal question--the user must - respond yes or no." - - " - PopUpMenu confirm: 'Are you hungry?' - " - - ^ self confirm: queryString trueChoice: 'Yes' falseChoice: 'No' icons: #(acceptIcon cancelIcon)! ! -!PopUpMenu class methodsFor: 'dialogs' stamp: 'HAW 6/14/2018 12:17:00' prior: 16891125! - confirm: queryString orCancel: cancelBlock - "Put up a yes/no/cancel menu with caption aString. Answer true if - the response is yes, false if no. If cancel is chosen, evaluate - cancelBlock. This is a modal question--the user must respond yes or no." - - "PopUpMenu confirm: 'Reboot universe' orCancel: [^'Nevermind']" - - | menu choice | - menu _ self labelArray: {'Yes'. 'No'. 'Cancel'} lines: #() icons: #(acceptIcon cancelIcon collapseIcon). - choice _ menu startUpWithCaption: queryString. - choice = 1 ifTrue: [^ true]. - choice = 2 ifTrue: [^ false]. - ^ cancelBlock value! ! -!PopUpMenu class methodsFor: 'dialogs' stamp: 'HAW 6/14/2018 12:22:28' prior: 16891144! - confirm: queryString trueChoice: trueChoice falseChoice: falseChoice - - "See #confirm:trueChoice:falseChoice:icons:" - - ^self confirm: queryString trueChoice: trueChoice falseChoice: falseChoice icons: #()! ! - -PopUpMenu removeSelector: #icons! - -Object subclass: #PopUpMenu - instanceVariableNames: 'labelString lineArray icons' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Menus'! - -!classDefinition: #PopUpMenu category: #'Tools-Menus'! -Object subclass: #PopUpMenu - instanceVariableNames: 'labelString lineArray icons' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Menus'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3350-IconsInPopUpMenu-HernanWilkinson-2018Jun14-11h15m-HAW.1.cs.st----! - -----SNAPSHOT----#(15 June 2018 11:05:40.747228 am) Cuis5.0-3350-32.image priorSource: 2196622! - -----QUIT----#(15 June 2018 11:06:01.583723 am) Cuis5.0-3350-32.image priorSource: 2246921! - -----STARTUP----#(11 July 2018 3:43:00.772945 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3350-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3350] on 15 June 2018 at 8:06:45 pm'! -!Theme methodsFor: 'private - shout mappings' stamp: 'jmv 6/15/2018 19:47:32'! - blockLevelOne - - ^ #( - blockStart1 - blockEnd1 - leftParenthesis1 - rightParenthesis1 - )! ! -!Theme methodsFor: 'private - shout mappings' stamp: 'jmv 6/15/2018 19:44:15'! - blockLevelThree - - ^ #( - blockStart3 - blockEnd3 - leftParenthesis3 - rightParenthesis3 - ) -! ! -!Theme methodsFor: 'private - shout mappings' stamp: 'jmv 6/15/2018 19:45:51'! - blockLevelTwo - - ^ #( - blockStart2 - blockEnd2 - leftParenthesis2 - rightParenthesis2 - ) -! ! -!Theme methodsFor: 'private - shout mappings' stamp: 'jmv 6/15/2018 19:53:16'! - blockLevelZero - - ^ #( - blockStart - blockEnd - leftParenthesis - rightParenthesis - )! ! -!Theme methodsFor: 'private - shout mappings' stamp: 'jmv 6/15/2018 19:53:22' prior: 16935803! - defaults - - ^ #( - default - arrayStart - arrayEnd - arrayStart1 - arrayEnd1 - leftBrace - rightBrace - cascadeSeparator - chainSeparator - statementSeparator - externalCallType - externalCallTypePointerIndicator - blockArgColon - )! ! -!Theme methodsFor: 'private - shout mappings' stamp: 'jmv 6/15/2018 20:06:29' prior: 16935821! - generateShoutConfig - - | styles colors | - styles := OrderedCollection new. - colors := self shout as: Dictionary. - - { - {self undefined. colors at: #undefined}. - {self defaults . colors at: #defaults}. - {self pseudoVariables . colors at: #pseudoVariables}. - {self literals . colors at: #literals}. - {self instVar . colors at: #instVar}. - {self messages . colors at: #messages}. - {self blockLevelZero . colors at: #blockLevelZero}. - {self blockLevelOne . colors at: #blockLevelOne}. - {self blockLevelTwo . colors at: #blockLevelTwo}. - {self blockLevelThree . colors at: #blockLevelThree}. - {self blockLevelFour . colors at: #blockLevelFour}. - {self blockLevelFive . colors at: #blockLevelFive}. - {self blockLevelSix . colors at: #blockLevelSix}. - {self blockLevelSeven . colors at: #blockLevelSeven}. - {self tempBar . colors at: #tempBar}. - {self methodTags . colors at: #methodTags . #bold}. - {self globals . colors at: #defaults . #bold}. - {self incompleteMessages . colors at: #incompleteMessages . #underlined}. - {self argumentTypes . colors at: #arguments . self italic}. - {self symbols . colors at: #messages . #bold}. - {self pattern . nil . #bold}. - {self ansiAssignment . nil . #bold}. - {self assignment . nil . #(#bold #withST80Glyphs)}. - {self return . nil . #(#bold #withST80Glyphs)}. - {self tempVars . colors at: #tempVars . self italic}. - {self blockTemps . colors at: #tempBar . self italic} - } do: [ :style | - styles addAll: - (style first - collect: [ :category | | elements | - elements _ style asOrderedCollection. - elements at: 1 put: category. - Array withAll: elements ])]. - - "Miscellaneous remainder after factoring out commonality:" - styles addAll: { - {#unfinishedString . colors at: #undefined . #normal}. - {#undefinedIdentifier . colors at: #undefined .#bold}. - {#unfinishedComment . colors at: #pseudoVariables . self italic}. - {#comment . colors at: #comment . self italic}. - {#string . colors at: #instVar . #normal}. - {#literal . nil . self italic}. - {#incompleteIdentifier . colors at: #tempVars . {#italic. #underlined}}. - {#classVar . colors at: #tempVars . #bold}. - }. - - ^ styles! ! -!Theme methodsFor: 'private - shout mappings' stamp: 'jmv 6/15/2018 19:45:42' prior: 16935897! - instVar - ^ #( - instVar - )! ! -!Theme methodsFor: 'private - shout mappings' stamp: 'jmv 6/15/2018 19:44:23' prior: 16935909! - literals - - ^ #( - character - integer - number - - - )! ! -!Theme methodsFor: 'shout' stamp: 'jmv 6/15/2018 20:06:11' prior: 16936786! - shout - "Color symbols as an association list. - SHTextStylerST80 initialize - " - - ^ { - #defaults -> #black. - #undefined -> #red. - #comment -> #(green muchDarker). - #methodTags -> #(green muchDarker). - #pseudoVariables -> #(red muchDarker). - #literals -> #(green muchDarker). - #messages -> #(blue darker). - #arguments -> #(cyan muchDarker). - #instVar -> #(magenta muchDarker). - #incompleteMessages -> #(gray veryMuchDarker). - #blockLevelZero -> #black. - #blockLevelOne -> #brown. - #blockLevelTwo -> #magenta. - #blockLevelThree -> #red. - #blockLevelFour -> #(orange darker). - #blockLevelFive -> #(orange muchDarker). - #blockLevelSix -> #(green muchDarker). - #blockLevelSeven -> #blue. - #tempBar -> #gray. - #tempVars -> #(gray muchDarker). - }! ! - -Theme removeSelector: #firstBlockLevel! - -Theme removeSelector: #firstBlockLevel! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - SHTextStylerST80 initialize! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3351-SyntaxHighlightEnhancements-JuanVuletich-2018Jun15-19h59m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3351] on 21 June 2018 at 2:06:07 pm'! -!PluggableMorph methodsFor: 'access' stamp: 'jmv 6/20/2018 22:42:04'! - balloonText - "Answer balloon help text or nil, if no help is available. - NB: subclasses may override such that they programatically - construct the text, for economy's sake, such as model phrases in - a Viewer" - - | balloonText | - balloonText _ super balloonText. - balloonText isSymbol ifTrue: [ ^model perform: balloonText ]. - ^ balloonText! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 6/20/2018 22:38:58' prior: 16875792! - setBalloonText: stringTextOrSymbol - "Set receiver's balloon help text. Pass nil to remove the help." - - stringTextOrSymbol - ifNil: [ self removeProperty: #balloonText ] - ifNotNil: [ - self setProperty: #balloonText - toValue: ((stringTextOrSymbol is: Text) - ifTrue: [ stringTextOrSymbol asString ] - ifFalse: [ stringTextOrSymbol ])]! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 6/20/2018 22:33:30' prior: 50341586! - addButtonFor: aMorph - - | button | - aMorph == self ifFalse: [ - button _ PluggableButtonMorph - model: aMorph - stateGetter: nil - action: #toggleCollapseOrShow. - button - color: self color; - icon: (aMorph imageForm: 32); - setBalloonText: #label. - button icon: button magnifiedIcon. - viewBox - addMorph: button - fixedWidth: self defaultHeight ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3352-KeepTaskButtonBalloonUpdated-JuanVuletich-2018Jun21-14h05m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3351] on 21 June 2018 at 2:06:28 pm'! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 6/21/2018 13:41:37' prior: 50371190! - parse: isAMethod - "Parse the receiver's text. If isAMethod is true - then treat text as a method, if false as an - expression with no message pattern" - - self initializeInstanceVariables. - sourcePosition _ 1. - arguments _ Dictionary new. - temporaries _ Dictionary new. - blockDepth _ bracketDepth := 0. - blockDepths _ OrderedCollection with: blockDepth. - blockDepthsStartIndexes _ OrderedCollection with: sourcePosition. - ranges ifNil: [ ranges := OrderedCollection new: 100] ifNotNil: [ ranges reset]. - errorBlock _ [^false]. - [ - self scanNext. - isAMethod - ifTrue: [ - self parseMessagePattern. - self parsePragmaSequence]. - self parseMethodTemporaries. - isAMethod ifTrue: [self parsePragmaSequence]. - "Iterate once for methods, but pontentially several times for workspaces - (to recover after errors, for possible good next lines or chunks)" - [ sourcePosition <= source size ] whileTrue: [ - self parseStatementList. - currentToken ifNotNil: [ - "Only if we are parsing a method, consider everything after this point as error." - isAMethod ifTrue: [self error]] - ]. - ] ensure: [errorBlock _ nil]. - ^true! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3353-ShoutWorkspacesBychunks-JuanVuletich-2018Jun21-14h06m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3353] on 25 June 2018 at 12:07:56 pm'! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2018 12:03:06'! - argument - "Answer the argument of the receiver (see Complex | argument). - Answer is in (-Pi .. +Pi] - Note: Assume the convention of 0+0i having argument=0" - - ^self < 0 - ifFalse: [0] - ifTrue: [Float pi]! ! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2018 12:03:18'! - phase - "Answer the argument of the receiver. - Answer is in (-Pi .. +Pi] - Note: Assume the convention of 0+0i having argument=0" - - ^ self argument! ! -!Number methodsFor: 'arithmetic' stamp: 'jmv 6/25/2018 11:58:51' prior: 16879685! - arg - "Answer the argument of the receiver (see Complex | arg). - Note: #argument and #phase assume the convention of 0+0i having argument=0" - - self isZero ifTrue: [self error: 'Zero (0 + 0 i) does not have an argument.']. - ^self < 0 - ifFalse: [0] - ifTrue: [Float pi]! ! -!Complex methodsFor: 'accessing' stamp: 'jmv 6/25/2018 12:01:46' prior: 16822295! - argument - "Answer the argument of the receiver. - Answer is in (-Pi .. +Pi]" - - self isZero ifTrue: [ ^0.0 ]. - ^imaginary arcTan: real! ! -!Complex methodsFor: 'accessing' stamp: 'jmv 6/25/2018 11:52:36' prior: 16822305! - magnitude - "Answer the distance of the receiver from zero (0 + 0 i)." - - ^ self abs! ! -!Complex methodsFor: 'accessing' stamp: 'jmv 6/25/2018 12:03:15' prior: 16822311! - phase - "Answer the argument of the receiver. - Answer is in (-Pi .. +Pi] - Note: Assume the convention of 0+0i having argument=0" - - ^ self argument! ! -!Complex methodsFor: 'arithmetic' stamp: 'jmv 6/25/2018 12:02:03' prior: 16822400! - arg - "Answer the argument of the receiver. - Answer is in (-Pi .. +Pi] - Note: #argument and #phase assume the convention of 0+0i having argument=0" - - self isZero ifTrue: [self error: 'zero has no argument.']. - ^imaginary arcTan: real! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3354-Complex-enh-JuanVuletich-2018Jun25-10h42m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3348] on 30 June 2018 at 7:27:04 pm'! -!PopUpMenu class methodsFor: 'instance creation' stamp: 'HAW 6/30/2018 19:26:48'! - labels: aString icons: icons - "Answer an instance of me whose items are in aString." - - ^self labels: aString lines: nil icons: icons! ! -!PopUpMenu class methodsFor: 'dialogs' stamp: 'HAW 6/30/2018 19:26:35' prior: 50380095! -inform: aString - "PopUpMenu inform: 'I like Cuis'" - - UISupervisor whenUIinSafeState: [ (self labels: ' OK ' icons: #(emblemImportantIcon)) startUpWithCaption: aString ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3355-inform_withIcon-HernanWilkinson-2018Jun30-19h26m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3348] on 1 July 2018 at 1:15:10 pm'! -!UndeclaredVariable methodsFor: 'exception handling' stamp: 'HAW 7/1/2018 13:05:18'! - defaultAction - - | labels actions lines caption choice icons | - - labels _ OrderedCollection new. - actions _ OrderedCollection new. - lines _ OrderedCollection new. - icons _ OrderedCollection new. - - self createMenuOptionsAddingTo: labels actions: actions icons: icons lines: lines. - caption _ 'Unknown variable: ' , name , ' please correct, or cancel:'. - choice _ (PopUpMenu labelArray: labels lines: lines icons: icons) startUpWithCaption: caption. - - self resume: (actions at: choice ifAbsent:[ nil ]).! ! -!UndeclaredVariable methodsFor: 'exception handling - private' stamp: 'HAW 7/1/2018 12:59:52'! - addAlternativesTo: labels actions: actions icons: icons - - | alternatives | - - alternatives _ parser possibleVariablesFor: name. - alternatives do: [ :each | - labels add: each. - actions add: [ parser substituteVariable: each atInterval: interval ]. - icons add: nil ]. -! ! -!UndeclaredVariable methodsFor: 'exception handling - private' stamp: 'HAW 7/1/2018 12:55:34'! - addCancelTo: labels actions: actions icons: icons - - labels add: 'cancel'. - actions add: nil. - icons add: #cancelIcon. - -! ! -!UndeclaredVariable methodsFor: 'exception handling - private' stamp: 'HAW 7/1/2018 12:50:36'! - addGlobalVariableOptionsTo: labels actions: actions - - labels add: 'define new class'. - actions add: [ parser defineClass: name ]. - - labels add: 'declare global'. - actions add: [ parser declareGlobal: name ]. - - parser canDeclareClassVariable ifTrue: [ - labels add: 'declare class variable'. - actions add: [ parser declareClassVar: name ]] -! ! -!UndeclaredVariable methodsFor: 'exception handling - private' stamp: 'HAW 7/1/2018 12:49:43'! - addLocalVariableOptionsTo: labels actions: actions - - labels add: 'declare block-local temp'. - actions add: [ parser declareTemp: name at: #block ]. - - labels add: 'declare method temp'. - actions add: [ parser declareTemp: name at: #method ]. - - parser canDeclareInstanceVariable ifTrue: [ - labels add: 'declare instance'. - actions add: [ parser declareInstVar: name ]]! ! -!UndeclaredVariable methodsFor: 'exception handling - private' stamp: 'HAW 7/1/2018 12:52:33'! - addOptionsTo: labels actions: actions icons: icons - - name first isLowercase - ifTrue: [ self addLocalVariableOptionsTo: labels actions: actions ] - ifFalse: [ self addGlobalVariableOptionsTo: labels actions: actions ]. - labels size timesRepeat: [ icons add: #listAddIcon ]. - -! ! -!UndeclaredVariable methodsFor: 'exception handling - private' stamp: 'HAW 7/1/2018 12:59:24'! - createMenuOptionsAddingTo: labels actions: actions icons: icons lines: lines - - self addOptionsTo: labels actions: actions icons: icons. - lines add: labels size. - self addAlternativesTo: labels actions: actions icons: icons. - lines add: labels size. - self addCancelTo: labels actions: actions icons: icons.! ! -!UndefinedVariable methodsFor: 'exception handling' stamp: 'HAW 7/1/2018 12:17:22'! - defaultAction - - | shouldResume | - - shouldResume := PopUpMenu confirm: name, ' appears to be\undefined at this point.\Proceed anyway?' withNewLines. - ^ self resume: shouldResume ! ! -!UnknownSelector methodsFor: 'exception handling' stamp: 'HAW 7/1/2018 13:07:30'! - defaultAction - - | alternatives labels lines caption choice icons | - - alternatives := Symbol possibleSelectorsFor: name. - labels := Array streamContents: [:s | s nextPut: name; nextPutAll: alternatives; nextPut: 'cancel']. - lines := {1. alternatives size + 1}. - icons := Array new: labels size. - icons at: 1 put: #acceptIcon. - icons at: icons size put: #cancelIcon. - caption := 'Unknown selector, please\confirm, correct, or cancel' withNewLines. - - choice := (PopUpMenu labelArray: labels lines: lines icons: icons) startUpWithCaption: caption. - choice = 1 ifTrue: [self resume: name asSymbol]. - choice = labels size ifTrue: [self resume: nil]. - self resume: (alternatives at: choice - 1 ifAbsent: [ nil ]) - -! ! -!UnusedVariable methodsFor: 'exception handling' stamp: 'HAW 7/1/2018 12:14:01'! - defaultAction - - | shouldResume | - - shouldResume := PopUpMenu confirm: name, ' appears to be\unused in this method.\OK to remove it?' withNewLines. - self resume: shouldResume ! ! - -UnusedVariable removeSelector: #openMenuIn:! - -UnusedVariable removeSelector: #openMenuIn:! - -UnknownSelector removeSelector: #openMenuIn:! - -UnknownSelector removeSelector: #openMenuIn:! - -UndefinedVariable removeSelector: #openMenuIn:! - -UndefinedVariable removeSelector: #openMenuIn:! - -UndeclaredVariable removeSelector: #addAlternative:to:actions:icons:! - -UndeclaredVariable removeSelector: #openMenuIn:! - -UndeclaredVariable removeSelector: #openMenuIn:! - -ParserNotification removeSelector: #defaultAction! - -ParserNotification removeSelector: #defaultAction! - -ParserNotification removeSelector: #openMenuIn:! - -ParserNotification removeSelector: #openMenuIn:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3356-ParserNotification-Enhancements-HernanWilkinson-2018Jul01-12h05m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3356] on 4 July 2018 at 5:23:57 pm'! -!Complex class methodsFor: 'instance creation' stamp: 'jmv 7/4/2018 17:03:13'! - magnitude: rho phase: theta - ^ self abs: rho arg: theta! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3357-Complex-rho-phase-JuanVuletich-2018Jul04-16h36m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3348] on 2 July 2018 at 7:56:47 pm'! -!SystemDictionary methodsFor: 'browsing' stamp: 'HAW 7/2/2018 19:55:29' prior: 16924171! - browseMessageList: messageList name: labelString autoSelect: autoSelectString - | title aSize | - "Create and schedule a MessageSet browser on the message list." - - messageList size = 0 ifTrue: - [^ PopUpMenu inform: ('There are no\' , labelString) withNewLines ]. - - title _ (aSize _ messageList size) > 1 - ifFalse: [ labelString ] - ifTrue: [ '[', aSize printString, '] ', labelString]. - - MessageSetWindow - openMessageList: messageList - label: title - autoSelect: autoSelectString! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3358-inform-not-label-CuisCore-HernanWilkinson-2018Jul02-19h53m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3348] on 2 July 2018 at 8:04:58 pm'! -!SystemDictionary methodsFor: 'ui' stamp: 'HAW 7/2/2018 20:04:12' prior: 16923767! - confirmRemovalOf: aSelector on: aClass - "Determine if it is okay to remove the given selector. Answer 1 if it - should be removed, 2 if it should be removed followed by a senders - browse, and 3 if it should not be removed." - | count aMenu answer caption allCalls | - allCalls _ self allCallsOn: aSelector. - (count _ allCalls size) = 0 - ifTrue: [^ 1]. - "no senders -- let the removal happen without warning" - count = 1 - ifTrue: [(allCalls first actualClass == aClass - and: [allCalls first methodSymbol == aSelector]) - ifTrue: [^ 1]]. - "only sender is itself" - aMenu _ PopUpMenu labels: 'Remove it -Remove, then browse senders -Don''t remove, but show me those senders -Forget it -- do nothing -- sorry I asked' - icons: #(acceptIcon acceptIcon cancelIcon cancelIcon). - - caption _ 'This message has ' , count printString , ' sender'. - count > 1 - ifTrue: [caption _ caption copyWith: $s]. - answer _ aMenu startUpWithCaption: caption. - answer = 3 - ifTrue: [self - browseMessageList: allCalls - name: 'Senders of ' , aSelector - autoSelect: aSelector keywords first]. - answer = 0 - ifTrue: [answer _ 3]. - "If user didn't answer, treat it as cancel" - ^ answer min: 3! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3359-icon-on-method-removal-HernanWilkinson-2018Jul02-19h56m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3359] on 5 July 2018 at 4:03:31 pm'! -!Number methodsFor: 'accessing' stamp: 'jmv 7/5/2018 15:47:19'! - imaginary - "Compatibility with Complex numbers" - ^ 0! ! -!Number methodsFor: 'accessing' stamp: 'jmv 7/5/2018 15:47:55'! - real - "Compatibility with Complex numbers" - ^ self! ! -!Number methodsFor: 'accessing' stamp: 'jmv 7/5/2018 15:48:09' prior: 50402138! - argument - "Compatibility with Complex numbers. - Answer the argument of the receiver (see Complex | argument). - Answer is in (-Pi .. +Pi] - Note: Assume the convention of 0+0i having argument=0" - - ^self < 0 - ifFalse: [0] - ifTrue: [Float pi]! ! -!Number methodsFor: 'accessing' stamp: 'jmv 7/5/2018 15:48:20' prior: 16880163! - magnitude - "Compatibility with Complex numbers" - ^self abs! ! -!Number methodsFor: 'accessing' stamp: 'jmv 7/5/2018 15:48:29' prior: 50402147! - phase - "Compatibility with Complex numbers. - Answer the argument of the receiver. - Answer is in (-Pi .. +Pi] - Note: Assume the convention of 0+0i having argument=0" - - ^ self argument! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3360-Number-ComplexProtocol-JuanVuletich-2018Jul05-10h07m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3345] on 5 July 2018 at 2:59:23 pm'! -!CodePackage methodsFor: 'accessing' stamp: 'HAW 7/5/2018 14:59:10' prior: 16810690! - hasUnsavedChanges - - "Might be nil and breaks when a code package window is open and loading packages - Hernan - This is not a lazy initialization, the variable is set to non nil value only when certain." - ^hasUnsavedChanges = true! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3361-FixPossibleWalkbackInPackageLoading-HernanWilkinson-2018Jul05-14h59m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3348] on 5 July 2018 at 3:17:35 pm'! -!Collection methodsFor: 'enumerating' stamp: 'HAW 7/5/2018 14:49:22'! - groupBy: keyBlock - - ^ self - inject: Dictionary new - into: [ :groupedCollection :elementToGroup | | group | - group := groupedCollection at: (keyBlock value: elementToGroup) ifAbsentPut: [ OrderedCollection new ]. - group add: elementToGroup. - groupedCollection ] - ! ! -!Collection methodsFor: 'enumerating' stamp: 'HAW 7/5/2018 15:14:50' prior: 16814398! - groupBy: keyBlock having: selectBlock - "Like in SQL operation - Split the receivers contents into collections of - elements for which keyBlock returns the same results, and return those - collections allowed by selectBlock. " - - ^ (self groupBy: keyBlock) select: selectBlock! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3362-groupBy-HernanWilkinson-2018Jul02-20h04m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3348] on 5 July 2018 at 4:00:10 pm'! - -Object subclass: #DynamicMenuBuilder - instanceVariableNames: 'title defaultTarget menuOptionsSelector menu items groups ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #DynamicMenuBuilder category: #'Morphic-Menus'! -Object subclass: #DynamicMenuBuilder - instanceVariableNames: 'title defaultTarget menuOptionsSelector menu items groups' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! -!DynamicMenuBuilder methodsFor: 'initialization' stamp: 'HAW 7/5/2018 15:42:29'! - initializeTitled: aTitle targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector - - title := aTitle. - defaultTarget := aDefaultTarget. - menuOptionsSelector := aMenuOptionsSelector ! ! -!DynamicMenuBuilder methodsFor: 'building - private' stamp: 'HAW 7/5/2018 15:59:10'! - addGroupSeparation - - menu addLine - ! ! -!DynamicMenuBuilder methodsFor: 'building - private' stamp: 'HAW 7/5/2018 15:56:23'! - addGroupedMenuOptionsToMenu - - groups := items groupBy: [ :item | item at: #itemGroup ]. - groups keys asSortedCollection - do: [ :group | self addMenuOptionsOfGroup: group ] - separatedBy: [ self addGroupSeparation ]. -! ! -!DynamicMenuBuilder methodsFor: 'building - private' stamp: 'HAW 7/5/2018 15:55:59'! - addMenuOptionsOfGroup: group - - | groupMenuOptions | - - groupMenuOptions := (groups at: group) asSortedCollection: [ :leftItem :rightItem | (leftItem at: #itemOrder) < (rightItem at: #itemOrder) ]. - menu addItemsFromDictionaries: groupMenuOptions.! ! -!DynamicMenuBuilder methodsFor: 'building - private' stamp: 'HAW 7/5/2018 15:53:08'! - collectMenuOptions - - items := (Smalltalk allClassesImplementing: menuOptionsSelector) - collect: [ :item | item isMeta ifTrue: [ item soleInstance perform: menuOptionsSelector ] ] - thenSelect: [ :item | item notNil ].! ! -!DynamicMenuBuilder class methodsFor: 'instance creation' stamp: 'HAW 7/5/2018 15:41:58'! - titled: aTitle targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector - - ^self new initializeTitled: aTitle targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector - -! ! -!DynamicMenuBuilder methodsFor: 'building' stamp: 'HAW 7/5/2018 15:57:34'! - build - - self - createMenu; - collectMenuOptions; - addGroupedMenuOptionsToMenu. - - ^ menu.! ! -!DynamicMenuBuilder methodsFor: 'building - private' stamp: 'HAW 7/5/2018 15:52:31'! - createMenu - - menu := MenuMorph entitled: title. - menu - defaultTarget: defaultTarget; - addStayUpIcons! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'HAW 7/5/2018 15:47:16' prior: 50397006! - openMenu - "Build the open window menu for the world." - - ^(DynamicMenuBuilder titled: 'Open...' targeting: self collectingMenuOptionsWith: #worldMenuForOpenGroup) build - - ! ! - -Object subclass: #DynamicMenuBuilder - instanceVariableNames: 'title defaultTarget menuOptionsSelector menu items groups' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #DynamicMenuBuilder category: #'Morphic-Menus'! -Object subclass: #DynamicMenuBuilder - instanceVariableNames: 'title defaultTarget menuOptionsSelector menu items groups' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3363-DynamicMenuBuilder-HernanWilkinson-2018Jul05-15h17m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3348] on 5 July 2018 at 6:42:58 pm'! -!DynamicMenuBuilder methodsFor: 'testing' stamp: 'HAW 7/5/2018 18:26:14'! - hasTitle - - ^title ~= self class noTitle ! ! -!DynamicMenuBuilder methodsFor: 'building - private' stamp: 'HAW 7/5/2018 18:41:03'! - classesProvidingMenuOptions - - ^(Smalltalk allClassesImplementing: menuOptionsSelector) select: [ :aClass | aClass isMeta ]! ! -!DynamicMenuBuilder class methodsFor: 'instance creation' stamp: 'HAW 7/5/2018 18:25:03'! - targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector - - ^self titled: self noTitle targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector - -! ! -!DynamicMenuBuilder class methodsFor: 'defaults' stamp: 'HAW 7/5/2018 18:25:09'! - noTitle - - ^nil! ! -!DynamicMenuBuilder class methodsFor: 'building' stamp: 'HAW 7/5/2018 18:27:20'! - buildTargeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector - - ^(self targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector) build! ! -!DynamicMenuBuilder class methodsFor: 'building' stamp: 'HAW 7/5/2018 18:27:45'! - buildTitled: aTitle targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector - - ^(self titled: aTitle targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector) build! ! -!TheWorldMenu class methodsFor: 'menu building' stamp: 'HAW 7/5/2018 18:37:46'! - worldMenuOptions - - ^`{{ - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Open...'. - #selector -> #openOpenMenu. - #icon -> #openIcon. - #balloonText -> 'Submenu to open various system tools'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'New morph...'. - #selector -> #newMorph. - #icon -> #morphsIcon. - #balloonText -> 'Offers a variety of ways to create new objects'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Preferences...'. - #selector -> #openPreferencesMenu. - #icon -> #preferencesIcon. - #balloonText -> 'Opens a menu offering many controls over appearance and system preferences.'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'Windows...'. - #selector -> #openWindowsMenu. - #icon -> #windowIcon. - #balloonText -> 'Manage open windows'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 50. - #label -> 'Help...'. - #selector -> #openHelpMenu. - #icon -> #helpIcon. - #balloonText -> 'Opens a menu of useful items for updating the system, determining what version you are running, and much else'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Changes...'. - #selector -> #openChangesMenu. - #icon -> #changesIcon. - #balloonText -> 'Opens a menu of useful tools for dealing with changes'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Debug...'. - #selector -> #openDebugMenu. - #icon -> #debugIcon. - #balloonText -> 'a menu of debugging items'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'Restore Display (r)'. - #object -> #myWorld. - #selector -> #restoreDisplay. - #icon -> #displayIcon. - #balloonText -> 'Repaint the screen -- useful for removing unwanted display artifacts, lingering cursors, etc.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Save'. - #object -> Smalltalk. - #selector -> #saveSession. - #icon -> #saveIcon. - #balloonText -> 'Save the current version of the image on disk'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Save as...'. - #object -> Smalltalk. - #selector -> #saveAs. - #icon -> #saveAsIcon. - #balloonText -> 'Save the current version of the image on disk under a new name.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'Save as New Version'. - #object -> Smalltalk. - #selector -> #saveAsNewVersion. - #icon -> #saveAsNewVersionIcon. - #balloonText -> ('Save the current image a new version-stamped name\and save it under that name on disk.\', - 'Clear all user preferences and user state (class vars).') withNewLines. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 40. - #label -> 'Save and Quit'. - #selector -> #saveAndQuit. - #icon -> #saveAndQuitIcon. - #balloonText -> 'Save the image and quit out of Cuis.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 50. - #label -> 'Quit'. - #selector -> #quitSession. - #icon -> #quitIcon. - #balloonText -> 'Quit out of Cuis.'. - } asDictionary. -}`! ! -!Workspace class methodsFor: 'menu-world' stamp: 'HAW 7/5/2018 18:03:00' prior: 50393671! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'Workspace'. - #object -> Workspace. - #selector -> #openWorkspace. - #icon -> #terminalIcon. - #balloonText -> 'A window for evaluating Smalltalk expressions'. - } asDictionary}`! ! -!Transcripter class methodsFor: 'menu-world' stamp: 'HAW 7/5/2018 18:02:53' prior: 50393684! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Emergency Evaluator'. - #object -> Transcripter. - #selector -> #emergencyEvaluator. - #icon -> #emblemImportantIcon. - #balloonText -> 'When all else fails...'. - } asDictionary}`! ! -!TextEditor class methodsFor: 'menu-world' stamp: 'HAW 7/5/2018 18:02:41' prior: 50393697! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Text Editor'. - #object -> TextEditor. - #selector -> #openTextEditor. - #icon -> #textEditorIcon. - #balloonText -> 'A window for composing text'. - } asDictionary}`! ! -!CodePackageListWindow class methodsFor: 'menu-world' stamp: 'HAW 7/5/2018 18:01:57' prior: 50393710! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Installed Packages'. - #object -> CodePackageListWindow. - #selector -> #openPackageList. - #icon -> #packageIcon. - #balloonText -> 'A tool for managing Packages (optional units of code) installed in the system'. - } asDictionary}`! ! -!BrowserWindow class methodsFor: 'menu-world' stamp: 'HAW 7/5/2018 18:01:26' prior: 50393724! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Browser'. - #object -> BrowserWindow. - #selector -> #openBrowser. - #icon -> #editFindReplaceIcon. - #balloonText -> 'A Smalltalk code browser, for studying and modifying the system'. - } asDictionary}`! ! -!MessageNamesWindow class methodsFor: 'menu-world' stamp: 'HAW 7/5/2018 18:02:18' prior: 50393738! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'Message Names'. - #object -> MessageNamesWindow. - #selector -> #openMessageNames. - #icon -> #inspectIcon. - #balloonText -> 'A tool for finding and editing methods that contain any given keyword in their names.'. - } asDictionary}`! ! -!ChangeSorterWindow class methodsFor: 'menu-world' stamp: 'HAW 7/5/2018 18:01:49' prior: 50393753! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Change Sorter'. - #object -> ChangeSorterWindow. - #selector -> #openChangeSorter. - #icon -> #halfRefreshIcon. - #balloonText -> 'A tool allowing you to view the methods in a Change Set, especially changes to the Base System'. - } asDictionary}`! ! -!FileListWindow class methodsFor: 'menu-world' stamp: 'HAW 7/5/2018 18:02:10' prior: 50393768! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'File List'. - #object -> FileListWindow. - #selector -> #openFileList. - #icon -> #systemFileManagerIcon. - #balloonText -> 'An explorer of the File System'. - } asDictionary}`! ! -!ProcessBrowserWindow class methodsFor: 'menu-world' stamp: 'HAW 7/5/2018 18:02:24' prior: 50393781! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Process Browser'. - #object -> ProcessBrowserWindow. - #selector -> #openProcessBrowser. - #icon -> #systemMonitorIcon. - #balloonText -> 'A tool to monitor and manage Smalltalk processes'. - } asDictionary}`! ! -!TestRunnerWindow class methodsFor: 'menu-world' stamp: 'HAW 7/5/2018 18:02:30' prior: 50393795! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'SUnit Test Runner'. - #object -> TestRunnerWindow. - #selector -> #openTestRunner. - #icon -> #weatherFewCloudsIcon. - #balloonText -> 'Smalltalk''s testing framework'. - } asDictionary}`! ! -!TranscriptWindow class methodsFor: 'menu-world' stamp: 'HAW 7/5/2018 18:02:47' prior: 50393808! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 10. - #itemOrder -> 50. - #label -> 'Transcript'. - #object -> TranscriptWindow. - #selector -> #openTranscript. - #icon -> #printerIcon. - #balloonText -> 'A window showing contents of the System Transcript'. - } asDictionary}`! ! -!DynamicMenuBuilder methodsFor: 'building - private' stamp: 'HAW 7/5/2018 18:41:32' prior: 50402614! - collectMenuOptions - - items := OrderedCollection new. - self classesProvidingMenuOptions do: [ :aClass | items addAll: (aClass soleInstance perform: menuOptionsSelector) ]. - ! ! -!DynamicMenuBuilder methodsFor: 'building - private' stamp: 'HAW 7/5/2018 18:25:48' prior: 50402639! - createMenu - - menu := self hasTitle ifTrue: [ MenuMorph entitled: title] ifFalse: [ MenuMorph new ]. - menu - defaultTarget: defaultTarget; - addStayUpIcons! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'HAW 7/5/2018 18:28:15' prior: 50396737! - buildWorldMenu - "Build the menu that is put up when the screen-desktop is clicked on" - - ^DynamicMenuBuilder buildTargeting: self collectingMenuOptionsWith: #worldMenuOptions - ! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'HAW 7/5/2018 18:28:15' prior: 50402646! - openMenu - "Build the open window menu for the world." - - ^DynamicMenuBuilder buildTitled: 'Open...' targeting: self collectingMenuOptionsWith: #worldMenuForOpenGroup - ! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3364-WorldMenuCustomization-HernanWilkinson-2018Jul05-16h00m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3358] on 7 July 2018 at 7:15:34 pm'! - -Object subclass: #DynamicMenuBuilder - instanceVariableNames: 'title defaultTarget menuOptionsSelector menu items groups optionsChanger ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #DynamicMenuBuilder category: #'Morphic-Menus'! -Object subclass: #DynamicMenuBuilder - instanceVariableNames: 'title defaultTarget menuOptionsSelector menu items groups optionsChanger' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 7/6/2018 12:21:10'! - classListMenu2Options - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'unsent methods'. - #selector -> #browseUnusedMethods. - #icon -> #junkIcon. - #balloonText -> 'browse all methods defined by this class that have no senders' - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'unreferenced inst vars'. - #selector -> #showUnreferencedInstVars. - #icon -> #junkIcon. - #balloonText -> 'show a list of all instance variables that are not referenced in methods' - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'unreferenced class vars'. - #selector -> #showUnreferencedClassVars. - #icon -> #junkIcon. - #balloonText -> 'show a list of all class variables that are not referenced in methods' - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'subclass template'. - #object -> #model. - #selector -> #makeNewSubclass. - #icon -> #classIcon. - #balloonText -> 'put a template into the code pane for defining of a subclass of this class' - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'sample instance'. - #selector -> #makeSampleInstance. - #icon -> #instanceIcon. - #balloonText -> 'give me a sample instance of this class, if possible' - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'inspect instances'. - #selector -> #inspectInstances. - #icon -> #inspectIcon. - #balloonText -> 'open an inspector on all the extant instances of this class' - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'inspect subinstances'. - #selector -> #inspectSubInstances. - #icon -> #inspectIcon. - #balloonText -> 'open an inspector on all the extant instances of this class and of all of its subclasses' - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'create inst var accessors'. - #object -> #model. - #selector -> #createInstVarAccessors. - #icon -> #sendReceiveIcon. - #balloonText -> 'compile instance-variable access methods for any instance variables that do not yet have them' - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'more...'. - #selector -> #offerClassListMenu. - #icon -> #listAddIcon. - #balloonText -> 'return to the standard class-list menu' - } asDictionary. - }`! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 7/6/2018 11:58:54'! - classListMenuOptions - - ^ `{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutClass. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'show hierarchy'. - #object -> #model. - #selector -> #hierarchy. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'show definition'. - #object -> #model. - #selector -> #editClass. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'show comment'. - #object -> #model. - #selector -> #editComment. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'inst var refs...'. - #selector -> #browseInstVarRefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'inst var defs...'. - #selector -> #browseInstVarDefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'class var refs...'. - #selector -> #browseClassVarRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 20. - #label -> 'class vars'. - #selector -> #browseClassVariables. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'class refs (N)'. - #selector -> #browseClassRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'rename class ...'. - #object -> #model. - #selector -> #renameClass. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 20. - #label -> 'copy class...'. - #object -> #model. - #selector -> #copyClass. - #icon -> #copyIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 30. - #label -> 'remove class (x)'. - #object -> #model. - #selector -> #removeClass. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 10. - #label -> 'run tests (t)'. - #object -> #model. - #selector -> #runClassTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 20. - #label -> 'more...'. - #selector -> #offerClassListMenu2. - #icon -> #listAddIcon - } asDictionary. - }`. - ! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 7/6/2018 12:24:58'! - messageCategoryMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'fileOut (o)'. - #object -> #model. - #selector -> #fileOutMessageCategories. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'reorganize'. - #object -> #model. - #selector -> #editMessageCategories. - #icon -> #sendReceiveIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'alphabetize'. - #object -> #model. - #selector -> #alphabetizeMessageCategories. - #icon -> #fontXGenericIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'remove empty categories'. - #object -> #model. - #selector -> #removeEmptyCategories. - #icon -> #listRemoveIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 40. - #label -> 'categorize all uncategorized'. - #object -> #model. - #selector -> #categorizeAllUncategorizedMethods. - #icon -> #packageIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 50. - #label -> 'new category...'. - #object -> #model. - #selector -> #addCategory. - #icon -> #newIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'rename...'. - #object -> #model. - #selector -> #renameCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'remove (x)'. - #object -> #model. - #selector -> #removeMessageCategory. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'run tests (t)'. - #object -> #model. - #selector -> #runMessageCategoryTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - }`. - ! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 7/7/2018 18:22:02'! - messageListMenu2Options - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'toggle diffing (D)'. - #object -> #model. - #selector -> #toggleDiffing. - #icon -> #switchIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'implementors of sent messages'. - #selector -> #browseAllMessages. - #icon -> #developmentIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'local senders of...'. - #selector -> #browseLocalSendersOfMessages. - #icon -> #mailForwardIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'local implementors of...'. - #selector -> #browseLocalImplementors. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'spawn sub-protocol'. - #selector -> #browseProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'spawn full protocol'. - #selector -> #browseFullProtocol. - #icon -> #speadsheetTemplateIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'sample instance'. - #selector -> #makeSampleInstance. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'inspect instances'. - #selector -> #inspectInstances. - #icon -> #inspectIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'inspect subinstances'. - #selector -> #inspectSubInstances. - #icon -> #inspectIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 40. - #label -> 'change category...'. - #object -> #model. - #selector -> #changeCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 50. - #label -> 'change sets with this method'. - #selector -> #findMethodInChangeSets. - #icon -> #changesIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 60. - #label -> 'revert to previous version'. - #object -> #model. - #selector -> #revertToPreviousVersion. - #icon -> #undoIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'more...'. - #selector -> #openMessageListMenu. - #icon -> #listAddIcon - } asDictionary. - }`! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 7/7/2018 19:10:48'! - messageListMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'what to show...'. - #selector -> #offerWhatToShowMenu. - #icon -> #preferencesIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'toggle break on entry'. - #object -> #model. - #selector -> #toggleBreakOnEntry. - #icon -> #debugIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'browse method (O)'. - #selector -> #openSingleMessageBrowser. - #icon -> #scriptIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 40. - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutMessage. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'explore CompiledMethod'. - #object -> #model. - #selector -> #exploreCompiledMethod. - #icon -> #exploreIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'senders of... (n)'. - #selector -> #browseSendersOfMessages. - #icon -> #mailForwardIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'implementors of... (m)'. - #selector -> #browseMessages. - #icon -> #developmentIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'inheritance (i)'. - #selector -> #methodHierarchy. - #icon -> #goDownIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 40. - #label -> 'versions (v)'. - #selector -> #browseVersions. - #icon -> #clockIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'inst var refs...'. - #selector -> #browseInstVarRefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 20. - #label -> 'inst var defs...'. - #selector -> #browseInstVarDefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'class var refs...'. - #selector -> #browseClassVarRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 40. - #label -> 'class variables'. - #selector -> #browseClassVariables. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 50. - #label -> 'class refs (N)'. - #selector -> #browseClassRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'remove method (x)'. - #object -> #model. - #selector -> #removeMessage. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 20. - #label -> 'run test (t)'. - #object -> #model. - #selector -> #runMethodTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 30. - #label -> 'debug test (r)'. - #object -> #model. - #selector -> #debugMethodTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 10. - #label -> 'more...'. - #selector -> #openMessageListMenu2. - #icon -> #listAddIcon - } asDictionary. - }`. - ! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 7/7/2018 19:04:27'! - systemCatSingletonMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'find class... (f)'. - #selector -> #findClass. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'browse all'. - #selector -> #browseAllClasses. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'browse'. - #selector -> #openSystemCategoryBrowser. - #icon -> #packageIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutSystemCategory. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'update'. - #object -> #model. - #selector -> #updateSystemCategories. - #icon -> #updateIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'rename...'. - #object -> #model. - #selector -> #renameSystemCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'remove'. - #object -> #model. - #selector -> #removeSystemCategory. - #icon -> #deleteIcon - } asDictionary. - }`. - ! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 7/7/2018 19:02:29'! - systemCategoryMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'find class... (f)'. - #selector -> #findClass. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'recent classes... (r)'. - #object -> #model. - #selector -> #recent. - #icon -> #clockIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'browse all'. - #selector -> #browseAllClasses. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'browse'. - #selector -> #openSystemCategoryBrowser. - #icon -> #packageIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutSystemCategory. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'reorganize'. - #object -> #model. - #selector -> #editSystemCategories. - #icon -> #sendReceiveIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'alphabetize'. - #object -> #model. - #selector -> #alphabetizeSystemCategories. - #icon -> #fontXGenericIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'update'. - #object -> #model. - #selector -> #updateSystemCategories. - #icon -> #updateIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 20. - #label -> 'add item...'. - #object -> #model. - #selector -> #addSystemCategory. - #icon -> #newIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'rename...'. - #object -> #model. - #selector -> #renameSystemCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 40. - #label -> 'remove'. - #object -> #model. - #selector -> #removeSystemCategory. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'move to top'. - #object -> #model. - #selector -> #moveSystemCategoryTop. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 20. - #label -> 'move up'. - #object -> #model. - #selector -> #moveSystemCategoryUp. - #icon -> #goUpIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 30. - #label -> 'move down'. - #object -> #model. - #selector -> #moveSystemCategoryDown. - #icon -> #goDownIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 40. - #label -> 'move to bottom'. - #object -> #model. - #selector -> #moveSystemCategoryBottom. - #icon -> #goBottomIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 10. - #label -> 'run tests (t)'. - #object -> #model. - #selector -> #runSystemCategoryTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - }`. - ! ! -!DynamicMenuBuilder methodsFor: 'initialization' stamp: 'HAW 7/7/2018 18:43:12'! - initializeTitled: aTitle targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector changingThemWith: anOptionsChangerBlock - - title := aTitle. - defaultTarget := aDefaultTarget. - menuOptionsSelector := aMenuOptionsSelector. - optionsChanger := anOptionsChangerBlock ! ! -!DynamicMenuBuilder methodsFor: 'testing' stamp: 'HAW 7/5/2018 18:26:14' prior: 50402676! - hasTitle - - ^title ~= self class noTitle ! ! -!DynamicMenuBuilder methodsFor: 'building - private' stamp: 'HAW 7/7/2018 18:40:31'! - changeOptions - - optionsChanger value: items! ! -!DynamicMenuBuilder methodsFor: 'building - private' stamp: 'HAW 7/5/2018 18:41:03' prior: 50402681! - classesProvidingMenuOptions - - ^(Smalltalk allClassesImplementing: menuOptionsSelector) select: [ :aClass | aClass isMeta ]! ! -!DynamicMenuBuilder class methodsFor: 'instance creation' stamp: 'HAW 7/5/2018 18:25:03' prior: 50402688! - targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector - - ^self titled: self noTitle targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector - -! ! -!DynamicMenuBuilder class methodsFor: 'instance creation' stamp: 'HAW 7/7/2018 18:42:10'! - titled: aTitle targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector changingThemWith: anOptionsChangerBlock - - ^self new initializeTitled: aTitle targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector changingThemWith: anOptionsChangerBlock - -! ! -!DynamicMenuBuilder class methodsFor: 'defaults' stamp: 'HAW 7/5/2018 18:25:09' prior: 50402697! - noTitle - - ^nil! ! -!DynamicMenuBuilder class methodsFor: 'building' stamp: 'HAW 7/5/2018 18:27:20' prior: 50402701! - buildTargeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector - - ^(self targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector) build! ! -!DynamicMenuBuilder class methodsFor: 'building' stamp: 'HAW 7/5/2018 18:27:45' prior: 50402709! - buildTitled: aTitle targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector - - ^(self titled: aTitle targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector) build! ! -!DynamicMenuBuilder class methodsFor: 'building' stamp: 'HAW 7/7/2018 18:42:56'! - buildTitled: aTitle targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector changingThemWith: anOptionsChangerBlock - - ^(self titled: aTitle targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector changingThemWith: anOptionsChangerBlock) build! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'HAW 7/6/2018 12:14:46' prior: 50402994! - buildWorldMenu - "Build the menu that is put up when the screen-desktop is clicked on" - - ^(DynamicMenuBuilder buildTargeting: self collectingMenuOptionsWith: #worldMenuOptions) - addStayUpIcons; - yourself - - ! ! -!TheWorldMenu class methodsFor: 'menu building' stamp: 'HAW 7/5/2018 18:37:46' prior: 50402718! - worldMenuOptions - - ^`{{ - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Open...'. - #selector -> #openOpenMenu. - #icon -> #openIcon. - #balloonText -> 'Submenu to open various system tools'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'New morph...'. - #selector -> #newMorph. - #icon -> #morphsIcon. - #balloonText -> 'Offers a variety of ways to create new objects'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Preferences...'. - #selector -> #openPreferencesMenu. - #icon -> #preferencesIcon. - #balloonText -> 'Opens a menu offering many controls over appearance and system preferences.'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'Windows...'. - #selector -> #openWindowsMenu. - #icon -> #windowIcon. - #balloonText -> 'Manage open windows'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 50. - #label -> 'Help...'. - #selector -> #openHelpMenu. - #icon -> #helpIcon. - #balloonText -> 'Opens a menu of useful items for updating the system, determining what version you are running, and much else'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Changes...'. - #selector -> #openChangesMenu. - #icon -> #changesIcon. - #balloonText -> 'Opens a menu of useful tools for dealing with changes'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Debug...'. - #selector -> #openDebugMenu. - #icon -> #debugIcon. - #balloonText -> 'a menu of debugging items'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'Restore Display (r)'. - #object -> #myWorld. - #selector -> #restoreDisplay. - #icon -> #displayIcon. - #balloonText -> 'Repaint the screen -- useful for removing unwanted display artifacts, lingering cursors, etc.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Save'. - #object -> Smalltalk. - #selector -> #saveSession. - #icon -> #saveIcon. - #balloonText -> 'Save the current version of the image on disk'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Save as...'. - #object -> Smalltalk. - #selector -> #saveAs. - #icon -> #saveAsIcon. - #balloonText -> 'Save the current version of the image on disk under a new name.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'Save as New Version'. - #object -> Smalltalk. - #selector -> #saveAsNewVersion. - #icon -> #saveAsNewVersionIcon. - #balloonText -> ('Save the current image a new version-stamped name\and save it under that name on disk.\', - 'Clear all user preferences and user state (class vars).') withNewLines. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 40. - #label -> 'Save and Quit'. - #selector -> #saveAndQuit. - #icon -> #saveAndQuitIcon. - #balloonText -> 'Save the image and quit out of Cuis.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 50. - #label -> 'Quit'. - #selector -> #quitSession. - #icon -> #quitIcon. - #balloonText -> 'Quit out of Cuis.'. - } asDictionary. -}`! ! -!Workspace class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:15:27' prior: 50402827! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'Workspace'. - #object -> Workspace. - #selector -> #openWorkspace. - #icon -> #terminalIcon. - #balloonText -> 'A window for evaluating Smalltalk expressions'. - } asDictionary}`! ! -!Transcripter class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:15:19' prior: 50402840! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Emergency Evaluator'. - #object -> Transcripter. - #selector -> #emergencyEvaluator. - #icon -> #emblemImportantIcon. - #balloonText -> 'When all else fails...'. - } asDictionary}`! ! -!TextEditor class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:14:50' prior: 50402853! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Text Editor'. - #object -> TextEditor. - #selector -> #openTextEditor. - #icon -> #textEditorIcon. - #balloonText -> 'A window for composing text'. - } asDictionary}`! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'HAW 7/5/2018 18:24:37' prior: 16887708! - invokeWorldMenu - "Put up the world menu, triggered by the passed-in event. - Perhaps a good place to disable it if needed" - - | menu | - menu _ (TheWorldMenu new - world: self - hand: self activeHand) buildWorldMenu. - menu addTitle: Preferences desktopMenuTitle. - menu popUpInWorld: self! ! -!CodePackageListWindow class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:13:05' prior: 50402866! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Installed Packages'. - #object -> CodePackageListWindow. - #selector -> #openPackageList. - #icon -> #packageIcon. - #balloonText -> 'A tool for managing Packages (optional units of code) installed in the system'. - } asDictionary}`! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'HAW 7/7/2018 18:32:00' prior: 50396104! - addExtraMenu2ItemsTo: optoins - "The shifted selector-list menu is being built; some menu items are appropriate only for certain kinds of browsers, and this gives a hook for them to be added as approrpiate. If any is added here, a line should be added first -- browse reimplementors of this message for examples."! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'HAW 7/6/2018 11:59:53' prior: 50398230! - classListMenu - "Set up the menu to apply to the receiver's class list, honoring the #shifted boolean" - - ^DynamicMenuBuilder buildTitled: 'Class List' targeting: self collectingMenuOptionsWith: #classListMenuOptions.! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'HAW 7/6/2018 12:18:34' prior: 50398319! - classListMenu2 - "Set up the menu to apply to the receiver's class list when the shift key is down" - - ^DynamicMenuBuilder buildTargeting: self collectingMenuOptionsWith: #classListMenu2Options. - ! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'HAW 7/6/2018 12:22:51' prior: 50401425! - messageCategoryMenu - - ^DynamicMenuBuilder buildTitled: 'Message Category' targeting: self collectingMenuOptionsWith: #messageCategoryMenuOptions. -! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'HAW 7/7/2018 19:09:07' prior: 50398447! - messageListMenu - "Answer the message-list menu" - "Changed by emm to include menu-item for breakpoints" - - ^DynamicMenuBuilder buildTitled: 'Message List' targeting: self collectingMenuOptionsWith: #messageListMenuOptions. - ! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'HAW 7/7/2018 18:45:13' prior: 50398555! - messageListMenu2 - "Fill aMenu with the items appropriate when the shift key is held down" - - ^DynamicMenuBuilder - buildTitled: 'Message List' - targeting: self - collectingMenuOptionsWith: #messageListMenu2Options - changingThemWith: [ :options | - self addExtraMenu2ItemsTo: options. - model canShowMultipleMessageCategories ifTrue: [ - options add: `{ - #itemGroup -> 40. - #itemOrder -> 45. - #label -> 'show category (C)'. - #object -> #model. - #selector -> #showHomeCategory. - #icon -> #packageIcon - } asDictionary` ]]. - - ! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'HAW 7/7/2018 18:57:48' prior: 50398841! - systemCatSingletonMenu - - ^DynamicMenuBuilder buildTitled: 'Class category' targeting: self collectingMenuOptionsWith: #systemCatSingletonMenuOptions. -! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'HAW 7/7/2018 19:03:15' prior: 50398884! - systemCategoryMenu - - ^DynamicMenuBuilder buildTitled: 'Class category' targeting: self collectingMenuOptionsWith: #systemCategoryMenuOptions.! ! -!BrowserWindow class methodsFor: 'menu-world' stamp: 'HAW 7/6/2018 11:53:52' prior: 50402880! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Browser'. - #object -> BrowserWindow. - #selector -> #openBrowser. - #icon -> #editFindReplaceIcon. - #balloonText -> 'A Smalltalk code browser, for studying and modifying the system'. - } asDictionary}`! ! -!MessageSetWindow methodsFor: 'menu building' stamp: 'HAW 7/7/2018 18:31:51' prior: 50398757! - addExtraMenu2ItemsTo: options - "The shifted selector-list menu is being built. Add items specific to MessageSet" - - model growable ifTrue: [ - options add: `{ - #itemGroup -> 40. - #itemOrder -> 31. - #label -> 'remove from this browser'. - #object -> #model. - #selector -> #removeMessageFromBrowser. - #icon -> #listRemoveIcon - } asDictionary`. - options add:`{ - #itemGroup -> 40. - #itemOrder -> 32. - #label -> 'filter message list...'. - #selector -> #filterMessageList. - #icon -> #findIcon - } asDictionary` ]. - - options add: `{ - #itemGroup -> 40. - #itemOrder -> 33. - #label -> 'sort by date'. - #object -> #model. - #selector -> #sortByDate. - #icon -> #dateIcon - } asDictionary`. - -! ! -!MessageNamesWindow class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:13:59' prior: 50402894! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'Message Names'. - #object -> MessageNamesWindow. - #selector -> #openMessageNames. - #icon -> #inspectIcon. - #balloonText -> 'A tool for finding and editing methods that contain any given keyword in their names.'. - } asDictionary}`! ! -!ChangeSorterWindow class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:12:50' prior: 50402909! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Change Sorter'. - #object -> ChangeSorterWindow. - #selector -> #openChangeSorter. - #icon -> #halfRefreshIcon. - #balloonText -> 'A tool allowing you to view the methods in a Change Set, especially changes to the Base System'. - } asDictionary}`! ! -!FileListWindow class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:13:27' prior: 50402924! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'File List'. - #object -> FileListWindow. - #selector -> #openFileList. - #icon -> #systemFileManagerIcon. - #balloonText -> 'An explorer of the File System'. - } asDictionary}`! ! -!ProcessBrowserWindow class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:14:22' prior: 50402937! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Process Browser'. - #object -> ProcessBrowserWindow. - #selector -> #openProcessBrowser. - #icon -> #systemMonitorIcon. - #balloonText -> 'A tool to monitor and manage Smalltalk processes'. - } asDictionary}`! ! -!TestRunnerWindow class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:14:27' prior: 50402951! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'SUnit Test Runner'. - #object -> TestRunnerWindow. - #selector -> #openTestRunner. - #icon -> #weatherFewCloudsIcon. - #balloonText -> 'Smalltalk''s testing framework'. - } asDictionary}`! ! -!TranscriptWindow class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:15:13' prior: 50402964! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 10. - #itemOrder -> 50. - #label -> 'Transcript'. - #object -> TranscriptWindow. - #selector -> #openTranscript. - #icon -> #printerIcon. - #balloonText -> 'A window showing contents of the System Transcript'. - } asDictionary}`! ! -!DynamicMenuBuilder methodsFor: 'building' stamp: 'HAW 7/7/2018 18:40:16' prior: 50402633! - build - - self - createMenu; - collectMenuOptions; - changeOptions; - addGroupedMenuOptionsToMenu. - - ^ menu.! ! -!DynamicMenuBuilder methodsFor: 'building - private' stamp: 'HAW 7/5/2018 18:41:32' prior: 50402977! - collectMenuOptions - - items := OrderedCollection new. - self classesProvidingMenuOptions do: [ :aClass | items addAll: (aClass soleInstance perform: menuOptionsSelector) ]. - ! ! -!DynamicMenuBuilder methodsFor: 'building - private' stamp: 'HAW 7/6/2018 12:15:07' prior: 50402986! - createMenu - - menu := self hasTitle ifTrue: [ MenuMorph entitled: title] ifFalse: [ MenuMorph new ]. - menu defaultTarget: defaultTarget! ! -!DynamicMenuBuilder class methodsFor: 'instance creation' stamp: 'HAW 7/7/2018 18:41:32' prior: 50402624! - titled: aTitle targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector - - ^self titled: aTitle targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector changingThemWith: [ :options | ]! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'HAW 7/6/2018 12:14:08' prior: 50403003! - openMenu - "Build the open window menu for the world." - - ^(DynamicMenuBuilder buildTitled: 'Open...' targeting: self collectingMenuOptionsWith: #worldMenuForOpenGroup) - addStayUpIcons; - yourself - ! ! - -DynamicMenuBuilder class removeSelector: #buildTitled:targeting:collectingMenuOptionsWith:adding:! - -DynamicMenuBuilder class removeSelector: #buildTitled:targeting:collectingMenuOptionsWith:changingOptionsWith:! - -DynamicMenuBuilder class removeSelector: #titled:targeting:collectingMenuOptionsWith:adding:! - -DynamicMenuBuilder class removeSelector: #titled:targeting:collectingMenuOptionsWith:changingOptionsWith:! - -DynamicMenuBuilder removeSelector: #addOptionalOptions! - -DynamicMenuBuilder removeSelector: #initializeTitled:targeting:collectingMenuOptionsWith:! - -DynamicMenuBuilder removeSelector: #initializeTitled:targeting:collectingMenuOptionsWith:! - -DynamicMenuBuilder removeSelector: #initializeTitled:targeting:collectingMenuOptionsWith:adding:! - -DynamicMenuBuilder removeSelector: #initializeTitled:targeting:collectingMenuOptionsWith:changingOptionsWith:! - -Object subclass: #DynamicMenuBuilder - instanceVariableNames: 'title defaultTarget menuOptionsSelector menu items groups optionsChanger' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #DynamicMenuBuilder category: #'Morphic-Menus'! -Object subclass: #DynamicMenuBuilder - instanceVariableNames: 'title defaultTarget menuOptionsSelector menu items groups optionsChanger' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3365-DynamicMenusInBrowser-HernanWilkinson-2018Jul05-16h00m-HAW.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3365] on 9 July 2018 at 4:41:43 pm'! -!False methodsFor: 'controlling' stamp: 'HAW 7/8/2018 20:12:50'! - and: aBlock1 and: aBlock2 - - ^self! ! -!False methodsFor: 'controlling' stamp: 'HAW 7/8/2018 20:13:01'! - and: aBlock1 and: aBlock2 and: aBlock3 - - ^self! ! -!False methodsFor: 'controlling' stamp: 'HAW 7/8/2018 20:13:06'! - and: aBlock1 and: aBlock2 and: aBlock3 and: aBlock4 - - ^self! ! -!False methodsFor: 'controlling' stamp: 'jmv 7/9/2018 16:37:10'! -or: aBlock1 or: aBlock2 - - ^aBlock1 value or: aBlock2! ! -!False methodsFor: 'controlling' stamp: 'jmv 7/9/2018 16:39:33'! - or: aBlock1 or: aBlock2 or: aBlock3 - - ^aBlock1 value or: aBlock2 or: aBlock3! ! -!False methodsFor: 'controlling' stamp: 'jmv 7/9/2018 16:39:40'! - or: aBlock1 or: aBlock2 or: aBlock3 or: aBlock4 - - ^aBlock1 value or: aBlock2 or: aBlock3 or: aBlock4! ! -!True methodsFor: 'controlling' stamp: 'jmv 7/9/2018 16:38:32'! - and: aBlock1 and: aBlock2 - - ^aBlock1 value and: aBlock2! ! -!True methodsFor: 'controlling' stamp: 'jmv 7/9/2018 16:39:09'! - and: aBlock1 and: aBlock2 and: aBlock3 - - ^aBlock1 value and: aBlock2 and: aBlock3! ! -!True methodsFor: 'controlling' stamp: 'jmv 7/9/2018 16:39:14'! - and: aBlock1 and: aBlock2 and: aBlock3 and: aBlock4 - - ^aBlock1 value and: aBlock2 and: aBlock3 and: aBlock4 ! ! -!True methodsFor: 'controlling' stamp: 'HAW 7/8/2018 20:13:31'! - or: aBlock1 or: aBlock2 - - ^self! ! -!True methodsFor: 'controlling' stamp: 'HAW 7/8/2018 20:13:43'! - or: aBlock1 or: aBlock2 or: aBlock3 - - ^self! ! -!True methodsFor: 'controlling' stamp: 'HAW 7/8/2018 20:13:48'! - or: aBlock1 or: aBlock2 or: aBlock3 or: aBlock4 - - ^self! ! -!Boolean methodsFor: 'controlling' stamp: 'HAW 7/8/2018 20:16:44' prior: 16790174! - and: block1 and: block2 - "Nonevaluating conjunction without deep nesting. - The receiver is evaluated, followed by the blocks in order. - If any of these evaluates as false, then return false immediately, - without evaluating any further blocks. - If all return true, then return true." - - self subclassResponsibility! ! -!Boolean methodsFor: 'controlling' stamp: 'HAW 7/8/2018 20:16:50' prior: 16790189! - and: block1 and: block2 and: block3 - "Nonevaluating conjunction without deep nesting. - The receiver is evaluated, followed by the blocks in order. - If any of these evaluates as false, then return false immediately, - without evaluating any further blocks. - If all return true, then return true." - - self subclassResponsibility! ! -!Boolean methodsFor: 'controlling' stamp: 'HAW 7/8/2018 20:16:57' prior: 16790205! - and: block1 and: block2 and: block3 and: block4 - "Nonevaluating conjunction without deep nesting. - The receiver is evaluated, followed by the blocks in order. - If any of these evaluates as false, then return false immediately, - without evaluating any further blocks. - If all return true, then return true." - - self subclassResponsibility! ! -!Boolean methodsFor: 'controlling' stamp: 'HAW 7/8/2018 20:17:04' prior: 16790280! - or: block1 or: block2 - "Nonevaluating alternation without deep nesting. - The receiver is evaluated, followed by the blocks in order. - If any of these evaluates as true, then return true immediately, - without evaluating any further blocks. - If all return false, then return false." - - self subclassResponsibility! ! -!Boolean methodsFor: 'controlling' stamp: 'HAW 7/8/2018 20:17:09' prior: 16790294! - or: block1 or: block2 or: block3 - "Nonevaluating alternation without deep nesting. - The receiver is evaluated, followed by the blocks in order. - If any of these evaluates as true, then return true immediately, - without evaluating any further blocks. - If all return false, then return false." - - self subclassResponsibility! ! -!Boolean methodsFor: 'controlling' stamp: 'HAW 7/8/2018 20:17:17' prior: 16790310! - or: block1 or: block2 or: block3 or: block4 - "Nonevaluating alternation without deep nesting. - The receiver is evaluated, followed by the blocks in order. - If any of these evaluates as true, then return true immediately, - without evaluating any further blocks. - If all return false, then return false." - - self subclassResponsibility! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3366-BooleanEnhancements-HernanWilkinson-JuanVuletich-2018Jul09-16h31m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3364] on 9 July 2018 at 10:16:59 am'! -!Float64Array methodsFor: 'arithmetic' stamp: 'jmv 7/8/2018 19:37:51'! - divideBy: aFloatArrayOrNumber ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue - ^aFloatArrayOrNumber isNumber - ifTrue:[self divideByScalar: aFloatArrayOrNumber asFloat ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue] - ifFalse:[self divideByArray: aFloatArrayOrNumber ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue]! ! -!Float64Array methodsFor: 'primitives-plugin' stamp: 'jmv 7/9/2018 09:45:37'! - divideByArray: floatArray ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue - - "It would be nice to have FloatArrayPlugin or equivalent for Float64Array..." - 1 to: self size do:[:i| | dividend divisor quotient | - dividend _ self at: i. - divisor _ floatArray at: i. - quotient _ - divisor isZero - ifTrue: [ - dividend isZero - ifTrue: indeterminateBlockOrValue - ifFalse: zeroDivisionBlockOrValue ] - ifFalse: [dividend / divisor]. - self at: i put: quotient]! ! -!Float64Array methodsFor: 'primitives-plugin' stamp: 'jmv 7/9/2018 09:45:23'! - divideByScalar: scalarValue ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue - - "It would be nice to have FloatArrayPlugin or equivalent for Float64Array..." - 1 to: self size do:[:i| | dividend quotient | - dividend _ self at: i. - quotient _ - scalarValue isZero - ifTrue: [ - dividend isZero - ifTrue: indeterminateBlockOrValue - ifFalse: zeroDivisionBlockOrValue ] - ifFalse: [dividend / scalarValue]. - self at: i put: quotient]! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'jmv 7/9/2018 09:41:43'! - divideBy: aFloatArrayOrNumber ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue - ^aFloatArrayOrNumber isNumber - ifTrue:[self divideByScalar: aFloatArrayOrNumber asFloat ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue] - ifFalse:[self divideByArray: aFloatArrayOrNumber ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue]! ! -!FloatArray methodsFor: 'primitives-plugin' stamp: 'jmv 7/9/2018 09:44:49'! - divideByArray: floatArray ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue - - (self primDivArray: floatArray) == #primitiveFailure ifTrue: [ - 1 to: self size do:[:i| | dividend divisor quotient | - dividend _ self at: i. - divisor _ floatArray at: i. - quotient _ - divisor isZero - ifTrue: [ - dividend isZero - ifTrue: indeterminateBlockOrValue - ifFalse: zeroDivisionBlockOrValue ] - ifFalse: [dividend / divisor]. - self at: i put: quotient]]! ! -!FloatArray methodsFor: 'primitives-plugin' stamp: 'jmv 7/8/2018 21:47:26'! - divideByScalar: scalarValue ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue - - "This primitive doesn't fail if argument is zeros, just fills with infinity or nan" - scalarValue isZero ifFalse: [ - ^self primDivScalar: scalarValue ]. - 1 to: self size do:[:i| | dividend quotient | - dividend _ self at: i. - quotient _ dividend isZero - ifTrue: indeterminateBlockOrValue - ifFalse: zeroDivisionBlockOrValue. - self at: i put: quotient]! ! -!Float64Array methodsFor: 'arithmetic' stamp: 'jmv 7/8/2018 18:52:23' prior: 16846212! - /= anObject - - ^self divideBy: anObject - ifDivisorZero: [^ZeroDivide signalWithDividend: self] - ifBothZero: [^ZeroDivide signalWithDividend: self]! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'jmv 7/8/2018 18:52:33' prior: 16846470! - /= anObject - - ^self divideBy: anObject - ifDivisorZero: [^ZeroDivide signalWithDividend: self] - ifBothZero: [^ZeroDivide signalWithDividend: self]! ! -!FloatArray methodsFor: 'primitives-plugin' stamp: 'jmv 7/8/2018 19:29:26' prior: 16846584! - primDivArray: floatArray - - - ^#primitiveFailure! ! -!FloatArray methodsFor: 'primitives-plugin' stamp: 'jmv 7/8/2018 19:53:08' prior: 16846592! - primDivScalar: scalarValue - "This primitive doesn't fail if argument is zero. It fills result with infinity or nan. - For consistency with division with arrays, and general practice, an exception block or value might be used in public protocol. If needed, call directly this method instead. - - #[1.0 2.0 3.141592 0.0] asFloatArray primDivScalar: 0.0. - #[1.0 2.0 3.141592 0.0] asFloatArray / 0.0. - #[1.0 2.0 3.141592 0.0] asFloatArray divideBy: 0.0 ifDivisorZero: -100 ifBothZero: -200 - " - - 1 to: self size do:[:i| self at: i put: (self at: i) / scalarValue].! ! - -Float64Array removeSelector: #primDivArray:! - -Float64Array removeSelector: #primDivArray:! - -Float64Array removeSelector: #primDivScalar:! - -Float64Array removeSelector: #primDivScalar:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3367-ArrayDivisionEnhancements-JuanVuletich-2018Jul09-10h14m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3358] on 9 July 2018 at 5:31:34 pm'! -!False methodsFor: 'controlling' stamp: 'HAW 7/9/2018 17:27:55' prior: 50404255! - or: aBlock1 or: aBlock2 - - "I sending value to aBlock2 to optimize the generated byte-code - Hernan" - ^aBlock1 value or: [ aBlock2 value ] -! ! -!False methodsFor: 'controlling' stamp: 'HAW 7/9/2018 17:28:10' prior: 50404259! - or: aBlock1 or: aBlock2 or: aBlock3 - - "I sending value to aBlock3 to optimize the generated byte-code - Hernan" - ^aBlock1 value or: [ aBlock2 value or: [ aBlock3 value ] ]! ! -!False methodsFor: 'controlling' stamp: 'HAW 7/9/2018 17:28:37' prior: 50404264! -or: aBlock1 or: aBlock2 or: aBlock3 or: aBlock4 - - "I sending value to aBlock4 to optimize the generated byte-code - Hernan" - ^aBlock1 value or: [ aBlock2 value or: [ aBlock3 value or: [ aBlock4 value ]]]. -! ! -!True methodsFor: 'controlling' stamp: 'HAW 7/9/2018 17:29:32' prior: 50404270! - and: aBlock1 and: aBlock2 - - "I sending value to aBlock2 to optimize the generated byte-code - Hernan" - ^aBlock1 value and: [ aBlock2 value ]! ! -!True methodsFor: 'controlling' stamp: 'HAW 7/9/2018 17:29:59' prior: 50404274! -and: aBlock1 and: aBlock2 and: aBlock3 - - "I sending value to aBlock3 to optimize the generated byte-code - Hernan" - ^aBlock1 value and: [ aBlock2 value and: [ aBlock3 value ]]! ! -!True methodsFor: 'controlling' stamp: 'HAW 7/9/2018 17:30:40' prior: 50404279! - and: aBlock1 and: aBlock2 and: aBlock3 and: aBlock4 - - "I sending value to aBlock4 to optimize the generated byte-code - Hernan" - ^aBlock1 value and: [ aBlock2 value and: [ aBlock3 value and: [ aBlock4 value ]]] ! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3368-BooleanEnhancements-take2-HernanWilkinson-2018Jul08-20h18m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3361] on 10 July 2018 at 7:12:14 pm'! -!SmalltalkEditor methodsFor: 'menu' stamp: 'HAW 7/10/2018 19:08:18'! - createMenuCollectingOptionsWith: aMenuOptionsSelector - - ^(DynamicMenuBuilder buildTitled: self class name targeting: self collectingMenuOptionsWith: aMenuOptionsSelector) - addStayUpIcons; - yourself - -! ! -!SmalltalkEditor methodsFor: 'menu' stamp: 'HAW 7/10/2018 19:08:50'! - getMenu2 - - ^self createMenuCollectingOptionsWith: #smalltalkEditorMenu2Options! ! -!SmalltalkEditor methodsFor: 'menu' stamp: 'HAW 7/10/2018 19:09:14'! - openMenu: aMenu - - aMenu popUpInWorld: morph world! ! -!SmalltalkEditor class methodsFor: 'menu' stamp: 'HAW 7/10/2018 19:03:02'! - smalltalkEditorMenu2Options - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Find...(f)'. - #selector -> #find. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'Find Again (g)'. - #selector -> #findAgain. - #icon -> #systemIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Use Selection for Find (j)'. - #selector -> #setSearchString. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Undo - multiple (z)'. - #selector -> #undo. - #icon -> #undoIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Redo - multiple (Z)'. - #selector -> #redo. - #icon -> #redoIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'Undo / Redo history'. - #selector -> #offerUndoHistory. - #icon -> #changesIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Copy (c)'. - #selector -> #copySelection. - #icon -> #copyIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Cut (x)'. - #selector -> #cut. - #icon -> #cutIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'Paste (v)'. - #selector -> #paste. - #icon -> #pasteIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 40. - #label -> 'Paste without Format'. - #selector -> #pasteString. - #icon -> #pasteIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 50. - #label -> 'Paste...'. - #selector -> #pasteRecent. - #icon -> #worldIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'Toggle WordWrap'. - #selector -> #wrapOnOff. - #icon -> #genericTextIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'Set Font... (k)'. - #selector -> #offerFontMenu. - #icon -> #preferencesDesktopFontIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'Clear Font'. - #selector -> #clearFont. - #icon -> #newIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 40. - #label -> 'Set Default Font...'. - #selector -> #offerDefaultFontMenu. - #icon -> #fontXGenericIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'More...'. - #selector -> #openMenu. - #icon -> #listAddIcon - } asDictionary. - }` -! ! -!SmalltalkEditor class methodsFor: 'menu' stamp: 'HAW 7/10/2018 18:57:42'! - smalltalkEditorMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Help...'. - #selector -> #openHelp. - #icon -> #helpIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Do it (d)'. - #selector -> #doIt. - #icon -> #doItIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Print it (p)'. - #selector -> #printIt. - #icon -> #printIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'Inspect it (i)'. - #selector -> #inspectIt. - #icon -> #inspectIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 40. - #label -> 'Explore it (I)'. - #selector -> #exploreIt. - #icon -> #exploreIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 50. - #label -> 'Debug it (D)'. - #selector -> #debugIt. - #icon -> #debugIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 60. - #label -> 'Profile it'. - #selector -> #profileIt. - #icon -> #clockIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Explain'. - #selector -> #explain. - #icon -> #helpIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Browse it (b)'. - #selector -> #browseIt. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'Senders of it (n)'. - #selector -> #sendersOfIt. - #icon -> #mailForwardIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 40. - #label -> 'Implementors of it (m)'. - #selector -> #implementorsOfIt. - #icon -> #developmentIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 50. - #label -> 'References to it (N)'. - #selector -> #referencesToIt. - #icon -> #addressBookIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'Method Strings with it (E)'. - #selector -> #methodStringsContainingit. - #icon -> #genericTextIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'Method Source with it'. - #selector -> #methodSourceContainingIt. - #icon -> #scriptIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'Class Comments with it'. - #selector -> #classCommentsContainingIt. - #icon -> #chatIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'Accept (s)'. - #selector -> #acceptContents. - #icon -> #acceptIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 20. - #label -> 'Cancel (l)'. - #selector -> #cancelEdits. - #icon -> #cancelIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'Accept & Run Test in Class (t)'. - #selector -> #acceptAndTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 40. - #label -> 'Accept & Run Test in Category (y)'. - #selector -> #acceptAndTestAll. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 50. - #label -> 'Accept & Debug Test (r)'. - #selector -> #acceptAndDebugTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'More...'. - #selector -> #openMenu2. - #icon -> #listAddIcon - } asDictionary. - }`! ! -!SmalltalkEditor methodsFor: 'menu' stamp: 'HAW 7/10/2018 19:08:33' prior: 50396451! - getMenu - - ^self createMenuCollectingOptionsWith: #smalltalkEditorMenuOptions! ! -!SmalltalkEditor methodsFor: 'menu' stamp: 'HAW 7/10/2018 19:09:25' prior: 50395430! - openMenu - - self openMenu: self getMenu - ! ! -!SmalltalkEditor methodsFor: 'menu' stamp: 'HAW 7/10/2018 19:09:34' prior: 50396546! - openMenu2 - - self openMenu: self getMenu2 - ! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3369-Make-SmalltalkEditorMenu-dynamic-HernanWilkinson-2018Jul10-18h51m-HAW.1.cs.st----! - -----SNAPSHOT----#(11 July 2018 3:43:07.11253 pm) Cuis5.0-3369-32.image priorSource: 2247017! - -----QUIT----#(11 July 2018 3:43:17.800134 pm) Cuis5.0-3369-32.image priorSource: 2342824! - -----STARTUP----#(27 July 2018 10:44:32.069372 am) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3369-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3369] on 11 July 2018 at 5:18:12 pm'! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'jmv 7/11/2018 17:16:50' prior: 50373585! - browseIt - "Launch a browser for the current selection, if appropriate" - - | aSymbol anEntry browser | - Preferences alternativeBrowseIt ifTrue: [^ self browseClassFromIt]. - - self wordSelectAndEmptyCheck: [^ self]. - aSymbol _ self selectedSymbol ifNil: [ - self - evaluateSelectionAndDo: [ :result | result class name ] - ifFail: [ morph flash ] - profiled: false]. - - aSymbol first isUppercase - ifTrue: [ - anEntry _ (Smalltalk - at: aSymbol - ifAbsent: [ - Smalltalk browseAllImplementorsOf: aSymbol. - ^ nil]). - anEntry ifNil: [^ morph flash]. - (anEntry isKindOf: Class) - ifFalse: [anEntry _ anEntry class]. - browser _ Browser new. - browser setClass: anEntry selector: nil. - BrowserWindow open: browser label:'System Browser: ', aSymbol] - ifFalse: - [Smalltalk browseAllImplementorsOf: aSymbol]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3370-browseIt-onObjects-JuanVuletich-2018Jul11-17h16m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3369] on 11 July 2018 at 6:10:38 pm'! -!Float methodsFor: 'printing' stamp: 'jmv 7/11/2018 18:06:31'! - absPrintOn: aStream base: base mantissaSignificantBits: significantBits - "Print my value on a stream in the given base. Assumes that my value is strictly - positive; negative numbers, zero, and NaNs have already been handled elsewhere. - Based upon the algorithm outlined in: - Robert G. Burger and R. Kent Dybvig - Printing Floating Point Numbers Quickly and Accurately - ACM SIGPLAN 1996 Conference on Programming Language Design and Implementation - June 1996. - This version performs all calculations with Floats instead of LargeIntegers, and loses - about 3 lsbs of accuracy compared to an exact conversion." - - | fBase exp baseExpEstimate r s mPlus mMinus scale d tc1 tc2 fixedFormat decPointCount | - self isInfinite ifTrue: [aStream nextPutAll: 'Infinity'. ^ self]. - fBase := base asFloat. - exp := self exponent. - baseExpEstimate := (exp * fBase reciprocalLogBase2 - 1.0e-10) ceiling. - exp >= 0 - ifTrue: - [r := self. - s := 1.0. - mPlus := 1.0 timesTwoPower: exp - significantBits. - mMinus := self significand ~= 1.0 ifTrue: [mPlus] ifFalse: [mPlus / 2.0]] - ifFalse: - [r := self timesTwoPower: significantBits. - s := 1.0 timesTwoPower: significantBits. - mMinus := 1.0 timesTwoPower: (exp max: -1024). - mPlus := - (exp = MinValLogBase2) | (self significand ~= 1.0) - ifTrue: [mMinus] - ifFalse: [mMinus * 2.0]]. - baseExpEstimate >= 0 - ifTrue: - [exp = 1023 - ifTrue: "scale down to prevent overflow to Infinity during conversion" - [r := r / fBase. - s := s * (fBase raisedToInteger: baseExpEstimate - 1). - mPlus := mPlus / fBase. - mMinus := mMinus / fBase] - ifFalse: - [s := s * (fBase raisedToInteger: baseExpEstimate)]] - ifFalse: - [exp < -1023 - ifTrue: "scale up to prevent denorm reciprocals overflowing to Infinity" - [d := (53 * fBase reciprocalLogBase2 - 1.0e-10) ceiling. - scale := fBase raisedToInteger: d. - r := r * scale. - mPlus := mPlus * scale. - mMinus := mMinus * scale. - scale := fBase raisedToInteger: (baseExpEstimate + d) negated] - ifFalse: - [scale := fBase raisedToInteger: baseExpEstimate negated]. - s := s / scale]. - (r + mPlus >= s) - ifTrue: [baseExpEstimate := baseExpEstimate + 1] - ifFalse: - [s := s / fBase]. - (fixedFormat := baseExpEstimate between: -3 and: 6) - ifTrue: - [decPointCount := baseExpEstimate. - baseExpEstimate <= 0 - ifTrue: [aStream nextPutAll: ('0.000000' truncateTo: 2 - baseExpEstimate)]] - ifFalse: - [decPointCount := 1]. - [d := (r / s) truncated. - r := r - (d * s). - (tc1 := r <= mMinus) | (tc2 := r + mPlus >= s)] whileFalse: - [aStream nextPut: (Character digitValue: d). - r := r * fBase. - mPlus := mPlus * fBase. - mMinus := mMinus * fBase. - decPointCount := decPointCount - 1. - decPointCount = 0 ifTrue: [aStream nextPut: $.]]. - tc2 ifTrue: - [tc1 not | (tc1 & (r*2.0 >= s)) ifTrue: [d := d + 1]]. - aStream nextPut: (Character digitValue: d). - decPointCount > 0 - ifTrue: - [decPointCount - 1 to: 1 by: -1 do: [:i | aStream nextPut: $0]. - aStream nextPutAll: '.0']. - fixedFormat ifFalse: - [aStream nextPut: $e. - aStream nextPutAll: (baseExpEstimate - 1) printString]! ! -!Float methodsFor: 'printing' stamp: 'jmv 7/11/2018 17:45:59'! - printAsIEEE32BitPrecisionFloatOn: aStream base: base - "Handle sign, zero, and NaNs; all other values passed to absPrintOn:base:mantissaSignificantBits: - Print as a 32 bit Float" - - self isNaN ifTrue: [aStream nextPutAll: 'NaN'. ^ self]. "check for NaN before sign" - self > 0.0 - ifTrue: [self absPrintOn: aStream base: base mantissaSignificantBits: 24] - ifFalse: - [self sign = -1 - ifTrue: [aStream nextPutAll: '-']. - self = 0.0 - ifTrue: [aStream nextPutAll: '0.0'. ^ self] - ifFalse: [self negated absPrintOn: aStream base: base mantissaSignificantBits: 24]]! ! -!FloatArray methodsFor: 'printing' stamp: 'jmv 7/11/2018 17:49:59'! - printElementsOn: aStream - "FloatArray elements are answered as 64 bit Float, but are really 32 bit Float. - When printing, print them as 32 bit Float." - aStream nextPut: $(. - self do: [ :element | - element printAsIEEE32BitPrecisionFloatOn: aStream base: 10. - aStream space]. - self isEmpty ifFalse: [aStream skip: -1]. - aStream nextPut: $)! ! -!Float methodsFor: 'printing' stamp: 'jmv 7/11/2018 17:43:34' prior: 16845413! - absPrintOn: aStream base: base - "Print my value on a stream in the given base. Assumes that my value is strictly - positive; negative numbers, zero, and NaNs have already been handled elsewhere. - Based upon the algorithm outlined in: - Robert G. Burger and R. Kent Dybvig - Printing Floating Point Numbers Quickly and Accurately - ACM SIGPLAN 1996 Conference on Programming Language Design and Implementation - June 1996. - This version performs all calculations with Floats instead of LargeIntegers, and loses - about 3 lsbs of accuracy compared to an exact conversion." - - self absPrintOn: aStream base: base mantissaSignificantBits: 50 "approximately 3 lsb's of accuracy loss during conversion"! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3371-FloatArray-printAs32bitFloat-JuanVuletich-2018Jul11-18h06m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3371] on 15 July 2018 at 10:28:26 pm'! -!MouseEvent methodsFor: 'button state' stamp: 'jmv 7/15/2018 22:24:54' prior: 16879055! - mouseButton1Pressed - "Answer true if the mouseButton1 is being pressed. - This is the first mouse button, usually the one at the left. - But if they are combined with ctrl or option(Mac) keys, it is considered button 2 or 3 (depending on shift). - See also #mouseButton1Changed" - - self controlKeyPressed ifTrue: [ ^ false ]. - ^ buttons anyMask: InputSensor mouseButton1! ! -!MouseEvent methodsFor: 'button state' stamp: 'jmv 7/15/2018 22:23:15' prior: 16879080! - mouseButton2Pressed - "Answer true if the mouseButton2 is being pressed. - This is usually the right mouse button or option+click on the Mac. - It is also emulated here with shift-ctrl-click on any platform." - - (self controlKeyPressed and: [self shiftPressed] and: [ buttons anyMask: InputSensor mouseButton1 ]) - ifTrue: [ ^ true ]. - ^ buttons anyMask: InputSensor mouseButton2! ! -!MouseEvent methodsFor: 'button state' stamp: 'jmv 7/15/2018 22:21:11' prior: 16879089! - mouseButton3Pressed - "Answer true if the mouseButton3 is being pressed. - This is usually the center (wheel) mouse button or cmd+click on the Mac or ctrl+click on Linux. - It is also emulated here with ctrl-click on any platform (i.e. Windows)." - - (self controlKeyPressed and: [self shiftPressed not] and: [ buttons anyMask: InputSensor mouseButton1 ]) - ifTrue: [ ^ true ]. - ^ buttons anyMask: InputSensor mouseButton3! ! -!MouseButtonEvent methodsFor: 'accessing' stamp: 'jmv 7/15/2018 22:25:04' prior: 16878630! -mouseButton1Changed - "Answer true if the mouseButton1 has changed. - This is usually the left mouse button. - But if they are combined with ctrl or option(Mac) keys, it is considered button 2 or 3 (depending on shift). - The check for button change (instead of button press) is specially useful on buttonUp events. - See also #mouseButton1Pressed" - - self controlKeyPressed ifTrue: [ ^ false ]. - ^ whichButton anyMask: InputSensor mouseButton1! ! -!MouseButtonEvent methodsFor: 'accessing' stamp: 'jmv 7/15/2018 22:22:40' prior: 16878657! - mouseButton2Changed - "Answer true if the mouseButton2 has changed. - This is the usually the right mouse button or option+click on the Mac. - It is also emulated here with shift-ctrl-click on any platform. - The check for button change (instead of button press) is specially useful on buttonUp events." - - (self controlKeyPressed and: [self shiftPressed] and: [ whichButton anyMask: InputSensor mouseButton1 ]) - ifTrue: [ ^ true ]. - ^ whichButton anyMask: InputSensor mouseButton2! ! -!MouseButtonEvent methodsFor: 'accessing' stamp: 'jmv 7/15/2018 22:22:16' prior: 16878669! - mouseButton3Changed - "Answer true if the mouseButton3 has changed. - This is usually the center (wheel) mouse button or cmd+click on the Mac or ctrl+click on Linux. - It is also emulated here with ctrl-click on any platform (i.e. Windows). - The check for button change (instead of button press) is specially useful on buttonUp events." - - (self controlKeyPressed and: [self shiftPressed not] and: [ whichButton anyMask: InputSensor mouseButton1 ]) - ifTrue: [ ^ true ]. - ^ whichButton anyMask: InputSensor mouseButton3! ! - -Preferences class removeSelector: #commandClickOpensHalo! - -Preferences class removeSelector: #commandClickOpensHalo! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3372-ctrlClick-shiftCtrlClick-MouseButtons-JuanVuletich-2018Jul15-22h27m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3372] on 16 July 2018 at 4:24:19 pm'! -!Array2D methodsFor: 'iterating' stamp: 'jmv 7/16/2018 15:12:46'! - do: aBlock - "Evaluate aBlock on each element" - - 1 to: height do: [ :i | - 1 to: width do: [ :j | - aBlock value: (self i: i j: j) ] ]! ! -!Array2D methodsFor: 'iterating' stamp: 'jmv 7/16/2018 16:14:30'! - with: otherImage do: aBlock - "Evaluate aBlock on each element" - - 1 to: height do: [ :i | - 1 to: width do: [ :j | - aBlock value: (self i: i j: j) value: (otherImage i: i j: j) ] ]! ! -!Array2D methodsFor: 'iterating' stamp: 'jmv 7/16/2018 15:11:48' prior: 16780157! - withIndexesDo: aBlock - "Evaluate aBlock on each element, including i, j indexes also as arguments" - - 1 to: height do: [ :i | - 1 to: width do: [ :j | - aBlock value: i value: j value: (self i: i j: j) ] ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3373-Array2D-iteration-JuanVuletich-2018Jul16-15h11m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3372] on 19 July 2018 at 9:35:19 am'! -!Number methodsFor: 'converting' stamp: 'jmv 7/18/2018 11:03:29'! - inMinusPiToPiRange - "Avoid conversion to Float if already ok" - (self > Float pi negated and: [self <= Float pi]) ifTrue: [ - ^ self ]. - ^ self asFloat inMinusPiToPiRange! ! -!Float methodsFor: 'converting' stamp: 'jmv 7/17/2018 15:52:15'! - inMinusPiToPiRange - "For angles in radians. Add or remove whole turns until we get to the (-Pi .. +Pi] range" - | answer | - answer _ self \\ Twopi. - answer > Pi ifTrue: [ - answer _ answer - Twopi ]. - ^ answer! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3374-inMinusPiToPiRange-JuanVuletich-2018Jul19-09h33m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3374] on 26 July 2018 at 11:48:37 am'! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 7/26/2018 09:42:55'! - smoothIsAbsBelow: threshold - "A Function that is 1 at zero, 0 outside a bounded interval of size 4*threshold, and is continuous and differentiable. - - It is a 'smooth' version of the #isAbsBelow: function. - Useful when we need to 'count' stuff, but still want continuous and differentiable stuff." - " - | g | - Feature require: 'Morphic-Widgets-Extras'. - g _ FunctionGraphMorph new. - g domain: (-4 to: 4). - g addFunction: [ :x | x abs < Float halfPi ifTrue: [1] ifFalse:[0] ] color: Color brown. - g addFunction: [ :x | x smoothIsAbsBelow: Float halfPi ] color: Color red. - (g embeddedInMorphicWindowLabeled: 'graph') openInWorld - " - | scaled | - scaled _ self / threshold. - ^ scaled abs < 2 ifTrue: [ (scaled * Float halfPi) cos + 1.0 * 0.5 ] ifFalse: [ 0 ]! ! -!Number methodsFor: 'arithmetic' stamp: 'jmv 7/26/2018 09:41:17' prior: 16879650! - \\ divisor - "Modulo operation. Remainder of the integer division #// (Floored division, truncated to minus infinity, a.k.a Knuth's division) - Answer a Number with the same sign as divisor. - 9\\4 = 1 - -9\\4 = 3 - 9\\-4 = -3 - 0.9\\0.4 = 0.1 - See http://en.wikipedia.org/wiki/Modulo_operation - See #\\, #rem: and #mod: - See detailed discussion at http://mathforum.org/library/drmath/view/52343.html - " - - ^self - (self // divisor * divisor) - - "Evaluate the following:" -" -| g d | -d _ 1. -Feature require: 'Morphic-Widgets-Extras'. -g _ FunctionGraphMorph new. -g domain: (-4 to: 4). -g addFunction: [ :x | x \\ d ] color: Color green. -g addFunction: [ :x | x // d ] color: Color red. -g openInWorld -" -" -| g d | -d _ -1. -Feature require: 'Morphic-Widgets-Extras'. -g _ FunctionGraphMorph new. -g domain: (-4 to: 4). -g addFunction: [ :x | x \\ d ] color: Color green. -g addFunction: [ :x | x // d ] color: Color red. -g openInWorld -"! ! -!Number methodsFor: 'arithmetic' stamp: 'jmv 7/26/2018 09:41:05' prior: 16879710! - mod: divisor - "Modulo operation. Remainder of the integer division #div: (Euclidean division) - Answer a Number that is never negative (it is positive or zero). - (9 mod: 4) = 1 - (-9 mod: 4) = 3 - (9 mod: -4) = 1 - (0.9 mod: 0.4) = 0.1 - See http://en.wikipedia.org/wiki/Modulo_operation - See #\\, #rem: and #mod: - See detailed discussion at http://mathforum.org/library/drmath/view/52343.html - And https://biblio.ugent.be/input/download?func=downloadFile&recordOId=314490&fileOId=452146 - " - "Answer r such that: - for some integer q, aNumber * q + r = self - with 0 <= r < | aNumber |" - - ^self \\ divisor abs - - "Evaluate the following:" -" -| g d | -d _ 1. -Feature require: 'Morphic-Widgets-Extras'. -g _ FunctionGraphMorph new. -g domain: (-4 to: 4). -g addFunction: [ :x | x mod: d ] color: Color green. -g addFunction: [ :x | x div: d ] color: Color red. -g openInWorld -" -" -| g d | -d _ -1. -Feature require: 'Morphic-Widgets-Extras'. -g _ FunctionGraphMorph new. -g domain: (-4 to: 4). -g addFunction: [ :x | x mod: d ] color: Color green. -g addFunction: [ :x | x div: d ] color: Color red. -g openInWorld -" -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3375-smothIsAbsBelow-JuanVuletich-2018Jul26-09h40m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3375] on 26 July 2018 at 3:11:29 pm'! -!Editor class methodsFor: 'help' stamp: 'jmv 7/26/2018 15:10:49' prior: 16836998! - help - " - Editor help - SimpleEditor help - CellStyleEditor help - TextEditor help - SmalltalkEditor help - " - | allSpecs | - allSpecs _ self cmdShortcutsSpec, self basicCmdShortcutsSpec. - ^String streamContents: [ :strm | - allSpecs do: [ :triplet | | c | - c _ triplet first = Character space - ifFalse: [ triplet first asString, ' ' ] - ifTrue: [ 'Space']. - strm nextPutAll: ('Cmd-', c, String tab, String tab, triplet third). - strm newLine ]]! ! -!SmalltalkEditor class methodsFor: 'keyboard shortcut tables' stamp: 'jmv 7/26/2018 15:05:27' prior: 50341359! - cmdShortcutsSpec - " - Editor initialize - " - "arranged in QWERTY keyboard order" - ^#( - #( $r #acceptAndDebugTest: 'Saves method and debugs it') - #( $t #acceptAndTest: 'Saves method, runs it as test and then all tests in class. Opens debugger if error') - #( $y #acceptAndTestAll: 'Saves method, runs it as test and then all tests in class category. Opens debugger if error') - #( $i #inspectIt: 'Inspect it (selection is a valid expression, or selection is over an inspect-ilst)') - #( $p #printIt: 'Print it (selection is a valid expression)') - - #( $s #save: 'Save (i.e. accept)') - #( $d #doIt: 'Do it (selection is a valid expression)') - - #( $b #browseIt: 'Browse it (selection is a class name or cursor is over a class-list or message-list)') - #( $n #sendersOfIt: 'Senders of it (selection is a message selector or cursor is over a class-list or message-list)') - #( $m #implementorsOfIt: 'Implementors of it (selection is a message selector or cursor is over a class-list or message-list)') - - #( $E #methodStringsContainingit:'Method strings containing it') - #( $T #displayIfTrue: 'Insert #ifTrue:') - #( $I #exploreIt: 'Inspect via Object Explorer') - - #( $A #argAdvance: 'Advance argument') - #( $D #debugIt: 'Debug it') - #( $F #displayIfFalse: 'Insert #ifFalse:') - #( $G #fileItIn: 'File in selection') - - #( $V #pasteInitials: 'Paste author initials') - #( $N #referencesToIt: 'References to it (selection is a class name, or cursor is over a class-list or message-list)') - )! ! -!SmalltalkEditor class methodsFor: 'menu' stamp: 'jmv 7/26/2018 15:04:57' prior: 50404719! - smalltalkEditorMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Help...'. - #selector -> #openHelp. - #icon -> #helpIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Do it (d)'. - #selector -> #doIt. - #icon -> #doItIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Print it (p)'. - #selector -> #printIt. - #icon -> #printIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'Inspect it (i)'. - #selector -> #inspectIt. - #icon -> #inspectIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 40. - #label -> 'Explore it (I)'. - #selector -> #exploreIt. - #icon -> #exploreIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 50. - #label -> 'Debug it (D)'. - #selector -> #debugIt. - #icon -> #debugIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 60. - #label -> 'Profile it'. - #selector -> #profileIt. - #icon -> #clockIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Explain'. - #selector -> #explain. - #icon -> #helpIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Browse it (b)'. - #selector -> #browseIt. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'Senders of it (n)'. - #selector -> #sendersOfIt. - #icon -> #mailForwardIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 40. - #label -> 'Implementors of it (m)'. - #selector -> #implementorsOfIt. - #icon -> #developmentIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 50. - #label -> 'References to it (N)'. - #selector -> #referencesToIt. - #icon -> #addressBookIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'Method Strings with it (E)'. - #selector -> #methodStringsContainingit. - #icon -> #genericTextIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'Method Source with it'. - #selector -> #methodSourceContainingIt. - #icon -> #scriptIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'Class Comments with it'. - #selector -> #classCommentsContainingIt. - #icon -> #chatIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'Accept (s)'. - #selector -> #acceptContents. - #icon -> #acceptIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'Accept & Run Test in Class (t)'. - #selector -> #acceptAndTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 40. - #label -> 'Accept & Run Test in Category (y)'. - #selector -> #acceptAndTestAll. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 50. - #label -> 'Accept & Debug Test (r)'. - #selector -> #acceptAndDebugTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'More...'. - #selector -> #openMenu2. - #icon -> #listAddIcon - } asDictionary. - }`! ! - -InnerTextMorph removeSelector: #cancelEdits! - -InnerTextMorph removeSelector: #cancelEdits! - -TextEditor removeSelector: #cancelEdits! - -TextEditor removeSelector: #cancelEdits! - -TextEditor removeSelector: #cancelEdits:! - -TextEditor removeSelector: #cancelEdits:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3376-remove-cancel-command-JuanVuletich-2018Jul26-15h04m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3375] on 26 July 2018 at 3:17:53 pm'! -!CuisSourceFileArray commentStamp: '' prior: 16825649! -Cuis source code access mechanism. -Uses the range for sourcePointer in CompiledMethods (16r1000000 to 16r4FFFFFF) quite differently than StandardSourceFileArray (the older way, inherited from Squeak). First half is for Sources, second half is for Changes. The actual offset in the file is the sourcePointer minus 16r1000000 (or minus 16r3000000) multiplied by a scaling factor. This scaling factor is (right now) 32, raising the limit to 1Gb. - -See the class comment at MigratingSourceFileArray to see how to activate this.! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3377-CuisSourceFileArray-comment-JuanVuletich-2018Jul26-15h11m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3377] on 26 July 2018 at 6:15:23 pm'! - -Object subclass: #Utilities - instanceVariableNames: '' - classVariableNames: 'AuthorInitials AuthorName LastStats LogsUserChanges ' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #Utilities category: #'System-Support'! -Object subclass: #Utilities - instanceVariableNames: '' - classVariableNames: 'AuthorInitials AuthorName LastStats LogsUserChanges' - poolDictionaries: '' - category: 'System-Support'! -!SystemDictionary methodsFor: 'image, changes name' stamp: 'jmv 7/26/2018 18:15:12'! - defaultUserChangesName - "Answer the default full path to the changes file corresponding to the image file name." - " - Smalltalk defaultUserChangesName - " - ^(FileIOAccessor default baseNameFor: self imageName), '.user.changes'! ! -!Utilities class methodsFor: 'identification' stamp: 'jmv 7/26/2018 18:15:16'! - logsUserChanges - LogsUserChanges ifNil: [ LogsUserChanges _ true ]. - ^ LogsUserChanges! ! -!Utilities class methodsFor: 'identification' stamp: 'jmv 7/26/2018 18:15:19'! - logsUserChanges: aBoolean - LogsUserChanges _ aBoolean! ! - -Object subclass: #Utilities - instanceVariableNames: '' - classVariableNames: 'AuthorInitials AuthorName LastStats LogsUserChanges' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #Utilities category: #'System-Support'! -Object subclass: #Utilities - instanceVariableNames: '' - classVariableNames: 'AuthorInitials AuthorName LastStats LogsUserChanges' - poolDictionaries: '' - category: 'System-Support'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3378-logsUserChanges-JuanVuletich-2018Jul26-18h12m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3377] on 26 July 2018 at 6:28:18 pm'! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'jmv 7/26/2018 18:22:27' prior: 16806554! - classComment: aString stamp: aStamp - "Store the comment, aString or Text or RemoteString, associated with the class we are organizing. Empty string gets stored only if had a non-empty one before." - - | ptr header oldCommentRemoteStr | - aString isRemote ifTrue: [ - SystemChangeNotifier uniqueInstance classCommented: self. - ^ self organization classComment: aString stamp: aStamp]. - - oldCommentRemoteStr _ self organization commentRemoteStr. - (aString size = 0) & (oldCommentRemoteStr == nil) ifTrue: [^ self organization classComment: nil]. - "never had a class comment, no need to write empty string out" - - ptr _ oldCommentRemoteStr ifNil: [0] ifNotNil: [oldCommentRemoteStr sourcePointer]. - SourceFiles ifNotNil: [ | file | - (file _ SourceFiles at: 2) ifNotNil: [ - file setToEnd; newLine; nextPut: $!!. "directly" - header _ String streamContents: [:strm | strm nextPutAll: self name; - nextPutAll: ' commentStamp: '. - aStamp storeOn: strm. - strm nextPutAll: ' prior: '; nextPutAll: ptr printString]. - file nextChunkPut: header]]. - self organization classComment: (RemoteString newString: aString onFileNumber: 2) stamp: aStamp. - Utilities logsUserChanges ifTrue: [ - Smalltalk defaultUserChangesName asFileEntry appendStreamDo: [ :stream | - stream newLine; nextPut: $!!. "directly" - header _ String streamContents: [:strm | strm nextPutAll: self name; - nextPutAll: ' commentStamp: '. - aStamp storeOn: strm. - strm nextPutAll: ' prior: '; nextPutAll: ptr printString]. - stream nextChunkPut: header. - stream newLine; nextChunkPut: aString. - ]. - ]. - SystemChangeNotifier uniqueInstance classCommented: self! ! -!BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'jmv 7/26/2018 18:22:23' prior: 16782654! - fileOutCommentOn: aFileStream moveSource: moveSource toFile: fileIndex - "Copy the class comment to aFileStream. If moveSource is true (as in compressChanges or compressSources, then update classComment to point to the new file." - | fileComment | - classComment ifNotNil: [ - aFileStream newLine. - fileComment _ RemoteString newString: classComment text - onFileNumber: fileIndex toFile: aFileStream. - moveSource ifTrue: [classComment _ fileComment]. - Smalltalk defaultUserChangesName asFileEntry appendStreamDo: [ :stream | - stream newLine; nextChunkPut: classComment text ]]! ! -!CompiledMethod methodsFor: 'source code management' stamp: 'jmv 7/26/2018 18:22:32' prior: 16820535! - putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble: preambleBlock - "Store the source code for the receiver on an external file. - If no sources are available, i.e., SourceFile is nil, do nothing. - If the fileIndex is 1, print on *.sources; if it is 2, print on *.changes, - in each case, storing a 4-byte source code pointer at the method end." - - | file remoteString | - (SourceFiles notNil and: [(file _ SourceFiles at: fileIndex) notNil]) ifTrue: [ - - Smalltalk assureStartupStampLogged. - file setToEnd. - - preambleBlock value: file. "Write the preamble" - remoteString _ RemoteString newString: sourceStr onFileNumber: fileIndex toFile: file. - - file nextChunkPut: ' '. - InMidstOfFileinNotification signal ifFalse: [file flush]. - self checkOKToAdd: sourceStr size at: remoteString position in: fileIndex. - self setSourcePosition: remoteString position inFile: fileIndex ]. - - Utilities logsUserChanges ifTrue: [ - Smalltalk defaultUserChangesName asFileEntry appendStreamDo: [ :stream | - preambleBlock value: stream. "Write the preamble" - stream nextChunkPut: sourceStr. - stream nextChunkPut: ' ' ] - ]! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 7/26/2018 17:58:26' prior: 50369623! - logSnapshot: save andQuit: quit - "Log quitting to changes file" - | msg | - self assureStartupStampLogged. - msg _ self snapshotMessageFor: save andQuit: quit. - (SourceFiles at: 2) ifNotNil: [ - save ifTrue: [ - LastQuitLogPosition _ (SourceFiles at: 2) - setToEnd; - position ]]. - self logChange: msg. - Transcript - newLine; - show: msg; - newLine! ! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'jmv 7/26/2018 18:23:44' prior: 16923062! - assureStartupStampLogged - "If there is a startup stamp not yet actually logged to disk, do it now." - | changesFile | - StartupStamp ifNil: [^ self]. - (SourceFiles notNil and: [(changesFile _ SourceFiles at: 2) notNil]) ifTrue: [ - changesFile isReadOnly ifFalse: [ - changesFile setToEnd; newLine; newLine. - changesFile nextChunkPut: StartupStamp asString; newLine. - self forceChangesToDisk ]]. - Smalltalk defaultUserChangesName asFileEntry appendStreamDo: [ :stream | - stream newLine; newLine. - stream nextChunkPut: StartupStamp asString; newLine ]. - StartupStamp _ nil! ! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'jmv 7/26/2018 17:58:32' prior: 16923264! - logChange: aStringOrText - "Write the argument, aString, onto the changes file." - ^ self logChange: aStringOrText preamble: nil! ! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'jmv 7/26/2018 18:27:21' prior: 16923287! - logChange: aStringOrText preamble: preambleOrNil - "Write the argument, aString, onto the changes file." - | aString changesFile | - self assureStartupStampLogged. - aString _ aStringOrText asString. - (aString findFirst: [:char | char isSeparator not]) = 0 - ifTrue: [^ self]. "null doits confuse replay" - (SourceFiles notNil and: [(changesFile _ SourceFiles at: 2) notNil]) ifTrue: [ - changesFile isReadOnly ifFalse: [ - changesFile setToEnd; newLine; newLine. - preambleOrNil ifNotNil: [ - changesFile nextPut: $!!; nextChunkPut: preambleOrNil; newLine ]. - changesFile nextChunkPut: aString. - "If want style changes in DoIt, use nextChunkPutWithStyle:, and allow Texts to get here" - self forceChangesToDisk ]]. - Utilities logsUserChanges ifTrue: [ - Smalltalk defaultUserChangesName asFileEntry appendStreamDo: [ :stream | - stream newLine; newLine. - preambleOrNil ifNotNil: [ - stream nextPut: $!!; nextChunkPut: preambleOrNil; newLine ]. - stream nextChunkPut: aString ]]! ! -!PositionableStream methodsFor: 'fileIn/Out' stamp: 'jmv 7/26/2018 18:15:37' prior: 50366265! - 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 | - Utilities logsUserChanges: false. - announcement - displayProgressAt: Sensor mousePoint - from: 0 - to: self size - during: [ :barBlock | - [ self atEnd ] whileFalse: [ - barBlock value: self position. - self skipSeparators. - - [ - val := (self peekFor: $!!) - ifTrue: [ - chunk := self nextChunk. - "These are the ones that should do nothing, - because next line is a doit that does the stuff - (or because it is handled elsewhere)" - (chunk beginsWith: 'description: ') - | (chunk beginsWith: 'provides: ') - | (chunk beginsWith: 'requires: ') - | (chunk beginsWith: 'classDefinition: ') - | (chunk beginsWith: 'classRemoval: ') - | (chunk beginsWith: 'methodRemoval: ') - | (chunk beginsWith: 'classMoveToSomePackage: ') - | (chunk beginsWith: 'methodMoveToSomePackage: ') - ifFalse: [(Compiler evaluate: chunk logged: false) scanFrom: self]] - ifFalse: [ - chunk := self nextChunk. - self checkForPreamble: chunk. - [ Compiler evaluate: chunk logged: true ] - on: Error - do: [ :ex | - ex print. - ('while evaluating: ', chunk) print. - ex pass ] - ]] - on: InMidstOfFileinNotification - do: [ :ex | ex resume: true ] ]. - ]. - "Note: The main purpose of this banner is to flush the changes file." - Utilities logsUserChanges: true. - Smalltalk logChange: '----End fileIn of ' , self name , '----'. - ^val! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3379-NewLogOfUserChanges-JuanVuletich-2018Jul26-18h15m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3379] on 27 July 2018 at 9:49:22 am'! -!ClassDescription methodsFor: 'accessing' stamp: 'jmv 7/27/2018 09:42:53' prior: 16805673! - comment: aStringOrText - "Set the receiver's comment to be the argument, aStringOrText." - - self theNonMetaClass classComment: aStringOrText asString.! ! -!ClassDescription methodsFor: 'accessing' stamp: 'jmv 7/27/2018 09:41:06' prior: 16805680! - comment: aStringOrText stamp: aStamp - "Set the receiver's comment to be the argument, aStringOrText." - - self theNonMetaClass classComment: aStringOrText asString stamp: aStamp.! ! -!PseudoClass methodsFor: 'class' stamp: 'jmv 7/27/2018 09:43:05' prior: 16896748! - comment: aString - self classComment: aString asString! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3380-tweaks-JuanVuletich-2018Jul27-09h49m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3380] on 27 July 2018 at 10:26:23 am'! -!FileSystemEntry methodsFor: 'convenience' stamp: 'jmv 7/27/2018 10:18:05'! - ifExists: aBlock - "Evaluate a block with receiver as argument if it exists on the file system. If not, do nothing." - self exists ifTrue: [ - aBlock value: self ]! ! -!FeatureRequirement methodsFor: 'private' stamp: 'jmv 7/27/2018 10:24:05'! - withPackageSubfoldersOf: aDirectoryEntry do: aBlock - - "Look in the requested directory" - aBlock value: aDirectoryEntry. - - "Look in the usual Packages subfolders" - aDirectoryEntry / 'Packages' ifExists: [ :packagesFolder | - aBlock value: packagesFolder. - packagesFolder / 'MorphicExamples' ifExists: [ :subFolder | aBlock value: subFolder ]. - packagesFolder / 'CompatibilityPackages' ifExists: [ :subFolder | aBlock value: subFolder ]]. - aDirectoryEntry / 'M3' ifExists: [ :subFolder | aBlock value: subFolder ]! ! -!FeatureRequirement methodsFor: 'private' stamp: 'jmv 7/27/2018 10:16:03' prior: 50376565! -inPackagesSubtreeOf: aDirectoryEntry do: aBlock - - "Direct subfolders" - self withPackageSubfoldersOf: aDirectoryEntry do: aBlock. - - "Finally look in folders that follow the convention of naming package repositories - with the 'Cuis-Smalltalk' prefix, and their possible 'Packages' subdir." - aDirectoryEntry children do: [ :entry | - (entry isDirectory and: [ entry name beginsWith: 'Cuis-Smalltalk' ]) ifTrue: [ - self withPackageSubfoldersOf: entry do: aBlock ]]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3381-PrerequisitesLoadingImprovements-JuanVuletich-2018Jul27-10h25m-jmv.1.cs.st----! - -----SNAPSHOT----#(27 July 2018 10:44:38.232329 am) Cuis5.0-3381-32.image priorSource: 2342918! - -----QUIT----#(27 July 2018 10:44:58.506214 am) Cuis5.0-3381-32.image priorSource: 2378376! - -----STARTUP----#(2 August 2018 9:10:18.602354 am) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3381-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3381] on 27 July 2018 at 2:21:57 pm'! -!ChangeList class methodsFor: 'public access' stamp: 'jmv 7/27/2018 14:20:49' prior: 16796932! - browseRecentLogOn: origChangesFileName startingFrom: initialPos - "Prompt with a menu of how far back to go when browsing a changes file." - - | end banners positions pos chunk i | - origChangesFileName asFileEntry readStreamDo: [ :changesFile | - banners _ OrderedCollection new. - positions _ OrderedCollection new. - end _ changesFile size. - pos _ initialPos. - [pos = 0 - or: [banners size > 20]] - whileFalse: [ - changesFile position: pos. - chunk _ changesFile nextChunk. - i _ chunk indexOfSubCollection: 'priorSource: ' startingAt: 1. - i > 0 - ifTrue: [ - positions addLast: pos. - banners addLast: (chunk copyFrom: 5 to: i - 2). - pos _ Number readFrom: (chunk copyFrom: i + 13 to: chunk size)] - ifFalse: [ - positions addLast: 0. - banners addLast: 'Whole file'. - pos _ 0]]. - ]. - banners size = 0 ifTrue: [^ self inform: -'this image has never been saved -since changes were compressed']. - pos _ (SelectionMenu labelList: banners selections: positions) - startUpWithCaption: 'Browse as far back as...'. - pos - ifNil: [^ self]. - self browseRecent: end - pos on: origChangesFileName! ! -!CompiledMethod methodsFor: 'source code management' stamp: 'jmv 7/27/2018 14:21:47' prior: 50405712! - putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble: preambleBlock - "Store the source code for the receiver on an external file. - If no sources are available, i.e., SourceFile is nil, do nothing. - If the fileIndex is 1, print on *.sources; if it is 2, print on *.changes, - in each case, storing a 4-byte source code pointer at the method end." - - | file remoteString | - Smalltalk assureStartupStampLogged. - (SourceFiles notNil and: [(file _ SourceFiles at: fileIndex) notNil]) ifTrue: [ - file setToEnd. - preambleBlock value: file. "Write the preamble" - remoteString _ RemoteString newString: sourceStr onFileNumber: fileIndex toFile: file. - file nextChunkPut: ' '. - InMidstOfFileinNotification signal ifFalse: [file flush]. - self checkOKToAdd: sourceStr size at: remoteString position in: fileIndex. - self setSourcePosition: remoteString position inFile: fileIndex ]. - - Utilities logsUserChanges ifTrue: [ - Smalltalk defaultUserChangesName asFileEntry appendStreamDo: [ :stream | - preambleBlock value: stream. "Write the preamble" - stream nextChunkPut: sourceStr. - stream nextChunkPut: ' ' ]]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3382-RecentChangesBrowseTweaks-JuanVuletich-2018Jul27-14h16m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3382] on 27 July 2018 at 6:17:35 pm'! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 7/27/2018 18:16:30' prior: 50402092! - parse: isAMethod - "Parse the receiver's text. If isAMethod is true - then treat text as a method, if false as an - expression with no message pattern" - - | continue | - self initializeInstanceVariables. - sourcePosition _ 1. - arguments _ Dictionary new. - temporaries _ Dictionary new. - blockDepth _ bracketDepth := 0. - blockDepths _ OrderedCollection with: blockDepth. - blockDepthsStartIndexes _ OrderedCollection with: sourcePosition. - ranges ifNil: [ ranges := OrderedCollection new: 100] ifNotNil: [ ranges reset]. - errorBlock _ [^false]. - [ - self scanNext. - isAMethod - ifTrue: [ - self parseMessagePattern. - self parsePragmaSequence]. - self parseMethodTemporaries. - isAMethod ifTrue: [self parsePragmaSequence]. - "Iterate once for methods, but pontentially several times for workspaces - (to recover after errors, for possible good next lines or chunks)" - continue _ true. - [ continue ] whileTrue: [ - self parseStatementList. - isAMethod - ifTrue: [ - "Only if we are parsing a method, consider everything after this point as error." - currentToken ifNotNil: [ self error ]. - continue _ false] - ifFalse: [ - sourcePosition > source size ifTrue: [continue _ false]]]. - ] ensure: [errorBlock _ nil]. - ^true! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3383-WorkspaceShoutFix-JuanVuletich-2018Jul27-18h07m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3384] on 30 July 2018 at 9:40:43 am'! -!Number methodsFor: 'testing' stamp: 'jmv 7/30/2018 08:51:35'! - ifNotZero: aBlock - " - Useful for workarounding division by zero - #(1.0 2.0 0.0) collect: [ :k | k ifNotZero: [100.0/k]] - " - ^ self isZero ifFalse: aBlock ifTrue: [self]! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'jmv 7/30/2018 08:53:30' prior: 50365027! - scrollBy: delta - "Move the contents in the direction delta." - - | newYoffset yRange xRange newXoffset | - - "Set the offset on the scroller" - yRange _ self vLeftoverScrollRange. - xRange _ self hLeftoverScrollRange. - newYoffset _ self scrollerOffset y - delta y min: yRange max: 0. - newXoffset _ self scrollerOffset x - delta x min: xRange max: 0. - - self scrollerOffset: newXoffset@newYoffset. - - "Update the scrollBars" - scrollBar scrollValue: (yRange ifNotZero: [newYoffset asFloat / yRange]). - hScrollBar scrollValue: (xRange ifNotZero: [newXoffset asFloat / xRange])! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'jmv 7/30/2018 08:58:19' prior: 50384517! - scrollToShow: aRectangle - "scroll to include as much of aRectangle as possible, where aRectangle is in the scroller's local space. - This means that 0@0 is scrolling all the way top and all the way left" - | deltaY | - (aRectangle top >= (0.1*self viewableHeight) and: [ - aRectangle bottom <= (0.9*self viewableHeight) ]) - ifTrue: [ - "already visible" - ^self ]. - - "Scroll center of selection into view if necessary" - deltaY _ self viewableExtent y * 0.1 - aRectangle top. - deltaY ~= 0 ifTrue: [ - self scrollBy: 0@deltaY ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3384-scrollToShow-JuanVuletich-2018Jul30-09h40m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3384] on 31 July 2018 at 5:43:12 pm'! -!ChangeList class methodsFor: 'public access' stamp: 'jmv 7/31/2018 17:40:24' prior: 50369852! - browseRecentLogOn: origChangesFileName - "figure out where the last snapshot or quit was, then browse the recent entries." - - | end done block positions prevBlock | - origChangesFileName asFileEntry readStreamDo: [ :changesFile | - positions _ SortedCollection new. - end _ changesFile size. - prevBlock _ end. - block _ end - 1024 max: 0. - done _ false. - [ done or: [ positions size > 0 ]] - whileFalse: [ - changesFile position: block. - "ignore first fragment" - changesFile nextChunk. - [ changesFile position < prevBlock ] - whileTrue: [ - | pos chunk | - pos _ changesFile position. - chunk _ changesFile nextChunk. - ((Smalltalk isQuitRecord: chunk) or: [ Smalltalk isSnapshotRecord: chunk ]) - ifTrue: [ positions add: pos ]]. - block = 0 - ifTrue: [done _ true] - ifFalse: [ - prevBlock _ block. - block _ block - 1024 max: 0]]. - ]. - self browseRecentLogOn: origChangesFileName startingFrom: (positions isEmpty ifTrue: [0] ifFalse: [positions last])! ! -!ChangeList class methodsFor: 'public access' stamp: 'jmv 7/31/2018 17:42:47' prior: 50405988! - browseRecentLogOn: origChangesFileName startingFrom: initialPos - "Prompt with a menu of how far back to go when browsing a changes file." - - | end banners positions pos chunk i | - origChangesFileName asFileEntry readStreamDo: [ :changesFile | - banners _ OrderedCollection new. - positions _ OrderedCollection new. - end _ changesFile size. - pos _ initialPos. - [pos = 0 - or: [banners size > 20]] "Go back at most 20 image exits" - whileFalse: [ - changesFile position: pos. - chunk _ changesFile nextChunk. - i _ chunk indexOfSubCollection: 'priorSource: ' startingAt: 1. - i > 0 - ifTrue: [ - positions addLast: pos. - banners addLast: (chunk copyFrom: 5 to: i - 2). - pos _ Number readFrom: (chunk copyFrom: i + 13 to: chunk size)] - ifFalse: [ - pos _ 0]]. - ]. - positions addLast: 0. - banners addLast: 'Whole file'. - pos _ (SelectionMenu labelList: banners selections: positions) - startUpWithCaption: 'Browse as far back as...'. - pos - ifNil: [^ self]. - self browseRecent: end - pos on: origChangesFileName! ! -!ChangeList class methodsFor: 'fileIn/Out' stamp: 'jmv 7/31/2018 17:21:48' prior: 16797019! - serviceRecentChanges - "Answer a service for opening a changelist browser on the tail end of a .changes file" - - ^ SimpleServiceEntry - provider: self - label: 'recent changes in file' - selector: #browseRecentLogOn: - description: 'open a changelist tool on recent changes in file' - buttonLabel: 'recent changes'! ! - -ChangeList class removeSelector: #browseRecentLogOnPath:! - -ChangeList class removeSelector: #browseRecentLogOnPath:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3385-recentLog-Enh-JuanVuletich-2018Jul31-17h21m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3385] on 1 August 2018 at 5:29:52 pm'! - -Object subclass: #FileSystemEntry - instanceVariableNames: 'drive pathComponents parent name creationTime modificationTime primEntryInParent exists lastSync ' - classVariableNames: '' - poolDictionaries: '' - category: 'System-FileMan-Core'! - -!classDefinition: #FileSystemEntry category: #'System-FileMan-Core'! -Object subclass: #FileSystemEntry - instanceVariableNames: 'drive pathComponents parent name creationTime modificationTime primEntryInParent exists lastSync' - classVariableNames: '' - poolDictionaries: '' - category: 'System-FileMan-Core'! -!FileSystemEntry methodsFor: 'accessing' stamp: 'jmv 8/1/2018 16:15:03'! - name: aString parent: parentEntryOrNil - name _ aString. - parentEntryOrNil - ifNil: [ - self pathString: aString ] - ifNotNil: [ - parent _ parentEntryOrNil. - drive _ parentEntryOrNil drive. "harmless if no drive supported, as in Unix" - pathComponents _ parentEntryOrNil pathComponents copyWith: name ]. - self refresh! ! -!FileSystemEntry methodsFor: 'private' stamp: 'jmv 8/1/2018 16:20:13'! - updateFrom: primitiveArray entryInParent: index - primEntryInParent _ index. - lastSync _ DateAndTime now. - exists _ true. - creationTime _ DateAndTime fromSeconds: (primitiveArray at: 2). - modificationTime _ DateAndTime fromSeconds: (primitiveArray at: 3)! ! -!FileSystemEntry methodsFor: 'initialize-release' stamp: 'jmv 8/1/2018 16:12:40'! - pathComponents: tokens drive: driveStringOrNil - | firstToken | - tokens isEmptyOrNil ifTrue: [ ^pathComponents _ nil ]. - (driveStringOrNil isNil and: [ (firstToken _ tokens first) isDriveName]) - ifTrue: [ - self drive: firstToken. - pathComponents _ tokens copyFrom: 2 to: tokens size ] - ifFalse: [ - self drive: driveStringOrNil. - pathComponents _ tokens ]. - - pathComponents ifNotEmpty: [ name _ pathComponents last ]. - self refresh! ! -!FileSystemEntry methodsFor: 'initialize-release' stamp: 'jmv 8/1/2018 16:15:35'! - pathString: aString - | tokens guessedDriveName | -"esto esta detectando el drive si corresponde y despues pasa nil para que se vuelva a detectar. repasar" - tokens _ FileIOAccessor default absolutePathComponentsFor: aString. - tokens ifEmpty: [^ nil]. - self fileAccessor isDriveSupported - ifTrue: [ - guessedDriveName _ tokens first asDriveName. - guessedDriveName ifNotNil: [ -"Yo creo que aca habria que llamar a #pathComponents:drive: y salir...." - self drive: guessedDriveName. - tokens := tokens copyFrom: 2 to: tokens size ]]. - self pathComponents: tokens drive: nil! ! -!FileSystemEntry class methodsFor: 'instance creation' stamp: 'jmv 8/1/2018 16:16:01'! - withPathComponents: comps drive: driveString - "May exist or not" - | instance | - instance _ self new. - instance pathComponents: comps drive: driveString. - ^instance! ! -!FileSystemEntry class methodsFor: 'instance creation' stamp: 'jmv 8/1/2018 16:17:07'! - withPathName: aString - "May exist or not" - | instance | - instance _ self new. - instance pathString: aString. - ^instance! ! -!DirectoryEntry methodsFor: 'private' stamp: 'jmv 8/1/2018 15:46:30'! - updateFrom: primitiveArray entryInParent: index - super updateFrom: primitiveArray entryInParent: index. - children _ nil. "lazy initialization"! ! -!FileEntry methodsFor: 'private' stamp: 'jmv 8/1/2018 10:38:53'! - primEntryInParent - ^ primEntryInParent! ! -!FileEntry methodsFor: 'private' stamp: 'jmv 8/1/2018 16:20:02'! - updateFrom: primitiveArray entryInParent: index - super updateFrom: primitiveArray entryInParent: index. - fileSize _ primitiveArray at: 5! ! -!FileList methodsFor: 'volume list and pattern' stamp: 'jmv 7/31/2018 10:36:52' prior: 16842806! - fileNameFormattedFrom: entry namePad: namePad sizePad: sizePad sizeWithCommasPad: sizeWithCommasPad - "entry is a 5-element array of the form: - (name creationTime modificationTime dirFlag fileSize)" - | sizeStr nameStr paddedNameStr dateStr someSpaces sizeDigits sizeDigitsAndCommas spacesToAdd font spaceWidth | - font _ Preferences standardListFont. - spaceWidth _ font widthOf: $ . - nameStr _ entry isDirectory - ifTrue: [ entry name , self folderString ] - ifFalse: [ entry name ]. - spacesToAdd _ namePad - (font widthOfString: nameStr) // spaceWidth. - paddedNameStr _ nameStr , - (String - new: spacesToAdd - withAll: $ ). - dateStr _ (entry modificationTime date printFormat: #(3 2 1 $/ 1 1 2 )) , ' ' , - (String streamContents: [ :s | - entry modificationTime time - print24: true - showSeconds: true - on: s ]). - sizeDigits _ entry fileSize printString size. - sizeStr _ entry fileSize printStringWithCommas. - sizeDigitsAndCommas _ sizeStr size. - spacesToAdd _ sizeWithCommasPad - sizeDigitsAndCommas. - "Usually a space takes the same space as a comma, and half the space of a digit. - Pad with 2 spaces for each missing digit and 1 space for each missing comma" - (font widthOf: Character space) ~= (font widthOf: $, ) - ifTrue: [spacesToAdd _ spacesToAdd + sizePad - sizeDigits max: 0]. - sizeStr _ (String new: spacesToAdd withAll: $ ) , sizeStr. - someSpaces _ String new: 6 withAll: $ . - sortMode = #name ifTrue: [ ^ paddedNameStr , someSpaces , '( ' , dateStr , someSpaces , sizeStr , ' )' ]. - sortMode = #date ifTrue: [ ^ '( ' , dateStr , someSpaces , sizeStr , ' )' , someSpaces , nameStr ]. - sortMode = #size ifTrue: [ ^ '( ' , sizeStr , someSpaces , dateStr , ' )' , someSpaces , nameStr ]! ! -!String methodsFor: 'fileman-converting' stamp: 'jmv 8/1/2018 16:17:21' prior: 16917503! - asDirectoryEntry - "See examples in #asFileEntry method comment" - ^DirectoryEntry withPathName: self! ! -!String methodsFor: 'fileman-converting' stamp: 'jmv 8/1/2018 16:17:23' prior: 16917538! -asFileEntry - " - -Windows - 'C:\Windows' asFileEntry exists false - 'C:\Windows' asDirectoryEntry exists true - '/' asFileEntry exists false - '/' asDirectoryEntry exists false - 'C:\' asFileEntry exists false - 'C:\' asDirectoryEntry exists true - ('C:' asDirectoryEntry // 'Windows') exists false - ('C:' asDirectoryEntry / 'Windows') exists true - -Linux - '/var' asFileEntry exists - '/var' asDirectoryEntry exists true - '/' asFileEntry exists false - '/' asDirectoryEntry exists true - '/media/cdrom' asFileEntry exists false - '/media/cdrom' asDirectoryEntry exists true - ('/bin' asDirectoryEntry / 'more') exists false - ('/bin' asDirectoryEntry // 'more') exists true - -MacOsX - '/var' asFileEntry exists false - '/var' asDirectoryEntry exists true - '/' asFileEntry exists false - '/' asDirectoryEntry exists true - '/Volumes/SanDisk32-NTFS' asFileEntry exists false - '/Volumes/SanDisk32-NTFS' asDirectoryEntry exists true - 'SanDisk32-NTFS' asFileEntry exists false - 'SanDisk32-NTFS' asDirectoryEntry exists false - - " - self isRelativeMark ifTrue: [ ^self error: 'Maybe you need to call #asDirectoryEntry!!' ]. - ^FileEntry withPathName: self! ! -!FileIOAccessor methodsFor: 'private' stamp: 'jmv 8/1/2018 15:50:23' prior: 16841783! - entriesIn: parentEntryOrNil - " - Warning: Private. Only to be called from within FileMan. - Accepts nil as argument, but behavior depends on platform. - -Windows (nil means root) -FileIOAccessor default entriesIn: nil #(C:\ D:\) -(FileIOAccessor default entriesIn: '' asDirectoryEntry) = (FileIOAccessor default entriesIn: '.' asDirectoryEntry) true -FileIOAccessor default entriesIn: '/' asDirectoryEntry #(\$Recycle.Bin \Config.Msi \Documents and Settings \gratMusic \hiberfil.sys \Intel \pagefile.sys \PerfLogs \Program Files \Program Files (x86) \ProgramData \Python27 \Recovery \SimuloHoy \System Volume Information \totalcmd \Users \Windows) - -Linux (nil means current dir, like '' and '.') -FileIOAccessor default entriesIn: nil #(Lots of stuff in current directory) -(FileIOAccessor default entriesIn: nil) = (FileIOAccessor default entriesIn: '.' asDirectoryEntry) true -(FileIOAccessor default entriesIn: '' asDirectoryEntry) = (FileIOAccessor default entriesIn: '.' asDirectoryEntry) true -FileIOAccessor default entriesIn: '/' asDirectoryEntry #(/vmlinuz /boot /sbin /srv /lib /lib32 /tmp /sys /home /etc /initrd.img /bin /dev /opt /proc /lost+found /var /root /lib64 /mnt /usr /run /media) - -MacOsX (nil means current dir, like '' and '.') -FileIOAccessor default entriesIn: nil #(/Volumes/SanDisk32-NTFS/CuisTest/2554-REVISAR-JuanVuletich-2015Oct21-16h40m-jmv.1.cs.st /Volumes/SanDisk32-NTFS/CuisTest/Cog.app /Volumes/SanDisk32-NTFS/CuisTest/Cog.app.tgz /Volumes/SanDisk32-NTFS/CuisTest/Cuis4.2-2553.changes /Volumes/SanDisk32-NTFS/CuisTest/Cuis4.2-2553.image /Volumes/SanDisk32-NTFS/CuisTest/CuisV4.sources) -(FileIOAccessor default entriesIn: '' asDirectoryEntry) = (FileIOAccessor default entriesIn: '.' asDirectoryEntry) true -FileIOAccessor default entriesIn: '/' asDirectoryEntry #(/.dbfseventsd /.DocumentRevisions-V100 /.DS_Store /.file /.fseventsd /.hotfiles.btree /.Spotlight-V100 /.Trashes /.vol /Applications /bin /cores /dev /etc /home /installer.failurerequests /Library /net /Network /opt /private /sbin /System /tmp /Users /usr /var /Volumes) - - " - | entries index done entryArray entry isDirectory lookIn | - entries _ OrderedCollection new: 200. - index _ 1. - done _ false. - lookIn _ parentEntryOrNil ifNil: [''] ifNotNil: [parentEntryOrNil pathName]. - [done] whileFalse: [ - entryArray _ self primLookupEntryIn: lookIn index: index. - #badDirectoryPath == entryArray ifTrue: [ - ^#()]. - entryArray == nil - ifTrue: [done _ true] - ifFalse: [ - isDirectory _ entryArray at: 4. - entry _ isDirectory ifTrue: [DirectoryEntry new] ifFalse: [FileEntry new]. - entry name: (entryArray at: 1) parent: parentEntryOrNil. - entry updateFrom: entryArray entryInParent: index. - entries addLast: entry ]. - index _ index + 1]. - - ^entries asArray! ! -!FileSystemEntry methodsFor: 'private' stamp: 'jmv 8/1/2018 16:16:21' prior: 16843927! - ensureParent - self pathComponents isEmpty - ifTrue: [^ nil]. - parent _ DirectoryEntry - withPathComponents: (self pathComponents copyFrom: 1 to: self pathComponents size - 1) - drive: self drive. - ^ parent! ! -!FileSystemEntry methodsFor: 'initialize-release' stamp: 'jmv 8/1/2018 09:19:11' prior: 16844018! - refresh - "Assume we know nothing about current state in the File System. - This might be because we're just created. - Or it might be because there is a chance the File System changed and we don't know current state." - lastSync _ nil. - exists _ nil. - creationTime _ nil. - modificationTime _ nil.! ! -!DirectoryEntry methodsFor: 'actions-path' stamp: 'jmv 8/1/2018 16:16:10' prior: 16834409! - concatPathComponentsAsDirectory: components - | entry entryComponents parentEntry | - components ifEmpty: [ ^self ]. - parentEntry := self isRoot ifFalse: [ self ]. - entryComponents := self pathComponents. - - components do: [ :eachComponent | - entryComponents := entryComponents copyWith: eachComponent. - entry := DirectoryEntry withPathComponents: entryComponents drive: self drive. - parentEntry ifNotNil: [ - entry setParent: parentEntry ]. - parentEntry := entry ]. - - ^entry! ! -!DirectoryEntry methodsFor: 'actions-path' stamp: 'jmv 8/1/2018 16:16:14' prior: 16834427! - concatPathComponentsAsFile: components - - | entry entryComponents parentEntry | - components ifEmpty: [ ^self ]. - parentEntry := self isRoot ifFalse: [ self ]. - entryComponents := self pathComponents. - - components allButLast do: [ :eachComponent | - entryComponents := entryComponents copyWith: eachComponent. - entry := DirectoryEntry withPathComponents: entryComponents drive: self drive. - parentEntry ifNotNil: [ - entry setParent: parentEntry ]. - parentEntry := entry ]. - - entryComponents := entryComponents copyWith: components last. - entry := FileEntry withPathComponents: entryComponents drive: self drive. - parentEntry ifNotNil: [ - entry setParent: parentEntry ]. - - ^entry! ! -!DirectoryEntry class methodsFor: 'instance creation' stamp: 'jmv 8/1/2018 16:17:15' prior: 16834792! - currentDirectory - "Answer the current directory. - - In Unix it is the current directory in the OS shell that started us. - In Windows the same happens if the image file is in a subree of the Windows current directory. - - But it defaults to the directory in wich this Smalltalk image was started (or last saved) if this fails - (this usually happens, for example, if the image is dropped on the VM in a Windows explorer). - See #getCurrentWorkingDirectory - - DirectoryEntry currentDirectory - " - - CurrentDirectory ifNil: [ - CurrentDirectory _ self withPathName: (Smalltalk getCurrentWorkingDirectory ifNil: [ Smalltalk imagePath ]) ]. - ^ CurrentDirectory! ! -!DirectoryEntry class methodsFor: 'instance creation' stamp: 'jmv 8/1/2018 16:17:17' prior: 16834830! - smalltalkImageDirectory - "Answer the directory on which this Smalltalk image was started (or last saved) - - DirectoryEntry smalltalkImageDirectory - " - - ImageDirectory ifNil: [ - ImageDirectory _ self withPathName: Smalltalk imagePath ]. - ^ ImageDirectory! ! -!DirectoryEntry class methodsFor: 'instance creation' stamp: 'jmv 8/1/2018 16:17:19' prior: 16834841! - vmDirectory - "Answer the directory containing the VM that runs us. - - DirectoryEntry vmDirectory - " - - VMDirectory ifNil: [ - VMDirectory _ self withPathName: Smalltalk vmPath ]. - ^ VMDirectory! ! -!FileEntry methodsFor: 'initialize-release' stamp: 'jmv 8/1/2018 16:19:41' prior: 16841472! - refresh - super refresh. - fileSize _ nil! ! - -FileSystemEntry class removeSelector: #pathComponents:! - -FileSystemEntry class removeSelector: #pathComponents:! - -FileSystemEntry class removeSelector: #pathComponents:drive:! - -FileSystemEntry class removeSelector: #pathComponents:drive:! - -FileSystemEntry class removeSelector: #pathName:! - -FileSystemEntry class removeSelector: #pathName:! - -FileSystemEntry removeSelector: #basicPathComponents:! - -FileSystemEntry removeSelector: #basicPathComponents:! - -FileSystemEntry removeSelector: #parent:! - -FileSystemEntry removeSelector: #parent:! - -FileSystemEntry removeSelector: #pathComponents:! - -FileSystemEntry removeSelector: #pathComponents:! - -FileSystemEntry removeSelector: #pathComponents:detectDrive:! - -FileSystemEntry removeSelector: #pathComponents:detectDrive:! - -FileSystemEntry removeSelector: #pathName:! - -FileSystemEntry removeSelector: #pathName:! - -Object subclass: #FileSystemEntry - instanceVariableNames: 'drive pathComponents parent name primEntryInParent lastSync exists creationTime modificationTime' - classVariableNames: '' - poolDictionaries: '' - category: 'System-FileMan-Core'! - -!classDefinition: #FileSystemEntry category: #'System-FileMan-Core'! -Object subclass: #FileSystemEntry - instanceVariableNames: 'drive pathComponents parent name primEntryInParent lastSync exists creationTime modificationTime' - classVariableNames: '' - poolDictionaries: '' - category: 'System-FileMan-Core'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3386-FileSystemEntry-refactor-JuanVuletich-2018Aug01-17h27m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3386] on 1 August 2018 at 5:32:47 pm'! -!FileIOAccessor methodsFor: 'private' stamp: 'jmv 8/1/2018 17:11:06'! - updateEntry: aFileSystemEntry - | entryArray index lookIn isDirectory | - - "If the index in aFileSystemEntry is valid, use it. No need to iterate over all entries." - aFileSystemEntry primEntryInParent ifNotNil: [ :tentativeIndex | - (self primLookupEntryIn: aFileSystemEntry parent pathName index: tentativeIndex) ifNotNil: [ :found | - found == #badDirectoryPath ifFalse: [ - aFileSystemEntry name = (found at: 1) ifTrue: [ - aFileSystemEntry updateFrom: found entryInParent: tentativeIndex. - ^ self ]]]]. - - "Otherwise, do a full iteration" - lookIn _ aFileSystemEntry parent pathName. - index _ 1. - [ - entryArray _ self primLookupEntryIn: lookIn index: index. - #badDirectoryPath == entryArray ifTrue: [ - ^ self]. - entryArray == nil ifTrue: [ - ^ self]. - isDirectory _ entryArray at: 4. - aFileSystemEntry name = (entryArray at: 1) ifTrue: [ - isDirectory == aFileSystemEntry isDirectory ifTrue: [ - aFileSystemEntry updateFrom: entryArray entryInParent: index ]. - "If found, exit even if invalid. No point to keep iterating." - ^ self ]. - index _ index + 1] repeat! ! -!FileSystemEntry methodsFor: 'accessing' stamp: 'jmv 8/1/2018 16:56:17'! - exists - self invalidateIfOld. - exists ifNil: [self updateExists]. - ^exists! ! -!FileSystemEntry methodsFor: 'private' stamp: 'jmv 8/1/2018 16:28:04'! - invalidateIfOld - - lastSync isNil ifTrue: [ - ^ self invalidate ]. - (DateAndTime now - lastSync) totalSeconds > 2 ifTrue: [ - self invalidate ]! ! -!FileSystemEntry methodsFor: 'initialize-release' stamp: 'jmv 8/1/2018 16:27:06'! - invalidate - "Assume we know nothing about current state in the File System. - This might be because we're just created. - Or it might be because there is a chance the File System changed and we don't know current state." - lastSync _ nil. - exists _ nil. - creationTime _ nil. - modificationTime _ nil.! ! -!DirectoryEntry methodsFor: 'testing' stamp: 'jmv 8/1/2018 16:55:24'! - updateExists - - | pathName | - (self fileAccessor isDriveSupported and: [self pathComponents isEmpty]) - ifTrue: [^ exists _ self fileAccessor drives includes: self ]. - - self isRoot ifTrue: [ ^ exists _ true ]. - - pathName _ self pathName. - pathName = self fileAccessor slash ifTrue: [ ^ exists _ true ]. - - exists _ self fileAccessor basicDirectoryExists: pathName! ! -!DirectoryEntry methodsFor: 'initialize-release' stamp: 'jmv 8/1/2018 16:31:30'! - invalidate - "Assume we know nothing about current state in the File System. - This might be because we're just created. - Or it might be because there is a chance the File System changed and we don't know current state." - super invalidate. - self invalidateChildren! ! -!DirectoryEntry methodsFor: 'initialize-release' stamp: 'jmv 8/1/2018 16:31:20'! - invalidateChildren - - children _ nil! ! -!FileEntry methodsFor: 'testing' stamp: 'jmv 8/1/2018 16:55:46'! - updateExists - - self fileSize "Updates both"! ! -!FileEntry methodsFor: 'initialize-release' stamp: 'jmv 8/1/2018 16:27:14'! - invalidate - "Assume we know nothing about current state in the File System. - This might be because we're just created. - Or it might be because there is a chance the File System changed and we don't know current state." - super invalidate. - fileSize _ nil! ! -!FileSystemEntry methodsFor: 'accessing' stamp: 'jmv 8/1/2018 17:13:59' prior: 16843857! - creationTime - self invalidateIfOld. - creationTime ifNil: [self fileAccessor updateEntry: self]. - ^creationTime! ! -!FileSystemEntry methodsFor: 'accessing' stamp: 'jmv 8/1/2018 17:01:34' prior: 16843875! - modificationTime - self invalidateIfOld. - modificationTime ifNil: [self fileAccessor updateEntry: self]. - ^modificationTime! ! -!FileSystemEntry methodsFor: 'accessing' stamp: 'jmv 8/1/2018 16:27:50' prior: 50406290! - name: aString parent: parentEntryOrNil - name _ aString. - parentEntryOrNil - ifNil: [ - self pathString: aString ] - ifNotNil: [ - parent _ parentEntryOrNil. - drive _ parentEntryOrNil drive. "harmless if no drive supported, as in Unix" - pathComponents _ parentEntryOrNil pathComponents copyWith: name ]. - self invalidate! ! -!FileSystemEntry methodsFor: 'initialize-release' stamp: 'jmv 8/1/2018 16:27:53' prior: 50406314! - pathComponents: tokens drive: driveStringOrNil - | firstToken | - tokens isEmptyOrNil ifTrue: [ ^pathComponents _ nil ]. - (driveStringOrNil isNil and: [ (firstToken _ tokens first) isDriveName]) - ifTrue: [ - self drive: firstToken. - pathComponents _ tokens copyFrom: 2 to: tokens size ] - ifFalse: [ - self drive: driveStringOrNil. - pathComponents _ tokens ]. - - pathComponents ifNotEmpty: [ name _ pathComponents last ]. - self invalidate! ! -!FileSystemEntry class methodsFor: 'class state access' stamp: 'jmv 8/1/2018 16:28:10' prior: 16844063! - releaseClassCachedState - - self allSubInstancesDo: [ :each | each invalidate]! ! -!DirectoryEntry methodsFor: 'actions-directory' stamp: 'jmv 8/1/2018 16:31:28' prior: 16834541! - delete - self fileAccessor deleteDirectory: self pathName. - self invalidateChildren! ! -!DirectoryEntry methodsFor: 'private' stamp: 'jmv 8/1/2018 16:31:26' prior: 16834573! - basicRecursiveDelete - self invalidateChildren. - self directoriesDo: [:dir | dir basicRecursiveDelete]. - self filesDo: [:file | file delete]. - self delete! ! -!DirectoryEntry methodsFor: 'dictionary-like' stamp: 'jmv 8/1/2018 16:31:24' prior: 16834599! - at: localFileName put: contents - - (self // localFileName) forceWriteStreamDo: [ :stream | - self setContentsOf: stream to: contents ]. - self invalidateChildren. - ^contents! ! -!DirectoryEntry methodsFor: 'dictionary-like' stamp: 'jmv 8/1/2018 16:31:32' prior: 16834639! - removeKey: localFileName ifAbsent: failBlock - self fileAccessor deleteFile: (self // localFileName) pathName ifAbsent: [^failBlock value]. - self invalidateChildren.! ! -!DirectoryEntry methodsFor: 'accessing' stamp: 'jmv 8/1/2018 16:45:23' prior: 16834647! -children - self invalidateIfOld. - children ifNil: [self initChildren]. - ^children! ! -!FileEntry methodsFor: 'actions-file' stamp: 'jmv 8/1/2018 16:27:36' prior: 16841288! - binaryContents: aByteArray - self forceWriteStreamDo: [ :stream | - self setContentsOf: stream binary to: aByteArray ]. - self invalidate! ! -!FileEntry methodsFor: 'actions-file' stamp: 'jmv 8/1/2018 16:27:44' prior: 16841337! - textContents: aString - self forceWriteStreamDo: [ :stream | - self setContentsOf: stream to: aString ]. - self invalidate! ! -!FileEntry methodsFor: 'accessing' stamp: 'jmv 8/1/2018 17:02:21' prior: 16841395! - fileSize - - self invalidateIfOld. - - "Slow version." - "fileSize ifNil: [self fileAccessor updateEntry: self]." - - "Fast version, that asks just for the size of this file. - Used if I was not created by reading a direcotry" - fileSize ifNil: [ - fileSize _ self fileAccessor fileSize: self. - exists _ fileSize notNil ]. - - ^fileSize! ! -!FileEntry methodsFor: 'accessing' stamp: 'jmv 8/1/2018 16:27:47' prior: 16841423! - writeStream - "If the file already exists raise FileExistsException. - Note: You need to eventually close the stream. - Usually prefer #writeStreamDo: that closes the file for you. - Creates the directory if it doesn't exist." - - self invalidate. - self parent exists ifFalse: [self parent assureExistence]. - ^self fileAccessor privateNewFile: self! ! -!FileEntry methodsFor: 'private' stamp: 'jmv 8/1/2018 16:27:41' prior: 16841436! - forceWriteStream - "If the file already exists, delete it first without asking. Do not raise FileExistsException. - Note: You need to eventually close the stream. - Usually prefer #forceWriteStreamDo: that closes the file for you. - Creates the directory if it doesn't exist." - - self invalidate. - self parent exists ifFalse: [self parent assureExistence]. - ^self fileAccessor privateForceNewFile: self! ! - -FileEntry removeSelector: #exists! - -FileEntry removeSelector: #exists! - -FileEntry removeSelector: #fileSize:! - -FileEntry removeSelector: #fileSize:! - -FileEntry removeSelector: #initValuesFrom:! - -FileEntry removeSelector: #initValuesFrom:! - -FileEntry removeSelector: #refresh! - -FileEntry removeSelector: #refresh! - -DirectoryEntry removeSelector: #exists! - -DirectoryEntry removeSelector: #exists! - -DirectoryEntry removeSelector: #refresh! - -DirectoryEntry removeSelector: #refresh! - -DirectoryEntry removeSelector: #refreshChildren! - -DirectoryEntry removeSelector: #refreshChildren! - -FileSystemEntry removeSelector: #creationTime:! - -FileSystemEntry removeSelector: #creationTime:! - -FileSystemEntry removeSelector: #initValuesFrom:! - -FileSystemEntry removeSelector: #initValuesFrom:! - -FileSystemEntry removeSelector: #initValuesFromParent! - -FileSystemEntry removeSelector: #initValuesFromParent! - -FileSystemEntry removeSelector: #modificationTime:! - -FileSystemEntry removeSelector: #modificationTime:! - -FileSystemEntry removeSelector: #refresh! - -FileSystemEntry removeSelector: #refresh! - -FileIOAccessor removeSelector: #fileExists:! - -FileIOAccessor removeSelector: #fileExists:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3387-FileSystemEntry-autosync-JuanVuletich-2018Aug01-17h32m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3387] on 1 August 2018 at 5:51:16 pm'! -!CodePackageFile class methodsFor: 'file list services' stamp: 'jmv 8/1/2018 08:49:06' prior: 50369183! - serviceInstallPackage - "Answer the service of installing a CodePackageFile (a chunk format file for a CodePackage)" - - ^ (SimpleServiceEntry - provider: self - label: 'install package' - selector: #installPackage: - description: 'install the package, replacing all existing code in the package (if any); create a new change set just for the installation' - buttonLabel: 'install package') - sortOrder: 100; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! - -CodePackageFile class removeSelector: #installPackageStream:! - -CodePackageFile class removeSelector: #installPackageStream:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3388-cleanup-JuanVuletich-2018Aug01-17h49m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3386] on 1 August 2018 at 6:36:13 pm'! -!FileSystemEntry methodsFor: 'initialize-release' stamp: 'jmv 8/1/2018 18:34:46' prior: 50406331! - pathString: aString - | tokens | - tokens _ FileIOAccessor default absolutePathComponentsFor: aString. - tokens ifEmpty: [^ nil]. - self fileAccessor isDriveSupported - ifTrue: [ - tokens first asDriveName ifNotNil: [ :guessedDriveName | - ^ self pathComponents: (tokens copyFrom: 2 to: tokens size) drive: guessedDriveName ]]. - self pathComponents: tokens drive: nil! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3389-keepWindowsDrive-JuanVuletich-2018Aug01-18h34m-jmv.1.cs.st----! - -----SNAPSHOT----#(2 August 2018 9:10:25.144328 am) Cuis5.0-3389-32.image priorSource: 2378472! - -----QUIT----#(2 August 2018 9:10:36.153818 am) Cuis5.0-3389-32.image priorSource: 2414073! - -----STARTUP----#(6 August 2018 6:24:10.968571 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3389-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3389] on 2 August 2018 at 4:49:36 pm'! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'HAW 8/2/2018 16:49:19'! - hasReferencesToInstanceVariableNamed: anInstanceVariableName - - "Returns true if only self has one or more methods referencing anInstanceVariableName - Hernan" - - ^(self whichSelectorsAccess: anInstanceVariableName) notEmpty! ! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'HAW 8/2/2018 16:48:53'! - isInstanceVariableNamedReferencedInHierarchy: anInstanceVariableName - - "Returns true if self or any subclass has one or more methods referencing anInstanceVariableName - Hernan" - - ^self withAllSubclasses anySatisfy: [ :aClass | aClass hasReferencesToInstanceVariableNamed: anInstanceVariableName ]! ! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'HAW 8/2/2018 16:03:04' prior: 16784635! - allUnreferencedInstanceVariables - - "Return a list of the instance variables known to the receiver which are not referenced in the receiver or any of its subclasses OR superclasses" - - ^ self allInstVarNames reject: [ :instanceVariableName | | definingClass | - definingClass _ self classThatDefinesInstanceVariable: instanceVariableName. - definingClass isInstanceVariableNamedReferencedInHierarchy: instanceVariableName ]! ! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'HAW 8/2/2018 15:59:42' prior: 16784677! - unreferencedInstanceVariables - "Return a list of the instance variables defined in the receiver which are not referenced in the receiver or any of its subclasses - - Object unreferencedInstanceVariables - " - - ^ self instVarNames reject: [ :instanceVariableName | self isInstanceVariableNamedReferencedInHierarchy: instanceVariableName ] - ! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3390-unreferencedIVars-enh-HernanWilkinson-2018Aug02-10h37m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3389] on 2 August 2018 at 8:36:25 pm'! -!Browser methodsFor: 'class list' stamp: 'HAW 8/2/2018 20:19:45'! -classListIndexOf: aClassNameToFind - - "Answer the index of the aClassName selection." - - aClassNameToFind ifNil: [ ^0 ]. - ^self listClassesHierarchically - ifTrue: [ self classListIndexWhenShowingHierarchicallyOf: aClassNameToFind ] - ifFalse: [ self classList indexOf: aClassNameToFind ] -! ! -!Browser methodsFor: 'class list' stamp: 'HAW 8/2/2018 20:20:58'! - classListIndexWhenShowingHierarchicallyOf: aClassNameToFind - - ^self classList findFirst: [ :showingClassName | showingClassName afterBlanksEndsWith: aClassNameToFind ] -! ! -!Browser methodsFor: 'class list' stamp: 'HAW 8/2/2018 19:37:45'! - createHierarchyTreeOf: col - - "Create a tree from a flat collection of classes" - - | transformed | - - transformed := col collect: [:ea | - | childs indexes | - childs := col select: [:class | class superclass = ea]. - indexes := childs collect: [:child | col indexOf: child]. - ea -> indexes]. - transformed copy do: [:ea | - ea value: (ea value collect: [:idx | - | val | - val := transformed at: idx. - transformed at: idx put: nil. - val])]. - ^ transformed select: [:ea | ea notNil]. -! ! -!Browser methodsFor: 'class list' stamp: 'HAW 8/2/2018 17:51:43'! - defaultClassList - "Answer an array of the class names of the selected category. Answer an - empty array if no selection exists." - - ^selectedSystemCategory - ifNil: [#()] - ifNotNil: [systemOrganizer listAtCategoryNamed: selectedSystemCategory]! ! -!Browser methodsFor: 'class list' stamp: 'HAW 8/2/2018 19:38:01'! - flattenHierarchyTree: classHierarchy on: col indent: indent - - ^ self - flattenHierarchyTree: classHierarchy - on: col - indent: indent - by: ' '.! ! -!Browser methodsFor: 'class list' stamp: 'HAW 8/2/2018 19:38:11'! - flattenHierarchyTree: classHierarchy on: col indent: indent by: indentChars - - "Recursively add to col the names in classHierarchy indenting to show the hierarchical relationship. Use indentChars to do the indenting: spaces, tabs, etc." - - | plusIndent | - - plusIndent := indentChars. - classHierarchy do: [:assoc | - | class childs | - class := assoc key. - col add: indent , class name. - childs := assoc value. - self - flattenHierarchyTree: childs - on: col - indent: indent , plusIndent - by: indentChars]. - ^ col! ! -!Browser methodsFor: 'class list' stamp: 'HAW 8/2/2018 19:38:37'! - hierarchicalClassList - - "classNames are an arbitrary collection of classNames of the system. - Reorder those class names so that they are sorted and indended by inheritance" - - | classes | - - "Creating the hierarchy is *really slow* for the full class list. Skip it for now." - selectedSystemCategory = SystemOrganizer allCategory ifTrue: [^ self defaultClassList]. - classes := self defaultClassList collect: [:sym | Smalltalk classNamed: sym]. - - ^ self - flattenHierarchyTree: (self createHierarchyTreeOf: classes) - on: OrderedCollection new - indent: ''.! ! -!Browser methodsFor: 'class list' stamp: 'HAW 8/2/2018 19:42:13'! - listClassesHierarchically - - ^self class listClassesHierarchically ! ! -!Browser class methodsFor: 'class list' stamp: 'HAW 8/2/2018 20:25:05'! - disableListClassesHierarchically - - ^Preferences disable: #listClassesHierarchically ! ! -!Browser class methodsFor: 'class list' stamp: 'HAW 8/2/2018 20:24:55'! - enableListClassesHierarchically - - ^Preferences enable: #listClassesHierarchically ! ! -!Browser class methodsFor: 'class list' stamp: 'HAW 8/2/2018 19:21:34'! - listClassesHierarchically - - ^Preferences listClassesHierarchically ! ! -!String methodsFor: 'converting' stamp: 'HAW 8/2/2018 20:19:09'! - afterBlanksEndsWith: aTail - - ^(self endsWith: aTail) and: [self size = aTail size or: [ (self at: self size - aTail size) isSeparator]] - - ! ! -!String methodsFor: 'converting' stamp: 'HAW 8/2/2018 19:11:17'! - withoutLeadingBlanks - - "Return a copy of the receiver from which leading blanks have been trimmed." - - | first | - - first := self findFirst: [:c | c isSeparator not ]. - first = 0 ifTrue: [^ '']. - first = 1 ifTrue: [^ self ]. - - "no non-separator character" - ^ self copyFrom: first to: self size - - " ' abc d ' withoutLeadingBlanks" -! ! -!Preferences class methodsFor: 'standard queries'! - listClassesHierarchically - ^ self - valueOfFlag: #listClassesHierarchically - ifAbsent: [ true ].! ! -!Browser methodsFor: 'class list' stamp: 'HAW 8/2/2018 19:42:28' prior: 16791804! - classList - - ^ self listClassesHierarchically - ifTrue: [self hierarchicalClassList] - ifFalse: [self defaultClassList].! ! -!Browser methodsFor: 'class list' stamp: 'HAW 8/2/2018 19:42:49' prior: 16791814! - classListIndex - "Answer the index of the current class selection." - - ^self classListIndexOf: selectedClassName ! ! -!Browser methodsFor: 'class list' stamp: 'HAW 8/2/2018 19:35:07' prior: 50390438! - classListIndex: anInteger - "Set anInteger to be the index of the current class selection." - - | className recent canSelectClass classList | - - classList _ self classList. - canSelectClass _ classList isInBounds: anInteger. - selectedClassName _ canSelectClass ifTrue: [ | newClassName | - newClassName := classList at: anInteger ifAbsent: [ nil ]. - newClassName := newClassName ifNotNil: [newClassName withoutLeadingBlanks asSymbol]. - newClassName ]. - self setClassOrganizer. - selectedMessageCategory _ nil. - selectedMessage _ nil. - - self classCommentIndicated ifFalse: [ - self editSelection: (canSelectClass - ifTrue: [#editClass] - ifFalse: [ metaClassIndicated | selectedSystemCategory isNil - ifTrue: [#none] - ifFalse: [#newClass]])]. - - self selectedClass ifNotNil: [ - recent _ self class recentClasses. - className _ self selectedClass name. - (recent includes: className) ifTrue: [recent remove: className]. - recent addFirst: className. - recent size > 16 ifTrue: [recent removeLast]]. - - "We have to refresh the class list if somebody wants to select a class that does not exist anymore - Hernan" - anInteger > classList size ifTrue: [ self changed: #classList ]. - self changed: #classSelectionChanged. - self changed: #classCommentText. - self changed: #classListIndex. "update my selection" - self changed: #messageCategoryList. - self changed: #messageList. - self changed: #relabel. - self acceptedContentsChanged! ! -!Browser methodsFor: 'class list' stamp: 'HAW 8/2/2018 19:44:06' prior: 16791874! - selectClass: classNotMeta - - self classListIndex: (self classListIndexOf: classNotMeta name)! ! -!Browser methodsFor: 'class list' stamp: 'HAW 8/2/2018 19:45:38' prior: 16791888! - selectedClassName - "Answer the name of the current class. Answer nil if no selection exists." - - ^selectedClassName - ! ! -!Browser methodsFor: 'metaclass' stamp: 'HAW 8/2/2018 19:45:57' prior: 16792546! - setClassOrganizer - - "Install whatever organization is appropriate" - - | theClass | - - classOrganizer _ nil. - metaClassOrganizer _ nil. - selectedClassName ifNil: [^ self]. - theClass := self selectedClass ifNil: [ ^self ]. - classOrganizer _ theClass organization. - metaClassOrganizer _ theClass class organization.! ! -!HierarchyBrowser methodsFor: 'initialization' stamp: 'HAW 8/2/2018 20:06:54' prior: 50390560! - classListIndex: newIndex - - "Cause system organization to reflect appropriate category" - - | newClassName ind i | - - (classList isInBounds: newIndex) ifTrue: [ - newClassName _ (classList at: newIndex) withoutLeadingBlanks. - i _ systemOrganizer numberOfCategoryOfElement: newClassName. - selectedSystemCategory _ i = 0 ifFalse: [ self systemCategoryList at: i]]. - ind _ super classListIndex: newIndex. - self changed: #systemCategorySingleton. - ^ ind! ! -!HierarchyBrowser methodsFor: 'initialization' stamp: 'HAW 8/2/2018 20:07:42' prior: 16853583! - potentialClassNames - - "Answer the names of all the classes that could be viewed in this browser" - - ^ self classList collect: [:aName | aName withoutLeadingBlanks ]! ! -!HierarchyBrowser methodsFor: 'initialization' stamp: 'HAW 8/2/2018 20:21:08' prior: 16853590! - selectClass: classNotMeta - - self classListIndex: (self classListIndexWhenShowingHierarchicallyOf: classNotMeta name)! ! -!HierarchyBrowser methodsFor: 'initialization' stamp: 'HAW 8/2/2018 20:10:24' prior: 16853600! - selectedClassName - "Answer the name of the class currently selected. di - bug fix for the case where name cannot be found -- return nil rather than halt" - - | aName | - - aName _ super selectedClassName. - ^ aName ifNotNil: [aName withoutLeadingBlanks asSymbol]! ! -!HierarchyBrowser methodsFor: 'class list' stamp: 'HAW 8/2/2018 20:06:27' prior: 16853658! - classList - - classList _ classList select: [:each | Smalltalk includesKey: each withoutLeadingBlanks asSymbol]. - ^ classList! ! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'HAW 8/2/2018 19:17:40' prior: 16906552! - findFirst: aBlock - "Return the index of my first element for which aBlock evaluates as true." - - | index currentSize | - - index _ 0. - currentSize _ self size. - - [(index _ index + 1) <= currentSize ] whileTrue: - [(aBlock value: (self at: index)) ifTrue: [^index]]. - - ^ 0! ! -!String methodsFor: 'converting' stamp: 'HAW 8/2/2018 19:17:01' prior: 16917010! - 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" - last = self size ifTrue: [ ^self ]. - - ^ self copyFrom: 1 to: last - - " ' abc d ' withoutTrailingBlanks" -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3391-BrowserListsHierarchically-HernanWilkinson-2018Aug02-16h49m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3389] on 3 August 2018 at 11:18:15 am'! -!String methodsFor: 'converting' stamp: 'HAW 8/3/2018 11:12:15'! - firstNoBlankIndex - - ^self findFirst: [:aChar | aChar isSeparator not ]! ! -!String methodsFor: 'converting' stamp: 'HAW 8/3/2018 11:12:25'! - lastNoBlankIndex - - ^ self findLast: [:aChar | aChar isSeparator not]. - ! ! -!String methodsFor: 'converting' stamp: 'HAW 8/3/2018 10:57:30' prior: 50407278! - afterBlanksEndsWith: aTail - - ^(self endsWith: aTail) and: [ self firstNoBlankIndex = (self size - aTail size + 1) ] -! ! -!String methodsFor: 'converting' stamp: 'HAW 8/3/2018 11:13:24' prior: 16916886! - withBlanksTrimmed - "Return a copy of the receiver from which leading and trailing blanks have been trimmed." - - | first | - - first _ self firstNoBlankIndex. - first = 0 ifTrue: [^ '']. "no non-separator character" - - ^ self copyFrom: first to: self lastNoBlankIndex - - " ' abc d ' withBlanksTrimmed" -! ! -!String methodsFor: 'converting' stamp: 'HAW 8/3/2018 11:02:05' prior: 50407285! - withoutLeadingBlanks - - "Return a copy of the receiver from which leading blanks have been trimmed." - - | first | - - first := self firstNoBlankIndex. - first = 0 ifTrue: [^ '']. - first = 1 ifTrue: [^ self ]. - - "no non-separator character" - ^ self copyFrom: first to: self size - - " ' abc d ' withoutLeadingBlanks" -! ! -!String methodsFor: 'converting' stamp: 'HAW 8/3/2018 11:08:59' prior: 50407458! - withoutTrailingBlanks - "Return a copy of the receiver from which trailing blanks have been trimmed." - - | last | - - last _ self lastNoBlankIndex. - last = 0 ifTrue: [^ '']. "no non-separator character" - last = self size ifTrue: [ ^self ]. - - ^ self copyFrom: 1 to: last - - " ' abc d ' withoutTrailingBlanks" -! ! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'HAW 8/3/2018 11:05:15' prior: 50405796! - logChange: aStringOrText preamble: preambleOrNil - "Write the argument, aString, onto the changes file." - | aString changesFile | - self assureStartupStampLogged. - aString _ aStringOrText asString. - aString firstNoBlankIndex = 0 ifTrue: [^ self]. "null doits confuse replay" - - (SourceFiles notNil and: [(changesFile _ SourceFiles at: 2) notNil]) ifTrue: [ - changesFile isReadOnly ifFalse: [ - changesFile setToEnd; newLine; newLine. - preambleOrNil ifNotNil: [ - changesFile nextPut: $!!; nextChunkPut: preambleOrNil; newLine ]. - changesFile nextChunkPut: aString. - "If want style changes in DoIt, use nextChunkPutWithStyle:, and allow Texts to get here" - self forceChangesToDisk ]]. - Utilities logsUserChanges ifTrue: [ - Smalltalk defaultUserChangesName asFileEntry appendStreamDo: [ :stream | - stream newLine; newLine. - preambleOrNil ifNotNil: [ - stream nextPut: $!!; nextChunkPut: preambleOrNil; newLine ]. - stream nextChunkPut: aString ]]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3392-String-cleanup-HernanWilkinson-2018Aug02-20h36m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3389] on 3 August 2018 at 11:45:47 am'! -!Browser methodsFor: 'class list' stamp: 'HAW 8/3/2018 11:45:20' prior: 50407372! - selectedClassName - "Answer the name of the current class. Answer nil if no selection exists." - - ^selectedClassName ifNotNil: [ - "I send #defaultClassList and no #classList because when showing classes hierarchically we should remove spaces to see - if class name is in the list and that consumes more time - Hernan" - (self defaultClassList includes: selectedClassName) ifTrue: [ selectedClassName ]]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3393-Browser-recent-bug-fix-HernanWilkinson-2018Aug03-11h18m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3389] on 3 August 2018 at 2:54:59 pm'! - -CodeProvider subclass: #Browser - instanceVariableNames: 'systemOrganizer classOrganizer metaClassOrganizer selectedSystemCategory selectedClassName selectedMessageCategory selectedMessage editSelection metaClassIndicated listClassesHierarchically ' - classVariableNames: 'RecentClasses ' - poolDictionaries: '' - category: 'Tools-Browser'! - -!classDefinition: #Browser category: #'Tools-Browser'! -CodeProvider subclass: #Browser - instanceVariableNames: 'systemOrganizer classOrganizer metaClassOrganizer selectedSystemCategory selectedClassName selectedMessageCategory selectedMessage editSelection metaClassIndicated listClassesHierarchically' - classVariableNames: 'RecentClasses' - poolDictionaries: '' - category: 'Tools-Browser'! -!Browser methodsFor: 'class list' stamp: 'HAW 8/3/2018 12:29:41'! - enableListClassesAlphabetically - - self listClassesHierarchically: false! ! -!Browser methodsFor: 'class list' stamp: 'HAW 8/3/2018 12:29:30'! - enableListClassesHierarchically - - self listClassesHierarchically: true! ! -!Browser methodsFor: 'class list' stamp: 'HAW 8/3/2018 14:49:36'! - listClassesHierarchically: aBoolean - - listClassesHierarchically := aBoolean. - - self changed: #classList. - self changed: #classListIndex. -! ! -!Browser methodsFor: 'initialization' stamp: 'HAW 8/3/2018 14:51:55'! - initialize - - super initialize. - self initializeListClassesHierachically! ! -!Browser methodsFor: 'initialization' stamp: 'HAW 8/3/2018 14:51:47'! - initializeListClassesHierachically - - listClassesHierarchically _ self class listClassesHierarchically ! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'HAW 8/3/2018 11:59:30'! - createClassButton - - | classSwitch | - - classSwitch := PluggableButtonMorph - model: model - stateGetter: #classMessagesIndicated - action: #indicateClassMessages. - - classSwitch - label: 'class'; - setBalloonText: 'show class methods'. - - ^classSwitch! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'HAW 8/3/2018 11:59:41'! - createCommentButton - - | commentSwitch | - - commentSwitch := PluggableButtonMorph - model: model - stateGetter: #classCommentIndicated - action: #plusButtonHit. - - commentSwitch - label: '?'; - setBalloonText: 'show class comment'. - - ^commentSwitch ! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'HAW 8/3/2018 11:59:22'! - createInstanceButton - - | instanceSwitch | - - instanceSwitch := PluggableButtonMorph - model: model - stateGetter: #instanceMessagesIndicated - action: #indicateInstanceMessages. - - instanceSwitch - label: 'instance'; - setBalloonText: 'show instance methods'. - - ^instanceSwitch ! ! -!Browser methodsFor: 'class list' stamp: 'HAW 8/3/2018 14:52:35' prior: 50407257! - listClassesHierarchically - - "I check for nil to support migration on already opened browser when the change is loaded in image - Hernan" - ^listClassesHierarchically ifNil: [ self initializeListClassesHierachically]! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'HAW 8/3/2018 14:54:25' prior: 16793097! - buildMorphicSwitches - - | instanceSwitch commentSwitch classSwitch row buttonColor | - - instanceSwitch _ self createInstanceButton. - commentSwitch _ self createCommentButton. - classSwitch _ self createClassButton. - - row _ LayoutMorph newRow. - row - doAdoptWidgetsColor; - addMorph: instanceSwitch proportionalWidth: 0.45; - addMorph: commentSwitch proportionalWidth: 0.22; - addMorph: classSwitch proportionalWidth: 0.33. - buttonColor _ self buttonColor. - row color: buttonColor. - - { - instanceSwitch. - commentSwitch. - classSwitch} do: [:m | m color: buttonColor ]. - - ^row! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 8/3/2018 14:47:08' prior: 50403120! - classListMenuOptions - - ^ `{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutClass. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 5. - #label -> 'show classes hierarchically'. - #object -> #model. - #selector -> #enableListClassesHierarchically. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 6. - #label -> 'show classes alphabetically'. - #object -> #model. - #selector -> #enableListClassesAlphabetically. - #icon -> #sendReceiveIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'show hierarchy'. - #object -> #model. - #selector -> #hierarchy. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'show definition'. - #object -> #model. - #selector -> #editClass. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'show comment'. - #object -> #model. - #selector -> #editComment. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'inst var refs...'. - #selector -> #browseInstVarRefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'inst var defs...'. - #selector -> #browseInstVarDefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'class var refs...'. - #selector -> #browseClassVarRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 20. - #label -> 'class vars'. - #selector -> #browseClassVariables. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'class refs (N)'. - #selector -> #browseClassRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'rename class ...'. - #object -> #model. - #selector -> #renameClass. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 20. - #label -> 'copy class...'. - #object -> #model. - #selector -> #copyClass. - #icon -> #copyIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 30. - #label -> 'remove class (x)'. - #object -> #model. - #selector -> #removeClass. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 10. - #label -> 'run tests (t)'. - #object -> #model. - #selector -> #runClassTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 20. - #label -> 'more...'. - #selector -> #offerClassListMenu2. - #icon -> #listAddIcon - } asDictionary. - }`. - ! ! - -HierarchyBrowserWindow removeSelector: #buildMorphicSwitches! - -BrowserWindow removeSelector: #createListClassesAlphabetically! - -BrowserWindow removeSelector: #createListClassesAlphabeticallyButton! - -BrowserWindow removeSelector: #createListClassesHierarchically! - -BrowserWindow removeSelector: #createListClassesHierarchicallyButton! - -Browser removeSelector: #listClassesAlphabetically! - -CodeProvider subclass: #Browser - instanceVariableNames: 'systemOrganizer classOrganizer metaClassOrganizer selectedSystemCategory selectedClassName selectedMessageCategory selectedMessage editSelection metaClassIndicated listClassesHierarchically' - classVariableNames: 'RecentClasses' - poolDictionaries: '' - category: 'Tools-Browser'! - -!classDefinition: #Browser category: #'Tools-Browser'! -CodeProvider subclass: #Browser - instanceVariableNames: 'systemOrganizer classOrganizer metaClassOrganizer selectedSystemCategory selectedClassName selectedMessageCategory selectedMessage editSelection metaClassIndicated listClassesHierarchically' - classVariableNames: 'RecentClasses' - poolDictionaries: '' - category: 'Tools-Browser'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3394-BrowserShowHierarchically-perBrowserOption-HernanWilkinson-2018Aug03-11h45m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3394] on 4 August 2018 at 2:48:52 pm'! -!Browser methodsFor: 'class list' stamp: 'jmv 8/4/2018 14:48:21' prior: 50407163! - classListIndexOf: aClassNameToFind - - "Answer the index of the aClassName selection." - - aClassNameToFind ifNil: [ ^0 ]. - ^self classList findFirst: [ :showingClassName | - "Works regardless of currently showing hierarchically or alphabetically." - showingClassName afterBlanksEndsWith: aClassNameToFind ]! ! -!HierarchyBrowser methodsFor: 'initialization' stamp: 'jmv 8/4/2018 14:48:30' prior: 50407419! - selectClass: classNotMeta - - self classListIndex: (self classListIndexOf: classNotMeta name)! ! - -Browser removeSelector: #classListIndexWhenShowingHierarchicallyOf:! - -Browser removeSelector: #classListIndexWhenShowingHierarchicallyOf:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3395-SlightSimplification-JuanVuletich-2018Aug04-14h48m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3395] on 4 August 2018 at 3:59:49 pm'! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph drawingMorphStack ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph drawingMorphStack' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 8/4/2018 15:46:00' prior: 16877545! - into: aMorph - | location previousLast | - location _ aMorph location. - drawingMorphStack ifNil: [ drawingMorphStack _ transformations collect: [ :t | nil ]]. - drawingMorphStack size = transformations size ifFalse: [ drawingMorphStack _ transformations collect: [ :t | nil ]]. - currentMorph _ aMorph. - cti _ cti + 1. - transformations size < cti - ifTrue: [ - drawingMorphStack add: aMorph. - currentTransformation _ currentTransformation composedWith: location. - transformations add: currentTransformation ] - ifFalse: [ - drawingMorphStack at: cti put: aMorph. - previousLast _ currentTransformation. - currentTransformation _ transformations at: cti. - "reuse the instance if possible" - (previousLast class == location class and: [ previousLast class == currentTransformation class ]) - ifTrue: [ - previousLast composedWith: location into: currentTransformation ] - ifFalse: [ - currentTransformation _ previousLast composedWith: location. - transformations at: cti put: currentTransformation ]]! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 8/4/2018 15:58:56' prior: 16877580! - outOfMorph - - drawingMorphStack at: cti put: nil. "Don't hold any morphs that could be collected" - cti _ cti - 1. - currentTransformation _ transformations at: cti. -" currentMorph _ drawingMorphStack at: cti" - currentMorph _ currentMorph owner! ! -!MorphicCanvas methodsFor: 'initialization' stamp: 'jmv 8/4/2018 15:37:46' prior: 16877585! - initializeWith: aForm origin: aPoint - self initialize. - self setForm: aForm. - - "We currently set up these only on initialization. - This is safe (wrt walkbacks during world redraw) because a new instance is created - each time the world is redrawn. See #drawInvalidAreasWorld:submorphs: - Maybe this cleanup should be in an aux method that can be called each time on an existing instance..." - currentTransformation _ MorphicTranslation withTranslation: aPoint. - cti _ 1. - transformations - ifNil: [ transformations _ OrderedCollection with: currentTransformation ] - ifNotNil: [ transformations at: cti put: currentTransformation ]. - drawingMorphStack - ifNil: [ drawingMorphStack _ OrderedCollection with: nil ] - ifNotNil: [ drawingMorphStack at: cti put: nil ].! ! - -MorphicCanvas removeSelector: #intoLocation:! - -MorphicCanvas removeSelector: #intoLocation:! - -MorphicCanvas removeSelector: #outOfLocation! - -MorphicCanvas removeSelector: #outOfLocation! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph drawingMorphStack' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph drawingMorphStack' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -MorphicCanvas allSubInstancesDo: [ :each | each instVarNamed: 'drawingMorphStack' put: ((each instVarNamed: 'transformations') collect: [ :t | nil])].! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3396-MoreRobustCanvas-JuanVuletich-2018Aug04-15h58m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3395] on 4 August 2018 at 4:01:01 pm'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 8/4/2018 16:00:30' prior: 50407926! - into: aMorph - | location previousLast | - location _ aMorph location. - currentMorph _ aMorph. - cti _ cti + 1. - transformations size < cti - ifTrue: [ - drawingMorphStack add: aMorph. - currentTransformation _ currentTransformation composedWith: location. - transformations add: currentTransformation ] - ifFalse: [ - drawingMorphStack at: cti put: aMorph. - previousLast _ currentTransformation. - currentTransformation _ transformations at: cti. - "reuse the instance if possible" - (previousLast class == location class and: [ previousLast class == currentTransformation class ]) - ifTrue: [ - previousLast composedWith: location into: currentTransformation ] - ifFalse: [ - currentTransformation _ previousLast composedWith: location. - transformations at: cti put: currentTransformation ]]! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 8/4/2018 16:00:39' prior: 50407961! - outOfMorph - - drawingMorphStack at: cti put: nil. "Don't hold any morphs that could be collected" - cti _ cti - 1. - currentTransformation _ transformations at: cti. - currentMorph _ drawingMorphStack at: cti! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3397-MoreRobustCanvas-JuanVuletich-2018Aug04-15h59m-jmv.1.cs.st----! - -----SNAPSHOT----#(6 August 2018 6:24:16.578232 pm) Cuis5.0-3397-32.image priorSource: 2414169! - -----QUIT----#(6 August 2018 6:24:27.83461 pm) Cuis5.0-3397-32.image priorSource: 2445912! - -----STARTUP----#(9 August 2018 6:34:29.823338 pm) as /home/juan/Rectifier/Cuis-Smalltalk-Dev/Cuis5.0-3397-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3397] on 9 August 2018 at 10:46:43 am'! -!DirectoryEntry methodsFor: 'enumeration' stamp: 'jmv 8/9/2018 10:41:27' prior: 16834451! -allChildrenDo: aBlock - self childrenDo: [ :child | - aBlock value: child ]. - self allDirectoriesDo: [ :child | - child allChildrenDo: aBlock]! ! -!FeatureRequirement methodsFor: 'private' stamp: 'jmv 8/9/2018 10:45:45' prior: 50405934! - withPackageSubfoldersOf: aDirectoryEntry do: aBlock - - "Look in the requested directory" - aBlock value: aDirectoryEntry. - - "Look in ./Packages/ and subfolders" - aDirectoryEntry / 'Packages' ifExists: [ :packagesFolder | - aBlock value: packagesFolder. - packagesFolder allDirectoriesDo: aBlock ]! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3398-PackageFolderReorganization-JuanVuletich-2018Aug09-09h22m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3398] on 9 August 2018 at 11:45:19 am'! - -GeometryTransformation variableWordSubclass: #AffineTransformation - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -!classDefinition: #AffineTransformation category: #'Graphics-Primitives'! -GeometryTransformation variableWordSubclass: #AffineTransformation - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -GeometryTransformation variableWordSubclass: #Homography - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -!classDefinition: #Homography category: #'Graphics-Primitives'! -GeometryTransformation variableWordSubclass: #Homography - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Primitives'! -!Homography commentStamp: '' prior: 0! - An homography (or perspective transformation) for resampling images (for example). Can apply or correct for the perspective resulting from taking a photograph to a 2D object that is not perpendicular to the camera axis (for example, taking an image of the ground ahead of the camera). - -http://docs.opencv.org/modules/imgproc/doc/geometric_transformations.html#warpperspective - -To be of use, needs #map:to: in NumCuis/ImageProcessing.pck.st! - -GeometryTransformation subclass: #MorphicTranslation - instanceVariableNames: 'deltaX deltaY ' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -!classDefinition: #MorphicTranslation category: #'Graphics-Primitives'! -GeometryTransformation subclass: #MorphicTranslation - instanceVariableNames: 'deltaX deltaY' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Primitives'! -!Morph commentStamp: '' prior: 16873905! - A Morph (from the Greek "shape" or "form") is an interactive graphical object. General information on the Morphic system can be found at http://wiki.squeak.org/squeak/morph. - -Morphs exist in a tree, rooted at a World (generally a PasteUpMorph). The morphs owned by a morph are its submorphs. Morphs are drawn recursively; if a Morph has no owner it never gets drawn. To hide a Morph and its submorphs, set its #visible property to false using the #visible: method. - -Structure: -instance var Type Description -owner Morph My parent Morph, or nil for the top-level Morph, which is a - or nil world, typically a PasteUpMorph. -submorphs Array My child Morphs. -location MorphicTranslation Specifies position (and possibly, angle of rotation and scale change) inside owner - or AffineTransformation -extension MorphExtension Allows extra properties to be stored without adding a - or nil storage burden to all morphs. -! -!GeometryTransformation methodsFor: 'testing' stamp: 'jmv 8/9/2018 11:25:47'! - is: aSymbol - ^aSymbol == #GeometryTransformation or: [ super is: aSymbol ]! ! -!GeometryTransformation methodsFor: 'testing' stamp: 'jmv 8/9/2018 11:27:48'! - isPureTranslation - "Return true if the receiver specifies no rotation or scaling." - ^false! ! -!Homography methodsFor: 'element access' stamp: 'jmv 8/9/2018 11:22:18'! - a0 - ^self at: 1! ! -!Homography methodsFor: 'element access' stamp: 'jmv 8/9/2018 11:22:18'! - a1 - ^self at: 2! ! -!Homography methodsFor: 'element access' stamp: 'jmv 8/9/2018 11:22:18'! - a2 - ^self at: 3! ! -!Homography methodsFor: 'element access' stamp: 'jmv 8/9/2018 11:22:18'! - b0 - ^self at: 4! ! -!Homography methodsFor: 'element access' stamp: 'jmv 8/9/2018 11:22:18'! - b1 - ^self at: 5! ! -!Homography methodsFor: 'element access' stamp: 'jmv 8/9/2018 11:22:18'! - b2 - ^self at: 6! ! -!Homography methodsFor: 'element access' stamp: 'jmv 8/9/2018 11:22:18'! - c0 - ^self at: 7! ! -!Homography methodsFor: 'element access' stamp: 'jmv 8/9/2018 11:22:18'! - c1 - ^self at: 8! ! -!Homography methodsFor: 'private access' stamp: 'jmv 8/9/2018 11:22:18'! - at: index - - ^Float fromIEEE32Bit: (self basicAt: index)! ! -!Homography methodsFor: 'private access' stamp: 'jmv 8/9/2018 11:22:18'! - at: index put: value - - value isFloat - ifTrue:[self basicAt: index put: value asIEEE32BitWord] - ifFalse:[self at: index put: value asFloat]. - ^value! ! -!Homography methodsFor: 'converting coordinates' stamp: 'jmv 8/9/2018 11:22:18'! - map: aPoint - | xx yy zz | - xx _ (self a0 * aPoint x) + (self a1 * aPoint y) + self a2. - yy _ (self b0 * aPoint x) + (self b1 * aPoint y) + self b2. - zz _ (self c0 * aPoint x) + (self c1 * aPoint y) + 1. - ^(xx / zz) @ (yy / zz)! ! -!Homography class methodsFor: 'instance creation' stamp: 'jmv 8/9/2018 11:22:18'! - new - ^(self basicNew: 8) initialize! ! -!Homography class methodsFor: 'instance creation' stamp: 'jmv 8/9/2018 11:23:34'! - new: s - self error: 'Please call Homography>>#new (without arguments).'. - ^self new! ! -!MorphicTranslation methodsFor: 'comparing' stamp: 'jmv 8/9/2018 11:26:07' prior: 16878311! - = aMorphicTranslation - self == aMorphicTranslation ifTrue: [ ^ true ]. - (aMorphicTranslation is: #GeometryTransformation) ifFalse: [ ^false ]. - aMorphicTranslation isPureTranslation ifFalse: [ ^false ]. - ^self translation = aMorphicTranslation translation! ! - -Homography class removeSelector: #map:to:! - -GeometryTransformation subclass: #MorphicTranslation - instanceVariableNames: 'deltaX deltaY' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -!classDefinition: #MorphicTranslation category: #'Graphics-Primitives'! -GeometryTransformation subclass: #MorphicTranslation - instanceVariableNames: 'deltaX deltaY' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -Smalltalk removeClassNamed: #MorphicLocation! - -Smalltalk removeClassNamed: #MorphicLocation! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3399-GeometryTransformation-refactor-JuanVuletich-2018Aug09-11h38m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3399] on 9 August 2018 at 1:17:11 pm'! -!Form methodsFor: 'pixel access' stamp: 'jmv 8/8/2018 14:17:49'! - i: i j: j - "Compatibility with Matrices" - ^ self colorAt: j@i -1! ! -!Form methodsFor: 'pixel access' stamp: 'jmv 8/8/2018 14:18:01'! - i: i j: j put: aColor - "Compatibility with Matrices" - ^ self colorAt: j@i -1 put: aColor! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3400-Form-MatrixCompatibleElementAccess-JuanVuletich-2018Aug09-12h40m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3400] on 9 August 2018 at 6:13:10 pm'! -!Form methodsFor: 'displaying' stamp: 'jmv 8/9/2018 16:23:10'! - displayAutoRangeAt: aPoint - "Display receiver, mapping used range to available gray levels" - - ^ self displayAutoRangeAt: aPoint zoom: 1! ! -!Form methodsFor: 'displaying' stamp: 'jmv 8/9/2018 16:22:37'! - displayAutoRangeAt: aPoint zoom: scale - "Display receiver, compatibility with Matrix and subclasses such as FloatImage" - - | form | - form _ self. - scale = 1 ifFalse: [ - form _ form magnifyBy: scale ]. - form displayAt: aPoint. - ^ form! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3401-Form-MatrixCompatibleDisplay-JuanVuletich-2018Aug09-16h22m-jmv.1.cs.st----! - -----SNAPSHOT----#(9 August 2018 6:34:36.53956 pm) Cuis5.0-3401-32.image priorSource: 2446008! - -----QUIT----#(9 August 2018 6:34:49.303719 pm) Cuis5.0-3401-32.image priorSource: 2454692! - -----STARTUP----#(15 August 2018 3:58:28.981525 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3401-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3401] on 10 August 2018 at 11:07:42 am'! -!SinglePackageBrowser methodsFor: 'lists' stamp: 'jmv 8/10/2018 11:05:40'! - defaultClassList - "Answer an array of the class names of the selected category. Answer an - empty array if no selection exists." - | answer | - answer _ selectedSystemCategory - ifNil: [#()] - ifNotNil: [ - (package includesSystemCategory: selectedSystemCategory) - ifTrue: [ systemOrganizer listAtCategoryNamed: selectedSystemCategory ] - ifFalse: [ - package extensionClassNamesIn: (selectedSystemCategory copyFrom: 2 to: selectedSystemCategory size) ]]. - selectedClassName ifNil: [ - answer size = 0 ifFalse: [ - selectedClassName _ answer first. - self setClassOrganizer. - self editSelection: #editClass ]]. - ^answer! ! - -SinglePackageBrowser removeSelector: #classList! - -SinglePackageBrowser removeSelector: #classList! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3402-PackageBrowser-fix-JuanVuletich-2018Aug10-11h05m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3402] on 10 August 2018 at 4:45:43 pm'! -!Form methodsFor: 'converting' stamp: 'jmv 8/10/2018 15:19:49'! - asFormAutoRange - "In optional packages (LinearAlgebra, ImageProcessing) we might have #asFormAutoRange - conversion methods for other kinds of objects." - ^self! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3403-asFormAutoRange-JuanVuletich-2018Aug10-15h19m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3403] on 12 August 2018 at 11:35:10 pm'! -!CompiledMethod methodsFor: 'comparing' stamp: 'jmv 8/12/2018 23:31:38' prior: 50334686! - = method - | numLits lit1 lit2 firstLitIndex | - - "Any object is equal to itself" - self == method ifTrue: [ ^ true ]. - - "Answer whether the receiver implements the same code as the - argument, method." - (method is: #CompiledMethod) ifFalse: [ ^false ]. - self size = method size ifFalse: [ ^false ]. - self header = method header ifFalse: [ ^false ]. - self initialPC to: self endPC do: [ :i | - (self at: i) = (method at: i) ifFalse: [ ^false ]]. - (numLits _ self numLiterals) ~= method numLiterals ifTrue: [ ^false ]. - - "Dont bother checking FFI and named primitives'' - jmv: Does this make any sense? - (#(117 120) includes: self primitive) ifTrue: [^ true]." - - "properties" - (self properties analogousCodeTo: method properties) ifFalse: [ - ^false ]. - - firstLitIndex _ 1. - (#(117 120) includes: self primitive) ifTrue: [ - lit1 _ self literalAt: firstLitIndex. - lit2 _ method literalAt: firstLitIndex. - lit1 isArray - ifTrue: [ - (lit2 isArray and: [ lit1 first = lit2 first and: [lit1 second = lit2 second]]) ifFalse: [ - ^false ]] - ifFalse: [ "ExternalLibraryFunction" - (lit1 analogousCodeTo: lit2) ifFalse: [ - ^false ]]. - firstLitIndex _ 2 ]. - - "#penultimateLiteral is selector (or properties, just compared, above) - Last literal is #methodClass. - Don't compare them. Two methods might be equal even if they have different selector (or none at all) - or are installed in different classes (or none at all)" - firstLitIndex to: numLits-2 do: [ :i | - lit1 _ self literalAt: i. - lit2 _ method literalAt: i. - lit1 = lit2 ifFalse: [ - "any other discrepancy is a failure" - ^ false ]]. - ^true! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'jmv 8/12/2018 21:36:15' prior: 50391833! - xBacktick - "Smalltalk code evaluated at compile time as a literal." - - self step. - buffer reset. - [hereChar == $` - and: [aheadChar == $` - ifTrue: [self step. false] - ifFalse: [true]]] - whileFalse: [ - buffer nextPut: self step. - (hereChar = Scanner doItCharacterValue asCharacter and: [source atEnd]) - ifTrue: [^self offEnd: 'Unmatched back quote']]. - self step. - [ | compiler method methodNode | - compiler _ Compiler new. - methodNode _ compiler compileNoPattern: buffer contents in: UndefinedObject context: nil notifying: nil ifFail: []. - method _ methodNode generate. - "Grab all messages sent while evaluating literal, so the main method will be shown as senders of them" - sentInLiterals addAll: method messages. - method literalsDo: [ :literal | literal isSymbol ifTrue: [ literal = #DoIt ifFalse: [sentInLiterals add: literal ]]]. - "Evaluate now." - token _ nil withArgs: #() executeMethod: method. - ] - on: SyntaxErrorNotification, UndeclaredVariableReference, Error - do: [ :ex | - ex class caseOf: { - [ SyntaxErrorNotification ] -> [ - self notify: 'Can not compile: ', ex errorMessage at: mark]. - [ UndeclaredVariableReference ] -> [ - self notify: 'Can not compile: Variable ''', ex varName, ''' is not declared' at: mark ] - } otherwise: [ - self notify: 'Can not evaluate code: ', ex description at: mark ]]. - tokenType _ #literal! ! -!Encoder methodsFor: 'results' stamp: 'jmv 8/12/2018 22:28:05' prior: 16837182! - allLiterals - addedSelectorAndMethodClassLiterals ifFalse: - [addedSelectorAndMethodClassLiterals := true. - "Put the optimized selectors in literals so as to browse senders more easily" - optimizedSelectors := optimizedSelectors reject: [:e| literalStream originalContents hasLiteral: e]. - optimizedSelectors isEmpty ifFalse: [ - "Use one entry per literal if enough room, else make anArray" - literalStream position + optimizedSelectors size + 2 >= self maxNumLiterals - ifTrue: [self litIndex: optimizedSelectors asArray sort] - ifFalse: [optimizedSelectors sorted do: [:e | self litIndex: e]]]. - "Add a slot for selector or MethodProperties" - self litIndex: nil. - self litIndex: self associationForClass]. - ^literalStream contents! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -ProtoObject withAllSubclasses do: [:c | c compileAll ].! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3404-ThreeCompiledMethodBugFixes-JuanVuletich-2018Aug12-23h34m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3404] on 15 August 2018 at 3:42:44 pm'! -!MenuItemMorph methodsFor: 'events' stamp: 'jmv 8/15/2018 15:42:06' prior: 16865939! - activateSubmenu: evt - "Activate our submenu; e.g., pass control to it" - subMenu ifNil: [ ^false ]. "not applicable" - (subMenu morphContainsPoint: (subMenu internalizeFromWorld: evt eventPosition)) ifFalse:[^false]. - subMenu activate: evt. - ^true! ! -!MenuItemMorph methodsFor: 'selecting' stamp: 'jmv 8/15/2018 15:41:44' prior: 50341139! - deselect - - self isSelected: false. - subMenu ifNotNil: [ - owner ifNotNil: [ owner activeSubmenu: nil ]]! ! - -MenuItemMorph removeSelector: #deselectTimeOut! - -MenuItemMorph removeSelector: #deselectTimeOut! - -MenuItemMorph removeSelector: #mouseLeave:! - -MenuItemMorph removeSelector: #mouseLeave:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3405-MenuFix-JuanVuletich-2018Aug15-15h41m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3403] on 11 August 2018 at 7:33:37 pm'! - -ParseNode subclass: #MessageNode - instanceVariableNames: 'receiver selector precedence special arguments sizes equalNode caseErrorNode originalReceiver originalSelector originalArguments keywordRanges ' - classVariableNames: 'MacroEmitters MacroPrinters MacroSelectors MacroSizers MacroTransformers ' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #MessageNode category: #'Compiler-ParseNodes'! -ParseNode subclass: #MessageNode - instanceVariableNames: 'receiver selector precedence special arguments sizes equalNode caseErrorNode originalReceiver originalSelector originalArguments keywordRanges' - classVariableNames: 'MacroEmitters MacroPrinters MacroSelectors MacroSizers MacroTransformers' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -ParseNode subclass: #MethodNode - instanceVariableNames: 'selectorOrFalse precedence arguments block primitive encoder temporaries properties sourceText locationCounter localsPool selectorKeywordsRanges ' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #MethodNode category: #'Compiler-ParseNodes'! -ParseNode subclass: #MethodNode - instanceVariableNames: 'selectorOrFalse precedence arguments block primitive encoder temporaries properties sourceText locationCounter localsPool selectorKeywordsRanges' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! -!CodeProvider methodsFor: 'message list menu' stamp: 'HAW 8/11/2018 18:52:25'! - inspectCompiledMethod - "Open an Inspector on the CompiledMethod itself" - - self selectedMessageName ifNotNil: [ - (self selectedClassOrMetaClass compiledMethodAt: self selectedMessageName) - inspect ]! ! -!Behavior methodsFor: 'methods' stamp: 'HAW 8/11/2018 18:49:25'! - methodNodeFor: aSourceCode - - | parser methodNode | - - parser := self parserClass new - encoderClass: EncoderForV3PlusClosures; - yourself. - - methodNode := parser parse: aSourceCode class: self. - methodNode sourceText: aSourceCode. - - ^methodNode - ! ! -!ParseNode methodsFor: 'testing' stamp: 'HAW 8/11/2018 19:00:35'! - isInstanceVariableNode - - ^false! ! -!ParseNode methodsFor: 'testing' stamp: 'HAW 8/11/2018 19:26:31'! - isMessageNamed: aSelector - - ^ false! ! -!Encoder methodsFor: 'temps' stamp: 'HAW 8/11/2018 19:09:30'! - bindArg: aName range: aRange - - ^ self addMultiRange: aRange for: (self bindArg: aName) -! ! -!Encoder methodsFor: 'temps' stamp: 'HAW 8/11/2018 19:13:38'! - bindTemp: aName range: aRange - - ^ self addMultiRange: aRange for: (self bindTemp: aName)! ! -!Encoder methodsFor: 'encoding' stamp: 'HAW 8/11/2018 19:14:52'! - encodeLiteral: object range: aRange - - ^ self addMultiRange: aRange for: (self encodeLiteral: object)! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 8/11/2018 19:11:31'! - addMultiRange: aRange for: aNode - - | ranges | - - "I'm using an OrderedCollection because ranges are added in order, while parsing the source code. - If this constrain is not hold, a SortedCollection should be used - Hernan" - ranges := sourceRanges at: aNode ifAbsentPut: [ OrderedCollection new ]. - ranges add: aRange. - - ^aNode ! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 8/11/2018 19:30:24'! - messageSendSelectorKeywordRangesOf: aSelector ifAbsent: aBlock - - | ranges sortedRanges | - - ranges := sourceRanges keys - select: [ :aParseNode | aParseNode isMessageNamed: aSelector ] - thenCollect: [ :aMessageSendNode | aMessageSendNode keywordRanges ]. - - ranges isEmpty ifTrue: [ ^aBlock value ]. - sortedRanges := ranges asSortedCollection: [ :left :right | left first first < right first first ]. - - ^sortedRanges ! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 8/11/2018 18:59:11'! - rangesForInstanceVariable: aName ifAbsent: aBlock - - ^ self - rangesForVariable: aName - checkingType: [ :variableNode | variableNode isInstanceVariableNode ] - ifAbsent: aBlock ! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 8/11/2018 18:59:25'! - rangesForTemporaryVariable: aName ifAbsent: aBlock - - ^ self - rangesForVariable: aName - checkingType: [ :variableNode | variableNode isTemp ] - ifAbsent: aBlock ! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 8/11/2018 18:58:07'! - rangesForVariable: aName checkingType: nodeTypeCheckBlock ifAbsent: anAbsentBlock - - | variableNode | - - variableNode := scopeTable at: aName ifAbsent: [ ^anAbsentBlock value ]. - (nodeTypeCheckBlock value: variableNode) ifFalse: [ ^anAbsentBlock value ]. - - ^sourceRanges at: variableNode ifAbsent: anAbsentBlock ! ! -!InstanceVariableNode methodsFor: 'testing' stamp: 'HAW 8/11/2018 19:00:19'! - isInstanceVariableNode - - ^true! ! -!MessageNode methodsFor: 'source ranges' stamp: 'HAW 8/11/2018 19:24:24'! - keywordRanges - - ^keywordRanges! ! -!MessageNode methodsFor: 'testing' stamp: 'HAW 8/11/2018 19:23:56'! - isMessageNamed: aSelector - - ^aSelector == selector key! ! -!MessageNode methodsFor: 'initialization' stamp: 'HAW 8/11/2018 19:21:33'! - receiver: aReceiver selector: aSelector arguments: args precedence: aPrecedence from: anEncoder sourceRange: aSourceRange keywordsRanges: wordsRanges - - keywordRanges := wordsRanges. - - ^self receiver: aReceiver selector: aSelector arguments: args precedence: aPrecedence from: anEncoder sourceRange: aSourceRange ! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 8/11/2018 19:01:49'! - rangesForInstanceVariable: aName ifAbsent: aBlock - - ^encoder rangesForInstanceVariable: aName ifAbsent: aBlock -! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 8/11/2018 19:01:59'! - rangesForTemporaryVariable: aName ifAbsent: aBlock - - ^encoder rangesForTemporaryVariable: aName ifAbsent: aBlock -! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 8/11/2018 19:06:30'! - selectorKeywordsRanges - - ^selectorKeywordsRanges! ! -!MethodNode methodsFor: 'initialization' stamp: 'HAW 8/11/2018 19:27:21'! - selector: selOrFalse arguments: args precedence: p temporaries: temps block: blk encoder: anEncoder primitive: prim properties: propDict selectorKeywordsRanges: range - - selectorKeywordsRanges := range. - - ^self selector: selOrFalse arguments: args precedence: p temporaries: temps block: blk encoder: anEncoder primitive: prim properties: propDict ! ! -!CompiledMethod methodsFor: 'decompiling' stamp: 'HAW 8/11/2018 18:50:26' prior: 16820711! - methodNode - "Return the parse tree that represents self" - - | aClass source | - - aClass := self methodClass. - source := self - getSourceFor: (self selector ifNil: [self defaultSelector]) - in: aClass. - - ^ aClass methodNodeFor: source - ! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 8/11/2018 18:51:50' prior: 50403379! - messageListMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'what to show...'. - #selector -> #offerWhatToShowMenu. - #icon -> #preferencesIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'toggle break on entry'. - #object -> #model. - #selector -> #toggleBreakOnEntry. - #icon -> #debugIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'browse method (O)'. - #selector -> #openSingleMessageBrowser. - #icon -> #scriptIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 40. - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutMessage. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'inspect CompiledMethod'. - #object -> #model. - #selector -> #inspectCompiledMethod. - #icon -> #exploreIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'senders of... (n)'. - #selector -> #browseSendersOfMessages. - #icon -> #mailForwardIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'implementors of... (m)'. - #selector -> #browseMessages. - #icon -> #developmentIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'inheritance (i)'. - #selector -> #methodHierarchy. - #icon -> #goDownIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 40. - #label -> 'versions (v)'. - #selector -> #browseVersions. - #icon -> #clockIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'inst var refs...'. - #selector -> #browseInstVarRefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 20. - #label -> 'inst var defs...'. - #selector -> #browseInstVarDefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'class var refs...'. - #selector -> #browseClassVarRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 40. - #label -> 'class variables'. - #selector -> #browseClassVariables. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 50. - #label -> 'class refs (N)'. - #selector -> #browseClassRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'remove method (x)'. - #object -> #model. - #selector -> #removeMessage. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 20. - #label -> 'run test (t)'. - #object -> #model. - #selector -> #runMethodTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 30. - #label -> 'debug test (r)'. - #object -> #model. - #selector -> #debugMethodTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 10. - #label -> 'more...'. - #selector -> #openMessageListMenu2. - #icon -> #listAddIcon - } asDictionary. - }`. - ! ! - -CodeProvider removeSelector: #exploreCompiledMethod! - -CodeProvider removeSelector: #exploreCompiledMethod! - -ParseNode subclass: #MessageNode - instanceVariableNames: 'receiver selector precedence special arguments sizes equalNode caseErrorNode originalReceiver originalSelector originalArguments keywordRanges' - classVariableNames: 'MacroEmitters MacroPrinters MacroSelectors MacroSizers MacroTransformers' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #MessageNode category: #'Compiler-ParseNodes'! -ParseNode subclass: #MessageNode - instanceVariableNames: 'receiver selector precedence special arguments sizes equalNode caseErrorNode originalReceiver originalSelector originalArguments keywordRanges' - classVariableNames: 'MacroEmitters MacroPrinters MacroSelectors MacroSizers MacroTransformers' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -ParseNode subclass: #MethodNode - instanceVariableNames: 'selectorOrFalse precedence arguments block primitive encoder temporaries properties sourceText locationCounter localsPool selectorKeywordsRanges' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #MethodNode category: #'Compiler-ParseNodes'! -ParseNode subclass: #MethodNode - instanceVariableNames: 'selectorOrFalse precedence arguments block primitive encoder temporaries properties sourceText locationCounter localsPool selectorKeywordsRanges' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3406-ParserEnhancements-HernanWilkinson-2018Aug11-18h49m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3403] on 11 August 2018 at 7:59:09 pm'! -!Parser methodsFor: 'scanning' stamp: 'HAW 8/11/2018 19:36:55'! - advanceWithRangeDo: aBlock - - | lexema start end | - - start := self startOfNextToken + requestorOffset. - lexema := self advance. - end _ self endOfLastToken + requestorOffset. - - ^ aBlock value: lexema value: (start to: end)! ! -!Parser methodsFor: 'temps' stamp: 'HAW 8/11/2018 19:45:20'! - bindArg: aName range: aRange - - ^ self bindArg: aName! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 19:48:40' prior: 16886084! - messagePart: level repeat: repeat - - | start receiver selector args precedence words keywordStart | - - [receiver := parseNode. - (hereType == #keyword and: [level >= 3]) - ifTrue: - [start := self startOfNextToken. - selector := WriteStream on: (String new: 32). - args := OrderedCollection new. - words := OrderedCollection new. - [hereType == #keyword] - whileTrue: - [keywordStart := self startOfNextToken + requestorOffset. - selector nextPutAll: self advance. - words addLast: (keywordStart to: self endOfLastToken + requestorOffset). - self primaryExpression ifFalse: [^self expected: 'Argument']. - self messagePart: 2 repeat: true. - args addLast: parseNode]. - (Symbol hasInterned: selector contents ifTrue: [ :sym | selector := sym]) - ifFalse: [ selector := self correctSelector: selector contents - wordIntervals: words - exprInterval: (start to: self endOfLastToken) - ifAbort: [ ^ self fail ] ]. - precedence := 3] - ifFalse: [ - - (level >= 2 and: [hereType == #verticalBar or: [hereType == #upArrow]]) ifTrue: [self transformVerticalBarAndUpArrowIntoABinarySelector]. - ((hereType == #binary ) - and: [level >= 2]) - ifTrue: - [start := self startOfNextToken. - selector := self advance asSymbol. - self primaryExpression ifFalse: [^self expected: 'Argument']. - self messagePart: 1 repeat: true. - args := Array with: parseNode. - precedence := 2] - ifFalse: [hereType == #word - ifTrue: - [start := self startOfNextToken. - selector := self advance. - args := #(). - words := OrderedCollection with: (start + requestorOffset to: self endOfLastToken + requestorOffset). - (Symbol hasInterned: selector ifTrue: [ :sym | selector := sym]) - ifFalse: [ selector := self correctSelector: selector - wordIntervals: words - exprInterval: (start to: self endOfLastToken) - ifAbort: [ ^ self fail ] ]. - precedence := 1] - ifFalse: [^args notNil]]]. - - parseNode := MessageNode new - receiver: receiver - selector: selector - arguments: args - precedence: precedence - from: encoder - sourceRange: (start to: self endOfLastToken) - keywordsRanges: words. - repeat] - whileTrue: []. - ^true! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 19:58:35' prior: 16886206! - pattern: fromDoit inContext: ctxt - " unarySelector | binarySelector arg | keyword arg {keyword arg} => - {selector, arguments, precedence}." - - | args selector end start argumentName | - - doitFlag := fromDoit. - fromDoit ifTrue: - [^ctxt == nil - ifTrue: [{#DoIt. {}. 1. nil }] - ifFalse: [{#DoItIn:. {encoder encodeVariable: encoder doItInContextName}. 3. nil}]]. - - hereType == #word ifTrue: [ - start _ self startOfNextToken + requestorOffset. - selector _ self advance asSymbol. - end _ self endOfLastToken + requestorOffset. - ^ {selector. {}. 1. {start to: end}}]. - - (hereType == #verticalBar - or: [hereType == #upArrow]) - ifTrue: [self transformVerticalBarAndUpArrowIntoABinarySelector]. - - hereType == #binary ifTrue: [ - start _ self startOfNextToken + requestorOffset. - selector _ self advance asSymbol. - end _ self endOfLastToken + requestorOffset. - - start _ self startOfNextToken + requestorOffset. - argumentName _ self argumentName. - end _ self endOfLastToken + requestorOffset. - - args _ Array with: (encoder bindArg: argumentName range: (start to: end)). - ^ {selector. args. 2. {start to: end}}]. - - hereType == #keyword ifTrue: [ | ranges | - selector := WriteStream on: (String new: 32). - args := OrderedCollection new. - ranges := OrderedCollection new. - [hereType == #keyword] whileTrue:[ | keywordAsString | - start _ self startOfNextToken + requestorOffset. - keywordAsString _ self advance. - end _ self endOfLastToken + requestorOffset. - ranges add: (start to: end). - selector nextPutAll: keywordAsString. - - start _ self startOfNextToken + requestorOffset. - argumentName _ self argumentName. - end _ self endOfLastToken + requestorOffset. - - args addLast: (encoder bindArg: argumentName range: (start to: end)). - ]. - ^ {selector contents asSymbol. args. 3. ranges}]. - ^self expected: 'Message pattern' -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3407-ParserEnhancements-HernanWilkinson-2018Aug11-19h33m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3403] on 11 August 2018 at 8:12:52 pm'! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 20:12:10'! - argumentNameWithRangeDo: aBlock - - hereType == #word ifFalse: [^self expected: 'Argument name']. - - ^self advanceWithRangeDo: aBlock! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 20:07:48' prior: 16886157! - method: doit context: ctxt - " pattern [ | temporaries ] block => MethodNode." - - | sap blk prim temps messageComment methodNode | - sap := self pattern: doit inContext: ctxt. - "sap={selector, arguments, precedence}" - self properties selector: (sap at: 1). - encoder selector: (sap at: 1). - (sap at: 2) do: [:argNode | argNode beMethodArg]. - doit ifFalse: [self pragmaSequence]. - temps := self temporaries. - messageComment := currentComment. - currentComment := nil. - doit ifFalse: [self pragmaSequence]. - prim := self pragmaPrimitives. - self statements: #() innerBlock: doit. - blk := parseNode. - doit ifTrue: [blk returnLast] - ifFalse: [blk returnSelfIfNoOther: encoder]. - hereType == #doIt ifFalse: [^self expected: 'Nothing more']. - methodNode := self newMethodNode comment: messageComment. - methodNode - selector: (sap at: 1) - arguments: (sap at: 2) - precedence: (sap at: 3) - temporaries: temps - block: blk - encoder: encoder - primitive: prim - properties: properties - selectorKeywordsRanges: (sap at: 4). - self interactive ifTrue: - [self declareUndeclaredTemps: methodNode. - self removeUnusedTemps]. - ^methodNode! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 20:10:22' prior: 50409081! - pattern: fromDoit inContext: ctxt - " unarySelector | binarySelector arg | keyword arg {keyword arg} => - {selector, arguments, precedence}." - - | args selector end start argumentName | - - doitFlag := fromDoit. - fromDoit ifTrue: - [^ctxt == nil - ifTrue: [{#DoIt. {}. 1. nil }] - ifFalse: [{#DoItIn:. {encoder encodeVariable: encoder doItInContextName}. 3. nil}]]. - - hereType == #word - ifTrue: [^ self advanceWithRangeDo: [ :sel :range | {sel asSymbol. {}. 1. {range}} ]]. - - (hereType == #verticalBar or: [hereType == #upArrow]) - ifTrue: [self transformVerticalBarAndUpArrowIntoABinarySelector]. - - hereType == #binary ifTrue: [ | selectorRange | - self advanceWithRangeDo: [ :sel :range | - selector _ sel asSymbol. - selectorRange _ range ]. - - start _ self startOfNextToken + requestorOffset. - argumentName _ self argumentName. - end _ self endOfLastToken + requestorOffset. - - args _ Array with: (encoder bindArg: argumentName range: (start to: end)). - ^ {selector. args. 2. {selectorRange}}]. - - hereType == #keyword ifTrue: [ | ranges | - selector := WriteStream on: (String new: 32). - args := OrderedCollection new. - ranges := OrderedCollection new. - [hereType == #keyword] whileTrue:[ - self advanceWithRangeDo: [ :keywordAsString :range | - selector nextPutAll: keywordAsString. - ranges add: range ]. - - start _ self startOfNextToken + requestorOffset. - argumentName _ self argumentName. - end _ self endOfLastToken + requestorOffset. - - args addLast: (encoder bindArg: argumentName range: (start to: end)). - ]. - ^ {selector contents asSymbol. args. 3. ranges}]. - ^self expected: 'Message pattern' -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3408-ParserEnhancements-HernanWilkinson-2018Aug11-19h59m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3403] on 11 August 2018 at 8:32:22 pm'! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 20:30:00'! - addKeywordPatternPartTo: selector keywordRanges: keywordRanges arguments: arguments - - self advanceWithRangeDo: [ :keywordAsString :range | - selector nextPutAll: keywordAsString. - keywordRanges add: range ]. - - self argumentNameWithRangeDo: [ :argName :range | - arguments addLast: (encoder bindArg: argName range: range)] -! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 20:25:57'! - binaryPattern - - ^ self advanceWithRangeDo: [ :selectorAsString :selectorRange | | arguments | - self argumentNameWithRangeDo: [ :argumentName :argumentRange | - arguments _ Array with: (encoder bindArg: argumentName range: argumentRange). - {selectorAsString asSymbol. arguments. 2. {selectorRange}}]]! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 20:31:37'! - doitPatternInContext: context - - ^context - ifNil: [{#DoIt. {}. 1. nil }] - ifNotNil: [{#DoItIn:. {encoder encodeVariable: encoder doItInContextName}. 3. nil}]! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 20:29:32'! - keywordPattern - - | keywordRanges selector arguments | - - selector := WriteStream on: (String new: 32). - arguments := OrderedCollection new. - keywordRanges := OrderedCollection new. - - [hereType == #keyword] whileTrue:[ - self addKeywordPatternPartTo: selector keywordRanges: keywordRanges arguments: arguments ]. - - ^ {selector contents asSymbol. arguments. 3. keywordRanges} - ! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 20:23:06'! - unaryPattern - - ^ self advanceWithRangeDo: [ :sel :range | {sel asSymbol. {}. 1. {range}} ]! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 20:21:50' prior: 50409194! - pattern: fromDoit inContext: ctxt - " unarySelector | binarySelector arg | keyword arg {keyword arg} => - {selector, arguments, precedence}." - - | args selector | - - doitFlag := fromDoit. - fromDoit ifTrue: - [^ctxt == nil - ifTrue: [{#DoIt. {}. 1. nil }] - ifFalse: [{#DoItIn:. {encoder encodeVariable: encoder doItInContextName}. 3. nil}]]. - - hereType == #word - ifTrue: [^ self advanceWithRangeDo: [ :sel :range | {sel asSymbol. {}. 1. {range}} ]]. - - (hereType == #verticalBar or: [hereType == #upArrow]) - ifTrue: [self transformVerticalBarAndUpArrowIntoABinarySelector]. - - hereType == #binary ifTrue: [ | selectorRange | - self advanceWithRangeDo: [ :sel :range | - selector _ sel asSymbol. - selectorRange _ range ]. - - ^ self argumentNameWithRangeDo: [ :argName :range | - args _ Array with: (encoder bindArg: argName range: range). - {selector. args. 2. {selectorRange}}]]. - - hereType == #keyword ifTrue: [ | keywordRanges | - selector := WriteStream on: (String new: 32). - args := OrderedCollection new. - keywordRanges := OrderedCollection new. - [hereType == #keyword] whileTrue:[ - self advanceWithRangeDo: [ :keywordAsString :range | - selector nextPutAll: keywordAsString. - keywordRanges add: range ]. - - self argumentNameWithRangeDo: [ :argName :range | - args addLast: (encoder bindArg: argName range: range)]. - ]. - ^ {selector contents asSymbol. args. 3. keywordRanges}]. - ^self expected: 'Message pattern' -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3409-ParserEnhancements-HernanWilkinson-2018Aug11-20h12m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3403] on 11 August 2018 at 8:36:31 pm'! -!Parser methodsFor: 'scanning' stamp: 'HAW 8/11/2018 20:36:10'! - transformVerticalBarAndUpArrowIntoABinarySelectorIfNecessary - - (hereType == #verticalBar or: [hereType == #upArrow]) - ifTrue: [self transformVerticalBarAndUpArrowIntoABinarySelector].! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 20:33:48' prior: 50409309! - pattern: fromDoit inContext: ctxt - " unarySelector | binarySelector arg | keyword arg {keyword arg} => - {selector, arguments, precedence}." - - doitFlag := fromDoit. - fromDoit ifTrue: [^self doitPatternInContext: ctxt ]. - - hereType == #word ifTrue: [^self unaryPattern ]. - - (hereType == #verticalBar or: [hereType == #upArrow]) - ifTrue: [self transformVerticalBarAndUpArrowIntoABinarySelector]. - - hereType == #binary ifTrue: [^self binaryPattern ]. - - hereType == #keyword ifTrue: [^self keywordPattern ]. - - ^self expected: 'Message pattern' -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3410-ParserEnhancements-HernanWilkinson-2018Aug11-20h32m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3403] on 11 August 2018 at 8:37:35 pm'! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 20:37:20' prior: 50409373! - pattern: fromDoit inContext: ctxt - " unarySelector | binarySelector arg | keyword arg {keyword arg} => - {selector, arguments, precedence}." - - doitFlag := fromDoit. - - fromDoit ifTrue: [^self doitPatternInContext: ctxt ]. - hereType == #word ifTrue: [^self unaryPattern ]. - self transformVerticalBarAndUpArrowIntoABinarySelectorIfNecessary. - hereType == #binary ifTrue: [^self binaryPattern ]. - hereType == #keyword ifTrue: [^self keywordPattern ]. - - ^self expected: 'Message pattern' -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3411-ParserEnhancements-HernanWilkinson-2018Aug11-20h36m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3403] on 11 August 2018 at 11:11:26 pm'! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 23:04:38' prior: 50409007! - messagePart: level repeat: repeat - - | start receiver selector args precedence words keywordStart | - - [receiver := parseNode. - (hereType == #keyword and: [level >= 3]) - ifTrue: - [start := self startOfNextToken. - selector := WriteStream on: (String new: 32). - args := OrderedCollection new. - words := OrderedCollection new. - [hereType == #keyword] - whileTrue: - [keywordStart := self startOfNextToken + requestorOffset. - selector nextPutAll: self advance. - words addLast: (keywordStart to: self endOfLastToken + requestorOffset). - self primaryExpression ifFalse: [^self expected: 'Argument']. - self messagePart: 2 repeat: true. - args addLast: parseNode]. - (Symbol hasInterned: selector contents ifTrue: [ :sym | selector := sym]) - ifFalse: [ selector := self correctSelector: selector contents - wordIntervals: words - exprInterval: (start to: self endOfLastToken) - ifAbort: [ ^ self fail ] ]. - precedence := 3] - ifFalse: [ - - (level >= 2 and: [hereType == #verticalBar or: [hereType == #upArrow]]) ifTrue: [self transformVerticalBarAndUpArrowIntoABinarySelector]. - ((hereType == #binary ) - and: [level >= 2]) - ifTrue: - [start := self startOfNextToken. - selector := self advance asSymbol. - words := OrderedCollection with: (start + requestorOffset to: self endOfLastToken + requestorOffset). - self primaryExpression ifFalse: [^self expected: 'Argument']. - self messagePart: 1 repeat: true. - args := Array with: parseNode. - precedence := 2] - ifFalse: [hereType == #word - ifTrue: - [start := self startOfNextToken. - selector := self advance. - args := #(). - words := OrderedCollection with: (start + requestorOffset to: self endOfLastToken + requestorOffset). - (Symbol hasInterned: selector ifTrue: [ :sym | selector := sym]) - ifFalse: [ selector := self correctSelector: selector - wordIntervals: words - exprInterval: (start to: self endOfLastToken) - ifAbort: [ ^ self fail ] ]. - precedence := 1] - ifFalse: [^args notNil]]]. - - parseNode := MessageNode new - receiver: receiver - selector: selector - arguments: args - precedence: precedence - from: encoder - sourceRange: (start to: self endOfLastToken) - keywordsRanges: words. - repeat] - whileTrue: []. - ^true! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3412-ParserEnhancements-HernanWilkinson-2018Aug11-20h58m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3403] on 11 August 2018 at 11:32:56 pm'! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 23:20:34' prior: 16886240! - primaryExpression - hereType == #word - ifTrue: [ - parseNode _ self variable. - - " - (parseNode isUndefTemp and: [self interactive] and: [ - ((requestor isKindOf: Editor) or: [ requestor is: #Morph ])]) - " - "If the requestor is of an exotic kind (like a telnet server) we might not be - allowed to open a PupUpMenu for querying the user" - - (parseNode isUndefTemp and: [ self interactive ]) - ifTrue: [self queryUndefined]. - parseNode nowHasRef. - ^ true]. - hereType == #leftBracket - ifTrue: [ - self advance. - self blockExpression. - ^true]. - hereType == #leftBrace - ifTrue: [ - self braceExpression. - ^true]. - hereType == #leftParenthesis - ifTrue: [ - self advance. - self expression ifFalse: [^self expected: 'expression']. - (self match: #rightParenthesis) - ifFalse: [^self expected: 'right parenthesis']. - ^true]. - (hereType == #string or: [hereType == #number or: [hereType == #literal]]) - ifTrue: [ - parseNode := self advanceWithRangeDo: [ :lexema :range | encoder encodeLiteral: lexema range: range ]. - ^true]. - (here == #- and: [tokenType == #number]) - ifTrue: [ - self advanceWithRangeDo: [ :minusChar :minusRange | - self advanceWithRangeDo: [ :number :numberRange | - parseNode := encoder encodeLiteral: number negated range: (minusRange first to: numberRange last)]]. - ^true]. - ^false! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 23:23:08' prior: 16886333! - temporaries - " [ '|' (variable)* '|' ]" - | vars theActualText | - (self match: #verticalBar) ifFalse: - ["no temps" - doitFlag ifTrue: - [tempsMark := self interactive - ifTrue: [requestor selectionInterval first] - ifFalse: [1]. - ^ #()]. - tempsMark := hereMark "formerly --> prevMark + prevToken". - tempsMark > 0 ifTrue: - [theActualText := source contents. - [tempsMark < theActualText size and: [(theActualText at: tempsMark) isSeparator]] - whileTrue: [tempsMark := tempsMark + 1]]. - ^ #()]. - vars := OrderedCollection new. - [hereType == #word] - whileTrue: [ - self advanceWithRangeDo: [ :variableName :range | - vars addLast: (encoder bindTemp: variableName range: range)]]. - (self match: #verticalBar) ifTrue: - [tempsMark := prevMark. - ^ vars]. - ^ self expected: 'Vertical bar' -! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 23:30:36' prior: 16886405! - variable - - ^self advanceWithRangeDo: [ :variableName :range | | varName result | - varName := variableName. - [result _ encoder encodeVariable: varName sourceRange: range ifUnknown: [ nil ]. - result ifNil: [ - result _ (UndeclaredVariableReference new) - parser: self; - varName: varName; - varStart: range first; - varEnd: range last; - signal ]. - result isString ] whileTrue: [ varName _ result]. - encoder addMultiRange: range for: result ]. - ! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3413-ParserEnhancements-HernanWilkinson-2018Aug11-23h11m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3411] on 13 August 2018 at 11:36:37 am'! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 8/13/2018 11:35:34'! -rangesForLiteralNode: aName ifAbsent: aBlock - - | variableNode | - - variableNode := litSet at: aName ifAbsent: [ ^aBlock value ]. - - ^sourceRanges at: variableNode ifAbsent: aBlock! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 8/13/2018 11:35:41'! - rangesForLiteralVariableNode: aName ifAbsent: aBlock - - | variableNode | - - variableNode := litIndSet values detect: [ :aLiteralVariableNode | aLiteralVariableNode name = aName ] ifNone: [ ^aBlock value ]. - - ^sourceRanges at: variableNode ifAbsent: aBlock! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3414-ParserEnhancements-2-HernanWilkinson-2018Aug13-11h28m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3411] on 13 August 2018 at 7:15:52 pm'! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/13/2018 19:15:42'! - performInteractiveChecks: aMethodNode - - self - declareUndeclaredTemps: aMethodNode; - removeUnusedTemps! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3415-ParserEnhancements-2-HernanWilkinson-2018Aug13-19h15m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3411] on 13 August 2018 at 7:16:22 pm'! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/13/2018 19:16:08' prior: 50409156! - method: doit context: ctxt - " pattern [ | temporaries ] block => MethodNode." - - | sap blk prim temps messageComment methodNode | - - sap := self pattern: doit inContext: ctxt. - "sap={selector, arguments, precedence}" - self properties selector: (sap at: 1). - encoder selector: (sap at: 1). - (sap at: 2) do: [:argNode | argNode beMethodArg]. - doit ifFalse: [self pragmaSequence]. - temps := self temporaries. - messageComment := currentComment. - currentComment := nil. - doit ifFalse: [self pragmaSequence]. - prim := self pragmaPrimitives. - self statements: #() innerBlock: doit. - blk := parseNode. - doit ifTrue: [blk returnLast] - ifFalse: [blk returnSelfIfNoOther: encoder]. - hereType == #doIt ifFalse: [^self expected: 'Nothing more']. - methodNode := self newMethodNode comment: messageComment. - methodNode - selector: (sap at: 1) - arguments: (sap at: 2) - precedence: (sap at: 3) - temporaries: temps - block: blk - encoder: encoder - primitive: prim - properties: properties - selectorKeywordsRanges: (sap at: 4). - - self interactive ifTrue: [ self performInteractiveChecks: methodNode ]. - - ^methodNode! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3416-ParserEnhancements-2-HernanWilkinson-2018Aug13-19h15m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3411] on 13 August 2018 at 7:45:27 pm'! -!Encoder methodsFor: 'temps' stamp: 'HAW 8/13/2018 19:44:54'! - bindBlockArg: name within: aBlockNode range: range - - ^self addMultiRange: range for: (self bindBlockArg: name within: aBlockNode) - -! ! -!Encoder methodsFor: 'temps' stamp: 'HAW 8/13/2018 19:45:13'! - bindBlockTemp: name within: aBlockNode range: range - - ^self addMultiRange: range for: (self bindBlockTemp: name within: aBlockNode) - -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3417-ParserEnhancements-3-HernanWilkinson-2018Aug13-19h16m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3411] on 13 August 2018 at 7:48:17 pm'! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/13/2018 19:47:02' prior: 16885972! - blockExpression - "[ ({:var} |) (| {temps} |) (statements) ] => BlockNode." - - | blockNode variableNodes temporaryBlockVariables start | - blockNode := BlockNode new. - variableNodes := OrderedCollection new. - start := prevMark + requestorOffset. - "Gather parameters." - [self match: #colon] whileTrue: - [self argumentNameWithRangeDo: [ :argumentName :range | - variableNodes addLast: (encoder bindBlockArg: argumentName within: blockNode range: range)]]. - (variableNodes size > 0 & (hereType ~~ #rightBracket) and: [(self match: #verticalBar) not]) ifTrue: - [^self expected: 'Vertical bar']. - - temporaryBlockVariables := self temporaryBlockVariablesFor: blockNode. - self statements: variableNodes innerBlock: true blockNode: blockNode. - blockNode temporaries: temporaryBlockVariables. - - (self match: #rightBracket) ifFalse: [^self expected: 'Period or right bracket']. - - blockNode noteSourceRangeStart: start end: self endOfLastToken encoder: encoder. - - "The scope of the parameters and temporary block variables is no longer active." - temporaryBlockVariables do: [:variable | variable scope: -1]. - variableNodes do: [:variable | variable scope: -1]! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/13/2018 19:47:49' prior: 16886386! - temporaryBlockVariablesFor: aBlockNode - "Scan and answer temporary block variables." - - | variables | - (self match: #verticalBar) ifFalse: - "There are't any temporary variables." - [aBlockNode tempsMark: prevMark + requestorOffset. - ^#()]. - - variables := OrderedCollection new. - [hereType == #word] whileTrue: - [self advanceWithRangeDo: [ :lexema :range | - variables addLast: (encoder bindBlockTemp: lexema within: aBlockNode range: range)]]. - (self match: #verticalBar) ifFalse: - [^self expected: 'Vertical bar']. - aBlockNode tempsMark: prevMark + requestorOffset. - ^variables! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3418-ParserEnhancements-3-HernanWilkinson-2018Aug13-19h45m-HAW.1.cs.st----! - -----SNAPSHOT----#(15 August 2018 3:58:45.323521 pm) Cuis5.0-3418-32.image priorSource: 2454787! - -----QUIT----#(15 August 2018 3:59:06.014689 pm) Cuis5.0-3418-32.image priorSource: 2500184! - -----STARTUP----#(25 August 2018 11:26:10.936056 am) as /home/juan/Rectifier/Cuis-Smalltalk-Dev/Cuis5.0-3418-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3418] on 15 August 2018 at 7:54:00 pm'! - -Object subclass: #Scanner - instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable isForTokenization sentInLiterals ignoreBacktick ' - classVariableNames: 'TypeTable ' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #Scanner category: #'Compiler-Kernel'! -Object subclass: #Scanner - instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable isForTokenization sentInLiterals ignoreBacktick' - classVariableNames: 'TypeTable' - poolDictionaries: '' - category: 'Compiler-Kernel'! -!Scanner methodsFor: 'expression types - private' stamp: 'HAW 8/15/2018 19:53:14'! - isBacktickAndShouldIgnoreIt - - "I compare with true because there are many ways to initialize the scanner and ingoreBacktick could be nil - Hernan" - ^ ignoreBacktick == true and: [tokenType = #xBacktick]! ! -!Scanner methodsFor: 'expression types - private' stamp: 'HAW 8/15/2018 19:53:27'! - skipDelimiters - - [(tokenType := self typeTableAt: hereChar) == #xDelimiter] whileTrue: [self step]. -! ! -!Scanner methodsFor: 'expression types - private' stamp: 'HAW 8/15/2018 19:53:35'! - skipDelimitersAndBacktickIfNecessary - - [self skipDelimiters. - self isBacktickAndShouldIgnoreIt ] whileTrue: [self step]. ! ! -!Scanner methodsFor: 'initialization' stamp: 'HAW 8/15/2018 19:51:51' prior: 50382611! - initScanner - - buffer := WriteStream on: (String new: 40). - typeTable := Scanner typeTable. - isForTokenization := false. - sentInLiterals := Set new. - ignoreBacktick := true! ! -!Scanner methodsFor: 'initialization' stamp: 'HAW 8/15/2018 19:52:00' prior: 16904201! - initScannerForTokenization - "Don't raise xIllegal when enocuntering an _" - "Simpler implementation for Cuis" - isForTokenization _ true. - ignoreBacktick _ true.! ! - -Object subclass: #Scanner - instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable isForTokenization sentInLiterals ignoreBacktick' - classVariableNames: 'TypeTable' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #Scanner category: #'Compiler-Kernel'! -Object subclass: #Scanner - instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable isForTokenization sentInLiterals ignoreBacktick' - classVariableNames: 'TypeTable' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3419-BacktickEvaluationOnlyWhenCompiling-HernanWilkinson-2018Aug15-19h51m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3418] on 15 August 2018 at 7:55:52 pm'! -!Scanner methodsFor: 'initialization' stamp: 'HAW 8/15/2018 19:55:10'! - ignoreBacktick: aBoolean - - ignoreBacktick := aBoolean ! ! -!Scanner methodsFor: 'expression types' stamp: 'HAW 8/15/2018 19:55:41' prior: 16903829! - scanToken - - "Skip delimiters fast, there almost always is one." - self skipDelimitersAndBacktickIfNecessary. - - mark := source position - 1. - (tokenType at: 1) = $x "x as first letter" - ifTrue: [self perform: tokenType "means perform to compute token & type"] - ifFalse: [token := self step asSymbol "else just unique the first char"]. - ^token! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3420-BacktickEvaluationOnlyWhenCompiling-HernanWilkinson-2018Aug15-19h54m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3418] on 15 August 2018 at 7:57:57 pm'! -!Compiler methodsFor: 'private' stamp: 'HAW 8/15/2018 19:56:18' prior: 16822062! - translate: aStream noPattern: noPattern ifFail: failBlock - ^self parser - sourceStreamGetter: sourceStreamGetter; "Cuis specific. Do not remove!!" - ignoreBacktick: false; - parse: aStream - class: class - category: category - noPattern: noPattern - context: context - notifying: requestor - ifFail: [^failBlock value]! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3421-BacktickEvaluationOnlyWhenCompiling-HernanWilkinson-2018Aug15-19h55m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3418] on 16 August 2018 at 6:44:54 am'! -!Scanner methodsFor: 'xBacktick processing - private' stamp: 'HAW 8/16/2018 06:37:45'! - compileBacktickCode - - | compiler method methodNode | - - compiler _ Compiler new. - methodNode _ compiler compileNoPattern: buffer contents in: UndefinedObject context: nil notifying: nil ifFail: []. - method _ methodNode generate. - - "Grab all messages sent while evaluating literal, so the main method will be shown as senders of them" - sentInLiterals addAll: method messages. - method literalsDo: [ :literal | literal isSymbol ifTrue: [ literal = #DoIt ifFalse: [sentInLiterals add: literal ]]]. - - "Evaluate now." - token _ nil withArgs: #() executeMethod: method ! ! -!Scanner methodsFor: 'xBacktick processing - private' stamp: 'HAW 8/16/2018 06:37:02'! - compileBacktickCodeHandlingErrors - - [[[self compileBacktickCode ] - on: SyntaxErrorNotification - do: [ :ex | self notify: 'Can not compile: ', ex errorMessage at: mark]] - on: UndeclaredVariableReference - do: [ :ex | self notify: 'Can not compile: Variable ''', ex varName, ''' is not declared' at: mark ]] - on: Error - do: [ :ex | self notify: 'Can not evaluate code: ', ex description at: mark ]. - - tokenType _ #literal! ! -!Scanner methodsFor: 'xBacktick processing - private' stamp: 'HAW 8/16/2018 06:28:34'! - isAtBacktick - - ^ hereChar == $` and: [aheadChar == $` ifTrue: [self step. false] ifFalse: [true]]! ! -!Scanner methodsFor: 'xBacktick processing - private' stamp: 'HAW 8/16/2018 06:28:54'! - readUpToNextBacktick - - self step. - buffer reset. - - [self isAtBacktick] - whileFalse: [ - buffer nextPut: self step. - (hereChar = Scanner doItCharacterValue asCharacter and: [source atEnd]) ifTrue: [^false]]. - self step. - - ^true! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'HAW 8/16/2018 06:38:36' prior: 50408474! - xBacktick - - "Smalltalk code evaluated at compile time as a literal." - - self readUpToNextBacktick ifFalse: [^self offEnd: 'Unmatched back quote']. - self compileBacktickCodeHandlingErrors.! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3422-ScannerCleanup-HernanWilkinson-2018Aug15-19h57m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3418] on 16 August 2018 at 6:49:39 am'! -!Scanner methodsFor: 'multi-character scans' stamp: 'HAW 8/16/2018 06:49:14'! - doItCharacter - - ^self class doItCharacterValue asCharacter! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3423-ScannerCleanup-HernanWilkinson-2018Aug16-06h44m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3418] on 16 August 2018 at 6:56:22 am'! -!Scanner methodsFor: 'expression types' stamp: 'HAW 8/16/2018 06:52:54' prior: 16903686! -scanAllTokenPositionsInto: aBlock - "Evaluate aBlock with the start and end positions of all separate non-white-space tokens, including comments." - - | lastMark | - lastMark := 1. - [currentComment ifNotNil: - [currentComment do: - [:cmnt| | idx | - idx := source originalContents indexOfSubCollection: cmnt startingAt: lastMark. - (idx > 0 and: [idx < mark]) ifTrue: - [aBlock value: idx - 1 value: (lastMark := idx + cmnt size)]]. - currentComment := nil]. - mark ifNotNil: - [(token == #- - and: [(self typeTableAt: hereChar) == #xDigit]) ifTrue: - [| savedMark | - savedMark := mark. - self scanToken. - token := token negated. - mark := savedMark]. - "Compensate for the fact that the parser uses two character lookahead. Normally we must - remove the extra two characters. But this mustn't happen for the last token at the end of stream." - aBlock - value: mark - value: (source position - (aheadChar = self class doItCharacterValue ifTrue: [hereChar = self doItCharacter ifTrue: [0] ifFalse: [1]] ifFalse: [2]))]. - (tokenType == #rightParenthesis - or: [tokenType == #doIt]) ifTrue: - [^self]. - tokenType == #leftParenthesis - ifTrue: - [self scanToken; scanAllTokenPositionsInto: aBlock] - ifFalse: - [(tokenType == #word or: [tokenType == #keyword or: [tokenType == #colon]]) - ifTrue: - [self scanLitWord. - token == #true ifTrue: [token := true]. - token == #false ifTrue: [token := false]. - token == #nil ifTrue: [token := nil]] - ifFalse: - [(token == #- - and: [(self typeTableAt: hereChar) == #xDigit]) - ifTrue: - [self scanToken. - token := token negated]]]. - self scanToken ] repeat! ! -!Scanner methodsFor: 'expression types' stamp: 'HAW 8/16/2018 06:50:46' prior: 16903844! - step - - | c | - c := hereChar. - hereChar := aheadChar. - source atEnd - ifTrue: [aheadChar := self doItCharacter "doit"] - ifFalse: [aheadChar := source next]. - ^c! ! -!Scanner methodsFor: 'xBacktick processing - private' stamp: 'HAW 8/16/2018 06:50:12' prior: 50409971! - readUpToNextBacktick - - self step. - buffer reset. - - [self isAtBacktick] - whileFalse: [ - buffer nextPut: self step. - (hereChar = self doItCharacter and: [source atEnd]) ifTrue: [^false]]. - self step. - - ^true! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'HAW 8/16/2018 06:51:11' prior: 16904051! - xDigit - "Form a number." - - tokenType := #number. - (aheadChar = self doItCharacter and: [source atEnd - and: [source skip: -1. source next ~= self doItCharacter]]) - ifTrue: [source skip: -1 "Read off the end last time"] - ifFalse: [source skip: -2]. - token := [Number readFrom: source] ifError: [:err :rcvr | self offEnd: err]. - self step; step! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'HAW 8/16/2018 06:51:33' prior: 16904073! - xDoubleQuote - "Collect a comment." - "wod 1/10/98: Allow 'empty' comments by testing the first character -for $"" rather than blindly adding it to the comment being collected." - | aStream stopChar | - stopChar := self doItCharacter. - aStream := WriteStream on: (String new: 200). - self step. - [hereChar == $"] - whileFalse: - [(hereChar == stopChar and: [source atEnd]) - ifTrue: [^self offEnd: 'Unmatched comment quote']. - aStream nextPut: self step.]. - self step. - currentComment == nil - ifTrue: [currentComment := OrderedCollection with: aStream contents] - ifFalse: [currentComment add: aStream contents]. - self scanToken! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'HAW 8/16/2018 06:51:48' prior: 16904108! - xLetter - "Form a word or keyword." - - | type | - buffer reset. - [(type := self typeTableAt: hereChar) == #xLetter - or: [type == #xDigit - or: [type == #xUnderscore]]] whileTrue: - ["open code step for speed" - buffer nextPut: hereChar. - hereChar := aheadChar. - aheadChar := source atEnd - ifTrue: [self doItCharacter "doit"] - ifFalse: [source next]]. - tokenType := (type == #colon or: [type == #xColon and: [aheadChar ~~ $=]]) - ifTrue: - [buffer nextPut: self step. - "Allow any number of embedded colons in literal symbols" - [(self typeTableAt: hereChar) == #xColon] whileTrue: - [buffer nextPut: self step]. - #keyword] - ifFalse: - [#word]. - token := buffer contents! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'HAW 8/16/2018 06:52:09' prior: 16904168! - xSingleQuote - "String." - - self step. - buffer reset. - [hereChar == $' - and: [aheadChar == $' - ifTrue: [self step. false] - ifFalse: [true]]] - whileFalse: - [buffer nextPut: self step. - (hereChar = self doItCharacter and: [source atEnd]) - ifTrue: [^self offEnd: 'Unmatched string quote']]. - self step. - token := buffer contents. - tokenType := #string! ! -!Scanner class methodsFor: 'cached class state' stamp: 'HAW 8/16/2018 06:52:18' prior: 50382998! - initTypeTable - | newTable | - newTable := Array new: 256 withAll: #xIllegal. "default" - newTable atAll: #(9 10 12 13 32 ) put: #xDelimiter. "tab lf ff cr space" - - 1 to: 255 - do: [:index | - (Character numericValue: index) isValidInIdentifiers - ifTrue: [ - "Digits and $_ are overwritten later" - newTable at: index put: #xLetter ]]. - - newTable atAll: ($0 numericValue to: $9 numericValue) put: #xDigit. - newTable atAll: '!!%&+-*/\±×÷¬­¯,<=>”•–—˜™š›œ«»?@~€‚ƒŽ‘’“žŸ°·' asByteArray put: #xBinary. - - newTable at: self doItCharacterValue put: #doIt. - newTable at: $" numericValue put: #xDoubleQuote. - newTable at: $# numericValue put: #xLitQuote. - newTable at: $$ numericValue put: #xDollar. - newTable at: $' numericValue put: #xSingleQuote. - newTable at: $` numericValue put: #xBacktick. - newTable at: $: numericValue put: #xColon. - newTable at: $( numericValue put: #leftParenthesis. - newTable at: $) numericValue put: #rightParenthesis. - newTable at: $. numericValue put: #period. - newTable at: $; numericValue put: #semicolon. - newTable at: $[ numericValue put: #leftBracket. - newTable at: $] numericValue put: #rightBracket. - newTable at: ${ numericValue put: #leftBrace. - newTable at: $} numericValue put: #rightBrace. - newTable at: $^ numericValue put: #upArrow. - newTable at: $_ numericValue put: #xUnderscore. - newTable at: $| numericValue put: #verticalBar. - TypeTable := newTable "bon voyage!!" - - " - Scanner initTypeTable - "! ! -!Parser methodsFor: 'scanning' stamp: 'HAW 8/16/2018 06:49:54' prior: 16885743! - advance - | this | - prevMark := hereMark. - prevEnd := hereEnd. - this := here. - here := token. - hereType := tokenType. - hereMark := mark. - hereEnd := source position - (source atEnd ifTrue: [hereChar = self doItCharacter ifTrue: [0] ifFalse: [1]] ifFalse: [2]). - self scanToken. - "Transcript show: 'here: ', here printString, ' mark: ', hereMark printString, ' end: ', hereEnd printString; cr." - ^this! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3424-ScannerCleanup-HernanWilkinson-2018Aug16-06h49m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3418] on 16 August 2018 at 7:01:54 am'! -!Scanner methodsFor: 'multi-character scans' stamp: 'HAW 8/16/2018 07:00:43'! - isAt: aChar - - ^ hereChar == aChar and: [aheadChar == aChar ifTrue: [self step. false] ifFalse: [true]]! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'HAW 8/16/2018 07:01:00'! - readUpToNext: aChar ifNotFound: aNotFoundBlock - - self step. - buffer reset. - - [self isAt: aChar] - whileFalse: - [buffer nextPut: self step. - (hereChar = self doItCharacter and: [source atEnd]) ifTrue: [^aNotFoundBlock value ]]. - - self step. - token := buffer contents. - ! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3425-ScannerCleanup-HernanWilkinson-2018Aug16-06h56m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3418] on 16 August 2018 at 7:05:45 am'! -!Scanner methodsFor: 'multi-character scans' stamp: 'HAW 8/16/2018 07:04:23' prior: 50409982! - xBacktick - - "Smalltalk code evaluated at compile time as a literal." - - self readUpToNext: $` ifNotFound: [^self offEnd: 'Unmatched back quote']. - self compileBacktickCodeHandlingErrors.! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'HAW 8/16/2018 07:03:12' prior: 50410151! - xSingleQuote - - "String." - - self readUpToNext: $' ifNotFound: [^self offEnd: 'Unmatched string quote']. - tokenType := #string! ! - -Scanner removeSelector: #isAtBacktick! - -Scanner removeSelector: #isAtBacktick! - -Scanner removeSelector: #readUpToNextBacktick! - -Scanner removeSelector: #readUpToNextBacktick! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3426-ScannerCleanup-HernanWilkinson-2018Aug16-07h01m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3426] on 19 August 2018 at 6:11:23 pm'! -!WorldState methodsFor: 'accessing' stamp: 'jmv 8/19/2018 18:11:12' prior: 50340369! - runLocalStepMethods: nowTime - "Run morph 'step' methods (LOCAL TO THIS WORLD) whose time has come. Purge any morphs that are no longer in this world." - - | stepMessage | - [ stepList notEmpty and: [ stepList first scheduledTime <= nowTime ]] - whileTrue: [ - stepMessage _ stepList first. - (stepMessage receiver shouldGetStepsFrom: world) - ifFalse: [ stepList removeFirst ] - ifTrue: [ - stepMessage valueAtTime: nowTime. - stepMessage rescheduleAfter: nowTime. - "We've just updated the scheduled time for stepMessage. - It might have been that stepMessage was removed altogether from stepList. - It also may be the case that stepList got added or removed other elements while on #valueAtTime: - Just reSort. It will be ok in any case." - stepList reSort. - ] - ]! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3427-MorphicStepFix-JuanVuletich-2018Aug19-18h11m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3418] on 21 August 2018 at 4:01:58 pm'! -!ProtocolBrowser methodsFor: 'initialization' stamp: 'jmv 8/21/2018 16:01:20' prior: 50374668! - initialize - super initialize. - exclude _ OrderedCollection new! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3428-ProtocolBrowser-fix-JuanVuletich-2018Aug21-16h01m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3402] on 18 August 2018 at 2:44:44 pm'! -!Behavior methodsFor: 'private' stamp: 'pb 8/18/2018 14:12:12' prior: 16784915! - handleFailingFailingBasicNew: sizeRequested - "This basicNew: gets sent after handleFailingBasicNew: has done a full - garbage collection and possibly grown memory. If this basicNew: fails - then the system really is low on space, so raise the OutOfMemory signal. - - Primitive. Answer an instance of this class with the number of indexable - variables specified by the argument, sizeRequested. Fail if this class is not - indexable or if the argument is not a positive Integer, or if there is not - enough memory available. Essential. See Object documentation whatIsAPrimitive." - "space must be low." - - (sizeRequested isInteger and: [ sizeRequested > 0 ]) - ifTrue: [ OutOfMemory signal ] - ifFalse: [ self error: 'sizeRequested must be a positive integer' ]. - ^ self basicNew: sizeRequested"retry if user proceeds".! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3429-not-always-OOM-PhilBellalouna-2018Aug18-14h12m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3429] on 23 August 2018 at 4:37:09 pm'! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 8/23/2018 09:45:40'! - smoothStep - "A Function that is - x <= -1 -> 1 - -1 < x < 1 -> smooth differentiable transition from 1 to 0 - 1 <= x -> 0 - - It is a 'smooth' version of an #negative - Has countless applications. For example in image and signal processing, but also in other fields." - " - | g | - Feature require: 'Morphic-Widgets-Extras'. - g _ FunctionGraphMorph new. - g domain: (-4 to: 4). - g addFunction: [ :x | x abs < 1 ifTrue: [1] ifFalse:[0] ] color: Color brown. - g addFunction: [ :x | x smoothStep ] color: Color red. - (g embeddedInMorphicWindowLabeled: 'graph') openInWorld - " - self > -1 ifFalse: [ ^ 1 ]. - 1 > self ifFalse: [ ^ 0 ]. - ^ (self +2 * Float halfPi) sin * 0.5 + 0.5! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 8/23/2018 09:30:56' prior: 16845643! - reciprocal - ^ 1.0 / self! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 8/23/2018 09:32:01' prior: 50405247! - smoothIsAbsBelow: threshold - "A Function that is 1 at zero, 0 outside a bounded interval of size 4*threshold, and is continuous and differentiable. - - It is a 'smooth' version of an #isAbsBelow: function: x abs < threshold. - Useful when we need to 'count' stuff, but still want continuous and differentiable stuff." - " - | g | - Feature require: 'Morphic-Widgets-Extras'. - g _ FunctionGraphMorph new. - g domain: (-4 to: 4). - g addFunction: [ :x | x abs < Float halfPi ifTrue: [1] ifFalse:[0] ] color: Color brown. - g addFunction: [ :x | x smoothIsAbsBelow: Float halfPi ] color: Color red. - (g embeddedInMorphicWindowLabeled: 'graph') openInWorld - " - | scaled | - scaled _ self / threshold. - ^ scaled abs < 2 ifTrue: [ (scaled * Float halfPi) cos + 1.0 * 0.5 ] ifFalse: [ 0 ]! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3430-FloatTweaks-JuanVuletich-2018Aug23-16h36m-jmv.1.cs.st----! - -----SNAPSHOT----#(25 August 2018 11:26:17.341828 am) Cuis5.0-3430-32.image priorSource: 2500281! - -----QUIT----#(25 August 2018 11:26:33.524013 am) Cuis5.0-3430-32.image priorSource: 2521102! - -----STARTUP----#(8 October 2018 11:00:54.431095 am) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3430-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3430] on 2 September 2018 at 11:47:54 pm'! - -Object subclass: #CharacterScanner - instanceVariableNames: 'destX lastIndex xTable map destY stopConditions text alignment leftMargin rightMargin font line runStopIndex spaceCount spaceWidth kern paragraphStyle tabWidth defaultFont lastTabIndex lastTabX ' - classVariableNames: 'DefaultStopConditions StopConditionsWithPaddedSpace StopConditionsWithSpace ' - poolDictionaries: '' - category: 'Graphics-Text'! - -!classDefinition: #CharacterScanner category: #'Graphics-Text'! -Object subclass: #CharacterScanner - instanceVariableNames: 'destX lastIndex xTable map destY stopConditions text alignment leftMargin rightMargin font line runStopIndex spaceCount spaceWidth kern paragraphStyle tabWidth defaultFont lastTabIndex lastTabX' - classVariableNames: 'DefaultStopConditions StopConditionsWithPaddedSpace StopConditionsWithSpace' - poolDictionaries: '' - category: 'Graphics-Text'! -!CharacterScanner methodsFor: 'private' stamp: 'jmv 9/2/2018 23:46:54' prior: 50370319! - setFont - | attributes | - "Set the font and other emphasis. - In fact set actual ParagraphStyle (or nil), alignment, font and emphasis" - - self setActualFont: (text fontAt: lastIndex default: defaultFont). - attributes _ text attributesAt: lastIndex. - text - withAttributeValues: attributes - do: [ :familyNameInText :pointSizeInText :emphasisInText :colorInText :alignmentInText :characterStyleInText :paragraphStyleInText :backgroundColorInText | - colorInText ifNotNil: [ self textColor: colorInText ]. - self backgroundColor: backgroundColorInText. - alignment _ alignmentInText. - paragraphStyle _ paragraphStyleInText ]. - - "Hardcoded color for TextAction" - attributes do: [ :attribute | - attribute forTextActionInfoDo: [ :info | - self textColor: TextAction textActionColor ]]. - - "Install various parameters from the font." - spaceWidth _ font widthOf: Character space. - tabWidth _ font pointSize * 5 // 2. - xTable _ font xTable! ! -!CharacterScanner methodsFor: 'stop conditions' stamp: 'jmv 9/2/2018 23:46:57' prior: 16802073! - tabDestX - "This is the basic method of adjusting destX for a tab." - - ^paragraphStyle - ifNotNil: [ - paragraphStyle - nextTabXFrom: destX - leftMargin: leftMargin - rightMargin: rightMargin ] - ifNil: [ - "Add the width of a tab for every two chars since last tab, to last tab x position." - (lastIndex - lastTabIndex // 3 + 1) * tabWidth + lastTabX min: rightMargin ]! ! -!CharacterScanner methodsFor: 'initialization' stamp: 'jmv 9/1/2018 20:32:04' prior: 16802089! - initialize - lastTabIndex _ lastTabX _ destX _ destY _ leftMargin _ rightMargin _ 0.! ! -!CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'jmv 9/2/2018 23:40:08' prior: 16801835! - tab - | currentX | - currentX _ self tabDestX. - lastSpaceOrTabWidth _ currentX - destX max: 0. - currentX >= characterPoint x - ifTrue: [ - lastCharacterWidth _ lastSpaceOrTabWidth. - ^ self crossedX ]. - destX _ currentX. - lastIndex _ lastIndex + 1. - lastTabX _ destX. - lastTabIndex _ lastIndex. - ^false! ! -!CharacterBlockScanner methodsFor: 'scanning' stamp: 'jmv 9/2/2018 23:30:31' prior: 16801846! - characterBlockAtPoint: aPoint index: index in: textLine - "This method is the Morphic characterBlock finder." - | runLength lineStop stopCondition | - line _ textLine. - rightMargin _ line rightMargin. - lastTabIndex _ lastIndex _ line first. - self setFont. - self setStopConditions. - characterIndex _ index. "nil means scanning for point" - characterPoint _ aPoint. - (characterPoint isNil or: [ characterPoint y > line bottom ]) - ifTrue: [ characterPoint _ line bottomRight ]. - (text isEmpty or: [( characterPoint y < line top or: [ characterPoint x < line left ]) - or: [ characterIndex notNil and: [ characterIndex < line first ]]]) - ifTrue: [^ CharacterBlock - stringIndex: line first - text: text - topLeft: line leftMargin@line top - extent: 0 @ line lineHeight - textLine: line]. - lastTabX _ destX _ leftMargin _ line leftMarginForAlignment: alignment. - destY _ line top. - runLength _ text runLengthFor: line first. - lineStop _ characterIndex "scanning for index" - ifNil: [ line last ]. "scanning for point" - runStopIndex _ lastIndex + (runLength - 1) min: lineStop. - lastCharacterWidth _ 0. - spaceCount _ 0. - - self placeEmbeddedObject. - [ - stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex - in: text string rightX: characterPoint x - stopConditions: stopConditions kern: font baseKern. - "see setStopConditions for stopping conditions for character block operations." - lastCharacterWidth _ specialWidth ifNil: [ font widthOf: (text at: lastIndex) ]. - (self perform: stopCondition) ifTrue: [ - ^characterIndex - ifNil: [ "Result for characterBlockAtPoint: " - CharacterBlock - stringIndex: lastIndex - text: text - topLeft: characterPoint - extent: lastCharacterWidth @ line lineHeight - textLine: line ] - ifNotNil: [ "Result for characterBlockForIndex: " - CharacterBlock - stringIndex: characterIndex - text: text - topLeft: characterPoint - extent: lastCharacterWidth @ line lineHeight - textLine: line ]] - ] repeat! ! -!CompositionScanner methodsFor: 'scanning' stamp: 'jmv 9/2/2018 23:27:51' prior: 16822889! - composeFrom: startIndex inRectangle: lineRectangle firstLine: firstLine leftSide: leftSide rightSide: rightSide - - "Answer an instance of TextLineInterval that represents the next line in the paragraph." - | runLength stopCondition xtraSpaceBefore spaceAfterParagraph | - - lastTabIndex _ lastIndex _ startIndex. "scanning sets last index" - destY _ lineRectangle top. - lineHeight _ baseline _ 0. "Will be increased by setFont" - self setFont. - self setStopConditions. - - "Set up margins" - leftMargin _ lineRectangle left. - rightMargin _ lineRectangle right. - xtraSpaceBefore _ 0. - spaceAfterParagraph _ 0. - paragraphStyle ifNotNil: [ - leftSide ifTrue: [ - leftMargin _ leftMargin + - ((firstLine and: [ paragraphStyle isListStyle not ]) - ifTrue: [ paragraphStyle firstIndent ] - ifFalse: [ paragraphStyle restIndent ])]. - rightSide ifTrue: [ - rightMargin _ rightMargin - paragraphStyle rightIndent]. - firstLine ifTrue: [ xtraSpaceBefore _ paragraphStyle spaceBefore ]. - spaceAfterParagraph _ paragraphStyle spaceAfter ]. - lastTabX _ destX _ spaceX _ leftMargin. - - runLength _ text runLengthFor: startIndex. - runStopIndex _ lastIndex + runLength - 1. - line _ (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0) - rectangle: lineRectangle. - line isFirstLine: firstLine. - spaceCount _ 0. - lastLineBreakingSpace _ 0. - leftMargin _ destX. - line leftMargin: leftMargin. - - self placeEmbeddedObject. - [ - stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex - in: text string rightX: rightMargin stopConditions: stopConditions - kern: font baseKern. - "See setStopConditions for stopping conditions for composing." - (self perform: stopCondition) ifTrue: [ - ^ line - lineHeight: lineHeight + xtraSpaceBefore + - (stopCondition == #doNewLine ifTrue: [spaceAfterParagraph] ifFalse: [0]) - baseline: baseline + xtraSpaceBefore ] - ] repeat! ! -!CompositionScanner methodsFor: 'stop conditions' stamp: 'jmv 9/2/2018 23:40:01' prior: 16823086! - tab - "Advance destination x according to tab settings in the current - ParagraphStyle. Answer whether the character has crossed the right edge of - the composition rectangle of the TextComposition." - - destX _ self tabDestX. - destX > rightMargin ifTrue: [^self crossedX]. - lastIndex _ lastIndex + 1. - lastTabX _ destX. - lastTabIndex _ lastIndex. - ^false -! ! -!MorphicScanner methodsFor: 'scanning' stamp: 'jmv 9/2/2018 23:30:05' prior: 50371346! - displayLine: textLine textTopLeft: textTopLeft leftInRun: leftInRun - "The call on the primitive (scanCharactersFrom:to:in:rightX:) will be interrupted according to an array of stop conditions passed to the scanner at which time the code to handle the stop condition is run and the call on the primitive continued until a stop condition returns true (which means the line has terminated). leftInRun is the # of characters left to scan in the current run; when 0, it is time to call setStopConditions." - - "textTopLeft is relative to the morph currently being drawn" - | stopCondition nowLeftInRun startIndex string lastPos x1 | - - topLeft _ textTopLeft. - line _ textLine. - lineY _ line top + textTopLeft y. - rightMargin _ line rightMargin + textTopLeft x. - lastTabIndex _ lastIndex _ line first. - leftInRun <= 0 ifTrue: [ - self setFont. - self setStopConditions ]. - leftMargin _ (line leftMarginForAlignment: alignment) + textTopLeft x. - lastTabX _ destX _ leftMargin. - destY _ lineY + line baseline - font ascent. - - textLine isEmptyLine ifTrue: [ - textLine paragraphStyle ifNotNil: [ :ps | - ps = paragraphStyle ifFalse: [ - foregroundColor _ defaultColor. - self setActualFont: ps font. - ps color ifNotNil: [ :color | self textColor: color ]. - alignment _ ps alignment. - paragraphStyle _ ps. - spaceWidth _ font widthOf: Character space. - xTable _ font xTable. - self setStopConditions. - text ifNotNil: [ destY _ lineY + line baseline - font ascent ]]]. - self displayBulletIfAppropriateFor: textLine textLeft: textTopLeft x. - ^leftInRun ]. - - self displayBulletIfAppropriateFor: textLine textLeft: textTopLeft x. - - leftInRun <= 0 - ifTrue: [nowLeftInRun _ text runLengthFor: lastIndex] - ifFalse: [nowLeftInRun _ leftInRun]. - runStopIndex _ lastIndex + (nowLeftInRun - 1) min: line last. - spaceCount _ 0. - string _ text string. - - self placeEmbeddedObject. - [ - startIndex _ lastIndex. - lastPos _ destX@destY. - stopCondition _ self - scanCharactersFrom: lastIndex to: runStopIndex - in: string rightX: rightMargin stopConditions: stopConditions - kern: font baseKern. - backgroundColor ifNotNil: [ - x1 _ destX. - (Preferences backgroundColorFillsAllBackground and: [startIndex > line last]) ifTrue: [ - x1 _ rightMargin ]. - canvas - fillRectangle: (lastPos corner: x1 @ (line bottom + textTopLeft y)) - color: backgroundColor. - (Preferences backgroundColorFillsAllBackground and: [stopCondition = #tab]) ifTrue: [ - canvas - fillRectangle: (destX @ lastPos y corner: self tabDestX @ (line bottom + textTopLeft y)) - color: backgroundColor ]]. - lastIndex >= startIndex ifTrue: [ - canvas - drawString: string - from: startIndex - to: lastIndex - at: lastPos - font: font - color: foregroundColor ]. - "see setStopConditions for stopping conditions for displaying." - (self perform: stopCondition) ifTrue: [ - "Number of characters remaining in the current run" - ^ runStopIndex - lastIndex ] - ] repeat! ! -!MorphicScanner methodsFor: 'stop conditions' stamp: 'jmv 9/2/2018 23:39:42' prior: 16878154! - tab - destX _ self tabDestX. - lastIndex _ lastIndex + 1. - lastTabX _ destX. - lastTabIndex _ lastIndex. - ^ false! ! - -Object subclass: #CharacterScanner - instanceVariableNames: 'destX lastIndex xTable destY stopConditions text alignment leftMargin rightMargin font line runStopIndex spaceCount spaceWidth tabWidth kern paragraphStyle defaultFont lastTabX lastTabIndex' - classVariableNames: 'DefaultStopConditions StopConditionsWithPaddedSpace StopConditionsWithSpace' - poolDictionaries: '' - category: 'Graphics-Text'! - -!classDefinition: #CharacterScanner category: #'Graphics-Text'! -Object subclass: #CharacterScanner - instanceVariableNames: 'destX lastIndex xTable destY stopConditions text alignment leftMargin rightMargin font line runStopIndex spaceCount spaceWidth tabWidth kern paragraphStyle defaultFont lastTabX lastTabIndex' - classVariableNames: 'DefaultStopConditions StopConditionsWithPaddedSpace StopConditionsWithSpace' - poolDictionaries: '' - category: 'Graphics-Text'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3431-TabColumnsFix-JuanVuletich-2018Sep02-23h10m-jmv.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3430] on 2 September 2018 at 11:54:19 pm'! -!Workspace class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:15:27' prior: 50403871! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'Workspace'. - #object -> Workspace. - #selector -> #openWorkspace. - #icon -> #terminalIcon. - #balloonText -> 'A window for evaluating Smalltalk expressions'. - } asDictionary}`! ! -!Transcripter class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:15:19' prior: 50403884! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Emergency Evaluator'. - #object -> Transcripter. - #selector -> #emergencyEvaluator. - #icon -> #emblemImportantIcon. - #balloonText -> 'When all else fails...'. - } asDictionary}`! ! -!TextEditor class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:14:50' prior: 50403897! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Text Editor'. - #object -> TextEditor. - #selector -> #openTextEditor. - #icon -> #textEditorIcon. - #balloonText -> 'A window for composing text'. - } asDictionary}`! ! -!CodePackageListWindow class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:13:05' prior: 50403922! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Installed Packages'. - #object -> CodePackageListWindow. - #selector -> #openPackageList. - #icon -> #packageIcon. - #balloonText -> 'A tool for managing Packages (optional units of code) installed in the system'. - } asDictionary}`! ! -!BrowserWindow class methodsFor: 'menu-world' stamp: 'HAW 7/6/2018 11:53:52' prior: 50404025! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Browser'. - #object -> BrowserWindow. - #selector -> #openBrowser. - #icon -> #editFindReplaceIcon. - #balloonText -> 'A Smalltalk code browser, for studying and modifying the system'. - } asDictionary}`! ! -!MessageNamesWindow class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:13:59' prior: 50404068! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'Message Names'. - #object -> MessageNamesWindow. - #selector -> #openMessageNames. - #icon -> #inspectIcon. - #balloonText -> 'A tool for finding and editing methods that contain any given keyword in their names.'. - } asDictionary}`! ! -!ChangeSorterWindow class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:12:50' prior: 50404083! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Change Sorter'. - #object -> ChangeSorterWindow. - #selector -> #openChangeSorter. - #icon -> #halfRefreshIcon. - #balloonText -> 'A tool allowing you to view the methods in a Change Set, especially changes to the Base System'. - } asDictionary}`! ! -!FileListWindow class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:13:27' prior: 50404098! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'File List'. - #object -> FileListWindow. - #selector -> #openFileList. - #icon -> #systemFileManagerIcon. - #balloonText -> 'An explorer of the File System'. - } asDictionary}`! ! -!ProcessBrowserWindow class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:14:22' prior: 50404111! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Process Browser'. - #object -> ProcessBrowserWindow. - #selector -> #openProcessBrowser. - #icon -> #systemMonitorIcon. - #balloonText -> 'A tool to monitor and manage Smalltalk processes'. - } asDictionary}`! ! -!TestRunnerWindow class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:14:27' prior: 50404125! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'SUnit Test Runner'. - #object -> TestRunnerWindow. - #selector -> #openTestRunner. - #icon -> #weatherFewCloudsIcon. - #balloonText -> 'Smalltalk''s testing framework'. - } asDictionary}`! ! -!TranscriptWindow class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:15:13' prior: 50404138! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 10. - #itemOrder -> 50. - #label -> 'Transcript'. - #object -> TranscriptWindow. - #selector -> #openTranscript. - #icon -> #printerIcon. - #balloonText -> 'A window showing contents of the System Transcript'. - } asDictionary}`! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3432-FixSomeTabbing-JuanVuletich-2018Sep02-23h47m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3430] on 3 September 2018 at 12:02:50 am'! -!Collection methodsFor: 'converting' stamp: 'jmv 9/3/2018 00:00:57' prior: 50393646! - asDictionary - "Answer a Dictionary. Assume our elements are Associations. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Browser'. - #object -> BrowserWindow. - #selector -> #openBrowser. - #icon -> #editFindReplaceIcon. - #balloonText -> 'A Smalltalk code browser, for studying and modifying the system'. - } asDictionary - " - - ^ self as: Dictionary! ! -!SmalltalkEditor class methodsFor: 'menu' stamp: 'HAW 7/10/2018 19:03:02' prior: 50404627! - smalltalkEditorMenu2Options - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Find...(f)'. - #selector -> #find. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'Find Again (g)'. - #selector -> #findAgain. - #icon -> #systemIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Use Selection for Find (j)'. - #selector -> #setSearchString. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Undo - multiple (z)'. - #selector -> #undo. - #icon -> #undoIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Redo - multiple (Z)'. - #selector -> #redo. - #icon -> #redoIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'Undo / Redo history'. - #selector -> #offerUndoHistory. - #icon -> #changesIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Copy (c)'. - #selector -> #copySelection. - #icon -> #copyIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Cut (x)'. - #selector -> #cut. - #icon -> #cutIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'Paste (v)'. - #selector -> #paste. - #icon -> #pasteIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 40. - #label -> 'Paste without Format'. - #selector -> #pasteString. - #icon -> #pasteIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 50. - #label -> 'Paste...'. - #selector -> #pasteRecent. - #icon -> #worldIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'Toggle WordWrap'. - #selector -> #wrapOnOff. - #icon -> #genericTextIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'Set Font... (k)'. - #selector -> #offerFontMenu. - #icon -> #preferencesDesktopFontIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'Clear Font'. - #selector -> #clearFont. - #icon -> #newIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 40. - #label -> 'Set Default Font...'. - #selector -> #offerDefaultFontMenu. - #icon -> #fontXGenericIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'More...'. - #selector -> #openMenu. - #icon -> #listAddIcon - } asDictionary. - }` -! ! -!SmalltalkEditor class methodsFor: 'menu' stamp: 'jmv 9/2/2018 23:59:47' prior: 50405421! - smalltalkEditorMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Help...'. - #selector -> #openHelp. - #icon -> #helpIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Do it (d)'. - #selector -> #doIt. - #icon -> #doItIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Print it (p)'. - #selector -> #printIt. - #icon -> #printIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'Inspect it (i)'. - #selector -> #inspectIt. - #icon -> #inspectIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 40. - #label -> 'Explore it (I)'. - #selector -> #exploreIt. - #icon -> #exploreIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 50. - #label -> 'Debug it (D)'. - #selector -> #debugIt. - #icon -> #debugIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 60. - #label -> 'Profile it'. - #selector -> #profileIt. - #icon -> #clockIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Explain'. - #selector -> #explain. - #icon -> #helpIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Browse it (b)'. - #selector -> #browseIt. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'Senders of it (n)'. - #selector -> #sendersOfIt. - #icon -> #mailForwardIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 40. - #label -> 'Implementors of it (m)'. - #selector -> #implementorsOfIt. - #icon -> #developmentIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 50. - #label -> 'References to it (N)'. - #selector -> #referencesToIt. - #icon -> #addressBookIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'Method Strings with it (E)'. - #selector -> #methodStringsContainingit. - #icon -> #genericTextIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'Method Source with it'. - #selector -> #methodSourceContainingIt. - #icon -> #scriptIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'Class Comments with it'. - #selector -> #classCommentsContainingIt. - #icon -> #chatIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'Accept (s)'. - #selector -> #acceptContents. - #icon -> #acceptIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'Accept & Run Test in Class (t)'. - #selector -> #acceptAndTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 40. - #label -> 'Accept & Run Test in Category (y)'. - #selector -> #acceptAndTestAll. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 50. - #label -> 'Accept & Debug Test (r)'. - #selector -> #acceptAndDebugTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'More...'. - #selector -> #openMenu2. - #icon -> #listAddIcon - } asDictionary. - }`! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'HAW 7/7/2018 18:45:13' prior: 50403987! - messageListMenu2 - "Fill aMenu with the items appropriate when the shift key is held down" - - ^DynamicMenuBuilder - buildTitled: 'Message List' - targeting: self - collectingMenuOptionsWith: #messageListMenu2Options - changingThemWith: [ :options | - self addExtraMenu2ItemsTo: options. - model canShowMultipleMessageCategories ifTrue: [ - options add: `{ - #itemGroup -> 40. - #itemOrder -> 45. - #label -> 'show category (C)'. - #object -> #model. - #selector -> #showHomeCategory. - #icon -> #packageIcon - } asDictionary` ]]. - - ! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 7/6/2018 12:21:10' prior: 50403034! - classListMenu2Options - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'unsent methods'. - #selector -> #browseUnusedMethods. - #icon -> #junkIcon. - #balloonText -> 'browse all methods defined by this class that have no senders' - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'unreferenced inst vars'. - #selector -> #showUnreferencedInstVars. - #icon -> #junkIcon. - #balloonText -> 'show a list of all instance variables that are not referenced in methods' - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'unreferenced class vars'. - #selector -> #showUnreferencedClassVars. - #icon -> #junkIcon. - #balloonText -> 'show a list of all class variables that are not referenced in methods' - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'subclass template'. - #object -> #model. - #selector -> #makeNewSubclass. - #icon -> #classIcon. - #balloonText -> 'put a template into the code pane for defining of a subclass of this class' - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'sample instance'. - #selector -> #makeSampleInstance. - #icon -> #instanceIcon. - #balloonText -> 'give me a sample instance of this class, if possible' - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'inspect instances'. - #selector -> #inspectInstances. - #icon -> #inspectIcon. - #balloonText -> 'open an inspector on all the extant instances of this class' - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'inspect subinstances'. - #selector -> #inspectSubInstances. - #icon -> #inspectIcon. - #balloonText -> 'open an inspector on all the extant instances of this class and of all of its subclasses' - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'create inst var accessors'. - #object -> #model. - #selector -> #createInstVarAccessors. - #icon -> #sendReceiveIcon. - #balloonText -> 'compile instance-variable access methods for any instance variables that do not yet have them' - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'more...'. - #selector -> #offerClassListMenu. - #icon -> #listAddIcon. - #balloonText -> 'return to the standard class-list menu' - } asDictionary. - }`! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 8/3/2018 14:47:08' prior: 50407713! - classListMenuOptions - - ^ `{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutClass. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 5. - #label -> 'show classes hierarchically'. - #object -> #model. - #selector -> #enableListClassesHierarchically. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 6. - #label -> 'show classes alphabetically'. - #object -> #model. - #selector -> #enableListClassesAlphabetically. - #icon -> #sendReceiveIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'show hierarchy'. - #object -> #model. - #selector -> #hierarchy. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'show definition'. - #object -> #model. - #selector -> #editClass. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'show comment'. - #object -> #model. - #selector -> #editComment. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'inst var refs...'. - #selector -> #browseInstVarRefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'inst var defs...'. - #selector -> #browseInstVarDefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'class var refs...'. - #selector -> #browseClassVarRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 20. - #label -> 'class vars'. - #selector -> #browseClassVariables. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'class refs (N)'. - #selector -> #browseClassRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'rename class ...'. - #object -> #model. - #selector -> #renameClass. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 20. - #label -> 'copy class...'. - #object -> #model. - #selector -> #copyClass. - #icon -> #copyIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 30. - #label -> 'remove class (x)'. - #object -> #model. - #selector -> #removeClass. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 10. - #label -> 'run tests (t)'. - #object -> #model. - #selector -> #runClassTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 20. - #label -> 'more...'. - #selector -> #offerClassListMenu2. - #icon -> #listAddIcon - } asDictionary. - }`. - ! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 7/6/2018 12:24:58' prior: 50403228! - messageCategoryMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'fileOut (o)'. - #object -> #model. - #selector -> #fileOutMessageCategories. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'reorganize'. - #object -> #model. - #selector -> #editMessageCategories. - #icon -> #sendReceiveIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'alphabetize'. - #object -> #model. - #selector -> #alphabetizeMessageCategories. - #icon -> #fontXGenericIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'remove empty categories'. - #object -> #model. - #selector -> #removeEmptyCategories. - #icon -> #listRemoveIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 40. - #label -> 'categorize all uncategorized'. - #object -> #model. - #selector -> #categorizeAllUncategorizedMethods. - #icon -> #packageIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 50. - #label -> 'new category...'. - #object -> #model. - #selector -> #addCategory. - #icon -> #newIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'rename...'. - #object -> #model. - #selector -> #renameCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'remove (x)'. - #object -> #model. - #selector -> #removeMessageCategory. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'run tests (t)'. - #object -> #model. - #selector -> #runMessageCategoryTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - }`. - ! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 7/7/2018 18:22:02' prior: 50403294! - messageListMenu2Options - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'toggle diffing (D)'. - #object -> #model. - #selector -> #toggleDiffing. - #icon -> #switchIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'implementors of sent messages'. - #selector -> #browseAllMessages. - #icon -> #developmentIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'local senders of...'. - #selector -> #browseLocalSendersOfMessages. - #icon -> #mailForwardIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'local implementors of...'. - #selector -> #browseLocalImplementors. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'spawn sub-protocol'. - #selector -> #browseProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'spawn full protocol'. - #selector -> #browseFullProtocol. - #icon -> #speadsheetTemplateIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'sample instance'. - #selector -> #makeSampleInstance. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'inspect instances'. - #selector -> #inspectInstances. - #icon -> #inspectIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'inspect subinstances'. - #selector -> #inspectSubInstances. - #icon -> #inspectIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 40. - #label -> 'change category...'. - #object -> #model. - #selector -> #changeCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 50. - #label -> 'change sets with this method'. - #selector -> #findMethodInChangeSets. - #icon -> #changesIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 60. - #label -> 'revert to previous version'. - #object -> #model. - #selector -> #revertToPreviousVersion. - #icon -> #undoIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'more...'. - #selector -> #openMessageListMenu. - #icon -> #listAddIcon - } asDictionary. - }`! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 8/11/2018 18:51:50' prior: 50408807! - messageListMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'what to show...'. - #selector -> #offerWhatToShowMenu. - #icon -> #preferencesIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'toggle break on entry'. - #object -> #model. - #selector -> #toggleBreakOnEntry. - #icon -> #debugIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'browse method (O)'. - #selector -> #openSingleMessageBrowser. - #icon -> #scriptIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 40. - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutMessage. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'inspect CompiledMethod'. - #object -> #model. - #selector -> #inspectCompiledMethod. - #icon -> #exploreIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'senders of... (n)'. - #selector -> #browseSendersOfMessages. - #icon -> #mailForwardIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'implementors of... (m)'. - #selector -> #browseMessages. - #icon -> #developmentIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'inheritance (i)'. - #selector -> #methodHierarchy. - #icon -> #goDownIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 40. - #label -> 'versions (v)'. - #selector -> #browseVersions. - #icon -> #clockIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'inst var refs...'. - #selector -> #browseInstVarRefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 20. - #label -> 'inst var defs...'. - #selector -> #browseInstVarDefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'class var refs...'. - #selector -> #browseClassVarRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 40. - #label -> 'class variables'. - #selector -> #browseClassVariables. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 50. - #label -> 'class refs (N)'. - #selector -> #browseClassRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'remove method (x)'. - #object -> #model. - #selector -> #removeMessage. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 20. - #label -> 'run test (t)'. - #object -> #model. - #selector -> #runMethodTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 30. - #label -> 'debug test (r)'. - #object -> #model. - #selector -> #debugMethodTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 10. - #label -> 'more...'. - #selector -> #openMessageListMenu2. - #icon -> #listAddIcon - } asDictionary. - }`. - ! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 7/7/2018 19:04:27' prior: 50403511! - systemCatSingletonMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'find class... (f)'. - #selector -> #findClass. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'browse all'. - #selector -> #browseAllClasses. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'browse'. - #selector -> #openSystemCategoryBrowser. - #icon -> #packageIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutSystemCategory. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'update'. - #object -> #model. - #selector -> #updateSystemCategories. - #icon -> #updateIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'rename...'. - #object -> #model. - #selector -> #renameSystemCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'remove'. - #object -> #model. - #selector -> #removeSystemCategory. - #icon -> #deleteIcon - } asDictionary. - }`. - ! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 7/7/2018 19:02:29' prior: 50403559! - systemCategoryMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'find class... (f)'. - #selector -> #findClass. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'recent classes... (r)'. - #object -> #model. - #selector -> #recent. - #icon -> #clockIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'browse all'. - #selector -> #browseAllClasses. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'browse'. - #selector -> #openSystemCategoryBrowser. - #icon -> #packageIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutSystemCategory. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'reorganize'. - #object -> #model. - #selector -> #editSystemCategories. - #icon -> #sendReceiveIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'alphabetize'. - #object -> #model. - #selector -> #alphabetizeSystemCategories. - #icon -> #fontXGenericIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'update'. - #object -> #model. - #selector -> #updateSystemCategories. - #icon -> #updateIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 20. - #label -> 'add item...'. - #object -> #model. - #selector -> #addSystemCategory. - #icon -> #newIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'rename...'. - #object -> #model. - #selector -> #renameSystemCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 40. - #label -> 'remove'. - #object -> #model. - #selector -> #removeSystemCategory. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'move to top'. - #object -> #model. - #selector -> #moveSystemCategoryTop. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 20. - #label -> 'move up'. - #object -> #model. - #selector -> #moveSystemCategoryUp. - #icon -> #goUpIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 30. - #label -> 'move down'. - #object -> #model. - #selector -> #moveSystemCategoryDown. - #icon -> #goDownIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 40. - #label -> 'move to bottom'. - #object -> #model. - #selector -> #moveSystemCategoryBottom. - #icon -> #goBottomIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 10. - #label -> 'run tests (t)'. - #object -> #model. - #selector -> #runSystemCategoryTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - }`. - ! ! -!MessageSetWindow methodsFor: 'menu building' stamp: 'HAW 7/7/2018 18:31:51' prior: 50404039! - addExtraMenu2ItemsTo: options - "The shifted selector-list menu is being built. Add items specific to MessageSet" - - model growable ifTrue: [ - options add: `{ - #itemGroup -> 40. - #itemOrder -> 31. - #label -> 'remove from this browser'. - #object -> #model. - #selector -> #removeMessageFromBrowser. - #icon -> #listRemoveIcon - } asDictionary`. - options add:`{ - #itemGroup -> 40. - #itemOrder -> 32. - #label -> 'filter message list...'. - #selector -> #filterMessageList. - #icon -> #findIcon - } asDictionary` ]. - - options add: `{ - #itemGroup -> 40. - #itemOrder -> 33. - #label -> 'sort by date'. - #object -> #model. - #selector -> #sortByDate. - #icon -> #dateIcon - } asDictionary`. - -! ! -!TheWorldMenu class methodsFor: 'menu building' stamp: 'HAW 7/5/2018 18:37:46' prior: 50403762! - worldMenuOptions - - ^`{{ - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Open...'. - #selector -> #openOpenMenu. - #icon -> #openIcon. - #balloonText -> 'Submenu to open various system tools'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'New morph...'. - #selector -> #newMorph. - #icon -> #morphsIcon. - #balloonText -> 'Offers a variety of ways to create new objects'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Preferences...'. - #selector -> #openPreferencesMenu. - #icon -> #preferencesIcon. - #balloonText -> 'Opens a menu offering many controls over appearance and system preferences.'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'Windows...'. - #selector -> #openWindowsMenu. - #icon -> #windowIcon. - #balloonText -> 'Manage open windows'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 50. - #label -> 'Help...'. - #selector -> #openHelpMenu. - #icon -> #helpIcon. - #balloonText -> 'Opens a menu of useful items for updating the system, determining what version you are running, and much else'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Changes...'. - #selector -> #openChangesMenu. - #icon -> #changesIcon. - #balloonText -> 'Opens a menu of useful tools for dealing with changes'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Debug...'. - #selector -> #openDebugMenu. - #icon -> #debugIcon. - #balloonText -> 'a menu of debugging items'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'Restore Display (r)'. - #object -> #myWorld. - #selector -> #restoreDisplay. - #icon -> #displayIcon. - #balloonText -> 'Repaint the screen -- useful for removing unwanted display artifacts, lingering cursors, etc.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Save'. - #object -> Smalltalk. - #selector -> #saveSession. - #icon -> #saveIcon. - #balloonText -> 'Save the current version of the image on disk'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Save as...'. - #object -> Smalltalk. - #selector -> #saveAs. - #icon -> #saveAsIcon. - #balloonText -> 'Save the current version of the image on disk under a new name.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'Save as New Version'. - #object -> Smalltalk. - #selector -> #saveAsNewVersion. - #icon -> #saveAsNewVersionIcon. - #balloonText -> ('Save the current image a new version-stamped name\and save it under that name on disk.\', - 'Clear all user preferences and user state (class vars).') withNewLines. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 40. - #label -> 'Save and Quit'. - #selector -> #saveAndQuit. - #icon -> #saveAndQuitIcon. - #balloonText -> 'Save the image and quit out of Cuis.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 50. - #label -> 'Quit'. - #selector -> #quitSession. - #icon -> #quitIcon. - #balloonText -> 'Quit out of Cuis.'. - } asDictionary. -}`! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3433-FixSomeTabbing-JuanVuletich-2018Sep02-23h54m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3430] on 3 September 2018 at 12:04:11 am'! -!Number methodsFor: 'printing' stamp: 'jmv 9/3/2018 00:03:09' prior: 50371634! - withBinaryUnitPrefixAndValue: aBlock - " - As in https://en.wikipedia.org/wiki/Binary_prefix - { 0.123456. 1.23456. 12.3456. 123.456. 1234.56. 12345.6. 123456. 1234560. 12345600 } do: [ :n | n withBinaryUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | {value printString, ' ', unitPrefixSymbol. unitPrefixName} print]] - " - | prefixIndex factor nameAndSymbol | - prefixIndex _ self log floor // 3. - prefixIndex _ prefixIndex min: 8 max: 0. - factor _ 1024 raisedToInteger: prefixIndex. - nameAndSymbol _ { - {''. ''}. - {'kibi'. 'Ki'}. - {'mebi'. 'Mi'}. - {'gibi'. 'Gi'}. - {'tebi'. 'Ti'}. - {'pebi'. 'Pi'}. - {'exbi'. 'Ei'}. - {'zebi'. 'Zi'}. - {'yobi'. 'Yi'} - } at: prefixIndex+1. - aBlock value: (self / factor) asIntegerOrFloat value: nameAndSymbol second value: nameAndSymbol first! ! -!Number methodsFor: 'printing' stamp: 'jmv 9/3/2018 00:03:34' prior: 50371662! - withDecimalUnitPrefixAndValue: aBlock - " - As in https://en.wikipedia.org/wiki/Metric_prefix - { 0.00000123456. 0.0000123456. 0.000123456. 0.00123456. 0.0123456. 0.123456. 1.23456. 12.3456. 123.456. 1234.56. 12345.6. 123456. 1234560. 12345600 } do: [ :n | n withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | {value printString, ' ', unitPrefixSymbol. unitPrefixName} print]] - " - | prefixIndex factor nameAndSymbol | - prefixIndex _ self log floor // 3. - prefixIndex _ prefixIndex min: 6 max: -6. - factor _ 1000 raisedToInteger: prefixIndex. - nameAndSymbol _ { - {'atto'. 'a'}. - {'femto'. 'f'}. - {'pico'. 'p'}. - {'nano'. 'n'}. - {'micro'. 'µ'}. - {'milli'. 'm'}. - {''. ''}. - {'kilo'. 'k'}. - {'mega'. 'M'}. - {'giga'. 'G'}. - {'tera'. 'T'}. - {'peta'. 'P'}. - {'exa'. 'E'} - } at: prefixIndex+7. - aBlock value: self asFloat / factor value: nameAndSymbol second value: nameAndSymbol first! ! -!SmalltalkEditor class methodsFor: 'menu' stamp: 'jmv 9/3/2018 00:03:51' prior: 50411091! - smalltalkEditorMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Help...'. - #selector -> #openHelp. - #icon -> #helpIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Do it (d)'. - #selector -> #doIt. - #icon -> #doItIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Print it (p)'. - #selector -> #printIt. - #icon -> #printIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'Inspect it (i)'. - #selector -> #inspectIt. - #icon -> #inspectIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 40. - #label -> 'Explore it (I)'. - #selector -> #exploreIt. - #icon -> #exploreIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 50. - #label -> 'Debug it (D)'. - #selector -> #debugIt. - #icon -> #debugIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 60. - #label -> 'Profile it'. - #selector -> #profileIt. - #icon -> #clockIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Explain'. - #selector -> #explain. - #icon -> #helpIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Browse it (b)'. - #selector -> #browseIt. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'Senders of it (n)'. - #selector -> #sendersOfIt. - #icon -> #mailForwardIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 40. - #label -> 'Implementors of it (m)'. - #selector -> #implementorsOfIt. - #icon -> #developmentIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 50. - #label -> 'References to it (N)'. - #selector -> #referencesToIt. - #icon -> #addressBookIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'Method Strings with it (E)'. - #selector -> #methodStringsContainingit. - #icon -> #genericTextIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'Method Source with it'. - #selector -> #methodSourceContainingIt. - #icon -> #scriptIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'Class Comments with it'. - #selector -> #classCommentsContainingIt. - #icon -> #chatIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'Accept (s)'. - #selector -> #acceptContents. - #icon -> #acceptIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'Accept & Run Test in Class (t)'. - #selector -> #acceptAndTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 40. - #label -> 'Accept & Run Test in Category (y)'. - #selector -> #acceptAndTestAll. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 50. - #label -> 'Accept & Debug Test (r)'. - #selector -> #acceptAndDebugTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'More...'. - #selector -> #openMenu2. - #icon -> #listAddIcon - } asDictionary. - }`! ! -!Transcript class methodsFor: 'preferred protocol' stamp: 'jmv 9/3/2018 00:04:05' prior: 16938264! - clear - - accessSemaphore critical: [ - "Having at least one entry simplifies handling of the entries circular collection" - firstIndex _ 1. - lastIndex _ 1. - entries at: 1 put: 'Transcript'. - unfinishedEntry reset. - lastDisplayPosition _ 0. - - logToFile ifTrue: [ - self filename asFileEntry forceWriteStreamDo: [ :stream | - stream nextPutAll: 'Transcript log started: '. - DateAndTime now printOn: stream. - stream - newLine; - nextPutAll: '------------------------------------------------------------------------'; - newLine ]]]. - self display! ! -!Transcript class methodsFor: 'preferred protocol' stamp: 'jmv 9/3/2018 00:04:08' prior: 16938303! - clearInternal - - accessSemaphore critical: [ - "Having at least one entry simplifies handling of the entries circular collection" - firstIndex _ 1. - lastIndex _ 1. - entries at: 1 put: 'Transcript'. - unfinishedEntry reset. - lastDisplayPosition _ 0 ]. - self display! ! -!PreDebugWindow methodsFor: 'GUI building' stamp: 'jmv 9/3/2018 00:03:40' prior: 16892604! - preDebugButtonSpec - - ^{ - {'Proceed'. #proceed. 'continue execution' }. - {'Abandon'. #abandon. 'abandon this execution by closing this window' }. - {'Debug'. #debug. 'bring up a debugger' } - }! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3434-FixSomeTabbing-JuanVuletich-2018Sep03-00h02m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3430] on 3 September 2018 at 12:07:09 am'! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 9/3/2018 00:05:26' prior: 50410375! - smoothStep - "A Function that is - x <= -1 -> 1 - -1 < x < 1 -> smooth differentiable transition from 1 to 0 - 1 <= x -> 0 - - It is a 'smooth' version of an #negative - Has countless applications. For example in image and signal processing, but also in other fields." - " - | g | - Feature require: 'Morphic-Widgets-Extras'. - g _ FunctionGraphMorph new. - g domain: (-4 to: 4). - g addFunction: [ :x | x abs < 1 ifTrue: [1] ifFalse:[0] ] color: Color brown. - g addFunction: [ :x | x smoothStep ] color: Color red. - (g embeddedInMorphicWindowLabeled: 'graph') openInWorld - " - self > -1 ifFalse: [ ^ 1 ]. - 1 > self ifFalse: [ ^ 0 ]. - ^ (self +2 * Float halfPi) sin * 0.5 + 0.5! ! -!PluggableScrollPane methodsFor: 'events' stamp: 'jmv 9/3/2018 00:05:46' prior: 50374226! - mouseScroll: aMouseEvent localPosition: localEventPosition - aMouseEvent direction - caseOf: { - [ #up ] -> [ scrollBar scrollUp: 1 ]. - [ #down ] -> [ scrollBar scrollDown: 1 ]. - [ #left ] -> [ hScrollBar scrollUp: 1 ]. - [ #right ] -> [ hScrollBar scrollDown: 1 ] }! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 9/3/2018 00:06:36' prior: 50396936! - helpMenu - "Build the help menu for the world." - - ^ (self menu: 'Help...') - addItemsFromDictionaries: `{ - { - #label -> 'About this System...'. - #object -> Smalltalk. - #selector -> #aboutThisSystem. - #icon -> #helpIcon. - #balloonText -> 'current version information.' - } asDictionary. - { - #label -> 'Terse Guide to Cuis'. - #selector -> #openTerseGuide. - #icon -> #helpIcon. - #balloonText -> 'explore Cuis Smalltalk' - } asDictionary. - { - #label -> 'Class Comment Browser'. - #selector -> #openCommentGuide. - #icon -> #helpIcon. - #balloonText -> 'search & explore Cuis Class Comments' - } asDictionary. - { - #label -> 'Code management in Cuis'. - #object -> Utilities. - #selector -> #openCodeManagementInCuis. - #icon -> #helpIcon. - #balloonText -> 'Features are kept in Packages.' - } asDictionary. - { - #label -> 'Using GitHub to host Cuis packages'. - #object -> Utilities. - #selector -> #openCuisAndGitHub. - #icon -> #helpIcon. - #balloonText -> 'GitHub usage pattern.' - } asDictionary. - nil. - { - #label -> 'Editor keyboard shortcuts'. - #object -> SmalltalkEditor. - #selector -> #openHelp. - #icon -> #keyboardShortcutsIcon. - #balloonText -> 'summary of keyboard shortcuts in editors for Smalltalk code.' - } asDictionary. - { - #label -> 'Useful Expressions'. - #object -> Utilities. - #selector -> #openUsefulExpressions. - #icon -> #chatIcon. - #balloonText -> 'a window full of useful expressions.' - } asDictionary. - nil. - { - #label -> 'VM Statistics'. - #selector -> #vmStatistics. - #icon -> #systemMonitorIcon. - #balloonText -> 'obtain some intriguing data about the vm.' - } asDictionary. - { - #label -> 'Space Left'. - #selector -> #garbageCollect. - #icon -> #removableMediaIcon. - #balloonText -> 'perform a full garbage-collection and report how many bytes of space remain in the image.' - } asDictionary. - }`! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3435-FixSomeTabbing-JuanVuletich-2018Sep03-00h04m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3430] on 3 September 2018 at 12:08:37 am'! -!LayoutSpec commentStamp: 'jmv 9/3/2018 00:07:43' prior: 16864138! - LayoutSpecs are the basis for the layout mechanism. Any Morph can be given a LayoutSpec, but in order to honor it, its owner must be a LayoutMorph. - -A LayoutSpec specifies how a morph wants to be layed out. It can specify either a fixed width or a fraction of some available owner width. Same goes for height. If a fraction is specified, a minimum extent is also possible. - - -Alternatives: - - proportionalWidth notNil, fixedWidth notNil -> Use fraction of available space, take fixedWidth as minimum desired width - - proportionalWidth isNil, fixedWidth isNil -> Use current morph width - - proportionalWidth isNil, fixedWidth notNil -> Use fixedWidth - - proportionalWidth notNil, fixedWidth isNil -> NOT VALID - -Same goes for proportionalHeight and fixedHeight -! -!LayoutSpec methodsFor: 'accessing' stamp: 'jmv 9/3/2018 00:08:13' prior: 16864261! - proportionalWidth: aNumberOrNil minimum: otherNumberOrNil - "Alternatives: - - proportionalWidth notNil, fixedWidth notNil -> Use fraction of available space, take fixedWidth as minimum desired width - - proportionalWidth isNil, fixedWidth isNil -> Use current morph width - - proportionalWidth isNil, fixedWidth notNil -> Use fixedWidth - - proportionalWidth notNil, fixedWidth isNil -> NOT VALID" - proportionalWidth _ aNumberOrNil. - fixedWidth _ otherNumberOrNil! ! -!LayoutSpec methodsFor: 'accessing' stamp: 'jmv 9/3/2018 00:08:20' prior: 16864285! - setProportionalWidth: aNumberOrNil - "Alternatives: - - proportionalWidth notNil, fixedWidth notNil -> Use fraction of available space, take fixedWidth as minimum desired width - - proportionalWidth isNil, fixedWidth isNil -> Use current morph width - - proportionalWidth isNil, fixedWidth notNil -> Use fixedWidth - - proportionalWidth notNil, fixedWidth isNil -> NOT VALID" - proportionalWidth _ aNumberOrNil! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3436-FixSomeTabbing-JuanVuletich-2018Sep03-00h07m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3436] on 6 September 2018 at 6:13:28 pm'! -!SmalltalkEditor methodsFor: 'typing/selecting keys' stamp: 'jmv 9/6/2018 17:51:29'! - argNext: aKeyboardEvent - "Invoked by cmd-A. - Search forward from the end of the selection for a colon followed by - a space. Place the text cursor after the space. If none are found, place the - text cursor at the end of the text.." - - | start t | - t _ model actualContents. - start _ t findString: ': ' startingAt: self startIndex. - start = 0 ifTrue: [ start _ t size + 1]. - self deselectAndPlaceCursorAt: start + 2. - ^true! ! -!SmalltalkEditor methodsFor: 'typing/selecting keys' stamp: 'jmv 9/6/2018 18:09:53'! - argPrev: aKeyboardEvent - "Invoked by cmd-Q. - Search backwards from the start of the selection for a colon followed by - a space. Place the text cursor after the space. If none are found, place the - text cursor at the start of the text.." - - | t i | - t _ model actualContents. - i _ self stopIndex. - i > 1 ifTrue: [ - i _ i -2. - [i > 0 and: [ (t at: i) ~= $ or: [(t at: i-1) ~= $: ]]] whileTrue: [ - i _ i -1 ]. - self deselectAndPlaceCursorAt: i + 1. - ]. - ^true! ! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'jmv 9/6/2018 17:56:10' prior: 16906691! - quickFindLast: aBlock - "Return the index of my last element for which aBlock evaluates as true. - Assumes that receiver is sorted according with aBlock. Then, we are able to use faster binary search. - Result is (in these cases) the same as #findLast: - - 1 to: 1000 :: findLast: [:x | x squared < 123456] - 1 to: 1000 :: quickFindLast: [:x | x squared < 123456] - - 1 to: 1000 :: findLast: [:x | x squared < -10] - 1 to: 1000 :: quickFindLast: [:x | x squared < -10] - - 1 to: 1000 :: findLast: [:x | x squared < 1234560] - 1 to: 1000 :: quickFindLast: [:x | x squared < 1234560] - " - ^self - findBinaryIndex: [ :x | (aBlock value: x) ifTrue: [1] ifFalse: [-1]] - do: [ :i | ] - ifNone: [ :i1 :i2 | i1 ]! ! -!SmalltalkEditor methodsFor: 'typing/selecting keys' stamp: 'jmv 9/6/2018 17:47:15' prior: 16910004! - displayIfFalse: aKeyboardEvent - "Replace the current text selection with the text 'ifFalse:'--initiated by - cmd-F." - - self addString: 'ifFalse:'. - ^false! ! -!SmalltalkEditor methodsFor: 'typing/selecting keys' stamp: 'jmv 9/6/2018 17:47:27' prior: 16910012! - displayIfTrue: aKeyboardEvent - "Replace the current text selection with the text 'ifTrue:'--initiated by - cmd-T." - - self addString: 'ifTrue:'. - ^false! ! -!SmalltalkEditor class methodsFor: 'keyboard shortcut tables' stamp: 'jmv 9/6/2018 17:50:48' prior: 50405368! - cmdShortcutsSpec - " - Editor initialize - " - "arranged in QWERTY keyboard order" - ^#( - #( $r #acceptAndDebugTest: 'Saves method and debugs it') - #( $t #acceptAndTest: 'Saves method, runs it as test and then all tests in class. Opens debugger if error') - #( $y #acceptAndTestAll: 'Saves method, runs it as test and then all tests in class category. Opens debugger if error') - #( $i #inspectIt: 'Inspect it (selection is a valid expression, or selection is over an inspect-ilst)') - #( $p #printIt: 'Print it (selection is a valid expression)') - - #( $s #save: 'Save (i.e. accept)') - #( $d #doIt: 'Do it (selection is a valid expression)') - - #( $b #browseIt: 'Browse it (selection is a class name or cursor is over a class-list or message-list)') - #( $n #sendersOfIt: 'Senders of it (selection is a message selector or cursor is over a class-list or message-list)') - #( $m #implementorsOfIt: 'Implementors of it (selection is a message selector or cursor is over a class-list or message-list)') - - #( $E #methodStringsContainingit:'Method strings containing it') - #( $T #displayIfTrue: 'Insert #ifTrue:') - #( $I #exploreIt: 'Inspect via Object Explorer') - - #( $Q #argPrev: 'Previous argument') - #( $A #argNext: 'Next argument') - #( $D #debugIt: 'Debug it') - #( $F #displayIfFalse: 'Insert #ifFalse:') - #( $G #fileItIn: 'File in selection') - - #( $V #pasteInitials: 'Paste author initials') - #( $N #referencesToIt: 'References to it (selection is a class name, or cursor is over a class-list or message-list)') - )! ! -!AutoCompleter methodsFor: 'keyboard' stamp: 'jmv 9/6/2018 17:40:31' prior: 50366945! -handleKeystrokeBefore: kbEvent - "I return a boolean. true when I have handled the event and no futher processing is needed by the caller." - | currentPos currentChar currentCharIsAlphaNumericOrColon keyValue ctrl cmd tab colon alphanum backspace esc space return keyChar | - currentPos _ textMorph editor startIndex-1. - currentCharIsAlphaNumericOrColon _ currentPos > 0 and: [ model textSize >= currentPos and: [ - currentChar _ model actualContents at: currentPos. currentChar isAlphaNumeric | (currentChar == $:) ]]. - keyValue _ kbEvent keyValue. - keyChar _ kbEvent keyCharacter. - ctrl _ kbEvent controlKeyPressed. - cmd _ kbEvent commandAltKeyPressed. - tab _ keyChar = Character tab. - colon _ keyChar = $:. - alphanum _ kbEvent keyCharacter isAlphaNumeric. - backspace _ keyValue = 8. - esc _ keyValue = 27. - space _ #(0 32 160) includes: keyValue. - return _ kbEvent isReturnKey. - - "Stuff to do if the menu is not open" - menuMorph ifNil: [ - "Ctrl-Space or Tab for open" - "Mac specific note: Using option-space (actually option+160) effectively disables the non-breaking space character 160" - (space & (ctrl | kbEvent rawMacOptionKeyPressed) or: [ - (self opensWithTab and: [tab]) and: [ currentCharIsAlphaNumericOrColon ]]) - ifTrue: [ self openCompletionMenu. ^ true]. - "Auto-open - currently deactivated" -" (ctrl not & cmd not & alphanum) - ifTrue: [ self openCompletionMenu ]." - ^ false]. - - "Starting here, stuff to do if the menu is open" - menuMorph stillActive. - "Escape" - esc ifTrue: [ self closeMenu. ^ true]. - "Backspace" - backspace ifTrue: [ - currentCharIsAlphaNumericOrColon ifFalse: [ self closeMenu ]. - ^ false]. - "Home" - keyValue = 1 ifTrue: [ menuMorph goHome. ^ true ]. - "End" - keyValue = 4 ifTrue: [ menuMorph goToEnd. ^ true]. - "?" - keyChar = $? ifTrue: [ menuMorph help. ^true]. - "Arrow up" - keyValue = 30 ifTrue: [ menuMorph goUp. ^ true]. - "Arrow down" - keyValue = 31 ifTrue: [ menuMorph goDown. ^ true]. - "Page up" - keyValue = 11 ifTrue: [ menuMorph goPageUp. ^ true]. - "Page down" - keyValue = 12 ifTrue: [ menuMorph goPageDown. ^ true]. - "Return, Tab or Ctrl-Space" - (return or: [ space & (ctrl | kbEvent rawMacOptionKeyPressed) or: [ tab]]) ifTrue: [ - self insertSelected - ifTrue: [^ true]]. - "All keys but the alphanumeric chars (without command and control ) - and the backspace key do close the menu" - (ctrl not & cmd not and: [ alphanum | colon]) - ifFalse: [ self closeMenu ]. - ^false! ! - -SmalltalkEditor removeSelector: #argAdvance:! - -SmalltalkEditor removeSelector: #argAdvance:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3437-NextArgument-PreviousArgument-JuanVuletich-2018Sep06-18h13m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3437] on 10 September 2018 at 9:12:16 am'! -!Time class methodsFor: 'smalltalk-80' stamp: 'jmv 9/10/2018 09:11:34' prior: 16937449! - readFrom: aStream - "Read a Time from the stream in the form: - :: - - , or may be omitted. e.g. 1:59:30 pm; 8AM; 15:30" - - | hour minute second ampm nanos nanosBuffer | - hour := Integer readFrom: aStream. - minute := 0. - second := 0. - nanosBuffer := '000000000' copy. - nanos := WriteStream on: nanosBuffer. - (aStream peekFor: $:) - ifTrue: [ - minute := Integer readFrom: aStream. - (aStream peekFor: $:) - ifTrue: [ - second := Integer readFrom: aStream]. - (aStream peekFor: $.) - ifTrue: [ - [aStream atEnd not and: [aStream peek isDigit]] - whileTrue: [nanos nextPut: aStream next]]]. - aStream skipSeparators. - (aStream atEnd not and: [aStream peek isLetter]) ifTrue: - [ampm := aStream next asLowercase. - - (ampm = $p and: [hour < 12]) ifTrue: [hour := hour + 12]. - (ampm = $a and: [hour = 12]) ifTrue: [hour := 0]. - - (aStream peekFor: $m) ifFalse: [aStream peekFor: $M ]]. - ^ self - hour: hour - minute: minute - second: second - nanoSecond: nanosBuffer asNumber - - "Time readFrom: (ReadStream on: '2:23:09 pm')"! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3438-Avoid-String-asInteger-JuanVuletich-2018Sep10-09h10m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3437] on 10 September 2018 at 9:10:09 am'! - -ImageReadWriter removeSelector: #space! - -ImageReadWriter removeSelector: #space! - -ImageReadWriter removeSelector: #tab! - -ImageReadWriter removeSelector: #tab! - -Stream removeSelector: #nextNumber! - -Stream removeSelector: #nextNumber! - -Stream removeSelector: #nextNumber:! - -Stream removeSelector: #nextNumber:! - -Stream removeSelector: #nextNumber:put:! - -Stream removeSelector: #nextNumber:put:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3439-Cleanup-JuanVuletich-2018Sep10-09h04m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3439] on 10 September 2018 at 9:16:29 am'! -!Integer class methodsFor: 'instance creation' stamp: 'GC 9/10/2018 00:18:57' prior: 50331667! - readFrom: aStream base: base - "Answer an instance of one of my concrete subclasses. Initial minus sign - accepted, and bases > 10 use letters A-Z. Embedded radix specifiers not - allowed--use Number readFrom: for that. Raises an error if - there are no digits." - - | digit value neg cc atLeastOneDigitRead | - - (aStream atEnd) ifTrue: [ self error: 'At least one digit expected here' ]. - - neg _ aStream peekFor: $-. - neg ifFalse: [aStream peekFor: $+]. - value _ 0. - atLeastOneDigitRead _ false. - [ aStream atEnd ] - whileFalse: [ - cc _ aStream next. - digit _ cc digitValue. - (digit < 0 or: [digit >= base]) - ifTrue: [ - aStream skip: -1. - atLeastOneDigitRead ifFalse: [self error: 'At least one digit expected here']. - ^neg - ifTrue: [value negated] - ifFalse: [value]]. - value _ value * base + digit. - atLeastOneDigitRead _ true ]. - neg ifTrue: [^ value negated]. - ^ value! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3440-Integer-readFrom-ErrorIfEmpty-GastonCaruso-2018Sep10-09h16m-GC.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3437] on 10 September 2018 at 10:25:41 am'! -!TestSuite class methodsFor: 'Creation - Private' stamp: 'jmv 9/10/2018 10:24:54' prior: 50338367! -forTestCaseClasses: testCaseClasses named: aName - - | suite | - suite _ self named: aName. - testCaseClasses do: [ :aTestCaseClass | - aTestCaseClass isAbstract - ifFalse: [ aTestCaseClass addToSuiteFromSelectors: suite ]]. - - ^suite! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3441-TestSystemCategory-fix-JuanVuletich-2018Sep10-10h16m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3440] on 10 September 2018 at 12:01:49 pm'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 9/10/2018 12:01:33' prior: 50401204! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3442-AddGastonAsAuthor-JuanVuletich-2018Sep10-10h35m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3442] on 16 September 2018 at 10:20:05 am'! -!PseudoClass methodsFor: 'accessing' stamp: 'JO 9/16/2018 10:19:39'! - variablesAndOffsetsDo: aBinaryBlock - "NOp"! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3443-PackageFileBrowserFix-JavierOlaechea-2018Sep16-10h19m-JO.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3443] on 16 September 2018 at 10:48:40 am'! -!Theme methodsFor: 'icons' stamp: 'jmv 9/16/2018 10:45:54'! - resizeBottomIcon - ^nil! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/16/2018 10:46:11'! - resizeBottomLeftIcon - ^nil! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/16/2018 10:46:15'! - resizeBottomRightIcon - ^nil! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/16/2018 10:45:41'! - resizeFullIcon - ^nil! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/16/2018 10:45:50'! - resizeLeftIcon - ^nil! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/16/2018 10:45:59'! - resizeRightIcon - ^nil! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/16/2018 10:45:46'! - resizeTopIcon - ^nil! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/16/2018 10:46:03'! - resizeTopLeftIcon - ^nil! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/16/2018 10:46:07'! - resizeTopRightIcon - ^nil! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3444-PlaceholdersForResizeWindowIcons-JuanVuletich-2018Sep16-10h48m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3368] on 14 September 2018 at 9:47:11 pm'! - -BorderedRectMorph subclass: #TileResizeMorph - instanceVariableNames: 'selectedResize selectionColor action' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #TileResizeMorph category: #'Morphic-Views'! -BorderedRectMorph subclass: #TileResizeMorph - instanceVariableNames: 'selectedResize selectionColor action' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! -!Preferences class methodsFor: 'get/set' stamp: 'MM 9/14/2018 10:03:28'! - disableTileResizerInWindowMenu - - Preferences disable: #tileResizerInWindowMenu.! ! -!Preferences class methodsFor: 'get/set' stamp: 'MM 9/14/2018 10:03:16'! - enableTileResizerInWindowMenu - - Preferences enable: #tileResizerInWindowMenu.! ! -!TileResizeMorph methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 09:40:43'! - action: aBlock - action _ aBlock! ! -!TileResizeMorph methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 11:34:14'! - drawOn: aCanvas - - super drawOn: aCanvas. - - selectedResize ifNil: [^ self]. - - aCanvas fillRectangle: (self selectionRectangle: selectedResize) - color: selectionColor - borderWidth: borderWidth - borderStyleSymbol: #simple - baseColorForBorder: borderColor.! ! -!TileResizeMorph methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 09:41:56'! - handlesMouseDown: aMouseButtonEvent - - ^ true! ! -!TileResizeMorph methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 09:44:47'! - handlesMouseHover - ^ true! ! -!TileResizeMorph methodsFor: 'as yet unclassified' stamp: 'MM 9/14/2018 18:08:50'! - initialize - - super initialize. - extent _ 120@60. - color _ Color white. - selectionColor _ Color lightYellow . - self borderColor: Color black. - self borderWidth: 1.! ! -!TileResizeMorph methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 11:20:20'! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - self selectResize: localEventPosition! ! -!TileResizeMorph methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 11:20:57'! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - self selectResize: localEventPosition. - action ifNotNil: [ - action value: selectedResize. - self delete]! ! -!TileResizeMorph methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 11:10:21'! - mouseHover: aMouseButtonEvent localPosition: localEventPosition - self selectResize: localEventPosition! ! -!TileResizeMorph methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 11:37:24'! - resizeAtPoint: aPoint - - |region| - - region _ (aPoint min: extent - 1) // (extent // 3). - - ^ region caseOf: { - [0@0] -> [#topLeft]. - [1@0] -> [#top]. - [2@0] -> [#topRight]. - [0@1] -> [#left]. - [1@1] -> [#full]. - [2@1] -> [#right]. - [0@2] -> [#bottomLeft]. - [1@2] -> [#bottom]. - [2@2] -> [#bottomRight]. - } otherwise: [nil]! ! -!TileResizeMorph methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 11:03:57'! - selectResize: localEventPosition - - | newResize | - - newResize _ self resizeAtPoint: localEventPosition. - newResize ~= selectedResize ifTrue: [ - selectedResize _ newResize. - self redrawNeeded]! ! -!TileResizeMorph methodsFor: 'as yet unclassified' stamp: 'MM 9/14/2018 18:10:14'! - selectionColor: aColor - - selectionColor _ aColor! ! -!TileResizeMorph methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 11:33:29'! - selectionRectangle: region - - ^ region caseOf: { - [#topLeft] -> [0@0 corner: (extent // 2)]. - [#top] -> [0@0 corner: (extent x@(extent y // 2))]. - [#topRight] -> [(extent x // 2)@0 corner: (extent x@(extent y // 2))]. - [#left] -> [0@0 corner: (extent x // 2)@extent y]. - [#full] -> [0@0 corner: extent]. - [#right] -> [(extent x // 2)@0 corner: extent]. - [#bottomLeft] -> [0@(extent y // 2) corner: (extent x // 2)@extent y]. - [#bottomRight] -> [(extent x // 2)@(extent y // 2) corner: extent]. - [#bottom] -> [0@(extent y // 2) corner: extent]. - }! ! -!TileResizeMorph class methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 16:11:37'! - calculateTileRegions: aNumber - - ^ self calculateTileRegionsIn: Display boundingBox by: aNumber! ! -!TileResizeMorph class methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 18:25:19'! - calculateTileRegionsHorizontallyIn: aRectangle by: aNumber - - | rects rects1 rects2 | - aNumber <= 2 ifTrue: [^ self divideRectHorizontally: aRectangle by: aNumber]. - - rects _ self divideRectHorizontally: aRectangle by: 2. - - rects1 _ self calculateTileRegionsVerticallyIn: rects first by: aNumber // 2. - rects2 _ self calculateTileRegionsVerticallyIn: rects second by: (aNumber - (aNumber // 2)). - - ^ rects1, rects2! ! -!TileResizeMorph class methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 16:13:08'! - calculateTileRegionsIn: aRectangle by: aNumber - - ^ self calculateTileRegionsHorizontallyIn: aRectangle by: aNumber! ! -!TileResizeMorph class methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 16:20:53'! - calculateTileRegionsVerticallyIn: aRectangle by: aNumber - - | rects rects1 rects2 | - aNumber <= 3 ifTrue: [^ self divideRectVertically: aRectangle by: aNumber]. - - rects _ self divideRectVertically: aRectangle by: 2. - - rects1 _ self calculateTileRegionsHorizontallyIn: rects first by: aNumber // 2. - rects2 _ self calculateTileRegionsHorizontallyIn: rects second by: (aNumber - (aNumber // 2)). - - ^ rects1, rects2! ! -!TileResizeMorph class methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 16:08:58'! - divideRectHorizontally: aRectangle by: aNumber - - | w x rects | - - x _ aRectangle origin x. - w _ aRectangle width // aNumber. - rects _ OrderedCollection new. - - aNumber timesRepeat: [ |rect| - rect _ Rectangle origin: x@aRectangle origin y extent: w@aRectangle height. - x _ x + w. - rects add: rect]. - - ^ rects - - ! ! -!TileResizeMorph class methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 16:10:57'! - divideRectVertically: aRectangle by: aNumber - - | h y rects | - - y _ aRectangle origin y. - h _ aRectangle height // aNumber. - rects _ OrderedCollection new. - - aNumber timesRepeat: [ |rect| - rect _ Rectangle origin: aRectangle origin x@y extent: aRectangle width@h. - y _ y + h. - rects add: rect]. - - ^ rects - - ! ! -!TileResizeMorph class methodsFor: 'as yet unclassified' stamp: 'MM 9/14/2018 10:01:07'! - initialize - - Preferences - addPreference: #tileResizerInWindowMenu - category: #gui - default: true - balloonHelp: 'If enabled, a tile resizer morph is embedded in windows menus.' withNewLines! ! -!TileResizeMorph class methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 15:59:18'! - tileOpenWindows - - |windows regions i | - - windows _ (SystemWindow - windowsIn: self runningWorld - satisfying: [ :w | w visible]). - - regions _ self calculateTileRegions: windows size. - - i _ 1. - windows do: [:w | |r| - r _ regions at: i. - w resize: r. - i _ i + 1]! ! -!SystemWindow methodsFor: 'menu' stamp: 'MM 9/14/2018 18:21:38' prior: 50399923! - buildWindowMenu - - | aMenu | - - aMenu _ MenuMorph new defaultTarget: self. - - aMenu - add: 'change title...' action: #relabel icon: #saveAsIcon; - add: 'window color...' action: #setWindowColor icon: #graphicsIcon; - addLine; - add: 'send to back' action: #sendToBack icon: #goBottomIcon; - add: 'make next-to-topmost' action: #makeSecondTopmost icon: #goUpIcon; - addLine; - add: (self isSticky ifTrue: [ 'make draggable' ] ifFalse: [ 'make undraggable' ]) - action: #toggleStickiness icon: (self isSticky ifFalse: [#pushPinIcon]); - addLine; - add: 'close' action: #delete icon: #closeIcon; - add: 'collapse' action: #collapse icon: #collapseIcon; - add: 'expand / contract' action: #expandBoxHit icon: #expandIcon; - addLine; - add: 'resize...' action: #resize. - "We can look at preferences here to decide what too do" - (Preferences tileResizerInWindowMenu) ifFalse: [ - aMenu add: 'resize full' action: #resizeFull icon: #resizeFullIcon; - add: 'resize top' action: #resizeTop icon: #resizeTopIcon; - add: 'resize left' action: #resizeLeft icon: #resizeLeftIcon; - add: 'resize bottom' action: #resizeBottom icon: #resizeBottomIcon; - add: 'resize right' action: #resizeRight icon: #resizeRightIcon; - add: 'resize top left' action: #resizeTopLeft icon: #resizeTopLeftIcon; - add: 'resize top right' action: #resizeTopRight icon: #resizeTopRightIcon; - add: 'resize bottom left' action: #resizeBottomLeft icon: #resizeBottomLeftIcon; - add: 'resize bottom right' action: #resizeBottomRight icon: #resizeBottomRightIcon] - ifTrue: [ |resizeMorph| - "Use embedded resize morph" - resizeMorph _ TileResizeMorph new - selectionColor: (self widgetsColor adjustSaturation: -0.2 brightness: 0.25) ; - action: [:resize | |resizeMsg| - resizeMsg _ ('resize', resize asString capitalized) asSymbol. - self perform: resizeMsg. - aMenu delete]; - yourself. - aMenu addMorphBack: resizeMorph]. - - ^ aMenu! ! -!TheWorldMenu methodsFor: 'windows & flaps menu' stamp: 'MM 9/14/2018 21:42:58' prior: 50397144! - windowsMenu - "Build the windows menu for the world." - - ^ (self menu: 'Windows') - addItemsFromDictionaries: `{ - { - #label -> 'Find Window'. - #object -> #myWorld. - #selector -> #findWindow:. - #icon -> #windowIcon. - #balloonText -> 'Presents a list of all windows; if you choose one from the list, it becomes the active window.' - } asDictionary. - { - #label -> 'Find changed Browsers...'. - #object -> #myWorld. - #selector -> #findDirtyBrowsers:. - #icon -> #editFindReplaceIcon. - #balloonText -> 'Presents a list of browsers that have unsubmitted changes; if you choose one from the list, it becomes the active window.' - } asDictionary. - { - #label -> 'Find changed Windows...'. - #object -> #myWorld. - #selector -> #findDirtyWindows:. - #icon -> #newWindowIcon. - #balloonText -> 'Presents a list of all windows that have unsubmitted changes; if you choose one from the list, it becomes the active window.' - } asDictionary. - nil. - { - #label -> 'Find a Transcript'. - #object -> #myWorld. - #selector -> #findATranscript:. - #icon -> #printerIcon. - #balloonText -> 'Brings an open Transcript to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find a FileList'. - #object -> #myWorld. - #selector -> #findAFileList:. - #icon -> #systemFileManagerIcon. - #balloonText -> 'Brings an open fileList to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find a Change Sorter'. - #object -> #myWorld. - #selector -> #findAChangeSorter:. - #icon -> #changesIcon. - #balloonText -> 'Brings an open change sorter to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find Message Names'. - #object -> #myWorld. - #selector -> #findAMessageNamesWindow:. - #icon -> #inspectIcon. - #balloonText -> 'Brings an open MessageNames window to the front, creating one if necessary, and makes it the active window' - } asDictionary. - nil. - { - #label -> 'Tile open windows'. - #object -> TileResizeMorph. - #selector -> #tileOpenWindows. - #icon -> #windowIcon. - #balloonText -> 'Tile open windows'. - } asDictionary. - { - #label -> 'Collapse all Windows'. - #object -> #myWorld. - #selector -> #collapseAll. - #icon -> #collapseIcon. - #balloonText -> 'Reduce all open windows to collapsed forms that only show titles.' - } asDictionary. - { - #label -> 'Restore all Windows'. - #object -> #myWorld. - #selector -> #restoreAll. - #icon -> #expandIcon. - #balloonText -> 'Restore all collapsed windows back to their previous forms.' - } asDictionary. - { - #label -> 'Close top Window'. - #object -> SystemWindow. - #selector -> #closeTopWindow. - #icon -> #closeIcon. - #balloonText -> 'Close the topmost window if possible.' - } asDictionary. - { - #label -> 'Send top Window to back'. - #object -> SystemWindow. - #selector -> #sendTopWindowToBack. - #icon -> #goBottomIcon. - #balloonText -> 'Make the topmost window become the backmost one, and activate the window just beneath it.' - } asDictionary. - { - #label -> 'Move Windows onscreen'. - #object -> #myWorld. - #selector -> #bringWindowsFullOnscreen. - #icon -> #displayIcon. - #balloonText -> 'Make all windows fully visible on the screen' - } asDictionary. - nil. - { - #label -> 'Delete unchanged Windows'. - #object -> #myWorld. - #selector -> #closeUnchangedWindows. - #icon -> #warningIcon. - #balloonText -> 'Deletes all windows that do not have unsaved text edits.' - } asDictionary. - { - #label -> 'Delete non Windows'. - #object -> #myWorld. - #selector -> #deleteNonWindows. - #icon -> #warningIcon. - #balloonText -> 'Deletes all non-window morphs lying on the world.' - } asDictionary. - { - #label -> 'Delete Both of the Above'. - #selector -> #cleanUpWorld. - #icon -> #warningIcon. - #balloonText -> 'Deletes all unchanged windows and also all non-window morphs lying on the world, other than flaps.' - } asDictionary. - }`! ! - -TileResizeMorph initialize! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3445-TileWindowResize-MarianoMontone-2018Sep13-01h34m-MM.4.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3430] on 18 September 2018 at 5:08:42 pm'! -!Stream methodsFor: 'nonhomogeneous accessing' stamp: 'jmv 9/18/2018 17:08:36'! - nextNumber - "Answer a number from the (text) stream." - - |element| - [(element := self next) isNil or: [element isDigit or: [element = $- or: [element = $)]]]] whileFalse. - element ifNil: [^nil]. - self skip: -1. - element = $) ifTrue: [^nil]. - ^Number readFrom: self! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3446-Reintroduce-Stream-nextNumber-JuanVuletich-2018Sep18-17h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3445] on 17 September 2018 at 5:37:57 pm'! -!TileResizeMorph class methodsFor: 'as yet unclassified' stamp: 'MM 9/17/2018 17:36:57' prior: 50413245! - tileOpenWindows - - |windows regions i | - - windows _ (SystemWindow - windowsIn: self runningWorld - satisfying: [ :w | w visible]). - - windows ifEmpty: [^ self]. - - regions _ self calculateTileRegions: windows size. - - i _ 1. - windows do: [:w | |r| - r _ regions at: i. - w resize: r. - i _ i + 1]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3447-tileWindowsFixWhenNoWindows-MarianoMontone-2018Sep17-17h36m-MM.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3430] on 19 September 2018 at 10:17:16 am'! -!ContentPack methodsFor: 'exporting' stamp: 'jmv 9/19/2018 10:08:59' prior: 16823316! - exportInto: aDirectory - - aDirectory assureExistence. - - self associations do: [ :assoc | - | klass thisDirectory fullPath | - klass _ assoc value class. - thisDirectory _ aDirectory / assoc key. - fullPath _ (aDirectory // assoc key) pathName. - - self flag: #note. "Add support for new file export type mappings here. --cbr" - klass = ContentPack - ifTrue: [ assoc value exportInto: thisDirectory ]. - - klass = ColorForm - ifTrue: [ assoc value writeBMPfileNamed: fullPath ]. - - klass = Form - ifTrue: [ assoc value writeBMPfileNamed: fullPath ] - ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3448-ContentPackFix-JuanVuletich-2018Sep19-10h16m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3430] on 19 September 2018 at 10:17:34 am'! -!FileIOAccessor methodsFor: 'private' stamp: 'jmv 9/19/2018 10:17:18' prior: 16841766! - basicDirectoryExists: fullPathName - - | result | - result := self primLookupEntryIn: fullPathName index: 1. - result ifNil: [ ^ false ]. - ^(result == #badDirectoryPath) not! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3449-basicDirectoryExists-fix-JuanVuletich-2018Sep19-10h17m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3449] on 21 September 2018 at 5:02:42 pm'! -!ContentPack methodsFor: 'importing' stamp: 'jmv 9/21/2018 16:13:27'! - loadContentFrom: aDirectoryEntry - - | contentPacks | - - (self supportedFilesIn: aDirectoryEntry) do: [ :filename | - self flag: #todo. "Add hook for other media types here. Also consider renaming this method. --cbr" - self at: filename name - put: (self import: [ Form fromFileEntry: filename ]) "This may yet be a cross-cutting concern, and need to be refactored when other media types become present. --cbr" - ]. - - contentPacks _ aDirectoryEntry directoryNames collect: [ :i | - i -> (ContentPack new loadContentFrom: aDirectoryEntry / i) - ]. - - ^ self union: (contentPacks as: Dictionary)! ! -!ContentPack class methodsFor: 'instance creation' stamp: 'jmv 9/21/2018 16:30:21'! - import - " - Feature require: 'Graphics-Files-Additional'. - Theme content export. - ContentPack import. - Theme bootstrap. - " - - ^ self new loadContentFrom: self exportDirectory! ! -!ContentPack class methodsFor: 'configuration' stamp: 'jmv 9/21/2018 16:07:27'! - exportDirectory - - ^ DirectoryEntry smalltalkImageDirectory / self defaultContentDirectory / 'Exported'! ! -!ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'jmv 9/21/2018 16:56:49'! - putForm: aForm onFile: fileEntry - "Store the given form on a file of the given name." - - fileEntry forceWriteStreamDo: [ :stream | - (self onBinaryStream: stream binary) nextPutImage: aForm ]! ! -!ContentPack methodsFor: 'exporting' stamp: 'jmv 9/21/2018 16:07:38' prior: 16823304! - export - - "Answer true on success." - - "self break." - - self class exportDirectory exists - ifTrue: [ Utilities inform: - 'Before you can export, you must move, rename or delete this directory: ' , - self exportDirectory pathName. - - ^ false. - ]. - - self exportInto: self class exportDirectory. - - ^ true! ! -!ContentPack methodsFor: 'exporting' stamp: 'jmv 9/21/2018 16:58:00' prior: 50413517! - exportInto: aDirectory - - | featureName | - featureName _ 'Graphics-Files-Additional'. - (FeatureRequirement name: featureName) isAlreadySatisfied - ifFalse: [ - self error: 'Please load "', featureName, '".']. - - aDirectory assureExistence. - - self associations do: [ :assoc | - | klass thisDirectory fullPath | - klass _ assoc value class. - thisDirectory _ aDirectory / assoc key. - fullPath _ aDirectory // assoc key. - - self flag: #note. "Add support for new file export type mappings here. --cbr" - klass = ContentPack - ifTrue: [ assoc value exportInto: thisDirectory ]. - - klass = ColorForm - ifTrue: [ assoc value writePNGfile: fullPath ]. - - klass = Form - ifTrue: [ assoc value writePNGfile: fullPath ] - ]! ! -!ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'jmv 9/21/2018 16:56:41' prior: 16854489! - putForm: aForm onFileNamed: filename - "Store the given form on a file of the given name." - - self putForm: aForm onFile: filename asFileEntry! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/21/2018 16:24:43' prior: 50413002! - resizeBottomIcon - " - Theme current resizeBottomIcon - " - ^ self fetch: #( '16x16' 'resize' 'resize-bottom' )! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/21/2018 16:25:13' prior: 50413005! - resizeBottomLeftIcon - " - Theme current resizeBottomLeftIcon - " - ^ self fetch: #( '16x16' 'resize' 'resize-bottom-left' )! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/21/2018 16:25:35' prior: 50413008! - resizeBottomRightIcon - " - Theme current resizeBottomRightIcon - " - ^ self fetch: #( '16x16' 'resize' 'resize-bottom-right' )! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/21/2018 16:28:59' prior: 50413011! - resizeFullIcon - " - Theme current resizeFullIcon - " - ^ self fetch: #( '16x16' 'resize' 'resize' )! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/21/2018 16:26:03' prior: 50413014! - resizeLeftIcon - " - Theme current resizeLeftIcon - " - ^ self fetch: #( '16x16' 'resize' 'resize-left' )! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/21/2018 16:26:25' prior: 50413017! - resizeRightIcon - " - Theme current resizeRightIcon - " - ^ self fetch: #( '16x16' 'resize' 'resize-right' )! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/21/2018 16:26:43' prior: 50413020! - resizeTopIcon - " - Theme current resizeTopIcon - " - ^ self fetch: #( '16x16' 'resize' 'resize-top' )! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/21/2018 16:27:13' prior: 50413023! - resizeTopLeftIcon - " - Theme current resizeTopLeftIcon - " - ^ self fetch: #( '16x16' 'resize' 'resize-top-left' )! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/21/2018 16:27:17' prior: 50413026! - resizeTopRightIcon - " - Theme current resizeTopRightIcon - " - ^ self fetch: #( '16x16' 'resize' 'resize-top-right' )! ! -!Theme methodsFor: 'icon lookup' stamp: 'jmv 9/21/2018 16:21:17' prior: 50399894! - fetch: aTuple " #( 'resolution' 'context' 'filename' ) " - - "Get an icon from Content. See icons protocol." - - | contentSpecifier icon themeGuess | - - icon _ nil. - themeGuess _ self class. - contentSpecifier _ self appendExtensionToContentSpec: aTuple. - - [ icon isNil ] - whileTrue: [ - icon _ self class content - from: themeGuess name - get: contentSpecifier. - - icon ifNotNil: [ ^ icon ]. - - themeGuess = Theme - ifTrue: [ ^ nil "See comment in ContentPack>>from:get: --cbr" ]. - - themeGuess _ themeGuess superclass - ]! ! -!Theme class methodsFor: 'importing/exporting' stamp: 'jmv 9/21/2018 16:08:35' prior: 16936871! - bootstrap - - "Destructive. Loads up initial content." - self flag: #todo. "Consider removal. --cbr" - - Content _ ContentPack import! ! - -ContentPack class removeSelector: #default! - -ContentPack class removeSelector: #default! - -ContentPack removeSelector: #exportDirectory! - -ContentPack removeSelector: #exportDirectory! - -ContentPack removeSelector: #path:! - -ContentPack removeSelector: #path:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3450-ContentPack-fixes-JuanVuletich-2018Sep21-17h01m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3450] on 22 September 2018 at 3:33:36 pm'! -!Number class methodsFor: 'instance creation' stamp: 'jmv 9/22/2018 09:01:25' prior: 16880670! - readRemainderOf: integerPart from: aStream base: base withSign: sign - "Read optional fractional part and exponent, and return the final result" - | value fraction fracpos peekChar | - - value := integerPart. - (aStream peekFor: $.) - ifTrue: [ "." - (aStream atEnd not and: [ aStream peek digitValue between: 0 and: base - 1 ]) - ifTrue: [ - fracpos := aStream position. - fraction := Integer readFrom: aStream base: base. - fraction := fraction / (base raisedTo: aStream position - fracpos). - value := value asFloat + fraction] - ifFalse: [ - "oops - just ." - aStream skip: -1. - "un-gobble the period" - ^ value * sign"Number readFrom: '3r-22.2'"]]. - peekChar := aStream peek. - peekChar = $e | (peekChar = $d) | (peekChar = $q) - ifTrue: [ "(e|d|q)>" - aStream next. - (aStream atEnd not and: [ (aStream peek digitValue between: 0 and: 9) or: [ aStream peek = $- ]]) - ifTrue: [ - value := value * (base raisedTo: (Integer readFrom: aStream)) ] - ifFalse: [ - "oops - just ." - aStream skip: -1.]]. - ^(value isFloat - and: [ value = 0.0 and: [ sign = -1 ]]) - ifTrue: [ Float negativeZero ] - ifFalse: [ value * sign ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3451-NumberFromString-fix-JuanVuletich-2018Sep22-15h33m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3451] on 24 September 2018 at 11:00:42 am'! -!Number class methodsFor: 'instance creation' stamp: 'jmv 9/24/2018 11:00:21' prior: 50413755! - readRemainderOf: integerPart from: aStream base: base withSign: sign - "Read optional fractional part and exponent, and return the final result" - | value fraction fracpos peekChar exp scale | - - value := integerPart. - (aStream peekFor: $.) - ifTrue: [ "." - (aStream atEnd not and: [ aStream peek digitValue between: 0 and: base - 1 ]) - ifTrue: [ - fracpos := aStream position. - fraction := Integer readFrom: aStream base: base. - fraction := fraction / (base raisedToInteger: aStream position - fracpos). - value := value asFloat + fraction] - ifFalse: [ - "oops - just ." - aStream skip: -1. - "un-gobble the period" - ^ value * sign"Number readFrom: '3r-22.2'"]]. - peekChar := aStream peek. - peekChar = $e | (peekChar = $d) | (peekChar = $q) - ifTrue: [ "(e|d|q)>" - aStream next. - (aStream atEnd not and: [ (aStream peek digitValue between: 0 and: 9) or: [ aStream peek = $- ]]) - ifTrue: [ - exp := Integer readFrom: aStream. - scale := base raisedToInteger: exp. - value := (value isFloat and: [ scale asFloat < Float fminNormalized ]) - ifTrue: [ - "Avoid Float arithmetic to allow stuff like - 12345678901234567890.0e-330 - (Float fminNormalized / 10) storeString asNumber = ((Float fminNormalized / 10)) - " - (value asTrueFraction * scale) asFloat ] - ifFalse: [ value * scale ] ] - ifFalse: [ - "oops - just ." - aStream skip: -1.]]. - ^(value isFloat - and: [ value = 0.0 and: [ sign = -1 ]]) - ifTrue: [ Float negativeZero ] - ifFalse: [ value * sign ]! ! -!Float methodsFor: 'printing' stamp: 'jmv 9/24/2018 10:31:30' prior: 16845315! -absPrintExactlyOn: aStream base: base - "Print my value on a stream in the given base. Assumes that my value is strictly - positive; negative numbers, zero, and NaNs have already been handled elsewhere. - Based upon the algorithm outlined in: - Robert G. Burger and R. Kent Dybvig - Printing Floating Point Numbers Quickly and Accurately - ACM SIGPLAN 1996 Conference on Programming Language Design and Implementation - June 1996. - This version guarantees that the printed representation exactly represents my value - by using exact integer arithmetic." - - | significand exp baseExpEstimate r s mPlus mMinus scale roundingIncludesLimits d tc1 tc2 fixedFormat decPointCount slowbit shead | - self isInfinite ifTrue: [aStream nextPutAll: 'Infinity'. ^ self]. - significand := self significandAsInteger. - roundingIncludesLimits := significand even. - exp := (self exponent - 52) max: MinValLogBase2. - baseExpEstimate := (self exponent * base asFloat reciprocalLogBase2 - 1.0e-10) ceiling. - exp >= 0 - ifTrue: - [significand ~= 16r10000000000000 - ifTrue: - [r := significand bitShift: 1 + exp. - s := 2. - mPlus := mMinus := 1 bitShift: exp] - ifFalse: - [r := significand bitShift: 2 + exp. - s := 4. - mPlus := 2 * (mMinus := 1 bitShift: exp)]] - ifFalse: - [(exp = MinValLogBase2 or: [significand ~= 16r10000000000000]) & false - ifTrue: - "jmv 2018-9-24. Deactivated. Makes the following false (See Tests package):" - " - | float | - float _ (Float fminNormalized / 2) successor. - float storeString asNumber = float - " - [r := significand bitShift: 1. - s := 1 bitShift: 1 - exp. - mPlus := mMinus := 1] - ifFalse: - [r := significand bitShift: 2. - s := 1 bitShift: 2 - exp. - mPlus := 2. - mMinus := 1]]. - baseExpEstimate >= 0 - ifTrue: [s := s * (base raisedToInteger: baseExpEstimate)] - ifFalse: - [scale := base raisedToInteger: baseExpEstimate negated. - r := r * scale. - mPlus := mPlus * scale. - mMinus := mMinus * scale]. - ((r + mPlus < s) not and: [roundingIncludesLimits or: [r + mPlus > s]]) - ifTrue: [baseExpEstimate := baseExpEstimate + 1] - ifFalse: - [r := r * base. - mPlus := mPlus * base. - mMinus := mMinus * base]. - (fixedFormat := baseExpEstimate between: -3 and: 6) - ifTrue: - [decPointCount := baseExpEstimate. - baseExpEstimate <= 0 - ifTrue: [aStream nextPutAll: ('0.000000' truncateTo: 2 - baseExpEstimate)]] - ifFalse: - [decPointCount := 1]. - slowbit := 1 - s lowBit . - shead := s bitShift: slowbit. - [d := (r bitShift: slowbit) // shead. - r := r - (d * s). - (tc1 := (r > mMinus) not and: [roundingIncludesLimits or: [r < mMinus]]) | - (tc2 := (r + mPlus < s) not and: [roundingIncludesLimits or: [r + mPlus > s]])] whileFalse: - [aStream nextPut: (Character digitValue: d). - r := r * base. - mPlus := mPlus * base. - mMinus := mMinus * base. - decPointCount := decPointCount - 1. - decPointCount = 0 ifTrue: [aStream nextPut: $.]]. - tc2 ifTrue: - [(tc1 not or: [r * 2 >= s]) ifTrue: [d := d + 1]]. - aStream nextPut: (Character digitValue: d). - decPointCount > 0 - ifTrue: - [decPointCount - 1 to: 1 by: -1 do: [:i | aStream nextPut: $0]. - aStream nextPutAll: '.0']. - fixedFormat ifFalse: - [aStream nextPut: $e. - aStream nextPutAll: (baseExpEstimate - 1) printString]! ! -!Float methodsFor: 'printing' stamp: 'jmv 9/24/2018 10:56:53' prior: 50405047! - absPrintOn: aStream base: base - "In Cuis, print Floats with enough digits to be able to recover later exactly the same Float." - - self absPrintExactlyOn: aStream base: base! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3452-FloatStringConversionFixes-JuanVuletich-2018Sep24-09h04m-jmv.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3452] on 24 September 2018 at 1:41:19 pm'! -!Float methodsFor: 'printing' stamp: 'jmv 9/24/2018 13:40:33' prior: 50413857! - absPrintExactlyOn: aStream base: base - "Print my value on a stream in the given base. Assumes that my value is strictly - positive; negative numbers, zero, and NaNs have already been handled elsewhere. - Based upon the algorithm outlined in: - Robert G. Burger and R. Kent Dybvig - Printing Floating Point Numbers Quickly and Accurately - ACM SIGPLAN 1996 Conference on Programming Language Design and Implementation - June 1996. - https://www.cs.indiana.edu/~dyb/pubs/FP-Printing-PLDI96.pdf - This version guarantees that the printed representation exactly represents my value - by using exact integer arithmetic." - - | significand exp baseExpEstimate r s mPlus mMinus scale roundingIncludesLimits d tc1 tc2 fixedFormat decPointCount slowbit shead | - self isInfinite ifTrue: [aStream nextPutAll: 'Infinity'. ^ self]. - significand := self significandAsInteger. - roundingIncludesLimits := significand even. - exp := (self exponent - 52) max: MinValLogBase2. - baseExpEstimate := (self exponent * base asFloat reciprocalLogBase2 - 1.0e-10) ceiling. - exp >= 0 - ifTrue: - [significand ~= 16r10000000000000 - ifTrue: - [r := significand bitShift: 1 + exp. - s := 2. - mPlus := mMinus := 1 bitShift: exp] - ifFalse: - [r := significand bitShift: 2 + exp. - s := 4. - mPlus := 2 * (mMinus := 1 bitShift: exp)]] - ifFalse: - [(exp = MinValLogBase2 or: [significand ~= 16r10000000000000]) - ifTrue: - [r := significand bitShift: 1. - s := 1 bitShift: 1 - exp. - mPlus := mMinus := 1] - ifFalse: - [r := significand bitShift: 2. - s := 1 bitShift: 2 - exp. - mPlus := 2. - mMinus := 1]]. - baseExpEstimate >= 0 - ifTrue: [s := s * (base raisedToInteger: baseExpEstimate)] - ifFalse: - [scale := base raisedToInteger: baseExpEstimate negated. - r := r * scale. - mPlus := mPlus * scale. - mMinus := mMinus * scale]. - ((r + mPlus < s) not and: [roundingIncludesLimits or: [r + mPlus > s]]) - ifTrue: [baseExpEstimate := baseExpEstimate + 1] - ifFalse: - [r := r * base. - mPlus := mPlus * base. - mMinus := mMinus * base]. - (fixedFormat := baseExpEstimate between: -3 and: 6) - ifTrue: - [decPointCount := baseExpEstimate. - baseExpEstimate <= 0 - ifTrue: [aStream nextPutAll: ('0.000000' truncateTo: 2 - baseExpEstimate)]] - ifFalse: - [decPointCount := 1]. - slowbit := 1 - s lowBit . - shead := s bitShift: slowbit. - [d := (r bitShift: slowbit) // shead. - r := r - (d * s). - (tc1 := (r > mMinus) not and: [roundingIncludesLimits or: [r < mMinus]]) | - (tc2 := (r + mPlus < s) not and: [roundingIncludesLimits or: [r + mPlus > s]])] whileFalse: - [aStream nextPut: (Character digitValue: d). - r := r * base. - mPlus := mPlus * base. - mMinus := mMinus * base. - decPointCount := decPointCount - 1. - decPointCount = 0 ifTrue: [aStream nextPut: $.]]. - tc2 ifTrue: - [(tc1 not or: [r * 2 >= s]) ifTrue: [d := d + 1]]. - aStream nextPut: (Character digitValue: d). - decPointCount > 0 - ifTrue: - [decPointCount - 1 to: 1 by: -1 do: [:i | aStream nextPut: $0]. - aStream nextPutAll: '.0']. - fixedFormat ifFalse: - [aStream nextPut: $e. - aStream nextPutAll: (baseExpEstimate - 1) printString]! ! -!Float methodsFor: 'printing' stamp: 'jmv 9/24/2018 13:40:36' prior: 50404912! - absPrintOn: aStream base: base mantissaSignificantBits: significantBits - "Print my value on a stream in the given base. Assumes that my value is strictly - positive; negative numbers, zero, and NaNs have already been handled elsewhere. - Based upon the algorithm outlined in: - Robert G. Burger and R. Kent Dybvig - Printing Floating Point Numbers Quickly and Accurately - ACM SIGPLAN 1996 Conference on Programming Language Design and Implementation - June 1996. - https://www.cs.indiana.edu/~dyb/pubs/FP-Printing-PLDI96.pdf - This version performs all calculations with Floats instead of LargeIntegers, and loses - about 3 lsbs of accuracy compared to an exact conversion." - - | fBase exp baseExpEstimate r s mPlus mMinus scale d tc1 tc2 fixedFormat decPointCount | - self isInfinite ifTrue: [aStream nextPutAll: 'Infinity'. ^ self]. - fBase := base asFloat. - exp := self exponent. - baseExpEstimate := (exp * fBase reciprocalLogBase2 - 1.0e-10) ceiling. - exp >= 0 - ifTrue: - [r := self. - s := 1.0. - mPlus := 1.0 timesTwoPower: exp - significantBits. - mMinus := self significand ~= 1.0 ifTrue: [mPlus] ifFalse: [mPlus / 2.0]] - ifFalse: - [r := self timesTwoPower: significantBits. - s := 1.0 timesTwoPower: significantBits. - mMinus := 1.0 timesTwoPower: (exp max: -1024). - mPlus := - (exp = MinValLogBase2) | (self significand ~= 1.0) - ifTrue: [mMinus] - ifFalse: [mMinus * 2.0]]. - baseExpEstimate >= 0 - ifTrue: - [exp = 1023 - ifTrue: "scale down to prevent overflow to Infinity during conversion" - [r := r / fBase. - s := s * (fBase raisedToInteger: baseExpEstimate - 1). - mPlus := mPlus / fBase. - mMinus := mMinus / fBase] - ifFalse: - [s := s * (fBase raisedToInteger: baseExpEstimate)]] - ifFalse: - [exp < -1023 - ifTrue: "scale up to prevent denorm reciprocals overflowing to Infinity" - [d := (53 * fBase reciprocalLogBase2 - 1.0e-10) ceiling. - scale := fBase raisedToInteger: d. - r := r * scale. - mPlus := mPlus * scale. - mMinus := mMinus * scale. - scale := fBase raisedToInteger: (baseExpEstimate + d) negated] - ifFalse: - [scale := fBase raisedToInteger: baseExpEstimate negated]. - s := s / scale]. - (r + mPlus >= s) - ifTrue: [baseExpEstimate := baseExpEstimate + 1] - ifFalse: - [s := s / fBase]. - (fixedFormat := baseExpEstimate between: -3 and: 6) - ifTrue: - [decPointCount := baseExpEstimate. - baseExpEstimate <= 0 - ifTrue: [aStream nextPutAll: ('0.000000' truncateTo: 2 - baseExpEstimate)]] - ifFalse: - [decPointCount := 1]. - [d := (r / s) truncated. - r := r - (d * s). - (tc1 := r <= mMinus) | (tc2 := r + mPlus >= s)] whileFalse: - [aStream nextPut: (Character digitValue: d). - r := r * fBase. - mPlus := mPlus * fBase. - mMinus := mMinus * fBase. - decPointCount := decPointCount - 1. - decPointCount = 0 ifTrue: [aStream nextPut: $.]]. - tc2 ifTrue: - [tc1 not | (tc1 & (r*2.0 >= s)) ifTrue: [d := d + 1]]. - aStream nextPut: (Character digitValue: d). - decPointCount > 0 - ifTrue: - [decPointCount - 1 to: 1 by: -1 do: [:i | aStream nextPut: $0]. - aStream nextPutAll: '.0']. - fixedFormat ifFalse: - [aStream nextPut: $e. - aStream nextPutAll: (baseExpEstimate - 1) printString]! ! - -Float removeSelector: #absByteEncode:base:! - -Float removeSelector: #absByteEncode:base:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3453-FloatStringConversionStuff-JuanVuletich-2018Sep24-13h39m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3453] on 26 September 2018 at 11:48:12 am'! -!Float commentStamp: 'jmv 9/24/2018 20:52:43' prior: 50375948! - A note About Floating Point numbers and Floating Point Arithmetic. - -The following is not specific to Cuis or Smalltalk at all. This is about the properties of Float numbers in any computer implementation. - -If you haven't done so already, read https://en.wikipedia.org/wiki/Floating-point_arithmetic - -But if you find the Wikipedia article too detailed, or hard to read, then try http://fabiensanglard.net/floating_point_visually_explained/ (get past "How Floating Point are usually explained" and read "A different way to explain..."). - -Other great reads are: - "Why don't my numbers add up?": - http://floating-point-gui.de/ -and - "What Every Computer Scientist Should Know About Floating-Point Arithmetic": - http://docs.oracle.com/cd/E19957-01/806-3568/ncg_goldberg.html -and also maybe - "Comparing floating point numbers" - https://randomascii.wordpress.com/2012/02/25/comparing-floating-point-numbers-2012-edition/ - -Now that you read them, and we are on the same boat, some further comments (from jmv): - -Floats are (conceptually) approximate real numbers. That's why trig and other trascendental functions always answer Floats. That's why it is ok to round the result of operations. That's why Float is considered more general than Fraction in ST-80 and most Smalltalks. So, when we have a Float value, we must not think about it as a Rational but as a Real (actually as some unknown Real that could hopefully be close to the Rational we can actually represent). Keep this in mind when dealing with Floats, and especially avoid comparing them for equality. - -When doing mixed operations with Floats and Fractions, Cuis, as most other Smalltalks, converts all values to Floats. Some other systems, including Pharo Smalltalk, Scheme and Lisp have two rules: when the answer is a Number, they convert to Float. But when the answer is a boolean (#<, #=, #<=, etc.) they convert to Fraction. We think this is a mistake. There should never be implicit conversions from Float to Fraction. Fractions are to hold exact values, and people expect Fractions to be exact. On the other hand, Floats are to hold approximations (and people should be aware of that!!). But an implicit conversion from Float to Fraction would give a Fraction that should not be considered an exact value (the value comes from an inexact Float), but that knowledge is lost, as it is an instance of Fraction. - -If you want exact arithmetic, usual mathematical properties (like transitivity of equality), can live in the limited world of Rational numbers, and can afford a slight performance penalty, use Fraction instead. Avoid trascendental functions and never convert to Float. - -In any case, most numeric computation is done on Float numbers. There are good reasons for that. One is that in most cases we don't need an exact answer. And in many cases we can't really have it: the inputs to algorithms already have a limited precision, or they use trascendental functions. And even when exact arithmetic possible, if we are doing sound synthesis, 24 bits of resolution is enough. For image processing and graphics, the result is never more than 16 bits per channel. So, these fields don't really need 64 bit Doubles. 32 bit Floats are enough. Other fields do need 64 bit Doubles, like physics simulations and geometry. Games usually prefer special, faster 32 bit Float operations in GPUs that have greater errors but are faster. - -There are some things that can be done to increase the confidence you can have on Float results. One is to do an error propagation analysis on the code you are running. This is not easy, but it is done for any widely used numerical method. Then, you can know real bounds and/or estimates of the errors made. So, understanding your inputs and your algorithms (for example error propagation, condition number, numeric stability), and using Float number if appropriate, is the usual advice. - -Perhaps you have heard about "interval arithmetic". It is a bit better than simple Float, but doesn't really fix the problems. - -The ultimate solution is to do Monte Carlo analysis, with random perturbation of inputs. After the Monte Carlo run, it is needed to do statistical analysis of possible correlations between the distributions of the random noise added to imputs and the result of the algorithm. - -Additional food for thought: http://www.cs.berkeley.edu/~wkahan/Mindless.pdf . According to this, doing Monte Carlo as described above attacks a slightly different problem. This might be yet another reason (besides performance) to try something like the next paragraph. I (jmv) came up with it, and I don't really know if it has been described and or tried before or not. Mhhh. Maybe a defensive publication is in order. - -A possibility that could be a practical solution, being much cheaper than Monte Carlo, but better than interval arithmetic, is to represent each value by 2 Floats: an estimation of the real value (i.e. an estimation of the mean value of the distribution of the corresponding Monte Carlo result), and an estimation of the error (i.e. an estimation of the standard deviation of the corresponding Monte Carlo result). Or perhaps even 3 of them. In addition to the estimation of the real value and an estimation of the error, we could add a hard bound on the error. In many cases it will be useless, because the error can not really be bound. But in those cases where it is possible to bound it, applications could really know about the quality of computed values. - -======================================================================= - -My instances represent IEEE-754 floating-point double-precision numbers. They have about 16 decimal digits of accuracy and their range is between plus and minus 10^307. Some valid examples are: - - 8.0 13.3 0.3 2.5e6 1.27e-30 1.27e-31 -12.987654e12 - -Mainly: no embedded blanks, little e for tens power, and a digit on both sides of the decimal point. It is actually possible to specify a radix for Squeak Float constants. This is great for teaching about numbers, but may be confusing to the average reader: - - 3r20.2 --> 6.66666666666667 - 8r20.2 --> 16.25 - -If you don't have access to the definition of IEEE-754, you can figure out what is going on by printing various simple values in Float hex. It may help you to know that the basic format is... - sign 1 bit - exponent 11 bits with bias of 1023 (16r3FF) to produce an exponent - in the range -1023 .. +1024 - - 16r000: - significand = 0: Float zero - significand ~= 0: Denormalized number (exp = -1023 + 1 = -1022, no hidden '1' bit in mantissa) - - 16r7FF: - significand = 0: Infinity - significand ~= 0: Not A Number (NaN) representation - mantissa 53 bits, but only 52 are stored (20 in the first word, 32 in the second). This is because a normalized mantissa, by definition, has a 1 to the right of its floating point, and IEEE-754 omits this redundant bit to gain an extra bit of precision instead. People talk about the mantissa without its leading one as the FRACTION, and with its leading 1 as the SIGNFICAND. - -The single-precision format is... - sign 1 bit - exponent 8 bits, with bias of 127, to represent -126 to +127 - - 0x0 and 0xFF reserved for Float zero (mantissa is ignored) - - 16r7F reserved for Float underflow/overflow (mantissa is ignored) - mantissa 24 bits, but only 23 are stored -This format is used in FloatArray (qv), and much can be learned from the conversion routines, Float asIEEE32BitWord, and Float class fromIEEE32Bit:. - -You might also check https://en.wikipedia.org/wiki/IEEE_754_revision - -Other great reads (covering broader but interesting issues): -https://randomascii.wordpress.com/2013/07/16/floating-point-determinism/ -http://www.ima.umn.edu/2010-2011/W1.10-14.11/activities/Leeser-Miriam/Leeser-GPU-IMA-Jan2011.pdf! -!Float methodsFor: 'converting' stamp: 'jmv 9/26/2018 09:32:40' prior: 16844861! - asTrueFraction - " Answer a fraction that EXACTLY represents self, - a double precision IEEE floating point number. - By David N. Smith with significant performance - improvements by Luciano Esteban Notarfrancesco. - (Version of 11April97). - Refactoring and simplification by jmv" - - ^self - partValues: [ :sign :exponent :mantissa | | zeroBitsCount | - " Prepare result. If exponent is greater than mantissa size, result is an integer" - (exponent >= 52 or: [ - zeroBitsCount _ mantissa lowBit - 1. - exponent + zeroBitsCount >= 52 ]) - ifTrue: [ - "result is an integer number" - sign * mantissa bitShift: exponent - 52 ] - ifFalse: [ - " This is the 'obvious' way. Better do Luciano's trick below:" - "result := Fraction - numerator: sign * mantissa - denominator: (1 bitShift: 52 - exponent)." - " Form the result. When exp>52, the exponent is adjusted by - the number of trailing zero bits in the mantissa to minimize - the (huge) time could be spent in #gcd:. " - Fraction - numerator: (sign * (mantissa bitShift: 0 - zeroBitsCount)) - denominator: (1 bitShift: 52 - exponent - zeroBitsCount) ] - ] - ifInfinite: [ self error: 'Cannot represent infinity as a fraction' ] - ifNaN: [ self error: 'Cannot represent Not-a-Number as a fraction' ].! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 9/26/2018 11:31:38' prior: 16844982! - exponentPart - " - Exponent part of the Floating Point representation. - For any Floating Point number (except zeros, infinities and NaNs) - Includes correction of stored exponent bits for denormals (where it acts as a label, not a real exponent) - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. (f signPart * f significandAsInteger * (2 raisedToInteger: f exponentPart-52)) asFloat = f } print ]. - " - ^self partValues: [ :sign :exponent :mantissa | exponent ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 9/26/2018 11:30:23' prior: 16844994! - mantissaPart - "Equivalent to #significandAsInteger." - "The actual bits in the mantissa of the receiver, as an integer number, including the implicit leading 1 if appropriate. - Does not include de sign. - See #exponentPart and #signPart - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. (f signPart * f mantissaPart * (2 raisedToInteger: f exponentPart-52)) asFloat = f } print ]. - " - ^self partValues: [ :sign :exponent :mantissa | mantissa ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 9/26/2018 11:29:42' prior: 16845031! - signPart - "The sign of the mantissa. - See #mantissaPart and #exponentPart" - " - | f | - f := -2.0. - (f signPart * f mantissaPart * (2 raisedToInteger: f exponentPart-52)) asFloat. - " - ^self partValues: [ :sign :exponent :mantissa | sign ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 9/26/2018 11:33:16' prior: 16845037! - significand - "Answers mantissa as a Float between one and two (or between -1 and -2). See #exponent. - See also #signPart, #significandAsInteger and #exponentPart - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. f significand * (2 raisedToInteger: f exponent) = f } print ]. - " - ^ self timesTwoPower: (self exponent negated)! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 9/26/2018 11:31:01' prior: 16845042! - significandAsInteger - "The actual bits in the mantissa of the receiver, as an integer number, including the implicit leading 1 if appropriate. - See #exponentPart - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. (f signPart * f significandAsInteger * (2 raisedToInteger: f exponentPart-52)) asFloat = f } print ]. - " - ^self partValues: [ :sign :exponent :mantissa | mantissa ]! ! -!BoxedFloat64 methodsFor: 'truncation and round off' stamp: 'jmv 9/26/2018 11:33:06' prior: 16790833! - exponent - "Primitive. Consider the receiver to be represented as a power of two - multiplied by a mantissa between one and two or between -1 and -2 (#significand). - Answer with the SmallInteger to whose power two is raised. - Optional. See Object documentation whatIsAPrimitive. - See also #signPart, #significandAsInteger and #exponentPart - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. f significand * (2 raisedToInteger: f exponent) = f } print ]. - " - - | positive | - - self >= 1.0 ifTrue: [^self floorLog: 2]. - self > 0.0 - ifTrue: - [positive _ (1.0 / self) exponent. - self = (1.0 / (1.0 timesTwoPower: positive)) - ifTrue: [^positive negated] - ifFalse: [^positive negated - 1]]. - self = 0.0 ifTrue: [^-1]. - ^self negated exponent! ! -!SmallFloat64 methodsFor: 'truncation and round off' stamp: 'jmv 9/26/2018 11:17:00' prior: 16908499! - exponent - "Primitive. Consider the receiver to be represented as a power of two - multiplied by a mantissa between one and two (#significand). - Answer with the SmallInteger to whose power two is raised. - Optional. See Object documentation whatIsAPrimitive. - See comment at BoxedFloat64" - - | positive | - - self >= 1.0 ifTrue: [^self floorLog: 2]. - self > 0.0 - ifTrue: - [positive _ (1.0 / self) exponent. - self = (1.0 / (1.0 timesTwoPower: positive)) - ifTrue: [^positive negated] - ifFalse: [^positive negated - 1]]. - self = 0.0 ifTrue: [^-1]. - ^self negated exponent! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3454-FloatCommentsEnhancements-JuanVuletich-2018Sep26-11h47m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3454] on 26 September 2018 at 1:32:50 pm'! -!Number class methodsFor: 'instance creation' stamp: 'jmv 9/26/2018 13:28:05' prior: 50413804! - readRemainderOf: integerPart from: aStream base: base withSign: sign - "Read optional fractional part and exponent, and return the final result" - | value fraction fracpos peekChar exp scale convertToFloat | - - convertToFloat := false. - value := integerPart. - (aStream peekFor: $.) - ifTrue: [ "." - (aStream atEnd not and: [ aStream peek digitValue between: 0 and: base - 1 ]) - ifTrue: [ - fracpos := aStream position. - fraction := Integer readFrom: aStream base: base. - fraction := fraction / (base raisedToInteger: aStream position - fracpos). - value := value + fraction. - convertToFloat := true ] - ifFalse: [ - "oops - just ." - aStream skip: -1. - "un-gobble the period" - ^ value * sign"Number readFrom: '3r-22.2'"]]. - peekChar := aStream peek. - peekChar = $e | (peekChar = $d) | (peekChar = $q) - ifTrue: [ "(e|d|q)>" - aStream next. - (aStream atEnd not and: [ (aStream peek digitValue between: 0 and: 9) or: [ aStream peek = $- ]]) - ifTrue: [ - exp := Integer readFrom: aStream. - scale := base raisedToInteger: exp. - value := value * scale ] - ifFalse: [ - "oops - just ." - aStream skip: -1.]]. - ^convertToFloat - ifTrue: [ - (value = 0.0 and: [ sign = -1 ]) - ifTrue: [ Float negativeZero ] - ifFalse: [ (value * sign) asFloat ]] - ifFalse: [ value * sign ]! ! -!Float methodsFor: 'printing' stamp: 'nice 4/20/2010 22:48' prior: 50413978! - absPrintExactlyOn: aStream base: base - "Print my value on a stream in the given base. Assumes that my value is strictly - positive; negative numbers, zero, and NaNs have already been handled elsewhere. - Based upon the algorithm outlined in: - Robert G. Burger and R. Kent Dybvig - Printing Floating Point Numbers Quickly and Accurately - ACM SIGPLAN 1996 Conference on Programming Language Design and Implementation - June 1996. - https://www.cs.indiana.edu/~dyb/pubs/FP-Printing-PLDI96.pdf - This version guarantees that the printed representation exactly represents my value - by using exact integer arithmetic." - - | significand exp baseExpEstimate r s mPlus mMinus scale roundingIncludesLimits d tc1 tc2 fixedFormat decPointCount slowbit shead | - self isInfinite ifTrue: [aStream nextPutAll: 'Infinity'. ^ self]. - significand := self significandAsInteger. - roundingIncludesLimits := significand even. - "What follows is equivalent, but faster than - exp := self exponentPart - 52." - exp := (self exponent - 52) max: MinValLogBase2. - baseExpEstimate := (self exponent * base asFloat reciprocalLogBase2 - 1.0e-10) ceiling. - exp >= 0 - ifTrue: - [significand ~= 16r10000000000000 - ifTrue: - [r := significand bitShift: 1 + exp. - s := 2. - mPlus := mMinus := 1 bitShift: exp] - ifFalse: - [r := significand bitShift: 2 + exp. - s := 4. - mPlus := 2 * (mMinus := 1 bitShift: exp)]] - ifFalse: - [(exp = MinValLogBase2 or: [significand ~= 16r10000000000000]) - ifTrue: - [r := significand bitShift: 1. - s := 1 bitShift: 1 - exp. - mPlus := mMinus := 1] - ifFalse: - [r := significand bitShift: 2. - s := 1 bitShift: 2 - exp. - mPlus := 2. - mMinus := 1]]. - baseExpEstimate >= 0 - ifTrue: [s := s * (base raisedToInteger: baseExpEstimate)] - ifFalse: - [scale := base raisedToInteger: baseExpEstimate negated. - r := r * scale. - mPlus := mPlus * scale. - mMinus := mMinus * scale]. - ((r + mPlus < s) not and: [roundingIncludesLimits or: [r + mPlus > s]]) - ifTrue: [baseExpEstimate := baseExpEstimate + 1] - ifFalse: - [r := r * base. - mPlus := mPlus * base. - mMinus := mMinus * base]. - (fixedFormat := baseExpEstimate between: -3 and: 6) - ifTrue: - [decPointCount := baseExpEstimate. - baseExpEstimate <= 0 - ifTrue: [aStream nextPutAll: ('0.000000' truncateTo: 2 - baseExpEstimate)]] - ifFalse: - [decPointCount := 1]. - slowbit := 1 - s lowBit . - shead := s bitShift: slowbit. - [d := (r bitShift: slowbit) // shead. - r := r - (d * s). - (tc1 := (r > mMinus) not and: [roundingIncludesLimits or: [r < mMinus]]) | - (tc2 := (r + mPlus < s) not and: [roundingIncludesLimits or: [r + mPlus > s]])] whileFalse: - [aStream nextPut: (Character digitValue: d). - r := r * base. - mPlus := mPlus * base. - mMinus := mMinus * base. - decPointCount := decPointCount - 1. - decPointCount = 0 ifTrue: [aStream nextPut: $.]]. - tc2 ifTrue: - [(tc1 not or: [r * 2 >= s]) ifTrue: [d := d + 1]]. - aStream nextPut: (Character digitValue: d). - decPointCount > 0 - ifTrue: - [decPointCount - 1 to: 1 by: -1 do: [:i | aStream nextPut: $0]. - aStream nextPutAll: '.0']. - fixedFormat ifFalse: - [aStream nextPut: $e. - aStream nextPutAll: (baseExpEstimate - 1) printString]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3455-FloatFromString-fix-JuanVuletich-2018Sep26-13h32m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3450] on 22 September 2018 at 10:28:10 am'! - -"Change Set: 3451-CuisCore-AuthorName-2018Sep22-10h25m -Date: 22 September 2018 -Author: Nahuel Garbezza - -Method #average: for Collection. Basically the composition of #collect: and #average"! -!Collection methodsFor: 'statistics' stamp: 'RNG 9/22/2018 10:26:52'! - average: aBlock - - ^ (self sum: aBlock) / self size! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3456-Collection_average_withArgument-NahuelGarbezza-2018Sep22-10h25m-RNG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3456] on 27 September 2018 at 11:14:05 am'! - -String removeSelector: #asCharacter! - -String removeSelector: #asCharacter! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3457-Remove-String-asCharacter-JuanVuletich-2018Sep27-10h55m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3451] on 23 September 2018 at 10:09:08 pm'! -!KeyboardEvent methodsFor: 'testing' stamp: 'HAW 9/23/2018 21:03:43'! - isAlphaNumeric - - ^ self keyCharacter isAlphaNumeric! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'HAW 9/23/2018 21:29:31'! - isArrowDown - - ^ keyValue = 31! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'HAW 9/23/2018 21:29:05'! - isArrowUp - - ^ keyValue = 30! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'HAW 9/23/2018 21:26:20'! - isBackspace - - ^ keyValue = 8! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'HAW 9/23/2018 21:04:09'! - isColon - - ^ self keyCharacter = $:.! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'HAW 9/23/2018 21:34:21'! - isCtrlSpace - - ^ (self controlKeyPressed or: [ self rawMacOptionKeyPressed ]) and: [ self isSpace ]! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'HAW 9/23/2018 21:27:43'! - isEnd - - ^ keyValue = 4! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'HAW 9/23/2018 21:25:30'! - isEsc - - ^ keyValue = 27! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'HAW 9/23/2018 21:27:07'! - isHome - - ^ keyValue = 1! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'HAW 9/23/2018 21:30:29'! - isPageDown - - ^ keyValue = 12! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'HAW 9/23/2018 21:30:07'! - isPageUp - - ^ keyValue = 11! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'HAW 9/23/2018 21:28:26'! - isQuesitonMark - - ^ self keyCharacter = $? ! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'HAW 9/23/2018 20:55:17'! - isSpace - - ^ #(0 32 160) includes: keyValue.! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'HAW 9/23/2018 20:55:13'! - isTab - - ^self keyCharacter = Character tab.! ! -!AutoCompleter methodsFor: 'keyboard - private' stamp: 'HAW 9/23/2018 21:16:16'! -isTab: kbEvent and: shouldOpenMoprh - - ^ self opensWithTab - and: [ kbEvent isTab - and: [ shouldOpenMoprh ]]! ! -!AutoCompleter methodsFor: 'keyboard - private' stamp: 'HAW 9/23/2018 21:35:54'! - openCompletionMenuFor: kbEvent if: shouldOpenMorph - - "Ctrl-Space or Tab for open" - "Mac specific note: Using option-space (actually option+160) effectively disables the non-breaking space character 160" - (kbEvent isCtrlSpace or: [self isTab: kbEvent and: shouldOpenMorph]) ifTrue: [ self openCompletionMenu. ^ true]. - - "Auto-open - currently deactivated" -" (ctrl not & cmd not & alphanum) ifTrue: [ self openCompletionMenu ]." - - ^ false! ! -!AutoCompleter methodsFor: 'keyboard - private' stamp: 'HAW 9/23/2018 21:06:20'! - shouldCloseMenu: kbEvent - - "All keys but the alphanumeric chars (without command and control ) - and the backspace key do close the menu" - - ^ ((kbEvent controlKeyPressed not and: [ kbEvent commandAltKeyPressed not ]) and: [ kbEvent isAlphaNumeric or: [ kbEvent isColon ]]) not -! ! -!AutoCompleter methodsFor: 'keyboard - private' stamp: 'HAW 9/23/2018 20:58:51'! - shouldInsertSelected: kbEvent - - ^ kbEvent isReturnKey - or: [ (kbEvent isSpace and: [ kbEvent controlKeyPressed or: [ kbEvent rawMacOptionKeyPressed ]]) - or: [ kbEvent isTab]]! ! -!AutoCompleter methodsFor: 'keyboard - private' stamp: 'HAW 9/23/2018 19:46:17'! - shouldOpenMorph - - | currentPos currentChar | - - currentPos _ textMorph editor startIndex-1. - currentPos <= 0 ifTrue: [ ^ false ]. - currentChar _ model actualContents at: currentPos. - - ^ currentChar = Character space - ifTrue: [ self shouldOpenMorphWhenNoPrefixAt: currentPos-1 ] - ifFalse: [ self shouldOpenMorphWhenPrefixAt: currentPos and: currentChar ]. - - - - ! ! -!AutoCompleter methodsFor: 'keyboard - private' stamp: 'HAW 9/23/2018 21:23:06'! - shouldOpenMorphWhenNoPrefixAt: currentPos - - ^ model textSize >= currentPos - and: [ currentPos > 0 - and: [ (model actualContents at: currentPos) isAlphaNumeric ]] ! ! -!AutoCompleter methodsFor: 'keyboard - private' stamp: 'HAW 9/23/2018 19:48:46'! - shouldOpenMorphWhenPrefixAt: currentPos and: currentChar - - ^ model textSize >= currentPos and: [ currentChar isAlphaNumeric or: [ currentChar == $: ]] - - - ! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 9/23/2018 19:30:07'! - canComputeMessageEntriesFor: prevRange and: prevPrevRange - - ^ prevRange notNil and: [ prevPrevRange isNil or: [ (#(binary keyword) includes: prevPrevRange rangeType) not]]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 9/23/2018 19:17:21'! - computeEntriesOfMessageOrIdentifiersFor: allSource using: last3Ranges at: range in: contextClass and: specificModel - - prefix _ allSource copyFrom: range start to: range end. - (parser isMessage: range rangeType) ifTrue: [ ^self computeMessageEntriesWhenSendinMessageFor: allSource using: last3Ranges in: contextClass and: specificModel ]. - (parser isPartialOrFullIdentifier: range rangeType) ifTrue: [ ^self computeIdentifierEntries ]. - - "If we don't know what to do, do nothing" - entries _ #() ! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 9/23/2018 19:26:07'! - computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel - - | id receiverClass | - - id _ allSource copyFrom: range start to: range end. - receiverClass _ range rangeType - caseOf: { - [ #globalVar ] -> [ (Smalltalk at: id asSymbol) class ]. - [ #self ] -> [ contextClass ]. - [ #super ] -> [ contextClass superclass ]. - [ #true ] -> [ True ]. - [ #false ] -> [ False ]. - [ #nil ] -> [ UndefinedObject ]. - [ #character ] -> [ id first class ]. - [ #number ] -> [ self classOfLiteral: id in: contextClass ]. - [ #string ] -> [ self classOfLiteral: id in: contextClass ]. - [ #symbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #stringSymbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #instVar ] -> [ self classOfInstVarNamed: id in: specificModel ]. - [ #tempVar ] -> [ self classOfTempVarNamed: id in: specificModel ]. - [ #workspaceVar ] -> [ self classOfWorkspaceVarNamed: id in: specificModel ]. - [ #classVar ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #poolConstant ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #thisContext ] -> [ self classOfThisContextIn: specificModel ]. } - otherwise: [ nil ]. - - self computeMessageEntries: receiverClass! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 9/23/2018 19:29:16'! - computeMessageEntriesWhenSendinMessageFor: allSource using: last3Ranges in: contextClass and: specificModel - - | prevPrevRange prevRange | - - "If previous range is a constant or a well known identifier, we might filter messages" - prevRange _ last3Ranges second. - prevPrevRange _ last3Ranges first. - - "3 if -> ifNil: but not ifTrue: - 3=4 -> ifNil: or ifTrue:" - ^ (self canComputeMessageEntriesFor: prevRange and: prevPrevRange) - ifTrue: [ self computeMessageEntriesFor: allSource at: prevRange in: contextClass and: specificModel ] - ifFalse: [ self computeMessageEntries: nil ] -! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 9/23/2018 19:18:09'! -computeMessageEntriesWithEmptyPrefixFor: allSource at: range in: contextClass and: specificModel - - prefix _ ''. - self computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel ! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 9/23/2018 19:03:49'! - parse: sourceToParse in: contextClass and: specificModel - - parser _ SHParserST80 new. - parser - workspace: ((specificModel is: #providesBindings) ifTrue: [specificModel]); - classOrMetaClass: contextClass; - source: sourceToParse. - parser parse. - - ^ parser last3Ranges. -! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 9/23/2018 19:01:52'! - selectedClassOrMetaClassIn: specificModel - - ^ (specificModel is: #CodeProvider) ifTrue: [ specificModel selectedClassOrMetaClass ]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 9/23/2018 19:30:43'! - textProviderOrModel - - ^ (model is: #hasTextProvider) ifTrue: [ model textProvider ] ifFalse: [ model ].! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/23/2018 22:03:28'! - classOfInstVarNamed: aName in: specificModel - - (specificModel isKindOf: Debugger) ifTrue: [ ^specificModel contextStackIndex ~= 0 ifTrue: [ (specificModel receiver instVarNamed: aName) class] ]. - - ^nil - ! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/23/2018 16:52:20'! - classOfLiteral: aLiteral in: aClass - - | compilerClass | - - compilerClass := aClass ifNil: [ Compiler ] ifNotNil: [ aClass compilerClass ]. - - ^ (compilerClass evaluate: aLiteral) class ! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/23/2018 16:52:36'! - classOfLocalBindingNamed: aName in: aClass - - ^ (aClass localBindingOf: aName) ifNotNil: [ :aBinding | aBinding value class ]! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/23/2018 22:04:08'! - classOfTempVarNamed: aName in: specificModel - - (specificModel isKindOf: Workspace) ifTrue: [ ^ self classOfTempVarNamed: aName inWorkspace: specificModel ]. - (specificModel isKindOf: Debugger) ifTrue: [ ^ self classOfTempVarNamed: aName inDebugger: specificModel ]. - (specificModel isKindOf: Inspector) ifTrue: [ ^ self classOfTempVarNamed: aName inInspector: specificModel ]. - - ^ nil! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/23/2018 19:31:39'! - classOfTempVarNamed: aName inDebugger: aDebugger - - | context tempIndex | - - context := aDebugger selectedContext. - tempIndex := context tempNames indexOf: aName. - - ^ tempIndex ~= 0 ifTrue: [(context tempAt: tempIndex) class]! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/23/2018 21:50:35'! -classOfTempVarNamed: aName inInspector: anInspector - - ^ (anInspector bindingOf: aName) value ifNotNil: [ :aValue | aValue class ] ! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/23/2018 16:38:27'! - classOfTempVarNamed: aName inWorkspace: aWorkspace - - ^ (aWorkspace bindingOf: aName) value ifNotNil: [ :aValue | aValue class ] ! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/23/2018 19:31:57'! - classOfThisContextIn: specificModel - - "thisContext could mean ContextPart or BlockClosure..." - ^ (specificModel isKindOf: Debugger) ifTrue: [ self classOfThisContextInDebugger: specificModel ] - ! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/23/2018 17:06:19'! - classOfThisContextInDebugger: aDebugger - - ^ aDebugger selectedContext class! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/23/2018 22:05:20'! - classOfWorkspaceVarNamed: id in: specificModel - - (specificModel isKindOf: Workspace) ifTrue: [ ^ self classOfWorkspaceVarNamed: id inWorkspace: specificModel ]. - (specificModel isKindOf: Inspector) ifTrue: [ ^self classOfWorkspaceVarNamed: id inInspector: specificModel ]. - - ^nil! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/23/2018 16:44:50'! - classOfWorkspaceVarNamed: aName inInspector: anInspector - - ^ (anInspector object instVarNamed: aName) class ! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/23/2018 16:43:48'! - classOfWorkspaceVarNamed: aName inWorkspace: aWorkspace - - ^ (aWorkspace bindingOf: aName) value ifNotNil: [ :aValue | aValue class ] ! ! -!AutoCompleter methodsFor: 'keyboard' stamp: 'HAW 9/23/2018 21:30:54' prior: 50412576! - handleKeystrokeBefore: kbEvent - - "I return a boolean. true when I have handled the event and no futher processing is needed by the caller." - - | shouldOpenMorph | - - shouldOpenMorph _ self shouldOpenMorph. - - "Stuff to do if the menu is not open" - menuMorph ifNil: [ ^ self openCompletionMenuFor: kbEvent if: shouldOpenMorph ]. - - "Starting here, stuff to do if the menu is open" - menuMorph stillActive. - - kbEvent isEsc ifTrue: [ self closeMenu. ^ true]. - kbEvent isBackspace ifTrue: [ shouldOpenMorph ifFalse: [ self closeMenu ]. ^ false]. - kbEvent isHome ifTrue: [ menuMorph goHome. ^ true ]. - kbEvent isEnd ifTrue: [ menuMorph goToEnd. ^ true]. - kbEvent isQuesitonMark ifTrue: [ menuMorph help. ^true]. - kbEvent isArrowUp ifTrue: [ menuMorph goUp. ^ true]. - kbEvent isArrowDown ifTrue: [ menuMorph goDown. ^ true]. - kbEvent isPageUp ifTrue: [ menuMorph goPageUp. ^ true]. - kbEvent isPageDown ifTrue: [ menuMorph goPageDown. ^ true]. - (self shouldInsertSelected: kbEvent) ifTrue: [ self insertSelected ifTrue: [^ true]]. - (self shouldCloseMenu: kbEvent) ifTrue: [ self closeMenu ]. - - ^false! ! -!SmalltalkCompleter methodsFor: 'entries' stamp: 'HAW 9/23/2018 19:18:00' prior: 50367917! - computeEntries - - | allSource contextClass specificModel last3Ranges range | - - allSource _ model actualContents string. - specificModel _ self textProviderOrModel. - contextClass _ self selectedClassOrMetaClassIn: specificModel. - last3Ranges _ self parse: (allSource copyFrom: 1 to: position) in: contextClass and: specificModel. - range _ last3Ranges third ifNil: [ ^entries _ #() ]. - - range end = position - ifTrue: [ self computeEntriesOfMessageOrIdentifiersFor: allSource using: last3Ranges at: range in: contextClass and: specificModel ] - ifFalse: [ self computeMessageEntriesWithEmptyPrefixFor: allSource at: range in: contextClass and: specificModel ]. - - ! ! -!SmalltalkCompleter methodsFor: 'entries' stamp: 'HAW 9/23/2018 19:23:35' prior: 16909351! - newCursorPosition: anEntry - - ^anEntry indexOf: $ ! ! -!SmalltalkCompleter methodsFor: 'entries' stamp: 'HAW 9/23/2018 19:23:40' prior: 16909355! - selectedEntry - - ^(self entries at: menuMorph selected) separateKeywords! ! - -SmalltalkCompleter removeSelector: #canDetectTypeOf:in:! - -SmalltalkCompleter removeSelector: #classForInstVarNamed:in:! - -SmalltalkCompleter removeSelector: #classOfLiteral:! - -SmalltalkCompleter removeSelector: #classOfLocalBindingNamed:of:! - -SmalltalkCompleter removeSelector: #classOfTempVarNamed:inBindingsProvider:! - -SmalltalkCompleter removeSelector: #computeEntriesOf:in:! - -AutoCompleter removeSelector: #isArrowDown:! - -AutoCompleter removeSelector: #isArrowUp:! - -AutoCompleter removeSelector: #isCtrlSpace:! - -AutoCompleter removeSelector: #isEnd:! - -AutoCompleter removeSelector: #isHome:! - -AutoCompleter removeSelector: #isPageDown:! - -AutoCompleter removeSelector: #isPageUp:! - -AutoCompleter removeSelector: #isQuesitonMark:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3458-SmalltalkCompleterEnhancements-p1-HernanWilkinson-2018Sep23-12h02m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3451] on 23 September 2018 at 10:28:44 pm'! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/23/2018 22:24:12'! - classOfBlockArgNamed: aName in: specificModel - - (specificModel isKindOf: Debugger) ifTrue: [ ^ self classOfBlockArgNamed: aName inDebugger: specificModel ]. - - ^ nil! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/23/2018 22:27:23'! - classOfBlockArgNamed: aName inDebugger: aDebugger - - ^ aDebugger contextStackIndex ~= 0 ifTrue: [ | selectedContext tempIndex | - selectedContext := aDebugger selectedContext. - tempIndex := selectedContext tempNames indexOf: aName ifAbsent: [ ^nil ]. - (selectedContext namedTempAt: tempIndex) class ]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 9/23/2018 22:23:41' prior: 50414978! - computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel - - | id receiverClass | - - id _ allSource copyFrom: range start to: range end. - receiverClass _ range rangeType - caseOf: { - [ #globalVar ] -> [ (Smalltalk at: id asSymbol) class ]. - [ #self ] -> [ contextClass ]. - [ #super ] -> [ contextClass superclass ]. - [ #true ] -> [ True ]. - [ #false ] -> [ False ]. - [ #nil ] -> [ UndefinedObject ]. - [ #character ] -> [ id first class ]. - [ #number ] -> [ self classOfLiteral: id in: contextClass ]. - [ #string ] -> [ self classOfLiteral: id in: contextClass ]. - [ #symbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #stringSymbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #instVar ] -> [ self classOfInstVarNamed: id in: specificModel ]. - [ #tempVar ] -> [ self classOfTempVarNamed: id in: specificModel ]. - [ #workspaceVar ] -> [ self classOfWorkspaceVarNamed: id in: specificModel ]. - [ #classVar ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #poolConstant ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #thisContext ] -> [ self classOfThisContextIn: specificModel ]. - [ #blockArg ] -> [ self classOfBlockArgNamed: id in: specificModel ].} - otherwise: [ nil ]. - - self computeMessageEntries: receiverClass! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3459-SmalltalkCompleterEnhancements-p2-HernanWilkinson-2018Sep23-22h09m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3451] on 24 September 2018 at 3:31:12 pm'! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/24/2018 15:03:26'! - classOfInstVarNamed: aName inDebugger: aDebugger - - ^aDebugger contextStackIndex ~= 0 ifTrue: [ (aDebugger receiver instVarNamed: aName) class]! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/24/2018 15:04:44'! - classOfInstVarNamed: aName inInspector: anInspector - - ^ (anInspector object instVarNamed: aName) class ! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/24/2018 15:17:20'! -classOfTempVarNamed: aName inContext: context - - | tempIndex | - - tempIndex := context tempNames indexOf: aName. - - ^ tempIndex ~= 0 ifTrue: [(context tempAt: tempIndex) class]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 9/24/2018 13:25:49' prior: 50415310! - computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel - - | id receiverClass | - - id _ allSource copyFrom: range start to: range end. - receiverClass _ range rangeType - caseOf: { - [ #globalVar ] -> [ (Smalltalk at: id asSymbol) class ]. - [ #self ] -> [ contextClass ]. - [ #super ] -> [ contextClass superclass ]. - [ #true ] -> [ True ]. - [ #false ] -> [ False ]. - [ #nil ] -> [ UndefinedObject ]. - [ #character ] -> [ id first class ]. - [ #number ] -> [ self classOfLiteral: id in: contextClass ]. - [ #string ] -> [ self classOfLiteral: id in: contextClass ]. - [ #symbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #stringSymbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #instVar ] -> [ self classOfInstVarNamed: id in: specificModel ]. - [ #tempVar ] -> [ self classOfTempVarNamed: id in: specificModel ]. - [ #workspaceVar ] -> [ self classOfWorkspaceVarNamed: id in: specificModel ]. - [ #classVar ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #poolConstant ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #thisContext ] -> [ self classOfThisContextIn: specificModel ]. - [ #blockArg ] -> [ self classOfBlockArgNamed: id in: specificModel ].} - otherwise: [ nil ]. - - self computeMessageEntries: receiverClass! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 9/24/2018 12:48:26' prior: 50415053! - parse: sourceToParse in: contextClass and: specificModel - - parser _ SHParserST80 new. - parser - workspace: ((specificModel is: #providesBindings) ifTrue: [specificModel]); - classOrMetaClass: contextClass; - source: sourceToParse. - parser parse: (specificModel is: #CodeProvider). - - ^ parser last3Ranges. -! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 9/24/2018 12:58:46' prior: 50415065! - selectedClassOrMetaClassIn: specificModel - - (specificModel is: #CodeProvider) ifTrue: [ ^ specificModel selectedClassOrMetaClass ]. - - "I can not use #selectedClassOrMetaClass becuase it changes with the selection but when compiling to evaluate it assumes object as receiver - Hernan" - ^ (specificModel isKindOf: Inspector) ifTrue: [ specificModel object class ] ! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/24/2018 15:02:09' prior: 50415289! - classOfBlockArgNamed: aName in: specificModel - - ^ (specificModel isKindOf: Debugger) ifTrue: [ self classOfBlockArgNamed: aName inDebugger: specificModel ]. - ! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/24/2018 15:03:54' prior: 50415078! - classOfInstVarNamed: aName in: specificModel - - (specificModel isKindOf: Debugger) ifTrue: [ ^ self classOfInstVarNamed: aName inDebugger: specificModel ]. - ^ (specificModel isKindOf: Inspector) ifTrue: [ self classOfInstVarNamed: aName inInspector: specificModel ]. - - ! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/24/2018 15:16:59' prior: 50415120! - classOfTempVarNamed: aName inDebugger: aDebugger - - | context | - - context := aDebugger selectedContext. - - ^self classOfTempVarNamed: aName inContext: context! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/24/2018 15:29:14' prior: 50415159! - classOfWorkspaceVarNamed: id in: specificModel - - (specificModel isKindOf: Workspace) ifTrue: [ ^ self classOfWorkspaceVarNamed: id inWorkspace: specificModel ]. - ^ (specificModel isKindOf: Inspector) ifTrue: [ self classOfWorkspaceVarNamed: id inInspector: specificModel ]. - ! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/24/2018 15:19:44' prior: 50415171! - classOfWorkspaceVarNamed: aName inInspector: anInspector - - ^ self classOfTempVarNamed: aName inContext: anInspector object - -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3460-SmalltalkCompleterEnhancements-p3-HernanWilkinson-2018Sep24-08h59m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3451] on 24 September 2018 at 3:44:30 pm'! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 9/24/2018 15:44:19' prior: 16909302! - computeIdentifierEntries - "Use an aux Set to avoid duplicates, but keep the order given." - | entriesSet | - - entriesSet _ Set new. - entries _ Array streamContents: [ :strm | - parser namesBeginningWith: prefix do: [ :identifier | - (entriesSet includes: identifier) ifFalse: [ - entriesSet add: identifier. - strm nextPut: identifier ]]]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3461-SmalltalkCompleterEnhancements-p4-HernanWilkinson-2018Sep24-15h31m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3463] on 28 September 2018 at 12:16:58 pm'! -!ContentPack commentStamp: 'jmv 9/28/2018 12:16:02' prior: 16823123! - ContentPack lets you read in and write out the (supported files in the) contents of a directory on your file system. It also allows you to trivially create "messenger" subclasses that capture the information containted in these directory trees, including any implicit communication that's there in the structure of the directory hierarchy itself, which are captured in your changes file. You can then file out a change set that contains a representation of the (supported file/object types and directory structurein) the stuff on your disk, or in your image. This subclass is a dummy which ContentPack compiles methods into containing base 64 encoded data. You can load this into another image, as long as that image has ContentPack loaded. The filed in class can then recreate the ContentPack on the other end with the media files and structure intact. - -The current implementation is based on #storeString, but the plan is to change that to SmartRefStream in the long run to support serializing things like morphs. - -ContentPack instances hang onto the actual tree of media objects. It has a nice simple EDSL that just interprets an array of strings from beginning to end as a "path" to a file (really a series of dictionary lookups to a Smalltalk object, wherin the dictionaries mirror the structure of what was on the disk, sans unsupported files.) This mechanism will likely change a little bit at some point, - -ContentPack came into the world a little faster than I expected, as I ended up using it to send some icons back in time to fix the Cuis update stream without having to sort my changes all over again. As such it had some unusual design pressures... it had to be able to carry information in and out of both the change set stream and the filesystem, as well as function in a slightly earlier (unreleased) version of Cuis than it was written in, and not break anything on it's way back up through the build to head. - -The code, in particular the way things are named, has not settled yet, and that's why this comment contains no code examples. Use with care and read the code first, for now. - -Currently, .bmp import and .png import are implemented, and both can be exported. Anything you can import, you can also shuffle into a change set. Plans are in the works to support audio, change sets, and text files. I'll support video if someone has a good importer, exporter, and player under the MIT license that'll work under Cuis. - -Currently, objects are serialized into single methods, which works for small icons, but likely doesn't work well (if at all) for larger files. My intent is to add some behavior that breaks up large objects into smaller chunks so that this becomes a non-issue. I'll likely get to that when I've removed most of the repetitive subtle variations of the same recursive tree walking visitor-trick from the code, and renamed everything. I think in essence this class is slightly smaller than it is as represented currently. - -Hopefully I will be able to explain all of this better once I've clarified the code a bit so that I can show off some examples. - - - cbr - ------------------------------------ -Alternative description (need to merge both!!) - -Forms (and potentially other media types) can exist in three forms: - -1) As external files, such as jpg, png, etc. This is the representation we need to use external tools (such as image processing apps, cameras, scanners, web, etc) to work on them. -2) As methods. Non human readable, base-64 encoded binary data. We need this to be able to include such stuff in the update stream, or in packages. After we update an image, we usually delete these methods, just keeping 3). -3) Live objects in the image, for example, stored in class variables. This is to make use of them in Cuis. - -Most of the time, we use 3). But we need 2) for the update stream. We also need 1) sometimes to work on them. ContentPack supports the conversion between these 3 formats. The implementation is quite simple. What is really great is that Casey realized we need some tool to move comfortably between these 3 representations. And he also implemented it. - - - jmv - -------------------------------------------- -Usage hints - -Feature require: 'Graphics-Files-Additional'. -Theme content export. - -"Build 'Import' directory copying the structure of 'Exported', with stuff to be loaded" - -"Just build an instance from files" -ContentPack import. - -"Build an instance and generate code" -ContentPack generateCode: ContentPack import. - -"Build an instance from code generated" -ContentPack decode. - -"Build and merge. Usually do this in the postscript of the change set that includes the generated code" -Theme content merge: ContentPack decode. -ContentPack removeCategory: ContentPack generatedMethodsCategory! -!ContentPack methodsFor: 'importing' stamp: 'jmv 9/28/2018 11:50:48'! - decodeContent - "Load content in us. - Start with an empty instance!!" - - self decodeContentFrom: self contentMap! ! -!ContentPack methodsFor: 'testing' stamp: 'jmv 9/28/2018 12:02:29'! - is: aSymbol - ^aSymbol == #ContentPack or: [ super is: aSymbol ]! ! -!ContentPack methodsFor: 'merge' stamp: 'jmv 9/28/2018 12:03:37'! - merge: aDictionaryOrContentPack - "Merge aDictionaryOrContentPack into us" - - aDictionaryOrContentPack keysAndValuesDo: [ :key :value | - (value is: #ContentPack) - ifFalse: [ - self at: key put: value ] - ifTrue: [ - (self at: key ifAbsentPut: [ContentPack new]) - merge: value ]]! ! -!ContentPack class methodsFor: 'instance creation' stamp: 'jmv 9/28/2018 11:51:51'! - decode - - ^ self new decodeContent! ! -!ContentPack class methodsFor: 'code pack' stamp: 'jmv 9/28/2018 10:47:25'! - generateCode: aDictionary - - | contentMap | - - self resetImporter. - - contentMap _ self encodeContentFrom: aDictionary. - - self compilePayloadWith: contentMap. - - self resetImporter.! ! -!ContentPack class methodsFor: 'configuration' stamp: 'jmv 9/28/2018 12:14:18'! - generatedMethodsCategory - ^ 'generated code'! ! -!ContentPack class methodsFor: 'configuration' stamp: 'jmv 9/28/2018 10:37:22'! -importDirectory - - ^ DirectoryEntry smalltalkImageDirectory / self defaultContentDirectory / 'Import'! ! -!ContentPack methodsFor: 'importing' stamp: 'jmv 9/28/2018 11:56:08' prior: 16823258! - decodeContentFrom: associationList - "Load content in us, frin geberated code. - Start with an empty instance!!" - - associationList do: [ :assoc | - (assoc at: 2) class == Array - ifTrue: [ - self at: (assoc at: 1) put: (ContentPack new decodeContentFrom: (assoc at: 2)) ] - ifFalse: [ - self at: (assoc at: 1) put: (Compiler - evaluate: (self - perform: - ('object' , (assoc at: 2) asString) asSymbol) base64Decoded) - ] - ]! ! -!ContentPack methodsFor: 'importing' stamp: 'jmv 9/28/2018 11:55:59' prior: 50413561! - loadContentFrom: aDirectoryEntry - "Load content in us, from files. - Start with an empty instance!!" - - (self supportedFilesIn: aDirectoryEntry) do: [ :filename | - self flag: #todo. "Add hook for other media types here. Also consider renaming this method. --cbr" - self at: filename name - put: (Form fromFileEntry: filename) - ]. - - aDirectoryEntry directoryNames do: [ :i | - self at: i put: (ContentPack new loadContentFrom: aDirectoryEntry / i) - ]! ! -!ContentPack class methodsFor: 'instance creation' stamp: 'jmv 9/28/2018 10:37:34' prior: 50413583! - import - " - Feature require: 'Graphics-Files-Additional'. - Theme content export. - ContentPack import. - Theme bootstrap. - " - - ^ self new loadContentFrom: self importDirectory! ! -!ContentPack class methodsFor: 'code pack' stamp: 'jmv 9/28/2018 12:14:28' prior: 16823429! - compilePayloadWith: contentMap - - | category | - category _ self generatedMethodsCategory. - self - compile: 'contentMap' , String newLineString , ' ^ ' , contentMap asString - classified: category. - - self - compile: 'objectCount' , String newLineString , ' ^ ' , payload size asString - classified: category. - - payload withIndexDo: [ :blob :index | | selector | - selector _ 'object', index asString. - self - compile: selector, String newLineString, ' ^ ', blob surroundedBySingleQuotes - classified: category ]! ! - -ContentPack class removeSelector: #withDictionary:! - -ContentPack class removeSelector: #withDictionary:! - -ContentPack removeSelector: #import:! - -ContentPack removeSelector: #import:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3462-ContentPack-enhancements-JuanVuletich-2018Sep28-11h24m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3462] on 28 September 2018 at 12:20:08 pm'! -!ContentPack methodsFor: 'generated code' stamp: 'jmv 9/28/2018 10:41:53'! - contentMap - ^ #(#('Theme' 1))! ! -!ContentPack methodsFor: 'generated code' stamp: 'jmv 9/28/2018 10:41:53'! - object1 - ^ 'KChDb250ZW50UGFjayBuZXcpIGFkZDogKCcxNngxNictPigoQ29udGVudFBhY2sgbmV3KSBh -ZGQ6ICgncmVzaXplJy0+KChDb250ZW50UGFjayBuZXcpIGFkZDogKCdyZXNpemUzLnBuZyct -PihGb3JtCglleHRlbnQ6IDE2QDE2CglkZXB0aDogMzIKCWZyb21BcnJheTogIyggNDI5NDk2 -NzI5NSA0MjQ0NjM1NjQ3IDQyNDQ2MzU2NDcgNDI0NDYzNTY0NyA0MjQ0NjM1NjQ3IDQyNDQ2 -MzU2NDcgNDI0NDYzNTY0NyA0MjQ0NjM1NjQ3IDQyNDQ2MzU2NDcgNDI0NDYzNTY0NyA0MjQ0 -NTY5ODU0IDQyNDQ1Njk4NTQgNDI0NDU2OTg1NCA0MjQ0NTY5ODU0IDQyNDQ1Njk4NTQgNDI5 -NDk2NzI5NSA0MjQ0NjM1NjQ3IDQyNzg5Nzk1OTYgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQy -NzgxOTAwODAgNDI3ODk3OTU5NiA0Mjk0MTExOTg2IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAg -NDI3ODE5MDA4MCA0MjQ0NTY5ODU0IDQyNDQ2MzU2NDcgNDI3ODg0ODAxMCA0Mjk0MzA5MzY1 -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0MTExOTg2IDQyOTQ5MDE1MDIgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjc4MTkwMDgwIDQyNDQ1Njk4NTQgNDI0NDYzNTY0NyA0Mjc4NTg0 -ODM4IDQyOTQ1NzI1MzcgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyNzgxOTAwODAgNDI0NDU2OTg1NCA0MjQ0 -NjM1NjQ3IDQyNzgzODc0NTkgNDI5NDc2OTkxNiA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQy -OTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI3ODE5MDA4MCA0 -MjQ0NTY5ODU0IDQyNDQ2MzU2NDcgNDI3ODI1NTg3MyA0Mjk0OTAxNTAyIDQyOTQ5NjcyOTUg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjc4MTkwMDgwIDQyNDQ1Njk4NTQgNDI0NDYzNTY0NyA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3 -Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI0NDYzNTY0NyA0MjQ0NjM1NjQ3IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0 -OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0MjQ0NjM1NjQ3IDQy -NDQ2MzU2NDcgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDQyNDQ2MzU2NDcgNDI0NDYzNTY0NyA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3 -Mjk1IDQyOTQ5NjcyOTUgNDI0NDYzNTY0NyA0MjQ0NjM1NjQ3IDQyNzgxOTAwODAgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0 -OTY3Mjk1IDQyOTQ3MDQxMjMgNDI3ODU4NDgzOCA0MjQ0NjM1NjQ3IDQyNDQ2MzU2NDcgNDI3 -ODE5MDA4MCA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQy -OTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDgzNTcwOSA0Mjc4NDUzMjUyIDQyNDQ2MzU2NDcg -NDI0NDYzNTY0NyA0Mjc4MTkwMDgwIDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTAxNTAyIDQyNzgzODc0 -NTkgNDI0NDYzNTY0NyA0MjQ0NjM1NjQ3IDQyNzgxOTAwODAgNDI5NDk2NzI5NSA0Mjk0OTY3 -Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI3ODMyMTY2NiA0MjQ0NjM1NjQ3IDQyNDQ2MzU2NDcgNDI3ODE5MDA4MCA0Mjc4 -MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5MDE1MDIgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQy -NzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MjU1ODczIDQyNDQ2MzU2NDcgNDI5NDk2NzI5NSA0 -MjQ0NjM1NjQ3IDQyNDQ2MzU2NDcgNDI0NDYzNTY0NyA0MjQ0NjM1NjQ3IDQyNDQ2MzU2NDcg -NDI0NDYzNTY0NyA0MjQ0NjM1NjQ3IDQyNDQ2MzU2NDcgNDI0NDYzNTY0NyA0MjQ0NjM1NjQ3 -IDQyNDQ2MzU2NDcgNDI0NDYzNTY0NyA0MjQ0NjM1NjQ3IDQyNDQ2MzU2NDcgNDI5NDk2NzI5 -NSkKCW9mZnNldDogMEAwKSk7IGFkZDogKCdyZXNpemUtcmlnaHQucG5nJy0+KEZvcm0KCWV4 -dGVudDogMTZAMTYKCWRlcHRoOiAzMgoJZnJvbUFycmF5OiAjKCA0Mjc4MTkwMDgwIDQyNzgx -OTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4 -MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3 -ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQy -NzgxOTAwODAgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSAzODkyMjQ4NTc2IDQyOTQ5MDE3NjAg -NDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjc4MTI0NTQ0 -IDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQwMDk2ODkw -ODggNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAx -NzYwIDQyNzgxMjQ1NDQgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDAyNjQ2NjMwNCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0 -OTAxNzYwIDQyOTQ5MDE3NjAgNDI3ODEyNDU0NCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQy -OTQ5NjcyOTUgNDI5NDk2NzI5NSA0MDI2NDY2MzA0IDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0 -Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0MjYxMzQ3MzI4IDQyNzgxOTAwODAg -NDI3ODE5MDA4MCA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQwMjY0NjYzMDQgNDI5NDkwMTc2 -MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyNjEzNDcz -MjggNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3 -Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDAyNjQ2 -NjMwNCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5 -MDE3NjAgNDI2MTM0NzMyOCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDk2NzI5NSA0Mjk0 -OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0MDI2NDY2MzA0IDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQy -OTQ5MDE3NjAgNDI5NDkwMTc2MCA0MjYxMzQ3MzI4IDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQwNDMyNDM1MjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYw -IDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyNjEzNDczMjggNDI3ODE5MDA4 -MCA0Mjc4MTkwMDgwIDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDA0MzI0MzUyMCA0Mjk0OTAx -NzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI0NDU3 -MDExMiA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0MDYw -MDIwNzM2IDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5 -NDkwMTc2MCA0MjQ0NTcwMTEyIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0OTY3Mjk1IDQy -OTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQwNjAwMjA3MzYgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAg -NDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyNDQ1NzAxMTIgNDI3ODE5MDA4MCA0Mjc4MTkwMDgw -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDA2MDAyMDczNiA0Mjk0OTAxNzYwIDQyOTQ5MDE3 -NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI0NDU3MDExMiA0Mjc4MTkw -MDgwIDQyNzgxOTAwODAgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0MDc2Nzk3OTUyIDQyOTQ5 -MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0MjI3 -NzkyODk2IDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDM5 -OTI5MTE4NzIgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0 -Mjk0OTAxNzYwIDQyMTEwMTU2ODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAg -NDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgw -IDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4 -MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwKQoJb2Zmc2V0 -OiAwQDApKTsgYWRkOiAoJ3Jlc2l6ZS1ib3R0b20tcmlnaHQucG5nJy0+KEZvcm0KCWV4dGVu -dDogMTZAMTYKCWRlcHRoOiAzMgoJZnJvbUFycmF5OiAjKCA0Mjc4MTkwMDgwIDQyNzgxOTAw -ODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkw -MDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5 -MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgx -OTAwODAgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0 -OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQy -NzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3 -Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0 -OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyNzgxOTAwODAgNDI3 -ODE5MDA4MCA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQy -OTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDk2NzI5NSA0Mjk0OTY3 -Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0MTEw -NDE3OTE5IDM4OTIzMTQxMTEgMzg5MjMxNDExMSAzODkyMzE0MTExIDM4OTIzMTQxMTEgMzg5 -MjMxNDExMSA0MTEwNDE3OTE5IDQxMTAzNTIzODQgMzg5MjI0ODU3NiAzODkyMjQ4NTc2IDM4 -OTIyNDg1NzYgMzg5MjI0ODU3NiAzODkyMjQ4NTc2IDQxMTAzNTIzODQgNDI3ODE5MDA4MCA0 -Mjc4MTkwMDgwIDM4OTIzMTQxMTEgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDM4OTIzMTQxMTEgMzg5MjI0ODU3NiA0Mjk0OTAxNzYw -IDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgMzg5MjI0ODU3 -NiA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgMzg5MjMxNDExMSA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgMzg5MjMxNDExMSAzODkyMjQ4 -NTc2IDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkw -MTc2MCAzODkyMjQ4NTc2IDQyNzgxOTAwODAgNDI3ODE5MDA4MCAzODkyMzE0MTExIDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSAzODky -MzE0MTExIDM4OTIyNDg1NzYgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5 -NDkwMTc2MCA0Mjk0OTAxNzYwIDM4OTIyNDg1NzYgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDM4 -OTIzMTQxMTEgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDM4OTIzMTQxMTEgMzg5MjI0ODU3NiA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAg -NDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgMzg5MjI0ODU3NiA0Mjc4MTkwMDgw -IDQyNzgxOTAwODAgMzg5MjMxNDExMSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgMzg5MjMxNDExMSAzODkyMjQ4NTc2IDQyOTQ5MDE3 -NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCAzODkyMjQ4 -NTc2IDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0MTEwNDE3OTE5IDM4OTIzMTQxMTEgMzg5MjMx -NDExMSAzODkyMzE0MTExIDM4OTIzMTQxMTEgMzg5MjMxNDExMSA0MTEwNDE3OTE5IDQxMTAz -NTIzODQgMzg5MjI0ODU3NiAzODkyMjQ4NTc2IDM4OTIyNDg1NzYgMzg5MjI0ODU3NiAzODky -MjQ4NTc2IDQxMTAzNTIzODQgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3 -ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQy -NzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0 -Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwKQoJb2Zmc2V0OiAw -QDApKTsgYWRkOiAoJ3Jlc2l6ZS10b3AucG5nJy0+KEZvcm0KCWV4dGVudDogMTZAMTYKCWRl -cHRoOiAzMgoJZnJvbUFycmF5OiAjKCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4 -MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAw -ODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkw -MDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDkw -MTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5 -MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0 -OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyNzgxOTAwODAgNDI3 -ODE5MDA4MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQy -OTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0 -Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAg -NDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYw -IDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2 -MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3 -NjAgNDI5NDkwMTc2MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDkwMTc2MCA0Mjk0OTAx -NzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkw -MTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5 -MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0 -OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5 -NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQy -OTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI3ODE5MDA4MCA0 -Mjc4MTkwMDgwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAg -NDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYw -IDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2 -MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3 -NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAx -NzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkw -MTc2MCA0Mjk0OTAxNzYwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0 -OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQy -OTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjc4MTkwMDgw -IDQyNzgxOTAwODAgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3 -Mjk1IDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0 -OTY3Mjk1IDQyOTQ5NjcyOTUgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQy -OTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjc4MTkwMDgwIDQyNzgxOTAwODAg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyNzgxOTAw -ODAgNDI3ODE5MDA4MCA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3 -Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4 -MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3 -ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQy -NzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwKQoJb2Zmc2V0OiAwQDApKTsgYWRkOiAo -J3Jlc2l6ZS1ib3R0b20tbGVmdC5wbmcnLT4oRm9ybQoJZXh0ZW50OiAxNkAxNgoJZGVwdGg6 -IDMyCglmcm9tQXJyYXk6ICMoIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQy -NzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0 -Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAg -NDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI3ODE5MDA4MCA0Mjc4MTkw -MDgwIDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjc4 -MTkwMDgwIDQyNzgxOTAwODAgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQy -OTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3 -Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjc4MTkwMDgwIDQyNzgx -OTAwODAgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0 -OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQy -NzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQxMTAzNTIzODQgMzg5MjI0ODU3 -NiAzODkyMjQ4NTc2IDM4OTIyNDg1NzYgMzg5MjI0ODU3NiAzODkyMjQ4NTc2IDQxMTAzNTIz -ODQgNDExMDQxNzkxOSAzODkyMzE0MTExIDM4OTIzMTQxMTEgMzg5MjMxNDExMSAzODkyMzE0 -MTExIDM4OTIzMTQxMTEgNDExMDQxNzkxOSA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgMzg5MjI0 -ODU3NiA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5 -MDE3NjAgMzg5MjI0ODU3NiAzODkyMzE0MTExIDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0 -OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSAzODkyMzE0MTExIDQyNzgxOTAwODAgNDI3 -ODE5MDA4MCAzODkyMjQ4NTc2IDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQy -OTQ5MDE3NjAgNDI5NDkwMTc2MCAzODkyMjQ4NTc2IDM4OTIzMTQxMTEgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDM4OTIzMTQxMTEg -NDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDM4OTIyNDg1NzYgNDI5NDkwMTc2MCA0Mjk0OTAxNzYw -IDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDM4OTIyNDg1NzYgMzg5MjMxNDEx -MSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgMzg5MjMxNDExMSA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgMzg5MjI0ODU3NiA0Mjk0OTAx -NzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgMzg5MjI0 -ODU3NiAzODkyMzE0MTExIDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSAzODkyMzE0MTExIDQyNzgxOTAwODAgNDI3ODE5MDA4MCAzODky -MjQ4NTc2IDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5 -NDkwMTc2MCAzODkyMjQ4NTc2IDM4OTIzMTQxMTEgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQy -OTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDM4OTIzMTQxMTEgNDI3ODE5MDA4MCA0 -Mjc4MTkwMDgwIDQxMTAzNTIzODQgMzg5MjI0ODU3NiAzODkyMjQ4NTc2IDM4OTIyNDg1NzYg -Mzg5MjI0ODU3NiAzODkyMjQ4NTc2IDQxMTAzNTIzODQgNDExMDQxNzkxOSAzODkyMzE0MTEx -IDM4OTIzMTQxMTEgMzg5MjMxNDExMSAzODkyMzE0MTExIDM4OTIzMTQxMTEgNDExMDQxNzkx -OSA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAw -ODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkw -MDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5 -MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODApCglvZmZzZXQ6IDBAMCkpOyBhZGQ6ICgncmVz -aXplLXRvcC1yaWdodC5wbmcnLT4oRm9ybQoJZXh0ZW50OiAxNkAxNgoJZGVwdGg6IDMyCglm -cm9tQXJyYXk6ICMoIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAw -ODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkw -MDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5 -MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0MTEwNDE3OTE5IDM4OTIz -MTQxMTEgMzg5MjMxNDExMSAzODkyMzE0MTExIDM4OTIzMTQxMTEgMzg5MjMxNDExMSA0MTEw -NDE3OTE5IDQxMTAzNTIzODQgMzg5MjI0ODU3NiAzODkyMjQ4NTc2IDM4OTIyNDg1NzYgMzg5 -MjI0ODU3NiAzODkyMjQ4NTc2IDQxMTAzNTIzODQgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDM4 -OTIzMTQxMTEgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDM4OTIzMTQxMTEgMzg5MjI0ODU3NiA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAg -NDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgMzg5MjI0ODU3NiA0Mjc4MTkwMDgw -IDQyNzgxOTAwODAgMzg5MjMxNDExMSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgMzg5MjMxNDExMSAzODkyMjQ4NTc2IDQyOTQ5MDE3 -NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCAzODkyMjQ4 -NTc2IDQyNzgxOTAwODAgNDI3ODE5MDA4MCAzODkyMzE0MTExIDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSAzODkyMzE0MTExIDM4OTIy -NDg1NzYgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0 -OTAxNzYwIDM4OTIyNDg1NzYgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDM4OTIzMTQxMTEgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDM4 -OTIzMTQxMTEgMzg5MjI0ODU3NiA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0 -Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgMzg5MjI0ODU3NiA0Mjc4MTkwMDgwIDQyNzgxOTAwODAg -Mzg5MjMxNDExMSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgMzg5MjMxNDExMSAzODkyMjQ4NTc2IDQyOTQ5MDE3NjAgNDI5NDkwMTc2 -MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCAzODkyMjQ4NTc2IDQyNzgxOTAw -ODAgNDI3ODE5MDA4MCA0MTEwNDE3OTE5IDM4OTIzMTQxMTEgMzg5MjMxNDExMSAzODkyMzE0 -MTExIDM4OTIzMTQxMTEgMzg5MjMxNDExMSA0MTEwNDE3OTE5IDQxMTAzNTIzODQgMzg5MjI0 -ODU3NiAzODkyMjQ4NTc2IDM4OTIyNDg1NzYgMzg5MjI0ODU3NiAzODkyMjQ4NTc2IDQxMTAz -NTIzODQgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0 -OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQy -OTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyNzgxOTAwODAgNDI3ODE5MDA4 -MCA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3 -Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI3ODE5 -MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0 -OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQy -OTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI3ODE5MDA4MCA0Mjc4MTkw -MDgwIDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjc4 -MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3 -ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQy -NzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0 -Mjc4MTkwMDgwIDQyNzgxOTAwODApCglvZmZzZXQ6IDBAMCkpOyBhZGQ6ICgncmVzaXplLWxl -ZnQucG5nJy0+KEZvcm0KCWV4dGVudDogMTZAMTYKCWRlcHRoOiAzMgoJZnJvbUFycmF5OiAj -KCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAw -ODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkw -MDgwIDQyNzgxOTAwODAgNDI3ODI1NTg3MyA0Mjc5MzA4NTYxIDQyNzkzMDg1NjEgNDI3OTE3 -Njk3NSA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5 -MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjc4 -MTkwMDc5IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0MTYwNzQ5NTY3IDQxNjA3NDk1NjcgNDE3 -NzUyNjc4MyAzOTA5MDkxMzI3IDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0OTAxNzYwIDQy -OTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0 -Mjk0OTAxNzYwIDQyNjE0MTI4NjMgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQwMjY1MzE4MzkgNDI3ODE5MDA4MCA0Mjc4MTkwMDgw -IDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2 -MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI0NDYzNTY0NyA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDA0MzMwOTA1NSA0Mjc4MTkw -MDgwIDQyNzgxOTAwODAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkw -MTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0MjI3ODU4NDMxIDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0MDc2 -ODYzNDg3IDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5 -NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQy -MTEwODEyMTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQwOTM2NDA3MDMgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5MDE3NjAg -NDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYw -IDQyOTQ5MDE3NjAgNDE5NDMwMzk5OSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDExMDQxNzkxOSA0Mjc4MTkwMDgwIDQyNzgxOTAw -ODAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAx -NzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0MTc3NTI2NzgzIDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0MTQzOTcyMzUxIDQyNzgx -OTAwODAgNDI3ODE5MDA4MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0 -OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQxNDM5NzIzNTEgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQx -NjA3NDk1NjcgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0 -Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAg -NDEyNzE5NTEzNSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDE5NDMwMzk5OSA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDkwMTc2 -MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3 -NjAgNDI5NDkwMTc2MCA0MTEwNDE3OTE5IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3 -Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0MjExMDgxMjE1IDQyNzgxOTAwODAgNDI3ODE5 -MDA4MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5 -MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQwNzY4NjM0ODcgNDI5NDk2NzI5NSA0Mjk0 -OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyMjc4NTg0MzEgNDI3 -ODE5MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQy -OTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDA2MDA4NjI3MSA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI0NDYzNTY0NyA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYw -IDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2 -MCA0MDI2NTMxODM5IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0MjYxNDEyODYzIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0OTAx -NzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkw -MTc2MCA0Mjk0OTAxNzYwIDM4OTIzMTQxMTEgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDE0Mzk3MjM1MSA0MTQzOTcyMzUxIDQwNjAwODYyNzEgNDI3ODE5MDA4MCA0Mjc4 -MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3 -ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQy -NzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0 -Mjc4MTkwMDgwKQoJb2Zmc2V0OiAwQDApKTsgYWRkOiAoJ3Jlc2l6ZS5wbmcnLT4oRm9ybQoJ -ZXh0ZW50OiAxNkAxNgoJZGVwdGg6IDMyCglmcm9tQXJyYXk6ICMoIDQyNzgxOTAwODAgNDI3 -ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzg4NDgwMTAgNDI0MDE2MTcyMyA0MjI3ODU4NDMxIDQy -Mjc4NTg0MzEgNDIyNzg1ODQzMSA0MjI3ODU4NDMxIDQyMjc4NTg0MzEgNDIyNzg1ODQzMSA0 -MjM5ODk4NTUxIDQyNzk1NzE3MzMgNDI3OTE3Njk3NSA0Mjc4NzE2NDI0IDQyNzk3MDMzMTkg -NDI3ODE5MDA4MCA0Mjc4OTEzODAzIDQyNzkyNDI3NjggNDI5MDU1OTE2NCA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI4OTQ0MDY4MyA0Mjc4OTc5NTk2IDQyNzgyNTU4 -NzMgNDI3ODcxNjQyNCA0Mjc4MTkwMDgwIDQyNzkxNzY5NzUgNDI3OTMwODU2MSA0MjkwNDkz -MzcxIDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0MjkwNDkzMzcxIDQyNzky -NDI3NjggNDI3ODkxMzgwMyA0Mjc4NzE2NDI0IDQyNzg5MTM4MDMgNDI5MDY5MDc1MCA0Mjkx -MjE3MDk0IDQyNzk1NzE3MzMgNDI5MDAzMjgyMCA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0MjkwNDI3NTc4IDQy -Nzk1MDU5NDAgNDI5MDgyMjMzNiA0Mjg5NTcyMjY5IDQyNzkyNDI3NjggNDI1NzEzNjMxOCA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5MTIxNzA5NCA0Mjc5NTcxNzMzIDQyODk5NjcwMjcg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0MjkwMzYxNzg1 -IDQyNzk1MDU5NDAgNDI5MDg4ODEyOSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI1NjYwOTk3 -NCA0MjQ0NjM1NjQ3IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTE2MTE4 -NTIgNDI3OTc2OTExMiA0Mjg5OTY3MDI3IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0MjkwMzYx -Nzg1IDQyNzk3MDMzMTkgNDI5MTI4Mjg4NyA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0MjQ0NjM1NjQ3IDQyNDQ2MzU2NDcgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0MjkxNjExODUyIDQyNzk3NjkxMTIgNDI4OTkwMTIzNCA0Mjkw -MzYxNzg1IDQyNzk3MDMzMTkgNDI5MTI4Mjg4NyA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyNDQ2MzU2NDcgNDI0NDYzNTY0NyA0Mjk0OTY3Mjk1IDQy -OTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5MTYxMTg1MiA0 -Mjc5MzA4NTYxIDQyNzkyNDI3NjggNDI5MTI4Mjg4NyA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI0NDYzNTY0NyA0MjQ0NjM1NjQ3 -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0MjkwMjMwMTk5IDQyNzkzNzQzNTQgNDI3OTQ0MDE0NyA0Mjg5ODM1NDQxIDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0MjQ0NjM1 -NjQ3IDQyNDQ2MzU2NDcgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0MjkwMjMwMTk5IDQyNzk3MDMzMTkgNDI5MTM0ODY4MCA0MjkxNjc3NjQ1IDQyNzk3 -NjkxMTIgNDI4OTgzNTQ0MSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0 -OTY3Mjk1IDQyNDQ2MzU2NDcgNDI0NDYzNTY0NyA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0MjkwMjMwMTk5IDQyNzk3MDMzMTkgNDI5MTQxNDQ3MyA0Mjk0OTY3Mjk1IDQy -OTQ5NjcyOTUgNDI5MTc0MzQzOCA0Mjc5NzY5MTEyIDQyODk4MzU0NDEgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI0NDYzNTY0NyA0MjU3NTMxMDc2IDQyOTQ5NjcyOTUg -NDI5NDk2NzI5NSA0MjkwMTY0NDA2IDQyNzk3MDMzMTkgNDI5MTQxNDQ3MyA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTE3NDM0MzggNDI3OTc2OTEx -MiA0Mjg5NzY5NjQ4IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0MjU2OTM4OTM5IDQyNzk1MDU5 -NDAgNDI5MDU1OTE2NCA0MjkwMTY0NDA2IDQyNzk3NjkxMTIgNDI5MTQxNDQ3MyA0Mjk0OTY3 -Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0MjkxNzQzNDM4IDQyNzk4MzQ5MDUgNDI4OTc2OTY0OCA0MjkwNTU5MTY0IDQyNzg4 -NDgwMTAgNDI3ODU4NDgzOCA0Mjc4OTEzODAzIDQyNzkzNzQzNTQgNDI5MTY3NzY0NSA0Mjk0 -OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5MTY3NzY0NSA0Mjc5Mzc0MzU0IDQy -NzkwNDUzODkgNDI3ODE5MDA4MCA0Mjc4NTg0ODM4IDQyNzg0NTMyNTIgNDI3OTA0NTM4OSA0 -MjkwMDMyODIwIDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0MjkwNDI3NTc4 -IDQyNzg5MTM4MDMgNDI3ODQ1MzI1MiA0Mjc4MTkwMDgwIDQyNjE5MzkyMDggNDI3ODE5MDA4 -MCA0Mjc4MTkwMDgwIDQyNjE5MzkyMDggNDEwNTYxNTAzMCA0MDQzMzA5MDU1IDQwNDMzMDkw -NTUgNDA0MzMwOTA1NSA0MDQzMzA5MDU1IDQwNDMzMDkwNTUgNDA0MzMwOTA1NSA0MDg5Njkz -MTIzIDQyNDYxNDg4ODcgNDI2MjA3MDc5NCA0MjYyMDcwNzk0IDQyNDU0MjUxNjQpCglvZmZz -ZXQ6IDBAMCkpOyBhZGQ6ICgncmVzaXplLXRvcC1sZWZ0LnBuZyctPihGb3JtCglleHRlbnQ6 -IDE2QDE2CglkZXB0aDogMzIKCWZyb21BcnJheTogIyggNDI3ODE5MDA4MCA0Mjc4MTkwMDgw -IDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4 -MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAw -ODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkw -MDgwIDQxMTAzNTIzODQgMzg5MjI0ODU3NiAzODkyMjQ4NTc2IDM4OTIyNDg1NzYgMzg5MjI0 -ODU3NiAzODkyMjQ4NTc2IDQxMTAzNTIzODQgNDExMDQxNzkxOSAzODkyMzE0MTExIDM4OTIz -MTQxMTEgMzg5MjMxNDExMSAzODkyMzE0MTExIDM4OTIzMTQxMTEgNDExMDQxNzkxOSA0Mjc4 -MTkwMDgwIDQyNzgxOTAwODAgMzg5MjI0ODU3NiA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5 -NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgMzg5MjI0ODU3NiAzODkyMzE0MTExIDQy -OTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSAz -ODkyMzE0MTExIDQyNzgxOTAwODAgNDI3ODE5MDA4MCAzODkyMjQ4NTc2IDQyOTQ5MDE3NjAg -NDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCAzODkyMjQ4NTc2 -IDM4OTIzMTQxMTEgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDM4OTIzMTQxMTEgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDM4OTIyNDg1 -NzYgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAx -NzYwIDM4OTIyNDg1NzYgMzg5MjMxNDExMSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgMzg5MjMxNDExMSA0Mjc4MTkwMDgwIDQyNzgx -OTAwODAgMzg5MjI0ODU3NiA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0 -OTAxNzYwIDQyOTQ5MDE3NjAgMzg5MjI0ODU3NiAzODkyMzE0MTExIDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSAzODkyMzE0MTExIDQy -NzgxOTAwODAgNDI3ODE5MDA4MCAzODkyMjQ4NTc2IDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0 -Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCAzODkyMjQ4NTc2IDM4OTIzMTQxMTEg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDM4OTIzMTQxMTEgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQxMTAzNTIzODQgMzg5MjI0ODU3 -NiAzODkyMjQ4NTc2IDM4OTIyNDg1NzYgMzg5MjI0ODU3NiAzODkyMjQ4NTc2IDQxMTAzNTIz -ODQgNDExMDQxNzkxOSAzODkyMzE0MTExIDM4OTIzMTQxMTEgMzg5MjMxNDExMSAzODkyMzE0 -MTExIDM4OTIzMTQxMTEgNDExMDQxNzkxOSA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0 -OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyNzgxOTAwODAgNDI3 -ODE5MDA4MCA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQy -OTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDk2NzI5NSA0Mjk0OTY3 -Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0 -OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQy -OTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI3ODE5MDA4MCA0 -Mjc4MTkwMDgwIDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3 -Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgx -OTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4 -MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3 -ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCkKCW9mZnNldDogMEAw -KSk7IGFkZDogKCdyZXNpemUtYm90dG9tLnBuZyctPihGb3JtCglleHRlbnQ6IDE2QDE2Cglk -ZXB0aDogMzIKCWZyb21BcnJheTogIyggNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAw -ODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkw -MDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5 -MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0 -OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjc4MTkwMDgwIDQy -NzgxOTAwODAgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3 -Mjk1IDQyOTQ5NjcyOTUgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0 -OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQy -OTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyNzgxOTAwODAg -NDI3ODE5MDA4MCA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3 -Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDkwMTc2MCA0Mjk0 -OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5 -NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQy -OTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0 -Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAg -NDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYw -IDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI3ODE5MDA4 -MCA0Mjc4MTkwMDgwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3 -NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAx -NzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkw -MTc2MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5 -MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0 -OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5 -NDkwMTc2MCA0Mjk0OTAxNzYwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0OTAxNzYwIDQy -OTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0 -Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAg -NDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgw -IDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2 -MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3 -NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjc4MTkw -MDgwIDQyNzgxOTAwODAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkw -MTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5 -MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0 -OTAxNzYwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3 -ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQy -NzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0 -Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCkKCW9mZnNldDogMEAwKSk7IHlvdXJz -ZWxmKSk7IHlvdXJzZWxmKSk7IHlvdXJzZWxmKQ=='! ! -!ContentPack methodsFor: 'generated code' stamp: 'jmv 9/28/2018 10:41:53'! -objectCount ^ 1! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - -Theme content merge: ContentPack decode. -ContentPack removeCategory: ContentPack generatedMethodsCategory! - -ContentPack removeSelector: #contentMap! - -ContentPack removeSelector: #object1! - -ContentPack removeSelector: #objectCount! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3463-AddNewResizeIcons-JuanVuletich-2018Sep28-12h19m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3461] on 2 October 2018 at 4:57:52 pm'! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 15:32:43'! - classOfBlockArgNamed: aName - - ^ nil! ! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 16:55:03'! - classOfBlockTempVarNamed: aName - - ^ nil! ! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 15:32:49'! - classOfInstVarNamed: aName - - ^ nil! ! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 15:32:56'! - classOfTempVarNamed: aName - - ^ nil! ! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 15:33:03'! - classOfThisContext - - ^ nil! ! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 15:33:09'! - classOfWorkspaceVarNamed: aName - - ^ nil! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 15:34:05'! - classOfBlockArgNamed: aName - - ^ textProvider classOfBlockArgNamed: aName ! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 16:56:47'! - classOfBlockTempVarNamed: aName - - ^ textProvider classOfBlockTempVarNamed: aName ! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 15:34:21'! - classOfInstVarNamed: aName - - ^ textProvider classOfInstVarNamed: aName ! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 15:34:36'! - classOfTempVarNamed: aName - - ^ textProvider classOfTempVarNamed: aName ! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 15:34:50'! - classOfThisContext - - ^ textProvider classOfThisContext ! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 15:35:04'! - classOfWorkspaceVarNamed: aName - - ^ textProvider classOfWorkspaceVarNamed: aName ! ! -!Workspace methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 15:50:00'! - classOfBindingOf: aName - - ^ (self bindingOf: aName) value ifNotNil: [ :aValue | aValue class ] ! ! -!Workspace methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 15:50:14'! - classOfTempVarNamed: aName - - ^ self classOfBindingOf: aName ! ! -!Workspace methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 15:50:27'! - classOfWorkspaceVarNamed: aName - - ^ self classOfBindingOf: aName ! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 9/28/2018 13:50:02'! - classOfBlockArgNamed: aName - - ^ nil! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 16:54:36'! - classOfBlockTempVarNamed: aName - - ^ nil! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 9/28/2018 13:50:17'! - classOfInstVarNamed: aName - - ^ nil! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 9/28/2018 13:50:42'! - classOfTempVarNamed: aName - - ^ nil! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 9/28/2018 13:51:28'! - classOfThisContext - - ^ nil! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 9/28/2018 13:51:53'! - classOfWorkspaceVarNamed: aName - - ^ nil! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 16:52:39'! - classOfBlockArgNamed: aName - - ^self classOfTempVarNamed: aName ! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 16:52:47'! - classOfBlockTempVarNamed: aName - - ^self classOfTempVarNamed: aName ! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 15:37:49'! - classOfInstVarNamed: aName - - ^ contextStackIndex ~= 0 ifTrue: [ (self receiver instVarNamed: aName) class]! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 16:53:29'! - classOfTempVarNamed: aName - - | context tempIndex | - - context := self selectedContext. - tempIndex := context tempNames indexOf: aName ifAbsent: [ ^ nil ]. - - ^ (self debuggerMap namedTempAt: tempIndex in: context) class - - ! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 15:52:45'! - classOfThisContext - - ^ self selectedContext class! ! -!Inspector methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 15:38:26'! - classOfInstVarNamed: aName - - ^ (object instVarNamed: aName) class ! ! -!Character methodsFor: 'testing' stamp: 'HAW 10/2/2018 16:31:57'! - isRightBracket - - ^self = $]! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 16:19:24'! - classOfBlockArgNamed: aName - - ^ nil! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 16:55:33'! - classOfBlockTempVarNamed: aName - - ^ nil! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 16:19:34'! - classOfInstVarNamed: aName - - ^ nil! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 16:19:42'! - classOfTempVarNamed: aName - - ^ nil! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 16:19:51'! - classOfThisContext - - ^ nil! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 16:19:58'! - classOfWorkspaceVarNamed: aName - - ^ nil! ! -!AutoCompleter methodsFor: 'keyboard - private' stamp: 'HAW 10/2/2018 16:36:34'! - shouldOpenMorphWhenNoPrefixFor: currentChar - - ^currentChar isAlphaNumeric or: [ currentChar isRightBracket ]! ! -!AutoCompleter methodsFor: 'keyboard - private' stamp: 'HAW 10/2/2018 16:34:55' prior: 50414934! - shouldOpenMorphWhenNoPrefixAt: currentPos - - ^ model textSize >= currentPos - and: [ currentPos > 0 - and: [ self shouldOpenMorphWhenNoPrefixFor: (model actualContents at: currentPos) ]]! ! -!SmalltalkCompleter methodsFor: 'entries' stamp: 'HAW 10/2/2018 16:29:25' prior: 50415224! - computeEntries - - | allSource contextClass specificModel last3Ranges range | - - allSource _ model actualContents string. - specificModel _ self textProviderOrModel. - contextClass _ self selectedClassOrMetaClassIn: specificModel. - last3Ranges _ self parse: (allSource copyFrom: 1 to: position) in: contextClass and: specificModel. - range _ last3Ranges third ifNil: [ ^entries _ #() ]. - - range end = position - ifTrue: [ self computeEntriesOfMessageOrIdentifiersFor: allSource using: last3Ranges at: range in: contextClass and: specificModel ] - ifFalse: [ self computeMessageEntriesWithEmptyPrefixFor: allSource at: range in: contextClass and: specificModel ]. - - ! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 10/2/2018 16:50:09' prior: 50415387! -computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel - - | id receiverClass | - - id _ allSource copyFrom: range start to: range end. - receiverClass _ range rangeType - caseOf: { - [ #globalVar ] -> [ (Smalltalk at: id asSymbol) class ]. - [ #self ] -> [ contextClass ]. - [ #super ] -> [ contextClass superclass ]. - [ #true ] -> [ True ]. - [ #false ] -> [ False ]. - [ #nil ] -> [ UndefinedObject ]. - [ #character ] -> [ id first class ]. - [ #number ] -> [ self classOfLiteral: id in: contextClass ]. - [ #string ] -> [ self classOfLiteral: id in: contextClass ]. - [ #symbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #stringSymbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #instVar ] -> [ specificModel classOfInstVarNamed: id ]. - [ #tempVar ] -> [ specificModel classOfTempVarNamed: id ]. - [ #workspaceVar ] -> [ specificModel classOfWorkspaceVarNamed: id ]. - [ #blockArg ] -> [ specificModel classOfBlockArgNamed: id ]. - [ #blockTempVar ] -> [ specificModel classOfBlockTempVarNamed: id ]. - [ #thisContext ] -> [ specificModel classOfThisContext ]. - [ #classVar ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #poolConstant ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #blockEnd ] -> [ BlockClosure ]. } - otherwise: [ nil ]. - - self computeMessageEntries: receiverClass! ! - -SmalltalkCompleter removeSelector: #classOfBlockArgNamed:in:! - -SmalltalkCompleter removeSelector: #classOfBlockArgNamed:in:! - -SmalltalkCompleter removeSelector: #classOfBlockArgNamed:inDebugger:! - -SmalltalkCompleter removeSelector: #classOfBlockArgNamed:inDebugger:! - -SmalltalkCompleter removeSelector: #classOfInstVarNamed:in:! - -SmalltalkCompleter removeSelector: #classOfInstVarNamed:in:! - -SmalltalkCompleter removeSelector: #classOfInstVarNamed:inDebugger:! - -SmalltalkCompleter removeSelector: #classOfInstVarNamed:inDebugger:! - -SmalltalkCompleter removeSelector: #classOfInstVarNamed:inInspector:! - -SmalltalkCompleter removeSelector: #classOfInstVarNamed:inInspector:! - -SmalltalkCompleter removeSelector: #classOfTempVarNamed:in:! - -SmalltalkCompleter removeSelector: #classOfTempVarNamed:in:! - -SmalltalkCompleter removeSelector: #classOfTempVarNamed:inContext:! - -SmalltalkCompleter removeSelector: #classOfTempVarNamed:inContext:! - -SmalltalkCompleter removeSelector: #classOfTempVarNamed:inDebugger:! - -SmalltalkCompleter removeSelector: #classOfTempVarNamed:inDebugger:! - -SmalltalkCompleter removeSelector: #classOfTempVarNamed:inInspector:! - -SmalltalkCompleter removeSelector: #classOfTempVarNamed:inInspector:! - -SmalltalkCompleter removeSelector: #classOfTempVarNamed:inWorkspace:! - -SmalltalkCompleter removeSelector: #classOfTempVarNamed:inWorkspace:! - -SmalltalkCompleter removeSelector: #classOfThisContextIn:! - -SmalltalkCompleter removeSelector: #classOfThisContextIn:! - -SmalltalkCompleter removeSelector: #classOfThisContextInDebugger:! - -SmalltalkCompleter removeSelector: #classOfThisContextInDebugger:! - -SmalltalkCompleter removeSelector: #classOfWorkspaceVarNamed:in:! - -SmalltalkCompleter removeSelector: #classOfWorkspaceVarNamed:in:! - -SmalltalkCompleter removeSelector: #classOfWorkspaceVarNamed:inInspector:! - -SmalltalkCompleter removeSelector: #classOfWorkspaceVarNamed:inInspector:! - -SmalltalkCompleter removeSelector: #classOfWorkspaceVarNamed:inWorkspace:! - -SmalltalkCompleter removeSelector: #classOfWorkspaceVarNamed:inWorkspace:! - -SmalltalkCompleter removeSelector: #shouldOpenMorphWhenNoPrefixFor:! - -Debugger removeSelector: #classOfThisContextIn:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3464-SmalltalkCompleterEnhancements-HernanWilkinson-2018Sep28-13h49m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3464] on 3 October 2018 at 3:23:41 pm'! -!Float methodsFor: 'truncation and round off' stamp: 'nice 3/1/2014 00:32' prior: 16845048! - successor - | ulp | - self isFinite ifFalse: [ - (self isNaN or: [self positive]) ifTrue: [^self]. - ^Float fmax negated]. - ulp := self ulp. - ^self + (0.5 * ulp) = self - ifTrue: [self * -1.0 - ulp * -1.0 "This trick is for obtaining a negativeZero"] - ifFalse: [self + (0.5 * ulp)]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3465-Float-successor-fix-NicolasCellier-2018Oct03-14h28m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3430] on 1 October 2018 at 4:22:14 pm'! -!PreDebugWindow class methodsFor: 'instance creation' stamp: 'jmv 10/1/2018 16:21:56' prior: 50335178! - open: model label: aString message: messageString - | window | - (Preferences usePreDebugWindow or: [messageString notNil]) - ifTrue: [ - window _ self new. - window - model: model; - buildMorphicWindowMessage: messageString print. - aString ifNotNil: [ window setLabel: aString ]. - window openInWorld ] - ifFalse: [ - model openFullMorphicLabel: aString ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3466-UsePreDebugWindowIfMessageToUser-JuanVuletich-2018Oct01-16h21m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3466] on 3 October 2018 at 4:37:19 pm'! -!Float methodsFor: 'comparing' stamp: 'nice 10/27/2014 21:57'! - literalEqual: aFloat - "Two float literals can be replaced by a single one only if their representation have the same bits. - For example, zero and negativeZero are equal, but not literally equal." - - ^self class == aFloat class and: [(self at: 1) = (aFloat at: 1) and: [(self at: 2) = (aFloat at: 2)]]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3467-Float-literalEqual-JuanVuletich-2018Oct03-16h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3467] on 3 October 2018 at 5:18:30 pm'! -!Float methodsFor: 'arithmetic' stamp: 'nice 12/20/2012 23:16' prior: 16845131! - negated - "Answer a Number that is the negation of the receiver. - Implementation note: this version cares of negativeZero." - - ^-1.0 * self! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3468-Float-negated-fix-NicolasCellier-2018Oct03-17h18m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3468] on 3 October 2018 at 5:52:09 pm'! -!Fraction methodsFor: 'mathematical functions' stamp: 'nice 4/25/2018 09:43'! - floorLog: radix - "Unlike super, this version is exact when radix is integer" - - | d n | - radix isInteger ifFalse: [^super floorLog: radix]. - n := numerator floorLog: radix. - d := denominator floorLog: radix. - ^(numerator * (radix raisedTo: d)) - < (denominator * (radix raisedTo: n)) - ifTrue: [n - d - 1] - ifFalse: [n - d]! ! -!Integer methodsFor: 'mathematical functions' stamp: 'nice 4/25/2018 09:43'! - floorLog: radix - "Unlike super, this version is exact when radix is integer" - - radix isInteger ifFalse: [^super floorLog: radix]. - self <= 0 ifTrue: [^DomainError signal: 'floorLog: is only defined for x > 0.0']. - ^(self numberOfDigitsInBase: radix) - 1! ! -!Number methodsFor: 'mathematical functions' stamp: 'nice 12/11/2012 19:18' prior: 16880105! - floorLog: radix - "Answer the floor of the log base radix of the receiver." - - ^(self log: radix) floor! ! -!Float methodsFor: 'mathematical functions' stamp: 'nice 6/3/2012 17:26' prior: 16844655! - floorLog: radix - "Answer the floor of the log base radix of the receiver. - The result may be off by one due to rounding errors, except in base 2." - - (radix = 2 and: [self > 0.0 and: [self isFinite]]) ifTrue: [^self exponent]. - ^ (self log: radix) floor -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3469-floorLog-exactWhenPossible-JuanVuletich-2018Oct03-17h24m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3430] on 2 October 2018 at 4:54:47 pm'! -!ClosureTraceNode methodsFor: 'printing' stamp: 'sqr 10/2/2018 16:14:51'! - dumpOn: aStream - - self dumpOn: aStream depth: 0! ! -!ClosureTraceNode methodsFor: 'printing' stamp: 'sqr 10/2/2018 16:54:39'! - dumpOn: aStream depth: anInteger - - anInteger timesRepeat: [aStream tab]. - self printOn: aStream. - aStream newLine. - self paths do: [:each | each dumpOn: aStream depth: anInteger + 1]! ! -!ClosureTraceNode methodsFor: 'printing' stamp: 'sqr 10/2/2018 16:16:41'! - dumpString - - | answer | - answer := String new writeStream. - self dumpOn: answer. - ^answer contents! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3470-ClosureTraceNode-dumpString-ud-2018Oct02-16h14m-sq.st----! - -----SNAPSHOT----#(8 October 2018 11:01:01.677053 am) Cuis5.0-3470-32.image priorSource: 2521200! - -----QUIT----#(8 October 2018 11:01:25.412521 am) Cuis5.0-3470-32.image priorSource: 2748807! - -----STARTUP----#(22 October 2018 2:44:57.043009 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3470-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3470] on 8 October 2018 at 6:54:40 pm'! -!Character class methodsFor: 'class initialization' stamp: 'jmv 10/8/2018 18:36:22'! - releaseClassState - UnaccentedTable _ nil. - UnicodeCodePoints _ nil! ! -!Character class methodsFor: 'constants' stamp: 'jmv 10/8/2018 18:39:44'! - unaccentedTable - UnaccentedTable ifNil: [ self initializeLookupTables ]. - ^UnaccentedTable! ! -!Character class methodsFor: 'constants' stamp: 'jmv 10/8/2018 18:37:36'! - unicodeCodePoints - UnicodeCodePoints ifNil: [ self initializeUnicodeCodePoints ]. - ^UnicodeCodePoints! ! -!Color class methodsFor: 'cached state access' stamp: 'jmv 10/8/2018 18:29:30'! - releaseClassState - "Do not remove them in every image save (#releaseClassCachedState) to save startup time." - " - Color releaseClassState - " - CachedColormaps _ nil. "Maps to translate between color depths" - ToGrayColormaps _ nil. "Maps colors to 8bpp grays for various color depths" - FromGrayColormaps _ nil. "Maps from 8bpp grays to colors of various depths" - MaskingMap _ nil. "Maps all colors except transparent to black for creating a mask" - IndexedColors _ nil. - GrayToIndexMap _ nil! ! -!BitBlt class methodsFor: 'cached state access' stamp: 'jmv 10/8/2018 18:31:40'! - releaseClassState - "Do not remove them in every image save (#releaseClassCachedState) to save startup time." - - CachedFontColorMaps _ ColorConvertingMaps _ nil! ! -!StrikeFont class methodsFor: 'class cached access' stamp: 'jmv 10/8/2018 18:53:44'! - releaseClassState - "Do not remove them in every image save (#releaseClassCachedState) to save startup time." - " - StrikeFont releaseClassState - " - "Deallocate synthetically derived copies of base fonts to save space" - self allSubInstancesDo: [ :sf | sf reset ]! ! -!BitBltCanvas class methodsFor: 'cached state access' stamp: 'jmv 10/8/2018 18:33:14'! - releaseClassState - "Do not remove them in every image save (#releaseClassCachedState) to save startup time." - " - BitBltCanvas releaseClassState - " - CachedForms _ nil.! ! -!Behavior methodsFor: 'system startup' stamp: 'jmv 10/8/2018 18:31:00' prior: 16785005! - releaseClassCachedState - "Will be called for each class on shutdown or snapshot. - All class vars or class instVar vars that can be cheaply recreated lazily on demand, should be nilled. - For more expensive stuff to recreate, consider #releaseClassState that is not called on every image save. - See implementors for examples"! ! -!Character methodsFor: 'accessing' stamp: 'jmv 10/8/2018 18:39:19' prior: 16800364! - codePoint - " - self assert: $A codePoint hex = '16r41'. - self assert: $¤ codePoint hex = '16r20AC'. - " - ^self class unicodeCodePoints at: self numericValue + 1! ! -!Character methodsFor: 'converting' stamp: 'jmv 10/8/2018 18:44:52' prior: 16800616! - asUnaccented - " - $A asUnaccented - $Á asUnaccented - (0 to: 255) collect: [ :i | (Character numericValue: i) asUnaccented ] - (0 to: 255) collect: [ :i | (Character numericValue: i) asUnaccented asLowercase] - " - ^ Character - numericValue: (self class unaccentedTable at: self numericValue + 1)! ! -!Character class methodsFor: 'class initialization' stamp: 'jmv 10/8/2018 18:46:39' prior: 16800743! - initialize - "Create the table of unique Characters. - Character initialize - " - self initializeLookupTables . - self initializeUnicodeCodePoints.! ! -!Character class methodsFor: 'converting' stamp: 'jmv 10/8/2018 18:37:44' prior: 16801210! - iso8859s15CodeForUnicodeCodePoint: codePoint - " - Answer nil if the Unicode codePoint is not a valid ISO 8859-15 character - - self assert: (Character iso8859s15CodeForUnicodeCodePoint: 16r41) = $A iso8859s15Code. - self assert: (Character iso8859s15CodeForUnicodeCodePoint: 16r20AC) = $¤ iso8859s15Code. - " - | code | - code _ (self unicodeCodePoints indexOf: codePoint) -1. - code = -1 ifTrue: [ ^nil ]. - ^code! ! -!BitBltCanvas class methodsFor: 'cached state access' stamp: 'jmv 10/8/2018 18:33:24' prior: 16787424! - releaseClassCachedState - " - BitBltCanvas releaseClassCachedState - " - AccessProtect _ nil. - AuxForm _ nil. - AuxBlitter _ nil! ! - -StrikeFont class removeSelector: #releaseClassCachedState! - -StrikeFont class removeSelector: #releaseClassCachedState! - -BitBlt class removeSelector: #releaseClassCachedState! - -BitBlt class removeSelector: #releaseClassCachedState! - -Color class removeSelector: #releaseClassCachedState! - -Color class removeSelector: #releaseClassCachedState! - -Character class removeSelector: #initClassCachedState! - -Character class removeSelector: #initClassCachedState! - -Character class removeSelector: #releaseClassCachedState! - -Character class removeSelector: #releaseClassCachedState! - -Character initialize! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3471-KeepExpensiveCachedStuff-JuanVuletich-2018Oct08-18h41m-jmv.3.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3470] on 8 October 2018 at 4:36:36 pm'! -!Float methodsFor: 'comparing' stamp: 'jmv 10/8/2018 16:29:40' prior: 16845719! - hash - "Hash is reimplemented because = is implemented. Both words of the float are used. (The bitShift:'s ensure that the intermediate results do not become a large integer.) Care is taken to answer same hash as an equal Integer." - - | asInteger | - self isFinite ifTrue: [ - asInteger _ self truncated. - asInteger = self ifTrue: [ - ^ asInteger hash ]]. - ^ ((self basicAt: 1) bitShift: -4) + - ((self basicAt: 2) bitShift: -4)! ! -!Fraction methodsFor: 'comparing' stamp: 'jmv 10/8/2018 16:30:04' prior: 16849531! - hash - "Hash is reimplemented because = is implemented. - Care is taken that a Fraction equal to a Float also have an equal hash" - - ^ self asFloat hash! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3472-Fraction-hash-consistentWithFloat-JuanVuletich-2018Oct08-16h29m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3472] on 9 October 2018 at 9:53:17 am'! -!Float methodsFor: 'converting' stamp: 'jmv 10/8/2018 18:05:43'! - partBits: aThreeArgumentBlock - " - Extract the bits for Sign, Mantissa and Exponent parts of the Floating Point representation. - Just extract the bits. Do not add implicit bit. Do not correct denormals. Do not substract exponent bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. (f signPart * f significandAsInteger * (2 raisedToInteger: f exponentPart-52)) asFloat = f } print ]. - " - | allBits signBit exponentBits mantissaBits | - - " Extract the bits of an IEEE double float " - allBits _ ((self basicAt: 1) bitShift: 32) + (self basicAt: 2). - - " Extract the sign and the biased exponent " - signBit _ allBits bitShift: -63. - exponentBits _ (allBits bitShift: -52) bitAnd: 16r7FF. - - " Extract fractional part " - mantissaBits _ allBits bitAnd: 16r000FFFFFFFFFFFFF. - - "Evaluate the block" - ^aThreeArgumentBlock value: signBit value: exponentBits value: mantissaBits! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 10/8/2018 18:10:16'! - exponentBits - " - Actual bits for the exponent part of the Floating Point representation. - Just extract the bits. Do not correct denormals. Do not substract bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - { f. f exponentBits. f exponentPart. f exponent } print ]. - " - - self partBits: [ :signBit :exponentBits :mantissaBits | - ^ exponentBits ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 10/8/2018 18:23:14'! - mantissaBits - " - Actual bits for the mantissa part of the Floating Point representation. - Just extract the bits. Do not correct denormals. Do not substract bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - { f. f mantissaBits. f mantissaPart. f significand. } print ]. - " - self partBits: [ :signBit :exponentBits :mantissaBits | - ^ mantissaBits ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 10/8/2018 18:15:24'! - signBit - " - Actual bits for the exponent part of the Floating Point representation. - Just extract the bits. Do not correct denormals. Do not substract bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0. 0.0. -0.0} do: [ :f | - { f. f signBit. f signPart. f sign } print ]. - " - - self partBits: [ :signBit :exponentBits :mantissaBits | - ^ signBit ]! ! -!Float methodsFor: 'converting' stamp: 'jmv 10/8/2018 18:17:37' prior: 16844918! - partValues: aThreeArgumentBlock ifInfinite: infiniryBlock ifNaN: nanBlock - " - Float pi hex print - Float pi partValues: [ :sign :exponent :mantissa | { sign hex. exponent hex. mantissa hex} print ] - 0.0 partValues: [ :sign :exponent :mantissa | { sign hex. exponent hex. mantissa hex} print ] - For 0.0, exponent will be the minimum possible, i.e. -1023, and mantissa will be 0. - " - | sign exponent mantissa | - - self partBits: [ :signBit :exponentBits :mantissaBits | - - " Extract the sign" - sign _ signBit = 0 ifTrue: [1] ifFalse: [-1]. - - " Special cases: infinites and NaN" - exponentBits = 16r7FF ifTrue: [ - ^mantissaBits = 0 - ifTrue: [ infiniryBlock valueWithPossibleArgument: self ] - ifFalse: [ nanBlock valueWithPossibleArgument: self and: mantissaBits ]]. - - "Unbias exponent: 16r3FF is bias" - exponent _ exponentBits - 16r3FF. - - " Replace omitted leading 1 in fraction if appropriate" - "If expPart = 0, I am +/-zero or a denormal value. In such cases, no implicit leading bit in mantissa" - exponentBits = 0 - ifTrue: [ - mantissa _ mantissaBits. - exponent _ exponent + 1 ] - ifFalse: [ - mantissa _ mantissaBits bitOr: 16r0010000000000000 ]. - - "Evaluate the block" - ^aThreeArgumentBlock value: sign value: exponent value: mantissa - ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 10/8/2018 18:13:53' prior: 50414546! - significandAsInteger - "The actual bits in the mantissa of the receiver, as an integer number, including the implicit leading 1 if appropriate. - See #exponentPart - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. (f signPart * f significandAsInteger * (2 raisedToInteger: f exponentPart-52)) asFloat = f } print ]. - " - ^self mantissaPart! ! -!BoxedFloat64 methodsFor: 'truncation and round off' stamp: 'jmv 10/8/2018 17:52:44' prior: 50414563! - exponent - "Primitive. Consider the receiver to be represented as a power of two - multiplied by a mantissa between one and two or between -1 and -2 (#significand). - Answer with the SmallInteger to whose power two is raised. - Optional. See Object documentation whatIsAPrimitive. - See also #signPart, #significandAsInteger and #exponentPart - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. f significand . f exponent. f significand * (2 raisedToInteger: f exponent) = f } print ]. - " - - | positive | - - self >= 1.0 ifTrue: [^self floorLog: 2]. - self > 0.0 - ifTrue: - [positive _ (1.0 / self) exponent. - self = (1.0 / (1.0 timesTwoPower: positive)) - ifTrue: [^positive negated] - ifFalse: [^positive negated - 1]]. - self = 0.0 ifTrue: [^-1]. - ^self negated exponent! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3473-Float-partBits-JuanVuletich-2018Oct09-09h43m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3471] on 9 October 2018 at 2:29:53 pm'! -!LargeNegativeInteger methodsFor: 'comparing' stamp: 'jmv 10/9/2018 14:20:27'! - hash - - self > Float maxExactInteger negated ifFalse: [ - ^ self asFloat hash ]. - ^ByteArray - hashBytes: self - startingWith: self species hash! ! -!Float methodsFor: 'comparing' stamp: 'jmv 10/9/2018 12:30:01' prior: 50417720! - hash - "Hash is reimplemented because = is implemented. Both words of the float are used. (The bitShift:'s ensure that the intermediate results do not become a large integer.) Care is taken to answer same hash as an equal Integer." - - | asInteger | - self isFinite ifTrue: [ - asInteger _ self truncated. - asInteger abs < Float maxExactInteger ifTrue: [ - ^ asInteger hash ]]. - ^ ((self basicAt: 1) bitShift: -4) + - ((self basicAt: 2) bitShift: -4)! ! -!Fraction methodsFor: 'comparing' stamp: 'jmv 10/8/2018 16:30:04' prior: 50417737! - hash - "Hash is reimplemented because = is implemented. - Care is taken that a Fraction equal to a Float also have an equal hash" - - ^ self asFloat hash! ! -!Integer methodsFor: 'comparing' stamp: 'jmv 10/9/2018 12:30:19' prior: 50333045! - hash - "Hash is reimplemented because = is implemented. - | s | - s _ (1 to: 10000) asSet. - [s includes: 123456] bench - " - - self abs < Float maxExactInteger ifFalse: [ - ^ self asFloat hash ]. - ^self hashMultiply! ! -!LargePositiveInteger methodsFor: 'comparing' stamp: 'jmv 10/9/2018 14:20:30' prior: 16862513! - hash - - self < Float maxExactInteger ifFalse: [ - ^ self asFloat hash ]. - ^ByteArray - hashBytes: self - startingWith: self species hash! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3474-Integer-hash-consistentWithFloat-JuanVuletich-2018Oct09-14h19m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3474] on 9 October 2018 at 2:51:00 pm'! -!LargePositiveInteger methodsFor: 'comparing' stamp: 'jmv 10/9/2018 14:49:10' prior: 50417971! - hash - self < `(2 raisedToInteger: Float emax+1)` ifFalse: [ - ^ `Float infinity hash` ]. - self < Float maxExactInteger ifFalse: [ - ^ self asFloat hash ]. - ^ByteArray - hashBytes: self - startingWith: self species hash! ! -!LargeNegativeInteger methodsFor: 'comparing' stamp: 'jmv 10/9/2018 14:50:07' prior: 50417928! - hash - - self > `(2 raisedToInteger: Float emax+1) negated` ifFalse: [ - ^ `Float negativeInfinity hash` ]. - self > Float maxExactInteger negated ifFalse: [ - ^ self asFloat hash ]. - ^ByteArray - hashBytes: self - startingWith: self species hash! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3475-Faster-LargeInteger-hash-JuanVuletich-2018Oct09-14h38m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3476] on 9 October 2018 at 4:31:26 pm'! -!Number methodsFor: 'truncation and round off' stamp: 'jmv 10/9/2018 16:30:05' prior: 16880603! - rounded - "Answer the integer nearest the receiver." - "See https://en.wikipedia.org/wiki/Rounding#Round_half_to_even" - - | truncated fractionPartAbs | - truncated _ self truncated. - fractionPartAbs _ (self-truncated) abs. - fractionPartAbs = (1/2) - ifTrue: [ truncated even ifTrue: [^truncated] ifFalse: [^truncated + self sign]]. - fractionPartAbs < (1/2) - ifTrue: [^ truncated] - ifFalse: [^ truncated + self sign]! ! - -Float removeSelector: #rounded! - -Float removeSelector: #rounded! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3476-RoundHalfToEven-JuanVuletich-2018Oct09-16h28m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3476] on 10 October 2018 at 3:49:14 pm'! -!Integer methodsFor: 'comparing' stamp: 'jmv 10/10/2018 15:44:51' prior: 50417961! - hash - "Hash is reimplemented because = is implemented. - | s | - s _ (1 to: 10000) asSet. - [s includes: 123456] bench - " - - "Can only happen in 64 bits images..." - self abs < Float maxExactInteger ifFalse: [ - ^ self asFloat hash ]. - - "In 32 bit image it will always go this way" - ^self hashMultiply! ! -!LargePositiveInteger methodsFor: 'comparing' stamp: 'jmv 10/10/2018 15:44:55' prior: 50417986! - hash - - self < `(2 raisedToInteger: Float emax+1)` ifFalse: [ - ^ `Float infinity hash` ]. - - self < Float maxExactInteger ifFalse: [ - "Will always enter here for 64 bits images." - ^ self asFloat hash ]. - - "May only reach here in 32 bit images" - ^ByteArray - hashBytes: self - startingWith: self species hash! ! -!LargeNegativeInteger methodsFor: 'comparing' stamp: 'jmv 10/10/2018 15:45:00' prior: 50417996! - hash - - self > `(2 raisedToInteger: Float emax+1) negated` ifFalse: [ - ^ `Float negativeInfinity hash` ]. - - self > Float maxExactInteger negated ifFalse: [ - "Will always enter here for 64 bits images." - ^ self asFloat hash ]. - - "May only reach here in 32 bit images" - ^ByteArray - hashBytes: self - startingWith: self species hash! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3477-hashComments-JuanVuletich-2018Oct10-15h48m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3476] on 10 October 2018 at 3:58:36 pm'! -!Float methodsFor: 'comparing' stamp: 'jmv 10/10/2018 15:53:22' prior: 50417936! - hash - "Hash is reimplemented because = is implemented. Both words of the float are used. (The bitShift:'s ensure that the intermediate results do not become a large integer.) Care is taken to answer same hash as an equal Integer." - - | asInteger | - self isFinite ifTrue: [ - asInteger _ self truncated. - (asInteger = self and: [ asInteger abs < Float maxExactInteger ]) ifTrue: [ - ^ asInteger hash ]]. - ^ ((self basicAt: 1) bitShift: -4) + - ((self basicAt: 2) bitShift: -4)! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3478-Float-hash-fix-JuanVuletich-2018Oct10-15h49m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3478] on 18 October 2018 at 9:52:42 am'! -!Float methodsFor: 'comparing' stamp: 'jmv 10/18/2018 09:52:13' prior: 50418087! - hash - "Hash is reimplemented because = is implemented. Both words of the float are used. (The bitShift:'s ensure that the intermediate results do not become a large integer.) Care is taken to answer same hash as an equal Integer." - - | asInteger | - self isFinite ifTrue: [ - asInteger _ self truncated. - "See Integer>>#hash, LargePositiveInteger>>#hash and LargeNegativeInteger>>#hash" - "Very big integers will answer true when asked #= with their own conversion to Float, - But that Float will #asInteger to a different integer. Use Float hash in those cases. - In addition, there is a performance improvement: the hash in LargeIntegers could - get very slow for very big numbers" - (asInteger = self and: [ asInteger abs < Float maxExactInteger ]) ifTrue: [ - ^ asInteger hash ]]. - ^ ((self basicAt: 1) bitShift: -4) + - ((self basicAt: 2) bitShift: -4)! ! -!Integer methodsFor: 'comparing' stamp: 'jmv 10/18/2018 09:48:12' prior: 50418040! - hash - "Hash is reimplemented because = is implemented. - | s | - s _ (1 to: 10000) asSet. - [s includes: 123456] bench - " - - "Can only happen in 64 bits images... - See Float>>#hash, LargePositiveInteger>>#hash and LargeNegativeInteger>>#hash" - self abs < Float maxExactInteger ifFalse: [ - ^ self asFloat hash ]. - - "In 32 bit image it will always go this way" - ^self hashMultiply! ! -!LargePositiveInteger methodsFor: 'comparing' stamp: 'jmv 10/18/2018 09:48:28' prior: 50418053! - hash - - self < `(2 raisedToInteger: Float emax+1)` ifFalse: [ - ^ `Float infinity hash` ]. - - self < Float maxExactInteger ifFalse: [ - "Will always enter here for 64 bits images. - See Float>>#hash, Integer>>#hash and LargeNegativeInteger>>#hash" - ^ self asFloat hash ]. - - "May only reach here in 32 bit images" - ^ByteArray - hashBytes: self - startingWith: self species hash! ! -!LargeNegativeInteger methodsFor: 'comparing' stamp: 'jmv 10/18/2018 09:48:53' prior: 50418066! - hash - - self > `(2 raisedToInteger: Float emax+1) negated` ifFalse: [ - ^ `Float negativeInfinity hash` ]. - - self > Float maxExactInteger negated ifFalse: [ - "Will always enter here for 64 bits images. - See Float>>#hash, Integer>>#hash and LargePositiveInteger>>#hash" - ^ self asFloat hash ]. - - "May only reach here in 32 bit images" - ^ByteArray - hashBytes: self - startingWith: self species hash! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3479-Float-Integer-hash-comments-JuanVuletich-2018Oct18-09h46m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3478] on 18 October 2018 at 9:59:15 am'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 10/18/2018 09:58:57' prior: 50412788! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('FJG' 'Facundo Javier Gelatti') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3480-AddFacundoAsKnownAuthor-JuanVuletich-2018Oct18-09h52m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3470] on 12 October 2018 at 12:23:20 pm'! -!Debugger methodsFor: 'method creation' stamp: 'FJG 10/8/2018 12:49:55'! - askForSuperclassOf: aClass upTo: aSuperclass toImplement: aSelector withCaption: aCaptionText ifCancel: cancelBlock - - | classes chosenClassIndex | - - classes _ aClass = aSuperclass ifTrue: [ { aClass } ] ifFalse: [ aClass withAllSuperclassesUpTo: aSuperclass ]. - chosenClassIndex _ PopUpMenu - withCaption: aCaptionText - chooseFrom: (classes collect: [:c | c name]). - chosenClassIndex = 0 ifTrue: [^ cancelBlock value]. - - ^ classes at: chosenClassIndex! ! -!Debugger methodsFor: 'method creation' stamp: 'FJG 10/8/2018 12:38:20'! - implement: aMessage inCategory: aCategory fromClass: aClass context: aContext - - aClass - compile: (aMessage createStubMethodFor: aClass) - classified: aCategory. - - aContext privRefreshWith: (aClass lookupSelector: aMessage selector). - aMessage arguments withIndexDo: [ :arg :index | aContext tempAt: index put: arg ]. - self resetContext: aContext! ! -!Debugger methodsFor: 'method creation' stamp: 'FJG 10/8/2018 12:50:42' prior: 50336677! - askForSuperclassOf: aClass upTo: aSuperclass toImplement: aSelector ifCancel: cancelBlock - - ^ self askForSuperclassOf: aClass upTo: aSuperclass toImplement: aSelector withCaption: 'Define #', aSelector, ' in which class?' ifCancel: cancelBlock! ! -!Debugger methodsFor: 'method creation' stamp: 'FJG 10/12/2018 12:22:13'! - createMethodWhenDoesNotUnderstand - - | message chosenClass interruptedContext | - - "The doesNotUndertand context must be selected - Hernan" - contextStackIndex = 1 ifFalse: [ self contextStackIndex: 1 oldContextWas: self selectedContext ]. - - interruptedContext _ self interruptedContext. - message _ interruptedContext tempAt: 1. - - chosenClass _ self - askForSuperclassOf: interruptedContext receiver class - toImplement: message selector - ifCancel: [^self]. - - self implement: message inClass: chosenClass context: self selectedContext - -! ! -!Debugger methodsFor: 'method creation' stamp: 'FJG 10/12/2018 12:22:26' prior: 50336764! - createMethod - - self wasInterrupedOnDoesNotUnderstand ifTrue: [ ^self createMethodWhenDoesNotUnderstand ]. - self wasInterruptedOnSubclassResponsibility ifTrue: [ ^self createMethodOnSubclassResponsibility ]. - self wasInterruptedOnOverridableMethod ifTrue: [ ^self overrideMethodOnSubclass ]. - - self inform: 'Only available to override methods or for #doesNotUnderstand: and #subclassResponsibility' ! ! -!Debugger methodsFor: 'method creation' stamp: 'FJG 10/8/2018 12:37:52' prior: 50368129! - implement: aMessage inClass: aClass context: aContext - - self implement: aMessage inCategory: (self askForCategoryIn: aClass default: 'as yet unclassified') fromClass: aClass context: aContext! ! -!Debugger methodsFor: 'method creation' stamp: 'FJG 10/8/2018 13:20:36'! - overrideMethodOnSubclass - - | chosenClass lastPossibleClass message methodCategory methodClass receiverClass | - - methodCategory _ self interruptedContext method category. - methodClass _ self interruptedContext method methodClass. - receiverClass _ self interruptedContext receiver class. - lastPossibleClass _ (receiverClass withAllSuperclassesPreviousTo: methodClass) last. - message _ self interruptedContext messageForYourself. - - chosenClass _ self - askForSuperclassOf: receiverClass - upTo: lastPossibleClass - toImplement: message selector - withCaption: 'Override #', message selector, ' in which class?' - ifCancel: [^self]. - - ^ self implement: message inCategory: methodCategory fromClass: chosenClass context: self interruptedContext! ! -!Debugger methodsFor: 'method creation' stamp: 'FJG 10/8/2018 13:20:43'! - wasInterruptedOnOverridableMethod - | methodClass receiverClass | - - methodClass _ self interruptedContext method methodClass. - receiverClass _ self interruptedContext receiver class. - - ^ methodClass ~= receiverClass! ! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'FJG 10/8/2018 13:21:29'! - allSuperclassesPreviousTo: aSuperclass - - | superclasses | - - superclasses _ self allSuperclassesUpTo: aSuperclass. - - ^ superclasses allButLast! ! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'FJG 10/8/2018 13:21:39'! - withAllSuperclassesPreviousTo: aSuperclass - - | classes | - - classes _ self withAllSuperclassesUpTo: aSuperclass. - - ^ classes allButLast! ! - -Debugger removeSelector: #createMethodWhenDoesNotUndertand! - -Debugger removeSelector: #createMethodWhenDoesNotUndertand! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3481-OverrideMethodsOnDebugger-FJG.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3481] on 18 October 2018 at 10:40:55 am'! -!Theme class methodsFor: 'consistency verification' stamp: 'HAW 10/10/2018 16:57:50'! - verifyShoutConfig - - " - self verifyShoutConfig - " - ^self allSubclasses - inject: OrderedCollection new into: [ :errors :themeClass | - [ themeClass new generateShoutConfig ] on: Error do: [:anError | | atIfAbsentContext key | - "I have to do this because error is not resumable - Hernan" - atIfAbsentContext := thisContext. - 10 timesRepeat: [ atIfAbsentContext := atIfAbsentContext sender ]. - key := atIfAbsentContext tempAt: 1. - errors add: themeClass -> key. - atIfAbsentContext receiver at: key put: Color black. - atIfAbsentContext restart ]. - errors ]! ! -!Theme methodsFor: 'shout' stamp: 'jmv 10/18/2018 10:39:38' prior: 50401994! - shout - "Color symbols as an association list. - SHTextStylerST80 initialize - " - - ^ { - #defaults -> #black. - #undefined -> #red. - #comment -> #(green muchDarker). - #methodTags -> #(green muchDarker). - #pseudoVariables -> #(red muchDarker). - #literals -> #(green muchDarker). - #messages -> #(blue darker). - #arguments -> #(cyan muchDarker). - #instVar -> #(magenta muchDarker). - #incompleteMessages -> #(gray veryMuchDarker). - #blockLevelZero -> #black. - #blockLevelOne -> #brown. - #blockLevelTwo -> #magenta. - #blockLevelThree -> #red. - #blockLevelFour -> #(orange darker). - #blockLevelFive -> #(orange muchDarker). - #blockLevelSix -> #(green muchDarker). - #blockLevelSeven -> #blue. - #tempBar -> #gray. - #tempVars -> #(gray muchDarker). - }! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3482-VerifyShoutConfig-HernanWilkinson-2018Oct18-10h28m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3482] on 18 October 2018 at 11:06:39 am'! -!Float methodsFor: 'mathematical functions' stamp: 'RNG 10/12/2018 05:43:21' prior: 16844725! - sign: aNumber - "Return a Number with the same sign as aNumber and same magnitude as self. - Implementation is different from super to handle the special case of Float negativeZero." - - (self isZero and: [aNumber sign negative]) ifTrue: [^Float negativeZero]. - ^aNumber copySignTo: self! ! -!Float methodsFor: 'converting' stamp: 'jmv 10/18/2018 10:56:50' prior: 16844793! - asIEEE32BitWord - "Convert the receiver into a 32 bit Integer value representing the same number in IEEE 32 bit format. - Used for conversion in FloatArrays only." - - | word1 word2 sign mantissa exponent destWord truncatedBits mask roundToUpper | - - "quickly skip positive and negative zero" - self isZero ifTrue: [^self basicAt: 1]. - - "retrieve 64 bits of IEEE 754 double" - word1 := self basicAt: 1. - word2 := self basicAt: 2. - - "prepare sign exponent and mantissa of 32 bits float" - sign := word1 bitAnd: 16r80000000. - exponent := ((word1 bitShift: -20) bitAnd: 16r7FF) - 1023 + 127. - mantissa := (word2 bitShift: -29) + ((word1 bitAnd: 16rFFFFF) bitShift: 3). - truncatedBits := (word2 bitAnd: 16r1FFFFFFF). - - "We must now honour default IEEE rounding mode (round to nearest even)" - - "we are below gradual underflow, even if rounded to upper mantissa" - exponent < -24 ifTrue: [^sign "this can be negative zero"]. - - "BEWARE: rounding occurs on less than 23bits when gradual underflow" - exponent <= 0 - ifTrue: - [mask := 1 bitShift: exponent negated. - mantissa := mantissa bitOr: 16r800000. - roundToUpper := (mantissa bitAnd: mask) isZero not - and: [truncatedBits isZero not - or: [(mantissa bitAnd: mask - 1) isZero not - or: [(mantissa bitAnd: mask*2) isZero not]]]. - mantissa := mantissa bitShift: exponent - 1. - "exponent := exponent + 1"] - ifFalse: - [roundToUpper := (truncatedBits bitAnd: 16r10000000) isZero not - and: [(mantissa bitAnd: 16r1) isZero not - or: [(truncatedBits bitAnd: 16r0FFFFFFF) isZero not]] - ]. - - "adjust mantissa and exponent due to IEEE rounding mode" - roundToUpper - ifTrue: - [mantissa := mantissa + 1. - mantissa > 16r7FFFFF - ifTrue: - [mantissa := 0. - exponent := exponent+1]]. - - exponent > 254 ifTrue: ["Overflow" - exponent := 255. - self isNaN - ifTrue: [mantissa isZero - ifTrue: ["BEWARE: do not convert a NaN to infinity due to truncatedBits" - mantissa := 1]] - ifFalse: [mantissa := 0]]. - - "Encode the word" - destWord := (sign bitOr: ((exponent max: 0) bitShift: 23)) bitOr: mantissa. - ^ destWord! ! -!Float methodsFor: 'converting' stamp: 'RNG 10/12/2018 05:44:04' prior: 16844974! - withNegativeSign - "Same as super, but handle the subtle case of Float negativeZero" - - self isZero ifTrue: [^self class negativeZero]. - ^super withNegativeSign! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 10/18/2018 10:59:41' prior: 16845001! - predecessor - | ulp | - self isFinite ifFalse: [ - (self isNaN or: [self negative]) ifTrue: [^self]. - ^Float fmax]. - ulp := self ulp. - ^self - (0.5 * ulp) = self - ifTrue: [self - ulp] - ifFalse: [self - (0.5 * ulp)]! ! -!Float methodsFor: 'truncation and round off' stamp: 'RNG 10/12/2018 05:43:53' prior: 16845059! - ulp - "Answer the unit of least precision of self (the power of two corresponding to last bit of mantissa)" - - | exponent | - self isFinite ifFalse: [^self abs]. - self isZero ifTrue: [^Float fmin]. - exponent := self exponent. - ^exponent < self class emin - ifTrue: [Float fminDenormalized] - ifFalse: [Float epsilon timesTwoPower: exponent]! ! -!Float methodsFor: 'testing' stamp: 'RNG 10/12/2018 05:46:10' prior: 16845075! - isFinite - "simple, byte-order independent test for rejecting Not-a-Number and (Negative)Infinity" - - ^(self - self) isZero! ! -!Float methodsFor: 'printing' stamp: 'RNG 10/12/2018 05:43:01' prior: 50405012! - printAsIEEE32BitPrecisionFloatOn: aStream base: base - "Handle sign, zero, and NaNs; all other values passed to absPrintOn:base:mantissaSignificantBits: - Print as a 32 bit Float" - - self isNaN ifTrue: [aStream nextPutAll: 'NaN'. ^ self]. "check for NaN before sign" - self > 0.0 - ifTrue: [self absPrintOn: aStream base: base mantissaSignificantBits: 24] - ifFalse: - [self sign = -1 - ifTrue: [aStream nextPutAll: '-']. - self isZero - ifTrue: [aStream nextPutAll: '0.0'. ^ self] - ifFalse: [self negated absPrintOn: aStream base: base mantissaSignificantBits: 24]]! ! -!Float methodsFor: 'printing' stamp: 'RNG 10/12/2018 05:43:12' prior: 16845527! - printOn: aStream base: base - "Handle sign, zero, and NaNs; all other values passed to absPrintOn:base:" - - self isNaN ifTrue: [aStream nextPutAll: 'NaN'. ^ self]. "check for NaN before sign" - self > 0.0 - ifTrue: [self absPrintOn: aStream base: base] - ifFalse: - [self sign = -1 - ifTrue: [aStream nextPutAll: '-']. - self isZero - ifTrue: [aStream nextPutAll: '0.0'. ^ self] - ifFalse: [self negated absPrintOn: aStream base: base]]! ! -!Float methodsFor: 'printing' stamp: 'RNG 10/12/2018 05:43:39' prior: 16845574! - storeOn: aStream base: base - "Print the Number exactly so it can be interpreted back unchanged" - self isFinite - ifTrue: [self sign = -1 ifTrue: [aStream nextPutAll: '-']. - base = 10 ifFalse: [aStream print: base; nextPut: $r]. - self isZero - ifTrue: [aStream nextPutAll: '0.0'] - ifFalse: [self abs absPrintExactlyOn: aStream base: base]] - ifFalse: [self isNaN - ifTrue: [aStream nextPutAll: 'Float nan'] - ifFalse: [self > 0.0 - ifTrue: [aStream nextPutAll: 'Float infinity'] - ifFalse: [aStream nextPutAll: 'Float infinity negated']]]! ! -!Color methodsFor: 'access' stamp: 'RNG 10/12/2018 05:45:04' prior: 50353261! - hue - "Return the hue of this color, an angle in the range [0.0..360.0]. - Color orange hue - " - - | r g b max min span h | - r _ self red. - g _ self green. - b _ self blue. - max _ (r max: g) max: b. - min _ (r min: g) min: b. - span _ (max - min) asFloat. - span isZero ifTrue: [ ^ 0.0 ]. - - r = max ifTrue: [ - h _ ((g - b) asFloat / span) * 60.0. - ] ifFalse: [ - g = max - ifTrue: [ h _ 120.0 + (((b - r) asFloat / span) * 60.0). ] - ifFalse: [ h _ 240.0 + (((r - g) asFloat / span) * 60.0). ]. - ]. - - ^h mod: 360.0! ! -!Color methodsFor: 'access' stamp: 'RNG 10/12/2018 05:45:46' prior: 50353307! - saturation - "Return the saturation of this color, a value between 0.0 and 1.0. - Color red saturation - Color gray saturation - " - - | r g b max min | - r _ self red. - g _ self green. - b _ self blue. - max _ (r max: g) max: b. - min _ (r min: g) min: b. - max isZero ifTrue: [ ^0.0 ]. - ^max - min / max! ! -!Color class methodsFor: 'class initialization' stamp: 'RNG 10/12/2018 05:45:57' prior: 50354672! - initializeGrayToIndexMap - "Build an array of gray values available in the 8-bit colormap. This array is indexed by a gray level between black (1) and white (256) and returns the pixel value for the corresponding gray level." - "Note: This method must be called after initializeIndexedColors, since it uses IndexedColors." - " - Color initializeGrayToIndexMap - " - - | grayLevels grayIndices c distToClosest dist indexOfClosest indexedColors | - "record the level and index of each gray in the 8-bit color table" - grayLevels _ OrderedCollection new. - grayIndices _ OrderedCollection new. - indexedColors _ self indexedColors. - "Note: skip the first entry, which is reserved for transparent" - 2 to: indexedColors size do: [:i | - c _ indexedColors at: i. - c saturation isZero ifTrue: [ "c is a gray" - grayLevels add: (c green * 255) rounded. "0 to 255; R, G, and B are the same" - grayIndices add: i - 1]]. "pixel values are zero-based" - grayLevels _ grayLevels asArray. - grayIndices _ grayIndices asArray. - - "for each gray level in [0..255], select the closest match" - GrayToIndexMap _ ByteArray new: 256. - 0 to: 255 do: [ :level | - distToClosest _ 10000. "greater than distance to any real gray" - 1 to: grayLevels size do: [:i | - dist _ (level - (grayLevels at: i)) abs. - dist < distToClosest ifTrue: [ - distToClosest _ dist. - indexOfClosest _ grayIndices at: i]]. - GrayToIndexMap at: (level + 1) put: indexOfClosest]! ! -!TranslucentColor methodsFor: 'queries' stamp: 'RNG 10/12/2018 05:46:53' prior: 50356606! - isTransparent - ^ self alpha isZero! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3483-Use-isZero-NahuelGarbezza-2018Oct18-10h56m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3461] on 15 October 2018 at 10:06:14 pm'! -!Behavior methodsFor: 'as yet unclassified' stamp: 'HAW 10/15/2018 20:57:14'! - addMethodsTo: methodsReferencingLiteral thatReferenceTo: aLiteral special: specialFlag byte: specialByte - - | selectors | - - selectors _ self whichSelectorsReferTo: aLiteral special: specialFlag byte: specialByte. - selectors do: [ :sel | methodsReferencingLiteral add: (MethodReference class: self selector: sel) ]! ! -!Behavior methodsFor: 'as yet unclassified' stamp: 'HAW 10/15/2018 20:57:14'! - addTo: aSet methodsThatReferenceInHierarchyTo: aSymbol special: special byte: byte. - - self withAllSuperAndSubclassesDoGently: [ :class | - class addMethodsTo: aSet thatReferenceTo: aSymbol special: special byte: byte ] - ! ! -!Behavior methodsFor: 'as yet unclassified' stamp: 'HAW 10/15/2018 20:59:04'! - rejectSelectorsFrom: selectors thatReferenceTo: aLiteral byte: specialByte - - "For special selectors, look for the literal in the source code. - Otherwise, for example, searching for senders of #== will include senders of #ifNil. - Except for #at:put:, because it has two arguments and won't find it in the source code like that." - - ^ (specialByte isNil or: [ aLiteral = #at:put: ]) - ifTrue: [ selectors ] - ifFalse: [ selectors select: [ :sel | ((self sourceCodeAt: sel) findString: aLiteral) > 0]]! ! -!Behavior methodsFor: 'testing method dictionary' stamp: 'HAW 10/15/2018 21:56:17' prior: 16784461! - whichSelectorsReferTo: literal special: specialFlag byte: specialByte - "Answer a set of selectors whose methods access the argument as a literal." - - | who | - - Preferences thoroughSenders - ifTrue: [ who _ self thoroughWhichSelectorsReferTo: literal special: specialFlag byte: specialByte ] - ifFalse: [ - who _ Set new. - self selectorsAndMethodsDo: [:sel :method | - ((method hasLiteral: literal) or: [specialFlag and: [method scanFor: specialByte]]) ifTrue: [ - ((literal isVariableBinding) not or: [method sendsToSuper not - "N.B. (method indexOfLiteral: literal) < method numLiterals copes with looking for - Float bindingOf: #NaN, since (Float bindingOf: #NaN) ~= (Float bindingOf: #NaN)." - or: [(method indexOfLiteral: literal) ~= 0]]) ifTrue: [who add: sel]]]]. - - ^self rejectSelectorsFrom: who thatReferenceTo: literal byte: specialByte ! ! -!Behavior methodsFor: 'user interface' stamp: 'HAW 10/15/2018 20:58:17' prior: 50343715! -allLocalCallsOn: aSymbol - "Answer a SortedCollection of all the methods that call on aSymbol, anywhere in my class hierarchy." - - | aSet special byte cls | - - aSet _ Set new. - cls _ self theNonMetaClass. - special _ Smalltalk hasSpecialSelector: aSymbol ifTrueSetByte: [ :b | byte _ b ]. - - cls addTo: aSet methodsThatReferenceInHierarchyTo: aSymbol special: special byte: byte. - cls class addTo: aSet methodsThatReferenceInHierarchyTo: aSymbol special: special byte: byte. - - ^aSet! ! -!SystemDictionary methodsFor: 'retrieving' stamp: 'HAW 10/15/2018 20:57:14' prior: 50332942! - allCallsOn: aLiteral "Smalltalk browseAllCallsOn: #open:label:." - "Answer a Collection of all the methods that call on aLiteral." - | aCollection special byte | - - #(23 48 'fred' (new open:label:)) size. - "Example above should find #open:label:, though it is deeply embedded here." - - aCollection _ OrderedCollection new. - special _ self hasSpecialSelector: aLiteral ifTrueSetByte: [:b | byte _ b ]. - self allBehaviorsDo: [:class | class addMethodsTo: aCollection thatReferenceTo: aLiteral special: special byte: byte ]. - - ^ aCollection! ! -!SystemDictionary methodsFor: 'retrieving' stamp: 'HAW 10/15/2018 21:07:56' prior: 16922089! - numberOfSendersOf: aSymbol - "Answer the count of all the methods that call on aLiteral. - [ (Smalltalk numberOfSendersOf: #open:label:) ] timeToRun - [ (Smalltalk numberOfSendersOf: #==) ] timeToRun - " - | count specialFlag specialByte | - - count _ 0. - specialFlag _ self hasSpecialSelector: aSymbol ifTrueSetByte: [ :b | specialByte _ b ]. - self allBehaviorsDo: [ :class | - class selectorsAndMethodsDo: [ :sel :method | - ((method hasLiteral: aSymbol) or: [specialFlag and: [(method scanFor: specialByte) and: [ ((class sourceCodeAt: sel) findString: aSymbol) > 0 ]]]) - ifTrue: [ count _ count + 1 ]]]. - ^ count! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'HAW 10/15/2018 20:57:14' prior: 16924287! - browseViewReferencesFromNonViews - " - Smalltalk browseViewReferencesFromNonViews - " - | aLiteral aCollection | - - aCollection _ OrderedCollection new. - - "Tweak to look just for pluggables or also for menus (or maybe for all morphs)" -" PopUpMenu withAllSubclasses , MenuMorph withAllSubclasses , PluggableMorph withAllSubclasses do: [ :view |" - PluggableMorph withAllSubclassesDo: [ :view | -" MenuMorph withAllSubclassesDo: [ :view |" - - aLiteral _ view name. - - "tweak to linclude refs to SysWindow subhierarchy or not" - (view includesBehavior: SystemWindow) & false ifFalse: [ - Smalltalk allBehaviorsDo: [ :class | - ((class includesBehavior: Morph) or: [ class includesBehavior: Morph class ]) ifFalse: [ - class addMethodsTo: aCollection thatReferenceTo: aLiteral special: false byte: nil ]]]]. - - Smalltalk - browseMessageList: aCollection asSet asArray sort - name: 'References to Views from non-Views' - autoSelect: ''.! ! - -Behavior removeSelector: #addMethodsTo:thatReferTo:special:byte:! - -Behavior removeSelector: #addTo:referencesInHierarchyTo:special:byte:! - -Behavior removeSelector: #addTo:referencesTo:special:byte:! - -Behavior removeSelector: #addTo:referencesTo:special:byte:! - -Behavior removeSelector: #rejectSelectorsFrom:thatReferTo:byte:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3484-Fix-whichSelectorsReferTo-HernanWilkinson-2018Oct02-16h57m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3484] on 22 October 2018 at 2:36:01 pm'! -!MorphicTranslation methodsFor: 'transforming rects' stamp: 'jmv 10/22/2018 14:32:45' prior: 16878595! - displayBoundsOfTransformOf: aRectangle - "Externalize aRectangle, and find a bounding rectangle with horizontal - and vertical bounds and integer coordinates (i.e. adisplayBounds)." - - ^(aRectangle translatedBy: self translation) rounded! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3485-displayBounds-fix-JuanVuletich-2018Oct22-14h35m-jmv.1.cs.st----! - -----SNAPSHOT----#(22 October 2018 2:45:12.031695 pm) Cuis5.0-3485-32.image priorSource: 2748905! - -----QUIT----#(22 October 2018 2:45:32.240509 pm) Cuis5.0-3485-32.image priorSource: 2797686! - -----STARTUP----#(30 November 2018 9:33:11.194093 am) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3485-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3485] on 5 November 2018 at 1:32:47 pm'! -!CodeProvider methodsFor: 'annotation' stamp: 'jmv 11/5/2018 13:32:18' prior: 16811768! -annotationForSelector: aSelector ofClass: aClass - "Provide a line of content for an annotation pane, representing - information about the given selector and class" - | stamp sendersCount implementorsCount aCategory separator aString aList aComment stream requestList | - aSelector == #Comment - ifTrue: [^ self annotationForClassCommentFor: aClass]. - aSelector == #Definition - ifTrue: [^ self annotationForClassDefinitionFor: aClass]. - aSelector == #Hierarchy - ifTrue: [^ self annotationForHierarchyFor: aClass]. - stream _ WriteStream on: String new. - requestList _ self annotationRequests. - separator _ requestList size > 1 - ifTrue: [self annotationSeparator] - ifFalse: ['']. - requestList - do: [:aRequest | - aRequest == #firstComment - ifTrue: [ - aComment _ aClass firstCommentAt: aSelector. - aComment isEmptyOrNil - ifFalse: [stream nextPutAll: aComment , separator]]. - aRequest == #masterComment - ifTrue: [ - aComment _ aClass supermostPrecodeCommentFor: aSelector. - aComment isEmptyOrNil - ifFalse: [stream nextPutAll: aComment , separator]]. - aRequest == #documentation - ifTrue: [ - aComment _ aClass precodeCommentOrInheritedCommentFor: aSelector. - aComment isEmptyOrNil - ifFalse: [stream nextPutAll: aComment , separator]]. - aRequest == #timeStamp - ifTrue: [ - stamp _ self timeStamp. - stream - nextPutAll: (stamp size > 0 - ifTrue: [stamp , separator] - ifFalse: ['no timeStamp' , separator])]. - aRequest == #messageCategory - ifTrue: [ - aCategory _ aClass organization categoryOfElement: aSelector. - aCategory - ifNotNil: ["woud be nil for a method no longer present, - e.g. in a recent-submissions browser" - stream nextPutAll: aCategory , separator]]. - aRequest == #sendersCount - ifTrue: [ - sendersCount _ Smalltalk numberOfSendersOf: aSelector. - sendersCount _ sendersCount = 1 - ifTrue: ['1 sender'] - ifFalse: [sendersCount printString , ' senders']. - stream nextPutAll: sendersCount , separator]. - aRequest == #implementorsCount - ifTrue: [ - implementorsCount _ Smalltalk numberOfImplementorsOf: aSelector. - implementorsCount _ implementorsCount = 1 - ifTrue: ['1 implementor'] - ifFalse: [implementorsCount printString , ' implementors']. - stream nextPutAll: implementorsCount , separator]. - aRequest == #priorVersionsCount - ifTrue: [ - self - addPriorVersionsCountForSelector: aSelector - ofClass: aClass - to: stream]. - aRequest == #priorTimeStamp - ifTrue: [ - stamp _ VersionsBrowser - timeStampFor: aSelector - class: aClass - reverseOrdinal: 2. - stamp - ifNotNil: [stream nextPutAll: 'prior time stamp: ' , stamp , separator]]. - aRequest == #packages - ifTrue: [ - (aClass compiledMethodAt: aSelector ifAbsent: nil) ifNotNil: [ :cm | - (CodePackage packageOfMethod: cm methodReference ifNone: nil) - ifNil: [ stream nextPutAll: 'part of base system (i.e. not in a package)' ] - ifNotNil: [ :codePackage | - stream nextPutAll: 'in package '; nextPutAll: codePackage packageName ]. - stream nextPutAll: separator]]. - aRequest == #changeSets - ifTrue: [ - aList _ ChangeSet allChangeSetsWithClass: aClass selector: aSelector. - aList size > 0 - ifTrue: [aList size = 1 - ifTrue: [stream nextPutAll: 'only in change set '] - ifFalse: [stream nextPutAll: 'in change sets:']. - aList - do: [:aChangeSet | stream nextPut: Character space; nextPutAll: aChangeSet name ] - separatedBy: [ stream nextPut: $, ]] - ifFalse: [stream nextPutAll: 'in no change set']. - stream nextPutAll: separator]. - aRequest == #allChangeSets - ifTrue: [ - aList _ ChangeSet allChangeSetsWithClass: aClass selector: aSelector. - aList size > 0 - ifTrue: [aList size = 1 - ifTrue: [stream nextPutAll: 'only in change set '] - ifFalse: [stream nextPutAll: 'in change sets:']. - aList - do: [:aChangeSet | stream nextPut: Character space; nextPutAll: aChangeSet name ] - separatedBy: [ stream nextPut: $, ]] - ifFalse: [stream nextPutAll: 'in no change set']. - stream nextPutAll: separator]. - aRequest == #allBaseSystemChangeSets - ifTrue: [ - aList _ (ChangeSet allChangeSetsWithClass: aClass selector: aSelector) select: [ :it | it isForBaseSystem ]. - aList size > 0 - ifTrue: [ - aList size = 1 - ifTrue: [stream nextPutAll: 'only in base system change set'] - ifFalse: [stream nextPutAll: 'in base system change sets:']. - aList - do: [:aChangeSet | stream nextPut: Character space; nextPutAll: aChangeSet name ] - separatedBy: [ stream nextPut: $, ]] - ifFalse: [stream nextPutAll: 'in no base system change set']. - stream nextPutAll: separator]. - aRequest == #closuresInfo - ifTrue: [ - aString _ aClass closuresInfoAt: aSelector. - aString size > 0 - ifTrue: [stream nextPutAll: aString , separator]]. - ]. - ^ stream contents! ! -!Preferences class methodsFor: 'parameters' stamp: 'jmv 11/5/2018 13:23:10' prior: 16893375! - setDefaultAnnotationInfo - " - Preferences setDefaultAnnotationInfo - " - ^ self parameters at: #MethodAnnotations put: #(timeStamp messageCategory implementorsCount sendersCount packages changeSets)! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - -Preferences setDefaultAnnotationInfo! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3486-MethodAnnotationsEnhancements-JuanVuletich-2018Nov05-13h21m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3487] on 17 November 2018 at 11:46:04 am'! -!Collection methodsFor: 'private' stamp: 'HAW 11/17/2018 11:40:56'! - emptyCollectionDescription - - ^self class emptyCollectionDescription ! ! -!Collection class methodsFor: 'error descriptions' stamp: 'HAW 11/17/2018 11:41:14'! - emptyCollectionDescription - - ^'this collection is empty'! ! -!Collection methodsFor: 'private' stamp: 'HAW 11/17/2018 11:39:51' prior: 16814643! - errorEmptyCollection - - self error: self emptyCollectionDescription! ! -!Collection methodsFor: 'statistics' stamp: 'HAW 11/17/2018 11:34:23' prior: 50414785! - average: aBlock - - ^ self average: aBlock ifEmpty: [ self errorEmptyCollection ]! ! -!Collection methodsFor: 'statistics' stamp: 'HAW 11/17/2018 11:38:13'! - average: aBlock ifEmpty: emptyBlock - - ^ (self sum: aBlock ifEmpty: [ ^emptyBlock value ]) / self size! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3487-Average-ifEmpty-HernanWilkinson-2018Nov17-11h28m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3490] on 17 November 2018 at 1:28:17 pm'! -!Collection methodsFor: 'private' stamp: 'GC 11/17/2018 13:12:25'! - errorCollectionTooSmall - - self error: self class collectionTooSmallDescription! ! -!Collection class methodsFor: 'error descriptions' stamp: 'GC 11/17/2018 13:12:24'! - collectionTooSmallDescription - - ^ 'this collection is too small'! ! -!Collection class methodsFor: 'error descriptions' stamp: 'GC 11/17/2018 13:23:46'! - notKeyedDescription - - ^ 'Instances of {1} do not respond to keyed accessing messages.' format: { self className }! ! -!Collection class methodsFor: 'error descriptions' stamp: 'GC 11/17/2018 13:18:00'! - objectNotFoundDescription - - ^ 'Object is not in the collection'! ! -!Collection class methodsFor: 'error descriptions' stamp: 'GC 11/17/2018 13:17:06'! - sizesDoNotMatchDescription - - ^ 'collection sizes do not match'! ! -!Collection methodsFor: 'private' stamp: 'GC 11/17/2018 13:15:10' prior: 50419288! - errorEmptyCollection - - self error: self class emptyCollectionDescription! ! -!Collection methodsFor: 'private' stamp: 'GC 11/17/2018 13:17:21' prior: 16814647! - errorNoMatch - - self error: self class sizesDoNotMatchDescription! ! -!Collection methodsFor: 'private' stamp: 'GC 11/17/2018 13:18:15' prior: 16814651! - errorNotFound: anObject - "Actually, this should raise a special Exception not just an error." - - self error: self class objectNotFoundDescription! ! -!Collection methodsFor: 'private' stamp: 'GC 11/17/2018 13:23:53' prior: 16814658! - errorNotKeyed - - self error: self class notKeyedDescription -! ! -!Collection methodsFor: 'statistics' stamp: 'HAW 11/17/2018 11:34:23' prior: 50419293! - average: aBlock - - ^ self average: aBlock ifEmpty: [ self errorEmptyCollection ]! ! -!Collection methodsFor: 'statistics' stamp: 'HAW 11/17/2018 11:38:13' prior: 50419298! - average: aBlock ifEmpty: emptyBlock - - ^ (self sum: aBlock ifEmpty: [ ^emptyBlock value ]) / self size! ! -!Collection class methodsFor: 'error descriptions' stamp: 'GC 11/17/2018 13:13:11' prior: 50419283! - emptyCollectionDescription - - ^ 'this collection is empty'! ! -!SequenceableCollection methodsFor: 'accessing' stamp: 'GC 11/17/2018 13:12:01' prior: 16905895! - penultimate - "Answer the penultimate element of the receiver. - Raise an error if the collection is empty or has just one element." - - | size | - (size _ self size) < 2 ifTrue: [self errorCollectionTooSmall]. - ^ self at: size-1! ! - -Collection class removeSelector: #collectionToSmallDescription! - -Collection class removeSelector: #notKeyedDescription:! - -Collection removeSelector: #emptyCollectionDescription! - -Collection removeSelector: #emptyCollectionDescription! - -Collection removeSelector: #errorCollectionToSmall! - -Collection removeSelector: #errorCollectionToSmall! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3488-CollectionErrorsCleanup-GastonCaruso-2018Nov17-13h07m-GC.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3488] on 20 November 2018 at 12:19:12 pm'! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'jmv 11/20/2018 12:18:39' prior: 16798356! - fileOut - "File out the receiver, to a file whose name is a function of the - change-set name and either of the date & time or chosen to have a - unique numeric tag, depending on the preference - 'changeSetVersionNumbers'" - | slips nameToUse | - nameToUse _ self name. - nameToUse _ nameToUse copyReplaceAll: 'AuthorName' with: Utilities authorName asUnaccented asCamelCase. - nameToUse _ Preferences changeSetVersionNumbers - ifTrue: [ - DirectoryEntry currentDirectory - nextNameFor: nameToUse coda: '-', Utilities authorInitials - extension: 'cs.st' ] - ifFalse: [ (nameToUse , '.' , Utilities dateTimeSuffix , '.cs.st') asFileName ]. - - nameToUse asFileEntry writeStreamDo: [ :stream | - stream timeStamp. - self fileOutPreambleOn: stream. - self fileOutOn: stream. - self fileOutPostscriptOn: stream ]. - - self hasUnsavedChanges: false. - Preferences checkForSlips - ifFalse: [^ self]. - slips _ self checkForSlips. - (slips size > 0 - and: [(PopUpMenu withCaption: 'Methods in this fileOut have halts -or references to the Transcript -or other ''slips'' in them. -Would you like to browse them?' chooseFrom: 'Ignore\Browse slips') - = 2]) - ifTrue: [ Smalltalk browseMessageList: slips name: 'Possible slips in ' , name ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3489-fixChangeSetFilenamewhenAuthorUsesTilde-JuanVuletich-2018Nov20-12h18m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3485] on 11 November 2018 at 7:26:03 pm'! -!Parser methodsFor: 'public access' stamp: 'HAW 11/11/2018 19:31:01'! - parse: sourceStreamOrString class: behavior noPattern: aBoolean - - ^ self - parse: sourceStreamOrString readStream - class: behavior - noPattern: aBoolean - context: nil - notifying: nil - ifFail: [^nil]! ! -!Workspace methodsFor: 'accessing' stamp: 'HAW 11/11/2018 19:24:17'! - methodNodeOf: aSourceCode ifErrorsParsing: aParsingErrorBlock - - ^[ UndefinedObject methodNodeFor: aSourceCode noPattern: true ] on: Error do: aParsingErrorBlock -! ! -!CodeProvider methodsFor: 'contents' stamp: 'HAW 11/11/2018 19:21:24'! - methodNodeOf: aSourceCode ifErrorsParsing: aParsingErrorBlock - - ^[ self selectedClassOrMetaClass methodNodeFor: aSourceCode ] on: Error do: aParsingErrorBlock - ! ! -!Inspector methodsFor: 'contents' stamp: 'HAW 11/11/2018 19:21:12'! - methodNodeOf: aSourceCode ifErrorsParsing: aParsingErrorBlock - - ^[ self selectedClassOrMetaClass methodNodeFor: aSourceCode noPattern: true ] on: Error do: aParsingErrorBlock ! ! -!Behavior methodsFor: 'methods' stamp: 'HAW 11/11/2018 15:07:12'! - methodNodeFor: aSourceCode noPattern: aBoolean - - | parser methodNode | - - parser := self parserClass new - encoderClass: EncoderForV3PlusClosures; - yourself. - - methodNode := parser parse: aSourceCode class: self noPattern: aBoolean. - methodNode sourceText: aSourceCode. - - ^methodNode - ! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 11/11/2018 14:27:34'! - parseNodeIncluding: aPosition ifAbsent: aBlockClosure - - | smallestRangeSize nodeWithRangeAtPosition | - - smallestRangeSize := SmallInteger maxVal. - nodeWithRangeAtPosition := nil. - - sourceRanges associationsDo: [ :nodeAtRange | - self withRangesOf: nodeAtRange including: aPosition do: [ :aRange | | currentNodeRangeSize | - currentNodeRangeSize := aRange size. - currentNodeRangeSize < smallestRangeSize ifTrue: [ - smallestRangeSize := currentNodeRangeSize. - nodeWithRangeAtPosition := nodeAtRange key -> aRange ]]]. - - ^ nodeWithRangeAtPosition ifNil: aBlockClosure ifNotNil: [ nodeWithRangeAtPosition ] - ! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 11/11/2018 14:26:13'! - withRangesOf: nodeAtRange including: aPosition do: aBlock - - | currentNodeRange ranges | - - currentNodeRange := nodeAtRange value. - ranges := currentNodeRange isInterval ifTrue: [ Array with: currentNodeRange ] ifFalse: [ currentNodeRange ]. - - ranges do: [ :aRange | (aRange includes: aPosition) ifTrue: [ aBlock value: aRange ]]. - - ! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 11/11/2018 14:16:41'! - parseNodeIncluding: aPosition ifAbsent: aBlockClosure - - ^encoder parseNodeIncluding: aPosition ifAbsent: aBlockClosure -! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'HAW 11/11/2018 14:29:56'! - implementorsOfItWhenErrorsParsing - - "Open an implementors browser on the selected selector" - - | aSelector | - - self lineSelectAndEmptyCheck: [^ self]. - (aSelector _ self selectedSelector) ifNil: [^ morph flash]. - Smalltalk browseAllImplementorsOf: aSelector! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'HAW 11/11/2018 14:15:34'! - sendersOfItWhenErrorsParsing - - "Open a senders browser on the selected selector" - - | aSelector | - - self lineSelectAndEmptyCheck: [^ self]. - (aSelector _ self selectedSelector) ifNil: [^ morph flash]. - Smalltalk browseAllCallsOn: aSelector! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'HAW 11/11/2018 14:36:04'! - withSelectorUnderCursorDo: aBlock ifErrorsParsing: aParsingErrorBlock - - self withSelectorUnderCursorDo: aBlock ifErrorsParsing: aParsingErrorBlock ifNoSelector: [ morph flash ]! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'HAW 11/11/2018 15:30:45'! - withSelectorUnderCursorDo: aBlock ifErrorsParsing: aParsingErrorBlock ifNoSelector: aNoSelectorBlock - - | methodNode nodeAtRange nodeUnderCursor | - - methodNode := self codeProvider methodNodeOf: model actualContents ifErrorsParsing: [ :anError | ^ aParsingErrorBlock value: anError ]. - - self startIndex < methodNode selectorLastPosition ifTrue: [ ^aBlock value: methodNode selector ]. - nodeAtRange := methodNode parseNodeIncluding: self startIndex ifAbsent: [ ^ aNoSelectorBlock value ]. - nodeUnderCursor := nodeAtRange key. - nodeUnderCursor isMessageNode ifTrue: [ ^aBlock value: nodeAtRange key selector key ]. - (nodeUnderCursor isLiteralNode and: [ nodeUnderCursor literalValue isSymbol ]) ifTrue: [ ^aBlock value: nodeUnderCursor literalValue ]. - - ^ aNoSelectorBlock value ! ! -!Behavior methodsFor: 'methods' stamp: 'HAW 11/11/2018 15:07:41' prior: 50408647! - methodNodeFor: aSourceCode - - ^self methodNodeFor: aSourceCode noPattern: false! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 11/11/2018 15:21:21'! - selectorLastPosition - - "If #DoIt selector, returns 0 - Hernan" - - ^self selector isUnary - ifTrue: [ selectorKeywordsRanges ifNil: [ 0 ] ifNotNil: [ selectorKeywordsRanges last last ]] - ifFalse: [ (encoder sourceRangeFor: arguments last) first last ]! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'HAW 11/11/2018 14:32:52' prior: 16909904! - implementorsOfIt - - "Open an implementors browser on the selector under cursor. If it can not parse the source code it uses - old implementation that looks for the selected selector if any - Hernan" - - self - withSelectorUnderCursorDo: [ :aSelector | Smalltalk browseAllImplementorsOf: aSelector ] - ifErrorsParsing: [ :anError | self implementorsOfItWhenErrorsParsing ] - -! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'HAW 11/11/2018 15:13:54' prior: 16909977! - sendersOfIt - - "Open a senders browser on the selector under cursor. If it can not parse the source code it uses - old implementation that looks for the selected selector if any - Hernan" - - self - withSelectorUnderCursorDo: [ :aSelector | Smalltalk browseAllCallsOn: aSelector ] - ifErrorsParsing: [ :anError | self sendersOfItWhenErrorsParsing ] -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3490-SendersImplementorsEnhancements-HernanWilkinson-2018Nov11-14h14m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3490] on 20 November 2018 at 12:51:56 pm'! -!Message methodsFor: 'comparing' stamp: 'jmv 11/20/2018 12:51:32'! - = aMessage - - "Any object is equal to itself" - self == aMessage ifTrue: [ ^ true ]. - - self class == aMessage class ifFalse: [ ^false ]. - selector = aMessage selector ifFalse: [ ^false ]. - lookupClass = aMessage lookupClass ifFalse: [ ^false ]. - ^args = aMessage arguments! ! -!Message methodsFor: 'comparing' stamp: 'jmv 11/20/2018 12:47:30'! - hash - "Hash is reimplemented because = is implemented." - ^selector hash bitXor: args hash! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3491-MessageEqualAndHash-JuanVuletich-2018Nov20-12h46m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3485] on 26 October 2018 at 6:11:52 am'! - -"Change Set: 3486-CuisCore-AuthorName-2018Oct26-06h03m -Date: 26 October 2018 -Author: Nahuel Garbezza - -This adds some shortcuts to browser category list section"! -!CodeWindow methodsFor: 'keyboard shortcuts' stamp: 'RNG 10/26/2018 06:10:22' prior: 50338655! - systemCatListKey: aChar from: view - "Respond to a Command key. I am a model with a code pane, and I also have a listView that has a list of methods. The view knows how to get the list and selection." - - aChar == $f ifTrue: [ ^ self findClass ]. - aChar == $x ifTrue: [ ^ model removeSystemCategory ]. - aChar == $t ifTrue: [ ^ model runSystemCategoryTests ]. - aChar == $a ifTrue: [ ^ model addSystemCategory ]. - aChar == $A ifTrue: [ ^ model alphabetizeSystemCategories ]. - aChar == $b ifTrue: [ ^ self openSystemCategoryBrowser ]. - aChar == $B ifTrue: [ ^ self browseAllClasses ]. - aChar == $o ifTrue: [ ^ model fileOutSystemCategory ]. - aChar == $u ifTrue: [ ^ model updateSystemCategories ]. - - ^ self classListKey: aChar from: view! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'RNG 10/26/2018 06:10:09' prior: 50411779! - systemCategoryMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'find class... (f)'. - #selector -> #findClass. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'recent classes... (r)'. - #object -> #model. - #selector -> #recent. - #icon -> #clockIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'browse all (B)'. - #selector -> #browseAllClasses. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'browse (b)'. - #selector -> #openSystemCategoryBrowser. - #icon -> #packageIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'fileOut (o)'. - #object -> #model. - #selector -> #fileOutSystemCategory. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'reorganize'. - #object -> #model. - #selector -> #editSystemCategories. - #icon -> #sendReceiveIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'alphabetize (A)'. - #object -> #model. - #selector -> #alphabetizeSystemCategories. - #icon -> #fontXGenericIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'update (u)'. - #object -> #model. - #selector -> #updateSystemCategories. - #icon -> #updateIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 20. - #label -> 'add item... (a)'. - #object -> #model. - #selector -> #addSystemCategory. - #icon -> #newIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'rename...'. - #object -> #model. - #selector -> #renameSystemCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 40. - #label -> 'remove (x)'. - #object -> #model. - #selector -> #removeSystemCategory. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'move to top'. - #object -> #model. - #selector -> #moveSystemCategoryTop. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 20. - #label -> 'move up'. - #object -> #model. - #selector -> #moveSystemCategoryUp. - #icon -> #goUpIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 30. - #label -> 'move down'. - #object -> #model. - #selector -> #moveSystemCategoryDown. - #icon -> #goDownIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 40. - #label -> 'move to bottom'. - #object -> #model. - #selector -> #moveSystemCategoryBottom. - #icon -> #goBottomIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 10. - #label -> 'run tests (t)'. - #object -> #model. - #selector -> #runSystemCategoryTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - }`. - ! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3492-SystemCategoryMenuOptionsEnh-NahuelGarbezza-2018Oct26-06h03m-RNG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3492] on 20 November 2018 at 7:10:56 pm'! -!Message methodsFor: 'comparing' stamp: 'jmv 11/20/2018 19:10:34' prior: 50419654! - = aMessage - - "Any object is equal to itself" - self == aMessage ifTrue: [ ^ true ]. - - self class == aMessage class ifFalse: [ ^false ]. - selector = aMessage selector ifFalse: [ ^false ]. - lookupClass = aMessage lookupClass ifFalse: [ ^false ]. - ^args literalEqual: aMessage arguments! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3493-MessageEqualFix-JuanVuletich-2018Nov20-19h10m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3485] on 8 November 2018 at 6:23:20 pm'! -!BlockClosure methodsFor: 'scheduling' stamp: 'jmv 11/8/2018 18:23:08' prior: 16788299! - fork - "Create and schedule a Process running the code in the receiver." - - "jmv - Do NOT answer the new process. - - See http://lists.squeakfoundation.org/pipermail/squeak-dev/2008-February/124960.html - - Most times, these methods return before resuming the new process (if priority of new process is less - or equal than current). But they might return afterwards. - - This means it is very dangerous to use the returned process in code that stores it in some variable - and checks for nil to start a new one. If these methods happen to return after the new process is forked, - chances are the code that starts all this runs again, that variable is nil, and a second process is forked, - perhaps breaking some shared state. This kind of bug is hard to spot and debug. - - Callers wanting the new process object, should call #newProcess, store the answer, and then #resume. - - A way to ensure this bug will not ever happen again is just to answer nil" - - self newProcess resume. - ^nil! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3494-fork-commentEnh-JuanVuletich-2018Nov08-18h22m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3494] on 21 November 2018 at 5:40:44 pm'! -!Float methodsFor: 'comparing' stamp: 'jmv 11/21/2018 17:04:24' prior: 50418112! - hash - "Hash is reimplemented because = is implemented." - - | asInteger | - self isFinite ifTrue: [ - asInteger _ self truncated. - "See Integer>>#hash, LargePositiveInteger>>#hash and LargeNegativeInteger>>#hash" - "Very big integers will answer true when asked #= with their own conversion to Float, - But that Float will #asInteger to a different integer. Use Float hash in those cases, to ensure equal hash value. - In addition, there is a performance improvement: the hash in LargeIntegers could - get very slow for very big numbers" - (asInteger = self and: [ asInteger abs < Float maxExactInteger ]) ifTrue: [ - ^ asInteger hash ]]. - "Both words of the float are used. (The bitShift:'s ensure that the intermediate results do not become a large integer.) - Care is taken to answer same hash as an equal Integer." - ^ ((self basicAt: 1) bitShift: -4) + - ((self basicAt: 2) bitShift: -4)! ! -!LargePositiveInteger methodsFor: 'comparing' stamp: 'jmv 11/21/2018 17:32:14' prior: 50418157! - hash - - self < `(2 raisedToInteger: Float emax+1)` ifFalse: [ - ^ `Float infinity hash` ]. - - self < Float maxExactInteger ifFalse: [ - "Will always enter here for 64 bits images. - See Float>>#hash, Integer>>#hash and LargeNegativeInteger>>#hash" - ^ self asFloat hash ]. - - "May normally only reach here in 32 bit images" - - "If could be a SmallInteger (regardless of the current word size, we want consistency between 32/64 bit systems)" - self digitLength <= 8 ifTrue: [ - ^ self hashMultiply ]. - - ^ByteArray - hashBytes: self - startingWith: self species hash! ! -!LargeNegativeInteger methodsFor: 'comparing' stamp: 'jmv 11/21/2018 17:32:25' prior: 50418172! - hash - - self > `(2 raisedToInteger: Float emax+1) negated` ifFalse: [ - ^ `Float negativeInfinity hash` ]. - - self > Float maxExactInteger negated ifFalse: [ - "Will always enter here for 64 bits images. - See Float>>#hash, Integer>>#hash and LargePositiveInteger>>#hash" - ^ self asFloat hash ]. - - "May normally only reach here in 32 bit images" - - "If could be a SmallInteger (regardless of the current word size, we want consistency between 32/64 bit systems)" - self digitLength <= 8 ifTrue: [ - ^ self hashMultiply ]. - - ^ByteArray - hashBytes: self - startingWith: self species hash! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3495-SmallInteger-LargeInteger-hash-consistency-JuanVuletich-2018Nov21-16h56m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3495] on 27 November 2018 at 9:04:27 am'! - -"Change Set: 3497-CuisCore-AuthorName-2018Nov27-09h04m -Date: 27 November 2018 -Author: Juan Vuletich -" -(FeatureRequirement name: 'Statistics') isAlreadySatisfied ifTrue: [ self inform: 'You have the Statistics package already loaded in this image. Please reinstall it after loading this change set (#3496).' ]! - -SortedCollection removeSelector: #median! - -SortedCollection removeSelector: #median! - -Collection removeSelector: #median! - -Collection removeSelector: #median! - -Collection removeSelector: #sampleStandardDeviation! - -Collection removeSelector: #sampleStandardDeviation! - -Collection removeSelector: #sampleVariance! - -Collection removeSelector: #sampleVariance! - -Collection removeSelector: #standardDeviation! - -Collection removeSelector: #standardDeviation! - -Collection removeSelector: #variance! - -Collection removeSelector: #variance! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3496-CleanBaseImageOfPackageStuff-JuanVuletich-2018Nov27-08h55m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3496] on 27 November 2018 at 9:20:13 am'! -!Color class methodsFor: 'instance creation' stamp: 'jmv 11/26/2018 17:17:17' prior: 50354353! - colorFrom: parm - "Return an instantiated color from parm. If parm is already a color, return it, else return the result of my performing it if it's a symbol or, if it is a list, it can either be an array of three numbers, which will be interpreted as RGB values, or a list of symbols, the first of which is sent to me and then the others of which are in turn sent to the prior result, thus allowing entries of the form #(blue darker). Else just return the thing" - - | aColor firstParm | - (parm is: #Color) ifTrue: [ ^ parm ]. - parm isSymbol ifTrue: [ ^ self perform: parm ]. - parm isString ifTrue: [ ^ self fromHexString: parm ]. - (parm isSequenceableCollection and: [ parm size > 0 ]) - ifTrue: [ - firstParm _ parm first. - firstParm isNumber ifTrue: [ - ^ self fromRgbTriplet: parm]. - aColor _ self colorFrom: firstParm. - parm withIndexDo: [ :sym :ind | - ind > 1 ifTrue: [ - aColor _ aColor perform: sym ]]. - ^ aColor]. - ^ parm - -" -Color colorFrom: #(blue darker) -Color colorFrom: Color blue darker -Color colorFrom: #blue -Color colorFrom: #(0.0 0.0 1.0) -Color colorFrom: '#D7B360' -"! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3497-Color-fromFrom-hexString-JuanVuletich-2018Nov27-09h19m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3496] on 27 November 2018 at 9:21:11 am'! -!InnerTextMorph methodsFor: 'private' stamp: 'jmv 11/26/2018 18:20:34' prior: 50381279! - selectionChanged - - self textComposition selectionRects do: [ :r | self invalidateLocalRect: r ]. - editor hasSelection - ifTrue: [ self stopBlinking ] - ifFalse: [ self hasKeyboardFocus ifTrue: [self startBlinking ]]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3498-FixTextCursorBlinking-JuanVuletich-2018Nov27-09h20m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3496] on 27 November 2018 at 9:28:07 am'! -!CodeWindow methodsFor: 'updating' stamp: 'jmv 11/26/2018 18:36:46' prior: 50387987! - decorateForInheritance - "Check to see if the currently-viewed method has a super send or an override, and if so, change screen feedback, unless the #decorateBrowserButtons says not to." - - | cm aColor aButton flags buttonColor | - (aButton _ self inheritanceButton) ifNil: [^ self]. - buttonColor _ self buttonColor. - - Preferences decorateBrowserButtons - ifFalse: [ ^aButton color: buttonColor ]. - cm _ model currentCompiledMethod. - (cm is: #CompiledMethod) - ifFalse: [ ^aButton color: buttonColor ]. - - flags _ 0. - model isThisAnOverride ifTrue: [ flags _ flags bitOr: 4 ]. - cm sendsToSuper ifTrue: [ flags _ flags bitOr: 2 ]. - model isThereAnOverride ifTrue: [ flags _ flags bitOr: 1 ]. - aColor _ { - - "This is NOTan override. There is no super implementation." - buttonColor. "no sends to super. there is not override in any subclass" - `Color tan`. "no sends to super. there is an override in some subclass" - `Color red`. "sends to super. there is no override in any subclass. Error: no super to call (or calls super with a different message)" - `Color red`. "sends to super. there is an override in some subclass. Error: no super to call (or calls super with a different message)" - - "This is an override. There is some super implementation" - `Color red muchLighter`. "doesn't have sub; has super but doesn't call it" - `Color r: 0.94 g: 0.823 b: 0.673`. "has sub; has super but doesn't call it" - `Color green muchLighter`. "doesn't have sub; has super and callsl it" - `Color blue muchLighter`. "has sub; has super and callsl it" - - } at: flags + 1. - Theme current useUniformColors - ifTrue: [ - aButton color: (self buttonColor mixed: 0.8 with: aColor) ] - ifFalse: [ - aButton color: aColor ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3499-softInheritanceButtonColoring-JuanVuletich-2018Nov27-09h21m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3485] on 27 November 2018 at 9:33:43 am'! -!SmalltalkCompleter class methodsFor: 'class initialization' stamp: 'jmv 3/19/2012 08:41' prior: 16909395! - initialize - " - It takes about 6 seconds, mostly because of the time to fetch method stamps from source files... - [ SmalltalkCompleter initialize ]timeToRun - Selectors inspect - " - | maxSortValue allImplemented | - SystemChangeNotifier uniqueInstance - removeActionsWithReceiver: self. "avoid double registration" - - SystemChangeNotifier uniqueInstance - when: #classRemoved send: #classRemoved:fromCategory: to: self; - when: #methodAdded send: #methodAdded:selector:inClass:requestor: to: self; - when: #methodAddedInProtocol send: #methodAdded:selector:inProtocol:class:requestor: to: self; - when: #methodRemoved send: #methodRemoved:selector:inProtocol:class: to: self. - - self protected: [ - allImplemented _ Smalltalk allImplementedMessages. - Selectors _ Trie new. - " - Smalltalk allBehaviorsDo: [:class | - class selectorsAndMethodsDo: [ :sel :method | - Selectors at: sel ifAbsentPut: [ 0 ]. - method messages do: [ :sentMsg | - Selectors at: sentMsg put: (Selectors at: sentMsg ifAbsent: [ 0 ]) + 1 ]]]. - " - Smalltalk allBehaviorsDo: [:class | - class selectorsAndMethodsDo: [ :sel :method | - self addSelector: sel method: method allImplemented: allImplemented]]. - "" - - "The following might not be found in #messages. Give them maximum priority." - maxSortValue _ SmallInteger maxVal. - "From MessageNode>>#initialize" - #( ifTrue: ifFalse: ifTrue:ifFalse: ifFalse:ifTrue: - and: or: - whileFalse: whileTrue: whileFalse whileTrue - to:do: to:by:do: - caseOf: caseOf:otherwise: - ifNil: ifNotNil: ifNil:ifNotNil: ifNotNil:ifNil:) do: [ :sel | - Selectors at: sel put: maxSortValue ]. - - maxSortValue _ SmallInteger maxVal-1. - "From SystemDictionary >>#recreateSpecialObjectsArray" - (1 to: Smalltalk specialSelectorSize) do: [ :i | - Selectors at: (Smalltalk specialSelectorAt: i) put: maxSortValue ]]! ! - -SmalltalkCompleter initialize! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -SmalltalkCompleter initialize! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3500-Initialize-Smalltalk-Completer-JuanVuletich-2018Nov27-09h32m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3500] on 27 November 2018 at 10:16:21 am'! - -Theme subclass: #BrightTheme - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Theme-Core'! - -!classDefinition: #BrightTheme category: #'Theme-Core'! -Theme subclass: #BrightTheme - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Theme-Core'! -!BrightTheme commentStamp: '' prior: 0! - Default bright colored theme for Cuis.! -!Theme methodsFor: 'private - shout mappings' stamp: 'jmv 11/26/2018 18:00:55' prior: 50401914! - generateShoutConfig - - | styles colors | - styles := OrderedCollection new. - colors := self shout as: Dictionary. - - { - {self undefined. colors at: #undefined}. - {self defaults . colors at: #defaults}. - {self pseudoVariables . colors at: #pseudoVariables}. - {self literals . colors at: #literals}. - {self instVar . colors at: #instVar}. - {self messages . colors at: #messages}. - {self blockLevelZero . colors at: #blockLevelZero}. - {self blockLevelOne . colors at: #blockLevelOne}. - {self blockLevelTwo . colors at: #blockLevelTwo}. - {self blockLevelThree . colors at: #blockLevelThree}. - {self blockLevelFour . colors at: #blockLevelFour}. - {self blockLevelFive . colors at: #blockLevelFive}. - {self blockLevelSix . colors at: #blockLevelSix}. - {self blockLevelSeven . colors at: #blockLevelSeven}. - {self tempBar . colors at: #tempBar}. - {self methodTags . colors at: #methodTags . #bold}. - {self globals . colors at: #defaults . #bold}. - {self incompleteMessages . colors at: #incompleteMessages . #underlined}. - {self argumentTypes . colors at: #arguments . self italic}. - {self symbols . colors at: #messages . #bold}. - {self pattern . colors at: #selector . #bold}. - {self ansiAssignment . nil . #bold}. - {self assignment . nil . #(#bold #withST80Glyphs)}. - {self return . nil . #(#bold #withST80Glyphs)}. - {self tempVars . colors at: #tempVars . self italic}. - {self blockTemps . colors at: #tempBar . self italic} - } do: [ :style | - styles addAll: - (style first - collect: [ :category | | elements | - elements _ style asOrderedCollection. - elements at: 1 put: category. - Array withAll: elements ])]. - - "Miscellaneous remainder after factoring out commonality:" - styles addAll: { - {#unfinishedString . colors at: #undefined . #normal}. - {#undefinedIdentifier . colors at: #undefined .#bold}. - {#unfinishedComment . colors at: #pseudoVariables . self italic}. - {#comment . colors at: #comment . self italic}. - {#string . colors at: #instVar . #normal}. - {#literal . nil . self italic}. - {#incompleteIdentifier . colors at: #tempVars . {#italic. #underlined}}. - {#classVar . colors at: #tempVars . #bold}. - }. - - ^ styles! ! -!Theme methodsFor: 'shout' stamp: 'jmv 11/27/2018 09:59:21' prior: 50418571! - shout - "Color symbols as an association list. - SHTextStylerST80 initialize - " - ^ { - #selector -> nil. - #arguments -> #(cyan muchDarker). - #comment -> #(green muchDarker). - #tempBar -> #gray. - #tempVars -> #(gray muchDarker). - #instVar -> #(magenta muchDarker). - #pseudoVariables -> #(red muchDarker). - #literals -> #(green muchDarker). - #messages -> #(blue darker). - #incompleteMessages -> #(gray veryMuchDarker). - #blockLevelZero -> #black. - #blockLevelOne -> #brown. - #blockLevelTwo -> #magenta. - #blockLevelThree -> #red. - #blockLevelFour -> #(orange darker). - #blockLevelFive -> #(orange muchDarker). - #blockLevelSix -> #(green muchDarker). - #blockLevelSeven -> #blue. - #defaults -> #black. - #undefined -> #red. - #methodTags -> #(green muchDarker). - }! ! -!Theme class methodsFor: 'user interface' stamp: 'jmv 11/27/2018 10:14:54' prior: 50397986! - changeTheme - - | menu | - menu _ MenuMorph new. - menu - addTitle: 'Choose a theme'; - addStayUpIcons. - (Theme allSubclasses sorted: [ :a :b | a name < b name ]) do: [ :themeClass | - menu add: themeClass name target: themeClass action: #beCurrent ]. - menu popUpInWorld: self runningWorld! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -BrightTheme beCurrent.! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3501-BrightTheme-JuanVuletich-2018Nov27-09h49m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3501] on 27 November 2018 at 10:20:03 am'! -!Workspace methodsFor: 'accessing' stamp: 'jmv 11/27/2018 10:19:24' prior: 50419466! - methodNodeOf: aSourceCode ifErrorsParsing: aParsingErrorBlock - - ^[ UndefinedObject methodNodeFor: aSourceCode noPattern: true ] on: Error, UndeclaredVariableReference do: aParsingErrorBlock -! ! -!CodeProvider methodsFor: 'contents' stamp: 'jmv 11/27/2018 10:19:13' prior: 50419474! - methodNodeOf: aSourceCode ifErrorsParsing: aParsingErrorBlock - - ^[ self selectedClassOrMetaClass methodNodeFor: aSourceCode ] on: Error, UndeclaredVariableReference do: aParsingErrorBlock - ! ! -!Inspector methodsFor: 'contents' stamp: 'jmv 11/27/2018 10:19:17' prior: 50419482! - methodNodeOf: aSourceCode ifErrorsParsing: aParsingErrorBlock - - ^[ self selectedClassOrMetaClass methodNodeFor: aSourceCode noPattern: true ] on: Error, UndeclaredVariableReference do: aParsingErrorBlock ! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3502-FixSendersImplementorsEnhancements-JuanVuletich-2018Nov27-10h19m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3501] on 27 November 2018 at 10:24:18 am'! - -CodePackage subclass: #ColorExtrasPackage - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Color-Extras'! - -!classDefinition: #ColorExtrasPackage category: #'Color-Extras'! -CodePackage subclass: #ColorExtrasPackage - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Color-Extras'! -!SmallInteger methodsFor: 'bit manipulation' stamp: 'SqR 8/3/2000 13:29' prior: 16908824! - hashMultiply - "Multiply by 1664525, take lower 28 bits, do not use LargeIntegers (not even in 32 bit images)" - | low | - - low _ self bitAnd: 16383. - ^(16r260D * low + ((16r260D * (self bitShift: -14) + (16r0065 * low) bitAnd: 16383) * 16384)) - bitAnd: 16r0FFFFFFF! ! - -Smalltalk removeClassNamedIfInBaseSystem: #ColorExtrasPackage! - -Smalltalk removeClassNamed: #ColorExtrasPackage! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3503-hashMultiplyComment-JuanVuletich-2018Nov27-10h22m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3501] on 27 November 2018 at 1:42:06 pm'! - -Number subclass: #Float - instanceVariableNames: '' - classVariableNames: 'E Epsilon Halfpi Infinity Ln10 Ln2 MaxVal MaxValLn MinValLogBase2 NaN NegativeInfinity NegativeZero Pi RadiansPerDegree Sqrt2 Twopi ' - poolDictionaries: '' - category: 'Kernel-Numbers'! - -!classDefinition: #Float category: #'Kernel-Numbers'! -Number subclass: #Float - instanceVariableNames: '' - classVariableNames: 'E Epsilon Halfpi Infinity Ln10 Ln2 MaxVal MaxValLn MinValLogBase2 NaN NegativeInfinity NegativeZero Pi RadiansPerDegree Sqrt2 Twopi' - poolDictionaries: '' - category: 'Kernel-Numbers'! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 11/27/2018 13:10:52'! - arcTanNonPrimitive - "Answer the angle in radians." - - | theta delta sinTheta cosTheta | - - "Newton-Raphson" - self < 0.0 ifTrue: [ ^ 0.0 - (0.0 - self) arcTan ]. - - "first guess" - theta _ (self * Halfpi) / (self + 1.0). - - "iterate" - [ - sinTheta _ theta sin. - cosTheta _ theta cos. - delta _ (sinTheta * cosTheta) - (self * cosTheta * cosTheta). - delta abs >= theta ulp ] - whileTrue: [ - theta _ theta - delta ]. - ^ theta! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 11/27/2018 13:24:16'! - expNonPrimitive - "Answer E raised to the receiver power." - - | base fract correction delta div | - - "Taylor series" - "check the special cases" - self < 0.0 ifTrue: [^ (self negated exp) reciprocal]. - self = 0.0 ifTrue: [^ 1]. - self abs > MaxValLn ifTrue: [self error: 'exp overflow']. - - "get first approximation by raising e to integer power" - base _ E raisedToInteger: (self truncated). - - "now compute the correction with a short Taylor series" - "fract will be 0..1, so correction will be 1..E" - "in the worst case, convergance time is logarithmic with 1/Epsilon" - fract _ self fractionPart. - fract = 0.0 ifTrue: [ ^ base ]. "no correction required" - - correction _ 1.0 + fract. - delta _ fract * fract / 2.0. - div _ 2.0. - [delta >= base ulp] whileTrue: [ - correction _ correction + delta. - div _ div + 1.0. - delta _ delta * fract / div]. - correction _ correction + delta. - ^ base * correction! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 11/27/2018 13:32:39'! - lnNonPrimitive - "Answer the natural logarithm of the receiver. - Optional. See Object documentation whatIsAPrimitive." - - | expt n mant x div pow delta sum | - - "Taylor series" - self <= 0.0 ifTrue: [DomainError signal: 'ln is only defined for x > 0.0']. - - "get a rough estimate from binary exponent" - expt := self exponent. - n := Ln2 * expt. - mant := self timesTwoPower: 0 - expt. - - "compute fine correction from mantinssa in Taylor series" - "mant is in the range [0..2]" - "we unroll the loop to avoid use of abs" - x := mant - 1.0. - div := 1.0. - pow := delta := sum := x. - x := x negated. "x <= 0" - [delta > (n + sum) ulp] whileTrue: [ - "pass one: delta is positive" - div := div + 1.0. - pow := pow * x. - delta := pow / div. - sum := sum + delta. - "pass two: delta is negative" - div := div + 1.0. - pow := pow * x. - delta := pow / div. - sum := sum + delta]. - - ^ n + sum - - "Float e ln 1.0"! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 11/27/2018 13:40:01'! - sinNonPrimitive - "Answer the sine of the receiver taken as an angle in radians." - - | sum delta self2 i | - - "Taylor series" - "normalize to the range [0..Pi/2]" - self < 0.0 ifTrue: [^ (0.0 - ((0.0 - self) sin))]. - self > Twopi ifTrue: [^ (self \\ Twopi) sin]. - self > Pi ifTrue: [^ (0.0 - (self - Pi) sin)]. - self > Halfpi ifTrue: [^ (Pi - self) sin]. - - "unroll loop to avoid use of abs" - sum _ delta _ self. - self2 _ 0.0 - (self * self). - i _ 2.0. - [delta >= sum ulp] whileTrue: [ - "once" - delta _ (delta * self2) / (i * (i + 1.0)). - i _ i + 2.0. - sum _ sum + delta. - "twice" - delta _ (delta * self2) / (i * (i + 1.0)). - i _ i + 2.0. - sum _ sum + delta]. - ^ sum! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 11/27/2018 13:10:59'! - sqrtNonPrimitive - "Answer the square root of the receiver. " - | exp guess delta | - - "Complex answer" - self <= 0.0 - ifTrue: [ - ^ self = 0.0 - ifFalse: [ (0.0 - self) sqrt i ] - ifTrue: [ self ] "Answer 0.0 for 0.0, but -0.0 for -0.0. See IEEE 754 standard" - ]. - - "NaN and Infinity" - self isFinite ifFalse: [ - ^ self ]. - - "Newton-Raphson" - "first guess is half the exponent" - exp _ self exponent // 2. - guess _ self timesTwoPower: 0 - exp. - [ - delta _ self - (guess * guess) / (guess * 2.0). - delta abs >= guess ulp ] - whileTrue: [ - guess _ guess + delta ]. - ^ guess! ! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 11/27/2018 11:09:00' prior: 16880047! - arcTan - "The receiver is the tangent of an angle. Answer the angle measured in radians. - Note: If the purpose is to recover the angle of some vector, prefer #arcTan: - See, for example, Complex>>#argument" - - ^self asFloat arcTan! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 11/27/2018 10:57:09' prior: 50400373! - sqrt - "Answer the square root of the receiver. - Use primitive if available, or Smalltalk code if primitive is unavailable or fails." - - | prim | - prim _ self primSqrt. - prim isNaN ifFalse: [ ^prim ]. - - ^ self sqrtNonPrimitive! ! -!Float class methodsFor: 'class initialization' stamp: 'jmv 11/27/2018 13:40:39' prior: 16845982! - initClassCachedState - "Float initialize" - "Constants from Computer Approximations, pp. 182-183: - Pi = 3.14159265358979323846264338327950288 - Pi/2 = 1.57079632679489661923132169163975144 - Pi*2 = 6.28318530717958647692528676655900576 - Pi/180 = 0.01745329251994329576923690768488612 - 2.0 ln = 0.69314718055994530941723212145817657 - 2.0 sqrt = 1.41421356237309504880168872420969808" - - Pi _ 3.14159265358979323846264338327950288. - Halfpi _ Pi / 2.0. - Twopi _ Pi * 2.0. - RadiansPerDegree _ Pi / 180.0. - - Ln2 _ 0.69314718055994530941723212145817657. - Ln10 _ 10.0 ln. - Sqrt2 _ 1.41421356237309504880168872420969808. - E _ 2.718281828459045235360287471353. - - MaxVal _ 1.7976931348623157e308. - MaxValLn _ 709.782712893384. - MinValLogBase2 _ -1074. - - Infinity _ MaxVal * MaxVal. - NegativeInfinity _ 0.0 - Infinity. - NaN _ Infinity - Infinity. - NegativeZero _ 1.0 / Infinity negated. -! ! -!Float class methodsFor: 'class initialization' stamp: 'jmv 11/27/2018 13:40:43' prior: 16846031! - releaseClassCachedState - - Pi _ nil. - Halfpi _ nil. - Twopi _ nil. - RadiansPerDegree _ nil. - - Ln2 _ nil. - Ln10 _ nil. - Sqrt2 _ nil. - E _ nil. - - MaxVal _ nil. - MaxValLn _ nil. - MinValLogBase2 _ nil. - - Infinity _ nil. - NegativeInfinity _ nil. - NaN _ nil. - NegativeZero _ nil! ! -!BoxedFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 11/27/2018 11:12:00' prior: 16790579! - arcTan - "Answer the angle in radians. - Optional. See Object documentation whatIsAPrimitive. - Note: If the purpose is to recover the angle of some vector, prefer #arcTan: - See, for example, Complex>>#argument" - - - ^ self arcTanNonPrimitive! ! -!BoxedFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 11/27/2018 11:14:01' prior: 16790598! - exp - "Answer E raised to the receiver power. - Optional. See Object documentation whatIsAPrimitive." - - - ^ self expNonPrimitive! ! -!BoxedFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 11/27/2018 11:14:45' prior: 16790631! - ln - "Answer the natural logarithm of the receiver. - Optional. See Object documentation whatIsAPrimitive." - - - ^ self lnNonPrimitive! ! -!BoxedFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 11/27/2018 11:15:17' prior: 16790733! - sin - "Answer the sine of the receiver taken as an angle in radians. - Optional. See Object documentation whatIsAPrimitive." - - - ^ self sinNonPrimitive! ! -!SmallFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 11/27/2018 11:11:58' prior: 16908312! - arcTan - "Answer the angle in radians. - Optional. See Object documentation whatIsAPrimitive. - Note: If the purpose is to recover the angle of some vector, prefer #arcTan: - See, for example, Complex>>#argument" - - - ^self arcTanNonPrimitive! ! -!SmallFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 11/27/2018 11:13:51' prior: 16908332! - exp - "Answer E raised to the receiver power. - Optional. See Object documentation whatIsAPrimitive." - - - ^ self expNonPrimitive! ! -!SmallFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 11/27/2018 11:14:36' prior: 16908365! - ln - "Answer the natural logarithm of the receiver. - Optional. See Object documentation whatIsAPrimitive." - - - ^ self lnNonPrimitive! ! -!SmallFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 11/27/2018 11:15:23' prior: 16908397! - sin - "Answer the sine of the receiver taken as an angle in radians. - Optional. See Object documentation whatIsAPrimitive." - - - ^ self sinNonPrimitive! ! -!Integer methodsFor: 'mathematical functions' stamp: 'jmv 11/27/2018 10:30:26' prior: 16859841! - sqrt - "Answer the square root of the receiver." - - | selfAsFloat floatResult guess | - selfAsFloat _ self asFloat. - floatResult _ selfAsFloat sqrt. - - floatResult isInfinite ifFalse: [ - guess _ floatResult truncated. - - "If got an exact answer, answer it. Otherwise answer float approximate answer." - guess squared = self - ifTrue: [ ^ guess ]]. - - "In this case, maybe it failed because we are such a big integer that the Float method becomes - inexact, even if we are a whole square number. So, try the slower but more general method." - selfAsFloat >= Float maxExactInteger asFloat squared - ifTrue: [ - guess _ self sqrtFloor. - guess squared = self - ifTrue: [ ^guess ]. - - "Nothing else can be done. No exact answer means answer must be a Float. - Answer the best we can which is the rounded sqrt." - ^ self sqrtRounded asFloat ]. - - "We need an approximate result" - ^floatResult! ! - -Number subclass: #Float - instanceVariableNames: '' - classVariableNames: 'E Halfpi Infinity Ln10 Ln2 MaxVal MaxValLn MinValLogBase2 NaN NegativeInfinity NegativeZero Pi RadiansPerDegree Sqrt2 Twopi' - poolDictionaries: '' - category: 'Kernel-Numbers'! - -!classDefinition: #Float category: #'Kernel-Numbers'! -Number subclass: #Float - instanceVariableNames: '' - classVariableNames: 'E Halfpi Infinity Ln10 Ln2 MaxVal MaxValLn MinValLogBase2 NaN NegativeInfinity NegativeZero Pi RadiansPerDegree Sqrt2 Twopi' - poolDictionaries: '' - category: 'Kernel-Numbers'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3504-Float-Refactor-RemoveEpsilonClassVar-JuanVuletich-2018Nov27-10h24m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3504] on 27 November 2018 at 2:34:48 pm'! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'jmv 11/27/2018 14:28:37'! - withSelectorUnderCursorDo: aBlock otherwise: failBlock - - self withSelectorUnderCursorDo: aBlock ifErrorsParsing: failBlock ifNoSelector: failBlock! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'jmv 11/27/2018 14:29:28' prior: 50419618! - implementorsOfIt - - "Open an implementors browser on the selector under cursor. If it can not parse the source code it uses - old implementation that looks for the selected selector if any - Hernan" - - self - withSelectorUnderCursorDo: [ :aSelector | Smalltalk browseAllImplementorsOf: aSelector ] - otherwise: [ self implementorsOfItWhenErrorsParsing ]! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'jmv 11/27/2018 14:29:23' prior: 50419633! - sendersOfIt - - "Open a senders browser on the selector under cursor. If it can not parse the source code it uses - old implementation that looks for the selected selector if any - Hernan" - - self - withSelectorUnderCursorDo: [ :aSelector | Smalltalk browseAllCallsOn: aSelector ] - otherwise: [ self sendersOfItWhenErrorsParsing ]! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'jmv 11/27/2018 14:33:01' prior: 50419575! - withSelectorUnderCursorDo: aBlock ifErrorsParsing: aParsingErrorBlock ifNoSelector: aNoSelectorBlock - - | methodNode nodeAtRange nodeUnderCursor | - - methodNode := self codeProvider methodNodeOf: model actualContents ifErrorsParsing: [ :anError | ^ aParsingErrorBlock valueWithPossibleArgument: anError ]. - - self startIndex < methodNode selectorLastPosition ifTrue: [ ^aBlock value: methodNode selector ]. - nodeAtRange := methodNode parseNodeIncluding: self startIndex ifAbsent: [ ^ aNoSelectorBlock value ]. - nodeUnderCursor := nodeAtRange key. - nodeUnderCursor isMessageNode ifTrue: [ ^aBlock value: nodeAtRange key selector key ]. - (nodeUnderCursor isLiteralNode and: [ nodeUnderCursor literalValue isSymbol ]) ifTrue: [ ^aBlock value: nodeUnderCursor literalValue ]. - - ^ aNoSelectorBlock value ! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3505-FixSendersImplementorsEnhancements-JuanVuletich-2018Nov27-14h32m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3505] on 27 November 2018 at 2:46:58 pm'! -!Theme class methodsFor: 'instance creation' stamp: 'jmv 11/27/2018 14:45:06' prior: 50400284! - beCurrent - self currentTheme: self. - self inform: 'Please close and reopen all windows'! ! -!Theme class methodsFor: 'user interface' stamp: 'jmv 11/27/2018 14:42:55' prior: 50420326! - changeTheme - - | menu | - "In Theme-Themes.pck.st" - (FeatureRequirement name: 'Theme-Themes') isAlreadySatisfied ifFalse: [ - (PopUpMenu - confirm: 'The Additional Themes package is not loaded', String newLineString, 'Would you like me to load it for you now?') - ifTrue: [Feature require: #'Theme-Themes'] - ]. - menu _ MenuMorph new. - menu - addTitle: 'Choose a theme'; - addStayUpIcons. - (Theme allSubclasses sorted: [ :a :b | a name < b name ]) do: [ :themeClass | - menu add: themeClass name target: themeClass action: #beCurrent ]. - menu popUpInWorld: self runningWorld! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3506-Themes-enh-JuanVuletich-2018Nov27-14h41m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3505] on 27 November 2018 at 4:39:19 pm'! -!PluggableTextModel commentStamp: '' prior: 16890049! - A TextModel whose contents are stored elsewhere (ivar textProvider)! -!TextProvider methodsFor: 'accessing' stamp: 'jmv 11/27/2018 16:38:04'! - methodNodeOf: aSourceCode ifErrorsParsing: aParsingErrorBlock - - ^[ UndefinedObject methodNodeFor: aSourceCode noPattern: true ] on: Error, UndeclaredVariableReference do: aParsingErrorBlock -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3507-yetAnother-JuanVuletich-2018Nov27-16h34m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3507] on 28 November 2018 at 6:06:10 pm'! -!Theme class methodsFor: 'instance creation' stamp: 'cbr 12/14/2010 01:55' prior: 50420834! - beCurrent - ^ self currentTheme: self! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3508-AvoidHangOnImageSave-JuanVuletich-2018Nov28-18h05m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3508] on 29 November 2018 at 1:05:06 pm'! - -Theme subclass: #BrightColorTheme - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Theme-Core'! - -!classDefinition: #BrightColorTheme category: #'Theme-Core'! -Theme subclass: #BrightColorTheme - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Theme-Core'! -!BrightColorTheme commentStamp: '' prior: 0! - Default bright colored theme for Cuis.! - -Theme subclass: #DarkTheme - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Theme-Core'! - -!classDefinition: #DarkTheme category: #'Theme-Core'! -Theme subclass: #DarkTheme - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Theme-Core'! -!DarkTheme commentStamp: '' prior: 0! - A low contrast, darker gray theme.! -!DarkTheme methodsFor: 'colors' stamp: 'jmv 11/27/2018 10:07:19'! - background - ^ `Color black`! ! -!DarkTheme methodsFor: 'colors' stamp: 'jmv 11/26/2018 18:24:15'! - buttonLabel - ^ `Color gray: 0.48`! ! -!DarkTheme methodsFor: 'colors' stamp: 'jmv 11/27/2018 10:07:25'! - defaultWindowColor - ^ `Color hue: 212 chroma: 0.015 luminance: 0.25`! ! -!DarkTheme methodsFor: 'colors' stamp: 'cbr 10/10/2012 20:18'! - missingCommentTextColor - - ^ TextColor cyan! ! -!DarkTheme methodsFor: 'colors' stamp: 'jmv 11/26/2018 16:59:09'! - paneBackgroundFrom: aColor - ^ aColor alphaMixed: 0.7 with: Color black! ! -!DarkTheme methodsFor: 'colors' stamp: 'jmv 11/27/2018 09:59:07'! - shout - "Color symbols as an association list." - - ^ { - #selector -> '#B59F60'. - #arguments -> '#289078'. - #comment -> #(green duller). - #tempBar -> #gray. - #tempVars -> '#767836'. - #instVar -> '#B3695A'. - #pseudoVariables -> '#2070E0'. - #literals -> #green. - #messages -> '#6FB3BD'. - #incompleteMessages -> '#F08060'. - #blockLevelZero -> '#6FB3BD'. - #blockLevelOne -> '#FFB0B0'. - #blockLevelTwo -> '#B0FFB0'. - #blockLevelThree -> '#B0B0FF'. - #blockLevelFour -> '#00B0B0'. - #blockLevelFive -> '#E03030'. - #blockLevelSix -> '#30E030'. - #blockLevelSeven -> '#3030E0'. - #defaults -> '#A1AFBF'. - #undefined -> '#E04020'. - #methodTags -> #green. - }! ! -!DarkTheme methodsFor: 'colors' stamp: 'jmv 11/27/2018 10:07:33'! - text - ^ `Color veryLightGray`! ! -!DarkTheme methodsFor: 'colors' stamp: 'jmv 11/26/2018 18:08:53'! - textHighlight - "A nice light blue." - " - ^ Color r: 0.71 g: 0.835 b: 1.0 - ^ Color hue: 214 chroma: 0.29 luminance: 0.816 - " - ^ `Color hue: 204 chroma: 0.29 luminance: 0.22`! ! -!DarkTheme methodsFor: 'colors' stamp: 'jmv 11/27/2018 10:07:40'! - textPane - ^ `Color gray`! ! -!DarkTheme methodsFor: 'colors' stamp: 'jmv 11/27/2018 10:07:46'! - unfocusedTextHighlightFrom: aColor - ^ aColor adjustSaturation: -0.15 brightness: -0.07! ! -!DarkTheme methodsFor: 'colors' stamp: 'cbr 10/10/2012 18:32'! - useUniformColors - ^ true! ! -!DarkTheme methodsFor: 'other options' stamp: 'jmv 11/27/2018 10:07:56'! - windowLabel - ^ `Color gray: 0.55`! ! -!DarkTheme methodsFor: 'menu colors' stamp: 'jmv 11/26/2018 18:29:15'! - menu - ^ `Color darkGray`! ! -!DarkTheme methodsFor: 'menu colors' stamp: 'jmv 11/26/2018 18:31:04'! - menuText - ^ self text! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -BrightColorTheme beCurrent! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3509-AddDarkTheme-JuanVuletich-2018Nov29-13h02m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3508] on 29 November 2018 at 1:05:30 pm'! - -Smalltalk removeClassNamed: #BrightTheme! - -Smalltalk removeClassNamed: #BrightTheme! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3510-cleanup-JuanVuletich-2018Nov29-13h05m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3510] on 30 November 2018 at 9:29:13 am'! -!Editor methodsFor: 'new selection' stamp: 'jmv 11/30/2018 09:26:44' prior: 16836464! - selectWordLeftDelimiters: leftDelimiters rightDelimiters: rightDelimiters - "Select delimited text or word--the result of double-clicking." - - | initialDelimiter finalDelimiter direction match level string here hereChar start stop | - string _ self privateCurrentString. - string size < 2 ifTrue: [^self selectFrom: 1 to: 1]. - here _ self pointIndex min: string size max: 2. - initialDelimiter _ string at: here - 1. - match _ leftDelimiters indexOf: initialDelimiter. - match > 0 - ifTrue: [ - "delimiter is on left -- match to the right" - start _ here. - direction _ 1. - here _ here - 1. - finalDelimiter _ rightDelimiters at: match] - ifFalse: [ - initialDelimiter _ string at: here. - match _ rightDelimiters indexOf: initialDelimiter. - match > 0 - ifTrue: [ - "delimiter is on right -- match to the left" - stop _ here - 1. - direction _ -1. - finalDelimiter _ leftDelimiters at: match] - ifFalse: [ - "no delimiters -- select a token" - direction _ -1]]. - level _ 1. - [level > 0 and: [direction > 0 - ifTrue: [here < string size] - ifFalse: [here > 1]]] - whileTrue: [ - hereChar _ string at: (here _ here + direction). - match = 0 - ifTrue: [ - "token scan goes left, then right" - hereChar isValidInIdentifiers "Consider $: as a word separator" - ifTrue: [ - here = 1 - ifTrue: [ - start _ 1. - "go right if hit string start" - direction _ 1]] - ifFalse: [ - direction < 0 - ifTrue: [ - start _ here + 1. - "go right if hit non-token" - direction _ 1] - ifFalse: [level _ 0]]] - ifFalse: [ - "delimiter match just counts nesting level" - hereChar = finalDelimiter - ifTrue: [level _ level - 1"leaving nest"] - ifFalse: [ - hereChar = initialDelimiter - ifTrue: [level _ level + 1"entering deeper nest"]]]]. - level > 0 ifTrue: [ - "If we failed to find final delimiter, then just select word." - ^self selectWordLeftDelimiters: '' rightDelimiters: '' ]. - direction > 0 - ifTrue: [ - "If a word ends with $: (a keyword), consider it part of the word" - hereChar = $: ifTrue: [here _ here + 1]. - self selectFrom: start to: here - 1] - ifFalse: [ - "But if a word starts with $: (this is the argument to a keyword), then it is not part of the word." - self selectFrom: here + 1 to: stop]! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'HAW 11/29/2018 19:11:47' prior: 50404877! - browseIt - "Launch a browser for the current selection, if appropriate" - - | aSymbol anEntry browser | - Preferences alternativeBrowseIt ifTrue: [^ self browseClassFromIt]. - - self wordSelectAndEmptyCheck: [^ self]. - aSymbol _ self selectedSymbol ifNil: [ - self - evaluateSelectionAndDo: [ :result | result class name ] - ifFail: [ ^morph flash ] - profiled: false]. - - aSymbol first isUppercase - ifTrue: [ - anEntry _ (Smalltalk - at: aSymbol - ifAbsent: [ - Smalltalk browseAllImplementorsOf: aSymbol. - ^ nil]). - anEntry ifNil: [^ morph flash]. - (anEntry isKindOf: Class) - ifFalse: [anEntry _ anEntry class]. - browser _ Browser new. - browser setClass: anEntry selector: nil. - BrowserWindow open: browser label:'System Browser: ', aSymbol] - ifFalse: - [Smalltalk browseAllImplementorsOf: aSymbol]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3511-AutoSelectToBrowse-fix-HernanWilkinson-2018Nov30-09h28m-HAW.1.cs.st----! - -----SNAPSHOT----#(30 November 2018 9:33:29.024398 am) Cuis5.0-3511-32.image priorSource: 2797784! - -----QUIT----#(30 November 2018 9:34:00.256006 am) Cuis5.0-3511-32.image priorSource: 2863884! - -----STARTUP----#(21 December 2018 5:44:55.56543 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3511-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3511] on 1 December 2018 at 11:24:55 am'! -!Editor methodsFor: 'new selection' stamp: 'jmv 12/1/2018 11:23:07' prior: 50421037! - selectWordLeftDelimiters: leftDelimiters rightDelimiters: rightDelimiters - "Select delimited text or word--the result of double-clicking." - - | initialDelimiter finalDelimiter direction match level string here hereChar start stop | - string _ self privateCurrentString. - string size < 2 ifTrue: [^self selectFrom: 1 to: 1]. - here _ self pointIndex min: string size max: 2. - initialDelimiter _ string at: here - 1. - match _ leftDelimiters indexOf: initialDelimiter. - match > 0 - ifTrue: [ - "delimiter is on left -- match to the right" - start _ here. - direction _ 1. - here _ here - 1. - finalDelimiter _ rightDelimiters at: match] - ifFalse: [ - initialDelimiter _ string at: here. - match _ rightDelimiters indexOf: initialDelimiter. - match > 0 - ifTrue: [ - "delimiter is on right -- match to the left" - stop _ here - 1. - direction _ -1. - finalDelimiter _ leftDelimiters at: match] - ifFalse: [ - "no delimiters -- select a token" - direction _ -1]]. - level _ 1. - [level > 0 and: [direction > 0 - ifTrue: [here < string size] - ifFalse: [here > 1]]] - whileTrue: [ - hereChar _ string at: (here _ here + direction). - match = 0 - ifTrue: [ - "token scan goes left, then right" - hereChar isValidInIdentifiers "Consider $: as a word separator" - ifTrue: [ - here = 1 - ifTrue: [ - start _ 1. - "go right if hit string start" - direction _ 1]] - ifFalse: [ - direction < 0 - ifTrue: [ - start _ here + 1. - "go right if hit non-token" - direction _ 1] - ifFalse: [level _ 0]]] - ifFalse: [ - "delimiter match just counts nesting level" - hereChar = finalDelimiter - ifTrue: [level _ level - 1"leaving nest"] - ifFalse: [ - hereChar = initialDelimiter - ifTrue: [level _ level + 1"entering deeper nest"]]]]. - level > 0 ifTrue: [ - leftDelimiters size + rightDelimiters size = 0 ifFalse: [ - "If we failed to find final delimiter, then just select word." - ^self selectWordLeftDelimiters: '' rightDelimiters: '' ]. - here _ here + direction ]. - direction > 0 - ifTrue: [ - "If a word ends with $: (a keyword), consider it part of the word" - hereChar = $: ifTrue: [here _ here + 1]. - self selectFrom: start to: here - 1] - ifFalse: [ - "But if a word starts with $: (this is the argument to a keyword), then it is not part of the word." - self selectFrom: here + 1 to: stop]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3512-TripleClickOnTextEditorFix-JuanVuletich-2018Dec01-11h16m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3512] on 4 December 2018 at 12:19:11 pm'! -!Float methodsFor: 'converting' stamp: 'jmv 12/4/2018 12:11:37' prior: 50417752! - partBits: aThreeArgumentBlock - " - Extract the bits for Sign, Mantissa and Exponent parts of the Floating Point representation. - Just extract the bits. Do not add implicit bit. Do not correct denormals. Do not substract exponent bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. (f signPart * f significandAsInteger * (2 raisedToInteger: f exponentPart-52)) asFloat = f } print ]. - " - | allBits signBit exponentBits mantissaBits | - - "Extract the bits of an IEEE double float " - allBits _ ((self basicAt: 1) bitShift: 32) + (self basicAt: 2). - - "Extract the sign and the biased exponent " - signBit _ allBits bitShift: -63. - exponentBits _ (allBits bitShift: -52) bitAnd: 16r7FF. - - "Extract fractional part " - mantissaBits _ allBits bitAnd: 16r000FFFFFFFFFFFFF. - - "Evaluate the block" - ^aThreeArgumentBlock value: signBit value: exponentBits value: mantissaBits! ! -!Float methodsFor: 'converting' stamp: 'jmv 12/4/2018 12:12:49' prior: 50417833! - partValues: aThreeArgumentBlock ifInfinite: infiniryBlock ifNaN: nanBlock - " - Float pi hex print - Float pi partValues: [ :sign :exponent :mantissa | { sign hex. exponent hex. mantissa hex} print ] - 0.0 partValues: [ :sign :exponent :mantissa | { sign hex. exponent hex. mantissa hex} print ] - For 0.0, exponent will be the minimum possible, i.e. -1023, and mantissa will be 0. - " - | sign exponent mantissa | - - self partBits: [ :signBit :exponentBits :mantissaBits | - - "Extract the sign" - sign _ signBit = 0 ifTrue: [1] ifFalse: [-1]. - - "Special cases: infinites and NaN" - exponentBits = 16r7FF ifTrue: [ - ^mantissaBits = 0 - ifTrue: [ infiniryBlock valueWithPossibleArgument: self ] - ifFalse: [ nanBlock valueWithPossibleArgument: self and: mantissaBits ]]. - - "Unbias exponent: 16r3FF is bias" - exponent _ exponentBits - 16r3FF. - - "Add back implicit leading 1 in fraction if appropriate" - "If expPart = 0, I am +/-zero or a denormal value. In such cases, no implicit leading bit in mantissa" - exponentBits = 0 - ifTrue: [ - mantissa _ mantissaBits. - exponent _ exponent + 1 ] - ifFalse: [ - mantissa _ 16r0010000000000000 bitOr: mantissaBits ]. - - "Evaluate the block" - ^aThreeArgumentBlock value: sign value: exponent value: mantissa - ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/4/2018 12:13:25' prior: 50414501! - mantissaPart - "Equivalent to #significandAsInteger." - "The actual bits in the mantissa of the receiver, as an integer, including the implicit leading 1 if appropriate. - Does not include de sign. - See #exponentPart and #signPart - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. (f signPart * f mantissaPart * (2 raisedToInteger: f exponentPart-52)) asFloat = f } print ]. - " - ^self partValues: [ :sign :exponent :mantissa | mantissa ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/4/2018 12:15:28' prior: 50418698! - predecessor - "Answer the largest Float smaller than self" - | ulp | - self isFinite ifFalse: [ - (self isNaN or: [self negative]) ifTrue: [^self]. - ^Float fmax]. - ulp := self ulp. - ^self - (0.5 * ulp) = self - ifTrue: [self - ulp] - ifFalse: [self - (0.5 * ulp)]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/4/2018 12:13:37' prior: 50417876! - significandAsInteger - "The actual bits in the mantissa of the receiver, as an integer number, including the implicit leading 1 if appropriate. - See #mantissaPart - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. (f signPart * f significandAsInteger * (2 raisedToInteger: f exponentPart-52)) asFloat = f } print ]. - " - ^self mantissaPart! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/4/2018 12:15:19' prior: 50417402! - successor - "Answer the smallest Float greater than self" - | ulp | - self isFinite ifFalse: [ - (self isNaN or: [self positive]) ifTrue: [^self]. - ^Float fmax negated]. - ulp := self ulp. - ^self + (0.5 * ulp) = self - ifTrue: [self * -1.0 - ulp * -1.0 "This trick is for obtaining a negativeZero"] - ifFalse: [self + (0.5 * ulp)]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/4/2018 12:15:44' prior: 50418708! - ulp - "Answer the unit of least precision of the receiver" - - | exponent | - self isFinite ifFalse: [^self abs]. - self isZero ifTrue: [^Float fmin]. - exponent := self exponent. - ^exponent < self class emin - ifTrue: [Float fminDenormalized] - ifFalse: [Float epsilon timesTwoPower: exponent]! ! -!Float methodsFor: 'printing' stamp: 'jmv 12/4/2018 12:17:36' prior: 50418750! - printOn: aStream base: base - "Handle sign, zero, and NaNs; all other values passed to absPrintOn:base:" - - self isNaN ifTrue: [aStream nextPutAll: 'NaN'. ^ self]. "check for NaN before sign" - self > 0.0 - ifTrue: [self absPrintOn: aStream base: base] - ifFalse: - [self sign = -1 - ifTrue: [aStream nextPutAll: '-']. - self isZero - ifTrue: [aStream nextPutAll: '0.0'] - ifFalse: [self negated absPrintOn: aStream base: base]]! ! -!Float class methodsFor: 'constants' stamp: 'jmv 12/4/2018 11:57:45' prior: 16845874! - emin - "Answer the exponent of the non-denormal value with smallest magnitude" - - ^-1022! ! -!Float class methodsFor: 'constants' stamp: 'jmv 12/4/2018 11:58:23' prior: 16845952! - precision - "Answer the apparent precision of the floating point representation. - That is the maximum number of radix-based digits (bits if radix=2) representable in floating point without rounding error. - Technically, 52 bits are stored in the representation, and normalized numbers have an implied leading 1 that does not need to be stored. - Note that denormalized floating point numbers don't have the implied leading 1, and thus gradually lose precision. - This format implements the IEEE-754 binary64 format." - - ^53! ! -!Fraction methodsFor: 'converting' stamp: 'jmv 12/4/2018 11:57:12' prior: 16849556! - asFloat - "Answer a Float that closely approximates the value of the receiver. - This implementation will answer the closest floating point number to the receiver. - In case of a tie, it will use the IEEE 754 round to nearest even mode. - In case of overflow, it will answer +/- Float infinity." - - | a b mantissa exponent floatMantissa hasTruncatedBits lostBit n ha hb hm | - a := numerator abs. - b := denominator. "denominator is always positive" - ha := a highBit. - hb := b highBit. - - "Number of bits to keep in mantissa plus one to handle rounding." - n := 1 + Float precision. - - "If both numerator and denominator are represented exactly as floating point number, - float division is fastest." - (ha < n and: [hb < n]) ifTrue: [^numerator asFloat / denominator asFloat]. - - "Shift the fraction by a power of two exponent so as to obtain a mantissa with n bits. - The first guess is approximate, the mantissa might have n+1 bits." - exponent := ha - hb - n. - exponent >= 0 - ifTrue: [b := b bitShift: exponent] - ifFalse: [a := a bitShift: exponent negated]. - mantissa := a quo: b. - hasTruncatedBits := a > (mantissa * b). - hm := mantissa highBit. - - "Check for gradual underflow, in which case the mantissa will lose bits. - Keep at least one bit to let underflow preserve the sign of zero." - lostBit := Float emin - (exponent + hm - 1). - lostBit > 0 ifTrue: [n := n - lostBit max: 1]. - - "Remove excess bits in the mantissa." - hm > n - ifTrue: - [exponent := exponent + hm - n. - hasTruncatedBits := hasTruncatedBits or: [mantissa anyBitOfMagnitudeFrom: 1 to: hm - n]. - mantissa := mantissa bitShift: n - hm]. - - "Check if mantissa must be rounded upward. - The case of tie will be handled by Integer>>asFloat." - (hasTruncatedBits and: [mantissa odd]) - ifTrue: [mantissa := mantissa + 1]. - - floatMantissa := mantissa asFloat. - self positive ifFalse: [floatMantissa := floatMantissa negated]. - ^floatMantissa timesTwoPower: exponent! ! -!Integer methodsFor: 'bit manipulation' stamp: 'jmv 12/4/2018 11:59:58' prior: 16859338! - highBitOfMagnitude - "Answer the position of the leading bit or zero if the - receiver is zero. Receiver has to be positive!!" - - | shifted bitNo | - shifted := self < 0 ifTrue: [0 - self] ifFalse: [self]. - bitNo := 0. - [shifted < 65536] - whileFalse: - [shifted := shifted bitShift: -16. - bitNo := bitNo + 16]. - shifted < 256 - ifFalse: - [shifted := shifted bitShift: -8. - bitNo := bitNo + 8]. - - "The high bits table can be obtained with: - (1 to: 8) inject: #[0] into: [:highBits :rank | highBits , (highBits collect: [:e | rank])]." - ^bitNo + ( #[0 1 2 2 3 3 3 3 4 4 4 4 4 4 4 4 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8] at: shifted + 1)! ! -!LargePositiveInteger methodsFor: 'bit manipulation' stamp: 'jmv 12/4/2018 11:59:42' prior: 16862428! - highBit - "Answer the position of the leading bit or zero if the - receiver is zero. Raise an error if the receiver is negative, since - negative integers are defined to have an infinite number of leading 1's - in 2's-complement arithmetic. Use >>highBitOfMagnitude if you want to - get the highest bit of the magnitude." - ^ self highBitOfMagnitude! ! -!LargePositiveInteger methodsFor: 'bit manipulation' stamp: 'jmv 12/4/2018 12:04:04' prior: 16862443! - highBitOfMagnitude - "Answer the position of the leading bit or zero if the - receiver is zero. - This method is used for LargeNegativeIntegers as well, - since Squeak's LargeIntegers are sign/magnitude." - | byteIndex msByte | - byteIndex := self digitLength. - [byteIndex > 0] whileTrue: - [ - msByte := self at: byteIndex. - msByte > 0 ifTrue: [^byteIndex - 1 * 8 + msByte highBit]. - byteIndex := byteIndex - 1 - ]. - ^0! ! -!LargeNegativeInteger methodsFor: 'bit manipulation' stamp: 'jmv 12/4/2018 11:59:30' prior: 16862144! - highBit - "Answer the position of the leading bit or zero if the - receiver is zero. Raise an error if the receiver is negative, since - negative integers are defined to have an infinite number of leading 1's - in 2's-complement arithmetic. Use >>highBitOfMagnitude if you want to - get the highest bit of the magnitude." - - ^self error: 'highBit is not defined for negative integers'! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3513-NumericsCleanup-JuanVuletich-2018Dec04-10h24m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3512] on 4 December 2018 at 12:21:28 pm'! -!Float methodsFor: 'converting' stamp: 'jmv 12/4/2018 12:20:55' prior: 50421280! - partValues: aThreeArgumentBlock ifInfinite: infinityBlock ifNaN: nanBlock - " - Float pi hex print - Float pi partValues: [ :sign :exponent :mantissa | { sign hex. exponent hex. mantissa hex} print ] - 0.0 partValues: [ :sign :exponent :mantissa | { sign hex. exponent hex. mantissa hex} print ] - For 0.0, exponent will be the minimum possible, i.e. -1023, and mantissa will be 0. - " - | sign exponent mantissa | - - self partBits: [ :signBit :exponentBits :mantissaBits | - - "Extract the sign" - sign _ signBit = 0 ifTrue: [1] ifFalse: [-1]. - - "Special cases: infinites and NaN" - exponentBits = 16r7FF ifTrue: [ - ^mantissaBits = 0 - ifTrue: [ infinityBlock valueWithPossibleArgument: self ] - ifFalse: [ nanBlock valueWithPossibleArgument: self and: mantissaBits ]]. - - "Unbias exponent: 16r3FF is bias" - exponent _ exponentBits - 16r3FF. - - "Add back implicit leading 1 in fraction if appropriate" - "If expPart = 0, I am +/-zero or a denormal value. In such cases, no implicit leading bit in mantissa" - exponentBits = 0 - ifTrue: [ - mantissa _ mantissaBits. - exponent _ exponent + 1 ] - ifFalse: [ - mantissa _ 16r0010000000000000 bitOr: mantissaBits ]. - - "Evaluate the block" - ^aThreeArgumentBlock value: sign value: exponent value: mantissa - ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3514-NumericsCleanup-JuanVuletich-2018Dec04-12h19m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3512] on 4 December 2018 at 12:26:03 pm'! -!Float methodsFor: 'printing' stamp: 'jmv 12/3/2018 18:27:17' prior: 16845515! - hex - ^ String streamContents: [ :strm | | word nibble | - 1 to: 2 do: [ :i | - word := self at: i. - 1 to: 8 do: [ :s | - nibble := (word bitShift: -8+s*4) bitAnd: 16rF. - strm nextPut: ('0123456789ABCDEF' at: nibble+1)]]] -" -(-2.0 to: 2.0) collect: [:f | f hex] -"! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3515-NumericsCleanup-JuanVuletich-2018Dec04-12h21m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3515] on 4 December 2018 at 3:51:34 pm'! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/4/2018 15:21:29'! - nextAwayFromZero - "Answer the Float with smallest magnitude but larger than ours, with the same sign - Only for finite numbers." - - | exponent mantissa | - self partValues: [ :sign :myExponent :myMantissa | - myMantissa = 16r1FFFFFFFFFFFFF - ifTrue: [ - mantissa _ 16r10000000000000. - exponent _ myExponent +1 ] - ifFalse: [ - mantissa _ myMantissa+1. - exponent _ myExponent ]. - ^ Float signPart: sign mantissaPart: mantissa exponentPart: exponent ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/4/2018 15:21:25'! - nextTowardsZero - "Answer the Float with largest magnitude but smaller than ours, with the same sign. - Only for finite, non zero numbers." - - | exponent mantissa | - self partValues: [ :sign :myExponent :myMantissa | - myMantissa isZero ifTrue: [ self error: 'Not for zero values' ]. - (myMantissa = 16r10000000000000 and: [myExponent > Float emin]) - ifTrue: [ - mantissa _ 16r1FFFFFFFFFFFFF. - exponent _ myExponent -1 ] - ifFalse: [ - mantissa _ myMantissa-1. - exponent _ myExponent ]. - ^ Float signPart: sign mantissaPart: mantissa exponentPart: exponent ]! ! -!Float class methodsFor: 'instance creation' stamp: 'jmv 12/4/2018 14:10:38'! - signBit: signBit mantissaBits: mantissaBits exponentBits: exponentBits - " - Float signBit: Float pi signBit mantissaBits: Float pi mantissaBits exponentBits: Float pi exponentBits - " - | answer leastSignificativeWord mostSignificativeWord | - answer _ BoxedFloat64 new. - mostSignificativeWord _ (signBit bitShift: 31) + (exponentBits bitShift: 20) + (mantissaBits bitShift: -32). - leastSignificativeWord _ mantissaBits bitAnd: 16rFFFFFFFF. - answer basicAt: 1 put: mostSignificativeWord. - answer basicAt: 2 put: leastSignificativeWord. - ^ answer! ! -!Float class methodsFor: 'instance creation' stamp: 'jmv 12/4/2018 14:09:38'! - signPart: signPart mantissaPart: mantissaPart exponentPart: exponentPart - " - Float signPart: Float pi signPart mantissaPart: Float pi mantissaPart exponentPart: Float pi exponentPart - " - ^ signPart * mantissaPart asFloat timesTwoPower: exponentPart-52! ! -!Float methodsFor: 'converting' stamp: 'jmv 12/4/2018 13:37:51' prior: 50421247! - partBits: aThreeArgumentBlock - " - Extract the bits for Sign, Mantissa and Exponent parts of the Floating Point representation. - Just extract the bits. Do not add implicit bit. Do not correct denormals. Do not substract exponent bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. (f signPart * f significandAsInteger * (2 raisedToInteger: f exponentPart-52)) asFloat = f } print ]. - " - | signBit exponentBits mantissaBits leastSignificativeWord mostSignificativeWord | - - mostSignificativeWord _ self basicAt: 1. - leastSignificativeWord _ self basicAt: 2. - signBit _ mostSignificativeWord bitShift: -31 . - exponentBits _ (mostSignificativeWord bitShift: -20 ) bitAnd: 16r7FF. - mantissaBits _ ((mostSignificativeWord bitAnd: 16r000FFFFF) bitShift: 32) + leastSignificativeWord. - - "Evaluate the block" - ^aThreeArgumentBlock value: signBit value: exponentBits value: mantissaBits! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/4/2018 14:54:42' prior: 50421341! - predecessor - "Answer the largest Float smaller than self" - - self isFinite ifFalse: [ - (self isNaN or: [self negative]) ifTrue: [^self]. - ^Float fmax]. - self isZero ifTrue: [ - "Both for positive and negative zero" - ^ -0.0 nextAwayFromZero ]. - ^self > 0.0 - ifTrue: [ self nextTowardsZero ] - ifFalse: [ self nextAwayFromZero ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/4/2018 14:54:36' prior: 50421368! - successor - "Answer the smallest Float greater than self" - - self isFinite ifFalse: [ - (self isNaN or: [self positive]) ifTrue: [^self]. - ^Float fmax negated]. - self isZero ifTrue: [ - "Both for positive and negative zero" - ^ 0.0 nextAwayFromZero ]. - ^self < 0.0 - ifTrue: [ self nextTowardsZero ] - ifFalse: [ self nextAwayFromZero ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/4/2018 14:51:27' prior: 50421382! - ulp - "Answer the unit of least precision of the receiver" - - self isFinite ifFalse: [^self abs]. - ^ (self nextAwayFromZero - self) abs! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3516-muchBetterUlpPredecessorSuccessor-JuanVuletich-2018Dec04-15h44m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3508] on 6 December 2018 at 12:58:58 pm'! - -VariableScopeFinder removeSelector: #visitFieldNode:! - -VariableScopeFinder removeSelector: #visitFieldNode:! - -ParseNodeEnumerator removeSelector: #visitFieldNode:! - -ParseNodeEnumerator removeSelector: #visitFieldNode:! - -ParseNodeVisitor removeSelector: #visitFieldNode:! - -ParseNodeVisitor removeSelector: #visitFieldNode:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3517-Cleanup-HernanWilkinson-2018Dec06-12h58m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3517] on 10 December 2018 at 6:59:08 pm'! -!Float methodsFor: 'converting' stamp: 'jmv 12/10/2018 18:49:42' prior: 50421592! - partValues: aThreeArgumentBlock ifInfinite: infinityBlock ifNaN: nanBlock - " - Float pi hex print - Float pi partValues: [ :sign :exponent :mantissa | { sign hex. exponent hex. mantissa hex} print ] - 0.0 partValues: [ :sign :exponent :mantissa | { sign hex. exponent hex. mantissa hex} print ] - For 0.0, exponent will be the minimum possible, i.e. -1023, and mantissa will be 0. - " - | sign exponent mantissa | - - ^ self partBits: [ :signBit :exponentBits :mantissaBits | - - "Extract the sign" - sign _ signBit = 0 ifTrue: [1] ifFalse: [-1]. - - "Special cases: infinites and NaN" - exponentBits = 16r7FF ifTrue: [ - ^mantissaBits = 0 - ifTrue: [ infinityBlock valueWithPossibleArgument: self ] - ifFalse: [ nanBlock valueWithPossibleArgument: self and: mantissaBits ]]. - - "Unbias exponent: 16r3FF is bias" - exponent _ exponentBits - 16r3FF. - - "Add back implicit leading 1 in fraction if appropriate" - "If expPart = 0, I am +/-zero or a denormal value. In such cases, no implicit leading bit in mantissa" - exponentBits = 0 - ifTrue: [ - mantissa _ mantissaBits. - exponent _ exponent + 1 ] - ifFalse: [ - mantissa _ 16r0010000000000000 bitOr: mantissaBits ]. - - "Evaluate the block" - aThreeArgumentBlock value: sign value: exponent value: mantissa - ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/10/2018 18:49:08' prior: 50417785! - exponentBits - " - Actual bits for the exponent part of the Floating Point representation. - Just extract the bits. Do not correct denormals. Do not substract bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - { f. f exponentBits. f exponentPart. f exponent } print ]. - " - - ^ self partBits: [ :signBit :exponentBits :mantissaBits | exponentBits ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/10/2018 18:49:15' prior: 50417801! - mantissaBits - " - Actual bits for the mantissa part of the Floating Point representation. - Just extract the bits. Do not correct denormals. Do not substract bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - { f. f mantissaBits. f mantissaPart. f significand. } print ]. - " - ^ self partBits: [ :signBit :exponentBits :mantissaBits | mantissaBits ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/10/2018 18:54:58' prior: 50421661! - nextAwayFromZero - "Answer the Float with smallest magnitude but larger than ours, with the same sign - Only for finite numbers." - - | exponent mantissa | - ^ self partValues: [ :sign :myExponent :myMantissa | - myMantissa = 16r1FFFFFFFFFFFFF - ifTrue: [ - mantissa _ 16r10000000000000. - exponent _ myExponent +1 ] - ifFalse: [ - mantissa _ myMantissa+1. - exponent _ myExponent ]. - Float signPart: sign mantissaPart: mantissa exponentPart: exponent ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/10/2018 18:55:04' prior: 50421678! - nextTowardsZero - "Answer the Float with largest magnitude but smaller than ours, with the same sign. - Only for finite, non zero numbers." - - | exponent mantissa | - ^ self partValues: [ :sign :myExponent :myMantissa | - myMantissa isZero ifTrue: [ self error: 'Not for zero values' ]. - (myMantissa = 16r10000000000000 and: [myExponent > Float emin]) - ifTrue: [ - mantissa _ 16r1FFFFFFFFFFFFF. - exponent _ myExponent -1 ] - ifFalse: [ - mantissa _ myMantissa-1. - exponent _ myExponent ]. - Float signPart: sign mantissaPart: mantissa exponentPart: exponent ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/10/2018 18:49:24' prior: 50417817! - signBit - " - Actual bits for the exponent part of the Floating Point representation. - Just extract the bits. Do not correct denormals. Do not substract bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0. 0.0. -0.0} do: [ :f | - { f. f signBit. f signPart. f sign } print ]. - " - - ^ self partBits: [ :signBit :exponentBits :mantissaBits | signBit ]! ! -!Integer methodsFor: 'bit manipulation' stamp: 'jmv 12/10/2018 18:36:21' prior: 16859375! - lowBit - "Answer the index of the low order bit of this number" - - | byte byteIndex byteSize | - byteIndex _ 1. - byteSize _ self digitLength. - [ byteIndex <= byteSize ] whileTrue: [ - byte _ self at: byteIndex. - byte > 0 ifTrue: [ ^ byteIndex - 1 * 8 + byte lowBit ]. - byteIndex _ byteIndex + 1 ]. - ^ 0.! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3518-AvoidNonLocalReturns-JuanVuletich-2018Dec10-14h13m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3517] on 11 December 2018 at 1:42:08 pm'! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/11/2018 13:10:34' prior: 50421791! - ulp - "Answer the unit of least precision of the receiver. - Follow John Harrison's definition as described at - https://en.wikipedia.org/wiki/Unit_in_the_last_place" - - self isFinite ifFalse: [^self abs]. - self isZero ifTrue: [^0.0 nextAwayFromZero]. - ^ (self - self nextTowardsZero) abs! ! -!Float class methodsFor: 'constants' stamp: 'jmv 12/11/2018 13:21:21' prior: 16845879! - epsilon - "Answer difference between 1.0 and next representable value. - Note: does not equal 1.0 ulp." - - ^1.0 successor - 1.0! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3519-UseJohnHarrisonsUlp-JuanVuletich-2018Dec11-10h00m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3511] on 12 December 2018 at 12:40:54 pm'! -!ChangeSet class methodsFor: 'change set to use' stamp: 'jmv 12/12/2018 12:22:30' prior: 16799212! - notInstallOrTestRun - - ^Installing isNil or: [ - (Installing beginsWith: 'RunningTest-') and: [ Processor activeProcess name ~= 'TestRunner' ]] - - " - (Installing beginsWith: 'RunningTest-') and: [ Processor activeProcess name = 'TestRunner' ] -> Test - (Installing beginsWith: Install-') -> Install - Installing isNil -> Normal - (Installing beginsWith: 'RunningTest-') and: [ Processor activeProcess name ~= 'TestRunner' ] -> Normal - "! ! -!CodePackageFile methodsFor: 'services' stamp: 'jmv 12/12/2018 12:40:08' prior: 50401559! - install: aFileStream - "Installs the package. Replace all existing code in the CodePackage, removing any code that is not included in us." - | localName newCodePackage pckClass currentCS | - - "Give reasonable warnings if there is stuff that can't be properly cleaned. Give the user the chance to abort." - '=============' print. - classesToRemove notEmpty ifTrue: [ - ('classesToRemove: ', classesToRemove printString) print. - '=============' print ]. - methodsToRemove notEmpty ifTrue: [ - 'methodsToRemove: ' print. - methodsToRemove do: [ :methodReference | methodReference print ]. - '=============' print ]. - - "Tirar warning si hay que borrar cosas que no se puede, si hay referencias, etc. Quizas si vamos a borrar el ultimo implementor de un mensaje enviado?" - - "Create, install and answer a (sub)instance of CodePackage" - localName _ fullName asFileEntry name. - ChangeSet installing: packageName do: [ - "This change set will capture a possible class definition for a subclass of CodePackage. - If it only has that, then remove it after package install. - One example needing this is 'Color-Extras.pck.st'" - currentCS _ ChangeSet changeSetForBaseSystem. - currentCS isEmpty ifFalse: [ currentCS _ nil ]. - pckClass _ CodePackage. - classes do: [ :ee | - (ee hasDefinition and: [ee superclassName = 'CodePackage']) ifTrue: [ - ee fileInDefinitionAndMetaclass. - pckClass _ Smalltalk at: ee name ]]. - newCodePackage _ pckClass - named: packageName - createIfAbsent: true - registerIfNew: true. - newCodePackage - fullFileName: fullName; - sourceSystem: sourceSystem; - description: description; - featureSpec: featureSpec. - aFileStream fileInAnnouncing: 'Installing ', localName, '...'. - methodsToRemove do: [ :methodReference | methodReference actualClass removeSelector: methodReference selector ]. - classesToRemove do: [ :className | (Smalltalk at: className) removeFromSystem ]. - currentCS ifNotNil: [ ChangeSet removeChangeSet: currentCS ]]. - newCodePackage hasUnsavedChanges: false; triggerEvent: #dirtyFlagChanged. - DataStream initialize. "Just in case" - "If we are installing an already installed package, zap the change set with possible changes done, - as they are irrelevant now: we have the package from disk" - ChangeSet removeChangeSet: (ChangeSet existingOrNewChangeSetForPackage: newCodePackage). - Transcript newLine; show: 'Package ', packageName, ' successfully installed'; newLine. - - "Tirar undeclared al transcript. warning si quedaron undeclared - Es feo que tire an transcript undeclareds que despues no lo son..." - Smalltalk cleanOutUndeclared. - Undeclared notEmpty ifTrue: [ - ('Undeclared: ', Undeclared printString) print ]. - - "Descartar la instancia de CodePackageFile" - ^newCodePackage! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3520-AvoidSuperfluousCSOnPackageInstall-JuanVuletich-2018Dec12-12h40m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3520] on 13 December 2018 at 5:20:43 pm'! -!Scanner methodsFor: 'multi-character scans' stamp: 'jmv 12/12/2018 16:22:24' prior: 16904023! - xBinary - - tokenType _ #binary. - token _ String streamContents: [ :stream | - stream nextPut: self step. - [ | type | - type _ self typeTableAt: hereChar. - type == #xBinary and: [hereChar ~= $- or: [aheadChar isDigit not]] - ] whileTrue: [ - stream nextPut: self step]]. - token _ token asSymbol! ! -!Scanner class methodsFor: 'cached class state' stamp: 'jmv 12/12/2018 15:33:25' prior: 50410166! - initTypeTable - | newTable | - newTable := Array new: 256 withAll: #xIllegal. "default" - newTable atAll: #(9 10 12 13 32 ) put: #xDelimiter. "tab lf ff cr space" - - 1 to: 255 - do: [:index | - (Character numericValue: index) isValidInIdentifiers - ifTrue: [ - "Digits and $_ are overwritten later" - newTable at: index put: #xLetter ]]. - - newTable atAll: ($0 numericValue to: $9 numericValue) put: #xDigit. - newTable atAll: '¡!!%&+-*/\±×÷¬­¯,<=>”•–—˜™š›œ«»¿?@~€‚ƒŽ‘’“žŸ°·¢£¤¥µ¶„…§©®¹²³ªº' asByteArray put: #xBinary. - - newTable at: self doItCharacterValue put: #doIt. - newTable at: $" numericValue put: #xDoubleQuote. - newTable at: $# numericValue put: #xLitQuote. - newTable at: $$ numericValue put: #xDollar. - newTable at: $' numericValue put: #xSingleQuote. - newTable at: $` numericValue put: #xBacktick. - newTable at: $: numericValue put: #xColon. - newTable at: $( numericValue put: #leftParenthesis. - newTable at: $) numericValue put: #rightParenthesis. - newTable at: $. numericValue put: #period. - newTable at: $; numericValue put: #semicolon. - newTable at: $[ numericValue put: #leftBracket. - newTable at: $] numericValue put: #rightBracket. - newTable at: ${ numericValue put: #leftBrace. - newTable at: $} numericValue put: #rightBrace. - newTable at: $^ numericValue put: #upArrow. - newTable at: $_ numericValue put: #xUnderscore. - newTable at: $| numericValue put: #verticalBar. - TypeTable := newTable "bon voyage!!" - - " - Scanner initTypeTable - "! ! -!Parser methodsFor: 'private' stamp: 'jmv 12/12/2018 16:17:46' prior: 16885517! - privateReadSelector - | args selector | - doitFlag := false. - - hereType == #word ifTrue: [ - ^ here asSymbol ]. - - self transformVerticalBarAndUpArrowIntoABinarySelector. - - hereType == #binary ifTrue: [ - ^ here asSymbol ]. - - hereType == #keyword ifTrue: [ - selector := WriteStream on: (String new: 32). - args := OrderedCollection new. - [hereType == #keyword] whileTrue: [ - selector nextPutAll: self advance. - args addLast: (encoder bindArg: self argumentName). - ]. - ^ selector contents asSymbol ]. - - ^self expected: 'Message pattern'! ! -!Parser methodsFor: 'scanning' stamp: 'jmv 12/13/2018 17:07:02' prior: 16885783! - transformVerticalBarAndUpArrowIntoABinarySelector - "Transform a vertical bar and or a up arrow into a binary selector. - Eventually aggregate a serie of immediately following vertical bars, up arrows and a binary selector. - Note that this aggregation cannot occur at scan time, because a pair of vertical bars can be encountered in two valid constructs: - - either as an empty temporaries specification, - - or as a local temporaries specification in a block of arity > 0. - Also do the same with some other special characters that are allowed as binary selectors, in addition to their traditional meaning" - | special | - special _ #(verticalBar upArrow). - (special identityIncludes: hereType) ifFalse: [ - ^ self ]. - here := here asString. - hereType := #binary. - [(special identityIncludes: tokenType) and: [hereMark + here size = mark]] - whileTrue: [ - here := here , token asString. - hereEnd := hereEnd + 1. - self scanToken]. - (tokenType == #binary and: [hereMark + here size = mark]) - ifTrue: [ - here := here asString , token. - hereType := #binary. - hereEnd := hereEnd + token size. - self scanToken].! ! -!Parser methodsFor: 'expression types' stamp: 'jmv 12/12/2018 16:17:30' prior: 50409427! - messagePart: level repeat: repeat - - | start receiver selector args precedence words keywordStart | - - [receiver := parseNode. - (hereType == #keyword and: [level >= 3]) - ifTrue: - [start := self startOfNextToken. - selector := WriteStream on: (String new: 32). - args := OrderedCollection new. - words := OrderedCollection new. - [hereType == #keyword] - whileTrue: - [keywordStart := self startOfNextToken + requestorOffset. - selector nextPutAll: self advance. - words addLast: (keywordStart to: self endOfLastToken + requestorOffset). - self primaryExpression ifFalse: [^self expected: 'Argument']. - self messagePart: 2 repeat: true. - args addLast: parseNode]. - (Symbol hasInterned: selector contents ifTrue: [ :sym | selector := sym]) - ifFalse: [ selector := self correctSelector: selector contents - wordIntervals: words - exprInterval: (start to: self endOfLastToken) - ifAbort: [ ^ self fail ] ]. - precedence := 3] - ifFalse: [ - - level >= 2 ifTrue: [self transformVerticalBarAndUpArrowIntoABinarySelector]. - ((hereType == #binary ) - and: [level >= 2]) - ifTrue: - [start := self startOfNextToken. - selector := self advance asSymbol. - words := OrderedCollection with: (start + requestorOffset to: self endOfLastToken + requestorOffset). - self primaryExpression ifFalse: [^self expected: 'Argument']. - self messagePart: 1 repeat: true. - args := Array with: parseNode. - precedence := 2] - ifFalse: [hereType == #word - ifTrue: - [start := self startOfNextToken. - selector := self advance. - args := #(). - words := OrderedCollection with: (start + requestorOffset to: self endOfLastToken + requestorOffset). - (Symbol hasInterned: selector ifTrue: [ :sym | selector := sym]) - ifFalse: [ selector := self correctSelector: selector - wordIntervals: words - exprInterval: (start to: self endOfLastToken) - ifAbort: [ ^ self fail ] ]. - precedence := 1] - ifFalse: [^args notNil]]]. - - parseNode := MessageNode new - receiver: receiver - selector: selector - arguments: args - precedence: precedence - from: encoder - sourceRange: (start to: self endOfLastToken) - keywordsRanges: words. - repeat] - whileTrue: []. - ^true! ! -!Parser methodsFor: 'expression types' stamp: 'jmv 12/12/2018 16:16:14' prior: 50409401! - pattern: fromDoit inContext: ctxt - " unarySelector | binarySelector arg | keyword arg {keyword arg} => - {selector, arguments, precedence}." - - doitFlag := fromDoit. - - fromDoit ifTrue: [^self doitPatternInContext: ctxt ]. - hereType == #word ifTrue: [^self unaryPattern ]. - self transformVerticalBarAndUpArrowIntoABinarySelector. - hereType == #binary ifTrue: [^self binaryPattern ]. - hereType == #keyword ifTrue: [^self keywordPattern ]. - - ^self expected: 'Message pattern' -! ! - -Parser removeSelector: #transformVerticalBarAndUpArrowIntoABinarySelectorIfNecessary! - -Parser removeSelector: #transformVerticalBarAndUpArrowIntoABinarySelectorIfNecessary! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3521-AdditionalPossibleBinarySelectors-JuanVuletich-2018Dec13-17h19m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3521] on 13 December 2018 at 7:37:45 pm'! -!Parser methodsFor: 'scanning' stamp: 'jmv 12/13/2018 19:37:11' prior: 50422199! - transformVerticalBarAndUpArrowIntoABinarySelector - "Transform a vertical bar and or a up arrow into a binary selector. - Eventually aggregate a serie of immediately following vertical bars, up arrows and a binary selector. - Note that this aggregation cannot occur at scan time, because a pair of vertical bars can be encountered in two valid constructs: - - either as an empty temporaries specification, - - or as a local temporaries specification in a block of arity > 0. - Colon $: can be used as binary, but '::' means Chain." - | toMakeBinary | - toMakeBinary _ #(verticalBar upArrow colon). - "Special case: '::' is not a binary selector but the Chain operator" - (hereType = #colon and: [tokenType = #colon]) ifTrue: [^ self ]. - (toMakeBinary identityIncludes: hereType) ifFalse: [ - ^ self ]. - here := here asString. - hereType := #binary. - [(toMakeBinary identityIncludes: tokenType) and: [hereMark + here size = mark]] - whileTrue: [ - here := here , token asString. - hereEnd := hereEnd + 1. - self scanToken]. - (tokenType == #binary and: [hereMark + here size = mark]) - ifTrue: [ - here := here asString , token. - hereType := #binary. - hereEnd := hereEnd + token size. - self scanToken].! ! -!SHParserST80 methodsFor: 'token testing' stamp: 'jmv 12/13/2018 19:37:20' prior: 16902034! - isBinary - | c | - (currentToken isNil or: [self isName or: [self isKeyword]]) - ifTrue: [^false]. - "Special case: '::' is not a binary selector but the Chain operator" - (sourcePosition - currentTokenSourcePosition = 1 and: [ - (source at: currentTokenSourcePosition ifAbsent: nil) = $: and: [ - (source at: sourcePosition ifAbsent: nil) = $: ]]) - ifTrue: [^ false ]. - 1 to: currentToken size do: [ :i | - c := currentToken at: i. - ((self isBinarySelectorCharacter: c) or: [c == $:]) - ifFalse: [^false]]. - ^true! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3522-AllowColonAsBinarySelector-JuanVuletich-2018Dec13-19h33m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3508] on 13 December 2018 at 4:50:45 pm'! - -Object subclass: #StackSizeWatcher - instanceVariableNames: 'watcher timeBetweenChecks stackSizeThreashold delay delayBetweenChecks ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Profiling' -! - -!classDefinition: #StackSizeWatcher category: #'Tools-Profiling'! -Object subclass: #StackSizeWatcher - instanceVariableNames: 'watcher timeBetweenChecks stackSizeThreashold delay delayBetweenChecks' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Profiling'! -!StackSizeWatcher methodsFor: 'configuration changing' stamp: 'HAW 12/13/2018 16:28:08' prior: 50389904! - changeTimeBetweenChecksTo: aTimeBetweenChecks - - "time in milliseconds - Hernan" - - delayBetweenChecks _ Delay forMilliseconds: aTimeBetweenChecks. -! ! -!StackSizeWatcher methodsFor: 'testing' stamp: 'HAW 12/13/2018 16:48:10' prior: 50389935! - shouldStopAndDebug: aProcess - - "Verify the process can be debugged before #isStackTooDeepAt: to avoid - loosing time in #isStackDeeperThan: that is more expensive - Hernan" - - ^(self canDebug: aProcess) and: [self isStackTooDeepAt: aProcess] - -! ! -!StackSizeWatcher methodsFor: 'private' stamp: 'HAW 12/13/2018 16:29:13' prior: 50389971! - watch - - | processToWatch | - - delayBetweenChecks wait. - processToWatch := Processor nextReadyProcess. - (self shouldStopAndDebug: processToWatch) ifTrue: [ self debug: processToWatch ] -! ! -!StackSizeWatcher class methodsFor: 'start/stop' stamp: 'HAW 12/13/2018 16:21:22' prior: 50389999! - isWatching - - ^ current notNil and: [ current isWatching ]! ! - -Object subclass: #StackSizeWatcher - instanceVariableNames: 'watcher stackSizeThreashold delayBetweenChecks' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Profiling' -! - -!classDefinition: #StackSizeWatcher category: #'Tools-Profiling'! -Object subclass: #StackSizeWatcher - instanceVariableNames: 'watcher stackSizeThreashold delayBetweenChecks' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Profiling'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3523-StackSizeWatcher-improvements-HernanWilkinson-2018Dec13-16h20m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3523] on 13 December 2018 at 8:18:41 pm'! -!Debugger methodsFor: 'private' stamp: 'jmv 12/13/2018 20:18:10' prior: 16830176! - resumeProcess - | mustTerminateActive mustRedisplay | - mustRedisplay _ self runningWorld. - savedCursor - ifNotNil: [savedCursor activateCursor]. - mustTerminateActive _ false. - interruptedProcess isTerminated ifFalse: [ - Processor activeProcess animatedUI = interruptedProcessUI ifTrue: [ - interruptedProcess animatedUI: interruptedProcessUI. - mustTerminateActive _ true ]. - interruptedProcess resume ]. - "if old process was terminated, just terminate current one" - interruptedProcess _ nil. - contextStackIndex _ 0. - contextStack _ nil. - contextStackTop _ nil. - receiverInspector _ nil. - contextVariablesInspector _ nil. - mustRedisplay ifNotNil: [ :w | UISupervisor whenUIinSafeState: [ w displayWorld ]]. - "restart low space handler" - Smalltalk installLowSpaceWatcher. - "If this process was the UI process, then it will terminate and never return to caller." - mustTerminateActive - ifTrue: [ Processor terminateActive ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3524-DebuggerResumeRedisplayFix-JuanVuletich-2018Dec13-20h18m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3524] on 14 December 2018 at 3:43:44 pm'! -!Character methodsFor: 'testing' stamp: 'jmv 12/14/2018 15:30:45'! - isValidInBinarySelectors - "Can be part of a binary selector? - $< isValidInBinarySelectors - $| isValidInBinarySelectors - $^ isValidInBinarySelectors - $: isValidInBinarySelectors - " - ^#(verticalBar upArrow xColon xBinary) statePointsTo: (Scanner typeTable at: self numericValue)! ! -!String methodsFor: 'converting' stamp: 'jmv 12/14/2018 15:40:54' prior: 16916666! - findSelector - "Revised to use scanner for better removal of extraneous stuff" - | sel colonIndex | - sel _ self withBlanksTrimmed. - colonIndex _ sel indexOf: $:. - "possible keyword selector" - (colonIndex > 1 and: [ (self at: colonIndex - 1) isLetter ]) ifTrue: [ - sel _ Scanner findSelectorIn: sel ]. - sel isEmpty ifTrue: [ ^ nil ]. - Symbol - hasInterned: sel - ifTrue: [ :aSymbol | - ^ aSymbol ]. - ^ nil.! ! -!String methodsFor: 'converting' stamp: 'jmv 12/14/2018 09:53:01' prior: 16916699! - keywords - "Answer an array of the keywords that compose the receiver." - | kwd char keywords isAllLeters | - keywords _ Array streamContents: [ :kwds | - kwd _ WriteStream on: (String new: 16). - isAllLeters _ true. - 1 - to: self size - do: [ :i | - char _ self at: i. - kwd nextPut: char. - char = $: & isAllLeters - ifTrue: [ - kwds nextPut: kwd contents. - kwd reset. - isAllLeters _ true ] - ifFalse: [ - char isLetter ifFalse: [ isAllLeters _ false ]]]. - kwd isEmpty ifFalse: [ kwds nextPut: kwd contents ]]. - - ^ keywords.! ! -!String methodsFor: 'system primitives' stamp: 'jmv 12/14/2018 15:27:30' prior: 16917278! - 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 start ix | - self size = 0 ifTrue: [ ^ -1 ]. - "Binary messages" - (self allSatisfy: [ :c | c isValidInBinarySelectors ]) - ifTrue: [ ^1 ]. - "Unary and keyword messages" - firstChar _ self at: 1. - firstChar isValidStartOfIdentifiers 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 ]. - ^ -1.! ! -!Symbol methodsFor: 'accessing' stamp: 'jmv 12/14/2018 15:41:59' prior: 16918441! - 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." - - | c | - self size = 0 ifTrue: [^ 0]. - "Consider selectors starting with an underscore $_ as unary, even if Preferences allowUnderscoreSelectors is not set." - c _ self first. - c isValidInBinarySelectors ifTrue: [^ 2]. - self last = $: ifTrue: [^ 3]. - ^ 1! ! -!SHParserST80 methodsFor: 'character testing' stamp: 'jmv 12/14/2018 15:39:18' prior: 50386084! - isBinarySelectorCharacter: aCharacter - aCharacter = $: ifTrue: [^ false]. - ^aCharacter isValidInBinarySelectors! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3525-MiscFixesForColonAsBinarySelector-JuanVuletich-2018Dec14-13h29m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3512] on 17 December 2018 at 10:09:21 am'! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'jmv 12/17/2018 10:09:17' prior: 16923172! - forceChangesToDisk - "Ensure that the changes file has been fully written to disk by closing and re-opening it. This makes the system more robust in the face of a power failure or hard-reboot." - - | changesFile | - "Expensive and not worth doing, esp. in Windows with antivirus active, when installing large packages" - ChangeSet notInstallOrTestRun ifTrue: [ - changesFile _ SourceFiles at: 2. - changesFile isFileStream ifTrue: [ - changesFile flush. - changesFile close. - changesFile open: changesFile name forWrite: true. - changesFile setToEnd. - ]. - ]! ! -!ChangeSet class methodsFor: 'change set to use' stamp: 'jmv 12/17/2018 10:05:42' prior: 16799185! - installing: aCodePackageOrChangeSetName do: aBlock - - | currentCS currentCSNumber newHighestUpdate | - Installing _ 'Install-', aCodePackageOrChangeSetName. - aBlock ensure: [ Installing _ nil ]. - Smalltalk forceChangesToDisk. - - SystemVersion current registerUpdate: aCodePackageOrChangeSetName. - newHighestUpdate _ SystemVersion current highestUpdate. - - currentCSNumber _ self currentBaseCSNumber. - currentCS _ self changeSetForBaseSystem. - currentCS isEmpty ifTrue: [ - ChangeSet removeChangeSet: currentCS. - currentCSNumber > newHighestUpdate ifFalse: [ - CurrentBaseCSNumber _ newHighestUpdate + 1 ]]! ! -!SmalltalkCompleter class methodsFor: 'class initialization' stamp: 'jmv 12/17/2018 10:08:59' prior: 16909373! - addSelector: aSymbol method: aCompiledMethod allImplemented: implemented - - | sentValue value | - self protected: [ - value _ ChangeSet notInstallOrTestRun - ifTrue: [ - "Expensive and not worth doing, esp. in Windows with antivirus active, when installing large packages" - aCompiledMethod dateSortingValue ] - ifFalse: [ 0 ]. - Selectors at: aSymbol put: (value max: (Selectors at: aSymbol ifAbsent: [0])). - aCompiledMethod messages do: [ :sentMsg | - ((Selectors includesKey: sentMsg) or: [ - implemented - ifNotNil: [ implemented includes: sentMsg ] - ifNil: [ Smalltalk isThereAnImplementorOf: sentMsg ]]) - ifTrue: [ - sentValue _ value max: (Selectors at: sentMsg ifAbsent: [0]). - Selectors at: sentMsg put: sentValue ]]]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3526-FasterPackageInstallInWindows-JuanVuletich-2018Dec17-10h04m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3526] on 18 December 2018 at 12:49:31 pm'! -!Color class methodsFor: 'examples' stamp: 'jmv 12/17/2018 16:29:53'! - experimentsTowardsANewColorPalette -" -self experimentsTowardsANewColorPalette -" -| selectedHue selectedSaturation selectedV selectedColor h s v color width height selectedChroma selectedLuminance | -width _ 300. -height _ 120. -selectedColor _ Color random. -selectedHue _ selectedColor hue. -selectedSaturation _ selectedColor saturation. -selectedChroma _ selectedColor chroma. -selectedV _ selectedColor brightness. -selectedLuminance _ selectedColor luminance. -Display getCanvas fillRectangle: (0@0 extent: height@height) color: selectedColor. -0 to: height do: [ :y | - v _ 1.0 - (y / height). - 0 to: height do: [ :x | - s _ x / height. - color _ Color new setHue: selectedHue saturation: s brightness: v. - Display colorAt: x@(y+height) put: color - ]. - DisplayScreen screenUpdateRequired: nil -]. -0 to: height do: [ :y | | c | - v _ 1.0 - (y / height). - s _ 1.0 - (y / height). - c _ s. - 0 to: width do: [ :x | - h _ x / width * 360. - - color _ Color new setHue: h chroma: c luminance: selectedLuminance. -" color _ Color new setHue: h chroma: c brightness: selectedV." - color ifNil: [ color _ Color black ]. -" color _ Color new setHue: h saturation: s brightness: selectedV." - Display colorAt: x+height@y put: color. - - color _ Color new setHue: h chroma: selectedChroma luminance: v. -" color _ Color new setHue: h chroma: selectedChroma brightness: v." - color ifNil: [ color _ Color black ]. -" color _ Color new setHue: h saturation: selectedSaturation brightness: v." - Display colorAt: x+height@(y+height) put: color. - - ]. - DisplayScreen screenUpdateRequired: nil -].! ! - -Color class removeSelector: #experimentsTowarsANewColorPalette! - -Color class removeSelector: #experimentsTowarsANewColorPalette! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3527-Color-tweak-JuanVuletich-2018Dec18-12h49m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3526] on 18 December 2018 at 12:50:08 pm'! -!Number methodsFor: 'comparing' stamp: 'jmv 12/18/2018 09:09:38'! - % another - "Answer the relative distance between two number" - ^ (self - another) abs / (self abs + another abs / 2)! ! -!Float methodsFor: 'truncation and round off' stamp: 'sqr 12/14/2018 23:01:59'! - floatsAwayFrom: aFloat - - | count2 count1 | - (self isNaN or: [ aFloat isNaN ]) ifTrue: [ ^ Float nan ]. - self partBits: [:s :e :m | count2 := (e bitShift: self class precision - 1) + m * (s * -2 + 1)]. - aFloat partBits: [:s :e :m | count1 := (e bitShift: self class precision - 1) + m * (s * -2 + 1)]. - ^count2 - count1! ! -!Float methodsFor: 'comparing' stamp: 'sqr 12/14/2018 23:04:40'! - isWithin: anInteger floatsFrom: aNumber - - ^self floatsAwayFrom: aNumber :: abs <= anInteger! ! -!Float methodsFor: 'mathematical functions' stamp: 'sqr 12/14/2018 23:35:21' prior: 16844641! - degreeCos - "If finite, allow for special values such as cos(60 degrees) = 1/2" - - self isFinite ifTrue: [^super degreeCos]. - ^self degreesToRadians cos! ! -!Float methodsFor: 'mathematical functions' stamp: 'sqr 12/14/2018 23:35:44' prior: 16844648! - degreeSin - "If finite, allow for special values such as cos(30 degrees) = 1/2" - - self isFinite ifTrue: [^super degreeSin]. - ^self degreesToRadians sin! ! -!Interval class methodsFor: 'instance creation' stamp: 'sqr 12/15/2018 00:19:19' prior: 16861321! - from: start to: stop by: step - "Answer an instance of me, starting at start, ending at - stop, and with an interval increment of step. - The actual interval creation uses start, stop and count, to avoid accumulation of rounding errors. - We need to tell apart things like - (0.0 to: 2.4 by: 0.1) the caller wants to honor end - from - (0.0 to: 10.0 by: 3.0) the caller actually wants to end at 9.0. - - Before this, - (0 to: 2.4 by: 0.1) last - used to answer 2.3" - | count end | - count _ stop - start / step + 1. - (count isFloat and: [count isWithin: 5 floatsFrom: count rounded asFloat]) - ifTrue: [ - count _ count rounded. - end _ stop ] - ifFalse: [ - count _ count truncated. - end _ count-1 * step + start ]. - ^self from: start to: end count: count! ! - -Float removeSelector: #closeTo:! - -Float removeSelector: #closeTo:! - -Float removeSelector: #isWithin:ulpsFrom:! - -Float removeSelector: #isWithin:ulpsFrom:! - -Float removeSelector: #reduce! - -Float removeSelector: #reduce! - -Number removeSelector: #closeTo:! - -Number removeSelector: #closeTo:! - -Number removeSelector: #isWithin:ulpsFrom:! - -Number removeSelector: #isWithin:ulpsFrom:! - -Number removeSelector: #reduce! - -Number removeSelector: #reduce! - -Object removeSelector: #closeTo:! - -Object removeSelector: #closeTo:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3528-Numerics-tweaks-JuanVuletich-2018Dec18-12h49m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3526] on 17 December 2018 at 6:04:42 pm'! -!String methodsFor: 'converting' stamp: 'HAW 12/17/2018 18:03:42' prior: 50422549! - keywords - "Answer an array of the keywords that compose the receiver." - | kwd char keywords isAllValidInIdentifiers | - keywords _ Array streamContents: [ :kwds | - kwd _ WriteStream on: (String new: 16). - isAllValidInIdentifiers _ true. - 1 - to: self size - do: [ :i | - char _ self at: i. - kwd nextPut: char. - char = $: & isAllValidInIdentifiers - ifTrue: [ - kwds nextPut: kwd contents. - kwd reset. - isAllValidInIdentifiers _ true ] - ifFalse: [ - char isValidInIdentifiers ifFalse: [ isAllValidInIdentifiers _ false ]]]. - kwd isEmpty ifFalse: [ kwds nextPut: kwd contents ]]. - - ^ keywords.! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3529-FixToColonAsBinarySelector-HernanWilkinson-2018Dec17-18h03m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3529] on 20 December 2018 at 10:58:38 am'! -!ObjectExplorer methodsFor: 'user interface support' stamp: 'jmv 12/20/2018 10:52:46'! - methodNodeOf: aSourceCode ifErrorsParsing: aParsingErrorBlock - - ^aParsingErrorBlock value: nil! ! -!TestResult methodsFor: 'Running' stamp: 'jmv 12/20/2018 10:58:20' prior: 16927991! - runCase: aTestCase - - | testCasePassed | - - testCasePassed _ - [ - [ - Transcript show: 'Will run: '; print: aTestCase; newLine. - aTestCase runCase. - Transcript show: 'finished.'; newLine. - true] - on: self class failure - do: [ :signal | - Transcript print: signal; newLine. - (self failures isEmpty or: [ (failures last == aTestCase) not ]) - ifTrue: [ failures add: aTestCase ]. - signal sunitExitWith: false ]] - on: self class error - do: [ :signal | - Transcript print: signal; newLine. - aTestCase errored: signal. - self errors add: aTestCase. - signal sunitExitWith: false ]. - - testCasePassed - ifTrue: [ self passed add: aTestCase ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3530-FixImplementorsInExplorer-LogTestInfoToTranscript-JuanVuletich-2018Dec20-10h50m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3529] on 20 December 2018 at 11:08:36 am'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 12/20/2018 11:07:32'! - storeOn: aStream - self == Smalltalk ifTrue: [ - ^ aStream nextPutAll: 'Smalltalk']. - ^ super storeOn: aStream! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3531-FixInfiniteRecursionOnDecompilingSmalltalkRefs-JuanVuletich-2018Dec20-10h58m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3529] on 20 December 2018 at 11:16:32 am'! -!FileIOAccessor methodsFor: 'private' stamp: 'pb 5/25/2016 00:32' prior: 50413545! - basicDirectoryExists: fullPathName - - | result | - result := self primLookupEntryIn: fullPathName index: 1. - ^(result == #badDirectoryPath) not! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3532-EmptyDirectoryDoesExist-JuanVuletich-2018Dec20-11h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3529] on 19 December 2018 at 6:02:57 pm'! - -SmallInteger removeSelector: #instVarAt:! - -SmallInteger removeSelector: #instVarAt:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3533-RemoveSmallIntegerInstVarAt-JuanVuletich-2018Dec19-18h02m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3533] on 21 December 2018 at 7:33:06 am'! -!Number methodsFor: 'arithmetic' stamp: 'jmv 12/20/2018 16:59:41'! - ^ another - "Covenient, usual idiom. - 2 ^ 8 - " - ^ self raisedTo: another! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3534-CaretAsRaisedTo-JuanVuletich-2018Dec21-07h32m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3533] on 21 December 2018 at 7:39:11 am'! -!Number methodsFor: 'printing' stamp: 'jmv 12/20/2018 17:54:18' prior: 16880287! -printOn: aStream fractionDigits: placesDesired - "Print a representation of the receiver on aStream in decimal notation with prescribed number of places after decimal separator." - - | rounder rounded roundedFractionPart | - placesDesired > 0 ifFalse: [ ^ self rounded printOn: aStream ]. - rounder _ 10 raisedToInteger: placesDesired. - rounded _ self roundTo: rounder reciprocal. - rounded negative ifTrue: [ aStream nextPut: $- ]. - rounded _ rounded abs. - rounded integerPart truncated printOn: aStream. - aStream nextPut: $.. - roundedFractionPart _ (rounded fractionPart * rounder) truncated. - roundedFractionPart - printOn: aStream - base: 10 - length: placesDesired - padded: true! ! -!Number methodsFor: 'printing' stamp: 'jmv 12/20/2018 16:30:54' prior: 16880311! - printOn: aStream integerDigits: placesLeftOfFractionPoint fractionDigits: placesRightOfFractionPoint - "placesLeftOfFractionPoint is the minimum to be used (use more if required) - placesRightOfFractionPoint is strict. Add extra zeros or round as appropriate." - " - String streamContents: [ :strm | 23 printOn: strm integerDigits: 3 fractionDigits: 5 ] - String streamContents: [ :strm | 1.23 printOn: strm integerDigits: 3 fractionDigits: 5 ] - String streamContents: [ :strm | 123456.23 printOn: strm integerDigits: 3 fractionDigits: 5 ] - String streamContents: [ :strm | Float pi printOn: strm integerDigits: 3 fractionDigits: 5 ] - String streamContents: [ :strm | Float nan printOn: strm integerDigits: 3 fractionDigits: 5 ] - String streamContents: [ :strm | Float infinity printOn: strm integerDigits: 3 fractionDigits: 5 ] - String streamContents: [ :strm | Float negativeInfinity printOn: strm integerDigits: 3 fractionDigits: 5 ] - String streamContents: [ :strm | Float zero printOn: strm integerDigits: 3 fractionDigits: 5 ] - " - - ^self printOn: aStream integerDigits: placesLeftOfFractionPoint padWith: nil fractionDigits: placesRightOfFractionPoint positiveIndicator: nil! ! -!Float methodsFor: 'printing' stamp: 'jmv 12/21/2018 07:38:12' prior: 16845543! - printOn: aStream fractionDigits: placesDesired - "This implementation avoids any rounding error caused by rounded or roundTo: - The approach is simple. Round to appropriate integer, take the digits, and just - add the decimal point in the appropriate place." - - | i s scaled | - self isFinite ifFalse: [ ^self printOn: aStream ]. - - placesDesired > 0 ifFalse: [ - ^self rounded printOn: aStream ]. - - scaled _ self * (10 raisedTo: placesDesired). - "If rounding could possible print a sequence that is read back as a different float, then go the more expensive Fraction way. - If the following line is commented, #testPrintShowingDecimalPlaces4 will fail!!" - scaled ulp > 1 ifTrue: [ - ^ self asTrueFraction printOn: aStream fractionDigits: placesDesired ]. - i _ scaled rounded. - i negative ifTrue: [ - aStream nextPut: $-. - i _ i negated ]. - s _ i printString. - placesDesired + 1 > s size - ifTrue: [ - aStream nextPutAll: '0.'. - placesDesired - s size timesRepeat: [ aStream nextPut: $0 ]. - aStream nextPutAll: s ] - ifFalse: [ - aStream - nextPutAll: (s copyFrom: 1 to: s size-placesDesired); - nextPut: $.; - nextPutAll: (s copyFrom: s size-placesDesired+1 to: s size) ]! ! -!Fraction methodsFor: 'printing' stamp: 'jmv 12/20/2018 17:54:02' prior: 16849803! - printOn: aStream fractionDigits: placesDesired - "Same as super, but provides a faster implementation by inlining some Fraction protocol thus avoiding intermediate Fraction creation." - - | roundedFractionPart integerPart scaling | - placesDesired > 0 - ifFalse: [self rounded printOn: aStream] - ifTrue: [ - scaling := 10 raisedToInteger: placesDesired. - integerPart := numerator abs quo: denominator. - roundedFractionPart := (numerator abs - (integerPart * denominator)) * scaling * 2 + denominator quo: denominator * 2. - roundedFractionPart = scaling - ifTrue: - [integerPart := integerPart + 1. - roundedFractionPart := 0]. - "Don't print minus sign if result is rouded to zero" - (numerator negative and: [integerPart > 0 or: [roundedFractionPart > 0]]) ifTrue: [aStream nextPut: $-]. - integerPart printOn: aStream. - aStream nextPut: $.. - roundedFractionPart printOn: aStream base: 10 length: placesDesired padded: true].! ! -!Integer methodsFor: 'printing' stamp: 'jmv 12/20/2018 17:54:47' prior: 16859997! - printOn: aStream fractionDigits: placesDesired - "Same as super, but provides a faster implementation because fraction part and rounding are trivial." - - self printOn: aStream base: 10. - - placesDesired > 0 - ifTrue: [ - aStream nextPut: $.. - placesDesired timesRepeat: [ - aStream nextPut: $0 ]]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3535-printOnFractionDigits-fix-JuanVuletich-2018Dec21-07h33m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3537] on 21 December 2018 at 2:50:39 pm'! -!Editor class methodsFor: 'help' stamp: 'jmv 12/21/2018 10:14:26' prior: 50405350! - help - " - TextEditor help edit - SmalltalkEditor help edit - " - | allSpecs | - allSpecs _ self cmdShortcutsSpec, self basicCmdShortcutsSpec. - ^String streamContents: [ :strm | - allSpecs do: [ :triplet | | c | - c _ triplet first = Character space - ifFalse: [ triplet first asString, ' ' ] - ifTrue: [ 'Space']. - strm nextPutAll: ('Cmd-', c, String tab, String tab, triplet third). - strm newLine ]]! ! -!TextEditor class methodsFor: 'keyboard shortcut tables' stamp: 'jmv 12/21/2018 14:43:04' prior: 50383120! - basicCmdShortcutsSpec - " - Editor initialize - " - - "arranged in QWERTY keyboard order" - ^#( - #( $( #enclose: 'Enclose within ( and ), or remove enclosing ( and )') - #( $[ #enclose: 'Enclose within [ and ], or remove enclosing [ and ]') - #( ${ #enclose: 'Enclose within { and }, or remove enclosing { and }') - #( $' #enclose: 'Enclose within single quotes, or remove enclosing single quotes') - #( $" #enclose: 'Enclose within double quotes, or remove enclosing double quotes') - #( $` #enclose: 'Enclose within backticks, or remove enclosing backticks') - #( $< #enclose: 'Enclose within < and >, or remove enclosing < and >') - - #( $a #selectAll: 'Select all') - #( $f #find: 'Find') - #( $g #findAgain: 'Find again') - #( $h #help: 'Open this help') - #( $j #setSearchString: 'Set selection as search string for find again') - - #( $z #undo: 'Undo (multiple levels)') - #( $x #cut: 'Cut selection and store it in the Clipboard') - #( $c #copySelection: 'Copy selection to the Clipboard') - #( $v #paste: 'Paste Clipboard contents') - - #( $R #indent: 'Indent (same as [Tab], move selection one tab-stap right)') - #( $Y #makeUppercase: 'Force selection to uppercase') - #( $U #changeLineEndsToLf: 'Convert line endings to LF characters (Cuis convention) in selection') - - #( $H #cursorTopHome: 'Move cursor to start of text') - #( $L #outdent: 'Outdent (same as [Shift][Tab], move selection one tab-stop left)') - - #( $Z #redo: 'Redo (multiple levels)') - #( $X #makeLowercase: 'Force selection to lowercase') - #( $C #compareToClipboard: 'Compare argument to clipboard') - - #( $ #selectWord: 'Select the current word as with double clicking') - )! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3536-EditorHelpTweaks-JuanVuletich-2018Dec21-14h50m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3538] on 21 December 2018 at 2:53:25 pm'! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 12/21/2018 11:06:01' prior: 50420458! - expNonPrimitive - "Answer e raised to the receiver power." - - | base fract correction delta div | - - "Taylor series" - "check the special cases" - self < 0.0 ifTrue: [^ (self negated exp) reciprocal]. - self = 0.0 ifTrue: [^ 1]. - self abs > MaxValLn ifTrue: [self error: 'exp overflow']. - - "get first approximation by raising e to integer power" - base _ E raisedToInteger: (self truncated). - - "now compute the correction with a short Taylor series" - "fract will be 0..1, so correction will be 1..E" - "in the worst case, convergance time is logarithmic with 1/Epsilon" - fract _ self fractionPart. - fract = 0.0 ifTrue: [ ^ base ]. "no correction required" - - correction _ 1.0 + fract. - delta _ fract * fract / 2.0. - div _ 2.0. - [delta >= base ulp] whileTrue: [ - correction _ correction + delta. - div _ div + 1.0. - delta _ delta * fract / div]. - correction _ correction + delta. - ^ base * correction! ! -!Float methodsFor: 'converting' stamp: 'jmv 12/21/2018 11:12:14' prior: 50421730! - partBits: aThreeArgumentBlock - " - Extract the bits for Sign, Mantissa and Exponent parts of the Floating Point representation. - Just extract the bits. Do not add implicit bit. Do not correct denormals. Do not subtract exponent bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. (f signPart * f significandAsInteger * (2 raisedToInteger: f exponentPart-52)) asFloat = f } print ]. - " - | signBit exponentBits mantissaBits leastSignificativeWord mostSignificativeWord | - - mostSignificativeWord _ self basicAt: 1. - leastSignificativeWord _ self basicAt: 2. - signBit _ mostSignificativeWord bitShift: -31 . - exponentBits _ (mostSignificativeWord bitShift: -20 ) bitAnd: 16r7FF. - mantissaBits _ ((mostSignificativeWord bitAnd: 16r000FFFFF) bitShift: 32) + leastSignificativeWord. - - "Evaluate the block" - ^aThreeArgumentBlock value: signBit value: exponentBits value: mantissaBits! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/21/2018 11:12:06' prior: 50421866! - exponentBits - " - Actual bits for the exponent part of the Floating Point representation. - Just extract the bits. Do not correct denormals. Do not subtract bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - { f. f exponentBits. f exponentPart. f exponent } print ]. - " - - ^ self partBits: [ :signBit :exponentBits :mantissaBits | exponentBits ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/21/2018 11:12:10' prior: 50421883! - mantissaBits - " - Actual bits for the mantissa part of the Floating Point representation. - Just extract the bits. Do not correct denormals. Do not subtract bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - { f. f mantissaBits. f mantissaPart. f significand. } print ]. - " - ^ self partBits: [ :signBit :exponentBits :mantissaBits | mantissaBits ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/21/2018 11:12:18' prior: 50421939! - signBit - " - Actual bits for the exponent part of the Floating Point representation. - Just extract the bits. Do not correct denormals. Do not subtract bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0. 0.0. -0.0} do: [ :f | - { f. f signBit. f signPart. f sign } print ]. - " - - ^ self partBits: [ :signBit :exponentBits :mantissaBits | signBit ]! ! -!Float class methodsFor: 'constants' stamp: 'jmv 12/21/2018 11:02:26' prior: 16845865! - e - "Answer the constant, e." - - ^E! ! -!Float class methodsFor: 'constants' stamp: 'jmv 12/21/2018 12:54:06' prior: 16845869! - emax - "Answer exponent of the maximal representable value" - - ^1023! ! -!Float class methodsFor: 'constants' stamp: 'jmv 12/21/2018 12:54:26' prior: 50421987! - epsilon - "Answer the difference between 1.0 and the next representable value. - Note: does not equal 1.0 ulp." - - ^1.0 successor - 1.0! ! -!BoxedFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 12/21/2018 11:04:53' prior: 50420643! - exp - "Answer e raised to the receiver power. - Optional. See Object documentation whatIsAPrimitive." - - - ^ self expNonPrimitive! ! -!SmallFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 12/21/2018 11:05:17' prior: 50420680! - exp - "Answer e raised to the receiver power. - Optional. See Object documentation whatIsAPrimitive." - - - ^ self expNonPrimitive! ! -!Fraction methodsFor: 'printing' stamp: 'jmv 12/21/2018 11:15:47' prior: 50423098! - printOn: aStream fractionDigits: placesDesired - "Same as super, but provides a faster implementation by inlining some Fraction protocol thus avoiding intermediate Fraction creation." - - | roundedFractionPart integerPart scaling | - placesDesired > 0 - ifFalse: [self rounded printOn: aStream] - ifTrue: [ - scaling := 10 raisedToInteger: placesDesired. - integerPart := numerator abs quo: denominator. - roundedFractionPart := (numerator abs - (integerPart * denominator)) * scaling * 2 + denominator quo: denominator * 2. - roundedFractionPart = scaling - ifTrue: - [integerPart := integerPart + 1. - roundedFractionPart := 0]. - "Don't print minus sign if result is rounded to zero" - (numerator negative and: [integerPart > 0 or: [roundedFractionPart > 0]]) ifTrue: [aStream nextPut: $-]. - integerPart printOn: aStream. - aStream nextPut: $.. - roundedFractionPart printOn: aStream base: 10 length: placesDesired padded: true].! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3537-FixTyposInNumerics-JuanVuletich-2018Dec21-14h52m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3535] on 21 December 2018 at 9:18:35 am'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 12/21/2018 09:18:25' prior: 50418196! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('AY' 'Angel Yan') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('FJG' 'Facundo Javier Gelatti') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3538-AddAngelAsKnownAuthor-JuanVuletich-2018Dec21-09h18m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3538] on 21 December 2018 at 3:11:09 pm'! -!TextEditor methodsFor: 'editing keys' stamp: 'AY 12/17/2018 17:05:42'! - tabKey: aKeyboardEvent - "Add/remove a tab at the front of every line occupied by the selection if there is one; treat as a normal character otherwise." - - aKeyboardEvent shiftPressed - ifTrue: [ ^ self outdent: aKeyboardEvent ]. - - ^ self hasSelection - ifTrue: [ self indent: aKeyboardEvent ] - ifFalse: [ self normalCharacter: aKeyboardEvent ]! ! -!TextEditor class methodsFor: 'class initialization' stamp: 'AY 12/21/2018 13:10:43'! - initializeShortcuts - - super initializeShortcuts. - shortcuts at: 9 + 1 put: #tabKey:.! ! -!TextEditor class methodsFor: 'keyboard shortcut tables' stamp: 'jmv 12/21/2018 08:09:38' prior: 50423168! - basicCmdShortcutsSpec - " - Editor initialize - " - - "arranged in QWERTY keyboard order" - ^#( - #( $( #enclose: 'Enclose within ( and ), or remove enclosing ( and )') - #( $[ #enclose: 'Enclose within [ and ], or remove enclosing [ and ]') - #( ${ #enclose: 'Enclose within { and }, or remove enclosing { and }') - #( $' #enclose: 'Enclose within single quotes, or remove enclosing single quotes') - #( $" #enclose: 'Enclose within double quotes, or remove enclosing double quotes') - #( $` #enclose: 'Enclose within backticks, or remove enclosing backticks') - #( $< #enclose: 'Enclose within < and >, or remove enclosing < and >') - - #( $a #selectAll: 'Select all') - #( $f #find: 'Find') - #( $g #findAgain: 'Find again') - #( $h #help: 'Open this help') - #( $j #setSearchString: 'Set selection as search string for find again') - - #( $z #undo: 'Undo (multiple levels)') - #( $x #cut: 'Cut selection and store it in the Clipboard') - #( $c #copySelection: 'Copy selection to the Clipboard') - #( $v #paste: 'Paste Clipboard contents') - - #( $R #indent: 'Indent (move selection one tab-stap right)') - #( $Y #makeUppercase: 'Force selection to uppercase') - #( $U #changeLineEndsToLf: 'Convert line endings to LF characters (Cuis convention) in selection') - - #( $H #cursorTopHome: 'Move cursor to start of text') - #( $L #outdent: 'Outdent (move selection one tab-stop left)') - - #( $Z #redo: 'Redo (multiple levels)') - #( $X #makeLowercase: 'Force selection to lowercase') - #( $C #compareToClipboard: 'Compare argument to clipboard') - - #( $ #selectWord: 'Select the current word as with double clicking') - )! ! -!Morph methodsFor: 'events-processing' stamp: 'jmv 12/21/2018 09:21:39' prior: 16874864! - focusKeyboardFor: aKeyboardEvent - - "If aKeyboardEvent ctrl-tab or shift-ctrl-tab use it to navigate keyboard focus. - Warning: This doesn't work on Windows... the event is not sent" - (aKeyboardEvent keyValue = 9 and: [ aKeyboardEvent controlKeyPressed and: [ aKeyboardEvent rawMacOptionKeyPressed not ]]) - ifTrue: [ - aKeyboardEvent shiftPressed - ifTrue: [ aKeyboardEvent hand keyboardFocusPrevious ] - ifFalse: [ aKeyboardEvent hand keyboardFocusNext ]. - ^ true ]. - "On Windows use at least some keystroke to navigate morphs... even shift-Tab that should navigate backwards" -" - (aKeyboardEvent keyValue = 9 and: [ aKeyboardEvent shiftPressed and: [ aKeyboardEvent rawMacOptionKeyPressed not ]]) - ifTrue: [ - aKeyboardEvent hand keyboardFocusNext. - ^ true ]. -" - - "Cycle through windows with cmdAlt + < and cmdAlt + >. - VM and platform peculiarities are hidden in #isCmdAltLessThan and #isCmdAltGreaterThan" - "This was done as an attempt to mimic the Mac OSX keystrokes for 'Move focus to next window in active application'. Unfortunately, it only works if OS X is set to use any other keys for this. If (as for example, with German defaults), OS-X uses these keystrokes, then they are not sent to the VM. This is a long standing issues in Chromium and PhotoShop, for example..." - self disableCode: [ - aKeyboardEvent isCmdAltLessThan ifTrue: [ - aKeyboardEvent hand activatePreviousWindow. - ^true ]. - aKeyboardEvent isCmdAltGreaterThan ifTrue: [ - aKeyboardEvent hand activateNextWindow. - ^true ]]. - "Alternative for Mac OS-X: option-Tab and option-shift-Tab" - (aKeyboardEvent keyValue = 9 and: [ aKeyboardEvent rawMacOptionKeyPressed ]) - ifTrue: [ - aKeyboardEvent shiftPressed - ifTrue: [ aKeyboardEvent hand activatePreviousWindow ] - ifFalse: [ aKeyboardEvent hand activateNextWindow ]. - ^ true ]. - "Alternative for non-Mac OS-X: alt-< and alt->" - (aKeyboardEvent commandAltKeyPressed and: [ aKeyboardEvent keyCharacter = $< ]) ifTrue: [ - aKeyboardEvent hand activatePreviousWindow. - ^true ]. - (aKeyboardEvent commandAltKeyPressed and: [ aKeyboardEvent keyCharacter = $> ]) ifTrue: [ - aKeyboardEvent hand activateNextWindow. - ^true ]. - ^false! ! -!HandMorph methodsFor: 'private events' stamp: 'jmv 12/21/2018 09:28:14' prior: 50374900! - generateKeyboardEvent: evtBuf - "Generate the appropriate mouse event for the given raw event buffer" - | buttons modifiers type keyValue pressType stamp | - stamp _ evtBuf second. - stamp = 0 ifTrue: [ stamp _ Time localMillisecondClock ]. - (evtBuf sixth <= 0 or: [ (keyValue _ Character iso8859s15CodeForUnicodeCodePoint: evtBuf sixth) isNil ]) ifTrue: [ keyValue _ Character macRomanToLatin1: evtBuf third ]. - Sensor peekEvent ifNotNil: [ :nxt | - "start: Combining diacritical marks (i.e. accents in the Linux VM)" - (nxt fourth = EventSensor eventKeyDown and: [ nxt third > 255 ]) ifTrue: [ - keyValue _ ((Character numericValue: keyValue) withDiacriticalMark: nxt third) iso8859s15Code. - Sensor - nextEvent; - nextEvent; - nextEvent ]. - "end: Combining diacritical marks (i.e. accents in the Linux VM)" - "start: Spurious LF after CR on Ctrl-Enter on Windows VM" - ((evtBuf fourth = EventSensor eventKeyChar and: [ evtBuf third = 13 ]) and: [ - nxt fourth = EventSensor eventKeyChar and: [ nxt third = 10 ]]) ifTrue: [ Sensor nextEvent - "print " ]]. - modifiers _ evtBuf fifth. - pressType _ evtBuf fourth. - pressType = EventSensor eventKeyDown ifTrue: [ - type _ #keyDown. - lastKeyDownValue _ keyValue ]. - pressType = EventSensor eventKeyUp ifTrue: [ - (keyValue = 9 and: [(modifiers anyMask: 1) and: [Smalltalk platformName = 'unix']]) - ifTrue: [ - "Linux VMs don't generate shift-tab keystroke. Turn #keyUp into #keystroke" - pressType _ EventSensor eventKeyChar ] - ifFalse: [type _ #keyUp ]]. - pressType = EventSensor eventKeyChar ifTrue: [ - type _ #keystroke. - "If Control key pressed, and the VM answers a code below 27, - it means it did the translation, convert it back to regular character: - We want to handle the meaning of ctrl ourselves." - (modifiers anyMask: 2) ifTrue: [ - "Control key pressed" - keyValue < 27 ifTrue: [ - "But we don't want to do it for Home/End/PgUp/PgDn, just for alphabetic keys" - lastKeyDownValue = keyValue ifFalse: [ - "If equal, real Home/End/PgUp/PgDn in Windows => don't translate" - (keyValue + 64 = lastKeyDownValue or: [ "If Equal, Ctrl-alphabetic in Windows => do translate" - lastKeyDownValue < 47 ]) ifTrue: [ - "Not on windows. If less (not sure about the bound, but do not translate 48: tab on Mac), alphabetic on Mac => do translate" - keyValue _ (modifiers anyMask: 1) - ifTrue: [ keyValue + 64 ] - ifFalse: [ keyValue + 96 - "shift not pressed: conver to lowercase letter" ]]]]. - "Act as if command/alt was pressed for some usual Windows ctrl-key combinations" - (self shouldControlEmulateAltFor: keyValue) ifTrue: [ modifiers _ modifiers bitOr: 8 ]]]. - buttons _ modifiers bitShift: 3. - ((modifiers anyMask: 2) and: [ - keyValue - between: (Preferences ctrlArrowsScrollHorizontally ifTrue: [28] ifFalse: [30]) - and: 31]) - ifTrue: [ "We're hijacking ctl-up/down arrow since that is what the VM sends us for scroll events. We're going to convert these to MouseScrollEvent and throw away the keyboard event" - "ThisPrecludes the use of up and down arrows with control, that are standard keystrokes in Windows to control the cursor. - But as Linux, Mac and Windows VMs generate ctrl-up and ctrl-down for mouse wheel events, we must honor them. - Some day, it would be good for the VMs to report mouse wheel events differently fom ctrl-up & ctrl-down..." - "Also do ctrl-left and ctrl-right for horizontal scroll." - ^ MouseScrollEvent new - setType: #mouseScroll - position: self morphPosition - direction: - (keyValue caseOf: { - "Implementing as a caseof to allow for easy adding of left/right/other events should they become available" - [ 30 ] -> [ #up ]. - [ 31 ] -> [ #down ]. - [ 28 ] -> [ #left ]. - [ 29 ] -> [ #right ]. - }) - buttons: buttons - hand: self - stamp: stamp ] - ifFalse: [ ^ KeyboardEvent new - setType: type - buttons: buttons - position: self morphPosition - keyValue: keyValue - hand: self - stamp: stamp ].! ! -!AutoCompleter methodsFor: 'keyboard - private' stamp: 'AY 12/17/2018 16:57:52' prior: 50414919! - shouldOpenMorph - - | currentPos currentChar | - - textMorph editor hasSelection ifTrue: [ ^ false ]. - - currentPos _ textMorph editor startIndex-1. - currentPos <= 0 ifTrue: [ ^ false ]. - currentChar _ model actualContents at: currentPos. - - ^ currentChar = Character space - ifTrue: [ self shouldOpenMorphWhenNoPrefixAt: currentPos-1 ] - ifFalse: [ self shouldOpenMorphWhenPrefixAt: currentPos and: currentChar ].! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Editor initialize! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3539-TabShiftTabToIndentOutdent-AngelYan-2018Dec21-15h06m-AY.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3526] on 19 December 2018 at 7:42:39 pm'! -!SystemDictionary methodsFor: 'testing' stamp: 'HAW 12/19/2018 16:09:00'! - isLiveTypeInformationInstalled - - ^(FeatureRequirement name: #LiveTypeInformation) isAlreadySatisfied! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 12/19/2018 19:41:54'! -returnTypeOfEnclosedExpressionAt: aRange - - Smalltalk isLiveTypeInformationInstalled ifFalse: [ ^nil ]. - - ^self - withParserSourceMethodNodeDo: [ :methodNode | self returnTypeOfEnclosedExpresionIn: methodNode at: aRange end ] - ifError: [ :anError | nil ]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 12/19/2018 16:43:55'! - returnTypeOfUnaryMessage: aSelector at: aRange - - Smalltalk isLiveTypeInformationInstalled ifFalse: [ ^nil ]. - - ^self - withParserSourceMethodNodeDo: [ :methodNode | self returnTypeOfNodeUnderCursorIn: methodNode at: aRange end] - ifError: [ :anError | nil ]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 12/19/2018 16:18:52'! -withParserSourceMethodNodeDo: doBlock ifError: anErrorBlock - - ^ [[ doBlock value: (parser classOrMetaClass methodNodeFor: parser source) ] - on: UndeclaredVariableReference - do: [ :anUndeclareVariableReference | anUndeclareVariableReference declareTempAndResume ]] - on: Error - do: anErrorBlock - - ! ! -!UndeclaredVariableReference methodsFor: 'handling' stamp: 'HAW 12/19/2018 19:34:38'! - declareTempAndResume - - parser declareTemp: varName at: #method. - self resume: varName! ! -!UndeclaredVariableReference methodsFor: 'handling' stamp: 'HAW 12/19/2018 19:34:42' prior: 16939960! - defaultAction - - ^parser correctVariable: varName interval: (varStart to: varEnd)! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 12/18/2018 19:03:40' prior: 50419502! - parseNodeIncluding: aPosition ifAbsent: aBlockClosure - - | smallestRangeSize nodeWithRangeAtPosition | - - smallestRangeSize := SmallInteger maxVal. - nodeWithRangeAtPosition := nil. - - sourceRanges associationsDo: [ :nodeAtRange | - self withRangesOf: nodeAtRange including: aPosition do: [ :aRange | | currentNodeRangeSize | - currentNodeRangeSize := aRange size. - currentNodeRangeSize < smallestRangeSize ifTrue: [ - smallestRangeSize := currentNodeRangeSize. - nodeWithRangeAtPosition := nodeAtRange key -> aRange ]]]. - - ^ nodeWithRangeAtPosition ifNil: aBlockClosure ifNotNil: [ nodeWithRangeAtPosition ] - ! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 12/18/2018 19:04:26' prior: 50419537! - parseNodeIncluding: aPosition ifAbsent: aBlockClosure - - ^encoder parseNodeIncluding: aPosition ifAbsent: aBlockClosure -! ! -!AutoCompleter methodsFor: 'keyboard - private' stamp: 'HAW 12/18/2018 18:41:14' prior: 50417238! -shouldOpenMorphWhenNoPrefixFor: currentChar - - ^currentChar isAlphaNumeric - or: [ currentChar isRightBracket - or: [ currentChar = $) ]]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 12/19/2018 19:41:54' prior: 50417278! - computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel - - | id receiverClassOrEntries | - - id _ allSource copyFrom: range start to: range end. - receiverClassOrEntries _ range rangeType - caseOf: { - [ #globalVar ] -> [ (Smalltalk at: id asSymbol) class ]. - [ #self ] -> [ contextClass ]. - [ #super ] -> [ contextClass superclass ]. - [ #true ] -> [ True ]. - [ #false ] -> [ False ]. - [ #nil ] -> [ UndefinedObject ]. - [ #character ] -> [ id first class ]. - [ #number ] -> [ self classOfLiteral: id in: contextClass ]. - [ #string ] -> [ self classOfLiteral: id in: contextClass ]. - [ #symbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #stringSymbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #instVar ] -> [ specificModel classOfInstVarNamed: id ]. - [ #methodArg ] -> [ specificModel classOfTempVarNamed: id ]. - [ #tempVar ] -> [ specificModel classOfTempVarNamed: id ]. - [ #workspaceVar ] -> [ specificModel classOfWorkspaceVarNamed: id ]. - [ #blockArg ] -> [ specificModel classOfBlockArgNamed: id ]. - [ #blockTempVar ] -> [ specificModel classOfBlockTempVarNamed: id ]. - [ #thisContext ] -> [ specificModel classOfThisContext ]. - [ #classVar ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #poolConstant ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #blockEnd ] -> [ BlockClosure ]. - [ #unary ] -> [ self returnTypeOfUnaryMessage: id at: range ]. - [ #rightParenthesis ] -> [ self returnTypeOfEnclosedExpressionAt: range ]. } - otherwise: [ nil ]. - - receiverClassOrEntries isCollection - ifTrue: [ - receiverClassOrEntries isEmpty - ifTrue: [ self computeMessageEntries: nil ] - ifFalse: [ entries _ receiverClassOrEntries asArray sort ]] - ifFalse: [ self computeMessageEntries: receiverClassOrEntries ]! ! -!SHParserST80 methodsFor: 'accessing' stamp: 'HAW 12/19/2018 16:10:09'! - classOrMetaClass - - ^classOrMetaClass! ! - -MethodNode removeSelector: #topParseNodeIncluding:ifAbsent:! - -Encoder removeSelector: #topParseNodeIncluding:ifAbsent:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3540-AutoCompleteImprovements-HernanWilkinson-2018Dec18-18h31m-HAW.4.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3526] on 20 December 2018 at 9:43:37 am'! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 12/20/2018 09:41:03'! - computeMessageEntriesForSelectors: selectors - - selectors isEmpty - ifTrue: [ self computeMessageEntries: nil ] - ifFalse: [ | prefixedSelectors | - prefixedSelectors := selectors select: [ :aSelector | aSelector beginsWith: prefix ]. - entries _ prefixedSelectors asArray sort ]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 12/20/2018 09:38:26' prior: 50424030! - computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel - - | id receiverClassOrEntries | - - id _ allSource copyFrom: range start to: range end. - receiverClassOrEntries _ range rangeType - caseOf: { - [ #globalVar ] -> [ (Smalltalk at: id asSymbol) class ]. - [ #self ] -> [ contextClass ]. - [ #super ] -> [ contextClass superclass ]. - [ #true ] -> [ True ]. - [ #false ] -> [ False ]. - [ #nil ] -> [ UndefinedObject ]. - [ #character ] -> [ id first class ]. - [ #number ] -> [ self classOfLiteral: id in: contextClass ]. - [ #string ] -> [ self classOfLiteral: id in: contextClass ]. - [ #symbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #stringSymbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #instVar ] -> [ specificModel classOfInstVarNamed: id ]. - [ #methodArg ] -> [ specificModel classOfTempVarNamed: id ]. - [ #tempVar ] -> [ specificModel classOfTempVarNamed: id ]. - [ #workspaceVar ] -> [ specificModel classOfWorkspaceVarNamed: id ]. - [ #blockArg ] -> [ specificModel classOfBlockArgNamed: id ]. - [ #blockTempVar ] -> [ specificModel classOfBlockTempVarNamed: id ]. - [ #thisContext ] -> [ specificModel classOfThisContext ]. - [ #classVar ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #poolConstant ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #blockEnd ] -> [ BlockClosure ]. - [ #unary ] -> [ self returnTypeOfUnaryMessage: id at: range ]. - [ #rightParenthesis ] -> [ self returnTypeOfEnclosedExpressionAt: range ]. } - otherwise: [ nil ]. - - receiverClassOrEntries isCollection - ifTrue: [ self computeMessageEntriesForSelectors: receiverClassOrEntries ] - ifFalse: [ self computeMessageEntries: receiverClassOrEntries ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3541-AutoCompleterSmallEnh-HernanWilkinson-2018Dec19-19h45m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3526] on 20 December 2018 at 3:12:35 pm'! - -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser ' - classVariableNames: 'AccessLock Selectors EntriesLimit ' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #SmalltalkCompleter category: #'Tools-Autocompletion'! -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! -!Object methodsFor: 'private' stamp: 'HAW 12/20/2018 14:18:53'! - errorDescriptionForSubcriptBounds: index - - ^'subscript is out of bounds: ' , index printString! ! -!SequenceableCollection methodsFor: 'assertions' stamp: 'HAW 12/20/2018 14:40:40'! - assertIsInBounds: anIndex - - (self isInBounds: anIndex) ifFalse: [ self errorSubscriptBounds: anIndex ] - ! ! -!ArrayedCollection methodsFor: 'inserting' stamp: 'HAW 12/20/2018 14:54:55'! - insert: anObject shiftingRightAt: anInsertionIndex - - "Inserts anObject at anInsertionIndex, moving right object between anInsertionIndex and self size, - loosing last object. Example: - #(0 1 3 4 5) insert: 2 shiftingRightAt: 3 - returns: #(0 1 2 3 4) - " - | currentIndex | - - self assertIsInBounds: anInsertionIndex. - currentIndex _ self size . - - [currentIndex > anInsertionIndex] whileTrue: [ - self at: currentIndex put: (self at: currentIndex-1). - currentIndex _ currentIndex - 1]. - - self at: anInsertionIndex put: anObject -! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 12/20/2018 14:43:28'! - add: selector and: lastUsedTime to: selectorsToShow - - ^ selectorsToShow size < EntriesLimit - ifTrue: [ self add: selector and: lastUsedTime whenNotFullTo: selectorsToShow ] - ifFalse: [ self add: selector and: lastUsedTime whenFullTo: selectorsToShow ] ! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 12/20/2018 14:44:54'! - add: selector and: lastUsedTime whenFullTo: selectorsToShow - - selectorsToShow - findBinaryIndex: [ :selectorAndTime | selectorAndTime second < lastUsedTime ifTrue: [ -1 ] ifFalse: [ 1 ]] - do: [ :found | ] - ifNone: [ :leftBound :rightBound | self insert: selector and: lastUsedTime at: rightBound to: selectorsToShow ]. - - ^selectorsToShow -! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 12/20/2018 14:49:34'! - add: selector and: lastUsedTime whenNotFullTo: selectorsToShow - - selectorsToShow add: { selector . lastUsedTime }. - - ^selectorsToShow size = EntriesLimit - ifTrue: [ self sortByLastUsedTime: selectorsToShow ] - ifFalse: [ selectorsToShow ] - ! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 12/20/2018 14:45:44'! - insert: selector and: lastUsedTime at: insertionIndex to: selectorsToShow - - insertionIndex <= EntriesLimit ifTrue: [ selectorsToShow insert: { selector . lastUsedTime } shiftingRightAt: insertionIndex ]. - - ^selectorsToShow ! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 12/20/2018 14:44:13'! - sortByLastUsedTime: selectorsToShow - - ^selectorsToShow asArray sort: [ :leftSelectorAndTime :rightSelectorAndTime | leftSelectorAndTime second > rightSelectorAndTime second ]! ! -!Object methodsFor: 'private' stamp: 'HAW 12/20/2018 14:17:22' prior: 16882709! - errorSubscriptBounds: index - "Create an error notification that an improper integer was used as an index." - - self error: (self errorDescriptionForSubcriptBounds: index)! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 12/20/2018 14:19:58'! - should: aBlockToFail raise: anExceptionHandlingCondition withMessageText: anExpectedErrorMessageCreator - - self - should: aBlockToFail - raise: anExceptionHandlingCondition - withExceptionDo: [ :anException | self assert: anExpectedErrorMessageCreator value equals: anException messageText ]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 12/20/2018 14:47:00' prior: 16909310! - computeMessageEntries: receiverClass - - | selectorsToShow notUnderstoodSelectors | - - selectorsToShow _ OrderedCollection new. - notUnderstoodSelectors _ OrderedCollection new. - - self class protected: [ - Selectors forPrefix: prefix keysAndValuesDo: [ :selector :lastUsedTime | - (receiverClass isNil or: [ receiverClass canUnderstand: selector ]) - ifTrue: [ selectorsToShow := self add: selector and: lastUsedTime to: selectorsToShow ] - ifFalse: [ notUnderstoodSelectors := self add: selector and: lastUsedTime to: notUnderstoodSelectors ]]]. - - selectorsToShow isEmpty ifTrue: [ selectorsToShow _ notUnderstoodSelectors ]. - selectorsToShow size < EntriesLimit ifTrue: [ selectorsToShow _ self sortByLastUsedTime: selectorsToShow ]. - - " To see the timestamps in the menu (need to tweak #insertCompletion: to activate. Right now, just for debugging) - entries _ selectorsToShow collect: [ :ary | ary first, '(', ((DateAndTime fromString: '01/01/1996 00:00') + ary second minutes) printString,')' ] - " - entries _ selectorsToShow collect: [ :selectorAndTime | selectorAndTime first ] - -! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 12/20/2018 11:32:31' prior: 50424121! - computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel - - | id receiverClassOrEntries | - - id _ allSource copyFrom: range start to: range end. - receiverClassOrEntries _ range rangeType - caseOf: { - [ #globalVar ] -> [ (Smalltalk at: id asSymbol) class ]. - [ #self ] -> [ contextClass ]. - [ #super ] -> [ contextClass superclass ]. - [ #true ] -> [ True ]. - [ #false ] -> [ False ]. - [ #nil ] -> [ UndefinedObject ]. - [ #character ] -> [ id first class ]. - [ #number ] -> [ self classOfLiteral: id in: contextClass ]. - [ #string ] -> [ self classOfLiteral: id in: contextClass ]. - [ #symbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #stringSymbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #instVar ] -> [ specificModel classOfInstVarNamed: id ]. - [ #methodArg ] -> [ specificModel classOfTempVarNamed: id ]. - [ #tempVar ] -> [ specificModel classOfTempVarNamed: id ]. - [ #workspaceVar ] -> [ specificModel classOfWorkspaceVarNamed: id ]. - [ #blockArg ] -> [ specificModel classOfBlockArgNamed: id ]. - [ #blockTempVar ] -> [ specificModel classOfBlockTempVarNamed: id ]. - [ #thisContext ] -> [ specificModel classOfThisContext ]. - [ #classVar ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #poolConstant ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #blockEnd ] -> [ BlockClosure ]. - [ #arrayEnd ] -> [ Array ]. - [ #rightBrace ] -> [ Array ]. - [ #unary ] -> [ self returnTypeOfUnaryMessage: id at: range ]. - [ #rightParenthesis ] -> [ self returnTypeOfEnclosedExpressionAt: range ]. } - otherwise: [ nil ]. - - receiverClassOrEntries isCollection - ifTrue: [ self computeMessageEntriesForSelectors: receiverClassOrEntries ] - ifFalse: [ self computeMessageEntries: receiverClassOrEntries ]! ! -!SmalltalkCompleter class methodsFor: 'class initialization' stamp: 'HAW 12/20/2018 11:51:22' prior: 50420132! - initialize - " - It takes about 6 seconds, mostly because of the time to fetch method stamps from source files... - [ SmalltalkCompleter initialize ]timeToRun - Selectors inspect - " - | maxSortValue allImplemented | - - EntriesLimit _ 400. - - SystemChangeNotifier uniqueInstance - removeActionsWithReceiver: self. "avoid double registration" - - SystemChangeNotifier uniqueInstance - when: #classRemoved send: #classRemoved:fromCategory: to: self; - when: #methodAdded send: #methodAdded:selector:inClass:requestor: to: self; - when: #methodAddedInProtocol send: #methodAdded:selector:inProtocol:class:requestor: to: self; - when: #methodRemoved send: #methodRemoved:selector:inProtocol:class: to: self. - - self protected: [ - allImplemented _ Smalltalk allImplementedMessages. - Selectors _ Trie new. - " - Smalltalk allBehaviorsDo: [:class | - class selectorsAndMethodsDo: [ :sel :method | - Selectors at: sel ifAbsentPut: [ 0 ]. - method messages do: [ :sentMsg | - Selectors at: sentMsg put: (Selectors at: sentMsg ifAbsent: [ 0 ]) + 1 ]]]. - " - Smalltalk allBehaviorsDo: [:class | - class selectorsAndMethodsDo: [ :sel :method | - self addSelector: sel method: method allImplemented: allImplemented]]. - "" - - "The following might not be found in #messages. Give them maximum priority." - maxSortValue _ SmallInteger maxVal. - "From MessageNode>>#initialize" - #( ifTrue: ifFalse: ifTrue:ifFalse: ifFalse:ifTrue: - and: or: - whileFalse: whileTrue: whileFalse whileTrue - to:do: to:by:do: - caseOf: caseOf:otherwise: - ifNil: ifNotNil: ifNil:ifNotNil: ifNotNil:ifNil:) do: [ :sel | - Selectors at: sel put: maxSortValue ]. - - maxSortValue _ SmallInteger maxVal-1. - "From SystemDictionary >>#recreateSpecialObjectsArray" - (1 to: Smalltalk specialSelectorSize) do: [ :i | - Selectors at: (Smalltalk specialSelectorAt: i) put: maxSortValue ]]! ! - -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #SmalltalkCompleter category: #'Tools-Autocompletion'! -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -SmalltalkCompleter initialize! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3542-AutoCompleterEnhancements-HernanWilkinson-2018Dec20-09h43m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3542] on 21 December 2018 at 5:34:41 pm'! -!SmalltalkCompleter class methodsFor: 'class initialization' stamp: 'jmv 12/21/2018 17:33:20' prior: 50422682! - addSelector: aSymbol method: aCompiledMethod allImplemented: implemented - - | sentValue value | - self protected: [ - value _ (ChangeSet notInstallOrTestRun or: [Smalltalk platformName ~= 'Win32']) - ifTrue: [ - "Expensive and not worth doing in Windows with antivirus active, when installing large packages" - aCompiledMethod dateSortingValue ] - ifFalse: [ 0 ]. - Selectors at: aSymbol put: (value max: (Selectors at: aSymbol ifAbsent: [0])). - aCompiledMethod messages do: [ :sentMsg | - ((Selectors includesKey: sentMsg) or: [ - implemented - ifNotNil: [ implemented includes: sentMsg ] - ifNil: [ Smalltalk isThereAnImplementorOf: sentMsg ]]) - ifTrue: [ - sentValue _ value max: (Selectors at: sentMsg ifAbsent: [0]). - Selectors at: sentMsg put: sentValue ]]]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3543-IgnorePackageMethodDateForAutocompleteOnlyOnWindows-JuanVuletich-2018Dec21-17h30m-jmv.1.cs.st----! - -----SNAPSHOT----#(21 December 2018 5:45:04.096019 pm) Cuis5.0-3543-32.image priorSource: 2863983! - -----QUIT----#(21 December 2018 5:45:21.234216 pm) Cuis5.0-3543-32.image priorSource: 2972104! - -----STARTUP----#(1 January 2019 8:24:44.006833 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3543-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3543] on 23 December 2018 at 11:25:59 am'! -!Behavior methodsFor: 'methods' stamp: 'KLG 12/23/2018 11:18:27' prior: 50419490! - methodNodeFor: aSourceCode noPattern: aBoolean - - | parser methodNode | - - parser := self parserClass new. - - methodNode := parser parse: aSourceCode class: self noPattern: aBoolean. - methodNode sourceText: aSourceCode. - - ^methodNode - ! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3544-DontHardCodeEncoderClass-KLG-2018Dec23-11h18m-KLG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3544] on 24 December 2018 at 12:15:36 pm'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 12/24/2018 12:15:14' prior: 50423422! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('AY' 'Angel Yan') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('FJG' 'Facundo Javier Gelatti') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('KLG' 'Gerald Klix') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3545-AddGeraldKlixAsKnownAuthor-JuanVuletich-2018Dec24-12h14m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3531] on 24 December 2018 at 10:41:52 am'! - -Object subclass: #DropFilesAction - instanceVariableNames: 'shouldAskForCancel dropFilesEvent cancelBlock' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Worlds'! - -!classDefinition: #DropFilesAction category: #'Morphic-Worlds'! -Object subclass: #DropFilesAction - instanceVariableNames: 'shouldAskForCancel dropFilesEvent cancelBlock' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Worlds'! - -MorphicEvent subclass: #DropFilesEvent - instanceVariableNames: 'position wasHandled numberOfFiles' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Events'! - -!classDefinition: #DropFilesEvent category: #'Morphic-Events'! -MorphicEvent subclass: #DropFilesEvent - instanceVariableNames: 'position wasHandled numberOfFiles' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Events'! -!Morph methodsFor: 'dropping/grabbing' stamp: 'HAW 12/24/2018 07:21:44'! - dropFiles: aDropFilesEvent - - "I do nothing, subclasses should redefine if they handle this event - Hernan"! ! -!Morph methodsFor: 'event handling testing' stamp: 'HAW 12/24/2018 07:13:50'! - allowsFilesDrop - "Answer whether we accept dropping files. By default answer false." - - "Use a property test to allow individual instances to specify this." - ^ self hasProperty: #'allowsFilesDrop'! ! -!Morph methodsFor: 'events-processing' stamp: 'HAW 12/24/2018 09:28:32'! - processDropFiles: aDropFilesEvent localPosition: localEventPosition - "Handle a dropping file." - - aDropFilesEvent wasHandled ifTrue: [ ^self ]. - - aDropFilesEvent wasHandled: true. - self dropFiles: aDropFilesEvent! ! -!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'HAW 12/24/2018 07:13:56'! - allowsFilesDrop - - ^ true! ! -!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'HAW 12/24/2018 10:27:39'! - dropFiles: aDropFilesEvent - - (DropFilesAction for: aDropFilesEvent) value! ! -!HandMorph methodsFor: 'events-processing' stamp: 'HAW 12/24/2018 09:25:29'! - startDropFilesEventDispatch: aDropFilesEvent - - owner dispatchEvent: aDropFilesEvent localPosition: aDropFilesEvent eventPosition. - self mouseOverHandler processMouseOver: lastMouseEvent! ! -!HandMorph methodsFor: 'private events' stamp: 'HAW 12/24/2018 09:29:07'! - generateDropFilesEvent: evtBuf - "Generate the appropriate mouse event for the given raw event buffer" - - | position stamp numberOfFiles dragType | - - stamp := evtBuf second. - stamp = 0 ifTrue: [stamp := Time localMillisecondClock]. - dragType := evtBuf third. - position := evtBuf fourth @ evtBuf fifth. - numberOfFiles := evtBuf seventh. - - ^ dragType = 4 ifTrue: [ DropFilesEvent at: position with: numberOfFiles from: self]. -! ! -!DropFilesAction methodsFor: 'initialization' stamp: 'HAW 12/24/2018 10:29:45'! - initializeFor: aDropFilesEvent - - dropFilesEvent := aDropFilesEvent. - shouldAskForCancel := aDropFilesEvent numberOfFiles > 1! ! -!DropFilesAction methodsFor: 'evaluating' stamp: 'HAW 12/24/2018 10:34:38'! - value - - cancelBlock := [ ^self ]. - dropFilesEvent fileNamesDo: [ :fileName | self fileNamedDropped: fileName ] - -! ! -!DropFilesAction methodsFor: 'evaluating - private' stamp: 'HAW 12/24/2018 10:33:29'! - ask: aQueation onYes: aYesBlock - - | yesSelected | - - yesSelected := shouldAskForCancel - ifTrue: [ self confirm: aQueation orCancel: cancelBlock ] - ifFalse: [ self confirm: aQueation ]. - - ^yesSelected ifTrue: aYesBlock ! ! -!DropFilesAction methodsFor: 'evaluating - private' stamp: 'HAW 12/24/2018 10:33:54'! - canBeFiledIn: aFileName - - ^aFileName endsWith: '.st'! ! -!DropFilesAction methodsFor: 'evaluating - private' stamp: 'HAW 12/24/2018 10:33:43'! - canBeInstalled: aFileName - - ^(aFileName endsWith: '.cs.st') or: [ aFileName endsWith: '.pck.st' ]! ! -!DropFilesAction methodsFor: 'evaluating - private' stamp: 'HAW 12/24/2018 10:36:41'! - fileNamedDropped: aFileName - - (self canBeInstalled: aFileName) - ifTrue: [ self ifUserWantsInstall: aFileName ] - ifFalse: [ (self canBeFiledIn: aFileName) - ifTrue: [ self ifUserWantsFileIn: aFileName ] - ifFalse: [ self inform: 'Dropped file ', aFileName, ' not supported' ]]! ! -!DropFilesAction methodsFor: 'evaluating - private' stamp: 'HAW 12/24/2018 10:32:40'! - ifUserWantsFileIn: aFileName - - self ask: 'Do you want to file in ', aFileName, ' ?' onYes: [ ChangeSet fileIn: aFileName asFileEntry ] ! ! -!DropFilesAction methodsFor: 'evaluating - private' stamp: 'HAW 12/24/2018 10:32:12'! - ifUserWantsInstall: aFileName - - self ask: 'Do you want to install ', aFileName, ' ?' onYes: [ ChangeSet install: aFileName asFileEntry ] - ! ! -!DropFilesAction class methodsFor: 'instance creation' stamp: 'HAW 12/24/2018 10:29:14'! - for: aDropFilesEvent - - ^self new initializeFor: aDropFilesEvent - ! ! -!DropFilesEvent methodsFor: 'initialization' stamp: 'HAW 12/24/2018 09:32:07'! - initializeAt: aPosition with: aNumberOfFiles from: aHand - - position := aPosition. - numberOfFiles := aNumberOfFiles. - source := aHand. - wasHandled := false.! ! -!DropFilesEvent methodsFor: 'testing' stamp: 'HAW 12/24/2018 09:27:00'! - isDropEvent - - ^true! ! -!DropFilesEvent methodsFor: 'testing' stamp: 'HAW 12/24/2018 09:27:13'! - wasHandled - - ^wasHandled! ! -!DropFilesEvent methodsFor: 'testing' stamp: 'HAW 12/24/2018 09:27:26'! - wasHandled: aBool - - "This is ugly, and means that events are copied in many places..." - self flag: #jmvVer. - - wasHandled _ aBool! ! -!DropFilesEvent methodsFor: 'dispatching' stamp: 'HAW 12/24/2018 09:24:16'! - dispatchWith: aMorph localPosition: positionInAMorph - "Drop is done on the innermost target that accepts it." - - | eventPositionInChild | - - "Try to get out quickly" - (aMorph fullContainsPoint: positionInAMorph) ifFalse: [ ^#rejected ]. - - "Go looking if any of our submorphs wants it" - aMorph submorphsDo: [ :eachChild | - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ ^self ]]. - - (aMorph allowsFilesDrop and: [ aMorph containsPoint: positionInAMorph event: self ]) - ifTrue: [^ self sentTo: aMorph localPosition: positionInAMorph ]. - - ^#rejected! ! -!DropFilesEvent methodsFor: 'dispatching' stamp: 'HAW 12/24/2018 07:20:35'! - sentTo: aMorph localPosition: positionInAMorph - "Dispatch the receiver into aMorph" - - ^aMorph processDropFiles: self localPosition: positionInAMorph! ! -!DropFilesEvent methodsFor: 'dispatching' stamp: 'HAW 12/24/2018 07:53:42'! - startDispatchFrom: aHand - "double dispatch the event dispatch" - - aHand startDropFilesEventDispatch: self! ! -!DropFilesEvent methodsFor: 'position' stamp: 'HAW 12/24/2018 09:30:41'! - eventPosition - - ^position! ! -!DropFilesEvent methodsFor: 'primitives' stamp: 'HAW 12/24/2018 09:39:09'! - primDropRequestFileHandle: dropIndex - "Primitive. Return the (read-only) file handle for some file that was just dropped onto Squeak. - Fail if dropIndex is out of range or the primitive is not supported." - - ^nil! ! -!DropFilesEvent methodsFor: 'primitives' stamp: 'HAW 12/24/2018 09:38:59'! - primDropRequestFileName: dropIndex - "Primitive. Return the file name for some file that was just dropped onto Squeak. - Fail if dropIndex is out of range or the primitive is not supported." - - ^nil! ! -!DropFilesEvent methodsFor: 'files' stamp: 'HAW 12/24/2018 09:38:25'! - fileNamesDo: aBlock - - 1 to: numberOfFiles do: [ :fileNumber | | fileName | - fileName := self primDropRequestFileName: fileNumber. - fileName ifNotNil: aBlock ]! ! -!DropFilesEvent methodsFor: 'files' stamp: 'HAW 12/24/2018 10:34:28'! - numberOfFiles - - ^numberOfFiles! ! -!DropFilesEvent class methodsFor: 'instance creation' stamp: 'HAW 12/24/2018 09:32:07'! - at: aPosition with: aNumberOfFiles from: aHand - - ^self new initializeAt: aPosition with: aNumberOfFiles from: aHand - -! ! -!StandardFileStream class methodsFor: 'error handling' stamp: 'HAW 12/24/2018 09:50:28' prior: 16913802! - readOnlyFileDoesNotExistUserHandling: fullFileName - - | dir files choices selection newName fileName | - dir _ fullFileName asFileEntry parent. - files _ dir fileNames. - fileName _ fullFileName asFileEntry name. - choices _ fileName correctAgainst: files. - choices add: 'Choose another name'. - choices add: 'Cancel'. - selection _ (PopUpMenu labelArray: choices lines: (Array with: 5) ) - startUpWithCaption: fullFileName asFileEntry name, ' -does not exist.'. - selection = choices size ifTrue:["cancel" ^ nil "should we raise another exception here?"]. - selection < (choices size - 1) ifTrue: [ - newName _ (dir pathName , '/', (choices at: selection))]. - selection = (choices size - 1) ifTrue: [ - newName _ FillInTheBlankMorph - request: 'Enter a new file name' - initialAnswer: fileName. - "If Cancel was pressed, no file should be opened - Hernan" - newName isEmpty ifTrue: [ ^nil ]]. - newName = '' ifFalse: [^ FileIOAccessor default privateReadOnlyFile: newName asFileEntry ]. - ^ self error: 'Could not open a file'! ! -!HandMorph methodsFor: 'event handling' stamp: 'HAW 12/24/2018 09:29:37' prior: 16851755! - processEventQueue - "Process user input events from the local input devices." - - | evt evtBuf type hadAny mcs | - mcs _ mouseClickState. - hadAny := false. - [ (evtBuf := Sensor nextEvent) isNil ] whileFalse: [ - evt := nil. "for unknown event types" - type := evtBuf first. - type = EventSensor eventTypeMouse - ifTrue: [ evt _ self generateMouseEvent: evtBuf ] ifFalse: [ - type = EventSensor eventTypeKeyboard - ifTrue: [ evt _ self generateKeyboardEvent: evtBuf ] ifFalse: [ - type = EventSensor eventTypeWindow - ifTrue: [ evt _ self generateWindowEvent: evtBuf ] ifFalse: [ - type = EventSensor eventTypeDragDropFiles - ifTrue: [evt _ self generateDropFilesEvent: evtBuf]]]]. - "All other events are ignored" - evt - ifNil: [ - "I have to consume all eventTypeDragDropFiles of type 2 quicky, that is why - I check if it was an eventTypeDragDropFiles to continue in the loop - Hernan" - type ~= EventSensor eventTypeDragDropFiles ifTrue: [^hadAny]] - ifNotNil: [ - "Finally, handle it" - self startEventDispatch: evt. - hadAny := true. - "For better user feedback, return immediately after a mouse event has been processed." - evt isMouse ifTrue: [ ^hadAny ]]]. - "note: if we come here we didn't have any mouse events" - mcs - ifNotNil: [ - "No mouse events during this cycle. Make sure click states time out accordingly" - mcs - handleEvent: (self lastMouseEvent asMouseMove: (Time localMillisecondClock - self lastMouseEventTime max: 0)) - from: self ]. - ^hadAny! ! -!ChangeSet class methodsFor: 'services' stamp: 'HAW 12/24/2018 09:44:22' prior: 16799274! - fileIn: aFileEntry - "File in the entire contents of the file specified by the name provided" - - aFileEntry ifNil: [^ Smalltalk beep ]. - aFileEntry readStreamDo: [ :stream | - stream ifNotNil: [ stream fileIn ]]! ! - -DropFilesEvent removeSelector: #inittializeAt:with:from:! - -DropFilesEvent removeSelector: #sentTo:! - -DropFilesEvent removeSelector: #type! - -StandardFileStream removeSelector: #primDropRequestFileHandle:! - -StandardFileStream removeSelector: #primDropRequestFileHandle:! - -StandardFileStream removeSelector: #primDropRequestFileName:! - -StandardFileStream removeSelector: #primDropRequestFileName:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3546-DropFileSupport-HernanWilkinson-2018Dec20-15h12m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3546] on 27 December 2018 at 5:58:46 pm'! -!Float class methodsFor: 'constants' stamp: 'jmv 12/26/2018 12:50:56' prior: 50423353! - emax - "Answer exponent of the maximal representable finite value" - - ^1023! ! -!Float class methodsFor: 'class initialization' stamp: 'jmv 12/26/2018 13:08:28' prior: 50420588! - initClassCachedState - "Float initialize" - "Constants from Computer Approximations, pp. 182-183: - Pi = 3.14159265358979323846264338327950288 - Pi/2 = 1.57079632679489661923132169163975144 - Pi*2 = 6.28318530717958647692528676655900576 - Pi/180 = 0.01745329251994329576923690768488612 - 2.0 ln = 0.69314718055994530941723212145817657 - 2.0 sqrt = 1.41421356237309504880168872420969808" - - Pi _ 3.14159265358979323846264338327950288. - Halfpi _ Pi / 2.0. - Twopi _ Pi * 2.0. - RadiansPerDegree _ Pi / 180.0. - - Ln2 _ 0.69314718055994530941723212145817657. - Ln10 _ 10.0 ln. - Sqrt2 _ 1.41421356237309504880168872420969808. - E _ 2.718281828459045235360287471353. - - MaxVal _ 1.7976931348623157e308. - MaxValLn _ 709.782712893384. - MinValLogBase2 _ -1074. - - Infinity _ MaxVal * MaxVal. - NegativeInfinity _ 0.0 - Infinity. - NaN _ Infinity - Infinity. - NegativeZero _ Float fmin negated nextTowardsZero. -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3547-NicerNegativeZeroInit-JuanVuletich-2018Dec27-17h57m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3546] on 26 December 2018 at 1:54:58 pm'! -!Float commentStamp: 'jmv 12/26/2018 13:44:13' prior: 50414191! - A note About Floating Point numbers and Floating Point Arithmetic. - -The following is not specific to Cuis or Smalltalk at all. This is about the properties of Float numbers in any computer implementation. - -If you haven't done so already, read https://en.wikipedia.org/wiki/Floating-point_arithmetic - -But if you find the Wikipedia article too detailed, or hard to read, then try http://fabiensanglard.net/floating_point_visually_explained/ (get past "How Floating Point are usually explained" and read "A different way to explain..."). - -Other great reads are: - "Why don't my numbers add up?": - http://floating-point-gui.de/ -and - "What Every Computer Scientist Should Know About Floating-Point Arithmetic": - http://docs.oracle.com/cd/E19957-01/806-3568/ncg_goldberg.html -and also maybe - "Comparing floating point numbers" - https://randomascii.wordpress.com/2012/02/25/comparing-floating-point-numbers-2012-edition/ - -Now that you read them, and we are on the same boat, some further comments (from jmv): - -Floats are (conceptually) approximate real numbers. That's why trig and other trascendental functions always answer Floats. That's why it is ok to round the result of operations. That's why Float is considered more general than Fraction in ST-80 and most Smalltalks. So, when we have a Float value, we must not think about it as a Rational but as a Real (actually as some unknown Real that could hopefully be close to the Rational we can actually represent). Keep this in mind when dealing with Floats, and especially avoid comparing them for equality. - -When doing mixed operations with Floats and Fractions, Cuis, as most other Smalltalks, converts all values to Floats. Some other systems, including Pharo Smalltalk, Scheme and Lisp have two rules: when the answer is a Number, they convert to Float. But when the answer is a boolean (#<, #=, #<=, etc.) they convert to Fraction. We think this is a mistake. There should never be implicit conversions from Float to Fraction. Fractions are to hold exact values, and people expect Fractions to be exact. On the other hand, Floats are to hold approximations (and people should be aware of that!!). But an implicit conversion from Float to Fraction would give a Fraction that should not be considered an exact value (the value comes from an inexact Float), but that knowledge is lost, as it is an instance of Fraction. - -If you want exact arithmetic, usual mathematical properties (like transitivity of equality), can live in the limited world of Rational numbers, and can afford a slight performance penalty, use Fraction instead. Avoid trascendental functions and never convert to Float. - -In any case, most numeric computation is done on Float numbers. There are good reasons for that. One is that in most cases we don't need an exact answer. And in many cases we can't really have it: the inputs to algorithms already have a limited precision, or they use trascendental functions. And even when exact arithmetic possible, if we are doing sound synthesis, 24 bits of resolution is enough. For image processing and graphics, the result is never more than 16 bits per channel. So, these fields don't really need 64 bit Doubles. 32 bit Floats are enough. Other fields do need 64 bit Doubles, like physics simulations and geometry. Games usually prefer special, faster 32 bit Float operations in GPUs that have greater errors but are faster. - -There are some things that can be done to increase the confidence you can have on Float results. One is to do an error propagation analysis on the code you are running. This is not easy, but it is done for any widely used numerical method. Then, you can know real bounds and/or estimates of the errors made. So, understanding your inputs and your algorithms (for example error propagation, condition number, numeric stability), and using Float number if appropriate, is the usual advice. - -Perhaps you have heard about "interval arithmetic". It is a bit better than simple Float, but doesn't really fix the problems. - -The ultimate solution is to do Monte Carlo analysis, with random perturbation of inputs. After the Monte Carlo run, it is needed to do statistical analysis of possible correlations between the distributions of the random noise added to imputs and the result of the algorithm. - -Additional food for thought: http://www.cs.berkeley.edu/~wkahan/Mindless.pdf . According to this, doing Monte Carlo as described above attacks a slightly different problem. This might be yet another reason (besides performance) to try something like the next paragraph. I (jmv) came up with it, and I don't really know if it has been described and or tried before or not. Mhhh. Maybe a defensive publication is in order. - -A possibility that could be a practical solution, being much cheaper than Monte Carlo, but better than interval arithmetic, is to represent each value by 2 Floats: an estimation of the real value (i.e. an estimation of the mean value of the distribution of the corresponding Monte Carlo result), and an estimation of the error (i.e. an estimation of the standard deviation of the corresponding Monte Carlo result). Or perhaps even 3 of them. In addition to the estimation of the real value and an estimation of the error, we could add a hard bound on the error. In many cases it will be useless, because the error can not really be bound. But in those cases where it is possible to bound it, applications could really know about the quality of computed values. - -======================================================================= - -My instances represent IEEE 754 floating-point double-precision numbers. They have about 16 decimal digits of accuracy and their range is between plus and minus 10^307. Some valid examples are: - - 8.0 13.3 0.3 2.5e6 1.27e-30 1.27e-31 -12.987654e12 - -Mainly: no embedded blanks, little e for tens power, and a digit on both sides of the decimal point. It is actually possible to specify a radix for Squeak Float constants. This is great for teaching about numbers, but may be confusing to the average reader: - - 3r20.2 --> 6.66666666666667 - 8r20.2 --> 16.25 - -If you don't have access to the definition of IEEE754, you can figure out what is going on by printing various simple values in Float hex. It may help you to know that the basic format is... - sign 1 bit - exponent 11 bits with bias of 1023 (16r3FF) to produce an exponent - in the range -1023 .. +1024 - - 16r000: - significand = 0: Float zero - significand ~= 0: Denormalized number (exp = -1023 + 1 = -1022, no hidden '1' bit in mantissa) - - 16r7FF: - significand = 0: Infinity - significand ~= 0: Not A Number (NaN) representation - mantissa 53 bits, but only 52 are stored (20 in the first word, 32 in the second). This is because a normalized mantissa, by definition, has a 1 to the right of its floating point, and IEEE 754 omits this redundant bit to gain an extra bit of precision instead. People talk about the mantissa without its leading one as the FRACTION, and with its leading 1 as the SIGNFICAND. - -The single-precision format is... - sign 1 bit - exponent 8 bits, with bias of 127, to represent -126 to +127 - - 0x0 and 0xFF reserved for Float zero (mantissa is ignored) - - 16r7F reserved for Float underflow/overflow (mantissa is ignored) - mantissa 24 bits, but only 23 are stored -This format is used in FloatArray (qv), and much can be learned from the conversion routines, Float asIEEE32BitWord, and Float class fromIEEE32Bit:. - -You might also check https://en.wikipedia.org/wiki/IEEE_754_revision - -Other great reads (covering broader but interesting issues): -https://randomascii.wordpress.com/2013/07/16/floating-point-determinism/ -http://www.ima.umn.edu/2010-2011/W1.10-14.11/activities/Leeser-Miriam/Leeser-GPU-IMA-Jan2011.pdf! -!Float methodsFor: 'testing' stamp: 'jmv 12/26/2018 13:43:52' prior: 16845106! - sign - "Answer 1 if the receiver is greater than 0, -1 if less than 0, else 0. - Handle IEEE754 negative-zero by reporting a sign of -1 - Warning!! This makes Float negativeZero the only number in the system such that - x sign negated = x negated sign - evaluates to false!! - This precludes the simpler implementation in #signPart - 0.0 sign -> 0 - 0.0 signPart -> 1 - Float negativeZero sign -> -1 - Float negativeZero signPart -> -1 - " - - self > 0 ifTrue: [^ 1]. - (self < 0 or: [((self at: 1) bitShift: -31) = 1]) ifTrue: [^ -1]. - ^ 0! ! -!Float class methodsFor: 'instance creation' stamp: 'jmv 12/26/2018 13:54:36' prior: 50421719! - signPart: signPart mantissaPart: mantissaPart exponentPart: exponentPart - " - Float signPart: Float pi signPart mantissaPart: Float pi mantissaPart exponentPart: Float pi exponentPart - " - ^ mantissaPart asFloat * signPart timesTwoPower: exponentPart-52! ! -!Float class methodsFor: 'constants' stamp: 'jmv 12/26/2018 13:44:22' prior: 50421417! - precision - "Answer the apparent precision of the floating point representation. - That is the maximum number of radix-based digits (bits if radix=2) representable in floating point without rounding error. - Technically, 52 bits are stored in the representation, and normalized numbers have an implied leading 1 that is not stored. - Note that denormalized floating point numbers don't have the implied leading 1, and thus gradually lose precision. - This format implements the IEEE 754 binary64 format." - - ^53! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3548-FloatCosmetics-JuanVuletich-2018Dec26-13h28m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3546] on 26 December 2018 at 2:34:46 pm'! -!Float methodsFor: 'converting' stamp: 'jmv 12/26/2018 14:05:07' prior: 50414438! - asTrueFraction - " Answer a fraction that EXACTLY represents self, - a double precision IEEE floating point number. - By David N. Smith with significant performance - improvements by Luciano Esteban Notarfrancesco. - (Version of 11April97). - Refactoring and simplification by jmv" - - ^self - partValues: [ :sign :exponent :mantissa | | zeroBitsCount | - " Prepare result. If exponent is greater than mantissa size, result is an integer" - (exponent >= 52 or: [ - zeroBitsCount _ mantissa lowBit - 1. - exponent + zeroBitsCount >= 52 ]) - ifTrue: [ - "result is an integer number" - sign * mantissa bitShift: exponent - 52 ] - ifFalse: [ - " This is the 'obvious' way. Better do Luciano's trick below:" - "result := Fraction - numerator: sign * mantissa - denominator: (1 bitShift: 52 - exponent)." - " Form the result. When exp>52, the exponent is adjusted by - the number of trailing zero bits in the mantissa to minimize - the (huge) time that could be spent in #gcd:. " - Fraction - numerator: (sign * (mantissa bitShift: 0 - zeroBitsCount)) - denominator: (1 bitShift: 52 - exponent - zeroBitsCount) ] - ] - ifInfinite: [ self error: 'Cannot represent infinity as a fraction' ] - ifNaN: [ self error: 'Cannot represent Not-a-Number as a fraction' ].! ! -!Float methodsFor: 'converting' stamp: 'jmv 12/26/2018 14:33:41' prior: 50423266! - partBits: aThreeArgumentBlock - " - Extract the bits for Sign, Mantissa and Exponent parts of the floating point representation. - Just extract the bits. Do not add implicit bit. Do not correct denormals. Do not subtract exponent bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. (f signPart * f significandAsInteger * (2 raisedToInteger: f exponentPart-52)) asFloat = f } print ]. - " - | signBit exponentBits mantissaBits leastSignificativeWord mostSignificativeWord | - - mostSignificativeWord _ self basicAt: 1. - leastSignificativeWord _ self basicAt: 2. - signBit _ mostSignificativeWord bitShift: -31 . - exponentBits _ (mostSignificativeWord bitShift: -20 ) bitAnd: 16r7FF. - mantissaBits _ ((mostSignificativeWord bitAnd: 16r000FFFFF) bitShift: 32) + leastSignificativeWord. - - "Evaluate the block" - ^aThreeArgumentBlock value: signBit value: exponentBits value: mantissaBits! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/26/2018 14:32:49' prior: 50423299! - exponentBits - " - Actual bits for the exponent part of the floating point representation. - Just extract the bits. Do not correct denormals. Do not subtract bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - { f. f exponentBits. f exponentPart. f exponent } print ]. - " - - ^ self partBits: [ :signBit :exponentBits :mantissaBits | exponentBits ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/26/2018 14:33:27' prior: 50414482! - exponentPart - " - Exponent part of the floating point representation. - Valid for any floating point number (except zeros, infinities and NaNs). - Includes correction of stored exponent bits for denormals (where it acts as a label, not a real exponent). - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. (f signPart * f significandAsInteger * (2 raisedToInteger: f exponentPart-52)) asFloat = f } print ]. - " - ^self partValues: [ :sign :exponent :mantissa | exponent ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/26/2018 14:34:33' prior: 50423316! - mantissaBits - " - Actual bits for the mantissa part of the floating point representation. - Just extract the bits. Do not correct denormals. Do not subtract bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - { f. f mantissaBits. f mantissaPart. f significand. } print ]. - " - ^ self partBits: [ :signBit :exponentBits :mantissaBits | mantissaBits ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/26/2018 14:28:48' prior: 50421323! - mantissaPart - "Equivalent to #significandAsInteger." - "The actual bits in the mantissa of the receiver, as an integer, including the implicit leading 1 if appropriate. - Does not include the sign. - See #exponentPart and #signPart - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. (f signPart * f mantissaPart * (2 raisedToInteger: f exponentPart-52)) asFloat = f } print ]. - " - ^self partValues: [ :sign :exponent :mantissa | mantissa ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/26/2018 14:34:07' prior: 50423333! - signBit - " - Actual bits for the exponent part of the floating point representation. - Just extract the bits. Do not correct denormals. Do not subtract bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0. 0.0. -0.0} do: [ :f | - { f. f signBit. f signPart. f sign } print ]. - " - - ^ self partBits: [ :signBit :exponentBits :mantissaBits | signBit ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3549-FloatCosmetics-JuanVuletich-2018Dec26-13h54m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3546] on 26 December 2018 at 2:41:21 pm'! -!Float methodsFor: 'converting' stamp: 'jmv 12/26/2018 14:41:18' prior: 50421823! - partValues: aThreeArgumentBlock ifInfinite: infinityBlock ifNaN: nanBlock - " - Float pi hex print - Float pi partValues: [ :sign :exponent :mantissa | { sign hex. exponent hex. mantissa hex} print ] - 0.0 partValues: [ :sign :exponent :mantissa | { sign hex. exponent hex. mantissa hex} print ] - For 0.0, exponent will be the minimum possible, i.e. -1023, and mantissa will be 0. - " - | sign exponent mantissa | - - ^ self partBits: [ :signBit :exponentBits :mantissaBits | - - "Extract the sign" - sign _ signBit = 0 ifTrue: [1] ifFalse: [-1]. - - "Special cases: infinites and NaN" - exponentBits = 16r7FF ifTrue: [ - ^mantissaBits = 0 - ifTrue: [ infinityBlock valueWithPossibleArgument: self ] - ifFalse: [ nanBlock valueWithPossibleArgument: self and: mantissaBits ]]. - - "Unbias exponent: 16r3FF is bias" - exponent _ exponentBits - 16r3FF. - - exponentBits ~= 0 - ifTrue: [ - "Add back implicit leading 1 in fraction." - mantissa _ 16r0010000000000000 bitOr: mantissaBits ] - ifFalse: [ - "If expPart = 0, I am +/-zero or a denormal value. In such cases, no implicit leading bit in mantissa." - mantissa _ mantissaBits. - exponent _ exponent + 1 ]. - - "Evaluate the block" - aThreeArgumentBlock value: sign value: exponent value: mantissa - ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3550-FloatCosmetics-JuanVuletich-2018Dec26-14h34m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3550] on 27 December 2018 at 6:03:32 pm'! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/26/2018 14:59:25' prior: 50425639! - signBit - " - Actual sigh bit part of the floating point representation. - Just extract the bit. Do not correct denormals. Do not subtract bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0. 0.0. -0.0} do: [ :f | - { f. f signBit. f signPart. f sign } print ]. - " - - ^ self partBits: [ :signBit :exponentBits :mantissaBits | signBit ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/26/2018 15:00:07' prior: 50421353! - significandAsInteger - "The actual bits in the mantissa of the receiver, as an integer, including the implicit leading 1 if appropriate. - See #mantissaPart - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. (f signPart * f significandAsInteger * (2 raisedToInteger: f exponentPart-52)) asFloat = f } print ]. - " - ^self mantissaPart! ! -!Float methodsFor: 'printing' stamp: 'jmv 12/26/2018 14:57:20' prior: 50423058! - printOn: aStream fractionDigits: placesDesired - "This implementation avoids rounding errors doue to #rounded or #roundTo: - Round to a suitable integer and insert the decimal point in the appropriately between the digits." - - | i s scaled | - self isFinite ifFalse: [ ^self printOn: aStream ]. - - placesDesired > 0 ifFalse: [ - ^self rounded printOn: aStream ]. - - scaled _ self * (10 raisedTo: placesDesired). - "If rounding could possibly print a sequence that is read back as a different float, then go the more expensive Fraction way. - If the following line is commented, #testPrintShowingDecimalPlaces4 will fail!!" - scaled ulp > 1 ifTrue: [ - ^ self asTrueFraction printOn: aStream fractionDigits: placesDesired ]. - i _ scaled rounded. - i negative ifTrue: [ - aStream nextPut: $-. - i _ i negated ]. - s _ i printString. - placesDesired + 1 > s size - ifTrue: [ - aStream nextPutAll: '0.'. - placesDesired - s size timesRepeat: [ aStream nextPut: $0 ]. - aStream nextPutAll: s ] - ifFalse: [ - aStream - nextPutAll: (s copyFrom: 1 to: s size-placesDesired); - nextPut: $.; - nextPutAll: (s copyFrom: s size-placesDesired+1 to: s size) ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3551-FloatCosmetics-JuanVuletich-2018Dec27-18h03m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3550] on 27 December 2018 at 6:26:26 pm'! -!SequenceableCollection methodsFor: 'comparing' stamp: 'jmv 12/27/2018 18:20:09' prior: 16906017! - 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 isSequenceable ifFalse: [^ false]. - (size _ self size) = otherCollection size ifFalse: [^ false]. - 1 to: size do: - [:index | - (self at: index) = (otherCollection at: index) ifFalse: [^ false]]. - ^ true! ! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'jmv 12/26/2018 15:47:12' prior: 16906652! - polynomialEval: thisX - "Treat myself as the coefficients of a polynomial in X. Evaluate it with thisX. First element is the constant and last is the coefficient for the highest power. - https://en.wikipedia.org/wiki/Horner's_method" - " #(1 2 3) polynomialEval: 2 " "is 3*X^2 + 2*X + 1 with X = 2" - - | index sum | - sum := self at: (index := self size). - [ (index := index - 1) >= 1 ] whileTrue: [ - sum := sum * thisX + (self at: index) ]. - ^sum! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 12/27/2018 18:25:18' prior: 50420004! - colorFrom: parm - "Return an instantiated color from parm. If parm is already a color, return it, else return the result of my performing it if it's a symbol or, if it is a list, it can either be an array of three numbers, which will be interpreted as RGB values, or a list of symbols, the first of which is sent to me and then the others of which are in turn sent to the prior result, thus allowing entries of the form #(blue darker). Else just return the thing" - - | aColor firstParm | - (parm is: #Color) ifTrue: [ ^ parm ]. - parm isSymbol ifTrue: [ ^ self perform: parm ]. - parm isString ifTrue: [ ^ self fromHexString: parm ]. - (parm isCollection and: [ parm isSequenceable and: [ parm size > 0 ]]) - ifTrue: [ - firstParm _ parm first. - firstParm isNumber ifTrue: [ - ^ self fromRgbTriplet: parm]. - aColor _ self colorFrom: firstParm. - parm withIndexDo: [ :sym :ind | - ind > 1 ifTrue: [ - aColor _ aColor perform: sym ]]. - ^ aColor]. - ^ parm - -" -Color colorFrom: #(blue darker) -Color colorFrom: Color blue darker -Color colorFrom: #blue -Color colorFrom: #(0.0 0.0 1.0) -Color colorFrom: '#D7B360' -"! ! -!ParseNode methodsFor: 'printing' stamp: 'jmv 12/27/2018 18:25:45' prior: 16884894! - nodePrintOn: aStrm indent: nn - | var aaStrm myLine | - "Show just the sub nodes and the code." - - (aaStrm := aStrm) ifNil: [aaStrm := WriteStream on: (String new: 500)]. - nn timesRepeat: [aaStrm tab]. - aaStrm nextPutAll: self class name; space. - myLine := self printString withBlanksCondensed. - myLine := myLine copyFrom: 1 to: (myLine size min: 70). - aaStrm nextPutAll: myLine; newLine. - 1 to: self class instSize do: [:ii | - var := self instVarAt: ii. - (var respondsTo: #asReturnNode) ifTrue: [var nodePrintOn: aaStrm indent: nn+1]]. - 1 to: self class instSize do: [:ii | - var := self instVarAt: ii. - (var isCollection and: [var isSequenceable]) ifTrue: [ - var do: [ :aNode | - (aNode respondsTo: #asReturnNode) ifTrue: [ - aNode nodePrintOn: aaStrm indent: nn+1]]]]. - ^ aaStrm! ! - -SequenceableCollection removeSelector: #allButFirstDo:! - -SequenceableCollection removeSelector: #allButFirstDo:! - -SequenceableCollection removeSelector: #allButLastDo:! - -SequenceableCollection removeSelector: #allButLastDo:! - -SequenceableCollection removeSelector: #at:incrementBy:! - -SequenceableCollection removeSelector: #at:incrementBy:! - -SequenceableCollection removeSelector: #errorFirstObject:! - -SequenceableCollection removeSelector: #errorFirstObject:! - -SequenceableCollection removeSelector: #forceTo:paddingStartWith:! - -SequenceableCollection removeSelector: #forceTo:paddingStartWith:! - -SequenceableCollection removeSelector: #forceTo:paddingWith:! - -SequenceableCollection removeSelector: #forceTo:paddingWith:! - -SequenceableCollection removeSelector: #integerAt:! - -SequenceableCollection removeSelector: #integerAt:! - -SequenceableCollection removeSelector: #integerAt:put:! - -SequenceableCollection removeSelector: #integerAt:put:! - -SequenceableCollection removeSelector: #isSequenceableCollection! - -SequenceableCollection removeSelector: #isSequenceableCollection! - -Object removeSelector: #isSequenceableCollection! - -Object removeSelector: #isSequenceableCollection! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3552-SequenceableCollectionCleanup-JuanVuletich-2018Dec27-18h03m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3543] on 25 December 2018 at 5:16:22 pm'! - -RectangleLikeMorph subclass: #DraggingGuideMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -!classDefinition: #DraggingGuideMorph category: #'Morphic-Kernel'! -RectangleLikeMorph subclass: #DraggingGuideMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! -!Browser methodsFor: 'message category functions' stamp: 'AY 12/22/2018 11:56:46'! - categorizeUnderCategoryAt: aMessageCategoryListIndex messageAt: aMessageListIndex - - self selectedClassOrMetaClass ifNotNil: [ :class | | categorySelector messageSelector | - categorySelector _ self messageCategoryList at: aMessageCategoryListIndex ifAbsent: [^self]. - messageSelector _ self messageList at: aMessageListIndex ifAbsent: [^self]. - categorySelector ~= Categorizer allCategory - ifTrue: [ - class organization classify: messageSelector under: categorySelector suppressIfDefault: false. - self changed: #messageList]]! ! -!PluggableListMorph methodsFor: 'accessing' stamp: 'HAW 12/25/2018 12:21:46'! - rowAtLocation: aPoint ifNone: aNoneBlock - - | listMorph | - - listMorph _ self listMorph. - ^listMorph rowAtLocation: (listMorph internalize: aPoint) ifNone: aNoneBlock! ! -!PluggableListMorph methodsFor: 'drawing' stamp: 'AY 12/25/2018 16:51:46'! - flashRow: aRow - - ^self listMorph flashRow: aRow.! ! -!PluggableListMorph methodsFor: 'events' stamp: 'AY 12/25/2018 17:02:10'! - dragEvent: aMouseEvent localPosition: localEventPosition - - | row dragged | - - row _ self rowAtLocation: localEventPosition ifNone: [ ^self ]. - - dragged _ DraggingGuideMorph new. - dragged addMorph: (StringMorph contents: (self getListItem: row)). - dragged setProperty: #dragSource toValue: self. - dragged setProperty: #dropSelectorArgument toValue: row. - - aMouseEvent hand attachMorphBeside: dragged.! ! -!PluggableListMorph methodsFor: 'event handling testing' stamp: 'AY 12/22/2018 11:50:28'! - allowsMorphDrop - - ^self hasProperty: #allowsMorphDrop! ! -!PluggableListMorph methodsFor: 'private' stamp: 'AY 12/22/2018 01:26:29'! - itemsAreDraggable - - ^self hasProperty: #draggableItems! ! -!PluggableListMorph methodsFor: 'accessing - properties' stamp: 'AY 12/22/2018 12:26:06'! - acceptDropsFrom: aMorph performing: aDropActionSelector - - self setProperty: #allowsMorphDrop toValue: true. - self setProperty: #acceptedDragSource toValue: aMorph. - self setProperty: #dropActionSelector toValue: aDropActionSelector.! ! -!PluggableListMorph methodsFor: 'accessing - properties' stamp: 'AY 12/22/2018 12:25:54'! - makeItemsDraggable - - self setProperty: #draggableItems toValue: true! ! -!PluggableListMorph methodsFor: 'accessing - properties' stamp: 'AY 12/22/2018 01:26:39'! - makeItemsUndraggable - - self removeProperty: #draggableItems! ! -!PluggableListMorph methodsFor: 'accessing - properties' stamp: 'AY 12/22/2018 12:27:38'! - rejectDrops - - self removeProperty: #allowsMorphDrop. - self removeProperty: #acceptedDragSource. - self removeProperty: #dropActionSelector.! ! -!PluggableListMorph methodsFor: 'layout' stamp: 'AY 12/25/2018 16:52:06'! - acceptDroppingMorph: aMorph event: dropEvent - - | localPosition row dropActionSelector args | - - localPosition _ self internalizeFromWorld: dropEvent eventPosition. - row _ self rowAtLocation: localPosition ifNone: [ ^self ]. - - self flashRow: row. - - dropActionSelector _ self valueOfProperty: #dropActionSelector. - args _ dropActionSelector numArgs. - args = 1 ifTrue: [ - model perform: dropActionSelector with: row. - ^self]. - args = 2 ifTrue: [ | dropSelectorArgument | - dropSelectorArgument _ aMorph - valueOfProperty: #dropSelectorArgument - ifAbsent: [self error: 'aMorph is missing dropSelectorArgument property']. - model perform: dropActionSelector with: row with: dropSelectorArgument. - ^self]. - - self error: 'dropActionSelector must be a 1- or 2-keyword symbol'! ! -!PluggableListMorph methodsFor: 'dropping/grabbing' stamp: 'HAW 12/25/2018 12:22:07'! - wantsDroppedMorph: aMorph event: evt - - ^(aMorph is: #DraggingGuideMorph) - and: [ (aMorph valueOfProperty: #dragSource) = (self valueOfProperty: #acceptedDragSource) ]! ! -!DraggingGuideMorph methodsFor: 'initialization' stamp: 'AY 12/21/2018 16:05:14'! - defaultColor - - ^Color transparent! ! -!DraggingGuideMorph methodsFor: 'initialization' stamp: 'AY 12/21/2018 16:06:08'! - initialize - - super initialize. - extent _ 0@0.! ! -!DraggingGuideMorph methodsFor: 'testing' stamp: 'AY 12/21/2018 16:05:22'! - is: aSymbol - - ^aSymbol == #DraggingGuideMorph or: [ super is: aSymbol ]! ! -!DraggingGuideMorph methodsFor: 'dropping/grabbing' stamp: 'AY 12/25/2018 16:49:57'! -justDroppedInto: newOwnerMorph event: anEvent - - self delete. - anEvent hand redrawNeeded.! ! -!HandMorph methodsFor: 'double click support' stamp: 'AY 12/21/2018 16:07:39'! - waitForClicksOrDragOrSimulatedMouseButton2: aMorph event: evt clkSel: clkSel clkNHalf: clkNHalfSel dblClkSel: dblClkSel dblClkNHalfSel: dblClkNHalfSel tripleClkSel: tripleClkSel dragSel: dragSel - - mouseClickState _ - MouseClickState new - client: aMorph - drag: dragSel - click: clkSel - clickAndHalf: clkNHalfSel - dblClick: dblClkSel - dblClickAndHalf: dblClkNHalfSel - tripleClick: tripleClkSel - event: evt - sendMouseButton2Activity: Preferences tapAndHoldEmulatesButton2! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'AY 12/25/2018 17:06:43'! - attachMorphBeside: aMorph - - "Position the given morph beside this hand, then grab it." - - aMorph aboutToBeGrabbedBy: self. - ^self grabMorph: aMorph delta: (self morphWidth)@0! ! -!InnerListMorph methodsFor: 'list management' stamp: 'HAW 12/25/2018 12:21:42'! - rowAtLocation: aPoint ifNone: aNoneBlock - - | potentialRowNumber | - - potentialRowNumber := aPoint y // font height + 1. - - ^(listItems isInBounds: potentialRowNumber) - ifTrue: [ potentialRowNumber ] - ifFalse: aNoneBlock! ! -!InnerListMorph methodsFor: 'drawing' stamp: 'AY 12/25/2018 16:51:08'! - flashRow: aRow - - self world ifNotNil: [ :world | world canvas ifNotNil: [ :canvas | - Display flash: (canvas externalizeDisplayBounds: (self drawBoundsForRow: aRow) from: self) ]]. - -! ! -!PluggableListMorph methodsFor: 'events' stamp: 'HAW 12/25/2018 12:22:40' prior: 16888625! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - - | row | - - self hasKeyboardFocus ifFalse: [ - aMouseButtonEvent hand newKeyboardFocus: self. - "If we are focusing, deselect, so that later selection doesn't result in deselect." - self listMorph noSelection]. - row _ self - rowAtLocation: localEventPosition - ifNone: [^super mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition ]. - - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view. - Model update will be done on mouse button up, so this feedback will be visible before that." - self listMorph highlightedRow: row. - - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: #click:localPosition: - clkNHalf: nil - dblClkSel: (doubleClickSelector ifNotNil: [ #doubleClick:localPosition: ]) - dblClkNHalfSel: nil - tripleClkSel: nil - dragSel: (self itemsAreDraggable ifTrue: [ #dragEvent:localPosition: ] ifFalse: [ nil ])! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'AY 12/22/2018 12:18:24' prior: 16793141! - buildMorphicWindow - "Create a pluggable version of all the morphs for a Browser in Morphic" - - | upperPanes messageCatList messageList | - - messageCatList _ self buildMorphicMessageCatList. - messageList _ self buildMorphicMessageList. - messageList makeItemsDraggable. - messageCatList acceptDropsFrom: messageList performing: #categorizeUnderCategoryAt:messageAt:. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: self buildMorphicSystemCatList proportionalWidth: 0.2; - addAdjusterAndMorph: self buildMorphicClassColumn proportionalWidth: 0.2; - addAdjusterAndMorph: messageCatList proportionalWidth: 0.2; - addAdjusterAndMorph: messageList proportionalWidth: 0.4. - - self layoutMorph - addMorph: upperPanes proportionalHeight: 0.3; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.7. - - model changed: #editSelection! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3553-DragAndDropToCategorizeMethods-AngelYan-2018Dec25-17h15m-AY.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3544] on 27 December 2018 at 10:16:55 am'! -!Browser methodsFor: 'message category functions' stamp: 'HAW 12/27/2018 10:07:52'! - categorizeUnderNewCategoryMessageAt: aSelectorToCategorize - - self selectedClassOrMetaClass ifNotNil: [ :class | | newCategory | - newCategory _ self newCategoryNameIfNone: [ ^self ]. - class organization - addCategory: newCategory; - classify: aSelectorToCategorize under: newCategory suppressIfDefault: false. - - self changed: #messageCategoryList. - self changed: #messageList]! ! -!Browser methodsFor: 'message category functions' stamp: 'HAW 12/27/2018 10:04:30'! - newCategoryNameIfNone: aNoneBlock - - | labels lines menuIndex newName reject | - - labels _ OrderedCollection with: 'new...'. - reject _ Set new. - reject - addAll: self selectedClassOrMetaClass organization categories; - add: ClassOrganizer nullCategory; - add: ClassOrganizer default. - lines _ OrderedCollection new. - self selectedClassOrMetaClass allSuperclasses do: [:cls | | cats | - cls = Object ifFalse: [ - cats _ cls organization categories reject: - [:cat | reject includes: cat]. - cats isEmpty ifFalse: [ - lines add: labels size. - labels addAll: cats asArray sort. - reject addAll: cats]]]. - newName _ (labels size = 1 or: [ - menuIndex _ (PopUpMenu labelArray: labels lines: lines) - startUpWithCaption: 'Add Category'. - menuIndex = 0 ifTrue: [^ aNoneBlock value]. - menuIndex = 1]) - ifTrue: [ - self request: 'Please type new category name' - initialAnswer: 'category name'] - ifFalse: [ - labels at: menuIndex]. - - ^ newName isEmpty - ifTrue: aNoneBlock - ifFalse: [newName asSymbol]. -! ! -!PluggableListMorph methodsFor: 'accessing - properties' stamp: 'HAW 12/27/2018 09:32:34'! - acceptDropsFrom: aMorph performing: aDropActionSelector whenOutsideList: aDropOutsideListActionSelector - - (aDropActionSelector numArgs between: 1 and: 2) ifFalse: [ self error: 'dropActionSelector must be a 1- or 2-keyword symbol' ]. - aDropOutsideListActionSelector numArgs = 1 ifFalse: [ self error: 'dropOutsideListActionSelector must be a 1-keyword symbol' ]. - - self setProperty: #allowsMorphDrop toValue: true. - self setProperty: #acceptedDragSource toValue: aMorph. - self setProperty: #dropActionSelector toValue: aDropActionSelector. - self setProperty: #dropOutsideListActionSelector toValue: aDropOutsideListActionSelector ! ! -!PluggableListMorph methodsFor: 'dropping/grabbing' stamp: 'HAW 12/27/2018 10:14:02'! - acceptDroppingMorph: aMorph atRow: row withEvent: dropEvent - - | args dropActionSelector | - - self flashRow: row. - - dropActionSelector _ self valueOfProperty: #dropActionSelector. - args _ dropActionSelector numArgs. - args = 1 ifTrue: [ ^model perform: dropActionSelector with: row]. - args = 2 ifTrue: [ | dropSelectorArgument | - dropSelectorArgument _ aMorph - valueOfProperty: #dropSelectorArgument - ifAbsent: [self error: 'aMorph is missing dropSelectorArgument property']. - ^model perform: dropActionSelector with: row with: dropSelectorArgument ]. - - self error: 'dropActionSelector must be a 1- or 2-keyword symbol' - - ! ! -!PluggableListMorph methodsFor: 'dropping/grabbing' stamp: 'HAW 12/27/2018 09:28:18'! - acceptDroppingMorph: aMorph outsideListWithEvent: dropEvent - - | dropActionSelector dropSelectorArgument | - - dropActionSelector _ self valueOfProperty: #dropOutsideListActionSelector. - dropSelectorArgument _ aMorph - valueOfProperty: #dropSelectorArgument - ifAbsent: [self error: 'aMorph is missing dropSelectorArgument property']. - model perform: dropActionSelector with: dropSelectorArgument. - ! ! -!Browser methodsFor: 'message category functions' stamp: 'HAW 12/27/2018 10:02:04' prior: 16791958! - addCategory - "Present a choice of categories or prompt for a new category name and add it before the current selection, or at the end if no current selection" - - | oldIndex newName | - - selectedClassName ifNil: [ ^self ]. - - oldIndex _ self messageCategoryListIndex. - newName _ self newCategoryNameIfNone: [ ^self ]. - - self classOrMetaClassOrganizer - addCategory: newName - before: selectedMessageCategory. - self changed: #messageCategoryList. - self messageCategoryListIndex: - (oldIndex = 0 - ifTrue: [self classOrMetaClassOrganizer categories size + 1] - ifFalse: [oldIndex]). - self changed: #messageCategoryList. - -! ! -!Browser methodsFor: 'message category functions' stamp: 'HAW 12/27/2018 09:54:08' prior: 50425949! - categorizeUnderCategoryAt: aMessageCategoryListIndex messageAt: aSelectorToCategorize - - self selectedClassOrMetaClass ifNotNil: [ :class | | categorySelector | - categorySelector _ self messageCategoryList at: aMessageCategoryListIndex ifAbsent: [^self]. - categorySelector ~= Categorizer allCategory - ifTrue: [ - class organization classify: aSelectorToCategorize under: categorySelector suppressIfDefault: false. - self changed: #messageList]]! ! -!PluggableListMorph methodsFor: 'accessing - properties' stamp: 'HAW 12/27/2018 09:19:35' prior: 50426029! - rejectDrops - - self removeProperty: #allowsMorphDrop. - self removeProperty: #acceptedDragSource. - self removeProperty: #dropActionSelector. - self removeProperty: #dropOutsideListActionSelector! ! -!PluggableListMorph methodsFor: 'dropping/grabbing' stamp: 'HAW 12/27/2018 10:12:59' prior: 50426036! - acceptDroppingMorph: aMorph event: dropEvent - - | localPosition row | - - localPosition _ self internalizeFromWorld: dropEvent eventPosition. - row _ self rowAtLocation: localPosition ifNone: [ ^self acceptDroppingMorph: aMorph outsideListWithEvent: dropEvent ]. - - self acceptDroppingMorph: aMorph atRow: row withEvent: dropEvent. - - ! ! -!PluggableListMorph methodsFor: 'events' stamp: 'HAW 12/27/2018 10:10:27' prior: 50425981! - dragEvent: aMouseEvent localPosition: localEventPosition - - | row dragged listItem | - - row _ self rowAtLocation: localEventPosition ifNone: [ ^self ]. - listItem _ self getListItem: row. - - dragged _ DraggingGuideMorph new. - dragged addMorph: (StringMorph contents: listItem). - dragged setProperty: #dragSource toValue: self. - dragged setProperty: #dropSelectorArgument toValue: listItem. - - aMouseEvent hand attachMorphBeside: dragged.! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'HAW 12/27/2018 10:09:58' prior: 50426173! - buildMorphicWindow - "Create a pluggable version of all the morphs for a Browser in Morphic" - - | upperPanes messageCatList messageList | - - messageCatList _ self buildMorphicMessageCatList. - messageList _ self buildMorphicMessageList. - messageList makeItemsDraggable. - messageCatList - acceptDropsFrom: messageList - performing: #categorizeUnderCategoryAt:messageAt: - whenOutsideList: #categorizeUnderNewCategoryMessageAt:. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: self buildMorphicSystemCatList proportionalWidth: 0.2; - addAdjusterAndMorph: self buildMorphicClassColumn proportionalWidth: 0.2; - addAdjusterAndMorph: messageCatList proportionalWidth: 0.2; - addAdjusterAndMorph: messageList proportionalWidth: 0.4. - - self layoutMorph - addMorph: upperPanes proportionalHeight: 0.3; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.7. - - model changed: #editSelection! ! - -PluggableListMorph removeSelector: #acceptDropsFrom:performing:! - -PluggableListMorph removeSelector: #acceptDropsFrom:performing:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3554-AllowMethodDropAfterLastCategory-HernanWilkinson-2018Dec27-09h14m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3544] on 27 December 2018 at 10:21:22 am'! -!DropFilesAction methodsFor: 'evaluating - private' stamp: 'HAW 12/27/2018 10:21:17' prior: 50424887! - fileNamedDropped: aFileName - - (self canBeInstalled: aFileName) ifTrue: [ ^self ifUserWantsInstall: aFileName ]. - (self canBeFiledIn: aFileName) ifTrue: [ ^self ifUserWantsFileIn: aFileName ]. - - self inform: 'Dropped file ', aFileName, ' not supported'! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3555-tweak-HernanWilkinson-2018Dec27-10h16m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3544] on 27 December 2018 at 10:29:13 am'! -!HandMorph methodsFor: 'event handling' stamp: 'HAW 12/27/2018 10:28:27'! - createEventFrom: eventBuffer ofType: type - - type = EventSensor eventTypeMouse ifTrue: [ ^self generateMouseEvent: eventBuffer ]. - type = EventSensor eventTypeKeyboard ifTrue: [ ^self generateKeyboardEvent: eventBuffer ]. - type = EventSensor eventTypeWindow ifTrue: [ ^self generateWindowEvent: eventBuffer ]. - type = EventSensor eventTypeDragDropFiles ifTrue: [ ^self generateDropFilesEvent: eventBuffer ]. - - "All other events are ignored" - ^nil ! ! -!HandMorph methodsFor: 'event handling' stamp: 'HAW 12/27/2018 10:28:17' prior: 50425063! - processEventQueue - "Process user input events from the local input devices." - - | evt evtBuf type hadAny mcs | - mcs _ mouseClickState. - hadAny := false. - [ (evtBuf := Sensor nextEvent) isNil ] whileFalse: [ - type := evtBuf first. - evt := self createEventFrom: evtBuf ofType: type. - evt - ifNil: [ - "I have to consume all eventTypeDragDropFiles of type 2 quicky, that is why - I check if it was an eventTypeDragDropFiles to continue in the loop - Hernan" - type ~= EventSensor eventTypeDragDropFiles ifTrue: [^hadAny]] - ifNotNil: [ - "Finally, handle it" - self startEventDispatch: evt. - hadAny := true. - "For better user feedback, return immediately after a mouse event has been processed." - evt isMouse ifTrue: [ ^hadAny ]]]. - "note: if we come here we didn't have any mouse events" - mcs - ifNotNil: [ - "No mouse events during this cycle. Make sure click states time out accordingly" - mcs - handleEvent: (self lastMouseEvent asMouseMove: (Time localMillisecondClock - self lastMouseEventTime max: 0)) - from: self ]. - ^hadAny! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3556-ReadabilityTweak-HernanWilkinson-2018Dec27-10h21m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3544] on 27 December 2018 at 1:42:37 pm'! -!Browser methodsFor: 'message category functions' stamp: 'HAW 12/27/2018 13:11:10'! - categorizeUnderCategoryAt: aMessageCategoryListIndex selector: aSelectorToCategorize - - self selectedClassOrMetaClass ifNotNil: [ :class | | categorySelector | - categorySelector _ self messageCategoryList at: aMessageCategoryListIndex ifAbsent: [^self]. - categorySelector ~= Categorizer allCategory - ifTrue: [ - class organization classify: aSelectorToCategorize under: categorySelector suppressIfDefault: false. - self changed: #messageList]]! ! -!Browser methodsFor: 'message category functions' stamp: 'HAW 12/27/2018 13:10:15'! - categorizeUnderNewCategorySelector: aSelectorToCategorize - - self selectedClassOrMetaClass ifNotNil: [ :class | | newCategory | - newCategory _ self newCategoryNameIfNone: [ ^self ]. - class organization - addCategory: newCategory; - classify: aSelectorToCategorize under: newCategory suppressIfDefault: false. - - self changed: #messageCategoryList. - self changed: #messageList]! ! -!Browser methodsFor: 'system category functions' stamp: 'HAW 12/27/2018 13:30:46'! - categorizeUnderCategoryAt: aSystemCategoryIndex class: aClassName - - systemOrganizer classify: aClassName under: (self systemCategoryList at: aSystemCategoryIndex). - self changed: #classList! ! -!Browser methodsFor: 'system category functions' stamp: 'HAW 12/27/2018 13:39:38'! - categorizeUnderNewCategoryClass: aClassName - - | newCategory | - - newCategory _ self newCategoryNameIfNone: [ ^self ]. - - systemOrganizer - addCategory: newCategory; - classify: aClassName under: newCategory. - - self changed: #systemCategoryList. - self changed: #classList.! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'HAW 12/27/2018 13:14:38'! - buildMorphicClassColumnWith: classList - - | column | - - column _ LayoutMorph newColumn. - column - addMorphUseAll: classList; - addAdjusterAndMorph: self buildMorphicSwitches fixedHeight: (Theme current minimalWindows ifTrue: [AbstractFont default height + 4] ifFalse: [AbstractFont default height *2-4]). - - ^column! ! -!Browser methodsFor: 'system category functions' stamp: 'HAW 12/27/2018 13:37:37' prior: 16792558! - addSystemCategory - "Prompt for a new category name and add it before the - current selection, or at the end if no current selection" - - | oldIndex newName | - - oldIndex _ self systemCategoryListIndex. - newName _ self newCategoryNameIfNone: [ ^self ]. - - systemOrganizer - addCategory: newName - before: selectedSystemCategory. - self systemCategoryListIndex: - (oldIndex = 0 - ifTrue: [self systemCategoryList size] - ifFalse: [oldIndex]). - self changed: #systemCategoryList.! ! -!Browser methodsFor: 'system category functions' stamp: 'HAW 12/27/2018 13:38:14' prior: 50426225! - newCategoryNameIfNone: aNoneBlock - - | newName | - - newName _ self - request: 'Please type new category name' - initialAnswer: 'Category-Name'. - - ^newName isEmpty - ifTrue: aNoneBlock - ifFalse: [newName asSymbol].! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'HAW 12/27/2018 13:15:08' prior: 16793040! - buildMorphicClassColumn - - ^self buildMorphicClassColumnWith: self buildMorphicClassList! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'HAW 12/27/2018 13:16:43' prior: 50426404! - buildMorphicWindow - "Create a pluggable version of all the morphs for a Browser in Morphic" - - | upperPanes messageCatList messageList systemCatList classList | - - systemCatList _ self buildMorphicSystemCatList. - classList _ self buildMorphicClassList. - messageCatList _ self buildMorphicMessageCatList. - messageList _ self buildMorphicMessageList. - - classList makeItemsDraggable. - systemCatList - acceptDropsFrom: classList - performing: #categorizeUnderCategoryAt:class: - whenOutsideList: #categorizeUnderNewCategoryClass:. - - messageList makeItemsDraggable. - messageCatList - acceptDropsFrom: messageList - performing: #categorizeUnderCategoryAt:selector: - whenOutsideList: #categorizeUnderNewCategorySelector:. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: systemCatList proportionalWidth: 0.2; - addAdjusterAndMorph: (self buildMorphicClassColumnWith: classList) proportionalWidth: 0.2; - addAdjusterAndMorph: messageCatList proportionalWidth: 0.2; - addAdjusterAndMorph: messageList proportionalWidth: 0.4. - - self layoutMorph - addMorph: upperPanes proportionalHeight: 0.3; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.7. - - model changed: #editSelection! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3557-DragAndDropToCategorizeClasses-HernanWilkinson-2018Dec27-10h29m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3544] on 27 December 2018 at 1:50:32 pm'! -!Browser methodsFor: 'system category functions' stamp: 'HAW 12/27/2018 13:48:49' prior: 50426559! - categorizeUnderCategoryAt: aSystemCategoryIndex class: aClassName - - systemOrganizer classify: aClassName withBlanksTrimmed asSymbol under: (self systemCategoryList at: aSystemCategoryIndex). - self changed: #classList! ! -!Browser methodsFor: 'system category functions' stamp: 'HAW 12/27/2018 13:48:56' prior: 50426568! -categorizeUnderNewCategoryClass: aClassName - - | newCategory | - - newCategory _ self newCategoryNameIfNone: [ ^self ]. - - systemOrganizer - addCategory: newCategory; - classify: aClassName withBlanksTrimmed asSymbol under: newCategory. - - self changed: #systemCategoryList. - self changed: #classList.! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3558-ClassesDnDFix-HernanWilkinson-2018Dec27-13h42m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3558] on 28 December 2018 at 11:02:37 am'! -!ClassDescription class methodsFor: 'utilities' stamp: 'jmv 12/28/2018 10:34:16'! - printPackageExtensionCategories - "In a bare image, without any packages, should print nothing - ClassDescription printPackageExtensionCategories - ClassOrganizer allInstancesDo: [:co | co removeEmptyCategories]. - " - ClassDescription allSubInstances do: [ :cls | - cls organization categories do: [ :cat | - (cat beginsWith: '*') ifTrue: [ - {cls. cat} print ]]].! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3559-RemovePackageLeftovers-JuanVuletich-2018Dec28-10h58m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3559] on 28 December 2018 at 11:16:11 am'! -!SelectionMenu methodsFor: 'basic control sequence' stamp: 'KLG 12/28/2018 14:05:30' prior: 16904809! - startUpWithCaption: captionOrNil at: location allowKeyboard: aBoolean - "Overridden to return value returned by manageMarker. The boolean parameter indicates whether the menu should be given keyboard focus (if in morphic)" - - | index | - index _ super startUpWithCaption: captionOrNil at: location allowKeyboard: aBoolean. - selections ifNil: [ ^index ]. "If there are no selections defined, show the super class' behavior." - index between: 1 and: selections size :: ifFalse: [ ^nil ]. - ^ selections at: index! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3560-FixFor-SelectionMenu-confirm-GeraldKlix-2018Dec28-11h15m-KLG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3560] on 28 December 2018 at 11:29:52 am'! -!CodeProvider methodsFor: 'misc' stamp: 'HAW 12/28/2018 09:33:38' prior: 16812484! - okayToAccept - "Answer whether it is okay to accept the receiver's input" - - self showingByteCodes ifTrue: [ - self inform: -'Sorry, you can only submit changes here -when you are showing source.'. - ^ false]. - - self showingDocumentation ifTrue: [ - self inform: -'Sorry, you can only submit changes here -when you are showing source.'. - ^ false]. - - self showingAnyKindOfDiffs ifTrue: [ - ^ SelectionMenu confirm: -'Caution!! You are "showing diffs" here, so -there is a danger that some of the text in the -code pane is contaminated by the "diff" display' - trueChoice: 'accept anyway -- I''ll take my chances' falseChoice: 'um, let me reconsider' icons: #(acceptIcon cancelIcon) - ]. - - ^ true! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3561-AddIconsTo-okayToAccept-HernanWilkinson-2018Dec28-11h27m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3561] on 28 December 2018 at 12:44:11 pm'! -!Browser methodsFor: 'message category functions' stamp: 'HAW 12/28/2018 12:37:44'! - newMethodCategoryNameIfNone: aNoneBlock - - | labels lines menuIndex newName reject | - - labels _ OrderedCollection with: 'new...'. - reject _ Set new. - reject - addAll: self selectedClassOrMetaClass organization categories; - add: ClassOrganizer nullCategory; - add: ClassOrganizer default. - lines _ OrderedCollection new. - self selectedClassOrMetaClass allSuperclasses do: [:cls | | cats | - cls = Object ifFalse: [ - cats _ cls organization categories reject: - [:cat | reject includes: cat]. - cats isEmpty ifFalse: [ - lines add: labels size. - labels addAll: cats asArray sort. - reject addAll: cats]]]. - newName _ (labels size = 1 or: [ - menuIndex _ (PopUpMenu labelArray: labels lines: lines) - startUpWithCaption: 'Add Category'. - menuIndex = 0 ifTrue: [^ aNoneBlock value]. - menuIndex = 1]) - ifTrue: [ - self request: 'Please type new category name' - initialAnswer: 'category name'] - ifFalse: [ - labels at: menuIndex]. - - ^ newName isEmpty - ifTrue: aNoneBlock - ifFalse: [newName asSymbol]. -! ! -!Browser methodsFor: 'system category functions' stamp: 'HAW 12/28/2018 12:37:19'! - newSystemCategoryNameIfNone: aNoneBlock - - | newName | - - newName _ self - request: 'Please type new category name' - initialAnswer: 'Category-Name'. - - ^newName isEmpty - ifTrue: aNoneBlock - ifFalse: [newName asSymbol].! ! -!Browser methodsFor: 'message category functions' stamp: 'HAW 12/28/2018 12:37:56' prior: 50426322! - addCategory - "Present a choice of categories or prompt for a new category name and add it before the current selection, or at the end if no current selection" - - | oldIndex newName | - - selectedClassName ifNil: [ ^self ]. - - oldIndex _ self messageCategoryListIndex. - newName _ self newMethodCategoryNameIfNone: [ ^self ]. - - self classOrMetaClassOrganizer - addCategory: newName - before: selectedMessageCategory. - self changed: #messageCategoryList. - self messageCategoryListIndex: - (oldIndex = 0 - ifTrue: [self classOrMetaClassOrganizer categories size + 1] - ifFalse: [oldIndex]). - self changed: #messageCategoryList. - -! ! -!Browser methodsFor: 'message category functions' stamp: 'HAW 12/28/2018 12:38:40' prior: 50426544! - categorizeUnderNewCategorySelector: aSelectorToCategorize - - self selectedClassOrMetaClass ifNotNil: [ :class | | newCategory | - newCategory _ self newMethodCategoryNameIfNone: [ ^self ]. - class organization - addCategory: newCategory; - classify: aSelectorToCategorize under: newCategory suppressIfDefault: false. - - self changed: #messageCategoryList. - self changed: #messageList]! ! -!Browser methodsFor: 'system category functions' stamp: 'HAW 12/28/2018 12:38:00' prior: 50426594! - addSystemCategory - "Prompt for a new category name and add it before the - current selection, or at the end if no current selection" - - | oldIndex newName | - - oldIndex _ self systemCategoryListIndex. - newName _ self newSystemCategoryNameIfNone: [ ^self ]. - - systemOrganizer - addCategory: newName - before: selectedSystemCategory. - self systemCategoryListIndex: - (oldIndex = 0 - ifTrue: [self systemCategoryList size] - ifFalse: [oldIndex]). - self changed: #systemCategoryList.! ! -!Browser methodsFor: 'system category functions' stamp: 'HAW 12/28/2018 12:38:10' prior: 50426688! - categorizeUnderNewCategoryClass: aClassName - - | newCategory | - - newCategory _ self newSystemCategoryNameIfNone: [ ^self ]. - - systemOrganizer - addCategory: newCategory; - classify: aClassName withBlanksTrimmed asSymbol under: newCategory. - - self changed: #systemCategoryList. - self changed: #classList.! ! - -Browser removeSelector: #categorizeUnderCategoryAt:messageAt:! - -Browser removeSelector: #categorizeUnderCategoryAt:messageAt:! - -Browser removeSelector: #categorizeUnderNewCategoryMessageAt:! - -Browser removeSelector: #categorizeUnderNewCategoryMessageAt:! - -Browser removeSelector: #newCategoryNameIfNone:! - -Browser removeSelector: #newCategoryNameIfNone:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3562-ClassesDragAndDropFix-HernanWilkinson-2018Dec28-12h33m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3562] on 29 December 2018 at 11:17:58 am'! - -ActiveModel subclass: #SimpleServiceEntry - instanceVariableNames: 'provider label selector useLineAfter stateSelector description argumentGetter buttonLabel argumentProvider triggerFileListChanged sortOrder icon ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-FileList'! - -!classDefinition: #SimpleServiceEntry category: #'Tools-FileList'! -ActiveModel subclass: #SimpleServiceEntry - instanceVariableNames: 'provider label selector useLineAfter stateSelector description argumentGetter buttonLabel argumentProvider triggerFileListChanged sortOrder icon' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-FileList'! - -Object subclass: #DropFilesAction - instanceVariableNames: 'shouldAskForCancel dropFilesEvent cancelBlock stopHereBlock selectedFileEntry shouldAskToStop ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Worlds'! - -!classDefinition: #DropFilesAction category: #'Morphic-Worlds'! -Object subclass: #DropFilesAction - instanceVariableNames: 'shouldAskForCancel dropFilesEvent cancelBlock stopHereBlock selectedFileEntry shouldAskToStop' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Worlds'! -!SimpleServiceEntry methodsFor: 'accessing' stamp: 'HAW 12/29/2018 09:55:38'! - icon - - ^icon ! ! -!SimpleServiceEntry methodsFor: 'accessing' stamp: 'HAW 12/29/2018 09:55:29'! - icon: anIcon - - icon := anIcon ! ! -!SimpleServiceEntry class methodsFor: 'instance creation' stamp: 'HAW 12/29/2018 10:21:57'! - provider: anObject label: aString selector: aSymbol description: anotherString buttonLabel: aLabel icon: anIcon - - ^ (self provider: anObject label: aString selector: aSymbol description: anotherString buttonLabel: aLabel) - icon: anIcon; - yourself! ! -!SimpleServiceEntry class methodsFor: 'instance creation' stamp: 'HAW 12/29/2018 10:21:33'! - provider: anObject label: aString selector: aSymbol description: anotherString icon: anIcon - - ^(self provider: anObject label: aString selector: aSymbol description: anotherString) - icon: anIcon; - yourself! ! -!DropFilesAction methodsFor: 'evaluating - private' stamp: 'HAW 12/29/2018 11:14:32'! - createMenuFor: options - - | icons lines labels | - - "options is a small collection, no problem to collect twice - Hernan" - labels := options collect: [ :option | option label ]. - icons := options collect: [ :option | option icon ]. - - shouldAskToStop - ifTrue: [ - lines := Array with: labels size. - labels add: 'stop here'. - icons add: #cancelIcon ] - ifFalse: [ lines := #() ]. - - ^PopUpMenu labelArray: labels lines: lines icons: icons! ! -!DropFilesAction methodsFor: 'evaluating - private' stamp: 'HAW 12/29/2018 11:06:41'! - performService: aService - - aService - argumentProvider: self; - performService -! ! -!DropFilesAction methodsFor: 'FileList protocol' stamp: 'HAW 12/28/2018 20:31:41'! - fullName - - ^selectedFileEntry name ! ! -!DropFilesAction methodsFor: 'FileList protocol' stamp: 'HAW 12/28/2018 20:26:43'! - selectedFileEntry - - ^selectedFileEntry! ! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'HAW 12/29/2018 10:06:58' prior: 50369065! - serviceBrowseCode - "Answer the service of opening a file-contents browser" - - ^ (SimpleServiceEntry - provider: self - label: 'browse code' - selector: #browseCode: - description: 'open a "file-contents browser" on this file, allowing you to view and selectively load its code' - buttonLabel: 'code' - icon: #editFindReplaceIcon) - sortOrder: 10; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'HAW 12/29/2018 10:07:24' prior: 50369081! - serviceBrowsePackage - "Answer the service of opening a file-contents browser" - - ^ (SimpleServiceEntry - provider: self - label: 'browse package' - selector: #browsePackage: - description: 'open a "package file browser" on this file, allowing you to view and selectively load its code' - buttonLabel: 'package browser' - icon: #editFindReplaceIcon) - sortOrder: 10; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!ChangeList class methodsFor: 'fileIn/Out' stamp: 'HAW 12/29/2018 10:01:13' prior: 50369097! - serviceContents - "Answer a service for opening a changelist browser on a file" - - ^ (SimpleServiceEntry - provider: self - label: 'see code file contents' - selector: #browseContents: - description: 'open a code file contents tool on this file' - buttonLabel: 'contents' - icon: #changesIcon) - sortOrder: 20; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!ChangeList class methodsFor: 'fileIn/Out' stamp: 'HAW 12/29/2018 09:59:06' prior: 50369111! - servicePackageContents - "Answer a service for opening a changelist browser on a file" - - ^ (SimpleServiceEntry - provider: self - label: 'see package file contents' - selector: #browsePackageContents: - description: 'open a code file contents tool on this package file' - buttonLabel: 'pck contents' - icon: #changesIcon) - sortOrder: 20; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!ChangeList class methodsFor: 'fileIn/Out' stamp: 'HAW 12/29/2018 10:01:37' prior: 50406250! - serviceRecentChanges - "Answer a service for opening a changelist browser on the tail end of a .changes file" - - ^ SimpleServiceEntry - provider: self - label: 'see recent changes in file' - selector: #browseRecentLogOn: - description: 'open a changelist tool on recent changes in file' - buttonLabel: 'recent changes' - icon: #changesIcon! ! -!FileList methodsFor: 'own services' stamp: 'HAW 12/29/2018 10:23:22' prior: 16842644! - serviceAddNewDirectory - "Answer a service entry characterizing the 'add new directory' command" - - ^ SimpleServiceEntry - provider: self - label: 'add new directory' - selector: #addNewDirectory - description: 'adds a new, empty directory (folder)' - icon: #listAddIcon! ! -!FileList methodsFor: 'own services' stamp: 'HAW 12/29/2018 10:42:05' prior: 16842655! - serviceAddNewFile - "Answer a service entry characterizing the 'add new file' command" - - ^ SimpleServiceEntry - provider: self - label: 'add new file' - selector: #addNewFile - description: 'create a new,. empty file, and add it to the current directory.' - icon: #newIcon! ! -!FileList methodsFor: 'own services' stamp: 'HAW 12/29/2018 10:24:39' prior: 16842665! - serviceCopyName - - ^ SimpleServiceEntry - provider: self - label: 'copy name to clipboard' - selector: #copyName - description:'copy name to clipboard' - icon: #copyIcon! ! -!FileList methodsFor: 'own services' stamp: 'HAW 12/29/2018 10:26:03' prior: 16842672! - serviceDeleteFile - - ^ SimpleServiceEntry - provider: self - label: 'delete' - selector: #deleteFile - description: 'delete the seleted item' - icon: #deleteIcon! ! -!FileList methodsFor: 'own services' stamp: 'HAW 12/29/2018 10:41:24' prior: 16842679! - serviceGet - "Answer a service for getting the entire file" - - ^ SimpleServiceEntry - provider: self - label: 'get entire file' - selector: #get - description: 'if the file has only been partially read in, because it is very large, read the entire file in at this time.' - icon: #textEditorIcon! ! -!FileList methodsFor: 'own services' stamp: 'HAW 12/29/2018 10:40:08' prior: 16842690! - serviceGetHex - - ^ SimpleServiceEntry - provider: self - label: 'view as hex' - selector: #getHex - description: 'view as hex' - icon: #fontXGenericIcon! ! -!FileList methodsFor: 'own services' stamp: 'HAW 12/29/2018 10:27:40' prior: 16842697! - serviceRenameFile - - ^ SimpleServiceEntry - provider: self - label: 'rename' - selector: #renameFile - description: 'rename file' - icon: #saveAsIcon! ! -!FileList methodsFor: 'own services' stamp: 'HAW 12/29/2018 10:31:06' prior: 16842704! - serviceSortByDate - "Answer a service for sorting by date" - | buttonLabel | - buttonLabel _ sortMode = #date - ifTrue: [ - sortAscending - ifTrue: [ '[^] - date' ] - ifFalse: [ '[v] - date' ]] - ifFalse: [ 'date' ]. - ^ (SimpleServiceEntry - provider: self - label: 'by date' - selector: #sortByDate - description: 'sort entries by date' - icon: #sendReceiveIcon) - extraSelector: #sortingByDate; - buttonLabel: buttonLabel! ! -!FileList methodsFor: 'own services' stamp: 'HAW 12/29/2018 10:31:00' prior: 16842720! - serviceSortByName - "Answer a service for soring by name" - | buttonLabel | - buttonLabel _ sortMode = #name - ifTrue: [ - sortAscending - ifTrue: [ '[^] - name' ] - ifFalse: [ '[v] - name' ]] - ifFalse: [ 'name' ]. - ^ (SimpleServiceEntry - provider: self - label: 'by name' - selector: #sortByName - description: 'sort entries by name' - icon: #sendReceiveIcon) - extraSelector: #sortingByName; - buttonLabel: buttonLabel! ! -!FileList methodsFor: 'own services' stamp: 'HAW 12/29/2018 10:29:42' prior: 16842735! - serviceSortBySize - "Answer a service for sorting by size" - | buttonLabel | - buttonLabel _ sortMode = #size - ifTrue: [ - sortAscending - ifTrue: [ '[^] - size' ] - ifFalse: [ '[v] - size' ]] - ifFalse: [ 'size' ]. - ^ (SimpleServiceEntry - provider: self - label: 'by size' - selector: #sortBySize - description: 'sort entries by size' - icon: #sendReceiveIcon) - extraSelector: #sortingBySize; - buttonLabel: buttonLabel.! ! -!FileList methodsFor: 'own services' stamp: 'HAW 12/29/2018 10:33:04' prior: 16842750! - serviceViewContentsInWorkspace - "Answer a service for viewing the contents of a file in a workspace" - - ^ SimpleServiceEntry - provider: self - label: 'workspace with contents' - selector: #viewContentsInWorkspace - description: 'open a new Workspace whose contents are set to the contents of this file' - icon: #terminalIcon! ! -!SimpleServiceEntry methodsFor: 'services menu' stamp: 'HAW 12/29/2018 10:20:15' prior: 50392965! - addServiceFor: served toMenu: aMenu - argumentProvider _ served. - aMenu - add: self label - target: self - action: #performService - icon: icon. - self useLineAfter ifTrue: [ aMenu addLine ].! ! -!SimpleServiceEntry methodsFor: 'initialization' stamp: 'HAW 12/29/2018 10:20:39' prior: 50369303! - initialize - - triggerFileListChanged _ false. - sortOrder _ 1. - icon _ nil.! ! -!DropFilesAction methodsFor: 'initialization' stamp: 'HAW 12/29/2018 11:14:32' prior: 50424852! - initializeFor: aDropFilesEvent - - dropFilesEvent := aDropFilesEvent. - shouldAskToStop := aDropFilesEvent numberOfFiles > 1! ! -!DropFilesAction methodsFor: 'evaluating' stamp: 'HAW 12/29/2018 11:14:49' prior: 50424859! - value - - stopHereBlock := [ ^self ]. - dropFilesEvent fileNamesDo: [ :fileName | self fileNamedDropped: fileName ] - -! ! -!DropFilesAction methodsFor: 'evaluating - private' stamp: 'HAW 12/29/2018 11:15:10' prior: 50426448! - fileNamedDropped: aFileName - - | options selectionIndex menu | - - selectedFileEntry := aFileName asFileEntry. - options := FileList itemsForFile: aFileName. - options isEmpty ifTrue: [ ^self inform: 'No action found for ', selectedFileEntry name ]. - menu := self createMenuFor: options. - - selectionIndex := menu startUpWithCaption: 'Select action for ', selectedFileEntry name. - - selectionIndex = 0 ifTrue: [ ^self ]. - (options isInBounds: selectionIndex) ifTrue: [ ^self performService: (options at: selectionIndex) ]. - "The only available option is 'stop here'. This could change if #createMenuFor: changes - Hernan" - stopHereBlock value - -! ! -!ChangeSet class methodsFor: 'file list services' stamp: 'HAW 12/29/2018 10:04:54' prior: 50369154! - serviceFileIn - "Answer a service for filing in an entire file" - - ^ (SimpleServiceEntry - provider: self - label: 'file in' - selector: #fileIn: - description: 'file in the entire contents of the file, which is expected to contain Smalltalk code in fileout ("chunk") format' - buttonLabel: 'filein' - icon: #saveIcon) - sortOrder: 100; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!ChangeSet class methodsFor: 'file list services' stamp: 'HAW 12/29/2018 10:05:49' prior: 50369170! - serviceInstall - "Answer a service for filing in an entire file" - - ^ (SimpleServiceEntry - provider: self - label: 'install code' - selector: #install: - description: 'install change set' - buttonLabel: 'install' - icon: #saveIcon) - sortOrder: 100; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!CodePackageFile class methodsFor: 'file list services' stamp: 'HAW 12/29/2018 10:16:53' prior: 50407043! - serviceInstallPackage - "Answer the service of installing a CodePackageFile (a chunk format file for a CodePackage)" - - ^ (SimpleServiceEntry - provider: self - label: 'install package' - selector: #installPackage: - description: 'install the package, replacing all existing code in the package (if any); create a new change set just for the installation' - buttonLabel: 'install package' - icon: #saveIcon) - sortOrder: 100; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! - -DropFilesAction removeSelector: #ask:onYes:! - -DropFilesAction removeSelector: #ask:onYes:! - -DropFilesAction removeSelector: #canBeFiledIn:! - -DropFilesAction removeSelector: #canBeFiledIn:! - -DropFilesAction removeSelector: #canBeInstalled:! - -DropFilesAction removeSelector: #canBeInstalled:! - -DropFilesAction removeSelector: #ifUserWantsFileIn:! - -DropFilesAction removeSelector: #ifUserWantsFileIn:! - -DropFilesAction removeSelector: #ifUserWantsInstall:! - -DropFilesAction removeSelector: #ifUserWantsInstall:! - -DropFilesAction removeSelector: #isAChangeSet:! - -DropFilesAction removeSelector: #isChangeSet:! - -ActiveModel subclass: #SimpleServiceEntry - instanceVariableNames: 'provider label selector useLineAfter stateSelector description argumentGetter buttonLabel argumentProvider triggerFileListChanged sortOrder icon' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-FileList'! - -!classDefinition: #SimpleServiceEntry category: #'Tools-FileList'! -ActiveModel subclass: #SimpleServiceEntry - instanceVariableNames: 'provider label selector useLineAfter stateSelector description argumentGetter buttonLabel argumentProvider triggerFileListChanged sortOrder icon' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-FileList'! - -Object subclass: #DropFilesAction - instanceVariableNames: 'dropFilesEvent selectedFileEntry shouldAskToStop stopHereBlock' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Worlds'! - -!classDefinition: #DropFilesAction category: #'Morphic-Worlds'! -Object subclass: #DropFilesAction - instanceVariableNames: 'dropFilesEvent selectedFileEntry shouldAskToStop stopHereBlock' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Worlds'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3563-DropFileEnhancements-HernanWilkinson-2018Dec28-17h36m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3562] on 29 December 2018 at 11:34:36 am'! -!SystemDictionary methodsFor: 'testing' stamp: 'HAW 12/29/2018 11:34:08'! - isLiveTypingInstalled - - ^(FeatureRequirement name: #LiveTyping) isAlreadySatisfied! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 12/29/2018 11:34:08' prior: 50423945! - returnTypeOfEnclosedExpressionAt: aRange - - Smalltalk isLiveTypingInstalled ifFalse: [ ^nil ]. - - ^self - withParserSourceMethodNodeDo: [ :methodNode | self returnTypeOfEnclosedExpresionIn: methodNode at: aRange end ] - ifError: [ :anError | nil ]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 12/29/2018 11:34:08' prior: 50423956! - returnTypeOfUnaryMessage: aSelector at: aRange - - Smalltalk isLiveTypingInstalled ifFalse: [ ^nil ]. - - ^self - withParserSourceMethodNodeDo: [ :methodNode | self returnTypeOfNodeUnderCursorIn: methodNode at: aRange end] - ifError: [ :anError | nil ]! ! - -SystemDictionary removeSelector: #isLiveTypeInformationInstalled! - -SystemDictionary removeSelector: #isLiveTypeInformationInstalled! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3564-LiveTyping-Enhancements-HernanWilkinson-2018Dec29-11h17m-HAW.1.cs.st----! - -----SNAPSHOT----#(1 January 2019 8:24:54.397819 pm) Cuis5.0-3564-32.image priorSource: 2972203! - -----QUIT----#(1 January 2019 8:25:15.549228 pm) Cuis5.0-3564-32.image priorSource: 3065141! - -----STARTUP----#(28 January 2019 10:37:51.345044 am) as /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/Cuis5.0-3564-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3562] on 8 January 2019 at 4:25:22 pm'! -!Parser methodsFor: 'scanning' stamp: 'HAW 1/8/2019 16:24:45'! - compensateTwoCharacterLookahead - - ^source position - (aheadChar == self doItCharacter ifTrue: [hereChar == self doItCharacter ifTrue: [0] ifFalse: [1]] ifFalse: [2]) - ! ! -!Scanner methodsFor: 'expression types' stamp: 'HAW 1/8/2019 16:21:59' prior: 50410010! - scanAllTokenPositionsInto: aBlock - "Evaluate aBlock with the start and end positions of all separate non-white-space tokens, including comments." - - | lastMark | - lastMark := 1. - [currentComment ifNotNil: - [currentComment do: - [:cmnt| | idx | - idx := source originalContents indexOfSubCollection: cmnt startingAt: lastMark. - (idx > 0 and: [idx < mark]) ifTrue: - [aBlock value: idx - 1 value: (lastMark := idx + cmnt size)]]. - currentComment := nil]. - mark ifNotNil: - [(token == #- - and: [(self typeTableAt: hereChar) == #xDigit]) ifTrue: - [| savedMark | - savedMark := mark. - self scanToken. - token := token negated. - mark := savedMark]. - "Compensate for the fact that the parser uses two character lookahead. Normally we must - remove the extra two characters. But this mustn't happen for the last token at the end of stream." - aBlock - value: mark - value: (source position - (aheadChar == self doItCharacter ifTrue: [hereChar == self doItCharacter ifTrue: [0] ifFalse: [1]] ifFalse: [2]))]. - (tokenType == #rightParenthesis - or: [tokenType == #doIt]) ifTrue: - [^self]. - tokenType == #leftParenthesis - ifTrue: - [self scanToken; scanAllTokenPositionsInto: aBlock] - ifFalse: - [(tokenType == #word or: [tokenType == #keyword or: [tokenType == #colon]]) - ifTrue: - [self scanLitWord. - token == #true ifTrue: [token := true]. - token == #false ifTrue: [token := false]. - token == #nil ifTrue: [token := nil]] - ifFalse: - [(token == #- - and: [(self typeTableAt: hereChar) == #xDigit]) - ifTrue: - [self scanToken. - token := token negated]]]. - self scanToken ] repeat! ! -!Parser methodsFor: 'scanning' stamp: 'HAW 1/8/2019 16:21:24' prior: 50410214! - advance - | this | - prevMark := hereMark. - prevEnd := hereEnd. - this := here. - here := token. - hereType := tokenType. - hereMark := mark. - hereEnd := source position - (aheadChar == self doItCharacter ifTrue: [hereChar == self doItCharacter ifTrue: [0] ifFalse: [1]] ifFalse: [2]). - self scanToken. - "Transcript show: 'here: ', here printString, ' mark: ', hereMark printString, ' end: ', hereEnd printString; cr." - ^this! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3565-ParserFix-HernanWilkinson-2019Jan08-11h39m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3562] on 8 January 2019 at 4:27:21 pm'! -!Scanner methodsFor: 'expression types' stamp: 'HAW 1/8/2019 16:26:05' prior: 50427458! - scanAllTokenPositionsInto: aBlock - "Evaluate aBlock with the start and end positions of all separate non-white-space tokens, including comments." - - | lastMark | - lastMark := 1. - [currentComment ifNotNil: - [currentComment do: - [:cmnt| | idx | - idx := source originalContents indexOfSubCollection: cmnt startingAt: lastMark. - (idx > 0 and: [idx < mark]) ifTrue: - [aBlock value: idx - 1 value: (lastMark := idx + cmnt size)]]. - currentComment := nil]. - mark ifNotNil: - [(token == #- - and: [(self typeTableAt: hereChar) == #xDigit]) ifTrue: - [| savedMark | - savedMark := mark. - self scanToken. - token := token negated. - mark := savedMark]. - "Compensate for the fact that the parser uses two character lookahead. Normally we must - remove the extra two characters. But this mustn't happen for the last token at the end of stream." - aBlock - value: mark - value: self compensateTwoCharacterLookahead ]. - (tokenType == #rightParenthesis - or: [tokenType == #doIt]) ifTrue: - [^self]. - tokenType == #leftParenthesis - ifTrue: - [self scanToken; scanAllTokenPositionsInto: aBlock] - ifFalse: - [(tokenType == #word or: [tokenType == #keyword or: [tokenType == #colon]]) - ifTrue: - [self scanLitWord. - token == #true ifTrue: [token := true]. - token == #false ifTrue: [token := false]. - token == #nil ifTrue: [token := nil]] - ifFalse: - [(token == #- - and: [(self typeTableAt: hereChar) == #xDigit]) - ifTrue: - [self scanToken. - token := token negated]]]. - self scanToken ] repeat! ! -!Parser methodsFor: 'scanning' stamp: 'HAW 1/8/2019 16:25:50' prior: 50427513! - advance - | this | - prevMark := hereMark. - prevEnd := hereEnd. - this := here. - here := token. - hereType := tokenType. - hereMark := mark. - hereEnd := self compensateTwoCharacterLookahead. - self scanToken. - "Transcript show: 'here: ', here printString, ' mark: ', hereMark printString, ' end: ', hereEnd printString; cr." - ^this! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3566-ParserFix-HernanWilkinson-2019Jan08-16h25m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3562] on 2 January 2019 at 7:08:02 pm'! -!FileList methodsFor: 'own services' stamp: 'HAW 1/2/2019 19:06:52' prior: 50427155! - serviceGetHex - - ^ SimpleServiceEntry - provider: self - label: 'view as hex' - selector: #getHex - description: 'view as hex' - icon: #preferencesDesktopFontIcon! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3567-HexFileListIcon-HernanWilkinson-2018Dec29-11h34m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3562] on 7 January 2019 at 4:06:33 pm'! -!CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'HAW 1/3/2019 07:04:14'! - removeProperties - - self penultimateLiteral: self selector! ! -!CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'HAW 1/3/2019 07:06:51'! - withPropertiesDo: withBlock - - ^self withPropertiesDo: withBlock ifSelector: [ :selector | nil ]! ! -!CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'HAW 1/3/2019 07:03:13'! -withPropertiesDo: withBlock ifSelector: notBlock - - | penultimalLiteral | - - penultimalLiteral := self penultimateLiteral. - - ^penultimalLiteral isMethodProperties - ifTrue: [ withBlock value: penultimalLiteral ] - ifFalse: [ notBlock value: penultimalLiteral ]! ! -!CompiledMethod methodsFor: 'accessing' stamp: 'HAW 1/3/2019 07:03:14' prior: 16819533! - properties - - "Answer the method properties of the receiver." - - ^self - withPropertiesDo: [ :properties | properties ] - ifSelector: [ :selector | AdditionalMethodState forMethod: self selector: selector ]! ! -!CompiledMethod methodsFor: 'accessing' stamp: 'HAW 1/7/2019 15:49:22' prior: 16819588! - selector - "Answer a method's selector. This is either the penultimate literal, - or, if the method has any properties or pragmas, the selector of - the MethodProperties stored in the penultimate literal." - - ^self - withPropertiesDo: [ :properties | properties selector ] - ifSelector: [ :selector | selector ] -! ! -!CompiledMethod methodsFor: 'accessing' stamp: 'HAW 1/7/2019 15:56:36' prior: 16819602! - selector: aSelector - "Set a method's selector. This is either the penultimate literal, - or, if the method has any properties or pragmas, the selector of - the MethodProperties stored in the penultimate literal." - - | numberOfLiterals | - - self - withPropertiesDo: [ :properties | properties selector: aSelector ] - ifSelector: [ :selector | - (numberOfLiterals := self numLiterals) < 2 ifTrue: [self error: 'insufficient literals to hold selector']. - self literalAt: numberOfLiterals - 1 put: aSelector]! ! -!CompiledMethod methodsFor: 'literals' stamp: 'HAW 1/3/2019 07:06:51' prior: 16820025! - hasLiteralSuchThat: litBlock - "Answer true if litBlock returns true for any literal in this method, even if embedded in array structure." - - | lit | - - self withPropertiesDo: [ :properties | (properties hasLiteralSuchThat: litBlock) ifTrue: [ ^true ]]. - - 2 to: self numLiterals + 1 do: [ :index | - lit := self objectAt: index. - ((litBlock value: lit) - or: [lit isArray and: [lit hasLiteralSuchThat: litBlock]]) ifTrue: - [^true]]. - ^false! ! -!CompiledMethod methodsFor: 'literals' stamp: 'HAW 1/3/2019 07:06:51' prior: 16820042! - hasLiteralThorough: literal - "Answer true if any literal in this method is literal, - even if embedded in array structure." - - | lit | - - self withPropertiesDo: [ :properties | (properties hasLiteralThorough: literal) ifTrue:[^true]]. - - 2 to: self numLiterals - 1 "exclude superclass + selector/properties" - do: [ :index | - (((lit := self objectAt: index) literalEqual: literal) - or: [(lit isVariableBinding and: [lit key == literal]) - or: [lit isArray and: [lit hasLiteral: literal]]]) ifTrue: - [^ true]]. - ^ false ! ! -!CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'HAW 1/3/2019 07:03:14' prior: 16820939! - pragmaAt: aKey - - "Answer the pragma with selector aKey, or nil if none." - - ^self withPropertiesDo: [ :properties | properties at: aKey ifAbsent: nil ] ifSelector: [ :selector | nil ]. - ! ! -!CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'HAW 1/3/2019 07:03:14' prior: 16820950! - pragmas - - ^self withPropertiesDo: [ :properties | properties pragmas ] ifSelector: [ :selector | #() ]! ! -!CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'HAW 1/3/2019 07:18:59' prior: 16820959! - propertyKeysAndValuesDo: aBlock - - "Enumerate the receiver with all the keys and values." - - self withPropertiesDo: [ :properties | properties propertyKeysAndValuesDo: aBlock]! ! -!CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'HAW 1/3/2019 16:57:04' prior: 16820970! - propertyValueAt: propName - - ^self withPropertiesDo: [ :properties | properties propertyValueAt: propName ifAbsent: nil] ! ! -!CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'HAW 1/3/2019 17:01:07' prior: 16820980! - propertyValueAt: propName ifAbsent: aBlock - - ^self withPropertiesDo: [ :properties | properties propertyValueAt: propName ifAbsent: aBlock ] ifSelector: [ :selector | aBlock value ] - ! ! -!CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'HAW 1/7/2019 15:45:43' prior: 16820991! - propertyValueAt: propName put: propValue - "Set or add the property with key propName and value propValue. - If the receiver does not yet have a method properties create one and replace - the selector with it. Otherwise, either relace propValue in the method properties - or replace method properties with one containing the new property." - - self - withPropertiesDo: [:properties | - (properties includesProperty: propName) ifTrue: [^properties at: propName put: propValue]. - self penultimateLiteral: (properties - copyWith: (Association - key: propName asSymbol - value: propValue)). - ^propValue ] - ifSelector: [ :selector | - self penultimateLiteral: ((AdditionalMethodState - selector: selector - with: (Association - key: propName asSymbol - value: propValue)) - setMethod: self; - yourself). - ^propValue].! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3568-CompiledMethodPropertiesCleanup-HernanWilkinson-2019Jan02-19h08m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3562] on 7 January 2019 at 4:23:57 pm'! -!ClassBuilder methodsFor: 'validation' stamp: 'HAW 1/7/2019 16:20:34'! - doesClassNameStartWithUppercase: aClassName - - ^ aClassName first isUppercase! ! -!ClassBuilder methodsFor: 'validation' stamp: 'HAW 1/7/2019 16:20:34' prior: 16803747! - validateClassName: aString - "Validate the new class name" - - (self doesClassNameStartWithUppercase: aString) ifFalse:[ - self error: 'Class names must be capitalized'. - ^false]. - Smalltalk at: aString ifPresent:[:old| - (old isKindOf: Behavior) ifFalse:[ - self notify: aString asText allBold, - ' already exists!!\Proceed will store over it.' withNewLines]]. - ^true! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3569-Tweak-HernanWilkinson-2019Jan07-16h06m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3569] on 8 January 2019 at 5:28:27 pm'! -!ProcessBrowser class methodsFor: 'process control' stamp: 'jmv 1/8/2019 17:27:55' prior: 16895117! - rulesFor: aProcess - "Answer two flags: allow-stop, and allow-debug" - - "Don't mess with the process running the ProcessBrowser. - If we support several active UIs, we'd detect the UI process running us" - self flag: #jmvVer2. - aProcess == Processor activeProcess - ifTrue: [^{false. false}]. - - aProcess name = 'Sound Player' - ifTrue: [ ^{false. false}]. - - ^ [aProcess caseOf: { - [] -> [{false. false}]. - [Smalltalk lowSpaceWatcherProcess] -> [{false. false}]. - [WeakArray runningFinalizationProcess] -> [{false. false}]. - [Processor activeProcess] -> [{false. true}]. - [Processor backgroundProcess] -> [{false. false}]. - [Sensor interruptWatcherProcess] -> [{false. false}]. - [Sensor eventTicklerProcess] -> [{false. false}]. - [CPUWatcher currentWatcherProcess] -> [{false. false}]. - [Delay timerProcess] -> [{false. false}]} - otherwise: [ {true. true}]] - ifError: [ :err :rcvr | {true. true}]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3570-rulesForFix-JuanVuletich-2019Jan08-17h27m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3562] on 7 January 2019 at 10:46:01 pm'! -!ClassBuilder class methodsFor: 'accessing' stamp: 'HAW 1/7/2019 22:32:41'! - reservedNames - - "Return a list of names that must not be used for variables" - - ^#(#self #super #true #false #nil #thisContext)! ! -!ClassBuilder methodsFor: 'private' stamp: 'HAW 1/7/2019 22:32:29' prior: 50368684! - reservedNames - - "Return a list of names that must not be used for variables" - - ^self class reservedNames ! ! -!Theme methodsFor: 'private - shout mappings' stamp: 'HAW 1/7/2019 22:33:06' prior: 16935932! - pseudoVariables - - ^ ClassBuilder reservedNames ! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3571-ClassBuilderCleanup-HernanWilkinson-2019Jan07-17h05m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3562] on 8 January 2019 at 5:05:17 pm'! - -Object subclass: #Scanner - instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable isForTokenization sentInLiterals ignoreBacktick ' - classVariableNames: 'TypeTable DoItCharacter ' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #Scanner category: #'Compiler-Kernel'! -Object subclass: #Scanner - instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable isForTokenization sentInLiterals ignoreBacktick' - classVariableNames: 'DoItCharacter TypeTable' - poolDictionaries: '' - category: 'Compiler-Kernel'! -!Scanner class methodsFor: 'class initialization' stamp: 'HAW 1/8/2019 17:02:07'! - initializeDoitCharacter - - DoItCharacter := self doItCharacterValue asCharacter ! ! -!Scanner class methodsFor: 'class initialization' stamp: 'HAW 1/8/2019 17:01:11' prior: 16904320! - initialize - " - Scanner initialize - " - self initTypeTable. - self initializeDoitCharacter! ! - -Object subclass: #Scanner - instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable isForTokenization sentInLiterals ignoreBacktick' - classVariableNames: 'DoItCharacter TypeTable' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #Scanner category: #'Compiler-Kernel'! -Object subclass: #Scanner - instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable isForTokenization sentInLiterals ignoreBacktick' - classVariableNames: 'DoItCharacter TypeTable' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -Scanner initialize! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3572-SlightParserSpeedup-HernanWilkinson-2019Jan08-16h27m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3562] on 8 January 2019 at 5:13:05 pm'! -!Scanner methodsFor: 'expression types' stamp: 'HAW 1/8/2019 17:08:16' prior: 50410066! - step - - | c | - c := hereChar. - hereChar := aheadChar. - source atEnd - ifTrue: [aheadChar := DoItCharacter "doit"] - ifFalse: [aheadChar := source next]. - ^c! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'HAW 1/8/2019 17:08:09' prior: 50410243! - readUpToNext: aChar ifNotFound: aNotFoundBlock - - self step. - buffer reset. - - [self isAt: aChar] - whileFalse: - [buffer nextPut: self step. - (hereChar == DoItCharacter and: [source atEnd]) ifTrue: [^aNotFoundBlock value ]]. - - self step. - token := buffer contents. - ! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'HAW 1/8/2019 17:10:01' prior: 50410085! - xDigit - "Form a number." - - tokenType := #number. - (aheadChar == DoItCharacter and: [source atEnd - and: [source skip: -1. source next ~~ DoItCharacter]]) - ifTrue: [source skip: -1 "Read off the end last time"] - ifFalse: [source skip: -2]. - token := [Number readFrom: source] ifError: [:err :rcvr | self offEnd: err]. - self step; step! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'HAW 1/8/2019 17:10:14' prior: 50410099! - xDoubleQuote - "Collect a comment." - "wod 1/10/98: Allow 'empty' comments by testing the first character -for $"" rather than blindly adding it to the comment being collected." - | aStream stopChar | - stopChar := DoItCharacter. - aStream := WriteStream on: (String new: 200). - self step. - [hereChar == $"] - whileFalse: - [(hereChar == stopChar and: [source atEnd]) - ifTrue: [^self offEnd: 'Unmatched comment quote']. - aStream nextPut: self step.]. - self step. - currentComment == nil - ifTrue: [currentComment := OrderedCollection with: aStream contents] - ifFalse: [currentComment add: aStream contents]. - self scanToken! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'HAW 1/8/2019 17:10:25' prior: 50410125! - xLetter - "Form a word or keyword." - - | type | - buffer reset. - [(type := self typeTableAt: hereChar) == #xLetter - or: [type == #xDigit - or: [type == #xUnderscore]]] whileTrue: - ["open code step for speed" - buffer nextPut: hereChar. - hereChar := aheadChar. - aheadChar := source atEnd - ifTrue: [DoItCharacter "doit"] - ifFalse: [source next]]. - tokenType := (type == #colon or: [type == #xColon and: [aheadChar ~~ $=]]) - ifTrue: - [buffer nextPut: self step. - "Allow any number of embedded colons in literal symbols" - [(self typeTableAt: hereChar) == #xColon] whileTrue: - [buffer nextPut: self step]. - #keyword] - ifFalse: - [#word]. - token := buffer contents! ! -!Parser methodsFor: 'scanning' stamp: 'HAW 1/8/2019 17:07:55' prior: 50427449! - compensateTwoCharacterLookahead - - ^source position - (aheadChar == DoItCharacter ifTrue: [hereChar == DoItCharacter ifTrue: [0] ifFalse: [1]] ifFalse: [2]) - ! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3573-SlightParserSpeedup-HernanWilkinson-2019Jan08-17h05m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3562] on 8 January 2019 at 5:37:28 pm'! - -Scanner removeSelector: #doItCharacter! - -Scanner removeSelector: #doItCharacter! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3574-SlightParserSpeedup-HernanWilkinson-2019Jan08-17h13m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3574] on 9 January 2019 at 12:29:29 pm'! -!TextEditor methodsFor: 'private' stamp: 'AY 1/2/2019 22:24:14'! - firstOfBeginningOfLineOrEndOfIndentationLeftOf: position - - "Returns the first of beginning-of-line or end-of-indentation that appears to the left of the given position, wrapping around to the end of the line (i.e. the line is considered circular). - This way, if the given position is beginning-of-line then end-of-indentation is returned." - - | currentLine beginningOfLine endOfIndentation stops | - - currentLine _ textComposition lines at: (textComposition lineIndexFor: position). - beginningOfLine _ currentLine first. - endOfIndentation _ self privateCurrentString - skipDelimiters: (String with: Character tab) - startingAt: beginningOfLine. - - stops _ OrderedCollection with: endOfIndentation with: beginningOfLine. - ^ stops detect: [ :stop | stop < position ] ifNone: [endOfIndentation]! ! -!Editor methodsFor: 'private' stamp: 'AY 1/9/2019 12:18:54' prior: 16836757! - beginningOfParagraph: position - | s | - s _ self privateCurrentString. - ^ (s - lastIndexOf: Character newLineCharacter - startingAt: (position-1 min: s size) - ifAbsent: [ 0 ]) - + 1.! ! -!TextEditor methodsFor: 'nonediting/nontyping keys' stamp: 'AY 1/9/2019 12:29:03' prior: 16932328! - cursorEnd: aKeyboardEvent - - "Private - Move cursor end of current line." - - self - moveCursor: [ :position | - "Mac standard keystrole" - (aKeyboardEvent commandAltKeyPressed or: [ - "Windows / Linux standard keystroke" - aKeyboardEvent controlKeyPressed ]) - ifTrue: [ self endOfText ] - ifFalse: [ self endOfLine: position ]] - forward: true - event: aKeyboardEvent. - ^true! ! -!TextEditor methodsFor: 'nonediting/nontyping keys' stamp: 'AY 1/9/2019 12:28:01' prior: 16932347! - cursorHome: aKeyboardEvent - - "Private - Move cursor from position in current line to beginning of current line or end of indentation (see #firstOfBeginningOfLineOrEndOfIndentationLeftOf:). - If control key is pressed put cursor at beginning of text" - - self - moveCursor: [ :position | - "Mac standard keystrole" - (aKeyboardEvent commandAltKeyPressed or: [ - "Windows / Linux standard keystroke" - aKeyboardEvent controlKeyPressed ]) - ifTrue: [ self beginningOfText ] - ifFalse: [ self firstOfBeginningOfLineOrEndOfIndentationLeftOf: position ]] - forward: false - event: aKeyboardEvent. - ^true! ! -!TextEditor methodsFor: 'private' stamp: 'jmv 1/9/2019 12:27:48' prior: 16932811! - sameColumn: start newLine: lineBlock forward: isForward - "Private - Compute the index in my text - with the line number derived from lineBlock," - " a one argument block accepting the old line number. - The position inside the line will be preserved as good as possible" - "The boolean isForward is used in the border case to determine if - we should move to the beginning or the end of the line." - | column currentLine offsetAtTargetLine targetEOL lines numberOfLines currentLineNumber targetLineNumber | - lines _ textComposition lines. - numberOfLines _ textComposition numberOfLines. - currentLineNumber _ textComposition lineIndexFor: start. - currentLine _ lines at: currentLineNumber. - column _ start - currentLine first. - targetLineNumber _ ((lineBlock value: currentLineNumber) max: 1) min: numberOfLines. - offsetAtTargetLine _ (lines at: targetLineNumber) first. - targetEOL _ (lines at: targetLineNumber) last + (targetLineNumber = numberOfLines ifTrue:[1]ifFalse:[0]). - targetLineNumber = currentLineNumber - "No movement or movement failed. Move to beginning or end of line." - ifTrue:[ - ^isForward - ifTrue:[targetEOL] - ifFalse:[offsetAtTargetLine]]. - ^offsetAtTargetLine + column min: targetEOL.! ! - -Preferences class removeSelector: #wordStyleCursorMovement! - -Preferences class removeSelector: #wordStyleCursorMovement! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3575-CursorHomeEnh-AngelYan-JuanVuletich-2019Jan09-12h09m-AY.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3575] on 11 January 2019 at 4:57:40 pm'! - -Error subclass: #AttemptToMutateObjectInCallStack - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #AttemptToMutateObjectInCallStack category: #'Exceptions Kernel'! -Error subclass: #AttemptToMutateObjectInCallStack - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! -!AttemptToMutateObjectInCallStack commentStamp: '' prior: 0! - A become operation tries to mutate an object that is the receiver ('self') in a method currently in execution, and part of the stack of calls of some process.! -!ProcessorScheduler methodsFor: 'accessing' stamp: 'jmv 1/11/2019 11:08:09'! - anyReceiverInStackIn: anArray - "Iterate over all methods currently in execution. Answer true if in any of them 'self' an element of argument" - " - Processor anyReceiverInStackIn: { self runningWorld } - Processor anyReceiverInStackIn: { Object new } - " - self processesDo: [ :p | ] withStackFramestDo: [ :p :c | - (anArray statePointsTo: c receiver) - ifTrue: [ ^ true ]]. - ^ false! ! -!ProcessorScheduler methodsFor: 'accessing' stamp: 'jmv 1/11/2019 11:11:48'! - anyReceiverInStackIn: anArray orIn: anotherArray - "Iterate over all methods currently in execution. Answer true if in any of them 'self' an element of argument" - " - Processor anyReceiverInStackIn: {} orIn: { self runningWorld } - Processor anyReceiverInStackIn: {} orIn: { Object new } - " - self processesDo: [ :p | ] withStackFramestDo: [ :p :c | | r | - r _ c receiver. - (anArray statePointsTo: r) - ifTrue: [ ^ true ]. - (anotherArray statePointsTo: r) - ifTrue: [ ^ true ]]. - ^ false! ! -!ProcessorScheduler methodsFor: 'accessing' stamp: 'jmv 1/9/2019 16:02:19'! - anyReceiverInStackIsKindOf: aClass - "Iterate over all methods currently in execution. Answer true if in any of them 'self' is a (sub)instance of aClass" - " - Processor anyReceiverInStackIsKindOf: Morph - Processor anyReceiverInStackIsKindOf: DifferenceFinder - " - self processesDo: [ :p | ] withStackFramestDo: [ :p :c | - (c receiver isKindOf: aClass) - ifTrue: [ ^ true ]]. - ^ false! ! -!ProcessorScheduler methodsFor: 'accessing' stamp: 'jmv 1/9/2019 15:54:20'! - processesDo: aBlock - "Iterate over processes that can run" - " - Processor processesDo: [ :p | p print ]. - " - Process allSubInstancesDo: [ :p | - p isTerminated ifFalse: [ - aBlock value: p ]]! ! -!ProcessorScheduler methodsFor: 'accessing' stamp: 'jmv 1/9/2019 15:59:16'! - processesDo: aBlock withStackFramestDo: twoArgBlock - "Iterate over processes that can run. - For each process, iterate over stack frames (i.e. contexts)." - " - Processor - processesDo: [ :p | - '--------------' print. - p print. - '--------------' print ] - withStackFramestDo: [ :p :c | - (' ', c printString) print ]. - " - self processesWithTopContextDo: [ :process :topContext | | context | - aBlock value: process. - context _ topContext. - [ context notNil ] whileTrue: [ - twoArgBlock value: process value: context. - context _ context sender ]]! ! -!ProcessorScheduler methodsFor: 'accessing' stamp: 'jmv 1/9/2019 15:54:54'! - processesWithTopContextDo: aBlock - "Iterate over processes that can run. Include top context in block arguments." - " - Processor processesWithTopContextDo: [ :p :c | p print. ('------->', c printString) print ]. - " - self processesDo: [ :process | - aBlock - value: process - value: (process isRunning ifTrue: [ thisContext ] ifFalse: [ process suspendedContext ]) ]! ! -!ProtoObject methodsFor: 'system primitives' stamp: 'jmv 1/11/2019 16:52:15' prior: 16896514! - become: otherObject - "Primitive. Swap the object pointers of the receiver and the argument. - All variables in the entire system that used to point to the - receiver now point to the argument, and vice-versa. - Fails if either object is a SmallInteger" - - | oldObjects newObjects | - oldObjects _ { self }. - newObjects _ { otherObject }. - self class == otherObject class ifFalse: [ - (Processor anyReceiverInStackIn: oldObjects orIn: newObjects) ifTrue: [ - AttemptToMutateObjectInCallStack - signal: 'Can not do #become: Either receiver or argument has some method currently in execution.']]. - oldObjects elementsExchangeIdentityWith: newObjects! ! -!Object methodsFor: 'system primitives' stamp: 'jmv 1/11/2019 16:52:24' prior: 16882299! - becomeForward: otherObject - "Primitive. All variables in the entire system that used to point - to the receiver now point to the argument. - Fails if either argument is a SmallInteger." - - | oldObjects | - oldObjects _ { self }. - self class == otherObject class ifFalse: [ - (Processor anyReceiverInStackIn: oldObjects) ifTrue: [ - AttemptToMutateObjectInCallStack - signal: 'Can not do #become: Receiver has some method currently in execution.']]. - oldObjects elementsForwardIdentityTo: { otherObject }! ! -!Object methodsFor: 'system primitives' stamp: 'jmv 1/11/2019 16:52:33' prior: 16882310! - becomeForward: otherObject copyHash: copyHash - "Primitive. All variables in the entire system that used to point to the receiver now point to the argument. - If copyHash is true, the argument's identity hash bits will be set to those of the receiver. - Fails if either argument is a SmallInteger." - - | oldObjects | - oldObjects _ { self }. - self class == otherObject class ifFalse: [ - (Processor anyReceiverInStackIn: oldObjects) ifTrue: [ - AttemptToMutateObjectInCallStack - signal: 'Can not do #become: Receiver has some method currently in execution.']]. - oldObjects - elementsForwardIdentityTo: { otherObject } - copyHash: copyHash! ! -!Behavior methodsFor: 'private' stamp: 'jmv 1/11/2019 11:39:10' prior: 16784728! - becomeCompact - "Here are the restrictions on compact classes in order for export segments to work: A compact class index may not be reused. If a class was compact in a release of Squeak, no other class may use that index. The class might not be compact later, and there should be nil in its place in the array." - | cct index | - - Smalltalk isSpur ifTrue: [ ^ self halt: 'No Compact Classes support in Spur' ]. - self isWeak ifTrue:[ ^ self halt: 'You must not make a weak class compact' ]. - (Processor anyReceiverInStackIsKindOf: self) - ifTrue: [ ^self halt: self name, ' has some (sub)instance with some method currently in execution.' ]. - cct _ Smalltalk compactClassesArray. - (self indexIfCompact > 0 or: [cct includes: self]) - ifTrue: [^ self halt: self name, ' is already compact']. - index _ cct indexOf: nil - ifAbsent: [^ self halt: 'compact class table is full']. - "Install this class in the compact class table" - cct at: index put: self. - "Update instspec so future instances will be compact" - format _ format + (index bitShift: 11). - "Make up new instances and become old ones into them" - self updateInstancesFrom: self. - "Purge any old instances" - Smalltalk garbageCollect.! ! -!Behavior methodsFor: 'private' stamp: 'jmv 1/11/2019 11:39:04' prior: 16784797! - becomeUncompact - | cct index | - cct _ Smalltalk compactClassesArray. - (index _ self indexIfCompact) = 0 - ifTrue: [^ self]. - (Processor anyReceiverInStackIsKindOf: self) - ifTrue: [ ^self halt: self name, ' has some (sub)instance with some method currently in execution.' ]. - (cct includes: self) - ifFalse: [^ self halt "inconsistent state"]. - "Update instspec so future instances will not be compact" - format _ format - (index bitShift: 11). - "Make up new instances and become old ones into them" - self updateInstancesFrom: self. - "Make sure there are no compact ones left around" - Smalltalk garbageCollect. - "Remove this class from the compact class table" - cct at: index put: nil. -! ! -!ClassBuilder methodsFor: 'class definition' stamp: 'jmv 1/11/2019 16:55:48' prior: 16803207! - class: oldClass instanceVariableNames: instVarString unsafe: unsafe - "This is the basic initialization message to change the definition of - an existing Metaclass" - | instVars newClass needNew copyOfOldClass | - instVars _ Scanner new scanFieldNames: instVarString. - unsafe ifFalse:[ - "Run validation checks so we know that we have a good chance for recompilation" - (self validateInstvars: instVars from: oldClass forSuper: oldClass superclass) ifFalse:[^nil]. - (self validateSubclassFormat: oldClass typeOfClass from: oldClass forSuper: oldClass superclass extra: instVars size) ifFalse:[^nil]. - (Processor anyReceiverInStackIsKindOf: oldClass) ifTrue: [ - AttemptToMutateObjectInCallStack - signal: oldClass name, ' has some (sub)instance with some method currently in execution.'. ^nil ]]. - "See if we need a new subclass or not" - needNew _ self needsSubclassOf: oldClass superclass type: oldClass typeOfClass instanceVariables: instVars from: oldClass. - needNew ifNil:[^nil]. "some error" - needNew ifFalse:[^oldClass]. "no new class needed" - - "Create the new class" - copyOfOldClass _ oldClass copy. - newClass _ self - newSubclassOf: oldClass superclass - type: oldClass typeOfClass - instanceVariables: instVars - from: oldClass. - - newClass _ self recompile: false from: oldClass to: newClass mutate: false. - self doneCompiling: newClass. - SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass. - ^newClass! ! -!ClassBuilder methodsFor: 'class definition' stamp: 'jmv 1/11/2019 16:56:13' prior: 16803265! - name: className subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category unsafe: unsafe - "Define a new class. - If unsafe is true do not run any validation checks. - This facility is provided to implement important system changes." - | oldClass newClass organization instVars classVars force needNew oldCategory copyOfOldClass newCategory | - instVars _ Scanner new scanFieldNames: instVarString. - classVars _ (Scanner new scanFieldNames: classVarString) collect: [:x | x asSymbol]. - - "Validate the proposed name" - unsafe ifFalse:[(self validateClassName: className) ifFalse:[^nil]]. - oldClass _ Smalltalk at: className ifAbsent: nil. - oldClass isBehavior - ifFalse:[oldClass _ nil]. "Already checked in #validateClassName:" - copyOfOldClass _ oldClass copy. - - unsafe ifFalse:[ - "Run validation checks so we know that we have a good chance for recompilation" - (self validateSuperclass: newSuper forSubclass: oldClass) ifFalse:[^nil]. - (self validateInstvars: instVars from: oldClass forSuper: newSuper) ifFalse:[^nil]. - (self validateClassvars: classVars from: oldClass forSuper: newSuper) ifFalse:[^nil]. - (self validateSubclassFormat: type from: oldClass forSuper: newSuper extra: instVars size) ifFalse:[^nil]. - (Processor anyReceiverInStackIsKindOf: oldClass) ifTrue: [ - AttemptToMutateObjectInCallStack - signal: oldClass name, ' has some (sub)instance with some method currently in execution.'. ^nil ]]. - - "See if we need a new subclass" - needNew _ self needsSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass. - needNew ifNil: [^nil]. "some error" - - (needNew and:[unsafe not]) ifTrue:[ - "Make sure we don't redefine any dangerous classes" - (self tooDangerousClasses includes: oldClass name) ifTrue:[ - self error: oldClass name, ' cannot be changed'. - ]. - "Check if the receiver should not be redefined" - (oldClass notNil and:[oldClass shouldNotBeRedefined]) ifTrue:[ - self notify: oldClass name asText allBold, - ' should not be redefined!! \Proceed to store over it.' withNewLines]]. - - needNew ifTrue:[ - "Create the new class" - newClass _ self - newSubclassOf: newSuper - type: type - instanceVariables: instVars - from: oldClass. - newClass ifNil: [ ^nil]. "Some error" - newClass setName: className. - ] ifFalse:[ - "Reuse the old class" - newClass _ oldClass. - ]. - - "Install the class variables and pool dictionaries... " - force _ (newClass declare: classVarString) | (newClass sharing: poolString). - - "... classify ..." - newCategory _ category asSymbol. - organization _ Smalltalk organization. - oldClass ifNotNil: [oldCategory := (organization categoryOfElement: oldClass name) asSymbol]. - organization classify: newClass name under: newCategory. - - "... recompile ..." - newClass _ self recompile: force from: oldClass to: newClass mutate: false. - - "... export if not yet done ..." - (Smalltalk at: newClass name ifAbsent: nil) == newClass ifFalse:[ - [Smalltalk at: newClass name put: newClass] - on: AttemptToWriteReadOnlyGlobal do:[:ex| ex resume: true]. - Smalltalk flushClassNameCache. - ]. - - self doneCompiling: newClass. - - "... notify interested clients ..." - oldClass ifNil: [ - SystemChangeNotifier uniqueInstance classAdded: newClass inCategory: newCategory. - ^ newClass]. - SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass. - newCategory ~= oldCategory - ifTrue: [SystemChangeNotifier uniqueInstance classRecategorized: newClass from: oldCategory to: category]. - ^newClass! ! -!ClassBuilder methodsFor: 'class definition' stamp: 'jmv 1/11/2019 11:58:48' prior: 16803437! - recompile: force from: oldClass to: newClass mutate: forceMutation - "Do the necessary recompilation after changing oldClass to newClass. - If required (e.g., when oldClass ~~ newClass) mutate oldClass to newClass - and all its subclasses. If forceMutation is true force a mutation even - if oldClass and newClass are the same." - - oldClass - ifNil: [^ newClass]. - - (newClass == oldClass and:[force not and:[forceMutation not]]) ifTrue:[ - ^newClass]. - - currentClassIndex _ 0. - maxClassIndex _ oldClass withAllSubclasses size. - - (oldClass == newClass and:[forceMutation not]) ifTrue:[ - "Recompile from newClass without mutating" - self informUserDuring:[ - newClass withAllSubclassesDo:[:cl| - self showProgressFor: cl. - cl compileAll]]. - ^newClass]. - "Recompile and mutate oldClass to newClass" - self informUserDuring:[ - self mutate: oldClass to: newClass. - ]. - ^oldClass "now mutated to newClass"! ! -!ClassBuilder methodsFor: 'public' stamp: 'jmv 1/11/2019 16:56:52' prior: 16804069! - moveInstVarNamed: instVarName from: srcClass to: dstClass after: prevInstVarName - "Move the given instVar from srcClass to dstClass" - | instancesOk | - (srcClass instVarNames includes: instVarName) - ifFalse:[^self error: instVarName,' is not an instance variable of ', srcClass name]. - (prevInstVarName isNil or:[dstClass instVarNames includes: prevInstVarName]) - ifFalse:[^self error: prevInstVarName, 'is not an instance variable of', dstClass name]. - instancesOk _ false. - (srcClass inheritsFrom: dstClass) ifTrue:[ - "Move the instvar up the hierarchy." - (Processor anyReceiverInStackIsKindOf: dstClass) ifTrue: [ - AttemptToMutateObjectInCallStack - signal: dstClass name, ' has some (sub)instance with some method currently in execution.' ^false ]. - instancesOk _ true. - (self validateClass: srcClass forMoving: instVarName upTo: dstClass) - ifFalse:[^false]. - ]. - (dstClass inheritsFrom: srcClass) ifTrue:[ - "Move the instvar down the hierarchy" - (Processor anyReceiverInStackIsKindOf: srcClass) ifTrue: [ - AttemptToMutateObjectInCallStack - signal: srcClass name, ' has some (sub)instance with some method currently in execution.' ^false ]. - instancesOk _ true. - (self validateClass: srcClass forMoving: instVarName downTo: dstClass) - ifFalse:[^false]. - ]. - instancesOk ifFalse: [ "disjunt hierarchies" - (Processor anyReceiverInStackIsKindOf: dstClass) ifTrue: [ - AttemptToMutateObjectInCallStack - signal: dstClass name, ' has some (sub)instance with some method currently in execution.' ^false ]. - (Processor anyReceiverInStackIsKindOf: srcClass) ifTrue: [ - AttemptToMutateObjectInCallStack - signal: srcClass name, ' has some (sub)instance with some method currently in execution.' ^false ]]. - ^self silentlyMoveInstVarNamed: instVarName from: srcClass to: dstClass after: prevInstVarName! ! -!Array methodsFor: 'converting' stamp: 'jmv 1/11/2019 11:10:01' prior: 16779671! -elementsExchangeIdentityWith: otherArray - "This primitive performs a bulk mutation, causing all pointers to the elements of the - receiver 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. - - Warning. This is a dangerous operation and it could lead to a crash if some object in receiver or argument is receiver of a method currently in execution. See #anyReceiverInStackIn: See senders for examples." - - - ec == #'bad receiver' ifTrue: - [^self error: 'receiver must be of class Array']. - ec == #'bad argument' ifTrue: - [^self error: (otherArray class == Array - ifTrue: ['arg must be of class Array'] - ifFalse: ['receiver and argument must have the same size'])]. - ec == #'inappropriate operation' ifTrue: - [^self error: 'can''t become immediates such as SmallIntegers or Characters']. - ec == #'no modification' ifTrue: - [^self error: 'can''t become immutable objects']. - ec == #'object is pinned' ifTrue: - [^self error: 'can''t become pinned objects']. - ec == #'insufficient object memory' ifTrue: - [| maxRequired | - "In Spur, two-way become may involve making each pair of objects into a forwarder into a copy of the other. - So if become fails with #'insufficient object memory', garbage collect, and if necessary, grow memory." - maxRequired := (self detectSum: [:obj | obj class byteSizeOfInstanceOfSize: obj basicSize]) - + (otherArray detectSum: [:obj | obj class byteSizeOfInstanceOfSize: obj basicSize]). - (Smalltalk garbageCollectMost < maxRequired - and: [Smalltalk garbageCollect < maxRequired]) ifTrue: - [Smalltalk growMemoryByAtLeast: maxRequired]. - ^self elementsExchangeIdentityWith: otherArray]. - self primitiveFailed! ! -!Array methodsFor: 'converting' stamp: 'jmv 1/11/2019 11:09:50' prior: 16779730! - elementsForwardIdentityTo: otherArray - "This primitive performs a bulk mutation, causing all pointers to the elements of the - receiver 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. - - Warning. This is a dangerous operation and it could lead to a crash if some object in receiver or argument is receiver of a method currently in execution. See #anyReceiverInStackIn: See senders for examples." - - - ec == #'bad receiver' ifTrue: - [^self error: 'receiver must be of class Array']. - ec == #'bad argument' ifTrue: - [^self error: (otherArray class == Array - ifTrue: ['arg must be of class Array'] - ifFalse: ['receiver and argument must have the same size'])]. - ec == #'inappropriate operation' ifTrue: - [^self error: 'can''t become immediates such as SmallIntegers or Characters']. - ec == #'no modification' ifTrue: - [^self error: 'can''t become immutable objects']. - ec == #'object is pinned' ifTrue: - [^self error: 'can''t become pinned objects']. - ec == #'insufficient object memory' ifTrue: - [self error: 'The virtual machine is out-of-date. Please upgrade.']. - self primitiveFailed! ! -!Array methodsFor: 'converting' stamp: 'jmv 1/11/2019 11:09:40' prior: 16779768! - elementsForwardIdentityTo: otherArray copyHash: copyHash - "This primitive performs a bulk mutation, causing all pointers to the elements of the - receiver to be replaced by pointers to the corresponding elements of otherArray. - If copyHash is true, the identityHashes remain with the pointers rather than with the - objects so that the objects in the receiver should still be properly indexed in any - existing hashed structures after the mutation. If copyHash is false, then the hashes - of the objects in otherArray remain unchanged. If you know what you're doing this - may indeed be what you want. - - Warning. This is a dangerous operation and it could lead to a crash if some object in receiver or argument is receiver of a method currently in execution. See #anyReceiverInStackIn: See senders for examples." - - ec == #'bad receiver' ifTrue: - [^self error: 'receiver must be of class Array']. - ec == #'bad argument' ifTrue: - [^self error: (otherArray class == Array - ifTrue: ['arg must be of class Array'] - ifFalse: ['receiver and argument must have the same size'])]. - ec == #'inappropriate operation' ifTrue: - [^self error: 'can''t become immediates such as SmallIntegers or Characters']. - ec == #'no modification' ifTrue: - [^self error: 'can''t become immutable objects']. - ec == #'object is pinned' ifTrue: - [^self error: 'can''t become pinned objects']. - self primitiveFailed! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3576-dontBecomeObjectIfRunningSomeMethod-JuanVuletich-2019Jan11-16h49m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3576] on 14 January 2019 at 4:35:29 pm'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 1/14/2019 16:34:53' prior: 50424560! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('AY' 'Angel Yan') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('FGJ' 'Fernando Gasperi Jabalera') - #('FJG' 'Facundo Javier Gelatti') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('KLG' 'Gerald Klix') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! -!MessageNode methodsFor: 'equation translation' stamp: 'jmv 1/14/2019 16:15:00' prior: 16867989! - arguments: list - arguments := list asArray! ! -!MessageNode methodsFor: 'cascading' stamp: 'jmv 1/14/2019 16:14:02' prior: 16868573! - receiver: rcvr arguments: args precedence: p - - receiver := rcvr. - originalReceiver := rcvr copy. - arguments := args asArray. - originalArguments := arguments copy. - sizes := Array new: arguments size. - precedence := p! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3577-MessageNodeFix-JuanVuletich-2019Jan14-16h33m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3577] on 16 January 2019 at 8:40:56 am'! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'jmv 1/16/2019 08:38:06'! - allButFirstDo: block - - 2 to: self size do: - [:index | block value: (self at: index)]! ! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'jmv 1/16/2019 08:38:18'! - allButLastDo: block - - 1 to: self size - 1 do: - [:index | block value: (self at: index)]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3578-AddBack-allButFirstDo-allButLastDo-JuanVuletich-2019Jan16-08h38m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3564] on 16 January 2019 at 12:05:04 pm'! -!Preferences class methodsFor: 'code generation' stamp: 'KLG 1/16/2019 11:51:32'! - leftArrowAssignmentsInGeneratedCodeWithComputedDefault - ^ self - valueOfFlag: #leftArrowAssignmentsInGeneratedCode - ifAbsent: [ - self syntaxHighlightingAsYouTypeLeftArrowAssignment or: [ - self syntaxHighlightingAsYouTypeAnsiAssignment not ]].! ! -!Browser methodsFor: 'class functions' stamp: 'KLG 1/16/2019 11:52:48' prior: 16791579! - createInstVarAccessors - "Create getters and setters for all inst vars defined at the level of the current class selection, except do NOT clobber or override any selectors already understood by the instances of the selected class" - self selectedClassOrMetaClass ifNotNil: [ :aClass | - aClass instVarNames do: [ :aName | | newMessage setter | - (aClass canUnderstand: aName asSymbol) ifFalse: [ - newMessage _ aName , ' - "Answer the value of ' , aName , '" - - ^ ' , aName. - aClass - compile: newMessage - classified: 'accessing' - notifying: nil ]. - (aClass canUnderstand: (setter _ aName , ':') asSymbol) ifFalse: [ - newMessage _ setter , ' anObject - "Set the value of ' , aName , '" - - ' , aName , ' ' , - (Preferences leftArrowAssignmentsInGeneratedCodeWithComputedDefault - ifTrue: [ '_' ] - ifFalse: [ ':=' ]) , ' anObject'. - aClass - compile: newMessage - classified: 'accessing' - notifying: nil ]]]! ! -!Message methodsFor: 'stub creation' stamp: 'KLG 1/16/2019 11:51:59' prior: 50389610! - addSetterCodeOn: stream - - stream - newLine; tab; - nextPutAll: selector allButLast; - nextPutAll: (Preferences leftArrowAssignmentsInGeneratedCodeWithComputedDefault - ifTrue: [ ' _ ' ] - ifFalse: [ ' := ' ]); - nextPutAll: self arguments first argumentName ! ! -!Preferences class methodsFor: 'standard queries' stamp: 'KLG 1/16/2019 12:03:07'! - leftArrowAssignmentsInGeneratedCode - ^ self - valueOfFlag: #leftArrowAssignmentsInGeneratedCode - ifAbsent: [ false ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3579-CodeGenerationHonorsAssignmentPreferences-KLG-ConsistentAssignment-In-Generated-Code-KLG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3564] on 17 January 2019 at 7:00:11 pm'! -!CodePackage methodsFor: 'enumerating' stamp: 'KLG 1/17/2019 18:40:59'! - coreMethodsForFileinOf: aClass do: aBlock - "Evaluate aBlock with the actual method objects in this package. - Only enumerate those methods that might be needed for proper filein. - such as #compilerClass." - - aClass organization categories do: [ :cat | - (self isForeignClassExtension: cat) ifFalse: [ - (aClass organization listAtCategoryNamed: cat) do: [ :s | - (self selectorNeededForFilein: s) ifTrue: [ - aBlock value: (self referenceForMethod: s ofClass: aClass) ]]]]! ! -!CodePackage methodsFor: 'testing' stamp: 'KLG 1/17/2019 18:43:05'! - selectorNeededForFilein: aSelector - "Answer true if aSelector might be needed for proper filein of the remaing methods." - - ^ Metaclass isScarySelector: aSelector! ! -!CodePackage methodsFor: 'saving' stamp: 'KLG 1/17/2019 18:54:50'! - write: classes methodsForFileinOn: aStream - - classes - do: [ :class | - self - writeCoreMethodsForFileinOf: class class on: aStream; - writeCoreMethodsForFileinOf: class on: aStream ] - displayingProgress: 'Saving methods...'! ! -!CodePackage methodsFor: 'saving' stamp: 'KLG 1/17/2019 18:56:42'! - writeCoreMethodsForFileinOf: aClass on: aStream - - self coreMethodsForFileinOf: aClass do: [ :methodReference | - methodReference isValid - ifTrue: [ - self writeMethod: methodReference on: aStream ]]! ! -!CodePackage methodsFor: 'enumerating' stamp: 'KLG 1/17/2019 18:44:19' prior: 50377160! - coreMethodsOf: aClass do: aBlock - "Evaluate aBlock with the actual method objects in this package. - - Leave out all the methods needed for filein." - - aClass organization categories do: [ :cat | - (self isForeignClassExtension: cat) ifFalse: [ - (aClass organization listAtCategoryNamed: cat) do: [ :s | - (self selectorNeededForFilein: s) ifFalse: [ - aBlock value: (self referenceForMethod: s ofClass: aClass) ]]]]! ! -!CodePackage methodsFor: 'saving' stamp: 'KLG 1/17/2019 18:55:00' prior: 50377182! - write: classes methodsOn: aStream - - classes - do: [ :class | - self - writeCoreMethodsOf: class on: aStream; - writeCoreMethodsOf: class class on: aStream ] - displayingProgress: 'Saving methods...'! ! -!CodePackage methodsFor: 'saving' stamp: 'KLG 1/17/2019 18:56:15' prior: 50401004! - writeOnStream: aStream - - | sortedClasses | - aStream - nextChunkPut: ('Description ', description) printString; - newLine. - self writeFeatureSpecOn: aStream. - self writeSystemCategoriesOn: aStream. - - self codePackageClass ifNotNil: [ :codePackageClass | - self - write: {codePackageClass} classDefinitionsOn: aStream; - write: {codePackageClass} classCommentsOn: aStream; - write: {codePackageClass} methodsOn: aStream. - aStream nextChunkPut: codePackageClass name, ' prePackageInstall'; newLine ]. - - sortedClasses _ Array streamContents: [ :strm | - self classesInSafeOrderDo: [ :cls | - cls == self class ifFalse: [ - strm nextPut: cls ]]]. - self - write: sortedClasses classDefinitionsOn: aStream; - write: sortedClasses classCommentsOn: aStream; - write: sortedClasses methodsForFileinOn: aStream; - write: sortedClasses methodsOn: aStream. - - self - sortedExtensionMethodsDo: [ :methodReference | - methodReference isValid ifTrue: [ - self writeMethod: methodReference on: aStream ]] - displayingProgress: 'Saving extension methods...'. - self write: sortedClasses initializersOn: aStream. - - self codePackageClass ifNotNil: [ :codePackageClass | - self write: { codePackageClass } initializersOn: aStream. - aStream nextChunkPut: codePackageClass name, ' postPackageInstall'; newLine ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3580-ScarySelectorsFirstInPackages-KLG-fileout-methods-for-filein-first-2019Jan17-16h55m-KLG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3562] on 11 January 2019 at 12:22:25 pm'! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 1/9/2019 19:00:12' prior: 50424348! - computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel - - | id receiverClassOrEntries | - - id _ allSource copyFrom: range start to: range end. - receiverClassOrEntries _ range rangeType - caseOf: { - [ #globalVar ] -> [ (Smalltalk at: id asSymbol) class ]. - [ #self ] -> [ contextClass ]. - [ #super ] -> [ contextClass superclass ]. - [ #true ] -> [ True ]. - [ #false ] -> [ False ]. - [ #nil ] -> [ UndefinedObject ]. - [ #character ] -> [ id first class ]. - [ #number ] -> [ self classOfLiteral: id in: contextClass ]. - [ #string ] -> [ self classOfLiteral: id in: contextClass ]. - [ #symbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #stringSymbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #instVar ] -> [ specificModel classOfInstVarNamed: id ]. - [ #methodArg ] -> [ specificModel classOfTempVarNamed: id ]. - [ #tempVar ] -> [ specificModel classOfTempVarNamed: id ]. - [ #workspaceVar ] -> [ specificModel classOfWorkspaceVarNamed: id ]. - [ #blockArg ] -> [ specificModel classOfBlockArgNamed: id ]. - [ #blockTempVar ] -> [ specificModel classOfBlockTempVarNamed: id ]. - [ #thisContext ] -> [ specificModel classOfThisContext ]. - [ #classVar ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #poolConstant ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #blockEnd ] -> [ BlockClosure ]. - [ #arrayEnd ] -> [ Array ]. - [ #rightBrace ] -> [ Array ]. - [ #unary ] -> [ self returnTypeOfUnaryMessage: id at: range ]. - [ #rightParenthesis ] -> [ self returnTypeOfEnclosedExpressionAt: range ]. } - otherwise: [ nil ]. - - receiverClassOrEntries isCollection - ifTrue: [ self computeMessageEntriesForSelectors: receiverClassOrEntries ] - ifFalse: [ -" Descomentar para que suceda solo para cuando el receiver es una clase" - "(receiverClassOrEntries notNil and: [ receiverClassOrEntries isMeta ])" - (receiverClassOrEntries notNil) - ifTrue: [ self computeMessageForMetaclass: receiverClassOrEntries ] - ifFalse: [ self computeMessageEntries: receiverClassOrEntries ]]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 1/11/2019 12:17:09'! - computeMessageForMetaclass: aMetaclass - - | selectorsToShow addedSelectorsFastSet current | - - true ifTrue: [ ^self computeMessageForMetaclassWithCategories: aMetaclass ]. - false ifTrue: [ ^self computeMessageForMetaclassAddingCategory: aMetaclass ]. - - selectorsToShow := OrderedCollection new. - addedSelectorsFastSet := IdentitySet new. - current := aMetaclass. - [ current notNil ] whileTrue: [ | currentSelectors | - currentSelectors := current selectors select: [ :aSelector | (aSelector beginsWith: prefix) and: [ (addedSelectorsFastSet includes: aSelector) not ]]. - - selectorsToShow addAll: currentSelectors sorted. - addedSelectorsFastSet addAll: currentSelectors. - - current := current superclass. - "Comentar/Descomentar abajo para poner separador por clase" - "selectorsToShow add: '-- ', current name, ':'"]. - - "Comentar/Descomentar abajo para poner separador con Object class" - "selectorsToShow ifNotEmpty: [ selectorsToShow add: '-- ', current name ]." - - "self computeMessageEntries: Object class." - "Falta sacar repetidos de entries" - "entries := selectorsToShow asArray, entries." - entries := selectorsToShow asArray. - - "Comentar todo lo de arriba y descomentar esto para ver el comportamiento original" - " - self computeMessageEntries: aMetaclass . - " - ! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 1/9/2019 19:01:26'! - computeMessageForMetaclassAddingCategory: aMetaclass - - | selectorsToShow addedSelectorsFastSet current | - - selectorsToShow := OrderedCollection new. - addedSelectorsFastSet := IdentitySet new. - current := aMetaclass. - [ current notNil ] whileTrue: [ | currentSelectors organization | - organization := current organization. - currentSelectors := (current selectors select: [ :aSelector | (aSelector beginsWith: prefix) and: [ (addedSelectorsFastSet includes: aSelector) not ]]) sorted. - currentSelectors do: [ :aSelector | selectorsToShow add: aSelector, ' | ', (organization categoryOfElement: aSelector) ]. - - addedSelectorsFastSet addAll: currentSelectors. - - current := current superclass. - "Comentar/Descomentar abajo para poner separador por clase" - "selectorsToShow add: '-- ', current name, ':'"]. - - "Comentar/Descomentar abajo para poner separador con Object class" - selectorsToShow ifNotEmpty: [ selectorsToShow add: '-- ', current name ]. - - self computeMessageEntries: Object class. - "Falta sacar repetidos de entries" - entries := selectorsToShow asArray, entries. - - "Comentar todo lo de arriba y descomentar esto para ver el comportamiento original" - " - self computeMessageEntries: aMetaclass . - " - ! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 1/9/2019 19:01:35'! - computeMessageForMetaclassWithCategories: aMetaclass - - | selectorsToShow categoriesWithSelectors addedSelectorsFastSet current | - - categoriesWithSelectors := OrderedDictionary new. - addedSelectorsFastSet := IdentitySet new. - current := aMetaclass. - [ current notNil ] whileTrue: [ | currentSelectors organization | - organization := current organization. - organization categories do: [ :aCategory | - currentSelectors := (organization listAtCategoryNamed: aCategory) - select: [ :aSelector | (aSelector beginsWith: prefix) and: [ (addedSelectorsFastSet includes: aSelector) not ] ]. - (categoriesWithSelectors at: aCategory ifAbsentPut: [ OrderedCollection new ]) addAll: currentSelectors. - addedSelectorsFastSet addAll: currentSelectors ]. - - current := current superclass]. - - selectorsToShow := OrderedCollection new. - categoriesWithSelectors - at: 'instance creation' - ifPresent: [ :instanceCreationSelectors | - instanceCreationSelectors isEmpty ifFalse: [ - selectorsToShow add: '-- instance creation'; addAll: instanceCreationSelectors. - categoriesWithSelectors removeKey: 'instance creation' ]]. - - categoriesWithSelectors associationsDo: [ :categoryAndSelectors | - categoryAndSelectors value isEmpty ifFalse: [ - selectorsToShow - add: '-- ', categoryAndSelectors key; - addAll: categoryAndSelectors value ]]. - - "Comentar/Descomentar abajo para poner separador con Object class" - "selectorsToShow ifNotEmpty: [ selectorsToShow add: '-- ', current name ]." - - "Falta sacar repetidos de entries" -" self computeMessageEntries: Object class. - entries := selectorsToShow asArray, entries." - entries := selectorsToShow asArray. - - "Comentar todo lo de arriba y descomentar esto para ver el comportamiento original" - " - self computeMessageEntries: aMetaclass . - " - ! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3581-AutoCompleterEnhancements-HernanWilkinson-2019Jan08-17h37m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3562] on 17 January 2019 at 4:48:31 pm'! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 1/17/2019 16:33:43' prior: 50427405! - returnTypeOfEnclosedExpressionAt: aRange - - Smalltalk isLiveTypingInstalled ifFalse: [ ^nil ]. - - ^self - withParserSourceMethodNodeDo: [ :methodNode | self returnTypeOfEnclosedExpresionIn: methodNode at: aRange end - 1 ] - ifError: [ :anError | nil ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3582-AutoCompleterFix-HernanWilkinson-2019Jan11-12h22m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3562] on 18 January 2019 at 12:58:36 am'! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 1/18/2019 00:58:19'! - typeOfCascadeReceiverAt: aRange - - | positionBeforeSemiColon | - - Smalltalk isLiveTypingInstalled ifFalse: [ ^nil ]. - - positionBeforeSemiColon := aRange end - 1. - - "I have to parse excluding the last semi-colon because if not a syntax error will be signaled - because the cascade message is not finished - Hernan" - ^self - withMethodNodeOf: (parser source first: positionBeforeSemiColon) - do: [ :methodNode | self typeOfCascadeReceiverIn: methodNode at: positionBeforeSemiColon ] - ifError: [ :anError | nil ]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 1/18/2019 00:14:55'! - withMethodNodeOf: aSourceCode do: doBlock ifError: anErrorBlock - - ^ [[ doBlock value: (parser classOrMetaClass methodNodeFor: aSourceCode) ] - on: UndeclaredVariableReference - do: [ :anUndeclareVariableReference | anUndeclareVariableReference declareTempAndResume ]] - on: Error - do: anErrorBlock - - ! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 1/18/2019 00:21:47'! - withMethodNodeOfAllSourceCodeDo: doBlock ifError: anErrorBlock - - ^ self withMethodNodeOf: parser source do: doBlock ifError: anErrorBlock - ! ! -!AutoCompleter methodsFor: 'keyboard - private' stamp: 'HAW 1/17/2019 23:26:04' prior: 50424022! - shouldOpenMorphWhenNoPrefixFor: currentChar - - ^currentChar isAlphaNumeric - or: [ currentChar isRightBracket - or: [ currentChar = $) - or: [ currentChar = $; ]]]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 1/17/2019 16:49:38' prior: 50414950! - canComputeMessageEntriesFor: prevRange and: prevPrevRange - - ^ prevRange notNil and: [ prevPrevRange isNil or: [ prevPrevRange rangeType ~= #binary ]]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 1/17/2019 23:33:22' prior: 50429306! - computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel - - | id receiverClassOrEntries | - - id _ allSource copyFrom: range start to: range end. - receiverClassOrEntries _ range rangeType - caseOf: { - [ #globalVar ] -> [ (Smalltalk at: id asSymbol) class ]. - [ #self ] -> [ contextClass ]. - [ #super ] -> [ contextClass superclass ]. - [ #true ] -> [ True ]. - [ #false ] -> [ False ]. - [ #nil ] -> [ UndefinedObject ]. - [ #character ] -> [ id first class ]. - [ #number ] -> [ self classOfLiteral: id in: contextClass ]. - [ #string ] -> [ self classOfLiteral: id in: contextClass ]. - [ #symbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #stringSymbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #instVar ] -> [ specificModel classOfInstVarNamed: id ]. - [ #methodArg ] -> [ specificModel classOfTempVarNamed: id ]. - [ #tempVar ] -> [ specificModel classOfTempVarNamed: id ]. - [ #workspaceVar ] -> [ specificModel classOfWorkspaceVarNamed: id ]. - [ #blockArg ] -> [ specificModel classOfBlockArgNamed: id ]. - [ #blockTempVar ] -> [ specificModel classOfBlockTempVarNamed: id ]. - [ #thisContext ] -> [ specificModel classOfThisContext ]. - [ #classVar ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #poolConstant ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #blockEnd ] -> [ BlockClosure ]. - [ #arrayEnd ] -> [ Array ]. - [ #rightBrace ] -> [ Array ]. - [ #unary ] -> [ self returnTypeOfUnaryMessage: id at: range ]. - [ #rightParenthesis ] -> [ self returnTypeOfEnclosedExpressionAt: range ]. - [ #cascadeSeparator] -> [ self typeOfCascadeReceiverAt: range ]. } - otherwise: [ nil ]. - - receiverClassOrEntries isCollection - ifTrue: [ self computeMessageEntriesForSelectors: receiverClassOrEntries ] - ifFalse: [ -" Descomentar para que suceda solo para cuando el receiver es una clase" - "(receiverClassOrEntries notNil and: [ receiverClassOrEntries isMeta ])" - (receiverClassOrEntries notNil) - ifTrue: [ self computeMessageForMetaclass: receiverClassOrEntries ] - ifFalse: [ self computeMessageEntries: receiverClassOrEntries ] ]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 1/18/2019 00:21:47' prior: 50429530! - returnTypeOfEnclosedExpressionAt: aRange - - Smalltalk isLiveTypingInstalled ifFalse: [ ^nil ]. - - ^self - withMethodNodeOfAllSourceCodeDo: [ :methodNode | self returnTypeOfEnclosedExpresionIn: methodNode at: aRange end - 1 ] - ifError: [ :anError | nil ]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 1/18/2019 00:45:13' prior: 50427417! - returnTypeOfUnaryMessage: aSelector at: aRange - - Smalltalk isLiveTypingInstalled ifFalse: [ ^nil ]. - - ^self - withMethodNodeOfAllSourceCodeDo: [ :methodNode | self returnTypeOfNodeUnderCursorIn: methodNode at: aRange end] - ifError: [ :anError | nil ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3583-AutocompleterHandlesCascade-HernanWilkinson-2019Jan17-16h48m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3583] on 18 January 2019 at 12:32:51 pm'! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 1/18/2019 12:32:36' prior: 50429606! - computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel - - | id receiverClassOrEntries | - - id _ allSource copyFrom: range start to: range end. - receiverClassOrEntries _ range rangeType - caseOf: { - [ #globalVar ] -> [ (Smalltalk at: id asSymbol) class ]. - [ #self ] -> [ contextClass ]. - [ #super ] -> [ contextClass superclass ]. - [ #true ] -> [ True ]. - [ #false ] -> [ False ]. - [ #nil ] -> [ UndefinedObject ]. - [ #character ] -> [ id first class ]. - [ #number ] -> [ self classOfLiteral: id in: contextClass ]. - [ #string ] -> [ self classOfLiteral: id in: contextClass ]. - [ #symbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #stringSymbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #instVar ] -> [ specificModel classOfInstVarNamed: id ]. - [ #methodArg ] -> [ specificModel classOfTempVarNamed: id ]. - [ #tempVar ] -> [ specificModel classOfTempVarNamed: id ]. - [ #workspaceVar ] -> [ specificModel classOfWorkspaceVarNamed: id ]. - [ #blockArg ] -> [ specificModel classOfBlockArgNamed: id ]. - [ #blockTempVar ] -> [ specificModel classOfBlockTempVarNamed: id ]. - [ #thisContext ] -> [ specificModel classOfThisContext ]. - [ #classVar ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #poolConstant ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #blockEnd ] -> [ BlockClosure ]. - [ #arrayEnd ] -> [ Array ]. - [ #rightBrace ] -> [ Array ]. - [ #unary ] -> [ self returnTypeOfUnaryMessage: id at: range ]. - [ #rightParenthesis ] -> [ self returnTypeOfEnclosedExpressionAt: range ]. - [ #cascadeSeparator] -> [ self typeOfCascadeReceiverAt: range ]. } - otherwise: [ nil ]. - - receiverClassOrEntries isCollection - ifTrue: [ self computeMessageEntriesForSelectors: receiverClassOrEntries ] - ifFalse: [ self computeMessageEntries: receiverClassOrEntries ]! ! - -SmalltalkCompleter removeSelector: #computeMessageForMetaclass:! - -SmalltalkCompleter removeSelector: #computeMessageForMetaclass:! - -SmalltalkCompleter removeSelector: #computeMessageForMetaclassAddingCategory:! - -SmalltalkCompleter removeSelector: #computeMessageForMetaclassAddingCategory:! - -SmalltalkCompleter removeSelector: #computeMessageForMetaclassWithCategories:! - -SmalltalkCompleter removeSelector: #computeMessageForMetaclassWithCategories:! - -SmalltalkCompleter removeSelector: #withParserSourceMethodNodeDo:ifError:! - -SmalltalkCompleter removeSelector: #withParserSourceMethodNodeDo:ifError:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3584-AutoCompleter-removeExperimentalCode-HernanWilkinson-2019Jan18-12h29m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3584] on 21 January 2019 at 12:44:58 pm'! -!ProcessorScheduler methodsFor: 'accessing' stamp: 'jmv 1/21/2019 12:43:41'! - anyReceiverInStackIn: anArray orIn: anotherArray runningProcessSearchStart: aContextOrNil - "Iterate over all methods currently in execution. Answer true if in any of them 'self' an element of argument" - " - Processor anyReceiverInStackIn: {} orIn: { self runningWorld } runningProcessSearchStart: nil - Processor anyReceiverInStackIn: {} orIn: { Object new } runningProcessSearchStart: nil - " - self - processesDo: [ :p | ] withStackFramestDo: [ :p :c | | r | - r _ c receiver. - (anArray statePointsTo: r) - ifTrue: [ ^ true ]. - (anotherArray statePointsTo: r) - ifTrue: [ ^ true ]] - runningProcessSearchStart: aContextOrNil. - ^ false! ! -!ProcessorScheduler methodsFor: 'accessing' stamp: 'jmv 1/21/2019 12:43:55'! - anyReceiverInStackIn: anArray runningProcessSearchStart: aContextOrNil - "Iterate over all methods currently in execution. Answer true if in any of them 'self' an element of argument" - " - Processor anyReceiverInStackIn: { self runningWorld } runningProcessSearchStart: nil - Processor anyReceiverInStackIn: { Object new } runningProcessSearchStart: nil - " - self - processesDo: [ :p | ] withStackFramestDo: [ :p :c | - (anArray statePointsTo: c receiver) - ifTrue: [ ^ true ]] - runningProcessSearchStart: aContextOrNil. - ^ false! ! -!ProcessorScheduler methodsFor: 'accessing' stamp: 'jmv 1/21/2019 12:25:46'! - processesDo: aBlock withStackFramestDo: twoArgBlock runningProcessSearchStart: aContextOrNil - "Iterate over processes that can run. - For each process, iterate over stack frames (i.e. contexts)." - " - Processor - processesDo: [ :p | - '--------------' print. - p print. - '--------------' print ] - withStackFramestDo: [ :p :c | - (' ', c printString) print ]. - " - self - processesWithTopContextDo: [ :process :topContext | | context | - aBlock value: process. - context _ topContext. - [ context notNil ] whileTrue: [ - twoArgBlock value: process value: context. - context _ context sender ]] - runningProcessSearchStart: aContextOrNil! ! -!ProcessorScheduler methodsFor: 'accessing' stamp: 'jmv 1/21/2019 12:25:07'! - processesWithTopContextDo: aBlock runningProcessSearchStart: aContextOrNil - "Iterate over processes that can run. Include top context in block arguments." - " - Processor processesWithTopContextDo: [ :p :c | p print. ('------->', c printString) print ]. - " - self processesDo: [ :process | - aBlock - value: process - value: (process isRunning ifTrue: [ aContextOrNil ifNil: [thisContext] ] ifFalse: [ process suspendedContext ]) ]! ! -!ProtoObject methodsFor: 'system primitives' stamp: 'jmv 1/21/2019 12:37:38' prior: 50428313! - become: otherObject - "Primitive. Swap the object pointers of the receiver and the argument. - All variables in the entire system that used to point to the - receiver now point to the argument, and vice-versa. - Fails if either object is a SmallInteger" - - | oldObjects newObjects | - oldObjects _ { self }. - newObjects _ { otherObject }. - self class == otherObject class ifFalse: [ - (Processor anyReceiverInStackIn: oldObjects orIn: newObjects runningProcessSearchStart: thisContext sender) ifTrue: [ - AttemptToMutateObjectInCallStack - signal: 'Can not do #become: Either receiver or argument has some method currently in execution.']]. - oldObjects elementsExchangeIdentityWith: newObjects! ! -!Object methodsFor: 'system primitives' stamp: 'jmv 1/21/2019 12:37:46' prior: 50428337! - becomeForward: otherObject - "Primitive. All variables in the entire system that used to point - to the receiver now point to the argument. - Fails if either argument is a SmallInteger." - - | oldObjects | - oldObjects _ { self }. - self class == otherObject class ifFalse: [ - (Processor anyReceiverInStackIn: oldObjects runningProcessSearchStart: thisContext sender) ifTrue: [ - AttemptToMutateObjectInCallStack - signal: 'Can not do #become: Receiver has some method currently in execution.']]. - oldObjects elementsForwardIdentityTo: { otherObject }! ! -!Object methodsFor: 'system primitives' stamp: 'jmv 1/21/2019 12:37:50' prior: 50428356! - becomeForward: otherObject copyHash: copyHash - "Primitive. All variables in the entire system that used to point to the receiver now point to the argument. - If copyHash is true, the argument's identity hash bits will be set to those of the receiver. - Fails if either argument is a SmallInteger." - - | oldObjects | - oldObjects _ { self }. - self class == otherObject class ifFalse: [ - (Processor anyReceiverInStackIn: oldObjects runningProcessSearchStart: thisContext sender) ifTrue: [ - AttemptToMutateObjectInCallStack - signal: 'Can not do #become: Receiver has some method currently in execution.']]. - oldObjects - elementsForwardIdentityTo: { otherObject } - copyHash: copyHash! ! -!ProcessorScheduler methodsFor: 'accessing' stamp: 'jmv 1/21/2019 12:34:33' prior: 50428220! - anyReceiverInStackIn: anArray - "Iterate over all methods currently in execution. Answer true if in any of them 'self' an element of argument" - " - Processor anyReceiverInStackIn: { self runningWorld } - Processor anyReceiverInStackIn: { Object new } - " - self - processesDo: [ :p | ] - withStackFramestDo: [ :p :c | - (anArray statePointsTo: c receiver) - ifTrue: [ ^ true ]] - runningProcessSearchStart: nil. - ^ false! ! -!ProcessorScheduler methodsFor: 'accessing' stamp: 'jmv 1/21/2019 12:34:49' prior: 50428253! - anyReceiverInStackIsKindOf: aClass - "Iterate over all methods currently in execution. Answer true if in any of them 'self' is a (sub)instance of aClass" - " - Processor anyReceiverInStackIsKindOf: Morph - Processor anyReceiverInStackIsKindOf: DifferenceFinder - " - self - processesDo: [ :p | ] - withStackFramestDo: [ :p :c | - (c receiver isKindOf: aClass) - ifTrue: [ ^ true ]] - runningProcessSearchStart: nil. - ^ false! ! - -ProcessorScheduler removeSelector: #anyReceiverInStackIn:orIn:! - -ProcessorScheduler removeSelector: #anyReceiverInStackIn:orIn:! - -ProcessorScheduler removeSelector: #processesDo:withStackFramestDo:! - -ProcessorScheduler removeSelector: #processesDo:withStackFramestDo:! - -ProcessorScheduler removeSelector: #processesWithTopContextDo:! - -ProcessorScheduler removeSelector: #processesWithTopContextDo:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3585-becomeStackCheckStartsAtSender-JuanVuletich-2019Jan21-12h39m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3584] on 21 January 2019 at 12:19:58 pm'! -!Debugger methodsFor: 'private' stamp: 'jmv 1/21/2019 12:17:19'! - fixReceiverInspector - "Make receiver inspector work on current context receiver. - Create a new inspector if needed" - - | currentReceiver requiredInspectorClass oldInspectorClass | - currentReceiver _ self receiver. - requiredInspectorClass _ currentReceiver inspectorClass. - oldInspectorClass _ receiverInspector class. - - oldInspectorClass ~= requiredInspectorClass ifTrue: [ - oldInspectorClass format = requiredInspectorClass format - ifTrue: [receiverInspector primitiveChangeClassTo: requiredInspectorClass basicNew] - ifFalse: [receiverInspector becomeForward: (requiredInspectorClass basicNew copyFrom: receiverInspector)]]. - - receiverInspector object: currentReceiver! ! -!Debugger methodsFor: 'private' stamp: 'jmv 1/21/2019 12:17:40' prior: 16830041! - contextStackIndex: arg1 oldContextWas: arg2 - | temp3 temp4 temp5 | - contextStackIndex _ arg1. - arg1 = 0 ifTrue: [ - currentCompiledMethod _ nil. - self changed: #contextStackIndex. - self acceptedContentsChanged. - contextVariablesInspector object: nil. - self fixReceiverInspector. - ^ self ]. - temp4 _ contextVariablesInspector selectedSlotName. - temp3 _ arg2 - ifNil: [ true ] - ifNotNil: [ arg2 method ~~ (currentCompiledMethod _ self selectedContext method) ]. - temp3 ifTrue: [ - self acceptedContentsChanged. - self pcRange ]. - self changed: #contextStackIndex. - self triggerEvent: #decorateButtons. - contextVariablesInspector object: self selectedContext. - ((temp5 _ contextVariablesInspector fieldList indexOf: temp4) ~= 0 and: [ - temp5 ~= contextVariablesInspector selectionIndex ]) ifTrue: [ - contextVariablesInspector toggleIndex: temp5 ]. - self fixReceiverInspector. - temp3 ifFalse: [ self changed: #contentsSelection ].! ! -!Inspector methodsFor: 'initialization' stamp: 'jmv 1/21/2019 12:12:06' prior: 50367144! - inspect: anObject - "Initialize the receiver so that it is inspecting anObject. There is no current selection." - - object := anObject. - self initialize! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3586-AvoidDangerousSelfBecomeInInspector-JuanVuletich-2019Jan21-12h19m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3586] on 22 January 2019 at 11:53:37 am'! -!FeatureRequirement methodsFor: 'private' stamp: 'jmv 1/22/2019 10:51:42' prior: 16840926! - placesToLookForPackagesDo: aBlock - - | base myDir | - - "Look inside my own folder" - pathName ifNotNil: [ - myDir _ pathName asFileEntry parent. - aBlock value: myDir ]. - - "Look in Cuis image folder and reasonable subfolders" - base _ DirectoryEntry smalltalkImageDirectory. - base allDirectoriesDo: aBlock. - - "Look in parent directory and reasonable subfolders. - Useful when image is stored in a subdirectory of the main app directory. - This could be the case when the package comes from a 'main' git repo, and image is copied from gitHub" - base parent allDirectoriesDo: aBlock. - - "Also look in host OS current directory" - (base ~= DirectoryEntry currentDirectory and: [base parent ~= DirectoryEntry currentDirectory]) - ifTrue: [ - base _ DirectoryEntry currentDirectory. - base allDirectoriesDo: aBlock ]! ! - -FeatureRequirement removeSelector: #inPackagesSubtreeOf:do:! - -FeatureRequirement removeSelector: #inPackagesSubtreeOf:do:! - -FeatureRequirement removeSelector: #withPackageSubfoldersOf:do:! - -FeatureRequirement removeSelector: #withPackageSubfoldersOf:do:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3587-SearchPackagesInAllFolderTree-JuanVuletich-2019Jan22-11h53m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3587] on 22 January 2019 at 12:56:51 pm'! -!PositionableStream methodsFor: 'fileIn/Out' stamp: 'jmv 1/22/2019 12:29:29' prior: 16891757! - 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." - - self fileInAnnouncing: 'Reading ' , self name. - Smalltalk cleanOutUndeclared. - Undeclared notEmpty ifTrue: [ - ('Undeclared: ', Undeclared printString) print ]! ! -!PositionableStream methodsFor: 'fileIn/Out' stamp: 'jmv 1/22/2019 12:25:39' prior: 50405830! - 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 | - Utilities logsUserChanges: false. - announcement - displayProgressAt: Sensor mousePoint - from: 0 - to: self size - during: [ :barBlock | - [ self atEnd ] whileFalse: [ - barBlock value: self position. - self skipSeparators. - - [ - val := (self peekFor: $!!) - ifTrue: [ - chunk := self nextChunk. - "These are the ones that should do nothing, - because next line is a doit that does the stuff - (or because it is handled elsewhere)" - (chunk beginsWith: 'description: ') - | (chunk beginsWith: 'provides: ') - | (chunk beginsWith: 'requires: ') - | (chunk beginsWith: 'classDefinition: ') - | (chunk beginsWith: 'classRemoval: ') - | (chunk beginsWith: 'methodRemoval: ') - | (chunk beginsWith: 'classMoveToSomePackage: ') - | (chunk beginsWith: 'methodMoveToSomePackage: ') - ifFalse: [(Compiler evaluate: chunk logged: false) scanFrom: self]] - ifFalse: [ - chunk := self nextChunk. - self checkForPreamble: chunk. - [ Compiler evaluate: chunk logged: true ] - on: Error - do: [ :ex | - ex print. - ('while evaluating: ', chunk) print. - ex pass ] - ]] - on: InMidstOfFileinNotification, UndeclaredVariableWarning - do: [ :ex | ex resume: true ] ]. - ]. - "Note: The main purpose of this banner is to flush the changes file." - Utilities logsUserChanges: true. - Smalltalk logChange: '----End fileIn of ' , self name , '----'. - ^val! ! -!FileStream methodsFor: 'fileIn/Out' stamp: 'jmv 1/22/2019 12:27:38' prior: 16843707! -fileIn - "Guarantee that the receiver is readOnly before fileIn for efficiency and - to eliminate remote sharing conflicts." - - self readOnly. - self fileInAnnouncing: 'Loading ', self localName. - Smalltalk cleanOutUndeclared. - Undeclared notEmpty ifTrue: [ - ('Undeclared: ', Undeclared printString) print ]. -! ! -!CodePackageFile methodsFor: 'services' stamp: 'jmv 1/22/2019 12:56:06' prior: 50422020! - install: aFileStream - "Installs the package. Replace all existing code in the CodePackage, removing any code that is not included in us." - | localName newCodePackage pckClass currentCS | - - "Give reasonable warnings if there is stuff that can't be properly cleaned. Give the user the chance to abort." - '=============' print. - classesToRemove notEmpty ifTrue: [ - ('classesToRemove: ', classesToRemove printString) print. - '=============' print ]. - methodsToRemove notEmpty ifTrue: [ - 'methodsToRemove: ' print. - methodsToRemove do: [ :methodReference | methodReference print ]. - '=============' print ]. - - "Create, install and answer a (sub)instance of CodePackage" - localName _ fullName asFileEntry name. - ChangeSet installing: packageName do: [ - "This change set will capture a possible class definition for a subclass of CodePackage. - If it only has that, then remove it after package install. - One example needing this is 'Color-Extras.pck.st'" - currentCS _ ChangeSet changeSetForBaseSystem. - currentCS isEmpty ifFalse: [ currentCS _ nil ]. - pckClass _ CodePackage. - classes do: [ :ee | - (ee hasDefinition and: [ee superclassName = 'CodePackage']) ifTrue: [ - ee fileInDefinitionAndMetaclass. - pckClass _ Smalltalk at: ee name ]]. - newCodePackage _ pckClass - named: packageName - createIfAbsent: true - registerIfNew: true. - newCodePackage - fullFileName: fullName; - sourceSystem: sourceSystem; - description: description; - featureSpec: featureSpec. - aFileStream fileInAnnouncing: 'Installing ', localName, '...'. - methodsToRemove do: [ :methodReference | methodReference actualClass removeSelector: methodReference selector ]. - classesToRemove do: [ :className | (Smalltalk at: className) removeFromSystem ]. - currentCS ifNotNil: [ ChangeSet removeChangeSet: currentCS ]]. - newCodePackage hasUnsavedChanges: false; triggerEvent: #dirtyFlagChanged. - DataStream initialize. "Just in case" - "If we are installing an already installed package, zap the change set with possible changes done, - as they are irrelevant now: we have the package from disk" - ChangeSet removeChangeSet: (ChangeSet existingOrNewChangeSetForPackage: newCodePackage). - Transcript newLine; show: 'Package ', packageName, ' successfully installed'; newLine. - - Smalltalk cleanOutUndeclared. - Undeclared notEmpty ifTrue: [ - ('Undeclared: ', Undeclared printString) print ]. - - ^newCodePackage! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3588-AvoidUndeclaredWarningsDuringPackageInstall-JuanVuletich-2019Jan22-12h54m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3588] on 23 January 2019 at 2:56:32 pm'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 1/23/2019 14:56:17' prior: 50428867! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('AY' 'Angel Yan') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('FGJ' 'Fernando Gasperi Jabalera') - #('FJG' 'Facundo Javier Gelatti') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('KLG' 'Gerald Klix') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('pmon' 'Paolo Montrasi') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3589-AddPaoloAsKnownAuthor-JuanVuletich-2019Jan23-14h56m-jmv.1.cs.st----! - -----SNAPSHOT----#(28 January 2019 10:37:58.299736 am) Cuis5.0-3589-32.image priorSource: 3065238! - -----QUIT----#(28 January 2019 10:38:40.021764 am) Cuis5.0-3589-32.image priorSource: 3163474! - -----STARTUP----#(16 February 2019 9:32:42.991404 pm) as /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/Cuis5.0-3589-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3589] on 29 January 2019 at 1:03:47 pm'! - -Error subclass: #MethodInCallStackToBecomeInvalid - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #MethodInCallStackToBecomeInvalid category: #'Exceptions Kernel'! -Error subclass: #MethodInCallStackToBecomeInvalid - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! -!MethodInCallStackToBecomeInvalid commentStamp: '' prior: 0! - A become operation tries to mutate an object that is the receiver ('self') in a method currently in execution, and part of the stack of calls of some process. This would render the method invalid and is potentially catastrophic.! -!ProtoObject methodsFor: 'system primitives' stamp: 'jmv 1/29/2019 12:03:51' prior: 50429886! - become: otherObject - "Primitive. Swap the object pointers of the receiver and the argument. - All variables in the entire system that used to point to the - receiver now point to the argument, and vice-versa. - Fails if either object is a SmallInteger" - - | selfMethod otherObjectMethod selector contextReceiver | - self class == otherObject class ifFalse: [ - Processor - processesDo: [ :p | ] withStackFramestDo: [ :process :context | - contextReceiver _ context receiver. - (self == contextReceiver or: [ otherObject == contextReceiver ]) ifTrue: [ - selector _ context method selector. - selfMethod _ self class lookupSelector: selector. - otherObjectMethod _ otherObject class lookupSelector: selector. - selfMethod = otherObjectMethod ifFalse: [ - MethodInCallStackToBecomeInvalid - signal: contextReceiver class name, ' has some instance running #', selector, ' that would become invalid.'. - ^ true ]]] - runningProcessSearchStart: thisContext sender. - ]. - { self } elementsExchangeIdentityWith: { otherObject }! ! -!Object methodsFor: 'system primitives' stamp: 'jmv 1/29/2019 12:03:48' prior: 50429911! - becomeForward: otherObject - "Primitive. All variables in the entire system that used to point - to the receiver now point to the argument. - Fails if either argument is a SmallInteger." - - | newMethod oldMethod selector | - self class == otherObject class ifFalse: [ - Processor - processesDo: [ :p | ] withStackFramestDo: [ :process :context | - self == context receiver ifTrue: [ - selector _ context method selector. - oldMethod _ self class lookupSelector: selector. - newMethod _ otherObject class lookupSelector: selector. - oldMethod = newMethod ifFalse: [ - MethodInCallStackToBecomeInvalid - signal: self class name, ' has some instance running #', selector, ' that would become invalid.'. - ^ true ]]] - runningProcessSearchStart: thisContext sender. - ]. - { self } elementsForwardIdentityTo: { otherObject }! ! -!Object methodsFor: 'system primitives' stamp: 'jmv 1/29/2019 12:03:50' prior: 50429932! - becomeForward: otherObject copyHash: copyHash - "Primitive. All variables in the entire system that used to point to the receiver now point to the argument. - If copyHash is true, the argument's identity hash bits will be set to those of the receiver. - Fails if either argument is a SmallInteger." - - | newMethod oldMethod selector | - self class == otherObject class ifFalse: [ - Processor - processesDo: [ :p | ] withStackFramestDo: [ :proces :context | - self == context receiver ifTrue: [ - selector _ context method selector. - oldMethod _ self class lookupSelector: selector. - newMethod _ otherObject class lookupSelector: selector. - oldMethod = newMethod ifFalse: [ - MethodInCallStackToBecomeInvalid - signal: self class name, ' has some instance running #', selector, ' that would become invalid.'. - ^ true ]]] - runningProcessSearchStart: thisContext sender. - ]. - { self } - elementsForwardIdentityTo: { otherObject } - copyHash: copyHash! ! -!Behavior methodsFor: 'private' stamp: 'jmv 8/16/2016 09:31:16' prior: 50428379! - becomeCompact - "Here are the restrictions on compact classes in order for export segments to work: A compact class index may not be reused. If a class was compact in a release of Squeak, no other class may use that index. The class might not be compact later, and there should be nil in its place in the array." - | cct index | - - Smalltalk isSpur ifTrue: [^ self halt: 'No Compact Classes support in Spur']. - self isWeak ifTrue:[^ self halt: 'You must not make a weak class compact']. - cct _ Smalltalk compactClassesArray. - (self indexIfCompact > 0 or: [cct includes: self]) - ifTrue: [^ self halt: self name , 'is already compact']. - index _ cct indexOf: nil - ifAbsent: [^ self halt: 'compact class table is full']. - "Install this class in the compact class table" - cct at: index put: self. - "Update instspec so future instances will be compact" - format _ format + (index bitShift: 11). - "Make up new instances and become old ones into them" - self updateInstancesFrom: self. - "Purge any old instances" - Smalltalk garbageCollect.! ! -!Behavior methodsFor: 'private' stamp: 'jmv 11/27/2008 16:05' prior: 50428419! - becomeUncompact - | cct index | - cct _ Smalltalk compactClassesArray. - (index _ self indexIfCompact) = 0 - ifTrue: [^ self]. - (cct includes: self) - ifFalse: [^ self halt "inconsistent state"]. - "Update instspec so future instances will not be compact" - format _ format - (index bitShift: 11). - "Make up new instances and become old ones into them" - self updateInstancesFrom: self. - "Make sure there are no compact ones left around" - Smalltalk garbageCollect. - "Remove this class from the compact class table" - cct at: index put: nil. -! ! -!ClassDescription methodsFor: 'initialization' stamp: 'jmv 1/29/2019 12:03:46' prior: 16807271! - updateInstancesFrom: oldClass - "Recreate any existing instances of the argument, oldClass, as instances of - the receiver, which is a newly changed class. Permute variables as necessary, - and forward old instances to new instances.. Answer nil to defeat any clients - that expected the old behaviour of answering the array of old instances." - "ar 7/15/1999: The updating below is possibly dangerous. If there are any - contexts having an old instance as receiver it might crash the system if - the new receiver in which the context is executed has a different layout. - See bottom below for a simple example:" - | newMethod oldMethod selector | - Processor - processesDo: [ :p | ] - withStackFramestDo: [ :process :context | - (context receiver isKindOf: oldClass) ifTrue: [ - selector _ context method selector. - oldMethod _ oldClass lookupSelector: selector. - newMethod _ self lookupSelector: selector. - oldMethod = newMethod ifFalse: [ - MethodInCallStackToBecomeInvalid - signal: self class name, ' has some instance running ', oldMethod printString, ' that would become invalid.'. - ^nil ]]] - runningProcessSearchStart: nil. - self updateInstances: oldClass allInstances asArray from: oldClass isMeta: self isMeta. - ^nil - -"This attempts to crash the VM by stepping off the end of an instance. - As the doctor says, do not do this." -" | crashingBlock class | - class := Object subclass: #CrashTestDummy - instanceVariableNames: 'instVar' - classVariableNames: '' - poolDictionaries: '' - category: 'Crash-Test'. - class compile:'instVar: value instVar := value'. - class compile:'crashingBlock ^[instVar]'. - crashingBlock := (class new) instVar: 42; crashingBlock. - Object subclass: #CrashTestDummy - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Crash-Test'. - crashingBlock value"! ! -!ClassBuilder methodsFor: 'class definition' stamp: 'jmv 5/20/2015 12:51' prior: 50428444! - class: oldClass instanceVariableNames: instVarString unsafe: unsafe - "This is the basic initialization message to change the definition of - an existing Metaclass" - | instVars newClass needNew copyOfOldClass | - instVars _ Scanner new scanFieldNames: instVarString. - unsafe ifFalse:[ - "Run validation checks so we know that we have a good chance for recompilation" - (self validateInstvars: instVars from: oldClass forSuper: oldClass superclass) ifFalse:[^nil]. - (self validateSubclassFormat: oldClass typeOfClass from: oldClass forSuper: oldClass superclass extra: instVars size) ifFalse:[^nil]]. - "See if we need a new subclass or not" - needNew _ self needsSubclassOf: oldClass superclass type: oldClass typeOfClass instanceVariables: instVars from: oldClass. - needNew ifNil:[^nil]. "some error" - needNew ifFalse:[^oldClass]. "no new class needed" - - "Create the new class" - copyOfOldClass _ oldClass copy. - newClass _ self - newSubclassOf: oldClass superclass - type: oldClass typeOfClass - instanceVariables: instVars - from: oldClass. - - newClass _ self recompile: false from: oldClass to: newClass mutate: false. - self doneCompiling: newClass. - SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass. - ^newClass! ! -!ClassBuilder methodsFor: 'class definition' stamp: 'jmv 5/20/2015 12:51' prior: 50428493! - name: className subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category unsafe: unsafe - "Define a new class. - If unsafe is true do not run any validation checks. - This facility is provided to implement important system changes." - | oldClass newClass organization instVars classVars force needNew oldCategory copyOfOldClass newCategory | - instVars _ Scanner new scanFieldNames: instVarString. - classVars _ (Scanner new scanFieldNames: classVarString) collect: [:x | x asSymbol]. - - "Validate the proposed name" - unsafe ifFalse:[(self validateClassName: className) ifFalse:[^nil]]. - oldClass _ Smalltalk at: className ifAbsent: nil. - oldClass isBehavior - ifFalse:[oldClass _ nil]. "Already checked in #validateClassName:" - copyOfOldClass _ oldClass copy. - - unsafe ifFalse:[ - "Run validation checks so we know that we have a good chance for recompilation" - (self validateSuperclass: newSuper forSubclass: oldClass) ifFalse:[^nil]. - (self validateInstvars: instVars from: oldClass forSuper: newSuper) ifFalse:[^nil]. - (self validateClassvars: classVars from: oldClass forSuper: newSuper) ifFalse:[^nil]. - (self validateSubclassFormat: type from: oldClass forSuper: newSuper extra: instVars size) ifFalse:[^nil]]. - - "See if we need a new subclass" - needNew _ self needsSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass. - needNew ifNil: [^nil]. "some error" - - (needNew and:[unsafe not]) ifTrue:[ - "Make sure we don't redefine any dangerous classes" - (self tooDangerousClasses includes: oldClass name) ifTrue:[ - self error: oldClass name, ' cannot be changed'. - ]. - "Check if the receiver should not be redefined" - (oldClass notNil and:[oldClass shouldNotBeRedefined]) ifTrue:[ - self notify: oldClass name asText allBold, - ' should not be redefined!! \Proceed to store over it.' withNewLines]]. - - needNew ifTrue:[ - "Create the new class" - newClass _ self - newSubclassOf: newSuper - type: type - instanceVariables: instVars - from: oldClass. - newClass ifNil: [ ^nil]. "Some error" - newClass setName: className. - ] ifFalse:[ - "Reuse the old class" - newClass _ oldClass. - ]. - - "Install the class variables and pool dictionaries... " - force _ (newClass declare: classVarString) | (newClass sharing: poolString). - - "... classify ..." - newCategory _ category asSymbol. - organization _ Smalltalk organization. - oldClass ifNotNil: [oldCategory := (organization categoryOfElement: oldClass name) asSymbol]. - organization classify: newClass name under: newCategory. - - "... recompile ..." - newClass _ self recompile: force from: oldClass to: newClass mutate: false. - - "... export if not yet done ..." - (Smalltalk at: newClass name ifAbsent: nil) == newClass ifFalse:[ - [Smalltalk at: newClass name put: newClass] - on: AttemptToWriteReadOnlyGlobal do:[:ex| ex resume: true]. - Smalltalk flushClassNameCache. - ]. - - self doneCompiling: newClass. - - "... notify interested clients ..." - oldClass ifNil: [ - SystemChangeNotifier uniqueInstance classAdded: newClass inCategory: newCategory. - ^ newClass]. - SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass. - newCategory ~= oldCategory - ifTrue: [SystemChangeNotifier uniqueInstance classRecategorized: newClass from: oldCategory to: category]. - ^newClass! ! -!ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:40' prior: 50428640! - moveInstVarNamed: instVarName from: srcClass to: dstClass after: prevInstVarName - "Move the given instVar from srcClass to dstClass" - (srcClass instVarNames includes: instVarName) - ifFalse:[^self error: instVarName,' is not an instance variable of ', srcClass name]. - (prevInstVarName isNil or:[dstClass instVarNames includes: prevInstVarName]) - ifFalse:[^self error: prevInstVarName, 'is not an instance variable of', dstClass name]. - (srcClass inheritsFrom: dstClass) ifTrue:[ - "Move the instvar up the hierarchy." - (self validateClass: srcClass forMoving: instVarName upTo: dstClass) - ifFalse:[^false]. - ]. - (dstClass inheritsFrom: srcClass) ifTrue:[ - "Move the instvar down the hierarchy" - (self validateClass: srcClass forMoving: instVarName downTo: dstClass) - ifFalse:[^false]. - ]. - ^self silentlyMoveInstVarNamed: instVarName from: srcClass to: dstClass after: prevInstVarName! ! - -ProcessorScheduler removeSelector: #anyReceiverInStackIn:orIn:runningProcessSearchStart:! - -ProcessorScheduler removeSelector: #anyReceiverInStackIn:orIn:runningProcessSearchStart:! - -ProcessorScheduler removeSelector: #anyReceiverInStackIn:runningProcessSearchStart:! - -ProcessorScheduler removeSelector: #anyReceiverInStackIn:runningProcessSearchStart:! - -ProcessorScheduler removeSelector: #anyReceiverInStackIsKindOf:! - -ProcessorScheduler removeSelector: #anyReceiverInStackIsKindOf:! - -Smalltalk removeClassNamed: #AttemptToMutateObjectInCallStack! - -Smalltalk removeClassNamed: #AttemptToMutateObjectInCallStack! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3590-BetterCheckForInvalidMethodsInCallStack-JuanVuletich-2019Jan29-12h57m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3590] on 30 January 2019 at 11:26:24 am'! -!ClassBuilder methodsFor: 'class mutation' stamp: 'jmv 1/30/2019 11:26:18' prior: 16804333! - update: oldClass to: newClass - "Convert oldClass, all its instances and possibly its meta class into newClass, - instances of newClass and possibly its meta class. The process is surprisingly - simple in its implementation and surprisingly complex in its nuances and potentially - bad side effects. - We can rely on two assumptions (which are critical): - #1: The method #updateInstancesFrom: will not create any lasting pointers to - 'old' instances ('old' is quote on quote since #updateInstancesFrom: will do - a become of the old vs. the new instances and therefore it will not create - pointers to *new* instances before the #become: which are *old* afterwards) - #2: The non-preemptive execution of the critical piece of code guarantees that - nobody can get a hold by 'other means' (such as process interruption and - reflection) on the old instances. - Given the above two, we know that after #updateInstancesFrom: there are no pointers - to any old instances. After the forwarding become there will be no pointers to the old - class or meta class either. - Meaning that if we throw in a nice fat GC at the end of the critical block, everything will - be gone (but see the comment right there). - Andreas Raab, 2/27/2003 23:42" - | meta | - meta := oldClass isMeta. - "Note: Everything from here on will run without the ability to get interrupted - to prevent any other process to create new instances of the old class." - ["Note: The following removal may look somewhat obscure and needs an explanation. - When we mutate the class hierarchy we create new classes for any existing subclass. - So it may look as if we don't have to remove the old class from its superclass. However, - at the top of the hierarchy (the first class we reshape) that superclass itself is not newly - created so therefore it will hold both the oldClass and newClass in its (obsolete or not) - subclasses. Since the #become: below will transparently replace the pointers to oldClass - with newClass the superclass would have newClass in its subclasses TWICE. With rather - unclear effects if we consider that we may convert the meta-class hierarchy itself (which - is derived from the non-meta class hierarchy). - Due to this problem ALL classes are removed from their superclass just prior to converting - them. Here, breaking the superclass/subclass invariant really doesn't matter since we will - effectively remove the oldClass - (becomeForward: or become+GC) just a few lines below." - - "Convert the instances of oldClass into instances of newClass" - newClass updateInstancesFrom: oldClass. - - oldClass superclass removeSubclass: oldClass. - oldClass superclass removeObsoleteSubclass: oldClass. - - "make sure that the VM cache is clean" - oldClass methodDict do: [:cm | cm flushCache]. - - meta - ifTrue: - [oldClass becomeForward: newClass. - oldClass updateMethodBindingsTo: oldClass binding] - ifFalse: - [{oldClass. oldClass class} elementsForwardIdentityTo: {newClass. newClass class}. - oldClass updateMethodBindingsTo: oldClass binding. - oldClass class updateMethodBindingsTo: oldClass class binding]. - - Smalltalk isSpur - ifTrue: [ - "eem 5/31/2014 07:22 At this point there used to be a garbage collect whose purpose was - to ensure no old instances existed after the becomeForward:. Without the GC it was possible - to resurrect old instances using e.g. allInstancesDo:. This was because the becomeForward: - updated references from the old objects to new objects but didn't destroy the old objects. - But as of late 2013/early 2014 becomeForward: has been modified to free all the old objects." - ] - - ifFalse: [ - "jmv: Squeak 4.6 (pre Spur) includes the GC. So, do it if not Spur. - Not really sure if needed on newer Cog and Stack non-Spur VMs. - Not sure if needed for SqueakJS. - Remove it when we are sure. - - Original note by Andreas Raab below." - Smalltalk garbageCollect. - "Warning: Read this before you even think about removing the GC. Yes, it slows us down. Quite heavily if you have a large image. However, there's no good and simple alternative here, since unfortunately, #become: does change class pointers. What happens is that after the above become all of the instances of the old class will have a class pointer identifying them as instances of newClass. If we get our hands on any of these instances we will break immediately since their expected instance layout (that of its class, e.g., newClass) will not match their actual instance layout (that of oldClass). And getting your hands on any of those instances is really simple - just reshaping one class two times in rapid succession will do it. Reflection techniques, interrupts, etc. will only add to this problem. In the case of Metaclass things get even worse since when we recompile the entire class hierarchy we will recompile both, Metaclass and its instances (and some of its instances will have the old and some the new layout). - The only easy solution to this problem would be to 'fix up' the class pointers of the old instances to point to the old class (using primitiveChangeClassTo:). But this won't work either - as we do a one-way become we would have to search the entire object memory for the oldClass and couldn't even clearly identify it unless we give it some 'special token' which sounds quite error-prone. If you really need to get rid of the GC here are some alternatives: - On the image level, one could create a copy of the oldClass before becoming it into the new class and, after becoming it, 'fix up' the old instances. That would certainly work but it sounds quite complex, as we need to make sure we're not breaking any of the superclass/subclass meta/non-meta class variants. - Alternatively, fix up #becomeForward on the VM-level to 'dump the source objects' of #become. This would be quite doable (just 'convert' them into a well known special class such as bitmap) yet it has problems if (accidentally or not) one of the objects in #become: appears on 'both sides of the fence' (right now, this will work ... in a way ... even though the consequences are unclear). - Another alternative is to provide a dedicated primitive for this (instead of using it implicitly in become) which would allow us to dump all the existing instances right here. This is equivalent to a more general primitiveChangeClassTo: and might be worthwhile but it would likely have to keep in mind the differences between bits and pointer thingies etc. - Since all of the alternatives seem rather complex and magical compared to a straight-forward GC it seems best to stick with the GC solution for now. If someone has a real need to fix this problem, that person will likely be motivated enough to check out the alternatives. Personally I'd probably go for #1 (copy the old class and remap the instances to it) since it's a solution that could be easily reverted from within the image if there's any problem with it. - Andreas Raab, 2/27/2003 23:42" - ] - ] valueUnpreemptively! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3591-AvoidCrashWhenClassMutationFails-JuanVuletich-2019Jan30-11h26m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3591] on 30 January 2019 at 11:54:45 am'! -!ClassDescription methodsFor: 'initialization' stamp: 'jmv 1/30/2019 11:54:25' prior: 50430701! - updateInstancesFrom: oldClass - "Recreate any existing instances of the argument, oldClass, as instances of - the receiver, which is a newly changed class. Permute variables as necessary, - and forward old instances to new instances.. Answer nil to defeat any clients - that expected the old behaviour of answering the array of old instances." - "ar 7/15/1999: The updating below is possibly dangerous. If there are any - contexts having an old instance as receiver it might crash the system if - the new receiver in which the context is executed has a different layout. - See bottom below for a simple example:" - | newMethod oldMethod selector | - Processor - processesDo: [ :p | ] - withStackFramestDo: [ :process :context | - (context receiver isKindOf: oldClass) ifTrue: [ - selector _ context method selector. - oldMethod _ oldClass lookupSelector: selector. - newMethod _ self lookupSelector: selector. - oldMethod = newMethod ifFalse: [ - MethodInCallStackToBecomeInvalid - signal: self class name, ' has some instance running #', selector, ' that would become invalid.'. - ^nil ]]] - runningProcessSearchStart: nil. - self updateInstances: oldClass allInstances asArray from: oldClass isMeta: self isMeta. - ^nil - -"This attempts to crash the VM by stepping off the end of an instance. - As the doctor says, do not do this." -" | crashingBlock class | - class := Object subclass: #CrashTestDummy - instanceVariableNames: 'instVar' - classVariableNames: '' - poolDictionaries: '' - category: 'Crash-Test'. - class compile:'instVar: value instVar := value'. - class compile:'crashingBlock ^[instVar]'. - crashingBlock := (class new) instVar: 42; crashingBlock. - Object subclass: #CrashTestDummy - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Crash-Test'. - crashingBlock value"! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3592-tweak-JuanVuletich-2019Jan30-11h54m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3592] on 30 January 2019 at 3:09:13 pm'! - -Exception subclass: #MethodInCallStackToBecomeInvalid - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #MethodInCallStackToBecomeInvalid category: #'Exceptions Kernel'! -Exception subclass: #MethodInCallStackToBecomeInvalid - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! -!MethodInCallStackToBecomeInvalid methodsFor: 'as yet unclassified' stamp: 'jmv 1/30/2019 15:04:38'! - defaultAction - - self noHandler! ! -!ProtoObject methodsFor: 'system primitives' stamp: 'jmv 1/30/2019 15:02:54' prior: 50430546! -become: otherObject - "Primitive. Swap the object pointers of the receiver and the argument. - All variables in the entire system that used to point to the - receiver now point to the argument, and vice-versa. - Fails if either object is a SmallInteger" - - | selfMethod otherObjectMethod selector contextReceiver | - self class == otherObject class ifFalse: [ - Processor - processesDo: [ :p | ] withStackFramestDo: [ :process :context | - contextReceiver _ context receiver. - (self == contextReceiver or: [ otherObject == contextReceiver ]) ifTrue: [ - selector _ context method selector. - selfMethod _ self class lookupSelector: selector. - otherObjectMethod _ otherObject class lookupSelector: selector. - selfMethod = otherObjectMethod ifFalse: [ - MethodInCallStackToBecomeInvalid - signal: contextReceiver class name, ' has some instance running #', selector, ' that would become invalid.' ]]] - runningProcessSearchStart: thisContext sender. - ]. - { self } elementsExchangeIdentityWith: { otherObject }! ! -!Object methodsFor: 'system primitives' stamp: 'jmv 1/30/2019 15:02:40' prior: 50430582! - becomeForward: otherObject - "Primitive. All variables in the entire system that used to point - to the receiver now point to the argument. - Fails if either argument is a SmallInteger." - - | newMethod oldMethod selector | - self class == otherObject class ifFalse: [ - Processor - processesDo: [ :p | ] withStackFramestDo: [ :process :context | - self == context receiver ifTrue: [ - selector _ context method selector. - oldMethod _ self class lookupSelector: selector. - newMethod _ otherObject class lookupSelector: selector. - oldMethod = newMethod ifFalse: [ - MethodInCallStackToBecomeInvalid - signal: self class name, ' has some instance running #', selector, ' that would become invalid.' ]]] - runningProcessSearchStart: thisContext sender. - ]. - { self } elementsForwardIdentityTo: { otherObject }! ! -!Object methodsFor: 'system primitives' stamp: 'jmv 1/30/2019 15:02:48' prior: 50430612! - becomeForward: otherObject copyHash: copyHash - "Primitive. All variables in the entire system that used to point to the receiver now point to the argument. - If copyHash is true, the argument's identity hash bits will be set to those of the receiver. - Fails if either argument is a SmallInteger." - - | newMethod oldMethod selector | - self class == otherObject class ifFalse: [ - Processor - processesDo: [ :p | ] withStackFramestDo: [ :proces :context | - self == context receiver ifTrue: [ - selector _ context method selector. - oldMethod _ self class lookupSelector: selector. - newMethod _ otherObject class lookupSelector: selector. - oldMethod = newMethod ifFalse: [ - MethodInCallStackToBecomeInvalid - signal: self class name, ' has some instance running #', selector, ' that would become invalid.' ]]] - runningProcessSearchStart: thisContext sender. - ]. - { self } - elementsForwardIdentityTo: { otherObject } - copyHash: copyHash! ! -!ClassDescription methodsFor: 'initialization' stamp: 'jmv 1/30/2019 15:02:33' prior: 50431205! - updateInstancesFrom: oldClass - "Recreate any existing instances of the argument, oldClass, as instances of - the receiver, which is a newly changed class. Permute variables as necessary, - and forward old instances to new instances.. Answer nil to defeat any clients - that expected the old behaviour of answering the array of old instances." - "ar 7/15/1999: The updating below is possibly dangerous. If there are any - contexts having an old instance as receiver it might crash the system if - the new receiver in which the context is executed has a different layout. - See bottom below for a simple example:" - | newMethod oldMethod selector | - Processor - processesDo: [ :p | ] - withStackFramestDo: [ :process :context | - (context receiver isKindOf: oldClass) ifTrue: [ - selector _ context method selector. - oldMethod _ oldClass lookupSelector: selector. - newMethod _ self lookupSelector: selector. - oldMethod = newMethod ifFalse: [ - MethodInCallStackToBecomeInvalid - signal: self class name, ' has some instance running #', selector, ' that would become invalid.' ]]] - runningProcessSearchStart: nil. - self updateInstances: oldClass allInstances asArray from: oldClass isMeta: self isMeta. - ^nil - -"This attempts to crash the VM by stepping off the end of an instance. - As the doctor says, do not do this." -" | crashingBlock class | - class := Object subclass: #CrashTestDummy - instanceVariableNames: 'instVar' - classVariableNames: '' - poolDictionaries: '' - category: 'Crash-Test'. - class compile:'instVar: value instVar := value'. - class compile:'crashingBlock ^[instVar]'. - crashingBlock := (class new) instVar: 42; crashingBlock. - Object subclass: #CrashTestDummy - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Crash-Test'. - crashingBlock value"! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3593-MethodInCallStackToBecomeInvalid-isResumable-JuanVuletich-2019Jan30-15h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3593] on 1 February 2019 at 10:32:03 am'! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'jmv 2/1/2019 10:27:32' prior: 16909686! -doIt - "Set the context to include pool vars of the model. Then evaluate. - Print the result on the Transcript" - ^ self - evaluateSelectionAndDo: [ :result | - Transcript finishEntry. - result print ] - ifFail: nil - profiled: false! ! -!Transcript class methodsFor: 'private' stamp: 'jmv 2/1/2019 10:27:12' prior: 16938455! - finishEntry - | newEntry | - self unfinishedEntrySize > 1 ifTrue: [ - newEntry _ unfinishedEntry contents. - unfinishedEntry reset. - lastDisplayPosition _ 0. - self addEntry: newEntry. - self display ].! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3594-TranscriptTweaks-JuanVuletich-2019Feb01-10h27m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3593] on 1 February 2019 at 10:33:43 am'! -!BreakpointManager class methodsFor: 'private' stamp: 'KLG 1/31/2019 17:21:07' prior: 16791259! - compilePrototype: aSymbol in: aClass - "Compile and return a new method containing a break statement" - - | source node trailer | - trailer _ (aClass compiledMethodAt: aSymbol) trailer. - source := self breakpointMethodSourceFor: aSymbol in: aClass. - node := aClass compilerClass new - compile: source - in: aClass - notifying: nil - ifFail: [self error: '[breakpoint] unable to install breakpoint']. - ^node ifNotNil: [ node generate: trailer ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3595-BreakpointManagerFix-GeraldKlix-2019Feb01-10h32m-KLG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3595] on 1 February 2019 at 11:08:47 am'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 2/1/2019 11:08:32' prior: 50430303! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('AY' 'Angel Yan') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('FGJ' 'Fernando Gasperi Jabalera') - #('FJG' 'Facundo Javier Gelatti') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('KLG' 'Gerald Klix') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('pmon' 'Paolo Montrasi') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('SLD' 'Steve Davies') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3596-AddSteveAsKnownAuthor-JuanVuletich-2019Feb01-11h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3589] on 1 February 2019 at 10:06:52 am'! -!MenuMorph methodsFor: 'events' stamp: 'SLD 2/1/2019 09:58:38' prior: 50339250! - keyStroke: aKeyboardEvent - | matchString char asc selectable | - char := aKeyboardEvent keyCharacter. - asc := char numericValue. - aKeyboardEvent isReturnKey - ifTrue: [ - selectedItem ifNotNil: [ - selectedItem hasSubMenu - ifTrue: [ - aKeyboardEvent hand newMouseFocus: selectedItem subMenu. - ^aKeyboardEvent hand newKeyboardFocus: selectedItem subMenu] - ifFalse: [ - "self delete." - ^selectedItem invokeWithEvent: aKeyboardEvent]]. - (selectable := self items) size = 1 - ifTrue: [^selectable first invokeWithEvent: aKeyboardEvent]. - ^self]. - asc = 27 - ifTrue: [ - "escape key" - self - valueOfProperty: #matchString - ifPresentDo: [ :str | - str isEmpty - ifFalse: [ - "If filtered, first ESC removes filter" - self setProperty: #matchString toValue: String new. - self selectItem: nil. - ^self displayFiltered: aKeyboardEvent]]. - "If a stand-alone menu, just delete it" - ^self delete]. - (asc = 28 or: [asc = 29]) - ifTrue: [ - "left or right arrow key" - (selectedItem notNil and: [selectedItem hasSubMenu]) - ifTrue: [ - aKeyboardEvent hand newMouseFocus: selectedItem subMenu. - selectedItem subMenu moveSelectionDown: 1 event: aKeyboardEvent. - ^aKeyboardEvent hand newKeyboardFocus: selectedItem subMenu] - ifFalse: [^ self]]. - asc = 30 ifTrue: [^self moveSelectionDown: -1 event: aKeyboardEvent]. "up arrow key" - asc = 31 ifTrue: [^self moveSelectionDown: 1 event: aKeyboardEvent]. "down arrow key" - asc = 11 ifTrue: [^self moveSelectionDown: -5 event: aKeyboardEvent]. "page up key" - asc = 12 ifTrue: [^self moveSelectionDown: 5 event: aKeyboardEvent]. "page down key" - matchString := self valueOfProperty: #matchString ifAbsent: [String new]. - matchString := char = Character backspace - ifTrue: [ - matchString isEmpty ifTrue: [matchString] ifFalse: [matchString allButLast]] - ifFalse: [matchString copyWith: aKeyboardEvent keyCharacter]. - self setProperty: #matchString toValue: matchString. - self displayFiltered: aKeyboardEvent! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3597-MenuMorphDropLeftRigh-SteveDavies-2019Jan31-17h38m-SLD.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3589] on 4 February 2019 at 3:31:26 am'! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'AY 2/4/2019 03:26:10'! - atFront - - ^owner firstSubmorph == self! ! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'AY 2/4/2019 03:26:20' prior: 16876877! - comeToFront - - self atFront ifFalse: [owner addMorphFront: self]! ! -!Morph methodsFor: 'user interface' stamp: 'AY 2/4/2019 03:30:37' prior: 50341564! - toggleCollapseOrShow - "If collapsed, show me. - If visible, collapse me." - - (self visible and: [self atFront]) - ifTrue: [ self collapse ] - ifFalse: [ self showAndComeToFront ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3598-WindowSwitchingEnh-AngelYan-2019Feb04-03h15m-AY.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3589] on 7 February 2019 at 12:00:51 am'! - -PluggableButtonMorph subclass: #HoverableButtonMorph - instanceVariableNames: 'mouseEnterSelector mouseLeaveSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #HoverableButtonMorph category: #'Morphic-Views'! -PluggableButtonMorph subclass: #HoverableButtonMorph - instanceVariableNames: 'mouseEnterSelector mouseLeaveSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'AY 2/4/2019 03:26:10' prior: 50431795! - atFront - - ^owner firstSubmorph == self! ! -!Morph methodsFor: 'previewing' stamp: 'AY 2/6/2019 23:55:29'! - beginPreview - - (self visible and: [self atFront]) ifFalse: [ - self visibleBeforePreview: self visible. - self morphBehindBeforePreview: (self owner submorphBehind: self). - self previewing: true. - self showAndComeToFront. ]! ! -!Morph methodsFor: 'previewing' stamp: 'AY 2/6/2019 23:55:39'! - endPreview - - self previewing ifTrue: [ - self visible: self visibleBeforePreview. - self owner addMorph: self inFrontOf: self morphBehindBeforePreview. - self previewing: false. ]! ! -!Morph methodsFor: 'previewing' stamp: 'AY 2/4/2019 05:46:06'! - endPreviewAndToggleCollapseOrShow - - self endPreview. - self toggleCollapseOrShow.! ! -!Morph methodsFor: 'previewing' stamp: 'AY 2/6/2019 05:28:28'! - morphBehindBeforePreview - - ^self valueOfProperty: #morphBehindBeforePreview! ! -!Morph methodsFor: 'previewing' stamp: 'AY 2/6/2019 05:28:19'! - morphBehindBeforePreview: aMorph - - self setProperty: #morphBehindBeforePreview toValue: aMorph! ! -!Morph methodsFor: 'previewing' stamp: 'AY 2/6/2019 23:56:03'! - previewing - - ^(self valueOfProperty: #previewing) = true! ! -!Morph methodsFor: 'previewing' stamp: 'AY 2/6/2019 23:56:28'! - previewing: aBoolean - - self setProperty: #previewing toValue: aBoolean! ! -!Morph methodsFor: 'previewing' stamp: 'AY 2/6/2019 05:27:23'! - visibleBeforePreview - - ^self valueOfProperty: #visibleBeforePreview! ! -!Morph methodsFor: 'previewing' stamp: 'AY 2/6/2019 05:25:28'! - visibleBeforePreview: aBoolean - - self setProperty: #visibleBeforePreview toValue: self visible! ! -!HoverableButtonMorph methodsFor: 'initialization' stamp: 'AY 2/6/2019 04:01:16'! - model: anObject stateGetter: getStateSel action: actionSel onMouseEnterSend: aMouseEnterSelector onMouseLeaveSend: aMouseLeaveSelector - - super model: anObject stateGetter: getStateSel action: actionSel label: nil. - mouseEnterSelector _ aMouseEnterSelector. - mouseLeaveSelector _ aMouseLeaveSelector.! ! -!HoverableButtonMorph methodsFor: 'events' stamp: 'AY 2/4/2019 04:04:24'! - mouseEnter: event - - mouseEnterSelector ifNotNil: [ model perform: mouseEnterSelector ]. - ^super mouseEnter: event! ! -!HoverableButtonMorph methodsFor: 'events' stamp: 'AY 2/4/2019 04:05:06'! -mouseLeave: event - - mouseLeaveSelector ifNotNil: [ model perform: mouseLeaveSelector ]. - ^super mouseLeave: event! ! -!HoverableButtonMorph class methodsFor: 'instance creation' stamp: 'AY 2/6/2019 03:59:26'! - model: anObject stateGetter: getStateSel action: actionSel onMouseEnterSend: aMouseEnterSelector onMouseLeaveSend: aMouseLeaveSelector - - ^ self new - model: anObject - stateGetter: getStateSel - action: actionSel - onMouseEnterSend: aMouseEnterSelector - onMouseLeaveSend: aMouseLeaveSelector! ! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'AY 2/4/2019 03:26:20' prior: 50431800! - comeToFront - - self atFront ifFalse: [owner addMorphFront: self]! ! -!TaskbarMorph methodsFor: 'services' stamp: 'AY 2/6/2019 04:01:56' prior: 50402070! - addButtonFor: aMorph - - | button | - aMorph == self ifFalse: [ - button _ HoverableButtonMorph - model: aMorph - stateGetter: nil - action: #endPreviewAndToggleCollapseOrShow - onMouseEnterSend: #beginPreview - onMouseLeaveSend: #endPreview. - button - color: self color; - icon: (aMorph imageForm: 32); - setBalloonText: #label. - button icon: button magnifiedIcon. - viewBox - addMorph: button - fixedWidth: self defaultHeight ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3599-WindowPreviewing-AngelYan-2019Feb06-03h50m-AY.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3597] on 8 February 2019 at 10:16:00 pm'! -!Browser methodsFor: 'class list' stamp: 'SLD 2/8/2019 22:07:43' prior: 50407318! - classListIndex: anInteger - "Set anInteger to be the index of the current class selection." - - | className recent canSelectClass classList | - - classList _ self classList. - canSelectClass _ classList isInBounds: anInteger. - selectedClassName _ canSelectClass ifTrue: [ | newClassName | - newClassName := classList at: anInteger ifAbsent: [ nil ]. - newClassName := newClassName ifNotNil: [newClassName withoutLeadingBlanks asSymbol]. - newClassName ]. - self setClassOrganizer. - selectedMessage _ nil. - - self classCommentIndicated ifFalse: [ - self editSelection: (canSelectClass - ifTrue: [#editClass] - ifFalse: [ metaClassIndicated | selectedSystemCategory isNil - ifTrue: [#none] - ifFalse: [#newClass]])]. - - self selectedClass ifNotNil: [ - recent _ self class recentClasses. - className _ self selectedClass name. - (recent includes: className) ifTrue: [recent remove: className]. - recent addFirst: className. - recent size > 16 ifTrue: [recent removeLast]]. - - "Clear selectedMessageCategory if there is no match in the new list of categories" - (self messageCategoryList indexOf: selectedMessageCategory) = 0 ifTrue: [ - selectedMessageCategory _ nil]. - - "We have to refresh the class list if somebody wants to select a class that does not exist anymore - Hernan" - anInteger > classList size ifTrue: [ self changed: #classList ]. - self changed: #classSelectionChanged. - self changed: #classCommentText. - self changed: #classListIndex. "update my selection" - self changed: #messageCategoryList. - self changed: #messageList. - self changed: #relabel. - self acceptedContentsChanged! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3600-try-to-keep-messageCategory-SteveDavies-2019Jan29-21h24m-SLD.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3597] on 4 February 2019 at 12:02:07 am'! -!PackageRequirementsList methodsFor: 'accessing' stamp: 'KLG 2/3/2019 23:50:55'! - updateSelectedRequirement - - | selectedPackage featureSpec newRequires selectedName | - self selectionIndex ifNil: [ ^self ]. - self selectionIndex isZero ifTrue: [ ^self ]. - ((codePackageList selectionIndex isNil) or: [ codePackageList selectionIndex isZero ]) - ifTrue: [ ^self ]. - - selectedPackage := codePackageList selection. - featureSpec := selectedPackage featureSpec. - newRequires := (featureSpec requires copyWithout: self selection), - {((selectedName _ self selection name) = Feature baseSystemFeature name) - ifTrue: [ Feature baseSystemFeature requirementOfMe ] - ifFalse: [ (CodePackage installedPackages at: selectedName) requirementOfMe]}. - featureSpec - provides: featureSpec provides - requires: newRequires. - selectedPackage hasUnsavedChanges: true. - requirements := codePackageList selection requires asArray. - self changed: #requirements - - - ! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'KLG 2/3/2019 23:30:07' prior: 50387936! - buildRequirementsPane - - | requirements deleteReqButton "editReqButton" reqLayout buttonLayout updateReqButton | - requirements := PluggableListMorph - model: (PackageRequirementsList fromCodePackageList: model) - listGetter: #requirementsStrings - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - requirements color: Theme current textPane. - - deleteReqButton := PluggableButtonMorph - model: requirements model - action: #deleteSelectedRequirement - label: 'delete'. - deleteReqButton color: self widgetsColor. - updateReqButton _ PluggableButtonMorph - model: requirements model - action: #updateSelectedRequirement - label: 'update'. - updateReqButton color: self widgetsColor. - - buttonLayout := LayoutMorph newRow. - buttonLayout - addMorph: deleteReqButton - layoutSpec: (LayoutSpec - proportionalWidth: 1.0 - proportionalHeight: 1.0 - minorDirectionPadding: #top); - color: self widgetsColor quiteWhiter; - addMorph: updateReqButton - layoutSpec: (LayoutSpec - proportionalWidth: 1.0 - proportionalHeight: 1.0 - minorDirectionPadding: #top); - color: self widgetsColor quiteWhiter. - - model when: #changed: send: #updateRequirementsFromPackageList to: requirements model. - self when: #changed: send: #updateRequirementsFromPackageList to: requirements model. - requirements model when: #changed: send: #verifyContents to: requirements. - self when: #changed: send: #verifyContents to: requirements. - - reqLayout := LayoutMorph newRow. - ^ reqLayout - doAdoptWidgetsColor; - addMorph: requirements - layoutSpec: (LayoutSpec - proportionalWidth: 0.8 - proportionalHeight: 1.0 - minorDirectionPadding: #left); - addMorph: buttonLayout - layoutSpec: (LayoutSpec - proportionalWidth: 0.2 - proportionalHeight: 1.0 - minorDirectionPadding: #right); - color: `Color transparent`; - yourself - ! ! -!CodePackageListWindow methodsFor: 'commands' stamp: 'KLG 2/3/2019 23:35:44' prior: 16811558! - addRequirement - "Ask user for a FeatureRequirement based on loaded packages" - - | current currentName packageNames reqiredNames selectionNames choices selection cuisBaseName req selectedName | - current _ model selection. - current ifNil: [ ^self ]. - - packageNames := model packages collect: [ :pak | pak packageName ]. - currentName := current packageName. - reqiredNames := current requires collect: [ :r | r name ]. - selectionNames := packageNames select: [ :name | - ((name = currentName) or: [reqiredNames includes: name]) not ]. - cuisBaseName := Feature baseSystemFeature name. - choices := OrderedCollection with: #CANCEL. - (reqiredNames includes: cuisBaseName) - ifFalse: [ choices add: cuisBaseName ]. - choices addAll: selectionNames. - choices size = 1 ifTrue: [ - ^ PopUpMenu inform: 'All loaded packages are already required, as is Cuis base system' ]. - selection := PopUpMenu - withCaption: 'Choose package to require' - chooseFrom: choices. - selection <= 1 - ifTrue: [ ^ self ] "1 -> Cance, 0 -> Clicked outside the menu" - ifFalse: [ - selectedName := choices at: selection. - req := (selectedName = cuisBaseName) - ifTrue: [ Feature baseSystemFeature requirementOfMe ] - ifFalse: [ (CodePackage installedPackages at: selectedName) requirementOfMe]. - current featureSpec requires: req. - current hasUnsavedChanges: true. - self changed: #requirement ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3601-InstalledPackagesTool-enh-GeraldKlix-BetterInstalledPackagesBrowser-KLG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3597] on 4 February 2019 at 4:55:07 pm'! -!Editor class methodsFor: 'class initialization' stamp: 'HAW 2/4/2019 16:54:10'! - initializeCmdShortcutsUsing: anInitializationMessage - - | dynamicInitializationMessage | - - self putIntoCmdShortcuts: (self perform: anInitializationMessage). - - dynamicInitializationMessage := (self name asString uncapitalized, anInitializationMessage asString capitalized) asSymbol. - (Smalltalk allClassesImplementing: dynamicInitializationMessage) do: [ :aClass | - self putIntoCmdShortcuts: (aClass soleInstance perform: dynamicInitializationMessage) ]. - - -! ! -!Editor class methodsFor: 'class initialization' stamp: 'HAW 2/4/2019 16:53:40'! -putIntoCmdShortcuts: shortcutsSpec - - shortcutsSpec do: [ :ary | cmdShortcuts at: ary first numericValue + 1 put: ary second ].! ! -!Editor class methodsFor: 'class initialization' stamp: 'HAW 2/4/2019 16:51:32' prior: 16836915! - initializeCmdShortcuts - "Initialize the (unshifted) command-key (or alt-key if not on Mac) shortcut table. - If you want to add a new shortcut for an specific editor, for example SmalltalkEditor, you should - define the message #smalltalkEditorCmdShortcutsSpec in a class of your category and it will - be dynamically send" - - "NOTE: if you don't know what your keyboard generates, use Sensor test" - - " - Editor initialize - " - - cmdShortcuts _ Array new: 256 withAll: #noop:. - - self initializeCmdShortcutsUsing: #basicCmdShortcutsSpec. - self initializeCmdShortcutsUsing: #cmdShortcutsSpec. -! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3602-PluggableEditorShortcuts-HernanWilkinson-2019Feb04-15h45m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3589] on 4 February 2019 at 11:11:35 pm'! -!Collection methodsFor: 'enumerating' stamp: 'AY 2/4/2019 23:11:18' prior: 50381597! - select: selectBlock thenDo: doBlock - "Equivalent to - (self select: selectBlock) do: doBlock - but avoid creating an extra collection." - - self do: [ :each | (selectBlock value: each) ifTrue: [ doBlock value: each ]]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3603-CollectionSelectThenDoMessageFix-AngelYan-2019Feb04-23h11m-AY.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3598] on 6 February 2019 at 12:02:06 pm'! -!Boolean methodsFor: 'logical operations' stamp: 'HAW 2/6/2019 12:01:53'! - xor: aBoolean - - self subclassResponsibility! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3604-Boolean-xor-HernanWilkinson-2019Feb06-12h00m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3598] on 6 February 2019 at 1:38:28 pm'! -!TestCase methodsFor: 'assertions' stamp: 'HAW 2/6/2019 12:17:47' prior: 50424297! - should: aBlockToFail raise: anExceptionHandlingCondition withMessageText: anExpectedErrorMessageCreator - - self - should: aBlockToFail - raise: anExceptionHandlingCondition - withExceptionDo: [ :anException | self assert: anExpectedErrorMessageCreator value equals: anException messageText ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3605-TestCase-enh-HernanWilkinson-2019Feb06-12h04m-HAW.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3598] on 6 February 2019 at 1:57:15 pm'! -!SHTextStylerST80 methodsFor: 'private' stamp: 'HAW 2/6/2019 13:57:03' prior: 50371895! - privateStyle - - | alpha end start count startIndexes c hue | - self parseSetWorkspace: true. - parser ranges ifNotNil: [ :ranges | - self setAttributesFromRanges: ranges ]. - - Preferences highlightBlockNesting ifTrue: [ - startIndexes _ parser blockDepthsStartIndexes. - count _ startIndexes size. - parser blockDepths withIndexDo: [ :depth :idx | - start _ startIndexes at: idx. - end _ idx = count ifTrue: [formattedText size] ifFalse: [ (startIndexes at: idx+1)-1]. - alpha _ depth / 10.0 min: 1.0. - hue _ depth * 60. - c _ Color h: hue s: 0.2 v: 0.5 alpha: alpha. - formattedText - addAttribute: (ShoutTextBackgroundColor color: c ) - from: start - to: end ]]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3606-TextStyler-tweak-HernanWilkinson-2019Feb06-13h38m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3598] on 6 February 2019 at 4:15:11 pm'! -!AutoCompleterMorph methodsFor: 'as yet unclassified' stamp: 'HAW 2/6/2019 16:14:45' prior: 16781473! - updateColor - - | remaining alpha | - - remaining := (self timeout - self timeOfLastActivity). - remaining < 1000 - ifTrue: [ - alpha _ remaining / 1000.0. - self color: (self color alpha: alpha). - self borderColor: (borderColor alpha: alpha) ] - ifFalse: [ - self color: self defaultColor. - self borderColor: self defaultBorderColor ] - - ! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3607-AutoCompleter-fix-HernanWilkinson-2019Feb06-16h14m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3607] on 16 February 2019 at 7:46:40 pm'! -!Morph methodsFor: 'drawing' stamp: 'jmv 2/7/2019 20:44:52' prior: 50337368! - visible: aBoolean - "set the 'visible' attribute of the receiver to aBoolean" - - self visible == aBoolean - ifTrue: [ ^ self ]. - aBoolean ifFalse: [ - self redrawNeeded ]. - self setProperty: #visible toValue: aBoolean. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - aBoolean ifTrue: [ - self redrawNeeded]! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 2/7/2019 20:45:05' prior: 50337295! - wasOpened: aMorph - "aMorph was added to the world. Add button for aMorph if appropriate (see #taskbarIncludesAllWindows)" - - self addButtonFor: aMorph! ! -!TaskbarMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 2/7/2019 20:44:10' prior: 50337624! - noteNewOwner: aMorph - "I have just been added as a submorph of aMorph" - super noteNewOwner: aMorph. - aMorph submorphsDo: [ :m | - self addButtonFor: m ]. - self notifyDisplayResize! ! - -TaskbarMorph removeSelector: #wasMadeVisible:! - -TaskbarMorph removeSelector: #wasMadeVisible:! - -Preferences class removeSelector: #taskbarIncludesAllWindows! - -Preferences class removeSelector: #taskbarIncludesAllWindows! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3608-TaskbarAlwaysShowsAllWindows-JuanVuletich-2019Feb16-19h39m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3597] on 8 February 2019 at 11:44:02 pm'! - -IdentityDictionary subclass: #SystemDictionary - instanceVariableNames: 'cachedClassNames cachedNonClassNames startUpScriptArguments startUpArguments ' - classVariableNames: 'EndianCache LastImageName LastQuitLogPosition LowSpaceProcess LowSpaceSemaphore ShutDownList SourceFileVersionString SpecialSelectors StartUpList StartupStamp WordSize ChangesInitialFileSize ' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #SystemDictionary category: #'System-Support'! -IdentityDictionary subclass: #SystemDictionary - instanceVariableNames: 'cachedClassNames cachedNonClassNames startUpScriptArguments startUpArguments' - classVariableNames: 'ChangesInitialFileSize EndianCache LastImageName LastQuitLogPosition LowSpaceProcess LowSpaceSemaphore ShutDownList SourceFileVersionString SpecialSelectors StartUpList StartupStamp WordSize' - poolDictionaries: '' - category: 'System-Support'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 2/8/2019 23:43:13' prior: 16922741! - saveAs: newName andQuit: aBoolean clearAllClassState: clearAllStateFlag - "Save the image under a new name." - - | newChangesName | - self currentChangesName ifNotNil: [ :oldChangesName | - self closeSourceFiles. "so copying the changes file will always work" - newChangesName _ self fullNameForChangesNamed: newName. - FileIOAccessor default copy: oldChangesName asFileEntry to: newChangesName asFileEntry. - ChangesInitialFileSize ifNotNil: [ - oldChangesName asFileEntry appendStreamDo: [ :strm | strm truncate: ChangesInitialFileSize ]]]. - - self - changeImageNameTo: (self fullNameForImageNamed: newName); - closeSourceFiles; openSourceFiles; "so SNAPSHOT appears in new changes file" - snapshot: true andQuit: aBoolean - clearAllClassState: clearAllStateFlag! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 2/8/2019 23:32:57' prior: 50381434! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag -"WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " -| activeProc | -activeProc _ Processor activeProcess. -[ - | isARealStartup guiRootObject guiRootObjectClass reopenTranscript | - save not & quit - ifTrue: [ - (SourceFiles at: 2) ifNotNil: [ :changes | - ChangesInitialFileSize ifNotNil: [ - changes truncate: ChangesInitialFileSize ]]] - ifFalse: [ self logSnapshot: save andQuit: quit ]. - - reopenTranscript _ false. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | each isInWorld ifTrue: [ each delete. reopenTranscript _ true ]]. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - - - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - - "Cosas que levanto explicitamente abajo" - guiRootObjectClass _ UISupervisor ui class. - guiRootObject _ UISupervisor ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "guiRootObject _ clearAllStateFlag ifFalse: [ UISupervisor ui ]." - UISupervisor stopUIProcess. - activeProc isTerminated ifFalse: [ - activeProc terminate ]. - - "Clean Globals" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: nil. - Smalltalk closeSourceFiles. Smalltalk at: #SourceFiles put: nil. - Smalltalk allClassesDo: [ :cls | cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ Smalltalk printStuffToCleanOnImageSave ]. - - - "Do image save & quit as apropriate" - Cursor write activateCursor. - save - ifTrue: [ - "The snapshot primitive answers false if it was just called to do the snapshot. - But image startup is resumed by returning (again) from the primitive, but this time answering true." - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - - - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: DisplayScreen new. - Smalltalk at: #SourceFiles put: (Array new: 2). - Smalltalk openSourceFiles. - - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - - UISupervisor spawnNewMorphicProcessFor: (guiRootObject ifNil: [ guiRootObject _ guiRootObjectClass newWorld ]). - Display triggerEvent: #screenSizeChanged. - - self restoreLostChangesIfNecessary. - - UISupervisor whenUIinSafeState: [ - "guiRootObject fullRepaintNeeded." - reopenTranscript ifTrue: [ - TranscriptWindow openTranscript ]]. - - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - UISupervisor whenUIinSafeState: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]. - -] forkAt: Processor timingPriority-1 named: 'Startup process'.! ! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'jmv 2/8/2019 23:33:15' prior: 16923339! - openSourcesAndChanges - "Open the changes and sources files and install them in SourceFiles. Inform the user of problems regarding write permissions or Lf/CrLf mixups." - "Note: SourcesName and imageName are full paths; changesName is a - local name." - | sources changes msg wmsg entry | - msg _ 'Cuis cannot locate XfileRef -Please check that the file is named properly and is in the -same directory as this image.'. - wmsg _ 'Cuis cannot write to XfileRef. - -Please check that you have write permission for this file. - -You won''t be able to save this image correctly until you fix this.'. - - "Do not open source files if internalized (i.e. notNil)" - sources _ SourceFiles at: 1. - sources ifNil: [ - entry _ Smalltalk defaultSourcesName asFileEntry. - entry exists ifFalse: [ - entry _ Smalltalk alternativeSourcesName asFileEntry ]. - entry exists ifTrue: [ - sources _ [ entry readStream ] on: FileDoesNotExistException do: [ nil ]]]. - (sources isNil and: [ Preferences valueOfFlag: #warnIfNoSourcesFile ]) - ifTrue: [ - Smalltalk platformName = 'Mac OS' ifTrue: [ - msg _ msg , String newLineString, 'Make sure the sources file is not an Alias.']. - self inform: (msg copyReplaceAll: 'XfileRef' with: 'the sources file named ' , entry pathName) ]. - - "Do not open source files if internalized (i.e. notNil)" - changes _ (SourceFiles at: 2) ifNil: [ - entry _ Smalltalk defaultChangesName asFileEntry. - [ entry appendStream ] on: FileWriteError do: [ nil ] ]. - (changes isNil and: [ Preferences valueOfFlag: #warnIfNoChangesFile ]) - ifTrue: [self inform: (wmsg copyReplaceAll: 'XfileRef' with: 'the changes file named ' , entry pathName)]. - ChangesInitialFileSize _ changes ifNotNil: [ changes position ]. - - SourceFiles _ Array with: sources with: changes! ! - -IdentityDictionary subclass: #SystemDictionary - instanceVariableNames: 'cachedClassNames cachedNonClassNames startUpScriptArguments startUpArguments' - classVariableNames: 'ChangesInitialFileSize EndianCache LastImageName LastQuitLogPosition LowSpaceProcess LowSpaceSemaphore ShutDownList SourceFileVersionString SpecialSelectors StartUpList StartupStamp WordSize' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #SystemDictionary category: #'System-Support'! -IdentityDictionary subclass: #SystemDictionary - instanceVariableNames: 'cachedClassNames cachedNonClassNames startUpScriptArguments startUpArguments' - classVariableNames: 'ChangesInitialFileSize EndianCache LastImageName LastQuitLogPosition LowSpaceProcess LowSpaceSemaphore ShutDownList SourceFileVersionString SpecialSelectors StartUpList StartupStamp WordSize' - poolDictionaries: '' - category: 'System-Support'! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3609-TruncateChangesOnQuitNoSave-JuanVuletich-2019Feb08-23h36m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3609] on 16 February 2019 at 8:06:52 pm'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 2/16/2019 20:06:00' prior: 50369650! -snapshotMessageFor: save andQuit: quit - - | dateAndTime | - dateAndTime _ DateAndTime now. - ^String streamContents: [ :stream | - stream - nextPutAll: self tagHeader; - nextPutAll: (self snapshotTagFor: save andQuit: quit); - nextPutAll: self tagTail. - stream nextPut: $(. - dateAndTime date printOn: stream. - stream space. - dateAndTime time print24: true showSeconds: true on: stream. - stream nextPut: $). - stream - space; - nextPutAll: self imageName asFileEntry name; - nextPutAll: ' priorSource: '; - print: LastQuitLogPosition ].! ! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'jmv 2/16/2019 20:02:34' prior: 16923402! - timeStamp: aStream - "Writes system version and current time on stream aStream." - - | dateTime | - dateTime _ DateAndTime now. - aStream - nextPutAll: 'From '; - nextPutAll: Smalltalk datedVersion; - nextPutAll: ' ['; - nextPutAll: Smalltalk lastUpdateString; - nextPutAll: '] on '. - dateTime date printOn: aStream. - aStream - nextPutAll: ' at '. - dateTime time print24: false showSeconds: true on: aStream! ! -!SystemDictionary methodsFor: 'startup' stamp: 'jmv 2/16/2019 20:03:15' prior: 16925503! - setStartupStamp - - | dateAndTime | - dateAndTime _ DateAndTime now. - StartupStamp _ String streamContents: [ :stream | - stream nextPutAll: '----STARTUP---- ('. - dateAndTime date printOn: stream. - stream space. - dateAndTime time print24: true showSeconds: true on: stream. - stream - nextPutAll: ') as '; - nextPutAll: Smalltalk imageName ] -! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3610-NicerStartupAndSnapshotStamps-JuanVuletich-2019Feb16-19h50m-jmv.1.cs.st----! - -----SNAPSHOT----(16 February 2019 21:32:48) Cuis5.0-3610-32.image priorSource: 3163573! - -----QUIT----(16 February 2019 21:32:58) Cuis5.0-3610-32.image priorSource: 3233786! - -----STARTUP---- (15 March 2019 17:26:38) as /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/Cuis5.0-3610-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3598] on 10 February 2019 at 9:09:37 pm'! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'HAW 2/10/2019 21:09:29' prior: 16902967! - namesBeginningWith: aString do: aBlock - "Evaluate aBlock for all available names that start with aString" - - self nonGlobalNamesDo: [ :name | - (name beginsWith: aString) ifTrue: [ aBlock value: name ]]. - Smalltalk namesBeginningWith: aString do: aBlock - -! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3611-CodeStylerTweak-HernanWilkinson-2019Feb06-16h15m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3598] on 14 February 2019 at 5:45:58 pm'! -!TextModelMorph methodsFor: 'initialization' stamp: 'HAW 2/14/2019 17:40:47'! - escAction: aBlock - - self textMorph escAction: aBlock! ! -!InnerTextMorph methodsFor: 'accessing' stamp: 'HAW 2/14/2019 17:37:45'! - escAction - - "Return the action to perform when user presses key" - - ^self valueOfProperty: #escAction! ! -!InnerTextMorph methodsFor: 'accessing' stamp: 'HAW 2/14/2019 17:40:40'! - escAction: aBlock - - "Sets the action to perform when user presses key" - - ^self setProperty: #escAction toValue: aBlock ! ! -!InnerTextMorph methodsFor: 'event handling' stamp: 'HAW 2/14/2019 17:45:05' prior: 16855817! - processKeyStroke: evt - | action | - - (acceptOnCR and: [evt isReturnKey]) ifTrue: [^ self acceptContents]. - - self pauseBlinking. - - "Return - check for special action" - evt isReturnKey ifTrue: [ - action _ self crAction. - action ifNotNil: [ ^action value]]. - - "Esc - check for special action" - evt isEsc ifTrue: [ - action _ self escAction. - action ifNotNil: [ ^action value]]. - - self handleInteraction: [ editor processKeyStroke: evt ]. - - "Is this really needed? It produces whole morph invalidation just by (for example) - moving the cursor around... (jmv Aug 6, 2014)" - "self updateFromTextComposition." - - self scrollSelectionIntoView! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'HAW 2/14/2019 17:42:22' prior: 50385758! - createTextPaneAcceptOnCR: acceptBoolean - "create the textPane" - | result | - - self flag: #todo. "Integrate this method with the Theme system. --cbr" - - result _ TextModelMorph - textProvider: self - textGetter: #response - textSetter: #response: - selectionGetter: #selectionInterval. - - result - hasUnacceptedEdits: true; - acceptOnCR: acceptBoolean; - escAction: [ self cancelClicked ]; - morphExtent: `18@5` * self sizeUnit. - - self addMorph: result position: `1@2` * self sizeUnit. - - ^ result! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3612-EscCancelsFillIntheBlankMorph-HernanWilkinson-2019Feb11-15h04m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3598] on 11 February 2019 at 3:04:48 pm'! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3613-TestCase-MessageCategorization-HernanWilkinson-2019Feb11-14h14m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3612] on 19 February 2019 at 11:50:01 am'! -!SHParserST80 methodsFor: 'aux' stamp: 'jmv 2/19/2019 11:49:22'! - namesBeginningWith: aString do: aBlock in: aCollection - "aCollection is sorted" - " - self new namesBeginningWith: 'O' do: [ :each | each print ] in: Smalltalk classNames - self new namesBeginningWith: 'ObjectExplorer' do: [ :each | each print ] in: Smalltalk classNames - self new namesBeginningWith: 'ObjectExplorerWrapper' do: [ :each | each print ] in: Smalltalk classNames - " - | count | - - "Find the first element starting with aString" - count _ aCollection size. - aCollection - findBinaryIndex: [ :element | - element < aString - ifFalse: [ -1 ] - ifTrue: [ 1 ] ] - do: [ :found | "Will never find any" ] - ifNone: [ :a :b | | i n | - i _ b. - [ i <= count and: [ - n _ aCollection at: i. - aString isEmpty or: [ - n beginsWith: aString ]]] whileTrue: [ - aBlock value: n. - i _ i + 1 ]]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 11:48:10' prior: 50432719! - namesBeginningWith: aString do: aBlock - "Evaluate aBlock for all available names that start with aString" - - self nonGlobalNamesDo: [ :name | - (name beginsWith: aString) ifTrue: [ aBlock value: name ]]. - self namesBeginningWith: aString do: aBlock in: Smalltalk classNames. - self namesBeginningWith: aString do: aBlock in: Smalltalk nonClassNames - -! ! - -SystemDictionary removeSelector: #namesBeginningWith:do:! - -SystemDictionary removeSelector: #namesBeginningWith:do:! - -SystemDictionary removeSelector: #namesBeginningWith:do:in:! - -SystemDictionary removeSelector: #namesBeginningWith:do:in:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3614-CodeColorizerSmallRefactor-JuanVuletich-2019Feb19-11h47m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3612] on 19 February 2019 at 12:26:57 pm'! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'jmv 2/19/2019 12:26:00' prior: 50415520! - computeIdentifierEntries - "Use an aux Set to avoid duplicates, but keep the order given." - | entriesSet lastTitle | - - entriesSet _ Set new. - lastTitle _ nil. - entries _ Array streamContents: [ :strm | - parser namesBeginningWith: prefix do: [ :identifier :kindOfIdentifierTitle | - (entriesSet includes: identifier) ifFalse: [ - kindOfIdentifierTitle = lastTitle ifFalse: [ - strm nextPut: kindOfIdentifierTitle. - lastTitle _ kindOfIdentifierTitle ]. - entriesSet add: identifier. - strm nextPut: identifier ]]]! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:09:28' prior: 16902093! - isBlockArgName: aString - "Answer true if aString is the name of a block argument, false otherwise" - - self blockArgNamesDo: [ :arg :dummy | arg = aString ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:09:18' prior: 16902101! - isBlockTempName: aString - "Answer true if aString is the name of a block temporary. false otherwise" - - self blockTempNamesDo: [ :arg :dummy | arg = aString ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:09:31' prior: 16902130! - isIncompleteBlockArgName: aString - "Answer true if aString is the start of the name of a block argument, false otherwise" - - self blockArgNamesDo: [ :arg :dummy | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:09:21' prior: 16902140! - isIncompleteBlockTempName: aString - "Answer true if aString is the start of the name of a block temporary. false otherwise" - - self blockTempNamesDo: [ :arg :dummy | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:09:05' prior: 16902150! - isIncompleteClassVarName: aString - "Answer true if aString is the start of the name of a class variable, false otherwise" - - self classVarNamesDo: [ :arg :dummy | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:08:54' prior: 16902168! - isIncompleteInstVarName: aString - "Answer true if aString is the start of the name of an instance variable, false otherwise" - - self instVarNamesDo: [ :arg :dummy | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:08:42' prior: 16902178! - isIncompleteMethodArgName: aString - "Answer true if aString is the start of the name of a method argument, false otherwise. - Does not check whether aString is also a blockArgName" - - self methodArgNamesDo: [ :arg :dummy | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:08:34' prior: 16902190! - isIncompleteMethodTempName: aString - "Answer true if aString is the start of the name of a method temporary, false otherwise." - - self methodTempNamesDo: [ :arg :dummy | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:07:49' prior: 16902200! - isIncompletePoolConstantName: aString - "Answer true if aString is the start of the name of a pool constant, false otherwise" - - self poolConstantNamesDo: [ :arg :dummy | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:07:38' prior: 16902219! - isIncompleteWorkspaceVarName: aString - "Answer true if aString is the start of the name of an workspace variable, false otherwise" - - self workspaceNamesDo: [ :arg :dummy | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:08:58' prior: 16902229! - isInstVarName: aString - "Answer true if aString is the name of an instance variable, false otherwise" - - self instVarNamesDo: [ :arg :dummy | arg = aString ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:08:45' prior: 16902238! - isMethodArgName: aString - "Answer true if aString is the name of a method argument, false otherwise. - Does not check whether aString is also a blockArgName" - - self methodArgNamesDo: [ :arg :dummy | arg = aString ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:08:28' prior: 16902248! - isMethodTempName: aString - "Answer true if aString is the name of a method temporary, false otherwise. - Does not check whether aString is also a block temporary - or argument" - - self methodTempNamesDo: [ :arg :dummy | arg = aString ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:23:37' prior: 16902922! - blockArgNamesDo: aBlock - "Iterate over block argument names valid at current blockDepth" - - | title | - title _ '--- Block Arguments ---'. - blockDepth to: 1 by: -1 do: [ :level | - arguments at: level ifPresent: [ :args | args do: [ :name | aBlock value: name value: title ] ]]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:23:47' prior: 16902931! - blockTempNamesDo: aBlock - "Iterate over block temp names valid at current blockDepth" - - | title | - title _ '--- Block Variables ---'. - blockDepth to: 1 by: -1 do: [ :level | - temporaries at: level ifPresent: [ :args | args do: [ :name | aBlock value: name value: title ] ]]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:23:53' prior: 16902940! - classVarNamesDo: aBlock - - | title | - title _ '--- Class Variables ---'. - classOrMetaClass isBehavior - ifTrue: [ - classOrMetaClass theNonMetaClass withAllSuperclasses do: [ :c | - c classPool keysDo: [ :name | aBlock value: name value: title ] ]]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:24:00' prior: 16902948! - instVarNamesDo: aBlock - - | title | - title _ '--- Instance Variables ---'. - instanceVariables do: [ :name | aBlock value: name value: title ]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:24:05' prior: 16902953! - methodArgNamesDo: aBlock - "Iterate over method argument names" - - | title | - title _ '--- Method Arguments ---'. - ^arguments at: 0 ifPresent: [ :args | args do: [ :name | aBlock value: name value: title ] ]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:24:10' prior: 16902960! - methodTempNamesDo: aBlock - "Iterate over method temporary names" - - | title | - title _ '--- Method Variables ---'. - ^temporaries at: 0 ifPresent: [ :args | args do: [ :name | aBlock value: name value: title ] ]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:20:50' prior: 50432844! - namesBeginningWith: aString do: aBlock - "Evaluate aBlock for all available names that start with aString" - - self nonGlobalNamesDo: [ :name :kindOfIdentifierTitle | - (name beginsWith: aString) ifTrue: [ aBlock value: name value: kindOfIdentifierTitle ]]. - self namesBeginningWith: aString do: [ :name | aBlock value: name value: '--- Classes ---' ] in: Smalltalk classNames. - self namesBeginningWith: aString do: [ :name | aBlock value: name value: '--- Globals ---' ] in: Smalltalk nonClassNames! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:24:43' prior: 50368726! - nonGlobalNamesDo: aBlock - "Evaluate aBlock over all available names, except for globals" - - self - blockArgNamesDo: aBlock; - blockTempNamesDo: aBlock; - methodArgNamesDo: aBlock; - methodTempNamesDo: aBlock; - instVarNamesDo: aBlock; - classVarNamesDo: aBlock; - poolConstantNamesDo: aBlock; - workspaceNamesDo: aBlock. - self - reservedNames do: [ :name | - aBlock value: name value: '--- Pseudovariables ---' ]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:24:53' prior: 16902993! - poolConstantNamesDo: aBlock - - | title | - title _ '--- Pool Variables ---'. - classOrMetaClass isBehavior - ifTrue: [ - classOrMetaClass theNonMetaClass withAllSuperclasses do: [ :c | - c sharedPools do: [ :pool | - pool bindingsDo: [ :assoc | aBlock value: assoc key value: title ]]]]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:25:01' prior: 16903009! - workspaceNamesDo: aBlock - - | title | - title _ '--- Workspace Variables ---'. - workspace ifNotNil: [ - workspace bindingNamesDo: [ :name | aBlock value: name value: title ] ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3615-Autocompleter-GroupNamesByKind-JuanVuletich-2019Feb19-11h50m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3590] on 19 February 2019 at 2:11:35 pm'! - -BorderedRectMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity selectorDocumentation originalPosition showUp ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #AutoCompleterMorph category: #'Tools-Autocompletion'! -BorderedRectMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity selectorDocumentation originalPosition showUp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser possibleInvalidSelectors selectorsClasses ' - classVariableNames: 'AccessLock EntriesLimit Selectors ' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #SmalltalkCompleter category: #'Tools-Autocompletion'! -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser possibleInvalidSelectors selectorsClasses' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -SmalltalkCompleter subclass: #DynamicTypingSmalltalkCompleter - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #DynamicTypingSmalltalkCompleter category: #'Tools-Autocompletion'! -SmalltalkCompleter subclass: #DynamicTypingSmalltalkCompleter - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -Object subclass: #AutoCompleterSelectorsCollector - instanceVariableNames: 'categoriesWithSelectors addedSelectorsFastSet prefix entriesToShow possibleInvalidSelectors otherClasses selectorsLimit' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #AutoCompleterSelectorsCollector category: #'Tools-Autocompletion'! -Object subclass: #AutoCompleterSelectorsCollector - instanceVariableNames: 'categoriesWithSelectors addedSelectorsFastSet prefix entriesToShow possibleInvalidSelectors otherClasses selectorsLimit' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -Object subclass: #SHParserST80 - instanceVariableNames: 'classOrMetaClass source workspace arguments sourcePosition currentToken currentTokenFirst temporaries instanceVariables errorBlock currentTokenSourcePosition blockDepth bracketDepth ranges blockDepths blockDepthsStartIndexes allSource ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -!classDefinition: #SHParserST80 category: #'Tools-Syntax Highlighting'! -Object subclass: #SHParserST80 - instanceVariableNames: 'classOrMetaClass source workspace arguments sourcePosition currentToken currentTokenFirst temporaries instanceVariables errorBlock currentTokenSourcePosition blockDepth bracketDepth ranges blockDepths blockDepthsStartIndexes allSource' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! -!TextModel methodsFor: 'shout styling' stamp: 'HAW 1/19/2019 20:23:45'! - shouldStyle: aText with: aSHTextStylerST80 - - ^true! ! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 12:30:03'! - computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 12:30:09'! -computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 12:30:14'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 12:30:20'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 2/6/2019 20:21:41'! - computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName - - textProvider computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName -! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 2/6/2019 20:28:38'! - computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName - - textProvider computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 2/6/2019 19:56:26'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - textProvider computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName -! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 2/6/2019 20:11:16'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - textProvider computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName -! ! -!Workspace methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 12:46:35'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - anAutocompleter computeMessageEntriesForClassOrNil: (self classOfBindingOf: aName)! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 12:30:29'! - computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 12:30:35'! - computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 12:30:44'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 12:30:51'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 2/18/2019 18:18:51'! - computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName - - self computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName -! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 2/6/2019 20:28:21'! - computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName - - ^self computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName ! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 12:35:07'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - contextStackIndex = 0 - ifTrue: [ anAutocompleter computeMessageEntriesForUnknowClass ] - ifFalse: [ anAutocompleter computeMessageEntriesForClass: (self receiver instVarNamed: aName) class]! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 12:35:07'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - | context tempIndex | - - context := self selectedContext. - tempIndex := context tempNames indexOf: aName ifAbsent: [ ^ anAutocompleter computeMessageEntriesForUnknowClass ]. - - anAutocompleter computeMessageEntriesForClass: (self debuggerMap namedTempAt: tempIndex in: context) class - - ! ! -!Inspector methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 12:35:07'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - anAutocompleter computeMessageEntriesForClass: (object instVarNamed: aName) class ! ! -!CompiledMethod methodsFor: 'auto complete' stamp: 'HAW 2/10/2019 17:37:57'! - autoCompleterDocumentationAppendingToParameter: aParameterAppendBlock toReturn: aReturnAppendBlock - - "This message is sent either by the dynamic typing or live typing auto complete. If you do not have - live typing installed you will see one sender, do not refactor it!! - Hernan" - - | methodNode text | - - text := self receiverTextAutoCompleterDocumentation. - - methodNode := self methodNode. - text := self selectorAutoCompleterDocumentationAppendingTo: text using: methodNode appendingToParameter: aParameterAppendBlock. - text := text append: aReturnAppendBlock value. - text := self commentAutoCompleterDocumentationAppendigTo: text using: methodNode. - - ^text! ! -!CompiledMethod methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 18:52:30'! - commentAutoCompleterDocumentationAppendigTo: text using: methodNode - - | comment | - - comment := methodNode comment. - ^ comment - ifNil: [ text ] - ifNotNil: [ text append: (self commentAutoCompleterDocumentationOf: comment)]. - - ! ! -!CompiledMethod methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 18:53:01'! - commentAutoCompleterDocumentationOf: comment - - ^ Text - string: (String streamContents: [ :stream | - stream - newLine; newLine; - nextPutAll: comment first ]) - attributes: (SHTextStylerST80 attributesFor: #comment)! ! -!CompiledMethod methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 18:22:02'! - dynamicTypingAutoCompleterDocumentation - - ^ self - autoCompleterDocumentationAppendingToParameter: [ :parameterName | '' ] - toReturn: [ '' ]! ! -!CompiledMethod methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 18:37:27'! - receiverTextAutoCompleterDocumentation - - | receiverString | - - receiverString := String streamContents: [ :stream | - stream - print: self methodClass; - nextPutAll: '>>' ]. - - ^Text string: receiverString attributes: (SHTextStylerST80 attributesFor: #patternKeyword). - - ! ! -!CompiledMethod methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 18:45:23'! - selectorAutoCompleterDocumentationAppendingTo: sourceText using: methodNode appendingToParameter: aParameterAppendBlock - - | selector text | - - selector := methodNode selectorNode key. - selector isUnary - ifTrue: [ text := sourceText append: (Text string: selector attributes: (SHTextStylerST80 attributesFor: #patternKeyword)) ] - ifFalse: [ - text := sourceText. - selector keywords - with: methodNode argumentNames - do: [ :keyword :argumentName | - text := text append: (Text string: keyword attributes: (SHTextStylerST80 attributesFor: #patternKeyword)). - text := text append: (Text string: ' ', argumentName, ' ' attributes: (SHTextStylerST80 attributesFor: #methodArg)). - text := text append: (aParameterAppendBlock value: argumentName) ] - separatedBy: [ text := text append: String newLineString, String tab ]]. - - ^ text -! ! -!TextEditor methodsFor: 'as yet unclassified' stamp: 'HAW 2/12/2019 17:14:49'! - characterBlockForIndex: anIndex - - ^ textComposition characterBlockForIndex: anIndex ! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'HAW 2/12/2019 18:22:48' prior: 16781439! - resetMenu - - | width newExtent adjustedY | - - self hideSelectorDocumentation. - firstVisible _ 1. - self selected: 1. - - width _ self calculateWidth. - newExtent _ width + 4 @ (self visibleItemsCount * self itemHeight+2). - - adjustedY := (self isYOutOfScreen: originalPosition with: newExtent) - ifTrue: [ originalPosition y - newExtent y - self itemHeight ] - ifFalse: [ originalPosition y ]. - - self morphPosition: originalPosition x @ adjustedY extent: newExtent. -! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/11/2019 20:13:14'! - adjust: aLocation ifOutOfScreenWith: anExtent xOffset: xOffset yOffset: yOffset - - | adjustedLocationX adjustedLocationY | - - adjustedLocationX := (self isXOutOfScreen: aLocation with: anExtent) - ifTrue: [ aLocation x - anExtent x - xOffset ] - ifFalse: [ aLocation x ]. - - adjustedLocationX < 0 ifTrue: [ adjustedLocationX := aLocation x ]. - - adjustedLocationY := (self isYOutOfScreen: aLocation with: anExtent) - ifTrue: [ aLocation y - anExtent y - yOffset ] - ifFalse: [ aLocation y ]. - - ^adjustedLocationX @ adjustedLocationY - ! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/11/2019 18:22:59'! - calculateWidth - - | width font | - - width _ 120. - font _ self class listFont. - - 1 - to: completer entryCount - do: [ :index | width _ width max: (font widthOfString: (completer entries at: index) asString)]. - - completer entryCount > self class itemsPerPage ifTrue: [ width _ width + ScrollBar scrollbarThickness ]. - - ^ width ! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/14/2019 17:10:34'! - colorOf: entry - - ^(completer isPossibleInvalidEntry: entry) - ifTrue: [ `Color blue` ] - ifFalse: [ Theme current text ] - ! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/10/2019 23:23:08'! - drawContainingRectangle: aCanvas - - aCanvas frameAndFillRectangle: (`0@0` extent: extent) fillColor: self color borderWidth: borderWidth borderColor: borderColor. -! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/10/2019 23:55:46'! - drawDownArrowOn: aCanvas thickness: scrollbarThickness - - aCanvas - image: (BitBltCanvas arrowOfDirection: #down size: scrollbarThickness) - at: self downButtonPosition. -! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/10/2019 23:46:59'! - drawItemOf: index on: aCanvas width: width top: itemTop - - | rectangle entry | - - rectangle _ 1@itemTop extent: width@self itemHeight. - index = self selected ifTrue: [ aCanvas fillRectangle: rectangle color: (Theme current listHighlightFocused: true) ]. - - entry _ completer entries at: index. - aCanvas - drawString: entry asString - at: rectangle topLeft - font: self class listFont - color: (self colorOf: entry). - ! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/10/2019 23:51:54'! - drawItemsOn: aCanvas width: width - - | itemTop | - - itemTop _ 1. - self firstVisible - to: self lastVisible - do: [ :index | - self drawItemOf: index on: aCanvas width: width top: itemTop. - itemTop _ itemTop + self itemHeight ].! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/11/2019 00:03:34'! - drawScrollBarMovementBarOn: aCanvas thickness: scrollbarThickness - - | height top bottom | - - height _ extent y - (2 * scrollbarThickness). - top _ (1.0 * self firstVisible-1 / completer entryCount * height) ceiling + 1 + scrollbarThickness-1. - bottom _ (1.0 * self lastVisible / completer entryCount * height) floor + 1 + scrollbarThickness -1. - aCanvas - fillRectangle: (extent x - scrollbarThickness+2@top corner: extent x-2 @ bottom) - color: `Color veryLightGray` ! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/11/2019 00:02:04'! - drawScrollBarOn: aCanvas - - | scrollbarThickness width | - - width _ extent x-2. - completer entryCount > self class itemsPerPage ifTrue: [ - scrollbarThickness _ ScrollBar scrollbarThickness. - width _ width - scrollbarThickness. - - self drawScrollBarRectangleOn: aCanvas thickness: scrollbarThickness. - self drawUpArrowOn: aCanvas thickness: scrollbarThickness. - self drawDownArrowOn: aCanvas thickness: scrollbarThickness. - self drawScrollBarMovementBarOn: aCanvas thickness: scrollbarThickness ]. - - ^width -! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/10/2019 23:57:30'! - drawScrollBarRectangleOn: aCanvas thickness: scrollbarThickness - - aCanvas - frameRectangle: (extent x - scrollbarThickness@0 extent: scrollbarThickness @ extent y) - borderWidth: 1 - color: borderColor. -! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/10/2019 23:54:49'! - drawUpArrowOn: aCanvas thickness: scrollbarThickness - - aCanvas - image: (BitBltCanvas arrowOfDirection: #up size: scrollbarThickness) - at: self upButtonPosition. -! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/14/2019 18:26:25'! - setDefaultColors - - self color: self defaultColor. - self borderColor: self defaultBorderColor ! ! -!AutoCompleterMorph methodsFor: 'selector documentation' stamp: 'HAW 2/8/2019 17:15:51'! - crPressedOnSelectorDocumentation - - self hideSelectorDocumentation. - self activeHand newKeyboardFocus: completer textMorph ! ! -!AutoCompleterMorph methodsFor: 'selector documentation' stamp: 'HAW 2/8/2019 17:13:41'! - hideSelectorDocumentation - - selectorDocumentation ifNotNil: [ selectorDocumentation hide ]. - self stillActive ! ! -!AutoCompleterMorph methodsFor: 'selector documentation' stamp: 'HAW 2/8/2019 17:15:38'! - initializeSelectorDocumentation - - selectorDocumentation := TextModelMorph withText: ''. - selectorDocumentation textMorph - acceptOnCR: false; - crAction: [ self crPressedOnSelectorDocumentation ]. - - selectorDocumentation - wrapFlag: true; - borderColor: Color black; - borderWidth: 1; - disableEditing; - openInWorld - ! ! -!AutoCompleterMorph methodsFor: 'selector documentation' stamp: 'HAW 2/8/2019 17:14:01'! - isShowingSelectorDocumentation - - ^selectorDocumentation notNil and: [ selectorDocumentation visible ]! ! -!AutoCompleterMorph methodsFor: 'selector documentation' stamp: 'HAW 2/8/2019 17:40:55'! - methodDocumentationSeparator - - ^ Text - string: String newLineString, '------------------------------------------------------------------------------------------------', String newLineString - attribute: TextColor black.! ! -!AutoCompleterMorph methodsFor: 'selector documentation' stamp: 'HAW 2/11/2019 16:27:17'! - selectorDefaultDocumentationLocation - - | relativeSelected | - - relativeSelected := (self selected - self firstVisible) min: self class itemsPerPage - 1 max: 0. - - ^location externalizePosition: extent x@(relativeSelected * self itemHeight + 1). - - ! ! -!AutoCompleterMorph methodsFor: 'selector documentation' stamp: 'HAW 2/8/2019 17:12:11'! - selectorDocumentation - - selectorDocumentation ifNil: [ self initializeSelectorDocumentation ]. - ^selectorDocumentation ! ! -!AutoCompleterMorph methodsFor: 'selector documentation' stamp: 'HAW 2/11/2019 16:18:05'! - selectorDocumentationExtent - - ^`600@250`! ! -!AutoCompleterMorph methodsFor: 'selector documentation' stamp: 'HAW 2/8/2019 18:11:20'! - selectorDocumentationText - - | selectedEntry selectorsClasses | - - selectedEntry := completer selectedEntry. - (completer isCategoryEntry: selectedEntry) ifTrue: [ ^'' ]. - selectedEntry := selectedEntry asSymbol. - selectorsClasses := completer selectorsClasses. - - ^ selectorsClasses isEmpty - ifTrue: [ self selectorDocumentationTextForAllImplementorsOf: selectedEntry ] - ifFalse: [ self selectorDocumentationTextOf: selectedEntry forAll: selectorsClasses ]. - ! ! -!AutoCompleterMorph methodsFor: 'selector documentation' stamp: 'HAW 2/18/2019 18:31:56'! - selectorDocumentationTextForAllI: aMethodsCollection - - | selectorDocumentationText implementors methodDocumentationSeparator | - - selectorDocumentationText := Text new. - methodDocumentationSeparator := self methodDocumentationSeparator. - implementors := aMethodsCollection asSortedCollection: [ :leftMethod :rightMethod | leftMethod methodClass classDepth < rightMethod methodClass classDepth ]. - - implementors - do: [ :implementor | selectorDocumentationText := selectorDocumentationText append: (completer documentationOf: implementor)] - separatedBy: [ selectorDocumentationText := selectorDocumentationText append: methodDocumentationSeparator ]. - - ^ selectorDocumentationText! ! -!AutoCompleterMorph methodsFor: 'selector documentation' stamp: 'HAW 2/18/2019 18:16:04'! - selectorDocumentationTextForAllImplementorsOf: selectedEntry - - ^ self selectorDocumentationTextForAllI: (Smalltalk allImplementorsOf: selectedEntry). - - ! ! -!AutoCompleterMorph methodsFor: 'selector documentation' stamp: 'HAW 2/18/2019 18:25:34'! - selectorDocumentationTextOf: selectedEntry forAll: selectorsClasses - - | methodsToShow | - - methodsToShow := selectorsClasses - inject: IdentitySet new - into: [ :methods :aClass | - (aClass lookupSelector: selectedEntry) ifNotNil: [ :method | methods add: method ]. - methods ]. - - ^self selectorDocumentationTextForAllI: methodsToShow ! ! -!AutoCompleterMorph methodsFor: 'selector documentation' stamp: 'HAW 2/14/2019 18:27:16'! - showSelectorDocumentation - - | selectorDocumentationLocation selectorDocumentationExtent | - - selectorDocumentationLocation := self selectorDefaultDocumentationLocation. - selectorDocumentationExtent := self selectorDocumentationExtent. - selectorDocumentationLocation := self adjust: selectorDocumentationLocation ifOutOfScreenWith: selectorDocumentationExtent xOffset: extent x yOffset: self itemHeight negated. - - self setDefaultColors. - - self selectorDocumentation - model: (TextModel withText: self selectorDocumentationText); - morphPosition: selectorDocumentationLocation extent: selectorDocumentationExtent; - wrapFlag: false; - show. - - ! ! -!AutoCompleterMorph methodsFor: 'submorphs-add/remove' stamp: 'HAW 2/8/2019 17:11:23'! - delete - - selectorDocumentation ifNotNil: [ - selectorDocumentation delete. - selectorDocumentation := nil ]. - - ^super delete ! ! -!AutoCompleterMorph methodsFor: 'testing' stamp: 'HAW 2/11/2019 19:45:39'! - isXOutOfScreen: aLocation with: anExtent - - ^aLocation x + anExtent x > DisplayScreen actualScreenSize x! ! -!AutoCompleterMorph methodsFor: 'testing' stamp: 'HAW 2/11/2019 19:43:44'! - isYOutOfScreen: aLocation with: anExtent - - ^aLocation y + anExtent y > DisplayScreen actualScreenSize y! ! -!InnerTextMorph methodsFor: 'accessing' stamp: 'HAW 1/21/2019 00:53:00'! - crAction: aBlock - "Sets the action to perform when user presses key" - ^self setProperty: #crAction toValue: aBlock ! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 12:21:43'! - computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 12:21:54'! - computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 12:22:00'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 12:22:05'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'HAW 1/19/2019 07:07:02'! - isArrowLeft - - ^keyValue = 28! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'HAW 1/18/2019 19:48:13'! - isArrowRight - - ^keyValue = 29 ! ! -!MethodReference methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 18:28:00'! - dynamicTypingAutoCompleterDocumentation - - ^self compiledMethod dynamicTypingAutoCompleterDocumentation ! ! -!MethodReference methodsFor: 'auto complete' stamp: 'HAW 2/18/2019 18:31:40'! - methodClass - - ^self actualClass ! ! -!AutoCompleter methodsFor: 'accessing' stamp: 'HAW 1/21/2019 01:02:40'! - textMorph - - ^textMorph! ! -!AutoCompleter methodsFor: 'entries' stamp: 'HAW 1/19/2019 23:55:50' prior: 16781300! - selectedEntry - - ^self entries at: menuMorph selected! ! -!AutoCompleter methodsFor: 'entries' stamp: 'HAW 2/6/2019 16:22:43'! - selectedEntryFormatted - - ^(self entries at: menuMorph selected), ' '! ! -!AutoCompleter methodsFor: 'testing' stamp: 'HAW 2/8/2019 17:23:31'! - canSelect: anEntry - - ^true! ! -!AutoCompleter methodsFor: 'testing' stamp: 'HAW 2/10/2019 21:35:19'! - isPossibleInvalidEntry: anEntry - - ^false! ! -!SmalltalkCompleter methodsFor: 'entries' stamp: 'HAW 1/19/2019 23:55:29'! - selectedEntryFormatted - - ^(self entries at: menuMorph selected) separateKeywords! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 2/8/2019 17:09:54'! - selectorsClasses - - ^selectorsClasses ! ! -!SmalltalkCompleter methodsFor: 'testing' stamp: 'HAW 2/8/2019 17:29:12'! - canSelect: anEntry - - ^ (self isCategoryEntry: anEntry) not! ! -!SmalltalkCompleter methodsFor: 'testing' stamp: 'HAW 2/8/2019 17:29:29'! - isCategoryEntry: anEntry - - ^anEntry beginsWith: AutoCompleterSelectorsCollector categoryEntryHeader! ! -!SmalltalkCompleter methodsFor: 'testing' stamp: 'HAW 2/10/2019 21:35:32'! - isPossibleInvalidEntry: anEntry - - ^possibleInvalidSelectors includes: anEntry ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 2/8/2019 16:07:20'! - computeEntriesOfUnaryMessageReturnNamed: aSelector at: aRange - - self subclassResponsibility ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 2/8/2019 17:09:54'! - computeMessageEntriesForClass: aClass - - selectorsClasses := Array with: aClass. - - entries := (AutoCompleterSelectorsCollector for: prefix) - addSelectorsOf: aClass; - entriesToShow! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 2/8/2019 12:43:44'! - computeMessageEntriesForClassOrNil: aClassOrNil - - aClassOrNil - ifNil: [ self computeMessageEntriesForUnknowClass ] - ifNotNil: [ self computeMessageEntriesForClass: aClassOrNil ]. - -! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 2/8/2019 16:10:27'! - computeMessageEntriesOfCascadeReceiverAt: aRange - - self subclassResponsibility ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 2/11/2019 00:21:12'! - computeMessageEntriesOfEnclosedExpressionReturnAt: aRange - - self subclassResponsibility ! ! -!SmalltalkCompleter methodsFor: 'message entries for unknown class - private' stamp: 'HAW 2/15/2019 15:40:47'! - computeMessageEntriesForUnknowClass - - | selectorsToShow | - - selectorsClasses _ #(). - possibleInvalidSelectors _ IdentitySet new. - selectorsToShow _ OrderedCollection new. - - self class protected: [ - Selectors forPrefix: prefix keysAndValuesDo: [ :selector :lastUsedTime | - selectorsToShow := self add: selector and: lastUsedTime to: selectorsToShow. - (Object canUnderstand: selector) ifFalse: [ possibleInvalidSelectors add: selector ]]]. - - selectorsToShow size < EntriesLimit ifTrue: [ selectorsToShow _ self sortByLastUsedTime: selectorsToShow ]. - - " To see the timestamps in the menu (need to tweak #insertCompletion: to activate. Right now, just for debugging) - entries _ selectorsToShow collect: [ :ary | ary first, '(', ((DateAndTime fromString: '01/01/1996 00:00') + ary second minutes) printString,')' ] - " - entries _ selectorsToShow collect: [ :selectorAndTime | selectorAndTime first ] - -! ! -!SmalltalkCompleter methodsFor: 'selector documentation' stamp: 'HAW 2/8/2019 18:12:00'! - documentationOf: aMethod - - self subclassResponsibility ! ! -!SmalltalkCompleter class methodsFor: 'instance creation' stamp: 'HAW 2/10/2019 17:44:10'! - withModel: aStringHolder - - "Looks it its subclasses the right autocompleter depending on the Type System. If you do not have - Live Typing installed you will see only one subclass but if Live Typing is intalled LiveTypeingSmalltalkCompleter - subclass is added - Hernan" - - | smalltalkCompleterClass | - - smalltalkCompleterClass := self subclasses detect: [ :aSubclass | aSubclass isForCurrentTypeSystem ]. - - ^smalltalkCompleterClass new setModel: aStringHolder! ! -!SmalltalkCompleter class methodsFor: 'testing' stamp: 'HAW 2/8/2019 15:57:29'! -isForCurrentTypeSystem - - self subclassResponsibility ! ! -!SmalltalkCompleter class methodsFor: 'accessing' stamp: 'HAW 2/15/2019 15:27:22'! - entriesLimit - - ^EntriesLimit ! ! -!DynamicTypingSmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 2/8/2019 16:09:35'! - computeEntriesOfUnaryMessageReturnNamed: aSelector at: aRange - - self computeMessageEntriesForUnknowClass - ! ! -!DynamicTypingSmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 2/8/2019 16:10:08'! - computeMessageEntriesOfCascadeReceiverAt: aRange - - self computeMessageEntriesForUnknowClass - -! ! -!DynamicTypingSmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 2/11/2019 00:21:13'! - computeMessageEntriesOfEnclosedExpressionReturnAt: aRange - - self computeMessageEntriesForUnknowClass - -! ! -!DynamicTypingSmalltalkCompleter methodsFor: 'selector documentation' stamp: 'HAW 2/8/2019 18:13:08'! - documentationOf: aMethod - - ^aMethod dynamicTypingAutoCompleterDocumentation! ! -!DynamicTypingSmalltalkCompleter class methodsFor: 'testing' stamp: 'HAW 2/8/2019 18:35:09'! - isForCurrentTypeSystem - - ^ Smalltalk isLiveTypingInstalled not! ! -!AutoCompleterSelectorsCollector methodsFor: 'initialization' stamp: 'HAW 2/15/2019 15:32:49'! - initializeFor: aPrefix withSelectorsLimitedTo: aLimit - - prefix := aPrefix. - categoriesWithSelectors := OrderedDictionary new. - addedSelectorsFastSet := IdentitySet new. - possibleInvalidSelectors := IdentitySet new. - selectorsLimit := aLimit ! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting' stamp: 'HAW 2/15/2019 15:03:00'! - addSelectorsOf: aClass - - self addSelectorsOf: aClass upTo: nil! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting' stamp: 'HAW 2/15/2019 15:04:08'! - addSelectorsOf: aClass upTo: aSuperclassToExclude - - self addSelectorsOfAll: (Array with: aClass) upTo: aSuperclassToExclude ! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting' stamp: 'HAW 2/15/2019 15:04:18'! - addSelectorsOfAll: classes upTo: aSuperclass - - classes do: [ :aClass | - otherClasses := classes copyWithout: aClass. - self addSelectorsMarkingPossibleInvalidOnesOf: aClass upTo: aSuperclass ]! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting' stamp: 'HAW 2/10/2019 21:54:59'! - addedSelectors: selectors - - addedSelectorsFastSet addAll: selectors ! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting' stamp: 'HAW 2/10/2019 21:32:17'! - possibleInvalidSelectors - - ^possibleInvalidSelectors! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting - private' stamp: 'HAW 2/15/2019 15:34:27'! - addCategoriesAndSelectorsOf: aClass - - | classOrganization | - - classOrganization := aClass organization. - - classOrganization categories do: [ :aCategory | | categorySelectors selectedSelectors | - self hasReachSelectorsLimit ifTrue: [ ^ self ]. - selectedSelectors := self prefixedSelectorsOf: aCategory in: classOrganization. - selectedSelectors isEmpty ifFalse: [ - categorySelectors := categoriesWithSelectors at: aCategory ifAbsentPut: [ OrderedCollection new ]. - categorySelectors addAll: selectedSelectors. - self addedSelectors: selectedSelectors. - self addToPossibleInvalidIfCorrespond: selectedSelectors ]]! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting - private' stamp: 'HAW 2/15/2019 15:35:41'! - addSelectorsMarkingPossibleInvalidOnesOf: aClass upTo: aSuperclassToExclude - - | currentClass | - - currentClass := aClass. - - [ currentClass ~= aSuperclassToExclude and: [ currentClass notNil ] and: [ self hasReachSelectorsLimit not ] ] whileTrue: [ - self addCategoriesAndSelectorsOf: currentClass. - currentClass := currentClass superclass]. - -! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting - private' stamp: 'HAW 2/15/2019 15:19:35'! - addToPossibleInvalidIfCorrespond: selectedSelectors - - selectedSelectors do: [ :aSelector | - (otherClasses allSatisfy: [ :otherClass | otherClass canUnderstand: aSelector ]) ifFalse: [ possibleInvalidSelectors add: aSelector ]]! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting - private' stamp: 'HAW 2/7/2019 18:40:03'! - prefixedSelectorsOf: aCategory in: aClassOrganization - - ^ (aClassOrganization listAtCategoryNamed: aCategory) - select: [ :aSelector | (aSelector beginsWith: prefix) and: [ (addedSelectorsFastSet includes: aSelector) not ] ]. -! ! -!AutoCompleterSelectorsCollector methodsFor: 'entries to show' stamp: 'HAW 2/8/2019 16:25:25'! - entriesToShow - - self hasCollectedOnlyOneSelector - ifTrue: [ entriesToShow := categoriesWithSelectors anyOne ] - ifFalse: [ - entriesToShow := OrderedCollection new. - self - addPrioritizedCategories; - addLeftCategories ]. - - ^entriesToShow - - ! ! -!AutoCompleterSelectorsCollector methodsFor: 'entries to show - private' stamp: 'HAW 2/18/2019 18:26:36'! - addCategory: aCategory with: selectors - - entriesToShow - add: (self categoryEntryFor: aCategory); - addAll: selectors - ! ! -!AutoCompleterSelectorsCollector methodsFor: 'entries to show - private' stamp: 'HAW 2/7/2019 18:26:18'! - addLeftCategories - - categoriesWithSelectors keysAndValuesDo: [ :aCategory :selectors | self addCategory: aCategory with: selectors ]. - ! ! -!AutoCompleterSelectorsCollector methodsFor: 'entries to show - private' stamp: 'HAW 2/7/2019 18:27:10'! - addPrioritizedCategories - - self prioritizedCategories do: [ :aCategory | self addPrioritizedCategory: aCategory ]! ! -!AutoCompleterSelectorsCollector methodsFor: 'entries to show - private' stamp: 'HAW 2/7/2019 18:27:10'! - addPrioritizedCategory: aCategory - - categoriesWithSelectors - at: aCategory - ifPresent: [ :selectors | - self addCategory: aCategory with: selectors. - categoriesWithSelectors removeKey: aCategory ]. -! ! -!AutoCompleterSelectorsCollector methodsFor: 'entries to show - private' stamp: 'HAW 2/8/2019 17:24:26'! - categoryEntryFor: aCategory - - ^self class categoryEntryHeader, aCategory ! ! -!AutoCompleterSelectorsCollector methodsFor: 'entries to show - private' stamp: 'HAW 2/7/2019 18:19:23'! - prioritizedCategories - - ^#('instance creation')! ! -!AutoCompleterSelectorsCollector methodsFor: 'testing' stamp: 'HAW 2/8/2019 16:26:00'! - hasCollectedOnlyOneSelector - - ^ categoriesWithSelectors size = 1 and: [ categoriesWithSelectors anyOne size = 1 ]! ! -!AutoCompleterSelectorsCollector methodsFor: 'testing' stamp: 'HAW 2/15/2019 15:34:27'! - hasReachSelectorsLimit - - ^addedSelectorsFastSet size >= selectorsLimit! ! -!AutoCompleterSelectorsCollector class methodsFor: 'instance creation' stamp: 'HAW 2/15/2019 15:33:47'! - for: aPrefix - - ^self for: aPrefix withSelectorsLimitedTo: SmalltalkCompleter entriesLimit! ! -!AutoCompleterSelectorsCollector class methodsFor: 'instance creation' stamp: 'HAW 2/15/2019 15:33:36'! - for: aPrefix withSelectorsLimitedTo: aLimit - - ^self new initializeFor: aPrefix withSelectorsLimitedTo: aLimit! ! -!AutoCompleterSelectorsCollector class methodsFor: 'category entry' stamp: 'HAW 2/8/2019 17:24:43'! - categoryEntryHeader - - ^ '-- '! ! -!SHParserST80 methodsFor: 'accessing' stamp: 'HAW 2/10/2019 18:35:50'! - allSource - - ^allSource! ! -!SHParserST80 methodsFor: 'accessing' stamp: 'HAW 2/10/2019 18:36:28'! - allSource: aSourceCode - - allSource _ aSourceCode! ! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 1/20/2019 18:47:22' prior: 50417096! - classOfThisContext - - ^ MethodContext ! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 1/20/2019 18:47:47' prior: 50417167! - classOfThisContext - - ^ MethodContext ! ! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'HAW 2/19/2019 14:09:50'! - with: otherCollection do: twoArgBlock separatedBy: separatorBlock - - | beforeFirst | - - beforeFirst := true. - self with: otherCollection do: [ :selfElement :otherCollectionElement | - beforeFirst - ifTrue: [beforeFirst := false] - ifFalse: [separatorBlock value]. - twoArgBlock value: selfElement value: otherCollectionElement ]. - - -! ! -!AutoCompleterMorph methodsFor: 'accessing' stamp: 'HAW 1/19/2019 09:05:56' prior: 16781381! - selected - "Answer the value of selected" - selected ifNil: [ self selected: self firstVisible ]. - ^ selected! ! -!AutoCompleterMorph methodsFor: 'accessing' stamp: 'HAW 2/8/2019 17:14:24' prior: 16781387! - selected: aNumber - - "Set the value of selected" - - ((aNumber between: 1 and: completer entryCount) and: [ aNumber ~= selected ]) - ifTrue: [ - selected _ aNumber. - self isShowingSelectorDocumentation ifTrue: [ self showSelectorDocumentation ]]! ! -!AutoCompleterMorph methodsFor: 'activity tracking' stamp: 'HAW 2/14/2019 18:26:11' prior: 50432304! -updateColor - - | remaining alpha | - - remaining := (self timeout - self timeOfLastActivity). - remaining < 1000 - ifTrue: [ - alpha _ remaining / 1000.0. - self color: (self color alpha: alpha). - self borderColor: (borderColor alpha: alpha) ] - ifFalse: [ self setDefaultColors ] - - ! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/10/2019 23:52:19' prior: 50385043! - downButtonPosition - - ^ `0@0` + (extent - ScrollBar scrollbarThickness)! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/10/2019 23:39:30' prior: 50388251! - drawOn: aCanvas - - | width | - - self drawContainingRectangle: aCanvas. - width _ self drawScrollBarOn: aCanvas. - self drawItemsOn: aCanvas width: width -! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/10/2019 23:52:14' prior: 16781539! - upButtonPosition - - ^extent x - ScrollBar scrollbarThickness@0! ! -!AutoCompleterMorph methodsFor: 'events' stamp: 'HAW 1/19/2019 06:12:38' prior: 50366914! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - (self morphContainsPoint: localEventPosition) - ifTrue: [ - ((self upButtonPosition extent: ScrollBar scrollbarThickness) containsPoint: localEventPosition) - ifTrue: [ ^self stillActive; goUp ]. - ((self downButtonPosition extent: ScrollBar scrollbarThickness) containsPoint: localEventPosition) - ifTrue: [ ^self stillActive; goDown ]. - self selected: (localEventPosition y // self itemHeight) + self firstVisible. - completer insertSelected ] - ifFalse: [ self delete. completer menuClosed ]! ! -!AutoCompleterMorph methodsFor: 'initialization' stamp: 'HAW 2/12/2019 18:22:48' prior: 16781585! - setCompleter: anAutoCompleter position: aPoint - - completer _ anAutoCompleter. - - originalPosition := aPoint. - - self resetMenu. - self openInWorld! ! -!AutoCompleterMorph methodsFor: 'stepping' stamp: 'HAW 2/8/2019 17:14:01' prior: 16781617! - stepAt: millisecondSinceLast - - self isShowingSelectorDocumentation ifTrue: [ ^self ]. - - self timeOfLastActivity > self timeout - ifTrue: [ self delete. completer menuClosed ] - ifFalse: [self updateColor]! ! -!AutoCompleterMorph class methodsFor: 'instance creation' stamp: 'HAW 2/12/2019 17:56:00' prior: 16781678! - completer: anAutoCompleter position: aPoint - - | newObject | - - newObject _ self new. - newObject setCompleter: anAutoCompleter position: aPoint. - - ^ newObject! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 2/6/2019 20:30:26' prior: 50417230! - classOfThisContext - - ^ MethodContext! ! -!AutoCompleter methodsFor: 'menu morph' stamp: 'HAW 2/16/2019 08:33:04' prior: 16781134! - openCompletionMenu - - | theEditor | - - theEditor _ textMorph editor. - position _ theEditor startIndex - 1. - self closeMenu. - self computeEntries. - entries notEmpty - ifTrue: [ | startIndex characterBlock cursorIndex | - cursorIndex := theEditor pointIndex. - startIndex := (theEditor text at: cursorIndex-1) = Character space - ifTrue: [ cursorIndex ] - ifFalse: [ theEditor previousWordStart: (cursorIndex > theEditor text size ifTrue: [ cursorIndex-1 ] ifFalse: [ cursorIndex ])]. - characterBlock := theEditor characterBlockForIndex: startIndex. - menuMorph _ AutoCompleterMorph - completer: self - position: characterBlock bottomLeft + textMorph morphPositionInWorld ]. -! ! -!AutoCompleter methodsFor: 'keyboard' stamp: 'HAW 2/12/2019 18:22:55' prior: 16781156! - handleKeystrokeAfter: aKeyboardEvent - | newPos | - menuMorph ifNil: [^self]. - newPos _ textMorph editor startIndex-1. - newPos = position ifTrue: [^self]. - newPos < position - ifTrue: [ - prefix _ prefix copyFrom: 1 to: prefix size+(newPos-position). - position _ newPos ] - ifFalse: [ - position _ position + 1. - prefix _ prefix copyWith: (model actualContents at: position) ]. - self computeEntries. - entries notEmpty - ifTrue: [ menuMorph resetMenu ] - ifFalse: [ self closeMenu ]! ! -!AutoCompleter methodsFor: 'keyboard' stamp: 'HAW 2/8/2019 17:14:24' prior: 50415186! - handleKeystrokeBefore: kbEvent - - "I return a boolean. true when I have handled the event and no futher processing is needed by the caller." - - | shouldOpenMorph | - - shouldOpenMorph _ self shouldOpenMorph. - - "Stuff to do if the menu is not open" - menuMorph ifNil: [ ^ self openCompletionMenuFor: kbEvent if: shouldOpenMorph ]. - - "Starting here, stuff to do if the menu is open" - menuMorph stillActive. - - kbEvent isEsc ifTrue: [ self closeMenu. ^ true]. - kbEvent isBackspace ifTrue: [ shouldOpenMorph ifFalse: [ self closeMenu ]. ^ false]. - kbEvent isHome ifTrue: [ menuMorph goHome. ^ true ]. - kbEvent isEnd ifTrue: [ menuMorph goToEnd. ^ true]. - kbEvent isQuesitonMark ifTrue: [ menuMorph help. ^true]. - kbEvent isArrowUp ifTrue: [ menuMorph goUp. ^ true]. - kbEvent isArrowDown ifTrue: [ menuMorph goDown. ^ true]. - kbEvent isPageUp ifTrue: [ menuMorph goPageUp. ^ true]. - kbEvent isPageDown ifTrue: [ menuMorph goPageDown. ^ true]. - kbEvent isArrowRight ifTrue: [ menuMorph showSelectorDocumentation. ^ true ]. - kbEvent isArrowLeft ifTrue: [ menuMorph hideSelectorDocumentation. ^ true ]. - (self shouldInsertSelected: kbEvent) ifTrue: [ self insertSelected ifTrue: [^ true]]. - (self shouldCloseMenu: kbEvent) ifTrue: [ self closeMenu ]. - - ^false! ! -!AutoCompleter methodsFor: 'entries' stamp: 'HAW 2/8/2019 17:27:05' prior: 16781274! - insertSelected - - | entry editor selEnd str | - - textMorph ifNil: [ ^false ]. - - entry _ self selectedEntryFormatted. - (self canSelect: entry) ifFalse: [ ^true ]. - - editor _ textMorph editor. - str _ model actualContents string. - selEnd _ position. - [selEnd < str size and: [ (str at: selEnd+1) tokenish ]] whileTrue: [ selEnd _ selEnd + 1 ]. - (selEnd < str size and: [ (str at: selEnd+1) = $ ]) ifTrue: [ selEnd _ selEnd + 1]. - editor selectFrom: position-prefix size+1 to: selEnd. - editor - replaceSelectionWith: entry; - deselectAndPlaceCursorAt: position - prefix size + 1 + (self newCursorPosition: entry). - textMorph redrawNeeded. - menuMorph delete. - menuMorph _ nil. - - ^ true! ! -!SmalltalkCompleter methodsFor: 'entries' stamp: 'HAW 2/10/2019 21:38:01' prior: 50417254! - computeEntries - - | allSource contextClass specificModel last3Ranges range | - - allSource _ model actualContents string. - specificModel _ self textProviderOrModel. - contextClass _ self selectedClassOrMetaClassIn: specificModel. - last3Ranges _ self parse: allSource in: contextClass and: specificModel. - range _ last3Ranges third ifNil: [ ^entries _ #() ]. - possibleInvalidSelectors _ #(). - - range end = position - ifTrue: [ self computeEntriesOfMessageOrIdentifiersFor: allSource using: last3Ranges at: range in: contextClass and: specificModel ] - ifFalse: [ self computeMessageEntriesWithEmptyPrefixFor: allSource at: range in: contextClass and: specificModel ]. - - ! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 2/10/2019 18:35:24' prior: 50415434! - parse: allSource in: contextClass and: specificModel - - parser _ SHParserST80 new. - parser - workspace: ((specificModel is: #providesBindings) ifTrue: [specificModel]); - classOrMetaClass: contextClass; - source: (allSource copyFrom: 1 to: position); - allSource: allSource. - parser parse: (specificModel is: #CodeProvider). - - ^ parser last3Ranges. -! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 2/18/2019 18:13:38' prior: 50429712! - computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel - - | id rangeType | - - id _ allSource copyFrom: range start to: range end. - rangeType _ range rangeType. - - rangeType == #globalVar ifTrue: [ ^self computeMessageEntriesForClass: (Smalltalk at: id asSymbol) class ]. - rangeType == #self ifTrue: [ ^self computeMessageEntriesForClass: contextClass ]. - rangeType == #super ifTrue: [ ^self computeMessageEntriesForClass: contextClass superclass ]. - rangeType == #true ifTrue: [ ^self computeMessageEntriesForClass: True ]. - rangeType == #false ifTrue: [ ^self computeMessageEntriesForClass: False ]. - rangeType == #nil ifTrue: [ ^self computeMessageEntriesForClass: UndefinedObject ]. - rangeType == #character ifTrue: [ ^self computeMessageEntriesForClass: id first class ]. - rangeType == #number ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #string ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #symbol ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #stringSymbol ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #instVar ifTrue: [ ^specificModel computeMessageEntriesIn: self ofInstVarNamed: id ]. - rangeType == #methodArg ifTrue: [ ^specificModel computeMessageEntriesIn: self ofTempVarNamed: id ]. - rangeType == #tempVar ifTrue: [ ^specificModel computeMessageEntriesIn: self ofTempVarNamed: id ]. - rangeType == #blockArg ifTrue: [ ^specificModel computeMessageEntriesIn: self ofBlockArgNamed: id ]. - rangeType == #blockTempVar ifTrue: [ ^specificModel computeMessageEntriesIn: self ofBlockTempVarNamed: id ]. - rangeType == #workspaceVar ifTrue: [ ^self computeMessageEntriesForClassOrNil: (specificModel classOfWorkspaceVarNamed: id) ]. - rangeType == #thisContext ifTrue: [ ^self computeMessageEntriesForClass: (specificModel classOfThisContext) ]. - rangeType == #classVar ifTrue: [ ^self computeMessageEntriesForClassOrNil: (self classOfLocalBindingNamed: id in: contextClass) ]. - rangeType == #poolConstant ifTrue: [ ^self computeMessageEntriesForClassOrNil: (self classOfLocalBindingNamed: id in: contextClass) ]. - rangeType == #blockEnd ifTrue: [ ^self computeMessageEntriesForClass: BlockClosure ]. - rangeType == #arrayEnd ifTrue: [ ^self computeMessageEntriesForClass: Array ]. - rangeType == #rightBrace ifTrue: [ ^self computeMessageEntriesForClass: Array ]. - rangeType == #unary ifTrue: [ ^self computeEntriesOfUnaryMessageReturnNamed: id at: range ]. - rangeType == #rightParenthesis ifTrue: [ ^self computeMessageEntriesOfEnclosedExpressionReturnAt: range ]. - rangeType == #cascadeSeparator ifTrue: [ ^self computeMessageEntriesOfCascadeReceiverAt: range ]. - - self computeMessageEntriesForUnknowClass - - ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 2/8/2019 12:18:59' prior: 50415022! - computeMessageEntriesWhenSendinMessageFor: allSource using: last3Ranges in: contextClass and: specificModel - - | prevPrevRange prevRange | - - "If previous range is a constant or a well known identifier, we might filter messages" - prevRange _ last3Ranges second. - prevPrevRange _ last3Ranges first. - - "3 if -> ifNil: but not ifTrue: - 3=4 -> ifNil: or ifTrue:" - ^ (self canComputeMessageEntriesFor: prevRange and: prevPrevRange) - ifTrue: [ self computeMessageEntriesFor: allSource at: prevRange in: contextClass and: specificModel ] - ifFalse: [ self computeMessageEntriesForUnknowClass ] -! ! -!SmalltalkCompleter class methodsFor: 'class initialization' stamp: 'HAW 2/15/2019 15:36:56' prior: 50424411! - initialize - " - It takes about 6 seconds, mostly because of the time to fetch method stamps from source files... - [ SmalltalkCompleter initialize ]timeToRun - Selectors inspect - " - | maxSortValue allImplemented | - - EntriesLimit _ 100. - - SystemChangeNotifier uniqueInstance - removeActionsWithReceiver: self. "avoid double registration" - - SystemChangeNotifier uniqueInstance - when: #classRemoved send: #classRemoved:fromCategory: to: self; - when: #methodAdded send: #methodAdded:selector:inClass:requestor: to: self; - when: #methodAddedInProtocol send: #methodAdded:selector:inProtocol:class:requestor: to: self; - when: #methodRemoved send: #methodRemoved:selector:inProtocol:class: to: self. - - self protected: [ - allImplemented _ Smalltalk allImplementedMessages. - Selectors _ Trie new. - " - Smalltalk allBehaviorsDo: [:class | - class selectorsAndMethodsDo: [ :sel :method | - Selectors at: sel ifAbsentPut: [ 0 ]. - method messages do: [ :sentMsg | - Selectors at: sentMsg put: (Selectors at: sentMsg ifAbsent: [ 0 ]) + 1 ]]]. - " - Smalltalk allBehaviorsDo: [:class | - class selectorsAndMethodsDo: [ :sel :method | - self addSelector: sel method: method allImplemented: allImplemented]]. - "" - - "The following might not be found in #messages. Give them maximum priority." - maxSortValue _ SmallInteger maxVal. - "From MessageNode>>#initialize" - #( ifTrue: ifFalse: ifTrue:ifFalse: ifFalse:ifTrue: - and: or: - whileFalse: whileTrue: whileFalse whileTrue - to:do: to:by:do: - caseOf: caseOf:otherwise: - ifNil: ifNotNil: ifNil:ifNotNil: ifNotNil:ifNil:) do: [ :sel | - Selectors at: sel put: maxSortValue ]. - - maxSortValue _ SmallInteger maxVal-1. - "From SystemDictionary >>#recreateSpecialObjectsArray" - (1 to: Smalltalk specialSelectorSize) do: [ :i | - Selectors at: (Smalltalk specialSelectorAt: i) put: maxSortValue ]]! ! - -AutoCompleterSelectorsCollector class removeSelector: #for:limitingNumberOfSelectorsTo:! - -AutoCompleterSelectorsCollector class removeSelector: #for:withALimitOf:! - -AutoCompleterSelectorsCollector removeSelector: #addEntriesToShowTo:! - -AutoCompleterSelectorsCollector removeSelector: #addPrioritzedCategory:! - -AutoCompleterSelectorsCollector removeSelector: #addPrioritzedCategory:with:! - -AutoCompleterSelectorsCollector removeSelector: #hasReachNumberOfSelectorsLimit! - -AutoCompleterSelectorsCollector removeSelector: #initialize! - -AutoCompleterSelectorsCollector removeSelector: #initializeFor:! - -AutoCompleterSelectorsCollector removeSelector: #initializeFor:limitingNumberOfSelectorsTo:! - -AutoCompleterSelectorsCollector removeSelector: #markAddedSelectorsAsPossibleInvalid! - -AutoCompleterSelectorsCollector removeSelector: #priorizeCategories! - -DynamicTypingSmalltalkCompleter removeSelector: #computeMessageEntriesOfOfEnclosedExpressionReturnAt:! - -SmalltalkCompleter removeSelector: #computeMessageEntries:! - -SmalltalkCompleter removeSelector: #computeMessageEntries:! - -SmalltalkCompleter removeSelector: #computeMessageEntriesForSelectors:! - -SmalltalkCompleter removeSelector: #computeMessageEntriesForSelectors:! - -SmalltalkCompleter removeSelector: #returnTypeOfEnclosedExpressionAt:! - -SmalltalkCompleter removeSelector: #returnTypeOfEnclosedExpressionAt:! - -SmalltalkCompleter removeSelector: #returnTypeOfUnaryMessage:at:! - -SmalltalkCompleter removeSelector: #returnTypeOfUnaryMessage:at:! - -SmalltalkCompleter removeSelector: #selectedEntry! - -SmalltalkCompleter removeSelector: #selectedEntry! - -SmalltalkCompleter removeSelector: #typeOfCascadeReceiverAt:! - -SmalltalkCompleter removeSelector: #typeOfCascadeReceiverAt:! - -SmalltalkCompleter removeSelectorIfInBaseSystem: #withMethodNodeOf:do:ifError:! - -SmalltalkCompleter removeSelector: #withMethodNodeOf:do:ifError:! - -SmalltalkCompleter removeSelectorIfInBaseSystem: #withMethodNodeOfAllSourceCodeDo:ifError:! - -SmalltalkCompleter removeSelector: #withMethodNodeOfAllSourceCodeDo:ifError:! - -AutoCompleter removeSelector: #keyStroke:! - -ClassNameRequestMorph removeSelector: #classOfBlockArgNamed:! - -ClassNameRequestMorph removeSelector: #classOfBlockArgNamed:! - -ClassNameRequestMorph removeSelector: #classOfBlockTempVarNamed:! - -ClassNameRequestMorph removeSelector: #classOfBlockTempVarNamed:! - -ClassNameRequestMorph removeSelector: #classOfInstVarNamed:! - -ClassNameRequestMorph removeSelector: #classOfInstVarNamed:! - -ClassNameRequestMorph removeSelector: #classOfTempVarNamed:! - -ClassNameRequestMorph removeSelector: #classOfTempVarNamed:! - -AutoCompleterMorph removeSelector: #adjust:ifOutOfScreenWith:! - -AutoCompleterMorph removeSelector: #adjust:ifOutOfScreenWith:xOffset:! - -AutoCompleterMorph removeSelector: #adjustPositionIfOutOfScreen! - -AutoCompleterMorph removeSelector: #adjustPositionIfOutOfScreen:! - -AutoCompleterMorph removeSelector: #adjustedIfOutOfScreen:! - -AutoCompleterMorph removeSelector: #drawItemOn:width:! - -AutoCompleterMorph removeSelector: #isOutOfScreen:with:! - -AutoCompleterMorph removeSelector: #privateExtent:! - -AutoCompleterMorph removeSelector: #resetMenu:! - -AutoCompleterMorph removeSelector: #selectorDocumentationLocation! - -AutoCompleterMorph removeSelector: #testxxx! - -AutoCompleterMorph removeSelector: #testxxxxx! - -Inspector removeSelector: #classOfInstVarNamed:! - -Inspector removeSelector: #classOfInstVarNamed:! - -Debugger removeSelector: #classOfBlockArgNamed:! - -Debugger removeSelector: #classOfBlockArgNamed:! - -Debugger removeSelector: #classOfBlockTempVarNamed:! - -Debugger removeSelector: #classOfBlockTempVarNamed:! - -Debugger removeSelector: #classOfInstVarNamed:! - -Debugger removeSelector: #classOfInstVarNamed:! - -Debugger removeSelector: #classOfTempVarNamed:! - -Debugger removeSelector: #classOfTempVarNamed:! - -TextProvider removeSelector: #classOfBlockArgNamed:! - -TextProvider removeSelector: #classOfBlockArgNamed:! - -TextProvider removeSelector: #classOfBlockTempVarNamed:! - -TextProvider removeSelector: #classOfBlockTempVarNamed:! - -TextProvider removeSelector: #classOfInstVarNamed:! - -TextProvider removeSelector: #classOfInstVarNamed:! - -TextProvider removeSelector: #classOfTempVarNamed:! - -TextProvider removeSelector: #classOfTempVarNamed:! - -Workspace removeSelector: #classOfTempVarNamed:! - -Workspace removeSelector: #classOfTempVarNamed:! - -PluggableTextModel removeSelector: #classOfBlockArgNamed:! - -PluggableTextModel removeSelector: #classOfBlockArgNamed:! - -PluggableTextModel removeSelector: #classOfBlockTempVarNamed:! - -PluggableTextModel removeSelector: #classOfBlockTempVarNamed:! - -PluggableTextModel removeSelector: #classOfInstVarNamed:! - -PluggableTextModel removeSelector: #classOfInstVarNamed:! - -PluggableTextModel removeSelector: #classOfTempVarNamed:! - -PluggableTextModel removeSelector: #classOfTempVarNamed:! - -TextModel removeSelector: #classOfBlockArgNamed:! - -TextModel removeSelector: #classOfBlockArgNamed:! - -TextModel removeSelector: #classOfBlockTempVarNamed:! - -TextModel removeSelector: #classOfBlockTempVarNamed:! - -TextModel removeSelector: #classOfInstVarNamed:! - -TextModel removeSelector: #classOfInstVarNamed:! - -TextModel removeSelector: #classOfTempVarNamed:! - -TextModel removeSelector: #classOfTempVarNamed:! - -BorderedRectMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity selectorDocumentation originalPosition showUp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #AutoCompleterMorph category: #'Tools-Autocompletion'! -BorderedRectMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity selectorDocumentation originalPosition showUp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser selectorsClasses possibleInvalidSelectors' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #SmalltalkCompleter category: #'Tools-Autocompletion'! -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser selectorsClasses possibleInvalidSelectors' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -SmalltalkCompleter initialize! - -Object subclass: #SHParserST80 - instanceVariableNames: 'classOrMetaClass source workspace arguments sourcePosition currentToken currentTokenFirst temporaries instanceVariables errorBlock currentTokenSourcePosition blockDepth bracketDepth ranges blockDepths blockDepthsStartIndexes allSource' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -!classDefinition: #SHParserST80 category: #'Tools-Syntax Highlighting'! -Object subclass: #SHParserST80 - instanceVariableNames: 'classOrMetaClass source workspace arguments sourcePosition currentToken currentTokenFirst temporaries instanceVariables errorBlock currentTokenSourcePosition blockDepth bracketDepth ranges blockDepths blockDepthsStartIndexes allSource' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3616-AutoCompleterBigRefactor-HernanWilkinson-2019Jan18-00h58m-HAW.4.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3590] on 19 February 2019 at 2:19:45 pm'! -!MethodNode methodsFor: 'accessing' stamp: 'HAW 2/19/2019 14:19:05'! - argumentNames - - ^arguments collect: [ :anArgumentNode | anArgumentNode name ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3617-MethodNode-argumentNames-HernanWilkinson-2019Feb19-14h11m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3612] on 19 February 2019 at 12:26:57 pm'! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'jmv 2/19/2019 12:26:00' prior: 50432874! - computeIdentifierEntries - "Use an aux Set to avoid duplicates, but keep the order given." - | entriesSet lastTitle | - - entriesSet _ Set new. - lastTitle _ nil. - entries _ Array streamContents: [ :strm | - parser namesBeginningWith: prefix do: [ :identifier :kindOfIdentifierTitle | - (entriesSet includes: identifier) ifFalse: [ - kindOfIdentifierTitle = lastTitle ifFalse: [ - strm nextPut: kindOfIdentifierTitle. - lastTitle _ kindOfIdentifierTitle ]. - entriesSet add: identifier. - strm nextPut: identifier ]]]! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:09:28' prior: 50432894! - isBlockArgName: aString - "Answer true if aString is the name of a block argument, false otherwise" - - self blockArgNamesDo: [ :arg :dummy | arg = aString ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:09:18' prior: 50432903! - isBlockTempName: aString - "Answer true if aString is the name of a block temporary. false otherwise" - - self blockTempNamesDo: [ :arg :dummy | arg = aString ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:09:31' prior: 50432912! - isIncompleteBlockArgName: aString - "Answer true if aString is the start of the name of a block argument, false otherwise" - - self blockArgNamesDo: [ :arg :dummy | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:09:21' prior: 50432922! - isIncompleteBlockTempName: aString - "Answer true if aString is the start of the name of a block temporary. false otherwise" - - self blockTempNamesDo: [ :arg :dummy | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:09:05' prior: 50432932! - isIncompleteClassVarName: aString - "Answer true if aString is the start of the name of a class variable, false otherwise" - - self classVarNamesDo: [ :arg :dummy | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:08:54' prior: 50432942! - isIncompleteInstVarName: aString - "Answer true if aString is the start of the name of an instance variable, false otherwise" - - self instVarNamesDo: [ :arg :dummy | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:08:42' prior: 50432952! - isIncompleteMethodArgName: aString - "Answer true if aString is the start of the name of a method argument, false otherwise. - Does not check whether aString is also a blockArgName" - - self methodArgNamesDo: [ :arg :dummy | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:08:34' prior: 50432964! - isIncompleteMethodTempName: aString - "Answer true if aString is the start of the name of a method temporary, false otherwise." - - self methodTempNamesDo: [ :arg :dummy | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:07:49' prior: 50432975! - isIncompletePoolConstantName: aString - "Answer true if aString is the start of the name of a pool constant, false otherwise" - - self poolConstantNamesDo: [ :arg :dummy | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:07:38' prior: 50432986! - isIncompleteWorkspaceVarName: aString - "Answer true if aString is the start of the name of an workspace variable, false otherwise" - - self workspaceNamesDo: [ :arg :dummy | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:08:58' prior: 50432997! - isInstVarName: aString - "Answer true if aString is the name of an instance variable, false otherwise" - - self instVarNamesDo: [ :arg :dummy | arg = aString ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:08:45' prior: 50433006! - isMethodArgName: aString - "Answer true if aString is the name of a method argument, false otherwise. - Does not check whether aString is also a blockArgName" - - self methodArgNamesDo: [ :arg :dummy | arg = aString ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:08:28' prior: 50433017! - isMethodTempName: aString - "Answer true if aString is the name of a method temporary, false otherwise. - Does not check whether aString is also a block temporary - or argument" - - self methodTempNamesDo: [ :arg :dummy | arg = aString ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:23:37' prior: 50433029! - blockArgNamesDo: aBlock - "Iterate over block argument names valid at current blockDepth" - - | title | - title _ '-- Block Arguments'. - blockDepth to: 1 by: -1 do: [ :level | - arguments at: level ifPresent: [ :args | args do: [ :name | aBlock value: name value: title ] ]]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:23:47' prior: 50433041! - blockTempNamesDo: aBlock - "Iterate over block temp names valid at current blockDepth" - - | title | - title _ '-- Block Variables'. - blockDepth to: 1 by: -1 do: [ :level | - temporaries at: level ifPresent: [ :args | args do: [ :name | aBlock value: name value: title ] ]]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:23:53' prior: 50433053! - classVarNamesDo: aBlock - - | title | - title _ '-- Class Variables'. - classOrMetaClass isBehavior - ifTrue: [ - classOrMetaClass theNonMetaClass withAllSuperclasses do: [ :c | - c classPool keysDo: [ :name | aBlock value: name value: title ] ]]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:24:00' prior: 50433065! - instVarNamesDo: aBlock - - | title | - title _ '-- Instance Variables'. - instanceVariables do: [ :name | aBlock value: name value: title ]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:24:05' prior: 50433073! - methodArgNamesDo: aBlock - "Iterate over method argument names" - - | title | - title _ '-- Method Arguments'. - ^arguments at: 0 ifPresent: [ :args | args do: [ :name | aBlock value: name value: title ] ]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:24:10' prior: 50433083! - methodTempNamesDo: aBlock - "Iterate over method temporary names" - - | title | - title _ '-- Method Variables'. - ^temporaries at: 0 ifPresent: [ :args | args do: [ :name | aBlock value: name value: title ] ]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:20:50' prior: 50433093! - namesBeginningWith: aString do: aBlock - "Evaluate aBlock for all available names that start with aString" - - self nonGlobalNamesDo: [ :name :kindOfIdentifierTitle | - (name beginsWith: aString) ifTrue: [ aBlock value: name value: kindOfIdentifierTitle ]]. - self namesBeginningWith: aString do: [ :name | aBlock value: name value: '-- Classes' ] in: Smalltalk classNames. - self namesBeginningWith: aString do: [ :name | aBlock value: name value: '-- Globals' ] in: Smalltalk nonClassNames! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:24:43' prior: 50433112! - nonGlobalNamesDo: aBlock - "Evaluate aBlock over all available names, except for globals" - - self - blockArgNamesDo: aBlock; - blockTempNamesDo: aBlock; - methodArgNamesDo: aBlock; - methodTempNamesDo: aBlock; - instVarNamesDo: aBlock; - classVarNamesDo: aBlock; - poolConstantNamesDo: aBlock; - workspaceNamesDo: aBlock. - self - reservedNames do: [ :name | - aBlock value: name value: '-- Pseudovariables' ]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:24:53' prior: 50433129! - poolConstantNamesDo: aBlock - - | title | - title _ '-- Pool Variables'. - classOrMetaClass isBehavior - ifTrue: [ - classOrMetaClass theNonMetaClass withAllSuperclasses do: [ :c | - c sharedPools do: [ :pool | - pool bindingsDo: [ :assoc | aBlock value: assoc key value: title ]]]]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:25:01' prior: 50433142! - workspaceNamesDo: aBlock - - | title | - title _ '-- Workspace Variables'. - workspace ifNotNil: [ - workspace bindingNamesDo: [ :name | aBlock value: name value: title ] ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3618-Autocompleter-GroupNamesByKind-JuanVuletich-2019Feb19-11h50m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3618] on 20 February 2019 at 6:32:54 pm'! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/20/2019 18:21:26'! - defaultFont11 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont11 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 11) - (setListFontTo: 11) - (setMenuFontTo: 12) - (setWindowTitleFontTo: 14) - (setCodeFontTo: 11) - (setButtonFontTo: 11)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/20/2019 18:21:31'! - defaultFont14 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont14 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 14) - (setListFontTo: 14) - (setMenuFontTo: 14) - (setWindowTitleFontTo: 17) - (setCodeFontTo: 14) - (setButtonFontTo: 14)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/20/2019 18:21:37'! - defaultFont17 - "Sets not only fonts but other GUI elements - to fit high resolution or large screens - Preferences defaultFont17 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 17) - (setListFontTo: 17) - (setMenuFontTo: 17) - (setWindowTitleFontTo: 22) - (setCodeFontTo: 17) - (setButtonFontTo: 17)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/20/2019 18:21:43'! - defaultFont22 - "Sets not only fonts but other GUI elements - to fit high resolution or large screens - Preferences defaultFont22 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 22) - (setListFontTo: 22) - (setMenuFontTo: 22) - (setWindowTitleFontTo: 28) - (setCodeFontTo: 22) - (setButtonFontTo: 22)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/20/2019 18:15:18'! - defaultFont28 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont28 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 28) - (setListFontTo: 28) - (setMenuFontTo: 28) - (setWindowTitleFontTo: 36) - (setCodeFontTo: 28) - (setButtonFontTo: 28)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/20/2019 18:16:03'! - defaultFont36 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont36 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 36) - (setListFontTo: 36) - (setMenuFontTo: 36) - (setWindowTitleFontTo: 46) - (setCodeFontTo: 36) - (setButtonFontTo: 36)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/20/2019 18:17:21'! - defaultFont46 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont46 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 46) - (setListFontTo: 46) - (setMenuFontTo: 46) - (setWindowTitleFontTo: 60) - (setCodeFontTo: 46) - (setButtonFontTo: 46)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/20/2019 18:17:47'! - defaultFont60 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont60 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 60) - (setListFontTo: 60) - (setMenuFontTo: 60) - (setWindowTitleFontTo: 80) - (setCodeFontTo: 60) - (setButtonFontTo: 60)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/20/2019 18:11:33'! - defaultFont8 - "Sets not only fonts but other GUI elements - to fit low resolution or small screens - Preferences defaultFont8 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 8) - (setListFontTo: 8) - (setMenuFontTo: 8) - (setWindowTitleFontTo: 11) - (setCodeFontTo: 8) - (setButtonFontTo: 8)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/20/2019 18:18:00'! - defaultFont80 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont80 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 80) - (setListFontTo: 80) - (setMenuFontTo: 80) - (setWindowTitleFontTo: 80) - (setCodeFontTo: 80) - (setButtonFontTo: 80)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/20/2019 18:20:55'! - defaultFont9 - "Sets not only fonts but other GUI elements - to fit low resolution or small screens - Preferences defaultFont9 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 9) - (setListFontTo: 9) - (setMenuFontTo: 10) - (setWindowTitleFontTo: 12) - (setCodeFontTo: 9) - (setButtonFontTo: 9)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/20/2019 18:12:32' prior: 50397737! - standardFonts - "Sets not only fonts but other GUI elements - to fit regular resolution and size screens - Preferences standardFonts - " - - self defaultFont9! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/20/2019 18:21:06' prior: 50397793! - verySmallFonts - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences verySmallFonts - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 8) - (setListFontTo: 7) - (setMenuFontTo: 7) - (setWindowTitleFontTo: 9) - (setCodeFontTo: 7) - (setButtonFontTo: 7)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!StrikeFont class methodsFor: 'instance creation' stamp: 'jmv 2/20/2019 18:03:06' prior: 50372567! - install: aString -" -StrikeFont install: 'DejaVu'. - -StrikeFont install: 'DejaVu Sans'. -StrikeFont buildLargerPunctuation: 'DejaVu Sans'. -Preferences setDefaultFontFamilyTo: 'DejaVu Sans'. -Preferences standardFonts. -Character initialize. -" -" -StrikeFont install: 'DejaVu Sans Mono'. -Preferences setDefaultFontFamilyTo: 'DejaVu Sans Mono'. -Preferences bigFonts. -Character initialize. -" -" -StrikeFont install: 'Inconsolata' -StrikeFont install: '#PilGi' -StrikeFont install: 'Optima' -StrikeFont install: 'Herculanum' -StrikeFont install: 'Papyrus' -StrikeFont install: 'Handwriting - Dakota' -StrikeFont install: 'Times New Roman' -StrikeFont install: 'Apple Chancery' -StrikeFont install: 'Cochin' -StrikeFont install: 'Cracked' -StrikeFont install: 'Zapfino' -StrikeFont install: 'Brush Script MT' -StrikeFont install: 'Chalkboard' -" - | fontDict | - fontDict _ AvailableFonts at: aString ifAbsentPut: Dictionary new. - #(5 6 7 8 9 10 11 12 14 17 22 28 36 48 60 80) do: [ :s | - (self create: aString size: s bold: true italic: true boldItalic: false) ifNotNil: [ :font | - fontDict - at: s - put: font ]]. - Preferences restoreDefaultFonts! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/6/2018 16:21:32' prior: 50397864! - preferencesMenu - "Build the preferences menu for the world." - - ^ (self menu: 'Preferences...') - addItemsFromDictionaries: `{ - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Font Sizes...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }`! ! -!Theme class methodsFor: 'user interface' stamp: 'jmv 2/20/2019 18:32:44' prior: 50397957! - changeFontSizes - | availableSizes menu | - availableSizes _ AbstractFont pointSizesFor: Preferences defaultFontFamily. - menu _ (MenuMorph new defaultTarget: Preferences) - addTitle: 'Choose a size'; - addStayUpIcons. - (availableSizes includes: 80) ifTrue: [ - menu add: 'Very High Resolution / Big Fonts (80pix)' action: #defaultFont80 ]. - (availableSizes includes: 80) ifTrue: [ - menu add: 'Very High Resolution / Big Fonts (60pix)' action: #defaultFont60 ]. - (availableSizes includes: 60) ifTrue: [ - menu add: 'Very High Resolution / Reg Fonts (46pix)' action: #defaultFont46 ]. - (availableSizes includes: 46) ifTrue: [ - menu add: 'Very High Resolution / Reg Fonts (36pix)' action: #defaultFont36 ]. - (availableSizes includes: 36) ifTrue: [ - menu add: 'High Resolution / Big Fonts (28pix)' action: #defaultFont28 ]. - (availableSizes includes: 28) ifTrue: [ - menu add: 'High Resolution / Big Fonts (22pix)' action: #defaultFont22 ]. - menu - add: 'High Resolution / Reg Fonts (17pix)' action: #defaultFont17; - add: 'High Resolution / Reg Fonts (14pix)' action: #defaultFont14; - add: 'Standard Resolution (11pix)' action: #defaultFont11; - add: 'Standard Resolution (9pix)' action: #defaultFont9; - add: 'Small Fonts (8pix)' action: #defaultFont8; - add: 'Very small Fonts'action: #verySmallFonts; - add: 'Tiny Fonts'action: #tinyFonts; - popUpInWorld: self runningWorld! ! - -Preferences class removeSelector: #bigFonts! - -Preferences class removeSelector: #bigFonts! - -Preferences class removeSelector: #hugeFonts! - -Preferences class removeSelector: #hugeFonts! - -Preferences class removeSelector: #smallFonts! - -Preferences class removeSelector: #smallFonts! - -Preferences class removeSelector: #veryBigFonts! - -Preferences class removeSelector: #veryBigFonts! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3619-BiggerFontSizes-JuanVuletich-2019Feb20-18h02m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3590] on 20 February 2019 at 6:18:18 pm'! -!Behavior methodsFor: 'auto complete' stamp: 'HAW 2/19/2019 17:53:31'! - typeName - - "If the class whishes to be shown in a different way in the selectors documentation. - For example, DenotativeObject does not show it self as a metaclass but as a class - Hernan" - - ^self name! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting - private' stamp: 'HAW 2/19/2019 15:44:12'! - addCategory: aCategory of: classOrganization - - | categorySelectors selectedSelectors | - - selectedSelectors := self prefixedSelectorsOf: aCategory in: classOrganization. - selectedSelectors isEmpty ifFalse: [ - categorySelectors := categoriesWithSelectors at: aCategory ifAbsentPut: [ OrderedCollection new ]. - categorySelectors addAll: selectedSelectors. - self addedSelectors: selectedSelectors. - self addToPossibleInvalidIfCorrespond: selectedSelectors ]! ! -!CompiledMethod methodsFor: 'auto complete' stamp: 'HAW 2/19/2019 17:53:31' prior: 50433447! - receiverTextAutoCompleterDocumentation - - | receiverString | - - receiverString := String streamContents: [ :stream | - stream - nextPutAll: self methodClass typeName; - nextPutAll: '>>' ]. - - ^Text string: receiverString attributes: (SHTextStylerST80 attributesFor: #patternKeyword). - - ! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting - private' stamp: 'HAW 2/19/2019 15:43:38' prior: 50434107! - addCategoriesAndSelectorsOf: aClass - - | classOrganization | - - classOrganization := aClass organization. - - classOrganization categories do: [ :aCategory | - self hasReachSelectorsLimit ifTrue: [ ^ self ]. - self addCategory: aCategory of: classOrganization ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3620-Autocompleter-tweaks-HernanWilkinson-2019Feb19-14h19m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3620] on 20 February 2019 at 7:05:43 pm'! -!CodePackageList methodsFor: 'as yet unclassified' stamp: 'HAW 2/20/2019 19:05:23'! - methodNodeOf: aSourceCode ifErrorsParsing: aParsingErrorBlock - - ^aParsingErrorBlock value: nil! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3621-PackageListFix-HernanWilkinson-2019Feb20-19h04m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3621] on 20 February 2019 at 8:00:52 pm'! -!StrikeFont class methodsFor: 'instance creation' stamp: 'jmv 2/20/2019 19:58:58' prior: 50435479! - install: aString -" -StrikeFont install: 'DejaVu'. - -StrikeFont install: 'DejaVu Sans'. -StrikeFont buildLargerPunctuation: 'DejaVu Sans'. -Preferences setDefaultFontFamilyTo: 'DejaVu Sans'. -Preferences standardFonts. -Character initialize. -" -" -StrikeFont install: 'DejaVu Sans Mono'. -Preferences setDefaultFontFamilyTo: 'DejaVu Sans Mono'. -Preferences bigFonts. -Character initialize. -" -" -StrikeFont install: 'Inconsolata' -StrikeFont install: '#PilGi' -StrikeFont install: 'Optima' -StrikeFont install: 'Herculanum' -StrikeFont install: 'Papyrus' -StrikeFont install: 'Handwriting - Dakota' -StrikeFont install: 'Times New Roman' -StrikeFont install: 'Apple Chancery' -StrikeFont install: 'Cochin' -StrikeFont install: 'Cracked' -StrikeFont install: 'Zapfino' -StrikeFont install: 'Brush Script MT' -StrikeFont install: 'Chalkboard' -" - | fontDict | - fontDict _ nil. - #(5 6 7 8 9 10 11 12 14 17 22 28 36 46 60 80) do: [ :s | - (self create: aString size: s bold: true italic: true boldItalic: false) ifNotNil: [ :font | - fontDict ifNil: [ fontDict _ AvailableFonts at: aString ifAbsentPut: Dictionary new ]. - fontDict - at: s - put: font ]]. - Preferences restoreDefaultFonts! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3622-StrikeFontTweak-JuanVuletich-2019Feb20-20h00m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3622] on 22 February 2019 at 4:50:06 pm'! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'jmv 2/22/2019 16:49:15' prior: 50434970! - computeIdentifierEntries - "Use an aux Set to avoid duplicates, but keep the order given." - | entriesSet lastTitle | - - entriesSet _ Set new. - lastTitle _ nil. - entries _ Array streamContents: [ :strm | - parser namesBeginningWith: prefix do: [ :identifier :kindOfIdentifierTitle | - (entriesSet includes: identifier) ifFalse: [ - kindOfIdentifierTitle = lastTitle ifFalse: [ - strm nextPut: kindOfIdentifierTitle. - lastTitle _ kindOfIdentifierTitle ]. - entriesSet add: identifier. - strm nextPut: identifier ]]]. - entriesSet size = 1 ifTrue: [ - entries _ Array with: entriesSet anyOne ]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/22/2019 16:41:34' prior: 50435125! - blockArgNamesDo: aBlock - "Iterate over block argument names valid at current blockDepth" - - | title | - title _ '-- block arguments'. - blockDepth to: 1 by: -1 do: [ :level | - arguments at: level ifPresent: [ :args | args do: [ :name | aBlock value: name value: title ] ]]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/22/2019 16:41:41' prior: 50435137! - blockTempNamesDo: aBlock - "Iterate over block temp names valid at current blockDepth" - - | title | - title _ '-- block variables'. - blockDepth to: 1 by: -1 do: [ :level | - temporaries at: level ifPresent: [ :args | args do: [ :name | aBlock value: name value: title ] ]]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/22/2019 16:41:48' prior: 50435149! - classVarNamesDo: aBlock - - | title | - title _ '-- class variables'. - classOrMetaClass isBehavior - ifTrue: [ - classOrMetaClass theNonMetaClass withAllSuperclasses do: [ :c | - c classPool keysDo: [ :name | aBlock value: name value: title ] ]]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/22/2019 16:42:08' prior: 50435160! - instVarNamesDo: aBlock - - | title | - title _ '-- instance variables'. - instanceVariables do: [ :name | aBlock value: name value: title ]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/22/2019 16:42:17' prior: 50435168! - methodArgNamesDo: aBlock - "Iterate over method argument names" - - | title | - title _ '-- method arguments'. - ^arguments at: 0 ifPresent: [ :args | args do: [ :name | aBlock value: name value: title ] ]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/22/2019 16:42:24' prior: 50435178! - methodTempNamesDo: aBlock - "Iterate over method temporary names" - - | title | - title _ '-- method variables'. - ^temporaries at: 0 ifPresent: [ :args | args do: [ :name | aBlock value: name value: title ] ]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/22/2019 16:42:33' prior: 50435188! - namesBeginningWith: aString do: aBlock - "Evaluate aBlock for all available names that start with aString" - - self nonGlobalNamesDo: [ :name :kindOfIdentifierTitle | - (name beginsWith: aString) ifTrue: [ aBlock value: name value: kindOfIdentifierTitle ]]. - self namesBeginningWith: aString do: [ :name | aBlock value: name value: '-- classes' ] in: Smalltalk classNames. - self namesBeginningWith: aString do: [ :name | aBlock value: name value: '-- globals' ] in: Smalltalk nonClassNames! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/22/2019 16:43:00' prior: 50435207! - nonGlobalNamesDo: aBlock - "Evaluate aBlock over all available names, except for globals" - - self - blockArgNamesDo: aBlock; - blockTempNamesDo: aBlock; - methodArgNamesDo: aBlock; - methodTempNamesDo: aBlock; - instVarNamesDo: aBlock; - classVarNamesDo: aBlock; - poolConstantNamesDo: aBlock; - workspaceNamesDo: aBlock. - self - reservedNames do: [ :name | - aBlock value: name value: '-- pseudovariables' ]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/22/2019 16:43:31' prior: 50435223! - poolConstantNamesDo: aBlock - - | title | - title _ '-- pool variables'. - classOrMetaClass isBehavior - ifTrue: [ - classOrMetaClass theNonMetaClass withAllSuperclasses do: [ :c | - c sharedPools do: [ :pool | - pool bindingsDo: [ :assoc | aBlock value: assoc key value: title ]]]]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/22/2019 16:43:38' prior: 50435236! - workspaceNamesDo: aBlock - - | title | - title _ '-- workspace variables'. - workspace ifNotNil: [ - workspace bindingNamesDo: [ :name | aBlock value: name value: title ] ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3623-Autocompleter-NameGroupingTweaks-JuanVuletich-2019Feb22-16h41m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3623] on 22 February 2019 at 5:03:32 pm'! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 2/22/2019 17:03:19' prior: 50372173! - setDefaultFont: fontFamilyName spec: defaultFontsSpec - - | font | - defaultFontsSpec do: [ :triplet | - font _ AbstractFont familyName: fontFamilyName pointSize: triplet second. - font ifNil: [ - StrikeFont install: Preferences defaultFontFamily. - font _ AbstractFont familyName: fontFamilyName pointSize: triplet second ]. - font ifNil: [ font _ AbstractFont default ]. - triplet size > 2 ifTrue: [ - font _ font emphasized: triplet third ]. - self - perform: triplet first - with: font]! ! -!StrikeFont class methodsFor: 'instance creation' stamp: 'jmv 2/22/2019 16:57:45' prior: 50372481! - create: fontName size: pointSize bold: includeBold italic: includeItalic boldItalic: includeBoldItalic - " - self create: 'DejaVu Sans Mono' size: 12 bold: true italic: true boldItalic: true - " - | folder base bold oblique boldOblique point | - folder _ DirectoryEntry smalltalkImageDirectory / 'AdditionalFontData'. - point _ pointSize asString. - base _ [ (StrikeFont new - buildFromForm: ((Form fromFileEntry: folder // (fontName, '-0-', point, '.bmp')) asFormOfDepth: 16) - data: (folder // (fontName, '-0-', point, '.txt')) fileContents substrings - name: fontName, ' ', point) - pointSize: pointSize ] on: FileDoesNotExistException do: [ : ex | nil ]. - includeBold ifTrue: [ - bold _ [ (StrikeFont new - buildFromForm: ((Form fromFileEntry: folder // (fontName, '-1-', point, '.bmp')) asFormOfDepth: 16) - data: (folder // (fontName, '-1-', point, '.txt')) fileContents substrings - name: fontName, ' ', point, 'B') - emphasis: 1; - pointSize: pointSize ] on: FileDoesNotExistException do: [ : ex | nil ]]. - includeItalic ifTrue: [ - oblique _ [ (StrikeFont new - buildFromForm: ((Form fromFileEntry: folder // (fontName, '-2-', point, '.bmp')) asFormOfDepth: 16) - data: (folder // (fontName, '-2-', point, '.txt')) fileContents substrings - name: fontName, ' ', point, 'I') - emphasis: 2; - pointSize: pointSize ] on: FileDoesNotExistException do: [ : ex | nil ]]. - includeBoldItalic ifTrue: [ - boldOblique _ [ (StrikeFont new - buildFromForm: ((Form fromFileEntry: folder // (fontName, '-3-', point, '.bmp')) asFormOfDepth: 16) - data: (folder // (fontName, '-3-', point, '.txt')) fileContents substrings - name: fontName, ' ', point, 'BI') - emphasis: 3; - pointSize: pointSize ] on: FileDoesNotExistException do: [ : ex | nil ]]. - "We have a regular, base font. Make others derivatives of it" - base ifNotNil: [ - bold ifNotNil: [ - base derivativeFont: bold at: 1 ]. - oblique ifNotNil: [ - base derivativeFont: oblique at: 2]. - boldOblique ifNotNil: [ - base derivativeFont: boldOblique at: 3 ]. - ^base ]. - "We don't have a base, regular font." - oblique ifNotNil: [ - oblique emphasis: 0. "Hacky. Non regular fonts can not have derivatives. Should change this?" - bold ifNotNil: [ - oblique derivativeFont: bold at: 1 ]. - boldOblique ifNotNil: [ - oblique derivativeFont: boldOblique at: 3 ]. - ^oblique ]. - bold ifNotNil: [ - bold emphasis: 0. "Hacky. Non regular fonts can not have derivatives. Should change this?" - boldOblique ifNotNil: [ - bold derivativeFont: boldOblique at: 3 ]. - ^bold ]. - boldOblique ifNotNil: [ - ^boldOblique ]. - ^nil! ! -!StrikeFont class methodsFor: 'instance creation' stamp: 'jmv 2/22/2019 16:59:13' prior: 50435744! -install: aString -" -StrikeFont install: 'DejaVu'. -" -" -StrikeFont install: 'DejaVu Sans Mono'. -Preferences setDefaultFontFamilyTo: 'DejaVu Sans Mono'. -Preferences bigFonts. -Character initialize. -" -" -StrikeFont install: 'DejaVu Sans'. -StrikeFont buildLargerPunctuation: 'DejaVu Sans'. -Preferences setDefaultFontFamilyTo: 'DejaVu Sans'. -Preferences standardFonts. -Character initialize. -" -" -StrikeFont install: 'Inconsolata' -StrikeFont install: '#PilGi' -StrikeFont install: 'Optima' -StrikeFont install: 'Herculanum' -StrikeFont install: 'Papyrus' -StrikeFont install: 'Handwriting - Dakota' -StrikeFont install: 'Times New Roman' -StrikeFont install: 'Apple Chancery' -StrikeFont install: 'Cochin' -StrikeFont install: 'Cracked' -StrikeFont install: 'Zapfino' -StrikeFont install: 'Brush Script MT' -StrikeFont install: 'Chalkboard' -" - | fontDict | - fontDict _ nil. - 1 to: 200 do: [ :s | - (self create: aString size: s bold: true italic: true boldItalic: false) ifNotNil: [ :font | - font print. - fontDict ifNil: [ fontDict _ AvailableFonts at: aString ifAbsentPut: Dictionary new ]. - fontDict - at: s - put: font ]]. - Preferences restoreDefaultFonts! ! -!Theme class methodsFor: 'user interface' stamp: 'jmv 2/22/2019 17:02:20' prior: 50435605! - changeFontSizes - - (MenuMorph new defaultTarget: Preferences) - addTitle: 'Choose a size'; - addStayUpIcons; - add: 'Very High Resolution / Big Fonts (80pix)' action: #defaultFont80; - add: 'Very High Resolution / Big Fonts (60pix)' action: #defaultFont60; - add: 'Very High Resolution / Reg Fonts (46pix)' action: #defaultFont46; - add: 'Very High Resolution / Reg Fonts (36pix)' action: #defaultFont36; - add: 'High Resolution / Big Fonts (28pix)' action: #defaultFont28; - add: 'High Resolution / Big Fonts (22pix)' action: #defaultFont22; - add: 'High Resolution / Reg Fonts (17pix)' action: #defaultFont17; - add: 'High Resolution / Reg Fonts (14pix)' action: #defaultFont14; - add: 'Standard Resolution (11pix)' action: #defaultFont11; - add: 'Standard Resolution (9pix)' action: #defaultFont9; - add: 'Small Fonts (8pix)' action: #defaultFont8; - add: 'Very small Fonts'action: #verySmallFonts; - add: 'Tiny Fonts'action: #tinyFonts; - popUpInWorld: self runningWorld! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3624-AdditionalFontInstallingEnhancements-JuanVuletich-2019Feb22-16h56m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3622] on 21 February 2019 at 3:10:53 pm'! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'HAW 2/21/2019 11:51:45' prior: 50433495! - resetMenu - - | width newExtent adjustedY | - - self hideSelectorDocumentation. - firstVisible _ 1. - self selected: 1. - - width _ self calculateWidth. - newExtent _ width + 4 @ (self visibleItemsCount * self itemHeight+2). - - adjustedY := (self isYOutOfScreen: originalPosition with: newExtent) - ifTrue: [ originalPosition y - newExtent y - self itemHeight ] - ifFalse: [ originalPosition y ]. - - self morphPosition: originalPosition x @ adjustedY extent: newExtent. - "redraw is needed even if position and extent haven't changed" - self redrawNeeded ! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3625-AutoCompleterMorphRedraw-HernanWilkinson-2019Feb21-08h18m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3622] on 21 February 2019 at 5:09:48 pm'! - -AutoCompleter subclass: #ClassNameCompleter - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #ClassNameCompleter category: #'Tools-Autocompletion'! -AutoCompleter subclass: #ClassNameCompleter - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser selectorsClasses possibleInvalidSelectors canShowSelectorDocumentation ' - classVariableNames: 'AccessLock EntriesLimit Selectors ' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #SmalltalkCompleter category: #'Tools-Autocompletion'! -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser selectorsClasses possibleInvalidSelectors canShowSelectorDocumentation' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! -!AutoCompleter methodsFor: 'testing' stamp: 'HAW 2/21/2019 16:00:50'! - canShowSelectorDocumentation - - self subclassResponsibility! ! -!ClassNameCompleter methodsFor: 'testing' stamp: 'HAW 2/21/2019 16:01:01'! - canShowSelectorDocumentation - - ^false! ! -!ClassNameCompleter methodsFor: 'testing' stamp: 'HAW 2/21/2019 15:54:56'! - opensWithTab - - ^true! ! -!ClassNameCompleter methodsFor: 'entries' stamp: 'HAW 2/21/2019 15:53:24'! - computeEntries - - prefix _ model actualContents string. - entries _ (Smalltalk classNames select: [ :aClassName | aClassName beginsWith: prefix ]) sort. - ! ! -!SmalltalkCompleter methodsFor: 'testing' stamp: 'HAW 2/21/2019 16:06:32'! - canShowSelectorDocumentation - - ^canShowSelectorDocumentation ! ! -!ClassNameRequestMorph methodsFor: 'user interface support' stamp: 'HAW 2/21/2019 15:53:49' prior: 16807427! - autoCompleterClassFor: textGetter - - ^ClassNameCompleter ! ! -!AutoCompleter methodsFor: 'keyboard' stamp: 'HAW 2/21/2019 16:10:52' prior: 50434432! - handleKeystrokeBefore: kbEvent - - "I return a boolean. true when I have handled the event and no futher processing is needed by the caller." - - | shouldOpenMorph | - - shouldOpenMorph _ self shouldOpenMorph. - - "Stuff to do if the menu is not open" - menuMorph ifNil: [ ^ self openCompletionMenuFor: kbEvent if: shouldOpenMorph ]. - - "Starting here, stuff to do if the menu is open" - menuMorph stillActive. - - kbEvent isEsc ifTrue: [ self closeMenu. ^ true]. - kbEvent isBackspace ifTrue: [ shouldOpenMorph ifFalse: [ self closeMenu ]. ^ false]. - kbEvent isHome ifTrue: [ menuMorph goHome. ^ true ]. - kbEvent isEnd ifTrue: [ menuMorph goToEnd. ^ true]. - kbEvent isQuesitonMark ifTrue: [ menuMorph help. ^true]. - kbEvent isArrowUp ifTrue: [ menuMorph goUp. ^ true]. - kbEvent isArrowDown ifTrue: [ menuMorph goDown. ^ true]. - kbEvent isPageUp ifTrue: [ menuMorph goPageUp. ^ true]. - kbEvent isPageDown ifTrue: [ menuMorph goPageDown. ^ true]. - - self canShowSelectorDocumentation - ifTrue: [ - kbEvent isArrowRight ifTrue: [ menuMorph showSelectorDocumentation. ^ true ]. - kbEvent isArrowLeft ifTrue: [ menuMorph hideSelectorDocumentation. ^ true ]] - ifFalse: [ - "If it is showing identifiers I eat the right arrow key because the user is used to it when - showing selectors, so to avoid an unexpected behavior I do nothing with it -Hernan" - kbEvent isArrowRight ifTrue: [ ^ true ]]. - - (self shouldInsertSelected: kbEvent) ifTrue: [ self insertSelected ifTrue: [^ true]]. - (self shouldCloseMenu: kbEvent) ifTrue: [ self closeMenu ]. - - ^false! ! -!AutoCompleter methodsFor: 'testing' stamp: 'HAW 2/21/2019 15:55:35' prior: 16781305! - opensWithTab - - "Returns wheter should open the auto completer when pressing Tab or not" - - ^false! ! -!SmalltalkCompleter methodsFor: 'testing' stamp: 'HAW 2/21/2019 15:55:07' prior: 16909360! - opensWithTab - - ^true! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 2/21/2019 16:05:59' prior: 50434540! - computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel - - | id rangeType | - - canShowSelectorDocumentation _ true. - id _ allSource copyFrom: range start to: range end. - rangeType _ range rangeType. - - rangeType == #globalVar ifTrue: [ ^self computeMessageEntriesForClass: (Smalltalk at: id asSymbol) class ]. - rangeType == #self ifTrue: [ ^self computeMessageEntriesForClass: contextClass ]. - rangeType == #super ifTrue: [ ^self computeMessageEntriesForClass: contextClass superclass ]. - rangeType == #true ifTrue: [ ^self computeMessageEntriesForClass: True ]. - rangeType == #false ifTrue: [ ^self computeMessageEntriesForClass: False ]. - rangeType == #nil ifTrue: [ ^self computeMessageEntriesForClass: UndefinedObject ]. - rangeType == #character ifTrue: [ ^self computeMessageEntriesForClass: id first class ]. - rangeType == #number ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #string ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #symbol ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #stringSymbol ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #instVar ifTrue: [ ^specificModel computeMessageEntriesIn: self ofInstVarNamed: id ]. - rangeType == #methodArg ifTrue: [ ^specificModel computeMessageEntriesIn: self ofTempVarNamed: id ]. - rangeType == #tempVar ifTrue: [ ^specificModel computeMessageEntriesIn: self ofTempVarNamed: id ]. - rangeType == #blockArg ifTrue: [ ^specificModel computeMessageEntriesIn: self ofBlockArgNamed: id ]. - rangeType == #blockTempVar ifTrue: [ ^specificModel computeMessageEntriesIn: self ofBlockTempVarNamed: id ]. - rangeType == #workspaceVar ifTrue: [ ^self computeMessageEntriesForClassOrNil: (specificModel classOfWorkspaceVarNamed: id) ]. - rangeType == #thisContext ifTrue: [ ^self computeMessageEntriesForClass: (specificModel classOfThisContext) ]. - rangeType == #classVar ifTrue: [ ^self computeMessageEntriesForClassOrNil: (self classOfLocalBindingNamed: id in: contextClass) ]. - rangeType == #poolConstant ifTrue: [ ^self computeMessageEntriesForClassOrNil: (self classOfLocalBindingNamed: id in: contextClass) ]. - rangeType == #blockEnd ifTrue: [ ^self computeMessageEntriesForClass: BlockClosure ]. - rangeType == #arrayEnd ifTrue: [ ^self computeMessageEntriesForClass: Array ]. - rangeType == #rightBrace ifTrue: [ ^self computeMessageEntriesForClass: Array ]. - rangeType == #unary ifTrue: [ ^self computeEntriesOfUnaryMessageReturnNamed: id at: range ]. - rangeType == #rightParenthesis ifTrue: [ ^self computeMessageEntriesOfEnclosedExpressionReturnAt: range ]. - rangeType == #cascadeSeparator ifTrue: [ ^self computeMessageEntriesOfCascadeReceiverAt: range ]. - - self computeMessageEntriesForUnknowClass - - ! ! -!SmalltalkCompleter methodsFor: 'identifier entries - private' stamp: 'HAW 2/21/2019 16:03:28' prior: 50435792! - computeIdentifierEntries - "Use an aux Set to avoid duplicates, but keep the order given." - - | entriesSet lastTitle | - entriesSet _ Set new. - lastTitle _ nil. - canShowSelectorDocumentation _ false. - - entries _ Array streamContents: [ :strm | - parser namesBeginningWith: prefix do: [ :identifier :kindOfIdentifierTitle | - (entriesSet includes: identifier) ifFalse: [ - kindOfIdentifierTitle = lastTitle ifFalse: [ - strm nextPut: kindOfIdentifierTitle. - lastTitle _ kindOfIdentifierTitle ]. - entriesSet add: identifier. - strm nextPut: identifier ]]]. - entriesSet size = 1 ifTrue: [ - entries _ Array with: entriesSet anyOne ]! ! -!SmalltalkCompleter methodsFor: 'message entries for unknown class - private' stamp: 'HAW 2/21/2019 16:06:15' prior: 50433966! - computeMessageEntriesForUnknowClass - - | selectorsToShow | - - selectorsClasses _ #(). - possibleInvalidSelectors _ IdentitySet new. - canShowSelectorDocumentation _ true. - selectorsToShow _ OrderedCollection new. - - self class protected: [ - Selectors forPrefix: prefix keysAndValuesDo: [ :selector :lastUsedTime | - selectorsToShow := self add: selector and: lastUsedTime to: selectorsToShow. - (Object canUnderstand: selector) ifFalse: [ possibleInvalidSelectors add: selector ]]]. - - selectorsToShow size < EntriesLimit ifTrue: [ selectorsToShow _ self sortByLastUsedTime: selectorsToShow ]. - - " To see the timestamps in the menu (need to tweak #insertCompletion: to activate. Right now, just for debugging) - entries _ selectorsToShow collect: [ :ary | ary first, '(', ((DateAndTime fromString: '01/01/1996 00:00') + ary second minutes) printString,')' ] - " - entries _ selectorsToShow collect: [ :selectorAndTime | selectorAndTime first ] - -! ! - -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser selectorsClasses possibleInvalidSelectors canShowSelectorDocumentation' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #SmalltalkCompleter category: #'Tools-Autocompletion'! -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser selectorsClasses possibleInvalidSelectors canShowSelectorDocumentation' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3626-ShowClassesOnlyInTheClassNameRequestMorph-HernanWilkinson-2019Feb21-15h10m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3622] on 21 February 2019 at 9:48:42 pm'! - -BorderedRectMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity selectorDocumentation originalPosition showUp itemsPerPage ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #AutoCompleterMorph category: #'Tools-Autocompletion'! -BorderedRectMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity selectorDocumentation originalPosition showUp itemsPerPage' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/21/2019 21:38:59'! - calculateItemsPerPage - - | itemsThatCanFit | - - itemsThatCanFit _ (DisplayScreen actualScreenSize y - originalPosition y - 2) // self itemHeight. - itemsPerPage _ (itemsThatCanFit min: self maxItemsPerPage) min: completer entryCount. - -! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/21/2019 21:31:17'! - maxItemsPerPage - - ^13! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'HAW 2/21/2019 21:40:47' prior: 50368546! - goDown - - "Wrap around" - self selected = completer entryCount ifTrue: [ ^ self goHome ]. - - self selected: self selected + 1. - (self selected > self lastVisible and: [self selected <= completer entryCount]) ifTrue: [firstVisible := firstVisible + 1]. - - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'HAW 2/21/2019 21:40:58' prior: 50366881! - goHome - - firstVisible := 1. - self selected: firstVisible. - - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'HAW 2/21/2019 21:42:25' prior: 50366886! - goPageDown - - (self gotoPage: self currentPage + 1) ifFalse: [ self goToEnd ]. - - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'HAW 2/21/2019 21:42:30' prior: 50366892! -goPageUp - - self gotoPage: self currentPage - 1. - - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'HAW 2/21/2019 21:42:37' prior: 50366897! - goToEnd - - self selected: completer entryCount. - firstVisible := selected - itemsPerPage + 1 max: 1. - - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'HAW 2/21/2019 20:46:55' prior: 50368558! - goUp - - (self selected = 0 and: [self firstVisible = 1]) ifTrue: [^ self]. - "Wrap around" - self selected = 1 ifTrue: [ ^self goToEnd ]. - - self selected: self selected - 1. - self selected < self firstVisible ifTrue: [firstVisible := firstVisible - 1]. - - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'HAW 2/21/2019 21:33:37' prior: 16781400! - help - - TextModel new contents: AutoCompleter helpText; openLabel: 'uCompletion Keyboard Help'! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'HAW 2/21/2019 21:41:36' prior: 50436127! - resetMenu - - | width newExtent | - - self hideSelectorDocumentation. - self goHome. - - self calculateItemsPerPage. - width _ self calculateWidth. - newExtent _ width + 4 @ (itemsPerPage * self itemHeight + 2). - - self morphPosition: originalPosition extent: newExtent. - "redraw is needed even if position and extent haven't changed" - self redrawNeeded ! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/11/2019 20:13:14' prior: 50433512! - adjust: aLocation ifOutOfScreenWith: anExtent xOffset: xOffset yOffset: yOffset - - | adjustedLocationX adjustedLocationY | - - adjustedLocationX := (self isXOutOfScreen: aLocation with: anExtent) - ifTrue: [ aLocation x - anExtent x - xOffset ] - ifFalse: [ aLocation x ]. - - adjustedLocationX < 0 ifTrue: [ adjustedLocationX := aLocation x ]. - - adjustedLocationY := (self isYOutOfScreen: aLocation with: anExtent) - ifTrue: [ aLocation y - anExtent y - yOffset ] - ifFalse: [ aLocation y ]. - - ^adjustedLocationX @ adjustedLocationY - ! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/21/2019 21:25:56' prior: 50433532! - calculateWidth - - | width font | - - width _ 120. - font _ self class listFont. - - 1 - to: completer entryCount - do: [ :index | width _ width max: (font widthOfString: (completer entries at: index) asString)]. - - completer entryCount > itemsPerPage ifTrue: [ width _ width + ScrollBar scrollbarThickness ]. - - ^ width ! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/10/2019 23:51:54' prior: 50433584! - drawItemsOn: aCanvas width: width - - | itemTop | - - itemTop _ 1. - self firstVisible - to: self lastVisible - do: [ :index | - self drawItemOf: index on: aCanvas width: width top: itemTop. - itemTop _ itemTop + self itemHeight ].! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/21/2019 21:26:22' prior: 50433612! - drawScrollBarOn: aCanvas - - | scrollbarThickness width | - - width _ extent x-2. - completer entryCount > itemsPerPage ifTrue: [ - scrollbarThickness _ ScrollBar scrollbarThickness. - width _ width - scrollbarThickness. - - self drawScrollBarRectangleOn: aCanvas thickness: scrollbarThickness. - self drawUpArrowOn: aCanvas thickness: scrollbarThickness. - self drawDownArrowOn: aCanvas thickness: scrollbarThickness. - self drawScrollBarMovementBarOn: aCanvas thickness: scrollbarThickness ]. - - ^width -! ! -!AutoCompleterMorph methodsFor: 'events' stamp: 'HAW 2/21/2019 21:45:16' prior: 50434335! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - - (self morphContainsPoint: localEventPosition) - ifTrue: [ - ((self upButtonPosition extent: ScrollBar scrollbarThickness) containsPoint: localEventPosition) - ifTrue: [ ^self stillActive; goUp ]. - ((self downButtonPosition extent: ScrollBar scrollbarThickness) containsPoint: localEventPosition) - ifTrue: [ ^self stillActive; goDown ]. - self selected: (localEventPosition y // self itemHeight) + self firstVisible. - completer insertSelected ] - ifFalse: [ self delete. completer menuClosed ]! ! -!AutoCompleterMorph methodsFor: 'paging' stamp: 'HAW 2/21/2019 21:26:13' prior: 16781592! - currentPage - - ^(self selected - 1 // itemsPerPage ) + 1.! ! -!AutoCompleterMorph methodsFor: 'paging' stamp: 'HAW 2/21/2019 21:45:37' prior: 50366935! - gotoPage: anInteger - - | item | - - item := ((anInteger - 1) * itemsPerPage) + 1. - item >= completer entryCount ifTrue: [^false]. - - item < 1 ifTrue: [item := 1]. - firstVisible := item. - self selected: firstVisible. - - ^ true! ! -!AutoCompleterMorph methodsFor: 'paging' stamp: 'HAW 2/21/2019 21:28:22' prior: 16781607! - pageCount - - | count | - - completer entryCount = itemsPerPage ifTrue: [^ 1]. - - count _ completer entryCount // itemsPerPage. - (completer entryCount \\ itemsPerPage) > 0 ifTrue: [ count _ count + 1]. - - ^count! ! -!AutoCompleterMorph methodsFor: 'private' stamp: 'HAW 2/21/2019 21:45:53' prior: 16781639! - firstVisible - - ^firstVisible min: completer entryCount! ! -!AutoCompleterMorph methodsFor: 'private' stamp: 'HAW 2/21/2019 21:25:00' prior: 16781644! - lastVisible - - ^ (self firstVisible + itemsPerPage - 1) min: completer entryCount! ! -!AutoCompleterMorph methodsFor: 'selector documentation' stamp: 'HAW 2/21/2019 21:28:49' prior: 50433698! - selectorDefaultDocumentationLocation - - | relativeSelected | - - relativeSelected := (self selected - self firstVisible) min: itemsPerPage - 1 max: 0. - - ^location externalizePosition: extent x@(relativeSelected * self itemHeight + 1). - - ! ! -!AutoCompleterMorph methodsFor: 'selector documentation' stamp: 'HAW 2/11/2019 16:18:05' prior: 50433716! - selectorDocumentationExtent - - ^`600@250`! ! - -AutoCompleterMorph class removeSelector: #itemsPerPage! - -AutoCompleterMorph class removeSelector: #itemsPerPage! - -AutoCompleterMorph class removeSelector: #maxItemsPerPage! - -AutoCompleterMorph removeSelector: #visibleItemsCount! - -AutoCompleterMorph removeSelector: #visibleItemsCount! - -BorderedRectMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity selectorDocumentation originalPosition showUp itemsPerPage' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #AutoCompleterMorph category: #'Tools-Autocompletion'! -BorderedRectMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity selectorDocumentation originalPosition showUp itemsPerPage' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3627-AutoCompleterMorphItemsPerPage-HernanWilkinson-2019Feb21-17h09m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3622] on 21 February 2019 at 10:08:10 pm'! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 2/21/2019 22:00:30'! - ifEmptyEntriesShowAllPrefixedSelectors - - entries isEmpty ifTrue: [ self computeMessageEntriesForUnknowClass ] ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 2/21/2019 21:59:30' prior: 50433935! - computeMessageEntriesForClass: aClass - - selectorsClasses := Array with: aClass. - - entries := (AutoCompleterSelectorsCollector for: prefix) - addSelectorsOf: aClass; - entriesToShow. - - self ifEmptyEntriesShowAllPrefixedSelectors! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3628-ShowsAllPrefixedSelectors-HernanWilkinson-2019Feb21-21h48m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3620] on 21 February 2019 at 12:30:15 am'! -!CodeWindow methodsFor: 'keyboard shortcuts' stamp: 'HAW 2/21/2019 00:29:45' prior: 50401403! - messageCatListKey: aChar from: view - - aChar == $o ifTrue: [^ model fileOutMessageCategories ]. - aChar == $t ifTrue: [^ model runMessageCategoryTests ]. - aChar == $x ifTrue: [^ model removeMessageCategory ]. - aChar == $R ifTrue: [ ^model renameCategory ]. - aChar == $n ifTrue: [^model addCategory ]. - aChar == $e ifTrue: [^model removeEmptyCategories ]. - aChar == $c ifTrue: [^model categorizeAllUncategorizedMethods ].! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 2/21/2019 00:29:34' prior: 50411444! - messageCategoryMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'fileOut (o)'. - #object -> #model. - #selector -> #fileOutMessageCategories. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'reorganize'. - #object -> #model. - #selector -> #editMessageCategories. - #icon -> #sendReceiveIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'alphabetize'. - #object -> #model. - #selector -> #alphabetizeMessageCategories. - #icon -> #fontXGenericIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'remove empty categories (e)'. - #object -> #model. - #selector -> #removeEmptyCategories. - #icon -> #listRemoveIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 40. - #label -> 'categorize all uncategorized (c)'. - #object -> #model. - #selector -> #categorizeAllUncategorizedMethods. - #icon -> #packageIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 50. - #label -> 'new category... (n)'. - #object -> #model. - #selector -> #addCategory. - #icon -> #newIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'rename... (R)'. - #object -> #model. - #selector -> #renameCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'remove (x)'. - #object -> #model. - #selector -> #removeMessageCategory. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'run tests (t)'. - #object -> #model. - #selector -> #runMessageCategoryTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - }`. - ! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3629-AdditionalShortcutsInMsgCatList-HernanWilkinson-2019Feb20-21h50m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3622] on 21 February 2019 at 8:18:20 am'! -!BrowserWindow class methodsFor: 'instance creation' stamp: 'HAW 2/21/2019 08:14:05'! - openNoSysCat: model label: aString - - self new - model: model; - buildNoSysCatMorphicWindow; - setLabel: aString; - openInWorld! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'HAW 2/21/2019 08:16:48' prior: 16793163! - buildNoSysCatMorphicWindow - "A Browser without the class categories list" - - | mySingletonList upperPanes messageCatList messageList | - mySingletonList _ PluggableListMorph - model: model - listGetter: #systemCategorySingleton - indexGetter: #indexIsOne - indexSetter: #indexIsOne: - mainView: self - menuGetter: #systemCatSingletonMenu - keystrokeAction: #systemCatSingletonKey:from:. - mySingletonList hideScrollBarsIndefinitely. - - messageCatList _ self buildMorphicMessageCatList. - messageList _ self buildMorphicMessageList. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: self buildMorphicClassColumn proportionalWidth: 0.3; - addAdjusterAndMorph: messageCatList proportionalWidth: 0.3; - addAdjusterAndMorph: messageList proportionalWidth: 0.4. - - messageList makeItemsDraggable. - messageCatList - acceptDropsFrom: messageList - performing: #categorizeUnderCategoryAt:selector: - whenOutsideList: #categorizeUnderNewCategorySelector:. - - self layoutMorph - addMorph: mySingletonList fixedHeight: Preferences standardCodeFont height + 10; - addAdjusterAndMorph: upperPanes proportionalHeight: 0.3; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.7. - - model changed: #editSelection! ! - -CodeWindow class removeSelector: #openNoSysCat:label:! - -CodeWindow class removeSelector: #openNoSysCat:label:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3630-MessageDnDInHierarchyBrowser-HernanWilkinson-2019Feb21-08h00m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3610] on 23 February 2019 at 8:07:26 pm'! -!Object methodsFor: 'debugging-haltOnce' stamp: 'GC 2/23/2019 20:05:35'! - clearHaltOnce - "Turn on the halt once flag." - - Smalltalk at: #HaltOnce put: false! ! -!Object methodsFor: 'debugging-haltOnce' stamp: 'GC 2/23/2019 20:05:43'! - haltOnce - "Halt unless we have already done it once." - - self haltOnceEnabled ifTrue: [ - self clearHaltOnce. - ^ self halt - ]! ! -!Object methodsFor: 'debugging-haltOnce' stamp: 'GC 2/23/2019 20:05:48'! - haltOnceEnabled - - ^ Smalltalk - at: #HaltOnce - ifAbsent: [false]! ! -!Object methodsFor: 'debugging-haltOnce' stamp: 'GC 2/23/2019 20:05:52'! - setHaltOnce - "Turn on the halt once flag." - - Smalltalk at: #HaltOnce put: true! ! -!Object methodsFor: 'debugging-haltOnce' stamp: 'GC 2/23/2019 20:00:03'! - toggleHaltOnce - self haltOnceEnabled - ifTrue: [self clearHaltOnce] - ifFalse: [self setHaltOnce]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3631-haltOnce-GastonCaruso-2019Feb23-19h57m-GC.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3631] on 25 February 2019 at 2:34:25 pm'! -!SmalltalkCompleter class methodsFor: 'class initialization' stamp: 'jmv 2/25/2019 14:33:42' prior: 50434661! - initialize - " - It takes about 6 seconds, mostly because of the time to fetch method stamps from source files... - [ SmalltalkCompleter initialize ]timeToRun - Selectors inspect - " - | maxSortValue allImplemented | - - EntriesLimit _ 100. - - SystemChangeNotifier uniqueInstance - removeActionsWithReceiver: self. "avoid double registration" - - SystemChangeNotifier uniqueInstance - when: #classRemoved send: #classRemoved:fromCategory: to: self; - when: #methodAdded send: #methodAdded:selector:inClass:requestor: to: self; - when: #methodAddedInProtocol send: #methodAdded:selector:inProtocol:class:requestor: to: self; - when: #methodRemoved send: #methodRemoved:selector:inProtocol:class: to: self. - - self protected: [ - allImplemented _ Smalltalk allImplementedMessages. - Selectors _ Trie new. - " - Smalltalk allBehaviorsDo: [:class | - class selectorsAndMethodsDo: [ :sel :method | - Selectors at: sel ifAbsentPut: [ 0 ]. - method messages do: [ :sentMsg | - Selectors at: sentMsg put: (Selectors at: sentMsg ifAbsent: [ 0 ]) + 1 ]]]. - " - Smalltalk allBehaviorsDo: [:class | - class selectorsAndMethodsDo: [ :sel :method | - self addSelector: sel method: method allImplemented: allImplemented]]. - "" - - "The following might not be found in #messages. Give them maximum priority." - maxSortValue _ SmallInteger maxVal. - "From MessageNode>>#initialize" - #( ifTrue: ifFalse: ifTrue:ifFalse: ifFalse:ifTrue: - and: or: - whileFalse: whileTrue: whileFalse whileTrue - to:do: to:by:do: - caseOf: caseOf:otherwise: - ifNil: ifNotNil: ifNil:ifNotNil: ifNotNil:ifNil:) do: [ :sel | - Selectors at: sel put: maxSortValue ]. - - maxSortValue _ SmallInteger maxVal-1. - "From SystemDictionary >>#recreateSpecialObjectsArray" - (1 to: Smalltalk specialSelectorSize) do: [ :i | | sym | - sym _ Smalltalk specialSelectorAt: i. - (Selectors includesKey: sym) - ifTrue: [ Selectors at: sym put: maxSortValue ]]]! ! - -SmalltalkCompleter initialize! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3632-SmalltalkCompleterFix-JuanVuletich-2019Feb25-14h26m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3632] on 25 February 2019 at 3:37:56 pm'! -!PluggableListMorph methodsFor: 'events' stamp: 'jmv 2/25/2019 15:21:30' prior: 50426387! - dragEvent: aMouseEvent localPosition: localEventPosition - - | row dragged listItem | - self listMorph highlightedRow: nil. - row _ self rowAtLocation: localEventPosition ifNone: [ ^self ]. - listItem _ self getListItem: row. - - dragged _ DraggingGuideMorph new. - dragged addMorph: (StringMorph contents: listItem). - dragged setProperty: #dragSource toValue: self. - dragged setProperty: #dropSelectorArgument toValue: listItem. - - aMouseEvent hand attachMorphBeside: dragged.! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3633-PluggableListMorphFix-JuanVuletich-2019Feb25-15h37m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3633] on 27 February 2019 at 1:27:51 pm'! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/27/2019 13:20:35'! - bigFonts - "Sets not only fonts but other GUI elements - to fit regular resolution and size screens - Preferences bigFonts - " - - self defaultFont17! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/27/2019 13:03:25'! - defaultFont05 - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences defaultFont05 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 7) - (setListFontTo: 5) - (setMenuFontTo: 5) - (setWindowTitleFontTo: 7) - (setCodeFontTo: 5) - (setButtonFontTo: 5)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/27/2019 13:06:29'! - defaultFont06 - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences defaultFont06 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 7) - (setListFontTo: 6) - (setMenuFontTo: 6) - (setWindowTitleFontTo: 8) - (setCodeFontTo: 6) - (setButtonFontTo: 6)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/27/2019 13:04:07'! - defaultFont07 - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences defaultFont07 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 8) - (setListFontTo: 7) - (setMenuFontTo: 7) - (setWindowTitleFontTo: 9) - (setCodeFontTo: 7) - (setButtonFontTo: 7)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/27/2019 13:02:21'! - defaultFont08 - "Sets not only fonts but other GUI elements - to fit low resolution or small screens - Preferences defaultFont08 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 8) - (setListFontTo: 8) - (setMenuFontTo: 8) - (setWindowTitleFontTo: 11) - (setCodeFontTo: 8) - (setButtonFontTo: 8)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/27/2019 13:02:38'! - defaultFont09 - "Sets not only fonts but other GUI elements - to fit low resolution or small screens - Preferences defaultFont09 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 9) - (setListFontTo: 9) - (setMenuFontTo: 10) - (setWindowTitleFontTo: 12) - (setCodeFontTo: 9) - (setButtonFontTo: 9)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/27/2019 13:05:56'! - defaultFont10 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont10 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 10) - (setListFontTo: 10) - (setMenuFontTo: 11) - (setWindowTitleFontTo: 12) - (setCodeFontTo: 10) - (setButtonFontTo: 10)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/27/2019 13:07:19'! - defaultFont12 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont12 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 12) - (setListFontTo: 12) - (setMenuFontTo: 12) - (setWindowTitleFontTo: 14) - (setCodeFontTo: 12) - (setButtonFontTo: 12)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/27/2019 13:20:12'! - hugeFonts - "Sets not only fonts but other GUI elements - to fit regular resolution and size screens - Preferences hugeFonts - " - - self defaultFont46! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/27/2019 13:21:58'! - smallFonts - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences smallFonts - " - - self defaultFont09! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/27/2019 13:20:22'! - veryBigFonts - "Sets not only fonts but other GUI elements - to fit regular resolution and size screens - Preferences veryBigFonts - " - - self defaultFont28! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/27/2019 13:20:44' prior: 50435451! - standardFonts - "Sets not only fonts but other GUI elements - to fit regular resolution and size screens - Preferences standardFonts - " - - self defaultFont12! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/27/2019 13:03:47' prior: 50397756! - tinyFonts - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences tinyFonts - " - - self defaultFont05! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/27/2019 13:04:24' prior: 50435460! - verySmallFonts - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences verySmallFonts - " - - self defaultFont07! ! -!StrikeFont class methodsFor: 'instance creation' stamp: 'jmv 2/27/2019 13:16:39' prior: 50436046! - install: aString -" -StrikeFont install: 'DejaVu'. -" -" -StrikeFont install: 'DejaVu Sans Mono'. -Preferences setDefaultFontFamilyTo: 'DejaVu Sans Mono'. -Preferences bigFonts. -Character initialize. -" -" -StrikeFont install: 'DejaVu Sans'. -StrikeFont buildLargerPunctuation: 'DejaVu Sans'. -Preferences setDefaultFontFamilyTo: 'DejaVu Sans'. -Preferences standardFonts. -Character initialize. -" -" -StrikeFont install: 'Inconsolata' -StrikeFont install: '#PilGi' -StrikeFont install: 'Optima' -StrikeFont install: 'Herculanum' -StrikeFont install: 'Papyrus' -StrikeFont install: 'Handwriting - Dakota' -StrikeFont install: 'Times New Roman' -StrikeFont install: 'Apple Chancery' -StrikeFont install: 'Cochin' -StrikeFont install: 'Cracked' -StrikeFont install: 'Zapfino' -StrikeFont install: 'Brush Script MT' -StrikeFont install: 'Chalkboard' -" - | fontDict | - fontDict _ nil. - 1 to: 200 do: [ :s | - (self create: aString size: s bold: true italic: true boldItalic: false) ifNotNil: [ :font | - font print. - fontDict ifNil: [ fontDict _ AvailableFonts at: aString ifAbsentPut: Dictionary new ]. - fontDict - at: s - put: font ]]! ! -!Theme class methodsFor: 'user interface' stamp: 'jmv 5/6/2018 16:42:00' prior: 50436085! - changeFontSizes - - (MenuMorph new defaultTarget: Preferences) - addTitle: 'Choose a size'; - addStayUpIcons; - add: 'Huge Fonts' action: #hugeFonts; - add: 'Very big Fonts' action: #veryBigFonts; - add: 'Big Fonts' action: #bigFonts; - add: 'Standard Fonts' action: #standardFonts; - add: 'Small Fonts' action: #smallFonts; - add: 'Very small Fonts'action: #verySmallFonts; - add: 'Tiny Fonts'action: #tinyFonts; - popUpInWorld: self runningWorld! ! - -Preferences class removeSelector: #defaultFont8! - -Preferences class removeSelector: #defaultFont8! - -Preferences class removeSelector: #defaultFont9! - -Preferences class removeSelector: #defaultFont9! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Preferences standardFonts! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3634-BetterFontSizeOptions-JuanVuletich-2019Feb27-13h02m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3634] on 1 March 2019 at 1:52:22 pm'! -!InnerTextMorph methodsFor: 'notifications' stamp: 'jmv 3/1/2019 00:34:30' prior: 16855878! - fontPreferenceChanged - - super fontPreferenceChanged. - hasUnacceptedEdits ifFalse: [ - model refetch ]. - self updateFromTextComposition.! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3635-CodePaneFontChangesOnFontSelection-JuanVuletich-2019Mar01-13h51m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3634] on 28 February 2019 at 8:31:40 pm'! - -Smalltalk renameClassNamed: #ProgessiveTestRunner as: #ProgressiveTestRunner! -!Browser methodsFor: 'tdd' stamp: 'HAW 2/28/2019 20:30:14' prior: 50338016! - runClassTests - - self selectedClassName ifNotNil: [ :aClassName | | selectedClass | - selectedClass _ Smalltalk classNamed: aClassName. - (ProgressiveTestRunner for: (TestSuite forClass: selectedClass)) value ]! ! -!Browser methodsFor: 'tdd' stamp: 'HAW 2/28/2019 20:30:14' prior: 50338025! - runMessageCategoryTests - - selectedMessageCategory ifNotNil: [ | selectedClass suite | - selectedClass _ Smalltalk classNamed: selectedClassName. - suite _ TestSuite forMessageCategoryNamed: selectedMessageCategory of: selectedClass categorizedWith: classOrganizer. - (ProgressiveTestRunner for: suite) value ] - - ! ! -!Browser methodsFor: 'tdd' stamp: 'HAW 2/28/2019 20:30:14' prior: 50338037! - runMethodTest - - | suite | - - suite _ TestSuite forCompiledMethod: currentCompiledMethod. - (ProgressiveTestRunner for: suite) value - ! ! -!Browser methodsFor: 'tdd' stamp: 'HAW 2/28/2019 20:30:14' prior: 50338044! - runSystemCategoryTests - - selectedSystemCategory ifNotNil: [ | suite | - suite _ TestSuite forSystemCategoryNamed: selectedSystemCategory using: systemOrganizer. - (ProgressiveTestRunner for: suite) value ] - - ! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HAW 2/28/2019 20:30:14' prior: 50338456! - runTestSuite: aTestSuite - - (ProgressiveTestRunner for: aTestSuite) value - - ! ! -!TestResultWindow methodsFor: 'actions' stamp: 'HAW 2/28/2019 20:30:14' prior: 50343808! - runSuite - - | suite | - - suite := TestSuite new. - suite addTests: testResult tests. - self delete. - (ProgressiveTestRunner for: suite) value. - ! ! -!ProgressiveTestRunner methodsFor: 'show result - private' stamp: 'HAW 2/28/2019 20:30:59' prior: 50343892! - showDeffects - - | defects | - - defects _ testResult defects. - defects size = 1 - ifTrue: [ defects anyOne debug ] - ifFalse: [ self openTestResultWindow]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3636-ProgressiveTestRunnerRenamed-HernanWilkinson-2019Feb28-20h30m-HAW.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3636] on 1 March 2019 at 1:54:06 pm'! - -MethodNode removeSelector: #rangesForInstanceVariable:ifAbsent:! - -MethodNode removeSelector: #rangesForInstanceVariable:ifAbsent:! - -MethodNode removeSelector: #rangesForTemporaryVariable:ifAbsent:! - -MethodNode removeSelector: #rangesForTemporaryVariable:ifAbsent:! - -Encoder removeSelector: #rangesForInstanceVariable:ifAbsent:! - -Encoder removeSelector: #rangesForInstanceVariable:ifAbsent:! - -Encoder removeSelector: #rangesForTemporaryVariable:ifAbsent:! - -Encoder removeSelector: #rangesForTemporaryVariable:ifAbsent:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3637-RemovedUnnecesaryMethodsFromMethodNodeAndEncoder-HernanWilkinson-2019Mar01-12h31m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3637] on 7 March 2019 at 9:40:58 am'! - -Error subclass: #RefactoringError - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RefactoringError category: #'Tools-Refactoring'! -Error subclass: #RefactoringError - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringError subclass: #CanNotRefactorDueToReferencesError - instanceVariableNames: 'references referencee' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #CanNotRefactorDueToReferencesError category: #'Tools-Refactoring'! -RefactoringError subclass: #CanNotRefactorDueToReferencesError - instanceVariableNames: 'references referencee' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Warning subclass: #RefactoringWarning - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RefactoringWarning category: #'Tools-Refactoring'! -Warning subclass: #RefactoringWarning - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ParseNodeVisitor subclass: #ExtractToTemporaryRewriter - instanceVariableNames: 'refactoring finder' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractToTemporaryRewriter category: #'Tools-Refactoring'! -ParseNodeVisitor subclass: #ExtractToTemporaryRewriter - instanceVariableNames: 'refactoring finder' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ParseNodeVisitor subclass: #ParseNodeToReplaceFinder - instanceVariableNames: 'refactoring currentBlock nodesToReplace blockContainingFirstNodeToReplace firstNodeToReplaceIndex currentStatementIndex' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ParseNodeToReplaceFinder category: #'Tools-Refactoring'! -ParseNodeVisitor subclass: #ParseNodeToReplaceFinder - instanceVariableNames: 'refactoring currentBlock nodesToReplace blockContainingFirstNodeToReplace firstNodeToReplaceIndex currentStatementIndex' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MessageSetWindow subclass: #ChangeSelectorWizardStepWindow - instanceVariableNames: 'applier' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ChangeSelectorWizardStepWindow category: #'Tools-Refactoring'! -MessageSetWindow subclass: #ChangeSelectorWizardStepWindow - instanceVariableNames: 'applier' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelectorWizardStepWindow subclass: #ChangeSelectorImplementorsStepWindow - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ChangeSelectorImplementorsStepWindow category: #'Tools-Refactoring'! -ChangeSelectorWizardStepWindow subclass: #ChangeSelectorImplementorsStepWindow - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelectorWizardStepWindow subclass: #ChangeSelectorSendersStepWindow - instanceVariableNames: 'changedMethods' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ChangeSelectorSendersStepWindow category: #'Tools-Refactoring'! -ChangeSelectorWizardStepWindow subclass: #ChangeSelectorSendersStepWindow - instanceVariableNames: 'changedMethods' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Object subclass: #Refactoring - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #Refactoring category: #'Tools-Refactoring'! -Object subclass: #Refactoring - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Refactoring subclass: #AddInstanceVariable - instanceVariableNames: 'newVariable classToRefactor' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #AddInstanceVariable category: #'Tools-Refactoring'! -Refactoring subclass: #AddInstanceVariable - instanceVariableNames: 'newVariable classToRefactor' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Refactoring subclass: #ChangeSelector - instanceVariableNames: 'oldSelector newSelector implementors senders changes' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ChangeSelector category: #'Tools-Refactoring'! -Refactoring subclass: #ChangeSelector - instanceVariableNames: 'oldSelector newSelector implementors senders changes' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelector subclass: #AddParameter - instanceVariableNames: 'newParameter newParameterValue implementorTrailingString senderTrailingString index isAddingLast' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #AddParameter category: #'Tools-Refactoring'! -ChangeSelector subclass: #AddParameter - instanceVariableNames: 'newParameter newParameterValue implementorTrailingString senderTrailingString index isAddingLast' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelector subclass: #RemoveParameter - instanceVariableNames: 'parameterToRemove parameterIndex senderReplacementString isLastParameter' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RemoveParameter category: #'Tools-Refactoring'! -ChangeSelector subclass: #RemoveParameter - instanceVariableNames: 'parameterToRemove parameterIndex senderReplacementString isLastParameter' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelector subclass: #RenameSelector - instanceVariableNames: 'newSelectorKeywords' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameSelector category: #'Tools-Refactoring'! -ChangeSelector subclass: #RenameSelector - instanceVariableNames: 'newSelectorKeywords' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Refactoring subclass: #ExtractToTemporary - instanceVariableNames: 'newVariable parseNodeToExtract methodNodeToRefactor newTemporary' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractToTemporary category: #'Tools-Refactoring'! -Refactoring subclass: #ExtractToTemporary - instanceVariableNames: 'newVariable parseNodeToExtract methodNodeToRefactor newTemporary' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Refactoring subclass: #InsertSuperclass - instanceVariableNames: 'classToRefactor superclassName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #InsertSuperclass category: #'Tools-Refactoring'! -Refactoring subclass: #InsertSuperclass - instanceVariableNames: 'classToRefactor superclassName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Refactoring subclass: #PushUpMethod - instanceVariableNames: 'method' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #PushUpMethod category: #'Tools-Refactoring'! -Refactoring subclass: #PushUpMethod - instanceVariableNames: 'method' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Refactoring subclass: #RemoveAllUnreferencedInstanceVariables - instanceVariableNames: 'classToRefactor' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RemoveAllUnreferencedInstanceVariables category: #'Tools-Refactoring'! -Refactoring subclass: #RemoveAllUnreferencedInstanceVariables - instanceVariableNames: 'classToRefactor' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Refactoring subclass: #RemoveInstanceVariable - instanceVariableNames: 'variableToRemove classToRefactor' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RemoveInstanceVariable category: #'Tools-Refactoring'! -Refactoring subclass: #RemoveInstanceVariable - instanceVariableNames: 'variableToRemove classToRefactor' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Refactoring subclass: #RenameClass - instanceVariableNames: 'classToRename newClassName system undeclared classToRenameOriginalName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameClass category: #'Tools-Refactoring'! -Refactoring subclass: #RenameClass - instanceVariableNames: 'classToRename newClassName system undeclared classToRenameOriginalName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Refactoring subclass: #RenameInstanceVariable - instanceVariableNames: 'oldVariable addInstanceVariable rewriter renamedReferences' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameInstanceVariable category: #'Tools-Refactoring'! -Refactoring subclass: #RenameInstanceVariable - instanceVariableNames: 'oldVariable addInstanceVariable rewriter renamedReferences' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Refactoring subclass: #RenameTemporary - instanceVariableNames: 'oldVariable newVariable methodNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameTemporary category: #'Tools-Refactoring'! -Refactoring subclass: #RenameTemporary - instanceVariableNames: 'oldVariable newVariable methodNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Refactoring subclass: #SafelyRemoveClass - instanceVariableNames: 'classToRemove' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #SafelyRemoveClass category: #'Tools-Refactoring'! -Refactoring subclass: #SafelyRemoveClass - instanceVariableNames: 'classToRemove' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Object subclass: #RefactoringApplier - instanceVariableNames: 'requestExitBlock refactoring changes' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RefactoringApplier category: #'Tools-Refactoring'! -Object subclass: #RefactoringApplier - instanceVariableNames: 'requestExitBlock refactoring changes' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #AddInstanceVariableApplier - instanceVariableNames: 'classToRefactor oldInstanceVariable newInstanceVariable browser' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #AddInstanceVariableApplier category: #'Tools-Refactoring'! -RefactoringApplier subclass: #AddInstanceVariableApplier - instanceVariableNames: 'classToRefactor oldInstanceVariable newInstanceVariable browser' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #ChangeSelectorApplier - instanceVariableNames: 'oldSelector scopeChoice implementors senders implementingClass wizardStepWindow shouldShowChanges browser' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ChangeSelectorApplier category: #'Tools-Refactoring'! -RefactoringApplier subclass: #ChangeSelectorApplier - instanceVariableNames: 'oldSelector scopeChoice implementors senders implementingClass wizardStepWindow shouldShowChanges browser' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelectorApplier subclass: #AddParameterApplier - instanceVariableNames: 'newParameter newParameterValue newKeyword parameterIndex' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #AddParameterApplier category: #'Tools-Refactoring'! -ChangeSelectorApplier subclass: #AddParameterApplier - instanceVariableNames: 'newParameter newParameterValue newKeyword parameterIndex' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelectorApplier subclass: #RemoveParameterApplier - instanceVariableNames: 'newParameter newParameterValue newKeyword originalMethod parameterToRemove' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RemoveParameterApplier category: #'Tools-Refactoring'! -ChangeSelectorApplier subclass: #RemoveParameterApplier - instanceVariableNames: 'newParameter newParameterValue newKeyword originalMethod parameterToRemove' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelectorApplier subclass: #RenameSelectorApplier - instanceVariableNames: 'newSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameSelectorApplier category: #'Tools-Refactoring'! -ChangeSelectorApplier subclass: #RenameSelectorApplier - instanceVariableNames: 'newSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #InsertSuperclassApplier - instanceVariableNames: 'browser newSuperclassName classToRefactor' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #InsertSuperclassApplier category: #'Tools-Refactoring'! -RefactoringApplier subclass: #InsertSuperclassApplier - instanceVariableNames: 'browser newSuperclassName classToRefactor' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #RemoveAllUnreferencedInstanceVariablesApplier - instanceVariableNames: 'classToRefactor browser variableToRemove' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RemoveAllUnreferencedInstanceVariablesApplier category: #'Tools-Refactoring'! -RefactoringApplier subclass: #RemoveAllUnreferencedInstanceVariablesApplier - instanceVariableNames: 'classToRefactor browser variableToRemove' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #RemoveInstanceVariableApplier - instanceVariableNames: 'classToRefactor browser variableToRemove' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RemoveInstanceVariableApplier category: #'Tools-Refactoring'! -RefactoringApplier subclass: #RemoveInstanceVariableApplier - instanceVariableNames: 'classToRefactor browser variableToRemove' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #RenameClassApplier - instanceVariableNames: 'browser classToRename newClassName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameClassApplier category: #'Tools-Refactoring'! -RefactoringApplier subclass: #RenameClassApplier - instanceVariableNames: 'browser classToRename newClassName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #RenameInstanceVariableApplier - instanceVariableNames: 'classToRefactor oldInstanceVariable newInstanceVariable browser' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameInstanceVariableApplier category: #'Tools-Refactoring'! -RefactoringApplier subclass: #RenameInstanceVariableApplier - instanceVariableNames: 'classToRefactor oldInstanceVariable newInstanceVariable browser' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #RenameTemporaryApplier - instanceVariableNames: 'classToRefactor oldVariable newVariable smalltalkEditor methodNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameTemporaryApplier category: #'Tools-Refactoring'! -RefactoringApplier subclass: #RenameTemporaryApplier - instanceVariableNames: 'classToRefactor oldVariable newVariable smalltalkEditor methodNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #SafelyRemoveClassApplier - instanceVariableNames: 'classToRemove browser' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #SafelyRemoveClassApplier category: #'Tools-Refactoring'! -RefactoringApplier subclass: #SafelyRemoveClassApplier - instanceVariableNames: 'classToRemove browser' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Object subclass: #RefactoringMenues - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RefactoringMenues category: #'Tools-Refactoring'! -Object subclass: #RefactoringMenues - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Object subclass: #RefactoringPrecondition - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RefactoringPrecondition category: #'Tools-Refactoring'! -Object subclass: #RefactoringPrecondition - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringPrecondition subclass: #NewClassPrecondition - instanceVariableNames: 'newClassName system undeclared' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #NewClassPrecondition category: #'Tools-Refactoring'! -RefactoringPrecondition subclass: #NewClassPrecondition - instanceVariableNames: 'newClassName system undeclared' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringPrecondition subclass: #NewInstanceVariablePrecondition - instanceVariableNames: 'classToAddInstVar instVarName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #NewInstanceVariablePrecondition category: #'Tools-Refactoring'! -RefactoringPrecondition subclass: #NewInstanceVariablePrecondition - instanceVariableNames: 'classToAddInstVar instVarName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!CanNotRefactorDueToReferencesError methodsFor: 'references' stamp: 'HAW 7/11/2018 16:56:20'! - anyReference - - ^references anyOne ! ! -!CanNotRefactorDueToReferencesError methodsFor: 'references' stamp: 'HAW 7/11/2018 16:54:54'! - numberOfReferences - - ^references size! ! -!CanNotRefactorDueToReferencesError methodsFor: 'references' stamp: 'HAW 8/1/2018 17:26:49'! - references - - ^references copy! ! -!CanNotRefactorDueToReferencesError methodsFor: 'initialization' stamp: 'HAW 8/1/2018 17:32:33'! - initialize: aMessageText references: aCollectionOfReferences to: aReferencee - - self messageText: aMessageText. - references := aCollectionOfReferences. - referencee := aReferencee ! ! -!CanNotRefactorDueToReferencesError methodsFor: 'referencee' stamp: 'HAW 8/1/2018 17:32:46'! - referencee - - ^referencee ! ! -!CanNotRefactorDueToReferencesError class methodsFor: 'signaling' stamp: 'HAW 8/1/2018 17:32:15'! - signal: aMessageText references: references to: aReferencee - - self new - initialize: aMessageText references: references to: aReferencee; - signal! ! -!ExtractToTemporaryRewriter methodsFor: 'initialization' stamp: 'HAW 10/18/2017 18:21:40'! - initializeOf: anExtractToTemporary on: aParseNodeToReplaceFinder - - refactoring := anExtractToTemporary. - finder := aParseNodeToReplaceFinder ! ! -!ExtractToTemporaryRewriter methodsFor: 'visiting' stamp: 'HAW 10/18/2017 18:26:27'! - visitBlockNode: aBlockNode - - | statements | - - statements := aBlockNode statements. - statements withIndexDo: [ :statement :index | - (finder shouldReplace: statement) - ifTrue: [ statements at: index put: refactoring newTemporary ] - ifFalse: [ statement accept: self]]! ! -!ExtractToTemporaryRewriter methodsFor: 'visiting' stamp: 'HAW 10/19/2017 06:24:35'! - visitMessageNode: aMessageNode - - aMessageNode receiver accept: self. - aMessageNode selector accept: self. - aMessageNode argumentsInEvaluationOrder withIndexDo: [:argument :index | - (finder shouldReplace: argument) - ifTrue: [ aMessageNode arguments at: index put: refactoring newTemporary ] - ifFalse: [ argument accept: self]]! ! -!ExtractToTemporaryRewriter methodsFor: 'visiting' stamp: 'HAW 10/19/2017 06:06:05'! - visitReturnNode: aReturnNode - - (finder shouldReplace: aReturnNode expr) - ifTrue: [ aReturnNode expr: refactoring newTemporary ] - ifFalse: [ super visitReturnNode: aReturnNode ]! ! -!ExtractToTemporaryRewriter class methodsFor: 'instance creation' stamp: 'HAW 10/18/2017 18:21:16'! - of: anExtractToTemporary on: aParseNodeToReplaceFinder - - ^self new initializeOf: anExtractToTemporary on: aParseNodeToReplaceFinder - ! ! -!ParseNodeToReplaceFinder methodsFor: 'as yet unclassified' stamp: 'HAW 10/19/2017 06:03:12'! - addNodeToReplace: aParseNode - - nodesToReplace isEmpty ifTrue: [ - blockContainingFirstNodeToReplace := currentBlock. - firstNodeToReplaceIndex := currentStatementIndex ]. - - nodesToReplace add: aParseNode.! ! -!ParseNodeToReplaceFinder methodsFor: 'as yet unclassified' stamp: 'HAW 10/18/2017 18:30:44'! - blockContainingFirstNodeToReplace - - ^blockContainingFirstNodeToReplace! ! -!ParseNodeToReplaceFinder methodsFor: 'as yet unclassified' stamp: 'HAW 10/18/2017 18:31:00'! - firstNodeToReplace - - ^nodesToReplace first! ! -!ParseNodeToReplaceFinder methodsFor: 'as yet unclassified' stamp: 'HAW 10/18/2017 18:39:56'! - firstNodeToReplaceIndex - - ^firstNodeToReplaceIndex! ! -!ParseNodeToReplaceFinder methodsFor: 'as yet unclassified' stamp: 'HAW 10/18/2017 18:12:47'! - keepCurrentBlockIfFirstNodeToReplace - - nodesToReplace isEmpty ifTrue: [ blockContainingFirstNodeToReplace := currentBlock ]. -! ! -!ParseNodeToReplaceFinder methodsFor: 'as yet unclassified' stamp: 'HAW 10/18/2017 18:26:50'! -shouldReplace: aParseNode - - ^nodesToReplace includes: aParseNode ! ! -!ParseNodeToReplaceFinder methodsFor: 'initialization' stamp: 'HAW 10/18/2017 18:12:47'! - initializeOf: anExtractToTemporary - - refactoring := anExtractToTemporary. - nodesToReplace := OrderedCollection new.! ! -!ParseNodeToReplaceFinder methodsFor: 'visiting' stamp: 'HAW 10/19/2017 06:02:34'! - visitBlockNode: aBlockNode - - | previousBlock | - - previousBlock := currentBlock. - currentBlock := aBlockNode. - - aBlockNode statements withIndexDo: [:statement :index | - currentStatementIndex := index. - statement accept: self]. - - currentBlock := previousBlock ! ! -!ParseNodeToReplaceFinder methodsFor: 'visiting' stamp: 'HAW 10/18/2017 18:12:47'! - visitLiteralNode: aLiteralNode - - (refactoring shouldExtract: aLiteralNode) ifTrue: [ self addNodeToReplace: aLiteralNode ]! ! -!ParseNodeToReplaceFinder methodsFor: 'visiting' stamp: 'HAW 10/19/2017 06:20:02'! - visitMessageNode: aMessageNode - - super visitMessageNode: aMessageNode! ! -!ParseNodeToReplaceFinder class methodsFor: 'instance creation' stamp: 'HAW 10/18/2017 18:12:47'! - of: anExtractToTemporary - - ^self new initializeOf: anExtractToTemporary ! ! -!ChangeSelectorWizardStepWindow methodsFor: 'actions' stamp: 'HAW 5/31/2017 17:26:05'! - add - - self subclassResponsibility ! ! -!ChangeSelectorWizardStepWindow methodsFor: 'actions' stamp: 'HAW 5/31/2017 17:36:12'! - addToList: aMethod - - model addMethodReference: aMethod methodReference ifIncluded: [ self inform: 'Method already in list' ]! ! -!ChangeSelectorWizardStepWindow methodsFor: 'actions' stamp: 'HAW 10/9/2018 20:57:59'! - do: aBlock withEnteredClassLabeled: aLabel - - | className | - - className := ClassNameRequestMorph request: aLabel onCancel: [ ^self ]. - ^self withClassNamed: className do: aBlock! ! -!ChangeSelectorWizardStepWindow methodsFor: 'actions' stamp: 'HAW 5/31/2017 18:17:19'! - inform: aClass doesNotImplement: aSelector - - self inform: aClass name, ' does not implement #', aSelector ! ! -!ChangeSelectorWizardStepWindow methodsFor: 'actions' stamp: 'HAW 1/7/2019 11:02:43'! - justRefactor - - applier doNotShowChanges. - self refactor.! ! -!ChangeSelectorWizardStepWindow methodsFor: 'actions' stamp: 'HAW 1/7/2019 11:16:36'! - refactor - - applier wizardStepWindow: self. - applier wizardEnded. - ! ! -!ChangeSelectorWizardStepWindow methodsFor: 'actions' stamp: 'HAW 5/31/2017 17:07:19'! -remove - - model removeMessageFromBrowserKeepingLabel! ! -!ChangeSelectorWizardStepWindow methodsFor: 'actions' stamp: 'HAW 10/10/2018 05:46:24'! - withClassNamed: aName do: aBlock - - | trimmedNamed | - - trimmedNamed := aName withBlanksTrimmed. - - (Smalltalk classNamed: trimmedNamed asSymbol) - ifNotNil: aBlock - ifNil: [ self inform: 'Class ', trimmedNamed , ' does not exist' ]. -! ! -!ChangeSelectorWizardStepWindow methodsFor: 'GUI building' stamp: 'HAW 5/31/2017 17:22:39'! - addButton: button to: row color: buttonColor - - button color: buttonColor. - row addMorph: button proportionalWidth: 10! ! -!ChangeSelectorWizardStepWindow methodsFor: 'GUI building' stamp: 'HAW 5/31/2017 17:18:46'! - addButtonsTo: row color: buttonColor - - self subclassResponsibility ! ! -!ChangeSelectorWizardStepWindow methodsFor: 'GUI building' stamp: 'HAW 5/31/2017 17:26:55'! - buildLowerPanes - - | codeAndButtons | - - codeAndButtons _ LayoutMorph newColumn. - codeAndButtons - addMorph: self buttonsRow fixedHeight: self defaultButtonPaneHeight; - addAdjusterMorph; - addMorph: self buildMorphicCodePane proportionalHeight: 1.0. - - ^codeAndButtons ! ! -!ChangeSelectorWizardStepWindow methodsFor: 'GUI building' stamp: 'HAW 5/31/2017 17:27:25'! - buttonsRow - - | buttonColor row | - - buttonColor := self buttonColor. - row := LayoutMorph newRow. - row doAdoptWidgetsColor. - row color: buttonColor. - - self addButtonsTo: row color: buttonColor. - - ^row - - ! ! -!ChangeSelectorWizardStepWindow methodsFor: 'compile methods' stamp: 'HAW 5/31/2017 17:08:14'! - compiledMethodsFrom: methodReferences - - ^ methodReferences collect: [:aMethodReference | aMethodReference compiledMethod ]! ! -!ChangeSelectorWizardStepWindow methodsFor: 'button creation' stamp: 'HAW 5/31/2017 17:21:11'! - createAddButton - - ^PluggableButtonMorph - model: self - stateGetter: nil - action: #add - label: 'Add'. -! ! -!ChangeSelectorWizardStepWindow methodsFor: 'button creation' stamp: 'HAW 5/31/2017 17:21:19'! - createCancelButton - - ^PluggableButtonMorph - model: self - stateGetter: nil - action: #delete - label: 'Cancel'. -! ! -!ChangeSelectorWizardStepWindow methodsFor: 'button creation' stamp: 'HAW 10/10/2018 19:47:37'! - createJustRefactorButton - - ^PluggableButtonMorph - model: self - stateGetter: nil - action: #justRefactor - label: 'Just Refactor!!'! ! -!ChangeSelectorWizardStepWindow methodsFor: 'button creation' stamp: 'HAW 10/10/2018 19:47:43'! - createRefactorButton - - ^PluggableButtonMorph - model: self - stateGetter: nil - action: #refactor - label: 'Refactor'! ! -!ChangeSelectorWizardStepWindow methodsFor: 'button creation' stamp: 'HAW 5/31/2017 17:16:37'! - createRemoveButton - - ^PluggableButtonMorph - model: self - stateGetter: #isMessageSelected - action: #remove - label: 'Remove'. -! ! -!ChangeSelectorWizardStepWindow methodsFor: 'initialization' stamp: 'HAW 1/7/2019 11:04:02'! - initializeFrom: aChangeSelectorApplier - - applier := aChangeSelectorApplier ! ! -!ChangeSelectorWizardStepWindow methodsFor: 'testing' stamp: 'HAW 6/5/2017 17:40:16'! - isMessageSelected - - ^model isNil ifTrue: [ false ] ifFalse: [ model selection notNil ]! ! -!ChangeSelectorWizardStepWindow methodsFor: 'accessing' stamp: 'HAW 1/7/2019 11:02:43'! - oldSelector - - ^applier oldSelector ! ! -!ChangeSelectorWizardStepWindow class methodsFor: 'instance creation' stamp: 'HAW 5/31/2017 16:59:25'! - methodReferencesOf: methods - - ^methods asOrderedCollection collect: [:aCompiledMethod | aCompiledMethod methodReference ]. -! ! -!ChangeSelectorWizardStepWindow class methodsFor: 'instance creation' stamp: 'HAW 1/7/2019 11:03:50'! - openFrom: aChangeSelectorApplier methods: methods label: aLabel - - | window | - - window := self openMessageList: (self methodReferencesOf: methods) label: aLabel autoSelect: aChangeSelectorApplier oldSelector. - window initializeFrom: aChangeSelectorApplier. - - ^window - -! ! -!ChangeSelectorImplementorsStepWindow methodsFor: 'actions' stamp: 'HAW 6/5/2017 17:33:16'! - add - - self - do: [ :classOfImplementorToAdd | self addImplementorIn: classOfImplementorToAdd ] - withEnteredClassLabeled: 'Class that implements ', self oldSelector ! ! -!ChangeSelectorImplementorsStepWindow methodsFor: 'actions' stamp: 'HAW 6/5/2017 17:33:26'! - addImplementorIn: classOfImplementorToAdd - - | implementorToAdd | - - implementorToAdd := classOfImplementorToAdd - compiledMethodAt: self oldSelector - ifAbsent: [ ^self inform: classOfImplementorToAdd doesNotImplement: self oldSelector ]. - - self addToList: implementorToAdd! ! -!ChangeSelectorImplementorsStepWindow methodsFor: 'actions' stamp: 'HAW 1/7/2019 11:02:43'! - changeImplementors - - applier implementors: (self compiledMethodsFrom: model messageList). - ! ! -!ChangeSelectorImplementorsStepWindow methodsFor: 'actions' stamp: 'HAW 10/10/2018 18:07:57'! - refactor - - self changeImplementors. - super refactor ! ! -!ChangeSelectorImplementorsStepWindow methodsFor: 'actions' stamp: 'HAW 1/7/2019 11:17:47'! - seeSenders - - self changeImplementors. - self delete. - - ChangeSelectorSendersStepWindow openFrom: applier ! ! -!ChangeSelectorImplementorsStepWindow methodsFor: 'GUI building' stamp: 'HAW 10/10/2018 19:55:34'! - addButtonsTo: row color: buttonColor - - self addButton: self createRemoveButton to: row color: buttonColor. - self addButton: self createAddButton to: row color: buttonColor. - self addButton: self createSeeSendersButton to: row color: buttonColor. - self addButton: self createRefactorButton to: row color: buttonColor. - self addButton: self createJustRefactorButton to: row color: buttonColor. - self addButton: self createCancelButton to: row color: buttonColor. -! ! -!ChangeSelectorImplementorsStepWindow methodsFor: 'button creation' stamp: 'HAW 10/10/2018 19:55:52'! - createSeeSendersButton - - ^PluggableButtonMorph - model: self - stateGetter: nil - action: #seeSenders - label: 'See Senders'. - -! ! -!ChangeSelectorImplementorsStepWindow class methodsFor: 'instance creation' stamp: 'HAW 8/18/2018 17:26:33'! - openFrom: aChangeSelectorRequest - - ^self - openFrom: aChangeSelectorRequest - methods: aChangeSelectorRequest implementors - label: 'Implementors of #', aChangeSelectorRequest oldSelector, ' to Refactor' -! ! -!ChangeSelectorSendersStepWindow methodsFor: 'actions' stamp: 'HAW 6/5/2017 17:36:00'! - add - - self - do: [ :classOfSenderToAdd | self askAndAddSenderOf: classOfSenderToAdd ] - withEnteredClassLabeled: 'Class that sends #', self oldSelector - ! ! -!ChangeSelectorSendersStepWindow methodsFor: 'actions' stamp: 'HAW 11/8/2018 15:25:57'! - askAndAddSenderOf: classOfSenderToAdd - - | senderSelector senderToAdd | - - senderSelector := FillInTheBlankMorph request: 'Selector of sender of #', self oldSelector onCancel: [^self ]. - senderToAdd := classOfSenderToAdd - compiledMethodAt: senderSelector asSymbol - ifAbsent: [ ^self inform: classOfSenderToAdd doesNotImplement: senderSelector asSymbol]. - - (senderToAdd sendsOrRefersTo: self oldSelector) ifFalse: [ ^self inform: senderToAdd classAndSelector, ' does not refer to #', self oldSelector ]. - - self addToList: senderToAdd ! ! -!ChangeSelectorSendersStepWindow methodsFor: 'actions' stamp: 'HAW 1/7/2019 11:02:43'! - changeRequestSenders - - applier senders: (self compiledMethodsFrom: model messageList). - ! ! -!ChangeSelectorSendersStepWindow methodsFor: 'actions' stamp: 'HAW 10/10/2018 18:09:18'! - refactor - - self changeRequestSenders. - super refactor ! ! -!ChangeSelectorSendersStepWindow methodsFor: 'actions' stamp: 'HAW 1/7/2019 11:17:34'! - seeImplementors - - self changeRequestSenders. - self delete. - - ChangeSelectorImplementorsStepWindow openFrom: applier! ! -!ChangeSelectorSendersStepWindow methodsFor: 'GUI building' stamp: 'HAW 10/10/2018 19:56:45'! - addButtonsTo: row color: buttonColor - - self addButton: self createRemoveButton to: row color: buttonColor. - self addButton: self createAddButton to: row color: buttonColor. - self addButton: self createSeeImplementorsButton to: row color: buttonColor. - self addButton: self createRefactorButton to: row color: buttonColor. - self addButton: self createJustRefactorButton to: row color: buttonColor. - self addButton: self createCancelButton to: row color: buttonColor. -! ! -!ChangeSelectorSendersStepWindow methodsFor: 'button creation' stamp: 'HAW 10/10/2018 19:56:51'! - createSeeImplementorsButton - - ^PluggableButtonMorph - model: self - stateGetter: nil - action: #seeImplementors - label: 'See Implementors'. -! ! -!ChangeSelectorSendersStepWindow class methodsFor: 'instance creation' stamp: 'HAW 8/18/2018 17:26:18'! - openFrom: aChangeSelectorRequest - - ^self - openFrom: aChangeSelectorRequest - methods: aChangeSelectorRequest senders - label: 'Senders of #', aChangeSelectorRequest oldSelector, ' to Refactor' ! ! -!Refactoring methodsFor: 'applying' stamp: 'HAW 5/24/2017 21:08:11'! - apply - - self subclassResponsibility ! ! -!Refactoring class methodsFor: 'exceptions' stamp: 'HAW 8/17/2018 16:34:16'! - canNotRefactorDueToReferencesError: aMessageText references: references to: referencee - - ^self canNotRefactorDueToReferencesErrorClass - signal: aMessageText - references: references - to: referencee ! ! -!Refactoring class methodsFor: 'exceptions' stamp: 'HAW 8/17/2018 16:32:42'! - canNotRefactorDueToReferencesErrorClass - - ^CanNotRefactorDueToReferencesError! ! -!Refactoring class methodsFor: 'exceptions' stamp: 'HAW 6/3/2017 11:58:07'! - refactoringError: aMessage - - self refactoringErrorClass signal: aMessage.! ! -!Refactoring class methodsFor: 'exceptions' stamp: 'HAW 6/3/2017 11:58:21'! - refactoringErrorClass - - ^ RefactoringError.! ! -!Refactoring class methodsFor: 'warnings' stamp: 'HAW 6/11/2017 18:49:41'! - refactoringWarning: aMessageText - - ^ self refactoringWarningClass signal: aMessageText.! ! -!Refactoring class methodsFor: 'warnings' stamp: 'HAW 6/3/2017 12:05:48'! - refactoringWarningClass - - ^ RefactoringWarning.! ! -!AddInstanceVariable methodsFor: 'applying' stamp: 'HAW 6/11/2017 18:27:26'! -apply - - classToRefactor addInstVarName: newVariable. - ! ! -!AddInstanceVariable methodsFor: 'accessing' stamp: 'HAW 6/11/2017 19:09:54'! - classToRefactor - - ^classToRefactor ! ! -!AddInstanceVariable methodsFor: 'accessing' stamp: 'HAW 6/6/2017 10:10:40'! - newVariable - - ^newVariable ! ! -!AddInstanceVariable methodsFor: 'initialization' stamp: 'HAW 6/6/2017 10:10:26'! - initializeNamed: aNewVariable to: aClassToRefactor - - newVariable := aNewVariable. - classToRefactor := aClassToRefactor ! ! -!AddInstanceVariable class methodsFor: 'instance creation' stamp: 'HAW 3/4/2019 11:43:12'! - named: aVariable to: aClassToRefactor - - | trimmedVariable | - - trimmedVariable := aVariable withBlanksTrimmed. - NewInstanceVariablePrecondition valueOf: trimmedVariable for: aClassToRefactor. - ^self new initializeNamed: trimmedVariable to: aClassToRefactor - ! ! -!ChangeSelector methodsFor: 'applying' stamp: 'HAW 11/29/2018 15:19:19'! - apply - - self - createNewImplementors; - renameSenders; - removeOldImplementors. - - ^changes -! ! -!ChangeSelector methodsFor: 'remove old implementors - private' stamp: 'HAW 8/18/2018 12:02:34'! - removeOldImplementor: anImplementor - - anImplementor methodClass removeSelector: anImplementor selector. - changes add: anImplementor methodReference! ! -!ChangeSelector methodsFor: 'remove old implementors - private' stamp: 'HAW 8/18/2018 12:01:49'! - removeOldImplementors - - implementors do: [:anImplementor | self removeOldImplementor: anImplementor ]! ! -!ChangeSelector methodsFor: 'create new implementors - private' stamp: 'HAW 11/8/2018 15:24:06'! - addToSendersIfOldSelectorIsSentIn: newImplementor - - (newImplementor sendsOrRefersTo: oldSelector) ifTrue: [ senders add: newImplementor ]. - ! ! -!ChangeSelector methodsFor: 'create new implementors - private' stamp: 'HAW 3/4/2019 15:24:22'! - compileNewImplementorOf: anImplementor - - | implementorClassification newSourceCode | - - newSourceCode := self implementorNewSourceCodeOf: anImplementor. - implementorClassification := anImplementor methodClass organization categoryOfElement: oldSelector. - - anImplementor methodClass - compile: newSourceCode - classified: implementorClassification. -! ! -!ChangeSelector methodsFor: 'create new implementors - private' stamp: 'HAW 8/18/2018 12:02:25'! - createNewImplementorOf: anImplementor - - | newImplementor | - - self compileNewImplementorOf: anImplementor. - newImplementor := anImplementor methodClass compiledMethodAt: newSelector. - self addToSendersIfOldSelectorIsSentIn: newImplementor. - - changes add: newImplementor methodReference - - ! ! -!ChangeSelector methodsFor: 'create new implementors - private' stamp: 'HAW 8/18/2018 12:02:52'! - createNewImplementors - - implementors do: [:anImplementor | self createNewImplementorOf: anImplementor ] - ! ! -!ChangeSelector methodsFor: 'create new implementors - private' stamp: 'HAW 8/18/2018 12:06:01'! - implementorNewSourceCodeOf: anImplementor - - self subclassResponsibility ! ! -!ChangeSelector methodsFor: 'rename senders - private' stamp: 'HAW 11/29/2018 15:28:39'! - add: oldSelectorLiteralRanges to: rangesToKeywords - - oldSelectorLiteralRanges do: [ :oldSelectorLiteralRange | - rangesToKeywords add: (oldSelectorLiteralRange first + 1 to: oldSelectorLiteralRange last) -> newSelector ]. - - - ! ! -!ChangeSelector methodsFor: 'rename senders - private' stamp: 'HAW 8/18/2018 12:05:39'! - addMessageSendSelectorKeywordRangesOf: aMethodNode to: rangesToKeywords - - self subclassResponsibility ! ! -!ChangeSelector methodsFor: 'rename senders - private' stamp: 'HAW 11/29/2018 15:29:06'! - addRangesForLiteralInLiteralArrayOf: methodNode to: rangesToKeywords - - | oldSelectorLiteralRanges | - - oldSelectorLiteralRanges := methodNode positionsInLiteralArrayOf: oldSelector. - self add: oldSelectorLiteralRanges to: rangesToKeywords ! ! -!ChangeSelector methodsFor: 'rename senders - private' stamp: 'HAW 11/29/2018 15:28:27'! - addRangesForLiteralOf: methodNode to: rangesToKeywords - - | oldSelectorLiteralRanges | - - oldSelectorLiteralRanges := methodNode positionsForLiteralNode: oldSelector ifAbsent: [ ^#() ]. - self add: oldSelectorLiteralRanges to: rangesToKeywords. - ! ! -!ChangeSelector methodsFor: 'rename senders - private' stamp: 'HAW 11/29/2018 14:16:42'! - rangesToKeywordsOf: aMethod - - | methodNode rangesToKeywords | - - methodNode := aMethod methodNode. - rangesToKeywords := SortedCollection sortBlock: [ :left :right | left key first < right key first ]. - - self addMessageSendSelectorKeywordRangesOf: methodNode to: rangesToKeywords. - self addRangesForLiteralOf: methodNode to: rangesToKeywords. - self addRangesForLiteralInLiteralArrayOf: methodNode to: rangesToKeywords. - - ^rangesToKeywords ! ! -!ChangeSelector methodsFor: 'rename senders - private' stamp: 'HAW 8/18/2018 12:03:19'! - renameSenders - - senders do: [ :aSender | self renameSendersIn: aSender ]. - ! ! -!ChangeSelector methodsFor: 'rename senders - private' stamp: 'HAW 9/4/2018 19:25:20'! - renameSendersIn: aMethod - - | newSource rangesToNewStrings | - - rangesToNewStrings := self rangesToKeywordsOf: aMethod. - newSource := aMethod sourceCode copyReplacing: rangesToNewStrings. - aMethod methodClass compile: newSource. - - changes add: (MethodReference class: aMethod methodClass selector: aMethod selector)! ! -!ChangeSelector methodsFor: 'implementors/senders' stamp: 'HAW 8/18/2018 12:04:37'! - implementorsSize - - ^implementors size! ! -!ChangeSelector methodsFor: 'implementors/senders' stamp: 'HAW 8/18/2018 12:03:31'! - sendersSize - - ^senders size! ! -!ChangeSelector methodsFor: 'initialization' stamp: 'HAW 9/3/2018 17:17:19'! - initializeFrom: anOldSelector to: aNewSelector implementors: aCollectionOfImplementors senders: aCollectionOfSenders - - oldSelector := anOldSelector. - newSelector := aNewSelector. - implementors := aCollectionOfImplementors. - "I have to make a copy of senders because it can change with recursive implementors - Hernan" - senders := aCollectionOfSenders asOrderedCollection. - - changes := Set new - ! ! -!ChangeSelector methodsFor: 'selectors' stamp: 'HAW 1/7/2019 13:59:37'! - newSelector - - ^newSelector ! ! -!ChangeSelector class methodsFor: 'pre-conditions' stamp: 'HAW 8/18/2018 12:39:40'! - assertAllImplementors: implementors haveSame: aSelector - - | invalidImplementors | - - invalidImplementors := implementors reject: [ :anImplementor | anImplementor selector = aSelector ]. - invalidImplementors notEmpty ifTrue: [ self signalInvalidImplementors: invalidImplementors ].! ! -!ChangeSelector class methodsFor: 'pre-conditions' stamp: 'HAW 11/29/2018 12:04:20'! - assertAllSenders: senders send: aSelector - - | invalidSenders | - - invalidSenders := senders reject: [ :aSender | aSender sendsOrRefersTo: aSelector ]. - invalidSenders notEmpty ifTrue: [ self signalInvalidSenders: invalidSenders of: aSelector ]! ! -!ChangeSelector class methodsFor: 'exceptions' stamp: 'HAW 1/7/2019 10:51:35'! - errorMessageForInvalidImplementors: aCollectionOfInvalidImplementors - - ^String streamContents: [ :stream | - stream - nextPutAll: (aCollectionOfInvalidImplementors size = 1 ifTrue: [ 'This method' ] ifFalse: [ 'These methods']); - nextPutAll: ' do not have same the same selector to rename: '. - aCollectionOfInvalidImplementors asCommaSeparated: [:anImplementor | anImplementor printClassAndSelectorOn: stream ] on: stream ] ! ! -!ChangeSelector class methodsFor: 'exceptions' stamp: 'HAW 1/7/2019 10:51:35'! - errorMessageForInvalidSenders: aCollectionOfInvalidSenders of: anOldSelector - - ^String streamContents: [ :stream | - stream - nextPutAll: 'Message #'; - nextPutAll: anOldSelector; - nextPutAll: ' is not send by: '. - aCollectionOfInvalidSenders asCommaSeparated: [:aSender | aSender printClassAndSelectorOn: stream ] on: stream ] ! ! -!ChangeSelector class methodsFor: 'exceptions' stamp: 'HAW 8/18/2018 12:43:59'! - signalInvalidImplementors: invalidImplementors - - self refactoringError: (self errorMessageForInvalidImplementors: invalidImplementors).! ! -!ChangeSelector class methodsFor: 'exceptions' stamp: 'HAW 8/18/2018 15:49:58'! - signalInvalidSenders: invalidSender of: aSelector - - self refactoringError: (self errorMessageForInvalidSenders: invalidSender of: aSelector).! ! -!ChangeSelector class methodsFor: 'implementors and senders' stamp: 'HAW 8/18/2018 17:19:35'! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders forClassAndMetaOf: aPotentialClassToRefactor - - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders of: aPotentialClassToRefactor theNonMetaClass. - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders of: aPotentialClassToRefactor theMetaClass. - -! ! -!ChangeSelector class methodsFor: 'implementors and senders' stamp: 'HAW 8/18/2018 17:19:39'! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategoriesAndHierarchyOf: aClass organizedBy: anOrganization - - | categories | - - categories := Set new. - - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inHierarchyOf: aClass doingPerClass: [:aClassInHierarchy | categories add: aClassInHierarchy category ]. - categories do: [:aCategory | self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategory: aCategory organizedBy: anOrganization ]. -! ! -!ChangeSelector class methodsFor: 'implementors and senders' stamp: 'HAW 8/18/2018 17:19:42'! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategory: aCategory organizedBy: anOrganization - - | classesInCategory | - - classesInCategory := anOrganization classesAt: aCategory. - classesInCategory do: [ :aPotentialClassToRefactor | self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders forClassAndMetaOf: aPotentialClassToRefactor ]. -! ! -!ChangeSelector class methodsFor: 'implementors and senders' stamp: 'HAW 8/18/2018 17:19:45'! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inHierarchyOf: aClass - - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inHierarchyOf: aClass doingPerClass: [ :aClassInHierarchy | ] - - ! ! -!ChangeSelector class methodsFor: 'implementors and senders' stamp: 'HAW 8/18/2018 17:19:49'! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inHierarchyOf: aClass doingPerClass: aBlock - - aClass theNonMetaClass withAllSubAndSuperclassesDo: [ :aPotentialClassToRefactor | - aPotentialClassToRefactor isMeta ifFalse: [ - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders forClassAndMetaOf: aPotentialClassToRefactor. - aBlock value: aPotentialClassToRefactor ]] - ! ! -!ChangeSelector class methodsFor: 'implementors and senders' stamp: 'HAW 8/18/2018 17:19:52'! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inSystem: aSystem - - aSystem allBehaviorsDo: [ :aPotentialClassToRefactor | - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders of: aPotentialClassToRefactor ]. -! ! -!ChangeSelector class methodsFor: 'implementors and senders' stamp: 'HAW 10/15/2018 20:53:23'! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders of: aPotentialClassToRefactor - - | potentialImplementor | - - potentialImplementor := aPotentialClassToRefactor compiledMethodAt: anOldSelector ifAbsent: [ nil ]. - potentialImplementor ifNotNil: [ implementors add: potentialImplementor ]. - - (aPotentialClassToRefactor whichSelectorsReferTo: anOldSelector) do: [ :aSelector | senders add: (aPotentialClassToRefactor compiledMethodAt: aSelector) ]. - ! ! -!AddParameter methodsFor: 'initialization' stamp: 'HAW 9/4/2018 19:00:42'! - initializedNamed: aNewParameter - at: anIndex - addingLast: anIsAddingLast - initializedWith: aNewParameterValue - to: anOldSelector - implementing: aNewSelector - addingToImplementors: anImplementorTrailingString - addingToSenders: aSenderTrailingString - implementors: implementorsCollection - senders: sendersCollection - - super initializeFrom: anOldSelector to: aNewSelector implementors: implementorsCollection senders: sendersCollection. - - newParameter := aNewParameter. - newParameterValue := aNewParameterValue. - implementorTrailingString := anImplementorTrailingString. - senderTrailingString := aSenderTrailingString. - - index := anIndex. - isAddingLast := anIsAddingLast ! ! -!AddParameter methodsFor: 'rename senders - private' stamp: 'HAW 3/4/2019 10:21:05'! - addMessageSendSelectorKeywordRangesOf: aMethodNode to: rangesToKeywords - - | insertionPoints senderSourceCode | - - senderSourceCode := aMethodNode sourceText. - isAddingLast - ifTrue: [ - insertionPoints := aMethodNode messageSendLastPositionsOf: oldSelector ifAbsent: [ #() ]. - insertionPoints do: [ :aPosition | | newPosition | - newPosition := self firstNoSeparatorIndexIn: senderSourceCode startingFrom: aPosition. - rangesToKeywords add: ((newPosition+1) to: newPosition) -> senderTrailingString ]] - ifFalse: [ - insertionPoints := aMethodNode messageSendKeywordPositionsAt: index of: oldSelector ifAbsent: [ #()]. - insertionPoints do: [ :aPosition | - rangesToKeywords add: (aPosition to: aPosition-1) -> senderTrailingString ]] - ! ! -!AddParameter methodsFor: 'rename senders - private' stamp: 'HAW 11/11/2018 14:07:23'! - firstNoLineSeparatorIndexIn: sourceCode startingFrom: aStartingPosition - - ^self firstNot: [ :aChar | aChar isLineSeparator ] indexIn: sourceCode startingFrom: aStartingPosition ! ! -!AddParameter methodsFor: 'rename senders - private' stamp: 'HAW 11/11/2018 14:06:46'! - firstNoSeparatorIndexIn: sourceCode startingFrom: aStartingPosition - - "Looks going back for the first no separator char. See #test24AddingParameterToSendersTakeCaresOfSeparators - It assumes that there is always going to be a no separator wich holds due to how aStartPosition is obtained - Hernan" - - ^self firstNot: [ :aChar | aChar isSeparator ] indexIn: sourceCode startingFrom: aStartingPosition ! ! -!AddParameter methodsFor: 'rename senders - private' stamp: 'HAW 1/7/2019 13:43:36'! - firstNot: aBlock indexIn: sourceCode startingFrom: aStartingPosition - - | noSeparatorIndex | - - noSeparatorIndex := aStartingPosition. - [ noSeparatorIndex > 0 and: [ aBlock value: (sourceCode at: noSeparatorIndex) ]] whileTrue: [ noSeparatorIndex := noSeparatorIndex - 1 ]. - - ^noSeparatorIndex - ! ! -!AddParameter methodsFor: 'create new implementors - private' stamp: 'HAW 11/11/2018 14:07:55'! - implementorNewSourceCodeOf: anImplementor - - | implementorMethodNode newSource originalSource insertionPoint | - - implementorMethodNode := anImplementor methodNode. - insertionPoint := isAddingLast - ifTrue: [ implementorMethodNode selectorLastPosition ] - ifFalse: [ (implementorMethodNode selectorKeywordPositionAt: index) first - 1]. - - originalSource := anImplementor sourceCode. - insertionPoint := self firstNoLineSeparatorIndexIn: originalSource startingFrom: insertionPoint. - - newSource := String streamContents: [ :newSourceStream | - newSourceStream - nextPutAll: (originalSource copyFrom: 1 to: insertionPoint); - nextPutAll: implementorTrailingString; - nextPutAll: (originalSource copyFrom: insertionPoint+1 to: originalSource size) ]. - - ^newSource! ! -!AddParameter class methodsFor: 'instance creation' stamp: 'HAW 9/4/2018 19:59:06'! - named: aNewParameter - at: anIndex - initializedWith: aNewParameterValue - using: aNewKeyword - toKeywordSelector: anOldSelector - implementors: implementorsCollection - senders: sendersCollection - - | validNewParameterValue isAddingLast numberOfParameters | - - self assertIsKeyword: anOldSelector. - self assertIsValidKeywordForNewParameter: aNewKeyword. - validNewParameterValue := self assertNewParameterValueIsValid: aNewParameterValue. - numberOfParameters := anOldSelector numArgs. - self assert: anIndex isValidIndexFor: numberOfParameters. - isAddingLast := anIndex > numberOfParameters. - - ^self - named: aNewParameter - at: anIndex - addingLast: isAddingLast - initializedWith: aNewParameterValue - to: anOldSelector - implementing: (self newSelectorAdding: aNewKeyword at: anIndex to: anOldSelector) - addingToImplementors: (self keywordImplementorTrailingFor: aNewKeyword and: aNewParameter addingLast: isAddingLast) - addingToSenders: (self keywordSenderTrailingFor: aNewKeyword and: validNewParameterValue addingLast: isAddingLast) - implementors: implementorsCollection - senders: sendersCollection -! ! -!AddParameter class methodsFor: 'instance creation' stamp: 'HAW 9/4/2018 19:32:45'! - named: aNewParameter - initializedWith: aNewParameterValue - toUnarySelector: anOldSelector - implementors: implementorsCollection - senders: sendersCollection - - | validNewParameterValue | - - self assertIsUnary: anOldSelector. - validNewParameterValue := self assertNewParameterValueIsValid: aNewParameterValue. - - ^self - named: aNewParameter - at: 1 - addingLast: true - initializedWith: aNewParameterValue - to: anOldSelector - implementing: (self newSelectorFromUnary: anOldSelector) - addingToImplementors: (self unaryImplementorTrailingFor: aNewParameter) - addingToSenders: (self unarySenderTrailingFor: validNewParameterValue) - implementors: implementorsCollection - senders: sendersCollection -! ! -!AddParameter class methodsFor: 'instance creation' stamp: 'HAW 9/4/2018 17:26:10'! - named: aNewParameter - initializedWith: aNewParameterValue - using: aNewKeyword - toKeywordSelector: anOldSelector - implementors: implementorsCollection - senders: sendersCollection - - ^self - named: aNewParameter - at: anOldSelector numArgs + 1 - initializedWith: aNewParameterValue - using: aNewKeyword - toKeywordSelector: anOldSelector - implementors: implementorsCollection - senders: sendersCollection -! ! -!AddParameter class methodsFor: 'instance creation - private' stamp: 'HAW 9/4/2018 19:05:41'! -keywordImplementorTrailingFor: aNewKeyword and: aNewParameter addingLast: isAddingLast - - ^String streamContents: [ :stream | - isAddingLast ifTrue: [ stream space ]. - stream - nextPutAll: aNewKeyword; - space; - nextPutAll: aNewParameter; - space ]! ! -!AddParameter class methodsFor: 'instance creation - private' stamp: 'HAW 9/4/2018 19:23:31'! - keywordSenderTrailingFor: aNewKeyword and: aNewParameterValue addingLast: isAddingLast - - ^String streamContents: [ :stream | - isAddingLast ifTrue: [ stream space ]. - stream - nextPutAll: aNewKeyword; - space; - nextPutAll: aNewParameterValue. - isAddingLast ifFalse: [ stream space ] ] - - ! ! -!AddParameter class methodsFor: 'instance creation - private' stamp: 'HAW 9/4/2018 19:00:16'! - named: aNewParameter - at: anIndex - addingLast: isAddingLast - initializedWith: aNewParameterValue - to: anOldSelector - implementing: aNewSelector - addingToImplementors: implementorTrailingString - addingToSenders: senderTrailingString - implementors: implementorsCollection - senders: sendersCollection - - | trimmedNewParameter | - - trimmedNewParameter := aNewParameter withBlanksTrimmed. - - self assertCanAddParameterTo: anOldSelector. - self assertIsValidParameterName: trimmedNewParameter. - self assertNewParameter: trimmedNewParameter isNotDefinedAsInstanceVariableInAny: implementorsCollection. - self assertNewParameter: trimmedNewParameter isNotDefinedAsLocalInAny: implementorsCollection. - self assertAllImplementors: implementorsCollection haveSame: anOldSelector. - self assertAllSenders: sendersCollection send: anOldSelector. - - ^ self new - initializedNamed: trimmedNewParameter - at: anIndex - addingLast: isAddingLast - initializedWith: aNewParameterValue - to: anOldSelector - implementing: aNewSelector - addingToImplementors: implementorTrailingString - addingToSenders: senderTrailingString - implementors: implementorsCollection - senders: sendersCollection -! ! -!AddParameter class methodsFor: 'instance creation - private' stamp: 'HAW 9/4/2018 21:32:44'! - newSelectorAdding: aNewKeyword at: anIndex to: anOldSelector - - | keywords | - - keywords := anOldSelector keywords asOrderedCollection. - keywords add: aNewKeyword beforeIndex: anIndex. - - ^Symbol fromCollectionOfStrings: keywords. - - ! ! -!AddParameter class methodsFor: 'instance creation - private' stamp: 'HAW 8/18/2018 12:14:00'! - newSelectorFromUnary: anOldSelector - - ^(anOldSelector, ':') asSymbol! ! -!AddParameter class methodsFor: 'instance creation - private' stamp: 'HAW 8/18/2018 12:15:49'! - unaryImplementorTrailingFor: aNewParameter - - ^ ': ', aNewParameter! ! -!AddParameter class methodsFor: 'instance creation - private' stamp: 'HAW 8/18/2018 12:16:32'! - unarySenderTrailingFor: aNewParameterValue - - ^ ': ', aNewParameterValue! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 8/25/2018 11:34:59'! - addParenthesisTo: trimmedNewParameterValue ifNewParameterValueIsKeywordMessage: newParameterValueMethodNode - - | newParameterNode | - - newParameterNode := newParameterValueMethodNode block statements first expr. - - ^ (self hasToAddParenthesisBasedOn: newParameterNode) - ifTrue: [ '(', trimmedNewParameterValue, ')' ] - ifFalse: [ trimmedNewParameterValue ] - ! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/4/2018 20:08:37'! - assert: anIndex isValidIndexFor: aNumberOfParameters - - (anIndex isInteger and: [ (anIndex between: 1 and: aNumberOfParameters + 1)]) ifFalse: [ self signalInvalidParameterIndex: anIndex for: aNumberOfParameters ]! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 8/18/2018 16:02:12'! - assertCanAddParameterTo: aSelector - - aSelector isInfix ifTrue: [ self signalSelectorCanNotBeBinary]! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 8/18/2018 12:29:54'! - assertIsKeyword: aSelector - - aSelector isKeyword ifFalse: [ self signalSelectorMustBeKeyword]! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 8/18/2018 12:23:04'! - assertIsUnary: aSelector - - aSelector isUnary ifFalse: [ self signalSelectorMustBeUnary]! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 8/18/2018 16:30:01'! - assertIsValidKeywordForNewParameter: aNewKeyword - - (aNewKeyword isKeyword and: [aNewKeyword numArgs = 1 ]) ifFalse: [ self signalNotValidKeywordForNewParameter]! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 8/17/2018 12:30:40'! - assertIsValidParameterName: aName - - | scannedNames | - - scannedNames _ Scanner new scanFieldNames: aName. - scannedNames size = 1 ifFalse: [ self signalInvalidParameterName: aName ]. - scannedNames first = aName ifFalse: [ self signalInvalidParameterName: aName ]. -! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 8/17/2018 16:59:29'! - assertNewParameter: aNewParameter isNotDefinedAsInstanceVariableInAny: implementors - - | classesDefiningInsVars | - - classesDefiningInsVars := self classesDefiningInstanceVariable: aNewParameter inAny: implementors. - classesDefiningInsVars notEmpty ifTrue: [ self signalNewParameter: aNewParameter definedAsInstanceVariableIn: classesDefiningInsVars ]! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 8/17/2018 16:59:47'! - assertNewParameter: aNewParameter isNotDefinedAsLocalInAny: implementors - - | implementorsDefiningNewParameterAsLocal | - - implementorsDefiningNewParameterAsLocal := implementors select: [ :implementor | implementor methodNode hasLocalNamed: aNewParameter ]. - implementorsDefiningNewParameterAsLocal notEmpty ifTrue: [ - self signalNewParameter: aNewParameter isDefinedAsLocalIn: implementorsDefiningNewParameterAsLocal ]! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 8/25/2018 11:30:18'! - assertNewParameterValueCompiles: trimmedNewParameterValue - - ^ [ Parser new parse: trimmedNewParameterValue readStream class: self noPattern: true notifying: nil ifFail: [nil] ] - on: SyntaxErrorNotification - do: [ :error | self signalNewParameterValueDoesNotCompile ].! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 8/25/2018 11:31:42'! - assertNewParameterValueDoesNotHaveMoreThanOneStatement: newParameterValueMethodNode - - newParameterValueMethodNode block statements size = 1 ifFalse: [ self signalNewParameterValueCanNotHaveMoreThanOneStatement ]. - ! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 8/17/2018 12:21:40'! - assertNewParameterValueIsNotEmpty: aNewParameterValue - - aNewParameterValue withBlanksTrimmed isEmpty ifTrue: [ self signalNewParameterValueCanNotBeEmpty]! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 8/25/2018 11:33:38'! - assertNewParameterValueIsValid: aNewParameterValue - - | newParameterValueMethodNode trimmedNewParameterValue | - - trimmedNewParameterValue := aNewParameterValue withBlanksTrimmed. - self assertNewParameterValueIsNotEmpty: trimmedNewParameterValue. - - newParameterValueMethodNode := self assertNewParameterValueCompiles: trimmedNewParameterValue. - self assertNewParameterValueDoesNotHaveMoreThanOneStatement: newParameterValueMethodNode. - - ^self addParenthesisTo: trimmedNewParameterValue ifNewParameterValueIsKeywordMessage: newParameterValueMethodNode. - ! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 8/25/2018 11:35:10'! - hasToAddParenthesisBasedOn: newParameterNode - - ^ newParameterNode isMessageNode and: [ newParameterNode selector key isKeyword ]! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/17/2018 15:05:29'! - classesDefiningInstanceVariable: aName inAny: implementors - - ^ implementors - inject: Set new - into: [ :classesDefiningInstVar :implementor | - (implementor methodClass whichClassDefinesInstanceVariable: aName ifNone: [ nil ]) ifNotNil: [ :classDefiningInstVar | - classesDefiningInstVar add: classDefiningInstVar ]. - classesDefiningInstVar ] -! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 9/4/2018 20:03:25'! - errorMessageForInvalidParameterIndex: anIndex for: aNumberOfParameters - - ^anIndex printString, ' is an invalid insertion index. It has to be between 1 and ', (aNumberOfParameters + 1) printString! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/17/2018 12:31:35'! - errorMessageForInvalidParameterName: aName - - ^ '''' , aName , ''' is not a valid parameter name'.! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/17/2018 15:18:46'! - errorMessageForNewParameter: aNewParameter definedAsInstanceVariableIn: definingClasses - - ^ String streamContents: [ :messageStream | - messageStream - nextPutAll: definingClasses asCommaStringAnd; - space; - nextPutAll: (definingClasses size = 1 ifTrue: [ 'defines' ] ifFalse: [ 'define' ]); - space; - nextPutAll: aNewParameter; - nextPutAll: ' as instance variable' ]! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 9/2/2018 19:59:27'! - errorMessageForNewParameterDefinedAsLocal: aNewParameter - - ^ aNewParameter, ' is already defined as parameter or temporary'! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/17/2018 12:22:31'! - newParameterValueCanNotBeEmptyErrorMessage - - ^'New parameter value can not be empty'! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/25/2018 11:26:54'! - newParameterValueCanNotHaveMoreThanOneStatementErrorMessage - - ^'New parameter value can not have more than one statement'! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/17/2018 12:24:53'! - newParameterValueDoesNotCompileErrorMessage - - ^'New parameter value code does not compile'! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/18/2018 16:31:03'! - notValidKeywordForNewParameterErrorMessage - - ^'New keyword must be of keyword type with one parameter'! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 12/13/2018 17:46:33'! - selectorCanNotBeBinaryErrorMessage - - ^'Can not add parameter to a binary selector. -Rename it to a keyword message first.'! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/18/2018 12:26:46'! - selectorMustBeKeywordErrorMessage - - ^'Selector must be of keyword type'! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/18/2018 12:23:47'! - selectorMustBeUnaryErrorMessage - - ^'Selector must be unary'! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 9/4/2018 20:02:24'! - signalInvalidParameterIndex: anIndex for: aNumberOfParameters - - self refactoringError: (self errorMessageForInvalidParameterIndex: anIndex for: aNumberOfParameters)! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/17/2018 12:31:15'! - signalInvalidParameterName: aName - - self refactoringError: (self errorMessageForInvalidParameterName: aName) - -! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/17/2018 15:11:03'! -signalNewParameter: aNewParameter definedAsInstanceVariableIn: definingClasses - - self refactoringError: (self errorMessageForNewParameter: aNewParameter definedAsInstanceVariableIn: definingClasses)! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 9/2/2018 19:59:27'! - signalNewParameter: aNewParameter isDefinedAsLocalIn: implementors - - self - canNotRefactorDueToReferencesError: (self errorMessageForNewParameterDefinedAsLocal: aNewParameter) - references: (implementors collect: [ :implementor | MethodReference method: implementor ]) - to: aNewParameter - ! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/17/2018 12:22:07'! - signalNewParameterValueCanNotBeEmpty - - self refactoringError: self newParameterValueCanNotBeEmptyErrorMessage! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/25/2018 11:27:05'! -signalNewParameterValueCanNotHaveMoreThanOneStatement - - self refactoringError: self newParameterValueCanNotHaveMoreThanOneStatementErrorMessage! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/17/2018 12:24:53'! - signalNewParameterValueDoesNotCompile - - self refactoringError: self newParameterValueDoesNotCompileErrorMessage! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/18/2018 16:25:55'! - signalNotValidKeywordForNewParameter - - self refactoringError: self notValidKeywordForNewParameterErrorMessage! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/18/2018 12:35:05'! -signalSelectorCanNotBeBinary - - self refactoringError: self selectorCanNotBeBinaryErrorMessage! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/18/2018 12:29:54'! - signalSelectorMustBeKeyword - - self refactoringError: self selectorMustBeKeywordErrorMessage! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/18/2018 12:23:26'! - signalSelectorMustBeUnary - - self refactoringError: self selectorMustBeUnaryErrorMessage! ! -!RemoveParameter methodsFor: 'initialization' stamp: 'HAW 9/4/2018 14:31:23'! - initializeNamed: aParameterToRemove - ofKeywordAtIndex: aParameterIndex - from: anOldSelector - creating: aNewSelector - implementors: implementorsCollection - senders: sendersCollection - - super initializeFrom: anOldSelector to: aNewSelector implementors: implementorsCollection senders: sendersCollection. - - parameterToRemove := aParameterToRemove. - parameterIndex := aParameterIndex. - senderReplacementString := newSelector isUnary ifTrue: [ newSelector asString ] ifFalse: [ '' ]. - isLastParameter := oldSelector numArgs = parameterIndex - ! ! -!RemoveParameter methodsFor: 'create new implementors - private' stamp: 'HAW 9/4/2018 14:42:51'! - implementorNewSourceCodeOf: anImplementor - - | implementorMethodNode newSource originalSource parameterToRemovePosition selectorToRemovePosition | - - implementorMethodNode := anImplementor methodNode. - selectorToRemovePosition := implementorMethodNode selectorKeywordPositionAt: parameterIndex. - parameterToRemovePosition := implementorMethodNode parameterDefinitionPositionAt: parameterIndex. - - originalSource := anImplementor sourceCode. - newSource := String streamContents: [ :newSourceStream | - self writeBeforeKeywordIn: newSourceStream from: originalSource removing: selectorToRemovePosition. - self writeAfterParameterIn: newSourceStream from: originalSource removing: parameterToRemovePosition ]. - - ^newSource! ! -!RemoveParameter methodsFor: 'create new implementors - private' stamp: 'HAW 9/4/2018 14:42:51'! - writeAfterParameterIn: newSourceStream from: originalSource removing: parameterToRemovePosition - - | afterParameterPosition | - - afterParameterPosition := parameterToRemovePosition last. - isLastParameter ifFalse: [ afterParameterPosition := self lastSeparatorIndexIn: originalSource startingFrom: afterParameterPosition ]. - - newSourceStream nextPutAll: (originalSource copyFrom: afterParameterPosition + 1 to: originalSource size) ! ! -!RemoveParameter methodsFor: 'create new implementors - private' stamp: 'HAW 9/4/2018 14:35:27'! - writeBeforeKeywordIn: newSourceStream from: originalSource removing: selectorToRemovePosition - - newSelector isUnary - ifTrue: [ newSourceStream nextPutAll: newSelector ] - ifFalse: [ newSourceStream nextPutAll: (originalSource copyFrom: 1 to: selectorToRemovePosition first - 1) ]. -! ! -!RemoveParameter methodsFor: 'rename senders - private' stamp: 'HAW 9/4/2018 17:42:53'! - addMessageSendSelectorKeywordRangesOf: aMethodNode to: rangesToKeywords - - | keywordAndParameterPositions senderSourceCode | - - senderSourceCode := aMethodNode sourceText. - keywordAndParameterPositions := aMethodNode messageSendKeywordAndParameterPositionsAt: parameterIndex of: oldSelector ifAbsent: [ #() ]. - keywordAndParameterPositions do: [ :aKeywordAndParameterPosition | | lastPosition | - lastPosition := self lastSeparatorIndexIn: senderSourceCode startingFrom: aKeywordAndParameterPosition last. - rangesToKeywords add: (aKeywordAndParameterPosition first to: lastPosition) -> senderReplacementString ] - ! ! -!RemoveParameter methodsFor: 'rename senders - private' stamp: 'HAW 9/4/2018 12:10:34'! - lastSeparatorIndexIn: senderSourceCode startingFrom: aPosition - - | lastPosition senderSourceCodeSize | - - lastPosition := aPosition. - senderSourceCodeSize := senderSourceCode size. - [ lastPosition := lastPosition + 1. - lastPosition <= senderSourceCodeSize and: [ (senderSourceCode at: lastPosition) isSeparator ]] whileTrue. - - ^lastPosition - 1! ! -!RemoveParameter class methodsFor: 'instance creation' stamp: 'HAW 9/4/2018 15:17:51'! - named: aParameterToRemove from: aMethod implementors: implementorsCollection senders: sendersCollection - - | oldSelector methodNode parameterIndex newSelector | - - oldSelector := aMethod selector. - self assertCanRemoveParameterFrom: oldSelector. - - methodNode := aMethod methodNode. - parameterIndex := self assert: aParameterToRemove isDefinedIn: methodNode. - self assertAllImplementors: implementorsCollection haveSame: oldSelector. - self assertAllSenders: sendersCollection send: oldSelector. - self assertNoImplementorFrom: implementorsCollection reference: aParameterToRemove definedAt: parameterIndex. - - newSelector := self newSelectorFrom: oldSelector removingParameterAt: parameterIndex. - - ^self new - initializeNamed: aParameterToRemove - ofKeywordAtIndex: parameterIndex - from: oldSelector - creating: newSelector - implementors: implementorsCollection - senders: sendersCollection -! ! -!RemoveParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/2/2018 20:07:30'! - assert: aParamerterToRemove isDefinedIn: methodNode - - | parameterIndex | - - parameterIndex := methodNode arguments findFirst: [ :aParameterNode | aParameterNode name = aParamerterToRemove ]. - parameterIndex = 0 ifTrue: [ self signalParameterNotInMessage: aParamerterToRemove ]. - - ^parameterIndex - ! ! -!RemoveParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/4/2018 15:18:13'! - assertCanRemoveParameterFrom: oldSelector - - self assertIsNotUnary: oldSelector. - self assertIsNotBinary: oldSelector.! ! -!RemoveParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/1/2018 12:34:26'! - assertIsNotBinary: aSelector - - aSelector isInfix ifTrue: [ self signalCanNotRemoveParameterFromBinaryMessages]! ! -!RemoveParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/1/2018 12:37:00'! - assertIsNotUnary: aSelector - - aSelector isUnary ifTrue: [ self signalCanNotRemoveParameterFromUnaryMessages]! ! -!RemoveParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/4/2018 15:41:24'! - assertNoImplementorFrom: implementorsCollection reference: aParamerterToRemove definedAt: parameterIndex - - | implementorsReferencingParameter | - - implementorsReferencingParameter := implementorsCollection select: [:anImplementor | anImplementor referencesParameterAt: parameterIndex ]. - - implementorsReferencingParameter isEmpty ifFalse: [ self signalCanNotRemove: aParamerterToRemove dueToReferencesIn: implementorsReferencingParameter ].! ! -!RemoveParameter class methodsFor: 'exceptions' stamp: 'HAW 1/7/2019 15:31:35'! - canNotRemoveParameterFromBinaryMessagesErrorMessage - - ^'Can not remove parameter from binary messages. -Rename message to a keyword one first'! ! -!RemoveParameter class methodsFor: 'exceptions' stamp: 'HAW 9/1/2018 12:36:43'! - canNotRemoveParameterFromUnaryMessagesErrorMessage - - ^'There is no parameter to remove in unary messages'! ! -!RemoveParameter class methodsFor: 'exceptions' stamp: 'HAW 9/2/2018 19:40:52'! - errorMessageForParameterNotInMessage: aParameterToRemove - - ^aParameterToRemove, ' is not define as parameter'! ! -!RemoveParameter class methodsFor: 'exceptions' stamp: 'HAW 9/3/2018 16:27:21'! - errorMessageForParameterToRemoveIsReferenced: aParameterToRemove - - ^aParameterToRemove, ' is being referenced in implementors'! ! -!RemoveParameter class methodsFor: 'exceptions' stamp: 'HAW 9/2/2018 20:21:43'! - signalCanNotRemove: aParameterToRemove dueToReferencesIn: implementorsReferencingParameterToRemove - - self - canNotRefactorDueToReferencesError: (self errorMessageForParameterToRemoveIsReferenced: aParameterToRemove) - references: (implementorsReferencingParameterToRemove collect: [ :implementor | MethodReference method: implementor ]) - to: aParameterToRemove - ! ! -!RemoveParameter class methodsFor: 'exceptions' stamp: 'HAW 9/1/2018 12:34:45'! - signalCanNotRemoveParameterFromBinaryMessages - - self refactoringError: self canNotRemoveParameterFromBinaryMessagesErrorMessage! ! -!RemoveParameter class methodsFor: 'exceptions' stamp: 'HAW 9/1/2018 12:37:00'! - signalCanNotRemoveParameterFromUnaryMessages - - self refactoringError: self canNotRemoveParameterFromUnaryMessagesErrorMessage! ! -!RemoveParameter class methodsFor: 'exceptions' stamp: 'HAW 9/2/2018 19:40:22'! - signalParameterNotInMessage: aParameterToRemove - - self refactoringError: (self errorMessageForParameterNotInMessage: aParameterToRemove)! ! -!RemoveParameter class methodsFor: 'instance creation - private' stamp: 'HAW 9/4/2018 21:22:36'! - newSelectorConcatenating: oldSelectorKeywords removingAt: anIndex - - | keywords | - - keywords := oldSelectorKeywords asOrderedCollection. - keywords removeIndex: anIndex. - - ^Symbol fromCollectionOfStrings: keywords.! ! -!RemoveParameter class methodsFor: 'instance creation - private' stamp: 'HAW 9/4/2018 21:30:47'! - newSelectorFrom: oldSelector removingParameterAt: parameterIndex - - | oldSelectorKeywords newSelector | - - oldSelectorKeywords := oldSelector keywords. - - newSelector := oldSelectorKeywords size = 1 - ifTrue: [ oldSelector allButLast asSymbol ] - ifFalse: [ self newSelectorConcatenating: oldSelectorKeywords removingAt: parameterIndex ]. - - ^newSelector! ! -!RenameSelector methodsFor: 'create new implementors - private' stamp: 'HAW 9/3/2018 19:49:44'! - implementorNewSourceCodeOf: anImplementor - - | newSource rangesToNewKeywords | - - rangesToNewKeywords := OrderedCollection new. - anImplementor methodNode selectorKeywordsPositions withIndexDo: [ :aKeywordRange :index | - rangesToNewKeywords add: aKeywordRange -> (newSelectorKeywords at: index) ]. - - newSource := anImplementor sourceCode copyReplacing: rangesToNewKeywords. - ^newSource! ! -!RenameSelector methodsFor: 'rename senders - private' stamp: 'HAW 9/3/2018 19:47:38'! -addMessageSendSelectorKeywordRangesOf: aMethodNode to: rangesToKeywords - - | oldSelectorKeywordsRanges | - - oldSelectorKeywordsRanges := aMethodNode messageSendSelectorKeywordPositionsOf: oldSelector ifAbsent: [ #() ]. - oldSelectorKeywordsRanges do: [ :aMessageSendSelectorRanges | - aMessageSendSelectorRanges withIndexDo: [ :aRange :index | rangesToKeywords add: aRange -> (newSelectorKeywords at: index) ]]. - ! ! -!RenameSelector methodsFor: 'initialization' stamp: 'HAW 9/3/2018 17:14:47'! - initializeFrom: anOldSelector to: aNewSelector implementors: aCollectionOfImplementors senders: aCollectionOfSenders - - super initializeFrom: anOldSelector to: aNewSelector implementors: aCollectionOfImplementors senders: aCollectionOfSenders. - - newSelectorKeywords := newSelector keywords. - ! ! -!RenameSelector class methodsFor: 'pre-conditions' stamp: 'HAW 5/25/2017 20:02:05'! - assert: aNewSelector hasTheSameNumberOfArgumentsAs: anOldSelector - - aNewSelector numArgs ~= anOldSelector numArgs ifTrue: [ self signalNewSelector: aNewSelector doesNotHaveSameNumberOfArgumentsAs: anOldSelector ]! ! -!RenameSelector class methodsFor: 'pre-conditions' stamp: 'HAW 5/26/2017 00:41:25'! - assert: aNewSelector isNotEqualTo: anOldSelector - - aNewSelector = anOldSelector ifTrue: [ self signalNewSelectorEqualToOldSelector]! ! -!RenameSelector class methodsFor: 'pre-conditions' stamp: 'HAW 12/13/2018 18:53:51'! - assert: aNewSelector isOfSameTypeAs: anOldSelector - - (self isRenamigBetweenBinary: anOldSelector andKeywordOfOneParameter: aNewSelector) ifTrue: [ ^self ]. - (self isRenamigBetweenBinary: aNewSelector andKeywordOfOneParameter: anOldSelector) ifTrue: [ ^self ]. - - aNewSelector precedence ~= anOldSelector precedence ifTrue: [ - self signalNewSelector: aNewSelector isNotOfSameTypeAs: anOldSelector ]! ! -!RenameSelector class methodsFor: 'pre-conditions' stamp: 'HAW 6/3/2017 11:54:48'! - assertIsNotEmpty: aCollection signalMessageText: errorMessageText - - aCollection isEmpty ifTrue: [ self refactoringError: errorMessageText ].! ! -!RenameSelector class methodsFor: 'pre-conditions' stamp: 'HAW 5/26/2017 00:44:37'! - assertIsValidToRenameFrom: anOldSelector to: aNewSelector - - self assertIsNotEmpty: anOldSelector signalMessageText: self oldSelectorCanNotBeEmptyErrorMessage. - self assertIsNotEmpty: aNewSelector signalMessageText: self newSelectorCanNotBeEmptyErrorMessage. - self assert: aNewSelector isNotEqualTo: anOldSelector. - self assert: aNewSelector isOfSameTypeAs: anOldSelector. - self assert: aNewSelector hasTheSameNumberOfArgumentsAs: anOldSelector. - ! ! -!RenameSelector class methodsFor: 'pre-conditions' stamp: 'HAW 5/31/2017 19:38:12'! - assertNoImplementorClassIn: implementorsCollection implements: aNewSelector - - | classesImplementingNewSelector | - - classesImplementingNewSelector := implementorsCollection - select: [ :anImplementor | anImplementor methodClass includesSelector: aNewSelector ] - thenCollect: [ :anImplementor | anImplementor methodClass ]. - - classesImplementingNewSelector notEmpty ifTrue: [ self signalNewSelector: aNewSelector implementedInAll: classesImplementingNewSelector ]! ! -!RenameSelector class methodsFor: 'pre-conditions' stamp: 'HAW 12/13/2018 18:52:19'! - isRenamigBetweenBinary: aPotentiallyBinarySelector andKeywordOfOneParameter: aPotentiallyKeywordSelector - - ^aPotentiallyBinarySelector isInfix - and: [ aPotentiallyKeywordSelector isKeyword - and: [ aPotentiallyKeywordSelector numArgs = 1 ]] -! ! -!RenameSelector class methodsFor: 'pre-conditions' stamp: 'HAW 5/31/2017 20:56:22'! - warnIfImplementionsOf: aNewSelector overridesImplementationInSuperclassesOf: implementorsCollection - - implementorsCollection do: [:anImplementor | - anImplementor methodClass - withSuperclassThatIncludesSelector: aNewSelector - do: [ :aSuperclass | self warnImplementionOf: aNewSelector in: anImplementor methodClass willOverrideImplementationIn: aSuperclass ] - ifNone: []]! ! -!RenameSelector class methodsFor: 'exceptions' stamp: 'HAW 5/25/2017 19:59:44'! - errorMessageForNewSelector: aNewSelector doesNotHaveSameNumberOfArgumentsAs: anOldSelector - - ^'New selector #', aNewSelector, ' does not have the same number of arguments as #', anOldSelector ! ! -!RenameSelector class methodsFor: 'exceptions' stamp: 'HAW 5/31/2017 19:41:36'! - errorMessageForNewSelector: aNewSelector implementedInAll: classesImplementingNewSelector - - ^'Can not rename because #', aNewSelector, ' is implemented in: ', classesImplementingNewSelector asCommaStringAnd ! ! -!RenameSelector class methodsFor: 'exceptions' stamp: 'HAW 5/25/2017 19:54:05'! - errorMessageForNewSelector: aNewSelector isNotOfSameTypeAs: anOldSelector - - ^'New selector #', aNewSelector, ' is not of same type as #', anOldSelector ! ! -!RenameSelector class methodsFor: 'exceptions' stamp: 'HAW 5/25/2017 18:51:46'! - implementorsCanNotBeEmptyErrorMessage - - ^'There are no methods to rename'! ! -!RenameSelector class methodsFor: 'exceptions' stamp: 'HAW 5/25/2017 18:49:15'! - newSelectorCanNotBeEmptyErrorMessage - - ^'New selector can not be empty'! ! -!RenameSelector class methodsFor: 'exceptions' stamp: 'HAW 5/26/2017 00:40:01'! - newSelectorEqualToOldSelectorErrorMessage - - ^'There is nothing to rename when new selector is equals to old selector'! ! -!RenameSelector class methodsFor: 'exceptions' stamp: 'HAW 5/25/2017 18:49:07'! - oldSelectorCanNotBeEmptyErrorMessage - - ^'Old selector can not be empty'! ! -!RenameSelector class methodsFor: 'exceptions' stamp: 'HAW 6/3/2017 11:55:23'! - signalNewSelector: aNewSelector doesNotHaveSameNumberOfArgumentsAs: anOldSelector - - self refactoringError: (self errorMessageForNewSelector: aNewSelector doesNotHaveSameNumberOfArgumentsAs: anOldSelector).! ! -!RenameSelector class methodsFor: 'exceptions' stamp: 'HAW 6/3/2017 11:55:38'! - signalNewSelector: aNewSelector implementedInAll: classesImplementingNewSelector - - self refactoringError: (self errorMessageForNewSelector: aNewSelector implementedInAll: classesImplementingNewSelector).! ! -!RenameSelector class methodsFor: 'exceptions' stamp: 'HAW 6/3/2017 11:55:54'! - signalNewSelector: aNewSelector isNotOfSameTypeAs: anOldSelector - - self refactoringError: (self errorMessageForNewSelector: aNewSelector isNotOfSameTypeAs: anOldSelector).! ! -!RenameSelector class methodsFor: 'exceptions' stamp: 'HAW 6/3/2017 11:55:58'! - signalNewSelectorEqualToOldSelector - - self refactoringError: self newSelectorEqualToOldSelectorErrorMessage.! ! -!RenameSelector class methodsFor: 'instance creation' stamp: 'HAW 5/31/2017 19:58:50'! - from: anOldSelector to: aNewSelector implementors: aCollectionOfImplementors senders: aCollectionOfSenders - - self assertIsValidToRenameFrom: anOldSelector to: aNewSelector. - self assertIsNotEmpty: aCollectionOfImplementors signalMessageText: self implementorsCanNotBeEmptyErrorMessage. - self assertAllImplementors: aCollectionOfImplementors haveSame: anOldSelector. - self assertNoImplementorClassIn: aCollectionOfImplementors implements: aNewSelector. - self assertAllSenders: aCollectionOfSenders send: anOldSelector. - - self warnIfImplementionsOf: aNewSelector overridesImplementationInSuperclassesOf: aCollectionOfImplementors. - - ^self new initializeFrom: anOldSelector to: aNewSelector implementors: aCollectionOfImplementors senders: aCollectionOfSenders - ! ! -!RenameSelector class methodsFor: 'instance creation' stamp: 'HAW 5/26/2017 00:04:36'! - from: anOldSelector to: aNewSelector in: aClassToRefactor - - | implementors senders | - - implementors := OrderedCollection new. - senders := OrderedCollection new. - - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders forClassAndMetaOf: aClassToRefactor theNonMetaClass. - - ^self from: anOldSelector to: aNewSelector implementors: implementors senders: senders ! ! -!RenameSelector class methodsFor: 'instance creation' stamp: 'HAW 5/30/2017 17:45:16'! - from: anOldSelector to: aNewSelector inCategoriesAndHierarchyOf: aClass organizedBy: anOrganization - - | implementors senders | - - implementors := IdentitySet new. - senders := IdentitySet new. - - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategoriesAndHierarchyOf: aClass organizedBy: anOrganization. - - ^self from: anOldSelector to: aNewSelector implementors: implementors senders: senders -! ! -!RenameSelector class methodsFor: 'instance creation' stamp: 'HAW 5/25/2017 23:59:19'! - from: anOldSelector to: aNewSelector inCategoryOf: aClass organizedBy: anOrganization - - | implementors senders | - - implementors := OrderedCollection new. - senders := OrderedCollection new. - - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategory: aClass category organizedBy: anOrganization. - - ^self from: anOldSelector to: aNewSelector implementors: implementors senders: senders -! ! -!RenameSelector class methodsFor: 'instance creation' stamp: 'HAW 5/25/2017 23:53:57'! - from: anOldSelector to: aNewSelector inHierarchyOf: aClass - - | implementors senders | - - implementors := OrderedCollection new. - senders := OrderedCollection new. - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inHierarchyOf: aClass. - - ^self from: anOldSelector to: aNewSelector implementors: implementors senders: senders - - ! ! -!RenameSelector class methodsFor: 'instance creation' stamp: 'HAW 5/30/2017 17:47:27'! - from: anOldSelector to: aNewSelector inSystem: aSystem - - | implementors senders | - - implementors := OrderedCollection new. - senders := OrderedCollection new. - - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inSystem: aSystem. - - ^self from: anOldSelector to: aNewSelector implementors: implementors senders: senders - ! ! -!RenameSelector class methodsFor: 'warnings' stamp: 'HAW 6/3/2017 12:01:34'! - warnImplementionOf: aNewSelector in: aClass willOverrideImplementationIn: aSuperclass - - self refactoringWarning: (self warningMessageForImplementationOf: aNewSelector in: aClass willOverrideImplementationIn: aSuperclass).! ! -!RenameSelector class methodsFor: 'warnings' stamp: 'HAW 8/1/2018 18:15:01'! - warningMessageForImplementationOf: aNewSelector in: aClass willOverrideImplementationIn: aSuperclass - - ^'Implemention of #', aNewSelector, ' in ', aClass name, ' will override implementation in ', aSuperclass name! ! -!ExtractToTemporary methodsFor: 'applying' stamp: 'HAW 10/18/2017 18:39:22'! - apply - - | temporaries finder rewriter | - - newTemporary := methodNodeToRefactor encoder bindTemp: newVariable. - temporaries := methodNodeToRefactor temporaries asOrderedCollection. - temporaries add: newTemporary. - - methodNodeToRefactor temporaries: temporaries. - finder := ParseNodeToReplaceFinder of: self. - methodNodeToRefactor accept: finder. - rewriter := ExtractToTemporaryRewriter of: self on: finder. - methodNodeToRefactor accept: rewriter. - finder blockContainingFirstNodeToReplace statements - add: (AssignmentNode new variable: newTemporary value: parseNodeToExtract) - beforeIndex: finder firstNodeToReplaceIndex. - - ^methodNodeToRefactor ! ! -!ExtractToTemporary methodsFor: 'initialization' stamp: 'HAW 10/4/2017 17:43:11'! - initializeNamed: aNewVariable with: aParseNodeToExtract in: aMethodNodeToRefactor - - newVariable := aNewVariable. - parseNodeToExtract := aParseNodeToExtract. - methodNodeToRefactor := aMethodNodeToRefactor ! ! -!ExtractToTemporary methodsFor: 'accessing' stamp: 'HAW 10/4/2017 18:45:19'! - newTemporary - - ^newTemporary ! ! -!ExtractToTemporary methodsFor: 'accessing' stamp: 'HAW 10/4/2017 18:38:13'! - parseNodeToExtract - - ^parseNodeToExtract! ! -!ExtractToTemporary methodsFor: 'testing' stamp: 'HAW 10/18/2017 18:08:31'! - shouldExtract: aParseNode - - ^parseNodeToExtract = aParseNode ! ! -!ExtractToTemporary methodsFor: 'as yet unclassified' stamp: 'HAW 9/11/2018 15:52:26'! - research - -" -TextEditor>>selectionInterval -hasSelection -selection -"! ! -!ExtractToTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 6/30/2017 06:25:21'! - assert: aSourceCodeToExtract isIncludedIn: aMethodNodeToRefactor - - (aMethodNodeToRefactor sourceText includesSubString: aSourceCodeToExtract) ifFalse: [ - self signalMethodNodeToRefactorDoesNotInclude: aSourceCodeToExtract ] - -! ! -!ExtractToTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 6/26/2017 16:30:52'! -assert: aNewVariable isNotDefinedIn: aMethodNode - - (aMethodNode tempNames includes: aNewVariable) ifTrue: [ self signalNewTemporaryVariable: aNewVariable isAlreadyDefinedIn: aMethodNode ] - ! ! -!ExtractToTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 6/26/2017 16:23:25'! - assertIsNotEmpty: aNewVariable - - aNewVariable isEmpty ifTrue: [ self signalNewVariableCanNotBeEmpty ]! ! -!ExtractToTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 3/6/2018 16:01:34'! -assertIsNotReturn: aSourceCodeToExtract - - "I have to use the source code to check this because parsing it returns the same methodNode for - 1 and ^1, that is, using methodNode does not help to distigished if there was or not a return - Hernan" - - aSourceCodeToExtract withBlanksTrimmed first = $^ ifTrue: [ self signalSourceCodeToExtractCanNotIncludeReturn ]! ! -!ExtractToTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 6/27/2017 17:52:29'! - assertIsOneStatement: aMethodNodeToExtract - - aMethodNodeToExtract block statements size ~= 1 ifTrue: [ self signalColaborationToExtractHasToBeOneStatement]! ! -!ExtractToTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 6/26/2017 16:27:32'! - assertIsValidVariableName: aName - - | scannedNames | - - scannedNames _ Scanner new scanFieldNames: aName. - scannedNames size = 1 ifFalse: [ self signalInvalidTemporaryVariable: aName ]. - scannedNames first = aName ifFalse: [ self signalInvalidTemporaryVariable: aName ].! ! -!ExtractToTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 6/30/2017 06:21:22'! - assertSourceCodeIsNotEmpty: aSourceCodeToExtract - - aSourceCodeToExtract isEmpty ifTrue: [ self signalSourceCodeToExtractCanNotBeEmpty]! ! -!ExtractToTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 6/26/2017 16:33:25'! - warnIf: aNewVariable isDefinedAsInstanceVariableInHierarchyOf: aClass - - | classDefiningNewVariable | - - classDefiningNewVariable := aClass whichClassDefinesInstanceVariable: aNewVariable ifNone: [ ^self ]. - self warn: aNewVariable willHideInstanceVariableDefinedIn: classDefiningNewVariable ! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/26/2017 16:28:07'! - errorMessageForInvalidTemporaryVariable: aName - - ^ '''' , aName , ''' is not a valid temporary variable name'.! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/26/2017 16:31:23'! - errorMessageForNewTemporaryVariable: aNewVariable isAlreadyDefinedIn: aMethodNode - - ^aNewVariable, ' is already defined in ', aMethodNode classAndSelector ! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/30/2017 06:34:01'! - errorMessageForSourceCodeToExtractHasSyntaxError: anErrorDescription - - ^'Can not extract a source code with syntax error: ', anErrorDescription ! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/30/2017 06:26:23'! - errorMessageMethodNodeToRefactorDoesNotInclude: aSourceCodeToExtract - - ^'The source code {', aSourceCodeToExtract, '} is not included in the method to refactor'! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/26/2017 16:24:10'! - newVariableCanNotBeEmptyErrorMessage - - ^'New variable can not be empty'! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/30/2017 06:34:15'! -signalColaborationToExtractHasSyntaxError: aSyntaxErrorNotification - - self refactoringError: (self errorMessageForSourceCodeToExtractHasSyntaxError: aSyntaxErrorNotification messageText)! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/30/2017 06:32:50'! - signalColaborationToExtractHasToBeOneStatement - - self refactoringError: self sourceCodeToExtractHasToBeOneStatementErrorMessage ! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/26/2017 16:27:51'! - signalInvalidTemporaryVariable: aName - - ^ self refactoringError: (self errorMessageForInvalidTemporaryVariable: aName).! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/27/2017 17:23:04'! - signalMethodNodeToRefactorDoesNotInclude: aColaborationToExtract - - ^self refactoringError: (self errorMessageMethodNodeToRefactorDoesNotInclude: aColaborationToExtract)! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/26/2017 16:31:08'! -signalNewTemporaryVariable: aNewVariable isAlreadyDefinedIn: aMethodNode - - self refactoringError: (self errorMessageForNewTemporaryVariable: aNewVariable isAlreadyDefinedIn: aMethodNode )! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/26/2017 16:23:49'! - signalNewVariableCanNotBeEmpty - - self refactoringError: self newVariableCanNotBeEmptyErrorMessage! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/30/2017 06:20:49'! - signalSourceCodeToExtractCanNotBeEmpty - - self refactoringError: self sourceCodeToExtractCanNotBeEmptyErrorMessage! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/30/2017 06:24:37'! - signalSourceCodeToExtractCanNotIncludeReturn - - self refactoringError: self sourceCodeToExtractCanNotIncludeReturnErrorMessage ! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/30/2017 06:20:21'! - sourceCodeToExtractCanNotBeEmptyErrorMessage - - ^'Source code to extract can not be empty'! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/30/2017 06:24:02'! - sourceCodeToExtractCanNotIncludeReturnErrorMessage - - ^'A return can not be extracted'! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/30/2017 06:32:22'! - sourceCodeToExtractHasToBeOneStatementErrorMessage - - ^'Can not extract more than one statement'! ! -!ExtractToTemporary class methodsFor: 'instance creation' stamp: 'HAW 9/11/2018 16:13:23'! - named: aNewVariable at: anIntervalToExtract from: aMethodSourceCode in: aClass - - | trimmedNewVariable parseNodeToExtract trimmedSourceCodeToExtract methodNodeToExtract methodNodeToRefactor sourceCodeToExtract | - - trimmedNewVariable := aNewVariable withBlanksTrimmed. - methodNodeToRefactor := aClass methodNodeFor: aMethodSourceCode. - - self assertIsNotEmpty: trimmedNewVariable. - self assertIsValidVariableName: trimmedNewVariable. - self assert: trimmedNewVariable isNotDefinedIn: methodNodeToRefactor. - - sourceCodeToExtract := aMethodSourceCode copyFrom: anIntervalToExtract first to: anIntervalToExtract last. - trimmedSourceCodeToExtract := sourceCodeToExtract withBlanksTrimmed. - self assertSourceCodeIsNotEmpty: trimmedSourceCodeToExtract. - self assertIsNotReturn: trimmedSourceCodeToExtract. - self assert: trimmedSourceCodeToExtract isIncludedIn: methodNodeToRefactor. - - [ methodNodeToExtract := Parser parse: trimmedSourceCodeToExtract class: methodNodeToRefactor methodClass noPattern: true ] - on: SyntaxErrorNotification - do: [ :anError | self signalColaborationToExtractHasSyntaxError: anError ]. - - parseNodeToExtract := self paseNodeToExtractFrom: methodNodeToExtract. - - self warnIf: trimmedNewVariable isDefinedAsInstanceVariableInHierarchyOf: methodNodeToRefactor methodClass. - - ^self new initializeNamed: trimmedNewVariable with: parseNodeToExtract in: methodNodeToRefactor - - ! ! -!ExtractToTemporary class methodsFor: 'instance creation' stamp: 'HAW 10/4/2017 17:41:59'! - named: aNewVariable with: aSourceCodeToExtract in: aMethodNodeToRefactor - - | trimmedNewVariable parseNodeToExtract trimmedSourceCodeToExtract methodNodeToExtract | - - trimmedNewVariable := aNewVariable withBlanksTrimmed. - - self assertIsNotEmpty: trimmedNewVariable. - self assertIsValidVariableName: trimmedNewVariable. - self assert: trimmedNewVariable isNotDefinedIn: aMethodNodeToRefactor. - - trimmedSourceCodeToExtract := aSourceCodeToExtract withBlanksTrimmed. - self assertSourceCodeIsNotEmpty: trimmedSourceCodeToExtract. - self assertIsNotReturn: trimmedSourceCodeToExtract. - self assert: trimmedSourceCodeToExtract isIncludedIn: aMethodNodeToRefactor. - - [ methodNodeToExtract := Parser parse: trimmedSourceCodeToExtract class: aMethodNodeToRefactor methodClass noPattern: true ] - on: SyntaxErrorNotification - do: [ :anError | self signalColaborationToExtractHasSyntaxError: anError ]. - - parseNodeToExtract := self paseNodeToExtractFrom: methodNodeToExtract. - - self warnIf: trimmedNewVariable isDefinedAsInstanceVariableInHierarchyOf: aMethodNodeToRefactor methodClass. - - ^self new initializeNamed: trimmedNewVariable with: parseNodeToExtract in: aMethodNodeToRefactor - - ! ! -!ExtractToTemporary class methodsFor: 'method node to extract' stamp: 'HAW 6/27/2017 17:58:04'! - paseNodeToExtractFrom: aMethodNodeToExtract - - self assertIsOneStatement: aMethodNodeToExtract. - - ^aMethodNodeToExtract block statements first expr. - ! ! -!ExtractToTemporary class methodsFor: 'warnings' stamp: 'HAW 6/26/2017 16:34:44'! - warn: aNewVariable willHideInstanceVariableDefinedIn: aClass - - self refactoringWarning: (self warningMessageFor: aNewVariable willHideInstanceVariableDefinedIn: aClass)! ! -!ExtractToTemporary class methodsFor: 'warnings' stamp: 'HAW 6/26/2017 16:35:04'! - warningMessageFor: aNewVariable willHideInstanceVariableDefinedIn: aClass - - ^aNewVariable, ' will hide instance variable defined in ', aClass name! ! -!InsertSuperclass methodsFor: 'applying' stamp: 'HAW 8/13/2018 18:31:33'! -apply - - | newSuperclass | - - newSuperclass := self createSuperclass. - self changeSuperclassOf: classToRefactor to: newSuperclass. - - ^newSuperclass ! ! -!InsertSuperclass methodsFor: 'applying - private' stamp: 'HAW 8/13/2018 18:31:43'! - changeSuperclassOf: classToRefactor to: newSuperclass - - newSuperclass subclass: classToRefactor name - instanceVariableNames: classToRefactor instanceVariablesString - classVariableNames: classToRefactor classVariablesString - poolDictionaries: classToRefactor sharedPoolsString - category: classToRefactor category.! ! -!InsertSuperclass methodsFor: 'applying - private' stamp: 'HAW 8/13/2018 18:31:06'! - createSuperclass - - ^classToRefactor superclass subclass: superclassName - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: classToRefactor category.! ! -!InsertSuperclass methodsFor: 'initialization' stamp: 'HAW 8/13/2018 17:36:34'! - initializeTo: aClass named: aSuperclassName - - classToRefactor := aClass. - superclassName := aSuperclassName.! ! -!InsertSuperclass class methodsFor: 'instance creation' stamp: 'HAW 3/3/2019 09:11:36'! - newClassPreconditionClass - - ^NewClassPrecondition ! ! -!InsertSuperclass class methodsFor: 'instance creation' stamp: 'HAW 8/13/2018 17:34:37'! - to: aClass named: aSuperclassName - - ^self to: aClass named: aSuperclassName in: Smalltalk undeclared: Undeclared! ! -!InsertSuperclass class methodsFor: 'instance creation' stamp: 'HAW 3/3/2019 09:11:31'! - to: aClass named: aSuperclassName in: aSystem undeclared: anUndeclared - - self newClassPreconditionClass valueFor: aSuperclassName in: aSystem undeclared: anUndeclared. - - ^self new initializeTo: aClass theNonMetaClass named: aSuperclassName ! ! -!PushUpMethod methodsFor: 'initialization' stamp: 'HAW 8/18/2018 11:44:09'! - initializeFor: aMethodToPushup - - method := aMethodToPushup ! ! -!PushUpMethod methodsFor: 'applying' stamp: 'HAW 3/4/2019 15:23:40'! - apply - - | methodCategory | - - methodCategory := method methodClass organization categoryOfElement: method selector. - method methodClass superclass - compile: method sourceCode - classified: methodCategory. - - method methodClass removeSelector: method selector. - ! ! -!PushUpMethod class methodsFor: 'instance creation' stamp: 'HAW 8/18/2018 11:43:53'! - for: aMethodToPushUp - - ^self new initializeFor: aMethodToPushUp ! ! -!RemoveAllUnreferencedInstanceVariables methodsFor: 'initialization' stamp: 'HAW 8/2/2018 16:14:57'! - initializeFrom: aClassToRefactor - - classToRefactor := aClassToRefactor ! ! -!RemoveAllUnreferencedInstanceVariables methodsFor: 'applying' stamp: 'HAW 8/2/2018 16:05:05'! - apply - - | variableNamesToRemove | - - variableNamesToRemove := classToRefactor unreferencedInstanceVariables. - variableNamesToRemove do: [ :aVariableName | classToRefactor removeInstVarName: aVariableName ]. - - ^variableNamesToRemove! ! -!RemoveAllUnreferencedInstanceVariables class methodsFor: 'instance creation' stamp: 'HAW 8/2/2018 16:14:45'! - from: aClassToRefactor - - ^self new initializeFrom: aClassToRefactor ! ! -!RemoveInstanceVariable methodsFor: 'applying' stamp: 'HAW 6/17/2017 19:46:45'! - apply - - classToRefactor removeInstVarName: variableToRemove ! ! -!RemoveInstanceVariable methodsFor: 'initialization' stamp: 'HAW 6/17/2017 19:45:18'! - initializeNamed: aVariable from: aClassToRefactor - - variableToRemove := aVariable. - classToRefactor := aClassToRefactor ! ! -!RemoveInstanceVariable class methodsFor: 'pre-conditions' stamp: 'HAW 6/12/2017 19:11:50'! - assert: aClass defines: anInstanceVariable - - (aClass definesInstanceVariableNamed: anInstanceVariable) ifFalse: [ self signalInstanceVariable: anInstanceVariable notDefinedIn: aClass ].! ! -!RemoveInstanceVariable class methodsFor: 'pre-conditions' stamp: 'HAW 8/1/2018 19:36:10'! - assert: aVaraible isNotReferencedInHierarchyOf: aClassToRefactor - - | references | - - references := OrderedCollection new. - aClassToRefactor withAllSubclassesDo: [ :aClass | - (aClass whichSelectorsAccess: aVaraible) do: [ :aSelector | references add: (MethodReference class: aClass selector: aSelector) ]]. - - references notEmpty ifTrue: [ self signalInstanceVariable: aVaraible isReferencedInAll: references ]! ! -!RemoveInstanceVariable class methodsFor: 'exceptions' stamp: 'HAW 8/1/2018 19:38:57'! - errorMessageForInstanceVariable: aVariable isReferencedInAll: methods - - ^aVariable, ' can not be removed because it has references'. - ! ! -!RemoveInstanceVariable class methodsFor: 'exceptions' stamp: 'HAW 6/12/2017 19:12:41'! - errorMessageForInstanceVariable: aName notDefinedIn: aClass - - ^ 'Instance variable ''' , aName , ''' is not defined in ' , aClass name.! ! -!RemoveInstanceVariable class methodsFor: 'exceptions' stamp: 'HAW 8/17/2018 16:34:16'! - signalInstanceVariable: aVariable isReferencedInAll: methods - - self - canNotRefactorDueToReferencesError: (self errorMessageForInstanceVariable: aVariable isReferencedInAll: methods) - references: methods - to: aVariable! ! -!RemoveInstanceVariable class methodsFor: 'exceptions' stamp: 'HAW 6/12/2017 19:12:12'! - signalInstanceVariable: aName notDefinedIn: aClass - - ^ self refactoringError: (self errorMessageForInstanceVariable: aName notDefinedIn: aClass).! ! -!RemoveInstanceVariable class methodsFor: 'instance creation' stamp: 'HAW 6/17/2017 19:44:39'! - named: aVariable from: aClassToRefactor - - self assert: aClassToRefactor defines: aVariable. - self assert: aVariable isNotReferencedInHierarchyOf: aClassToRefactor. - - ^self new initializeNamed: aVariable from: aClassToRefactor -! ! -!RenameClass methodsFor: 'applying' stamp: 'HAW 6/4/2017 18:09:21'! - apply - - classToRename safeRenameTo: newClassName. - ^self renameReferences. - - ! ! -!RenameClass methodsFor: 'initialization' stamp: 'HAW 8/9/2018 15:40:00'! - initializeFrom: aClass to: aNewClassName in: aSystem undeclared: anUndeclaredDictionary - - classToRename := aClass. - classToRenameOriginalName := aClass name. - newClassName := aNewClassName. - system := aSystem. - undeclared := anUndeclaredDictionary. - - ! ! -!RenameClass methodsFor: 'accessing' stamp: 'HAW 6/4/2017 18:16:33'! - newClassName - - ^newClassName ! ! -!RenameClass methodsFor: 'accessing' stamp: 'HAW 6/4/2017 18:24:56'! - referencesToOldClass - - ^system allCallsOn: newClassName! ! -!RenameClass methodsFor: 'accessing' stamp: 'HAW 6/4/2017 18:25:56'! - referencesToOldClassName - - ^system allCallsOn: classToRenameOriginalName! ! -!RenameClass methodsFor: 'applying - private' stamp: 'HAW 8/13/2018 15:27:46'! - newSourceCodeOf: aCompiledMethod - - | newSource | - - newSource := aCompiledMethod sourceCode copyReplacing: (self rangesToReplaceOf: aCompiledMethod) with: newClassName. - - ^newSource! ! -!RenameClass methodsFor: 'applying - private' stamp: 'HAW 9/3/2018 19:48:30'! - rangesForLiteralOf: methodNode - - | literalRanges | - - literalRanges := methodNode positionsForLiteralNode: classToRenameOriginalName ifAbsent: [ #() ]. - literalRanges := literalRanges collect: [ :aRange | aRange first + 1 to: aRange last ]. - - ^literalRanges ! ! -!RenameClass methodsFor: 'applying - private' stamp: 'HAW 9/3/2018 19:48:49'! - rangesForLiteralVariableOf: methodNode - - ^methodNode positionsForLiteralVariableNode: classToRenameOriginalName ifAbsent: [ #() ] - ! ! -!RenameClass methodsFor: 'applying - private' stamp: 'HAW 8/13/2018 15:20:40'! - rangesToReplaceOf: aCompiledMethod - - | methodNode ranges | - - methodNode := aCompiledMethod methodNode. - ranges := SortedCollection sortBlock: [ :leftRange :rightRange | leftRange first < rightRange first ]. - - ranges addAll: (self rangesForLiteralVariableOf: methodNode). - ranges addAll: (self rangesForLiteralOf: methodNode). - - ^ranges ! ! -!RenameClass methodsFor: 'applying - private' stamp: 'HAW 8/9/2018 14:50:34'! - references: aMethodReference classVarNamed: aName - - ^aMethodReference actualClass definesClassVariableNamedInHierarchy: aName ! ! -!RenameClass methodsFor: 'applying - private' stamp: 'HAW 8/9/2018 14:50:52'! - referencesNewClassName: aMethodReference - - ^self references: aMethodReference classVarNamed: newClassName ! ! -!RenameClass methodsFor: 'applying - private' stamp: 'HAW 8/9/2018 14:51:07'! - referencesOldClassName: aMethodReference - - ^self references: aMethodReference classVarNamed: classToRenameOriginalName! ! -!RenameClass methodsFor: 'applying - private' stamp: 'HAW 8/9/2018 14:49:43'! - rejectReferencesToClassVariablesFrom: references - - ^references reject: [ :aMethodReference | (self referencesOldClassName: aMethodReference) or: [ self referencesNewClassName: aMethodReference ] ].! ! -!RenameClass methodsFor: 'applying - private' stamp: 'HAW 8/13/2018 15:18:43'! - renameReference: aReferencingMethod - - | newSource | - - newSource := self newSourceCodeOf: aReferencingMethod. - aReferencingMethod methodClass compile: newSource ! ! -!RenameClass methodsFor: 'applying - private' stamp: 'HAW 8/13/2018 15:17:56'! - renameReferences - - | references | - - references := (self referencesToOldClass asSet, self referencesToOldClassName asSet) asOrderedCollection. - references := self rejectReferencesToClassVariablesFrom: references. - references do: [ :aReference | self renameReference: aReference compiledMethod ]. - - ^references! ! -!RenameClass class methodsFor: 'pre-conditions' stamp: 'HAW 6/1/2017 19:06:21'! - assert: aClass isNotNamed: aNewName - - aClass name = aNewName ifTrue: [ self signalNewNameEqualsOldName]! ! -!RenameClass class methodsFor: 'pre-conditions' stamp: 'HAW 6/4/2017 18:49:54'! - assertIsNotMeta: aBehavior - - aBehavior isMeta ifTrue: [ self signalClassToRenameCanNotBeMetaclass]! ! -!RenameClass class methodsFor: 'pre-conditions' stamp: 'HAW 8/13/2018 18:45:26'! - newClassPreconditionClass - - ^NewClassPrecondition ! ! -!RenameClass class methodsFor: 'exceptions' stamp: 'HAW 6/4/2017 18:50:36'! - classToRenameCanNotBeMetaclassErrorMessage - - ^'Class to rename can not be a metaclass'! ! -!RenameClass class methodsFor: 'exceptions' stamp: 'HAW 6/1/2017 19:07:08'! - newNameEqualsOldNameErrorMessage - - ^'New class name equals old one'! ! -!RenameClass class methodsFor: 'exceptions' stamp: 'HAW 6/4/2017 18:50:56'! - signalClassToRenameCanNotBeMetaclass - - self refactoringError: self classToRenameCanNotBeMetaclassErrorMessage! ! -!RenameClass class methodsFor: 'exceptions' stamp: 'HAW 8/13/2018 18:39:00'! - signalNewNameEqualsOldName - - self refactoringError: self newNameEqualsOldNameErrorMessage.! ! -!RenameClass class methodsFor: 'instance creation' stamp: 'HAW 6/2/2017 11:43:48'! - from: aClass to: aNewClassName - - ^self from: aClass to: aNewClassName in: Smalltalk - ! ! -!RenameClass class methodsFor: 'instance creation' stamp: 'HAW 6/2/2017 11:55:32'! - from: aClass to: aNewClassName in: aSystem - - ^self from: aClass to: aNewClassName in: aSystem undeclared: Undeclared - - ! ! -!RenameClass class methodsFor: 'instance creation' stamp: 'HAW 8/13/2018 18:45:15'! - from: aClass to: aNewClassName in: aSystem undeclared: anUndeclaredDictionary - - self assertIsNotMeta: aClass. - self assert: aClass isNotNamed: aNewClassName. - self newClassPreconditionClass valueFor: aNewClassName in: aSystem undeclared: anUndeclaredDictionary. - - ^self new initializeFrom: aClass to: aNewClassName in: aSystem undeclared: anUndeclaredDictionary -! ! -!RenameInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 6/11/2017 19:06:35'! - addNewInstanceVariable - - addInstanceVariable apply! ! -!RenameInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 6/11/2017 19:07:49'! - copyOldInstanceVariableToNewOne - - | oldVariableIndex newVariableIndex | - - oldVariableIndex := self classToRefactor indexOfInstanceVariable: oldVariable. - newVariableIndex := self classToRefactor indexOfInstanceVariable: self newVariable. - self classToRefactor allSubInstancesDo: [ :anInstance | anInstance instVarAt: newVariableIndex put: (anInstance instVarAt: oldVariableIndex) ]. - -! ! -!RenameInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 9/3/2018 19:48:09'! -newSourceOf: aCompiledMethod - - | newSource ranges | - - ranges := aCompiledMethod methodNode positionsForInstanceVariable: oldVariable ifAbsent: [ #() ]. - newSource := aCompiledMethod sourceCode copyReplacing: ranges with: self newVariable. - - ^newSource - ! ! -!RenameInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 6/11/2017 19:07:20'! - removeOldInstanceVariable - - self classToRefactor removeInstVarName: oldVariable.! ! -!RenameInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 6/11/2017 19:07:10'! - renameReferencesToOldVariable - - renamedReferences := OrderedCollection new. - self classToRefactor withAllSubclassesDo: [ :aClass | self renameReferencesToOldVariableInClass: aClass ]! ! -!RenameInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 6/17/2017 19:17:33'! - renameReferencesToOldVariableInClass: aClass - - | referencingMethodNames | - - referencingMethodNames := aClass whichSelectorsAccess: oldVariable. - referencingMethodNames do: [ :referencingMethodName | self renameReferencesToOldVariableInMethod: (aClass compiledMethodAt: referencingMethodName) ] - ! ! -!RenameInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 8/13/2018 14:53:56'! - renameReferencesToOldVariableInMethod: aCompiledMethod - - aCompiledMethod methodClass compile: (self newSourceOf: aCompiledMethod). - renamedReferences add: aCompiledMethod methodReference ! ! -!RenameInstanceVariable methodsFor: 'applying' stamp: 'HAW 6/5/2017 16:53:57'! - apply - - self - addNewInstanceVariable; - copyOldInstanceVariableToNewOne; - renameReferencesToOldVariable; - removeOldInstanceVariable. - - ^renamedReferences - ! ! -!RenameInstanceVariable methodsFor: 'accessing' stamp: 'HAW 6/11/2017 19:09:35'! - classToRefactor - - ^addInstanceVariable classToRefactor! ! -!RenameInstanceVariable methodsFor: 'accessing' stamp: 'HAW 6/11/2017 19:07:37'! - newVariable - - ^ addInstanceVariable newVariable! ! -!RenameInstanceVariable methodsFor: 'initialization' stamp: 'HAW 8/9/2018 17:20:55'! - initializeFrom: anOldvariable addingWith: anAddInstanceVariable - - oldVariable := anOldvariable. - addInstanceVariable := anAddInstanceVariable. -! ! -!RenameInstanceVariable class methodsFor: 'pre-conditions' stamp: 'HAW 5/24/2017 21:49:18'! - assert: aClass defines: anInstanceVariable - - (aClass definesInstanceVariableNamed: anInstanceVariable) ifFalse: [ self signalInstanceVariable: anInstanceVariable notDefinedIn: aClass ].! ! -!RenameInstanceVariable class methodsFor: 'exceptions' stamp: 'HAW 5/24/2017 21:56:02'! - errorMessageForInstanceVariable: aName notDefinedIn: aClass - - ^ 'Instance variable ''' , aName , ''' is not defined in ' , aClass name.! ! -!RenameInstanceVariable class methodsFor: 'exceptions' stamp: 'HAW 6/3/2017 11:54:22'! - signalInstanceVariable: aName notDefinedIn: aClass - - ^ self refactoringError: (self errorMessageForInstanceVariable: aName notDefinedIn: aClass).! ! -!RenameInstanceVariable class methodsFor: 'instance creation' stamp: 'HAW 6/11/2017 19:04:59'! - from: anOldvariable to: aNewVariable in: aClassToRefactor - - | addInstanceVariable | - - self assert: aClassToRefactor defines: anOldvariable. - addInstanceVariable := AddInstanceVariable named: aNewVariable to: aClassToRefactor. - - ^self new initializeFrom: anOldvariable addingWith: addInstanceVariable ! ! -!RenameTemporary methodsFor: 'applying' stamp: 'HAW 9/3/2018 19:49:06'! - apply - - | newSource ranges | - - ranges := methodNode positionsForTemporaryVariable: oldVariable ifAbsent: [ #() ]. - newSource := methodNode sourceText copyReplacing: ranges with: newVariable. - - ^ newSource! ! -!RenameTemporary methodsFor: 'applying' stamp: 'HAW 8/9/2018 19:34:51'! - methodNodeAfterApply - - ^methodNode methodClass methodNodeFor: self apply. - - ! ! -!RenameTemporary methodsFor: 'initialization' stamp: 'HAW 6/25/2017 21:53:31'! - initializeFrom: anOldVariable to: aNewVariable in: aMethodNode - - oldVariable := anOldVariable. - newVariable := aNewVariable. - methodNode := aMethodNode ! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 6/25/2017 21:53:31'! - assert: aVariable isDefinedIn: aMethodNode - - (aMethodNode tempNames includes: aVariable) ifFalse: [ self signalTemporaryVariable: aVariable notDefinedIn: aMethodNode ]! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 6/25/2017 21:53:31'! - assert: aNewVariable isNotDefinedIn: aMethodNode - - (aMethodNode tempNames includes: aNewVariable) ifTrue: [ self signalNewTemporaryVariable: aNewVariable isAlreadyDefinedIn: aMethodNode ] - ! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 6/25/2017 21:53:31'! - assertIsNotEmpty: aNewVariable - - aNewVariable isEmpty ifTrue: [ self signalNewVariableCanNotBeEmpty ]! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 6/25/2017 21:53:31'! - assertIsValidVariableName: aName - - | scannedNames | - - scannedNames _ Scanner new scanFieldNames: aName. - scannedNames size = 1 ifFalse: [ self signalInvalidTemporaryVariable: aName ]. - scannedNames first = aName ifFalse: [ self signalInvalidTemporaryVariable: aName ].! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 6/25/2017 21:53:31'! - warnIf: aNewVariable isDefinedAsInstanceVariableInHierarchyOf: aClass - - | classDefiningNewVariable | - - classDefiningNewVariable := aClass whichClassDefinesInstanceVariable: aNewVariable ifNone: [ ^self ]. - self warn: aNewVariable willHideInstanceVariableDefinedIn: classDefiningNewVariable ! ! -!RenameTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/25/2017 21:53:31'! - errorMessageForInvalidTemporaryVariable: aName - - ^ '''' , aName , ''' is not a valid temporary variable name'.! ! -!RenameTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/25/2017 21:53:31'! - errorMessageForNewTemporaryVariable: aNewVariable isAlreadyDefinedIn: aMethodNode - - ^aNewVariable, ' is already defined in ', aMethodNode classAndSelector ! ! -!RenameTemporary class methodsFor: 'exceptions' stamp: 'HAW 10/4/2017 17:04:37'! - errorMessageForTemporaryVariable: aVariable notDefinedIn: aMethodNode - - ^'Temporary variable ', aVariable, ' is not defined in ', aMethodNode classAndSelector ! ! -!RenameTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/25/2017 21:53:31'! - newVariableCanNotBeEmptyErrorMessage - - ^'New variable can not be empty'! ! -!RenameTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/25/2017 21:53:31'! - signalInvalidTemporaryVariable: aName - - ^ self refactoringError: (self errorMessageForInvalidTemporaryVariable: aName).! ! -!RenameTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/25/2017 21:53:31'! - signalNewTemporaryVariable: aNewVariable isAlreadyDefinedIn: aMethodNode - - self refactoringError: (self errorMessageForNewTemporaryVariable: aNewVariable isAlreadyDefinedIn: aMethodNode )! ! -!RenameTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/25/2017 21:53:31'! - signalNewVariableCanNotBeEmpty - - self refactoringError: self newVariableCanNotBeEmptyErrorMessage! ! -!RenameTemporary class methodsFor: 'exceptions' stamp: 'HAW 10/4/2017 17:04:27'! - signalTemporaryVariable: aVariable notDefinedIn: aMethodNode - - self refactoringError: (self errorMessageForTemporaryVariable: aVariable notDefinedIn: aMethodNode)! ! -!RenameTemporary class methodsFor: 'instance creation' stamp: 'HAW 6/25/2017 21:53:31'! - from: anOldVariable to: aNewVariable in: aMethodNode - - | trimmedNewVariable | - - trimmedNewVariable := aNewVariable withBlanksTrimmed. - - self assert: anOldVariable isDefinedIn: aMethodNode. - self assertIsNotEmpty: trimmedNewVariable. - self assertIsValidVariableName: trimmedNewVariable. - self assert: trimmedNewVariable isNotDefinedIn: aMethodNode. - - self warnIf: trimmedNewVariable isDefinedAsInstanceVariableInHierarchyOf: aMethodNode methodClass. - - ^self new initializeFrom: anOldVariable to: trimmedNewVariable in: aMethodNode -! ! -!RenameTemporary class methodsFor: 'warnings' stamp: 'HAW 6/25/2017 21:53:31'! - warn: aNewVariable willHideInstanceVariableDefinedIn: aClass - - self refactoringWarning: (self warningMessageFor: aNewVariable willHideInstanceVariableDefinedIn: aClass)! ! -!RenameTemporary class methodsFor: 'warnings' stamp: 'HAW 6/25/2017 21:53:31'! - warningMessageFor: aNewVariable willHideInstanceVariableDefinedIn: aClass - - ^aNewVariable, ' will hide instance variable defined in ', aClass name! ! -!SafelyRemoveClass methodsFor: 'applying' stamp: 'HAW 8/1/2018 16:42:17'! -apply - - self removeWithAllSubclasses: classToRemove. - ! ! -!SafelyRemoveClass methodsFor: 'applying - private' stamp: 'HAW 8/1/2018 16:42:17'! - removeWithAllSubclasses: aClassToRemove - - "I have to do 'subclasses do:' and not 'subclassesDo:' because removing a class modifies parent's subclasses collection. - #subclasses returns a copy of superclass' subclasses collection -Hernan" - aClassToRemove subclasses do: [ :aSubclassToRemove | self removeWithAllSubclasses: aSubclassToRemove ]. - aClassToRemove removeFromSystem. - ! ! -!SafelyRemoveClass methodsFor: 'initialization' stamp: 'HAW 8/1/2018 16:42:17'! - initializeOf: aClassToSafetelyRemove - - classToRemove := aClassToSafetelyRemove ! ! -!SafelyRemoveClass class methodsFor: 'instance creation' stamp: 'HAW 8/1/2018 16:42:17'! - of: aClassToSafelyRemove - - | theNonMetaclassToRemove | - - theNonMetaclassToRemove := aClassToSafelyRemove theNonMetaClass. - self assertNoReferencesTo: theNonMetaclassToRemove. - self warnIfHasSubclasses: theNonMetaclassToRemove. - - ^self new initializeOf: theNonMetaclassToRemove ! ! -!SafelyRemoveClass class methodsFor: 'pre-conditions' stamp: 'HAW 8/1/2018 16:42:17'! - assertNoReferencesTo: aClassToSafelyRemove - - | references withAllSubclasses withAllSubclassesNames referenced | - - withAllSubclasses := aClassToSafelyRemove withAllSubclasses. - withAllSubclassesNames := withAllSubclasses collect: [:aClass | aClass name ]. - references :=OrderedCollection new. - referenced := OrderedCollection new. - - withAllSubclasses do: [ :aClass | | allReferences referencesOutsideHierarchy | - allReferences := aClass allCallsOn. - referencesOutsideHierarchy := allReferences reject: [ :aReference | withAllSubclassesNames includes: aReference classSymbol ]. - referencesOutsideHierarchy notEmpty ifTrue: [ - referenced add: aClass. - references addAll: referencesOutsideHierarchy ]]. - - references notEmpty ifTrue: [ self signalCanNotRemove: aClassToSafelyRemove dueToReferences: references toAll: referenced ]! ! -!SafelyRemoveClass class methodsFor: 'pre-conditions' stamp: 'HAW 8/1/2018 16:42:17'! - warnIfHasSubclasses: aClassToSafelyRemove - - | allSubclasses | - - allSubclasses := aClassToSafelyRemove allSubclasses. - allSubclasses isEmpty ifFalse: [ self warn: aClassToSafelyRemove hasSubclasses: allSubclasses ]! ! -!SafelyRemoveClass class methodsFor: 'exceptions' stamp: 'HAW 8/1/2018 18:10:36'! - errorMessageForCanNotRemove: aClassToSafelyRemove dueToReferencesToAll: referenced - - ^String streamContents: [ :stream | - stream - nextPutAll: aClassToSafelyRemove name asString; - nextPutAll: ' can not be removed '. - - referenced size = 1 - ifTrue: [ (referenced includes: aClassToSafelyRemove) - ifTrue: [ stream nextPutAll: 'because it has references' ] - ifFalse: [ stream - nextPutAll: 'because it subclass, '; - nextPutAll: referenced anyOne name asString; - nextPutAll: ', has references' ]] - ifFalse: [ (referenced includes: aClassToSafelyRemove) - ifTrue: [ stream - nextPutAll: 'due to references to: '; - nextPutAll: referenced asCommaStringAnd ] - ifFalse: [ stream - nextPutAll: 'due to references to its subclasses: '; - nextPutAll: referenced asCommaStringAnd ]]]! ! -!SafelyRemoveClass class methodsFor: 'exceptions' stamp: 'HAW 8/17/2018 16:34:16'! - signalCanNotRemove: aClassToSafelyRemove dueToReferences: references toAll: allReferenced - - self - canNotRefactorDueToReferencesError: (self errorMessageForCanNotRemove: aClassToSafelyRemove dueToReferencesToAll: allReferenced) - references: references - to: aClassToSafelyRemove - ! ! -!SafelyRemoveClass class methodsFor: 'warnings' stamp: 'HAW 8/1/2018 16:42:17'! - warn: aClassToSafelyRemove hasSubclasses: allSubclasses - - self refactoringWarning: (self warningMessageFor: aClassToSafelyRemove hasSubclasses: allSubclasses)! ! -!SafelyRemoveClass class methodsFor: 'warnings' stamp: 'HAW 8/1/2018 18:24:31'! - warningMessageFor: aClassToSafelyRemove hasSubclasses: allSubclasses - - ^String streamContents: [ :stream | - stream nextPutAll: aClassToSafelyRemove name asString. - allSubclasses size = 1 - ifTrue: [ stream nextPutAll: ' has a subclass' ] - ifFalse: [ stream - nextPutAll: ' has '; - print: allSubclasses size; - nextPutAll: ' subclasses' ]. - stream nextPutAll: ' that will be removed']. - - ! ! -!RefactoringApplier methodsFor: 'refactoring - applying' stamp: 'HAW 6/5/2017 18:06:39'! - applyRefactoring - - changes := refactoring apply! ! -!RefactoringApplier methodsFor: 'refactoring - creation' stamp: 'HAW 6/5/2017 18:05:46'! - createRefactoring - - self subclassResponsibility ! ! -!RefactoringApplier methodsFor: 'refactoring - creation' stamp: 'HAW 6/5/2017 18:05:20'! - createRefactoringHandlingRefactoringExceptions - - self valueHandlingRefactoringExceptions: [ refactoring := self createRefactoring ] - ! ! -!RefactoringApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 6/5/2017 14:24:04'! - endRequest - - ^requestExitBlock value! ! -!RefactoringApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 6/5/2017 19:04:16'! - requestRefactoringParameters - - self subclassResponsibility ! ! -!RefactoringApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 6/5/2017 19:05:35'! - requestRefactoringParametersHandlingRefactoringExceptions - - self valueHandlingRefactoringExceptions: [ self requestRefactoringParameters ] - ! ! -!RefactoringApplier methodsFor: 'exception handling' stamp: 'HAW 8/17/2018 16:37:38'! - browseReferencesOn: aCanNotRefactorDueToReferencesError - - Smalltalk - browseMessageList: aCanNotRefactorDueToReferencesError references - name: (self referencesBrowserTitleOn: aCanNotRefactorDueToReferencesError) - autoSelect: true -! ! -!RefactoringApplier methodsFor: 'exception handling' stamp: 'HAW 8/17/2018 16:37:55'! - handleCanNotRefactorDueToReferencesError: aCanNotRefactorDueToReferencesError - - | options answer question | - - options := -'Browse references -Cancel'. - - question := PopUpMenu labels: options icons: #(mailForwardIcon cancelIcon). - answer := question startUpWithCaption: aCanNotRefactorDueToReferencesError messageText. - - answer = 1 ifTrue: [ self browseReferencesOn: aCanNotRefactorDueToReferencesError ]. - self endRequest.! ! -!RefactoringApplier methodsFor: 'exception handling' stamp: 'HAW 6/5/2017 18:47:40'! - handleRefactoringError: aRefactoringError - - self inform: aRefactoringError messageText. - self endRequest ! ! -!RefactoringApplier methodsFor: 'exception handling' stamp: 'HAW 8/1/2018 18:15:21'! - handleRefactoringWarning: aRefactoringWarning - - (self confirm: aRefactoringWarning messageText, '. Continue?') - ifTrue: [ aRefactoringWarning resume ] - ifFalse: [ self endRequest]! ! -!RefactoringApplier methodsFor: 'exception handling' stamp: 'HAW 8/17/2018 16:38:07'! - referencesBrowserTitleOn: aCanNotRefactorDueToReferencesError - - ^'References to ', aCanNotRefactorDueToReferencesError referencee asString! ! -!RefactoringApplier methodsFor: 'exception handling' stamp: 'HAW 8/17/2018 16:35:47'! - valueHandlingRefactoringExceptions: aBlock - - ^[[aBlock - on: Refactoring refactoringWarningClass - do: [ :aRefactoringWarning | self handleRefactoringWarning: aRefactoringWarning ]] - on: Refactoring canNotRefactorDueToReferencesErrorClass - do: [ :aCanNotRefactorDueToReferencesError | self handleCanNotRefactorDueToReferencesError: aCanNotRefactorDueToReferencesError ]] - on: Refactoring refactoringErrorClass - do: [ :aRefactoringError | self handleRefactoringError: aRefactoringError ] - ! ! -!RefactoringApplier methodsFor: 'request information' stamp: 'HAW 6/11/2017 19:22:50'! - request: aLabel - - ^self request: aLabel initialAnswer: '' -! ! -!RefactoringApplier methodsFor: 'request information' stamp: 'HAW 6/5/2017 16:03:04'! - request: aLabel initialAnswer: anAnswer - - ^self request: aLabel initialAnswer: anAnswer onCancel: requestExitBlock ! ! -!RefactoringApplier methodsFor: 'request information' stamp: 'HAW 6/5/2017 16:03:30'! - request: aLabel initialAnswer: anAnswer onCancel: cancelBlock - - ^FillInTheBlankMorph request: aLabel initialAnswer: anAnswer onCancel: cancelBlock ! ! -!RefactoringApplier methodsFor: 'refactoring - changes' stamp: 'HAW 6/5/2017 18:06:53'! - showChanges - - self subclassResponsibility - ! ! -!RefactoringApplier methodsFor: 'evaluating' stamp: 'HAW 6/5/2017 19:05:50'! - value - - requestExitBlock := [ ^self ]. - - self - requestRefactoringParametersHandlingRefactoringExceptions; - createRefactoringHandlingRefactoringExceptions; - applyRefactoring; - showChanges - - ! ! -!RefactoringApplier class methodsFor: 'value handling exceptions' stamp: 'HAW 1/7/2019 15:28:18'! - createAndValueHandlingExceptions: creationBlock - - | refactoring | - - refactoring := creationBlock - on: Refactoring refactoringErrorClass - do: [ :refactoringError | ^self inform: refactoringError messageText ]. - - refactoring value ! ! -!AddInstanceVariableApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/30/2017 18:12:33'! - askNewVariableName - - newInstanceVariable := self request: self newVariableNameLabel. - newInstanceVariable := newInstanceVariable withBlanksTrimmed ! ! -!AddInstanceVariableApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/30/2017 18:12:47'! - newVariableNameLabel - - ^'Enter new variable name:'! ! -!AddInstanceVariableApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 6/11/2017 19:18:00'! - requestRefactoringParameters - - self askNewVariableName! ! -!AddInstanceVariableApplier methodsFor: 'refactoring - creation' stamp: 'HAW 6/11/2017 19:19:25'! - createRefactoring - - ^AddInstanceVariable named: newInstanceVariable to: classToRefactor. - ! ! -!AddInstanceVariableApplier methodsFor: 'refactoring - changes' stamp: 'HAW 1/7/2019 14:41:01'! -informChangesToBrowser - - browser acceptedContentsChanged! ! -!AddInstanceVariableApplier methodsFor: 'refactoring - changes' stamp: 'HAW 6/11/2017 19:20:03'! - showChanges - - self informChangesToBrowser! ! -!AddInstanceVariableApplier methodsFor: 'initialization' stamp: 'HAW 1/7/2019 14:40:44'! - initializeOn: aBrowser for: aClassToRefactor - - browser := aBrowser. - classToRefactor := aClassToRefactor ! ! -!AddInstanceVariableApplier class methodsFor: 'instance creation' stamp: 'HAW 1/7/2019 14:40:37'! - on: aBrowser for: aClassToRefactor - - ^self new initializeOn: aBrowser for: aClassToRefactor -! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 1/3/2019 07:57:24'! - askForImplementosAndSenders - - self - askScope; - calculateImplementorsAndSenders; - startWizard ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/18/2018 17:21:12'! - askScope - - | scopeMenu | - - scopeMenu := PopUpMenu labelArray: self scopeOptionLabels. - scopeChoice := scopeMenu startUpWithCaption: 'Select Refactoring Scope'. - scopeChoice = 0 ifTrue: [ self endRequest ]. - ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 12/13/2018 17:41:06'! - calculateImplementorsAndSenders - - implementors := IdentitySet new. - senders := IdentitySet new. - - scopeChoice = 1 ifTrue: [ ^self implementorsAndSendersForClass ]. - scopeChoice = 2 ifTrue: [ ^self implementorsAndSendersForHierarchy ]. - scopeChoice = 3 ifTrue: [ ^self implementorsAndSendersInCategory ]. - scopeChoice = 4 ifTrue: [ ^self implementorsAndSendersInCategoryAndHierarchy ]. - scopeChoice = 5 ifTrue: [ ^self implementorsAndSendersInSystem ]. - - self error: 'Unknown scope option' - - ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/18/2018 17:00:51'! - implementorsAndSendersForClass - - ^self refactoringClass addImplementorsOf: oldSelector to: implementors andSendersTo: senders forClassAndMetaOf: implementingClass! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/18/2018 17:00:56'! - implementorsAndSendersForHierarchy - - ^self refactoringClass addImplementorsOf: oldSelector to: implementors andSendersTo: senders inHierarchyOf: implementingClass! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/18/2018 17:01:01'! - implementorsAndSendersInCategory - - ^self refactoringClass - addImplementorsOf: oldSelector - to: implementors - andSendersTo: senders - inCategory: implementingClass category - organizedBy: SystemOrganization! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/18/2018 17:01:05'! - implementorsAndSendersInCategoryAndHierarchy - - ^self refactoringClass - addImplementorsOf: oldSelector - to: implementors - andSendersTo: senders - inCategoriesAndHierarchyOf: implementingClass - organizedBy: SystemOrganization ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/18/2018 17:01:15'! - implementorsAndSendersInSystem - - ^self refactoringClass addImplementorsOf: oldSelector to: implementors andSendersTo: senders inSystem: Smalltalk ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 12/13/2018 17:41:33'! -scopeOptionLabels - - ^{'In Class'. 'In Hierarchy'. 'In Category'. 'In Hierarchy and its Categories'. 'In System'}.! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 1/7/2019 11:17:34'! - startWizard - - ChangeSelectorImplementorsStepWindow openFrom: self! ! -!ChangeSelectorApplier methodsFor: 'accessing' stamp: 'HAW 8/18/2018 17:02:26'! - implementors - - ^implementors ! ! -!ChangeSelectorApplier methodsFor: 'accessing' stamp: 'HAW 8/18/2018 17:02:29'! - implementors: implementorsCollection - - implementors := implementorsCollection ! ! -!ChangeSelectorApplier methodsFor: 'accessing' stamp: 'HAW 8/18/2018 17:02:33'! - oldSelector - - ^oldSelector ! ! -!ChangeSelectorApplier methodsFor: 'accessing' stamp: 'HAW 8/18/2018 17:02:37'! - senders - - ^senders ! ! -!ChangeSelectorApplier methodsFor: 'accessing' stamp: 'HAW 8/18/2018 17:02:41'! - senders: sendersCollection - - senders := sendersCollection ! ! -!ChangeSelectorApplier methodsFor: 'accessing' stamp: 'HAW 1/7/2019 11:16:36'! - wizardStepWindow: aWizarStepWindow - - wizardStepWindow := aWizarStepWindow ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - changes' stamp: 'HAW 1/7/2019 11:08:33'! - closeBrowser - - wizardStepWindow delete. - ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - changes' stamp: 'HAW 10/10/2018 19:50:39'! - doNotShowChanges - - shouldShowChanges := false! ! -!ChangeSelectorApplier methodsFor: 'refactoring - changes' stamp: 'HAW 1/7/2019 14:09:10'! - informChangesToBrowser - - "If the selected message is not the same as the oldSelector, that is the selector being renamed, - then it implies that we are renaming a selector sent in the source code of the selected message then - I don't have to change the selected message in the browser - Hernan" - browser selectedMessageName = oldSelector ifTrue: [ - browser setSelector: refactoring newSelector ]! ! -!ChangeSelectorApplier methodsFor: 'refactoring - changes' stamp: 'HAW 8/18/2018 17:02:52'! - messageSetWindowClass - - ^MessageSetWindow - ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - changes' stamp: 'HAW 10/10/2018 19:52:08'! - showChanges - - self showChangesInMessageSetWindow! ! -!ChangeSelectorApplier methodsFor: 'refactoring - changes' stamp: 'HAW 8/18/2018 17:28:30'! - showChangesInMessageSetWindow - - self messageSetWindowClass openMessageList: changes asSortedCollection label: 'Changed methods' ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - creation' stamp: 'HAW 1/7/2019 13:51:04'! -createAndApplyRefactoring - - self - createRefactoringHandlingRefactoringExceptions; - applyRefactoring; - informChangesToBrowser. - - shouldShowChanges ifTrue: [ self showChanges ] - - ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - creation' stamp: 'HAW 1/3/2019 08:46:41'! - createAndApplyRefactoringWhenNoSendersAndOneImplementor: anImplementor - - implementors := Array with: anImplementor. - senders := #(). - shouldShowChanges := false. - - self createAndApplyRefactoring ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - creation' stamp: 'HAW 8/18/2018 17:03:58'! - refactoringClass - - self subclassResponsibility ! ! -!ChangeSelectorApplier methodsFor: 'initialization' stamp: 'HAW 1/7/2019 13:47:34'! - initializeOn: aBrowser for: aSelector in: aClass - - oldSelector := aSelector. - implementingClass := aClass. - browser := aBrowser. - shouldShowChanges := true.! ! -!ChangeSelectorApplier methodsFor: 'evaluation' stamp: 'HAW 1/7/2019 14:59:52'! - ifHasNoSendersAndOneImplementor: trueBlock ifNot: falseBlock - - | allImplementors | - - allImplementors := Smalltalk allImplementorsOf: oldSelector. - - "I could try to see if there is one sender and that that sender is in the same method beeing renamed. That could - mean that it is a recursive call but I should also see if the receiver is self to be sure because if it is other 'type' of - object the rename could not be safe. To complex for a small posibility - Hernan" - (allImplementors size = 1 and: [ (Smalltalk allCallsOn: oldSelector) isEmpty ]) - ifTrue: [ trueBlock value: allImplementors anyOne compiledMethod ] - ifFalse: falseBlock! ! -!ChangeSelectorApplier methodsFor: 'evaluation' stamp: 'HAW 1/3/2019 08:41:27'! - value - - requestExitBlock := [ ^self ]. - - self requestRefactoringParametersHandlingRefactoringExceptions. - - self - ifHasNoSendersAndOneImplementor: [ :anImplementor | self createAndApplyRefactoringWhenNoSendersAndOneImplementor: anImplementor ] - ifNot: [ self askForImplementosAndSenders ]! ! -!ChangeSelectorApplier methodsFor: 'evaluation' stamp: 'HAW 1/3/2019 08:46:11'! - wizardEnded - - requestExitBlock := [ ^self ]. - - self - closeBrowser; - createAndApplyRefactoring.! ! -!ChangeSelectorApplier class methodsFor: 'pre-conditions' stamp: 'HAW 8/18/2018 17:17:52'! - assertCanApplyRefactoringFor: aSelector in: aClass - - self subclassResponsibility ! ! -!ChangeSelectorApplier class methodsFor: 'instance creation' stamp: 'HAW 1/7/2019 13:47:54'! - on: aBrowser for: aSelector in: aClass - - self assertCanApplyRefactoringFor: aSelector in: aClass. - - ^self new initializeOn: aBrowser for: aSelector in: aClass - ! ! -!AddParameterApplier methodsFor: 'refactoring - creation' stamp: 'HAW 8/18/2018 16:46:49'! - createRefactoring - - oldSelector isUnary ifTrue: [ ^self createRefactoringForUnarySelector]. - oldSelector isKeyword ifTrue: [ ^self createRefactoringForKeywordSelector ]. - - self error: 'oldSelector should be unary or keyword!!'! ! -!AddParameterApplier methodsFor: 'refactoring - creation' stamp: 'HAW 9/4/2018 20:24:53'! - createRefactoringForKeywordSelector - - ^self refactoringClass - named: newParameter - at: parameterIndex - initializedWith: newParameterValue - using: newKeyword - toKeywordSelector: oldSelector - implementors: implementors - senders: senders ! ! -!AddParameterApplier methodsFor: 'refactoring - creation' stamp: 'HAW 8/18/2018 16:56:55'! - createRefactoringForUnarySelector - - ^self refactoringClass - named: newParameter - initializedWith: newParameterValue - toUnarySelector: oldSelector - implementors: implementors - senders: senders ! ! -!AddParameterApplier methodsFor: 'refactoring - creation' stamp: 'HAW 8/18/2018 16:56:55'! - refactoringClass - - ^AddParameter! ! -!AddParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 9/4/2018 20:33:41'! - askInsertionIndex - - | methodNode originalMethod parameterNames | - - originalMethod := implementingClass compiledMethodAt: oldSelector. - methodNode := originalMethod methodNode. - parameterNames := methodNode argumentNames. - parameterNames add: 'Add as last parameter'. - - parameterIndex := (PopUpMenu labelArray: parameterNames) startUpWithCaption: 'Add Before?'. - parameterIndex = 0 ifTrue: [self endRequest ]. - - ! ! -!AddParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 9/4/2018 20:33:37'! - askInsertionIndexIfNecessary - - oldSelector isKeyword ifTrue: [ self askInsertionIndex ]. - ! ! -!AddParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/18/2018 17:06:28'! - askNewKeyword - - | enteredString | - - enteredString := self request: 'Enter keyword for new parameter'. - newKeyword := enteredString withBlanksTrimmed asSymbol. - self refactoringClass assertIsValidKeywordForNewParameter: newKeyword! ! -!AddParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/18/2018 17:06:28'! - askNewKeywordIfNecessary - - oldSelector isKeyword ifTrue: [self askNewKeyword]! ! -!AddParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/18/2018 16:56:55'! - askNewParameter - - | enteredString | - - enteredString := self request: 'Enter new parameter name'. - newParameter := enteredString withBlanksTrimmed. - self refactoringClass assertIsValidParameterName: newParameter -! ! -!AddParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/25/2018 11:28:58'! - askNewParameterValue - - | enteredString | - - enteredString := self request: 'Enter parameter value for senders'. - newParameterValue := enteredString withBlanksTrimmed. - self refactoringClass assertNewParameterValueIsNotEmpty: newParameterValue. - self refactoringClass assertNewParameterValueIsValid: newParameterValue. -! ! -!AddParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 1/3/2019 08:01:40'! - requestRefactoringParameters - - self - askNewParameter; - askNewParameterValue; - askInsertionIndexIfNecessary; - askNewKeywordIfNecessary - ! ! -!AddParameterApplier class methodsFor: 'pre-conditions' stamp: 'HAW 8/18/2018 17:18:06'! - assertCanApplyRefactoringFor: aSelector in: aClass - - AddParameter assertCanAddParameterTo: aSelector. - - - ! ! -!RemoveParameterApplier methodsFor: 'refactoring - creation' stamp: 'HAW 9/4/2018 15:15:48'! - createRefactoring - - ^self refactoringClass named: parameterToRemove from: originalMethod implementors: implementors senders: senders ! ! -!RemoveParameterApplier methodsFor: 'refactoring - creation' stamp: 'HAW 9/4/2018 15:15:00'! - refactoringClass - - ^RemoveParameter! ! -!RemoveParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 9/4/2018 15:30:50'! - askParameterToRemove - - | methodNode parameterNames | - - originalMethod := implementingClass compiledMethodAt: oldSelector. - methodNode := originalMethod methodNode. - parameterNames := methodNode argumentNames. - - parameterNames size = 1 - ifTrue: [ parameterToRemove := parameterNames first ] - ifFalse: [ parameterToRemove := self selectParameterToRemoveForm: parameterNames ]. - - ! ! -!RemoveParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 1/3/2019 08:01:51'! - requestRefactoringParameters - - self askParameterToRemove - - ! ! -!RemoveParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 9/4/2018 15:36:30'! - selectParameterToRemoveForm: parameterNames - - | parameterIndex | - - parameterIndex := (PopUpMenu labelArray: parameterNames) startUpWithCaption: 'Select parameter to remove'. - parameterIndex = 0 ifTrue: [self endRequest ]. - - ^parameterNames at: parameterIndex.! ! -!RemoveParameterApplier class methodsFor: 'pre-conditions' stamp: 'HAW 9/4/2018 15:17:09'! - assertCanApplyRefactoringFor: aSelector in: aClass - - RemoveParameter assertCanRemoveParameterFrom: aSelector. - - - ! ! -!RenameSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 6/5/2017 17:02:06'! - askNewSelector - - | enteredString | - - enteredString := self request: 'Enter new selector:' initialAnswer: oldSelector. - newSelector := enteredString withBlanksTrimmed asSymbol. - -! ! -!RenameSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/18/2018 16:56:24'! - assertCanRenameSelector - - self refactoringClass assertIsValidToRenameFrom: oldSelector to: newSelector. - ! ! -!RenameSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 1/3/2019 08:02:00'! - requestRefactoringParameters - - self - askNewSelector; - assertCanRenameSelector - ! ! -!RenameSelectorApplier methodsFor: 'refactoring - creation' stamp: 'HAW 8/18/2018 16:56:24'! - createRefactoring - - ^self refactoringClass from: oldSelector to: newSelector implementors: implementors senders: senders. - ! ! -!RenameSelectorApplier methodsFor: 'refactoring - creation' stamp: 'HAW 8/18/2018 17:04:02'! - refactoringClass - - ^RenameSelector ! ! -!RenameSelectorApplier class methodsFor: 'pre-conditions' stamp: 'HAW 8/18/2018 17:24:18'! - assertCanApplyRefactoringFor: aSelector in: aClass - - ! ! -!InsertSuperclassApplier methodsFor: 'initialization' stamp: 'FJG 8/5/2018 22:31:03'! - initializeOn: aBrowser for: aClass - browser _ aBrowser. - classToRefactor _ aClass.! ! -!InsertSuperclassApplier methodsFor: 'refactoring - parameters request' stamp: 'FJG 8/5/2018 22:31:31'! - askNewSuperclassName - newSuperclassName _ self - request: 'Enter new superclass name:'. - newSuperclassName _ newSuperclassName withBlanksTrimmed asSymbol.! ! -!InsertSuperclassApplier methodsFor: 'refactoring - parameters request' stamp: 'FJG 8/5/2018 22:29:07'! - requestRefactoringParameters - - self askNewSuperclassName! ! -!InsertSuperclassApplier methodsFor: 'refactoring - creation' stamp: 'HAW 8/13/2018 15:55:10'! - createRefactoring - - ^InsertSuperclass to: classToRefactor named: newSuperclassName! ! -!InsertSuperclassApplier methodsFor: 'refactoring - changes' stamp: 'FJG 8/5/2018 22:33:49'! - showChanges - - browser changed: #classList. -! ! -!InsertSuperclassApplier class methodsFor: 'instance creation' stamp: 'FJG 8/5/2018 22:27:02'! - on: aBrowser for: aClass - - ^self new initializeOn: aBrowser for: aClass! ! -!RemoveAllUnreferencedInstanceVariablesApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/2/2018 16:11:13'! - requestRefactoringParameters - - ! ! -!RemoveAllUnreferencedInstanceVariablesApplier methodsFor: 'refactoring - creation' stamp: 'HAW 8/2/2018 16:15:05'! - createRefactoring - - ^RemoveAllUnreferencedInstanceVariables from: classToRefactor ! ! -!RemoveAllUnreferencedInstanceVariablesApplier methodsFor: 'refactoring - changes' stamp: 'HAW 1/7/2019 14:42:50'! - informChangesToBrowser - - browser acceptedContentsChanged! ! -!RemoveAllUnreferencedInstanceVariablesApplier methodsFor: 'refactoring - changes' stamp: 'HAW 8/2/2018 16:20:16'! - showChanges - - | removedInstanceVariablesMessage | - - self informChangesToBrowser. - removedInstanceVariablesMessage := changes isEmpty - ifTrue: [ 'No instance variable was removed' ] - ifFalse: [ changes size = 1 - ifTrue: [ changes first, ' was removed' ] - ifFalse: [ changes asCommaStringAnd, ' were removed' ]]. - - self inform: removedInstanceVariablesMessage! ! -!RemoveAllUnreferencedInstanceVariablesApplier methodsFor: 'initialization' stamp: 'HAW 1/7/2019 14:42:41'! -initializeOn: aBrowser for: aClassToRefactor - - browser := aBrowser. - classToRefactor := aClassToRefactor ! ! -!RemoveAllUnreferencedInstanceVariablesApplier class methodsFor: 'instance creation' stamp: 'HAW 1/7/2019 14:42:34'! - on: aBrowser for: aClassToRefactor - - ^self new initializeOn: aBrowser for: aClassToRefactor -! ! -!RemoveInstanceVariableApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/30/2017 18:22:28'! - chooseInstanceVariable - - classToRefactor - chooseDefiningInstanceVariableAlphabeticallyWith: self selectVariableLabel - thenDo: [ :aVariableToRemove | ^variableToRemove := aVariableToRemove ]. - self endRequest - - ! ! -!RemoveInstanceVariableApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 6/17/2017 19:51:21'! - requestRefactoringParameters - - self chooseInstanceVariable. - - ! ! -!RemoveInstanceVariableApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/30/2017 18:22:41'! - selectVariableLabel - - ^'Select instance variable to remove'! ! -!RemoveInstanceVariableApplier methodsFor: 'refactoring - creation' stamp: 'HAW 6/17/2017 19:50:03'! - createRefactoring - - ^RemoveInstanceVariable named: variableToRemove from: classToRefactor ! ! -!RemoveInstanceVariableApplier methodsFor: 'refactoring - changes' stamp: 'HAW 1/7/2019 14:43:43'! - informChangesToBrowser - - browser acceptedContentsChanged! ! -!RemoveInstanceVariableApplier methodsFor: 'refactoring - changes' stamp: 'HAW 6/17/2017 19:50:31'! - showChanges - - self informChangesToBrowser! ! -!RemoveInstanceVariableApplier methodsFor: 'initialization' stamp: 'HAW 1/7/2019 14:43:37'! - initializeOn: aBrowser for: aClassToRefactor - - browser := aBrowser. - classToRefactor := aClassToRefactor ! ! -!RemoveInstanceVariableApplier class methodsFor: 'instance creation' stamp: 'HAW 1/7/2019 14:43:28'! - on: aBrowser for: aClassToRefactor - - ^self new initializeOn: aBrowser for: aClassToRefactor -! ! -!RenameClassApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 6/5/2017 16:02:13'! - askNewClassName - - newClassName := self request: 'Enter new name:' initialAnswer: classToRename name. - newClassName := newClassName withBlanksTrimmed asSymbol. - ! ! -!RenameClassApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 6/5/2017 19:05:08'! - requestRefactoringParameters - - self askNewClassName! ! -!RenameClassApplier methodsFor: 'refactoring - creation' stamp: 'HAW 6/5/2017 18:07:28'! - createRefactoring - - ^RenameClass from: classToRename to: newClassName in: Smalltalk undeclared: Undeclared. - -! ! -!RenameClassApplier methodsFor: 'refactoring - changes' stamp: 'HAW 6/5/2017 16:05:00'! - informChangesToBrowser - - browser changed: #classList. - browser selectClass: classToRename. -! ! -!RenameClassApplier methodsFor: 'refactoring - changes' stamp: 'HAW 6/5/2017 18:08:13'! - openChangedMethods - - changes ifNotEmpty: [ - MessageSetWindow openMessageList: changes label: 'Renamed references' autoSelect: newClassName ] -! ! -!RenameClassApplier methodsFor: 'refactoring - changes' stamp: 'HAW 6/5/2017 18:07:55'! - showChanges - - self - informChangesToBrowser; - openChangedMethods -! ! -!RenameClassApplier methodsFor: 'initialization' stamp: 'HAW 6/5/2017 16:55:57'! - initializeOn: aBrowser for: aClass - - browser := aBrowser. - classToRename := aClass. - ! ! -!RenameClassApplier class methodsFor: 'instance creation' stamp: 'HAW 6/5/2017 12:27:45'! - on: aBrowser for: aClass - - ^self new initializeOn: aBrowser for: aClass! ! -!RenameInstanceVariableApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 6/5/2017 16:49:50'! - askNewVariableName - - newInstanceVariable := self request: 'Enter new name:' initialAnswer: oldInstanceVariable. - newInstanceVariable := newInstanceVariable withBlanksTrimmed ! ! -!RenameInstanceVariableApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 11/28/2018 19:37:54'! - chooseInstanceVariable - - oldInstanceVariable ifNotNil: [ ^self ]. - - classToRefactor - chooseDefiningInstanceVariableAlphabeticallyWith: self selectVariableLabel - thenDo: [ :anOldInstanceVariable | ^oldInstanceVariable := anOldInstanceVariable ]. - self endRequest ! ! -!RenameInstanceVariableApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 6/5/2017 19:05:16'! - requestRefactoringParameters - - self - chooseInstanceVariable; - askNewVariableName! ! -!RenameInstanceVariableApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/30/2017 17:27:22'! - selectVariableLabel - - ^'Select instance variable to rename'! ! -!RenameInstanceVariableApplier methodsFor: 'refactoring - creation' stamp: 'HAW 6/5/2017 18:09:13'! - createRefactoring - - ^RenameInstanceVariable from: oldInstanceVariable to: newInstanceVariable in: classToRefactor. - ! ! -!RenameInstanceVariableApplier methodsFor: 'refactoring - changes' stamp: 'HAW 11/28/2018 19:38:47'! - informChangesToBrowser - - browser acceptedContentsChanged! ! -!RenameInstanceVariableApplier methodsFor: 'refactoring - changes' stamp: 'HAW 8/30/2017 17:30:22'! - openChangedMethods - - changes ifNotEmpty: [ self openChangedMethodsWhenChangesNotEmpty ]! ! -!RenameInstanceVariableApplier methodsFor: 'refactoring - changes' stamp: 'HAW 8/30/2017 17:30:13'! -openChangedMethodsWhenChangesNotEmpty - - MessageSetWindow openMessageList: changes label: 'Renamed references' autoSelect: newInstanceVariable ! ! -!RenameInstanceVariableApplier methodsFor: 'refactoring - changes' stamp: 'HAW 6/5/2017 18:09:30'! - showChanges - - self - informChangesToBrowser; - openChangedMethods ! ! -!RenameInstanceVariableApplier methodsFor: 'initialization' stamp: 'HAW 11/28/2018 19:40:02'! - initializeOn: aBrowserWindow for: anOldInstanceVariable at: aClassToRefactor - - browser := aBrowserWindow. - classToRefactor := aClassToRefactor. - oldInstanceVariable := anOldInstanceVariable ! ! -!RenameInstanceVariableApplier class methodsFor: 'instance creation' stamp: 'HAW 11/29/2018 20:19:06'! - on: aBrowser at: aClassToRefactor - - ^self new initializeOn: aBrowser for: nil at: aClassToRefactor -! ! -!RenameInstanceVariableApplier class methodsFor: 'instance creation' stamp: 'HAW 11/29/2018 20:18:59'! - on: aBrowser for: anInstanceVariableName at: aClassToRefactor - - ^self new initializeOn: aBrowser for: anInstanceVariableName at: aClassToRefactor ! ! -!RenameTemporaryApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 6/25/2017 21:37:58'! - askNewVariableName - - newVariable := (self request: 'Enter new name:' initialAnswer: oldVariable) withBlanksTrimmed ! ! -!RenameTemporaryApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 11/28/2018 19:42:45'! - chooseTemporaryVariable - - | variables | - - oldVariable ifNotNil: [ ^self ]. - - variables := methodNode tempNames. - variables isEmpty - ifTrue: [ self noTemporaryToRename ] - ifFalse: [ self chooseTemporaryVariableFrom: variables ] - - ! ! -!RenameTemporaryApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 10/4/2017 17:15:17'! - chooseTemporaryVariableFrom: variables - - | selection | - - selection := smalltalkEditor selection string withBlanksTrimmed. - oldVariable := (self is: selection temporaryVariableFrom: variables) - ifTrue: [ selection ] - ifFalse: [ self selectTemporaryVariableFrom: variables]! ! -!RenameTemporaryApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 10/4/2017 17:13:25'! - is: selection temporaryVariableFrom: variables - - ^smalltalkEditor hasSelection and: [variables includes: selection]! ! -!RenameTemporaryApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 10/4/2017 17:09:43'! - noTemporaryToRename - - self inform: 'There are no temporary to rename'. - self endRequest ! ! -!RenameTemporaryApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 6/25/2017 21:29:58'! - requestRefactoringParameters - - self - chooseTemporaryVariable; - askNewVariableName! ! -!RenameTemporaryApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 10/4/2017 17:16:25'! -selectTemporaryVariableFrom: variables - - | selectionIndex | - - selectionIndex := (PopUpMenu labelArray: variables lines: #()) startUpWithCaption: 'Select temporary to rename'. - - ^selectionIndex = 0 - ifTrue: [ self endRequest ] - ifFalse: [ variables at: selectionIndex ]! ! -!RenameTemporaryApplier methodsFor: 'refactoring - creation' stamp: 'HAW 6/25/2017 21:54:40'! - createRefactoring - - ^RenameTemporary from: oldVariable to: newVariable in: methodNode - ! ! -!RenameTemporaryApplier methodsFor: 'initialization' stamp: 'HAW 11/28/2018 19:43:15'! - initializeOn: aSmalltalkEditor for: aTemporary - - smalltalkEditor := aSmalltalkEditor. - classToRefactor := smalltalkEditor codeProvider selectedClassOrMetaClass. - methodNode := classToRefactor methodNodeFor: smalltalkEditor actualContents string. - oldVariable := aTemporary - ! ! -!RenameTemporaryApplier methodsFor: 'refactoring - changes' stamp: 'HAW 8/9/2018 19:43:41'! - showChanges - - smalltalkEditor actualContents: changes. - smalltalkEditor hasUnacceptedEdits ifFalse: [ - smalltalkEditor - hasUnacceptedEdits: true; - acceptContents ] - ! ! -!RenameTemporaryApplier class methodsFor: 'exceptions' stamp: 'HAW 10/4/2017 17:05:53'! - errorMessageForCanNotParseMethod: anError - - ^ String streamContents: [ :stream | - stream - nextPutAll: 'Method can not be parsed due to:'; - newLine; - nextPutAll: anError messageText ]! ! -!RenameTemporaryApplier class methodsFor: 'instance creation' stamp: 'HAW 11/28/2018 19:44:13'! - on: aSmalltalkEditor for: aTemporary - - ^self new initializeOn: aSmalltalkEditor for: aTemporary! ! -!SafelyRemoveClassApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/1/2018 16:54:40'! - confirmationMessageText - - ^'Are you sure you want to remove ', classToRemove name asString, '?'! ! -!SafelyRemoveClassApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/1/2018 16:52:57'! - requestRefactoringParameters - - (self confirm: self confirmationMessageText) ifFalse: [ self endRequest ]. - - ! ! -!SafelyRemoveClassApplier methodsFor: 'refactoring - creation' stamp: 'HAW 8/1/2018 16:54:33'! - createRefactoring - - ^SafelyRemoveClass of: classToRemove ! ! -!SafelyRemoveClassApplier methodsFor: 'refactoring - changes' stamp: 'HAW 9/14/2018 13:48:37'! - informChangesToBrowser - - browser classListIndex: 0! ! -!SafelyRemoveClassApplier methodsFor: 'refactoring - changes' stamp: 'HAW 9/14/2018 13:47:58'! - showChanges - - self informChangesToBrowser! ! -!SafelyRemoveClassApplier methodsFor: 'initialization' stamp: 'HAW 9/14/2018 13:47:41'! - initializeOn: aBrowser of: aClassToRemove - - browser := aBrowser. - classToRemove := aClassToRemove ! ! -!SafelyRemoveClassApplier class methodsFor: 'instance creation' stamp: 'HAW 9/14/2018 13:47:16'! - on: aBrowser of: aClassToRemove - - ^self new initializeOn: aBrowser of: aClassToRemove ! ! -!RefactoringMenues class methodsFor: 'editor menus' stamp: 'HAW 11/28/2018 20:23:45'! - smalltalkEditorMenuOptions - - ^`{ - { - #itemGroup -> 35. - #itemOrder -> 10. - #label -> 'Rename... (R)'. - #selector -> #contextualRename. - #icon -> #saveAsIcon - } asDictionary - }`! ! -!RefactoringMenues class methodsFor: 'browser menues' stamp: 'HAW 7/7/2018 19:25:26'! - classListMenuOptions - - ^ `{ - { - #itemGroup -> 5. - #itemOrder -> 10. - #label -> 'refactorings...'. - #selector -> #openClassRefactoringMenu. - #icon -> #listAddIcon - } asDictionary. - }`. - ! ! -!RefactoringMenues class methodsFor: 'browser menues' stamp: 'HAW 8/17/2018 17:50:40'! - classRefactoringMenuOptions - - ^ `{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'rename class ...'. - #object -> #model. - #selector -> #renameClass. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'insert superclass ...'. - #object -> #model. - #selector -> #insertSuperclass. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'safely remove class (x)'. - #object -> #model. - #selector -> #safelyRemoveClass. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'add inst var...'. - #selector -> #addInstVar. - #icon -> #listAddIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'rename inst var...'. - #selector -> #renameInstVar. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'remove inst var...'. - #selector -> #removeInstVar. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 40. - #label -> 'remove all unreferenced inst var...'. - #selector -> #removeAllUnreferencedInstVar. - #icon -> #deleteIcon - } asDictionary. - }`. - ! ! -!RefactoringMenues class methodsFor: 'browser menues' stamp: 'HAW 7/7/2018 19:38:01'! - messageListMenuOptions - - ^ `{ - { - #itemGroup -> 5. - #itemOrder -> 10. - #label -> 'refactorings...'. - #selector -> #openMessageRefactoringMenu. - #icon -> #listAddIcon - } asDictionary. - }`. - ! ! -!RefactoringMenues class methodsFor: 'browser menues' stamp: 'HAW 3/6/2019 15:05:24'! -messsageRefactoringMenuOptions - - ^ `{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'rename...'. - #selector -> #renameSelector. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'add parameter...'. - #selector -> #addParameter. - #icon -> #listAddIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'remove parameter...'. - #selector -> #removeParameter. - #icon -> #listRemoveIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'push up'. - #selector -> #pushUpSelector. - #icon -> #goTopIcon - } asDictionary. - }`. - - ! ! -!RefactoringMenues class methodsFor: 'initialization' stamp: 'HAW 12/28/2018 12:51:56'! - initialize - - Editor initialize! ! -!RefactoringMenues class methodsFor: 'shortcuts' stamp: 'HAW 2/4/2019 16:43:23'! - smalltalkEditorCmdShortcutsSpec - - ^#( - #( $R #contextualRename: 'Renames what is under cursor')) -! ! -!RefactoringPrecondition methodsFor: 'exceptions' stamp: 'HAW 3/4/2019 11:48:22'! - refactoringError: aMessage - - Refactoring refactoringError: aMessage.! ! -!RefactoringPrecondition methodsFor: 'warnings' stamp: 'HAW 3/4/2019 13:30:01'! - refactoringWarning: aMessageText - - ^ Refactoring refactoringWarning: aMessageText ! ! -!NewClassPrecondition methodsFor: 'evaluating' stamp: 'HAW 3/3/2019 09:18:10'! - value - - self assertNewClassNameIsNotEmpty. - self assertNewClassNameSymbol. - self assertNewClassNameStartsWithUppercaseLetter. - self assertNewClassNameHasNoSeparators. - self assertNewClassNameDoesNotExistInSystem. - self assertNewClassNameIsNotUndeclaredInUndeclared. - -! ! -!NewClassPrecondition methodsFor: 'evaluating - private' stamp: 'HAW 3/4/2019 11:55:05'! - assertNewClassNameDoesNotExistInSystem - - system at: newClassName ifPresent: [ :value | - value isBehavior - ifTrue: [ self signalClassAlreadyExists] - ifFalse: [ self signalGlobalAlreadyExists]].! ! -!NewClassPrecondition methodsFor: 'evaluating - private' stamp: 'HAW 3/4/2019 11:50:39'! - assertNewClassNameHasNoSeparators - - (newClassName anySatisfy: [:aChar | aChar isSeparator]) - ifTrue: [ self signalNewClassNameCanNotHaveSeparators]! ! -!NewClassPrecondition methodsFor: 'evaluating - private' stamp: 'HAW 3/4/2019 11:50:43'! - assertNewClassNameIsNotEmpty - - newClassName withBlanksTrimmed isEmpty ifTrue: [ self signalNewClassNameCanNotBeEmpty]! ! -!NewClassPrecondition methodsFor: 'evaluating - private' stamp: 'HAW 3/4/2019 11:55:23'! - assertNewClassNameIsNotUndeclaredInUndeclared - - (undeclared includesKey: newClassName) ifTrue: [ self signalNewClassIsUndeclared]! ! -!NewClassPrecondition methodsFor: 'evaluating - private' stamp: 'HAW 3/4/2019 11:50:51'! - assertNewClassNameStartsWithUppercaseLetter - - newClassName first isUppercase ifFalse: [ self signalNewNameMustStartWithUppercaseLetter]! ! -!NewClassPrecondition methodsFor: 'evaluating - private' stamp: 'HAW 3/4/2019 11:50:55'! - assertNewClassNameSymbol - - newClassName isSymbol ifFalse: [ self signalNewNameMustBeSymbol]! ! -!NewClassPrecondition methodsFor: 'initialization' stamp: 'HAW 8/13/2018 16:00:19'! - initializeFor: aNewClassName in: aSystem undeclared: anUndeclaredDictionary - - newClassName := aNewClassName. - system := aSystem. - undeclared := anUndeclaredDictionary ! ! -!NewClassPrecondition methodsFor: 'exceptions' stamp: 'HAW 3/4/2019 11:54:34'! - signalClassAlreadyExists - - self refactoringError: (self class errorMessageForAlreadyExistClassNamed: newClassName).! ! -!NewClassPrecondition methodsFor: 'exceptions' stamp: 'HAW 3/4/2019 11:55:05'! - signalGlobalAlreadyExists - - self refactoringError: (self class errorMessageForAlreadyExistGlobalNamed: newClassName)! ! -!NewClassPrecondition methodsFor: 'exceptions' stamp: 'HAW 3/4/2019 11:55:23'! - signalNewClassIsUndeclared - - self refactoringError: (self class errorMessageForNewClassIsUndeclared: newClassName).! ! -!NewClassPrecondition methodsFor: 'exceptions' stamp: 'HAW 3/4/2019 11:52:08'! - signalNewClassNameCanNotBeEmpty - - self refactoringError: self class newClassNameCanNotBeEmptyErrorMessage! ! -!NewClassPrecondition methodsFor: 'exceptions' stamp: 'HAW 3/4/2019 11:52:13'! - signalNewClassNameCanNotHaveSeparators - - self refactoringError: self class newClassNameCanNotHaveSeparatorsErrorMessage ! ! -!NewClassPrecondition methodsFor: 'exceptions' stamp: 'HAW 3/4/2019 11:52:17'! - signalNewNameMustBeSymbol - - self refactoringError: self class newNameMustBeSymbolErrorMessage.! ! -!NewClassPrecondition methodsFor: 'exceptions' stamp: 'HAW 3/4/2019 11:52:22'! - signalNewNameMustStartWithUppercaseLetter - - self refactoringError: self class newNameMustStartWithUppercaseLetterErrorMessage.! ! -!NewClassPrecondition class methodsFor: 'error messages' stamp: 'HAW 12/13/2018 17:56:51'! - errorMessageForAlreadyExistClassNamed: aNewClassName - - ^'Class named ', aNewClassName, ' already exist'! ! -!NewClassPrecondition class methodsFor: 'error messages' stamp: 'HAW 12/13/2018 17:59:02'! - errorMessageForAlreadyExistGlobalNamed: aNewClassName - - ^'There is already a global variable named ', aNewClassName ! ! -!NewClassPrecondition class methodsFor: 'error messages' stamp: 'HAW 8/13/2018 15:58:18'! - errorMessageForNewClassIsUndeclared: aNewClassName - - ^aNewClassName, ' is undeclared'! ! -!NewClassPrecondition class methodsFor: 'error messages' stamp: 'HAW 8/13/2018 15:58:18'! - newClassNameCanNotBeEmptyErrorMessage - - ^'New class name can not be empty'! ! -!NewClassPrecondition class methodsFor: 'error messages' stamp: 'HAW 3/3/2019 09:20:59'! - newClassNameCanNotHaveSeparatorsErrorMessage - - ^'New class name can not have separators'! ! -!NewClassPrecondition class methodsFor: 'error messages' stamp: 'HAW 8/13/2018 15:58:18'! - newNameMustBeSymbolErrorMessage - - ^'New class name must be a symbol'! ! -!NewClassPrecondition class methodsFor: 'error messages' stamp: 'HAW 8/13/2018 15:58:18'! - newNameMustStartWithUppercaseLetterErrorMessage - - ^'New class name must start with an uppercase letter'! ! -!NewClassPrecondition class methodsFor: 'instance creation' stamp: 'HAW 8/13/2018 17:31:51'! - for: aNewClassName in: aSystem undeclared: anUndeclaredDictionary - - ^self new initializeFor: aNewClassName in: aSystem undeclared: anUndeclaredDictionary -! ! -!NewClassPrecondition class methodsFor: 'evaluation' stamp: 'HAW 8/13/2018 17:37:20'! - valueFor: aNewClassName in: aSystem undeclared: anUndeclaredDictionary - - ^(self for: aNewClassName in: aSystem undeclared: anUndeclaredDictionary) value! ! -!NewInstanceVariablePrecondition methodsFor: 'initialization' stamp: 'HAW 3/3/2019 08:10:58'! - initializeOf: anInstanceVariableName for: aClass - - instVarName := anInstanceVariableName withBlanksTrimmed. - classToAddInstVar := aClass.! ! -!NewInstanceVariablePrecondition methodsFor: 'evaluating' stamp: 'HAW 3/3/2019 08:30:12'! - value - - self assertIsNotEmpty. - self assertIsNotAReservedName. - self assertIsValidInstanceVariableName. - self assertIsNotAlreadyDefined. - - self warnIfIsDefinedInMethods.! ! -!NewInstanceVariablePrecondition methodsFor: 'pre-conditions' stamp: 'HAW 3/3/2019 08:36:05'! - assertIsNotAReservedName - - (ClassBuilder reservedNames includes: instVarName) ifTrue: [ self signalNewInstanceVariableCanNotBeAReservedName ]! ! -!NewInstanceVariablePrecondition methodsFor: 'pre-conditions' stamp: 'HAW 3/3/2019 08:35:12'! - assertIsNotAlreadyDefined - - ^ classToAddInstVar - withClassesThatDefineInHierarchyInstanceVariable: instVarName - do: [ :definingClasses | self signalAlreadyDefinedInAll: definingClasses ] - ifNone: [ ].! ! -!NewInstanceVariablePrecondition methodsFor: 'pre-conditions' stamp: 'FGJ 12/17/2018 15:29:44'! - assertIsNotEmpty - - instVarName isEmpty ifTrue: [ self signalNewVariableCanNotBeEmpty]! ! -!NewInstanceVariablePrecondition methodsFor: 'pre-conditions' stamp: 'HAW 3/3/2019 08:34:17'! - assertIsValidInstanceVariableName - - | scannedNames | - - scannedNames := Scanner new scanFieldNames: instVarName . - scannedNames size = 1 ifFalse: [ self signalInvalidInstanceVariable ]. - scannedNames first = instVarName ifFalse: [ self signalInvalidInstanceVariable ].! ! -!NewInstanceVariablePrecondition methodsFor: 'exceptions' stamp: 'HAW 3/3/2019 08:35:12'! - signalAlreadyDefinedInAll: classes - - ^ self refactoringError: (self class errorMessageForNewInstanceVariable: instVarName alreadyDefinedInAll: classes).! ! -!NewInstanceVariablePrecondition methodsFor: 'exceptions' stamp: 'HAW 3/3/2019 08:34:09'! - signalInvalidInstanceVariable - - ^ self refactoringError: (self class errorMessageForInvalidInstanceVariable: instVarName).! ! -!NewInstanceVariablePrecondition methodsFor: 'exceptions' stamp: 'HAW 3/3/2019 08:36:00'! - signalNewInstanceVariableCanNotBeAReservedName - - self refactoringError: (self class errorMessageForNewInstanceVariableCanNotBeAReservedName: instVarName)! ! -!NewInstanceVariablePrecondition methodsFor: 'exceptions' stamp: 'FGJ 12/17/2018 16:27:50'! - signalNewVariableCanNotBeEmpty - - self refactoringError: self class newVariableCanNotBeEmptyErrorMessage! ! -!NewInstanceVariablePrecondition methodsFor: 'warnings' stamp: 'HAW 3/3/2019 08:19:24'! - methodsDefiningNewVariable - - | methodsDefiningNewVariableInHierarchy | - - methodsDefiningNewVariableInHierarchy := OrderedCollection new. - - classToAddInstVar withAllSubclassesDo: [ :class | - methodsDefiningNewVariableInHierarchy addAll: (class methodsWithArgumentOrTemporaryNamed: instVarName) ]. - - ^methodsDefiningNewVariableInHierarchy - - ! ! -!NewInstanceVariablePrecondition methodsFor: 'warnings' stamp: 'HAW 3/3/2019 08:13:49'! - warnIfIsDefinedInMethods - - | methodsDefiningNewVariable | - - methodsDefiningNewVariable := self methodsDefiningNewVariable. - - methodsDefiningNewVariable notEmpty ifTrue: [ self warnNewVariable: instVarName willBeHiddenAtAll: methodsDefiningNewVariable ].! ! -!NewInstanceVariablePrecondition methodsFor: 'warnings' stamp: 'FGJ 12/17/2018 16:29:18'! - warnNewVariable: newVariable willBeHiddenAtAll: methods - - ^ self refactoringWarning: (self class warningMessageForNewVariable: newVariable willBeHiddenAtAll: methods).! ! -!NewInstanceVariablePrecondition class methodsFor: 'instance creation' stamp: 'HAW 3/3/2019 08:10:58'! - of: anInstanceVariableName for: aClass - - ^self new initializeOf: anInstanceVariableName for: aClass ! ! -!NewInstanceVariablePrecondition class methodsFor: 'error messages' stamp: 'FGJ 12/17/2018 16:27:09'! - errorMessageForInvalidInstanceVariable: aName - - ^ '''' , aName , ''' is not a valid instance variable name'.! ! -!NewInstanceVariablePrecondition class methodsFor: 'error messages' stamp: 'FGJ 12/17/2018 16:28:18'! - errorMessageForNewInstanceVariable: aName alreadyDefinedInAll: classes - - ^ 'Instance variable ''' , aName , ''' is already defined in ' , classes asCommaStringAnd.! ! -!NewInstanceVariablePrecondition class methodsFor: 'error messages' stamp: 'HAW 3/3/2019 08:32:29'! - errorMessageForNewInstanceVariableCanNotBeAReservedName: aName - - ^'''', aName, ''' can not be used as instance variable name because it is a reserved name'! ! -!NewInstanceVariablePrecondition class methodsFor: 'error messages' stamp: 'FGJ 12/17/2018 16:05:38'! - newVariableCanNotBeEmptyErrorMessage - - ^'New variable can not be empty'! ! -!NewInstanceVariablePrecondition class methodsFor: 'warning messages' stamp: 'HAW 3/3/2019 08:27:30'! - warningMessageForNewVariable: newVariable willBeHiddenAtAll: methods - - ^String streamContents: [ :stream | - stream - nextPutAll: newVariable; - nextPutAll: ' will be hidden at '. - methods asCommaSeparated: [:aMethod | aMethod printClassAndSelectorOn: stream ] on: stream ]! ! -!NewInstanceVariablePrecondition class methodsFor: 'evaluating' stamp: 'HAW 3/3/2019 10:06:23'! - valueOf: anInstanceVariableName for: aClass - - ^(self of: anInstanceVariableName for: aClass) value! ! - -RefactoringMenues initialize! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3638-Refactorings-HernanWilkinson-2019Mar07-09h40m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3639] on 4 March 2019 at 4:23:49 pm'! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:56:13'! - withParseNodeIncluding: aPosition do: aBlock ifAbsent: anAbsentBlock - - | nodeAndPosition | - - nodeAndPosition :=self parseNodeIncluding: aPosition ifAbsent: [ ^ anAbsentBlock value ]. - ^aBlock value: nodeAndPosition key.! ! -!CodeProvider methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:52:13'! - isEditingMethod - - ^false! ! -!Browser methodsFor: 'refactorings' stamp: 'HAW 3/4/2019 16:02:28'! -insertSuperclass - - self selectedClassOrMetaClass ifNotNil: [ :aBehavior | - (InsertSuperclassApplier on: self for: aBehavior theNonMetaClass) value ].! ! -!Browser methodsFor: 'refactorings' stamp: 'HAW 3/4/2019 16:02:36' prior: 16791771! - removeClass - - self safelyRemoveClass ! ! -!Browser methodsFor: 'refactorings' stamp: 'HAW 3/4/2019 16:02:38' prior: 16791778! - renameClass - - self selectedClassOrMetaClass ifNotNil: [ :aBehavior | - (RenameClassApplier on: self for: aBehavior theNonMetaClass) value ].! ! -!Browser methodsFor: 'refactorings' stamp: 'HAW 3/4/2019 16:02:41'! - safelyRemoveClass - - self selectedClassOrMetaClass ifNotNil: [ :aBehavior | - (SafelyRemoveClassApplier on: self of: aBehavior theNonMetaClass) value ].! ! -!Browser methodsFor: 'testing' stamp: 'HAW 3/4/2019 16:02:31'! - isEditingMethod - - ^editSelection = #editMessage or: [ editSelection = #newMessage ] -! ! -!MessageSet methodsFor: 'message list' stamp: 'HAW 3/4/2019 16:11:56'! - addMethodReference: aMethodReferenceToAdd ifIncluded: aBlockClosure - - (messageList includes: aMethodReferenceToAdd) - ifTrue: aBlockClosure - ifFalse: [ self addMethodReference: aMethodReferenceToAdd ]! ! -!MessageSet methodsFor: 'message list' stamp: 'HAW 3/4/2019 16:11:51' prior: 16869941! - removeMessageFromBrowser - "Remove the selected message from the browser." - - self removeMessageFromBrowserKeepingLabel. - self changed: #relabel! ! -!MessageSet methodsFor: 'message list' stamp: 'HAW 3/4/2019 16:11:48'! - removeMessageFromBrowserKeepingLabel - - selectedMessage ifNil: [ ^nil ]. - self deleteFromMessageList: self selection. - self reformulateList. -! ! -!Debugger methodsFor: 'testing' stamp: 'HAW 3/4/2019 16:05:01'! - isEditingMethod - - ^true! ! -!UndefinedObject methodsFor: 'accessing instances and variables' stamp: 'HAW 3/4/2019 15:18:06'! - whichClassDefinesInstanceVariable: aVariable ifNone: aNoneBlock - - ^aNoneBlock value! ! -!Behavior methodsFor: 'accessing method dictionary' stamp: 'HAW 3/4/2019 15:19:49'! - methodsSelect: aCondition - - ^ self methodDict valuesSelect: aCondition! ! -!Behavior methodsFor: 'accessing method dictionary' stamp: 'HAW 3/4/2019 15:20:07'! - methodsWithArgumentOrTemporaryNamed: instVarName - - ^self methodsSelect: [:aMethod | aMethod hasArgumentOrTemporary: instVarName ]! ! -!Behavior methodsFor: 'accessing method dictionary' stamp: 'HAW 3/4/2019 15:20:45'! - withSuperclassThatIncludesSelector: aSelector do: aFoundClosure ifNone: aNoneClosure - - ^superclass - ifNil: aNoneClosure - ifNotNil: [ - (superclass whichClassIncludesSelector: aSelector) - ifNil: aNoneClosure - ifNotNil: aFoundClosure ]! ! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'HAW 3/4/2019 15:18:50'! - definesClassVariableNamedInHierarchy: aClassVariableName - - ^self allClassVarNames includes: aClassVariableName ! ! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'HAW 3/4/2019 15:19:06'! - definesInstanceVariableNamed: anInstanceVariableName - - ^self instVarNames includes: anInstanceVariableName! ! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'HAW 3/4/2019 15:19:30'! - indexOfInstanceVariable: aName - - ^self allInstVarNames indexOf: aName! ! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'HAW 3/4/2019 15:20:24'! - whichClassDefinesInstanceVariable: aVariable ifNone: aNoneBlock - - (self definesInstanceVariableNamed: aVariable) ifTrue: [ ^self ]. - - ^superclass whichClassDefinesInstanceVariable: aVariable ifNone: aNoneBlock! ! -!ClassDescription methodsFor: 'instance variables' stamp: 'HAW 3/4/2019 15:21:47'! - chooseDefiningInstanceVariableAlphabeticallyWith: aCaption thenDo: aBlock - - ^self - chooseDefiningInstanceVariableAlphabeticallyWith: aCaption - thenDo: aBlock - ifNone: [ ^ self inform: 'There are no instance variables defined in ', self name ] ! ! -!ClassDescription methodsFor: 'instance variables' stamp: 'HAW 3/4/2019 15:21:57'! - chooseDefiningInstanceVariableAlphabeticallyWith: aCaption thenDo: aBlock ifNone: noneBlock - - | vars index | - "Put up a menu of the instance variables in the receiver, presented in alphabetical order, and when the user chooses one, evaluate aBlock with the chosen variable as its parameter." - - vars _ self instVarNames sorted. - vars isEmpty ifTrue: [^ noneBlock value ]. - - index _ (PopUpMenu labelArray: vars lines: #()) startUpWithCaption: aCaption. - index = 0 ifTrue: [^ self]. - aBlock value: (vars at: index)! ! -!ClassDescription methodsFor: 'instance variables' stamp: 'HAW 3/4/2019 15:26:00'! - withClassesThatDefineInHierarchyInstanceVariable: aName do: foundBlock ifNone: noneBlock - - ^(self classThatDefinesInstanceVariable: aName) - ifNil: [ self withSubclassesThatDefineInstanceVariable: aName do: foundBlock ifNone: noneBlock ] - ifNotNil: [ :definingClass | foundBlock value: (Array with: definingClass) ]! ! -!ClassDescription methodsFor: 'instance variables' stamp: 'HAW 3/4/2019 15:26:16'! - withSubclassesThatDefineInstanceVariable: aName do: foundBlock ifNone: noneBlock - - | definingSubclasses | - - definingSubclasses := self allSubclasses select: [ :aSubclass | aSubclass definesInstanceVariableNamed: aName ]. - - ^definingSubclasses isEmpty - ifTrue: noneBlock - ifFalse: [ foundBlock value: definingSubclasses ]! ! -!Class methodsFor: 'class name' stamp: 'HAW 3/4/2019 15:27:49' prior: 16802364! - rename: aString - "The new name of the receiver is the argument, aString." - - | newName | - (newName _ aString asSymbol) ~= self name - ifFalse: [^ self]. - (Smalltalk includesKey: newName) - ifTrue: [^ self error: newName , ' already exists']. - (Undeclared includesKey: newName) - ifTrue: [self inform: 'There are references to, ' , aString printString , ' -from Undeclared. Check them after this change.']. - - self safeRenameTo: newName.! ! -!Class methodsFor: 'class name' stamp: 'HAW 3/4/2019 15:27:53'! - safeRenameTo: newName - - Smalltalk renameClass: self as: newName. - name _ newName! ! -!SystemOrganizer methodsFor: 'categories' stamp: 'HAW 3/4/2019 15:58:45'! - hasCategory: aCategory - - ^self categories includes: aCategory ! ! -!SystemOrganizer methodsFor: 'categories' stamp: 'HAW 3/4/2019 15:58:48'! - removeSystemCategories: categories - - (self superclassOrderInAll: categories) reverseDo: [ :class | class removeFromSystem]. - - categories do: [ :aCategory | self removeCategory: aCategory]. -! ! -!SystemOrganizer methodsFor: 'categories' stamp: 'HAW 3/4/2019 15:58:52'! - superclassOrderInAll: categories - - | classes | - - classes := OrderedCollection new. - categories do: [ :aCategory | classes addAll: (self classesAt: aCategory)]. - - ^Array streamContents: [ :stream | Smalltalk hierarchySorted: classes do: [ :aClass | stream nextPut: aClass ]].! ! -!Number methodsFor: 'intervals' stamp: 'HAW 3/4/2019 15:29:17'! - toSelfPlus: aDelta - - ^self to: self + aDelta! ! -!Collection methodsFor: 'converting' stamp: 'HAW 3/4/2019 15:36:16'! - as: aPrintingBlock on: aStream delimiter: delimiter last: lastDelimiter - - | position selfSize | - - position := 1. - selfSize := self size. - - self - do: [:elem | - position := position + 1. - aPrintingBlock value: elem ] - separatedBy: [ - aStream nextPutAll: (position = selfSize ifTrue: [lastDelimiter] ifFalse: [delimiter])]! ! -!Collection methodsFor: 'converting' stamp: 'HAW 3/4/2019 15:36:31'! - asCommaSeparated: aPrintingBlock on: aStream - - ^self as: aPrintingBlock on: aStream delimiter: ', ' last: ' and '! ! -!Collection methodsFor: 'converting' stamp: 'HAW 3/4/2019 15:37:03'! - asCommaStringAnd - - ^String streamContents: [:stream | self asStringOn: stream delimiter: ', ' last: ' and ']! ! -!Collection methodsFor: 'converting' stamp: 'HAW 3/4/2019 15:37:18'! - asStringOn: aStream delimiter: delimString last: lastDelimString - - self as: [ :elem | aStream nextPutAll: elem asString ] on: aStream delimiter: delimString last: lastDelimString! ! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'HAW 3/4/2019 15:38:35'! - intervalOfSubCollection: aSubCollectionToFind - - | startingIndex | - - startingIndex := self indexOfSubCollection: aSubCollectionToFind startingAt: 1. - - ^startingIndex toSelfPlus: aSubCollectionToFind size! ! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'HAW 3/4/2019 15:37:58' prior: 50434272! - with: otherCollection do: twoArgBlock separatedBy: separatorBlock - - | beforeFirst | - - beforeFirst := true. - self with: otherCollection do: [ :selfElement :otherCollectionElement | - beforeFirst - ifTrue: [beforeFirst := false] - ifFalse: [separatorBlock value]. - twoArgBlock value: selfElement value: otherCollectionElement ]. - - -! ! -!String methodsFor: 'copying' stamp: 'HAW 3/4/2019 15:30:11'! - copyReplacing: rangesToNewStrings - - ^self class streamContents: [ :replacementStream | self copyReplacing: rangesToNewStrings into: replacementStream ].! ! -!String methodsFor: 'copying' stamp: 'HAW 3/4/2019 15:30:14'! - copyReplacing: rangesToNewStrings into: replacementStream - - | lastFrom | - - lastFrom := rangesToNewStrings inject: 1 into: [ :from :aRangeToNewString | - self - newFromAfterAppending: aRangeToNewString value - into: replacementStream - keepingFrom: from - skipping: aRangeToNewString key ]. - - replacementStream nextPutAll: (self copyFrom: lastFrom to: self size). -! ! -!String methodsFor: 'copying' stamp: 'HAW 3/4/2019 15:30:18'! - copyReplacing: ranges with: newString - - "Ranges must be in order, with first ranges first. If not, result is unexpected - Hernan" - - ^ self class streamContents: [ :replacementStream | self copyReplacing: ranges with: newString into: replacementStream ] - ! ! -!String methodsFor: 'copying' stamp: 'HAW 3/4/2019 15:30:22'! - copyReplacing: ranges with: newString into: replacementStream - - | lastFrom | - - lastFrom := ranges - inject: 1 - into: [ :from :aRange | - self newFromAfterAppending: newString into: replacementStream keepingFrom: from skipping: aRange ]. - - replacementStream nextPutAll: (self copyFrom: lastFrom to: self size).! ! -!String methodsFor: 'copying' stamp: 'HAW 3/4/2019 15:30:28'! - newFromAfterAppending: aNewString into: replacementStream keepingFrom: from skipping: aRange - - replacementStream - nextPutAll: (self copyFrom: from to: aRange first - 1); - nextPutAll: aNewString. - - ^ aRange last + 1! ! -!Symbol class methodsFor: 'instance creation' stamp: 'HAW 3/4/2019 15:31:05'! - fromCollectionOfStrings: aCollectionOfStrings - - ^self newFrom: aCollectionOfStrings concatenation ! ! -!CompiledMethod methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:32:05'! - hasArgumentOrTemporary: aVariable - - | methodNode | - - methodNode := self methodNode. - - ^methodNode tempNames includes: aVariable ! ! -!CompiledMethod methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:33:16'! - readsInstanceVariable: aName - - ^self readsField: (self methodClass indexOfInstanceVariable: aName) ! ! -!CompiledMethod methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:33:41'! - referencesParameterAt: parameterIndex - - | methodNode implementorParameterNodeToRemove parameterRanges | - - methodNode := self methodNode. - implementorParameterNodeToRemove := methodNode arguments at: parameterIndex. - parameterRanges := methodNode positionsForTemporaryVariable: implementorParameterNodeToRemove name ifAbsent: [#()]. - - ^parameterRanges size ~= 1! ! -!CompiledMethod methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:33:58'! - sendsOrRefersTo: aSelector - - ^ (self hasLiteralThorough: aSelector) or: [ self sendsSelector: aSelector ]! ! -!CompiledMethod methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:34:45'! - writesInstanceVariable: aName - - ^self writesField: (self methodClass indexOfInstanceVariable: aName)! ! -!CompiledMethod methodsFor: 'printing' stamp: 'HAW 3/4/2019 15:31:47'! - classAndSelector - - ^String streamContents: [:stream | self printClassAndSelectorOn: stream ]! ! -!CompiledMethod methodsFor: 'printing' stamp: 'HAW 3/4/2019 15:32:47'! - printClassAndSelectorOn: aStream - - aStream - print: self methodClass; - nextPutAll: '>>'; - nextPutAll: self selector storeString! ! -!CompiledMethod methodsFor: 'printing' stamp: 'HAW 3/4/2019 15:32:51' prior: 16819891! - printOn: aStream - "Overrides method inherited from the byte arrayed collection." - - aStream nextPut: $(. - self printClassAndSelectorOn: aStream. - aStream space; nextPut: $". - self printNameOn: aStream. - aStream nextPut: $(; print: self identityHash; nextPut: $); nextPut: $"; nextPut: $)! ! -!CompiledMethod methodsFor: 'source code management' stamp: 'HAW 3/4/2019 15:34:32'! - sourceCode - - "This method is implemented because getSource is not so intuitive - Hernan" - ^self getSource! ! -!MethodDictionary methodsFor: 'enumeration' stamp: 'HAW 3/4/2019 15:35:17'! - valuesSelect: aCondition - - | selected | - - selected := OrderedCollection new. - self valuesDo: [ :aValue | (aCondition value: aValue) ifTrue: [ selected add: aValue ]]. - - ^selected! ! -!Parser class methodsFor: 'parsing' stamp: 'HAW 3/4/2019 15:41:47'! - parse: sourceCode class: aClass - - ^self parse: sourceCode class: aClass noPattern: false! ! -!Parser class methodsFor: 'parsing' stamp: 'HAW 3/4/2019 15:41:50'! -parse: sourceCode class: aClass noPattern: aBoolean - - ^(self new - encoderClass: EncoderForV3PlusClosures; - parse: sourceCode class: aClass noPattern: aBoolean) - sourceText: sourceCode; - yourself! ! -!ParseNode methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:43:27' prior: 50408658! - isInstanceVariableNode - - ^false! ! -!ParseNode methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:43:38' prior: 50408662! - isMessageNamed: aSelector - - ^false! ! -!ParseNode methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:43:50'! - isReturn - - ^false! ! -!ParseNode methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:43:53'! - isTempOrArg - - ^false! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:39:58'! - messageSendKeywordAndParameterPositionsAt: anIndex of: aSelector ifAbsent: aBlock - - | positions | - - positions := sourceRanges keys - select: [ :aParseNode | aParseNode isMessageNamed: aSelector ] - thenCollect: [ :aMessageSendNode | aMessageSendNode keywordAndParameterPositionAt: anIndex encodedWith: self]. - - ^ positions isEmpty - ifTrue: aBlock - ifFalse: [ positions ] - ! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:40:02'! -messageSendKeywordPositionsAt: anIndex of: aSelector ifAbsent: aBlock - - | positions sortedPositions | - - positions := sourceRanges keys - select: [ :aParseNode | aParseNode isMessageNamed: aSelector ] - thenCollect: [ :aMessageSendNode | (aMessageSendNode keywordPositionAt: anIndex) first ]. - - positions isEmpty ifTrue: [ ^aBlock value ]. - sortedPositions := positions asSortedCollection. - - ^sortedPositions ! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:40:05'! - messageSendLastPositionsOf: aSelector ifAbsent: aBlock - - | positions sortedPositions | - - positions := sourceRanges keys - select: [ :aParseNode | aParseNode isMessageNamed: aSelector ] - thenCollect: [ :aMessageSendNode | (sourceRanges at: aMessageSendNode) last ]. - - positions isEmpty ifTrue: [ ^aBlock value ]. - sortedPositions := positions asSortedCollection. - - ^sortedPositions ! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:40:08'! - messageSendSelectorKeywordPositionsOf: aSelector ifAbsent: aBlock - - | ranges sortedRanges | - - ranges := sourceRanges keys - select: [ :aParseNode | aParseNode isMessageNamed: aSelector ] - thenCollect: [ :aMessageSendNode | aMessageSendNode keywordRanges ]. - - ranges isEmpty ifTrue: [ ^aBlock value ]. - sortedRanges := ranges asSortedCollection: [ :left :right | left first first < right first first ]. - - ^sortedRanges ! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:40:12'! - parameterDefinitionPositionFor: aParameterNode - - ^ (self sourceRangeFor: aParameterNode) first! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:40:15'! - positionsForInstanceVariable: aName ifAbsent: aBlock - - ^ self - rangesForVariable: aName - checkingType: [ :variableNode | variableNode isInstanceVariableNode ] - ifAbsent: aBlock ! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:40:19'! - positionsForLiteralNode: aName ifAbsent: aBlock - - | variableNode | - - variableNode := litSet at: aName ifAbsent: [ ^aBlock value ]. - - ^sourceRanges at: variableNode ifAbsent: aBlock! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:40:23'! - positionsForLiteralVariableNode: aName ifAbsent: aBlock - - | variableNode | - - variableNode := litIndSet values detect: [ :aLiteralVariableNode | aLiteralVariableNode name = aName ] ifNone: [ ^aBlock value ]. - - ^sourceRanges at: variableNode ifAbsent: aBlock! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:40:25'! - positionsForTemporaryVariable: aName ifAbsent: aBlock - - ^ self - rangesForVariable: aName - checkingType: [ :variableNode | variableNode isTemp ] - ifAbsent: aBlock ! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:40:29'! - positionsOfLiteralArraysContaining: aSymbol - - | positions | - - positions := OrderedCollection new. - litSet keysAndValuesDo: [ :aLiteral :aLiteralNode | - (aLiteral isArray and: [ aLiteral hasLiteral: aSymbol ]) ifTrue: [ positions addAll: (sourceRanges at: aLiteralNode) ]]. - - ^positions ! ! -!EncoderForV3PlusClosures methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:41:15'! - hasLocalNamed: aName - - ^ scopeTable includesKey: aName ! ! -!LeafNode methodsFor: 'accessing' stamp: 'HAW 3/4/2019 15:44:23'! - key: aKey - - key := aKey ! ! -!VariableNode methodsFor: 'initialization' stamp: 'HAW 3/4/2019 15:51:10'! - nameAndKey: aName - - name := key := aName ! ! -!InstanceVariableNode methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:51:26' prior: 50408740! - isInstanceVariableNode - - ^true! ! -!TempVariableNode methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:51:43'! - isTempOrArg - - ^self isTemp or: [ self isArg ]! ! -!MessageNode methodsFor: 'source ranges' stamp: 'HAW 3/4/2019 15:45:16'! - keywordAndParameterPositionAt: anIndex encodedWith: anEncoder - - | keywordPosition parameterLastPosition | - - keywordPosition := keywordRanges at: anIndex. - parameterLastPosition := anIndex = arguments size - ifTrue: [ (anEncoder sourceRangeFor: self) last ] - ifFalse: [ (keywordRanges at: anIndex + 1) first - 1]. - - ^keywordPosition first to: parameterLastPosition! ! -!MessageNode methodsFor: 'source ranges' stamp: 'HAW 3/4/2019 15:45:19'! - keywordPositionAt: anIndex - - ^keywordRanges at: anIndex ! ! -!MessageNode methodsFor: 'source ranges' stamp: 'HAW 3/4/2019 15:45:22' prior: 50408744! - keywordRanges - - ^keywordRanges! ! -!MessageNode methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:44:44' prior: 50408748! - isMessageNamed: aSelector - - ^aSelector == self selectorSymbol ! ! -!MessageNode methodsFor: 'accessing' stamp: 'HAW 3/4/2019 16:23:43'! - selectorSymbol - - ^selector key! ! -!MethodNode methodsFor: 'accessing' stamp: 'HAW 3/4/2019 15:46:33' prior: 50434956! - argumentNames - - ^arguments collect: [ :anArgumentNode | anArgumentNode name ]! ! -!MethodNode methodsFor: 'accessing' stamp: 'HAW 3/4/2019 15:48:55'! - tempNodes - - ^encoder tempNodes! ! -!MethodNode methodsFor: 'printing' stamp: 'HAW 3/4/2019 15:47:01'! - classAndSelector - - ^self methodClass name, '>>', self selector storeString! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:46:24'! - addPositionTo: symbolPositions of: symbolString inside: literalArrayPosition - - | insidePosition | - - insidePosition := literalArrayPosition first. - [ insidePosition < literalArrayPosition last ] whileTrue: [ - insidePosition := self nextPositionAfterAddPositionTo: symbolPositions of: symbolString startingAt: insidePosition ]. - ! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:48:09'! - messageSendKeywordAndParameterPositionsAt: anIndex of: aSelector ifAbsent: aClosure - - ^encoder messageSendKeywordAndParameterPositionsAt: anIndex of: aSelector ifAbsent: aClosure! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:48:12'! - messageSendKeywordPositionsAt: anIndex of: aSelector ifAbsent: aBlock - - ^encoder messageSendKeywordPositionsAt: anIndex of: aSelector ifAbsent: aBlock - ! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:48:16'! - messageSendLastPositionsOf: aSelector ifAbsent: aBlock - - ^encoder messageSendLastPositionsOf: aSelector ifAbsent: aBlock! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:48:19'! - messageSendSelectorKeywordPositionsOf: aSelector ifAbsent: aBlock - - ^encoder messageSendSelectorKeywordPositionsOf: aSelector ifAbsent: aBlock! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:48:23'! - nextPositionAfterAddPositionTo: symbolPositions of: symbolString startingAt: insidePosition - - | symbolStartPosition nextPosition | - - symbolStartPosition := sourceText indexOfSubCollection: symbolString startingAt: insidePosition. - - symbolStartPosition = 0 - ifTrue: [ nextPosition := SmallInteger maxVal ] - ifFalse: [ - nextPosition := symbolStartPosition + symbolString size. - (sourceText at: nextPosition) tokenish ifFalse: [ symbolPositions add: (symbolStartPosition to: nextPosition - 1) ]]. - - ^nextPosition - - ! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:48:27'! - parameterDefinitionPositionAt: anIndex - - ^encoder parameterDefinitionPositionFor: (arguments at: anIndex)! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:48:30'! - positionsForInstanceVariable: aName ifAbsent: aBlock - - ^encoder positionsForInstanceVariable: aName ifAbsent: aBlock -! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:48:33'! - positionsForLiteralNode: aName ifAbsent: aBlock - - ^encoder positionsForLiteralNode: aName ifAbsent: aBlock -! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:48:36'! - positionsForLiteralVariableNode: aName ifAbsent: aBlock - - ^encoder positionsForLiteralVariableNode: aName ifAbsent: aBlock! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:48:39'! - positionsForTemporaryVariable: aName ifAbsent: aBlock - - ^encoder positionsForTemporaryVariable: aName ifAbsent: aBlock! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:48:42'! - positionsInLiteralArrayOf: aSymbol - - | literalArrayPositions | - - literalArrayPositions := encoder positionsOfLiteralArraysContaining: aSymbol. - - ^self positionsOf: aSymbol printString containedIn: literalArrayPositions. - -! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:48:45'! - positionsOf: symbolString containedIn: literalArrayPositions - - | symbolPositions | - - symbolPositions := OrderedCollection new. - - literalArrayPositions do: [ :literalArrayPosition | self addPositionTo: symbolPositions of: symbolString inside: literalArrayPosition ]. - - ^symbolPositions - - - - -! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:48:48'! - selectorKeywordPositionAt: anIndex - - ^selectorKeywordsRanges at: anIndex! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:48:52'! - selectorKeywordsPositions - - ^selectorKeywordsRanges! ! -!MethodNode methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:47:33'! - hasArgumentOrTemporary: aVariable - - ^self tempNames includes: aVariable! ! -!MethodNode methodsFor: 'testing' stamp: 'HAW 3/4/2019 16:13:33'! - hasLocalNamed: aName - - ^ encoder hasLocalNamed: aName ! ! -!ReturnNode methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:50:43'! - isImplicitSelfReturnIn: aMethodNode - - ^self isReturnSelf and: [ (aMethodNode encoder rawSourceRanges includesKey: expr) not ]! ! -!ReturnNode methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:50:48'! - isReturn - - ^true! ! -!TextEditor methodsFor: 'accessing' stamp: 'HAW 3/4/2019 15:52:45'! - actualContents - - ^model actualContents ! ! -!TextEditor methodsFor: 'accessing' stamp: 'HAW 3/4/2019 15:52:48'! - actualContents: aString - - model actualContents: aString ! ! -!TextEditor methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:53:18'! - hasUnacceptedEdits - - ^morph hasUnacceptedEdits ! ! -!TextEditor methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:53:29'! - hasUnacceptedEdits: aBoolean - - ^morph hasUnacceptedEdits: aBoolean ! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/4/2019 15:57:20'! - contextualRename - - self - withMethodNodeAndClassDo: [ :methodNode :classToRefactor | self contextualRenameOf: methodNode in: classToRefactor] - ifErrorsParsing: [ :anError | morph flash ]. - - ! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/4/2019 15:57:23'! - contextualRename: aKeyboardEvent - - self contextualRename. - ^true! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/4/2019 15:57:26'! - contextualRenameOf: aMethodNode in: aClassToRefactor - - aMethodNode - withParseNodeIncluding: self startIndex - do: [ :nodeUnderCursor | self rename: nodeUnderCursor in: aClassToRefactor ] - ifAbsent: [ - self startIndex <= aMethodNode selectorLastPosition - ifTrue: [ self ifRenameCanBeAppliedDo: [ self renameSelectorFor: aMethodNode selector in: aClassToRefactor ]] - ifFalse: [ morph flash ]] - - -! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/4/2019 15:57:30'! - ifRenameCanBeAppliedDo: aBlock - - ^(self hasUnacceptedEdits or: [morph hasEditingConflicts ]) - ifTrue: [ self inform: 'Rename can not be applied becuase there are unsaved changes' ] - ifFalse: aBlock! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/4/2019 15:57:35'! - rename: aNodeUnderCursor in: aClassToRefactor - - aNodeUnderCursor isTempOrArg ifTrue: [ ^self renameTemporary: aNodeUnderCursor name ]. - - self ifRenameCanBeAppliedDo: [ - aNodeUnderCursor isMessageNode ifTrue: [ ^ self renameSelectorFor: aNodeUnderCursor selector key in: aClassToRefactor ]. - aNodeUnderCursor isInstanceVariableNode ifTrue: [ ^ self renameInstanceVariableOn: self codeProvider for: aNodeUnderCursor name at: aClassToRefactor ]. - aNodeUnderCursor isLiteralVariableNode ifTrue: [ | posibleBehavior | - posibleBehavior := aNodeUnderCursor key value. - posibleBehavior isBehavior ifTrue: [ ^self renameClassOn: self codeProvider for: posibleBehavior theNonMetaClass ]]. - - ^morph flash ]! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/4/2019 15:57:38'! - renameClassOn: aBrowser for: aClassToRefactor - - (RenameClassApplier on: aBrowser for: aClassToRefactor) value! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/4/2019 15:57:41'! - renameInstanceVariableOn: aBrowser for: anInstanceVariableName at: aClassToRefactor - - (RenameInstanceVariableApplier on: aBrowser for: anInstanceVariableName at: aClassToRefactor) value! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/4/2019 15:57:45'! - renameSelectorFor: aSelector in: aClassToRefactor - - RenameSelectorApplier createAndValueHandlingExceptions: [ RenameSelectorApplier on: model textProvider for: aSelector in: aClassToRefactor ]! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/4/2019 15:57:49'! - renameTemporary: aTemporaryName - - self codeProvider isEditingMethod ifTrue: [ | applier | - [ applier := RenameTemporaryApplier on: self for: aTemporaryName ] - on: SyntaxErrorNotification - do: [:anError | ^self inform: (RenameTemporaryApplier errorMessageForCanNotParseMethod: anError) ]. - applier value ]. -! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/4/2019 15:57:52'! - withMethodNodeAndClassDo: aBlock ifErrorsParsing: anErrorBlock - - | class methodNode | - - class := self codeProvider selectedClassOrMetaClass. - methodNode := [ class methodNodeFor: model actualContents ] on: Error do: [ :anError | ^ anErrorBlock value: anError ]. - - ^aBlock value: methodNode value: class.! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 3/4/2019 15:59:35'! - addInstVar - - model selectedClassOrMetaClass ifNotNil: [ :aClass | - (AddInstanceVariableApplier on: model for: aClass) value ].! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 3/4/2019 15:59:38'! - addParameter - - model selectedMessageName ifNotNil: [ :oldSelector | - AddParameterApplier createAndValueHandlingExceptions: [ AddParameterApplier on: model for: oldSelector in: model selectedClassOrMetaClass ]]! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 3/4/2019 15:59:41'! -classRefactoringMenu - - ^DynamicMenuBuilder buildTitled: 'Refactorings' targeting: self collectingMenuOptionsWith: #classRefactoringMenuOptions.! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 3/4/2019 15:59:47'! - messageRefactoringMenu - - ^DynamicMenuBuilder buildTitled: 'Refactorings' targeting: self collectingMenuOptionsWith: #messsageRefactoringMenuOptions.! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 3/4/2019 15:59:50'! - openClassRefactoringMenu - - ^self classRefactoringMenu popUpInWorld! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 3/4/2019 15:59:53'! - openMessageRefactoringMenu - - ^self messageRefactoringMenu popUpInWorld! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 3/4/2019 16:00:10'! - pushUpSelector - - model selectedMessageName ifNotNil: [ :selectedSelector | - (PushUpMethod for: model selectedClassOrMetaClass>>selectedSelector) apply. - model messageListIndex: 0. - model changed: #messageList. - model setClassOrganizer ].! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 3/4/2019 16:00:13'! - removeAllUnreferencedInstVar - - model selectedClassOrMetaClass ifNotNil: [ :aClass | - (RemoveAllUnreferencedInstanceVariablesApplier on: model for: aClass) value ].! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 3/4/2019 16:00:16'! - removeInstVar - - model selectedClassOrMetaClass ifNotNil: [ :aClass | - (RemoveInstanceVariableApplier on: model for: aClass) value ].! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 3/4/2019 16:00:23'! - removeParameter - - model selectedMessageName ifNotNil: [ :oldSelector | - RemoveParameterApplier createAndValueHandlingExceptions: [ - RemoveParameterApplier on: model for: oldSelector in: model selectedClassOrMetaClass ]]! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 3/4/2019 16:00:26'! - renameInstVar - - model selectedClassOrMetaClass ifNotNil: [ :aClass | - (RenameInstanceVariableApplier on: model at: aClass) value ].! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 3/4/2019 16:00:30'! - renameSelector - - model selectedMessageName ifNotNil: [ :oldSelector | - RenameSelectorApplier createAndValueHandlingExceptions: [ RenameSelectorApplier on: model for: oldSelector in: model selectedClassOrMetaClass ]].! ! -!MessageSetWindow class methodsFor: 'opening' stamp: 'HAW 3/4/2019 16:01:36' prior: 16870560! - openFullProtocolForClass: aClass - "Create and schedule a browser for the entire protocol of the class." - "ProtocolBrowser openFullProtocolForClass: ProtocolBrowser." - - | aPBrowser label | - - aPBrowser _ ProtocolBrowser new on: aClass. - label _ 'Entire protocol of: ', aClass name. - - ^self open: aPBrowser label: label! ! -!MessageSetWindow class methodsFor: 'opening' stamp: 'HAW 3/4/2019 16:01:39' prior: 50343741! - openMessageList: anArray label: aString - "Create a standard system view for the message set on the list, anArray. - The label of the view is aString." - - ^self open: (MessageSet messageList: anArray) label: aString! ! -!MessageSetWindow class methodsFor: 'opening' stamp: 'HAW 3/4/2019 16:01:42' prior: 16870583! - openMessageList: messageList label: labelString autoSelect: autoSelectString - "Open a system view for a MessageSet on messageList. - 1/24/96 sw: the there-are-no msg now supplied by my sender" - - | messageSet | - - messageSet _ MessageSet messageList: messageList. - messageSet autoSelectString: autoSelectString. - - ^self open: messageSet label: labelString ! ! -!MessageSetWindow class methodsFor: 'opening' stamp: 'HAW 3/4/2019 16:01:46' prior: 16870597! - openSubProtocolForClass: aClass - "Create and schedule a browser for the entire protocol of the class." - "ProtocolBrowser openSubProtocolForClass: ProtocolBrowser." - - | aPBrowser label | - - aPBrowser _ ProtocolBrowser new onSubProtocolOf: aClass. - label _ 'Sub-protocol of: ', aClass name. - - ^self open: aPBrowser label: label! ! -!ChangeSelector methodsFor: 'create new implementors - private' stamp: 'HAW 3/4/2019 15:24:22' prior: 50438588! - compileNewImplementorOf: anImplementor - - | implementorClassification newSourceCode | - - newSourceCode := self implementorNewSourceCodeOf: anImplementor. - implementorClassification := anImplementor methodClass organization categoryOfElement: oldSelector. - - anImplementor methodClass - compile: newSourceCode - classified: implementorClassification. -! ! -!PushUpMethod methodsFor: 'applying' stamp: 'HAW 3/4/2019 15:23:40' prior: 50440575! - apply - - | methodCategory | - - methodCategory := method methodClass organization categoryOfElement: method selector. - method methodClass superclass - compile: method sourceCode - classified: methodCategory. - - method methodClass removeSelector: method selector. - ! ! - -MethodNode removeSelector: #selectorKeywordsRanges! - -MethodNode removeSelector: #selectorKeywordsRanges! - -ClassDescription removeSelector: #compile:classifyUnder:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3639-Refactorings-part2-HernanWilkinson-2019Mar03-08h04m-HAW.4xx.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3641] on 6 March 2019 at 4:12:06 pm'! -!ProgressiveTestRunner methodsFor: 'evaluating' stamp: 'HAW 3/6/2019 15:35:58' prior: 50338122! - value - - Utilities authorInitials. - testsStream _ ReadStream on: testSuite tests. - testsStream atEnd - ifTrue: [ self informNoTestToRun ] - ifFalse:[ self createProgressBarAndRun ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3640-ProgressiveTestRunner-HernanWilkinson-2019Mar06-15h06m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3637] on 6 March 2019 at 12:20:34 pm'! - -Encoder removeSelector: #bindTemp:in:! - -Encoder removeSelector: #bindTemp:in:! - -Parser removeSelector: #bindTemp:in:! - -Parser removeSelector: #bindTemp:in:! - -Parser removeSelector: #temporariesIn:! - -Parser removeSelector: #temporariesIn:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3641-Cleanup-JuanVuletich-2019Mar06-12h18m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3637] on 6 March 2019 at 12:21:07 pm'! -!Encoder methodsFor: 'encoding' stamp: 'jmv 3/6/2019 12:06:54' prior: 16837538! - undeclared: name - | sym | - requestor interactive ifTrue: [ - ^self notify: 'Undeclared']. - "Allow knowlegeable clients to squash the undeclared warning if they want (e.g. - Diffing pretty printers that are simply formatting text). As this breaks - compilation it should only be used by clients that want to discard the result - of the compilation. To squash the warning use e.g. - [Compiler format: code in: class notifying: nil decorated: false] - on: UndeclaredVariableWarning - do: [:ex| ex resume: false]" - sym := name asSymbol. - ^(UndeclaredVariableWarning new name: name selector: selector class: class) signal - ifTrue: - [Undeclared at: sym put: nil. - self global: (Undeclared associationAt: sym) name: sym] - ifFalse: - [self global: (Association key: sym) name: sym]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3642-Cleanup-JuanVuletich-2019Mar06-12h20m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3639] on 6 March 2019 at 1:08:21 pm'! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'jmv 3/6/2019 13:07:59' prior: 16806925! - printMethodChunk: selector withPreamble: doPreamble on: outStream moveSource: moveSource toFile: fileIndex - "Copy the source code for the method associated with selector onto the fileStream. If moveSource true, then also set the source code pointer of the method." - | preamble method oldPos newPos sourceFile endPos | - doPreamble - ifTrue: [preamble _ self name , ' methodsFor: ' , - (self organization categoryOfElement: selector) asString printString] - ifFalse: [preamble _ '']. - method _ self methodDict at: selector ifAbsent: [ - outStream nextPutAll: selector; newLine. - outStream tab; nextPutAll: '** ERROR - THIS METHOD IS MISSING ** '; newLine; newLine. - outStream nextPutAll: ' '. - ^ outStream]. - - ((method fileIndex = 0 - or: [(SourceFiles at: method fileIndex) == nil]) - or: [(oldPos _ method filePosition) = 0]) - ifTrue: [ - "The source code is not accessible. We must decompile..." - preamble size > 0 ifTrue: [ outStream newLine; nextPut: $!!; nextChunkPut: preamble; newLine]. - outStream nextChunkPut: method decompileString] - ifFalse: [ - sourceFile _ SourceFiles at: method fileIndex. - preamble size > 0 - ifTrue: "Copy the preamble" - [outStream copyPreamble: preamble from: sourceFile at: oldPos] - ifFalse: - [sourceFile position: oldPos]. - "Copy the method chunk" - fileIndex = 0 ifFalse: [ - outStream padTo: SourceFiles pointerScaleForWriting put: $ ]. - newPos _ outStream position. - outStream copyMethodChunkFrom: sourceFile. - moveSource ifTrue: [ "Set the new method source pointer" - endPos _ outStream position. - method checkOKToAdd: endPos - newPos at: newPos in: method fileIndex. - method setSourcePosition: newPos inFile: fileIndex]]. - preamble size > 0 ifTrue: [ outStream nextChunkPut: ' ' ]. - ^ outStream newLine! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3643-BetterMissingMethodText-JuanVuletich-2019Mar06-13h07m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3640] on 7 March 2019 at 12:04:56 pm'! - -Error subclass: #RecompilationFailure - instanceVariableNames: 'class selector' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #RecompilationFailure category: #'Exceptions Kernel'! -Error subclass: #RecompilationFailure - instanceVariableNames: 'class selector' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! -!RecompilationFailure commentStamp: 'jmv 3/7/2019 11:39:10' prior: 0! - Recompilation of some existing method failed. - -The usual handling of this exception should be to cancel the action that triggered recompilation. If not handled, a debugger will open.! -!RecompilationFailure methodsFor: 'accessing' stamp: 'jmv 3/7/2019 12:02:40'! - messageText - ^ 'In method ', class name,'>>', selector asString,' ', messageText! ! -!RecompilationFailure methodsFor: 'private' stamp: 'jmv 3/7/2019 11:28:08'! -class: aClass selector: aSymbol messageText: aString - class _ aClass. - selector _ aSymbol. - messageText _ aString! ! -!RecompilationFailure class methodsFor: 'instance creation' stamp: 'jmv 3/7/2019 11:28:18'! - class: aClass selector: aSymbol messageText: aString - ^ self new class: aClass selector: aSymbol messageText: aString! ! -!Browser methodsFor: '*LiveTyping' stamp: 'jmv 3/7/2019 12:03:38' prior: 16791377! - contents: input notifying: aRequestor - "The retrieved information has changed and its source must now be - updated. The information can be a variety of things, depending on - the list selections (such as templates for class or message definition, - methods) or the user menu commands (such as definition, comment, - hierarchy). Answer the result of updating the source." - - | aString aText theClass | - aString _ input asString. - aText _ input asText. - editSelection == #editSystemCategories ifTrue: [ ^ self changeSystemCategories: aString ]. - editSelection == #editClass | (editSelection == #newClass) ifTrue: [ - [ - self defineClass: aString notifying: aRequestor - ] on: RecompilationFailure do: [ :ex | - self inform: ex messageText. - ^ false]. - ^ true]. - editSelection == #editComment - ifTrue: [ - theClass _ self selectedClass. - theClass - ifNil: [ - self inform: 'You must select a class -before giving it a comment.'. - ^ false]. - theClass comment: aText stamp: Utilities changeStamp. - self changed: #classCommentText. - ^ true]. - editSelection == #hierarchy ifTrue: [ ^ true ]. - editSelection == #editMessageCategories ifTrue: [ ^ self changeMessageCategories: aString ]. - editSelection == #editMessage | (editSelection == #newMessage) - ifTrue: [ - ^ self okayToAccept - ifFalse:[ false ] - ifTrue: [ - (self compileMessage: aText notifying: aRequestor) - ifTrue: [ self triggerEvent: #annotationChanged ]; - yourself ]]. - editSelection == #none - ifTrue: [ - self inform: 'This text cannot be accepted -in this part of the browser.'. - ^ false]. - self error: 'unacceptable accept'! ! -!Encoder methodsFor: 'private' stamp: 'jmv 3/7/2019 12:02:44' prior: 16837633! - warnAboutShadowed: name - | msg fullMsg | - msg _ 'There already exists a variable named ', name, ' '. - fullMsg _ class name,'>>', selector asString, ' ', msg. - requestor addWarning: fullMsg. - Transcript newLine; show: fullMsg. - InMidstOfFileinNotification signal - ifFalse: [ - requestor interactive - ifTrue: [ - self notify: msg] - ifFalse: [ - (RecompilationFailure - class: class - selector: selector - messageText: msg, String newLineString, 'Please use a different name') signal ]]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3644-DontAllowVariableShadowing-JuanVuletich-2019Mar07-11h24m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3645] on 7 March 2019 at 2:53:00 pm'! - -"Change Set: 3645-CuisCore-AuthorName-2019Mar07-13h02m -Date: 7 March 2019 -Author: Hernan Wilkinson -Removes empty categories and recategorized methods -" -MethodReference organization - classify: #printOn: under: 'printing'. -Browser organization - classify: #classDefinitionText under: 'class functions'; - classify: #contents:notifying: under: 'accessing'; - classify: #selectedMessage under: 'message list'. -MessageSet organization - classify: #contents:notifying: under: 'accessing'; - classify: #selectedMessage under: 'message list'. -Debugger organization - classify: #askForSuperclassOf:toImplement:ifCancel: under: 'method creation'. -CompiledMethod organization - classify: #printOn: under: 'printing'. -CodeProvider organization - classify: #isModeStyleable under: 'shout styling'; - classify: #contentsSymbolQuints under: 'controls'. -ProtoObject withAllSubclassesDo: [ :class | class organization removeEmptyCategories ]. -! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3645-MethodRecategorization-HernanWilkinson-2019Mar07-13h02m-HAW.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3645] on 7 March 2019 at 4:30:23 pm'! -!Browser methodsFor: 'class functions' stamp: 'HAW 3/7/2019 16:29:51' prior: 16791532! - classDefinitionText - "return the text to display for the definition of the currently selected class" - - ^self selectedClassOrMetaClass - ifNil: [''] - ifNotNil: [ :theClass | theClass definition]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3646-classDefinition-HernanWilkinson-2019Mar07-14h53m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3645] on 7 March 2019 at 4:44:03 pm'! -!MethodReference methodsFor: 'printing' stamp: 'HAW 3/7/2019 16:41:54'! - printClassAndSelectorOn: aStream - - aStream nextPutAll: classSymbol. - classIsMeta ifTrue: [ aStream nextPutAll: ' class' ]. - aStream - nextPutAll: '>>#'; - nextPutAll: methodSymbol! ! -!MethodReference methodsFor: 'printing' stamp: 'HAW 3/7/2019 16:43:30' prior: 50364607! - printOn: aStream - "Print the receiver on a stream" - - super printOn: aStream. - aStream space. - self printClassAndSelectorOn: aStream! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3647-MethodReferencePrintOn-HernanWilkinson-2019Mar07-16h30m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3647] on 7 March 2019 at 5:16:10 pm'! -!TestSuite class methodsFor: 'instance creation - private' stamp: 'HAW 3/7/2019 17:15:17' prior: 50338300! - forClasses: classes named: aName - - | suite | - - suite _ classes - inject: (self named: aName) - into: [ :partialSuite :aClass | partialSuite addTests: (self forClass: aClass) tests ]. - - ^suite - -! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3648-TestSuiteVarShadowing-HernanWilkinson-2019Mar07-17h04m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3647] on 7 March 2019 at 5:29:58 pm'! -!InsertSuperclass methodsFor: 'applying - private' stamp: 'HAW 3/7/2019 17:28:52'! - changeSuperclassTo: newSuperclass - - newSuperclass subclass: classToRefactor name - instanceVariableNames: classToRefactor instanceVariablesString - classVariableNames: classToRefactor classVariablesString - poolDictionaries: classToRefactor sharedPoolsString - category: classToRefactor category.! ! -!FileList methodsFor: 'volume list and pattern' stamp: 'HAW 3/7/2019 17:27:14' prior: 16842796! - doesPattern: aPattern allow: entry - - ^(aPattern = '*' or: [ aPattern match: entry name ]) and: [ - "Hide Mac resurce forks and folder service stores" - (entry name = '.DS_Store') not and: [ - ('._*' match: entry name) not ]]! ! -!InsertSuperclass methodsFor: 'applying' stamp: 'HAW 3/7/2019 17:29:03' prior: 50440510! - apply - - | newSuperclass | - - newSuperclass := self createSuperclass. - self changeSuperclassTo: newSuperclass. - - ^newSuperclass ! ! - -InsertSuperclass removeSelector: #changeSuperclassOf:to:! - -InsertSuperclass removeSelector: #changeSuperclassOf:to:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3649-MoreVariablesShadowingFixes-HernanWilkinson-2019Mar07-17h16m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3649] on 8 March 2019 at 11:29:51 am'! -!DummyStream methodsFor: 'as yet unclassified' stamp: 'jmv 3/8/2019 10:17:33'! - padToEndIfCantTruncate - "Only makes sense for file streams with existing content."! ! -!Morph methodsFor: 'as yet unclassified' stamp: 'jmv 3/8/2019 11:24:08'! - whenUIinSafeState: evaluableObject - self world - ifNotNil: [ :w | w whenUIinSafeState: evaluableObject ] - ifNil: evaluableObject! ! -!ProgressMorph methodsFor: 'accessing' stamp: 'jmv 3/8/2019 11:29:08'! - updatePositionAndExtent - | h w newExtent | - w _ ((labelMorph measureContents x max: subLabelMorph measureContents x) max: 200) + 8. - h _ labelMorph morphHeight + subLabelMorph morphHeight + progress morphHeight + 10. - newExtent _ w@h. - self world - ifNotNil: [ :world | self morphPosition: world morphExtent - newExtent // 2 extent: newExtent ] - ifNil: [ self morphExtent: newExtent ]! ! -!ProgressMorph methodsFor: 'accessing' stamp: 'jmv 3/8/2019 11:27:03' prior: 16896249! - label: aString subLabel: otherString - self whenUIinSafeState: [ - labelMorph contents: aString. - subLabelMorph contents: otherString. - self updatePositionAndExtent. ]! ! -!ProgressMorph methodsFor: 'accessing' stamp: 'jmv 3/8/2019 11:24:39' prior: 16896255! - subLabel: aString - self whenUIinSafeState: [ - subLabelMorph contents: aString. - self updatePositionAndExtent. ]! ! -!ProgressMorph methodsFor: 'initialization' stamp: 'jmv 3/8/2019 11:18:58' prior: 16896278! - openInWorld: aWorld - "This msg and its callees result in the window being activeOnlyOnTop" - aWorld addMorph: self. - self updatePositionAndExtent. - labelMorph fitContents. - subLabelMorph fitContents. - layoutNeeded _ true.! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3650-CenterProgressMorph-JuanVuletich-2019Mar08-11h16m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3649] on 7 March 2019 at 11:05:12 pm'! -!ExtractToTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 3/7/2019 22:52:44'! - assert: aNewVariable isNotDefinedAsInstanceVariableInHierarchyOf: aClass - - | classDefiningNewVariable | - - classDefiningNewVariable := aClass whichClassDefinesInstanceVariable: aNewVariable ifNone: [ ^self ]. - self signal: aNewVariable canNotHideInstanceVariableDefinedIn: classDefiningNewVariable ! ! -!ExtractToTemporary class methodsFor: 'warnings' stamp: 'HAW 3/7/2019 22:54:39'! - errorMessageFor: aNewVariable canNotBeNamedAsInstanceVariableDefinedIn: aClass - - ^aNewVariable, ' can not be named as instance variable defined in ', aClass name! ! -!ExtractToTemporary class methodsFor: 'warnings' stamp: 'HAW 3/7/2019 22:54:39'! - signal: aNewVariable canNotHideInstanceVariableDefinedIn: aClass - - self refactoringError: (self errorMessageFor: aNewVariable canNotBeNamedAsInstanceVariableDefinedIn: aClass)! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 3/7/2019 22:52:44'! - assert: aNewVariable isNotDefinedAsInstanceVariableInHierarchyOf: aClass - - | classDefiningNewVariable | - - classDefiningNewVariable := aClass whichClassDefinesInstanceVariable: aNewVariable ifNone: [ ^self ]. - self signal: aNewVariable canNotHideInstanceVariableDefinedIn: classDefiningNewVariable ! ! -!RenameTemporary class methodsFor: 'warnings' stamp: 'HAW 3/7/2019 22:54:39'! - errorMessageFor: aNewVariable canNotBeNamedAsInstanceVariableDefinedIn: aClass - - ^aNewVariable, ' can not be named as instance variable defined in ', aClass name! ! -!RenameTemporary class methodsFor: 'warnings' stamp: 'HAW 3/7/2019 22:54:39'! - signal: aNewVariable canNotHideInstanceVariableDefinedIn: aClass - - self refactoringError: (self errorMessageFor: aNewVariable canNotBeNamedAsInstanceVariableDefinedIn: aClass)! ! -!NewInstanceVariablePrecondition methodsFor: 'warnings' stamp: 'HAW 3/7/2019 22:29:07'! - assertIsDefinedInMethods - - | methodsDefiningNewVariable | - - methodsDefiningNewVariable := self methodsDefiningNewVariable. - - methodsDefiningNewVariable notEmpty ifTrue: [ self signalNewVariable: instVarName willBeHiddenAtAll: methodsDefiningNewVariable ].! ! -!NewInstanceVariablePrecondition methodsFor: 'warnings' stamp: 'HAW 3/7/2019 22:29:57'! - signalNewVariable: newVariable willBeHiddenAtAll: methods - - ^ self refactoringError: (self class errorMessageForNewVariable: newVariable willBeHiddenAtAll: methods).! ! -!NewInstanceVariablePrecondition class methodsFor: 'warning messages' stamp: 'HAW 3/7/2019 23:02:55'! - errorMessageForNewVariable: newVariable willBeHiddenAtAll: methods - - ^String streamContents: [ :stream | - stream - nextPutAll: newVariable; - nextPutAll: ' can not be named as temporary/parameter in '. - methods asCommaSeparated: [:aMethod | aMethod printClassAndSelectorOn: stream ] on: stream ]! ! -!ExtractToTemporary class methodsFor: 'instance creation' stamp: 'HAW 3/7/2019 22:51:29' prior: 50440399! - named: aNewVariable at: anIntervalToExtract from: aMethodSourceCode in: aClass - - | trimmedNewVariable parseNodeToExtract trimmedSourceCodeToExtract methodNodeToExtract methodNodeToRefactor sourceCodeToExtract | - - trimmedNewVariable := aNewVariable withBlanksTrimmed. - methodNodeToRefactor := aClass methodNodeFor: aMethodSourceCode. - - self assertIsNotEmpty: trimmedNewVariable. - self assertIsValidVariableName: trimmedNewVariable. - self assert: trimmedNewVariable isNotDefinedIn: methodNodeToRefactor. - - sourceCodeToExtract := aMethodSourceCode copyFrom: anIntervalToExtract first to: anIntervalToExtract last. - trimmedSourceCodeToExtract := sourceCodeToExtract withBlanksTrimmed. - self assertSourceCodeIsNotEmpty: trimmedSourceCodeToExtract. - self assertIsNotReturn: trimmedSourceCodeToExtract. - self assert: trimmedSourceCodeToExtract isIncludedIn: methodNodeToRefactor. - - [ methodNodeToExtract := Parser parse: trimmedSourceCodeToExtract class: methodNodeToRefactor methodClass noPattern: true ] - on: SyntaxErrorNotification - do: [ :anError | self signalColaborationToExtractHasSyntaxError: anError ]. - - parseNodeToExtract := self paseNodeToExtractFrom: methodNodeToExtract. - - self assert: trimmedNewVariable isNotDefinedAsInstanceVariableInHierarchyOf: methodNodeToRefactor methodClass. - - ^self new initializeNamed: trimmedNewVariable with: parseNodeToExtract in: methodNodeToRefactor - - ! ! -!ExtractToTemporary class methodsFor: 'instance creation' stamp: 'HAW 3/7/2019 22:51:29' prior: 50440446! - named: aNewVariable with: aSourceCodeToExtract in: aMethodNodeToRefactor - - | trimmedNewVariable parseNodeToExtract trimmedSourceCodeToExtract methodNodeToExtract | - - trimmedNewVariable := aNewVariable withBlanksTrimmed. - - self assertIsNotEmpty: trimmedNewVariable. - self assertIsValidVariableName: trimmedNewVariable. - self assert: trimmedNewVariable isNotDefinedIn: aMethodNodeToRefactor. - - trimmedSourceCodeToExtract := aSourceCodeToExtract withBlanksTrimmed. - self assertSourceCodeIsNotEmpty: trimmedSourceCodeToExtract. - self assertIsNotReturn: trimmedSourceCodeToExtract. - self assert: trimmedSourceCodeToExtract isIncludedIn: aMethodNodeToRefactor. - - [ methodNodeToExtract := Parser parse: trimmedSourceCodeToExtract class: aMethodNodeToRefactor methodClass noPattern: true ] - on: SyntaxErrorNotification - do: [ :anError | self signalColaborationToExtractHasSyntaxError: anError ]. - - parseNodeToExtract := self paseNodeToExtractFrom: methodNodeToExtract. - - self assert: trimmedNewVariable isNotDefinedAsInstanceVariableInHierarchyOf: aMethodNodeToRefactor methodClass. - - ^self new initializeNamed: trimmedNewVariable with: parseNodeToExtract in: aMethodNodeToRefactor - - ! ! -!RenameTemporary class methodsFor: 'instance creation' stamp: 'HAW 3/7/2019 22:51:29' prior: 50441145! - from: anOldVariable to: aNewVariable in: aMethodNode - - | trimmedNewVariable | - - trimmedNewVariable := aNewVariable withBlanksTrimmed. - - self assert: anOldVariable isDefinedIn: aMethodNode. - self assertIsNotEmpty: trimmedNewVariable. - self assertIsValidVariableName: trimmedNewVariable. - self assert: trimmedNewVariable isNotDefinedIn: aMethodNode. - - self assert: trimmedNewVariable isNotDefinedAsInstanceVariableInHierarchyOf: aMethodNode methodClass. - - ^self new initializeFrom: anOldVariable to: trimmedNewVariable in: aMethodNode -! ! -!NewInstanceVariablePrecondition methodsFor: 'evaluating' stamp: 'HAW 3/7/2019 22:28:38' prior: 50442738! - value - - self assertIsNotEmpty. - self assertIsNotAReservedName. - self assertIsValidInstanceVariableName. - self assertIsNotAlreadyDefined. - - self assertIsDefinedInMethods.! ! - -NewInstanceVariablePrecondition class removeSelector: #warningMessageForNewVariable:willBeHiddenAtAll:! - -NewInstanceVariablePrecondition class removeSelector: #warningMessageForNewVariable:willBeHiddenAtAll:! - -NewInstanceVariablePrecondition removeSelector: #warnIfIsDefinedInMethods! - -NewInstanceVariablePrecondition removeSelector: #warnIfIsDefinedInMethods! - -NewInstanceVariablePrecondition removeSelector: #warnNewVariable:willBeHiddenAtAll:! - -NewInstanceVariablePrecondition removeSelector: #warnNewVariable:willBeHiddenAtAll:! - -RenameTemporary class removeSelector: #errorMessageFor:canNotHideInstanceVariableDefinedIn:! - -RenameTemporary class removeSelector: #warn:willHideInstanceVariableDefinedIn:! - -RenameTemporary class removeSelector: #warn:willHideInstanceVariableDefinedIn:! - -RenameTemporary class removeSelector: #warnIf:isDefinedAsInstanceVariableInHierarchyOf:! - -RenameTemporary class removeSelector: #warnIf:isDefinedAsInstanceVariableInHierarchyOf:! - -RenameTemporary class removeSelector: #warningMessageFor:willHideInstanceVariableDefinedIn:! - -RenameTemporary class removeSelector: #warningMessageFor:willHideInstanceVariableDefinedIn:! - -ExtractToTemporary class removeSelector: #errorMessageFor:canNotHideInstanceVariableDefinedIn:! - -ExtractToTemporary class removeSelector: #warn:willHideInstanceVariableDefinedIn:! - -ExtractToTemporary class removeSelector: #warn:willHideInstanceVariableDefinedIn:! - -ExtractToTemporary class removeSelector: #warnIf:isDefinedAsInstanceVariableInHierarchyOf:! - -ExtractToTemporary class removeSelector: #warnIf:isDefinedAsInstanceVariableInHierarchyOf:! - -ExtractToTemporary class removeSelector: #warningMessageFor:willHideInstanceVariableDefinedIn:! - -ExtractToTemporary class removeSelector: #warningMessageFor:willHideInstanceVariableDefinedIn:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3651-RefactoringFailsWhenHiddingVariable-HernanWilkinson-2019Mar07-22h09m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3651] on 10 March 2019 at 2:42:17 pm'! -!ProgressMorph methodsFor: 'accessing' stamp: 'jmv 3/10/2019 14:41:35' prior: 50444412! - updatePositionAndExtent - | w newExtent | - w _ ((labelMorph measureContents x max: subLabelMorph measureContents x) max: 200) + 8. - newExtent _ w > extent x - ifTrue: [ w+10@(labelMorph morphHeight + subLabelMorph morphHeight + progress morphHeight + 10) ] - ifFalse: [ extent ]. - self world - ifNotNil: [ :world | self morphPosition: world morphExtent - newExtent // 2 extent: newExtent ] - ifNil: [ self morphExtent: newExtent ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3652-CenterProgressMorphTweak-JuanVuletich-2019Mar10-14h26m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3652] on 11 March 2019 at 3:12:20 pm'! -!TestCase methodsFor: 'assertions' stamp: 'jmv 3/11/2019 15:05:47'! - shouldFix: aBlock - "Currently disable execution on a Block. - The test fails, but it is an expected failure. - Still, the failure should eventually be fixed."! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3653-TestCase-shouldFix-JuanVuletich-2019Mar11-14h59m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3652] on 11 March 2019 at 9:09:24 am'! -!Compiler methodsFor: 'public access' stamp: 'HAW 3/11/2019 09:04:53'! - compileDoIt: textOrStream in: aClass context: aContext notifying: aRequestor ifFail: failBlock - "Similar to #compile:in:notifying:ifFail:, but the compiled code is - expected to be a do-it expression, with no message pattern." - - self from: textOrStream - class: aClass - context: aContext - notifying: aRequestor. - ^self - translate: sourceStream - noPattern: false - doIt: true - ifFail: failBlock! ! -!Compiler methodsFor: 'private' stamp: 'HAW 3/11/2019 09:04:33'! - translate: aStream noPattern: noPattern doIt: doIt ifFail: failBlock - - ^self parser - sourceStreamGetter: sourceStreamGetter; "Cuis specific. Do not remove!!" - ignoreBacktick: false; - parse: aStream - class: class - category: category - noPattern: noPattern - doIt: doIt - context: context - notifying: requestor - ifFail: [^failBlock value]! ! -!Scanner class methodsFor: 'doIt selectors' stamp: 'HAW 3/11/2019 09:00:46'! - doItInSelector - - ^#DoItIn:! ! -!Scanner class methodsFor: 'doIt selectors' stamp: 'HAW 3/11/2019 09:00:54'! - doItSelector - - ^#DoIt! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 3/11/2019 09:01:34'! - method: noPattern doIt: doIt context: ctxt - " pattern [ | temporaries ] block => MethodNode." - - | sap block primitives temporaries messageComment methodNode | - - sap := self pattern: noPattern inContext: ctxt. - "sap={selector, arguments, precedence}" - self properties selector: (sap at: 1). - encoder selector: (sap at: 1). - (sap at: 2) do: [:argNode | argNode beMethodArg]. - - doIt ifFalse: [self pragmaSequence]. - temporaries := self temporaries. - messageComment := currentComment. - currentComment := nil. - doIt ifFalse: [self pragmaSequence]. - primitives := self pragmaPrimitives. - - self statements: #() innerBlock: doIt. - block := parseNode. - doIt - ifTrue: [block returnLast] - ifFalse: [block returnSelfIfNoOther: encoder]. - hereType == #doIt ifFalse: [^self expected: 'Nothing more']. - - methodNode := self newMethodNode comment: messageComment. - methodNode - selector: (sap at: 1) - arguments: (sap at: 2) - precedence: (sap at: 3) - temporaries: temporaries - block: block - encoder: encoder - primitive: primitives - properties: properties - selectorKeywordsRanges: (sap at: 4). - - self interactive ifTrue: [ self performInteractiveChecks: methodNode ]. - - ^methodNode! ! -!Parser methodsFor: 'public access' stamp: 'HAW 3/11/2019 09:02:15'! - parse: sourceStream class: class category: aCategory noPattern: noPattern doIt: doIt context: aContext notifying: aRequestor ifFail: aBlock - - "Answer a MethodNode for the argument, sourceStream, that is the root of - a parse tree. Parsing is done with respect to the argument, class, to find - instance, class, and pool variables; and with respect to the argument, - ctxt, to find temporary variables. Errors in parsing are reported to the - argument, req, if not nil; otherwise aBlock is evaluated. The argument - noPattern is a Boolean that is true if the the sourceStream does not - contain a method header (i.e., for DoIts)." - - | methNode repeatNeeded myStream sourceCode startPosition | - - category _ aCategory. - myStream _ sourceStream. - [ - repeatNeeded _ false. - startPosition _ myStream position. - sourceCode _ myStream upToEnd. - myStream position: startPosition. - self encoder init: class context: aContext notifying: self. - self init: myStream notifying: aRequestor failBlock: [^ aBlock value ]. - doitFlag _ noPattern. - failBlock _ aBlock. - [ methNode _ self method: noPattern doIt: doIt context: aContext ] - on: ReparseAfterSourceEditing - do: [ :ex | - repeatNeeded _ true. - myStream _ sourceStreamGetter notNil "Cuis specific. Do not remove!!" - ifTrue: [ requestor perform: sourceStreamGetter ] - ifFalse: [ ReadStream on: requestor text string ]]. - repeatNeeded - ] whileTrue: [ encoder _ self encoder class new ]. - - methNode sourceText: sourceCode. - "See #xBacktick" - sentInLiterals do: [ :sym | encoder noteOptimizedSelector: sym ]. - - ^ methNode! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3654-DebugginSourceCode1-HernanWilkinson-2019Mar11-09h00m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3651] on 11 March 2019 at 9:12:47 am'! -!CompiledMethod methodsFor: 'decompiling' stamp: 'HAW 3/11/2019 08:53:25'! - createMethodNode - - "Creates the parse tree that represents self" - - | aClass source | - - aClass := self methodClass. - source := self - getSourceFor: (self selector ifNil: [self defaultSelector]) - in: aClass. - - ^ aClass methodNodeFor: source - ! ! -!CompiledMethod methodsFor: 'as yet unclassified' stamp: 'HAW 3/9/2019 02:52:10'! - methodNode: aMethodNode - - self propertyValueAt: #methodNode put: aMethodNode! ! -!Compiler methodsFor: 'public access' stamp: 'HAW 3/11/2019 06:35:05'! - evaluateMethod: method to: receiver logged: doLog profiled: doProfile - - "See evaluate:in:to:notifying:ifFail:logged:profiled: - It does the same but without compiling because it recevies the result of the compilation - as the parameter method. - self should have compile method" - - | value toLog itsSelection itsSelectionString | - - "(jmv) Log before evaluating. This way, if the evaluation is halted by whatever reason, it is logged anyway" - doLog ifTrue: [ - toLog _ ((requestor respondsTo: #selection) - and: [ (itsSelection _ requestor selection) notNil - and: [ (itsSelectionString _ itsSelection asString) isEmptyOrNil not ]]) - ifTrue: [ itsSelectionString ] - ifFalse: [ sourceStream contents ]. - SystemChangeNotifier uniqueInstance evaluated: toLog context: context ]. - - "Evaluate now." - doProfile - ifTrue: [ - AndreasSystemProfiler spyOn: [ - value _ receiver - withArgs: (context ifNil: [#()] ifNotNil: [{context}]) - executeMethod: method ]] - ifFalse: [ - value _ receiver - withArgs: (context ifNil: [#()] ifNotNil: [{context}]) - executeMethod: method ]. - - ^ value! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'HAW 3/11/2019 08:34:11'! - compileSelectionFor: anObject in: evalContext ifFail: failBlock - - | methodNode method sourceCode compiler | - - sourceCode := self selectionDoItSourceCodeIn: evalContext. - - methodNode _ [ - compiler _ Compiler new. - compiler - sourceStreamGetter: #selectionAsStream; "Cuis specific. Do not remove!!" - compileDoIt: sourceCode - in: anObject class - context: evalContext - notifying: self - ifFail: [ ^ failBlock value ]] - on: OutOfScopeNotification - do: [ :ex | ex resume: true ]. - - methodNode block returnLast. - method _ methodNode generate. - method methodNode: methodNode. - - ^{ #method -> method. #compiler -> compiler } asDictionary -! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'HAW 3/11/2019 08:57:46'! - selectionDoItSourceCodeIn: evalContext - - ^String streamContents: [ :stream | - "I use previousContext and not ThisContext as in the parser to avoid - name collision. Also, previousContext is more intention revealing - Hernan" - stream - nextPutAll: (evalContext ifNil: [ Scanner doItSelector ] ifNotNil: [ Scanner doItInSelector, ' previousContext' ]); - newLine; - newLine; - nextPutAll: self selectionAsStream upToEnd ]! ! -!CompiledMethod methodsFor: 'accessing' stamp: 'HAW 3/11/2019 08:35:51' prior: 16819362! - defaultSelector - - "Invent and answer an appropriate message selector (a Symbol) for me, - that is, one that will parse with the correct number of arguments." - - ^Scanner doItSelector numArgs: self numArgs! ! -!CompiledMethod methodsFor: 'source code management' stamp: 'HAW 3/11/2019 08:47:47' prior: 16820444! - getSourceFor: selector in: class - "Retrieve or reconstruct the source code for this method." - - | flagByte source | - - flagByte := self last. - - "If no source pointer..." - source := flagByte < 252 - ifTrue: [ nil ] - ifFalse: [ - "Situation normal; read the sourceCode from the file - An error can happen here if, for example, the changes file has been truncated by an aborted download. - The present solution is to ignore the error and fall back on the decompiler. - A more thorough solution should probably trigger a systematic invalidation of all source pointers past the end of the changes file. - Consider that, as time goes on, the changes file will eventually grow large enough to cover the lost code, and then instead of falling - into this error case, random source code will get returned." - [self getSourceFromFile] - on: Error - do: [ :ex | ex return: nil]]. - - "If source code not available, use DoIt source code or if absent decompile blind (no temps)" - ^source ifNil: [ (class decompilerClass new decompile: selector in: class method: self) decompileString ]! ! -!CompiledMethod methodsFor: 'decompiling' stamp: 'HAW 3/11/2019 08:55:04' prior: 50408796! - methodNode - - "Return the parse tree that represents self" - - "I do not save the method node in the #methodNode property if it does not - exist to avoid keeping the method node in memory. - The methodNode is saved in the property #methodNode to avoid loosing the source - code when debugging - Hernan" - ^self propertyValueAt: #methodNode ifAbsent: [ self createMethodNode ]! ! -!Compiler methodsFor: 'public access' stamp: 'HAW 3/9/2019 00:01:13' prior: 16821912! - evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock - - ^ self evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock logged: false profiled: false! ! -!Compiler methodsFor: 'public access' stamp: 'HAW 3/11/2019 08:45:50' prior: 50382479! - evaluate: textOrStream in: aContext to: aReceiver notifying: aRequestor ifFail: failBlock logged: doLog profiled: doProfile - "Compiles the sourceStream into a parse tree, then generates code into - a method. If aContext is not nil, the text can refer to temporaries in that - context (the Debugger uses this). If aRequestor is not nil, then it will receive - a notify:at: message before the attempt to evaluate is aborted. Finally, the - compiled method is invoked from here via withArgs:executeMethod:, hence - the system no longer creates Doit method litter on errors." - - | methodNode method | - - class _ (aContext ifNil: [ aReceiver ] ifNotNil: [ aContext receiver ]) class. - methodNode _ self compileNoPattern: textOrStream in: class context: aContext notifying: aRequestor ifFail: [^failBlock value]. - method _ methodNode generate. - "I'm not keeping the source nor the methodNode for back compabibility. - The SmalltalkEditor sends the message #evaluateMethod:... which already keep the method node - for the debugger to show the right source code - Hernan" - - ^self evaluateMethod: method to: aReceiver logged: doLog profiled: doProfile! ! -!Compiler methodsFor: 'private' stamp: 'HAW 3/11/2019 07:07:06' prior: 50409906! - translate: aStream noPattern: noPattern ifFail: failBlock - - ^self translate: aStream noPattern: noPattern doIt: noPattern ifFail: failBlock ! ! -!Compiler class methodsFor: 'evaluating' stamp: 'HAW 3/9/2019 00:01:04' prior: 16822139! - evaluate: textOrString for: anObject notifying: aRequestor logged: logFlag - "Compile and execute the argument, textOrString with respect to the class - of anObject. If a compilation error occurs, notify aRequestor. If both - compilation and execution are successful then, if logFlag is true, log - (write) the text onto a system changes file so that it can be replayed if - necessary." - - ^ self new - evaluate: textOrString - in: nil - to: anObject - notifying: aRequestor - ifFail: [^nil] - logged: logFlag - profiled: false! ! -!Scanner methodsFor: 'xBacktick processing - private' stamp: 'HAW 3/11/2019 08:36:29' prior: 50409927! - compileBacktickCode - - | compiler method methodNode | - - compiler _ Compiler new. - methodNode _ compiler compileNoPattern: buffer contents in: UndefinedObject context: nil notifying: nil ifFail: []. - method _ methodNode generate. - - "Grab all messages sent while evaluating literal, so the main method will be shown as senders of them" - sentInLiterals addAll: method messages. - method literalsDo: [ :literal | literal isSymbol ifTrue: [ literal = self class doItSelector ifFalse: [sentInLiterals add: literal ]]]. - - "Evaluate now." - token _ nil withArgs: #() executeMethod: method ! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 3/11/2019 06:42:49' prior: 50409280! - doitPatternInContext: context - - ^context - ifNil: [{self class doItSelector. {}. 1. nil }] - ifNotNil: [{self class doItInSelector. {encoder encodeVariable: encoder doItInContextName}. 3. nil}]! ! -!Parser methodsFor: 'public access' stamp: 'HAW 3/11/2019 08:31:06' prior: 16886850! - parse: sourceStream class: class noPattern: noPattern context: aContext notifying: aRequestor ifFail: aBlock - - ^self parse: sourceStream class: class category: nil noPattern: noPattern doIt: noPattern context: aContext notifying: aRequestor ifFail: aBlock ! ! -!AssignmentNode methodsFor: 'initialization' stamp: 'HAW 3/10/2019 12:37:09' prior: 16780831! - variable: aVariable value: expression from: encoder - - "Case of remote temp vars" - (aVariable isMemberOf: MessageAsTempNode) ifTrue: [ ^aVariable store: expression from: encoder]. - - variable := aVariable. - value := expression. - - ^self - -! ! -!AssignmentNode methodsFor: 'initialization' stamp: 'HAW 3/9/2019 20:03:46' prior: 16780841! - variable: aVariable value: expression from: encoder sourceRange: range - - | realNode | - - realNode := self variable: aVariable value: expression from: encoder. - encoder noteSourceRange: range forNode: realNode. - - ^realNode! ! -!MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'HAW 3/11/2019 08:56:15' prior: 16867539! - store: expr from: encoder - "ctxt tempAt: n -> ctxt tempAt: n put: expr (see Assignment). - For assigning into temps of a context being debugged." - - selector key ~= #namedTempAt: ifTrue: [^self error: 'cant transform this message']. - - ^ MessageAsTempNode new - receiver: receiver - selector: #namedTempAt:put: - arguments: (arguments copyWith: expr) - precedence: precedence - from: encoder! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'HAW 3/11/2019 06:25:51' prior: 16909636! - compileSelectionFor: anObject in: evalContext - - ^(self compileSelectionFor: anObject in: evalContext ifFail: [ ^ nil ]) at: #method -! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'HAW 3/11/2019 08:57:10' prior: 16909670! - debugIt - - | provider method receiver context | - - self lineSelectAndEmptyCheck: [^self]. - - provider _ self codeProvider. - (provider respondsTo: #doItReceiver) - ifTrue: [ - receiver _ provider doItReceiver. - context _ provider doItContext] - ifFalse: [ - receiver _ context _ nil]. - - method _ self compileSelectionFor: receiver in: context. - method ifNotNil: [ self debug: method receiver: receiver in: context ]! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'HAW 3/11/2019 08:42:34' prior: 16909696! - evaluateSelectionAndDo: aBlock ifFail: failBlock profiled: doProfile - "Treat the current selection as an expression; evaluate it and return the result - 3 +4 - " - | provider result receiver context methodAndCompiler | - - self lineSelectAndEmptyCheck: [^ '']. - - provider _ self codeProvider. - (provider respondsTo: #doItReceiver) - ifTrue: [ - receiver _ provider doItReceiver. - context _ provider doItContext] - ifFalse: [receiver _ context _ nil]. - - methodAndCompiler _ self compileSelectionFor: receiver in: context ifFail: [^ failBlock value]. - - result _ (methodAndCompiler at: #compiler) - evaluateMethod: (methodAndCompiler at: #method) - to: receiver - logged: true - profiled: doProfile. - - morph formatAndStyleIfNeeded. "Needed to re-shout workspaces, that might have new variables binded." - - ^ aBlock value: result! ! -!DebuggerMethodMap methodsFor: 'source mapping' stamp: 'HAW 3/11/2019 08:39:26' prior: 16830789! -abstractSourceMap - "Answer with a Dictionary of abstractPC to sourceRange ." - - | theMethodToScan rawSourceRanges concreteSourceRanges abstractPC scanner client | - - abstractSourceRanges ifNotNil: [ ^abstractSourceRanges]. - - methodNode encoder hasGeneratedMethod - ifTrue: [ - rawSourceRanges := methodNode encoder rawSourceRanges. - theMethodToScan := self method ] - ifFalse: [ - "If the methodNode hasn't had a method generated it doesn't have pcs set in its - nodes so we must generate a new method and might as well use it for scanning." - [methodNode rawSourceRangesAndMethodDo: [ :ranges :method | - rawSourceRanges := ranges. - theMethodToScan := method ]] - on: UndeclaredVariableWarning - do: [ :ex | ex resume ]]. - - concreteSourceRanges := Dictionary new. - rawSourceRanges keysAndValuesDo: [ :node :range | - node pc ~= 0 ifTrue: [ | realRange | - realRange := (range isKindOf: OrderedCollection) ifTrue: [ range last ] ifFalse: [ range ]. - concreteSourceRanges at: node pc put: realRange ]]. - - abstractPC := 1. - abstractSourceRanges := Dictionary new. - scanner := InstructionStream on: theMethodToScan. - client := InstructionClient new. - [ - (concreteSourceRanges includesKey: scanner pc) ifTrue: [ - abstractSourceRanges at: abstractPC put: (concreteSourceRanges at: scanner pc)]. - abstractPC := abstractPC + 1. - scanner interpretNextInstructionFor: client. - scanner atEnd ] whileFalse. - - ^abstractSourceRanges! ! -!DebuggerMethodMap methodsFor: 'source mapping' stamp: 'HAW 3/9/2019 03:26:53' prior: 16830892! - sourceText - - ^methodNode sourceText! ! -!DebuggerMethodMap class methodsFor: 'instance creation' stamp: 'HAW 3/11/2019 08:55:37' prior: 16830911! - forMethod: aMethod "" - "Answer a DebuggerMethodMap suitable for debugging activations of aMethod. - Answer an existing instance from the cache if it exists, cacheing a new one if required." - - | methodNode | - - ^self protected: [ - MapCache - at: aMethod - ifAbsent: [ - [ methodNode _ aMethod methodNode ] - on: UndeclaredVariableWarning - do: [ :ex | ex resume ]. - self - cacheDebugMap: (self - forMethod: aMethod - methodNode: methodNode) - forMethod: aMethod] ]! ! -!DebuggerMethodMap class methodsFor: 'instance creation' stamp: 'HAW 3/9/2019 03:16:29' prior: 16830930! - forMethod: aMethod "" methodNode: methodNode "" - "Uncached instance creation method for private use or for tests. - Please consider using forMethod: instead." - ^self new - forMethod: aMethod - methodNode: methodNode! ! - -Parser removeSelector: #method:context:! - -Parser removeSelector: #method:context:! - -Parser removeSelector: #parse:class:category:noPattern:context:notifying:ifFail:! - -Parser removeSelector: #parse:class:category:noPattern:context:notifying:ifFail:! - -Compiler removeSelector: #evaluateMethod:in:to:logged:profiled:! - -Compiler removeSelector: #evaluateMethod:in:to:notifying:ifFail:logged:profiled:! - -Compiler removeSelector: #evaluateMethod:in:to:notifying:logged:profiled:! - -CompiledMethod removeSelector: #doItSourceCodeIfAbsent:! - -CompiledMethod removeSelector: #generateDoItSourceCodeWith:! - -CompiledMethod removeSelector: #keepDoItSourceCodeWith:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3655-DebuggingSourceCode2-HernanWilkinson-2019Mar08-22h34m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3655] on 12 March 2019 at 2:14:59 pm'! -!Date methodsFor: 'squeak protocol' stamp: 'jmv 3/12/2019 13:50:59'! - > aDate - - self assert: aDate class == Date. - ^ self start > aDate start! ! -!Time class methodsFor: 'general inquiries' stamp: 'jmv 3/12/2019 14:02:51' prior: 16937263! - localMicrosecondClock - "Answer the number of microseconds since the Smalltalk epoch, - i.e. 00:00 on the morning of January 1, 1901, in the local host time zone. - In other words, the number of microseconds since it was that time in this time zone. - Answer might be a LargePositiveInteger (very likely on 32-bit images, very unlikely on 64-bit images). - - { Time localMicrosecondClock . Time localMicrosecondClock // 1000000 . Time localSecondClock } print - - Note 1: Never rolls over. Can be used with confidence. Joins primMillisecondClock - rollover control and sync with seconds clock. Uses existing offset if any, and validates result. - Resynchs if needed. Resynch is very robust. No problems if clocks go out of synch for unknown reasons. - - Note 2: This is in local time, i.e. the time the system shows to the user. UTC would be better, - but older VMs don't know about the current time zone" - - "If our VM supports the new primitive, just use it." - self primLocalMicrosecondClock ifNotNil: [ :microSecs | ^microSecs ]. - - "Otherwise we'll have just millisecond precision" - ^self localMillisecondClock * 1000! ! -!Time class methodsFor: 'general inquiries' stamp: 'jmv 3/12/2019 14:02:55' prior: 16937299! - localMillisecondClock - "Answer the number of milliseconds since the Smalltalk epoch, - i.e. 00:00 on the morning of January 1, 1901, in the local host time zone. - In other words, the number of milliseconds since it was that time in this time zone. - Answer might be a LargePositiveInteger (very likely on 32-bit images, very unlikely on 64-bit images). - - { Time localMillisecondClock . Time localMillisecondClock // 1000 . Time localSecondClock } print - - Note 1: Never rolls over. Can be used with confidence. Joins primMillisecondClock - rollover control and sync with seconds clock. Uses existing offset if any, and validates result. - Resynchs if needed. Resynch is very robust. No problems if clocks go out of synch for unknown reasons. - - Note 2: This is in local time, i.e. the time the system shows to the user. UTC would be better, - but older VMs don't know about the current time zone" - - | millisecsSinceStartupOrRollover nowMillisecs nowSecs delay lastSecond | - - "If our VM supports the new primitive, just use it." - self primLocalMicrosecondClock ifNotNil: [ :microSecs | ^microSecs // 1000 ]. - - "Otherwise use millisecond clock and offset from second clock" - MillisecondClockOffset ifNil: [ MillisecondClockOffset _ 0 ]. "Fix it below." - millisecsSinceStartupOrRollover _ self primMillisecondClock. - nowMillisecs _ millisecsSinceStartupOrRollover + MillisecondClockOffset. - - "Do expensive resync (delay 1 second) only on primMillisecondClock rollover, or if for whatever reason offset is wrong." - nowSecs _ self primLocalSecondsClock. - nowMillisecs // 1000 = nowSecs ifFalse: [ - delay _ Delay forMilliseconds: 1. - lastSecond _ self primLocalSecondsClock. - [ lastSecond = self primLocalSecondsClock ] whileTrue: [ delay wait ]. - millisecsSinceStartupOrRollover _ self primMillisecondClock. - nowSecs _ lastSecond + 1. - MillisecondClockOffset _ nowSecs * 1000 - millisecsSinceStartupOrRollover ]. - - nowMillisecs _ MillisecondClockOffset + millisecsSinceStartupOrRollover. - ^nowMillisecs! ! -!Time class methodsFor: 'general inquiries' stamp: 'jmv 3/12/2019 14:03:05' prior: 16937363! - localSecondClock - "Answer the number of milliseconds since the Smalltalk epoch, - i.e. 00:00 on the morning of January 1, 1901, in the local host time zone. - In other words, the number of milliseconds since it was that time in this time zone. - This is in local time, i.e. the time the system shows to the user. - Answer might be a LargePositiveInteger (very likely on 32-bit images, very unlikely on 64-bit images). - - { Time localMillisecondClock . Time localMillisecondClock // 1000 . Time localSecondClock } print - " - ^self localMillisecondClock // 1000! ! -!Time class methodsFor: 'primitives' stamp: 'jmv 3/12/2019 14:03:29' prior: 50378291! - primHighResClock - "Primitive. Answer the value of the high resolution clock if this computer has one. - Usually, this should be the highest resolution value available, for example on Intel - it will be the value of the time stamp counter register. - Answer might be a LargePositiveInteger (very likely on 32-bit images, very unlikely on 64-bit images). - Implemented on Cog, but not in standard interpreter VMs." - " - Time primHighResClock - On Cog on Linux, OS-X and Windows, this gives sub nano second ticks!! - - Time highResTimerTicksPerMillisecond - " - "Not really a clock, but a timer or ticker" - - - ^0! ! -!Time class methodsFor: 'primitives' stamp: 'jmv 3/12/2019 14:03:33' prior: 16937585! - primLocalMicrosecondClock - "Answer the number of microseconds since the local time zone Smalltalk epoch, - i.e. 00:00 on the morning of January 1, 1901, in local time. - Answer might be a LargePositiveInteger (very likely on 32-bit images, very unlikely on 64-bit images). - Cog VMs implement this. Interpreters might not." - " - Time primLocalMicrosecondClock - Time primLocalMicrosecondClock/ 1000 / 1000 / 60 / 60 / 24 / 365.25 - " - - ^nil! ! -!Time class methodsFor: 'primitives' stamp: 'jmv 3/12/2019 14:05:35' prior: 16937600! - primLocalSecondsClock - "Answer the number of seconds since the Smalltalk epoch, - i.e. 00:00 on the morning of January 1, 1901, in the local host time zone. - In other words, the number of seconds since it was that time in this time zone. - Answer is a 32-bit unsigned number. - Answer might be a LargePositiveInteger on 32-bit images. - Note: This is in local time, i.e. the time the system shows to the user. - Essential. See Object documentation whatIsAPrimitive. - - Time primLocalSecondsClock - Time primLocalSecondsClock / 60 / 60 / 24 / 365.25 - - Warning: Will overflow in year 2037 - " - - - self primitiveFailed! ! -!Time class methodsFor: 'primitives' stamp: 'jmv 3/12/2019 14:05:48' prior: 50340956! - primUtcMicrosecondClock - "Answer the number of microseconds since the UTC Smalltalk epoch, - i.e. 00:00 on the morning of January 1, 1901, the start of the 20th century, in UTC time. - The value is derived from the Posix epoch with a constant offset corresponding to elapsed microseconds - between the two epochs according to RFC 868. - Answer might be a LargePositiveInteger (very likely on 32-bit images, very unlikely on 64-bit images). - Cog VMs implement this. Interpreters might not." - " - Time primUtcMicrosecondClock - Time primUtcMicrosecondClock/ 1000 / 1000 / 60 / 60 / 24 / 365.25 - - (Time primUtcMicrosecondClock / 1000 / 1000 + Time primUtcWithOffset second) / 60 / 60 / 24 / 365.25 - (DateAndTime now - (DateAndTime year: 1901 month: 1 day: 1)) totalSeconds / 60 / 60 / 24 / 365.25 - " - - ^nil! ! -!Time class methodsFor: 'primitives' stamp: 'jmv 3/12/2019 14:07:31' prior: 16937663! - primUtcWithOffset - "Answer a two element array. - - First element is the number of microseconds since the UTC Posix (Unix) epoch, - i.e. 00:00 on the morning of January 1, 1970, in UTC time. - It might be a LargePositiveInteger (very likely on 32-bit images, very unlikely on 64-bit images). - - Second element is the current seconds offset from GMT in the local time zone. - - Recent VMs implement this. Older Interpreters might not. - " - " - Time primUtcWithOffset - Time primUtcWithOffset first / 1000 / 1000 / 60 / 60 / 24 / 365.25 - Time primUtcWithOffset second / 60 / 60.0 - - (Time primUtcWithOffset first / 1000 / 1000 + Time primUtcWithOffset second) / 60 / 60 / 24 / 365.25 - (DateAndTime now - (DateAndTime year: 1970 month: 1 day: 1)) totalSeconds / 60 / 60 / 24 / 365.25 - " - - ^nil - - " - Evaluate on various platforms and record the results -{ - Smalltalk vmVersion . - Smalltalk platformName . - Smalltalk platformSubtype . - Smalltalk osVersion . - Time primLocalMicrosecondClock/ 1000 / 1000 / 60 / 60 / 24 / 365.25 . - Time primLocalSecondsClock / 60 / 60 / 24 / 365.25 . - Time primUtcMicrosecondClock / 1000 / 1000 / 60 / 60 / 24 / 365.25 . - Time primUtcWithOffset first / 1000 / 1000 / 60 / 60 / 24 / 365.25 . - Time primUtcWithOffset second / 60 / 60.0 -} - "! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3656-SomeMethodCommentTweaks-JuanVuletich-2019Mar11-17h23m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3652] on 11 March 2019 at 3:33:12 pm'! - -"Change Set: 3653-CuisCore-AuthorName-2019Mar11-14h53m -Date: 11 March 2019 -Author: Nahuel Garbezza - -Categorize a bunch of uncategorized methods"! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3657-MethodsCategorization-NahuelGarbezza-2019Mar11-14h53m-RNG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3652] on 11 March 2019 at 4:34:52 pm'! - -"Change Set: 3653-CuisCore-AuthorName-2019Mar11-15h56m -Date: 11 March 2019 -Author: Nahuel Garbezza - -Add (R) as a shortcut to rename packages, classes, categories and methods"! -!CodeWindow methodsFor: 'keyboard shortcuts' stamp: 'RNG 3/11/2019 16:33:24' prior: 50338609! - messageListKey: aChar from: view - "Respond to a Command key. I am a model with a code pane, and I also - have a listView that has a list of methods. The view knows how to get - the list and selection." - - | sel class | - aChar == $D ifTrue: [^ model toggleDiffing]. - - sel _ model selectedMessageName. - aChar == $m ifTrue: [ "These next two put up a type in if no message selected" - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllImplementorsOf: to: Smalltalk]. - aChar == $n ifTrue: [ - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllCallsOn: to: Smalltalk]. - - "The following require a class selection" - (class _ model selectedClassOrMetaClass) ifNil: [^ self ]. - aChar == $b ifTrue: [^ BrowserWindow fullOnClass: class selector: sel]. - aChar == $N ifTrue: [^ self browseClassRefs]. - aChar == $i ifTrue: [^ self methodHierarchy]. - aChar == $h ifTrue: [^ self browseHierarchy]. - aChar == $p ifTrue: [^ self browseFullProtocol]. - - sel - ifNotNil: [ - "The following require a method selection" - aChar == $o ifTrue: [^ model fileOutMessage]. - aChar == $c ifTrue: [^ model copySelector]. - aChar == $v ifTrue: [^ self browseVersions]. - aChar == $O ifTrue: [^ self openSingleMessageBrowser]. - aChar == $x ifTrue: [^ model removeMessage]. - aChar == $t ifTrue: [^ model runMethodTest]. - aChar == $r ifTrue: [^ model debugMethodTest]. - aChar == $R ifTrue: [^ self renameSelector]] - ifNil: [ - aChar == $R ifTrue: [^ model renameClass]]! ! -!CodeWindow methodsFor: 'keyboard shortcuts' stamp: 'RNG 3/1/2019 21:49:28' prior: 50419684! - systemCatListKey: aChar from: view - "Respond to a Command key. I am a model with a code pane, and I also have a listView that has a list of methods. The view knows how to get the list and selection." - - aChar == $f ifTrue: [ ^ self findClass ]. - aChar == $x ifTrue: [ ^ model removeSystemCategory ]. - aChar == $t ifTrue: [ ^ model runSystemCategoryTests ]. - aChar == $a ifTrue: [ ^ model addSystemCategory ]. - aChar == $A ifTrue: [ ^ model alphabetizeSystemCategories ]. - aChar == $b ifTrue: [ ^ self openSystemCategoryBrowser ]. - aChar == $B ifTrue: [ ^ self browseAllClasses ]. - aChar == $o ifTrue: [ ^ model fileOutSystemCategory ]. - aChar == $u ifTrue: [ ^ model updateSystemCategories ]. - aChar == $R ifTrue: [ ^ model renameSystemCategory ]. - - ^ self classListKey: aChar from: view! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'RNG 3/1/2019 21:50:23' prior: 50411320! - classListMenuOptions - - ^ `{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutClass. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 5. - #label -> 'show classes hierarchically'. - #object -> #model. - #selector -> #enableListClassesHierarchically. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 6. - #label -> 'show classes alphabetically'. - #object -> #model. - #selector -> #enableListClassesAlphabetically. - #icon -> #sendReceiveIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'show hierarchy'. - #object -> #model. - #selector -> #hierarchy. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'show definition'. - #object -> #model. - #selector -> #editClass. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'show comment'. - #object -> #model. - #selector -> #editComment. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'inst var refs...'. - #selector -> #browseInstVarRefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'inst var defs...'. - #selector -> #browseInstVarDefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'class var refs...'. - #selector -> #browseClassVarRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 20. - #label -> 'class vars'. - #selector -> #browseClassVariables. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'class refs (N)'. - #selector -> #browseClassRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'rename class... (R)'. - #object -> #model. - #selector -> #renameClass. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 20. - #label -> 'copy class...'. - #object -> #model. - #selector -> #copyClass. - #icon -> #copyIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 30. - #label -> 'remove class (x)'. - #object -> #model. - #selector -> #removeClass. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 10. - #label -> 'run tests (t)'. - #object -> #model. - #selector -> #runClassTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 20. - #label -> 'more...'. - #selector -> #offerClassListMenu2. - #icon -> #listAddIcon - } asDictionary. - }`. - ! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'RNG 3/1/2019 21:48:16' prior: 50411731! - systemCatSingletonMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'find class... (f)'. - #selector -> #findClass. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'browse all (B)'. - #selector -> #browseAllClasses. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'browse (b)'. - #selector -> #openSystemCategoryBrowser. - #icon -> #packageIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'fileOut (o)'. - #object -> #model. - #selector -> #fileOutSystemCategory. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'update (u)'. - #object -> #model. - #selector -> #updateSystemCategories. - #icon -> #updateIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'rename... (R)'. - #object -> #model. - #selector -> #renameSystemCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'remove (x)'. - #object -> #model. - #selector -> #removeSystemCategory. - #icon -> #deleteIcon - } asDictionary. - }`. - ! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'RNG 3/1/2019 21:48:09' prior: 50419711! - systemCategoryMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'find class... (f)'. - #selector -> #findClass. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'recent classes... (r)'. - #object -> #model. - #selector -> #recent. - #icon -> #clockIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'browse all (B)'. - #selector -> #browseAllClasses. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'browse (b)'. - #selector -> #openSystemCategoryBrowser. - #icon -> #packageIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'fileOut (o)'. - #object -> #model. - #selector -> #fileOutSystemCategory. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'reorganize'. - #object -> #model. - #selector -> #editSystemCategories. - #icon -> #sendReceiveIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'alphabetize (A)'. - #object -> #model. - #selector -> #alphabetizeSystemCategories. - #icon -> #fontXGenericIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'update (u)'. - #object -> #model. - #selector -> #updateSystemCategories. - #icon -> #updateIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 20. - #label -> 'add item... (a)'. - #object -> #model. - #selector -> #addSystemCategory. - #icon -> #newIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'rename... (R)'. - #object -> #model. - #selector -> #renameSystemCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 40. - #label -> 'remove (x)'. - #object -> #model. - #selector -> #removeSystemCategory. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'move to top'. - #object -> #model. - #selector -> #moveSystemCategoryTop. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 20. - #label -> 'move up'. - #object -> #model. - #selector -> #moveSystemCategoryUp. - #icon -> #goUpIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 30. - #label -> 'move down'. - #object -> #model. - #selector -> #moveSystemCategoryDown. - #icon -> #goDownIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 40. - #label -> 'move to bottom'. - #object -> #model. - #selector -> #moveSystemCategoryBottom. - #icon -> #goBottomIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 10. - #label -> 'run tests (t)'. - #object -> #model. - #selector -> #runSystemCategoryTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - }`. - ! ! -!RefactoringMenues class methodsFor: 'browser menues' stamp: 'RNG 3/11/2019 15:58:36' prior: 50442450! - classRefactoringMenuOptions - - ^ `{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'rename class... (R)'. - #object -> #model. - #selector -> #renameClass. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'insert superclass...'. - #object -> #model. - #selector -> #insertSuperclass. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'safely remove class (x)'. - #object -> #model. - #selector -> #safelyRemoveClass. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'add inst var...'. - #selector -> #addInstVar. - #icon -> #listAddIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'rename inst var...'. - #selector -> #renameInstVar. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'remove inst var...'. - #selector -> #removeInstVar. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 40. - #label -> 'remove all unreferenced inst var...'. - #selector -> #removeAllUnreferencedInstVar. - #icon -> #deleteIcon - } asDictionary. - }`. - ! ! -!RefactoringMenues class methodsFor: 'browser menues' stamp: 'RNG 3/11/2019 15:58:48' prior: 50442508! - messsageRefactoringMenuOptions - - ^ `{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'rename... (R)'. - #selector -> #renameSelector. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'add parameter...'. - #selector -> #addParameter. - #icon -> #listAddIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'remove parameter...'. - #selector -> #removeParameter. - #icon -> #listRemoveIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'push up'. - #selector -> #pushUpSelector. - #icon -> #goTopIcon - } asDictionary. - }`. - - ! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3658-Shortcuts-NahuelGarbezza-2019Mar11-15h56m-RNG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3656] on 12 March 2019 at 3:09:32 pm'! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'jmv 3/12/2019 15:07:50' prior: 50436553! - resetMenu - - | width newExtent | - self hideSelectorDocumentation. - - firstVisible := 1. - self selected: ((completer canSelect: (completer entries at: firstVisible)) ifTrue: [firstVisible] ifFalse: [firstVisible+1]). - - self calculateItemsPerPage. - width _ self calculateWidth. - newExtent _ width + 4 @ (itemsPerPage * self itemHeight + 2). - - self morphPosition: originalPosition extent: newExtent. - "redraw is needed even if position and extent haven't changed" - self redrawNeeded ! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3659-skipCategoryTitleInAutocompleter-JuanVuletich-2019Mar12-15h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3659] on 12 March 2019 at 10:00:35 pm'! - -"Change Set: 3660-CuisCore-AuthorName-2019Mar12-21h45m -Date: 12 March 2019 -Author: Nahuel Garbezza - -Add some shortcuts to file list"! -!FileListWindow methodsFor: 'keyboard shortcuts' stamp: 'RNG 3/12/2019 21:55:43'! - fileListKey: aChar from: aView - - aChar == $x ifTrue: [ ^ aView model deleteFile ]. - aChar == $R ifTrue: [ ^ aView model renameFile ]. - aChar == $n ifTrue: [ ^ aView model addNewFile ]. - aChar == $N ifTrue: [ ^ aView model addNewDirectory ].! ! -!FileList methodsFor: 'own services' stamp: 'RNG 3/12/2019 21:57:34' prior: 50427101! - serviceAddNewDirectory - "Answer a service entry characterizing the 'add new directory' command" - - ^ SimpleServiceEntry - provider: self - label: 'add new directory (N)' - selector: #addNewDirectory - description: 'adds a new, empty directory (folder)' - icon: #listAddIcon! ! -!FileList methodsFor: 'own services' stamp: 'RNG 3/12/2019 21:56:19' prior: 50427113! - serviceAddNewFile - "Answer a service entry characterizing the 'add new file' command" - - ^ SimpleServiceEntry - provider: self - label: 'add new file (n)' - selector: #addNewFile - description: 'create a new,. empty file, and add it to the current directory.' - icon: #newIcon! ! -!FileList methodsFor: 'own services' stamp: 'RNG 3/12/2019 21:58:57' prior: 50427134! - serviceDeleteFile - - ^ SimpleServiceEntry - provider: self - label: 'delete (x)' - selector: #deleteFile - description: 'delete the seleted item' - icon: #deleteIcon! ! -!FileList methodsFor: 'own services' stamp: 'RNG 3/12/2019 21:59:33' prior: 50427163! - serviceRenameFile - - ^ SimpleServiceEntry - provider: self - label: 'rename (R)' - selector: #renameFile - description: 'rename file' - icon: #saveAsIcon! ! -!FileListWindow methodsFor: 'GUI building' stamp: 'RNG 3/12/2019 21:47:48' prior: 16843344! - morphicFileListPane - - ^PluggableListMorph - model: model - listGetter: #fileList - indexGetter: #fileListIndex - indexSetter: #fileListIndex: - mainView: self - menuGetter: #fileListMenu - keystrokeAction: #fileListKey:from:! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3660-FileListShortcuts-NahuelGarbezza-2019Mar12-21h45m-RNG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3660] on 13 March 2019 at 11:31:28 am'! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 3/13/2019 11:30:42' prior: 50406073! - parse: isAMethod - "Parse the receiver's text. If isAMethod is true - then treat text as a method, if false as an - expression with no message pattern" - - | continue prevSourcePosition | - self initializeInstanceVariables. - sourcePosition _ 1. - arguments _ Dictionary new. - temporaries _ Dictionary new. - blockDepth _ bracketDepth := 0. - blockDepths _ OrderedCollection with: blockDepth. - blockDepthsStartIndexes _ OrderedCollection with: sourcePosition. - ranges ifNil: [ ranges := OrderedCollection new: 100] ifNotNil: [ ranges reset]. - errorBlock _ [^false]. - [ - self scanNext. - isAMethod - ifTrue: [ - self parseMessagePattern. - self parsePragmaSequence]. - self parseMethodTemporaries. - isAMethod ifTrue: [self parsePragmaSequence]. - "Iterate once for methods, but pontentially several times for workspaces - (to recover after errors, for possible good next lines or chunks)" - continue _ true. - [ continue ] whileTrue: [ - prevSourcePosition _ sourcePosition. - self parseStatementList. - continue _ sourcePosition > prevSourcePosition. - isAMethod - ifTrue: [ - "Only if we are parsing a method, consider everything after this point as error." - currentToken ifNotNil: [ self error ]. - continue _ false] - ifFalse: [ - sourcePosition > source size ifTrue: [continue _ false]]]. - ] ensure: [errorBlock _ nil]. - ^true! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3661-SyntaxHighlighterFix-JuanVuletich-2019Mar13-11h12m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3661] on 14 March 2019 at 1:15:33 pm'! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 3/14/2019 13:04:03' prior: 16880199! - raisedToInteger: anInteger - - "The 0 raisedToInteger: 0 is an special case. In some contexts must be 1 and in others must - be handled as an indeterminate form. - I take the first context because that's the way that was previously handled. - Maybe further discussion is required on this topic." - - | bitProbe result firstTry exponent exponent1 exponent2 | - - anInteger negative ifTrue: [ - exponent := anInteger negated. - firstTry := self raisedToInteger: exponent. - ^firstTry isInfinite - ifFalse: [firstTry reciprocal] - ifTrue: [ - exponent1 _ exponent // 2. - exponent2 _ exponent - exponent1. - (self raisedToInteger: exponent1) reciprocal * (self raisedToInteger: exponent2) reciprocal ]]. - bitProbe := 1 bitShift: anInteger highBit - 1. - result := self class one. - [ - (anInteger bitAnd: bitProbe) = 0 ifFalse: [result := result * self]. - bitProbe := bitProbe bitShift: -1. - bitProbe > 0 ] - whileTrue: [result := result * result]. - - ^result! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3662-fix-raisedToInteger-edgeCases-JuanVuletich-2019Mar14-13h00m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3610] on 14 March 2019 at 4:34:14 pm'! -!Editor methodsFor: 'private' stamp: 'AY 3/14/2019 16:25:09'! - nextWordEndFrom: aPosition goingForwards: goingForwardsBoolean - - "Answer the position of the end of the next word on the current line going - forwards (or backwards). - If the given position is the end (or beginning) of the line then answer the - beginning (or end) of the next (or previous) line." - - | string beginningOfLine endOfLine step offset index newPosition | - - string _ self privateCurrentString. - beginningOfLine _ self beginningOfLine: aPosition. - endOfLine _ self endOfLine: aPosition. - step _ goingForwardsBoolean ifTrue: [1] ifFalse: [-1]. - offset _ goingForwardsBoolean ifTrue: [0] ifFalse: [-1]. - - index _ aPosition. - [(index + step between: beginningOfLine and: endOfLine) - and: [(string at: index + offset) isValidInIdentifiers not]] - whileTrue: [index _ index + step]. - [(index + step between: beginningOfLine and: endOfLine) - and: [(string at: index + offset) isValidInIdentifiers]] - whileTrue: [index _ index + step]. - - newPosition _ index = aPosition ifTrue: [index + step] ifFalse: [index]. - ^newPosition min: string size + 1 max: 1! ! -!Editor methodsFor: 'private' stamp: 'AY 3/14/2019 16:29:31'! - nextWordStartFrom: aPosition goingForwards: goingForwardsBoolean - - "Answer the position of the start of the next word on the current line going - forwards (or backwards). - If the given position is the end (or beginning) of the line then answer the - beginning (or end) of the next (or previous) line." - - | string beginningOfLine endOfLine step offset index newPosition | - - string _ self privateCurrentString. - beginningOfLine _ self beginningOfLine: aPosition. - endOfLine _ self endOfLine: aPosition. - step _ goingForwardsBoolean ifTrue: [1] ifFalse: [-1]. - offset _ goingForwardsBoolean ifTrue: [0] ifFalse: [-1]. - - index _ aPosition. - [(index + step between: beginningOfLine and: endOfLine) - and: [(string at: index + offset) isValidInIdentifiers]] - whileTrue: [index _ index + step]. - [(index + step between: beginningOfLine and: endOfLine) - and: [(string at: index + offset) isValidInIdentifiers not]] - whileTrue: [index _ index + step]. - - newPosition _ index = aPosition ifTrue: [index + step] ifFalse: [index]. - ^newPosition min: string size + 1 max: 1! ! -!Editor methodsFor: 'nonediting/nontyping keys' stamp: 'AY 3/14/2019 01:24:07' prior: 16836563! - cursorLeft: aKeyboardEvent - "Private - Move cursor left one character if nothing selected, otherwise move cursor to beginning of selection. If the shift key is down, start selecting or extending current selection. - Don't allow cursor past beginning of text" - - self - moveCursor: [ :position | | newPos | - newPos _ position - 1. - "Mac standard keystroke" - (aKeyboardEvent rawMacOptionKeyPressed or: [ - "Windows / Linux standard keystroke" - aKeyboardEvent controlKeyPressed ]) - ifTrue: [ newPos _ self previousWordStart: position ]. - "Mac standard keystroke" - aKeyboardEvent commandAltKeyPressed ifTrue: [ - newPos _ self beginningOfLine: position ]. - newPos ] - forward: false - event: aKeyboardEvent. - ^ true! ! -!Editor methodsFor: 'nonediting/nontyping keys' stamp: 'AY 3/14/2019 16:26:36' prior: 16836609! -cursorRight: aKeyboardEvent - "Private - Move cursor right one character if nothing selected, otherwise move cursor to end of selection. If the shift key is down, start selecting characters or extending already selected characters. - Don't allow cursor past end of text" - - self - moveCursor: [ :position | | newPos | - newPos _ position + 1. - "Mac standard keystroke" - (aKeyboardEvent rawMacOptionKeyPressed or: [ - "Windows / Linux standard keystroke" - aKeyboardEvent controlKeyPressed ]) - ifTrue: [ newPos _ self nextWordEnd: position ]. - "Mac standard keystroke" - aKeyboardEvent commandAltKeyPressed ifTrue: [ - newPos _ self endOfLine: position ]. - newPos ] - forward: true - event: aKeyboardEvent. - ^ true! ! -!Editor methodsFor: 'private' stamp: 'AY 3/14/2019 16:30:31' prior: 16836804! - nextWordEnd: aPosition - - ^self nextWordEndFrom: aPosition goingForwards: true! ! -!Editor methodsFor: 'private' stamp: 'AY 3/14/2019 16:30:13' prior: 16836818! -nextWordStart: aPosition - - ^self nextWordStartFrom: aPosition goingForwards: true! ! -!Editor methodsFor: 'private' stamp: 'AY 3/14/2019 16:31:46' prior: 16836832! - previousWordStart: aPosition - - ^self nextWordEndFrom: aPosition goingForwards: false! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3663-NextWord-PreviousWord-tweaks-AngelYan-2019Mar13-22h56m-AY.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3661] on 15 March 2019 at 2:26:59 pm'! -!AutoCompleterMorph methodsFor: 'accessing' stamp: 'AY 3/15/2019 11:51:58'! - entryCount - - ^completer entryCount! ! -!AutoCompleterMorph methodsFor: 'accessing' stamp: 'AY 3/15/2019 13:26:28'! - itemsPerPage - - ^itemsPerPage! ! -!AutoCompleterMorph methodsFor: 'private' stamp: 'AY 3/15/2019 13:04:51'! - firstSelectableEntryIndex - - ^self nextSelectableEntryIndexFrom: 0! ! -!AutoCompleterMorph methodsFor: 'private' stamp: 'AY 3/15/2019 14:01:03'! - firstVisible: anIndex - - firstVisible _ anIndex - min: self entryCount - self itemsPerPage + 1 - max: 1.! ! -!AutoCompleterMorph methodsFor: 'private' stamp: 'AY 3/15/2019 14:10:19'! - lastSelectableEntryIndex - - ^self previousSelectableEntryIndexFrom: 1! ! -!AutoCompleterMorph methodsFor: 'private' stamp: 'AY 3/15/2019 14:01:42'! - lastVisible: anIndex - - self firstVisible: anIndex - self itemsPerPage + 1.! ! -!AutoCompleterMorph methodsFor: 'private' stamp: 'AY 3/15/2019 13:31:48'! - nextSelectableEntryIndexFrom: anIndex - - ^self nextSelectableEntryIndexFrom: anIndex goingForwards: true! ! -!AutoCompleterMorph methodsFor: 'private' stamp: 'AY 3/15/2019 13:31:31'! - nextSelectableEntryIndexFrom: anIndex goingForwards: goingForwardsBoolean - - | direction indicesFromAnIndex | - - direction _ goingForwardsBoolean ifTrue: [1] ifFalse: [-1]. - indicesFromAnIndex _ (1 to: self entryCount) - collect: [ :offset | self wrapIndex: anIndex + (offset*direction) by: self entryCount ]. - - ^indicesFromAnIndex - detect: [ :index | self canSelectEntryAt: index ] - ifNone: [self error: 'there are no selectable entries']! ! -!AutoCompleterMorph methodsFor: 'private' stamp: 'AY 3/15/2019 14:18:28'! - nextSelectableEntryIndexFromAndIncluding: anIndex - - ^self nextSelectableEntryIndexFrom: anIndex - 1! ! -!AutoCompleterMorph methodsFor: 'private' stamp: 'AY 3/15/2019 13:32:02'! - previousSelectableEntryIndexFrom: anIndex - - ^self nextSelectableEntryIndexFrom: anIndex goingForwards: false! ! -!AutoCompleterMorph methodsFor: 'private' stamp: 'AY 3/15/2019 13:25:42'! - wrapIndex: anIndex by: aSize - - ^anIndex - 1 \\ aSize + 1! ! -!AutoCompleterMorph methodsFor: 'testing' stamp: 'AY 3/15/2019 11:55:29'! - canSelectEntryAt: anIndex - - ^completer canSelectEntryAt: anIndex! ! -!AutoCompleter methodsFor: 'entries' stamp: 'AY 3/15/2019 11:47:28'! - entryAt: anIndex - - ^self entries at: anIndex! ! -!AutoCompleter methodsFor: 'testing' stamp: 'AY 3/15/2019 11:47:48'! - canSelectEntryAt: anIndex - - ^self canSelect: (self entryAt: anIndex)! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'AY 3/15/2019 14:10:45' prior: 50436498! - goDown - - self selected: (self nextSelectableEntryIndexFrom: self selected). - (self selected between: self firstVisible and: self lastVisible) - ifFalse: [self lastVisible: self selected]. - - self redrawNeeded.! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'AY 3/15/2019 14:03:40' prior: 50436510! - goHome - - self selected: self firstSelectableEntryIndex. - self firstVisible: 1. - self redrawNeeded.! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'AY 3/15/2019 14:03:32' prior: 50436528! -goToEnd - - self selected: self lastSelectableEntryIndex. - self lastVisible: self selected. - self redrawNeeded.! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'AY 3/15/2019 14:00:18' prior: 50436535! - goUp - - (self selected = 0 and: [self firstVisible = 1]) ifTrue: [^ self]. - - self selected: (self previousSelectableEntryIndexFrom: self selected). - (self selected between: self firstVisible and: self lastVisible) - ifFalse: [self firstVisible: self selected]. - - self redrawNeeded.! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'AY 3/15/2019 14:25:49' prior: 50446128! - resetMenu - - | width newExtent | - self hideSelectorDocumentation. - - self calculateItemsPerPage. - - self firstVisible: 1. - self selected: self firstSelectableEntryIndex. - - width _ self calculateWidth. - newExtent _ width + 4 @ (itemsPerPage * self itemHeight + 2). - - self morphPosition: originalPosition extent: newExtent. - "redraw is needed even if position and extent haven't changed" - self redrawNeeded ! ! -!AutoCompleterMorph methodsFor: 'paging' stamp: 'AY 3/15/2019 14:18:47' prior: 50436656! - gotoPage: anInteger - - | item | - - item := ((anInteger - 1) * itemsPerPage) + 1. - item >= completer entryCount ifTrue: [^false]. - - item < 1 ifTrue: [item := 1]. - firstVisible _ item. - self selected: (self nextSelectableEntryIndexFromAndIncluding: item). - - ^ true! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3664-Autocompleter-skipTitles-AngelYan-2019Mar15-14h07m-AY.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3662] on 15 March 2019 at 5:14:44 pm'! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'AY 3/15/2019 17:13:20' prior: 50436516! - goPageDown - - | oldEntry newEntry nextEntry | - - oldEntry _ self selected. - newEntry _ oldEntry. - [nextEntry _ self nextSelectableEntryIndexFrom: newEntry. - nextEntry > oldEntry and: [nextEntry - oldEntry <= self itemsPerPage]] - whileTrue: [newEntry _ nextEntry]. - - self selected: newEntry. - self firstVisible: newEntry. - - self redrawNeeded.! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'AY 3/15/2019 17:09:51' prior: 50436522! - goPageUp - - | oldEntry newEntry nextEntry | - - oldEntry _ self selected. - newEntry _ oldEntry. - [nextEntry _ self previousSelectableEntryIndexFrom: newEntry. - oldEntry > nextEntry and: [oldEntry - nextEntry <= self itemsPerPage]] - whileTrue: [newEntry _ nextEntry]. - - self selected: newEntry. - self firstVisible: newEntry. - - self redrawNeeded.! ! - -AutoCompleterMorph removeSelector: #currentPage! - -AutoCompleterMorph removeSelector: #currentPage! - -AutoCompleterMorph removeSelector: #gotoPage:! - -AutoCompleterMorph removeSelector: #gotoPage:! - -AutoCompleterMorph removeSelector: #pageCount! - -AutoCompleterMorph removeSelector: #pageCount! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3665-AutoCompleterPageUpDown-AngelYan-2019Mar15-17h08m-AY.1.cs.st----! - -----SNAPSHOT----(15 March 2019 17:35:56) Cuis5.0-3665-32.image priorSource: 3233875! - -----QUIT----(15 March 2019 17:43:13) Cuis5.0-3665-32.image priorSource: 3680436! - -----STARTUP---- (23 April 2019 09:05:04) as /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/Cuis5.0-3665-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3665] on 15 March 2019 at 10:06:54 pm'! -!AutoCompleterMorph methodsFor: 'accessing' stamp: 'AY 3/15/2019 21:55:46' prior: 50434293! - selected: aNumber - - "Set the value of selected" - - ((aNumber between: 1 and: self entryCount) and: [ aNumber ~= selected ]) - ifTrue: [ - selected _ aNumber. - self isShowingSelectorDocumentation ifTrue: [ self showSelectorDocumentation ]]! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'AY 3/15/2019 21:54:52' prior: 50446588! - resetMenu - - | width newExtent | - self hideSelectorDocumentation. - - self calculateItemsPerPage. - - self firstVisible: 1. - self selected: self firstSelectableEntryIndex. - - width _ self calculateWidth. - newExtent _ width + 4 @ (self itemsPerPage * self itemHeight + 2). - - self morphPosition: originalPosition extent: newExtent. - "redraw is needed even if position and extent haven't changed" - self redrawNeeded ! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'AY 3/15/2019 21:56:00' prior: 50436484! - calculateItemsPerPage - - | itemsThatCanFit | - - itemsThatCanFit _ (DisplayScreen actualScreenSize y - originalPosition y - 2) // self itemHeight. - itemsPerPage _ (itemsThatCanFit min: self maxItemsPerPage) min: self entryCount. - -! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'AY 3/15/2019 21:56:10' prior: 50436587! - calculateWidth - - | width font | - - width _ 120. - font _ self class listFont. - - 1 - to: self entryCount - do: [ :index | width _ width max: (font widthOfString: (completer entries at: index) asString)]. - - self entryCount > self itemsPerPage ifTrue: [ width _ width + ScrollBar scrollbarThickness ]. - - ^ width ! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'AY 3/15/2019 21:55:40' prior: 50433594! - drawScrollBarMovementBarOn: aCanvas thickness: scrollbarThickness - - | height top bottom | - - height _ extent y - (2 * scrollbarThickness). - top _ (1.0 * self firstVisible-1 / self entryCount * height) ceiling + 1 + scrollbarThickness-1. - bottom _ (1.0 * self lastVisible / self entryCount * height) floor + 1 + scrollbarThickness -1. - aCanvas - fillRectangle: (extent x - scrollbarThickness+2@top corner: extent x-2 @ bottom) - color: `Color veryLightGray` ! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'AY 3/15/2019 21:54:24' prior: 50436611! - drawScrollBarOn: aCanvas - - | scrollbarThickness width | - - width _ extent x-2. - self entryCount > self itemsPerPage ifTrue: [ - scrollbarThickness _ ScrollBar scrollbarThickness. - width _ width - scrollbarThickness. - - self drawScrollBarRectangleOn: aCanvas thickness: scrollbarThickness. - self drawUpArrowOn: aCanvas thickness: scrollbarThickness. - self drawDownArrowOn: aCanvas thickness: scrollbarThickness. - self drawScrollBarMovementBarOn: aCanvas thickness: scrollbarThickness ]. - - ^width -! ! -!AutoCompleterMorph methodsFor: 'private' stamp: 'AY 3/15/2019 22:05:12' prior: 50436676! - firstVisible - - ^firstVisible min: self entryCount! ! -!AutoCompleterMorph methodsFor: 'private' stamp: 'AY 3/15/2019 22:02:14' prior: 50436681! - lastVisible - - ^self firstVisible + self itemsPerPage - 1 min: self entryCount! ! -!AutoCompleterMorph methodsFor: 'selector documentation' stamp: 'AY 3/15/2019 21:54:35' prior: 50436687! - selectorDefaultDocumentationLocation - - | relativeSelected | - - relativeSelected := (self selected - self firstVisible) min: self itemsPerPage - 1 max: 0. - - ^location externalizePosition: extent x@(relativeSelected * self itemHeight + 1). - - ! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3666-AutoCompleterInstVarEncapsulation-AngelYan-2019Mar15-21h54m-AY.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3665] on 17 March 2019 at 9:14:29 am'! -!PasteUpMorph methodsFor: 'accessing' stamp: 'GC 3/17/2019 08:16:08'! - handlesKeyboard - - ^ true ! ! -!BrowserWindow class methodsFor: 'GUI building' stamp: 'GC 3/17/2019 08:13:13'! - findClass - - | allClassNames | - - allClassNames _ Smalltalk classNames asOrderedCollection. - - self findClassFrom: allClassNames ifFound: [:foundClass | self fullOnClass: foundClass ] - - ! ! -!BrowserWindow class methodsFor: 'GUI building' stamp: 'GC 3/17/2019 08:15:15'! - findClassFrom: potentialClassNames ifFound: aBlock - - | classNames exactMatch foundClass index pattern toMatch | - - pattern _ ClassNameRequestMorph request: 'Class name or fragment?'. - pattern isEmpty ifTrue: [^ self flash]. - toMatch _ (pattern copyWithout: $.) asLowercase withBlanksTrimmed. - classNames _ (pattern last = $. or: [pattern last = $ ]) - ifTrue: [potentialClassNames select: [:nm | nm asLowercase = toMatch]] - ifFalse: [potentialClassNames select: [:n | n includesSubstring: toMatch caseSensitive: false]]. - classNames isEmpty ifTrue: [^ self flash]. - exactMatch _ classNames detect: [ :each | each asLowercase = toMatch] ifNone: nil. - - index _ classNames size = 1 - ifTrue: [ 1 ] - ifFalse: [ exactMatch - ifNil: [(PopUpMenu labelArray: classNames lines: #()) startUpMenu] - ifNotNil: [classNames addFirst: exactMatch. - (PopUpMenu labelArray: classNames lines: #(1)) startUpMenu]]. - - index = 0 ifTrue: [^ self flash]. - foundClass _ Smalltalk at: (classNames at: index) asSymbol. - - aBlock value: foundClass.! ! -!BrowserWindow class methodsFor: 'GUI building' stamp: 'GC 3/17/2019 08:15:28'! - fullOnClass: aClass - - self fullOnClass: aClass selector: nil! ! -!Theme methodsFor: 'keyboard shortcuts' stamp: 'HAW 3/17/2019 08:37:46'! - findClassIn: aWindow - - | isBrowserWindow | - - isBrowserWindow _ (aWindow class = BrowserWindow) or: [ aWindow class = HierarchyBrowserWindow ]. - isBrowserWindow - ifTrue: [ aWindow findClass ] - ifFalse: [ BrowserWindow findClass ]! ! -!TextEditor methodsFor: 'menu' stamp: 'HAW 3/17/2019 08:53:17' prior: 50396376! - getMenu - - ^(MenuMorph new defaultTarget: self) - addTitle: self class name; - addStayUpIcons; - addItemsFromDictionaries: `{ - { - #label -> 'Help...'. - #selector -> #openHelp. - #icon -> #helpIcon - } asDictionary. - nil. - { - #label -> 'Find...(F)'. - #selector -> #find. - #icon -> #findIcon - } asDictionary. - { - #label -> 'Find Again (g)'. - #selector -> #findAgain. - #icon -> #systemIcon - } asDictionary. - { - #label -> 'Use Selection for Find (j)'. - #selector -> #setSearchString. - #icon -> #saveAsIcon - } asDictionary. - nil. - { - #label -> 'Undo - multiple (z)'. - #selector -> #undo. - #icon -> #undoIcon - } asDictionary. - { - #label -> 'Redo - multiple (Z)'. - #selector -> #redo. - #icon -> #redoIcon - } asDictionary. - { - #label -> 'Undo / Redo history'. - #selector -> #offerUndoHistory. - #icon -> #changesIcon - } asDictionary. - nil. - { - #label -> 'Copy (c)'. - #selector -> #copySelection. - #icon -> #copyIcon - } asDictionary. - { - #label -> 'Cut (x)'. - #selector -> #cut. - #icon -> #cutIcon - } asDictionary. - { - #label -> 'Paste (v)'. - #selector -> #paste. - #icon -> #pasteIcon - } asDictionary. - { - #label -> 'Paste without Format'. - #selector -> #pasteString. - #icon -> #pasteIcon - } asDictionary. - { - #label -> 'Paste...'. - #selector -> #pasteRecent. - #icon -> #worldIcon - } asDictionary. - nil. - { - #label -> 'Toggle WordWrap'. - #selector -> #wrapOnOff. - #icon -> #genericTextIcon - } asDictionary. - { - #label -> 'Set Font... (k)'. - #selector -> #offerFontMenu. - #icon -> #preferencesDesktopFontIcon - } asDictionary. - { - #label -> 'Clear Font'. - #selector -> #clearFont. - #icon -> #newIcon - } asDictionary. - { - #label -> 'Set Default Font...'. - #selector -> #offerDefaultFontMenu. - #icon -> #fontXGenericIcon - } asDictionary. - { - #label -> 'Set Alignment...'. - #selector -> #chooseAlignment. - #icon -> #formatJustifyLeftIcon - } asDictionary. - }`! ! -!TextEditor class methodsFor: 'keyboard shortcut tables' stamp: 'HAW 3/17/2019 08:58:33' prior: 50423649! - basicCmdShortcutsSpec - " - Editor initialize - " - - "arranged in QWERTY keyboard order" - ^#( - #( $( #enclose: 'Enclose within ( and ), or remove enclosing ( and )') - #( $[ #enclose: 'Enclose within [ and ], or remove enclosing [ and ]') - #( ${ #enclose: 'Enclose within { and }, or remove enclosing { and }') - #( $' #enclose: 'Enclose within single quotes, or remove enclosing single quotes') - #( $" #enclose: 'Enclose within double quotes, or remove enclosing double quotes') - #( $` #enclose: 'Enclose within backticks, or remove enclosing backticks') - #( $< #enclose: 'Enclose within < and >, or remove enclosing < and >') - - #( $a #selectAll: 'Select all') - #( $F #find: 'Find') - #( $g #findAgain: 'Find again') - #( $h #help: 'Open this help') - #( $j #setSearchString: 'Set selection as search string for find again') - - #( $z #undo: 'Undo (multiple levels)') - #( $x #cut: 'Cut selection and store it in the Clipboard') - #( $c #copySelection: 'Copy selection to the Clipboard') - #( $v #paste: 'Paste Clipboard contents') - - #( $R #indent: 'Indent (move selection one tab-stap right)') - #( $Y #makeUppercase: 'Force selection to uppercase') - #( $U #changeLineEndsToLf: 'Convert line endings to LF characters (Cuis convention) in selection') - - #( $H #cursorTopHome: 'Move cursor to start of text') - #( $L #outdent: 'Outdent (move selection one tab-stop left)') - - #( $Z #redo: 'Redo (multiple levels)') - #( $X #makeLowercase: 'Force selection to lowercase') - #( $C #compareToClipboard: 'Compare argument to clipboard') - - #( $ #selectWord: 'Select the current word as with double clicking') - )! ! -!SmalltalkEditor class methodsFor: 'keyboard shortcut tables' stamp: 'HAW 3/17/2019 09:00:30' prior: 50412522! - cmdShortcutsSpec - " - Editor initialize - " - "arranged in QWERTY keyboard order" - ^#( - #( $r #acceptAndDebugTest: 'Saves method and debugs it') - #( $t #acceptAndTest: 'Saves method, runs it as test and then all tests in class. Opens debugger if error') - #( $y #acceptAndTestAll: 'Saves method, runs it as test and then all tests in class category. Opens debugger if error') - #( $i #inspectIt: 'Inspect it (selection is a valid expression, or selection is over an inspect-ilst)') - #( $p #printIt: 'Print it (selection is a valid expression)') - - #( $s #save: 'Save (i.e. accept)') - #( $d #doIt: 'Do it (selection is a valid expression)') - - #( $b #browseIt: 'Browse it (selection is a class name or cursor is over a class-list or message-list)') - #( $n #sendersOfIt: 'Senders of it (selection is a message selector or cursor is over a class-list or message-list)') - #( $m #implementorsOfIt: 'Implementors of it (selection is a message selector or cursor is over a class-list or message-list)') - - #( $E #methodStringsContainingit:'Method strings containing it') - #( $T #displayIfTrue: 'Insert #ifTrue:') - #( $I #exploreIt: 'Inspect via Object Explorer') - - #( $Q #argPrev: 'Previous argument') - #( $A #argNext: 'Next argument') - #( $D #debugIt: 'Debug it') -" #( $F #displayIfFalse: 'Insert #ifFalse:')" - #( $G #fileItIn: 'File in selection') - - #( $V #pasteInitials: 'Paste author initials') - #( $N #referencesToIt: 'References to it (selection is a class name, or cursor is over a class-list or message-list)') - )! ! -!SmalltalkEditor class methodsFor: 'menu' stamp: 'HAW 3/17/2019 08:53:38' prior: 50410998! - smalltalkEditorMenu2Options - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Find...(F)'. - #selector -> #find. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'Find Again (g)'. - #selector -> #findAgain. - #icon -> #systemIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Use Selection for Find (j)'. - #selector -> #setSearchString. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Undo - multiple (z)'. - #selector -> #undo. - #icon -> #undoIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Redo - multiple (Z)'. - #selector -> #redo. - #icon -> #redoIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'Undo / Redo history'. - #selector -> #offerUndoHistory. - #icon -> #changesIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Copy (c)'. - #selector -> #copySelection. - #icon -> #copyIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Cut (x)'. - #selector -> #cut. - #icon -> #cutIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'Paste (v)'. - #selector -> #paste. - #icon -> #pasteIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 40. - #label -> 'Paste without Format'. - #selector -> #pasteString. - #icon -> #pasteIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 50. - #label -> 'Paste...'. - #selector -> #pasteRecent. - #icon -> #worldIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'Toggle WordWrap'. - #selector -> #wrapOnOff. - #icon -> #genericTextIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'Set Font... (k)'. - #selector -> #offerFontMenu. - #icon -> #preferencesDesktopFontIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'Clear Font'. - #selector -> #clearFont. - #icon -> #newIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 40. - #label -> 'Set Default Font...'. - #selector -> #offerDefaultFontMenu. - #icon -> #fontXGenericIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'More...'. - #selector -> #openMenu. - #icon -> #listAddIcon - } asDictionary. - }` -! ! -!BrowserWindow methodsFor: 'commands' stamp: 'GC 3/17/2019 08:13:00' prior: 16793460! - findClass - - | scopedClassNames | - - scopedClassNames _ model potentialClassNames asOrderedCollection. - - self class findClassFrom: scopedClassNames ifFound: [:foundClass | - model selectCategoryForClass: foundClass. - model selectClass: foundClass ]! ! -!HandMorph methodsFor: 'events-processing' stamp: 'GC 3/17/2019 08:15:50' prior: 16851808! - startKeyboardDispatch: aKeyboardEvent - - | focusedElement | - - focusedElement _ self keyboardFocus ifNil: [ self world ]. - focusedElement handleFocusEvent: aKeyboardEvent. - - self mouseOverHandler processMouseOver: self lastMouseEvent! ! -!Theme methodsFor: 'keyboard shortcuts' stamp: 'HAW 3/17/2019 08:59:01' prior: 50381789! - keyStroke: aKeyboardEvent morph: aMorph - - aKeyboardEvent commandAltKeyPressed | aKeyboardEvent controlKeyPressed - ifFalse: [ ^ false ]. - - aKeyboardEvent keyValue = $w numericValue ifTrue: [ - aMorph owningWindow ifNotNil: [ :w | - (w morphContainsPoint: (w internalizeFromWorld: aKeyboardEvent eventPosition)) ifTrue: [ - w delete. - ^ true ]]]. - - aKeyboardEvent keyValue = $f numericValue ifTrue: [ - self findClassIn: aMorph owningWindow. - ^ true]. - - ^ false! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Editor initialize. -! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3667-GlobalFindClass-GastonCaruso-2019Mar17-08h12m-GC.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3667] on 18 March 2019 at 9:47:50 am'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 3/18/2019 09:47:05' prior: 50431510! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('AY' 'Angel Yan') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('bgs' 'Boris G. Shingarov') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('FGJ' 'Fernando Gasperi Jabalera') - #('FJG' 'Facundo Javier Gelatti') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('KLG' 'Gerald Klix') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MM' 'Mariano Montone') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('pmon' 'Paolo Montrasi') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('SLD' 'Steve Davies') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3668-AddBorisAndMarianoAsKnownAuthors-JuanVuletich-2019Mar18-09h47m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3668] on 18 March 2019 at 1:14:24 pm'! -!WriteStream methodsFor: 'character writing' stamp: 'jmv 3/18/2019 12:14:37'! - cr - "Append a cr character to the receiver. - Use this method when you specifically need a cr character. - In many cases, it is advisable to call #newLine" - - self nextPut: Character cr! ! -!Transcript class methodsFor: 'old Transcript compatibility' stamp: 'jmv 3/18/2019 12:12:55'! - cr - "Old Squeak Transcript protocol. Still used for some doIt examples. - In the older TranscriptStream, it added a CR character. - Now, finish the current incomplete entry." - - self finishEntry! ! -!FileIOAccessor methodsFor: 'utilities' stamp: 'jmv 3/18/2019 12:52:32' prior: 16842041! - fileSize: fileEntry - - | pathName f size | - pathName _ fileEntry pathName. - "At least on Linux 64 Cog, opening a directory as a stream and asking #size answers some absurd number: 9223372036854775807" - (self basicDirectoryExists: pathName) ifTrue: [^ nil ]. - f _ self concreteStreamClass new open: pathName forWrite: false. - f ifNil: [^ nil]. - size _ f size. - f close. - ^ size! ! -!FileIOAccessor methodsFor: 'file stream creation' stamp: 'jmv 3/18/2019 13:00:59' prior: 16842134! - privateReadOnlyFile: fileEntry - "Open the existing file with the given name in this directory for read-only access." - - | pathName | - pathName _ fileEntry pathName. - (self basicDirectoryExists: pathName) ifTrue: [ - "If it is a directory, the it is not a file, and the requested file does not exist." - ^ ((FileDoesNotExistException fileName: pathName) readOnly: true) signal ]. - ^(self concreteStreamClass new open: pathName forWrite: false) - ifNil: [ - "File does not exist..." - ((FileDoesNotExistException fileName: pathName) readOnly: true) signal ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3669-FileAccessorFixes-JuanVuletich-2019Mar18-13h14m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3665] on 17 March 2019 at 7:32:51 am'! -!TestCase methodsFor: 'assertions' stamp: 'HAW 3/17/2019 07:08:22'! - shouldFail: aBlock - - self should: aBlock raise: Exception ! ! - -TestCase removeSelector: #shouldFix:! - -TestCase removeSelector: #shouldFix:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3670-ShouldFail-HernanWilkinson-2019Mar17-06h57m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3665] on 17 March 2019 at 6:57:41 am'! - -ChangeSelector subclass: #ChangeSelectorKeepingParameters - instanceVariableNames: 'newSelectorKeywords currentImplementorMethodNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ChangeSelectorKeepingParameters category: #'Tools-Refactoring'! -ChangeSelector subclass: #ChangeSelectorKeepingParameters - instanceVariableNames: 'newSelectorKeywords currentImplementorMethodNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelectorKeepingParameters subclass: #ChangeKeywordsSelectorOrder - instanceVariableNames: 'changedOrder' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ChangeKeywordsSelectorOrder category: #'Tools-Refactoring'! -ChangeSelectorKeepingParameters subclass: #ChangeKeywordsSelectorOrder - instanceVariableNames: 'changedOrder' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelectorKeepingParameters subclass: #RenameSelector - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameSelector category: #'Tools-Refactoring'! -ChangeSelectorKeepingParameters subclass: #RenameSelector - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelectorApplier subclass: #ChangeSelectorKeepingParametersApplier - instanceVariableNames: 'newSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ChangeSelectorKeepingParametersApplier category: #'Tools-Refactoring'! -ChangeSelectorApplier subclass: #ChangeSelectorKeepingParametersApplier - instanceVariableNames: 'newSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelectorKeepingParametersApplier subclass: #ChangeKeywordsSelectorOrderApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ChangeKeywordsSelectorOrderApplier category: #'Tools-Refactoring'! -ChangeSelectorKeepingParametersApplier subclass: #ChangeKeywordsSelectorOrderApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelectorKeepingParametersApplier subclass: #RenameSelectorApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameSelectorApplier category: #'Tools-Refactoring'! -ChangeSelectorKeepingParametersApplier subclass: #RenameSelectorApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'HAW 3/17/2019 05:43:39'! - withIndexDo: elementAndIndexBlock separatedBy: separatorBlock - "Evaluate the elementAndIndexBlock for all elements in the receiver, - and evaluate the separatorBlock between." - - 1 to: self size do: [:index | - index = 1 ifFalse: [separatorBlock value]. - elementAndIndexBlock value: (self at: index) value: index]! ! -!CodeWindow methodsFor: 'as yet unclassified' stamp: 'HAW 3/16/2019 17:58:08'! - changeKeywordOrder - - model selectedMessageName ifNotNil: [ :oldSelector | - ChangeKeywordsSelectorOrderApplier createAndValueHandlingExceptions: [ - ChangeKeywordsSelectorOrderApplier on: model for: oldSelector in: model selectedClassOrMetaClass ]].! ! -!TestCase methodsFor: 'assertions' stamp: 'HAW 3/17/2019 06:29:53'! - shouldntFail: aBlock - - self shouldnt: aBlock raise: Error! ! -!ChangeSelectorKeepingParameters methodsFor: 'create new implementors - private' stamp: 'HAW 3/17/2019 06:24:07'! - addImplementorSelectorRanges: aKeywordRange at: index to: rangesToNewKeywords - - self subclassResponsibility ! ! -!ChangeSelectorKeepingParameters methodsFor: 'create new implementors - private' stamp: 'HAW 3/17/2019 06:24:07'! - implementorNewSourceCodeOf: anImplementor - - | newSource rangesToNewKeywords | - - rangesToNewKeywords := OrderedCollection new. - currentImplementorMethodNode := anImplementor methodNode. - - currentImplementorMethodNode selectorKeywordsPositions withIndexDo: [ :aKeywordRange :index | - self addImplementorSelectorRanges: aKeywordRange at: index to: rangesToNewKeywords ]. - - newSource := anImplementor sourceCode copyReplacing: rangesToNewKeywords. - ^newSource! ! -!ChangeSelectorKeepingParameters methodsFor: 'rename senders - private' stamp: 'HAW 3/17/2019 06:02:54'! - addMessageSendSelectorKeywordRangesOf: aMethodNode to: rangesToKeywords - - | oldSelectorKeywordsRanges | - - oldSelectorKeywordsRanges := aMethodNode messageSendSelectorKeywordPositionsOf: oldSelector ifAbsent: [ #() ]. - oldSelectorKeywordsRanges do: [ :aMessageSendSelectorRanges | - aMessageSendSelectorRanges withIndexDo: [ :aRange :index | rangesToKeywords add: aRange -> (newSelectorKeywords at: index) ]]. - ! ! -!ChangeSelectorKeepingParameters methodsFor: 'initialization' stamp: 'HAW 3/17/2019 06:03:03'! - initializeFrom: anOldSelector to: aNewSelector implementors: aCollectionOfImplementors senders: aCollectionOfSenders - - super initializeFrom: anOldSelector to: aNewSelector implementors: aCollectionOfImplementors senders: aCollectionOfSenders. - - newSelectorKeywords := newSelector keywords. - ! ! -!ChangeSelectorKeepingParameters class methodsFor: 'instance creation' stamp: 'HAW 3/17/2019 05:58:22'! - from: anOldSelector to: aNewSelector implementors: aCollectionOfImplementors senders: aCollectionOfSenders - - self assertIsValidToRenameFrom: anOldSelector to: aNewSelector. - self assertIsNotEmpty: aCollectionOfImplementors signalMessageText: self implementorsCanNotBeEmptyErrorMessage. - self assertAllImplementors: aCollectionOfImplementors haveSame: anOldSelector. - self assertNoImplementorClassIn: aCollectionOfImplementors implements: aNewSelector. - self assertAllSenders: aCollectionOfSenders send: anOldSelector. - - self warnIfImplementionsOf: aNewSelector overridesImplementationInSuperclassesOf: aCollectionOfImplementors. - - ^self new initializeFrom: anOldSelector to: aNewSelector implementors: aCollectionOfImplementors senders: aCollectionOfSenders - ! ! -!ChangeSelectorKeepingParameters class methodsFor: 'instance creation' stamp: 'HAW 3/17/2019 05:58:34'! - from: anOldSelector to: aNewSelector in: aClassToRefactor - - | implementors senders | - - implementors := OrderedCollection new. - senders := OrderedCollection new. - - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders forClassAndMetaOf: aClassToRefactor theNonMetaClass. - - ^self from: anOldSelector to: aNewSelector implementors: implementors senders: senders ! ! -!ChangeSelectorKeepingParameters class methodsFor: 'instance creation' stamp: 'HAW 3/17/2019 05:58:38'! - from: anOldSelector to: aNewSelector inCategoriesAndHierarchyOf: aClass organizedBy: anOrganization - - | implementors senders | - - implementors := IdentitySet new. - senders := IdentitySet new. - - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategoriesAndHierarchyOf: aClass organizedBy: anOrganization. - - ^self from: anOldSelector to: aNewSelector implementors: implementors senders: senders -! ! -!ChangeSelectorKeepingParameters class methodsFor: 'instance creation' stamp: 'HAW 3/17/2019 05:58:43'! - from: anOldSelector to: aNewSelector inCategoryOf: aClass organizedBy: anOrganization - - | implementors senders | - - implementors := OrderedCollection new. - senders := OrderedCollection new. - - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategory: aClass category organizedBy: anOrganization. - - ^self from: anOldSelector to: aNewSelector implementors: implementors senders: senders -! ! -!ChangeSelectorKeepingParameters class methodsFor: 'instance creation' stamp: 'HAW 3/17/2019 05:58:47'! - from: anOldSelector to: aNewSelector inHierarchyOf: aClass - - | implementors senders | - - implementors := OrderedCollection new. - senders := OrderedCollection new. - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inHierarchyOf: aClass. - - ^self from: anOldSelector to: aNewSelector implementors: implementors senders: senders - - ! ! -!ChangeSelectorKeepingParameters class methodsFor: 'instance creation' stamp: 'HAW 3/17/2019 05:58:52'! - from: anOldSelector to: aNewSelector inSystem: aSystem - - | implementors senders | - - implementors := OrderedCollection new. - senders := OrderedCollection new. - - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inSystem: aSystem. - - ^self from: anOldSelector to: aNewSelector implementors: implementors senders: senders - ! ! -!ChangeSelectorKeepingParameters class methodsFor: 'pre-conditions' stamp: 'HAW 3/17/2019 05:59:02'! - assert: aNewSelector hasTheSameNumberOfArgumentsAs: anOldSelector - - aNewSelector numArgs ~= anOldSelector numArgs ifTrue: [ self signalNewSelector: aNewSelector doesNotHaveSameNumberOfArgumentsAs: anOldSelector ]! ! -!ChangeSelectorKeepingParameters class methodsFor: 'pre-conditions' stamp: 'HAW 3/17/2019 05:59:07'! - assert: aNewSelector isNotEqualTo: anOldSelector - - aNewSelector = anOldSelector ifTrue: [ self signalNewSelectorEqualToOldSelector]! ! -!ChangeSelectorKeepingParameters class methodsFor: 'pre-conditions' stamp: 'HAW 3/17/2019 05:59:44'! - assert: aNewSelector isOfSameTypeAs: anOldSelector - - (self isRenamingBetweenBinary: anOldSelector andKeywordOfOneParameter: aNewSelector) ifTrue: [ ^self ]. - (self isRenamingBetweenBinary: aNewSelector andKeywordOfOneParameter: anOldSelector) ifTrue: [ ^self ]. - - aNewSelector precedence ~= anOldSelector precedence ifTrue: [ - self signalNewSelector: aNewSelector isNotOfSameTypeAs: anOldSelector ]! ! -!ChangeSelectorKeepingParameters class methodsFor: 'pre-conditions' stamp: 'HAW 3/17/2019 05:59:14'! - assertIsNotEmpty: aCollection signalMessageText: errorMessageText - - aCollection isEmpty ifTrue: [ self refactoringError: errorMessageText ].! ! -!ChangeSelectorKeepingParameters class methodsFor: 'pre-conditions' stamp: 'HAW 3/17/2019 05:59:19'! - assertIsValidToRenameFrom: anOldSelector to: aNewSelector - - self assertIsNotEmpty: anOldSelector signalMessageText: self oldSelectorCanNotBeEmptyErrorMessage. - self assertIsNotEmpty: aNewSelector signalMessageText: self newSelectorCanNotBeEmptyErrorMessage. - self assert: aNewSelector isNotEqualTo: anOldSelector. - self assert: aNewSelector isOfSameTypeAs: anOldSelector. - self assert: aNewSelector hasTheSameNumberOfArgumentsAs: anOldSelector. - ! ! -!ChangeSelectorKeepingParameters class methodsFor: 'pre-conditions' stamp: 'HAW 3/17/2019 05:59:23'! - assertNoImplementorClassIn: implementorsCollection implements: aNewSelector - - | classesImplementingNewSelector | - - classesImplementingNewSelector := implementorsCollection - select: [ :anImplementor | anImplementor methodClass includesSelector: aNewSelector ] - thenCollect: [ :anImplementor | anImplementor methodClass ]. - - classesImplementingNewSelector notEmpty ifTrue: [ self signalNewSelector: aNewSelector implementedInAll: classesImplementingNewSelector ]! ! -!ChangeSelectorKeepingParameters class methodsFor: 'pre-conditions' stamp: 'HAW 3/17/2019 05:59:50'! - isRenamingBetweenBinary: aPotentiallyBinarySelector andKeywordOfOneParameter: aPotentiallyKeywordSelector - - ^aPotentiallyBinarySelector isInfix - and: [ aPotentiallyKeywordSelector isKeyword - and: [ aPotentiallyKeywordSelector numArgs = 1 ]] -! ! -!ChangeSelectorKeepingParameters class methodsFor: 'pre-conditions' stamp: 'HAW 3/17/2019 05:59:54'! - warnIfImplementionsOf: aNewSelector overridesImplementationInSuperclassesOf: implementorsCollection - - implementorsCollection do: [:anImplementor | - anImplementor methodClass - withSuperclassThatIncludesSelector: aNewSelector - do: [ :aSuperclass | self warnImplementionOf: aNewSelector in: anImplementor methodClass willOverrideImplementationIn: aSuperclass ] - ifNone: []]! ! -!ChangeSelectorKeepingParameters class methodsFor: 'exceptions' stamp: 'HAW 3/17/2019 06:00:00'! - errorMessageForNewSelector: aNewSelector doesNotHaveSameNumberOfArgumentsAs: anOldSelector - - ^'New selector #', aNewSelector, ' does not have the same number of arguments as #', anOldSelector ! ! -!ChangeSelectorKeepingParameters class methodsFor: 'exceptions' stamp: 'HAW 3/17/2019 06:00:04'! - errorMessageForNewSelector: aNewSelector implementedInAll: classesImplementingNewSelector - - ^'Can not rename because #', aNewSelector, ' is implemented in: ', classesImplementingNewSelector asCommaStringAnd ! ! -!ChangeSelectorKeepingParameters class methodsFor: 'exceptions' stamp: 'HAW 3/17/2019 06:00:07'! - errorMessageForNewSelector: aNewSelector isNotOfSameTypeAs: anOldSelector - - ^'New selector #', aNewSelector, ' is not of same type as #', anOldSelector ! ! -!ChangeSelectorKeepingParameters class methodsFor: 'exceptions' stamp: 'HAW 3/17/2019 06:00:11'! - implementorsCanNotBeEmptyErrorMessage - - ^'There are no methods to rename'! ! -!ChangeSelectorKeepingParameters class methodsFor: 'exceptions' stamp: 'HAW 3/17/2019 06:00:16'! - newSelectorCanNotBeEmptyErrorMessage - - ^'New selector can not be empty'! ! -!ChangeSelectorKeepingParameters class methodsFor: 'exceptions' stamp: 'HAW 3/17/2019 06:00:19'! - newSelectorEqualToOldSelectorErrorMessage - - ^'There is nothing to rename when new selector is equals to old selector'! ! -!ChangeSelectorKeepingParameters class methodsFor: 'exceptions' stamp: 'HAW 3/17/2019 06:00:23'! - oldSelectorCanNotBeEmptyErrorMessage - - ^'Old selector can not be empty'! ! -!ChangeSelectorKeepingParameters class methodsFor: 'exceptions' stamp: 'HAW 3/17/2019 06:00:27'! - signalNewSelector: aNewSelector doesNotHaveSameNumberOfArgumentsAs: anOldSelector - - self refactoringError: (self errorMessageForNewSelector: aNewSelector doesNotHaveSameNumberOfArgumentsAs: anOldSelector).! ! -!ChangeSelectorKeepingParameters class methodsFor: 'exceptions' stamp: 'HAW 3/17/2019 06:00:30'! - signalNewSelector: aNewSelector implementedInAll: classesImplementingNewSelector - - self refactoringError: (self errorMessageForNewSelector: aNewSelector implementedInAll: classesImplementingNewSelector).! ! -!ChangeSelectorKeepingParameters class methodsFor: 'exceptions' stamp: 'HAW 3/17/2019 06:00:33'! - signalNewSelector: aNewSelector isNotOfSameTypeAs: anOldSelector - - self refactoringError: (self errorMessageForNewSelector: aNewSelector isNotOfSameTypeAs: anOldSelector).! ! -!ChangeSelectorKeepingParameters class methodsFor: 'exceptions' stamp: 'HAW 3/17/2019 06:00:37'! - signalNewSelectorEqualToOldSelector - - self refactoringError: self newSelectorEqualToOldSelectorErrorMessage.! ! -!ChangeSelectorKeepingParameters class methodsFor: 'warnings' stamp: 'HAW 3/17/2019 06:00:42'! - warnImplementionOf: aNewSelector in: aClass willOverrideImplementationIn: aSuperclass - - self refactoringWarning: (self warningMessageForImplementationOf: aNewSelector in: aClass willOverrideImplementationIn: aSuperclass).! ! -!ChangeSelectorKeepingParameters class methodsFor: 'warnings' stamp: 'HAW 3/17/2019 06:00:46'! -warningMessageForImplementationOf: aNewSelector in: aClass willOverrideImplementationIn: aSuperclass - - ^'Implemention of #', aNewSelector, ' in ', aClass name, ' will override implementation in ', aSuperclass name! ! -!ChangeKeywordsSelectorOrder methodsFor: 'initialization' stamp: 'HAW 3/17/2019 06:14:09'! - initializeChangedOrder: aChangeOrder - - changedOrder := aChangeOrder ! ! -!ChangeKeywordsSelectorOrder methodsFor: 'create new implementors - private' stamp: 'HAW 3/17/2019 06:24:07'! - addImplementorSelectorRanges: aKeywordRange at: index to: rangesToNewKeywords - - rangesToNewKeywords add: aKeywordRange -> (newSelectorKeywords at: index). - rangesToNewKeywords add: - (currentImplementorMethodNode parameterDefinitionPositionAt: index) -> - (currentImplementorMethodNode argumentNames at: (changedOrder at: index))! ! -!ChangeKeywordsSelectorOrder class methodsFor: 'instance creation' stamp: 'HAW 3/17/2019 06:11:48'! - from: anOldSelector to: aNewSelector implementors: aCollectionOfImplementors senders: aCollectionOfSenders - - | changedOrder | - - self assertIsKeywordWithMoreThanOneParameter: anOldSelector. - changedOrder := self changedOrderFrom: anOldSelector to: aNewSelector. - - ^ (super from: anOldSelector to: aNewSelector implementors: aCollectionOfImplementors senders: aCollectionOfSenders) - initializeChangedOrder: changedOrder -! ! -!ChangeKeywordsSelectorOrder class methodsFor: 'pre-conditions' stamp: 'HAW 3/17/2019 06:18:21'! - assertIsKeywordWithMoreThanOneParameter: anOldSelector - - (anOldSelector isKeyword and: [ anOldSelector numArgs > 1 ]) ifFalse: [ self signalSelectorToChangeIsNotKeywordWithMoreThanOneParameter ]! ! -!ChangeKeywordsSelectorOrder class methodsFor: 'exceptions' stamp: 'HAW 3/16/2019 17:45:39'! - newSelectorDoesNotIncludeOldSelectorKeywordsErrorMessage - - ^'New selector keywords do not include old selector keywords'! ! -!ChangeKeywordsSelectorOrder class methodsFor: 'exceptions' stamp: 'HAW 3/17/2019 06:18:58'! - selectorToChangeIsNotKeywordWithMoreThanOneParameterErrorMessage - - ^'Can only change a selector order for keyword messages with more that one parameter'! ! -!ChangeKeywordsSelectorOrder class methodsFor: 'exceptions' stamp: 'HAW 3/16/2019 17:45:39'! - signalNewSelectorDoesNotIncludeOldSelectorKeywords - - self refactoringError: self newSelectorDoesNotIncludeOldSelectorKeywordsErrorMessage! ! -!ChangeKeywordsSelectorOrder class methodsFor: 'exceptions' stamp: 'HAW 3/17/2019 06:18:58'! - signalSelectorToChangeIsNotKeywordWithMoreThanOneParameter - - self refactoringError: self selectorToChangeIsNotKeywordWithMoreThanOneParameterErrorMessage! ! -!ChangeKeywordsSelectorOrder class methodsFor: 'changed order' stamp: 'HAW 3/17/2019 06:13:43'! - changedOrderFrom: anOldSelector to: aNewSelector - - | changedOrder newSelectorKeywords | - - changedOrder := Dictionary new. - newSelectorKeywords := aNewSelector keywords. - anOldSelector keywords withIndexDo: [ :keyword :index | - changedOrder - at: (newSelectorKeywords indexOf: keyword ifAbsent: [ self signalNewSelectorDoesNotIncludeOldSelectorKeywords ]) - put: index ]. - - ^changedOrder ! ! -!RenameSelector methodsFor: 'create new implementors - private' stamp: 'HAW 3/17/2019 06:24:07'! - addImplementorSelectorRanges: aKeywordRange at: index to: rangesToNewKeywords - - rangesToNewKeywords add: aKeywordRange -> (newSelectorKeywords at: index) ! ! -!ChangeSelectorKeepingParametersApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 3/17/2019 06:52:15'! - askNewSelector - - | enteredString | - - enteredString := self request: 'Enter new selector:' initialAnswer: oldSelector. - newSelector := enteredString withBlanksTrimmed asSymbol. - -! ! -!ChangeSelectorKeepingParametersApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 3/17/2019 06:52:23'! - assertCanRenameSelector - - self refactoringClass assertIsValidToRenameFrom: oldSelector to: newSelector. - ! ! -!ChangeSelectorKeepingParametersApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 3/17/2019 06:52:38'! - requestRefactoringParameters - - self - askNewSelector; - assertCanRenameSelector - ! ! -!ChangeSelectorKeepingParametersApplier methodsFor: 'refactoring - creation' stamp: 'HAW 3/17/2019 06:52:28'! - createRefactoring - - ^self refactoringClass from: oldSelector to: newSelector implementors: implementors senders: senders. - ! ! -!ChangeKeywordsSelectorOrderApplier methodsFor: 'refactoring - creation' stamp: 'HAW 3/16/2019 17:55:35'! - refactoringClass - - ^ChangeKeywordsSelectorOrder ! ! -!ChangeKeywordsSelectorOrderApplier class methodsFor: 'pre-conditions' stamp: 'HAW 3/17/2019 06:50:17'! - assertCanApplyRefactoringFor: aSelector in: aClass - - ChangeKeywordsSelectorOrder assertIsKeywordWithMoreThanOneParameter: aSelector ! ! -!RefactoringMenues class methodsFor: 'browser menues' stamp: 'HAW 3/17/2019 06:46:00' prior: 50446093! - messsageRefactoringMenuOptions - - ^ `{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'rename... (R)'. - #selector -> #renameSelector. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 15. - #label -> 'change keyword order...'. - #selector -> #changeKeywordOrder. - #icon -> #sendReceiveIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'add parameter...'. - #selector -> #addParameter. - #icon -> #listAddIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'remove parameter...'. - #selector -> #removeParameter. - #icon -> #listRemoveIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'push up'. - #selector -> #pushUpSelector. - #icon -> #goTopIcon - } asDictionary. - }`. - - ! ! - -RenameSelectorApplier removeSelector: #askNewSelector! - -RenameSelectorApplier removeSelector: #askNewSelector! - -RenameSelectorApplier removeSelector: #assertCanRenameSelector! - -RenameSelectorApplier removeSelector: #assertCanRenameSelector! - -RenameSelectorApplier removeSelector: #createRefactoring! - -RenameSelectorApplier removeSelector: #createRefactoring! - -RenameSelectorApplier removeSelector: #requestRefactoringParameters! - -RenameSelectorApplier removeSelector: #requestRefactoringParameters! - -ChangeKeywordsSelectorOrderApplier class removeSelector: #m1! - -RenameSelector class removeSelector: #assert:hasTheSameNumberOfArgumentsAs:! - -RenameSelector class removeSelector: #assert:hasTheSameNumberOfArgumentsAs:! - -RenameSelector class removeSelector: #assert:isNotEqualTo:! - -RenameSelector class removeSelector: #assert:isNotEqualTo:! - -RenameSelector class removeSelector: #assert:isOfSameTypeAs:! - -RenameSelector class removeSelector: #assert:isOfSameTypeAs:! - -RenameSelector class removeSelector: #assertIsNotEmpty:signalMessageText:! - -RenameSelector class removeSelector: #assertIsNotEmpty:signalMessageText:! - -RenameSelector class removeSelector: #assertIsValidToRenameFrom:to:! - -RenameSelector class removeSelector: #assertIsValidToRenameFrom:to:! - -RenameSelector class removeSelector: #assertNoImplementorClassIn:implements:! - -RenameSelector class removeSelector: #assertNoImplementorClassIn:implements:! - -RenameSelector class removeSelector: #errorMessageForNewSelector:doesNotHaveSameNumberOfArgumentsAs:! - -RenameSelector class removeSelector: #errorMessageForNewSelector:doesNotHaveSameNumberOfArgumentsAs:! - -RenameSelector class removeSelector: #errorMessageForNewSelector:implementedInAll:! - -RenameSelector class removeSelector: #errorMessageForNewSelector:implementedInAll:! - -RenameSelector class removeSelector: #errorMessageForNewSelector:isNotOfSameTypeAs:! - -RenameSelector class removeSelector: #errorMessageForNewSelector:isNotOfSameTypeAs:! - -RenameSelector class removeSelector: #from:to:implementors:senders:! - -RenameSelector class removeSelector: #from:to:implementors:senders:! - -RenameSelector class removeSelector: #from:to:in:! - -RenameSelector class removeSelector: #from:to:in:! - -RenameSelector class removeSelector: #from:to:inCategoriesAndHierarchyOf:organizedBy:! - -RenameSelector class removeSelector: #from:to:inCategoriesAndHierarchyOf:organizedBy:! - -RenameSelector class removeSelector: #from:to:inCategoryOf:organizedBy:! - -RenameSelector class removeSelector: #from:to:inCategoryOf:organizedBy:! - -RenameSelector class removeSelector: #from:to:inHierarchyOf:! - -RenameSelector class removeSelector: #from:to:inHierarchyOf:! - -RenameSelector class removeSelector: #from:to:inSystem:! - -RenameSelector class removeSelector: #from:to:inSystem:! - -RenameSelector class removeSelector: #implementorsCanNotBeEmptyErrorMessage! - -RenameSelector class removeSelector: #implementorsCanNotBeEmptyErrorMessage! - -RenameSelector class removeSelector: #isRenamigBetweenBinary:andKeywordOfOneParameter:! - -RenameSelector class removeSelector: #isRenamigBetweenBinary:andKeywordOfOneParameter:! - -RenameSelector class removeSelector: #isRenamingBetweenBinary:andKeywordOfOneParameter:! - -RenameSelector class removeSelector: #newSelectorCanNotBeEmptyErrorMessage! - -RenameSelector class removeSelector: #newSelectorCanNotBeEmptyErrorMessage! - -RenameSelector class removeSelector: #newSelectorEqualToOldSelectorErrorMessage! - -RenameSelector class removeSelector: #newSelectorEqualToOldSelectorErrorMessage! - -RenameSelector class removeSelector: #oldSelectorCanNotBeEmptyErrorMessage! - -RenameSelector class removeSelector: #oldSelectorCanNotBeEmptyErrorMessage! - -RenameSelector class removeSelector: #signalNewSelector:doesNotHaveSameNumberOfArgumentsAs:! - -RenameSelector class removeSelector: #signalNewSelector:doesNotHaveSameNumberOfArgumentsAs:! - -RenameSelector class removeSelector: #signalNewSelector:implementedInAll:! - -RenameSelector class removeSelector: #signalNewSelector:implementedInAll:! - -RenameSelector class removeSelector: #signalNewSelector:isNotOfSameTypeAs:! - -RenameSelector class removeSelector: #signalNewSelector:isNotOfSameTypeAs:! - -RenameSelector class removeSelector: #signalNewSelectorEqualToOldSelector! - -RenameSelector class removeSelector: #signalNewSelectorEqualToOldSelector! - -RenameSelector class removeSelector: #warnIfImplementionsOf:overridesImplementationInSuperclassesOf:! - -RenameSelector class removeSelector: #warnIfImplementionsOf:overridesImplementationInSuperclassesOf:! - -RenameSelector class removeSelector: #warnImplementionOf:in:willOverrideImplementationIn:! - -RenameSelector class removeSelector: #warnImplementionOf:in:willOverrideImplementationIn:! - -RenameSelector class removeSelector: #warningMessageForImplementationOf:in:willOverrideImplementationIn:! - -RenameSelector class removeSelector: #warningMessageForImplementationOf:in:willOverrideImplementationIn:! - -RenameSelector removeSelector: #addMessageSendSelectorKeywordRangesOf:to:! - -RenameSelector removeSelector: #addMessageSendSelectorKeywordRangesOf:to:! - -RenameSelector removeSelector: #addRanges:at:to:! - -RenameSelector removeSelector: #implementorNewSourceCodeOf:! - -RenameSelector removeSelector: #implementorNewSourceCodeOf:! - -RenameSelector removeSelector: #initializeFrom:to:implementors:senders:! - -RenameSelector removeSelector: #initializeFrom:to:implementors:senders:! - -ChangeKeywordsSelectorOrder class removeSelector: #assertIsNotUnary:! - -ChangeKeywordsSelectorOrder class removeSelector: #assertIsValidToRenameFrom:to:! - -ChangeKeywordsSelectorOrder class removeSelector: #canChangeOrderOfKeywordsInKeywordMessagesErrorDescription! - -ChangeKeywordsSelectorOrder class removeSelector: #canOnlyChangeSelectorOrderForKeywordMessagesWithMoreThanOneParameterErrorDescription! - -ChangeKeywordsSelectorOrder class removeSelector: #cannotChangeSelectorOrderForAUnaryMessage! - -ChangeKeywordsSelectorOrder class removeSelector: #cannotChangeSelectorOrderForAnUnaryMessage! - -ChangeKeywordsSelectorOrder class removeSelector: #newSelectorDoesNotIncludeOldSelectorKeywords! - -ChangeKeywordsSelectorOrder class removeSelector: #signalCanChangeOrderOfKeywordsInKeywordMessages! - -ChangeKeywordsSelectorOrder class removeSelector: #signalCannotChangeSelectorOrderForAUnaryMessage! - -ChangeKeywordsSelectorOrder class removeSelector: #signalCannotChangeSelectorOrderForAnUnaryMessage! - -ChangeKeywordsSelectorOrder removeSelector: #addRanges:at:to:! - -ChangeKeywordsSelectorOrder removeSelector: #apply! - -ChangeKeywordsSelectorOrder removeSelector: #implementorNewSourceCodeOf:! - -ChangeKeywordsSelectorOrder removeSelector: #initializeChangeOrder:! - -ChangeKeywordsSelectorOrder removeSelector: #initializeRenameRefactoring:! - -ChangeSelectorKeepingParameters removeSelector: #addRanges:at:to:! - -ChangeSelectorKeepingParameters subclass: #RenameSelector - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameSelector category: #'Tools-Refactoring'! -ChangeSelectorKeepingParameters subclass: #RenameSelector - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelectorKeepingParametersApplier subclass: #RenameSelectorApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameSelectorApplier category: #'Tools-Refactoring'! -ChangeSelectorKeepingParametersApplier subclass: #RenameSelectorApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3671-ChangeKeywordsSelectorOrder-HernanWilkinson-2019Mar16-16h37m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3610] on 17 March 2019 at 6:14:00 pm'! -!TextModel methodsFor: 'as yet unclassified' stamp: 'jpb 3/17/2019 18:09:39'! - saveOn: stream as: format - "Saves the model to the given stream" - stream binary. - stream nextPutAll: self actualContents asString.! ! -!SystemWindow methodsFor: 'user interface' stamp: 'jpb 3/17/2019 18:12:16'! - saveContents - "Prompts the user for a file name and saves the contents to the file" - | fileName | - self hasSaveAs ifFalse: [^self]. - - fileName _ FillInTheBlankMorph request: 'Filename'. - - fileName isEmptyOrNil - ifTrue: [ self notifyUserWith: 'Contents not saved'] - ifFalse: [ self saveContentsTo: fileName ].! ! -!SystemWindow methodsFor: 'user interface' stamp: 'jpb 3/17/2019 18:12:28'! - saveContentsTo: fileName - "Saves the contents to the given filename" - | stream | - self hasSaveAs ifFalse: [^self]. - - stream _ StandardFileStream new. - stream open: fileName forWrite: true. - - model saveOn: stream as: 'text/plain'. - - stream closed ifFalse: [stream close]. - self notifyUserWith: 'Contents saved'.! ! -!SystemWindow methodsFor: 'menu' stamp: 'jpb 3/16/2019 17:00:59'! - addTileResizerMenuTo: aMenu - "We can look at preferences here to decide what too do" - (Preferences tileResizerInWindowMenu) ifFalse: [ - aMenu add: 'resize full' action: #resizeFull icon: #resizeFullIcon; - add: 'resize top' action: #resizeTop icon: #resizeTopIcon; - add: 'resize left' action: #resizeLeft icon: #resizeLeftIcon; - add: 'resize bottom' action: #resizeBottom icon: #resizeBottomIcon; - add: 'resize right' action: #resizeRight icon: #resizeRightIcon; - add: 'resize top left' action: #resizeTopLeft icon: #resizeTopLeftIcon; - add: 'resize top right' action: #resizeTopRight icon: #resizeTopRightIcon; - add: 'resize bottom left' action: #resizeBottomLeft icon: #resizeBottomLeftIcon; - add: 'resize bottom right' action: #resizeBottomRight icon: #resizeBottomRightIcon] - ifTrue: [ |resizeMorph| - "Use embedded resize morph" - resizeMorph _ TileResizeMorph new - selectionColor: (self widgetsColor adjustSaturation: -0.2 brightness: 0.25) ; - action: [:resize | |resizeMsg| - resizeMsg _ ('resize', resize asString capitalized) asSymbol. - self perform: resizeMsg. - aMenu delete]; - yourself. - aMenu addMorphBack: resizeMorph]. - ^aMenu.! ! -!SystemWindow methodsFor: 'user interface' stamp: 'jpb 3/17/2019 17:49:20'! - hasSaveAs - "Returns true if the window has a model which can be saved to a file" - ^model respondsTo: #saveOn:as:! ! -!SystemWindow methodsFor: 'user interface' stamp: 'jpb 3/17/2019 17:30:24'! -notifyUserWith: message - "Notifies the user with a message and an 'ok' button" - | morph | - morph _ MenuMorph new. - morph addTitle: message. - morph add: 'Ok' action: nil. - morph openInWorld.! ! -!SystemWindow methodsFor: 'menu' stamp: 'jpb 3/16/2019 17:13:12'! - addWindowControlTo: aMenu - - aMenu - add: 'send to back' action: #sendToBack icon: #goBottomIcon; - add: 'make next-to-topmost' action: #makeSecondTopmost icon: #goUpIcon; - addLine; - add: (self isSticky ifTrue: [ 'make draggable' ] ifFalse: [ 'make undraggable' ]) - action: #toggleStickiness icon: (self isSticky ifFalse: [#pushPinIcon]); - addLine; - add: 'close' action: #delete icon: #closeIcon; - add: 'collapse' action: #collapse icon: #collapseIcon; - add: 'expand / contract' action: #expandBoxHit icon: #expandIcon; - addLine; - add: 'resize...' action: #resize. - - ^aMenu! ! -!SystemWindow methodsFor: 'menu' stamp: 'jpb 3/17/2019 17:42:09' prior: 50413257! - buildWindowMenu - - | aMenu | - - aMenu _ MenuMorph new defaultTarget: self. - - aMenu - add: 'change title...' action: #relabel icon: #saveAsIcon; - add: 'window color...' action: #setWindowColor icon: #graphicsIcon. - - self hasSaveAs - ifTrue: [ aMenu add: 'Save as ...' action: #saveContents icon: #saveAsIcon ]. - - aMenu - addLine. - - self addWindowControlTo: aMenu. - self addTileResizerMenuTo: aMenu. - - ^ aMenu! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3672-text-saveAs-JosefPhilipBernhart-2019Mar17-18h07m-jpb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3672] on 19 March 2019 at 12:25:43 am'! - -"Change Set: 3673-CuisCore-AuthorName-2019Mar19-00h10m -Date: 19 March 2019 -Author: Nahuel Garbezza - -Support navigation between PluggableListMorph using left and right arrows. Refactored the key events handler"! - -PluggableScrollPane subclass: #PluggableListMorph - instanceVariableNames: 'list getListSelector getIndexSelector setIndexSelector keystrokeActionSelector autoDeselect lastKeystrokeTime lastKeystrokes doubleClickSelector menuGetter mainView leftSibling rightSibling ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #PluggableListMorph category: #'Morphic-Views'! -PluggableScrollPane subclass: #PluggableListMorph - instanceVariableNames: 'list getListSelector getIndexSelector setIndexSelector keystrokeActionSelector autoDeselect lastKeystrokeTime lastKeystrokes doubleClickSelector menuGetter mainView leftSibling rightSibling' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! -!PluggableListMorph methodsFor: 'events' stamp: 'RNG 3/19/2019 00:18:17'! - gainFocusFrom: aHand - - aHand newKeyboardFocus: self. - self getCurrentSelectionIndex = 0 ifTrue: [ self selectionIndex: 1 ].! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'RNG 3/16/2019 14:24:13'! - navigateDown - "move down, wrapping to top if needed" - - | nextSelection | - nextSelection _ self getCurrentSelectionIndex + 1. - nextSelection > self maximumSelection ifTrue: [ nextSelection _ 1 ]. - - self changeSelectionTo: nextSelection! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'RNG 3/19/2019 00:16:46'! - navigateLeft - - leftSibling ifNotNil: [ leftSibling gainFocusFrom: self activeHand ]! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'RNG 3/16/2019 14:21:05'! - navigateOnePageDown - - | nextSelection | - nextSelection _ self getCurrentSelectionIndex + self numSelectionsInView min: self maximumSelection. - - self getCurrentSelectionIndex ~= nextSelection - ifTrue: [ self changeSelectionTo: nextSelection ]! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'RNG 3/16/2019 14:23:27'! - navigateOnePageUp - - self changeSelectionTo: (self minimumSelection max: self getCurrentSelectionIndex - self numSelectionsInView)! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'RNG 3/19/2019 00:16:35'! - navigateRight - - rightSibling ifNotNil: [ rightSibling gainFocusFrom: self activeHand ]! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'RNG 3/16/2019 14:23:47'! - navigateToBottom - - self changeSelectionTo: self maximumSelection! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'RNG 3/16/2019 14:23:57'! - navigateToTop - - self changeSelectionTo: 1! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'RNG 3/16/2019 14:24:07'! - navigateUp - "move up, wrapping to bottom if needed" - - | nextSelection | - nextSelection _ self getCurrentSelectionIndex - 1. - nextSelection < 1 ifTrue: [ nextSelection _ self maximumSelection ]. - - self changeSelectionTo: nextSelection! ! -!PluggableListMorph methodsFor: 'private' stamp: 'RNG 3/16/2019 14:22:49'! - changeSelectionTo: nextSelection - - self getCurrentSelectionIndex ~= nextSelection ifTrue: [ - | window | - window _ self owningWindow. - (window isNil or: [ window okToChangeDueTo: self ]) ifTrue: [ - "No change if model is locked" - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self listMorph highlightedRow: nextSelection. - "Update the model in next world cycle, so user gets the immediate feedback." - UISupervisor whenUIinSafeState: [ self setSelectionIndex: nextSelection ]. - ] - ]! ! -!PluggableListMorph methodsFor: 'siblings' stamp: 'RNG 3/16/2019 14:08:59'! - leftSibling: aListMorphToTheLeft - - leftSibling _ aListMorphToTheLeft! ! -!PluggableListMorph methodsFor: 'siblings' stamp: 'RNG 3/16/2019 14:08:42'! - leftSibling: aListMorphToTheLeft rightSibling: aListMorphToTheRight - - self leftSibling: aListMorphToTheLeft. - self rightSibling: aListMorphToTheRight.! ! -!PluggableListMorph methodsFor: 'siblings' stamp: 'RNG 3/16/2019 14:08:55'! - rightSibling: aListMorphToTheRight - - rightSibling _ aListMorphToTheRight! ! -!PluggableListMorph methodsFor: 'events' stamp: 'RNG 3/16/2019 14:27:45' prior: 50374047! - keyStroke: aKeyboardEvent - "Process keys" - - | aCharacter | - (Theme current keyStroke: aKeyboardEvent morph: self) - ifTrue: [^ self]. - (self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - (self arrowKey: aKeyboardEvent) ifNotNil: [ ^ self ]. - aCharacter _ aKeyboardEvent keyCharacter. - aCharacter numericValue = 27 ifTrue: [ " escape key" - ^ self mouseButton2Activity]. - aKeyboardEvent anyModifierKeyPressed - ifTrue: [ - (self keystrokeAction: aCharacter) - ifTrue: [ ^self ]]. - ^ self keyboardSearch: aCharacter! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'RNG 3/19/2019 00:12:56' prior: 50391361! - arrowKey: aKeyboardEvent - - aKeyboardEvent isArrowUp ifTrue: [ ^ self navigateUp ]. - aKeyboardEvent isArrowDown ifTrue: [ ^ self navigateDown ]. - aKeyboardEvent isArrowLeft ifTrue: [ ^ self navigateLeft ]. - aKeyboardEvent isArrowRight ifTrue: [ ^ self navigateRight ]. - aKeyboardEvent isHome ifTrue: [ ^ self navigateToTop ]. - aKeyboardEvent isEnd ifTrue: [ ^ self navigateToBottom ]. - aKeyboardEvent isPageUp ifTrue: [ ^ self navigateOnePageUp ]. - aKeyboardEvent isPageDown ifTrue: [ ^ self navigateOnePageDown ]. - ^ nil! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'RNG 3/16/2019 14:29:57' prior: 50426629! - buildMorphicWindow - "Create a pluggable version of all the morphs for a Browser in Morphic" - - | upperPanes messageCatList messageList systemCatList classList | - - systemCatList _ self buildMorphicSystemCatList. - classList _ self buildMorphicClassList. - messageCatList _ self buildMorphicMessageCatList. - messageList _ self buildMorphicMessageList. - - systemCatList rightSibling: classList. - classList leftSibling: systemCatList rightSibling: messageCatList. - messageCatList leftSibling: classList rightSibling: messageList. - messageList leftSibling: messageCatList. - - classList makeItemsDraggable. - systemCatList - acceptDropsFrom: classList - performing: #categorizeUnderCategoryAt:class: - whenOutsideList: #categorizeUnderNewCategoryClass:. - - messageList makeItemsDraggable. - messageCatList - acceptDropsFrom: messageList - performing: #categorizeUnderCategoryAt:selector: - whenOutsideList: #categorizeUnderNewCategorySelector:. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: systemCatList proportionalWidth: 0.2; - addAdjusterAndMorph: (self buildMorphicClassColumnWith: classList) proportionalWidth: 0.2; - addAdjusterAndMorph: messageCatList proportionalWidth: 0.2; - addAdjusterAndMorph: messageList proportionalWidth: 0.4. - - self layoutMorph - addMorph: upperPanes proportionalHeight: 0.3; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.7. - - model changed: #editSelection! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'RNG 3/19/2019 00:24:39' prior: 50436864! - buildNoSysCatMorphicWindow - "A Browser without the class categories list" - - | mySingletonList upperPanes messageCatList messageList classColumn classList | - mySingletonList _ PluggableListMorph - model: model - listGetter: #systemCategorySingleton - indexGetter: #indexIsOne - indexSetter: #indexIsOne: - mainView: self - menuGetter: #systemCatSingletonMenu - keystrokeAction: #systemCatSingletonKey:from:. - mySingletonList hideScrollBarsIndefinitely. - - classColumn _ self buildMorphicClassColumn. - classList _ classColumn submorphs third. - messageCatList _ self buildMorphicMessageCatList. - messageList _ self buildMorphicMessageList. - - classList rightSibling: messageCatList. - messageCatList leftSibling: classList rightSibling: messageList. - messageList leftSibling: messageCatList. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: classColumn proportionalWidth: 0.3; - addAdjusterAndMorph: messageCatList proportionalWidth: 0.3; - addAdjusterAndMorph: messageList proportionalWidth: 0.4. - - messageList makeItemsDraggable. - messageCatList - acceptDropsFrom: messageList - performing: #categorizeUnderCategoryAt:selector: - whenOutsideList: #categorizeUnderNewCategorySelector:. - - self layoutMorph - addMorph: mySingletonList fixedHeight: Preferences standardCodeFont height + 10; - addAdjusterAndMorph: upperPanes proportionalHeight: 0.3; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.7. - - model changed: #editSelection! ! - -PluggableListMorph removeSelector: #leftKeyPressed! - -PluggableListMorph removeSelector: #rightKeyPressed! - -PluggableScrollPane subclass: #PluggableListMorph - instanceVariableNames: 'list getListSelector getIndexSelector setIndexSelector keystrokeActionSelector autoDeselect lastKeystrokeTime lastKeystrokes doubleClickSelector menuGetter mainView leftSibling rightSibling' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #PluggableListMorph category: #'Morphic-Views'! -PluggableScrollPane subclass: #PluggableListMorph - instanceVariableNames: 'list getListSelector getIndexSelector setIndexSelector keystrokeActionSelector autoDeselect lastKeystrokeTime lastKeystrokes doubleClickSelector menuGetter mainView leftSibling rightSibling' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3673-BrowserNavegationWithArrowKeys-NahuelGarbezza-2019Mar19-00h10m-RNG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3672] on 19 March 2019 at 2:19:53 am'! - -"Change Set: 3673-CuisCore-AuthorName-2019Mar19-02h18m -Date: 19 March 2019 -Author: Nahuel Garbezza - -add #isLiteralVariableNode which was needed when renaming contextually in the editor."! -!ParseNode methodsFor: 'testing' stamp: 'RNG 3/19/2019 02:18:54'! - isLiteralVariableNode - - ^ false! ! -!LiteralVariableNode methodsFor: 'testing' stamp: 'RNG 3/19/2019 02:18:42'! - isLiteralVariableNode - - ^ true! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3674-isLiteralVariableNode-NahuelGarbezza-2019Mar19-02h18m-RNG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3672] on 18 March 2019 at 6:45:12 pm'! -!TextModel methodsFor: 'testing' stamp: 'jmv 3/18/2019 18:43:10'! - is: aSymbol - ^ aSymbol == #canSaveContents or: [ super is: aSymbol ]! ! -!SystemWindow methodsFor: 'user interface' stamp: 'jmv 3/18/2019 18:43:17' prior: 50448478! - hasSaveAs - "Returns true if the window has a model which can be saved to a file" - ^model is: #canSaveContents! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3675-saveAs-cleanup-JuanVuletich-2019Mar18-18h44m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3671] on 18 March 2019 at 6:13:27 pm'! -!PasteUpMorph methodsFor: 'events' stamp: 'jmv 3/18/2019 17:56:22'! - keyStroke: aKeyboardEvent - "Handle a keystroke event." - (aKeyboardEvent commandAltKeyPressed or: [ aKeyboardEvent controlKeyPressed ]) - ifTrue: [ - aKeyboardEvent keyCharacter = $b ifTrue: [ BrowserWindow openBrowser ]. - aKeyboardEvent keyCharacter = $f ifTrue: [ BrowserWindow findClass ]]. - "aKeyboardEvent keyCharacter print." - ^ super keyStroke: aKeyboardEvent! ! -!TextEditor methodsFor: 'menu' stamp: 'jmv 5/6/2018 10:32:42' prior: 50446857! - getMenu - - ^(MenuMorph new defaultTarget: self) - addTitle: self class name; - addStayUpIcons; - addItemsFromDictionaries: `{ - { - #label -> 'Help...'. - #selector -> #openHelp. - #icon -> #helpIcon - } asDictionary. - nil. - { - #label -> 'Find...(f)'. - #selector -> #find. - #icon -> #findIcon - } asDictionary. - { - #label -> 'Find Again (g)'. - #selector -> #findAgain. - #icon -> #systemIcon - } asDictionary. - { - #label -> 'Use Selection for Find (j)'. - #selector -> #setSearchString. - #icon -> #saveAsIcon - } asDictionary. - nil. - { - #label -> 'Undo - multiple (z)'. - #selector -> #undo. - #icon -> #undoIcon - } asDictionary. - { - #label -> 'Redo - multiple (Z)'. - #selector -> #redo. - #icon -> #redoIcon - } asDictionary. - { - #label -> 'Undo / Redo history'. - #selector -> #offerUndoHistory. - #icon -> #changesIcon - } asDictionary. - nil. - { - #label -> 'Copy (c)'. - #selector -> #copySelection. - #icon -> #copyIcon - } asDictionary. - { - #label -> 'Cut (x)'. - #selector -> #cut. - #icon -> #cutIcon - } asDictionary. - { - #label -> 'Paste (v)'. - #selector -> #paste. - #icon -> #pasteIcon - } asDictionary. - { - #label -> 'Paste without Format'. - #selector -> #pasteString. - #icon -> #pasteIcon - } asDictionary. - { - #label -> 'Paste...'. - #selector -> #pasteRecent. - #icon -> #worldIcon - } asDictionary. - nil. - { - #label -> 'Toggle WordWrap'. - #selector -> #wrapOnOff. - #icon -> #genericTextIcon - } asDictionary. - { - #label -> 'Set Font... (k)'. - #selector -> #offerFontMenu. - #icon -> #preferencesDesktopFontIcon - } asDictionary. - { - #label -> 'Clear Font'. - #selector -> #clearFont. - #icon -> #newIcon - } asDictionary. - { - #label -> 'Set Default Font...'. - #selector -> #offerDefaultFontMenu. - #icon -> #fontXGenericIcon - } asDictionary. - { - #label -> 'Set Alignment...'. - #selector -> #chooseAlignment. - #icon -> #formatJustifyLeftIcon - } asDictionary. - }`! ! -!TextEditor class methodsFor: 'keyboard shortcut tables' stamp: 'jmv 12/21/2018 08:09:38' prior: 50446933! - basicCmdShortcutsSpec - " - Editor initialize - " - - "arranged in QWERTY keyboard order" - ^#( - #( $( #enclose: 'Enclose within ( and ), or remove enclosing ( and )') - #( $[ #enclose: 'Enclose within [ and ], or remove enclosing [ and ]') - #( ${ #enclose: 'Enclose within { and }, or remove enclosing { and }') - #( $' #enclose: 'Enclose within single quotes, or remove enclosing single quotes') - #( $" #enclose: 'Enclose within double quotes, or remove enclosing double quotes') - #( $` #enclose: 'Enclose within backticks, or remove enclosing backticks') - #( $< #enclose: 'Enclose within < and >, or remove enclosing < and >') - - #( $a #selectAll: 'Select all') - #( $f #find: 'Find') - #( $g #findAgain: 'Find again') - #( $h #help: 'Open this help') - #( $j #setSearchString: 'Set selection as search string for find again') - - #( $z #undo: 'Undo (multiple levels)') - #( $x #cut: 'Cut selection and store it in the Clipboard') - #( $c #copySelection: 'Copy selection to the Clipboard') - #( $v #paste: 'Paste Clipboard contents') - - #( $R #indent: 'Indent (move selection one tab-stap right)') - #( $Y #makeUppercase: 'Force selection to uppercase') - #( $U #changeLineEndsToLf: 'Convert line endings to LF characters (Cuis convention) in selection') - - #( $H #cursorTopHome: 'Move cursor to start of text') - #( $L #outdent: 'Outdent (move selection one tab-stop left)') - - #( $Z #redo: 'Redo (multiple levels)') - #( $X #makeLowercase: 'Force selection to lowercase') - #( $C #compareToClipboard: 'Compare argument to clipboard') - - #( $ #selectWord: 'Select the current word as with double clicking') - )! ! -!SmalltalkEditor class methodsFor: 'keyboard shortcut tables' stamp: 'jmv 9/6/2018 17:50:48' prior: 50446992! - cmdShortcutsSpec - " - Editor initialize - " - "arranged in QWERTY keyboard order" - ^#( - #( $r #acceptAndDebugTest: 'Saves method and debugs it') - #( $t #acceptAndTest: 'Saves method, runs it as test and then all tests in class. Opens debugger if error') - #( $y #acceptAndTestAll: 'Saves method, runs it as test and then all tests in class category. Opens debugger if error') - #( $i #inspectIt: 'Inspect it (selection is a valid expression, or selection is over an inspect-ilst)') - #( $p #printIt: 'Print it (selection is a valid expression)') - - #( $s #save: 'Save (i.e. accept)') - #( $d #doIt: 'Do it (selection is a valid expression)') - - #( $b #browseIt: 'Browse it (selection is a class name or cursor is over a class-list or message-list)') - #( $n #sendersOfIt: 'Senders of it (selection is a message selector or cursor is over a class-list or message-list)') - #( $m #implementorsOfIt: 'Implementors of it (selection is a message selector or cursor is over a class-list or message-list)') - - #( $E #methodStringsContainingit:'Method strings containing it') - #( $T #displayIfTrue: 'Insert #ifTrue:') - #( $I #exploreIt: 'Inspect via Object Explorer') - - #( $Q #argPrev: 'Previous argument') - #( $A #argNext: 'Next argument') - #( $D #debugIt: 'Debug it') - #( $F #displayIfFalse: 'Insert #ifFalse:') - #( $G #fileItIn: 'File in selection') - - #( $V #pasteInitials: 'Paste author initials') - #( $N #referencesToIt: 'References to it (selection is a class name, or cursor is over a class-list or message-list)') - )! ! -!SmalltalkEditor class methodsFor: 'menu' stamp: 'HAW 7/10/2018 19:03:02' prior: 50447047! - smalltalkEditorMenu2Options - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Find...(f)'. - #selector -> #find. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'Find Again (g)'. - #selector -> #findAgain. - #icon -> #systemIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Use Selection for Find (j)'. - #selector -> #setSearchString. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Undo - multiple (z)'. - #selector -> #undo. - #icon -> #undoIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Redo - multiple (Z)'. - #selector -> #redo. - #icon -> #redoIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'Undo / Redo history'. - #selector -> #offerUndoHistory. - #icon -> #changesIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Copy (c)'. - #selector -> #copySelection. - #icon -> #copyIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Cut (x)'. - #selector -> #cut. - #icon -> #cutIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'Paste (v)'. - #selector -> #paste. - #icon -> #pasteIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 40. - #label -> 'Paste without Format'. - #selector -> #pasteString. - #icon -> #pasteIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 50. - #label -> 'Paste...'. - #selector -> #pasteRecent. - #icon -> #worldIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'Toggle WordWrap'. - #selector -> #wrapOnOff. - #icon -> #genericTextIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'Set Font... (k)'. - #selector -> #offerFontMenu. - #icon -> #preferencesDesktopFontIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'Clear Font'. - #selector -> #clearFont. - #icon -> #newIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 40. - #label -> 'Set Default Font...'. - #selector -> #offerDefaultFontMenu. - #icon -> #fontXGenericIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'More...'. - #selector -> #openMenu. - #icon -> #listAddIcon - } asDictionary. - }` -! ! -!Morph methodsFor: 'events' stamp: 'jmv 3/18/2019 17:39:33' prior: 16874640! - mouseLeave: evt - "Handle a mouseLeave event, meaning the mouse just left my bounds with no button pressed." - evt hand releaseKeyboardFocus: self. - "Allow instances to dynamically use properties for handling common events." - self - valueOfProperty: #mouseLeave: - ifPresentDo: [ :handler | handler value: evt ].! ! -!HandMorph methodsFor: 'focus handling' stamp: 'jmv 3/18/2019 17:58:51' prior: 16851989! - releaseKeyboardFocus: aMorph - "If the given morph had the keyboard focus before, release it" - keyboardFocus ifNotNil: [ - keyboardFocus withAllOwnersDo: [ :outerOwner | - outerOwner == aMorph ifTrue: [self releaseKeyboardFocus]]]! ! -!Theme methodsFor: 'keyboard shortcuts' stamp: 'jmv 2/23/2018 15:42:17' prior: 50447162! - keyStroke: aKeyboardEvent morph: aMorph - - (aKeyboardEvent commandAltKeyPressed or: [ aKeyboardEvent controlKeyPressed ]) - ifFalse: [ ^ false ]. - - aKeyboardEvent keyValue = $w numericValue ifTrue: [ - aMorph owningWindow ifNotNil: [ :w | - (w morphContainsPoint: (w internalizeFromWorld: aKeyboardEvent eventPosition)) ifTrue: [ - w delete. - ^true ] ]]. -" aKeyboardEvent keyValue = $f numericValue - ifTrue: [aMorph owningWindow ifNotNil: [ :w | w fullScreen. ^true ]]. -" - ^ false! ! - -Theme removeSelector: #findClassIn:! - -Theme removeSelector: #findClassIn:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3676-GlobalFindOnlyIfFocusOnWorld-JuanVuletich-2019Mar18-18h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3671] on 18 March 2019 at 6:16:32 pm'! -!Morph methodsFor: 'events' stamp: 'jmv 3/18/2019 18:03:59' prior: 16874517! - keyStroke: aKeyboardEvent - "Handle a keystroke event." - - (self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - - "Allow instances to dynamically use properties for handling common events." - self - valueOfProperty: #'keyStroke:' - ifPresentDo: [ :handler | handler value: aKeyboardEvent ]! ! -!PluggableScrollPane methodsFor: 'events' stamp: 'jmv 3/18/2019 18:04:07' prior: 50374012! - keyStroke: aKeyboardEvent - - ( self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - super keyStroke: aKeyboardEvent. - scroller keyStroke: aKeyboardEvent! ! -!HierarchicalListMorph methodsFor: 'events' stamp: 'jmv 3/18/2019 18:03:49' prior: 50374023! - keyStroke: aKeyboardEvent - "Process potential command keys" - - | args aCharacter | - (self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - aCharacter _ aKeyboardEvent keyCharacter. - (self arrowKey: aCharacter) - ifTrue: [ ^self ]. - keystrokeActionSelector ifNil: [^self]. - (args _ keystrokeActionSelector numArgs) = 1 - ifTrue: [^mainView perform: keystrokeActionSelector with: aCharacter]. - args = 2 - ifTrue: [ - ^mainView - perform: keystrokeActionSelector - with: aCharacter - with: self]. - ^self error: 'The keystrokeActionSelector must be a 1- or 2-keyword symbol'! ! -!PluggableListMorph methodsFor: 'events' stamp: 'jmv 3/18/2019 18:04:03' prior: 50448678! - keyStroke: aKeyboardEvent - "Process keys" - - | aCharacter | - (self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - (self arrowKey: aKeyboardEvent) ifNotNil: [ ^ self ]. - aCharacter _ aKeyboardEvent keyCharacter. - aCharacter numericValue = 27 ifTrue: [ " escape key" - ^ self mouseButton2Activity]. - aKeyboardEvent anyModifierKeyPressed - ifTrue: [ - (self keystrokeAction: aCharacter) - ifTrue: [ ^self ]]. - ^ self keyboardSearch: aCharacter! ! -!TextModelMorph methodsFor: 'events' stamp: 'jmv 3/18/2019 18:04:10' prior: 16934057! -keyStroke: aKeyboardEvent - "A keystroke was hit while the receiver had keyboard focus. Pass the keywtroke on to my textMorph, and and also, if I have an event handler, pass it on to that handler" - - (self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - self textMorph keyStroke: aKeyboardEvent! ! -!InnerTextMorph methodsFor: 'events' stamp: 'jmv 3/18/2019 18:03:54' prior: 50374182! - keyStroke: aKeyboardEvent - - (self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - - autoCompleter - ifNil: [ self processKeyStroke: aKeyboardEvent ] - ifNotNil: [ - autoCompleter - autoCompletionAround: [ self processKeyStroke: aKeyboardEvent ] - keyStroke: aKeyboardEvent ]! ! -!KeyboardEvent methodsFor: 'dispatching' stamp: 'jmv 3/18/2019 18:03:20' prior: 16861811! - sentTo: aMorph localPosition: positionInAMorph - "Dispatch the receiver into anObject" - type == #keystroke ifTrue: [ - (self commandAltKeyPressed or: [ self controlKeyPressed ]) - ifTrue: [ - self keyValue = $w numericValue ifTrue: [ - aMorph owningWindow ifNotNil: [ :w | - (w morphContainsPoint: (w internalizeFromWorld: self eventPosition)) ifTrue: [ - w delete. - ^self ]]]]. - ^ aMorph - processKeystroke: self - localPosition: positionInAMorph ]. - type == #keyDown ifTrue: [ - ^ aMorph - processKeyDown: self - localPosition: positionInAMorph ]. - type == #keyUp ifTrue: [ - ^ aMorph - processKeyUp: self - localPosition: positionInAMorph ]. - ^ super - sentTo: aMorph - localPosition: positionInAMorph.! ! - -Theme removeSelector: #keyStroke:morph:! - -Theme removeSelector: #keyStroke:morph:! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Editor initialize! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3677-ThemeCleanup-JuanVuletich-2019Mar18-18h13m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3677] on 19 March 2019 at 5:25:59 pm'! -!AutoCompleterMorph methodsFor: 'events' stamp: 'jmv 3/19/2019 17:25:05'! - mouseEnter: evt - self activeHand newKeyboardFocus: completer textMorph. - ^ super mouseEnter: evt! ! -!AutoCompleterMorph methodsFor: 'event handling testing' stamp: 'jmv 3/19/2019 17:25:18'! - handlesMouseOver: evt - "Do I want to receive mouseEnter: and mouseLeave: when the button is up and the hand is empty?" - ^true! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3678-AutoCompleterMorphFix-JuanVuletich-2019Mar19-17h25m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3678] on 19 March 2019 at 5:34:42 pm'! -!KeyboardEvent methodsFor: 'dispatching' stamp: 'jmv 3/19/2019 17:34:09' prior: 50449325! - sentTo: aMorph localPosition: positionInAMorph - "Dispatch the receiver into anObject" - type == #keystroke ifTrue: [ - (self shiftPressed and: [self keyValue = 13 ]) ifTrue: [ - ^BrowserWindow findClass]. - (self commandAltKeyPressed or: [ self controlKeyPressed ]) - ifTrue: [ - self keyValue = $w numericValue ifTrue: [ - aMorph owningWindow ifNotNil: [ :w | - (w morphContainsPoint: (w internalizeFromWorld: self eventPosition)) ifTrue: [ - w delete. - ^self ]]]]. - ^ aMorph - processKeystroke: self - localPosition: positionInAMorph ]. - type == #keyDown ifTrue: [ - ^ aMorph - processKeyDown: self - localPosition: positionInAMorph ]. - type == #keyUp ifTrue: [ - ^ aMorph - processKeyUp: self - localPosition: positionInAMorph ]. - ^ super - sentTo: aMorph - localPosition: positionInAMorph.! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3679-ShiftEnter-GlobalFindClass-JuanVuletich-2019Mar19-17h30m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3674] on 19 March 2019 at 6:57:48 am'! -!MessageSet methodsFor: 'message list' stamp: 'HAW 3/19/2019 06:56:35' prior: 16870002! - selectedMessage - "Answer the source method for the currently selected message." - - | class selector | - selectedMessage ifNil: [^ 'Class vanished']. - - class _ selectedMessage actualClass. - selector _ selectedMessage methodSymbol. - selector ifNil: [ ^'prims']. - (class notNil and: [ class includesSelector: selector]) ifFalse: [ - currentCompiledMethod _ nil. - ^ 'Missing']. - - selector first isUppercase ifTrue: [ - selector == #Comment ifTrue: [ - currentCompiledMethod _ class organization commentRemoteStr. - ^ class comment]. - selector == #Definition ifTrue: [ - ^ class definition]. - selector == #Hierarchy ifTrue: [^ class printHierarchy]]. - - self showingDecompile ifTrue: [ - ^ self decompiledSource ]. - - currentCompiledMethod _ class compiledMethodAt: selector ifAbsent: nil. - self showingDocumentation ifTrue: [ - ^ self commentContents ]. - - ^self sourceStringPrettifiedAndDiffed! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3680-DeletingAClassWhenSeeingImplementorsOrSenders-HernanWilkinson-2019Mar19-06h52m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3680] on 19 March 2019 at 6:37:26 pm'! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'HAW 3/19/2019 18:36:48' prior: 50380231! - arrowKey: aChar - "Handle a keyboard navigation character. Answer true if handled, false if not." - | keyEvent answer nextSelection oldSelection | - answer := false. - keyEvent := aChar numericValue. - oldSelection := self visualSelectionIndex. - nextSelection := oldSelection. - keyEvent = 31 ifTrue: [ - "down" - nextSelection := oldSelection + 1. - nextSelection > self maximumSelection ifTrue: [ nextSelection := self minimumSelection ]]. - keyEvent = 30 ifTrue: [ - "up" - nextSelection := oldSelection - 1. - nextSelection < self minimumSelection ifTrue: [ nextSelection := self maximumSelection ]]. - keyEvent = 1 ifTrue: [ "home" - nextSelection := 1 ]. - keyEvent = 4 ifTrue: [ "end" - nextSelection := scroller submorphs size ]. - keyEvent = 11 ifTrue: [ "page up" - nextSelection := oldSelection - self numSelectionsInView max: 1 ]. - keyEvent = 12 ifTrue: [ "page down" - nextSelection := oldSelection + self numSelectionsInView ]. - keyEvent = 29 ifTrue: [ - "right" - selectedMorph ifNotNil: [ - (selectedMorph canExpand and: [ selectedMorph isExpanded not ]) - ifTrue: [ - self toggleExpandedState: selectedMorph. - self scrollSelectionIntoView. - answer := true ] - ifFalse: [ nextSelection := oldSelection + 1 ]]]. - keyEvent = 28 ifTrue: [ - "left" - selectedMorph ifNotNil: [ - selectedMorph isExpanded - ifTrue: [ - self toggleExpandedState: selectedMorph. - self scrollSelectionIntoView. - answer := true ] - ifFalse: [ - oldSelection > self minimumSelection ifTrue: [ - nextSelection _ (oldSelection-1 to: 1 by: -1) - detect: [ :i | ( scroller submorphs at: i) indentLevel < selectedMorph indentLevel ] - ifNone: [ oldSelection ]]. - ]]]. - nextSelection = oldSelection ifFalse: [ - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self highlightedMorph: (self listMorphAt: nextSelection). - "Update the model in next world cycle, so user gets the immediate feedback." - UISupervisor whenUIinSafeState: [ self setSelectionIndex: nextSelection ]. - answer := true ]. - ^ answer.! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3681-HierarchicalListMorphLeftKey-HernanWilkinson-2019Mar16-16h37m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3681] on 20 March 2019 at 7:47:50 am'! -!Stream methodsFor: 'accessing' stamp: 'HAW 3/20/2019 06:54:02'! - nextPut: anObject when: aCondition - - aCondition ifTrue: [ self nextPut: anObject ].! ! -!Stream methodsFor: 'accessing' stamp: 'HAW 3/20/2019 06:54:23'! - nextPutAll: aCollection when: aCondition - - aCondition ifTrue: [ self nextPutAll: aCollection ]. - ! ! -!Stream methodsFor: 'printing' stamp: 'HAW 3/20/2019 06:54:30'! - print: anObject when: aCondition - - aCondition ifTrue: [self print: anObject].! ! -!WriteStream methodsFor: 'character writing' stamp: 'HAW 3/20/2019 07:28:29'! -newLineTab: times when: aCondition - - aCondition ifTrue: [ self newLineTab: times ] - - ! ! -!WriteStream methodsFor: 'character writing' stamp: 'HAW 3/20/2019 07:22:21'! - newLineWhen: aCondition - - aCondition ifTrue: [ self newLine ]! ! -!WriteStream methodsFor: 'character writing' stamp: 'HAW 3/20/2019 07:43:22'! - space: times when: aCondition - - aCondition ifTrue: [ self space: times ] - - ! ! -!WriteStream methodsFor: 'character writing' stamp: 'HAW 3/20/2019 07:20:05'! - spaceWhen: aCondition - - aCondition ifTrue: [ self space ]! ! -!WriteStream methodsFor: 'character writing' stamp: 'HAW 3/20/2019 07:26:09'! - tab: times when: aCondition - - aCondition ifTrue: [ self tab: times ] - - ! ! -!WriteStream methodsFor: 'character writing' stamp: 'HAW 3/20/2019 07:23:42'! - tabWhen: aCondition - - aCondition ifTrue: [ self tab ]! ! -!Transcript class methodsFor: 'old Transcript compatibility' stamp: 'HAW 3/20/2019 07:30:29'! - newLineWhen: aCondition - - aCondition ifTrue: [ self newLine ] - - ! ! -!Transcript class methodsFor: 'old Transcript compatibility' stamp: 'HAW 3/20/2019 07:12:13'! - nextPut: anObject when: aCondition - - aCondition ifTrue: [ self nextPut: anObject ].! ! -!Transcript class methodsFor: 'old Transcript compatibility' stamp: 'HAW 3/20/2019 07:11:01'! - nextPutAll: aCollection when: aCondition - - aCondition ifTrue: [ self nextPutAll: aCollection ]. -! ! -!Transcript class methodsFor: 'old Transcript compatibility' stamp: 'HAW 3/20/2019 07:12:56'! - print: anObject when: aCondition - - aCondition ifTrue: [self print: anObject].! ! -!Transcript class methodsFor: 'old Transcript compatibility' stamp: 'HAW 3/20/2019 07:39:41'! - spaceWhen: aCondition - - aCondition ifTrue: [ self space ]! ! -!Transcript class methodsFor: 'old Transcript compatibility' stamp: 'HAW 3/20/2019 07:40:59'! - tabWhen: aCondition - - aCondition ifTrue: [ self tab ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3682-nextPutWhen-HernanModrow-2019Mar20-06h53m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3682] on 20 March 2019 at 3:52:35 pm'! -!Preferences class methodsFor: 'standard queries' stamp: 'GC 3/19/2019 21:00:04' prior: 0! - biggerCursors - ^ self - valueOfFlag: #biggerCursors - ifAbsent: [ false ].! ! -!Preferences class methodsFor: 'themes' stamp: 'GC 3/19/2019 21:02:02' prior: 50391970! - cuisDefaults - " - Preferences cuisDefaults - " - self setPreferencesFrom: - - #( - (balloonHelpEnabled true) - (biggerCursors false) - (browseWithPrettyPrint false) - (caseSensitiveFinds false) - (checkForSlips true) - (cmdDotEnabled true) - (diffsInChangeList true) - (diffsWithPrettyPrint false) - (menuKeyboardControl true) - (optionalButtons true) - (extraDebuggerButtons true) - (subPixelRenderFonts true) - (thoroughSenders true) - (cheapWindowReframe false) - (syntaxHighlightingAsYouType true) - (tapAndHoldEmulatesButton2 true) - (clickGrabsMorphs false) - - (syntaxHighlightingAsYouTypeAnsiAssignment false) - (syntaxHighlightingAsYouTypeLeftArrowAssignment false) - ). - self useMenuIcons - ". - Theme beCurrent. - Taskbar showTaskbar - "! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 3/20/2019 15:49:29' prior: 50435253! - defaultFont11 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont11 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 11) - (setListFontTo: 11) - (setMenuFontTo: 12) - (setWindowTitleFontTo: 14) - (setCodeFontTo: 11) - (setButtonFontTo: 11)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 3/20/2019 15:49:26' prior: 50437167! - defaultFont12 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont12 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 12) - (setListFontTo: 12) - (setMenuFontTo: 12) - (setWindowTitleFontTo: 14) - (setCodeFontTo: 12) - (setButtonFontTo: 12)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 3/20/2019 15:49:22' prior: 50435271! - defaultFont14 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont14 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 14) - (setListFontTo: 14) - (setMenuFontTo: 14) - (setWindowTitleFontTo: 17) - (setCodeFontTo: 14) - (setButtonFontTo: 14)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Preferences standardCodeFont pointSize < 14 ifTrue: [Preferences disable: #biggerCursors]! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3683-DisableBiggerCursorsByDefault-GastonCaruso-JuanVuletich-2019Mar20-15h49m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3683] on 20 March 2019 at 4:37:35 pm'! -!FeatureRequirement methodsFor: 'private' stamp: 'jmv 3/20/2019 16:36:14' prior: 50430083! - placesToLookForPackagesDo: aBlock - - | base myDir | - - "Look inside my own folder" - pathName ifNotNil: [ - myDir _ pathName asFileEntry parent. - aBlock value: myDir ]. - - "Look in Cuis image folder and reasonable subfolders" - base _ DirectoryEntry smalltalkImageDirectory. - base allDirectoriesDo: aBlock. - - "Look in parent directory and reasonable subfolders. - Useful when image is stored in a subdirectory of the main app directory. - This could be the case when the package comes from a 'main' git repo, and image is copied from gitHub. - First try directories including the word Cuis in the name. Then try others." - base parent directoriesDo: [ :dir | - ('*Cuis*' match: dir name) - ifTrue: [aBlock value: dir. dir allDirectoriesDo: aBlock]]. - base parent directoriesDo: [ :dir | - ('*Cuis*' match: dir name) - ifFalse: [aBlock value: dir. dir allDirectoriesDo: aBlock]]. - - "Also look in host OS current directory" - (base ~= DirectoryEntry currentDirectory and: [base parent ~= DirectoryEntry currentDirectory]) - ifTrue: [ - base _ DirectoryEntry currentDirectory. - base allDirectoriesDo: aBlock ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3684-PreferCuisFoldersForSearchingPackages-JuanVuletich-2019Mar20-16h25m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3684] on 21 March 2019 at 11:39:19 am'! -!MorphicScanner methodsFor: 'scanning' stamp: 'jmv 3/21/2019 11:38:24' prior: 16878048! - placeEmbeddedObject: anchoredFormOrMorph - - (super placeEmbeddedObject: anchoredFormOrMorph) ifFalse: [^ false]. - (anchoredFormOrMorph is: #Morph) - ifTrue: [ - anchoredFormOrMorph morphPosition: - ((destX - anchoredFormOrMorph morphWidth)@ - (lineY+ line baseline - anchoredFormOrMorph morphHeight)) - - topLeft. - anchoredFormOrMorph show. - canvas fullDraw: anchoredFormOrMorph ] - ifFalse: [ - destY _ lineY. - canvas - image: anchoredFormOrMorph - at: destX - anchoredFormOrMorph width @ (destY + line baseline - anchoredFormOrMorph height) ]. - ^ true! ! -!InnerTextMorph methodsFor: 'notifications' stamp: 'jmv 3/21/2019 11:37:52' prior: 16856099! - possiblyChanged - | embeddedMorphs | - embeddedMorphs _ model actualContents embeddedMorphs. - self submorphsDo: [:each| - (embeddedMorphs includes: each) ifFalse: [ - self privateRemove: each. - each privateOwner: nil ]]. - embeddedMorphs do: [ :each| - each owner == self ifFalse: [ - self addMorphFront: each. - each hide "Show it only when properly located"]]. - owner possiblyChanged! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3685-MorphsInText-fix-JuanVuletich-2019Mar21-11h33m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3685] on 25 March 2019 at 4:08:19 pm'! -!Editor class methodsFor: 'class initialization' stamp: 'HAW 3/25/2019 16:06:05'! - collectCmdShortcutsSpecUsing: anInitializationMessage - - | shortcutsSpec dynamicInitializationMessage | - - shortcutsSpec := self perform: anInitializationMessage. - - dynamicInitializationMessage := (self name asString uncapitalized, anInitializationMessage asString capitalized) asSymbol. - (Smalltalk allClassesImplementing: dynamicInitializationMessage) do: [ :aClass | - shortcutsSpec := shortcutsSpec, (aClass soleInstance perform: dynamicInitializationMessage) ]. - - ^shortcutsSpec - -! ! -!Editor class methodsFor: 'keyboard shortcut tables' stamp: 'HAW 3/25/2019 16:02:43'! - allCmdShortcutsSpec - - ^ (self collectCmdShortcutsSpecUsing: #basicCmdShortcutsSpec), (self collectCmdShortcutsSpecUsing: #cmdShortcutsSpec)! ! -!Editor class methodsFor: 'keyboard shortcut tables' stamp: 'HAW 3/25/2019 15:57:24'! - allShiftShortcutsSpec - - ^ self shiftShortcutsSpec! ! -!Editor class methodsFor: 'keyboard shortcut tables' stamp: 'HAW 3/25/2019 15:57:38'! - shiftShortcutsSpec - - ^#( - #( 'Enter' #globalFindClass: 'Global Find class name or fragment') - )! ! -!Editor class methodsFor: 'help' stamp: 'HAW 3/25/2019 15:33:02'! - formatShortcutsUsingModifierKey: aModifierKey andSpecs: aSpecs - "Format shortcuts specs with a modifier key" - ^ String streamContents: [ :strm | - aSpecs do: [ :triplet | | c | - c _ triplet first = Character space - ifFalse: [ triplet first asString, ' ' ] - ifTrue: [ 'Space']. - strm nextPutAll: (aModifierKey, '-', c, String tab, String tab, triplet third). - strm newLine ]]! ! -!Editor class methodsFor: 'class initialization' stamp: 'HAW 3/25/2019 15:59:28' prior: 16836902! - basicInitialize - " - Editor initialize - " - self withAllSubclassesDo: [ :c | c initializeShortcuts; initializeCmdShortcuts ]! ! -!Editor class methodsFor: 'class initialization' stamp: 'HAW 3/25/2019 15:59:22' prior: 50334908! -initialize - " - Editor initialize - " - self withAllSubclassesDo: [ :c | c basicInitialize ]! ! -!Editor class methodsFor: 'class initialization' stamp: 'HAW 3/25/2019 16:04:41' prior: 50432194! - initializeCmdShortcuts - "Initialize the (unshifted) command-key (or alt-key if not on Mac) shortcut table. - If you want to add a new shortcut for an specific editor, for example SmalltalkEditor, you should - define the message #smalltalkEditorCmdShortcutsSpec in a class of your category and it will - be dynamically send" - - "NOTE: if you don't know what your keyboard generates, use Sensor test" - - " - Editor initialize - " - - cmdShortcuts _ Array new: 256 withAll: #noop:. - - self putIntoCmdShortcuts: self allCmdShortcutsSpec -! ! -!Editor class methodsFor: 'keyboard shortcut tables' stamp: 'HAW 3/25/2019 15:57:29' prior: 16836973! - basicCmdShortcutsSpec - - ^#()! ! -!Editor class methodsFor: 'keyboard shortcut tables' stamp: 'HAW 3/25/2019 15:57:18' prior: 16836977! - cmdShortcuts - "Same for all instances. - A subclass could handle specific keyboard shortcuts for each instance, though." - - cmdShortcuts ifNil: [self initializeCmdShortcuts ]. - - ^cmdShortcuts! ! -!Editor class methodsFor: 'keyboard shortcut tables' stamp: 'HAW 3/25/2019 15:57:33' prior: 16836986! - cmdShortcutsSpec - - ^#()! ! -!Editor class methodsFor: 'keyboard shortcut tables' stamp: 'HAW 3/25/2019 15:58:00' prior: 16836990! - shortcuts - "Same for all instances. - A subclass could handle specific keyboard shortcuts for each instance, though." - - shortcuts ifNil: [ self initializeShortcuts ]. - - ^shortcuts! ! -!Editor class methodsFor: 'help' stamp: 'HAW 3/25/2019 15:33:02' prior: 50423151! - help - " - TextEditor help edit - SmalltalkEditor help edit - " - ^ (self formatShortcutsUsingModifierKey: 'Shift' andSpecs: self allShiftShortcutsSpec) , - (self formatShortcutsUsingModifierKey: 'Cmd' andSpecs: self allCmdShortcutsSpec). -! ! -!TextEditor class methodsFor: 'keyboard shortcut tables' stamp: 'HAW 3/25/2019 16:00:48' prior: 50448980! - basicCmdShortcutsSpec - " - Editor initialize - " - - "arranged in QWERTY keyboard order" - ^#( - #( $( #enclose: 'Enclose within ( and ), or remove enclosing ( and )') - #( $[ #enclose: 'Enclose within [ and ], or remove enclosing [ and ]') - #( ${ #enclose: 'Enclose within { and }, or remove enclosing { and }') - #( $' #enclose: 'Enclose within single quotes, or remove enclosing single quotes') - #( $" #enclose: 'Enclose within double quotes, or remove enclosing double quotes') - #( $` #enclose: 'Enclose within backticks, or remove enclosing backticks') - #( $< #enclose: 'Enclose within < and >, or remove enclosing < and >') - - #( $a #selectAll: 'Select all') - #( $f #find: 'Find') - #( $g #findAgain: 'Find again') - #( $h #help: 'Open this help') - #( $j #setSearchString: 'Set selection as search string for find again') - - #( $z #undo: 'Undo (multiple levels)') - #( $x #cut: 'Cut selection and store it in the Clipboard') - #( $c #copySelection: 'Copy selection to the Clipboard') - #( $v #paste: 'Paste Clipboard contents') - - #( $Y #makeUppercase: 'Force selection to uppercase') - #( $U #changeLineEndsToLf: 'Convert line endings to LF characters (Cuis convention) in selection') - - #( $H #cursorTopHome: 'Move cursor to start of text') - #( $L #outdent: 'Outdent (move selection one tab-stop left)') - - #( $Z #redo: 'Redo (multiple levels)') - #( $X #makeLowercase: 'Force selection to lowercase') - #( $C #compareToClipboard: 'Compare argument to clipboard') - - #( $ #selectWord: 'Select the current word as with double clicking') - )! ! - -Editor class removeSelector: #collectCmdShortcutsSpecsUsing:! - -Editor class removeSelector: #collectCmdShortcutsUsing:! - -Editor class removeSelector: #formatShortcutsUsingModifierKey:AndSpecs:! - -Editor class removeSelector: #initializeCmdShortcutsUsing:! - -Editor class removeSelector: #initializeCmdShortcutsUsing:! - -Editor initialize! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3686-EditorHelp-Mash-2019Mar25-15h30m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3659] on 18 March 2019 at 2:46:24 pm'! - -Object subclass: #RefactoringApplier - instanceVariableNames: 'requestExitBlock refactoring changes ' - classVariableNames: 'Appliers ' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RefactoringApplier category: #'Tools-Refactoring'! -Object subclass: #RefactoringApplier - instanceVariableNames: 'requestExitBlock refactoring changes' - classVariableNames: 'Appliers' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!ClassDescription methodsFor: 'compiling' stamp: 'HAW 3/12/2019 22:09:16'! - localBindingOf: varNameSymbol - - self subclassResponsibility ! ! -!Metaclass methodsFor: 'compiling' stamp: 'HAW 3/12/2019 22:08:40'! - localBindingOf: varNameSymbol - - ^thisClass localBindingOf: varNameSymbol ! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'HAW 3/13/2019 18:05:09'! - browseMessageList: messageList ofSize: messageListSize name: labelString autoSelect: autoSelectString - - | title | - - "Create and schedule a MessageSet browser on the message list." - - messageListSize = 0 ifTrue: [^ PopUpMenu inform: ('There are no\' , labelString) withNewLines ]. - - title _ messageListSize > 1 - ifFalse: [ labelString ] - ifTrue: [ '[', messageListSize printString, '] ', labelString]. - - MessageSetWindow - openMessageList: messageList - label: title - autoSelect: autoSelectString! ! -!Stream methodsFor: 'accessing' stamp: 'HAW 3/13/2019 20:09:02'! - nextPutAll: aCollection asCommaSeparated: aPrintBlock - - aCollection asCommaSeparated: aPrintBlock on: self! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/15/2019 14:38:44'! -rename: aNodeUnderCursor in: aSelectedClass at: aSelectedSelector - - aNodeUnderCursor isTempOrArg ifTrue: [ ^self renameTemporary: aNodeUnderCursor name ]. - - self ifRenameCanBeAppliedDo: [ - aNodeUnderCursor isMessageNode ifTrue: [ ^ self renameSelectorOf: aNodeUnderCursor in: aSelectedClass at: aSelectedSelector ]. - aNodeUnderCursor isInstanceVariableNode ifTrue: [ ^ self renameInstanceVariableOn: self codeProvider for: aNodeUnderCursor name at: aSelectedClass ]. - aNodeUnderCursor isLiteralVariableNode ifTrue: [ | potentialBehavior | - potentialBehavior := aNodeUnderCursor key value. - potentialBehavior isBehavior ifTrue: [ ^self renameClassOn: self codeProvider for: potentialBehavior theNonMetaClass ]]. - - ^morph flash ]! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/15/2019 14:41:17'! - renameSelectorOf: aMessageNode in: aSelectedClass at: aSelectedSelector - - RefactoringApplier renameSelectorApplier createAndValueHandlingExceptionsOn: model textProvider of: aMessageNode in: aSelectedClass at: aSelectedSelector! ! -!RefactoringApplier class methodsFor: 'initialization' stamp: 'HAW 3/12/2019 22:04:08'! -initialize - - Appliers := IdentityDictionary new.! ! -!RefactoringApplier class methodsFor: 'appliers' stamp: 'HAW 3/12/2019 22:03:31'! - registerRenameSelectorApplier: aRenameSelectorApplierClass - - Appliers at: #renameSelectorApplier put: aRenameSelectorApplierClass name! ! -!RefactoringApplier class methodsFor: 'appliers' stamp: 'HAW 3/12/2019 22:05:45'! - renameSelectorApplier - - ^Appliers - at: #renameSelectorApplier - ifPresent: [ :anApplierName | Smalltalk classNamed: anApplierName ] - ifAbsent: [ RenameSelectorApplier ]! ! -!RefactoringApplier class methodsFor: 'appliers' stamp: 'HAW 3/12/2019 22:12:54'! - resetRenameSelectorApplier - - Appliers removeKey: #renameSelectorApplier ifAbsent: []! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 3/12/2019 22:26:11'! -initializeImplementorsAndSenders - - implementors := IdentitySet new. - senders := IdentitySet new. -! ! -!RenameSelectorApplier methodsFor: 'as yet unclassified' stamp: 'HAW 3/14/2019 18:08:53'! - sendersFrom: methodReferences - - ^ methodReferences collect: [:aMethodReference | aMethodReference compiledMethod ]! ! -!RenameSelectorApplier class methodsFor: 'instance creation' stamp: 'HAW 3/12/2019 22:20:18'! - createAndValueHandlingExceptionsOn: aModel for: anOldSelector in: aClassToRefactor - - self createAndValueHandlingExceptions: [ self on: aModel for: anOldSelector in: aClassToRefactor ]! ! -!RenameSelectorApplier class methodsFor: 'instance creation' stamp: 'HAW 3/15/2019 13:54:21'! - createAndValueHandlingExceptionsOn: aModel of: aMessageNode in: aSelectedClass - - ^self createAndValueHandlingExceptionsOn: aModel for: aMessageNode selector key in: aSelectedClass ! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'HAW 3/13/2019 18:05:40' prior: 50402403! - browseMessageList: messageList name: labelString autoSelect: autoSelectString - - ^self browseMessageList: messageList ofSize: messageList size name: labelString autoSelect: autoSelectString! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/15/2019 13:47:38' prior: 50443714! - contextualRename - - self - withMethodNodeAndClassDo: [ :methodNode :selectedClass | self contextualRenameOf: methodNode in: selectedClass] - ifErrorsParsing: [ :anError | morph flash ]. - - ! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/15/2019 14:36:50' prior: 50443728! - contextualRenameOf: aMethodNode in: aSelectedClass - - aMethodNode - withParseNodeIncluding: self startIndex - do: [ :nodeUnderCursor | self rename: nodeUnderCursor in: aSelectedClass at: aMethodNode selector ] - ifAbsent: [ - self startIndex <= aMethodNode selectorLastPosition - ifTrue: [ self ifRenameCanBeAppliedDo: [ self renameSelectorFor: aMethodNode selector in: aSelectedClass ]] - ifFalse: [ morph flash ]] - - -! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/12/2019 22:15:38' prior: 50443794! - renameSelectorFor: aSelector in: aClassToRefactor - - RefactoringApplier renameSelectorApplier createAndValueHandlingExceptionsOn: model textProvider for: aSelector in: aClassToRefactor ! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/15/2019 13:47:20' prior: 50443816! - withMethodNodeAndClassDo: aBlock ifErrorsParsing: anErrorBlock - - | selectedClass methodNode | - - selectedClass := self codeProvider selectedClassOrMetaClass. - methodNode := [ selectedClass methodNodeFor: model actualContents ] on: Error do: [ :anError | ^ anErrorBlock value: anError ]. - - ^aBlock value: methodNode value: selectedClass.! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 3/12/2019 22:15:54' prior: 50443911! - renameSelector - - model selectedMessageName ifNotNil: [ :oldSelector | - RefactoringApplier renameSelectorApplier createAndValueHandlingExceptionsOn: model for: oldSelector in: model selectedClassOrMetaClass ]! ! -!ChangeSelectorSendersStepWindow methodsFor: 'actions' stamp: 'HAW 3/14/2019 18:08:17' prior: 50438437! - changeRequestSenders - - applier sendersFrom: model messageList - ! ! -!AddInstanceVariable methodsFor: 'accessing' stamp: 'HAW 3/14/2019 09:11:51' prior: 50438532! - classToRefactor - - ^classToRefactor ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 3/12/2019 22:25:49' prior: 50441525! - askForImplementosAndSenders - - self - askScope; - initializeImplementorsAndSenders; - calculateImplementorsAndSenders; - startWizard ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 3/12/2019 22:25:29' prior: 50441542! -calculateImplementorsAndSenders - - scopeChoice = 1 ifTrue: [ ^self implementorsAndSendersForClass ]. - scopeChoice = 2 ifTrue: [ ^self implementorsAndSendersForHierarchy ]. - scopeChoice = 3 ifTrue: [ ^self implementorsAndSendersInCategory ]. - scopeChoice = 4 ifTrue: [ ^self implementorsAndSendersInCategoryAndHierarchy ]. - scopeChoice = 5 ifTrue: [ ^self implementorsAndSendersInSystem ]. - - self error: 'Unknown scope option' - - ! ! -!ChangeSelectorApplier class methodsFor: 'instance creation' stamp: 'HAW 3/15/2019 15:02:08' prior: 50441773! - on: aBrowser for: aSelector in: aClass - - self assertCanApplyRefactoringFor: aSelector in: aClass. - - ^self new initializeOn: aBrowser for: aSelector in: aClass - ! ! -!RenameSelectorApplier methodsFor: 'refactoring - creation' stamp: 'HAW 8/18/2018 16:56:24'! - createRefactoring - - ^self refactoringClass from: oldSelector to: newSelector implementors: implementors senders: senders. - ! ! - -RenameSelector class removeSelector: #addActualImplementorsOf:in:to:andActualSendersTo:inSystem:! - -ChangeSelector class removeSelectorIfInBaseSystem: #addActualImplementorsOf:in:to:andActualSendersTo:inSystem:! - -SmalltalkEditor removeSelector: #rename:in:! - -SmalltalkEditor removeSelector: #rename:in:! - -SmalltalkEditor removeSelector: #renameSelectorOf:in:! - -Object subclass: #RefactoringApplier - instanceVariableNames: 'requestExitBlock refactoring changes' - classVariableNames: 'Appliers' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RefactoringApplier category: #'Tools-Refactoring'! -Object subclass: #RefactoringApplier - instanceVariableNames: 'requestExitBlock refactoring changes' - classVariableNames: 'Appliers' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier initialize! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3687-LiveTypingRefactoringSupport-HernanWilkinson-2019Mar12-21h51m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3685] on 26 March 2019 at 7:58:13 pm'! - -Refactoring subclass: #RenameGlobal - instanceVariableNames: 'system oldName newName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameGlobal category: #'Tools-Refactoring'! -Refactoring subclass: #RenameGlobal - instanceVariableNames: 'system oldName newName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #RenameGlobalApplier - instanceVariableNames: 'browser newName oldName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameGlobalApplier category: #'Tools-Refactoring'! -RefactoringApplier subclass: #RenameGlobalApplier - instanceVariableNames: 'browser newName oldName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringPrecondition subclass: #NewGlobalPrecondition - instanceVariableNames: 'system newName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #NewGlobalPrecondition category: #'Tools-Refactoring'! -RefactoringPrecondition subclass: #NewGlobalPrecondition - instanceVariableNames: 'system newName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!Browser methodsFor: 'refactorings' stamp: 'HAW 3/26/2019 19:11:22'! - renameGlobal - - (RenameGlobalApplier on: self for: '') value! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/26/2019 18:42:51'! - renameGlobalOn: aBrowser for: anOldName - - (RenameGlobalApplier on: aBrowser for: anOldName) value! ! -!RenameGlobal methodsFor: 'applying' stamp: 'HAW 3/26/2019 18:34:07'! - apply - - | renamedReferences | - - system at: newName put: (system at: oldName). - renamedReferences := self renameReferences. - system removeKey: oldName. - - ^renamedReferences - ! ! -!RenameGlobal methodsFor: 'initialization' stamp: 'HAW 3/26/2019 17:55:21'! - initializeFrom: anOldName to: aNewName in: aSystem - - oldName := anOldName. - newName := aNewName. - system := aSystem. - - ! ! -!RenameGlobal methodsFor: 'accessing' stamp: 'HAW 3/26/2019 17:56:01'! - newName - - ^newName ! ! -!RenameGlobal methodsFor: 'accessing' stamp: 'HAW 3/26/2019 18:03:41'! - referencesToOldName - - ^system allCallsOn: oldName! ! -!RenameGlobal methodsFor: 'applying - private' stamp: 'HAW 3/26/2019 17:55:21'! - newSourceCodeOf: aCompiledMethod - - | newSource | - - newSource := aCompiledMethod sourceCode copyReplacing: (self rangesToReplaceOf: aCompiledMethod) with: newName. - - ^newSource! ! -!RenameGlobal methodsFor: 'applying - private' stamp: 'HAW 3/26/2019 18:12:45'! - rangesForLiteralOf: methodNode - - | literalRanges | - - literalRanges := methodNode positionsForLiteralNode: oldName ifAbsent: [ #() ]. - literalRanges := literalRanges collect: [ :aRange | aRange first + 1 to: aRange last ]. - - ^literalRanges ! ! -!RenameGlobal methodsFor: 'applying - private' stamp: 'HAW 3/26/2019 18:12:31'! - rangesForLiteralVariableOf: methodNode - - ^methodNode positionsForLiteralVariableNode: oldName ifAbsent: [ #() ] - ! ! -!RenameGlobal methodsFor: 'applying - private' stamp: 'HAW 3/26/2019 17:14:05'! - rangesToReplaceOf: aCompiledMethod - - | methodNode ranges | - - methodNode := aCompiledMethod methodNode. - ranges := SortedCollection sortBlock: [ :leftRange :rightRange | leftRange first < rightRange first ]. - - ranges addAll: (self rangesForLiteralVariableOf: methodNode). - ranges addAll: (self rangesForLiteralOf: methodNode). - - ^ranges ! ! -!RenameGlobal methodsFor: 'applying - private' stamp: 'HAW 3/26/2019 19:36:06'! - references: aMethodReference classVarNamed: aName - - ^aMethodReference actualClass theNonMetaClass definesClassVariableNamedInHierarchy: aName ! ! -!RenameGlobal methodsFor: 'applying - private' stamp: 'HAW 3/26/2019 18:25:27'! - referencesOldName: aMethodReference - - ^self references: aMethodReference classVarNamed: oldName ! ! -!RenameGlobal methodsFor: 'applying - private' stamp: 'HAW 3/26/2019 18:34:48'! - rejectReferencesToClassVariablesFrom: references - - ^references reject: [ :aMethodReference | self referencesOldName: aMethodReference ].! ! -!RenameGlobal methodsFor: 'applying - private' stamp: 'HAW 3/26/2019 17:14:05'! - renameReference: aReferencingMethod - - | newSource | - - newSource := self newSourceCodeOf: aReferencingMethod. - aReferencingMethod methodClass compile: newSource ! ! -!RenameGlobal methodsFor: 'applying - private' stamp: 'HAW 3/26/2019 18:51:20'! - renameReferences - - | references | - - references := self referencesToOldName. - references := self rejectReferencesToClassVariablesFrom: references. - references do: [ :aReference | self renameReference: aReference compiledMethod ]. - - ^references! ! -!RenameGlobal class methodsFor: 'pre-conditions' stamp: 'HAW 3/26/2019 19:17:48'! - assert: anOldName isDefinedIn: aSystem - - (aSystem bindingOf: anOldName) ifNil: [ self signalGlobalNotDefined: anOldName ]! ! -!RenameGlobal class methodsFor: 'pre-conditions' stamp: 'HAW 3/26/2019 17:20:18'! - assert: anOldName isNotEqualTo: aNewName - - anOldName = aNewName ifTrue: [ self signalNewNameEqualsOldName]! ! -!RenameGlobal class methodsFor: 'pre-conditions' stamp: 'HAW 3/26/2019 17:18:11'! -assertIsNotClass: anOldName - - (Smalltalk classNamed: anOldName) ifNotNil: [ self signalGlobalToRenameCanNotBeClass]! ! -!RenameGlobal class methodsFor: 'pre-conditions' stamp: 'HAW 3/26/2019 19:50:14'! - assertIsNotEmpty: anOldName - - anOldName isEmpty ifTrue: [ self signalOldNameIsEmpty ]! ! -!RenameGlobal class methodsFor: 'pre-conditions' stamp: 'HAW 3/26/2019 17:39:50'! - newGlobalPreconditionClass - - ^NewGlobalPrecondition ! ! -!RenameGlobal class methodsFor: 'exceptions' stamp: 'HAW 3/26/2019 19:18:54'! - errorMessageForGlobalNotDefined: anOldName - - ^ anOldName asString, ' is not defined as global variable'! ! -!RenameGlobal class methodsFor: 'exceptions' stamp: 'HAW 3/26/2019 17:18:56'! - globalCanNotBeClassErrorMessage - - ^'Global to rename can not be a class'! ! -!RenameGlobal class methodsFor: 'exceptions' stamp: 'HAW 3/26/2019 18:56:16'! - newNameEqualsOldNameErrorMessage - - ^'New name is equal to the old one'! ! -!RenameGlobal class methodsFor: 'exceptions' stamp: 'HAW 3/26/2019 19:51:21'! - oldNameCanNotBeEmptyErrorMessage - - ^'Global variable name to rename can not be empty'! ! -!RenameGlobal class methodsFor: 'exceptions' stamp: 'HAW 3/26/2019 19:18:19'! - signalGlobalNotDefined: anOldName - - self refactoringError: (self errorMessageForGlobalNotDefined: anOldName)! ! -!RenameGlobal class methodsFor: 'exceptions' stamp: 'HAW 3/26/2019 17:18:37'! - signalGlobalToRenameCanNotBeClass - - self refactoringError: self globalCanNotBeClassErrorMessage! ! -!RenameGlobal class methodsFor: 'exceptions' stamp: 'HAW 3/26/2019 17:14:05'! - signalNewNameEqualsOldName - - self refactoringError: self newNameEqualsOldNameErrorMessage.! ! -!RenameGlobal class methodsFor: 'exceptions' stamp: 'HAW 3/26/2019 19:50:54'! - signalOldNameIsEmpty - - self refactoringError: self oldNameCanNotBeEmptyErrorMessage! ! -!RenameGlobal class methodsFor: 'instance creation' stamp: 'HAW 3/26/2019 17:15:55'! - from: anOldName to: aNewName - - ^self from: anOldName to: aNewName in: Smalltalk - ! ! -!RenameGlobal class methodsFor: 'instance creation' stamp: 'HAW 3/26/2019 19:48:41'! - from: anOldName to: aNewName in: aSystem - - self assertIsNotEmpty: anOldName. - self assert: anOldName isDefinedIn: aSystem. - self assertIsNotClass: anOldName. - self assert: anOldName isNotEqualTo: aNewName. - self newGlobalPreconditionClass valueFor: aNewName in: aSystem. - - ^self new initializeFrom: anOldName to: aNewName in: aSystem ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 3/26/2019 17:36:48'! - sendersFrom: methodReferences - - ^ methodReferences collect: [:aMethodReference | aMethodReference compiledMethod ]! ! -!RenameSelectorApplier class methodsFor: 'instance creation' stamp: 'HAW 3/26/2019 19:56:53'! - createAndValueHandlingExceptionsOn: aModel of: aMessageNode in: aSelectedClass at: aSelectedSelector - - ^self createAndValueHandlingExceptionsOn: aModel for: aMessageNode selector key in: aSelectedClass -! ! -!RenameGlobalApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 3/26/2019 18:53:42'! - askNewName - - newName := self request: 'Enter new name:' initialAnswer: oldName asString. - newName := newName withBlanksTrimmed asSymbol. - ! ! -!RenameGlobalApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 3/26/2019 19:13:49'! - askOldName - - oldName := self request: 'Enter global name to rename:' initialAnswer: oldName. - oldName := oldName withBlanksTrimmed asSymbol. - ! ! -!RenameGlobalApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 3/26/2019 19:13:00'! - requestRefactoringParameters - - oldName isEmpty ifTrue: [ self askOldName ]. - self askNewName! ! -!RenameGlobalApplier methodsFor: 'refactoring - creation' stamp: 'HAW 3/26/2019 18:36:05'! - createRefactoring - - ^RenameGlobal from: oldName to: newName in: Smalltalk ! ! -!RenameGlobalApplier methodsFor: 'refactoring - changes' stamp: 'HAW 3/26/2019 18:35:42'! - openChangedMethods - - changes ifNotEmpty: [ - MessageSetWindow openMessageList: changes label: 'Renamed references' autoSelect: newName ] -! ! -!RenameGlobalApplier methodsFor: 'refactoring - changes' stamp: 'HAW 3/26/2019 18:36:56'! - showChanges - - self openChangedMethods -! ! -!RenameGlobalApplier methodsFor: 'initialization' stamp: 'HAW 3/26/2019 18:37:12'! - initializeOn: aBrowser for: anOldName - - browser := aBrowser. - oldName := anOldName. - ! ! -!RenameGlobalApplier class methodsFor: 'instance creation' stamp: 'HAW 3/26/2019 19:12:35'! - on: aBrowser - - ^self on: aBrowser for: ''! ! -!RenameGlobalApplier class methodsFor: 'instance creation' stamp: 'HAW 3/26/2019 18:37:50'! - on: aBrowser for: anOldName - - ^self new initializeOn: aBrowser for: anOldName! ! -!NewGlobalPrecondition methodsFor: 'evaluating' stamp: 'HAW 3/26/2019 17:29:43'! - value - - self - assertNewNameIsNotEmpty; - assertNewNameIsSymbol; - assertNewNameHasNoSeparators; - assertNewNameDoesNotExistInSystem. - -! ! -!NewGlobalPrecondition methodsFor: 'evaluating - private' stamp: 'HAW 3/26/2019 17:26:43'! - assertNewNameDoesNotExistInSystem - - system at: newName ifPresent: [ :value | - value isBehavior - ifTrue: [ self signalClassAlreadyExists ] - ifFalse: [ self signalGlobalAlreadyExists ]].! ! -!NewGlobalPrecondition methodsFor: 'evaluating - private' stamp: 'HAW 3/26/2019 17:27:22'! - assertNewNameHasNoSeparators - - (newName anySatisfy: [:aChar | aChar isSeparator]) - ifTrue: [ self signalNewNameCanNotHaveSeparators ]! ! -!NewGlobalPrecondition methodsFor: 'evaluating - private' stamp: 'HAW 3/26/2019 17:28:35'! - assertNewNameIsNotEmpty - - newName withBlanksTrimmed isEmpty ifTrue: [ self signalNewNameCanNotBeEmpty]! ! -!NewGlobalPrecondition methodsFor: 'evaluating - private' stamp: 'HAW 3/26/2019 17:29:43'! - assertNewNameIsSymbol - - newName isSymbol ifFalse: [ self signalNewNameMustBeSymbol]! ! -!NewGlobalPrecondition methodsFor: 'initialization' stamp: 'HAW 3/26/2019 17:37:17'! - initializeFor: aNewName in: aSystem - - newName := aNewName. - system := aSystem. -! ! -!NewGlobalPrecondition methodsFor: 'exceptions' stamp: 'HAW 3/26/2019 17:26:07'! - signalClassAlreadyExists - - self refactoringError: (self class errorMessageForAlreadyExistClassNamed: newName).! ! -!NewGlobalPrecondition methodsFor: 'exceptions' stamp: 'HAW 3/26/2019 17:26:07'! - signalGlobalAlreadyExists - - self refactoringError: (self class errorMessageForAlreadyExistGlobalNamed: newName)! ! -!NewGlobalPrecondition methodsFor: 'exceptions' stamp: 'HAW 3/26/2019 17:28:54'! - signalNewNameCanNotBeEmpty - - self refactoringError: self class newNameCanNotBeEmptyErrorMessage! ! -!NewGlobalPrecondition methodsFor: 'exceptions' stamp: 'HAW 3/26/2019 17:27:57'! - signalNewNameCanNotHaveSeparators - - self refactoringError: self class newNameCanNotHaveSeparatorsErrorMessage ! ! -!NewGlobalPrecondition methodsFor: 'exceptions' stamp: 'HAW 3/26/2019 17:22:52'! - signalNewNameMustBeSymbol - - self refactoringError: self class newNameMustBeSymbolErrorMessage.! ! -!NewGlobalPrecondition class methodsFor: 'error messages' stamp: 'HAW 3/26/2019 17:26:34'! - errorMessageForAlreadyExistClassNamed: aNewName - - ^'Class named ', aNewName, ' already exist'! ! -!NewGlobalPrecondition class methodsFor: 'error messages' stamp: 'HAW 3/26/2019 17:26:21'! - errorMessageForAlreadyExistGlobalNamed: aNewName - - ^'There is already a global variable named ', aNewName ! ! -!NewGlobalPrecondition class methodsFor: 'error messages' stamp: 'HAW 3/26/2019 17:29:00'! - newNameCanNotBeEmptyErrorMessage - - ^'New name can not be empty'! ! -!NewGlobalPrecondition class methodsFor: 'error messages' stamp: 'HAW 3/26/2019 17:28:07'! - newNameCanNotHaveSeparatorsErrorMessage - - ^'New name can not have separators'! ! -!NewGlobalPrecondition class methodsFor: 'error messages' stamp: 'HAW 3/26/2019 17:30:05'! - newNameMustBeSymbolErrorMessage - - ^'New name must be a symbol'! ! -!NewGlobalPrecondition class methodsFor: 'instance creation' stamp: 'HAW 3/26/2019 17:38:25'! - for: aNewName in: aSystem - - ^self new initializeFor: aNewName in: aSystem ! ! -!NewGlobalPrecondition class methodsFor: 'evaluation' stamp: 'HAW 3/26/2019 17:40:04'! - valueFor: aNewName in: aSystem - - ^(self for: aNewName in: aSystem) value! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/26/2019 18:57:11' prior: 50450079! - rename: aNodeUnderCursor in: aSelectedClass at: aSelectedSelector - - aNodeUnderCursor isTempOrArg ifTrue: [ ^self renameTemporary: aNodeUnderCursor name ]. - - self ifRenameCanBeAppliedDo: [ - aNodeUnderCursor isMessageNode ifTrue: [ ^ self renameSelectorOf: aNodeUnderCursor in: aSelectedClass at: aSelectedSelector ]. - aNodeUnderCursor isInstanceVariableNode ifTrue: [ ^ self renameInstanceVariableOn: self codeProvider for: aNodeUnderCursor name at: aSelectedClass ]. - aNodeUnderCursor isLiteralVariableNode ifTrue: [ | variableName | - variableName := aNodeUnderCursor key key. - (Smalltalk classNamed: variableName) ifNotNil: [ :classToRename | ^self renameClassOn: self codeProvider for: classToRename ]. - (Smalltalk bindingOf: variableName) ifNotNil: [ ^self renameGlobalOn: self codeProvider for: variableName ] ]. - - ^morph flash ]! ! -!InsertSuperclass class methodsFor: 'instance creation' stamp: 'HAW 3/3/2019 09:11:31' prior: 50440559! - to: aClass named: aSuperclassName in: aSystem undeclared: anUndeclared - - self newClassPreconditionClass valueFor: aSuperclassName in: aSystem undeclared: anUndeclared. - - ^self new initializeTo: aClass theNonMetaClass named: aSuperclassName ! ! -!RenameClass class methodsFor: 'exceptions' stamp: 'HAW 3/26/2019 18:56:37' prior: 50440840! - newNameEqualsOldNameErrorMessage - - ^'New class name is equal to the old one'! ! -!RenameClass class methodsFor: 'instance creation' stamp: 'HAW 8/13/2018 18:45:15' prior: 50440870! - from: aClass to: aNewClassName in: aSystem undeclared: anUndeclaredDictionary - - self assertIsNotMeta: aClass. - self assert: aClass isNotNamed: aNewClassName. - self newClassPreconditionClass valueFor: aNewClassName in: aSystem undeclared: anUndeclaredDictionary. - - ^self new initializeFrom: aClass to: aNewClassName in: aSystem undeclared: anUndeclaredDictionary -! ! -!RefactoringMenues class methodsFor: 'browser menues' stamp: 'HAW 3/26/2019 19:09:35' prior: 50446044! - classRefactoringMenuOptions - - ^ `{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'rename class... (R)'. - #object -> #model. - #selector -> #renameClass. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'insert superclass...'. - #object -> #model. - #selector -> #insertSuperclass. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'safely remove class (x)'. - #object -> #model. - #selector -> #safelyRemoveClass. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'add inst var...'. - #selector -> #addInstVar. - #icon -> #listAddIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'rename inst var...'. - #selector -> #renameInstVar. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'remove inst var...'. - #selector -> #removeInstVar. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 40. - #label -> 'remove all unreferenced inst var...'. - #selector -> #removeAllUnreferencedInstVar. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'rename global...'. - #object -> #model. - #selector -> #renameGlobal. - #icon -> #saveAsIcon - } asDictionary. - }`. - ! ! -!NewClassPrecondition class methodsFor: 'evaluation' stamp: 'HAW 8/13/2018 17:37:20' prior: 50442722! - valueFor: aNewClassName in: aSystem undeclared: anUndeclaredDictionary - - ^(self for: aNewClassName in: aSystem undeclared: anUndeclaredDictionary) value! ! - -NewGlobalPrecondition class removeSelector: #errorMessageForNewClassIsUndeclared:! - -NewGlobalPrecondition class removeSelector: #for:in:undeclared:! - -NewGlobalPrecondition class removeSelector: #newClassCanNotHaveSeparatorsErrorMessage! - -NewGlobalPrecondition class removeSelector: #newClassNameCanNotBeEmptyErrorMessage! - -NewGlobalPrecondition class removeSelector: #newClassNameCanNotHaveSeparatorsErrorMessage! - -NewGlobalPrecondition class removeSelector: #newNameMustStartWithUppercaseLetterErrorMessage! - -NewGlobalPrecondition class removeSelector: #valueFor:in:undeclared:! - -NewGlobalPrecondition removeSelector: #assertNewClassNameDoesNotExistInSystem! - -NewGlobalPrecondition removeSelector: #assertNewClassNameHasNoSeparators! - -NewGlobalPrecondition removeSelector: #assertNewClassNameIsNotEmpty! - -NewGlobalPrecondition removeSelector: #assertNewClassNameIsNotUndeclaredInUndeclared! - -NewGlobalPrecondition removeSelector: #assertNewClassNameStartsWithUppercaseLetter! - -NewGlobalPrecondition removeSelector: #assertNewClassNameSymbol! - -NewGlobalPrecondition removeSelector: #assertNewNameSymbol! - -NewGlobalPrecondition removeSelector: #initializeFor:in:undeclared:! - -NewGlobalPrecondition removeSelector: #signalNewClassIsUndeclared! - -NewGlobalPrecondition removeSelector: #signalNewClassNameCanNotBeEmpty! - -NewGlobalPrecondition removeSelector: #signalNewClassNameCanNotHaveSeparators! - -NewGlobalPrecondition removeSelector: #signalNewNameMustStartWithUppercaseLetter! - -RenameGlobalApplier removeSelector: #askNewClassName! - -RenameGlobalApplier removeSelector: #informChangesToBrowser! - -RenameSelectorApplier class removeSelector: #createAndValueHandlingExceptionsOn:of:in:! - -RenameSelectorApplier class removeSelector: #createAndValueHandlingExceptionsOn:of:in:! - -RenameSelectorApplier removeSelector: #sendersFrom:! - -RenameSelectorApplier removeSelector: #sendersFrom:! - -RenameGlobal class removeSelector: #assert:isNotNamed:! - -RenameGlobal class removeSelector: #assertIsNotMeta:! - -RenameGlobal class removeSelector: #classToRenameCanNotBeMetaclassErrorMessage! - -RenameGlobal class removeSelector: #from:to:in:undeclared:! - -RenameGlobal class removeSelector: #newClassPreconditionClass! - -RenameGlobal class removeSelector: #signalClassToRenameCanNotBeMetaclass! - -RenameGlobal removeSelector: #initializeFrom:to:in:undeclared:! - -RenameGlobal removeSelector: #newClassName! - -RenameGlobal removeSelector: #referencesNewClassName:! - -RenameGlobal removeSelector: #referencesOldClassName:! - -RenameGlobal removeSelector: #referencesToOldClass! - -RenameGlobal removeSelector: #referencesToOldClassName! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3688-RenameGlobalRefactoring-HernanWilkinson-2019Mar24-20h01m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3688] on 27 March 2019 at 10:21:01 am'! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 3/26/2019 12:03:11' prior: 16844595! -arcTan: denominator - "Answer the angle in radians. - Implementation note: use sign in order to catch cases of negativeZero" - - ^self = 0.0 - ifTrue: [denominator sign >= 0 - ifTrue: [ 0.0 ] - ifFalse: [ self sign >= 0 - ifTrue: [ Pi ] - ifFalse: [ Pi negated ]]] - ifFalse: [denominator = 0.0 - ifTrue: [self > 0.0 - ifTrue: [ Halfpi ] - ifFalse: [ Halfpi negated ]] - ifFalse: [denominator > 0.0 - ifTrue: [ (self / denominator) arcTan ] - ifFalse: [self > 0.0 - ifTrue: [ ((self / denominator) arcTan) + Pi ] - ifFalse: [ ((self / denominator) arcTan) - Pi ]]]]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3689-ArcTanTweak-JuanVuletich-2019Mar27-10h20m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3689] on 28 March 2019 at 8:56:04 am'! -!Morph methodsFor: 'events' stamp: 'jmv 3/28/2019 08:54:29' prior: 50449187! - mouseLeave: evt - "Handle a mouseLeave event, meaning the mouse just left my bounds with no button pressed." - Preferences focusFollowsMouse - ifTrue: [evt hand releaseKeyboardFocus: self]. - "Allow instances to dynamically use properties for handling common events." - self - valueOfProperty: #mouseLeave: - ifPresentDo: [ :handler | handler value: evt ].! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3690-FixFocusHandlingIfClickToFocusIsOn-JuanVuletich-2019Mar28-08h55m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3690] on 5 April 2019 at 5:29:12 pm'! -!Float commentStamp: 'jmv 4/5/2019 17:21:41' prior: 50425186! - A note About Floating Point numbers and Floating Point Arithmetic. - -The following is not specific to Cuis or Smalltalk at all. This is about the properties of Float numbers in any computer implementation. - -If you haven't done so already, read https://en.wikipedia.org/wiki/Floating-point_arithmetic - -But if you find the Wikipedia article too detailed, or hard to read, then try http://fabiensanglard.net/floating_point_visually_explained/ (get past "How Floating Point are usually explained" and read "A different way to explain..."). - -Other great reads are: - "Why don't my numbers add up?": - http://floating-point-gui.de/ -and - "What Every Computer Scientist Should Know About Floating-Point Arithmetic": - http://docs.oracle.com/cd/E19957-01/806-3568/ncg_goldberg.html -and also maybe - "Comparing floating point numbers" - https://randomascii.wordpress.com/2012/02/25/comparing-floating-point-numbers-2012-edition/ - -Now that you read them, and we are on the same boat, some further comments (from jmv): - -Floats are (conceptually) approximate real numbers. That's why trig and other trascendental functions always answer Floats. That's why it is ok to round the result of operations. That's why Float is considered more general than Fraction in ST-80 and most Smalltalks. So, when we have a Float value, we must not think about it as a Rational but as a Real (actually as some unknown Real that could hopefully be close to the Rational we can actually represent). Keep this in mind when dealing with Floats, and especially avoid comparing them for equality. - -When doing mixed operations with Floats and Fractions, Cuis, as most other Smalltalks, converts all values to Floats. Some other systems, including Pharo Smalltalk, Scheme and Lisp have two rules: when the answer is a Number, they convert to Float. But when the answer is a boolean (#<, #=, #<=, etc.) they convert to Fraction. We think this is a mistake. There should never be implicit conversions from Float to Fraction. Fractions are to hold exact values, and people expect Fractions to be exact. On the other hand, Floats are to hold approximations (and people should be aware of that!!). But an implicit conversion from Float to Fraction would give a Fraction that should not be considered an exact value (the value comes from an inexact Float), but that knowledge is lost, as it is an instance of Fraction. - -If you want exact arithmetic, usual mathematical properties (like transitivity of equality), can live in the limited world of Rational numbers, and can afford a slight performance penalty, use Fraction instead. Avoid trascendental functions and never convert to Float. - -In any case, most numeric computation is done on Float numbers. There are good reasons for that. One is that in most cases we don't need an exact answer. And in many cases we can't really have it: the inputs to algorithms already have a limited precision, or they use trascendental functions. And even when exact arithmetic possible, if we are doing sound synthesis, 24 bits of resolution is enough. For image processing and graphics, the result is never more than 16 bits per channel. So, these fields don't really need 64 bit Doubles. 32 bit Floats are enough. Other fields do need 64 bit Doubles, like physics simulations and geometry. Games usually prefer special, faster 32 bit Float operations in GPUs that have greater errors but are faster. - -There are some things that can be done to increase the confidence you can have on Float results. One is to do an error propagation analysis on the code you are running. This is not easy, but it is done for any widely used numerical method. Then, you can know real bounds and/or estimates of the errors made. So, understanding your inputs and your algorithms (for example error propagation, condition number, numeric stability), and using Float number if appropriate, is the usual advice. - -Perhaps you have heard about "interval arithmetic". It is a bit better than simple Float, but doesn't really fix the problems. - -The ultimate solution is to do Monte Carlo analysis, with random perturbation of inputs. After the Monte Carlo run, it is needed to do statistical analysis of possible correlations between the distributions of the random noise added to imputs and the result of the algorithm. - -Additional food for thought: http://www.cs.berkeley.edu/~wkahan/Mindless.pdf . According to this, doing Monte Carlo as described above attacks a slightly different problem. This might be yet another reason (besides performance) to try something like the next paragraph. I (jmv) came up with it, and I don't really know if it has been described and or tried before or not. Mhhh. Maybe a defensive publication is in order. - -A possibility that could be a practical solution, being much cheaper than Monte Carlo, but better than interval arithmetic, is to represent each value by 2 Floats: an estimation of the real value (i.e. an estimation of the mean value of the distribution of the corresponding Monte Carlo result), and an estimation of the error (i.e. an estimation of the standard deviation of the corresponding Monte Carlo result). Or perhaps even 3 of them. In addition to the estimation of the real value and an estimation of the error, we could add a hard bound on the error. In many cases it will be useless, because the error can not really be bound. But in those cases where it is possible to bound it, applications could really know about the quality of computed values. - -======================================================================= - -My instances represent IEEE 754 floating-point double-precision numbers. They have about 16 decimal digits of accuracy and their range is between plus and minus 10^307. Some valid examples are: - - 8.0 13.3 0.3 2.5e6 1.27e-30 1.27e-31 -12.987654e12 - -Mainly: no embedded blanks, little e for tens power, and a digit on both sides of the decimal point. It is actually possible to specify a radix for Float constants. This is great for teaching about numbers, but may be confusing to the average reader: - - 3r20.2 --> 6.66666666666667 - 8r20.2 --> 16.25 - -If you don't have access to the definition of IEEE754, you can figure out what is going on by printing various simple values in Float hex. It may help you to know that the basic format is... - sign 1 bit - exponent 11 bits with bias of 1023 (16r3FF), substracted to produce an actual exponent in the range -1022 .. +1023 - - 16r000: - significand = 0: Float zero - significand ~= 0: Denormal number (actual exponent is -1022, not -1023. No implicit leading '1' bit in mantissa) - - 16r7FF: - significand = 0: Infinity - significand ~= 0: Not A Number (NaN) representation - mantissa 53 bits, but only 52 are stored (20 in the first word, 32 in the second). This is because a normalized mantissa, by definition, has a 1 to the right of its floating point, and IEEE 754 omits this redundant bit to gain an extra bit of precision instead. People talk about the mantissa without its leading one as the FRACTION, and with its leading 1 as the SIGNFICAND. - -The single-precision format is... - sign 1 bit - exponent 8 bits with bias of 127 (16r7F, substracted to produce an actual exponent in the range -126 .. +127 - - 16r00: - significand = 0: Float zero - significand ~= 0: Denormal number (actual exponent is -126, not -127. No implicit leading '1' bit in mantissa) - - 16rFF: - significand = 0: Infinity - significand ~= 0: Not A Number (NaN) representation - mantissa 24 bits, but only 23 are stored -This format is used in FloatArray (qv), and much can be learned from the conversion routines, Float asIEEE32BitWord, and Float class fromIEEE32Bit:. - -You might also check https://en.wikipedia.org/wiki/IEEE_754_revision - -Other great reads (covering broader but interesting issues): -https://randomascii.wordpress.com/2013/07/16/floating-point-determinism/ -http://www.ima.umn.edu/2010-2011/W1.10-14.11/activities/Leeser-Miriam/Leeser-GPU-IMA-Jan2011.pdf! -!Number methodsFor: 'testing' stamp: 'jmv 4/5/2019 10:02:36'! - isFinite - ^ true! ! -!Complex methodsFor: 'arithmetic' stamp: 'jmv 4/5/2019 09:09:44'! - complexConjugate - "Return the complex conjugate of this complex number." - - ^self class real: real imaginary: imaginary negated! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 4/5/2019 16:19:44' prior: 50421763! -predecessor - "Answer the largest Float smaller than self" - - self isFinite ifFalse: [ - (self isNaN or: [self negative]) ifTrue: [^self]. - ^Float fmax]. - self signBit = 1 ifTrue: [ "Negative or -0.0" - ^ self nextAwayFromZero ]. - self = 0.0 ifTrue: [ - ^ -0.0 ]. - ^ self nextTowardsZero.! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 4/5/2019 16:11:39' prior: 50425712! - signBit - " - Actual sigh bit part of the floating point representation. - 0 means positive number or 0.0 - 1 means negative number or -0.0 - Just extract the bit. Do not correct denormals. Do not subtract bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0. 0.0. -0.0} do: [ :f | - { f. f signBit. f signPart. f sign } print ]. - " - - ^ self partBits: [ :signBit :exponentBits :mantissaBits | signBit ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 4/5/2019 16:14:21' prior: 50414520! - signPart - "The sign of the mantissa. - 1 means positive number or 0.0 - -1 means negative number or -0.0 - See #mantissaPart and #exponentPart" - " - | f | - f := -2.0. - (f signPart * f mantissaPart * (2 raisedToInteger: f exponentPart-52)) asFloat. - " - ^self partValues: [ :sign :exponent :mantissa | sign ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 4/5/2019 16:18:03' prior: 50421777! - successor - "Answer the smallest Float greater than self" - - self isFinite ifFalse: [ - (self isNaN or: [self positive]) ifTrue: [^self]. - ^Float fmax negated]. - self signBit = 0 ifTrue: [ - ^ self nextAwayFromZero ]. - self = -0.0 ifTrue: [ - ^ 0.0 ]. - ^ self nextTowardsZero.! ! -!Float methodsFor: 'testing' stamp: 'jmv 4/5/2019 16:14:46' prior: 50425433! - sign - "Answer 1 if the receiver is greater than 0, -1 if less than 0, else 0. - Handle IEEE754 negative-zero by reporting a sign of -1 - Warning!! This makes Float negativeZero the only number in the system such that - x sign negated = x negated sign - evaluates to false!! - This precludes the simpler implementation in #signPart - 0.0 sign -> 0 - 0.0 signPart -> 1 - -0.0 sign -> -1 - -0.0 signPart -> -1 - " - - "Negative number or -0.0" - self signBit = 1 ifTrue: [ ^ -1 ]. - - "Zero" - self = 0.0 ifTrue: [ ^ 0 ]. - - "Positive number otherwise" - ^ 1! ! -!Float class methodsFor: 'instance creation' stamp: 'jmv 4/5/2019 17:23:54' prior: 16845757! - fromIEEE32Bit: word - "Convert the given 32 bit word (which is supposed to be a positive 32bit value) from - a 32bit IEEE floating point representation into an actual Float object (being - 64bit wide). Should only be used for conversion in FloatArrays or likewise objects." - - | sign exponent mantissa exponentBits fractionBits answerFractionBits delta signBit answerExponent | - word negative ifTrue: [ ^ self error: 'Cannot deal with negative numbers' ]. - word = 0 ifTrue: [ ^ Float zero ]. - word = 16r80000000 ifTrue: [ ^Float negativeZero ]. - - signBit _ word bitAnd: 16r80000000. - sign _ (word bitShift: -31) = 0 ifTrue: [1] ifFalse: [-1]. - exponentBits _ (word bitShift: -23) bitAnd: 16rFF. - fractionBits _ word bitAnd: 16r7FFFFF. - - " Special cases: infinites and NaN" - exponentBits = 16rFF ifTrue: [ - fractionBits = 0 ifFalse: [ ^ Float nan ]. - ^ sign positive - ifTrue: [ Float infinity ] - ifFalse: [ Float negativeInfinity ]]. - - " Unbias exponent: 16r3FF is bias" - exponent _ exponentBits - 16r7F. - -"Older version." -false ifTrue: [ - " Replace omitted leading 1 in fraction if appropriate" - "If expPart = 0, I am +/-zero or a denormal value. In such cases, no implicit leading bit in mantissa" - exponentBits = 0 - ifTrue: [ - "gradual underflow (denormalized number) - There is no implied one, but the exponent is -126" - mantissa _ fractionBits. - answerExponent _ exponent + 1 ] - ifFalse: [ - mantissa _ fractionBits + 16r800000. - answerExponent _ exponent ]. - ^ (sign * mantissa) asFloat timesTwoPower: answerExponent - 23 ]. - - "Newer version" - exponentBits = 0 - ifTrue: [ - "gradual underflow (denormalized number) - Remove first bit of mantissa and adjust exponent" - delta := fractionBits highBit. - answerFractionBits := (fractionBits bitAnd: (1 bitShift: delta - 1) - 1) bitShift: 24 - delta. - answerExponent := exponent + delta - 23] - ifFalse: [ - answerFractionBits _ fractionBits. - answerExponent _ exponent ]. - - "Create new float" - ^ (self basicNew: 2) - basicAt: 1 put: ((signBit bitOr: (1023 + answerExponent bitShift: 20)) bitOr: (answerFractionBits bitShift: -3)); - basicAt: 2 put: ((answerFractionBits bitAnd: 7) bitShift: 29); - * 1.0. "reduce to SmallFloat64 if possible" - -" -Float fromIEEE32Bit: Float pi asIEEE32BitWord -(Float fromIEEE32Bit: Float pi asIEEE32BitWord ) = Float pi -(Float fromIEEE32Bit: Float pi asIEEE32BitWord ) - Float pi - -Float fromIEEE32Bit: (Float pi / 1e40) asIEEE32BitWord -(Float fromIEEE32Bit: (Float pi / 1e40) asIEEE32BitWord) = (Float pi / 1e40) -(Float fromIEEE32Bit: (Float pi / 1e40) asIEEE32BitWord) - (Float pi / 1e40) -"! ! -!Float class methodsFor: 'constants' stamp: 'jmv 4/5/2019 17:28:20' prior: 16845859! - denormalized - "Answer whether implementation supports denormalized numbers. - Denormalized numbers guarantees that the result x - y is non-zero when x !!= y." - - ^true! ! -!Float class methodsFor: 'constants' stamp: 'jmv 4/5/2019 17:28:36' prior: 16845897! - fminDenormalized - "Answer the minimum denormalized value representable. - Denormalized numbers guarantees that the result x - y is non-zero when x !!= y. - " - - ^1.0 timesTwoPower: MinValLogBase2! ! -!Float class methodsFor: 'constants' stamp: 'jmv 4/5/2019 16:58:02' prior: 16845942! - negativeZero - "Negative Zero is a very special number - -0.0 = 0.0 evaluates to true - Any function evaluated in -0.0 gives the same result as evaluated in 0.0. - Exceptions are: - 0.0 sign -> 0 - -0.0 sign -> -1 - - 0.0 negated -> -0.0 - -0.0 negated -> 0.0 - - 0.0 sqrt -> 0.0 - -0.0 sqrt -> -0.0 - The behavior of negative zero is specified in IEEE 754 - " - - ^ NegativeZero! ! -!BoxedFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 4/5/2019 16:32:47' prior: 50400397! - primSqrt - "Answer the square root of the receiver. - Optional. See Object documentation whatIsAPrimitive. - Note: - -0.0 primSqrt - -0.0 sqrt - both evaluate to -0.0 - " - - - ^Float nan! ! -!Complex methodsFor: 'arithmetic' stamp: 'jmv 4/5/2019 09:48:03' prior: 16822321! - * aNumber - "Answer the result of multiplying the receiver by aNumber." - | c d newReal newImaginary | - aNumber isComplex - ifTrue: [ - c _ aNumber real. - d _ aNumber imaginary. - newReal _ (real * c) - (imaginary * d). - newImaginary _ (real * d) + (imaginary * c) ] - ifFalse: [ - newReal _ real * aNumber. - newImaginary _ imaginary * aNumber ]. - ^ Complex real: newReal imaginary: newImaginary! ! -!Complex methodsFor: 'arithmetic' stamp: 'jmv 4/5/2019 09:48:36' prior: 16822337! - + aNumber - "Answer the sum of the receiver and aNumber." - ^ Complex - real: real + aNumber real - imaginary: imaginary + aNumber imaginary.! ! -!Complex methodsFor: 'arithmetic' stamp: 'jmv 4/5/2019 09:48:52' prior: 16822351! - - aNumber - "Answer the difference between the receiver and aNumber." - ^ Complex - real: real - aNumber real - imaginary: imaginary - aNumber imaginary.! ! -!Complex methodsFor: 'arithmetic' stamp: 'jmv 4/5/2019 10:34:02' prior: 16822366! - / aNumber - "Answer the result of dividing receiver by aNumber" - | c d newReal newImaginary s e f | - aNumber isComplex - ifTrue: [ - c _ aNumber real. - d _ aNumber imaginary. - e _ (real * c) + (imaginary * d). - e isFinite ifFalse: [ ^ self divideFastAndSecureBy: aNumber ]. - f _ (imaginary * c) - (real * d). - s _ (c * c) + (d * d). - (e isFloat and: [ s = 0.0 ]) ifTrue: [ ^ self divideFastAndSecureBy: aNumber ]. - newReal _ e / s. - newImaginary _ f / s ] - ifFalse: [ - newReal _ real / aNumber. - newImaginary _ imaginary / aNumber ]. - ^ Complex real: newReal imaginary: newImaginary! ! -!Complex methodsFor: 'arithmetic' stamp: 'jmv 4/5/2019 09:58:22' prior: 16822414! - divideFastAndSecureBy: aComplex - "Answer the result of dividing receiver by aNumber" - " Both operands are scaled to avoid arithmetic overflow. - This algorithm works for a wide range of values, and it needs only three divisions." - | r d newReal newImaginary | - aComplex real abs > aComplex imaginary abs - ifTrue: [ - r _ aComplex imaginary / aComplex real. - d _ r * aComplex imaginary + aComplex real. - newReal _ r * imaginary + real / d. - newImaginary _ r negated * real + imaginary / d ] - ifFalse: [ - r _ aComplex real / aComplex imaginary. - d _ r * aComplex real + aComplex imaginary. - newReal _ r * real + imaginary / d. - newImaginary _ r * imaginary - real / d ]. - ^ Complex - real: newReal - imaginary: newImaginary.! ! -!Complex methodsFor: 'comparing' stamp: 'jmv 4/5/2019 08:37:31' prior: 16822502! - = anObject - self == anObject ifTrue: [ ^ true ]. - anObject isNumber ifFalse: [^false]. - ^real = anObject real and: [ imaginary = anObject imaginary ]! ! -!Transcript class methodsFor: 'private' stamp: 'jmv 4/5/2019 16:11:01' prior: 50431468! - finishEntry - | newEntry | - self unfinishedEntrySize > 0 ifTrue: [ - newEntry _ unfinishedEntry contents. - unfinishedEntry reset. - lastDisplayPosition _ 0. - self addEntry: newEntry. - self display ].! ! - -Complex removeSelector: #conjugated! - -Complex removeSelector: #conjugated! - -Complex removeSelector: #divideSecureBy:! - -Complex removeSelector: #divideSecureBy:! - -Number removeSelector: #adaptToComplex:andSend:! - -Number removeSelector: #adaptToComplex:andSend:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3691-FloatAndComplexFixes-JuanVuletich-2019Apr05-08h34m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3690] on 5 April 2019 at 1:21:24 am'! - -"Change Set: 3691-CuisCore-AuthorName-2019Apr05-01h16m -Date: 5 April 2019 -Author: Nahuel Garbezza - -replace calls to messageListIndex: 0 by reformulateList which does that"! -!Browser methodsFor: 'message functions' stamp: 'RNG 4/5/2019 01:19:29' prior: 16792332! - removeMessage - "If a message is selected, create a Confirmer so the user can verify that - the currently selected message should be removed from the system. If - so, - remove it. If the Preference 'confirmMethodRemoves' is set to false, the - confirmer is bypassed." - | messageName confirmation | - selectedMessage ifNil: [ ^self ]. - messageName _ self selectedMessageName. - confirmation _ Smalltalk confirmRemovalOf: messageName on: self selectedClassOrMetaClass. - confirmation = 3 - ifTrue: [^ self]. - self selectedClassOrMetaClass removeSelector: self selectedMessageName. - self reformulateList. - self changed: #messageList. - self setClassOrganizer. - "In case organization not cached" - confirmation = 2 - ifTrue: [Smalltalk browseAllCallsOn: messageName]! ! -!Browser methodsFor: 'initialization' stamp: 'RNG 4/5/2019 01:19:09' prior: 16792851! - methodCategoryChanged - self changed: #messageCategoryList. - self changed: #messageList. - self triggerEvent: #annotationChanged. - self reformulateList! ! -!CodeFileBrowser methodsFor: 'removing' stamp: 'RNG 4/5/2019 01:19:43' prior: 16809136! - removeMessage - | messageName | - selectedMessage ifNil: [ ^self ]. - messageName _ self selectedMessageName. - (self selectedClass confirmRemovalOf: messageName) - ifFalse: [^ false]. - self selectedClassOrMetaClass removeMethod: self selectedMessageName. - self reformulateList. - self setClassOrganizer. - "In case organization not cached" - self changed: #messageList! ! -!CodeFileBrowser methodsFor: 'removing' stamp: 'RNG 4/5/2019 01:20:08' prior: 16809194! - removeUnmodifiedMethods - | theClass cat | - theClass := self selectedClassOrMetaClass. - theClass ifNil: [ ^self]. - cat := self selectedMessageCategoryName. - cat ifNil: [ ^self]. - theClass removeUnmodifiedMethods: (theClass organization listAtCategoryNamed: cat). - self reformulateList. - self changed: #messageList.! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'RNG 4/5/2019 01:18:54' prior: 50443869! - pushUpSelector - - model selectedMessageName ifNotNil: [ :selectedSelector | - (PushUpMethod for: model selectedClassOrMetaClass>>selectedSelector) apply. - model reformulateList. - model changed: #messageList. - model setClassOrganizer ].! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3692-Cleanup-NahuelGarbezza-2019Apr05-01h16m-RNG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3692] on 5 April 2019 at 5:52:57 pm'! -!CodeFileBrowser methodsFor: 'infoView' stamp: 'KenD 3/30/2019 02:10:13' prior: 16809357! - extraInfo - ^ (self - methodDiffFor: (self selectedClassOrMetaClass sourceCodeAt: self selectedMessageName) - class: self selectedClass - selector: self selectedMessageName - meta: self metaClassIndicated) hasAnyAttribute - ifTrue: [' - **MODIFIED**'] - ifFalse: [' - identical']! ! -!CodeFileBrowser methodsFor: 'infoView' stamp: 'KenD 3/30/2019 02:11:17' prior: 16809368! - infoViewContents - | theClass | - editSelection == #newClass ifTrue: [ - ^codeFile - ifNil: [ 'No file selected' ] - ifNotNil: [ codeFile summary ]]. - self selectedClass ifNil: [^ '']. - theClass _ Smalltalk at: self selectedClass name asSymbol ifAbsent: nil. - editSelection == #editClass ifTrue: [ - ^ theClass - ifNotNil: ['Class exists already in the system'] - ifNil: ['Class not in the system']]. - editSelection == #editMessage ifFalse: [^ '']. - (theClass notNil and: [self metaClassIndicated]) - ifTrue: [theClass _ theClass class]. - ^ (theClass notNil and: [theClass includesSelector: self selectedMessageName]) - ifTrue: ['Method already exists' , self extraInfo] - ifFalse: ['**NEW** Method not in the system']! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3693-CodeFileBrowserEnhancement-KenDickey-2019Apr05-17h52m-KenD.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3693] on 8 April 2019 at 9:47:04 am'! -!Float methodsFor: 'testing' stamp: 'jmv 4/8/2019 09:43:05'! - isDenormalized - "Denormalized numbers are only represented as BoxedFloat64" - - ^ false! ! -!BoxedFloat64 methodsFor: 'testing' stamp: 'jmv 4/8/2019 09:43:27'! - isDenormalized - "Denormalized numbers are only represented as BoxedFloat64" - - ^ self partBits: [ :signBit :exponentBits :mantissaBits | - exponentBits = 0 and: [mantissaBits ~=0]]! ! -!Complex methodsFor: 'arithmetic' stamp: 'jmv 4/5/2019 19:37:44'! - safeAbs - "Answer the distance of the receiver from zero (0 + 0 i). - Try avoiding overflow and/or underflow" - - | scale a b | - scale _ real abs max: imaginary abs. - scale = 0.0 - ifTrue: [^0.0]. - a _ real / scale. - b _ imaginary / scale. - ^((a * a) + (b * b)) sqrt * scale! ! -!Complex methodsFor: 'arithmetic' stamp: 'jmv 4/8/2019 09:44:54'! - safeDivideBy: aComplex - "Answer the result of dividing receiver by aNumber" - " Both operands are scaled to avoid arithmetic overflow. - This algorithm works for a wide range of values, and it needs only three divisions." - | r d newReal newImaginary | - aComplex real abs > aComplex imaginary abs - ifTrue: [ - r _ aComplex imaginary / aComplex real. - d _ r * aComplex imaginary + aComplex real. - newReal _ r * imaginary + real / d. - newImaginary _ r negated * real + imaginary / d ] - ifFalse: [ - r _ aComplex real / aComplex imaginary. - d _ r * aComplex real + aComplex imaginary. - newReal _ r * real + imaginary / d. - newImaginary _ r * imaginary - real / d ]. - ^ Complex - real: newReal - imaginary: newImaginary.! ! -!Complex methodsFor: 'arithmetic' stamp: 'jmv 4/8/2019 09:45:16' prior: 50451539! - / aNumber - "Answer the result of dividing receiver by aNumber" - | c d newReal newImaginary s e f | - aNumber isComplex - ifTrue: [ - c _ aNumber real. - d _ aNumber imaginary. - e _ (real * c) + (imaginary * d). - e isFinite ifFalse: [ ^ self safeDivideBy: aNumber ]. - f _ (imaginary * c) - (real * d). - s _ (c * c) + (d * d). - (e isFloat and: [ s = 0.0 ]) ifTrue: [ ^ self safeDivideBy: aNumber ]. - newReal _ e / s. - newImaginary _ f / s ] - ifFalse: [ - newReal _ real / aNumber. - newImaginary _ imaginary / aNumber ]. - ^ Complex real: newReal imaginary: newImaginary! ! -!Complex methodsFor: 'arithmetic' stamp: 'jmv 4/5/2019 19:56:25' prior: 16822382! -abs - "Answer the distance of the receiver from zero (0 + 0 i)." - - | absSquared | - absSquared _ (real * real) + (imaginary * imaginary). - absSquared isFloat ifTrue: [ - absSquared < Float fminNormalized ifTrue: [ - ^ self safeAbs ]. - absSquared isFinite ifFalse: [ - ^ self safeAbs ]]. - ^absSquared sqrt! ! - -Complex removeSelector: #absSecure! - -Complex removeSelector: #absSecure! - -Complex removeSelector: #divideFastAndSecureBy:! - -Complex removeSelector: #divideFastAndSecureBy:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3694-FloatAndComplexTweaks-JuanVuletich-2019Apr08-09h42m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3694] on 8 April 2019 at 2:43:51 pm'! -!Character methodsFor: 'accessing' stamp: 'jmv 4/8/2019 14:19:18'! - leadingChar - "See Squeak if curious." - ^ 0! ! -!AffineTransformation class methodsFor: 'instance creation' stamp: 'jmv 4/8/2019 14:39:23' prior: 16778911! - transformFrom: originalBounds to: resultBounds - "Answer a Transform to translate coordinates inside originalBounds into coordinates inside resultBounds. - Parameters are instances of Rectangle. Therefore, there's no rotation involved, just scale and offset." - - ^((self withTranslation: (resultBounds topLeft + resultBounds bottomRight / 2.0)) composedWith: - (self withPointScale: (resultBounds extent / originalBounds extent) asFloatPoint)) composedWith: - (self withTranslation: (originalBounds topLeft + originalBounds bottomRight / 2.0) negated)! ! - -StrikeFont removeSelector: #maxAscii! - -StrikeFont removeSelector: #maxAscii! - -StrikeFont removeSelector: #minAscii! - -StrikeFont removeSelector: #minAscii! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3695-Tweaks-JuanVuletich-2019Apr08-14h11m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3695] on 16 April 2019 at 10:34:27 am'! -!IndentingListItemMorph methodsFor: 'initialization' stamp: 'KenD 4/14/2019 16:46:00' prior: 16854720! - initWithContents: anObject prior: priorMorph forList: hostList indentLevel: newLevel - - | o | - container _ hostList. - complexContents _ anObject. - self initWithContents: anObject asString font: Preferences standardListFont emphasis: nil. - indentLevel _ 0. - isExpanded _ false. - nextSibling _ firstChild _ nil. - priorMorph ifNotNil: [ - priorMorph nextSibling: self. - ]. - o _ anObject withoutListWrapper. - icon _ o ifNotNil: [ (o respondsTo: #icon) ifTrue: [ o icon ] ]. - indentLevel _ newLevel. -! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3696-IndentingListItemMorph-fix-KenDickey-2019Apr16-10h33m-KenD.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3696] on 17 April 2019 at 2:14:28 pm'! -!PasteUpMorph methodsFor: 'events' stamp: 'jmv 4/17/2019 14:13:14' prior: 16887164! - click: aMouseButtonEvent localPosition: localEventPosition - ^self whenUIinSafeState: [self mouseButton2Activity]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3697-WorldMenuFix-JuanVuletich-2019Apr17-14h14m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3697] on 17 April 2019 at 3:05:02 pm'! -!Parser methodsFor: 'error correction' stamp: 'jmv 4/17/2019 15:01:56' prior: 16886442! - correctSelector: proposedKeyword wordIntervals: aSpots exprInterval: expInt ifAbort: abortAction - "Correct the proposedKeyword to some selector symbol, correcting the original text if such action is indicated. abortAction is invoked if the proposedKeyword couldn't be converted into a valid selector. Spots is an ordered collection of intervals within the test stream of the for each of the keyword parts." - - | correctSelector userSelection delta spots | - "If we can't ask the user, assume that the keyword will be defined later" - self interactive ifFalse: [^proposedKeyword asSymbol]. - - "If the requestor is of an exotic kind (like a telnet server) we might not be allowed to open a PupUpMenu for querying the user" - " - ((requestor isKindOf: Editor) or: [ requestor is: #Morph ]) - ifFalse: [ ^ proposedKeyword asSymbol ]. - " - - userSelection _ requestor selectionInterval. - delta _ userSelection last - aSpots last last. - spots _ aSpots collect: [ :interval | interval first + delta to: interval last + delta ]. - requestor selectFrom: spots first first to: spots last last. - - correctSelector _ UnknownSelector name: proposedKeyword. - correctSelector ifNil: [^abortAction value]. - - requestor selectInvisiblyFrom: userSelection first to: userSelection last. - - self substituteSelector: correctSelector keywords wordIntervals: spots. - ^(proposedKeyword last ~~ $: - and: [correctSelector last == $:]) - ifTrue: [abortAction value] - ifFalse: [correctSelector]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3698-SelectorCorrectionFix-JuanVuletich-2019Apr17-15h04m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3698] on 17 April 2019 at 3:18:04 pm'! - -Object subclass: #Compiler - instanceVariableNames: 'sourceStream requestor class category context parser sourceStreamGetter ' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #Compiler category: #'Compiler-Kernel'! -Object subclass: #Compiler - instanceVariableNames: 'sourceStream requestor class category context parser sourceStreamGetter' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -Scanner subclass: #Parser - instanceVariableNames: 'here hereType hereMark hereEnd prevMark prevEnd encoder requestor parseNode failBlock requestorOffset tempsMark doitFlag properties category sourceStreamGetter ' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #Parser category: #'Compiler-Kernel'! -Scanner subclass: #Parser - instanceVariableNames: 'here hereType hereMark hereEnd prevMark prevEnd encoder requestor parseNode failBlock requestorOffset tempsMark doitFlag properties category sourceStreamGetter' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! -!Compiler methodsFor: 'private' stamp: 'jmv 4/17/2019 15:15:58' prior: 50444790! - translate: aStream noPattern: noPattern doIt: doIt ifFail: failBlock - - ^self parser - ignoreBacktick: false; - parse: aStream - class: class - category: category - noPattern: noPattern - doIt: doIt - context: context - notifying: requestor - ifFail: [^failBlock value]! ! -!Parser methodsFor: 'public access' stamp: 'jmv 4/17/2019 15:17:07' prior: 50444852! - parse: sourceStream class: class category: aCategory noPattern: noPattern doIt: doIt context: aContext notifying: aRequestor ifFail: aBlock - - "Answer a MethodNode for the argument, sourceStream, that is the root of - a parse tree. Parsing is done with respect to the argument, class, to find - instance, class, and pool variables; and with respect to the argument, - ctxt, to find temporary variables. Errors in parsing are reported to the - argument, req, if not nil; otherwise aBlock is evaluated. The argument - noPattern is a Boolean that is true if the the sourceStream does not - contain a method header (i.e., for DoIts)." - - | methNode repeatNeeded myStream sourceCode startPosition | - - category _ aCategory. - myStream _ sourceStream. - [ - repeatNeeded _ false. - startPosition _ myStream position. - sourceCode _ myStream upToEnd. - myStream position: startPosition. - self encoder init: class context: aContext notifying: self. - self init: myStream notifying: aRequestor failBlock: [^ aBlock value ]. - doitFlag _ noPattern. - failBlock _ aBlock. - [ methNode _ self method: noPattern doIt: doIt context: aContext ] - on: ReparseAfterSourceEditing - do: [ :ex | - repeatNeeded _ true. - myStream _ ReadStream on: requestor text string ]. - repeatNeeded - ] whileTrue: [ encoder _ self encoder class new ]. - - methNode sourceText: sourceCode. - "See #xBacktick" - sentInLiterals do: [ :sym | encoder noteOptimizedSelector: sym ]. - - ^ methNode! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'jmv 4/17/2019 15:15:33' prior: 50444965! - compileSelectionFor: anObject in: evalContext ifFail: failBlock - - | methodNode method sourceCode compiler | - - sourceCode := self selectionDoItSourceCodeIn: evalContext. - - methodNode _ [ - compiler _ Compiler new. - compiler - compileDoIt: sourceCode - in: anObject class - context: evalContext - notifying: self - ifFail: [ ^ failBlock value ]] - on: OutOfScopeNotification - do: [ :ex | ex resume: true ]. - - methodNode block returnLast. - method _ methodNode generate. - method methodNode: methodNode. - - ^{ #method -> method. #compiler -> compiler } asDictionary -! ! - -Parser removeSelector: #sourceStreamGetter:! - -Parser removeSelector: #sourceStreamGetter:! - -Compiler removeSelector: #sourceStreamGetter:! - -Compiler removeSelector: #sourceStreamGetter:! - -Object subclass: #Compiler - instanceVariableNames: 'sourceStream requestor class category context parser' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #Compiler category: #'Compiler-Kernel'! -Object subclass: #Compiler - instanceVariableNames: 'sourceStream requestor class category context parser' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -Scanner subclass: #Parser - instanceVariableNames: 'here hereType hereMark hereEnd prevMark prevEnd encoder requestor parseNode failBlock requestorOffset tempsMark doitFlag properties category' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #Parser category: #'Compiler-Kernel'! -Scanner subclass: #Parser - instanceVariableNames: 'here hereType hereMark hereEnd prevMark prevEnd encoder requestor parseNode failBlock requestorOffset tempsMark doitFlag properties category' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3699-CompilerCleanup-JuanVuletich-2019Apr17-15h15m-jmv.1.cs.st----! - -----SNAPSHOT----(23 April 2019 09:05:16) Cuis5.0-3699-32.image priorSource: 3680522! - -----QUIT----(23 April 2019 09:05:37) Cuis5.0-3699-32.image priorSource: 3855686! - -----STARTUP---- (29 April 2019 09:02:06) as /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/Cuis5.0-3699-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3699] on 23 April 2019 at 10:14:09 am'! -!Parser methodsFor: 'error correction' stamp: 'jmv 4/23/2019 10:13:10' prior: 16886486! - correctVariable: proposedVariable interval: aSpot - "Correct the proposedVariable to a known variable, or declare it as a new - variable if such action is requested. We support declaring lowercase - variables as temps or inst-vars, and uppercase variables as Globals or - ClassVars, depending on whether the context is nil (class=UndefinedObject). - Spot is the interval within the test stream of the variable. - rr 3/4/2004 10:26 : adds the option to define a new class. " - - "Check if this is an i-var, that has been corrected already (ugly)" - - "Display the pop-up menu" - - | userSelection action delta spot | - (encoder classEncoding instVarNames includes: proposedVariable) ifTrue: [ - ^InstanceVariableNode new - name: proposedVariable - index: (encoder classEncoding allInstVarNames indexOf: proposedVariable)]. - - "First check to see if the requestor knows anything about the variable" - (requestor bindingOf: proposedVariable) - ifNotNil: [ :binding | ^ encoder global: binding name: proposedVariable]. - - "If we can't ask the user for correction, make it undeclared" - self interactive ifFalse: [^encoder undeclared: proposedVariable]. - - userSelection _ requestor selectionInterval. - delta _ userSelection last - aSpot last. - spot _ aSpot first + delta to: aSpot last + delta. - requestor selectFrom: spot first to: spot last. - - "Build the menu with alternatives" - action _ UndeclaredVariable - signalFor: self - name: proposedVariable - inRange: spot. - action ifNil: [^self fail]. - - "Execute the selected action" - requestor selectInvisiblyFrom: userSelection first to: userSelection last. - ^action value! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3700-VariableCorrectionFix-JuanVuletich-2019Apr23-10h05m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3688] on 17 April 2019 at 9:09:08 pm'! - -Object subclass: #ClassDefinitionNodeAnalyzer - instanceVariableNames: 'classDefinitionNode classCreationMessageNode superClassNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Support'! - -!classDefinition: #ClassDefinitionNodeAnalyzer category: #'Compiler-Support'! -Object subclass: #ClassDefinitionNodeAnalyzer - instanceVariableNames: 'classDefinitionNode classCreationMessageNode superClassNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Support'! -!ClassDefinitionNodeAnalyzer methodsFor: 'initialization' stamp: 'HAW 4/17/2019 18:19:19'! - initializeFor: aClassDefinitionMethodNode - - classDefinitionNode := aClassDefinitionMethodNode. - classCreationMessageNode := classDefinitionNode block statements first expr. - superClassNode := classCreationMessageNode receiver. -! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'testing' stamp: 'HAW 4/17/2019 20:47:37'! - isAtCategory: anIndex - - ^self is: anIndex atStringParameterNumber: self class categoryPosition - ! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'testing' stamp: 'HAW 4/17/2019 18:36:15'! - isAtClassName: anIndex - - ^(classDefinitionNode sourceRangeFor: classCreationMessageNode arguments first) first includes: anIndex! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'testing' stamp: 'HAW 4/17/2019 20:46:45'! - isAtInstanceVariables: anIndex - - ^self is: anIndex atStringParameterNumber: self class instanceVariableNamesPosition! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'testing' stamp: 'HAW 4/17/2019 18:34:11'! - isAtSuperclass: anIndex - - ^(classDefinitionNode sourceRangeFor: superClassNode) first includes: anIndex! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'accessing' stamp: 'HAW 4/17/2019 18:41:46'! - superclass - - ^superClassNode key value ! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'testing - private' stamp: 'HAW 4/17/2019 20:37:06'! - is: anIndex atStringParameterNumber: aParameterPosition - - | parameterRange | - - parameterRange := (classDefinitionNode sourceRangeFor: (classCreationMessageNode arguments at: aParameterPosition)) first. - - ^anIndex between: parameterRange first + 1 and: parameterRange last - 1! ! -!ClassDefinitionNodeAnalyzer class methodsFor: 'parameters positions' stamp: 'HAW 4/17/2019 20:47:27'! -categoryPosition - - ^5! ! -!ClassDefinitionNodeAnalyzer class methodsFor: 'parameters positions' stamp: 'HAW 4/17/2019 20:47:15'! - instanceVariableNamesPosition - - ^2! ! -!ClassDefinitionNodeAnalyzer class methodsFor: 'instance creation' stamp: 'HAW 4/17/2019 18:18:03'! - for: aClassDefinitionMethodNode - - ^self new initializeFor: aClassDefinitionMethodNode ! ! -!Editor methodsFor: 'new selection' stamp: 'HAW 4/15/2019 16:01:45'! - wordLeftDelimiters - - ^''! ! -!Editor methodsFor: 'new selection' stamp: 'HAW 4/15/2019 15:57:53'! - wordRangeLeftDelimiters: leftDelimiters rightDelimiters: rightDelimiters - "Select delimited text or word--the result of double-clicking." - - | initialDelimiter finalDelimiter direction match level string here hereChar start stop | - string _ self privateCurrentString. - string size < 2 ifTrue: [^1 to: 1]. - here _ self pointIndex min: string size max: 2. - initialDelimiter _ string at: here - 1. - match _ leftDelimiters indexOf: initialDelimiter. - match > 0 - ifTrue: [ - "delimiter is on left -- match to the right" - start _ here. - direction _ 1. - here _ here - 1. - finalDelimiter _ rightDelimiters at: match] - ifFalse: [ - initialDelimiter _ string at: here. - match _ rightDelimiters indexOf: initialDelimiter. - match > 0 - ifTrue: [ - "delimiter is on right -- match to the left" - stop _ here - 1. - direction _ -1. - finalDelimiter _ leftDelimiters at: match] - ifFalse: [ - "no delimiters -- select a token" - direction _ -1]]. - level _ 1. - [level > 0 and: [direction > 0 - ifTrue: [here < string size] - ifFalse: [here > 1]]] - whileTrue: [ - hereChar _ string at: (here _ here + direction). - match = 0 - ifTrue: [ - "token scan goes left, then right" - hereChar isValidInIdentifiers "Consider $: as a word separator" - ifTrue: [ - here = 1 - ifTrue: [ - start _ 1. - "go right if hit string start" - direction _ 1]] - ifFalse: [ - direction < 0 - ifTrue: [ - start _ here + 1. - "go right if hit non-token" - direction _ 1] - ifFalse: [level _ 0]]] - ifFalse: [ - "delimiter match just counts nesting level" - hereChar = finalDelimiter - ifTrue: [level _ level - 1"leaving nest"] - ifFalse: [ - hereChar = initialDelimiter - ifTrue: [level _ level + 1"entering deeper nest"]]]]. - level > 0 ifTrue: [ - leftDelimiters size + rightDelimiters size = 0 ifFalse: [ - "If we failed to find final delimiter, then just select word." - ^self wordRangeLeftDelimiters: '' rightDelimiters: '' ]. - here _ here + direction ]. - ^ direction > 0 - ifTrue: [ - "If a word ends with $: (a keyword), consider it part of the word" - hereChar = $: ifTrue: [here _ here + 1]. - start to: here - 1] - ifFalse: [ - "But if a word starts with $: (this is the argument to a keyword), then it is not part of the word." - here + 1 to: stop]! ! -!Editor methodsFor: 'new selection' stamp: 'HAW 4/15/2019 16:01:58'! - wordRightDelimiters - - ^''! ! -!Editor methodsFor: 'new selection' stamp: 'HAW 4/17/2019 18:01:07'! - wordUnderCursorRange - - ^self wordRangeLeftDelimiters: self wordLeftDelimiters rightDelimiters: self wordRightDelimiters ! ! -!TextEditor methodsFor: 'model access' stamp: 'HAW 4/17/2019 19:26:58'! - wordUnderCursor - - | wordUnderCursorRange word indexOfSpace | - - wordUnderCursorRange := self wordUnderCursorRange. - word := (model actualContents copyFrom: wordUnderCursorRange first to: wordUnderCursorRange last) asString. - - "I have to handle the edge case where the cursor is for example between a ' and the first letter of the word. - In that case the range will include words with spaces - Hernan" - indexOfSpace := word indexOf: $ ifAbsent: [ ^word ]. - - ^word first: indexOfSpace -1 - - ! ! -!SmalltalkEditor methodsFor: 'new selection' stamp: 'HAW 4/15/2019 16:01:45'! - wordLeftDelimiters - - ^ '([{<|''"`'! ! -!SmalltalkEditor methodsFor: 'new selection' stamp: 'HAW 4/15/2019 16:01:58'! - wordRightDelimiters - - ^ ')]}>|''"`'! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 4/17/2019 20:09:44'! - contextualRenameInClassDefinition - - self ifRenameCanBeAppliedDo: [ - self - withClassDefinitionNodeAndClassDo: [ :classDefinitionNode :selectedClass | self contextualRenameInClassDefinitionOf: classDefinitionNode in: selectedClass] - ifErrorsParsing: [ :anError | morph flash ] ]! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 4/17/2019 21:06:49'! - contextualRenameInClassDefinitionOf: aClassDefinitionNode in: aSelectedClass - - | analyzer cursorPosition | - - analyzer := ClassDefinitionNodeAnalyzer for: aClassDefinitionNode. - cursorPosition := self startIndex. - - (analyzer isAtSuperclass: cursorPosition) - ifTrue: [ ^self renameClassOn: self codeProvider for: analyzer superclass ]. - - (analyzer isAtClassName: cursorPosition) - ifTrue: [ ^self renameClassOn: self codeProvider for: aSelectedClass ]. - - (analyzer isAtInstanceVariables: cursorPosition) - ifTrue: [ ^self renameInstanceVariableOn: self codeProvider for: self wordUnderCursor at: aSelectedClass ]. - - (analyzer isAtCategory: cursorPosition) - ifTrue: [ - "I'm sure codeProvider is a Browser - Hernan" - ^self codeProvider renameSystemCategory ]. - - morph flash - -! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 4/15/2019 14:48:21'! - contextualRenameInMethod - - self - withMethodNodeAndClassDo: [ :methodNode :selectedClass | self contextualRenameOf: methodNode in: selectedClass] - ifErrorsParsing: [ :anError | morph flash ] ! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 4/15/2019 14:54:34'! - withClassDefinitionNodeAndClassDo: aBlock ifErrorsParsing: anErrorBlock - - | selectedClass methodNode | - - selectedClass := self codeProvider selectedClassOrMetaClass. - methodNode := [ selectedClass methodNodeFor: model actualContents noPattern: true ] on: Error do: [ :anError | ^ anErrorBlock value: anError ]. - - ^aBlock value: methodNode value: selectedClass.! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 4/17/2019 20:13:57'! - sourceRangeFor: aParseNode - - ^encoder sourceRangeFor: aParseNode ! ! -!Editor methodsFor: 'new selection' stamp: 'HAW 4/15/2019 16:01:58' prior: 16836452! - selectWord - "Select delimited text or word--the result of double-clicking." - - ^self selectWordLeftDelimiters: self wordLeftDelimiters rightDelimiters: self wordRightDelimiters ! ! -!Editor methodsFor: 'new selection' stamp: 'HAW 4/15/2019 15:48:33' prior: 50421160! - selectWordLeftDelimiters: leftDelimiters rightDelimiters: rightDelimiters - "Select delimited text or word--the result of double-clicking." - - | wordRange | - - wordRange := self wordRangeLeftDelimiters: leftDelimiters rightDelimiters: rightDelimiters. - - self selectFrom: wordRange first to: wordRange last! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 4/15/2019 14:48:08' prior: 50450183! - contextualRename - - self isEditingClassDefinition - ifTrue: [ self contextualRenameInClassDefinition ] - ifFalse: [ self contextualRenameInMethod ]! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 4/17/2019 20:11:29'! - isEditingClassDefinition - - "This is ugly, but I don't find a better way to do it without making a big change in the code provider hierarchy - Hernan" - ^(self codeProvider respondsTo: #editSelection) and: [ self codeProvider editSelection == #editClass]! ! - -SmalltalkEditor removeSelector: #selectWord! - -SmalltalkEditor removeSelector: #selectWord! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3701-ContextualRenameInClassDefinition-HernanWilkinson-2019Mar27-11h04m-HAW.5.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3688] on 17 April 2019 at 9:21:57 pm'! -!Dictionary class methodsFor: 'error descriptions' stamp: 'HAW 4/4/2019 08:14:52'! - keyNotFoundErrorDescription - - ^'key not found'! ! -!Dictionary methodsFor: 'private' stamp: 'HAW 4/4/2019 08:15:21' prior: 16833741! - errorKeyNotFound - - self error: self class keyNotFoundErrorDescription ! ! -!Trie methodsFor: 'private' stamp: 'HAW 4/4/2019 08:15:38' prior: 16939280! - errorKeyNotFound - - self error: Dictionary keyNotFoundErrorDescription ! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3702-KeyNotFound-HernanWilkinson-2019Mar27-11h04m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3688] on 18 April 2019 at 6:07:20 pm'! -!AbstractFont methodsFor: 'as yet unclassified' stamp: 'HAW 4/2/2019 22:15:03'! - ascent - - self subclassResponsibility ! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3703-AbstractFontAscent-HernanWilkinson-2019Mar27-11h04m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3688] on 18 April 2019 at 6:36:44 pm'! -!MessageSetWindow class methodsFor: 'opening' stamp: 'HAW 3/29/2019 11:36:08'! - open: model label: aString - - | window | - - window := super open: model label: aString. - model messageListIndex: 1. - - ^window! ! -!MessageSet methodsFor: 'private' stamp: 'HAW 3/29/2019 11:32:39' prior: 50368662! - initializeMessageList: anArray - - messageList _ anArray. - messageList isEmpty - ifTrue: [ selectedMessage _ nil ] - ifFalse: [ self messageListIndex: 1 ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3704-SelectionWhenOpening-HernanWilkinson-2019Mar27-11h04m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3688] on 18 April 2019 at 8:56:36 pm'! - -PluggableScrollPane subclass: #TextModelMorph - instanceVariableNames: 'shouldAttendActualScopeSenderChanged ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #TextModelMorph category: #'Morphic-Views'! -PluggableScrollPane subclass: #TextModelMorph - instanceVariableNames: 'shouldAttendActualScopeSenderChanged' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! -!MessageSet methodsFor: 'source code ranges' stamp: 'HAW 4/18/2019 20:42:29'! - messageSendsRangesOf: aSelector - - ^ selectedMessage - ifNil: [ #() ] - ifNotNil: [selectedMessage messageSendsRangesOf: aSelector ]! ! -!CompiledMethod methodsFor: 'source code ranges' stamp: 'HAW 4/18/2019 20:41:51'! - messageSendsRangesOf: aSentSelector - - | methodNode ranges | - - methodNode := self methodNode. - ranges := OrderedCollection new. - - methodNode nodesDo: [ :aParseNode | - (aParseNode isMessageNamed: aSentSelector) ifTrue: [ ranges add: (methodNode sourceRangeFor: aParseNode) ]]. - - ^ranges ! ! -!TextModelMorph methodsFor: 'updating' stamp: 'HAW 4/18/2019 20:51:03'! - selectMessage - - | messageSendsRanges | - - messageSendsRanges := model textProvider messageSendsRangesOf: model autoSelectString. - self editor messageSendsRanges: messageSendsRanges. -! ! -!TextModelMorph methodsFor: 'updating' stamp: 'HAW 4/18/2019 20:51:08'! - selectString - - self editor - setSearch: model autoSelectString; - findAndReplaceMany: true ! ! -!TextModelMorph methodsFor: 'updating' stamp: 'HAW 4/18/2019 20:34:31'! - updateAcceptedContents - - self textMorph hasUnacceptedEdits ifTrue: [ - self textMorph hasEditingConflicts: true. - ^self redrawNeeded ]. - model refetch. - "#actualContents also signalled in #refetch. No need to repeat what's done there." - ^self ! ! -!TextModelMorph methodsFor: 'updating' stamp: 'HAW 4/18/2019 20:33:38'! -updateActualContents - - "Some day, it would be nice to keep objects and update them - instead of throwing them away all the time for no good reason..." - self textMorph - releaseEditorAndTextComposition; - installEditorAndTextComposition; - formatAndStyleIfNeeded. - self setScrollDeltas. - self redrawNeeded. - ^self ! ! -!TextModelMorph methodsFor: 'updating' stamp: 'HAW 4/18/2019 20:53:31'! - updateAutoSelect - - TextEditor abandonChangeText. "no replacement!!" - (model autoSelectString isKindOf: Symbol) - ifTrue: [ self selectMessage ] - ifFalse: [ self selectString]. - - self textMorph updateFromTextComposition. - ^self scrollSelectionIntoView! ! -!TextModelMorph methodsFor: 'updating' stamp: 'HAW 4/18/2019 20:37:48'! - updateClearUserEdits - - "Quite ugly" - ^self hasUnacceptedEdits: false -! ! -!TextModelMorph methodsFor: 'updating' stamp: 'HAW 4/18/2019 20:36:13'! - updateInitialSelection - - ^self - setSelection: model getSelection; - redrawNeeded! ! -!TextModelMorph methodsFor: 'updating' stamp: 'HAW 4/18/2019 20:35:31'! - updateRefetched - - "#actualContents also signalled when #refetched is signalled. - No need to repeat what's done there." - self setSelection: model getSelection. - self hasUnacceptedEdits: false. - - ^self ! ! -!TextModelMorph methodsFor: 'updating' stamp: 'HAW 4/18/2019 20:38:23'! - updateShoutStyled - - self textMorph stylerStyled. - ^self redrawNeeded ! ! -!MethodReference methodsFor: 'source code ranges' stamp: 'HAW 4/18/2019 20:17:52'! - messageSendsRangesOf: aSentSelector - - | compiledMethod | - - compiledMethod := self compiledMethodIfAbsent: [ ^#() ]. - ^compiledMethod messageSendsRangesOf: aSentSelector ! ! -!CompiledMethod methodsFor: 'decompiling' stamp: 'HAW 4/18/2019 20:40:33' prior: 50444923! - methodNode: aMethodNode - - self propertyValueAt: #methodNode put: aMethodNode! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'HAW 4/18/2019 20:10:24' prior: 16923849! - browseAllCallsOn: aLiteral - "Create and schedule a message browser on each method that refers to - aLiteral. For example, Smalltalk browseAllCallsOn: #open:label:." - (aLiteral isKindOf: LookupKey) - ifTrue: [ - self - browseMessageList: (self allCallsOn: aLiteral) asArray sort - name: 'Users of ' , aLiteral key - autoSelect: aLiteral key ] - ifFalse: [ - self - browseMessageList: (self allCallsOn: aLiteral) asArray sort - name: 'Senders of ' , aLiteral - autoSelect: aLiteral ].! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'HAW 4/18/2019 20:29:53' prior: 16923881! - browseAllCallsOn: aLiteral localTo: aClass - "Create and schedule a message browser on each method in or below the given class that refers to - aLiteral. For example, Smalltalk browseAllCallsOn: #open:label:." - aClass ifNil: [ ^ self inform: 'no selected class' ]. - (aLiteral isKindOf: LookupKey) - ifTrue: [ - self - browseMessageList: (aClass allLocalCallsOn: aLiteral) asArray sort - name: 'Users of ' , aLiteral key , ' local to ' , aClass name - autoSelect: aLiteral key ] - ifFalse: [ - self - browseMessageList: (aClass allLocalCallsOn: aLiteral) asArray sort - name: 'Senders of ' , aLiteral , ' local to ' , aClass name - autoSelect: aLiteral ].! ! -!TextEditor methodsFor: 'new selection' stamp: 'HAW 4/18/2019 20:56:26'! - messageSendsRanges: aRanges - - selectionStartBlocks := OrderedCollection new. - selectionStopBlocks := OrderedCollection new. - - aRanges do: [ :range | - selectionStartBlocks add: (textComposition characterBlockForIndex: range first). - selectionStopBlocks add: (textComposition characterBlockForIndex: range last + 1) ]! ! -!TextModelMorph methodsFor: 'updating' stamp: 'HAW 4/18/2019 20:39:08' prior: 16934212! - update: aSymbol - - super update: aSymbol. - aSymbol ifNil: [^self]. - - aSymbol == #flash ifTrue: [^self flash]. - aSymbol == #actualContents ifTrue: [ ^self updateActualContents ]. - aSymbol == #acceptedContents ifTrue: [ ^self updateAcceptedContents ]. - aSymbol == #refetched ifTrue: [ ^self updateRefetched ]. - aSymbol == #initialSelection ifTrue: [ ^self updateInitialSelection ]. - aSymbol == #autoSelect ifTrue: [ ^self updateAutoSelect ]. - aSymbol == #clearUserEdits ifTrue: [ ^self updateClearUserEdits ]. - aSymbol == #shoutStyled ifTrue: [ ^self updateShoutStyled ]. -! ! -!MessageSetWindow methodsFor: 'GUI building' stamp: 'jmv 1/1/2015 21:05' prior: 16870413! - buildLowerPanes - | codeAndButtons codeButtonsAndAnnotations | - codeAndButtons _ LayoutMorph newColumn. - Preferences optionalButtons ifTrue: [ - codeAndButtons - addMorph: self optionalButtonRow fixedHeight: self defaultButtonPaneHeight; - addAdjusterMorph ]. - codeAndButtons - addMorph: self buildMorphicCodePane proportionalHeight: 1.0. - Preferences optionalButtons ifFalse: [ - ^codeAndButtons ]. - codeButtonsAndAnnotations _ LayoutMorph newColumn. - codeButtonsAndAnnotations - addMorph: self buildMorphicAnnotationsPane fixedHeight: self defaultAnnotationPaneHeight; - addAdjusterMorph; - addMorph: codeAndButtons proportionalHeight: 1.0. - ^codeButtonsAndAnnotations! ! -!MethodReference methodsFor: 'queries' stamp: 'HAW 4/18/2019 20:17:23'! - compiledMethodIfAbsent: ifAbsentBlock - - ^ self actualClass compiledMethodAt: methodSymbol ifAbsent: ifAbsentBlock ! ! -!RefactoringApplier methodsFor: 'exception handling' stamp: 'HAW 4/15/2019 15:41:14' prior: 50441359! - browseReferencesOn: aCanNotRefactorDueToReferencesError - - Smalltalk - browseMessageList: aCanNotRefactorDueToReferencesError references - name: (self referencesBrowserTitleOn: aCanNotRefactorDueToReferencesError) - autoSelect: aCanNotRefactorDueToReferencesError referencee name asString -! ! - -PluggableScrollPane subclass: #TextModelMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #TextModelMorph category: #'Morphic-Views'! -PluggableScrollPane subclass: #TextModelMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3705-MessageSendSelection-HernanWilkinson-2019Mar27-11h04m-HAW.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3688] on 18 April 2019 at 5:55:07 pm'! -!MessageNode methodsFor: 'testing' stamp: 'HAW 4/18/2019 17:52:07'! - isCascade - - ^receiver isNil ! ! -!MethodNode methodsFor: 'testing' stamp: 'HAW 3/29/2019 23:50:04'! - isMultipleRanges: aRangeOrRanges - - ^aRangeOrRanges isKindOf: OrderedCollection ! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'HAW 3/29/2019 23:42:52'! - inspectSelectionOrLine - - self - evaluateSelectionAndDo: [ :result | result inspect ] - ifFail: [ morph flash ] - profiled: false! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'HAW 3/29/2019 23:58:09'! - selectForInspection: aNodeUnderCursor in: aMethodNode - - (aNodeUnderCursor isLiteralNode or: [ aNodeUnderCursor isVariableNode ]) ifTrue: [ ^self selectNodeRange: aNodeUnderCursor in: aMethodNode ]. - aNodeUnderCursor isMessageNode ifTrue: [ ^self selectMessageNode: aNodeUnderCursor in: aMethodNode ].! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'HAW 3/30/2019 00:29:14'! - selectMessageNode: aMessageNodeUnderCursor in: aMethodNode - - | messageRange | - - self - withReceiverRangeOf: aMessageNodeUnderCursor - in: aMethodNode - selectorPosition: self startIndex - do: [ :receiverRange | - messageRange := aMethodNode sourceRangeFor: aMessageNodeUnderCursor. - self selectFrom: receiverRange first to: messageRange last ] - - ! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'HAW 3/29/2019 23:57:59'! - selectNodeRange: aNodeUnderCursor in: aMethodNode - - | range ranges | - - ranges := aMethodNode sourceRangeFor: aNodeUnderCursor. - range := (aMethodNode isMultipleRanges: ranges) - ifTrue: [ ranges detect: [ :aRange | aRange includes: self startIndex ] ifNone: [ ^self ]] - ifFalse: [ ranges ]. - - self selectFrom: range first to: range last -! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'HAW 3/29/2019 23:57:08'! - selectNodeUnderCursorForInspectionIn: aMethodNode - - aMethodNode - withParseNodeIncluding: self startIndex - do: [ :nodeUnderCursor | self selectForInspection: nodeUnderCursor in: aMethodNode ] - ifAbsent: [] - - -! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'HAW 4/18/2019 17:54:45'! - withReceiverRangeOf: aMessageNode in: aMethodNode selectorPosition: aSelectorPosition do: aBlock - - | receiverRange receiverRangeOrRanges messageNodeReceiver | - - "If aMessageNode receiver isNil it means that it is a cascade receiver so this imposes the question on how to inspect - a cascade message send. We could inspect the result of sending all the messages up to the cursor but the problem is - that when looking for the cascade receiver range it does not find it because it is a different node that the used in the source - ranges... we could do the trick of looking for printString in the sourceRanges keys, but that is too much - Hernan" - aMessageNode isCascade ifFalse: [ - messageNodeReceiver := aMessageNode receiver. - messageNodeReceiver isMessageNode ifTrue: [ - ^self withReceiverRangeOf: messageNodeReceiver in: aMethodNode selectorPosition: (messageNodeReceiver keywordPositionAt: 1) first do: aBlock ]. - - receiverRangeOrRanges := aMethodNode sourceRangeFor: messageNodeReceiver. - - receiverRange := (aMethodNode isMultipleRanges: receiverRangeOrRanges) - ifTrue: [ | closestRange | - closestRange := receiverRangeOrRanges first. - receiverRangeOrRanges do: [ :aRange | (aRange last < aSelectorPosition and: [ aRange last > closestRange last ]) ifTrue: [ closestRange := aRange ]]. - closestRange ] - ifFalse: [ receiverRangeOrRanges ]. - - aBlock value: receiverRange ]! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'HAW 3/30/2019 00:45:22' prior: 16909732! - inspectIt - - self hasSelection ifFalse: [ - self - withMethodNodeAndClassDo: [ :methodNode :selectedClass | self selectNodeUnderCursorForInspectionIn: methodNode ] - ifErrorsParsing: [ :anError | ]]. - - self inspectSelectionOrLine - - ! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 4/18/2019 17:34:21' prior: 50450219! - withMethodNodeAndClassDo: aBlock ifErrorsParsing: anErrorBlock - - | selectedClass methodNode | - - "I have to do this because some codeProviders do no answer selectedClassOrMetaClass like the Workspace - Hernan" - selectedClass := [ self codeProvider selectedClassOrMetaClass ] on: Error do: [ :anError | anError return: UndefinedObject ]. - [ methodNode := selectedClass methodNodeFor: model actualContents ] on: Error do: [ :anError | ^ anErrorBlock value: anError ]. - - aBlock value: methodNode value: selectedClass.! ! -!DebuggerMethodMap methodsFor: 'source mapping' stamp: 'HAW 3/29/2019 23:50:31' prior: 50445278! - abstractSourceMap - "Answer with a Dictionary of abstractPC to sourceRange ." - - | theMethodToScan rawSourceRanges concreteSourceRanges abstractPC scanner client | - - abstractSourceRanges ifNotNil: [ ^abstractSourceRanges]. - - methodNode encoder hasGeneratedMethod - ifTrue: [ - rawSourceRanges := methodNode encoder rawSourceRanges. - theMethodToScan := self method ] - ifFalse: [ - "If the methodNode hasn't had a method generated it doesn't have pcs set in its - nodes so we must generate a new method and might as well use it for scanning." - [methodNode rawSourceRangesAndMethodDo: [ :ranges :method | - rawSourceRanges := ranges. - theMethodToScan := method ]] - on: UndeclaredVariableWarning - do: [ :ex | ex resume ]]. - - concreteSourceRanges := Dictionary new. - rawSourceRanges keysAndValuesDo: [ :node :range | - node pc ~= 0 ifTrue: [ | realRange | - realRange := (methodNode isMultipleRanges: range) ifTrue: [ range last ] ifFalse: [ range ]. - concreteSourceRanges at: node pc put: realRange ]]. - - abstractPC := 1. - abstractSourceRanges := Dictionary new. - scanner := InstructionStream on: theMethodToScan. - client := InstructionClient new. - [ - (concreteSourceRanges includesKey: scanner pc) ifTrue: [ - abstractSourceRanges at: abstractPC put: (concreteSourceRanges at: scanner pc)]. - abstractPC := abstractPC + 1. - scanner interpretNextInstructionFor: client. - scanner atEnd ] whileFalse. - - ^abstractSourceRanges! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3706-InspectUnderCursor-HernanWilkinson-2019Mar27-11h04m-HAW.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3696] on 19 April 2019 at 3:03:00 pm'! - -Transcript class - instanceVariableNames: 'entries firstIndex lastIndex accessSemaphore unfinishedEntry logToFile showOnDisplay lastDisplayPosition bounds logToStdout '! - -!classDefinition: 'Transcript class' category: #'System-Support'! -Transcript class - instanceVariableNames: 'entries firstIndex lastIndex accessSemaphore unfinishedEntry logToFile showOnDisplay lastDisplayPosition bounds logToStdout'! -!Transcript class methodsFor: 'preferred protocol' stamp: 'GC 4/19/2019 14:55:44'! - clearStdout - - logToStdout ifTrue: [ - 15 timesRepeat: [ self stdout newLine ] - ]! ! -!Transcript class methodsFor: 'preferred protocol' stamp: 'GC 4/19/2019 14:56:52'! - logToStdout: aBoolean - - logToStdout _ aBoolean ! ! -!Transcript class methodsFor: 'preferred protocol' stamp: 'GC 4/19/2019 14:56:49'! - logsToStdout - - ^ logToStdout! ! -!Transcript class methodsFor: 'private' stamp: 'GC 4/19/2019 14:37:08'! - addEntry: aString logToFileAndStdout: fileEntryToLog - "Add a new entrie to the entries circular list. If full, a new entry will replace the oldest one." - - accessSemaphore critical: [ - - "Internal circular collection" - lastIndex _ lastIndex \\ self maxEntries + 1. - firstIndex = lastIndex ifTrue: [ firstIndex _ firstIndex \\ self maxEntries + 1 ]. - entries at: lastIndex put: aString. - - fileEntryToLog ifNotNil: [ - self writeToFile: fileEntryToLog. - self writeToStdout: fileEntryToLog - ] - ]! ! -!Transcript class methodsFor: 'private' stamp: 'GC 4/19/2019 14:16:07'! - stdout - - ^ StdIOWriteStream stdout! ! -!Transcript class methodsFor: 'private' stamp: 'GC 4/19/2019 14:37:53'! - writeToFile: anEntry - - self filename asFileEntry appendStreamDo: [ :stream | stream nextPutAll: anEntry ]! ! -!Transcript class methodsFor: 'private' stamp: 'GC 4/19/2019 14:37:47'! - writeToStdout: anEntry - - logToStdout ifTrue: [ self stdout nextPutAll: anEntry ]! ! -!TranscriptMorph methodsFor: 'menu commands' stamp: 'GC 4/19/2019 14:40:27'! - clearStdout - - Transcript clearStdout! ! -!TranscriptMorph methodsFor: 'menu commands' stamp: 'GC 4/19/2019 15:02:25'! - dontLogToStdout - - Transcript logToStdout: false! ! -!TranscriptMorph methodsFor: 'menu commands' stamp: 'GC 4/19/2019 15:02:22'! -logToStdout - - Transcript logToStdout: true! ! -!Transcript class methodsFor: 'preferred protocol' stamp: 'GC 4/19/2019 14:41:02' prior: 16938285! - clearAll - - self clearInternal. - logToFile ifTrue: [ self clearFile ]. - self clearStdout! ! -!Transcript class methodsFor: 'private' stamp: 'GC 4/19/2019 14:34:58' prior: 16938403! - addEntry: aString - "Add a new entrie to the entries circular list. If full, a new entry will replace the oldest one." - | msg now entryToLog | - entryToLog _ [ - now _ DateAndTime now. - msg _ String streamContents: [ :strm | - now printWithMsOn: strm. - strm - nextPutAll: ' process:'; - nextPutAll: Processor activeProcess priority printString; - nextPut: $ ; - nextPutAll: Processor activeProcess hash printString; - nextPut: $ ; - nextPutAll: aString; - newLine ]]. - - logToFile or: [ logToStdout ] :: ifTrue: entryToLog value. - - self addEntry: (aString copyReplaceAll: String newLineString with: ' ') logToFileAndStdout: msg! ! -!Transcript class methodsFor: 'class initialization' stamp: 'GC 4/19/2019 14:01:37' prior: 16938542! - initialize - " - self initialize - " - showOnDisplay _ true. - bounds _ 20@20 extent: 300@500. - logToFile _ false. - logToStdout _ false. - entries _ Array new: self maxEntries. - unfinishedEntry _ String new writeStream. - lastDisplayPosition _ 0. - accessSemaphore _ Semaphore forMutualExclusion. - self clear! ! -!TranscriptMorph methodsFor: 'menus' stamp: 'GC 4/19/2019 14:40:07' prior: 50399657! - getMenu - "Set up the menu to apply to the receiver" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - doImmediateUpdates - ifTrue: [ aMenu add: 'Only update in the regular Morphic cycle' action: #doRegularUpdates ] - ifFalse: [ aMenu add: 'Immediately show each entry' action: #doImmediateUpdates ]. - aMenu - addLine; - add: 'Workspace with Contents' action: #editContents; - addLine; - add: 'Clear Transcript' action: #clearInternal; - add: 'Clear Transcript File' action: #clearFile; - add: 'Clear Transcript Stdout' action: #clearStdout; - add: 'Clear Both' action: #clearAll; - addLine. - Transcript logsToFile - ifTrue: [ aMenu add: 'Stop logging to File' action: #dontLogToFile ] - ifFalse: [ aMenu add: 'Start logging to File' action: #logToFile ]. - aMenu addLine. - Transcript logsToStdout - ifTrue: [ aMenu add: 'Stop logging to Stdout' action: #dontLogToStdout ] - ifFalse: [ aMenu add: 'Start logging to Stdout' action: #logToStdout ]. - - ^ aMenu! ! - -Transcript initialize! - -Transcript class - instanceVariableNames: 'entries firstIndex lastIndex accessSemaphore unfinishedEntry logToFile showOnDisplay lastDisplayPosition bounds logToStdout '! - -!classDefinition: 'Transcript class' category: #'System-Support'! -Transcript class - instanceVariableNames: 'entries firstIndex lastIndex accessSemaphore unfinishedEntry logToFile showOnDisplay lastDisplayPosition bounds logToStdout'! - -"Postscript: -To initialize Transcript logToStdout class variable" -Transcript initialize. -Display restore! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3707-TranscriptCanLogToStdout-GC.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3707] on 24 April 2019 at 4:30:53 pm'! -!Transcript class methodsFor: 'private' stamp: 'jmv 4/24/2019 16:30:16' prior: 50453106! - writeToFile: anEntry - - logToFile ifTrue: [ - self filename asFileEntry appendStreamDo: [ :stream | stream nextPutAll: anEntry ]]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3708-OnlyLogTranscriptToFileIfRequested-JuanVuletich-2019Apr24-16h30m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3708] on 25 April 2019 at 8:41:55 am'! -!StrikeFont methodsFor: 'accessing' stamp: 'jmv 4/24/2019 20:27:07'! - lineSpacing - "Answer the height of the receiver including any additional line gap." - - ^self ascent + self descent! ! -!AbstractFont methodsFor: 'accessing' stamp: 'jmv 4/24/2019 18:11:27' prior: 50452562! - ascent - - self subclassResponsibility ! ! -!AbstractFont methodsFor: 'accessing' stamp: 'jmv 4/25/2019 08:40:28' prior: 16777250! -height - "Answer the line spacing. Prefer calling #lineSpacing, that is more explicit. - Besides, #height is false polymorphism, Fonts are not interchangeable with Form or Rectangle!!" - - ^self lineSpacing! ! -!StrikeFont methodsFor: 'accessing' stamp: 'jmv 4/24/2019 20:25:57' prior: 16914181! - ascent - "Answer the receiver's maximum extent of characters above the baseline. Positive." - - self isSuperscript ifTrue: [ ^ ascent * 1.9 ]. - self isSubscript ifTrue: [ ^ ascent * 0.75 ]. - ^ascent! ! -!StrikeFont methodsFor: 'accessing' stamp: 'jmv 4/24/2019 20:25:44' prior: 16914258! - descent - "Answer the receiver's maximum extent of characters below the baseline. Positive." - - | answer | - answer _ descent. - self isSubscript ifTrue: [ answer _ answer * 2 ]. - ^ answer! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3709-FontRefactor1-JuanVuletich-2019Apr25-08h38m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3708] on 25 April 2019 at 9:14:52 am'! -!Object methodsFor: 'private' stamp: 'jmv 4/24/2019 20:40:04' prior: 50382696! - primitiveError: aString - "This method is called when the error handling results in a recursion in - calling on error: or halt or halt:." - - | context emergencyEvaluator lines r | - r _ `10@10` extent: (Display extent -20 min: `700@1000`). - lines _ r height // AbstractFont default lineSpacing. - emergencyEvaluator _ Transcripter newInFrame: r. - emergencyEvaluator - nextPutAll: '***System error handling failed***'; newLine; - nextPutAll: aString; newLine; - nextPutAll: '-------------------------------'; newLine. - context _ thisContext sender sender. - (30 min: lines - 10) timesRepeat: [context ifNotNil: [emergencyEvaluator print: (context _ context sender); newLine]]. - emergencyEvaluator - nextPutAll: '-------------------------------'; newLine; - nextPutAll: 'Type ''revert'' to revert your last method change.'; newLine; - nextPutAll: 'Type ''exit'' to exit the emergency evaluator.'; newLine. - emergencyEvaluator readEvalPrint! ! -!Transcripter methodsFor: 'accessing' stamp: 'jmv 4/24/2019 20:40:14' prior: 50386617! -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]. - textComposition - setModel: (TextModel withText: c asText); - extentForComposing: frame width-8 @9999. - textComposition composeAll. - d _ textComposition usedHeight - frame height. - d > 0 ifTrue: [ - "Scroll up to keep all contents visible" - cb _ textComposition characterBlockAtPoint: - `0@0` + (0@(d+AbstractFont default lineSpacing)). - self on: (c copyFrom: cb stringIndex to: c size). - readLimit _ position _ collection size. - ^ self endEntry]. - Display fill: (frame insetBy: -2) fillColor: self black; - fill: frame fillColor: self white. - Display getCanvas - textComposition: textComposition - bounds: (`4@4` + frame topLeft extent: Display extent) - color: `Color black` - selectionColor: `Color blue`. - DisplayScreen screenUpdateRequired: nil! ! -!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'jmv 4/24/2019 20:59:12' prior: 50382880! - defaultAction - - | delta textFrame barFrame outerFrame result range width filledWidth f h textWidth textForm innerBarFrame oldFilledWidth oldFilledWidth2 prevContents | - f _ AbstractFont default. - h _ f lineSpacing * 3//2. - textWidth _ (f widthOfString: progressTitle) + h. - width _ 150 max: textWidth. - - textForm _ Form extent: width@h depth: 32. - textForm fillBlack. - textForm fillWhite: (textForm boundingBox insetBy: 2). - progressTitle displayOn: textForm at: (width-textWidth+h//2@4). - barFrame _ Rectangle center: aPoint extent: width@h. - textFrame _ `0@0` extent: width@h. - textFrame _ textFrame - aligned: textFrame bottomCenter - with: barFrame topCenter + `0@2`. - outerFrame _ barFrame merge: textFrame. - delta _ outerFrame amountToTranslateWithin: Display boundingBox. - barFrame _ barFrame translatedBy: delta. - textFrame _ textFrame translatedBy: delta. - outerFrame _ outerFrame translatedBy: delta. - prevContents _ Form fromDisplay: outerFrame. - range _ maxVal = minVal ifTrue: [1] ifFalse: [maxVal - minVal]. "Avoid div by 0" - innerBarFrame _ barFrame insetBy: 2. - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - oldFilledWidth _ 0. - oldFilledWidth2 _ 0. - result _ workBlock value: "Supply the bar-update block for evaluation in the work block" - [ :barVal | - barVal - ifNotNil: [ currentVal _ barVal ] - ifNil: [ - currentVal _ currentVal + 1. - currentVal >= maxVal - ifTrue: [ currentVal _ minVal ]]. - filledWidth _ ((barFrame width-4) asFloat * ((currentVal-minVal) asFloat / range min: 1.0)) asInteger. - filledWidth > oldFilledWidth ifTrue: [ - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - Display fillGray: (barFrame topLeft + `2@2` extent: filledWidth@17). - filledWidth -200 > oldFilledWidth2 - ifFalse: [ - "Usually just request an update, to be done asynchronously." - DisplayScreen screenUpdateRequired: outerFrame ] - ifTrue: [ - "Once in a while, force a real screen update (warning: really slow on MacOS if done too often)" - Display forceToScreen: outerFrame. oldFilledWidth2 _ filledWidth ]. - oldFilledWidth _ filledWidth ]]. - prevContents displayAt: outerFrame topLeft. - self resume: result! ! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 4/24/2019 20:41:49' prior: 50394649! - standardWindowExtent - "Answer the standard default extent for new windows. " - - | grid allowedArea maxLevel | - "NOTE: following copied from strictlyStaggeredInitialFrameFor:" - allowedArea _ self maximumUsableArea insetBy: ( - self scrollBarSetback @ self screenTopSetback extent: `0@0` - ). - "Number to be staggered at each corner (less on small screens)" - maxLevel _ allowedArea area > 700000 ifTrue: [3] ifFalse: [2]. - "Amount by which to stagger (less on small screens)" - grid _ allowedArea area > 700000 ifTrue: [40] ifFalse: [20]. - ^ (allowedArea extent - (grid*(maxLevel+1*2) + (grid//2))) min: `52@40` * Preferences standardCodeFont lineSpacing! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 4/24/2019 20:29:10' prior: 50390687! - displayOn: aForm in: aRectangle - " - 1 to: 2000 do: [ :i | i print ]. - 1 to: 750 do: [ :i | i print ]. - Transcript displayOn: Display in: bounds - " - | font count string x y fh canvas innerR index | - aForm fill: aRectangle fillColor: `Color white`. - font _ AbstractFont default. - - innerR _ aRectangle insetBy: self padding. - canvas _ aForm getCanvas. - canvas newClipRect: innerR. - x _ innerR left. - y _ innerR top. - fh _ font lineSpacing. - count _ lastIndex - firstIndex \\ self maxEntries + 1 min: innerR height // fh - 1. - index _ lastIndex - count \\ self maxEntries + 1. - count timesRepeat: [ - string _ entries at: index. - canvas drawString: string at: x@y font: font color: `Color veryDarkGray`. - y _ y + fh. - index _ index \\ self maxEntries + 1 ]. - string _ unfinishedEntry contents. - canvas drawString: string at: x@y font: font color: `Color veryDarkGray`! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 4/24/2019 20:42:17' prior: 50386852! - displayUnfinishedEntryOn: aForm - - | font count string x y fh canvas r innerR | - innerR _ bounds insetBy: self padding. - lastDisplayPosition < innerR right ifTrue: [ - font _ AbstractFont default. - fh _ font lineSpacing. - count _ innerR height // fh-1. - x _ innerR left. - string _ unfinishedEntry contents. - y _ ((lastIndex - firstIndex \\ self maxEntries) min: count-1) + 1 * font lineSpacing + innerR top. - canvas _ aForm getCanvas. - r _ innerR left: lastDisplayPosition. - canvas newClipRect: r. - (canvas drawString: string at: x@y font: font color: `Color veryDarkGray`) ifNotNil: [ :lastPoint | - lastDisplayPosition _ lastPoint x. - ^r ]]. - ^nil! ! -!GrafPort methodsFor: 'text' stamp: 'jmv 4/24/2019 20:41:09' prior: 16850109! - basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font - "Answer last affected pixel position" - - destY _ aPoint y. - destX _ aPoint x. - - "the following are not really needed, but theBitBlt primitive will fail if not set" - sourceX ifNil: [sourceX _ 100]. - width ifNil: [width _ 100]. - - self primDisplayString: aString from: startIndex to: stopIndex - map: font characterToGlyphMap xTable: font xTable - kern: font baseKern. - ^ destX@(destY+font lineSpacing)! ! -!GrafPort methodsFor: 'text' stamp: 'jmv 4/22/2019 13:06:08' prior: 50358907! - displayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: aStrikeFont color: foregroundColor - "If required, do a second pass with new rule and colorMap. - Answer last affected pixel position - Answer nil if nothing was done - " - - | answer prevRule secondPassMap sourceDepth destDepth | - - "Slight optimization when there's nothing to do." - clipHeight = 0 ifTrue: [^nil]. - clipWidth = 0 ifTrue: [^nil]. - - self installStrikeFont: aStrikeFont foregroundColor: (foregroundColor alpha: 1). - - "If combinationRule is rgbMul, we might need the special two-pass technique for component alpha blending. - If not, do it simply" - combinationRule = 37 "rgbMul" ifFalse: [ - ^self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: aStrikeFont ]. - - "We need to do a second pass. The colormap set is for use in the second pass." - secondPassMap _ colorMap. - sourceDepth _ sourceForm depth. - destDepth _ destForm depth. - colorMap _ sourceDepth ~= destDepth - ifTrue: [ Color cachedColormapFrom: sourceDepth to: destDepth ]. - answer := self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: aStrikeFont. - colorMap := secondPassMap. - secondPassMap ifNotNil: [ - prevRule := combinationRule. - combinationRule := 20. "rgbAdd" - self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: aStrikeFont. - combinationRule := prevRule ]. - ^answer! ! -!GrafPort methodsFor: 'private' stamp: 'jmv 4/25/2019 09:14:34' prior: 16850216! - installStrikeFont: aStrikeFont foregroundColor: foregroundColor - - sourceForm _ aStrikeFont glyphs. - sourceY _ 0. - height _ sourceForm height. - self setRuleAndMapFor: sourceForm depth foregroundColor: foregroundColor! ! -!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jmv 4/24/2019 21:03:12' prior: 50368766! - label: aStringOrNil font: aFontOrNil - "Label this button with the given string." - label _ aStringOrNil. - font _ aFontOrNil. - (self fontToUse notNil and: [ label notNil ]) - ifTrue: [ "Add a bit of padding" - extent := (self fontToUse widthOfString: label) + 10 @ (self fontToUse lineSpacing + 10) ]! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 4/24/2019 20:58:58' prior: 50367612! - drawEmbossedLabelOn: aCanvas - - | availableW center colorForLabel f l labelMargin targetSize w x y | - label ifNotNil: [ - colorForLabel _ Theme current buttonLabel. - self isPressed - ifFalse: [ - self mouseIsOver - ifFalse: [ colorForLabel _ colorForLabel adjustSaturation: -0.10 brightness: 0.10 ]] - ifTrue: [ colorForLabel _ colorForLabel adjustSaturation: 0.0 brightness: -0.07 ]. - f _ self fontToUse. - center _ extent // 2. - labelMargin _ 3. - w _ f widthOfString: label. - availableW _ extent x - labelMargin - labelMargin. - availableW >= w - ifTrue: [ - l _ label ] - ifFalse: [ - x _ labelMargin. - targetSize _ label size * availableW // w. - l _ label squeezedTo: targetSize. - (f widthOfString: l) > availableW ifTrue: [ - targetSize _ targetSize - 1. - l _ label squeezedTo: targetSize ]]. - - w _ f widthOfString: l. - x _ center x - (w // 2). - y _ center y - (f lineSpacing // 2). - aCanvas - drawString: l - at: x@y - font: f - color: colorForLabel - embossed: true ]! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 4/24/2019 20:59:05' prior: 50367647! - drawRegularLabelOn: aCanvas - - | w f center x y availableW l labelMargin | - - f _ self fontToUse. - center _ extent // 2. - - label ifNotNil: [ - labelMargin _ 4. - w _ f widthOfString: label. - availableW _ extent x - labelMargin - labelMargin - 1. - availableW >= w - ifTrue: [ - x _ center x - (w // 2). - l _ label ] - ifFalse: [ - x _ labelMargin. - l _ label squeezedTo: (label size * availableW / w) rounded ]. - y _ center y - (f lineSpacing // 2). - self isPressed ifTrue: [ - x _ x + 1. - y _ y + 1 ]. - aCanvas - drawString: l - at: x@y - font: f - color: Theme current buttonLabel ]! ! -!PluggableListMorph methodsFor: 'geometry' stamp: 'jmv 4/24/2019 20:41:36' prior: 16888733! - scrollDeltaHeight - "Return the increment in pixels which this pane should be scrolled." - ^ self font lineSpacing! ! -!TextModelMorph methodsFor: 'geometry' stamp: 'jmv 4/24/2019 20:40:10' prior: 16934097! - scrollDeltaHeight - "Return the increment in pixels which this pane should be scrolled." - - ^ AbstractFont default lineSpacing! ! -!SystemWindow methodsFor: 'geometry' stamp: 'jmv 4/24/2019 20:40:08' prior: 16926187! - minPaneHeightForReframe - ^AbstractFont default lineSpacing + 10! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 4/24/2019 20:42:07' prior: 50384700! - boxExtent - "answer the extent to use in all the buttons. - - the label height is used to be proportional to the fonts preferences" - | e | - Theme current minimalWindows ifTrue: [^`0@0`]. - e _ Preferences windowTitleFont lineSpacing. - ^e@e! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'jmv 4/24/2019 20:41:02' prior: 50384811! - initialExtent - - ^`540@400` * Preferences standardCodeFont lineSpacing // 14! ! -!CodeWindow methodsFor: 'GUI building' stamp: 'jmv 4/24/2019 20:39:53' prior: 16813005! - defaultAnnotationPaneHeight - "Answer the receiver's preferred default height for new annotation panes." - - ^ AbstractFont default lineSpacing * 2 + 8! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'jmv 4/24/2019 20:39:50' prior: 50426580! - buildMorphicClassColumnWith: classList - - | column | - - column _ LayoutMorph newColumn. - column - addMorphUseAll: classList; - addAdjusterAndMorph: self buildMorphicSwitches fixedHeight: (Theme current minimalWindows ifTrue: [AbstractFont default lineSpacing + 4] ifFalse: [AbstractFont default lineSpacing *2-4]). - - ^column! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'jmv 4/24/2019 20:40:51' prior: 50448766! - buildNoSysCatMorphicWindow - "A Browser without the class categories list" - - | mySingletonList upperPanes messageCatList messageList classColumn classList | - mySingletonList _ PluggableListMorph - model: model - listGetter: #systemCategorySingleton - indexGetter: #indexIsOne - indexSetter: #indexIsOne: - mainView: self - menuGetter: #systemCatSingletonMenu - keystrokeAction: #systemCatSingletonKey:from:. - mySingletonList hideScrollBarsIndefinitely. - - classColumn _ self buildMorphicClassColumn. - classList _ classColumn submorphs third. - messageCatList _ self buildMorphicMessageCatList. - messageList _ self buildMorphicMessageList. - - classList rightSibling: messageCatList. - messageCatList leftSibling: classList rightSibling: messageList. - messageList leftSibling: messageCatList. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: classColumn proportionalWidth: 0.3; - addAdjusterAndMorph: messageCatList proportionalWidth: 0.3; - addAdjusterAndMorph: messageList proportionalWidth: 0.4. - - messageList makeItemsDraggable. - messageCatList - acceptDropsFrom: messageList - performing: #categorizeUnderCategoryAt:selector: - whenOutsideList: #categorizeUnderNewCategorySelector:. - - self layoutMorph - addMorph: mySingletonList fixedHeight: Preferences standardCodeFont lineSpacing + 10; - addAdjusterAndMorph: upperPanes proportionalHeight: 0.3; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.7. - - model changed: #editSelection! ! -!CodeFileBrowserWindow methodsFor: 'GUI building' stamp: 'jmv 4/24/2019 20:40:59' prior: 16809559! - buildMorphicWindow - "Create a pluggable version of all the views for a Browser, using Morphic widgets." - - | list1 list2 upperPanes | - model systemCategoryListIndex: 1. - list1 _ PluggableListMorph - model: model - listGetter: #systemCategorySingleton - indexGetter: #indexIsOne - indexSetter: #indexIsOne: - mainView: self - menuGetter: #codeFileListMenu - keystrokeAction: #codeFileListKey:from:. - list1 hideScrollBarsIndefinitely. - - list2 _ PluggableListMorph - model: model - listGetter: #messageCategoryList - indexGetter: #messageCategoryListIndex - indexSetter: #messageCategoryListIndex: - mainView: self - menuGetter: #messageCategoryMenu - keystrokeAction: nil. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: self buildMorphicClassColumn proportionalWidth: 0.3; - addAdjusterAndMorph: list2 proportionalWidth: 0.3; - addAdjusterAndMorph: self buildMorphicMessageList proportionalWidth: 0.4. - - self layoutMorph - addMorph: list1 fixedHeight: Preferences standardCodeFont lineSpacing + 10; - addAdjusterAndMorph: upperPanes proportionalHeight: 0.3; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.7. - model changed: #editSelection! ! -!ChangeSorterWindow methodsFor: 'GUI building' stamp: 'jmv 4/24/2019 20:40:56' prior: 50384817! - initialExtent - ^`540@300` * Preferences standardCodeFont lineSpacing // 14! ! -!PreDebugWindow methodsFor: 'GUI building' stamp: 'jmv 4/24/2019 20:41:45' prior: 50384823! - initialExtent - ^ `640 @ 320` * Preferences standardCodeFont lineSpacing // 14! ! -!InspectorWindow methodsFor: 'GUI building' stamp: 'jmv 4/24/2019 20:41:30' prior: 50384829! - initialExtent - - ^`600@325` * Preferences standardCodeFont lineSpacing // 14! ! -!ObjectExplorerWindow methodsFor: 'GUI building' stamp: 'jmv 4/24/2019 20:41:33' prior: 50384835! - initialExtent - - ^`300@500` * Preferences standardCodeFont lineSpacing // 14! ! -!AutoCompleterMorph class methodsFor: 'preferences' stamp: 'jmv 4/24/2019 20:40:46' prior: 16781661! - itemHeight - "height must be forced to be even to allow the detail arrow to be drawn correctly" - ^ (self listFont lineSpacing + 2) roundUpTo: 2"14".! ! -!StringMorph methodsFor: 'geometry' stamp: 'jmv 4/24/2019 20:45:28' prior: 50337419! - measureContents - | f | - f _ self fontToUse. - ^((f widthOfString: contents) max: 3) @ f lineSpacing! ! -!LayoutMorph methodsFor: 'private' stamp: 'jmv 4/24/2019 20:40:01' prior: 16863561! - minPaneHeightForReframe - ^AbstractFont default lineSpacing + 10! ! -!TaskbarMorph methodsFor: 'initialization' stamp: 'jmv 4/24/2019 20:42:10' prior: 50337216! - defaultHeight - - ^ Preferences windowTitleFont lineSpacing * 2 * self scale! ! -!InnerListMorph methodsFor: 'list management' stamp: 'jmv 4/24/2019 20:41:19' prior: 16855072! - drawBoundsForRow: row - "calculate the bounds that row should be drawn at. This might be outside our bounds!!" - - self flag: #jmvVer2. - "revisar senders" - ^ 0 @ (self drawYForRow: row) extent: extent x @ font lineSpacing! ! -!InnerListMorph methodsFor: 'list management' stamp: 'jmv 4/24/2019 20:41:22' prior: 16855082! - drawYForRow: row - "calculate the vertical position that row should be drawn at. This might be outside our bounds!!" - ^ row - 1 * font lineSpacing! ! -!InnerListMorph methodsFor: 'list management' stamp: 'jmv 4/24/2019 20:41:25' prior: 16855098! - rowAtLocation: aPoint - "return the number of the row at aPoint" - - listItems isEmpty ifTrue: [ ^0 ]. - ^aPoint y // font lineSpacing + 1 min: listItems size max: 1! ! -!InnerListMorph methodsFor: 'list management' stamp: 'jmv 4/24/2019 20:41:27' prior: 50426118! - rowAtLocation: aPoint ifNone: aNoneBlock - - | potentialRowNumber | - - potentialRowNumber := aPoint y // font lineSpacing + 1. - - ^(listItems isInBounds: potentialRowNumber) - ifTrue: [ potentialRowNumber ] - ifFalse: aNoneBlock! ! -!InnerListMorph methodsFor: 'geometry' stamp: 'jmv 4/24/2019 20:41:16' prior: 16855313! - adjustExtent - "Adjust our height to match the underlying list, - but make it wider if neccesary to fill the available width in our PluggableListMorph - (this is needed to make the selection indicator no narrower than the list)" - self morphExtent: - self desiredWidth @ ((listItems size max: 1) * font lineSpacing) -! ! -!InnerTextMorph methodsFor: 'geometry' stamp: 'jmv 4/24/2019 20:39:58' prior: 16855883! - minimumExtent - - ^(9@(AbstractFont default lineSpacing+2))! ! -!InnerTextMorph methodsFor: 'private' stamp: 'jmv 4/24/2019 20:38:42' prior: 16855971! - fit - "Adjust my bounds to fit the text. - Required after the text changes, - or if wrapFlag is true and the user attempts to change the extent." - - | newExtent newHeight newWidth | - newWidth _ extent x. - "Adjust width only if we don't wrap text to own width!!" - wrapFlag ifFalse: [ - newWidth _ self textComposition usedWidth max: 9 ]. - newHeight _ self textComposition usedHeight max: AbstractFont default lineSpacing + 2. - newExtent _ newWidth @ newHeight. - extent = newExtent - ifTrue: [ - self redrawNeeded. - "Too conservative: only text composition (because of changes in text or styles, etc) - should cause invalidation. - Try to avoid calling #fit unless needed." - ] - ifFalse: [ - extent = newExtent ifFalse: [ - self redrawNeeded. - extent _ newExtent. - self someSubmorphPositionOrExtentChanged. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]]. - - owner innerHeight: newExtent y! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jmv 4/24/2019 20:39:55' prior: 16844192! - sizeUnit - ^AbstractFont default lineSpacing! ! -!TextComposer methodsFor: 'as yet unclassified' stamp: 'jmv 4/24/2019 20:59:37' prior: 16930448! - addEmptyTrailingLine: isANewParagraph - "The line to add is usually the first line of a new paragraph (if last char in text was newLine), - but it can be a new line in same paragraph (if enough spaces ended last line)." - | ts f h bs r lm rm w a leftMarginForAlignment s | - s _ theText size+1. - f _ editor - ifNotNil: [ editor lastFont ] - ifNil: [ theText fontAt: s default: self defaultFont ]. - ts _ editor - ifNotNil: [ editor lastParagraphStyleOrNil ] - ifNil: [ theText paragraphStyleOrNilAt: s]. - - h _ f lineSpacing. - bs _ f ascent. - lm _ 0. - rm _ 0. - w _ extentForComposing x. - a _ 0. - ts ifNotNil: [ - isANewParagraph ifTrue: [ - h _ h + ts spaceBefore. - bs _ bs + ts spaceBefore ]. - lm _ ((isANewParagraph and: [ ts isListStyle not ]) - ifTrue: [ ts firstIndent ] - ifFalse: [ ts restIndent ]). - rm _ ts rightIndent. - a _ ts alignment ]. - - leftMarginForAlignment _ a = CharacterScanner rightFlushCode - ifTrue: [ w - rm] - ifFalse: [ - a = CharacterScanner centeredCode - ifTrue: [ (w - rm - lm) //2 + lm] - ifFalse: [ lm ]]. - r _ leftMarginForAlignment @ currentY extent: 0@h. - - lines addLast: ( - EmptyLine new - firstIndex: s lastIndex: s - 1; - rectangle: r; - lineHeight: h baseline: bs; - paragraphStyle: ts)! ! -!Theme methodsFor: 'other options' stamp: 'jmv 4/24/2019 20:42:14' prior: 16935668! - buttonPaneHeight - "Answer the user's preferred default height for button panes." - - ^Preferences standardButtonFont lineSpacing * 14 // 8! ! -!PopUpMenu methodsFor: 'accessing' stamp: 'jmv 4/24/2019 20:41:39' prior: 16890903! -frameHeight - "Designed to avoid the entire frame computation (includes MVC form), - since the menu may well end up being displayed in Morphic anyway." - | nItems | - nItems _ 1 + labelString lineCount. - ^ (nItems * Preferences standardMenuFont lineSpacing) + 4 "border width"! ! -!PopUpMenu methodsFor: 'basic control sequence' stamp: 'jmv 4/24/2019 20:41:42' prior: 16890928! - startUpSegmented: segmentHeight withCaption: captionOrNil at: location allowKeyboard: aBoolean - "This menu is too big to fit comfortably on the screen. - Break it up into smaller chunks, and manage the relative indices. - Inspired by a special-case solution by Reinier van Loon. The boolean parameter indicates whether the menu should be given keyboard focus (if in morphic)" - -" -(PopUpMenu labels: (String streamContents: [:s | 1 to: 100 do: [:i | s print: i; newLine]. s skip: -1]) - lines: (5 to: 100 by: 5)) startUpWithCaption: 'Give it a whirl...'. -" - | nLines nLinesPer allLabels from to subset subLines index | - allLabels := labelString lines. - nLines _ allLabels size. - lineArray ifNil: [lineArray _ Array new]. - nLinesPer _ segmentHeight // Preferences standardMenuFont lineSpacing - 5. - from := 1. - [ true ] whileTrue: [ - to := (from + nLinesPer) min: nLines. - subset := (allLabels copyFrom: from to: to) asOrderedCollection. - subset add: (to = nLines ifTrue: ['start over...'] ifFalse: ['more...']) - before: subset first. - subLines _ lineArray select: [:n | n >= from] thenCollect: [:n | n - (from-1) + 1]. - subLines _ (Array with: 1) , subLines. - index := (PopUpMenu labels: subset printStringWithNewline lines: subLines) - startUpWithCaption: captionOrNil at: location allowKeyboard: aBoolean. - index = 1 - ifTrue: [from := to + 1. - from > nLines ifTrue: [ from := 1 ]] - ifFalse: [index = 0 ifTrue: [^ 0]. - ^ from + index - 2]]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3710-FontRefactor2-JuanVuletich-2019Apr25-08h41m-jmv.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3710] on 25 April 2019 at 10:12:27 am'! -!StrikeFont methodsFor: 'accessing' stamp: 'jmv 4/25/2019 10:10:55' prior: 50372396! - baseKern - "Return the base kern value to be used for all characters. - What follows is some 'random' text used to visually adjust this method. - HaHbHcHdHeHfHgHhHiHjHkHlHmHnHoHpHqHrHsHtHuHvHwHxHyHzH - HAHBHCHDHEHFHGHHHIHJHKHLHMHNHOHPHQHRHSHTHUHVHWHXHYHXZH - wok yuyo wuwu vuvu rucu tucu WUWU VUVU huevo HUEVO to - k y mate runico ridiculo ARABICO AAAAA TOMATE - TUTU - tatadalajafua - abacadafagahaqawaearatayauaiaoapasadafagahajakalazaxacavabanama - kUxUxa - q?d?h?l?t?f?j?" - - | italic baseKern | - italic _ self isItalic. - - "Assume synthetic will not affect kerning (i.e. synthetic italics are not used)" - "After all, DejaVu Sans are the only StrikeFonts used in Cuis..." -" self familyName = 'DejaVu Sans' - ifTrue: [" - baseKern _ (italic or: [ pointSize < 9 ]) - ifTrue: [ -1 ] - ifFalse: [ 0 ]. - pointSize >= 13 ifTrue: [ - baseKern _ baseKern +1 ]. - pointSize >= 20 ifTrue: [ - baseKern _ baseKern +1 ]"] - ifFalse: [ - baseKern _ pointSize < 12 - ifTrue: [ -1 ] - ifFalse: [ 0 ]. - italic ifTrue: [ - baseKern _ baseKern - 1]]". - - "If synthetic italic" - "See makeItalicGlyphs" - (self isSynthetic and: [ italic and: [ self isBold ]]) ifTrue: [ - baseKern _ baseKern - ((self lineSpacing-1-self ascent+4)//4 max: 0) - - (((self ascent-5+4)//4 max: 0)) ]. - ^baseKern! ! -!StrikeFont methodsFor: 'emphasis' stamp: 'jmv 4/25/2019 10:11:20' prior: 16914509! - makeItalicGlyphs - "Make an italic set of glyphs with same widths by skewing left and right. - In the process, characters would overlap, so we widen them all first. - " - | extraWidth newGlyphs newXTable x newX w extraOnLeft | - extraOnLeft _ (self lineSpacing-1-self ascent+4)//4 max: 0. - extraWidth _ ((self ascent-5+4)//4 max: 0) + extraOnLeft. - newGlyphs _ Form extent: (glyphs width + (maxAscii + 1 - minAscii*extraWidth)) @ glyphs height depth: glyphs depth. - newGlyphs fillWhite. - newXTable _ xTable copy. - - "Copy glyphs into newGlyphs with room on left and right for overlap." - minAscii to: maxAscii+1 do: - [:ascii | x _ xTable at: ascii+1. w _ (xTable at: ascii+2) - x. - newX _ newXTable at: ascii+1. - newGlyphs copy: ((newX + extraOnLeft) @ 0 extent: w @ glyphs height) - from: x @ 0 in: glyphs rule: Form over. - newXTable at: ascii+2 put: newX + w + extraWidth]. - glyphs _ newGlyphs. - xTable _ newXTable. - "Slide the bitmaps left and right for synthetic italic effect." - 4 to: self ascent-1 by: 4 do: - [:y | "Slide ascenders right..." - glyphs copy: (1@0 extent: glyphs width @ (self ascent - y)) - from: 0@0 in: glyphs rule: Form over]. - self ascent to: self height-1 by: 4 do: - [:y | "Slide descenders left..." - glyphs copy: (0@y extent: glyphs width @ glyphs height) - from: 1@y in: glyphs rule: Form over]. - self isSynthetic: true! ! -!StrikeFont methodsFor: 'file in/out' stamp: 'jmv 4/25/2019 10:11:24' prior: 16914590! - printOn: aStream - super printOn: aStream. - aStream - nextPut: $(; - nextPutAll: self name; - space; - print: self lineSpacing; - nextPut: $)! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 4/25/2019 10:10:59' prior: 16914664! - glyphAt: character - "Answer a Form copied out of the glyphs for the argument, character." - | ascii leftX rightX | - ascii _ character numericValue. - (ascii between: minAscii and: maxAscii) ifFalse: [ascii _ maxAscii + 1]. - leftX _ xTable at: ascii + 1. - rightX _ xTable at: ascii + 2. - ^ glyphs copy: (leftX @ 0 corner: rightX @ self lineSpacing)! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 4/25/2019 10:11:09' prior: 16914677! - glyphAt: character put: characterForm - "Copy characterForm over the glyph for the argument, character." - | ascii leftX rightX widthDif newGlyphs | - ascii _ character numericValue. - ascii < minAscii ifTrue: [^ self error: 'Cant store characters below min ascii']. - ascii > maxAscii ifTrue: - [(self confirm: -'This font does not accomodate ascii values higher than ' , maxAscii printString , '. -Do you wish to extend it permanently to handle values up to ' , ascii printString) - ifTrue: [self extendMaxAsciiTo: ascii] - ifFalse: [^ self error: 'No change made']]. - leftX _ xTable at: ascii + 1. - rightX _ xTable at: ascii + 2. - widthDif _ characterForm width - (rightX - leftX). - widthDif ~= 0 ifTrue: - ["Make new glyphs with more or less space for this char" - newGlyphs _ Form extent: (glyphs width + widthDif) @ glyphs height depth: glyphs depth. - newGlyphs copy: (0@0 corner: leftX@glyphs height) - from: 0@0 in: glyphs rule: Form over. - newGlyphs copy: ((rightX+widthDif)@0 corner: newGlyphs width@glyphs height) - from: rightX@0 in: glyphs rule: Form over. - glyphs _ newGlyphs. - "adjust further entries on xTable" - xTable _ xTable copy. - ascii+2 to: xTable size - do: [:i | xTable at: i put: (xTable at: i) + widthDif]]. - glyphs copy: (leftX @ 0 extent: characterForm extent) - from: 0@0 in: characterForm rule: Form over -" -| f | f _ AbstractFont default. -f glyphAt: $ put: (Form extent: (f widthOf: $ )+10@f lineSpacing) -"! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3711-FontRefactor3-JuanVuletich-2019Apr25-10h06m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3710] on 25 April 2019 at 10:25:07 am'! -!Object methodsFor: 'private' stamp: 'jmv 4/25/2019 10:24:39'! - deprecatedMethod - "Warn that this method is deprecated and should not be used" - - '========' print. - thisContext sender print. - '--------------' print. - 'This method is deprecated. It will be removed from the system. Please change this and any other related senders.' print. - '--------------' print. - thisContext sender printStack: 6. - '========' print.! ! -!AbstractFont methodsFor: 'accessing' stamp: 'jmv 4/25/2019 10:21:53' prior: 50453258! - height - "Answer the line spacing. Prefer calling #lineSpacing, that is more explicit. - Besides, #height is false polymorphism, Fonts are not interchangeable with Form or Rectangle!!" - - self deprecatedMethod. - ^self lineSpacing! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3712-DeprecationWarning-JuanVuletich-2019Apr25-10h12m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3707] on 24 April 2019 at 9:22:51 pm'! -!TextModelMorph methodsFor: 'accessing' stamp: 'pb 4/24/2019 20:32:26'! - emptyTextDisplayMessage: aString - self - setProperty: #emptyTextDisplayMessage - toValue: aString.! ! -!FillInTheBlankMorph methodsFor: 'accessing' stamp: 'pb 4/24/2019 21:14:06'! - emptyTextDisplayMessage: aString - self - setProperty: #emptyTextDisplayMessage - toValue: aString.! ! -!Theme methodsFor: 'colors' stamp: 'pb 4/24/2019 20:46:25'! - textEmptyDisplayMessage - ^ `Color veryLightGray`! ! -!Browser methodsFor: 'class functions' stamp: 'pb 4/24/2019 20:20:32' prior: 16791512! - classCommentText - "return the text to display for the comment of the currently selected class" - | theClass | - theClass _ self selectedClassOrMetaClass. - ^ Text - initialFont: Preferences standardCodeFont - stringOrText: - ((theClass notNil and: [ theClass hasComment ]) - ifTrue: [ theClass comment ] - ifFalse: [ '' ]).! ! -!MessageNames methodsFor: 'initialization' stamp: 'pb 4/24/2019 20:40:35' prior: 16867714! - initialize - super initialize. - searchString _ ''! ! -!TextModelMorph methodsFor: 'drawing' stamp: 'pb 4/24/2019 20:57:54' prior: 50387805! - drawOn: aCanvas - "Include a thin red inset border for unaccepted edits, or, if the unaccepted edits are known to conflict with a change made somewhere else to the same method (typically), put a thick red frame" - | bw bc | - self flag: #todo. - "Integrate this method with the Theme system. --cbr" - super drawOn: aCanvas. - bw _ Preferences focusIndicatorWidth. - bc _ nil. - self wantsFrameAdornments ifTrue: [ - model refusesToAccept - ifTrue: [ "Put up feedback showing that code cannot be submitted in this state" - bc _ Color tan ] - ifFalse: [ - self textMorph hasEditingConflicts - ifTrue: [ - bw _ 3. - bc _ Color red ] - ifFalse: [ - self textMorph hasUnacceptedEdits ifTrue: [ bc _ Color red ]]]]. - (drawKeyboardFocusIndicator and: [ self textMorph hasKeyboardFocus ]) - ifTrue: [ bc ifNil: [ bc _ Theme current focusIndicator ]] - ifFalse: [ - bc ifNotNil: [ - bc _ bc - alphaMixed: 0.4 - with: Color white ]]. - bc ifNotNil: [ - aCanvas - frameRectangle: self focusIndicatorRectangle - borderWidth: bw - color: bc ]. - model actualContents isEmpty ifTrue: [ - self - valueOfProperty: #emptyTextDisplayMessage - ifPresentDo: [ :msg | - aCanvas - drawString: msg - at: `0 @ 0` - font: nil - color: Theme current textEmptyDisplayMessage ]].! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'pb 4/24/2019 20:22:29' prior: 16793063! - buildMorphicCommentPane - "Construct the pane that shows the class comment." - ^ (BrowserCommentTextMorph - textProvider: model - textGetter: #classCommentText - textSetter: #newClassComment:) emptyTextDisplayMessage: 'THIS CLASS HAS NO COMMENT!!'.! ! -!MessageNamesWindow methodsFor: 'GUI building' stamp: 'pb 4/24/2019 20:40:18' prior: 16867755! - buildMorphicWindow - "Answer a morphic window with the given initial search string, nil if none" - -"MessageNames openMessageNames" - - | selectorListView firstRow searchButton secondRow | - textMorph _ (TextModelMorph - textProvider: model - textGetter: #searchString - textSetter: #searchString: - selectionGetter: #contentsSelection) emptyTextDisplayMessage: 'type here, then hit Search'. - textMorph textMorph setProperty: #alwaysAccept toValue: true. - textMorph askBeforeDiscardingEdits: false. - textMorph acceptOnCR: true. - textMorph hideScrollBarsIndefinitely. - - searchButton _ PluggableButtonMorph new - model: textMorph textMorph; - label: 'Search'; - action: #acceptContents. - searchButton setBalloonText: 'Type some letters into the pane at right, and then press this Search button (or hit RETURN) and all method selectors that match what you typed will appear in the list pane below. Click on any one of them, and all the implementors of that selector will be shown in the right-hand pane, and you can view and edit their code without leaving this tool.'. - - firstRow _ LayoutMorph newRow. - firstRow color: self windowColor. - firstRow - doAdoptWidgetsColor; - addMorph: searchButton proportionalWidth: 0.25; - addMorph: textMorph proportionalWidth: 0.75. - - selectorListView _ PluggableListMorph - model: model - listGetter: #selectorList - indexGetter: #selectorListIndex - indexSetter: #selectorListIndex: - mainView: self - menuGetter: #selectorListMenu - keystrokeAction: #selectorListKey:from:. - secondRow _ LayoutMorph newRow. - secondRow - addMorph: selectorListView proportionalWidth: 0.5; - addAdjusterAndMorph: self buildMorphicMessageList proportionalWidth: 0.5. - - self layoutMorph - addMorph: firstRow fixedHeight: self defaultButtonPaneHeight+4; - addAdjusterAndMorph: secondRow proportionalHeight: 0.5; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.5. - model changed: #editSelection! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'pb 4/24/2019 21:15:30' prior: 50432781! - createTextPaneAcceptOnCR: acceptBoolean - "create the textPane" - | result | - self flag: #todo. - "Integrate this method with the Theme system. --cbr" - result _ TextModelMorph - textProvider: self - textGetter: #response - textSetter: #response: - selectionGetter: #selectionInterval. - self - valueOfProperty: #emptyTextDisplayMessage - ifPresentDo: [ :msg | - result emptyTextDisplayMessage: msg ]. - result - hasUnacceptedEdits: true; - acceptOnCR: acceptBoolean; - escAction: [ self cancelClicked ]; - morphExtent: `18 @ 5` * self sizeUnit. - self - addMorph: result - position: `1 @ 2` * self sizeUnit. - ^ result.! ! -!FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'pb 4/24/2019 21:19:42' prior: 16844242! - initializedInstance - | aFillInTheBlankMorph | - aFillInTheBlankMorph _ self new - emptyTextDisplayMessage: 'Enter answer here'; - - setQuery: 'queryString' - initialAnswer: '' - acceptOnCR: true. - aFillInTheBlankMorph responseUponCancel: 'returnOnCancel'. - ^ aFillInTheBlankMorph.! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3713-TextModelMorphEmptyMessage-PhilBellalouna-2019Apr24-20h08m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3713] on 26 April 2019 at 8:57:21 am'! -!ZeroDivide commentStamp: '' prior: 16946761! - ZeroDivide may be signaled when a mathematical division by 0 is attempted. - -It might be argued that x / 0.0 is Float infinity or Float negativeInfinity, with the sign of x; and that x / -0.0 is Float infinity or Float negativeInfinity, with the opposite sign of x. But usually infinities are not considered in numeric code. Client code might chose to catch the exception and resume with an appropriate value.! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3714-ZeroDivideComment-JuanVuletich-2019Apr26-08h55m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3713] on 26 April 2019 at 9:06:55 am'! -!Float class methodsFor: 'constants' stamp: 'jmv 4/26/2019 09:02:14' prior: 50451465! - denormalized - "Answer whether implementation supports denormalized numbers. - Allowing denormalized numbers guarantees that the result x - y is non-zero when x !!= y." - - ^true! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3715-CuisCore-JuanVuletich-2019Apr26-08h57m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3715] on 26 April 2019 at 11:10:25 am'! -!MessageNamesWindow methodsFor: 'GUI building' stamp: 'jmv 4/26/2019 11:03:57' prior: 50454358! - buildMorphicWindow - "Answer a morphic window with the given initial search string, nil if none" - -"MessageNames openMessageNames" - - | selectorListView firstRow searchButton secondRow | - textMorph _ (TextModelMorph - textProvider: model - textGetter: #searchString - textSetter: #searchString: - selectionGetter: #contentsSelection) emptyTextDisplayMessage: 'type here, then hit Search'. - textMorph askBeforeDiscardingEdits: false. - textMorph acceptOnCR: true. - textMorph hideScrollBarsIndefinitely. - - searchButton _ PluggableButtonMorph new - model: textMorph textMorph; - label: 'Search'; - action: #acceptContents. - searchButton setBalloonText: 'Type some letters into the pane at right, and then press this Search button (or hit RETURN) and all method selectors that match what you typed will appear in the list pane below. Click on any one of them, and all the implementors of that selector will be shown in the right-hand pane, and you can view and edit their code without leaving this tool.'. - - firstRow _ LayoutMorph newRow. - firstRow color: self windowColor. - firstRow - doAdoptWidgetsColor; - addMorph: searchButton proportionalWidth: 0.25; - addMorph: textMorph proportionalWidth: 0.75. - - selectorListView _ PluggableListMorph - model: model - listGetter: #selectorList - indexGetter: #selectorListIndex - indexSetter: #selectorListIndex: - mainView: self - menuGetter: #selectorListMenu - keystrokeAction: #selectorListKey:from:. - secondRow _ LayoutMorph newRow. - secondRow - addMorph: selectorListView proportionalWidth: 0.5; - addAdjusterAndMorph: self buildMorphicMessageList proportionalWidth: 0.5. - - self layoutMorph - addMorph: firstRow fixedHeight: self defaultButtonPaneHeight+4; - addAdjusterAndMorph: secondRow proportionalHeight: 0.5; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.5. - model changed: #editSelection! ! -!InnerTextMorph methodsFor: 'editing' stamp: 'jmv 4/26/2019 11:02:36' prior: 50379907! - acceptContents - "The message is sent when the user hits return or Cmd-S. - Accept the current contents and end editing." - "Inform the model of text to be accepted, and return true if OK." - - | accepted prevSelection prevScrollValue | - - prevSelection _ self editor selectionInterval copy. - prevScrollValue _ owner verticalScrollBar scrollValue. - - hasUnacceptedEdits ifFalse: [ self flash. ^true ]. - hasEditingConflicts ifTrue: [ - self confirmAcceptAnyway ifFalse: [self flash. ^false]]. - - accepted _ model acceptContentsFrom: owner. - "During the step for the browser, updatePaneIfNeeded is called, and - invariably resets the contents of the code-holding PluggableTextMorph - at that time, resetting the cursor position and scroller in the process. - The following line forces that update without waiting for the step, - then restores the cursor and scrollbar" - - "some implementors of acceptContentsFrom: answer self :(" - ^accepted == true - ifTrue: [ - model refetch. - self editor selectFrom: prevSelection first to: prevSelection last. - UISupervisor whenUIinSafeState: [ - self world ifNotNil: [ :w | w activeHand newKeyboardFocus: self ]. - owner verticalScrollBar internalScrollValue: prevScrollValue]. - true] - ifFalse: [ false ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3716-TextModelMorph-fix-JuanVuletich-2019Apr26-10h38m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3716] on 27 April 2019 at 5:17:15 pm'! -!Number class methodsFor: 'instance creation' stamp: 'jmv 4/27/2019 17:14:36' prior: 16880639! - readFrom: stringOrStream - "Answer a number as described on aStream. The number may - include a leading radix specification, as in 16rFADE" - | value base aStream sign | - aStream _ (stringOrStream isMemberOf: String) - ifTrue: [ReadStream on: stringOrStream] - ifFalse: [stringOrStream]. - (aStream nextMatchAll: 'NaN') ifTrue: [^ Float nan]. - sign _ (aStream peekFor: $-) ifTrue: [-1] ifFalse: [1]. - (aStream nextMatchAll: 'Infinity') ifTrue: [^ Float infinity * sign]. - base _ 10. - value _ Integer readFrom: aStream base: base. - (aStream peekFor: $r) - ifTrue: [ - "r" - (base _ value) < 2 ifTrue: [ - base = 1 ifTrue: [ ^Integer readBaseOneFrom: aStream ]. - ^self error: 'Invalid radix']. - (aStream peekFor: $-) ifTrue: [sign _ sign negated]. - value _ Integer readFrom: aStream base: base]. - (aStream peekFor: $x) - ifTrue: [ - "0x" "Hexadecimal" - base _ 16. - (aStream peekFor: $-) ifTrue: [sign _ sign negated]. - value _ Integer readFrom: aStream base: base]. - ^ self readRemainderOf: value from: aStream base: base withSign: sign.! ! -!Number class methodsFor: 'instance creation' stamp: 'jmv 4/27/2019 16:54:05' prior: 50414622! - readRemainderOf: integerPart from: aStream base: base withSign: sign - "Read optional fractional part and exponent, and return the final result" - | value fraction fracpos peekChar exp scale convertToFloat | - - convertToFloat := false. - value := integerPart. - (aStream peekFor: $.) - ifTrue: [ "." - (aStream atEnd not and: [ aStream peek digitValue between: 0 and: base - 1 ]) - ifTrue: [ - fracpos := aStream position. - fraction := Integer readFrom: aStream base: base. - fraction := fraction / (base raisedToInteger: aStream position - fracpos). - value := value + fraction. - convertToFloat := true ] - ifFalse: [ - "oops - just ." - aStream skip: -1. - "un-gobble the period" - ^ value * sign"Number readFrom: '3r-22.2'"]]. - peekChar := aStream peek. - ('deqp' includes: peekChar) - ifTrue: [ "(e|d|q)>" "(p)>" - aStream next. - (aStream atEnd not and: [ (aStream peek digitValue between: 0 and: 9) or: [ '+-' includes: aStream peek ]]) - ifTrue: [ - exp := Integer readFrom: aStream. - scale := (peekChar = $p ifTrue: [2] ifFalse: [base]) raisedToInteger: exp. - value := value * scale ] - ifFalse: [ - "oops - just ." - aStream skip: -1.]]. - ^convertToFloat - ifTrue: [ - (value = 0.0 and: [ sign = -1 ]) - ifTrue: [ Float negativeZero ] - ifFalse: [ (value * sign) asFloat ]] - ifFalse: [ value * sign ]! ! -!SHParserST80 methodsFor: 'scan' stamp: 'jmv 4/27/2019 17:10:13' prior: 16901854! -scanNumber - | start c nc base | - start := sourcePosition. - self skipDigits. - c := self currentChar. - ('rx' includes: c) - ifTrue: [ - base := Integer readFrom: (ReadStream on: (source copyFrom: start to: sourcePosition - 1)). - self peekChar == $- ifTrue:[self nextChar]. - self skipBigDigits: base. - c := self currentChar. - c == $. - ifTrue: [ - (self isBigDigit: self nextChar base: base) - ifFalse: [sourcePosition := sourcePosition - 1] - ifTrue: [self skipBigDigits: base]]. - c := self currentChar. - ('deqp'includes: c) - ifTrue: [ - ((nc := self nextChar) isDigit or: [nc == $- and:[self peekChar isDigit]]) - ifFalse: [sourcePosition := sourcePosition - 1] - ifTrue: [self skipDigits]]. - c == $s - ifTrue: [ - self nextChar isDigit - ifFalse: [sourcePosition := sourcePosition - 1] - ifTrue: [self skipDigits]]. - currentToken := source copyFrom: start to: sourcePosition - 1. - ^currentTokenSourcePosition := start]. - c == $s - ifTrue: [ - self nextChar isDigit - ifFalse: [sourcePosition := sourcePosition - 1] - ifTrue: [self skipDigits.]. - currentToken := source copyFrom: start to: sourcePosition - 1. - ^currentTokenSourcePosition := start]. - c == $. - ifTrue: [ - self nextChar isDigit - ifFalse: [ - sourcePosition := sourcePosition - 1. - currentToken := source copyFrom: start to: sourcePosition - 1. - ^currentTokenSourcePosition := start] - ifTrue: [self skipDigits]]. - c := self currentChar. - ('deqp' includes: c) - ifTrue: [ - ((nc := self nextChar) isDigit or: [nc == $- and:[self peekChar isDigit]]) - ifFalse: [sourcePosition := sourcePosition - 1] - ifTrue: [self skipDigits]]. - c == $s - ifTrue: [ - self nextChar isDigit - ifFalse: [sourcePosition := sourcePosition - 1] - ifTrue: [self skipDigits]]. - currentToken := source copyFrom: start to: sourcePosition - 1. - ^currentTokenSourcePosition := start! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3717-HexadecimalExponentialNotation-JuanVuletich-2019Apr27-17h15m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3717] on 28 April 2019 at 7:10:10 pm'! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 4/28/2019 19:09:34' prior: 50448698! - arrowKey: aKeyboardEvent - - aKeyboardEvent anyModifierKeyPressed ifFalse: [ - aKeyboardEvent isArrowUp ifTrue: [ ^ self navigateUp ]. - aKeyboardEvent isArrowDown ifTrue: [ ^ self navigateDown ]. - aKeyboardEvent isArrowLeft ifTrue: [ ^ self navigateLeft ]. - aKeyboardEvent isArrowRight ifTrue: [ ^ self navigateRight ]. - aKeyboardEvent isHome ifTrue: [ ^ self navigateToTop ]. - aKeyboardEvent isEnd ifTrue: [ ^ self navigateToBottom ]. - aKeyboardEvent isPageUp ifTrue: [ ^ self navigateOnePageUp ]. - aKeyboardEvent isPageDown ifTrue: [ ^ self navigateOnePageDown ]]. - ^ nil! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3718-ListMorphKeyboardNavigationOnlyIfNoModifiers-JuanVuletich-2019Apr28-19h09m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3718] on 28 April 2019 at 8:39:00 pm'! -!CharacterBlockScanner methodsFor: 'scanning' stamp: 'jmv 4/28/2019 20:37:26' prior: 50410543! - characterBlockAtPoint: aPoint index: index in: textLine - "This method is the Morphic characterBlock finder." - | runLength lineStop stopCondition | - line _ textLine. - rightMargin _ line rightMargin. - lastTabIndex _ lastIndex _ line first. - self setFont. - self setStopConditions. - characterIndex _ index. "nil means scanning for point" - characterPoint _ aPoint. - (characterPoint isNil or: [ characterPoint y > line bottom ]) - ifTrue: [ characterPoint _ line bottomRight ]. - (text isEmpty or: [( characterPoint y < line top or: [ characterPoint x < line left ]) - or: [ characterIndex notNil and: [ characterIndex < line first ]]]) - ifTrue: [^ CharacterBlock - stringIndex: line first - text: text - topLeft: line leftMargin@line top - extent: 0 @ line lineHeight - textLine: line]. - lastTabX _ destX _ leftMargin _ line leftMarginForAlignment: alignment. - destY _ line top. - runLength _ text runLengthFor: line first. - lineStop _ characterIndex "scanning for index" - ifNil: [ line last ]. "scanning for point" - runStopIndex _ lastIndex + (runLength - 1) min: lineStop. - lastCharacterWidth _ 0. - spaceCount _ 0. - - self placeEmbeddedObject. - [ - stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex - in: text string rightX: characterPoint x - stopConditions: stopConditions kern: font baseKern. - "see setStopConditions for stopping conditions for character block operations." - lastCharacterWidth _ specialWidth ifNil: [ font widthOf: (text at: lastIndex) ]. - (self perform: stopCondition) ifTrue: [ - ^characterIndex - ifNil: [ "Result for characterBlockAtPoint: " - CharacterBlock - stringIndex: lastIndex - text: text - topLeft: characterPoint x@line top - extent: lastCharacterWidth @ line lineHeight - textLine: line ] - ifNotNil: [ "Result for characterBlockForIndex: " - CharacterBlock - stringIndex: characterIndex - text: text - topLeft: characterPoint x@line top - extent: lastCharacterWidth @ line lineHeight - textLine: line ]] - ] repeat! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'jmv 4/28/2019 20:33:01' prior: 50406152! - scrollToShow: aRectangle - "scroll to include as much of aRectangle as possible, where aRectangle is in the scroller's local space. - This means that 0@0 is scrolling all the way top and all the way left" - | deltaY | - (aRectangle top >= 0 and: [ - aRectangle bottom <= self viewableHeight ]) - ifTrue: [ - "already visible" - ^self ]. - "Scroll center of selection into view if necessary" - deltaY _ (aRectangle amountToTranslateWithin: (`0@0` extent: self viewableExtent)) y. - deltaY ~= 0 ifTrue: [ - self scrollBy: 0@deltaY ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3719-AvoidExcessiveAutoScrollJumping-JuanVuletich-2019Apr28-20h37m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3719] on 29 April 2019 at 8:59:46 am'! -!Transcript class methodsFor: 'private' stamp: 'jmv 4/29/2019 08:58:28'! - addEntry: aString log: otherString - "Add a new entrie to the entries circular list. If full, a new entry will replace the oldest one." - - accessSemaphore critical: [ - - "Internal circular collection" - lastIndex _ lastIndex \\ self maxEntries + 1. - firstIndex = lastIndex ifTrue: [ firstIndex _ firstIndex \\ self maxEntries + 1 ]. - entries at: lastIndex put: aString. - - otherString ifNotNil: [ - self writeToFile: otherString. - self writeToStdout: otherString - ] - ]! ! -!Transcript class methodsFor: 'private' stamp: 'jmv 4/29/2019 08:58:40' prior: 50453137! - addEntry: aString - "Add a new entrie to the entries circular list. If full, a new entry will replace the oldest one." - | msg now | - logToFile | logToStdout ifTrue: [ - now _ DateAndTime now. - msg _ String streamContents: [ :strm | - now printWithMsOn: strm. - strm - nextPutAll: ' process:'; - nextPutAll: Processor activeProcess priority printString; - nextPut: $ ; - nextPutAll: Processor activeProcess hash printString; - nextPut: $ ; - nextPutAll: aString; - newLine ]]. - - self addEntry: (aString copyReplaceAll: String newLineString with: ' ') log: msg! ! - -Transcript class removeSelector: #addEntry:logToFile:! - -Transcript class removeSelector: #addEntry:logToFile:! - -Transcript class removeSelector: #addEntry:logToFileAndStdout:! - -Transcript class removeSelector: #addEntry:logToFileAndStdout:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3720-TranscriptTweaks-JuanVuletich-2019Apr29-08h58m-jmv.1.cs.st----! - -----SNAPSHOT----(29 April 2019 09:05:16) Cuis5.0-3720-32.image priorSource: 3855772! - -----QUIT----(29 April 2019 09:05:30) Cuis5.0-3720-32.image priorSource: 3945444! - -----STARTUP---- (3 June 2019 11:00:42) as /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/Cuis5.0-3720-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3720] on 29 April 2019 at 9:15:50 am'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 4/29/2019 09:14:33' prior: 50343143! - saveAsNewVersion - "Save the image/changes using the next available version number." - " - Smalltalk saveAsNewVersion - " - | fileName newName changesName systemVersion | - self okayToSave ifFalse: [ ^ self ]. - systemVersion _ SystemVersion current. - fileName _ String streamContents: [ :strm | - strm - nextPutAll: 'Cuis'; - print: systemVersion versionMajor; - nextPut: $.; - print: systemVersion versionMinor; - nextPut: $-; - print: systemVersion highestUpdate. - Smalltalk isSpur - ifTrue: [ - Smalltalk wordSize = 4 ifTrue: [ - strm nextPutAll: '-32' ]] - ifFalse: [ - strm nextPutAll: '-v3' ]]. - newName _ fileName, '.image'. - (DirectoryEntry smalltalkImageDirectory // newName) exists ifTrue: [ - newName _ DirectoryEntry smalltalkImageDirectory - nextNameFor: fileName - extension: 'image' ]. - changesName _ self fullNameForChangesNamed: newName. - "Check to see if there is a .changes file that would cause a problem if we saved a new .image file with the new version number" - changesName asFileEntry exists ifTrue: [ - ^ self inform: -'There is already .changes file of the desired name, -', changesName, ' -curiously already present, even though there is no -corresponding .image file. -Please remedy manually and then repeat your request.' ]. - "Try to clear all user state, including all class vars, preferences, etc" - self saveAs: newName andQuit: false clearAllClassState: true! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3721-SaveAsNewVersion-WarningMessageTweak-JuanVuletich-2019Apr29-09h14m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3721] on 2 May 2019 at 8:31:27 am'! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/1/2019 12:50:29'! - navigateDown - "move down, wrapping to top if needed" - | nextSelection | - nextSelection _ self visualSelectionIndex + 1. - nextSelection > self maximumSelection ifTrue: [ nextSelection _ self minimumSelection ]. - self changeSelectionTo: nextSelection! ! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/1/2019 12:51:51'! - navigateLeft - | oldSelection nextSelection | - oldSelection _ self visualSelectionIndex. - nextSelection _ oldSelection. - selectedMorph ifNotNil: [ - selectedMorph isExpanded - ifTrue: [ - self toggleExpandedState: selectedMorph. - self scrollSelectionIntoView ] - ifFalse: [ - oldSelection > self minimumSelection ifTrue: [ - nextSelection _ (oldSelection-1 to: 1 by: -1) - detect: [ :i | ( scroller submorphs at: i) indentLevel < selectedMorph indentLevel ] - ifNone: [ oldSelection ]]. - ]]. - self changeSelectionTo: nextSelection! ! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/1/2019 12:58:27'! - navigateOnePageDown - - self changeSelectionTo: (self visualSelectionIndex + self numSelectionsInView min: self maximumSelection)! ! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/1/2019 12:54:14'! - navigateOnePageUp - - self changeSelectionTo: (self minimumSelection max: self visualSelectionIndex - self numSelectionsInView)! ! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/1/2019 12:51:59'! - navigateRight - | oldSelection nextSelection | - oldSelection _ self visualSelectionIndex. - nextSelection _ oldSelection. - selectedMorph ifNotNil: [ - (selectedMorph canExpand and: [ selectedMorph isExpanded not ]) - ifTrue: [ - self toggleExpandedState: selectedMorph. - self scrollSelectionIntoView ] - ifFalse: [ nextSelection := oldSelection + 1 ]]. - self changeSelectionTo: nextSelection! ! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/1/2019 12:49:21'! - navigateToBottom - - self changeSelectionTo: self maximumSelection! ! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/1/2019 12:52:29'! - navigateToTop - - self changeSelectionTo: self minimumSelection! ! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/1/2019 12:50:43'! - navigateUp - "move up, wrapping to bottom if needed" - | nextSelection | - nextSelection _ self visualSelectionIndex - 1. - nextSelection < self minimumSelection ifTrue: [ nextSelection _ self maximumSelection ]. - self changeSelectionTo: nextSelection! ! -!HierarchicalListMorph methodsFor: 'private' stamp: 'jmv 5/1/2019 12:37:18'! - changeSelectionTo: nextSelection - - nextSelection = self visualSelectionIndex ifFalse: [ - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self highlightedMorph: (self listMorphAt: nextSelection). - "Update the model in next world cycle, so user gets the immediate feedback." - UISupervisor whenUIinSafeState: [ self setSelectionIndex: nextSelection ]].! ! -!HierarchicalListMorph methodsFor: 'events' stamp: 'jmv 5/1/2019 12:55:50' prior: 50449261! - keyStroke: aKeyboardEvent - "Process potential command keys" - - | args | - (self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - (self arrowKey: aKeyboardEvent) ifNotNil: [ ^ self ]. - keystrokeActionSelector ifNil: [^self]. - (args _ keystrokeActionSelector numArgs) = 1 - ifTrue: [^mainView perform: keystrokeActionSelector with: aKeyboardEvent keyCharacter]. - args = 2 - ifTrue: [ - ^mainView - perform: keystrokeActionSelector - with: aKeyboardEvent keyCharacter - with: self]. - ^self error: 'The keystrokeActionSelector must be a 1- or 2-keyword symbol'! ! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/1/2019 12:55:36' prior: 50449468! - arrowKey: aKeyboardEvent - - "Handle a keyboard navigation event. Answer nil if not handled." - aKeyboardEvent isArrowUp ifTrue: [ ^ self navigateUp ]. - aKeyboardEvent isArrowDown ifTrue: [ ^ self navigateDown ]. - aKeyboardEvent isArrowLeft ifTrue: [ ^ self navigateLeft ]. - aKeyboardEvent isArrowRight ifTrue: [ ^ self navigateRight ]. - aKeyboardEvent isHome ifTrue: [ ^ self navigateToTop ]. - aKeyboardEvent isEnd ifTrue: [ ^ self navigateToBottom ]. - aKeyboardEvent isPageUp ifTrue: [ ^ self navigateOnePageUp ]. - aKeyboardEvent isPageDown ifTrue: [ ^ self navigateOnePageDown ]. - ^ nil! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/1/2019 12:55:33' prior: 50454771! - arrowKey: aKeyboardEvent - - "Handle a keyboard navigation event. Answer nil if not handled." - aKeyboardEvent anyModifierKeyPressed ifFalse: [ - aKeyboardEvent isArrowUp ifTrue: [ ^ self navigateUp ]. - aKeyboardEvent isArrowDown ifTrue: [ ^ self navigateDown ]. - aKeyboardEvent isArrowLeft ifTrue: [ ^ self navigateLeft ]. - aKeyboardEvent isArrowRight ifTrue: [ ^ self navigateRight ]. - aKeyboardEvent isHome ifTrue: [ ^ self navigateToTop ]. - aKeyboardEvent isEnd ifTrue: [ ^ self navigateToBottom ]. - aKeyboardEvent isPageUp ifTrue: [ ^ self navigateOnePageUp ]. - aKeyboardEvent isPageDown ifTrue: [ ^ self navigateOnePageDown ]]. - ^ nil! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/1/2019 12:50:55' prior: 50448577! - navigateDown - "move down, wrapping to top if needed" - | nextSelection | - nextSelection _ self getCurrentSelectionIndex + 1. - nextSelection > self maximumSelection ifTrue: [ nextSelection _ self minimumSelection ]. - self changeSelectionTo: nextSelection! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/1/2019 12:58:14' prior: 50448594! - navigateOnePageDown - - self changeSelectionTo: (self getCurrentSelectionIndex + self numSelectionsInView min: self maximumSelection)! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/1/2019 12:52:34' prior: 50448623! - navigateToTop - - self changeSelectionTo: self minimumSelection! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/1/2019 12:51:10' prior: 50448628! - navigateUp - "move up, wrapping to bottom if needed" - | nextSelection | - nextSelection _ self getCurrentSelectionIndex - 1. - nextSelection < self minimumSelection ifTrue: [ nextSelection _ self maximumSelection ]. - self changeSelectionTo: nextSelection! ! -!PluggableListMorph methodsFor: 'private' stamp: 'jmv 5/1/2019 12:36:00' prior: 50448638! - changeSelectionTo: nextSelection - - nextSelection = self getCurrentSelectionIndex ifFalse: [ - | window | - window _ self owningWindow. - (window isNil or: [ window okToChangeDueTo: self ]) ifTrue: [ - "No change if model is locked" - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self listMorph highlightedRow: nextSelection. - "Update the model in next world cycle, so user gets the immediate feedback." - UISupervisor whenUIinSafeState: [ self setSelectionIndex: nextSelection ]. - ] - ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3722-HierarchicalListMorph-refactor-JuanVuletich-2019May02-08h22m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3722] on 2 May 2019 at 9:37:49 am'! -!TextEditor methodsFor: 'accessing' stamp: 'jmv 5/2/2019 09:12:25'! - selectionRectangle - "Answer a rectangle that encompasses single or multiple selection. - If no selection, answer a rectangle that includes cursor." - selectionStartBlocks notEmpty ifTrue: [ - ^ selectionStartBlocks first quickMerge: selectionStopBlocks last]. - ^ markBlock quickMerge: pointBlock! ! -!TextEditor methodsFor: 'accessing-selection' stamp: 'jmv 5/2/2019 09:02:22' prior: 16931381! - hasSelection - ^ markBlock ~= pointBlock or: [ selectionStartBlocks notEmpty ]! ! -!TextEditor methodsFor: 'accessing-selection' stamp: 'jmv 5/2/2019 09:00:31' prior: 16931446! - selectionAsStream - "Answer a ReadStream on the text that is currently selected. - Note: Only considers single selection. See #selection to see how we handle multiple selection." - - ^ReadWriteStream - on: self privateCurrentString - from: self startIndex - to: self stopIndex - 1! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'jmv 5/2/2019 09:33:42' prior: 50454868! - scrollToShow: aRectangle - "scroll to include as much of aRectangle as possible, where aRectangle is in the scroller's local space. - This means that 0@0 is scrolling all the way top and all the way left" - | deltaY | - deltaY _ (aRectangle amountToTranslateWithin: (`0@0` extent: self viewableExtent)) y. - deltaY ~= 0 ifTrue: [ - self scrollBy: 0@deltaY ]! ! -!TextModelMorph methodsFor: 'editor access' stamp: 'jmv 5/2/2019 09:10:04' prior: 16934028! -scrollSelectionIntoView - "Scroll my text into view if necessary and return true, else return false" - - self scrollToShow: (self editor selectionRectangle translatedBy: self textMorph morphPosition)! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3723-scrollSelectionIntoView-fix-JuanVuletich-2019May02-09h35m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3723] on 2 May 2019 at 4:27:24 pm'! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/2/2019 16:25:15' prior: 50455135! - arrowKey: aKeyboardEvent - - "Handle a keyboard navigation event. Answer nil if not handled." - "Ctrl arrows is used to scroll without changing the selection" - aKeyboardEvent controlKeyPressed ifFalse: [ - aKeyboardEvent isArrowUp ifTrue: [ ^ self navigateUp ]. - aKeyboardEvent isArrowDown ifTrue: [ ^ self navigateDown ]. - aKeyboardEvent isArrowLeft ifTrue: [ ^ self navigateLeft ]. - aKeyboardEvent isArrowRight ifTrue: [ ^ self navigateRight ]. - aKeyboardEvent isHome ifTrue: [ ^ self navigateToTop ]. - aKeyboardEvent isEnd ifTrue: [ ^ self navigateToBottom ]. - aKeyboardEvent isPageUp ifTrue: [ ^ self navigateOnePageUp ]. - aKeyboardEvent isPageDown ifTrue: [ ^ self navigateOnePageDown ]]. - ^ nil! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/2/2019 16:24:31' prior: 50455157! - arrowKey: aKeyboardEvent - - "Handle a keyboard navigation event. Answer nil if not handled." - "Ctrl arrows is used to scroll without changing the selection" - aKeyboardEvent controlKeyPressed ifFalse: [ - aKeyboardEvent isArrowUp ifTrue: [ ^ self navigateUp ]. - aKeyboardEvent isArrowDown ifTrue: [ ^ self navigateDown ]. - aKeyboardEvent isArrowLeft ifTrue: [ ^ self navigateLeft ]. - aKeyboardEvent isArrowRight ifTrue: [ ^ self navigateRight ]. - aKeyboardEvent isHome ifTrue: [ ^ self navigateToTop ]. - aKeyboardEvent isEnd ifTrue: [ ^ self navigateToBottom ]. - aKeyboardEvent isPageUp ifTrue: [ ^ self navigateOnePageUp ]. - aKeyboardEvent isPageDown ifTrue: [ ^ self navigateOnePageDown ]]. - ^ nil! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3724-ListMorphKeyboardNavigationOnlyIfNoCtrl-JuanVuletich-2019May02-16h24m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3724] on 4 May 2019 at 9:17:44 pm'! -!KeyboardEvent methodsFor: 'actions' stamp: 'RNG 5/4/2019 21:13:06'! - closeCurrentWindowOf: aMorph - - aMorph owningWindow ifNotNil: [ :w | - (w morphContainsPoint: (w internalizeFromWorld: self eventPosition)) - ifTrue: [ w delete. ] ]! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'RNG 5/4/2019 21:14:18'! - isCloseWindowShortcut - - ^ (self commandAltKeyPressed or: [ self controlKeyPressed ]) - and: [self keyCharacter = $w]! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'RNG 5/4/2019 21:16:04'! - isFindClassShortcut - - ^ self shiftPressed and: [ self isReturnKey ]! ! -!KeyboardEvent methodsFor: 'dispatching' stamp: 'RNG 5/4/2019 21:14:56' prior: 50449391! -sentTo: aMorph localPosition: positionInAMorph - "Dispatch the receiver into anObject" - type == #keystroke ifTrue: [ - self isFindClassShortcut - ifTrue: [ ^ BrowserWindow findClass]. - self isCloseWindowShortcut - ifTrue: [ ^ self closeCurrentWindowOf: aMorph ]. - ^ aMorph - processKeystroke: self - localPosition: positionInAMorph ]. - type == #keyDown ifTrue: [ - ^ aMorph - processKeyDown: self - localPosition: positionInAMorph ]. - type == #keyUp ifTrue: [ - ^ aMorph - processKeyUp: self - localPosition: positionInAMorph ]. - ^ super - sentTo: aMorph - localPosition: positionInAMorph.! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3725-KeyboardEventCleanup-NahuelGarbezza-2019May04-20h42m-RNG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3716] on 5 May 2019 at 6:48:52 pm'! -!CodeProvider methodsFor: 'annotation' stamp: 'pb 5/5/2019 18:18:13' prior: 16811706! -annotation - "Provide a line of content for an annotation pane, representing information about the method associated with the selected class and selector in the receiver." - - | aSelector aClass | - - ((aSelector _ self selectedMessageName) == nil or: [(aClass _ self selectedClassOrMetaClass) == nil]) - ifTrue: [^ '']. - ^ self annotationForSelector: aSelector ofClass: aClass! ! -!Browser methodsFor: 'annotation' stamp: 'pb 5/5/2019 18:19:46' prior: 16791461! - annotation - "Provide a line of content for an annotation pane, representing information about the method associated with the selected class and selector in the receiver." - - | aSelector aClass | - (aClass _ self selectedClassOrMetaClass) - ifNil: [^ '']. - self editSelection == #editComment - ifTrue: [^ self annotationForSelector: #Comment ofClass: aClass]. - self editSelection == #editClass - ifTrue: [^ self annotationForSelector: #Definition ofClass: aClass]. - (aSelector _ self selectedMessageName) - ifNil: [^ '']. - ^ self annotationForSelector: aSelector ofClass: aClass! ! -!ChangeList methodsFor: 'viewing access' stamp: 'pb 5/5/2019 18:19:33' prior: 16796581! - annotation - "Answer the string to be shown in an annotation pane. Make plain that the annotation is associated with the current in-image version of the code, not of the selected disk-based version, and if the corresponding method is missing from the in-image version, mention that fact." - - | change count selectedCount ann1 ann2 | - change _ self currentChange. - - change isNil ifTrue: [ - count _ listSelections size. - selectedCount _ listSelections count: [ :flag | flag ]. - ^ 'Total items: ', count printString, ' - Selected items: ', selectedCount printString ]. - - change changeType == #classDefinition ifTrue: [ - ann1 _ change isMetaClassChange ifTrue: [ 'Metaclass' ] ifFalse: [ 'Class' ]. - ann2 _ (Smalltalk includesKey: change changeClassName) ifTrue: [ ' already exists' ] ifFalse: [ ' not in system' ]. - ^ann1, ann2 ]. - - (self selectedMessageName isNil or: [self selectedClassOrMetaClass isNil]) - ifTrue: [^ '']. - - ^ change methodSelector notNil - ifFalse: [ super annotation] - ifTrue: [ - (self isNewMethod: change) - ifTrue: [ - String streamContents: [ :strm | | sel | - sel _ change methodSelector. - strm - nextPutAll: change changeClassName; - nextPutAll: ' >> '; - nextPutAll: sel; - nextPutAll: ' is not present in the system. It has '. - count _ Smalltalk numberOfImplementorsOf: sel. - count = 1 - ifTrue: [strm nextPutAll: '1 implementor'] - ifFalse: [count printOn: strm. strm nextPutAll: ' implementors' ]. - strm nextPutAll: ' and '. - count _ Smalltalk numberOfSendersOf: sel. - count = 1 - ifTrue: [strm nextPutAll: '1 sender.'] - ifFalse: [count printOn: strm. strm nextPutAll: ' senders.' ]. - ] - ] - ifFalse: [ - 'current version: ', super annotation]]! ! -!TestRunner methodsFor: 'updating' stamp: 'pb 5/5/2019 18:31:36' prior: 16928357! - refreshTR - self updateErrors: TestResult new. - self updateFailures: TestResult new. - self displayPassFail: ''. - self displayDetails: ''! ! -!TestRunner methodsFor: 'initialization' stamp: 'pb 5/5/2019 18:31:29' prior: 16928424! - initialize - - result := TestResult new. - passFail := ''. - details := ''. - failures := OrderedCollection new. - errors := OrderedCollection new. - tests := self gatherTestNames. - selectedSuite := 0. - selectedFailureTest := 0. - selectedErrorTest := 0. - selectedSuites := tests collect: [:ea | true]. - running := nil. - runSemaphore := Semaphore new! ! -!CodePackage methodsFor: 'naming' stamp: 'pb 5/5/2019 17:59:16' prior: 50401530! - packageName: aString - packageName _ aString. - description _ ''. - featureSpec _ FeatureSpec new. - featureSpec provides: (Feature name: packageName version: 1 revision: 0). - hasUnsavedChanges _ self includesAnyCode. - "But reset revision if it was incremented because of marking it dirty!!" - featureSpec provides name: packageName version: 1 revision: 0! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'pb 5/5/2019 18:13:05' prior: 50387862! - buildMorphicWindow - " - CodePackageListWindow open: CodePackageList new - " - | dirtyFlags names fileNames upperRow description summary backColor labelBackground | - backColor := self textBackgroundColor. - labelBackground := Theme current background. - - dirtyFlags := PluggableListMorph - model: model - listGetter: #packageDirtyFlags - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - dirtyFlags color: backColor. - dirtyFlags := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: ' Unsaved?'); - addMorphUseAll: dirtyFlags. - - names := PluggableListMorph - model: model - listGetter: #packageNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - names color: backColor. - names := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: ' Package Name'); - addMorphUseAll: names. - - fileNames := PluggableListMorph - model: model - listGetter: #packageFullNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - fileNames color: backColor. - fileNames := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: ' File Name'); - addMorphUseAll: fileNames. - - upperRow := LayoutMorph newRow. - upperRow - addMorph: dirtyFlags proportionalWidth: 0.13; - addAdjusterAndMorph: names proportionalWidth: 0.27; - addAdjusterAndMorph: fileNames proportionalWidth: 0.6. - - description := (TextModelMorph - textProvider: model - textGetter: #description - textSetter: #description:) emptyTextDisplayMessage: 'Please enter a description for this package'. - - summary := (TextModelMorph - textProvider: model - textGetter: #summary) emptyTextDisplayMessage: 'Package summary (No package selected?)'. - - self layoutMorph - addMorph: upperRow proportionalHeight: 0.6; - addAdjusterAndMorph: self buildButtonPane fixedHeight: Theme current buttonPaneHeight; - addAdjusterAndMorph: summary fixedHeight: 60; - addAdjusterAndMorph: description proportionalHeight: 0.25; - addAdjusterAndMorph: self buildRequirementsPane proportionalHeight: 0.15. - self setLabel: 'Installed Packages'! ! -!CodeWindow methodsFor: 'GUI building' stamp: 'pb 5/5/2019 18:24:20' prior: 16812980! - buildMorphicAnnotationsPane - - | aTextMorph | - aTextMorph _ (TextModelMorph - textProvider: model - textGetter: #annotation) emptyTextDisplayMessage: 'Class or method annotation (not selected?)'. - model when: #annotationChanged send: #refetch to: aTextMorph model. - model when: #decorateButtons send: #decorateButtons to: self. - aTextMorph - askBeforeDiscardingEdits: false; - hideScrollBarsIndefinitely. - ^aTextMorph! ! -!CodeWindow methodsFor: 'GUI building' stamp: 'pb 5/5/2019 18:40:52' prior: 16812994! - buildMorphicCodePane - "Construct the pane that shows the code. - Respect the Preference for standardCodeFont." - ^ (TextModelMorph - textProvider: model - textGetter: #acceptedContents - textSetter: #contents:notifying: - selectionGetter: #contentsSelection) emptyTextDisplayMessage: 'Smalltalk code (nothing selected?)'! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'pb 5/5/2019 18:07:59' prior: 50454347! - buildMorphicCommentPane - "Construct the pane that shows the class comment." - ^ (BrowserCommentTextMorph - textProvider: model - textGetter: #classCommentText - textSetter: #newClassComment:) emptyTextDisplayMessage: 'Please enter a comment for this class'.! ! -!MessageNamesWindow methodsFor: 'GUI building' stamp: 'pb 5/5/2019 18:07:23' prior: 50454503! - buildMorphicWindow - "Answer a morphic window with the given initial search string, nil if none" - -"MessageNames openMessageNames" - - | selectorListView firstRow searchButton secondRow | - textMorph _ (TextModelMorph - textProvider: model - textGetter: #searchString - textSetter: #searchString: - selectionGetter: #contentsSelection) emptyTextDisplayMessage: 'Type here, then hit Search'. - textMorph askBeforeDiscardingEdits: false. - textMorph acceptOnCR: true. - textMorph hideScrollBarsIndefinitely. - - searchButton _ PluggableButtonMorph new - model: textMorph textMorph; - label: 'Search'; - action: #acceptContents. - searchButton setBalloonText: 'Type some letters into the pane at right, and then press this Search button (or hit RETURN) and all method selectors that match what you typed will appear in the list pane below. Click on any one of them, and all the implementors of that selector will be shown in the right-hand pane, and you can view and edit their code without leaving this tool.'. - - firstRow _ LayoutMorph newRow. - firstRow color: self windowColor. - firstRow - doAdoptWidgetsColor; - addMorph: searchButton proportionalWidth: 0.25; - addMorph: textMorph proportionalWidth: 0.75. - - selectorListView _ PluggableListMorph - model: model - listGetter: #selectorList - indexGetter: #selectorListIndex - indexSetter: #selectorListIndex: - mainView: self - menuGetter: #selectorListMenu - keystrokeAction: #selectorListKey:from:. - secondRow _ LayoutMorph newRow. - secondRow - addMorph: selectorListView proportionalWidth: 0.5; - addAdjusterAndMorph: self buildMorphicMessageList proportionalWidth: 0.5. - - self layoutMorph - addMorph: firstRow fixedHeight: self defaultButtonPaneHeight+4; - addAdjusterAndMorph: secondRow proportionalHeight: 0.5; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.5. - model changed: #editSelection! ! -!ChangeListWindow methodsFor: 'GUI building' stamp: 'pb 5/5/2019 18:48:30' prior: 16797072! - buildMorphicCodePane - - ^(TextModelMorph - textProvider: model - textGetter: #acceptedContents) emptyTextDisplayMessage: 'Selection detail (no change selected?)'! ! -!DebuggerWindow methodsFor: 'GUI building' stamp: 'pb 5/5/2019 18:47:09' prior: 50391458! - buildMorphicWindow - "Open a full morphic debugger with the given label" - - | bottomMorph | - - stackList _ PluggableListMorph - model: model - listGetter: #contextStackList - indexGetter: #contextStackIndex - indexSetter: #toggleContextStackIndex: - mainView: self - menuGetter: #contextStackMenu - keystrokeAction: #contextStackKey:from:. - - receiverInspector _ PluggableListMorph - model: model receiverInspector - listGetter: #fieldList - indexGetter: #selectionIndex - indexSetter: #toggleIndex: - mainView: self - menuGetter: #receiverFieldListMenu - keystrokeAction: #inspectorKey:from:. - receiverInspector doubleClickSelector: #inspectSelection. - receiverInspectorText _ (TextModelMorph - textProvider: model receiverInspector - textGetter: #acceptedContents - textSetter: #accept: - selectionGetter: #contentsSelection) emptyTextDisplayMessage: 'Receiver scope'. - contextVariableInspector _ PluggableListMorph - model: model contextVariablesInspector - listGetter: #fieldList - indexGetter: #selectionIndex - indexSetter: #toggleIndex: - mainView: self - menuGetter: #contextFieldListMenu - keystrokeAction: #inspectorKey:from:. - contextVariableInspector doubleClickSelector: #inspectSelection. - contextVariableInspectorText _ (TextModelMorph - textProvider: model contextVariablesInspector - textGetter: #acceptedContents - textSetter: #accept: - selectionGetter: #contentsSelection) emptyTextDisplayMessage: 'Context scope'. - - bottomMorph _ LayoutMorph newRow. - bottomMorph - addMorph: receiverInspector proportionalWidth: 0.2; - addAdjusterAndMorph: receiverInspectorText proportionalWidth: 0.3; - addAdjusterAndMorph: contextVariableInspector proportionalWidth: 0.2; - addAdjusterAndMorph: contextVariableInspectorText proportionalWidth: 0.3. - - self layoutMorph - addMorph: stackList proportionalHeight: 0.25; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.55; - addAdjusterAndMorph: bottomMorph proportionalHeight: 0.2! ! -!InspectorWindow methodsFor: 'GUI building' stamp: 'pb 5/5/2019 18:44:07' prior: 50334404! - buildMorphicWindow - " Inspector openOn: SystemOrganization " - | contentsText list upperRow evaluatorText label | - "Build widgets. We'll assemble them below." - list _ PluggableListMorph - model: model - listGetter: #fieldList - indexGetter: #selectionIndex - indexSetter: #toggleIndex: - mainView: self - menuGetter: #fieldListMenu - keystrokeAction: #inspectorKey:from:. - list doubleClickSelector: #inspectSelection. - contentsText _ TextModelMorph - textProvider: model - textGetter: #acceptedContents - textSetter: #accept: - selectionGetter: #contentsSelection. - evaluatorText _ (TextModelMorph textProvider: model) - askBeforeDiscardingEdits: false; - emptyTextDisplayMessage: 'Smalltalk expression'. - "Upper row has two widgets, side by side: the list of variables at the left side, and the variable contents pane at the right side." - upperRow _ LayoutMorph newRow. - upperRow - addMorph: list proportionalWidth: 0.3; - addAdjusterAndMorph: contentsText proportionalWidth: 0.7. - "Inspector Window has two rows: At the top, the one we just bult. Below it, the evaluation pane." - self layoutMorph - addMorph: upperRow proportionalHeight: 0.7; - addAdjusterAndMorph: evaluatorText proportionalHeight: 0.3. - "Set label" - label _ [model object printStringLimitedTo: 64] - on: UnhandledError - do: [:ex | ex return: model object class printString, ' (printing failed)']. - (label includesSubString: model object class name) - ifFalse: [label _ model object class name, ': ', label]. - self setLabel: label! ! -!ObjectExplorerWindow methodsFor: 'GUI building' stamp: 'pb 5/5/2019 18:42:14' prior: 50334453! - buildMorphicWindow - - | textMorph | - listMorph _ HierarchicalListMorph - model: model - listGetter: #getList - indexGetter: #getCurrentSelection - indexSetter: #noteNewSelection: - mainView: self - menuGetter: #genericMenu - keystrokeAction: #explorerKey:from:. - listMorph autoDeselect: false. - listMorph doubleClickSelector: #inspectSelection. - textMorph _ ((TextModelMorph textProvider: model) - askBeforeDiscardingEdits: false; - emptyTextDisplayMessage: 'Smalltalk expression (self is selected item)'). - self layoutMorph - addMorph: listMorph proportionalHeight: 0.8; - addAdjusterAndMorph: textMorph proportionalHeight: 0.2. - self setLabel: (model rootObject printStringLimitedTo: 64)! ! -!ProcessBrowserWindow methodsFor: 'GUI building' stamp: 'pb 5/5/2019 18:41:54' prior: 16895306! - buildMorphicWindow - "Create a pluggable version of me, answer a window" - | aTextMorph list1 list2 upperRow | - list1 _ PluggableListMorph - model: model - listGetter: #processNameList - indexGetter: #processListIndex - indexSetter: #processListIndex: - mainView: self - menuGetter: #processListMenu - keystrokeAction: #processListKey:from:. - list2 _ PluggableListMorph - model: model - listGetter: #stackNameList - indexGetter: #stackListIndex - indexSetter: #stackListIndex: - mainView: self - menuGetter: #stackListMenu - keystrokeAction: #stackListKey:from:. - upperRow _ LayoutMorph newRow. - upperRow - addMorph: list1 proportionalWidth: 0.5; - addAdjusterAndMorph: list2 proportionalWidth: 0.5. - aTextMorph _ (TextModelMorph - textProvider: model - textGetter: #selectedMethod) emptyTextDisplayMessage: 'Method source (not selected?)'. - aTextMorph askBeforeDiscardingEdits: false. - self layoutMorph - addMorph: upperRow proportionalHeight: 0.5; - addAdjusterAndMorph: aTextMorph proportionalHeight: 0.5. - self setLabel: 'Process Browser'! ! -!TestRunnerWindow methodsFor: 'GUI building' stamp: 'pb 5/5/2019 18:32:14' prior: 16928498! - buildDetailsText - detailsText _ (TextModelMorph - textProvider: model - textGetter: #details) emptyTextDisplayMessage: 'Test run details (no results to display)'. - detailsText hideScrollBarsIndefinitely. - ^detailsText! ! -!TestRunnerWindow methodsFor: 'GUI building' stamp: 'pb 5/5/2019 18:33:10' prior: 16928566! - buildPassFailText - passFailText _ (TextModelMorph - textProvider: model - textGetter: #passFail) emptyTextDisplayMessage: 'Pass/Fail summary (no results to display)'. - passFailText hideScrollBarsIndefinitely. - ^ passFailText! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'pb 5/5/2019 18:39:46' prior: 50454422! - createTextPaneAcceptOnCR: acceptBoolean - "create the textPane" - | result | - self flag: #todo. - "Integrate this method with the Theme system. --cbr" - result _ (TextModelMorph - textProvider: self - textGetter: #response - textSetter: #response: - selectionGetter: #selectionInterval) emptyTextDisplayMessage: 'Enter response'. - self - valueOfProperty: #emptyTextDisplayMessage - ifPresentDo: [ :msg | - result emptyTextDisplayMessage: msg ]. - result - hasUnacceptedEdits: true; - acceptOnCR: acceptBoolean; - escAction: [ self cancelClicked ]; - morphExtent: `18 @ 5` * self sizeUnit. - self - addMorph: result - position: `1 @ 2` * self sizeUnit. - ^ result.! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3726-MoreEmptyMessages-PhilBellalouna-2019May05-17h58m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3725] on 5 May 2019 at 8:59:01 pm'! -!Scanner class methodsFor: 'doIt selectors' stamp: 'HAW 5/5/2019 19:22:41'! - selectionDoItSourceCodeHeaderSizeWithContext: hasContext - - ^(String streamContents: [ :stream | self selectionDoItSourceCodeHeaderWithContext: hasContext into: stream ]) size! ! -!Scanner class methodsFor: 'doIt selectors' stamp: 'HAW 5/5/2019 19:06:58'! - selectionDoItSourceCodeHeaderWithContext: hasContext into: stream - - "I use previousContext and not ThisContext as in the parser to avoid - name collision. Also, previousContext is more intention revealing - Hernan" - stream - nextPutAll: (hasContext ifTrue: [ Scanner doItInSelector, ' previousContext' ] ifFalse: [ Scanner doItSelector ]); - newLine; - newLine! ! -!Parser methodsFor: 'error correction' stamp: 'jmv 5/5/2019 20:54:13'! - correctSourceDelta - - | userSelectionDelta | - userSelectionDelta _ requestor selectionInterval ifEmpty: [0] ifNotEmpty: [ :userSelection | userSelection first-1 ]. - encoder selector = Scanner doItSelector ifTrue: [ - ^ (Scanner selectionDoItSourceCodeHeaderSizeWithContext: false) - userSelectionDelta ]. - encoder selector = Scanner doItInSelector ifTrue: [ - ^ (Scanner selectionDoItSourceCodeHeaderSizeWithContext: true) - userSelectionDelta ]. - - ^ 0! ! -!Parser methodsFor: 'error correction' stamp: 'HAW 5/5/2019 19:42:21' prior: 50451926! - correctSelector: proposedKeyword wordIntervals: aSpots exprInterval: expInt ifAbort: abortAction - "Correct the proposedKeyword to some selector symbol, correcting the original text if such action is indicated. abortAction is invoked if the proposedKeyword couldn't be converted into a valid selector. Spots is an ordered collection of intervals within the test stream of the for each of the keyword parts." - - | correctSelector userSelection delta adjustedSpots | - "If we can't ask the user, assume that the keyword will be defined later" - self interactive ifFalse: [^proposedKeyword asSymbol]. - - "If the requestor is of an exotic kind (like a telnet server) we might not be allowed to open a PupUpMenu for querying the user" - " - ((requestor isKindOf: Editor) or: [ requestor is: #Morph ]) - ifFalse: [ ^ proposedKeyword asSymbol ]. - " - - userSelection _ requestor selectionInterval. - - delta := self correctSourceDelta. - adjustedSpots := aSpots collect: [ :interval | interval first - delta to: interval last - delta ]. - requestor selectFrom: adjustedSpots first first to: adjustedSpots last last. - - correctSelector _ UnknownSelector name: proposedKeyword. - correctSelector ifNil: [^abortAction value]. - - requestor selectInvisiblyFrom: userSelection first to: userSelection last. - - self substituteSelector: correctSelector keywords wordIntervals: adjustedSpots. - ^(proposedKeyword last ~~ $: - and: [correctSelector last == $:]) - ifTrue: [abortAction value] - ifFalse: [correctSelector]! ! -!Parser methodsFor: 'error correction' stamp: 'HAW 5/5/2019 19:38:20' prior: 50452153! - correctVariable: proposedVariable interval: aSpot - "Correct the proposedVariable to a known variable, or declare it as a new - variable if such action is requested. We support declaring lowercase - variables as temps or inst-vars, and uppercase variables as Globals or - ClassVars, depending on whether the context is nil (class=UndefinedObject). - Spot is the interval within the test stream of the variable. - rr 3/4/2004 10:26 : adds the option to define a new class. " - - "Check if this is an i-var, that has been corrected already (ugly)" - - "Display the pop-up menu" - - | userSelection action delta spot | - (encoder classEncoding instVarNames includes: proposedVariable) ifTrue: [ - ^InstanceVariableNode new - name: proposedVariable - index: (encoder classEncoding allInstVarNames indexOf: proposedVariable)]. - - "First check to see if the requestor knows anything about the variable" - (requestor bindingOf: proposedVariable) - ifNotNil: [ :binding | ^ encoder global: binding name: proposedVariable]. - - "If we can't ask the user for correction, make it undeclared" - self interactive ifFalse: [^encoder undeclared: proposedVariable]. - - userSelection _ requestor selectionInterval. - delta _ self correctSourceDelta. - spot _ aSpot first - delta to: aSpot last - delta. - requestor selectFrom: spot first to: spot last. - - "Build the menu with alternatives" - action _ UndeclaredVariable - signalFor: self - name: proposedVariable - inRange: spot. - action ifNil: [^self fail]. - - "Execute the selected action" - requestor selectInvisiblyFrom: userSelection first to: userSelection last. - ^action value! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'HAW 5/5/2019 19:34:47' prior: 50444988! - selectionDoItSourceCodeIn: evalContext - - ^String streamContents: [ :stream | - Scanner selectionDoItSourceCodeHeaderWithContext: evalContext notNil into: stream. - stream nextPutAll: self selectionAsStream upToEnd ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3727-VariableAndSelectorCorrectionFix-HernanWilkinson-JuanVuletich-2019May05-20h57m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3707] on 3 May 2019 at 6:47:45 pm'! - -Object subclass: #FontChanger - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-GUI'! - -!classDefinition: #FontChanger category: #'Tools-GUI'! -Object subclass: #FontChanger - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-GUI'! -!FontChanger class methodsFor: 'prompting user' stamp: 'EB 5/3/2019 17:16:14'! - promptUser - "Present a menu of available font families, and if one is chosen, change to it." - self promptUserWithFamilies: AbstractFont familyNames.! ! -!FontChanger class methodsFor: 'prompting user' stamp: 'EB 5/3/2019 18:11:14'! - promptUserAndInstallIfNecessaryWithFamilies: fontFamilies - " - Present a menu of available font families, and if one is chosen, - install it if necessary, and change to it. - " - self promptUserWithFamilies: fontFamilies withMessageOnSelection: #changeToAndInstallIfNecessary:! ! -!FontChanger class methodsFor: 'prompting user' stamp: 'EB 5/3/2019 18:11:30'! - promptUserWithFamilies: fontFamilies - "Present a menu of font families, and if one is chosen, change to it." - self promptUserWithFamilies: fontFamilies withMessageOnSelection: #changeTo:! ! -!FontChanger class methodsFor: 'prompting user' stamp: 'EB 5/3/2019 18:11:03'! - promptUserWithFamilies: fontFamilies withMessageOnSelection: aMessageSymbol - " - Present a menu of available font families, and if one is chosen, - send aMessageSymbol to self with the corresponding font family as argument. - " - | fontMenu priorFontFamily | - priorFontFamily _ Preferences defaultFontFamily. - fontMenu _ MenuMorph new defaultTarget: self. - fontFamilies do: [:fontName | - | isCurrent label | - isCurrent _ priorFontFamily sameAs: fontName. - label _ self toSelectableMenuLabel: fontName isCurrent: isCurrent. - fontMenu - add: label - target: self - action: aMessageSymbol - argument: fontName. - ]. - fontMenu invokeModal.! ! -!FontChanger class methodsFor: 'changing font' stamp: 'EB 5/3/2019 18:13:51'! - changeToAndInstallIfNecessary: aFontName - "install the font if necessary, and change to it on the whole system without changing point sizes." - self installFontIfNecessary: aFontName. - self changeTo: aFontName. -! ! -!FontChanger class methodsFor: 'changing font' stamp: 'EB 5/3/2019 18:13:38'! - installFontIfNecessary: aFontName - | isFontInstalled | - isFontInstalled _ AbstractFont availableFonts includesKey: aFontName. - isFontInstalled ifFalse: [StrikeFont install: aFontName.].! ! -!FontChanger class methodsFor: 'private' stamp: 'EB 5/3/2019 17:58:16'! - toSelectableMenuLabel: aString isCurrent: isCurrent - | label | - isCurrent ifTrue: [label _ ''] ifFalse: [label _ '']. - ^label, aString! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'EB 5/3/2019 18:44:00' prior: 50435518! - preferencesMenu - "Build the preferences menu for the world." - - ^ (self menu: 'Preferences...') - addItemsFromDictionaries: `{ - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Font Sizes...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Set font...'. - #object -> FontChanger. - #selector -> #promptUserAndInstallIfNecessaryWithFamilies:. - #arguments -> #(('DejaVu' 'DejaVu Sans Mono')). - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'change the current font family.' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }`! ! -!FontChanger class methodsFor: 'changing font' stamp: 'EB 5/3/2019 16:29:08'! - changeTo: aFontName - "Change the font on the whole system without changing point sizes." - Preferences setDefaultFontFamilyTo: aFontName. - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: { - {#setSystemFontTo:. AbstractFont default pointSize}. - {#setListFontTo:. Preferences standardListFont pointSize.}. - {#setMenuFontTo:. Preferences standardMenuFont pointSize.}. - {#setWindowTitleFontTo:. Preferences windowTitleFont pointSize.}. - {#setCodeFontTo:. Preferences standardCodeFont pointSize.}. - {#setButtonFontTo:. Preferences standardButtonFont pointSize.}. - }. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]. - -! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3728-FontChanger-EricBrandwein-2019Apr24-23h47m-EB.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3720] on 6 May 2019 at 9:49:09 am'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 5/6/2019 09:48:47' prior: 50447197! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('AY' 'Angel Yan') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('bgs' 'Boris G. Shingarov') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('EB' 'Eric Brandwein') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('FGJ' 'Fernando Gasperi Jabalera') - #('FJG' 'Facundo Javier Gelatti') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('KLG' 'Gerald Klix') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MM' 'Mariano Montone') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('pmon' 'Paolo Montrasi') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('SLD' 'Steve Davies') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3729-AddEricAsKnownAuthor-JuanVuletich-2019May06-09h48m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3729] on 8 May 2019 at 9:12:09 am'! -!InputSensor class methodsFor: 'constants' stamp: 'jmv 5/8/2019 08:48:48'! - cmdAltOptionCtrlShiftModifierKeys - "Include all of them" - ^ 16r78 "cmd | opt | ctrl | shft "! ! -!Preferences class methodsFor: 'standard queries' stamp: 'jmv 5/8/2019 08:15:39' prior: 50374430! - ctrlArrowsScrollHorizontally - "Enables / disables Ctrl-ArrowKeys horizontal scroll. - By default it is false, to enable ctrl-leftArrow and ctrl-rightArrow to move cursor word by word in text editors." - ^ self - valueOfFlag: #ctrlArrowsScrollHorizontally - ifAbsent: [ false ]! ! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/1/2019 12:55:36' prior: 50455309! - arrowKey: aKeyboardEvent - - "Handle a keyboard navigation event. Answer nil if not handled." - aKeyboardEvent isArrowUp ifTrue: [ ^ self navigateUp ]. - aKeyboardEvent isArrowDown ifTrue: [ ^ self navigateDown ]. - aKeyboardEvent isArrowLeft ifTrue: [ ^ self navigateLeft ]. - aKeyboardEvent isArrowRight ifTrue: [ ^ self navigateRight ]. - aKeyboardEvent isHome ifTrue: [ ^ self navigateToTop ]. - aKeyboardEvent isEnd ifTrue: [ ^ self navigateToBottom ]. - aKeyboardEvent isPageUp ifTrue: [ ^ self navigateOnePageUp ]. - aKeyboardEvent isPageDown ifTrue: [ ^ self navigateOnePageDown ]. - ^ nil! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/8/2019 09:09:27' prior: 50455335! - arrowKey: aKeyboardEvent - - "Handle a keyboard navigation event. Answer nil if not handled." - aKeyboardEvent isArrowUp ifTrue: [ ^ self navigateUp ]. - aKeyboardEvent isArrowDown ifTrue: [ ^ self navigateDown ]. - aKeyboardEvent isArrowLeft ifTrue: [ ^ self navigateLeft ]. - aKeyboardEvent isArrowRight ifTrue: [ ^ self navigateRight ]. - aKeyboardEvent isHome ifTrue: [ ^ self navigateToTop ]. - aKeyboardEvent isEnd ifTrue: [ ^ self navigateToBottom ]. - aKeyboardEvent isPageUp ifTrue: [ ^ self navigateOnePageUp ]. - aKeyboardEvent isPageDown ifTrue: [ ^ self navigateOnePageDown ]. - ^ nil! ! -!HandMorph methodsFor: 'private events' stamp: 'jmv 5/8/2019 09:03:50' prior: 50423778! - generateKeyboardEvent: evtBuf - "Generate the appropriate mouse event for the given raw event buffer" - | buttons modifiers type keyValue pressType stamp mouseScrollDirection | - stamp _ evtBuf second. - stamp = 0 ifTrue: [ stamp _ Time localMillisecondClock ]. - (evtBuf sixth <= 0 or: [ (keyValue _ Character iso8859s15CodeForUnicodeCodePoint: evtBuf sixth) isNil ]) ifTrue: [ keyValue _ Character macRomanToLatin1: evtBuf third ]. - Sensor peekEvent ifNotNil: [ :nxt | - "start: Combining diacritical marks (i.e. accents in the Linux VM)" - (nxt fourth = EventSensor eventKeyDown and: [ nxt third > 255 ]) ifTrue: [ - keyValue _ ((Character numericValue: keyValue) withDiacriticalMark: nxt third) iso8859s15Code. - Sensor - nextEvent; - nextEvent; - nextEvent ]. - "end: Combining diacritical marks (i.e. accents in the Linux VM)" - "start: Spurious LF after CR on Ctrl-Enter on Windows VM" - ((evtBuf fourth = EventSensor eventKeyChar and: [ evtBuf third = 13 ]) and: [ - nxt fourth = EventSensor eventKeyChar and: [ nxt third = 10 ]]) ifTrue: [ Sensor nextEvent - "print " ]]. - modifiers _ evtBuf fifth. - pressType _ evtBuf fourth. - pressType = EventSensor eventKeyDown ifTrue: [ - type _ #keyDown. - lastKeyDownValue _ keyValue ]. - pressType = EventSensor eventKeyUp ifTrue: [ - (keyValue = 9 and: [(modifiers anyMask: 1) and: [Smalltalk platformName = 'unix']]) - ifTrue: [ - "Linux VMs don't generate shift-tab keystroke. Turn #keyUp into #keystroke" - pressType _ EventSensor eventKeyChar ] - ifFalse: [type _ #keyUp ]]. - pressType = EventSensor eventKeyChar ifTrue: [ - type _ #keystroke. - "If Control key pressed, and the VM answers a code below 27, - it means it did the translation, convert it back to regular character: - We want to handle the meaning of ctrl ourselves." - (modifiers anyMask: 2) ifTrue: [ - "Control key pressed" - keyValue < 27 ifTrue: [ - "But we don't want to do it for Home/End/PgUp/PgDn, just for alphabetic keys" - lastKeyDownValue = keyValue ifFalse: [ - "If equal, real Home/End/PgUp/PgDn in Windows => don't translate" - (keyValue + 64 = lastKeyDownValue or: [ "If Equal, Ctrl-alphabetic in Windows => do translate" - lastKeyDownValue < 47 ]) ifTrue: [ - "Not on windows. If less (not sure about the bound, but do not translate 48: tab on Mac), alphabetic on Mac => do translate" - keyValue _ (modifiers anyMask: 1) - ifTrue: [ keyValue + 64 ] - ifFalse: [ keyValue + 96 - "shift not pressed: conver to lowercase letter" ]]]]. - "Act as if command/alt was pressed for some usual Windows ctrl-key combinations" - (self shouldControlEmulateAltFor: keyValue) ifTrue: [ modifiers _ modifiers bitOr: 8 ]]]. - buttons _ modifiers bitShift: 3. - "Linux and Windows VM send keyboard ctrl-upArrow and ctrl-downArrow when the user tries to scroll using the mouse wheel - Mac VM sends cmd-option-ctrl-shift-upArrow and cmd-option-ctrl-shift-downArrow for trackpad vertical scroll gestures, - and cmd-option-ctrl-shift-leftArrow and cmd-option-ctrl-shift-rightArrow for horizontal scroll gestures. - This way of reporting scroll events by the VM also enables scrolling using the keyboard (actually, we can't tell if user gesture was on Mouse, Trackpad or Keyboard). - But ctrl-shift and cmdAlt-shift are needed used for selecting while moving by word, line, etc. - Additionally, #ctrlArrowsScrollHorizontally allows chosing between keyboard horizontal scroll and moving word by word in text editors." - mouseScrollDirection _ nil. - "Ctrl for Keyboard or Mouse wheel gestures. All modifiers for Trackpad gestures." - (buttons = InputSensor controlKey or: [buttons = InputSensor cmdAltOptionCtrlShiftModifierKeys]) ifTrue: [ - keyValue = 30 - ifTrue: [mouseScrollDirection _ #up] - ifFalse: [keyValue = 31 - ifTrue: [mouseScrollDirection _ #down]]]. - "Ctrl for Keyboard or Mouse wheel gestures, only if preference is set. All modifiers for Trackpad gestures." - ((buttons = InputSensor controlKey and: [Preferences ctrlArrowsScrollHorizontally]) or: [buttons = InputSensor cmdAltOptionCtrlShiftModifierKeys]) ifTrue: [ - keyValue = 28 - ifTrue: [mouseScrollDirection _ #left] - ifFalse: [keyValue = 29 - ifTrue: [mouseScrollDirection _ #right]]]. - mouseScrollDirection ifNotNil: [ - ^ MouseScrollEvent new - setType: #mouseScroll - position: self morphPosition - direction: mouseScrollDirection - buttons: buttons - hand: self - stamp: stamp ]. - ^ KeyboardEvent new - setType: type - buttons: buttons - position: self morphPosition - keyValue: keyValue - hand: self - stamp: stamp! ! - -TextEditor removeSelector: #scrollBy:! - -TextEditor removeSelector: #scrollBy:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3730-CorrectHandlingOfTrackpadScrollEvents-JuanVuletich-2019May08-09h06m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3725] on 5 May 2019 at 10:54:32 am'! - -Object subclass: #FontFamily - instanceVariableNames: 'familyName baseFontBySizes' - classVariableNames: 'AvailableFamilies DefaultFamilyName DefaultPointSize' - poolDictionaries: '' - category: 'Graphics-Text'! - -!classDefinition: #FontFamily category: #'Graphics-Text'! -Object subclass: #FontFamily - instanceVariableNames: 'familyName baseFontBySizes' - classVariableNames: 'AvailableFamilies DefaultFamilyName DefaultPointSize' - poolDictionaries: '' - category: 'Graphics-Text'! -!FontFamily commentStamp: '' prior: 0! - Also called Typeface.! - -FontFamily subclass: #StrikeFontFamily - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Text'! - -!classDefinition: #StrikeFontFamily category: #'Graphics-Text'! -FontFamily subclass: #StrikeFontFamily - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Text'! -!FontFamily methodsFor: 'initialization' stamp: 'jmv 5/5/2019 10:33:56'! - atPointSize: aNumber - ^baseFontBySizes at: aNumber ifAbsent: nil! ! -!FontFamily methodsFor: 'initialization' stamp: 'jmv 5/4/2019 16:11:02'! - atPointSize: aNumber put: aFontAndSize - "aFontAndSize must have emphasis = 0, i.e. it is a base font" - baseFontBySizes at: aNumber put: aFontAndSize ! ! -!FontFamily methodsFor: 'initialization' stamp: 'jmv 5/4/2019 16:00:18'! - familyName: aString - familyName _ aString. - baseFontBySizes _ Dictionary new! ! -!FontFamily methodsFor: 'accessing' stamp: 'jmv 5/4/2019 16:09:26'! - familyName - ^ familyName! ! -!FontFamily class methodsFor: 'accessing' stamp: 'jmv 5/5/2019 10:54:03'! - familyNames - " - FontFamily familyNames - " - ^AvailableFamilies keys sort! ! -!FontFamily class methodsFor: 'initialization' stamp: 'jmv 5/5/2019 10:54:06'! - initialize - " - FontFamily initialize - " - (AvailableFamilies isNil and: [AbstractFont availableFonts notNil]) ifTrue: [ - self migrate ]! ! -!FontFamily class methodsFor: 'initialization' stamp: 'jmv 5/5/2019 10:54:12'! - migrate - " - FontFamily migrate - " - | family def strikeFontAndSize | - AvailableFamilies _ Dictionary new. - def _ AbstractFont default. - - AbstractFont familyNames do: [ :familyName | - family _ StrikeFontFamily new. - family familyName: familyName. - (AbstractFont pointSizesFor: familyName) do: [ :ps | - strikeFontAndSize _ AbstractFont familyName: familyName pointSize: ps. - family atPointSize: ps put: strikeFontAndSize. - def == strikeFontAndSize ifTrue: [ - DefaultFamilyName _ family familyName. - DefaultPointSize _ ps ]]. - AvailableFamilies at: family familyName put: family ].! ! -!FontFamily class methodsFor: 'accessing fonts' stamp: 'jmv 5/5/2019 10:54:00'! - defaultFamilyPointSize: aNumber - " - FontFamily defaultFamilyPointSize: 12 - " - | family | - family _ AvailableFamilies at: DefaultFamilyName. - ^family atPointSize: aNumber! ! -!FontFamily class methodsFor: 'accessing fonts' stamp: 'jmv 5/5/2019 10:54:08'! - familyName: aString pointSize: aNumber - " - FontFamily familyName: 'DejaVu' pointSize: 12 - " - | family | - family _ AvailableFamilies at: aString ifAbsent: [^nil]. - ^family atPointSize: aNumber! ! - -FontFamily initialize! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3731-FontFamily-JuanVuletich-2019May05-10h53m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3726] on 5 May 2019 at 11:12:11 am'! -!FontFamily methodsFor: 'accessing' stamp: 'jmv 5/5/2019 11:03:44'! - aroundPointSize: aNumber - ^baseFontBySizes at: aNumber ifAbsent: [ |found | - found _ nil. - baseFontBySizes do: [ :font | - (found isNil or: [ (found pointSize - aNumber) abs > (font pointSize - aNumber) abs ]) - ifTrue: [ found _ font ]]. - found - ]! ! -!FontFamily methodsFor: 'accessing' stamp: 'jmv 5/5/2019 11:08:04'! - pointSizes - ^baseFontBySizes keys sort! ! -!FontFamily class methodsFor: 'accessing fonts' stamp: 'jmv 5/5/2019 11:10:37'! - defaultFamilyAndPointSize - " - FontFamily defaultFamilyAndPointSize - " - | family | - family _ AvailableFamilies at: DefaultFamilyName. - ^family atPointSize: DefaultPointSize ! ! -!FontFamily class methodsFor: 'accessing fonts' stamp: 'jmv 5/5/2019 11:04:13'! -familyName: aString aroundPointSize: aNumber - " - FontFamily familyName: 'DejaVu' aroundPointSize: 120 - " - | family | - family _ AvailableFamilies at: aString ifAbsent: [^nil]. - ^family aroundPointSize: aNumber! ! -!FontFamily class methodsFor: 'accessing fonts' stamp: 'jmv 5/5/2019 11:08:33'! - pointSizesFor: aString - " - FontFamily pointSizesFor: 'DejaVu' - " - | family | - family _ AvailableFamilies at: aString ifAbsent: [^nil]. - ^family pointSizes! ! -!SystemDictionary methodsFor: 'shrinking' stamp: 'jmv 5/5/2019 11:09:34' prior: 50391902! - reduceCuis - " - Smalltalk reduceCuis - " - | keep n unused newDicts oldDicts | - - self nominallyUnsent: #reduceCuis. - - "Remove icons" - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - PasteUpMorph allInstancesDo: [ :w | - w backgroundImageData: nil. - w submorphsDo: [ :a | a delete ]]. - Preferences useNoMenuIcons. - Theme current initialize. - Theme content: nil. - Color shutDown. - BitBltCanvas releaseClassCachedState. - - Transcript clear. - Clipboard default initialize. - - - "Remove some methods, even if they have senders." - Utilities removeSelector: #vmStatisticsReportString. - SystemDictionary removeSelector: #recreateSpecialObjectsArray. - - StrikeFont saveSpace. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - - keep := OrderedCollection new. - keep addAll: #(SpaceTally). - AppLauncher appGlobalName ifNotNil: [ :any | - keep add: any ]. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - [ - #hereWeGo print. - unused do: [:c | - c print. - (Smalltalk at: c) removeFromSystem]. - n := Smalltalk removeAllUnSentMessages. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - n > 0 or: [ - unused notEmpty ]] whileTrue. - ChangeSet zapAllChangeSets. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - Symbol rehash. - - "Shrink method dictionaries." - Smalltalk garbageCollect. - oldDicts _ MethodDictionary allInstances. - newDicts _ Array new: oldDicts size. - oldDicts withIndexDo: [:d :index | - newDicts at: index put: d rehashWithoutBecome ]. - oldDicts elementsExchangeIdentityWith: newDicts. - oldDicts _ newDicts _ nil. - - SmalltalkCompleter initialize . - - "Sanity checks" -" Undeclared - Smalltalk cleanOutUndeclared - Smalltalk browseUndeclaredReferences - Smalltalk obsoleteClasses - Smalltalk obsoleteBehaviors - Smalltalk browseObsoleteMethodReferences - SmalltalkImage current fixObsoleteReferences - Smalltalk browseAllUnimplementedCalls"! ! -!AbstractFont class methodsFor: 'instance accessing' stamp: 'jmv 5/5/2019 11:11:03' prior: 16777387! - default - " - Compatibility. - AbstractFont default - " - false ifTrue: [ self deprecatedMethod ]. "Too much senders to activate warnings right now!!" - ^FontFamily defaultFamilyAndPointSize! ! -!AbstractFont class methodsFor: 'instance accessing' stamp: 'jmv 5/5/2019 11:04:58' prior: 50372342! - familyName: aString aroundPointSize: aNumber - " - Compatibility. - AbstractFont familyName: Preferences defaultFontFamily aroundPointSize: 120 - " - false ifTrue: [ self deprecatedMethod ]. "Too much senders to activate warnings right now!!" - ^FontFamily familyName: aString aroundPointSize: aNumber! ! -!AbstractFont class methodsFor: 'instance accessing' stamp: 'jmv 5/5/2019 11:01:15' prior: 50372359! - familyName: aString pointSize: aNumber - " - Compatibility. - AbstractFont familyName: Preferences defaultFontFamily pointSize: 12 - " - false ifTrue: [ self deprecatedMethod ]. "Too much senders to activate warnings right now!!" - ^FontFamily familyName: aString pointSize: aNumber! ! -!AbstractFont class methodsFor: 'instance accessing' stamp: 'jmv 5/5/2019 11:06:50' prior: 16777421! - familyNames - " - Compatibility. - AbstractFont familyNames - " - false ifTrue: [ self deprecatedMethod ]. "Too much senders to activate warnings right now!!" - ^FontFamily familyNames! ! -!AbstractFont class methodsFor: 'instance accessing' stamp: 'jmv 5/5/2019 11:09:11' prior: 50372370! - pointSizesFor: aString - " - Compatibility. - AbstractFont pointSizesFor: Preferences defaultFontFamily - " - false ifTrue: [ self deprecatedMethod ]. "Too much senders to activate warnings right now!!" - ^FontFamily pointSizesFor: aString! ! -!FontFamily methodsFor: 'accessing' stamp: 'jmv 5/5/2019 10:33:56' prior: 50456807! - atPointSize: aNumber - ^baseFontBySizes at: aNumber ifAbsent: nil! ! - -StrikeFont class removeSelector: #removeForPDA! - -StrikeFont class removeSelector: #removeForPDA! - -StrikeFont class removeSelector: #removeMostFonts! - -StrikeFont class removeSelector: #removeMostFonts! - -StrikeFont class removeSelector: #removeSomeFonts! - -StrikeFont class removeSelector: #removeSomeFonts! - -AbstractFont class removeSelector: #initialize! - -AbstractFont class removeSelector: #initialize! - -AbstractFont initialize! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3732-FontStateInFontFamily-JuanVuletich-2019May05-11h01m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3727] on 5 May 2019 at 2:40:12 pm'! -!FontFamily class methodsFor: 'initialization' stamp: 'jmv 5/5/2019 14:33:28'! - defaultFamilyName: aString - DefaultFamilyName _ aString! ! -!FontFamily class methodsFor: 'initialization' stamp: 'jmv 5/5/2019 14:33:45'! - defaultPointSize: aNumber - DefaultPointSize _ aNumber! ! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 5/5/2019 14:34:40' prior: 16892991! - setSystemFontTo: aFont - "Establish the default text font and style" - - aFont ifNil: [^ self]. - FontFamily defaultFamilyName: aFont familyName. - FontFamily defaultPointSize: aFont pointSize.! ! - -AbstractFont class removeSelector: #default:! - -AbstractFont class removeSelector: #default:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3733-AbstractFontStateRemoval1-JuanVuletich-2019May05-14h33m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3728] on 5 May 2019 at 4:11:41 pm'! -!FontFamily class methodsFor: 'accessing' stamp: 'jmv 5/5/2019 14:58:07'! - defaultFamilyName - ^ DefaultFamilyName! ! -!FontFamily class methodsFor: 'initialization' stamp: 'jmv 5/5/2019 14:46:11'! - addFamily: aFontFamily - AvailableFamilies at: aFontFamily familyName put: aFontFamily! ! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 5/5/2019 15:04:20' prior: 50372193! - restoreDefaultFonts - "Since this is called from menus, we can take the opportunity to prompt for missing font styles. - Preferences restoreDefaultFonts - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 9) - (setListFontTo: 9) - (setMenuFontTo: 10) - (setWindowTitleFontTo: 12) - (setCodeFontTo: 9) - (setButtonFontTo: 9))! ! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 5/5/2019 15:05:14' prior: 50435943! - setDefaultFont: fontFamilyName spec: defaultFontsSpec - - | font | - defaultFontsSpec do: [ :triplet | - font _ FontFamily familyName: fontFamilyName pointSize: triplet second. - font ifNil: [ - StrikeFont install: FontFamily defaultFamilyName. - font _ FontFamily familyName: fontFamilyName pointSize: triplet second ]. - font ifNil: [ font _ FontFamily defaultFamilyAndPointSize ]. - triplet size > 2 ifTrue: [ - font _ font emphasized: triplet third ]. - self - perform: triplet first - with: font]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/5/2019 15:03:07' prior: 50437059! - defaultFont05 - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences defaultFont05 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 7) - (setListFontTo: 5) - (setMenuFontTo: 5) - (setWindowTitleFontTo: 7) - (setCodeFontTo: 5) - (setButtonFontTo: 5)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/5/2019 15:03:11' prior: 50437077! - defaultFont06 - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences defaultFont06 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 7) - (setListFontTo: 6) - (setMenuFontTo: 6) - (setWindowTitleFontTo: 8) - (setCodeFontTo: 6) - (setButtonFontTo: 6)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/5/2019 15:03:14' prior: 50437095! - defaultFont07 - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences defaultFont07 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 8) - (setListFontTo: 7) - (setMenuFontTo: 7) - (setWindowTitleFontTo: 9) - (setCodeFontTo: 7) - (setButtonFontTo: 7)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/5/2019 15:03:18' prior: 50437113! - defaultFont08 - "Sets not only fonts but other GUI elements - to fit low resolution or small screens - Preferences defaultFont08 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 8) - (setListFontTo: 8) - (setMenuFontTo: 8) - (setWindowTitleFontTo: 11) - (setCodeFontTo: 8) - (setButtonFontTo: 8)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/5/2019 15:03:22' prior: 50437131! - defaultFont09 - "Sets not only fonts but other GUI elements - to fit low resolution or small screens - Preferences defaultFont09 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 9) - (setListFontTo: 9) - (setMenuFontTo: 10) - (setWindowTitleFontTo: 12) - (setCodeFontTo: 9) - (setButtonFontTo: 9)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/5/2019 15:03:28' prior: 50437149! - defaultFont10 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont10 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 10) - (setListFontTo: 10) - (setMenuFontTo: 11) - (setWindowTitleFontTo: 12) - (setCodeFontTo: 10) - (setButtonFontTo: 10)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/5/2019 15:03:34' prior: 50449666! - defaultFont11 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont11 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 11) - (setListFontTo: 11) - (setMenuFontTo: 12) - (setWindowTitleFontTo: 14) - (setCodeFontTo: 11) - (setButtonFontTo: 11)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/5/2019 15:03:37' prior: 50449685! - defaultFont12 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont12 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 12) - (setListFontTo: 12) - (setMenuFontTo: 12) - (setWindowTitleFontTo: 14) - (setCodeFontTo: 12) - (setButtonFontTo: 12)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/5/2019 15:03:42' prior: 50449704! - defaultFont14 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont14 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 14) - (setListFontTo: 14) - (setMenuFontTo: 14) - (setWindowTitleFontTo: 17) - (setCodeFontTo: 14) - (setButtonFontTo: 14)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/5/2019 15:03:48' prior: 50435289! - defaultFont17 - "Sets not only fonts but other GUI elements - to fit high resolution or large screens - Preferences defaultFont17 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 17) - (setListFontTo: 17) - (setMenuFontTo: 17) - (setWindowTitleFontTo: 22) - (setCodeFontTo: 17) - (setButtonFontTo: 17)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/5/2019 15:03:51' prior: 50435307! -defaultFont22 - "Sets not only fonts but other GUI elements - to fit high resolution or large screens - Preferences defaultFont22 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 22) - (setListFontTo: 22) - (setMenuFontTo: 22) - (setWindowTitleFontTo: 28) - (setCodeFontTo: 22) - (setButtonFontTo: 22)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/5/2019 15:03:56' prior: 50435325! -defaultFont28 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont28 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 28) - (setListFontTo: 28) - (setMenuFontTo: 28) - (setWindowTitleFontTo: 36) - (setCodeFontTo: 28) - (setButtonFontTo: 28)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/5/2019 15:04:00' prior: 50435343! - defaultFont36 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont36 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 36) - (setListFontTo: 36) - (setMenuFontTo: 36) - (setWindowTitleFontTo: 46) - (setCodeFontTo: 36) - (setButtonFontTo: 36)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/5/2019 15:04:06' prior: 50435361! - defaultFont46 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont46 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 46) - (setListFontTo: 46) - (setMenuFontTo: 46) - (setWindowTitleFontTo: 60) - (setCodeFontTo: 46) - (setButtonFontTo: 46)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/5/2019 15:04:10' prior: 50435379! - defaultFont60 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont60 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 60) - (setListFontTo: 60) - (setMenuFontTo: 60) - (setWindowTitleFontTo: 80) - (setCodeFontTo: 60) - (setButtonFontTo: 60)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/5/2019 15:04:14' prior: 50435415! - defaultFont80 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont80 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 80) - (setListFontTo: 80) - (setMenuFontTo: 80) - (setWindowTitleFontTo: 80) - (setCodeFontTo: 80) - (setButtonFontTo: 80)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!AbstractFont methodsFor: 'displaying' stamp: 'jmv 5/5/2019 14:58:54' prior: 50372320! - on: aGrafPort displayString: aString from: firstIndex to: lastIndex at: p color: color - "Answer last affected pixel position - Answer nil if nothing was done" - - | char fallbackFont x y answer | - fallbackFont _ (FontFamily - familyName: FontFamily defaultFamilyName - aroundPointSize: self pointSize*0.9) - emphasized: self emphasis. - x _ p x. - y _ p y. - firstIndex to: lastIndex do: [ :i | - char _ aString at: i. - answer _ aGrafPort displayString: char asString from: 1 to: 1 at: x@y strikeFont: fallbackFont color: color. - x _ x + (self widthOf: char) ]. - ^answer! ! -!StrikeFont methodsFor: 'synthetic derivatives' stamp: 'jmv 5/5/2019 15:05:35' prior: 50372440! - syntheticSubscript - "Build and answer a derivative that is Subscript." - - | derivative | - derivative _ ((FontFamily familyName: FontFamily defaultFamilyName aroundPointSize: pointSize * 0.58) - emphasized: emphasis) - copy. - derivative useShortUnderscore. - ^ derivative - -" -StrikeFont allInstances do: [ :a | a reset ]. -('Hi ', (Text string: 'there' attribute: TextEmphasis superscript), ' how ', (Text string: 'are' attribute: TextEmphasis subscript), ' you?') edit. - -que todos, menos estos, tengan superscript y subscript en cero. Y en estos, apropiado. y en 'aca' usarlo. y listo -"! ! -!StrikeFont methodsFor: 'synthetic derivatives' stamp: 'jmv 5/5/2019 15:05:40' prior: 50372462! - syntheticSuperscript - "Build and answer a derivative that is Superscript." - - | derivative | - derivative _ ((FontFamily familyName: FontFamily defaultFamilyName aroundPointSize: pointSize * 0.58) - emphasized: emphasis) - copy. - derivative name: self name , 'Sup'. - ^ derivative - -" -StrikeFont allInstances do: [ :a | a reset ]. -('Hi ', (Text string: 'there' attribute: TextEmphasis superscript), ' how ', (Text string: 'are' attribute: TextEmphasis subscript), ' you?') edit. -"! ! -!StrikeFont class methodsFor: 'instance creation' stamp: 'jmv 5/5/2019 16:01:49' prior: 50437237! - install: aString -" -StrikeFont install: 'DejaVu'. -" -" -StrikeFont install: 'DejaVu Sans Mono'. -FontFamily defaultFamilyName: 'DejaVu Sans Mono'. -Preferences bigFonts. -Character initialize. -" -" -StrikeFont install: 'DejaVu Sans'. -StrikeFont buildLargerPunctuation: 'DejaVu Sans'. -FontFamily defaultFamilyName: 'DejaVu Sans'. -Preferences standardFonts. -Character initialize. -" -" -StrikeFont install: 'Inconsolata' -StrikeFont install: '#PilGi' -StrikeFont install: 'Optima' -StrikeFont install: 'Herculanum' -StrikeFont install: 'Papyrus' -StrikeFont install: 'Handwriting - Dakota' -StrikeFont install: 'Times New Roman' -StrikeFont install: 'Apple Chancery' -StrikeFont install: 'Cochin' -StrikeFont install: 'Cracked' -StrikeFont install: 'Zapfino' -StrikeFont install: 'Brush Script MT' -StrikeFont install: 'Chalkboard' -" - | family | - family _ nil. - 1 to: 200 do: [ :s | - (self create: aString size: s bold: true italic: true boldItalic: false) ifNotNil: [ :font | - font print. - family ifNil: [ - family _ StrikeFontFamily new. - family familyName: aString.]. - family atPointSize: s put: font ]]. - family ifNotNil: [ - FontFamily addFamily: family ]! ! -!FontFamily class methodsFor: 'initialization' stamp: 'jmv 5/5/2019 15:13:29' prior: 50456841! - migrate - " - FontFamily migrate - " - | family def strikeFont | - AvailableFamilies _ Dictionary new. - def _ AbstractFont default. - - AbstractFont familyNames do: [ :familyName | - family _ StrikeFontFamily new. - family familyName: familyName. - (AbstractFont pointSizesFor: familyName) do: [ :ps | - strikeFont _ AbstractFont familyName: familyName pointSize: ps. - family atPointSize: ps put: strikeFont. - def == strikeFont ifTrue: [ - DefaultFamilyName _ family familyName. - DefaultPointSize _ ps ]]. - AvailableFamilies at: family familyName put: family ].! ! -!UpdatingStringMorph class methodsFor: 'new-morph participation' stamp: 'jmv 5/5/2019 15:05:46' prior: 50372715! - initializedInstance - "Answer a digital clock" - - | newInst | - newInst := self - contents: '' - font: (AbstractFont familyName: FontFamily defaultFamilyName pointSize: 22) - emphasis: AbstractFont boldCode. - newInst - stepTime: 500; "half a second" - target: [String streamContents: [ :strm | DateAndTime now printHMSOn: strm]] ; - getSelector: #value. - - ^ newInst! ! - -Preferences class removeSelector: #defaultFontFamily! - -Preferences class removeSelector: #defaultFontFamily! - -Preferences class removeSelector: #setDefaultFontFamilyTo:! - -Preferences class removeSelector: #setDefaultFontFamilyTo:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3734-AbstractFontStateRemoval2-JuanVuletich-2019May05-16h10m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3729] on 5 May 2019 at 4:21:34 pm'! - -Object subclass: #AbstractFont - instanceVariableNames: '' - classVariableNames: 'AvailableFonts DefaultFont ' - poolDictionaries: '' - category: 'Graphics-Text'! - -!classDefinition: #AbstractFont category: #'Graphics-Text'! -Object subclass: #AbstractFont - instanceVariableNames: '' - classVariableNames: 'AvailableFonts DefaultFont' - poolDictionaries: '' - category: 'Graphics-Text'! - -FontFamily class removeSelector: #initialize! - -FontFamily class removeSelector: #initialize! - -FontFamily class removeSelector: #migrate! - -FontFamily class removeSelector: #migrate! - -AbstractFont class removeSelector: #availableFonts! - -AbstractFont class removeSelector: #availableFonts! - -Object subclass: #AbstractFont - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Text'! - -!classDefinition: #AbstractFont category: #'Graphics-Text'! -Object subclass: #AbstractFont - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Text'! - -FontFamily initialize! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3735-AbstractFontStateRemoval3-JuanVuletich-2019May05-16h20m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3735] on 6 May 2019 at 5:52:48 pm'! -!FontFamily class methodsFor: 'accessing' stamp: 'jmv 5/6/2019 17:50:27'! - defaultPointSize - ^ DefaultPointSize ! ! -!FontChanger class methodsFor: 'prompting user' stamp: 'jmv 5/6/2019 17:48:01' prior: 50456168! - promptUserWithFamilies: fontFamilies withMessageOnSelection: aMessageSymbol - " - Present a menu of available font families, and if one is chosen, - send aMessageSymbol to self with the corresponding font family as argument. - " - | fontMenu priorFontFamily | - priorFontFamily _ FontFamily defaultFamilyName. - fontMenu _ MenuMorph new defaultTarget: self. - fontFamilies do: [:fontName | - | isCurrent label | - isCurrent _ priorFontFamily sameAs: fontName. - label _ self toSelectableMenuLabel: fontName isCurrent: isCurrent. - fontMenu - add: label - target: self - action: aMessageSymbol - argument: fontName. - ]. - fontMenu invokeModal.! ! -!FontChanger class methodsFor: 'changing font' stamp: 'jmv 5/6/2019 17:50:36' prior: 50456315! - changeTo: aFontName - "Change the font on the whole system without changing point sizes." - FontFamily defaultFamilyName: aFontName. - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: { - {#setSystemFontTo:. FontFamily defaultPointSize}. - {#setListFontTo:. Preferences standardListFont pointSize.}. - {#setMenuFontTo:. Preferences standardMenuFont pointSize.}. - {#setWindowTitleFontTo:. Preferences windowTitleFont pointSize.}. - {#setCodeFontTo:. Preferences standardCodeFont pointSize.}. - {#setButtonFontTo:. Preferences standardButtonFont pointSize.}. - }. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]. - -! ! -!FontChanger class methodsFor: 'changing font' stamp: 'jmv 5/6/2019 17:52:10' prior: 50456201! - installFontIfNecessary: aFontName - | isFontInstalled | - isFontInstalled _ FontFamily familyNames includes: aFontName. - isFontInstalled ifFalse: [StrikeFont install: aFontName.].! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3736-AdaptFontChanger-JuanVuletich-2019May06-17h47m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3736] on 7 May 2019 at 9:43:54 am'! -!StrikeFontFamily methodsFor: 'accessing' stamp: 'jmv 5/7/2019 09:21:59'! - atPointSize: aNumber put: aFontAndSize - "aFontAndSize must have emphasis = 0, i.e. it is a base font" - baseFontBySizes at: aNumber put: aFontAndSize ! ! - -FontFamily removeSelector: #atPointSize:put:! - -FontFamily removeSelector: #atPointSize:put:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3737-FontFamilyTweak-JuanVuletich-2019May07-07h39m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3738] on 7 May 2019 at 10:14:06 am'! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/7/2019 10:13:23' prior: 50456218! - preferencesMenu - "Build the preferences menu for the world." - - ^ (self menu: 'Preferences...') - addItemsFromDictionaries: { - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Font Sizes...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Set font...'. - #object -> FontChanger. - #selector -> #promptUserAndInstallIfNecessaryWithFamilies:. - #arguments -> {FontFamily familyNames}. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'change the current font family.' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3738-DynamicWorldMenu-JuanVuletich-2019May07-10h10m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3738] on 9 May 2019 at 7:00:28 am'! -!Character class methodsFor: 'class initialization' stamp: 'jmv 5/9/2019 07:00:25' prior: 50417662! - initialize - "Create the table of unique Characters. - Character initialize - " - self initializeLookupTables. - self initializeUnicodeCodePoints.! ! -!Character class methodsFor: 'class initialization' stamp: 'jmv 5/7/2019 19:52:45' prior: 16800808! - initializeUnicodeCodePoints - " - Character initializeUnicodeCodePoints - String streamContents: [ :strm | 28 to: 255 do: [ :i | strm nextPut: (Character numericValue: i) ]] - " - - "Initialize the table of Unicode code points" - UnicodeCodePoints _ Array new: 256. - 0 to: 255 do: [ :code | - UnicodeCodePoints at: code + 1 put: code ]. - - "Arrows" - UnicodeCodePoints at: 28+1 put: 8592. "left arrow" - UnicodeCodePoints at: 29+1 put: 8594. "right arrow" - UnicodeCodePoints at: 30+1 put: 8593. "up arrow" - UnicodeCodePoints at: 31+1 put: 8595. "down arrow" - - "The following codes are different in ISO 8859-15 from those in ISO 8859-1, - so the character code is not equal to the Unicode code point" - UnicodeCodePoints at: 16rA4+1 put: 16r20AC. "euro sign" - UnicodeCodePoints at: 16rA6+1 put: 16r160. "latin capital letter S with caron" - UnicodeCodePoints at: 16rA8+1 put: 16r161. "latin small letter s with caron" - UnicodeCodePoints at: 16rB4+1 put: 16r17D. "latin capital letter Z with caron" - UnicodeCodePoints at: 16rB8+1 put: 16r17E. "latin small letter z with caron" - UnicodeCodePoints at: 16rBC+1 put: 16r152. "latin capital ligature OE" - UnicodeCodePoints at: 16rBD+1 put: 16r153. "latin small ligature oe" - UnicodeCodePoints at: 16rBE+1 put: 16r178. "latin capital letter Y with diaeresis" - - UnicodeCodePoints at: 16r80+1 put: 16r2200. "FOR ALL" - UnicodeCodePoints at: 16r81+1 put: 16r2202. "PARTIAL DIFFERENTIAL" - UnicodeCodePoints at: 16r82+1 put: 16r2203. "THERE EXISTS" - UnicodeCodePoints at: 16r83+1 put: 16r2204. "THERE DOES NOT EXIST" - UnicodeCodePoints at: 16r84+1 put: 16r2205. "EMPTY SET" - UnicodeCodePoints at: 16r85+1 put: 16r221E. "INFINITY" - UnicodeCodePoints at: 16r86+1 put: 16r2102. "DOUBLE-STRUCK CAPITAL C" - UnicodeCodePoints at: 16r87+1 put: 16r210D. "DOUBLE-STRUCK CAPITAL H" - UnicodeCodePoints at: 16r88+1 put: 16r2115. "DOUBLE-STRUCK CAPITAL N" - UnicodeCodePoints at: 16r89+1 put: 16r2119. "DOUBLE-STRUCK CAPITAL P" - UnicodeCodePoints at: 16r8A+1 put: 16r211A. "DOUBLE-STRUCK CAPITAL Q" - UnicodeCodePoints at: 16r8B+1 put: 16r211D. "DOUBLE-STRUCK CAPITAL R" - UnicodeCodePoints at: 16r8C+1 put: 16r2124. "DOUBLE-STRUCK CAPITAL Z" - UnicodeCodePoints at: 16r8D+1 put: 16r2135. "ALEF SYMBOL" - UnicodeCodePoints at: 16r8E+1 put: 16r2A00. "N-ARY CIRCLED DOT OPERATOR" - UnicodeCodePoints at: 16r8F+1 put: 16r2A01. "N-ARY CIRCLED PLUS OPERATOR" - UnicodeCodePoints at: 16r90+1 put: 16r2A02. "N-ARY CIRCLED TIMES OPERATOR" - UnicodeCodePoints at: 16r91+1 put: 16r2211. "N-ARY SUMMATION" - UnicodeCodePoints at: 16r92+1 put: 16r222B. "INTEGRAL" - UnicodeCodePoints at: 16r93+1 put: 16r2A15. "INTEGRAL AROUND A POINT OPERATOR" - UnicodeCodePoints at: 16r94+1 put: 16r2260. "NOT EQUAL TO" - UnicodeCodePoints at: 16r95+1 put: 16r2261. "IDENTICAL TO" - UnicodeCodePoints at: 16r96+1 put: 16r2262. "NOT IDENTICAL TO" - UnicodeCodePoints at: 16r97+1 put: 16r2263. "STRICTLY EQUIVALENT TO" - UnicodeCodePoints at: 16r98+1 put: 16r2264. "LESS-THAN OR EQUAL TO" - UnicodeCodePoints at: 16r99+1 put: 16r2265. "GREATER-THAN OR EQUAL TO" - UnicodeCodePoints at: 16r9A+1 put: 16r2266. "LESS-THAN OVER EQUAL TO" - UnicodeCodePoints at: 16r9B+1 put: 16r2267. "GREATER-THAN OVER EQUAL TO" - UnicodeCodePoints at: 16r9C+1 put: 16r2268. "LESS-THAN BUT NOT EQUAL TO" - UnicodeCodePoints at: 16r9D+1 put: 16r2269. "GREATER-THAN BUT NOT EQUAL TO" - UnicodeCodePoints at: 16r9E+1 put: 16r2218. "RING OPERATOR" - UnicodeCodePoints at: 16r9F+1 put: 16r2219. "BULLET OPERATOR"! ! - -Character initialize! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3739-UnicodeTranslationOfArrows-JuanVuletich-2019May09-06h54m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3739] on 10 May 2019 at 11:14:14 am'! -!FontFamily class methodsFor: 'file read write' stamp: 'jmv 5/10/2019 10:04:51'! - readAdditionalTrueTypeFonts - Feature require: 'VectorGraphics'. - Smalltalk at: #TrueTypeFontFamily ifPresent: [ :cls | cls readAdditionalFonts ]! ! -!FontChanger class methodsFor: 'prompting user' stamp: 'jmv 5/10/2019 10:40:37'! - familyNames - | monospacedStrikeFont options | - monospacedStrikeFont _ 'DejaVu Sans Mono'. - options _ FontFamily familyNames. - (options includes: monospacedStrikeFont) ifFalse: [ - options _ options copyWith: monospacedStrikeFont ]. - ^ options! ! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 5/10/2019 11:12:15' prior: 50457131! - setDefaultFont: fontFamilyName spec: defaultFontsSpec - - | font | - defaultFontsSpec do: [ :triplet | - font _ FontFamily familyName: fontFamilyName pointSize: triplet second. - font ifNil: [ - self revisar. "Please remove this hack meant to install larger DejaVu StrikeFonts on demand." - StrikeFont install: FontFamily defaultFamilyName. - font _ FontFamily familyName: fontFamilyName pointSize: triplet second ]. - font ifNil: [ font _ FontFamily defaultFamilyAndPointSize ]. - triplet size > 2 ifTrue: [ - font _ font emphasized: triplet third ]. - self - perform: triplet first - with: font]! ! -!StrikeFont methodsFor: 'emphasis' stamp: 'jmv 5/6/2019 18:04:56' prior: 50454113! - makeItalicGlyphs - "Make an italic set of glyphs with same widths by skewing left and right. - In the process, characters would overlap, so we widen them all first. - " - | extraWidth newGlyphs newXTable x newX w extraOnLeft | - extraOnLeft _ (self lineSpacing-1-self ascent+4)//4 max: 0. - extraWidth _ ((self ascent-5+4)//4 max: 0) + extraOnLeft. - newGlyphs _ Form extent: (glyphs width + (maxAscii + 1 - minAscii*extraWidth)) @ glyphs height depth: glyphs depth. - newGlyphs fillWhite. - newXTable _ xTable copy. - - "Copy glyphs into newGlyphs with room on left and right for overlap." - minAscii to: maxAscii+1 do: - [:ascii | x _ xTable at: ascii+1. w _ (xTable at: ascii+2) - x. - newX _ newXTable at: ascii+1. - newGlyphs copy: ((newX + extraOnLeft) @ 0 extent: w @ glyphs height) - from: x @ 0 in: glyphs rule: Form over. - newXTable at: ascii+2 put: newX + w + extraWidth]. - glyphs _ newGlyphs. - xTable _ newXTable. - "Slide the bitmaps left and right for synthetic italic effect." - 4 to: self ascent-1 by: 4 do: - [:y | "Slide ascenders right..." - glyphs copy: (1@0 extent: glyphs width @ (self ascent - y)) - from: 0@0 in: glyphs rule: Form over]. - self ascent to: self lineSpacing-1 by: 4 do: - [:y | "Slide descenders left..." - glyphs copy: (0@y extent: glyphs width @ glyphs height) - from: 1@y in: glyphs rule: Form over]. - self isSynthetic: true! ! -!FontFamily class methodsFor: 'initialization' stamp: 'jmv 5/10/2019 11:12:22' prior: 50457077! - defaultFamilyName: aString - | family | - self revisar. "Please remove this hack meant to install larger DejaVu StrikeFonts on demand." - aString = 'DejaVu' ifTrue: [ - family _ AvailableFamilies at: aString. - (family pointSizes includes: DefaultPointSize) ifFalse: [ StrikeFont install: aString]]. - DefaultFamilyName _ aString! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 5/10/2019 10:21:36' prior: 16926073! - drawLabelOn: aCanvas - - | e x0 y0 f w availableW l | - f _ Preferences windowTitleFont. - e _ self boxExtent. - x0 _ e x * 4 + 14. - y0 _ 2+3. - y0 _ e y - f ascent // 2. - availableW _ extent x - x0. - l _ labelString. - w _ f widthOfString: l. - [ w > availableW ] whileTrue: [ - l _ l squeezedTo: (1.0 * l size * availableW / w) truncated. - l isEmpty ifTrue: [ ^self ]. - w _ f widthOfString: l ]. - aCanvas - drawString: l - at: x0@y0 - font: f - color: Theme current windowLabel - embossed: Theme current embossedTitles! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/10/2019 10:39:45' prior: 50457730! - preferencesMenu - "Build the preferences menu for the world." - - ^ (self menu: 'Preferences...') - addItemsFromDictionaries: { - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Font Sizes...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Set font...'. - #object -> FontChanger. - #selector -> #promptUserAndInstallIfNecessaryWithFamilies:. - #arguments -> {FontChanger familyNames}. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'change the current font family.' - } asDictionary. - { - #label -> 'Load extra fonts'. - #object -> FontFamily. - #selector -> #readAdditionalTrueTypeFonts. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'Load additional TrueType fonts included with Cuis.' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3740-TrueTypeFontsOnDemand-JuanVuletich-2019May10-11h13m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3729] on 9 May 2019 at 4:02:29 pm'! -!CodeWindow methodsFor: 'keyboard shortcuts' stamp: 'EB 5/9/2019 16:00:27' prior: 50445683! - messageListKey: aChar from: view - "Respond to a Command key. I am a model with a code pane, and I also - have a listView that has a list of methods. The view knows how to get - the list and selection." - - | sel class | - aChar == $D ifTrue: [^ model toggleDiffing]. - - sel _ model selectedMessageName. - aChar == $m ifTrue: [ "These next two put up a type in if no message selected" - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllImplementorsOf: to: Smalltalk]. - aChar == $n ifTrue: [ - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllCallsOn: to: Smalltalk]. - - "The following require a class selection" - (class _ model selectedClassOrMetaClass) ifNil: [^ self ]. - aChar == $b ifTrue: [^ BrowserWindow fullOnClass: class selector: sel]. - aChar == $N ifTrue: [^ self browseClassRefs]. - aChar == $i ifTrue: [^ self methodHierarchy]. - aChar == $h ifTrue: [^ self browseHierarchy]. - aChar == $p ifTrue: [^ self browseFullProtocol]. - - sel - ifNotNil: [ - "The following require a method selection" - aChar == $o ifTrue: [^ model fileOutMessage]. - aChar == $c ifTrue: [^ model copySelector]. - aChar == $v ifTrue: [^ self browseVersions]. - aChar == $C ifTrue: [^ model showHomeCategory]. - aChar == $O ifTrue: [^ self openSingleMessageBrowser]. - aChar == $x ifTrue: [^ model removeMessage]. - aChar == $t ifTrue: [^ model runMethodTest]. - aChar == $r ifTrue: [^ model debugMethodTest]. - aChar == $R ifTrue: [^ self renameSelector]] - ifNil: [ - aChar == $R ifTrue: [^ model renameClass]]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3741-ShowCategoryShortcut-EricBrandwein-2019May09-15h34m-EB.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3741] on 12 May 2019 at 10:33:47 pm'! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:42:20'! - FF - " - Character FF - " - ^ $! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:34:09'! - circ - " - Character circ - " - ^ $•! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:39:22'! - div - " - Character div - " - ^ $÷! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:33:06'! - epsilon - " - Character epsilon - " - ^ $„! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:39:44'! - pi - " - Character pi - " - ^ $ƒ! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:40:22'! - sqrt - " - Character sqrt - " - ^ $Ÿ! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:44:27'! - zeta - " - Character zeta - " - ^ $…! ! -!Character class methodsFor: 'class initialization' stamp: 'len 5/12/2019 22:31:40' prior: 50457842! - initializeUnicodeCodePoints - " - Character initializeUnicodeCodePoints - String streamContents: [ :strm | 28 to: 255 do: [ :i | strm nextPut: (Character numericValue: i) ]] - " - - "Initialize the table of Unicode code points" - UnicodeCodePoints _ Array new: 256. - 0 to: 255 do: [ :code | - UnicodeCodePoints at: code + 1 put: code ]. - - "Arrows" - UnicodeCodePoints at: 28+1 put: 8592. "left arrow" - UnicodeCodePoints at: 29+1 put: 8594. "right arrow" - UnicodeCodePoints at: 30+1 put: 8593. "up arrow" - UnicodeCodePoints at: 31+1 put: 8595. "down arrow" - - "The following codes are different in ISO 8859-15 from those in ISO 8859-1, - so the character code is not equal to the Unicode code point" - UnicodeCodePoints at: 16rA4+1 put: 16r20AC. "euro sign" - UnicodeCodePoints at: 16rA6+1 put: 16r160. "latin capital letter S with caron" - UnicodeCodePoints at: 16rA8+1 put: 16r161. "latin small letter s with caron" - UnicodeCodePoints at: 16rB4+1 put: 16r17D. "latin capital letter Z with caron" - UnicodeCodePoints at: 16rB8+1 put: 16r17E. "latin small letter z with caron" - UnicodeCodePoints at: 16rBC+1 put: 16r152. "latin capital ligature OE" - UnicodeCodePoints at: 16rBD+1 put: 16r153. "latin small ligature oe" - UnicodeCodePoints at: 16rBE+1 put: 16r178. "latin capital letter Y with diaeresis" - - UnicodeCodePoints at: 16r80+1 put: 16r2205. "EMPTY SET" - UnicodeCodePoints at: 16r81+1 put: 16r221E. "INFINITY" - UnicodeCodePoints at: 16r82+1 put: 16r2135. "ALEF SYMBOL" - UnicodeCodePoints at: 16r83+1 put: 16r03C0. "pi" - UnicodeCodePoints at: 16r84+1 put: 16r03B5. "epsilon" - UnicodeCodePoints at: 16r85+1 put: 16r03B6. "zeta" - UnicodeCodePoints at: 16r86+1 put: 16r0394. "Delta" - UnicodeCodePoints at: 16r87+1 put: 16r03A9. "Omega" - UnicodeCodePoints at: 16r88+1 put: 16r2102. "DOUBLE-STRUCK CAPITAL C" - UnicodeCodePoints at: 16r89+1 put: 16r210D. "DOUBLE-STRUCK CAPITAL H" - UnicodeCodePoints at: 16r8A+1 put: 16r2115. "DOUBLE-STRUCK CAPITAL N" - UnicodeCodePoints at: 16r8B+1 put: 16r2119. "DOUBLE-STRUCK CAPITAL P" - UnicodeCodePoints at: 16r8C+1 put: 16r211A. "DOUBLE-STRUCK CAPITAL Q" - UnicodeCodePoints at: 16r8D+1 put: 16r211D. "DOUBLE-STRUCK CAPITAL R" - UnicodeCodePoints at: 16r8E+1 put: 16r2124. "DOUBLE-STRUCK CAPITAL Z" - UnicodeCodePoints at: 16r8F+1 put: 16r0046. "DOUBLE-STRUCK CAPITAL F" "should be 1D53D, index out of bounds" - UnicodeCodePoints at: 16r90+1 put: 16r2295. "OPLUS" - UnicodeCodePoints at: 16r91+1 put: 16r2297. "OTIMES" - UnicodeCodePoints at: 16r92+1 put: 16r2299. "ODOT" - UnicodeCodePoints at: 16r93+1 put: 16r2296. "OMINUS" - UnicodeCodePoints at: 16r94+1 put: 16r2217. "ASTERISK OPERATOR" - UnicodeCodePoints at: 16r95+1 put: 16r2218. "RING OPERATOR (circ)" - UnicodeCodePoints at: 16r96+1 put: 16r2219. "BULLET OPERATOR (filled circ)" - UnicodeCodePoints at: 16r97+1 put: 16r22C5. "DOT OPERATOR" "(already at B7)" - UnicodeCodePoints at: 16r98+1 put: 16r22C6. "STAR OPERATOR" - UnicodeCodePoints at: 16r99+1 put: 16r21A0. "SURJECTIVE ARROW" - UnicodeCodePoints at: 16r9A+1 put: 16r21A3. "INJECTIVE ARROW" - UnicodeCodePoints at: 16r9B+1 put: 16r2194. "BIJECTIVE ARROW" - UnicodeCodePoints at: 16r9C+1 put: 16r21AA. "INCLUSION ARROW" - UnicodeCodePoints at: 16r9D+1 put: 16r21A6. "MAPPING ARROW" - UnicodeCodePoints at: 16r9E+1 put: 16r2202. "PARTIAL DIFFERENTIAL" - UnicodeCodePoints at: 16r9F+1 put: 16r221A. "SQUARE ROOT" - - UnicodeCodePoints at: 16r2D+1 put: 16r2212. "WIDE MINUS" - UnicodeCodePoints at: 16r2A+1 put: 16r2217. "CENTERED ASTERISK"! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:41:10' prior: 16801334! - CC - " - Character CC - " - ^ $ˆ! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:41:20' prior: 16801338! - HH - " - Character HH - " - ^ $‰! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:41:29' prior: 16801342! - NN - " - Character NN - " - ^ $Š! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:41:38' prior: 16801346! - PP - " - Character PP - " - ^ $‹! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:41:48' prior: 16801350! - QQ - " - Character QQ - " - ^ $Œ! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:41:55' prior: 16801354! - RR - " - Character RR - " - ^ $! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:42:11' prior: 16801358! - ZZ - " - Character ZZ - " - ^ $Ž! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:43:23' prior: 16801362! - aleph - " - Character aleph - " - ^ $‚! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:35:59' prior: 16801367! - bullet - " - Character bullet - " - ^ $–! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:33:17' prior: 16801397! - emptySet - " - Character emptySet - " - ^ $€! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:36:47' prior: 50371936! - infinity - " - Character infinity - " - ^ $! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:36:35' prior: 16801473! - oplus - " - Character oplus - " - ^ $! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:37:52' prior: 16801478! - otimes - " - Character otimes - " - ^ $‘! ! -!String class methodsFor: 'initialization' stamp: 'len 5/12/2019 21:51:05' prior: 16917924! - initialize - " - String initialize - " - - | order newOrder lowercase | - - "Case insensitive compare sorts null, space, digits, letters, all the rest..." - newOrder _ Array new: 256. - order _ -1. - newOrder at: 0+1 put: (order _ order+1). - 32 to: 64 do: [ :c | - newOrder at: c + 1 put: (order _ order+1)]. - #(92 94 124 126) do: [ :c | "\^|~" - newOrder at: c + 1 put: (order _ order+1)]. - 16r90 to: 16r9F do: [:c| "special math operators" - newOrder at: c + 1 put: (order _ order+1)]. - Character uppercaseLowercaseAndUnaccentedLetters do: [ :upperAndLowercase | - order _ order+1. - newOrder at: upperAndLowercase first numericValue + 1 put: order. - upperAndLowercase size > 1 ifTrue: [ - newOrder at: upperAndLowercase second numericValue + 1 put: order ]]. - 1 to: newOrder size do: [ :i | - (newOrder at: i) ifNil: [ - newOrder at: i put: (order _ order+1)]]. - CaseInsensitiveOrder _ newOrder asByteArray. - - "Case sensitive compare sorts null, space, digits, letters, all the rest..." - newOrder _ Array new: 256. - order _ -1. - newOrder at: 0+1 put: (order _ order+1). - 32 to: 64 do: [ :c | - newOrder at: c + 1 put: (order _ order+1)]. - #(92 94 124 126) do: [ :c | "\^|~" - newOrder at: c + 1 put: (order _ order+1)]. - 16r90 to: 16r9F do: [:c| "special math operators" - newOrder at: c + 1 put: (order _ order+1)]. - Character uppercaseLowercaseAndUnaccentedLetters do: [ :upperAndLowercase | - upperAndLowercase size > 1 ifTrue: [ - newOrder at: upperAndLowercase first numericValue + 1 put: (order _ order+1) ]]. - Character uppercaseLowercaseAndUnaccentedLetters do: [ :upperAndLowercase | - lowercase _ upperAndLowercase size = 1 - ifTrue: [ upperAndLowercase first ] - ifFalse: [ upperAndLowercase second ]. - newOrder at: lowercase numericValue + 1 put: (order _ order+1) ]. - 1 to: newOrder size do: [ :i | - (newOrder at: i) ifNil: [ - newOrder at: i put: (order _ order+1)]]. - order = 255 ifFalse: [self error: 'order problem']. - CaseSensitiveOrder _ newOrder asByteArray. - - "a table for translating to lower case" - LowercasingTable _ String withAll: (Character characterTable collect: [:c | c asLowercase]). - - "a table for translating to upper case" - UppercasingTable _ String withAll: (Character characterTable collect: [:c | c asUppercase]). - - "a table for testing tokenish (for fast numArgs)" - Tokenish _ String withAll: (Character characterTable collect: - [:c | c tokenish ifTrue: [c] ifFalse: [$~]]). - - "CR and LF--characters that terminate a line" - CSLineEnders _ CharacterSet new. - CSLineEnders add: Character cr. - CSLineEnders add: Character lf. - - "separators and non-separators" - CSSeparators _ CharacterSet separators. - CSNonSeparators _ CSSeparators complement! ! - -Character class removeSelector: #circle! - -Character class removeSelector: #circle! - -Character class removeSelector: #contourIntegral! - -Character class removeSelector: #contourIntegral! - -Character class removeSelector: #doesNotExist! - -Character class removeSelector: #doesNotExist! - -Character class removeSelector: #exists! - -Character class removeSelector: #exists! - -Character class removeSelector: #forAll! - -Character class removeSelector: #forAll! - -Character class removeSelector: #greaterNotEqual! - -Character class removeSelector: #greaterNotEqual! - -Character class removeSelector: #greaterOrEqual! - -Character class removeSelector: #greaterOrEqual! - -Character class removeSelector: #greaterOverEqual! - -Character class removeSelector: #greaterOverEqual! - -Character class removeSelector: #identical! - -Character class removeSelector: #identical! - -Character class removeSelector: #integral! - -Character class removeSelector: #integral! - -Character class removeSelector: #lessNotEqual! - -Character class removeSelector: #lessNotEqual! - -Character class removeSelector: #lessOrEqual! - -Character class removeSelector: #lessOrEqual! - -Character class removeSelector: #lessOverEqual! - -Character class removeSelector: #lessOverEqual! - -Character class removeSelector: #notEqual! - -Character class removeSelector: #notEqual! - -Character class removeSelector: #notIdentical! - -Character class removeSelector: #notIdentical! - -Character class removeSelector: #odot! - -Character class removeSelector: #odot! - -Character class removeSelector: #partial! - -Character class removeSelector: #partial! - -Character class removeSelector: #strictlyEquivalent! - -Character class removeSelector: #strictlyEquivalent! - -Character class removeSelector: #summation! - -Character class removeSelector: #summation! - -Character initialize! - -String initialize! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3742-MathCharacters-LucianoEstebanNotarfrancesco-2019May12-12h53m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3741] on 13 May 2019 at 10:30:38 am'! -!TextEditor methodsFor: 'events' stamp: 'jmv 5/13/2019 10:03:18' prior: 16932039! - mouseMove: aMouseMoveEvent localPosition: localEventPosition - "Change the selection in response to mouse-down drag" - - | newPointBlock goingBackwards newStartBlock newStopBlock interval i1 i2 | - newPointBlock _ textComposition characterBlockAtPoint: localEventPosition. - goingBackwards _ newPointBlock stringIndex < markBlock stringIndex. - - doWordSelection ifTrue: [ - pointBlock _ newPointBlock. - self selectWordLeftDelimiters: '' rightDelimiters: ''. - newStartBlock _ self startBlock min: initialSelectionStart. - newStopBlock _ self stopBlock max: initialSelectionStop. - markBlock _ goingBackwards ifTrue: [newStopBlock] ifFalse: [newStartBlock]. - pointBlock _ goingBackwards ifTrue: [newStartBlock] ifFalse: [newStopBlock]. - self storeSelectionInComposition. - ^self ]. - - doParagraphSelection ifTrue: [ - i1 _ newPointBlock stringIndex min: initialSelectionStart stringIndex. - i2 _ newPointBlock stringIndex max: initialSelectionStop stringIndex-1. - interval _ self privateCurrentString encompassParagraph: (i1 to: i2). - self selectFrom: interval first to: interval last. - newStartBlock _ self startBlock min: initialSelectionStart. - newStopBlock _ self stopBlock max: initialSelectionStop. - markBlock _ goingBackwards ifTrue: [newStopBlock] ifFalse: [newStartBlock]. - pointBlock _ goingBackwards ifTrue: [newStartBlock] ifFalse: [newStopBlock]. - self storeSelectionInComposition. - ^self ]. - - pointBlock _ newPointBlock. - self storeSelectionInComposition! ! -!PluggableScrollPane methodsFor: 'events' stamp: 'jmv 5/13/2019 10:22:02' prior: 16889553! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - - | eventPositionLocalToScroller | - eventPositionLocalToScroller _ localEventPosition - scroller morphPosition. - scroller mouseButton1Down: aMouseButtonEvent localPosition: eventPositionLocalToScroller. - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: nil - clkNHalf: nil - dblClkSel: #doubleClick:localPosition: - dblClkNHalfSel: #doubleClickAndHalf:localPosition: - tripleClkSel: nil! ! -!PluggableScrollPane methodsFor: 'events' stamp: 'jmv 5/13/2019 10:22:51' prior: 16889568! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - - | eventPositionLocalToScroller | - eventPositionLocalToScroller _ localEventPosition - scroller morphPosition. - super mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition. - scroller mouseButton1Up: aMouseButtonEvent localPosition: eventPositionLocalToScroller! ! -!PluggableScrollPane methodsFor: 'events' stamp: 'jmv 5/13/2019 10:22:12' prior: 16889578! - mouseMove: aMouseMoveEvent localPosition: localEventPosition - - | eventPositionLocalToScroller | - eventPositionLocalToScroller _ localEventPosition - scroller morphPosition. - scroller mouseMove: aMouseMoveEvent localPosition: eventPositionLocalToScroller! ! -!TextModelMorph methodsFor: 'editor access' stamp: 'jmv 5/13/2019 10:30:16' prior: 50455291! - scrollSelectionIntoView - "Scroll my text into view if necessary and return true, else return false" - - | delta | - delta _ self textMorph morphPosition. - self editor pointIndex > 1 - ifTrue: [ - self scrollToShow: (self editor pointBlock translatedBy: delta) ] - ifFalse: [ - self scrollToShow: (self editor selectionRectangle translatedBy: delta) ]! ! -!TextModelMorph methodsFor: 'events' stamp: 'jmv 5/13/2019 10:21:37' prior: 50381741! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - - | eventPositionLocalToScroller | - eventPositionLocalToScroller _ localEventPosition - scroller morphPosition. - scroller mouseButton1Down: aMouseButtonEvent localPosition: eventPositionLocalToScroller. - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: nil - clkNHalf: #clickAndHalf:localPosition: - dblClkSel: #doubleClick:localPosition: - dblClkNHalfSel: #doubleClickAndHalf:localPosition: - tripleClkSel: nil! ! -!InnerTextMorph methodsFor: 'event handling' stamp: 'jmv 5/13/2019 09:23:53' prior: 50432757! - processKeyStroke: evt - | action | - - (acceptOnCR and: [evt isReturnKey]) ifTrue: [^ self acceptContents]. - - self pauseBlinking. - - "Return - check for special action" - evt isReturnKey ifTrue: [ - action _ self crAction. - action ifNotNil: [ ^action value]]. - - "Esc - check for special action" - evt isEsc ifTrue: [ - action _ self escAction. - action ifNotNil: [ ^action value]]. - - self handleInteraction: [ editor processKeyStroke: evt ]. - self scrollSelectionIntoView! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3743-DragSelectionAutoscrollFixes-JuanVuletich-2019May13-10h26m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3743] on 13 May 2019 at 12:39:08 pm'! -!Color methodsFor: 'transformations' stamp: 'jmv 5/13/2019 12:37:50'! - *= anObject - super *= anObject. - self clipToValidValues! ! -!Color methodsFor: 'transformations' stamp: 'jmv 5/13/2019 12:38:03'! - += anObject - super += anObject. - self clipToValidValues! ! -!Color methodsFor: 'transformations' stamp: 'jmv 5/13/2019 12:38:13'! - -= anObject - super -= anObject. - self clipToValidValues! ! -!Color methodsFor: 'transformations' stamp: 'jmv 5/13/2019 12:38:18'! - /= anObject - super /= anObject. - self clipToValidValues! ! -!Color methodsFor: 'private' stamp: 'jmv 5/13/2019 12:37:37'! - clipToValidValues - | v | - 1 to: self size do: [ :i | - v _ self at: i. - v > 1 ifTrue: [self at: i put: 1.0]. - v < 0 ifTrue: [self at: i put: 0.0]]! ! -!Color methodsFor: 'transformations' stamp: 'jmv 5/13/2019 12:24:11' prior: 50353953! - * aNumberOrColor - "Answer this color with its RGB multiplied by the given number. " - " - (Color brown *2) display - " - (aNumberOrColor is: #Color) ifTrue: [ - ^ (Color new - setRed: (self red * aNumberOrColor red min: 1.0 max: 0.0) - green: (self green * aNumberOrColor green min: 1.0 max: 0.0) - blue: (self blue * aNumberOrColor blue min: 1.0 max: 0.0)) - alpha: self alpha * aNumberOrColor alpha - ]. - ^ (Color new - setRed: (self red * aNumberOrColor min: 1.0 max: 0.0) - green: (self green * aNumberOrColor min: 1.0 max: 0.0) - blue: (self blue * aNumberOrColor min: 1.0 max: 0.0)) - alpha: self alpha! ! -!Color methodsFor: 'transformations' stamp: 'jmv 5/13/2019 12:25:02' prior: 50353989! - / aNumberOrColor - "Answer this color with its RGB divided by the given number. " - " - (Color red / 2) display - " - (aNumberOrColor is: #Color) ifTrue: [ - ^ Color new - setRed: (self red / aNumberOrColor red min: 1.0 max: 0.0) - green: (self green / aNumberOrColor green min: 1.0 max: 0.0) - blue: (self blue / aNumberOrColor blue min: 1.0 max: 0.0) - ]. - ^ Color new - setRed: (self red / aNumberOrColor min: 1.0 max: 0.0) - green: (self green / aNumberOrColor min: 1.0 max: 0.0) - blue: (self blue / aNumberOrColor min: 1.0 max: 0.0)! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3744-Color-fix-JuanVuletich-2019May13-12h24m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3744] on 13 May 2019 at 11:42:23 pm'! -!StrikeFont methodsFor: 'synthetic derivatives' stamp: 'jmv 5/13/2019 23:33:44' prior: 50457471! - syntheticSubscript - "Build and answer a derivative that is Subscript." - - | derivative | - derivative _ ((FontFamily familyName: self familyName aroundPointSize: pointSize * 0.58) - emphasized: emphasis) - copy. - derivative useShortUnderscore. - ^ derivative - -" -StrikeFont allInstances do: [ :a | a reset ]. -('Hi ', (Text string: 'there' attribute: TextEmphasis superscript), ' how ', (Text string: 'are' attribute: TextEmphasis subscript), ' you?') edit. -"! ! -!StrikeFont methodsFor: 'synthetic derivatives' stamp: 'jmv 5/13/2019 23:33:31' prior: 50457493! - syntheticSuperscript - "Build and answer a derivative that is Superscript." - - | derivative | - derivative _ ((FontFamily familyName: self familyName aroundPointSize: pointSize * 0.58) - emphasized: emphasis) - copy. - derivative name: self name , 'Sup'. - ^ derivative - -" -StrikeFont allInstances do: [ :a | a reset ]. -('Hi ', (Text string: 'there' attribute: TextEmphasis superscript), ' how ', (Text string: 'are' attribute: TextEmphasis subscript), ' you?') edit. -"! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3745-StrikeFont-fix-JuanVuletich-2019May13-23h39m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3745] on 15 May 2019 at 7:29:25 pm'! -!TestCase methodsFor: 'assertions' stamp: 'HAW 5/15/2019 19:24:37'! -assert: anAction changes: aCondition - - | after before | - - before := aCondition value. - anAction value. - after := aCondition value. - - self deny: after = before! ! -!TestCase methodsFor: 'assertions' stamp: 'HAW 5/15/2019 19:25:11'! - assert: anAction changes: aCondition by: aDifference - - | after before | - - before := aCondition value. - anAction value. - after := aCondition value. - - self assert: after equals: before + aDifference! ! -!TestCase methodsFor: 'assertions' stamp: 'HAW 5/15/2019 19:27:33'! - assert: anAction changes: aCondition from: anInitialObject to: aFinalObject - - | after before | - - before := aCondition value. - anAction value. - after := aCondition value. - - self assert: before equals: anInitialObject. - self assert: after equals: aFinalObject! ! -!TestCase methodsFor: 'assertions' stamp: 'HAW 5/15/2019 19:27:43'! - assert: anAction doesNotChange: aCondition - - | after before | - - before := aCondition value. - anAction value. - after := aCondition value. - - self assert: after equals: before! ! -!TestCase methodsFor: 'assertions' stamp: 'HAW 5/15/2019 18:53:33'! - assert: aCollection includes: anObject - - ^ self assert: (aCollection includes: anObject) description: [ aCollection asString, ' does not include ', anObject asString ]! ! -!TestCase methodsFor: 'assertions' stamp: 'HAW 5/15/2019 18:57:54'! - assert: aNumber isNearTo: anotherNumber - - self assert: aNumber isNearTo: anotherNumber withPrecision: self defaultPrecision ! ! -!TestCase methodsFor: 'assertions' stamp: 'HAW 5/15/2019 19:23:07'! - assert: aNumber isNearTo: anotherNumber withPrecision: aPrecision - - self assert: (self is: aNumber biggerThan: anotherNumber withPrecision: aPrecision)! ! -!TestCase methodsFor: 'assertions' stamp: 'HAW 5/15/2019 18:58:32'! -assert: aNumber isNotNearTo: anotherNumber - - self assert: aNumber isNotNearTo: anotherNumber withPrecision: self defaultPrecision ! ! -!TestCase methodsFor: 'assertions' stamp: 'HAW 5/15/2019 19:23:13'! - assert: aFloatNumber isNotNearTo: anotherFloatNumber withPrecision: aPrecision - - self deny: (self is: aFloatNumber biggerThan: anotherFloatNumber withPrecision: aPrecision) -! ! -!TestCase methodsFor: 'assertions' stamp: 'HAW 5/15/2019 19:09:01'! - defaultPrecision - - ^ 0.0001 - ! ! -!TestCase methodsFor: 'assertions' stamp: 'HAW 5/15/2019 19:23:27'! - is: aNumber biggerThan: anotherNumber withPrecision: aPrecision - - aNumber = 0 ifTrue: [ ^ anotherNumber abs < aPrecision ]. - - ^ (aNumber - anotherNumber) abs < (aPrecision * (aNumber abs max: anotherNumber abs))! ! -!TestCase methodsFor: 'assertions' stamp: 'HAW 5/15/2019 19:04:32'! - should: aClosure notTakeMoreThan: aLimit - - | millisecondsLimit | - - millisecondsLimit := aLimit totalMilliseconds. - self assert: aClosure timeToRun <= millisecondsLimit description: [ 'Took more than ', millisecondsLimit printString, ' milliseconds' ]! ! -!TestCase methodsFor: 'assertions' stamp: 'HAW 5/15/2019 18:58:49' prior: 16927399! - deny: aBoolean description: aString - - self assert: aBoolean not description: aString - ! ! - -TestCase removeSelector: #should:takeLessThan:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3746-TestCaseAssertions-GastonCarusoHernanWilkinson-2019May15-18h28m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3746] on 17 May 2019 at 9:03:11 am'! -!ByteArray methodsFor: 'platform independent access' stamp: 'jmv 5/16/2019 16:01:00'! - bitAt: bitIndex - "Answer the bit (0 or 1) at a bit index. - This way, the receiver behaves as a BitArray. - Note: There is no error raised if you the possible access extra bits at the end if size is not multiple of 8." - | bitPosition index | - index _ bitIndex - 1 // 8 + 1. - bitPosition _ bitIndex - 1 \\ 8 + 1. - ^ self bitAt: index bitPosition: bitPosition! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'jmv 5/17/2019 08:52:33'! - bitAt: bitIndex put: aBit - "Set the bit (0 or 1) at a bit index. This way, the receiver behaves as a BitArray - Note: There is no error raised if you the possible access extra bits at the end if size is not multiple of 8. - #[1 0 0 ] bitAt: 1 - #[0 1 0 ] bitAt: 9 - #[0 0 128 ] bitAt: 24 - " - | bitPosition index | - index _ bitIndex - 1 // 8 + 1. - bitPosition _ bitIndex - 1 \\ 8 + 1. - self bitAt: index bitPosition: bitPosition put: aBit! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'jmv 5/17/2019 08:51:43'! - bitBooleanAt: bitIndex - "Consider the bit at bitIndex as a Boolean value. - 0 -> false - 1 -> true" - ^ (self bitAt: bitIndex) = 1! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'jmv 5/17/2019 08:52:49'! - bitBooleanAt: bitIndex put: aBoolean - "Consider the bit at bitIndex as a Boolean value. - 0 -> false - 1 -> true" - self bitAt: bitIndex put: (aBoolean ifTrue: [1] ifFalse: [0])! ! -!ByteArray methodsFor: 'private' stamp: 'jmv 5/16/2019 15:49:51'! - bitAt: index bitPosition: bitPosition - "Answer the bit (0 or 1) at byte at index, at bitPosition. - The bits are indexed starting at 1 for the least significant bit" - ^(self at: index) bitAt: bitPosition! ! -!ByteArray methodsFor: 'private' stamp: 'jmv 5/16/2019 15:58:53'! - bitAt: index bitPosition: bitPosition put: aBit - "Set the bit (0 or 1) at byte at index, at bitPosition. - The bit value should be 0 or 1, otherwise raise an Error. - The bits are indexed starting at 1 for the least significant bit" - self at: index put: ((self at: index) bitAt: bitPosition put: aBit)! ! -!ByteArray class methodsFor: 'instance creation' stamp: 'jmv 5/16/2019 15:59:16'! - newBits: bitCount - " - (ByteArray newBits: 8) bitAt: 8 put: 1; bitAt: 8 - (ByteArray newBits: 9) bitAt: 9 put: 1; bitAt: 9 - " - ^self new: bitCount + 7 // 8! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3747-BitArrayAccessInByteArray-JuanVuletich-2019May17-08h48m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3747] on 17 May 2019 at 9:53:10 am'! -!StrikeFont methodsFor: 'objects from disk' stamp: 'jmv 5/17/2019 09:52:58' prior: 16914907! - objectForDataStream: refStrm - - "I am about to be written on an object file. Write a textual reference instead. - Warning: This saves a lot of space, but might fail if using other fonts than those in AvailableFonts" - - ^ DiskProxy - global: #FontFamily - selector: #familyName:aroundPointSize: - args: (Array with: self familyName with: self pointSize)! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3748-StrikeFontSerialization-tweak-JuanVuletich-2019May17-09h52m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3748] on 18 May 2019 at 5:07:05 pm'! -!Collection class methodsFor: 'instance creation' stamp: 'HAW 5/18/2019 09:36:08'! - ofSize: aSize - - "Create a new collection of size aSize with nil as its elements. - This method exists because OrderedCollection new: aSize creates an - empty collection, not one of size aSize that it is necesary for #streamContents: - when sent to OrderedCollection" - - ^ self new: aSize! ! -!OrderedCollection methodsFor: 'initialization' stamp: 'HAW 5/18/2019 16:49:45'! - initializeOfSize: aSize - - array := Array new: aSize. - firstIndex := 1. - lastIndex := aSize.! ! -!OrderedCollection class methodsFor: 'instance creation' stamp: 'HAW 5/18/2019 16:49:03'! - ofSize: aSize - - "See superclass implementation" - - ^ super new initializeOfSize: aSize! ! -!SequenceableCollection class methodsFor: 'stream creation' stamp: 'HAW 5/18/2019 16:51:23' prior: 16907019! - streamContents: blockWithArg estimatedSize: estimatedSize - - | stream originalContents | - - stream _ WriteStream on: (self ofSize: estimatedSize). - blockWithArg value: stream. - originalContents _ stream originalContents. - - ^stream position = originalContents size - ifTrue: [ originalContents ] - ifFalse: [ stream contents ]! ! -!WriteStream methodsFor: 'private' stamp: 'HAW 5/18/2019 16:53:59' prior: 50341263! - growTo: anInteger - "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. - - anInteger is the required minimal new size of the collection " - - | oldSize grownCollection newSize | - oldSize _ collection size. - newSize _ anInteger + (oldSize max: 20). - grownCollection _ collection class ofSize: newSize. - collection _ grownCollection replaceFrom: 1 to: oldSize with: collection startingAt: 1. - writeLimit _ collection size! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3749-OrderedCollectionStreamContents-HernanWilkinson-2019May18-08h58m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3748] on 18 May 2019 at 5:13:28 pm'! -!Collection methodsFor: 'copying' stamp: 'HAW 5/18/2019 17:09:55'! - flatten - - ^ self species streamContents: [ :flattenedStream | self flattenTo: flattenedStream ]! ! -!Collection methodsFor: 'copying' stamp: 'HAW 5/18/2019 17:10:09'! - flattenTo: flattenedStream - - self do: [ :each | - each isCollection - ifTrue: [ each flattenTo: flattenedStream ] - ifFalse: [ flattenedStream nextPut: each ]]. - - ^ flattenedStream -! ! -!String methodsFor: 'copying' stamp: 'HAW 5/18/2019 17:10:29'! -flattenTo: flattenedStream - - flattenedStream nextPut: self! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3750-Flatten-GF-GC-HernanWilkinson-2019May18-17h09m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3744] on 17 May 2019 at 1:38:30 pm'! - -Smalltalk renameClassNamed: #LocalToInstanceVariable as: #TemporaryToInstanceVariable! - -Refactoring subclass: #TemporaryToInstanceVariable - instanceVariableNames: 'variable method' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #TemporaryToInstanceVariable category: #'Tools-Refactoring'! -Refactoring subclass: #TemporaryToInstanceVariable - instanceVariableNames: 'variable method' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #TemporaryToInstanceVariableApplier - instanceVariableNames: 'smalltalkEditor classToRefactor methodNode variableName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #TemporaryToInstanceVariableApplier category: #'Tools-Refactoring'! -RefactoringApplier subclass: #TemporaryToInstanceVariableApplier - instanceVariableNames: 'smalltalkEditor classToRefactor methodNode variableName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!SmalltalkEditor methodsFor: 'temp to inst var' stamp: 'EB 5/17/2019 13:00:30'! - temporaryToInstanceVariable - self withNodeUnderCursorDo: [ :nodeUnderCursor | - nodeUnderCursor isTemp ifTrue: [ - TemporaryToInstanceVariableApplier on: self for: nodeUnderCursor name :: value - ] ifFalse: [ morph flash ]. - ] ifAbsent: [ morph flash ].! ! -!SmalltalkEditor methodsFor: 'temp to inst var' stamp: 'EB 5/17/2019 13:21:21'! - temporaryToInstanceVariable: aKeyboardEvent - self temporaryToInstanceVariable. - ^true.! ! -!SmalltalkEditor methodsFor: 'temp to inst var' stamp: 'EB 5/17/2019 12:53:43'! - withNodeUnderCursorDo: aDoBlock ifAbsent: anAbsentBlock - self - withMethodNodeAndClassDo: [ :currentMethodNode :currentClass | - currentMethodNode withParseNodeIncluding: self startIndex - do: aDoBlock - ifAbsent: anAbsentBlock. - ] ifErrorsParsing: [ :arg1 | anAbsentBlock value ].! ! -!TemporaryToInstanceVariable methodsFor: 'initialization' stamp: 'EB 5/15/2019 22:52:40'! - initializeNamed: aTemporaryVariableName fromMethod: aMethodNode - variable _ aTemporaryVariableName. - method _ aMethodNode.! ! -!TemporaryToInstanceVariable methodsFor: 'applying' stamp: 'EB 5/16/2019 00:09:59'! - addInstanceVariable - AddInstanceVariable named: variable to: method methodClass :: apply.! ! -!TemporaryToInstanceVariable methodsFor: 'applying' stamp: 'EB 5/17/2019 13:08:04'! - apply - | newSourceCode | - newSourceCode _ self removeTemporary. - self addInstanceVariable. - ^newSourceCode.! ! -!TemporaryToInstanceVariable methodsFor: 'applying' stamp: 'EB 5/17/2019 13:07:44'! - removeTemporary - | temporaryVariablePositions newSourceCode variableDeclarationPosition | - temporaryVariablePositions _ method positionsForTemporaryVariable: variable ifAbsent: []. - variableDeclarationPosition _ {temporaryVariablePositions first}. - newSourceCode _ method sourceText copyReplacing: variableDeclarationPosition with: ''. - method methodClass compile: newSourceCode. - ^newSourceCode. - ! ! -!TemporaryToInstanceVariable class methodsFor: 'instance creation' stamp: 'EB 5/17/2019 01:24:00'! - named: aTemporaryVariableName fromMethod: aMethodNode - | methodClass | - methodClass _ aMethodNode methodClass. - - self assert: aMethodNode hasTemporaryNamed: aTemporaryVariableName. - self assertNoOtherMethodIn: methodClass orSubclassesDefinesTemporaryNamed: aTemporaryVariableName. - self assertSubclassesOf: methodClass haventGotInstanceVariableNamed: aTemporaryVariableName. - - ^self new initializeNamed: aTemporaryVariableName fromMethod: aMethodNode.! ! -!TemporaryToInstanceVariable class methodsFor: 'error descriptions' stamp: 'EB 5/16/2019 00:17:51'! - inexistentTemporaryErrorDescription - ^'The temporary variable does not exist.'! ! -!TemporaryToInstanceVariable class methodsFor: 'error descriptions' stamp: 'EB 5/16/2019 02:43:50'! - temporaryExistsAsInstVarInSubclassesErrorDescription - ^'The temporary variable exists as an instance variable in a subclass.'! ! -!TemporaryToInstanceVariable class methodsFor: 'error descriptions' stamp: 'EB 5/16/2019 00:42:42'! - temporaryExistsInOtherMethodsErrorDescription - ^'Temporary variable exists in other methods; remove those first.'! ! -!TemporaryToInstanceVariable class methodsFor: 'assertions' stamp: 'EB 5/17/2019 13:28:16'! - assert: aMethodNode hasTemporaryNamed: aTemporaryVariableName - aMethodNode hasLocalNamed: aTemporaryVariableName :: ifFalse: [ - self refactoringError: self inexistentTemporaryErrorDescription. - ].! ! -!TemporaryToInstanceVariable class methodsFor: 'assertions' stamp: 'EB 5/17/2019 13:28:45'! - assertNoOtherMethodIn: aClass orSubclassesDefinesTemporaryNamed: aTemporaryVariableName - | methodsDefiningTemporaryInHierarchy | - methodsDefiningTemporaryInHierarchy := OrderedCollection new. - aClass withAllSubclassesDo: [ :subclass | - methodsDefiningTemporaryInHierarchy addAll: (subclass methodsWithArgumentOrTemporaryNamed: aTemporaryVariableName) - ]. - - methodsDefiningTemporaryInHierarchy size > 1 ifTrue: [ - self refactoringError: self temporaryExistsInOtherMethodsErrorDescription. - ].! ! -!TemporaryToInstanceVariable class methodsFor: 'assertions' stamp: 'EB 5/17/2019 13:29:19'! - assertSubclassesOf: aClass haventGotInstanceVariableNamed: anInstanceVariableName - aClass allSubclassesDo: [ :subclass | - subclass instVarNames includes: anInstanceVariableName :: ifTrue: [ - self refactoringError: self temporaryExistsAsInstVarInSubclassesErrorDescription. - ]. - ].! ! -!TemporaryToInstanceVariableApplier methodsFor: 'initialization' stamp: 'EB 5/17/2019 00:59:52'! - initializeOn: aSmalltalkEditor for: aTemporaryVariableName - smalltalkEditor := aSmalltalkEditor. - classToRefactor := smalltalkEditor codeProvider selectedClassOrMetaClass. - methodNode := classToRefactor methodNodeFor: smalltalkEditor actualContents string. - variableName := aTemporaryVariableName - ! ! -!TemporaryToInstanceVariableApplier methodsFor: 'refactoring - creation' stamp: 'EB 5/17/2019 00:58:32'! - createRefactoring - ^TemporaryToInstanceVariable named: variableName fromMethod: methodNode.! ! -!TemporaryToInstanceVariableApplier methodsFor: 'refactoring - parameters request' stamp: 'EB 5/17/2019 01:01:08'! - requestRefactoringParameters - ! ! -!TemporaryToInstanceVariableApplier methodsFor: 'refactoring - changes' stamp: 'EB 5/17/2019 13:08:22'! - showChanges - smalltalkEditor actualContents: changes. - ! ! -!TemporaryToInstanceVariableApplier class methodsFor: 'as yet unclassified' stamp: 'EB 5/17/2019 00:59:39'! - on: aSmalltalkEditor for: aTemporaryVariableName - - ^self new initializeOn: aSmalltalkEditor for: aTemporaryVariableName! ! -!RefactoringMenues class methodsFor: 'editor menus' stamp: 'EB 5/17/2019 13:32:48' prior: 50442430! -smalltalkEditorMenuOptions - - ^`{ - { - #itemGroup -> 35. - #itemOrder -> 10. - #label -> 'Rename... (R)'. - #selector -> #contextualRename. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 10. - #label -> 'Temporary to Instance Variable (P)'. - #selector -> #temporaryToInstanceVariable. - #icon -> #saveAsIcon - } asDictionary. - - }`! ! -!RefactoringMenues class methodsFor: 'shortcuts' stamp: 'EB 5/17/2019 13:21:27' prior: 50442539! - smalltalkEditorCmdShortcutsSpec - - ^#( - #( $R #contextualRename: 'Renames what is under cursor') - #( $P #temporaryToInstanceVariable: 'Extracts temporary variable to instance variable')) -! ! - -SmalltalkEditor removeSelector: #withNodeUnderCursorInside:do:ifAbsent:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3751-TemporaryToInstanceVariable-EricBrandwein-2019May03-18h48m-EB.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3751] on 19 May 2019 at 5:39:14 pm'! -!SmalltalkEditor methodsFor: 'temp to inst var' stamp: 'HAW 5/19/2019 17:27:10' prior: 50459233! - temporaryToInstanceVariable - - self - withNodeUnderCursorDo: [ :nodeUnderCursor | - nodeUnderCursor isTemp - ifTrue: [ TemporaryToInstanceVariableApplier on: self for: nodeUnderCursor name :: value ] - ifFalse: [ morph flash ]] - ifAbsent: [ morph flash ].! ! -!SmalltalkEditor methodsFor: 'temp to inst var' stamp: 'HAW 5/19/2019 17:38:26' prior: 50459244! - temporaryToInstanceVariable: aKeyboardEvent - - self temporaryToInstanceVariable. - - ^true.! ! -!SmalltalkEditor methodsFor: 'temp to inst var' stamp: 'HAW 5/19/2019 17:27:59' prior: 50459250! - withNodeUnderCursorDo: aDoBlock ifAbsent: anAbsentBlock - - self - withMethodNodeAndClassDo: [ :currentMethodNode :currentClass | - currentMethodNode - withParseNodeIncluding: self startIndex - do: aDoBlock - ifAbsent: anAbsentBlock ] - ifErrorsParsing: [ :arg1 | anAbsentBlock value ].! ! -!TemporaryToInstanceVariable methodsFor: 'applying' stamp: 'HAW 5/19/2019 17:26:03' prior: 50459269! - addInstanceVariable - - AddInstanceVariable named: variable to: method methodClass :: apply.! ! -!TemporaryToInstanceVariable methodsFor: 'applying' stamp: 'HAW 5/19/2019 17:25:59' prior: 50459275! - apply - - | newSourceCode | - - newSourceCode _ self removeTemporary. - self addInstanceVariable. - - ^newSourceCode.! ! -!TemporaryToInstanceVariable methodsFor: 'applying' stamp: 'HAW 5/19/2019 17:26:16' prior: 50459282! - removeTemporary - - | temporaryVariablePositions newSourceCode variableDeclarationPosition | - - temporaryVariablePositions _ method positionsForTemporaryVariable: variable ifAbsent: []. - variableDeclarationPosition _ {temporaryVariablePositions first}. - newSourceCode _ method sourceText copyReplacing: variableDeclarationPosition with: ''. - method methodClass compile: newSourceCode. - - ^newSourceCode. - ! ! -!TemporaryToInstanceVariable class methodsFor: 'instance creation' stamp: 'HAW 5/19/2019 17:23:35' prior: 50459298! - named: aTemporaryVariableName fromMethod: aMethodNode - - | methodClass | - - methodClass _ aMethodNode methodClass. - - self assert: aMethodNode hasTemporaryNamed: aTemporaryVariableName. - self assertNoOtherMethodIn: methodClass orSubclassesDefinesTemporaryNamed: aTemporaryVariableName. - self assertSubclassesOf: methodClass haventGotInstanceVariableNamed: aTemporaryVariableName. - - ^self new initializeNamed: aTemporaryVariableName fromMethod: aMethodNode.! ! -!TemporaryToInstanceVariable class methodsFor: 'error descriptions' stamp: 'HAW 5/19/2019 17:23:40' prior: 50459316! - inexistentTemporaryErrorDescription - - ^'The temporary variable does not exist.'! ! -!TemporaryToInstanceVariable class methodsFor: 'error descriptions' stamp: 'HAW 5/19/2019 17:23:44' prior: 50459322! - temporaryExistsAsInstVarInSubclassesErrorDescription - - ^'The temporary variable exists as an instance variable in a subclass.'! ! -!TemporaryToInstanceVariable class methodsFor: 'error descriptions' stamp: 'HAW 5/19/2019 17:23:47' prior: 50459330! - temporaryExistsInOtherMethodsErrorDescription - - ^'Temporary variable exists in other methods; remove those first.'! ! -!TemporaryToInstanceVariable class methodsFor: 'assertions' stamp: 'HAW 5/19/2019 17:23:56' prior: 50459337! - assert: aMethodNode hasTemporaryNamed: aTemporaryVariableName - - aMethodNode hasLocalNamed: aTemporaryVariableName :: ifFalse: [ - self refactoringError: self inexistentTemporaryErrorDescription ].! ! -!TemporaryToInstanceVariable class methodsFor: 'assertions' stamp: 'HAW 5/19/2019 17:24:11' prior: 50459347! - assertNoOtherMethodIn: aClass orSubclassesDefinesTemporaryNamed: aTemporaryVariableName - - | methodsDefiningTemporaryInHierarchy | - - methodsDefiningTemporaryInHierarchy := OrderedCollection new. - aClass withAllSubclassesDo: [ :subclass | - methodsDefiningTemporaryInHierarchy addAll: (subclass methodsWithArgumentOrTemporaryNamed: aTemporaryVariableName) ]. - - methodsDefiningTemporaryInHierarchy size > 1 ifTrue: [ - self refactoringError: self temporaryExistsInOtherMethodsErrorDescription ].! ! -!TemporaryToInstanceVariable class methodsFor: 'assertions' stamp: 'HAW 5/19/2019 17:24:43' prior: 50459366! - assertSubclassesOf: aClass haventGotInstanceVariableNamed: anInstanceVariableName - - aClass allSubclassesDo: [ :subclass | - subclass instVarNames includes: anInstanceVariableName :: ifTrue: [ - self refactoringError: self temporaryExistsAsInstVarInSubclassesErrorDescription ]].! ! -!TemporaryToInstanceVariableApplier methodsFor: 'initialization' stamp: 'HAW 5/19/2019 17:28:47' prior: 50459379! - initializeOn: aSmalltalkEditor for: aTemporaryVariableName - - smalltalkEditor := aSmalltalkEditor. - classToRefactor := smalltalkEditor codeProvider selectedClassOrMetaClass. - methodNode := classToRefactor methodNodeFor: smalltalkEditor actualContents string. - variableName := aTemporaryVariableName - ! ! -!TemporaryToInstanceVariableApplier methodsFor: 'refactoring - creation' stamp: 'HAW 5/19/2019 17:26:37' prior: 50459392! - createRefactoring - - ^TemporaryToInstanceVariable named: variableName fromMethod: methodNode.! ! -!TemporaryToInstanceVariableApplier methodsFor: 'refactoring - changes' stamp: 'HAW 5/19/2019 17:29:06' prior: 50459404! - showChanges - - smalltalkEditor actualContents: changes. - ! ! -!RefactoringMenues class methodsFor: 'editor menus' stamp: 'HAW 5/19/2019 17:37:43' prior: 50459417! - smalltalkEditorMenuOptions - - ^`{ - { - #itemGroup -> 35. - #itemOrder -> 10. - #label -> 'Rename... (R)'. - #selector -> #contextualRename. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 10. - #label -> 'Temporary to Instance Variable (O)'. - #selector -> #temporaryToInstanceVariable. - #icon -> #saveAsIcon - } asDictionary. - - }`! ! -!RefactoringMenues class methodsFor: 'shortcuts' stamp: 'HAW 5/19/2019 17:38:03' prior: 50459434! - smalltalkEditorCmdShortcutsSpec - - ^#( - #( $R #contextualRename: 'Renames what is under cursor') - #( $O #temporaryToInstanceVariable: 'Extracts temporary variable to instance variable')) -! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3752-TemporaryToInstanceVariableFormattingChanges-HernanWilkinson-2019May19-17h23m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3741] on 12 May 2019 at 3:41:55 pm'! - -"Change Set: 3742-CuisCore-AuthorName-2019May11-16h02m -Date: 12 May 2019 -Author: Nahuel Garbezza - -Allow to delete words using ctrl/alt+backspace"! -!Editor methodsFor: 'typing/selecting keys' stamp: 'RNG 5/11/2019 16:34:48' prior: 16836665! - backspace: aKeyboardEvent - "Backspace over the last character." - "This is a user command, and generates undo" - - | startIndex | - (aKeyboardEvent rawMacOptionKeyPressed or: [ aKeyboardEvent controlKeyPressed ]) - ifTrue: [ ^ self backWord: aKeyboardEvent ]. - aKeyboardEvent shiftPressed - ifTrue: [ ^ self forwardDelete: aKeyboardEvent ]. - startIndex _ self markIndex + (self hasSelection ifTrue: [1] ifFalse: [0]). - startIndex _ 1 max: startIndex - 1. - self backTo: startIndex. - ^ false! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3753-backwardDelete-NahuelGarbezza-2019May11-16h02m-RNG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3726] on 7 May 2019 at 9:27:10 pm'! -!SystemDictionary methodsFor: 'ui' stamp: 'pb 5/7/2019 21:26:55'! - systemCategoryFromUserWithPrompt: aString - "Prompt the user to select an existing system category (i.e. the ones that appear in the top left pane in the Browser window)" - | allCats menuIndex | - allCats := self organization categories sorted. - menuIndex := (PopUpMenu labelArray: allCats) startUpWithCaption: aString. - ^ menuIndex = 0 ifTrue: [nil] ifFalse: [allCats at: menuIndex]! ! -!Browser methodsFor: 'system category functions' stamp: 'pb 5/7/2019 21:21:40'! - moveAllToOtherSystemCategory - "If a class category is selected, prompt user for category to move to, - create a Confirmer so the user can verify that all the classes in current category - should be moved to the selected category." - | newSystemCategory | - selectedSystemCategory ifNil: [ ^ self ]. - newSystemCategory _ Smalltalk systemCategoryFromUserWithPrompt: 'Move classes to System Category...'. - (newSystemCategory notNil and: [ - self classList size > 0 and: [ self confirm: 'Are you sure you want to -move classes from ' , selectedSystemCategory , ' -to ' , newSystemCategory , '?' ]]) ifTrue: [ - "Safer this way (#classList will be a collection of strings with spaces and who knows what in the future. So let's just get the classes we need directly)" - (SystemOrganization classesAt: selectedSystemCategory) do: [ :eaClass | - eaClass category: newSystemCategory ]. - self changed: #systemCategoryList ].! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'pb 5/7/2019 19:34:03' prior: 50445934! - systemCategoryMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'find class... (f)'. - #selector -> #findClass. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'recent classes... (r)'. - #object -> #model. - #selector -> #recent. - #icon -> #clockIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'browse all (B)'. - #selector -> #browseAllClasses. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'browse (b)'. - #selector -> #openSystemCategoryBrowser. - #icon -> #packageIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'fileOut (o)'. - #object -> #model. - #selector -> #fileOutSystemCategory. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'reorganize'. - #object -> #model. - #selector -> #editSystemCategories. - #icon -> #sendReceiveIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'alphabetize (A)'. - #object -> #model. - #selector -> #alphabetizeSystemCategories. - #icon -> #fontXGenericIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'update (u)'. - #object -> #model. - #selector -> #updateSystemCategories. - #icon -> #updateIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 20. - #label -> 'add item... (a)'. - #object -> #model. - #selector -> #addSystemCategory. - #icon -> #newIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'rename... (R)'. - #object -> #model. - #selector -> #renameSystemCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 35. - #label -> 'move to... (m)'. - #object -> #model. - #selector -> #moveAllToOtherSystemCategory. - #icon -> #saveAsIcon. - #balloonText -> 'Move all classes in this category to another category' - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 40. - #label -> 'remove (x)'. - #object -> #model. - #selector -> #removeSystemCategory. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'move to top'. - #object -> #model. - #selector -> #moveSystemCategoryTop. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 20. - #label -> 'move up'. - #object -> #model. - #selector -> #moveSystemCategoryUp. - #icon -> #goUpIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 30. - #label -> 'move down'. - #object -> #model. - #selector -> #moveSystemCategoryDown. - #icon -> #goDownIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 40. - #label -> 'move to bottom'. - #object -> #model. - #selector -> #moveSystemCategoryBottom. - #icon -> #goBottomIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 10. - #label -> 'run tests (t)'. - #object -> #model. - #selector -> #runSystemCategoryTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - }`. - ! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3754-SystemCategoryMoveTo-PhilBellalouna-2019May07-19h31m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3751] on 19 May 2019 at 6:28:54 pm'! -!TextModelMorph methodsFor: 'drawing' stamp: 'jmv 5/19/2019 17:45:47' prior: 50454303! - drawOn: aCanvas - "Include a thin red inset border for unaccepted edits, or, if the unaccepted edits are known to conflict with a change made somewhere else to the same method (typically), put a thick red frame" - | bw bc | - self flag: #todo. - "Integrate this method with the Theme system. --cbr" - super drawOn: aCanvas. - bw _ Preferences focusIndicatorWidth. - bc _ nil. - self wantsFrameAdornments ifTrue: [ - model refusesToAccept - ifTrue: [ "Put up feedback showing that code cannot be submitted in this state" - bc _ Color tan ] - ifFalse: [ - self textMorph hasEditingConflicts - ifTrue: [ - bw _ 3. - bc _ Color red ] - ifFalse: [ - self textMorph hasUnacceptedEdits ifTrue: [ bc _ Color red ]]]]. - (drawKeyboardFocusIndicator and: [ self textMorph hasKeyboardFocus ]) - ifTrue: [ bc ifNil: [ bc _ Theme current focusIndicator ]] - ifFalse: [ - bc ifNotNil: [ - bc _ bc - alphaMixed: 0.4 - with: Color white ]]. - bc ifNotNil: [ - aCanvas - frameRectangle: self focusIndicatorRectangle - borderWidth: bw - color: bc ]. - model actualContents isEmpty ifTrue: [ - self - valueOfProperty: #emptyTextDisplayMessage - ifPresentDo: [ :msg | - aCanvas - drawString: msg - at: self xtraBorder @ self xtraBorder - font: nil - color: Theme current textEmptyDisplayMessage ]].! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3755-RepositionEmptyTextMessage-JuanVuletich-2019May19-18h28m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3754] on 20 May 2019 at 9:27:06 am'! -!GeometryTransformation methodsFor: 'converting coordinates' stamp: 'jmv 5/20/2019 08:57:05'! - externalizeRectangle: aRectangle - ^ (self transform: aRectangle origin) corner: (self transform: aRectangle corner)! ! -!Rectangle methodsFor: 'truncation and round off' stamp: 'jmv 5/20/2019 09:03:53' prior: 16898920! - rounded - "Answer a Rectangle whose origin and corner are rounded." - - ^Rectangle origin: origin rounded corner: self corner rounded! ! -!BitBltCanvas methodsFor: 'drawing-ovals' stamp: 'jmv 5/20/2019 09:22:30' prior: 16786642! - ellipseCenterX: mcx y: mcy rx: mrx ry: mry borderWidth: mbw borderColor: mbc fillColor: morphFillColor - - | displayRectangle doBorder doFill | - doBorder _ mbw > 0 and: [ mbc isTransparent not]. - doFill _ morphFillColor isTransparent not. - doBorder | doFill ifTrue: [ - displayRectangle _ (currentTransformation externalizeRectangle: (Rectangle center: mcx@mcy extent: mrx@mry * 2)) rounded. - "draw the border of the oval" - doBorder ifTrue: [ - self setPaintColor: mbc. - port frameOval: displayRectangle borderWidth: mbw]. - "fill the inside" - doFill ifTrue: [ - self setPaintColor: morphFillColor. - port fillOval: (displayRectangle insetBy: mbw) ]]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 5/20/2019 09:06:52' prior: 16786715! - frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor - | rect bw | - - r area = 0 ifTrue: [ ^self ]. - rect _ (currentTransformation externalizeRectangle: r) rounded. - bw _ currentTransformation externalizeScalar: borderWidth. - - "draw the border of the rectangle" - borderColor isTransparent ifFalse: [ - self setPaintColor: borderColor. - port frameRect: rect borderWidth: bw ]. - - "fill the inside" - fillColor isTransparent ifFalse: [ - self setPaintColor: fillColor. - port fillRect: (rect insetBy: bw) ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 5/20/2019 09:23:54' prior: 16786735! - frameRectangle: r borderWidth: borderWidth color: borderColor - " - Display getCanvas - frameRectangle: (10@10 extent: 300@200) - borderWidth: 20 - color: Color red. - Display forceToScreen - " - | rect bw | - (borderWidth > 0 and: [ borderColor isTransparent not ]) ifTrue: [ - rect _ (currentTransformation externalizeRectangle: r) rounded. - bw _ currentTransformation externalizeScalar: borderWidth. - self setPaintColor: borderColor. - port - frameRect: rect - borderWidth: bw ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 5/20/2019 09:24:39' prior: 16786753! - frameRectangle: r color: aColor borderWidth: borderWidth borderStyleSymbol: aSymbol - " - Display getCanvas fillRectangle: (10@10 extent: 300@200) color: Color white. Display forceToScreen. - Display getCanvas - frameRectangle: (10@10 extent: 300@200) - color: Color green - borderWidth: 10 - borderStyleSymbol: #raised. - Display forceToScreen. - " - - | displayRectangle bw | - bw _ (currentTransformation externalizeScalar: borderWidth) rounded. - aSymbol == #raised ifTrue: [ - displayRectangle _ (currentTransformation externalizeRectangle: r) rounded. - ^ self - frameRectangle: displayRectangle - borderWidth: bw - topLeftColor: aColor quiteWhiter - bottomRightColor: aColor quiteBlacker ]. - - aSymbol == #inset ifTrue: [ - displayRectangle _ (currentTransformation externalizeRectangle: r) rounded. - ^ self - frameRectangle: displayRectangle - borderWidth: bw - topLeftColor: aColor quiteBlacker - bottomRightColor: aColor quiteWhiter ]. - - "Unrecognized border style. Draw some border..." - self frameRectangle: r borderWidth: bw color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 5/20/2019 09:25:08' prior: 50388640! - reverseRectangleBorder: r borderWidth: borderWidth - " - Display getCanvas - reverseRectangleBorder: (10@10 extent: 300@200) - borderWidth: 20. - Display forceToScreen - " - | rect | - rect _ (currentTransformation externalizeRectangle: r) rounded. - port - sourceForm: nil; - fillColor: `Color gray`; - combinationRule: Form reverse; - frameRect: rect borderWidth: borderWidth! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 5/20/2019 09:23:29' prior: 50385967! - fillRectangle: aRectangle tilingWith: aForm sourceRect: patternBox rule: aCombinationRule - - | displayRectangle additionalOffset clippedPort targetTopLeft clipOffset ex - targetBox savedMap top left | - - ex _ patternBox extent. - ex x = 0 ifTrue: [ ^self ]. - ex y = 0 ifTrue: [ ^self ]. - displayRectangle _ (currentTransformation externalizeRectangle: aRectangle) rounded. - - "this is a bit of a kludge to get the form to be aligned where I *think* it should be. - something better is needed, but not now" - - additionalOffset _ `0@0`. - clippedPort _ port clippedBy: displayRectangle. - targetTopLeft _ clippedPort clipRect topLeft truncateTo: ex. - clipOffset _ displayRectangle topLeft - targetTopLeft. - additionalOffset _ (clipOffset \\ ex) - ex. - - "do it iteratively" - targetBox _ clippedPort clipRect. - savedMap _ clippedPort colorMap. - clippedPort sourceForm: aForm; - fillColor: nil; - combinationRule: aCombinationRule; - sourceRect: patternBox; - colorMap: (aForm colormapIfNeededFor: clippedPort destForm). - top _ (targetBox top truncateTo: patternBox height) + additionalOffset y. - left _ (targetBox left truncateTo: patternBox width) + additionalOffset x. - - left to: (targetBox right - 1) by: patternBox width do: [:x | - top to: (targetBox bottom - 1) by: patternBox height do: [:y | - clippedPort destOrigin: x@y; copyBits]]. - clippedPort colorMap: savedMap! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3756-BitBltCanvas-roundRectangles-JuanVuletich-2019May20-09h20m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3754] on 20 May 2019 at 9:50:16 am'! -!AbstractFont methodsFor: 'accessing' stamp: 'jmv 5/19/2019 18:42:54'! - leftOffsetAt: aCharacter - ^ 0! ! -!AbstractFont methodsFor: 'accessing' stamp: 'jmv 5/20/2019 09:46:22'! - rightOffsetAt: aCharacter - ^ 0! ! -!CharacterScanner methodsFor: 'scanning' stamp: 'jmv 5/20/2019 09:49:18' prior: 16802018! - scanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernValue - "Primitive. This is the inner loop of text display--but see - scanCharactersFrom: to:rightX: which would get the string, - stopConditions and displaying from the instance. March through source - String from startIndex to stopIndex. If any character is flagged with a - non-nil entry in stops, then return the corresponding value. Determine - width of each character from xTable, indexed by map. - If dextX would exceed rightX, then return stops at: 258. - Advance destX by the width of the character. If stopIndex has been - reached, then return stops at: 257. Optional. - See Object documentation whatIsAPrimitive." - | nextDestX char rightOffset | - - lastIndex _ startIndex. - [ lastIndex <= stopIndex ] - whileTrue: [ - char _ sourceString at: lastIndex. - "stops are only defined for the first 256 characters. - If we (ever) handle Character like objects beyond those in ISO-8859-15, - thenf #iso8859s15Code shound answer nil!!" - char iso8859s15Code ifNotNil: [ :code | - (stops at: code + 1) ifNotNil: [ :stop | ^stop ]]. - nextDestX _ destX + (font widthOf: char). - rightOffset _ font rightOffsetAt: char. - nextDestX + rightOffset > rightX ifTrue: [ - ^stops at: CharacterScanner crossedXCode ]. - destX _ nextDestX. - lastIndex _ lastIndex + 1 ]. - lastIndex _ stopIndex. - ^ stops at: CharacterScanner endOfRunCode! ! -!CompositionScanner methodsFor: 'scanning' stamp: 'jmv 5/20/2019 09:35:12' prior: 50410610! - composeFrom: startIndex inRectangle: lineRectangle firstLine: firstLine leftSide: leftSide rightSide: rightSide - - "Answer an instance of TextLineInterval that represents the next line in the paragraph." - | runLength stopCondition xtraSpaceBefore spaceAfterParagraph | - - lastTabIndex _ lastIndex _ startIndex. "scanning sets last index" - destY _ lineRectangle top. - lineHeight _ baseline _ 0. "Will be increased by setFont" - self setFont. - self setStopConditions. - - "Set up margins" - leftMargin _ lineRectangle left. - leftSide ifTrue: [ - leftMargin _ leftMargin - (font leftOffsetAt: (text string at: lastIndex)) ]. - rightMargin _ lineRectangle right. - xtraSpaceBefore _ 0. - spaceAfterParagraph _ 0. - paragraphStyle ifNotNil: [ - leftSide ifTrue: [ - leftMargin _ leftMargin + - ((firstLine and: [ paragraphStyle isListStyle not ]) - ifTrue: [ paragraphStyle firstIndent ] - ifFalse: [ paragraphStyle restIndent ])]. - rightSide ifTrue: [ - rightMargin _ rightMargin - paragraphStyle rightIndent]. - firstLine ifTrue: [ xtraSpaceBefore _ paragraphStyle spaceBefore ]. - spaceAfterParagraph _ paragraphStyle spaceAfter ]. - lastTabX _ destX _ spaceX _ leftMargin. - - runLength _ text runLengthFor: startIndex. - runStopIndex _ lastIndex + runLength - 1. - line _ (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0) - rectangle: lineRectangle. - line isFirstLine: firstLine. - spaceCount _ 0. - lastLineBreakingSpace _ 0. - leftMargin _ destX. - line leftMargin: leftMargin. - - self placeEmbeddedObject. - [ - stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex - in: text string rightX: rightMargin stopConditions: stopConditions - kern: font baseKern. - "See setStopConditions for stopping conditions for composing." - (self perform: stopCondition) ifTrue: [ - ^ line - lineHeight: lineHeight + xtraSpaceBefore + - (stopCondition == #doNewLine ifTrue: [spaceAfterParagraph] ifFalse: [0]) - baseline: baseline + xtraSpaceBefore ] - ] repeat! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3757-honorLeftAndRightOffsetOfGlyphs-JuanVuletich-2019May20-09h27m-jmv.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3757] on 21 May 2019 at 12:10:25 pm'! -!Morph methodsFor: 'meta-actions' stamp: 'KenD 5/8/2019 20:51:33' prior: 16876423! - potentialEmbeddingTargets - "Return the potential targets for embedding the receiver" - | myRect myWorld | - owner ifNil:[^#()]. - myWorld := owner world ifNil:[^#()]. - myRect := self morphBoundsInWorld. - ^myWorld submorphs select: [ :m | - m isReallyVisible - and: [ m isLocked not - and: [(m morphBoundsInWorld intersects: myRect) - and: [(m ~= self) - and: [(m isKindOf: HaloMorph) not]]]] - ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3758-potentialEmbeddingTargets-KenDickey-2019May21-12h09m-KenD.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3754] on 19 May 2019 at 8:10:56 pm'! - -"Change Set: 3755-CuisCore-AuthorName-2019May19-19h59m -Date: 19 May 2019 -Author: Nahuel Garbezza - -Delete words forward using Ctrl+Del on Win/Linux and Option-Del in Mac"! -!TextEditor methodsFor: 'private' stamp: 'RNG 5/19/2019 20:02:41'! - shouldDeleteAWordForward: aKeyboardEvent - - ^ aKeyboardEvent isDelete and: [ - aKeyboardEvent rawMacOptionKeyPressed or: [ - aKeyboardEvent controlKeyPressed ] ]! ! -!TextEditor methodsFor: 'private' stamp: 'RNG 5/19/2019 20:09:09'! - shouldHandleUsingCmdShortcuts: aKeyboardEvent - ^ (aKeyboardEvent keyValue between: 32 and: 126) and: [ aKeyboardEvent commandAltKeyPressed ]! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'RNG 5/19/2019 20:01:06'! - isDelete - - ^ keyValue = 127! ! -!TextEditor methodsFor: 'typing support' stamp: 'RNG 5/19/2019 20:09:09' prior: 16932450! - dispatchOn: aKeyboardEvent - "Carry out the action associated with this character, if any." - - | asciiValue c | - self clearParens. - asciiValue _ aKeyboardEvent keyValue. - "Control keys are handled by #shortcuts even if they have any modifiers" - (self shouldHandleUsingCmdShortcuts: aKeyboardEvent) ifTrue: [ - ^self perform: (self cmdShortcuts at: asciiValue + 1) with: aKeyboardEvent ]. - - c _ aKeyboardEvent keyCharacter. - (')]}' includes: c) - ifTrue: [ self blinkPrevParen: c ]. - - ^ self perform: (self shortcuts at: asciiValue + 1) with: aKeyboardEvent! ! -!TextEditor methodsFor: 'typing/selecting keys' stamp: 'RNG 5/19/2019 20:02:24' prior: 50367289! - forwardDelete: aKeyboardEvent - "Delete forward over the next character." - "This is a user command, and generates undo" - - | startIndex stopIndex | - - "If there was a selection" - self hasSelection ifTrue: [ - self replaceSelectionWith: self nullText. - ^ false]. - - "Exit if at end" - startIndex _ self markIndex. - startIndex > model textSize ifTrue: [ - ^ false]. - - "Null selection - do the delete forward" - stopIndex _ startIndex. - (self shouldDeleteAWordForward: aKeyboardEvent) - ifTrue: [stopIndex := (self nextWordStart: stopIndex) - 1]. - self selectFrom: startIndex to: stopIndex. - self replaceSelectionWith: self nullText. - self deselectAndPlaceCursorAt: startIndex. - ^false! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3759-forwardDelete-NahuelGarbezza-2019May19-19h59m-RNG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3740] on 10 May 2019 at 12:46:11 pm'! -!NewClassPrecondition methodsFor: 'evaluating - private' stamp: 'HAW 5/10/2019 12:24:16'! - assertNewClassNameIsNotDeclaredInUndeclared - - (undeclared includesKey: newClassName) ifTrue: [ self signalNewClassIsUndeclared]! ! -!NewClassPrecondition methodsFor: 'evaluating - private' stamp: 'HAW 5/10/2019 12:30:59'! - assertNewClassNameStartsWithRightLetter - - newClassName first isUppercase ifFalse: [ self signalNewNameMustStartWithRightLetter]! ! -!NewClassPrecondition methodsFor: 'exceptions' stamp: 'HAW 5/10/2019 12:31:44'! - signalNewNameMustStartWithRightLetter - - self refactoringError: self class newNameMustStartWithRightLetterErrorMessage.! ! -!NewClassPrecondition class methodsFor: 'error messages' stamp: 'HAW 5/10/2019 12:31:44'! - newNameMustStartWithRightLetterErrorMessage - - ^'New class name must start with an uppercase letter'! ! -!NewClassPrecondition methodsFor: 'evaluating' stamp: 'HAW 5/10/2019 12:24:16' prior: 50442556! - value - - self assertNewClassNameIsNotEmpty. - self assertNewClassNameSymbol. - self assertNewClassNameStartsWithRightLetter. - self assertNewClassNameHasNoSeparators. - self assertNewClassNameDoesNotExistInSystem. - self assertNewClassNameIsNotDeclaredInUndeclared. - -! ! - -NewClassPrecondition class removeSelector: #newNameMustStartWithUppercaseLetterErrorMessage! - -NewClassPrecondition class removeSelector: #newNameMustStartWithUppercaseLetterErrorMessage! - -NewClassPrecondition removeSelector: #assertNewClassNameIsNotUndeclaredInUndeclared! - -NewClassPrecondition removeSelector: #assertNewClassNameIsNotUndeclaredInUndeclared! - -NewClassPrecondition removeSelector: #assertNewClassNameStartsWithUppercaseLetter! - -NewClassPrecondition removeSelector: #assertNewClassNameStartsWithUppercaseLetter! - -NewClassPrecondition removeSelector: #signalNewNameMustStartWithUppercaseLetter! - -NewClassPrecondition removeSelector: #signalNewNameMustStartWithUppercaseLetter! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3760-NewClassPreconditionRefactoring-HernanWilkinson-2019May05-19h58m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3754] on 15 May 2019 at 4:46:46 pm'! -!Array methodsFor: 'converting' stamp: 'len 5/15/2019 16:43:02' prior: 50428700! - elementsExchangeIdentityWith: otherArray - "This primitive performs a bulk mutation, causing all pointers to the elements of the - receiver 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. - - Warning. This is a dangerous operation and it could lead to a crash if some object in receiver or argument is receiver of a method currently in execution. See #anyReceiverInStackIn: See senders for examples." - - - ec == #'bad receiver' ifTrue: - [^self error: 'receiver must be of class Array']. - ec == #'bad argument' ifTrue: - [^self error: (otherArray class == Array - ifTrue: ['arg must be of class Array'] - ifFalse: ['receiver and argument must have the same size'])]. - ec == #'inappropriate operation' ifTrue: - [^self error: 'can''t become immediates such as SmallIntegers or Characters']. - ec == #'no modification' ifTrue: - [^self error: 'can''t become immutable objects']. - ec == #'object is pinned' ifTrue: - [^self error: 'can''t become pinned objects']. - ec == #'insufficient object memory' ifTrue: - [| maxRequired | - "In Spur, two-way become may involve making each pair of objects into a forwarder into a copy of the other. - So if become fails with #'insufficient object memory', garbage collect, and if necessary, grow memory." - maxRequired := (self sum: [:obj | obj class byteSizeOfInstanceOfSize: obj basicSize] ifEmpty: [0]) - + (otherArray sum: [:obj | obj class byteSizeOfInstanceOfSize: obj basicSize] ifEmpty: [0]). - (Smalltalk garbageCollectMost < maxRequired - and: [Smalltalk garbageCollect < maxRequired]) ifTrue: - [Smalltalk growMemoryByAtLeast: maxRequired]. - ^self elementsExchangeIdentityWith: otherArray]. - self primitiveFailed! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'len 5/15/2019 16:43:26' prior: 50365882! - macroBenchmark1 "Smalltalk macroBenchmark1" - "Decompiles and prettyPrints the source for every method in the system (or less depending on the *FILTER*, and then compiles that source and verifies that it generates (and decompiles to) identical code. This currently fails in a number of places because some different patterns (esp involving conditionals where the first branch returns) decompile the same. Because it never installs the new method, it should not cause any flusing of the method cache." - | methodNode oldMethod newMethod badOnes oldCodeString n classes | - classes _ Smalltalk allClasses select: [:c | c name < 'B3']. - badOnes _ OrderedCollection new. -'Decompiling and recompiling...' -displayProgressAt: Sensor mousePoint -from: 0 to: (classes sum: [:c | c selectors size] ifEmpty: [0]) -during: [:barBlock | n _ 0. - classes do: - [:cls | - "Transcript cr; show: cls name." - cls selectors do: - [:selector | barBlock value: (n _ n+1). - oldMethod _ cls compiledMethodAt: selector. - oldCodeString _ (cls decompilerClass new - decompile: selector in: cls method: oldMethod) - decompileString. - methodNode _ cls compilerClass new - compile: oldCodeString - in: cls notifying: nil ifFail: nil. - newMethod _ methodNode generate: #(0 0 0 0). - oldCodeString = (cls decompilerClass new - decompile: selector in: cls method: newMethod) - decompileString ifFalse: [badOnes add: cls name , ' ' , selector]]]. -]. - ^ badOnes size! ! - -Collection removeSelector: #detectSum:! - -Collection removeSelector: #detectSum:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3761-detectSumRemoval-LucianoEstebanNotarfrancesco-2019May15-16h43m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3761] on 23 May 2019 at 8:48:15 am'! -!Parser methodsFor: 'expression types' stamp: 'HAW 5/23/2019 08:42:06' prior: 16886009! - braceExpression - " { elements } => BraceNode." - - | elements locations loc more sourceRangeStart sourceRangeEnd | - - sourceRangeStart _ hereMark. - elements := OrderedCollection new. - locations := OrderedCollection new. - self advance. - more := hereType ~~ #rightBrace. - [more] - whileTrue: - [loc := hereMark + requestorOffset. - self expression - ifTrue: - [elements addLast: parseNode. - locations addLast: loc] - ifFalse: - [^self expected: 'Variable or expression or right brace']. - (self match: #period) - ifTrue: [more := hereType ~~ #rightBrace] - ifFalse: [more := false]]. - parseNode := BraceNode new elements: elements sourceLocations: locations. - sourceRangeEnd _ hereEnd. - - (self match: #rightBrace) ifFalse: [^self expected: 'Period or right brace']. - encoder noteSourceRange: (sourceRangeStart to: sourceRangeEnd) forNode: parseNode. - - ^true! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3762-SourceRangeBraceNode-NahuelGarvezzaHernanWilkinson-2019May23-08h40m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3763] on 23 May 2019 at 10:45:10 am'! -!CompiledMethod methodsFor: 'ometa2preload' stamp: 'jmv 5/23/2019 10:44:49' prior: 50444912! - createMethodNode - "Creates the parse tree that represents self" - | aClass source | - aClass := self methodClass. - source := self - getSourceFor: (self selector ifNil: [ self defaultSelector ]) - in: aClass. - "OMeta2 (and maybe others) could do source code transformations that mean #methodNodeFor: could fail." - ^ (aClass methodNodeFor: source) ifNil: [ self decompile ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3763-HelpOMeta2-JuanVuletich-2019May23-10h40m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3763] on 24 May 2019 at 10:05:57 am'! -!TestRunnerWindow methodsFor: 'GUI building' stamp: 'jmv 5/24/2019 10:04:35' prior: 16928625! - buildUpperControls - | refreshButton filterButton stopButton runOneButton runButton runProfiledButton row column1 column2 column3 theTestsList | - - refreshButton _ self buildRefreshButton. - filterButton _ self buildFilterButton. - stopButton _ self buildStopButton. - column1 _ LayoutMorph newColumn. - column1 doAdoptWidgetsColor. - column1 addMorphs: { refreshButton . filterButton . stopButton }. - - theTestsList _ PluggableListMorphOfMany - model: model - listGetter: #tests - primarySelectionGetter: #selectedSuite - primarySelectionSetter: #selectedSuite: - listSelectionGetter: #listSelectionAt: - listSelectionSetter: #listSelectionAt:put: - mainView: self - menuGetter: #listMenu - keystrokeAction: nil. - theTestsList autoDeselect: false. - theTestsList color: self textBackgroundColor. - column2 _ LayoutMorph newColumn. - column2 - addMorph: theTestsList proportionalHeight: 1; - addMorph: self optionalButtonRow fixedHeight: self defaultButtonPaneHeight. - - runOneButton _ self buildRunOneButton. - runButton _ self buildRunButton. - runProfiledButton := self buildRunProfiledButton. - column3 _ LayoutMorph newColumn. - column3 doAdoptWidgetsColor. - column3 addMorphs: { runOneButton . runButton . runProfiledButton }. - - row _ LayoutMorph newRow. - row - addMorph: column1 proportionalWidth: 0.1; - addMorph: column2 proportionalWidth: 0.7; - addMorph: column3 proportionalWidth: 0.2. - - ^row - -! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3764-TestRunnerButtonsLayoutFix-JuanVuletich-2019May24-10h03m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3763] on 24 May 2019 at 10:19:06 am'! -!Encoder methodsFor: 'source mapping' stamp: 'jmv 5/23/2019 09:49:51'! - rangeForNode: node ifAbsent: aBlock - - ^sourceRanges at: node ifAbsent: aBlock! ! -!MessageNode methodsFor: 'source ranges' stamp: 'jmv 5/23/2019 10:05:52'! - keywordAndParameterPositionAt: anIndex encodedWith: anEncoder ifAbsent: aBlock - - | keywordPosition parameterLastPosition | - - keywordPosition := keywordRanges at: anIndex. - parameterLastPosition := anIndex = arguments size - ifTrue: [ (anEncoder rangeForNode: self ifAbsent: aBlock) last ] - ifFalse: [ (keywordRanges at: anIndex + 1) first - 1]. - - ^keywordPosition first to: parameterLastPosition! ! -!MethodNode methodsFor: 'source mapping' stamp: 'jmv 5/23/2019 09:50:16'! - rangeForNode: node ifAbsent: aBlock - - ^encoder rangeForNode: node ifAbsent: aBlock! ! -!CompiledMethod methodsFor: 'source code ranges' stamp: 'HAW 5/24/2019 09:41:50' prior: 50452617! - messageSendsRangesOf: aSentSelector - - | methodNode ranges | - - methodNode := self methodNode. - ranges := OrderedCollection new. - - methodNode nodesDo: [ :aParseNode | - (aParseNode isMessageNamed: aSentSelector) ifTrue: [ - ranges add: (methodNode - rangeForNode: aParseNode - ifAbsent: [ self error: 'should not happen. aParseNode is part of the methodNode'])]]. - - ^ranges ! ! -!Encoder methodsFor: 'source mapping' stamp: 'jmv 5/23/2019 10:06:08' prior: 50443371! - messageSendKeywordAndParameterPositionsAt: anIndex of: aSelector ifAbsent: aBlock - - | positions | - - positions := sourceRanges keys - select: [ :aParseNode | aParseNode isMessageNamed: aSelector ] - thenCollect: [ :aMessageSendNode | aMessageSendNode keywordAndParameterPositionAt: anIndex encodedWith: self ifAbsent: aBlock]. - - ^ positions isEmpty - ifTrue: aBlock - ifFalse: [ positions ] - ! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 5/24/2019 09:36:14' prior: 50443432! - parameterDefinitionPositionFor: aParameterNode - - ^ (self rangeForNode: aParameterNode ifAbsent: [ self error: 'invalid parameter node' ]) first! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 5/24/2019 09:57:00' prior: 50419607! - selectorLastPosition - - "If #DoIt selector, returns 0 - Hernan" - - ^self selector isUnary - ifTrue: [ selectorKeywordsRanges ifNil: [ 0 ] ifNotNil: [ selectorKeywordsRanges last last ]] - ifFalse: [ - (encoder - rangeForNode: arguments last - ifAbsent: [ self error: 'Should not happen. arguments is part of the encoder' ]) first last ]! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'testing' stamp: 'jmv 5/23/2019 09:51:43' prior: 50452246! - isAtClassName: anIndex - - ^(classDefinitionNode rangeForNode: classCreationMessageNode arguments first ifAbsent: [ ^ false ]) first includes: anIndex! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'testing' stamp: 'jmv 5/23/2019 09:51:59' prior: 50452260! - isAtSuperclass: anIndex - - ^(classDefinitionNode rangeForNode: superClassNode ifAbsent: [ ^ false ]) first includes: anIndex! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'testing - private' stamp: 'jmv 5/23/2019 09:51:14' prior: 50452272! - is: anIndex atStringParameterNumber: aParameterPosition - - | parameterRange | - - parameterRange := (classDefinitionNode rangeForNode: (classCreationMessageNode arguments at: aParameterPosition) ifAbsent: [ ^ false ]) first. - - ^anIndex between: parameterRange first + 1 and: parameterRange last - 1! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'jmv 5/23/2019 10:09:52' prior: 50452884! - selectMessageNode: aMessageNodeUnderCursor in: aMethodNode - - | messageRange | - - self - withReceiverRangeOf: aMessageNodeUnderCursor - in: aMethodNode - selectorPosition: self startIndex - do: [ :receiverRange | - messageRange := aMethodNode rangeForNode: aMessageNodeUnderCursor ifAbsent: [ ^ self ]. - self selectFrom: receiverRange first to: messageRange last ] - - ! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'jmv 5/23/2019 10:10:12' prior: 50452898! - selectNodeRange: aNodeUnderCursor in: aMethodNode - - | range ranges | - - ranges := aMethodNode rangeForNode: aNodeUnderCursor ifAbsent: [ ^ self ]. - range := (aMethodNode isMultipleRanges: ranges) - ifTrue: [ ranges detect: [ :aRange | aRange includes: self startIndex ] ifNone: [ ^self ]] - ifFalse: [ ranges ]. - - self selectFrom: range first to: range last -! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'jmv 5/23/2019 10:10:22' prior: 50452921! - withReceiverRangeOf: aMessageNode in: aMethodNode selectorPosition: aSelectorPosition do: aBlock - - | receiverRange receiverRangeOrRanges messageNodeReceiver | - - "If aMessageNode receiver isNil it means that it is a cascade receiver so this imposes the question on how to inspect - a cascade message send. We could inspect the result of sending all the messages up to the cursor but the problem is - that when looking for the cascade receiver range it does not find it because it is a different node that the used in the source - ranges... we could do the trick of looking for printString in the sourceRanges keys, but that is too much - Hernan" - aMessageNode isCascade ifFalse: [ - messageNodeReceiver := aMessageNode receiver. - messageNodeReceiver isMessageNode ifTrue: [ - ^self withReceiverRangeOf: messageNodeReceiver in: aMethodNode selectorPosition: (messageNodeReceiver keywordPositionAt: 1) first do: aBlock ]. - - receiverRangeOrRanges := aMethodNode rangeForNode: messageNodeReceiver ifAbsent: [ ^ self ]. - - receiverRange := (aMethodNode isMultipleRanges: receiverRangeOrRanges) - ifTrue: [ | closestRange | - closestRange := receiverRangeOrRanges first. - receiverRangeOrRanges do: [ :aRange | (aRange last < aSelectorPosition and: [ aRange last > closestRange last ]) ifTrue: [ closestRange := aRange ]]. - closestRange ] - ifFalse: [ receiverRangeOrRanges ]. - - aBlock value: receiverRange ]! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 5/24/2019 10:14:31' prior: 50439246! - assertIsValidParameterName: aName - - | scannedNames | - - scannedNames _ [ Scanner new scanFieldNames: aName ] - on: Error - do: [ :anError | self signalInvalidParameterName: aName ]. - scannedNames size = 1 ifFalse: [ self signalInvalidParameterName: aName ]. - scannedNames first = aName ifFalse: [ self signalInvalidParameterName: aName ]. -! ! - -MethodNode removeSelector: #sourceRangeFor:! - -MethodNode removeSelector: #sourceRangeFor:! - -MessageNode removeSelector: #keywordAndParameterPositionAt:encodedWith:! - -MessageNode removeSelector: #keywordAndParameterPositionAt:encodedWith:! - -Encoder removeSelector: #sourceRangeFor:! - -Encoder removeSelector: #sourceRangeFor:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3765-missingSourceRanges-forSupportingOMeta-JuanVuletichHernanWilkinson-2019May24-09h35m-HAW.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3766] on 25 May 2019 at 9:36:48 am'! -!CompiledMethod methodsFor: 'source code ranges' stamp: 'jmv 5/23/2019 09:52:58' prior: 50460668! - messageSendsRangesOf: aSentSelector - - | methodNode ranges | - - methodNode := self methodNode. - ranges := OrderedCollection new. - - methodNode nodesDo: [ :aParseNode | - (aParseNode isMessageNamed: aSentSelector) ifTrue: [ - (methodNode rangeForNode: aParseNode ifAbsent: nil) ifNotNil: [ :range | - ranges add: range ]]]. - - ^ranges ! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3766-messageSendsRangesOf-HernanWilkinson-2019May25-09h36m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3766] on 25 May 2019 at 9:51:28 am'! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'len 2/19/2017 18:58:55' prior: 16906364! - combinations: k atATimeDo: aBlock - "Take the items in the receiver, k 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 choose: k) combinations. - - 'abcde' combinations: 3 atATimeDo: [:each | Transcript newLine; show: each printString]. - " - - | aCollection | - k = 0 ifTrue: [aBlock value: #(). ^ self]. - aCollection _ Array new: k. - self combinationsAt: 1 in: aCollection after: 0 do: aBlock! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3767-combinationsWithCero-LucianoNotarfrancesco-2019May25-09h49m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3766] on 25 May 2019 at 10:26:14 am'! -!Number methodsFor: 'mathematical functions' stamp: 'HAW 5/25/2019 10:22:42'! - raisedToNegativeInteger: negativeExponent - - | firstTry positiveExponent exponent1 exponent2 | - - positiveExponent := negativeExponent negated. - firstTry := self raisedToInteger: positiveExponent. - ^firstTry isInfinite - ifFalse: [firstTry reciprocal] - ifTrue: [ - exponent1 _ positiveExponent // 2. - exponent2 _ positiveExponent - exponent1. - (self raisedToInteger: exponent1) reciprocal * (self raisedToInteger: exponent2) reciprocal ]! ! -!Number methodsFor: 'mathematical functions' stamp: 'HAW 5/25/2019 10:24:39' prior: 50400574! - raisedTo: exponent - "Answer the receiver raised to aNumber." - - exponent isInteger ifTrue: [ - "Do the special case of integer power" - ^ self raisedToInteger: exponent]. - exponent isFraction ifTrue: [ - "Special case for fraction power by Nicolas Cellier: - If aNumber is a fraction, but result must be a Float, learn it as quickly as possible, and give quick Float answer - Allows evaluating: - (2009/2000) raisedTo: (3958333/100000) - " - ^ self raisedToFraction: exponent]. - self < 0 ifTrue: [ - ^(Complex basicReal: self imaginary: 0) raisedTo: exponent ]. - 0 = exponent ifTrue: [^ self class one]. "Special case of exponent=0" - 1 = exponent ifTrue: [^ self]. "Special case of exponent=1" - 0 = self ifTrue: [ "Special case of self = 0" - exponent < 0 - ifTrue: [^ (ZeroDivide dividend: self) signal] - ifFalse: [^ self]]. - ^ (exponent * self ln) exp "Otherwise use logarithms"! ! -!Number methodsFor: 'mathematical functions' stamp: 'HAW 5/25/2019 10:24:15' prior: 50400605! - raisedToFraction: exponent - self isZero ifTrue: [ - exponent negative ifTrue: [ - ^ (ZeroDivide dividend: 1) signal ]. - ^ self ]. - self negative ifFalse: [ - ^ (self ln * exponent) exp ]. - exponent denominator = 2 ifTrue: [ - ^ self sqrt raisedToInteger: exponent numerator ]. - (self negative and: [ exponent denominator even ]) ifTrue: [ - ^ (Complex basicReal: self imaginary: 0) raisedToFraction: exponent]. - ^ (self negated ln * exponent) exp negated! ! -!Number methodsFor: 'mathematical functions' stamp: 'HAW 5/25/2019 10:23:49' prior: 50446280! - raisedToInteger: exponent - - "The 0 raisedToInteger: 0 is an special case. In some contexts must be 1 and in others must - be handled as an indeterminate form. - I take the first context because that's the way that was previously handled. - Maybe further discussion is required on this topic." - - | bitProbe result | - - exponent negative ifTrue: [^self raisedToNegativeInteger: exponent ]. - - bitProbe := 1 bitShift: exponent highBit - 1. - result := self class one. - - [(exponent bitAnd: bitProbe) = 0 ifFalse: [result := result * self]. - bitProbe := bitProbe bitShift: -1. - bitProbe > 0 ] whileTrue: [result := result * result]. - - ^result! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3768-raisedToParameterRename-HernanWilkinson-2019May25-09h51m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3765] on 24 May 2019 at 7:25:25 pm'! -!PluggableListMorph methodsFor: 'events' stamp: 'len 5/24/2019 19:23:59'! - mouseLeave: event - super mouseLeave: event. - self listMorph highlightedRow: nil! ! -!PluggableListMorph methodsFor: 'events-processing' stamp: 'len 5/24/2019 19:10:11' prior: 16888707! - processMouseMove: aMouseMoveEvent localPosition: localEventPosition - "Reimplemented because we really want #mouseMove when a morph is dragged around" - - aMouseMoveEvent wasHandled ifTrue: [ ^self ]. "not interested" - self listMorph highlightedRow: (self rowAtLocation: localEventPosition ifNone: []). - (aMouseMoveEvent anyButtonPressed and: [ self hasMouseFocus ]) ifFalse: [ ^self ]. - aMouseMoveEvent wasHandled: true. - self mouseMove: aMouseMoveEvent localPosition: localEventPosition. - (self handlesMouseStillDown: aMouseMoveEvent) ifTrue:[ - "Step at the new location" - self startStepping: #processMouseStillDown stepTime: 1 ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3769-ListHighlightMouseOver-LucianoEstebanNotarfrancesco-2019May24-19h21m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3769] on 25 May 2019 at 4:48:20 pm'! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:34:46'! - focusIndicatorBottom - ^ self hIsScrollbarShowing - ifTrue: [ extent y - borderWidth - self scrollBarClass scrollbarThickness ] - ifFalse: [ extent y - borderWidth ]! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:31:00'! - focusIndicatorLeft - ^ borderWidth! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:34:00'! - focusIndicatorRight - ^ self vIsScrollbarShowing - ifTrue: [ extent x - borderWidth - self scrollBarClass scrollbarThickness ] - ifFalse: [ extent x - borderWidth ]! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:31:43'! - focusIndicatorTop - ^ borderWidth! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:43:21'! - viewableArea - ^ self viewableAreaTopLeft corner: self viewableAreaRight @ self viewableAreaBottom! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:30:36'! - viewableAreaBottom - ^ self focusIndicatorBottom - self xtraBorder! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:31:05'! - viewableAreaLeft - ^ self focusIndicatorLeft + self xtraBorder! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:31:23'! - viewableAreaRight - ^ self focusIndicatorRight - self xtraBorder! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:32:00'! - viewableAreaTop - ^ self focusIndicatorTop + self xtraBorder! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:40:16'! - viewableAreaTopLeft - ^ self viewableAreaLeft @ self viewableAreaTop! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:38:15' prior: 16889616! - focusIndicatorExtent - ^ self focusIndicatorRectangle extent! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:37:59' prior: 16889627! - focusIndicatorRectangle - - ^ self focusIndicatorLeft @ self focusIndicatorTop corner: self focusIndicatorRight @ self focusIndicatorBottom! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:46:16' prior: 16889651! - hScrollBarWidth - "Return the width of the horizontal scrollbar" - - ^ self focusIndicatorRight - self focusIndicatorLeft! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:42:08' prior: 16889742! - scrollerOffset - - ^ scroller morphPosition negated + self viewableAreaTopLeft! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:42:01' prior: 16889747! - scrollerOffset: newOffset - - scroller morphPosition: self viewableAreaTopLeft - newOffset! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:36:45' prior: 16889830! - viewableExtent - - ^ self viewableWidth @ self viewableHeight! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:35:29' prior: 16889835! - viewableHeight - "Viewable height. - Leave room for horizontal scrollbar if present" - - ^ self viewableAreaBottom - self viewableAreaTop ! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:35:54' prior: 16889841! - viewableWidth - "Viewable width. - Leave room for vertical scrollbar if present" - - ^ self viewableAreaRight - self viewableAreaLeft! ! -!PluggableListMorph methodsFor: 'events-processing' stamp: 'jmv 5/25/2019 16:43:26' prior: 50461014! - processMouseMove: aMouseMoveEvent localPosition: localEventPosition - "Reimplemented because we really want #mouseMove when a morph is dragged around" - - aMouseMoveEvent wasHandled ifTrue: [ ^self ]. "not interested" - self listMorph highlightedRow: ( - (self viewableArea containsPoint: localEventPosition) ifTrue: [ - self rowAtLocation: localEventPosition ifNone: []]). - (aMouseMoveEvent anyButtonPressed and: [ self hasMouseFocus ]) ifFalse: [ ^self ]. - aMouseMoveEvent wasHandled: true. - self mouseMove: aMouseMoveEvent localPosition: localEventPosition. - (self handlesMouseStillDown: aMouseMoveEvent) ifTrue:[ - "Step at the new location" - self startStepping: #processMouseStillDown stepTime: 1 ]! ! -!TextModelMorph methodsFor: 'drawing' stamp: 'jmv 5/25/2019 16:44:45' prior: 50459865! - drawOn: aCanvas - "Include a thin red inset border for unaccepted edits, or, if the unaccepted edits are known to conflict with a change made somewhere else to the same method (typically), put a thick red frame" - | bw bc | - self flag: #todo. - "Integrate this method with the Theme system. --cbr" - super drawOn: aCanvas. - bw _ Preferences focusIndicatorWidth. - bc _ nil. - self wantsFrameAdornments ifTrue: [ - model refusesToAccept - ifTrue: [ "Put up feedback showing that code cannot be submitted in this state" - bc _ Color tan ] - ifFalse: [ - self textMorph hasEditingConflicts - ifTrue: [ - bw _ 3. - bc _ Color red ] - ifFalse: [ - self textMorph hasUnacceptedEdits ifTrue: [ bc _ Color red ]]]]. - (drawKeyboardFocusIndicator and: [ self textMorph hasKeyboardFocus ]) - ifTrue: [ bc ifNil: [ bc _ Theme current focusIndicator ]] - ifFalse: [ - bc ifNotNil: [ - bc _ bc - alphaMixed: 0.4 - with: Color white ]]. - bc ifNotNil: [ - aCanvas - frameRectangle: self focusIndicatorRectangle - borderWidth: bw - color: bc ]. - model actualContents isEmpty ifTrue: [ - self - valueOfProperty: #emptyTextDisplayMessage - ifPresentDo: [ :msg | - aCanvas - drawString: msg - at: self viewableAreaTopLeft - font: nil - color: Theme current textEmptyDisplayMessage ]].! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3770-ListHighlightMouseOverTweak-JuanVuletich-2019May25-16h27m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3768] on 25 May 2019 at 1:24:40 pm'! -!SequenceableCollection methodsFor: 'private' stamp: 'sqr 5/25/2019 13:19:43'! - combinationsAt: j upTo: k in: aCollection after: m upTo: n do: aBlock - "Choose k of N items and put in aCollection. j-1 already chosen. Indexes of items are in numerical order to avoid duplication. In this slot, we are allowed to use items in self indexed by m+1 up to n. m is the index used for position j-1." - "(1 to: 6) combinations: 3 atATimeDo: [:each | Transcript cr; show: each printString]" - - m+1 to: n do: [:index | - aCollection at: j put: (self at: index). - j = k - ifTrue: [aBlock value: aCollection] - ifFalse: [self combinationsAt: j + 1 upTo: k in: aCollection after: index upTo: n do: aBlock]]! ! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'sqr 5/25/2019 13:20:59' prior: 50460883! - combinations: k atATimeDo: aBlock - "Take the items in the receiver, k 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 choose: k) combinations. - - 'abcde' combinations: 3 atATimeDo: [:each | Transcript newLine; show: each printString]. - " - - | aCollection | - k = 0 ifTrue: [aBlock value: #(). ^ self]. - aCollection _ Array new: k. - self combinationsAt: 1 upTo: k in: aCollection after: 0 upTo: self size do: aBlock! ! - -SequenceableCollection removeSelector: #combinationsAt:in:after:do:! - -SequenceableCollection removeSelector: #combinationsAt:in:after:do:! - -SequenceableCollection removeSelector: #combinationsAt:upTo:in:after:do:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3771-combinationsPerformanceImprovement-AndresValloud-2019May25-13h09m-sqr.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3771] on 26 May 2019 at 5:08:55 pm'! -!Behavior methodsFor: 'testing' stamp: 'len 5/16/2019 05:56:15'! - isDoubleBytes - "Answer whether the receiver's instances indexed 16-bit integer instance variables. - Above Cog Spur the class format is - <5 bits inst spec><16 bits inst size> - where the 5-bit inst spec is - 0 = 0 sized objects (UndefinedObject True False et al) - 1 = non-indexable objects with inst vars (Point et al) - 2 = indexable objects with no inst vars (Array et al) - 3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al) - 4 = weak indexable objects with inst vars (WeakArray et al) - 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron) - 6 = unused - 7 = immediates (SmallInteger, Character) - 8 = unused - 9 = 64-bit indexable - 10-11 = 32-bit indexable (Bitmap) - 12-15 = 16-bit indexable - 16-23 = 8-bit indexable - 24-31 = compiled methods (CompiledMethod)" - - ^ Smalltalk isSpur and: [ self instSpec = 12 ]! ! -!Behavior methodsFor: 'testing' stamp: 'len 5/16/2019 05:56:02'! - isDoubleWords - "Answer whether the receiver's instances indexed 64-bit integer instance variables. - Above Cog Spur the class format is - <5 bits inst spec><16 bits inst size> - where the 5-bit inst spec is - 0 = 0 sized objects (UndefinedObject True False et al) - 1 = non-indexable objects with inst vars (Point et al) - 2 = indexable objects with no inst vars (Array et al) - 3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al) - 4 = weak indexable objects with inst vars (WeakArray et al) - 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron) - 6 = unused - 7 = immediates (SmallInteger, Character) - 8 = unused - 9 = 64-bit indexable - 10-11 = 32-bit indexable (Bitmap) - 12-15 = 16-bit indexable - 16-23 = 8-bit indexable - 24-31 = compiled methods (CompiledMethod)" - - ^ Smalltalk isSpur and: [ self instSpec = 9 ]! ! -!Class methodsFor: 'subclass creation' stamp: 'len 5/16/2019 05:11:11'! - variableDoubleByteSubclass: t instanceVariableNames: f - classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a - subclass of an existing class (the receiver) in which the subclass is to - have indexable double-byte-sized (16 bits) nonpointer variables." - "Note: Only for Spur images" - - | answer | - answer _ ClassBuilder new - superclass: self - variableDoubleByteSubclass: t - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat. - - Smalltalk - logChange: answer definition - preamble: answer definitionPreamble. - ^answer -! ! -!Class methodsFor: 'subclass creation' stamp: 'len 5/16/2019 05:10:47'! - variableDoubleWordSubclass: t instanceVariableNames: f - classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a - subclass of an existing class (the receiver) in which the subclass is to - have indexable double-word-sized (64 bits) nonpointer variables." - "Note: Only for Spur images" - - | answer | - answer _ ClassBuilder new - superclass: self - variableDoubleWordSubclass: t - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat. - - Smalltalk - logChange: answer definition - preamble: answer definitionPreamble. - ^answer! ! -!ClassBuilder methodsFor: 'public' stamp: 'len 5/16/2019 06:13:03'! - superclass: aClass - variableDoubleByteSubclass: t instanceVariableNames: f - classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a - subclass of an existing class in which the subclass is to - have indexable double-byte-sized (16 bit) nonpointer variables." - "Note: Only for Spur images" - - (aClass instSize > 0) - ifTrue: [^self error: 'cannot make a 16-bit word subclass of a class with named fields']. - (aClass isVariable and: [aClass isPointers]) - ifTrue: [^self error: 'cannot make a 16-bit word subclass of a class with pointer fields']. - (aClass isVariable and: [aClass isDoubleBytes not]) - ifTrue: [^self error: 'cannot make a 16-bit word subclass of a class with 8, 32 or 64 bit fields']. - - ^self - name: t - subclassOf: aClass - type: #shorts - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat! ! -!ClassBuilder methodsFor: 'public' stamp: 'len 5/16/2019 06:12:49'! - superclass: aClass - variableDoubleWordSubclass: t instanceVariableNames: f - classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a - subclass of an existing class in which the subclass is to - have indexable double-word-sized (64 bit) nonpointer variables." - "Note: Only for Spur images" - - (aClass instSize > 0) - ifTrue: [^self error: 'cannot make a 64-bit word subclass of a class with named fields']. - (aClass isVariable and: [aClass isPointers]) - ifTrue: [^self error: 'cannot make a 64-bit word subclass of a class with pointer fields']. - (aClass isVariable and: [aClass isDoubleWords not]) - ifTrue: [^self error: 'cannot make a 64-bit word subclass of a class with 8, 16 or 32 bit fields']. - - ^self - name: t - subclassOf: aClass - type: #longs - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat! ! -!Behavior methodsFor: 'testing' stamp: 'len 5/16/2019 05:53:44' prior: 16783112! - isWords - "Answer whether the receiver's instances indexed 32-bit integer instance variables. - Above Cog Spur the class format is - <5 bits inst spec><16 bits inst size> - where the 5-bit inst spec is - 0 = 0 sized objects (UndefinedObject True False et al) - 1 = non-indexable objects with inst vars (Point et al) - 2 = indexable objects with no inst vars (Array et al) - 3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al) - 4 = weak indexable objects with inst vars (WeakArray et al) - 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron) - 6 = unused - 7 = immediates (SmallInteger, Character) - 8 = unused - 9 = 64-bit indexable - 10-11 = 32-bit indexable (Bitmap) - 12-15 = 16-bit indexable - 16-23 = 8-bit indexable - 24-31 = compiled methods (CompiledMethod)" - - ^ Smalltalk isSpur - ifTrue: [ self instSpec = 10 ] - ifFalse: [ self isBytes not ]! ! -!ClassBuilder methodsFor: 'public' stamp: 'len 5/16/2019 06:09:08' prior: 16804187! - superclass: aClass - variableByteSubclass: t instanceVariableNames: f - classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a - subclass of an existing class in which the subclass is to - have indexable byte-sized nonpointer variables." - | oldClassOrNil actualType | - (aClass instSize > 0) - ifTrue: [^self error: 'cannot make a byte subclass of a class with named fields']. - (aClass isVariable and: [aClass isPointers]) - ifTrue: [^self error: 'cannot make a byte subclass of a class with pointer fields']. - (aClass isVariable and: [aClass isBytes not]) - ifTrue: [^self error: 'cannot make a byte subclass of a class with 16, 32 or 64 bit fields']. - oldClassOrNil := Smalltalk at: t ifAbsent: nil. - actualType := (oldClassOrNil notNil - and: [oldClassOrNil typeOfClass == #compiledMethod]) - ifTrue: [#compiledMethod] - ifFalse: [#bytes]. - ^self - name: t - subclassOf: aClass - type: actualType - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat! ! -!ClassBuilder methodsFor: 'public' stamp: 'len 5/16/2019 06:12:34' prior: 16804243! - superclass: aClass - variableWordSubclass: t instanceVariableNames: f - classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a - subclass of an existing class in which the subclass is to - have indexable word-sized (32 bit) nonpointer variables." - (aClass instSize > 0) - ifTrue: [^self error: 'cannot make a 32-bit word subclass of a class with named fields']. - (aClass isVariable and: [aClass isPointers]) - ifTrue: [^self error: 'cannot make a 32-bit word subclass of a class with pointer fields']. - (aClass isVariable and: [aClass isWords not]) - ifTrue: [^self error: 'cannot make a 32-bit word subclass of a class with 8, 16 or 64 bit fields']. - - ^self - name: t - subclassOf: aClass - type: #words - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3772-16and64bitArrays-LucianoEstebanNotarfrancesco-2019May26-17h07m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3772] on 26 May 2019 at 5:18:23 pm'! -!ClassBuilder methodsFor: 'class format' stamp: 'jmv 5/26/2019 17:17:57' prior: 16803525! - computeFormat: type instSize: newInstSize forSuper: newSuper - "Compute the new format for making oldClass a subclass of newSuper. - Answer the format or nil if there is any problem." - - "Only for Spur!!" - - | instSize isVar isPointers isWeak bitsUnitSize | - type == #compiledMethod ifTrue: - [newInstSize > 0 ifTrue: - [self error: 'A compiled method class cannot have named instance variables'. - ^nil]. - ^CompiledMethod format]. - instSize := newInstSize + (newSuper ifNil:[0] ifNotNil:[newSuper instSize]). - instSize > 65535 ifTrue: - [self error: 'Class has too many instance variables (', instSize printString,')'. - ^nil]. - type == #normal ifTrue:[isVar := isWeak := false. isPointers := true]. - type == #bytes ifTrue:[isVar := true. bitsUnitSize := 1. isPointers := isWeak := false]. - type == #shorts ifTrue:[isVar := true. bitsUnitSize := 2. isPointers := isWeak := false]. - type == #words ifTrue:[isVar := true. bitsUnitSize := 4. isPointers := isWeak := false]. - type == #longs ifTrue:[isVar := true. bitsUnitSize := 8. isPointers := isWeak := false]. - type == #variable ifTrue:[isVar := isPointers := true. isWeak := false]. - type == #weak ifTrue:[isVar := isWeak := isPointers := true]. - type == #ephemeron ifTrue:[isVar := false. isWeak := isPointers := true]. - type == #immediate ifTrue:[isVar := isWeak := isPointers := false]. - isVar ifNil: [ self error: 'Unsupported class format type: ', type. ^ nil ]. - (isPointers not and: [instSize > 0]) ifTrue: - [self error: 'A non-pointer class cannot have named instance variables'. - ^nil]. - ^self format: instSize variable: isVar bitsUnitSize: bitsUnitSize pointers: isPointers weak: isWeak! ! -!ClassBuilder methodsFor: 'class format' stamp: 'jmv 5/26/2019 17:17:52' prior: 16803577! - computeFormat: type instSize: newInstSize forSuper: newSuper ccIndex: ccIndex - "Compute the new format for making oldClass a subclass of newSuper. - Return the format or nil if there is any problem." - - | instSize isVar isWords isPointers isWeak | - - "Spur uses this version" - Smalltalk isSpur ifTrue: [ - ^ self computeFormat: type instSize: newInstSize forSuper: newSuper ]. - - "This for preSpur images" - type == #compiledMethod - ifTrue:[^CompiledMethod format]. - instSize := newInstSize + (newSuper ifNil:[0] ifNotNil:[newSuper instSize]). - instSize > 254 ifTrue:[ - self error: 'Class has too many instance variables (', instSize printString,')'. - ^nil]. - type == #normal ifTrue:[isVar := isWeak := false. isWords := isPointers := true]. - type == #bytes ifTrue:[isVar := true. isWords := isPointers := isWeak := false]. - type == #words ifTrue:[isVar := isWords := true. isPointers := isWeak := false]. - type == #variable ifTrue:[isVar := isPointers := isWords := true. isWeak := false]. - type == #weak ifTrue:[isVar := isWeak := isWords := isPointers := true]. - isVar ifNil: [ self error: 'Unsupported class format type: ', type. ^ nil ]. - (isPointers not and:[instSize > 0]) ifTrue:[ - self error:'A non-pointer class cannot have instance variables'. - ^nil]. - ^(self format: instSize - variable: isVar - words: isWords - pointers: isPointers - weak: isWeak) + (ccIndex bitShift: 11)! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3773-FailClassCreationOnInvalidType-JuanVuletich-2019May26-17h17m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3720] on 26 May 2019 at 11:05:05 pm'! -!Array2D methodsFor: 'accessing' stamp: 'GSC 5/26/2019 23:04:56'! - elements - - ^elements! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3774-FailedWhenYouCompareTwoArray2DByEqual-GonzaloSanchezCano.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3774] on 28 May 2019 at 4:20:41 pm'! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'HAW 5/28/2019 16:15:38'! - definesInstanceVariableNamedInHierarchy: anInstanceVariableName - - ^self allInstVarNames includes: anInstanceVariableName! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'HAW 5/28/2019 16:19:35' prior: 16909935! - referencesToIt - "Open a references browser on the selected symbol: a variable name or class name" - - | selectedSymbol provider environment | - - "look for exactly a whole word" - self selectWord. - selectedSymbol _ self selectedSymbol ifNil: [ ^ morph flash ]. - - "convenient access to class variables, including those in SharedPools" - provider _ self codeProvider. - environment _ (provider respondsTo: #selectedClassOrMetaClass) ifTrue: [ provider selectedClassOrMetaClass ]. - environment _ environment ifNil: [ Smalltalk ]. - - (environment bindingOf: selectedSymbol) - ifNotNil: [ :reference | Smalltalk browseAllCallsOn: reference ] - ifNil: [ (environment ~= Smalltalk and: [ environment definesInstanceVariableNamedInHierarchy: selectedSymbol ]) - ifTrue: [ Smalltalk browseAllAccessesTo: selectedSymbol from: environment ] - ifFalse: [ morph flash ]] - - - ! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3775-ReferencesToInstVarFromEditor-EricBrandweinHernanWilkinson-2019May28-15h58m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3765] on 26 May 2019 at 3:47:55 pm'! -!TemporaryToInstanceVariable methodsFor: 'applying' stamp: 'EB 5/25/2019 00:38:49'! - sourceCodeWithoutAnyTemporaryDeclarations - | firstPipeIndex secondPipeIndex | - firstPipeIndex _ method sourceText findString: '|'. - secondPipeIndex _ method sourceText findString: '|' startingAt: firstPipeIndex + 1. - ^method sourceText copyReplacing: {firstPipeIndex to: secondPipeIndex} with: ' ' ! ! -!TemporaryToInstanceVariable methodsFor: 'applying' stamp: 'EB 5/25/2019 00:39:01'! - sourceCodeWithoutTemporaryDeclaration - | temporaryVariablePositions variableDeclarationPosition | - temporaryVariablePositions _ method positionsForTemporaryVariable: variable ifAbsent: []. - variableDeclarationPosition _ {temporaryVariablePositions first}. - ^method sourceText copyReplacing: variableDeclarationPosition with: ''! ! -!TemporaryToInstanceVariable methodsFor: 'applying' stamp: 'EB 5/25/2019 00:39:01' prior: 50459499! - removeTemporary - - | newSourceCode | - newSourceCode _ method temporaries size = 1 - ifTrue: [ self sourceCodeWithoutAnyTemporaryDeclarations ] - ifFalse: [ self sourceCodeWithoutTemporaryDeclaration]. - - method methodClass compile: newSourceCode. - - ^newSourceCode. - ! ! -!TemporaryToInstanceVariable class methodsFor: 'assertions' stamp: 'EB 5/26/2019 15:40:50' prior: 50459568! - assertNoOtherMethodIn: aClass orSubclassesDefinesTemporaryNamed: aTemporaryVariableName - - | methodsDefiningTemporaryInHierarchy | - - methodsDefiningTemporaryInHierarchy := OrderedCollection new. - aClass withAllSubclassesDo: [ :subclass | - methodsDefiningTemporaryInHierarchy addAll: (subclass methodsWithArgumentOrTemporaryNamed: aTemporaryVariableName) ]. - - methodsDefiningTemporaryInHierarchy size > 1 ifTrue: [ - self - canNotRefactorDueToReferencesError: self temporaryExistsInOtherMethodsErrorDescription - references: (methodsDefiningTemporaryInHierarchy collect: [ :implementor | MethodReference method: implementor ]) - to: aTemporaryVariableName. ].! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3776-TemporaryToInstanceVariableBetterErrorMessageAndRemovesPipes-EricBrandwein-2019May24-18h51m-EB.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3766] on 28 May 2019 at 12:20:29 am'! - -ParseNodeVisitor subclass: #TemporaryVariableDeclarationCounter - instanceVariableNames: 'temporaryVariable count' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #TemporaryVariableDeclarationCounter category: #'Tools-Refactoring'! -ParseNodeVisitor subclass: #TemporaryVariableDeclarationCounter - instanceVariableNames: 'temporaryVariable count' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!TemporaryVariableDeclarationCounter methodsFor: 'initialization' stamp: 'EB 5/27/2019 20:46:01'! - initializeFor: aTemporaryVariable - - temporaryVariable _ aTemporaryVariable. - count _ 0.! ! -!TemporaryVariableDeclarationCounter methodsFor: 'visiting' stamp: 'EB 5/27/2019 20:53:26'! - visitBlockNode: aBlockNode - - | hasTemporaryVariable | - - super visitBlockNode: aBlockNode. - hasTemporaryVariable _ aBlockNode temporaries anySatisfy: [ :temporaryVariableNode | - temporaryVariableNode key = temporaryVariable ]. - hasTemporaryVariable ifTrue: [ count _ count + 1 ]! ! -!TemporaryVariableDeclarationCounter methodsFor: 'count' stamp: 'EB 5/27/2019 20:46:23'! - count - - ^count.! ! -!TemporaryVariableDeclarationCounter class methodsFor: 'instance creation' stamp: 'EB 5/27/2019 20:32:01'! - for: aTemporaryVariable - ^self new initializeFor: aTemporaryVariable.! ! -!TemporaryToInstanceVariable class methodsFor: 'error descriptions' stamp: 'EB 5/27/2019 20:20:10'! - temporaryExistsInOtherBlockErrorDescription - - ^'The temporary exists in other blocks in this method; remove those first.'.! ! -!TemporaryToInstanceVariable class methodsFor: 'assertions' stamp: 'EB 5/27/2019 20:45:47'! - assertNoOtherBlockIn: aMethodNode definesTemporaryNamed: aTemporaryVariableName - - | counter | - - counter _ TemporaryVariableDeclarationCounter for: aTemporaryVariableName. - aMethodNode accept: counter. - counter count > 1 ifTrue: [ - self refactoringError: self temporaryExistsInOtherBlockErrorDescription ].! ! -!TemporaryToInstanceVariable class methodsFor: 'instance creation' stamp: 'EB 5/27/2019 20:22:44' prior: 50459516! - named: aTemporaryVariableName fromMethod: aMethodNode - - | methodClass | - - methodClass _ aMethodNode methodClass. - - self assertNoOtherBlockIn: aMethodNode definesTemporaryNamed: aTemporaryVariableName. - self assert: aMethodNode hasTemporaryNamed: aTemporaryVariableName. - self assertNoOtherMethodIn: methodClass orSubclassesDefinesTemporaryNamed: aTemporaryVariableName. - self assertSubclassesOf: methodClass haventGotInstanceVariableNamed: aTemporaryVariableName. - - ^self new initializeNamed: aTemporaryVariableName fromMethod: aMethodNode.! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3777-TemporaryToInstanceVariableWithMultipleBlocks-EricBrandwein-2019May28-00h17m-EB.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3777] on 29 May 2019 at 9:08:47 am'! - -ParseNodeVisitor subclass: #ParseNodesDeclaringTemporaryVariableVisitor - instanceVariableNames: 'temporaryVariable' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ParseNodesDeclaringTemporaryVariableVisitor category: #'Tools-Refactoring'! -ParseNodeVisitor subclass: #ParseNodesDeclaringTemporaryVariableVisitor - instanceVariableNames: 'temporaryVariable' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ParseNodeVisitor subclass: #TemporaryVariableDeclarationCounter - instanceVariableNames: 'temporaryVariable count ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #TemporaryVariableDeclarationCounter category: #'Tools-Refactoring'! -ParseNodeVisitor subclass: #TemporaryVariableDeclarationCounter - instanceVariableNames: 'temporaryVariable count' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!ParseNodesDeclaringTemporaryVariableVisitor methodsFor: 'visiting' stamp: 'EB 5/28/2019 21:40:33'! - isNodeDeclaringTemporary: aParseNode - - ^aParseNode temporaries anySatisfy: [ :temporaryVariableNode | - temporaryVariableNode key = temporaryVariable - ].! ! -!ParseNodesDeclaringTemporaryVariableVisitor methodsFor: 'visiting' stamp: 'EB 5/28/2019 20:58:20'! - visitBlockNode: aBlockNode - - (self isNodeDeclaringTemporary: aBlockNode) ifTrue: [ - self visitBlockNodeDeclaringTemporary: aBlockNode - ]. - super visitBlockNode: aBlockNode.! ! -!ParseNodesDeclaringTemporaryVariableVisitor methodsFor: 'visiting' stamp: 'EB 5/28/2019 21:40:38'! - visitBlockNodeDeclaringTemporary: aBlockNode - - self subclassResponsibility.! ! -!ParseNodesDeclaringTemporaryVariableVisitor methodsFor: 'visiting' stamp: 'EB 5/28/2019 20:58:33'! - visitMethodNode: aMethodNode - - (self isNodeDeclaringTemporary: aMethodNode) ifTrue: [ - self visitMethodNodeDeclaringTemporary: aMethodNode. - ]. - super visitMethodNode: aMethodNode.! ! -!ParseNodesDeclaringTemporaryVariableVisitor methodsFor: 'visiting' stamp: 'EB 5/28/2019 21:40:42'! - visitMethodNodeDeclaringTemporary: aMethodNode - - self subclassResponsibility.! ! -!ParseNodesDeclaringTemporaryVariableVisitor methodsFor: 'initialization' stamp: 'EB 5/28/2019 20:53:53'! - initializeFor: aTemporaryVariable - - temporaryVariable _ aTemporaryVariable. -! ! -!ParseNodesDeclaringTemporaryVariableVisitor class methodsFor: 'instance creation' stamp: 'EB 5/28/2019 21:40:48'! - for: aTemporaryVariable - - ^self new initializeFor: aTemporaryVariable.! ! - -ParseNodeVisitor subclass: #TemporaryVariableDeclarationCounter - instanceVariableNames: 'count' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #TemporaryVariableDeclarationCounter category: #'Tools-Refactoring'! -ParseNodeVisitor subclass: #TemporaryVariableDeclarationCounter - instanceVariableNames: 'count' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3778-RemovePipesFixPreInstallation-HernanWilkinson-2019May29-09h07m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3777] on 29 May 2019 at 9:14:30 am'! - -ParseNodesDeclaringTemporaryVariableVisitor subclass: #TemporaryVariableDeclarationCounter - instanceVariableNames: 'count ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #TemporaryVariableDeclarationCounter category: #'Tools-Refactoring'! -ParseNodesDeclaringTemporaryVariableVisitor subclass: #TemporaryVariableDeclarationCounter - instanceVariableNames: 'count' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ParseNodesDeclaringTemporaryVariableVisitor subclass: #TemporaryVariableDeclarationRemover - instanceVariableNames: 'methodNode newSourceCode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #TemporaryVariableDeclarationRemover category: #'Tools-Refactoring'! -ParseNodesDeclaringTemporaryVariableVisitor subclass: #TemporaryVariableDeclarationRemover - instanceVariableNames: 'methodNode newSourceCode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!TemporaryVariableDeclarationCounter methodsFor: 'initialization' stamp: 'EB 5/28/2019 21:00:58'! - initialize - - count _ 0.! ! -!TemporaryVariableDeclarationCounter methodsFor: 'visiting' stamp: 'EB 5/28/2019 20:59:44'! - visitBlockNodeDeclaringTemporary: aBlockNode - - count _ count + 1.! ! -!TemporaryVariableDeclarationCounter methodsFor: 'visiting' stamp: 'EB 5/28/2019 21:00:06'! - visitMethodNodeDeclaringTemporary: aMethodNode - - count _ count + 1.! ! -!TemporaryVariableDeclarationRemover methodsFor: 'source text generation' stamp: 'EB 5/28/2019 21:24:38'! - sourceTextWithoutMethodTemporaryDeclarationLine - - | endTempsMark startTempsMark | - - startTempsMark _ methodNode sourceText indexOf: $|. - endTempsMark _ methodNode sourceText indexOf: $| startingAt: startTempsMark + 1. - ^self sourceTextWithoutTemporaryDeclarationLineFrom: startTempsMark to: endTempsMark.! ! -!TemporaryVariableDeclarationRemover methodsFor: 'source text generation' stamp: 'EB 5/28/2019 21:22:07'! -sourceTextWithoutTemporaryDeclaration - - | temporaryVariablePositions variableDeclarationPosition | - - temporaryVariablePositions _ methodNode positionsForTemporaryVariable: temporaryVariable ifAbsent: []. - variableDeclarationPosition _ {temporaryVariablePositions first}. - ^methodNode sourceText copyReplacing: variableDeclarationPosition with: ''! ! -!TemporaryVariableDeclarationRemover methodsFor: 'source text generation' stamp: 'EB 5/28/2019 21:41:15'! - sourceTextWithoutTemporaryDeclarationLineFrom: firstIndex to: lastIndex - - ^methodNode sourceText copyReplaceFrom: firstIndex to: lastIndex with: ' '.! ! -!TemporaryVariableDeclarationRemover methodsFor: 'source text generation' stamp: 'EB 5/28/2019 21:24:38'! - sourceTextWithoutTemporaryDeclarationLineInBlockNode: aBlockNode - - | sourceTextUpToEndTemps endTempsMark startTempsMark | - - endTempsMark _ aBlockNode tempsMark. - sourceTextUpToEndTemps _ methodNode sourceText copyFrom: 1 to: endTempsMark - 1. - startTempsMark _ sourceTextUpToEndTemps findLastOccurrenceOfString: '|' startingAt: 1. - ^self sourceTextWithoutTemporaryDeclarationLineFrom: startTempsMark to: endTempsMark. - - ! ! -!TemporaryVariableDeclarationRemover methodsFor: 'source text generation' stamp: 'EB 5/28/2019 21:27:58'! - sourceTextWithoutTemporaryFromParseNode: aParseNode -withTemporaryDeclarationLineRemover: aTemporaryDeclarationLineRemovingBlock - - ^aParseNode temporaries size = 1 - ifTrue: aTemporaryDeclarationLineRemovingBlock value - ifFalse: [ self sourceTextWithoutTemporaryDeclaration ].! ! -!TemporaryVariableDeclarationRemover methodsFor: 'accessing' stamp: 'EB 5/28/2019 21:12:33'! - methodNode: aMethodNode - - methodNode _ aMethodNode.! ! -!TemporaryVariableDeclarationRemover methodsFor: 'accessing' stamp: 'EB 5/28/2019 21:18:31'! - newSourceCode - - ^newSourceCode ! ! -!TemporaryVariableDeclarationRemover methodsFor: 'visiting' stamp: 'EB 5/28/2019 21:17:14'! - visitBlockNodeDeclaringTemporary: aBlockNode - - self - visitNodeDeclaringTemporary: aBlockNode - withTemporaryDeclarationLineRemover: [ - self sourceTextWithoutTemporaryDeclarationLineInBlockNode: aBlockNode ]! ! -!TemporaryVariableDeclarationRemover methodsFor: 'visiting' stamp: 'EB 5/28/2019 21:17:46'! - visitMethodNodeDeclaringTemporary: aMethodNode - - self - visitNodeDeclaringTemporary: aMethodNode - withTemporaryDeclarationLineRemover: [ self sourceTextWithoutMethodTemporaryDeclarationLine ]! ! -!TemporaryVariableDeclarationRemover methodsFor: 'visiting' stamp: 'EB 5/28/2019 21:27:34'! - visitNodeDeclaringTemporary: aParseNode -withTemporaryDeclarationLineRemover: aTemporaryDeclarationLineRemovingBlock - - newSourceCode _ self - sourceTextWithoutTemporaryFromParseNode: aParseNode - withTemporaryDeclarationLineRemover: aTemporaryDeclarationLineRemovingBlock. - - methodNode methodClass compile: newSourceCode.! ! -!TemporaryVariableDeclarationRemover class methodsFor: 'instance creation' stamp: 'EB 5/28/2019 21:11:31'! - in: aMethodNode for: aTemporaryVariable - - | instance | - - instance _ self for: aTemporaryVariable. - instance methodNode: aMethodNode. - ^instance! ! -!BlockNode methodsFor: 'accessing' stamp: 'EB 5/28/2019 19:43:53' prior: 16789659! - temporaries - "Collection of TempVariableNodes" - ^temporaries ifNil: [#()]! ! -!BlockNode methodsFor: 'accessing' stamp: 'EB 5/28/2019 19:43:59' prior: 16789663! -temporaries: aCollection - "Collection of TempVariableNodes" - temporaries := aCollection! ! -!BlockNode methodsFor: 'accessing' stamp: 'EB 5/28/2019 19:52:48' prior: 16789667! - tempsMark - "Index of the end of the temporaries declarations in the containing MethodNode sourceText" - ^tempsMark! ! -!BlockNode methodsFor: 'accessing' stamp: 'EB 5/28/2019 19:53:04' prior: 16789670! - tempsMark: anInteger - "Index of the end of the temporaries declarations in the containing MethodNode sourceText" - tempsMark := anInteger! ! -!TemporaryToInstanceVariable methodsFor: 'applying' stamp: 'EB 5/28/2019 21:29:47' prior: 50461758! - removeTemporary - - | remover | - - remover _ TemporaryVariableDeclarationRemover in: method for: variable. - method accept: remover. - ^remover newSourceCode. - ! ! - -TemporaryToInstanceVariable removeSelector: #sourceCodeWithoutAnyTemporaryDeclarations! - -TemporaryToInstanceVariable removeSelector: #sourceCodeWithoutAnyTemporaryDeclarations! - -TemporaryToInstanceVariable removeSelector: #sourceCodeWithoutTemporaryDeclaration! - -TemporaryToInstanceVariable removeSelector: #sourceCodeWithoutTemporaryDeclaration! - -TemporaryVariableDeclarationCounter class removeSelector: #for:! - -TemporaryVariableDeclarationCounter class removeSelector: #for:! - -TemporaryVariableDeclarationCounter removeSelector: #initializeFor:! - -TemporaryVariableDeclarationCounter removeSelector: #initializeFor:! - -TemporaryVariableDeclarationCounter removeSelector: #visitBlockNode:! - -TemporaryVariableDeclarationCounter removeSelector: #visitBlockNode:! - -ParseNodesDeclaringTemporaryVariableVisitor subclass: #TemporaryVariableDeclarationCounter - instanceVariableNames: 'count' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #TemporaryVariableDeclarationCounter category: #'Tools-Refactoring'! -ParseNodesDeclaringTemporaryVariableVisitor subclass: #TemporaryVariableDeclarationCounter - instanceVariableNames: 'count' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3779-TemporaryToInstanceVariableRemovesPipesInBlock-EricBrandwein-2019May29-09h08m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3779] on 31 May 2019 at 11:34:28 am'! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 5/31/2019 11:33:02' prior: 50450582! - sendersFrom: methodReferences - - senders := methodReferences collect: [:aMethodReference | aMethodReference compiledMethod ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3780-ChangeSendersOnRenameFix-HernanWilkinson-2019May31-11h33m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3779] on 31 May 2019 at 11:51:56 am'! -!SHParserST80 methodsFor: 'scan' stamp: 'EB 5/30/2019 19:54:12' prior: 16901793! - scanBinary - | c d | - c := self currentChar. - currentTokenSourcePosition := sourcePosition. - currentToken := c asString. - d := self nextChar. - ((self isBinarySelectorCharacter: c) or: [c == $:]) ifFalse: [^currentToken]. - (c == $: and: [d == $=]) - ifTrue: [" := assignment" - currentToken := currentToken , d asString. - self nextChar. - ^currentToken]. - (c == $| and: [d == $|]) - ifTrue: ["|| empty temp declaration" - ^currentToken]. - c _ d. - [ - d _ self peekChar. - c == $- - ifTrue: [ d isDigit not ] - ifFalse: [ self isBinarySelectorCharacter: c ] - ] - whileTrue: [ - currentToken _ currentToken copyWith: c. - c _ self nextChar ]. - ^currentToken! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3781-ParsingTwoPipesAsAnEmptyTempDeclaration-EricBrandwein-HernanWilkinson-2019May31-11h34m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3781] on 3 June 2019 at 10:17:39 am'! -!String class methodsFor: 'initialization' stamp: 'len 5/13/2019 13:50:16' prior: 50458467! - initialize - " - String initialize - " - - | order newOrder lowercase | - "Case insensitive compare sorts null, space, digits, letters, all the rest..." - newOrder _ Array new: 256. - order _ -1. - newOrder at: 0+1 put: (order _ order+1). - 32 to: 64 do: [ :c | - newOrder at: c + 1 put: (order _ order+1)]. - #(92 94 124 126 183 215 247) do: [ :c | "\^|~·÷×" - newOrder at: c + 1 put: (order _ order+1)]. - 16r90 to: 16r9F do: [:c| "special math operators" - newOrder at: c + 1 put: (order _ order+1)]. - Character uppercaseLowercaseAndUnaccentedLetters do: [ :upperAndLowercase | - order _ order+1. - newOrder at: upperAndLowercase first numericValue + 1 put: order. - upperAndLowercase size > 1 ifTrue: [ - newOrder at: upperAndLowercase second numericValue + 1 put: order ]]. - 1 to: newOrder size do: [ :i | - (newOrder at: i) ifNil: [ - newOrder at: i put: (order _ order+1)]]. - CaseInsensitiveOrder _ newOrder asByteArray. - - "Case sensitive compare sorts null, space, digits, letters, all the rest..." - newOrder _ Array new: 256. - order _ -1. - newOrder at: 0+1 put: (order _ order+1). - 32 to: 64 do: [ :c | - newOrder at: c + 1 put: (order _ order+1)]. - #(92 94 124 126 183 215 247) do: [ :c | "\^|~·÷×" - newOrder at: c + 1 put: (order _ order+1)]. - 16r90 to: 16r9F do: [:c| "special math operators" - newOrder at: c + 1 put: (order _ order+1)]. - Character uppercaseLowercaseAndUnaccentedLetters do: [ :upperAndLowercase | - upperAndLowercase size > 1 ifTrue: [ - newOrder at: upperAndLowercase first numericValue + 1 put: (order _ order+1) ]]. - Character uppercaseLowercaseAndUnaccentedLetters do: [ :upperAndLowercase | - lowercase _ upperAndLowercase size = 1 - ifTrue: [ upperAndLowercase first ] - ifFalse: [ upperAndLowercase second ]. - newOrder at: lowercase numericValue + 1 put: (order _ order+1) ]. - 1 to: newOrder size do: [ :i | - (newOrder at: i) ifNil: [ - newOrder at: i put: (order _ order+1)]]. - order = 255 ifFalse: [self error: 'order problem']. - CaseSensitiveOrder _ newOrder asByteArray. - - "a table for translating to lower case" - LowercasingTable _ String withAll: (Character characterTable collect: [:c | c asLowercase]). - - "a table for translating to upper case" - UppercasingTable _ String withAll: (Character characterTable collect: [:c | c asUppercase]). - - "a table for testing tokenish (for fast numArgs)" - Tokenish _ String withAll: (Character characterTable collect: - [:c | c tokenish ifTrue: [c] ifFalse: [$~]]). - - "CR and LF--characters that terminate a line" - CSLineEnders _ CharacterSet new. - CSLineEnders add: Character cr. - CSLineEnders add: Character lf. - - "separators and non-separators" - CSSeparators _ CharacterSet separators. - CSNonSeparators _ CSSeparators complement! ! - -String initialize! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3782-SortingOfMathOperators-tweak-LucianoEstebanNotarfrancesco-2019Jun03-10h16m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3781] on 3 June 2019 at 10:25:49 am'! -!String methodsFor: 'text conversion helpers' stamp: 'len 6/3/2019 10:24:00' prior: 16917730! - bold - "Stuff like - ('X' italic, '2' super, ' + ', 'H' bold, 'ij' sub, ' + ', 'lim' italic under, 'z  ' sub, '(1 / z)' ) edit - " - ^self asText bold! ! -!String methodsFor: 'text conversion helpers' stamp: 'len 6/3/2019 10:24:16' prior: 16917738! - italic - "Stuff like - ('X' italic, '2' super, ' + ', 'H' bold, 'ij' sub, ' + ', 'lim' italic under, 'z  ' sub, '(1 / z)' ) edit - " - ^self asText italic! ! -!String methodsFor: 'text conversion helpers' stamp: 'len 6/3/2019 10:24:18' prior: 16917750! - sub - "Stuff like - ('X' italic, '2' super, ' + ', 'H' bold, 'ij' sub, ' + ', 'lim' italic under, 'z  ' sub, '(1 / z)' ) edit - " - ^self asText sub! ! -!String methodsFor: 'text conversion helpers' stamp: 'len 6/3/2019 10:24:20' prior: 16917758! - super - "Stuff like - ('X' italic, '2' super, ' + ', 'H' bold, 'ij' sub, ' + ', 'lim' italic under, 'z  ' sub, '(1 / z)' ) edit - " - ^self asText super! ! -!String methodsFor: 'text conversion helpers' stamp: 'len 6/3/2019 10:24:24' prior: 16917766! - under - "Stuff like - ('X' italic, '2' super, ' + ', 'H' bold, 'ij' sub, ' + ', 'lim' italic under, 'z  ' sub, '(1 / z)' ) edit - " - ^self asText under! ! -!Text methodsFor: 'adding emphasis' stamp: 'len 6/3/2019 10:24:26' prior: 16929729! - bold - "Stuff like - ('X' italic, '2' super, ' + ', 'H' bold, 'ij' sub, ' + ', 'lim' italic under, 'z  ' sub, '(1 / z)' ) edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextEmphasis bold from: 1 to: string size! ! -!Text methodsFor: 'adding emphasis' stamp: 'len 6/3/2019 10:24:28' prior: 16929739! - italic - "Stuff like - ('X' italic, '2' super, ' + ', 'H' bold, 'ij' sub, ' + ', 'lim' italic under, 'z  ' sub, '(1 / z)' ) edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextEmphasis italic from: 1 to: string size! ! -!Text methodsFor: 'adding emphasis' stamp: 'len 6/3/2019 10:24:30' prior: 16929755! - sub - "Stuff like - ('X' italic, '2' super, ' + ', 'H' bold, 'ij' sub, ' + ', 'lim' italic under, 'z  ' sub, '(1 / z)' ) edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextEmphasis subscript from: 1 to: string size! ! -!Text methodsFor: 'adding emphasis' stamp: 'len 6/3/2019 10:24:32' prior: 16929765! - super - "Stuff like - ('X' italic, '2' super, ' + ', 'H' bold, 'ij' sub, ' + ', 'lim' italic under, 'z  ' sub, '(1 / z)' ) edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextEmphasis superscript from: 1 to: string size! ! -!Text methodsFor: 'adding emphasis' stamp: 'len 6/3/2019 10:24:34' prior: 16929775! - under - "Stuff like - ('X' italic, '2' super, ' + ', 'H' bold, 'ij' sub, ' + ', 'lim' italic under, 'z  ' sub, '(1 / z)' ) edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextEmphasis underlined from: 1 to: string size! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3783-InfinityGlyphChangedForTT-LucianoEstebanNotarfrancesco-2019Jun03-10h18m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3777] on 1 June 2019 at 6:21:58 am'! - -Object subclass: #DamageRecorder - instanceVariableNames: 'invalidRects totalRepaint drSemaphore ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #DamageRecorder category: #'Morphic-Support'! -Object subclass: #DamageRecorder - instanceVariableNames: 'invalidRects totalRepaint drSemaphore' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! -!DamageRecorder methodsFor: 'initialization' stamp: 'pb 6/1/2019 06:02:18'! - initialize - super initialize . - invalidRects _ OrderedCollection new: 15. - totalRepaint _ false! ! -!DamageRecorder methodsFor: 'private' stamp: 'pb 6/1/2019 05:21:24'! - pvtAccessProtect - ^ drSemaphore ifNil: [drSemaphore := Semaphore forMutualExclusion]! ! -!DamageRecorder methodsFor: 'private' stamp: 'pb 6/1/2019 06:00:14'! - pvtInnerRecordInvalidRect: requestedRect - "Record the given rectangle in my damage list, a list of rectangular areas of the display that should be redraw on the next display cycle. - Rectangles are specified in world coordinates (might be not the same as Display coordinates if there is some origin set on some canvas. Usually there will be none, but we can't be sure) - " - "Details: Damaged rectangles are often identical or overlap significantly. In these cases, we merge them to reduce the number of damage rectangles that must be processed when the display is updated. Moreover, above a certain threshold, we ignore the individual rectangles completely, and simply do a complete repaint on the next cycle. - jmv: Important. There should be no overlapping rectangles in the list. If there are, translucent morphs might be drawn several times, with visible defects. - WRT performance, the different paths for various intersections seem a bit complicated. I could not find strong evidence of the best way. - Leave it as it is right now." - | newRect mergeRect indexToReuse | - totalRepaint ifTrue: [ ^ self ]. - "planning full repaint; don't bother collecting damage" - indexToReuse _ nil. - newRect _ requestedRect truncated. - invalidRects withIndexDo: [ :oldRect :index | - oldRect - ifNil: [ indexToReuse ifNil: [ indexToReuse _ index ]] - ifNotNil: [ - "No two rectangles should intersect" - (oldRect intersects: newRect) ifTrue: [ - "newRect already in. Nothing to do then." - (oldRect containsRect: newRect) ifTrue: [ ^ self ]. - "Some oldRect included in newRect. Remove it and continue, as newRect could still intersect others." - (newRect containsRect: oldRect) ifTrue: [ - invalidRects - at: index - put: nil. - "Effectively like 'invalidRects remove: rect', but without performance penalty." - indexToReuse ifNil: [ indexToReuse _ index ]]. - "Merge rectangles if they overlap significantly, i.e. if the merge is not much larger than separated rectangles." - mergeRect _ (oldRect origin min: newRect origin) corner: (oldRect corner max: newRect corner). - mergeRect area > (newRect area + oldRect area * 2) - ifTrue: [ - "Avoid intersections!!" - newRect - areasOutside: oldRect - do: [ :nonIntersection | - "We have brand new newRects. Start all over with each of them." - self pvtInnerRecordInvalidRect: nonIntersection ]. - "newRect no longer needed, then." - ^ self ] - ifFalse: [ - "Merge into newRect, as any overlap with forecoming rectangles in the iteration is detected and treated." - newRect _ mergeRect. - invalidRects - at: index - put: nil. - "Effectively like 'invalidRects remove: rect', but without performance penalty." - indexToReuse ifNil: [ indexToReuse _ index ]]]]]. - invalidRects size >= 10 ifTrue: [ - "if there are too many separate areas, merge them all" - mergeRect _ Rectangle merging: invalidRects. - self pvtReset. - mergeRect ifNotNil: [ invalidRects addLast: mergeRect ]. - indexToReuse _ nil ]. - "Add the given rectangle to the damage list" - indexToReuse - ifNil: [ invalidRects addLast: newRect ] - ifNotNil: [ - invalidRects - at: indexToReuse - put: newRect ].! ! -!DamageRecorder methodsFor: 'private' stamp: 'pb 6/1/2019 05:59:38'! - pvtReset - "Clear the damage list." - invalidRects removeAll. - totalRepaint _ false.! ! -!WorldState methodsFor: 'drawing' stamp: 'pb 6/1/2019 06:06:26' prior: 50381071! - drawInvalidAreasSubmorphs: submorphs - "Redraw the damaged areas of the given canvas and clear the damage list. Return a collection of the areas that were redrawn." - - | initialRectsToRepair currentRectsToRepair newRectsToRepair morphsToDraw rectsForEachMorph thisMorphRects reuse i n morph morphBounds morphClipRect | - - "The simple implementation is slowers as it draws morph areas that will later be covered by other morphs. - But it works, and it is easier to understand. - See en.wikipedia.org/wiki/Painter's_algorithm" - true not ifTrue: [ ^self simpleDrawInvalidAreasSubmorphs: submorphs ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - initialRectsToRepair _ damageRecorder invalidRectsFullBounds: world viewBox. - currentRectsToRepair _ OrderedCollection new. - newRectsToRepair _ OrderedCollection withAll: initialRectsToRepair. - morphsToDraw _ OrderedCollection new. - rectsForEachMorph _ OrderedCollection new. - thisMorphRects _ OrderedCollection new. - n _ submorphs size. - i _ 1. - - "The idea here is to iterate morphs front to back, i.e. first the ones on top. - For each morph, record the rectangles it affects. And if a morph is opaque, remove the area behind it from the list of rectangles to be repaired. - This means, for example, that morphs completely covered might even not be redrawn. - this is a huge performance gain when there are many morphs on screen, especially if there are more than ten open windows, and Theme uses opaque colors. - See 'A reverse painter's algorithm' at en.wikipedia.org/wiki/Painter's_algorithm" - [ i <= n and: [ newRectsToRepair notEmpty ]] whileTrue: [ - morph _ submorphs at: i. - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - reuse _ currentRectsToRepair. - currentRectsToRepair _ newRectsToRepair. - newRectsToRepair _ reuse removeAll. - currentRectsToRepair do: [ :r | - (morphBounds intersects: r) - ifTrue: [ - morphClipRect _ morphBounds intersect: r. - thisMorphRects add: morphClipRect. "We could perhaps try and join adjacent rectangles in this collection..." - morph addPossiblyUncoveredAreasIn: r to: newRectsToRepair ] - ifFalse: [ - newRectsToRepair add: r ]]. - thisMorphRects ifNotEmpty: [ - morphsToDraw add: morph. - rectsForEachMorph add: thisMorphRects. - thisMorphRects _ OrderedCollection new. - ]]. - i _ i + 1 ]. - - "*make this true to flash damaged areas for testing*" - Preferences debugShowDamage ifTrue: [ world fillRects: initialRectsToRepair ]. - - "Draw world background on those areas that were not completely covered by opaque morphs" - i > n ifTrue: [ - newRectsToRepair do: [ :r | - world drawOn: (canvas newClipRect: r) ]]. - - "Now, draw the recorded areas of selected morphs, back to front." - morphsToDraw with: rectsForEachMorph reverseDo: [ :m :xrects | - "Here we could think about merging all xrects into just one call... - This would mean drawing each morph just once. - But that would mean drawing pixels we were not told to. There could be other morphs in that area that are not even being drawn!! - See WorldState class >> #experiment1" - "*make this true to flash damaged areas for testing*" - Preferences debugShowDamage2 ifTrue: [ - world fillRects: xrects ]. -" rr _ nil." - xrects do: [ :r | -" rr _ rr ifNil: [ r ] ifNotNil: [ r quickMerge: rr ]." - (canvas newClipRect: r) fullDraw: m. - ]. -" (canvas newClipRect: rr) fullDraw: m" - ]. - - "Answer a list of rectangles to be updated on the Display. - This usually is not performance critical, drawing morphs is slower than just exposing the Display." - "What should we force on Display? Whatever was asked? Each small rect that was updated? A single bigger rect? - Right now, answer whatever was asked... Maybe this could be changed if that enhances performance... - (think of vnc over slow networks)" - ^ initialRectsToRepair! ! -!WorldState methodsFor: 'drawing' stamp: 'pb 6/1/2019 06:06:40' prior: 50339786! - simpleDrawInvalidAreasSubmorphs: submorphs - - "mover todo esto al canvas, no? - Y ver que hacer con los argumentos, etc.... Toda esta bananarama!!" - - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - This simple implementation just does as requested: No optimizations are done." - - | rectsToRepair morphBounds | - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ damageRecorder invalidRectsFullBounds: world viewBox. - - "Draw World" - rectsToRepair do: [ :r | - world drawOn: (canvas newClipRect: r) ]. - - "Draw morphs" - submorphs reverseDo: [ :morph | - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - rectsToRepair do: [ :r | - (morphBounds intersects: r) ifTrue: [ - (canvas newClipRect: r) fullDraw: morph ]]]]. - - ^ rectsToRepair! ! -!DamageRecorder methodsFor: 'recording' stamp: 'pb 6/1/2019 06:05:16' prior: 16826973! - invalidRectsFullBounds: aRectangle - "Return a collection of damaged rectangles for the given canvas. If a total repaint has been requested, return the given rectangle." - "The collection answered should not be modified outside this method. In addition, it could contain nil objects, that should be ignored." - | answer | - answer _ totalRepaint - ifTrue: [ Array with: aRectangle ]. - self pvtAccessProtect critical: [ - answer ifNil: [answer := invalidRects reject: [ :r | - r isNil ]]. - self pvtReset]. - ^ answer.! ! -!DamageRecorder methodsFor: 'recording' stamp: 'pb 6/1/2019 05:39:59' prior: 16826990! - recordInvalidRect: requestedRect - ^ self pvtAccessProtect critical: [ self pvtInnerRecordInvalidRect: requestedRect ]! ! -!DamageRecorder methodsFor: 'testing' stamp: 'pb 6/1/2019 05:34:58' prior: 16827091! - updateIsNeeded - "Return true if the display needs to be updated. - Note: This could give a false positive (i.e. answer true) if invalidRects is not empty but it only contains nils. - Senders should be aware of this." - ^ totalRepaint or: [ self pvtAccessProtect critical: [invalidRects notEmpty] ].! ! - -DamageRecorder class removeSelector: #new! - -DamageRecorder class removeSelector: #new! - -DamageRecorder removeSelector: #reset! - -DamageRecorder removeSelector: #reset! - -Object subclass: #DamageRecorder - instanceVariableNames: 'invalidRects totalRepaint drSemaphore' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #DamageRecorder category: #'Morphic-Support'! -Object subclass: #DamageRecorder - instanceVariableNames: 'invalidRects totalRepaint drSemaphore' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3784-BackgroundSafeRedrawNeeded-PhilBellalouna-2019Jun01-05h20m-pb.1.cs.st----! - -----SNAPSHOT----(3 June 2019 11:00:52) Cuis5.0-3784-32.image priorSource: 3945530! - -----QUIT----(3 June 2019 11:01:14) Cuis5.0-3784-32.image priorSource: 4198122! - -----STARTUP---- (11 June 2019 14:15:38) as /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/Cuis5.0-3784-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3784] on 5 June 2019 at 2:42:46 pm'! -!TextReplaceCommand methodsFor: 'as yet unclassified' stamp: 'EB 6/5/2019 14:41:58'! - stopPosition - ^position + new size.! ! -!TextModel methodsFor: 'undoable commands' stamp: 'EB 6/5/2019 14:41:58' prior: 16933816! - logUndoAndReplaceFrom: start to: stop with: replacement - "As requested." - - | command now | - "Time millisecondClockValue rolls over and is generally not adviced. - But here, we don't care. A user edit doing during rollover would be split in two, as if the user did a pause. - Not a problem." - - now _ Time millisecondClockValue. - command _ self commandForReplaceFrom: start to: stop with: replacement. - (stop+1 = start and: [ lastEditTimeStamp notNil and: [ now - lastEditTimeStamp < 1000 and: [start = undoRedoCommands last stopPosition] ]]) - ifTrue: [ - "Don't use the command we just built" - undoRedoCommands last appendToNew: replacement - ] - ifFalse: [ - undoRedoCommands - nextPut: command; - truncateAtPosition. "To disable redo of previous commands, now invalidated." - ]. - command doOn: self. - lastEditTimeStamp _ now! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3785-SyntaxErrorUndoFix-EricBrandwein-2019Jun05-03h24m-EB.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3784] on 7 June 2019 at 3:27:40 am'! -!Random methodsFor: 'accessing' stamp: 'len 5/13/2019 10:04:43'! - nextBoolean - ^ (self nextBits: 1) = 1! ! -!Random methodsFor: 'accessing' stamp: 'len 6/7/2019 02:40:48' prior: 16897822! - nextBits: anInteger - "Answer a random integer in the interval [0, 2^anInteger - 1]" - - | toGo remainder answer | - anInteger < 0 ifTrue: [self error: 'invalid interval']. - remainder := anInteger \\ self nextChunkSize. - answer _ remainder > 0 - ifTrue: [self nextChunkBits bitShift: remainder - self nextChunkSize] - ifFalse: [0]. - toGo := anInteger - self nextChunkSize. - [toGo > 0] whileTrue: - [ - answer _ answer bitShift: self nextChunkSize :: bitXor: self nextChunkBits. - toGo _ toGo - self nextChunkSize - ]. - ^answer! ! -!Random methodsFor: 'accessing' stamp: 'len 6/7/2019 02:40:59' prior: 16897839! -nextInteger: anInteger - "Answer a random integer in the interval [1, anInteger]" - - | answer | - anInteger >= 1 ifFalse: [self error: 'invalid interval']. - [(answer _ self nextBits: anInteger highBit) >= anInteger] whileTrue. - ^ answer + 1! ! -!LaggedFibonacciRandom methodsFor: 'private' stamp: 'len 6/7/2019 03:23:02' prior: 16862087! - seed: anInteger - - | random | - random _ ParkMiller93Random seed: anInteger. - self initializeRingWith: random. - self last: 1! ! -!ParkMiller88Random methodsFor: 'private' stamp: 'len 6/6/2019 05:48:02' prior: 16884603! - seed: anInteger - seed _ anInteger - 1 \\ (self m - 1) truncated + 1. -" (seed between: 1 and: self m - 1) ifFalse: [self error: 'Seed out of range']"! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3786-MoreRandomFixes-LucianoEstebanNotarfrancesco-2019Jun07-02h37m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3785] on 7 June 2019 at 9:38:59 am'! -!Random methodsFor: 'accessing' stamp: 'HAW 6/7/2019 09:34:08' prior: 50462899! - nextBits: anInteger - "Answer a random integer in the interval [0, 2^anInteger - 1]" - - | toGo remainder answer | - - anInteger negative ifTrue: [self error: 'invalid interval']. - remainder := anInteger \\ self nextChunkSize. - answer _ remainder > 0 - ifTrue: [self nextChunkBits bitShift: remainder - self nextChunkSize] - ifFalse: [0]. - toGo := anInteger - self nextChunkSize. - [toGo > 0] whileTrue: - [ - answer _ answer bitShift: self nextChunkSize :: bitXor: self nextChunkBits. - toGo _ toGo - self nextChunkSize - ]. - ^answer! ! -!Random methodsFor: 'accessing' stamp: 'HAW 6/7/2019 09:37:25' prior: 50462918! - nextInteger: anInteger - "Answer a random integer in the interval [1, anInteger]" - - | answer | - - anInteger strictlyPositive ifFalse: [self error: 'invalid interval']. - [(answer _ self nextBits: anInteger highBit) >= anInteger] whileTrue. - - ^ answer + 1! ! -!ParkMiller88Random methodsFor: 'private' stamp: 'HAW 6/7/2019 09:33:01' prior: 50462936! - seed: anInteger - - seed _ anInteger - 1 \\ (self m - 1) truncated + 1. - ! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3786-RandomChanges-HernanWilkinson-2019Jun07-09h29m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3786] on 8 June 2019 at 6:28:48 pm'! -!String methodsFor: 'converting' stamp: 'HAW 6/8/2019 18:20:03'! - withoutSeparators - - ^self reject: [ :aCharacter | aCharacter isSeparator ]! ! -!TextEditor methodsFor: 'accessing-selection' stamp: 'HAW 6/8/2019 18:16:53'! - selectedString - - ^self selection string! ! -!TextEditor methodsFor: 'editing keys' stamp: 'HAW 6/8/2019 18:23:09' prior: 16931693! - changeLineEndsToLf: aKeyboardEvent - "Replace all CRs and CrLfs by LFs. - Triggered by Cmd-U -- useful when getting code from FTP sites" - "This is a user command, and generates undo" - - self replaceSelectionWith: self selectedString withCuisLineEndings. - ^ true! ! -!TextEditor methodsFor: 'editing keys' stamp: 'HAW 6/8/2019 18:23:30' prior: 16931770! - hiddenInfo - "In TextLinks, TextDoits, TextColor, and TextURLs, there is hidden info. Return the entire string that was used by Cmd-6 to create this text attribute. Usually enclosed in < >." - - | attrList | - attrList _ model actualContents attributesAt: (self pointIndex + self markIndex)//2. - attrList do: [:attr | - attr forTextActionInfoDo: [ :info | - ^ self selectedString, '<', info, '>']]. - "If none of the above" - attrList do: [:attr | - attr forTextColorDo: [ :color | - ^ self selectedString, '<', color printString, '>']]. - ^ self selectedString, '[No hidden info]'! ! -!TextEditor methodsFor: 'editing keys' stamp: 'HAW 6/8/2019 18:23:38' prior: 16931883! - makeCapitalized: aKeyboardEvent - "Force the current selection to uppercase. Triggered by Cmd-X." - "This is a user command, and generates undo" - - | prev | - prev _ $-. "not a letter" - self replaceSelectionWith: - (self selectedString collect: - [:c | prev _ prev isLetter ifTrue: [c asLowercase] ifFalse: [c asUppercase]]). - ^ true! ! -!TextEditor methodsFor: 'editing keys' stamp: 'HAW 6/8/2019 18:23:45' prior: 16931896! - makeLowercase: aKeyboardEvent - "Force the current selection to lowercase. Triggered by Cmd-X." - "This is a user command, and generates undo" - - self replaceSelectionWith: self selectedString asLowercase. - ^ true! ! -!TextEditor methodsFor: 'editing keys' stamp: 'HAW 6/8/2019 18:23:53' prior: 16931905! - makeUppercase: aKeyboardEvent - "Force the current selection to uppercase. Triggered by Cmd-Y." - "This is a user command, and generates undo" - - self replaceSelectionWith: self selectedString asUppercase. - ^ true! ! -!TextEditor methodsFor: 'menu messages' stamp: 'HAW 6/8/2019 18:24:07' prior: 16932192! - setSearchString - "Make the current selection, if any, be the current search string." - self hasSelection ifFalse: [morph flash. ^ self]. - self setSearch: self selectedString! ! -!TextEditor methodsFor: 'nonediting/nontyping keys' stamp: 'HAW 6/8/2019 18:24:13' prior: 16932375! - setSearchString: aKeyboardEvent - "Establish the current selection as the current search string." - - | aString | - self lineSelectAndEmptyCheck: [^ true]. - aString _ self selectedString. - aString size = 0 - ifTrue: [ self flash ] - ifFalse: [ self setSearch: aString ]. - ^ true! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'HAW 6/8/2019 18:21:46' prior: 16909761! - browseClassFromIt - "Launch a hierarchy browser for the class indicated by the current selection. If multiple classes matching the selection exist, let the user choose among them." - - | aClass | - self wordSelectAndEmptyCheck: [^ self]. - - aClass _ Utilities - classFromPattern: self selectedString withBlanksCondensed - withCaption: 'choose a class to browse...'. - aClass ifNil: [^ morph flash]. - - HierarchyBrowserWindow - onClass: aClass - selector: nil! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'HAW 6/8/2019 18:21:52' prior: 16909803! - classCommentsContainingIt - "Open a browser class comments which contain the current selection somewhere in them." - - self lineSelectAndEmptyCheck: [^ self]. - Smalltalk browseClassCommentsWithString: self selectedString! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'HAW 6/8/2019 18:22:28' prior: 16909813! - explain - "Try to shed some light on what kind of entity the current selection is. - The selection must be a single token or construct. Insert the answer after - the selection. Send private messages whose names begin with 'explain' - that return a string if they recognize the selection, else nil." - - | string tiVars cgVars selectors delimitors numbers sorry reply symbol provider | - sorry _ 'Sorry, I can''t explain that. Please select a single -token, construct, or special character.'. - (string _ self selectedString) isEmpty - ifTrue: [reply _ ''] - ifFalse: [ - string _ string withBlanksTrimmed. - "Remove space, tab, cr" - "Temps and Instance vars need only test strings that are all letters" - (string detect: [:char | char isValidInIdentifiers not] - ifNone: nil) ifNil: [ - tiVars _ (self explainTemp: string) - ifNil: [self explainInst: string]]. - - provider _ self codeProvider. - (tiVars == nil and: [provider respondsTo: #explainSpecial:]) - ifTrue: [tiVars _ provider explainSpecial: string]. - tiVars _ tiVars - ifNil: [ ''] - ifNotNil: [ tiVars , '\' withNewLines]. - "Context, Class, Pool, and Global vars, and Selectors need - only test symbols" - (Symbol hasInterned: string ifTrue: [:s | symbol _ s]) - ifTrue: [ - cgVars _ (self explainCtxt: symbol) - ifNil: [ (self explainClass: symbol) - ifNil: [ self explainGlobal: symbol]]. - "See if it is a Selector (sent here or not)" - selectors _ (self explainMySel: symbol) - ifNil: [(self explainPartSel: string) - ifNil: [ self explainAnySel: symbol]]] - ifFalse: [selectors _ self explainPartSel: string]. - cgVars _ cgVars - ifNil: [ ''] - ifNotNil: [cgVars , '\' withNewLines]. - selectors _ selectors - ifNil: [ ''] - ifNotNil: [ selectors , '\' withNewLines]. - delimitors _ string size = 1 - ifTrue: ["single special characters" - self explainChar: string] - ifFalse: ["matched delimitors" - self explainDelimitor: string]. - numbers _ self explainNumber: string. - numbers ifNil: [numbers _ '']. - delimitors ifNil: [delimitors _ '']. - reply _ tiVars , cgVars , selectors , delimitors , numbers]. - reply size = 0 ifTrue: [reply _ sorry]. - - morph showBalloon: reply. - self runningWorld ifNotNil: [ :w | w findATranscript ]. - reply print! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'HAW 6/8/2019 18:22:40' prior: 16909914! - methodSourceContainingIt - "Open a browser on methods which contain the current selection in their source (case-sensitive full-text search of source). Slow!!" - - self lineSelectAndEmptyCheck: [^ self]. - Smalltalk browseMethodsWithSourceString: self selectedString! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'HAW 6/8/2019 18:22:47' prior: 16909925! - methodStringsContainingit - "Open a browser on methods which contain the current selection as part of a string constant." - - self lineSelectAndEmptyCheck: [^ self]. - Smalltalk browseMethodsWithString: self selectedString! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'HAW 6/8/2019 18:25:03' prior: 50461693! - referencesToIt - "Open a references browser on the selected symbol: a variable name or class name" - - | selectedString provider environment | - - "look for exactly a whole word" - self selectWord. - selectedString _ self selectedString withoutSeparators. - - "convenient access to class variables, including those in SharedPools" - provider _ self codeProvider. - environment _ (provider respondsTo: #selectedClassOrMetaClass) ifTrue: [ provider selectedClassOrMetaClass ]. - environment _ environment ifNil: [ Smalltalk ]. - - (environment bindingOf: selectedString) - ifNotNil: [ :reference | Smalltalk browseAllCallsOn: reference ] - ifNil: [ (environment ~= Smalltalk and: [ environment definesInstanceVariableNamedInHierarchy: selectedString ]) - ifTrue: [ Smalltalk browseAllAccessesTo: selectedString from: environment ] - ifFalse: [ morph flash ]] - - - ! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'HAW 6/8/2019 18:22:55' prior: 16909957! - selectedSelector - "Try to make a selector out of the current text selection" - - ^ self selectedString findSelector! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'HAW 6/8/2019 18:20:31' prior: 16909964! - selectedSymbol - "Return the currently selected symbol, or nil if none. Spaces, tabs and returns are ignored" - - | aString | - self hasSelection ifFalse: [^ nil]. - aString _ self selectedString withoutSeparators. - aString size = 0 ifTrue: [^ nil]. - Symbol hasInterned: aString ifTrue: [:sym | ^ sym]. - - ^ nil! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3787-ReferencesToItFixStringWithoutSeparators-HernanWilkinson-2019Jun08-18h16m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3786] on 7 June 2019 at 5:12:13 pm'! -!TextModel methodsFor: 'undoable commands' stamp: 'EB 6/7/2019 17:02:49'! - logUndoAndReplaceFrom: start to: stop with: replacement shouldMergeCommandsIfPossible: shouldMergeCommands - "As requested." - - | command now | - "Time millisecondClockValue rolls over and is generally not adviced. - But here, we don't care. A user edit doing during rollover would be split in two, as if the user did a pause. - Not a problem." - - now _ Time millisecondClockValue. - command _ self commandForReplaceFrom: start to: stop with: replacement. - (shouldMergeCommands and: [ - stop+1 = start and: [ lastEditTimeStamp notNil and: [ now - lastEditTimeStamp < 1000 and: [start = undoRedoCommands last stopPosition] ]]]) - ifTrue: [ - "Don't use the command we just built" - undoRedoCommands last appendToNew: replacement - ] - ifFalse: [ - undoRedoCommands - nextPut: command; - truncateAtPosition. "To disable redo of previous commands, now invalidated." - ]. - command doOn: self. - lastEditTimeStamp _ now! ! -!TextEditor methodsFor: 'accessing' stamp: 'EB 6/7/2019 17:04:15'! - replaceSelectionWith: aTextOrString shouldMergeCommandsIfPossible: shouldMergeCommands - "Deselect, and replace the selection text by aText." - "This is a user command, and generates undo" - - | start stop replacement | - - morph disablesEditing ifTrue: [ - ^ self ]. - - start _ self startIndex. - stop _ self stopIndex. - (aTextOrString isEmpty and: [stop > start]) ifTrue: [ - "If deleting, then set emphasisHere from 1st character of the deletion" - emphasisHere _ (model actualContents attributesAt: start) select: [:att | - att mayBeExtended]]. - - (start = stop and: [ aTextOrString isEmpty ]) ifFalse: [ - replacement _ self addAttributesForPasting: aTextOrString. - model logUndoAndReplaceFrom: start to: stop - 1 with: replacement shouldMergeCommandsIfPossible: shouldMergeCommands. - textComposition - recomposeFrom: start - to: start + replacement size - 1 - delta: replacement size - (stop-start). - self deselectAndPlaceCursorAt: start + replacement size. - selectionStartBlocks _ #(). - selectionStopBlocks _ #(). - self userHasEdited " -- note text now dirty" ]. - - morph possiblyChanged! ! -!TextEditor methodsFor: 'new selection' stamp: 'EB 6/7/2019 16:55:51'! - insertAndSelect: aString at: anInteger shouldMergeCommandsIfPossible: shouldMergeCommands - "This is a user command, and generates undo" - - | newText | - newText _ (aString is: #Text) ifTrue: [aString] ifFalse: [Text string: aString attributes: emphasisHere]. - self deselectAndPlaceCursorAt: anInteger. - self replaceSelectionWith: newText shouldMergeCommandsIfPossible: shouldMergeCommands. - self selectFrom: anInteger to: anInteger + newText size - 1! ! -!TextModel methodsFor: 'undoable commands' stamp: 'EB 6/7/2019 17:03:26' prior: 50462859! - logUndoAndReplaceFrom: start to: stop with: replacement - "As requested." - self logUndoAndReplaceFrom: start to: stop with: replacement shouldMergeCommandsIfPossible: true.! ! -!TextEditor methodsFor: 'accessing' stamp: 'EB 6/7/2019 17:03:59' prior: 50369362! - replaceSelectionWith: aTextOrString - "Deselect, and replace the selection text by aText." - "This is a user command, and generates undo" - self replaceSelectionWith: aTextOrString shouldMergeCommandsIfPossible: true.! ! -!TextEditor methodsFor: 'new selection' stamp: 'EB 6/7/2019 17:05:33' prior: 16932257! - insertAndSelect: aString at: anInteger - "This is a user command, and generates undo" - self insertAndSelect: aString at: anInteger shouldMergeCommandsIfPossible: true.! ! -!SmalltalkEditor methodsFor: 'new selection' stamp: 'EB 6/7/2019 17:07:30' prior: 16910549! - notify: aString at: anInteger in: aStream - "The compilation of text failed. The syntax error is noted as the argument, - aString. Insert it in the text at starting character position anInteger." - "This is a user command, and generates undo" - self insertAndSelect: aString at: (anInteger max: 1) shouldMergeCommandsIfPossible: false.! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3788-UndoSyntaxErrorsSeparately-EricBrandwein-2019Jun07-16h45m-EB.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3777] on 9 June 2019 at 10:04:40 pm'! -!MorphicCanvas methodsFor: 'drawing' stamp: 'pb 5/31/2019 19:35:57'! - line: pt1 to: pt2 width: wp color: c - self subclassResponsibility ! ! -!MorphicCanvas methodsFor: 'drawing-icons' stamp: 'pb 5/31/2019 19:45:10'! - drawButtonIconFromCurrentMorph - self subclassResponsibility ! ! -!MorphicCanvas methodsFor: 'drawing-images' stamp: 'pb 5/31/2019 19:39:09'! - image: aForm at: aPoint - self subclassResponsibility ! ! -!MorphicCanvas methodsFor: 'drawing-images' stamp: 'pb 5/31/2019 19:39:29'! - image: aForm at: aPoint sourceRect: sourceRect - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-images' stamp: 'pb 5/31/2019 19:39:52'! - image: aForm multipliedBy: aColor at: aPoint - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-images' stamp: 'pb 5/31/2019 19:40:07'! - stencil: stencilForm at: aPoint color: aColor - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-images' stamp: 'pb 5/31/2019 19:40:17'! - stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-ovals' stamp: 'pb 5/31/2019 19:34:51'! - ellipseCenterX: mcx y: mcy rx: mrx ry: mry borderWidth: mbw borderColor: mbc fillColor: morphFillColor - self subclassResponsibility ! ! -!MorphicCanvas methodsFor: 'drawing-rectangles' stamp: 'pb 5/31/2019 19:41:12'! - fillRectangle: aRectangle color: aColor - self subclassResponsibility ! ! -!MorphicCanvas methodsFor: 'drawing-rectangles' stamp: 'pb 5/31/2019 19:41:22'! - fillRectangle: aRectangle color: aColor borderWidth: borderWidth borderStyleSymbol: aSymbol baseColorForBorder: baseColorForBorder - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-rectangles' stamp: 'pb 5/31/2019 19:41:31'! - fillRectangle: aRectangle tilingWith: aForm multipliedBy: aColor - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-rectangles' stamp: 'pb 5/31/2019 19:41:47'! - frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor - self subclassResponsibility ! ! -!MorphicCanvas methodsFor: 'drawing-rectangles' stamp: 'pb 5/31/2019 19:42:05'! - frameRectangle: r borderWidth: borderWidth color: borderColor - self subclassResponsibility ! ! -!MorphicCanvas methodsFor: 'drawing-rectangles' stamp: 'pb 5/31/2019 19:42:23'! - frameRectangle: r color: aColor borderWidth: borderWidth borderStyleSymbol: aSymbol - self subclassResponsibility ! ! -!MorphicCanvas methodsFor: 'drawing-rectangles' stamp: 'pb 5/31/2019 19:42:33'! - reverseRectangleBorder: r borderWidth: borderWidth - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-roundedRectangles' stamp: 'pb 5/31/2019 19:43:02'! - roundRect: aRectangle color: aColor radius: r - self subclassResponsibility ! ! -!MorphicCanvas methodsFor: 'drawing-roundedRectangles' stamp: 'pb 5/31/2019 19:43:12'! - roundRect: displayRectangle color: aColor radius: r gradientTop: topFactor gradientBottom: bottomFactor gradientHeight: h - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-roundedRectangles' stamp: 'pb 5/31/2019 19:43:22'! - roundRect: aRectangle color: aColor radius: r gradientTop: topFactor gradientCenter: centerFactor gradientBottom: bottomFactor gradient1Height: h1 - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-roundedRectangles' stamp: 'pb 5/31/2019 19:43:31'! - windowFrame: aRectangle color: aColor radius: r border: bw labelHeight: lh gradientTop: topFactor gradientBottom: bottomFactor insideColor: insideColor - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'pb 5/31/2019 19:38:04'! - drawString: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - self subclassResponsibility ! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'pb 5/31/2019 19:49:08'! - clippingRectForCurrentMorph - "In form coordinates" - "En M3, es el obtenido al dibujarlo, recien. -Dejar eso claro en el nombre. Eliminar 'clipping'" - ^ currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds.! ! -!MorphicCanvas methodsFor: 'testing' stamp: 'pb 5/31/2019 19:50:24'! - isCurrentMorphVisible - | aRectangle | - currentMorph visible ifFalse: [ ^ false ]. - aRectangle _ currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds. - "Optimization" - aRectangle right < clipLeft ifTrue: [ ^ false ]. - aRectangle left > (clipRight + 1) ifTrue: [ ^ false ]. - aRectangle bottom < clipTop ifTrue: [ ^ false ]. - aRectangle top > (clipBottom + 1) ifTrue: [ ^ false ]. - ^ true.! ! -!MorphicCanvas methodsFor: 'private' stamp: 'pb 5/31/2019 19:32:16'! - setForm: aForm - form _ aForm.! ! -!BitBltCanvas methodsFor: 'private' stamp: 'pb 5/31/2019 19:32:31' prior: 16787141! - setForm: aForm - super setForm: aForm. - self resetGrafPort. - self newClipRect: nil.! ! - -BitBltCanvas removeSelector: #clippingRectForCurrentMorph! - -BitBltCanvas removeSelector: #clippingRectForCurrentMorph! - -BitBltCanvas removeSelector: #isCurrentMorphVisible! - -BitBltCanvas removeSelector: #isCurrentMorphVisible! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3789-CanvasCleanup-PhilBellalouna-2019May31-19h32m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3789] on 10 June 2019 at 10:59:02 am'! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 6/10/2019 10:39:02'! - clippingRectForCurrentMorph - "In form coordinates" - - ^currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds! ! -!BitBltCanvas methodsFor: 'testing' stamp: 'jmv 6/10/2019 10:47:56'! - isCurrentMorphVisible - - | aRectangle | - currentMorph visible ifFalse: [ ^false ]. - aRectangle _ self clippingRectForCurrentMorph. - "Optimization" - aRectangle right < clipLeft ifTrue: [^ false]. - aRectangle left > (clipRight+1) ifTrue: [^ false]. - aRectangle bottom < clipTop ifTrue: [^ false]. - aRectangle top > (clipBottom+1) ifTrue: [^ false]. - ^ true -! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 6/10/2019 10:53:51' prior: 16875248! - externalizeDisplayBounds: r - - | inOwners | - "All senders of #displayBoundsOfTransformOf: should be rethought..." - self flag: #jmvVer2. - - inOwners _ location displayBoundsOfTransformOf: r. - ^owner - ifNotNil: [ owner externalizeDisplayBounds: inOwners ] - ifNil: [ inOwners ]! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 6/10/2019 10:44:13' prior: 50463536! - clippingRectForCurrentMorph - "This only works reasonably with BitBltCanvas (where submorph clipping is only about Rectangles (aligned with target form pixel grille). - For submorph cliping in VectorCanvas we use #currentOwnerIfClips:, and this 'clippingRect' is just an optimization of the area to be redrawn. - So, we need a better name than #clippingRectForCurrentMorph" - self revisar. - self subclassResponsibility! ! -!MorphicCanvas methodsFor: 'testing' stamp: 'jmv 6/10/2019 10:34:59' prior: 50463546! - isCurrentMorphVisible - self subclassResponsibility! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3790-CanvasTweaks-JuanVuletich-2019Jun10-10h57m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3771] on 26 May 2019 at 7:38:33 am'! -!IndentingListItemMorph methodsFor: 'events' stamp: 'len 5/26/2019 05:08:15'! - mouseEnter: event - isHighlighted _ true. - self redrawNeeded. - ^super mouseEnter: event! ! -!IndentingListItemMorph methodsFor: 'events' stamp: 'len 5/26/2019 05:08:59'! - mouseLeave: event - isHighlighted _ false. - self redrawNeeded. - ^super mouseEnter: event! ! -!IndentingListItemMorph methodsFor: 'event handling testing' stamp: 'len 5/26/2019 05:12:45'! - handlesMouseOver: event - ^ true! ! -!IndentingListItemMorph methodsFor: 'drawing' stamp: 'len 5/26/2019 07:35:54' prior: 50385181! - drawOn: aCanvas - - | tRect colorToUse sLeft aForm centeringOffset | - isHighlighted ifTrue: [ - aCanvas - fillRectangle: (`0@0` extent: extent) - color: ((Theme current - listHighlightFocused: owner owner hasKeyboardFocus) alpha: 0.3) ]. - isSelected ifTrue: [ - aCanvas - fillRectangle: (`0@0` extent: extent) - color: (Theme current - listHighlightFocused: owner owner hasKeyboardFocus) ]. - - tRect _ self toggleRectangle. - aForm _ isExpanded - ifTrue: [ container expandedForm ] - ifFalse: [ container notExpandedForm ]. - centeringOffset _ ((tRect height - aForm extent y) / 2.0) rounded. - - complexContents hasContents ifTrue: [ - aCanvas - image: aForm - at: (tRect topLeft translatedBy: 0 @ centeringOffset) ]. - - icon isNil - ifFalse: [ - aCanvas - image: icon - at: (tRect topLeft translatedBy: icon width @ centeringOffset). - sLeft _ indentLevel * 12 + 16 + (icon width + 2). - ] - ifTrue: [ - sLeft _ indentLevel * 12 + 16. - ]. - colorToUse _ complexContents preferredColor ifNil: [ color ]. - - aCanvas - drawString: contents asString - at: sLeft@0 - font: self fontToUse - color: colorToUse! ! -!InnerListMorph methodsFor: 'drawing' stamp: 'len 5/26/2019 07:34:30' prior: 50385658! - drawHighlightOn: aCanvas -"Ademas, poner el mouse pointer de relojito si tarda... Detectarlo automaticamente, etc. Aunque no estoy seguro de como hacerlo... quizas colgar un cachito de codigo en un proceso de mayor prioridad, onda 'si pasa 1 segundo, y todavia no te resetee este flag, entonces pone el relojito'" - | selectionDrawBounds | - highlightedRow ifNil: [ ^self ]. - highlightedRow = 0 ifTrue: [ ^self ]. - selectionDrawBounds _ self drawBoundsForRow: highlightedRow. - selectionDrawBounds _ selectionDrawBounds intersect: (`0@0` extent: extent). - aCanvas - fillRectangle: selectionDrawBounds - color: ((Theme current listHighlightFocused: owner hasKeyboardFocus) alpha: 0.3)! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3791-MouseOverHighlightImprovements-LucianoEstebanNotarfrancesco-2019May26-07h31m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3791] on 11 June 2019 at 11:07:45 am'! -!Character methodsFor: 'accessing' stamp: 'jmv 6/11/2019 11:04:59'! - codePointOfGlyphToUse - " - For certain ASCII characters, we prefer a non ASCII Unicode glyph if available (i.e. with TrueType fonts). - $* codePoint hex - $* codePointOfGlyphToUse hex - " - self = $- ifTrue: [ ^16r2212 ]. "WIDE MINUS" - self = $* ifTrue: [ ^16r2217 ]. "CENTERED ASTERISK" - ^ self codePoint! ! -!Character class methodsFor: 'class initialization' stamp: 'jmv 6/11/2019 11:05:22' prior: 50457834! - initialize - "Create the table of unique Characters. - Character initialize - " - self initializeLookupTables. - self initializeUnicodeCodePoints.! ! -!Character class methodsFor: 'class initialization' stamp: 'jmv 6/11/2019 11:05:16' prior: 50458288! - initializeUnicodeCodePoints - " - Character initializeUnicodeCodePoints - String streamContents: [ :strm | 28 to: 255 do: [ :i | strm nextPut: (Character numericValue: i) ]] - " - - "Initialize the table of Unicode code points" - UnicodeCodePoints _ Array new: 256. - 0 to: 255 do: [ :code | - UnicodeCodePoints at: code + 1 put: code ]. - - "Arrows" - UnicodeCodePoints at: 28+1 put: 8592. "left arrow" - UnicodeCodePoints at: 29+1 put: 8594. "right arrow" - UnicodeCodePoints at: 30+1 put: 8593. "up arrow" - UnicodeCodePoints at: 31+1 put: 8595. "down arrow" - - "The following codes are different in ISO 8859-15 from those in ISO 8859-1, - so the character code is not equal to the Unicode code point" - UnicodeCodePoints at: 16rA4+1 put: 16r20AC. "euro sign" - UnicodeCodePoints at: 16rA6+1 put: 16r160. "latin capital letter S with caron" - UnicodeCodePoints at: 16rA8+1 put: 16r161. "latin small letter s with caron" - UnicodeCodePoints at: 16rB4+1 put: 16r17D. "latin capital letter Z with caron" - UnicodeCodePoints at: 16rB8+1 put: 16r17E. "latin small letter z with caron" - UnicodeCodePoints at: 16rBC+1 put: 16r152. "latin capital ligature OE" - UnicodeCodePoints at: 16rBD+1 put: 16r153. "latin small ligature oe" - UnicodeCodePoints at: 16rBE+1 put: 16r178. "latin capital letter Y with diaeresis" - - UnicodeCodePoints at: 16r80+1 put: 16r2205. "EMPTY SET" - UnicodeCodePoints at: 16r81+1 put: 16r221E. "INFINITY" - UnicodeCodePoints at: 16r82+1 put: 16r2135. "ALEF SYMBOL" - UnicodeCodePoints at: 16r83+1 put: 16r03C0. "pi" - UnicodeCodePoints at: 16r84+1 put: 16r03B5. "epsilon" - UnicodeCodePoints at: 16r85+1 put: 16r03B6. "zeta" - UnicodeCodePoints at: 16r86+1 put: 16r0394. "Delta" - UnicodeCodePoints at: 16r87+1 put: 16r03A9. "Omega" - UnicodeCodePoints at: 16r88+1 put: 16r2102. "DOUBLE-STRUCK CAPITAL C" - UnicodeCodePoints at: 16r89+1 put: 16r210D. "DOUBLE-STRUCK CAPITAL H" - UnicodeCodePoints at: 16r8A+1 put: 16r2115. "DOUBLE-STRUCK CAPITAL N" - UnicodeCodePoints at: 16r8B+1 put: 16r2119. "DOUBLE-STRUCK CAPITAL P" - UnicodeCodePoints at: 16r8C+1 put: 16r211A. "DOUBLE-STRUCK CAPITAL Q" - UnicodeCodePoints at: 16r8D+1 put: 16r211D. "DOUBLE-STRUCK CAPITAL R" - UnicodeCodePoints at: 16r8E+1 put: 16r2124. "DOUBLE-STRUCK CAPITAL Z" - UnicodeCodePoints at: 16r8F+1 put: 16r0046. "DOUBLE-STRUCK CAPITAL F" "should be 1D53D, index out of bounds" - UnicodeCodePoints at: 16r90+1 put: 16r2295. "OPLUS" - UnicodeCodePoints at: 16r91+1 put: 16r2297. "OTIMES" - UnicodeCodePoints at: 16r92+1 put: 16r2299. "ODOT" - UnicodeCodePoints at: 16r93+1 put: 16r2296. "OMINUS" - UnicodeCodePoints at: 16r94+1 put: 16r2217. "ASTERISK OPERATOR" - UnicodeCodePoints at: 16r95+1 put: 16r2218. "RING OPERATOR (circ)" - UnicodeCodePoints at: 16r96+1 put: 16r2219. "BULLET OPERATOR (filled circ)" - UnicodeCodePoints at: 16r97+1 put: 16r22C5. "DOT OPERATOR" "(already at B7)" - UnicodeCodePoints at: 16r98+1 put: 16r22C6. "STAR OPERATOR" - UnicodeCodePoints at: 16r99+1 put: 16r21A0. "SURJECTIVE ARROW" - UnicodeCodePoints at: 16r9A+1 put: 16r21A3. "INJECTIVE ARROW" - UnicodeCodePoints at: 16r9B+1 put: 16r2194. "BIJECTIVE ARROW" - UnicodeCodePoints at: 16r9C+1 put: 16r21AA. "INCLUSION ARROW" - UnicodeCodePoints at: 16r9D+1 put: 16r21A6. "MAPPING ARROW" - UnicodeCodePoints at: 16r9E+1 put: 16r2202. "PARTIAL DIFFERENTIAL" - UnicodeCodePoints at: 16r9F+1 put: 16r221A. "SQUARE ROOT" - - "Additionally, see #codePointOfGlyphToUse"! ! - -Character initialize! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3792-TrueTypeGlyphsTweak-JuanVuletich-2019Jun11-10h49m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3791] on 11 June 2019 at 11:56:29 am'! -!Number methodsFor: 'comparing' stamp: 'jmv 6/11/2019 11:41:36'! - = aNumber - "Note: Consistency between #= and #hash for numeric classes is not done in the usual way (redefining them together), because we also need #= and #hash consistency across numeric classes: - (3 = 3.0) ifTrue: [3 hash = 3.0 hash] - Therefore, consistency between #= and #hash for numeric classes is validated by specific tests" - - ^self subclassResponsibility! ! -!Number methodsFor: 'comparing' stamp: 'jmv 6/11/2019 11:41:27'! - hash - "Note: Consistency between #= and #hash for numeric classes is not done in the usual way (redefining them together), because we also need #= and #hash consistency across numeric classes: - (3 = 3.0) ifTrue: [3 hash = 3.0 hash] - Therefore, consistency between #= and #hash for numeric classes is validated by specific tests" - - ^self subclassResponsibility! ! -!TextDoIt methodsFor: 'comparing' stamp: 'jmv 6/11/2019 11:43:43'! - hash - "Hash is reimplemented because = is implemented." - - ^evalString hash! ! -!TextURL methodsFor: 'comparing' stamp: 'jmv 6/11/2019 11:43:54'! - hash - "Hash is reimplemented because = is implemented." - - ^url hash! ! -!TextAnchor methodsFor: 'comparing' stamp: 'jmv 6/11/2019 11:44:13'! - hash - "Hash is reimplemented because = is implemented." - - ^anchoredFormOrMorph hash! ! -!FeatureRequirement methodsFor: 'comparing' stamp: 'jmv 6/11/2019 11:45:31'! - hash - "Hash is reimplemented because = is implemented." - - ^name hash! ! -!CharacterBlock methodsFor: 'comparing' stamp: 'jmv 6/11/2019 11:42:38'! - hash - "Hash is reimplemented because = is implemented." - - ^stringIndex hash! ! -!MouseScrollEvent methodsFor: 'comparing' stamp: 'jmv 6/11/2019 11:54:11'! - = aMorphicEvent - - "Any object is equal to itself" - self == aMorphicEvent ifTrue: [ ^ true ]. - - self class == aMorphicEvent class ifFalse: [ ^ false ]. - - position = aMorphicEvent eventPosition ifFalse: [ ^ false ]. - buttons = aMorphicEvent buttons ifFalse: [ ^ false ]. - direction = aMorphicEvent direction ifFalse: [ ^ false ]. - ^ true! ! - -MorphicEvent removeSelector: #hash! - -MorphicEvent removeSelector: #hash! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3793-hashCleanup-JuanVuletich-2019Jun11-11h16m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3793] on 11 June 2019 at 2:07:48 pm'! -!Character methodsFor: 'testing' stamp: 'jmv 6/11/2019 12:14:09'! - is: aSymbol - ^ aSymbol == #Character or: [ super is: aSymbol ]! ! -!String methodsFor: 'enumerating' stamp: 'jmv 6/11/2019 12:23:44'! - collect: aBlock - "Refer to the comment in Collection|collect:." - | result value stillAString | - result _ self species new: self size. - stillAString _ true. - 1 to: self size do: [ :index | - value _ aBlock value: (self at: index). - (stillAString and: [ (value is: #Character) not]) ifTrue: [ - result _ result asArray. - stillAString _ false ]. - result at: index put: value]. - ^ result! ! -!Collection methodsFor: 'private' stamp: 'jmv 6/11/2019 12:08:53' prior: 16814664! - species - "Answer the preferred class for reconstructing the receiver. For example, - collections create new collections whenever enumeration messages such as - collect: or select: are invoked. The new kind of collection is determined by - the species of the original collection. Species and class are not always the - same. For example, the species of Interval is Array." - "Redefined here just for reference. See inheritance. - #collect: avoids using #species in String, when there are non-Character objects - #select: and #copy avoid using it in SortedCollection" - - ^ self class! ! -!String methodsFor: 'accessing' stamp: 'jmv 6/11/2019 12:14:25' prior: 16915413! - 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." - - - (aCharacter is: #Character) - ifTrue: [ - index isInteger - ifTrue: [self errorSubscriptBounds: index] - ifFalse: [self errorNonIntegerIndex]] - ifFalse: [self error: 'Strings only store Characters']! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3794-String-collect-enhancements-JuanVuletich-2019Jun11-14h06m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3793] on 11 June 2019 at 2:08:54 pm'! -!Semaphore methodsFor: 'private' stamp: 'jmv 6/11/2019 12:31:53'! - species - "So we are never equal an Array" - - ^ self class! ! -!RunArray methodsFor: 'accessing' stamp: 'jmv 6/11/2019 12:34:02' prior: 16901152! - = otherArray - self == otherArray ifTrue: [ ^ true ]. - - self species == otherArray species ifFalse: [^ false]. - - "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]! ! -!Dictionary methodsFor: 'testing' stamp: 'jmv 6/11/2019 12:41:01' prior: 16833502! - is: aSymbol - "Dictionaries and Sets have different #species. So, aDictionary is: #Set should be false." - aSymbol == #Set ifTrue: [ ^ false ]. - ^aSymbol == #Dictionary or: [ super is: aSymbol ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3795-Collections-equality-fixes-JuanVuletich-2019Jun11-14h07m-jmv.1.cs.st----! - -----SNAPSHOT----(11 June 2019 14:15:46) Cuis5.0-3795-32.image priorSource: 4198206! - -----QUIT----(11 June 2019 14:16:11) Cuis5.0-3795-32.image priorSource: 4236798! - -----STARTUP---- (12 July 2019 10:25:56) as /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/Cuis5.0-3795-32.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3795] on 11 June 2019 at 8:54:49 pm'! -!SequenceableCollection methodsFor: 'comparing' stamp: 'jmv 6/11/2019 18:53:56'! - hashQuick - | hash size step | - - size _ self size. - hash _ (self species hash + size hash) hashMultiply. - step _ size < 64 ifTrue: [1] ifFalse: [size//64]. - 1 to: size by: step do: [ :i | | elem | - elem _ self at: i. - elem == self ifFalse: [ - hash _ (hash + elem hash) hashMultiply]]. - ^hash! ! -!FloatArray methodsFor: 'comparing' stamp: 'jmv 6/11/2019 16:12:42'! - hashFull - | hash | - - hash _ (self species hash + self size hash) hashMultiply. - 1 to: self size do: [:i | hash _ (hash + (self basicAt: i)) hashMultiply]. - ^hash! ! -!Association methodsFor: 'comparing' stamp: 'jmv 6/11/2019 18:22:00' prior: 16780999! - hash - "Hash is reimplemented because = is implemented." - - value == self ifTrue: [ ^ key hash ]. - ^key hash bitXor: value hash.! ! -!Collection methodsFor: 'comparing' stamp: 'jmv 6/11/2019 19:07:39' prior: 16814019! - hash - "A default hash function for any collection. Note that this method only considers a few elements so you might want to refine this behavior." - - | size hash count | - size _ self size. - hash _ self species hash bitXor: size hash. - count _ 0. - self do: [ :elem | - elem == self ifFalse: [ - hash _ hash bitXor: elem hash. - count _ count + 1. - count =64 ifTrue: [ - ^ hash]]]. - ^ hash! ! -!SequenceableCollection methodsFor: 'comparing' stamp: 'jmv 6/11/2019 16:08:53' prior: 16906036! - hash - "Subclasses might use other methods. - However #hashQuick is suggested for very large collections." - ^ self hashQuick! ! -!String methodsFor: 'comparing' stamp: 'jmv 6/11/2019 16:23:20' prior: 16915822! - = aString - "Answer whether the receiver sorts equally as aString. - This means same characters in same order." - - "Any object is equal to itself" - self == aString ifTrue: [ ^ true ]. - - "If argument is not a String or Symbol, maybe it is a Text?" - aString species == String ifFalse: [ - (aString is: #Text) ifTrue: [ ^ self = aString string ]. - ^ false]. - - self size = aString size ifFalse: [ - ^false ]. - - self size > 256 ifTrue: [ - self hashQuick = aString hashQuick ifFalse: [ ^false ]]. - - ^ (self compare: self with: aString collated: CaseSensitiveOrder) = 2! ! -!String methodsFor: 'comparing' stamp: 'jmv 6/11/2019 16:13:53' prior: 16916053! - hash - "#hash is implemented, because #= is implemented" - self size > 256 ifTrue: [ ^ self hashQuick ]. - ^ByteArray - hashBytes: self - startingWith: self species hash! ! -!ByteArray methodsFor: 'comparing' stamp: 'jmv 6/11/2019 16:09:49' prior: 16793826! - hash - "#hash is implemented, because #= is implemented" - self size > 256 ifTrue: [ ^ self hashQuick ]. - ^self class - hashBytes: self - startingWith: self species hash! ! -!FloatArray methodsFor: 'comparing' stamp: 'jmv 6/11/2019 16:22:31' prior: 50348241! -= another - self == another ifTrue: [ ^ true ]. - self class == another class ifFalse: [ ^ false ]. - self size > 256 ifTrue: [ - self hashQuick = another hashQuick ifFalse: [ ^false ]]. - ^self primitiveEqual: another! ! -!FloatArray methodsFor: 'comparing' stamp: 'jmv 6/11/2019 16:10:44' prior: 16846547! - hash - self size > 256 ifTrue: [ ^ self hashQuick ]. - ^ self hashFull! ! -!Set methodsFor: 'testing' stamp: 'jmv 6/11/2019 18:46:53' prior: 16907334! - = aSet - - self == aSet ifTrue: [^ true]. "Any object is equal to itself" - self species == aSet species ifFalse: [^ false]. - self size = aSet size ifFalse: [^ false]. - self do: [ :each | (aSet includes: each) ifFalse: [^ false]]. - ^ true! ! -!Dictionary methodsFor: 'testing' stamp: 'jmv 7/4/2016 22:13' prior: 50464037! - is: aSymbol - ^aSymbol == #Dictionary or: [ super is: aSymbol ]! ! -!Dictionary methodsFor: 'comparing' stamp: 'jmv 6/11/2019 18:47:15' prior: 16833837! - = 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]. "Any object is equal to itself" - self species == aDictionary species ifFalse: [^ false]. - self size = aDictionary size ifFalse: [^false]. - self associationsDo: [:assoc| - (aDictionary at: assoc key ifAbsent: [^false]) = assoc value - ifFalse: [^false]]. - ^true - -! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3796-AdditionalHashAndEqualityEnhancements-JuanVuletich-2019Jun11-20h52m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3796] on 11 June 2019 at 9:19:18 pm'! -!Association methodsFor: 'comparing' stamp: 'jmv 6/11/2019 21:18:46' prior: 50464085! - hash - "Hash is reimplemented because = is implemented." - - ^ key hash! ! -!Collection methodsFor: 'comparing' stamp: 'di 12/14/1999 07:45' prior: 50464092! - hash - "A default hash function for any collection. Note that this method is insensitive to contents when the size is greater than 10, so critical applications that compare many large collections of the same length will want to refine this behavior." - - | hash | - hash _ self species hash. - self size <= 10 ifTrue: - [self do: [:elem | hash _ hash bitXor: elem hash]]. - ^ hash bitXor: self size hash -! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3797-Collection-hash-rollBack-Association-hash-dontRecurse-JuanVuletich-2019Jun11-21h15m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3797] on 11 June 2019 at 10:14:24 pm'! -!Dictionary methodsFor: 'comparing' stamp: 'jmv 6/11/2019 22:13:22'! - hash - "Note that this method is insensitive to contents when the size is greater than 10, so critical applications that compare many large collections of the same length will want to refine this behavior." - - | hash | - hash _ self species hash. - self size <= 10 ifTrue: [ - self associationsDo: [ :association | hash _ hash bitXor: association hash ]]. - ^ hash bitXor: self size hash! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3798-Dictionary-hash-JuanVuletich-2019Jun11-22h11m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3798] on 12 June 2019 at 9:19:25 am'! -!ParseNode methodsFor: 'testing' stamp: 'jmv 6/12/2019 09:17:45'! - isSuperPseudoVariable - "Overridden in VariableNode." - ^false! ! -!VariableNode methodsFor: 'testing' stamp: 'jmv 6/12/2019 09:17:53'! - isSuperPseudoVariable - "Answer if this ParseNode represents the 'self' pseudo-variable." - - ^ key = 'super' or: [name = '{{super}}']! ! -!MessageNode methodsFor: 'private' stamp: 'jmv 6/12/2019 09:18:46' prior: 16868602! - pvtCheckForPvtSelector: encoder - "If the code being compiled is trying to send a private message (e.g. 'pvtCheckForPvtSelector:') to anyone other than self, then complain to encoder." - - selector isPvtSelector ifTrue: [ - (receiver isSelfPseudoVariable or: [ receiver isSuperPseudoVariable ]) ifFalse: [ - encoder notify: 'Private messages may only be sent to self or super']].! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3799-AllowSuperSendsOfPvtMethods-JuanVuletich-2019Jun12-09h17m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3799] on 12 June 2019 at 5:45:08 pm'! -!Symbol methodsFor: 'testing' stamp: 'jmv 6/12/2019 09:46:50'! - isPvtInitializeSelector - "Answer whether the receiver is a private instance initialization message selector, that is, - begins with 'pvtInitialize' (followed or not by additional stuff, as a unary message, or as keyword with arguments)" - - ^ self beginsWith: 'pvtInitialize'! ! -!ParseNode methodsFor: 'testing' stamp: 'jmv 6/12/2019 17:44:11'! - isSelfBasicNewMessageSend - "Overridden in MessageNode." - ^false! ! -!ParseNode methodsFor: 'testing' stamp: 'jmv 6/12/2019 09:44:25'! - isSelfNewMessageSend - "Overridden in MessageNode." - ^false! ! -!SelectorNode methodsFor: 'testing' stamp: 'jmv 6/12/2019 09:47:15'! - isPvtInitializeSelector - "Answer whether the receiver is a private instance initialization message selecto" - - ^ key isPvtInitializeSelector! ! -!MessageNode methodsFor: 'testing' stamp: 'jmv 6/12/2019 17:44:09'! - isSelfBasicNewMessageSend - "Answer if this ParseNode represents the 'self new'' message send." - - ^ receiver isSelfPseudoVariable and: [ self selectorSymbol == #basicNew ]! ! -!MessageNode methodsFor: 'testing' stamp: 'jmv 6/12/2019 09:44:22'! - isSelfNewMessageSend - "Answer if this ParseNode represents the 'self new'' message send." - - ^ receiver isSelfPseudoVariable and: [ self selectorSymbol == #new ]! ! -!MessageNode methodsFor: 'private' stamp: 'jmv 6/12/2019 17:44:32' prior: 50464271! - pvtCheckForPvtSelector: encoder - "If the code being compiled is trying to send a private message (e.g. 'pvtCheckForPvtSelector:') to anyone other than self, then complain to encoder." - - selector isPvtInitializeSelector ifTrue: [ - (receiver isSelfNewMessageSend or: [receiver isSelfBasicNewMessageSend]) ifFalse: [ - encoder notify: 'Private instance initialization messages may only be sent to ''self new'' or "self basicNew" (by class instance creation methods)']. - ^ self ]. - selector isPvtSelector ifTrue: [ - (receiver isSelfPseudoVariable or: [ receiver isSuperPseudoVariable ]) ifFalse: [ - encoder notify: 'Private messages may only be sent to self or super']].! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3800-pvtInitialize-support-JuanVuletich-2019Jun12-17h42m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3799] on 12 June 2019 at 10:02:22 am'! -!Point methodsFor: 'private - initialization' stamp: 'jmv 6/12/2019 09:55:41'! - pvtInitializeX: xValue y: yValue - "Points are immutable." - x _ xValue. - y _ yValue! ! -!Point class methodsFor: 'instance creation' stamp: 'jmv 6/12/2019 09:55:51' prior: 50335839! - x: anX y: anY - "Answer an instance of me with supplied coordinates." - - ^self new pvtInitializeX: anX y: anY! ! - -Point removeSelector: #privateSetX:setY:! - -Point removeSelector: #privateSetX:setY:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3801-ImmutablePoints-JuanVuletich-2019Jun12-10h00m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3799] on 12 June 2019 at 10:15:34 am'! -!CharacterSet methodsFor: 'collection ops' stamp: 'jmv 6/12/2019 10:11:23' prior: 16802206! - includes: aCharacter - (aCharacter is: #Character) ifFalse: [ ^ false ]. - ^(map at: aCharacter numericValue + 1) > 0! ! -!Interval methodsFor: 'testing' stamp: 'jmv 6/12/2019 10:14:04' prior: 16861288! - includes: aNumber - aNumber isNumber ifFalse: [ ^ false ]. - ^ aNumber between: self first and: self last! ! -!Trie methodsFor: 'testing' stamp: 'jmv 6/12/2019 10:14:56' prior: 16939257! - includes: aString - "Consistent with Set, but not with Dictionary, as in Dictionary, #includes: - finds a value regardless of the key. To get this behavior, use #includesValue:" - - aString isString ifFalse: [ ^ false ]. - self at: aString ifPresent: [ :v | ^v = aString ]. - ^false! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3802-universalIncludes-JuanVuletich-2019Jun12-10h02m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3802] on 12 June 2019 at 6:11:48 pm'! -!Collection methodsFor: 'comparing' stamp: 'jmv 6/12/2019 18:08:54'! - emptyCollectionHash - ^self species hash! ! -!Set methodsFor: 'comparing' stamp: 'jmv 6/12/2019 18:09:50'! - emptyCollectionHash - ^ Set hash! ! -!Dictionary methodsFor: 'comparing' stamp: 'jmv 6/12/2019 18:10:04'! - emptyCollectionHash - ^ Dictionary hash! ! -!Collection methodsFor: 'comparing' stamp: 'jmv 6/12/2019 18:09:13' prior: 50464213! - hash - "A default hash function for any collection. Note that this method is insensitive to contents when the size is greater than 10, so critical applications that compare many large collections of the same length will want to refine this behavior." - - | hash | - hash _ self emptyCollectionHash. - self size <= 10 ifTrue: [ - self do: [ :elem | hash _ hash bitXor: elem hash]]. - ^ hash bitXor: self size hash -! ! -!Set methodsFor: 'testing' stamp: 'jmv 6/12/2019 18:05:55' prior: 50464167! - = aSet - - self == aSet ifTrue: [^ true]. "Any object is equal to itself" - (aSet is: #Set) ifFalse: [^ false]. - (aSet is: #Dictionary) ifTrue: [^ false]. - self size = aSet size ifFalse: [^ false]. - self do: [ :each | (aSet includes: each) ifFalse: [^ false]]. - ^ true! ! -!Dictionary methodsFor: 'comparing' stamp: 'jmv 7/5/2016 09:20' prior: 50464182! - = 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]. "Any object is equal to itself" - (aDictionary is: #Dictionary) ifFalse: [^false]. - self size = aDictionary size ifFalse: [^false]. - self associationsDo: [:assoc| - (aDictionary at: assoc key ifAbsent: [^false]) = assoc value - ifFalse: [^false]]. - ^true - -! ! -!Dictionary methodsFor: 'comparing' stamp: 'jmv 6/12/2019 18:11:13' prior: 50464237! - hash - "Note that this method is insensitive to contents when the size is greater than 10, so critical applications that compare many large collections of the same length will want to refine this behavior." - - | hash | - hash _ self emptyCollectionHash. - self size <= 10 ifTrue: [ - self associationsDo: [ :association | hash _ hash bitXor: association hash ]]. - ^ hash bitXor: self size hash! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3803-SetAndIdentitySetMayBeEqual-JuanVuletich-2019Jun12-18h02m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3801] on 12 June 2019 at 5:27:40 pm'! -!ParseNode methodsFor: 'testing' stamp: 'HAW 6/12/2019 17:23:21'! - isFalsePseudoVariable - "Overridden in VariableNode." - ^false! ! -!ParseNode methodsFor: 'testing' stamp: 'HAW 6/12/2019 17:23:26'! - isNilPseudoVariable - "Overridden in VariableNode." - ^false! ! -!ParseNode methodsFor: 'testing' stamp: 'HAW 6/12/2019 17:23:34'! - isThisContextPseudoVariable - "Overridden in VariableNode." - ^false! ! -!ParseNode methodsFor: 'testing' stamp: 'HAW 6/12/2019 17:23:42'! - isTruePseudoVariable - "Overridden in VariableNode." - ^false! ! -!VariableNode methodsFor: 'testing' stamp: 'HAW 6/12/2019 17:25:37'! - isFalsePseudoVariable - - ^key = 'false' or: [name = '{{false}}']! ! -!VariableNode methodsFor: 'testing' stamp: 'HAW 6/12/2019 17:25:44'! - isNilPseudoVariable - - ^ key = 'nil' or: [name = '{{nil}}']! ! -!VariableNode methodsFor: 'testing' stamp: 'HAW 6/12/2019 17:26:06'! - isThisContextPseudoVariable - - ^key = 'thisContext' or: [name = '{{thisContext}}']! ! -!VariableNode methodsFor: 'testing' stamp: 'HAW 6/12/2019 17:25:56'! - isTruePseudoVariable - - ^ key = 'true' or: [name = '{{true}}']! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3804-isXxxPseudoVariable-HernanWilkinson-2019Jun12-17h22m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3804] on 13 June 2019 at 8:56:28 am'! -!Symbol methodsFor: 'testing' stamp: 'jmv 6/13/2019 08:54:44'! - isInitializePvtSelector - "Answer whether the receiver is a private instance initialization message selector, that is, - begins with 'initializePvt' (followed or not by additional stuff, as a unary message, or as keyword with arguments)" - - ^ self beginsWith: 'initializePvt'! ! -!SelectorNode methodsFor: 'testing' stamp: 'jmv 6/13/2019 08:54:32'! - isInitializePvtSelector - "Answer whether the receiver is a private instance initialization message selector" - - ^ key isInitializePvtSelector! ! -!Point methodsFor: 'private - initialization' stamp: 'jmv 6/13/2019 08:51:25'! - initializePvtX: xValue y: yValue - "Points are immutable." - x _ xValue. - y _ yValue! ! -!MessageNode methodsFor: 'private' stamp: 'jmv 6/13/2019 08:52:31' prior: 50464337! - pvtCheckForPvtSelector: encoder - "If the code being compiled is trying to send a private message (e.g. 'pvtCheckForPvtSelector:') to anyone other than self, then complain to encoder." - - selector isInitializePvtSelector ifTrue: [ - (receiver isSelfNewMessageSend or: [receiver isSelfBasicNewMessageSend]) ifFalse: [ - encoder notify: 'Private instance initialization messages may only be sent to ''self new'' or "self basicNew" (by class instance creation methods)']]. - selector isPvtSelector ifTrue: [ - (receiver isSelfPseudoVariable or: [ receiver isSuperPseudoVariable ]) ifFalse: [ - encoder notify: 'Private messages may only be sent to self or super']].! ! -!Point class methodsFor: 'instance creation' stamp: 'jmv 6/13/2019 08:55:26' prior: 50464375! - x: anX y: anY - "Answer an instance of me with supplied coordinates." - - ^self new initializePvtX: anX y: anY! ! - -Point removeSelector: #pvtInitializeX:y:! - -Point removeSelector: #pvtInitializeX:y:! - -SelectorNode removeSelector: #isPvtInitializeSelector! - -SelectorNode removeSelector: #isPvtInitializeSelector! - -Symbol removeSelector: #isPvtInitializeSelector! - -Symbol removeSelector: #isPvtInitializeSelector! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3805-ImmutableInitializationEnh-JuanVuletich-2019Jun13-08h51m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3805] on 22 June 2019 at 3:21:51 pm'! -!SUnitNameResolver class methodsFor: 'Camp Smalltalk' stamp: 'sqr 6/22/2019 15:21:45' prior: 16903599! - errorObject - ^UnhandledError! ! -!TestCase methodsFor: 'assertions' stamp: 'sqr 6/26/2019 12:51:03' prior: 50447595! - shouldntFail: aBlock - - self shouldnt: aBlock raise: TestResult exError! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3806-SUnitFix-AndresValloud-2019Jun22-15h20m-sqr.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3805] on 22 June 2019 at 3:26:49 pm'! - -ArithmeticError subclass: #NegativePowerError - instanceVariableNames: 'base argument selector' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #NegativePowerError category: #'Exceptions Kernel'! -ArithmeticError subclass: #NegativePowerError - instanceVariableNames: 'base argument selector' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! -!NegativePowerError methodsFor: 'initialization' stamp: 'jmv 6/22/2019 15:00:02'! - base: aNumber selector: aSymbol argument: otherNumber - base _ aNumber. - selector _ aSymbol. - argument _ otherNumber ! ! -!NegativePowerError methodsFor: 'initialization' stamp: 'jmv 6/22/2019 15:01:03'! - signalBase: aNumber selector: aSymbol argument: otherNumber - ^self - base: aNumber selector: aSymbol argument: otherNumber; - signal! ! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 6/22/2019 15:01:22' prior: 50460928! - raisedTo: exponent - "Answer the receiver raised to aNumber." - - exponent isInteger ifTrue: [ - "Do the special case of integer power" - ^ self raisedToInteger: exponent]. - exponent isFraction ifTrue: [ - "Special case for fraction power by Nicolas Cellier: - If aNumber is a fraction, but result must be a Float, learn it as quickly as possible, and give quick Float answer - Allows evaluating: - (2009/2000) raisedTo: (3958333/100000) - " - ^ self raisedToFraction: exponent]. - self < 0 ifTrue: [ - ^NegativePowerError new signalBase: self selector: #raisedTo: argument: exponent]. - 0 = exponent ifTrue: [^ self class one]. "Special case of exponent=0" - 1 = exponent ifTrue: [^ self]. "Special case of exponent=1" - 0 = self ifTrue: [ "Special case of self = 0" - exponent < 0 - ifTrue: [^ (ZeroDivide dividend: self) signal] - ifFalse: [^ self]]. - ^ (exponent * self ln) exp "Otherwise use logarithms"! ! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 6/22/2019 15:04:09' prior: 50460959! - raisedToFraction: aFraction - self isZero ifTrue: [ - aFraction negative ifTrue: [ - ^ (ZeroDivide dividend: 1) signal ]. - ^ self ]. - self negative ifFalse: [ - ^ (self ln * aFraction) exp ]. - aFraction denominator = 2 ifTrue: [ - ^ self sqrt raisedToInteger: aFraction numerator ]. - (self negative and: [ aFraction denominator even ]) ifTrue: [ - ^NegativePowerError new signalBase: self selector: #raisedToFraction: argument: aFraction]. - ^ (self negated ln * aFraction) exp negated! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 6/22/2019 15:05:38' prior: 50400477! - nthRoot: aPositiveInteger - "Answer the nth root of the receiver." - aPositiveInteger = 2 ifTrue: [ - ^self sqrt ]. - - (aPositiveInteger isInteger not or: [ aPositiveInteger negative ]) - ifTrue: [^ ArithmeticError signal: 'nth root only defined for positive Integer n.']. - - ^self negative - ifTrue: [ - aPositiveInteger even - ifTrue: [ NegativePowerError new signalBase: self selector: #nthRoot: argument: aPositiveInteger ] - ifFalse: [ (self negated nthRoot: aPositiveInteger) negated ]] - ifFalse: [ self raisedTo: 1.0 / aPositiveInteger ]! ! -!Fraction methodsFor: 'mathematical functions' stamp: 'jmv 6/22/2019 15:06:05' prior: 50400497! - nthRoot: aPositiveInteger - "Answer the nth root of the receiver." - | guess | - aPositiveInteger = 2 ifTrue: [ - ^ self sqrt ]. - - (aPositiveInteger isInteger not or: [ aPositiveInteger negative ]) - ifTrue: [^ ArithmeticError signal: 'nth root only defined for positive Integer n.']. - - (self negative and: [ aPositiveInteger even ]) ifTrue: [ - ^ NegativePowerError new signalBase: self selector: #nthRoot: argument: aPositiveInteger ]. - - guess _ (numerator nthRootTruncated: aPositiveInteger) / - (denominator nthRootTruncated: aPositiveInteger). - (guess raisedTo: aPositiveInteger) = self ifTrue: [ - ^ guess ]. - "There is no exact nth root, so answer a Float approximation" - ^ (self abs ln / aPositiveInteger) exp * self sign! ! -!Fraction methodsFor: 'mathematical functions' stamp: 'jmv 6/22/2019 15:03:56' prior: 50400623! - raisedToFraction: aFraction - | root | - aFraction denominator = 2 ifTrue: [ - ^ self sqrt raisedToInteger: aFraction numerator ]. - (self negative and: [ aFraction denominator even ]) ifTrue: [ - ^NegativePowerError new signalBase: self selector: #raisedToFraction: argument: aFraction]. - root _ (self numerator nthRootTruncated: aFraction denominator) / - (self denominator nthRootTruncated: aFraction denominator). - (root raisedToInteger: aFraction denominator) = self ifTrue: [ - ^ root raisedToInteger: aFraction numerator ]. - ^ super raisedToFraction: aFraction! ! -!Integer methodsFor: 'mathematical functions' stamp: 'jmv 6/22/2019 15:06:14' prior: 50400523! - nthRoot: aPositiveInteger - "Answer the nth root of the receiver. - Answer an Integer if root is exactly this Integer, else answer the Float nearest the exact root." - - | guess excess scaled nBits | - self = 0 ifTrue: [ ^0 ]. - - aPositiveInteger = 2 ifTrue: [ - ^ self sqrt ]. - - (aPositiveInteger isInteger not or: [ aPositiveInteger negative ]) - ifTrue: [^ ArithmeticError signal: 'nth root only defined for positive Integer n.']. - - (self negative and: [ aPositiveInteger even ]) ifTrue: [ - ^ NegativePowerError new signalBase: self selector: #nthRoot: argument: aPositiveInteger ]. - - guess _ self nthRootRounded: aPositiveInteger. - excess _ (guess raisedTo: aPositiveInteger) - self. - excess = 0 ifTrue: [ ^ guess ]. - - nBits _ Float precision - guess highBitOfMagnitude. - nBits <= 0 ifTrue: [ ^(Fraction numerator: guess * 4 - excess sign denominator: 4) asFloat]. - - scaled _ self << (nBits * aPositiveInteger). - guess _ scaled nthRootRounded: aPositiveInteger. - excess _ (guess raisedTo: aPositiveInteger) - scaled. - ^(Fraction numerator: guess * 4 - excess sign denominator: 1 << (nBits + 2)) asFloat! ! -!Integer methodsFor: 'mathematical functions' stamp: 'jmv 6/22/2019 15:04:35' prior: 50400644! - raisedToFraction: aFraction - | root | - self = 0 ifTrue: [ ^0 ]. - aFraction denominator = 2 ifTrue: [ - ^ self sqrt raisedToInteger: aFraction numerator ]. - (self negative and: [ aFraction denominator even ]) ifTrue: [ - ^NegativePowerError new signalBase: self selector: #raisedToFraction: argument: aFraction]. - root _ self nthRootTruncated: aFraction denominator. - (root raisedToInteger: aFraction denominator) = self ifTrue: [ - ^ root raisedToInteger: aFraction numerator ]. - ^ super raisedToFraction: aFraction! ! - -Number removeSelector: #asComplex! - -Number removeSelector: #asComplex! - -Number removeSelector: #i! - -Number removeSelector: #i! - -Smalltalk removeClassNamed: #Complex! - -Smalltalk removeClassNamed: #Complex! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3807-LoadableComplex-AndresValloud-JuanVuletich-2019Jun22-15h21m-sqr.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3805] on 22 June 2019 at 3:27:28 pm'! -!Float64Array methodsFor: 'arithmetic' stamp: 'jmv 6/22/2019 14:40:41' prior: 50404491! - /= anObject - - ^self divideBy: anObject - ifDivisorZero: [ZeroDivide signalWithDividend: self] - ifBothZero: [ZeroDivide signalWithDividend: self]! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'jmv 6/22/2019 14:40:49' prior: 50404499! - /= anObject - - ^self divideBy: anObject - ifDivisorZero: [ZeroDivide signalWithDividend: self] - ifBothZero: [ZeroDivide signalWithDividend: self]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3808-Cleanup-AndresValloud-JuanVuletich-2019Jun22-15h26m-sqr.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3808] on 22 June 2019 at 3:36:06 pm'! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 6/22/2019 15:34:46' prior: 50420544! - sqrtNonPrimitive - "Answer the square root of the receiver. " - | exp guess delta | - - self = 0.0 ifTrue: [ - ^self ]. "Answer 0.0 for 0.0, but -0.0 for -0.0. See IEEE 754 standard" - - self <= 0.0 - ifTrue: [ - ^NegativePowerError new signalBase: self selector: #raisedTo: argument: 1/2 ]. - - "NaN and Infinity" - self isFinite ifFalse: [ - ^ self ]. - - "Newton-Raphson" - "first guess is half the exponent" - exp _ self exponent // 2. - guess _ self timesTwoPower: 0 - exp. - [ - delta _ self - (guess * guess) / (guess * 2.0). - delta abs >= guess ulp ] - whileTrue: [ - guess _ guess + delta ]. - ^ guess! ! -!LargeNegativeInteger methodsFor: 'mathematical functions' stamp: 'jmv 6/22/2019 15:32:24' prior: 50400431! - sqrt - "Answer the square root of the receiver." - ^NegativePowerError new signalBase: self selector: #raisedTo: argument: 1/2! ! -!SmallInteger methodsFor: 'mathematical functions' stamp: 'jmv 6/22/2019 15:32:02' prior: 50400437! - sqrt - - self positive ifTrue: [^super sqrt]. - ^NegativePowerError new signalBase: self selector: #raisedTo: argument: 1/2! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3809-LoadableComplex-p2-AndresValloud-JuanVuletich-2019Jun22-15h30m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3809] on 23 June 2019 at 5:17:18 pm'! -!JPEGReadWriter2 methodsFor: 'public access' stamp: 'jmv 6/23/2019 17:16:57' prior: 16861429! - compress: aForm quality: quality progressiveJPEG: progressiveFlag usingBuffer: aByteArrayOrNil into: aBlock - "Encode the given Form with the given settings. Quality goes from 0 (low) to 100 (high), where -1 means default. If progressiveFlag is true, encode as a progressive JPEG. - - Evaluate aBlock with two arguments. The first is a ByteArray with the data. Usually bigger than needed. - The second argument is the actual maningful bytes. - - We can only compress: - * 32-bit deep Forms - * -32-bit deep Forms - * 16-bit deep Forms - * -16-bit deep Forms - * 8-bit deep GrayForms - * -8-bit deep GrayForms" - - | sourceForm jpegCompressStruct jpegErrorMgr2Struct buffer byteCount | - self supportsGrayForms - ifTrue: [ - "Newer plugin supports 32bpp, 16bpp, GrayForms" - sourceForm _ (aForm depth = 32) | (aForm depth = 16) | (aForm is: #GrayForm) - ifTrue: [aForm] - ifFalse: [aForm asFormOfDepth: 16]] - ifFalse: [ - "Original plugin supports 32bpp and even width big endian 16bpp" - sourceForm _ (aForm depth = 32) | (aForm width even & (aForm nativeDepth = 16)) - ifTrue: [aForm] - ifFalse: [aForm asFormOfDepth: 32]]. - - jpegCompressStruct _ ByteArray new: self primJPEGCompressStructSize. - jpegErrorMgr2Struct _ ByteArray new: self primJPEGErrorMgr2StructSize. - "Most likely more than needed" - buffer _ aByteArrayOrNil ifNil: [ByteArray new: sourceForm width * sourceForm height // 2+1024]. - [ - byteCount _ self jpegWriteImage: jpegCompressStruct - onByteArray: buffer - form: sourceForm - quality: quality - progressiveJPEG: progressiveFlag - errorMgr: jpegErrorMgr2Struct. - byteCount = 0 ] whileTrue: [ - "But if not, ask for some more" - buffer _ ByteArray new: buffer size * 14 // 10 ]. - - aBlock value: buffer value: byteCount! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3810-JPEG-fix-JuanVuletich-2019Jun23-17h15m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3810] on 25 June 2019 at 6:48:07 pm'! - -Error subclass: #ArithmeticMessageError - instanceVariableNames: 'receiver selector arguments' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #ArithmeticMessageError category: #'Exceptions Kernel'! -Error subclass: #ArithmeticMessageError - instanceVariableNames: 'receiver selector arguments' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -ArithmeticMessageError subclass: #NegativePowerError - instanceVariableNames: 'base argument ' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #NegativePowerError category: #'Exceptions Kernel'! -ArithmeticMessageError subclass: #NegativePowerError - instanceVariableNames: 'base argument' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -ArithmeticMessageError subclass: #ZeroDivide - instanceVariableNames: 'dividend ' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #ZeroDivide category: #'Exceptions Kernel'! -ArithmeticMessageError subclass: #ZeroDivide - instanceVariableNames: 'dividend' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! -!ZeroDivide commentStamp: '' prior: 50454464! - ZeroDivide may be signaled when a mathematical division by 0 is attempted.! -!ArithmeticMessageError methodsFor: 'initialization' stamp: 'jmv 6/25/2019 18:26:00'! - receiver: aNumber selector: aSymbol argument: otherNumber - self receiver: aNumber selector: aSymbol arguments: {otherNumber}! ! -!ArithmeticMessageError methodsFor: 'initialization' stamp: 'jmv 6/25/2019 18:26:00'! - receiver: aNumber selector: aSymbol arguments: aCollection - receiver _ aNumber. - selector _ aSymbol. - arguments _ aCollection! ! -!ArithmeticMessageError methodsFor: 'exceptionDescription' stamp: 'jmv 6/25/2019 18:26:00'! - defaultAction - (receiver isFloat or: [ arguments anySatisfy: [ :a | a isFloat ]]) ifTrue: [ - ^self floatErrorValue ]. - ^ super defaultAction! ! -!ArithmeticMessageError methodsFor: 'signaling' stamp: 'jmv 6/25/2019 18:26:00'! - floatErrorValue - ^ self subclassResponsibility! ! -!ArithmeticMessageError methodsFor: 'signaling' stamp: 'jmv 6/25/2019 18:26:00'! - signalReceiver: aNumber selector: aSymbol argument: otherNumber - - ^self - receiver: aNumber selector: aSymbol argument: otherNumber; - signal! ! -!ArithmeticMessageError methodsFor: 'signaling' stamp: 'jmv 6/25/2019 18:26:00'! - signalReceiver: aNumber selector: aSymbol arguments: aCollection - - ^self - receiver: aNumber selector: aSymbol arguments: aCollection; - signal! ! -!NegativePowerError methodsFor: 'signaling' stamp: 'jmv 6/25/2019 18:41:08'! -floatErrorValue - ^ Float nan! ! -!ZeroDivide methodsFor: 'signaling' stamp: 'jmv 6/25/2019 18:47:06'! - floatErrorValue - receiver isZero ifTrue: [ ^ Float nan ]. - ^ (receiver * arguments first) sign = -1 - ifTrue: [ Float negativeInfinity ] - ifFalse: [ Float infinity ]! ! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:06:04' prior: 50464668! - raisedTo: exponent - "Answer the receiver raised to aNumber." - - exponent isInteger ifTrue: [ - "Do the special case of integer power" - ^ self raisedToInteger: exponent]. - exponent isFraction ifTrue: [ - "Special case for fraction power by Nicolas Cellier: - If aNumber is a fraction, but result must be a Float, learn it as quickly as possible, and give quick Float answer - Allows evaluating: - (2009/2000) raisedTo: (3958333/100000) - " - ^ self raisedToFraction: exponent]. - self < 0 ifTrue: [ - ^NegativePowerError new signalReceiver: self selector: #raisedTo: argument: exponent]. - 0 = exponent ifTrue: [^ self class one]. "Special case of exponent=0" - 1 = exponent ifTrue: [^ self]. "Special case of exponent=1" - 0 = self ifTrue: [ "Special case of self = 0" - exponent < 0 - ifTrue: [^ ZeroDivide new signalReceiver: self selector: #raisedTo: argument: exponent] - ifFalse: [^ self]]. - ^ (exponent * self ln) exp "Otherwise use logarithms"! ! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:06:12' prior: 50464700! - raisedToFraction: aFraction - self isZero ifTrue: [ - aFraction negative ifTrue: [ - ^ZeroDivide new signalReceiver: self selector: #raisedToFraction: argument: aFraction]. - ^ self ]. - self negative ifFalse: [ - ^ (self ln * aFraction) exp ]. - aFraction denominator = 2 ifTrue: [ - ^ self sqrt raisedToInteger: aFraction numerator ]. - (self negative and: [ aFraction denominator even ]) ifTrue: [ - ^NegativePowerError new signalReceiver: self selector: #raisedToFraction: argument: aFraction]. - ^ (self negated ln * aFraction) exp negated! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:17:58' prior: 16844544! - arCosh - "Answer receiver's area hyperbolic cosine. - That is the inverse function of cosh." - - self < 1 - ifTrue: [^ Float nan]. - ^self + 1 = self - ifTrue: [self abs ln + 2 ln] - ifFalse: [((self squared - 1) sqrt + self) ln]! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:18:29' prior: 16844567! - arTanh - "Answer receiver's area hyperbolic tangent. - That is the inverse function of tanh." - - self = 0.0 ifTrue: [^self]. "Handle negativeZero" - self abs = 1 ifTrue: [^self copySignTo: Float infinity]. - self abs > 1 ifTrue: [^ Float nan]. - ^((1 + self) / (1 - self)) ln / 2! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:18:55' prior: 16844584! - arcSin - "Answer the angle in radians." - - ((self < -1.0) or: [self > 1.0]) ifTrue: [^ Float nan]. - ^((self = -1.0) or: [self = 1.0]) - ifTrue: [Halfpi * self] - ifFalse: [(self / (1.0 - (self * self)) sqrt) arcTan]! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:19:05' prior: 50420489! - lnNonPrimitive - "Answer the natural logarithm of the receiver. - Optional. See Object documentation whatIsAPrimitive." - - | expt n mant x div pow delta sum | - - "Taylor series" - self <= 0.0 ifTrue: [^ Float nan]. - - "get a rough estimate from binary exponent" - expt := self exponent. - n := Ln2 * expt. - mant := self timesTwoPower: 0 - expt. - - "compute fine correction from mantinssa in Taylor series" - "mant is in the range [0..2]" - "we unroll the loop to avoid use of abs" - x := mant - 1.0. - div := 1.0. - pow := delta := sum := x. - x := x negated. "x <= 0" - [delta > (n + sum) ulp] whileTrue: [ - "pass one: delta is positive" - div := div + 1.0. - pow := pow * x. - delta := pow / div. - sum := sum + delta. - "pass two: delta is negative" - div := div + 1.0. - pow := pow * x. - delta := pow / div. - sum := sum + delta]. - - ^ n + sum - - "Float e ln 1.0"! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:07:09' prior: 50464719! - nthRoot: aPositiveInteger - "Answer the nth root of the receiver." - aPositiveInteger = 2 ifTrue: [ - ^self sqrt ]. - - (aPositiveInteger isInteger not or: [ aPositiveInteger negative ]) - ifTrue: [^ DomainError signal: 'nth root only defined for positive Integer n.']. - - ^self negative - ifTrue: [ - aPositiveInteger even - ifTrue: [ NegativePowerError new signalReceiver: self selector: #nthRoot: argument: aPositiveInteger ] - ifFalse: [ (self negated nthRoot: aPositiveInteger) negated ]] - ifFalse: [ self raisedTo: 1.0 / aPositiveInteger ]! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:04:46' prior: 50464884! - sqrtNonPrimitive - "Answer the square root of the receiver. " - | exp guess delta | - - self = 0.0 ifTrue: [ - ^self ]. "Answer 0.0 for 0.0, but -0.0 for -0.0. See IEEE 754 standard" - - self <= 0.0 - ifTrue: [ - ^NegativePowerError new signalReceiver: self selector: #sqrtNonPrimitive arguments: {} ]. - - "NaN and Infinity" - self isFinite ifFalse: [ - ^ self ]. - - "Newton-Raphson" - "first guess is half the exponent" - exp _ self exponent // 2. - guess _ self timesTwoPower: 0 - exp. - [ - delta _ self - (guess * guess) / (guess * 2.0). - delta abs >= guess ulp ] - whileTrue: [ - guess _ guess + delta ]. - ^ guess! ! -!BoxedFloat64 methodsFor: 'arithmetic' stamp: 'jmv 6/25/2019 17:44:27' prior: 16790493! - / aNumber - "Primitive. Answer the result of dividing receiver by aNumber. - Fail if the argument is not a Float. - Essential. See Object clas >> whatIsAPrimitive." - - - aNumber isZero ifTrue: [^ ZeroDivide new signalReceiver: self selector: #/ argument: aNumber]. - ^ aNumber adaptToFloat: self andSend: #/! ! -!SmallFloat64 methodsFor: 'arithmetic' stamp: 'jmv 6/25/2019 18:01:31' prior: 16908219! - / aNumber - "Primitive. Answer the result of dividing receiver by aNumber. - Fail if the argument is not a Float. - Essential. See Object clas >> whatIsAPrimitive." - - - aNumber isZero ifTrue: [^ZeroDivide new signalReceiver: self selector: #/ argument: aNumber ]. - ^ aNumber adaptToFloat: self andSend: #/! ! -!Fraction methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:21:44' prior: 16849641! - ln - "This function is defined because super ln might overflow." - | res | - self <= 0 ifTrue: [^DomainError signal: 'ln is only defined for x > 0']. - "Test self < 1 before converting to float in order to avoid precision loss due to gradual underflow." - numerator < denominator ifTrue: [^self reciprocal ln negated]. - res := super ln. - res isFinite ifTrue: [^res]. - ^numerator ln - denominator ln! ! -!Fraction methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:21:48' prior: 16849656! - log - " - (1/(10 raisedTo: 215)) log - (1/((10 raisedTo: 215)+(10 raisedTo: 213))) log - " - | res | - self <= 0 ifTrue: [^DomainError signal: 'log is only defined for x > 0']. - - "Integer answer if possible!!" - numerator = 1 - ifTrue: [ ^denominator log negated ]. - - "This because super log might overflow." - "Test self < 1 before converting to float in order to avoid precision loss due to gradual underflow." - numerator < denominator ifTrue: [ ^self reciprocal log negated ]. - res := super log. - res isFinite ifTrue: [^res]. - ^numerator log - denominator log! ! -!Fraction methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:07:13' prior: 50464740! - nthRoot: aPositiveInteger - "Answer the nth root of the receiver." - | guess | - aPositiveInteger = 2 ifTrue: [ - ^ self sqrt ]. - - (aPositiveInteger isInteger not or: [ aPositiveInteger negative ]) - ifTrue: [^ DomainError signal: 'nth root only defined for positive Integer n.']. - - (self negative and: [ aPositiveInteger even ]) ifTrue: [ - ^ NegativePowerError new signalReceiver: self selector: #nthRoot: argument: aPositiveInteger ]. - - guess _ (numerator nthRootTruncated: aPositiveInteger) / - (denominator nthRootTruncated: aPositiveInteger). - (guess raisedTo: aPositiveInteger) = self ifTrue: [ - ^ guess ]. - "There is no exact nth root, so answer a Float approximation" - ^ (self abs ln / aPositiveInteger) exp * self sign! ! -!Fraction methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:05:14' prior: 50464766! - raisedToFraction: aFraction - | root | - aFraction denominator = 2 ifTrue: [ - ^ self sqrt raisedToInteger: aFraction numerator ]. - (self negative and: [ aFraction denominator even ]) ifTrue: [ - ^NegativePowerError new signalReceiver: self selector: #raisedToFraction: argument: aFraction]. - root _ (self numerator nthRootTruncated: aFraction denominator) / - (self denominator nthRootTruncated: aFraction denominator). - (root raisedToInteger: aFraction denominator) = self ifTrue: [ - ^ root raisedToInteger: aFraction numerator ]. - ^ super raisedToFraction: aFraction! ! -!Fraction methodsFor: 'private' stamp: 'jmv 6/25/2019 17:57:12' prior: 16849897! - setNumerator: n denominator: d - - d = 0 - ifTrue: [^ZeroDivide new signalReceiver: self selector: #setNumerator:denominator: arguments: {n.d}] - ifFalse: [ - numerator _ n asInteger. - denominator _ d asInteger abs. "keep sign in numerator" - d < 0 ifTrue: [numerator _ numerator negated]]! ! -!Integer methodsFor: 'arithmetic' stamp: 'jmv 6/25/2019 17:47:55' prior: 16858901! - // aNumber - | q | - aNumber = 0 ifTrue: [^ ZeroDivide new signalReceiver: self selector: #// argument: aNumber]. - self = 0 ifTrue: [^ 0]. - q _ self quo: aNumber. - "Refer to the comment in Number>>#//." - ^(q negative - ifTrue: [q * aNumber ~= self] - ifFalse: [q = 0 and: [self negative ~= aNumber negative]]) - ifTrue: [q - 1"Truncate towards minus infinity."] - ifFalse: [q]! ! -!Integer methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:21:59' prior: 16859597! - ln - "This function is defined because super ln might overflow." - | res h | - self <= 0 ifTrue: [^DomainError signal: 'ln is only defined for x > 0']. - res := super ln. - res isFinite ifTrue: [^res]. - h := self highBit. - ^2 ln * h + (self / (1 << h)) asFloat ln! ! -!Integer methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:22:05' prior: 16859608! - log - "This function is defined because super log might overflow. - (10 raisedTo: 215) log - ((10 raisedTo: 215)+(10 raisedTo: 213)) log - Answers an integer number if appropriate. Doing this is somewhat expensive. If you care about performance and not about using Floats, do 'aNumber asFloat log: another'. - " - | floatAnswer roundedAnswer | - self <= 0 ifTrue: [^DomainError signal: 'log is only defined for x > 0']. - floatAnswer _ self floatLog. - roundedAnswer _ floatAnswer rounded. - (10 raisedToInteger: roundedAnswer) = self - ifTrue: [ ^roundedAnswer ]. - ^floatAnswer! ! -!Integer methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:22:11' prior: 16859640! - log: aNumber - "Answer the log base aNumber of the receiver. - (3 raisedTo: 215) log: 3 - ((3 raisedTo: 215)+(3 raisedTo: 213)) log: 3 - Answers an integer number if appropriate. Doing this is somewhat expensive. If you care about performance and not about using Floats, do 'aNumber asFloat log: another'. - " - | floatAnswer roundedAnswer | - self <= 0 ifTrue: [^DomainError signal: 'log is only defined for x > 0']. - floatAnswer _ self asFloat log: aNumber. - roundedAnswer _ floatAnswer rounded. - (aNumber raisedToInteger: roundedAnswer) = self - ifTrue: [ ^roundedAnswer ]. - ^floatAnswer! ! -!Integer methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:07:17' prior: 50464787! - nthRoot: aPositiveInteger - "Answer the nth root of the receiver. - Answer an Integer if root is exactly this Integer, else answer the Float nearest the exact root." - - | guess excess scaled nBits | - self = 0 ifTrue: [ ^0 ]. - - aPositiveInteger = 2 ifTrue: [ - ^ self sqrt ]. - - (aPositiveInteger isInteger not or: [ aPositiveInteger negative ]) - ifTrue: [^ DomainError signal: 'nth root only defined for positive Integer n.']. - - (self negative and: [ aPositiveInteger even ]) ifTrue: [ - ^ NegativePowerError new signalReceiver: self selector: #nthRoot: argument: aPositiveInteger ]. - - guess _ self nthRootRounded: aPositiveInteger. - excess _ (guess raisedTo: aPositiveInteger) - self. - excess = 0 ifTrue: [ ^ guess ]. - - nBits _ Float precision - guess highBitOfMagnitude. - nBits <= 0 ifTrue: [ ^(Fraction numerator: guess * 4 - excess sign denominator: 4) asFloat]. - - scaled _ self << (nBits * aPositiveInteger). - guess _ scaled nthRootRounded: aPositiveInteger. - excess _ (guess raisedTo: aPositiveInteger) - scaled. - ^(Fraction numerator: guess * 4 - excess sign denominator: 1 << (nBits + 2)) asFloat! ! -!Integer methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:07:44' prior: 16859690! - nthRootRounded: aPositiveInteger - "Answer the integer nearest the nth root of the receiver. -http://stackoverflow.com/questions/39794338/precise-nth-root - -http://smallissimo.blogspot.com.ar/2011/09/clarifying-and-optimizing.html -Ojo 32/64!! - -Tambien -http://smallissimo.blogspot.com.ar/2011/09/reviewing-fraction-asfloat.html -" - | guess | - self = 0 ifTrue: [^0]. - self negative - ifTrue: [ - aPositiveInteger even ifTrue: [ ^DomainError signal: 'Negative numbers don''t have even roots.' ]. - ^(self negated nthRootRounded: aPositiveInteger) negated]. - guess := self nthRootTruncated: aPositiveInteger. - ^self * 2 > ((guess + 1 raisedTo: aPositiveInteger) + (guess raisedTo: aPositiveInteger)) - ifTrue: [guess + 1] - ifFalse: [guess]! ! -!Integer methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:08:30' prior: 16859718! - nthRootTruncated: aPositiveInteger - "Answer the integer part of the nth root of the receiver." - | guess guessToTheNthMinusOne nextGuess | - self = 0 ifTrue: [^0]. - self negative - ifTrue: [ - aPositiveInteger even ifTrue: [ ^DomainError signal: 'Negative numbers don''t have even roots.' ]. - ^(self negated nthRootTruncated: aPositiveInteger) negated]. - guess := 1 bitShift: self highBitOfMagnitude + aPositiveInteger - 1 // aPositiveInteger. - [ - guessToTheNthMinusOne := guess raisedTo: aPositiveInteger - 1. - nextGuess := (aPositiveInteger - 1 * guess * guessToTheNthMinusOne + self) // (guessToTheNthMinusOne * aPositiveInteger). - nextGuess >= guess ] whileFalse: - [ guess := nextGuess ]. - ( guess raisedTo: aPositiveInteger) > self ifTrue: - [ guess := guess - 1 ]. - ^guess! ! -!Integer methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:05:31' prior: 50464826! - raisedToFraction: aFraction - | root | - self = 0 ifTrue: [ ^0 ]. - aFraction denominator = 2 ifTrue: [ - ^ self sqrt raisedToInteger: aFraction numerator ]. - (self negative and: [ aFraction denominator even ]) ifTrue: [ - ^NegativePowerError new signalReceiver: self selector: #raisedToFraction: argument: aFraction]. - root _ self nthRootTruncated: aFraction denominator. - (root raisedToInteger: aFraction denominator) = self ifTrue: [ - ^ root raisedToInteger: aFraction numerator ]. - ^ super raisedToFraction: aFraction! ! -!Integer methodsFor: 'private' stamp: 'jmv 6/25/2019 17:58:27' prior: 16860338! - digitDiv: arg neg: ng - "Answer with an array of (quotient, remainder)." - | quo rem ql d div dh dnh dl qhi qlo j l hi lo r3 a t | - - arg = 0 ifTrue: [^ ZeroDivide new signalReceiver: self selector: #digitDiv:neg: arguments: {arg.ng}]. - "TFEI added this line" - l _ self digitLength - arg digitLength + 1. - l <= 0 ifTrue: [^ Array with: 0 with: self]. - "shortcut against #highBit" - d _ 8 - arg lastDigit highBitOfMagnitude. - div _ arg digitLshift: d. - div _ div growto: div digitLength + 1. - "shifts so high order word is >=128" - rem _ self digitLshift: d. - rem digitLength = self digitLength ifTrue: [rem _ rem growto: self digitLength + 1]. - "makes a copy and shifts" - quo _ Integer new: l neg: ng. - dl _ div digitLength - 1. - "Last actual byte of data" - ql _ l. - dh _ div digitAt: dl. - dnh _ dl = 1 - ifTrue: [0] - ifFalse: [div digitAt: dl - 1]. - 1 to: ql do: - [:k | - "maintain quo*arg+rem=self" - "Estimate rem/div by dividing the leading to bytes of rem by dh." - "The estimate is q = qhi*16+qlo, where qhi and qlo are nibbles." - j _ rem digitLength + 1 - k. - "r1 _ rem digitAt: j." - (rem digitAt: j) - = dh - ifTrue: [qhi _ qlo _ 15 - "i.e. q=255"] - ifFalse: - ["Compute q = (r1,r2)//dh, t = (r1,r2)\\dh. - Note that r1,r2 are bytes, not nibbles. - Be careful not to generate intermediate results exceeding 13 - bits." - "r2 _ (rem digitAt: j - 1)." - t _ ((rem digitAt: j) - bitShift: 4) - + ((rem digitAt: j - 1) - bitShift: -4). - qhi _ t // dh. - t _ (t \\ dh bitShift: 4) - + ((rem digitAt: j - 1) - bitAnd: 15). - qlo _ t // dh. - t _ t \\ dh. - "Next compute (hi,lo) _ q*dnh" - hi _ qhi * dnh. - lo _ qlo * dnh + ((hi bitAnd: 15) - bitShift: 4). - hi _ (hi bitShift: -4) - + (lo bitShift: -8). - lo _ lo bitAnd: 255. - "Correct overestimate of q. - Max of 2 iterations through loop -- see Knuth vol. 2" - r3 _ j < 3 - ifTrue: [0] - ifFalse: [rem digitAt: j - 2]. - [(t < hi - or: [t = hi and: [r3 < lo]]) - and: - ["i.e. (t,r3) < (hi,lo)" - qlo _ qlo - 1. - lo _ lo - dnh. - lo < 0 - ifTrue: - [hi _ hi - 1. - lo _ lo + 256]. - hi >= dh]] - whileTrue: [hi _ hi - dh]. - qlo < 0 - ifTrue: - [qhi _ qhi - 1. - qlo _ qlo + 16]]. - "Subtract q*div from rem" - l _ j - dl. - a _ 0. - 1 to: div digitLength do: - [:i | - hi _ (div digitAt: i) - * qhi. - lo _ a + (rem digitAt: l) - ((hi bitAnd: 15) - bitShift: 4) - ((div digitAt: i) - * qlo). - rem digitAt: l put: lo - (lo // 256 * 256). - "sign-tolerant form of (lo bitAnd: 255)" - a _ lo // 256 - (hi bitShift: -4). - l _ l + 1]. - a < 0 - ifTrue: - ["Add div back into rem, decrease q by 1" - qlo _ qlo - 1. - l _ j - dl. - a _ 0. - 1 to: div digitLength do: - [:i | - a _ (a bitShift: -8) - + (rem digitAt: l) + (div digitAt: i). - rem digitAt: l put: (a bitAnd: 255). - l _ l + 1]]. - quo digitAt: quo digitLength + 1 - k put: (qhi bitShift: 4) - + qlo]. - rem _ rem - digitRshift: d - bytes: 0 - lookfirst: dl. - ^ Array with: quo with: rem! ! -!LargeNegativeInteger methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:05:55' prior: 50464907! - sqrt - "Answer the square root of the receiver." - ^NegativePowerError new signalReceiver: self selector: #sqrt arguments: {}! ! -!SmallInteger methodsFor: 'arithmetic' stamp: 'jmv 6/25/2019 18:01:37' prior: 16908637! - / aNumber - "Primitive. This primitive (for /) divides the receiver by the argument - and returns the result if the division is exact. Fail if the result is not a - whole integer. Fail if the argument is 0 or is not a SmallInteger. Optional. - No Lookup. See Object documentation whatIsAPrimitive." - - - aNumber isZero ifTrue: [^ZeroDivide new signalReceiver: self selector: #/ argument: aNumber ]. - ^(aNumber isMemberOf: SmallInteger) - ifTrue: [(Fraction numerator: self denominator: aNumber) reduced] - ifFalse: [super / aNumber]! ! -!SmallInteger methodsFor: 'arithmetic' stamp: 'jmv 6/25/2019 18:01:48' prior: 16908691! - quo: aNumber - "Primitive. Divide the receiver by the argument and answer with the - result. Round the result down towards zero to make it a whole integer. - Fail if the argument is 0 or is not a SmallInteger. Optional. See Object - documentation whatIsAPrimitive." - - aNumber = 0 ifTrue: [^ZeroDivide new signalReceiver: self selector: #quo: argument: aNumber ]. - (aNumber isMemberOf: SmallInteger) - ifFalse: [^ super quo: aNumber]. - (aNumber = -1 and: [self = self class minVal]) - ifTrue: ["result is aLargeInteger" ^ self negated]. - self primitiveFailed! ! -!SmallInteger methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:06:25' prior: 50464915! - sqrt - - self positive ifTrue: [^super sqrt]. - ^NegativePowerError new signalReceiver: self selector: #sqrt arguments: {}! ! -!Float64Array methodsFor: 'arithmetic' stamp: 'jmv 6/25/2019 17:43:40' prior: 50464860! - /= anObject - - ^self divideBy: anObject - ifDivisorZero: [ZeroDivide new signalReceiver: self selector: #/= argument: anObject] - ifBothZero: [ZeroDivide new signalReceiver: self selector: #/= argument: anObject]! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'jmv 6/25/2019 17:43:52' prior: 50464868! - /= anObject - - ^self divideBy: anObject - ifDivisorZero: [ZeroDivide new signalReceiver: self selector: #/= argument: anObject] - ifBothZero: [ZeroDivide new signalReceiver: self selector: #/= argument: anObject]! ! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jmv 6/25/2019 18:09:04' prior: 16921076! - maxExternalSemaphores: aSize - "Changes the size of table where external semaphores are registered. - The size can only grow, and will always be the next power of two larger than the parameter. - - Setting this at any time other than start-up can potentially lose requests. - i.e. during the realloc new storage is allocated, t - he old contents are copied and then pointers are switched. - Requests occurring during copying won't be seen if they occur to indices already copied. - The intended use is to set the table to some adequate maximum at start-up" - - self isRunningCog ifFalse: [^0]. - "The vm-header field is a short, maximum 64k entries. Well, on most platforms anyways " - (aSize < 0 or: [aSize > 16rFFFF]) ifTrue: [^Error signal: 'Must be in the range (0 to: 16rFFFF)']. - ^self vmParameterAt: 49 put: aSize! ! - -ZeroDivide class removeSelector: #dividend:! - -ZeroDivide class removeSelector: #dividend:! - -ZeroDivide class removeSelector: #signalWithDividend:! - -ZeroDivide class removeSelector: #signalWithDividend:! - -ZeroDivide removeSelector: #dividend! - -ZeroDivide removeSelector: #dividend! - -ZeroDivide removeSelector: #dividend:! - -ZeroDivide removeSelector: #dividend:! - -NegativePowerError removeSelector: #base:selector:argument:! - -NegativePowerError removeSelector: #base:selector:argument:! - -NegativePowerError removeSelector: #signalBase:selector:argument:! - -NegativePowerError removeSelector: #signalBase:selector:argument:! - -ArithmeticMessageError subclass: #NegativePowerError - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #NegativePowerError category: #'Exceptions Kernel'! -ArithmeticMessageError subclass: #NegativePowerError - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -ArithmeticMessageError subclass: #ZeroDivide - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #ZeroDivide category: #'Exceptions Kernel'! -ArithmeticMessageError subclass: #ZeroDivide - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3811-DoAnswerFloatNan-JuanVuletich-2019Jun25-18h28m-jmv.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3811] on 26 June 2019 at 10:17:44 am'! -!BlockClosure methodsFor: 'testing' stamp: 'sqr 6/26/2019 09:59:10'! - hasNonLocalReturn - "Answer whether the receiver has a method-return ('^') in its code." - | myMethod scanner preceedingBytecodeMessage end | - "Determine end of block from the instruction preceding it. - Find the instruction by using an MNU handler to capture - the instruction message sent by the scanner." - myMethod := outerContext method. - scanner := InstructionStream new method: myMethod pc: myMethod initialPC. - [scanner pc < startpc] whileTrue: - [[scanner interpretNextInstructionFor: nil] - on: MessageNotUnderstood - do: [:ex| preceedingBytecodeMessage := ex message]]. - end := preceedingBytecodeMessage arguments last + startpc - 1. - scanner method: myMethod pc: startpc. - scanner scanFor: [:byte | (byte between: 120 and: 124) or: [scanner pc > end]]. - ^scanner pc <= end! ! -!MethodContext methodsFor: 'accessing' stamp: 'sqr 6/26/2019 09:58:58'! - hasNonLocalReturn - ^closureOrNil hasNonLocalReturn! ! -!ContextPart methodsFor: 'system simulation' stamp: 'sqr 6/26/2019 09:59:16' prior: 16824643! - runSimulated: aBlock contextAtEachStep: block2 - "Simulate the execution of the argument, aBlock, until it ends. aBlock - MUST NOT contain an '^'. Evaluate block2 with the current context - prior to each instruction executed. Answer the simulated value of aBlock." - | current | - aBlock hasNonLocalReturn - ifTrue: [self error: 'simulation of blocks with ^ can run loose']. - current := aBlock asContext. - current pushArgs: Array new from: self. - [current == self] - whileFalse: - [block2 value: current. - current := current step]. - ^self pop! ! - -MethodContext removeSelector: #hasMethodReturn! - -MethodContext removeSelector: #hasMethodReturn! - -BlockClosure removeSelector: #hasMethodReturn! - -BlockClosure removeSelector: #hasMethodReturn! - -BlockClosure removeSelector: #valueUninterruptably! - -BlockClosure removeSelector: #valueUninterruptably! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3812-BlockClosureCleanup-AndresValloud-2019Jun26-09h47m-sqr.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3795] on 28 June 2019 at 10:45:24 am'! -!Integer methodsFor: 'mathematical functions' stamp: 'len 6/17/2019 04:28:05' prior: 16859591! - lcm: anInteger - "Answer the least common multiple of the receiver and anInteger. - This is the smallest non-negative integer divisible by the receiver and the argument. - If either the receiver or the argument is zero, the result is zero." - - (self = 0 or: [anInteger = 0]) ifTrue: [^ 0]. - ^self abs // (self gcd: anInteger) * anInteger abs! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3813-lcmFix-LucianoNotarfrancesco-2019Jun27-18h17m-sqr.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3725] on 5 May 2019 at 11:45:31 pm'! - -"Change Set: 3726-CuisCore-AuthorName-2019May05-23h41m -Date: 5 May 2019 -Author: Nahuel Garbezza - -When installing new updates, handle (ignore) files that are not updates"! -!ChangeSet class methodsFor: 'services' stamp: 'RNG 5/5/2019 23:44:16'! - isNewUpdate: aFile - - ^ aFile name first isDigit and: [ aFile name asNumber > SystemVersion current highestUpdate ]! ! -!ChangeSet class methodsFor: 'services' stamp: 'RNG 5/5/2019 23:41:26' prior: 16799320! - newUpdates: updatesFileDirectory - - ^ (updatesFileDirectory files select: [ :each | self isNewUpdate: each ]) - asSortedCollection: [ :a :b | a name < b name ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3814-DontFailOnExtraFilesInUpdates-NahuelGarbezza-2019May05-23h41m-RNG.1.cs.st----! - -'From Cuis 5.0 [latest update: #3814] on 1 July 2019 at 8:26:12 am'! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'jmv 7/1/2019 08:24:52' prior: 50432672! - timeStamp: aStream - "Writes system version and current time on stream aStream." - - | dateTime | - dateTime _ DateAndTime now. - aStream - nextPutAll: 'From '; - nextPutAll: Smalltalk version; - nextPutAll: ' ['; - nextPutAll: Smalltalk lastUpdateString; - nextPutAll: '] on '. - dateTime date printOn: aStream. - aStream - nextPutAll: ' at '. - dateTime time print24: false showSeconds: true on: aStream! ! -!SystemVersion methodsFor: 'printing' stamp: 'jmv 7/1/2019 08:25:27' prior: 16925852! - printOn: stream - stream - nextPutAll: self version; - nextPutAll: ' update ' , self highestUpdate printString! ! - -SystemVersion removeSelector: #datedVersion! - -SystemVersion removeSelector: #datedVersion! - -SystemDictionary removeSelector: #datedVersion! - -SystemDictionary removeSelector: #datedVersion! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3815-DontIncludeOriginalReleaseDateInStamps-JuanVuletich-2019Jul01-08h24m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3815] on 1 July 2019 at 4:37:34 pm'! -!TestCase methodsFor: 'assertions' stamp: 'jmv 7/1/2019 16:22:32'! - assert: aNumber isCloseTo: anotherNumber - - self assert: aNumber isCloseTo: anotherNumber withPrecision: self defaultPrecision ! ! -!TestCase methodsFor: 'assertions' stamp: 'jmv 7/1/2019 16:22:01'! - assert: aNumber isCloseTo: anotherNumber withPrecision: aPrecision - - self assert: (self is: aNumber closeTo: anotherNumber withPrecision: aPrecision)! ! -!TestCase methodsFor: 'assertions' stamp: 'jmv 7/1/2019 16:23:17'! - assert: aNumber isNotCloseTo: anotherNumber - - self assert: aNumber isNotCloseTo: anotherNumber withPrecision: self defaultPrecision ! ! -!TestCase methodsFor: 'assertions' stamp: 'jmv 7/1/2019 16:23:12'! - assert: aFloatNumber isNotCloseTo: anotherFloatNumber withPrecision: aPrecision - - self deny: (self is: aFloatNumber closeTo: anotherFloatNumber withPrecision: aPrecision) -! ! -!TestCase methodsFor: 'assertions' stamp: 'jmv 7/1/2019 16:37:25'! - is: aNumber closeTo: anotherNumber withPrecision: aPrecision - "This way of comparing numbers could be useful for many tests, but there is no single correct way to do it for numerical algorithms. That's why this method is here and not at Float." - - aNumber = 0 ifTrue: [ ^ anotherNumber abs < aPrecision ]. - - ^ (aNumber - anotherNumber) abs < (aPrecision * (aNumber abs max: anotherNumber abs))! ! - -TestCase removeSelector: #assert:isNearTo:! - -TestCase removeSelector: #assert:isNearTo:! - -TestCase removeSelector: #assert:isNearTo:withPrecision:! - -TestCase removeSelector: #assert:isNearTo:withPrecision:! - -TestCase removeSelector: #assert:isNotNearTo:! - -TestCase removeSelector: #assert:isNotNearTo:! - -TestCase removeSelector: #assert:isNotNearTo:withPrecision:! - -TestCase removeSelector: #assert:isNotNearTo:withPrecision:! - -TestCase removeSelector: #is:biggerThan:withPrecision:! - -TestCase removeSelector: #is:biggerThan:withPrecision:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3816-BetterNamesForTestCaseNumberHelpers-JuanVuletich-2019Jul01-16h19m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3805] on 26 June 2019 at 9:02:51 am'! -!InnerTextMorph methodsFor: 'events' stamp: 'HAW 6/26/2019 09:02:18' prior: 50449313! - keyStroke: aKeyboardEvent - - (self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - - autoCompleter - ifNil: [ self processKeyStroke: aKeyboardEvent ] - ifNotNil: [ - autoCompleter - autoCompletionAround: [ self processKeyStroke: aKeyboardEvent ] - keyStroke: aKeyboardEvent ]. - - super keyStroke: aKeyboardEvent! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3817-keyStrokeDinamicHandlerOnInnerTextMorph-HernanWilkinson-2019Jun26-09h02m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3817] on 2 July 2019 at 11:34:51 am'! -!Object methodsFor: 'testing' stamp: 'jmv 7/2/2019 08:22:13'! - isFloatOrFloatComplex - "Overridden to return true in Float and Complex" - ^ false! ! -!Float methodsFor: 'testing' stamp: 'jmv 7/2/2019 08:22:25'! - isFloatOrFloatComplex - ^ true! ! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 7/2/2019 11:30:18' prior: 50465093! - raisedTo: exponent - "Answer the receiver raised to aNumber." - - exponent isInteger ifTrue: [ - "Do the special case of integer power" - ^ self raisedToInteger: exponent]. - exponent isFraction ifTrue: [ - "Special case for fraction power by Nicolas Cellier: - If aNumber is a fraction, but result must be a Float, learn it as quickly as possible, and give quick Float answer - Allows evaluating: - (2009/2000) raisedTo: (3958333/100000) - " - ^ self raisedToFraction: exponent]. - self < 0 ifTrue: [ - ^NegativePowerError new signalReceiver: self selector: #raisedTo: argument: exponent]. - 0 = exponent ifTrue: [^ self class one]. "Special case of exponent=0" - 1 = exponent ifTrue: [^ self]. "Special case of exponent=1" - 0 = self ifTrue: [ "Special case of self = 0" - exponent < 0 - ifTrue: [^ (self raisedTo: exponent negated) reciprocal] - ifFalse: [^ self]]. - ^ (exponent * self ln) exp "Otherwise use logarithms"! ! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 7/2/2019 11:30:27' prior: 50465126! - raisedToFraction: aFraction - self isZero ifTrue: [ - aFraction negative ifTrue: [^ (self raisedToFraction: aFraction negated) reciprocal]. - ^ self ]. - self negative ifFalse: [ - ^ (self ln * aFraction) exp ]. - aFraction denominator = 2 ifTrue: [ - ^ self sqrt raisedToInteger: aFraction numerator ]. - (self negative and: [ aFraction denominator even ]) ifTrue: [ - ^NegativePowerError new signalReceiver: self selector: #raisedToFraction: argument: aFraction]. - ^ (self negated ln * aFraction) exp negated! ! -!ArithmeticMessageError methodsFor: 'exceptionDescription' stamp: 'jmv 7/2/2019 10:05:55' prior: 50465052! - defaultAction - (receiver isFloatOrFloatComplex or: [ arguments notNil and: [arguments anySatisfy: [ :a | a isFloatOrFloatComplex ]]]) ifTrue: [ - ^self floatErrorValue ]. - ^ super defaultAction! ! -!NegativePowerError methodsFor: 'signaling' stamp: 'jmv 7/2/2019 08:25:33' prior: 50465080! - floatErrorValue - ^ receiver class nan! ! -!ZeroDivide methodsFor: 'signaling' stamp: 'jmv 7/2/2019 11:13:46' prior: 50465084! - floatErrorValue - | answerClass answerSign | - - receiver isZero ifTrue: [ - answerClass _ receiver isComplex ifTrue: [ receiver class ] ifFalse: [ Float ]. - ^ answerClass nan ]. - - receiver isComplex ifFalse: [ - answerSign _ arguments first isComplex - ifTrue: [ receiver sign ] - ifFalse: [ (receiver * arguments first) sign ]. - ^ answerSign = -1 - ifTrue: [ Float negativeInfinity ] - ifFalse: [ Float infinity ]]. - - ^ receiver class infinity! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3818-ArithmeticErrorsWithComplex-JuanVuletich-2019Jul02-11h29m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3817] on 2 July 2019 at 11:35:21 am'! -!ChangeList methodsFor: 'scanning' stamp: 'jmv 7/2/2019 10:01:30' prior: 16795919! - scanCategory: category class: class meta: meta stamp: stamp - | itemPosition method | - [ - itemPosition _ file position. - method _ file nextChunk. - method size > 0 ] "done when double terminators" - whileTrue: [ - self - addItem: (ChangeRecord new file: file position: itemPosition type: #method - class: class category: category meta: meta stamp: stamp) - text: 'method: ' , class , (meta ifTrue: [' class '] ifFalse: [' ']) - , (((Smalltalk at: class ifAbsent: [Object class]) parserClass selectorFrom: method) ifNil: ['']) - , (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp])]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3819-ChangeList-fix-JuanVuletich-2019Jul02-11h34m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3817] on 1 July 2019 at 5:36:37 pm'! -!HandMorph methodsFor: 'private events' stamp: 'jmv 7/1/2019 17:36:19' prior: 50456623! - generateKeyboardEvent: evtBuf - "Generate the appropriate mouse event for the given raw event buffer" - | buttons modifiers type keyValue pressType stamp mouseScrollDirection | - stamp _ evtBuf second. - stamp = 0 ifTrue: [ stamp _ Time localMillisecondClock ]. - (evtBuf sixth <= 0 or: [ (keyValue _ Character iso8859s15CodeForUnicodeCodePoint: evtBuf sixth) isNil ]) ifTrue: [ keyValue _ Character macRomanToLatin1: evtBuf third ]. - Sensor peekEvent ifNotNil: [ :nxt | - "start: Combining diacritical marks (i.e. accents in the Linux VM)" - (nxt fourth = EventSensor eventKeyDown and: [ nxt third > 255 ]) ifTrue: [ - keyValue _ ((Character numericValue: keyValue) withDiacriticalMark: nxt third) iso8859s15Code. - Sensor - nextEvent; - nextEvent; - nextEvent ]. - "end: Combining diacritical marks (i.e. accents in the Linux VM)" - "start: Spurious LF after CR on Ctrl-Enter on Windows VM" - ((evtBuf fourth = EventSensor eventKeyChar and: [ evtBuf third = 13 ]) and: [ - nxt fourth = EventSensor eventKeyChar and: [ nxt third = 10 ]]) ifTrue: [ Sensor nextEvent - "print " ]]. - modifiers _ evtBuf fifth. - pressType _ evtBuf fourth. - pressType = EventSensor eventKeyDown ifTrue: [ - type _ #keyDown. - lastKeyDownValue _ keyValue ]. - pressType = EventSensor eventKeyUp ifTrue: [ - (keyValue = 9 and: [(modifiers anyMask: 1) and: [Smalltalk platformName = 'unix']]) - ifTrue: [ - "Linux VMs don't generate shift-tab keystroke. Turn #keyUp into #keystroke" - pressType _ EventSensor eventKeyChar ] - ifFalse: [type _ #keyUp ]]. - pressType = EventSensor eventKeyChar ifTrue: [ - type _ #keystroke. - "If Control key pressed, and the VM answers a code below 27, - it means it did the translation, convert it back to regular character: - We want to handle the meaning of ctrl ourselves." - (modifiers anyMask: 2) ifTrue: [ - "Control key pressed" - keyValue < 27 ifTrue: [ - "But we don't want to do it for Home/End/PgUp/PgDn, just for alphabetic keys" - lastKeyDownValue = keyValue ifFalse: [ - "If equal, real Home/End/PgUp/PgDn in Windows => don't translate" - (keyValue + 64 = lastKeyDownValue or: [ "If Equal, Ctrl-alphabetic in Windows => do translate" - lastKeyDownValue < 47 ]) ifTrue: [ - "Not on windows. If less (not sure about the bound, but do not translate 48: tab on Mac), alphabetic on Mac => do translate" - keyValue _ (modifiers anyMask: 1) - ifTrue: [ keyValue + 64 ] - ifFalse: [ keyValue + 96 - "shift not pressed: conver to lowercase letter" ]]]]. - "On Windows, ctrl-backSpace is reported as ctrl-forwardDelete. But keyDown is ok, so we can know and fix." - (keyValue = 127 and: [ lastKeyDownValue = 8 ]) - ifTrue: [ keyValue _ 8 ]. - "Act as if command/alt was pressed for some usual Windows ctrl-key combinations" - (self shouldControlEmulateAltFor: keyValue) ifTrue: [ modifiers _ modifiers bitOr: 8 ]]]. - buttons _ modifiers bitShift: 3. - "Linux and Windows VM send keyboard ctrl-upArrow and ctrl-downArrow when the user tries to scroll using the mouse wheel - Mac VM sends cmd-option-ctrl-shift-upArrow and cmd-option-ctrl-shift-downArrow for trackpad vertical scroll gestures, - and cmd-option-ctrl-shift-leftArrow and cmd-option-ctrl-shift-rightArrow for horizontal scroll gestures. - This way of reporting scroll events by the VM also enables scrolling using the keyboard (actually, we can't tell if user gesture was on Mouse, Trackpad or Keyboard). - But ctrl-shift and cmdAlt-shift are needed used for selecting while moving by word, line, etc. - Additionally, #ctrlArrowsScrollHorizontally allows chosing between keyboard horizontal scroll and moving word by word in text editors." - mouseScrollDirection _ nil. - "Ctrl for Keyboard or Mouse wheel gestures. All modifiers for Trackpad gestures." - (buttons = InputSensor controlKey or: [buttons = InputSensor cmdAltOptionCtrlShiftModifierKeys]) ifTrue: [ - keyValue = 30 - ifTrue: [mouseScrollDirection _ #up] - ifFalse: [keyValue = 31 - ifTrue: [mouseScrollDirection _ #down]]]. - "Ctrl for Keyboard or Mouse wheel gestures, only if preference is set. All modifiers for Trackpad gestures." - ((buttons = InputSensor controlKey and: [Preferences ctrlArrowsScrollHorizontally]) or: [buttons = InputSensor cmdAltOptionCtrlShiftModifierKeys]) ifTrue: [ - keyValue = 28 - ifTrue: [mouseScrollDirection _ #left] - ifFalse: [keyValue = 29 - ifTrue: [mouseScrollDirection _ #right]]]. - mouseScrollDirection ifNotNil: [ - ^ MouseScrollEvent new - setType: #mouseScroll - position: self morphPosition - direction: mouseScrollDirection - buttons: buttons - hand: self - stamp: stamp ]. - ^ KeyboardEvent new - setType: type - buttons: buttons - position: self morphPosition - keyValue: keyValue - hand: self - stamp: stamp! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3820-fixCtrlBackspaceOnWindows-JuanVuletich-2019Jul01-17h35m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3817] on 1 July 2019 at 8:44:05 pm'! - -"Change Set: 3818-CuisCore-AuthorName-2019Jul01-20h42m -Date: 1 July 2019 -Author: Nahuel Garbezza - -Adds a convenient CompiledMethod>>browse method"! -!CompiledMethod methodsFor: 'user interface support' stamp: 'RNG 7/1/2019 20:42:52'! - browse - - BrowserWindow fullOnClass: self methodClass selector: self selector! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3821-CompiledMethod-browse-NahuelGarbezza-2019Jul01-20h42m-RNG.1.cs.st----! - -'From Cuis 5.0 [latest update: #3821] on 3 July 2019 at 10:11:52 am'! -!Parser methodsFor: 'error correction' stamp: 'jmv 7/3/2019 10:11:08'! - sourceDelta - - | userSelectionDelta | - requestor notNil ifTrue: [ - userSelectionDelta _ requestor selectionInterval ifEmpty: [0] ifNotEmpty: [ :userSelection | userSelection first-1 ]. - encoder selector = Scanner doItSelector ifTrue: [ - ^ (Scanner selectionDoItSourceCodeHeaderSizeWithContext: false) - userSelectionDelta ]. - encoder selector = Scanner doItInSelector ifTrue: [ - ^ (Scanner selectionDoItSourceCodeHeaderSizeWithContext: true) - userSelectionDelta ]]. - - ^ 0! ! -!Parser methodsFor: 'error handling' stamp: 'jmv 7/3/2019 10:11:21' prior: 16885713! - notify: string at: location - | adjustedLocation | - adjustedLocation _ location - self sourceDelta. - requestor - ifNil: [ - (encoder == self or: [encoder isNil]) ifTrue: [^ self fail "failure setting up syntax error"]. - SyntaxErrorNotification - inClass: encoder classEncoding - category: category - withCode: - (source contents - copyReplaceFrom: adjustedLocation - to: adjustedLocation - 1 - with: string , ' ->') - doitFlag: doitFlag - errorMessage: string - location: adjustedLocation] - ifNotNil: [ - requestor - notify: string , ' ->' - at: adjustedLocation - in: source]. - ^self fail! ! -!Parser methodsFor: 'error correction' stamp: 'jmv 7/3/2019 10:11:16' prior: 50456008! - correctSelector: proposedKeyword wordIntervals: aSpots exprInterval: expInt ifAbort: abortAction - "Correct the proposedKeyword to some selector symbol, correcting the original text if such action is indicated. abortAction is invoked if the proposedKeyword couldn't be converted into a valid selector. Spots is an ordered collection of intervals within the test stream of the for each of the keyword parts." - - | correctSelector userSelection delta adjustedSpots | - "If we can't ask the user, assume that the keyword will be defined later" - self interactive ifFalse: [^proposedKeyword asSymbol]. - - "If the requestor is of an exotic kind (like a telnet server) we might not be allowed to open a PupUpMenu for querying the user" - " - ((requestor isKindOf: Editor) or: [ requestor is: #Morph ]) - ifFalse: [ ^ proposedKeyword asSymbol ]. - " - - userSelection _ requestor selectionInterval. - - delta := self sourceDelta. - adjustedSpots := aSpots collect: [ :interval | interval first - delta to: interval last - delta ]. - requestor selectFrom: adjustedSpots first first to: adjustedSpots last last. - - correctSelector _ UnknownSelector name: proposedKeyword. - correctSelector ifNil: [^abortAction value]. - - requestor selectInvisiblyFrom: userSelection first to: userSelection last. - - self substituteSelector: correctSelector keywords wordIntervals: adjustedSpots. - ^(proposedKeyword last ~~ $: - and: [correctSelector last == $:]) - ifTrue: [abortAction value] - ifFalse: [correctSelector]! ! -!Parser methodsFor: 'error correction' stamp: 'jmv 7/3/2019 10:11:19' prior: 50456058! - correctVariable: proposedVariable interval: aSpot - "Correct the proposedVariable to a known variable, or declare it as a new - variable if such action is requested. We support declaring lowercase - variables as temps or inst-vars, and uppercase variables as Globals or - ClassVars, depending on whether the context is nil (class=UndefinedObject). - Spot is the interval within the test stream of the variable. - rr 3/4/2004 10:26 : adds the option to define a new class. " - - "Check if this is an i-var, that has been corrected already (ugly)" - - "Display the pop-up menu" - - | userSelection action delta spot | - (encoder classEncoding instVarNames includes: proposedVariable) ifTrue: [ - ^InstanceVariableNode new - name: proposedVariable - index: (encoder classEncoding allInstVarNames indexOf: proposedVariable)]. - - "First check to see if the requestor knows anything about the variable" - (requestor bindingOf: proposedVariable) - ifNotNil: [ :binding | ^ encoder global: binding name: proposedVariable]. - - "If we can't ask the user for correction, make it undeclared" - self interactive ifFalse: [^encoder undeclared: proposedVariable]. - - userSelection _ requestor selectionInterval. - delta _ self sourceDelta. - spot _ aSpot first - delta to: aSpot last - delta. - requestor selectFrom: spot first to: spot last. - - "Build the menu with alternatives" - action _ UndeclaredVariable - signalFor: self - name: proposedVariable - inRange: spot. - action ifNil: [^self fail]. - - "Execute the selected action" - requestor selectInvisiblyFrom: userSelection first to: userSelection last. - ^action value! ! - -Parser removeSelector: #correctSourceDelta! - -Parser removeSelector: #correctSourceDelta! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3822-NothingMoreExpectedFix-JuanVuletich-2019Jul03-10h10m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3822] on 3 July 2019 at 9:40:21 am'! -!BlockClosure methodsFor: 'testing' stamp: 'jmv 7/3/2019 09:37:11'! - isCleanClosure - "A clean closure is one that doesn't really need the home context because: - - It doesn't send messages to self or super - - It doesn't access any instance variable - - It doesn't access any outer temp - - It doesn't do non local return (return from method to caller, i.e. ^ something) - Therefore it doesn't close over a lexical scope, and in this sense they are trivial. - They can also be called 'context free' or 'simple block'. - " - - | recreated source | - source _ self decompile decompileString. - - "This catches any acess to outer context!!" - recreated _ [ Compiler evaluate: source ] on: UndeclaredVariableWarning do: [ :ex | ^ false ]. - - "Fail if returns from outer context, or uses self" - Smalltalk - eliotsClosureMeasurementsOn: recreated outerContext method - over: [ :closuresCount :hasIndirectTemps :anyClosureHasCopied :anyClosureDoesNonLocalReturn :anyClosureUsesSelf | - anyClosureDoesNonLocalReturn ifTrue: [ ^ false ]. - anyClosureUsesSelf ifTrue: [ ^ false ]]. - - "Ok." - ^true! ! -!BlockClosure methodsFor: 'objects from disk' stamp: 'jmv 7/3/2019 09:38:53' prior: 16788614! - objectForDataStream: refStrm - "I am about to be written on an object file. Write a textual reference instead." - self isCleanClosure ifFalse: [ - self error: 'Can only serialize clean (context free) closures.' ]. - ^ DiskProxy - global: #Compiler - selector: #evaluate: - args: (Array with: self decompile decompileString)! ! -!SystemDictionary methodsFor: 'Closure measurements' stamp: 'jmv 7/3/2019 09:24:10' prior: 16924388! - browseMethodsWithClosuresThatAccessOuterTemps - " - Smalltalk browseMethodsWithClosuresThatAccessOuterTemps - " - - self - browseMessageList: (self allSelect: [ :m | - self eliotsClosureMeasurementsOn: m over: [ :closuresCount - :hasIndirectTemps :anyClosureHasCopied :anyClosureDoesNonLocalReturn :anyClosureUsesSelf | - anyClosureHasCopied ]. - ]) - name: 'Closures that read or write to outer temps'! ! -!SystemDictionary methodsFor: 'Closure measurements' stamp: 'jmv 7/3/2019 09:24:14' prior: 16924404! - browseMethodsWithClosuresThatOnlyReadOuterTemps - " - Smalltalk browseMethodsWithClosuresThatOnlyReadOuterTemps - " - - self - browseMessageList: (self allSelect: [ :m | - self eliotsClosureMeasurementsOn: m over: [ :closuresCount - :hasIndirectTemps :anyClosureHasCopiedValues :anyClosureDoesNonLocalReturn :anyClosureUsesSelf | - anyClosureHasCopiedValues & hasIndirectTemps not]. - ]) - name: 'Closures that read but not write to outer temps'! ! -!SystemDictionary methodsFor: 'Closure measurements' stamp: 'jmv 7/3/2019 09:24:19' prior: 16924421! - browseMethodsWithClosuresThatWriteOuterTemps - " - Smalltalk browseMethodsWithClosuresThatWriteOuterTemps - " - - self - browseMessageList: (self allSelect: [ :m | - self eliotsClosureMeasurementsOn: m over: [ :closuresCount - :hasIndirectTemps :anyClosureHasCopied :anyClosureDoesNonLocalReturn :anyClosureUsesSelf | - hasIndirectTemps ]. - ]) - name: ' Closures that write to outer temps'! ! -!SystemDictionary methodsFor: 'Closure measurements' stamp: 'jmv 7/3/2019 09:24:25' prior: 16924436! - browseMethodsWithClosuresThatWriteOuterTempsButCleanOtherwise - " - Smalltalk browseMethodsWithClosuresThatWriteOuterTempsButCleanOtherwise - " - - self - browseMessageList: (self allSelect: [ :m | - self eliotsClosureMeasurementsOn: m over: [ :closuresCount - :hasIndirectTemps :anyClosureHasCopied :anyClosureDoesNonLocalReturn :anyClosureUsesSelf | - hasIndirectTemps and: [ anyClosureDoesNonLocalReturn not and: [ anyClosureUsesSelf not ] ] ]. - ]) - name: ' Closures that write to outer temps, but clean otherwise'! ! -!SystemDictionary methodsFor: 'Closure measurements' stamp: 'jmv 7/3/2019 09:24:29' prior: 16924474! - browseMethodsWithMoreThanOneClosure - " - Smalltalk browseMethodsWithMoreThanOneClosure - " - - self - browseMessageList: (self allSelect: [ :m | - self eliotsClosureMeasurementsOn: m over: [ :closuresCount - :hasIndirectTemps :anyClosureHasCopied :anyClosureDoesNonLocalReturn :anyClosureUsesSelf | - closuresCount > 1 ]. - ]) - name: 'Methods with more than one Closure'! ! -!SystemDictionary methodsFor: 'Closure measurements' stamp: 'jmv 7/3/2019 09:24:34' prior: 16924489! - browseMethodsWithOnlyCleanClosures - " - Smalltalk browseMethodsWithOnlyCleanClosures - " - self - browseMessageList: ( - self allSelect: [ :m | - self eliotsClosureMeasurementsOn: m over: [ :closuresCount - :hasIndirectTemps :anyClosureHasCopied :anyClosureDoesNonLocalReturn :anyClosureUsesSelf | - closuresCount > 0 and: [ - (anyClosureHasCopied or: [ anyClosureDoesNonLocalReturn or: [ anyClosureUsesSelf ]]) not ]. - ] - ]) - name: 'Methods with only Clean Closures'! ! -!SystemDictionary methodsFor: 'Closure measurements' stamp: 'jmv 7/3/2019 09:24:43' prior: 16924507! - closuresInfoStringForClass: aClass selector: aSelector - " - Smalltalk closuresInfoStringFor: PlayingWithClosures class >> #exp01Argument - " - | answer all someDo noneDoes method | - method _ aClass compiledMethodAt: aSelector ifAbsent: [ ^'' ]. - self eliotsClosureMeasurementsOn: method over: [ - :closuresCount :hasIndirectTemps :anyClosureHasCopied :anyClosureDoesNonLocalReturn :anyClosureUsesSelf | - - closuresCount > 0 - ifFalse: [ answer _ 'No real (non-optimized) Closures' ] - ifTrue: [ - closuresCount = 1 - ifTrue: [ - answer _ '1 Closure: '. - all _ ''. - someDo _ 'does'. - noneDoes _ 'does not' ] - ifFalse: [ - answer _ closuresCount printString, ' Closures: '. - all _ 'all '. - someDo _ 'some do'. - noneDoes _ 'none does' ]. - (anyClosureHasCopied or: [ anyClosureDoesNonLocalReturn or: [ anyClosureUsesSelf ]]) - ifFalse: [ answer _ answer, all, 'clean' ] - ifTrue: [ - answer _ answer, (anyClosureHasCopied - ifTrue: [ - hasIndirectTemps - ifTrue: [ someDo, ' write (and maybe ', someDo, ' read)' ] - ifFalse: [ someDo, ' read (but ', noneDoes, ' write)' ] ] - ifFalse: [ noneDoes, ' access' ]), ' outer temps; '. - answer _ answer, (anyClosureDoesNonLocalReturn - ifTrue: [ someDo ] - ifFalse: [ noneDoes ]), ' ^return; '. - answer _ answer, (anyClosureUsesSelf - ifTrue: [ someDo ] - ifFalse: [ noneDoes ]), ' use self' - ]. - ] - ]. - ^answer! ! -!SystemDictionary methodsFor: 'Closure measurements' stamp: 'jmv 7/3/2019 09:34:34' prior: 16924556! - eliotsClosureMeasurements - " - Smalltalk eliotsClosureMeasurements - From http://www.mirandabanda.org/cogblog/2008/11/14/mechanised-modifications-and-miscellaneous-measurements/ - by Eliot Miranda - " - | numMethods numMethodsWithClosure numMethodsWithIndirectTemps - numClosures numClosuresWithCopiedValues numCopiedValuesForClosure - numRemoteTemps numScopesWithRemoteTemps - nonLocalReturnsInClosure closureUsesSelfs nonLocalReturnAndUsesSelfs numClean | - - numMethods := numMethodsWithClosure := numMethodsWithIndirectTemps := - numClosures := numClosuresWithCopiedValues := numCopiedValuesForClosure := - numRemoteTemps := numScopesWithRemoteTemps := - nonLocalReturnsInClosure := closureUsesSelfs := nonLocalReturnAndUsesSelfs := numClean := 0. - self allSelect: [ :m | - | s hasClosure hasIndirectTemps blkPc blkSz doesNonLocalReturn usesSelf hasCopied sel | - sel _ false. - hasClosure := hasIndirectTemps := false. - s := InstructionStream on: m. - s scanFor: - [:b| - b = 143 "closure creation" ifTrue: - [hasClosure := true. - numClosures := numClosures + 1. - s followingByte >= 16 ifTrue: - [numClosuresWithCopiedValues := numClosuresWithCopiedValues + 1. - numCopiedValuesForClosure := numCopiedValuesForClosure + (s followingByte >> 4)]]. - (b = 138 "indirect temp vector creation" - and: [s followingByte <= 127]) ifTrue: - [hasIndirectTemps := true. - numScopesWithRemoteTemps := numScopesWithRemoteTemps + 1. - numRemoteTemps := numRemoteTemps + s followingByte]. - false]. - numMethods := numMethods + 1. - hasClosure ifTrue: - [numMethodsWithClosure := numMethodsWithClosure + 1. - s pc: m initialPC; scanFor: [:b| b = 143]. - -"jmv-This looks like the correct place to do this" - hasCopied := s followingByte >= 16. - - blkSz := s interpretNextInstructionFor: BlockStartLocator new. - blkPc := s pc. - doesNonLocalReturn := usesSelf := false. - -"jmv-Doing this here looks like a bug. See the other comment" - hasCopied := s followingByte >= 16. - -"jmv-Another bug. This only considers the first closure (and any nested closure in it), but not later ones" - - s scanFor: - [:b| - s pc >= (blkPc + blkSz) - ifTrue: [true] - ifFalse: - [doesNonLocalReturn := doesNonLocalReturn or: [s willReturn and: [s willBlockReturn not]]. - usesSelf := usesSelf or: [b = 112 "pushSelf" - or: [b < 16 "pushInstVar" - or: [(b = 128 and: [s followingByte <= 63]) "pushInstVar" - or: [(b between: 96 and: 96 + 7) "storePopInstVar" - or: [(b = 130 and: [s followingByte <= 63]) "storePopInstVar" - or: [(b = 129 and: [s followingByte <= 63]) "storeInstVar" - or: [b = 132 and: [s followingByte = 160]]]]]]]]. - false]]. - doesNonLocalReturn ifTrue: - [nonLocalReturnsInClosure := nonLocalReturnsInClosure + 1]. - usesSelf ifTrue: - [closureUsesSelfs := closureUsesSelfs + 1]. - (doesNonLocalReturn and: [usesSelf]) ifTrue: - [nonLocalReturnAndUsesSelfs := nonLocalReturnAndUsesSelfs + 1]. - (doesNonLocalReturn or: [usesSelf or: [hasCopied]]) ifFalse: - [numClean := numClean + 1]]. - hasIndirectTemps ifTrue: [numMethodsWithIndirectTemps := numMethodsWithIndirectTemps + 1]. - sel]. -^ { {'Methods'. numMethods}. {'MethodsWithClosure'. numMethodsWithClosure}. {'MethodsWithIndirectTemps'. numMethodsWithIndirectTemps}. - {'Closures'. numClosures}. {'CopiedValuesForClosures'. numCopiedValuesForClosure}. {'ClosuresWithCopiedValues'. numClosuresWithCopiedValues}. - {'RemoteTemps'. numRemoteTemps}. {'ScopesWithRemoteTemps'. numScopesWithRemoteTemps}. - {'MethodsWithNonLocalReturnsInClosures'. nonLocalReturnsInClosure}. {'MethodsWithReferencesToSelfInClosures'. closureUsesSelfs}. {'Both'. nonLocalReturnAndUsesSelfs}. - {'MethodsWithOnlyCleanClosures'. numClean} }! ! -!SystemDictionary methodsFor: 'Closure measurements' stamp: 'jmv 7/3/2019 09:30:32' prior: 16924733! - eliotsClosureMeasurements2 - " - Smalltalk eliotsClosureMeasurements2 - " - | numMethods numMethodsWithClosure numMethodsWithIndirectTemps anyClosureDoesNonLocalReturnCount anyClosureUsesSelfCount bothCount onlyCleanBlocksCount anyClosureHasCopiedCount | - - numMethods := numMethodsWithClosure := numMethodsWithIndirectTemps := - anyClosureDoesNonLocalReturnCount := anyClosureUsesSelfCount := bothCount := onlyCleanBlocksCount := 0. - anyClosureHasCopiedCount _ 0. - self allSelect: [ :m | - self eliotsClosureMeasurementsOn: m over: [ :closuresCount :hasIndirectTemps :anyClosureHasCopied :anyClosureDoesNonLocalReturn :anyClosureUsesSelf | - numMethods := numMethods + 1. - closuresCount > 0 ifTrue: [ numMethodsWithClosure := numMethodsWithClosure + 1 ]. - hasIndirectTemps ifTrue: [ numMethodsWithIndirectTemps := numMethodsWithIndirectTemps + 1]. - anyClosureDoesNonLocalReturn ifTrue: [ anyClosureDoesNonLocalReturnCount := anyClosureDoesNonLocalReturnCount + 1]. - anyClosureUsesSelf ifTrue: [ anyClosureUsesSelfCount := anyClosureUsesSelfCount + 1]. - (anyClosureDoesNonLocalReturn and: [anyClosureUsesSelf]) ifTrue: [ bothCount := bothCount + 1]. - closuresCount > 0 ifTrue: [ - (anyClosureDoesNonLocalReturn or: [anyClosureUsesSelf or: [anyClosureHasCopied]]) ifFalse: [ - onlyCleanBlocksCount := onlyCleanBlocksCount + 1]]. - anyClosureHasCopied ifTrue: [ anyClosureHasCopiedCount _ anyClosureHasCopiedCount + 1 ]. - false. - ] - ]. - ^{ - {'Methods'. numMethods}. {'MethodsWithClosure'. numMethodsWithClosure}. - {'WithClosuresAccessingOuterTemps'. anyClosureHasCopiedCount}. - {'WithClosuresWritingOuterTemps'. numMethodsWithIndirectTemps}. - {'WithNonLocalReturnsInClosures'. anyClosureDoesNonLocalReturnCount}. - {'WithReferencesToSelfInClosures'. anyClosureUsesSelfCount}. - {'BothAbove'. bothCount}. - {'WithOnlyCleanClosures'. onlyCleanBlocksCount}. - }! ! -!SystemDictionary methodsFor: 'Closure measurements' stamp: 'jmv 7/3/2019 09:30:39' prior: 16924794! -eliotsClosureMeasurements2On: aMethod - " - A Couple of Clean Closures - Smalltalk eliotsClosureMeasurements2On: PlayingWithClosures class >> #exp01Argument - Smalltalk eliotsClosureMeasurements2On: PlayingWithClosures class >> #exp01LocalTemp - - Closures reading and writing to outer temps - Smalltalk eliotsClosureMeasurements2On: PlayingWithClosures class >> #exp01RemoteTemp - Smalltalk eliotsClosureMeasurements2On: PlayingWithClosures class >> #exp01RemoteTempWithAssignment - - Closure doing an method return - Smalltalk eliotsClosureMeasurements2On: PlayingWithClosures class >> #exp01UpArrowReturn - - Closures sending messages to self & super - Smalltalk eliotsClosureMeasurements2On: PlayingWithClosures class >> #exp01SelfSend - Smalltalk eliotsClosureMeasurements2On: PlayingWithClosures class >> #exp01SuperSend - - A couple of non-closures, i.e. blocks that are optimized by the compiler and a closure is never created - Smalltalk eliotsClosureMeasurements2On: PlayingWithClosures class >> #exp01RemoteTempOptimized - Smalltalk eliotsClosureMeasurements2On: PlayingWithClosures class >> #exp01RemoteTempOptimizedWithAssignment - - A remote temp whose declaration can not be moved inside the block - Smalltalk eliotsClosureMeasurements2On: PlayingWithClosures class >> #exp01RemoteTempCantBeMovedInside - Smalltalk eliotsClosureMeasurements2On: PlayingWithClosures class >> #exp01RemoteTempAssignedTwice - A remote temp whose declaration can be moved inside the block - Smalltalk eliotsClosureMeasurements2On: PlayingWithClosures class >> #exp01RemoteTempCanBeMovedInside - A not-so remote temp. The declaration was moved inside the block, making it a clean block - Smalltalk eliotsClosureMeasurements2On: PlayingWithClosures class >> #exp01LocalTemp - " - | numMethods numMethodsWithClosure numMethodsWithIndirectTemps anyClosureDoesNonLocalReturnCount anyClosureUsesSelfCount bothCount onlyCleanBlocksCount anyClosureHasCopiedCount | - - numMethods := numMethodsWithClosure := numMethodsWithIndirectTemps := - anyClosureDoesNonLocalReturnCount := anyClosureUsesSelfCount := bothCount := onlyCleanBlocksCount := 0. - anyClosureHasCopiedCount _ 0. - self eliotsClosureMeasurementsOn: aMethod over: [ :closuresCount :hasIndirectTemps :anyClosureHasCopied :anyClosureDoesNonLocalReturn :anyClosureUsesSelf | - numMethods := numMethods + 1. - closuresCount > 0 ifTrue: [ numMethodsWithClosure := numMethodsWithClosure + 1 ]. - hasIndirectTemps ifTrue: [ numMethodsWithIndirectTemps := numMethodsWithIndirectTemps + 1]. - anyClosureDoesNonLocalReturn ifTrue: [ anyClosureDoesNonLocalReturnCount := anyClosureDoesNonLocalReturnCount + 1]. - anyClosureUsesSelf ifTrue: [ anyClosureUsesSelfCount := anyClosureUsesSelfCount + 1]. - (anyClosureDoesNonLocalReturn and: [anyClosureUsesSelf]) ifTrue: [ bothCount := bothCount + 1]. - closuresCount > 0 ifTrue: [ - (anyClosureDoesNonLocalReturn or: [anyClosureUsesSelf or: [anyClosureHasCopied]]) ifFalse: [ - onlyCleanBlocksCount := onlyCleanBlocksCount + 1]]. - anyClosureHasCopied ifTrue: [ anyClosureHasCopiedCount _ anyClosureHasCopiedCount + 1 ]. - ]. - ^{ - {'Methods'. numMethods}. {'MethodsWithClosure'. numMethodsWithClosure}. - {'WithClosuresAccessingOuterTemps'. anyClosureHasCopiedCount}. - {'WithClosuresWritingOuterTemps'. numMethodsWithIndirectTemps}. - {'WithNonLocalReturnsInClosures'. anyClosureDoesNonLocalReturnCount}. - {'WithReferencesToSelfInClosures'. anyClosureUsesSelfCount}. - {'BothAbove'. bothCount}. - {'WithOnlyCleanClosures'. onlyCleanBlocksCount}. - }! ! -!SystemDictionary methodsFor: 'Closure measurements' stamp: 'jmv 7/3/2019 09:28:27' prior: 16924906! - eliotsClosureMeasurementsOn: m over: aFiveArgBlock - " - See senders. - Or try something like: - Smalltalk - eliotsClosureMeasurementsOn: FileList >> #defaultContents - over: [ :closuresCount :hasCopiedValuesForClosure :hasIndirectTemps :anyClosureHasCopied :anyClosureDoesNonLocalReturn :anyClosureUsesSelf | - (Array with: closuresCount with: hasCopiedValuesForClosure with: hasIndirectTemps with: anyClosureHasCopied with: anyClosureDoesNonLocalReturn with: anyClosureUsesSelf)] - - From http://www.mirandabanda.org/cogblog/2008/11/14/mechanised-modifications-and-miscellaneous-measurements/ - by Eliot Miranda - - Note: This could perhaps be refactored to use the newer #embeddedBlockClosures and testing methods on the closures themselves. - " - | s nextScanStart thisClosureHasCopied closuresCount hasIndirectTemps blkPc blkSz anyClosureHasCopied anyClosureDoesNonLocalReturn anyClosureUsesSelf analyzedClosures | - closuresCount := 0. - hasIndirectTemps := false. - anyClosureHasCopied := anyClosureDoesNonLocalReturn := anyClosureUsesSelf := false. - s := InstructionStream on: m. - s scanFor: [ :b | - b = 16r8F "16r8F = 143 closure creation" ifTrue: [ - closuresCount := closuresCount + 1]. - (b = 16r8A "16r8A = 138indirect temp vector creation" and: [ s followingByte <= 127]) ifTrue: [ - hasIndirectTemps := true]. - false]. - nextScanStart := m initialPC. - analyzedClosures := 0. - [ analyzedClosures < closuresCount ] whileTrue: [ - s pc: nextScanStart; scanFor: [ :b | b = 16r8F ]. "16r8F = 143 Search for first closure" - analyzedClosures := analyzedClosures + 1. - thisClosureHasCopied := s followingByte >= 16r10. - anyClosureHasCopied := anyClosureHasCopied | thisClosureHasCopied. - blkSz := s interpretNextInstructionFor: BlockStartLocator new. "Findout size of first closure" - blkPc := s pc. - s scanFor: [ :b | - s pc >= (blkPc + blkSz) - ifTrue: [ - nextScanStart := s pc. - true] - ifFalse: [ - b = 16r8F ifTrue: [ - thisClosureHasCopied := s followingByte >= 16r10. - anyClosureHasCopied := anyClosureHasCopied | thisClosureHasCopied. - analyzedClosures := analyzedClosures + 1 ]. - anyClosureDoesNonLocalReturn := anyClosureDoesNonLocalReturn or: [s willReturn and: [s willBlockReturn not]]. - anyClosureUsesSelf := anyClosureUsesSelf or: [b = 16r70 "pushSelf" - or: [b < 16r10 "pushInstVar" - or: [(b = 16r80 and: [s followingByte <= 16r3F]) "pushInstVar" - or: [(b between: 16r60 and: 16r60 + 7) "storePopInstVar" - or: [(b = 16r82 and: [s followingByte <= 63]) "storePopInstVar" - or: [(b = 16r81 and: [s followingByte <= 63]) "storeInstVar" - or: [b = 16r84 and: [s followingByte = 160]]]]]]]]. - false]]]. - ^aFiveArgBlock valueWithArguments: (Array - with: closuresCount - with: hasIndirectTemps - with: anyClosureHasCopied - with: anyClosureDoesNonLocalReturn - with: anyClosureUsesSelf)! ! - -BlockClosure removeSelector: #isTrivialClosure! - -BlockClosure removeSelector: #isTrivialClosure! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3823-BetterNamesForClosuresStuff-JuanVuletich-2019Jul03-09h23m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3823] on 11 July 2019 at 2:45:03 pm'! -!ProtocolBrowser methodsFor: 'accessing' stamp: 'HAW 7/11/2019 14:44:31' prior: 50374615! - labelString - "Answer the string for the window title" - - ^ 'Protocol for: ', baseClass name, ' up to: ', (selectedName ifNil: [ ProtoObject name asString ])! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3824-ProtocolBrowserFix-HernanWilkinson-2019Jul11-14h35m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3823] on 11 July 2019 at 5:10:57 pm'! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 7/11/2019 16:14:04' prior: 50452979! - withMethodNodeAndClassDo: aBlock ifErrorsParsing: anErrorBlock - - | selectedClass methodNode | - - "I have to do this because some codeProviders do no answer selectedClassOrMetaClass like the Workspace - Hernan" - selectedClass := [ self codeProvider selectedClassOrMetaClass ] on: Error do: [ :anError | anError return: UndefinedObject ]. - [ methodNode := selectedClass methodNodeFor: model actualContents ] on: Error do: [ :anError | ^ anErrorBlock value: anError ]. - - ^aBlock value: methodNode value: selectedClass.! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3825-ReturnOnWithMethodNodeAndClassDo-HernanWilkinson-2019Jul11-14h45m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3823] on 11 July 2019 at 5:44:59 pm'! -!Editor methodsFor: 'new selection' stamp: 'HAW 7/11/2019 17:31:59'! - wordRangeLeftDelimiters: leftDelimiters rightDelimiters: rightDelimiters startingAt: pointIndex - "Select delimited text or word--the result of double-clicking." - - | initialDelimiter finalDelimiter direction match level string here hereChar start stop | - string _ self privateCurrentString. - string size < 2 ifTrue: [^1 to: 1]. - here _ pointIndex min: string size max: 2. - initialDelimiter _ string at: here - 1. - match _ leftDelimiters indexOf: initialDelimiter. - match > 0 - ifTrue: [ - "delimiter is on left -- match to the right" - start _ here. - direction _ 1. - here _ here - 1. - finalDelimiter _ rightDelimiters at: match] - ifFalse: [ - initialDelimiter _ string at: here. - match _ rightDelimiters indexOf: initialDelimiter. - match > 0 - ifTrue: [ - "delimiter is on right -- match to the left" - stop _ here - 1. - direction _ -1. - finalDelimiter _ leftDelimiters at: match] - ifFalse: [ - "no delimiters -- select a token" - direction _ -1]]. - level _ 1. - [level > 0 and: [direction > 0 - ifTrue: [here < string size] - ifFalse: [here > 1]]] - whileTrue: [ - hereChar _ string at: (here _ here + direction). - match = 0 - ifTrue: [ - "token scan goes left, then right" - hereChar isValidInIdentifiers "Consider $: as a word separator" - ifTrue: [ - here = 1 - ifTrue: [ - start _ 1. - "go right if hit string start" - direction _ 1]] - ifFalse: [ - direction < 0 - ifTrue: [ - start _ here + 1. - "go right if hit non-token" - direction _ 1] - ifFalse: [level _ 0]]] - ifFalse: [ - "delimiter match just counts nesting level" - hereChar = finalDelimiter - ifTrue: [level _ level - 1"leaving nest"] - ifFalse: [ - hereChar = initialDelimiter - ifTrue: [level _ level + 1"entering deeper nest"]]]]. - level > 0 ifTrue: [ - leftDelimiters size + rightDelimiters size = 0 ifFalse: [ - "If we failed to find final delimiter, then just select word." - ^self wordRangeLeftDelimiters: '' rightDelimiters: '' ]. - here _ here + direction ]. - ^ direction > 0 - ifTrue: [ - "If a word ends with $: (a keyword), consider it part of the word" - hereChar = $: ifTrue: [here _ here + 1]. - start to: here - 1] - ifFalse: [ - "But if a word starts with $: (this is the argument to a keyword), then it is not part of the word." - here + 1 to: stop]! ! -!Editor methodsFor: 'new selection' stamp: 'HAW 7/11/2019 17:37:54'! - wordRangeUnder: aPositionInText - - ^self wordRangeLeftDelimiters: self wordLeftDelimiters rightDelimiters: self wordRightDelimiters startingAt: aPositionInText ! ! -!TextEditor methodsFor: 'model access' stamp: 'HAW 7/11/2019 17:37:01'! - wordUnder: aPositionInText - - | wordUnderCursorRange word indexOfSpace | - - wordUnderCursorRange := self wordRangeUnder: aPositionInText. - word := (model actualContents copyFrom: wordUnderCursorRange first to: wordUnderCursorRange last) asString. - - "I have to handle the edge case where the cursor is for example between a ' and the first letter of the word. - In that case the range will include words with spaces - Hernan" - indexOfSpace := word indexOf: $ ifAbsent: [ ^word ]. - - ^word first: indexOfSpace -1 - - ! ! -!Editor methodsFor: 'new selection' stamp: 'HAW 7/11/2019 17:32:34' prior: 50452304! - wordRangeLeftDelimiters: leftDelimiters rightDelimiters: rightDelimiters - "Select delimited text or word--the result of double-clicking." - - ^self wordRangeLeftDelimiters: leftDelimiters rightDelimiters: rightDelimiters startingAt: self pointIndex ! ! -!TextEditor methodsFor: 'model access' stamp: 'HAW 7/11/2019 17:39:22' prior: 50452392! - wordUnderCursor - - ^self wordUnder: self pointIndex! ! - -Editor removeSelector: #wordUnderCursorRange! - -Editor removeSelector: #wordUnderCursorRange! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3826-BetterWordRangeSupport-HernanWilkinson-2019Jul11-17h10m-HAW.1.cs.st----! - -----SNAPSHOT----(12 July 2019 10:26:06) Cuis5.0-3826-32.image priorSource: 4236883! - -----QUIT----(12 July 2019 10:26:34) Cuis5.0-3826-32.image priorSource: 4342542! - -----STARTUP---- (23 August 2019 10:04:32) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-3826-32.image! - - -'From Cuis 5.0 [latest update: #3826] on 17 July 2019 at 5:45:34 pm'! -!InspectorWindow methodsFor: 'GUI building' stamp: 'HAW 7/17/2019 17:34:49'! - buildContentsText - - | contentsText | - - contentsText _ TextModelMorph - textProvider: model - textGetter: #acceptedContents - textSetter: #accept: - selectionGetter: #contentsSelection. - - ^contentsText! ! -!InspectorWindow methodsFor: 'GUI building' stamp: 'HAW 7/17/2019 17:35:31'! - buildEvaluatorText - - | evaluatorText | - - evaluatorText _ (TextModelMorph textProvider: model) - askBeforeDiscardingEdits: false; - emptyTextDisplayMessage: 'Smalltalk expression'. - - ^evaluatorText ! ! -!InspectorWindow methodsFor: 'GUI building' stamp: 'HAW 7/17/2019 17:34:02'! - buildList - - | list | - - list _ PluggableListMorph - model: model - listGetter: #fieldList - indexGetter: #selectionIndex - indexSetter: #toggleIndex: - mainView: self - menuGetter: #fieldListMenu - keystrokeAction: #inspectorKey:from:. - list doubleClickSelector: #inspectSelection. - - ^list! ! -!InspectorWindow methodsFor: 'GUI building' stamp: 'HAW 7/17/2019 17:35:57' prior: 50455802! - buildMorphicWindow - " Inspector openOn: SystemOrganization " - | contentsText list upperRow evaluatorText label | - - "Build widgets. We'll assemble them below." - list _ self buildList. - contentsText _ self buildContentsText. - evaluatorText _ self buildEvaluatorText. - - "Upper row has two widgets, side by side: the list of variables at the left side, and the variable contents pane at the right side." - upperRow _ LayoutMorph newRow. - upperRow - addMorph: list proportionalWidth: 0.3; - addAdjusterAndMorph: contentsText proportionalWidth: 0.7. - "Inspector Window has two rows: At the top, the one we just bult. Below it, the evaluation pane." - self layoutMorph - addMorph: upperRow proportionalHeight: 0.7; - addAdjusterAndMorph: evaluatorText proportionalHeight: 0.3. - "Set label" - label _ [model object printStringLimitedTo: 64] - on: UnhandledError - do: [:ex | ex return: model object class printString, ' (printing failed)']. - (label includesSubString: model object class name) - ifFalse: [label _ model object class name, ': ', label]. - self setLabel: label! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3827-InspectorWindowGUIBuildingRefactoring-HernanWilkinson-2019Jul17-12h40m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3826] on 19 July 2019 at 8:20:27 am'! -!CodeWindow methodsFor: 'keyboard shortcuts' stamp: 'HAW 7/19/2019 08:19:18' prior: 50458196! - messageListKey: aChar from: view - "Respond to a Command key. I am a model with a code pane, and I also - have a listView that has a list of methods. The view knows how to get - the list and selection." - - | sel class | - aChar == $D ifTrue: [^ model toggleDiffing]. - - sel _ model selectedMessageName. - aChar == $m ifTrue: [ "These next two put up a type in if no message selected" - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllImplementorsOf: to: Smalltalk]. - aChar == $n ifTrue: [ - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllCallsOn: to: Smalltalk]. - - aChar == $M ifTrue: [ ^ self browseActualImplementorsOfSelectedMethod ]. - aChar == $B ifTrue: [ ^ self browseActualSendersOfSelectedMethod ]. - - "The following require a class selection" - (class _ model selectedClassOrMetaClass) ifNil: [^ self ]. - aChar == $b ifTrue: [^ BrowserWindow fullOnClass: class selector: sel]. - aChar == $N ifTrue: [^ self browseClassRefs]. - aChar == $i ifTrue: [^ self methodHierarchy]. - aChar == $h ifTrue: [^ self browseHierarchy]. - aChar == $p ifTrue: [^ self browseFullProtocol]. - aChar == $R ifTrue: [^ model renameClass]. - - sel - ifNotNil: [ - "The following require a method selection" - aChar == $o ifTrue: [^ model fileOutMessage]. - aChar == $c ifTrue: [^ model copySelector]. - aChar == $v ifTrue: [^ self browseVersions]. - aChar == $C ifTrue: [^ model showHomeCategory]. - aChar == $O ifTrue: [^ self openSingleMessageBrowser]. - aChar == $x ifTrue: [^ model removeMessage]. - aChar == $t ifTrue: [^ model runMethodTest]. - aChar == $r ifTrue: [^ model debugMethodTest]. - aChar == $R ifTrue: [^ self renameSelector]] - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3828-CuisCore-HernanWilkinson-2019Jul17-17h45m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3826] on 14 July 2019 at 3:54:15 pm'! -!DirectoryEntry class methodsFor: 'instance creation' stamp: 'jmv 7/14/2019 15:49:59' prior: 50406645! - currentDirectory - "Answer the current directory. - - In Unix it is the current directory in the OS shell that started us. - In Windows the same happens if the image file is in a subree of the Windows current directory. - - But it defaults to the directory in wich this Smalltalk image was started (or last saved) if this fails - (this usually happens, for example, if the image is dropped on the VM in a Windows explorer). - See #getCurrentWorkingDirectory - - DirectoryEntry currentDirectory - " - - CurrentDirectory ifNil: [ - CurrentDirectory _ Smalltalk getCurrentWorkingDirectory - ifNotNil: [ :wd | self withPathName: wd ] - ifNil: [ (self withPathName: Smalltalk imagePath) parent ]]. - ^ CurrentDirectory! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -DirectoryEntry releaseClassCachedState! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3829-CurrentDirectoryFix-JuanVuletich-2019Jul14-15h49m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3829] on 1 August 2019 at 11:18:12 am'! -!MouseEvent methodsFor: 'button state' stamp: 'jmv 8/1/2019 10:45:48'! - turnMouseButton1Into2 - "Answer true if modifier keys are such that button 1 should be considered as button 2. - ctrl - click -> right click - " - - (self controlKeyPressed and: [self shiftPressed not]) ifTrue: [ ^ true ]. - ^ false! ! -!MouseEvent methodsFor: 'button state' stamp: 'jmv 8/1/2019 11:01:35'! - turnMouseButton1Into3 - "Answer true if modifier keys are such that button 1 should be considered as button 3. - ctrl - shift - click -> center click - alt -> click -> center click (effective only on Windows, - the vm on Mac already reports center click, and on Linux right click) - " - - (self controlKeyPressed and: [self shiftPressed]) ifTrue: [ ^ true ]. - self commandAltKeyPressed ifTrue: [ ^ true ]. - ^ false! ! -!MouseEvent methodsFor: 'button state' stamp: 'jmv 8/1/2019 11:14:36' prior: 50405079! - mouseButton1Pressed - "Answer true if the mouseButton1 is being pressed. - Reported by the VM for the single/first mouse button, usually the one at the left. - But if they are combined with modifier keys, it is might button 2 or 3. - See mouseButton2Pressed and mouseButton3Pressed. - See also #mouseButton1Changed" - - self turnMouseButton1Into2 ifTrue: [ ^ false ]. - self turnMouseButton1Into3 ifTrue: [ ^ false ]. - ^ buttons anyMask: InputSensor mouseButton1! ! -!MouseEvent methodsFor: 'button state' stamp: 'jmv 8/1/2019 11:12:43' prior: 50405094! - mouseButton2Pressed - "Answer true if the mouseButton2 is being pressed. - Reported by the VM for right mouse button or option+click on the Mac, ctrl-click on Windows, or ctrl-click or alt-click on Linux. - It is also emulated here with ctrl-click on any platform." - - (self turnMouseButton1Into2 and: [ buttons anyMask: InputSensor mouseButton1 ]) - ifTrue: [ ^ true ]. - ^ buttons anyMask: InputSensor mouseButton2! ! -!MouseEvent methodsFor: 'button state' stamp: 'jmv 8/1/2019 11:12:08' prior: 50405109! - mouseButton3Pressed - "Answer true if the mouseButton3 is being pressed. - Reported by the VM for center (wheel) mouse button or cmd+click on the Mac or win/meta+click on Windows and Linux. - It is also emulated here with shift-ctrl-click on any platform." - - (self turnMouseButton1Into3 and: [ buttons anyMask: InputSensor mouseButton1 ]) - ifTrue: [ ^ true ]. - ^ buttons anyMask: InputSensor mouseButton3! ! -!MouseButtonEvent methodsFor: 'accessing' stamp: 'jmv 8/1/2019 11:14:43' prior: 50405125! - mouseButton1Changed - "Answer true if the mouseButton1 has changed. - Reported by the VM for the single/first mouse button, usually the one at the left. - But if they are combined with modifier keys, it is might button 2 or 3. - See mouseButton1Changed and mouseButton3Changed. - The check for button change (instead of button press) is specially useful on buttonUp events. - See also #mouseButton1Pressed" - - self turnMouseButton1Into2 ifTrue: [ ^ false ]. - self turnMouseButton1Into3 ifTrue: [ ^ false ]. - ^ whichButton anyMask: InputSensor mouseButton1! ! -!MouseButtonEvent methodsFor: 'accessing' stamp: 'jmv 8/1/2019 11:12:49' prior: 50405142! - mouseButton2Changed - "Answer true if the mouseButton2 has changed. - Reported by the VM for right mouse button or option+click on the Mac. - It is also emulated here with ctrl-click on any platform. - The check for button change (instead of button press) is specially useful on buttonUp events." - - (self turnMouseButton1Into2 and: [ whichButton anyMask: InputSensor mouseButton1 ]) - ifTrue: [ ^ true ]. - ^ whichButton anyMask: InputSensor mouseButton2! ! -!MouseButtonEvent methodsFor: 'accessing' stamp: 'jmv 8/1/2019 11:12:33' prior: 50405160! - mouseButton3Changed - "Answer true if the mouseButton3 has changed. - Reported by the VM for center (wheel) mouse button or cmd+click on the Mac or meta+click on Linux. - It is also emulated here with shift-ctrl-click on any platform. - The check for button change (instead of button press) is specially useful on buttonUp events." - - (self turnMouseButton1Into3 and: [ whichButton anyMask: InputSensor mouseButton1 ]) - ifTrue: [ ^ true ]. - ^ whichButton anyMask: InputSensor mouseButton3! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3830-makeCtrlClickMeanButton2OnMac-JuanVuletich-2019Aug01-10h25m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3830] on 2 August 2019 at 9:27:45 am'! -!BoxedFloat64 methodsFor: 'testing' stamp: 'jmv 8/1/2019 16:42:44'! - isFinite - "simple, byte-order independent test for rejecting Not-a-Number and (Negative)Infinity" - - ^(self - self) = 0.0! ! -!BoxedFloat64 methodsFor: 'testing' stamp: 'jmv 8/1/2019 16:42:00'! -isInfinite - "Return true if the receiver is positive or negative infinity." - - ^ self = Infinity or: [self = NegativeInfinity]! ! -!BoxedFloat64 methodsFor: 'testing' stamp: 'jmv 8/1/2019 16:39:56'! - isNaN - "simple, byte-order independent test for Not-a-Number" - - ^ self ~= self! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 8/1/2019 16:59:41' prior: 50465157! - arTanh - "Answer receiver's area hyperbolic tangent. - That is the inverse function of tanh." - - self = 0.0 ifTrue: [^self]. "Handle negativeZero" - self = 1 ifTrue: [^ Float infinity]. - self = -1 ifTrue: [^Float negativeInfinity]. - self abs > 1 ifTrue: [^ Float nan]. - ^((1 + self) / (1 - self)) ln / 2! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 8/1/2019 17:02:16' prior: 16844737! - sinh - "Answer receivers hyperbolic sine" - - | ex | - ex _ self abs exp. - ^ (ex - ex reciprocal) / 2 * self sign! ! -!Float methodsFor: 'testing' stamp: 'jmv 8/1/2019 16:43:28' prior: 50418722! - isFinite - "Infinities and Not a Number are only represented as BoxedFloat64" - - ^ true! ! -!Float methodsFor: 'testing' stamp: 'jmv 8/2/2019 09:22:50' prior: 16845083! - isInfinite - "Infinities are only represented as BoxedFloat64" - - ^ false -! ! -!Float methodsFor: 'testing' stamp: 'jmv 8/1/2019 16:40:18' prior: 16845099! - isNaN - "Not a Number are only represented as BoxedFloat64" - - ^ false! ! -!BoxedFloat64 methodsFor: 'truncation and round off' stamp: 'jmv 8/1/2019 18:39:12' prior: 50417892! - exponent - "Primitive. Consider the receiver to be represented as a power of two - multiplied by a mantissa between one and two or between -1 and -2 (#significand). - Answer with the SmallInteger to whose power two is raised. - Optional. See Object documentation whatIsAPrimitive. - Note: invalid for infinities, NaN and zero. - See also #signPart, #significandAsInteger and #exponentPart - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. f significand . f exponent. f significand * (2 raisedToInteger: f exponent) = f } print ]. - " - - | positive | - - self >= 1.0 ifTrue: [^self floorLog: 2]. - self > 0.0 - ifTrue: - [positive _ (1.0 / self) exponent. - self = (1.0 / (1.0 timesTwoPower: positive)) - ifTrue: [^positive negated] - ifFalse: [^positive negated - 1]]. - self = 0.0 ifTrue: [^-1]. - ^self negated exponent! ! -!SmallFloat64 methodsFor: 'truncation and round off' stamp: 'jmv 8/1/2019 18:39:17' prior: 50414592! - exponent - "Primitive. Consider the receiver to be represented as a power of two - multiplied by a mantissa between one and two (#significand). - Answer with the SmallInteger to whose power two is raised. - Optional. See Object documentation whatIsAPrimitive. - Note: invalid for infinities, NaN and zero. - See comment at BoxedFloat64" - - | positive | - - self >= 1.0 ifTrue: [^self floorLog: 2]. - self > 0.0 - ifTrue: - [positive _ (1.0 / self) exponent. - self = (1.0 / (1.0 timesTwoPower: positive)) - ifTrue: [^positive negated] - ifFalse: [^positive negated - 1]]. - self = 0.0 ifTrue: [^-1]. - ^self negated exponent! ! -!Duration class methodsFor: 'squeak protocol' stamp: 'jmv 8/1/2019 16:57:21' prior: 16836217! - readFrom: aStream - "Formatted as per ANSI 5.8.2.16: [-]D:HH:MM:SS[.S]" - - | sign days hours minutes seconds nanos nanosBuffer | - sign := (aStream peekFor: $-) ifTrue: [-1] ifFalse: [1]. - days := (aStream upTo: $:) asInteger * sign. - hours := (aStream upTo: $:) asInteger * sign. - minutes := (aStream upTo: $:) asInteger * sign. - seconds := (aStream upTo: $.) asInteger * sign. - nanosBuffer := '000000000' copy. - nanos := WriteStream on: nanosBuffer. - [aStream atEnd not and: [aStream peek isDigit]] - whileTrue: [nanos nextPut: aStream next]. - - ^ self - days: days - hours: hours - minutes: minutes - seconds: seconds - nanoSeconds: (nanosBuffer asInteger * sign) - - " '0:00:00:00' asDuration - '0:00:00:00.000000001' asDuration - '0:00:00:00.999999999' asDuration - '0:00:00:00.100000000' asDuration - '0:00:00:00.001 ' asDuration - '0:00:00:00.1' asDuration - '0:00:00:01 ' asDuration - '0:12:45:45' asDuration - '1:00:00:00' asDuration - '365:00:00:00' asDuration - '-7:09:12:06.10' asDuration - '+0:01:02:3' asDuration - "! ! - -Float removeSelector: #sign:! - -Float removeSelector: #sign:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3831-FloatCleanup-JuanVuletich-2019Aug02-09h15m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3830] on 2 August 2019 at 11:49:09 am'! -!BoxedFloat64 methodsFor: 'arithmetic' stamp: 'jmv 8/2/2019 11:02:05'! - arg - "Compatibility with Complex numbers." - self isNaN ifTrue: [^self]. - ^super arg! ! -!BoxedFloat64 methodsFor: 'arithmetic' stamp: 'jmv 8/2/2019 11:02:02'! - argument - "Compatibility with Complex numbers." - self isNaN ifTrue: [^self]. - ^super argument! ! -!BoxedFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 8/1/2019 19:23:08'! - raisedTo: exponent - "Answer the receiver raised to aNumber." - - self isNaN ifTrue: [ ^self ]. - ^super raisedTo: exponent! ! -!BoxedFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 8/2/2019 10:36:02'! - raisedToInteger: exponent - "Answer the receiver raised to aNumber." - - self isNaN ifTrue: [ ^self ]. - ^super raisedToInteger: exponent! ! -!BoxedFloat64 methodsFor: 'testing' stamp: 'jmv 8/1/2019 16:53:05'! - sign - "Answer 1 if the receiver is greater than 0, -1 if less than 0, else 0." - - self isNaN ifTrue: [ self error: 'Can not handle Not-a-Number' ]. - ^super sign! ! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 8/1/2019 19:23:05' prior: 50466076! -raisedTo: exponent - "Answer the receiver raised to aNumber." - - exponent isInteger ifTrue: [ - "Do the special case of integer power" - ^ self raisedToInteger: exponent]. - exponent isFraction ifTrue: [ - "Special case for fraction power by Nicolas Cellier: - If aNumber is a fraction, but result must be a Float, learn it as quickly as possible, and give quick Float answer - Allows evaluating: - (2009/2000) raisedTo: (3958333/100000) - " - ^ self raisedToFraction: exponent]. - self < 0 ifTrue: [ - ^NegativePowerError new signalReceiver: self selector: #raisedTo: argument: exponent]. - 0.0 = exponent ifTrue: [^ self class one]. "Special case of exponent=0" - 1.0 = exponent ifTrue: [^ self]. "Special case of exponent=1" - 0 = self ifTrue: [ "Special case of self = 0" - exponent isNaN ifTrue: [ ^exponent ]. - ^exponent < 0 - ifTrue: [(self raisedTo: exponent negated) reciprocal] - ifFalse: [self]]. - ^ (exponent * self ln) exp "Otherwise use logarithms"! ! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 8/2/2019 09:47:02' prior: 50466108! - raisedToFraction: aFraction - "Raise an exception if argument is not a Fraction" - aFraction denominator = 2 ifTrue: [ - ^ self sqrt raisedToInteger: aFraction numerator ]. - self isZero ifTrue: [ - aFraction negative ifTrue: [^ (self raisedToFraction: aFraction negated) reciprocal]. - ^ self ]. - self negative ifFalse: [ - ^ (self ln * aFraction) exp ]. - (self negative and: [ aFraction denominator even ]) ifTrue: [ - ^NegativePowerError new signalReceiver: self selector: #raisedToFraction: argument: aFraction]. - ^ (self negated ln * aFraction) exp negated! ! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 8/2/2019 11:47:20' prior: 50460977! - raisedToInteger: exponent - "The 0 raisedToInteger: 0 is an special case. In some contexts must be 1 and in others must - be handled as an indeterminate form. - Maybe further discussion is required on this topic." - - | bitProbe result | - - exponent negative ifTrue: [^self raisedToNegativeInteger: exponent ]. - exponent = 0 ifTrue: [^ self class one]. - exponent = 1 ifTrue: [^ self]. - - bitProbe := 1 bitShift: exponent highBit - 1. - result := self class one. - [ - (exponent bitAnd: bitProbe) = 0 ifFalse: [result := result * self]. - bitProbe := bitProbe bitShift: -1. - bitProbe > 0 ] - whileTrue: [ - result := result * result]. - ^result! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 8/2/2019 10:46:33' prior: 50450990! -arcTan: denominator - "Answer the angle in radians. - Implementation note: use sign in order to catch cases of negativeZero" - - self isNaN ifTrue: [ ^self ]. - denominator isNaN ifTrue: [ ^denominator class nan ]. "if Complex, answer complex nan" - ^self = 0.0 - ifTrue: [denominator sign >= 0 - ifTrue: [ 0.0 ] - ifFalse: [ self sign >= 0 - ifTrue: [ Pi ] - ifFalse: [ Pi negated ]]] - ifFalse: [denominator = 0.0 - ifTrue: [self > 0.0 - ifTrue: [ Halfpi ] - ifFalse: [ Halfpi negated ]] - ifFalse: [denominator > 0.0 - ifTrue: [ (self / denominator) arcTan ] - ifFalse: [self > 0.0 - ifTrue: [ ((self / denominator) arcTan) + Pi ] - ifFalse: [ ((self / denominator) arcTan) - Pi ]]]]! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 8/2/2019 10:49:29' prior: 16844618! - copySignTo: aNumber - "Return a number with same magnitude as aNumber and same sign as self. - Implementation note: take care of Float negativeZero, which is considered as having a negative sign." - - self isNaN ifTrue: [ ^self ]. - (self > 0.0 or: [(self at: 1) = 0]) ifTrue: [^ aNumber abs]. - ^aNumber withNegativeSign! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 8/1/2019 18:32:12' prior: 50412262! - smoothStep - "A Function that is - x <= -1 -> 1 - -1 < x < 1 -> smooth differentiable transition from 1 to 0 - 1 <= x -> 0 - - It is a 'smooth' version of an #negative - Has countless applications. For example in image and signal processing, but also in other fields." - " - | g | - Feature require: 'Morphic-Widgets-Extras'. - g _ FunctionGraphMorph new. - g domain: (-4 to: 4). - g addFunction: [ :x | x abs < 1 ifTrue: [1] ifFalse:[0] ] color: Color brown. - g addFunction: [ :x | x smoothStep ] color: Color red. - (g embeddedInMorphicWindowLabeled: 'graph') openInWorld - " - self isNaN ifTrue: [ ^self ]. - self > -1 ifFalse: [ ^ 1 ]. - 1 > self ifFalse: [ ^ 0 ]. - ^ (self +2 * Float halfPi) sin * 0.5 + 0.5! ! -!BoxedFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 8/1/2019 19:10:12' prior: 16790782! - timesTwoPower: anInteger - "Primitive. Answer with the receiver multiplied by 2 raised to the power of the argument. - Optional. See Object documentation whatIsAPrimitive." - - - anInteger isInteger ifFalse: [ ^DomainError signal: '#timesTwoPower: only defined for Integer argument.']. - self isFinite ifFalse: [^self]. - self isZero ifTrue: [^self]. - - "Make sure that (2.0 raisedTo: Integer) can be safely used without overflow - For example: - Float fminNormalized * (2.0 raisedTo: 2000) = Float infinity. - while: - (Float fminNormalized timesTwoPower: 2000) = (2.0 raisedTo: 2000+Float emin)." - anInteger > Float emax ifTrue: [^(self timesTwoPower: Float emax) timesTwoPower: anInteger - Float emax]. - - "In case of gradual underflow, timesTwoPower: is not exact, so greatest care must be taken - because two consecutive timesTwoPower: might differ from a single one" - anInteger < Float emin - ifTrue: [ - | deltaToUnderflow | - deltaToUnderflow := Float emin - self exponent max: Float emin. - deltaToUnderflow >= 0 ifTrue: [ - "self is already near or past underflow, so don't care, result will be zero" - deltaToUnderflow := Float emin]. - ^(self timesTwoPower: deltaToUnderflow) timesTwoPower: anInteger - deltaToUnderflow]. - - "If (2.0 raisedToInteger: anInteger) fit in a positive SmallInteger, then use faster SmallInteger conversion. - Note that SmallInteger maxVal highBit = 30 in a 32 bits image, so 1 can be shifted 29 times." - anInteger > -29 ifTrue: [ - anInteger < 0 ifTrue: [^ self / (1 bitShift: (0 - anInteger)) asFloat]. - anInteger < 30 ifTrue: [^ self * (1 bitShift: anInteger) asFloat]]. - - ^ self * (2.0 raisedToInteger: anInteger)! ! -!BoxedFloat64 methodsFor: 'truncation and round off' stamp: 'jmv 8/2/2019 09:34:43' prior: 16790863! - truncated - "Answer with a SmallInteger equal to the value of the receiver without - its fractional part. The primitive fails if the truncated value cannot be - represented as a SmallInteger. In that case, the code below will compute - a LargeInteger truncated value. - Raise an exception if no conversion to integer is possible, i.e. for Infinities and NaN. - Essential. See Object documentation whatIsAPrimitive. " - - - - ^ self partValues: [ :sign :exponent :mantissa | - sign * (mantissa bitShift: exponent - 52) ]! ! -!SmallFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 8/1/2019 19:10:21' prior: 16908447! - timesTwoPower: anInteger - "Primitive. Answer with the receiver multiplied by 2 raised to the power of the argument. - Optional. See Object documentation whatIsAPrimitive." - - - anInteger isInteger ifFalse: [ ^DomainError signal: '#timesTwoPower: only defined for Integer argument.']. - self isFinite ifFalse: [^self]. - self isZero ifTrue: [^self]. - - "Make sure that (2.0 raisedTo: Integer) can be safely used without overflow - For example: - Float fminNormalized * (2.0 raisedTo: 2000) = Float infinity. - while: - (Float fminNormalized timesTwoPower: 2000) = (2.0 raisedTo: 2000+Float emin)." - anInteger > Float emax ifTrue: [^(self timesTwoPower: Float emax) timesTwoPower: anInteger - Float emax]. - - "In case of gradual underflow, timesTwoPower: is not exact, so greatest care must be taken - because two consecutive timesTwoPower: might differ from a single one" - anInteger < Float emin - ifTrue: [ - | deltaToUnderflow | - deltaToUnderflow := Float emin - self exponent max: Float emin. - deltaToUnderflow >= 0 ifTrue: [ - "self is already near or past underflow, so don't care, result will be zero" - deltaToUnderflow := Float emin]. - ^(self timesTwoPower: deltaToUnderflow) timesTwoPower: anInteger - deltaToUnderflow]. - - "If (2.0 raisedToInteger: anInteger) fit in a positive SmallInteger, then use faster SmallInteger conversion. - Note that SmallInteger maxVal highBit = 30 in a 32 bits image, so 1 can be shifted 29 times." - anInteger > -29 ifTrue: [ - anInteger < 0 ifTrue: [^ self / (1 bitShift: (0 - anInteger)) asFloat]. - anInteger < 30 ifTrue: [^ self * (1 bitShift: anInteger) asFloat]]. - - ^ self * (2.0 raisedToInteger: anInteger)! ! -!SmallFloat64 methodsFor: 'truncation and round off' stamp: 'jmv 8/2/2019 09:34:46' prior: 16908530! - truncated - "Answer with a SmallInteger equal to the value of the receiver without - its fractional part. The primitive fails if the truncated value cannot be - represented as a SmallInteger. In that case, the code below will compute - a LargeInteger truncated value. - Raise an exception if no conversion to integer is possible, i.e. for Infinities and NaN. - Essential. See Object documentation whatIsAPrimitive. " - - - - ^ self partValues: [ :sign :exponent :mantissa | - sign * (mantissa bitShift: exponent - 52) ]! ! -!Fraction methodsFor: 'mathematical' stamp: 'jmv 8/2/2019 10:07:49' prior: 16849624! - reciprocal - "Refer to the comment in Number|reciprocal." - - ^denominator / numerator! ! -!Fraction methodsFor: 'mathematical functions' stamp: 'jmv 8/2/2019 09:47:13' prior: 50465342! - raisedToFraction: aFraction - "Raise an exception if argument is not a Fraction" - | root | - aFraction denominator = 2 ifTrue: [ - ^ self sqrt raisedToInteger: aFraction numerator ]. - (self negative and: [ aFraction denominator even ]) ifTrue: [ - ^NegativePowerError new signalReceiver: self selector: #raisedToFraction: argument: aFraction]. - root _ (self numerator nthRootTruncated: aFraction denominator) / - (self denominator nthRootTruncated: aFraction denominator). - (root raisedToInteger: aFraction denominator) = self ifTrue: [ - ^ root raisedToInteger: aFraction numerator ]. - ^ super raisedToFraction: aFraction! ! -!Fraction methodsFor: 'mathematical functions' stamp: 'jmv 8/2/2019 10:05:14' prior: 16849711! - raisedToInteger: anInteger - "See Number | raisedToInteger:" - "Raise an exception if argument is not a anInteger" - - ^ (numerator raisedToInteger: anInteger) / (denominator raisedToInteger: anInteger)! ! -!Integer methodsFor: 'arithmetic' stamp: 'jmv 8/1/2019 17:26:46' prior: 50465375! - // aNumber - | q | - aNumber = 0 ifTrue: [^ ZeroDivide new signalReceiver: self selector: #// argument: aNumber]. - aNumber isInteger ifFalse: [ ^super // aNumber ]. - self = 0 ifTrue: [^ 0]. - q _ self quo: aNumber. - "Refer to the comment in Number>>#//." - ^(q negative - ifTrue: [q * aNumber ~= self] - ifFalse: [q = 0 and: [self negative ~= aNumber negative]]) - ifTrue: [q - 1"Truncate towards minus infinity."] - ifFalse: [q]! ! -!Integer methodsFor: 'mathematical functions' stamp: 'jmv 8/2/2019 10:56:57' prior: 50465445! - nthRoot: aPositiveInteger - "Answer the nth root of the receiver. - Answer an Integer if root is exactly this Integer, else answer the Float nearest the exact root." - - | guess excess scaled nBits | - aPositiveInteger = 2 ifTrue: [ - ^ self sqrt ]. - - (aPositiveInteger isInteger not or: [ aPositiveInteger negative ]) - ifTrue: [^ DomainError signal: 'nth root only defined for positive Integer n.']. - - self = 0 ifTrue: [ ^0 ]. - - (self negative and: [ aPositiveInteger even ]) ifTrue: [ - ^ NegativePowerError new signalReceiver: self selector: #nthRoot: argument: aPositiveInteger ]. - - guess _ self nthRootRounded: aPositiveInteger. - excess _ (guess raisedTo: aPositiveInteger) - self. - excess = 0 ifTrue: [ ^ guess ]. - - nBits _ Float precision - guess highBitOfMagnitude. - nBits <= 0 ifTrue: [ ^(Fraction numerator: guess * 4 - excess sign denominator: 4) asFloat]. - - scaled _ self << (nBits * aPositiveInteger). - guess _ scaled nthRootRounded: aPositiveInteger. - excess _ (guess raisedTo: aPositiveInteger) - scaled. - ^(Fraction numerator: guess * 4 - excess sign denominator: 1 << (nBits + 2)) asFloat! ! -!Integer methodsFor: 'mathematical functions' stamp: 'jmv 8/2/2019 09:47:05' prior: 50465547! - raisedToFraction: aFraction - "Raise an exception if argument is not a Fraction" - | root | - aFraction denominator = 2 ifTrue: [ - ^ self sqrt raisedToInteger: aFraction numerator ]. - self = 0 ifTrue: [ ^0 ]. - (self negative and: [ aFraction denominator even ]) ifTrue: [ - ^NegativePowerError new signalReceiver: self selector: #raisedToFraction: argument: aFraction]. - root _ self nthRootTruncated: aFraction denominator. - (root raisedToInteger: aFraction denominator) = self ifTrue: [ - ^ root raisedToInteger: aFraction numerator ]. - ^ super raisedToFraction: aFraction! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3832-NaNpropagationFixes-JuanVuletich-2019Aug02-09h27m-jmv.2.cs.st----! - -'From Cuis 5.0 [latest update: #3826] on 3 August 2019 at 9:21:49 am'! -!Behavior methodsFor: 'accessing method dictionary' stamp: 'HAW 8/3/2019 09:16:52'! - highestClassImplementing: aSelector ifNone: aNoneBlock - - | highestImplementorClass | - - self withAllSuperclassesDo: [ :aBehavior | (aBehavior includesSelector: aSelector) ifTrue: [ highestImplementorClass := aBehavior ]]. - - ^ highestImplementorClass ifNil: aNoneBlock ! ! -!ChangeSelector class methodsFor: 'implementors and senders' stamp: 'HAW 8/3/2019 09:13:18' prior: 50438862! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inHierarchyOf: aClass doingPerClass: aBlock - - | highestClassImplementingOldSelector | - - highestClassImplementingOldSelector := aClass highestClassImplementing: anOldSelector ifNone: [ aClass ]. - highestClassImplementingOldSelector theNonMetaClass withAllSubAndSuperclassesDo: [ :aPotentialClassToRefactor | - aPotentialClassToRefactor isMeta ifFalse: [ - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders forClassAndMetaOf: aPotentialClassToRefactor. - aBlock value: aPotentialClassToRefactor ]] - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3833-HierarchyScopeRenameFix-HernanWilkinson-2019Jul19-08h20m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3826] on 5 August 2019 at 10:56:29 am'! -!Debugger methodsFor: 'private' stamp: 'jmv 8/5/2019 10:51:08' prior: 50430034! - contextStackIndex: anInteger oldContextWas: oldContext - "Change the context stack index to anInteger, perhaps in response to user selection." - - | isNewMethod selectedContextSlotName index | - contextStackIndex _ anInteger. - anInteger = 0 ifTrue: [ - currentCompiledMethod _ nil. - self changed: #contextStackIndex. - self acceptedContentsChanged. - contextVariablesInspector object: nil. - self fixReceiverInspector. - ^ self ]. - selectedContextSlotName _ contextVariablesInspector selectedSlotName. - isNewMethod _ oldContext == nil - or: [ oldContext method ~~ (currentCompiledMethod _ self selectedContext method) ]. - isNewMethod ifTrue: [ - self acceptedContentsChanged. - self pcRange ]. - self changed: #contextStackIndex. - self triggerEvent: #decorateButtons. - contextVariablesInspector object: self selectedContext. - ((index _ contextVariablesInspector fieldList indexOf: selectedContextSlotName) ~= 0 and: [ - index ~= contextVariablesInspector selectionIndex ]) ifTrue: [ - contextVariablesInspector toggleIndex: index ]. - self fixReceiverInspector. - isNewMethod ifFalse: [ self changed: #contentsSelection ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3834-contextStackIndexoldContextWas-hadLostSourceCode-JuanVuletich-2019Aug05-10h47m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3826] on 3 August 2019 at 12:15:41 am'! -!Boolean methodsFor: 'testing' stamp: 'jpb 8/3/2019 00:11:00'! - is: aSymbol - ^#Boolean = aSymbol or: [ super is: aSymbol ]! ! -!Number methodsFor: 'testing' stamp: 'jpb 8/2/2019 23:58:01'! - is: aSymbol - "Note: Senders might prefer #isNumber for perfomance reasons. Still, Cuis tries to keep isXXX testing selectors to a minimum." - ^#Number = aSymbol or: [ super is: aSymbol]! ! -!Fraction methodsFor: 'testing' stamp: 'jpb 8/3/2019 00:08:08'! - is: aSymbol - "Note: Senders might prefer #isFraction for perfomance reasons. Still, Cuis tries to keep isXXX testing selectors to a minimum." - ^#Fraction = aSymbol or: [ super is: aSymbol ]! ! -!Integer methodsFor: 'testing' stamp: 'jpb 8/2/2019 23:58:43'! -is: aSymbol - "Note: Senders might prefer #isInteger for perfomance reasons. Still, Cuis tries to keep isXXX testing selectors to a minimum." - ^#Integer = aSymbol or: [ super is: aSymbol ]! ! -!Collection methodsFor: 'testing' stamp: 'jpb 8/2/2019 23:59:42'! - is: aSymbol - "Note: Senders might prefer #isCollection for perfomance reasons. Still, Cuis tries to keep isXXX testing selectors to a minimum." - ^#Collection = aSymbol or: [ super is: aSymbol ]! ! -!String methodsFor: 'testing' stamp: 'jpb 8/3/2019 00:01:22'! - is: aSymbol - "Note: Senders might prefer #isString for perfomance reasons. Still, Cuis tries to keep isXXX testing selectors to a minimum." - ^#String = aSymbol or: [ super is: aSymbol]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3835-Additional-is-methods-JosefPhilipBernhart-2019Aug02-23h58m-jpb.1.cs.st----! - -'From Cuis 5.0 [latest update: #3832] on 4 August 2019 at 10:07:59 pm'! -!Debugger methodsFor: 'accessing' stamp: 'HAW 8/4/2019 22:06:34' prior: 16829568! -contents: aText notifying: aController - "The retrieved information has changed and its source must now be updated. - In this case, the retrieved information is the method of the selected context." - - | result selector classOfMethod category h ctxt newMethod | - - contextStackIndex = 0 ifTrue: [^false]. - - classOfMethod := self selectedClass. - category := self selectedMessageCategoryName. - selector :=self selectedClass parserClass selectorFrom: aText. - - selector ~= self selectedMessageName ifTrue: [ - self inform: 'Can not change the selector in the debugger'. - ^false]. - (classOfMethod = UndefinedObject and: [ selector = Scanner doItSelector or: [ selector = Scanner doItInSelector ]]) ifTrue: [ - self inform: 'DoIt and DoItIn: methods can not be changed'. - ^false]. - - self selectedContext isExecutingBlock ifTrue: [ - h := self selectedContext activeHome. - h ifNil: [ - self inform: 'Method for block not found on stack, can''t edit and continue'. - ^false]. - (self confirm: 'I will have to revert to the method from\which this block originated. Is that OK?' withNewLines) ifFalse: [^false]. - self resetContext: h. - (result := self contents: aText notifying: aController) ifTrue: [self acceptedContentsChanged]. - ^result]. - - selector := classOfMethod - compile: aText - classified: category - notifying: aController. - selector ifNil: [^false]. "compile cancelled" - newMethod := classOfMethod compiledMethodAt: selector. - - newMethod isQuick ifTrue: [ - contextStackIndex + 1 > contextStack size ifTrue: [ - self inform: 'Can not compile a quick method in the stack base context'. - ^false]. - self down. - self selectedContext jump: (self selectedContext previousPc - self selectedContext pc)]. - - ctxt := interruptedProcess popTo: self selectedContext. - ctxt == self selectedContext - ifFalse: - [self inform: 'Method saved, but current context unchanged\because of unwind error. Click OK to see error' withNewLines] - ifTrue: - [newMethod isQuick ifFalse: - [interruptedProcess - restartTopWith: newMethod; - stepToSendOrReturn]. - contextVariablesInspector object: nil]. - self resetContext: ctxt. - ^true! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3836-ChangeSelectorOrDoitInDebugger-HernanWilkinson-2019Aug04-18h56m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3836] on 5 August 2019 at 3:35:31 pm'! -!ChangeSelector class methodsFor: 'implementors and senders' stamp: 'HAW 8/5/2019 15:35:03' prior: 50468301! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inHierarchyOf: aClass doingPerClass: aBlock - - | highestClassImplementingOldSelector | - - highestClassImplementingOldSelector := aClass highestClassImplementing: anOldSelector ifNone: [ aClass ]. - highestClassImplementingOldSelector theNonMetaClass withAllSubclassesDo: [ :aPotentialClassToRefactor | - aPotentialClassToRefactor isMeta ifFalse: [ - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders forClassAndMetaOf: aPotentialClassToRefactor. - aBlock value: aPotentialClassToRefactor ]] - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3837-RenameSelectorHierarchyFix-HernanWilkinson-2019Aug05-15h35m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3837] on 5 August 2019 at 4:25:51 pm'! -!CodeWindow methodsFor: 'keyboard shortcuts' stamp: 'EB 5/9/2019 16:00:27' prior: 50467444! - messageListKey: aChar from: view - "Respond to a Command key. I am a model with a code pane, and I also - have a listView that has a list of methods. The view knows how to get - the list and selection." - - | sel class | - aChar == $D ifTrue: [^ model toggleDiffing]. - - sel _ model selectedMessageName. - aChar == $m ifTrue: [ "These next two put up a type in if no message selected" - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllImplementorsOf: to: Smalltalk]. - aChar == $n ifTrue: [ - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllCallsOn: to: Smalltalk]. - - "The following require a class selection" - (class _ model selectedClassOrMetaClass) ifNil: [^ self ]. - aChar == $b ifTrue: [^ BrowserWindow fullOnClass: class selector: sel]. - aChar == $N ifTrue: [^ self browseClassRefs]. - aChar == $i ifTrue: [^ self methodHierarchy]. - aChar == $h ifTrue: [^ self browseHierarchy]. - aChar == $p ifTrue: [^ self browseFullProtocol]. - - sel - ifNotNil: [ - "The following require a method selection" - aChar == $o ifTrue: [^ model fileOutMessage]. - aChar == $c ifTrue: [^ model copySelector]. - aChar == $v ifTrue: [^ self browseVersions]. - aChar == $C ifTrue: [^ model showHomeCategory]. - aChar == $O ifTrue: [^ self openSingleMessageBrowser]. - aChar == $x ifTrue: [^ model removeMessage]. - aChar == $t ifTrue: [^ model runMethodTest]. - aChar == $r ifTrue: [^ model debugMethodTest]. - aChar == $R ifTrue: [^ self renameSelector]] - ifNil: [ - aChar == $R ifTrue: [^ model renameClass]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3838-RenameMessageHotKeyFix-HernanWilkinson-2019Aug05-16h23m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3838] on 6 August 2019 at 8:37:30 am'! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 8/6/2019 08:36:15' prior: 50402056! - setBalloonText: stringTextOrSymbol - "Set receiver's balloon help text. Pass nil to remove the help." - - stringTextOrSymbol - ifNil: [ self removeProperty: #balloonText ] - ifNotNil: [ - self - setProperty: #balloonText - toValue: stringTextOrSymbol string ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3839-fixABadIsSender-JuanVuletich-2019Aug06-08h35m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3839] on 11 August 2019 at 11:41:15 pm'! -!CompiledMethod methodsFor: 'decompiling' stamp: 'HAW 8/11/2019 22:36:12'! - selectorAndArgumentsAsString - - ^self methodNode selectorAndArgumentsAsString ! ! -!MethodNode methodsFor: 'printing' stamp: 'HAW 8/11/2019 23:38:22'! - ifPrimitivePrintOn: aStream - - primitive > 0 ifTrue: - [(primitive between: 255 and: 519) ifFalse: "Dont decompile quick prims e.g, ^ self or ^instVar" - [aStream newLineTab: 1. - self printPrimitiveOn: aStream]]. -! ! -!MethodNode methodsFor: 'printing' stamp: 'HAW 8/11/2019 23:37:02'! - printCommentOn: aStream - - comment ifNotNil: [ - aStream newLineTab: 1. - self printCommentOn: aStream indent: 1].! ! -!MethodNode methodsFor: 'printing' stamp: 'HAW 8/11/2019 22:34:14'! - printSelectorAndArgumentsOn: aStream - - | selectorNode | - - selectorNode _ self selectorNode. - precedence = 1 - ifTrue: - [selectorNode isForFFICall - ifTrue: [selectorNode - printAsFFICallWithArguments: arguments - on: aStream - indent: 0] - ifFalse: [aStream nextPutAll: selectorNode key]] - ifFalse: - [selectorNode key keywords withIndexDo: - [:kwd :i | | arg | - arg _ arguments at: i. - i = 1 ifFalse: [ aStream space ]. - aStream nextPutAll: kwd; space; nextPutAll: arg key ]]. -! ! -!MethodNode methodsFor: 'printing' stamp: 'HAW 8/11/2019 23:37:36'! - printTemporariesOn: aStream - - block printTemporaries: temporaries on: aStream doPrior: [aStream newLineTab: 1]. -! ! -!MethodNode methodsFor: 'printing' stamp: 'HAW 8/11/2019 22:34:14'! - selectorAndArgumentsAsString - - ^String streamContents: [ :aStream | self printSelectorAndArgumentsOn: aStream ]! ! -!MethodNode methodsFor: 'printing' stamp: 'HAW 8/11/2019 23:39:17' prior: 16872740! - printOn: aStream - - self - printSelectorAndArgumentsOn: aStream; - printCommentOn: aStream; - printTemporariesOn: aStream; - ifPrimitivePrintOn: aStream; - printPropertiesOn: aStream; - printPragmasOn: aStream. - - aStream newLineTab: 1. - block printStatementsOn: aStream indent: 0! ! - -MethodNode removeSelector: #printSelectorOn:! - -MethodNode removeSelector: #selectorAsString! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3840-MethodNodePrintOnRefactoring-HernanWilkinson-2019Aug11-21h52m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3839] on 17 August 2019 at 11:24:04 am'! -!RenameSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/17/2019 11:17:16'! - openChangeSelectorSendersStepWindow - - ChangeSelectorSendersStepWindow openFrom: self ! ! -!ChangeSelectorImplementorsStepWindow methodsFor: 'actions' stamp: 'HAW 8/17/2019 11:23:47' prior: 50438366! - seeSenders - - self changeImplementors. - self delete. - - "Necesary indirection to support actual senders in LiveTyping - Hernan" - applier openChangeSelectorSendersStepWindow! ! -!AddInstanceVariable methodsFor: 'applying' stamp: 'HAW 8/16/2019 11:24:02' prior: 50438527! - apply - - classToRefactor addInstVarName: newVariable. - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3841-RenameSenderWindowIndirection-HernanWilkinson-2019Aug13-19h10m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3839] on 17 August 2019 at 12:35:37 pm'! -!ChangeSelectorKeepingParameters methodsFor: 'rename senders - private' stamp: 'HAW 8/17/2019 12:29:38'! - addRangesOf: oldSelectorKeywordsRanges to: rangesToKeywords - - oldSelectorKeywordsRanges do: [ :aMessageSendSelectorRanges | - aMessageSendSelectorRanges withIndexDo: [ :aRange :index | rangesToKeywords add: aRange -> (newSelectorKeywords at: index) ]]. - - - ! ! -!ChangeSelectorKeepingParameters methodsFor: 'rename senders - private' stamp: 'HAW 8/17/2019 12:29:21' prior: 50447627! - addMessageSendSelectorKeywordRangesOf: aMethodNode to: rangesToKeywords - - | oldSelectorKeywordsRanges | - - oldSelectorKeywordsRanges := aMethodNode messageSendSelectorKeywordPositionsOf: oldSelector ifAbsent: [ #() ]. - self addRangesOf: oldSelectorKeywordsRanges to: rangesToKeywords. - - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3842-RenameSelectorRefactoring-HernanWilkinson-2019Aug17-11h24m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3839] on 19 August 2019 at 6:19:21 am'! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 8/17/2019 16:17:55'! - withMessageSendKeywordPositionsOf: aSelector do: aMessageSendNodeBlock ifAbsent: aBlock - - | positions sortedPositions | - - positions := sourceRanges keys - select: [ :aParseNode | aParseNode isMessageNamed: aSelector ] - thenCollect: aMessageSendNodeBlock. - - positions isEmpty ifTrue: [ ^aBlock value ]. - sortedPositions := positions asSortedCollection. - - ^sortedPositions ! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 8/19/2019 05:37:27'! - ifChangeSelectorCanBeAppliedDo: aBlock - - ^(self hasUnacceptedEdits or: [morph hasEditingConflicts ]) - ifTrue: [ self inform: 'Rename, Add Parameter and Remove Parameter can not be applied when there are unsaved changes' ] - ifFalse: aBlock! ! -!SmalltalkEditor methodsFor: 'contextual add parameter' stamp: 'HAW 8/19/2019 05:39:02'! - addParameter: aNodeUnderCursor in: aSelectedClass at: aSelectedSelector - - self ifChangeSelectorCanBeAppliedDo: [ - aNodeUnderCursor isMessageNode - ifTrue: [ self addParameterOf: aNodeUnderCursor in: aSelectedClass at: aSelectedSelector ] - ifFalse: [ morph flash ]] -! ! -!SmalltalkEditor methodsFor: 'contextual add parameter' stamp: 'HAW 8/19/2019 05:43:57'! - addParameterOf: aMessageNode in: aSelectedClass at: aSelectedSelector - - RefactoringApplier addParameterApplier - createAndValueHandlingExceptionsOn: model textProvider - of: aMessageNode - in: aSelectedClass - at: aSelectedSelector! ! -!SmalltalkEditor methodsFor: 'contextual add parameter' stamp: 'HAW 8/19/2019 05:47:11'! - addParameterTo: aSelector in: aClassToRefactor - - RefactoringApplier addParameterApplier - createAndValueHandlingExceptionsOn: model textProvider - for: aSelector - in: aClassToRefactor ! ! -!SmalltalkEditor methodsFor: 'contextual add parameter' stamp: 'HAW 8/18/2019 20:55:50'! - contextualAddParameter - - self isEditingClassDefinition - ifTrue: [ morph flash ] - ifFalse: [ self contextualAddParameterInMethod ]! ! -!SmalltalkEditor methodsFor: 'contextual add parameter' stamp: 'HAW 8/18/2019 20:54:15'! - contextualAddParameter: aKeyboardEvent - - self contextualAddParameter. - ^true! ! -!SmalltalkEditor methodsFor: 'contextual add parameter' stamp: 'HAW 8/18/2019 20:56:07'! - contextualAddParameterInMethod - - self - withMethodNodeAndClassDo: [ :methodNode :selectedClass | self contextualAddParameterOf: methodNode in: selectedClass] - ifErrorsParsing: [ :anError | morph flash ] ! ! -!SmalltalkEditor methodsFor: 'contextual add parameter' stamp: 'HAW 8/19/2019 05:36:00'! - contextualAddParameterOf: aMethodNode in: aSelectedClass - - aMethodNode - withParseNodeIncluding: self startIndex - do: [ :nodeUnderCursor | self addParameter: nodeUnderCursor in: aSelectedClass at: aMethodNode selector ] - ifAbsent: [ - self startIndex <= aMethodNode selectorLastPosition - ifTrue: [ self ifChangeSelectorCanBeAppliedDo: [ self addParameterTo: aMethodNode selector in: aSelectedClass ]] - ifFalse: [ morph flash ]] -! ! -!SmalltalkEditor methodsFor: 'contextual remove parameter' stamp: 'HAW 8/19/2019 05:50:19'! - contextualRemoveParameter - - self isEditingClassDefinition - ifTrue: [ morph flash ] - ifFalse: [ self contextualRemoveParameterInMethod ]! ! -!SmalltalkEditor methodsFor: 'contextual remove parameter' stamp: 'HAW 8/19/2019 05:49:23'! - contextualRemoveParameter: aKeyboardEvent - - self contextualRemoveParameter. - ^true! ! -!SmalltalkEditor methodsFor: 'contextual remove parameter' stamp: 'HAW 8/19/2019 05:50:49'! - contextualRemoveParameterInMethod - - self - withMethodNodeAndClassDo: [ :methodNode :selectedClass | self contextualRemoveParameterOf: methodNode in: selectedClass] - ifErrorsParsing: [ :anError | morph flash ]! ! -!SmalltalkEditor methodsFor: 'contextual remove parameter' stamp: 'HAW 8/19/2019 05:51:33'! - contextualRemoveParameterOf: aMethodNode in: aSelectedClass - - aMethodNode - withParseNodeIncluding: self startIndex - do: [ :nodeUnderCursor | self removeParameter: nodeUnderCursor in: aSelectedClass at: aMethodNode selector ] - ifAbsent: [ - self startIndex <= aMethodNode selectorLastPosition - ifTrue: [ self ifChangeSelectorCanBeAppliedDo: [ self removeParameterTo: aMethodNode selector in: aSelectedClass ]] - ifFalse: [ morph flash ]] -! ! -!SmalltalkEditor methodsFor: 'contextual remove parameter' stamp: 'HAW 8/19/2019 05:52:50'! - removeParameter: aNodeUnderCursor in: aSelectedClass at: aSelectedSelector - - self ifChangeSelectorCanBeAppliedDo: [ - aNodeUnderCursor isMessageNode - ifTrue: [ self removeParameterOf: aNodeUnderCursor in: aSelectedClass at: aSelectedSelector ] - ifFalse: [ morph flash ]] -! ! -!SmalltalkEditor methodsFor: 'contextual remove parameter' stamp: 'HAW 8/19/2019 05:53:28'! - removeParameterOf: aMessageNode in: aSelectedClass at: aSelectedSelector - - RefactoringApplier removeParameterApplier - createAndValueHandlingExceptionsOn: model textProvider - of: aMessageNode - in: aSelectedClass - at: aSelectedSelector! ! -!SmalltalkEditor methodsFor: 'contextual remove parameter' stamp: 'HAW 8/19/2019 05:55:27'! - removeParameterTo: aSelector in: aClassToRefactor - - RefactoringApplier removeParameterApplier - createAndValueHandlingExceptionsOn: model textProvider - for: aSelector - in: aClassToRefactor ! ! -!AddParameter methodsFor: 'rename senders - private' stamp: 'HAW 8/17/2019 16:37:49'! - addKeywordRangesForLastPositionOf: aMethodNode using: insertionPoints to: rangesToKeywords - - | originalSourceCode | - - originalSourceCode := aMethodNode sourceText. - insertionPoints do: [ :aPosition | | newPosition | - newPosition := self firstNoSeparatorIndexIn: originalSourceCode startingFrom: aPosition. - rangesToKeywords add: ((newPosition+1) to: newPosition) -> senderTrailingString ]! ! -!AddParameter methodsFor: 'rename senders - private' stamp: 'HAW 8/17/2019 16:38:39'! - addKeywordRangesUsing: insertionPoints to: rangesToKeywords - - insertionPoints do: [ :aPosition | - rangesToKeywords add: (aPosition to: aPosition-1) -> senderTrailingString ] -! ! -!AddParameter methodsFor: 'rename senders - private' stamp: 'HAW 8/17/2019 15:57:54'! - messageSendKeywordPositionsIn: aMethodNode - - ^aMethodNode messageSendKeywordPositionsAt: index of: oldSelector ifAbsent: [ #()].! ! -!AddParameter methodsFor: 'rename senders - private' stamp: 'HAW 8/17/2019 15:58:04'! - messageSendLastPositionIn: aMethodNode - - ^aMethodNode messageSendLastPositionsOf: oldSelector ifAbsent: [ #() ].! ! -!ChangeSelectorKeepingParameters methodsFor: 'rename senders - private' stamp: 'HAW 8/17/2019 15:59:10'! - messageSendSelectorKeywordPositionsIn: aMethodNode - - ^aMethodNode messageSendSelectorKeywordPositionsOf: oldSelector ifAbsent: [ #() ].! ! -!RemoveParameter methodsFor: 'rename senders - private' stamp: 'HAW 8/18/2019 12:11:04'! - keywordAndParameterPositionsIn: aMethodNode - - ^aMethodNode messageSendKeywordAndParameterPositionsAt: parameterIndex of: oldSelector ifAbsent: [ #() ].! ! -!RefactoringApplier class methodsFor: 'appliers - registering' stamp: 'HAW 8/18/2019 20:02:30'! - registerAddParameterApplier: anAddParameterApplierClass - - self registerApplierAt: self addParameterApplierId with: anAddParameterApplierClass ! ! -!RefactoringApplier class methodsFor: 'appliers - registering' stamp: 'HAW 8/18/2019 20:03:28'! - registerRemoveParameterApplier: aRemoveParameterApplierClass - - self registerApplierAt: self removeParameterApplierId with: aRemoveParameterApplierClass ! ! -!RefactoringApplier class methodsFor: 'appliers - getting' stamp: 'HAW 8/18/2019 19:59:32'! - addParameterApplier - - ^self applierAt: self addParameterApplierId ifAbsent: [ AddParameterApplier ]! ! -!RefactoringApplier class methodsFor: 'appliers - getting' stamp: 'HAW 8/18/2019 20:16:16'! - removeParameterApplier - - ^self applierAt: self removeParameterApplierId ifAbsent: [ RemoveParameterApplier ]! ! -!RefactoringApplier class methodsFor: 'appliers - id' stamp: 'HAW 8/18/2019 20:00:08'! - addParameterApplierId - - ^#addParameterApplier! ! -!RefactoringApplier class methodsFor: 'appliers - id' stamp: 'HAW 8/18/2019 20:00:21'! - removeParameterApplierId - - ^#removeParameterApplier! ! -!RefactoringApplier class methodsFor: 'appliers - id' stamp: 'HAW 8/18/2019 20:01:09'! - renameSelectorApplierId - - ^#renameSelectorApplier! ! -!RefactoringApplier class methodsFor: 'appliers - resetting' stamp: 'HAW 8/18/2019 20:04:34'! - resetAddParameterApplier - - self resetApplierAt: self addParameterApplierId! ! -!RefactoringApplier class methodsFor: 'appliers - resetting' stamp: 'HAW 8/18/2019 20:16:43'! - resetRemoveParameterApplier - - self resetApplierAt: self removeParameterApplierId ! ! -!RefactoringApplier class methodsFor: 'appliers - private' stamp: 'HAW 8/18/2019 19:55:48'! - applierAt: anApplierId ifAbsent: absentBlock - - ^Appliers - at: anApplierId - ifPresent: [ :anApplierName | Smalltalk classNamed: anApplierName ] - ifAbsent: absentBlock ! ! -!RefactoringApplier class methodsFor: 'appliers - private' stamp: 'HAW 8/18/2019 20:03:03'! - registerApplierAt: anApplierId with: anApplierClass - - Appliers at: anApplierId put: anApplierClass name ! ! -!RefactoringApplier class methodsFor: 'appliers - private' stamp: 'HAW 8/18/2019 20:04:48'! - resetApplierAt: anApplierId - - Appliers removeKey: anApplierId ifAbsent: []! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/17/2019 22:18:41'! - createImplementors - - ^IdentitySet new.! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/17/2019 22:19:08'! - createSenders - - ^IdentitySet new. -! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/17/2019 22:41:27'! - openChangeSelectorSendersStepWindow - - ChangeSelectorSendersStepWindow openFrom: self ! ! -!ChangeSelectorApplier class methodsFor: 'instance creation' stamp: 'HAW 8/17/2019 22:30:43'! - createAndValueHandlingExceptionsOn: aModel for: anOldSelector in: aClassToRefactor - - self createAndValueHandlingExceptions: [ self on: aModel for: anOldSelector in: aClassToRefactor ]! ! -!AddParameterApplier class methodsFor: 'instance creation' stamp: 'HAW 8/19/2019 05:42:49'! - createAndValueHandlingExceptionsOn: aModel of: aMessageNode in: aSelectedClass at: aSelectedSelector - - ^self createAndValueHandlingExceptionsOn: aModel for: aMessageNode selector key in: aSelectedClass -! ! -!RemoveParameterApplier class methodsFor: 'instance creation' stamp: 'HAW 8/19/2019 05:43:07'! - createAndValueHandlingExceptionsOn: aModel of: aMessageNode in: aSelectedClass at: aSelectedSelector - - ^self createAndValueHandlingExceptionsOn: aModel for: aMessageNode selector key in: aSelectedClass -! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 8/17/2019 16:18:44' prior: 50443385! - messageSendKeywordPositionsAt: anIndex of: aSelector ifAbsent: absentBlock - - ^self - withMessageSendKeywordPositionsOf: aSelector - do: [ :aMessageSendNode | (aMessageSendNode keywordPositionAt: anIndex) first ] - ifAbsent: absentBlock - ! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 8/17/2019 16:19:39' prior: 50443401! - messageSendLastPositionsOf: aSelector ifAbsent: absentBlock - - ^self - withMessageSendKeywordPositionsOf: aSelector - do: [ :aMessageSendNode | (sourceRanges at: aMessageSendNode) last ] - ifAbsent: absentBlock - ! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 8/19/2019 05:35:49' prior: 50452419! - contextualRenameInClassDefinition - - self ifChangeSelectorCanBeAppliedDo: [ - self - withClassDefinitionNodeAndClassDo: [ :classDefinitionNode :selectedClass | self contextualRenameInClassDefinitionOf: classDefinitionNode in: selectedClass] - ifErrorsParsing: [ :anError | morph flash ] ]! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 8/19/2019 05:35:49' prior: 50450193! - contextualRenameOf: aMethodNode in: aSelectedClass - - aMethodNode - withParseNodeIncluding: self startIndex - do: [ :nodeUnderCursor | self rename: nodeUnderCursor in: aSelectedClass at: aMethodNode selector ] - ifAbsent: [ - self startIndex <= aMethodNode selectorLastPosition - ifTrue: [ self ifChangeSelectorCanBeAppliedDo: [ self renameSelectorFor: aMethodNode selector in: aSelectedClass ]] - ifFalse: [ morph flash ]] - - -! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 8/19/2019 05:35:49' prior: 50450775! - rename: aNodeUnderCursor in: aSelectedClass at: aSelectedSelector - - aNodeUnderCursor isTempOrArg ifTrue: [ ^self renameTemporary: aNodeUnderCursor name ]. - - self ifChangeSelectorCanBeAppliedDo: [ - aNodeUnderCursor isMessageNode ifTrue: [ ^ self renameSelectorOf: aNodeUnderCursor in: aSelectedClass at: aSelectedSelector ]. - aNodeUnderCursor isInstanceVariableNode ifTrue: [ ^ self renameInstanceVariableOn: self codeProvider for: aNodeUnderCursor name at: aSelectedClass ]. - aNodeUnderCursor isLiteralVariableNode ifTrue: [ | variableName | - variableName := aNodeUnderCursor key key. - (Smalltalk classNamed: variableName) ifNotNil: [ :classToRename | ^self renameClassOn: self codeProvider for: classToRename ]. - (Smalltalk bindingOf: variableName) ifNotNil: [ ^self renameGlobalOn: self codeProvider for: variableName ] ]. - - ^morph flash ]! ! -!CodeWindow methodsFor: 'keyboard shortcuts' stamp: 'HAW 8/19/2019 06:04:39' prior: 50468539! - messageListKey: aChar from: view - "Respond to a Command key. I am a model with a code pane, and I also - have a listView that has a list of methods. The view knows how to get - the list and selection." - - | sel class | - aChar == $D ifTrue: [^ model toggleDiffing]. - - sel _ model selectedMessageName. - aChar == $m ifTrue: [ "These next two put up a type in if no message selected" - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllImplementorsOf: to: Smalltalk]. - aChar == $n ifTrue: [ - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllCallsOn: to: Smalltalk]. - - "The following require a class selection" - (class _ model selectedClassOrMetaClass) ifNil: [^ self ]. - aChar == $b ifTrue: [^ BrowserWindow fullOnClass: class selector: sel]. - aChar == $N ifTrue: [^ self browseClassRefs]. - aChar == $i ifTrue: [^ self methodHierarchy]. - aChar == $h ifTrue: [^ self browseHierarchy]. - aChar == $p ifTrue: [^ self browseFullProtocol]. - - sel - ifNotNil: [ - "The following require a method selection" - aChar == $o ifTrue: [^ model fileOutMessage]. - aChar == $c ifTrue: [^ model copySelector]. - aChar == $v ifTrue: [^ self browseVersions]. - aChar == $C ifTrue: [^ model showHomeCategory]. - aChar == $O ifTrue: [^ self openSingleMessageBrowser]. - aChar == $x ifTrue: [^ model removeMessage]. - aChar == $t ifTrue: [^ model runMethodTest]. - aChar == $r ifTrue: [^ model debugMethodTest]. - aChar == $R ifTrue: [^ self renameSelector]. - aChar == $U ifTrue: [^ self addParameter ]. - aChar == $I ifTrue: [^ self removeParameter ]] - ifNil: [ - aChar == $R ifTrue: [^ model renameClass]]! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 8/18/2019 20:37:30' prior: 50443835! - addParameter - - model selectedMessageName ifNotNil: [ :oldSelector | - RefactoringApplier addParameterApplier createAndValueHandlingExceptionsOn: model for: oldSelector in: model selectedClassOrMetaClass ]! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 8/18/2019 20:29:17' prior: 50443894! - removeParameter - - model selectedMessageName ifNotNil: [ :oldSelector | - RefactoringApplier removeParameterApplier createAndValueHandlingExceptionsOn: model for: oldSelector in: model selectedClassOrMetaClass ]. - - ! ! -!ChangeSelectorSendersStepWindow methodsFor: 'actions' stamp: 'HAW 8/18/2019 11:46:24' prior: 50438448! - seeImplementors - - self delete. - - ChangeSelectorImplementorsStepWindow openFrom: applier! ! -!AddParameter methodsFor: 'rename senders - private' stamp: 'HAW 8/17/2019 16:38:25' prior: 50438933! - addMessageSendSelectorKeywordRangesOf: aMethodNode to: rangesToKeywords - - | insertionPoints | - - isAddingLast - ifTrue: [ - insertionPoints := self messageSendLastPositionIn: aMethodNode. - self addKeywordRangesForLastPositionOf: aMethodNode using: insertionPoints to: rangesToKeywords ] - ifFalse: [ - insertionPoints := self messageSendKeywordPositionsIn: aMethodNode. - self addKeywordRangesUsing: insertionPoints to: rangesToKeywords ]! ! -!ChangeSelectorKeepingParameters methodsFor: 'rename senders - private' stamp: 'HAW 8/17/2019 15:58:57' prior: 50468733! - addMessageSendSelectorKeywordRangesOf: aMethodNode to: rangesToKeywords - - | oldSelectorKeywordsRanges | - - oldSelectorKeywordsRanges := self messageSendSelectorKeywordPositionsIn: aMethodNode. - self addRangesOf: oldSelectorKeywordsRanges to: rangesToKeywords. - - ! ! -!RemoveParameter methodsFor: 'rename senders - private' stamp: 'HAW 8/18/2019 12:10:48' prior: 50439593! - addMessageSendSelectorKeywordRangesOf: aMethodNode to: rangesToKeywords - - | keywordAndParameterPositions senderSourceCode | - - senderSourceCode := aMethodNode sourceText. - keywordAndParameterPositions := self keywordAndParameterPositionsIn: aMethodNode. - keywordAndParameterPositions do: [ :aKeywordAndParameterPosition | | lastPosition | - lastPosition := self lastSeparatorIndexIn: senderSourceCode startingFrom: aKeywordAndParameterPosition last. - rangesToKeywords add: (aKeywordAndParameterPosition first to: lastPosition) -> senderReplacementString ] - ! ! -!RefactoringApplier class methodsFor: 'appliers - registering' stamp: 'HAW 8/18/2019 20:03:49' prior: 50450120! - registerRenameSelectorApplier: aRenameSelectorApplierClass - - self registerApplierAt: self renameSelectorApplierId with: aRenameSelectorApplierClass ! ! -!RefactoringApplier class methodsFor: 'appliers - getting' stamp: 'HAW 8/18/2019 20:01:43' prior: 50450127! - renameSelectorApplier - - ^self applierAt: self renameSelectorApplierId ifAbsent: [ RenameSelectorApplier ]! ! -!RefactoringApplier class methodsFor: 'appliers - resetting' stamp: 'HAW 8/18/2019 20:15:33' prior: 50450136! - resetRenameSelectorApplier - - self resetApplierAt: self renameSelectorApplierId ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/17/2019 22:19:01' prior: 50450142! - initializeImplementorsAndSenders - - implementors := self createImplementors. - senders := self createSenders! ! -!RefactoringMenues class methodsFor: 'editor menus' stamp: 'HAW 8/18/2019 20:51:47' prior: 50459627! - smalltalkEditorMenuOptions - - ^`{ - { - #itemGroup -> 35. - #itemOrder -> 10. - #label -> 'Rename... (R)'. - #selector -> #contextualRename. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 20. - #label -> 'Add Parameter... (U)'. - #selector -> #contextualAddParameter. - #icon -> #listAddIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 30. - #label -> 'Remove Parameter... (I)'. - #selector -> #contextualRemoveParameter. - #icon -> #listRemoveIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 40. - #label -> 'Temporary to Instance Variable (O)'. - #selector -> #temporaryToInstanceVariable. - #icon -> #saveAsIcon - } asDictionary. - - }`! ! -!RefactoringMenues class methodsFor: 'shortcuts' stamp: 'HAW 8/19/2019 06:12:02' prior: 50459644! - smalltalkEditorCmdShortcutsSpec - - ^#( - #( $R #contextualRename: 'Renames what is under cursor') - #( $U #contextualAddParameter: 'Adds parameter to message that is under cursor') - #( $I #contextualRemoveParameter: 'Removes parameter to message that is under cursor') - #( $O #temporaryToInstanceVariable: 'Extracts temporary variable to instance variable')) -! ! - -RenameSelectorApplier class removeSelector: #createAndValueHandlingExceptionsOn:for:in:! - -RenameSelectorApplier class removeSelector: #createAndValueHandlingExceptionsOn:for:in:! - -RenameSelectorApplier removeSelector: #openChangeSelectorSendersStepWindow! - -RenameSelectorApplier removeSelector: #openChangeSelectorSendersStepWindow! - -ChangeSelectorApplier removeSelectorIfInBaseSystem: #sendersFrom:! - -ChangeSelectorApplier removeSelector: #sendersFrom:! - -AddParameter removeSelector: #messageSendKeywordPositionsOf:! - -AddParameter removeSelector: #messageSendLastPositionOf:! - -ChangeSelectorSendersStepWindow removeSelector: #changeRequestSenders! - -ChangeSelectorSendersStepWindow removeSelector: #changeRequestSenders! - -ChangeSelectorSendersStepWindow removeSelector: #refactor! - -ChangeSelectorSendersStepWindow removeSelector: #refactor! - -SmalltalkEditor removeSelector: #ifRenameCanBeAppliedDo:! - -SmalltalkEditor removeSelector: #ifRenameCanBeAppliedDo:! - -"Postscript: -Initializes editor shortcuts" -Editor initialize. -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3843-RefactoringsRefactoring-HernanWilkinson-2019Aug17-12h36m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3843] on 19 August 2019 at 1:15:38 pm'! -!SmalltalkEditor methodsFor: 'contextual add/remove parameter' stamp: 'HAW 8/19/2019 12:32:23'! - changeSelector: aNodeUnderCursor in: aSelectedClass at: aSelectedSelector using: aChangeSelectorApplier - - aNodeUnderCursor isMessageNode - ifTrue: [ self changeSelectorOf: aNodeUnderCursor in: aSelectedClass at: aSelectedSelector using: aChangeSelectorApplier ] - ifFalse: [ morph flash ] -! ! -!SmalltalkEditor methodsFor: 'contextual add/remove parameter' stamp: 'HAW 8/19/2019 12:32:54'! - changeSelectorOf: aMessageNode in: aSelectedClass at: aSelectedSelector using: aChangeSelectorApplier - - aChangeSelectorApplier - createAndValueHandlingExceptionsOn: model textProvider - of: aMessageNode - in: aSelectedClass - at: aSelectedSelector! ! -!SmalltalkEditor methodsFor: 'contextual add/remove parameter' stamp: 'HAW 8/19/2019 12:33:40'! - changeSelectorTo: aSelector in: aClassToRefactor using: aChangeSelectorApplier - - aChangeSelectorApplier - createAndValueHandlingExceptionsOn: model textProvider - for: aSelector - in: aClassToRefactor ! ! -!SmalltalkEditor methodsFor: 'contextual add/remove parameter' stamp: 'HAW 8/19/2019 12:30:16'! - contextualChangeSelectorInMethodUsing: aChangeSelectorApplier - - self - withMethodNodeAndClassDo: [ :methodNode :selectedClass | self contextualChangeSelectorOf: methodNode in: selectedClass using: aChangeSelectorApplier ] - ifErrorsParsing: [ :anError | morph flash ] ! ! -!SmalltalkEditor methodsFor: 'contextual add/remove parameter' stamp: 'HAW 8/19/2019 12:31:37'! - contextualChangeSelectorOf: aMethodNode in: aSelectedClass using: aChangeSelectorApplier - - aMethodNode - withParseNodeIncluding: self startIndex - do: [ :nodeUnderCursor | self changeSelector: nodeUnderCursor in: aSelectedClass at: aMethodNode selector using: aChangeSelectorApplier ] - ifAbsent: [ - self startIndex <= aMethodNode selectorLastPosition - ifTrue: [ self changeSelectorTo: aMethodNode selector in: aSelectedClass using: aChangeSelectorApplier ] - ifFalse: [ morph flash ]] -! ! -!SmalltalkEditor methodsFor: 'contextual add/remove parameter' stamp: 'HAW 8/19/2019 12:29:50'! - contextualChangeSelectorUsing: aChangeSelectorApplier - - self isEditingClassDefinition - ifTrue: [ morph flash ] - ifFalse: [ self ifChangeSelectorCanBeAppliedDo: [ self contextualChangeSelectorInMethodUsing: aChangeSelectorApplier ]]! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 8/19/2019 12:22:15'! - changeKeywordOrder - - model selectedMessageName ifNotNil: [ :oldSelector | - ChangeKeywordsSelectorOrderApplier createAndValueHandlingExceptions: [ - ChangeKeywordsSelectorOrderApplier on: model for: oldSelector in: model selectedClassOrMetaClass ]].! ! -!SmalltalkEditor methodsFor: 'contextual add/remove parameter' stamp: 'HAW 8/19/2019 12:34:29' prior: 50468810! - contextualAddParameter - - self contextualChangeSelectorUsing: RefactoringApplier addParameterApplier ! ! -!SmalltalkEditor methodsFor: 'contextual add/remove parameter' stamp: 'HAW 8/19/2019 13:14:32' prior: 50468851! - contextualRemoveParameter - - self contextualChangeSelectorUsing: RefactoringApplier removeParameterApplier ! ! -!SmalltalkEditor methodsFor: 'contextual add/remove parameter' stamp: 'HAW 8/19/2019 13:15:03' prior: 50468859! - contextualRemoveParameter: aKeyboardEvent - - self contextualRemoveParameter. - ^true! ! - -CodeWindow removeSelector: #changeKeywordOrder! - -CodeWindow removeSelector: #changeKeywordOrder! - -SmalltalkEditor removeSelector: #addParameter:in:at:! - -SmalltalkEditor removeSelector: #addParameter:in:at:! - -SmalltalkEditor removeSelector: #addParameterOf:in:at:! - -SmalltalkEditor removeSelector: #addParameterOf:in:at:! - -SmalltalkEditor removeSelector: #addParameterOf:in:at:using:! - -SmalltalkEditor removeSelector: #addParameterTo:in:! - -SmalltalkEditor removeSelector: #addParameterTo:in:! - -SmalltalkEditor removeSelector: #contextualAddParameterInMethod! - -SmalltalkEditor removeSelector: #contextualAddParameterInMethod! - -SmalltalkEditor removeSelector: #contextualAddParameterOf:in:! - -SmalltalkEditor removeSelector: #contextualAddParameterOf:in:! - -SmalltalkEditor removeSelector: #contextualRemoveParameterInMethod! - -SmalltalkEditor removeSelector: #contextualRemoveParameterInMethod! - -SmalltalkEditor removeSelector: #contextualRemoveParameterOf:in:! - -SmalltalkEditor removeSelector: #contextualRemoveParameterOf:in:! - -SmalltalkEditor removeSelector: #removeParameter:in:at:! - -SmalltalkEditor removeSelector: #removeParameter:in:at:! - -SmalltalkEditor removeSelector: #removeParameterOf:in:at:! - -SmalltalkEditor removeSelector: #removeParameterOf:in:at:! - -SmalltalkEditor removeSelector: #removeParameterTo:in:! - -SmalltalkEditor removeSelector: #removeParameterTo:in:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3844-ContextualAddRemoveParameterRefactoring-HernanWilkinson-2019Aug19-06h48m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3843] on 21 August 2019 at 9:20:26 am'! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'HAW 8/21/2019 00:20:09'! - addAllSubclassesTo: allSubclasses - - self subclassesDo: [ :aSubclass | - allSubclasses add: aSubclass. - aSubclass addAllSubclassesTo: allSubclasses ]! ! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'HAW 8/21/2019 09:16:33' prior: 16783550! - allSubclasses - "Answer a Set of the receiver, the receiver's descendent's, and the - receiver's descendent's subclasses." - - | allSubclasses | - - allSubclasses := OrderedCollection new. - self addAllSubclassesTo: allSubclasses. - - ^allSubclasses ! ! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'HAW 8/21/2019 09:16:38' prior: 16783643! - withAllSubclasses - "Answer a Set of the receiver, the receiver's descendent's, and the - receiver's descendent's subclasses." - - | allSubclasses | - - allSubclasses := OrderedCollection with: self. - self addAllSubclassesTo: allSubclasses. - - ^allSubclasses ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3845-allSubclassesImprovement-HernanWilkinson-2019Aug20-19h44m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3826] on 16 August 2019 at 5:44:37 pm'! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'jpb 8/16/2019 17:34:29'! - deleteAction - "Handles deleting action, which happens when the user presses backspace or delete key within me" - | deleteActionBlock | - deleteActionBlock _ self valueOfProperty: #deleteAction ifAbsent: [ nil ]. - deleteActionBlock isNil - ifTrue: [ self flash ] - ifFalse: [ deleteActionBlock value ]. - ^self! ! -!PluggableListMorph methodsFor: 'events' stamp: 'jpb 8/16/2019 17:27:02' prior: 50449283! - keyStroke: aKeyboardEvent - "Process keys" - | aCharacter | - (self focusKeyboardFor: aKeyboardEvent) ifTrue: [ ^ self ]. - - (self arrowKey: aKeyboardEvent) ifNotNil: [ ^ self ]. - - aKeyboardEvent isEsc ifTrue: [ " escape key" ^ self mouseButton2Activity ]. - aKeyboardEvent isDelete ifTrue: [ "delete key" ^ self deleteAction ]. - aKeyboardEvent isBackspace ifTrue: [ "backspace key" ^ self deleteAction ]. - - aCharacter _ aKeyboardEvent keyCharacter. - - aKeyboardEvent anyModifierKeyPressed - ifTrue: [ - (self keystrokeAction: aCharacter) - ifTrue: [ ^self ]]. - ^ self keyboardSearch: aCharacter! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'jpb 8/16/2019 16:46:40' prior: 50414828! - isBackspace - "Returns true if the pressed key is a backspace key. In Text Editors, pressing backspace usually means to delete the character before the cursor position" - ^ keyValue = 8! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'jpb 8/16/2019 16:47:15' prior: 50460273! - isDelete - "Returns true on the delete key, which is not the same as the backspace key. In Text Editors, it usually means to delete the character after the cursor" - ^keyValue = 127 ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3846-DeleteActioninPluggableListMorph-JosefPhilipBernhart-2019Aug16-16h39m-jpb.1.cs.st----! - -'From Cuis 5.0 [latest update: #3840] on 21 August 2019 at 12:30:57 pm'! -!CPUWatcher methodsFor: 'startup-shutdown' stamp: 'pb 8/21/2019 12:23:45' prior: 16795059! - monitorProcessPeriod: secs sampleRate: msecs suspendPorcine: aBoolean - | delay | - self stopMonitoring. - watcher _ [ - delay _ Delay forMilliseconds: msecs truncated. - [ | thisTally | - thisTally _ IdentityBag new: 20. - secs * 1000 // msecs timesRepeat: [ - delay wait. - thisTally add: Processor nextReadyProcess ]. - tally _ thisTally. - aBoolean ifTrue: [ self findThePig ]] repeat ] newProcess. - watcher - priority: Processor highestPriority; - name: 'CPUWatcher monitor'; - resume. - Processor yield.! ! -!ProcessBrowser methodsFor: 'initialization' stamp: 'pb 8/21/2019 12:16:40' prior: 16895080! - startCPUWatcher - "Answers whether I started the CPUWatcher" - - CPUWatcher isMonitoring ifFalse: [ - CPUWatcher startMonitoringPeriod: 1 rate: 25 threshold: 0.85 suspendPorcine: false. - ^true - ]. - ^false -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3847-CPUWatcher-fix-PhilBellalouna-2019Aug21-11h57m-pb.1.cs.st----! - -'From Cuis 5.0 [latest update: #3846] on 22 August 2019 at 3:48:21 pm'! -!ChangeSelectorWizardStepWindow class methodsFor: 'instance creation' stamp: 'HAW 8/22/2019 15:41:07'! - openFrom: aChangeSelectorApplier methods: methods label: aLabel selecting: somethingToSelect - - | window | - - window := self openMessageList: (self methodReferencesOf: methods) label: aLabel autoSelect: somethingToSelect. - window initializeFrom: aChangeSelectorApplier. - - ^window - -! ! -!ChangeSelectorImplementorsStepWindow class methodsFor: 'instance creation' stamp: 'HAW 8/22/2019 15:41:48' prior: 50438399! - openFrom: aChangeSelectorApplier - - ^self - openFrom: aChangeSelectorApplier - methods: aChangeSelectorApplier implementors - label: 'Implementors of #', aChangeSelectorApplier oldSelector, ' to Refactor' - selecting: nil -! ! -!ChangeSelectorSendersStepWindow class methodsFor: 'instance creation' stamp: 'HAW 8/22/2019 15:41:39' prior: 50438481! - openFrom: aChangeSelectorApplier - - ^self - openFrom: aChangeSelectorApplier - methods: aChangeSelectorApplier senders - label: 'Senders of #', aChangeSelectorApplier oldSelector, ' to Refactor' - selecting: aChangeSelectorApplier oldSelector ! ! - -ChangeSelectorWizardStepWindow class removeSelector: #openFrom:methods:label:! - -ChangeSelectorWizardStepWindow class removeSelector: #openFrom:methods:label:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3848-RenameImplementorsSelection-HernanWilkinson-2019Aug22-11h43m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3840] on 22 August 2019 at 12:10:43 pm'! -!Morph methodsFor: 'geometry' stamp: 'pb 8/22/2019 12:08:01' prior: 16875445! - morphPosition: aPoint - "Change the position of this morph. Argument is in owner's coordinates." - (location isTranslation: aPoint) ifTrue: [ "Null change" - ^ self ]. - "Invalidate the rectangle at the old position..." - self redrawNeeded. - location _ location withTranslation: aPoint. - "... and the new position" - self redrawNeeded. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3849-morphPosition-comment-PhilBellalouna-2019Aug22-12h07m-pb.1.cs.st----! - -----SNAPSHOT----(23 August 2019 10:04:40) Cuis5.0-3849-32.image priorSource: 4342627! - -----QUIT----(23 August 2019 10:05:12) Cuis5.0-3849-32.image priorSource: 4420560! - -----STARTUP---- (6 September 2019 11:33:17) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-3849-32.image! - - -'From Cuis 5.0 [latest update: #3846] on 23 August 2019 at 3:54:52 pm'! -!TestSuite class methodsFor: 'instance creation - private' stamp: 'HAW 8/23/2019 15:53:43' prior: 50444341! - forClasses: classes named: aName - - | testMethods suite classTests tests testMethod | - - "I don't want repeated tests. TestCase does not redefine #= so instead of redefining it and use a Set - I decided to keep the related tests methods in a different set and decide to add it or note base on that - - Hernan" - - testMethods := IdentitySet new. - tests := OrderedCollection new. - - classes do: [ :aClass | - classTests := (self forClass: aClass) tests. - classTests do: [ :aTest | - testMethod := aTest methodForTest. - (testMethods includes: testMethod) ifFalse: [ - testMethods add: testMethod. - tests add: aTest ]]]. - - suite := self named: aName. - suite addTests: tests. - - ^suite - -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3850-AvoidRepeatedTests-HernanWilkinson-2019Aug23-10h11m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3850] on 24 August 2019 at 10:45:54 am'! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'sqr 8/23/2019 15:32' prior: 50469599! - allSubclasses - "A breadth-first iterative algorithm. Significantly faster than a recursive, depth-first implementation." - - | answer finger fingerLimit each | - answer := OrderedCollection new. - self subclassesDo: [:some | answer add: some]. - finger := 0. - fingerLimit := answer size. - [finger < fingerLimit] whileTrue: - [ - finger + 1 to: fingerLimit do: - [:index | - each := answer at: index. - each subclassesDo: [:some | answer add: some] - ]. - finger := fingerLimit. - fingerLimit := answer size. - ]. - ^answer! ! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'sqr 8/23/2019 15:41' prior: 16783603! - allSuperclasses - "Answer an OrderedCollection of the receiver's and the receiver's - ancestor's superclasses. The first element is the receiver's immediate - superclass, followed by its superclass; the last element is Object." - - | answer pivot | - answer := OrderedCollection new. - pivot := superclass. - [pivot == nil] whileFalse: - [ - answer add: pivot. - pivot := pivot superclass - ]. - ^answer! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3851-faster-allSubclasses-allSuperclasses-AndresValloud-2019Aug24-10h36m-sqr.1.cs.st----! - -'From Cuis 5.0 [latest update: #3851] on 25 August 2019 at 11:21:31 am'! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'sqr 8/24/2019 18:19' prior: 50469859! - allSuperclasses - "Answer an OrderedCollection of the receiver's and the receiver's - ancestor's superclasses. The first element is the receiver's immediate - superclass, followed by its superclass and subsequent superclasses, - and proceeding as long as there is a non-nil superclass." - - | answer pivot | - answer := OrderedCollection new. - pivot := superclass. - [pivot == nil] whileFalse: - [ - answer add: pivot. - pivot := pivot superclass - ]. - ^answer! ! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'sqr 8/24/2019 18:25' prior: 16783618! - subclasses - "slow implementation since Behavior does not keep track of subclasses" - - ^ self class allInstances select: [:each | each superclass = self ]! ! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'HAW 8/24/2019 15:23:44' prior: 50469610! -withAllSubclasses - "Answer an OrderedCollection with the receiver, the receiver's descendents, and the - receiver's descendents' subclasses." - - ^self allSubclasses addFirst: self; yourself! ! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'sqr 8/24/2019 18:21' prior: 16783651! - withAllSuperclasses - "Answer an OrderedCollection of the receiver and the receiver's - superclasses. See also #allSuperclasses." - - ^self allSuperclasses addFirst: self; yourself! ! - -Behavior removeSelector: #addAllSubclassesTo:! - -Behavior removeSelector: #addAllSubclassesTo:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3852-allSubclassesAndFriends-AndresValloud-HernanWilkinson-2019Aug25-11h15m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3852] on 1 September 2019 at 2:19:12 pm'! -!Utilities class methodsFor: 'default desktop' stamp: 'pb 9/1/2019 14:07:42'! - pvtDefaultTextEditorContents - ^ Text - string: ' - -Cuis Smalltalk - - - -"Yay, Juan. You GO, guy!! ...a great example of malleable software (and a clever mind) at work." - Dan Ingalls - -"I like it... It''s nice and clean and simple and pretty. Nice stuff!!" - Alan Kay - -"I think you have a very elegant design aesthetic." - John Maloney - -Cuis is: - - - Small - - Clean - - Appropriable - - -Like Squeak, Cuis is also: - - - Open Source - - Multiplatform - - -Like other Smalltalk systems (including Squeak, Pharo and others), Cuis is also: - - - A complete development environment written in itself - - A pure, dynamic Object Oriented language - - -Cuis assumes very little on the underlying platform, and this lets it run out-of-the-box on Windows, MacOS, Linux, ChromeOS and WebBrowsers. Cuis shares the [OpenSmalltalk Virtual Machine](http://www.opensmalltalk.org) with Squeak, Pharo and Newspeak. - -What sets Cuis apart from the other members of the Squeak family is the focus on Smalltalk-80 and an active attitude towards system complexity: - -Unbound complexity growth, together with development strategies focused only in the short term, are the worst long term enemies of all software systems. As systems grow older, they usually become more complex. New features are added as layers on top of whatever is below, sometimes without really understanding it, and almost always without modifying it. Complexity and size grow without control. Evolution slows down. Understanding the system becomes harder every day. Bugs are harder to fix. Codebases become huge for no clear reason. At some point, the system can''t evolve anymore and becomes "legacy code". - -Complexity puts a limit to the level of understanding of the system a person might reach, and therefore limits the things that can be done with it. Dan Ingalls says all this in ["Design Principles Behind Smalltalk"](http://www.cs.virginia.edu/~evans/cs655/readings/smalltalk.html). Even if you have already done so, please go and read it again!! - -Cuis Smalltalk is our attempt at this challenge. Furthermore, we believe we are doing something else that no other Smalltalk, commercial or open source, does. We attempt to give the true Smalltalk-80 experience, and keep Smalltalk-80 not as legacy software historic significance, but as a live, evolving system. We feel we are the keepers of the Smalltalk-80 heritage, and enablers of the Dynabook experience. - -Cuis is continuously evolving towards simplicity. Each release is better (i.e. simpler) than the previous one. At the same time, features are enhanced, and any reported bugs fixed. We also adopt recent enhancements from Squeak and share our work with the wider Squeak and Smalltalk community. - - -License - -Cuis is distributed subject to the MIT License, as in http://www.opensource.org/licenses/mit-license.php . Any contribution submitted for incorporation into or for distribution with Cuis shall be presumed subject to the same license. -Portions of Cuis are: -Copyright (c) Xerox Corp. 1981, 1982 -Copyright (c) Apple Computer, Inc. 1985-1996 -Copyright (c) Contributors to Squeak and Cuis projects. 1997-2019' - runs: - (RunArray - runs: #(2 14 1 4 98 11 73 8 56 12 1 1 1 8 2 42 3 26 2 37 4 80 2 105 2065 7 405 ) - values: - ((Array new: 27) - - at: 1 - put: #(); - - at: 2 - put: - ((Array new: 4) - - at: 1 - put: - (TextAlignment basicNew - - instVarAt: 1 - put: 2; - yourself); - - at: 2 - put: - (TextFontFamilyAndSize basicNew - - instVarAt: 1 - put: 'DejaVu'; - - instVarAt: 2 - put: 22; - yourself); - - at: 3 - put: - (TextEmphasis basicNew - - instVarAt: 1 - put: 1; - yourself); - - at: 4 - put: - (TextColor basicNew - - instVarAt: 1 - put: - (Color - r: 0.0 - g: 0.0 - b: 1.0); - yourself); - yourself); - - at: 3 - put: - ((Array new: 1) - - at: 1 - put: - (TextAlignment basicNew - - instVarAt: 1 - put: 2; - yourself); - yourself); - - at: 4 - put: #(); - - at: 5 - put: - ((Array new: 2) - - at: 1 - put: - (TextAlignment basicNew - - instVarAt: 1 - put: 1; - yourself); - - at: 2 - put: - (TextFontFamilyAndSize basicNew - - instVarAt: 1 - put: 'DejaVu'; - - instVarAt: 2 - put: 9; - yourself); - yourself); - - at: 6 - put: - ((Array new: 3) - - at: 1 - put: - (TextAlignment basicNew - - instVarAt: 1 - put: 1; - yourself); - - at: 2 - put: - (TextEmphasis basicNew - - instVarAt: 1 - put: 2; - yourself); - - at: 3 - put: - (TextFontFamilyAndSize basicNew - - instVarAt: 1 - put: 'DejaVu'; - - instVarAt: 2 - put: 9; - yourself); - yourself); - - at: 7 - put: - ((Array new: 2) - - at: 1 - put: - (TextAlignment basicNew - - instVarAt: 1 - put: 1; - yourself); - - at: 2 - put: - (TextFontFamilyAndSize basicNew - - instVarAt: 1 - put: 'DejaVu'; - - instVarAt: 2 - put: 9; - yourself); - yourself); - - at: 8 - put: - ((Array new: 3) - - at: 1 - put: - (TextAlignment basicNew - - instVarAt: 1 - put: 1; - yourself); - - at: 2 - put: - (TextEmphasis basicNew - - instVarAt: 1 - put: 2; - yourself); - - at: 3 - put: - (TextFontFamilyAndSize basicNew - - instVarAt: 1 - put: 'DejaVu'; - - instVarAt: 2 - put: 9; - yourself); - yourself); - - at: 9 - put: - ((Array new: 2) - - at: 1 - put: - (TextAlignment basicNew - - instVarAt: 1 - put: 1; - yourself); - - at: 2 - put: - (TextFontFamilyAndSize basicNew - - instVarAt: 1 - put: 'DejaVu'; - - instVarAt: 2 - put: 9; - yourself); - yourself); - - at: 10 - put: - ((Array new: 3) - - at: 1 - put: - (TextAlignment basicNew - - instVarAt: 1 - put: 1; - yourself); - - at: 2 - put: - (TextEmphasis basicNew - - instVarAt: 1 - put: 2; - yourself); - - at: 3 - put: - (TextFontFamilyAndSize basicNew - - instVarAt: 1 - put: 'DejaVu'; - - instVarAt: 2 - put: 9; - yourself); - yourself); - - at: 11 - put: - ((Array new: 2) - - at: 1 - put: - (TextAlignment basicNew - - instVarAt: 1 - put: 1; - yourself); - - at: 2 - put: - (TextFontFamilyAndSize basicNew - - instVarAt: 1 - put: 'DejaVu'; - - instVarAt: 2 - put: 9; - yourself); - yourself); - - at: 12 - put: - ((Array new: 1) - - at: 1 - put: - (TextFontFamilyAndSize basicNew - - instVarAt: 1 - put: 'DejaVu'; - - instVarAt: 2 - put: 9; - yourself); - yourself); - - at: 13 - put: #(); - - at: 14 - put: - ((Array new: 1) - - at: 1 - put: - (TextEmphasis basicNew - - instVarAt: 1 - put: 1; - yourself); - yourself); - - at: 15 - put: #(); - - at: 16 - put: - ((Array new: 2) - - at: 1 - put: - (TextColor basicNew - - instVarAt: 1 - put: - (Color - r: 0.0 - g: 0.0 - b: 1.0); - yourself); - - at: 2 - put: - (TextFontFamilyAndSize basicNew - - instVarAt: 1 - put: 'DejaVu'; - - instVarAt: 2 - put: 14; - yourself); - yourself); - - at: 17 - put: #(); - - at: 18 - put: - ((Array new: 1) - - at: 1 - put: - (TextEmphasis basicNew - - instVarAt: 1 - put: 1; - yourself); - yourself); - - at: 19 - put: #(); - - at: 20 - put: - ((Array new: 2) - - at: 1 - put: - (TextFontFamilyAndSize basicNew - - instVarAt: 1 - put: 'DejaVu'; - - instVarAt: 2 - put: 14; - yourself); - - at: 2 - put: - (TextColor basicNew - - instVarAt: 1 - put: - (Color - r: 0.0 - g: 0.0 - b: 1.0); - yourself); - yourself); - - at: 21 - put: #(); - - at: 22 - put: - ((Array new: 1) - - at: 1 - put: - (TextEmphasis basicNew - - instVarAt: 1 - put: 1; - yourself); - yourself); - - at: 23 - put: #(); - - at: 24 - put: - ((Array new: 2) - - at: 1 - put: - (TextColor basicNew - - instVarAt: 1 - put: - (Color - r: 0.0 - g: 0.0 - b: 1.0); - yourself); - - at: 2 - put: - (TextFontFamilyAndSize basicNew - - instVarAt: 1 - put: 'DejaVu'; - - instVarAt: 2 - put: 14; - yourself); - yourself); - - at: 25 - put: #(); - - at: 26 - put: - ((Array new: 1) - - at: 1 - put: - (TextEmphasis basicNew - - instVarAt: 1 - put: 1; - yourself); - yourself); - - at: 27 - put: #(); - yourself)).! ! -!Utilities class methodsFor: 'default desktop' stamp: 'pb 9/1/2019 13:55:38'! - recreateDefaultDesktop - | editor | - TranscriptWindow openTranscript - morphPosition: 5 @ 290; - morphExtent: 988 @ 399. - editor _ TextEditor openTextEditor - morphPosition: 463 @ 4; - morphExtent: 894 @ 686. - editor model actualContents: self pvtDefaultTextEditorContents. - self runningWorld showTaskbar.! ! -!Utilities class methodsFor: 'default desktop' stamp: 'pb 9/1/2019 14:18:37'! - tearDownDesktop - self runningWorld hideTaskbar. - SystemWindow allSubInstancesDo: [ :ea | - ea delete ].! ! -!TextEditor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 13:30:38' prior: 16933261! - openTextEditor - - ^ SystemWindow editText: TextModel new label: 'Text Editor' wrap: true! ! -!TranscriptWindow class methodsFor: 'GUI building' stamp: 'pb 9/1/2019 13:27:51' prior: 16938768! - openTranscript - " - TranscriptWindow openTranscript - " - | win | - win _ TranscriptWindow new. - win - setLabel: 'Transcript'; - model: Transcript. - win layoutMorph addMorph: TranscriptMorph new proportionalHeight: 1. - win model when: #redraw send: #redrawNeeded to: win. - ^ win openInWorld. -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3853-recreate-default-desktop-PhilBellalouna-2019Sep01-13h18m-pb.1.cs.st----! - -'From Cuis 5.0 [latest update: #3852] on 1 September 2019 at 5:49:54 am'! - -Form subclass: #Cursor - instanceVariableNames: '' - classVariableNames: 'BlankCursor BottomLeftCursor BottomRightCursor CornerCursor CrossHairCursor CurrentCursor DownCursor MarkerCursor MenuCursor MoveCursor NormalCursor OriginCursor ReadCursor ResizeLeftCursor ResizeTopCursor ResizeTopLeftCursor ResizeTopRightCursor RightArrowCursor SquareCursor TargetCursor TopLeftCursor TopRightCursor UpCursor WaitCursor WebLinkCursor WriteCursor XeqCursor CursorDict ' - poolDictionaries: '' - category: 'Graphics-Display Objects'! - -!classDefinition: #Cursor category: #'Graphics-Display Objects'! -Form subclass: #Cursor - instanceVariableNames: '' - classVariableNames: 'BlankCursor BottomLeftCursor BottomRightCursor CornerCursor CrossHairCursor CurrentCursor CursorDict DownCursor MarkerCursor MenuCursor MoveCursor NormalCursor OriginCursor ReadCursor ResizeLeftCursor ResizeTopCursor ResizeTopLeftCursor ResizeTopRightCursor RightArrowCursor SquareCursor TargetCursor TopLeftCursor TopRightCursor UpCursor WaitCursor WebLinkCursor WriteCursor XeqCursor' - poolDictionaries: '' - category: 'Graphics-Display Objects'! -!Cursor commentStamp: '' prior: 16825810! - I am a Form that is a possible appearance for a mouse cursor. My size is always 16x16, ever since the original implementation on the Alto. - -Predefined cursors should accessed via #cursorAt: which caches Cursor instances. For example "Cursor cursorAt: #normalCursorWithMask". You can also dynamically add your own cursors or modify existing ones via #cursorAt:put: as desired.! - -LayoutAdjustingMorph subclass: #WindowEdgeAdjustingMorph - instanceVariableNames: 'selector coordinateGetter cursorGetter cursorKey ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -!classDefinition: #WindowEdgeAdjustingMorph category: #'Morphic-Layouts'! -LayoutAdjustingMorph subclass: #WindowEdgeAdjustingMorph - instanceVariableNames: 'selector coordinateGetter cursorGetter cursorKey' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! -!Cursor class methodsFor: 'accessing' stamp: 'pb 9/1/2019 00:43:01'! - cursorAt: cursorKey - ^ CursorDict - at: cursorKey - ifAbsent: [ - (self respondsTo: cursorKey) ifTrue: [ | newCursor | - newCursor _ self perform: cursorKey. - newCursor hasMask ifFalse: [ newCursor _ newCursor withMask ]. - self - cursorAt: cursorKey - put: newCursor ]].! ! -!Cursor class methodsFor: 'accessing' stamp: 'pb 8/31/2019 23:11:45'! - cursorAt: cursorKey put: aCursor - ^ CursorDict at: cursorKey put: aCursor! ! -!Cursor class methodsFor: 'accessing' stamp: 'pb 9/1/2019 04:32:41'! - defaultCursor - "Answer the instance of me that is the shape of an arrow slanted left." - ^ Preferences biggerCursors - ifTrue: [ CursorWithAlpha biggerNormal ] - ifFalse: [ self cursorAt: #normalCursorWithMask ].! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:40:46'! - blankCursor - "Answer the instance of me that is all white." - ^ self new.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 8/31/2019 23:29:22'! - bottomLeftCursor - ^ self - extent: 16 @ 16 - fromArray: #(49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 65532 65532 0 0 ) - offset: 0 @ -16.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 8/31/2019 23:29:16'! - bottomRightCursor - ^ self - extent: 16 @ 16 - fromArray: #(12 12 12 12 12 12 12 12 12 12 12 12 65532 65532 0 0 ) - offset: -16 @ -16.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:41:03'! - cornerCursor - "Answer the instance of me that is the shape of the bottom right corner - of a rectangle." - ^ self - extent: 16 @ 16 - fromArray: #(12 12 12 12 12 12 12 12 12 12 12 12 65532 65532 0 0 ) - offset: -16 @ -16.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:41:14'! - crossHairCursor - "Answer the instance of me that is the shape of a cross." - ^ self - extent: 16 @ 16 - fromArray: #(0 256 256 256 256 256 256 32764 256 256 256 256 256 256 0 0 ) - offset: -7 @ -7.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:41:27'! - downCursor - "Answer the instance of me that is the shape of an arrow facing - downward." - ^ self - extent: 16 @ 16 - fromArray: #(12288 12288 12288 12288 12288 12288 12288 64512 30720 12288 0 0 0 0 0 0 ) - offset: 0 @ 0.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:42:56'! - executeCursor - "Answer the instance of me that is the shape of an arrow slanted left - with a star next to it." - ^ self - extent: 16 @ 16 - fromArray: #(32800 49184 57456 62462 63884 64648 65272 61656 55692 39172 3072 3072 1536 1536 0 0 ) - offset: 0 @ 0.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:43:07'! - markerCursor - "Answer the instance of me that is the shape of a small ball." - ^ self - extent: 16 @ 16 - fromArray: #(28672 63488 63488 28672 0 0 0 0 0 0 0 0 0 0 0 0 ) - offset: 0 @ 0.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:43:17'! - menuCursor - "Answer the instance of me that is the shape of a menu." - ^ self - extent: 16 @ 16 - fromArray: #(65504 32800 42528 32800 54112 65504 32800 45728 32800 44192 32800 42272 32800 65504 0 ) - offset: 0 @ 0.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:43:27'! - moveCursor - "Answer the instance of me that is the shape of a cross inside a square." - ^ self - extent: 16 @ 16 - fromArray: #(65532 65532 49932 49932 49932 49932 65532 65532 49932 49932 49932 49932 65532 65532 0 0 ) - offset: 0 @ 0.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:43:41'! - normalCursor - "Answer the instance of me that is the shape of an arrow slanted left." - ^ self - extent: 16 @ 16 - fromArray: #(32768 49152 57344 61440 63488 64512 65024 63488 63488 38912 3072 3072 1536 1536 768 768 ) - offset: 0 @ 0.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 8/31/2019 23:54:01'! - normalCursorWithMask - "Cursor initNormalWithMask. Cursor normal show" - "Next two lines work simply for any cursor..." - " - self initNormal. - NormalCursor _ CursorWithMask derivedFrom: NormalCursor. - " - "But for a good looking cursor, you have to tweak things..." - ^ (CursorWithMask - extent: 16 @ 16 - depth: 1 - fromArray: #(0 1073741824 1610612736 1879048192 2013265920 2080374784 2113929216 2130706432 2139095040 2080374784 1811939328 1174405120 100663296 50331648 50331648 0 ) - offset: -1 @ -1) setMaskForm: - (Form - extent: 16 @ 16 - depth: 1 - fromArray: #(3221225472 3758096384 4026531840 4160749568 4227858432 4261412864 4278190080 4286578688 4290772992 4292870144 4261412864 4009754624 3472883712 2273312768 125829120 58720256 ) - offset: 0 @ 0).! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:43:57'! - originCursor - "Answer the instance of me that is the shape of the top left corner of a - rectangle." - ^ self - extent: 16 @ 16 - fromArray: #(65532 65532 49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 0 0 ) - offset: 0 @ 0.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:44:07'! - readCursor - "Answer the instance of me that is the shape of eyeglasses." - ^ self - extent: 16 @ 16 - fromArray: #(0 0 4104 10260 16416 64480 33824 33824 46496 31680 0 0 0 0 0 0 ) - offset: 0 @ 0.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:07:52'! - resizeBottomCursor - ^ self cursorAt: #resizeTopCursor! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:08:37'! - resizeBottomLeftCursor - ^ self cursorAt: #resizeTopRightCursor! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:11:24'! - resizeBottomRightCursor - ^ self cursorAt: #resizeTopLeftCursor! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 8/31/2019 23:38:39'! - resizeLeftCursor - ^ (self - extent: 16 @ 16 - fromArray: #(0 1152 1152 1152 5280 13488 29880 64764 29880 13488 5280 1152 1152 1152 0 0 ) - offset: -7 @ -7) withMask.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:12:01'! - resizeRightCursor - ^ self cursorAt: #resizeLeftCursor! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 8/31/2019 23:39:40'! - resizeTopCursor - ^ (self - extent: 16 @ 16 - fromArray: #(256 896 1984 4064 256 32764 0 0 32764 256 4064 1984 896 256 0 ) - offset: -7 @ -7) withMask.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 8/31/2019 23:40:11'! - resizeTopLeftCursor - ^ (self - extent: 16 @ 16 - fromArray: #(0 31760 30752 28740 26760 17680 544 1088 2176 4420 8748 1052 2108 124 0 0 ) - offset: -7 @ -7) withMask.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 8/31/2019 23:40:38'! - resizeTopRightCursor - ^ (self - extent: 16 @ 16 - fromArray: #(0 4220 2108 17436 8748 4420 2176 1088 544 17680 26760 28736 30752 31744 0 0 ) - offset: -7 @ -7) withMask.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:44:30'! - rightArrowCursor - "Answer the instance of me that is the shape of an arrow pointing to the right." - ^ self - extent: 16 @ 16 - fromArray: #(1536 1920 2016 65528 2016 1920 1536 0 0 0 0 0 0 0 0 0 ) - offset: 0 @ 0.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:44:49'! - squareCursor - "Answer the instance of me that is the shape of a square." - ^ self - extent: 16 @ 16 - fromArray: #(0 0 0 0 0 960 960 960 960 0 0 0 0 0 0 0 ) - offset: -8 @ -8.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:45:00'! - targetCursor - "Answer the instance of me that is the shape of a gunsight." - ^ self - extent: 16 @ 16 - fromArray: #(1984 6448 8456 16644 17284 33026 35106 65278 35106 33026 17284 16644 8456 6448 1984 0 ) - offset: -7 @ -7.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 8/31/2019 23:44:44'! - topLeftCursor - ^ self - extent: 16 @ 16 - fromArray: #(65532 65532 49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 0 0 ) - offset: 0 @ 0.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 8/31/2019 23:45:08'! - topRightCursor - ^ self - extent: 16 @ 16 - fromArray: #(65532 65532 12 12 12 12 12 12 12 12 12 12 12 12 0 0 ) - offset: -16 @ 0.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:45:13'! - upCursor - "Answer the instance of me that is the shape of an arrow facing upward." - ^ self - extent: 16 @ 16 - fromArray: #(12288 30720 64512 12288 12288 12288 12288 12288 12288 12288 0 0 0 0 0 0 ) - offset: 0 @ 0.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:45:22'! - waitCursor - "Answer the instance of me that is the shape of an Hourglass (was in the - shape of three small balls)." - ^ self - extent: 16 @ 16 - fromArray: #(65532 32772 16392 8208 7392 4032 1920 1920 2368 4384 8592 17352 36852 65532 0 ) - offset: 0 @ 0.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:45:34'! - webLinkCursor - "Return a cursor that can be used for emphasizing web links" - ^ (CursorWithMask - extent: 16 @ 16 - fromArray: #(3072 4608 4608 4608 4608 5046 4681 29257 37449 37449 32769 32769 49155 16386 24582 16380 ) - offset: -5 @ 0) setMaskForm: - (Form - extent: 16 @ 16 - fromArray: - (#(3072 7680 7680 7680 7680 8118 8191 32767 65535 65535 65535 65535 65535 32766 32766 16380 ) collect: [ :bits | - bits bitShift: 16 ]) - offset: 0 @ 0).! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:45:43'! - writeCursor - "Answer the instance of me that is the shape of a pen writing." - ^ self - extent: 16 @ 16 - fromArray: #(24 60 72 144 288 580 1156 2316 4624 9232 30728 20728 57728 32512 0 0 ) - offset: 0 @ 0.! ! -!Debugger methodsFor: 'initialization' stamp: 'pb 9/1/2019 04:32:41' prior: 50379254! - openNotifierContents: msgString label: label - "Create and schedule a notifier view with the given label and message. A notifier view shows just the message or the first several lines of the stack, with a menu that allows the user to open a full debugger if so desired." - "NOTE: When this method returns, a new process has been scheduled to run the windows, and thus this notifier, but the previous active porcess has not been suspended. The sender will do this." - | msg | - Sensor flushKeyboard. - savedCursor _ Cursor currentCursor. - Cursor defaultCursor activateCursor. - msg _ (label beginsWith: 'Space is low') - ifTrue: [ self lowSpaceChoices , (msgString ifNil: [ '' ]) ] - ifFalse: [ msgString ]. - interruptedProcessUI _ UISupervisor newProcessIfUI: interruptedProcess. - UISupervisor whenUIinSafeState: [ - PreDebugWindow - open: self - label: label - message: msg ].! ! -!EventSensor methodsFor: 'private' stamp: 'pb 9/1/2019 04:32:41' prior: 16839421! - eventTickler - "If the UI process hasn't processed events in a while, do it here. - This is needed to detect the interrupt key." - | delay delta | - delay _ Delay forMilliseconds: self class eventPollPeriod. - self lastEventPoll. - "ensure not nil." - [ - [ - delay wait. - delta _ Time localMillisecondClock - lastEventPoll. - delta > self class eventPollPeriod ifTrue: [ - "See #doOneCycleNowFor:" - Cursor currentCursor = Cursor defaultCursor ifTrue: [ (Cursor cursorAt: #waitCursor) activateCursor ]. - "Discard any mouse events. This code is run when the UI is slow, essentially to have a working - interrupt key. Processing mouse events is pointless: the UI will not handle them anyway. - In addition, at least on Windows 7, when the machine is suspended and resumed with Cuis - running, a lot of meaningless mouseMove events with the same coordinates are sent, maing - Cuis extremely slow and CPU hungry for a few minutes without reason. Discarding mouse - events makes the 'processing' of those very quick." - self fetchMoreEventsDiscardingMouseEvents: true ]] - on: Error - do: [ :ex | - nil ]] repeat.! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'pb 9/1/2019 01:30:55' prior: 50432426! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag - "WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " - | activeProc | - activeProc _ Processor activeProcess. - [ | isARealStartup guiRootObject guiRootObjectClass reopenTranscript | - save not & quit - ifTrue: [ - (SourceFiles at: 2) ifNotNil: [ :changes | - ChangesInitialFileSize ifNotNil: [ changes truncate: ChangesInitialFileSize ]]] - ifFalse: [ - self - logSnapshot: save - andQuit: quit ]. - reopenTranscript _ false. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | - each isInWorld ifTrue: [ - each delete. - reopenTranscript _ true ]]. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - "Cosas que levanto explicitamente abajo" - guiRootObjectClass _ UISupervisor ui class. - guiRootObject _ UISupervisor ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "guiRootObject _ clearAllStateFlag ifFalse: [ UISupervisor ui ]." - UISupervisor stopUIProcess. - activeProc isTerminated ifFalse: [ activeProc terminate ]. - "Clean Globals" - Smalltalk - at: #Sensor - put: nil. - Smalltalk - at: #Display - put: nil. - Smalltalk closeSourceFiles. - Smalltalk - at: #SourceFiles - put: nil. - Smalltalk allClassesDo: [ :cls | - cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | - cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ Smalltalk printStuffToCleanOnImageSave ]. - "Do image save & quit as apropriate" - (Cursor cursorAt: #writeCursor) activateCursor. - save - ifTrue: [ - "The snapshot primitive answers false if it was just called to do the snapshot. - But image startup is resumed by returning (again) from the primitive, but this time answering true." - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk - at: #Sensor - put: nil. - Smalltalk - at: #Display - put: DisplayScreen new. - Smalltalk - at: #SourceFiles - put: (Array new: 2). - Smalltalk openSourceFiles. - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | - cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - UISupervisor spawnNewMorphicProcessFor: (guiRootObject ifNil: [ guiRootObject _ guiRootObjectClass newWorld ]). - Display triggerEvent: #screenSizeChanged. - self restoreLostChangesIfNecessary. - UISupervisor whenUIinSafeState: [ - "guiRootObject fullRepaintNeeded." - reopenTranscript ifTrue: [ TranscriptWindow openTranscript ]]. - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - UISupervisor whenUIinSafeState: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]] - forkAt: Processor timingPriority - 1 - named: 'Startup process'.! ! -!SystemDictionary methodsFor: 'startup' stamp: 'pb 9/1/2019 04:32:41' prior: 50381554! - doStartUp: isARealStartup - " - isARealStartup - true: system is coming up (VM and image just started) - false: we have just saved an image snapshot, but didn't quit. - " - "Here, startup begins!!" - Cursor defaultCursor activateCursor. - self setGCParameters. - isARealStartup ifTrue: [ self clearExternalObjects ]. - self readCommandLineArguments. - self processStartUpList: isARealStartup. - isARealStartup ifTrue: [ - self setPlatformPreferences. - self setStartupStamp ].! ! -!UISupervisor class methodsFor: 'services' stamp: 'pb 9/1/2019 04:32:41' prior: 50380123! - restoreDisplay - DisplayScreen startUp. - self ui ifNotNil: [ :guiRootObject | - guiRootObject restoreDisplay ]. - self whenUIinSafeState: [ Cursor defaultCursor activateCursor ].! ! -!Cursor class methodsFor: 'class initialization' stamp: 'pb 9/1/2019 03:36:04' prior: 16826333! - initialize - CursorDict _ Dictionary new. -! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 03:19:53' prior: 16826391! - resizeForEdge: aSymbol - "Cursor resizeForEdge: #topCursor" - "Cursor resizeForEdge: #bottomLeftCursor" - - "Do not erase this literal, as it helps 'senders' workproperly, and it protects these methods from accidental deletion" - self nominallyUnsent: #(#resizeBottomCursor #resizeBottomLeftCursor #resizeBottomRightCursor #resizeLeftCursor #resizeRightCursor #resizeTopCursor #resizeTopLeftCursor #resizeTopRightCursor ). - - ^ self perform: ('resize' , aSymbol first asString asUppercase - , (aSymbol copyFrom: 2 to: aSymbol size), 'Cursor') asSymbol! ! -!CursorWithAlpha methodsFor: 'accessing' stamp: 'pb 9/1/2019 04:02:28' prior: 16826611! -fallback - ^fallback ifNil: [self class cursorAt: #normalCursorWithMask]! ! -!Point class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 04:32:41' prior: 16890849! - fromUser - Sensor waitNoButton. - (Cursor cursorAt: #crossHairCursor) activateCursor. - Sensor waitButton. - Cursor defaultCursor activateCursor. - ^ Sensor mousePoint"Point fromUser".! ! -!Rectangle class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:30:37' prior: 16899091! - fromUser - "Answer a Rectangle that is determined by having the user - designate the top left and bottom right corners." - | originRect | - originRect _ (Cursor cursorAt: #originCursor) showWhile: [ - (Sensor mousePoint extent: 0 @ 0) newRectFrom: [ :f | - Sensor mousePoint extent: 0 @ 0 ]]. - ^ (Cursor cursorAt: #cornerCursor) showWhile: [ - originRect newRectFrom: [ :f | - f origin corner: Sensor mousePoint ]].! ! -!Rectangle class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:30:41' prior: 16899156! - originFromUser: extentPoint - "Answer an instance of me that is determined by having the user - designate the top left corner. The width and height are determined by - extentPoint." - ^ (Cursor cursorAt: #originCursor) showWhile: [ - (Sensor mousePoint extent: extentPoint) newRectFrom: [ :f | - Sensor mousePoint extent: extentPoint ]].! ! -!PasteUpMorph class methodsFor: 'system startup' stamp: 'pb 9/1/2019 04:32:41' prior: 50380984! - initClassCachedState - "Should use some other way to find relevant instances" - self flag: #jmvVer2. - self allInstancesDo: [ :each | - each buildMagnifiedBackgroundImage. - each isWorldMorph ifTrue: [ each redrawNeeded ]]. - Cursor defaultCursor activateCursor.! ! -!HandMorph methodsFor: 'drawing' stamp: 'pb 9/1/2019 01:31:41' prior: 50388306! - drawOn: aCanvas - "Draw the hand itself (i.e., the cursor)." - "This method is only called when we are carrying morphs around..." - aCanvas - stencil: (Cursor cursorAt: #moveCursor) - at: 0 @ 0 - color: Color black.! ! -!HandMorph methodsFor: 'drawing' stamp: 'pb 9/1/2019 01:31:53' prior: 16851639! - needsToBeDrawn - "Return true if this hand must be drawn explicitely instead of being drawn via the hardware cursor. This is the case if it (a) it is a remote hand, (b) it is showing a temporary cursor, or (c) it is not empty and there are any visible submorphs. If using the software cursor, ensure that the hardware cursor is hidden." - "Details: Return true if this hand has a saved patch to ensure that is is processed by the world. This saved patch will be deleted after one final display pass when it becomes possible to start using the hardware cursor again. This trick gives us one last display cycle to allow us to remove the software cursor from the display." - "Note. We draw the hand as a regular morph (using #drawOn:), disabling the hardware cursor, when we carry submorphs. The reason is to lock the mouse pointer and the carried morph together. Otherwhise the carried morph would lag behind the mouse pointer. - This method answers whether the regular #drawOn: drawing mechanism is used for us. - - Check senders. Hand drawing is handled explicitly by the world, because the Hand is not a submorph of the world!!" - (savedPatch notNil or: [ - submorphs anySatisfy: [ :ea | - ea visible ]]) ifTrue: [ - "using the software cursor; hide the hardware one" - Cursor currentCursor == (Cursor cursorAt: #blankCursor) ifFalse: [ (Cursor cursorAt: #blankCursor) activateCursor ]. - ^ true ]. - ^ false.! ! -!HandMorph methodsFor: 'drawing' stamp: 'pb 9/1/2019 04:32:41' prior: 16851684! - restoreSavedPatchOn: aCanvas - "Clear the changed flag and restore the part of the given canvas under this hand from the previously saved patch. If necessary, handle the transition to using the hardware cursor." - hasChanged _ false. - savedPatch ifNotNil: [ - aCanvas - image: savedPatch - at: savedPatch offset. - submorphs notEmpty ifTrue: [ ^ self ]. - "Make the transition to using hardware cursor. Clear savedPatch and - report one final damage rectangle to erase the image of the software cursor." - " owner invalidateDisplayRect: (savedPatch offset extent: savedPatch extent) from: nil." - self - invalidateDisplayRect: (self morphPosition extent: extent) - from: nil. - Cursor currentCursor == Cursor defaultCursor ifFalse: [ Cursor defaultCursor activateCursor ]. - "show hardware cursor" - savedPatch _ nil ].! ! -!HandMorph methodsFor: 'initialization' stamp: 'pb 9/1/2019 04:32:41' prior: 16852171! - initialize - super initialize. - self initForEvents. - keyboardFocus _ nil. - mouseFocus _ nil. - extent _ CursorWithMask defaultCursor extent. - damageRecorder _ DamageRecorder new. - grabMorphData _ IdentityDictionary new. - self initForEvents.! ! -!LayoutAdjustingMorph methodsFor: 'accessing' stamp: 'pb 9/1/2019 03:02:06' prior: 16862873! - cursor - ^ owner direction == #horizontal - ifTrue: [ Cursor cursorAt: #resizeLeftCursor ] - ifFalse: [ Cursor cursorAt: #resizeTopCursor ].! ! -!LayoutAdjustingMorph methodsFor: 'events' stamp: 'pb 9/1/2019 04:32:41' prior: 16862905! - mouseLeave: anEvent - super mouseLeave: anEvent. - hand ifNotNil: [ - hand _ nil. - Cursor defaultCursor activateCursor ].! ! -!LayoutAdjustingMorph methodsFor: 'stepping' stamp: 'pb 9/1/2019 04:32:41' prior: 16862921! - stepAt: millisecondSinceLast - "got the #mouseLeave: message" - | p | - hand ifNil: [ - Cursor currentCursor == self cursor ifTrue: [ Cursor defaultCursor activateCursor ]. - ^ self stopStepping ]. - "hasn't got the #mouseLeave: message (yet)" - p _ hand morphPosition. - hand lastMouseEvent mouseButton1Pressed - ifTrue: [ - self adjustOwnerAt: p. - Preferences cheapWindowReframe ifTrue: [ - owner morphBoundsInWorld newRectFrom: [ :f | - self adjustOwnerAt: Sensor mousePoint. - owner morphBoundsInWorld ]]] - ifFalse: [ - self stopStepping. - "If the button was unpressed outside the morph (can happen if you try to go outside container), - we might not get the #mouseLeave: message" - (self morphContainsPoint: (self internalizeFromWorld: p)) ifFalse: [ - hand _ nil. - Cursor defaultCursor activateCursor ]].! ! -!WindowEdgeAdjustingMorph methodsFor: 'initialization' stamp: 'pb 9/1/2019 05:47:40' prior: 16945044! - initializeBottom - selector _ #windowBottom:. - coordinateGetter _ #y. - cursorKey _ #resizeBottomCursor! ! -!WindowEdgeAdjustingMorph methodsFor: 'initialization' stamp: 'pb 9/1/2019 05:47:14' prior: 16945050! - initializeBottomLeft - selector _ #windowBottomLeft:. - coordinateGetter _ #yourself. - cursorKey _ #resizeBottomLeftCursor! ! -!WindowEdgeAdjustingMorph methodsFor: 'initialization' stamp: 'pb 9/1/2019 05:47:22' prior: 16945057! - initializeBottomRight - selector _ #windowBottomRight:. - coordinateGetter _ #yourself. - cursorKey _ #resizeBottomRightCursor! ! -!WindowEdgeAdjustingMorph methodsFor: 'initialization' stamp: 'pb 9/1/2019 05:47:07' prior: 16945064! - initializeLeft - selector _ #windowLeft:. - coordinateGetter _ #x. - cursorKey _ #resizeLeftCursor! ! -!WindowEdgeAdjustingMorph methodsFor: 'initialization' stamp: 'pb 9/1/2019 05:47:34' prior: 16945070! - initializeRight - selector _ #windowRight:. - coordinateGetter _ #x. - cursorKey _ #resizeRightCursor! ! -!WindowEdgeAdjustingMorph methodsFor: 'initialization' stamp: 'pb 9/1/2019 05:48:00' prior: 16945076! - initializeTop - selector _ #windowTop:. - coordinateGetter _ #y. - cursorKey _ #resizeTopCursor! ! -!WindowEdgeAdjustingMorph methodsFor: 'initialization' stamp: 'pb 9/1/2019 05:47:55' prior: 16945082! - initializeTopLeft - selector _ #windowTopLeft:. - coordinateGetter _ #yourself. - cursorKey _ #resizeTopLeftCursor! ! -!WindowEdgeAdjustingMorph methodsFor: 'initialization' stamp: 'pb 9/1/2019 05:47:49' prior: 16945089! - initializeTopRight - selector _ #windowTopRight:. - coordinateGetter _ #yourself. - cursorKey _ #resizeTopRightCursor! ! -!WindowEdgeAdjustingMorph methodsFor: 'accessing' stamp: 'pb 9/1/2019 05:47:45' prior: 16945106! - cursor - ^ Cursor cursorAt: cursorKey.! ! -!WorldState methodsFor: 'update cycle' stamp: 'pb 9/1/2019 04:32:41' prior: 50339961! - doOneCycleNow - "Immediately do one cycle of the interaction loop." - "See #eventTickler" - | hadAnyEvent | - Cursor currentCursor = (Cursor cursorAt: #waitCursor) ifTrue: [ Cursor defaultCursor activateCursor ]. - "Repair visual damage." - DisplayScreen checkForNewScreenSize. - self displayWorldSafely. - "Run steps, alarms and deferred UI messages" - self runStepMethods. - "Process user input events. Run all event triggered code." - hadAnyEvent _ false. - self handsDo: [ :h | - activeHand _ h. - hadAnyEvent _ hadAnyEvent | h processEventQueue. - activeHand _ nil ]. - "The default is the primary hand" - activeHand _ self hands first. - ^ hadAnyEvent.! ! - -Cursor class removeSelector: #blank! - -Cursor class removeSelector: #blank! - -Cursor class removeSelector: #bottomLeft! - -Cursor class removeSelector: #bottomLeft! - -Cursor class removeSelector: #bottomRight! - -Cursor class removeSelector: #bottomRight! - -Cursor class removeSelector: #corner! - -Cursor class removeSelector: #corner! - -Cursor class removeSelector: #crossHair! - -Cursor class removeSelector: #crossHair! - -Cursor class removeSelector: #down! - -Cursor class removeSelector: #down! - -Cursor class removeSelector: #execute! - -Cursor class removeSelector: #execute! - -Cursor class removeSelector: #initBottomLeft! - -Cursor class removeSelector: #initBottomLeft! - -Cursor class removeSelector: #initBottomRight! - -Cursor class removeSelector: #initBottomRight! - -Cursor class removeSelector: #initCorner! - -Cursor class removeSelector: #initCorner! - -Cursor class removeSelector: #initCrossHair! - -Cursor class removeSelector: #initCrossHair! - -Cursor class removeSelector: #initDown! - -Cursor class removeSelector: #initDown! - -Cursor class removeSelector: #initMarker! - -Cursor class removeSelector: #initMarker! - -Cursor class removeSelector: #initMenu! - -Cursor class removeSelector: #initMenu! - -Cursor class removeSelector: #initMove! - -Cursor class removeSelector: #initMove! - -Cursor class removeSelector: #initNormal! - -Cursor class removeSelector: #initNormal! - -Cursor class removeSelector: #initNormalWithMask! - -Cursor class removeSelector: #initNormalWithMask! - -Cursor class removeSelector: #initOrigin! - -Cursor class removeSelector: #initOrigin! - -Cursor class removeSelector: #initRead! - -Cursor class removeSelector: #initRead! - -Cursor class removeSelector: #initResizeLeft! - -Cursor class removeSelector: #initResizeLeft! - -Cursor class removeSelector: #initResizeTop! - -Cursor class removeSelector: #initResizeTop! - -Cursor class removeSelector: #initResizeTopLeft! - -Cursor class removeSelector: #initResizeTopLeft! - -Cursor class removeSelector: #initResizeTopRight! - -Cursor class removeSelector: #initResizeTopRight! - -Cursor class removeSelector: #initRightArrow! - -Cursor class removeSelector: #initRightArrow! - -Cursor class removeSelector: #initSquare! - -Cursor class removeSelector: #initSquare! - -Cursor class removeSelector: #initTarget! - -Cursor class removeSelector: #initTarget! - -Cursor class removeSelector: #initTopLeft! - -Cursor class removeSelector: #initTopLeft! - -Cursor class removeSelector: #initTopRight! - -Cursor class removeSelector: #initTopRight! - -Cursor class removeSelector: #initUp! - -Cursor class removeSelector: #initUp! - -Cursor class removeSelector: #initWait! - -Cursor class removeSelector: #initWait! - -Cursor class removeSelector: #initWrite! - -Cursor class removeSelector: #initWrite! - -Cursor class removeSelector: #initXeq! - -Cursor class removeSelector: #initXeq! - -Cursor class removeSelector: #makeCursorsWithMask! - -Cursor class removeSelector: #makeCursorsWithMask! - -Cursor class removeSelector: #marker! - -Cursor class removeSelector: #marker! - -Cursor class removeSelector: #menu! - -Cursor class removeSelector: #menu! - -Cursor class removeSelector: #move! - -Cursor class removeSelector: #move! - -Cursor class removeSelector: #normal! - -Cursor class removeSelector: #normal! - -Cursor class removeSelector: #normalOrBiggerCursor! - -Cursor class removeSelector: #origin! - -Cursor class removeSelector: #origin! - -Cursor class removeSelector: #read! - -Cursor class removeSelector: #read! - -Cursor class removeSelector: #resizeBottom! - -Cursor class removeSelector: #resizeBottom! - -Cursor class removeSelector: #resizeBottomLeft! - -Cursor class removeSelector: #resizeBottomLeft! - -Cursor class removeSelector: #resizeBottomRight! - -Cursor class removeSelector: #resizeBottomRight! - -Cursor class removeSelector: #resizeLeft! - -Cursor class removeSelector: #resizeLeft! - -Cursor class removeSelector: #resizeRight! - -Cursor class removeSelector: #resizeRight! - -Cursor class removeSelector: #resizeTop! - -Cursor class removeSelector: #resizeTop! - -Cursor class removeSelector: #resizeTopLeft! - -Cursor class removeSelector: #resizeTopLeft! - -Cursor class removeSelector: #resizeTopRight! - -Cursor class removeSelector: #resizeTopRight! - -Cursor class removeSelector: #rightArrow! - -Cursor class removeSelector: #rightArrow! - -Cursor class removeSelector: #square! - -Cursor class removeSelector: #square! - -Cursor class removeSelector: #target! - -Cursor class removeSelector: #target! - -Cursor class removeSelector: #topLeft! - -Cursor class removeSelector: #topLeft! - -Cursor class removeSelector: #topRight! - -Cursor class removeSelector: #topRight! - -Cursor class removeSelector: #up! - -Cursor class removeSelector: #up! - -Cursor class removeSelector: #wait! - -Cursor class removeSelector: #wait! - -Cursor class removeSelector: #webLink! - -Cursor class removeSelector: #webLink! - -Cursor class removeSelector: #write! - -Cursor class removeSelector: #write! - -Cursor class removeSelector: #xeqCursor! - -Form subclass: #Cursor - instanceVariableNames: '' - classVariableNames: 'CurrentCursor CursorDict' - poolDictionaries: '' - category: 'Graphics-Display Objects'! - -!classDefinition: #Cursor category: #'Graphics-Display Objects'! -Form subclass: #Cursor - instanceVariableNames: '' - classVariableNames: 'CurrentCursor CursorDict' - poolDictionaries: '' - category: 'Graphics-Display Objects'! - -Cursor initialize! - -LayoutAdjustingMorph subclass: #WindowEdgeAdjustingMorph - instanceVariableNames: 'selector coordinateGetter cursorKey' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -!classDefinition: #WindowEdgeAdjustingMorph category: #'Morphic-Layouts'! -LayoutAdjustingMorph subclass: #WindowEdgeAdjustingMorph - instanceVariableNames: 'selector coordinateGetter cursorKey' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -Utilities runningWorld hideTaskbar! - -TranscriptWindow allInstancesDo: [ :t | t delete ]! - -SystemWindow allInstancesDo: [ :t | t delete ]! - -Cursor initialize! - -Utilities recreateDefaultDesktop! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3854-Cursor-cleanup-PhilBellalouna-2019Aug31-23h08m-pb.1.cs.st----! - -'From Cuis 5.0 [latest update: #3854] on 3 September 2019 at 11:58:35 am'! -!String methodsFor: 'text conversion emphasis' stamp: 'jmv 9/3/2019 10:17:21'! - pointSize: pointSize - "Stuff like - ('Hello World' pointSize: 22) edit - " - ^self asText pointSize: pointSize! ! -!String methodsFor: 'text conversion attributes' stamp: 'jmv 9/3/2019 10:08:21'! -centered - "Stuff like - ('Hello world' centered ) edit - " - ^self asText centered! ! -!String methodsFor: 'text conversion attributes' stamp: 'jmv 9/3/2019 10:08:52'! - justified - "Stuff like - ('Hello world' justified ) edit - " - ^self asText justified! ! -!String methodsFor: 'text conversion attributes' stamp: 'jmv 9/3/2019 10:09:50'! - leftFlush - "Stuff like - ('Hello world' leftFlush ) edit - " - ^self asText leftFlush! ! -!String methodsFor: 'text conversion attributes' stamp: 'jmv 9/3/2019 10:10:05'! - rightFlush - "Stuff like - ('Hello world' rightFlush ) edit - " - ^self asText rightFlush! ! -!String methodsFor: 'text conversion color' stamp: 'jmv 9/3/2019 10:29:49'! - black - "Stuff like - 'Hello world' black edit - " - ^self asText black! ! -!String methodsFor: 'text conversion color' stamp: 'jmv 9/3/2019 10:29:58'! - blue - "Stuff like - 'Hello world' blue edit - " - ^self asText blue! ! -!String methodsFor: 'text conversion color' stamp: 'jmv 9/3/2019 10:30:04'! - cyan - "Stuff like - 'Hello world' cyan edit - " - ^self asText cyan! ! -!String methodsFor: 'text conversion color' stamp: 'jmv 9/3/2019 10:30:11'! - gray - "Stuff like - 'Hello world' gray edit - " - ^self asText gray! ! -!String methodsFor: 'text conversion color' stamp: 'jmv 9/3/2019 10:30:19'! - green - "Stuff like - 'Hello world' green edit - " - ^self asText green! ! -!String methodsFor: 'text conversion color' stamp: 'jmv 9/3/2019 10:31:04'! - magenta - "Stuff like - 'Hello world' magenta edit - " - ^self asText magenta! ! -!String methodsFor: 'text conversion color' stamp: 'jmv 9/3/2019 10:31:17'! - red - "Stuff like - 'Hello world' red edit - " - ^self asText red! ! -!String methodsFor: 'text conversion color' stamp: 'jmv 9/3/2019 10:31:27'! - yellow - "Stuff like - 'Hello world' yellow edit - " - ^self asText yellow! ! -!Text methodsFor: 'adding emphasis' stamp: 'jmv 9/3/2019 10:16:59'! - pointSize: pointSize - "Stuff like - ('Hello World' pointSize: 22) edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: (TextFontFamilyAndSize pointSize: pointSize) from: 1 to: string size! ! -!Text methodsFor: 'adding attributes' stamp: 'jmv 9/3/2019 10:08:33'! - centered - "Stuff like - ('Hello world' centered ) edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextAlignment centered from: 1 to: string size! ! -!Text methodsFor: 'adding attributes' stamp: 'jmv 9/3/2019 10:08:58'! - justified - "Stuff like - ('Hello world' justified ) edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextAlignment justified from: 1 to: string size! ! -!Text methodsFor: 'adding attributes' stamp: 'jmv 9/3/2019 10:09:57'! - leftFlush - "Stuff like - ('Hello world' leftFlush ) edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextAlignment leftFlush from: 1 to: string size! ! -!Text methodsFor: 'adding attributes' stamp: 'jmv 9/3/2019 10:10:10'! - rightFlush - "Stuff like - ('Hello world' rightFlush ) edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextAlignment rightFlush from: 1 to: string size! ! -!Text methodsFor: 'adding color' stamp: 'jmv 9/3/2019 10:30:49'! - black - "Stuff like - 'Hello world' black edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextColor black from: 1 to: string size! ! -!Text methodsFor: 'adding color' stamp: 'jmv 9/3/2019 10:30:43'! - blue - "Stuff like - 'Hello world' blue edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextColor blue from: 1 to: string size! ! -!Text methodsFor: 'adding color' stamp: 'jmv 9/3/2019 10:30:38'! - cyan - "Stuff like - 'Hello world' cyan edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextColor cyan from: 1 to: string size! ! -!Text methodsFor: 'adding color' stamp: 'jmv 9/3/2019 10:30:32'! - gray - "Stuff like - 'Hello world' gray edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextColor gray from: 1 to: string size! ! -!Text methodsFor: 'adding color' stamp: 'jmv 9/3/2019 10:30:27'! - green - "Stuff like - 'Hello world' green edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextColor green from: 1 to: string size! ! -!Text methodsFor: 'adding color' stamp: 'jmv 9/3/2019 10:31:00'! - magenta - "Stuff like - 'Hello world' magenta edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextColor magenta from: 1 to: string size! ! -!Text methodsFor: 'adding color' stamp: 'jmv 9/3/2019 10:31:13'! - red - "Stuff like - 'Hello world' red edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextColor red from: 1 to: string size! ! -!Text methodsFor: 'adding color' stamp: 'jmv 9/3/2019 10:31:31'! - yellow - "Stuff like - 'Hello world' yellow edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextColor yellow from: 1 to: string size! ! -!Text methodsFor: 'emphasis' stamp: 'jmv 9/3/2019 11:44:38' prior: 50370511! - fontIfApplying: textAttributes default: defaultFont - "Answer the font for characters as specified by the argument." - - | fn ps | - self withAttributeValues: textAttributes do: [ :familyName :pointSize :emphasis :color :alignment :characterStyle :paragraphStyle :backgroundColor | - fn _ familyName ifNil: [ defaultFont ifNotNil: [ defaultFont familyName ] ifNil: [ FontFamily defaultFamilyName ]]. - ps _ pointSize ifNil: [ defaultFont ifNotNil: [ defaultFont pointSize ] ifNil: [ FontFamily defaultPointSize ]]. - ^((AbstractFont familyName: fn pointSize: ps) ifNil: [ - AbstractFont familyName: fn aroundPointSize: ps]) - emphasized: emphasis ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3855-TextEnhancements-JuanVuletich-2019Sep03-11h57m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3854] on 3 September 2019 at 11:13:52 am'! -!TextFontFamilyAndSize class methodsFor: 'instance creation' stamp: 'jmv 9/3/2019 10:14:04'! - pointSize: aNumber - "Reference only baseFonts. Any emphasis should be done with TextEmphasis. - Store only familiName and pointSize" - ^ self new familyName: FontFamily defaultFamilyName pointSize: aNumber! ! -!MessageNode methodsFor: 'private' stamp: 'jmv 9/3/2019 10:01:06' prior: 50464575! - pvtCheckForPvtSelector: encoder - "If the code being compiled is trying to send a private message (e.g. 'pvtCheckForPvtSelector:') to anyone other than self, then complain to encoder." - - selector isInitializePvtSelector ifTrue: [ - (receiver isSelfNewMessageSend or: [receiver isSelfBasicNewMessageSend]) ifFalse: [ - encoder notify: 'Private instance initialization messages may only be sent to ''self new'' or "self basicNew" (by class instance creation methods)']]. - selector isPvtSelector ifTrue: [ - (receiver isSelfPseudoVariable or: [ receiver isSuperPseudoVariable ]) ifFalse: [ - self halt. - encoder notify: 'Private messages may only be sent to self or super']].! ! -!Utilities class methodsFor: 'default desktop' stamp: 'jmv 9/3/2019 10:58:38' prior: 50469939! - pvtDefaultTextEditorContents - ^ (' -', -('Cuis Smalltalk - -' centered blue pointSize: FontFamily defaultPointSize * 3), -(' -"Yay, Juan. You GO, guy!! ...a great example of malleable software (and a clever mind) at work." -' rightFlush pointSize: FontFamily defaultPointSize * 0.6), -('Dan Ingalls -' italic rightFlush pointSize: FontFamily defaultPointSize * 0.6), -(' -"I like it... It''s nice and clean and simple and pretty. Nice stuff!!" -' rightFlush pointSize: FontFamily defaultPointSize * 0.6), -('Alan Kay -' italic rightFlush pointSize: FontFamily defaultPointSize * 0.6), -(' -"I think you have a very elegant design aesthetic." -' rightFlush pointSize: FontFamily defaultPointSize * 0.6), -('John Maloney -'italic rightFlush pointSize: FontFamily defaultPointSize * 0.6), -' - -', -'Cuis is a modern, Open Source, multiplatform, Smalltalk-80 system. - - -', -'Cuis is: - -' bold, -' - Small - - Clean - - Appropriable -' blue, -' - -Additionally, Cuis is: - -' bold, -' - Open Source - - Multiplatform -' blue, -' - -Like other Smalltalk systems, Cuis is also: - -' bold, -' - A complete development environment written in itself - - A pure, dynamic Object Oriented language -' blue, -' - -Cuis assumes very little on the underlying platform, and this lets it run out-of-the-box on Windows, MacOS, Linux, ChromeOS and WebBrowsers. Cuis shares the [OpenSmalltalk Virtual Machine] (http://www.opensmalltalk.org) with Squeak, Pharo and Newspeak. - -What sets Cuis apart from the other members of the Squeak family is the focus on Smalltalk-80 and an active attitude towards system complexity: - -Unbound complexity growth, together with development strategies focused only in the short term, are the worst long term enemies of all software systems. As systems grow older, they usually become more complex. New features are added as layers on top of whatever is below, sometimes without really understanding it, and almost always without modifying it. Complexity and size grow without control. Evolution slows down. Understanding the system becomes harder every day. Bugs are harder to fix. Codebases become huge for no clear reason. At some point, the system can''t evolve anymore and becomes "legacy code". - -Complexity puts a limit to the level of understanding of the system a person might reach, and therefore limits the things that can be done with it. Dan Ingalls says all this in ["Design Principles Behind Smalltalk"] (http://www.cs.virginia.edu/~evans/cs655/readings/smalltalk.html). Even if you have already done so, please go and read it again!! - -Cuis Smalltalk is our attempt at this challenge. Furthermore, we believe we are doing something else that no other Smalltalk, commercial or open source, does. We attempt to give the true Smalltalk-80 experience, and keep Smalltalk-80 not as legacy software historic significance, but as a live, evolving system. We feel we are the keepers of the Smalltalk-80 heritage, and enablers of the Dynabook experience. - -As Cuis evolves, we keep on these values. Every update, be it a bug fix or a feature enhancement, is reviewed carefully to avoid adding unneded complexity to the system. Every opportunity to remove unneded complexity is followed. As we go, features are enhanced, and any reported bugs fixed. We also adopt selected enhancements from Squeak and Pharo, and share our work with the wider Smalltalk community. - - -' justified, -'License -' bold, -' -Cuis is distributed subject to the MIT License, as in http://www.opensource.org/licenses/mit-license.php . Any contribution submitted for incorporation into or for distribution with Cuis shall be presumed subject to the same license. - -Portions of Cuis are: -Copyright (c) Xerox Corp. 1981, 1982 -Copyright (c) Apple Computer, Inc. 1985-1996 -Copyright (c) Contributors to Squeak and Cuis projects. 1997-2019')! ! -!Utilities class methodsFor: 'default desktop' stamp: 'jmv 9/3/2019 11:05:35' prior: 50470299! - recreateDefaultDesktop - | editor | - Utilities runningWorld hideTaskbar. - TranscriptWindow allInstancesDo: [ :t | t delete ]. - SystemWindow allInstancesDo: [ :t | t delete ]. - TranscriptWindow openTranscript - morphPosition: 5 @ 290; - morphExtent: 990 @ 400. - editor _ TextEditor openTextEditor - morphPosition: 456 @ 10; - morphExtent: 900 @ 680. - editor setLabel: 'About Cuis'. - editor model actualContents: self pvtDefaultTextEditorContents. - self runningWorld showTaskbar.! ! -!FontFamily class methodsFor: 'initialization' stamp: 'jmv 9/3/2019 11:07:48' prior: 50458050! - defaultFamilyName: aString - | family | - self revisar. "Please remove this hack meant to install larger DejaVu StrikeFonts on demand." - aString = 'DejaVu' ifTrue: [ - family _ AvailableFamilies at: aString. - (family pointSizes includes: DefaultPointSize) ifFalse: [ StrikeFont install: aString]]. - DefaultFamilyName _ aString. - Utilities recreateDefaultDesktop.! ! -!FontFamily class methodsFor: 'initialization' stamp: 'jmv 9/3/2019 11:07:44' prior: 50457082! - defaultPointSize: aNumber - DefaultPointSize _ aNumber. - Utilities recreateDefaultDesktop.! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Utilities recreateDefaultDesktop.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3856-AboutWindowTweaks-JuanVuletich-2019Sep03-11h12m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3856] on 5 September 2019 at 11:18:24 am'! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 9/5/2019 10:58:07'! - createCloseButton - ^ (PluggableButtonMorph model: self action: #closeBoxHit) - icon: Theme current closeIcon; - iconName: #drawCloseIcon; - setBalloonText: 'close this window'; - morphExtent: self titleBarButtonsExtent! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 9/5/2019 10:58:11'! - createCollapseButton - ^(PluggableButtonMorph model: self action: #collapse) - icon: Theme current collapseIcon; - iconName: #drawCollapseIcon; - setBalloonText: 'collapse this window'; - morphExtent: self titleBarButtonsExtent! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 9/5/2019 10:58:40'! - createExpandButton - ^ (PluggableButtonMorph model: self action: #expandBoxHit) - icon: Theme current expandIcon; - iconName: #drawExpandIcon; - setBalloonText: 'expand to full screen'; - morphExtent: self titleBarButtonsExtent! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 9/5/2019 10:58:54'! - createMenuButton - ^ (PluggableButtonMorph model: self action: #offerWindowMenu) - icon: Theme current windowMenuIcon; - iconName: #drawMenuIcon; - setBalloonText: 'window menu'; - morphExtent: self titleBarButtonsExtent! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 9/5/2019 08:17:04'! - titleBarButtonsExtent - "answer the extent to use for close & other title bar buttons. - - the label height is used to be proportional to the fonts preferences" - | e | - Theme current minimalWindows ifTrue: [^`0@0`]. - e _ Preferences windowTitleFont pointSize. - ^e@e! ! -!PluggableButtonMorph methodsFor: 'private' stamp: 'jmv 9/5/2019 08:24:08' prior: 50367725! - magnifiedIcon - | factor magnifiedExtent w h | - - icon ifNil: [ ^nil ]. - magnifiedIcon ifNil: [ - magnifiedIcon _ icon. - w _ icon width. - h _ icon height. - w*h = 0 ifFalse: [ - factor _ 1.0 * extent x / w min: 1.0 * extent y / h. - factor = 1.0 ifFalse: [ - magnifiedExtent _ (icon extent * factor) rounded. - magnifiedIcon _ icon magnifyTo: magnifiedExtent ]]]. - ^magnifiedIcon! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 9/5/2019 08:20:12' prior: 50458063! - drawLabelOn: aCanvas - - | x0 y0 f w availableW l | - f _ Preferences windowTitleFont. - x0 _ f lineSpacing * 4 + 14. - y0 _ 2+3. - y0 _ f lineSpacing - f ascent // 2. - availableW _ extent x - x0. - l _ labelString. - w _ f widthOfString: l. - [ w > availableW ] whileTrue: [ - l _ l squeezedTo: (1.0 * l size * availableW / w) truncated. - l isEmpty ifTrue: [ ^self ]. - w _ f widthOfString: l ]. - aCanvas - drawString: l - at: x0@y0 - font: f - color: Theme current windowLabel - embossed: Theme current embossedTitles! ! -!SystemWindow methodsFor: 'geometry' stamp: 'jmv 9/5/2019 08:36:52' prior: 50384684! - rescaleButtons - "boxExtent changed. Update my buttons." - | buttonPos buttonExtent buttonDelta| - buttonExtent := self titleBarButtonsExtent. - buttonPos _ self labelHeight + borderWidth - buttonExtent // 2 * (1@1). - buttonDelta _ buttonExtent x *14//10. - self submorphsReverseDo: [ :aMorph | - (aMorph is: #PluggableButtonMorph) - ifTrue: [ - aMorph morphExtent: buttonExtent. - aMorph morphPosition: buttonPos. - buttonPos _ buttonPos + (buttonDelta@0). - ]. - ]! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 9/5/2019 08:31:34' prior: 50384743! - initializeLabelArea - "Initialize the label area (titlebar) for the window." - - | topLeft spacing | - topLeft _ self labelHeight + borderWidth - self titleBarButtonsExtent // 2 * (1@1). - spacing _ self titleBarButtonsExtent x *14//10. - self addMorph: self createCloseButton position: topLeft. - self addMorph: self createCollapseButton position: spacing@0 + topLeft. - self addMorph: self createExpandButton position: spacing*2@0 + topLeft. - self addMorph: self createMenuButton position: spacing*3@0 + topLeft! ! -!SystemWindow methodsFor: 'label' stamp: 'jmv 9/5/2019 08:20:31' prior: 16926332! - labelHeight - "Answer the height for the window label." - - ^ Preferences windowTitleFont lineSpacing+1! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 9/5/2019 11:14:23' prior: 50388178! - addStayUpIcons - | closeButton pinButton w buttonHW | - Preferences optionalButtons ifFalse: [ ^self ]. - (self valueOfProperty: #hasStayUpIcons ifAbsent: [ false ]) - ifTrue: [ - self removeProperty: #needsStayUpIcons. - ^self ]. - titleMorph ifNil: [ - "Title not yet there. Flag ourself, so this method is called again when adding title." - self setProperty: #needsStayUpIcons toValue: true. - ^ self]. - buttonHW _ Preferences windowTitleFont pointSize. - closeButton _ PluggableButtonMorph model: self action: #delete. - closeButton icon: Theme current closeIcon; color: `Color transparent`. - pinButton _ PluggableButtonMorph model: self action: #stayUp. - pinButton icon: Theme current pushPinIcon; color: `Color transparent`. - w _ (titleMorph hasSubmorphs ifTrue: [ titleMorph firstSubmorph morphWidth ] ifFalse: [ 0 ]) + 60. - self addMorphFront: - (LayoutMorph newRow - "Make room for buttons" - morphExtent: w @ (titleMorph morphHeight max: buttonHW); - color: `Color transparent`; - addMorph: closeButton fixedWidth: buttonHW; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedWidth: buttonHW//3; - addMorph: titleMorph proportionalWidth: 1; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedWidth: buttonHW//3; - addMorph: pinButton fixedWidth: buttonHW). - - self setProperty: #hasStayUpIcons toValue: true. - self removeProperty: #needsStayUpIcons! ! - -SystemWindow removeSelector: #boxExtent! - -SystemWindow removeSelector: #boxExtent! - -SystemWindow removeSelector: #createCloseBox! - -SystemWindow removeSelector: #createCloseBox! - -SystemWindow removeSelector: #createCollapseBox! - -SystemWindow removeSelector: #createCollapseBox! - -SystemWindow removeSelector: #createExpandBox! - -SystemWindow removeSelector: #createExpandBox! - -SystemWindow removeSelector: #createMenuBox! - -SystemWindow removeSelector: #createMenuBox! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3857-BetterScalingOfWindowButtons-JuanVuletich-2019Sep05-10h56m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3849] on 3 September 2019 at 11:42:23 pm'! -!SmalltalkEditor methodsFor: 'typing/selecting keys' stamp: 'EB 9/3/2019 23:41:10' prior: 16910020! - newLine: aKeyboardEvent - "Replace the current text selection with a newLine (i.e. LF) followed by as many tabs - as there are leading tabs on the current line (+/- bracket count)." - - | char s i tabCount stopIndex newLineString | - s _ self privateCurrentString. - stopIndex _ self stopIndex. - i _ stopIndex. - tabCount _ 0. - [ (i _ i-1) > 0 and: [ (char _ s at: i) isLineSeparator not ] ] whileTrue: [ - "Count brackets" - char = $[ ifTrue: [tabCount _ tabCount + 1]. - char = $] ifTrue: [tabCount _ tabCount - 1]]. - [ (i _ i + 1) < stopIndex and: [ (char _ s at: i) isSeparator ] ] whileTrue: [ - "Count leading tabs" - char = Character tab ifTrue: [ tabCount _ tabCount + 1 ]]. - "Now inject newline with tabCount tabs, generating a new undoable command" - newLineString _ String streamContents: [ :strm | strm newLineTab: tabCount ]. - self replaceSelectionWith: newLineString shouldMergeCommandsIfPossible: false. - ^ false! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3858-NewLineSeparatesUndo-EricBrandwein-2019Sep03-23h41m-EB.1.cs.st----! - -'From Cuis 5.0 [latest update: #3858] on 5 September 2019 at 11:39:06 am'! -!TextModel methodsFor: 'undoable commands' stamp: 'jmv 9/5/2019 11:35:32'! - startNewUndoRedoCommand - - lastEditTimeStamp _ nil! ! -!TextModel methodsFor: 'undoable commands' stamp: 'jmv 9/5/2019 11:32:02' prior: 50463360! - logUndoAndReplaceFrom: start to: stop with: replacement - "As requested." - - | command now | - "Time millisecondClockValue rolls over and is generally not adviced. - But here, we don't care. A user edit doing during rollover would be split in two, as if the user did a pause. - Not a problem." - - now _ Time millisecondClockValue. - command _ self commandForReplaceFrom: start to: stop with: replacement. - (stop+1 = start and: [ lastEditTimeStamp notNil and: [ now - lastEditTimeStamp < 1000 and: [start = undoRedoCommands last stopPosition] ]]) - ifTrue: [ - "Don't use the command we just built" - undoRedoCommands last appendToNew: replacement - ] - ifFalse: [ - undoRedoCommands - nextPut: command; - truncateAtPosition. "To disable redo of previous commands, now invalidated." - ]. - command doOn: self. - lastEditTimeStamp _ now! ! -!TextEditor methodsFor: 'accessing' stamp: 'jmv 9/5/2019 11:33:21' prior: 50463369! - replaceSelectionWith: aTextOrString - "Deselect, and replace the selection text by aText." - "This is a user command, and generates undo" - - | start stop replacement | - - morph disablesEditing ifTrue: [ - ^ self ]. - - start _ self startIndex. - stop _ self stopIndex. - (aTextOrString isEmpty and: [stop > start]) ifTrue: [ - "If deleting, then set emphasisHere from 1st character of the deletion" - emphasisHere _ (model actualContents attributesAt: start) select: [:att | - att mayBeExtended]]. - - (start = stop and: [ aTextOrString isEmpty ]) ifFalse: [ - replacement _ self addAttributesForPasting: aTextOrString. - model logUndoAndReplaceFrom: start to: stop - 1 with: replacement. - textComposition - recomposeFrom: start - to: start + replacement size - 1 - delta: replacement size - (stop-start). - self deselectAndPlaceCursorAt: start + replacement size. - selectionStartBlocks _ #(). - selectionStopBlocks _ #(). - self userHasEdited " -- note text now dirty" ]. - - morph possiblyChanged! ! -!TextEditor methodsFor: 'new selection' stamp: 'jmv 9/5/2019 11:37:06' prior: 50463379! - insertAndSelect: aString at: anInteger - "This is a user command, and generates undo" - - | newText | - newText _ (aString is: #Text) ifTrue: [aString] ifFalse: [Text string: aString attributes: emphasisHere]. - self deselectAndPlaceCursorAt: anInteger. - self replaceSelectionWith: newText. - self selectFrom: anInteger to: anInteger + newText size - 1! ! -!SmalltalkEditor methodsFor: 'typing/selecting keys' stamp: 'jmv 9/5/2019 11:36:14' prior: 50472067! - newLine: aKeyboardEvent - "Replace the current text selection with a newLine (i.e. LF) followed by as many tabs - as there are leading tabs on the current line (+/- bracket count)." - - | char s i tabCount stopIndex newLineString | - s _ self privateCurrentString. - stopIndex _ self stopIndex. - i _ stopIndex. - tabCount _ 0. - [ (i _ i-1) > 0 and: [ (char _ s at: i) isLineSeparator not ] ] whileTrue: [ - "Count brackets" - char = $[ ifTrue: [tabCount _ tabCount + 1]. - char = $] ifTrue: [tabCount _ tabCount - 1]]. - [ (i _ i + 1) < stopIndex and: [ (char _ s at: i) isSeparator ] ] whileTrue: [ - "Count leading tabs" - char = Character tab ifTrue: [ tabCount _ tabCount + 1 ]]. - "Now inject newline with tabCount tabs, generating a new undoable command" - newLineString _ String streamContents: [ :strm | strm newLineTab: tabCount ]. - model startNewUndoRedoCommand. - self replaceSelectionWith: newLineString. - ^ false! ! -!SmalltalkEditor methodsFor: 'new selection' stamp: 'jmv 9/5/2019 11:37:26' prior: 50463388! - notify: aString at: anInteger in: aStream - "The compilation of text failed. The syntax error is noted as the argument, - aString. Insert it in the text at starting character position anInteger." - "This is a user command, and generates undo" - model startNewUndoRedoCommand. - self insertAndSelect: aString at: (anInteger max: 1).! ! - -TextEditor removeSelector: #insertAndSelect:at:shouldMergeCommandsIfPossible:! - -TextEditor removeSelector: #insertAndSelect:at:shouldMergeCommandsIfPossible:! - -TextEditor removeSelector: #replaceSelectionWith:shouldMergeCommandsIfPossible:! - -TextEditor removeSelector: #replaceSelectionWith:shouldMergeCommandsIfPossible:! - -TextModel removeSelector: #logUndoAndReplaceFrom:to:with:shouldMergeCommandsIfPossible:! - -TextModel removeSelector: #logUndoAndReplaceFrom:to:with:shouldMergeCommandsIfPossible:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3859-TextUndoCleanup-JuanVuletich-2019Sep05-11h32m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3859] on 5 September 2019 at 12:09:26 pm'! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'jmv 9/5/2019 11:57:33' prior: 50420769! - implementorsOfIt - "Open an implementors browser. - If text selection defines a selector, take it. Otherwise, try finding selector under cursor. If this fails, consider the whole line." - - self selectedSelector ifNotNil: [ :selector | - ^ Smalltalk browseAllImplementorsOf: selector ]. - self - withSelectorUnderCursorDo: [ :selector | Smalltalk browseAllImplementorsOf: selector ] - otherwise: [ self implementorsOfItWhenErrorsParsing ]! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'jmv 9/5/2019 11:58:03' prior: 50420784! - sendersOfIt - "Open a senders browser. - If text selection defines a selector, take it. Otherwise, try finding selector under cursor. If this fails, consider the whole line." - - self selectedSelector ifNotNil: [ :selector | - ^ Smalltalk browseAllCallsOn: selector ]. - self - withSelectorUnderCursorDo: [ :selector | Smalltalk browseAllCallsOn: selector ] - otherwise: [ self sendersOfItWhenErrorsParsing ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3860-SendersOfSelectionWhenPartOfOtherSelector-JuanVuletich-2019Sep05-12h08m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3859] on 5 September 2019 at 12:10:04 pm'! -!TextEditor methodsFor: 'new selection' stamp: 'jmv 9/5/2019 12:06:44' prior: 50452760! - messageSendsRanges: aRanges - - selectionStartBlocks := OrderedCollection new. - selectionStopBlocks := OrderedCollection new. - - aRanges do: [ :range | - selectionStartBlocks add: (textComposition characterBlockForIndex: range first). - selectionStopBlocks add: (textComposition characterBlockForIndex: range last + 1) ]. - aRanges notEmpty ifTrue: [ - self selectFrom: aRanges last first to: aRanges last last ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3861-AutoselectFix-JuanVuletich-2019Sep05-12h09m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3861] on 5 September 2019 at 5:43:43 pm'! -!MenuItemMorph methodsFor: 'accessing' stamp: 'jmv 5/1/2018 14:17:12' prior: 50393661! - setIcon: symbolOrFormOrNil - "Argument can be a Form, a Symbol (to be sent to Theme current) or nil." - - icon _ symbolOrFormOrNil isSymbol - ifTrue: [Theme current perform: symbolOrFormOrNil] - ifFalse: [ symbolOrFormOrNil ]! ! -!MenuItemMorph methodsFor: 'drawing' stamp: 'jmv 9/5/2019 17:31:30' prior: 50392657! - drawOn: aCanvas - | stringColor leftEdge | - - stringColor _ color. - isSelected & isEnabled - ifTrue: [ - aCanvas fillRectangle: (`0@0` extent: extent) color: Theme current menuHighlight]. - leftEdge _ 0. - - self hasMarker ifTrue: [ - leftEdge _ leftEdge + submorphs first morphWidth + 8 ]. - - icon ifNotNil: [ - | iconForm w h factor magnifiedExtent magnifiedIcon | - iconForm _ isEnabled ifTrue: [ icon ] ifFalse: [ icon asGrayScaleAndTransparent ]. - magnifiedIcon _ iconForm. - w _ iconForm width. - h _ iconForm height. - w*h = 0 ifFalse: [ - factor _ extent y * 0.8 / h. - factor = 1.0 ifFalse: [ - magnifiedExtent _ (iconForm extent * factor) rounded. - magnifiedIcon _ iconForm magnifyTo: magnifiedExtent ]]. - aCanvas image: magnifiedIcon at: leftEdge+1 @ (magnifiedIcon height *1//10). - leftEdge _ magnifiedIcon width *12//10 + leftEdge]. - - aCanvas - drawString: contents - at: leftEdge @ 1 - font: self fontToUse - color: stringColor. - subMenu ifNotNil: [ - aCanvas - image: self class subMenuMarker - at: extent x - 8 @ (extent y - self class subMenuMarker height // 2) ]! ! -!MenuItemMorph methodsFor: 'layout' stamp: 'jmv 9/5/2019 17:28:38' prior: 50392685! - minItemWidth - | fontToUse iconWidth subMenuWidth markerWidth | - fontToUse _ self fontToUse. - subMenuWidth _ self hasSubMenu - ifFalse: [0] - ifTrue: [10]. - iconWidth _ icon - ifNotNil: [icon width * 12//10] - ifNil: [0]. - markerWidth _ self hasMarker - ifTrue: [ submorphs first morphWidth + 8 ] - ifFalse: [ 0 ]. - ^ (fontToUse widthOfString: contents) - + subMenuWidth + iconWidth + markerWidth.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3862-ScaleMenuIIcons-JuanVuletich-2019Sep05-17h43m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3861] on 5 September 2019 at 5:46:32 pm'! -!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'jmv 9/5/2019 17:41:17' prior: 50453361! - defaultAction - - | delta textFrame barFrame outerFrame result range width filledWidth f h textWidth textForm innerBarFrame oldFilledWidth oldFilledWidth2 prevContents | - f _ AbstractFont default. - h _ f lineSpacing * 3//2. - textWidth _ (f widthOfString: progressTitle) + h. - width _ 150 max: textWidth. - - textForm _ Form extent: width@h depth: 32. - textForm fillBlack. - textForm fillWhite: (textForm boundingBox insetBy: 2). - progressTitle displayOn: textForm at: (width-textWidth+h//2@4). - barFrame _ Rectangle center: aPoint extent: width@h. - textFrame _ `0@0` extent: width@h. - textFrame _ textFrame - aligned: textFrame bottomCenter - with: barFrame topCenter + `0@2`. - outerFrame _ barFrame merge: textFrame. - delta _ outerFrame amountToTranslateWithin: Display boundingBox. - barFrame _ barFrame translatedBy: delta. - textFrame _ textFrame translatedBy: delta. - outerFrame _ outerFrame translatedBy: delta. - prevContents _ Form fromDisplay: outerFrame. - range _ maxVal = minVal ifTrue: [1] ifFalse: [maxVal - minVal]. "Avoid div by 0" - innerBarFrame _ barFrame insetBy: 2. - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - oldFilledWidth _ 0. - oldFilledWidth2 _ 0. - result _ workBlock value: "Supply the bar-update block for evaluation in the work block" - [ :barVal | - barVal - ifNotNil: [ currentVal _ barVal ] - ifNil: [ - currentVal _ currentVal + 1. - currentVal >= maxVal - ifTrue: [ currentVal _ minVal ]]. - filledWidth _ ((barFrame width-4) asFloat * ((currentVal-minVal) asFloat / range min: 1.0)) asInteger. - filledWidth > oldFilledWidth ifTrue: [ - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - Display fillGray: (barFrame topLeft + `2@2` extent: filledWidth@(h-4)). - filledWidth -200 > oldFilledWidth2 - ifFalse: [ - "Usually just request an update, to be done asynchronously." - DisplayScreen screenUpdateRequired: outerFrame ] - ifTrue: [ - "Once in a while, force a real screen update (warning: really slow on MacOS if done too often)" - Display forceToScreen: outerFrame. oldFilledWidth2 _ filledWidth ]. - oldFilledWidth _ filledWidth ]]. - prevContents displayAt: outerFrame topLeft. - self resume: result! ! -!ProgressMorph methodsFor: 'initialization' stamp: 'jmv 9/5/2019 17:34:15' prior: 50385524! - initialize - super initialize. - self separation: 0. - labelMorph _ StringMorph contents: '' font: AbstractFont default. - subLabelMorph _ StringMorph contents: '' font: AbstractFont default. - progress _ ProgressBarMorph new. - progress morphExtent: 200 @ AbstractFont default lineSpacing. - self addMorphFront: labelMorph. - self addMorphFront: subLabelMorph. - self addMorph: progress fixedHeight: AbstractFont default lineSpacing! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3863-BetterScalingOfProgressBars-JuanVuletich-2019Sep05-17h43m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3863] on 5 September 2019 at 6:18:36 pm'! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 9/5/2019 18:12:41' prior: 50457116! - restoreDefaultFonts - "Since this is called from menus, we can take the opportunity to prompt for missing font styles. - Preferences restoreDefaultFonts - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 9) - (setMenuFontTo: 10) - (setWindowTitleFontTo: 12) - (setCodeFontTo: 9) - (setButtonFontTo: 9) - (setSystemFontTo: 9))! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/5/2019 18:08:38' prior: 50457151! - defaultFont05 - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences defaultFont05 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 5) - (setMenuFontTo: 5) - (setWindowTitleFontTo: 7) - (setCodeFontTo: 5) - (setButtonFontTo: 5) - (setSystemFontTo: 7)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/5/2019 18:09:16' prior: 50457170! - defaultFont06 - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences defaultFont06 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 6) - (setMenuFontTo: 6) - (setWindowTitleFontTo: 8) - (setCodeFontTo: 6) - (setButtonFontTo: 6) - (setSystemFontTo: 7)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/5/2019 18:09:35' prior: 50457189! - defaultFont07 - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences defaultFont07 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 7) - (setMenuFontTo: 7) - (setWindowTitleFontTo: 9) - (setCodeFontTo: 7) - (setButtonFontTo: 7) - (setSystemFontTo: 8)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/5/2019 18:10:10' prior: 50457208! - defaultFont08 - "Sets not only fonts but other GUI elements - to fit low resolution or small screens - Preferences defaultFont08 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 8) - (setMenuFontTo: 8) - (setWindowTitleFontTo: 11) - (setCodeFontTo: 8) - (setButtonFontTo: 8) - (setSystemFontTo: 8)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/5/2019 18:10:36' prior: 50457226! - defaultFont09 - "Sets not only fonts but other GUI elements - to fit low resolution or small screens - Preferences defaultFont09 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 9) - (setMenuFontTo: 10) - (setWindowTitleFontTo: 12) - (setCodeFontTo: 9) - (setButtonFontTo: 9) - (setSystemFontTo: 9)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/5/2019 18:10:45' prior: 50457244! - defaultFont10 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont10 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 10) - (setMenuFontTo: 11) - (setWindowTitleFontTo: 12) - (setCodeFontTo: 10) - (setButtonFontTo: 10) - (setSystemFontTo: 10)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/5/2019 18:10:56' prior: 50457263! - defaultFont11 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont11 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 11) - (setMenuFontTo: 12) - (setWindowTitleFontTo: 14) - (setCodeFontTo: 11) - (setButtonFontTo: 11) - (setSystemFontTo: 11)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/5/2019 18:11:03' prior: 50457282! - defaultFont12 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont12 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 12) - (setMenuFontTo: 12) - (setWindowTitleFontTo: 14) - (setCodeFontTo: 12) - (setButtonFontTo: 12) - (setSystemFontTo: 12)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/5/2019 18:11:11' prior: 50457301! - defaultFont14 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont14 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 14) - (setMenuFontTo: 14) - (setWindowTitleFontTo: 17) - (setCodeFontTo: 14) - (setButtonFontTo: 14) - (setSystemFontTo: 14)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/5/2019 18:11:20' prior: 50457320! - defaultFont17 - "Sets not only fonts but other GUI elements - to fit high resolution or large screens - Preferences defaultFont17 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 17) - (setMenuFontTo: 17) - (setWindowTitleFontTo: 22) - (setCodeFontTo: 17) - (setButtonFontTo: 17) - (setSystemFontTo: 17)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/5/2019 18:11:26' prior: 50457338! -defaultFont22 - "Sets not only fonts but other GUI elements - to fit high resolution or large screens - Preferences defaultFont22 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 22) - (setMenuFontTo: 22) - (setWindowTitleFontTo: 28) - (setCodeFontTo: 22) - (setButtonFontTo: 22) - (setSystemFontTo: 22)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/5/2019 18:11:46' prior: 50457356! -defaultFont28 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont28 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 28) - (setMenuFontTo: 28) - (setWindowTitleFontTo: 36) - (setCodeFontTo: 28) - (setButtonFontTo: 28) - (setSystemFontTo: 28)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/5/2019 18:11:56' prior: 50457375! - defaultFont36 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont36 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 36) - (setMenuFontTo: 36) - (setWindowTitleFontTo: 46) - (setCodeFontTo: 36) - (setButtonFontTo: 36) - (setSystemFontTo: 36)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/5/2019 18:12:11' prior: 50457394! - defaultFont46 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont46 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 46) - (setMenuFontTo: 46) - (setWindowTitleFontTo: 60) - (setCodeFontTo: 46) - (setButtonFontTo: 46) - (setSystemFontTo: 46)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/5/2019 18:12:19' prior: 50457413! - defaultFont60 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont60 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 60) - (setMenuFontTo: 60) - (setWindowTitleFontTo: 80) - (setCodeFontTo: 60) - (setButtonFontTo: 60) - (setSystemFontTo: 60)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/5/2019 18:12:31' prior: 50457432! - defaultFont80 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont80 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 80) - (setMenuFontTo: 80) - (setWindowTitleFontTo: 80) - (setCodeFontTo: 80) - (setButtonFontTo: 80) - (setSystemFontTo: 80)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!UpdatingStringMorph class methodsFor: 'new-morph participation' stamp: 'jmv 9/5/2019 17:51:19' prior: 50457573! - initializedInstance - "Answer a digital clock" - - | newInst | - newInst := self - contents: '' - font: Preferences windowTitleFont - emphasis: AbstractFont boldCode. - newInst - stepTime: 500; "half a second" - target: [String streamContents: [ :strm | DateAndTime now printHMSOn: strm]] ; - getSelector: #value. - - ^ newInst! ! -!TaskbarMorph methodsFor: 'initialization' stamp: 'jmv 9/5/2019 17:59:48' prior: 50337225! - initialize - super initialize. - viewBox _ LayoutMorph newRow color: self defaultColor. - self - addMorph: UpdatingStringMorph initializedInstance - layoutSpec: (LayoutSpec morphWidthProportionalHeight: 0.5). - self - addMorph: viewBox - layoutSpec: (LayoutSpec - proportionalWidth: 1.0 - proportionalHeight: 1.0 - minorDirectionPadding: #right). - viewBox separation: self defaultHeight // 8 -! ! -!FontChanger class methodsFor: 'changing font' stamp: 'jmv 9/5/2019 18:08:23' prior: 50457671! - changeTo: aFontName - "Change the font on the whole system without changing point sizes." - FontFamily defaultFamilyName: aFontName. - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: { - {#setListFontTo:. Preferences standardListFont pointSize.}. - {#setMenuFontTo:. Preferences standardMenuFont pointSize.}. - {#setWindowTitleFontTo:. Preferences windowTitleFont pointSize.}. - {#setCodeFontTo:. Preferences standardCodeFont pointSize.}. - {#setButtonFontTo:. Preferences standardButtonFont pointSize.}. - {#setSystemFontTo:. FontFamily defaultPointSize}. - }. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]. - -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3864-BetterScalingOfTaskbar-JuanVuletich-2019Sep05-18h17m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3864] on 5 September 2019 at 7:58:35 pm'! -!MessageNode methodsFor: 'private' stamp: 'jmv 6/13/2019 08:52:31' prior: 50471665! - pvtCheckForPvtSelector: encoder - "If the code being compiled is trying to send a private message (e.g. 'pvtCheckForPvtSelector:') to anyone other than self, then complain to encoder." - - selector isInitializePvtSelector ifTrue: [ - (receiver isSelfNewMessageSend or: [receiver isSelfBasicNewMessageSend]) ifFalse: [ - encoder notify: 'Private instance initialization messages may only be sent to ''self new'' or "self basicNew" (by class instance creation methods)']]. - selector isPvtSelector ifTrue: [ - (receiver isSelfPseudoVariable or: [ receiver isSuperPseudoVariable ]) ifFalse: [ - encoder notify: 'Private messages may only be sent to self or super']].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3865-RemoveSpuriousHalt-JuanVuletich-2019Sep05-19h58m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3865] on 6 September 2019 at 10:37:54 am'! -!Utilities class methodsFor: 'default desktop' stamp: 'jmv 9/6/2019 09:31:05'! - defaultTextEditorContents - ^ (' -', -('Cuis Smalltalk - -' centered blue pointSize: FontFamily defaultPointSize * 3), -(' -"Yay, Juan. You GO, guy!! ...a great example of malleable software (and a clever mind) at work." -' rightFlush pointSize: FontFamily defaultPointSize * 0.6), -('Dan Ingalls -' italic rightFlush pointSize: FontFamily defaultPointSize * 0.6), -(' -"I like it... It''s nice and clean and simple and pretty. Nice stuff!!" -' rightFlush pointSize: FontFamily defaultPointSize * 0.6), -('Alan Kay -' italic rightFlush pointSize: FontFamily defaultPointSize * 0.6), -(' -"I think you have a very elegant design aesthetic." -' rightFlush pointSize: FontFamily defaultPointSize * 0.6), -('John Maloney -'italic rightFlush pointSize: FontFamily defaultPointSize * 0.6), -' - -', -'Cuis is a modern, Open Source, multiplatform, Smalltalk-80 system. - - -', -'Cuis is: - -' bold, -' - Small - - Clean - - Appropriable -' blue, -' - -Additionally, Cuis is: - -' bold, -' - Open Source - - Multiplatform -' blue, -' - -Like other Smalltalk systems, Cuis is also: - -' bold, -' - A complete development environment written in itself - - A pure, dynamic Object Oriented language -' blue, -' - -Cuis assumes very little on the underlying platform, and this lets it run out-of-the-box on Windows, MacOS, Linux, ChromeOS and WebBrowsers. Cuis shares the [OpenSmalltalk Virtual Machine] (http://www.opensmalltalk.org) with Squeak, Pharo and Newspeak. - -What sets Cuis apart from the other members of the Squeak family is the focus on Smalltalk-80 and an active attitude towards system complexity: - -Unbound complexity growth, together with development strategies focused only in the short term, are the worst long term enemies of all software systems. As systems grow older, they usually become more complex. New features are added as layers on top of whatever is below, sometimes without really understanding it, and almost always without modifying it. Complexity and size grow without control. Evolution slows down. Understanding the system becomes harder every day. Bugs are harder to fix. Codebases become huge for no clear reason. At some point, the system can''t evolve anymore and becomes "legacy code". - -Complexity puts a limit to the level of understanding of the system a person might reach, and therefore limits the things that can be done with it. Dan Ingalls says all this in ["Design Principles Behind Smalltalk"] (http://www.cs.virginia.edu/~evans/cs655/readings/smalltalk.html). Even if you have already done so, please go and read it again!! - -Cuis Smalltalk is our attempt at this challenge. Furthermore, we believe we are doing something else that no other Smalltalk, commercial or open source, does. We attempt to give the true Smalltalk-80 experience, and keep Smalltalk-80 not as legacy software historic significance, but as a live, evolving system. We feel we are the keepers of the Smalltalk-80 heritage, and enablers of the Dynabook experience. - -As Cuis evolves, we keep on these values. Every update, be it a bug fix or a feature enhancement, is reviewed carefully to avoid adding unneded complexity to the system. Every opportunity to remove unneded complexity is followed. As we go, features are enhanced, and any reported bugs fixed. We also adopt selected enhancements from Squeak and Pharo, and share our work with the wider Smalltalk community. - - -' justified, -'License -' bold, -' -Cuis is distributed subject to the MIT License, as in http://www.opensource.org/licenses/mit-license.php . Any contribution submitted for incorporation into or for distribution with Cuis shall be presumed subject to the same license. - -Portions of Cuis are: -Copyright (c) Xerox Corp. 1981, 1982 -Copyright (c) Apple Computer, Inc. 1985-1996 -Copyright (c) Contributors to Squeak and Cuis projects. 1997-2019')! ! -!FontFamily class methodsFor: 'initialization' stamp: 'jmv 9/6/2019 09:41:59'! - defaultFamilyName: aStringOrNil defaultPointSize: aNumberOrNil - "Nil just means leave it as it is now." - | family | - aStringOrNil ifNotNil: [DefaultFamilyName _ aStringOrNil]. - aNumberOrNil ifNotNil: [DefaultPointSize _ aNumberOrNil]. - self revisar. "Please remove this hack meant to install larger DejaVu StrikeFonts on demand." - DefaultFamilyName = 'DejaVu' ifTrue: [ - family _ AvailableFamilies at: DefaultFamilyName. - (family pointSizes includes: DefaultPointSize) ifFalse: [ StrikeFont install: DefaultFamilyName]]. - UISupervisor ui ifNotNil: [ :world | world recreateDefaultDesktop ].! ! -!PasteUpMorph methodsFor: 'defaul desktop' stamp: 'jmv 9/6/2019 09:35:32'! -recreateDefaultDesktop - | editor | - self whenUIinSafeState: [ - self hideTaskbar. - submorphs - do: [ :ea | - (ea class == SystemWindow) ifTrue: [ ea delete ]. - (ea class == TranscriptWindow) ifTrue: [ ea delete ]]. - TranscriptWindow openTranscript - morphPosition: 5 @ 290; - morphExtent: 990 @ 400. - editor _ TextEditor openTextEditor - morphPosition: 456 @ 10; - morphExtent: 900 @ 680. - editor setLabel: 'About Cuis'. - editor model actualContents: Utilities defaultTextEditorContents. - self showTaskbar. - ].! ! -!PasteUpMorph methodsFor: 'defaul desktop' stamp: 'jmv 9/6/2019 09:35:42'! - tearDownDesktop - self whenUIinSafeState: [ - self hideTaskbar. - submorphs - do: [ :ea | (ea is: #SystemWindow) ifTrue: [ ea delete ]]].! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 9/6/2019 10:37:39' prior: 50470794! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag - "WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " - | activeProc | - activeProc _ Processor activeProcess. - [ | isARealStartup guiRootObject guiRootObjectClass | - save not & quit - ifTrue: [ - (SourceFiles at: 2) ifNotNil: [ :changes | - ChangesInitialFileSize ifNotNil: [ changes truncate: ChangesInitialFileSize ]]] - ifFalse: [ - self - logSnapshot: save - andQuit: quit ]. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | - each isInWorld ifTrue: [ - each delete.]]. - UISupervisor ui tearDownDesktop. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - "Cosas que levanto explicitamente abajo" - guiRootObjectClass _ UISupervisor ui class. - guiRootObject _ UISupervisor ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "guiRootObject _ clearAllStateFlag ifFalse: [ UISupervisor ui ]." - UISupervisor stopUIProcess. - activeProc isTerminated ifFalse: [ activeProc terminate ]. - "Clean Globals" - Smalltalk - at: #Sensor - put: nil. - Smalltalk - at: #Display - put: nil. - Smalltalk closeSourceFiles. - Smalltalk - at: #SourceFiles - put: nil. - Smalltalk allClassesDo: [ :cls | - cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | - cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ Smalltalk printStuffToCleanOnImageSave ]. - "Do image save & quit as apropriate" - (Cursor cursorAt: #writeCursor) activateCursor. - save - ifTrue: [ - "The snapshot primitive answers false if it was just called to do the snapshot. - But image startup is resumed by returning (again) from the primitive, but this time answering true." - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk - at: #Sensor - put: nil. - Smalltalk - at: #Display - put: DisplayScreen new. - Smalltalk - at: #SourceFiles - put: (Array new: 2). - Smalltalk openSourceFiles. - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | - cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - UISupervisor spawnNewMorphicProcessFor: (guiRootObject ifNil: [ guiRootObject _ guiRootObjectClass newWorld ]). - Display triggerEvent: #screenSizeChanged. - self restoreLostChangesIfNecessary. - clearAllStateFlag ifTrue: [ - UISupervisor whenUIinSafeState: [ - guiRootObject recreateDefaultDesktop ]]. - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - UISupervisor whenUIinSafeState: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]] - forkAt: Processor timingPriority - 1 - named: 'Startup process'.! ! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 9/6/2019 09:22:28' prior: 50457087! - setSystemFontTo: aFont - "Establish the default text font and style" - - aFont ifNil: [^ self]. - FontFamily defaultFamilyName: aFont familyName defaultPointSize: aFont pointSize.! ! -!FontFamily class methodsFor: 'initialization' stamp: 'jmv 9/6/2019 09:42:26' prior: 50471830! - defaultFamilyName: aString - self defaultFamilyName: aString defaultPointSize: nil! ! -!FontFamily class methodsFor: 'initialization' stamp: 'jmv 9/6/2019 09:42:35' prior: 50471845! - defaultPointSize: aNumber - self defaultFamilyName: nil defaultPointSize: aNumber! ! - -Utilities class removeSelector: #pvtDefaultTextEditorContents! - -Utilities class removeSelector: #pvtDefaultTextEditorContents! - -Utilities class removeSelector: #recreateDefaultDesktop! - -Utilities class removeSelector: #recreateDefaultDesktop! - -Utilities class removeSelector: #tearDownDesktop! - -Utilities class removeSelector: #tearDownDesktop! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3866-FixSaveAsNewVersion-JuanVuletich-2019Sep06-10h35m-jmv.1.cs.st----! - -----SNAPSHOT----(6 September 2019 11:33:26) Cuis5.0-3866-32.image priorSource: 4420647! - -----QUIT----(6 September 2019 11:33:47) Cuis5.0-3866-32.image priorSource: 4530733! - -----STARTUP---- (15 November 2019 09:44:41) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-3866-32.image! - - -'From Cuis 5.0 [latest update: #3866] on 7 September 2019 at 8:37:40 pm'! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/7/2019 20:20:19' prior: 50437051! - bigFonts - "Sets not only fonts but other GUI elements - to fit regular resolution and size screens - Preferences bigFonts - " - - self defaultFont17! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/7/2019 20:34:57' prior: 50472507! - defaultFont05 - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences defaultFont05 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 5) - (setMenuFontTo: 6) - (setWindowTitleFontTo: 7) - (setCodeFontTo: 5) - (setButtonFontTo: 5) - (setSystemFontTo: 6)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/7/2019 20:34:46' prior: 50472526! - defaultFont06 - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences defaultFont06 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 6) - (setMenuFontTo: 7) - (setWindowTitleFontTo: 8) - (setCodeFontTo: 6) - (setButtonFontTo: 6) - (setSystemFontTo: 7)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/7/2019 20:34:28' prior: 50472545! - defaultFont07 - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences defaultFont07 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 7) - (setMenuFontTo: 8) - (setWindowTitleFontTo: 9) - (setCodeFontTo: 7) - (setButtonFontTo: 7) - (setSystemFontTo: 8)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/7/2019 20:34:19' prior: 50472564! - defaultFont08 - "Sets not only fonts but other GUI elements - to fit low resolution or small screens - Preferences defaultFont08 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 8) - (setMenuFontTo: 9) - (setWindowTitleFontTo: 10) - (setCodeFontTo: 8) - (setButtonFontTo: 8) - (setSystemFontTo: 8)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/7/2019 20:33:57' prior: 50472582! - defaultFont09 - "Sets not only fonts but other GUI elements - to fit low resolution or small screens - Preferences defaultFont09 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 9) - (setMenuFontTo: 10) - (setWindowTitleFontTo: 11) - (setCodeFontTo: 9) - (setButtonFontTo: 9) - (setSystemFontTo: 9)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/7/2019 20:20:33' prior: 50437185! - hugeFonts - "Sets not only fonts but other GUI elements - to fit regular resolution and size screens - Preferences hugeFonts - " - - self defaultFont28! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/7/2019 20:24:07' prior: 50437193! - smallFonts - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences smallFonts - " - - self defaultFont11! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/7/2019 20:20:10' prior: 50437210! - standardFonts - "Sets not only fonts but other GUI elements - to fit regular resolution and size screens - Preferences standardFonts - " - - self defaultFont14! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/7/2019 20:24:24' prior: 50437219! - tinyFonts - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences tinyFonts - " - - self defaultFont06! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/7/2019 20:20:29' prior: 50437201! - veryBigFonts - "Sets not only fonts but other GUI elements - to fit regular resolution and size screens - Preferences veryBigFonts - " - - self defaultFont22! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/7/2019 20:24:18' prior: 50437228! - verySmallFonts - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences verySmallFonts - " - - self defaultFont08! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3867-FontSizeChoicesTweaks-JuanVuletich-2019Sep07-20h03m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3867] on 8 September 2019 at 7:37:20 pm'! -!FontChanger class methodsFor: 'changing font' stamp: 'jmv 9/8/2019 19:30:55' prior: 50472837! - changeTo: aFontName - "Change the font on the whole system without changing point sizes." - FontFamily defaultFamilyName: aFontName. - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: { - {#setListFontTo:. Preferences standardListFont pointSize.}. - {#setMenuFontTo:. Preferences standardMenuFont pointSize.}. - {#setWindowTitleFontTo:. Preferences windowTitleFont pointSize.}. - {#setCodeFontTo:. Preferences standardCodeFont pointSize.}. - {#setButtonFontTo:. Preferences standardButtonFont pointSize.}. - }. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]. - -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3868-FontChangeFix-JuanVuletich-2019Sep08-19h36m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3846] on 9 September 2019 at 8:58:25 am'! -!Object methodsFor: 'associating' stamp: 'HAW 9/9/2019 08:57:04' prior: 16880944! - -> anObject - "Answer an Association between self and anObject" - - ^Association key: self value: anObject! ! -!Browser methodsFor: 'class list' stamp: 'HAW 9/9/2019 08:56:20' prior: 50407183! - createHierarchyTreeOf: col - - "Create a tree from a flat collection of classes" - - | transformed | - - transformed := col collect: [:ea | - | childs indexes | - childs := col select: [:class | class superclass = ea]. - indexes := childs collect: [:child | col indexOf: child]. - Association key: ea value: indexes]. - transformed copy do: [:ea | - ea value: (ea value collect: [:idx | - | val | - val := transformed at: idx. - transformed at: idx put: nil. - val])]. - ^ transformed select: [:ea | ea notNil]. -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3869-BrowserFixWhenAssociationMessageRedefined-HernanWilkinson-2019Sep09-08h55m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3869] on 12 September 2019 at 12:53:24 pm'! -!TextEditor class methodsFor: 'keyboard shortcut tables' stamp: 'jmv 9/12/2019 11:05:51' prior: 50449958! - basicCmdShortcutsSpec - " - Editor initialize - " - - "arranged in QWERTY keyboard order" - ^#( - #( $( #enclose: 'Enclose within ( and ), or remove enclosing ( and )') - #( $[ #enclose: 'Enclose within [ and ], or remove enclosing [ and ]') - #( ${ #enclose: 'Enclose within { and }, or remove enclosing { and }') - #( $' #enclose: 'Enclose within single quotes, or remove enclosing single quotes') - #( $" #enclose: 'Enclose within double quotes, or remove enclosing double quotes') - #( $` #enclose: 'Enclose within backticks, or remove enclosing backticks') - #( $< #enclose: 'Enclose within < and >, or remove enclosing < and >') - - #( $a #selectAll: 'Select all') - #( $f #find: 'Find') - #( $g #findAgain: 'Find again') - #( $h #help: 'Open this help') - #( $j #setSearchString: 'Set selection as search string for find again') - - #( $z #undo: 'Undo (multiple levels)') - #( $x #cut: 'Cut selection and store it in the Clipboard') - #( $c #copySelection: 'Copy selection to the Clipboard') - #( $v #paste: 'Paste Clipboard contents') - - #( $Y #makeUppercase: 'Force selection to uppercase') - #( $U #changeLineEndsToLf: 'Convert line endings to LF characters (Cuis convention) in selection') - - #( $H #cursorTopHome: 'Move cursor to start of text') - - #( $Z #redo: 'Redo (multiple levels)') - #( $X #makeLowercase: 'Force selection to lowercase') - #( $C #compareToClipboard: 'Compare argument to clipboard') - )! ! -!SmalltalkEditor class methodsFor: 'keyboard shortcut tables' stamp: 'jmv 9/12/2019 11:10:04' prior: 50449039! - cmdShortcutsSpec - " - Editor initialize - " - "arranged in QWERTY keyboard order" - ^#( - #( $r #acceptAndDebugTest: 'Saves method and debugs it') - #( $t #acceptAndTest: 'Saves method, runs it as test and then all tests in class. Opens debugger if error') - #( $y #acceptAndTestAll: 'Saves method, runs it as test and then all tests in class category. Opens debugger if error') - #( $i #inspectIt: 'Inspect it (selection is a valid expression, or selection is over an inspect-ilst)') - #( $p #printIt: 'Print it (selection is a valid expression)') - - #( $s #save: 'Save (i.e. accept)') - #( $d #doIt: 'Do it (selection is a valid expression)') - - #( $b #browseIt: 'Browse it (selection is a class name or cursor is over a class-list or message-list)') - #( $n #sendersOfIt: 'Senders of it (selection is a message selector or cursor is over a class-list or message-list)') - #( $m #implementorsOfIt: 'Implementors of it (selection is a message selector or cursor is over a class-list or message-list)') - - #( $E #methodStringsContainingit:'Method strings containing it') - #( $I #exploreIt: 'Inspect via Object Explorer') - - #( $Q #argPrev: 'Previous argument') - #( $W #argNext: 'Next argument') - #( $D #debugIt: 'Debug it') - - #( $N #referencesToIt: 'References to it (selection is a class name, or cursor is over a class-list or message-list)') - )! ! -!RefactoringMenues class methodsFor: 'editor menus' stamp: 'jmv 9/12/2019 11:19:24' prior: 50469348! - smalltalkEditorMenuOptions - - ^`{ - { - #itemGroup -> 35. - #itemOrder -> 10. - #label -> 'Rename... (R)'. - #selector -> #contextualRename. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 20. - #label -> 'Add Parameter... (A)'. - #selector -> #contextualAddParameter. - #icon -> #listAddIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 30. - #label -> 'Remove Parameter... (S)'. - #selector -> #contextualRemoveParameter. - #icon -> #listRemoveIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 40. - #label -> 'Temporary to Instance Variable (O)'. - #selector -> #temporaryToInstanceVariable. - #icon -> #saveAsIcon - } asDictionary. - - }`! ! -!RefactoringMenues class methodsFor: 'shortcuts' stamp: 'jmv 9/12/2019 11:15:55' prior: 50469378! - smalltalkEditorCmdShortcutsSpec - - ^#( - #( $R #contextualRename: 'Renames what is under cursor') - #( $A #contextualAddParameter: 'Adds parameter to message that is under cursor') - #( $S #contextualRemoveParameter: 'Removes parameter to message that is under cursor') - #( $O #temporaryToInstanceVariable: 'Extracts temporary variable to instance variable')) -! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Editor initialize! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3870-EditorShortcutsTweaks-HernanWilkinson-JuanVuletich-2019Sep12-12h52m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3870] on 12 September 2019 at 1:04:57 pm'! -!Editor methodsFor: 'typing/selecting keys' stamp: 'jmv 9/12/2019 13:03:45' prior: 16836711! - returnKey: aKeyboardEvent - "Return / Enter / key was pressed" - "Process the various Return / Enter keystrokes" - - morph acceptOnCR ifTrue: [ - ^ true]. - aKeyboardEvent commandAltKeyPressed print ifTrue: [ - (aKeyboardEvent controlKeyPressed | aKeyboardEvent rawMacOptionKeyPressed) print ifTrue: [ - self addString: String crString. - ^false ]. - self addString: String crlfString. - ^false ]. - ^ self newLine: aKeyboardEvent! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3871-crLf-cr-keystrokes-JuanVuletich-2019Sep12-12h56m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3871] on 16 September 2019 at 11:53:10 am'! -!TestResult methodsFor: 'running' stamp: 'FJG 9/16/2019 11:52:06' prior: 50422908! - runCase: aTestCase - - | testCasePassed | - - testCasePassed _ - [ - [ - self reportAboutToRun: aTestCase. - aTestCase runCase. - self reportPassed: aTestCase. - true] - on: self class failure - do: [ :signal | - self reportFailed: aTestCase because: signal. - (self failures isEmpty or: [ failures last ~~ aTestCase ]) - ifTrue: [ failures add: aTestCase ]. - signal sunitExitWith: false ]] - on: self class error - do: [ :signal | - self reportError: aTestCase because: signal. - aTestCase errored: signal. - self errors add: aTestCase. - signal sunitExitWith: false ]. - - testCasePassed - ifTrue: [ self passed add: aTestCase ]! ! -!TestResult methodsFor: 'logging' stamp: 'FJG 9/16/2019 11:52:20'! - reportAboutToRun: aTestCase - - Transcript show: 'Will run: '; print: aTestCase; newLine! ! -!TestResult methodsFor: 'logging' stamp: 'FJG 9/16/2019 11:52:23'! - reportError: aTestCase because: anException - - Transcript print: anException; newLine.! ! -!TestResult methodsFor: 'logging' stamp: 'FJG 9/16/2019 11:52:27'! - reportFailed: aTestCase because: anException - - Transcript print: anException; newLine. - ! ! -!TestResult methodsFor: 'logging' stamp: 'FJG 9/16/2019 11:52:30'! - reportPassed: aTestCase - - Transcript show: 'finished.'; newLine! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3872-TestResultRefactor-FacundoJavierGelatti-2019Sep16-11h52m-FJG.1.cs.st----! - -'From Cuis 5.0 [latest update: #3871] on 16 September 2019 at 11:54:40 am'! -!StdIOWriteStream methodsFor: 'character writing' stamp: 'FJG 9/15/2019 02:53:23'! - printUtf8CodePoint: utf8CodePoint - "Example: printing a checkmark on the console - 'StdIOWriteStream stdout printUtf8CodePoint: 16r2713; flush.' - " - - | characterBytes | - - characterBytes _ Character utf8BytesOfUnicodeCodePoint: utf8CodePoint. - - self primWrite: fileID from: characterBytes startingAt: 1 count: characterBytes size -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3873-StdIO_Utf8-FacundoJavierGelatti-2019Sep16-11h53m-FJG.1.cs.st----! - -'From Cuis 5.0 [latest update: #3873] on 16 September 2019 at 12:35:33 pm'! -!StdIOWriteStream methodsFor: 'open / close' stamp: 'jmv 9/16/2019 11:23:26' prior: 50332310! - openOnHandle: aFileID name: streamName - "Initialize the instance with the given file handle. - N.B. Do _not_ register the stream. We do not want it to be - closed implicitly (e.g. on GC). There may be multiple instances - accessing the same stream. The stream is not a file." - - fileID _ aFileID. - name _ streamName. - buffer1 _ ByteArray new: 1! ! -!StdIOWriteStream methodsFor: 'streaming' stamp: 'jmv 9/16/2019 12:34:21' prior: 50332329! - nextPut: charOrByte - "Write the given character or byte to this file. - We can handle String (possibly including NCRs) and ByteArray (with utf-8 contents) - - StdIOWriteStream stdout nextPutAll: ('--- r2713; ===' asUtf8: true); flush. - StdIOWriteStream stdout nextPutAll: ('--- ✓ ===' asUtf8: true); flush. - StdIOWriteStream stdout nextPutAll: #[226 156 147]; flush. - StdIOWriteStream stdout nextPutAll: '¿El Ñandú toma agüita?', String newLineString; flush. - StdIOWriteStream stdout nextPutAll: ('¿El Ñandú toma agüita?', String newLineString) asUtf8 ; flush. - See at the end of this method for a larger example with NCRs for arbitrary Unicode - " - charOrByte isNumber ifTrue: [ - buffer1 at: 1 put: charOrByte. - self primWrite: fileID from: buffer1 startingAt: 1 count: 1. - ^ charOrByte ]. - Character - evaluate: [ :byte | self nextPut: byte ] - withUtf8BytesOfUnicodeCodePoint: charOrByte codePoint. - ^ charOrByte -" -StdIOWriteStream stdout nextPutAll: (' -Αα Alpha -Ββ Beta -Γγ Gamma -†δ Delta -Ε„ Epsilon -Ζ… Zeta -Ηη Eta -Θθ Theta -Ιι Iota -Κκ Kappa -Λλ Lambda -Μμ Mu -Νν Nu -Ξξ Xi -Οο Omicron -Πƒ Pi -Ρρ Rho -Σσς Sigma -Ττ Tau -Υυ Upsilon -Φφ Phi -Χχ Chi -Ψψ Psi -‡ω Omega -&# 937;&# 969; Not a NCR, just regular ASCII chars!! -' asUtf8: true); flush -"! ! - -StdIOWriteStream removeSelector: #printUtf8CodePoint:! - -StdIOWriteStream removeSelector: #printUtf8CodePoint:! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -StdIOWriteStream releaseClassCachedState! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3874-StdOut-utf8-JuanVuletich-2019Sep16-12h28m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3852] on 28 August 2019 at 11:20:43 pm'! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'pb 8/28/2019 23:19:53' prior: 50422638! - forceChangesToDisk - "Just flush the buffer and trust the OS to do its job." - | changesFile | - "Expensive and not worth doing, esp. in Windows with antivirus active, when installing large packages" - ChangeSet notInstallOrTestRun ifTrue: [ - changesFile _ SourceFiles at: 2. - changesFile isFileStream ifTrue: [ changesFile flush ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3875-forceChangesToDisk-enough-already-its-2019-PhilBellalouna-2019Aug28-23h07m-pb.1.cs.st----! - -'From Cuis 5.0 [latest update: #3875] on 16 September 2019 at 1:30:10 pm'! - -SimpleServiceEntry removeSelector: #icon! - -SimpleServiceEntry removeSelector: #icon! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3876-remove-icon-method-JuanVuletich-2019Sep16-13h18m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3876] on 16 September 2019 at 1:48:19 pm'! - -Stream subclass: #StdIOWriteStream - instanceVariableNames: 'fileID name buffer1 ' - classVariableNames: 'StdErr StdOut ' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #StdIOWriteStream category: #'System-Support'! -Stream subclass: #StdIOWriteStream - instanceVariableNames: 'fileID name buffer1' - classVariableNames: 'StdErr StdOut' - poolDictionaries: '' - category: 'System-Support'! -!StdIOWriteStream methodsFor: 'streaming' stamp: 'jmv 9/16/2019 13:46:59'! - nextPutAll: aStringOrUTF8Bytes - "Write the given String (possibly including NCRs) or ByteArray (with utf-8 contents) - StdIOWriteStream stdout nextPutAll: '--- r2713; ==='; flush. - StdIOWriteStream stdout nextPutAll: '--- ✓ ==='; flush. - StdIOWriteStream stdout nextPutAll: #[226 156 147]; flush. - StdIOWriteStream stdout nextPutAll: '¿El Ñandú toma agüita?', String newLineString; flush. - StdIOWriteStream stdout nextPutAll: ('¿El Ñandú toma agüita?', String newLineString) asUtf8 ; flush. - See at the end of this method for a larger example with NCRs for arbitrary Unicode - " - | utf8Bytes | - utf8Bytes _ aStringOrUTF8Bytes isString - ifTrue: [ aStringOrUTF8Bytes asUtf8: true ] - ifFalse: [ aStringOrUTF8Bytes ]. - self primWrite: fileID from: utf8Bytes startingAt: 1 count: utf8Bytes size. - ^aStringOrUTF8Bytes -" -StdIOWriteStream stdout nextPutAll: ' -Αα Alpha -Ββ Beta -Γγ Gamma -†δ Delta -Ε„ Epsilon -Ζ… Zeta -Ηη Eta -Θθ Theta -Ιι Iota -Κκ Kappa -Λλ Lambda -Μμ Mu -Νν Nu -Ξξ Xi -Οο Omicron -Πƒ Pi -Ρρ Rho -Σσς Sigma -Ττ Tau -Υυ Upsilon -Φφ Phi -Χχ Chi -Ψψ Psi -‡ω Omega -&# 937;&# 969; Not a NCR, just regular ASCII chars!! -'; flush -"! ! -!StdIOWriteStream methodsFor: 'open / close' stamp: 'jmv 9/16/2019 13:47:35' prior: 50473734! - openOnHandle: aFileID name: streamName - "Initialize the instance with the given file handle. - N.B. Do _not_ register the stream. We do not want it to be - closed implicitly (e.g. on GC). There may be multiple instances - accessing the same stream. The stream is not a file." - - fileID _ aFileID. - name _ streamName.! ! -!StdIOWriteStream methodsFor: 'streaming' stamp: 'jmv 9/16/2019 13:46:29' prior: 50473748! - nextPut: aCharacter - "Write the given character or byte to this file. - StdIOWriteStream stdout nextPut: $a; flush. - " - self nextPutAll: aCharacter asString. - ^aCharacter! ! - -Stream subclass: #StdIOWriteStream - instanceVariableNames: 'fileID name' - classVariableNames: 'StdErr StdOut' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #StdIOWriteStream category: #'System-Support'! -Stream subclass: #StdIOWriteStream - instanceVariableNames: 'fileID name' - classVariableNames: 'StdErr StdOut' - poolDictionaries: '' - category: 'System-Support'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3877-StdOut-Unicode-BetterImplementation-JuanVuletich-2019Sep16-13h42m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3877] on 16 September 2019 at 10:53:22 pm'! -!SimpleServiceEntry methodsFor: 'accessing' stamp: 'jmv 9/16/2019 22:52:17'! - iconSpec - - ^icon! ! -!DropFilesAction methodsFor: 'evaluating - private' stamp: 'jmv 9/16/2019 22:52:28' prior: 50426990! - createMenuFor: options - - | icons lines labels | - - "options is a small collection, no problem to collect twice - Hernan" - labels := options collect: [ :option | option label ]. - icons := options collect: [ :option | option iconSpec ]. - - shouldAskToStop - ifTrue: [ - lines := Array with: labels size. - labels add: 'stop here'. - icons add: #cancelIcon ] - ifFalse: [ lines := #() ]. - - ^PopUpMenu labelArray: labels lines: lines icons: icons! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3878-stFileDnDFix-JuanVuletich-2019Sep16-22h52m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3878] on 19 September 2019 at 5:33:19 pm'! -!TextEditor methodsFor: 'new selection' stamp: 'jmv 9/19/2019 17:31:32' prior: 50472299! - messageSendsRanges: aRanges - "aRanges must be notEmpty" - - selectionStartBlocks := OrderedCollection new. - selectionStopBlocks := OrderedCollection new. - - aRanges do: [ :range | - selectionStartBlocks add: (textComposition characterBlockForIndex: range first). - selectionStopBlocks add: (textComposition characterBlockForIndex: range last + 1) ]. - self selectFrom: aRanges last first to: aRanges last last! ! -!TextModelMorph methodsFor: 'updating' stamp: 'jmv 9/19/2019 17:31:48' prior: 50452629! - selectMessage - - | messageSendsRanges | - - messageSendsRanges := model textProvider messageSendsRangesOf: model autoSelectString. - ^ messageSendsRanges notEmpty - ifTrue: [ self editor messageSendsRanges: messageSendsRanges ]; yourself! ! -!TextModelMorph methodsFor: 'updating' stamp: 'jmv 9/19/2019 17:30:20' prior: 50452667! - updateAutoSelect - - TextEditor abandonChangeText. "no replacement!!" - self selectMessage - ifFalse: [ self selectString ]. - - self textMorph updateFromTextComposition. - ^self scrollSelectionIntoView! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3879-AutoselectFix-JuanVuletich-2019Sep19-17h32m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3852] on 29 August 2019 at 2:41:42 pm'! -!Editor class methodsFor: 'class initialization' stamp: 'jmv 8/29/2019 10:42:05' prior: 50432186! - putIntoCmdShortcuts: shortcutsSpec - - shortcutsSpec do: [ :ary | | i previous | - i _ ary first numericValue + 1. - previous _ cmdShortcuts at: i. - previous = #noop: - ifTrue: [ - cmdShortcuts at: i put: ary second ] - ifFalse: [ ('Editor shortcut: ', ary first printString, ' already taken for: ', previous, '. Override request for: ', ary second, ' ignored') print ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3880-LogAndIgnoreShortcutOverride-JuanVuletich-2019Aug29-14h40m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3870] on 12 September 2019 at 1:04:57 pm'! -!Editor methodsFor: 'typing/selecting keys' stamp: 'jmv 9/12/2019 13:03:45' prior: 50473637! - returnKey: aKeyboardEvent - "Return / Enter / key was pressed" - "Process the various Return / Enter keystrokes" - - morph acceptOnCR ifTrue: [ - ^ true]. - aKeyboardEvent commandAltKeyPressed ifTrue: [ - (aKeyboardEvent controlKeyPressed | aKeyboardEvent rawMacOptionKeyPressed) ifTrue: [ - self addString: String crString. - ^false ]. - self addString: String crlfString. - ^false ]. - ^ self newLine: aKeyboardEvent! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3881-crLf-cr-keystrokes-JuanVuletich-2019Sep19-12h56m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3878] on 18 September 2019 at 8:25:36 pm'! -!Cursor class methodsFor: 'accessing' stamp: 'pb 9/18/2019 20:24:42'! - cursorAt: cursorKey ifAbsent: aBlock - ^ (CursorDict - at: cursorKey - ifAbsent: [ - (self respondsTo: cursorKey) ifTrue: [ | newCursor | - newCursor _ self perform: cursorKey. - newCursor hasMask ifFalse: [ newCursor _ newCursor withMask ]. - self - cursorAt: cursorKey - put: newCursor ]]) ifNil: aBlock.! ! -!Cursor class methodsFor: 'accessing' stamp: 'pb 9/18/2019 20:25:12' prior: 50470408! - cursorAt: cursorKey - ^ self - cursorAt: cursorKey - ifAbsent: [ self defaultCursor ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3882-Cursor-missing-use-default-PhilBellalouna-2019Sep18-20h14m-pb.1.cs.st----! - -'From Cuis 5.0 [latest update: #3866] on 17 September 2019 at 9:46:20 pm'! -!TextEditor methodsFor: 'menu' stamp: 'jpb 9/17/2019 21:44:24'! - addCutAndPasteMenuSectionTo: aMenu - "Adds typical cut and paste operations section to a menu" - - self hasUnacceptedEdits ifTrue: [ - aMenu - add: 'Accept (s)' - action: #acceptContents - icon: #acceptIcon - ]. - - aMenu - add: 'Copy (c)' - action: #copySelection - icon: #copyIcon. - - aMenu - add: 'Cut (x)' - action: #cut - icon: #cutIcon. - - aMenu - add: 'Paste (v)' - action: #paste - icon: #pasteIcon. - - aMenu - add: 'Paste without Format' - action: #pasteString - icon: #pasteIcon. - - aMenu - add: 'Paste...' - action: #pasteRecent - icon: #worldIcon. - - ^aMenu! ! -!TextEditor methodsFor: 'menu' stamp: 'jpb 9/17/2019 21:34:30'! - addFinderMenuSectionTo: aMenu - "Build a submenu with finding related operations" - - aMenu addItemsFromDictionaries: - `{ - { - #label -> 'Find...(f)'. - #selector -> #find. - #icon -> #findIcon - } asDictionary. - { - #label -> 'Find Again (g)'. - #selector -> #findAgain. - #icon -> #systemIcon - } asDictionary. - { - #label -> 'Use Selection for Find (j)'. - #selector -> #setSearchString. - #icon -> #saveAsIcon - } asDictionary. - }`. - ^aMenu! ! -!TextEditor methodsFor: 'menu' stamp: 'jpb 9/17/2019 21:41:04'! - addStyleMenuSectionTo: aMenu - "Adds to the given menu text styiling related operations" - - aMenu - addItemsFromDictionaries: - `{ - { - #label -> 'Toggle WordWrap'. - #selector -> #wrapOnOff. - #icon -> #genericTextIcon - } asDictionary. - { - #label -> 'Set Font... (k)'. - #selector -> #offerFontMenu. - #icon -> #preferencesDesktopFontIcon - } asDictionary. - { - #label -> 'Clear Font'. - #selector -> #clearFont. - #icon -> #newIcon - } asDictionary. - { - #label -> 'Set Default Font...'. - #selector -> #offerDefaultFontMenu. - #icon -> #fontXGenericIcon - } asDictionary. - { - #label -> 'Set Alignment...'. - #selector -> #chooseAlignment. - #icon -> #formatJustifyLeftIcon - } asDictionary. - }`. - ^aMenu! ! -!TextEditor methodsFor: 'menu' stamp: 'jpb 9/17/2019 21:36:55'! - addUndoMenuSectionTo: aMenu - "Adds undo operations to the given menu" - - aMenu - addItemsFromDictionaries: - `{ - nil. - { - #label -> 'Undo - multiple (z)'. - #selector -> #undo. - #icon -> #undoIcon - } asDictionary. - { - #label -> 'Redo - multiple (Z)'. - #selector -> #redo. - #icon -> #redoIcon - } asDictionary. - { - #label -> 'Undo / Redo history'. - #selector -> #offerUndoHistory. - #icon -> #changesIcon - } asDictionary. - }`. - - ^aMenu.! ! -!TextEditor methodsFor: 'menu' stamp: 'jpb 9/17/2019 21:44:32' prior: 50448904! - getMenu - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu - addTitle: self class name; - addStayUpIcons. - - aMenu - add: 'Help...' - action: #openHelp - icon: #helpIcon. - aMenu addLine. - - self addFinderMenuSectionTo: aMenu. - self addUndoMenuSectionTo: aMenu. - aMenu addLine. - - self addCutAndPasteMenuSectionTo: aMenu. - aMenu addLine. - - self addStyleMenuSectionTo: aMenu. - - ^aMenu ! ! - -TextEditor removeSelector: #addOperationsMenuTo:! - -TextEditor removeSelector: #addTextstyleMenuTo:! - -TextEditor removeSelector: #addUndoMenuTo:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3883-EditorMenuEnh-JosefPhilipBernhart-2019Sep17-20h06m-jpb.1.cs.st----! - -'From Cuis 5.0 [latest update: #3883] on 25 September 2019 at 5:03:34 pm'! -!DiskProxy commentStamp: '' prior: 16834863! - A DiskProxy is an externalized form of an object to write on a -DataStream. It contains a "constructor" message to regenerate -the object, in context, when sent a comeFullyUpOnReload: message -(i.e. "internalize"). - -We are now using DiskProxy for shared system objects like StrikeFonts. - -The idea is to define, for each kind of object that needs special -externalization, a class method that will internalize the object by -reconstructing it from its defining state. We call this a -"constructor" method. Then externalize such an object as a frozen -message that invokes this method--a DiskProxy. - -(Here is the old comment: -Constructing a new object is good for any object that (1) can not be -externalized simply by snapshotting and reloading its instance -variables (like a CompiledMethod or a Picture), or (2) wants to be -free to evolve its internal representation without making stored -instances obsolete (and dangerous). Snapshotting and reloading an -object"s instance variables is a dangerous breach of encapsulation. - -The internal structure of the class is then free to evolve. All -externalized instances will be useful as long as the -constructor methods are maintained with the same semantics. - -There may be several constructor methods for a particular class. This -is useful for (1) instances with characteristically different -defining state, and (2) newer, evolved forms of an object and its -constructors, with the old constructor methods kept around so old -data can still be properly loaded.) - -Create one like this example from class Picture - - DiskProxy global: #Picture - selector: #fromByteArray: - args: (Array with: self storage asByteArray) - -* See also subclass DiskProxyQ that will construct an object in -the above manner and then send it a sequence of messages. This may save -creating a wide variety of constructor methods. It is also useful because -the newly read-in DiskProxyQ can catch messages like #objectContainedIn: -(via #doesNotUnderstand:) and add them to the queue of messages to -send to the new object. - -* We may also want a subclass of DiskProxy that evaluates a string -expression to compute the receiver of the constructor message. - -My instance variables: -* globalObjectName -- the Symbol name of a global object in the - System dictionary (usually a class). -* constructorSelector -- the constructor message selector Symbol to - send to the global object (perform:withArguments:), typically a - variation on newFrom:. -* constructorArgs -- the Array of arguments to pass in the - constructor message. - --- 11/9/92 Jerry Morrison -! -!VariableNode methodsFor: 'testing' stamp: 'jmv 9/24/2019 12:51:03' prior: 50464264! - isSuperPseudoVariable - "Answer if this ParseNode represents the 'super' pseudo-variable." - - ^ key = 'super' or: [name = '{{super}}']! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3884-CommentTweaks-JuanVuletich-2019Sep25-17h01m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3883] on 25 September 2019 at 5:05:25 pm'! -!BlockClosure methodsFor: 'accessing' stamp: 'jmv 9/25/2019 10:55:23'! - outerContextsDo: aBlock - - outerContext outerContextsDo: aBlock! ! -!MethodContext methodsFor: 'accessing' stamp: 'jmv 9/25/2019 10:54:45'! - outerContextsDo: aBlock - "Answer the context in which the receiver was defined." - - closureOrNil - ifNotNil: [ closureOrNil outerContextsDo: aBlock ]. - aBlock value: self! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3885-outerContextsDo-JuanVuletich-2019Sep25-17h03m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3885] on 26 September 2019 at 10:00:23 am'! -!BlockClosure methodsFor: 'accessing' stamp: 'jmv 9/25/2019 09:16:04'! - capturedValues - | n copiedValues | - n _ self numCopiedValues. - copiedValues _ Array new: n. - 1 to: n do: [ :i | - copiedValues at: i put: (self copiedValueAt: i) ]. - ^copiedValues! ! -!BlockClosure methodsFor: 'accessing' stamp: 'jmv 9/26/2019 09:19:46'! - endpc - "Determine end of block from the instruction preceding it. - Find the instruction by using an MNU handler to capture - the instruction message sent by the scanner." - | myMethod scanner preceedingBytecodeMessage end | - myMethod := self method. - scanner := InstructionStream new method: myMethod pc: myMethod initialPC. - [scanner pc < startpc] whileTrue: - [[scanner interpretNextInstructionFor: nil] - on: MessageNotUnderstood - do: [:ex| preceedingBytecodeMessage := ex message]]. - end := preceedingBytecodeMessage arguments last + startpc - 1. - ^end! ! -!BlockClosure methodsFor: 'testing' stamp: 'jmv 9/26/2019 09:41:53'! - sendsToSuper - "Answer whether the receiver sends any message to super." - | myMethod scanner end | - myMethod := self method. - scanner := InstructionStream new method: myMethod pc: startpc. - end := self endpc. - scanner scanFor: [ :byte | - (byte = 16r85 or: [ - byte = 16r84 and: [scanner followingByte between: 16r20 and: 16r3F]]) - or: [scanner pc > end]]. - ^scanner pc <= end! ! -!BlockClosure methodsFor: 'testing' stamp: 'jmv 9/26/2019 09:41:42' prior: 50465825! - hasNonLocalReturn - "Answer whether the receiver has a method-return ('^') in its code." - | myMethod scanner end | - myMethod := self method. - scanner := InstructionStream new method: myMethod pc: startpc. - end := self endpc. - scanner scanFor: [:byte | (byte between: 120 and: 124) or: [scanner pc > end]]. - ^scanner pc <= end! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3886-BlockClosure-hasNonLocalReturn-JuanVuletich-2019Sep26-09h59m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3885] on 26 September 2019 at 9:56:21 am'! -!Decompiler methodsFor: 'public access' stamp: 'jmv 9/25/2019 17:51:15' prior: 16832266! - decompileBlock: aBlock - "Decompile aBlock, returning the result as a BlockNode. - Show temp names from source if available." - "Decompiler new decompileBlock: [3 + 4]" - | methodNode home | - (home := aBlock home) ifNil: [^ nil]. - method := home method. - (home methodClass) == #unknown ifTrue: [^ nil]. - aBlock isClosure ifTrue: - [(methodNode := method decompile) - ifNil: [^nil] - ifNotNil: [methodNode nodesDo: [:node| node pc = aBlock startpc ifTrue: [^node]]]. - ^self error: 'cannot find block node matching aBlock']. - ^self error: 'can only decompile BlockClosures'! ! -!Compiler methodsFor: 'public access' stamp: 'jmv 9/26/2019 09:55:33' prior: 50445078! - evaluate: textOrStream in: aContext to: aReceiver notifying: aRequestor ifFail: failBlock logged: doLog profiled: doProfile - "Compiles the sourceStream into a parse tree, then generates code into - a method. If aContext is not nil, the text can refer to temporaries in that - context (the Debugger uses this). If aRequestor is not nil, then it will receive - a notify:at: message before the attempt to evaluate is aborted. Finally, the - compiled method is invoked from here via withArgs:executeMethod:, hence - the system no longer creates Doit method litter on errors." - - | methodNode method | - - class _ (aReceiver ifNotNil: [ aReceiver ] ifNil: [ aContext ifNotNil: [ :c | c receiver ]]) class. - methodNode _ self compileNoPattern: textOrStream in: class context: aContext notifying: aRequestor ifFail: [^failBlock value]. - method _ methodNode generate. - "I'm not keeping the source nor the methodNode for back compabibility. - The SmalltalkEditor sends the message #evaluateMethod:... which already keep the method node - for the debugger to show the right source code - Hernan" - ^self evaluateMethod: method to: aReceiver logged: doLog profiled: doProfile! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3887-Compiler-Decompiler-tweaks-JuanVuletich-2019Sep26-09h54m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3887] on 26 September 2019 at 7:38:16 pm'! - -Decompiler subclass: #SerializableClosureDecompiler - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #SerializableClosureDecompiler category: #'System-Support'! -Decompiler subclass: #SerializableClosureDecompiler - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! - -AssignmentNode subclass: #SerializableClosureAssignmentNode - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #SerializableClosureAssignmentNode category: #'System-Support'! -AssignmentNode subclass: #SerializableClosureAssignmentNode - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! - -InstanceVariableNode subclass: #SerializableClosureInstanceVariableNode - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #SerializableClosureInstanceVariableNode category: #'System-Support'! -InstanceVariableNode subclass: #SerializableClosureInstanceVariableNode - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! - -TempVariableNode subclass: #SerializableClosureTempVariableNode - instanceVariableNames: 'capturedIndex' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #SerializableClosureTempVariableNode category: #'System-Support'! -TempVariableNode subclass: #SerializableClosureTempVariableNode - instanceVariableNames: 'capturedIndex' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! - -DecompilerConstructor subclass: #SerializableClosureDecompilerConstructor - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #SerializableClosureDecompilerConstructor category: #'System-Support'! -DecompilerConstructor subclass: #SerializableClosureDecompilerConstructor - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! - -Object subclass: #SerializableBlockClosure - instanceVariableNames: 'theSelf sourceCode capturedValues' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #SerializableBlockClosure category: #'System-Support'! -Object subclass: #SerializableBlockClosure - instanceVariableNames: 'theSelf sourceCode capturedValues' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! -!SerializableBlockClosure commentStamp: 'jmv 9/25/2019 17:21:45' prior: 0! - A SerializableBlockClosure is a regular Smalltalk object (and hence serializable by ReferenceStream and SmartRefStream), that hold the source code for a BlockClosure, together with the state (originally in outer temps) that the BlockClosure might access. - -When sent #asEvaluable (even after materializing in the same or different Smalltalk image / machine), the result is a BlockClosure that can be evaluated with identical result as the original. - -By making BlockClosure>>objectForDataStream: call #asSerializable, we enable serialization and #veryDeepCopy of BlockClosures as if they were regular Smalltalk objects. - -(The only limitation is that we can't meaningfully handle non-local returns. This limitation also applies to regular BlockClosures if evaluation is attempted when there's nowhere to return to.)! -!BlockClosure methodsFor: 'objects from disk' stamp: 'jmv 9/20/2019 21:17:34'! - asSerializable - ^SerializableBlockClosure onBlockClosure: self! ! -!SerializableClosureDecompiler methodsFor: 'instruction decoding' stamp: 'jmv 9/25/2019 18:23:40'! - pushReceiver - - stack addLast: (InstanceVariableNode new - name: 'theSelf' - index: 1)! ! -!SerializableClosureDecompiler methodsFor: 'public access' stamp: 'jmv 9/25/2019 18:00:20'! - decompileBlockAndMethod: aBlock - "Decompile aBlock, returning the result as a BlockNode, and the corresponding MethodNode." - "Decompiler new decompileBlockAndMethod: [3 + 4]" - - | homeMethod methodNode home methodClass methodSelector | - (home := aBlock home) ifNil: [^ nil]. - homeMethod := home method. - (home methodClass) == #unknown ifTrue: [^ nil]. - aBlock isClosure ifTrue: [ - methodClass := homeMethod methodClass ifNil: [Object]. - methodSelector := homeMethod selector ifNil: [homeMethod defaultSelector]. - methodNode := self decompile: methodSelector in: methodClass method: homeMethod. - methodNode - ifNil: [^nil] - ifNotNil: [methodNode nodesDo: [:node| node pc = aBlock startpc ifTrue: [^{node. methodNode}]]]. - ^self error: 'cannot find block node matching aBlock']. - ^self error: 'can only decompile BlockClosures'! ! -!SerializableClosureDecompiler methodsFor: 'private' stamp: 'jmv 9/26/2019 18:48:55'! - constructorForMethod: aMethod - - ^SerializableClosureDecompilerConstructor new! ! -!SerializableClosureAssignmentNode methodsFor: 'printing' stamp: 'jmv 9/26/2019 18:47:12'! - printOn: aStream indent: level - - "For temps and args local to a block" - (variable isTemp and: [variable isCapturedByClosure not]) ifTrue: [ ^super printOn: aStream indent: level ]. - - "For outer temps, but also for ivars" - aStream nextPutAll: '('. - variable printIndirectOn: aStream indent: level. - aStream nextPutAll: ' put: '. - value printOn: aStream indent: level. - aStream nextPutAll: ')'.! ! -!SerializableClosureInstanceVariableNode methodsFor: 'printing' stamp: 'jmv 9/26/2019 18:44:09'! - printIndirectOn: aStream indent: level - - aStream nextPutAll: 'theSelf instVarNamed: ''', name, ''''! ! -!SerializableClosureInstanceVariableNode methodsFor: 'printing' stamp: 'jmv 9/26/2019 18:44:22'! - printOn: aStream indent: level - - aStream nextPut: $(. - self printIndirectOn: aStream indent: level. - aStream nextPut: $).! ! -!SerializableClosureTempVariableNode methodsFor: 'printing' stamp: 'jmv 9/26/2019 18:44:13'! - printIndirectOn: aStream indent: level - - self isRemote - ifTrue: [ aStream nextPutAll: 'capturedValues last at: ', capturedIndex printString ] - ifFalse: [ aStream nextPutAll: 'capturedValues at: ', capturedIndex printString ]! ! -!SerializableClosureTempVariableNode methodsFor: 'printing' stamp: 'jmv 9/26/2019 18:47:08'! - printOn: aStream indent: level - - "For temps local to the block" - self isCapturedByClosure ifFalse: [ - ^super printOn: aStream indent: level ]. - - "For outer temps" - aStream nextPut: $(. - self printIndirectOn: aStream indent: level. - aStream nextPut: $).! ! -!SerializableClosureTempVariableNode methodsFor: 'testing' stamp: 'jmv 9/26/2019 16:14:58'! - isCapturedByClosure - - ^capturedIndex notNil! ! -!SerializableClosureTempVariableNode methodsFor: 'accessing' stamp: 'jmv 9/26/2019 16:03:48'! - capturedIndex: idx - - capturedIndex _ idx! ! -!SerializableClosureDecompilerConstructor methodsFor: 'constructor' stamp: 'jmv 9/26/2019 18:49:23'! - codeAssignTo: variable value: expression - - ^ SerializableClosureAssignmentNode new variable: variable value: expression! ! -!SerializableClosureDecompilerConstructor methodsFor: 'constructor' stamp: 'jmv 9/26/2019 18:49:54'! -codeInst: index - - ^ SerializableClosureInstanceVariableNode new - name: (instVars at: index + 1 ifAbsent: ['unknown', index asString]) - index: index + 1! ! -!SerializableClosureDecompilerConstructor methodsFor: 'constructor' stamp: 'jmv 9/26/2019 18:49:40'! - codeTemp: index - - ^ SerializableClosureTempVariableNode new - name: 'temp' , (index + 1) printString - index: index - type: LdTempType - scope: 0! ! -!SerializableClosureDecompilerConstructor methodsFor: 'constructor' stamp: 'jmv 9/26/2019 18:49:40'! - codeTemp: index named: tempName - - ^ SerializableClosureTempVariableNode new - name: tempName - index: index - type: LdTempType - scope: 0! ! -!SerializableBlockClosure methodsFor: 'initialization' stamp: 'jmv 9/26/2019 19:34:11'! - onBlockClosure: aBlockClosure - - | both blockNode methodNode indirectTempNames sortedOuterTemps ownNames usedOuterNames sortedUsedOuterNames | - aBlockClosure hasNonLocalReturn ifTrue: [ - self error: 'Can not serialize closures with non-local returns.' ]. - aBlockClosure sendsToSuper ifTrue: [ - self error: 'Can not currently serialize closures with super sends.' ]. - both _ SerializableClosureDecompiler new decompileBlockAndMethod: aBlockClosure. - blockNode _ both first. - methodNode _ both second. - - indirectTempNames _ methodNode temporaries - detect: [ :node | node isIndirectTempVector ] - ifFound: [ :node | node remoteTemps collect: [ :n | n name ]] - ifNone: [#()]. - sortedOuterTemps _ OrderedCollection new. - aBlockClosure outerContextsDo: [ :c | c closure ifNotNil: [ :cc | - | ccn | - ccn _ cc decompile. - sortedOuterTemps addAll: ccn arguments; addAll: ccn temporaries ]]. - sortedOuterTemps addAll: methodNode temporaries; addAll: methodNode arguments. - - ownNames _ ((blockNode arguments, blockNode temporaries) - collect: [ :node | node name ]) asSet. - usedOuterNames _ Set new. - blockNode nodesDo: [ :node | node isTemp ifTrue: [ - (ownNames includes: node name) | (indirectTempNames includes: node name) ifFalse: [ - usedOuterNames add: node name]]]. - - sortedUsedOuterNames _ sortedOuterTemps select: [ :node | - usedOuterNames includes: node name ]. "sort them" - sortedUsedOuterNames _ sortedUsedOuterNames collect: [ :node | node name ]. - - blockNode nodesDo: [ :node | node isTemp ifTrue: [ - node isRemote - ifTrue: [node capturedIndex: (indirectTempNames indexOf: node name) ] - ifFalse: [ - (sortedUsedOuterNames includes: node name) - ifTrue: [node capturedIndex: (sortedUsedOuterNames indexOf: node name)]]]]. - - theSelf _ aBlockClosure receiver. - capturedValues _ aBlockClosure capturedValues. - sourceCode _ blockNode decompileString.! ! -!SerializableBlockClosure methodsFor: 'evaluating' stamp: 'jmv 9/25/2019 17:14:00'! - asEvaluable - - ^Compiler evaluate: sourceCode for: self logged: false! ! -!SerializableBlockClosure methodsFor: 'objects from disk' stamp: 'jmv 9/25/2019 11:43:02'! - comeFullyUpOnReload: smartRefStream - - ^ self asEvaluable! ! -!SerializableBlockClosure class methodsFor: 'instance creation' stamp: 'jmv 9/20/2019 21:18:13'! - onBlockClosure: aBlockClosure - ^self new onBlockClosure: aBlockClosure! ! -!BlockClosure methodsFor: 'objects from disk' stamp: 'jmv 9/26/2019 09:26:56' prior: 50466559! - objectForDataStream: refStrm - "I am about to be written on an object file. - Write a textual reference if possible. If not, attempt converting to a serializable object. - This might also fail. See #onBlockClosure:" - - self isCleanClosure ifTrue: [ - ^ DiskProxy - global: #Compiler - selector: #evaluate: - args: (Array with: self decompile decompileString) ]. - ^self asSerializable! ! -!MethodContext methodsFor: 'accessing' stamp: 'jmv 9/26/2019 17:23:06' prior: 50474313! - outerContextsDo: aBlock - "Answer the context in which the receiver was defined." - - aBlock value: self. - closureOrNil - ifNotNil: [ closureOrNil outerContextsDo: aBlock ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3888-BlockClosureSerialization-JuanVuletich-2019Sep26-19h37m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3888] on 29 September 2019 at 1:08:13 pm'! -!ArrayedCollection class methodsFor: 'instance creation' stamp: 'jmv 9/29/2019 12:48:46'! - instancesMustBeOfSpecificSize - "Some subclasses create instances of a specific size, and answer true" - ^self numElements ~= 0! ! -!ArrayedCollection class methodsFor: 'instance creation' stamp: 'jmv 9/29/2019 12:47:53'! - numElements - "Some subclasses create instances of a specific size, and a non-zero number" - ^0! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3889-FixedSizeCollctionTweaks-p1-JuanVuletich-2019Sep29-13h08m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3888] on 29 September 2019 at 1:09:24 pm'! -!ArrayedCollection methodsFor: 'private' stamp: 'jmv 9/29/2019 13:00:32'! - species - "For methods such as #select:, and for instances of fixed size classes, such as Color, - find an appropriate class for new instances." - | candidate | - candidate _ self class. - [ candidate instancesMustBeOfSpecificSize ] whileTrue: [ - candidate _ candidate superclass ]. - ^candidate! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 9/29/2019 12:49:41'! - numElements - ^3! ! -!TranslucentColor class methodsFor: 'instance creation' stamp: 'jmv 9/29/2019 12:49:48'! - numElements - ^4! ! -!ArrayedCollection class methodsFor: 'instance creation' stamp: 'jmv 9/29/2019 12:52:40' prior: 16780577! - new - "Answer a new instance of me, with size = 0, unles a specific size is used." - - ^self new: self numElements! ! - -TranslucentColor class removeSelector: #new! - -TranslucentColor class removeSelector: #new! - -Color class removeSelector: #new! - -Color class removeSelector: #new! - -Float64Array class removeSelector: #new! - -Float64Array class removeSelector: #new! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3890-FixedSizeCollectionTweaks-p2-JuanVuletich-2019Sep29-13h08m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3890] on 29 September 2019 at 1:52:09 pm'! -!FeatureRequirement methodsFor: 'testing' stamp: 'KenD 9/26/2019 16:16:32'! - satisfies: anotherFeatureRequirement - - "Answer true if anotherFeatureRequirement is satisfied by me" - (self name = anotherFeatureRequirement name) ifFalse: [^false]. - "FIXME: add version,revision checks" - ^true! ! -!FeatureRequirement methodsFor: 'private' stamp: 'KenD 9/28/2019 09:03:11'! - addToLoad: toLoad withMyRequirements: requirements - - "Add self to OrderedCollection toLoad before any requirements I have" - | requires | - requires := requirements collect: [:r| r name]. "a set" - toLoad do: [ :featureReq | - (requires includes: featureReq name) - ifTrue: [ - "Transcript show: ('adding ', self name asString, ' before: ', featureReq name asString); newLine." - toLoad add: self before: featureReq. - ^ toLoad - ] - ]. - "Transcript show: ('adding ', self name asString); newLine." - toLoad addLast: self. - ^ toLoad - ! ! -!FeatureRequirement methodsFor: 'requires' stamp: 'KenD 9/28/2019 09:03:54' prior: 16840798! - require - "See if all the transitive closure of requirements can be met and answer the load order if so" - - | packagesToLoad | - - "Preflight before load" - [packagesToLoad _ self requireUnlessIn: OrderedCollection new main: nil] - on: FeatureRequirementUnsatisfied - do: [ :error | error defaultAction. - ^self "exit" - ]. - "Transcript show: 'packagesToLoad: '; newLine. - packagesToLoad do: [ :x |Transcript show: x; newLine ]. - Transcript newLine . -self halt." - packagesToLoad reverseDo: [ :requirement | - requirement isAlreadySatisfied ifFalse: [ - requirement install ]]. - self isAlreadySatisfied ifFalse: [ - self install ]! ! -!FeatureRequirement methodsFor: 'requires' stamp: 'KenD 9/27/2019 16:09:25' prior: 16840816! - requireUnlessIn: toLoad main: mainFeatureOrNil - "See if all the requirements can be met and answer the load order" - - self isAlreadySatisfied ifFalse: [ - (toLoad anySatisfy: [ :featReq | featReq satisfies: self]) - ifFalse: [ - (self findPackageFileAsReqOf: mainFeatureOrNil) - ifTrue: [ | otherRequirements | - otherRequirements := self requirements. - self == mainFeatureOrNil ifFalse: [ - self addToLoad: toLoad withMyRequirements: otherRequirements ]. - otherRequirements ifNotNil: [ - otherRequirements do: [ :requires | - requires requireUnlessIn: toLoad main: (mainFeatureOrNil ifNil: [self])]]] - ifFalse: [ - FeatureRequirementUnsatisfied - signal: 'Could not find package supplying: ', - String newLineString, ' ', - self printString - ]]]. - - ^ toLoad! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3891-FeatureReq-KenDickey-2019Sep29-13h51m-KenD.1.cs.st----! - -'From Cuis 5.0 [latest update: #3891] on 29 September 2019 at 1:56:19 pm'! -!Morph methodsFor: 'submorphs-accessing' stamp: 'jmv 9/29/2019 13:55:44' prior: 16876717! - submorphBehind: aMorph - - self submorphsBehind: aMorph do: [ :m | ^m ]. - ^nil! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3892-no-submorphBehind-JuanVuletich-2019Sep29-13h55m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3892] on 2 October 2019 at 10:56:50 am'! - -ArrayedCollection removeSelector: #species! - -ArrayedCollection removeSelector: #species! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3893-species-generally-means-class-JuanVuletich-2019Oct02-10h56m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3893] on 2 October 2019 at 11:39:31 am'! - -Object variableWordSubclass: #Float32SlotsObject - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Objects'! - -!classDefinition: #Float32SlotsObject category: #'Kernel-Objects'! -Object variableWordSubclass: #Float32SlotsObject - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Objects'! -!Float32SlotsObject commentStamp: '' prior: 0! - Abstract superclass for objects whose slots are 32 bit Floating Point values, but don't inherit from FloatArray because they are not collections, and collection protocol makes no sense on them.! -!Float32SlotsObject methodsFor: 'private' stamp: 'jmv 10/2/2019 11:38:34'! - at: index -" -'---------'print. -thisContext printStack: 10. -'======'print. -" -^self slotAt: index! ! -!Float32SlotsObject methodsFor: 'private' stamp: 'jmv 10/2/2019 11:38:42'! - at: index put: stuff -" -'---------'print. -thisContext printStack: 10. -'======'print. -" -^self slotAt: index put: stuff! ! -!Float32SlotsObject methodsFor: 'private' stamp: 'jmv 10/2/2019 11:21:16'! - slotAt: index - - ^Float fromIEEE32Bit: (self basicAt: index)! ! -!Float32SlotsObject methodsFor: 'private' stamp: 'jmv 10/2/2019 11:21:55'! -slotAt: index put: value - - value isFloat - ifTrue: [ self basicAt: index put: value asIEEE32BitWord ] - ifFalse: [ self slotAt: index put: value asFloat ]. - ^value! ! -!Float32SlotsObject class methodsFor: 'instance creation' stamp: 'jmv 10/2/2019 11:19:44'! - new - "Answer a new instance of me, with size = 0, unles a specific size is used." - - ^self new: self numSlots! ! -!Float32SlotsObject class methodsFor: 'instance creation' stamp: 'jmv 10/2/2019 11:39:11'! - numSlots - ^0! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3894-Float32SlotsObject-JuanVuletich-2019Oct02-11h38m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3894] on 2 October 2019 at 11:53:53 am'! -!Color methodsFor: 'comparing' stamp: 'jmv 10/2/2019 20:37:24'! - primitiveEqual: aColor - | length | - - aColor class == self class ifFalse: [^ false]. - length _ self size. - length = aColor size ifFalse: [^ false]. - 1 to: self size do: [ :i | - (self basicAt: i) = (aColor basicAt: i) ifFalse: [^ false]]. - ^ true! ! -!Color methodsFor: 'comparing' stamp: 'jmv 10/2/2019 20:31:03'! - = another - self == another ifTrue: [ ^ true ]. - self class == another class ifFalse: [ ^ false ]. - ^self primitiveEqual: another! ! -!Color methodsFor: 'private' stamp: 'jmv 10/2/2019 11:40:28'! - slotAt: index - - ^Float fromIEEE32Bit: (self basicAt: index)! ! -!Color methodsFor: 'private' stamp: 'jmv 10/2/2019 11:40:37'! - slotAt: index put: value - - value isFloat - ifTrue: [ self basicAt: index put: value asIEEE32BitWord ] - ifFalse: [ self slotAt: index put: value asFloat ]. - ^value! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 10/2/2019 11:19:25'! - numSlots - ^3! ! -!TranslucentColor class methodsFor: 'instance creation' stamp: 'jmv 10/2/2019 11:42:58'! - numSlots - ^4! ! -!Color methodsFor: 'access' stamp: 'jmv 10/2/2019 11:25:11' prior: 50353227! - blue - "Return the blue component of this color, a float in the range [0.0..1.0]." - - ^ self slotAt: 3! ! -!Color methodsFor: 'access' stamp: 'jmv 10/2/2019 11:25:44' prior: 50353255! - green - "Return the green component of this color, a float in the range [0.0..1.0]." - - ^ self slotAt: 2! ! -!Color methodsFor: 'access' stamp: 'jmv 10/2/2019 11:26:27' prior: 50353302! - red - "Return the red component of this color, a float in the range [0.0..1.0]." - - ^ self slotAt: 1! ! -!Color methodsFor: 'conversions' stamp: 'jmv 10/2/2019 11:26:14' prior: 50364625! - pixelValueForDepth: d - "Returns an integer representing the bits that appear in a single pixel of this color in a Form of the given depth. The depth must be one of 1, 2, 4, 8, 16, or 32. Contrast with pixelWordForDepth: and bitPatternForDepth:, which return either a 32-bit word packed with the given pixel value or a multiple-word Bitmap containing a pattern. The inverse is the class message colorFromPixelValue:depth:" - "Details: For depths of 8 or less, the result is a colorMap index. For depths of 16 and 32, it is a direct color value with 5 or 8 bits per color component." - "Transparency: The pixel value zero is reserved for transparent. For depths greater than 8 and less than 32 (no Indexed colors, no real alpha), black maps to the darkest possible blue. - Note that - Color transparent class = TranslucentColor - this special case is handled in TranslucentColor >> #pixelValueForDepth: - " - - | bitBltFakeBlack val | - "Most common case" - "eight bits per component; top 8 bits set to all ones (opaque alpha)" - d = 32 ifTrue: [ - ^ 16rFF000000 bitOr: - ((((self slotAt: 1) * 255.999) truncated bitShift: 16) bitOr: - ((((self slotAt: 2) * 255.999) truncated bitShift: 8) bitOr: - (((self slotAt: 3) * 255.999) truncated))) ]. - -"Faster in 32 bit systems, but slower in 64 bits" -" d = 32 ifTrue: [ - val _ LargePositiveInteger new: 4. - val at: 3 put: ((self at: 1) * 255.999) truncated. - val at: 2 put: ((self at: 2) * 255.999) truncated. - val at: 1 put: ((self at: 3) * 255.999) truncated. - val at: 4 put: 16rFF. - ^ val normalize]." - - d = 8 ifTrue: [^ self closestPixelValue8]. "common case" - d < 8 ifTrue: [ - d = 4 ifTrue: [^ self closestPixelValue4]. - d = 2 ifTrue: [^ self closestPixelValue2]. - d = 1 ifTrue: [^ self closestPixelValue1]]. - - "For the depth 16, pixelValue = 0 means transparent, black is represented as 16r8000 (rgb=0, pixelvalue !!= 0)." - (d = 16) | (d = 15) ifTrue: [ - "five bits per component; top bits ignored" - val _ ((self red * 31) rounded bitShift: 10) bitOr: - (((self green * 31) rounded bitShift: 5) bitOr: - ((self blue * 31) rounded)). - ^ val = 0 - ifTrue: [d = 16 ifTrue: [16r8000] ifFalse: [1]] - ifFalse: [val]]. - - "For the rest of the depths, pixelValue = 0 means transparent, and darkest blue is considered to be black." - bitBltFakeBlack := 1. "closest black that is not transparent in RGB - Not for depths <=8 (Indexed) or = 32 (RGBA)" - d = 12 ifTrue: [ "for indexing a color map with 4 bits per color component" - val _ ((self red * 15) rounded bitShift: 8) bitOr: - (((self green * 15) rounded bitShift: 4) bitOr: - ((self blue * 15) rounded)). - ^ val = 0 ifTrue: [bitBltFakeBlack] ifFalse: [val]]. - - d = 9 ifTrue: [ "for indexing a color map with 3 bits per color component" - val _ ((self red * 7) rounded bitShift: 6) bitOr: - (((self green * 7) rounded bitShift: 3) bitOr: - ((self blue * 7) rounded)). - ^ val = 0 ifTrue: [bitBltFakeBlack] ifFalse: [val]]. - - self error: 'unknown pixel depth: ', d printString! ! -!Color methodsFor: 'queries' stamp: 'jmv 10/2/2019 11:25:51' prior: 50353819! - isBlack - "Return true if the receiver represents black" - (self slotAt: 1) = 0.0 ifFalse: [ ^ false ]. - (self slotAt: 2) = 0.0 ifFalse: [ ^ false ]. - (self slotAt: 3) = 0.0 ifFalse: [ ^ false ]. - ^ true! ! -!Color methodsFor: 'queries' stamp: 'jmv 10/2/2019 11:25:59' prior: 50353832! - isWhite - "Return true if the receiver represents white" - (self slotAt: 1) = 1.0 ifFalse: [ ^ false ]. - (self slotAt: 2) = 1.0 ifFalse: [ ^ false ]. - (self slotAt: 3) = 1.0 ifFalse: [ ^ false ]. - ^ true! ! -!Color methodsFor: 'private' stamp: 'jmv 10/2/2019 11:21:43' prior: 50354208! - basicSetRed: r green: g blue: b - "Initialize this color's r, g, and b components to the given values in the range [0.0..1.0]." - - self - slotAt: 1 put: r; - slotAt: 2 put: g; - slotAt: 3 put: b! ! -!Color methodsFor: 'private' stamp: 'jmv 10/2/2019 11:25:15' prior: 50458792! - clipToValidValues - | v | - 1 to: self size do: [ :i | - v _ self slotAt: i. - v > 1 ifTrue: [self slotAt: i put: 1.0]. - v < 0 ifTrue: [self slotAt: i put: 0.0]]! ! -!TranslucentColor methodsFor: 'accessing' stamp: 'jmv 10/2/2019 11:50:06' prior: 50356498! - alpha - "Return my alpha value, a number between 0.0 and 1.0 where 0.0 is completely transparent and 1.0 is completely opaque." - - ^ self slotAt: 4! ! -!TranslucentColor methodsFor: 'private' stamp: 'jmv 10/2/2019 11:51:07' prior: 50356596! - setRed: r green: g blue: b alpha: alphaValue - - self basicSetRed: r green: g blue: b. - self slotAt: 4 put: alphaValue! ! - -Color removeSelector: #convertToCurrentVersion:refStream:! - -Color removeSelector: #convertToCurrentVersion:refStream:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3895-Color-part1-JuanVuletich-2019Oct02-11h53m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3894] on 2 October 2019 at 11:43:53 am'! - -Float32SlotsObject variableWordSubclass: #Color - instanceVariableNames: '' - classVariableNames: 'CachedColormaps FromGrayColormaps GrayToIndexMap IndexedColors MaskingMap ToGrayColormaps' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -!classDefinition: #Color category: #'Graphics-Primitives'! -Float32SlotsObject variableWordSubclass: #Color - instanceVariableNames: '' - classVariableNames: 'CachedColormaps FromGrayColormaps GrayToIndexMap IndexedColors MaskingMap ToGrayColormaps' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3896-Color-part2-JuanVuletich-2019Oct02-11h43m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3894] on 2 October 2019 at 11:46:14 am'! - -TranslucentColor class removeSelector: #numElements! - -TranslucentColor class removeSelector: #numElements! - -Color class removeSelector: #numElements! - -Color class removeSelector: #numElements! - -Color removeSelector: #slotAt:! - -Color removeSelector: #slotAt:! - -Color removeSelector: #slotAt:put:! - -Color removeSelector: #slotAt:put:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3897-Color-part3-JuanVuletich-2019Oct02-11h43m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3897] on 2 October 2019 at 11:57:45 am'! - -Float32SlotsObject removeSelector: #at:! - -Float32SlotsObject removeSelector: #at:! - -Float32SlotsObject removeSelector: #at:put:! - -Float32SlotsObject removeSelector: #at:put:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3898-Float32SlotsObject-cleanup-JuanVuletich-2019Oct02-11h56m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3898] on 2 October 2019 at 2:16:17 pm'! -!Color methodsFor: 'object serialization' stamp: 'jmv 6/22/2017 12:54:10'! - convertToCurrentVersion: varDict refStream: smartRefStrm - - "subclasses should implement if they wish to convert old instances to modern ones" - self size = 0 ifTrue: [ - ^ Color new copyFrom: (varDict at: 'floatRGB') ]. - ^ self! ! -!Color methodsFor: 'private' stamp: 'jmv 10/2/2019 13:53:40' prior: 50354332! - setRed: r green: g blue: b range: range - "Initialize this color's r, g, and b components to the given values in the range [0..r]." - - self basicSetRed: r/range green: g/range blue: b/range. - self clipToValidValues! ! - -Color removeSelector: #*=! - -Color removeSelector: #*=! - -Color removeSelector: #+=! - -Color removeSelector: #+=! - -Color removeSelector: #-=! - -Color removeSelector: #-=! - -Color removeSelector: #/=! - -Color removeSelector: #/=! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3899-Color-fixes-JuanVuletich-2019Oct02-14h15m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3892] on 30 September 2019 at 3:25:41 pm'! -!FeatureRequirement methodsFor: 'testing' stamp: 'KenD 9/30/2019 08:12:46'! - checkRequirement - "Answer if I am satisfied by package found at pathName" - - pathName asFileEntry readStreamDo: [ :stream | | fSpec | - fSpec := ((CodePackageFile buildFileStream: stream) featureSpec). - ((fSpec isNil) or: [(fSpec provides satisfies: self) not]) - ifTrue: [ - FeatureRequirementUnsatisfied - signal: pathName, - String newLineString, - ' could not satisfy ', self printString. - ^false - ] - ifFalse: [ ^true ] - ] - -! ! -!FeatureRequirement methodsFor: 'testing' stamp: 'KenD 9/30/2019 09:51:40'! - sameNameAs: anotherFeatureRequirement - - "Answer true if anotherFeatureRequirement has same name as me" - ^(self name = anotherFeatureRequirement name)! ! -!CodePackageFile methodsFor: 'accessing' stamp: 'KenD 9/29/2019 21:28:27'! - featureSpec - - ^ featureSpec! ! -!FeatureRequirement methodsFor: 'requires' stamp: 'KenD 9/30/2019 15:12:46' prior: 50474911! - require - "See if all the transitive closure of requirements can be met and answer the load order if so" - - | packagesToLoad | - - "Preflight before load - [1] Build transitive closure as load order where Feature comes - before its required features." - [packagesToLoad _ self requireUnlessIn: OrderedCollection new main: nil] - on: FeatureRequirementUnsatisfied - do: [ :error | error defaultAction. - ^self "exit" - ]. - - "Transcript show: 'packagesToLoad: '; newLine. - packagesToLoad do: [ :x |Transcript show: x; newLine ]. - Transcript newLine." - - "[2] Check to see that each requirement is actually satisfied" - [packagesToLoad do: [ :fReq | fReq checkRequirement ]] - on: FeatureRequirementUnsatisfied - do: [ :error | error defaultAction. - ^self "exit" - ]. - - "[3] Load required packages before packages that require them" - packagesToLoad reverseDo: [ :requirement | - requirement isAlreadySatisfied ifFalse: [ - requirement install ]]. - self isAlreadySatisfied ifFalse: [ - self install ]! ! -!FeatureRequirement methodsFor: 'requires' stamp: 'KenD 9/30/2019 15:23:40' prior: 50474934! - requireUnlessIn: toLoad main: mainFeatureOrNil - "See if all the requirements can be met and answer the load order" - - self isAlreadySatisfied ifFalse: [ - (toLoad anySatisfy: [ :featReq | featReq sameNameAs: self]) - ifFalse: [ - (self findPackageFileAsReqOf: mainFeatureOrNil) - ifTrue: [ | otherRequirements | - otherRequirements := self requirements. - otherRequirements ifNotNil: [ - otherRequirements do: [ :requires | - requires requireUnlessIn: toLoad main: (mainFeatureOrNil ifNil: [self])]]. - self == mainFeatureOrNil ifFalse: [ - self addToLoad: toLoad withMyRequirements: otherRequirements ]. - ] - ifFalse: [ - FeatureRequirementUnsatisfied - signal: 'Could not find package supplying: ', - String newLineString, ' ', - self printString - ]]]. - - ^ toLoad! ! -!FeatureRequirement methodsFor: 'private' stamp: 'KenD 9/30/2019 15:13:19' prior: 50474891! - addToLoad: toLoad withMyRequirements: requirements - - "Add self to OrderedCollection 'toLoad' before any requirements I have" - | myRequirements | - myRequirements := self requirements. - toLoad do: [ :featureReq | - (myRequirements anySatisfy: [ :req | featureReq sameNameAs: req]) - ifTrue: [ - "Transcript show: ('adding ', self name asString, ' before: ', featureReq name asString); newLine." - toLoad add: self before: featureReq. - ^ toLoad - ] - ]. - "Transcript show: ('adding ', self name asString); newLine." - toLoad addLast: self. - ^ toLoad - ! ! - -FeatureRequirement removeSelector: #satisfies:! - -FeatureRequirement removeSelector: #satisfies:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3900-FeatureReFix-KenD-2019Sep30-15h20m-KenD.1.st----! - -'From Cuis 5.0 [latest update: #3900] on 2 October 2019 at 8:48:36 pm'! -!Color methodsFor: 'comparing' stamp: 'jmv 10/2/2019 20:31:03' prior: 50475071! - = another - self == another ifTrue: [ ^ true ]. - self class == another class ifFalse: [ ^ false ]. - ^self primitiveEqual: another! ! -!Color methodsFor: 'comparing' stamp: 'jmv 10/2/2019 20:37:59'! - hash - | hash | - - hash _ (self species hash + self size hash) hashMultiply. - 1 to: self size do: [ :i | hash _ (hash + (self basicAt: i)) hashMultiply]. - ^hash! ! -!Color methodsFor: 'comparing' stamp: 'jmv 10/2/2019 20:37:24' prior: 50475059! - primitiveEqual: aColor - | length | - - aColor class == self class ifFalse: [^ false]. - length _ self size. - length = aColor size ifFalse: [^ false]. - 1 to: self size do: [ :i | - (self basicAt: i) = (aColor basicAt: i) ifFalse: [^ false]]. - ^ true! ! -!Color methodsFor: 'object serialization' stamp: 'jmv 10/2/2019 20:45:01'! - 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." - - Smalltalk isLittleEndian ifTrue: [ - BitBlt swapBytesIn32BitWords: self ]! ! -!Color methodsFor: 'object serialization' stamp: 'jmv 10/2/2019 20:46:32'! - 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." - aStream nextSignedInt32Put: self basicSize bigEndian: true. - aStream nextWordsPutAll: self.! ! -!Color class methodsFor: 'class initialization' stamp: 'jmv 10/2/2019 20:47:49'! - newFromStream: s - "Only meant for my subclasses that are raw bits and word-like. For quick unpack form the disk." - | len | - len _ s nextSignedInt32BigEndian: true. - ^ s nextWordsInto: (self basicNew: len)! ! - -Color removeSelector: #hashFull! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3901-Color-fixes-JuanVuletich-2019Oct02-20h29m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3901] on 6 October 2019 at 10:24:14 am'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 10/6/2019 10:23:56' prior: 50456347! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('AY' 'Angel Yan') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('bgs' 'Boris G. Shingarov') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('EB' 'Eric Brandwein') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('FGJ' 'Fernando Gasperi Jabalera') - #('FJG' 'Facundo Javier Gelatti') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('KLG' 'Gerald Klix') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MM' 'Mariano Montone') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('pmon' 'Paolo Montrasi') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('SLD' 'Steve Davies') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('ss' 'Sebastian Sujarchuk') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3902-AddSebastianAsKnownAuthor-JuanVuletich-2019Oct06-10h23m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3901] on 6 October 2019 at 10:24:55 am'! -!BasicClassOrganizer methodsFor: 'private' stamp: 'ss 10/3/2019 19:59:34'! - hasClassComment - - ^classComment notNil and: [^classComment text notNil]! ! -!BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'ss 10/3/2019 19:59:25' prior: 50405690! - fileOutCommentOn: aFileStream moveSource: moveSource toFile: fileIndex - "Copy the class comment to aFileStream. If moveSource is true (as in compressChanges or compressSources, then update classComment to point to the new file." - | fileComment | - self hasClassComment ifTrue: [ - aFileStream newLine. - fileComment _ RemoteString newString: self classComment - onFileNumber: fileIndex toFile: aFileStream. - moveSource ifTrue: [classComment _ fileComment]. - Smalltalk defaultUserChangesName asFileEntry appendStreamDo: [ :stream | - stream newLine; nextChunkPut: self classComment ]]! ! -!BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'ss 10/3/2019 19:58:31' prior: 16782685! - putCommentOnFile: aFileStream numbered: sourceIndex moveSource: moveSource forClass: aClass - "Store the comment about the class onto file, aFileStream." - | header | - self hasClassComment ifTrue: [ - aFileStream newLine; nextPut: $!!. - header _ String streamContents: [:strm | - strm nextPutAll: aClass name; - nextPutAll: ' commentStamp: '. - commentStamp ifNil: [commentStamp _ '']. - commentStamp storeOn: strm. - strm nextPutAll: ' prior: '; nextPutAll: '0']. - aFileStream nextChunkPut: header. - aClass organization fileOutCommentOn: aFileStream - moveSource: moveSource toFile: sourceIndex. - aFileStream newLine]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3903-FileoutWithNoClassCommentFix-SebastianSujarchuk-2019Oct06-10h24m-ss.1.cs.st----! - -'From Cuis 5.0 [latest update: #3903] on 6 October 2019 at 10:34:39 am'! -!Float32SlotsObject methodsFor: 'accessing' stamp: 'jmv 10/6/2019 10:34:22'! - byteSize - ^self size * 4! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3904-Color-byteSize-JuanVuletich-2019Oct06-10h34m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3904] on 8 October 2019 at 7:59:11 am'! -!Integer methodsFor: 'mathematical functions' stamp: 'sqr 10/8/2019 07:57:23' prior: 50337799! - raisedTo: n modulo: m - "Answer the modular exponential. - Note: this implementation is optimized for case of large integers raised to large powers." - | a s mInv | - n = 0 ifTrue: [^1 \\ m]. - (self >= m or: [self < 0]) ifTrue: [^self \\ m raisedTo: n modulo: m]. - n < 0 ifTrue: [^(self reciprocalModulo: m) raisedTo: n negated modulo: m]. - (n < 4096 or: [m even]) - ifTrue: - ["Overhead of Montgomery method might cost more than naive divisions, use naive" - ^self slidingLeftRightRaisedTo: n modulo: m]. - - mInv := self montgomeryDigitBase - ((m bitAnd: self montgomeryDigitMax) reciprocalModulo: self montgomeryDigitBase). - - "Initialize the result to R=self montgomeryDigitModulo raisedTo: m montgomeryNumberOfDigits" - a := (1 bitShift: m montgomeryNumberOfDigits * m montgomeryDigitLength) \\ m. - - "Montgomerize self (multiply by R)" - (s := self montgomeryTimes: (a*a \\ m) modulo: m mInvModB: mInv) - ifNil: - ["No Montgomery primitive available ? fallback to naive divisions" - ^self slidingLeftRightRaisedTo: n modulo: m]. - - "Exponentiate self*R" - a := s montgomeryRaisedTo: n times: a modulo: m mInvModB: mInv. - - "Demontgomerize the result (divide by R)" - ^a montgomeryTimes: 1 modulo: m mInvModB: mInv! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3905-Integer-raisedTo-modulo-fix-AndresValloud-AgustinSansone-2019Oct08-07h57m-sqr.1.cs.st----! - -'From Cuis 5.0 [latest update: #3905] on 8 October 2019 at 8:44:06 am'! -!FeatureRequirement methodsFor: 'requires' stamp: 'KenD 10/7/2019 10:59:06' prior: 16840839! - satisfyRequirementsAndInstall - "Like #require, but install me even if already satisified (i.e. installed)" - - | packagesToLoad | - - "Preflight before load" - [packagesToLoad _ self requireUnlessIn: OrderedCollection new main: self] - on: FeatureRequirementUnsatisfied - do: [ :error | error defaultAction. - ^self "exit" - ]. - - "Check to see that each requirement is actually satisfied" - [packagesToLoad do: [ :fReq | fReq checkRequirement ]] - on: FeatureRequirementUnsatisfied - do: [ :error | error defaultAction. - ^self "exit" - ]. - - "All requirements are satisfied; do the deed" - packagesToLoad reverseDo: [ :requirement | - requirement isAlreadySatisfied ifFalse: [ - requirement install ]]. - self install! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3906-FileList-install-fix-KenDickey-2019Oct08-08h42m-KenD.1.cs.st----! - -'From Cuis 5.0 [latest update: #3906] on 9 October 2019 at 11:38:23 am'! -!DirectoryEntry methodsFor: 'enumeration' stamp: 'jmv 10/9/2019 11:23:46'! - allRegularDirectoriesDo: aBlock - self regularDirectoriesDo: [ :child | - aBlock value: child. - child allRegularDirectoriesDo: aBlock]! ! -!DirectoryEntry methodsFor: 'enumeration' stamp: 'jmv 10/9/2019 11:23:21'! - regularDirectoriesDo: aBlock - self childrenDo: [ :each | - each isFile ifFalse: [ - each isRegularDirectory ifTrue: [ - aBlock value: each ]]]! ! -!DirectoryEntry methodsFor: 'testing' stamp: 'jmv 10/9/2019 11:28:39'! - isRegularDirectory - "hidden convention in Unix" - name first = $. ifTrue: [ ^false ]. - "in MacOS, applications are actually directories, but are usually not treated as such" - self extension = 'app' ifTrue: [ ^false ]. - "in MacOS, .bundle directories, are resource packages" - self extension = 'bundle' ifTrue: [ ^false ]. - ^true! ! -!FeatureRequirement methodsFor: 'private' stamp: 'jmv 10/9/2019 11:35:55' prior: 50449742! - placesToLookForPackagesDo: aBlock - - | myDir base packagesDirectory | - - "Look inside my own folder" - pathName ifNotNil: [ - myDir _ pathName asFileEntry parent. - aBlock value: myDir ]. - - "Look in Cuis image folder and reasonable subfolders" - base _ DirectoryEntry smalltalkImageDirectory. - aBlock value: base. - packagesDirectory _ base / 'Packages'. - aBlock value: packagesDirectory. - packagesDirectory allRegularDirectoriesDo: aBlock. - base regularDirectoriesDo: [ :child | - child = packagesDirectory ifFalse: [ - aBlock value: child. - child allRegularDirectoriesDo: aBlock]]. - - "Look in parent directory and reasonable subfolders. - Useful when image is stored in a subdirectory of the main app directory. - This could be the case when the package comes from a 'main' git repo, and image is copied from gitHub. - First try directories including the word Cuis in the name. Then try others." - base parent regularDirectoriesDo: [ :dir | - dir ~= base ifTrue: [ - ('*Cuis*' match: dir name) - ifTrue: [aBlock value: dir. dir allRegularDirectoriesDo: aBlock]]]. - base parent regularDirectoriesDo: [ :dir | - dir ~= base ifTrue: [ - ('*Cuis*' match: dir name) - ifFalse: [aBlock value: dir. dir allRegularDirectoriesDo: aBlock]]]. - - "Also look in host OS current directory" - (base ~= DirectoryEntry currentDirectory and: [base parent ~= DirectoryEntry currentDirectory]) - ifTrue: [ - base _ DirectoryEntry currentDirectory. - base allRegularDirectoriesDo: aBlock ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3907-PackageLookupImprovements-JuanVuletich-2019Oct09-11h04m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3907] on 9 October 2019 at 12:17:11 pm'! -!FeatureRequirementUnsatisfied methodsFor: 'exceptionDescription' stamp: 'jmv 10/9/2019 11:57:30' prior: 16841023! - defaultAction - "The default action taken if the exception is signaled." - - self messageText print. - PopUpMenu inform: - self messageText, - String newLineString, String newLineString, - 'You can view loaded Packages and their requirements via', - String newLineString, - ' World menu > Open.. > Installed Packages', - String newLineString - -! ! -!FeatureRequirement methodsFor: 'requires' stamp: 'jmv 10/9/2019 12:14:51' prior: 16840767! - findPackageFileAsReqOf: mainFeatureOrNil - "Look in known places for packages providing required feature. - Answer wether search was successful." - | packageFileName entry | - pathName ifNotNil: [ - pathName asFileEntry exists ifTrue: [ ^ true ]]. - packageFileName _ self packageFileName. - (mainFeatureOrNil ifNil: [ self ]) placesToLookForPackagesDo: [ :directory | - entry _ directory // packageFileName. - entry exists ifTrue: [ - pathName _ entry pathName. - self checkRequirement ifTrue: [ ^true ]. - pathName _ nil]]. - ^ false! ! -!FeatureRequirement methodsFor: 'testing' stamp: 'jmv 10/9/2019 12:16:13' prior: 50475365! - checkRequirement - "Answer if I am satisfied by package found at pathName" - - pathName asFileEntry readStreamDo: [ :stream | | fSpec | - fSpec := ((CodePackageFile buildFileStream: stream) featureSpec). - ^ fSpec notNil and: [fSpec provides satisfies: self]] - -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3908-RequirementsCheckEnhancements-JuanVuletich-2019Oct09-12h14m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3908] on 9 October 2019 at 2:36:48 pm'! -!SystemDictionary methodsFor: 'shrinking' stamp: 'jmv 10/9/2019 14:36:43' prior: 50456929! - reduceCuis - " - Smalltalk reduceCuis - " - | keep n unused newDicts oldDicts | - - self nominallyUnsent: #reduceCuis. - - "Remove icons" - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - PasteUpMorph allInstancesDo: [ :w | - w backgroundImageData: nil. - w submorphsDo: [ :a | a delete ]]. - Preferences useNoMenuIcons. - Theme current initialize. - Theme content: nil. - Color shutDown. - BitBltCanvas releaseClassCachedState. - - Transcript clear. - Clipboard default initialize. - - - "Remove some methods, even if they have senders." - Utilities removeSelector: #vmStatisticsReportString. - SystemDictionary removeSelector: #recreateSpecialObjectsArray. - - StrikeFont saveSpace. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - - keep := OrderedCollection new. - keep addAll: #(SpaceTally DynamicTypingSmalltalkCompleter). - AppLauncher appGlobalName ifNotNil: [ :any | - keep add: any ]. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - [ - #hereWeGo print. - unused do: [:c | - c print. - (Smalltalk at: c) removeFromSystem]. - n := Smalltalk removeAllUnSentMessages. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - n > 0 or: [ - unused notEmpty ]] whileTrue. - ChangeSet zapAllChangeSets. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - Symbol rehash. - - "Shrink method dictionaries." - Smalltalk garbageCollect. - oldDicts _ MethodDictionary allInstances. - newDicts _ Array new: oldDicts size. - oldDicts withIndexDo: [:d :index | - newDicts at: index put: d rehashWithoutBecome ]. - oldDicts elementsExchangeIdentityWith: newDicts. - oldDicts _ newDicts _ nil. - - SmalltalkCompleter initialize . - - "Sanity checks" -" Undeclared - Smalltalk cleanOutUndeclared - Smalltalk browseUndeclaredReferences - Smalltalk obsoleteClasses - Smalltalk obsoleteBehaviors - Smalltalk browseObsoleteMethodReferences - SmalltalkImage current fixObsoleteReferences - Smalltalk browseAllUnimplementedCalls"! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3909-reduceCuis-fix-JuanVuletich-2019Oct09-14h36m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3904] on 8 October 2019 at 10:16:09 pm'! -!TheWorldMenu methodsFor: 'private' stamp: 'pb 10/8/2019 22:07:22'! - pvtAlphaSplitListDepth - "Split factor. A higher number results in fewer items in each submenu" - ^ 4! ! -!TheWorldMenu methodsFor: 'private' stamp: 'pb 10/8/2019 22:07:30'! - pvtCategorySplitListDepth - "Split factor. A higher number results in fewer items in each submenu" - ^ 2.! ! -!TheWorldMenu methodsFor: 'private' stamp: 'pb 10/8/2019 22:14:40'! - pvtMaxItemsPerCategorySubMenu - "If the number of items exceeds this value, split the category submenu into sub-submenus" - ^ 15.! ! -!TheWorldMenu methodsFor: 'private' stamp: 'pb 10/8/2019 22:00:02'! - pvtNewMenuForSplitLists: splitLists -| firstChar lastChar menu subMenu | -menu := MenuMorph new defaultTarget: self. - 1 - to: splitLists size - do: [ :i | - firstChar := i = 1 - ifTrue: [ $A ] - ifFalse: [ - (splitLists at: i) first name first: 3 ]. - lastChar := i = splitLists size - ifTrue: [ $Z ] - ifFalse: [ - (splitLists at: i) last name first: 3 ]. - subMenu := MenuMorph new. - (splitLists at: i) do: [ :cl | - subMenu - add: cl name - target: self - action: #newMorphOfClass:event: - argument: cl ]. - menu - add: firstChar asString , ' - ' , lastChar asString - subMenu: subMenu ]. - ^ menu.! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'pb 10/8/2019 22:07:54' prior: 50393217! - alphabeticalMorphMenu - | list splitLists | - list := Morph withAllSubclasses select: [ :m | - m includeInNewMorphMenu ]. - list := list asArray sort: [ :c1 :c2 | - c1 name < c2 name ]. - splitLists := self - splitNewMorphList: list - depth: self pvtAlphaSplitListDepth . - ^ self pvtNewMenuForSplitLists: splitLists -! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'pb 10/8/2019 22:11:22' prior: 50393326! - newMorph - "The user requested 'new morph' from the world menu. Put up a menu that allows many ways of obtaining new morphs. If the preference #classicNewMorphMenu is true, the full form of yore is used; otherwise, a much shortened form is used." - | menu catDict | - menu _ self menu: 'Add a new morph'. - menu - - add: 'From Clipboard' - target: myHand - action: #pasteMorph; - - add: 'From Alphabetical List' - subMenu: self alphabeticalMorphMenu. - menu addLine. - "Add 'Classic' New Morph menu" - catDict _ Dictionary new. - Morph allSubclassesDo: [ :eaSubclass | - eaSubclass includeInNewMorphMenu ifTrue: [ | category | - (eaSubclass respondsTo: #categoryInNewMorphMenu) - ifTrue: [ category _ eaSubclass categoryInNewMorphMenu ] - ifFalse: [ category _ 'Unknown' ]. - (catDict includesKey: category) - ifTrue: [ (catDict at: category) add: eaSubclass ] - ifFalse: [ - catDict - at: category - put: (OrderedCollection with: eaSubclass) ]]]. - catDict keys sort do: [ :categ | | morphsInCat | - morphsInCat _ (catDict at: categ) asArray sort: [ :c1 :c2 | - c1 name < c2 name ]. - morphsInCat size > self pvtMaxItemsPerCategorySubMenu - ifTrue: [ - menu - add: categ - subMenu: - (self pvtNewMenuForSplitLists: - (self - splitNewMorphList: morphsInCat - depth: self pvtCategorySplitListDepth )) ] - ifFalse: [ | subMenu | - subMenu _ MenuMorph new. - morphsInCat do: [ :cl | - subMenu - add: cl name - target: self - action: #newMorphOfClass:event: - argument: cl ]. - menu - add: categ - subMenu: subMenu ]]. - self doPopUp: menu.! ! - -TheWorldMenu removeSelector: #pvtMaxItemsPerCategory! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3910-New-Morph-category-menu-split-PhilBellalouna-2019Oct08-21h55m-pb.1.cs.st----! - -'From Cuis 5.0 [latest update: #3846] on 9 October 2019 at 10:19:37 am'! - -Refactoring subclass: #RenameInstanceVariable - instanceVariableNames: 'oldVariable addInstanceVariable rewriter renamedReferences newVariable methodsAndRangesToChange classToRefactor ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameInstanceVariable category: #'Tools-Refactoring'! -Refactoring subclass: #RenameInstanceVariable - instanceVariableNames: 'oldVariable addInstanceVariable rewriter renamedReferences newVariable methodsAndRangesToChange classToRefactor' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!CodeProvider methodsFor: 'contents' stamp: 'HAW 10/8/2019 16:39:33'! - instanceVariableRenamed - - self acceptedContentsChanged -! ! -!Debugger methodsFor: 'accessing' stamp: 'HAW 10/8/2019 16:52:56'! - resetToSelectedContextWith: newMethod - - | ctxt | - - ctxt := interruptedProcess popTo: self selectedContext. - ctxt == self selectedContext - ifFalse: - [self inform: 'Method saved, but current context unchanged\because of unwind error. Click OK to see error' withNewLines] - ifTrue: - [newMethod isQuick ifFalse: - [interruptedProcess - restartTopWith: newMethod; - stepToSendOrReturn]. - contextVariablesInspector object: nil]. - self resetContext: ctxt. - ! ! -!Debugger methodsFor: 'contents' stamp: 'HAW 10/8/2019 16:54:07'! - instanceVariableRenamed - - | newMethod | - - newMethod := self selectedClass compiledMethodAt: self selectedContext selector. - self resetToSelectedContextWith: newMethod ! ! -!Categorizer class methodsFor: 'well known categories' stamp: 'HAW 10/8/2019 14:45:15'! - initialization - - ^'initialization'! ! -!Categorizer class methodsFor: 'well known categories' stamp: 'HAW 10/8/2019 17:18:38'! - instanceCreation - - ^'instance creation'! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'testing' stamp: 'HAW 10/9/2019 10:06:00'! - isAtClassNameInClassDefinition: anIndex - - ^(classDefinitionNode rangeForNode: classCreationMessageNode arguments first ifAbsent: [ ^ false ]) first includes: anIndex! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'testing' stamp: 'HAW 10/9/2019 10:04:36'! - isAtSuperclassInClassDefinition: anIndex - - ^(classDefinitionNode rangeForNode: superClassNode ifAbsent: [ ^ false ]) first includes: anIndex ! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'testing' stamp: 'HAW 10/9/2019 10:14:44'! - isClassDefinition - - ^classDefinitionNode encoder classEncoding isMeta not! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'parameters positions' stamp: 'HAW 10/9/2019 10:18:15'! - instanceVariableNamesPosition - - ^self isClassDefinition ifTrue: [ self class instanceVariableNamesPositionForClassDefinition ] ifFalse: [ self class instanceVariableNamesPositionForMetaclassDefinition ]! ! -!ClassDefinitionNodeAnalyzer class methodsFor: 'parameters positions' stamp: 'HAW 10/9/2019 10:18:41'! - instanceVariableNamesPositionForClassDefinition - - ^2! ! -!ClassDefinitionNodeAnalyzer class methodsFor: 'parameters positions' stamp: 'HAW 10/9/2019 10:18:46'! - instanceVariableNamesPositionForMetaclassDefinition - - ^1! ! -!RenameInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 10/9/2019 09:16:21'! - changeInstanceVariableName - - | instanceVariableNames oldVariableIndex | - - instanceVariableNames := classToRefactor instVarNames. - oldVariableIndex := instanceVariableNames indexOf: oldVariable. - instanceVariableNames at: oldVariableIndex put: newVariable.! ! -!RenameInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 10/9/2019 09:07:24'! - keepMethodToChangeNamed: aSelector in: aClass - - | methodToChange rangesToChange | - - methodToChange := aClass >> aSelector. - rangesToChange := methodToChange methodNode positionsForInstanceVariable: oldVariable ifAbsent: [ #() ]. - - methodsAndRangesToChange add: methodToChange -> rangesToChange ! ! -!RenameInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 10/9/2019 09:16:15'! - lookForMethodsReferencingOldVariable - - methodsAndRangesToChange := OrderedCollection new. - classToRefactor withAllSubclassesDo: [ :aClass | self lookForMethodsReferencingOldVariableIn: aClass ]. -! ! -!RenameInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 10/9/2019 09:06:51'! - lookForMethodsReferencingOldVariableIn: aClass - - (aClass whichSelectorsAccess: oldVariable) do: [ :aSelector | self keepMethodToChangeNamed: aSelector in: aClass ]. - ! ! -!RenameInstanceVariable methodsFor: 'initialization' stamp: 'HAW 10/9/2019 09:14:17'! -initializeFrom: anOldvariable to: aNewVariable in: aClassToRefactor - - oldVariable := anOldvariable. - newVariable := aNewVariable. - classToRefactor := aClassToRefactor ! ! -!Debugger methodsFor: 'accessing' stamp: 'HAW 10/8/2019 16:53:16' prior: 50468430! - contents: aText notifying: aController - "The retrieved information has changed and its source must now be updated. - In this case, the retrieved information is the method of the selected context." - - | result selector classOfMethod category h newMethod | - - contextStackIndex = 0 ifTrue: [^false]. - - classOfMethod := self selectedClass. - category := self selectedMessageCategoryName. - selector :=self selectedClass parserClass selectorFrom: aText. - - selector ~= self selectedMessageName ifTrue: [ - self inform: 'Can not change the selector in the debugger'. - ^false]. - (classOfMethod = UndefinedObject and: [ selector = Scanner doItSelector or: [ selector = Scanner doItInSelector ]]) ifTrue: [ - self inform: 'DoIt and DoItIn: methods can not be changed'. - ^false]. - - self selectedContext isExecutingBlock ifTrue: [ - h := self selectedContext activeHome. - h ifNil: [ - self inform: 'Method for block not found on stack, can''t edit and continue'. - ^false]. - (self confirm: 'I will have to revert to the method from\which this block originated. Is that OK?' withNewLines) ifFalse: [^false]. - self resetContext: h. - (result := self contents: aText notifying: aController) ifTrue: [self acceptedContentsChanged]. - ^result]. - - selector := classOfMethod - compile: aText - classified: category - notifying: aController. - selector ifNil: [^false]. "compile cancelled" - newMethod := classOfMethod compiledMethodAt: selector. - - newMethod isQuick ifTrue: [ - contextStackIndex + 1 > contextStack size ifTrue: [ - self inform: 'Can not compile a quick method in the stack base context'. - ^false]. - self down. - self selectedContext jump: (self selectedContext previousPc - self selectedContext pc)]. - - self resetToSelectedContextWith: newMethod. - - ^true! ! -!Debugger methodsFor: 'context stack menu' stamp: 'HAW 10/8/2019 17:18:14' prior: 16829788! - askForCategoryIn: aClass default: aDefaultCategory - - | categories index category classCategories | - - categories := OrderedCollection with: 'new ...'. - - aClass isMeta ifTrue: [ categories add: Categorizer instanceCreation ]. - classCategories := aClass allMethodCategoriesIntegratedThrough: Object. - aClass isMeta ifTrue: [ classCategories remove: Categorizer instanceCreation ifAbsent: []]. - - categories addAll: classCategories. - index := PopUpMenu - withCaption: 'Please provide a good category for the new method!!' - chooseFrom: categories. - index = 0 ifTrue: [^ aDefaultCategory]. - category := index = 1 - ifTrue: [FillInTheBlankMorph request: 'Enter category name:'] - ifFalse: [categories at: index]. - - ^ category isEmpty ifTrue: [aDefaultCategory] ifFalse: [category]! ! -!Debugger methodsFor: 'method creation' stamp: 'HAW 10/8/2019 17:15:10' prior: 50418479! - implement: aMessage inClass: aClass context: aContext - - self implement: aMessage inCategory: (self askForCategoryIn: aClass default: Categorizer default) fromClass: aClass context: aContext! ! -!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'HAW 10/8/2019 17:21:29' prior: 16806150! - allMethodCategoriesIntegratedThrough: mostGenericClass - "Answer a list of all the method categories of the receiver and all its superclasses, up through mostGenericClass" - - | aColl | - aColl _ OrderedCollection new. - self withAllSuperclasses do: [ :aClass | - (aClass includesBehavior: mostGenericClass) - ifTrue: [ aColl addAll: aClass organization categories ]]. - aColl remove: 'no messages' asSymbol ifAbsent: nil. - - ^ aColl asSet asSortedCollection: [ :a :b | a asLowercase < b asLowercase ] - -"ColorTileMorph allMethodCategoriesIntegratedThrough: TileMorph"! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'testing' stamp: 'HAW 10/9/2019 10:14:50' prior: 50452240! - isAtCategory: anIndex - - ^self isClassDefinition and: [ self is: anIndex atStringParameterNumber: self class categoryPosition ] - ! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'testing' stamp: 'HAW 10/9/2019 10:14:57' prior: 50460721! - isAtClassName: anIndex - - ^self isClassDefinition and: [ self isAtClassNameInClassDefinition: anIndex ] - ! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'testing' stamp: 'HAW 10/9/2019 10:09:14' prior: 50452253! - isAtInstanceVariables: anIndex - - ^self is: anIndex atStringParameterNumber: self instanceVariableNamesPosition! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'testing' stamp: 'HAW 10/9/2019 10:15:11' prior: 50460729! - isAtSuperclass: anIndex - - ^self isClassDefinition and: [ self isAtSuperclassInClassDefinition: anIndex ]! ! -!AutoCompleterSelectorsCollector methodsFor: 'entries to show - private' stamp: 'HAW 10/8/2019 17:19:27' prior: 50434218! - prioritizedCategories - - ^{Categorizer instanceCreation}! ! -!RenameInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 10/9/2019 09:14:52' prior: 50440905! - newSourceOf: aMethodAndRangesToChange - - | newSource ranges methodToChange | - - methodToChange := aMethodAndRangesToChange key. - ranges := aMethodAndRangesToChange value. - newSource := methodToChange sourceCode copyReplacing: ranges with: newVariable. - - ^newSource - ! ! -!RenameInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 10/9/2019 09:09:41' prior: 50440922! - renameReferencesToOldVariable - - renamedReferences := OrderedCollection new. - methodsAndRangesToChange do: [ :aMethodAndRangesToChange | self renameReferencesToOldVariableInMethod: aMethodAndRangesToChange ]. - ! ! -!RenameInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 10/9/2019 09:01:03' prior: 50440944! -renameReferencesToOldVariableInMethod: aMethodAndRangesToChange - - | methodToChange | - - methodToChange := aMethodAndRangesToChange key. - methodToChange methodClass compile: (self newSourceOf: aMethodAndRangesToChange). - renamedReferences add: methodToChange methodReference ! ! -!RenameInstanceVariable methodsFor: 'applying' stamp: 'HAW 10/9/2019 09:08:49' prior: 50440953! - apply - - self - lookForMethodsReferencingOldVariable; - changeInstanceVariableName; - renameReferencesToOldVariable. - - ^renamedReferences - ! ! -!RenameInstanceVariable class methodsFor: 'instance creation' stamp: 'HAW 10/9/2019 09:13:37' prior: 50441004! - from: anOldvariable to: aNewVariable in: aClassToRefactor - - | trimmedNewVariable | - - trimmedNewVariable := aNewVariable withBlanksTrimmed. - self assert: aClassToRefactor defines: anOldvariable. - NewInstanceVariablePrecondition valueOf: trimmedNewVariable for: aClassToRefactor. - - ^self new initializeFrom: anOldvariable to: trimmedNewVariable in: aClassToRefactor ! ! -!RenameInstanceVariableApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 10/9/2019 09:21:29' prior: 50442207! - requestRefactoringParameters - - self - chooseInstanceVariable; - askNewVariableName! ! -!RenameInstanceVariableApplier methodsFor: 'refactoring - changes' stamp: 'HAW 10/8/2019 16:55:08' prior: 50442227! - informChangesToBrowser - - browser instanceVariableRenamed ! ! -!RenameInstanceVariableApplier methodsFor: 'refactoring - changes' stamp: 'HAW 10/8/2019 16:55:44' prior: 50442247! - showChanges - - self informChangesToBrowser! ! -!RenameInstanceVariableApplier class methodsFor: 'instance creation' stamp: 'HAW 10/8/2019 17:02:16' prior: 50442270! - on: aBrowser for: anInstanceVariableName at: aClassToRefactor - - ^self new initializeOn: aBrowser for: anInstanceVariableName at: aClassToRefactor ! ! - -RenameInstanceVariableApplier removeSelector: #applyRefactoring! - -RenameInstanceVariableApplier removeSelector: #isOnDebugger! - -RenameInstanceVariableApplier removeSelector: #openChangedMethods! - -RenameInstanceVariableApplier removeSelector: #openChangedMethods! - -RenameInstanceVariableApplier removeSelector: #openChangedMethodsWhenChangesNotEmpty! - -RenameInstanceVariableApplier removeSelector: #openChangedMethodsWhenChangesNotEmpty! - -RenameInstanceVariableApplier removeSelector: #value! - -RenameInstanceVariableApplier removeSelector: #warnIfOnDebugger! - -RenameInstanceVariable removeSelector: #addNewInstanceVariable! - -RenameInstanceVariable removeSelector: #addNewInstanceVariable! - -RenameInstanceVariable removeSelector: #classToRefactor! - -RenameInstanceVariable removeSelector: #classToRefactor! - -RenameInstanceVariable removeSelector: #copyOldInstanceVariableToNewOne! - -RenameInstanceVariable removeSelector: #copyOldInstanceVariableToNewOne! - -RenameInstanceVariable removeSelector: #initializeFrom:addingWith:! - -RenameInstanceVariable removeSelector: #initializeFrom:addingWith:! - -RenameInstanceVariable removeSelector: #newVariable! - -RenameInstanceVariable removeSelector: #newVariable! - -RenameInstanceVariable removeSelector: #removeOldInstanceVariable! - -RenameInstanceVariable removeSelector: #removeOldInstanceVariable! - -RenameInstanceVariable removeSelector: #renameReferencesToOldVariableInClass:! - -RenameInstanceVariable removeSelector: #renameReferencesToOldVariableInClass:! - -ClassDefinitionNodeAnalyzer class removeSelector: #instanceVariableNamesPosition! - -ClassDefinitionNodeAnalyzer class removeSelector: #instanceVariableNamesPosition! - -ClassDefinitionNodeAnalyzer removeSelector: #isMetaclassDefinition! - -Refactoring subclass: #RenameInstanceVariable - instanceVariableNames: 'oldVariable renamedReferences methodsAndRangesToChange newVariable classToRefactor' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameInstanceVariable category: #'Tools-Refactoring'! -Refactoring subclass: #RenameInstanceVariable - instanceVariableNames: 'oldVariable renamedReferences methodsAndRangesToChange newVariable classToRefactor' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3911-RenameInstanceVariableRefactoring-HernanWilkinson-2019Oct07-14h29m-HAW.2.cs.st----! - -'From Cuis 5.0 [latest update: #3911] on 10 October 2019 at 9:24:43 am'! -!TextEditor methodsFor: 'new selection' stamp: 'jmv 10/10/2019 09:22:28' prior: 50473981! - messageSendsRanges: aRanges - "aRanges must be notEmpty" - | lastRange | - - selectionStartBlocks := OrderedCollection new. - selectionStopBlocks := OrderedCollection new. - lastRange := nil. - - aRanges do: [ :range | - selectionStartBlocks add: (textComposition characterBlockForIndex: range first). - selectionStopBlocks add: (textComposition characterBlockForIndex: range last + 1). - ( lastRange isNil or: [ range first > lastRange first ]) ifTrue: [ - lastRange _ range ]]. - self selectFrom: lastRange first to: lastRange last! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3912-messageSendsRanges-mightBeASet-JuanVuletich-2019Oct10-09h22m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3912] on 10 October 2019 at 10:19:48 am'! - -Error subclass: #RecompilationFailure - instanceVariableNames: 'class selector ' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #RecompilationFailure category: #'Exceptions Kernel'! -Error subclass: #RecompilationFailure - instanceVariableNames: 'class selector' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! -!RecompilationFailure methodsFor: 'private' stamp: 'HAW 10/10/2019 10:09:03'! - class: aClass messageText: aString - class _ aClass. - messageText _ aString! ! -!RecompilationFailure class methodsFor: 'instance creation' stamp: 'HAW 10/10/2019 10:09:30'! - class: aClass messageText: aString - ^ self new class: aClass messageText: aString! ! -!Encoder methodsFor: 'private' stamp: 'HAW 10/10/2019 10:15:32' prior: 50444237! - warnAboutShadowed: name - - | msg | - - msg _ 'There already exists a variable named ', name, ' '. - requestor addWarning: msg. - Transcript newLine; show: msg. - InMidstOfFileinNotification signal - ifFalse: [ - requestor interactive - ifTrue: [ - self notify: msg] - ifFalse: [ - (RecompilationFailure - class: class - messageText: msg, String newLineString, 'Please use a different name') signal ]]! ! - -RecompilationFailure class removeSelector: #class:selector:messageText:! - -RecompilationFailure class removeSelector: #class:selector:messageText:! - -RecompilationFailure removeSelector: #class:selector:messageText:! - -RecompilationFailure removeSelector: #class:selector:messageText:! - -RecompilationFailure removeSelector: #messageText! - -RecompilationFailure removeSelector: #messageText! - -Error subclass: #RecompilationFailure - instanceVariableNames: 'class' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #RecompilationFailure category: #'Exceptions Kernel'! -Error subclass: #RecompilationFailure - instanceVariableNames: 'class' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3913-RecompilationFailureRemovedSelector-HernanWilkinson-2019Oct10-10h05m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3913] on 11 October 2019 at 10:12:30 pm'! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'eem 8/28/2009 14:52'! - voidCogVMState - "Void any internal caches the VM maintains other than the method lookup caches. - These comprise - - the stack zone, where method activations are stored, and - - the machine code zone, where the machine code form of CompiledMethods is held." - - ^self primitiveFailed - - "Time millisecondsToRun: [Smalltalk voidCogVMState]" - "(1 to: 10) collect: [:ign| Time millisecondsToRun: [Smalltalk voidCogVMState]]"! ! -!SystemDictionary methodsFor: 'vm parameters' stamp: 'jmv 10/11/2019 22:09:36'! - doMixedArithmetic - "If true, then primitives can handle the conversions: - SmallInteger arithmeticOp: Float (Small or Boxed) - SmallInteger compareOp: Float (Small or Boxed) - Else, the primitive fail in case of mixed arithmetic, and conversion will be performed at image side. - See doMixedArithmetic: - - Note: - OpenSmalltalk VMs after March, 2019 can set the option and will honor it. The comparison operation behaves as if the Float was converted #asTrueFraction. This means that some rather big SmallIntegers in 64 bit systems, that can not be represented exactly as a Float will not be equal to any Float. Squeak adopted this critera. Cuis follows the more conventional, Smalltalk-80 tradition to always convert to Float if any operand is Float. Therefore Cuis needs to do 'Smalltalk doMixedArithmetic: false'. - Previous VMs can not set the option, and will answer true when queried. But these VMs did the conversion to Float, and the requested operation in Floats. So, with these VMs, Cuis will also have the desired behavior." - - ^ ((Smalltalk vmParameterAt: 48) allMask: 64) not! ! -!SystemDictionary methodsFor: 'vm parameters' stamp: 'jmv 10/11/2019 22:10:11'! - doMixedArithmetic: aBoolean - "If set to true, then primitives can handle the conversions: - SmallInteger arithmeticOp: Float (Small or Boxed) - SmallInteger compareOp: Float (Small or Boxed) - Else, the primitive fail in case of mixed arithmetic, and conversion will be performed at image side. - - Please see comment at #doMixedArithmetic" - - "Ignore request if VM doesn't support it" - [ - self vmParameterAt: 48 put: ((self vmParameterAt: 48) bitClear: 64) + (aBoolean ifTrue: [0] ifFalse: [64]). - ] on: Error do: [].! ! -!SystemDictionary methodsFor: 'startup' stamp: 'jmv 10/11/2019 22:11:55' prior: 50470927! -doStartUp: isARealStartup - " - isARealStartup - true: system is coming up (VM and image just started) - false: we have just saved an image snapshot, but didn't quit. - " - "Here, startup begins!!" - Cursor defaultCursor activateCursor. - self setGCParameters. - isARealStartup ifTrue: [ self clearExternalObjects ]. - - "We need to do this on startup because we can not know if the image was saved with a pre March2019 VM, - and started with a later VM that handles the option. - Please see comment at #doMixedArithmetic" - self doMixedArithmetic: false. - - self readCommandLineArguments. - self processStartUpList: isARealStartup. - isARealStartup ifTrue: [ - self setPlatformPreferences. - self setStartupStamp ].! ! -!SystemDictionary methodsFor: 'vm parameters' stamp: 'jmv 10/11/2019 19:12:58' prior: 16921183! - vmParameterAt: parameterIndex - "parameterIndex is a positive integer corresponding to one of the VM's internal parameter/metric registers. - Answer with the current value of that register. - Answer nil if the VM doesn't provide the register, and the primitive fails. - - Also see #getVMParameters and #vmParameterAt:put: These 3 methods call the - same primitive, whose behavior depends on argument count: - 0 args: return an Array of VM parameter values; - 1 arg: return the indicated VM parameter; - 2 args: set the VM indicated parameter. - - VM parameters are numbered as follows: - 1 end (v3) / size(Spur) of old-space (0-based, read-only) - 2 end of young-space (v3) / size of new-space (Spur) (read-only) - 3 end (v3) / size(Spur) of heap (read-only) - 4 nil (was allocationCount (read-only)) - 5 nil (was allocations between GCs (read-write) - 6 survivor count tenuring threshold (read-write) - 7 full GCs since startup (read-only) - 8 total milliseconds in full GCs since startup (read-only) - 9 incremental GCs (v3) / scavenges (Spur) since startup (read-only) - 10 total milliseconds in incremental GCs (v3) / scavenges (Spur) since startup (read-only) - 11 tenures of surving objects since startup or reset (read-write) - 12-20 were specific to ikp's JITTER VM, now 12-15 are open for use - 16 total microseconds at idle since start-up (if non-zero) - 17 fraction of the code zone to use (Sista only; used to control code zone use to preserve sendAndBranchData on counter tripped callback) - 18 total milliseconds in compaction phase of full GC since start-up (Spur only) - 19 scavenge threshold, the effective size of eden. When eden fills to the threshold a scavenge is scheduled. Newer Spur VMs only. - 20 utc microseconds at VM start-up (actually at time initialization, which precedes image load). - 21 root/remembered table size (occupancy) (read-only) - 22 root table overflows since startup (read-only) - 23 bytes of extra memory to reserve for VM buffers, plugins, etc (stored in image file header). - 24 memory threshold above which shrinking object memory (rw) - 25 memory headroom when growing object memory (rw) - 26 interruptChecksEveryNms - force an ioProcessEvents every N milliseconds (rw) - 27 number of times mark loop iterated for current IGC/FGC (read-only) includes ALL marking - 28 number of times sweep loop iterated for current IGC/FGC (read-only) - 29 number of times make forward loop iterated for current IGC/FGC (read-only) - 30 number of times compact move loop iterated for current IGC/FGC (read-only) - 31 number of grow memory requests (read-only) - 32 number of shrink memory requests (read-only) - 33 number of root table entries used for current IGC/FGC (read-only) - 34 Spur: bytes allocated in total since start-up or reset (read-write) (Used to be number of allocations done before current IGC/FGC (read-only)) - 35 number of survivor objects after current IGC/FGC (read-only) - 36 millisecond clock when current IGC/FGC completed (read-only) - 37 number of marked objects for Roots of the world, not including Root Table entries for current IGC/FGC (read-only) - 38 milliseconds taken by current IGC (read-only) - 39 Number of finalization signals for Weak Objects pending when current IGC/FGC completed (read-only) - 40 BytesPerOop for this image - 41 imageFormatVersion for the VM - 42 number of stack pages in use - 43 desired number of stack pages (stored in image file header, max 65535) - 44 size of eden, in bytes - 45 desired size of eden, in bytes (stored in image file header) - 46 machine code zone size, in bytes (Cog only; otherwise nil) - 47 desired machine code zone size (stored in image file header; Cog only; otherwise nil) - 48 various header flags. - Bit 0: tells the VM that the image's Process class has threadId as its 5th inst var (after nextLink, suspendedContext, priority & myList) - Bit 1: on Cog JIT VMs asks the VM to set the flag bit in interpreted methods - Bit 2: if set, preempting a process puts it to the head of its run queue, not the back, - i.e. preempting a process by a higher priority one will not cause the preempted process to yield - to others at the same priority. - Bit 3: in a muilt-threaded VM, if set, the Window system will only be accessed from the first VM thread - Bit 4: in a Spur vm, if set, causes weaklings and ephemerons to be queued individually for finalization - Bit 5: (on VMs that support it) if set, implies wheel events will be delivered as such and not mapped to arrow key events - Bit 6: (on VMs that support it) whether the arithmetic primitives perform conversion in case of mixed SmallInteger/Float (not set) or fail (set) - (on VMs that don't support it, those primitives will fail in those cases) - 49 max size the image promises to grow the external semaphore table to (0 sets to default, which is 256 as of writing) - 50-51 nil; reserved for VM parameters that persist in the image (such as eden above) - 52 root/remembered table capacity - 53 number of segments (Spur only; otherwise nil) - 54 total size of free old space (Spur only, otherwise nil) - 55 ratio of growth and image size at or above which a GC will be performed post scavenge - 56 number of process switches since startup (read-only) - 57 number of ioProcessEvents calls since startup (read-only) - 58 number of ForceInterruptCheck calls since startup (read-only) - 59 number of check event calls since startup (read-only) - 60 number of stack page overflows since startup (read-only) - 61 number of stack page divorces since startup (read-only) - 62 compiled code compactions since startup (read-only; Cog only; otherwise nil) - 63 total milliseconds in compiled code compactions since startup (read-only; Cog only; otherwise nil) - 64 the number of methods that currently have jitted machine-code - 65 whether the VM supports a certain feature, MULTIPLE_BYTECODE_SETS is bit 0, IMMUTABILITY is bit 1 - 66 the byte size of a stack page - 67 the max allowed size of old space (Spur only; nil otherwise; 0 implies no limit except that of the underlying platform) - 68 the average number of live stack pages when scanned by GC (at scavenge/gc/become et al) (read-write) - 69 the maximum number of live stack pages when scanned by GC (at scavenge/gc/become et al) (read-write) - 70 the vmProxyMajorVersion (the interpreterProxy VM_MAJOR_VERSION) - 71 the vmProxyMinorVersion (the interpreterProxy VM_MINOR_VERSION) - 72 total milliseconds in full GCs Mark phase since startup (read-only) - 73 total milliseconds in full GCs Sweep phase since startup (read-only, can be 0 depending on compactors) - 74 maximum pause time due to segment allocation" - - - ^nil! ! -!SystemDictionary methodsFor: 'vm parameters' stamp: 'jmv 10/11/2019 19:12:16' prior: 16921316! - vmParameterAt: parameterIndex put: newValue - "parameterIndex is a positive integer corresponding to one of the VM's internal - parameter/metric registers. Store newValue (a positive integer) into that - register and answer with the previous value that was stored there. - Fail if newValue is out of range, if parameterIndex has no corresponding - register, or if the corresponding register is read-only. - - As of mid 2017 the parameters which can be set are - 5 allocations between GCs (read-write; nil in Cog VMs) - 6 survivor count tenuring threshold (read-write) - 17 proportion of code zone available for use (Sista VMs only) - 23 bytes of extra memory to reserve for VM buffers, plugins, etc. - 24 memory threshold above whichto shrink object memory (read-write) - 25 memory headroom when growing object memory (read-write) - 26 interruptChecksEveryNms - force an ioProcessEvents every N milliseconds (read-write) - 34 bytes allocated in total since start-up or reset (read-write) - 43 desired number of stack pages (stored in image file header, max 65535; Cog VMs only, otherwise nil) - 45 desired size of eden, in bytes (stored in image file header; Cog VMs only, otherwise nil) - 47 desired size of machine code zone, in bytes (applies at startup only, stored in image file header; Cog JIT VM only) - 48 various properties of the Cog VM as an integer encoding an array of bit flags. - Bit 0: tells the VM that the image's Process class has threadId as its 5th inst var (after nextLink, suspendedContext, priority & myList) - Bit 1: on Cog JIT VMs asks the VM to set the flag bit in interpreted methods - Bit 2: if set, preempting a process puts it to the head of its run queue, not the back, - i.e. preempting a process by a higher priority one will not cause the preempted process to yield - to others at the same priority. - Bit 3: in a muilt-threaded VM, if set, the Window system will only be accessed from the first VM thread - Bit 4: in a Spur vm, if set, causes weaklings and ephemerons to be queued individually for finalization - Bit 5: (on VMs that support it) if set, implies wheel events will be delivered as such and not mapped to arrow key events - Bit 6: (on VMs that support it) whether the arithmetic primitives perform conversion in case of mixed SmallInteger/Float (not set) or fail (set) - (on VMs that don't support it, those primitives will fail in those cases) - 49 the size of the external semaphore table (read-write; Cog VMs only) - 55 ratio of growth and image size at or above which a GC will be performed post scavenge (Spur only, otherwise nil) - 67 the maximum allowed size of old space in bytes, 0 implies no internal limit (Spur only)." - - - self primitiveFailed! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Smalltalk doMixedArithmetic: false.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3914-SetMixedArithmeticVMOption-JuanVuletich-2019Oct11-22h00m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3914] on 12 October 2019 at 11:35:42 am'! -!Integer methodsFor: 'testing' stamp: 'a s + sqr 10/11/2019 23:51:08' prior: 16860216! - isPrime - - self < 3 ifTrue: [^self = 2]. - self even ifTrue: [^false]. - self \\ 3 = 0 ifTrue: [^self = 3]. - self \\ 5 = 0 ifTrue: [^self = 5]. - self < 8281 ifTrue: [ - "Approximate sqrtFloor to avoid computational expense" - self \\ 7 = 0 ifTrue: [^self = 7]. - self \\ 11 = 0 ifTrue: [^self = 11]. - self \\ 13 = 0 ifTrue: [^self = 13]. - 12 to: (self bitShift: -6) + 11 by: 6 do: [:each | - self \\ (each+5) = 0 ifTrue: [^false]. - self \\ (each+7) = 0 ifTrue: [^false] - ]. - ^true - ]. - "Now 2, 3 and 5 do not divide self. So, self is of the form - 30*k + {1, 7, 11, 13, 17, 19, 23, 29} for integer k >= 0. - The 31 case below is the 30k+1 case, excluding k = 0" - 0 to: self sqrtFloor by: 30 do: [:each | - self \\ (each+7) = 0 ifTrue: [^false]. - self \\ (each+11) = 0 ifTrue: [^false]. - self \\ (each+13) = 0 ifTrue: [^false]. - self \\ (each+17) = 0 ifTrue: [^false]. - self \\ (each+19) = 0 ifTrue: [^false]. - self \\ (each+23) = 0 ifTrue: [^false]. - self \\ (each+29) = 0 ifTrue: [^false]. - self \\ (each+31) = 0 ifTrue: [^false] - ]. - ^true! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3915-isPrime-performanceImprovements-AgustinSansone-AndresValloud-2019Oct12-11h34m-sqr.1.cs.st----! - -'From Cuis 5.0 [latest update: #3913] on 11 October 2019 at 12:35:03 pm'! -!FeatureRequirement methodsFor: 'requires' stamp: 'jmv 10/11/2019 12:34:45'! - requireUnlessIn: toLoad main: mainFeatureOrNil requiringFeature: requiringFeatureOrNil - "See if all the requirements can be met and answer the load order" - - self isAlreadySatisfied ifFalse: [ - (toLoad anySatisfy: [ :featReq | featReq sameNameAs: self]) ifFalse: [ - (self findPackageFileAsReqOf: mainFeatureOrNil) - ifTrue: [ | otherRequirements | - otherRequirements := self requirements. - otherRequirements ifNotNil: [ - otherRequirements do: [ :requires | - requires requireUnlessIn: toLoad main: (mainFeatureOrNil ifNil: [self]) requiringFeature: self ]]. - self == mainFeatureOrNil ifFalse: [ - self addToLoad: toLoad withMyRequirements: otherRequirements ]. - ] - ifFalse: [ | failureMessage | - failureMessage := 'Could not find package supplying: ', self printString, String newLineString, - 'Required by: ', (requiringFeatureOrNil ifNil: [ self ]) printString, String newLineString, - 'For installing: ', (mainFeatureOrNil ifNil: [ self ]) printString, String newLineString. - FeatureRequirementUnsatisfied signal: failureMessage. - ]]]. - - ^ toLoad! ! -!PackageRequirementsList methodsFor: 'accessing' stamp: 'jmv 10/11/2019 12:16:09' prior: 50432021! - updateSelectedRequirement - - | selectedPackage requiredPackage featureSpec requirementToUpdate updatedRequirement newRequires selectedName | - self selectionIndex ifNil: [ ^self ]. - self selectionIndex isZero ifTrue: [ ^self ]. - ((codePackageList selectionIndex isNil) or: [ codePackageList selectionIndex isZero ]) - ifTrue: [ ^self ]. - - selectedPackage := codePackageList selection. - featureSpec := selectedPackage featureSpec. - requirementToUpdate := self selection. - updatedRequirement := (selectedName _ requirementToUpdate name) = Feature baseSystemFeature name - ifTrue: [ Feature baseSystemFeature requirementOfMe ] - ifFalse: [ - requiredPackage := CodePackage installedPackages at: selectedName. - requiredPackage hasUnsavedChanges - ifTrue: [ self notify: 'Please save package ', requiredPackage packageName, ' first. Requirement version of an unsaved package can not be updated.'. ^self ]. - requiredPackage requirementOfMe ]. - newRequires := (featureSpec requires copyWithout: requirementToUpdate) copyWith: updatedRequirement. - featureSpec - provides: featureSpec provides - requires: newRequires. - selectedPackage hasUnsavedChanges: true. - requirements := codePackageList selection requires asArray. - self changed: #requirements - - - ! ! -!FeatureRequirement methodsFor: 'requires' stamp: 'jmv 10/11/2019 12:25:39' prior: 50475394! - require - "See if all the transitive closure of requirements can be met and answer the load order if so" - - | packagesToLoad | - - "Preflight before load - [1] Build transitive closure as load order where Feature comes - before its required features." - [packagesToLoad _ self requireUnlessIn: OrderedCollection new main: nil requiringFeature: nil] - on: FeatureRequirementUnsatisfied - do: [ :error | error defaultAction. - ^self "exit" - ]. - - "Transcript show: 'packagesToLoad: '; newLine. - packagesToLoad do: [ :x |Transcript show: x; newLine ]. - Transcript newLine." - - "[2] Check to see that each requirement is actually satisfied" - [packagesToLoad do: [ :fReq | fReq checkRequirement ]] - on: FeatureRequirementUnsatisfied - do: [ :error | error defaultAction. - ^self "exit" - ]. - - "[3] Load required packages before packages that require them" - packagesToLoad reverseDo: [ :requirement | - requirement isAlreadySatisfied ifFalse: [ - requirement install ]]. - self isAlreadySatisfied ifFalse: [ - self install ]! ! -!FeatureRequirement methodsFor: 'requires' stamp: 'jmv 10/11/2019 12:26:13' prior: 50475896! - satisfyRequirementsAndInstall - "Like #require, but install me even if already satisified (i.e. installed)" - - | packagesToLoad | - - "Preflight before load" - [packagesToLoad _ self requireUnlessIn: OrderedCollection new main: self requiringFeature: self] - on: FeatureRequirementUnsatisfied - do: [ :error | error defaultAction. - ^self "exit" - ]. - - "Check to see that each requirement is actually satisfied" - [packagesToLoad do: [ :fReq | fReq checkRequirement ]] - on: FeatureRequirementUnsatisfied - do: [ :error | error defaultAction. - ^self "exit" - ]. - - "All requirements are satisfied; do the deed" - packagesToLoad reverseDo: [ :requirement | - requirement isAlreadySatisfied ifFalse: [ - requirement install ]]. - self install! ! - -FeatureRequirement removeSelector: #requireUnlessIn:main:! - -FeatureRequirement removeSelector: #requireUnlessIn:main:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3916-FeatureRequirement-enh-JuanVuletich-2019Oct11-12h02m-jmv.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3812] on 26 June 2019 at 2:14:05 pm'! -!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'jmv 6/26/2019 14:12:51'! - title: argString at: argPoint from: argMinVal to: argMaxVal workBlock: argWorkBlock - - progressTitle _ argString. - aPoint _ argPoint. - minVal _ argMinVal. - maxVal _ argMaxVal. - currentVal _ minVal. - workBlock _ argWorkBlock.! ! -!ProgressInitiationException methodsFor: 'instance migration protection' stamp: 'jmv 6/26/2019 14:03:36'! - aPoint - ^aPoint! ! -!ProgressInitiationException methodsFor: 'instance migration protection' stamp: 'jmv 6/26/2019 14:04:37'! - currentVal - ^currentVal! ! -!ProgressInitiationException methodsFor: 'instance migration protection' stamp: 'jmv 6/26/2019 14:05:16'! - currentVal: val - currentVal _ val! ! -!ProgressInitiationException methodsFor: 'instance migration protection' stamp: 'jmv 6/26/2019 14:03:51'! - maxVal - ^maxVal! ! -!ProgressInitiationException methodsFor: 'instance migration protection' stamp: 'jmv 6/26/2019 14:03:57'! - minVal - ^minVal! ! -!ProgressInitiationException methodsFor: 'instance migration protection' stamp: 'jmv 6/26/2019 14:02:59'! - progressTitle - ^progressTitle! ! -!ProgressInitiationException methodsFor: 'instance migration protection' stamp: 'jmv 6/26/2019 14:04:22'! - workBlock - ^workBlock! ! -!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'jmv 6/26/2019 14:06:27' prior: 50472393! - defaultAction - - | delta textFrame barFrame outerFrame result range width filledWidth f h textWidth textForm innerBarFrame oldFilledWidth oldFilledWidth2 prevContents | - f _ AbstractFont default. - h _ f lineSpacing * 3//2. - textWidth _ (f widthOfString: self progressTitle) + h. - width _ 150 max: textWidth. - - textForm _ Form extent: width@h depth: 32. - textForm fillBlack. - textForm fillWhite: (textForm boundingBox insetBy: 2). - self progressTitle displayOn: textForm at: (width-textWidth+h//2@4). - barFrame _ Rectangle center: self aPoint extent: width@h. - textFrame _ `0@0` extent: width@h. - textFrame _ textFrame - aligned: textFrame bottomCenter - with: barFrame topCenter + `0@2`. - outerFrame _ barFrame merge: textFrame. - delta _ outerFrame amountToTranslateWithin: Display boundingBox. - barFrame _ barFrame translatedBy: delta. - textFrame _ textFrame translatedBy: delta. - outerFrame _ outerFrame translatedBy: delta. - prevContents _ Form fromDisplay: outerFrame. - range _ self maxVal = self minVal ifTrue: [1] ifFalse: [self maxVal - self minVal]. "Avoid div by 0" - innerBarFrame _ barFrame insetBy: 2. - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - oldFilledWidth _ 0. - oldFilledWidth2 _ 0. - result _ self workBlock value: "Supply the bar-update block for evaluation in the work block" - [ :barVal | - barVal - ifNotNil: [ self currentVal: barVal ] - ifNil: [ - self currentVal: self currentVal + 1. - self currentVal >= self maxVal - ifTrue: [ self currentVal: self minVal ]]. - filledWidth _ ((barFrame width-4) asFloat * ((self currentVal - self minVal) asFloat / range min: 1.0)) asInteger. - filledWidth > oldFilledWidth ifTrue: [ - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - Display fillGray: (barFrame topLeft + `2@2` extent: filledWidth@(h-4)). - filledWidth -200 > oldFilledWidth2 - ifFalse: [ - "Usually just request an update, to be done asynchronously." - DisplayScreen screenUpdateRequired: outerFrame ] - ifTrue: [ - "Once in a while, force a real screen update (warning: really slow on MacOS if done too often)" - Display forceToScreen: outerFrame. oldFilledWidth2 _ filledWidth ]. - oldFilledWidth _ filledWidth ]]. - prevContents displayAt: outerFrame topLeft. - self resume: result! ! -!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'jmv 6/26/2019 14:13:40' prior: 16896146! - display: argString at: argPoint from: argMinVal to: argMaxVal during: argWorkBlock - - self title: argString at: argPoint from: argMinVal to: argMaxVal workBlock: argWorkBlock. - ^self signal! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3917-EnableProgress-JuanVuletich-2019Jun26-14h12m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3813] on 26 June 2019 at 2:22:04 pm'! - -Object subclass: #Exception - instanceVariableNames: 'messageText tag signalContext handlerContexts outerContext handlerBlockNotCurtailed ' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #Exception category: #'Exceptions Kernel'! -Object subclass: #Exception - instanceVariableNames: 'messageText tag signalContext handlerContexts outerContext handlerBlockNotCurtailed' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! -!Exception methodsFor: 'handling' stamp: 'sqr 6/26/2019 11:19:08' prior: 16840031! - outer - "Evaluate the enclosing exception action and return to here instead of signal if it resumes (see #resumeUnchecked:)." - - | prevOuterContext | - handlerBlockNotCurtailed _ true. - self isResumable ifTrue: [ - prevOuterContext _ outerContext. - outerContext _ thisContext contextTag. - ]. - self topHandlerContext nextHandlerContext handleSignal: self! ! -!Exception methodsFor: 'handling' stamp: 'sqr 6/26/2019 11:19:23' prior: 16840044! - pass - "Yield control to the enclosing exception action for the receiver." - - | nextHandler | - handlerBlockNotCurtailed _ true. - nextHandler := self topHandlerContext nextHandlerContext. - self popHandlerContext. - nextHandler handleSignal: self! ! -!Exception methodsFor: 'handling' stamp: 'sqr 6/26/2019 11:19:27' prior: 16840053! - resignalAs: replacementException - "Signal an alternative exception in place of the receiver." - - handlerBlockNotCurtailed _ true. - signalContext resumeEvaluating: [replacementException signal]! ! -!Exception methodsFor: 'handling' stamp: 'sqr 6/26/2019 11:23:41' prior: 16840067! - resume: resumptionValue - "Return resumptionValue as the value of the signal message." - - handlerBlockNotCurtailed _ true. - self isResumable ifFalse: [IllegalResumeAttempt signal]. - self resumeUnchecked: resumptionValue! ! -!Exception methodsFor: 'handling' stamp: 'sqr 6/26/2019 11:20:01' prior: 16840075! - resumeUnchecked: resumptionValue - "Return resumptionValue as the value of #signal, unless this was called after an #outer message, then return resumptionValue as the value of #outer." - - | ctxt | - handlerBlockNotCurtailed _ true. - outerContext ifNil: [ - signalContext return: resumptionValue - ] ifNotNil: [ - ctxt _ outerContext. - outerContext _ ctxt tempAt: 1. "prevOuterContext in #outer" - ctxt return: resumptionValue - ]. -! ! -!Exception methodsFor: 'handling' stamp: 'sqr 6/26/2019 11:20:09' prior: 16840090! - retry - "Abort an exception handler and re-evaluate its protected block." - - handlerBlockNotCurtailed _ true. - self topHandlerContext restart! ! -!Exception methodsFor: 'handling' stamp: 'sqr 6/26/2019 11:20:14' prior: 16840096! - retryUsing: alternativeBlock - "Abort an exception handler and evaluate a new block in place of the handler's protected block." - - handlerBlockNotCurtailed _ true. - self topHandlerContext restartWithNewReceiver: alternativeBlock -! ! -!Exception methodsFor: 'handling' stamp: 'sqr 6/26/2019 11:18:21' prior: 16840111! - return: returnValue - "Return the argument as the value of the block protected by the active exception handler." - - handlerBlockNotCurtailed _ true. - self topHandlerContext return: returnValue! ! - -Object subclass: #Exception - instanceVariableNames: 'messageText tag signalContext handlerContexts outerContext handlerBlockNotCurtailed' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #Exception category: #'Exceptions Kernel'! -Object subclass: #Exception - instanceVariableNames: 'messageText tag signalContext handlerContexts outerContext handlerBlockNotCurtailed' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3918-ExceptionHandlerBlocksWithoutNonlocalReturns-p1-AndresValloud-2019Jun26-14h21m-sqr.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3813] on 26 June 2019 at 2:23:06 pm'! -!Exception methodsFor: 'priv handling' stamp: 'sqr 6/26/2019 13:07:12'! - evaluateHandlerBlock: aBlock - - | handlerEx | - handlerBlockNotCurtailed := false. - ^[ - | answer | - answer _ [aBlock valueWithPossibleArgument: self] on: Exception do: [:ex | handlerEx _ ex. ex pass]. - handlerBlockNotCurtailed _ true. - answer - ] ifCurtailed: - [ - (handlerBlockNotCurtailed not and: [handlerEx isNil or: [handlerEx handlerBlockNotCurtailed not]]) - ifTrue: [self error: 'Exception handler blocks must not do non local returns'] - ifFalse: [handlerBlockNotCurtailed _ true] - ]! ! -!Exception methodsFor: 'priv handling' stamp: 'sqr 6/26/2019 12:29:35'! - handlerBlockNotCurtailed - - ^handlerBlockNotCurtailed! ! -!ContextPart methodsFor: 'private-exceptions' stamp: 'sqr 6/26/2019 10:30:43' prior: 16824974! - evaluateSignal: exception - "The following primitive is just a marker used to find the evaluation context. - See MethodContext>>#isHandlerOrSignalingContext. " - - - | value | - exception pushHandlerContext: self contextTag. - value := exception evaluateHandlerBlock: self exceptionHandlerBlock. - "return from self if not otherwise directed in handle block" - self return: value! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3919-ExceptionHandlerBlocksWithoutNonlocalReturns-p2-AndresValloud-2019Jun26-14h22m-sqr.1.cs.st----! - -'From Cuis 5.0 [latest update: #3916] on 12 October 2019 at 10:29:16 pm'! -!ProgressInitiationException methodsFor: 'exceptionDescription' stamp: 'jmv 9/5/2019 17:41:17' prior: 50477487! -defaultAction - - | delta textFrame barFrame outerFrame result range width filledWidth f h textWidth textForm innerBarFrame oldFilledWidth oldFilledWidth2 prevContents | - f _ AbstractFont default. - h _ f lineSpacing * 3//2. - textWidth _ (f widthOfString: progressTitle) + h. - width _ 150 max: textWidth. - - textForm _ Form extent: width@h depth: 32. - textForm fillBlack. - textForm fillWhite: (textForm boundingBox insetBy: 2). - progressTitle displayOn: textForm at: (width-textWidth+h//2@4). - barFrame _ Rectangle center: aPoint extent: width@h. - textFrame _ `0@0` extent: width@h. - textFrame _ textFrame - aligned: textFrame bottomCenter - with: barFrame topCenter + `0@2`. - outerFrame _ barFrame merge: textFrame. - delta _ outerFrame amountToTranslateWithin: Display boundingBox. - barFrame _ barFrame translatedBy: delta. - textFrame _ textFrame translatedBy: delta. - outerFrame _ outerFrame translatedBy: delta. - prevContents _ Form fromDisplay: outerFrame. - range _ maxVal = minVal ifTrue: [1] ifFalse: [maxVal - minVal]. "Avoid div by 0" - innerBarFrame _ barFrame insetBy: 2. - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - oldFilledWidth _ 0. - oldFilledWidth2 _ 0. - result _ workBlock value: "Supply the bar-update block for evaluation in the work block" - [ :barVal | - barVal - ifNotNil: [ currentVal _ barVal ] - ifNil: [ - currentVal _ currentVal + 1. - currentVal >= maxVal - ifTrue: [ currentVal _ minVal ]]. - filledWidth _ ((barFrame width-4) asFloat * ((currentVal-minVal) asFloat / range min: 1.0)) asInteger. - filledWidth > oldFilledWidth ifTrue: [ - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - Display fillGray: (barFrame topLeft + `2@2` extent: filledWidth@(h-4)). - filledWidth -200 > oldFilledWidth2 - ifFalse: [ - "Usually just request an update, to be done asynchronously." - DisplayScreen screenUpdateRequired: outerFrame ] - ifTrue: [ - "Once in a while, force a real screen update (warning: really slow on MacOS if done too often)" - Display forceToScreen: outerFrame. oldFilledWidth2 _ filledWidth ]. - oldFilledWidth _ filledWidth ]]. - prevContents displayAt: outerFrame topLeft. - self resume: result! ! -!ProgressInitiationException methodsFor: 'exceptionDescription' stamp: 'jmv 1/30/2009 15:24' prior: 50477565! - display: argString at: argPoint from: argMinVal to: argMaxVal during: argWorkBlock - - progressTitle _ argString. - aPoint _ argPoint. - minVal _ argMinVal. - maxVal _ argMaxVal. - currentVal _ minVal. - workBlock _ argWorkBlock. - ^self signal! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3920-DisableHindrance-JuanVuletich-2019Oct12-22h27m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3815] on 26 June 2019 at 2:34:09 pm'! - -ProgressInitiationException removeSelector: #aPoint! - -ProgressInitiationException removeSelector: #aPoint! - -ProgressInitiationException removeSelector: #currentVal! - -ProgressInitiationException removeSelector: #currentVal! - -ProgressInitiationException removeSelector: #currentVal:! - -ProgressInitiationException removeSelector: #currentVal:! - -ProgressInitiationException removeSelector: #maxVal! - -ProgressInitiationException removeSelector: #maxVal! - -ProgressInitiationException removeSelector: #minVal! - -ProgressInitiationException removeSelector: #minVal! - -ProgressInitiationException removeSelector: #progressTitle! - -ProgressInitiationException removeSelector: #progressTitle! - -ProgressInitiationException removeSelector: #title:at:from:to:workBlock:! - -ProgressInitiationException removeSelector: #title:at:from:to:workBlock:! - -ProgressInitiationException removeSelector: #workBlock! - -ProgressInitiationException removeSelector: #workBlock! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3921-CeaseAndDesist-AndresValloud-2019Jun26-14h31m-sqr.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3817] on 26 June 2019 at 2:47:57 pm'! -!BlockClosure methodsFor: 'testing' stamp: 'sqr 6/26/2019 12:09:30' prior: 50466524! - isCleanClosure - "A clean closure is one that doesn't really need the home context because: - - It doesn't send messages to self or super - - It doesn't access any instance variable - - It doesn't access any outer temp - - It doesn't do ^ return (return from method to caller) - Therefore it doesn't close over a lexical scope, and in this sense they are trivial. - They can also be called 'context free', 'clean' or 'simple block'. - " - - | recreated source | - source _ self decompile decompileString. - - "This catches any acess to outer context!!" - recreated _ [ Compiler evaluate: source. ] on: UndeclaredVariableWarning do: [ :ex | ex return]. - recreated isNil ifTrue: [^false]. - - "Fail if returns from outer context, or uses self" - Smalltalk - eliotsClosureMeasurementsOn: recreated outerContext method - over: [ :closuresCount :hasIndirectTemps :anyClosureHasCopied :anyClosureDoesMethodReturn :anyClosureUsesSelf | - anyClosureDoesMethodReturn ifTrue: [ ^ false ]. - anyClosureUsesSelf ifTrue: [ ^ false ]]. - - "Ok." - ^true! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'sqr 6/26/2019 12:46:01' prior: 50420798! - withSelectorUnderCursorDo: aBlock ifErrorsParsing: aParsingErrorBlock ifNoSelector: aNoSelectorBlock - - | methodNode nodeAtRange nodeUnderCursor | - methodNode := self codeProvider - methodNodeOf: model actualContents - ifErrorsParsing: [ :anError | aParsingErrorBlock valueWithPossibleArgument: anError. anError return ]. - methodNode isNil ifTrue: [^nil]. - - self startIndex < methodNode selectorLastPosition ifTrue: [ ^aBlock value: methodNode selector ]. - nodeAtRange := methodNode parseNodeIncluding: self startIndex ifAbsent: [ ^ aNoSelectorBlock value ]. - nodeUnderCursor := nodeAtRange key. - nodeUnderCursor isMessageNode ifTrue: [ ^aBlock value: nodeAtRange key selector key ]. - (nodeUnderCursor isLiteralNode and: [ nodeUnderCursor literalValue isSymbol ]) ifTrue: [ ^aBlock value: nodeUnderCursor literalValue ]. - - ^ aNoSelectorBlock value ! ! -!TestCase methodsFor: 'assertions' stamp: 'sqr 6/26/2019 11:36:48' prior: 50343632! - should: aBlock raise: anExceptonHandlingCondition - - self should: aBlock raise: anExceptonHandlingCondition withExceptionDo: [ :anException | ] - ! ! -!TestCase methodsFor: 'assertions' stamp: 'sqr 6/26/2019 11:36:34' prior: 50343640! - should: aBlock raise: anExceptonHandlingCondition description: aFailDescription - - self should: aBlock raise: anExceptonHandlingCondition withExceptionDo: [:anException | ] description: aFailDescription! ! -!TestCase methodsFor: 'assertions' stamp: 'sqr 6/26/2019 11:36:39' prior: 50343649! - should: aBlock raise: anExceptonHandlingCondition withExceptionDo: assertionsBlock - - self should: aBlock raise: anExceptonHandlingCondition withExceptionDo: assertionsBlock description: self defaultFailDescription! ! -!TestCase methodsFor: 'assertions' stamp: 'sqr 6/26/2019 11:56:51' prior: 50390667! - should: aBlock raise: anExceptionHandlingCondition withExceptionDo: assertionsBlock description: aFailDescription - - | passed | - passed := [aBlock value. false] - on: anExceptionHandlingCondition - do: [:ex | assertionsBlock value: ex. ex return: true]. - passed ifFalse: [self failWith: aFailDescription]! ! -!TestCase methodsFor: 'assertions' stamp: 'sqr 6/26/2019 11:37:05' prior: 50343670! - shouldnt: aBlock raise: anExceptonHandlingCondition - - self shouldnt: aBlock raise: anExceptonHandlingCondition description: anExceptonHandlingCondition printString, ' was not expected to be raised'! ! -!TestCase methodsFor: 'assertions' stamp: 'sqr 6/26/2019 11:37:10' prior: 50343679! - shouldnt: aBlock raise: anExceptonHandlingCondition description: aFailDescription - - aBlock - on: anExceptonHandlingCondition - do: [ :anException | self failWith: aFailDescription ] -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3922-ExceptionHandlingRefinements-AndresValloud-2019Jun26-14h43m-sqr.1.cs.st----! - -'From Cuis 5.0 [latest update: #3922] on 14 October 2019 at 7:46:20 am'! -!Exception methodsFor: 'priv handling' stamp: 'jmv 10/14/2019 07:43:10' prior: 50477709! - evaluateHandlerBlock: aBlock - - | handlerEx | - handlerBlockNotCurtailed := false. - ^[ - | answer | - answer _ [aBlock valueWithPossibleArgument: self] on: Exception do: [:ex | handlerEx _ ex. ex pass]. - handlerBlockNotCurtailed _ true. - answer - ] ifCurtailed: - [ - (handlerBlockNotCurtailed not and: [handlerEx isNil or: [handlerEx handlerBlockNotCurtailed not]]) - ifTrue: [ - "self error: 'Exception handler blocks must not do non local returns'." - "Please see -https://gator3294.hostgator.com:2096/cpsess8738249540/3rdparty/squirrelmail/src/read_body.php?account=0&mailbox=INBOX&passed_id=116522&startMessage=1 -https://gator3294.hostgator.com:2096/cpsess8738249540/3rdparty/squirrelmail/src/read_body.php?account=0&mailbox=INBOX&passed_id=116533&startMessage=1 - Also see the rest of the tread in detail. - This is work in progress. - Currently (October 14, 2019) system behavior is unaffected, except for the following message to the Transcript. But the necessary code to detect the questionable method returns in exception handlers is kept, to aid in further development. - " - 'It is advisable to avoid method returns (non local returns) in exception handler blocks' print. - ] - ifFalse: [handlerBlockNotCurtailed _ true] - ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3923-TemporarilyDisableRecentExceptionHandlersReturnLimitation-JuanVuletich-2019Oct14-07h35m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3923] on 18 October 2019 at 10:50:50 am'! -!Preferences class methodsFor: 'exception handling' stamp: 'jmv 10/18/2019 10:49:40'! - allowNonLocalReturnsInExceptionHandlers - ^ self - valueOfFlag: #allowNonLocalReturnsInExceptionHandlers - ifAbsent: [ true ].! ! -!Preferences class methodsFor: 'exception handling' stamp: 'jmv 10/18/2019 10:49:45'! - warnAboutNonLocalReturnsInExceptionHandlers - ^ self - valueOfFlag: #warnAboutNonLocalReturnsInExceptionHandlers - ifAbsent: [ true ].! ! -!Exception methodsFor: 'priv handling' stamp: 'jmv 10/18/2019 10:50:17' prior: 50478022! - evaluateHandlerBlock: aBlock - - | handlerEx | - handlerBlockNotCurtailed := false. - ^[ - | answer | - answer _ [aBlock valueWithPossibleArgument: self] on: Exception do: [:ex | handlerEx _ ex. ex pass]. - signalContext := nil. "To enable recycling of exceptions, but only after handler block has finished execution." - handlerBlockNotCurtailed _ true. - answer - ] ifCurtailed: - [ - signalContext := nil. "To enable recycling of exceptions, but only after handler block has finished execution." - (handlerBlockNotCurtailed not and: [handlerEx isNil or: [handlerEx handlerBlockNotCurtailed not]]) - ifTrue: [ - "Please see - https://lists.cuis.st/mailman/archives/cuis-dev/2019-October/000800.html - https://lists.cuis.st/mailman/archives/cuis-dev/2019-October/000809.html - Also see the rest of the tread in detail. - This is work in progress." - Preferences allowNonLocalReturnsInExceptionHandlers - ifFalse: [ self error: 'Exception handler blocks must not do non local returns' ] - ifTrue: [ - Preferences warnAboutNonLocalReturnsInExceptionHandlers - ifTrue: [ 'It is advisable to avoid method returns (non local returns) in exception handler blocks' print ]. - handlerBlockNotCurtailed _ true ]. - ] - ifFalse: [handlerBlockNotCurtailed _ true] - ]! ! -!Exception methodsFor: 'signaling' stamp: 'jmv 10/18/2019 09:50:15' prior: 16840181! - signalIn: aContext - "Ask ContextHandlers in the sender chain to handle this signal. The default is to execute and return my defaultAction." - - signalContext ifNotNil: [self error: 'This exception has already been signaled and its handler block is being executed.']. - signalContext _ aContext contextTag. - ^ aContext nextHandlerContext handleSignal: self! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3924-noReSignalInExceptionHandlers-PreferencesForNonLocalReturns-JuanVuletich-2019Oct18-10h48m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3913] on 18 October 2019 at 6:43:17 pm'! -!RenameInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 10/18/2019 18:39:55'! - logClassDefinition - - Smalltalk - logChange: classToRefactor definition - preamble: classToRefactor definitionPreamble.! ! -!RenameInstanceVariable methodsFor: 'applying' stamp: 'HAW 10/18/2019 18:40:03' prior: 50476597! - apply - - self - lookForMethodsReferencingOldVariable; - changeInstanceVariableName; - logClassDefinition; - renameReferencesToOldVariable. - - ^renamedReferences - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3925-LogRenameInstanceVarClassDefinition-HernanWilkinson-2019Oct18-18h39m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3924] on 23 October 2019 at 8:56:55 am'! -!Object methodsFor: 'error handling' stamp: 'HAW 10/23/2019 08:11:45'! - shouldNotHappen - "Used to announce that something that should not happen by design, happened. - For example: (Array with: 1) at: 1 ifAbsent: [self shouldNotHappen]. - See #shouldNotHappenBecause: also" - - self error: self shouldNotHappenErrorMessage! ! -!Object methodsFor: 'error handling' stamp: 'HAW 10/23/2019 08:12:51'! - shouldNotHappenBecause: aReason - "Used to announce that something that should not happen by design, happened. - For example: (Array with: 1) at: 1 ifAbsent: [self shouldNotHappenBecause: 'The array has one element']. - See #shouldNotHappen also" - - self error: self shouldNotHappenBecauseErrorMessage, aReason! ! -!Object methodsFor: 'error handling' stamp: 'HAW 10/23/2019 08:13:13'! - shouldNotHappenBecauseErrorMessage - - ^self shouldNotHappenErrorMessage, ' because: '! ! -!Object methodsFor: 'error handling' stamp: 'HAW 10/23/2019 08:11:58'! - shouldNotHappenErrorMessage - - ^'Should not happen'! ! -!BlockNode methodsFor: 'code generation (closures)' stamp: 'HAW 10/23/2019 08:15:24' prior: 16789071! - addRemoteTemp: aTempVariableNode rootNode: rootNode "" - "Add aTempVariableNode to my actualScope's sequence of - remote temps. If I am an optimized block then the actual - scope is my actualScopeIfOptimized, otherwise it is myself." - remoteTempNode == nil ifTrue: - [remoteTempNode := RemoteTempVectorNode new - name: self remoteTempNodeName - index: arguments size + temporaries size - type: LdTempType - scope: 0. - actualScopeIfOptimized - ifNil: - [self addTempNode: remoteTempNode. - remoteTempNode definingScope: self] - ifNotNil: [actualScopeIfOptimized addHoistedTemps: { remoteTempNode }]]. - remoteTempNode addRemoteTemp: aTempVariableNode encoder: rootNode encoder. - "use remove:ifAbsent: because the deferred analysis for optimized - loops can result in the temp has already been hoised into the root." - self removeTempNode: aTempVariableNode ifAbsent: [ - self actualScope removeTempNode: aTempVariableNode ifAbsent: [self shouldNotHappen ]]. - ^remoteTempNode! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 10/23/2019 08:14:45' prior: 50460707! - selectorLastPosition - - "If #DoIt selector, returns 0 - Hernan" - - ^self selector isUnary - ifTrue: [ selectorKeywordsRanges ifNil: [ 0 ] ifNotNil: [ selectorKeywordsRanges last last ]] - ifFalse: [ - (encoder - rangeForNode: arguments last - ifAbsent: [ self shouldNotHappenBecause: 'arguments are part of the encoder' ]) first last ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3926-shouldNotHappen-HernanWilkinson-2019Oct23-08h09m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3926] on 23 October 2019 at 11:04:22 am'! -!Preferences class methodsFor: 'user changes' stamp: 'HAW 10/23/2019 11:03:16'! - defaultUserChangesFileName - "Answer the default full path to the changes file corresponding to the image file name." - - ^(FileIOAccessor default baseNameFor: Smalltalk imageName), '.user.changes'! ! -!Preferences class methodsFor: 'user changes' stamp: 'MGD 2/19/2019 10:24:39'! - userChangesFileName - ^ self - valueOfFlag: #userChangesFileName - ifAbsent: [ self defaultUserChangesFileName ].! ! -!SystemDictionary methodsFor: 'image, changes name' stamp: 'MGD 2/19/2019 10:17:37' prior: 50405594! - defaultUserChangesName - "Answer the default full path to the changes file corresponding to the image file name." - " - Smalltalk defaultUserChangesName - " - ^ Preferences userChangesFileName.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3927-UserChangesFileNamePreference-HernanWilkinson-2019Oct23-10h51m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3926] on 23 October 2019 at 11:07:03 am'! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'HAW 10/23/2019 11:06:10' prior: 16923105! - classRemoved: aClass fromCategory: aCategoryName - - aClass acceptsLoggingOfCompilation - ifTrue: [ - self - logChange: aClass definition - preamble: 'classRemoval: ', aClass name printString, ' stamp: ', Utilities changeStamp printString ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3928-ClassRemovedChangeLog-HernanWilkinson-2019Oct23-11h04m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3926] on 23 October 2019 at 11:21:36 am'! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'HAW 10/23/2019 11:20:23' prior: 16923312! - methodRemoved: aMethod selector: aSymbol inProtocol: protocol class: aClass - - aClass acceptsLoggingOfCompilation - ifTrue: [ self - logChange: aMethod sourceCode - preamble: 'methodRemoval: ', aClass printString, '>>#', aSymbol, ' stamp: ', Utilities changeStamp printString ]. ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3929-MethodRemovedChangeLog-HernanWilkinson-2019Oct23-11h07m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3926] on 26 October 2019 at 2:37:20 pm'! - -ChangeListElement subclass: #ClassDeletionChangeRecord - instanceVariableNames: 'className doItOnlyIfInBaseSystem stamp classDefinition ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #ClassDeletionChangeRecord category: #'Tools-Changes'! -ChangeListElement subclass: #ClassDeletionChangeRecord - instanceVariableNames: 'className doItOnlyIfInBaseSystem stamp classDefinition' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -ChangeListElement subclass: #MethodDeletionChangeRecord - instanceVariableNames: 'methodReference doItOnlyIfInBaseSystem sourceCode stamp ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #MethodDeletionChangeRecord category: #'Tools-Changes'! -ChangeListElement subclass: #MethodDeletionChangeRecord - instanceVariableNames: 'methodReference doItOnlyIfInBaseSystem sourceCode stamp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -Object subclass: #ClassChangeRecord - instanceVariableNames: 'inForce changeTypes priorDefinition thisName priorName methodChanges stamp ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #ClassChangeRecord category: #'Tools-Changes'! -Object subclass: #ClassChangeRecord - instanceVariableNames: 'inForce changeTypes priorDefinition thisName priorName methodChanges stamp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -Object subclass: #MethodChangeRecord - instanceVariableNames: 'changeType currentMethod infoFromRemoval stamp ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #MethodChangeRecord category: #'Tools-Changes'! -Object subclass: #MethodChangeRecord - instanceVariableNames: 'changeType currentMethod infoFromRemoval stamp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 11:25:33'! - itemIsRecognized: item - - ^ self knownPreambles anySatisfy: [ :preamble | item includesSubString: preamble ] ! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/23/2019 11:25:05'! - knownPreambles - - ^ `{ - 'commentStamp:'. - 'methodsFor:'. - 'classDefinition:'. - 'classRemoval:'. - 'methodRemoval:'. - 'methodMoveToSomePackage:'. - 'classMoveToSomePackage:'. - 'provides'. - 'requires' }`! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 11:42:13'! - notSeparatorChar - - | prevChar | - - [file atEnd not and: [file peek isSeparator]] whileTrue: [prevChar _ file next]. - - ^prevChar! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/23/2019 11:41:41'! - scanAndIgnore: item in: position - - | record | - - record _ ChangeRecord new - file: file - position: position - type: #preamble. - - self - addItem: record - text: ('preamble: ' , item contractTo: 160) -! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 11:30:10'! - scanClassComment: tokens - - | className stamp record | - - className _ tokens first. - stamp _ tokens third. - record _ ChangeRecord new - file: file - position: file position - type: #classComment - class: className - category: nil - meta: false - stamp: stamp. - - self - addItem: record - text: 'class comment for ' , className, (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp]). - - file nextChunk. -! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 11:32:17'! - scanClassDefinition: tokens - - | classDefinition isMeta itemPosition className record fullClassName | - - itemPosition _ file position. - fullClassName _ tokens second. - isMeta _ fullClassName includesSubString: ' class'. - className _ isMeta ifTrue: [fullClassName substrings first] ifFalse: [fullClassName]. - classDefinition _ file nextChunk. - - record _ ChangeRecord new - file: file - position: itemPosition - type: #classDefinition - class: className asSymbol - category: tokens last - meta: isMeta - stamp: nil. - - self addItem: record text: 'classDefinition: ', classDefinition.! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/25/2019 10:54:48'! - scanClassRemoval: tokens - - | doItOnlyIfInBaseSystem removeType classDefinition className description record stamp | - - removeType _ tokens first. - className _ tokens second. - doItOnlyIfInBaseSystem _ removeType == #classMoveToSomePackage:. - classDefinition _ file nextChunk. - stamp _ tokens last. - - record _ ClassDeletionChangeRecord - className: className - definition: classDefinition - doItOnlyIfInBaseSystem: doItOnlyIfInBaseSystem - stamp: stamp. - - description _ doItOnlyIfInBaseSystem - ifTrue: ['clase move to some package: '] - ifFalse: ['class removal: ']. - - self - addItem: record - text: description, className, '; ', stamp ! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 11:48:24'! - scanDoIt - - | itemPosition command | - - itemPosition _ file position. - command _ file nextChunk. - - command notEmpty ifTrue: [ - self - addItem: (ChangeRecord new file: file position: itemPosition type: #doIt) - text: 'do it: ' , (command contractTo: 160)]! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/23/2019 11:44:09'! - scanFeatureProvision: tokens - - | feature | - - feature _ FeatureChangeRecord new - type: #provides - feature: (Feature name: tokens second version: tokens third revision: tokens fourth). - - self addItem: feature text: feature string! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 11:39:44'! - scanFeatureRequirement: tokens - - | feature requirement | - - requirement _ FeatureRequirement - name: tokens second - minVersion: tokens third - minRevision: tokens fourth - maxVersion: (tokens size > 4 ifTrue: [tokens fifth]). - - feature _ FeatureChangeRecord new - type: #requires - feature: requirement. - - self addItem: feature text: feature string.! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 11:52:16'! - scanMethodDefinition: tokens - - | stamp stampIndex className | - - className _ tokens first. - stamp _ ''. - stampIndex _ tokens indexOf: #stamp: ifAbsent: nil. - stampIndex ifNotNil: [stamp _ tokens at: (stampIndex + 1)]. - - tokens second == #methodsFor: ifTrue: [ - ^ self scanCategory: tokens third class: className meta: false stamp: stamp ]. - - tokens third == #methodsFor: ifTrue: [ - ^ self scanCategory: tokens fourth class: className meta: true stamp: stamp ]. - - self shouldNotHappen -! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/23/2019 23:35:04'! - scanMethodRemoval: tokens - - | doItOnlyIfInBaseSystem removeType isMeta sourceCode methodReference className description record selector stamp | - - removeType _ tokens first. - className _ tokens second. - doItOnlyIfInBaseSystem _ removeType == #methodMoveToSomePackage:. - - sourceCode _ file nextChunk. - isMeta _ tokens third == #class. - selector _ tokens at: tokens size - 2. - stamp _ tokens last. - - methodReference _ MethodReference new - setClassSymbol: className - classIsMeta: isMeta - methodSymbol: selector - stringVersion: className, (isMeta ifTrue: [' class '] ifFalse: [' ']), selector,'; ', stamp. - - record _ MethodDeletionChangeRecord - methodReference: methodReference - doItOnlyIfInBaseSystem: doItOnlyIfInBaseSystem - source: sourceCode - stamp: stamp. - - description _ doItOnlyIfInBaseSystem - ifTrue: ['method move to some package: '] - ifFalse: ['method removal: ']. - - self - addItem: record - text: description, methodReference stringVersion! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 11:45:05'! - scanSpecificChangeRecordTypeIfNotAtEnd: prevChar - - (prevChar notNil and: [ prevChar isLineSeparator ]) ifTrue: [self scanSpecificChangeRecordType]! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 11:51:26'! - scanUpTo: stopPosition informing: barBlock - - [file position < stopPosition] whileTrue: [ | prevChar | - barBlock value: file position. - prevChar _ self notSeparatorChar. - "A line starting with $!! means a specific ChangeRecord type" - (file peekFor: $!!) - ifTrue: [ self scanSpecificChangeRecordTypeIfNotAtEnd: prevChar] - ifFalse: [ self scanDoIt ]]! ! -!Class methodsFor: 'fileIn/Out' stamp: 'HAW 10/24/2019 09:41:50'! - definitionReplacingCategoryWith: aNewCategory - - | definition categoryDefinitionIndex currentCategoryDefinition definitionWithNewCategory | - - definition := self definition. - "category can be nil, that is why I sent asString to it - Hernan" - currentCategoryDefinition := 'category: ''', self category asString, ''''. - categoryDefinitionIndex := definition - indexOfSubCollection: currentCategoryDefinition - startingAt: 1 - ifAbsent: [ self error: 'Definition of category not found!!' ]. - - definitionWithNewCategory := definition first: categoryDefinitionIndex - 1. - definitionWithNewCategory := definitionWithNewCategory, 'category: ''', aNewCategory, ''''. - - ^definitionWithNewCategory ! ! -!MethodReference methodsFor: 'queries' stamp: 'HAW 10/23/2019 20:56:40'! - actualClassIfAbsent: anAbsentBlock - - ^Smalltalk - at: classSymbol - ifPresent: [ :actualClass | - classIsMeta - ifTrue: [ actualClass class ] - ifFalse: [ actualClass ] ] - ifAbsent: anAbsentBlock -! ! -!MethodReference methodsFor: 'queries' stamp: 'HAW 10/23/2019 21:40:47'! - sourceCodeIfAbsent: aBlock - - | actualClass | - - actualClass := self actualClassIfAbsent: [ ^aBlock value ]. - ^actualClass sourceCodeAt: methodSymbol ifAbsent: aBlock! ! -!MethodReference class methodsFor: 'instance creation' stamp: 'HAW 10/23/2019 21:05:22'! - classSymbol: aClassName classIsMeta: isMeta methodSymbol: aSelector - - ^self new setClassSymbol: aClassName classIsMeta: isMeta methodSymbol: aSelector stringVersion: ''.! ! -!MethodReference class methodsFor: 'error description' stamp: 'HAW 10/23/2019 21:38:36'! - classDoesNotExistErrorMessage - - ^'Class does not exist'! ! -!ChangeListElement methodsFor: 'perform' stamp: 'HAW 10/25/2019 10:35:21'! - performOn: aCodeFile - - ^aCodeFile perform: (self changeType copyWith: $:) asSymbol with: self ! ! -!ChangeRecord methodsFor: 'printing' stamp: 'HAW 10/26/2019 11:57:37'! - printOn: aStream - - super printOn: aStream. - aStream - nextPutAll: ' - type: '; - nextPutAll: type ! ! -!ClassDeletionChangeRecord methodsFor: 'accessing' stamp: 'HAW 10/24/2019 08:57:18'! - className: aSymbol - - className _ aSymbol! ! -!ClassDeletionChangeRecord methodsFor: 'initialization' stamp: 'HAW 10/24/2019 08:55:20'! - initializeClassName: aClassName definition: aClassDefinition doItOnlyIfInBaseSystem: aDoItOnlyIfInBaseSystem stamp: aStamp - - className := aClassName. - classDefinition := aClassDefinition. - doItOnlyIfInBaseSystem := aDoItOnlyIfInBaseSystem. - stamp := aStamp.! ! -!ClassDeletionChangeRecord methodsFor: 'services' stamp: 'HAW 10/26/2019 10:38:56'! - command - - ^doItOnlyIfInBaseSystem - ifTrue: [ 'Smalltalk removeClassNamedIfInBaseSystem: #', className ] - ifFalse: [ 'Smalltalk removeClassNamed: #', className ]. -! ! -!ClassDeletionChangeRecord class methodsFor: 'instance creation' stamp: 'HAW 10/24/2019 08:55:05'! - className: aClassName definition: aClassDefinition doItOnlyIfInBaseSystem: aDoItOnlyIfInBaseSystem stamp: aStamp - - ^self new - initializeClassName: aClassName - definition: aClassDefinition - doItOnlyIfInBaseSystem: aDoItOnlyIfInBaseSystem - stamp: aStamp ! ! -!MethodDeletionChangeRecord methodsFor: 'initialization' stamp: 'HAW 10/23/2019 23:35:56'! - initializeMethodReference: aMethodReference doItOnlyIfInBaseSystem: aDoit source: aSourceCode stamp: aStamp - - methodReference := aMethodReference. - doItOnlyIfInBaseSystem := aDoit. - sourceCode := aSourceCode. - stamp := aStamp ! ! -!MethodDeletionChangeRecord methodsFor: 'perform' stamp: 'HAW 10/25/2019 10:37:08'! - performOn: aCodeFile - - ^aCodeFile removedMethod: self command with: self ! ! -!MethodDeletionChangeRecord class methodsFor: 'instance creation' stamp: 'HAW 10/23/2019 23:36:19'! - methodReference: aMethodReference doItOnlyIfInBaseSystem: aDoit source: aSourceCode stamp: aStamp - - ^self new - initializeMethodReference: aMethodReference - doItOnlyIfInBaseSystem: aDoit - source: aSourceCode - stamp: aStamp ! ! -!ChangeSet methodsFor: 'accessing' stamp: 'HAW 10/26/2019 12:27:22'! - movedClassRecords - - ^ changeRecords values select: [ :aChangeRecord | aChangeRecord isClassMoveToOtherPackage ]! ! -!ChangeSet methodsFor: 'accessing' stamp: 'HAW 10/25/2019 10:02:15'! - removedClassRecords - - ^ changeRecords values select: [ :aChangeRecord | aChangeRecord isClassRemoval]! ! -!ChangeSet methodsFor: 'accessing' stamp: 'HAW 10/26/2019 12:27:57'! - sortedClassRecords: classRecords - - ^ classRecords sort: [:left :rigth | left thisName < rigth thisName ]! ! -!ChangeSet methodsFor: 'accessing' stamp: 'HAW 10/26/2019 12:27:57'! - sortedMovedClassesToOtherPackage - - ^ self sortedClassRecords: self movedClassRecords! ! -!ChangeSet methodsFor: 'accessing' stamp: 'HAW 10/26/2019 12:27:57'! - sortedRemovedClassRecords - - ^ self sortedClassRecords: self removedClassRecords! ! -!ChangeSet methodsFor: 'class changes' stamp: 'HAW 10/25/2019 09:51:55'! - noteRemovalOf: class fromCategory: aCategoryName - "The class is about to be removed from the system. - Adjust the receiver to reflect that fact." - - class wantsChangeSetLogging ifFalse: [^ self]. - (self changeRecorderFor: class) noteRemoved: class fromCategory: aCategoryName. - changeRecords removeKey: class class name ifAbsent: nil. - self hasUnsavedChanges: true! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 12:41:49'! - fileOutClassDefinitionsOf: classList on: stream - - classList do: [ :aClass | self fileOutClassDefinition: aClass on: stream ]! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 12:35:49'! - fileOutClassDeletionFrom: aClassChangeRecord doItOnlyIfInBaseSystem: aDoIt on: stream - - | record | - - record := ClassDeletionChangeRecord - className: aClassChangeRecord thisName - definition: aClassChangeRecord priorDefinition - doItOnlyIfInBaseSystem: aDoIt - stamp: aClassChangeRecord stamp. - - record fileOutOn: stream - -! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 12:44:32'! - fileOutClassInitializationsOf: classList on: stream - - ^ classList do: [ :aClass | - self fileOutPSFor: aClass on: stream ]! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 10/23/2019 23:37:18'! - fileOutMethodRemovalOf: selector for: class movedToOtherPackage: moved on: stream stamp: stamp - - | methodReference changeRecord | - - methodReference := MethodReference class: class selector: selector. - - changeRecord := MethodDeletionChangeRecord - methodReference: methodReference - doItOnlyIfInBaseSystem: moved - source: (methodReference sourceCodeIfAbsent: [ 'Missing' ]) - stamp: stamp. - - changeRecord fileOutOn: stream ! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 10/24/2019 08:40:10'! - fileOutMethodRemovalsOf: changeTypes movedToOtherPackage: moved for: class on: stream - "Write out removals and initialization for this class." - - | classRecord methodChanges changeType | - - classRecord _ changeRecords at: class name ifAbsent: [^ self]. - methodChanges _ classRecord methodChanges. - - methodChanges keysAndValuesDo: [:selector :aMethodChange | - changeType _ aMethodChange changeType. - (changeTypes includes: changeType) - ifTrue: [ self - fileOutMethodRemovalOf: selector - for: class - movedToOtherPackage: moved - on: stream - stamp: aMethodChange stamp ]]. -! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 12:41:55'! - fileOutMethodsAdditionsOf: classList on: stream - - classList do: [ :aClass | self fileOutMethodAdditionsFor: aClass on: stream ]! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 12:42:26'! - fileOutMethodsChangesOf: stream on: classList - - ^ classList do: [ :aClass | self fileOutMethodChangesFor: aClass on: stream ]! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 12:36:11'! - fileOutMovedClassRecord: aRemovedClassRecord on: stream - - self fileOutClassDeletionFrom: aRemovedClassRecord doItOnlyIfInBaseSystem: true on: stream -! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 12:45:35'! - fileOutMovedClassesOn: stream - - ^ self sortedMovedClassesToOtherPackage do: [ :aMovedClassRecord | - self fileOutMovedClassRecord: aMovedClassRecord on: stream ]! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 12:43:33'! - fileOutRemovedAndMovedMethodsOf: classList on: stream - - ^ classList reverseDo: [ :aClass | - self fileOutMethodRemovalsFor: aClass on: stream. - self fileOutMethodMovedToOtherPackagesFor: aClass on: stream ]! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 12:35:04'! - fileOutRemovedClassRecord: aRemovedClassRecord on: stream - - self fileOutClassDeletionFrom: aRemovedClassRecord doItOnlyIfInBaseSystem: false on: stream -! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 12:45:13'! - fileOutRemovedClassesOn: stream - - ^ self sortedRemovedClassRecords do: [ :aRemovedClassRecord | - self fileOutRemovedClassRecord: aRemovedClassRecord on: stream ]! ! -!ClassChangeRecord methodsFor: 'all changes' stamp: 'HAW 10/25/2019 10:10:10'! - noteRemoved: class fromCategory: aCategoryName - - priorDefinition := class definitionReplacingCategoryWith: aCategoryName. - self noteChangeType: #remove fromClass: class -! ! -!ClassChangeRecord methodsFor: 'stamp' stamp: 'HAW 10/25/2019 10:19:05'! - stamp - - ^stamp! ! -!MethodChangeRecord methodsFor: 'stamp' stamp: 'HAW 10/23/2019 23:41:48'! - stamp - - ^stamp ! ! -!MethodChangeRecord methodsFor: 'perform' stamp: 'HAW 10/25/2019 10:36:24'! - performOn: aCodeFile - - ^aCodeFile perform: (self changeType copyWith: $:) asSymbol with: self ! ! -!CodeFile methodsFor: 'reading' stamp: 'HAW 10/26/2019 12:51:11'! - buildFrom: changes informingTo: barBlock - - changes withIndexDo: [ :changeRecord :anIndex | - barBlock value: anIndex. - changeRecord performOn: self. - ]. -! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 11:39:00' prior: 50466166! - scanCategory: category class: class meta: meta stamp: stamp - - | itemPosition method | - - [ - itemPosition _ file position. - method _ file nextChunk. - method notEmpty ] whileTrue: [ "done when double terminators" - self - addItem: (ChangeRecord new - file: file - position: itemPosition - type: #method - class: class - category: category - meta: meta - stamp: stamp) - text: 'method: ' , class , (meta ifTrue: [' class '] ifFalse: [' ']) - , (((Smalltalk at: class ifAbsent: [Object class]) parserClass selectorFrom: method) ifNil: ['']) - , (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp])]! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 11:50:35' prior: 50365569! - scanFile: aFile from: startPosition to: stopPosition - - file _ aFile. - changeList _ OrderedCollection new. - list _ OrderedCollection new. - listIndex _ 0. - file position: startPosition. - - 'Scanning ', aFile localName, '...' - displayProgressAt: Sensor mousePoint - from: startPosition to: stopPosition - during: [ :barBlock | self scanUpTo: stopPosition informing: barBlock ]. - - self clearSelections! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/23/2019 22:47:43' prior: 16795976! - scanSpecificChangeRecordType - "Scan anything that involves more than one chunk" - - | itemPosition item tokens firstToken secondToken | - - itemPosition _ file position. - item _ file nextChunk. - - (self itemIsRecognized: item) ifFalse: [ - "Maybe a preamble, but not one we recognize; bail out with the preamble trick" - ^ self scanAndIgnore: item in: itemPosition ]. - - tokens _ Scanner new scanTokens: item. - tokens size >= 2 ifTrue: [ - firstToken _ tokens first. - secondToken _ tokens second. - - firstToken == #classDefinition: - ifTrue: [ ^ self scanClassDefinition: tokens ]. - (firstToken == #classRemoval: or: [ firstToken == #classMoveToSomePackage: ]) - ifTrue: [ ^ self scanClassRemoval: tokens ]. - (firstToken == #methodRemoval: or: [ firstToken == #methodMoveToSomePackage: ]) - ifTrue: [ ^ self scanMethodRemoval: tokens ]. - (secondToken == #methodsFor: or: [ tokens third == #methodsFor: ]) - ifTrue: [ ^ self scanMethodDefinition: tokens ]. - secondToken == #commentStamp: - ifTrue: [ ^ self scanClassComment: tokens ]. - firstToken == #provides: - ifTrue: [ ^ self scanFeatureProvision: tokens ]. - firstToken == #requires: - ifTrue: [ ^ self scanFeatureRequirement: tokens ]. - ]! ! -!ChangeList class methodsFor: 'public access' stamp: 'HAW 10/24/2019 08:57:14' prior: 16796836! - browsePackageContents: aFileEntry - "Opens a changeList on a fileStream" - | changeList packageFile | - aFileEntry readStreamDo: [ :stream | - changeList _ self new scanFile: stream from: 0 to: stream size. - stream reset. - packageFile _ CodePackageFile buildFileStream: stream. - ]. - "Add deletions of methods and classes that are in the CodePackage (i.e., active in the system) - but are no longer in the CodePackageFile being viewed." - packageFile methodsToRemove do: [ :methodReference | - changeList - addItem: (MethodDeletionChangeRecord new methodReference: methodReference) - text: 'method no longer in package: ', methodReference stringVersion ]. - packageFile classesToRemove do: [ :clsName | - changeList - addItem: (ClassDeletionChangeRecord new className: clsName) - text: 'class no longer in package: ', clsName ]. - changeList clearSelections. - ChangeListWindow open: changeList label: aFileEntry name! ! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'HAW 10/24/2019 09:45:22' prior: 50478300! - classRemoved: aClass fromCategory: aCategoryName - - | classDefinition | - - aClass acceptsLoggingOfCompilation - ifTrue: [ - "I have to recreate the category because the classs has already been removed form the - SystemOrganizer - Hernan" - classDefinition := aClass definitionReplacingCategoryWith: aCategoryName. - - self - logChange: classDefinition - preamble: 'classRemoval: ', aClass name printString, ' stamp: ', Utilities changeStamp printString ]. - - ! ! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'HAW 10/23/2019 19:09:00' prior: 50478319! - methodRemoved: aMethod selector: aSymbol inProtocol: protocol class: aClass - - aClass acceptsLoggingOfCompilation - ifTrue: [ self - logChange: aMethod sourceCode - preamble: 'methodRemoval: ', aClass name, ' ', aSymbol storeString, ' stamp: ', Utilities changeStamp printString ]. -! ! -!MethodReference methodsFor: 'queries' stamp: 'HAW 10/23/2019 20:58:03' prior: 16873043! - actualClass - - ^self actualClassIfAbsent: [ nil ]! ! -!MethodReference methodsFor: 'queries' stamp: 'HAW 10/23/2019 21:38:10' prior: 16873093! - sourceCode - - ^ (self actualClassIfAbsent: [ self error: self class classDoesNotExistErrorMessage ]) - sourceCodeAt: methodSymbol! ! -!ClassDeletionChangeRecord methodsFor: 'fileIn/fileOut' stamp: 'HAW 10/25/2019 10:41:36' prior: 16805542! - fileIn - - doItOnlyIfInBaseSystem - ifTrue: [ Smalltalk removeClassNamedIfInBaseSystem: className] - ifFalse: [ self changeClass ifNotNil: [ :aClass | aClass removeFromSystem ] ]! ! -!ClassDeletionChangeRecord methodsFor: 'fileIn/fileOut' stamp: 'HAW 10/26/2019 10:50:42' prior: 16805550! - fileOutOn: stream - "File the receiver out on the given file stream" - - | record | - - record := String streamContents: [ :recordStream | - recordStream - nextPutAll: (doItOnlyIfInBaseSystem ifTrue: [ 'classMoveToSomePackage: #' ] ifFalse: ['classRemoval: #']); - nextPutAll: className; - nextPutAll: ' stamp: '; - print: stamp ]. - - stream - nextPut: $!!; - nextChunkPut: record; - newLine; - nextChunkPut: self command; - newLine; newLine. - ! ! -!ClassDeletionChangeRecord methodsFor: 'accessing' stamp: 'HAW 10/24/2019 08:54:41' prior: 16805567! - changeClass - ^Smalltalk at: className ifAbsent: nil! ! -!ClassDeletionChangeRecord methodsFor: 'accessing' stamp: 'HAW 10/24/2019 08:54:42' prior: 16805572! - changeClassName - ^className! ! -!ClassDeletionChangeRecord methodsFor: 'accessing' stamp: 'HAW 10/24/2019 08:56:50' prior: 16805597! - string - - ^classDefinition ifNil: [ '' ]! ! -!MethodDeletionChangeRecord methodsFor: 'accessing' stamp: 'HAW 10/23/2019 17:22:05' prior: 16871939! - string - - ^sourceCode ifNil: [ '' ]! ! -!MethodDeletionChangeRecord methodsFor: 'fileIn/fileOut' stamp: 'HAW 10/26/2019 10:48:23' prior: 16871953! - fileOutOn: stream - "File the receiver out on the given file stream" - - | record | - - record := String streamContents: [ :recordStream | - recordStream - nextPutAll: (doItOnlyIfInBaseSystem ifTrue: [ 'methodMoveToSomePackage: ' ] ifFalse: ['methodRemoval: ']); - nextPutAll: self changeClassName; - space; - nextPutAll: self methodSelector storeString; - nextPutAll: ' stamp: '; - print: stamp ]. - - stream - nextPut: $!!; - nextChunkPut: record; - newLine; - nextChunkPut: self command; - newLine - -! ! -!MethodDeletionChangeRecord methodsFor: 'services' stamp: 'HAW 10/26/2019 10:48:08' prior: 16871970! - command - - ^String streamContents: [ :stream | - stream - nextPutAll: self changeClassName; - space; - nextPutAll: (doItOnlyIfInBaseSystem ifTrue: ['removeSelectorIfInBaseSystem:'] ifFalse: ['removeSelector:']); - space; - nextPutAll: self methodSelector storeString ]! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 10/23/2019 22:26:35' prior: 16798429! - fileOutMethodMovedToOtherPackagesFor: class on: stream - "Write out removals and initialization for this class." - - self - fileOutMethodRemovalsOf: #(movedToOtherPackage) - movedToOtherPackage: true - for: class - on: stream -! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 10/23/2019 22:26:05' prior: 16798450! - fileOutMethodRemovalsFor: class on: stream - "Write out removals and initialization for this class." - - self - fileOutMethodRemovalsOf: #(remove addedThenRemoved) - movedToOtherPackage: false - for: class - on: stream - ! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 12:46:36' prior: 16798470! - fileOutOn: stream - "Write out all the changes the receiver knows about" - - | classList | - - self isEmpty ifTrue: [ self inform: 'Warning: no changes to file out' ]. - - classList _ Array streamContents: [ :strm | - Smalltalk hierarchySorted: self changedClasses do: [ :cls | strm nextPut: cls ]]. - - self fileOutClassDefinitionsOf: classList on: stream. - self fileOutMethodsAdditionsOf: classList on: stream. - self fileOutMethodsChangesOf: stream on: classList. - self fileOutRemovedAndMovedMethodsOf: classList on: stream. - self fileOutClassInitializationsOf: classList on: stream. - self fileOutRemovedClassesOn: stream. - self fileOutMovedClassesOn: stream. -! ! -!ChangeSet methodsFor: 'system change notifications' stamp: 'HAW 10/24/2019 15:00:59' prior: 16798746! - classRemoved: aClass fromCategory: aCategoryName - - self noteRemovalOf: aClass fromCategory: aCategoryName! ! -!ClassChangeRecord methodsFor: 'all changes' stamp: 'HAW 10/25/2019 09:53:27' prior: 16804996! - noteChangeType: changeSymbol fromClass: class - - stamp _ Utilities changeStamp. - - changeSymbol == #movedToOtherPackage ifTrue: [ - ^ changeTypes add: changeSymbol]. - "Any other change type meanse we're still here!!" - changeTypes remove: #movedToOtherPackage ifAbsent: nil. - - (changeSymbol == #new or: [changeSymbol == #add]) ifTrue: [ - changeTypes add: #add. - changeTypes remove: #change ifAbsent: nil. - ^ self]. - changeSymbol == #change ifTrue: [ - (changeTypes includes: #add) ifTrue: [^ self]. - ^ changeTypes add: changeSymbol]. - changeSymbol == #addedThenRemoved ifTrue: [ - ^ self]. "An entire class was added but then removed" - changeSymbol == #comment ifTrue: [ - ^ changeTypes add: changeSymbol]. - changeSymbol == #reorganize ifTrue: [ - ^ changeTypes add: changeSymbol]. - changeSymbol == #rename ifTrue: [ - ^ changeTypes add: changeSymbol]. - (changeSymbol beginsWith: 'oldName: ') ifTrue: [ - "Must only be used when assimilating other changeSets" - (changeTypes includes: #add) ifTrue: [^ self]. - priorName _ changeSymbol copyFrom: 'oldName: ' size + 1 to: changeSymbol size. - ^ changeTypes add: #rename]. - changeSymbol == #remove ifTrue: [ - (changeTypes includes: #add) - ifTrue: [changeTypes add: #addedThenRemoved] - ifFalse: [changeTypes add: #remove]. - ^ changeTypes removeAllFoundIn: #(add change comment reorganize)]. - - self error: 'Unrecognized changeType'! ! -!ClassChangeRecord methodsFor: 'method changes' stamp: 'HAW 10/24/2019 08:49:09' prior: 16805172! - findOrMakeMethodChangeAt: selector priorMethod: priorMethod - - ^ methodChanges - at: selector - ifAbsentPut: [MethodChangeRecord new priorMethod: priorMethod]! ! -!MethodChangeRecord methodsFor: 'change type' stamp: 'HAW 10/25/2019 17:21:14' prior: 16871354! - noteChangeType: newChangeType - - stamp _ Utilities changeStamp. - - "Change of an added method, is still an add" - (changeType == #add and: [ newChangeType == #change ]) - ifTrue: [ ^self ]. - - "Change of an added method, is still an add" - (changeType == #addedThenRemoved and: [ newChangeType == #change ]) - ifTrue: [ - changeType _ #add. - ^self ]. - - changeType _ newChangeType.! ! -!CodeFile methodsFor: 'reading' stamp: 'HAW 10/26/2019 12:50:49' prior: 50366511! - buildFrom: aStream - - | changes | - - changes _ (ChangeList new scanFile: aStream from: 0 to: aStream size) changeList. - - ('Processing ', self name) - displayProgressAt: Sensor mousePoint - from: 1 - to: changes size - during: [ :barBlock | self buildFrom: changes informingTo: barBlock ]. -! ! - -ChangeSet removeSelector: #classMovesToOtherPackage! - -!methodRemoval: ChangeSet #classMovesToOtherPackage stamp: 'jmv 11/15/2019 09:44:50'! -classMovesToOtherPackage - "Unlike some related methods, answer an Array (not a Set)" - ^ changeRecords keys select: [ :className | - (changeRecords at: className) isClassMoveToOtherPackage]! - -ChangeSet removeSelector: #fileOutMethodRemovalOf:for:movedToOtherPackage:on:! - -ChangeSet removeSelector: #classRemoves! - -!methodRemoval: ChangeSet #classRemoves stamp: 'jmv 11/15/2019 09:44:50'! -classRemoves - "Unlike some related methods, answer an Array (not a Set)" - ^ changeRecords keys select: [ :className | - (changeRecords at: className) isClassRemoval]! - -ChangeSet removeSelector: #fileOutRemovedClassRecord:! - -ChangeSet removeSelector: #noteRemovalOf:! - -!methodRemoval: ChangeSet #noteRemovalOf: stamp: 'jmv 11/15/2019 09:44:50'! -noteRemovalOf: class - "The class is about to be removed from the system. - Adjust the receiver to reflect that fact." - - class wantsChangeSetLogging ifFalse: [^ self]. - (self changeRecorderFor: class) - noteChangeType: #remove fromClass: class. - changeRecords removeKey: class class name ifAbsent: nil. - self hasUnsavedChanges: true! - -ChangeSet removeSelector: #fileOutInitializationOf:on:! - -ChangeSet removeSelector: #sorteClassRecords:! - -MethodDeletionChangeRecord class removeSelector: #methodReference:doItOnlyIfInBaseSystem:source:! - -MethodDeletionChangeRecord removeSelector: #initializeMethodReference:doItOnlyIfInBaseSystem:source:! - -ClassDeletionChangeRecord removeSelector: #clsName:! - -!methodRemoval: ClassDeletionChangeRecord #clsName: stamp: 'jmv 11/15/2019 09:44:50'! -clsName: aSymbol - clsName _ aSymbol! - -MethodReference class removeSelector: #classSymbol:isMeta:selector:! - -MethodReference removeSelector: #sourceCodeIfMissing:! - -ChangeListElement subclass: #ClassDeletionChangeRecord - instanceVariableNames: 'className doItOnlyIfInBaseSystem classDefinition stamp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #ClassDeletionChangeRecord category: #'Tools-Changes'! -ChangeListElement subclass: #ClassDeletionChangeRecord - instanceVariableNames: 'className doItOnlyIfInBaseSystem classDefinition stamp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -ChangeListElement subclass: #MethodDeletionChangeRecord - instanceVariableNames: 'methodReference doItOnlyIfInBaseSystem sourceCode stamp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #MethodDeletionChangeRecord category: #'Tools-Changes'! -ChangeListElement subclass: #MethodDeletionChangeRecord - instanceVariableNames: 'methodReference doItOnlyIfInBaseSystem sourceCode stamp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -Object subclass: #ClassChangeRecord - instanceVariableNames: 'inForce changeTypes priorDefinition thisName priorName methodChanges stamp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #ClassChangeRecord category: #'Tools-Changes'! -Object subclass: #ClassChangeRecord - instanceVariableNames: 'inForce changeTypes priorDefinition thisName priorName methodChanges stamp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -Object subclass: #MethodChangeRecord - instanceVariableNames: 'changeType currentMethod infoFromRemoval stamp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #MethodChangeRecord category: #'Tools-Changes'! -Object subclass: #MethodChangeRecord - instanceVariableNames: 'changeType currentMethod infoFromRemoval stamp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3930-ChangesScanningRefactoring-HernanWilkinson-2019Oct23-11h21m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3926] on 26 October 2019 at 3:08:06 pm'! -!ChangeList class methodsFor: 'scanning' stamp: 'HAW 10/26/2019 14:54:50'! - knownFileInPreambles - - ^ `{ - 'classDefinition:'. - 'classRemoval:'. - 'methodRemoval:'. - 'methodMoveToSomePackage:'. - 'classMoveToSomePackage:'. - 'provides:'. - 'requires:' }`! ! -!ChangeList class methodsFor: 'scanning' stamp: 'HAW 10/26/2019 14:55:26'! - knownPreambles - - ^ `{ 'commentStamp:'. 'methodsFor:'. }, ChangeList knownFileInPreambles`! ! -!PositionableStream methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 15:01:19'! - compileNextChunk - - (self peekFor: $!!) - ifTrue: [ self compileNextChunkWhenStartsWithExclamationMark ] - ifFalse: [ self compileNextChunkWhenDoesNotStartWithExclamationMark ]! ! -!PositionableStream methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 14:43:50'! - compileNextChunkHandlingExceptions - - [ self compileNextChunk ] - on: InMidstOfFileinNotification, UndeclaredVariableWarning - do: [ :ex | ex resume: true ]! ! -!PositionableStream methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 15:03:58'! - compileNextChunkWhenDoesNotStartWithExclamationMark - - | chunk | - - chunk := self nextChunk. - self checkForPreamble: chunk. - self evaluate: [ Compiler evaluate: chunk logged: true ] printingErrorWith: chunk - ! ! -!PositionableStream methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 15:04:31'! - compileNextChunkWhenStartsWithExclamationMark - - | chunk | - - chunk := self nextChunk. - - "These are the ones that should do nothing, - because next line is a doit that does the stuff - (or because it is handled elsewhere)" - - ((chunk beginsWith: 'description: ') - or: [ ChangeList knownFileInPreambles anySatisfy: [ :aPreamble | chunk beginsWith: aPreamble ]]) - ifFalse: [ self evaluate: [ (Compiler evaluate: chunk logged: false) scanFrom: self ] printingErrorWith: chunk ]! ! -!PositionableStream methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 15:03:41'! - evaluate: aBlock printingErrorWith: chunk - - aBlock - on: Error - do: [ :ex | - ex print. - ('while evaluating: ', chunk) print. - ex pass ] - ! ! -!PositionableStream methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 14:44:04'! - fileInInformingTo: barBlock - - [ self atEnd ] whileFalse: [ - barBlock value: self position. - self skipSeparators. - self compileNextChunkHandlingExceptions ]! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 14:56:01' prior: 50478398! - itemIsRecognized: item - - ^ self class knownPreambles anySatisfy: [ :preamble | item includesSubString: preamble ] ! ! -!PositionableStream methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 15:07:52' prior: 50430142! - 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. Put up a progress report with the given announcement as the title." - - Utilities logsUserChanges: false. - - announcement - displayProgressAt: Sensor mousePoint - from: 0 - to: self size - during: [ :barBlock | self fileInInformingTo: barBlock ]. - - "Note: The main purpose of this banner is to flush the changes file." - Utilities logsUserChanges: true. - Smalltalk logChange: '----End fileIn of ' , self name , '----'. - ! ! - -PositionableStream removeSelector: #m1! - -ChangeList removeSelector: #knownPreambles! - -!methodRemoval: ChangeList #knownPreambles stamp: 'jmv 11/15/2019 09:44:50'! -knownPreambles - - ^ `{ - 'commentStamp:'. - 'methodsFor:'. - 'classDefinition:'. - 'classRemoval:'. - 'methodRemoval:'. - 'methodMoveToSomePackage:'. - 'classMoveToSomePackage:'. - 'provides'. - 'requires' }`! - -ChangeList removeSelector: #knownFileInPreambles! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3931-FileInRefactoring-HernanWilkinson-2019Oct26-14h37m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3931] on 26 October 2019 at 6:02:11 pm'! - -ChangeListElement subclass: #ChangeRecord - instanceVariableNames: 'file position type class category meta stamp prior ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #ChangeRecord category: #'Tools-Changes'! -ChangeListElement subclass: #ChangeRecord - instanceVariableNames: 'file position type class category meta stamp prior' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 17:59:01'! - priorMethodReferenceFrom: tokens - - | priorMethodReference tagIndex | - - tagIndex _ tokens indexOf: #prior: ifAbsent: [ ^ nil ]. - priorMethodReference _ tokens at: tagIndex + 1. - - ^ priorMethodReference -! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 18:00:17'! - scanCategory: category class: class meta: meta stamp: stamp prior: aPriorMethod - - | itemPosition method | - - [ - itemPosition _ file position. - method _ file nextChunk. - method notEmpty ] whileTrue: [ "done when double terminators" - self - addItem: (ChangeRecord new - file: file - position: itemPosition - type: #method - class: class - category: category - meta: meta - stamp: stamp - prior: aPriorMethod) - text: 'method: ' , class , (meta ifTrue: [' class '] ifFalse: [' ']) - , (((Smalltalk at: class ifAbsent: [Object class]) parserClass selectorFrom: method) ifNil: ['']) - , (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp])]! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 17:58:04'! - stampFrom: tokens - - | stamp stampIndex | - - stampIndex _ tokens indexOf: #stamp: ifAbsent: [ ^'' ]. - stamp _ tokens at: stampIndex + 1. - - ^ stamp -! ! -!ChangeRecord methodsFor: 'access' stamp: 'HAW 10/26/2019 18:01:07'! - prior - - ^prior! ! -!ChangeRecord methodsFor: 'initialization' stamp: 'HAW 10/26/2019 18:00:29'! - file: aFile position: aPosition type: aType class: aClassName category: aClassCategory meta: isMeta stamp: aStamp prior: aPrior - - self file: aFile position: aPosition type: aType. - class _ aClassName. - category _ aClassCategory. - meta _ isMeta. - stamp _ aStamp. - prior _ aPrior.! ! -!ClassDeletionChangeRecord methodsFor: 'accessing' stamp: 'HAW 10/26/2019 17:53:44'! - stamp - - ^stamp! ! -!MethodDeletionChangeRecord methodsFor: 'accessing' stamp: 'HAW 10/26/2019 17:53:57'! - stamp - - ^stamp! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 17:58:04' prior: 50478445! - scanClassDefinition: tokens - - | classDefinition isMeta itemPosition className record fullClassName stamp | - - itemPosition _ file position. - fullClassName _ tokens second. - isMeta _ fullClassName includesSubString: ' class'. - className _ isMeta ifTrue: [fullClassName substrings first] ifFalse: [fullClassName]. - stamp _ self stampFrom: tokens. - classDefinition _ file nextChunk. - - record _ ChangeRecord new - file: file - position: itemPosition - type: #classDefinition - class: className asSymbol - category: tokens last - meta: isMeta - stamp: stamp. - - self addItem: record text: 'classDefinition: ', classDefinition.! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 17:58:04' prior: 50478466! - scanClassRemoval: tokens - - | doItOnlyIfInBaseSystem removeType classDefinition className description record stamp | - - removeType _ tokens first. - className _ tokens second. - doItOnlyIfInBaseSystem _ removeType == #classMoveToSomePackage:. - stamp _ self stampFrom: tokens. - classDefinition _ file nextChunk. - - record _ ClassDeletionChangeRecord - className: className - definition: classDefinition - doItOnlyIfInBaseSystem: doItOnlyIfInBaseSystem - stamp: stamp. - - description _ doItOnlyIfInBaseSystem - ifTrue: ['clase move to some package: '] - ifFalse: ['class removal: ']. - - self - addItem: record - text: description, className, '; ', stamp ! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 17:59:01' prior: 50478524! - scanMethodDefinition: tokens - - | stamp className priorMethod | - - className _ tokens first. - stamp _ self stampFrom: tokens. - priorMethod _ self priorMethodReferenceFrom: tokens. - - tokens second == #methodsFor: ifTrue: [ - ^ self scanCategory: tokens third class: className meta: false stamp: stamp prior: priorMethod ]. - - tokens third == #methodsFor: ifTrue: [ - ^ self scanCategory: tokens fourth class: className meta: true stamp: stamp prior: priorMethod ]. - - self error: 'Unsupported method definition' -! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 17:58:04' prior: 50478542! - scanMethodRemoval: tokens - - | doItOnlyIfInBaseSystem removeType isMeta sourceCode methodReference className description record selector stamp | - - removeType _ tokens first. - className _ tokens second. - doItOnlyIfInBaseSystem _ removeType == #methodMoveToSomePackage:. - - sourceCode _ file nextChunk. - isMeta _ tokens third == #class. - selector _ tokens at: tokens size - 2. - stamp _ self stampFrom: tokens. - - methodReference _ MethodReference new - setClassSymbol: className - classIsMeta: isMeta - methodSymbol: selector - stringVersion: className, (isMeta ifTrue: [' class '] ifFalse: [' ']), selector,'; ', stamp. - - record _ MethodDeletionChangeRecord - methodReference: methodReference - doItOnlyIfInBaseSystem: doItOnlyIfInBaseSystem - source: sourceCode - stamp: stamp. - - description _ doItOnlyIfInBaseSystem - ifTrue: ['method move to some package: '] - ifFalse: ['method removal: ']. - - self - addItem: record - text: description, methodReference stringVersion! ! -!ChangeRecord methodsFor: 'initialization' stamp: 'HAW 10/26/2019 17:22:59' prior: 16797422! - file: aFile position: aPosition type: aType - - file _ aFile. - position _ aPosition. - type _ aType. -" -file closed ifFalse: [ - '' print. - file print. - self print. - thisContext printStack: 10 ] -"! ! -!ChangeRecord methodsFor: 'initialization' stamp: 'HAW 10/26/2019 18:00:17' prior: 16797430! -file: aFile position: aPosition type: aType class: aClassName category: aClassCategory meta: isMeta stamp: aStamp - - self - file: aFile - position: aPosition - type: aType - class: aClassName - category: aClassCategory - meta: isMeta - stamp: aStamp - prior: nil -! ! -!ClassDeletionChangeRecord methodsFor: 'accessing' stamp: 'HAW 10/26/2019 18:01:23' prior: 16805576! - changeType - - ^ #classRemoval! ! - -ChangeRecord removeSelector: #priorMethod! - -ChangeRecord removeSelector: #file:position:type:class:category:meta:stamp:priorMethod:! - -ChangeList removeSelector: #scanCategory:class:meta:stamp:! - -!methodRemoval: ChangeList #scanCategory:class:meta:stamp: stamp: 'jmv 11/15/2019 09:44:50'! -scanCategory: category class: class meta: meta stamp: stamp - - | itemPosition method | - - [ - itemPosition _ file position. - method _ file nextChunk. - method notEmpty ] whileTrue: [ "done when double terminators" - self - addItem: (ChangeRecord new - file: file - position: itemPosition - type: #method - class: class - category: category - meta: meta - stamp: stamp) - text: 'method: ' , class , (meta ifTrue: [' class '] ifFalse: [' ']) - , (((Smalltalk at: class ifAbsent: [Object class]) parserClass selectorFrom: method) ifNil: ['']) - , (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp])]! - -ChangeList removeSelector: #scanChangeStamp:! - -ChangeList removeSelector: #scanPriorMethodReference:! - -ChangeListElement subclass: #ChangeRecord - instanceVariableNames: 'file position type class category meta stamp prior' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #ChangeRecord category: #'Tools-Changes'! -ChangeListElement subclass: #ChangeRecord - instanceVariableNames: 'file position type class category meta stamp prior' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3932-ReferenceToPriorAndRefactorings-HernanWilkinson-2019Oct26-15h09m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3931] on 26 October 2019 at 7:10:18 pm'! -!CodeFile methodsFor: 'change record types' stamp: 'HAW 10/26/2019 19:09:58'! - classRemoval: aClassDeletionChangeRecord - - ^self classDefinition: aClassDeletionChangeRecord ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3933-ClassRemovalFix-HernanWilkinson-2019Oct26-18h02m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3931] on 26 October 2019 at 11:35:30 pm'! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 20:10:35'! - classDefinitionRecordFrom: tokens - - | classDefinition isMeta itemPosition className record fullClassName stamp | - - itemPosition _ file position. - fullClassName _ tokens second. - isMeta _ fullClassName includesSubString: ' class'. - className _ isMeta ifTrue: [fullClassName substrings first] ifFalse: [fullClassName]. - stamp _ self stampFrom: tokens. - classDefinition _ file nextChunk. - - record _ ChangeRecord new - file: file - position: itemPosition - type: #classDefinition - class: className asSymbol - category: tokens last - meta: isMeta - stamp: stamp. - - ^record -! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 20:12:15' prior: 50479611! - scanClassDefinition: tokens - - | record | - - record _ self classDefinitionRecordFrom: tokens. - - self addItem: record text: 'classDefinition: ', record changeClassName. - ! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 23:23:14' prior: 50479677! - scanMethodRemoval: tokens - - | doItOnlyIfInBaseSystem removeType isMeta sourceCode methodReference className description record selector stamp | - - removeType _ tokens first. - className _ tokens second. - doItOnlyIfInBaseSystem _ removeType == #methodMoveToSomePackage:. - - sourceCode _ file nextChunk. - isMeta _ tokens third == #class. - selector _ isMeta ifTrue: [ tokens fourth ] ifFalse: [ tokens third ]. - stamp _ self stampFrom: tokens. - - methodReference _ MethodReference new - setClassSymbol: className - classIsMeta: isMeta - methodSymbol: selector - stringVersion: className, (isMeta ifTrue: [' class '] ifFalse: [' ']), selector,'; ', stamp. - - record _ MethodDeletionChangeRecord - methodReference: methodReference - doItOnlyIfInBaseSystem: doItOnlyIfInBaseSystem - source: sourceCode - stamp: stamp. - - description _ doItOnlyIfInBaseSystem - ifTrue: ['method move to some package: '] - ifFalse: ['method removal: ']. - - self - addItem: record - text: description, methodReference stringVersion! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3934-ScandDefinitionRefactoringMethodRemovalFix-HernanWilkinson-2019Oct26-19h10m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3931] on 26 October 2019 at 11:50:18 pm'! -!Utilities class methodsFor: 'identification' stamp: 'HAW 10/26/2019 23:43:23'! - changeStampField - - ^' stamp: ', self changeStamp printString.! ! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 23:49:20' prior: 16806649! - definitionPreamble - - ^'classDefinition: ', self name printString, ' category: ', self category printString, Utilities changeStampField! ! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'HAW 10/26/2019 23:45:14' prior: 50479028! - classRemoved: aClass fromCategory: aCategoryName - - | classDefinition | - - aClass acceptsLoggingOfCompilation - ifTrue: [ - "I have to recreate the category because the classs has already been removed form the - SystemOrganizer - Hernan" - classDefinition := aClass definitionReplacingCategoryWith: aCategoryName. - - self - logChange: classDefinition - preamble: 'classRemoval: ', aClass name printString, Utilities changeStampField ]! ! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'HAW 10/26/2019 23:45:25' prior: 50479047! - methodRemoved: aMethod selector: aSymbol inProtocol: protocol class: aClass - - aClass acceptsLoggingOfCompilation - ifTrue: [ self - logChange: aMethod sourceCode - preamble: 'methodRemoval: ', aClass name, ' ', aSymbol storeString, Utilities changeStampField ]. -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3935-ChangeStampField-HernanWilkinson-2019Oct26-23h35m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3935] on 28 October 2019 at 1:00:31 am'! - -Object subclass: #AutoCompleterSelectorsCollector - instanceVariableNames: 'categoriesWithSelectors addedSelectorsFastSet prefix entriesToShow possibleInvalidSelectors otherClasses selectorsLimit selectorSelectionCondition ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #AutoCompleterSelectorsCollector category: #'Tools-Autocompletion' stamp: 'jmv 11/15/2019 09:44:51'! -Object subclass: #AutoCompleterSelectorsCollector - instanceVariableNames: 'categoriesWithSelectors addedSelectorsFastSet prefix entriesToShow possibleInvalidSelectors otherClasses selectorsLimit selectorSelectionCondition' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:46:37'! - computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:48:30'! - computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:43:00'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:45:40'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:46:37'! - computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName with: possibleBinaryMessageSendRange - - textProvider computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName with: possibleBinaryMessageSendRange -! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:48:30'! - computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName with: possibleBinaryMessageSendRange - - textProvider computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName with: possibleBinaryMessageSendRange! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:43:01'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName with: possibleBinaryMessageSendRange - - textProvider computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName with: possibleBinaryMessageSendRange -! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:45:40'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange - - textProvider computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange -! ! -!Workspace methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:47:59'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForClassOrNil: (self classOfBindingOf: aName) with: possibleBinaryMessageSendRange! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:46:37'! - computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:48:30'! - computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:43:00'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:45:40'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:46:37'! - computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName with: possibleBinaryMessageSendRange - - self computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange -! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:48:30'! - computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName with: possibleBinaryMessageSendRange - - ^self computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange ! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:43:00'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName with: possibleBinaryMessageSendRange - - contextStackIndex = 0 - ifTrue: [ anAutocompleter computeMessageEntriesForUnknowClass ] - ifFalse: [ anAutocompleter computeMessageEntriesForClass: (self receiver instVarNamed: aName) class with: possibleBinaryMessageSendRange]! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:45:40'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange - - | context tempIndex | - - context := self selectedContext. - tempIndex := context tempNames indexOf: aName ifAbsent: [ ^ anAutocompleter computeMessageEntriesForUnknowClass ]. - - anAutocompleter computeMessageEntriesForClass: (self debuggerMap namedTempAt: tempIndex in: context) class with: possibleBinaryMessageSendRange - - ! ! -!Inspector methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:43:00'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForClass: (object instVarNamed: aName) class with: possibleBinaryMessageSendRange ! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:46:37'! - computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:48:30'! - computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:43:00'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:45:40'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 10/27/2019 20:09:37'! - canComputeMessageEntriesFor: prevRange - - ^ prevRange notNil ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 10/27/2019 18:38:46'! - computeEntriesOfUnaryMessageReturnNamed: aSelector at: aRange with: possibleBinaryMessageSendRange - - self subclassResponsibility ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 10/28/2019 00:24:58'! - computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel with: possibleBinarySendRange - - | id rangeType | - - canShowSelectorDocumentation _ true. - id _ allSource copyFrom: range start to: range end. - rangeType _ range rangeType. - - rangeType == #globalVar - ifTrue: [ ^self computeMessageEntriesForClass: (Smalltalk at: id asSymbol) class with: possibleBinarySendRange ]. - rangeType == #self - ifTrue: [ ^self computeMessageEntriesForClass: contextClass with: possibleBinarySendRange ]. - rangeType == #super - ifTrue: [ ^self computeMessageEntriesForClass: contextClass superclass with: possibleBinarySendRange ]. - rangeType == #true - ifTrue: [ ^self computeMessageEntriesForClass: True with: possibleBinarySendRange ]. - rangeType == #false - ifTrue: [ ^self computeMessageEntriesForClass: False with: possibleBinarySendRange ]. - rangeType == #nil - ifTrue: [ ^self computeMessageEntriesForClass: UndefinedObject with: possibleBinarySendRange ]. - rangeType == #character - ifTrue: [ ^self computeMessageEntriesForClass: id first class with: possibleBinarySendRange ]. - rangeType == #number - ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) with: possibleBinarySendRange ]. - rangeType == #string - ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) with: possibleBinarySendRange ]. - rangeType == #symbol - ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) with: possibleBinarySendRange ]. - rangeType == #stringSymbol - ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) with: possibleBinarySendRange ]. - rangeType == #instVar - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofInstVarNamed: id with: possibleBinarySendRange ]. - rangeType == #methodArg - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofTempVarNamed: id with: possibleBinarySendRange ]. - rangeType == #tempVar - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofTempVarNamed: id with: possibleBinarySendRange ]. - rangeType == #blockArg - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofBlockArgNamed: id with: possibleBinarySendRange ]. - rangeType == #blockTempVar - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofBlockTempVarNamed: id with: possibleBinarySendRange ]. - rangeType == #workspaceVar - ifTrue: [ ^self computeMessageEntriesForClassOrNil: (specificModel classOfWorkspaceVarNamed: id) with: possibleBinarySendRange ]. - rangeType == #thisContext - ifTrue: [ ^self computeMessageEntriesForClass: (specificModel classOfThisContext) with: possibleBinarySendRange ]. - rangeType == #classVar - ifTrue: [ ^self computeMessageEntriesForClassOrNil: (self classOfLocalBindingNamed: id in: contextClass) with: possibleBinarySendRange ]. - rangeType == #poolConstant - ifTrue: [ ^self computeMessageEntriesForClassOrNil: (self classOfLocalBindingNamed: id in: contextClass) with: possibleBinarySendRange ]. - rangeType == #blockEnd - ifTrue: [ ^self computeMessageEntriesForClass: BlockClosure with: possibleBinarySendRange ]. - rangeType == #arrayEnd - ifTrue: [ ^self computeMessageEntriesForClass: Array with: possibleBinarySendRange ]. - rangeType == #rightBrace - ifTrue: [ ^self computeMessageEntriesForClass: Array with: possibleBinarySendRange ]. - rangeType == #unary - ifTrue: [ ^self computeEntriesOfUnaryMessageReturnNamed: id at: range with: possibleBinarySendRange ]. - rangeType == #rightParenthesis - ifTrue: [ ^self computeMessageEntriesOfEnclosedExpressionReturnAt: range with: possibleBinarySendRange ]. - rangeType == #cascadeSeparator - ifTrue: [ ^self computeMessageEntriesOfCascadeReceiverAt: range with: possibleBinarySendRange ]. - - self computeMessageEntriesForUnknowClass - - ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 10/27/2019 21:55:05' prior: 50436746! -computeMessageEntriesForClass: aClass - - selectorsClasses := Array with: aClass. - - entries := (AutoCompleterSelectorsCollector for: prefix) - addSelectorsOf: aClass; - entriesToShow! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 10/27/2019 21:54:40'! - computeMessageEntriesForClass: aClass with: possibleBinaryMessageSendRange - - (self isBinaryMessageSend: possibleBinaryMessageSendRange) - ifTrue: [ self computeMessageEntriesForClass: aClass withPreviousBinaryMessageSend: possibleBinaryMessageSendRange ] - ifFalse: [ self computeMessageEntriesForClass: aClass ]. - - self ifEmptyEntriesShowAllPrefixedSelectors! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 10/27/2019 21:55:51'! - computeMessageEntriesForClass: aClass withPreviousBinaryMessageSend: possibleBinaryMessageSendRange - - self computeMessageEntriesForClass: aClass - ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 10/27/2019 21:47:59'! - computeMessageEntriesForClassOrNil: aClassOrNil with: possibleBinaryMessageSendRange - - aClassOrNil - ifNil: [ self computeMessageEntriesForUnknowClass ] - ifNotNil: [ self computeMessageEntriesForClass: aClassOrNil with: possibleBinaryMessageSendRange ]. - -! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 10/27/2019 23:31:06'! - computeMessageEntriesOfCascadeReceiverAt: aRange with: possibleBinaryMessageSendRange - - self subclassResponsibility ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 10/27/2019 23:30:13'! - computeMessageEntriesOfEnclosedExpressionReturnAt: aRange with: possibleBinaryMessageSendRange - - self subclassResponsibility ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 10/27/2019 19:56:52'! - computeMessageEntriesWithEmptyPrefixFor: allSource using: last3Ranges at: range in: contextClass and: specificModel - - prefix _ ''. - self computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel with: last3Ranges second.! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 10/27/2019 18:40:11'! - isBinaryMessageSend: possibleBinaryMessageSendRange - - ^possibleBinaryMessageSendRange notNil and: [ possibleBinaryMessageSendRange rangeType = #binary ]. - - ! ! -!DynamicTypingSmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 10/27/2019 18:38:46'! - computeEntriesOfUnaryMessageReturnNamed: aSelector at: aRange with: possibleBinaryMessageSendRange - - self computeMessageEntriesForUnknowClass - ! ! -!DynamicTypingSmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 10/27/2019 23:31:06'! - computeMessageEntriesOfCascadeReceiverAt: aRange with: possibleBinaryMessageSendRange - - self computeMessageEntriesForUnknowClass - -! ! -!DynamicTypingSmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 10/27/2019 23:30:13'! - computeMessageEntriesOfEnclosedExpressionReturnAt: aRange with: possibleBinaryMessageSendRange - - self computeMessageEntriesForUnknowClass - -! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting' stamp: 'HAW 10/28/2019 00:38:01'! - addKeywordSelectorsOf: aClass - - self selectKeywordSelectorsWhile: [ self addSelectorsOf: aClass ]! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting' stamp: 'HAW 10/28/2019 00:38:01'! - addKeywordSelectorsOf: aClass upTo: aSuperclassToExclude - - self selectKeywordSelectorsWhile: [ self addSelectorsOf: aClass upTo: aSuperclassToExclude ]! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting' stamp: 'HAW 10/28/2019 00:38:01'! - addKeywordSelectorsOfAll: classes upTo: aSuperclass - - self selectKeywordSelectorsWhile: [ self addSelectorsOfAll: classes upTo: aSuperclass ]! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting' stamp: 'HAW 10/27/2019 19:38:13'! - addUnaryAndBinarySelectorsOf: aClass - - self selectUnaryAndBinarySelectorsWhile: [ self addSelectorsOf: aClass ]. - ! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting' stamp: 'HAW 10/27/2019 23:54:56'! - addUnaryAndBinarySelectorsOf: aClass upTo: aSuperclassToExclude - - self selectUnaryAndBinarySelectorsWhile: [ self addSelectorsOf: aClass upTo: aSuperclassToExclude ]. - ! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting' stamp: 'HAW 10/27/2019 23:55:50'! - addUnaryAndBinarySelectorsOfAll: classes upTo: aSuperclassToExclude - - self selectUnaryAndBinarySelectorsWhile: [ self addSelectorsOfAll: classes upTo: aSuperclassToExclude ]. - ! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting - private' stamp: 'HAW 10/28/2019 00:38:01'! - selectKeywordSelectorsWhile: aClosure - - self selectSelectorsThatSatisfy: [ :aSelector | aSelector isKeyword ] while: aClosure -! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting - private' stamp: 'HAW 10/27/2019 19:36:18'! - selectSelectorsThatSatisfy: aSelectorsSelectionCondition while: aClosure - - | currentSelectorsSelectionCondition | - - currentSelectorsSelectionCondition := selectorSelectionCondition. - [ selectorSelectionCondition := aSelectorsSelectionCondition. - aClosure value ] ensure: [ selectorSelectionCondition := currentSelectorsSelectionCondition ].! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting - private' stamp: 'HAW 10/27/2019 19:38:54'! -selectUnaryAndBinarySelectorsWhile: aClosure - - self selectSelectorsThatSatisfy: [ :aSelector | aSelector isKeyword not ] while: aClosure -! ! -!SmalltalkCompleter methodsFor: 'entries' stamp: 'HAW 10/27/2019 12:40:42' prior: 50434500! - computeEntries - - | allSource contextClass specificModel last3Ranges range | - - allSource _ model actualContents string. - specificModel _ self textProviderOrModel. - contextClass _ self selectedClassOrMetaClassIn: specificModel. - last3Ranges _ self parse: allSource in: contextClass and: specificModel. - range _ last3Ranges third ifNil: [ ^entries _ #() ]. - possibleInvalidSelectors _ #(). - - range end = position - ifTrue: [ self computeEntriesOfMessageOrIdentifiersFor: allSource using: last3Ranges at: range in: contextClass and: specificModel ] - ifFalse: [ self computeMessageEntriesWithEmptyPrefixFor: allSource using: last3Ranges at: range in: contextClass and: specificModel ]. - - ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 10/27/2019 20:09:37' prior: 50434638! - computeMessageEntriesWhenSendinMessageFor: allSource using: last3Ranges in: contextClass and: specificModel - - | prevPrevRange prevRange | - - "If previous range is a constant or a well known identifier, we might filter messages" - prevRange _ last3Ranges second. - prevPrevRange _ last3Ranges first. - - "3 if -> ifNil: but not ifTrue: - 3=4 -> ifNil: or ifTrue:" - - ^ (self canComputeMessageEntriesFor: prevRange ) - ifTrue: [ self computeMessageEntriesFor: allSource at: prevRange in: contextClass and: specificModel with: prevPrevRange ] - ifFalse: [ self computeMessageEntriesForUnknowClass ] -! ! -!AutoCompleterSelectorsCollector methodsFor: 'initialization' stamp: 'HAW 10/27/2019 19:20:29' prior: 50434063! - initializeFor: aPrefix withSelectorsLimitedTo: aLimit - - prefix := aPrefix. - categoriesWithSelectors := OrderedDictionary new. - addedSelectorsFastSet := IdentitySet new. - possibleInvalidSelectors := IdentitySet new. - selectorsLimit := aLimit. - selectorSelectionCondition := [ :aSelector | true ]! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting - private' stamp: 'HAW 10/27/2019 19:22:52' prior: 50434156! - prefixedSelectorsOf: aCategory in: aClassOrganization - - ^ (aClassOrganization listAtCategoryNamed: aCategory) - select: [ :aSelector | - (aSelector beginsWith: prefix) - and: [ (selectorSelectionCondition value: aSelector) - and: [ (addedSelectorsFastSet includes: aSelector) not ]]]. -! ! - -AutoCompleterSelectorsCollector removeSelector: #addBinarySelectorsOfAll:upTo:! - -AutoCompleterSelectorsCollector removeSelector: #selectBinaryKeywordWhile:! - -AutoCompleterSelectorsCollector removeSelector: #addBinarySelectorsOf:upTo:! - -AutoCompleterSelectorsCollector removeSelector: #addBinarySelectorsOf:! - -AutoCompleterSelectorsCollector removeSelector: #selectBinarySelectorsWhile:! - -DynamicTypingSmalltalkCompleter removeSelector: #computeMessageEntriesOfCascadeReceiverAt:! - -!methodRemoval: DynamicTypingSmalltalkCompleter #computeMessageEntriesOfCascadeReceiverAt: stamp: 'jmv 11/15/2019 09:44:51'! -computeMessageEntriesOfCascadeReceiverAt: aRange - - self computeMessageEntriesForUnknowClass - -! - -DynamicTypingSmalltalkCompleter removeSelector: #computeEntriesOfUnaryMessageReturnNamed:at:! - -!methodRemoval: DynamicTypingSmalltalkCompleter #computeEntriesOfUnaryMessageReturnNamed:at: stamp: 'jmv 11/15/2019 09:44:51'! -computeEntriesOfUnaryMessageReturnNamed: aSelector at: aRange - - self computeMessageEntriesForUnknowClass - ! - -DynamicTypingSmalltalkCompleter removeSelector: #computeMessageEntriesOfEnclosedExpressionReturnAt:! - -!methodRemoval: DynamicTypingSmalltalkCompleter #computeMessageEntriesOfEnclosedExpressionReturnAt: stamp: 'jmv 11/15/2019 09:44:51'! -computeMessageEntriesOfEnclosedExpressionReturnAt: aRange - - self computeMessageEntriesForUnknowClass - -! - -SmalltalkCompleter removeSelector: #computeMessageEntriesOfEnclosedExpressionReturnAt:! - -!methodRemoval: SmalltalkCompleter #computeMessageEntriesOfEnclosedExpressionReturnAt: stamp: 'jmv 11/15/2019 09:44:51'! -computeMessageEntriesOfEnclosedExpressionReturnAt: aRange - - self subclassResponsibility ! - -SmalltalkCompleter removeSelector: #computeEntriesOfUnaryMessageReturnNamed:at:! - -!methodRemoval: SmalltalkCompleter #computeEntriesOfUnaryMessageReturnNamed:at: stamp: 'jmv 11/15/2019 09:44:51'! -computeEntriesOfUnaryMessageReturnNamed: aSelector at: aRange - - self subclassResponsibility ! - -SmalltalkCompleter removeSelector: #computeMessageEntriesOfCascadeReceiverAt:! - -!methodRemoval: SmalltalkCompleter #computeMessageEntriesOfCascadeReceiverAt: stamp: 'jmv 11/15/2019 09:44:51'! -computeMessageEntriesOfCascadeReceiverAt: aRange - - self subclassResponsibility ! - -SmalltalkCompleter removeSelector: #computeMessageEntriesForClassOrNil:! - -!methodRemoval: SmalltalkCompleter #computeMessageEntriesForClassOrNil: stamp: 'jmv 11/15/2019 09:44:51'! -computeMessageEntriesForClassOrNil: aClassOrNil - - aClassOrNil - ifNil: [ self computeMessageEntriesForUnknowClass ] - ifNotNil: [ self computeMessageEntriesForClass: aClassOrNil ]. - -! - -SmalltalkCompleter removeSelector: #canComputeMessageEntriesFor:and:! - -!methodRemoval: SmalltalkCompleter #canComputeMessageEntriesFor:and: stamp: 'jmv 11/15/2019 09:44:51'! -canComputeMessageEntriesFor: prevRange and: prevPrevRange - - ^ prevRange notNil and: [ prevPrevRange isNil or: [ prevPrevRange rangeType ~= #binary ]]! - -SmalltalkCompleter removeSelector: #computeMessageEntriesWithEmptyPrefixFor:at:in:and:! - -!methodRemoval: SmalltalkCompleter #computeMessageEntriesWithEmptyPrefixFor:at:in:and: stamp: 'jmv 11/15/2019 09:44:51'! -computeMessageEntriesWithEmptyPrefixFor: allSource at: range in: contextClass and: specificModel - - prefix _ ''. - self computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel ! - -SmalltalkCompleter removeSelector: #computeMessageEntriesFor:at:in:and:! - -!methodRemoval: SmalltalkCompleter #computeMessageEntriesFor:at:in:and: stamp: 'jmv 11/15/2019 09:44:51'! -computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel - - | id rangeType | - - canShowSelectorDocumentation _ true. - id _ allSource copyFrom: range start to: range end. - rangeType _ range rangeType. - - rangeType == #globalVar ifTrue: [ ^self computeMessageEntriesForClass: (Smalltalk at: id asSymbol) class ]. - rangeType == #self ifTrue: [ ^self computeMessageEntriesForClass: contextClass ]. - rangeType == #super ifTrue: [ ^self computeMessageEntriesForClass: contextClass superclass ]. - rangeType == #true ifTrue: [ ^self computeMessageEntriesForClass: True ]. - rangeType == #false ifTrue: [ ^self computeMessageEntriesForClass: False ]. - rangeType == #nil ifTrue: [ ^self computeMessageEntriesForClass: UndefinedObject ]. - rangeType == #character ifTrue: [ ^self computeMessageEntriesForClass: id first class ]. - rangeType == #number ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #string ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #symbol ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #stringSymbol ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #instVar ifTrue: [ ^specificModel computeMessageEntriesIn: self ofInstVarNamed: id ]. - rangeType == #methodArg ifTrue: [ ^specificModel computeMessageEntriesIn: self ofTempVarNamed: id ]. - rangeType == #tempVar ifTrue: [ ^specificModel computeMessageEntriesIn: self ofTempVarNamed: id ]. - rangeType == #blockArg ifTrue: [ ^specificModel computeMessageEntriesIn: self ofBlockArgNamed: id ]. - rangeType == #blockTempVar ifTrue: [ ^specificModel computeMessageEntriesIn: self ofBlockTempVarNamed: id ]. - rangeType == #workspaceVar ifTrue: [ ^self computeMessageEntriesForClassOrNil: (specificModel classOfWorkspaceVarNamed: id) ]. - rangeType == #thisContext ifTrue: [ ^self computeMessageEntriesForClass: (specificModel classOfThisContext) ]. - rangeType == #classVar ifTrue: [ ^self computeMessageEntriesForClassOrNil: (self classOfLocalBindingNamed: id in: contextClass) ]. - rangeType == #poolConstant ifTrue: [ ^self computeMessageEntriesForClassOrNil: (self classOfLocalBindingNamed: id in: contextClass) ]. - rangeType == #blockEnd ifTrue: [ ^self computeMessageEntriesForClass: BlockClosure ]. - rangeType == #arrayEnd ifTrue: [ ^self computeMessageEntriesForClass: Array ]. - rangeType == #rightBrace ifTrue: [ ^self computeMessageEntriesForClass: Array ]. - rangeType == #unary ifTrue: [ ^self computeEntriesOfUnaryMessageReturnNamed: id at: range ]. - rangeType == #rightParenthesis ifTrue: [ ^self computeMessageEntriesOfEnclosedExpressionReturnAt: range ]. - rangeType == #cascadeSeparator ifTrue: [ ^self computeMessageEntriesOfCascadeReceiverAt: range ]. - - self computeMessageEntriesForUnknowClass - - ! - -ClassNameRequestMorph removeSelector: #computeMessageEntriesIn:ofInstVarNamed:! - -!methodRemoval: ClassNameRequestMorph #computeMessageEntriesIn:ofInstVarNamed: stamp: 'jmv 11/15/2019 09:44:51'! -computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! - -ClassNameRequestMorph removeSelector: #computeMessageEntriesIn:ofTempVarNamed:! - -!methodRemoval: ClassNameRequestMorph #computeMessageEntriesIn:ofTempVarNamed: stamp: 'jmv 11/15/2019 09:44:51'! -computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! - -ClassNameRequestMorph removeSelector: #computeMessageEntriesIn:ofBlockArgNamed:! - -!methodRemoval: ClassNameRequestMorph #computeMessageEntriesIn:ofBlockArgNamed: stamp: 'jmv 11/15/2019 09:44:51'! -computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! - -ClassNameRequestMorph removeSelector: #computeMessageEntriesIn:ofBlockTempVarNamed:! - -!methodRemoval: ClassNameRequestMorph #computeMessageEntriesIn:ofBlockTempVarNamed: stamp: 'jmv 11/15/2019 09:44:51'! -computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! - -Inspector removeSelector: #computeMessageEntriesIn:ofInstVarNamed:! - -!methodRemoval: Inspector #computeMessageEntriesIn:ofInstVarNamed: stamp: 'jmv 11/15/2019 09:44:51'! -computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - anAutocompleter computeMessageEntriesForClass: (object instVarNamed: aName) class ! - -Debugger removeSelector: #computeMessageEntriesIn:ofInstVarNamed:! - -!methodRemoval: Debugger #computeMessageEntriesIn:ofInstVarNamed: stamp: 'jmv 11/15/2019 09:44:51'! -computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - contextStackIndex = 0 - ifTrue: [ anAutocompleter computeMessageEntriesForUnknowClass ] - ifFalse: [ anAutocompleter computeMessageEntriesForClass: (self receiver instVarNamed: aName) class]! - -Debugger removeSelector: #computeMessageEntriesIn:ofTempVarNamed:! - -!methodRemoval: Debugger #computeMessageEntriesIn:ofTempVarNamed: stamp: 'jmv 11/15/2019 09:44:51'! -computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - | context tempIndex | - - context := self selectedContext. - tempIndex := context tempNames indexOf: aName ifAbsent: [ ^ anAutocompleter computeMessageEntriesForUnknowClass ]. - - anAutocompleter computeMessageEntriesForClass: (self debuggerMap namedTempAt: tempIndex in: context) class - - ! - -Debugger removeSelector: #computeMessageEntriesIn:ofBlockArgNamed:! - -!methodRemoval: Debugger #computeMessageEntriesIn:ofBlockArgNamed: stamp: 'jmv 11/15/2019 09:44:51'! -computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName - - self computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName -! - -Debugger removeSelector: #computeMessageEntriesIn:ofBlockTempVarNamed:! - -!methodRemoval: Debugger #computeMessageEntriesIn:ofBlockTempVarNamed: stamp: 'jmv 11/15/2019 09:44:51'! -computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName - - ^self computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName ! - -TextProvider removeSelector: #computeMessageEntriesIn:ofInstVarNamed:! - -!methodRemoval: TextProvider #computeMessageEntriesIn:ofInstVarNamed: stamp: 'jmv 11/15/2019 09:44:51'! -computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! - -TextProvider removeSelector: #computeMessageEntriesIn:ofTempVarNamed:! - -!methodRemoval: TextProvider #computeMessageEntriesIn:ofTempVarNamed: stamp: 'jmv 11/15/2019 09:44:51'! -computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! - -TextProvider removeSelector: #computeMessageEntriesIn:ofBlockArgNamed:! - -!methodRemoval: TextProvider #computeMessageEntriesIn:ofBlockArgNamed: stamp: 'jmv 11/15/2019 09:44:51'! -computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! - -TextProvider removeSelector: #computeMessageEntriesIn:ofBlockTempVarNamed:! - -!methodRemoval: TextProvider #computeMessageEntriesIn:ofBlockTempVarNamed: stamp: 'jmv 11/15/2019 09:44:51'! -computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! - -Workspace removeSelector: #computeMessageEntriesIn:ofTempVarNamed:! - -!methodRemoval: Workspace #computeMessageEntriesIn:ofTempVarNamed: stamp: 'jmv 11/15/2019 09:44:51'! -computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - anAutocompleter computeMessageEntriesForClassOrNil: (self classOfBindingOf: aName)! - -PluggableTextModel removeSelector: #computeMessageEntriesIn:ofInstVarNamed:! - -!methodRemoval: PluggableTextModel #computeMessageEntriesIn:ofInstVarNamed: stamp: 'jmv 11/15/2019 09:44:51'! -computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - textProvider computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName -! - -PluggableTextModel removeSelector: #computeMessageEntriesIn:ofTempVarNamed:! - -!methodRemoval: PluggableTextModel #computeMessageEntriesIn:ofTempVarNamed: stamp: 'jmv 11/15/2019 09:44:51'! -computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - textProvider computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName -! - -PluggableTextModel removeSelector: #computeMessageEntriesIn:ofBlockArgNamed:! - -!methodRemoval: PluggableTextModel #computeMessageEntriesIn:ofBlockArgNamed: stamp: 'jmv 11/15/2019 09:44:51'! -computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName - - textProvider computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName -! - -PluggableTextModel removeSelector: #computeMessageEntriesIn:ofBlockTempVarNamed:! - -!methodRemoval: PluggableTextModel #computeMessageEntriesIn:ofBlockTempVarNamed: stamp: 'jmv 11/15/2019 09:44:51'! -computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName - - textProvider computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName! - -TextModel removeSelector: #computeMessageEntriesIn:ofInstVarNamed:! - -!methodRemoval: TextModel #computeMessageEntriesIn:ofInstVarNamed: stamp: 'jmv 11/15/2019 09:44:51'! -computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! - -TextModel removeSelector: #computeMessageEntriesIn:ofTempVarNamed:! - -!methodRemoval: TextModel #computeMessageEntriesIn:ofTempVarNamed: stamp: 'jmv 11/15/2019 09:44:51'! -computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! - -TextModel removeSelector: #computeMessageEntriesIn:ofBlockArgNamed:! - -!methodRemoval: TextModel #computeMessageEntriesIn:ofBlockArgNamed: stamp: 'jmv 11/15/2019 09:44:51'! -computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! - -TextModel removeSelector: #computeMessageEntriesIn:ofBlockTempVarNamed:! - -!methodRemoval: TextModel #computeMessageEntriesIn:ofBlockTempVarNamed: stamp: 'jmv 11/15/2019 09:44:51'! -computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! - -Object subclass: #AutoCompleterSelectorsCollector - instanceVariableNames: 'categoriesWithSelectors addedSelectorsFastSet prefix entriesToShow possibleInvalidSelectors otherClasses selectorsLimit selectorSelectionCondition' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #AutoCompleterSelectorsCollector category: #'Tools-Autocompletion' stamp: 'jmv 11/15/2019 09:44:51'! -Object subclass: #AutoCompleterSelectorsCollector - instanceVariableNames: 'categoriesWithSelectors addedSelectorsFastSet prefix entriesToShow possibleInvalidSelectors otherClasses selectorsLimit selectorSelectionCondition' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3936-AutoCompleteRecognitionOfBinaryMessageSend-HernanWilkinson-2019Oct27-00h56m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3935] on 28 October 2019 at 1:24:17 am'! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 10/28/2019 01:23:36' prior: 50480311! - computeMessageEntriesForClass: aClass withPreviousBinaryMessageSend: possibleBinaryMessageSendRange - - selectorsClasses := Array with: aClass. - - entries := (AutoCompleterSelectorsCollector for: prefix) - addUnaryAndBinarySelectorsOf: aClass; - entriesToShow! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3937-ShowOnlyUnaryAndBinary-HernanWilkinson-2019Oct28-01h00m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3937] on 28 October 2019 at 8:56:17 am'! -!ChangeRecord methodsFor: 'initialization' stamp: 'HAW 10/28/2019 08:36:56'! - markAsTest: aBoolean - - isTest := aBoolean ! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/28/2019 08:32:47' prior: 50479803! - classDefinitionRecordFrom: tokens - - | classDefinition isMeta itemPosition className record fullClassName stamp | - - itemPosition _ file position. - fullClassName _ tokens second. - isMeta _ fullClassName includesSubString: ' class'. - className _ isMeta ifTrue: [fullClassName substrings first] ifFalse: [fullClassName]. - stamp _ self stampFrom: tokens. - classDefinition _ file nextChunk. - - record _ ChangeRecord new - file: file - position: itemPosition - type: #classDefinition - class: className asSymbol - category: tokens last - meta: isMeta - stamp: stamp. - - record markAsTest: (classDefinition beginsWith: TestCase name asString). - - ^record -! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/28/2019 08:35:29' prior: 50479824! - scanClassDefinition: tokens - - | record | - - record _ self classDefinitionRecordFrom: tokens. - - self addItem: record text: 'classDefinition: ', record changeClassName. - ! ! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'HAW 10/28/2019 08:41:18' prior: 50479881! - definitionPreamble - - ^'classDefinition: ', self name printString, ' category: ', self category printString, Utilities changeStampField! ! -!ChangeRecord methodsFor: 'initialization' stamp: 'HAW 10/28/2019 08:38:08' prior: 50479711! - file: aFile position: aPosition type: aType - - file _ aFile. - position _ aPosition. - type _ aType. - - self markAsTest: false. -" -file closed ifFalse: [ - '' print. - file print. - self print. - thisContext printStack: 10 ] -"! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3938-TestClassDefinition-HernanWilkinson-2019Oct28-08h25m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3938] on 28 October 2019 at 9:56:04 am'! -!Class methodsFor: 'fileIn/Out' stamp: 'HAW 10/28/2019 09:53:14' prior: 50478596! - definitionReplacingCategoryWith: aNewCategory - - | definition categoryDefinitionIndex currentCategoryDefinition definitionWithNewCategory | - - definition := self definition. - "category can be nil, that is why I sent asString to it - Hernan" - currentCategoryDefinition := 'category: ''', self category asString, ''''. - categoryDefinitionIndex := definition - indexOfSubCollection: currentCategoryDefinition - startingAt: 1 - ifAbsent: [ self error: 'Definition of category not found!!' ]. - - definitionWithNewCategory := definition first: categoryDefinitionIndex - 1. - definitionWithNewCategory := definitionWithNewCategory, 'category: ''', aNewCategory asString, ''''. - - ^definitionWithNewCategory ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3939-definitionReplacingCategoryWith-HernanWilkinson-2019Oct28-09h48m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3938] on 28 October 2019 at 10:08:28 am'! - -ChangeListElement subclass: #ChangeRecord - instanceVariableNames: 'file position type class category meta stamp prior isTest ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #ChangeRecord category: #'Tools-Changes' stamp: 'jmv 11/15/2019 09:44:51'! -ChangeListElement subclass: #ChangeRecord - instanceVariableNames: 'file position type class category meta stamp prior isTest' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -ChangeListElement subclass: #ChangeRecord - instanceVariableNames: 'file position type class category meta stamp prior isTest' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #ChangeRecord category: #'Tools-Changes' stamp: 'jmv 11/15/2019 09:44:51'! -ChangeListElement subclass: #ChangeRecord - instanceVariableNames: 'file position type class category meta stamp prior isTest' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3940-ChangeRecordDefinition-HernanWilkinson-2019Oct28-09h56m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3940] on 28 October 2019 at 4:50:46 pm'! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'jmv 10/28/2019 16:49:45' prior: 50407534! - logChange: aStringOrText preamble: preambleOrNil - "Write the argument, aString, onto the changes file." - | aString changesFile | - self assureStartupStampLogged. - aString _ aStringOrText asString. - aString firstNoBlankIndex = 0 ifTrue: [^ self]. "null doits confuse replay" - - (SourceFiles notNil and: [(changesFile _ SourceFiles at: 2) notNil]) ifTrue: [ - changesFile isReadOnly ifFalse: [ - changesFile setToEnd; newLine; newLine. - preambleOrNil ifNotNil: [ - changesFile nextPut: $!!; nextChunkPut: preambleOrNil; newLine ]. - changesFile nextChunkPut: aString. - self forceChangesToDisk ]]. - Utilities logsUserChanges ifTrue: [ - Smalltalk defaultUserChangesName asFileEntry appendStreamDo: [ :stream | - stream newLine; newLine. - preambleOrNil ifNotNil: [ - stream nextPut: $!!; nextChunkPut: preambleOrNil; newLine ]. - stream nextChunkPut: aString ]]! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -ClassOrganizer allInstancesDo: [:co | co removeEmptyCategories]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3941-veryMinorCleanup-JuanVuletich-2019Oct28-16h49m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3941] on 28 October 2019 at 5:27:04 pm'! - -"Change Set: 3840-CuisCore-SantiagoDandois-2019Oct27 -Date: 27 October 2019 -Author: Santiago José Dandois - -Small changes to TextModel acceptContents. - -Check if new contents equal previousContents before resetting undeRedoBuffers. -This way you can safely save (Cmd-s) and undo changes (Cmd-z) after saving."! -!TextModel methodsFor: 'accessing' stamp: 'sjd 10/28/2019 17:23:39' prior: 16933681! - actualContents: aTextOrString - self basicActualContents: aTextOrString. - self changed: #actualContents! ! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 10/28/2019 17:26:50' prior: 50475563! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('AY' 'Angel Yan') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('bgs' 'Boris G. Shingarov') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('EB' 'Eric Brandwein') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('FGJ' 'Fernando Gasperi Jabalera') - #('FJG' 'Facundo Javier Gelatti') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('KLG' 'Gerald Klix') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MM' 'Mariano Montone') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('pmon' 'Paolo Montrasi') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('sjd' 'Santiago Jose Dandois') - #('SLD' 'Steve Davies') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('ss' 'Sebastian Sujarchuk') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3942-UndoingAfterSaving-SantiagoJoseDandois-2019Oct28-17h08m-sjd.1.cs.st----! - -'From Cuis 5.0 [latest update: #3942] on 28 October 2019 at 6:15:49 pm'! -!MessageSetWindow class methodsFor: 'opening' stamp: 'jmv 10/28/2019 18:14:40'! - findInSourceCode - | textToSearch | - - textToSearch _ FillInTheBlankMorph request: 'Text to search Source Code for?'. - Smalltalk browseMethodsWithSourceString: textToSearch! ! -!PasteUpMorph methodsFor: 'events' stamp: 'jmv 10/28/2019 18:13:11' prior: 50448889! - keyStroke: aKeyboardEvent - "Handle a keystroke event." - (aKeyboardEvent commandAltKeyPressed or: [ aKeyboardEvent controlKeyPressed ]) - ifTrue: [ - aKeyboardEvent keyCharacter = $b ifTrue: [ BrowserWindow openBrowser ]. - aKeyboardEvent keyCharacter = $f ifTrue: [ BrowserWindow findClass ]. - aKeyboardEvent keyCharacter = $F ifTrue: [ MessageSetWindow findInSourceCode ]. - ]. - "aKeyboardEvent keyCharacter print." - ^ super keyStroke: aKeyboardEvent! ! - -MessageSetWindow class removeSelector: #findSourceCode! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3943-SourceCodeFinder-GastonCaruso-JuanVuletich-2019Oct28-18h12m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3943] on 29 October 2019 at 11:08:22 am'! -!ChangeList methodsFor: 'as yet unclassified' stamp: 'HAW 10/29/2019 11:06:21'! - classCategoryFrom: tokens - - ^self field: #category: from: tokens ifAbsentOrNil: [ Categorizer default ]! ! -!ChangeList methodsFor: 'as yet unclassified' stamp: 'HAW 10/29/2019 10:53:32'! - field: aFieldName from: tokens ifAbsentOrNil: aBlock - - | fieldValue fieldIndex | - - fieldIndex _ tokens indexOf: aFieldName ifAbsent: [ ^aBlock value ]. - fieldValue _ tokens at: fieldIndex + 1 ifAbsent: [ ^aBlock value ]. - - ^ fieldValue ifNil: aBlock! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/29/2019 11:06:27' prior: 50481031! - classDefinitionRecordFrom: tokens - - | classDefinition isMeta itemPosition className record fullClassName category stamp | - - itemPosition _ file position. - fullClassName _ tokens second. - isMeta _ fullClassName includesSubString: ' class'. - className _ isMeta ifTrue: [fullClassName substrings first] ifFalse: [fullClassName]. - category _ self classCategoryFrom: tokens. - stamp _ self stampFrom: tokens. - classDefinition _ file nextChunk. - - record _ ChangeRecord new - file: file - position: itemPosition - type: #classDefinition - class: className asSymbol - category: category - meta: isMeta - stamp: stamp. - - record markAsTest: (classDefinition beginsWith: TestCase name asString). - - ^record -! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/29/2019 10:54:41' prior: 50479581! - stampFrom: tokens - - ^self field: #stamp: from: tokens ifAbsentOrNil: [ '' ] - -! ! - -ChangeList removeSelector: #categoryFrom:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3944-ClassCategoryRefactoring-HernanWilkinson-2019Oct29-10h41m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3944] on 4 November 2019 at 11:11:21 am'! -!Duration methodsFor: 'ansi protocol' stamp: 'jmv 11/4/2019 11:10:43' prior: 16835967! - hash - ^seconds hash bitXor: nanos hash! ! -!Time methodsFor: 'ansi protocol' stamp: 'jmv 11/4/2019 11:11:16' prior: 16936970! - hash - - ^ seconds hash bitXor: nanos hash! ! -!Character methodsFor: 'comparing' stamp: 'jmv 11/4/2019 11:03:26' prior: 16800457! -hash - "Hash is reimplemented because = is implemented." - - ^self numericValue hash! ! -!Timespan methodsFor: 'ansi protocol' stamp: 'jmv 11/4/2019 11:02:38' prior: 16938011! - hash - - ^ start hash bitXor: duration hash -! ! -!Interval methodsFor: 'comparing' stamp: 'jmv 11/4/2019 11:07:17' prior: 16861220! - hash - "Hash is reimplemented because = is implemented." - - ^ (start hash bitXor: stop hash) bitXor: count hash! ! -!KeyboardEvent methodsFor: 'comparing' stamp: 'jmv 11/4/2019 11:02:03' prior: 16861807! - hash - ^buttons hash bitXor: keyValue hash -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3945-hash-enh-JuanVuletich-2019Nov04-11h02m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3866] on 2 November 2019 at 8:46:40 pm'! -!SmallInteger methodsFor: 'enumerating' stamp: 'sqr 11/2/2019 20:45:34'! - timesRepeat: aBlock - "Evaluate the argument, aBlock, the number of times represented by the - receiver." - - self < 1 ifTrue: [^self]. - 1 to: (self bitAnd: 31) do: [:x | aBlock value]. - 1 to: (self bitAnd: -32) by: 32 do: - [:x | - aBlock value. aBlock value. aBlock value. aBlock value. - aBlock value. aBlock value. aBlock value. aBlock value. - aBlock value. aBlock value. aBlock value. aBlock value. - aBlock value. aBlock value. aBlock value. aBlock value. - aBlock value. aBlock value. aBlock value. aBlock value. - aBlock value. aBlock value. aBlock value. aBlock value. - aBlock value. aBlock value. aBlock value. aBlock value. - aBlock value. aBlock value. aBlock value. aBlock value - ]! ! -!Integer methodsFor: 'enumerating' stamp: 'sqr 11/2/2019 20:17:15' prior: 16859496! - timesRepeat: aBlock - "Evaluate the argument, aBlock, the number of times represented by the - receiver." - - | toGo thisRound | - toGo := self. - [toGo > 0] whileTrue: - [ - thisRound := toGo min: SmallInteger maxVal. - thisRound timesRepeat: aBlock. - toGo := toGo - thisRound - ]! ! - -LargePositiveInteger removeSelector: #timesRepeat:! - -!methodRemoval: LargePositiveInteger #timesRepeat: stamp: 'jmv 11/15/2019 09:44:51'! -timesRepeat: aBlock - "Evaluate the argument, aBlock, the number of times represented by the - receiver." - - | toGo thisRound count | - toGo := self. - [toGo > 0] whileTrue: - [ - thisRound := toGo min: SmallInteger maxVal. - count := 1. - [count <= thisRound] whileTrue: - [ - aBlock value. - count := count + 1 - ]. - toGo := toGo - thisRound - ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3946-faster-timesRepeatAndresValloud-2019Nov02-20h00m-sqr.1.cs.st----! - -'From Cuis 5.0 [latest update: #3946] on 7 November 2019 at 2:09:32 pm'! -!LargePositiveInteger methodsFor: 'enumerating' stamp: 'sqr 11/2/2019 20:17:15'! - timesRepeat: aBlock - "Evaluate the argument, aBlock, the number of times represented by the - receiver." - - | toGo thisRound | - toGo := self. - [toGo > 0] whileTrue: - [ - thisRound := toGo min: SmallInteger maxVal. - thisRound timesRepeat: aBlock. - toGo := toGo - thisRound - ]! ! -!Integer methodsFor: 'enumerating' stamp: '' prior: 50481598! - timesRepeat: aBlock - "Evaluate the argument, aBlock, the number of times represented by the - receiver." - - | count | - count _ 1. - [count <= self] - whileTrue: - [aBlock value. - count _ count + 1]! ! -!Integer methodsFor: 'testing' stamp: 'dtl 1/23/2010 14:16' prior: 50477244! - isPrime - "Answer true if the receiver is a prime number. See isProbablyPrime for a probabilistic - implementation that is much faster for large integers, and that is correct to an extremely - high statistical level of confidence (effectively deterministic)." - - self <= 1 ifTrue: [ ^false ]. - self even ifTrue: [ ^self = 2]. - 3 to: self sqrtFloor by: 2 do: [ :each | - self \\ each = 0 ifTrue: [ ^false ] ]. - ^true! ! - -SmallInteger removeSelector: #timesRepeat:! - -!methodRemoval: SmallInteger #timesRepeat: stamp: 'jmv 11/15/2019 09:44:51'! -timesRepeat: aBlock - "Evaluate the argument, aBlock, the number of times represented by the - receiver." - - self < 1 ifTrue: [^self]. - 1 to: (self bitAnd: 31) do: [:x | aBlock value]. - 1 to: (self bitAnd: -32) by: 32 do: - [:x | - aBlock value. aBlock value. aBlock value. aBlock value. - aBlock value. aBlock value. aBlock value. aBlock value. - aBlock value. aBlock value. aBlock value. aBlock value. - aBlock value. aBlock value. aBlock value. aBlock value. - aBlock value. aBlock value. aBlock value. aBlock value. - aBlock value. aBlock value. aBlock value. aBlock value. - aBlock value. aBlock value. aBlock value. aBlock value. - aBlock value. aBlock value. aBlock value. aBlock value - ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3947-RecentFasterAlternativesMovedToOwnPackage-JuanVuletich-2019Nov07-14h09m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3924] on 22 October 2019 at 4:56:30 pm'! -!Compiler commentStamp: 'jmv 10/22/2019 16:55:21' prior: 16821828! - The compiler accepts Smalltalk source code and compiles it with respect to a given class. The user of the compiler supplies a context so that temporary variables are accessible during compilation. If there is an error, a requestor is sent the message notify:at:in: so that the error message can be displayed. If there is no error, then the result of compilation is a MethodNode, which is the root of a parse tree whose nodes are kinds of ParseNodes. The parse tree can be sent messages to (1) generate code for a CompiledMethod (this is done for compiling methods or evaluating expressions); (2) pretty-print the code (for formatting); or (3) produce a map from object code back to source code (used by debugger program-counter selection). See also Parser, Encoder, ParseNode. - -See http://www.whysmalltalk.com/articles/bykov/HitchHiker.htm! -!Scanner commentStamp: 'jmv 10/22/2019 16:56:07' prior: 16903621! - I scan a string or text, picking out Smalltalk syntactic tokens. I look one character ahead. I put each token found into the instance variable, token, and its type (a Symbol) into the variable, tokenType. At the end of the input stream, I pretend to see an endless sequence of special characters called doIts. - -Instance Variables - aheadChar: - buffer: - currentComment: - hereChar: - mark: - source: - token: - tokenType: - typeTable: - -aheadChar - - the next character in the input stream - -buffer - - a reusable WriteStream on a String which is used for building strings. Shouldn't be used from multiple methods without resetting. - -currentComment - - an OrderedCollection of strings which contain all comments between the current token and the previous token or the beginning of the source. - -hereChar - - the current character - -mark - - the position of the current token in the source stream - -source - - the input stream of characters - -token - - the current token - -tokenType - - the type of the current token. The possible token types are: #binary, #character, #colon, #doIt, #keyword, #leftArrow, #leftBrace, #leftBracket, #leftParenthesis, #literal, #period, #rightBrace, #rightBracket, #rightParenthesis, #semicolon, #string, #upArrow, #verticalBar, #word, #xBinary, #xColon, #xDelimiter, #xDigit, #xDollar, #xDoubleQuote, #xLetter, #xLitQuote, #xSingleQuote, #xUnderscore - -typeTable - - an array that maps each an evaluable tokenType to each character with asciiValue between 0 and 255 - -See http://www.whysmalltalk.com/articles/bykov/HitchHiker.htm! -!Parser commentStamp: 'jmv 10/22/2019 16:56:12' prior: 16885486! - I parse Smalltalk syntax and create a MethodNode that is the root of the parse tree. I look one token ahead. - -See http://www.whysmalltalk.com/articles/bykov/HitchHiker.htm! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3948-CompilerCommentTweak-JuanVuletich-2019Oct22-16h55m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3948] on 7 November 2019 at 5:58:12 pm'! - -LargePositiveInteger removeSelector: #timesRepeat:! - -!methodRemoval: LargePositiveInteger #timesRepeat: stamp: 'jmv 11/15/2019 09:44:51'! -timesRepeat: aBlock - "Evaluate the argument, aBlock, the number of times represented by the - receiver." - - | toGo thisRound | - toGo := self. - [toGo > 0] whileTrue: - [ - thisRound := toGo min: SmallInteger maxVal. - thisRound timesRepeat: aBlock. - toGo := toGo - thisRound - ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3949-LargeInteger-timesRepeat-toPerfImprovPck-JuanVuletich-2019Nov07-17h57m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3949] on 7 November 2019 at 7:30:54 pm'! -!MenuMorph methodsFor: 'modal control' stamp: 'jmv 11/7/2019 19:16:35' prior: 50340012! - invokeModal: allowKeyboardControl - "Invoke this menu and don't return until the user has chosen a value. If the allowKeyboarControl boolean is true, permit keyboard control of the menu - See senders of this method for finding out how to use modal menu morphs." - | w oldFocus actHand delay | - w _ self runningWorld. - actHand _ w activeHand. - oldFocus _ actHand keyboardFocus. - w doOneMinimalCycleNow. - self - popUpAt: actHand morphPosition - forHand: actHand - allowKeyboard: allowKeyboardControl. - self isModalInvokationDone: false. - delay _ Delay forSeconds: 0.1. - [ self isInWorld and: [self isModalInvokationDone not] ] whileTrue: [ w doOneMinimalCycleNow. delay wait ]. - self delete. - oldFocus ifNotNil: [ actHand newKeyboardFocus: oldFocus ]. - ^ self modalSelection! ! -!MVCMenuMorph methodsFor: 'invoking' stamp: 'jmv 11/7/2019 19:14:21' prior: 50395747! - invokeAt: aPoint allowKeyboard: aBoolean - "Add this menu to the given world centered at the given point. Wait for the user to make a selection and answer it. The selection value returned is an integer in keeping with PopUpMenu, if the menu is converted from an MVC-style menu." - "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop." - |actHand w oldFocus delay | - w _ self runningWorld. - actHand _ w activeHand. - oldFocus _ actHand keyboardFocus. - w doOneMinimalCycleNow. - self - popUpAt: aPoint - forHand: actHand - allowKeyboard: aBoolean. - done _ false. - delay _ Delay forSeconds: 0.1. - [ done not and: [self isInWorld] ] whileTrue: [ w doOneMinimalCycleNow. delay wait ]. - self delete. - oldFocus ifNotNil: [ actHand newKeyboardFocus: oldFocus ]. - ^ mvcSelection ! ! -!FillInTheBlankMorph methodsFor: 'invoking' stamp: 'jmv 11/7/2019 19:15:41' prior: 50340072! -getUserResponse - "Wait for the user to accept or cancel, and answer the result string. Answers the empty string if the user cancels." - "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop." - - | w delay | - w _ self world. - w isNil ifTrue: [^ response]. - done _ false. - textPane focusText. - delay _ Delay forSeconds: 0.1. - [done] whileFalse: [ w doOneMinimalCycleNow. delay wait ]. - self delete. - w doOneMinimalCycleNow. - ^ response -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3950-FixHighCPUUsageOnMenus-JuanVuletich-2019Nov07-19h30m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3944] on 31 October 2019 at 3:42:59 pm'! -!SystemDictionary methodsFor: 'image, changes name' stamp: 'HAW 10/31/2019 13:15:44' prior: 50478283! - defaultUserChangesName - "Answer the default full path to the changes file corresponding to the image file name." - " - Smalltalk defaultUserChangesName - " - ^(FileIOAccessor default baseNameFor: self imageName), '.user.changes'! ! - -Preferences class removeSelector: #userChangesFileName! - -!methodRemoval: Preferences class #userChangesFileName stamp: 'jmv 11/15/2019 09:44:51'! -userChangesFileName - ^ self - valueOfFlag: #userChangesFileName - ifAbsent: [ self defaultUserChangesFileName ].! - -Preferences class removeSelector: #defaultUserChangesFileName! - -!methodRemoval: Preferences class #defaultUserChangesFileName stamp: 'jmv 11/15/2019 09:44:51'! -defaultUserChangesFileName - "Answer the default full path to the changes file corresponding to the image file name." - - ^(FileIOAccessor default baseNameFor: Smalltalk imageName), '.user.changes'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3951-UserChangesFileName-HernanWilkinson-2019Oct31-13h15m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3944] on 1 November 2019 at 4:37:21 pm'! -!Preferences class methodsFor: 'user changes' stamp: 'HAW 10/31/2019 16:16:59'! - use: aFileExtension asUserChangesFileNameExtensionWhile: aBlock - - ^[ self parameters at: #userChangesFileNameExtension put: aFileExtension. - aBlock value ] ensure: [ self parameters removeKey: #userChangesFileNameExtension ifAbsent: [] ].! ! -!Preferences class methodsFor: 'user changes' stamp: 'HAW 10/31/2019 16:16:15'! - userChangesFileNameExtension - - ^self parameters at: #userChangesFileNameExtension ifAbsent: [ '.user.changes' ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3952-UserChangesFileExtention-HernanWilkinson-2019Oct31-15h42m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3944] on 1 November 2019 at 4:37:44 pm'! -!SystemDictionary methodsFor: 'image, changes name' stamp: 'HAW 11/1/2019 16:37:26' prior: 50481913! - defaultUserChangesName - "Answer the default full path to the changes file corresponding to the image file name." - " - Smalltalk defaultUserChangesName - " - ^(FileIOAccessor default baseNameFor: self imageName), - Preferences userChangesFileNameExtension ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3953-defaultUserChangesName-HernanWilkinson-2019Nov01-16h37m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3953] on 9 November 2019 at 10:47:28 am'! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'HAW 11/9/2019 10:35:24'! - definitionPreambleWithoutStamp - - ^'classDefinition: ', self name printString, ' category: ', self category printString! ! -!ChangeRecord methodsFor: 'testing' stamp: 'HAW 11/9/2019 10:44:49'! - isTestClassChange - - ^ isTest! ! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'HAW 11/9/2019 10:35:36' prior: 50481064! - definitionPreamble - - ^self definitionPreambleWithoutStamp, Utilities changeStampField! ! -!CodePackage methodsFor: 'saving' stamp: 'HAW 11/9/2019 10:41:04' prior: 16810555! - write: classes classDefinitionsOn: aStream - - classes - do: [ :class | - aStream - nextPut: $!!; nextChunkPut: class definitionPreambleWithoutStamp; newLine; - nextChunkPut: class definition; newLine; - - nextPut: $!!; nextChunkPut: class class definitionPreambleWithoutStamp; newLine; - nextChunkPut: class class definition; newLine; - - newLine ] - displayingProgress: 'Saving class definitions...'.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3954-ClassDefinitionWithoutTimeStampForPackage-HernanWilkinson-2019Nov09-10h34m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3953] on 9 November 2019 at 11:05:02 am'! -!MenuMorph methodsFor: 'modal control' stamp: 'HAW 11/9/2019 11:03:35' prior: 50481824! - invokeModal: allowKeyboardControl - "Invoke this menu and don't return until the user has chosen a value. If the allowKeyboarControl boolean is true, permit keyboard control of the menu - See senders of this method for finding out how to use modal menu morphs." - | w oldFocus actHand delay | - w _ self runningWorld. - actHand _ w activeHand. - oldFocus _ actHand keyboardFocus. - w doOneMinimalCycleNow. - self - popUpAt: actHand morphPosition - forHand: actHand - allowKeyboard: allowKeyboardControl. - self isModalInvokationDone: false. - delay _ Delay forMilliseconds: 10. - [ self isInWorld and: [self isModalInvokationDone not] ] whileTrue: [ w doOneMinimalCycleNow. delay wait ]. - self delete. - oldFocus ifNotNil: [ actHand newKeyboardFocus: oldFocus ]. - ^ self modalSelection! ! -!MVCMenuMorph methodsFor: 'invoking' stamp: 'HAW 11/9/2019 11:03:22' prior: 50481851! - invokeAt: aPoint allowKeyboard: aBoolean - "Add this menu to the given world centered at the given point. Wait for the user to make a selection and answer it. The selection value returned is an integer in keeping with PopUpMenu, if the menu is converted from an MVC-style menu." - "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop." - |actHand w oldFocus delay | - w _ self runningWorld. - actHand _ w activeHand. - oldFocus _ actHand keyboardFocus. - w doOneMinimalCycleNow. - self - popUpAt: aPoint - forHand: actHand - allowKeyboard: aBoolean. - done _ false. - delay _ Delay forMilliseconds: 10. - [ done not and: [self isInWorld] ] whileTrue: [ w doOneMinimalCycleNow. delay wait ]. - self delete. - oldFocus ifNotNil: [ actHand newKeyboardFocus: oldFocus ]. - ^ mvcSelection ! ! -!FillInTheBlankMorph methodsFor: 'invoking' stamp: 'HAW 11/9/2019 11:02:25' prior: 50481883! - getUserResponse - "Wait for the user to accept or cancel, and answer the result string. Answers the empty string if the user cancels." - "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop." - - | w delay | - w _ self world. - w isNil ifTrue: [^ response]. - done _ false. - textPane focusText. - delay _ Delay forMilliseconds: 10. - [done] whileFalse: [ w doOneMinimalCycleNow. delay wait. ]. - self delete. - w doOneMinimalCycleNow. - ^ response -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3955-FixHighCPUUsageOnMenusShorterDelay-HernanWilkinson-2019Nov09-10h47m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3955] on 9 November 2019 at 3:37:56 pm'! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'HAW 11/9/2019 15:35:45' prior: 16806760! - fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex - "File a description of the receiver on aFileStream. If the boolean - argument, moveSource, is true, then set the trailing bytes to the position - of aFileStream and to fileIndex in order to indicate where to find the - source code." - - aFileStream nextPut: $!!; nextChunkPut: self definitionPreambleWithoutStamp; newLine. - aFileStream nextChunkPut: self definition. - - self organization - putCommentOnFile: aFileStream - numbered: fileIndex - moveSource: moveSource - forClass: self. - self organization categories do: [ :heading | - self fileOutCategory: heading - on: aFileStream - moveSource: moveSource - toFile: fileIndex]! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 11/9/2019 15:35:19' prior: 16798519! - fileOutPSFor: class on: stream - "Write out removals and initialization for this class." - - | dict classRecord currentDef | - classRecord _ changeRecords at: class name ifAbsent: [^ self]. - dict _ classRecord methodChangeTypes. - ((dict includesKey: #initialize) and: [ class isMeta ]) ifTrue: [ - stream nextChunkPut: class soleInstance name, ' initialize'; newLine]. - ((classRecord includesChangeType: #change) - and: [(currentDef _ class definition) ~= (self fatDefForClass: class)]) ifTrue: [ - stream - nextPut: $!!; - nextChunkPut: class definitionPreambleWithoutStamp; newLine; - nextChunkPut: currentDef; newLine]. - (classRecord includesChangeType: #reorganize) ifTrue: [ - class fileOutOrganizationOn: stream. - stream newLine]! ! -!ChangeSet methodsFor: 'private' stamp: 'HAW 11/9/2019 15:37:00' prior: 16798678! - fileOutClassDefinition: class on: stream - "Write out class definition for the given class on the given stream, if the class definition was added or changed." - - (self atClass: class includes: #rename) ifTrue: [ - stream nextChunkPut: 'Smalltalk renameClassNamed: #', (self oldNameFor: class), ' as: #', class name; newLine]. - - (self atClass: class includes: #change) ifTrue: [ "fat definition only needed for changes" - stream - nextPut: $!!; nextChunkPut: class definitionPreambleWithoutStamp; newLine; - nextChunkPut: (self fatDefForClass: class); newLine. - ] ifFalse: [ - (self atClass: class includes: #add) ifTrue: [ "use current definition for add" - stream - nextPut: $!!; nextChunkPut: class definitionPreambleWithoutStamp; newLine; - nextChunkPut: class definition; newLine. - ]. - ]. - - (self atClass: class includes: #comment) ifTrue: [ - class theNonMetaClass organization putCommentOnFile: stream numbered: 0 moveSource: false forClass: class theNonMetaClass. - stream newLine]. - -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3956-RemoveFileOutClassDefinitionStamp-HernanWilkinson-2019Nov09-15h33m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3956] on 12 November 2019 at 11:29:19 am'! - -Refactoring subclass: #PushDownMethod - instanceVariableNames: 'method' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #PushDownMethod category: #'Tools-Refactoring' stamp: 'jmv 11/15/2019 09:44:51'! -Refactoring subclass: #PushDownMethod - instanceVariableNames: 'method' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 11/12/2019 11:25:59'! - pushDownSelector - - model selectedMessageName ifNotNil: [ :selectedSelector | - (PushDownMethod for: model selectedClassOrMetaClass>>selectedSelector) apply. - model reformulateList. - model changed: #messageList. - model setClassOrganizer ].! ! -!PushDownMethod methodsFor: 'initialization' stamp: 'HAW 11/12/2019 11:26:37'! - initializeFor: aMethodToPushDown - - method := aMethodToPushDown ! ! -!PushDownMethod methodsFor: 'applying' stamp: 'HAW 11/12/2019 11:27:19'! - apply - - | methodCategory | - - methodCategory := method methodClass organization categoryOfElement: method selector. - method methodClass subclassesDo: [:subClass | - subClass - compile: method sourceCode - classified: methodCategory. - ]. - - method methodClass removeSelector: method selector. - ! ! -!PushDownMethod class methodsFor: 'instance creation' stamp: 'HAW 11/12/2019 11:26:28'! - for: aMethodToPushDown - - ^self new initializeFor: aMethodToPushDown ! ! -!RefactoringMenues class methodsFor: 'browser menues' stamp: 'HAW 11/12/2019 11:28:03' prior: 50448126! - messsageRefactoringMenuOptions - - ^ `{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'rename... (R)'. - #selector -> #renameSelector. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 15. - #label -> 'change keyword order...'. - #selector -> #changeKeywordOrder. - #icon -> #sendReceiveIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'add parameter...'. - #selector -> #addParameter. - #icon -> #listAddIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'remove parameter...'. - #selector -> #removeParameter. - #icon -> #listRemoveIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'push up'. - #selector -> #pushUpSelector. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 50. - #label -> 'push down'. - #selector -> #pushDownSelector. - #icon -> #goBottomIcon - } asDictionary. - }`. - - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3957-PushDownRefactoring-HernanWilkinson-2019Nov12-08h51m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3956] on 12 November 2019 at 11:49:46 am'! - -Refactoring subclass: #PushUpMethod - instanceVariableNames: 'method' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #PushUpMethod category: #'Tools-Refactoring' stamp: 'jmv 11/15/2019 09:44:51'! -Refactoring subclass: #PushUpMethod - instanceVariableNames: 'method' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #PushUpMethodApplier - instanceVariableNames: 'browser methodToPushUp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #PushUpMethodApplier category: #'Tools-Refactoring' stamp: 'jmv 11/15/2019 09:44:51'! -RefactoringApplier subclass: #PushUpMethodApplier - instanceVariableNames: 'browser methodToPushUp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!CompiledMethod methodsFor: 'testing' stamp: 'MSC 10/14/2019 13:44:00'! - accessesInstanceVariable: aName - - ^(self readsInstanceVariable: aName) or: [self writesInstanceVariable: aName].! ! -!PushUpMethod class methodsFor: 'pre-conditions' stamp: 'HAW 11/12/2019 11:30:59'! - assertIsNotAccessingInstanceVariable: aMethodToPushUp - - aMethodToPushUp methodClass instVarNames - do: [ :instVarName | - (aMethodToPushUp accessesInstanceVariable: instVarName) ifTrue: [self signalMethodCannotAccessInstanceVariable]].! ! -!PushUpMethod class methodsFor: 'pre-conditions' stamp: 'MSC 10/14/2019 20:57:57'! - assertIsValidToPushUpMethod: aMethodToPushUp - - self assertIsNotAccessingInstanceVariable: aMethodToPushUp. -! ! -!PushUpMethod class methodsFor: 'warnings' stamp: 'MSC 10/19/2019 23:33:15'! - warnIfExistMethodToPushUpOnSuperClass: aMethodToPushUp - - ((aMethodToPushUp methodClass superclass) methodDict includesKey: aMethodToPushUp selector) - ifTrue: [self refactoringWarning: self warningMesssageForExistMethodToPushUpOnSuperClass ].! ! -!PushUpMethod class methodsFor: 'warnings' stamp: 'MSC 10/19/2019 22:41:32'! - warnIsValidToPushUpMethod: aMethodToPushUp - - self warnIfExistMethodToPushUpOnSuperClass: aMethodToPushUp. -! ! -!PushUpMethod class methodsFor: 'warnings' stamp: 'HAW 11/12/2019 11:39:38'! - warningMesssageForExistMethodToPushUpOnSuperClass - - ^'Method already exist in superclass'. - - ! ! -!PushUpMethod class methodsFor: 'exceptions' stamp: 'HAW 11/12/2019 11:38:58'! - errorMessageForMethodCannotAccessInstanceVariable - - ^ 'Can not push up a method that access an instance variable'! ! -!PushUpMethod class methodsFor: 'exceptions' stamp: 'MSC 10/19/2019 23:29:03'! - signalMethodCannotAccessInstanceVariable - - self refactoringError: self errorMessageForMethodCannotAccessInstanceVariable! ! -!PushUpMethodApplier methodsFor: 'initialization' stamp: 'MSC 10/14/2019 13:09:53'! - initializeOn: aBrowser for: aMethodToPushUp - - browser := aBrowser. - methodToPushUp := aMethodToPushUp.! ! -!PushUpMethodApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 11/12/2019 11:41:50'! - requestRefactoringParameters - - ! ! -!PushUpMethodApplier methodsFor: 'refactoring - creation' stamp: 'MSC 10/14/2019 19:37:02'! - createRefactoring - - ^self refactoringClass for: methodToPushUp.! ! -!PushUpMethodApplier methodsFor: 'refactoring - creation' stamp: 'MSC 10/14/2019 19:36:48'! - refactoringClass - - ^PushUpMethod! ! -!PushUpMethodApplier methodsFor: 'refactoring - changes' stamp: 'MSC 10/14/2019 13:10:22'! - informChangesToBrowser - - | classMethod | - - classMethod := methodToPushUp methodClass asString. - - browser classListIndex: (browser classListIndexOf: classMethod).! ! -!PushUpMethodApplier methodsFor: 'refactoring - changes' stamp: 'MSC 10/14/2019 13:09:46'! - showChanges - - self informChangesToBrowser.! ! -!PushUpMethodApplier class methodsFor: 'instance creation' stamp: 'MSC 10/14/2019 12:11:10'! - on: aBrowser for: aMethodToPushUp - - ^self new initializeOn: aBrowser for: aMethodToPushUp ! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 11/12/2019 11:44:45' prior: 50451689! - pushUpSelector - - model selectedMessageName ifNotNil: [ :selectedSelector | - (PushUpMethodApplier on: model for: model selectedClassOrMetaClass>>selectedSelector) value ].! ! -!PushUpMethod methodsFor: 'initialization' stamp: 'HAW 8/18/2018 11:44:09' prior: 50440570! - initializeFor: aMethodToPushup - - method := aMethodToPushup ! ! -!PushUpMethod methodsFor: 'applying' stamp: 'HAW 3/4/2019 15:23:40' prior: 50443987! - apply - - | methodCategory | - - methodCategory := method methodClass organization categoryOfElement: method selector. - method methodClass superclass - compile: method sourceCode - classified: methodCategory. - - method methodClass removeSelector: method selector. - ! ! -!PushUpMethod class methodsFor: 'instance creation' stamp: 'MSC 10/19/2019 22:42:30' prior: 50440587! - for: aMethodToPushUp - - self assertIsValidToPushUpMethod: aMethodToPushUp. - self warnIsValidToPushUpMethod: aMethodToPushUp. - - ^self new initializeFor: aMethodToPushUp! ! - -PushUpMethodApplier removeSelector: #askConfirmation! - -PushUpMethodApplier removeSelector: #confirmationMessageText! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3958-PushUpImprovement-HernanWilkinson-2019Nov12-11h30m-HAW.1.cs.st----! - -----SNAPSHOT----(15 November 2019 09:44:56) Cuis5.0-3958-32.image priorSource: 4530822! - -----QUIT----(15 November 2019 09:45:04) Cuis5.0-3958-32.image priorSource: 4826656! - -----STARTUP---- (15 November 2019 10:08:13) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-3958-32.image! - - -'From Cuis 5.0 [latest update: #3958] on 15 November 2019 at 10:06:34 am'! -!ChangeSet class methodsFor: 'change set to use' stamp: 'jmv 11/15/2019 10:06:10'! - installingString - ^Installing ! ! -!Utilities class methodsFor: 'identification' stamp: 'jmv 11/15/2019 10:02:06' prior: 16940644! - authorInitials - "Answer the initials to be used to identify the current code author. " - " - Utilities clearAuthor; authorInitials - " - ChangeSet notInstallOrTestRun ifFalse: [ - ^ ChangeSet installingString ]. - - [AuthorInitials isNil or: [AuthorInitials isEmpty]] whileTrue: [self setAuthor]. - ^ AuthorInitials! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3959-DontAskInitialsForPackageInstall-JuanVuletich-2019Nov15-10h06m-jmv.1.cs.st----! - -----SNAPSHOT----(15 November 2019 10:08:23) Cuis5.0-3959-32.image priorSource: 4826745! - -----QUIT----(15 November 2019 10:08:33) Cuis5.0-3959-32.image priorSource: 4827783! - -----STARTUP---- (11 January 2020 17:57:39) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-3959-32.image! - - -'From Cuis 5.0 [latest update: #3958] on 16 November 2019 at 1:10:59 pm'! -!NewInstanceVariablePrecondition methodsFor: 'evaluating' stamp: 'HAW 11/13/2019 20:46:26'! - valueForSuperclass - - self assertIsNotEmpty. - self assertIsNotAReservedName. - self assertIsValidInstanceVariableName. - self assertIsNotAlreadyDefinedInSuperclasses. - - ! ! -!NewInstanceVariablePrecondition methodsFor: 'pre-conditions' stamp: 'HAW 11/13/2019 20:47:54'! - assertIsNotAlreadyDefinedInSuperclasses - - ^ (classToAddInstVar classThatDefinesInstanceVariable: instVarName) - ifNotNil: [ :definingClasses | self signalAlreadyDefinedInAll: definingClasses ] - ! ! -!NewInstanceVariablePrecondition methodsFor: 'pre-conditions' stamp: 'HAW 11/13/2019 20:43:43'! - assertIsNotDefinedInMethods - - | methodsDefiningNewVariable | - - methodsDefiningNewVariable := self methodsDefiningNewVariable. - - methodsDefiningNewVariable notEmpty ifTrue: [ self signalNewVariable: instVarName willBeHiddenAtAll: methodsDefiningNewVariable ].! ! -!ParseNodeVisitor methodsFor: 'visiting' stamp: 'HAW 11/16/2019 13:09:55' prior: 16885384! - visitMessageNode: aMessageNode - - aMessageNode receiver accept: self. - aMessageNode selector accept: self. - aMessageNode argumentsInEvaluationOrder do: [:argument| argument accept: self]! ! -!NewInstanceVariablePrecondition methodsFor: 'evaluating' stamp: 'HAW 11/13/2019 20:43:43' prior: 50444663! - value - - self assertIsNotEmpty. - self assertIsNotAReservedName. - self assertIsValidInstanceVariableName. - self assertIsNotAlreadyDefined. - - self assertIsNotDefinedInMethods.! ! - -NewInstanceVariablePrecondition removeSelector: #assertIsDefinedInMethods! - -!methodRemoval: NewInstanceVariablePrecondition #assertIsDefinedInMethods stamp: 'Install-3960-NewInstVarPreconditionForSuperclass-HernanWilkinson-2019Nov12-15h55m-HAW.1.cs.st 1/11/2020 17:57:44'! -assertIsDefinedInMethods - - | methodsDefiningNewVariable | - - methodsDefiningNewVariable := self methodsDefiningNewVariable. - - methodsDefiningNewVariable notEmpty ifTrue: [ self signalNewVariable: instVarName willBeHiddenAtAll: methodsDefiningNewVariable ].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3960-NewInstVarPreconditionForSuperclass-HernanWilkinson-2019Nov12-15h55m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3958] on 25 November 2019 at 2:49:34 pm'! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 11/25/2019 14:47:40' prior: 50452431! - contextualRenameInClassDefinitionOf: aClassDefinitionNode in: aSelectedClass - - | analyzer cursorPosition | - - analyzer := ClassDefinitionNodeAnalyzer for: aClassDefinitionNode. - cursorPosition := self startIndex. - - (analyzer isAtSuperclass: cursorPosition) - ifTrue: [ ^self renameClassOn: self codeProvider for: analyzer superclass ]. - - (analyzer isAtClassName: cursorPosition) - ifTrue: [ ^self renameClassOn: self codeProvider for: aSelectedClass ]. - - (analyzer isAtInstanceVariables: cursorPosition) - ifTrue: [ |selection variableToRename| - selection := self selectedString. - variableToRename := selection isEmpty ifTrue: [ self wordUnderCursor ] ifFalse: [ selection ]. - ^self renameInstanceVariableOn: self codeProvider for: variableToRename at: aSelectedClass ]. - - (analyzer isAtCategory: cursorPosition) - ifTrue: [ - "I'm sure codeProvider is a Browser - Hernan" - ^self codeProvider renameSystemCategory ]. - - morph flash - -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3961-SelectedInstVarRenameOnClassDefinitionFix-HernanWilkinson-2019Nov25-14h45m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3958] on 27 November 2019 at 4:38:55 pm'! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 8/18/2018 16:30:01' prior: 50439238! - assertIsValidKeywordForNewParameter: aNewKeyword - - (aNewKeyword isKeyword and: [aNewKeyword numArgs = 1 ]) ifFalse: [ self signalNotValidKeywordForNewParameter]! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 11/27/2019 16:26:50' prior: 50439414! - notValidKeywordForNewParameterErrorMessage - - ^'New keyword can not be unary or binary. It has to be a keyword with one parameter'! ! -!AddParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 11/27/2019 16:34:16' prior: 50441843! - askNewKeyword - - | enteredString | - - enteredString := (self request: 'Enter keyword for new parameter') withBlanksTrimmed. - (enteredString endsWith: ':') ifFalse: [ enteredString := enteredString, ':' ]. - newKeyword := enteredString asSymbol. - self refactoringClass assertIsValidKeywordForNewParameter: newKeyword! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3962-CuisCore-HernanWilkinson-2019Nov27-16h25m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3962] on 4 December 2019 at 11:18:08 am'! - -RefactoringApplier subclass: #RenameClassApplier - instanceVariableNames: 'browser classToRename newClassName ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameClassApplier category: #'Tools-Refactoring' stamp: 'Install-3963-RenameClassLogAndRefreshFix-HernanWilkinson-2019Dec03-16h25m-HAW.1.cs.st 1/11/2020 17:57:44'! -RefactoringApplier subclass: #RenameClassApplier - instanceVariableNames: 'browser classToRename newClassName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!Browser methodsFor: 'class list' stamp: 'HAW 12/4/2019 10:43:04'! - originalSelectedClassName - "Returns the selectedClassName no matter if it exits or not. - It is used for refreshing the browser when renaming a class - Hernan" - - ^selectedClassName! ! -!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'HAW 12/3/2019 18:08:42'! - aboutToRenameClass: aClass from: oldClassName to: newClassName inCategory: aCategoryName - - self - triggerEvent: #aboutToRenameClass - withArguments: { aClass . oldClassName . newClassName . aCategoryName }! ! -!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'HAW 12/3/2019 18:09:31' prior: 16919116! - classRenamed: aClass from: oldClassName to: newClassName inCategory: aCategoryName - - self - triggerEvent: #classRenamed - withArguments: { aClass . oldClassName . newClassName . aCategoryName }! ! -!SystemDictionary methodsFor: 'class names' stamp: 'HAW 12/4/2019 10:54:31'! - prepareToRenameClass: aClass as: newName - - ^self prepareToRenameClass: aClass from: aClass name to: newName! ! -!SystemDictionary methodsFor: 'class names' stamp: 'HAW 12/4/2019 10:54:28'! - prepareToRenameClass: aClass from: oldName to: newName - - "Rename the class, aClass, to have the title newName." - - | oldref i category | - - category := SystemOrganization categoryOfElement: oldName. - SystemOrganization classify: newName under: category. - SystemOrganization removeElement: oldName. - oldref _ self associationAt: oldName. - self removeKey: oldName. - oldref key: newName. - self add: oldref. "Old association preserves old refs" - (Array with: StartUpList with: ShutDownList) do: - [:list | i _ list indexOf: aClass name ifAbsent: [0]. - i > 0 ifTrue: [list at: i put: newName]]. - self flushClassNameCache. - - SystemChangeNotifier uniqueInstance aboutToRenameClass: aClass from: oldName to: newName inCategory: category. - ! ! -!SystemDictionary methodsFor: 'class names' stamp: 'HAW 12/3/2019 18:11:03'! - renamedClass: aClass from: oldName - - | newName | - - newName := aClass name. - - SystemChangeNotifier uniqueInstance classRenamed: aClass from: oldName to: newName inCategory: aClass category. - Smalltalk - logChange: 'Smalltalk renameClassNamed: #', oldName, ' as: #', newName - preamble: 'classRenamed: #', oldName, ' as: #', newName, Utilities changeStampField! ! -!CodeWindow methodsFor: 'updating' stamp: 'HAW 12/3/2019 17:05:07'! - classRenamed: aClass from: oldClassName to: newClassName inCategory: aCategoryName - - "Do nothing here. Subclasses should implement if necessary - Hernan"! ! -!CodeWindow methodsFor: 'notification actions' stamp: 'HAW 12/4/2019 11:01:38'! - initializeNotificationActions - - "Avoid double registration" - self - removeNotificationActions; - registerNotificationActionsIfModelNotNil -! ! -!CodeWindow methodsFor: 'notification actions' stamp: 'HAW 12/4/2019 11:02:26'! -registerNotificationActions - - SystemChangeNotifier uniqueInstance - when: #classAdded send: #updateListsAndCode to: self; - when: #classCommented send: #updateListsAndCode to: self; - when: #classDefinitionChanged send: #updateListsAndCode to: self; - when: #classRecategorized send: #updateListsAndCode to: self; - when: #classRemoved send: #updateListsAndCode to: self; - when: #classRenamed send: #classRenamed:from:to:inCategory: to: self; - when: #classReorganized send: #updateListsAndCode to: self; - when: #methodAdded send: #updateListsAndCode to: self; - when: #methodAddedInProtocol send: #updateListsAndCode to: self; - when: #methodChanged send: #updateListsAndCode to: self; - when: #methodRemoved send: #updateListsAndCode to: self; - when: #selectorRecategorized send: #updateListsAndCode to: self ! ! -!CodeWindow methodsFor: 'notification actions' stamp: 'HAW 12/4/2019 11:02:39'! - registerNotificationActionsIfModelNotNil - - "model set to nil on delete" - model ifNotNil: [ self registerNotificationActions ] ! ! -!CodeWindow methodsFor: 'notification actions' stamp: 'HAW 12/4/2019 11:01:04'! - removeNotificationActions - - SystemChangeNotifier uniqueInstance removeActionsWithReceiver: self. -! ! -!BrowserWindow methodsFor: 'updating' stamp: 'HAW 12/4/2019 10:41:57'! - classRenamed: aClass from: oldClassName to: newClassName inCategory: aCategoryName - - | currentSelectedClass | - - self canDiscardEdits ifTrue: [ - self model selectedSystemCategoryName = aCategoryName ifTrue: [ - currentSelectedClass := self model selectedClass. - currentSelectedClass ifNil: [ - self model originalSelectedClassName = oldClassName ifTrue: [ - currentSelectedClass := aClass ]]. - - self model changed: #classList. - self model selectClass: currentSelectedClass ]]! ! -!DebuggerWindow methodsFor: 'notification actions' stamp: 'HAW 12/4/2019 11:09:30'! - registerNotificationActions - - super registerNotificationActions. - model when: #closeViews send: #closeView to: self ! ! -!PreDebugWindow methodsFor: 'notification actions' stamp: 'HAW 12/4/2019 11:09:19'! - registerNotificationActions - - super registerNotificationActions. - model when: #closeViews send: #closeView to: self ! ! -!ChangeSet methodsFor: 'system change notifications' stamp: 'HAW 12/3/2019 18:06:13'! - aboutToRenameClass: aClass from: oldClassName to: newClassName inCategory: aCategoryName - - self noteRenameClass: aClass as: newClassName! ! -!ChangeSet class methodsFor: 'class initialization' stamp: 'HAW 12/4/2019 10:48:12'! - initializeNotificationActions - - "Avoid double registration" - self - removeNotificationActions; - registerNotificationActions ! ! -!ChangeSet class methodsFor: 'class initialization' stamp: 'HAW 12/4/2019 11:09:58'! - registerNotificationActions - - "Only sent when model is not nil - Hernan" - SystemChangeNotifier uniqueInstance - when: #classAdded send: #classAdded:inCategory: to: self; - when: #classCommented send: #classCommented: to: self; - when: #classDefinitionChanged send: #classDefinitionChangedFrom:to: to: self; - when: #classRecategorized send: #classRecategorized:from:to: to: self; - when: #classRemoved send: #classRemoved:fromCategory: to: self; - when: #aboutToRenameClass send: #aboutToRenameClass:from:to:inCategory: to: self; - when: #classReorganized send: #classReorganized: to: self; - when: #methodAdded send: #methodAdded:selector:inClass:requestor: to: self; - when: #methodAddedInProtocol send: #methodAdded:selector:inProtocol:class:requestor: to: self; - when: #methodChanged send: #methodChangedFrom:to:selector:inClass:requestor: to: self; - when: #methodRemoved send: #methodRemoved:selector:inProtocol:class: to: self; - when: #selectorRecategorized send: #selectorRecategorized:from:to:inClass: to: self! ! -!ChangeSet class methodsFor: 'class initialization' stamp: 'HAW 12/4/2019 10:47:36'! - removeNotificationActions - - SystemChangeNotifier uniqueInstance removeActionsWithReceiver: self. - - ! ! -!ChangeSet class methodsFor: 'system change notifications' stamp: 'HAW 12/3/2019 18:06:45'! - aboutToRenameClass: aClass from: oldClassName to: newClassName inCategory: aCategoryName - - | packageOrNil | - packageOrNil _ CodePackage - packageOfSystemCategory: aCategoryName ifNone: nil. - (self changeSetForPackage: packageOrNil) ifNotNil: [ :changeSet | - changeSet - aboutToRenameClass: aClass - from: oldClassName - to: newClassName - inCategory: aCategoryName ]. - packageOrNil ifNotNil: [ - packageOrNil hasUnsavedChanges: true ]! ! -!RenameClassApplier methodsFor: 'initialization' stamp: 'HAW 12/3/2019 17:58:34'! - initializeFor: aClass - - classToRename := aClass. - ! ! -!RenameClassApplier class methodsFor: 'instance creation' stamp: 'HAW 12/3/2019 17:58:52'! - for: aClass - - ^self new initializeFor: aClass! ! -!Browser methodsFor: 'refactorings' stamp: 'HAW 12/3/2019 17:59:08' prior: 50442936! - renameClass - - self selectedClassOrMetaClass ifNotNil: [ :aBehavior | - (RenameClassApplier for: aBehavior theNonMetaClass) value ].! ! -!Class methodsFor: 'class name' stamp: 'HAW 12/4/2019 10:54:09' prior: 50443114! - safeRenameTo: newName - - | oldName | - - oldName := name. - Smalltalk prepareToRenameClass: self as: newName. - name _ newName. - Smalltalk renamedClass: self from: oldName! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 12/3/2019 17:59:14' prior: 50443778! - renameClassOn: aBrowser for: aClassToRefactor - - (RenameClassApplier for: aClassToRefactor) value! ! -!CodeWindow methodsFor: 'initialization' stamp: 'HAW 12/4/2019 11:04:33' prior: 16813837! - model: anObject - "Set my model and make me me a dependent of the given object." - - super model: anObject. - - self initializeNotificationActions! ! -!ChangeSet class methodsFor: 'class initialization' stamp: 'HAW 12/4/2019 10:47:19' prior: 16798835! - initialize - " - ChangeSet initialize - " - AllChangeSets _ OrderedCollection new. - - self initializeNotificationActions! ! -!RenameClassApplier methodsFor: 'refactoring - changes' stamp: 'HAW 12/3/2019 17:57:58' prior: 50442168! - showChanges - - self openChangedMethods -! ! - -RenameClassApplier class removeSelector: #on:for:! - -!methodRemoval: RenameClassApplier class #on:for: stamp: 'Install-3963-RenameClassLogAndRefreshFix-HernanWilkinson-2019Dec03-16h25m-HAW.1.cs.st 1/11/2020 17:57:44'! -on: aBrowser for: aClass - - ^self new initializeOn: aBrowser for: aClass! - -RenameClassApplier removeSelector: #initializeOn:for:! - -!methodRemoval: RenameClassApplier #initializeOn:for: stamp: 'Install-3963-RenameClassLogAndRefreshFix-HernanWilkinson-2019Dec03-16h25m-HAW.1.cs.st 1/11/2020 17:57:44'! -initializeOn: aBrowser for: aClass - - browser := aBrowser. - classToRename := aClass. - ! - -RenameClassApplier removeSelector: #informChangesToBrowser! - -!methodRemoval: RenameClassApplier #informChangesToBrowser stamp: 'Install-3963-RenameClassLogAndRefreshFix-HernanWilkinson-2019Dec03-16h25m-HAW.1.cs.st 1/11/2020 17:57:44'! -informChangesToBrowser - - browser changed: #classList. - browser selectClass: classToRename. -! - -ChangeSet class removeSelector: #classRenamed:from:to:inCategory:! - -!methodRemoval: ChangeSet class #classRenamed:from:to:inCategory: stamp: 'Install-3963-RenameClassLogAndRefreshFix-HernanWilkinson-2019Dec03-16h25m-HAW.1.cs.st 1/11/2020 17:57:44'! -classRenamed: aClass from: oldClassName to: newClassName inCategory: aCategoryName - - | packageOrNil | - packageOrNil _ CodePackage - packageOfSystemCategory: aCategoryName ifNone: nil. - (self changeSetForPackage: packageOrNil) ifNotNil: [ :changeSet | - changeSet - classRenamed: aClass - from: oldClassName - to: newClassName - inCategory: aCategoryName ]. - packageOrNil ifNotNil: [ - packageOrNil hasUnsavedChanges: true ]! - -ChangeSet removeSelector: #classRenamed:from:to:inCategory:! - -!methodRemoval: ChangeSet #classRenamed:from:to:inCategory: stamp: 'Install-3963-RenameClassLogAndRefreshFix-HernanWilkinson-2019Dec03-16h25m-HAW.1.cs.st 1/11/2020 17:57:44'! -classRenamed: aClass from: oldClassName to: newClassName inCategory: aCategoryName - - self noteRenameClass: aClass as: newClassName! - -PreDebugWindow removeSelector: #model:! - -!methodRemoval: PreDebugWindow #model: stamp: 'Install-3963-RenameClassLogAndRefreshFix-HernanWilkinson-2019Dec03-16h25m-HAW.1.cs.st 1/11/2020 17:57:44'! -model: aDebugger - super model: aDebugger. - aDebugger ifNotNil: [ - aDebugger when: #closeViews send: #closeView to: self ]! - -DebuggerWindow removeSelector: #model:! - -!methodRemoval: DebuggerWindow #model: stamp: 'Install-3963-RenameClassLogAndRefreshFix-HernanWilkinson-2019Dec03-16h25m-HAW.1.cs.st 1/11/2020 17:57:44'! -model: aDebugger - super model: aDebugger. - aDebugger ifNotNil: [ - aDebugger when: #closeViews send: #closeView to: self ]! - -SystemDictionary removeSelector: #renamedClass:from:to:! - -SystemDictionary removeSelector: #renameClass:from:to:! - -!methodRemoval: SystemDictionary #renameClass:from:to: stamp: 'Install-3963-RenameClassLogAndRefreshFix-HernanWilkinson-2019Dec03-16h25m-HAW.1.cs.st 1/11/2020 17:57:44'! -renameClass: aClass from: oldName to: newName - "Rename the class, aClass, to have the title newName." - | oldref i category | - category := SystemOrganization categoryOfElement: oldName. - SystemOrganization classify: newName under: category. - SystemOrganization removeElement: oldName. - oldref _ self associationAt: oldName. - self removeKey: oldName. - oldref key: newName. - self add: oldref. "Old association preserves old refs" - (Array with: StartUpList with: ShutDownList) do: - [:list | i _ list indexOf: aClass name ifAbsent: [0]. - i > 0 ifTrue: [list at: i put: newName]]. - self flushClassNameCache. - SystemChangeNotifier uniqueInstance classRenamed: aClass from: oldName to: newName inCategory: category! - -SystemDictionary removeSelector: #renameClass:as:! - -!methodRemoval: SystemDictionary #renameClass:as: stamp: 'Install-3963-RenameClassLogAndRefreshFix-HernanWilkinson-2019Dec03-16h25m-HAW.1.cs.st 1/11/2020 17:57:44'! -renameClass: aClass as: newName - ^self renameClass: aClass from: aClass name to: newName! - -ChangeSet initialize! - -RefactoringApplier subclass: #RenameClassApplier - instanceVariableNames: 'classToRename newClassName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameClassApplier category: #'Tools-Refactoring' stamp: 'Install-3963-RenameClassLogAndRefreshFix-HernanWilkinson-2019Dec03-16h25m-HAW.1.cs.st 1/11/2020 17:57:44'! -RefactoringApplier subclass: #RenameClassApplier - instanceVariableNames: 'classToRename newClassName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -"Postscript: -Due to changes in the rename class notification, the ChangeSet and CodeWindows -must reinitialize the notification actions" -ChangeSet initializeNotificationActions. -CodeWindow allSubInstances do: [:aCodeWindow | aCodeWindow initializeNotificationActions ]. -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3963-RenameClassLogAndRefreshFix-HernanWilkinson-2019Dec03-16h25m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3963] on 4 December 2019 at 4:17:22 pm'! - -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser selectorsClasses possibleInvalidSelectors canShowSelectorDocumentation possibleBinarySendRange ' - classVariableNames: 'AccessLock EntriesLimit Selectors ' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #SmalltalkCompleter category: #'Tools-Autocompletion' stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser selectorsClasses possibleInvalidSelectors canShowSelectorDocumentation possibleBinarySendRange' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:16:53'! - computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:17:33'! - computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:11:59'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:15:51'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:16:53'! - computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName - - textProvider computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName ! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:17:33'! - computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName - - textProvider computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName ! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:11:59'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - textProvider computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName ! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:15:51'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - textProvider computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName ! ! -!Workspace methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:15:51'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - anAutocompleter computeMessageEntriesForClassOrNil: (self classOfBindingOf: aName) ! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:16:53'! - computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:17:33'! - computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:11:59'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:15:51'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:16:53'! - computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName - - self computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName ! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:17:33'! - computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName - - ^self computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName ! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:52:45'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - contextStackIndex = 0 - ifTrue: [ anAutocompleter computeMessageEntriesForUnknowClass ] - ifFalse: [ anAutocompleter computeMessageEntriesForClass: (self receiver instVarNamed: aName) class ]! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:37:54'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - | context tempIndex | - - context := self selectedContext. - tempIndex := context tempNames indexOf: aName ifAbsent: [ ^ anAutocompleter computeMessageEntriesForUnknowClass ]. - - anAutocompleter computeMessageEntriesForClass: - (self debuggerMap namedTempAt: tempIndex in: context) class ! ! -!Inspector methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:37:55'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - anAutocompleter computeMessageEntriesForClass: (object instVarNamed: aName) class ! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:16:53'! - computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:17:33'! - computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:11:59'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:15:51'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 12/4/2019 15:18:56'! - computeEntriesOfUnaryMessageReturnNamed: aSelector at: aRange - - self subclassResponsibility ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 12/4/2019 15:37:55'! - computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel - - | id rangeType | - - canShowSelectorDocumentation _ true. - id _ allSource copyFrom: range start to: range end. - rangeType _ range rangeType. - - rangeType == #globalVar - ifTrue: [ ^self computeMessageEntriesForClass: (Smalltalk at: id asSymbol) class ]. - rangeType == #self - ifTrue: [ ^self computeMessageEntriesForClass: contextClass ]. - rangeType == #super - ifTrue: [ ^self computeMessageEntriesForClass: contextClass superclass ]. - rangeType == #true - ifTrue: [ ^self computeMessageEntriesForClass: True ]. - rangeType == #false - ifTrue: [ ^self computeMessageEntriesForClass: False ]. - rangeType == #nil - ifTrue: [ ^self computeMessageEntriesForClass: UndefinedObject ]. - rangeType == #character - ifTrue: [ ^self computeMessageEntriesForClass: id first class ]. - rangeType == #number - ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #string - ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #symbol - ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #stringSymbol - ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #instVar - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofInstVarNamed: id ]. - rangeType == #methodArg - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofTempVarNamed: id ]. - rangeType == #tempVar - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofTempVarNamed: id ]. - rangeType == #blockArg - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofBlockArgNamed: id ]. - rangeType == #blockTempVar - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofBlockTempVarNamed: id ]. - rangeType == #workspaceVar - ifTrue: [ ^self computeMessageEntriesForClassOrNil: (specificModel classOfWorkspaceVarNamed: id) ]. - rangeType == #thisContext - ifTrue: [ ^self computeMessageEntriesForClass: (specificModel classOfThisContext) ]. - rangeType == #classVar - ifTrue: [ ^self computeMessageEntriesForClassOrNil: (self classOfLocalBindingNamed: id in: contextClass) ]. - rangeType == #poolConstant - ifTrue: [ ^self computeMessageEntriesForClassOrNil: (self classOfLocalBindingNamed: id in: contextClass) ]. - rangeType == #blockEnd - ifTrue: [ ^self computeMessageEntriesForClass: BlockClosure ]. - rangeType == #arrayEnd - ifTrue: [ ^self computeMessageEntriesForClass: Array ]. - rangeType == #rightBrace - ifTrue: [ ^self computeMessageEntriesForClass: Array ]. - rangeType == #unary - ifTrue: [ ^self computeEntriesOfUnaryMessageReturnNamed: id at: range ]. - rangeType == #rightParenthesis - ifTrue: [ ^self computeMessageEntriesOfEnclosedExpressionReturnAt: range ]. - rangeType == #cascadeSeparator - ifTrue: [ ^self computeMessageEntriesOfCascadeReceiverAt: range ]. - - self computeMessageEntriesForUnknowClass - - ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 12/4/2019 15:37:54' prior: 50480287! - computeMessageEntriesForClass: aClass - - self isPreviousMessageSendBinary - ifTrue: [ self computeMessageEntriesWithBinaryMessageForClass: aClass ] - ifFalse: [ self computeMessageEntriesWithoutBinaryMessageForClass: aClass ]. - - self ifEmptyEntriesShowAllPrefixedSelectors! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 12/4/2019 15:37:55'! - computeMessageEntriesForClassOrNil: aClassOrNil - - aClassOrNil - ifNil: [ self computeMessageEntriesForUnknowClass ] - ifNotNil: [ self computeMessageEntriesForClass: aClassOrNil ]. - -! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 12/4/2019 15:20:04'! - computeMessageEntriesOfCascadeReceiverAt: aRange - - self subclassResponsibility ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 12/4/2019 15:19:35'! - computeMessageEntriesOfEnclosedExpressionReturnAt: aRange - - self subclassResponsibility ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 12/4/2019 15:37:14'! - computeMessageEntriesWithBinaryMessageForClass: aClass - - selectorsClasses := Array with: aClass. - - entries := (AutoCompleterSelectorsCollector for: prefix) - addUnaryAndBinarySelectorsOf: aClass; - entriesToShow! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 12/4/2019 15:36:49'! - computeMessageEntriesWithoutBinaryMessageForClass: aClass - - selectorsClasses := Array with: aClass. - - entries := (AutoCompleterSelectorsCollector for: prefix) - addSelectorsOf: aClass; - entriesToShow! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 12/4/2019 15:26:55'! - isPreviousMessageSendBinary - - ^possibleBinarySendRange notNil and: [ possibleBinarySendRange rangeType = #binary ]. - - ! ! -!DynamicTypingSmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 12/4/2019 15:18:56'! - computeEntriesOfUnaryMessageReturnNamed: aSelector at: aRange - - self computeMessageEntriesForUnknowClass - ! ! -!DynamicTypingSmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 12/4/2019 15:20:04'! - computeMessageEntriesOfCascadeReceiverAt: aRange - - self computeMessageEntriesForUnknowClass - -! ! -!DynamicTypingSmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 12/4/2019 15:19:35'! - computeMessageEntriesOfEnclosedExpressionReturnAt: aRange - - self computeMessageEntriesForUnknowClass - -! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 12/4/2019 15:25:10' prior: 50480495! - computeMessageEntriesWhenSendinMessageFor: allSource using: last3Ranges in: contextClass and: specificModel - - | prevRange | - - "If previous range is a constant or a well known identifier, we might filter messages" - prevRange _ last3Ranges second. - possibleBinarySendRange _ last3Ranges first. - - ^ (self canComputeMessageEntriesFor: prevRange ) - ifTrue: [ self computeMessageEntriesFor: allSource at: prevRange in: contextClass and: specificModel ] - ifFalse: [ self computeMessageEntriesForUnknowClass ] -! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 12/4/2019 15:25:10' prior: 50480346! - computeMessageEntriesWithEmptyPrefixFor: allSource using: last3Ranges at: range in: contextClass and: specificModel - - prefix _ ''. - possibleBinarySendRange _ last3Ranges second. - - self computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel .! ! - -DynamicTypingSmalltalkCompleter removeSelector: #computeMessageEntriesOfEnclosedExpressionReturnAt:with:! - -!methodRemoval: DynamicTypingSmalltalkCompleter #computeMessageEntriesOfEnclosedExpressionReturnAt:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -computeMessageEntriesOfEnclosedExpressionReturnAt: aRange with: possibleBinaryMessageSendRange - - self computeMessageEntriesForUnknowClass - -! - -DynamicTypingSmalltalkCompleter removeSelector: #computeMessageEntriesOfCascadeReceiverAt:with:! - -!methodRemoval: DynamicTypingSmalltalkCompleter #computeMessageEntriesOfCascadeReceiverAt:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -computeMessageEntriesOfCascadeReceiverAt: aRange with: possibleBinaryMessageSendRange - - self computeMessageEntriesForUnknowClass - -! - -DynamicTypingSmalltalkCompleter removeSelector: #computeEntriesOfUnaryMessageReturnNamed:at:with:! - -!methodRemoval: DynamicTypingSmalltalkCompleter #computeEntriesOfUnaryMessageReturnNamed:at:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -computeEntriesOfUnaryMessageReturnNamed: aSelector at: aRange with: possibleBinaryMessageSendRange - - self computeMessageEntriesForUnknowClass - ! - -SmalltalkCompleter removeSelector: #computeMessageEntriesForClass:with:! - -!methodRemoval: SmalltalkCompleter #computeMessageEntriesForClass:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -computeMessageEntriesForClass: aClass with: possibleBinaryMessageSendRange - - (self isBinaryMessageSend: possibleBinaryMessageSendRange) - ifTrue: [ self computeMessageEntriesForClass: aClass withPreviousBinaryMessageSend: possibleBinaryMessageSendRange ] - ifFalse: [ self computeMessageEntriesForClass: aClass ]. - - self ifEmptyEntriesShowAllPrefixedSelectors! - -SmalltalkCompleter removeSelector: #computeMessageEntriesWithPossibleBinaryMessageSendForClass:! - -SmalltalkCompleter removeSelector: #computeMessageEntriesOfCascadeReceiverAt:with:! - -!methodRemoval: SmalltalkCompleter #computeMessageEntriesOfCascadeReceiverAt:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -computeMessageEntriesOfCascadeReceiverAt: aRange with: possibleBinaryMessageSendRange - - self subclassResponsibility ! - -SmalltalkCompleter removeSelector: #computeMessageEntriesWithBinaryMessageSendForClass:withPreviousBinaryMessageSend:! - -SmalltalkCompleter removeSelector: #computeMessageEntriesForClassOrNil:with:! - -!methodRemoval: SmalltalkCompleter #computeMessageEntriesForClassOrNil:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -computeMessageEntriesForClassOrNil: aClassOrNil with: possibleBinaryMessageSendRange - - aClassOrNil - ifNil: [ self computeMessageEntriesForUnknowClass ] - ifNotNil: [ self computeMessageEntriesForClass: aClassOrNil with: possibleBinaryMessageSendRange ]. - -! - -SmalltalkCompleter removeSelector: #computeMessageEntriesOfEnclosedExpressionReturnAt:with:! - -!methodRemoval: SmalltalkCompleter #computeMessageEntriesOfEnclosedExpressionReturnAt:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -computeMessageEntriesOfEnclosedExpressionReturnAt: aRange with: possibleBinaryMessageSendRange - - self subclassResponsibility ! - -SmalltalkCompleter removeSelector: #computeMessageEntriesFor:at:in:and:with:! - -!methodRemoval: SmalltalkCompleter #computeMessageEntriesFor:at:in:and:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel with: possibleBinarySendRange - - | id rangeType | - - canShowSelectorDocumentation _ true. - id _ allSource copyFrom: range start to: range end. - rangeType _ range rangeType. - - rangeType == #globalVar - ifTrue: [ ^self computeMessageEntriesForClass: (Smalltalk at: id asSymbol) class with: possibleBinarySendRange ]. - rangeType == #self - ifTrue: [ ^self computeMessageEntriesForClass: contextClass with: possibleBinarySendRange ]. - rangeType == #super - ifTrue: [ ^self computeMessageEntriesForClass: contextClass superclass with: possibleBinarySendRange ]. - rangeType == #true - ifTrue: [ ^self computeMessageEntriesForClass: True with: possibleBinarySendRange ]. - rangeType == #false - ifTrue: [ ^self computeMessageEntriesForClass: False with: possibleBinarySendRange ]. - rangeType == #nil - ifTrue: [ ^self computeMessageEntriesForClass: UndefinedObject with: possibleBinarySendRange ]. - rangeType == #character - ifTrue: [ ^self computeMessageEntriesForClass: id first class with: possibleBinarySendRange ]. - rangeType == #number - ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) with: possibleBinarySendRange ]. - rangeType == #string - ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) with: possibleBinarySendRange ]. - rangeType == #symbol - ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) with: possibleBinarySendRange ]. - rangeType == #stringSymbol - ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) with: possibleBinarySendRange ]. - rangeType == #instVar - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofInstVarNamed: id with: possibleBinarySendRange ]. - rangeType == #methodArg - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofTempVarNamed: id with: possibleBinarySendRange ]. - rangeType == #tempVar - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofTempVarNamed: id with: possibleBinarySendRange ]. - rangeType == #blockArg - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofBlockArgNamed: id with: possibleBinarySendRange ]. - rangeType == #blockTempVar - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofBlockTempVarNamed: id with: possibleBinarySendRange ]. - rangeType == #workspaceVar - ifTrue: [ ^self computeMessageEntriesForClassOrNil: (specificModel classOfWorkspaceVarNamed: id) with: possibleBinarySendRange ]. - rangeType == #thisContext - ifTrue: [ ^self computeMessageEntriesForClass: (specificModel classOfThisContext) with: possibleBinarySendRange ]. - rangeType == #classVar - ifTrue: [ ^self computeMessageEntriesForClassOrNil: (self classOfLocalBindingNamed: id in: contextClass) with: possibleBinarySendRange ]. - rangeType == #poolConstant - ifTrue: [ ^self computeMessageEntriesForClassOrNil: (self classOfLocalBindingNamed: id in: contextClass) with: possibleBinarySendRange ]. - rangeType == #blockEnd - ifTrue: [ ^self computeMessageEntriesForClass: BlockClosure with: possibleBinarySendRange ]. - rangeType == #arrayEnd - ifTrue: [ ^self computeMessageEntriesForClass: Array with: possibleBinarySendRange ]. - rangeType == #rightBrace - ifTrue: [ ^self computeMessageEntriesForClass: Array with: possibleBinarySendRange ]. - rangeType == #unary - ifTrue: [ ^self computeEntriesOfUnaryMessageReturnNamed: id at: range with: possibleBinarySendRange ]. - rangeType == #rightParenthesis - ifTrue: [ ^self computeMessageEntriesOfEnclosedExpressionReturnAt: range with: possibleBinarySendRange ]. - rangeType == #cascadeSeparator - ifTrue: [ ^self computeMessageEntriesOfCascadeReceiverAt: range with: possibleBinarySendRange ]. - - self computeMessageEntriesForUnknowClass - - ! - -SmalltalkCompleter removeSelector: #computeMessageEntriesWithPossibleBinaryMessageSendForClass:with:! - -SmalltalkCompleter removeSelector: #computeMessageEntriesForClass:withPreviousBinaryMessageSend:! - -!methodRemoval: SmalltalkCompleter #computeMessageEntriesForClass:withPreviousBinaryMessageSend: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -computeMessageEntriesForClass: aClass withPreviousBinaryMessageSend: possibleBinaryMessageSendRange - - selectorsClasses := Array with: aClass. - - entries := (AutoCompleterSelectorsCollector for: prefix) - addUnaryAndBinarySelectorsOf: aClass; - entriesToShow! - -SmalltalkCompleter removeSelector: #isBinaryMessageSend:! - -!methodRemoval: SmalltalkCompleter #isBinaryMessageSend: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -isBinaryMessageSend: possibleBinaryMessageSendRange - - ^possibleBinaryMessageSendRange notNil and: [ possibleBinaryMessageSendRange rangeType = #binary ]. - - ! - -SmalltalkCompleter removeSelector: #computeMessageEntriesWithBinaryMessageSendForClass:! - -SmalltalkCompleter removeSelector: #isPreviousMessageSendBinary:! - -SmalltalkCompleter removeSelector: #computeEntriesOfUnaryMessageReturnNamed:at:with:! - -!methodRemoval: SmalltalkCompleter #computeEntriesOfUnaryMessageReturnNamed:at:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -computeEntriesOfUnaryMessageReturnNamed: aSelector at: aRange with: possibleBinaryMessageSendRange - - self subclassResponsibility ! - -ClassNameRequestMorph removeSelector: #computeMessageEntriesIn:ofBlockArgNamed:with:! - -!methodRemoval: ClassNameRequestMorph #computeMessageEntriesIn:ofBlockArgNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! - -ClassNameRequestMorph removeSelector: #computeMessageEntriesIn:ofTempVarNamed:with:! - -!methodRemoval: ClassNameRequestMorph #computeMessageEntriesIn:ofTempVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! - -ClassNameRequestMorph removeSelector: #computeMessageEntriesIn:ofBlockTempVarNamed:with:! - -!methodRemoval: ClassNameRequestMorph #computeMessageEntriesIn:ofBlockTempVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! - -ClassNameRequestMorph removeSelector: #computeMessageEntriesIn:ofInstVarNamed:with:! - -!methodRemoval: ClassNameRequestMorph #computeMessageEntriesIn:ofInstVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! - -Inspector removeSelector: #computeMessageEntriesIn:ofInstVarNamed:with:! - -!methodRemoval: Inspector #computeMessageEntriesIn:ofInstVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForClass: (object instVarNamed: aName) class with: possibleBinaryMessageSendRange ! - -Debugger removeSelector: #computeMessageEntriesIn:ofBlockArgNamed:with:! - -!methodRemoval: Debugger #computeMessageEntriesIn:ofBlockArgNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName with: possibleBinaryMessageSendRange - - self computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange -! - -Debugger removeSelector: #computeMessageEntriesIn:ofTempVarNamed:with:! - -!methodRemoval: Debugger #computeMessageEntriesIn:ofTempVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange - - | context tempIndex | - - context := self selectedContext. - tempIndex := context tempNames indexOf: aName ifAbsent: [ ^ anAutocompleter computeMessageEntriesForUnknowClass ]. - - anAutocompleter computeMessageEntriesForClass: (self debuggerMap namedTempAt: tempIndex in: context) class with: possibleBinaryMessageSendRange - - ! - -Debugger removeSelector: #computeMessageEntriesIn:ofBlockTempVarNamed:with:! - -!methodRemoval: Debugger #computeMessageEntriesIn:ofBlockTempVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName with: possibleBinaryMessageSendRange - - ^self computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange ! - -Debugger removeSelector: #computeMessageEntriesIn:ofInstVarNamed:with:! - -!methodRemoval: Debugger #computeMessageEntriesIn:ofInstVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName with: possibleBinaryMessageSendRange - - contextStackIndex = 0 - ifTrue: [ anAutocompleter computeMessageEntriesForUnknowClass ] - ifFalse: [ anAutocompleter computeMessageEntriesForClass: (self receiver instVarNamed: aName) class with: possibleBinaryMessageSendRange]! - -TextProvider removeSelector: #computeMessageEntriesIn:ofBlockArgNamed:with:! - -!methodRemoval: TextProvider #computeMessageEntriesIn:ofBlockArgNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! - -TextProvider removeSelector: #computeMessageEntriesIn:ofTempVarNamed:with:! - -!methodRemoval: TextProvider #computeMessageEntriesIn:ofTempVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! - -TextProvider removeSelector: #computeMessageEntriesIn:ofBlockTempVarNamed:with:! - -!methodRemoval: TextProvider #computeMessageEntriesIn:ofBlockTempVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! - -TextProvider removeSelector: #computeMessageEntriesIn:ofInstVarNamed:with:! - -!methodRemoval: TextProvider #computeMessageEntriesIn:ofInstVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! - -Workspace removeSelector: #computeMessageEntriesIn:ofTempVarNamed:with:! - -!methodRemoval: Workspace #computeMessageEntriesIn:ofTempVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForClassOrNil: (self classOfBindingOf: aName) with: possibleBinaryMessageSendRange! - -PluggableTextModel removeSelector: #computeMessageEntriesIn:ofBlockArgNamed:with:! - -!methodRemoval: PluggableTextModel #computeMessageEntriesIn:ofBlockArgNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName with: possibleBinaryMessageSendRange - - textProvider computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName with: possibleBinaryMessageSendRange -! - -PluggableTextModel removeSelector: #computeMessageEntriesIn:ofTempVarNamed:with:! - -!methodRemoval: PluggableTextModel #computeMessageEntriesIn:ofTempVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange - - textProvider computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange -! - -PluggableTextModel removeSelector: #computeMessageEntriesIn:ofBlockTempVarNamed:with:! - -!methodRemoval: PluggableTextModel #computeMessageEntriesIn:ofBlockTempVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName with: possibleBinaryMessageSendRange - - textProvider computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName with: possibleBinaryMessageSendRange! - -PluggableTextModel removeSelector: #computeMessageEntriesIn:ofInstVarNamed:with:! - -!methodRemoval: PluggableTextModel #computeMessageEntriesIn:ofInstVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName with: possibleBinaryMessageSendRange - - textProvider computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName with: possibleBinaryMessageSendRange -! - -TextModel removeSelector: #computeMessageEntriesIn:ofBlockArgNamed:with:! - -!methodRemoval: TextModel #computeMessageEntriesIn:ofBlockArgNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! - -TextModel removeSelector: #computeMessageEntriesIn:ofTempVarNamed:with:! - -!methodRemoval: TextModel #computeMessageEntriesIn:ofTempVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! - -TextModel removeSelector: #computeMessageEntriesIn:ofBlockTempVarNamed:with:! - -!methodRemoval: TextModel #computeMessageEntriesIn:ofBlockTempVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! - -TextModel removeSelector: #computeMessageEntriesIn:ofInstVarNamed:with:! - -!methodRemoval: TextModel #computeMessageEntriesIn:ofInstVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! - -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser selectorsClasses possibleInvalidSelectors canShowSelectorDocumentation possibleBinarySendRange' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #SmalltalkCompleter category: #'Tools-Autocompletion' stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:57:44'! -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser selectorsClasses possibleInvalidSelectors canShowSelectorDocumentation possibleBinarySendRange' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3958] on 9 December 2019 at 1:56:57 am'! - -Refactoring subclass: #MoveToInstanceOrClassMethod - instanceVariableNames: 'methodToMove originalClass newClass' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #MoveToInstanceOrClassMethod category: #'Tools-Refactoring' stamp: 'Install-3965-MoveToInsClassSide-LeandroMartinYampolsky-2019Dec08-14h41m-LMY.1.cs.st 1/11/2020 17:57:44'! -Refactoring subclass: #MoveToInstanceOrClassMethod - instanceVariableNames: 'methodToMove originalClass newClass' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MoveToInstanceOrClassMethod class - instanceVariableNames: ''! - -!classDefinition: 'MoveToInstanceOrClassMethod class' category: #'Tools-Refactoring' stamp: 'Install-3965-MoveToInsClassSide-LeandroMartinYampolsky-2019Dec08-14h41m-LMY.1.cs.st 1/11/2020 17:57:44'! -MoveToInstanceOrClassMethod class - instanceVariableNames: ''! - -RefactoringApplier subclass: #MoveToInstanceOrClassMethodApplier - instanceVariableNames: 'browser methodToMove' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #MoveToInstanceOrClassMethodApplier category: #'Tools-Refactoring' stamp: 'Install-3965-MoveToInsClassSide-LeandroMartinYampolsky-2019Dec08-14h41m-LMY.1.cs.st 1/11/2020 17:57:44'! -RefactoringApplier subclass: #MoveToInstanceOrClassMethodApplier - instanceVariableNames: 'browser methodToMove' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!BrowserWindow methodsFor: 'refactorings' stamp: 'LMY 12/9/2019 00:34:31'! - moveToInstanceOrClassMethod - - model selectedMessageName ifNotNil: [ :selectedSelector | - (MoveToInstanceOrClassMethodApplier on: model for: model selectedClassOrMetaClass>>selectedSelector) value ].! ! -!MoveToInstanceOrClassMethod methodsFor: 'initialization' stamp: 'LMY 12/9/2019 00:01:14'! - initializeFor: aMethodToMove - - methodToMove := aMethodToMove. - originalClass := aMethodToMove methodClass. - newClass := aMethodToMove methodClass isMeta - ifTrue: [aMethodToMove methodClass soleInstance] - ifFalse: [aMethodToMove methodClass class]! ! -!MoveToInstanceOrClassMethod methodsFor: 'applying' stamp: 'LMY 12/9/2019 00:02:43'! - apply - - | methodCategory | - - methodCategory := originalClass organization categoryOfElement: methodToMove selector. - newClass - compile: methodToMove sourceCode - classified: methodCategory. - - originalClass removeSelector: methodToMove selector. - ! ! -!MoveToInstanceOrClassMethod class methodsFor: 'instance creation' stamp: 'LMY 12/8/2019 18:44:15'! - for: aMethodToMove - - self assertIsNotAccessingInstanceVariable: aMethodToMove. - self assertLocalVariableDoesNotConflictWithInstanceVariable: aMethodToMove. - - ^self new initializeFor: aMethodToMove ! ! -!MoveToInstanceOrClassMethod class methodsFor: 'exceptions' stamp: 'LMY 12/8/2019 18:42:50'! - localVariableConflictsWithInstanceVariableErrorMessage - - ^ 'Can not move a method that uses a local variable with same name as an instance variable'! ! -!MoveToInstanceOrClassMethod class methodsFor: 'exceptions' stamp: 'LMY 12/8/2019 17:58:30'! - referencingInstanceVariablesErrorMessage - - ^ 'Can not move a method that accesses an instance variable'! ! -!MoveToInstanceOrClassMethod class methodsFor: 'exceptions' stamp: 'LMY 12/8/2019 18:42:11'! - signalLocalVariableConflictsWithInstanceVariable - - self refactoringError: self localVariableConflictsWithInstanceVariableErrorMessage! ! -!MoveToInstanceOrClassMethod class methodsFor: 'exceptions' stamp: 'LMY 12/8/2019 17:58:37'! - signalMethodCannotAccessInstanceVariable - - self refactoringError: self referencingInstanceVariablesErrorMessage! ! -!MoveToInstanceOrClassMethod class methodsFor: 'pre-conditions' stamp: 'LMY 12/8/2019 17:56:44'! - assertIsNotAccessingInstanceVariable: aMethodToMove - - aMethodToMove methodClass instVarNames - do: [ :instVarName | - (aMethodToMove accessesInstanceVariable: instVarName) ifTrue: [self signalMethodCannotAccessInstanceVariable]].! ! -!MoveToInstanceOrClassMethod class methodsFor: 'pre-conditions' stamp: 'LMY 12/9/2019 00:08:13'! - assertLocalVariableDoesNotConflictWithInstanceVariable: aMethodToMove - - | newClass | - - aMethodToMove methodClass isMeta - ifTrue: [newClass := aMethodToMove methodClass soleInstance] - ifFalse: [newClass := aMethodToMove methodClass class]. - - newClass instVarNames - do: [ :instVarName | - (aMethodToMove methodNode hasLocalNamed: instVarName) - ifTrue: [self signalLocalVariableConflictsWithInstanceVariable] - ]! ! -!MoveToInstanceOrClassMethodApplier methodsFor: 'initialization' stamp: 'LMY 12/9/2019 00:26:42'! - initializeOn: aBrowser for: aMethodToMove - - browser := aBrowser. - methodToMove := aMethodToMove.! ! -!MoveToInstanceOrClassMethodApplier methodsFor: 'refactoring - creation' stamp: 'LMY 12/9/2019 00:30:05'! - createRefactoring - - ^self refactoringClass for: methodToMove.! ! -!MoveToInstanceOrClassMethodApplier methodsFor: 'refactoring - creation' stamp: 'LMY 12/9/2019 00:29:41'! - refactoringClass - - ^MoveToInstanceOrClassMethod! ! -!MoveToInstanceOrClassMethodApplier methodsFor: 'refactoring - changes' stamp: 'LMY 12/9/2019 00:31:04'! - informChangesToBrowser - - | classMethod | - - classMethod := methodToMove methodClass asString. - - browser classListIndex: (browser classListIndexOf: classMethod).! ! -!MoveToInstanceOrClassMethodApplier methodsFor: 'refactoring - changes' stamp: 'LMY 12/9/2019 00:30:19'! - showChanges - - self informChangesToBrowser.! ! -!MoveToInstanceOrClassMethodApplier methodsFor: 'refactoring - parameters request' stamp: 'LMY 12/9/2019 01:26:59'! - confirmationMessageText - - ^'This message has senders. Are you sure you want to move it?'! ! -!MoveToInstanceOrClassMethodApplier methodsFor: 'refactoring - parameters request' stamp: 'LMY 12/9/2019 01:46:26'! - methodHasSenders - - ^(methodToMove methodClass whichSelectorsReferTo: methodToMove selector) isEmpty not.! ! -!MoveToInstanceOrClassMethodApplier methodsFor: 'refactoring - parameters request' stamp: 'LMY 12/9/2019 01:25:16'! -requestRefactoringParameters - - self methodHasSenders ifTrue: [ - (self confirm: self confirmationMessageText) ifFalse: [ self endRequest ] - ]! ! -!MoveToInstanceOrClassMethodApplier class methodsFor: 'instance creation' stamp: 'LMY 12/9/2019 00:46:41'! - on: aBrowser for: aMethodToMove - - ^self new initializeOn: aBrowser for: aMethodToMove ! ! -!RefactoringMenues class methodsFor: 'browser menues' stamp: 'LMY 12/9/2019 01:56:12' prior: 50482266! - messsageRefactoringMenuOptions - - ^ `{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'rename... (R)'. - #selector -> #renameSelector. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 15. - #label -> 'change keyword order...'. - #selector -> #changeKeywordOrder. - #icon -> #sendReceiveIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'add parameter...'. - #selector -> #addParameter. - #icon -> #listAddIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'remove parameter...'. - #selector -> #removeParameter. - #icon -> #listRemoveIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'push up'. - #selector -> #pushUpSelector. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 50. - #label -> 'push down'. - #selector -> #pushDownSelector. - #icon -> #goBottomIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 60. - #label -> 'move to instance/class method'. - #selector -> #moveToInstanceOrClassMethod. - #icon -> #changesIcon - } asDictionary. - }`. - - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3965-MoveToInsClassSide-LeandroMartinYampolsky-2019Dec08-14h41m-LMY.1.cs.st----! - -'From Cuis 5.0 [latest update: #3959] on 12 December 2019 at 2:15:11 am'! -!Parser methodsFor: 'error correction' stamp: 'EB 12/12/2019 02:12:58'! - removeUnusedTemp: aTempName - - | positionsForVariable end start | - - positionsForVariable := (encoder positionsForTemporaryVariable: aTempName ifAbsent: []) first. - start := positionsForVariable first. - end := positionsForVariable last. - requestor correctFrom: start to: end with: ''.! ! -!Parser methodsFor: 'error correction' stamp: 'EB 12/12/2019 02:10:49' prior: 16886708! - removeUnusedTemps - "Scan for unused temp names, and prompt the user about the prospect of removing each one found" - - | str madeChanges | - madeChanges := false. - str := requestor text asString. - ((tempsMark between: 1 and: str size) - and: [(str at: tempsMark) = $|]) ifFalse: [^ self]. - encoder unusedTempNames do: - [:temp | (UnusedVariable name: temp) ifTrue: - [(encoder lookupVariable: temp ifAbsent: []) isUndefTemp - ifTrue: [ - self removeUnusedTemp: temp. - madeChanges := true. ] - ifFalse: - [self inform: -'You''ll first have to remove the\statement where it''s stored into' withNewLines]]]. - madeChanges ifTrue: [ReparseAfterSourceEditing signal]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3966-RemoveUnusedTempInsideBlock-EricBrandwein-2019Dec09-17h42m-EB.1.cs.st----! - -'From Cuis 5.0 [latest update: #3959] on 12 December 2019 at 2:53:20 am'! -!Parser methodsFor: 'error correction' stamp: 'EB 12/12/2019 02:49:07' prior: 50484477! - removeUnusedTemps - "Scan for unused temp names, and prompt the user about the prospect of removing each one found" - - | str madeChanges | - madeChanges := false. - str := requestor text asString. - ((tempsMark between: 1 and: str size) - and: [(str at: tempsMark) = $|]) ifFalse: [^ self]. - encoder unusedTempNames findFirst: - [:temp | (UnusedVariable name: temp) ifTrue: - [(encoder lookupVariable: temp ifAbsent: []) isUndefTemp - ifTrue: [ - self removeUnusedTemp: temp. - madeChanges := true. ] - ifFalse: [ - self inform: 'You''ll first have to remove the\statement where it''s stored into' withNewLines]]. - madeChanges ]. - madeChanges ifTrue: [ReparseAfterSourceEditing signal]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3967-ReparseAfterRemovingEachUnusedTemp-EricBrandwein-2019Dec12-02h15m-EB.1.cs.st----! - -'From Cuis 5.0 [latest update: #3965] on 12 December 2019 at 4:27:54 pm'! -!Parser methodsFor: 'error correction' stamp: 'HAW 12/12/2019 16:13:57'! - tryToRemoveUnusedTemp: aTemp - - (encoder lookupVariable: aTemp ifAbsent: []) isUndefTemp - ifTrue: [ - self removeUnusedTemp: aTemp. - ^true. ] - ifFalse: [ - self inform: 'You''ll first have to remove the\statement where it''s stored into' withNewLines. - ^false]! ! -!Parser methodsFor: 'error correction' stamp: 'HAW 12/12/2019 16:13:50' prior: 50484465! - removeUnusedTemp: aTemp - - | positionsForVariable end start | - - positionsForVariable := (encoder positionsForTemporaryVariable: aTemp ifAbsent: []) first. - start := positionsForVariable first. - end := positionsForVariable last. - - requestor correctFrom: start to: end with: ''.! ! -!Parser methodsFor: 'error correction' stamp: 'HAW 12/12/2019 16:19:26' prior: 50484509! - removeUnusedTemps - "Scan for unused temp names, and prompt the user about the prospect of removing each one found" - - | index | - - index := encoder unusedTempNames findFirst: [:temp | - (UnusedVariable name: temp) - ifTrue: [ self tryToRemoveUnusedTemp: temp ] - ifFalse: [ false ]]. - - index ~=0 ifTrue: [ReparseAfterSourceEditing signal]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3968-ImprovementOnRemoveUnusedTemps-HernanWilkinson-2019Dec12-15h46m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3968] on 12 December 2019 at 5:46:19 pm'! -!Parser methodsFor: 'error correction' stamp: 'HAW 12/12/2019 17:34:00'! - filterSeparatorsToTheLeftOn: currentSource startingAt: anInitialPosition - - | start | - - start := anInitialPosition. - [ (currentSource at: start-1) isSeparator ] whileTrue: [ start := start - 1 ]. - - ^start - ! ! -!Parser methodsFor: 'error correction' stamp: 'HAW 12/12/2019 17:34:04'! -filterSeparatorsToTheRightOn: currentSource startingAt: anInitialPosition - - | end | - - end := anInitialPosition. - [ (currentSource at: end+1) isSeparator ] whileTrue: [ end := end + 1 ]. - - ^end -! ! -!Parser methodsFor: 'error correction' stamp: 'HAW 12/12/2019 16:49:15'! - ifHasToRemove: aTemp addTo: tempsToRemove - - (encoder lookupVariable: aTemp ifAbsent: []) isUndefTemp - ifTrue: [ tempsToRemove add: ((encoder positionsForTemporaryVariable: aTemp ifAbsent: []) first)] - ifFalse: [ self inform: 'You''ll first have to remove the\statement where it''s stored into' withNewLines]! ! -!Parser methodsFor: 'error correction' stamp: 'HAW 12/12/2019 17:44:22'! - newRangeRemovingTempsDeclarationFrom: currentSource - startingAt: start - to: originalEnd - - | end | - - end := self filterSeparatorsToTheRightOn: currentSource startingAt: originalEnd. - - (currentSource at: end+1) = $| ifTrue: [ | possibleNewStart | - possibleNewStart := (self filterSeparatorsToTheLeftOn: currentSource startingAt: start) - 1. - (currentSource at: possibleNewStart) = $| ifTrue: [ ^Array with: possibleNewStart with: end + 1 ]]. - - ^Array with: start with: end -! ! -!Parser methodsFor: 'error correction' stamp: 'HAW 12/12/2019 17:42:34'! - removeUnusedTempRange: aRangeToRemove with: delta - - | currentSource start end newRangeToRemove | - - currentSource := requestor text. - newRangeToRemove := self - newRangeRemovingTempsDeclarationFrom: currentSource - startingAt: aRangeToRemove first - delta - to: aRangeToRemove last - delta. - start := newRangeToRemove first. - end := newRangeToRemove last. - - requestor correctFrom: start to: end with: ''. - - ^delta + end - start + 1 -! ! -!Parser methodsFor: 'error correction' stamp: 'HAW 12/12/2019 17:23:59'! - removeUnusedTempsRanges: tempsToRemove - - tempsToRemove inject: 0 into: [ :delta :aRangeToRemove | - self removeUnusedTempRange: aRangeToRemove with: delta ]! ! -!Parser methodsFor: 'error correction' stamp: 'HAW 12/12/2019 17:20:50' prior: 50484566! - removeUnusedTemps - "Scan for unused temp names, and prompt the user about the prospect of removing each one found" - - | tempsToRemove | - - tempsToRemove := SortedCollection sortBlock: [ :leftRange :rightRange | leftRange first < rightRange first ]. - - encoder unusedTempNames do: [:temp | - (UnusedVariable name: temp) ifTrue: [ self ifHasToRemove: temp addTo: tempsToRemove ]]. - - self removeUnusedTempsRanges: tempsToRemove -! ! - -Parser removeSelector: #tryToRemoveUnusedTemp:! - -!methodRemoval: Parser #tryToRemoveUnusedTemp: stamp: 'Install-3969-RemoveUnusedTempsRefactoring-HernanWilkinson-2019Dec12-16h46m-HAW.1.cs.st 1/11/2020 17:57:44'! -tryToRemoveUnusedTemp: aTemp - - (encoder lookupVariable: aTemp ifAbsent: []) isUndefTemp - ifTrue: [ - self removeUnusedTemp: aTemp. - ^true. ] - ifFalse: [ - self inform: 'You''ll first have to remove the\statement where it''s stored into' withNewLines. - ^false]! - -Parser removeSelector: #removeUnusedTemp:! - -!methodRemoval: Parser #removeUnusedTemp: stamp: 'Install-3969-RemoveUnusedTempsRefactoring-HernanWilkinson-2019Dec12-16h46m-HAW.1.cs.st 1/11/2020 17:57:44'! -removeUnusedTemp: aTemp - - | positionsForVariable end start | - - positionsForVariable := (encoder positionsForTemporaryVariable: aTemp ifAbsent: []) first. - start := positionsForVariable first. - end := positionsForVariable last. - - requestor correctFrom: start to: end with: ''.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3969-RemoveUnusedTempsRefactoring-HernanWilkinson-2019Dec12-16h46m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3969] on 14 December 2019 at 11:29:06 am'! - -Refactoring subclass: #MoveMethod - instanceVariableNames: 'method' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #MoveMethod category: #'Tools-Refactoring' stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:57:44'! -Refactoring subclass: #MoveMethod - instanceVariableNames: 'method' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MoveMethod subclass: #MoveToInstanceOrClassMethod - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #MoveToInstanceOrClassMethod category: #'Tools-Refactoring' stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:57:44'! -MoveMethod subclass: #MoveToInstanceOrClassMethod - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MoveMethod subclass: #PushDownMethod - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #PushDownMethod category: #'Tools-Refactoring' stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:57:44'! -MoveMethod subclass: #PushDownMethod - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MoveMethod subclass: #PushUpMethod - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #PushUpMethod category: #'Tools-Refactoring' stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:57:45'! -MoveMethod subclass: #PushUpMethod - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #MoveMethodApplier - instanceVariableNames: 'browser methodToMove' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #MoveMethodApplier category: #'Tools-Refactoring' stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:57:45'! -RefactoringApplier subclass: #MoveMethodApplier - instanceVariableNames: 'browser methodToMove' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MoveMethodApplier subclass: #MoveToInstanceOrClassMethodApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #MoveToInstanceOrClassMethodApplier category: #'Tools-Refactoring' stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:57:45'! -MoveMethodApplier subclass: #MoveToInstanceOrClassMethodApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MoveMethodApplier subclass: #PushDownMethodApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #PushDownMethodApplier category: #'Tools-Refactoring' stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:57:45'! -MoveMethodApplier subclass: #PushDownMethodApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MoveMethodApplier subclass: #PushUpMethodApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #PushUpMethodApplier category: #'Tools-Refactoring' stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:57:45'! -MoveMethodApplier subclass: #PushUpMethodApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!MoveMethod methodsFor: 'initialization' stamp: 'HAW 12/14/2019 11:04:04'! - initializeFor: aMethodToPushup - - method := aMethodToPushup! ! -!MoveMethod methodsFor: 'applying - private' stamp: 'HAW 12/14/2019 11:05:51'! - moveMethod - - self subclassResponsibility ! ! -!MoveMethod methodsFor: 'applying - private' stamp: 'HAW 12/14/2019 11:09:30'! - removeMethod - - method methodClass removeSelector: method selector. - ! ! -!MoveMethod methodsFor: 'applying' stamp: 'HAW 12/14/2019 11:05:41'! - apply - - self - moveMethod; - removeMethod - ! ! -!MoveMethod methodsFor: 'applying' stamp: 'HAW 12/14/2019 11:05:01'! - methodCategory - - ^method methodClass organization categoryOfElement: method selector! ! -!MoveToInstanceOrClassMethod methodsFor: 'applying - private' stamp: 'HAW 12/14/2019 11:08:02'! - moveMethod - - | targetClass | - - targetClass := method methodClass isMeta - ifTrue: [method methodClass soleInstance] - ifFalse: [method methodClass class]. - - targetClass - compile: method sourceCode - classified: self methodCategory. - - ! ! -!PushDownMethod methodsFor: 'applying - private' stamp: 'HAW 12/14/2019 11:10:31'! - moveMethod - - | methodCategory sourceCode | - - methodCategory := self methodCategory. - sourceCode := method sourceCode. - - method methodClass subclassesDo: [:subclass | - subclass - compile: sourceCode - classified: methodCategory. - ]. -! ! -!PushDownMethod class methodsFor: 'pre-conditions' stamp: 'HAW 12/14/2019 10:27:16'! - addShadowedInstVarsOf: subclass in: aMethodToPushDown to: subclassesWithShadowedInstVarNames - - | shadowedInstVarNames | - - shadowedInstVarNames := subclass instVarNames select: [:instVarName | - (aMethodToPushDown hasArgumentOrTemporary: instVarName) ]. - - shadowedInstVarNames ifNotEmpty: [ - subclassesWithShadowedInstVarNames at: subclass put: shadowedInstVarNames ]! ! -!PushDownMethod class methodsFor: 'pre-conditions' stamp: 'HAW 12/14/2019 10:26:56'! - assertIsValidToPushDownMethod: aMethodToPushDown - - | subclassesWithShadowedInstVarNames | - - subclassesWithShadowedInstVarNames := Dictionary new. - - aMethodToPushDown methodClass subclassesDo: [:subclass | - self addShadowedInstVarsOf: subclass in: aMethodToPushDown to: subclassesWithShadowedInstVarNames ]. - - subclassesWithShadowedInstVarNames ifNotEmpty: [ - self signalMethodCannotShadowInstVarOfSubclasses: subclassesWithShadowedInstVarNames] - ! ! -!PushDownMethod class methodsFor: 'pre-conditions' stamp: 'HAW 12/14/2019 10:57:17'! - warnIfExistMethodToPushDownOnSubClass: aMethodToPushDown - - | subclassesImplementingMessage | - - subclassesImplementingMessage := aMethodToPushDown methodClass subclasses select: [:subclass | - subclass includesSelector: aMethodToPushDown selector ]. - - subclassesImplementingMessage ifNotEmpty: [ - self warnMessageAlreadyImplementedIn: subclassesImplementingMessage ] - ! ! -!PushDownMethod class methodsFor: 'exceptions' stamp: 'HAW 12/14/2019 11:23:44'! - errorMessageCanNotPushDownWithShadowedInstVarsOf: subclassesWithShadowedInstVarNames - - ^String streamContents: [ :stream | - stream - nextPutAll: 'Can not push down method because the following subclasses'; - newLine; - nextPutAll: 'would have shadowed instance variables:'. - - subclassesWithShadowedInstVarNames - keysAndValuesDo: [ :class :instVarNames | - stream - newLine; - print: class; - nextPutAll: ': '. - instVarNames asCommaSeparated: [:instVarName | stream nextPutAll: instVarName ] on: stream ]]. - - -! ! -!PushDownMethod class methodsFor: 'exceptions' stamp: 'HAW 12/14/2019 10:39:22'! - signalMethodCannotShadowInstVarOfSubclasses: subclassesWithShadowedInstVarNames - - self refactoringError: ( - self errorMessageCanNotPushDownWithShadowedInstVarsOf: subclassesWithShadowedInstVarNames)! ! -!PushDownMethod class methodsFor: 'warnings' stamp: 'HAW 12/14/2019 10:58:41'! - warnMessageAlreadyImplementedIn: subclassesImplementingMessage - - self refactoringWarning: - (self warningMesssageForMessageAlreadyImplementedIn: subclassesImplementingMessage)! ! -!PushDownMethod class methodsFor: 'warnings' stamp: 'HAW 12/14/2019 10:49:27'! - warningMesssageForMessageAlreadyImplementedIn: subclassesImplementingMessage - - ^String streamContents: [ :stream | - stream - nextPutAll: 'Method already exist in the following subclasses:'; - newLine. - - subclassesImplementingMessage asCommaSeparated: [ :aClass | stream print: aClass ] on: stream. - - stream - newLine; - nextPutAll: 'If you continue they will be overwritten' ].! ! -!PushUpMethod methodsFor: 'applying - private' stamp: 'HAW 12/14/2019 11:11:15'! - moveMethod - - method methodClass superclass - compile: method sourceCode - classified: self methodCategory! ! -!PushUpMethod class methodsFor: 'warnings' stamp: 'HAW 12/14/2019 10:54:05'! - methodToPushUpExistOnSuperclassWarningMessage - - ^'Method already exist in superclass'. - - ! ! -!MoveMethodApplier methodsFor: 'initialization' stamp: 'HAW 12/14/2019 11:15:12'! - initializeOn: aBrowser for: aMethodToMove - - browser := aBrowser. - methodToMove := aMethodToMove.! ! -!MoveMethodApplier methodsFor: 'refactoring - creation' stamp: 'HAW 12/14/2019 11:15:34'! - createRefactoring - - ^self refactoringClass for: methodToMove.! ! -!MoveMethodApplier methodsFor: 'refactoring - creation' stamp: 'HAW 12/14/2019 11:19:17'! - refactoringClass - - self subclassResponsibility ! ! -!MoveMethodApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 12/14/2019 11:16:56'! - requestRefactoringParameters - - ! ! -!MoveMethodApplier methodsFor: 'refactoring - changes' stamp: 'HAW 12/14/2019 11:17:14'! - informChangesToBrowser - - browser - reformulateList; - changed: #messageList; - setClassOrganizer! ! -!MoveMethodApplier methodsFor: 'refactoring - changes' stamp: 'HAW 12/14/2019 11:17:10'! - showChanges - - self informChangesToBrowser.! ! -!MoveMethodApplier class methodsFor: 'instance creation' stamp: 'HAW 12/14/2019 11:13:33'! - on: aBrowser for: aMethodToMove - - ^self new initializeOn: aBrowser for: aMethodToMove ! ! -!PushDownMethodApplier methodsFor: 'refactoring - creation' stamp: 'fz 12/4/2019 15:38:49'! - refactoringClass - - ^PushDownMethod! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 12/14/2019 11:27:21' prior: 50482231! - pushDownSelector - - model selectedMessageName ifNotNil: [ :selectedSelector | - (PushDownMethodApplier on: model for: model selectedClassOrMetaClass>>selectedSelector) value ].! ! -!PushDownMethod class methodsFor: 'instance creation' stamp: 'HAW 12/14/2019 10:04:49' prior: 50482260! - for: aMethodToPushDown - - self assertIsValidToPushDownMethod: aMethodToPushDown. - self warnIfExistMethodToPushDownOnSubClass: aMethodToPushDown. - - ^self new initializeFor: aMethodToPushDown ! ! -!PushUpMethod class methodsFor: 'instance creation' stamp: 'HAW 12/14/2019 10:52:55' prior: 50482467! - for: aMethodToPushUp - - self assertIsValidToPushUpMethod: aMethodToPushUp. - self warnIfExistMethodToPushUpOnSuperClass: aMethodToPushUp. - - ^self new initializeFor: aMethodToPushUp! ! -!PushUpMethod class methodsFor: 'warnings' stamp: 'HAW 12/14/2019 10:54:19' prior: 50482363! - warnIfExistMethodToPushUpOnSuperClass: aMethodToPushUp - - (aMethodToPushUp methodClass superclass includesSelector: aMethodToPushUp selector) - ifTrue: [self refactoringWarning: self methodToPushUpExistOnSuperclassWarningMessage ].! ! - -PushUpMethodApplier class removeSelector: #on:for:! - -!methodRemoval: PushUpMethodApplier class #on:for: stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:57:45'! -on: aBrowser for: aMethodToPushUp - - ^self new initializeOn: aBrowser for: aMethodToPushUp ! - -PushUpMethodApplier removeSelector: #createRefactoring! - -!methodRemoval: PushUpMethodApplier #createRefactoring stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:57:45'! -createRefactoring - - ^self refactoringClass for: methodToPushUp.! - -PushUpMethodApplier removeSelector: #initializeOn:for:! - -!methodRemoval: PushUpMethodApplier #initializeOn:for: stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:57:45'! -initializeOn: aBrowser for: aMethodToPushUp - - browser := aBrowser. - methodToPushUp := aMethodToPushUp.! - -PushUpMethodApplier removeSelector: #requestRefactoringParameters! - -!methodRemoval: PushUpMethodApplier #requestRefactoringParameters stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:57:45'! -requestRefactoringParameters - - ! - -PushUpMethodApplier removeSelector: #showChanges! - -!methodRemoval: PushUpMethodApplier #showChanges stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:57:45'! -showChanges - - self informChangesToBrowser.! - -PushUpMethodApplier removeSelector: #informChangesToBrowser! - -!methodRemoval: PushUpMethodApplier #informChangesToBrowser stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:57:45'! -informChangesToBrowser - - | classMethod | - - classMethod := methodToPushUp methodClass asString. - - browser classListIndex: (browser classListIndexOf: classMethod).! - -PushDownMethodApplier class removeSelector: #on:for:! - -PushDownMethodApplier removeSelector: #informChangesToBrowser! - -PushDownMethodApplier removeSelector: #initializeOn:for:! - -PushDownMethodApplier removeSelector: #showChanges! - -PushDownMethodApplier removeSelector: #createRefactoring! - -PushDownMethodApplier removeSelector: #requestRefactoringParameters! - -MoveToInstanceOrClassMethodApplier class removeSelector: #on:for:! - -!methodRemoval: MoveToInstanceOrClassMethodApplier class #on:for: stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:57:45'! -on: aBrowser for: aMethodToMove - - ^self new initializeOn: aBrowser for: aMethodToMove ! - -MoveToInstanceOrClassMethodApplier removeSelector: #createRefactoring! - -!methodRemoval: MoveToInstanceOrClassMethodApplier #createRefactoring stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:57:45'! -createRefactoring - - ^self refactoringClass for: methodToMove.! - -MoveToInstanceOrClassMethodApplier removeSelector: #informChangesToBrowser! - -!methodRemoval: MoveToInstanceOrClassMethodApplier #informChangesToBrowser stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:57:45'! -informChangesToBrowser - - | classMethod | - - classMethod := methodToMove methodClass asString. - - browser classListIndex: (browser classListIndexOf: classMethod).! - -MoveToInstanceOrClassMethodApplier removeSelector: #showChanges! - -!methodRemoval: MoveToInstanceOrClassMethodApplier #showChanges stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:57:45'! -showChanges - - self informChangesToBrowser.! - -MoveToInstanceOrClassMethodApplier removeSelector: #initializeOn:for:! - -!methodRemoval: MoveToInstanceOrClassMethodApplier #initializeOn:for: stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:57:45'! -initializeOn: aBrowser for: aMethodToMove - - browser := aBrowser. - methodToMove := aMethodToMove.! - -PushUpMethod class removeSelector: #warningMesssageForExistMethodToPushUpOnSuperClass! - -!methodRemoval: PushUpMethod class #warningMesssageForExistMethodToPushUpOnSuperClass stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:57:45'! -warningMesssageForExistMethodToPushUpOnSuperClass - - ^'Method already exist in superclass'. - - ! - -PushUpMethod class removeSelector: #warnIsValidToPushUpMethod:! - -!methodRemoval: PushUpMethod class #warnIsValidToPushUpMethod: stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:57:45'! -warnIsValidToPushUpMethod: aMethodToPushUp - - self warnIfExistMethodToPushUpOnSuperClass: aMethodToPushUp. -! - -PushUpMethod removeSelector: #initializeFor:! - -!methodRemoval: PushUpMethod #initializeFor: stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:57:45'! -initializeFor: aMethodToPushup - - method := aMethodToPushup ! - -PushUpMethod removeSelector: #apply! - -!methodRemoval: PushUpMethod #apply stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:57:45'! -apply - - | methodCategory | - - methodCategory := method methodClass organization categoryOfElement: method selector. - method methodClass superclass - compile: method sourceCode - classified: methodCategory. - - method methodClass removeSelector: method selector. - ! - -PushDownMethod class removeSelector: #warningMesssageForExistMethodToPushDownOnSubClass! - -PushDownMethod class removeSelector: #signalMethodCannotShadowInstVarOfSubclasses! - -PushDownMethod class removeSelector: #warningMesssageForMessageAlreadyImplementedIn! - -PushDownMethod class removeSelector: #errorMessageCanNotPushDownWithShadowedInstVarsOf! - -PushDownMethod class removeSelector: #warnMethodAlreadyImplementedIn:! - -PushDownMethod class removeSelector: #errorMessageForTempOrArgVarDeclaredAsInstVarOnSubClass! - -PushDownMethod class removeSelector: #signalMethodCannotShadowAnInstVarOfASubClass! - -PushDownMethod class removeSelector: #warnIsValidToPushDownMethod:! - -PushDownMethod removeSelector: #initializeFor:! - -!methodRemoval: PushDownMethod #initializeFor: stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:57:45'! -initializeFor: aMethodToPushDown - - method := aMethodToPushDown ! - -PushDownMethod removeSelector: #apply! - -!methodRemoval: PushDownMethod #apply stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:57:45'! -apply - - | methodCategory | - - methodCategory := method methodClass organization categoryOfElement: method selector. - method methodClass subclassesDo: [:subClass | - subClass - compile: method sourceCode - classified: methodCategory. - ]. - - method methodClass removeSelector: method selector. - ! - -MoveToInstanceOrClassMethod removeSelector: #initializeFor:! - -!methodRemoval: MoveToInstanceOrClassMethod #initializeFor: stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:57:45'! -initializeFor: aMethodToMove - - methodToMove := aMethodToMove. - originalClass := aMethodToMove methodClass. - newClass := aMethodToMove methodClass isMeta - ifTrue: [aMethodToMove methodClass soleInstance] - ifFalse: [aMethodToMove methodClass class]! - -MoveToInstanceOrClassMethod removeSelector: #apply! - -!methodRemoval: MoveToInstanceOrClassMethod #apply stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:57:45'! -apply - - | methodCategory | - - methodCategory := originalClass organization categoryOfElement: methodToMove selector. - newClass - compile: methodToMove sourceCode - classified: methodCategory. - - originalClass removeSelector: methodToMove selector. - ! - -MoveMethod subclass: #MoveToInstanceOrClassMethod - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #MoveToInstanceOrClassMethod category: #'Tools-Refactoring' stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:57:45'! -MoveMethod subclass: #MoveToInstanceOrClassMethod - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MoveMethod subclass: #PushDownMethod - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #PushDownMethod category: #'Tools-Refactoring' stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:57:45'! -MoveMethod subclass: #PushDownMethod - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MoveMethod subclass: #PushUpMethod - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #PushUpMethod category: #'Tools-Refactoring' stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:57:45'! -MoveMethod subclass: #PushUpMethod - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MoveMethodApplier subclass: #MoveToInstanceOrClassMethodApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #MoveToInstanceOrClassMethodApplier category: #'Tools-Refactoring' stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:57:45'! -MoveMethodApplier subclass: #MoveToInstanceOrClassMethodApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MoveMethodApplier subclass: #PushUpMethodApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #PushUpMethodApplier category: #'Tools-Refactoring' stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:57:45'! -MoveMethodApplier subclass: #PushUpMethodApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3959] on 14 December 2019 at 12:33:24 pm'! -!Browser methodsFor: 'testing' stamp: 'HAW 12/14/2019 12:01:16'! - is: aSymbol - - ^ aSymbol == #Browser or: [ super is: aSymbol ]! ! -!Browser methodsFor: 'testing' stamp: 'HAW 12/14/2019 12:30:56'! - isEditingClass - - ^self isEditingExistingClass or: [ self isEditingNewClass ]! ! -!Browser methodsFor: 'testing' stamp: 'HAW 12/14/2019 12:29:57'! - isEditingExistingClass - - ^editSelection == #editClass! ! -!Browser methodsFor: 'testing' stamp: 'HAW 12/14/2019 12:14:04'! - isEditingNewClass - - ^editSelection == #newClass ! ! -!Browser methodsFor: 'accessing' stamp: 'HAW 12/14/2019 12:29:57' prior: 16791323! - acceptedStringOrText - "Depending on the current selection, different information is retrieved. - Answer a string description of that information. This information is the - method of the currently selected class and message." - - | comment theClass latestCompiledMethod | - latestCompiledMethod _ currentCompiledMethod. - currentCompiledMethod _ nil. - - editSelection == #none ifTrue: [^ '']. - editSelection == #editSystemCategories - ifTrue: [^ systemOrganizer printString]. - self isEditingNewClass - ifTrue: [^ (theClass _ self selectedClass) - ifNil: [ - Class template: selectedSystemCategory] - ifNotNil: [ - Class templateForSubclassOf: theClass category: selectedSystemCategory]]. - self isEditingExistingClass - ifTrue: [^ self classDefinitionText ]. - editSelection == #editComment - ifTrue: [ - (theClass _ self selectedClass) ifNil: [^ '']. - comment _ theClass comment. - currentCompiledMethod _ theClass organization commentRemoteStr. - ^ comment size = 0 - ifTrue: ['This class has not yet been commented.'] - ifFalse: [comment]]. - editSelection == #hierarchy - ifTrue: [^ self selectedClassOrMetaClass printHierarchy]. - editSelection == #editMessageCategories - ifTrue: [^ self classOrMetaClassOrganizer printString]. - editSelection == #newMessage - ifTrue: [ - ^ (theClass _ self selectedClassOrMetaClass) - ifNil: [''] - ifNotNil: [theClass sourceCodeTemplate]]. - editSelection == #editMessage - ifTrue: [ - self showingByteCodes ifTrue: [^ self selectedBytecodes]. - currentCompiledMethod _ latestCompiledMethod. - ^ self selectedMessage]. - - self error: 'Browser internal error: unknown edit selection.'! ! -!Browser methodsFor: 'accessing' stamp: 'HAW 12/14/2019 12:30:40' prior: 50444183! - contents: input notifying: aRequestor - "The retrieved information has changed and its source must now be - updated. The information can be a variety of things, depending on - the list selections (such as templates for class or message definition, - methods) or the user menu commands (such as definition, comment, - hierarchy). Answer the result of updating the source." - - | aString aText theClass | - aString _ input asString. - aText _ input asText. - editSelection == #editSystemCategories ifTrue: [ ^ self changeSystemCategories: aString ]. - self isEditingClass ifTrue: [ - [ - self defineClass: aString notifying: aRequestor - ] on: RecompilationFailure do: [ :ex | - self inform: ex messageText. - ^ false]. - ^ true]. - editSelection == #editComment - ifTrue: [ - theClass _ self selectedClass. - theClass - ifNil: [ - self inform: 'You must select a class -before giving it a comment.'. - ^ false]. - theClass comment: aText stamp: Utilities changeStamp. - self changed: #classCommentText. - ^ true]. - editSelection == #hierarchy ifTrue: [ ^ true ]. - editSelection == #editMessageCategories ifTrue: [ ^ self changeMessageCategories: aString ]. - editSelection == #editMessage | (editSelection == #newMessage) - ifTrue: [ - ^ self okayToAccept - ifFalse:[ false ] - ifTrue: [ - (self compileMessage: aText notifying: aRequestor) - ifTrue: [ self triggerEvent: #annotationChanged ]; - yourself ]]. - editSelection == #none - ifTrue: [ - self inform: 'This text cannot be accepted -in this part of the browser.'. - ^ false]. - self error: 'unacceptable accept'! ! -!Browser methodsFor: 'annotation' stamp: 'HAW 12/14/2019 12:29:57' prior: 50455431! - annotation - "Provide a line of content for an annotation pane, representing information about the method associated with the selected class and selector in the receiver." - - | aSelector aClass | - (aClass _ self selectedClassOrMetaClass) - ifNil: [^ '']. - self editSelection == #editComment - ifTrue: [^ self annotationForSelector: #Comment ofClass: aClass]. - self isEditingExistingClass - ifTrue: [^ self annotationForSelector: #Definition ofClass: aClass]. - (aSelector _ self selectedMessageName) - ifNil: [^ '']. - ^ self annotationForSelector: aSelector ofClass: aClass! ! -!Browser methodsFor: 'class functions' stamp: 'HAW 12/14/2019 12:30:40' prior: 16791681! - explainSpecial: string - "Answer a string explaining the code pane selection if it is displaying - one of the special edit functions." - - | classes whole lits reply | - self isEditingClass - ifTrue: - ["Selector parts in class definition" - string last == $: ifFalse: [^nil]. - lits _ Array with: - #subclass:instanceVariableNames:classVariableNames:poolDictionaries:category:. - (whole _ lits detect: [:each | (each keywords - detect: [:frag | frag = string] ifNone: nil) notNil] - ifNone: nil) notNil - ifTrue: [reply _ '"' , string , ' is one part of the message selector ' , whole , '.'] - ifFalse: [^nil]. - classes _ Smalltalk allClassesImplementing: whole. - classes _ 'these classes ' , classes printString. - ^reply , ' It is defined in ' , classes , '." -Smalltalk browseAllImplementorsOf: #' , whole]. - - editSelection == #hierarchy - ifTrue: - ["Instance variables in subclasses" - classes _ self selectedClassOrMetaClass allSubclasses. - classes _ classes detect: [:each | (each instVarNames - detect: [:name | name = string] ifNone: nil) notNil] - ifNone: [^nil]. - classes _ classes printString. - ^'"is an instance variable in class ' , classes , '." -' , classes , ' browseAllAccessesTo: ''' , string , '''.']. - editSelection == #editSystemCategories ifTrue: [^nil]. - editSelection == #editMessageCategories ifTrue: [^nil]. - ^nil! ! -!CodeFileBrowser methodsFor: 'accessing' stamp: 'HAW 12/14/2019 12:29:57' prior: 16809070! - acceptedStringOrText - self updateInfoView. - (self isEditingNewClass and: [ codeFile notNil ]) - ifTrue: [ ^codeFile description ]. - self isEditingExistingClass - ifTrue:[ ^self modifiedClassDefinition ]. - ^super acceptedStringOrText! ! -!CodeFileBrowser methodsFor: 'infoView' stamp: 'HAW 12/14/2019 12:29:57' prior: 50451719! - infoViewContents - | theClass | - self isEditingNewClass ifTrue: [ - ^codeFile - ifNil: [ 'No file selected' ] - ifNotNil: [ codeFile summary ]]. - self selectedClass ifNil: [^ '']. - theClass _ Smalltalk at: self selectedClass name asSymbol ifAbsent: nil. - self isEditingExistingClass ifTrue: [ - ^ theClass - ifNotNil: ['Class exists already in the system'] - ifNil: ['Class not in the system']]. - editSelection == #editMessage ifFalse: [^ '']. - (theClass notNil and: [self metaClassIndicated]) - ifTrue: [theClass _ theClass class]. - ^ (theClass notNil and: [theClass includesSelector: self selectedMessageName]) - ifTrue: ['Method already exists' , self extraInfo] - ifFalse: ['**NEW** Method not in the system']! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 12/14/2019 12:29:57' prior: 50452517! - isEditingClassDefinition - - ^(self codeProvider is: #Browser) and: [ self codeProvider isEditingExistingClass ]! ! -!BrowserCommentTextMorph methodsFor: 'updating' stamp: 'HAW 12/14/2019 12:29:57' prior: 16792978! - update: anAspect - super update: anAspect. - anAspect == #editSelection ifFalse: [ ^self ]. - model textProvider isEditingExistingClass - ifTrue: [ self showPane ] - ifFalse: [ self hidePane ]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 12/14/2019 12:30:40' prior: 50434525! - parse: allSource in: contextClass and: specificModel - - | isMethod | - - parser _ SHParserST80 new. - parser - workspace: ((specificModel is: #providesBindings) ifTrue: [specificModel]); - classOrMetaClass: contextClass; - source: (allSource copyFrom: 1 to: position); - allSource: allSource. - - isMethod := (specificModel is: #Browser) - ifTrue: [ specificModel isEditingClass not ] - ifFalse: [ specificModel is: #CodeProvider ]. - parser parse: isMethod. - - ^ parser last3Ranges. -! ! - -Browser removeSelector: #isEditingClassOrNewClass! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3971-AutoCompleteWhenEditingClass-HernanWilkinson-2019Dec14-11h53m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3969] on 12 December 2019 at 10:54:47 pm'! -!Parser methodsFor: 'error correction' stamp: 'EB 12/12/2019 20:48:34'! - declarationRangesForTemps: someTempNodes - - ^someTempNodes collect: [ :temporaryNode | - (encoder rangeForNode: temporaryNode ifAbsent: []) first ].! ! -!Parser methodsFor: 'error correction' stamp: 'EB 12/12/2019 20:58:49'! - rangesForRemovableUnusedTemps - - | tempsToRemove | - - tempsToRemove := SortedCollection sortBlock: [ :leftRange :rightRange | leftRange first < rightRange first ]. - - parseNode nodesDo: [ :node | - node isBlockNode ifTrue: [ - tempsToRemove addAll: (self rangesForRemovableUnusedTempsInBlockNode: node) ]]. - - ^tempsToRemove! ! -!Parser methodsFor: 'error correction' stamp: 'EB 12/12/2019 20:57:18'! - rangesForRemovableUnusedTempsInBlockNode: aBlockNode - - | removableTemps unusedTemps | - - unusedTemps := self unusedTempsOf: aBlockNode. - removableTemps := self selectRemovableUnusedTempsFrom: unusedTemps. - ^self declarationRangesForTemps: removableTemps.! ! -!Parser methodsFor: 'error correction' stamp: 'EB 12/12/2019 20:57:44'! - selectRemovableUnusedTempsFrom: someUnusedTemps - - ^someUnusedTemps select: [ :temporaryNode | - (UnusedVariable name: temporaryNode name) and: [ - temporaryNode isUndefTemp - ifTrue: [ true ] - ifFalse: [ - self inform: 'You''ll first have to remove the\statement where it''s stored into' withNewLines. - false ] - ] - ].! ! -!Parser methodsFor: 'error correction' stamp: 'EB 12/12/2019 22:50:35'! - unusedTempsOf: aBlockNode - - ^aBlockNode temporaries select: [ :temporaryNode | temporaryNode isUnusedTemp ]! ! -!Parser methodsFor: 'expression types' stamp: 'EB 12/12/2019 22:51:14' prior: 50444812! - method: noPattern doIt: doIt context: ctxt - " pattern [ | temporaries ] block => MethodNode." - - | sap block primitives temporaries messageComment methodNode | - - sap := self pattern: noPattern inContext: ctxt. - "sap={selector, arguments, precedence}" - self properties selector: (sap at: 1). - encoder selector: (sap at: 1). - (sap at: 2) do: [:argNode | argNode beMethodArg]. - - doIt ifFalse: [self pragmaSequence]. - temporaries := self temporaries. - messageComment := currentComment. - currentComment := nil. - doIt ifFalse: [self pragmaSequence]. - primitives := self pragmaPrimitives. - - self statements: #() innerBlock: doIt. - parseNode temporaries: temporaries. - block := parseNode. - doIt - ifTrue: [block returnLast] - ifFalse: [block returnSelfIfNoOther: encoder]. - hereType == #doIt ifFalse: [^self expected: 'Nothing more']. - - methodNode := self newMethodNode comment: messageComment. - methodNode - selector: (sap at: 1) - arguments: (sap at: 2) - precedence: (sap at: 3) - temporaries: temporaries - block: block - encoder: encoder - primitive: primitives - properties: properties - selectorKeywordsRanges: (sap at: 4). - - self interactive ifTrue: [ self performInteractiveChecks: methodNode ]. - - ^methodNode! ! -!Parser methodsFor: 'error correction' stamp: 'EB 12/12/2019 20:56:04' prior: 50484661! - removeUnusedTemps - "Scan for unused temp names, and prompt the user about the prospect of removing each one found" - - self removeUnusedTempsRanges: self rangesForRemovableUnusedTemps. -! ! - -Parser removeSelector: #ifHasToRemove:addTo:! - -!methodRemoval: Parser #ifHasToRemove:addTo: stamp: 'Install-3972-RemoveUnusedTemporariesWithManyVariablesWithSameName-EricBrandwein-2019Dec12-17h56m-EB.1.cs.st 1/11/2020 17:57:45'! -ifHasToRemove: aTemp addTo: tempsToRemove - - (encoder lookupVariable: aTemp ifAbsent: []) isUndefTemp - ifTrue: [ tempsToRemove add: ((encoder positionsForTemporaryVariable: aTemp ifAbsent: []) first)] - ifFalse: [ self inform: 'You''ll first have to remove the\statement where it''s stored into' withNewLines]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3972-RemoveUnusedTemporariesWithManyVariablesWithSameName-EricBrandwein-2019Dec12-17h56m-EB.1.cs.st----! - -'From Cuis 5.0 [latest update: #3972] on 17 December 2019 at 9:16:27 am'! -!Parser methodsFor: 'error correction' stamp: 'HAW 12/17/2019 09:13:58'! - rangesForRemovableUnusedTempsOf: aMethodNode - - | tempsToRemove | - - tempsToRemove := SortedCollection sortBlock: [ :leftRange :rightRange | leftRange first < rightRange first ]. - - tempsToRemove addAll: (self rangesForRemovableUnusedTempsInBlockNode: aMethodNode). - aMethodNode nodesDo: [ :node | - node isBlockNode ifTrue: [ - tempsToRemove addAll: (self rangesForRemovableUnusedTempsInBlockNode: node) ]]. - - ^tempsToRemove! ! -!Parser methodsFor: 'error correction' stamp: 'HAW 12/17/2019 09:13:21'! - removeUnusedTempsOf: aMethodNode - "Scan for unused temp names, and prompt the user about the prospect of removing each one found" - - self removeUnusedTempsRanges: (self rangesForRemovableUnusedTempsOf: aMethodNode)! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 3/11/2019 09:01:34' prior: 50485727! - method: noPattern doIt: doIt context: ctxt - " pattern [ | temporaries ] block => MethodNode." - - | sap block primitives temporaries messageComment methodNode | - - sap := self pattern: noPattern inContext: ctxt. - "sap={selector, arguments, precedence}" - self properties selector: (sap at: 1). - encoder selector: (sap at: 1). - (sap at: 2) do: [:argNode | argNode beMethodArg]. - - doIt ifFalse: [self pragmaSequence]. - temporaries := self temporaries. - messageComment := currentComment. - currentComment := nil. - doIt ifFalse: [self pragmaSequence]. - primitives := self pragmaPrimitives. - - self statements: #() innerBlock: doIt. - block := parseNode. - doIt - ifTrue: [block returnLast] - ifFalse: [block returnSelfIfNoOther: encoder]. - hereType == #doIt ifFalse: [^self expected: 'Nothing more']. - - methodNode := self newMethodNode comment: messageComment. - methodNode - selector: (sap at: 1) - arguments: (sap at: 2) - precedence: (sap at: 3) - temporaries: temporaries - block: block - encoder: encoder - primitive: primitives - properties: properties - selectorKeywordsRanges: (sap at: 4). - - self interactive ifTrue: [ self performInteractiveChecks: methodNode ]. - - ^methodNode! ! -!Parser methodsFor: 'error correction' stamp: 'HAW 12/17/2019 09:15:06' prior: 50485696! - rangesForRemovableUnusedTempsInBlockNode: aNodeWithTemporaries - - | removableTemps unusedTemps | - - unusedTemps := self unusedTempsOf: aNodeWithTemporaries. - removableTemps := self selectRemovableUnusedTempsFrom: unusedTemps. - - ^self declarationRangesForTemps: removableTemps.! ! -!Parser methodsFor: 'error correction' stamp: 'HAW 12/17/2019 09:14:42' prior: 50485720! - unusedTempsOf: aNodeWithTemporaries - - ^aNodeWithTemporaries temporaries select: [ :temporaryNode | temporaryNode isUnusedTemp ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3973-ParserUnusedVaraiblesRefactoring-HernanWilkinson-2019Dec17-09h12m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3972] on 17 December 2019 at 9:21:05 am'! -!Parser methodsFor: 'expression types' stamp: 'HAW 12/17/2019 09:18:00' prior: 50409637! - performInteractiveChecks: aMethodNode - - self - declareUndeclaredTemps: aMethodNode; - removeUnusedTempsOf: aMethodNode ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3974-ParserUnusedVaraiblesRefactoring-HernanWilkinson-2019Dec17-09h16m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3972] on 17 December 2019 at 9:23:58 am'! - -Parser removeSelector: #removeUnusedTemps! - -!methodRemoval: Parser #removeUnusedTemps stamp: 'Install-3975-ParserUnusedVaraiblesRefactoring-HernanWilkinson-2019Dec17-09h21m-HAW.1.cs.st 1/11/2020 17:57:45'! -removeUnusedTemps - "Scan for unused temp names, and prompt the user about the prospect of removing each one found" - - self removeUnusedTempsRanges: self rangesForRemovableUnusedTemps. -! - -Parser removeSelector: #rangesForRemovableUnusedTemps! - -!methodRemoval: Parser #rangesForRemovableUnusedTemps stamp: 'Install-3975-ParserUnusedVaraiblesRefactoring-HernanWilkinson-2019Dec17-09h21m-HAW.1.cs.st 1/11/2020 17:57:45'! -rangesForRemovableUnusedTemps - - | tempsToRemove | - - tempsToRemove := SortedCollection sortBlock: [ :leftRange :rightRange | leftRange first < rightRange first ]. - - parseNode nodesDo: [ :node | - node isBlockNode ifTrue: [ - tempsToRemove addAll: (self rangesForRemovableUnusedTempsInBlockNode: node) ]]. - - ^tempsToRemove! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3975-ParserUnusedVaraiblesRefactoring-HernanWilkinson-2019Dec17-09h21m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3972] on 17 December 2019 at 11:16:36 am'! -!ParserNotification methodsFor: 'name' stamp: 'HAW 12/17/2019 10:47:30'! - name - - ^name! ! -!ParserNotification methodsFor: 'initialization' stamp: 'HAW 12/17/2019 10:46:22'! - initializeNamed: aName - - name _ aName! ! -!ParserNotification class methodsFor: 'instance creation' stamp: 'HAW 12/17/2019 10:47:11' prior: 16886988! - name: aName - - ^(self new initializeNamed: aName) signal! ! - -ParserNotification removeSelector: #setName:! - -!methodRemoval: ParserNotification #setName: stamp: 'Install-3976-ParseNotificationAccessing-HernanWilkinson-2019Dec17-10h46m-HAW.1.cs.st 1/11/2020 17:57:45'! -setName: aString - - name _ aString! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3976-ParseNotificationAccessing-HernanWilkinson-2019Dec17-10h46m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3970] on 13 December 2019 at 1:28:36 am'! -!Parser methodsFor: 'error correction' stamp: 'EB 12/13/2019 01:21:02'! - createTempDeclarationInBlockWith: tempName before: aTempsMark - "Return the new tempsMark." - - | delta insertion offset | - - insertion := ' | ' , tempName , ' |'. - delta := 1. "the bar" - offset := self insertWord: insertion at: aTempsMark + 1. - - ^aTempsMark + offset - delta.! ! -!Parser methodsFor: 'error correction' stamp: 'EB 12/13/2019 01:20:31'! -createTempDeclarationInMethodWith: aTempName - "No bars - insert some with CR, tab. Return the new tempsMark." - - | characterBeforeMark delta insertion theTextString offset | - - theTextString := requestor text string. - characterBeforeMark := theTextString at: tempsMark - 1 ifAbsent: [$ ]. - insertion := '| ', aTempName, ' |', String newLineString. - delta := 2. "the bar and CR" - characterBeforeMark = Character tab ifTrue: [ - insertion := insertion , String tab. - delta := delta + 1. "the tab" - ]. - - offset := self insertWord: insertion at: tempsMark. - - ^tempsMark + offset - delta.! ! -!Parser methodsFor: 'error correction' stamp: 'EB 12/13/2019 01:19:25'! - insertWord: anInsertion at: aPosition - - ^self substituteWord: anInsertion - wordInterval: (aPosition to: aPosition - 1) - offset: 0.! ! -!Parser methodsFor: 'error correction' stamp: 'EB 12/13/2019 01:20:01'! - pasteTemp: name before: aTempsMark - "Return the new position of the tempsMark." - - | insertion theTextString characterBeforeMark offset | - - theTextString := requestor text string. - insertion := name, ' '. - characterBeforeMark := theTextString at: aTempsMark - 1 ifAbsent: [$ ]. - characterBeforeMark isSeparator ifFalse: [ insertion := ' ', insertion]. - offset := self insertWord: insertion at: aTempsMark. - - ^aTempsMark + offset.! ! -!Parser methodsFor: 'error correction' stamp: 'EB 12/13/2019 01:09:37'! - pasteTemp: tempName inBlock: aBlockNode - - | theTextString blockTempsMark newTempsMark | - - theTextString := requestor text string. - blockTempsMark := aBlockNode tempsMark + requestorOffset. - - newTempsMark := - (theTextString at: blockTempsMark) = $| - ifTrue: [ - "Paste it before the second vertical bar" - aBlockNode tempsMark: (self pasteTemp: tempName before: blockTempsMark) ] - ifFalse: [ - "The tempsMark is at the beginning of the block, we should insert after it." - self createTempDeclarationInBlockWith: tempName before: blockTempsMark ]. - - aBlockNode tempsMark: newTempsMark.! ! -!Parser methodsFor: 'error correction' stamp: 'EB 12/13/2019 00:18:45' prior: 16886592! - declareUndeclaredTemps: methodNode - "Declare any undeclared temps, declaring them at the smallest enclosing scope." - | undeclared userSelection blocksToVars | - (undeclared _ encoder undeclaredTemps) isEmpty ifTrue: [ ^ self ]. - userSelection _ requestor selectionInterval. - blocksToVars _ IdentityDictionary new. - undeclared do: [ :var | - (blocksToVars - at: (var tag == #method - ifTrue: [ methodNode block ] - ifFalse: [ methodNode accept: (VariableScopeFinder new ofVariable: var) ]) - ifAbsentPut: [ SortedCollection new ]) add: var name ]. - (blocksToVars removeKey: methodNode block ifAbsent: nil) ifNotNil: [ :rootVars | - rootVars do: [ :varName | - self pasteTempAtMethodLevel: varName ]]. - (blocksToVars keys sort: [ :a :b | - a tempsMark < b tempsMark ]) do: [ :block | - (blocksToVars at: block) do: [ :varName | self pasteTemp: varName inBlock: block ]]. - requestor - selectInvisiblyFrom: userSelection first - to: userSelection last + requestorOffset. - ReparseAfterSourceEditing signal! ! -!Parser methodsFor: 'error correction' stamp: 'EB 12/13/2019 01:26:43' prior: 16886663! - pasteTempAtMethodLevel: name - - | theTextString | - - theTextString := requestor text string. - tempsMark := - (theTextString at: tempsMark) = $| - ifTrue: [ - "Paste it before the second vertical bar" - self pasteTemp: name before: tempsMark ] - ifFalse: [ self createTempDeclarationInMethodWith: name ]. - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3977-DeclareUndeclaredInBlockFix-EricBrandwein-2019Dec12-23h47m-EB.1.cs.st----! - -'From Cuis 5.0 [latest update: #3976] on 17 December 2019 at 5:20:19 pm'! -!UndeclaredVariable methodsFor: 'exception handling - private' stamp: 'HAW 12/17/2019 17:09:06'! - declareBlockTempAction - - ^[ parser declareTemp: name at: #block ]! ! -!UndeclaredVariable methodsFor: 'exception handling - private' stamp: 'HAW 12/17/2019 17:09:53'! - declareInstanceVariableAction - - ^[ parser declareInstVar: name ]! ! -!UndeclaredVariable methodsFor: 'exception handling - private' stamp: 'HAW 12/17/2019 17:09:25'! - declareMethodTempAction - - ^[ parser declareTemp: name at: #method ].! ! -!UndeclaredVariable methodsFor: 'exception handling - private' stamp: 'HAW 12/17/2019 17:09:43' prior: 50402280! - addLocalVariableOptionsTo: labels actions: actions - - labels add: 'declare block-local temp'. - actions add: self declareBlockTempAction. - - labels add: 'declare method temp'. - actions add: self declareMethodTempAction. - - parser canDeclareInstanceVariable ifTrue: [ - labels add: 'declare instance'. - actions add: self declareInstanceVariableAction]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3978-UndeclareVariabeRefactoring-HernanWilkinson-2019Dec17-12h05m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3978] on 17 December 2019 at 7:20:58 pm'! - -RefactoringApplier subclass: #RenameTemporaryApplier - instanceVariableNames: 'classToRefactor oldVariable newVariable smalltalkEditor methodNode oldVariableNode ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameTemporaryApplier category: #'Tools-Refactoring' stamp: 'Install-3979-RenameTemporaryOnSameVarNameFix-HernanWilkinson-2019Dec17-17h22m-HAW.1.cs.st 1/11/2020 17:57:45'! -RefactoringApplier subclass: #RenameTemporaryApplier - instanceVariableNames: 'classToRefactor oldVariable newVariable smalltalkEditor methodNode oldVariableNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Refactoring subclass: #RenameTemporary - instanceVariableNames: 'oldVariableNode newVariable methodNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameTemporary category: #'Tools-Refactoring' stamp: 'Install-3979-RenameTemporaryOnSameVarNameFix-HernanWilkinson-2019Dec17-17h22m-HAW.1.cs.st 1/11/2020 17:57:45'! -Refactoring subclass: #RenameTemporary - instanceVariableNames: 'oldVariableNode newVariable methodNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!CompiledMethod methodsFor: 'testing' stamp: 'HAW 12/17/2019 19:12:33'! - hasArgumentOrTemporaryNamed: aVariable - - | methodNode | - - methodNode := self methodNode. - - ^methodNode tempNames includes: aVariable ! ! -!BlockNode methodsFor: 'testing' stamp: 'HAW 12/17/2019 19:14:02'! - isArgumentOrTemporary: aParseNode - - ^(self temporaries includes: aParseNode) or: [ self arguments includes: aParseNode ] - ! ! -!MethodNode methodsFor: 'testing' stamp: 'HAW 12/17/2019 19:12:33'! - hasArgumentOrTemporaryNamed: aVariable - - ^self tempNames includes: aVariable! ! -!MethodNode methodsFor: 'testing' stamp: 'HAW 12/17/2019 19:13:21'! - isArgumentOrTemporary: aParseNode - - ^(self temporaries includes: aParseNode) or: [ self arguments includes: aParseNode ] - ! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 12/17/2019 18:33:53'! - renameTemporary: aTemporaryNode at: aMethodNode - - self codeProvider isEditingMethod ifTrue: [ | applier | - [ applier := RenameTemporaryApplier on: self for: aTemporaryNode at: aMethodNode ] - on: SyntaxErrorNotification - do: [:anError | ^self inform: (RenameTemporaryApplier errorMessageForCanNotParseMethod: anError) ]. - applier value ]. -! ! -!RenameTemporary methodsFor: 'initialization' stamp: 'HAW 12/17/2019 19:16:57'! - initializeFromOldVariableNode: anOldVariableNode to: aNewVariable in: aMethodNode - - oldVariableNode := anOldVariableNode. - newVariable := aNewVariable. - methodNode := aMethodNode ! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 12/17/2019 19:14:24'! - assert: anOldVariableNode isPartOf: aMethodNode - - "I can not use tempNode becuase it uses scopeTable that does not have - repeated nodes for variables with same name - Hernan" - - (aMethodNode isArgumentOrTemporary: anOldVariableNode) ifTrue: [ ^self ]. - - aMethodNode nodesDo: [ :aNode | - aNode isBlockNode ifTrue: [ - (aNode isArgumentOrTemporary: anOldVariableNode) ifTrue: [ ^self ]]]. - - self signalOldVariableNodeNotPartOfMethodNode ! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 12/17/2019 18:52:51'! - assertIsArgOrTempNode: anOldVariableNode - - anOldVariableNode isTempOrArg ifFalse: [ self signalOldVariableNodeMustBeArgOrTempNodeErrorDescription ]! ! -!RenameTemporary class methodsFor: 'exceptions' stamp: 'HAW 12/17/2019 18:53:23'! - oldVariableNodeMustBeArgOrTempNodeErrorDescription - - ^'Old variable node must be argument or temporary node'! ! -!RenameTemporary class methodsFor: 'exceptions' stamp: 'HAW 12/17/2019 18:49:53'! - oldVariableNodeNotPartOfMethodNodeErrorDescription - - ^'Node of variable to rename is not part of method''s method node'! ! -!RenameTemporary class methodsFor: 'exceptions' stamp: 'HAW 12/17/2019 18:53:03'! - signalOldVariableNodeMustBeArgOrTempNodeErrorDescription - - self refactoringError: self oldVariableNodeMustBeArgOrTempNodeErrorDescription! ! -!RenameTemporary class methodsFor: 'exceptions' stamp: 'HAW 12/17/2019 18:49:23'! - signalOldVariableNodeNotPartOfMethodNode - - self refactoringError: self oldVariableNodeNotPartOfMethodNodeErrorDescription! ! -!RenameTemporary class methodsFor: 'instance creation' stamp: 'HAW 12/17/2019 19:16:57'! - fromOldVariableNode: anOldVariableNode to: aNewVariable in: aMethodNode - - | trimmedNewVariable | - - trimmedNewVariable := aNewVariable withBlanksTrimmed. - - self assertIsArgOrTempNode: anOldVariableNode. - self assert: anOldVariableNode isPartOf: aMethodNode. - self assertIsNotEmpty: trimmedNewVariable. - self assertIsValidVariableName: trimmedNewVariable. - self assert: trimmedNewVariable isNotDefinedIn: aMethodNode. - - self assert: trimmedNewVariable isNotDefinedAsInstanceVariableInHierarchyOf: aMethodNode methodClass. - - ^self new initializeFromOldVariableNode: anOldVariableNode to: trimmedNewVariable in: aMethodNode -! ! -!RenameTemporaryApplier methodsFor: 'initialization' stamp: 'HAW 12/17/2019 18:41:46'! - initializeOn: aSmalltalkEditor for: aTemporaryNode at: aMethodNode - - smalltalkEditor := aSmalltalkEditor. - classToRefactor := smalltalkEditor codeProvider selectedClassOrMetaClass. - methodNode := aMethodNode. - oldVariableNode := aTemporaryNode. - ! ! -!RenameTemporaryApplier class methodsFor: 'instance creation' stamp: 'HAW 12/17/2019 18:34:06'! - on: aSmalltalkEditor for: aTemporaryNode at: aMethodNode - - ^self new initializeOn: aSmalltalkEditor for: aTemporaryNode at: aMethodNode! ! -!Behavior methodsFor: 'accessing method dictionary' stamp: 'HAW 12/17/2019 19:12:33' prior: 50442994! - methodsWithArgumentOrTemporaryNamed: instVarName - - ^self methodsSelect: [:aMethod | aMethod hasArgumentOrTemporaryNamed: instVarName ]! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 12/17/2019 18:31:46' prior: 50469137! - contextualRenameOf: aMethodNode in: aSelectedClass - - aMethodNode - withParseNodeIncluding: self startIndex - do: [ :nodeUnderCursor | self rename: nodeUnderCursor in: aSelectedClass at: aMethodNode ] - ifAbsent: [ - self startIndex <= aMethodNode selectorLastPosition - ifTrue: [ self ifChangeSelectorCanBeAppliedDo: [ self renameSelectorFor: aMethodNode selector in: aSelectedClass ]] - ifFalse: [ morph flash ]] - - -! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 12/17/2019 18:33:32' prior: 50469154! - rename: aNodeUnderCursor in: aSelectedClass at: aMethodNode - - aNodeUnderCursor isTempOrArg ifTrue: [ ^self renameTemporary: aNodeUnderCursor at: aMethodNode ]. - - self ifChangeSelectorCanBeAppliedDo: [ - aNodeUnderCursor isMessageNode ifTrue: [ - ^ self renameSelectorOf: aNodeUnderCursor in: aSelectedClass at: aMethodNode selector ]. - aNodeUnderCursor isInstanceVariableNode ifTrue: [ - ^ self renameInstanceVariableOn: self codeProvider for: aNodeUnderCursor name at: aSelectedClass ]. - aNodeUnderCursor isLiteralVariableNode ifTrue: [ | variableName | - variableName := aNodeUnderCursor key key. - (Smalltalk classNamed: variableName) ifNotNil: [ :classToRename | - ^self renameClassOn: self codeProvider for: classToRename ]. - (Smalltalk bindingOf: variableName) ifNotNil: [ - ^self renameGlobalOn: self codeProvider for: variableName ] ]. - - ^morph flash ]! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 12/17/2019 18:38:47' prior: 50467201! - withMethodNodeAndClassDo: aBlock ifErrorsParsing: anErrorBlock - - | selectedClass methodNode | - - "I have to do this because some codeProviders do no answer selectedClassOrMetaClass like the Workspace - Hernan" - selectedClass := [ self codeProvider selectedClassOrMetaClass ] on: Error do: [ :anError | anError return: UndefinedObject ]. - [ methodNode := selectedClass methodNodeFor: model actualContents asString ] on: Error do: [ :anError | ^ anErrorBlock value: anError ]. - - ^aBlock value: methodNode value: selectedClass.! ! -!PushDownMethod class methodsFor: 'pre-conditions' stamp: 'HAW 12/17/2019 19:12:33' prior: 50484884! - addShadowedInstVarsOf: subclass in: aMethodToPushDown to: subclassesWithShadowedInstVarNames - - | shadowedInstVarNames | - - shadowedInstVarNames := subclass instVarNames select: [:instVarName | - (aMethodToPushDown hasArgumentOrTemporaryNamed: instVarName) ]. - - shadowedInstVarNames ifNotEmpty: [ - subclassesWithShadowedInstVarNames at: subclass put: shadowedInstVarNames ]! ! -!RenameTemporary methodsFor: 'applying' stamp: 'HAW 12/17/2019 18:23:43' prior: 50441016! - apply - - | newSource ranges | - - ranges := methodNode rangeForNode: oldVariableNode ifAbsent: [ #() ]. - newSource := methodNode sourceText copyReplacing: ranges with: newVariable. - - ^ newSource! ! -!RenameTemporary class methodsFor: 'instance creation - private' stamp: 'HAW 12/17/2019 19:16:37' prior: 50444642! - from: anOldVariable to: aNewVariable in: aMethodNode - - | oldVariableNode | - - "I keept this message for testing only, the applier now uses the one that receives the - old variable node, that fixes the problem when renaming a temp that is in more than - one block - Hernan" - oldVariableNode := aMethodNode tempNodes - detect: [ :aTempNode | aTempNode name = anOldVariable ] - ifNone: [ self signalTemporaryVariable: anOldVariable notDefinedIn: aMethodNode ]. - - ^self fromOldVariableNode: oldVariableNode to: aNewVariable in: aMethodNode ! ! -!RenameTemporaryApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 12/17/2019 18:41:40' prior: 50442279! - askNewVariableName - - newVariable := (self request: 'Enter new name:' initialAnswer: oldVariableNode name) withBlanksTrimmed ! ! -!RenameTemporaryApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 12/17/2019 18:40:46' prior: 50442326! - requestRefactoringParameters - - self askNewVariableName! ! -!RenameTemporaryApplier methodsFor: 'refactoring - creation' stamp: 'HAW 12/17/2019 19:15:28' prior: 50442344! - createRefactoring - - ^RenameTemporary fromOldVariableNode: oldVariableNode to: newVariable in: methodNode - ! ! - -RenameTemporaryApplier class removeSelector: #on:for:! - -!methodRemoval: RenameTemporaryApplier class #on:for: stamp: 'Install-3979-RenameTemporaryOnSameVarNameFix-HernanWilkinson-2019Dec17-17h22m-HAW.1.cs.st 1/11/2020 17:57:45'! -on: aSmalltalkEditor for: aTemporary - - ^self new initializeOn: aSmalltalkEditor for: aTemporary! - -RenameTemporaryApplier removeSelector: #selectTemporaryVariableFrom:! - -!methodRemoval: RenameTemporaryApplier #selectTemporaryVariableFrom: stamp: 'Install-3979-RenameTemporaryOnSameVarNameFix-HernanWilkinson-2019Dec17-17h22m-HAW.1.cs.st 1/11/2020 17:57:45'! -selectTemporaryVariableFrom: variables - - | selectionIndex | - - selectionIndex := (PopUpMenu labelArray: variables lines: #()) startUpWithCaption: 'Select temporary to rename'. - - ^selectionIndex = 0 - ifTrue: [ self endRequest ] - ifFalse: [ variables at: selectionIndex ]! - -RenameTemporaryApplier removeSelector: #chooseTemporaryVariable! - -!methodRemoval: RenameTemporaryApplier #chooseTemporaryVariable stamp: 'Install-3979-RenameTemporaryOnSameVarNameFix-HernanWilkinson-2019Dec17-17h22m-HAW.1.cs.st 1/11/2020 17:57:45'! -chooseTemporaryVariable - - | variables | - - oldVariable ifNotNil: [ ^self ]. - - variables := methodNode tempNames. - variables isEmpty - ifTrue: [ self noTemporaryToRename ] - ifFalse: [ self chooseTemporaryVariableFrom: variables ] - - ! - -RenameTemporaryApplier removeSelector: #noTemporaryToRename! - -!methodRemoval: RenameTemporaryApplier #noTemporaryToRename stamp: 'Install-3979-RenameTemporaryOnSameVarNameFix-HernanWilkinson-2019Dec17-17h22m-HAW.1.cs.st 1/11/2020 17:57:45'! -noTemporaryToRename - - self inform: 'There are no temporary to rename'. - self endRequest ! - -RenameTemporaryApplier removeSelector: #initializeOn:for:! - -!methodRemoval: RenameTemporaryApplier #initializeOn:for: stamp: 'Install-3979-RenameTemporaryOnSameVarNameFix-HernanWilkinson-2019Dec17-17h22m-HAW.1.cs.st 1/11/2020 17:57:45'! -initializeOn: aSmalltalkEditor for: aTemporary - - smalltalkEditor := aSmalltalkEditor. - classToRefactor := smalltalkEditor codeProvider selectedClassOrMetaClass. - methodNode := classToRefactor methodNodeFor: smalltalkEditor actualContents string. - oldVariable := aTemporary - ! - -RenameTemporaryApplier removeSelector: #is:temporaryVariableFrom:! - -!methodRemoval: RenameTemporaryApplier #is:temporaryVariableFrom: stamp: 'Install-3979-RenameTemporaryOnSameVarNameFix-HernanWilkinson-2019Dec17-17h22m-HAW.1.cs.st 1/11/2020 17:57:45'! -is: selection temporaryVariableFrom: variables - - ^smalltalkEditor hasSelection and: [variables includes: selection]! - -RenameTemporaryApplier removeSelector: #chooseTemporaryVariableFrom:! - -!methodRemoval: RenameTemporaryApplier #chooseTemporaryVariableFrom: stamp: 'Install-3979-RenameTemporaryOnSameVarNameFix-HernanWilkinson-2019Dec17-17h22m-HAW.1.cs.st 1/11/2020 17:57:45'! -chooseTemporaryVariableFrom: variables - - | selection | - - selection := smalltalkEditor selection string withBlanksTrimmed. - oldVariable := (self is: selection temporaryVariableFrom: variables) - ifTrue: [ selection ] - ifFalse: [ self selectTemporaryVariableFrom: variables]! - -RenameTemporary class removeSelector: #fromNodeOfOld:to:in:! - -RenameTemporary removeSelector: #initializeFrom:to:in:! - -!methodRemoval: RenameTemporary #initializeFrom:to:in: stamp: 'Install-3979-RenameTemporaryOnSameVarNameFix-HernanWilkinson-2019Dec17-17h22m-HAW.1.cs.st 1/11/2020 17:57:45'! -initializeFrom: anOldVariable to: aNewVariable in: aMethodNode - - oldVariable := anOldVariable. - newVariable := aNewVariable. - methodNode := aMethodNode ! - -RenameTemporary removeSelector: #initializeFromNodeOfOld:to:in:! - -SmalltalkEditor removeSelector: #renameTemporary:! - -!methodRemoval: SmalltalkEditor #renameTemporary: stamp: 'Install-3979-RenameTemporaryOnSameVarNameFix-HernanWilkinson-2019Dec17-17h22m-HAW.1.cs.st 1/11/2020 17:57:45'! -renameTemporary: aTemporaryName - - self codeProvider isEditingMethod ifTrue: [ | applier | - [ applier := RenameTemporaryApplier on: self for: aTemporaryName ] - on: SyntaxErrorNotification - do: [:anError | ^self inform: (RenameTemporaryApplier errorMessageForCanNotParseMethod: anError) ]. - applier value ]. -! - -MethodNode removeSelector: #hasArgumentOrTemporary:! - -!methodRemoval: MethodNode #hasArgumentOrTemporary: stamp: 'Install-3979-RenameTemporaryOnSameVarNameFix-HernanWilkinson-2019Dec17-17h22m-HAW.1.cs.st 1/11/2020 17:57:45'! -hasArgumentOrTemporary: aVariable - - ^self tempNames includes: aVariable! - -CompiledMethod removeSelector: #hasArgumentOrTemporary:! - -!methodRemoval: CompiledMethod #hasArgumentOrTemporary: stamp: 'Install-3979-RenameTemporaryOnSameVarNameFix-HernanWilkinson-2019Dec17-17h22m-HAW.1.cs.st 1/11/2020 17:57:45'! -hasArgumentOrTemporary: aVariable - - | methodNode | - - methodNode := self methodNode. - - ^methodNode tempNames includes: aVariable ! - -RefactoringApplier subclass: #RenameTemporaryApplier - instanceVariableNames: 'classToRefactor newVariable smalltalkEditor methodNode oldVariableNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameTemporaryApplier category: #'Tools-Refactoring' stamp: 'Install-3979-RenameTemporaryOnSameVarNameFix-HernanWilkinson-2019Dec17-17h22m-HAW.1.cs.st 1/11/2020 17:57:45'! -RefactoringApplier subclass: #RenameTemporaryApplier - instanceVariableNames: 'classToRefactor newVariable smalltalkEditor methodNode oldVariableNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Refactoring subclass: #RenameTemporary - instanceVariableNames: 'oldVariableNode newVariable methodNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameTemporary category: #'Tools-Refactoring' stamp: 'Install-3979-RenameTemporaryOnSameVarNameFix-HernanWilkinson-2019Dec17-17h22m-HAW.1.cs.st 1/11/2020 17:57:45'! -Refactoring subclass: #RenameTemporary - instanceVariableNames: 'oldVariableNode newVariable methodNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3979-RenameTemporaryOnSameVarNameFix-HernanWilkinson-2019Dec17-17h22m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3979] on 18 December 2019 at 4:07:57 pm'! - -RefactoringWarning subclass: #ReferencesRefactoringWarning - instanceVariableNames: 'references primaryReferencee allreferenced' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ReferencesRefactoringWarning category: #'Tools-Refactoring' stamp: 'Install-3980-RemovingClassWarnsForReferencesToName-HernanWilkinson-2019Dec18-11h06m-HAW.1.cs.st 1/11/2020 17:57:45'! -RefactoringWarning subclass: #ReferencesRefactoringWarning - instanceVariableNames: 'references primaryReferencee allreferenced' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Object subclass: #ClassReferencesCollector - instanceVariableNames: 'classToLookForReferences referencesToClass referencedAsClass referencesToName referencedAsName withAllSubclassesNames' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ClassReferencesCollector category: #'Tools-Refactoring' stamp: 'Install-3980-RemovingClassWarnsForReferencesToName-HernanWilkinson-2019Dec18-11h06m-HAW.1.cs.st 1/11/2020 17:57:45'! -Object subclass: #ClassReferencesCollector - instanceVariableNames: 'classToLookForReferences referencesToClass referencedAsClass referencesToName referencedAsName withAllSubclassesNames' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!CompiledMethod methodsFor: 'testing' stamp: 'HAW 12/18/2019 12:01:17'! - hasVariableBindingTo: aClass - - self literalsDo: [ :aLiteral | - (aLiteral isVariableBinding and: [ aLiteral value = aClass ]) ifTrue: [ ^true ]]. - - ^false! ! -!CanNotRefactorDueToReferencesError methodsFor: 'initialization' stamp: 'HAW 12/18/2019 12:23:57'! - initializeWith: aMessageText references: aCollectionOfReferences to: aReferencee - - self messageText: aMessageText. - references := aCollectionOfReferences. - referencee := aReferencee ! ! -!CanNotRefactorDueToReferencesError class methodsFor: 'instance creation' stamp: 'HAW 12/18/2019 12:23:36'! - with: aMessageText references: references to: aReferencee - - ^self new initializeWith: aMessageText references: references to: aReferencee! ! -!ReferencesRefactoringWarning methodsFor: 'initialization' stamp: 'HAW 12/18/2019 12:26:09'! - initializeWith: aMessageText references: aReferences of: aPrimaryReferencee toAll: anAllReferenced - - self messageText: aMessageText. - references := aReferences. - primaryReferencee := aPrimaryReferencee. - allreferenced := anAllReferenced ! ! -!ReferencesRefactoringWarning methodsFor: 'accessing' stamp: 'HAW 12/18/2019 15:14:58'! - referencee - - ^primaryReferencee ! ! -!ReferencesRefactoringWarning methodsFor: 'accessing' stamp: 'HAW 12/18/2019 15:14:48'! - references - - ^references! ! -!ReferencesRefactoringWarning methodsFor: 'references' stamp: 'HAW 12/18/2019 16:04:55'! - anyReference - - ^references anyOne ! ! -!ReferencesRefactoringWarning methodsFor: 'references' stamp: 'HAW 12/18/2019 16:04:39'! -numberOfReferences - - ^references size! ! -!ReferencesRefactoringWarning class methodsFor: 'as yet unclassified' stamp: 'HAW 12/18/2019 12:24:17'! - signal: aMessageText references: references of: primaryReferencee toAll: allReferenced - - (self with: aMessageText references: references of: primaryReferencee toAll: allReferenced) signal! ! -!ReferencesRefactoringWarning class methodsFor: 'instance creation' stamp: 'HAW 12/18/2019 12:24:55'! - with: aMessageText references: references of: primaryReferencee toAll: allReferenced - - ^self new initializeWith: aMessageText references: references of: primaryReferencee toAll: allReferenced! ! -!MethodReference methodsFor: 'testing' stamp: 'HAW 12/18/2019 11:59:43'! - hasVariableBindingTo: aClass - - ^self compiledMethod hasVariableBindingTo: aClass -! ! -!ClassReferencesCollector methodsFor: 'initialization' stamp: 'HAW 12/18/2019 15:50:25'! - initializeOf: aClassToLookForReferences - - classToLookForReferences := aClassToLookForReferences ! ! -!ClassReferencesCollector methodsFor: 'evaluating - private' stamp: 'HAW 12/18/2019 15:55:55'! - add: aClass asReferencedToClassWith: referencesToVariableBinding - - referencedAsClass add: aClass. - referencesToClass addAll: referencesToVariableBinding ! ! -!ClassReferencesCollector methodsFor: 'evaluating - private' stamp: 'HAW 12/18/2019 15:55:44'! - add: aClass asReferencedToNameWith: referencesToClassName - - referencedAsName add: aClass. - referencesToName addAll: referencesToClassName - ! ! -!ClassReferencesCollector methodsFor: 'evaluating - private' stamp: 'HAW 12/18/2019 15:55:55'! - collectReferencesOf: aClass - - | allReferences referencesOutsideHierarchy referencesToVariableBinding referencesToClassName | - - allReferences := aClass allCallsOn. - referencesOutsideHierarchy := allReferences reject: [ :aReference | withAllSubclassesNames includes: aReference classSymbol ]. - referencesToVariableBinding := referencesOutsideHierarchy select: [ :aReference | aReference hasVariableBindingTo: aClass ]. - referencesToClassName := referencesOutsideHierarchy difference: referencesToVariableBinding. - - referencesToVariableBinding notEmpty ifTrue: [ self add: aClass asReferencedToClassWith: referencesToVariableBinding ]. - referencesToClassName notEmpty ifTrue: [ self add: aClass asReferencedToNameWith: referencesToClassName ]. - ! ! -!ClassReferencesCollector methodsFor: 'evaluating - private' stamp: 'HAW 12/18/2019 15:57:22'! - initializeCollectionFor: withAllSubclasses - - withAllSubclassesNames := withAllSubclasses collect: [:aClass | aClass name ]. - referencesToClass := OrderedCollection new. - referencedAsClass := OrderedCollection new. - referencesToName := OrderedCollection new. - referencedAsName := OrderedCollection new! ! -!ClassReferencesCollector methodsFor: 'evaluating' stamp: 'HAW 12/18/2019 15:57:12'! - value - - | withAllSubclasses | - - withAllSubclasses := classToLookForReferences withAllSubclasses. - self initializeCollectionFor: withAllSubclasses. - - withAllSubclasses do: [ :aClass | self collectReferencesOf: aClass ]. - - ! ! -!ClassReferencesCollector methodsFor: 'testing' stamp: 'HAW 12/18/2019 15:58:27'! - hasReferencesToClass - - ^referencesToClass notEmpty! ! -!ClassReferencesCollector methodsFor: 'testing' stamp: 'HAW 12/18/2019 15:58:43'! - hasReferencesToName - - ^referencesToName notEmpty ! ! -!ClassReferencesCollector methodsFor: 'accessing' stamp: 'HAW 12/18/2019 15:59:32'! - referencedAsClass - - ^referencedAsClass! ! -!ClassReferencesCollector methodsFor: 'accessing' stamp: 'HAW 12/18/2019 15:59:00'! - referencedAsName - - ^referencedAsName! ! -!ClassReferencesCollector methodsFor: 'accessing' stamp: 'HAW 12/18/2019 15:59:23'! - referencesToClass - - ^referencesToClass! ! -!ClassReferencesCollector methodsFor: 'accessing' stamp: 'HAW 12/18/2019 15:58:52'! - referencesToName - - ^referencesToName! ! -!ClassReferencesCollector class methodsFor: 'evaluating' stamp: 'HAW 12/18/2019 15:49:34'! - valueOf: aClassToLookForReferences - - ^(self of: aClassToLookForReferences) value! ! -!ClassReferencesCollector class methodsFor: 'instance creation' stamp: 'HAW 12/18/2019 15:49:47'! - of: aClassToLookForReferences - - ^self new initializeOf: aClassToLookForReferences! ! -!Refactoring class methodsFor: 'warnings' stamp: 'HAW 12/18/2019 12:21:19'! - referencesWarningClass - - ^ReferencesRefactoringWarning! ! -!Refactoring class methodsFor: 'warnings' stamp: 'HAW 12/18/2019 15:37:30'! - warnAboutReferences: references with: aMessageText of: primaryReferencee toAll: allReferenced - - ^self referencesWarningClass - signal: aMessageText - references: references - of: primaryReferencee - toAll: allReferenced ! ! -!SafelyRemoveClass class methodsFor: 'warnings' stamp: 'HAW 12/18/2019 15:37:44'! - warnAboutRemoveOf: aClassToSafelyRemove dueToNameReferences: references toAll: allReferenced - - self - warnAboutReferences: references - with: (self warningMessageForReferencesToNames: allReferenced) - of: aClassToSafelyRemove - toAll: allReferenced - ! ! -!SafelyRemoveClass class methodsFor: 'warnings' stamp: 'HAW 12/18/2019 12:08:06'! - warningMessageForReferencesToNames: referenced - - ^'There are references to the name of ', referenced asCommaStringAnd ! ! -!RefactoringApplier methodsFor: 'exception handling' stamp: 'HAW 12/18/2019 15:18:30'! - handleReferencesWarning: aReferencesWarning - - | options answer question | - - options := -'Browse references and Cancel -Browse references and Continue -Continue'. - - question := PopUpMenu labels: options icons: #(cancelIcon mailForwardIcon acceptIcon). - answer := question startUpWithCaption: aReferencesWarning messageText. - - answer <= 2 ifTrue: [ self browseReferencesOn: aReferencesWarning ]. - answer = 1 ifTrue: [ self endRequest ]. - aReferencesWarning resume.! ! -!CanNotRefactorDueToReferencesError class methodsFor: 'signaling' stamp: 'HAW 12/18/2019 12:23:14' prior: 50438031! - signal: aMessageText references: references to: aReferencee - - (self with: aMessageText references: references to: aReferencee) signal! ! -!SafelyRemoveClass class methodsFor: 'instance creation' stamp: 'HAW 12/18/2019 15:18:38' prior: 50441206! - of: aClassToSafelyRemove - - | theNonMetaclassToRemove | - - theNonMetaclassToRemove := aClassToSafelyRemove theNonMetaClass. - self assertNoReferencesTo: theNonMetaclassToRemove. - self warnIfHasSubclasses: theNonMetaclassToRemove. - - ^self new initializeOf: theNonMetaclassToRemove ! ! -!SafelyRemoveClass class methodsFor: 'pre-conditions' stamp: 'HAW 12/18/2019 15:49:06' prior: 50441218! - assertNoReferencesTo: aClassToSafelyRemove - - | referencesCollector | - - referencesCollector := ClassReferencesCollector valueOf: aClassToSafelyRemove. - - referencesCollector hasReferencesToClass ifTrue: [ - ^self - signalCanNotRemove: aClassToSafelyRemove - dueToReferences: referencesCollector referencesToClass - toAll: referencesCollector referencedAsClass ]. - - referencesCollector hasReferencesToName ifTrue: [ - ^self - warnAboutRemoveOf: aClassToSafelyRemove - dueToNameReferences: referencesCollector referencesToName - toAll: referencesCollector referencedAsName ]. -! ! -!RefactoringApplier methodsFor: 'exception handling' stamp: 'HAW 12/18/2019 12:28:15' prior: 50441411! - valueHandlingRefactoringExceptions: aBlock - - ^[[[aBlock - on: Refactoring referencesWarningClass - do: [ :aReferencesRefactoringWarning | self handleReferencesWarning: aReferencesRefactoringWarning ]] - on: Refactoring refactoringWarningClass - do: [ :aRefactoringWarning | self handleRefactoringWarning: aRefactoringWarning ]] - on: Refactoring canNotRefactorDueToReferencesErrorClass - do: [ :aCanNotRefactorDueToReferencesError | self handleCanNotRefactorDueToReferencesError: aCanNotRefactorDueToReferencesError ]] - on: Refactoring refactoringErrorClass - do: [ :aRefactoringError | self handleRefactoringError: aRefactoringError ] - ! ! - -Refactoring class removeSelector: #warnAboutReferences:references:of:toAll:! - -ClassReferencesCollector removeSelector: #add:asReferenceeToClassWith:! - -CanNotRefactorDueToReferencesError removeSelector: #initialize:references:to:! - -!methodRemoval: CanNotRefactorDueToReferencesError #initialize:references:to: stamp: 'Install-3980-RemovingClassWarnsForReferencesToName-HernanWilkinson-2019Dec18-11h06m-HAW.1.cs.st 1/11/2020 17:57:45'! -initialize: aMessageText references: aCollectionOfReferences to: aReferencee - - self messageText: aMessageText. - references := aCollectionOfReferences. - referencee := aReferencee ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3980-RemovingClassWarnsForReferencesToName-HernanWilkinson-2019Dec18-11h06m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3980] on 18 December 2019 at 6:39:08 pm'! - -Refactoring subclass: #RenameInstanceVariable - instanceVariableNames: 'oldVariable renamedReferences methodsAndRangesToChange newVariable classToRefactor originalClassToRefactor ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameInstanceVariable category: #'Tools-Refactoring' stamp: 'Install-3981-RenameInstVarLogChange-HernanWilkinson-2019Dec18-17h51m-HAW.1.cs.st 1/11/2020 17:57:45'! -Refactoring subclass: #RenameInstanceVariable - instanceVariableNames: 'oldVariable renamedReferences methodsAndRangesToChange newVariable classToRefactor originalClassToRefactor' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!Behavior methodsFor: 'testing' stamp: 'HAW 12/18/2019 18:18:28'! - hasChangedComparedTo: anotherClass - - ^self superclass ~~ anotherClass superclass - or: [ self instVarNames ~= anotherClass instVarNames - or: [ self classVarNames ~= anotherClass classVarNames - or: [ self sharedPools ~= anotherClass sharedPools ]]]! ! -!ChangeSet methodsFor: 'testing' stamp: 'HAW 12/18/2019 18:37:51'! -isWithClass: aClass - - ^changeRecords includesKey: aClass name! ! -!ChangeSet class methodsFor: 'enumerating' stamp: 'HAW 12/18/2019 18:37:51'! - allChangeSetsWithClass: aClass - - ^ AllChangeSets select: [ :aChangeSet | aChangeSet isWithClass: aClass ]! ! -!RenameInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 12/18/2019 18:26:23'! - logChange - - Smalltalk - logChange: classToRefactor definition - preamble: classToRefactor definitionPreamble. - - ChangeSet - classDefinitionChangedFrom: originalClassToRefactor to: classToRefactor ! ! -!ChangeSet methodsFor: 'system change notifications' stamp: 'HAW 12/18/2019 18:18:57' prior: 16798726! - classDefinitionChangedFrom: oldClass to: newClass - - (newClass hasChangedComparedTo: oldClass) ifTrue: [ - self noteChangeClass: newClass from: oldClass ]! ! -!RenameInstanceVariable methodsFor: 'applying' stamp: 'HAW 12/18/2019 18:26:00' prior: 50478162! - apply - - originalClassToRefactor := classToRefactor copy. - - self - lookForMethodsReferencingOldVariable; - changeInstanceVariableName; - logChange; - renameReferencesToOldVariable. - - ^renamedReferences - ! ! - -RenameInstanceVariable removeSelector: #logClassDefinition! - -!methodRemoval: RenameInstanceVariable #logClassDefinition stamp: 'Install-3981-RenameInstVarLogChange-HernanWilkinson-2019Dec18-17h51m-HAW.1.cs.st 1/11/2020 17:57:45'! -logClassDefinition - - Smalltalk - logChange: classToRefactor definition - preamble: classToRefactor definitionPreamble.! - -ChangeSet class removeSelector: #allChangeSetWithClass:! - -ChangeSet removeSelector: #isForClass:! - -Refactoring subclass: #RenameInstanceVariable - instanceVariableNames: 'oldVariable renamedReferences methodsAndRangesToChange newVariable classToRefactor originalClassToRefactor' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameInstanceVariable category: #'Tools-Refactoring' stamp: 'Install-3981-RenameInstVarLogChange-HernanWilkinson-2019Dec18-17h51m-HAW.1.cs.st 1/11/2020 17:57:45'! -Refactoring subclass: #RenameInstanceVariable - instanceVariableNames: 'oldVariable renamedReferences methodsAndRangesToChange newVariable classToRefactor originalClassToRefactor' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3981-RenameInstVarLogChange-HernanWilkinson-2019Dec18-17h51m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3981] on 18 December 2019 at 8:57:41 pm'! -!ChangeSet class methodsFor: 'system change notifications' stamp: 'HAW 12/18/2019 19:57:53' prior: 50482923! - aboutToRenameClass: aClass from: oldClassName to: newClassName inCategory: aCategoryName - - | packageOrNil | - - aClass wantsChangeSetLogging ifFalse: [ ^self ]. - - packageOrNil _ CodePackage packageOfSystemCategory: aCategoryName ifNone: nil. - (self changeSetForPackage: packageOrNil) ifNotNil: [ :changeSet | - changeSet - aboutToRenameClass: aClass - from: oldClassName - to: newClassName - inCategory: aCategoryName ]. - packageOrNil ifNotNil: [ - packageOrNil hasUnsavedChanges: true ]! ! -!ChangeSet class methodsFor: 'system change notifications' stamp: 'HAW 12/18/2019 19:57:46' prior: 16798884! - classAdded: aClass inCategory: aCategoryName - - | packageOrNil | - - aClass wantsChangeSetLogging ifFalse: [ ^self ]. - - packageOrNil _ CodePackage packageOfSystemCategory: aCategoryName ifNone: nil. - (self changeSetForPackage: packageOrNil) ifNotNil: [ :changeSet | - changeSet classAdded: aClass inCategory: aCategoryName ]. - packageOrNil ifNotNil: [ - packageOrNil hasUnsavedChanges: true ]! ! -!ChangeSet class methodsFor: 'system change notifications' stamp: 'HAW 12/18/2019 19:58:08' prior: 16798898! - classCommented: aClass - - | packageOrNil | - - aClass wantsChangeSetLogging ifFalse: [ ^self ]. - - packageOrNil _ CodePackage packageOfClass: aClass ifNone: nil. - (self changeSetForPackage: packageOrNil) ifNotNil: [ :changeSet | - changeSet classCommented: aClass ]. - packageOrNil ifNotNil: [ - packageOrNil hasUnsavedChanges: true ].! ! -!ChangeSet class methodsFor: 'system change notifications' stamp: 'HAW 12/18/2019 19:58:19' prior: 16798910! - classDefinitionChangedFrom: oldClass to: newClass - "In case the class is moved from one package to another, both change sets should be affected. - But there's no need to do it here, as #classRecategorized:from:to: is also called." - - | packageOrNil | - - newClass wantsChangeSetLogging ifFalse: [ ^self ]. - - packageOrNil _ CodePackage packageOfClass: newClass ifNone: nil. - (self changeSetForPackage: packageOrNil) ifNotNil: [ :changeSet | - changeSet classDefinitionChangedFrom: oldClass to: newClass ]. - packageOrNil ifNotNil: [ - packageOrNil hasUnsavedChanges: true ]! ! -!ChangeSet class methodsFor: 'system change notifications' stamp: 'HAW 12/18/2019 19:58:38' prior: 16798929! - classRecategorized: aClass from: oldCategory to: newCategory - "If the class was moved to a dfferent package, out of the base system, record the fact in the change set. - The actual class redefinition is done at #classDefinitionChangedFrom:to: that is also called (if the class really changed)." - - | oldPackageOrNil newPackageOrNil newChangeSet | - - aClass wantsChangeSetLogging ifFalse: [ ^self ]. - - newPackageOrNil _ CodePackage - packageOfSystemCategory: newCategory - ifNone: nil. - newPackageOrNil ifNotNil: [ newPackageOrNil hasUnsavedChanges: true ]. - newChangeSet _ ChangeSet changeSetForPackage: newPackageOrNil. - newChangeSet noteRecategorizationOfClass: aClass. - - oldPackageOrNil _ CodePackage - packageOfSystemCategory: oldCategory - ifNone: nil. - oldPackageOrNil - ifNotNil: [ oldPackageOrNil hasUnsavedChanges: true ] - ifNil: [ - "If destination is a package, but source isn't, then record the change in the base system changeset" - newPackageOrNil ifNotNil: [ - self changeSetForBaseSystem noteClassMoveToOtherPackage: aClass ]]! ! -!ChangeSet class methodsFor: 'system change notifications' stamp: 'HAW 12/18/2019 19:59:02' prior: 16798963! - classRemoved: aClass fromCategory: aCategoryName - - | packageOrNil | - - aClass wantsChangeSetLogging ifFalse: [ ^self ]. - - packageOrNil _ CodePackage packageOfSystemCategory: aCategoryName ifNone: nil. - (self changeSetForPackage: packageOrNil) ifNotNil: [ :changeSet | - changeSet classRemoved: aClass fromCategory: aCategoryName ]. - packageOrNil ifNotNil: [ - packageOrNil hasUnsavedChanges: true ]! ! -!ChangeSet class methodsFor: 'system change notifications' stamp: 'HAW 12/18/2019 19:59:14' prior: 16798994! -classReorganized: aClass - - | packageOrNil | - - aClass wantsChangeSetLogging ifFalse: [ ^self ]. - - packageOrNil _ CodePackage packageOfClass: aClass ifNone: nil. - (self changeSetForPackage: packageOrNil) ifNotNil: [ :changeSet | - changeSet classReorganized: aClass ]. - packageOrNil ifNotNil: [ - packageOrNil hasUnsavedChanges: true ]! ! -!ChangeSet class methodsFor: 'system change notifications' stamp: 'HAW 12/18/2019 19:59:24' prior: 16799006! -methodAdded: aCompiledMethod selector: aSymbol inClass: aClass requestor: requestor - - | packageOrNil | - - aClass wantsChangeSetLogging ifFalse: [ ^self ]. - - packageOrNil _ CodePackage packageOfMethod: aCompiledMethod methodReference ifNone: nil. - (self changeSetForPackage: packageOrNil) ifNotNil: [ :changeSet | - changeSet - methodAdded: aCompiledMethod - selector: aSymbol - inClass: aClass - requestor: requestor ]. - packageOrNil ifNotNil: [ - packageOrNil hasUnsavedChanges: true ]! ! -!ChangeSet class methodsFor: 'system change notifications' stamp: 'HAW 12/18/2019 19:59:32' prior: 16799023! - methodAdded: aCompiledMethod selector: aSymbol inProtocol: aCategoryName class: aClass requestor: requestor - - | packageOrNil | - - aClass wantsChangeSetLogging ifFalse: [ ^self ]. - - packageOrNil _ CodePackage packageOfMethod: aCompiledMethod methodReference ifNone: nil. - (self changeSetForPackage: packageOrNil) ifNotNil: [ :changeSet | - changeSet - methodAdded: aCompiledMethod - selector: aSymbol - inProtocol: aCategoryName - class: aClass - requestor: requestor ]. - packageOrNil ifNotNil: [ - packageOrNil hasUnsavedChanges: true ]! ! -!ChangeSet class methodsFor: 'system change notifications' stamp: 'HAW 12/18/2019 19:59:39' prior: 16799042! - methodChangedFrom: oldMethod to: newMethod selector: aSymbol inClass: aClass requestor: requestor - - | packageOrNil | - - aClass wantsChangeSetLogging ifFalse: [ ^self ]. - - packageOrNil _ CodePackage packageOfMethod: newMethod methodReference ifNone: nil. - (self changeSetForPackage: packageOrNil) ifNotNil: [ :changeSet | - changeSet - methodChangedFrom: oldMethod - to: newMethod - selector: aSymbol - inClass: aClass - requestor: requestor ]. - packageOrNil ifNotNil: [ - packageOrNil hasUnsavedChanges: true ]! ! -!ChangeSet class methodsFor: 'system change notifications' stamp: 'HAW 12/18/2019 19:59:51' prior: 16799060! - methodRemoved: aCompiledMethod selector: aSymbol inProtocol: aCategoryName class: aClass - - | packageOrNil | - - aClass wantsChangeSetLogging ifFalse: [ ^self ]. - - packageOrNil _ CodePackage packageOfMethodCategory: aCategoryName ofClass: aClass ifNone: nil. - (self changeSetForPackage: packageOrNil) ifNotNil: [ :changeSet | - changeSet - methodRemoved: aCompiledMethod - selector: aSymbol - inProtocol: aCategoryName - class: aClass ]. - packageOrNil ifNotNil: [ - packageOrNil hasUnsavedChanges: true ]! ! -!ChangeSet class methodsFor: 'system change notifications' stamp: 'HAW 12/18/2019 20:00:33' prior: 16799078! - selectorRecategorized: selector from: oldCategory to: newCategory inClass: aClass - "If the method was moved to a dfferent package, affect the package that lost the it. Tell it that it lost the method. - The actual method redefinition is done at one of the method definition methods, that is also called." - - | newPackageOrNil newChangeSet oldPackageOrNil | - - aClass wantsChangeSetLogging ifFalse: [ ^self ]. - - newPackageOrNil _ CodePackage packageOfMethodCategory: newCategory ofClass: aClass ifNone: nil. - newPackageOrNil ifNotNil: [ newPackageOrNil hasUnsavedChanges: true ]. - newChangeSet _ ChangeSet changeSetForPackage: newPackageOrNil. - newChangeSet selectorRecategorized: selector from: oldCategory to: newCategory inClass: aClass. - - oldPackageOrNil _ CodePackage packageOfMethodCategory: oldCategory ofClass: aClass ifNone: nil. - oldPackageOrNil - ifNotNil: [ oldPackageOrNil hasUnsavedChanges: true ] - ifNil: [ - "If destination is a package, but source isn't, then record the change in the base system changeset" - newPackageOrNil ifNotNil: [ - self changeSetForBaseSystem noteMethodMoveToOtherPackage: selector forClass: aClass ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3982-wantsChangeSetLoggingFix-HernanWilkinson-2019Dec18-19h57m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3982] on 20 December 2019 at 8:59:35 pm'! -!Parser methodsFor: 'error correction' stamp: 'EB 12/20/2019 20:54:07' prior: 50486031! - pasteTemp: tempName inBlock: aBlockNode - - | theTextString blockTempsMark | - - theTextString := requestor text string. - blockTempsMark := aBlockNode tempsMark + requestorOffset. - - (theTextString at: blockTempsMark) = $| - ifTrue: [ - "Paste it before the second vertical bar" - self pasteTemp: tempName before: blockTempsMark ] - ifFalse: [ - "The tempsMark is at the beginning of the block, we should insert after it." - self createTempDeclarationInBlockWith: tempName before: blockTempsMark ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3983-DeclareMoreThanOneUndeclaredInSameBlock-EricBrandwein-2019Dec20-20h02m-EB.1.cs.st----! - -'From Cuis 5.0 [latest update: #3979] on 18 December 2019 at 6:58:51 pm'! - -ParseNodeVisitor subclass: #BlockNodeParentsFinder - instanceVariableNames: 'selectedBlockNode root parents found' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #BlockNodeParentsFinder category: #'Tools-Refactoring' stamp: 'Install-3984-RenameTemporaryWithOtherBlocksDeclaringNewVariable-EricBrandwein-2019Dec18-16h29m-EB.1.cs.st 1/11/2020 17:57:45'! -ParseNodeVisitor subclass: #BlockNodeParentsFinder - instanceVariableNames: 'selectedBlockNode root parents found' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!BlockNodeParentsFinder commentStamp: 'EB 12/18/2019 18:55:03' prior: 0! - I find the BlockNode parents of a BlockNode in the ParseNode tree starting from a ParseNode supplied to #parentsIn:. ! -!BlockNodeParentsFinder methodsFor: 'initializing' stamp: 'EB 12/18/2019 18:09:42'! - initializeFor: aSelectedBlockNode - - selectedBlockNode := aSelectedBlockNode. - parents := OrderedCollection new. - found := false.! ! -!BlockNodeParentsFinder methodsFor: 'visiting' stamp: 'EB 12/18/2019 18:09:00'! - visitBlockNode: aBlockNode - - found ifFalse: [ - aBlockNode = selectedBlockNode - ifTrue: [ found := true ] - ifFalse: [ - parents add: aBlockNode. - super visitBlockNode: aBlockNode. - found ifFalse: [ parents removeLast ] - ] - ] - - - ! ! -!BlockNodeParentsFinder methodsFor: 'accessing' stamp: 'EB 12/18/2019 18:13:27'! - parentsIn: aParseNode - - aParseNode accept: self. - ^parents! ! -!BlockNodeParentsFinder class methodsFor: 'instance creation' stamp: 'EB 12/18/2019 18:10:08'! - for: aSelectedBlockNode - - ^self new initializeFor: aSelectedBlockNode.! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'EB 12/18/2019 17:01:45'! - any: someBlockOrMethodNodes declaresTempNamed: aTempName - - ^someBlockOrMethodNodes anySatisfy: [ :node | - self is: aTempName declaredIn: node ]! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'EB 12/18/2019 18:50:44'! - assert: aTempName isNotDeclaredInParseTreeBranchOfNodeDeclaring: aTempNode in: aMethodNode - - | blockNode | - - blockNode := self blockNodeDeclaringTempNode: aTempNode in: aMethodNode. - ((self is: aTempName declaredInChildrenOf: blockNode) or: [ - self is: aTempName declaredInParentsOf: blockNode in: aMethodNode ]) - ifTrue: [ self signalNewTemporaryVariable: aTempName isAlreadyDefinedIn: aMethodNode ].! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'EB 12/18/2019 18:51:30'! - blockNodeDeclaringTempNode: aTempNode in: aMethodNode - - | blockNode | - - aMethodNode nodesDo: [ :node | - (node isBlockNode and: [ node isArgumentOrTemporary: aTempNode ]) - ifTrue: [ blockNode := node ]]. - blockNode ifNil: [ blockNode := aMethodNode body ]. - ^blockNode! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'EB 12/18/2019 17:01:52'! - is: aTempName declaredIn: aBlockOrMethodNode - - ^(aBlockOrMethodNode temporaries union: aBlockOrMethodNode arguments) anySatisfy: [ :tempNode | - tempNode name = aTempName ]! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'EB 12/18/2019 18:36:52'! - is: aTempName declaredInChildrenOf: aBlockNode - - aBlockNode nodesDo: [ :node | - (node isBlockNode and: [ self is: aTempName declaredIn: node ]) ifTrue: [^true]]. - ^false! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'EB 12/18/2019 18:53:37'! - is: aTempName declaredInParentsOf: aBlockNode in: aMethodNode - - | parents | - - parents := (BlockNodeParentsFinder for: aBlockNode) parentsIn: aMethodNode. - parents add: aMethodNode. - ^self any: parents declaresTempNamed: aTempName! ! -!RenameTemporary class methodsFor: 'instance creation' stamp: 'EB 12/18/2019 18:47:12' prior: 50486289! - fromOldVariableNode: anOldVariableNode to: aNewVariable in: aMethodNode - - | trimmedNewVariable | - - trimmedNewVariable := aNewVariable withBlanksTrimmed. - - self assertIsArgOrTempNode: anOldVariableNode. - self assert: anOldVariableNode isPartOf: aMethodNode. - self assertIsNotEmpty: trimmedNewVariable. - self assertIsValidVariableName: trimmedNewVariable. - self assert: trimmedNewVariable isNotDeclaredInParseTreeBranchOfNodeDeclaring: anOldVariableNode in: aMethodNode. - self assert: trimmedNewVariable isNotDefinedAsInstanceVariableInHierarchyOf: aMethodNode methodClass. - - ^self new initializeFromOldVariableNode: anOldVariableNode to: trimmedNewVariable in: aMethodNode -! ! - -RenameTemporary class removeSelector: #assert:isNotDefinedIn:! - -!methodRemoval: RenameTemporary class #assert:isNotDefinedIn: stamp: 'Install-3984-RenameTemporaryWithOtherBlocksDeclaringNewVariable-EricBrandwein-2019Dec18-16h29m-EB.1.cs.st 1/11/2020 17:57:45'! -assert: aNewVariable isNotDefinedIn: aMethodNode - - (aMethodNode tempNames includes: aNewVariable) ifTrue: [ self signalNewTemporaryVariable: aNewVariable isAlreadyDefinedIn: aMethodNode ] - ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3984-RenameTemporaryWithOtherBlocksDeclaringNewVariable-EricBrandwein-2019Dec18-16h29m-EB.1.cs.st----! - -'From Cuis 5.0 [latest update: #3984] on 22 December 2019 at 8:33:28 pm'! -!ParseNode methodsFor: 'testing' stamp: 'HAW 12/22/2019 20:21:52'! - hasNodeIn: aCollectionOfNodes named: aName - - ^aCollectionOfNodes anySatisfy: [ :tempNode | tempNode name = aName ]! ! -!BlockNode methodsFor: 'testing' stamp: 'HAW 12/22/2019 20:22:33'! - hasLocallyArgumentOrTemporaryNamed: aVariableName - - ^(self hasNodeIn: self temporaries named: aVariableName) - or: [self hasNodeIn: self arguments named: aVariableName ]! ! -!BlockNode methodsFor: 'testing' stamp: 'HAW 12/22/2019 20:30:26'! - isLocalArgumentOrTemporary: aParseNode - - ^(self temporaries includes: aParseNode) or: [ self arguments includes: aParseNode ] - ! ! -!MethodNode methodsFor: 'testing' stamp: 'HAW 12/22/2019 20:28:55'! - hasLocallyArgumentOrTemporaryNamed: aVariableName - - "See #hasArgumentOrTemporaryNamed: comment - Hernan" - ^(self hasNodeIn: self temporaries named: aVariableName) - or: [self hasNodeIn: self arguments named: aVariableName ]! ! -!MethodNode methodsFor: 'testing' stamp: 'HAW 12/22/2019 20:30:47'! - isLocalArgumentOrTemporary: aParseNode - - "Looks only in this scope - Hernan" - ^(self temporaries includes: aParseNode) or: [ self arguments includes: aParseNode ] - ! ! -!CompiledMethod methodsFor: 'testing' stamp: 'HAW 12/22/2019 20:23:52' prior: 50486187! -hasArgumentOrTemporaryNamed: aVariable - - ^self methodNode hasArgumentOrTemporaryNamed: aVariable -! ! -!MethodNode methodsFor: 'testing' stamp: 'HAW 12/22/2019 20:28:34' prior: 50486201! - hasArgumentOrTemporaryNamed: aVariableName - - " - - hasArgumentOrTemporaryNamed: returns true if there is a temp or variable in this scope or subscopes - named aVariableName - - hasLocalName: returns true if there is a variable in the scopeTable name aVariableName. That includes - temps, arguments, instance variables and pseudo-variables - - hasLocallyArgumentOrTemporaryNamed: returns true if ony this scope defines a temp or argument - named aVariableName. - Hernan" - ^self tempNames includes: aVariableName! ! -!MethodNode methodsFor: 'testing' stamp: 'HAW 12/22/2019 20:28:48' prior: 50443683! - hasLocalNamed: aName - - "See #hasArgumentOrTemporaryNamed: comment - Hernan" - ^ encoder hasLocalNamed: aName ! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 12/22/2019 20:20:02' prior: 50487510! - any: someBlockOrMethodNodes declaresTempNamed: aTempName - - ^someBlockOrMethodNodes anySatisfy: [ :node | node hasLocallyArgumentOrTemporaryNamed: aTempName]! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 12/22/2019 20:30:26' prior: 50486236! - assert: anOldVariableNode isPartOf: aMethodNode - - "I can not use tempNode becuase it uses scopeTable that does not have - repeated nodes for variables with same name - Hernan" - - (aMethodNode isLocalArgumentOrTemporary: anOldVariableNode) ifTrue: [ ^self ]. - - aMethodNode nodesDo: [ :aNode | - aNode isBlockNode ifTrue: [ - (aNode isLocalArgumentOrTemporary: anOldVariableNode) ifTrue: [ ^self ]]]. - - self signalOldVariableNodeNotPartOfMethodNode ! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 12/22/2019 20:33:00' prior: 50487534! - blockNodeDeclaringTempNode: aTempNode in: aMethodNode - - | blockNode | - - aMethodNode nodesDo: [ :node | - (node isBlockNode and: [ node isLocalArgumentOrTemporary: aTempNode ]) - ifTrue: [ blockNode := node ]]. - blockNode ifNil: [ blockNode := aMethodNode body ]. - - ^blockNode! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 12/22/2019 20:20:14' prior: 50487555! -is: aTempName declaredInChildrenOf: aBlockNode - - aBlockNode nodesDo: [ :node | - (node isBlockNode and: [ node hasLocallyArgumentOrTemporaryNamed: aTempName ]) ifTrue: [^true]]. - - ^false! ! - -RenameTemporary class removeSelector: #is:declaredIn:! - -!methodRemoval: RenameTemporary class #is:declaredIn: stamp: 'Install-3985-RenameTemporaryRefactors-HernanWilkinson-2019Dec22-20h17m-HAW.1.cs.st 1/11/2020 17:57:45'! -is: aTempName declaredIn: aBlockOrMethodNode - - ^(aBlockOrMethodNode temporaries union: aBlockOrMethodNode arguments) anySatisfy: [ :tempNode | - tempNode name = aTempName ]! - -MethodNode removeSelector: #isArgumentOrTemporary:! - -!methodRemoval: MethodNode #isArgumentOrTemporary: stamp: 'Install-3985-RenameTemporaryRefactors-HernanWilkinson-2019Dec22-20h17m-HAW.1.cs.st 1/11/2020 17:57:45'! -isArgumentOrTemporary: aParseNode - - ^(self temporaries includes: aParseNode) or: [ self arguments includes: aParseNode ] - ! - -BlockNode removeSelector: #isArgumentOrTemporary:! - -!methodRemoval: BlockNode #isArgumentOrTemporary: stamp: 'Install-3985-RenameTemporaryRefactors-HernanWilkinson-2019Dec22-20h17m-HAW.1.cs.st 1/11/2020 17:57:45'! -isArgumentOrTemporary: aParseNode - - ^(self temporaries includes: aParseNode) or: [ self arguments includes: aParseNode ] - ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3985-RenameTemporaryRefactors-HernanWilkinson-2019Dec22-20h17m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3985] on 23 December 2019 at 7:21:35 am'! - -ParseNode subclass: #CodeNode - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #CodeNode category: #'Compiler-ParseNodes' stamp: 'Install-3986-CodeNodeRefactoring-HernanWilkinson-2019Dec23-07h12m-HAW.1.cs.st 1/11/2020 17:57:45'! -ParseNode subclass: #CodeNode - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -CodeNode subclass: #BlockNode - instanceVariableNames: 'arguments statements returns nArgsNode size remoteCopyNode temporaries optimized optimizedMessageNode actualScopeIfOptimized blockExtent remoteTempNode copiedValues closureCreationNode startOfLastStatement tempsMark ' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #BlockNode category: #'Compiler-ParseNodes' stamp: 'Install-3986-CodeNodeRefactoring-HernanWilkinson-2019Dec23-07h12m-HAW.1.cs.st 1/11/2020 17:57:45'! -CodeNode subclass: #BlockNode - instanceVariableNames: 'arguments statements returns nArgsNode size remoteCopyNode temporaries optimized optimizedMessageNode actualScopeIfOptimized blockExtent remoteTempNode copiedValues closureCreationNode startOfLastStatement tempsMark' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -CodeNode subclass: #MethodNode - instanceVariableNames: 'selectorOrFalse precedence arguments block primitive encoder temporaries properties sourceText locationCounter localsPool selectorKeywordsRanges ' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #MethodNode category: #'Compiler-ParseNodes' stamp: 'Install-3986-CodeNodeRefactoring-HernanWilkinson-2019Dec23-07h12m-HAW.1.cs.st 1/11/2020 17:57:45'! -CodeNode subclass: #MethodNode - instanceVariableNames: 'selectorOrFalse precedence arguments block primitive encoder temporaries properties sourceText locationCounter localsPool selectorKeywordsRanges' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! -!CodeNode methodsFor: 'accessing' stamp: 'HAW 12/23/2019 07:13:13'! - arguments - - self subclassResponsibility ! ! -!CodeNode methodsFor: 'accessing' stamp: 'HAW 12/23/2019 07:13:20'! - temporaries - - self subclassResponsibility ! ! -!CodeNode methodsFor: 'testing' stamp: 'HAW 12/23/2019 07:14:12'! - hasLocallyArgumentOrTemporaryNamed: aVariableName - - "See #hasArgumentOrTemporaryNamed: comment - Hernan" - ^(self hasNodeIn: self temporaries named: aVariableName) - or: [self hasNodeIn: self arguments named: aVariableName ]! ! -!CodeNode methodsFor: 'testing' stamp: 'HAW 12/23/2019 07:16:18'! - hasNodeIn: aCollectionOfNodes named: aName - - ^aCollectionOfNodes anySatisfy: [ :tempNode | tempNode name = aName ]! ! -!CodeNode methodsFor: 'testing' stamp: 'HAW 12/23/2019 07:15:28'! - isLocalArgumentOrTemporary: aParseNode - - "Looks only in this scope - Hernan" - ^(self temporaries includes: aParseNode) or: [ self arguments includes: aParseNode ] - ! ! - -CodeNode removeSelector: #hasArgumentOrTemporaryNamed:! - -CodeNode subclass: #BlockNode - instanceVariableNames: 'arguments statements returns nArgsNode size remoteCopyNode temporaries optimized optimizedMessageNode actualScopeIfOptimized blockExtent remoteTempNode copiedValues closureCreationNode startOfLastStatement tempsMark' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #BlockNode category: #'Compiler-ParseNodes' stamp: 'Install-3986-CodeNodeRefactoring-HernanWilkinson-2019Dec23-07h12m-HAW.1.cs.st 1/11/2020 17:57:45'! -CodeNode subclass: #BlockNode - instanceVariableNames: 'arguments statements returns nArgsNode size remoteCopyNode temporaries optimized optimizedMessageNode actualScopeIfOptimized blockExtent remoteTempNode copiedValues closureCreationNode startOfLastStatement tempsMark' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -CodeNode subclass: #MethodNode - instanceVariableNames: 'selectorOrFalse precedence arguments block primitive encoder temporaries properties sourceText locationCounter localsPool selectorKeywordsRanges' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #MethodNode category: #'Compiler-ParseNodes' stamp: 'Install-3986-CodeNodeRefactoring-HernanWilkinson-2019Dec23-07h12m-HAW.1.cs.st 1/11/2020 17:57:45'! -CodeNode subclass: #MethodNode - instanceVariableNames: 'selectorOrFalse precedence arguments block primitive encoder temporaries properties sourceText locationCounter localsPool selectorKeywordsRanges' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3986-CodeNodeRefactoring-HernanWilkinson-2019Dec23-07h12m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3985] on 23 December 2019 at 7:26:58 am'! -!CodeNode methodsFor: 'testing' stamp: 'HAW 12/23/2019 07:24:08' prior: 50487853! - hasLocallyArgumentOrTemporaryNamed: aVariableName - - "- hasArgumentOrTemporaryNamed: returns true if there is a temp or variable in this scope or subscopes - named aVariableName - - hasLocalName: returns true if there is a variable in the scopeTable name aVariableName. That includes - temps, arguments, instance variables and pseudo-variables - - hasLocallyArgumentOrTemporaryNamed: returns true if ony this scope defines a temp or argument - named aVariableName. - Hernan" - - ^(self hasNodeIn: self temporaries named: aVariableName) - or: [self hasNodeIn: self arguments named: aVariableName ]! ! -!MethodNode methodsFor: 'testing' stamp: 'HAW 12/23/2019 07:24:55' prior: 50487666! - hasArgumentOrTemporaryNamed: aVariableName - - "See #hasLocallyArgumentOrTemporaryNamed: comment - Hernan" - - ^self tempNames includes: aVariableName! ! -!MethodNode methodsFor: 'testing' stamp: 'HAW 12/23/2019 07:25:03' prior: 50487685! - hasLocalNamed: aName - - "See #hasLocallyArgumentOrTemporaryNamed: comment - Hernan" - - ^ encoder hasLocalNamed: aName ! ! - -MethodNode removeSelector: #hasLocallyArgumentOrTemporaryNamed:! - -!methodRemoval: MethodNode #hasLocallyArgumentOrTemporaryNamed: stamp: 'Install-3987-CodeNodeRefactoring2-HernanWilkinson-2019Dec23-07h21m-HAW.1.cs.st 1/11/2020 17:57:45'! -hasLocallyArgumentOrTemporaryNamed: aVariableName - - "See #hasArgumentOrTemporaryNamed: comment - Hernan" - ^(self hasNodeIn: self temporaries named: aVariableName) - or: [self hasNodeIn: self arguments named: aVariableName ]! - -MethodNode removeSelector: #isLocalArgumentOrTemporary:! - -!methodRemoval: MethodNode #isLocalArgumentOrTemporary: stamp: 'Install-3987-CodeNodeRefactoring2-HernanWilkinson-2019Dec23-07h21m-HAW.1.cs.st 1/11/2020 17:57:45'! -isLocalArgumentOrTemporary: aParseNode - - "Looks only in this scope - Hernan" - ^(self temporaries includes: aParseNode) or: [ self arguments includes: aParseNode ] - ! - -BlockNode removeSelector: #hasLocallyArgumentOrTemporaryNamed:! - -!methodRemoval: BlockNode #hasLocallyArgumentOrTemporaryNamed: stamp: 'Install-3987-CodeNodeRefactoring2-HernanWilkinson-2019Dec23-07h21m-HAW.1.cs.st 1/11/2020 17:57:45'! -hasLocallyArgumentOrTemporaryNamed: aVariableName - - ^(self hasNodeIn: self temporaries named: aVariableName) - or: [self hasNodeIn: self arguments named: aVariableName ]! - -BlockNode removeSelector: #isLocalArgumentOrTemporary:! - -!methodRemoval: BlockNode #isLocalArgumentOrTemporary: stamp: 'Install-3987-CodeNodeRefactoring2-HernanWilkinson-2019Dec23-07h21m-HAW.1.cs.st 1/11/2020 17:57:45'! -isLocalArgumentOrTemporary: aParseNode - - ^(self temporaries includes: aParseNode) or: [ self arguments includes: aParseNode ] - ! - -ParseNode removeSelector: #hasNodeIn:named:! - -!methodRemoval: ParseNode #hasNodeIn:named: stamp: 'Install-3987-CodeNodeRefactoring2-HernanWilkinson-2019Dec23-07h21m-HAW.1.cs.st 1/11/2020 17:57:45'! -hasNodeIn: aCollectionOfNodes named: aName - - ^aCollectionOfNodes anySatisfy: [ :tempNode | tempNode name = aName ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3987-CodeNodeRefactoring2-HernanWilkinson-2019Dec23-07h21m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3987] on 23 December 2019 at 8:33:32 am'! -!CodeNode methodsFor: 'accessing' stamp: 'HAW 12/23/2019 08:32:49'! - arguments: aCollectionOfArguments - - self subclassResponsibility ! ! -!CodeNode methodsFor: 'accessing' stamp: 'HAW 12/23/2019 08:29:27'! - block - - self subclassResponsibility ! ! -!CodeNode methodsFor: 'accessing' stamp: 'HAW 12/23/2019 08:31:57'! - temporaries: aCollectionOfTemporaries - - self subclassResponsibility ! ! -!CodeNode methodsFor: 'printing' stamp: 'HAW 12/23/2019 08:30:31'! - decompileString - - self subclassResponsibility ! ! -!BlockNode methodsFor: 'accessing' stamp: 'HAW 12/23/2019 08:32:32' prior: 16789587! - arguments: aCollectionOfArguments - "Decompile." - - arguments := aCollectionOfArguments! ! -!BlockNode methodsFor: 'accessing' stamp: 'HAW 12/23/2019 08:31:43' prior: 50462169! - temporaries: aCollectionOfTemporaries - "Collection of TempVariableNodes" - temporaries := aCollectionOfTemporaries! ! -!MethodNode methodsFor: 'accessing' stamp: 'HAW 12/23/2019 08:32:45' prior: 16872338! - arguments: aCollectionOfArguments - - "For transformations etc, not used in compilation" - arguments := aCollectionOfArguments! ! -!MethodNode methodsFor: 'accessing' stamp: 'HAW 12/23/2019 08:31:49' prior: 16872401! - temporaries: aCollectionOfTemporaries - "For transformations etc, not used in compilation" - temporaries := aCollectionOfTemporaries! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3988-CodeNodeRefactoring3-HernanWilkinson-2019Dec23-08h29m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3983] on 22 December 2019 at 7:34:47 pm'! - -ParseNodeVisitor subclass: #ArgumentDeclarationCounter - instanceVariableNames: 'argumentName counter' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ArgumentDeclarationCounter category: #'Tools-Refactoring' stamp: 'Install-3989-TemporaryToInstanceVariableWithArgumentsFix-EricBrandwein-2019Dec22-17h06m-EB.1.cs.st 1/11/2020 17:57:46'! -ParseNodeVisitor subclass: #ArgumentDeclarationCounter - instanceVariableNames: 'argumentName counter' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Smalltalk renameClassNamed: #ParseNodesDeclaringTemporaryVariableVisitor as: #ParseNodesDeclaringTemporaryVariableVisitor! - -Smalltalk renameClassNamed: #TemporaryVariableDeclarationCounter as: #TemporaryVariableDeclarationCounter! -!TemporaryVariableDeclarationRemover commentStamp: '' prior: 0! -I remove declarations of a temporary variable from the children of a ParseNode.! -!ArgumentDeclarationCounter methodsFor: 'initialization' stamp: 'EB 12/22/2019 19:14:35'! - initializeFor: anArgumentName - - argumentName := anArgumentName. - counter := 0! ! -!ArgumentDeclarationCounter methodsFor: 'visiting' stamp: 'EB 12/22/2019 19:21:08'! - declaresSoughtArgument: aParseNode - - ^aParseNode arguments anySatisfy: [ :argument | argument name = argumentName ]! ! -!ArgumentDeclarationCounter methodsFor: 'visiting' stamp: 'EB 12/22/2019 19:18:07'! - visitBlockNode: aBlockNode - - self visitPotentiallyDeclaringParseNode: aBlockNode. - super visitBlockNode: aBlockNode! ! -!ArgumentDeclarationCounter methodsFor: 'visiting' stamp: 'EB 12/22/2019 19:17:52'! - visitMethodNode: aMethodNode - - self visitPotentiallyDeclaringParseNode: aMethodNode. - super visitMethodNode: aMethodNode! ! -!ArgumentDeclarationCounter methodsFor: 'visiting' stamp: 'EB 12/22/2019 19:22:02'! - visitPotentiallyDeclaringParseNode: aParseNode - - (self declaresSoughtArgument: aParseNode) ifTrue: [ counter := counter + 1 ]! ! -!ArgumentDeclarationCounter methodsFor: 'accessing' stamp: 'EB 12/22/2019 19:12:12'! - count - - ^counter! ! -!ArgumentDeclarationCounter class methodsFor: 'instance creation' stamp: 'EB 12/22/2019 19:14:12'! - for: anArgumentName - - ^self new initializeFor: anArgumentName ! ! -!ParseNodesDeclaringTemporaryVariableVisitor methodsFor: 'visiting' stamp: 'EB 12/22/2019 18:41:19' prior: 50461926! - isNodeDeclaringTemporary: aParseNode - - ^aParseNode temporaries anySatisfy: [ :temporaryVariableNode | - temporaryVariableNode key = temporaryVariable - ].! ! -!SmalltalkEditor methodsFor: 'temp to inst var' stamp: 'EB 12/22/2019 19:31:10' prior: 50459454! - temporaryToInstanceVariable - - self - withNodeUnderCursorDo: [ :nodeUnderCursor | - (nodeUnderCursor isTemp and: [nodeUnderCursor isArg not]) - ifTrue: [ TemporaryToInstanceVariableApplier on: self for: nodeUnderCursor name :: value ] - ifFalse: [ morph flash ]] - ifAbsent: [ morph flash ].! ! -!TemporaryToInstanceVariable class methodsFor: 'assertions' stamp: 'EB 12/22/2019 18:48:54' prior: 50459558! - assert: aMethodNode hasTemporaryNamed: aTemporaryVariableName - - | counter | - - counter := TemporaryVariableDeclarationCounter for: aTemporaryVariableName. - aMethodNode accept: counter. - - counter count = 1 :: ifFalse: [ - self refactoringError: self inexistentTemporaryErrorDescription ].! ! -!TemporaryToInstanceVariable class methodsFor: 'assertions' stamp: 'EB 12/22/2019 19:32:35' prior: 50461853! - assertNoOtherBlockIn: aMethodNode definesTemporaryNamed: aTemporaryVariableName - - | temporaryCounter argumentCounter | - - temporaryCounter := TemporaryVariableDeclarationCounter for: aTemporaryVariableName. - aMethodNode accept: temporaryCounter. - - argumentCounter := ArgumentDeclarationCounter for: aTemporaryVariableName. - aMethodNode accept: argumentCounter. - - temporaryCounter count + argumentCounter count > 1 ifTrue: [ - self refactoringError: self temporaryExistsInOtherBlockErrorDescription ]. - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3989-TemporaryToInstanceVariableWithArgumentsFix-EricBrandwein-2019Dec22-17h06m-EB.1.cs.st----! - -'From Cuis 5.0 [latest update: #3987] on 23 December 2019 at 8:59:27 am'! -!CodeNode methodsFor: 'testing' stamp: 'HAW 12/23/2019 08:49:29'! - hasLocallyArgumentNamed: aVariableName - - ^self hasNodeIn: self arguments named: aVariableName! ! -!CodeNode methodsFor: 'testing' stamp: 'HAW 12/23/2019 08:49:24'! - hasLocallyTemporaryNamed: aVariableName - - ^self hasNodeIn: self temporaries named: aVariableName ! ! -!CodeNode methodsFor: 'testing' stamp: 'HAW 12/23/2019 08:47:40' prior: 50487937! - hasLocallyArgumentOrTemporaryNamed: aVariableName - - "- hasArgumentOrTemporaryNamed: returns true if there is a temp or variable in this scope or subscopes - named aVariableName - - hasLocalName: returns true if there is a variable in the scopeTable name aVariableName. That includes - temps, arguments, instance variables and pseudo-variables - - hasLocallyArgumentOrTemporaryNamed: returns true if ony this scope defines a temp or argument - named aVariableName. - Hernan" - - ^(self hasLocallyArgumentNamed: aVariableName) - or: [self hasLocallyTemporaryNamed: aVariableName]! ! -!ArgumentDeclarationCounter methodsFor: 'visiting' stamp: 'HAW 12/23/2019 08:48:15' prior: 50488131! - declaresSoughtArgument: aParseNode - - ^aParseNode hasLocallyArgumentNamed: argumentName - - ! ! -!ParseNodesDeclaringTemporaryVariableVisitor methodsFor: 'visiting' stamp: 'HAW 12/23/2019 08:51:24' prior: 50488169! - isNodeDeclaringTemporary: aParseNode - - ^aParseNode hasLocallyTemporaryNamed: temporaryVariable - ! ! -!ParseNodesDeclaringTemporaryVariableVisitor methodsFor: 'visiting' stamp: 'HAW 12/23/2019 08:53:50' prior: 50461935! - visitBlockNode: aBlockNode - - (self isNodeDeclaringTemporary: aBlockNode) ifTrue: [ - self visitBlockNodeDeclaringTemporary: aBlockNode ]. - - super visitBlockNode: aBlockNode.! ! -!ParseNodesDeclaringTemporaryVariableVisitor methodsFor: 'visiting' stamp: 'HAW 12/23/2019 08:53:57' prior: 50461950! - visitMethodNode: aMethodNode - - (self isNodeDeclaringTemporary: aMethodNode) ifTrue: [ - self visitMethodNodeDeclaringTemporary: aMethodNode ]. - - super visitMethodNode: aMethodNode.! ! -!TemporaryVariableDeclarationRemover methodsFor: 'visiting' stamp: 'HAW 12/23/2019 08:54:15' prior: 50462142! - visitNodeDeclaringTemporary: aParseNode - withTemporaryDeclarationLineRemover: aTemporaryDeclarationLineRemovingBlock - - newSourceCode _ self - sourceTextWithoutTemporaryFromParseNode: aParseNode - withTemporaryDeclarationLineRemover: aTemporaryDeclarationLineRemovingBlock. - - methodNode methodClass compile: newSourceCode.! ! -!TemporaryToInstanceVariable class methodsFor: 'assertions' stamp: 'HAW 12/23/2019 08:52:40' prior: 50488190! - assert: aMethodNode hasTemporaryNamed: aTemporaryVariableName - - | counter | - - counter := TemporaryVariableDeclarationCounter for: aTemporaryVariableName. - aMethodNode accept: counter. - - counter count = 1 ifFalse: [ - self refactoringError: self inexistentTemporaryErrorDescription ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3990-TemporaryToInstanceVariableWithArgumentsRefactoring-HernanWilkinson-2019Dec23-08h47m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3982] on 20 December 2019 at 8:56:58 pm'! - -"Change Set: 3983-CuisCore-AuthorName-2019Dec20-20h38m -Date: 20 December 2019 -Author: Nahuel Garbezza - -Extract Method refactoring"! - -Refactoring subclass: #ExtractMethod - instanceVariableNames: 'intervalToExtract categoryOfNewSelector newMessage extractedSourceCode existingMethod' - classVariableNames: '' - poolDictionaries: '' - category: 'Refactorings-ExtractMethod'! - -!classDefinition: #ExtractMethod category: #'Refactorings-ExtractMethod' stamp: 'Install-3991-ExtractMethod-NahuelGarbezza-2019Dec20-20h38m-RNG.1.cs.st 1/11/2020 17:57:46'! -Refactoring subclass: #ExtractMethod - instanceVariableNames: 'intervalToExtract categoryOfNewSelector newMessage extractedSourceCode existingMethod' - classVariableNames: '' - poolDictionaries: '' - category: 'Refactorings-ExtractMethod'! - -RefactoringApplier subclass: #ExtractMethodApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newSelector newMessageArguments' - classVariableNames: '' - poolDictionaries: '' - category: 'Refactorings-ExtractMethod'! - -!classDefinition: #ExtractMethodApplier category: #'Refactorings-ExtractMethod' stamp: 'Install-3991-ExtractMethod-NahuelGarbezza-2019Dec20-20h38m-RNG.1.cs.st 1/11/2020 17:57:46'! -RefactoringApplier subclass: #ExtractMethodApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newSelector newMessageArguments' - classVariableNames: '' - poolDictionaries: '' - category: 'Refactorings-ExtractMethod'! - -RefactoringPrecondition subclass: #ExtractMethodNewSelectorPrecondition - instanceVariableNames: 'selectorToValidate classToDefineSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Refactorings-ExtractMethod'! - -!classDefinition: #ExtractMethodNewSelectorPrecondition category: #'Refactorings-ExtractMethod' stamp: 'Install-3991-ExtractMethod-NahuelGarbezza-2019Dec20-20h38m-RNG.1.cs.st 1/11/2020 17:57:46'! -RefactoringPrecondition subclass: #ExtractMethodNewSelectorPrecondition - instanceVariableNames: 'selectorToValidate classToDefineSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Refactorings-ExtractMethod'! - -Object subclass: #ExtractMethodEditorMenu - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Refactorings-ExtractMethod'! - -!classDefinition: #ExtractMethodEditorMenu category: #'Refactorings-ExtractMethod' stamp: 'Install-3991-ExtractMethod-NahuelGarbezza-2019Dec20-20h38m-RNG.1.cs.st 1/11/2020 17:57:46'! -Object subclass: #ExtractMethodEditorMenu - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Refactorings-ExtractMethod'! - -Object subclass: #ExtractMethodExpressionValidation - instanceVariableNames: 'method intervalToExtract methodNode sourceCode initialNode finalNode initialNodeAncestors finalNodeAncestors' - classVariableNames: '' - poolDictionaries: '' - category: 'Refactorings-ExtractMethod'! - -!classDefinition: #ExtractMethodExpressionValidation category: #'Refactorings-ExtractMethod' stamp: 'Install-3991-ExtractMethod-NahuelGarbezza-2019Dec20-20h38m-RNG.1.cs.st 1/11/2020 17:57:46'! -Object subclass: #ExtractMethodExpressionValidation - instanceVariableNames: 'method intervalToExtract methodNode sourceCode initialNode finalNode initialNodeAncestors finalNodeAncestors' - classVariableNames: '' - poolDictionaries: '' - category: 'Refactorings-ExtractMethod'! - -Object subclass: #ExtractMethodIntervalTrimmer - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Refactorings-ExtractMethod'! - -!classDefinition: #ExtractMethodIntervalTrimmer category: #'Refactorings-ExtractMethod' stamp: 'Install-3991-ExtractMethod-NahuelGarbezza-2019Dec20-20h38m-RNG.1.cs.st 1/11/2020 17:57:46'! -Object subclass: #ExtractMethodIntervalTrimmer - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Refactorings-ExtractMethod'! -!Message methodsFor: 'accessing' stamp: 'RNG 6/23/2019 20:03:36'! - fullName - - ^ String streamContents: [ :messageStream | - args - ifEmpty: [ messageStream nextPutAll: selector ] - ifNotEmpty: [ - self selector keywords withIndexDo: [ :keyword :index | - messageStream - nextPutAll: keyword; - nextPut: Character space; - nextPutAll: (args at: index). - "add an space unless it's the last keyword" - index = self selector keywords size ifFalse: [ messageStream nextPut: Character space ] - ] - ]. - ]! ! -!Symbol methodsFor: 'testing' stamp: 'RNG 9/10/2019 19:09:10'! - isValidSelector - - ^ (self isUnary and: [ self allSatisfy: [ :character | character isValidInIdentifiers ] ]) - or: [ self isKeyword and: [ self keywords allSatisfy: [ :keywordString | keywordString allButLast asSymbol isValidSelector ] ] ]! ! -!ParseNode methodsFor: 'testing' stamp: 'RNG 9/28/2019 01:40:07'! - equivalentTo: aParseNode - - ^ aParseNode isTemp and: [ self key = aParseNode key ]! ! -!ParseNode methodsFor: 'testing' stamp: 'RNG 9/8/2019 19:05:07'! - isAssignmentToTemporary - - ^ false! ! -!ParseNode methodsFor: 'private' stamp: 'RNG 9/10/2019 17:12:27'! - consolidateAsCollection: sourceRanges - - ^ sourceRanges isInterval - ifTrue: [ OrderedCollection with: sourceRanges ] - ifFalse: [ sourceRanges ]! ! -!ParseNode methodsFor: 'source ranges' stamp: 'RNG 9/7/2019 20:05:56'! - expandIfEnclosedWithParentheses: sourceRange on: sourceCode - - | startsWithParen endsWithParen | - self flag: #RNG. "take into account other cases: spaces in middle, multiple parenthesis" - startsWithParen _ (sourceCode at: sourceRange first - 1 ifAbsent: [nil]) = $(. - endsWithParen _ (sourceCode at: sourceRange last + 1 ifAbsent: [nil]) = $). - ^ startsWithParen & endsWithParen - ifTrue: [ sourceRange first - 1 to: sourceRange last + 1 ] - ifFalse: [ sourceRange ]! ! -!ParseNode methodsFor: 'source ranges' stamp: 'RNG 7/9/2019 15:55:40'! - expandRange: aSourceRange basedOn: sourceRangesOfChildNode - - | intervals | - intervals _ sourceRangesOfChildNode isInterval - ifTrue: [ OrderedCollection with: sourceRangesOfChildNode ] ifFalse: [ sourceRangesOfChildNode ]. - intervals withIndexDo: [ :interval :index | - (interval first > aSourceRange first) ifTrue: [ - ^ (aSourceRange first min: (intervals at: index - 1 ifAbsent: [ intervals last ]) first) to: aSourceRange last ] ]. - ^ (aSourceRange first min: intervals last first) to: aSourceRange last! ! -!ParseNode methodsFor: 'source ranges' stamp: 'RNG 9/10/2019 17:33:30'! - expandRanges: sourceRanges basedOn: allSourceRanges using: sourceCode - - ^ (self consolidateAsCollection: sourceRanges) - collect: [ :sourceRange | self expandIfEnclosedWithParentheses: sourceRange on: sourceCode ]! ! -!Encoder methodsFor: 'source mapping' stamp: 'RNG 9/7/2019 19:58:40'! - completeSourceRangesBasedOn: sourceCode - - | completeSourceRanges | - completeSourceRanges _ Dictionary new. - sourceRanges keysAndValuesDo: [ :parseNode :nodeRanges | - | expandedNodeSourceRanges | - expandedNodeSourceRanges _ parseNode expandRanges: nodeRanges basedOn: sourceRanges using: sourceCode. - completeSourceRanges at: parseNode put: expandedNodeSourceRanges ]. - ^ completeSourceRanges! ! -!Encoder methodsFor: 'source mapping' stamp: 'RNG 7/9/2019 11:14:09'! - parseNodesPathAt: aPosition using: expandedSourceRanges ifAbsent: aBlockClosure - - | nodesWithRangeAtPosition | - nodesWithRangeAtPosition _ SortedCollection sortBlock: [ :nodePathOne :nodePathTwo | - nodePathOne value first >= nodePathTwo value first and: [ - nodePathOne value last <= nodePathTwo value last ] ]. - - expandedSourceRanges associationsDo: [ :nodeAtRange | - self withRangesOf: nodeAtRange including: aPosition do: [ :aRange | - nodesWithRangeAtPosition add: (nodeAtRange key -> aRange) ] ]. - - ^ nodesWithRangeAtPosition - ifEmpty: aBlockClosure - ifNotEmpty: [ nodesWithRangeAtPosition ]! ! -!AssignmentNode methodsFor: 'testing' stamp: 'RNG 9/8/2019 19:03:48'! - isAssignmentToTemporary - - ^ self isAssignmentNode and: [ variable isTemp ]! ! -!AssignmentNode methodsFor: 'source ranges' stamp: 'RNG 12/20/2019 20:51:44'! - expandRanges: sourceRanges basedOn: allSourceRanges using: sourceCode - - ^ self consolidateAsCollection: (self - expandRange: (sourceRanges isInterval ifTrue: [ sourceRanges ] ifFalse: [ sourceRanges first ]) - basedOn: (allSourceRanges at: variable))! ! -!BlockNode methodsFor: 'testing' stamp: 'RNG 12/20/2019 20:49:06'! - hasArgumentOrTemporaryNamed: aName - - ^ (temporaries union: arguments) anySatisfy: [ :temp | temp isNamed: aName ]! ! -!BlockNode methodsFor: 'source ranges' stamp: 'RNG 9/10/2019 17:13:25'! - expandRanges: sourceRanges basedOn: allSourceRanges using: sourceCode - "the closure creation node already contains the source ranges including the [ ] and arguments declaration" - - ^ self consolidateAsCollection: (allSourceRanges at: closureCreationNode)! ! -!LiteralNode methodsFor: 'testing' stamp: 'RNG 9/19/2019 21:32:10'! - equivalentTo: aParseNode - - ^ aParseNode isLiteralNode and: [ self key = aParseNode key ]! ! -!VariableNode methodsFor: 'testing' stamp: 'RNG 9/8/2019 20:46:04'! -isNamed: aName - - ^ self name = aName! ! -!MessageNode methodsFor: 'source ranges' stamp: 'RNG 9/19/2019 21:16:03'! - expandRanges: aSourceRange basedOn: sourceRanges using: sourceCode - - | receiverExpandedRanges expandedRangeWithReceiver | - receiverExpandedRanges _ self isCascade - ifTrue: [ self flag: #RNG . aSourceRange ] "fix source ranges for cascade messages" - ifFalse: [ receiver expandRanges: (self receiverSourceRangesFrom: sourceRanges) basedOn: sourceRanges using: sourceCode ]. - expandedRangeWithReceiver _ self - expandRange: (aSourceRange isInterval ifTrue: [ aSourceRange ] ifFalse: [ aSourceRange first ]) - basedOn: receiverExpandedRanges. - ^ self consolidateAsCollection: (self expandIfEnclosedWithParentheses: expandedRangeWithReceiver on: sourceCode)! ! -!MessageNode methodsFor: 'source ranges' stamp: 'RNG 9/19/2019 21:24:41'! - receiverSourceRangesFrom: sourceRanges - "we can't just do #at: because sometimes what it is on the source ranges map - is not the exact same object than the receiver or the originalReceiver - (like when optimizations are made), so we look for an 'equivalent' one - (at least for using as a key in the source ranges)" - - ^ sourceRanges at: receiver ifAbsent: [ - | parseNodeOfReceiver | - parseNodeOfReceiver _ sourceRanges keys detect: [ :parseNode | - (parseNode equivalentTo: receiver) or: [ parseNode equivalentTo: originalReceiver ] ]. - sourceRanges at: parseNodeOfReceiver - ]! ! -!MessageNode methodsFor: 'testing' stamp: 'RNG 9/19/2019 21:31:18'! - equivalentTo: aParseNode - - self flag: #RNG. "complete definition by checking each argument" - ^ aParseNode isMessageNode - :: and: [ self receiver equivalentTo: aParseNode ] - :: and: [ self selector = aParseNode selector ] - :: and: [ self arguments isEmpty ]! ! -!MethodNode methodsFor: '*Refactorings-ExtractMethod' stamp: 'RNG 9/10/2019 17:19:25'! - allParseNodesWithin: aSourceCodeInterval satisfy: aCondition - - self completeSourceRangesDo: [ :parseNode :sourceRanges | - (aCondition value: parseNode) ifTrue: [ - sourceRanges anySatisfy: [ :sourceRange | aSourceCodeInterval rangeIncludes: sourceRange first ] - :: ifTrue: [ ^ false ] - ] ]. - ^ true! ! -!MethodNode methodsFor: '*Refactorings-ExtractMethod' stamp: 'RNG 9/7/2019 20:00:55'! - completeSourceRanges - "Returns the 'expanded' version of the source ranges, for instance in message sends it also includes the receiver, and if there are parentheses they are included in the source range as well. Right now used for refactorings." - - ^ encoder completeSourceRangesBasedOn: self sourceText! ! -!MethodNode methodsFor: '*Refactorings-ExtractMethod' stamp: 'RNG 9/10/2019 17:10:08'! - completeSourceRangesDo: aBinaryBlock - "block has to receive parse node and collection of source ranges" - - ^ self completeSourceRanges keysAndValuesDo: aBinaryBlock! ! -!MethodNode methodsFor: '*Refactorings-ExtractMethod' stamp: 'RNG 9/7/2019 19:41:58'! - parseNodesPathAt: aPosition ifAbsent: aBlockClosure - - ^ encoder - parseNodesPathAt: aPosition - using: self completeSourceRanges - ifAbsent: aBlockClosure! ! -!SmalltalkEditor methodsFor: 'extract method' stamp: 'RNG 12/20/2019 20:54:56'! - extractMethod - - "hack to prevent the extract method to be evaluated on editors w/o methods like the workspace" - self codeProvider respondsTo: #currentCompiledMethod - :: and: [ self codeProvider currentCompiledMethod notNil ] - :: ifFalse: [ ^ nil ]. - - morph owningWindow okToChange ifTrue: [ - ExtractMethodApplier createAndValueHandlingExceptions: [ - ExtractMethodApplier for: self selectionInterval of: self codeProvider currentCompiledMethod ] ]! ! -!SmalltalkEditor methodsFor: 'extract method' stamp: 'RNG 5/9/2019 00:06:54'! - extractMethod: aKeyboardEvent - - self extractMethod. - ^true! ! -!ExtractMethod methodsFor: 'applying' stamp: 'RNG 4/29/2019 00:45:18'! - apply - - self - defineExtractedMethod; - changeExistingMethod! ! -!ExtractMethod methodsFor: 'applying' stamp: 'RNG 6/23/2019 20:29:44'! - changeExistingMethod - - self sourceClass - compile: self updatedSourceCodeOfExistingMethod - classified: existingMethod category! ! -!ExtractMethod methodsFor: 'applying' stamp: 'RNG 6/23/2019 20:25:44'! - defineExtractedMethod - - self sourceClass - compile: self newMethodSourceCode - classified: categoryOfNewSelector! ! -!ExtractMethod methodsFor: 'initialization' stamp: 'RNG 6/23/2019 20:29:44'! - initializeExtractedSourceCode - - extractedSourceCode _ existingMethod sourceCode - copyFrom: intervalToExtract first - to: intervalToExtract last! ! -!ExtractMethod methodsFor: 'initialization' stamp: 'RNG 6/23/2019 20:29:44'! - initializeFrom: anIntervalToExtract of: aMethodToExtractCodeFrom to: aNewMessage in: aCategory - - intervalToExtract _ anIntervalToExtract. - existingMethod _ aMethodToExtractCodeFrom. - newMessage _ aNewMessage. - categoryOfNewSelector _ aCategory. - self initializeExtractedSourceCode.! ! -!ExtractMethod methodsFor: 'private - source code' stamp: 'RNG 10/13/2019 19:00:16'! - callingExpression - - | expression | - expression _ 'self ', self newMessageString. - - ^ self shouldBeEnclosedWithParens - ifTrue: [ '(' , expression , ')' ] - ifFalse: [ expression ]! ! -!ExtractMethod methodsFor: 'private - source code' stamp: 'RNG 6/23/2019 19:57:48'! - newMessageString - - ^ newMessage fullName! ! -!ExtractMethod methodsFor: 'private - source code' stamp: 'RNG 9/19/2019 22:04:14'! -newMethodSourceCode - - ^ self newMessageString - , self startingMethodIdentation - , self returnCharacterIfNeeded - , extractedSourceCode! ! -!ExtractMethod methodsFor: 'private - source code' stamp: 'RNG 6/23/2019 20:26:40'! - returnCharacterIfNeeded - - | parseNode | - parseNode _ Parser parse: extractedSourceCode class: self sourceClass noPattern: true. - ^ parseNode block statements size = 1 ifTrue: [ '^ ' ] ifFalse: [ '' ]! ! -!ExtractMethod methodsFor: 'private - source code' stamp: 'RNG 10/13/2019 18:58:51'! -shouldBeEnclosedWithParens - - | initialNode finalNode parseNodesInCommon methodNode initialNodeAncestors finalNodeAncestors insideMessageNodeExpressions | - - methodNode _ existingMethod methodNode. - initialNodeAncestors _ methodNode parseNodesPathAt: intervalToExtract first ifAbsent: [ ^ false]. - finalNodeAncestors _ methodNode parseNodesPathAt: intervalToExtract last ifAbsent: [ ^ false ]. - parseNodesInCommon _ initialNodeAncestors intersection: finalNodeAncestors. - - initialNode _ (parseNodesInCommon at: 1 ifAbsent: [ ^ false ]) key. - finalNode _ (parseNodesInCommon at: 2 ifAbsent: [ ^ false ]) key. - insideMessageNodeExpressions _ initialNode isMessageNode and: [ finalNode isMessageNode ]. - - ^ insideMessageNodeExpressions - and: [ initialNode precedence < newMessage selector precedence ] - :: and: [ initialNode precedence <= finalNode precedence ]! ! -!ExtractMethod methodsFor: 'private - source code' stamp: 'RNG 6/23/2019 20:29:44'! - sourceClass - - ^ existingMethod methodClass! ! -!ExtractMethod methodsFor: 'private - source code' stamp: 'RNG 9/19/2019 22:04:09'! - startingMethodIdentation - - ^ String lfString , String lfString , String tab! ! -!ExtractMethod methodsFor: 'private - source code' stamp: 'RNG 10/13/2019 18:26:11'! - updatedSourceCodeOfExistingMethod - - ^ existingMethod sourceCode - copyReplaceFrom: intervalToExtract first - to: intervalToExtract last - with: self callingExpression! ! -!ExtractMethod class methodsFor: 'validations' stamp: 'RNG 5/4/2019 22:40:07'! - ensure: aSelector canBeDefinedIn: aClass - - ExtractMethodNewSelectorPrecondition valueFor: aSelector on: aClass! ! -!ExtractMethod class methodsFor: 'validations' stamp: 'RNG 9/7/2019 19:23:53'! - ensure: anIntervalToExtract isValidIntervalOn: aMethodToExtractCodeFrom - - self isNotEmpty: anIntervalToExtract - :: ifFalse: [ self signalNoSelectedCodeError ]. - self is: anIntervalToExtract withinBoundsOf: aMethodToExtractCodeFrom sourceCode - :: ifFalse: [ self signalOutOfBoundsIntervalError ]. - self method: aMethodToExtractCodeFrom containsAValidExpressionOn: anIntervalToExtract - :: ifFalse: [ self signalSelectedCodeIsInvalidForExtractError ].! ! -!ExtractMethod class methodsFor: 'validations - private' stamp: 'RNG 5/28/2019 00:22:21'! - is: anIntervalToExtract withinBoundsOf: aSourceCode - - ^ anIntervalToExtract first >= 1 and: [ anIntervalToExtract last <= aSourceCode size ]! ! -!ExtractMethod class methodsFor: 'validations - private' stamp: 'RNG 9/7/2019 19:26:15'! - isNotEmpty: anInterval - - ^ anInterval first <= anInterval last! ! -!ExtractMethod class methodsFor: 'validations - private' stamp: 'RNG 7/6/2019 20:06:09'! - method: aMethod containsAValidExpressionOn: anIntervalToExtract - - ^ (ExtractMethodExpressionValidation for: anIntervalToExtract of: aMethod) passed! ! -!ExtractMethod class methodsFor: 'error messages' stamp: 'RNG 9/7/2019 19:20:33'! - noSelectionErrorMessage - - ^ 'Please select some code for extraction'! ! -!ExtractMethod class methodsFor: 'error messages' stamp: 'RNG 4/20/2019 21:53:45'! - outOfBoundsSelectionErrorMessage - - ^ 'The source code selection interval is out of bounds'! ! -!ExtractMethod class methodsFor: 'error messages' stamp: 'RNG 5/12/2019 23:42:45'! - selectedCodeInvalidForExtractErrorMessage - - ^ 'The selected code can not be extracted to a method'! ! -!ExtractMethod class methodsFor: 'exceptions' stamp: 'RNG 9/7/2019 19:24:57'! - signalNoSelectedCodeError - - self refactoringError: self noSelectionErrorMessage! ! -!ExtractMethod class methodsFor: 'exceptions' stamp: 'RNG 4/20/2019 21:53:24'! - signalOutOfBoundsIntervalError - - self refactoringError: self outOfBoundsSelectionErrorMessage! ! -!ExtractMethod class methodsFor: 'exceptions' stamp: 'RNG 5/12/2019 23:54:19'! - signalSelectedCodeIsInvalidForExtractError - - self refactoringError: self selectedCodeInvalidForExtractErrorMessage! ! -!ExtractMethod class methodsFor: 'instance creation' stamp: 'RNG 6/23/2019 18:24:36'! - fromInterval: anIntervalToExtract of: aMethodToExtractCodeFrom to: newMessage categorizedAs: aCategory - - | trimmedIntervalToExtract | - trimmedIntervalToExtract _ ExtractMethodIntervalTrimmer - trim: anIntervalToExtract locatedIn: aMethodToExtractCodeFrom sourceCode. - self - ensure: newMessage selector canBeDefinedIn: aMethodToExtractCodeFrom methodClass; - ensure: trimmedIntervalToExtract isValidIntervalOn: aMethodToExtractCodeFrom. - - ^ self new - initializeFrom: trimmedIntervalToExtract - of: aMethodToExtractCodeFrom - to: newMessage - in: aCategory! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 9/10/2019 17:26:45'! - blockNodesEnclosingIntervalToExtract - - | nodes | - nodes _ Set new. - methodToExtractCodeFrom methodNode completeSourceRangesDo: [ :parseNode :sourceRanges | - parseNode isBlockNode - :: and: [ self intervalToExtractIsCoveredByAnyOf: sourceRanges ] - :: ifTrue: [ nodes add: parseNode ] ]. - ^ nodes! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 9/10/2019 18:31:16'! - buildInitialSelectorAnswer: parseNodesToParameterize - "builds a selector with the shape of #m1 if unary, or #m1: something m2: else if it has args" - - ^ parseNodesToParameterize - ifEmpty: [ self formatAsKeyword: 'm1' ] - ifNotEmpty: [ parseNodesToParameterize - inject: '' - into: [ :partialSelector :parseNode | - | currentKeyword | - currentKeyword _ 'm' , (parseNodesToParameterize indexOf: parseNode) asString , ': '. - partialSelector - , (self formatAsKeyword: currentKeyword) - , (self formatAsMethodArgument: parseNode name) - , String newLineString ] ]! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 12/20/2019 20:48:35'! - definedInOuterScope: parseNode - - ^ self nodesThatAddVariablesToScope - anySatisfy: [ :node | node hasArgumentOrTemporaryNamed: parseNode name ]! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 9/10/2019 18:30:31'! - formatAsKeyword: aKeyword - - ^ Text - string: aKeyword - attributes: (SHTextStylerST80 attributesFor: #patternKeyword)! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 9/10/2019 18:31:37'! - formatAsMethodArgument: aMethodArgumentName - - ^ Text - string: aMethodArgumentName - attributes: (SHTextStylerST80 attributesFor: #methodArg)! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 9/10/2019 17:26:57'! - intervalToExtractIsCoveredByAnyOf: sourceRanges - - ^ sourceRanges anySatisfy: [ :sourceRange | - sourceRange first < intervalToExtract first - and: [ sourceRange last > intervalToExtract last ] ]! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 9/10/2019 17:30:00'! - nodesThatAddVariablesToScope - - ^ (Set with: methodToExtractCodeFrom methodNode) , self blockNodesEnclosingIntervalToExtract! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 9/10/2019 17:15:34'! - parseNodesToParameterize - - | parseNodesFound | - parseNodesFound _ OrderedCollection new. - methodToExtractCodeFrom methodNode completeSourceRangesDo: [ :parseNode :sourceRanges | - (self shouldBeParameterized: parseNode appearingIn: sourceRanges) - ifTrue: [ parseNodesFound add: parseNode ] - ]. - ^ parseNodesFound! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 9/8/2019 20:51:17'! - saveBinaryOrKeywordSelector: userAnswer withArguments: parseNodesToParameterize - - self saveMessageArgumentsForEach: parseNodesToParameterize using: userAnswer. - newSelector _ '' join: (self selectorTokensOf: userAnswer) :: asSymbol.! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 9/19/2019 22:11:12'! - saveMessageArgumentsForEach: parseNodesToParameterize using: userAnswer - - | newSelectorKeywords | - newSelectorKeywords _ self selectorTokensOf: userAnswer. - self validateRequiredParameters: parseNodesToParameterize haveACorrespondingKeywordIn: newSelectorKeywords. - parseNodesToParameterize withIndexDo: [ :parseNode :index | - newMessageArguments at: (newSelectorKeywords at: index) put: parseNode ]! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 9/8/2019 20:55:52'! - selectorTokensOf: userAnswer - "this selects the pieces of strings before each $:" - - ^ (userAnswer findTokens: ':') allButLast - collect: [ :tok | (tok findTokens: Character separators) last , ':' ]! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 9/10/2019 17:16:48'! - shouldBeParameterized: parseNode appearingIn: sourceRanges - - ^ sourceRanges anySatisfy: [ :sourceRange | intervalToExtract includes: sourceRange first ] - :: and: [ parseNode isTempOrArg ] - :: and: [ self definedInOuterScope: parseNode ]! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 9/19/2019 20:43:42'! - signalExtractMethodWithWrongNumberOfArgumentsError - - ^ ExtractMethod refactoringError: 'The number of arguments in the entered selector is not correct'! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 9/19/2019 22:11:43'! - validateRequiredParameters: parseNodesToParameterize haveACorrespondingKeywordIn: newSelectorKeywords - - newSelectorKeywords size = parseNodesToParameterize size - ifFalse: [ self signalExtractMethodWithWrongNumberOfArgumentsError ]! ! -!ExtractMethodApplier methodsFor: 'refactoring - parameters request' stamp: 'RNG 9/10/2019 18:23:12'! - requestRefactoringParameters - - | parseNodesToParameterize initialAnswer userAnswer | - parseNodesToParameterize _ self parseNodesToParameterize. - initialAnswer _ self buildInitialSelectorAnswer: parseNodesToParameterize. - userAnswer _ self request: 'New method name:' initialAnswer: initialAnswer. - - parseNodesToParameterize - ifEmpty: [ self saveUnarySelector: userAnswer ] - ifNotEmpty: [ self saveBinaryOrKeywordSelector: userAnswer withArguments: parseNodesToParameterize ]! ! -!ExtractMethodApplier methodsFor: 'initialization' stamp: 'RNG 6/23/2019 19:08:58'! - initializeFor: anIntervalToExtract of: aMethodToExtractCodeFrom - - intervalToExtract _ anIntervalToExtract. - methodToExtractCodeFrom _ aMethodToExtractCodeFrom. - newMessageArguments _ Dictionary new! ! -!ExtractMethodApplier methodsFor: 'private - new message' stamp: 'RNG 9/8/2019 20:39:42'! - buildNewMessage - - ^ Message - selector: newSelector - arguments: self newMessageArgumentNames! ! -!ExtractMethodApplier methodsFor: 'private - new message' stamp: 'RNG 9/8/2019 20:39:33'! - newMessageArgumentNames - - ^ newMessageArguments values collect: [ :parseNode | parseNode name ]! ! -!ExtractMethodApplier methodsFor: 'private - new message' stamp: 'RNG 9/8/2019 20:05:08'! - saveUnarySelector: userAnswer - - ^ newSelector _ userAnswer asSymbol! ! -!ExtractMethodApplier methodsFor: 'refactoring - creation' stamp: 'RNG 6/23/2019 20:11:34'! - createRefactoring - - ^ ExtractMethod - fromInterval: intervalToExtract - of: methodToExtractCodeFrom - to: self buildNewMessage - categorizedAs: methodToExtractCodeFrom category! ! -!ExtractMethodApplier methodsFor: 'refactoring - changes' stamp: 'RNG 5/13/2019 02:17:27'! - showChanges! ! -!ExtractMethodApplier class methodsFor: 'instance creation' stamp: 'RNG 6/2/2019 18:56:51'! - for: anIntervalToExtract of: aMethodToExtractCodeFrom - - | trimmedIntervalToExtract sourceCode | - sourceCode _ aMethodToExtractCodeFrom sourceCode. - trimmedIntervalToExtract _ ExtractMethodIntervalTrimmer trim: anIntervalToExtract locatedIn: sourceCode. - - self assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: trimmedIntervalToExtract. - - ^ self new initializeFor: trimmedIntervalToExtract of: aMethodToExtractCodeFrom! ! -!ExtractMethodApplier class methodsFor: 'pre-conditions' stamp: 'RNG 5/13/2019 02:06:39'! - assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: anIntervalToExtract - - ExtractMethod - ensure: anIntervalToExtract - isValidIntervalOn: aMethodToExtractCodeFrom! ! -!ExtractMethodNewSelectorPrecondition methodsFor: 'exceptions' stamp: 'RNG 6/2/2019 19:20:09'! - signalNewSelectorBeginsWithAnInvalidCharacter - - self refactoringError: self class invalidStartingCharacterOfNewSelectorErrorMessage! ! -!ExtractMethodNewSelectorPrecondition methodsFor: 'exceptions' stamp: 'RNG 4/18/2019 15:11:55'! - signalNewSelectorCanNotBeEmptyError - - self refactoringError: self class newSelectorCanNotBeEmptyErrorMessage! ! -!ExtractMethodNewSelectorPrecondition methodsFor: 'exceptions' stamp: 'RNG 5/5/2019 12:22:02'! - signalNewSelectorCanNotContainSeparatorsError - - self refactoringError: self class newSelectorCanNotContainSeparatorsErrorMessage! ! -!ExtractMethodNewSelectorPrecondition methodsFor: 'exceptions' stamp: 'RNG 9/10/2019 18:53:55'! - signalNewSelectorContainsInvalidCharactersError - - self refactoringError: self class invalidCharacterInsideNewSelectorErrorMessage! ! -!ExtractMethodNewSelectorPrecondition methodsFor: 'exceptions' stamp: 'RNG 5/5/2019 12:22:40'! - signalNewSelectorIsAlreadyDefinedInTheClassError - - self refactoringError: self class newSelectorAlreadyDefinedOnTheClassErrorMessage! ! -!ExtractMethodNewSelectorPrecondition methodsFor: 'evaluating - private' stamp: 'RNG 6/2/2019 19:21:50'! - assertNewSelectorBeginsWithAValidCharacter - - selectorToValidate first isValidStartOfIdentifiers - ifFalse: [ self signalNewSelectorBeginsWithAnInvalidCharacter ]! ! -!ExtractMethodNewSelectorPrecondition methodsFor: 'evaluating - private' stamp: 'RNG 12/20/2019 20:53:38'! - assertNewSelectorContainsOnlyValidCharacters - - selectorToValidate isValidSelector - ifFalse: [ self signalNewSelectorContainsInvalidCharactersError ]! ! -!ExtractMethodNewSelectorPrecondition methodsFor: 'evaluating - private' stamp: 'RNG 4/18/2019 15:13:52'! - assertNewSelectorDoesNotContainSeparators - - (selectorToValidate anySatisfy: [ :character | character isSeparator ]) - ifTrue: [ self signalNewSelectorCanNotContainSeparatorsError ]! ! -!ExtractMethodNewSelectorPrecondition methodsFor: 'evaluating - private' stamp: 'RNG 9/8/2019 20:49:51'! - assertNewSelectorIsNotAlreadyDefinedInTheClass - - (classToDefineSelector includesSelector: selectorToValidate) - ifTrue: [ self signalNewSelectorIsAlreadyDefinedInTheClassError ]! ! -!ExtractMethodNewSelectorPrecondition methodsFor: 'evaluating - private' stamp: 'RNG 5/5/2019 12:23:16'! - assertNewSelectorIsNotEmpty - - selectorToValidate ifEmpty: [ self signalNewSelectorCanNotBeEmptyError ]! ! -!ExtractMethodNewSelectorPrecondition methodsFor: 'evaluating' stamp: 'RNG 9/10/2019 18:52:36'! - value - - self - assertNewSelectorIsNotEmpty; - assertNewSelectorDoesNotContainSeparators; - assertNewSelectorBeginsWithAValidCharacter; - assertNewSelectorContainsOnlyValidCharacters; - assertNewSelectorIsNotAlreadyDefinedInTheClass! ! -!ExtractMethodNewSelectorPrecondition methodsFor: 'initialization' stamp: 'RNG 4/18/2019 16:04:44'! - initializeFor: aSelectorToValidate on: aClassToDefineSelector - - selectorToValidate _ aSelectorToValidate. - classToDefineSelector _ aClassToDefineSelector! ! -!ExtractMethodNewSelectorPrecondition class methodsFor: 'error messages' stamp: 'RNG 9/10/2019 18:51:15'! - invalidCharacterInsideNewSelectorErrorMessage - - ^ 'New selector should only contain letters, numbers or _'! ! -!ExtractMethodNewSelectorPrecondition class methodsFor: 'error messages' stamp: 'RNG 6/2/2019 19:18:14'! - invalidStartingCharacterOfNewSelectorErrorMessage - - ^ 'New selector should begin with a lowercase letter or _'! ! -!ExtractMethodNewSelectorPrecondition class methodsFor: 'error messages' stamp: 'RNG 4/18/2019 15:58:58'! - newSelectorAlreadyDefinedOnTheClassErrorMessage - - ^ 'New selector is already defined on this class'! ! -!ExtractMethodNewSelectorPrecondition class methodsFor: 'error messages' stamp: 'RNG 4/18/2019 14:40:21'! - newSelectorCanNotBeEmptyErrorMessage - - ^ 'New selector can not be empty'! ! -!ExtractMethodNewSelectorPrecondition class methodsFor: 'error messages' stamp: 'RNG 4/18/2019 15:05:41'! - newSelectorCanNotContainSeparatorsErrorMessage - - ^ 'New selector can not contain separators'! ! -!ExtractMethodNewSelectorPrecondition class methodsFor: 'instance creation' stamp: 'RNG 4/18/2019 16:01:43'! - for: aSelectorToValidate on: aClass - - ^ self new initializeFor: aSelectorToValidate on: aClass! ! -!ExtractMethodNewSelectorPrecondition class methodsFor: 'evaluating' stamp: 'RNG 4/18/2019 15:59:44'! - valueFor: aSelectorToValidate on: aClass - - ^ (self for: aSelectorToValidate on: aClass) value! ! -!ExtractMethodEditorMenu class methodsFor: 'shortcuts' stamp: 'RNG 9/8/2019 20:56:48'! - smalltalkEditorCmdShortcutsSpec - - ^#(#($K #extractMethod: 'Extracts the selected code into a separate method'))! ! -!ExtractMethodEditorMenu class methodsFor: 'menu items' stamp: 'RNG 9/8/2019 20:56:43'! - smalltalkEditorMenuOptions - - ^`{ - { - #itemGroup -> 35. - #itemOrder -> 20. - #label -> 'Extract Method... (K)'. - #selector -> #extractMethod. - #icon -> #saveAsIcon - } asDictionary - }`! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 9/28/2019 01:21:30'! - containsValidNodes - - ^ self isNotLeftSideOfAssignment - :: and: [ self thereAreNoLocalVariableAssignments ] - :: and: [ self thereAreNoReturnExpressions ] - :: and: [ self isNotATempDeclaration ]! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 9/19/2019 22:16:05'! - intervalCoversCompleteAstNodes - - ^ (self trimmed: (initialNode value first to: finalNode value last)) = intervalToExtract! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 7/9/2019 15:59:28'! - intervalMatchesBeginningOfStatement - - ^ initialNodeAncestors last value first = intervalToExtract first! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 7/9/2019 15:59:45'! - intervalMatchesEndOfStatement - - ^ finalNodeAncestors last value last = intervalToExtract last! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 9/28/2019 00:05:30'! - isDeclaredWithinIntervalToExtract: aVariableNode - - ^ methodNode - allParseNodesWithin: intervalToExtract - satisfy: [ :parseNode | parseNode isBlockNode - and: [ parseNode temporaries includes: aVariableNode ] ]! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 9/8/2019 21:14:54'! - isLeftSideOfAssignment - - ^ initialNodeAncestors size > 1 - :: and: [ initialNodeAncestors second key isAssignmentNode ] - :: and: [ initialNodeAncestors second key variable = initialNode key ]! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 9/28/2019 01:41:03'! - isNotATempDeclaration - - | startOfFirstOccurrence sourceRanges tempKey allTempSourceRanges | - initialNode key isTemp ifFalse: [ ^ true ]. - sourceRanges _ methodNode rawSourceRanges. - tempKey _ sourceRanges keys detect: [ :parseNode | parseNode isTemp and: [ parseNode equivalentTo: initialNode key ] ]. - allTempSourceRanges _ sourceRanges at: tempKey. - startOfFirstOccurrence _ allTempSourceRanges isInterval - ifTrue: [ allTempSourceRanges first ] ifFalse: [ allTempSourceRanges first first ]. - ^ startOfFirstOccurrence ~= intervalToExtract first! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 7/6/2019 20:40:51'! - isNotLeftSideOfAssignment - - ^ (self startAndEndParseNodesAreTheSame and: [ self isLeftSideOfAssignment ]) not! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 7/9/2019 15:59:45'! - parseNodesInCommon - - ^ initialNodeAncestors intersection: finalNodeAncestors! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 7/9/2019 16:03:15'! - startAndEndNodesShareAParentNode - - | parseNodesInCommon | - parseNodesInCommon _ self parseNodesInCommon. - ^ parseNodesInCommon notEmpty and: [ - (self trimmed: parseNodesInCommon first value) = intervalToExtract - ] - - -! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 7/9/2019 15:59:04'! - startAndEndParseNodesAreTheSame - - ^ initialNode key = finalNode key! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 9/28/2019 00:04:36'! - thereAreNoLocalVariableAssignments - - ^ methodNode - allParseNodesWithin: intervalToExtract - satisfy: [ :parseNode | parseNode isAssignmentToTemporary - and: [ self isDeclaredWithinIntervalToExtract: parseNode variable ] ]! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 9/8/2019 19:05:37'! - thereAreNoReturnExpressions - - ^ methodNode - allParseNodesWithin: intervalToExtract - satisfy: [ :parseNode | parseNode isReturn ]! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 7/9/2019 16:03:24'! - trimmed: anInterval - - ^ ExtractMethodIntervalTrimmer trim: anInterval locatedIn: sourceCode! ! -!ExtractMethodExpressionValidation methodsFor: 'validation' stamp: 'RNG 9/8/2019 18:42:38'! - passed - - methodNode _ method methodNode. - sourceCode _ method sourceCode. - initialNodeAncestors _ methodNode parseNodesPathAt: intervalToExtract first ifAbsent: [ ^ false]. - finalNodeAncestors _ methodNode parseNodesPathAt: intervalToExtract last ifAbsent: [ ^ false ]. - initialNode _ initialNodeAncestors first. - finalNode _ finalNodeAncestors first. - - ^ self intervalCoversCompleteAstNodes - :: and: [ self containsValidNodes ] - :: and: [ self startAndEndParseNodesAreTheSame - :: or: [ self startAndEndNodesShareAParentNode ] - :: or: [ self intervalMatchesBeginningOfStatement and: [ self intervalMatchesEndOfStatement ] ] ]! ! -!ExtractMethodExpressionValidation methodsFor: 'initialization' stamp: 'RNG 9/19/2019 22:14:50'! - initializeFor: anIntervalToExtract of: aMethodUnderValidation - - intervalToExtract _ anIntervalToExtract. - method _ aMethodUnderValidation! ! -!ExtractMethodExpressionValidation class methodsFor: 'instance creation' stamp: 'RNG 7/6/2019 20:07:49'! - for: anIntervalToExtract of: aMethod - - ^ self new initializeFor: anIntervalToExtract of: aMethod! ! -!ExtractMethodIntervalTrimmer class methodsFor: 'private' stamp: 'RNG 7/6/2019 19:18:23'! - shouldTrim: sourceCode atIndex: currentIndex - - | currentChar | - currentChar _ sourceCode at: currentIndex ifAbsent: [ ^ false ]. - ^ currentChar isSeparator or: [ currentChar = $. ] -! ! -!ExtractMethodIntervalTrimmer class methodsFor: 'evaluating' stamp: 'RNG 7/6/2019 19:22:50'! - trim: anInterval locatedIn: sourceCode - - | trimmedInterval | - trimmedInterval _ anInterval. - [ self shouldTrim: sourceCode atIndex: trimmedInterval first ] - whileTrue: [ trimmedInterval _ trimmedInterval first + 1 to: trimmedInterval last ]. - [ self shouldTrim: sourceCode atIndex: trimmedInterval last ] - whileTrue: [ trimmedInterval _ trimmedInterval first to: trimmedInterval last - 1 ]. - - [ - | initialChar endingChar | - initialChar _ sourceCode at: trimmedInterval first ifAbsent: [ nil ]. - endingChar _ sourceCode at: trimmedInterval last ifAbsent: [ nil ]. - initialChar = $( and: [ endingChar = $) ] - ] - whileTrue: [ trimmedInterval _ trimmedInterval first + 1 to: trimmedInterval last - 1 ]. - - ^ trimmedInterval! ! - -MethodNode removeSelector: #hasTemporaryOrArgumentNamed:! - -"Postscript: -Reload the shortcuts to get the new Extract Method shortcut" -SmalltalkEditor initializeCmdShortcuts! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3991-ExtractMethod-NahuelGarbezza-2019Dec20-20h38m-RNG.1.cs.st----! - -'From Cuis 5.0 [latest update: #3990] on 23 December 2019 at 11:14:21 am'! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 12/23/2019 10:59:16'! - ifSourceCodeRefactoringCanBeAppliedDo: aBlock - - ^(self hasUnacceptedEdits or: [morph hasEditingConflicts ]) - ifTrue: [ self inform: 'This refactoring can not be applied when there are unsaved changes' ] - ifFalse: aBlock! ! -!CodeNode methodsFor: 'testing' stamp: 'HAW 12/23/2019 09:58:07' prior: 50487863! - hasNodeIn: aCollectionOfNodes named: aName - - ^aCollectionOfNodes anySatisfy: [ :tempNode | tempNode isNamed: aName ]! ! -!BlockNode methodsFor: 'testing' stamp: 'HAW 12/23/2019 09:59:19' prior: 50488592! - hasArgumentOrTemporaryNamed: aName - - ^ self hasLocallyArgumentOrTemporaryNamed: aName! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 12/23/2019 10:40:42' prior: 50488686! - completeSourceRanges - "Returns the 'expanded' version of the source ranges, for instance in message sends it also includes the receiver, and if there are parentheses they are included in the source range as well. Right now used for refactorings." - - ^ encoder completeSourceRangesBasedOn: self sourceText! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 12/23/2019 10:40:45' prior: 50488699! - completeSourceRangesDo: aBinaryBlock - "block has to receive parse node and collection of source ranges" - - ^ self completeSourceRanges keysAndValuesDo: aBinaryBlock! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 12/23/2019 10:41:00' prior: 50488707! - parseNodesPathAt: aPosition ifAbsent: aBlockClosure - - ^ encoder - parseNodesPathAt: aPosition - using: self completeSourceRanges - ifAbsent: aBlockClosure! ! -!MethodNode methodsFor: 'testing' stamp: 'HAW 12/23/2019 11:10:37' prior: 50488673! - allParseNodesWithin: aSourceCodeInterval satisfy: aCondition - - self completeSourceRangesDo: [ :parseNode :sourceRanges | - (aCondition value: parseNode) ifTrue: [ - sourceRanges anySatisfy: [ :sourceRange | aSourceCodeInterval rangeIncludes: sourceRange first ] - :: ifTrue: [ ^ false ]]]. - - ^ true! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 12/23/2019 10:59:16' prior: 50469124! - contextualRenameInClassDefinition - - self ifSourceCodeRefactoringCanBeAppliedDo: [ - self - withClassDefinitionNodeAndClassDo: [ :classDefinitionNode :selectedClass | self contextualRenameInClassDefinitionOf: classDefinitionNode in: selectedClass] - ifErrorsParsing: [ :anError | morph flash ] ]! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 12/23/2019 10:59:16' prior: 50486339! - contextualRenameOf: aMethodNode in: aSelectedClass - - aMethodNode - withParseNodeIncluding: self startIndex - do: [ :nodeUnderCursor | self rename: nodeUnderCursor in: aSelectedClass at: aMethodNode ] - ifAbsent: [ - self startIndex <= aMethodNode selectorLastPosition - ifTrue: [ self ifSourceCodeRefactoringCanBeAppliedDo: [ self renameSelectorFor: aMethodNode selector in: aSelectedClass ]] - ifFalse: [ morph flash ]] - - -! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 12/23/2019 10:59:16' prior: 50486356! - rename: aNodeUnderCursor in: aSelectedClass at: aMethodNode - - aNodeUnderCursor isTempOrArg ifTrue: [ ^self renameTemporary: aNodeUnderCursor at: aMethodNode ]. - - self ifSourceCodeRefactoringCanBeAppliedDo: [ - aNodeUnderCursor isMessageNode ifTrue: [ - ^ self renameSelectorOf: aNodeUnderCursor in: aSelectedClass at: aMethodNode selector ]. - aNodeUnderCursor isInstanceVariableNode ifTrue: [ - ^ self renameInstanceVariableOn: self codeProvider for: aNodeUnderCursor name at: aSelectedClass ]. - aNodeUnderCursor isLiteralVariableNode ifTrue: [ | variableName | - variableName := aNodeUnderCursor key key. - (Smalltalk classNamed: variableName) ifNotNil: [ :classToRename | - ^self renameClassOn: self codeProvider for: classToRename ]. - (Smalltalk bindingOf: variableName) ifNotNil: [ - ^self renameGlobalOn: self codeProvider for: variableName ] ]. - - ^morph flash ]! ! -!SmalltalkEditor methodsFor: 'contextual add/remove parameter' stamp: 'HAW 12/23/2019 10:59:16' prior: 50469498! - contextualChangeSelectorUsing: aChangeSelectorApplier - - self isEditingClassDefinition - ifTrue: [ morph flash ] - ifFalse: [ self ifSourceCodeRefactoringCanBeAppliedDo: [ self contextualChangeSelectorInMethodUsing: aChangeSelectorApplier ]]! ! -!SmalltalkEditor methodsFor: 'extract method' stamp: 'HAW 12/23/2019 10:59:16' prior: 50488715! - extractMethod - - "hack to prevent the extract method to be evaluated on editors w/o methods like the workspace" - self codeProvider respondsTo: #currentCompiledMethod - :: and: [ self codeProvider currentCompiledMethod notNil ] - :: ifFalse: [ ^ nil ]. - - self ifSourceCodeRefactoringCanBeAppliedDo: [ - ExtractMethodApplier createAndValueHandlingExceptions: [ - ExtractMethodApplier for: self selectionInterval of: self codeProvider currentCompiledMethod ] ]! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'HAW 12/23/2019 10:02:36' prior: 50489025! - nodesThatAddVariablesToScope - - ^ (Set with: methodToExtractCodeFrom methodNode) - addAll: self blockNodesEnclosingIntervalToExtract; - yourself! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'HAW 12/23/2019 10:20:54' prior: 50489451! - startAndEndNodesShareAParentNode - - | parseNodesInCommon | - parseNodesInCommon _ self parseNodesInCommon. - - ^ parseNodesInCommon notEmpty and: [ - (self trimmed: parseNodesInCommon first value) = intervalToExtract] - - -! ! - -SmalltalkEditor removeSelector: #ifChangeSelectorCanBeAppliedDo:! - -!methodRemoval: SmalltalkEditor #ifChangeSelectorCanBeAppliedDo: stamp: 'Install-3992-ExtractMethodRefactorings-HernanWilkinson-2019Dec23-09h51m-HAW.1.cs.st 1/11/2020 17:57:46'! -ifChangeSelectorCanBeAppliedDo: aBlock - - ^(self hasUnacceptedEdits or: [morph hasEditingConflicts ]) - ifTrue: [ self inform: 'Rename, Add Parameter and Remove Parameter can not be applied when there are unsaved changes' ] - ifFalse: aBlock! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3992-ExtractMethodRefactorings-HernanWilkinson-2019Dec23-09h51m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3992] on 23 December 2019 at 11:48:22 am'! - -Object subclass: #ExtractMethodExpressionValidation - instanceVariableNames: 'method intervalToExtract methodNode sourceCode initialNode finalNode initialNodeAncestors finalNodeAncestors' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractMethodExpressionValidation category: #'Tools-Refactoring' stamp: 'Install-3993-ExtractMethodRefactorings2-HernanWilkinson-2019Dec23-11h44m-HAW.1.cs.st 1/11/2020 17:57:46'! -Object subclass: #ExtractMethodExpressionValidation - instanceVariableNames: 'method intervalToExtract methodNode sourceCode initialNode finalNode initialNodeAncestors finalNodeAncestors' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Object subclass: #ExtractMethodIntervalTrimmer - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractMethodIntervalTrimmer category: #'Tools-Refactoring' stamp: 'Install-3993-ExtractMethodRefactorings2-HernanWilkinson-2019Dec23-11h44m-HAW.1.cs.st 1/11/2020 17:57:46'! -Object subclass: #ExtractMethodIntervalTrimmer - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Refactoring subclass: #ExtractMethod - instanceVariableNames: 'intervalToExtract categoryOfNewSelector newMessage extractedSourceCode existingMethod' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractMethod category: #'Tools-Refactoring' stamp: 'Install-3993-ExtractMethodRefactorings2-HernanWilkinson-2019Dec23-11h44m-HAW.1.cs.st 1/11/2020 17:57:46'! -Refactoring subclass: #ExtractMethod - instanceVariableNames: 'intervalToExtract categoryOfNewSelector newMessage extractedSourceCode existingMethod' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #ExtractMethodApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newSelector newMessageArguments' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractMethodApplier category: #'Tools-Refactoring' stamp: 'Install-3993-ExtractMethodRefactorings2-HernanWilkinson-2019Dec23-11h44m-HAW.1.cs.st 1/11/2020 17:57:46'! -RefactoringApplier subclass: #ExtractMethodApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newSelector newMessageArguments' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringPrecondition subclass: #ExtractMethodNewSelectorPrecondition - instanceVariableNames: 'selectorToValidate classToDefineSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractMethodNewSelectorPrecondition category: #'Tools-Refactoring' stamp: 'Install-3993-ExtractMethodRefactorings2-HernanWilkinson-2019Dec23-11h44m-HAW.1.cs.st 1/11/2020 17:57:46'! -RefactoringPrecondition subclass: #ExtractMethodNewSelectorPrecondition - instanceVariableNames: 'selectorToValidate classToDefineSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!RefactoringMenues class methodsFor: 'editor menus' stamp: 'HAW 12/23/2019 11:45:31' prior: 50473575! - smalltalkEditorMenuOptions - - ^`{ - { - #itemGroup -> 35. - #itemOrder -> 10. - #label -> 'Rename... (R)'. - #selector -> #contextualRename. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 20. - #label -> 'Extract Method... (K)'. - #selector -> #extractMethod. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 30. - #label -> 'Add Parameter... (A)'. - #selector -> #contextualAddParameter. - #icon -> #listAddIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 40. - #label -> 'Remove Parameter... (S)'. - #selector -> #contextualRemoveParameter. - #icon -> #listRemoveIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 50. - #label -> 'Temporary to Instance Variable (O)'. - #selector -> #temporaryToInstanceVariable. - #icon -> #saveAsIcon - } asDictionary. - }`! ! -!RefactoringMenues class methodsFor: 'shortcuts' stamp: 'HAW 12/23/2019 11:44:05' prior: 50473605! - smalltalkEditorCmdShortcutsSpec - - ^#( - #( $R #contextualRename: 'Renames what is under cursor') - #( $A #contextualAddParameter: 'Adds parameter to message that is under cursor') - #( $S #contextualRemoveParameter: 'Removes parameter to message that is under cursor') - #( $O #temporaryToInstanceVariable: 'Extracts temporary variable to instance variable') - #( $K #extractMethod: 'Extracts the selected code into a separate method') - ) -! ! - -Smalltalk removeClassNamed: #ExtractMethodEditorMenu! - -!classRemoval: #ExtractMethodEditorMenu stamp: 'Install-3993-ExtractMethodRefactorings2-HernanWilkinson-2019Dec23-11h44m-HAW.1.cs.st 1/11/2020 17:57:46'! -Object subclass: #ExtractMethodEditorMenu - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Refactorings-ExtractMethod'! - -"Postscript:" -SystemOrganization removeSystemCategory: 'Refactorings-ExtractMethod'. -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3993-ExtractMethodRefactorings2-HernanWilkinson-2019Dec23-11h44m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3993] on 26 December 2019 at 8:24:25 am'! -!Process methodsFor: 'debugging' stamp: 'HAW 12/26/2019 08:17:53' prior: 16894514! - debug: context title: title full: bool - "Open debugger on self with context shown on top" - - | topContext | - - topContext _ self isRunning ifTrue: [thisContext] ifFalse: [self suspendedContext]. - (topContext notNil and: [ topContext hasContext: context ]) ifFalse: [^ self error: 'context not in process']. - Debugger openOn: self context: context label: title fullView: bool. -! ! -!TestFailure methodsFor: 'Camp Smalltalk' stamp: 'HAW 12/26/2019 08:21:50' prior: 16927789! - defaultAction - - self noHandler! ! - -SyntaxErrorNotification removeSelector: #defaultAction! - -!methodRemoval: SyntaxErrorNotification #defaultAction stamp: 'Install-3994-ThroughHangFixWhenTestFail-HernanWilkinson-2019Dec26-08h20m-HAW.1.cs.st 1/11/2020 17:57:46'! -defaultAction - - "Handle a syntax error" - | | -true ifTrue: [ ^super defaultAction ]. -" notifier := SyntaxError new - setClass: self errorClass - code: self errorCode - debugger: (Debugger context: self signalerContext) - doitFlag: self doitFlag. - notifier category: self category. - SyntaxError open: notifier. - "! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3994-ThroughHangFixWhenTestFail-HernanWilkinson-2019Dec26-08h20m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3994] on 26 December 2019 at 10:03:58 am'! -!UISupervisor class methodsFor: 'gui process' stamp: 'HAW 12/26/2019 10:01:29' prior: 50378940! - spawnNewMorphicProcessFor: guiRootObject - - | previousUIProcess | - - previousUIProcess := UIProcess. - UIProcess _ guiRootObject runProcess. - previousUIProcess ifNotNil: [ previousUIProcess animatedUI: nil ]. - UIProcess resume! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3995-UIFreezeBugFixWhenSimulatingExecution-HernanWilkinson-2019Dec26-10h01m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3994] on 26 December 2019 at 11:10:16 am'! -!Process methodsFor: 'changing suspended state' stamp: 'HAW 12/26/2019 10:59:25'! - canSearchForSignalerContextOf: anException - - ^ (anException class includesBehavior: Exception) - and: [anException canSearchForSignalerContext]! ! -!Process methodsFor: 'changing suspended state' stamp: 'HAW 12/26/2019 10:55:07'! - completeStepUpTo: aContext - - [aContext == suspendedContext] - whileFalse: [self completeStep: suspendedContext].! ! -!Process methodsFor: 'changing suspended state' stamp: 'HAW 12/26/2019 10:59:09'! - ifSuspendedContextIsUnhandledErrorDo: aBlock - - | unhandledError | - - self isSuspendedContextSignalUnhandledError ifTrue: [ - unhandledError := suspendedContext tempAt: 1. - (self canSearchForSignalerContextOf: unhandledError) ifTrue: [ - aBlock value: unhandledError ]].! ! -!Process methodsFor: 'changing suspended state' stamp: 'HAW 12/26/2019 10:56:50'! - isSuspendedContextSignalUnhandledError - - ^ suspendedContext selector == #signalForException: - and: [suspendedContext receiver isBehavior - and: [suspendedContext receiver includesBehavior: UnhandledError]]! ! -!Notification methodsFor: 'debugger updating' stamp: 'HAW 12/26/2019 11:01:45'! - isToUpdateDebuggerOn: aContext - - ^tag isArray - and: [tag size = 2 - and: [(tag first == aContext or: [tag first hasSender: aContext])]]! ! -!Notification methodsFor: 'debugger updating' stamp: 'HAW 12/26/2019 11:01:48'! - withNewDebuggerLabelOn: aContext do: labelBlock ifNone: noneBlok - - ^(self isToUpdateDebuggerOn: aContext) - ifTrue: [ labelBlock value: tag second description ] - ifFalse: noneBlok ! ! -!Notification class methodsFor: 'debugger updating - signaling' stamp: 'HAW 12/26/2019 11:02:18'! - signalToUpdateDebuggerOn: unhandledErrorSignalerContext dueTo: anError - - self new - tag: {unhandledErrorSignalerContext. anError}; - signal.! ! -!Object methodsFor: 'testing' stamp: 'HAW 12/26/2019 10:04:01'! - isContext - - ^false ! ! -!Debugger methodsFor: 'context stack menu' stamp: 'HAW 12/26/2019 10:19:57' prior: 50367114! - handleLabelUpdatesIn: aBlock whenExecuting: aContext - "Send the selected message in the accessed method, and regain control - after the invoked method returns." - - ^aBlock - on: Notification - do: [:aNotification| - aNotification - withNewDebuggerLabelOn: aContext - do: [ :aNewLabel | - self labelString: aNewLabel. - aNotification resume] - ifNone: [aNotification pass]]! ! -!Debugger class methodsFor: 'class initialization' stamp: 'HAW 12/26/2019 10:05:14' prior: 50373339! - openContext: aContext label: aString contents: contentsStringOrNil - "Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger." - - "Simulation guard" - - (self errorRecursion not and: [Preferences logDebuggerStackToFile]) ifTrue: - [Smalltalk logError: aString inContext: aContext to: 'CuisDebug']. - ErrorRecursion ifTrue: [ - ErrorRecursion _ false. - contentsStringOrNil - ifNil: [ - self primitiveError: 'Can not open debugger due to recursion error.', - String newLineString, aString] - ifNotNil: [ - self primitiveError: 'Can not open debugger due to recursion error.', - String newLineString, aString, String newLineString, contentsStringOrNil ]]. - ErrorRecursion _ true. - [self informExistingDebugger: aContext label: aString. - (Debugger context: aContext) - openNotifierContents: contentsStringOrNil - label: aString.] ensure: [ ErrorRecursion _ false ]. - Processor activeProcess suspend. -! ! -!Process methodsFor: 'changing suspended state' stamp: 'HAW 12/26/2019 11:09:25' prior: 50367203! - stepToHome: aContext - "Resume self until the home of top context is aContext. Top context may be a block context. - Catch any UnhandledErrors that are created while stepping, answering the relevant signalerContext - if so. Note that this will cause weird effects if using through to step through UnhandledError - code, but as the doctor ordered, don't do that; use over or into instead." - - | home | - - home := aContext home. - [suspendedContext := suspendedContext step. - home == suspendedContext home or: [home isDead]] whileFalse: - [self ifSuspendedContextIsUnhandledErrorDo: [ :anError | - anError signalerContext ifNotNil: [:unhandledErrorSignalerContext| - self completeStepUpTo: unhandledErrorSignalerContext. - - "Give a debugger a chance to update its title to reflect the new exception" - Notification signalToUpdateDebuggerOn: unhandledErrorSignalerContext dueTo: anError. - ^unhandledErrorSignalerContext]]]. - - ^suspendedContext! ! -!PasteUpMorph methodsFor: 'interaction loop' stamp: 'HAW 12/26/2019 10:05:45' prior: 50378685! - runProcess - - | process | - - process _ [ self mainLoop ] newProcess. - process - priority: Processor userSchedulingPriority; - name: 'Morphic UI'; - animatedUI: self. - - ^ process! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3996-DebuggerRefactorings-HernanWilkinson-2019Dec26-10h03m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3996] on 26 December 2019 at 11:35:35 am'! -!PreDebugWindow class methodsFor: 'instance creation' stamp: 'HAW 12/26/2019 11:18:10'! - forceOpen: model label: aString message: messageString - - | window | - - window _ self new. - window - model: model; - buildMorphicWindowMessage: messageString print. - aString ifNotNil: [ window setLabel: aString ]. - - window openInWorld ! ! -!Debugger methodsFor: 'initialization' stamp: 'HAW 12/26/2019 11:18:22' prior: 50470724! - openNotifierContents: msgString label: label - "Create and schedule a notifier view with the given label and message. A notifier view shows just the message or the first several lines of the stack, with a menu that allows the user to open a full debugger if so desired." - "NOTE: When this method returns, a new process has been scheduled to run the windows, and thus this notifier, but the previous active porcess has not been suspended. The sender will do this." - | msg | - Sensor flushKeyboard. - savedCursor _ Cursor currentCursor. - Cursor defaultCursor activateCursor. - msg _ (label beginsWith: 'Space is low') - ifTrue: [ self lowSpaceChoices , (msgString ifNil: [ '' ]) ] - ifFalse: [ msgString ]. - interruptedProcessUI _ UISupervisor newProcessIfUI: interruptedProcess. - UISupervisor whenUIinSafeState: [ - PreDebugWindow - forceOpen: self - label: label - message: msg ].! ! -!PreDebugWindow class methodsFor: 'instance creation' stamp: 'HAW 12/26/2019 11:17:49' prior: 50417422! - open: model label: aString message: messageString - - (Preferences usePreDebugWindow or: [messageString notNil]) - ifTrue: [self forceOpen: model label: aString message: messageString] - ifFalse: [model openFullMorphicLabel: aString ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3997-UsePreDebugWindowForInternalErrors-HernanWilkinson-2019Dec26-11h11m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3997] on 26 December 2019 at 10:03:20 pm'! - -Refactoring subclass: #MoveInstanceVariable - instanceVariableNames: 'classToRefactor instanceVariableToMove' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #MoveInstanceVariable category: #'Tools-Refactoring' stamp: 'Install-3998-PushUpDownInstanceVariable-HernanWilkinson-2019Dec26-19h05m-HAW.1.cs.st 1/11/2020 17:57:46'! -Refactoring subclass: #MoveInstanceVariable - instanceVariableNames: 'classToRefactor instanceVariableToMove' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MoveInstanceVariable subclass: #PushDownInstanceVariable - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #PushDownInstanceVariable category: #'Tools-Refactoring' stamp: 'Install-3998-PushUpDownInstanceVariable-HernanWilkinson-2019Dec26-19h05m-HAW.1.cs.st 1/11/2020 17:57:46'! -MoveInstanceVariable subclass: #PushDownInstanceVariable - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MoveInstanceVariable subclass: #PushUpInstanceVariable - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #PushUpInstanceVariable category: #'Tools-Refactoring' stamp: 'Install-3998-PushUpDownInstanceVariable-HernanWilkinson-2019Dec26-19h05m-HAW.1.cs.st 1/11/2020 17:57:46'! -MoveInstanceVariable subclass: #PushUpInstanceVariable - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #MoveInstanceVariableApplier - instanceVariableNames: 'browser classToRefactor instanceVariableName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #MoveInstanceVariableApplier category: #'Tools-Refactoring' stamp: 'Install-3998-PushUpDownInstanceVariable-HernanWilkinson-2019Dec26-19h05m-HAW.1.cs.st 1/11/2020 17:57:46'! -RefactoringApplier subclass: #MoveInstanceVariableApplier - instanceVariableNames: 'browser classToRefactor instanceVariableName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MoveInstanceVariableApplier subclass: #PushDownInstanceVariableApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #PushDownInstanceVariableApplier category: #'Tools-Refactoring' stamp: 'Install-3998-PushUpDownInstanceVariable-HernanWilkinson-2019Dec26-19h05m-HAW.1.cs.st 1/11/2020 17:57:46'! -MoveInstanceVariableApplier subclass: #PushDownInstanceVariableApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MoveInstanceVariableApplier subclass: #PushUpInstanceVariableApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #PushUpInstanceVariableApplier category: #'Tools-Refactoring' stamp: 'Install-3998-PushUpDownInstanceVariable-HernanWilkinson-2019Dec26-19h05m-HAW.1.cs.st 1/11/2020 17:57:46'! -MoveInstanceVariableApplier subclass: #PushUpInstanceVariableApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!CodeProvider methodsFor: 'contents' stamp: 'MSC 12/19/2019 07:20:34'! - instanceVariablePushedUp - - self acceptedContentsChanged -! ! -!SmalltalkEditor methodsFor: 'contextual push up/down inst. var' stamp: 'HAW 12/26/2019 19:37:18'! - apply: aBlock inClassDefinitionOf: aClassDefinitionNode in: aSelectedClass - - | analyzer cursorPosition | - - analyzer := ClassDefinitionNodeAnalyzer for: aClassDefinitionNode. - cursorPosition := self startIndex. - - (analyzer isAtInstanceVariables: cursorPosition) - ifTrue: [ aBlock value: aSelectedClass ] - ifFalse: [ morph flash ] - -! ! -!SmalltalkEditor methodsFor: 'contextual push up/down inst. var' stamp: 'HAW 12/26/2019 19:37:20'! - contextualPushDownInClassDefinition - - self inClassDefinitionContextuallyApply: [ :aSelectedClass | - (PushDownInstanceVariableApplier - on: self codeProvider - for: self wordUnderCursor - at: aSelectedClass ) value ]! ! -!SmalltalkEditor methodsFor: 'contextual push up/down inst. var' stamp: 'HAW 12/26/2019 19:37:25'! - contextualPushUpInClassDefinition - - self inClassDefinitionContextuallyApply: [ :aSelectedClass | - (PushUpInstanceVariableApplier - on: self codeProvider - for: self wordUnderCursor - at: aSelectedClass) value ]! ! -!SmalltalkEditor methodsFor: 'contextual push up/down inst. var' stamp: 'HAW 12/26/2019 19:37:28'! - ifEditingClassDefinitionDoOrWarn: aBlock - - self isEditingClassDefinition - ifTrue: aBlock - ifFalse: [ self informRefactoringCanOnlyBeAppliedInClassDefinition ]! ! -!SmalltalkEditor methodsFor: 'contextual push up/down inst. var' stamp: 'HAW 12/26/2019 19:37:32'! - inClassDefinitionContextuallyApply: aBlock - - self ifEditingClassDefinitionDoOrWarn: [ - self ifSourceCodeRefactoringCanBeAppliedDo: [ - self - withClassDefinitionNodeAndClassDo: [ :classDefinitionNode :selectedClass | - self apply: aBlock inClassDefinitionOf: classDefinitionNode in: selectedClass ] - ifErrorsParsing: [ :anError | morph flash ]]]! ! -!SmalltalkEditor methodsFor: 'contextual push up/down inst. var' stamp: 'HAW 12/26/2019 19:37:35'! - informRefactoringCanOnlyBeAppliedInClassDefinition - - self inform: 'This refactoring can only be applied from the class definition'! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'MSC 12/21/2019 10:54:17'! - pushDownInstanceVariable - - model selectedClassOrMetaClass ifNotNil: [ :aClass | - (PushDownInstanceVariableApplier on: model at: aClass ) value].! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'MSC 12/19/2019 07:09:01'! - pushUpInstanceVariable - - model selectedClassOrMetaClass ifNotNil: [ :aClass | - (PushUpInstanceVariableApplier on: model at: aClass ) value].! ! -!ChangeListElement methodsFor: 'fileIn/fileOut' stamp: 'HAW 12/26/2019 19:06:18'! - fileIn - - self subclassResponsibility ! ! -!ChangeListElement methodsFor: 'fileIn/fileOut' stamp: 'HAW 12/26/2019 19:07:08'! - fileOutOn: aFileStream - - self subclassResponsibility ! ! -!FeatureChangeRecord methodsFor: 'fileIn/fileOut' stamp: 'HAW 12/26/2019 19:05:33'! - fileIn - - "It does nothing - Hernan"! ! -!FeatureChangeRecord methodsFor: 'fileIn/fileOut' stamp: 'HAW 12/26/2019 19:07:28'! - fileOutOn: aFileStream - - "Nothing to file out - Hernan"! ! -!MoveInstanceVariable methodsFor: 'initialization' stamp: 'HAW 12/26/2019 20:23:54'! - initializeNamed: anInstanceVariableToMove from: aClassToRefactor - - instanceVariableToMove := anInstanceVariableToMove. - classToRefactor := aClassToRefactor.! ! -!MoveInstanceVariable class methodsFor: 'instance creation' stamp: 'HAW 12/26/2019 20:36:55'! - named: anInstanceVariable from: aClassToRefactor - - self assertCanMove: anInstanceVariable from: aClassToRefactor. - - ^self new initializeNamed: anInstanceVariable from: aClassToRefactor! ! -!MoveInstanceVariable class methodsFor: 'pre-conditions' stamp: 'HAW 12/26/2019 20:36:58'! - assert: aClassToRefactor hasInstanceVariable: anInstanceVariable - - (aClassToRefactor definesInstanceVariableNamed: anInstanceVariable) ifFalse: [self refactoringError: self instanceVariableDoesNotExistOnClassToRefactor]. - - ! ! -!MoveInstanceVariable class methodsFor: 'pre-conditions' stamp: 'HAW 12/26/2019 20:37:02'! - assertCanMove: anInstanceVariable from: aClassToRefactor - - self subclassResponsibility ! ! -!MoveInstanceVariable class methodsFor: 'error descriptions' stamp: 'HAW 12/26/2019 20:37:05'! - instanceVariableDoesNotExistOnClassToRefactor - - ^ 'Instance variable does not exist on class to refactor'! ! -!PushDownInstanceVariable methodsFor: 'applying' stamp: 'HAW 12/26/2019 20:23:14'! - apply - - classToRefactor removeInstVarName: instanceVariableToMove. - self pushDownInstanceVariableToAllSubclasses! ! -!PushDownInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 12/26/2019 20:23:14'! - pushDownInstanceVariableToAllSubclasses - - classToRefactor subclassesDo: [ :subClass | - subClass addInstVarName: instanceVariableToMove ]! ! -!PushDownInstanceVariable class methodsFor: 'pre-conditions' stamp: 'HAW 12/26/2019 20:37:10'! - assert: aClassToRefactor isNotAccessingInstanceVariable: anInstanceVariable - - | selectorsReferencingInstVar | - - selectorsReferencingInstVar := aClassToRefactor whichSelectorsAccess: anInstanceVariable. - selectorsReferencingInstVar ifNotEmpty: [ - self - canNotRefactorDueToReferencesError: ( - self errorMessageForInstanceVariable: anInstanceVariable isAccessedInMethodsOf: aClassToRefactor) - references: (selectorsReferencingInstVar collect: [ :selector | - MethodReference class: aClassToRefactor selector: selector ]) asArray - to: anInstanceVariable ]! ! -!PushDownInstanceVariable class methodsFor: 'pre-conditions' stamp: 'HAW 12/26/2019 20:37:13'! - assertCanMove: anInstanceVariable from: aClassToRefactor - - self assert: aClassToRefactor hasInstanceVariable: anInstanceVariable. - self assert: aClassToRefactor isNotAccessingInstanceVariable: anInstanceVariable. - - ! ! -!PushDownInstanceVariable class methodsFor: 'error descriptions' stamp: 'HAW 12/26/2019 20:37:16'! - errorMessageForInstanceVariable: anInstanceVariable isAccessedInMethodsOf: aClassToRefactor - - ^ 'Cannot push down ', anInstanceVariable, ' because it is accessed in methods of ', aClassToRefactor name! ! -!PushUpInstanceVariable methodsFor: 'applying' stamp: 'HAW 12/26/2019 20:36:17'! - apply - - self removeSubclassesInstanceVariable. - classToRefactor superclass addInstVarName: instanceVariableToMove.! ! -!PushUpInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 12/26/2019 20:36:02'! - removeSubclassesInstanceVariable - - classToRefactor superclass subclassesDo: [ :subclass | - (subclass definesInstanceVariableNamed: instanceVariableToMove) ifTrue: [ subclass removeInstVarName: instanceVariableToMove]. - ].! ! -!PushUpInstanceVariable class methodsFor: 'pre-conditions' stamp: 'HAW 12/26/2019 20:37:25'! - assertCanMove: anInstanceVariable from: aClassToRefactor - - self assert: aClassToRefactor hasInstanceVariable: anInstanceVariable. - self assertNoOtherMethodIn: aClassToRefactor superclass definesTemporaryNamed: anInstanceVariable.! ! -!PushUpInstanceVariable class methodsFor: 'pre-conditions' stamp: 'HAW 12/26/2019 21:59:38'! - assertNoOtherMethodIn: aSuperclass definesTemporaryNamed: anInstanceVariableName - - | methodsDefiningTemporaryInSuperclass | - - methodsDefiningTemporaryInSuperclass := OrderedCollection new. - methodsDefiningTemporaryInSuperclass addAll: ( - aSuperclass methodsWithArgumentOrTemporaryNamed: anInstanceVariableName). - - methodsDefiningTemporaryInSuperclass ifNotEmpty: [ - self - canNotRefactorDueToReferencesError: ( - self errorMessageForInstanceVariable: anInstanceVariableName isDefinedInMethodsOf: aSuperclass) - references: ( - methodsDefiningTemporaryInSuperclass collect: [ :aMethod | MethodReference method: aMethod ]) - to: anInstanceVariableName ]! ! -!PushUpInstanceVariable class methodsFor: 'error descriptions' stamp: 'HAW 12/26/2019 20:35:21'! - errorMessageForInstanceVariable: anInstanceVariableName isDefinedInMethodsOf: aSuperclass - - ^ anInstanceVariableName, ' exist as temporary in methods of ', aSuperclass name! ! -!MoveInstanceVariableApplier methodsFor: 'initialization' stamp: 'HAW 12/26/2019 20:44:46'! - initializeOn: aBrowserWindow for: anInstanceVariableName at: aClassToRefactor - - browser := aBrowserWindow. - classToRefactor := aClassToRefactor. - instanceVariableName := anInstanceVariableName! ! -!MoveInstanceVariableApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 12/26/2019 20:45:00'! - chooseInstanceVariable - - instanceVariableName ifNotNil: [ ^self ]. - - classToRefactor - chooseDefiningInstanceVariableAlphabeticallyWith: self selectVariableLabel - thenDo: [ :anInstanceVariable | ^instanceVariableName := anInstanceVariable ]. - - self endRequest ! ! -!MoveInstanceVariableApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 12/26/2019 20:45:09'! - requestRefactoringParameters - - self chooseInstanceVariable! ! -!MoveInstanceVariableApplier methodsFor: 'refactoring - changes' stamp: 'HAW 12/26/2019 20:45:33'! - informChangesToBrowser - - browser acceptedContentsChanged.! ! -!MoveInstanceVariableApplier methodsFor: 'refactoring - changes' stamp: 'HAW 12/26/2019 20:45:38'! -showChanges - - self informChangesToBrowser! ! -!MoveInstanceVariableApplier class methodsFor: 'instance creation' stamp: 'HAW 12/26/2019 20:46:23'! - on: aBrowser at: aClassToRefactor - - ^self on: aBrowser for: nil at: aClassToRefactor! ! -!MoveInstanceVariableApplier class methodsFor: 'instance creation' stamp: 'HAW 12/26/2019 20:46:28'! - on: aBrowser for: anInstanceVariableName at: aClassToRefactor - - ^self new initializeOn: aBrowser for: anInstanceVariableName at: aClassToRefactor! ! -!PushDownInstanceVariableApplier methodsFor: 'refactoring - parameters request' stamp: 'MSC 12/21/2019 11:03:46'! - selectVariableLabel - - ^'Select instance variable to push down'! ! -!PushDownInstanceVariableApplier methodsFor: 'refactoring - creation' stamp: 'HAW 12/26/2019 20:17:41'! - createRefactoring - - ^PushDownInstanceVariable named: instanceVariableName from: classToRefactor. - ! ! -!PushUpInstanceVariableApplier methodsFor: 'refactoring - parameters request' stamp: 'MSC 12/19/2019 07:11:47'! - selectVariableLabel - - ^'Select instance variable to push up'! ! -!PushUpInstanceVariableApplier methodsFor: 'refactoring - creation' stamp: 'HAW 12/26/2019 20:41:01'! - createRefactoring - - ^PushUpInstanceVariable named: instanceVariableName from: classToRefactor. - ! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 12/26/2019 19:16:11' prior: 50489644! - contextualRenameInClassDefinition - - self ifSourceCodeRefactoringCanBeAppliedDo: [ - self - withClassDefinitionNodeAndClassDo: [ :classDefinitionNode :selectedClass | - self contextualRenameInClassDefinitionOf: classDefinitionNode in: selectedClass] - ifErrorsParsing: [ :anError | morph flash ] ]! ! -!ChangeRecord methodsFor: 'fileIn/fileOut' stamp: 'HAW 12/26/2019 19:06:40' prior: 50370024! - fileIn - "File the receiver in. If I represent a method or a class-comment, file the method in and make a note of it in the recent-submissions list; if I represent a do-it, then, well, do it." - | s | - type == #method ifTrue: [ - self changeClass ifNotNil: [ :methodClass | - methodClass - compile: self text - classified: category - withStamp: stamp - notifying: nil ]]. - self isDoIt ifTrue: [ - ((s _ self string) beginsWith: '----') ifFalse: [ Compiler evaluate: s ]]. - type == #classDefinition ifTrue: [ Compiler evaluate: self string ]. - type == #classComment ifTrue: [ - (Smalltalk at: class asSymbol) - comment: self text - stamp: stamp ]! ! -!ChangeRecord methodsFor: 'fileIn/fileOut' stamp: 'HAW 12/26/2019 19:06:52' prior: 16797355! - fileOutOn: aFileStream - "File the receiver out on the given file stream" - - | aString | - type == #method - ifTrue: [ - aFileStream newLine; nextPut: $!!. - aString _ class asString - , (meta ifTrue: [' class methodsFor: '] - ifFalse: [' methodsFor: ']) - , category asString printString. - stamp ifNotNil: [ - aString _ aString, ' stamp: ''', stamp, '''']. - aFileStream nextChunkPut: aString. - aFileStream newLine ]. - - type == #preamble ifTrue: [ aFileStream nextPut: $!! ]. - - type == #classComment - ifTrue: [ - aFileStream nextPut: $!!. - aFileStream nextChunkPut: class asString, ' commentStamp: ', stamp storeString. - aFileStream newLine ]. - - type == #classDefinition ifTrue: [ - aFileStream nextPut: $!!. - aFileStream nextChunkPut: - 'classDefinition: ', - (self isMetaClassChange ifTrue: [self changeClassName, ' class'] ifFalse: [self changeClassName]) printString, - ' category: ', self category printString. - aFileStream newLine ]. - - aFileStream nextChunkPut: self string. - - type == #method ifTrue: [ aFileStream nextChunkPut: ' '; newLine ]. - type == #classComment ifTrue: [ aFileStream newLine ]. - aFileStream newLine! ! -!RefactoringApplier methodsFor: 'exception handling' stamp: 'HAW 12/26/2019 22:03:03' prior: 50452825! - browseReferencesOn: aCanNotRefactorDueToReferencesError - - Smalltalk - browseMessageList: aCanNotRefactorDueToReferencesError references - name: (self referencesBrowserTitleOn: aCanNotRefactorDueToReferencesError) - autoSelect: aCanNotRefactorDueToReferencesError referencee asString -! ! -!RefactoringMenues class methodsFor: 'editor menus' stamp: 'HAW 12/26/2019 20:51:34' prior: 50489876! - smalltalkEditorMenuOptions - - ^`{ - { - #itemGroup -> 35. - #itemOrder -> 10. - #label -> 'Rename... (R)'. - #selector -> #contextualRename. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 20. - #label -> 'Extract Method... (K)'. - #selector -> #extractMethod. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 30. - #label -> 'Add Parameter... (A)'. - #selector -> #contextualAddParameter. - #icon -> #listAddIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 40. - #label -> 'Remove Parameter... (S)'. - #selector -> #contextualRemoveParameter. - #icon -> #listRemoveIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 50. - #label -> 'Temporary to Instance Variable (O)'. - #selector -> #temporaryToInstanceVariable. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 60. - #label -> 'Push Up Instance Variable'. - #selector -> #contextualPushUpInClassDefinition. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 70. - #label -> 'Push Down Instance Variable'. - #selector -> #contextualPushDownInClassDefinition. - #icon -> #goBottomIcon - } asDictionary. - }`! ! -!RefactoringMenues class methodsFor: 'browser menues' stamp: 'MSC 12/21/2019 10:53:57' prior: 50450837! - classRefactoringMenuOptions - - ^ `{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'rename class... (R)'. - #object -> #model. - #selector -> #renameClass. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'insert superclass...'. - #object -> #model. - #selector -> #insertSuperclass. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'safely remove class (x)'. - #object -> #model. - #selector -> #safelyRemoveClass. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'add inst var...'. - #selector -> #addInstVar. - #icon -> #listAddIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'rename inst var...'. - #selector -> #renameInstVar. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'remove inst var...'. - #selector -> #removeInstVar. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 40. - #label -> 'remove all unreferenced inst var...'. - #selector -> #removeAllUnreferencedInstVar. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 50. - #label -> 'push up inst var...'. - #selector -> #pushUpInstanceVariable. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 60. - #label -> 'push down inst var...'. - #selector -> #pushDownInstanceVariable. - #icon -> #goBottomIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'rename global...'. - #object -> #model. - #selector -> #renameGlobal. - #icon -> #saveAsIcon - } asDictionary. - }`. - ! ! - -PushUpInstanceVariableApplier class removeSelector: #on:at:! - -PushUpInstanceVariableApplier class removeSelector: #on:for:at:! - -PushUpInstanceVariableApplier removeSelector: #showChanges! - -PushUpInstanceVariableApplier removeSelector: #chooseInstanceVariable! - -PushUpInstanceVariableApplier removeSelector: #initializeOn:for:at:! - -PushUpInstanceVariableApplier removeSelector: #requestRefactoringParameters! - -PushUpInstanceVariableApplier removeSelector: #informChangesToBrowser! - -PushDownInstanceVariableApplier class removeSelector: #on:at:! - -PushDownInstanceVariableApplier class removeSelector: #on:for:at:! - -PushDownInstanceVariableApplier removeSelector: #showChanges! - -PushDownInstanceVariableApplier removeSelector: #chooseInstanceVariable! - -PushDownInstanceVariableApplier removeSelector: #initializeOn:for:at:! - -PushDownInstanceVariableApplier removeSelector: #requestRefactoringParameters! - -PushDownInstanceVariableApplier removeSelector: #informChangesToBrowser! - -PushUpInstanceVariable class removeSelector: #assert:pushUp:! - -PushUpInstanceVariable class removeSelector: #errorMessageForInstanceVariableNotExistOnClassToRefactor! - -PushUpInstanceVariable class removeSelector: #assert:hasInstanceVariable:! - -PushUpInstanceVariable class removeSelector: #named:from:! - -PushUpInstanceVariable class removeSelector: #instanceVariableDoesNotExistOnClassToRefactor! - -PushUpInstanceVariable class removeSelector: #errorMessageForInstanceVariableAlreadyExistsOnSuperClassToRefactorAsTemporary:! - -PushUpInstanceVariable class removeSelector: #errorMessageForInstanceVariable:! - -PushUpInstanceVariable class removeSelector: #named:to:! - -PushUpInstanceVariable class removeSelector: #errorMessageForInstanceVariableAlreadyExistsOnSuperClassToRefactorAsTemporary! - -PushUpInstanceVariable removeSelector: #initializeNamed:from:! - -PushUpInstanceVariable removeSelector: #removeSubclassesInstanceVariables:from:! - -PushUpInstanceVariable removeSelector: #initializeNamed:to:! - -PushDownInstanceVariable class removeSelector: #errorMessageForInstanceVariableNotExistOnClassToRefactor! - -PushDownInstanceVariable class removeSelector: #assert:hasInstanceVariable:! - -PushDownInstanceVariable class removeSelector: #assert:IsNotAccessingInstanceVariable:! - -PushDownInstanceVariable class removeSelector: #assert:pushDown:! - -PushDownInstanceVariable class removeSelector: #errorMessageForInstanceVariableIsAccessesOnClassToRefactor! - -PushDownInstanceVariable class removeSelector: #named:from:! - -PushDownInstanceVariable class removeSelector: #instanceVariableDoesNotExistOnClassToRefactor! - -PushDownInstanceVariable class removeSelector: #errorMessageForInstanceVariable:! - -PushDownInstanceVariable class removeSelector: #errorMessageForInstanceVariableIsAccessesOnClassToRefactor:! - -PushDownInstanceVariable class removeSelector: #named:to:! - -PushDownInstanceVariable class removeSelector: #assertCanPushDown:from:! - -PushDownInstanceVariable removeSelector: #initializeNamed:from:! - -PushDownInstanceVariable removeSelector: #pushDownInstanceVariableToAllSubclasses:to:! - -PushDownInstanceVariable removeSelector: #initializeNamed:to:! - -SmalltalkEditor removeSelector: #contextualPushDown! - -SmalltalkEditor removeSelector: #pushUpInstanceVariableOn:for:at:! - -SmalltalkEditor removeSelector: #contextualPushUp! - -SmalltalkEditor removeSelector: #contextualPushUpInClassDefinitionOf:in:! - -SmalltalkEditor removeSelector: #pushDownInstanceVariableOn:for:at:! - -SmalltalkEditor removeSelector: #contextualPushDownInClassDefinitionOf:in:! - -CodeProvider removeSelector: #instanceVariablePushedDown! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3998-PushUpDownInstanceVariable-HernanWilkinson-2019Dec26-19h05m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3997] on 30 December 2019 at 6:23:44 pm'! -!ChangeSelector class methodsFor: 'pre-conditions' stamp: 'HAW 12/30/2019 18:11:22'! - assertIsNotEmpty: aCollection signalMessageText: errorMessageText - - aCollection isEmpty ifTrue: [ self refactoringError: errorMessageText ].! ! -!ChangeSelectorWizardStepWindow methodsFor: 'compile methods' stamp: 'HAW 12/30/2019 17:03:12' prior: 50438253! -compiledMethodsFrom: methodReferences - - ^ methodReferences - select: [ :aMethodReference | aMethodReference isValid ] - thenCollect: [:aMethodReference | aMethodReference compiledMethod ]! ! -!ChangeSelectorKeepingParameters class methodsFor: 'instance creation' stamp: 'HAW 12/30/2019 17:55:51' prior: 50447656! - from: anOldSelector to: aNewSelector implementors: aCollectionOfImplementors senders: aCollectionOfSenders - - self assertIsValidToRenameFrom: anOldSelector to: aNewSelector. - self assertAllImplementors: aCollectionOfImplementors haveSame: anOldSelector. - self assertNoImplementorClassIn: aCollectionOfImplementors implements: aNewSelector. - self assertAllSenders: aCollectionOfSenders send: anOldSelector. - - self warnIfImplementionsOf: aNewSelector overridesImplementationInSuperclassesOf: aCollectionOfImplementors. - - ^self new initializeFrom: anOldSelector to: aNewSelector implementors: aCollectionOfImplementors senders: aCollectionOfSenders - ! ! -!RefactoringApplier class methodsFor: 'value handling exceptions' stamp: 'HAW 12/30/2019 16:46:47' prior: 50441464! - createAndValueHandlingExceptions: creationBlock - - | applier | - - applier := creationBlock - on: Refactoring refactoringErrorClass - do: [ :refactoringError | ^self inform: refactoringError messageText ]. - - applier value ! ! - -ChangeSelectorKeepingParameters class removeSelector: #implementorsCanNotBeEmptyErrorMessage! - -!methodRemoval: ChangeSelectorKeepingParameters class #implementorsCanNotBeEmptyErrorMessage stamp: 'Install-3999-RenameSelectorWithEmptyImplementors-HernanWilkinson-2019Dec30-12h36m-HAW.1.cs.st 1/11/2020 17:57:46'! -implementorsCanNotBeEmptyErrorMessage - - ^'There are no methods to rename'! - -ChangeSelectorKeepingParameters class removeSelector: #assertCanChangeSelectorFrom:to:implementors:senders:! - -ChangeSelectorKeepingParameters class removeSelector: #assertIsNotEmpty:signalMessageText:! - -!methodRemoval: ChangeSelectorKeepingParameters class #assertIsNotEmpty:signalMessageText: stamp: 'Install-3999-RenameSelectorWithEmptyImplementors-HernanWilkinson-2019Dec30-12h36m-HAW.1.cs.st 1/11/2020 17:57:46'! -assertIsNotEmpty: aCollection signalMessageText: errorMessageText - - aCollection isEmpty ifTrue: [ self refactoringError: errorMessageText ].! - -ChangeSelectorKeepingParameters class removeSelector: #doesNotMakeSenseToApplyRefactoringWithOutImplementors! - -ChangeSelector class removeSelectorIfInBaseSystem: #doesNotMakeSenseToApplyRefactoringWithOutImplementors! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3999-RenameSelectorWithEmptyImplementors-HernanWilkinson-2019Dec30-12h36m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3997] on 31 December 2019 at 3:01:26 pm'! -!ProgressMorph methodsFor: 'accessing' stamp: 'HAW 12/31/2019 15:00:11' prior: 50444736! - updatePositionAndExtent - | w newExtent | - w _ ((labelMorph measureContents x max: subLabelMorph measureContents x) max: 200) + 18. - w _ w min: Display extent x. - newExtent _ w > extent x - ifTrue: [ w@(labelMorph morphHeight + subLabelMorph morphHeight + progress morphHeight + 10) ] - ifFalse: [ extent ]. - self world - ifNotNil: [ :world | self morphPosition: world morphExtent - newExtent // 2 extent: newExtent ] - ifNil: [ self morphExtent: newExtent ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4000-ProgressMorphOutOfScreenFix-HernanWilkinson-2019Dec30-18h32m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #4000] on 31 December 2019 at 5:35:23 pm'! -!Process methodsFor: 'debugging' stamp: 'jmv 12/31/2019 17:34:38' prior: 50489950! - debug: context title: title full: bool - "Open debugger on self with context shown on top" - - | topCtxt | - self isTerminated ifTrue: [^ self error: 'can not debug a terminated process']. - topCtxt _ self isRunning ifTrue: [thisContext] ifFalse: [self suspendedContext]. - (topCtxt hasContext: context) ifFalse: [^ self error: 'context not in process']. - Debugger openOn: self context: context label: title fullView: bool. -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4001-TweakToTerminatedProcessDebugMessage-JuanVuletich-2019Dec31-17h31m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4001] on 1 January 2020 at 4:56:07 pm'! -!Utilities class methodsFor: 'default desktop' stamp: 'jmv 1/1/2020 16:48:22' prior: 50472900! - defaultTextEditorContents - ^ (' -', -('Cuis Smalltalk - -' centered blue pointSize: FontFamily defaultPointSize * 3), -(' -"Yay, Juan. You GO, guy!! ...a great example of malleable software (and a clever mind) at work." -' rightFlush pointSize: FontFamily defaultPointSize * 0.6), -('Dan Ingalls -' italic rightFlush pointSize: FontFamily defaultPointSize * 0.6), -(' -"I like it... It''s nice and clean and simple and pretty. Nice stuff!!" -' rightFlush pointSize: FontFamily defaultPointSize * 0.6), -('Alan Kay -' italic rightFlush pointSize: FontFamily defaultPointSize * 0.6), -(' -"I think you have a very elegant design aesthetic." -' rightFlush pointSize: FontFamily defaultPointSize * 0.6), -('John Maloney -'italic rightFlush pointSize: FontFamily defaultPointSize * 0.6), -' - -', -'Cuis is a modern, Open Source, multiplatform, Smalltalk-80 system. - - -', -'Cuis is: - -' bold, -' - Small - - Clean - - Appropriable -' blue, -' - -Additionally, Cuis is: - -' bold, -' - Open Source - - Multiplatform -' blue, -' - -Like other Smalltalk systems, Cuis is also: - -' bold, -' - A complete development environment written in itself - - A pure, dynamic Object Oriented language -' blue, -' - -Cuis assumes very little on the underlying platform, and this lets it run out-of-the-box on Windows, MacOS, Linux, ChromeOS and WebBrowsers. Cuis shares the [OpenSmalltalk Virtual Machine] (http://www.opensmalltalk.org) with Squeak, Pharo and Newspeak. - -What sets Cuis apart from the other members of the Squeak family is the focus on Smalltalk-80 and an active attitude towards system complexity: - -Unbound complexity growth, together with development strategies focused only in the short term, are the worst long term enemies of all software systems. As systems grow older, they usually become more complex. New features are added as layers on top of whatever is below, sometimes without really understanding it, and almost always without modifying it. Complexity and size grow without control. Evolution slows down. Understanding the system becomes harder every day. Bugs are harder to fix. Codebases become huge for no clear reason. At some point, the system can''t evolve anymore and becomes "legacy code". - -Complexity puts a limit to the level of understanding of the system a person might reach, and therefore limits the things that can be done with it. Dan Ingalls says all this in ["Design Principles Behind Smalltalk"] (http://www.cs.virginia.edu/~evans/cs655/readings/smalltalk.html). Even if you have already done so, please go and read it again!! - -Cuis Smalltalk is our attempt at this challenge. Furthermore, we believe we are doing something else that no other Smalltalk, commercial or open source, does. We attempt to give the true Smalltalk-80 experience, and keep Smalltalk-80 not as legacy software historic significance, but as a live, evolving system. We feel we are the keepers of the Smalltalk-80 heritage, and enablers of the Dynabook experience. - -As Cuis evolves, we keep on these values. Every update, be it a bug fix or a feature enhancement, is reviewed carefully to avoid adding unneded complexity to the system. Every opportunity to remove unneded complexity is followed. As we go, features are enhanced, and any reported bugs fixed. We also adopt selected enhancements from Squeak and Pharo, and share our work with the wider Smalltalk community. - - -' justified, -'License -' bold, -' -Cuis is distributed subject to the MIT License, as in http://www.opensource.org/licenses/mit-license.php . Any contribution submitted for incorporation into or for distribution with Cuis shall be presumed subject to the same license. - -Portions of Cuis are: -Copyright (c) Xerox Corp. 1981, 1982 -Copyright (c) Apple Computer, Inc. 1985-1996 -Copyright (c) Contributors to Squeak project. 1997-2020 -Copyright (c) Contributors to Cuis project. 1997-2020')! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4002-UpdateCopyrightNoticeYear-JuanVuletich-2020Jan01-16h44m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3997] on 2 January 2020 at 7:05:52 am'! - -RefactoringApplier subclass: #ChangeSelectorApplier - instanceVariableNames: 'oldSelector scopeChoice implementors senders implementingClass wizardStepWindow shouldShowChanges browser selectedClass ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ChangeSelectorApplier category: #'Tools-Refactoring' stamp: 'Install-4003-RefactoringAndBugFixingOfChangeSelectorRefactoring-HernanWilkinson-2019Dec31-15h01m-HAW.1.cs.st 1/11/2020 17:57:46'! -RefactoringApplier subclass: #ChangeSelectorApplier - instanceVariableNames: 'oldSelector scopeChoice implementors senders implementingClass wizardStepWindow shouldShowChanges browser selectedClass' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelectorApplier subclass: #AddParameterApplier - instanceVariableNames: 'newParameter newParameterValue newKeyword parameterIndex' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #AddParameterApplier category: #'Tools-Refactoring' stamp: 'Install-4003-RefactoringAndBugFixingOfChangeSelectorRefactoring-HernanWilkinson-2019Dec31-15h01m-HAW.1.cs.st 1/11/2020 17:57:46'! -ChangeSelectorApplier subclass: #AddParameterApplier - instanceVariableNames: 'newParameter newParameterValue newKeyword parameterIndex' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelectorApplier subclass: #RemoveParameterApplier - instanceVariableNames: 'newParameter newParameterValue newKeyword originalMethod parameterToRemove parameterToRemoveIndex parameterToRemoveName ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RemoveParameterApplier category: #'Tools-Refactoring' stamp: 'Install-4003-RefactoringAndBugFixingOfChangeSelectorRefactoring-HernanWilkinson-2019Dec31-15h01m-HAW.1.cs.st 1/11/2020 17:57:46'! -ChangeSelectorApplier subclass: #RemoveParameterApplier - instanceVariableNames: 'newParameter newParameterValue newKeyword originalMethod parameterToRemove parameterToRemoveIndex parameterToRemoveName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!MethodReference methodsFor: 'testing' stamp: 'HAW 1/2/2020 06:45:07'! - referencesParameterAt: parameterIndex - - ^(self compiledMethodIfAbsent: [ ^false ]) referencesParameterAt: parameterIndex ! ! -!RemoveParameter class methodsFor: 'instance creation' stamp: 'HAW 1/1/2020 23:34:04'! - atIndex: parameterIndex named: aParameterToRemove from: oldSelector implementors: implementorsCollection senders: sendersCollection - - | newSelector | - - self assertCanRemoveParameterFrom: oldSelector. - self assert: parameterIndex isValidFor: oldSelector. - - self assertAllImplementors: implementorsCollection haveSame: oldSelector. - self assertAllSenders: sendersCollection send: oldSelector. - self assertNoImplementorFrom: implementorsCollection reference: aParameterToRemove definedAt: parameterIndex. - - newSelector := self newSelectorFrom: oldSelector removingParameterAt: parameterIndex. - - ^self new - initializeNamed: aParameterToRemove - ofKeywordAtIndex: parameterIndex - from: oldSelector - creating: newSelector - implementors: implementorsCollection - senders: sendersCollection -! ! -!RemoveParameter class methodsFor: 'pre-conditions' stamp: 'HAW 1/1/2020 23:39:59'! - assert: parameterIndex isValidFor: oldSelector - - parameterIndex isInteger ifFalse: [ self signalInvalidParameterIndex ]. - (parameterIndex between: 1 and: oldSelector numArgs) ifFalse: [ self signalInvalidParameterIndex ].! ! -!RemoveParameter class methodsFor: 'exceptions' stamp: 'HAW 1/1/2020 23:35:34'! - invalidParameterIndexErrorMessage - - ^'Invalid parameter index'! ! -!RemoveParameter class methodsFor: 'exceptions' stamp: 'HAW 1/1/2020 23:35:19'! - signalInvalidParameterIndex - - self refactoringError: self invalidParameterIndexErrorMessage! ! -!ChangeSelectorApplier class methodsFor: 'instance creation' stamp: 'HAW 1/2/2020 00:05:51'! - on: aMessageNode createAndValueHandlingExceptionsOn: aModel in: aSelectedClass at: aSelectedSelector - - ^self createAndValueHandlingExceptionsOn: aModel for: aMessageNode selector key in: aSelectedClass -! ! -!AddParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 1/1/2020 23:52:39'! - addAsLastParameterLabel - - ^ 'Add as last parameter'! ! -!AddParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 1/1/2020 23:52:39'! - askInsertionIndexUsingKeywords - - | keywords | - - keywords := oldSelector keywords asOrderedCollection. - keywords add: self addAsLastParameterLabel. - - parameterIndex := (PopUpMenu labelArray: keywords) startUpWithCaption: 'Select keyword to add parameter before'. - parameterIndex = 0 ifTrue: [self endRequest ]. - - ! ! -!RemoveParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 1/1/2020 23:19:25'! - askKeywordToRemove - - | keywords | - - keywords := oldSelector keywords. - - keywords size = 1 - ifTrue: [ parameterToRemoveIndex := 1 ] - ifFalse: [ parameterToRemoveIndex := self selectKeywordIndexToRemoveFrom: keywords ]. - - "Because I do not know the parameter name, I'll use this one as explanation - Hernan" - parameterToRemoveName := 'Parameter related to keyword ', (keywords at: parameterToRemoveIndex) ! ! -!RemoveParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 1/1/2020 23:18:18'! -selectKeywordIndexToRemoveFrom: keywords - - | keywordIndex | - - keywordIndex := (PopUpMenu labelArray: keywords) startUpWithCaption: 'Select keyword related to parameter to remove'. - keywordIndex = 0 ifTrue: [self endRequest ]. - - ^keywordIndex! ! -!RemoveParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 1/1/2020 23:21:19'! - selectParameterIndexToRemoveFrom: parameterNames - - | parameterIndex | - - parameterIndex := (PopUpMenu labelArray: parameterNames) startUpWithCaption: 'Select parameter to remove'. - parameterIndex = 0 ifTrue: [self endRequest ]. - - ^parameterIndex! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 1/2/2020 00:04:31' prior: 50450105! - renameSelectorOf: aMessageNode in: aSelectedClass at: aSelectedSelector - - RefactoringApplier renameSelectorApplier - on: aMessageNode - createAndValueHandlingExceptionsOn: model textProvider - in: aSelectedClass - at: aSelectedSelector! ! -!SmalltalkEditor methodsFor: 'contextual add/remove parameter' stamp: 'HAW 1/2/2020 00:04:31' prior: 50469446! - changeSelectorOf: aMessageNode in: aSelectedClass at: aSelectedSelector using: aChangeSelectorApplier - - aChangeSelectorApplier - on: aMessageNode - createAndValueHandlingExceptionsOn: model textProvider - in: aSelectedClass - at: aSelectedSelector! ! -!ChangeSelectorWizardStepWindow methodsFor: 'compile methods' stamp: 'HAW 1/1/2020 19:45:32' prior: 50491015! - compiledMethodsFrom: methodReferences - - "If the method is not implemented, I leave the not implemented reference because actual senders of it - should be renamed. This is important for LiveTyping Actual Scope Refactorings - Hernan" - ^ methodReferences collect: [:aMethodReference | - aMethodReference compiledMethodIfAbsent: [ aMethodReference ]]! ! -!MethodReference methodsFor: 'queries' stamp: 'HAW 1/1/2020 19:46:02' prior: 50452818! - compiledMethodIfAbsent: ifAbsentBlock - - ^ self actualClass - ifNil: ifAbsentBlock - ifNotNil: [ :aClass | aClass compiledMethodAt: methodSymbol ifAbsent: ifAbsentBlock ] ! ! -!MethodReference methodsFor: 'testing' stamp: 'HAW 1/2/2020 06:45:39' prior: 50486786! - hasVariableBindingTo: aClass - - ^(self compiledMethodIfAbsent: [ ^false ]) hasVariableBindingTo: aClass -! ! -!ChangeSelector methodsFor: 'create new implementors - private' stamp: 'HAW 1/1/2020 19:44:25' prior: 50438616! - createNewImplementors - - implementors - select: [ :anImplementor | anImplementor isValid ] - thenDo: [:anImplementor | self createNewImplementorOf: anImplementor ] - ! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 1/2/2020 07:00:51' prior: 50439257! - assertNewParameter: aNewParameter isNotDefinedAsInstanceVariableInAny: implementors - - | classesDefiningInsVars | - - classesDefiningInsVars := self classesDefiningInstanceVariable: aNewParameter inAny: implementors. - classesDefiningInsVars ifNotEmpty: [ - self signalNewParameter: aNewParameter definedAsInstanceVariableIn: classesDefiningInsVars ]! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 1/2/2020 07:00:58' prior: 50439271! - assertNewParameter: aNewParameter isNotDefinedAsLocalInAny: implementors - - | implementorsDefiningNewParameterAsLocal | - - implementorsDefiningNewParameterAsLocal := implementors select: [ :implementor | - implementor isValid and: [ implementor methodNode hasLocalNamed: aNewParameter ]]. - implementorsDefiningNewParameterAsLocal ifNotEmpty: [ - self signalNewParameter: aNewParameter isDefinedAsLocalIn: implementorsDefiningNewParameterAsLocal ]! ! -!RemoveParameter class methodsFor: 'instance creation' stamp: 'HAW 1/2/2020 00:23:12' prior: 50439630! - named: aParameterToRemove from: aMethod implementors: implementorsCollection senders: sendersCollection - - | parameterIndex | - - parameterIndex := self assert: aParameterToRemove isDefinedIn: aMethod methodNode. - - ^self - atIndex: parameterIndex - named: aParameterToRemove - from: aMethod selector - implementors: implementorsCollection - senders: sendersCollection ! ! -!RefactoringApplier class methodsFor: 'value handling exceptions' stamp: 'HAW 12/30/2019 16:46:47' prior: 50491049! - createAndValueHandlingExceptions: creationBlock - - | applier | - - applier := creationBlock - on: Refactoring refactoringErrorClass - do: [ :refactoringError | ^self inform: refactoringError messageText ]. - - applier value ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 1/1/2020 21:52:03' prior: 50441561! - implementorsAndSendersForClass - - ^self refactoringClass - addImplementorsOf: oldSelector - to: implementors - andSendersTo: senders - forClassAndMetaOf: selectedClass! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 1/1/2020 21:52:03' prior: 50441570! -implementorsAndSendersForHierarchy - - ^self refactoringClass - addImplementorsOf: oldSelector - to: implementors - andSendersTo: senders - inHierarchyOf: selectedClass! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 1/1/2020 21:52:03' prior: 50441579! -implementorsAndSendersInCategory - - ^self refactoringClass - addImplementorsOf: oldSelector - to: implementors - andSendersTo: senders - inCategory: selectedClass category - organizedBy: SystemOrganization! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 1/1/2020 21:52:02' prior: 50441590! - implementorsAndSendersInCategoryAndHierarchy - - ^self refactoringClass - addImplementorsOf: oldSelector - to: implementors - andSendersTo: senders - inCategoriesAndHierarchyOf: selectedClass - organizedBy: SystemOrganization ! ! -!ChangeSelectorApplier methodsFor: 'initialization' stamp: 'HAW 1/1/2020 21:54:19' prior: 50441717! - initializeOn: aBrowser for: aSelector in: aSelectedClass - - oldSelector := aSelector. - selectedClass := aSelectedClass. - browser := aBrowser. - shouldShowChanges := true.! ! -!ChangeSelectorApplier class methodsFor: 'pre-conditions' stamp: 'HAW 1/1/2020 21:55:17' prior: 50441767! - assertCanApplyRefactoringFor: aSelector in: aSelectedClass - - self subclassResponsibility ! ! -!ChangeSelectorApplier class methodsFor: 'instance creation' stamp: 'HAW 1/1/2020 21:54:30' prior: 50450280! - on: aBrowser for: aSelector in: aSelectedClass - - self assertCanApplyRefactoringFor: aSelector in: aSelectedClass. - - ^self new initializeOn: aBrowser for: aSelector in: aSelectedClass - ! ! -!AddParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 1/2/2020 07:02:14' prior: 50441819! - askInsertionIndex - - | methodNode originalMethod parameterNames | - - "See RemoveParameterApplier#askParameterToRemove to understand why I ask for the index using - the keywords when no method is found - Hernan" - originalMethod := selectedClass - compiledMethodAt: oldSelector - ifAbsent: [ ^self askInsertionIndexUsingKeywords ]. - - methodNode := originalMethod methodNode. - parameterNames := methodNode argumentNames. - parameterNames add: self addAsLastParameterLabel. - - parameterIndex := (PopUpMenu labelArray: parameterNames) startUpWithCaption: 'Add parameter before?'. - parameterIndex = 0 ifTrue: [self endRequest ]. - - ! ! -!AddParameterApplier class methodsFor: 'pre-conditions' stamp: 'HAW 1/1/2020 21:55:05' prior: 50441892! - assertCanApplyRefactoringFor: aSelector in: aSelectedClass - - AddParameter assertCanAddParameterTo: aSelector. - - - ! ! -!ChangeKeywordsSelectorOrderApplier class methodsFor: 'pre-conditions' stamp: 'HAW 1/1/2020 21:55:12' prior: 50448118! - assertCanApplyRefactoringFor: aSelector in: aSelectedClass - - ChangeKeywordsSelectorOrder assertIsKeywordWithMoreThanOneParameter: aSelector ! ! -!RenameSelectorApplier class methodsFor: 'pre-conditions' stamp: 'HAW 1/1/2020 21:55:26' prior: 50441987! - assertCanApplyRefactoringFor: aSelector in: aSelectedClass - - ! ! -!RemoveParameterApplier methodsFor: 'refactoring - creation' stamp: 'HAW 1/1/2020 23:25:59' prior: 50441899! - createRefactoring - - ^self refactoringClass - atIndex: parameterToRemoveIndex - named: parameterToRemoveName - from: oldSelector - implementors: implementors - senders: senders ! ! -!RemoveParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 1/1/2020 23:28:37' prior: 50441912! - askParameterToRemove - - | methodNode parameterNames selectedMethod | - - "If the compiled method does not exist it means that the remove is being executed from the - editor, in a message send therefore we can not ask for the parameter name unless we look for implementors or - use LiveTyping to look for actual implementors, etc. - To make it simpler, when we can know the parameter names, we use that. When we can not, we use the keyword - names. I tried to used only keyword names but it is not so intuitive. I decided to use two different ways of asking - instead of one (asking for keyword names) becuase I think the programmer prefers to see parameter names. - - It could happen that the selected class implements the message to remove the parameter but that the remove - is executed from the editor (not sending to self), in that case the parameters of selected class implementation - will be use... it is a rare case and I think it will not confuse the programmer - Hernan" - - selectedMethod := selectedClass - compiledMethodAt: oldSelector - ifAbsent: [ ^self askKeywordToRemove ]. - - methodNode := selectedMethod methodNode. - parameterNames := methodNode argumentNames. - - parameterToRemoveIndex := parameterNames size = 1 - ifTrue: [ 1 ] - ifFalse: [ self selectParameterIndexToRemoveFrom: parameterNames ]. - - parameterToRemoveName := parameterNames at: parameterToRemoveIndex. - - - ! ! -!RemoveParameterApplier class methodsFor: 'pre-conditions' stamp: 'HAW 1/1/2020 21:55:21' prior: 50441946! - assertCanApplyRefactoringFor: aSelector in: aSelectedClass - - RemoveParameter assertCanRemoveParameterFrom: aSelector. - - - ! ! -!CompiledMethod methodsFor: 'testing' stamp: 'HAW 1/2/2020 07:21:15'! - isValid - - "To be polimorphic with MethodReference, important for refactorings - Hernan" - ^true! ! - -RemoveParameterApplier class removeSelector: #createAndValueHandlingExceptionsOn:of:in:at:! - -!methodRemoval: RemoveParameterApplier class #createAndValueHandlingExceptionsOn:of:in:at: stamp: 'Install-4003-RefactoringAndBugFixingOfChangeSelectorRefactoring-HernanWilkinson-2019Dec31-15h01m-HAW.1.cs.st 1/11/2020 17:57:46'! -createAndValueHandlingExceptionsOn: aModel of: aMessageNode in: aSelectedClass at: aSelectedSelector - - ^self createAndValueHandlingExceptionsOn: aModel for: aMessageNode selector key in: aSelectedClass -! - -RemoveParameterApplier class removeSelector: #on:createAndValueHandlingExceptionsOn:of:in:at:! - -RemoveParameterApplier class removeSelector: #on:createAndValueHandlingExceptionsOn:in:at:! - -RemoveParameterApplier removeSelector: #selectKeywordToRemoveFrom:! - -RemoveParameterApplier removeSelector: #selectParameterToRemoveForm:! - -!methodRemoval: RemoveParameterApplier #selectParameterToRemoveForm: stamp: 'Install-4003-RefactoringAndBugFixingOfChangeSelectorRefactoring-HernanWilkinson-2019Dec31-15h01m-HAW.1.cs.st 1/11/2020 17:57:46'! -selectParameterToRemoveForm: parameterNames - - | parameterIndex | - - parameterIndex := (PopUpMenu labelArray: parameterNames) startUpWithCaption: 'Select parameter to remove'. - parameterIndex = 0 ifTrue: [self endRequest ]. - - ^parameterNames at: parameterIndex.! - -RemoveParameterApplier removeSelector: #selectParameterToRemoveFrom:! - -RenameSelectorApplier class removeSelector: #createAndValueHandlingExceptionsOn:of:in:at:! - -!methodRemoval: RenameSelectorApplier class #createAndValueHandlingExceptionsOn:of:in:at: stamp: 'Install-4003-RefactoringAndBugFixingOfChangeSelectorRefactoring-HernanWilkinson-2019Dec31-15h01m-HAW.1.cs.st 1/11/2020 17:57:46'! -createAndValueHandlingExceptionsOn: aModel of: aMessageNode in: aSelectedClass at: aSelectedSelector - - ^self createAndValueHandlingExceptionsOn: aModel for: aMessageNode selector key in: aSelectedClass -! - -RenameSelectorApplier class removeSelector: #on:createAndValueHandlingExceptionsOn:of:in:at:! - -RenameSelectorApplier class removeSelector: #on:createAndValueHandlingExceptionsOn:in:at:! - -AddParameterApplier class removeSelector: #createAndValueHandlingExceptionsOn:of:in:at:! - -!methodRemoval: AddParameterApplier class #createAndValueHandlingExceptionsOn:of:in:at: stamp: 'Install-4003-RefactoringAndBugFixingOfChangeSelectorRefactoring-HernanWilkinson-2019Dec31-15h01m-HAW.1.cs.st 1/11/2020 17:57:46'! -createAndValueHandlingExceptionsOn: aModel of: aMessageNode in: aSelectedClass at: aSelectedSelector - - ^self createAndValueHandlingExceptionsOn: aModel for: aMessageNode selector key in: aSelectedClass -! - -AddParameterApplier class removeSelector: #on:createAndValueHandlingExceptionsOn:of:in:at:! - -AddParameterApplier class removeSelector: #on:createAndValueHandlingExceptionsOn:in:at:! - -RefactoringApplier subclass: #ChangeSelectorApplier - instanceVariableNames: 'oldSelector scopeChoice implementors senders selectedClass wizardStepWindow shouldShowChanges browser' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ChangeSelectorApplier category: #'Tools-Refactoring' stamp: 'Install-4003-RefactoringAndBugFixingOfChangeSelectorRefactoring-HernanWilkinson-2019Dec31-15h01m-HAW.1.cs.st 1/11/2020 17:57:46'! -RefactoringApplier subclass: #ChangeSelectorApplier - instanceVariableNames: 'oldSelector scopeChoice implementors senders selectedClass wizardStepWindow shouldShowChanges browser' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelectorApplier subclass: #RemoveParameterApplier - instanceVariableNames: 'parameterToRemoveIndex parameterToRemoveName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RemoveParameterApplier category: #'Tools-Refactoring' stamp: 'Install-4003-RefactoringAndBugFixingOfChangeSelectorRefactoring-HernanWilkinson-2019Dec31-15h01m-HAW.1.cs.st 1/11/2020 17:57:46'! -ChangeSelectorApplier subclass: #RemoveParameterApplier - instanceVariableNames: 'parameterToRemoveIndex parameterToRemoveName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4003-RefactoringAndBugFixingOfChangeSelectorRefactoring-HernanWilkinson-2019Dec31-15h01m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3997] on 2 January 2020 at 11:25:04 am'! -!SmalltalkEditor methodsFor: 'menu' stamp: 'HAW 1/2/2020 10:13:18'! - openSmalltalkEditorRefactoringMenu - - ^self refactoringMenu popUpInWorld! ! -!SmalltalkEditor methodsFor: 'menu' stamp: 'HAW 1/2/2020 11:21:36'! - refactoringMenu - - ^DynamicMenuBuilder - buildTitled: 'More refactorings' - targeting: self - collectingMenuOptionsWith: #smalltalkEditorRefactoringMenuOptions.! ! -!RefactoringMenues class methodsFor: 'editor menus' stamp: 'HAW 1/2/2020 11:21:44'! - smalltalkEditorRefactoringMenuOptions - - ^`{ - { - #itemGroup -> 35. - #itemOrder -> 30. - #label -> 'Add Parameter... (A)'. - #selector -> #contextualAddParameter. - #icon -> #listAddIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 40. - #label -> 'Remove Parameter... (S)'. - #selector -> #contextualRemoveParameter. - #icon -> #listRemoveIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 50. - #label -> 'Temporary to Instance Variable (O)'. - #selector -> #temporaryToInstanceVariable. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 60. - #label -> 'Push Up Instance Variable'. - #selector -> #contextualPushUpInClassDefinition. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 70. - #label -> 'Push Down Instance Variable'. - #selector -> #contextualPushDownInClassDefinition. - #icon -> #goBottomIcon - } asDictionary. - }`! ! -!RefactoringMenues class methodsFor: 'editor menus' stamp: 'HAW 1/2/2020 10:12:44' prior: 50490771! - smalltalkEditorMenuOptions - - ^`{ - { - #itemGroup -> 35. - #itemOrder -> 10. - #label -> 'Rename... (R)'. - #selector -> #contextualRename. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 20. - #label -> 'Extract Method... (K)'. - #selector -> #extractMethod. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 30. - #label -> 'More Refactorings...'. - #selector -> #openSmalltalkEditorRefactoringMenu. - #icon -> #listAddIcon - } asDictionary. - }`! ! - -SmalltalkEditor removeSelector: #openClassRefactoringMenu! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4004-SmalltalkEditorRefactoringMenu-HernanWilkinson-2020Jan02-07h21m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #4003] on 2 January 2020 at 10:01:34 pm'! - -"Change Set: 4004-CuisCore-AuthorName-2020Jan02-21h40m -Date: 2 January 2020 -Author: Nahuel Garbezza - -Fixes to Extract Method refactoring: - -* bug: extra arguments were selected for the extracted message when extracting blocks -* change :: usage to facilitate interoperability -* rename 'ensure' by 'assert' to have consistency with other refactorings"! -!ExtractMethod class methodsFor: 'validations' stamp: 'RNG 1/2/2020 21:50:31'! - assert: aSelector canBeDefinedIn: aClass - - ExtractMethodNewSelectorPrecondition valueFor: aSelector on: aClass! ! -!ExtractMethod class methodsFor: 'validations' stamp: 'RNG 1/2/2020 21:51:30'! - assert: anIntervalToExtract isValidIntervalOn: aMethodToExtractCodeFrom - - (self isNotEmpty: anIntervalToExtract) - ifFalse: [ self signalNoSelectedCodeError ]. - (self is: anIntervalToExtract withinBoundsOf: aMethodToExtractCodeFrom sourceCode) - ifFalse: [ self signalOutOfBoundsIntervalError ]. - (self method: aMethodToExtractCodeFrom containsAValidExpressionOn: anIntervalToExtract) - ifFalse: [ self signalSelectedCodeIsInvalidForExtractError ].! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 1/2/2020 21:55:44' prior: 50489365! - containsValidNodes - - ^ self isNotLeftSideOfAssignment - and: [ self thereAreNoLocalVariableAssignments ] - and: [ self thereAreNoReturnExpressions ] - and: [ self isNotATempDeclaration ]! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 1/2/2020 21:56:11' prior: 50489407! - isLeftSideOfAssignment - - ^ initialNodeAncestors size > 1 - and: [ initialNodeAncestors second key isAssignmentNode ] - and: [ initialNodeAncestors second key variable = initialNode key ]! ! -!ExtractMethodExpressionValidation methodsFor: 'validation' stamp: 'RNG 1/2/2020 21:56:53' prior: 50489493! - passed - - methodNode _ method methodNode. - sourceCode _ method sourceCode. - initialNodeAncestors _ methodNode parseNodesPathAt: intervalToExtract first ifAbsent: [ ^ false]. - finalNodeAncestors _ methodNode parseNodesPathAt: intervalToExtract last ifAbsent: [ ^ false ]. - initialNode _ initialNodeAncestors first. - finalNode _ finalNodeAncestors first. - - ^ self intervalCoversCompleteAstNodes - and: [ self containsValidNodes ] - and: [ self startAndEndParseNodesAreTheSame - or: [ self startAndEndNodesShareAParentNode ] - or: [ self intervalMatchesBeginningOfStatement and: [ self intervalMatchesEndOfStatement ] ] ]! ! -!ExtractMethod methodsFor: 'private - source code' stamp: 'RNG 1/2/2020 21:58:40' prior: 50488805! - shouldBeEnclosedWithParens - - | initialNode finalNode parseNodesInCommon methodNode initialNodeAncestors finalNodeAncestors insideMessageNodeExpressions | - - methodNode _ existingMethod methodNode. - initialNodeAncestors _ methodNode parseNodesPathAt: intervalToExtract first ifAbsent: [ ^ false]. - finalNodeAncestors _ methodNode parseNodesPathAt: intervalToExtract last ifAbsent: [ ^ false ]. - parseNodesInCommon _ initialNodeAncestors intersection: finalNodeAncestors. - - initialNode _ (parseNodesInCommon at: 1 ifAbsent: [ ^ false ]) key. - finalNode _ (parseNodesInCommon at: 2 ifAbsent: [ ^ false ]) key. - insideMessageNodeExpressions _ initialNode isMessageNode and: [ finalNode isMessageNode ]. - - ^ insideMessageNodeExpressions - and: [ initialNode precedence < newMessage selector precedence ] - and: [ initialNode precedence <= finalNode precedence ]! ! -!ExtractMethod class methodsFor: 'instance creation' stamp: 'RNG 1/2/2020 21:51:11' prior: 50488936! - fromInterval: anIntervalToExtract of: aMethodToExtractCodeFrom to: newMessage categorizedAs: aCategory - - | trimmedIntervalToExtract | - trimmedIntervalToExtract _ ExtractMethodIntervalTrimmer - trim: anIntervalToExtract locatedIn: aMethodToExtractCodeFrom sourceCode. - self - assert: newMessage selector canBeDefinedIn: aMethodToExtractCodeFrom methodClass; - assert: trimmedIntervalToExtract isValidIntervalOn: aMethodToExtractCodeFrom. - - ^ self new - initializeFrom: trimmedIntervalToExtract - of: aMethodToExtractCodeFrom - to: newMessage - in: aCategory! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 1/2/2020 21:53:15' prior: 50488957! - blockNodesEnclosingIntervalToExtract - - | nodes | - nodes _ Set new. - methodToExtractCodeFrom methodNode completeSourceRangesDo: [ :parseNode :sourceRanges | - (parseNode isBlockNode and: [ self intervalToExtractIsCoveredByAnyOf: sourceRanges ]) - ifTrue: [ nodes add: parseNode ] ]. - ^ nodes! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 1/2/2020 21:47:50' prior: 50488992! - definedInOuterScope: parseNode - - ^ self nodesThatAddVariablesToScope - anySatisfy: [ :node | node hasLocallyArgumentOrTemporaryNamed: parseNode name ]! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 1/2/2020 21:45:39' prior: 50489015! - intervalToExtractIsCoveredByAnyOf: sourceRanges - - ^ sourceRanges anySatisfy: [ :sourceRange | - sourceRange first < intervalToExtract first - and: [ sourceRange last > intervalToExtract last ] ]! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 1/2/2020 21:53:56' prior: 50489045! - saveBinaryOrKeywordSelector: userAnswer withArguments: parseNodesToParameterize - - self saveMessageArgumentsForEach: parseNodesToParameterize using: userAnswer. - newSelector _ ('' join: (self selectorTokensOf: userAnswer)) asSymbol.! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 1/2/2020 21:59:32' prior: 50489082! - shouldBeParameterized: parseNode appearingIn: sourceRanges - - ^ (sourceRanges anySatisfy: [ :sourceRange | intervalToExtract includes: sourceRange first ]) - and: [ parseNode isTempOrArg ] - and: [ self definedInOuterScope: parseNode ]! ! -!ExtractMethodApplier class methodsFor: 'pre-conditions' stamp: 'RNG 1/2/2020 21:51:11' prior: 50489188! - assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: anIntervalToExtract - - ExtractMethod - assert: anIntervalToExtract - isValidIntervalOn: aMethodToExtractCodeFrom! ! - -ExtractMethod class removeSelector: #ensure:isValidIntervalOn:! - -!methodRemoval: ExtractMethod class #ensure:isValidIntervalOn: stamp: 'Install-4005-ExtractMethodFix-NahuelGarbezza-2020Jan02-21h40m-RNG.1.cs.st 1/11/2020 17:57:46'! -ensure: anIntervalToExtract isValidIntervalOn: aMethodToExtractCodeFrom - - self isNotEmpty: anIntervalToExtract - :: ifFalse: [ self signalNoSelectedCodeError ]. - self is: anIntervalToExtract withinBoundsOf: aMethodToExtractCodeFrom sourceCode - :: ifFalse: [ self signalOutOfBoundsIntervalError ]. - self method: aMethodToExtractCodeFrom containsAValidExpressionOn: anIntervalToExtract - :: ifFalse: [ self signalSelectedCodeIsInvalidForExtractError ].! - -ExtractMethod class removeSelector: #ensure:canBeDefinedIn:! - -!methodRemoval: ExtractMethod class #ensure:canBeDefinedIn: stamp: 'Install-4005-ExtractMethodFix-NahuelGarbezza-2020Jan02-21h40m-RNG.1.cs.st 1/11/2020 17:57:46'! -ensure: aSelector canBeDefinedIn: aClass - - ExtractMethodNewSelectorPrecondition valueFor: aSelector on: aClass! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4005-ExtractMethodFix-NahuelGarbezza-2020Jan02-21h40m-RNG.1.cs.st----! - -'From Cuis 5.0 [latest update: #4005] on 9 January 2020 at 4:34:58 pm'! -!Text methodsFor: 'emphasis' stamp: 'jmv 1/9/2020 11:59:43'! - colorAt: characterIndex - "Answer the color for characters in the run beginning at characterIndex." - - self - withAttributeValues: (self attributesAt: characterIndex) - do: [ :familyName :pointSize :emphasis :color :alignment :characterStyle :paragraphStyle :backgroundColor | - ^ color ]! ! -!Text methodsFor: 'adding color' stamp: 'jmv 1/9/2020 12:15:35'! - color: aColor - "Stuff like - 'Hello world' blue edit - " - self addAttribute: (TextColor color: aColor)! ! -!Text methodsFor: 'emphasis' stamp: 'jmv 1/9/2020 12:11:24' prior: 16929248! - addAttribute: att - string size = 0 ifTrue: [ ^self ]. - ^ self addAttribute: att from: 1 to: self size! ! -!Text methodsFor: 'adding emphasis' stamp: 'jmv 1/9/2020 12:16:25' prior: 50462432! - bold - "Stuff like - ('X' italic, '2' super, ' + ', 'H' bold, 'ij' sub, ' + ', 'lim' italic under, 'z  ' sub, '(1 / z)' ) edit - " - self addAttribute: TextEmphasis bold! ! -!Text methodsFor: 'adding emphasis' stamp: 'jmv 1/9/2020 12:16:49' prior: 50462442! - italic - "Stuff like - ('X' italic, '2' super, ' + ', 'H' bold, 'ij' sub, ' + ', 'lim' italic under, 'z  ' sub, '(1 / z)' ) edit - " - self addAttribute: TextEmphasis italic! ! -!Text methodsFor: 'adding emphasis' stamp: 'jmv 1/9/2020 12:18:12' prior: 50471526! - pointSize: pointSize - "Stuff like - ('Hello World' pointSize: 22) edit - " - self addAttribute: (TextFontFamilyAndSize pointSize: pointSize)! ! -!Text methodsFor: 'adding emphasis' stamp: 'jmv 1/9/2020 12:18:47' prior: 16929749! - struck - "Stuff like - ('Hello world' struck ) edit - " - self addAttribute: TextEmphasis struckThrough! ! -!Text methodsFor: 'adding emphasis' stamp: 'jmv 1/9/2020 12:19:00' prior: 50462452! - sub - "Stuff like - ('X' italic, '2' super, ' + ', 'H' bold, 'ij' sub, ' + ', 'lim' italic under, 'z  ' sub, '(1 / z)' ) edit - " - self addAttribute: TextEmphasis subscript! ! -!Text methodsFor: 'adding emphasis' stamp: 'jmv 1/9/2020 12:19:10' prior: 50462462! - super - "Stuff like - ('X' italic, '2' super, ' + ', 'H' bold, 'ij' sub, ' + ', 'lim' italic under, 'z  ' sub, '(1 / z)' ) edit - " - self addAttribute: TextEmphasis superscript! ! -!Text methodsFor: 'adding emphasis' stamp: 'jmv 1/9/2020 12:19:21' prior: 50462473! - under - "Stuff like - ('X' italic, '2' super, ' + ', 'H' bold, 'ij' sub, ' + ', 'lim' italic under, 'z  ' sub, '(1 / z)' ) edit - " - self addAttribute: TextEmphasis underlined! ! -!Text methodsFor: 'adding attributes' stamp: 'jmv 1/9/2020 12:16:39' prior: 50471535! - centered - "Stuff like - ('Hello world' centered ) edit - " - self addAttribute: TextAlignment centered! ! -!Text methodsFor: 'adding attributes' stamp: 'jmv 1/9/2020 12:17:33' prior: 50471543! - justified - "Stuff like - ('Hello world. Hello world. Hello world. Hello world. Hello world. Hello world. Hello world. Hello world. Hello world. Hello world. Hello world. Hello world. Hello world. Hello world. Hello world. Hello world. Hello world. Hello world. Hello world. Hello world. Hello world. ' justified ) edit - " - self addAttribute: TextAlignment justified! ! -!Text methodsFor: 'adding attributes' stamp: 'jmv 1/9/2020 12:17:54' prior: 50471551! - leftFlush - "Stuff like - ('Hello world' leftFlush ) edit - " - self addAttribute: TextAlignment leftFlush! ! -!Text methodsFor: 'adding attributes' stamp: 'jmv 1/9/2020 12:18:23' prior: 50471559! -rightFlush - "Stuff like - ('Hello world' rightFlush ) edit - " - self addAttribute: TextAlignment rightFlush! ! -!Text methodsFor: 'adding color' stamp: 'jmv 1/9/2020 12:12:58' prior: 50471567! - black - "Stuff like - 'Hello world' black edit - " - self color: Color black! ! -!Text methodsFor: 'adding color' stamp: 'jmv 1/9/2020 12:12:40' prior: 50471574! - blue - "Stuff like - 'Hello world' blue edit - " - self color: Color blue! ! -!Text methodsFor: 'adding color' stamp: 'jmv 1/9/2020 12:13:20' prior: 50471581! - cyan - "Stuff like - 'Hello world' cyan edit - " - self color: Color cyan! ! -!Text methodsFor: 'adding color' stamp: 'jmv 1/9/2020 12:13:38' prior: 50471588! - gray - "Stuff like - 'Hello world' gray edit - " - self color: Color gray! ! -!Text methodsFor: 'adding color' stamp: 'jmv 1/9/2020 12:13:51' prior: 50471595! - green - "Stuff like - 'Hello world' green edit - " - self color: Color green! ! -!Text methodsFor: 'adding color' stamp: 'jmv 1/9/2020 12:14:13' prior: 50471602! - magenta - "Stuff like - 'Hello world' magenta edit - " - self color: Color magenta! ! -!Text methodsFor: 'adding color' stamp: 'jmv 1/9/2020 12:14:27' prior: 50471609! - red - "Stuff like - 'Hello world' red edit - " - self color: Color red! ! -!Text methodsFor: 'adding color' stamp: 'jmv 1/9/2020 12:14:45' prior: 50471616! - yellow - "Stuff like - 'Hello world' yellow edit - " - self color: Color yellow! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4006-Text-cleanup-JuanVuletich-2020Jan09-16h33m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4006] on 9 January 2020 at 4:38:36 pm'! -!InnerListMorph methodsFor: 'drawing' stamp: 'jmv 1/9/2020 16:37:23' prior: 16855140! - draw: item atRow: row on: canvas - "display the given item at row row" - | f | - f _ (item is: #Text) - ifTrue: [ font emphasized: (item emphasisAt: 1) ] - ifFalse: [ font ]. - canvas - drawString: item - at: 0 @ (self drawYForRow: row) - font: f - color: Theme current text! ! - -Theme removeSelector: #listSelectedRowText! - -!methodRemoval: Theme #listSelectedRowText stamp: 'Install-4007-InnerListMorph-cleanup-JuanVuletich-2020Jan09-16h37m-jmv.1.cs.st 1/11/2020 17:57:46'! -listSelectedRowText - ^ self text! - -Theme removeSelector: #listUnselectedRowText! - -!methodRemoval: Theme #listUnselectedRowText stamp: 'Install-4007-InnerListMorph-cleanup-JuanVuletich-2020Jan09-16h37m-jmv.1.cs.st 1/11/2020 17:57:46'! -listUnselectedRowText - ^ self text! - -InnerListMorph removeSelector: #colorForRow:! - -!methodRemoval: InnerListMorph #colorForRow: stamp: 'Install-4007-InnerListMorph-cleanup-JuanVuletich-2020Jan09-16h37m-jmv.1.cs.st 1/11/2020 17:57:47'! -colorForRow: row - ^(selectedRow notNil and: [ row = selectedRow]) - ifTrue: [ Theme current listSelectedRowText ] - ifFalse: [ Theme current listUnselectedRowText ].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4007-InnerListMorph-cleanup-JuanVuletich-2020Jan09-16h37m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4007] on 9 January 2020 at 5:25:46 pm'! -!ChangeList methodsFor: 'menu actions' stamp: 'jmv 1/9/2020 17:25:05' prior: 16796356! - removeUpToDate - "Remove all up to date version of entries from the receiver" - - | newChangeList newList | - newChangeList _ OrderedCollection new. - newList _ OrderedCollection new. - changeList with: list do: [ :chRec :strNstamp | | keep cls name | - keep _ chRec isClassDeletion not or: [ chRec changeClass notNil ]. "If a class deletion, and class already gone, don't keep it" - keep ifTrue: [ - (cls _ chRec changeClass) ifNotNil: [ | sel str | - str _ chRec string. - sel _ chRec methodSelector. - keep _ chRec isMethodDeletion - ifTrue: [cls includesSelector: sel] - ifFalse: [(cls sourceCodeAt: sel ifAbsent: nil) ~= str]]]. - (chRec changeType == #classComment and: [ - name _ chRec changeClassName. - Smalltalk includesKey: name]) ifTrue: [ - cls _ Smalltalk at: name. - keep _ cls organization classComment ~= chRec text ]. - (chRec changeType == #classDefinition and: [ - name _ chRec changeClassName. - Smalltalk includesKey: name]) ifTrue: [ - cls _ Smalltalk at: name. - chRec isMetaClassChange ifTrue: [ cls _ cls class ]. - keep _ cls definition ~= chRec text ]. - keep ifTrue: [ - newChangeList add: chRec. - newList add: strNstamp]]. - newChangeList size < changeList size ifTrue: [ - changeList _ newChangeList. - list _ newList. - listIndex _ 0. - self clearSelections ]. - self changed: #list! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4008-removeUpToDate-doRemoveDeletionOfMissingMethods-JuanVuletich-2020Jan09-17h22m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4008] on 9 January 2020 at 5:43:07 pm'! -!Browser methodsFor: 'message list' stamp: 'jmv 1/9/2020 17:41:56' prior: 16792365! - messageList - "Answer an Array of the message selectors of the currently selected message category, provided that the messageCategoryListIndex is in proper range. Otherwise, answer an empty Array If messageCategoryListIndex is found to be larger than the number of categories (it happens!!), it is reset to zero." - | classOrMetaClassOrganizer sel answer | - classOrMetaClassOrganizer _ self classOrMetaClassOrganizer. - classOrMetaClassOrganizer isNil ifTrue: [ ^#() ]. - sel _ self messageCategoryListSelection. - (sel isNil or: [ sel == ClassOrganizer allCategory ]) ifTrue: [ - ^ classOrMetaClassOrganizer allMethodSelectors]. - selectedMessageCategory isNil ifTrue: [ ^#() ]. - answer _ classOrMetaClassOrganizer listAtCategoryNamed: selectedMessageCategory. - answer isNil ifTrue: [ - selectedMessageCategory _ nil. - answer _ #() ]. - ^answer! ! -!PluggableListMorph methodsFor: 'initialization' stamp: 'jmv 1/9/2020 17:28:19' prior: 16888766! - initialize - super initialize. - scroller morphWidth: extent x.! ! - -PluggableListMorph removeSelector: #textColor! - -!methodRemoval: PluggableListMorph #textColor stamp: 'Install-4009-Cleanup-JuanVuletich-2020Jan09-17h28m-jmv.1.cs.st 1/11/2020 17:57:47'! -textColor - "" - ^ Theme current text! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4009-Cleanup-JuanVuletich-2020Jan09-17h28m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4009] on 9 January 2020 at 6:04:38 pm'! -!Browser methodsFor: 'message category functions' stamp: 'jmv 1/9/2020 18:00:54' prior: 16792026! -categoryOfCurrentMethod - "Determine the method category associated with the receiver at the current moment, or nil if none" - - | category | - ^ super categoryOfCurrentMethod ifNil: [ - category _ selectedMessageCategory. - category == ClassOrganizer allCategory - ifTrue: [nil] - ifFalse: [category]]! ! -!Browser methodsFor: 'message list' stamp: 'jmv 1/9/2020 18:01:53' prior: 50492490! - messageList - "Answer an Array of the message selectors of the currently selected message category, provided that the messageCategoryListIndex is in proper range. Otherwise, answer an empty Array If messageCategoryListIndex is found to be larger than the number of categories (it happens!!), it is reset to zero." - | classOrMetaClassOrganizer answer | - classOrMetaClassOrganizer _ self classOrMetaClassOrganizer. - classOrMetaClassOrganizer isNil ifTrue: [ ^#() ]. - (selectedMessageCategory isNil or: [ selectedMessageCategory == ClassOrganizer allCategory ]) ifTrue: [ - ^ classOrMetaClassOrganizer allMethodSelectors]. - answer _ classOrMetaClassOrganizer listAtCategoryNamed: selectedMessageCategory. - answer isNil ifTrue: [ - selectedMessageCategory _ nil. - answer _ #() ]. - ^answer! ! - -Browser removeSelector: #messageCategoryListSelection! - -!methodRemoval: Browser #messageCategoryListSelection stamp: 'Install-4010-Browser-cleanup-JuanVuletich-2020Jan09-17h51m-jmv.1.cs.st 1/11/2020 17:57:47'! -messageCategoryListSelection - "Return the selected category name or nil." - - ^ ((self messageCategoryList size = 0 - or: [self messageCategoryListIndex = 0]) - or: [self messageCategoryList size < self messageCategoryListIndex]) - ifTrue: [nil] - ifFalse: [self messageCategoryList at: (self messageCategoryListIndex max: 1)]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4010-Browser-cleanup-JuanVuletich-2020Jan09-17h51m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4010] on 9 January 2020 at 7:32:25 pm'! -!Browser methodsFor: 'message list' stamp: 'jmv 1/9/2020 12:07:48' prior: 50390505! - messageListIndex: anInteger - "Set the selected message selector to be the one indexed by anInteger." - - | index messageList | - - messageList _ self messageList. - index _ messageList ifInBounds: anInteger ifNot: 0. - - selectedMessage _ index = 0 ifFalse: [ (messageList at: index) string ]. - self editSelection: (index > 0 - ifTrue: [#editMessage] - ifFalse: [self messageCategoryListIndex > 0 - ifTrue: [#newMessage] - ifFalse: [self classListIndex > 0 - ifTrue: [#editClass] - ifFalse: [#newClass]]]). - self changed: #messageListIndex. "update my selection" - self acceptedContentsChanged! ! -!InnerListMorph methodsFor: 'drawing' stamp: 'jmv 1/9/2020 12:00:12' prior: 50492392! - draw: item atRow: row on: canvas - "display the given item at row row" - | f c | - (item is: #Text) - ifTrue: [ - f _ font emphasized: (item emphasisAt: 1). - c _ item colorAt: 1] - ifFalse: [ - f _ font. - c _ Theme current text]. - canvas - drawString: item - at: 0 @ (self drawYForRow: row) - font: f - color: c! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4011-AllowTextAsListItems-JuanVuletich-2020Jan09-19h31m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4010] on 9 January 2020 at 7:49:25 pm'! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'jmv 1/9/2020 19:47:47' prior: 50477925! - withSelectorUnderCursorDo: aBlock ifErrorsParsing: aParsingErrorBlock ifNoSelector: aNoSelectorBlock - - | methodNode nodeAtRange nodeUnderCursor alternativeAnswer failed | - failed _ false. - methodNode := self codeProvider - methodNodeOf: model actualContents - ifErrorsParsing: [ :anError | - alternativeAnswer _ aParsingErrorBlock valueWithPossibleArgument: anError. - failed _ true ]. - failed ifTrue: [ ^alternativeAnswer ]. - - self startIndex < methodNode selectorLastPosition ifTrue: [ ^aBlock value: methodNode selector ]. - nodeAtRange := methodNode parseNodeIncluding: self startIndex ifAbsent: [ ^ aNoSelectorBlock value ]. - nodeUnderCursor := nodeAtRange key. - nodeUnderCursor isMessageNode ifTrue: [ ^aBlock value: nodeAtRange key selector key ]. - (nodeUnderCursor isLiteralNode and: [ nodeUnderCursor literalValue isSymbol ]) ifTrue: [ ^aBlock value: nodeUnderCursor literalValue ]. - - ^ aNoSelectorBlock value ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4012-SmalltalkEditor-fix-JuanVuletich-2020Jan09-19h32m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4005] on 9 January 2020 at 3:57:20 pm'! - -Browser subclass: #CodeFileBrowser - instanceVariableNames: 'codeFile caseCodeSource baseCodeSource ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Code File Browser'! - -!classDefinition: #CodeFileBrowser category: #'Tools-Code File Browser' stamp: 'Install-4013-CodeFileBrowser-flexible-case-and-base-PhilBellalouna-2020Jan09-15h14m-pb.1.cs.st 1/11/2020 17:57:47'! -Browser subclass: #CodeFileBrowser - instanceVariableNames: 'codeFile caseCodeSource baseCodeSource' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Code File Browser'! -!CodeFileBrowser methodsFor: 'accessing' stamp: 'pb 12/11/2019 01:12:35'! - baseCodeSource - ^ baseCodeSource ifNil: [ Smalltalk ].! ! -!CodeFileBrowser methodsFor: 'accessing' stamp: 'pb 12/11/2019 01:12:28'! - baseCodeSource: aCodeFile - baseCodeSource _ aCodeFile! ! -!CodeFileBrowser methodsFor: 'accessing' stamp: 'pb 12/11/2019 01:12:39'! - caseCodeSource - ^ caseCodeSource ifNil: [ Smalltalk ].! ! -!CodeFileBrowser methodsFor: 'accessing' stamp: 'pb 12/11/2019 01:12:44'! - caseCodeSource: aCodeFile - caseCodeSource _ aCodeFile! ! -!CodeFileBrowser methodsFor: 'private' stamp: 'pb 12/11/2019 23:51:51'! - pvtBaseClassOrMetaclass - | theClass | - theClass _ [self baseCodeSource classNamed: self selectedClass name asSymbol] on: Error do: ["Class not found in base?"]. - ^ (theClass notNil and: [ self metaClassIndicated ]) - ifTrue: [ theClass class ] - ifFalse: [ theClass ].! ! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'pb 12/5/2019 03:00:05'! - browseCodeFileEntry: aFileEntry - self browseCodeSource: (CodeFile newFromFile: aFileEntry )! ! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'pb 12/11/2019 01:23:20'! - browseCodeSource: aCaseCodeSource - self browseCodeSource: aCaseCodeSource base: nil! ! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'pb 12/12/2019 01:50:16'! - browseCodeSource: aCaseCodeSource base: aBaseCodeSource - | useCaseCodeSource useCaseClasses browser useCaseOrganizer useHeading | - browser _ self new. - browser - caseCodeSource: aCaseCodeSource; - baseCodeSource: aBaseCodeSource. - useCaseCodeSource _ browser caseCodeSource. - useCaseClasses _ useCaseCodeSource classes collect: [ :ea | - ea name ]. - useCaseOrganizer _ useCaseCodeSource organization. - useHeading _ (useCaseCodeSource isLiveSmalltalkImage not and: [ browser baseCodeSource isLiveSmalltalkImage ]) - ifTrue: [ useCaseCodeSource name ] - ifFalse: [ "This is a non-standard configuration... make the user aware" - useCaseCodeSource name , '(' , useCaseCodeSource class name , '), target: ' , aBaseCodeSource name , '(' , aBaseCodeSource class name , ')' ]. - (useCaseCodeSource notNil and: [ useCaseCodeSource isLiveSmalltalkImage not ]) ifTrue: [ - useCaseOrganizer - classifyAll: useCaseClasses - under: useHeading ]. - browser - systemOrganizer: useCaseOrganizer; - caseCodeSource: useCaseCodeSource. - aBaseCodeSource ifNotNil: [ browser baseCodeSource: aBaseCodeSource ]. - CodeFileBrowserWindow - open: browser - label: nil.! ! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'pb 12/5/2019 02:59:59'! - browsePackageFileEntry: aFileEntry - self browseCodeSource: (CodePackageFile newFromFile: aFileEntry )! ! -!ClassDescription methodsFor: 'testing' stamp: 'pb 12/11/2019 23:57:24'! - hasDefinition - ^ true! ! -!SystemDictionary methodsFor: 'accessing' stamp: 'pb 12/11/2019 02:56:50'! - description - "Needed by CodeFileBrowser to use Smalltalk as the 'case' source" - ^ self name! ! -!SystemDictionary methodsFor: 'accessing' stamp: 'pb 12/5/2019 02:17:02'! - name - ^ 'Image'! ! -!SystemDictionary methodsFor: 'accessing' stamp: 'pb 12/11/2019 02:56:15'! - summary - "Needed by CodeFileBrowser to use Smalltalk as the 'case' source" - ^ self name! ! -!SystemDictionary methodsFor: 'private' stamp: 'pb 1/9/2020 15:28:55'! - baseLabel - ^ 'system'! ! -!SystemDictionary methodsFor: 'testing' stamp: 'pb 12/5/2019 03:21:11'! - isLiveSmalltalkImage - ^ true! ! -!CodeFileBrowserWindow methodsFor: 'GUI building' stamp: 'pb 12/12/2019 01:22:31'! - optionalButtonTuples - "Answer a tuple buttons, in the format: - button label - selector to send - help message" - ^ (self model baseCodeSource isLiveSmalltalkImage and: [ self model caseCodeSource isLiveSmalltalkImage not ]) - ifTrue: [ super optionalButtonTuples ] - ifFalse: [ "For non-standard browser configurations assume most of the default buttons are invalid" - #( - #(10 'show...' #offerWhatToShowMenu 'menu of what to show in lower pane' ) - ) ].! ! -!CodeFile methodsFor: 'accessing' stamp: 'pb 12/11/2019 01:51:02'! - classDictionary - ^classes! ! -!CodeFile methodsFor: 'accessing' stamp: 'pb 12/11/2019 23:14:13'! -classNamed: className - ^ classes at: className! ! -!CodeFile methodsFor: 'accessing' stamp: 'pb 12/5/2019 00:22:02'! - organization - ^ SystemOrganizer defaultList: Array new.! ! -!CodeFile methodsFor: 'testing' stamp: 'pb 12/5/2019 03:16:55'! - isLiveSmalltalkImage - ^ false! ! -!CodeFile methodsFor: 'private' stamp: 'pb 1/9/2020 15:29:37'! -baseLabel - ^ 'base'! ! -!CodeFile class methodsFor: 'instance creation' stamp: 'pb 12/5/2019 00:24:43'! - newFromFile: aFileEntry - ^ aFileEntry readStreamDo: [ :stream | - self new - fullName: aFileEntry pathName; - buildFrom: stream ].! ! -!PseudoClass methodsFor: 'accessing' stamp: 'pb 12/11/2019 23:20:55'! - theMetaClass - ^ metaClass ifNil: [ metaClass _ PseudoMetaclass new name: self name ].! ! -!CodeFileBrowser methodsFor: 'accessing' stamp: 'pb 12/11/2019 01:13:28' prior: 50485594! - acceptedStringOrText - self updateInfoView. - (editSelection == #newClass and: [ caseCodeSource notNil ]) - ifTrue: [ ^caseCodeSource description ]. - editSelection == #editClass - ifTrue:[ ^self modifiedClassDefinition ]. - ^super acceptedStringOrText! ! -!CodeFileBrowser methodsFor: 'class list' stamp: 'pb 12/11/2019 02:39:26' prior: 16809207! - classList - "Answer an array of the class names of the selected category. Answer an - empty array if no selection exists." - - ^(selectedSystemCategory isNil or: [ caseCodeSource isNil ]) - ifTrue: [ #() ] - ifFalse: [ (caseCodeSource classes collect: [:ea| ea name]) sort ]! ! -!CodeFileBrowser methodsFor: 'class list' stamp: 'pb 12/11/2019 01:53:26' prior: 16809217! - renameClass - | oldName newName | - selectedClassName ifNil: [ ^self ]. - oldName _ self selectedClass name. - newName _ (self request: 'Please type new class name' - initialAnswer: oldName) asSymbol. - (newName isEmpty or:[newName = oldName]) ifTrue: [^ self]. - (caseCodeSource classDictionary includesKey: newName) - ifTrue: [^ self error: newName , ' already exists in the CodeFile']. - systemOrganizer classify: newName under: selectedSystemCategory. - systemOrganizer removeElement: oldName. - caseCodeSource renameClass: self selectedClass to: newName. - self changed: #classList. - self classListIndex: ((systemOrganizer listAtCategoryNamed: selectedSystemCategory) indexOf: newName). -! ! -!CodeFileBrowser methodsFor: 'class list' stamp: 'pb 12/11/2019 23:14:26' prior: 16809241! - selectedClass - "Answer the class that is currently selected. Answer nil if no selection - exists." - - ^self selectedClassName ifNotNil: [ :scn | - caseCodeSource classNamed: scn ]! ! -!CodeFileBrowser methodsFor: 'diffs' stamp: 'pb 1/9/2020 15:22:58' prior: 16809273! - methodDiffFor: aString class: aPseudoClass selector: selector meta: meta - "Answer the diff between the current copy of the given class/selector/meta for the string provided" - | theClass source | - theClass _ self pvtBaseClassOrMetaclass. - theClass ifNotNil: [ - meta ifTrue: [ theClass _ theClass class ]. - (theClass includesSelector: selector) ifTrue: [ source _ theClass sourceCodeAt: selector ]]. - ^ DifferenceFinder - displayPatchFrom: (source ifNil: ['']) - to: aString - tryWords: self shouldDiffWords - prettyPrintedIn: - (self showingAnyKindOfPrettyDiffs ifTrue: [ theClass ]).! ! -!CodeFileBrowser methodsFor: 'diffs' stamp: 'pb 12/11/2019 23:58:45' prior: 16809294! - modifiedClassDefinition - | pClass rClass old new | - pClass := self selectedClassOrMetaClass. - pClass ifNil: [^'']. - pClass hasDefinition ifFalse: [ ^pClass definition]. - rClass := [self baseCodeSource classNamed: self selectedClass name] on: Error do: ["Missing class"]. - rClass ifNil: [ ^pClass definition]. - self metaClassIndicated ifTrue:[ rClass := rClass class]. - old := rClass definition. - new := pClass definition. - ^ DifferenceFinder displayPatchFrom: old to: new tryWords: true! ! -!CodeFileBrowser methodsFor: 'fileIn/fileOut' stamp: 'pb 12/11/2019 01:18:26' prior: 16809311! - fileIn - caseCodeSource fileIn! ! -!CodeFileBrowser methodsFor: 'fileIn/fileOut' stamp: 'pb 12/11/2019 01:14:09' prior: 16809332! -fileOut - - caseCodeSource fileOut! ! -!CodeFileBrowser methodsFor: 'infoView' stamp: 'pb 1/9/2020 15:56:50' prior: 50485605! - infoViewContents - | theClass useLabel | - useLabel _ self baseCodeSource baseLabel. - editSelection == #newClass ifTrue: [ ^ caseCodeSource - ifNil: [ 'No file selected' ] - ifNotNil: [ caseCodeSource summary ]]. - self selectedClass ifNil: [ ^ '' ]. - theClass _ self pvtBaseClassOrMetaclass. - editSelection == #editClass ifTrue: [ ^ theClass - ifNil: [ 'Class not in the ' , useLabel ] - ifNotNil: [ 'Class exists already in the ' , useLabel ]]. - editSelection == #editMessage ifFalse: [ ^ '' ]. - (theClass notNil and: [ self metaClassIndicated ]) ifTrue: [ theClass _ theClass class ]. - ^ (theClass notNil and: [ theClass includesSelector: self selectedMessageName ]) - ifTrue: [ 'Method already exists' , self extraInfo ] - ifFalse: [ '**NEW** Method not in the ' , useLabel ].! ! -!CodeFileBrowser methodsFor: 'metaclass' stamp: 'pb 12/11/2019 23:18:54' prior: 16809397! - selectedClassOrMetaClass - "Answer the selected class or metaclass." - - | cls | - self metaClassIndicated - ifTrue: [^ (cls _ self selectedClass) ifNotNil: [cls theMetaClass]] - ifFalse: [^ self selectedClass]! ! -!CodeFileBrowser methodsFor: 'metaclass' stamp: 'pb 12/11/2019 23:16:03' prior: 16809406! - setClassOrganizer - "Install whatever organization is appropriate" - | theClass | - classOrganizer _ nil. - metaClassOrganizer _ nil. - selectedClassName ifNil: [ ^self ]. - theClass _ self selectedClass. - theClass ifNil: [classOrganizer := self baseCodeSource organization. - metaClassOrganizer := self baseCodeSource organization] ifNotNil: [ - classOrganizer _ theClass organization. - metaClassOrganizer _ theClass theMetaClass organization. - -]! ! -!CodeFileBrowser methodsFor: 'removing' stamp: 'pb 12/11/2019 01:16:45' prior: 16809125! - removeClass - | class | - selectedClassName ifNil: [ ^self ]. - class _ self selectedClass. - (self confirm:'Are you certain that you -want to delete the class ', class name, '?') ifFalse:[^self]. - caseCodeSource removeClass: class. - self classListIndex: 0. - self changed: #classList.! ! -!CodeFileBrowser methodsFor: 'removing' stamp: 'pb 12/11/2019 23:18:54' prior: 16809172! - removeUnmodifiedCategories - | theClass | - theClass _ self selectedClass. - theClass ifNil: [^self]. - theClass removeUnmodifiedMethods: theClass selectors. - theClass theMetaClass removeUnmodifiedMethods: theClass theMetaClass selectors. - self messageCategoryListIndex: 0. - self changed: #messageCategoryList! ! -!CodeFileBrowser methodsFor: 'removing' stamp: 'pb 12/11/2019 02:41:02' prior: 16809184! - removeUnmodifiedClasses - caseCodeSource isLiveSmalltalkImage - ifTrue: [ self error: 'Do not perform on a live image!!' ] - ifFalse: [ - caseCodeSource classDictionary copy do: [ :theClass | - theClass removeAllUnmodified. - theClass hasChanges ifFalse: [ caseCodeSource removeClass: theClass ]]. - self classListIndex: 0. - self changed: #classList ].! ! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'pb 12/5/2019 00:48:37' prior: 50427022! - serviceBrowseCode - "Answer the service of opening a file-contents browser" - - ^ (SimpleServiceEntry - provider: self - label: 'browse code' - selector: #browseCodeFileEntry: - description: 'open a "file-contents browser" on this file, allowing you to view and selectively load its code' - buttonLabel: 'code' - icon: #editFindReplaceIcon) - sortOrder: 10; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'pb 12/5/2019 00:49:55' prior: 50427039! - serviceBrowsePackage - "Answer the service of opening a file-contents browser" - - ^ (SimpleServiceEntry - provider: self - label: 'browse package' - selector: #browsePackageFileEntry: - description: 'open a "package file browser" on this file, allowing you to view and selectively load its code' - buttonLabel: 'package browser' - icon: #editFindReplaceIcon) - sortOrder: 10; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!CodeFileBrowserWindow methodsFor: 'menu building' stamp: 'pb 12/11/2019 01:09:41' prior: 50398625! - classListMenu - | aMenu itemColl | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Class List'. - itemColl _ OrderedCollection new. - itemColl addAll: - { - {#label -> 'definition'. #object -> #model. #selector -> #editClass. #icon -> #editFindReplaceIcon} asDictionary. - {#label -> 'comment'. #object -> #model. #selector -> #editComment. #icon -> #editFindReplaceIcon} asDictionary. - nil - }. - self model baseCodeSource isLiveSmalltalkImage ifTrue: [ - itemColl addAll: - { - {#label -> 'browse full (b)'. #selector -> #browseMethodFull. #icon -> #editFindReplaceIcon} asDictionary. - {#label -> 'class refs (N)'. #selector -> #browseClassRefs. #icon -> #classIcon} asDictionary. - nil. - {#label -> 'fileIn'. #object -> #model. #selector -> #fileInClass. #icon -> #updateIcon} asDictionary - } ]. - itemColl addAll: - { - {#label -> 'fileOut'. #object -> #model. #selector -> #fileOutClass. #icon -> #fileOutIcon} asDictionary. - nil. - {#label -> 'rename...'. #object -> #model. #selector -> #renameClass. #icon -> #saveAsIcon} asDictionary. - {#label -> 'remove'. #object -> #model. #selector -> #removeClass. #icon -> #listRemoveIcon} asDictionary. - nil. - {#label -> 'remove existing'. #object -> #model. #selector -> #removeUnmodifiedCategories. #icon -> #deleteIcon} asDictionary - }. - aMenu addItemsFromDictionaries: itemColl. - ^ aMenu.! ! -!CodeFileBrowserWindow methodsFor: 'menu building' stamp: 'pb 12/11/2019 01:10:17' prior: 50398981! - codeFileListMenu - | aMenu itemColl | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Code File'. - itemColl _ OrderedCollection new. - itemColl addAll: - { - {#label -> 'find class... (f)'. #selector -> #findClass} asDictionary. - nil - }. - self model baseCodeSource isLiveSmalltalkImage ifTrue: [ - itemColl add: - {#label -> 'fileIn'. #object -> #model. #selector -> #fileIn} asDictionary ]. - itemColl add: - {#label -> 'fileOut'. #object -> #model. #selector -> #fileOut} asDictionary. - self model caseCodeSource isLiveSmalltalkImage ifFalse: [ - itemColl add: - {#label -> 'remove existing'. #object -> #model. #selector -> #removeUnmodifiedClasses} asDictionary ]. - aMenu addItemsFromDictionaries: itemColl. - ^ aMenu.! ! -!CodeFileBrowserWindow methodsFor: 'menu building' stamp: 'pb 12/11/2019 01:10:17' prior: 50398677! - messageCategoryMenu - | aMenu itemColl | - aMenu _ MenuMorph new defaultTarget: model. - "All the options are for the model." - aMenu addTitle: 'Message Category'. - itemColl _ OrderedCollection new. - self model baseCodeSource isLiveSmalltalkImage ifTrue: [ - itemColl add: - {#label -> 'fileIn'. #selector -> #fileInMessageCategories. #icon -> #updateIcon} asDictionary ]. - itemColl addAll: - { - {#label -> 'fileOut'. #selector -> #fileOutMessageCategories. #icon -> #fileOutIcon} asDictionary. - nil. - {#label -> 'reorganize'. #selector -> #editMessageCategories. #icon -> #sendReceiveIcon} asDictionary. - nil. - {#label -> 'add item...'. #selector -> #addCategory. #icon -> #newIcon} asDictionary. - nil. - {#label -> 'rename...'. #selector -> #renameCategory. #icon -> #saveAsIcon} asDictionary. - {#label -> 'remove'. #selector -> #removeMessageCategory. #icon -> #listRemoveIcon} asDictionary - }. - self model caseCodeSource isLiveSmalltalkImage ifFalse: [ - itemColl addAll: - { - nil. - {#label -> 'remove existing'. #selector -> #removeUnmodifiedMethods. #icon -> #deleteIcon} asDictionary - } ]. - aMenu addItemsFromDictionaries: itemColl. - ^ aMenu.! ! -!CodeFileBrowserWindow methodsFor: 'menu building' stamp: 'pb 12/11/2019 01:09:41' prior: 50398717! - messageListMenu - | aMenu itemColl | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Message List'. - itemColl _ OrderedCollection new. - self model baseCodeSource isLiveSmalltalkImage ifTrue: [ - itemColl add: - {#label -> 'fileIn'. #object -> #model. #selector -> #fileInMessage. #icon -> #updateIcon} asDictionary ]. - itemColl addAll: - { - {#label -> 'fileOut'. #object -> #model. #selector -> #fileOutMessage. #icon -> #fileOutIcon} asDictionary. - nil - }. - self model baseCodeSource isLiveSmalltalkImage ifTrue: [ - itemColl addAll: - { - {#label -> 'senders (n)'. #selector -> #browseSenders. #icon -> #mailForwardIcon} asDictionary. - {#label -> 'implementors (m)'. #selector -> #browseImplementors. #icon -> #developmentIcon} asDictionary. - {#label -> 'method inheritance (h)'. #selector -> #methodHierarchy. #icon -> #goDownIcon} asDictionary. - {#label -> 'versions (v)'. #selector -> #browseVersions. #icon -> #clockIcon} asDictionary - } ]. - itemColl addAll: - { - nil. - {#label -> 'remove method (x)'. #object -> #model. #selector -> #removeMessage. #icon -> #deleteIcon} asDictionary - }. - aMenu addItemsFromDictionaries: itemColl. - ^ aMenu.! ! -!CodeFileBrowserWindow methodsFor: 'commands' stamp: 'pb 12/11/2019 01:53:06' prior: 16809729! - findClass - | pattern foundClass classNames index foundCodeFile | - self okToChange ifFalse: [^ self flash]. - pattern _ (FillInTheBlankMorph request: 'Class Name?') asLowercase. - pattern isEmpty ifTrue: [^ self]. - classNames := Set new. - classNames addAll: model caseCodeSource classDictionary keys. - classNames := classNames asArray select: - [:n | (n asLowercase indexOfSubCollection: pattern startingAt: 1) > 0]. - classNames isEmpty ifTrue: [^ self]. - index _ classNames size = 1 - ifTrue: [1] - ifFalse: [(PopUpMenu labelArray: classNames lines: #()) startUpMenu]. - index = 0 ifTrue: [^ self]. - foundCodeFile := nil. - foundClass := nil. - (model caseCodeSource classDictionary includesKey: (classNames at: index)) ifTrue:[ - foundClass := model caseCodeSource classDictionary at: (classNames at: index). - foundCodeFile := model caseCodeSource ]. - foundClass ifNotNil: [ - model systemCategoryListIndex: (model systemCategoryList indexOf: foundCodeFile name asSymbol). - model classListIndex: (model classList indexOf: foundClass name) ]! ! -!CodeFile methodsFor: 'accessing' stamp: 'pb 12/11/2019 02:38:00' prior: 16808703! - classes - ^ self classDictionary values! ! -!CodeFile methodsFor: 'fileIn/fileOut' stamp: 'pb 12/11/2019 23:18:54' prior: 16808936! - fileIn - | doitsMark | - doitsMark := 1. - doIts isEmpty ifFalse:[doitsMark := self askForDoits]. - doitsMark = 4 ifTrue: [^nil]. - doitsMark = 2 ifTrue:[self fileInDoits]. - classOrder do:[:cls| - cls fileInDefinition. - ]. - classes do:[:cls| - Transcript newLine; show:'Filing in ', cls name. - cls fileInMethods. - cls hasMetaclass ifTrue:[cls theMetaClass fileInMethods]. - ]. - doitsMark = 3 ifTrue: [ self fileInDoits ]! ! -!CodeFile methodsFor: 'fileIn/fileOut' stamp: 'pb 12/11/2019 23:18:54' prior: 16808976! - fileOutOn: aStream - | doitsMark | - doitsMark := 1. - doIts isEmpty ifFalse:[doitsMark := self askForDoits]. - doitsMark = 4 ifTrue: [^nil]. - doitsMark = 2 ifTrue:[self fileOutDoits: aStream]. - classOrder do:[:cls| - cls fileOutDefinitionOn: aStream. - ]. - classes do:[:cls| - cls fileOutMethodsOn: aStream. - cls hasMetaclass ifTrue:[cls theMetaClass fileOutMethodsOn: aStream]. - ]. - doitsMark = 3 ifTrue:[self fileOutDoits: aStream].! ! -!CodeFile methodsFor: 'xtras' stamp: 'pb 12/11/2019 23:18:54' prior: 16809011! - allMethodReferences - "Create an answer a Set with method references for all methods in us" - | answer className metaClass | - answer _ Set new. - - classes do: [ :pseudoClass | - className _ pseudoClass name. - pseudoClass selectors do: [ :selector | - answer add: - (MethodReference new - setClassSymbol: className - classIsMeta: false - methodSymbol: selector - stringVersion: className, ' ' , selector) ]. - pseudoClass hasMetaclass ifTrue: [ - metaClass _ pseudoClass theMetaClass. - metaClass selectors do: [ :selector | - answer add: - (MethodReference new - setClassSymbol: className - classIsMeta: true - methodSymbol: selector - stringVersion: className, ' class ' , selector) ]. - ]]. - ^answer! ! -!CodeFile methodsFor: 'private' stamp: 'pb 12/11/2019 23:18:54' prior: 16808789! - metaClassDefinition: string with: chgRec - | tokens theClass | - tokens := Scanner new scanTokens: string. - theClass := self getClass: (tokens at: 1). - theClass theMetaClass definition: string. - classOrder add: theClass theMetaClass.! ! -!CodeFile methodsFor: 'private' stamp: 'pb 12/11/2019 23:18:54' prior: 16808799! - msgClassComment: string with: chgRec - | tokens theClass | - tokens := Scanner new scanTokens: string. - (tokens size = 3 and:[(tokens at: 3) class == String]) ifTrue:[ - theClass := self getClass: tokens first. - ^theClass classComment: tokens last]. - (tokens size = 4 and:[(tokens at: 3) asString = 'class' and:[(tokens at: 4) class == String]]) ifTrue:[ - theClass := self getClass: tokens first. - theClass theMetaClass classComment: tokens last]. -! ! -!CodeFile methodsFor: 'private' stamp: 'pb 12/11/2019 23:18:54' prior: 16808826! - removedMethod: string with: chgRec - | class tokens firstToken secondToken thirdToken | - tokens _ Scanner new scanTokens: string. - tokens size >= 3 ifTrue: [ - firstToken _ tokens at: 1. - secondToken _ tokens at: 2. - thirdToken _ tokens at: 3. - (tokens size = 3 and: [ secondToken == #removeSelector: or: [ secondToken == #removeSelectorIfInBaseSystem: ]]) ifTrue:[ - class _ self getClass: firstToken. - ^class perform: secondToken with: thirdToken. - ]. - (tokens size = 4 and: [ secondToken == #class and: [ thirdToken == #removeSelector: or: [ thirdToken == #removeSelectorIfInBaseSystem: ]]]) ifTrue:[ - class _ self getClass: firstToken. - ^class theMetaClass perform: thirdToken with: (tokens at: 4). - ]. - ]. - doIts add: chgRec! ! -!PseudoClass methodsFor: 'testing' stamp: 'pb 12/11/2019 23:18:54' prior: 16896947! - needsInitialize - ^self hasMetaclass and:[ - self theMetaClass realClass includesSelector: #initialize]! ! -!PseudoClass methodsFor: 'methods' stamp: 'pb 12/11/2019 23:18:54' prior: 16897122! - methodChange: aChangeRecord - aChangeRecord isMetaClassChange ifTrue:[ - ^self theMetaClass addMethodChange: aChangeRecord. - ] ifFalse:[ - ^self addMethodChange: aChangeRecord. - ]. -! ! -!PseudoClass methodsFor: 'testing method dictionary' stamp: 'pb 12/5/2019 03:20:39' prior: 16897194! - includesSelector: aSymbol - ^ source keys includes: aSymbol.! ! - -PseudoClass removeSelector: #metaClass! - -!methodRemoval: PseudoClass #metaClass stamp: 'Install-4013-CodeFileBrowser-flexible-case-and-base-PhilBellalouna-2020Jan09-15h14m-pb.1.cs.st 1/11/2020 17:57:47'! -metaClass - ^metaClass ifNil:[metaClass := PseudoMetaclass new name: (self name)].! - -CodeFile removeSelector: #classAt:! - -!methodRemoval: CodeFile #classAt: stamp: 'Install-4013-CodeFileBrowser-flexible-case-and-base-PhilBellalouna-2020Jan09-15h14m-pb.1.cs.st 1/11/2020 17:57:47'! -classAt: className - ^ classes at: className! - -CodeFileBrowserWindow class removeSelector: #browseFile:! - -!methodRemoval: CodeFileBrowserWindow class #browseFile: stamp: 'Install-4013-CodeFileBrowser-flexible-case-and-base-PhilBellalouna-2020Jan09-15h14m-pb.1.cs.st 1/11/2020 17:57:47'! -browseFile: aFileEntry - - | codeFile organizer browser | - organizer _ SystemOrganizer defaultList: Array new. - aFileEntry readStreamDo: [ :stream | - codeFile _ (CodeFile new fullName: aFileEntry pathName; buildFrom: stream) ]. - organizer - classifyAll: codeFile classes keys - under: codeFile name. - (browser _ CodeFileBrowser new) - systemOrganizer: organizer; - codeFile: codeFile. - self open: browser label: nil! - -CodeFileBrowserWindow class removeSelector: #browsePackageFile:! - -!methodRemoval: CodeFileBrowserWindow class #browsePackageFile: stamp: 'Install-4013-CodeFileBrowser-flexible-case-and-base-PhilBellalouna-2020Jan09-15h14m-pb.1.cs.st 1/11/2020 17:57:47'! -browsePackageFile: aFileEntry - - | codeFile organizer browser | - organizer _ SystemOrganizer defaultList: Array new. - aFileEntry readStreamDo: [ :stream | - codeFile _ (CodePackageFile new fullName: aFileEntry pathName; buildFrom: stream) ]. - organizer - classifyAll: codeFile classes keys - under: codeFile name. - (browser _ CodeFileBrowser new) - systemOrganizer: organizer; - codeFile: codeFile. - self open: browser label: nil! - -CodeFileBrowserWindow removeSelector: #buildWindowMenu! - -CodeFileBrowser class removeSelector: #browseCode:! - -!methodRemoval: CodeFileBrowser class #browseCode: stamp: 'Install-4013-CodeFileBrowser-flexible-case-and-base-PhilBellalouna-2020Jan09-15h14m-pb.1.cs.st 1/11/2020 17:57:47'! -browseCode: aFileEntry - - CodeFileBrowserWindow browseFile: aFileEntry! - -CodeFileBrowser class removeSelector: #browsePackage:! - -!methodRemoval: CodeFileBrowser class #browsePackage: stamp: 'Install-4013-CodeFileBrowser-flexible-case-and-base-PhilBellalouna-2020Jan09-15h14m-pb.1.cs.st 1/11/2020 17:57:47'! -browsePackage: aFileEntry - - CodeFileBrowserWindow browsePackageFile: aFileEntry! - -CodeFileBrowser removeSelector: #shouldShowFalseColorDiffs! - -CodeFileBrowser removeSelector: #toggleShowFalseColorDiffsLabel! - -CodeFileBrowser removeSelector: #codeFile:! - -!methodRemoval: CodeFileBrowser #codeFile: stamp: 'Install-4013-CodeFileBrowser-flexible-case-and-base-PhilBellalouna-2020Jan09-15h14m-pb.1.cs.st 1/11/2020 17:57:47'! -codeFile: aCodeFile - codeFile _ aCodeFile! - -CodeFileBrowser removeSelector: #toggleShowFalseColorDiffs! - -CodeFileBrowser removeSelector: #initialize! - -CodeFileBrowser removeSelector: #selectedCodeFile! - -!methodRemoval: CodeFileBrowser #selectedCodeFile stamp: 'Install-4013-CodeFileBrowser-flexible-case-and-base-PhilBellalouna-2020Jan09-15h14m-pb.1.cs.st 1/11/2020 17:57:47'! -selectedCodeFile - ^codeFile! - -Browser subclass: #CodeFileBrowser - instanceVariableNames: 'baseCodeSource caseCodeSource' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Code File Browser'! - -!classDefinition: #CodeFileBrowser category: #'Tools-Code File Browser' stamp: 'Install-4013-CodeFileBrowser-flexible-case-and-base-PhilBellalouna-2020Jan09-15h14m-pb.1.cs.st 1/11/2020 17:57:47'! -Browser subclass: #CodeFileBrowser - instanceVariableNames: 'baseCodeSource caseCodeSource' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Code File Browser'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4013-CodeFileBrowser-flexible-case-and-base-PhilBellalouna-2020Jan09-15h14m-pb.1.cs.st----! - -'From Cuis 5.0 [latest update: #4012] on 10 January 2020 at 12:21:32 am'! -!CodeFileBrowser methodsFor: 'message list' stamp: 'pb 1/10/2020 00:20:12'! - messageList - "Colorize messages as needed" - ^ super messageList collect: [ :eaListItem | | foundCat useAttr | - foundCat _ classOrganizer categoryOfElement: eaListItem. - " - Transcript - show: foundCat class name; - finishEntry. - " - useAttr _ foundCat = PseudoClass removedCategoryName - ifTrue: [ TextColor red ] - ifFalse: [ | baseSrc | - baseSrc _ self pvtBaseSelectedMessageSourceCodeFor: eaListItem. - baseSrc - ifNil: [ TextColor green ] - ifNotNil: [ | caseSrc | - caseSrc _ self pvtCaseSelectedMessageSourceCodeFor: eaListItem. - baseSrc = caseSrc ifFalse: [ TextColor blue ]]]. - useAttr - ifNil: [ eaListItem ] - ifNotNil: [ :attr | - Text - string: eaListItem - attribute: attr ]].! ! -!CodeFileBrowser methodsFor: 'private' stamp: 'pb 1/9/2020 23:39:45'! - pvtBaseSelectedMessageSourceCodeFor: selector - ^ self pvtBaseClassOrMetaclass ifNotNil: [ :theClass | | useClass | - self metaClassIndicated - ifTrue: [ useClass _ theClass class ] - ifFalse: [ useClass _ theClass ]. - (useClass includesSelector: selector) ifTrue: [ useClass sourceCodeAt: selector ]].! ! -!CodeFileBrowser methodsFor: 'private' stamp: 'pb 1/9/2020 23:40:02'! - pvtCaseSelectedMessageSourceCodeFor: selector - | class | - class _ self selectedClassOrMetaClass. - ^ class sourceCodeAt: selector.! ! -!PseudoClass class methodsFor: 'categories' stamp: 'pb 1/9/2020 22:19:49'! - removedCategoryName - ^ `Text string: '*** removed methods ***' attribute: TextColor red`! ! -!Categorizer methodsFor: 'accessing' stamp: 'pb 1/9/2020 21:21:38' prior: 16795291! - addCategory: catString before: nextCategory - "Add a new category named heading. - If default category exists and is empty, remove it. - If nextCategory is nil, then add the new one at the end, - otherwise, insert it before nextCategory." - | index newCategory | - newCategory _ catString . - (categoryArray indexOf: newCategory) > 0 - ifTrue: [^self]. "heading already exists, so done" - index _ categoryArray indexOf: nextCategory - ifAbsent: [categoryArray size + 1]. - categoryArray _ categoryArray - copyReplaceFrom: index - to: index-1 - with: (Array with: newCategory). - categoryStops _ categoryStops - copyReplaceFrom: index - to: index-1 - with: (Array with: (index = 1 - ifTrue: [0] - ifFalse: [categoryStops at: index-1])). - "remove empty default category" - (newCategory ~= Default - and: [(self listAtCategoryNamed: Default) isEmpty]) - ifTrue: [self removeCategory: Default]! ! -!Categorizer methodsFor: 'accessing' stamp: 'pb 1/9/2020 21:21:47' prior: 16795449! - classify: element under: heading suppressIfDefault: aBoolean - "Store the argument, element, in the category named heading. If aBoolean is true, then invoke special logic such that the classification is NOT done if the new heading is the Default and the element already had a non-Default classification -- useful for filein" - - | catName catIndex elemIndex realHeading | - ((heading = NullCategory) or: [heading == nil]) - ifTrue: [realHeading _ Default] - ifFalse: [realHeading _ heading ]. - (catName _ self categoryOfElement: element) = realHeading - ifTrue: [^ self]. "done if already under that category" - - catName ifNotNil: [ - (aBoolean and: [realHeading = Default]) - ifTrue: [^ self]. "return if non-Default category already assigned in memory" - self removeElement: element]. "remove if in another category" - - (categoryArray indexOf: realHeading) = 0 ifTrue: [self addCategory: realHeading]. - - catIndex _ categoryArray indexOf: realHeading. - elemIndex _ - catIndex > 1 - ifTrue: [categoryStops at: catIndex - 1] - ifFalse: [0]. - [(elemIndex _ elemIndex + 1) <= (categoryStops at: catIndex) - and: [element >= (elementArray at: elemIndex)]] whileTrue. - - "elemIndex is now the index for inserting the element. Do the insertion before it." - elementArray _ elementArray copyReplaceFrom: elemIndex to: elemIndex-1 - with: (Array with: element). - - "add one to stops for this and later categories" - catIndex to: categoryArray size do: - [:i | categoryStops at: i put: (categoryStops at: i) + 1]. - - (self listAtCategoryNamed: Default) size = 0 ifTrue: [self removeCategory: Default]! ! -!CodeFileBrowserWindow methodsFor: 'GUI building' stamp: 'pb 1/9/2020 22:41:38' prior: 50453769! - buildMorphicWindow - "Create a pluggable version of all the views for a Browser, using Morphic widgets." - - | sysCatList msgCatList upperPanes clsLayout msgLayout clsList msgList | - model systemCategoryListIndex: 1. - sysCatList _ PluggableListMorph - model: model - listGetter: #systemCategorySingleton - indexGetter: #indexIsOne - indexSetter: #indexIsOne: - mainView: self - menuGetter: #codeFileListMenu - keystrokeAction: #codeFileListKey:from:. - sysCatList hideScrollBarsIndefinitely. - - msgCatList _ PluggableListMorph - model: model - listGetter: #messageCategoryList - indexGetter: #messageCategoryListIndex - indexSetter: #messageCategoryListIndex: - mainView: self - menuGetter: #messageCategoryMenu - keystrokeAction: nil. - clsLayout := self buildMorphicClassColumn. - msgLayout := self buildMorphicMessageList. - clsList := clsLayout findDeepSubmorphThat: [:tstMorph| tstMorph class = PluggableListMorph] ifAbsent: [nil]. - msgList := msgLayout findDeepSubmorphThat: [:tstMorph| tstMorph class = PluggableListMorph] ifAbsent: [nil]. - sysCatList rightSibling: clsList. - clsList leftSibling: sysCatList rightSibling: msgCatList. - msgCatList leftSibling: clsList rightSibling: msgList. - msgList leftSibling: msgCatList . - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: clsLayout proportionalWidth: 0.3; - addAdjusterAndMorph: msgCatList proportionalWidth: 0.3; - addAdjusterAndMorph: msgLayout proportionalWidth: 0.4. - - self layoutMorph - addMorph: sysCatList fixedHeight: Preferences standardCodeFont lineSpacing + 10; - addAdjusterAndMorph: upperPanes proportionalHeight: 0.3; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.7. - model changed: #editSelection! ! -!PseudoClass methodsFor: 'fileIn/fileOut' stamp: 'pb 1/9/2020 22:20:09' prior: 16896988! - fileInMethods: aCollection - "FileIn all methods with selectors taken from aCollection" - | theClass | - self exists ifFalse:[^self classNotDefined]. - theClass := self realClass. - aCollection do:[:sel| - | cat | - cat := self organization categoryOfElement: sel. - cat = self class removedCategoryName ifFalse:[ - theClass - compile: (self sourceCodeAt: sel) - classified: cat - withStamp: (self stampAt: sel) - notifying: nil. - ]. - ].! ! -!PseudoClass methodsFor: 'fileIn/fileOut' stamp: 'pb 1/9/2020 22:20:04' prior: 16897044! - fileOutMethods: aCollection on: aStream - "FileOut all methods with selectors taken from aCollection" - | categories | - categories := Dictionary new. - aCollection do:[:sel| - | cat | - cat := self organization categoryOfElement: sel. - cat = self class removedCategoryName ifFalse:[ - (categories includesKey: cat) - ifFalse:[ categories at: cat put: Set new ]. - (categories at: cat) add: sel]. - ]. - categories associationsDo:[:assoc| - assoc value do: [ :sel | - aStream newLine. - (self sourceCode at: sel) fileOutOn: aStream. - ]. - ].! ! -!PseudoClass methodsFor: 'methods' stamp: 'pb 1/9/2020 22:19:59' prior: 16897134! - removeSelector: aSelector - | catName | - catName := self class removedCategoryName. - self organization addCategory: catName before: self organization categories first. - self organization classify: aSelector under: catName. - self sourceCodeAt: aSelector put:'methodWasRemoved' asText.! ! -!SequenceDifference methodsFor: 'printing' stamp: 'pb 1/9/2020 23:51:15' prior: 16905320! - attributesFor: condition - condition == #unchanged - ifTrue: [ - ^ {TextEmphasis normal} ]. - condition == #removed - ifTrue: [ - ^ {TextEmphasis struckThrough. TextColor red} ]. - condition == #inserted - ifTrue: [ - ^ {TextColor green} ]! ! - -PseudoClass removeSelector: #removedCategoryName! - -!methodRemoval: PseudoClass #removedCategoryName stamp: 'Install-4014-CodeFileBrowser-color-lists-PhilBellalouna-2020Jan09-21h17m-pb.1.cs.st 1/11/2020 17:57:47'! -removedCategoryName - ^'*** removed methods ***' asSymbol! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4014-CodeFileBrowser-color-lists-PhilBellalouna-2020Jan09-21h17m-pb.1.cs.st----! - -'From Cuis 5.0 [latest update: #4014] on 10 January 2020 at 2:43:44 pm'! -!BrowserWindow methodsFor: 'GUI building' stamp: 'jmv 1/10/2020 14:38:33' prior: 50453719! - buildNoSysCatMorphicWindow - "A Browser without the class categories list" - - | mySingletonList upperPanes messageCatList messageList classColumn classList | - mySingletonList _ PluggableListMorph - model: model - listGetter: #systemCategorySingleton - indexGetter: #indexIsOne - indexSetter: #indexIsOne: - mainView: self - menuGetter: #systemCatSingletonMenu - keystrokeAction: #systemCatSingletonKey:from:. - mySingletonList hideScrollBarsIndefinitely. - - classList _ self buildMorphicClassList. - classColumn _ self buildMorphicClassColumnWith: classList. - messageCatList _ self buildMorphicMessageCatList. - messageList _ self buildMorphicMessageList. - - classList rightSibling: messageCatList. - messageCatList leftSibling: classList rightSibling: messageList. - messageList leftSibling: messageCatList. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: classColumn proportionalWidth: 0.3; - addAdjusterAndMorph: messageCatList proportionalWidth: 0.3; - addAdjusterAndMorph: messageList proportionalWidth: 0.4. - - messageList makeItemsDraggable. - messageCatList - acceptDropsFrom: messageList - performing: #categorizeUnderCategoryAt:selector: - whenOutsideList: #categorizeUnderNewCategorySelector:. - - self layoutMorph - addMorph: mySingletonList fixedHeight: Preferences standardCodeFont lineSpacing + 10; - addAdjusterAndMorph: upperPanes proportionalHeight: 0.3; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.7. - - model changed: #editSelection! ! -!CodeFileBrowserWindow methodsFor: 'GUI building' stamp: 'jmv 1/10/2020 14:42:40' prior: 50493696! - buildMorphicWindow - "Create a pluggable version of all the views for a Browser, using Morphic widgets." - - | sysCatList msgCatList upperPanes clsLayout clsList msgList | - model systemCategoryListIndex: 1. - sysCatList _ PluggableListMorph - model: model - listGetter: #systemCategorySingleton - indexGetter: #indexIsOne - indexSetter: #indexIsOne: - mainView: self - menuGetter: #codeFileListMenu - keystrokeAction: #codeFileListKey:from:. - sysCatList hideScrollBarsIndefinitely. - - msgCatList _ PluggableListMorph - model: model - listGetter: #messageCategoryList - indexGetter: #messageCategoryListIndex - indexSetter: #messageCategoryListIndex: - mainView: self - menuGetter: #messageCategoryMenu - keystrokeAction: nil. - - clsList := self buildMorphicClassList. - clsLayout := self buildMorphicClassColumnWith: clsList. - msgList := self buildMorphicMessageList. - sysCatList rightSibling: clsList. - clsList leftSibling: sysCatList rightSibling: msgCatList. - msgCatList leftSibling: clsList rightSibling: msgList. - msgList leftSibling: msgCatList. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: clsLayout proportionalWidth: 0.3; - addAdjusterAndMorph: msgCatList proportionalWidth: 0.3; - addAdjusterAndMorph: msgList proportionalWidth: 0.4. - - self layoutMorph - addMorph: sysCatList fixedHeight: Preferences standardCodeFont lineSpacing + 10; - addAdjusterAndMorph: upperPanes proportionalHeight: 0.3; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.7. - model changed: #editSelection! ! - -BrowserWindow removeSelector: #buildMorphicClassColumn! - -!methodRemoval: BrowserWindow #buildMorphicClassColumn stamp: 'Install-4015-Cleanup-JuanVuletich-2020Jan10-14h35m-jmv.1.cs.st 1/11/2020 17:57:47'! -buildMorphicClassColumn - - ^self buildMorphicClassColumnWith: self buildMorphicClassList! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4015-Cleanup-JuanVuletich-2020Jan10-14h35m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4014] on 10 January 2020 at 3:47:01 pm'! -!CodeFileBrowser methodsFor: 'diffs' stamp: 'jmv 1/10/2020 15:39:10'! - methodDiffFor: aString selector: selector - "Answer the diff between the current copy of the given class/selector/meta for the string provided" - | theClass source | - source _ ''. - theClass _ self pvtBaseClassOrMetaclass. - theClass ifNotNil: [ - (theClass includesSelector: selector) ifTrue: [ - source _ theClass sourceCodeAt: selector ]]. - ^ DifferenceFinder - displayPatchFrom: source - to: aString - tryWords: self shouldDiffWords - prettyPrintedIn: - (self showingAnyKindOfPrettyDiffs ifTrue: [ theClass ]).! ! -!PseudoClassOrganizer methodsFor: 'testing' stamp: 'jmv 1/10/2020 15:29:44'! - isRemoved: aSelector - ^(self categoryOfElement: aSelector) = PseudoClass removedCategoryName! ! -!CodeFileBrowser methodsFor: 'edit pane' stamp: 'jmv 1/10/2020 15:41:21' prior: 16809253! - selectedMessage - "Answer a copy of the source code for the selected message selector." - - | class selector answer | - class _ self selectedClassOrMetaClass. - selector _ self selectedMessageName. - answer _ class sourceCodeAt: selector. - (self classOrMetaClassOrganizer isRemoved: selector) ifTrue: [ - ^ Text - string: answer - attribute: TextColor red ]. - Preferences browseWithPrettyPrint ifTrue: [ - answer _ class compilerClass new - format: answer in: class notifying: nil ]. - self showingAnyKindOfDiffs ifTrue: [ - answer _ self - methodDiffFor: answer - selector: self selectedMessageName ]. - ^ answer! ! -!CodeFileBrowser methodsFor: 'infoView' stamp: 'jmv 1/10/2020 15:38:07' prior: 50451707! - extraInfo - ^ (self - methodDiffFor: (self selectedClassOrMetaClass sourceCodeAt: self selectedMessageName) - selector: self selectedMessageName) - hasAnyAttribute - ifTrue: [' - **MODIFIED**'] - ifFalse: [' - identical']! ! -!CodeFileBrowser methodsFor: 'infoView' stamp: 'jmv 1/10/2020 15:33:10' prior: 50492974! - infoViewContents - | theClass selector useLabel | - useLabel _ self baseCodeSource baseLabel. - editSelection == #newClass ifTrue: [ - ^ caseCodeSource - ifNil: [ 'No file selected' ] - ifNotNil: [ caseCodeSource summary ]]. - self selectedClass ifNil: [ ^ '' ]. - theClass _ self pvtBaseClassOrMetaclass. - editSelection == #editClass ifTrue: [ - ^ theClass - ifNil: [ 'Class not in the ' , useLabel ] - ifNotNil: [ 'Class exists already in the ' , useLabel ]]. - editSelection == #editMessage ifFalse: [ ^ '' ]. - selector _ self selectedMessageName. - ^ (theClass notNil and: [ theClass includesSelector: selector ]) - ifTrue: [ 'Method already exists' , self extraInfo ] - ifFalse: [ - (self classOrMetaClassOrganizer isRemoved: selector) - ifTrue: [ 'Method not in the ' , useLabel ] - ifFalse: [ '**NEW** Method not in the ' , useLabel ]]! ! -!CodeFileBrowser methodsFor: 'message list' stamp: 'jmv 1/10/2020 15:30:55' prior: 50493560! - messageList - "Colorize messages as needed" - ^ super messageList collect: [ :eaListItem | | useAttr | - useAttr _ (self classOrMetaClassOrganizer isRemoved: eaListItem) - ifTrue: [ TextColor red ] - ifFalse: [ | baseSrc | - baseSrc _ self pvtBaseSelectedMessageSourceCodeFor: eaListItem. - baseSrc - ifNil: [ TextColor green ] - ifNotNil: [ | caseSrc | - caseSrc _ self pvtCaseSelectedMessageSourceCodeFor: eaListItem. - baseSrc = caseSrc ifFalse: [ TextColor blue ]]]. - useAttr - ifNil: [ eaListItem ] - ifNotNil: [ :attr | - Text - string: eaListItem - attribute: attr ]].! ! -!CodeFileBrowser methodsFor: 'private' stamp: 'jmv 1/10/2020 15:14:57' prior: 50493586! - pvtBaseSelectedMessageSourceCodeFor: selector - ^ self pvtBaseClassOrMetaclass ifNotNil: [ :theClass | - (theClass includesSelector: selector) ifTrue: [ theClass sourceCodeAt: selector ]].! ! - -CodeFileBrowser removeSelector: #methodDiffFor:class:selector:meta:! - -!methodRemoval: CodeFileBrowser #methodDiffFor:class:selector:meta: stamp: 'Install-4016-CodeFileBrowser-color-lists-fixes-JuanVuletich-2020Jan10-15h35m-jmv.1.cs.st 1/11/2020 17:57:47'! -methodDiffFor: aString class: aPseudoClass selector: selector meta: meta - "Answer the diff between the current copy of the given class/selector/meta for the string provided" - | theClass source | - theClass _ self pvtBaseClassOrMetaclass. - theClass ifNotNil: [ - meta ifTrue: [ theClass _ theClass class ]. - (theClass includesSelector: selector) ifTrue: [ source _ theClass sourceCodeAt: selector ]]. - ^ DifferenceFinder - displayPatchFrom: (source ifNil: ['']) - to: aString - tryWords: self shouldDiffWords - prettyPrintedIn: - (self showingAnyKindOfPrettyDiffs ifTrue: [ theClass ]).! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4016-CodeFileBrowser-color-lists-fixes-JuanVuletich-2020Jan10-15h35m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4012] on 10 January 2020 at 12:41:08 am'! -!Semaphore commentStamp: '' prior: 16905069! - I provide synchronized communication of a single bit of information (a "signal") between Processes. A signal is sent by sending the message signal and received by sending the message wait. If no signal has been sent when a wait message is sent, the sending Process will be suspended until a signal is sent. - -Beware that if a process calls 'aSemaphore critical: []' while already in a critical section for that semaphore, it will enter a deadlock. In some cases, a Mutex can be used instead. Refer to the Mutex class comment. - -More detail on the implementation as provided by Eliot Miranda: - -A semaphore is a queue (implemented as a linked list) and an excess signals count, which is a non-negative integer. On instance creation a new semaphore is empty and has a zero excess signals count. A semaphore created for mutual exclusion is empty and has an excess signals count of one. - -When a process waits on a semaphore, if the semaphore's excess signals count is non-zero, then the excess signal count is decremented, and the process proceeds. But if the semaphore has a zero excess signals count then the process is unscheduled and added to the end of the semaphore, after any other processes that are queued on the semaphore. - -When a semaphore is signaled, if it is not empty, the first process is removed from it and added to the runnable processes in the scheduler. If the semaphore is empty its excess signals count is incremented.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4017-Semaphore-class-comment-PhilBellalouna-2020Jan10-00h40m-pb.1.cs.st----! - -'From Cuis 5.0 [latest update: #3959] on 11 January 2020 at 5:38:50 pm'! -!BitBltCanvas methodsFor: 'drawing' stamp: 'jmv 1/11/2020 17:37:21' prior: 16786555! - line: pt1 to: pt2 width: wp color: c - | p1 p2 w | - (wp > 0 and: [ c isTransparent not ]) ifTrue: [ - p1 _ (currentTransformation transform: pt1) rounded. - p2 _ (currentTransformation transform: pt2) rounded. - w _ currentTransformation externalizeScalar: wp. - self setPaintColor: c. - port ifNil: [ self resetGrafPort ]. - port - width: w; - height: w; - drawFrom: p1 to: p2 ]! ! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 1/11/2020 17:38:10' prior: 50367322! - image: aForm at: aPoint sourceRect: sourceRect - "Draw a translucent image using the best available way of representing translucency. - Note: This will be fixed in the future." - | r p | - p _ (currentTransformation transform: aPoint) rounded. - r _ (self depth < 32 or: [ aForm mightBeTranslucent not ]) - ifTrue: [ - "Rule Form paint treats pixels with a value of zero as transparent" - Form paint ] - ifFalse: [ Form blend ]. - port ifNil: [ self resetGrafPort ]. - port colorMap: (aForm colormapIfNeededFor: form); fillColor: nil. - port image: aForm at: p sourceRect: sourceRect rule: r. - (self depth = 32 and: [ aForm depth < 32 ]) ifTrue: [ - "If we blit to 32bpp from one of smaller depth, - it will have zero in the alpha channel (until BitBlt is fixed!!) - This is the same workaround as in #asFormOfDepth:" - port sourceForm: nil. - port combinationRule: 40. "fixAlpha:with:" - port copyBits ]! ! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 1/11/2020 17:38:02' prior: 16786629! - stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor - "Flood this canvas with aColor wherever stencilForm has non-zero pixels" - | p | - p _ (currentTransformation transform: aPoint) rounded. - self setPaintColor: aColor. - port ifNil: [ self resetGrafPort ]. - port colorMap: stencilForm maskingMap. - port stencil: stencilForm - at: p - sourceRect: sourceRect! ! -!BitBltCanvas methodsFor: 'drawing-ovals' stamp: 'jmv 1/11/2020 17:38:14' prior: 50459932! - ellipseCenterX: mcx y: mcy rx: mrx ry: mry borderWidth: mbw borderColor: mbc fillColor: morphFillColor - - | displayRectangle doBorder doFill | - doBorder _ mbw > 0 and: [ mbc isTransparent not]. - doFill _ morphFillColor isTransparent not. - doBorder | doFill ifTrue: [ - displayRectangle _ (currentTransformation externalizeRectangle: (Rectangle center: mcx@mcy extent: mrx@mry * 2)) rounded. - "draw the border of the oval" - port ifNil: [ self resetGrafPort ]. - doBorder ifTrue: [ - self setPaintColor: mbc. - port frameOval: displayRectangle borderWidth: mbw]. - "fill the inside" - doFill ifTrue: [ - self setPaintColor: morphFillColor. - port fillOval: (displayRectangle insetBy: mbw) ]]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 1/11/2020 17:38:07' prior: 50459956! - frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor - | rect bw | - - r area = 0 ifTrue: [ ^self ]. - rect _ (currentTransformation externalizeRectangle: r) rounded. - bw _ currentTransformation externalizeScalar: borderWidth. - - "draw the border of the rectangle" - port ifNil: [ self resetGrafPort ]. - borderColor isTransparent ifFalse: [ - self setPaintColor: borderColor. - port frameRect: rect borderWidth: bw ]. - - "fill the inside" - fillColor isTransparent ifFalse: [ - self setPaintColor: fillColor. - port fillRect: (rect insetBy: bw) ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 1/11/2020 17:37:34' prior: 50459977! - frameRectangle: r borderWidth: borderWidth color: borderColor - " - Display getCanvas - frameRectangle: (10@10 extent: 300@200) - borderWidth: 20 - color: Color red. - Display forceToScreen - " - | rect bw | - (borderWidth > 0 and: [ borderColor isTransparent not ]) ifTrue: [ - rect _ (currentTransformation externalizeRectangle: r) rounded. - bw _ currentTransformation externalizeScalar: borderWidth. - self setPaintColor: borderColor. - port ifNil: [ self resetGrafPort ]. - port - frameRect: rect - borderWidth: bw ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 1/11/2020 17:37:55' prior: 50460032! - reverseRectangleBorder: r borderWidth: borderWidth - " - Display getCanvas - reverseRectangleBorder: (10@10 extent: 300@200) - borderWidth: 20. - Display forceToScreen - " - | rect | - rect _ (currentTransformation externalizeRectangle: r) rounded. - port ifNil: [ self resetGrafPort ]. - port - sourceForm: nil; - fillColor: `Color gray`; - combinationRule: Form reverse; - frameRect: rect borderWidth: borderWidth! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 1/11/2020 17:38:18' prior: 16787001! - drawString: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | p1 font | - "Don't waste any time if NOP" - lastIndex = 0 ifTrue: [ - ^nil ]. - - p1 _ (currentTransformation transform: aPoint) rounded. - port ifNil: [ self resetGrafPort ]. - port colorMap: nil. - font _ fontOrNil ifNil: [ AbstractFont default ]. - ^font on: port - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: aColor! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 1/11/2020 17:37:51' prior: 50460047! - fillRectangle: aRectangle tilingWith: aForm sourceRect: patternBox rule: aCombinationRule - - | displayRectangle additionalOffset clippedPort targetTopLeft clipOffset ex - targetBox savedMap top left | - - ex _ patternBox extent. - ex x = 0 ifTrue: [ ^self ]. - ex y = 0 ifTrue: [ ^self ]. - displayRectangle _ (currentTransformation externalizeRectangle: aRectangle) rounded. - - "this is a bit of a kludge to get the form to be aligned where I *think* it should be. - something better is needed, but not now" - - additionalOffset _ `0@0`. - port ifNil: [ self resetGrafPort ]. - clippedPort _ port clippedBy: displayRectangle. - targetTopLeft _ clippedPort clipRect topLeft truncateTo: ex. - clipOffset _ displayRectangle topLeft - targetTopLeft. - additionalOffset _ (clipOffset \\ ex) - ex. - - "do it iteratively" - targetBox _ clippedPort clipRect. - savedMap _ clippedPort colorMap. - clippedPort sourceForm: aForm; - fillColor: nil; - combinationRule: aCombinationRule; - sourceRect: patternBox; - colorMap: (aForm colormapIfNeededFor: clippedPort destForm). - top _ (targetBox top truncateTo: patternBox height) + additionalOffset y. - left _ (targetBox left truncateTo: patternBox width) + additionalOffset x. - - left to: (targetBox right - 1) by: patternBox width do: [:x | - top to: (targetBox bottom - 1) by: patternBox height do: [:y | - clippedPort destOrigin: x@y; copyBits]]. - clippedPort colorMap: savedMap! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 1/11/2020 17:37:40' prior: 16787100! - frameRectangle: rect borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor - " - rect and borderWidth are in form coordinates. No transformation is done. - Display getCanvas - frameRectangle: (10@10 extent: 300@200) - borderWidth: 20 - topLeftColor: Color green - bottomRightColor: Color red - Display getCanvas fillRectangle: (10@10 extent: 300@200) color: Color white - " - | w h | - - rect area = 0 ifTrue: [^ self]. - - self setPaintColor: topLeftColor. - - port ifNil: [ self resetGrafPort ]. - port frameRectTopLeft: rect borderWidth: borderWidth. - - borderWidth isNumber - ifTrue: [w _ h _ borderWidth] - ifFalse: [w _ borderWidth x. h _ borderWidth y]. - self setPaintColor: bottomRightColor. - port - frameRectRight: rect width: w; - frameRectBottom: rect height: h! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 1/11/2020 17:37:44' prior: 16787135! - setClipRect: aRectangle - "In form coordinates" - - super setClipRect: aRectangle. - port ifNil: [ self resetGrafPort ]. - port clipRect: aRectangle! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 1/11/2020 17:37:59' prior: 50388655! - setPaintColor: aColor - "Install a new color used for filling." - | paintColor | - paintColor _ aColor ifNil: [ `Color transparent` ]. - (paintColor is: #Color) ifFalse: [ - ^ self error: 'Cannot install color' ]. - - "Okay, so paintColor really *is* a color" - port ifNil: [ self resetGrafPort ]. - port sourceForm: nil. - (paintColor isOpaque or: [ self depth < 32]) ifTrue: [ - port fillColor: paintColor. - port combinationRule: Form paint. - ^ self ]. - - "BitBlt setup for alpha mapped transfer" - port fillColor: paintColor. - port combinationRule: Form blend! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4018-BitBltCanvasCleanup1-JuanVuletich-2020Jan11-17h37m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3959] on 11 January 2020 at 5:40:48 pm'! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph drawingMorphStack engine ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support' stamp: 'Install-4019-BitBltCanvasCleanup2-JuanVuletich-2020Jan11-17h38m-jmv.1.cs.st 1/11/2020 17:57:47'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph drawingMorphStack engine' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 1/11/2020 17:40:22' prior: 16787126! - resetGrafPort - "Private!! Create a new grafPort for a new copy." - - port _ GrafPort toForm: form. - "Init BitBlt so that the first call to the 'primitiveDisplayString' primitive will not fail" - port sourceX: 0; width: 0. - engine _ port! ! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph drawingMorphStack engine' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support' stamp: 'Install-4019-BitBltCanvasCleanup2-JuanVuletich-2020Jan11-17h38m-jmv.1.cs.st 1/11/2020 17:57:47'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph drawingMorphStack engine' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - -BitBltCanvas allInstancesDo: [ :canvas | canvas resetGrafPort ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4019-BitBltCanvasCleanup2-JuanVuletich-2020Jan11-17h38m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4017] on 11 January 2020 at 3:14:31 pm'! - -Smalltalk renameClassNamed: #GrafPort as: #BitBltCanvasEngine! - -!classRenamed: #GrafPort as: #BitBltCanvasEngine stamp: 'Install-4020-BitBltCanvasCleanup3-JuanVuletich-2020Jan11-15h08m-jmv.1.cs.st 1/11/2020 17:57:47'! -Smalltalk renameClassNamed: #GrafPort as: #BitBltCanvasEngine! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph drawingMorphStack engine ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support' stamp: 'Install-4020-BitBltCanvasCleanup3-JuanVuletich-2020Jan11-15h08m-jmv.1.cs.st 1/11/2020 17:57:47'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph drawingMorphStack engine' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! -!AbstractFont methodsFor: 'BitBltCanvas support' stamp: 'jmv 1/11/2020 15:11:46'! - onBitBltCanvasEngine: engine displayString: aString from: firstIndex to: lastIndex at: p color: color - "Answer last affected pixel position - Answer nil if nothing was done" - - | char fallbackFont x y answer | - fallbackFont _ (FontFamily - familyName: FontFamily defaultFamilyName - aroundPointSize: self pointSize*0.9) - emphasized: self emphasis. - x _ p x. - y _ p y. - firstIndex to: lastIndex do: [ :i | - char _ aString at: i. - answer _ engine displayString: char asString from: 1 to: 1 at: x@y strikeFont: fallbackFont color: color. - x _ x + (self widthOf: char) ]. - ^answer! ! -!StrikeFont methodsFor: 'BitBltCanvas support' stamp: 'jmv 1/11/2020 15:11:58'! - onBitBltCanvasEngine: engine displayString: aString from: firstIndex to: lastIndex at: p color: color - "Answer last affected pixel position. - Answer nil if nothing was done." - - ^engine - displayString: aString - from: firstIndex - to: lastIndex - at: p - strikeFont: self - color: color! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 1/11/2020 15:09:59'! - resetEngine - "Private!! Create a new BitBltCanvasEngine for a new copy." - - engine _ BitBltCanvasEngine toForm: form. - "Init BitBlt so that the first call to the 'primitiveDisplayString' primitive will not fail" - engine sourceX: 0; width: 0. - port _ engine! ! -!Form class methodsFor: 'instance creation' stamp: 'jmv 1/11/2020 15:08:13' prior: 50387131! -fakeSphereAt: aPoint diameter: diameter color: aColor - "Create a form which contains a round black dot." - | bb rect d p | - bb _ BitBltCanvasEngine toForm: Display. - bb fillColor: aColor. - bb combinationRule: Form blend. - rect _ aPoint extent: diameter. - bb fillOval: rect. - p _ (diameter * 2 // 5) asPoint + aPoint. - #(2 3 4 5 6 ) do: [ :i | - "simulate facade by circles of gray" - bb fillColor: `Color white alpha: 0.3`. - d _ i * diameter // 10. - rect _ Rectangle - center: p - extent: d. - bb fillOval: rect ]. - DisplayScreen screenUpdateRequired: nil. -" - Form fakeSphereAt: 50@50 diameter: 30 color: (Color red alpha: 0.5) -"! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 1/11/2020 15:12:09' prior: 50494299! - drawString: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | p1 font | - "Don't waste any time if NOP" - lastIndex = 0 ifTrue: [ - ^nil ]. - - p1 _ (currentTransformation transform: aPoint) rounded. - port colorMap: nil. - font _ fontOrNil ifNil: [ AbstractFont default ]. - ^font - onBitBltCanvasEngine: port - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: aColor! ! -!BitBltCanvas methodsFor: 'initialization' stamp: 'jmv 1/11/2020 15:10:03' prior: 16787190! - initializeWith: aForm origin: aPoint - - super initializeWith: aForm origin: aPoint. - self resetEngine! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 1/11/2020 15:10:07' prior: 50463566! - setForm: aForm - super setForm: aForm. - self resetEngine. - self newClipRect: nil.! ! - -BitBltCanvas removeSelector: #resetGrafPort! - -!methodRemoval: BitBltCanvas #resetGrafPort stamp: 'Install-4020-BitBltCanvasCleanup3-JuanVuletich-2020Jan11-15h08m-jmv.1.cs.st 1/11/2020 17:57:47'! -resetGrafPort - "Private!! Create a new grafPort for a new copy." - - port _ GrafPort toForm: form. - "Init BitBlt so that the first call to the 'primitiveDisplayString' primitive will not fail" - port sourceX: 0; width: 0. - engine _ port! - -StrikeFont removeSelector: #on:displayString:from:to:at:color:! - -!methodRemoval: StrikeFont #on:displayString:from:to:at:color: stamp: 'Install-4020-BitBltCanvasCleanup3-JuanVuletich-2020Jan11-15h08m-jmv.1.cs.st 1/11/2020 17:57:47'! -on: aGrafPort displayString: aString from: firstIndex to: lastIndex at: p color: color - "Answer last affected pixel position. - Answer nil if nothing was done." - - ^aGrafPort - displayString: aString - from: firstIndex - to: lastIndex - at: p - strikeFont: self - color: color! - -AbstractFont removeSelector: #on:displayString:from:to:at:color:! - -!methodRemoval: AbstractFont #on:displayString:from:to:at:color: stamp: 'Install-4020-BitBltCanvasCleanup3-JuanVuletich-2020Jan11-15h08m-jmv.1.cs.st 1/11/2020 17:57:47'! -on: aGrafPort displayString: aString from: firstIndex to: lastIndex at: p color: color - "Answer last affected pixel position - Answer nil if nothing was done" - - | char fallbackFont x y answer | - fallbackFont _ (FontFamily - familyName: FontFamily defaultFamilyName - aroundPointSize: self pointSize*0.9) - emphasized: self emphasis. - x _ p x. - y _ p y. - firstIndex to: lastIndex do: [ :i | - char _ aString at: i. - answer _ aGrafPort displayString: char asString from: 1 to: 1 at: x@y strikeFont: fallbackFont color: color. - x _ x + (self widthOf: char) ]. - ^answer! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -BitBltCanvas allInstancesDo: [ :canvas | canvas resetEngine ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4020-BitBltCanvasCleanup3-JuanVuletich-2020Jan11-15h08m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4018] on 11 January 2020 at 3:20:49 pm'! -!BitBltCanvas methodsFor: 'drawing' stamp: 'jmv 1/11/2020 15:17:59' prior: 50494154! - line: pt1 to: pt2 width: wp color: c - | p1 p2 w | - (wp > 0 and: [ c isTransparent not ]) ifTrue: [ - p1 _ (currentTransformation transform: pt1) rounded. - p2 _ (currentTransformation transform: pt2) rounded. - w _ currentTransformation externalizeScalar: wp. - self setPaintColor: c. - engine - width: w; - height: w; - drawFrom: p1 to: p2 ]! ! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 1/11/2020 15:19:31' prior: 50494169! - image: aForm at: aPoint sourceRect: sourceRect - "Draw a translucent image using the best available way of representing translucency. - Note: This will be fixed in the future." - | r p | - p _ (currentTransformation transform: aPoint) rounded. - r _ (self depth < 32 or: [ aForm mightBeTranslucent not ]) - ifTrue: [ - "Rule Form paint treats pixels with a value of zero as transparent" - Form paint ] - ifFalse: [ Form blend ]. - engine colorMap: (aForm colormapIfNeededFor: form); fillColor: nil. - engine image: aForm at: p sourceRect: sourceRect rule: r. - (self depth = 32 and: [ aForm depth < 32 ]) ifTrue: [ - "If we blit to 32bpp from one of smaller depth, - it will have zero in the alpha channel (until BitBlt is fixed!!) - This is the same workaround as in #asFormOfDepth:" - engine sourceForm: nil. - engine combinationRule: 40. "fixAlpha:with:" - engine copyBits ]! ! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 1/11/2020 15:19:17' prior: 50494201! - stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor - "Flood this canvas with aColor wherever stencilForm has non-zero pixels" - | p | - p _ (currentTransformation transform: aPoint) rounded. - self setPaintColor: aColor. - engine colorMap: stencilForm maskingMap. - engine stencil: stencilForm - at: p - sourceRect: sourceRect! ! -!BitBltCanvas methodsFor: 'drawing-ovals' stamp: 'jmv 1/11/2020 15:19:39' prior: 50494216! - ellipseCenterX: mcx y: mcy rx: mrx ry: mry borderWidth: mbw borderColor: mbc fillColor: morphFillColor - - | displayRectangle doBorder doFill | - doBorder _ mbw > 0 and: [ mbc isTransparent not]. - doFill _ morphFillColor isTransparent not. - doBorder | doFill ifTrue: [ - displayRectangle _ (currentTransformation externalizeRectangle: (Rectangle center: mcx@mcy extent: mrx@mry * 2)) rounded. - "draw the border of the oval" - doBorder ifTrue: [ - self setPaintColor: mbc. - engine frameOval: displayRectangle borderWidth: mbw]. - "fill the inside" - doFill ifTrue: [ - self setPaintColor: morphFillColor. - engine fillOval: (displayRectangle insetBy: mbw) ]]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 1/11/2020 15:19:21' prior: 50494241! - frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor - | rect bw | - - r area = 0 ifTrue: [ ^self ]. - rect _ (currentTransformation externalizeRectangle: r) rounded. - bw _ currentTransformation externalizeScalar: borderWidth. - - "draw the border of the rectangle" - borderColor isTransparent ifFalse: [ - self setPaintColor: borderColor. - engine frameRect: rect borderWidth: bw ]. - - "fill the inside" - fillColor isTransparent ifFalse: [ - self setPaintColor: fillColor. - engine fillRect: (rect insetBy: bw) ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 1/11/2020 15:18:04' prior: 50494263! - frameRectangle: r borderWidth: borderWidth color: borderColor - " - Display getCanvas - frameRectangle: (10@10 extent: 300@200) - borderWidth: 20 - color: Color red. - Display forceToScreen - " - | rect bw | - (borderWidth > 0 and: [ borderColor isTransparent not ]) ifTrue: [ - rect _ (currentTransformation externalizeRectangle: r) rounded. - bw _ currentTransformation externalizeScalar: borderWidth. - self setPaintColor: borderColor. - engine - frameRect: rect - borderWidth: bw ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 1/11/2020 15:19:00' prior: 50494283! - reverseRectangleBorder: r borderWidth: borderWidth - " - Display getCanvas - reverseRectangleBorder: (10@10 extent: 300@200) - borderWidth: 20. - Display forceToScreen - " - | rect | - rect _ (currentTransformation externalizeRectangle: r) rounded. - engine - sourceForm: nil; - fillColor: `Color gray`; - combinationRule: Form reverse; - frameRect: rect borderWidth: borderWidth! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 1/11/2020 15:19:46' prior: 50494597! - drawString: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | p1 font | - "Don't waste any time if NOP" - lastIndex = 0 ifTrue: [ - ^nil ]. - - p1 _ (currentTransformation transform: aPoint) rounded. - engine colorMap: nil. - font _ fontOrNil ifNil: [ AbstractFont default ]. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: aColor! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 1/11/2020 15:19:54' prior: 50494318! - fillRectangle: aRectangle tilingWith: aForm sourceRect: patternBox rule: aCombinationRule - - | displayRectangle additionalOffset clippedEngine targetTopLeft clipOffset ex - targetBox savedMap top left | - - ex _ patternBox extent. - ex x = 0 ifTrue: [ ^self ]. - ex y = 0 ifTrue: [ ^self ]. - displayRectangle _ (currentTransformation externalizeRectangle: aRectangle) rounded. - - "this is a bit of a kludge to get the form to be aligned where I *think* it should be. - something better is needed, but not now" - - additionalOffset _ `0@0`. - clippedEngine _ engine clippedBy: displayRectangle. - targetTopLeft _ clippedEngine clipRect topLeft truncateTo: ex. - clipOffset _ displayRectangle topLeft - targetTopLeft. - additionalOffset _ (clipOffset \\ ex) - ex. - - "do it iteratively" - targetBox _ clippedEngine clipRect. - savedMap _ clippedEngine colorMap. - clippedEngine sourceForm: aForm; - fillColor: nil; - combinationRule: aCombinationRule; - sourceRect: patternBox; - colorMap: (aForm colormapIfNeededFor: clippedEngine destForm). - top _ (targetBox top truncateTo: patternBox height) + additionalOffset y. - left _ (targetBox left truncateTo: patternBox width) + additionalOffset x. - - left to: (targetBox right - 1) by: patternBox width do: [:x | - top to: (targetBox bottom - 1) by: patternBox height do: [:y | - clippedEngine destOrigin: x@y; copyBits]]. - clippedEngine colorMap: savedMap! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 1/11/2020 15:18:12' prior: 50494365! - frameRectangle: rect borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor - " - rect and borderWidth are in form coordinates. No transformation is done. - Display getCanvas - frameRectangle: (10@10 extent: 300@200) - borderWidth: 20 - topLeftColor: Color green - bottomRightColor: Color red - Display getCanvas fillRectangle: (10@10 extent: 300@200) color: Color white - " - | w h | - - rect area = 0 ifTrue: [^ self]. - - self setPaintColor: topLeftColor. - - engine frameRectTopLeft: rect borderWidth: borderWidth. - - borderWidth isNumber - ifTrue: [w _ h _ borderWidth] - ifFalse: [w _ borderWidth x. h _ borderWidth y]. - self setPaintColor: bottomRightColor. - engine - frameRectRight: rect width: w; - frameRectBottom: rect height: h! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 1/11/2020 15:18:17' prior: 50494393! - setClipRect: aRectangle - "In form coordinates" - - super setClipRect: aRectangle. - engine clipRect: aRectangle! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 1/11/2020 15:19:11' prior: 50494401! - setPaintColor: aColor - "Install a new color used for filling." - | paintColor | - paintColor _ aColor ifNil: [ `Color transparent` ]. - (paintColor is: #Color) ifFalse: [ - ^ self error: 'Cannot install color' ]. - - "Okay, so paintColor really *is* a color" - engine sourceForm: nil. - (paintColor isOpaque or: [ self depth < 32]) ifTrue: [ - engine fillColor: paintColor. - engine combinationRule: Form paint. - ^ self ]. - - "BitBlt setup for alpha mapped transfer" - engine fillColor: paintColor. - engine combinationRule: Form blend! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4021-BitBltCanvasCleanup4-JuanVuletich-2020Jan11-15h17m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4019] on 11 January 2020 at 3:22:11 pm'! - -MorphicCanvas subclass: #BitBltCanvas - instanceVariableNames: 'port ' - classVariableNames: 'AccessProtect AuxBlitter AuxForm CachedForms ' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #BitBltCanvas category: #'Morphic-Support' stamp: 'Install-4022-BitBltCanvasCleanup5-JuanVuletich-2020Jan11-15h21m-jmv.1.cs.st 1/11/2020 17:57:47'! -MorphicCanvas subclass: #BitBltCanvas - instanceVariableNames: 'port' - classVariableNames: 'AccessProtect AuxBlitter AuxForm CachedForms' - poolDictionaries: '' - category: 'Morphic-Support'! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 1/11/2020 15:21:45' prior: 50494563! - resetEngine - "Private!! Create a new BitBltCanvasEngine for a new copy." - - engine _ BitBltCanvasEngine toForm: form. - "Init BitBlt so that the first call to the 'primitiveDisplayString' primitive will not fail" - engine sourceX: 0; width: 0! ! - -MorphicCanvas subclass: #BitBltCanvas - instanceVariableNames: '' - classVariableNames: 'AccessProtect AuxBlitter AuxForm CachedForms' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #BitBltCanvas category: #'Morphic-Support' stamp: 'Install-4022-BitBltCanvasCleanup5-JuanVuletich-2020Jan11-15h21m-jmv.1.cs.st 1/11/2020 17:57:47'! -MorphicCanvas subclass: #BitBltCanvas - instanceVariableNames: '' - classVariableNames: 'AccessProtect AuxBlitter AuxForm CachedForms' - poolDictionaries: '' - category: 'Morphic-Support'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4022-BitBltCanvasCleanup5-JuanVuletich-2020Jan11-15h21m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4020] on 11 January 2020 at 3:33:30 pm'! -!AbstractFont methodsFor: 'BitBltCanvas support' stamp: 'jmv 1/11/2020 15:32:19' prior: 50494530! - onBitBltCanvasEngine: engine displayString: aString from: firstIndex to: lastIndex at: p color: color - "Answer last affected pixel position - Answer nil if nothing was done" - - self subclassResponsibility! ! -!StrikeFont methodsFor: 'BitBltCanvas support' stamp: 'jmv 1/11/2020 15:32:02' prior: 50494551! - onBitBltCanvasEngine: engine displayString: aString from: firstIndex to: lastIndex at: p color: color - "Answer last affected pixel position. - Answer nil if nothing was done." - - ^ engine - displayString: aString - from: firstIndex - to: lastIndex - at: p - strikeFont: self - color: color! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4023-BitBltCanvasCleanup6-JuanVuletich-2020Jan11-15h32m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4021] on 11 January 2020 at 3:49:54 pm'! -!PasteUpMorph methodsFor: 'defaul desktop' stamp: 'jmv 1/11/2020 15:47:27' prior: 50473043! - recreateDefaultDesktop - | editor | - self whenUIinSafeState: [ - self hideTaskbar. - (submorphs - select: [ :ea | ea class == SystemWindow or: [ea class == TranscriptWindow]]) - do: [ :ea | ea delete ]. - TranscriptWindow openTranscript - morphPosition: 5 @ 290; - morphExtent: 990 @ 400. - editor _ TextEditor openTextEditor - morphPosition: 456 @ 10; - morphExtent: 900 @ 680. - editor setLabel: 'About Cuis'. - editor model actualContents: Utilities defaultTextEditorContents. - self showTaskbar. - ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4024-RecreateDefaultDesktop-fix-JuanVuletich-2020Jan11-15h49m-jmv.1.cs.st----! - -----SNAPSHOT----(11 January 2020 17:57:52) Cuis5.0-4024-32.image priorSource: 4827872! - -----QUIT----(11 January 2020 17:58:14) Cuis5.0-4024-32.image priorSource: 5229447! - -----STARTUP---- (1 April 2020 17:55:56) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4024-32.image! - - -'From Cuis 5.0 [latest update: #4024] on 12 January 2020 at 9:41:15 pm'! - -"Change Set: 4025-CuisCore-AuthorName-2020Jan12-21h12m -Date: 12 January 2020 -Author: Nahuel Garbezza - -Ability to extract quoted expressions in the extract method refactoring"! -!ParseNode methodsFor: 'source ranges' stamp: 'RNG 1/12/2020 21:20:28'! - expandIfEnclosed: sourceRange on: sourceCode - "takes a source range and a source code and if the source range represents an - expression that can be expanded and still is valid, it returns the source range - 'grown'. Examples: (*3 + 4*) to *(3 + 4)*; `*3 + 4*` to *`3 + 4`*" - - | firstChar lastChar | - firstChar _ sourceCode at: sourceRange first - 1 ifAbsent: [ nil ]. - lastChar _ sourceCode at: sourceRange last + 1 ifAbsent: [ nil ]. - ^ ((firstChar = $( and: [ lastChar = $) ]) - or: [ firstChar = $` and: [ lastChar = $` ] ]) - ifTrue: [ sourceRange first - 1 to: sourceRange last + 1 ] - ifFalse: [ sourceRange ]! ! -!ParseNode methodsFor: 'source ranges' stamp: 'RNG 1/12/2020 21:12:37' prior: 50488530! - expandRanges: sourceRanges basedOn: allSourceRanges using: sourceCode - - ^ (self consolidateAsCollection: sourceRanges) - collect: [ :sourceRange | self expandIfEnclosed: sourceRange on: sourceCode ]! ! -!MessageNode methodsFor: 'source ranges' stamp: 'RNG 1/12/2020 21:12:37' prior: 50488618! - expandRanges: aSourceRange basedOn: sourceRanges using: sourceCode - - | receiverExpandedRanges expandedRangeWithReceiver | - receiverExpandedRanges _ self isCascade - ifTrue: [ self flag: #RNG . aSourceRange ] "fix source ranges for cascade messages" - ifFalse: [ receiver expandRanges: (self receiverSourceRangesFrom: sourceRanges) basedOn: sourceRanges using: sourceCode ]. - expandedRangeWithReceiver _ self - expandRange: (aSourceRange isInterval ifTrue: [ aSourceRange ] ifFalse: [ aSourceRange first ]) - basedOn: receiverExpandedRanges. - ^ self consolidateAsCollection: (self expandIfEnclosed: expandedRangeWithReceiver on: sourceCode)! ! - -ParseNode removeSelector: #expandIfEnclosedWithParentheses:on:! - -!methodRemoval: ParseNode #expandIfEnclosedWithParentheses:on: stamp: 'Install-4025-CuisCore-NahuelGarbezza-2020Jan12-21h12m-RNG.1.cs.st 4/1/2020 17:56:03'! -expandIfEnclosedWithParentheses: sourceRange on: sourceCode - - | startsWithParen endsWithParen | - self flag: #RNG. "take into account other cases: spaces in middle, multiple parenthesis" - startsWithParen _ (sourceCode at: sourceRange first - 1 ifAbsent: [nil]) = $(. - endsWithParen _ (sourceCode at: sourceRange last + 1 ifAbsent: [nil]) = $). - ^ startsWithParen & endsWithParen - ifTrue: [ sourceRange first - 1 to: sourceRange last + 1 ] - ifFalse: [ sourceRange ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4025-CuisCore-NahuelGarbezza-2020Jan12-21h12m-RNG.1.cs.st----! - -'From Cuis 5.0 [latest update: #4024] on 14 January 2020 at 9:33:11 am'! -!MorphicCanvas methodsFor: 'accessing' stamp: 'jmv 1/14/2020 09:32:14' prior: 16877371! - clipRect - "Return the currently active clipping rectangle" - "In targetForm coordinates" - - ^ clipLeft@clipTop corner: clipRight@clipBottom+1! ! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 1/14/2020 09:32:17' prior: 16877358! - setClipRect: aRectangle - "by convention, aRectangle includes left and top but does not include right and bottom. - We do draw clipRight and clipBottom but not beyond. - " - "In targetForm coordinates" - - clipLeft _ aRectangle left. - clipTop _ aRectangle top. - clipRight _ aRectangle right - 1. - clipBottom _ aRectangle bottom - 1! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 1/14/2020 09:32:06' prior: 50494904! - frameRectangle: rect borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor - " - rect and borderWidth are in targetForm coordinates. No transformation is done. - Display getCanvas - frameRectangle: (10@10 extent: 300@200) - borderWidth: 20 - topLeftColor: Color green - bottomRightColor: Color red - Display getCanvas fillRectangle: (10@10 extent: 300@200) color: Color white - " - | w h | - - rect area = 0 ifTrue: [^ self]. - - self setPaintColor: topLeftColor. - - engine frameRectTopLeft: rect borderWidth: borderWidth. - - borderWidth isNumber - ifTrue: [w _ h _ borderWidth] - ifFalse: [w _ borderWidth x. h _ borderWidth y]. - self setPaintColor: bottomRightColor. - engine - frameRectRight: rect width: w; - frameRectBottom: rect height: h! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 1/14/2020 09:32:10' prior: 50494931! - setClipRect: aRectangle - "In targetForm coordinates" - - super setClipRect: aRectangle. - engine clipRect: aRectangle! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 1/14/2020 09:32:00' prior: 50463586! - clippingRectForCurrentMorph - "In targetForm coordinates" - - ^currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds! ! -!BitBltCanvas methodsFor: 'testing' stamp: 'jmv 1/14/2020 09:30:46' prior: 50463593! - isCurrentMorphVisible - - | aRectangle | - currentMorph visible ifFalse: [ ^false ]. - "#clippingRectForCurrentMorph is valid even before drawing currentMorph, only in BitBltCanvas!!" - aRectangle _ self clippingRectForCurrentMorph. - aRectangle right < clipLeft ifTrue: [^ false]. - aRectangle left > (clipRight+1) ifTrue: [^ false]. - aRectangle bottom < clipTop ifTrue: [^ false]. - aRectangle top > (clipBottom+1) ifTrue: [^ false]. - ^ true -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4026-CommentsTweaks-JuanVuletich-2020Jan14-09h19m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4026] on 17 January 2020 at 10:23:32 am'! -!BlockClosure methodsFor: 'evaluating' stamp: 'jmv 1/17/2020 10:22:55' prior: 50371850! - bench - "See how many times I can value in 5 seconds. I'll answer a meaningful description. - [ Float pi printString ] bench print. - [ 80000 factorial printString ] bench print. - " - - | secondsPerRun startTime endTime count run | - count _ 0. - run _ true. - [ (Delay forSeconds: 5) wait. run _ false ] forkAt: Processor timingPriority - 1. - startTime _ Time localMillisecondClock. - [ run ] whileTrue: [ self value. count _ count + 1 ]. - endTime _ Time localMillisecondClock. - secondsPerRun _ (endTime - startTime) / (count * 1000). - secondsPerRun >= 1 - ifTrue: [ - secondsPerRun withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - ^String streamContents: [ :strm | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixSymbol; - nextPutAll: ' seconds per run']] - ] - ifFalse: [ - 1.0 / secondsPerRun withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - ^String streamContents: [ :strm | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixSymbol; - nextPutAll: ' runs per second' ]] - ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4027-bench-fix-JuanVuletich-2020Jan17-10h14m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4026] on 18 January 2020 at 2:28:39 pm'! -!BitBltCanvasEngine methodsFor: 'private' stamp: 'jmv 1/18/2020 14:26:21' prior: 50387490! - setRuleAndMapFor: sourceDepth foregroundColor: foregroundColor - - | targetColor destDepth | - destDepth _ destForm depth. - halftoneForm _ nil. "Don't use fillColor. Use a more powerful ColorMap" - - sourceDepth = 1 ifTrue: [ - self combinationRule: Form paint. - "Set up color map for a different source depth (color font)" - "Uses caching for reasonable efficiency" - colorMap _ self cachedFontColormapFrom1BitTo: destDepth. - colorMap at: 1 put: (destForm pixelValueFor: `Color transparent`). - colorMap at: 2 put: (destForm pixelValueFor: foregroundColor) ] - - ifFalse: [ - "Enable subpixel rendering if requested, but never for translucent text: - This technique always draws opaque text. This could be added, by using an extra colormap for the rgbMul phase... - So far, no need arised for doing so." - (sourceDepth > 8 and: [ - Preferences subPixelRenderFonts and: [ foregroundColor = `Color black` or: [ - Preferences subPixelRenderColorFonts and: [ foregroundColor isOpaque ]]]]) ifTrue: [ - destDepth > 8 ifTrue: [ - "rgbMul is equivalent to component alpha blend if text is black (only faster, hehe)" - self combinationRule: 37. "rgbMul" - colorMap _ (foregroundColor ~= `Color black` or: [ - destDepth = 32 and: [ destForm ~~ Display or: [Preferences properDisplayAlphaForFonts] ]]) ifTrue: [ - "rgbMul / rgbAdd IS component alpha blend for any color of text (neat trick, eh!!)" - "This colorMap is to be used on the second pass with rule 20 (rgbAdd) - See #displayString:from:to:at:strikeFont:color:" - "Note: In 32bpp, if we want the correct alpha in the result, we need the second pass, as the destination could have transparent pixels, - and we need to add to the alpha channel" - self colorConvertingMap: foregroundColor from: sourceDepth to: destDepth keepSubPixelAA: true]] - ifFalse: [ - self combinationRule: 25. "Paint" - targetColor _ foregroundColor = `Color black` ifFalse: [ foregroundColor ]. - colorMap _ self colorConvertingMap: targetColor from: sourceDepth to: destDepth keepSubPixelAA: true]] - ifFalse: [ - "Do not use rule 34 for 16bpp display." - self combinationRule: (destDepth = 32 ifTrue: [34 "alphaBlendScaled"] ifFalse: [25 "Paint"]). - colorMap _ self colorConvertingMap: foregroundColor from: sourceDepth to: destDepth keepSubPixelAA: false]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4028-BitBltCommentFix-JuanVuletich-2020Jan18-14h15m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4026] on 19 January 2020 at 9:41:37 am'! - -StrikeFont removeSelector: #setGlyphs:! - -!methodRemoval: StrikeFont #setGlyphs: stamp: 'Install-4029-setGlyphs-removal-JuanVuletich-2020Jan19-09h22m-jmv.1.cs.st 4/1/2020 17:56:03'! -setGlyphs: newGlyphs - "Replace the glyphs form. Used to make a synthetic bold or italic font quickly." - - glyphs _ newGlyphs! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4029-setGlyphs-removal-JuanVuletich-2020Jan19-09h22m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4029] on 19 January 2020 at 11:57:15 pm'! - -"Change Set: 4030-CuisCore-AuthorName-2020Jan19-23h10m -Date: 19 January 2020 -Author: Nahuel Garbezza - -Small improvements to the inspector contextual menu"! -!InspectorWindow methodsFor: 'menu building' stamp: 'RNG 1/19/2020 23:53:02'! - addCollectionSpecificMenuOptionsTo: aMenu - - | object | - object _ model object. - (object is: #Dictionary) ifTrue: [ - aMenu addItemsFromDictionaries: self menuOptionsForDictionary ] - ifFalse: [ (object is: #Set) ifTrue: [ - aMenu addItemsFromDictionaries: self menuOptionsForSet ]]! ! -!InspectorWindow methodsFor: 'menu building' stamp: 'RNG 1/19/2020 23:27:18'! - basicMenuOptions - - ^ `{ - { - #label -> 'inspect (i)'. - #selector -> #inspectSelection. - #icon -> #inspectIcon - } asDictionary. - { - #label -> 'explore (I)'. - #selector -> #exploreSelection. - #icon -> #exploreIcon - } asDictionary. - { - #label -> 'copy to clipboard (c)'. - #selector -> #copySelectionToClipboard. - #icon -> #copyIcon - } asDictionary. - { - #label -> 'basic inspect'. - #selector -> #inspectBasic. - #icon -> #inspectIcon - } asDictionary. - { - #label -> 'references finder'. - #selector -> #openReferencesFinder. - #icon -> #exploreIcon - } asDictionary. - { - #label -> 'weight explorer'. - #selector -> #openWeightExplorer. - #icon -> #exploreIcon - } asDictionary. - }`! ! -!InspectorWindow methodsFor: 'menu building' stamp: 'RNG 1/19/2020 23:24:15'! - menuOptionsForBrowsing - - ^ `{ - nil. - { - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - }`! ! -!InspectorWindow methodsFor: 'menu building' stamp: 'RNG 1/19/2020 23:25:40'! - menuOptionsForDictionary - - ^ `{ - nil. - { - #label -> 'senders of this key'. - #selector -> #sendersOfSelectedKey. - #icon -> #mailForwardIcon - } asDictionary. - { - #label -> 'add key'. - #selector -> #addEntry. - #icon -> #listAddIcon - } asDictionary. - { - #label -> 'rename key'. - #selector -> #renameEntry. - #icon -> #saveAsIcon - } asDictionary. - { - #label -> 'remove'. - #object -> #model. - #selector -> #removeSelection. - #icon -> #listRemoveIcon - } asDictionary. - }`! ! -!InspectorWindow methodsFor: 'menu building' stamp: 'RNG 1/19/2020 23:25:27'! - menuOptionsForSet - - ^ `{ - nil. - { - #label -> 'remove'. - #object -> #model. - #selector -> #removeSelection. - #icon -> #listRemoveIcon - } asDictionary. - }`! ! -!InspectorWindow methodsFor: 'menu building' stamp: 'RNG 1/19/2020 23:52:42' prior: 50399283! - fieldListMenu - "Arm the supplied menu with items for the field-list of the receiver" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addItemsFromDictionaries: self basicMenuOptions. - self addCollectionSpecificMenuOptionsTo: aMenu. - aMenu addItemsFromDictionaries: self menuOptionsForBrowsing. - ^ aMenu! ! -!InspectorWindow methodsFor: 'menu commands' stamp: 'RNG 1/19/2020 23:11:27' prior: 16857378! - sendersOfSelectedKey - | key | - key _ model selectedKey. - key isString ifFalse: [ ^self ]. - Smalltalk browseAllCallsOn: key! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4030-InspectorImprovement-NahuelGarbezza-2020Jan19-23h10m-RNG.1.cs.st----! - -'From Cuis 5.0 [latest update: #4029] on 19 January 2020 at 2:37:19 pm'! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 1/19/2020 14:06:22' prior: 16914792! - useLeftArrow - "Use left arrow glyph instead of underscore, and up arrow glyph instead of caret" - self characterToGlyphMap. - characterToGlyphMap at: 96 put: 28. - characterToGlyphMap at: 95 put: 30! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 1/19/2020 14:07:34' prior: 16914798! - useRightArrow - "Use right arrow glyph instead of underscore, and up arrow glyph instead of caret" - self characterToGlyphMap. - characterToGlyphMap at: 96 put: 29. - characterToGlyphMap at: 95 put: 30! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 1/19/2020 14:06:46' prior: 16914809! - useUnderscore - "Sets underscore and caret glyphs for chars 95 and 94. - ASCII standard glyphs" - self characterToGlyphMap. - characterToGlyphMap at: 96 put: 95. - characterToGlyphMap at: 95 put: 94! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4031-StrikeFont-comments-JuanVuletich-2020Jan19-14h06m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4030] on 26 January 2020 at 9:04:24 am'! -!Character class methodsFor: 'class initialization' stamp: 'jmv 1/26/2020 08:29:15' prior: 50463755! - initializeUnicodeCodePoints - " - Character initializeUnicodeCodePoints - String streamContents: [ :strm | 28 to: 255 do: [ :i | strm nextPut: (Character numericValue: i) ]] - " - - "Initialize the table of Unicode code points" - UnicodeCodePoints _ Array new: 256. - 0 to: 255 do: [ :code | - UnicodeCodePoints at: code + 1 put: code ]. - - "Arrows" - UnicodeCodePoints at: 28+1 put: 8592. "left arrow" - UnicodeCodePoints at: 29+1 put: 8594. "right arrow" - UnicodeCodePoints at: 30+1 put: 8593. "up arrow" - UnicodeCodePoints at: 31+1 put: 8595. "down arrow" - - "The following codes are different in ISO 8859-15 from those in ISO 8859-1, - so the character code is not equal to the Unicode code point" - UnicodeCodePoints at: 16rA4+1 put: 16r20AC. "euro sign" - UnicodeCodePoints at: 16rA6+1 put: 16r160. "latin capital letter S with caron" - UnicodeCodePoints at: 16rA8+1 put: 16r161. "latin small letter s with caron" - UnicodeCodePoints at: 16rB4+1 put: 16r17D. "latin capital letter Z with caron" - UnicodeCodePoints at: 16rB8+1 put: 16r17E. "latin small letter z with caron" - UnicodeCodePoints at: 16rBC+1 put: 16r152. "latin capital ligature OE" - UnicodeCodePoints at: 16rBD+1 put: 16r153. "latin small ligature oe" - UnicodeCodePoints at: 16rBE+1 put: 16r178. "latin capital letter Y with diaeresis" - - UnicodeCodePoints at: 16r80+1 put: 16r2205. "EMPTY SET" - UnicodeCodePoints at: 16r81+1 put: 16r221E. "INFINITY" - UnicodeCodePoints at: 16r82+1 put: 16r2135. "ALEF SYMBOL" - UnicodeCodePoints at: 16r83+1 put: 16r03C0. "pi" - UnicodeCodePoints at: 16r84+1 put: 16r03B5. "epsilon" - UnicodeCodePoints at: 16r85+1 put: 16r03B6. "zeta" - UnicodeCodePoints at: 16r86+1 put: 16r0394. "Delta" - UnicodeCodePoints at: 16r87+1 put: 16r03A9. "Omega" - UnicodeCodePoints at: 16r88+1 put: 16r2102. "DOUBLE-STRUCK CAPITAL C" - UnicodeCodePoints at: 16r89+1 put: 16r210D. "DOUBLE-STRUCK CAPITAL H" - UnicodeCodePoints at: 16r8A+1 put: 16r2115. "DOUBLE-STRUCK CAPITAL N" - UnicodeCodePoints at: 16r8B+1 put: 16r2119. "DOUBLE-STRUCK CAPITAL P" - UnicodeCodePoints at: 16r8C+1 put: 16r211A. "DOUBLE-STRUCK CAPITAL Q" - UnicodeCodePoints at: 16r8D+1 put: 16r211D. "DOUBLE-STRUCK CAPITAL R" - UnicodeCodePoints at: 16r8E+1 put: 16r2124. "DOUBLE-STRUCK CAPITAL Z" - UnicodeCodePoints at: 16r8F+1 put: 16r0046. "DOUBLE-STRUCK CAPITAL F" "should be 1D53D, index out of bounds" - UnicodeCodePoints at: 16r90+1 put: 16r2295. "OPLUS" - UnicodeCodePoints at: 16r91+1 put: 16r2297. "OTIMES" - UnicodeCodePoints at: 16r92+1 put: 16r2299. "ODOT" - UnicodeCodePoints at: 16r93+1 put: 16r2296. "OMINUS" - UnicodeCodePoints at: 16r94+1 put: 16r2217. "ASTERISK OPERATOR" - UnicodeCodePoints at: 16r95+1 put: 16r2218. "RING OPERATOR (circ)" - UnicodeCodePoints at: 16r96+1 put: 16r2219. "BULLET OPERATOR (filled circ)" - UnicodeCodePoints at: 16r97+1 put: 16r22C5. "DOT OPERATOR" "(already at B7)" - UnicodeCodePoints at: 16r98+1 put: 16r22C6. "STAR OPERATOR" - UnicodeCodePoints at: 16r99+1 put: 16r21A0. "SURJECTIVE ARROW" - UnicodeCodePoints at: 16r9A+1 put: 16r21A3. "INJECTIVE ARROW" - UnicodeCodePoints at: 16r9B+1 put: 16r2194. "BIJECTIVE ARROW" - UnicodeCodePoints at: 16r9C+1 put: 16r21AA. "INCLUSION ARROW" - UnicodeCodePoints at: 16r9D+1 put: 16r21A6. "MAPPING ARROW" - UnicodeCodePoints at: 16r9E+1 put: 16r2202. "PARTIAL DIFFERENTIAL" - UnicodeCodePoints at: 16r9F+1 put: 16r221A. "SQUARE ROOT" -! ! - -Character removeSelector: #codePointOfGlyphToUse! - -!methodRemoval: Character #codePointOfGlyphToUse stamp: 'Install-4032-Character-cleanup-JuanVuletich-2020Jan26-08h29m-jmv.1.cs.st 4/1/2020 17:56:03'! -codePointOfGlyphToUse - " - For certain ASCII characters, we prefer a non ASCII Unicode glyph if available (i.e. with TrueType fonts). - $* codePoint hex - $* codePointOfGlyphToUse hex - " - self = $- ifTrue: [ ^16r2212 ]. "WIDE MINUS" - self = $* ifTrue: [ ^16r2217 ]. "CENTERED ASTERISK" - ^ self codePoint! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4032-Character-cleanup-JuanVuletich-2020Jan26-08h29m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4032] on 28 January 2020 at 9:56:35 am'! -!InnerListMorph methodsFor: 'drawing' stamp: 'jmv 1/28/2020 09:55:26' prior: 50492626! - draw: item atRow: row on: canvas - "display the given item at row row" - | f c | - (item is: #Text) - ifTrue: [ - f _ font emphasized: (item emphasisAt: 1). - c _ (item colorAt: 1) ifNil: [Theme current text]] - ifFalse: [ - f _ font. - c _ Theme current text]. - canvas - drawString: item - at: 0 @ (self drawYForRow: row) - font: f - color: c! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4033-FixBugIntroducedIn4011-JuanVuletich-2020Jan28-09h55m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4030] on 25 January 2020 at 6:29:18 pm'! -!MessageNames commentStamp: '' prior: 0! -Search for message names. There are several special characters that alter how searchString is interpreted: -$; - separate several search criteria (like 'editorClassFor:;contentsSelection') -$* - matches a string pattern rather than just a simple string match (i.e. 'set*text') -$# - matches a single character (for example, 'ini###lize'! -!MessageNamesWindow methodsFor: 'GUI building' stamp: 'pb 1/25/2020 18:22:25' prior: 50455667! - buildMorphicWindow - "Answer a morphic window with the given initial search string, nil if none" - "MessageNames openMessageNames" - | selectorListView firstRow searchButton secondRow | - textMorph _ (TextModelMorph - textProvider: model - textGetter: #searchString - textSetter: #searchString: - selectionGetter: #contentsSelection) - setBalloonText: 'See MessageNames class comment for search string options'; - emptyTextDisplayMessage: 'Type here, then hit Search'. - textMorph askBeforeDiscardingEdits: false. - textMorph acceptOnCR: true. - textMorph hideScrollBarsIndefinitely. - searchButton _ PluggableButtonMorph new - model: textMorph textMorph; - label: 'Search'; - action: #acceptContents. - searchButton setBalloonText: 'Type some letters into the pane at right, and then press this Search button (or hit RETURN) and all method selectors that match what you typed will appear in the list pane below. Click on any one of them, and all the implementors of that selector will be shown in the right-hand pane, and you can view and edit their code without leaving this tool.'. - firstRow _ LayoutMorph newRow. - firstRow color: self windowColor. - firstRow - doAdoptWidgetsColor; - - addMorph: searchButton - proportionalWidth: 0.25; - - addMorph: textMorph - proportionalWidth: 0.75. - selectorListView _ PluggableListMorph - model: model - listGetter: #selectorList - indexGetter: #selectorListIndex - indexSetter: #selectorListIndex: - mainView: self - menuGetter: #selectorListMenu - keystrokeAction: #selectorListKey:from:. - secondRow _ LayoutMorph newRow. - secondRow - - addMorph: selectorListView - proportionalWidth: 0.5; - - addAdjusterAndMorph: self buildMorphicMessageList - proportionalWidth: 0.5. - self layoutMorph - - addMorph: firstRow - fixedHeight: self defaultButtonPaneHeight + 4; - - addAdjusterAndMorph: secondRow - proportionalHeight: 0.5; - - addAdjusterAndMorph: self buildLowerPanes - proportionalHeight: 0.5. - model changed: #editSelection.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4034-MessageNames-searchString-documentation-PhilBellalouna-2020Jan25-18h00m-pb.1.cs.st----! - -'From Cuis 5.0 [latest update: #4034] on 17 February 2020 at 3:33:24 pm'! -!Feature class methodsFor: 'convenience' stamp: 'jmv 2/17/2020 15:27:42'! - require: featureName version: integerVersion revision: integerRevision - " - Feature require: 'Sound' version: 1 revision: 0 - Feature require: 'Tests' version: 1 revision: 0 - " - (FeatureRequirement name: featureName version: integerVersion revision: integerRevision) require! ! -!Feature class methodsFor: 'convenience' stamp: 'jmv 2/17/2020 15:27:34' prior: 16840628! - require: featureName version: versionNumber - " - Feature require: 'StyledTextInstaller' version: 1 - Feature require: 'Sound' version: 1 - Feature require: 'Tests' version: 1 - " - (FeatureRequirement name: featureName version: versionNumber) require! ! -!FeatureRequirement methodsFor: 'printing' stamp: 'jmv 2/17/2020 15:26:20' prior: 16840869! - printDetailsOn: aStream - aStream - nextPutAll: name; - nextPut: $ . - minVersion - ifNil: [ - aStream nextPutAll: '*.*)'. - ^self ] - ifNotNil: [ minVersion printOn: aStream ]. - aStream nextPut: $.. - minRevision - ifNil: [ aStream nextPut: $* ] - ifNotNil: [ minRevision printOn: aStream ]. - (minRevision notNil or: [ maxVersion isNil or: [maxVersion > minVersion ]]) ifTrue: [ - aStream nextPutAll: ' to '. - maxVersion - ifNil: [ aStream nextPut: $* ] - ifNotNil: [ maxVersion printOn: aStream ]. - maxVersion = minVersion - ifTrue: [ aStream nextPutAll: '.999' ] - ifFalse: [ aStream nextPutAll: '.*' ] - ]! ! -!FeatureRequirement class methodsFor: 'instance creation' stamp: 'jmv 2/17/2020 15:32:03' prior: 16840985! - name: aSymbol minVersion: minVersionOrNil minRevision: minRevisionOrNil maxVersion: maxVersionOrNil - - | newInst | - (minVersionOrNil isNil or: [ minVersionOrNil isInteger ]) ifFalse: [ - self error: 'Version numbers must be Integer numbers. Specify also Revision number if needed.' ]. - (minRevisionOrNil isNil or: [ minRevisionOrNil isInteger ]) ifFalse: [ - self error: 'Revision numbers must be Integer numbers.' ]. - (maxVersionOrNil isNil or: [ maxVersionOrNil isInteger ]) ifFalse: [ - self error: 'Version numbers must be Integer numbers. Specify also Revision number if needed.' ]. - newInst _ self new. - newInst name: aSymbol minVersion: minVersionOrNil minRevision: minRevisionOrNil maxVersion: maxVersionOrNil. - - ^ newInst! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4035-FeatureRequirement-fixes-JuanVuletich-2020Feb17-15h11m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4034] on 10 February 2020 at 1:34:40 pm'! -!PasteUpMorph methodsFor: 'geometry' stamp: 'jmv 2/10/2020 13:34:12'! - fontPreferenceChanged - self recreateDefaultDesktop. - super fontPreferenceChanged! ! -!FontFamily class methodsFor: 'initialization' stamp: 'jmv 2/10/2020 13:34:19' prior: 50473022! - defaultFamilyName: aStringOrNil defaultPointSize: aNumberOrNil - "Nil just means leave it as it is now." - | family | - aStringOrNil ifNotNil: [DefaultFamilyName _ aStringOrNil]. - aNumberOrNil ifNotNil: [DefaultPointSize _ aNumberOrNil]. - self revisar. "Please remove this hack meant to install larger DejaVu StrikeFonts on demand." - DefaultFamilyName = 'DejaVu' ifTrue: [ - family _ AvailableFamilies at: DefaultFamilyName. - (family pointSizes includes: DefaultPointSize) ifFalse: [ StrikeFont install: DefaultFamilyName]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4036-Cleanup-JuanVuletich-2020Feb10-13h33m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4035] on 16 February 2020 at 9:01:19 pm'! -!String methodsFor: 'displaying' stamp: 'jmv 2/16/2020 20:59:55' prior: 50365662! - 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 mousePoint - from: 0 to: 100 - during: [:barBlock | - 1 to: 100 do: [:x | - (Delay forMilliseconds: 10) wait. - barBlock value: x.]]. - -['Now here''s some Real Progress' - displayProgressAt: Sensor mousePoint - from: 0 to: 100 - during: [:barBlock | - 1 to: 100 do: [:x | barBlock value: x. - (Delay forMilliseconds: 100) wait]].] fork - -['Now here''s some Real Progress' - displayProgressAt: Sensor mousePoint - from: 0 to: 10 - during: [:barBlock | - 1 to: 30 do: [:x | barBlock value: x \\ 11. - (Delay forMilliseconds: 100) wait]]] fork - -'Now here''s some Real Progress' - displayProgressAt: Sensor mousePoint - from: 0 to: 10 - during: [:barBlock | - 1 to: 30 do: [:x | barBlock value: nil. - (Delay forMilliseconds: 200) 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. - -The use of ProgressInitiationException allows for avoiding actual -progress display, by catching the exception. -" - | answer duration | - Transcript show: self; show: '...'. - duration _ [ - answer _ ProgressInitiationException - display: self - at: aPoint - from: minVal - to: maxVal - during: workBlock] durationToRun. - Transcript show: ' done. Took '; show: duration printString; newLine. - ^answer! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4037-LogProgressToTranscript-JuanVuletich-2020Feb16-20h54m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4034] on 29 January 2020 at 8:52:03 am'! -!Behavior methodsFor: 'compiling' stamp: 'jmv 1/29/2020 08:47:49' prior: 16783295! - compile: code notifying: requestor - "Compile the argument, code, as source code in the context of the - receiver and install the result in the receiver's method dictionary. The - second argument, requestor, is to be notified if an error occurs. The - argument code is either a string or an object that converts to a string or - a PositionableStream. This method also saves the source code." - - | methodAndNode | - methodAndNode _ self - basicCompile: code "a Text" - notifying: requestor - trailer: self defaultMethodTrailer - ifFail: [^nil]. - methodAndNode method putSource: code fromParseNode: methodAndNode node inFile: 2 - withPreamble: [:f | f newLine; nextPut: $!!; nextChunkPut: 'Behavior method'; newLine]. - self addSelectorSilently: methodAndNode selector withMethod: methodAndNode method. - ^ methodAndNode selector! ! -!Decompiler class methodsFor: 'testing' stamp: 'jmv 1/29/2020 08:46:03' prior: 16832427! - recompileAllTest - "[Decompiler recompileAllTest]" - "decompile every method and compile it back; if the decompiler is correct then the system should keep running. :)" - - Smalltalk allBehaviorsDo: [ :behavior | - Utilities informUser: (behavior printString) during: [ - behavior selectors do: [ :sel | - | decompiled ast compiled | - decompiled := Decompiler new decompile: sel in: behavior. - ast := Compiler new compile: decompiled in: behavior notifying: nil ifFail: [ self error: 'failed' ]. - compiled := ast generate: (behavior compiledMethodAt: sel) trailer. - behavior addSelectorSilently: sel withMethod: compiled. ] ] ]! ! -!CodeWindow methodsFor: 'notification actions' stamp: 'jmv 1/29/2020 08:49:25' prior: 50482791! - registerNotificationActions - - SystemChangeNotifier uniqueInstance - when: #classAdded send: #updateListsAndCode to: self; - when: #classCommented send: #updateListsAndCode to: self; - when: #classDefinitionChanged send: #updateListsAndCode to: self; - when: #classRecategorized send: #updateListsAndCode to: self; - when: #classRemoved send: #updateListsAndCode to: self; - when: #classRenamed send: #classRenamed:from:to:inCategory: to: self; - when: #classReorganized send: #updateListsAndCode to: self; - when: #methodAddedInProtocol send: #updateListsAndCode to: self; - when: #methodChanged send: #updateListsAndCode to: self; - when: #methodRemoved send: #updateListsAndCode to: self; - when: #selectorRecategorized send: #updateListsAndCode to: self ! ! -!ChangeSet class methodsFor: 'class initialization' stamp: 'jmv 1/29/2020 08:49:18' prior: 50482881! - registerNotificationActions - - "Only sent when model is not nil - Hernan" - SystemChangeNotifier uniqueInstance - when: #classAdded send: #classAdded:inCategory: to: self; - when: #classCommented send: #classCommented: to: self; - when: #classDefinitionChanged send: #classDefinitionChangedFrom:to: to: self; - when: #classRecategorized send: #classRecategorized:from:to: to: self; - when: #classRemoved send: #classRemoved:fromCategory: to: self; - when: #aboutToRenameClass send: #aboutToRenameClass:from:to:inCategory: to: self; - when: #classReorganized send: #classReorganized: to: self; - when: #methodAddedInProtocol send: #methodAdded:selector:inProtocol:class:requestor: to: self; - when: #methodChanged send: #methodChangedFrom:to:selector:inClass:requestor: to: self; - when: #methodRemoved send: #methodRemoved:selector:inProtocol:class: to: self; - when: #selectorRecategorized send: #selectorRecategorized:from:to:inClass: to: self! ! -!SmalltalkCompleter class methodsFor: 'class initialization' stamp: 'jmv 1/29/2020 08:49:30' prior: 50436953! - initialize - " - It takes about 6 seconds, mostly because of the time to fetch method stamps from source files... - [ SmalltalkCompleter initialize ]timeToRun - Selectors inspect - " - | maxSortValue allImplemented | - - EntriesLimit _ 100. - - SystemChangeNotifier uniqueInstance - removeActionsWithReceiver: self. "avoid double registration" - - SystemChangeNotifier uniqueInstance - when: #classRemoved send: #classRemoved:fromCategory: to: self; - when: #methodAddedInProtocol send: #methodAdded:selector:inProtocol:class:requestor: to: self; - when: #methodRemoved send: #methodRemoved:selector:inProtocol:class: to: self. - - self protected: [ - allImplemented _ Smalltalk allImplementedMessages. - Selectors _ Trie new. - " - Smalltalk allBehaviorsDo: [:class | - class selectorsAndMethodsDo: [ :sel :method | - Selectors at: sel ifAbsentPut: [ 0 ]. - method messages do: [ :sentMsg | - Selectors at: sentMsg put: (Selectors at: sentMsg ifAbsent: [ 0 ]) + 1 ]]]. - " - Smalltalk allBehaviorsDo: [:class | - class selectorsAndMethodsDo: [ :sel :method | - self addSelector: sel method: method allImplemented: allImplemented]]. - "" - - "The following might not be found in #messages. Give them maximum priority." - maxSortValue _ SmallInteger maxVal. - "From MessageNode>>#initialize" - #( ifTrue: ifFalse: ifTrue:ifFalse: ifFalse:ifTrue: - and: or: - whileFalse: whileTrue: whileFalse whileTrue - to:do: to:by:do: - caseOf: caseOf:otherwise: - ifNil: ifNotNil: ifNil:ifNotNil: ifNotNil:ifNil:) do: [ :sel | - Selectors at: sel put: maxSortValue ]. - - maxSortValue _ SmallInteger maxVal-1. - "From SystemDictionary >>#recreateSpecialObjectsArray" - (1 to: Smalltalk specialSelectorSize) do: [ :i | | sym | - sym _ Smalltalk specialSelectorAt: i. - (Selectors includesKey: sym) - ifTrue: [ Selectors at: sym put: maxSortValue ]]]! ! - -SmalltalkCompleter class removeSelector: #methodAdded:selector:inClass:requestor:! - -!methodRemoval: SmalltalkCompleter class #methodAdded:selector:inClass:requestor: stamp: 'Install-4038-remove-methodAdded-event-JuanVuletich-2020Jan29-08h46m-jmv.1.cs.st 4/1/2020 17:56:03'! -methodAdded: aMethod selector: aSymbol inClass: aClass requestor: requestor - - self protected: [ - self addSelector: aSymbol method: aMethod allImplemented: nil ]! - -ChangeSet class removeSelector: #methodAdded:selector:inClass:requestor:! - -!methodRemoval: ChangeSet class #methodAdded:selector:inClass:requestor: stamp: 'Install-4038-remove-methodAdded-event-JuanVuletich-2020Jan29-08h46m-jmv.1.cs.st 4/1/2020 17:56:03'! -methodAdded: aCompiledMethod selector: aSymbol inClass: aClass requestor: requestor - - | packageOrNil | - - aClass wantsChangeSetLogging ifFalse: [ ^self ]. - - packageOrNil _ CodePackage packageOfMethod: aCompiledMethod methodReference ifNone: nil. - (self changeSetForPackage: packageOrNil) ifNotNil: [ :changeSet | - changeSet - methodAdded: aCompiledMethod - selector: aSymbol - inClass: aClass - requestor: requestor ]. - packageOrNil ifNotNil: [ - packageOrNil hasUnsavedChanges: true ]! - -ChangeSet removeSelector: #methodAdded:selector:inClass:requestor:! - -!methodRemoval: ChangeSet #methodAdded:selector:inClass:requestor: stamp: 'Install-4038-remove-methodAdded-event-JuanVuletich-2020Jan29-08h46m-jmv.1.cs.st 4/1/2020 17:56:03'! -methodAdded: aMethod selector: aSymbol inClass: aClass requestor: requestor - - self - noteNewMethod: aMethod - forClass: aClass - selector: aSymbol - priorMethod: nil! - -ClassDescription removeSelector: #addSelector:withMethod:notifying:! - -!methodRemoval: ClassDescription #addSelector:withMethod:notifying: stamp: 'Install-4038-remove-methodAdded-event-JuanVuletich-2020Jan29-08h46m-jmv.1.cs.st 4/1/2020 17:56:03'! -addSelector: selector withMethod: compiledMethod notifying: requestor - | priorMethodOrNil newProtocolOrNil priorProtocolOrNil | - priorMethodOrNil _ self compiledMethodAt: selector ifAbsent: nil. - priorProtocolOrNil _ self whichCategoryIncludesSelector: selector. - self addSelectorSilently: selector withMethod: compiledMethod. - newProtocolOrNil _ self whichCategoryIncludesSelector: selector. - priorMethodOrNil - ifNil: [ - SystemChangeNotifier uniqueInstance - methodAdded: compiledMethod - selector: selector - inClass: self - requestor: requestor ] - ifNotNil: [ - SystemChangeNotifier uniqueInstance - methodChangedFrom: priorMethodOrNil - to: compiledMethod - selector: selector - inClass: self - requestor: requestor. - - newProtocolOrNil = priorProtocolOrNil ifFalse: [ - SystemChangeNotifier uniqueInstance - selectorRecategorized: selector - from: priorProtocolOrNil - to: newProtocolOrNil - inClass: self ]]! - -Behavior removeSelector: #addSelector:withMethod:! - -!methodRemoval: Behavior #addSelector:withMethod: stamp: 'Install-4038-remove-methodAdded-event-JuanVuletich-2020Jan29-08h46m-jmv.1.cs.st 4/1/2020 17:56:03'! -addSelector: selector withMethod: compiledMethod - ^ self addSelector: selector withMethod: compiledMethod notifying: nil! - -Behavior removeSelector: #addSelector:withMethod:notifying:! - -!methodRemoval: Behavior #addSelector:withMethod:notifying: stamp: 'Install-4038-remove-methodAdded-event-JuanVuletich-2020Jan29-08h46m-jmv.1.cs.st 4/1/2020 17:56:03'! -addSelector: selector withMethod: compiledMethod notifying: requestor - ^ self addSelectorSilently: selector withMethod: compiledMethod! - -SystemChangeNotifier removeSelector: #methodAdded:selector:inClass:requestor:! - -!methodRemoval: SystemChangeNotifier #methodAdded:selector:inClass:requestor: stamp: 'Install-4038-remove-methodAdded-event-JuanVuletich-2020Jan29-08h46m-jmv.1.cs.st 4/1/2020 17:56:03'! -methodAdded: aMethod selector: aSymbol inClass: aClass requestor: requestor - "A method with the given selector was added to aClass, but not put in a protocol." - - self - triggerEvent: #methodAdded - withArguments: { aMethod . aSymbol . aClass . requestor }! - -SmalltalkCompleter initialize! - -ChangeSet initialize! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4038-remove-methodAdded-event-JuanVuletich-2020Jan29-08h46m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4035] on 29 January 2020 at 9:52:36 am'! -!ClassDescription methodsFor: 'compiling' stamp: 'jmv 1/29/2020 09:51:41' prior: 16806418! - compile: text classified: category withStamp: changeStamp notifying: requestor logSource: logSource - | methodAndNode | - methodAndNode _ self basicCompile: text asString notifying: requestor - trailer: self defaultMethodTrailer ifFail: [^nil]. - logSource ifTrue: [ - self logMethodSource: text forMethodWithNode: methodAndNode - inCategory: category withStamp: changeStamp notifying: requestor. - ]. - self addAndClassifySelector: methodAndNode selector withMethod: methodAndNode - method inProtocol: category notifying: requestor. - ^ methodAndNode selector! ! - -ClassDescription removeSelector: #noteCompilationOf:meta:! - -!methodRemoval: ClassDescription #noteCompilationOf:meta: stamp: 'Install-4039-noteCompilationOfmeta-removal-JuanVuletich-2020Jan29-09h03m-jmv.1.cs.st 4/1/2020 17:56:04'! -noteCompilationOf: aSelector meta: isMeta - "A hook allowing some classes to react to recompilation of certain selectors"! - -Object class removeSelector: #noteCompilationOf:meta:! - -!methodRemoval: Object class #noteCompilationOf:meta: stamp: 'Install-4039-noteCompilationOfmeta-removal-JuanVuletich-2020Jan29-09h03m-jmv.1.cs.st 4/1/2020 17:56:04'! -noteCompilationOf: aSelector meta: isMeta - "A hook allowing some classes to react to recompilation of certain selectors. - This implementor catches class methods."! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4039-noteCompilationOfmeta-removal-JuanVuletich-2020Jan29-09h03m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4035] on 29 January 2020 at 10:25:30 am'! -!Object class methodsFor: 'compiling' stamp: 'pb 1/29/2020 10:24:14'! - isOkToAddMethod: selector isMeta: isMeta - "A hook allowing some classes to disallow and/or react to addition of certain selectors before the change is committed - This implementor is only for convenience, as the method is meant to be redefined in class side as needed." - ^super isOkToAddMethod: selector isMeta: isMeta! ! -!Object class methodsFor: 'compiling' stamp: 'pb 1/29/2020 10:24:22'! - isOkToChangeMethod: selector isMeta: isMeta - "A hook allowing some classes to disallow and/or react to recompilation of certain selectors before the change is committed - This implementor is only for convenience, as the method is meant to be redefined in class side as needed." - ^super isOkToChangeMethod: selector isMeta: isMeta! ! -!Object class methodsFor: 'compiling' stamp: 'pb 1/29/2020 10:24:26'! - isOkToRemoveMethod: selector isMeta: isMeta - "A hook allowing some classes to disallow and/or react to removal of certain selectors before the change is committed - This implementor is only for convenience, as the method is meant to be redefined in class side as needed." - ^super isOkToRemoveMethod: selector isMeta: isMeta! ! -!ClassDescription methodsFor: 'compiling' stamp: 'pb 1/29/2020 10:09:40'! - isOkToAddMethod: selector isMeta: isMeta - "A hook allowing some classes to disallow and/or react to addition of certain selectors before the change is committed" - ^true! ! -!ClassDescription methodsFor: 'compiling' stamp: 'pb 1/29/2020 10:24:45'! - isOkToChangeMethod: selector isMeta: isMeta - "A hook allowing some classes to disallow and/or react to recompilation of certain selectors before the change is committed" - ^true! ! -!ClassDescription methodsFor: 'compiling' stamp: 'pb 1/29/2020 10:10:16'! - isOkToRemoveMethod: selector isMeta: isMeta - "A hook allowing some classes to disallow and/or react to removal of certain selectors before the change is committed" - ^true! ! -!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'pb 1/29/2020 10:21:42' prior: 16806248! - removeSelector: selector - | priorMethod priorProtocol | - "Remove the message whose selector is given from the method - dictionary of the receiver, if it is there. Answer nil otherwise." - - priorMethod _ self compiledMethodAt: selector ifAbsent: [^ nil]. - (self theNonMetaClass isOkToRemoveMethod: selector isMeta: self isMeta) - ifFalse: [self error: 'Method removal not allowed']. - priorProtocol _ self whichCategoryIncludesSelector: selector. - SystemChangeNotifier uniqueInstance doSilently: [ - self organization removeElement: selector]. - super removeSelector: selector. - SystemChangeNotifier uniqueInstance - methodRemoved: priorMethod selector: selector inProtocol: priorProtocol class: self.! ! -!ClassDescription methodsFor: 'compiling' stamp: 'pb 1/29/2020 10:21:23' prior: 50496288! - compile: text classified: category withStamp: changeStamp notifying: requestor logSource: logSource - | methodAndNode selector isExistingMethod | - methodAndNode _ self basicCompile: text asString notifying: requestor - trailer: self defaultMethodTrailer ifFail: [^nil]. - selector _ methodAndNode selector. - isExistingMethod _ self includesSelector: selector. - isExistingMethod - ifTrue: [ - (self theNonMetaClass isOkToChangeMethod: selector isMeta: self isMeta) - ifFalse: [self error: 'Method modification not allowed']] - ifFalse: [ - (self theNonMetaClass isOkToAddMethod: selector isMeta: self isMeta) - ifFalse: [self error: 'Method addition not allowed']]. - logSource ifTrue: [ - self logMethodSource: text forMethodWithNode: methodAndNode - inCategory: category withStamp: changeStamp notifying: requestor. - ]. - self addAndClassifySelector: selector withMethod: methodAndNode - method inProtocol: category notifying: requestor. - ^ methodAndNode selector! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4040-tracking-method-changes-globally-PhilBellalouna-2020Jan29-10h00m-pb.2.cs.st----! - -'From Cuis 5.0 [latest update: #4040] on 18 February 2020 at 11:01:29 am'! -!CodePackage methodsFor: 'listing' stamp: 'jmv 2/18/2020 11:00:34' prior: 16810099! - sortedExtensionMethodsDo: aBlock displayingProgress: aString - "Include both class and instance methods we define, for classes we don't define." - | externalClasses methods | - externalClasses _ self externalClasses. - aString - displayProgressAt: Sensor mousePoint - from: 0 to: externalClasses size - during: [ :barBlock | - externalClasses withIndexDo: [ :classOrMetaClass :i | - barBlock value: i. - methods _ Array streamContents: [ :stream | - (self extensionCategoriesForClass: classOrMetaClass) do: [ :cat | - self methodsInCategory: cat ofClass: classOrMetaClass do: [ :m | - stream nextPut: m ]]]. - methods sort: [ :a :b | - a methodSymbol < b methodSymbol ]. - methods do: aBlock. - ] - ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4041-AvoidExcessiveProgressDialogs-JuanVuletich-2020Feb18-11h00m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4034] on 2 February 2020 at 12:45:03 pm'! - -"Change Set: 4035-CuisCore-AuthorName-2020Feb02-12h37m -Date: 2 February 2020 -Author: Nahuel Garbezza - -Add an option to inspect keys on dictionaty inspector"! -!InspectorWindow methodsFor: 'menu commands' stamp: 'RNG 2/2/2020 12:44:24'! - inspectSelectedKey - - ^ model selectedKey inspect! ! -!InspectorWindow methodsFor: 'menu building' stamp: 'RNG 2/2/2020 12:41:50' prior: 50495468! - menuOptionsForDictionary - - ^ `{ - nil. - { - #label -> 'inspect key'. - #selector -> #inspectSelectedKey. - #icon -> #findIcon - } asDictionary. - { - #label -> 'senders of this key'. - #selector -> #sendersOfSelectedKey. - #icon -> #mailForwardIcon - } asDictionary. - { - #label -> 'add key'. - #selector -> #addEntry. - #icon -> #listAddIcon - } asDictionary. - { - #label -> 'rename key'. - #selector -> #renameEntry. - #icon -> #saveAsIcon - } asDictionary. - { - #label -> 'remove'. - #object -> #model. - #selector -> #removeSelection. - #icon -> #listRemoveIcon - } asDictionary. - }`! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4042-inspectKey-option-in-Dictionaries-NahuelGarbezza-2020Feb02-12h37m-RNG.1.cs.st----! - -'From Cuis 5.0 [latest update: #4042] on 19 February 2020 at 11:16:25 am'! -!SystemDictionary methodsFor: 'browsing' stamp: 'pb 2/17/2020 20:04:57'! - browseAllReferencesToLiteral: aLiteral - "Create and schedule a message browser on each method that references aLiteral. For example, - Smalltalk browseAllReferencesToLiteral: 47. - Smalltalk browseAllReferencesToLiteral: `0 @ 0`." - ^ self - browseMessageList: (self allReferencesToLiteral: aLiteral) - name: 'References to literal ' , aLiteral asString.! ! -!SystemDictionary methodsFor: 'retrieving' stamp: 'pb 2/17/2020 19:53:49'! - allReferencesToLiteral: aLiteral - | coll | - coll := OrderedCollection new. - Smalltalk allBehaviorsDo: [ :eaClass | - eaClass - addMethodsTo: coll - thatReferenceTo: aLiteral - special: false - byte: nil ]. - ^ coll.! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'pb 2/19/2020 10:58:00'! - referencesToSelectedLiteral - "Evaluate the selected text and browse methods that reference the same literal" - [ - self - evaluateSelectionAndDo: [ :result | - Smalltalk - browseMessageList: (Smalltalk allReferencesToLiteral: result) asArray sort - name: 'Users of literal: ' , result asString - autoSelect: self selection ] - ifFail: nil - profiled: false ] - on: UndeclaredVariableReference , UnknownSelector - do: [ :ex | - morph flash ]! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'pb 2/19/2020 10:55:00' prior: 50463217! - referencesToIt - "Open a references browser on the selected symbol: a variable name or class name" - - | selectedString provider environment | - - "look for exactly a whole word" - selectedString _ self selectedString withoutSeparators. - - "convenient access to class variables, including those in SharedPools" - provider _ self codeProvider. - environment _ (provider respondsTo: #selectedClassOrMetaClass) ifTrue: [ provider selectedClassOrMetaClass ]. - environment _ environment ifNil: [ Smalltalk ]. - - (environment bindingOf: selectedString) - ifNotNil: [ :reference | Smalltalk browseAllCallsOn: reference ] - ifNil: [ (environment ~= Smalltalk and: [ environment definesInstanceVariableNamedInHierarchy: selectedString ]) - ifTrue: [ Smalltalk browseAllAccessesTo: selectedString from: environment ] - ifFalse: [ self referencesToSelectedLiteral ]] - - - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4043-browse-literal-references-PhilBellalouna-2020Feb19-10h49m-pb.1.cs.st----! - -'From Cuis 5.0 [latest update: #4043] on 19 February 2020 at 12:22:13 pm'! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'jmv 2/19/2020 12:18:39' prior: 50496587! - referencesToIt - "Open a references browser on the selected symbol: a variable name or class name" - - | selectedSymbol provider environment selectedString | - self hasSelection ifFalse: [ self selectWord ]. - selectedSymbol _ self selectedSymbol. - - "convenient access to class variables, including those in SharedPools" - provider _ self codeProvider. - environment _ (provider respondsTo: #selectedClassOrMetaClass) ifTrue: [ provider selectedClassOrMetaClass ]. - environment _ environment ifNil: [ Smalltalk ]. - - (selectedSymbol ifNotNil: [environment bindingOf: selectedSymbol]) ifNotNil: [ :reference | - Smalltalk browseAllCallsOn: reference. - ^ self ]. - - selectedString _ self selectedString withoutSeparators. - (environment ~= Smalltalk and: [ environment definesInstanceVariableNamedInHierarchy: selectedString ]) ifTrue: [ - Smalltalk browseAllAccessesTo: selectedString from: environment. - ^ self ]. - - self referencesToSelectedLiteral! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4044-FixReferencesToGlobalNames-JuanVuletich-2020Feb19-12h21m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4044] on 19 February 2020 at 12:57:24 pm'! -!SequenceableCollection methodsFor: 'accessing' stamp: 'EB 1/27/2020 19:50:15'! - lastIndexOf: anElement startingAt: lastIndex endingAt: firstIndex 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: lastIndex endingAt: firstIndex do: [ :index | ^index ]. - ^exceptionBlock value.! ! -!Parser methodsFor: 'error correction' stamp: 'EB 1/27/2020 02:36:44'! - createEmptyTempsDeclarationAfter: aDeclarationPosition - "Return the position of the end of the declaration." - | offset | - - offset := self insertWord: ' | |' at: aDeclarationPosition + 1. - ^aDeclarationPosition + offset! ! -!Parser methodsFor: 'error correction' stamp: 'EB 1/27/2020 03:01:19'! - createEmptyTempsDeclarationIfNecessaryIn: aBlockNode - "Return the new tempsMark for this BlockNode" - | blockTempsMark | - - blockTempsMark := aBlockNode tempsMark + requestorOffset. - (self hasNoTempDeclarationPipes: aBlockNode) ifTrue: [ - blockTempsMark := self createEmptyTempsDeclarationAfter: blockTempsMark ]. - ^blockTempsMark! ! -!Parser methodsFor: 'error correction' stamp: 'EB 1/27/2020 02:39:26'! - declareUndeclaredTemps: undeclaredTempNodes inBlock: aDeclaringBlockNode - - | blockTempsMark | - - blockTempsMark := self createEmptyTempsDeclarationIfNecessaryIn: aDeclaringBlockNode. - undeclaredTempNodes do: [ :varName | blockTempsMark := self pasteTemp: varName before: blockTempsMark ]! ! -!Parser methodsFor: 'error correction' stamp: 'EB 1/27/2020 20:18:18'! - hasNoTempDeclarationPipes: aBlockNode - "Determine if a BlockNode already has the '| |' used to declare temps." - | blockTempsMark sourceCode hasNoTemps | - - sourceCode := requestor text string. - blockTempsMark := aBlockNode tempsMark + requestorOffset. - hasNoTemps := aBlockNode temporaries isEmpty. - ^hasNoTemps and: [ (self isLastPipeOfEmptyTempsDeclaration: blockTempsMark) not ].! ! -!Parser methodsFor: 'error correction' stamp: 'EB 1/27/2020 20:19:48'! - isLastPipeOfEmptyTempsDeclaration: pipeIndex - - | indexOfPreviousPipe sourceCode | - - sourceCode := requestor text string. - indexOfPreviousPipe := sourceCode lastIndexOf: $| startingAt: pipeIndex - 1 endingAt: 1 ifAbsent: [ ^false ]. - ^(sourceCode at: pipeIndex) = $| and: [ - (sourceCode copyFrom: indexOfPreviousPipe + 1 to: pipeIndex - 1) allSatisfy: [ :char | char isSeparator ]]! ! -!Parser methodsFor: 'error correction' stamp: 'EB 1/27/2020 02:16:43' prior: 50486053! - declareUndeclaredTemps: methodNode - "Declare any undeclared temps, declaring them at the smallest enclosing scope." - | undeclared userSelection blocksToVars | - (undeclared _ encoder undeclaredTemps) isEmpty ifTrue: [ ^ self ]. - userSelection _ requestor selectionInterval. - blocksToVars _ IdentityDictionary new. - undeclared do: [ :var | - (blocksToVars - at: (var tag == #method - ifTrue: [ methodNode block ] - ifFalse: [ methodNode accept: (VariableScopeFinder new ofVariable: var) ]) - ifAbsentPut: [ SortedCollection new ]) add: var name ]. - (blocksToVars removeKey: methodNode block ifAbsent: nil) ifNotNil: [ :rootVars | - rootVars do: [ :varName | - self pasteTempAtMethodLevel: varName ]]. - (blocksToVars keys sort: [ :a :b | - a tempsMark < b tempsMark ]) do: [ :block | | blockUndeclaredVars | - blockUndeclaredVars := blocksToVars at: block. - self declareUndeclaredTemps: blockUndeclaredVars inBlock: block ]. - requestor - selectInvisiblyFrom: userSelection first - to: userSelection last + requestorOffset. - ReparseAfterSourceEditing signal! ! - -Parser removeSelector: #pasteTemp:inBlock:! - -!methodRemoval: Parser #pasteTemp:inBlock: stamp: 'Install-4045-DeclareUndeclaredWithBlockArgumentsFix-EricBrandwein-2020Feb19-12h55m-EB.1.cs.st 4/1/2020 17:56:04'! -pasteTemp: tempName inBlock: aBlockNode - - | theTextString blockTempsMark | - - theTextString := requestor text string. - blockTempsMark := aBlockNode tempsMark + requestorOffset. - - (theTextString at: blockTempsMark) = $| - ifTrue: [ - "Paste it before the second vertical bar" - self pasteTemp: tempName before: blockTempsMark ] - ifFalse: [ - "The tempsMark is at the beginning of the block, we should insert after it." - self createTempDeclarationInBlockWith: tempName before: blockTempsMark ].! - -Parser removeSelector: #createTempDeclarationInBlockWith:before:! - -!methodRemoval: Parser #createTempDeclarationInBlockWith:before: stamp: 'Install-4045-DeclareUndeclaredWithBlockArgumentsFix-EricBrandwein-2020Feb19-12h55m-EB.1.cs.st 4/1/2020 17:56:04'! -createTempDeclarationInBlockWith: tempName before: aTempsMark - "Return the new tempsMark." - - | delta insertion offset | - - insertion := ' | ' , tempName , ' |'. - delta := 1. "the bar" - offset := self insertWord: insertion at: aTempsMark + 1. - - ^aTempsMark + offset - delta.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4045-DeclareUndeclaredWithBlockArgumentsFix-EricBrandwein-2020Feb19-12h55m-EB.1.cs.st----! - -'From Cuis 5.0 [latest update: #4045] on 21 February 2020 at 12:41:15 am'! -!Integer methodsFor: 'printing' stamp: 'jmv 2/20/2020 16:52:31' prior: 50342181! - printOn: aStream length: minimum zeroPadded: zeroFlag - " - 7 printOn: Transcript length: 4 zeroPadded: true. Transcript newLine. - " - self printOn: aStream base: 10 length: minimum padded: zeroFlag! ! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'jmv 2/20/2020 16:51:14' prior: 50405766! - assureStartupStampLogged - "If there is a startup stamp not yet actually logged to disk, do it now." - | changesFile directory oldUserChanges oldUserChangesName | - StartupStamp ifNil: [^ self]. - (SourceFiles notNil and: [(changesFile _ SourceFiles at: 2) notNil]) ifTrue: [ - changesFile isReadOnly ifFalse: [ - changesFile setToEnd; newLine; newLine. - changesFile nextChunkPut: StartupStamp asString; newLine. - self forceChangesToDisk ]]. - oldUserChanges _ Smalltalk defaultUserChangesName asFileEntry. - oldUserChanges exists ifTrue: [ - directory _ oldUserChanges parent. - oldUserChangesName _ directory nextNameFor: oldUserChanges nameWithoutExtension extension: 'changes'. - oldUserChanges rename: oldUserChangesName ]. - Smalltalk defaultUserChangesName asFileEntry appendStreamDo: [ :stream | - stream newLine; newLine. - stream nextChunkPut: StartupStamp asString; newLine ]. - StartupStamp _ nil! ! -!FileIOAccessor methodsFor: 'utilities' stamp: 'jmv 2/20/2020 16:40:54' prior: 16842049! - splitNameVersionExtensionFor: fileName - " answer an array with the root name, version # and extension. - See comment in senders for more details" - - | baseName version i j | - self baseNameAndExtensionFor: fileName do: [ :b :extension | - baseName _ b. - i := j := baseName findLast: [:c | c isDigit not]. - i = 0 - ifTrue: [version := 0] - ifFalse: [ - (baseName at: i) = $. - ifTrue: [ - version := (baseName copyFrom: i+1 to: baseName size) asNumber. - j := j - 1] - ifFalse: [version := 0]. - baseName := baseName copyFrom: 1 to: j ]. - ^ Array with: baseName with: version with: extension ]! ! -!DirectoryEntry methodsFor: 'services' stamp: 'jmv 2/21/2020 00:38:45' prior: 16834728! -nextNameFor: baseFileName coda: fileNameCoda extension: extension - "Assumes a file name includes a version number encoded as '.' followed by digits - preceding the file extension. Increment the version number and answer the new file name. - If a version number is not found, set the version to 1 and answer a new file name. - fileNameCoda is ignored during version number search, but added to the final name. It allows sequences like: - someFileName-authorXX.cs - someFileName-authorYY.1.cs - someFileName-authorZZ.2.cs - " - - | files splits version candidate | - files _ self fileNamesMatching: (baseFileName,'*.', extension). - splits _ files collect: [ :file | self fileAccessor splitNameVersionExtensionFor: file ]. - splits _ splits asArray sort: [ :a :b | (a at: 2) < (b at: 2)]. - splits isEmpty - ifTrue: [ version _ 1 ] - ifFalse: [ version _ (splits last at: 2) + 1 ]. - candidate _ (baseFileName, fileNameCoda, '.', (String streamContents: [ :strm | version printOn: strm length: 3 zeroPadded: true ]), '.', extension) asFileName. - ^ candidate! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4046-SequentialUserChangesFiles-JuanVuletich-2020Feb20-16h38m-jmv.008.cs.st----! - -'From Cuis 5.0 [latest update: #4046] on 21 February 2020 at 1:29:11 pm'! -!IdentitySet methodsFor: 'accessing' stamp: 'jmv 2/21/2020 12:47:37'! - elementForIdentityHash: aNumber - "Answer any element matching argument. - Answer nil if none found" - | finish scale index element | - finish _ array size. - scale _ finish // (Smalltalk maxIdentityHash + 1). - scale = 0 ifTrue: [scale _ 1]. - index _ aNumber * scale \\ finish + 1. - - element _ array at: index. - ^element identityHash = aNumber ifTrue: [ element ]! ! -!WeakIdentitySet methodsFor: 'accessing' stamp: 'jmv 2/21/2020 12:50:06'! - elementForIdentityHash: aNumber - "Answer any element matching argument. - Answer nil if none found" - | finish scale index element | - finish _ array size. - scale _ finish // (Smalltalk maxIdentityHash + 1). - scale = 0 ifTrue: [scale _ 1]. - index _ aNumber * scale \\ finish + 1. - - element _ array at: index. - element == flag ifTrue: [ ^ nil ]. - ^element identityHash = aNumber ifTrue: [ element ]! ! -!ProtoObject methodsFor: 'comparing' stamp: 'jmv 2/21/2020 11:02:26' prior: 16896484! - identityHash - "Answer a SmallInteger whose value is related to the receiver's identity. - This method must not be overridden, except by immediate classes such as SmallInteger, - and in Spur systems, Character and SmallFloat64. - Primitive. Fails if the receiver is a SmallInteger. Essential. - See Object documentation whatIsAPrimitive. - - Do not override." - - - self primitiveFailed! ! -!Set methodsFor: 'private' stamp: 'jmv 2/21/2020 12:39:07' prior: 16907261! - keyAt: index - "May be overridden by subclasses so that fixCollisionsFrom: will work" - ^ array at: index! ! -!Set methodsFor: 'private' stamp: 'jmv 2/21/2020 12:39:37' prior: 16907302! - swap: oneIndex with: otherIndex - "May be overridden by subclasses so that fixCollisionsFrom: will work" - - array swap: oneIndex with: otherIndex -! ! -!Dictionary methodsFor: 'private' stamp: 'jmv 2/21/2020 12:39:24' prior: 16833748! - keyAt: index - "May be overridden by subclasses so that fixCollisionsFrom: will work" - | assn | - assn _ array at: index. - assn ifNil: [^ nil]. - ^ assn key! ! -!IdentityDictionary methodsFor: 'private' stamp: 'jmv 2/21/2020 12:33:35' prior: 16853954! - 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 scale start element | - finish _ array size. - scale _ finish // (Smalltalk maxIdentityHash + 1). - scale = 0 ifTrue: [scale _ 1]. - start _ anObject identityHash * scale \\ 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"! ! -!WeakIdentityKeyDictionary methodsFor: 'private' stamp: 'jmv 2/21/2020 12:33:40' prior: 16943757! - 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." - | finish scale start element | - finish _ array size. - scale _ finish // (Smalltalk maxIdentityHash + 1). - scale = 0 ifTrue: [scale _ 1]. - start _ anObject identityHash * scale \\ 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"! ! -!WeakIdentityKeyDictionary methodsFor: 'private' stamp: 'jmv 2/21/2020 12:33:43' prior: 16943793! - scanForNil: anObject - "Private. Scan the key array for the first slot containing nil (indicating an empty slot). Answer the index of that slot." - - | finish scale start | - finish _ array size. - scale _ finish // (Smalltalk maxIdentityHash + 1). - scale = 0 ifTrue: [scale _ 1]. - start _ anObject identityHash * scale \\ finish + 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"! ! -!IdentitySet methodsFor: 'private' stamp: 'jmv 2/21/2020 12:33:27' prior: 16854018! - 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 scale start element | - finish _ array size. - scale _ finish // (Smalltalk maxIdentityHash + 1). - scale = 0 ifTrue: [scale _ 1]. - start _ anObject identityHash * scale \\ 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"! ! -!WeakIdentitySet methodsFor: 'private' stamp: 'jmv 2/21/2020 12:33:47' prior: 16943822! - 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 scale start element | - finish _ array size. - scale _ finish // (Smalltalk maxIdentityHash + 1). - scale = 0 ifTrue: [scale _ 1]. - start _ anObject identityHash * scale \\ 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"! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -IdentityDictionary allInstancesDo: [ :d | d rehash ]. -IdentitySet allInstancesDo: [ :d | d rehash ]. -WeakIdentityKeyDictionary allInstancesDo: [ :d | d rehash ]. -WeakIdentitySet allInstancesDo: [ :d | d rehash ].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4047-UseAllBitsOfIdentityHash-JuanVuletich-2020Feb21-11h02m-jmv.009.cs.st----! - -'From Cuis 5.0 [latest update: #4045] on 24 February 2020 at 11:53:19 pm'! - -"Change Set: 4046-CuisCore-AuthorName-2020Feb20-08h41m -Date: 24 February 2020 -Author: Nahuel Garbezza - -Refactorings and additions on Refactorings package: - -* Cleanups on extract method helpers -* Extract new temporary validations to a separate class (helpful for the upcoming ExtractToTemporary) -* Add some class comments"! -!ArgumentDeclarationCounter commentStamp: '' prior: 0! - I am responsible for counting the times an argument name appears in different block nodes across a method node.! -!ExtractMethodExpressionValidation commentStamp: '' prior: 0! - I check if an expression selected for extract method can be actually extracted. - -Many conditions have to happen: -* we are selecting from the beginning of an AST node to an end of an AST node -* it is a smalltalk expression, a single statement or a sequence of complete statements -* the expression does not contain returns, or temporary variable assignments! -!Refactoring commentStamp: 'RNG 2/24/2020 23:36:38' prior: 0! - I am a refactoring, a code transformation preserving behavior, based on some input (provided from the end user through a RefactoringApplier; or provided programmatically). Instances of me have usually only public method, #apply, which does all the work. - -In case the refactoring cannot be made, or there is a problem during the application of it, I can throw errors using the class message #refactoringError:, or warnings using the class message #refactoringWarning:! -!AddInstanceVariable commentStamp: 'RNG 2/24/2020 23:37:30' prior: 0! - I can add a new instance variable to a class. Input parameters are: - -* name of the new variable -* class to add that variable! -!ChangeSelector commentStamp: 'RNG 2/24/2020 23:38:29' prior: 0! - I am a refactoring abstract class whose purpose is to change a given selector; either by renaming it or changing arguments (adding, removing, change order)! -!AddParameter commentStamp: 'RNG 2/24/2020 23:43:14' prior: 0! - I am a refactoring that adds a new parameter to a given selector (that has to be a unary or keyword). The input is the following: - -* the new parameter name -* the selector that is going to be modified -* the position of the new parameter in the selector -* the keyword for the new parameter -* the default value for senders of this message -* the collection of implementors affected by the change -* the collection of senders affected by the change! -!ExtractMethod commentStamp: 'RNG 2/24/2020 23:48:02' prior: 0! - I am a refactoring that extracts a selected piece of code to a separate method. The input is the following: - -* interval of code to extract (from index - to index) -* the CompiledMethod where this change applies -* the new method selector + argument names (instance of Message) -* the category name for the new method - -Many conditions have to be satisfied for this refactoring to be made, I delegate into ExtractMethodExpressionValidation and ExtractMethodNewSelectorPrecondition some of these checks. Refer to the class comment of those classes for more information.! - -RefactoringPrecondition subclass: #NewTemporaryPrecondition - instanceVariableNames: 'newTemporaryVariableName methodNode blockNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #NewTemporaryPrecondition category: #'Tools-Refactoring' stamp: 'Install-4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st 4/1/2020 17:56:04'! -RefactoringPrecondition subclass: #NewTemporaryPrecondition - instanceVariableNames: 'newTemporaryVariableName methodNode blockNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!NewTemporaryPrecondition commentStamp: '' prior: 0! - I am responsible for checking if a new temporary variable can be introduced in a specific block node of a method. If that is not possible, I raise a refactoring error.! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'RNG 2/23/2020 20:55:30'! - newTemporaryPreconditionClass - - ^ NewTemporaryPrecondition! ! -!RefactoringPrecondition methodsFor: 'evaluating' stamp: 'RNG 2/24/2020 23:51:09'! - value - - self subclassResponsibility! ! -!NewTemporaryPrecondition methodsFor: 'private' stamp: 'RNG 2/23/2020 21:36:35'! - isDeclaredInAnyOf: someBlockOrMethodNodes - - ^ someBlockOrMethodNodes anySatisfy: [ :node | node hasLocallyArgumentOrTemporaryNamed: newTemporaryVariableName ]! ! -!NewTemporaryPrecondition methodsFor: 'private' stamp: 'RNG 2/23/2020 21:33:07'! - isDeclaredInChildrenOfBlockNode - - blockNode nodesDo: [ :node | - (node isBlockNode and: [ node hasLocallyArgumentOrTemporaryNamed: newTemporaryVariableName ]) ifTrue: [ ^ true ] ]. - - ^ false! ! -!NewTemporaryPrecondition methodsFor: 'private' stamp: 'RNG 2/23/2020 21:35:53'! - isDeclaredInParentsOfBlockNode - - | parents | - parents _ (BlockNodeParentsFinder for: blockNode) parentsIn: methodNode. - parents add: methodNode. - ^ self isDeclaredInAnyOf: parents! ! -!NewTemporaryPrecondition methodsFor: 'evaluating' stamp: 'RNG 2/23/2020 21:33:58'! - value - - self - assertIsNotEmpty; - assertIsValidVariableName; - assertIsNotDefinedAsInstanceVariableInHierarchyOfMethodClass; - assertIsNotDeclaredInParentsOrChildrenScopes! ! -!NewTemporaryPrecondition methodsFor: 'initialization' stamp: 'RNG 2/23/2020 21:41:48'! - initializeFor: aNewTemporaryVariableName in: aBlockNode of: aMethodNode - - newTemporaryVariableName _ aNewTemporaryVariableName. - blockNode _ aBlockNode. - methodNode _ aMethodNode! ! -!NewTemporaryPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 2/23/2020 21:33:58'! - assertIsNotDeclaredInParentsOrChildrenScopes - - (self isDeclaredInChildrenOfBlockNode or: [ self isDeclaredInParentsOfBlockNode ]) - ifTrue: [ self signalNewTemporaryVariableisAlreadyDefined ]! ! -!NewTemporaryPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 2/23/2020 20:36:51'! - assertIsNotDefinedAsInstanceVariableInHierarchyOfMethodClass - - | classDefiningNewVariable | - - classDefiningNewVariable _ methodNode methodClass - whichClassDefinesInstanceVariable: newTemporaryVariableName ifNone: [ ^ self ]. - - self signalNewVariableCanNotHideInstanceVariableDefinedIn: classDefiningNewVariable! ! -!NewTemporaryPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 2/22/2020 22:15:22'! - assertIsNotEmpty - - newTemporaryVariableName isEmpty ifTrue: [ self signalNewVariableCanNotBeEmpty ]! ! -!NewTemporaryPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 2/23/2020 20:32:31'! - assertIsValidVariableName - - | scannedNames | - scannedNames _ Scanner new scanFieldNames: newTemporaryVariableName. - scannedNames size = 1 ifFalse: [ self signalInvalidTemporaryVariable ]. - scannedNames first = newTemporaryVariableName ifFalse: [ self signalInvalidTemporaryVariable ].! ! -!NewTemporaryPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 2/23/2020 21:38:31'! - signalNewTemporaryVariableisAlreadyDefined - - self refactoringError: ( - self class - errorMessageForNewTemporaryVariable: newTemporaryVariableName - isAlreadyDefinedIn: methodNode)! ! -!NewTemporaryPrecondition methodsFor: 'exceptions' stamp: 'RNG 2/23/2020 20:39:23'! - signalInvalidTemporaryVariable - - self refactoringError: (self class errorMessageForInvalidTemporaryVariable: newTemporaryVariableName)! ! -!NewTemporaryPrecondition methodsFor: 'exceptions' stamp: 'RNG 2/23/2020 20:23:57'! - signalNewVariableCanNotBeEmpty - - self refactoringError: self class errorMessageForEmptyTemporaryVariable! ! -!NewTemporaryPrecondition methodsFor: 'exceptions' stamp: 'RNG 2/23/2020 20:39:02'! - signalNewVariableCanNotHideInstanceVariableDefinedIn: aClass - - self refactoringError: ( - self class - errorMessageFor: newTemporaryVariableName - canNotBeNamedAsInstanceVariableDefinedIn: aClass)! ! -!NewTemporaryPrecondition class methodsFor: 'evaluating' stamp: 'RNG 2/23/2020 21:42:24'! - valueFor: aNewTemporaryVariableName in: aBlockNode of: aMethodNode - - ^ (self for: aNewTemporaryVariableName in: aBlockNode of: aMethodNode) value! ! -!NewTemporaryPrecondition class methodsFor: 'instance creation' stamp: 'RNG 2/23/2020 21:41:24'! - for: aNewTemporaryVariableName in: aBlockNode of: aMethodNode - - ^ self new initializeFor: aNewTemporaryVariableName in: aBlockNode of: aMethodNode! ! -!NewTemporaryPrecondition class methodsFor: 'error messages' stamp: 'RNG 2/23/2020 20:39:50'! - errorMessageFor: aNewVariable canNotBeNamedAsInstanceVariableDefinedIn: aClass - - ^ aNewVariable, ' can not be named as instance variable defined in ', aClass name! ! -!NewTemporaryPrecondition class methodsFor: 'error messages' stamp: 'RNG 2/23/2020 20:23:44'! - errorMessageForEmptyTemporaryVariable - - ^ 'New variable can not be empty'! ! -!NewTemporaryPrecondition class methodsFor: 'error messages' stamp: 'RNG 2/22/2020 22:21:57'! - errorMessageForInvalidTemporaryVariable: aName - - ^ '''' , aName , ''' is not a valid temporary variable name'! ! -!NewTemporaryPrecondition class methodsFor: 'error messages' stamp: 'RNG 2/23/2020 21:38:55'! - errorMessageForNewTemporaryVariable: aNewVariable isAlreadyDefinedIn: aMethodNode - - ^ aNewVariable , ' is already defined in ' , aMethodNode classAndSelector! ! -!Encoder methodsFor: 'source mapping' stamp: 'RNG 2/20/2020 08:41:40' prior: 50488554! - parseNodesPathAt: aPosition using: completeSourceRanges ifAbsent: aBlockClosure - - | nodesWithRangeAtPosition | - nodesWithRangeAtPosition _ SortedCollection sortBlock: [ :nodePathOne :nodePathTwo | - nodePathOne value first >= nodePathTwo value first and: [ - nodePathOne value last <= nodePathTwo value last ] ]. - - completeSourceRanges associationsDo: [ :nodeAtRange | - self withRangesOf: nodeAtRange including: aPosition do: [ :aRange | - nodesWithRangeAtPosition add: (nodeAtRange key -> aRange) ] ]. - - ^ nodesWithRangeAtPosition - ifEmpty: aBlockClosure - ifNotEmpty: [ nodesWithRangeAtPosition ]! ! -!MessageNode methodsFor: 'source ranges' stamp: 'RNG 2/22/2020 20:42:15' prior: 50495121! - expandRanges: aSourceRange basedOn: sourceRanges using: sourceCode - - | receiverExpandedRanges expandedRangeWithReceiver | - receiverExpandedRanges _ self isCascade - ifTrue: [ self flag: #RNG . aSourceRange ] "fix source ranges for cascade messages" - ifFalse: [ receiver expandRanges: (self receiverSourceRangesFrom: sourceRanges) basedOn: sourceRanges using: sourceCode ]. - expandedRangeWithReceiver _ self - expandRange: (aSourceRange isInterval ifTrue: [ aSourceRange ] ifFalse: [ aSourceRange first ]) - basedOn: receiverExpandedRanges. - ^ super - expandRanges: expandedRangeWithReceiver - basedOn: expandedRangeWithReceiver - using: sourceCode! ! -!RenameTemporary class methodsFor: 'instance creation' stamp: 'RNG 2/23/2020 21:46:34' prior: 50487575! - fromOldVariableNode: anOldVariableNode to: aNewVariable in: aMethodNode - - | trimmedNewVariable blockNode | - - trimmedNewVariable := aNewVariable withBlanksTrimmed. - - self assertIsArgOrTempNode: anOldVariableNode. - self assert: anOldVariableNode isPartOf: aMethodNode. - - blockNode _ self blockNodeDeclaringTempNode: anOldVariableNode in: aMethodNode. - self newTemporaryPreconditionClass valueFor: trimmedNewVariable in: blockNode of: aMethodNode. - - ^ self new initializeFromOldVariableNode: anOldVariableNode to: trimmedNewVariable in: aMethodNode -! ! - -RenameTemporary class removeSelector: #errorMessageForInvalidTemporaryVariable:! - -!methodRemoval: RenameTemporary class #errorMessageForInvalidTemporaryVariable: stamp: 'Install-4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st 4/1/2020 17:56:04'! -errorMessageForInvalidTemporaryVariable: aName - - ^ '''' , aName , ''' is not a valid temporary variable name'.! - -RenameTemporary class removeSelector: #assertIsValidVariableName:! - -!methodRemoval: RenameTemporary class #assertIsValidVariableName: stamp: 'Install-4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st 4/1/2020 17:56:04'! -assertIsValidVariableName: aName - - | scannedNames | - - scannedNames _ Scanner new scanFieldNames: aName. - scannedNames size = 1 ifFalse: [ self signalInvalidTemporaryVariable: aName ]. - scannedNames first = aName ifFalse: [ self signalInvalidTemporaryVariable: aName ].! - -RenameTemporary class removeSelector: #assertIsNotEmpty:! - -!methodRemoval: RenameTemporary class #assertIsNotEmpty: stamp: 'Install-4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st 4/1/2020 17:56:04'! -assertIsNotEmpty: aNewVariable - - aNewVariable isEmpty ifTrue: [ self signalNewVariableCanNotBeEmpty ]! - -RenameTemporary class removeSelector: #signalNewVariableCanNotBeEmpty! - -!methodRemoval: RenameTemporary class #signalNewVariableCanNotBeEmpty stamp: 'Install-4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st 4/1/2020 17:56:04'! -signalNewVariableCanNotBeEmpty - - self refactoringError: self newVariableCanNotBeEmptyErrorMessage! - -RenameTemporary class removeSelector: #assert:isNotDeclaredInParseTreeBranchOfNodeDeclaring:in:! - -!methodRemoval: RenameTemporary class #assert:isNotDeclaredInParseTreeBranchOfNodeDeclaring:in: stamp: 'Install-4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st 4/1/2020 17:56:04'! -assert: aTempName isNotDeclaredInParseTreeBranchOfNodeDeclaring: aTempNode in: aMethodNode - - | blockNode | - - blockNode := self blockNodeDeclaringTempNode: aTempNode in: aMethodNode. - ((self is: aTempName declaredInChildrenOf: blockNode) or: [ - self is: aTempName declaredInParentsOf: blockNode in: aMethodNode ]) - ifTrue: [ self signalNewTemporaryVariable: aTempName isAlreadyDefinedIn: aMethodNode ].! - -RenameTemporary class removeSelector: #signalNewTemporaryVariable:isAlreadyDefinedIn:! - -!methodRemoval: RenameTemporary class #signalNewTemporaryVariable:isAlreadyDefinedIn: stamp: 'Install-4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st 4/1/2020 17:56:04'! -signalNewTemporaryVariable: aNewVariable isAlreadyDefinedIn: aMethodNode - - self refactoringError: (self errorMessageForNewTemporaryVariable: aNewVariable isAlreadyDefinedIn: aMethodNode )! - -RenameTemporary class removeSelector: #is:declaredInParentsOf:in:! - -!methodRemoval: RenameTemporary class #is:declaredInParentsOf:in: stamp: 'Install-4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st 4/1/2020 17:56:04'! -is: aTempName declaredInParentsOf: aBlockNode in: aMethodNode - - | parents | - - parents := (BlockNodeParentsFinder for: aBlockNode) parentsIn: aMethodNode. - parents add: aMethodNode. - ^self any: parents declaresTempNamed: aTempName! - -RenameTemporary class removeSelector: #signal:canNotHideInstanceVariableDefinedIn:! - -!methodRemoval: RenameTemporary class #signal:canNotHideInstanceVariableDefinedIn: stamp: 'Install-4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st 4/1/2020 17:56:04'! -signal: aNewVariable canNotHideInstanceVariableDefinedIn: aClass - - self refactoringError: (self errorMessageFor: aNewVariable canNotBeNamedAsInstanceVariableDefinedIn: aClass)! - -RenameTemporary class removeSelector: #is:declaredInChildrenOf:! - -!methodRemoval: RenameTemporary class #is:declaredInChildrenOf: stamp: 'Install-4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st 4/1/2020 17:56:04'! -is: aTempName declaredInChildrenOf: aBlockNode - - aBlockNode nodesDo: [ :node | - (node isBlockNode and: [ node hasLocallyArgumentOrTemporaryNamed: aTempName ]) ifTrue: [^true]]. - - ^false! - -RenameTemporary class removeSelector: #errorMessageFor:canNotBeNamedAsInstanceVariableDefinedIn:! - -!methodRemoval: RenameTemporary class #errorMessageFor:canNotBeNamedAsInstanceVariableDefinedIn: stamp: 'Install-4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st 4/1/2020 17:56:04'! -errorMessageFor: aNewVariable canNotBeNamedAsInstanceVariableDefinedIn: aClass - - ^aNewVariable, ' can not be named as instance variable defined in ', aClass name! - -RenameTemporary class removeSelector: #any:declaresTempNamed:! - -!methodRemoval: RenameTemporary class #any:declaresTempNamed: stamp: 'Install-4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st 4/1/2020 17:56:04'! -any: someBlockOrMethodNodes declaresTempNamed: aTempName - - ^someBlockOrMethodNodes anySatisfy: [ :node | node hasLocallyArgumentOrTemporaryNamed: aTempName]! - -RenameTemporary class removeSelector: #assert:isNotDefinedAsInstanceVariableInHierarchyOf:! - -!methodRemoval: RenameTemporary class #assert:isNotDefinedAsInstanceVariableInHierarchyOf: stamp: 'Install-4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st 4/1/2020 17:56:04'! -assert: aNewVariable isNotDefinedAsInstanceVariableInHierarchyOf: aClass - - | classDefiningNewVariable | - - classDefiningNewVariable := aClass whichClassDefinesInstanceVariable: aNewVariable ifNone: [ ^self ]. - self signal: aNewVariable canNotHideInstanceVariableDefinedIn: classDefiningNewVariable ! - -RenameTemporary class removeSelector: #signalInvalidTemporaryVariable:! - -!methodRemoval: RenameTemporary class #signalInvalidTemporaryVariable: stamp: 'Install-4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st 4/1/2020 17:56:04'! -signalInvalidTemporaryVariable: aName - - ^ self refactoringError: (self errorMessageForInvalidTemporaryVariable: aName).! - -RenameTemporary class removeSelector: #newVariableCanNotBeEmptyErrorMessage! - -!methodRemoval: RenameTemporary class #newVariableCanNotBeEmptyErrorMessage stamp: 'Install-4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st 4/1/2020 17:56:04'! -newVariableCanNotBeEmptyErrorMessage - - ^'New variable can not be empty'! - -RenameTemporary class removeSelector: #errorMessageForNewTemporaryVariable:isAlreadyDefinedIn:! - -!methodRemoval: RenameTemporary class #errorMessageForNewTemporaryVariable:isAlreadyDefinedIn: stamp: 'Install-4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st 4/1/2020 17:56:04'! -errorMessageForNewTemporaryVariable: aNewVariable isAlreadyDefinedIn: aMethodNode - - ^aNewVariable, ' is already defined in ', aMethodNode classAndSelector ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st----! - -'From Cuis 5.0 [latest update: #4047] on 25 February 2020 at 12:09:20 am'! - -"Change Set: 4048-CuisCore-AuthorName-2020Feb25-00h08m -Date: 25 February 2020 -Author: Nahuel Garbezza - -Remove old and unused implementation of the extract to temporary refactoring"! - -Smalltalk removeClassNamed: #ExtractToTemporary! - -!classRemoval: #ExtractToTemporary stamp: 'Install-4049-CuisCore-NahuelGarbezza-2020Feb25-00h08m-RNG.001.cs.st 4/1/2020 17:56:04'! -Refactoring subclass: #ExtractToTemporary - instanceVariableNames: 'newVariable parseNodeToExtract methodNodeToRefactor newTemporary' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4049-CuisCore-NahuelGarbezza-2020Feb25-00h08m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4049] on 29 February 2020 at 6:14:13 pm'! -!Parser methodsFor: 'expression types' stamp: 'HAW 2/29/2020 18:10:55' prior: 50409587! - variable - - ^self advanceWithRangeDo: [ :variableName :range | | varName result rightRange | - varName := variableName. - - "See ParserTest>>#testRangesAreOkWhenReturningAVariableWithoutSpaceAfterThat - There is a very difficult bug to fix. It happends when the source code ends with a return of a variable of - one char an no other char after that, for example: '^a' - In that case the range includes the ^ that is incorrect and makes the rename temporary fail. - I do this fix becuase changing how the range is calculated is almost imposible due to the coupling - and complexity of the parser. This change applies only to variables and therefore it assures no - unexpected behavior. I'm not cheching for size = 1 because it is redundant - Hernan" - rightRange := varName size = range size - ifTrue: [ range ] - ifFalse: [ range last - varName size + 1 to: range last ]. - - [result _ encoder encodeVariable: varName sourceRange: rightRange ifUnknown: [ nil ]. - result ifNil: [ - result _ (UndeclaredVariableReference new) - parser: self; - varName: varName; - varStart: rightRange first; - varEnd: rightRange last; - signal ]. - result isString ] whileTrue: [ varName _ result]. - encoder addMultiRange: rightRange for: result ]. - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4050-Parser-variableRangeFix-HernanWilkinson-2020Feb29-18h10m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4047] on 28 February 2020 at 12:34:49 pm'! -!FloatArray methodsFor: 'accessing' stamp: 'jmv 2/28/2020 12:09:11'! - floatAt: index - - ^Float fromIEEE32Bit: (self basicAt: index)! ! -!FloatArray methodsFor: 'accessing' stamp: 'jmv 2/28/2020 12:09:39'! - floatAt: index put: value - - value isFloat - ifTrue: [self basicAt: index put: value asIEEE32BitWord] - ifFalse: [self floatAt: index put: value asFloat]. - ^value! ! -!IntegerArray methodsFor: 'accessing' stamp: 'jmv 2/28/2020 12:22:43'! - integerAt: index - "Return the integer at the given index" - | word | - - word _ self basicAt: index. - word < 16r3FFFFFFF ifTrue:[^word]. "Avoid LargeInteger computations" - ^word >= 16r80000000 "Negative?!!" - ifTrue:["word - 16r100000000" - (word bitInvert32 + 1) negated] - ifFalse:[word]! ! -!IntegerArray methodsFor: 'accessing' stamp: 'jmv 2/28/2020 12:24:33'! - integerAt: index put: anInteger - "Store the integer at the given index" - | word | - - anInteger < 0 - ifTrue:["word _ 16r100000000 + anInteger" - word _ (anInteger + 1) negated bitInvert32] - ifFalse:[word _ anInteger]. - self basicAt: index put: word. - ^anInteger! ! -!FloatArray methodsFor: 'accessing' stamp: 'jmv 2/28/2020 12:11:02' prior: 16846406! - at: index - ^self floatAt: index! ! -!FloatArray methodsFor: 'accessing' stamp: 'jmv 2/28/2020 12:10:34' prior: 16846412! - at: index put: value - ^self floatAt: index put: value! ! -!IntegerArray methodsFor: 'accessing' stamp: 'jmv 2/28/2020 12:25:30' prior: 16861100! - at: index - ^self integerAt: index! ! -!IntegerArray methodsFor: 'accessing' stamp: 'jmv 2/28/2020 12:24:58' prior: 16861111! - at: index put: anInteger - ^self integerAt: index put: anInteger! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4051-enablePointCollectionSubclasses-JuanVuletich-2020Feb28-11h02m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4048] on 28 February 2020 at 6:23:37 pm'! -!AffineTransformation class methodsFor: 'instance creation' stamp: 'jmv 2/28/2020 18:12:45'! - withPointScale: aPoint position: otherPoint - " - (AffineTransformation withPointScale: 4@3) transform: 1@1 - " - ^self new - setPointScale: aPoint; - setTranslation: otherPoint! ! -!AffineTransformation class methodsFor: 'instance creation' stamp: 'jmv 2/28/2020 18:15:20' prior: 16778956! - withScale: aNumber - ^self new setPointScale: aNumber@aNumber! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4052-AffineTransformation-tweaks-JuanVuletich-2020Feb28-16h46m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4047] on 26 February 2020 at 2:26:37 pm'! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'pb 2/26/2020 12:39:06'! - fileReaderServicesForFileEntry: filename suffix: suffix - "FileList buttons that open a CodeFileBrowserWindow on contents." - - (#('st' 'cs' 'cs.st') includes: suffix) ifTrue: [ - ^ { self serviceBrowseCode } ]. - - (suffix = 'pck') | (suffix = 'pck.st') ifTrue: [ - ^ { self serviceBrowsePackage } ]. - - ^#()! ! -!ChangeList class methodsFor: 'fileIn/Out' stamp: 'pb 2/26/2020 12:39:06'! - fileReaderServicesForFileEntry: filename suffix: suffix - "FileList buttons that open a ChangeListWindow on contents" - - (#('st' 'cs' 'cs.st') includes: suffix) - ifTrue: [ ^ {self serviceContents} ]. - - (suffix = 'pck') | (suffix = 'pck.st') - ifTrue: [ ^ {self servicePackageContents} ]. - - suffix = 'changes' - ifTrue: [ ^ {self serviceRecentChanges} ]. - - ^#()! ! -!FileList methodsFor: 'file list menu' stamp: 'pb 2/26/2020 12:43:21'! - itemsForFileEntry: aFileEntry - "Answer a list of services appropriate for a file of the given name" - ^ self class itemsForFileEntry: aFileEntry! ! -!FileList class methodsFor: 'file reader registration' stamp: 'pb 2/26/2020 12:43:21'! - itemsForFileEntry: aFileEntry - "Answer a list of services appropriate for a file of the given name" - | services suffix classList | - " - suffix _ (FileIOAccessor default extensionFor: filename) asLowercase. - " - suffix := aFileEntry extension asLowercase. - "Build the list dynamically for all implementers of the appropriate class method... registration no longer required" - classList _ (Smalltalk allClassesImplementing: #fileReaderServicesForFileEntry:suffix:) - collect: [ :item | - item class == Metaclass ifTrue: [ item soleInstance ]] - thenSelect: [ :item | - item notNil ]. - services _ OrderedCollection new. - classList do: [ :reader | - services addAll: - (reader - fileReaderServicesForFileEntry: aFileEntry - suffix: suffix) ]. - services sort: [ :a :b | a sortOrder < b sortOrder ]. - ^ services.! ! -!FileEntry methodsFor: 'accessing' stamp: 'pb 2/26/2020 13:37:21'! - baseDirectory - "The directory this file is located in" - ^ DirectoryEntry - withPathComponents: self pathComponents allButLast - drive: nil.! ! -!ChangeSet class methodsFor: 'file list services' stamp: 'pb 2/26/2020 12:39:06'! - fileReaderServicesForFileEntry: filename suffix: suffix - "These would better be done by ChangeSorter!!" - - (#('cs' 'cs.st') includes: suffix) ifTrue: [ - ^{self serviceInstall} ]. - - (#('st') includes: suffix) ifTrue: [ - ^{self serviceFileIn} ]. - - ^#()! ! -!CodePackageFile class methodsFor: 'file list services' stamp: 'pb 2/26/2020 12:39:06'! - fileReaderServicesForFileEntry: filename suffix: suffix - "FileList buttons that are serviced by us." - - (suffix = 'pck') | (suffix = 'pck.st') - ifTrue: [ ^ { self serviceInstallPackage } ]. - ^#()! ! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'pb 2/26/2020 14:25:31' prior: 50493069! - serviceBrowseCode - "Answer the service of opening a file-contents browser" - - ^ (SimpleServiceEntry - provider: self - label: 'browse code' - selector: #browseCodeFileEntry: - description: 'open a "file-contents browser" on this file, allowing you to view and selectively load its code' - buttonLabel: 'code' - icon: #editFindReplaceIcon) - sortOrder: 10! ! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'pb 2/26/2020 14:25:39' prior: 50493086! - serviceBrowsePackage - "Answer the service of opening a file-contents browser" - - ^ (SimpleServiceEntry - provider: self - label: 'browse package' - selector: #browsePackageFileEntry: - description: 'open a "package file browser" on this file, allowing you to view and selectively load its code' - buttonLabel: 'package browser' - icon: #editFindReplaceIcon) - sortOrder: 10! ! -!ChangeList class methodsFor: 'public access' stamp: 'pb 2/26/2020 12:46:51' prior: 50406179! - browseRecentLogOn: origChangesFileEntry - "figure out where the last snapshot or quit was, then browse the recent entries." - - | end done block positions prevBlock | - origChangesFileEntry readStreamDo: [ :changesFile | - positions _ SortedCollection new. - end _ changesFile size. - prevBlock _ end. - block _ end - 1024 max: 0. - done _ false. - [ done or: [ positions size > 0 ]] - whileFalse: [ - changesFile position: block. - "ignore first fragment" - changesFile nextChunk. - [ changesFile position < prevBlock ] - whileTrue: [ - | pos chunk | - pos _ changesFile position. - chunk _ changesFile nextChunk. - ((Smalltalk isQuitRecord: chunk) or: [ Smalltalk isSnapshotRecord: chunk ]) - ifTrue: [ positions add: pos ]]. - block = 0 - ifTrue: [done _ true] - ifFalse: [ - prevBlock _ block. - block _ block - 1024 max: 0]]. - ]. - self browseRecentLogOn: origChangesFileEntry startingFrom: (positions isEmpty ifTrue: [0] ifFalse: [positions last])! ! -!ChangeList class methodsFor: 'fileIn/Out' stamp: 'pb 2/26/2020 14:25:02' prior: 50427056! - serviceContents - "Answer a service for opening a changelist browser on a file" - - ^ (SimpleServiceEntry - provider: self - label: 'see code file contents' - selector: #browseContents: - description: 'open a code file contents tool on this file' - buttonLabel: 'contents' - icon: #changesIcon) - sortOrder: 20! ! -!ChangeList class methodsFor: 'fileIn/Out' stamp: 'pb 2/26/2020 14:25:10' prior: 50427071! - servicePackageContents - "Answer a service for opening a changelist browser on a file" - - ^ (SimpleServiceEntry - provider: self - label: 'see package file contents' - selector: #browsePackageContents: - description: 'open a code file contents tool on this package file' - buttonLabel: 'pck contents' - icon: #changesIcon) - sortOrder: 20! ! -!FileList methodsFor: 'initialization' stamp: 'pb 2/26/2020 12:43:21' prior: 16842586! - dynamicButtonServices - "Answer services for buttons that may come and go in the button pane, depending on selection" - - ^ fileName isEmptyOrNil - ifTrue: - [#()] - ifFalse: - [ | toReject | - toReject _ self buttonSelectorsToSuppress. - (self itemsForFileEntry: self selectedFileEntry) reject: - [:svc | toReject includes: svc selector]]! ! -!SimpleServiceEntry methodsFor: 'performing service' stamp: 'pb 2/26/2020 14:24:39' prior: 16907933! - getArgumentsFrom: aProvider - - argumentGetter ifNil: [^aProvider selectedFileEntry ]. - ^argumentGetter value: aProvider! ! -!FileListWindow methodsFor: 'menu building' stamp: 'pb 2/26/2020 12:43:21' prior: 16843400! - fileSelectedMenu - - | itemsPart1 itemsPart2 itemsPart3 itemsPart4 n1 n2 n3 services aMenu | - aMenu _ MenuMorph new defaultTarget: model. - itemsPart1 _ model itemsForAnyFile1. - itemsPart2 _ model itemsForFileEntry: model selectedFileEntry. - itemsPart3 _ model itemsForAnyFile2. - itemsPart4 _ model itemsForNoFile. - n1 _ itemsPart1 size. - n2 _ n1 + itemsPart2 size. - n3 _ n2 + itemsPart3 size. - services _ itemsPart1, itemsPart2, itemsPart3, itemsPart4. - services do: [ :svc | svc when: #fileListChanged send: #updateFileList to: model ]. - ^ aMenu - addServices: services - for: model - extraLines:{ n1 . n2 . n3 } -! ! -!DropFilesAction methodsFor: 'evaluating - private' stamp: 'pb 2/26/2020 12:43:21' prior: 50427266! - fileNamedDropped: aFileName - - | options selectionIndex menu | - - selectedFileEntry := aFileName asFileEntry. - options := FileList itemsForFileEntry: selectedFileEntry. - options isEmpty ifTrue: [ ^self inform: 'No action found for ', selectedFileEntry name ]. - menu := self createMenuFor: options. - - selectionIndex := menu startUpWithCaption: 'Select action for ', selectedFileEntry name. - - selectionIndex = 0 ifTrue: [ ^self ]. - (options isInBounds: selectionIndex) ifTrue: [ ^self performService: (options at: selectionIndex) ]. - "The only available option is 'stop here'. This could change if #createMenuFor: changes - Hernan" - stopHereBlock value - -! ! -!ChangeSet class methodsFor: 'file list services' stamp: 'pb 2/26/2020 14:25:16' prior: 50427290! - serviceFileIn - "Answer a service for filing in an entire file" - - ^ (SimpleServiceEntry - provider: self - label: 'file in' - selector: #fileIn: - description: 'file in the entire contents of the file, which is expected to contain Smalltalk code in fileout ("chunk") format' - buttonLabel: 'filein' - icon: #saveIcon) - sortOrder: 100! ! -!ChangeSet class methodsFor: 'file list services' stamp: 'pb 2/26/2020 14:25:23' prior: 50427306! - serviceInstall - "Answer a service for filing in an entire file" - - ^ (SimpleServiceEntry - provider: self - label: 'install code' - selector: #install: - description: 'install change set' - buttonLabel: 'install' - icon: #saveIcon) - sortOrder: 100! ! -!CodePackageFile class methodsFor: 'file list services' stamp: 'pb 2/26/2020 14:25:45' prior: 50427320! - serviceInstallPackage - "Answer the service of installing a CodePackageFile (a chunk format file for a CodePackage)" - - ^ (SimpleServiceEntry - provider: self - label: 'install package' - selector: #installPackage: - description: 'install the package, replacing all existing code in the package (if any); create a new change set just for the installation' - buttonLabel: 'install package' - icon: #saveIcon) - sortOrder: 100! ! - -CodePackageFile class removeSelector: #fileReaderServicesForFile:suffix:! - -!methodRemoval: CodePackageFile class #fileReaderServicesForFile:suffix: stamp: 'Install-4053-fileReaderServices-use-FileEntry-PhilBellalouna-2020Feb26-12h37m-pb.001.cs.st 4/1/2020 17:56:04'! -fileReaderServicesForFile: filename suffix: suffix - "FileList buttons that are serviced by us." - - (suffix = 'pck') | (suffix = 'pck.st') - ifTrue: [ ^ { self serviceInstallPackage } ]. - ^#()! - -ChangeSet class removeSelector: #fileReaderServicesForFile:suffix:! - -!methodRemoval: ChangeSet class #fileReaderServicesForFile:suffix: stamp: 'Install-4053-fileReaderServices-use-FileEntry-PhilBellalouna-2020Feb26-12h37m-pb.001.cs.st 4/1/2020 17:56:04'! -fileReaderServicesForFile: filename suffix: suffix - "These would better be done by ChangeSorter!!" - - (#('cs' 'cs.st') includes: suffix) ifTrue: [ - ^{self serviceInstall} ]. - - (#('st') includes: suffix) ifTrue: [ - ^{self serviceFileIn} ]. - - ^#()! - -FileList class removeSelector: #itemsForFile:! - -!methodRemoval: FileList class #itemsForFile: stamp: 'Install-4053-fileReaderServices-use-FileEntry-PhilBellalouna-2020Feb26-12h37m-pb.001.cs.st 4/1/2020 17:56:04'! -itemsForFile: filename - "Answer a list of services appropriate for a file of the given name" - | services suffix classList | - suffix _ (FileIOAccessor default extensionFor: filename) asLowercase. - "Build the list dynamically for all implementers of the appropriate class method... registration no longer required" - classList _ (Smalltalk allClassesImplementing: #fileReaderServicesForFile:suffix:) - collect: [ :item | - item class == Metaclass ifTrue: [ item soleInstance ]] - thenSelect: [ :item | - item notNil ]. - services _ OrderedCollection new. - classList do: [ :reader | - services addAll: - (reader - fileReaderServicesForFile: filename - suffix: suffix) ]. - services sort: [ :a :b | a sortOrder < b sortOrder ]. - ^ services.! - -FileList removeSelector: #itemsForFile:! - -!methodRemoval: FileList #itemsForFile: stamp: 'Install-4053-fileReaderServices-use-FileEntry-PhilBellalouna-2020Feb26-12h37m-pb.001.cs.st 4/1/2020 17:56:04'! -itemsForFile: filename - "Answer a list of services appropriate for a file of the given name" - ^ self class itemsForFile: filename! - -ChangeList class removeSelector: #fileReaderServicesForFile:suffix:! - -!methodRemoval: ChangeList class #fileReaderServicesForFile:suffix: stamp: 'Install-4053-fileReaderServices-use-FileEntry-PhilBellalouna-2020Feb26-12h37m-pb.001.cs.st 4/1/2020 17:56:04'! -fileReaderServicesForFile: filename suffix: suffix - "FileList buttons that open a ChangeListWindow on contents" - - (#('st' 'cs' 'cs.st') includes: suffix) - ifTrue: [ ^ {self serviceContents} ]. - - (suffix = 'pck') | (suffix = 'pck.st') - ifTrue: [ ^ {self servicePackageContents} ]. - - suffix = 'changes' - ifTrue: [ ^ {self serviceRecentChanges} ]. - - ^#()! - -CodeFileBrowser class removeSelector: #fileReaderServicesForFile:suffix:! - -!methodRemoval: CodeFileBrowser class #fileReaderServicesForFile:suffix: stamp: 'Install-4053-fileReaderServices-use-FileEntry-PhilBellalouna-2020Feb26-12h37m-pb.001.cs.st 4/1/2020 17:56:04'! -fileReaderServicesForFile: filename suffix: suffix - "FileList buttons that open a CodeFileBrowserWindow on contents." - - (#('st' 'cs' 'cs.st') includes: suffix) ifTrue: [ - ^ { self serviceBrowseCode } ]. - - (suffix = 'pck') | (suffix = 'pck.st') ifTrue: [ - ^ { self serviceBrowsePackage } ]. - - ^#()! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4053-fileReaderServices-use-FileEntry-PhilBellalouna-2020Feb26-12h37m-pb.001.cs.st----! - -'From Cuis 5.0 [latest update: #4048] on 28 February 2020 at 4:42:54 pm'! -!IndentingListItemMorph methodsFor: 'geometry' stamp: 'KenD 2/28/2020 16:35:26'! - fontPreferenceChanged - - super fontPreferenceChanged. - self font: Preferences standardListFont.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4054-HonorFontPreferenceChange-KenD-2020Feb28-07h41m-KenD.001.cs.st----! - -'From Cuis 5.0 [latest update: #4047] on 3 March 2020 at 4:04:48 am'! -!Color class methodsFor: 'color from user' stamp: 'pb 3/3/2020 03:54:12' prior: 50357345! - colorPaletteForDepth: depth extent: chartExtent - "Display a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." - "Note: It is slow to build this palette, so it should be cached for quick access." - "(Color colorPaletteForDepth: 16 extent: 190@60) display" - - | basicHue x y startHue palette transHt vSteps transCaption grayWidth hSteps | - palette _ Form extent: chartExtent depth: depth. - transCaption _ - (Form extent: 34@9 depth: 1 - fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0) - offset: `0@0`). - transHt _ transCaption height. - palette fillWhite: (`0@0` extent: palette width@transHt). - palette fillBlack: (0@transHt extent: palette width@1). - transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0). - grayWidth _ 10. - startHue _ 338.0. - vSteps _ palette height - transHt // 2. - hSteps _ palette width - grayWidth. - x _ 0. - startHue to: startHue + 360.0 by: 360.0/hSteps do: [ :h | - basicHue _ Color h: h asFloat s: 1.0 v: 1.0. - y _ transHt+1. - 0 to: vSteps do: [ :n | | c | - c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Color white. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - 1 to: vSteps do: [ :n | | c | - c _ Color black mixed: (n asFloat / vSteps asFloat) with: basicHue. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - x _ x + 1]. - y _ transHt + 1. - 1 to: vSteps * 2 do: [ :n | | c | - c _ Color black mixed: (n asFloat / (vSteps*2) asFloat) with: Color white. - palette fill: (x@y extent: 10@1) fillColor: c. - y _ y + 1]. - ^ palette -! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:00:30' prior: 50470440! - bottomLeftCursor - ^ self - extent: `16 @ 16` - fromArray: #(49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 65532 65532 0 0 ) - offset: `0 @ -16`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:00:40' prior: 50470448! - bottomRightCursor - ^ self - extent: `16 @ 16` - fromArray: #(12 12 12 12 12 12 12 12 12 12 12 12 65532 65532 0 0 ) - offset: `-16 @ -16`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:00:50' prior: 50470455! - cornerCursor - "Answer the instance of me that is the shape of the bottom right corner - of a rectangle." - ^ self - extent: `16 @ 16` - fromArray: #(12 12 12 12 12 12 12 12 12 12 12 12 65532 65532 0 0 ) - offset: `-16 @ -16`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:01:07' prior: 50470465! - crossHairCursor - "Answer the instance of me that is the shape of a cross." - ^ self - extent: `16 @ 16` - fromArray: #(0 256 256 256 256 256 256 32764 256 256 256 256 256 256 0 0 ) - offset: `-7 @ -7`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:01:13' prior: 50470474! - downCursor - "Answer the instance of me that is the shape of an arrow facing - downward." - ^ self - extent: `16 @ 16` - fromArray: #(12288 12288 12288 12288 12288 12288 12288 64512 30720 12288 0 0 0 0 0 0 ) - offset: `0 @ 0`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:01:19' prior: 50470484! - executeCursor - "Answer the instance of me that is the shape of an arrow slanted left - with a star next to it." - ^ self - extent: `16 @ 16` - fromArray: #(32800 49184 57456 62462 63884 64648 65272 61656 55692 39172 3072 3072 1536 1536 0 0 ) - offset: `0 @ 0`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:01:27' prior: 16826365! - extent: extentPoint fromArray: anArray offset: offsetPoint - "Answer a new instance of me with width and height specified by - extentPoint, offset by offsetPoint, and bits from anArray. - NOTE: This has been kluged to take an array of 16-bit constants, - and shift them over so they are left-justified in a 32-bit bitmap" - - extentPoint = (`16 @ 16`) - ifTrue: - [^ super - extent: extentPoint - fromArray: (anArray collect: [:bits | bits bitShift: 16]) - offset: offsetPoint] - ifFalse: [self error: 'cursors must be 16@16']! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:01:32' prior: 50470495! - markerCursor - "Answer the instance of me that is the shape of a small ball." - ^ self - extent: `16 @ 16` - fromArray: #(28672 63488 63488 28672 0 0 0 0 0 0 0 0 0 0 0 0 ) - offset: `0 @ 0`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:01:37' prior: 50470504! - menuCursor - "Answer the instance of me that is the shape of a menu." - ^ self - extent: `16 @ 16` - fromArray: #(65504 32800 42528 32800 54112 65504 32800 45728 32800 44192 32800 42272 32800 65504 0 ) - offset: `0 @ 0`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:01:44' prior: 50470514! - moveCursor - "Answer the instance of me that is the shape of a cross inside a square." - ^ self - extent: `16 @ 16` - fromArray: #(65532 65532 49932 49932 49932 49932 65532 65532 49932 49932 49932 49932 65532 65532 0 0 ) - offset: `0 @ 0`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 03:48:43' prior: 16826384! - new - - ^ self extent: `16 @ 16` - fromArray: (Array new: 16 withAll: 0) - offset: `0 @ 0` - - "Cursor new bitEdit show"! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 03:48:52' prior: 50470524! - normalCursor - "Answer the instance of me that is the shape of an arrow slanted left." - ^ self - extent: `16 @ 16` - fromArray: #(32768 49152 57344 61440 63488 64512 65024 63488 63488 38912 3072 3072 1536 1536 768 768 ) - offset: `0 @ 0`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 03:49:10' prior: 50470534! - normalCursorWithMask - "Cursor initNormalWithMask. Cursor normal show" - "Next two lines work simply for any cursor..." - " - self initNormal. - NormalCursor _ CursorWithMask derivedFrom: NormalCursor. - " - "But for a good looking cursor, you have to tweak things..." - ^ (CursorWithMask - extent: `16 @ 16` - depth: 1 - fromArray: #(0 1073741824 1610612736 1879048192 2013265920 2080374784 2113929216 2130706432 2139095040 2080374784 1811939328 1174405120 100663296 50331648 50331648 0 ) - offset: -1 @ -1) setMaskForm: - (Form - extent: `16 @ 16` - depth: 1 - fromArray: #(3221225472 3758096384 4026531840 4160749568 4227858432 4261412864 4278190080 4286578688 4290772992 4292870144 4261412864 4009754624 3472883712 2273312768 125829120 58720256 ) - offset: `0 @ 0`).! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 03:49:18' prior: 50470561! -originCursor - "Answer the instance of me that is the shape of the top left corner of a - rectangle." - ^ self - extent: `16 @ 16` - fromArray: #(65532 65532 49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 0 0 ) - offset: `0 @ 0`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 03:49:28' prior: 50470572! - readCursor - "Answer the instance of me that is the shape of eyeglasses." - ^ self - extent: `16 @ 16` - fromArray: #(0 0 4104 10260 16416 64480 33824 33824 46496 31680 0 0 0 0 0 0 ) - offset: `0 @ 0`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:02:13' prior: 50470596! - resizeLeftCursor - ^ (self - extent: `16 @ 16` - fromArray: #(0 1152 1152 1152 5280 13488 29880 64764 29880 13488 5280 1152 1152 1152 0 0 ) - offset: `-7 @ -7`) withMask.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:02:22' prior: 50470609! - resizeTopCursor - ^ (self - extent: `16 @ 16` - fromArray: #(256 896 1984 4064 256 32764 0 0 32764 256 4064 1984 896 256 0 ) - offset: `-7 @ -7`) withMask.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:02:30' prior: 50470617! - resizeTopLeftCursor - ^ (self - extent: `16 @ 16` - fromArray: #(0 31760 30752 28740 26760 17680 544 1088 2176 4420 8748 1052 2108 124 0 0 ) - offset: `-7 @ -7`) withMask.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:02:37' prior: 50470625! - resizeTopRightCursor - ^ (self - extent: `16 @ 16` - fromArray: #(0 4220 2108 17436 8748 4420 2176 1088 544 17680 26760 28736 30752 31744 0 0 ) - offset: `-7 @ -7`) withMask.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 03:49:38' prior: 50470633! - rightArrowCursor - "Answer the instance of me that is the shape of an arrow pointing to the right." - ^ self - extent: `16 @ 16` - fromArray: #(1536 1920 2016 65528 2016 1920 1536 0 0 0 0 0 0 0 0 0 ) - offset: `0 @ 0`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:02:48' prior: 50470643! - squareCursor - "Answer the instance of me that is the shape of a square." - ^ self - extent: `16 @ 16` - fromArray: #(0 0 0 0 0 960 960 960 960 0 0 0 0 0 0 0 ) - offset: `-8 @ -8`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:02:56' prior: 50470651! - targetCursor - "Answer the instance of me that is the shape of a gunsight." - ^ self - extent: `16 @ 16` - fromArray: #(1984 6448 8456 16644 17284 33026 35106 65278 35106 33026 17284 16644 8456 6448 1984 0 ) - offset: `-7 @ -7`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 03:49:50' prior: 50470661! - topLeftCursor - ^ self - extent: `16 @ 16` - fromArray: #(65532 65532 49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 0 0 ) - offset: `0 @ 0`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:03:08' prior: 50470669! - topRightCursor - ^ self - extent: `16 @ 16` - fromArray: #(65532 65532 12 12 12 12 12 12 12 12 12 12 12 12 0 0 ) - offset: `-16 @ 0`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 03:49:59' prior: 50470676! - upCursor - "Answer the instance of me that is the shape of an arrow facing upward." - ^ self - extent: `16 @ 16` - fromArray: #(12288 30720 64512 12288 12288 12288 12288 12288 12288 12288 0 0 0 0 0 0 ) - offset: `0 @ 0`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 03:50:07' prior: 50470686! - waitCursor - "Answer the instance of me that is the shape of an Hourglass (was in the - shape of three small balls)." - ^ self - extent: `16 @ 16` - fromArray: #(65532 32772 16392 8208 7392 4032 1920 1920 2368 4384 8592 17352 36852 65532 0 ) - offset: `0 @ 0`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 03:50:19' prior: 50470697! - webLinkCursor - "Return a cursor that can be used for emphasizing web links" - ^ (CursorWithMask - extent: `16 @ 16` - fromArray: #(3072 4608 4608 4608 4608 5046 4681 29257 37449 37449 32769 32769 49155 16386 24582 16380 ) - offset: -5 @ 0) setMaskForm: - (Form - extent: `16 @ 16` - fromArray: - (#(3072 7680 7680 7680 7680 8118 8191 32767 65535 65535 65535 65535 65535 32766 32766 16380 ) collect: [ :bits | - bits bitShift: 16 ]) - offset: `0 @ 0`).! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 03:50:30' prior: 50470714! - writeCursor - "Answer the instance of me that is the shape of a pen writing." - ^ self - extent: `16 @ 16` - fromArray: #(24 60 72 144 288 580 1156 2316 4624 9232 30728 20728 57728 32512 0 0 ) - offset: `0 @ 0`.! ! -!CursorWithMask class methodsFor: 'as yet unclassified' stamp: 'pb 3/3/2020 03:54:50' prior: 16826711! - derivedFrom: aForm "Cursor initNormalWithMask. Cursor normal show" - "aForm is presumably a cursor" - | cursor mask ext | - ext _ aForm extent. - cursor _ self extent: ext. - cursor copy: (1@1 extent: ext) from: `0@0` in: aForm rule: Form over. - mask _ Form extent: ext. - (1@1) eightNeighbors do: - [:p | mask copy: (p extent: ext) from: `0@0` in: aForm rule: Form under]. - cursor setMaskForm: mask. - cursor offset: ((aForm offset - (1@1)) max: ext negated). - ^ cursor! ! -!Rectangle class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 03:51:23' prior: 50470994! - fromUser - "Answer a Rectangle that is determined by having the user - designate the top left and bottom right corners." - | originRect | - originRect _ (Cursor cursorAt: #originCursor) showWhile: [ - (Sensor mousePoint extent: `0 @ 0`) newRectFrom: [ :f | - Sensor mousePoint extent: `0 @ 0` ]]. - ^ (Cursor cursorAt: #cornerCursor) showWhile: [ - originRect newRectFrom: [ :f | - f origin corner: Sensor mousePoint ]].! ! -!StrikeFont methodsFor: 'emphasis' stamp: 'pb 3/3/2020 03:57:46' prior: 50458004! - makeItalicGlyphs - "Make an italic set of glyphs with same widths by skewing left and right. - In the process, characters would overlap, so we widen them all first. - " - | extraWidth newGlyphs newXTable x newX w extraOnLeft | - extraOnLeft _ (self lineSpacing-1-self ascent+4)//4 max: 0. - extraWidth _ ((self ascent-5+4)//4 max: 0) + extraOnLeft. - newGlyphs _ Form extent: (glyphs width + (maxAscii + 1 - minAscii*extraWidth)) @ glyphs height depth: glyphs depth. - newGlyphs fillWhite. - newXTable _ xTable copy. - - "Copy glyphs into newGlyphs with room on left and right for overlap." - minAscii to: maxAscii+1 do: - [:ascii | x _ xTable at: ascii+1. w _ (xTable at: ascii+2) - x. - newX _ newXTable at: ascii+1. - newGlyphs copy: ((newX + extraOnLeft) @ 0 extent: w @ glyphs height) - from: x @ 0 in: glyphs rule: Form over. - newXTable at: ascii+2 put: newX + w + extraWidth]. - glyphs _ newGlyphs. - xTable _ newXTable. - "Slide the bitmaps left and right for synthetic italic effect." - 4 to: self ascent-1 by: 4 do: - [:y | "Slide ascenders right..." - glyphs copy: (`1@0` extent: glyphs width @ (self ascent - y)) - from: `0@0` in: glyphs rule: Form over]. - self ascent to: self lineSpacing-1 by: 4 do: - [:y | "Slide descenders left..." - glyphs copy: (0@y extent: glyphs width @ glyphs height) - from: 1@y in: glyphs rule: Form over]. - self isSynthetic: true! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'pb 3/3/2020 03:57:26' prior: 50454181! - glyphAt: character put: characterForm - "Copy characterForm over the glyph for the argument, character." - | ascii leftX rightX widthDif newGlyphs | - ascii _ character numericValue. - ascii < minAscii ifTrue: [^ self error: 'Cant store characters below min ascii']. - ascii > maxAscii ifTrue: - [(self confirm: -'This font does not accomodate ascii values higher than ' , maxAscii printString , '. -Do you wish to extend it permanently to handle values up to ' , ascii printString) - ifTrue: [self extendMaxAsciiTo: ascii] - ifFalse: [^ self error: 'No change made']]. - leftX _ xTable at: ascii + 1. - rightX _ xTable at: ascii + 2. - widthDif _ characterForm width - (rightX - leftX). - widthDif ~= 0 ifTrue: - ["Make new glyphs with more or less space for this char" - newGlyphs _ Form extent: (glyphs width + widthDif) @ glyphs height depth: glyphs depth. - newGlyphs copy: (`0@0` corner: leftX@glyphs height) - from: `0@0` in: glyphs rule: Form over. - newGlyphs copy: ((rightX+widthDif)@0 corner: newGlyphs width@glyphs height) - from: rightX@0 in: glyphs rule: Form over. - glyphs _ newGlyphs. - "adjust further entries on xTable" - xTable _ xTable copy. - ascii+2 to: xTable size - do: [:i | xTable at: i put: (xTable at: i) + widthDif]]. - glyphs copy: (leftX @ 0 extent: characterForm extent) - from: 0@0 in: characterForm rule: Form over -" -| f | f _ AbstractFont default. -f glyphAt: $ put: (Form extent: (f widthOf: $ )+10@f lineSpacing) -"! ! -!StrikeFont methodsFor: 'building' stamp: 'pb 3/3/2020 03:57:08' prior: 50371981! - buildFromForm: allGlyphs data: data name: aString - - | x shortUnderscore firstGlyphInFiles | - pointSize _ data first asNumber. - ascent _ data second asNumber. - descent _ data third asNumber. - - firstGlyphInFiles _ 257-(data size-3). - minAscii _ 1. - maxAscii _ 255. - name _ aString. - type _ 0. "ignored for now" - superscript _ ascent - descent // 3. - subscript _ descent - ascent // 3. - emphasis _ 0. - - xTable _ (Array new: 258) atAllPut: 0. - maxWidth _ 0. - glyphs _ allGlyphs depth > 16 ifTrue: [ allGlyphs asFormOfDepth: 16 ] ifFalse: [ allGlyphs ]. - x _ 0. - 4 to: data size do: [ :i | - x _ (data at: i) asNumber. - xTable at: i+firstGlyphInFiles+1-4 put: x]. - xTable at: 258 put: x. - self reset. - derivativeFonts _ nil. - - self makeCrVisible. - - "Replace glyph for 127 (a box) with a short version of the underscore (used to optionally mark subscript in code)" - shortUnderscore _ self glyphAt: $_. - shortUnderscore _ shortUnderscore copy: (`0@0` extent: 1@shortUnderscore height). - self glyphAt: (Character numericValue: 127) put: shortUnderscore! ! -!StrikeFont methodsFor: 'building' stamp: 'pb 3/3/2020 03:57:59' prior: 16914891! - stripHighGlyphs - "Remove glyphs for characters above 128" - | i | - - characterToGlyphMap _ nil. - maxAscii _ 127. - - xTable _ xTable copyFrom: 1 to: maxAscii + 3. - i _ xTable at: maxAscii + 2. - xTable at: maxAscii + 3 put: i. - glyphs _ glyphs copy: (`0@0` extent: i+1@glyphs height). - maxWidth _ 0. - 2 to: xTable size do: [ :ii | - maxWidth _ maxWidth max: (xTable at: ii) - (xTable at: ii-1)-1 ]. - self reset! ! -!TileResizeMorph methodsFor: 'as yet unclassified' stamp: 'pb 3/3/2020 03:58:50' prior: 50413116! - resizeAtPoint: aPoint - - |region| - - region _ (aPoint min: extent - 1) // (extent // 3). - - ^ region caseOf: { - [`0@0`] -> [#topLeft]. - [`1@0`] -> [#top]. - [`2@0`] -> [#topRight]. - [`0@1`] -> [#left]. - [`1@1`] -> [#full]. - [`2@1`] -> [#right]. - [`0@2`] -> [#bottomLeft]. - [`1@2`] -> [#bottom]. - [`2@2`] -> [#bottomRight]. - } otherwise: [nil]! ! -!TileResizeMorph methodsFor: 'as yet unclassified' stamp: 'pb 3/3/2020 03:59:07' prior: 50413144! - selectionRectangle: region - - ^ region caseOf: { - [#topLeft] -> [`0@0` corner: (extent // 2)]. - [#top] -> [`0@0` corner: (extent x@(extent y // 2))]. - [#topRight] -> [(extent x // 2)@0 corner: (extent x@(extent y // 2))]. - [#left] -> [`0@0` corner: (extent x // 2)@extent y]. - [#full] -> [`0@0` corner: extent]. - [#right] -> [(extent x // 2)@0 corner: extent]. - [#bottomLeft] -> [0@(extent y // 2) corner: (extent x // 2)@extent y]. - [#bottomRight] -> [(extent x // 2)@(extent y // 2) corner: extent]. - [#bottom] -> [0@(extent y // 2) corner: extent]. - }! ! -!DraggingGuideMorph methodsFor: 'initialization' stamp: 'pb 3/3/2020 03:54:58' prior: 50426076! - initialize - - super initialize. - extent _ `0@0`.! ! -!HandMorph methodsFor: 'drawing' stamp: 'pb 3/3/2020 03:50:54' prior: 50471036! - drawOn: aCanvas - "Draw the hand itself (i.e., the cursor)." - "This method is only called when we are carrying morphs around..." - aCanvas - stencil: (Cursor cursorAt: #moveCursor) - at: `0 @ 0` - color: Color black.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4055-fix-some-Point-literals-PhilBellalouna-2020Mar03-03h47m-pb.001.cs.st----! - -'From Cuis 5.0 [latest update: #4047] on 3 March 2020 at 7:46:29 pm'! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 19:45:18' prior: 50492736! - browseCodeFileEntry: aFileEntry - ^ self browseCodeSource: (CodeFile newFromFile: aFileEntry )! ! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 19:45:11' prior: 50492742! - browseCodeSource: aCaseCodeSource - ^ self browseCodeSource: aCaseCodeSource base: nil! ! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 19:45:02' prior: 50492748! - browseCodeSource: aCaseCodeSource base: aBaseCodeSource - | useCaseCodeSource useCaseClasses browser useCaseOrganizer useHeading | - browser _ self new. - browser - caseCodeSource: aCaseCodeSource; - baseCodeSource: aBaseCodeSource. - useCaseCodeSource _ browser caseCodeSource. - useCaseClasses _ useCaseCodeSource classes collect: [ :ea | - ea name ]. - useCaseOrganizer _ useCaseCodeSource organization. - useHeading _ (useCaseCodeSource isLiveSmalltalkImage not and: [ browser baseCodeSource isLiveSmalltalkImage ]) - ifTrue: [ useCaseCodeSource name ] - ifFalse: [ "This is a non-standard configuration... make the user aware" - useCaseCodeSource name , '(' , useCaseCodeSource class name , '), target: ' , aBaseCodeSource name , '(' , aBaseCodeSource class name , ')' ]. - (useCaseCodeSource notNil and: [ useCaseCodeSource isLiveSmalltalkImage not ]) ifTrue: [ - useCaseOrganizer - classifyAll: useCaseClasses - under: useHeading ]. - browser - systemOrganizer: useCaseOrganizer; - caseCodeSource: useCaseCodeSource. - aBaseCodeSource ifNotNil: [ browser baseCodeSource: aBaseCodeSource ]. - ^ CodeFileBrowserWindow - open: browser - label: nil.! ! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 19:45:27' prior: 50492787! - browsePackageFileEntry: aFileEntry - ^ self browseCodeSource: (CodePackageFile newFromFile: aFileEntry )! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4056-CodeFileBrowser-does-not-return-instance-PhilBellalouna-2020Mar03-19h45m-pb.001.cs.st----! - -'From Cuis 5.0 [latest update: #4056] on 5 March 2020 at 9:55:36 pm'! -!ChangeSelectorSendersStepWindow methodsFor: 'actions' stamp: 'HAW 3/5/2020 21:07:36'! - changeSenders - - applier senders: model messageList - ! ! -!ChangeSelectorSendersStepWindow methodsFor: 'actions' stamp: 'HAW 3/5/2020 19:21:40'! - refactor - - self changeSenders. - super refactor ! ! -!ChangeSelectorKeepingParameters class methodsFor: 'convertion' stamp: 'HAW 3/5/2020 21:22:32'! - collectCompiledMethodsOf: aCollectionOfMethodReferences - - ^aCollectionOfMethodReferences collect: [ :aMethodReference | aMethodReference compiledMethod ]. - - ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - creation' stamp: 'HAW 3/5/2020 20:59:45'! - convertSendersToCompiledMethods - - senders := senders collect: [ :aMethodReference | aMethodReference compiledMethod ]! ! -!ChangeSelectorWizardStepWindow class methodsFor: 'instance creation' stamp: 'HAW 3/5/2020 21:05:27' prior: 50469726! - openFrom: aChangeSelectorApplier methods: methods label: aLabel selecting: somethingToSelect - - | window | - - window := self openMessageList: methods label: aLabel autoSelect: somethingToSelect. - window initializeFrom: aChangeSelectorApplier. - - ^window - -! ! -!ChangeSelectorImplementorsStepWindow class methodsFor: 'instance creation' stamp: 'HAW 3/5/2020 21:04:09' prior: 50469739! -openFrom: aChangeSelectorApplier - - ^self - openFrom: aChangeSelectorApplier - methods: (self methodReferencesOf: aChangeSelectorApplier implementors) - label: 'Implementors of #', aChangeSelectorApplier oldSelector, ' to Refactor' - selecting: nil -! ! -!ChangeSelectorSendersStepWindow methodsFor: 'actions' stamp: 'HAW 3/5/2020 19:25:10' prior: 50469259! - seeImplementors - - self changeSenders. - self delete. - - ChangeSelectorImplementorsStepWindow openFrom: applier! ! -!ChangeSelectorSendersStepWindow class methodsFor: 'instance creation' stamp: 'HAW 3/5/2020 21:05:36' prior: 50469750! - openFrom: aChangeSelectorApplier - - ^self - openFrom: aChangeSelectorApplier - methods: aChangeSelectorApplier senders asOrderedCollection - label: 'Senders of #', aChangeSelectorApplier oldSelector, ' to Refactor' - selecting: aChangeSelectorApplier oldSelector ! ! -!ChangeSelector class methodsFor: 'implementors and senders' stamp: 'HAW 3/5/2020 19:47:57' prior: 50438815! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategoriesAndHierarchyOf: aClass organizedBy: anOrganization - - | categories | - - categories := Set new. - - self - addImplementorsOf: anOldSelector - to: implementors - andSendersTo: senders - inHierarchyOf: aClass - doingPerClass: [:aClassInHierarchy | categories add: aClassInHierarchy category ]. - - categories do: [:aCategory | - self - addImplementorsOf: anOldSelector - to: implementors - andSendersTo: senders - inCategory: aCategory - organizedBy: anOrganization ]. -! ! -!ChangeSelector class methodsFor: 'implementors and senders' stamp: 'HAW 3/5/2020 19:48:17' prior: 50438835! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategory: aCategory organizedBy: anOrganization - - | classesInCategory | - - classesInCategory := anOrganization classesAt: aCategory. - classesInCategory do: [ :aPotentialClassToRefactor | - self - addImplementorsOf: anOldSelector - to: implementors - andSendersTo: senders - forClassAndMetaOf: aPotentialClassToRefactor ]. -! ! -!ChangeSelector class methodsFor: 'implementors and senders' stamp: 'HAW 3/5/2020 19:48:32' prior: 50438851! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inHierarchyOf: aClass - - self - addImplementorsOf: anOldSelector - to: implementors - andSendersTo: senders - inHierarchyOf: aClass - doingPerClass: [ :aClassInHierarchy | ] - - ! ! -!ChangeSelector class methodsFor: 'implementors and senders' stamp: 'HAW 3/5/2020 19:48:48' prior: 50468509! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inHierarchyOf: aClass doingPerClass: aBlock - - | highestClassImplementingOldSelector | - - highestClassImplementingOldSelector := aClass highestClassImplementing: anOldSelector ifNone: [ aClass ]. - highestClassImplementingOldSelector theNonMetaClass withAllSubclassesDo: [ :aPotentialClassToRefactor | - aPotentialClassToRefactor isMeta ifFalse: [ - self - addImplementorsOf: anOldSelector - to: implementors - andSendersTo: senders - forClassAndMetaOf: aPotentialClassToRefactor. - aBlock value: aPotentialClassToRefactor ]] - ! ! -!ChangeSelector class methodsFor: 'implementors and senders' stamp: 'HAW 3/5/2020 19:49:40' prior: 50438891! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders of: aPotentialClassToRefactor - - | potentialImplementor | - - potentialImplementor := aPotentialClassToRefactor compiledMethodAt: anOldSelector ifAbsent: [ nil ]. - potentialImplementor ifNotNil: [ implementors add: potentialImplementor ]. - - (aPotentialClassToRefactor whichSelectorsReferTo: anOldSelector) do: [ :aSelector | - senders add: (MethodReference class: aPotentialClassToRefactor selector: aSelector) ]! ! -!ChangeSelectorKeepingParameters class methodsFor: 'instance creation' stamp: 'HAW 3/5/2020 21:49:45' prior: 50447684! -from: anOldSelector to: aNewSelector in: aClassToRefactor - - | implementors senders | - - implementors := OrderedCollection new. - senders := OrderedCollection new. - - self - addImplementorsOf: anOldSelector - to: implementors - andSendersTo: senders - forClassAndMetaOf: aClassToRefactor theNonMetaClass. - - ^self from: anOldSelector to: aNewSelector implementors: implementors senders: (self collectCompiledMethodsOf: senders)! ! -!ChangeSelectorKeepingParameters class methodsFor: 'instance creation' stamp: 'HAW 3/5/2020 21:51:08' prior: 50447700! - from: anOldSelector to: aNewSelector inCategoriesAndHierarchyOf: aClass organizedBy: anOrganization - - | implementors senders | - - implementors := IdentitySet new. - senders := Set new. - - self - addImplementorsOf: anOldSelector - to: implementors - andSendersTo: senders - inCategoriesAndHierarchyOf: aClass - organizedBy: anOrganization. - - "I have to convert senders to OrderedCollection because CompiledMethod>>#= does not compare the class - where it is installed - Hernan" - ^self - from: anOldSelector - to: aNewSelector - implementors: implementors - senders: (self collectCompiledMethodsOf: senders asOrderedCollection) -! ! -!ChangeSelectorKeepingParameters class methodsFor: 'instance creation' stamp: 'HAW 3/5/2020 21:51:17' prior: 50447717! - from: anOldSelector to: aNewSelector inCategoryOf: aClass organizedBy: anOrganization - - | implementors senders | - - implementors := OrderedCollection new. - senders := OrderedCollection new. - - self - addImplementorsOf: anOldSelector - to: implementors - andSendersTo: senders - inCategory: aClass category - organizedBy: anOrganization. - - ^self from: anOldSelector to: aNewSelector implementors: implementors senders: (self collectCompiledMethodsOf: senders) -! ! -!ChangeSelectorKeepingParameters class methodsFor: 'instance creation' stamp: 'HAW 3/5/2020 21:51:28' prior: 50447734! - from: anOldSelector to: aNewSelector inHierarchyOf: aClass - - | implementors senders | - - implementors := OrderedCollection new. - senders := OrderedCollection new. - - self - addImplementorsOf: anOldSelector - to: implementors - andSendersTo: senders - inHierarchyOf: aClass. - - ^self from: anOldSelector to: aNewSelector implementors: implementors senders: (self collectCompiledMethodsOf: senders) - - ! ! -!ChangeSelectorKeepingParameters class methodsFor: 'instance creation' stamp: 'HAW 3/5/2020 21:51:40' prior: 50447749! - from: anOldSelector to: aNewSelector inSystem: aSystem - - | implementors senders | - - implementors := OrderedCollection new. - senders := OrderedCollection new. - - self - addImplementorsOf: anOldSelector - to: implementors - andSendersTo: senders - inSystem: aSystem. - - ^self from: anOldSelector to: aNewSelector implementors: implementors senders: (self collectCompiledMethodsOf: senders) - ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 3/5/2020 21:06:18' prior: 50469063! - createSenders - - ^Set new -! ! -!ChangeSelectorApplier methodsFor: 'refactoring - creation' stamp: 'HAW 3/5/2020 19:54:38' prior: 50441693! - createAndApplyRefactoring - - self convertSendersToCompiledMethods. - - self - createRefactoringHandlingRefactoringExceptions; - applyRefactoring; - informChangesToBrowser. - - shouldShowChanges ifTrue: [ self showChanges ] - - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4057-RemovingSendersInRefactoringFix-HernanWilkinson-2020Mar05-19h01m-HAW.002.cs.st----! - -'From Cuis 5.0 [latest update: #4057] on 7 March 2020 at 6:54:33 pm'! -!ChangeSelector class methodsFor: 'implementors and senders' stamp: 'HAW 3/7/2020 18:53:49' prior: 50499152! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders of: aPotentialClassToRefactor - - | potentialImplementor | - - "Phil B. requested to avoid refactoring OMeta2 classes, so right now - it avoids implementors and senders whose compilerClass is not Compiler - It is not common to subclass Compiler and keep Smalltalk syntax, that it is why I - check for Compiler and not for a list of allowed/disallowed compilers - Hernan" - aPotentialClassToRefactor compilerClass = Compiler ifFalse: [^self ]. - - potentialImplementor := aPotentialClassToRefactor compiledMethodAt: anOldSelector ifAbsent: [ nil ]. - potentialImplementor ifNotNil: [ implementors add: potentialImplementor ]. - - (aPotentialClassToRefactor whichSelectorsReferTo: anOldSelector) do: [ :aSelector | - senders add: (MethodReference class: aPotentialClassToRefactor selector: aSelector) ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4058-AvoidRefactoringOtherLanguageMethods-HernanWilkinson-2020Mar07-18h27m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4057] on 7 March 2020 at 8:14:42 pm'! - -"Change Set: 4058-CuisCore-AuthorName-2020Mar06-09h46m -Date: 7 March 2020 -Author: Nahuel Garbezza - -Fix flaky test on the ExtractMethod refactoring"! -!Encoder methodsFor: 'source mapping' stamp: 'RNG 3/6/2020 16:41:44'! - criteriaToSortSourceRangeBetween: parseNodeWithSourceRangeOne and: parseNodeWithSourceRangeTwo - - | sourceRangeOne sourceRangeTwo | - sourceRangeOne _ parseNodeWithSourceRangeOne value. - sourceRangeTwo _ parseNodeWithSourceRangeTwo value. - ^ sourceRangeOne first > sourceRangeTwo first - or: [ sourceRangeOne first = sourceRangeTwo first - and: [ sourceRangeOne last <= sourceRangeTwo last ] ]! ! -!Encoder methodsFor: 'source mapping' stamp: 'RNG 3/6/2020 16:40:40' prior: 50497469! - parseNodesPathAt: aPosition using: completeSourceRanges ifAbsent: aBlockClosure - - | nodesWithRangeAtPosition | - nodesWithRangeAtPosition _ SortedCollection sortBlock: [ :parseNodeWithSourceRangeOne :parseNodeWithSourceRangeTwo | - self criteriaToSortSourceRangeBetween: parseNodeWithSourceRangeOne and: parseNodeWithSourceRangeTwo ]. - - completeSourceRanges associationsDo: [ :nodeAtRange | - self withRangesOf: nodeAtRange including: aPosition do: [ :aRange | - nodesWithRangeAtPosition add: (nodeAtRange key -> aRange) ] ]. - - ^ nodesWithRangeAtPosition - ifEmpty: aBlockClosure - ifNotEmpty: [ nodesWithRangeAtPosition ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4059-ExtractMethodFix-NahuelGarbezza-2020Mar06-09h46m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4057] on 6 March 2020 at 11:09:45 am'! -!ChangeList class methodsFor: 'public access' stamp: 'jmv 3/6/2020 11:08:35' prior: 50370761! - browseFrom: startPosition on: aChangesFileEntry labeled: aLabel - - " - ChangeList browseFrom: Smalltalk lastQuitLogPosition on: Smalltalk currentChangesName labeled: 'Lost changes' - " - - | changeList end | - - aChangesFileEntry readStreamDo: [ :changesFile | - end _ changesFile size. - changeList _ self new - scanFile: changesFile - from: startPosition - to: end. - ]. - - ChangeListWindow open: changeList label: aLabel! ! -!ChangeList class methodsFor: 'public access' stamp: 'jmv 3/6/2020 11:07:19' prior: 16796867! - browseRecent: charCount on: origChangesFileEntry - "Opens a changeList on the end of the specified changes log file" - - | changeList end | - origChangesFileEntry readStreamDo: [ :changesFile | - end _ changesFile size. - changeList _ self new - scanFile: changesFile - from: (0 max: end - charCount) - to: end. - ]. - ChangeListWindow open: changeList label: 'Recent changes'! ! -!ChangeList class methodsFor: 'public access' stamp: 'jmv 3/6/2020 11:07:42' prior: 16796882! - browseRecentLog - "ChangeList browseRecentLog" - "Prompt with a menu of how far back to go to browse the current image's changes log file" - ^ self - browseRecentLogOn: Smalltalk currentChangesName asFileEntry - startingFrom: Smalltalk lastQuitLogPosition! ! -!ChangeList class methodsFor: 'public access' stamp: 'jmv 3/6/2020 11:07:26' prior: 50406214! - browseRecentLogOn: origChangesFileEntry startingFrom: initialPos - "Prompt with a menu of how far back to go when browsing a changes file." - - | end banners positions pos chunk i | - origChangesFileEntry readStreamDo: [ :changesFile | - banners _ OrderedCollection new. - positions _ OrderedCollection new. - end _ changesFile size. - pos _ initialPos. - [pos = 0 - or: [banners size > 20]] "Go back at most 20 image exits" - whileFalse: [ - changesFile position: pos. - chunk _ changesFile nextChunk. - i _ chunk indexOfSubCollection: 'priorSource: ' startingAt: 1. - i > 0 - ifTrue: [ - positions addLast: pos. - banners addLast: (chunk copyFrom: 5 to: i - 2). - pos _ Number readFrom: (chunk copyFrom: i + 13 to: chunk size)] - ifFalse: [ - pos _ 0]]. - ]. - positions addLast: 0. - banners addLast: 'Whole file'. - pos _ (SelectionMenu labelList: banners selections: positions) - startUpWithCaption: 'Browse as far back as...'. - pos - ifNil: [^ self]. - self browseRecent: end - pos on: origChangesFileEntry! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'jmv 3/6/2020 11:08:54' prior: 50370779! - restoreLostChangesManually - - ChangeList browseFrom: LastQuitLogPosition on: self currentChangesName asFileEntry labeled: 'Lost changes' -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4060-fileName-fileEntry-fix-JuanVuletich-2020Mar06-11h06m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4058] on 7 March 2020 at 6:23:55 pm'! - -RectangleLikeMorph subclass: #LayoutMorph - instanceVariableNames: 'direction separation padding cachedMinExtent doAdoptWidgetsColor ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -!classDefinition: #LayoutMorph category: #'Morphic-Layouts' stamp: 'Install-4061-HonorMinimumExtent-fix-JuanVuletich-2020Mar07-18h23m-jmv.001.cs.st 4/1/2020 17:56:05'! -RectangleLikeMorph subclass: #LayoutMorph - instanceVariableNames: 'direction separation padding cachedMinExtent doAdoptWidgetsColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! -!Morph methodsFor: 'geometry' stamp: 'jmv 3/7/2020 18:19:05'! - minimumLayoutExtent - "This returns the minimum extent that the morph may be shrunk to. - It is expressed in the morph own coordinates, like morphExtent." - - | minExtent | - minExtent _ self minimumExtent. - ^ layoutSpec - ifNil: [ minExtent ] - ifNotNil: [ minExtent max: layoutSpec minimumLayoutWidth @ layoutSpec minimumLayoutHeight ]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 3/6/2020 18:01:08'! - fixedOrMinimumLayoutHeight - ^fixedHeight ifNil: [0]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 3/6/2020 18:01:13'! - fixedOrMinimumLayoutWidth - ^fixedWidth ifNil: [0]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 3/6/2020 17:59:40'! - minimumLayoutHeight - "Generally prefer asking the morph itself!!" - - proportionalHeight ifNil: [ ^0 ]. - ^fixedHeight ifNil: [0]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 3/6/2020 17:59:48'! - minimumLayoutWidth - "Generally prefer asking the morph itself!!" - - proportionalWidth ifNil: [ ^0 ]. - ^fixedWidth ifNil: [0]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 3/6/2020 18:02:32'! -proportionaLayoutlHeight - - ^ proportionalHeight ifNil: [ 0 ]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 3/6/2020 18:03:02'! - proportionalLayoutWidth - - ^ proportionalWidth ifNil: [ 0 ]! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 3/7/2020 18:19:15' prior: 50384187! - minimumExtent - "This returns the minimum extent that the morph may be shrunk to. - It is expressed in the morph own coordinates, like morphExtent." - - ^ `1@1`! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 3/7/2020 18:16:34' prior: 16889705! - minimumExtent - | minW minH | - "Figure out the minimum extent for this pane so that either content, or at least required scrollbars, will fit" - minW _ self xtraBorder * 2 + scroller morphWidth min: self scrollBarClass scrollbarThickness * 2. - self vIsScrollbarShowing - ifTrue: [ - minW _ minW + self scrollBarClass scrollbarThickness]. - minH _ self xtraBorder * 2 + scroller morphHeight. - self hIsScrollbarShowing - ifTrue: [ - minH _ minH + self scrollBarClass scrollbarThickness]. - minH _ minH min: self scrollBarClass scrollbarThickness * 2. - ^ (minW + (borderWidth * 2)) @ (minH + (borderWidth * 2))! ! -!BrowserCommentTextMorph methodsFor: 'displaying' stamp: 'jmv 3/6/2020 18:37:46' prior: 16792955! - hidePane - - self hide. - separator visible ifTrue: [ - proportionalHeight _ self layoutSpec proportionaLayoutlHeight. - separatorHeight _ separator layoutSpec fixedOrMinimumLayoutHeight ]. - separator layoutSpec fixedHeight: 0. - self layoutSpec proportionalHeight: 0. - separator ifNotNil: [ separator hide ]! ! -!SystemWindow methodsFor: 'geometry' stamp: 'jmv 3/7/2020 18:16:44' prior: 50384680! - minimumExtent - - ^layoutMorph minimumExtent + (borderWidth * 2) + (0@self labelHeight)! ! -!LayoutMorph methodsFor: 'adjust' stamp: 'jmv 3/7/2020 18:19:33' prior: 50375336! - adjustHorizontallyBy: aLayoutAdjustMorph at: aPoint - | delta l ls r rs lNewWidth rNewWidth i lCurrentWidth rCurrentWidth | - i _ submorphs indexOf: aLayoutAdjustMorph. - l _ self submorphs at: i +1. - ls _ l layoutSpec. - lCurrentWidth _ l morphWidth max: 1. "avoid division by zero" - r _ self submorphs at: i - 1. - rs _ r layoutSpec. - rCurrentWidth _ r morphWidth max: 1. "avoid division by zero" - delta _ aPoint x - aLayoutAdjustMorph referencePosition x. - delta _ delta max: l minimumLayoutExtent x - lCurrentWidth. - delta _ delta min: rCurrentWidth - r minimumLayoutExtent x. - delta = 0 ifTrue: [ ^self ]. - rNewWidth _ rCurrentWidth - delta. - lNewWidth _ lCurrentWidth + delta. - (ls isProportionalWidth and: [ rs isProportionalWidth ]) - ifTrue: [ | leftNewProportion rightNewProportion toDistribute | "If both proportional, update them" - leftNewProportion _ lNewWidth / (lNewWidth + rNewWidth). - rightNewProportion _ 1.0 - leftNewProportion. - toDistribute _ ls proportionalLayoutWidth + rs proportionalLayoutWidth. - ls setProportionalWidth: leftNewProportion * toDistribute. - rs setProportionalWidth: rightNewProportion * toDistribute ] - ifFalse: ["If at least one is fixed, update only the fixed" - ls isProportionalWidth ifFalse: [ - ls fixedOrMorphWidth: lNewWidth ]. - rs isProportionalWidth ifFalse: [ - rs fixedOrMorphWidth: rNewWidth ]]. - self layoutSubmorphs.! ! -!LayoutMorph methodsFor: 'adjust' stamp: 'jmv 3/7/2020 18:19:39' prior: 16863103! - adjustVerticallyBy: aLayoutAdjustMorph at: aPoint - | delta t ts b bs tNewHeight bNewHeight i tCurrentHeight bCurrentHeight | - i _ submorphs indexOf: aLayoutAdjustMorph. - t _ self submorphs at: i +1. - ts _ t layoutSpec. - tCurrentHeight _ t morphHeight max: 1. "avoid division by zero" - b _ self submorphs at: i - 1. - bs _ b layoutSpec. - bCurrentHeight _ b morphHeight max: 1. "avoid division by zero" - delta _ aPoint y - aLayoutAdjustMorph referencePosition y. - delta _ delta max: t minimumLayoutExtent y - tCurrentHeight. - delta _ delta min: bCurrentHeight - b minimumLayoutExtent y. - delta = 0 ifTrue: [ ^self ]. - tNewHeight _ tCurrentHeight + delta. - bNewHeight _ bCurrentHeight - delta. - (ts isProportionalHeight and: [ bs isProportionalHeight ]) - ifTrue: [ | bottomNewProportion toDistribute topNewProportion | "If both proportional, update them" - topNewProportion _ tNewHeight / (tNewHeight + bNewHeight). - bottomNewProportion _ 1.0 - topNewProportion. - toDistribute _ ts proportionaLayoutlHeight + bs proportionaLayoutlHeight. - ts setProportionalHeight: topNewProportion * toDistribute. - bs setProportionalHeight: bottomNewProportion * toDistribute ] - ifFalse: ["If at least one is fixed, update only the fixed" - ts isProportionalHeight ifFalse: [ - ts fixedOrMorphHeight: tNewHeight ]. - bs isProportionalHeight ifFalse: [ - bs fixedOrMorphHeight: bNewHeight ]]. - self layoutSubmorphs! ! -!LayoutMorph methodsFor: 'geometry' stamp: 'jmv 3/7/2020 18:20:11' prior: 16863282! - minimumExtent - "Answer size sufficient to frame my submorphs." - - | width height | - width := self ySeparation. - height := self xSeparation. - (self direction = #vertical) - ifTrue: [ - self submorphsDo: [ :sm | | smMinExtent | - smMinExtent := sm minimumLayoutExtent. - "use maximum width across submorphs" - width := width max: (smMinExtent x max: sm layoutSpec fixedOrMinimumLayoutWidth). - "sum up submorph heights" - height := height + (smMinExtent y max: sm layoutSpec fixedOrMinimumLayoutHeight) + self ySeparation. - ]. - width := width + self xSeparation. - ] - ifFalse: [ - self submorphsDo: [ :sm | | smMinExtent | - smMinExtent := sm minimumLayoutExtent. - "sum up submorphs width" - width := width + (smMinExtent x max: sm layoutSpec fixedOrMinimumLayoutWidth) + self xSeparation. - "use maximum height across submorph" - height := height max: (smMinExtent y max: sm layoutSpec fixedOrMinimumLayoutHeight). - ]. - height := height + self xSeparation. - ]. - - ^ (width @ height) + self extentBorder! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 3/7/2020 18:19:43' prior: 50385340! - layoutSubmorphsHorizontallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - | xSep ySep usableWidth sumOfFixedOrMinimum normalizationFactor availableForPropWidth - fractionalWidths integerWidths theLeft usableHeight boundsTop boundsRight theTop minWidth submorphsToLayout - nextMorph ht wd ls theRight boundsBottom theBottom alternativeWidths count diff i | - - boundsForLayout extent > `2@2` "self minimumExtent" - ifFalse: [ ^self ]. "Too small. Don't bother!!" - - submorphsToLayout := self submorphsToLayout. - xSep := self xSeparation. - ySep := self ySeparation. - usableWidth := boundsForLayout width - ((submorphsToLayout size + 1) * xSep). - sumOfFixedOrMinimum := submorphsToLayout sum: [ :m | m minimumLayoutExtent x max: m layoutSpec fixedOrMinimumLayoutWidth ]. - availableForPropWidth := usableWidth - sumOfFixedOrMinimum max: 0. - normalizationFactor := self proportionalWidthNormalizationFactor. - availableForPropWidth := availableForPropWidth * normalizationFactor. - - fractionalWidths := submorphsToLayout collect: [ :m | m layoutSpec widthFor: availableForPropWidth ]. - "Compute integer widths, mostly rounding but with occasional #floor or #ceiling as needed to keep sum" - integerWidths _ fractionalWidths collect: [ :w | w rounded ]. - diff _ integerWidths sum - fractionalWidths sum rounded. - alternativeWidths _ diff > 0 ifTrue: [ fractionalWidths collect: [ :w | w floor ]] ifFalse: [ fractionalWidths collect: [ :w | w ceiling ]]. - count _ diff abs. - i _ 1. - [ count > 0] whileTrue: [ - (integerWidths at: i) = (alternativeWidths at: i) ifFalse: [ - integerWidths at: i put: (alternativeWidths at: i). - count _ count -1 ]. - i _ i + 1 ]. - minWidth := integerWidths sum. - theLeft := ((usableWidth - minWidth) * (padding ifNil: [0]) max: 0) + boundsForLayout left + xSep. - usableHeight := boundsForLayout height - (ySep * 2) max: 0. - boundsTop := boundsForLayout top + ySep. - boundsRight := boundsForLayout right - xSep. - boundsBottom := boundsForLayout bottom - ySep. - - submorphsToLayout size to: 1 by: -1 do: [ :index | - nextMorph := submorphsToLayout at: index. - "major direction" - wd := integerWidths at: index. - "minor direction" - ls := nextMorph layoutSpec. - ht := (ls heightFor: usableHeight) min: usableHeight. - theTop := ((usableHeight - ht) * ls minorDirectionPadding) floor + boundsTop. - theBottom := (theTop + ht) ceiling min: boundsBottom. - theRight := (theLeft + (wd min: minWidth)) "ceiling "min: boundsRight. - "Set bounds and adjust major direction for next step" - self flag: #jmvVer2. "should extent be set in m's coordinate system? what if its scale is not 1?" - ls usesMorphExtent - ifTrue: [ - nextMorph morphPosition: theLeft floor @ theTop floor ] - ifFalse: [ - nextMorph morphPosition: theLeft floor @ theTop floor extent: theRight - theLeft @ (theBottom - theTop) ]. - theLeft := theRight + xSep - ]! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 3/7/2020 18:19:47' prior: 50385431! - layoutSubmorphsVerticallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - | xSep ySep usableHeight sumOfFixedOrMinimum normalizationFactor availableForPropHeight - fractionalHeights integerHeights theTop usableWidth boundsLeft boundsBottom theLeft minHeight submorphsToLayout - nextMorph ht wd ls theBottom boundsRight theRight alternativeHeights count diff i | - - boundsForLayout extent > `2@2` "self minimumExtent" - ifFalse: [ ^self ]. "Too small. Don't bother!!" - - submorphsToLayout := self submorphsToLayout. - xSep := self xSeparation. - ySep := self ySeparation. - usableHeight := boundsForLayout height - ((submorphsToLayout size + 1) * ySep). - sumOfFixedOrMinimum := submorphsToLayout sum: [ :m | m minimumLayoutExtent y max: m layoutSpec fixedOrMinimumLayoutHeight ]. - availableForPropHeight := usableHeight - sumOfFixedOrMinimum max: 0. - normalizationFactor := self proportionalHeightNormalizationFactor. - availableForPropHeight := availableForPropHeight * normalizationFactor. - - fractionalHeights := submorphsToLayout collect: [ :m | m layoutSpec heightFor: availableForPropHeight ]. - "Compute integer widths, mostly rounding but with occasional #floor or #ceiling as needed to keep sum" - integerHeights _ fractionalHeights collect: [ :w | w rounded ]. - diff _ integerHeights sum - fractionalHeights sum rounded. - alternativeHeights _ diff > 0 ifTrue: [ fractionalHeights collect: [ :w | w floor ]] ifFalse: [ fractionalHeights collect: [ :w | w ceiling ]]. - count _ diff abs. - i _ 1. - [ count > 0] whileTrue: [ - (integerHeights at: i) = (alternativeHeights at: i) ifFalse: [ - integerHeights at: i put: (alternativeHeights at: i). - count _ count -1 ]. - i _ i + 1 ]. - minHeight := integerHeights sum. - theTop := ((usableHeight - minHeight) * (padding ifNil: [0]) max: 0) + boundsForLayout top + ySep. - usableWidth := boundsForLayout width - (xSep * 2) max: 0. - boundsLeft := boundsForLayout left + xSep. - boundsBottom := boundsForLayout bottom - ySep. - boundsRight := boundsForLayout right - xSep. - - submorphsToLayout size to: 1 by: -1 do: [ :index | - nextMorph := submorphsToLayout at: index. - "major direction" - ht := integerHeights at: index. - "minor direction" - ls := nextMorph layoutSpec. - wd := (ls widthFor: usableWidth) min: usableWidth. - theLeft := ((usableWidth - wd) * ls minorDirectionPadding) floor + boundsLeft. - theRight := (theLeft + wd) ceiling min: boundsRight. - theBottom := (theTop + (ht min: minHeight)) "ceiling" min: boundsBottom. - "Set bounds and adjust major direction for next step" - self flag: #jmvVer2. "should extent be set in m's coordinate system? what if its scale is not 1?" - ls usesMorphExtent - ifTrue: [ - nextMorph morphPosition: theLeft floor @ theTop floor ] - ifFalse: [ - nextMorph morphPosition: theLeft floor @ theTop floor extent: theRight - theLeft @ (theBottom - theTop) ]. - theTop := theBottom + ySep - ]! ! -!LayoutMorph methodsFor: 'private' stamp: 'jmv 3/6/2020 18:37:57' prior: 16863569! - proportionalHeightNormalizationFactor - - | sumOfProportional | - sumOfProportional _ self submorphsToLayout sum: [ :m | m layoutSpec proportionaLayoutlHeight ]. - ^1.0 / (sumOfProportional max: 1.0).! ! -!LayoutMorph methodsFor: 'private' stamp: 'jmv 3/6/2020 18:38:18' prior: 16863578! - proportionalWidthNormalizationFactor - - | sumOfProportional | - sumOfProportional _ self submorphsToLayout sum: [ :m | m layoutSpec proportionalLayoutWidth ]. - ^1.0 / (sumOfProportional max: 1.0).! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 3/6/2020 16:06:23' prior: 50359925! -example1 -" - self example1 -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example1. -pane color: Color red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addMorph: (BorderedRectMorph new color: (Color blue); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addMorph: (BorderedRectMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 200 fixedHeight: 200). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #G) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8); - addMorph: (BorderedRectMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (BorderedRectMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -pane morphPosition: 150@130 extent: 400@300. -pane openInWorld! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 3/7/2020 18:20:17' prior: 16864341! - heightFor: availableSpace - "If proportional is zero, answer stored fixed extent, or actual morph extent if undefined. - Otherwise, we do proportional layout, and the stored extent is a minimum extent. - If there is no minimum extent, it should be set to zero." - - ^proportionalHeight isNil - ifTrue: [fixedHeight ifNil: [morph morphHeight]] - ifFalse: [proportionalHeight * availableSpace + morph minimumLayoutExtent y]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 3/7/2020 18:20:21' prior: 16864364! - widthFor: availableSpace - "If proportional is zero, answer stored fixed extent, or actual morph extent if undefined. - Otherwise, we do proportional layout, and the stored extent is a minimum extent. - If there is no minimum extent, it should be set to zero." - - ^proportionalWidth isNil - ifTrue: [fixedWidth ifNil: [morph morphWidth]] - ifFalse: [proportionalWidth * availableSpace + morph minimumLayoutExtent x]! ! - -LayoutSpec removeSelector: #fixedWidth! - -!methodRemoval: LayoutSpec #fixedWidth stamp: 'Install-4061-HonorMinimumExtent-fix-JuanVuletich-2020Mar07-18h23m-jmv.001.cs.st 4/1/2020 17:56:05'! -fixedWidth - "If proportional is zero, answer stored fixed extent, or actual morph extent if undefined. (no proportional extent is computed) - Otherwise, we do proportional layout, and the stored extent is a minimum extent, so we don't really a fixed extent." - proportionalWidth ifNil: [ ^ fixedWidth ifNil: [ morph morphWidth ] ]. - ^ 0! - -LayoutSpec removeSelector: #proportionalHeight! - -!methodRemoval: LayoutSpec #proportionalHeight stamp: 'Install-4061-HonorMinimumExtent-fix-JuanVuletich-2020Mar07-18h23m-jmv.001.cs.st 4/1/2020 17:56:05'! -proportionalHeight - - ^ proportionalHeight ifNil: [ 0 ]! - -LayoutSpec removeSelector: #fixedHeight! - -!methodRemoval: LayoutSpec #fixedHeight stamp: 'Install-4061-HonorMinimumExtent-fix-JuanVuletich-2020Mar07-18h23m-jmv.001.cs.st 4/1/2020 17:56:05'! -fixedHeight - "If proportional is zero, answer stored fixed extent, or actual morph extent if undefined. (no proportional extent is computed) - Otherwise, we do proportional layout, and the stored extent is a minimum extent, so we don't really a fixed extent." - proportionalHeight ifNil: [ ^ fixedHeight ifNil: [ morph morphHeight ] ]. - ^ 0! - -LayoutSpec removeSelector: #proportionalWidth! - -!methodRemoval: LayoutSpec #proportionalWidth stamp: 'Install-4061-HonorMinimumExtent-fix-JuanVuletich-2020Mar07-18h23m-jmv.001.cs.st 4/1/2020 17:56:05'! -proportionalWidth - - ^ proportionalWidth ifNil: [ 0 ]! - -LayoutMorph removeSelector: #fontPreferenceChanged! - -!methodRemoval: LayoutMorph #fontPreferenceChanged stamp: 'Install-4061-HonorMinimumExtent-fix-JuanVuletich-2020Mar07-18h23m-jmv.001.cs.st 4/1/2020 17:56:05'! -fontPreferenceChanged - "Something may have changed. - Update my cache with the current size" - - super fontPreferenceChanged. - cachedMinExtent := self calculateMinimumExtent ! - -LayoutMorph removeSelector: #calculateMinimumExtent! - -!methodRemoval: LayoutMorph #calculateMinimumExtent stamp: 'Install-4061-HonorMinimumExtent-fix-JuanVuletich-2020Mar07-18h23m-jmv.001.cs.st 4/1/2020 17:56:05'! -calculateMinimumExtent - "Answer size sufficient to frame my submorphs." - - | width height | - width := self ySeparation. - height := self xSeparation. - (self direction = #vertical) - ifTrue: [ - self submorphsDo: [ :sm | | smMinExtent | - smMinExtent := sm minimumExtent. - "use maximum width across submorphs" - width := width max: smMinExtent x. - "sum up submorph heights" - height := height + smMinExtent y + self ySeparation. - ]. - width := width + self xSeparation. - ] - ifFalse: [ - self submorphsDo: [ :sm | | smMinExtent | - smMinExtent := sm minimumExtent. - "sum up submorphs width" - width := width + smMinExtent x + self xSeparation. - "use maximum height across submorph" - height := height max: smMinExtent y. - ]. - height := height + self xSeparation. - ]. - - ^ (width @ height) + self extentBorder.! - -LayoutMorph removeSelector: #minPaneHeightForReframe! - -!methodRemoval: LayoutMorph #minPaneHeightForReframe stamp: 'Install-4061-HonorMinimumExtent-fix-JuanVuletich-2020Mar07-18h23m-jmv.001.cs.st 4/1/2020 17:56:05'! -minPaneHeightForReframe - ^AbstractFont default lineSpacing + 10! - -LayoutMorph removeSelector: #minPaneWidthForReframe! - -!methodRemoval: LayoutMorph #minPaneWidthForReframe stamp: 'Install-4061-HonorMinimumExtent-fix-JuanVuletich-2020Mar07-18h23m-jmv.001.cs.st 4/1/2020 17:56:05'! -minPaneWidthForReframe - - ^(self submorphs collect: [ :m | m minimumExtent x ]) max! - -SystemWindow removeSelector: #minPaneWidthForReframe! - -!methodRemoval: SystemWindow #minPaneWidthForReframe stamp: 'Install-4061-HonorMinimumExtent-fix-JuanVuletich-2020Mar07-18h23m-jmv.001.cs.st 4/1/2020 17:56:05'! -minPaneWidthForReframe - ^ScrollBar scrollbarThickness * 3! - -SystemWindow removeSelector: #minPaneHeightForReframe! - -!methodRemoval: SystemWindow #minPaneHeightForReframe stamp: 'Install-4061-HonorMinimumExtent-fix-JuanVuletich-2020Mar07-18h23m-jmv.001.cs.st 4/1/2020 17:56:05'! -minPaneHeightForReframe - ^AbstractFont default lineSpacing + 10! - -Morph removeSelector: #minPaneWidthForReframe! - -!methodRemoval: Morph #minPaneWidthForReframe stamp: 'Install-4061-HonorMinimumExtent-fix-JuanVuletich-2020Mar07-18h23m-jmv.001.cs.st 4/1/2020 17:56:05'! -minPaneWidthForReframe - ^ self minimumExtent x! - -RectangleLikeMorph subclass: #LayoutMorph - instanceVariableNames: 'direction separation padding doAdoptWidgetsColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -!classDefinition: #LayoutMorph category: #'Morphic-Layouts' stamp: 'Install-4061-HonorMinimumExtent-fix-JuanVuletich-2020Mar07-18h23m-jmv.001.cs.st 4/1/2020 17:56:05'! -RectangleLikeMorph subclass: #LayoutMorph - instanceVariableNames: 'direction separation padding doAdoptWidgetsColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4061-HonorMinimumExtent-fix-JuanVuletich-2020Mar07-18h23m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4061] on 8 March 2020 at 4:29:11 pm'! -!LayoutMorph methodsFor: 'geometry' stamp: 'KenD 2/22/2020 16:55:11'! - refreshExtent - "Flush cache & recalculate" - self morphExtent: (self morphExtent max: self minimumExtent)! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 3/8/2020 16:27:44' prior: 50499491! - minimumLayoutExtent - "This returns the minimum extent that the morph may be shrunk to, when resizing LayoutMorphs or when adjusting a LayoutAdjustingMorph. - It is expressed in the morph own coordinates, like morphExtent." - - | minExtent | - minExtent _ self minimumExtent. - ^ layoutSpec - ifNil: [ minExtent ] - ifNotNil: [ minExtent max: layoutSpec minimumLayoutWidth @ layoutSpec minimumLayoutHeight ]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 3/8/2020 16:28:31' prior: 50499504! - fixedOrMinimumLayoutHeight - ^fixedHeight ifNil: [ morph morphHeight ]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 3/8/2020 16:28:20' prior: 50499508! - fixedOrMinimumLayoutWidth - ^fixedWidth ifNil: [ morph morphWidth ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4062-HonorMinimumExtent-part2-JuanVuletich-2020Mar08-16h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4059] on 8 March 2020 at 1:47:57 pm'! -!ScrollBar methodsFor: 'geometry' stamp: 'KenD 3/8/2020 13:40:38'! - fontPreferenceChanged - "Rescale" - - self recreateSubmorphs! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4063-CuisCoreScrollRsz-KenD-2020Mar08-13h37m-KenD.001.cs.st----! - -'From Cuis 5.0 [latest update: #4063] on 9 March 2020 at 10:14:50 am'! -!Morph methodsFor: 'testing' stamp: 'jmv 3/9/2020 10:11:38'! - isOwnedByWorld - ^owner is: #PasteUpMorph! ! -!PasteUpMorph methodsFor: 'testing' stamp: 'jmv 3/9/2020 10:13:47'! - is: aSymbol - ^ aSymbol == #PasteUpMorph or: [ super is: aSymbol ]! ! -!LayoutMorph methodsFor: 'accessing' stamp: 'KenD 2/24/2020 14:16:35'! - addMorphFrontFromWorldPosition: aMorph - - super addMorphFrontFromWorldPosition: aMorph. - self refreshExtent. -! ! -!PasteUpMorph methodsFor: 'geometry' stamp: 'jmv 3/9/2020 09:55:00' prior: 50495878! - fontPreferenceChanged - self recreateDefaultDesktop. - self submorphsDo: [ :m | - m morphExtent: (m morphExtent max: m minimumExtent). - m fontPreferenceChanged ]! ! -!SystemWindow methodsFor: 'geometry' stamp: 'jmv 3/9/2020 09:52:24' prior: 50499579! - minimumExtent - - ^layoutMorph minimumExtent + (borderWidth * 2) + (0@self labelHeight) max: self titleBarButtonsExtent x * 6 @ 0! ! -!LayoutMorph methodsFor: 'geometry' stamp: 'jmv 3/9/2020 10:14:14' prior: 50500183! - refreshExtent - "Flush cache & recalculate" - (self isOwnedByWorld or: [self isOwnedByHand]) ifTrue: [ - self morphExtent: (self morphExtent max: self minimumExtent) ]! ! -!LayoutMorph methodsFor: 'initialization' stamp: 'KenD 2/22/2020 11:41:51' prior: 16863292! - beColumn - direction _ #vertical. - self padding: #center. - self refreshExtent.! ! -!LayoutMorph methodsFor: 'initialization' stamp: 'KenD 2/22/2020 11:41:57' prior: 16863297! - beRow - direction _ #horizontal. - self padding: #left. - self refreshExtent.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4064-MinExtent-furtherTweaks-JuanVuletich-2020Mar09-10h06m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4064] on 11 March 2020 at 2:32:08 pm'! -!Morph methodsFor: 'drawing' stamp: 'jmv 3/11/2020 14:26:26'! - imageForm: extent depth: depth - | canvas | - canvas _ BitBltCanvas depth: depth over: (self morphPosition extent: (self morphExtent min: extent)). - canvas fullDraw: self. - ^ canvas form! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 3/11/2020 14:26:57' prior: 16874111! - icon - ^ (self imageForm: 400@300 depth: 32) - ifNil: [ Theme current morphsIcon ] - ifNotNil: [ :form | form icon ]! ! -!Morph methodsFor: 'printing' stamp: 'jmv 3/11/2020 14:27:36' prior: 50333020! - printOn: aStream - "Add the identity of the receiver to a stream" - aStream isText - ifTrue: [ - aStream - withAttribute: (TextAnchor new anchoredFormOrMorph: (owner ifNil: [self] ifNotNil: [self imageForm: 32@32 depth: 32])) - do: [ aStream nextPut: $* ]. - ^ self]. - super printOn: aStream. "a(n) className" - aStream - nextPut: $(; - print: self identityHash; - nextPut: $). - self valueOfProperty: #morphName ifPresentDo: [ :x | aStream nextPutAll: x asString]! ! -!SystemWindow class methodsFor: 'top window' stamp: 'jmv 3/11/2020 14:30:03' prior: 16926881! - noteTopWindowIn: aWorld but: aWindow - | newTop | - "TopWindow must be nil or point to the top window in this project." - TopWindow _ nil. - aWorld ifNil: [^ nil]. - newTop := aWorld submorphs - detect: [:m | (m is: #SystemWindow) and: [m visible and: [m ~~ aWindow]]] - ifNone: [^nil]. - newTop activate. - ^newTop! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 3/11/2020 14:27:17' prior: 50431936! - addButtonFor: aMorph - - | button | - aMorph == self ifFalse: [ - button _ HoverableButtonMorph - model: aMorph - stateGetter: nil - action: #endPreviewAndToggleCollapseOrShow - onMouseEnterSend: #beginPreview - onMouseLeaveSend: #endPreview. - button - color: self color; - icon: (aMorph imageForm: 400@300 depth: 32); - setBalloonText: #label. - button icon: button magnifiedIcon. - viewBox - addMorph: button - fixedWidth: self defaultHeight ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4065-AvoidPotentialHugeFormAllocation-JuanVuletich-2020Mar11-14h17m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4064] on 11 March 2020 at 2:48:24 pm'! -!Preferences class methodsFor: 'standard queries' stamp: 'jmv 3/11/2020 14:47:53'! - autoNumberUserChanges - ^ self - valueOfFlag: #autoNumberUserChanges - ifAbsent: [ true ].! ! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'jmv 3/11/2020 14:47:57' prior: 50496838! - assureStartupStampLogged - "If there is a startup stamp not yet actually logged to disk, do it now." - | changesFile directory oldUserChanges oldUserChangesName | - StartupStamp ifNil: [^ self]. - (SourceFiles notNil and: [(changesFile _ SourceFiles at: 2) notNil]) ifTrue: [ - changesFile isReadOnly ifFalse: [ - changesFile setToEnd; newLine; newLine. - changesFile nextChunkPut: StartupStamp asString; newLine. - self forceChangesToDisk ]]. - Preferences autoNumberUserChanges ifTrue: [ - oldUserChanges _ Smalltalk defaultUserChangesName asFileEntry. - oldUserChanges exists ifTrue: [ - directory _ oldUserChanges parent. - oldUserChangesName _ directory nextNameFor: oldUserChanges nameWithoutExtension extension: 'changes'. - oldUserChanges rename: oldUserChangesName ]]. - Smalltalk defaultUserChangesName asFileEntry appendStreamDo: [ :stream | - stream newLine; newLine. - stream nextChunkPut: StartupStamp asString; newLine ]. - StartupStamp _ nil! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4066-AutoNumberUserChangesPrefernce-JuanVuletich-2020Mar11-14h32m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4064] on 11 March 2020 at 2:59:20 pm'! -!SHTextStyler methodsFor: 'styling' stamp: 'jmv 3/11/2020 14:57:11' prior: 16903138! - formatAndStyle: text allowBackgroundStyleProcess: aBoolean - "Do the styling on a copy of the model text. - After finishing, send it to the model, by triggering #shoutStyled - The model should grab the TextAttributes we added to the copy, as appropriate." - self terminateBackgroundStylingProcess. - formattedText _ text. - self privateFormatAndConvert. - (aBoolean and: [formattedText size > 4096]) - ifTrue: [ - formattedText size < 65536 ifTrue: [ - self styleInBackgroundProcess ]] - ifFalse: [ - self privateStyle. - textModel changed: #shoutStyled ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4067-DontShoutLargeText-JuanVuletich-2020Mar11-14h48m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4067] on 11 March 2020 at 3:17:47 pm'! -!LayoutAdjustingMorph methodsFor: 'stepping' stamp: 'jmv 3/11/2020 15:17:12' prior: 50471148! - stepAt: millisecondSinceLast - "got the #mouseLeave: message" - | p | - hand ifNil: [ - Cursor currentCursor == self cursor ifTrue: [ Cursor defaultCursor activateCursor ]. - ^ self stopStepping ]. - "hasn't got the #mouseLeave: message (yet)" - p _ hand morphPosition. - hand lastMouseEvent mouseButton1Pressed - ifTrue: [ - self adjustOwnerAt: p. - (Preferences cheapWindowReframe or: [ millisecondSinceLast > 200]) ifTrue: [ - owner morphBoundsInWorld newRectFrom: [ :f | - self adjustOwnerAt: Sensor mousePoint. - owner morphBoundsInWorld ]]] - ifFalse: [ - self stopStepping. - "If the button was unpressed outside the morph (can happen if you try to go outside container), - we might not get the #mouseLeave: message" - (self morphContainsPoint: (self internalizeFromWorld: p)) ifFalse: [ - hand _ nil. - Cursor defaultCursor activateCursor ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4068-cheapWindowReframeIfTooSlow-JuanVuletich-2020Mar11-15h12m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4068] on 11 March 2020 at 3:31:36 pm'! -!LayoutMorph methodsFor: 'initialization' stamp: 'jmv 3/11/2020 15:31:04' prior: 50500273! - beColumn - direction _ #vertical. - padding ifNil: [self padding: #center]. - self refreshExtent.! ! -!LayoutMorph methodsFor: 'initialization' stamp: 'jmv 3/11/2020 15:31:13' prior: 50500279! - beRow - direction _ #horizontal. - padding ifNil: [self padding: #left]. - self refreshExtent.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4069-keepPaddingIfAtAllPossible-JuanVuletich-2020Mar11-15h30m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4069] on 13 March 2020 at 8:19:20 am'! -!Duration methodsFor: 'squeak protocol' stamp: 'jmv 3/13/2020 08:18:50' prior: 50342318! - printOn: aStream - "Format as per ANSI 5.8.2.16: [-]D:HH:MM:SS[.S] - (Duration days: 2 hours: 3 minutes: 16 seconds: 43) printString = '2:03:16:43' - " - | d h m s n | - d _ self days abs. - h _ self hours abs. - m _ self minutes abs. - s _ self seconds abs truncated. - n _ self nanoSeconds abs. self negative ifTrue: [ aStream nextPut: $- ]. - d printOn: aStream. aStream nextPut: $:. - h printOn: aStream length: 2 zeroPadded: true.aStream nextPut: $:. - m printOn: aStream length: 2 zeroPadded: true.aStream nextPut: $:. - s printOn: aStream length: 2 zeroPadded: true. - n = 0 ifFalse: [ - | z ps | - aStream nextPut: $.. - ps _ n printString padded: #left to: 9 with: $0. - z _ ps findLast: [ :c | c digitValue > 0 ]. - z _ #(3 6 9) detect: [ :ez | ez >= z ]. "print either milliseconds, microseconds or nanoseconds" - ps from: 1 to: z do: [ :c | aStream nextPut: c ] ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4070-Duration-printString-tweak-JuanVuletich-2020Mar13-08h18m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4070] on 18 March 2020 at 10:57:34 am'! -!CharacterScanner methodsFor: 'scanning' stamp: 'jmv 1/25/2014 13:42' prior: 50460108! - scanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernValue - "Primitive. This is the inner loop of text display--but see - scanCharactersFrom: to:rightX: which would get the string, - stopConditions and displaying from the instance. March through source - String from startIndex to stopIndex. If any character is flagged with a - non-nil entry in stops, then return the corresponding value. Determine - width of each character from xTable, indexed by map. - If dextX would exceed rightX, then return stops at: 258. - Advance destX by the width of the character. If stopIndex has been - reached, then return stops at: 257. Optional. - See Object documentation whatIsAPrimitive." - | nextDestX char | - - lastIndex _ startIndex. - [ lastIndex <= stopIndex ] - whileTrue: [ - char _ sourceString at: lastIndex. - "stops are only defined for the first 256 characters. - If we (ever) handle Character like objects beyond those in ISO-8859-15, - thenf #iso8859s15Code shound answer nil!!" - char iso8859s15Code ifNotNil: [ :code | - (stops at: code + 1) ifNotNil: [ :stop | ^stop ]]. - nextDestX _ destX + (font widthOf: char). - nextDestX > rightX ifTrue: [ - ^stops at: CharacterScanner crossedXCode ]. - destX _ nextDestX. - lastIndex _ lastIndex + 1 ]. - lastIndex _ stopIndex. - ^ stops at: CharacterScanner endOfRunCode! ! -!CompositionScanner methodsFor: 'scanning' stamp: 'jmv 9/2/2018 23:27:51' prior: 50460157! - composeFrom: startIndex inRectangle: lineRectangle firstLine: firstLine leftSide: leftSide rightSide: rightSide - - "Answer an instance of TextLineInterval that represents the next line in the paragraph." - | runLength stopCondition xtraSpaceBefore spaceAfterParagraph | - - lastTabIndex _ lastIndex _ startIndex. "scanning sets last index" - destY _ lineRectangle top. - lineHeight _ baseline _ 0. "Will be increased by setFont" - self setFont. - self setStopConditions. - - "Set up margins" - leftMargin _ lineRectangle left. - rightMargin _ lineRectangle right. - xtraSpaceBefore _ 0. - spaceAfterParagraph _ 0. - paragraphStyle ifNotNil: [ - leftSide ifTrue: [ - leftMargin _ leftMargin + - ((firstLine and: [ paragraphStyle isListStyle not ]) - ifTrue: [ paragraphStyle firstIndent ] - ifFalse: [ paragraphStyle restIndent ])]. - rightSide ifTrue: [ - rightMargin _ rightMargin - paragraphStyle rightIndent]. - firstLine ifTrue: [ xtraSpaceBefore _ paragraphStyle spaceBefore ]. - spaceAfterParagraph _ paragraphStyle spaceAfter ]. - lastTabX _ destX _ spaceX _ leftMargin. - - runLength _ text runLengthFor: startIndex. - runStopIndex _ lastIndex + runLength - 1. - line _ (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0) - rectangle: lineRectangle. - line isFirstLine: firstLine. - spaceCount _ 0. - lastLineBreakingSpace _ 0. - leftMargin _ destX. - line leftMargin: leftMargin. - - self placeEmbeddedObject. - [ - stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex - in: text string rightX: rightMargin stopConditions: stopConditions - kern: font baseKern. - "See setStopConditions for stopping conditions for composing." - (self perform: stopCondition) ifTrue: [ - ^ line - lineHeight: lineHeight + xtraSpaceBefore + - (stopCondition == #doNewLine ifTrue: [spaceAfterParagraph] ifFalse: [0]) - baseline: baseline + xtraSpaceBefore ] - ] repeat! ! - -AbstractFont removeSelector: #rightOffsetAt:! - -!methodRemoval: AbstractFont #rightOffsetAt: stamp: 'Install-4071-Font-smallSimplification-JuanVuletich-2020Mar18-10h56m-jmv.001.cs.st 4/1/2020 17:56:05'! -rightOffsetAt: aCharacter - ^ 0! - -AbstractFont removeSelector: #leftOffsetAt:! - -!methodRemoval: AbstractFont #leftOffsetAt: stamp: 'Install-4071-Font-smallSimplification-JuanVuletich-2020Mar18-10h56m-jmv.001.cs.st 4/1/2020 17:56:05'! -leftOffsetAt: aCharacter - ^ 0! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4071-Font-smallSimplification-JuanVuletich-2020Mar18-10h56m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4071] on 21 March 2020 at 10:32:12 am'! -!AbstractFont class methodsFor: 'initialization' stamp: 'jmv 3/21/2020 10:30:25'! - assignmentGlyphSelectorPreferenceChanged - "Subclasses should adjust their instances accordingly."! ! -!StrikeFont class methodsFor: 'initialization' stamp: 'jmv 3/21/2020 10:18:08'! - assignmentGlyphSelectorPreferenceChanged - self allInstancesDo: [ :each | each reset ]! ! -!Preferences class methodsFor: 'shout' stamp: 'jmv 3/21/2020 10:30:40' prior: 16893889! - useAssignmentGlyphLeftArrow - " - Preferences useAssignmentGlyphLeftArrow - " - Preferences setPreference: #assignmentGlyphSelector toValue: #useLeftArrow. - AbstractFont withAllSubclassesDo: [ :fontClass | fontClass assignmentGlyphSelectorPreferenceChanged ].! ! -!Preferences class methodsFor: 'shout' stamp: 'jmv 3/21/2020 10:30:45' prior: 16893898! - useAssignmentGlyphRightArrow - " - Preferences useAssignmentGlyphRightArrow - " - Preferences setPreference: #assignmentGlyphSelector toValue: #useRightArrow. - AbstractFont withAllSubclassesDo: [ :fontClass | fontClass assignmentGlyphSelectorPreferenceChanged ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4072-AssignmentGlyphPrefRefacor-JuanVuletich-2020Mar21-10h29m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4072] on 22 March 2020 at 11:37:21 pm'! -!Character class methodsFor: 'converting' stamp: 'jmv 3/22/2020 23:19:17'! - nextCodePointBytesFromUtf8: anUtf8Stream into: aBlock - "anUtf8Stream can be over a ByteArray. - See senders." - - | byte1 byte2 byte3 byte4 | - byte1 _ anUtf8Stream next. - byte1 < 128 ifTrue: [ "single byte" - ^ aBlock value: byte1 value: nil value: nil value: nil ]. - - "At least 2 bytes" - byte2 _ anUtf8Stream next. - (byte2 bitAnd: 16rC0) = 16r80 ifFalse: [^nil]. "invalid UTF-8" - (byte1 bitAnd: 16rE0) = 192 ifTrue: [ "two bytes" - ^ aBlock value: byte1 value: byte2 value: nil value: nil ]. - - "At least 3 bytes" - byte3 _ anUtf8Stream next. - (byte3 bitAnd: 16rC0) = 16r80 ifFalse: [^nil]. "invalid UTF-8" - (byte1 bitAnd: 16rF0) = 224 ifTrue: [ "three bytes" - ^ aBlock value: byte1 value: byte2 value: byte3 value: nil ]. - - "4 bytes" - byte4 _ anUtf8Stream next. - (byte4 bitAnd: 16rC0) = 16r80 ifFalse: [^nil]. "invalid UTF-8" - (byte1 bitAnd: 16rF8) = 240 ifTrue: [ "four bytes" - ^ aBlock value: byte1 value: byte2 value: byte3 value: byte4 ]. - - ^nil! ! -!Character class methodsFor: 'converting' stamp: 'jmv 3/22/2020 23:33:20' prior: 16801277! - nextUnicodeCodePointFromUtf8: anUtf8Stream - "anUtf8Stream can be over a ByteArray - Answer nil if conversion not possible, because of invalid UTF-8. - Also answer nil for codePoint U+FEFF (BOM, unneededly added by Win clipboard)" - - ^ self - nextCodePointBytesFromUtf8: anUtf8Stream - into: [ :byte1 :byte2 :byte3 :byte4 | - byte4 notNil - ifTrue: [ ((byte1 bitAnd: 16r7) bitShift: 18) + ((byte2 bitAnd: 63) bitShift: 12) + ((byte3 bitAnd: 63) bitShift: 6) + (byte4 bitAnd: 63) ] - ifFalse: [ - byte3 notNil - ifTrue: [ | codePoint | - codePoint _ ((byte1 bitAnd: 15) bitShift: 12) + ((byte2 bitAnd: 63) bitShift: 6) + (byte3 bitAnd: 63). - codePoint = 16rFEFF - ifFalse: [ codePoint ] - ifTrue: [ nil ]] - ifFalse: [ - byte2 notNil - ifTrue: [ ((byte1 bitAnd: 31) bitShift: 6) + (byte2 bitAnd: 63) ] - ifFalse: [ byte1 ]]]]! ! - -Character class removeSelector: #nextCodePointBytesFromUtf8:ifOneByte:ifTwoBytes:ifThreeBytes:ifFourBytes:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4073-RefactoringCharacter-JuanVuletich-2020Mar22-23h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4073] on 24 March 2020 at 10:39:45 am'! -!LayoutMorph methodsFor: 'geometry' stamp: 'jmv 3/24/2020 10:23:22' prior: 50499678! - minimumExtent - "Answer size sufficient to frame my submorphs." - - | width height | - width := self ySeparation. - height := self xSeparation. - (self direction = #vertical) - ifTrue: [ - self submorphsDo: [ :sm | | smMinExtent | - smMinExtent := sm minimumLayoutExtent. - "use maximum width across submorphs" - width := width max: (smMinExtent x max: sm layoutSpec fixedOrMinimumLayoutWidth). - "sum up submorph heights" - height := height + (smMinExtent y max: sm layoutSpec fixedOrMinimumLayoutHeight) + self ySeparation. - ]. - width := width + self xSeparation. - ] - ifFalse: [ - self submorphsDo: [ :sm | | smMinExtent | - smMinExtent := sm minimumLayoutExtent. - "sum up submorphs width" - width := width + (smMinExtent x max: sm layoutSpec fixedOrMinimumLayoutWidth) + self xSeparation. - "use maximum height across submorph" - height := height max: (smMinExtent y max: sm layoutSpec fixedOrMinimumLayoutHeight). - ]. - height := height + self ySeparation. - ]. - - ^ (width @ height) + self extentBorder! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4074-LayoutFix-JuanVuletich-2020Mar24-10h23m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #3964] on 21 March 2020 at 3:51:01 pm'! - -ChangeListElement subclass: #ChangeRecord - instanceVariableNames: 'file position type class category meta stamp prior isTest overrides ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #ChangeRecord category: #'Tools-Changes' stamp: 'Install-4075-MethodOverrideChange-MatiasDinota-2020Jan02-09h08m-MGD.1.cs.st 4/1/2020 17:56:05'! -ChangeListElement subclass: #ChangeRecord - instanceVariableNames: 'file position type class category meta stamp prior isTest overrides' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! -!ChangeList methodsFor: 'scanning' stamp: 'MGD 3/17/2020 19:35:38'! -overridenMethodReferenceFrom: tokens - - | overridenMethodReference tagIndex | - - tagIndex _ tokens indexOf: #overrides: ifAbsent: [ ^ nil ]. - overridenMethodReference _ tokens at: tagIndex + 1. - - ^ overridenMethodReference -! ! -!ChangeList methodsFor: 'scanning' stamp: 'MGD 3/17/2020 19:37:43'! - scanCategory: category class: class meta: meta stamp: stamp prior: aPriorMethod overrides: anOverridenMethod - - | itemPosition method | - - [ - itemPosition _ file position. - method _ file nextChunk. - method notEmpty ] whileTrue: [ "done when double terminators" - self - addItem: (ChangeRecord new - file: file - position: itemPosition - type: #method - class: class - category: category - meta: meta - stamp: stamp - prior: aPriorMethod - overrides: anOverridenMethod) - text: 'method: ' , class , (meta ifTrue: [' class '] ifFalse: [' ']) - , (((Smalltalk at: class ifAbsent: [Object class]) parserClass selectorFrom: method) ifNil: ['']) - , (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp])]! ! -!ClassDescription methodsFor: 'fileIn/Out'! - printCategoryChunk: category on: aFileStream withStamp: changeStamp priorMethod: priorMethod overridesMethod: overridenMethod - "Print a method category preamble. This must have a category name. - It may have an author/date stamp, and it may have a prior source link. - If it has a prior source link, it MUST have a stamp, even if it is empty." - -"The current design is that changeStamps and prior source links are preserved in the changes file. All fileOuts include changeStamps. Condensing sources, however, eliminates all stamps (and links, natch)." - - aFileStream newLine; nextPut: $!!. - aFileStream nextChunkPut: (String streamContents: [ :strm | - strm nextPutAll: self name; nextPutAll: ' methodsFor: '; print: category asString. - (changeStamp notNil and: [ - changeStamp size > 0 or: [priorMethod notNil]]) ifTrue: [ - strm nextPutAll: ' stamp: '; print: changeStamp]. - priorMethod notNil ifTrue: [ - strm nextPutAll: ' prior: '; print: priorMethod sourcePointer]. - overridenMethod notNil ifTrue: [ - strm nextPutAll: ' overrides: '; print: overridenMethod sourcePointer] - ]). -! ! -!CompiledMethod methodsFor: 'source code management' stamp: 'MGD 3/17/2020 18:12:26'! - putSource: sourceStr fromParseNode: methodNode class: class category: catName - withStamp: changeStamp inFile: fileIndex priorMethod: priorMethod overridesMethod: overridenMethod - - ^ self putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble: [ :file | - class - printCategoryChunk: catName - on: file - withStamp: changeStamp - priorMethod: priorMethod - overridesMethod: overridenMethod. - file newLine ]! ! -!ChangeRecord methodsFor: 'access' stamp: 'MGD 3/17/2020 19:40:04'! - overridesASuperclassMethod - ^ overrides notNil ! ! -!ChangeRecord methodsFor: 'initialization' stamp: 'MGD 3/17/2020 19:39:04'! - file: aFile position: aPosition type: aType class: aClassName category: aClassCategory meta: isMeta stamp: aStamp prior: aPrior overrides: anOverridenMethod - - self file: aFile position: aPosition type: aType. - class _ aClassName. - category _ aClassCategory. - meta _ isMeta. - stamp _ aStamp. - prior _ aPrior. - overrides _ anOverridenMethod.! ! -!ChangeList methodsFor: 'scanning' stamp: 'MGD 3/17/2020 19:35:05' prior: 50479658! - scanMethodDefinition: tokens - - | stamp className priorMethod overridenMethod | - - className _ tokens first. - stamp _ self stampFrom: tokens. - priorMethod _ self priorMethodReferenceFrom: tokens. - overridenMethod _ self overridenMethodReferenceFrom: tokens. - - tokens second == #methodsFor: ifTrue: [ - ^ self scanCategory: tokens third class: className meta: false stamp: stamp prior: priorMethod overrides: overridenMethod ]. - - tokens third == #methodsFor: ifTrue: [ - ^ self scanCategory: tokens fourth class: className meta: true stamp: stamp prior: priorMethod overrides: overridenMethod ]. - - self error: 'Unsupported method definition' -! ! -!ClassDescription methodsFor: 'private' stamp: 'MGD 3/17/2020 19:08:00' prior: 16807087! -logMethodSource: aText forMethodWithNode: aCompiledMethodWithNode inCategory: category withStamp: changeStamp notifying: requestor - | priorMethodOrNil overridenMethodOrNil | - - priorMethodOrNil := self compiledMethodAt: aCompiledMethodWithNode selector ifAbsent: nil. - overridenMethodOrNil := self superclass ifNotNil: [ self superclass lookupSelector: aCompiledMethodWithNode selector ]. - - aCompiledMethodWithNode method putSource: aText asString - fromParseNode: aCompiledMethodWithNode node - class: self category: category withStamp: changeStamp - inFile: 2 priorMethod: priorMethodOrNil overridesMethod: overridenMethodOrNil.! ! - -ChangeList removeSelector: #scanCategory:class:meta:stamp:prior:! - -!methodRemoval: ChangeList #scanCategory:class:meta:stamp:prior: stamp: 'Install-4075-MethodOverrideChange-MatiasDinota-2020Jan02-09h08m-MGD.1.cs.st 4/1/2020 17:56:05'! -scanCategory: category class: class meta: meta stamp: stamp prior: aPriorMethod - - | itemPosition method | - - [ - itemPosition _ file position. - method _ file nextChunk. - method notEmpty ] whileTrue: [ "done when double terminators" - self - addItem: (ChangeRecord new - file: file - position: itemPosition - type: #method - class: class - category: category - meta: meta - stamp: stamp - prior: aPriorMethod) - text: 'method: ' , class , (meta ifTrue: [' class '] ifFalse: [' ']) - , (((Smalltalk at: class ifAbsent: [Object class]) parserClass selectorFrom: method) ifNil: ['']) - , (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp])]! - -ChangeListElement subclass: #ChangeRecord - instanceVariableNames: 'file position type class category meta stamp prior isTest overrides' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #ChangeRecord category: #'Tools-Changes' stamp: 'Install-4075-MethodOverrideChange-MatiasDinota-2020Jan02-09h08m-MGD.1.cs.st 4/1/2020 17:56:05'! -ChangeListElement subclass: #ChangeRecord - instanceVariableNames: 'file position type class category meta stamp prior isTest overrides' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4075-MethodOverrideChange-MatiasDinota-2020Jan02-09h08m-MGD.1.cs.st----! - -'From Cuis 5.0 [latest update: #4070] on 24 March 2020 at 11:24:31 am'! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'HAW 3/24/2020 11:20:25' prior: 16806885! - printCategoryChunk: category on: aFileStream withStamp: changeStamp priorMethod: priorMethod - - ^self - printCategoryChunk: category - on: aFileStream - withStamp: changeStamp - priorMethod: priorMethod - overridesMethod: nil ! ! -!ClassDescription methodsFor: 'private' stamp: 'HAW 3/24/2020 11:16:12' prior: 50500973! - logMethodSource: aText forMethodWithNode: aCompiledMethodWithNode inCategory: category withStamp: changeStamp notifying: requestor - | priorMethodOrNil overridenMethodOrNil | - - priorMethodOrNil := self compiledMethodAt: aCompiledMethodWithNode selector ifAbsent: nil. - overridenMethodOrNil := self superclass ifNotNil: [ :aSuperclass | - aSuperclass lookupSelector: aCompiledMethodWithNode selector ]. - - aCompiledMethodWithNode method - putSource: aText asString - fromParseNode: aCompiledMethodWithNode node - class: self - category: category - withStamp: changeStamp - inFile: 2 - priorMethod: priorMethodOrNil - overridesMethod: overridenMethodOrNil.! ! - -CompiledMethod removeSelector: #putSource:fromParseNode:class:category:withStamp:inFile:priorMethod:! - -!methodRemoval: CompiledMethod #putSource:fromParseNode:class:category:withStamp:inFile:priorMethod: stamp: 'Install-4076-MethodOverrideChangeImprovements-HernanWilkinson-2020Mar24-11h15m-HAW.001.cs.st 4/1/2020 17:56:05'! -putSource: sourceStr fromParseNode: methodNode class: class category: catName - withStamp: changeStamp inFile: fileIndex priorMethod: priorMethod - - ^ self putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble: [ :file | - class - printCategoryChunk: catName - on: file - withStamp: changeStamp - priorMethod: priorMethod. - file newLine ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4076-MethodOverrideChangeImprovements-HernanWilkinson-2020Mar24-11h15m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #3964] on 2 January 2020 at 9:08:33 am'! - -ChangeListElement subclass: #ClassRenamedChangeRecord - instanceVariableNames: 'previousName newName stamp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #ClassRenamedChangeRecord category: #'Tools-Changes' stamp: 'Install-4077-ClassRenameChangeReification-MatiasDinota-2020Jan02-09h08m-MGD.1.cs.st 4/1/2020 17:56:06'! -ChangeListElement subclass: #ClassRenamedChangeRecord - instanceVariableNames: 'previousName newName stamp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! -!ChangeList methodsFor: 'scanning' stamp: 'MGD 12/19/2019 19:36:26'! - scanClassRenamed: tokens - - | record stamp newName previousName preamble | - - preamble _ tokens first. - previousName _ tokens second. - newName _ tokens fourth. - stamp _ self stampFrom: tokens. - file nextChunk. - - record _ ClassRenamedChangeRecord from: previousName to: newName stamp: stamp. - - self - addItem: record - text: preamble, previousName, ' - ', newName, '; ', stamp ! ! -!ClassRenamedChangeRecord methodsFor: 'initialization' stamp: 'MGD 12/19/2019 19:19:01'! - initializeFrom: previousClassName to: newClassName stamp: aString - - previousName := previousClassName. - newName := newClassName. - stamp := aString.! ! -!ClassRenamedChangeRecord methodsFor: 'accessing' stamp: 'MGD 12/19/2019 21:14:43'! - changeClass - ^ nil! ! -!ClassRenamedChangeRecord methodsFor: 'accessing' stamp: 'MGD 12/19/2019 19:32:01'! - changeClassName - ^ previousName ! ! -!ClassRenamedChangeRecord methodsFor: 'accessing' stamp: 'MGD 12/19/2019 19:19:28'! - changeType - ^ #classRenamed! ! -!ClassRenamedChangeRecord methodsFor: 'accessing' stamp: 'MGD 12/19/2019 19:33:26'! - newClassName - ^ newName ! ! -!ClassRenamedChangeRecord methodsFor: 'accessing' stamp: 'MGD 12/19/2019 19:31:06'! - stamp - ^stamp! ! -!ClassRenamedChangeRecord methodsFor: 'printing' stamp: 'MGD 12/19/2019 21:13:47'! - string - ^ 'classRenamed: #', previousName, ' as: #', newName, stamp ! ! -!ClassRenamedChangeRecord methodsFor: 'fileIn/fileOut' stamp: 'MGD 1/2/2020 08:58:15' overrides: 50490428! - fileIn - ! ! -!ClassRenamedChangeRecord class methodsFor: 'instance creation' stamp: 'MGD 12/19/2019 19:17:45'! - from: previousClassName to: newClassName stamp: aString - ^self new initializeFrom: previousClassName to: newClassName stamp: aString ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4077-ClassRenameChangeReification-MatiasDinota-2020Jan02-09h08m-MGD.1.cs.st----! - -'From Cuis 5.0 [latest update: #4071] on 24 March 2020 at 11:34:19 am'! -!ChangeList methodsFor: '*TDDGuruFirstBootstrapping' stamp: 'HAW 3/24/2020 11:30:46' prior: 50478955! - scanSpecificChangeRecordType - "Scan anything that involves more than one chunk" - - | itemPosition item tokens firstToken secondToken | - - itemPosition _ file position. - item _ file nextChunk. - - (self itemIsRecognized: item) ifFalse: [ - "Maybe a preamble, but not one we recognize; bail out with the preamble trick" - ^ self scanAndIgnore: item in: itemPosition ]. - - tokens _ Scanner new scanTokens: item. - tokens size >= 2 ifTrue: [ - firstToken _ tokens first. - secondToken _ tokens second. - - firstToken == #classDefinition: - ifTrue: [ ^ self scanClassDefinition: tokens ]. - (firstToken == #classRemoval: or: [ firstToken == #classMoveToSomePackage: ]) - ifTrue: [ ^ self scanClassRemoval: tokens ]. - (firstToken == #methodRemoval: or: [ firstToken == #methodMoveToSomePackage: ]) - ifTrue: [ ^ self scanMethodRemoval: tokens ]. - (secondToken == #methodsFor: or: [ tokens third == #methodsFor: ]) - ifTrue: [ ^ self scanMethodDefinition: tokens ]. - secondToken == #commentStamp: - ifTrue: [ ^ self scanClassComment: tokens ]. - firstToken == #provides: - ifTrue: [ ^ self scanFeatureProvision: tokens ]. - firstToken == #requires: - ifTrue: [ ^ self scanFeatureRequirement: tokens ]. - firstToken == #classRenamed: - ifTrue: [ ^ self scanClassRenamed: tokens ]. - ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4078-ClassRenameChangeReification-HernanWilkinson-2020Mar24-11h26m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4074] on 24 March 2020 at 12:18:49 pm'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4079-ChangeListMethodsRecategorization-HernanWilkinson-2020Mar24-12h16m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4075] on 24 March 2020 at 3:26:46 pm'! -!ChangeList class methodsFor: 'scanning' stamp: 'HAW 3/24/2020 15:26:32' prior: 50479409! - knownFileInPreambles - - ^ `{ - 'classDefinition:'. - 'classRemoval:'. - 'methodRemoval:'. - 'methodMoveToSomePackage:'. - 'classMoveToSomePackage:'. - 'provides:'. - 'requires:'. - 'classRenamed:'. }`! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4080-ClassRenameChangeReification-HernanWilkinson-2020Mar24-15h26m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4069] on 20 March 2020 at 9:39:27 pm'! -!Preferences class methodsFor: 'standard queries' stamp: 'pb 3/20/2020 21:02:28'! - transcriptLogVerbose - ^ self - valueOfFlag: #transcriptLogVerbose - ifAbsent: [ true ].! ! -!String methodsFor: 'displaying' stamp: 'pb 3/20/2020 21:04:16' prior: 50495910! - 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 mousePoint - from: 0 to: 100 - during: [:barBlock | - 1 to: 100 do: [:x | - (Delay forMilliseconds: 10) wait. - barBlock value: x.]]. - -['Now here''s some Real Progress' - displayProgressAt: Sensor mousePoint - from: 0 to: 100 - during: [:barBlock | - 1 to: 100 do: [:x | barBlock value: x. - (Delay forMilliseconds: 100) wait]].] fork - -['Now here''s some Real Progress' - displayProgressAt: Sensor mousePoint - from: 0 to: 10 - during: [:barBlock | - 1 to: 30 do: [:x | barBlock value: x \\ 11. - (Delay forMilliseconds: 100) wait]]] fork - -'Now here''s some Real Progress' - displayProgressAt: Sensor mousePoint - from: 0 to: 10 - during: [:barBlock | - 1 to: 30 do: [:x | barBlock value: nil. - (Delay forMilliseconds: 200) 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. - -The use of ProgressInitiationException allows for avoiding actual -progress display, by catching the exception. -" - | answer duration | - Preferences transcriptLogVerbose ifTrue: [ - Transcript show: self; show: '...']. - duration _ [ - answer _ ProgressInitiationException - display: self - at: aPoint - from: minVal - to: maxVal - during: workBlock] durationToRun. - Preferences transcriptLogVerbose ifTrue: [ - Transcript show: ' done. Took '; show: duration printString; newLine]. - ^answer! ! -!ChangeSet class methodsFor: 'services' stamp: 'pb 3/20/2020 21:18:53' prior: 16799283! - install: aFileEntry - "File in the entire contents of the file specified by the name provided. - Do not affect the user change sets, store changes in separate one" - - ChangeSet installing: aFileEntry name do: [ self fileIn: aFileEntry ]. - Preferences transcriptLogVerbose ifTrue: [ - ('Installed ChangeSet: ', aFileEntry name) print]! ! -!CodeFile methodsFor: 'fileIn/fileOut' stamp: 'pb 3/20/2020 21:05:57' prior: 50493300! - fileIn - | doitsMark | - doitsMark := 1. - doIts isEmpty ifFalse:[doitsMark := self askForDoits]. - doitsMark = 4 ifTrue: [^nil]. - doitsMark = 2 ifTrue:[self fileInDoits]. - classOrder do:[:cls| - cls fileInDefinition. - ]. - classes do:[:cls| - Preferences transcriptLogVerbose ifTrue: [ - Transcript newLine; show:'Filing in ', cls name]. - cls fileInMethods. - cls hasMetaclass ifTrue:[cls theMetaClass fileInMethods]. - ]. - doitsMark = 3 ifTrue: [ self fileInDoits ]! ! -!CodePackageFile methodsFor: 'services' stamp: 'pb 3/20/2020 21:29:40' prior: 50430216! - install: aFileStream - "Installs the package. Replace all existing code in the CodePackage, removing any code that is not included in us." - | localName newCodePackage pckClass currentCS | - - "Give reasonable warnings if there is stuff that can't be properly cleaned. Give the user the chance to abort." - Preferences transcriptLogVerbose ifTrue: [ - '=============' print. - classesToRemove notEmpty ifTrue: [ - ('classesToRemove: ', classesToRemove printString) print. - '=============' print ]. - methodsToRemove notEmpty ifTrue: [ - 'methodsToRemove: ' print. - methodsToRemove do: [ :methodReference | methodReference print ]. - '=============' print ]]. - - "Create, install and answer a (sub)instance of CodePackage" - localName _ fullName asFileEntry name. - ChangeSet installing: packageName do: [ - "This change set will capture a possible class definition for a subclass of CodePackage. - If it only has that, then remove it after package install. - One example needing this is 'Color-Extras.pck.st'" - currentCS _ ChangeSet changeSetForBaseSystem. - currentCS isEmpty ifFalse: [ currentCS _ nil ]. - pckClass _ CodePackage. - classes do: [ :ee | - (ee hasDefinition and: [ee superclassName = 'CodePackage']) ifTrue: [ - ee fileInDefinitionAndMetaclass. - pckClass _ Smalltalk at: ee name ]]. - newCodePackage _ pckClass - named: packageName - createIfAbsent: true - registerIfNew: true. - newCodePackage - fullFileName: fullName; - sourceSystem: sourceSystem; - description: description; - featureSpec: featureSpec. - aFileStream fileInAnnouncing: 'Installing ', localName, '...'. - methodsToRemove do: [ :methodReference | methodReference actualClass removeSelector: methodReference selector ]. - classesToRemove do: [ :className | (Smalltalk at: className) removeFromSystem ]. - currentCS ifNotNil: [ ChangeSet removeChangeSet: currentCS ]]. - newCodePackage hasUnsavedChanges: false; triggerEvent: #dirtyFlagChanged. - DataStream initialize. "Just in case" - "If we are installing an already installed package, zap the change set with possible changes done, - as they are irrelevant now: we have the package from disk" - ChangeSet removeChangeSet: (ChangeSet existingOrNewChangeSetForPackage: newCodePackage). - Preferences transcriptLogVerbose ifTrue: [ - Transcript newLine; show: 'Package ', packageName, ' successfully installed'; newLine. - Smalltalk cleanOutUndeclared. - Undeclared notEmpty ifTrue: [ - ('Undeclared: ', Undeclared printString) print ]]. - ^newCodePackage! ! -!TestResult methodsFor: 'logging' stamp: 'pb 3/20/2020 21:36:27' prior: 50473685! - reportAboutToRun: aTestCase - Preferences transcriptLogVerbose ifTrue: [ - Transcript show: 'Will run: '; print: aTestCase; newLine]! ! -!TestResult methodsFor: 'logging' stamp: 'pb 3/20/2020 21:35:31' prior: 50473695! - reportFailed: aTestCase because: anException - Preferences transcriptLogVerbose ifTrue: [ - Transcript print: anException; newLine].! ! -!TestResult methodsFor: 'logging' stamp: 'pb 3/20/2020 21:35:55' prior: 50473700! - reportPassed: aTestCase - Preferences transcriptLogVerbose ifTrue: [ - Transcript show: 'finished.'; newLine]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4081-Preferences-verbose-logging-PhilBellalouna-2020Mar20-21h02m-pb.001.cs.st----! - -'From Cuis 5.0 [latest update: #4081] on 30 March 2020 at 6:31:58 pm'! -!MorphicTranslation methodsFor: 'composing' stamp: 'pb 3/15/2020 16:23:20' prior: 16878340! - composedWith: aTransformation into: result - "Return the composition of the receiver and the transformation passed in. - Store the composed matrix into result. - Please see the comment at: #composedWith:" - - result setTranslation: self translation + aTransformation translation. - ^ result! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4082-MorphicTranslation-methods-behave-according-to-documentation-PhilBellalouna-2020Mar30-18h28m-pb.001.cs.st----! - -'From Cuis 5.0 [latest update: #4069] on 20 March 2020 at 12:56:57 pm'! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph drawingMorphStack engine clipRect ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support' stamp: 'Install-4083-Canvas-clipRect-PhilBellalouna-2020Mar20-12h41m-pb.001.cs.st 4/1/2020 17:56:06'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph drawingMorphStack engine clipRect' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! -!MorphicCanvas methodsFor: 'accessing' stamp: 'pb 3/20/2020 12:49:43' prior: 50495173! - clipRect - "Return the currently active clipping rectangle" - "In targetForm coordinates" - ^ clipRect ifNil: [clipRect := clipLeft@clipTop corner: clipRight@clipBottom+1]! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'pb 3/20/2020 12:44:46' prior: 50385927! - textComposition: aTextComposition bounds: boundsRect color: c selectionColor: sc - | displayScanner leftInRun line boundsInWorld tl | - - tl _ boundsRect topLeft. - boundsInWorld _ currentTransformation displayBoundsOfTransformOf: boundsRect. - - displayScanner _ MorphicScanner new - defaultFont: aTextComposition defaultFont; - text: aTextComposition textComposed - foreground: c. - displayScanner canvas: self. - - leftInRun _ 0. - "Take clipRect into account. Extrememly fast scrolls and redraws of huge files (like .sources)" - (aTextComposition lineIndexForPoint: (`0@0` max: self clipRect origin - boundsInWorld origin)) - to: (aTextComposition lineIndexForPoint: (boundsInWorld extent min: self clipRect corner - boundsInWorld origin)) - do: [ :i | - line _ aTextComposition lines at: i. - aTextComposition - displaySelectionInLine: line - on: self - textTopLeft: tl - selectionColor: sc. - leftInRun _ displayScanner displayLine: line textTopLeft: tl leftInRun: leftInRun ]! ! -!MorphicCanvas methodsFor: 'private' stamp: 'pb 3/20/2020 12:49:28' prior: 50495181! - setClipRect: aRectangle - "by convention, aRectangle includes left and top but does not include right and bottom. - We do draw clipRight and clipBottom but not beyond. - " - "In targetForm coordinates" - clipRect := aRectangle! ! -!BitBltCanvas methodsFor: 'testing' stamp: 'pb 3/20/2020 12:48:36' prior: 50495236 overrides: 50463635! - isCurrentMorphVisible - | aRectangle myClipRect | - currentMorph visible ifFalse: [ ^false ]. - "#clippingRectForCurrentMorph is valid even before drawing currentMorph, only in BitBltCanvas!!" - aRectangle := self clippingRectForCurrentMorph. - myClipRect := self clipRect. - aRectangle right < myClipRect left ifTrue: [^ false]. - aRectangle left > myClipRect right ifTrue: [^ false]. - aRectangle bottom < myClipRect top ifTrue: [^ false]. - aRectangle top > myClipRect bottom ifTrue: [^ false]. - ^ true -! ! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipRect clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph drawingMorphStack engine' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support' stamp: 'Install-4083-Canvas-clipRect-PhilBellalouna-2020Mar20-12h41m-pb.001.cs.st 4/1/2020 17:56:06'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipRect clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph drawingMorphStack engine' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4083-Canvas-clipRect-PhilBellalouna-2020Mar20-12h41m-pb.001.cs.st----! - -'From Cuis 5.0 [latest update: #4070] on 20 March 2020 at 1:01:06 pm'! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipRect clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph drawingMorphStack engine ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support' stamp: 'Install-4084-Canvas-clipRect-cleanup-PhilBellalouna-2020Mar20-12h59m-pb.001.cs.st 4/1/2020 17:56:06'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipRect clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph drawingMorphStack engine' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -BitBltCanvas allInstances do:[:eaCanvas| eaCanvas clipRect]! -!MorphicCanvas methodsFor: 'accessing' stamp: 'pb 3/20/2020 12:59:56' prior: 50501530! - clipRect - "Return the currently active clipping rectangle" - "In targetForm coordinates" - ^ clipRect! ! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipRect transformations currentTransformation cti currentMorph drawingMorphStack engine' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support' stamp: 'Install-4084-Canvas-clipRect-cleanup-PhilBellalouna-2020Mar20-12h59m-pb.001.cs.st 4/1/2020 17:56:06'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipRect transformations currentTransformation cti currentMorph drawingMorphStack engine' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4084-Canvas-clipRect-cleanup-PhilBellalouna-2020Mar20-12h59m-pb.001.cs.st----! - -'From Cuis 5.0 [latest update: #4058] on 7 March 2020 at 10:34:03 pm'! - -"Change Set: 4059-CuisCore-AuthorName-2020Mar07-22h12m -Date: 7 March 2020 -Author: Nahuel Garbezza - -Adds two new parse nodes representing a temporaries assignment and each individual assignment, add those to each MethodNode and BlockNode (coexisting with the current approach -list of temporaries-)"! - -CodeNode subclass: #BlockNode - instanceVariableNames: 'arguments statements returns nArgsNode size remoteCopyNode temporaries optimized optimizedMessageNode actualScopeIfOptimized blockExtent remoteTempNode copiedValues closureCreationNode startOfLastStatement tempsMark temporariesDeclaration ' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #BlockNode category: #'Compiler-ParseNodes' stamp: 'Install-4085-TemporariesDefinitionASTNode-NahuelGarbezza-2020Mar07-22h12m-RNG.001.cs.st 4/1/2020 17:56:06'! -CodeNode subclass: #BlockNode - instanceVariableNames: 'arguments statements returns nArgsNode size remoteCopyNode temporaries optimized optimizedMessageNode actualScopeIfOptimized blockExtent remoteTempNode copiedValues closureCreationNode startOfLastStatement tempsMark temporariesDeclaration' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! -!BlockNode commentStamp: '' prior: 16789015! - I represent a bracketed block with 0 or more arguments and 1 or more statements. If I am initialized with no statements, I create one. I have a flag to tell whether my last statement returns a value from the enclosing method. My last three fields remember data needed for code generation. I can emit for value in the usual way, in which case I create a literal method (actually a context remotely copied) to be evaluated by sending it value: at run time. Or I can emit code to be evaluated in line; this only happens at the top level of a method and in conditionals and while-loops, none of which have arguments. - -We are in the process of refactoring "temporaries" inst var to a "temporariesDeclaration" inst var which is a parse node that contains more than just the temporaries' nodes, it is the node that represents the declaration itself. Refer to the class comment in MethodNode for more information on how to migrate to "temporariesDeclaration".! - -CodeNode subclass: #MethodNode - instanceVariableNames: 'selectorOrFalse precedence arguments block primitive encoder temporaries properties sourceText locationCounter localsPool selectorKeywordsRanges temporariesDeclaration ' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #MethodNode category: #'Compiler-ParseNodes' stamp: 'Install-4085-TemporariesDefinitionASTNode-NahuelGarbezza-2020Mar07-22h12m-RNG.001.cs.st 4/1/2020 17:56:06'! -CodeNode subclass: #MethodNode - instanceVariableNames: 'selectorOrFalse precedence arguments block primitive encoder temporaries properties sourceText locationCounter localsPool selectorKeywordsRanges temporariesDeclaration' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! -!MethodNode commentStamp: '' prior: 16872285! - I am the root of the parse tree.. - -Instance Variables - arguments: - block: - encoder: - localsPool: - locationCounter: - precedence: - primitive: - properties: - selectorOrFalse: - sourceText: - temporaries: - temporariesDeclaration: - -arguments - - the collection of parsed or decompiled method arguments - -block - - the BlockNode holding the method's statements - -encoder - - the object that comprises the copiler's scope table, literal pool and back-end bytecode generator - -localsPool - - a set used to determine the set of copied values for each block in the method - -locationCounter - - an integer used to mark block scopes for the purposes of the closure transformation. See BlockNode>>#analyseArguments:temporaries:rootNode: - -precedence - - the precedence of the method's selector (see Symbol>>precedence) - -primitive - - if non-zero this is the integer code of the method's primitive - -properties - - the object used to accumulate method properties (a.k.a. pragmas) - -selectorOrFalse - - the method's selector or false if this is a doit - -sourceText - - the source test from which the method was compiled - -temporaries - - the collection of parsed or decompiled method temporaries - -temporariesDeclaration - - an alternative way to represent the temporaries declaration, by using a parse node to represent that; it should eventually replace the need for the "temporaries" instance variable (because the temporaries can be obtained through this object); every read to "temporaries" can be replaced by sending #allDeclaredVariableNodes to this object; right now the Parser initializes both "temporaries" and "temporariesDeclaration" to ease the migration process! - -ParseNode subclass: #TemporariesDeclarationNode - instanceVariableNames: 'tempDeclarationNodes' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #TemporariesDeclarationNode category: #'Compiler-ParseNodes' stamp: 'Install-4085-TemporariesDefinitionASTNode-NahuelGarbezza-2020Mar07-22h12m-RNG.001.cs.st 4/1/2020 17:56:06'! -ParseNode subclass: #TemporariesDeclarationNode - instanceVariableNames: 'tempDeclarationNodes' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -ParseNode subclass: #TemporaryDeclarationNode - instanceVariableNames: 'variableNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #TemporaryDeclarationNode category: #'Compiler-ParseNodes' stamp: 'Install-4085-TemporariesDefinitionASTNode-NahuelGarbezza-2020Mar07-22h12m-RNG.001.cs.st 4/1/2020 17:56:06'! -ParseNode subclass: #TemporaryDeclarationNode - instanceVariableNames: 'variableNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! -!ParseNode methodsFor: 'testing' stamp: 'RNG 3/7/2020 22:29:21'! - isTemporariesDeclaration - - ^ false! ! -!BlockNode methodsFor: 'accessing' stamp: 'RNG 3/7/2020 22:31:36'! - temporariesDeclaration - - ^ temporariesDeclaration! ! -!BlockNode methodsFor: 'accessing' stamp: 'RNG 3/7/2020 22:22:01'! - temporariesDeclaration: aTemporariesDeclarationNode - "RNG: after removing all the usages of the temporaries inst var, the last line can be removed" - - temporariesDeclaration := aTemporariesDeclarationNode. - self temporaries: aTemporariesDeclarationNode allDeclaredVariableNodes! ! -!MethodNode methodsFor: 'accessing' stamp: 'RNG 3/7/2020 22:32:32'! - temporariesDeclaration - - ^ temporariesDeclaration! ! -!MethodNode methodsFor: 'accessing' stamp: 'RNG 3/7/2020 22:20:11'! - temporariesDeclaration: aTemporariesDeclarationNode - "RNG: after removing all the usages of the temporaries inst var, the last line can be removed" - - temporariesDeclaration := aTemporariesDeclarationNode. - self temporaries: aTemporariesDeclarationNode allDeclaredVariableNodes! ! -!MethodNode methodsFor: 'initialization' stamp: 'RNG 3/7/2020 22:24:48'! - selector: selOrFalse arguments: args precedence: p temporariesDeclaration: tempsDeclaration block: blk encoder: anEncoder primitive: prim properties: propDict - "Initialize the receiver with respect to the arguments given." - "RNG: this is the preferred initializer (with temporariesDeclaration) as opposed to the one with 'temporaries' that is going to be deprecated" - - encoder := anEncoder. - selectorOrFalse := selOrFalse. - precedence := p. - arguments := args. - temporariesDeclaration _ tempsDeclaration. - temporaries := tempsDeclaration allDeclaredVariableNodes. - block := blk. - primitive := prim. - properties := propDict.! ! -!MethodNode methodsFor: 'initialization' stamp: 'RNG 3/7/2020 22:25:18'! - selector: selOrFalse arguments: args precedence: p temporariesDeclaration: tempsDeclaration block: blk encoder: anEncoder primitive: prim properties: propDict selectorKeywordsRanges: range - "RNG: this is the preferred initializer (with temporariesDeclaration) as opposed to the one with 'temporaries' that is going to be deprecated" - - selectorKeywordsRanges := range. - - ^ self selector: selOrFalse arguments: args precedence: p temporariesDeclaration: tempsDeclaration block: blk encoder: anEncoder primitive: prim properties: propDict! ! -!TemporariesDeclarationNode methodsFor: 'testing' stamp: 'RNG 3/7/2020 22:28:39'! - declaresAnyVariable - - ^ tempDeclarationNodes notEmpty! ! -!TemporariesDeclarationNode methodsFor: 'testing' stamp: 'RNG 3/7/2020 22:28:44'! - declaresVariable: aVariableNode - - ^ self allDeclaredVariableNodes - anySatisfy: [ :variableNode | variableNode isNamed: aVariableNode name ]! ! -!TemporariesDeclarationNode methodsFor: 'testing' stamp: 'RNG 3/7/2020 22:28:50' overrides: 50501878! - isTemporariesDeclaration - - ^ true! ! -!TemporariesDeclarationNode methodsFor: 'accessing' stamp: 'RNG 3/7/2020 22:28:14'! - allDeclaredVariableNodes - - ^ tempDeclarationNodes collect: [ :tempDeclaration | tempDeclaration variableNode ]! ! -!TemporariesDeclarationNode methodsFor: 'accessing' stamp: 'RNG 3/7/2020 22:33:16'! - temporaryDeclarationNodes - - ^ tempDeclarationNodes! ! -!TemporariesDeclarationNode methodsFor: 'printing' stamp: 'RNG 3/7/2020 22:27:53'! - printEachTempVarDeclarationOn: aStream - - ^ tempDeclarationNodes do: [ :tempDeclarationNode | - aStream nextPutAll: tempDeclarationNode variableName; space]! ! -!TemporariesDeclarationNode methodsFor: 'printing' stamp: 'RNG 3/7/2020 22:28:00' overrides: 16884940! - printOn: aStream indent: anInteger - - aStream nextPut: $|; space. - self printEachTempVarDeclarationOn: aStream. - aStream nextPut: $|.! ! -!TemporariesDeclarationNode methodsFor: 'initialization' stamp: 'RNG 3/7/2020 22:27:28'! - initializeWithAll: aCollectionOfTempDeclarationNodes - - tempDeclarationNodes _ aCollectionOfTempDeclarationNodes! ! -!TemporariesDeclarationNode class methodsFor: 'instance creation' stamp: 'RNG 3/7/2020 22:27:06'! - empty - - ^ self withAll: #()! ! -!TemporariesDeclarationNode class methodsFor: 'instance creation' stamp: 'RNG 3/7/2020 22:27:12'! - withAll: tempDeclarationNodes - - ^ self new initializeWithAll: tempDeclarationNodes! ! -!TemporaryDeclarationNode methodsFor: 'testing' stamp: 'RNG 3/7/2020 22:30:38'! - declaresVariable: aVariableNode - - ^ variableNode isNamed: aVariableNode name! ! -!TemporaryDeclarationNode methodsFor: 'testing' stamp: 'RNG 3/7/2020 22:30:46' overrides: 50501878! - isTemporariesDeclaration - - ^ true! ! -!TemporaryDeclarationNode methodsFor: 'printing' stamp: 'RNG 3/7/2020 22:30:25' overrides: 16884940! - printOn: aStream indent: anInteger - - aStream nextPut: $|; space. - variableNode printOn: aStream indent: anInteger. - aStream space; nextPut: $|.! ! -!TemporaryDeclarationNode methodsFor: 'accessing' stamp: 'RNG 3/7/2020 22:30:10'! - variableName - - ^ self variableNode name! ! -!TemporaryDeclarationNode methodsFor: 'accessing' stamp: 'RNG 3/7/2020 22:30:16'! - variableNode - - ^ variableNode! ! -!TemporaryDeclarationNode methodsFor: 'initialization' stamp: 'RNG 3/7/2020 22:29:58'! - initializeVariableNode: aVariableNode - - variableNode _ aVariableNode! ! -!TemporaryDeclarationNode class methodsFor: 'instance creation' stamp: 'RNG 3/7/2020 22:29:44'! - of: aVariableNode - - ^ self new initializeVariableNode: aVariableNode! ! -!BlockNode methodsFor: 'accessing' stamp: 'RNG 3/7/2020 22:21:23' prior: 50462164 overrides: 50487849! - temporaries - "Collection of TempVariableNodes" - - "RNG: implementation can be changed after adopting the use of temporariesDeclaration inst var. - After that, the implementation for this message can be changed to: - ^ temporariesDeclaration allDeclaredVariableNodes - - Or we can analyze the senders and change the way we request the temporaries" - - ^temporaries ifNil: [#()]! ! -!BlockNode methodsFor: 'accessing' stamp: 'RNG 3/7/2020 22:21:49' prior: 50488066 overrides: 50488050! - temporaries: aCollectionOfTemporaries - "Collection of TempVariableNodes" - "RNG: deprecated, try to use #temporariesDeclaration: instead" - - temporaries := aCollectionOfTemporaries! ! -!MethodNode methodsFor: 'accessing' stamp: 'RNG 3/7/2020 22:22:33' prior: 16872396 overrides: 50487849! - temporaries - "For transformations etc, not used in compilation" - - "RNG: implementation can be changed after adopting the use of temporariesDeclaration inst var. - After that, the implementation for this message can be changed to: - ^ temporariesDeclaration allDeclaredVariableNodes - - Or we can analyze the senders and change the way we request the temporaries" - - ^temporaries! ! -!MethodNode methodsFor: 'accessing' stamp: 'RNG 3/7/2020 22:22:44' prior: 50488080 overrides: 50488050! - temporaries: aCollectionOfTemporaries - "For transformations etc, not used in compilation" - "RNG: deprecated in favor of #temporariesDeclaration:" - - temporaries := aCollectionOfTemporaries! ! -!MethodNode methodsFor: 'initialization' stamp: 'RNG 3/7/2020 22:24:02' prior: 16873004! - selector: selOrFalse arguments: args precedence: p temporaries: temps block: blk encoder: anEncoder primitive: prim - "RNG: deprecated, use one of the methods that receives a temporariesDeclaration instead of the collection of temporaries" - - self - selector: selOrFalse - arguments: args - precedence: p - temporaries: temps - block: blk - encoder: anEncoder - primitive: prim - properties: AdditionalMethodState new.! ! -!MethodNode methodsFor: 'initialization' stamp: 'RNG 3/7/2020 22:24:16' prior: 16873016! - selector: selOrFalse arguments: args precedence: p temporaries: temps block: blk encoder: anEncoder primitive: prim properties: propDict - "Initialize the receiver with respect to the arguments given." - "RNG: its external use is deprecated, in favor of any of the methods that receives a temporariesDeclaration instead of the collection of temporaries" - - encoder := anEncoder. - selectorOrFalse := selOrFalse. - precedence := p. - arguments := args. - temporaries := temps. - block := blk. - primitive := prim. - properties := propDict.! ! -!MethodNode methodsFor: 'initialization' stamp: 'RNG 3/7/2020 22:24:34' prior: 50408782! - selector: selOrFalse arguments: args precedence: p temporaries: temps block: blk encoder: anEncoder primitive: prim properties: propDict selectorKeywordsRanges: range - "RNG: deprecated, use one of the methods that receives a temporariesDeclaration instead of the collection of temporaries" - - selectorKeywordsRanges := range. - - ^self selector: selOrFalse arguments: args precedence: p temporaries: temps block: blk encoder: anEncoder primitive: prim properties: propDict! ! - -CodeNode subclass: #BlockNode - instanceVariableNames: 'arguments statements returns nArgsNode size remoteCopyNode temporaries optimized optimizedMessageNode actualScopeIfOptimized blockExtent remoteTempNode copiedValues closureCreationNode startOfLastStatement tempsMark temporariesDeclaration' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #BlockNode category: #'Compiler-ParseNodes' stamp: 'Install-4085-TemporariesDefinitionASTNode-NahuelGarbezza-2020Mar07-22h12m-RNG.001.cs.st 4/1/2020 17:56:06'! -CodeNode subclass: #BlockNode - instanceVariableNames: 'arguments statements returns nArgsNode size remoteCopyNode temporaries optimized optimizedMessageNode actualScopeIfOptimized blockExtent remoteTempNode copiedValues closureCreationNode startOfLastStatement tempsMark temporariesDeclaration' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -CodeNode subclass: #MethodNode - instanceVariableNames: 'selectorOrFalse precedence arguments block primitive encoder temporaries properties sourceText locationCounter localsPool selectorKeywordsRanges temporariesDeclaration' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #MethodNode category: #'Compiler-ParseNodes' stamp: 'Install-4085-TemporariesDefinitionASTNode-NahuelGarbezza-2020Mar07-22h12m-RNG.001.cs.st 4/1/2020 17:56:06'! -CodeNode subclass: #MethodNode - instanceVariableNames: 'selectorOrFalse precedence arguments block primitive encoder temporaries properties sourceText locationCounter localsPool selectorKeywordsRanges temporariesDeclaration' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4085-TemporariesDefinitionASTNode-NahuelGarbezza-2020Mar07-22h12m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4059] on 13 March 2020 at 12:25:29 am'! - -"Change Set: 4060-CuisCore-AuthorName-2020Mar13-00h15m -Date: 13 March 2020 -Author: Nahuel Garbezza - -Allow Parser to parse temp declaration nodes. It has some code that needs to be cleaned up after integrating this change"! -!Parser methodsFor: 'temps' stamp: 'RNG 3/13/2020 00:16:54'! - createTempDeclarationOf: variableNode sourceRange: sourceRange - - | declarationNode | - declarationNode _ TemporaryDeclarationNode of: variableNode. - encoder noteSourceRange: sourceRange forNode: declarationNode. - ^ declarationNode! ! -!Parser methodsFor: 'temps' stamp: 'RNG 3/13/2020 00:17:01'! - createTempsDeclarationWith: tempDeclarationNodes sourceRange: sourceRange - - |tempsDeclarationNode| - tempsDeclarationNode _ TemporariesDeclarationNode withAll: tempDeclarationNodes. - encoder noteSourceRange: sourceRange forNode: tempsDeclarationNode. - ^ tempsDeclarationNode! ! -!Parser methodsFor: 'temps' stamp: 'RNG 3/13/2020 00:17:09'! - noTempsDeclaration - - ^ TemporariesDeclarationNode empty! ! -!Parser methodsFor: 'expression types' stamp: 'RNG 3/13/2020 00:23:38' prior: 50409717! - blockExpression - "[ ({:var} |) (| {temps} |) (statements) ] => BlockNode." - - | blockNode variableNodes temporaryBlockVariables start | - blockNode := BlockNode new. - variableNodes := OrderedCollection new. - start := prevMark + requestorOffset. - "Gather parameters." - [self match: #colon] whileTrue: - [self argumentNameWithRangeDo: [ :argumentName :range | - variableNodes addLast: (encoder bindBlockArg: argumentName within: blockNode range: range)]]. - (variableNodes size > 0 & (hereType ~~ #rightBracket) and: [(self match: #verticalBar) not]) ifTrue: - [^self expected: 'Vertical bar']. - - temporaryBlockVariables := self temporaryBlockVariablesFor: blockNode. - - "RNG - temporary change until we fully start using temporary declaration nodes in the parser" - temporaryBlockVariables isCollection - ifTrue: [ blockNode temporaries: temporaryBlockVariables ] - ifFalse: [ blockNode temporariesDeclaration: temporaryBlockVariables ]. - - self statements: variableNodes innerBlock: true blockNode: blockNode. - - (self match: #rightBracket) ifFalse: [^self expected: 'Period or right bracket']. - - blockNode noteSourceRangeStart: start end: self endOfLastToken encoder: encoder. - - "The scope of the parameters and temporary block variables is no longer active." - "RNG - temporary change until we fully start using temporary declaration nodes in the parser" - temporaryBlockVariables isCollection - ifTrue: [ temporaryBlockVariables do: [:variable | variable scope: -1] ] - ifFalse: [ temporaryBlockVariables allDeclaredVariableNodes do: [:variable | variable scope: -1] ]. - - variableNodes do: [:variable | variable scope: -1]! ! -!Parser methodsFor: 'expression types' stamp: 'RNG 3/13/2020 00:16:04' prior: 50485828! - method: noPattern doIt: doIt context: ctxt - " pattern [ | temporaries ] block => MethodNode." - - | sap block primitives temporaries messageComment methodNode | - - sap := self pattern: noPattern inContext: ctxt. - "sap={selector, arguments, precedence}" - self properties selector: (sap at: 1). - encoder selector: (sap at: 1). - (sap at: 2) do: [:argNode | argNode beMethodArg]. - - doIt ifFalse: [self pragmaSequence]. - temporaries := self temporaries. - messageComment := currentComment. - currentComment := nil. - doIt ifFalse: [self pragmaSequence]. - primitives := self pragmaPrimitives. - - self statements: #() innerBlock: doIt. - block := parseNode. - doIt - ifTrue: [block returnLast] - ifFalse: [block returnSelfIfNoOther: encoder]. - hereType == #doIt ifFalse: [^self expected: 'Nothing more']. - - methodNode := self newMethodNode comment: messageComment. - - "RNG - temporary change, until we start using temporary declaration nodes in the parser" - temporaries isCollection - ifTrue: [ - methodNode - selector: (sap at: 1) - arguments: (sap at: 2) - precedence: (sap at: 3) - temporaries: temporaries - block: block - encoder: encoder - primitive: primitives - properties: properties - selectorKeywordsRanges: (sap at: 4) ] - ifFalse: [ - methodNode - selector: (sap at: 1) - arguments: (sap at: 2) - precedence: (sap at: 3) - temporariesDeclaration: temporaries - block: block - encoder: encoder - primitive: primitives - properties: properties - selectorKeywordsRanges: (sap at: 4) ]. - - self interactive ifTrue: [ self performInteractiveChecks: methodNode ]. - - ^methodNode! ! -!Parser methodsFor: 'expression types' stamp: 'RNG 3/13/2020 00:24:08' prior: 50409558! - temporaries - " [ '|' (variable)* '|' ]" - | tempDeclarationNodes theActualText declarationStartIndex | - (self match: #verticalBar) ifFalse: - ["no temps" - doitFlag ifTrue: - [tempsMark := self interactive - ifTrue: [requestor selectionInterval first] - ifFalse: [1]. - ^ self noTempsDeclaration ]. - tempsMark := hereMark "formerly --> prevMark + prevToken". - tempsMark > 0 ifTrue: - [theActualText := source contents. - [tempsMark < theActualText size and: [(theActualText at: tempsMark) isSeparator]] - whileTrue: [tempsMark := tempsMark + 1]]. - ^ self noTempsDeclaration ]. - tempDeclarationNodes _ OrderedCollection new. - declarationStartIndex _ prevMark. - [hereType == #word] whileTrue: [ - self advanceWithRangeDo: [ :variableName :range | - | variableNode | - variableNode _ encoder bindTemp: variableName range: range. - tempDeclarationNodes addLast: (self createTempDeclarationOf: variableNode sourceRange: range) ] ]. - (self match: #verticalBar) ifTrue: [ - tempsMark := prevMark. - ^ self - createTempsDeclarationWith: tempDeclarationNodes - sourceRange: (declarationStartIndex to: prevMark) ]. - ^ self expected: 'Vertical bar'! ! -!Parser methodsFor: 'expression types' stamp: 'RNG 3/13/2020 00:24:05' prior: 50409756! - temporaryBlockVariablesFor: aBlockNode - "Scan and answer temporary block variables." - - | tempDeclarationNodes declarationStartIndex | - (self match: #verticalBar) ifFalse: - "There are't any temporary variables." - [aBlockNode tempsMark: prevMark + requestorOffset. - ^ self noTempsDeclaration ]. - - tempDeclarationNodes _ OrderedCollection new. - declarationStartIndex _ prevMark. - [hereType == #word] whileTrue: [ - self advanceWithRangeDo: [ :variableName :range | - | variableNode | - variableNode _ encoder bindBlockTemp: variableName within: aBlockNode range: range. - tempDeclarationNodes addLast: (self createTempDeclarationOf: variableNode sourceRange: range) ] ]. - (self match: #verticalBar) ifFalse: - [^self expected: 'Vertical bar']. - aBlockNode tempsMark: prevMark + requestorOffset. - ^ self - createTempsDeclarationWith: tempDeclarationNodes - sourceRange: (declarationStartIndex to: prevMark)! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4086-TemporariesDefinitionASTNode-NahuelGarbezza-2020Mar13-00h15m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4060] on 13 March 2020 at 12:29:32 am'! - -"Change Set: 4061-CuisCore-AuthorName-2020Mar13-00h27m -Date: 13 March 2020 -Author: Nahuel Garbezza - -Cleanup parse logic for temporaries as Array. Now generating temporary declaration nodes"! -!Parser methodsFor: 'expression types' stamp: 'RNG 3/13/2020 00:28:02' prior: 50502256! - blockExpression - "[ ({:var} |) (| {temps} |) (statements) ] => BlockNode." - - | blockNode tempsDeclarationNode variableNodes temporaryBlockVariables start | - blockNode := BlockNode new. - variableNodes := OrderedCollection new. - start := prevMark + requestorOffset. - "Gather parameters." - [self match: #colon] whileTrue: - [self argumentNameWithRangeDo: [ :argumentName :range | - variableNodes addLast: (encoder bindBlockArg: argumentName within: blockNode range: range)]]. - (variableNodes size > 0 & (hereType ~~ #rightBracket) and: [(self match: #verticalBar) not]) ifTrue: - [^self expected: 'Vertical bar']. - - tempsDeclarationNode := self temporaryBlockVariablesFor: blockNode. - temporaryBlockVariables := tempsDeclarationNode allDeclaredVariableNodes. - self statements: variableNodes innerBlock: true blockNode: blockNode. - blockNode temporariesDeclaration: tempsDeclarationNode. - - (self match: #rightBracket) ifFalse: [^self expected: 'Period or right bracket']. - - blockNode noteSourceRangeStart: start end: self endOfLastToken encoder: encoder. - - "The scope of the parameters and temporary block variables is no longer active." - temporaryBlockVariables do: [:variable | variable scope: -1]. - variableNodes do: [:variable | variable scope: -1]! ! -!Parser methodsFor: 'expression types' stamp: 'RNG 3/13/2020 00:27:50' prior: 50502310! - method: noPattern doIt: doIt context: ctxt - " pattern [ | temporaries ] block => MethodNode." - - | sap block primitives tempsDeclarationNode messageComment methodNode | - - sap := self pattern: noPattern inContext: ctxt. - "sap={selector, arguments, precedence}" - self properties selector: (sap at: 1). - encoder selector: (sap at: 1). - (sap at: 2) do: [:argNode | argNode beMethodArg]. - - doIt ifFalse: [self pragmaSequence]. - tempsDeclarationNode := self temporaries. - messageComment := currentComment. - currentComment := nil. - doIt ifFalse: [self pragmaSequence]. - primitives := self pragmaPrimitives. - - self statements: #() innerBlock: doIt. - block := parseNode. - doIt - ifTrue: [block returnLast] - ifFalse: [block returnSelfIfNoOther: encoder]. - hereType == #doIt ifFalse: [^self expected: 'Nothing more']. - - methodNode := self newMethodNode comment: messageComment. - methodNode - selector: (sap at: 1) - arguments: (sap at: 2) - precedence: (sap at: 3) - temporariesDeclaration: tempsDeclarationNode - block: block - encoder: encoder - primitive: primitives - properties: properties - selectorKeywordsRanges: (sap at: 4). - - self interactive ifTrue: [ self performInteractiveChecks: methodNode ]. - - ^methodNode! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4087-TemporariesDefinitionASTNode-NahuelGarbezza-2020Mar13-00h27m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4061] on 29 March 2020 at 4:05:51 pm'! - -"Change Set: 4062-CuisCore-AuthorName-2020Mar29-15h59m -Date: 29 March 2020 -Author: Nahuel Garbezza - -Add visitor protocol to temporary declaration nodes"! -!TemporariesDeclarationNode methodsFor: 'enumerating' stamp: 'RNG 3/29/2020 16:03:34'! - temporaryDeclarationNodesDo: aBlock - - self temporaryDeclarationNodes do: aBlock! ! -!TemporariesDeclarationNode methodsFor: 'visiting' stamp: 'RNG 3/29/2020 15:59:33' overrides: 16884650! - accept: aVisitor - - ^ aVisitor visitTemporariesDeclarationNode: self! ! -!TemporaryDeclarationNode methodsFor: 'visiting' stamp: 'RNG 3/29/2020 16:00:46' overrides: 16884650! - accept: aVisitor - - ^ aVisitor visitTemporaryDeclarationNode: self! ! -!ParseNodeVisitor methodsFor: 'visiting' stamp: 'RNG 3/29/2020 16:02:42'! - visitTemporariesDeclarationNode: aTemporariesDeclarationNode - - aTemporariesDeclarationNode temporaryDeclarationNodesDo: - [ :temporaryDeclarationNode | temporaryDeclarationNode accept: self ]! ! -!ParseNodeVisitor methodsFor: 'visiting' stamp: 'RNG 3/29/2020 16:01:42'! - visitTemporaryDeclarationNode: aTemporaryDeclarationNode! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4088-TemporariesDefinitionASTVisitor-NahuelGarbezza-2020Mar29-15h59m-RNG.1.cs.st----! - -'From Cuis 5.0 [latest update: #4062] on 29 March 2020 at 4:26:28 pm'! - -"Change Set: 4063-CuisCore-AuthorName-2020Mar29-16h16m -Date: 29 March 2020 -Author: Nahuel Garbezza - -Allow ParseNodeVisitor to visit temporary declaration nodes"! -!ParseNodeVisitor methodsFor: 'private - visiting' stamp: 'RNG 3/29/2020 16:23:39'! - visitIfNotNil: aParseNode - "RNG: this was implemented to support unexpected nil temporary declarations - (coming from instances of MethodNode and BlockNode that were living in the image - before the new parse nodes were introduced)" - - aParseNode ifNotNil: [ aParseNode accept: self ]! ! -!ParseNodeVisitor methodsFor: 'visiting' stamp: 'RNG 3/29/2020 16:22:29' prior: 16885349! - visitBlockNode: aBlockNode - - self visitIfNotNil: aBlockNode temporariesDeclaration. - aBlockNode statements do: - [ :statement| statement accept: self ]! ! -!ParseNodeVisitor methodsFor: 'visiting' stamp: 'RNG 3/29/2020 16:25:47' prior: 16885404! - visitMethodNode: aMethodNode - - self visitIfNotNil: aMethodNode temporariesDeclaration. - aMethodNode block accept: self! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4089-TemporariesDefinitionASTVisitor-NahuelGarbezza-2020Mar29-16h16m-RNG.1.cs.st----! - -'From Cuis 5.0 [latest update: #4062] on 29 March 2020 at 4:42:17 pm'! - -"Change Set: 4064-CuisCore-AuthorName-2020Mar29-16h26m -Date: 29 March 2020 -Author: Nahuel Garbezza - -Encapsulate iteration of collections for some parse nodes"! -!BraceNode methodsFor: 'enumerating' stamp: 'RNG 3/29/2020 16:29:30'! - elementsDo: aBlock - - elements do: aBlock! ! -!BlockNode methodsFor: 'enumerating' stamp: 'RNG 3/29/2020 16:37:51'! - statementsDo: aBlock - - statements do: aBlock! ! -!BraceNode methodsFor: 'code generation (closures)' stamp: 'RNG 3/29/2020 16:29:52' prior: 16790936! - analyseTempsWithin: scopeBlock "" rootNode: rootNode "" assignmentPools: assignmentPools "" - - self elementsDo: [ :node | - node analyseTempsWithin: scopeBlock rootNode: rootNode assignmentPools: assignmentPools ]! ! -!BraceNode methodsFor: 'code generation (new scheme)' stamp: 'RNG 3/29/2020 16:35:42' prior: 16791007! - emitCodeForValue: stack encoder: encoder - - (encoder supportsClosureOpcodes - "Hack; we have no way of knowing how much stack space is available" - and: [elements size <= self maxElementsForConsArray]) ifTrue: - [ self elementsDo: [:node| node emitCodeForValue: stack encoder: encoder]. - encoder genPushConsArray: elements size. - stack - pop: elements size; - push: 1. - ^self]. - ^emitNode emitCodeForValue: stack encoder: encoder! ! -!MessageNode methodsFor: 'macro transformations' stamp: 'RNG 3/29/2020 16:36:18' prior: 16869163! - transformCase: encoder - - | caseNode | - caseNode := arguments first. - (caseNode isMemberOf: BraceNode) ifFalse: [^false]. - (caseNode blockAssociationCheck: encoder) ifFalse: [^false]. - (arguments size = 1 - or: [self checkBlock: arguments last as: 'otherwise arg' from: encoder maxArgs: 0]) ifFalse: - [^false]. - caseNode elementsDo: - [:messageNode | - messageNode receiver noteOptimizedIn: self. - messageNode arguments first noteOptimizedIn: self]. - arguments size = 2 ifTrue: - [arguments last noteOptimizedIn: self]. - ^true! ! -!TemporariesDeclarationNode methodsFor: 'enumerating' stamp: 'RNG 3/29/2020 16:38:52' prior: 50502546! - temporaryDeclarationNodesDo: aBlock - - tempDeclarationNodes do: aBlock! ! -!ParseNodeVisitor methodsFor: 'visiting' stamp: 'RNG 3/29/2020 16:27:55' prior: 50502602! - visitBlockNode: aBlockNode - - self visitIfNotNil: aBlockNode temporariesDeclaration. - aBlockNode statementsDo: - [ :statement| statement accept: self ]! ! -!ParseNodeVisitor methodsFor: 'visiting' stamp: 'RNG 3/29/2020 16:36:33' prior: 16885355! - visitBraceNode: aBraceNode - - aBraceNode elementsDo: - [ :element | element accept: self ]! ! -!VariableScopeFinder methodsFor: 'visiting' stamp: 'RNG 3/29/2020 16:28:09' prior: 16942180 overrides: 50502693! - visitBlockNode: aBlockNode - "Answer the minimum enclosing node for aVariabe or nil if none. - If the variable is accessed in more than one statement then aBlockNode is the - enclosing node, otherwise it is which ever single block node that includes it, if any." - ^(self enclosingNodeFor: [:aBlock| aBlockNode statementsDo: aBlock] of: aBlockNode) ifNotNil: - [:aNode| - aNode isBlockNode ifTrue: [aNode] ifFalse: [aBlockNode]]! ! -!VariableScopeFinder methodsFor: 'visiting' stamp: 'RNG 3/29/2020 16:37:34' prior: 16942196 overrides: 50502701! - visitBraceNode: aBraceNode - "Answer the minimum enclosing node for aVariabe or nil if none. - If the variable is accessed in more than one subexpression then aBraceNode - is the enclosing node, otherwise it is which ever single node that includes it, if any." - ^self - enclosingNodeFor: [:aBlock| aBraceNode elementsDo: aBlock] - of: aBraceNode! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4090-TemporariesDefinitionASTVisitor-NahuelGarbezza-2020Mar29-16h26m-RNG.1.cs.st----! - -'From Cuis 5.0 [latest update: #4085] on 30 March 2020 at 3:14:54 pm'! -!ChangeList class methodsFor: 'scanning' stamp: 'HAW 3/30/2020 15:09:24' prior: 50479418! - knownPreambles - - ^ { 'commentStamp:'. 'methodsFor:'. }, ChangeList knownFileInPreambles! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4091-knownPreambles-HernanWilkinson-2020Mar30-15h09m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4085] on 30 March 2020 at 3:38:39 pm'! -!Compiler class methodsFor: 'utilities' stamp: 'HAW 3/30/2020 15:38:12'! - notSameMethodsAfterCompilingAll - - " - self notSameMethodsAfterCompilingAll - " - - | notEqual | - - notEqual := OrderedCollection new. - - ProtoObject withAllSubclassesDo: [ :class | - class selectorsDo: [ :selector | | currentCompiledMethod newCompiledMethod | - currentCompiledMethod := class >> selector. - newCompiledMethod := class - basicCompile: currentCompiledMethod sourceCode - notifying: nil - trailer: class defaultMethodTrailer - ifFail: [^self error: 'error compiling']. - currentCompiledMethod = newCompiledMethod method ifFalse: [ notEqual add: currentCompiledMethod ]]. - ]. - - ^notEqual.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4092-notSameMethodsAfterCompilingAll-HernanWilkinson-2020Mar30-15h36m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4074] on 29 March 2020 at 5:06:59 pm'! - -"Change Set: 4075-CuisCore-AuthorName-2020Mar29-16h47m -Date: 29 March 2020 -Author: Nahuel Garbezza - -Fix Extract Method error occurring on some optimized selector cases"! -!MessageNode methodsFor: 'testing' stamp: 'RNG 3/29/2020 17:02:11'! - hasEquivalentArgumentsWith: aMessageNode - - self arguments with: aMessageNode arguments do: - [ :myArgument :otherParseNodeArgument | (myArgument equivalentTo: otherParseNodeArgument) ifFalse: [ ^ false ] ]. - ^ true! ! -!MessageNode methodsFor: 'testing' stamp: 'RNG 3/29/2020 17:06:17' prior: 50488662 overrides: 50488478! - equivalentTo: aParseNode - - ^ ((aParseNode isMessageNode - and: [ self receiver equivalentTo: aParseNode receiver ]) - and: [ self selector = aParseNode selector ]) - and: [ self hasEquivalentArgumentsWith: aParseNode ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4093-ExtractMethodSpecialSelectors-NahuelGarbezza-2020Mar29-16h47m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4074] on 29 March 2020 at 7:37:44 pm'! - -"Change Set: 4075-CuisCore-AuthorName-2020Mar29-19h36m -Date: 29 March 2020 -Author: Nahuel Garbezza - -Remove unused classes from the old implementation of the Extract Temporary refactoring."! - -Smalltalk removeClassNamed: #ExtractToTemporaryRewriter! - -!classRemoval: #ExtractToTemporaryRewriter stamp: 'Install-4094-ExtractMethodClassesRemoval-NahuelGarbezza-2020Mar29-19h36m-RNG.001.cs.st 4/1/2020 17:56:07'! -ParseNodeVisitor subclass: #ExtractToTemporaryRewriter - instanceVariableNames: 'refactoring finder' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Smalltalk removeClassNamed: #ParseNodeToReplaceFinder! - -!classRemoval: #ParseNodeToReplaceFinder stamp: 'Install-4094-ExtractMethodClassesRemoval-NahuelGarbezza-2020Mar29-19h36m-RNG.001.cs.st 4/1/2020 17:56:07'! -ParseNodeVisitor subclass: #ParseNodeToReplaceFinder - instanceVariableNames: 'refactoring currentBlock nodesToReplace blockContainingFirstNodeToReplace firstNodeToReplaceIndex currentStatementIndex' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4094-ExtractMethodClassesRemoval-NahuelGarbezza-2020Mar29-19h36m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4069] on 23 March 2020 at 4:50:04 pm'! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'NPM 3/18/2020 19:50:30'! - selectorsOf: aClass beginningWith: aPrefix - - ^ (AutoCompleterSelectorsCollector for: aPrefix) - addSelectorsOf: aClass; - entriesToShow! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'NPM 3/18/2020 19:50:06'! - unaryAndBinarySelectorsOf: aClass beginningWith: aPrefix - - ^ (AutoCompleterSelectorsCollector for: aPrefix) - addUnaryAndBinarySelectorsOf: aClass; - entriesToShow! ! -!SmalltalkCompleter methodsFor: 'identifier entries - private' stamp: 'NPM 3/17/2020 17:53:08'! - computeIdentifierEntriesBeginningWith: aPrefix - "Use an aux Set to avoid duplicates, but keep the order given." - - | entriesSet lastTitle candidates | - entriesSet _ Set new. - lastTitle _ nil. - - candidates _ Array streamContents: [ :strm | - parser namesBeginningWith: aPrefix do: [ :identifier :kindOfIdentifierTitle | - (entriesSet includes: identifier) ifFalse: [ - kindOfIdentifierTitle = lastTitle ifFalse: [ - strm nextPut: kindOfIdentifierTitle. - lastTitle _ kindOfIdentifierTitle ]. - entriesSet add: identifier. - strm nextPut: identifier ]]]. - entriesSet size = 1 ifTrue: [ - ^ Array with: entriesSet anyOne ] - ifFalse: [ ^ candidates ]! ! -!SmalltalkCompleter methodsFor: 'message entries for unknown class - private' stamp: 'NPM 3/16/2020 23:09:03'! - computeMessageEntriesForUnknowClassAddingPossibleInvalidSelectorsTo: aCollection - - | selectorsToShow | - selectorsToShow _ OrderedCollection new. - - self class protected: [ - Selectors forPrefix: prefix keysAndValuesDo: [ :selector :lastUsedTime | - selectorsToShow := self add: selector and: lastUsedTime to: selectorsToShow. - (Object canUnderstand: selector) ifFalse: [ aCollection add: selector ]]]. - - selectorsToShow size < EntriesLimit ifTrue: [ selectorsToShow _ self sortByLastUsedTime: selectorsToShow ]. - - " To see the timestamps in the menu (need to tweak #insertCompletion: to activate. Right now, just for debugging) - entries _ selectorsToShow collect: [ :ary | ary first, '(', ((DateAndTime fromString: '01/01/1996 00:00') + ary second minutes) printString,')' ] - " - ^ selectorsToShow collect: [ :selectorAndTime | selectorAndTime first ] - -! ! -!SmalltalkCompleter methodsFor: 'accessing' stamp: 'NPM 3/17/2020 03:12:11'! - changePositionTo: newPosition - - position _ newPosition! ! -!SmalltalkCompleter methodsFor: 'accessing' stamp: 'NPM 3/17/2020 17:30:02'! - possibleInvalidSelectors - - ^ possibleInvalidSelectors! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'NPM 3/18/2020 19:50:06' prior: 50483480! - computeMessageEntriesWithBinaryMessageForClass: aClass - - selectorsClasses := Array with: aClass. - - entries := self unaryAndBinarySelectorsOf: aClass beginningWith: prefix. - ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'NPM 3/18/2020 19:51:12' prior: 50483490! - computeMessageEntriesWithoutBinaryMessageForClass: aClass - - selectorsClasses := Array with: aClass. - - entries := self selectorsOf: aClass beginningWith: prefix.! ! -!SmalltalkCompleter methodsFor: 'identifier entries - private' stamp: 'NPM 3/18/2020 20:44:01' prior: 50436380! - computeIdentifierEntries - - canShowSelectorDocumentation _ false. - entries _ self computeIdentifierEntriesBeginningWith: prefix.! ! -!SmalltalkCompleter methodsFor: 'message entries for unknown class - private' stamp: 'NPM 3/18/2020 20:47:56' prior: 50436405! - computeMessageEntriesForUnknowClass - - selectorsClasses _ #(). - possibleInvalidSelectors _ IdentitySet new. - canShowSelectorDocumentation _ true. - entries _ self computeMessageEntriesForUnknowClassAddingPossibleInvalidSelectorsTo: possibleInvalidSelectors.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4095-AutoCompleteRefactor-NicolasPapagnaMaldonado-2020Mar16-22h56m-NPM.5.cs.st----! - -'From Cuis 5.0 [latest update: #4074] on 30 March 2020 at 5:35:06 pm'! - -"Change Set: 4075-CuisCore-AuthorName-2020Mar30-17h23m -Date: 30 March 2020 -Author: Nahuel Garbezza - -Validate temporaries declaration cannot be extracted to a method if it is used outside of the selection interval"! -!MethodNode methodsFor: 'testing' stamp: 'RNG 3/30/2020 17:32:21'! - anyParseNodeWithin: aSourceCodeInterval satisfy: aCondition - - self completeSourceRangesDo: [ :parseNode :sourceRanges | - (aCondition value: parseNode) ifTrue: [ - sourceRanges anySatisfy: [ :sourceRange | aSourceCodeInterval rangeIncludes: sourceRange first ] - :: ifTrue: [ ^ true ]]]. - - ^ false! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 3/30/2020 17:31:54'! - isNotATempDeclarationWithUsagesOutOfIntervalToExtract - - initialNode key isTemporariesDeclaration ifFalse: [ ^ true ]. - - ^ (methodNode - anyParseNodeWithin: (intervalToExtract last to: sourceCode size) - satisfy: [ :parseNode | - parseNode isVariableNode - and: [ initialNode key declaresVariable: parseNode ] ]) not! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 3/30/2020 17:33:26'! - isNotDeclaredWithinIntervalToExtract: aVariableNode - - ^ (methodNode - anyParseNodeWithin: intervalToExtract - satisfy: [ :parseNode | parseNode isTemporariesDeclaration - and: [ parseNode declaresVariable: aVariableNode ] ]) not! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 3/30/2020 17:33:23'! - thereAreNoLocalVariableAssignmentsWithoutDeclaration - - ^ (methodNode - anyParseNodeWithin: intervalToExtract - satisfy: [ :parseNode | - parseNode isAssignmentToTemporary - and: [ self isNotDeclaredWithinIntervalToExtract: parseNode variable ] ]) not! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 3/30/2020 17:32:59' prior: 50492032! - containsValidNodes - - ^ self isNotLeftSideOfAssignment - and: [ self thereAreNoLocalVariableAssignmentsWithoutDeclaration ] - and: [ self thereAreNoReturnExpressions ] - and: [ self isNotATempDeclarationWithUsagesOutOfIntervalToExtract ] - and: [ self isNotATempDeclaration ]! ! - -ExtractMethodExpressionValidation removeSelector: #thereAreNoLocalVariableAssignments! - -!methodRemoval: ExtractMethodExpressionValidation #thereAreNoLocalVariableAssignments stamp: 'Install-4096-ExtractMethodFix-NahuelGarbezza-2020Mar30-17h23m-RNG.001.cs.st 4/1/2020 17:56:07'! -thereAreNoLocalVariableAssignments - - ^ methodNode - allParseNodesWithin: intervalToExtract - satisfy: [ :parseNode | parseNode isAssignmentToTemporary - and: [ self isDeclaredWithinIntervalToExtract: parseNode variable ] ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4096-ExtractMethodFix-NahuelGarbezza-2020Mar30-17h23m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4024] on 30 March 2020 at 6:10:32 pm'! - -Notification subclass: #PoolDefinitionNotification - instanceVariableNames: 'name' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Classes'! - -!classDefinition: #PoolDefinitionNotification category: #'Kernel-Classes' stamp: 'Install-4097-PoolDefinitionNotification-HernanWilkinson-2020Mar30-18h08m-HAW.1.cs.st 4/1/2020 17:56:07'! -Notification subclass: #PoolDefinitionNotification - instanceVariableNames: 'name' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Classes'! -!Class methodsFor: 'initialization' stamp: 'HAW 3/30/2020 18:09:32' prior: 16803027! - sharing: poolString - "Set up sharedPools. Answer whether recompilation is advisable." - | oldPools | - oldPools _ self sharedPools. - sharedPools _ OrderedCollection new. - (Scanner new scanFieldNames: poolString) do: - [:poolName | - sharedPools add: (Smalltalk at: poolName asSymbol ifAbsent:[ - (PoolDefinitionNotification signalNamed: poolName) - ifTrue:[Smalltalk at: poolName asSymbol put: Dictionary new] - ifFalse:[^self error: poolName,' does not exist']])]. - sharedPools isEmpty ifTrue: [sharedPools _ nil]. - ^oldPools anySatisfy: [ :pool | - self sharedPools noneSatisfy: [ :p | p == pool ]]! ! -!PositionableStream methodsFor: 'fileIn/Out' stamp: 'HAW 3/30/2020 18:09:14' prior: 50479433! -compileNextChunkHandlingExceptions - - [ self compileNextChunk ] - on: InMidstOfFileinNotification, UndeclaredVariableWarning, PoolDefinitionNotification - do: [ :ex | ex resume: true ]! ! -!PoolDefinitionNotification methodsFor: 'exception handling' stamp: 'HAW 3/30/2020 18:10:04' overrides: 16879527! - defaultAction - - | shouldResume | - - shouldResume := PopUpMenu confirm: 'The pool dictionary ', name,' does not exist.', - '\Do you want it automatically created?' withNewLines. - - ^ self resume: shouldResume ! ! -!PoolDefinitionNotification methodsFor: 'initialization' stamp: 'HAW 3/30/2020 18:10:08'! - initializeNamed: aName - - name := aName ! ! -!PoolDefinitionNotification class methodsFor: 'signaling' stamp: 'HAW 3/30/2020 18:09:58'! - signalNamed: aName - - ^(self named: aName) signal! ! -!PoolDefinitionNotification class methodsFor: 'instance creation' stamp: 'HAW 3/30/2020 18:09:54'! - named: aName - - ^self new initializeNamed: aName! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4097-PoolDefinitionNotification-HernanWilkinson-2020Mar30-18h08m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #4069] on 30 March 2020 at 7:41:32 pm'! -!SHTextStyler methodsFor: 'private' stamp: 'pb 3/30/2020 19:39:57' prior: 16903183! - privateFormatAndConvert - self subclassResponsibility ! ! -!SHTextStyler methodsFor: 'private' stamp: 'pb 3/30/2020 19:40:05' prior: 16903187! - privateStyle - self subclassResponsibility ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4098-should-be-subclassResponsibility-PhilBellalouna-2020Mar30-19h39m-pb.001.cs.st----! - -'From Cuis 5.0 [latest update: #4069] on 17 March 2020 at 1:55:28 pm'! -!Form methodsFor: 'analyzing' stamp: 'pb 3/17/2020 13:39:41' prior: 50383316! - primCountBits - "Count the non-zero pixels of this form." - self depth > 8 ifTrue: [ - ^(self asFormOfDepth: 8) primCountBits]. - ^ (BitBlt toForm: self) - fillColor: (Bitmap with: 0); - destRect: self boundingBox; - combinationRule: 32; - copyBits! ! -!Form methodsFor: 'converting' stamp: 'pb 3/17/2020 13:38:02' prior: 50383510! - asGrayForm: componentIndex -"Native depth" - "Assume the receiver is a grayscale image. Return a GrayForm computed by extracting the brightness levels of one color component. This technique allows a 32-bit Form to be converted to an 8-bit GrayForm to save space while retaining a full 255 levels of gray. (The usual colormapping technique quantizes to 8, 16, or 32 levels, which loses information.) - - If component = 1, take the alpha component - If component = 2, take the red component - If component = 3, take the green component - If component = 4, take the blue component - " - | f32 result map mask shift | - self depth = 32 ifFalse: [ - f32 _ Form extent: self extent depth: 32. - self displayOn: f32. - ^ f32 asGrayForm: componentIndex ]. - - result _ GrayForm extent: self extent. - shift _ #(-24 -16 -8 0) at: componentIndex. - mask _ #(16rFF000000 16rFF0000 16rFF00 16rFF) at: componentIndex. - map _ ColorMap masks: { mask. 0. 0. 0 } shifts: { shift. 0. 0. 0 }. - (BitBlt toForm: result) - sourceForm: self; - combinationRule: Form over; - colorMap: map; - sourceRect: self boundingBox ; - destOrigin: `0@0`; - copyBits. - ^ result! ! -!Form methodsFor: 'converting' stamp: 'pb 3/17/2020 13:39:15' prior: 50383549! - asGrayScaleAndTransparent: componentIndex -"Native depth" - "Assume the receiver is a grayscale image. Return a grayscale ColorForm computed by extracting the brightness levels of one color component. This technique allows a 32-bit Form to be converted to an 8-bit ColorForm to save space while retaining a full 255 levels of gray. (The usual colormapping technique quantizes to 8, 16, or 32 levels, which loses information.) - - If component = 1, take the alpha component - If component = 2, take the red component - If component = 3, take the green component - If component = 4, take the blue component - " - | f32 result map mask shift | - self depth = 32 ifFalse: [ - f32 _ Form extent: self extent depth: 32. - self displayOn: f32. - ^ f32 asGrayScaleAndTransparent: componentIndex ]. - - result _ ColorForm grayScaleAndTransparentExtent: self extent. - shift _ #(-24 -16 -8 0) at: componentIndex. - mask _ #(16rFF000000 16rFF0000 16rFF00 16rFF) at: componentIndex. - map _ ColorMap masks: { mask. 0. 0. 0 } shifts: { shift. 0. 0. 0 }. - (BitBlt toForm: result) - sourceForm: self; - combinationRule: Form over; - colorMap: map; - sourceRect: self boundingBox; - destOrigin: `0@0`; - copyBits. - - "final BitBlt to zero-out pixels that were truely transparent in the original" - map _ Bitmap new: 512. - map at: 1 put: 16rFF. - (BitBlt toForm: result) - sourceForm: self; - sourceRect: self boundingBox; - destOrigin: `0@0`; - combinationRule: Form erase; - colorMap: map; - copyBits. - ^ result! ! -!Morph methodsFor: 'geometry' stamp: 'pb 3/17/2020 13:51:15' prior: 50384206! - morphPositionInWorld - - self flag: #jmvVer2. - "Most likely we don't want to use global coordinates... - In fact, we could be in many frames of reference at the same time... - This method makes no sense at all!!" - - ^self externalizeToWorld: self morphTopLeft ! ! -!PasteUpMorph methodsFor: 'change reporting' stamp: 'pb 3/17/2020 13:41:52' prior: 50384240 overrides: 16874147! - invalidateDisplayRect: damageRect from: aMorph - "Clip damage reports to my bounds, since drawing is clipped to my bounds." - - self == self world - ifTrue: [ worldState recordDamagedRect: (damageRect intersect: self morphLocalBounds ) ] - ifFalse: [ super invalidateDisplayRect: damageRect from: aMorph ]! ! -!PasteUpMorph methodsFor: 'project state' stamp: 'pb 3/17/2020 13:42:03' prior: 50384289! - viewBox - - ^ worldState - ifNotNil: [ - self morphLocalBounds ] - ifNil: [ - self world viewBox ]! ! -!EllipseMorph methodsFor: 'geometry testing' stamp: 'pb 3/17/2020 13:36:07' prior: 50384329 overrides: 16875610! - morphContainsPoint: aLocalPoint - - | radius other delta xOverY | - (self morphLocalBounds containsPoint: aLocalPoint) ifFalse: [^ false]. "quick elimination" - extent > `1@1` - ifFalse: [^ true]. "Degenerate case -- code below fails by a bit" - - radius _ extent y asFloat / 2. - other _ extent x asFloat / 2. - delta _ aLocalPoint - (other@radius). - xOverY _ extent x asFloat / extent y asFloat. - ^ (delta x asFloat / xOverY) squared + delta y squared <= radius squared! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:42:18' prior: 50384382! - draw3DLookOn: aCanvas - - | borderStyleSymbol c | - borderStyleSymbol _ self isPressed ifFalse: [ #raised ] ifTrue: [ #inset ]. - c _ color. - self mouseIsOver ifTrue: [ c _ c lighter ]. - aCanvas - fillRectangle: self morphLocalBounds - color: c - borderWidth: borderWidth - borderStyleSymbol: borderStyleSymbol - baseColorForBorder: c. - - self drawRegularLabelOn: aCanvas! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:42:43' prior: 50384397! - drawRoundGradientLookOn: aCanvas - | r colorForButton rect bottomFactor topFactor | - - self isPressed - ifFalse: [ - topFactor _ Theme current buttonGradientTopFactor. - bottomFactor _ Theme current buttonGradientBottomFactor. - self mouseIsOver - ifTrue: [ - colorForButton _ Color h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ - colorForButton _ color ]] - ifTrue: [ - topFactor _ Theme current buttonGradientBottomFactor. - bottomFactor _ Theme current buttonGradientTopFactor. - colorForButton _ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - Theme current useButtonGradient - ifTrue: [ - rect _ self morphLocalBounds insetBy: `1@3`. - aCanvas - roundRect: rect - color: colorForButton - radius: r - gradientTop: topFactor - gradientBottom: bottomFactor - gradientHeight: Theme current buttonGradientHeight ] - ifFalse: [ - rect _ self morphLocalBounds insetBy: `1@3`. - aCanvas roundRect: rect color: colorForButton radius: r ] - ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawEmbossedLabelOn: aCanvas ] - ifFalse: [ self drawRegularLabelOn: aCanvas ]! ! -!PluggableButtonMorph methodsFor: 'geometry testing' stamp: 'pb 3/17/2020 13:43:00' prior: 50384453 overrides: 16875610! - morphContainsPoint: aLocalPoint - - | iconOrigin | - (self morphLocalBounds containsPoint: aLocalPoint) ifFalse: [ ^false ]. - ^ self isOrthoRectangularMorph or: [ - magnifiedIcon isNil or: [ - iconOrigin _ extent - magnifiedIcon extent // 2. - (magnifiedIcon isTransparentAt: (aLocalPoint - iconOrigin) rounded) not ]]! ! -!SystemWindow methodsFor: 'change reporting' stamp: 'pb 3/17/2020 13:53:05' prior: 50384596! - invalidateTitleArea - - "not really pretty... also invalidating the top border, regardless of it being above or below the title area - (Different themes use various looks, this covers them all)" - self invalidateLocalRect: (self morphTopLeft extent: extent x @ (self labelHeight + borderWidth))! ! -!SystemWindow methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:43:27' prior: 50384608! - drawClassicFrameOn: aCanvas color: titleColor - "Window border encompasses title area. No round corners. No title gradient." - - aCanvas fillRectangle: self morphLocalBounds color: color borderWidth: borderWidth borderStyleSymbol: #simple baseColorForBorder: self widgetsColor. - - "A border was drawn at the left, top and right of the title area. - The look is that the title area is inside the window" - aCanvas fillRectangle: (borderWidth@borderWidth extent: extent x - (2*borderWidth)@ self labelHeight) color: titleColor! ! -!SystemWindow methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:43:37' prior: 50384627! - drawRoundedFrameOn: aCanvas color: widgetsColor - "Title area is not inside window borders" - | bottomFactor topFactor | - Theme current useWindowTitleGradient - ifTrue: [ - topFactor _ Theme current titleGradientTopFactor. - bottomFactor _ Theme current titleGradientBottomFactor ] - ifFalse: [ - topFactor _ 1. - bottomFactor _ 1 ]. - aCanvas - windowFrame: self morphLocalBounds - color: widgetsColor * Theme current titleGradientExtraLightness - radius: Theme current roundedWindowRadius - border: borderWidth - labelHeight: self labelHeight + borderWidth - gradientTop: topFactor - gradientBottom: bottomFactor - insideColor: color! ! -!ScrollBar methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:43:16' prior: 50384852 overrides: 16790395! - drawOn: aCanvas - - aCanvas - fillRectangle: self morphLocalBounds - color: (color alphaMixed: 0.3 with: Theme current scrollbarColor) - borderWidth: borderWidth - borderStyleSymbol: #simple - baseColorForBorder: borderColor! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:35:12' prior: 50433552! - drawContainingRectangle: aCanvas - - aCanvas frameAndFillRectangle: self morphLocalBounds fillColor: self color borderWidth: borderWidth borderColor: borderColor. -! ! -!ImageMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:48:15' prior: 50385163 overrides: 16899205! - drawOn: aCanvas - - aCanvas image: image at: self morphTopLeft! ! -!StringMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:52:32' prior: 50385168 overrides: 16899205! - drawOn: aCanvas - aCanvas - drawString: (contents ifNil: [ '' ]) - at: self morphTopLeft - font: self fontToUse - color: color! ! -!IndentingListItemMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:40:18' prior: 50463664 overrides: 50503483! - drawOn: aCanvas - - | tRect colorToUse sLeft aForm centeringOffset | - isHighlighted ifTrue: [ - aCanvas - fillRectangle: self morphLocalBounds - color: ((Theme current - listHighlightFocused: owner owner hasKeyboardFocus) alpha: 0.3) ]. - isSelected ifTrue: [ - aCanvas - fillRectangle: self morphLocalBounds - color: (Theme current - listHighlightFocused: owner owner hasKeyboardFocus) ]. - - tRect _ self toggleRectangle. - aForm _ isExpanded - ifTrue: [ container expandedForm ] - ifFalse: [ container notExpandedForm ]. - centeringOffset _ ((tRect height - aForm extent y) / 2.0) rounded. - - complexContents hasContents ifTrue: [ - aCanvas - image: aForm - at: (tRect topLeft translatedBy: 0 @ centeringOffset) ]. - - icon isNil - ifFalse: [ - aCanvas - image: icon - at: (tRect topLeft translatedBy: icon width @ centeringOffset). - sLeft _ indentLevel * 12 + 16 + (icon width + 2). - ] - ifTrue: [ - sLeft _ indentLevel * 12 + 16. - ]. - colorToUse _ complexContents preferredColor ifNil: [ color ]. - - aCanvas - drawString: contents asString - at: sLeft@0 - font: self fontToUse - color: colorToUse! ! -!MenuItemMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:41:40' prior: 50472332 overrides: 50503483! - drawOn: aCanvas - | stringColor leftEdge | - - stringColor _ color. - isSelected & isEnabled - ifTrue: [ - aCanvas fillRectangle: self morphLocalBounds color: Theme current menuHighlight]. - leftEdge _ 0. - - self hasMarker ifTrue: [ - leftEdge _ leftEdge + submorphs first morphWidth + 8 ]. - - icon ifNotNil: [ - | iconForm w h factor magnifiedExtent magnifiedIcon | - iconForm _ isEnabled ifTrue: [ icon ] ifFalse: [ icon asGrayScaleAndTransparent ]. - magnifiedIcon _ iconForm. - w _ iconForm width. - h _ iconForm height. - w*h = 0 ifFalse: [ - factor _ extent y * 0.8 / h. - factor = 1.0 ifFalse: [ - magnifiedExtent _ (iconForm extent * factor) rounded. - magnifiedIcon _ iconForm magnifyTo: magnifiedExtent ]]. - aCanvas image: magnifiedIcon at: leftEdge+1 @ (magnifiedIcon height *1//10). - leftEdge _ magnifiedIcon width *12//10 + leftEdge]. - - aCanvas - drawString: contents - at: leftEdge @ 1 - font: self fontToUse - color: stringColor. - subMenu ifNotNil: [ - aCanvas - image: self class subMenuMarker - at: extent x - 8 @ (extent y - self class subMenuMarker height // 2) ]! ! -!LayoutAdjustingMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:41:10' prior: 50385328 overrides: 16899205! - drawOn: aCanvas - - aCanvas - fillRectangle: self morphLocalBounds - color: color! ! -!LayoutMorph methodsFor: 'layout' stamp: 'pb 3/17/2020 13:41:27' prior: 50385334! - layoutBounds - "Return the bounds for laying out children of the receiver" - - ^ self morphLocalBounds! ! -!HaloHandleMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:49:31' prior: 50385539 overrides: 16899205! - drawOn: aCanvas - - aCanvas - image: (self class circleForm: extent) - multipliedBy: color - at: self morphTopLeft ! ! -!InnerHierarchicalListMorph methodsFor: 'geometry' stamp: 'pb 3/17/2020 13:50:18' prior: 50385613! - itemFromPoint: aPoint - "Return the list element (morph) at the given point or nil if outside" - | ptY last | - self hasSubmorphs ifFalse: [ ^nil ]. - (aPoint > self morphTopLeft and: [ aPoint < extent ]) ifFalse: [ ^nil ]. - ptY _ aPoint y. - "note: following assumes that submorphs are vertical, non-overlapping, and ordered" - self firstSubmorph morphPosition y > ptY ifTrue: [ ^nil ]. - last _ self lastSubmorph. - last morphPosition y + last morphHeight < ptY ifTrue: [ ^nil ]. - "now use binary search" - ^self - findSubmorphBinary: [ :m | - (m morphPosition y <= ptY and: [ m morphPosition y + m morphHeight >= ptY ]) - ifTrue: [ 0 ] "found" - ifFalse: [ m morphPosition y + (m morphHeight // 2) > ptY ifTrue: [-1] ifFalse: [1]]]! ! -!InnerListMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:40:29' prior: 50385639! - drawBackgroundForMulti: row on: aCanvas - | selectionDrawBounds c | - "shade the background darker, if this row is selected" - selectionDrawBounds _ self drawBoundsForRow: row. - selectionDrawBounds _ selectionDrawBounds intersect: self morphLocalBounds. - c _ (selectedRow notNil and: [ row = selectedRow]) - ifTrue: [ Theme current listHighlightFocused: owner hasKeyboardFocus ] - ifFalse: [ Theme current listMultiHighlightFocused: owner hasKeyboardFocus ]. - aCanvas fillRectangle: selectionDrawBounds color: c! ! -!InnerListMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:40:40' prior: 50463702! - drawHighlightOn: aCanvas -"Ademas, poner el mouse pointer de relojito si tarda... Detectarlo automaticamente, etc. Aunque no estoy seguro de como hacerlo... quizas colgar un cachito de codigo en un proceso de mayor prioridad, onda 'si pasa 1 segundo, y todavia no te resetee este flag, entonces pone el relojito'" - | selectionDrawBounds | - highlightedRow ifNil: [ ^self ]. - highlightedRow = 0 ifTrue: [ ^self ]. - selectionDrawBounds _ self drawBoundsForRow: highlightedRow. - selectionDrawBounds _ selectionDrawBounds intersect: self morphLocalBounds. - aCanvas - fillRectangle: selectionDrawBounds - color: ((Theme current listHighlightFocused: owner hasKeyboardFocus) alpha: 0.3)! ! -!InnerListMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:40:50' prior: 50385682! - drawSelectionOn: aCanvas - | selectionDrawBounds | - selectedRow ifNil: [ ^self ]. - selectedRow = 0 ifTrue: [ ^self ]. - selectionDrawBounds _ self drawBoundsForRow: selectedRow. - selectionDrawBounds _ selectionDrawBounds intersect: self morphLocalBounds. - aCanvas - fillRectangle: selectionDrawBounds - color: (Theme current listHighlightFocused: owner hasKeyboardFocus)! ! -!InnerTextMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:41:01' prior: 50385697 overrides: 16899205! - drawOn: aCanvas - "Draw the receiver on a canvas" - - false ifTrue: [ self debugDrawLineRectsOn: aCanvas ]. "show line rects for debugging" - - aCanvas - textComposition: self textComposition - bounds: self morphLocalBounds - color: color - selectionColor: (Theme current textHighlightFocused: self hasKeyboardFocus)! ! -!FillInTheBlankMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:36:24' prior: 50385782 overrides: 16899205! - drawOn: aCanvas - - Theme current roundWindowCorners - ifTrue: [ - aCanvas - roundRect: self morphLocalBounds - color: color - radius: Theme current roundedWindowRadius ] - ifFalse: [ super drawOn: aCanvas ]! ! -!TranscriptMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:54:36' prior: 50385792 overrides: 16899205! - drawOn: aCanvas - Transcript - showOnDisplay: true; - displayOn: form in: self morphLocalBounds. - aCanvas image: form at: self morphTopLeft. - Transcript - bounds: self morphBoundsInWorld; - showOnDisplay: doImmediateUpdates. - self updateWorkspace! ! -!MenuLineMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:50:47' prior: 50385803 overrides: 16899205! - drawOn: aCanvas - | baseColor | - baseColor _ owner color. - aCanvas - fillRectangle: (self morphTopLeft corner: extent x @ (extent y / 2)) - color: baseColor twiceDarker. - - aCanvas - fillRectangle: (0 @ (extent y / 2) corner: extent) - color: baseColor twiceLighter! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4099-use-morph-bounds-PhilBellalouna-2020Mar17-13h35m-pb.001.cs.st----! - -'From Cuis 5.0 [latest update: #4099] on 31 March 2020 at 3:55:45 pm'! - -Object subclass: #FontPicker - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #FontPicker category: #'Morphic-Widgets' stamp: 'Install-4100-FontChanger-FontPicker-JuanVuletich-2020Mar31-15h53m-jmv.001.cs.st 4/1/2020 17:56:07'! -Object subclass: #FontPicker - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! -!FontFamily class methodsFor: 'accessing fonts' stamp: 'jmv 3/31/2020 10:18:34'! - familyNamed: aString - " - FontFamily familyNamed: 'DejaVu' - " - ^AvailableFamilies at: aString ifAbsent: [].! ! -!FontPicker class methodsFor: 'prompting user' stamp: 'jmv 3/31/2020 10:42:28'! - familyNames - | monospacedStrikeFont options | - monospacedStrikeFont _ 'DejaVu Sans Mono'. - options _ FontFamily familyNames. - (options includes: monospacedStrikeFont) ifFalse: [ - options _ options copyWith: monospacedStrikeFont ]. - ^ options! ! -!FontPicker class methodsFor: 'prompting user' stamp: 'jmv 3/31/2020 10:42:28'! - promptUser - "Present a menu of font families, answer selection. - FontChanger promptUser - " - ^self promptUserWithFamilies: AbstractFont familyNames.! ! -!FontPicker class methodsFor: 'prompting user' stamp: 'jmv 3/31/2020 10:42:28'! - promptUserAndSetDefault - "Present a menu of available font families, and if one is chosen, change to it." - self promptUserAndSetDefaultWithFamilies: AbstractFont familyNames.! ! -!FontPicker class methodsFor: 'prompting user' stamp: 'jmv 3/31/2020 10:42:28'! - promptUserAndSetDefaultWithFamilies: fontFamilies - "Present a menu of font families, and if one is chosen, change to it." - self promptUserWithFamilies: fontFamilies withMessageOnSelection: #setDefaultFont:! ! -!FontPicker class methodsFor: 'prompting user' stamp: 'jmv 3/31/2020 10:42:28'! - promptUserInstallIfNecessaryWithFamilies: fontFamilies - " - Present a menu of available font families, and if one is chosen, - install it if necessary, and change to it. - " - self promptUserWithFamilies: fontFamilies withMessageOnSelection: #promptUserAndSetDefaultWithFamilies:! ! -!FontPicker class methodsFor: 'prompting user' stamp: 'jmv 3/31/2020 10:42:28'! - promptUserWithFamilies: fontFamilies - "Present a menu of font families, answer selection." - | fontMenu priorFontFamily | - priorFontFamily _ FontFamily defaultFamilyName. - fontMenu _ MenuMorph new defaultTarget: self. - fontFamilies do: [:fontName | - | isCurrent label | - isCurrent _ priorFontFamily sameAs: fontName. - label _ self toSelectableMenuLabel: fontName isCurrent: isCurrent. - fontMenu - add: label - target: fontMenu - action: #modalSelection: - argument: fontName. - ]. - ^FontFamily familyNamed: fontMenu invokeModal.! ! -!FontPicker class methodsFor: 'prompting user' stamp: 'jmv 3/31/2020 10:42:28'! - promptUserWithFamilies: fontFamilies withMessageOnSelection: aMessageSymbol - " - Present a menu of available font families, and if one is chosen, - send aMessageSymbol to self with the corresponding font family as argument. - " - | fontMenu priorFontFamily | - priorFontFamily _ FontFamily defaultFamilyName. - fontMenu _ MenuMorph new defaultTarget: self. - fontFamilies do: [:fontName | - | isCurrent label | - isCurrent _ priorFontFamily sameAs: fontName. - label _ self toSelectableMenuLabel: fontName isCurrent: isCurrent. - fontMenu - add: label - target: self - action: aMessageSymbol - argument: fontName. - ]. - ^fontMenu invokeModal.! ! -!FontPicker class methodsFor: 'changing font' stamp: 'jmv 3/31/2020 10:42:28'! - changeTo: aFontName - "Change the font on the whole system without changing point sizes." - FontFamily defaultFamilyName: aFontName. - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: { - {#setListFontTo:. Preferences standardListFont pointSize.}. - {#setMenuFontTo:. Preferences standardMenuFont pointSize.}. - {#setWindowTitleFontTo:. Preferences windowTitleFont pointSize.}. - {#setCodeFontTo:. Preferences standardCodeFont pointSize.}. - {#setButtonFontTo:. Preferences standardButtonFont pointSize.}. - }. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]. -! ! -!FontPicker class methodsFor: 'changing font' stamp: 'jmv 3/31/2020 10:42:28'! - installFontIfNecessary: aFontName - | isFontInstalled | - isFontInstalled _ FontFamily familyNames includes: aFontName. - isFontInstalled ifFalse: [StrikeFont install: aFontName.].! ! -!FontPicker class methodsFor: 'changing font' stamp: 'jmv 3/31/2020 10:42:28'! - setDefaultAndInstallIfNecessary: aFontName - "install the font if necessary, and change to it on the whole system without changing point sizes." - self installFontIfNecessary: aFontName. - self setDefaultFont: aFontName. -! ! -!FontPicker class methodsFor: 'changing font' stamp: 'jmv 3/31/2020 10:42:28'! - setDefaultFont: aFontName - "Change the font on the whole system without changing point sizes." - FontFamily defaultFamilyName: aFontName. - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: { - {#setListFontTo:. Preferences standardListFont pointSize.}. - {#setMenuFontTo:. Preferences standardMenuFont pointSize.}. - {#setWindowTitleFontTo:. Preferences windowTitleFont pointSize.}. - {#setCodeFontTo:. Preferences standardCodeFont pointSize.}. - {#setButtonFontTo:. Preferences standardButtonFont pointSize.}. - }. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]. - -! ! -!FontPicker class methodsFor: 'private' stamp: 'jmv 3/31/2020 10:42:28'! - toSelectableMenuLabel: aString isCurrent: isCurrent - | label | - isCurrent ifTrue: [label _ ''] ifFalse: [label _ '']. - ^label, aString! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 3/31/2020 10:43:09' prior: 50458083! - preferencesMenu - "Build the preferences menu for the world." - - ^ (self menu: 'Preferences...') - addItemsFromDictionaries: { - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Font Sizes...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Set font...'. - #object -> FontPicker. - #selector -> #promptUserInstallIfNecessaryWithFamilies:. - #arguments -> {FontPicker familyNames}. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'change the current font family.' - } asDictionary. - { - #label -> 'Load extra fonts'. - #object -> FontFamily. - #selector -> #readAdditionalTrueTypeFonts. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'Load additional TrueType fonts included with Cuis.' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }! ! - -Smalltalk removeClassNamed: #FontChanger! - -!classRemoval: #FontChanger stamp: 'Install-4100-FontChanger-FontPicker-JuanVuletich-2020Mar31-15h53m-jmv.001.cs.st 4/1/2020 17:56:07'! -Object subclass: #FontChanger - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-GUI'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4100-FontChanger-FontPicker-JuanVuletich-2020Mar31-15h53m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4100] on 31 March 2020 at 6:32:04 pm'! -!Character class methodsFor: 'converting' stamp: 'jmv 3/31/2020 18:30:21'! - evaluateOnce: aBlock withUtf8BytesOfUnicodeCodePoint: aCodePoint - "Similar to #evaluate:withUtf8BytesOfUnicodeCodePoint:, but aBlock is evaluated just once, and must have 4 parameters." - - | mask nBytes shift byte1 byte2 byte3 byte4 | - aCodePoint < 128 ifTrue: [ - ^aBlock value: aCodePoint value: nil value: nil value: nil ]. - nBytes _ aCodePoint highBit + 3 // 5. - mask _ #(128 192 224 240 248 252 254 255) at: nBytes. - shift _ nBytes - 1 * -6. - byte1 _ (aCodePoint bitShift: shift) + mask. - nBytes >= 2 ifTrue: [ - shift _ shift + 6. - byte2 _ ((aCodePoint bitShift: shift) bitAnd: 63) + 128. - nBytes >= 3 ifTrue: [ - shift _ shift + 6. - byte3 _ ((aCodePoint bitShift: shift) bitAnd: 63) + 128. - nBytes = 4 ifTrue: [ - shift _ shift + 6. - byte4 _ ((aCodePoint bitShift: shift) bitAnd: 63) + 128. - ]. - ]. - ]. - ^aBlock value: byte1 value: byte2 value: byte3 value: byte4.! ! -!String class methodsFor: 'instance creation' stamp: 'jmv 3/31/2020 16:22:54'! - utf32FromUtf8: aByteArray - "Convert the given string from UTF-8 to UTF-32" - - ^IntegerArray streamContents: [ :strm | | bytes codePoint | - bytes _ aByteArray readStream. - [ bytes atEnd ] whileFalse: [ - codePoint _ (Character nextUnicodeCodePointFromUtf8: bytes). - codePoint ifNotNil: [ - strm nextPut: codePoint ]]]! ! -!String class methodsFor: 'instance creation' stamp: 'jmv 3/31/2020 16:25:01'! - utf8FromUtf32: anIntegerArray - "Convert the given string from UTF-8 to UTF-32" - - ^ByteArray streamContents: [ :strm | - anIntegerArray do: [ :codePoint | - Character - evaluate: [ :byte | strm nextPut: byte ] - withUtf8BytesOfUnicodeCodePoint: codePoint ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4101-utf32-JuanVuletich-2020Mar31-18h29m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4101] on 31 March 2020 at 7:07:55 pm'! -!FontPicker class methodsFor: 'prompting user' stamp: 'jmv 3/31/2020 19:00:47'! - promptUserAndSetDefaultInstallIfNecessaryWithFamilies: fontFamilies - " - Present a menu of available font families, and if one is chosen, - install it if necessary, and change to it. - " - self promptUserWithFamilies: fontFamilies withMessageOnSelection: #setDefaultAndInstallIfNecessary:! ! -!FontPicker class methodsFor: 'prompting user' stamp: 'jmv 3/31/2020 19:07:33' prior: 50503759! - promptUser - "Present a menu of font families, answer selection. - FontPicker promptUser - " - ^self promptUserWithFamilies: AbstractFont familyNames.! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 3/31/2020 19:02:26' prior: 50503912! - preferencesMenu - "Build the preferences menu for the world." - - ^ (self menu: 'Preferences...') - addItemsFromDictionaries: { - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Font Sizes...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Set font...'. - #object -> FontPicker. - #selector -> #promptUserAndSetDefaultInstallIfNecessaryWithFamilies:. - #arguments -> {FontPicker familyNames}. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'change the current font family.' - } asDictionary. - { - #label -> 'Load extra fonts'. - #object -> FontFamily. - #selector -> #readAdditionalTrueTypeFonts. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'Load additional TrueType fonts included with Cuis.' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }! ! - -FontPicker class removeSelector: #promptUserInstallIfNecessaryWithFamilies:! - -!methodRemoval: FontPicker class #promptUserInstallIfNecessaryWithFamilies: stamp: 'Install-4102-FontPicker-fixes-JuanVuletich-2020Mar31-19h06m-jmv.001.cs.st 4/1/2020 17:56:07'! -promptUserInstallIfNecessaryWithFamilies: fontFamilies - " - Present a menu of available font families, and if one is chosen, - install it if necessary, and change to it. - " - self promptUserWithFamilies: fontFamilies withMessageOnSelection: #promptUserAndSetDefaultWithFamilies:! - -FontPicker class removeSelector: #changeTo:! - -!methodRemoval: FontPicker class #changeTo: stamp: 'Install-4102-FontPicker-fixes-JuanVuletich-2020Mar31-19h06m-jmv.001.cs.st 4/1/2020 17:56:07'! -changeTo: aFontName - "Change the font on the whole system without changing point sizes." - FontFamily defaultFamilyName: aFontName. - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: { - {#setListFontTo:. Preferences standardListFont pointSize.}. - {#setMenuFontTo:. Preferences standardMenuFont pointSize.}. - {#setWindowTitleFontTo:. Preferences windowTitleFont pointSize.}. - {#setCodeFontTo:. Preferences standardCodeFont pointSize.}. - {#setButtonFontTo:. Preferences standardButtonFont pointSize.}. - }. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]. -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4102-FontPicker-fixes-JuanVuletich-2020Mar31-19h06m-jmv.001.cs.st----! - -----SNAPSHOT----(1 April 2020 17:56:15) Cuis5.0-4102-32.image priorSource: 5229535! - -----QUIT----(1 April 2020 17:56:34) Cuis5.0-4102-32.image priorSource: 5523785! - -----STARTUP---- (3 April 2020 11:07:08) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4102-32.image! - - -'From Cuis 5.0 [latest update: #4102] on 2 April 2020 at 3:45:31 pm'! -!CompiledMethod methodsFor: 'source code management' stamp: 'jmv 4/2/2020 11:38:53'! - getPreamble - | file preamble | - self fileIndex = 0 ifTrue: [^ String new]. "no source pointer for this method" - file _ SourceFiles at: self fileIndex. - file ifNil: [^ '']. "sources file not available" - "file does not exist happens in secure mode" - [ - file name asFileEntry readStreamDo: [ :stream | - preamble _ (self getPreambleFrom: stream at: (0 max: self filePosition)) ifNil: [ '' ]. - ] - ] on: FileDoesNotExistException do: [ :ex | preamble _ '' ]. - ^ preamble! ! -!CompiledMethod class methodsFor: 'source code management aux' stamp: 'HAW 10/29/2019 11:06:21'! - classCategoryFrom: tokens - - ^self field: #category: from: tokens ifAbsentOrNil: [ Categorizer default ]! ! -!CompiledMethod class methodsFor: 'source code management aux' stamp: 'HAW 10/29/2019 10:53:32'! - field: aFieldName from: tokens ifAbsentOrNil: aBlock - - | fieldValue fieldIndex | - - fieldIndex _ tokens indexOf: aFieldName ifAbsent: [ ^aBlock value ]. - fieldValue _ tokens at: fieldIndex + 1 ifAbsent: [ ^aBlock value ]. - - ^ fieldValue ifNil: aBlock! ! -!CompiledMethod class methodsFor: 'source code management aux' stamp: 'jmv 4/2/2020 12:50:44'! - overridenMethodReferenceFrom: tokens - - ^ self field: #overrides: from: tokens ifAbsentOrNil: [ nil ]! ! -!CompiledMethod class methodsFor: 'source code management aux' stamp: 'jmv 4/2/2020 12:51:03'! - priorReferenceFrom: tokens - - ^ self field: #prior: from: tokens ifAbsentOrNil: [ nil ]! ! -!CompiledMethod class methodsFor: 'source code management aux' stamp: 'HAW 10/29/2019 10:54:41'! - stampFrom: tokens - - ^self field: #stamp: from: tokens ifAbsentOrNil: [ '' ] - -! ! -!MessageSet methodsFor: 'message list' stamp: 'jmv 4/2/2020 13:12:43' prior: 50449428 overrides: 16792430! - selectedMessage - "Answer the source method for the currently selected message." - - | class selector | - selectedMessage ifNil: [^ 'Class vanished']. - - class _ selectedMessage actualClass. - selector _ selectedMessage methodSymbol. - selector ifNil: [ ^'prims']. - - selector first isUppercase ifTrue: [ - selector == #Comment ifTrue: [ - currentCompiledMethod _ class organization commentRemoteStr. - ^ class comment ]. - selector == #Definition ifTrue: [ - ^ class definition ]. - selector == #Hierarchy ifTrue: [ - ^ class printHierarchy ]]. - - (class notNil and: [ class includesSelector: selector]) ifFalse: [ - currentCompiledMethod _ nil. - ^ 'Missing']. - - self showingDecompile ifTrue: [ - ^ self decompiledSource ]. - - currentCompiledMethod _ class compiledMethodAt: selector ifAbsent: nil. - self showingDocumentation ifTrue: [ - ^ self commentContents ]. - - ^self sourceStringPrettifiedAndDiffed! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/29/2019 11:06:27' prior: 50481495! - classDefinitionRecordFrom: tokens - - | classDefinition isMeta itemPosition className record fullClassName category stamp | - - itemPosition _ file position. - fullClassName _ tokens second. - isMeta _ fullClassName includesSubString: ' class'. - className _ isMeta ifTrue: [fullClassName substrings first] ifFalse: [fullClassName]. - category _ CompiledMethod classCategoryFrom: tokens. - stamp _ CompiledMethod stampFrom: tokens. - classDefinition _ file nextChunk. - - record _ ChangeRecord new - file: file - position: itemPosition - type: #classDefinition - class: className asSymbol - category: category - meta: isMeta - stamp: stamp. - - record markAsTest: (classDefinition beginsWith: TestCase name asString). - - ^record -! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 17:58:04' prior: 50479634! - scanClassRemoval: tokens - - | doItOnlyIfInBaseSystem removeType classDefinition className description record stamp | - - removeType _ tokens first. - className _ tokens second. - doItOnlyIfInBaseSystem _ removeType == #classMoveToSomePackage:. - stamp _ CompiledMethod stampFrom: tokens. - classDefinition _ file nextChunk. - - record _ ClassDeletionChangeRecord - className: className - definition: classDefinition - doItOnlyIfInBaseSystem: doItOnlyIfInBaseSystem - stamp: stamp. - - description _ doItOnlyIfInBaseSystem - ifTrue: ['clase move to some package: '] - ifFalse: ['class removal: ']. - - self - addItem: record - text: description, className, '; ', stamp ! ! -!ChangeList methodsFor: 'scanning' stamp: 'MGD 12/19/2019 19:36:26' prior: 50501132! - scanClassRenamed: tokens - - | record stamp newName previousName preamble | - - preamble _ tokens first. - previousName _ tokens second. - newName _ tokens fourth. - stamp _ CompiledMethod stampFrom: tokens. - file nextChunk. - - record _ ClassRenamedChangeRecord from: previousName to: newName stamp: stamp. - - self - addItem: record - text: preamble, previousName, ' - ', newName, '; ', stamp ! ! -!ChangeList methodsFor: 'scanning' stamp: 'jmv 4/2/2020 12:51:10' prior: 50500950! - scanMethodDefinition: tokens - - | stamp className priorMethod overridenMethod | - - className _ tokens first. - stamp _ CompiledMethod stampFrom: tokens. - priorMethod _ CompiledMethod priorReferenceFrom: tokens. - overridenMethod _ CompiledMethod overridenMethodReferenceFrom: tokens. - - tokens second == #methodsFor: ifTrue: [ - ^ self scanCategory: tokens third class: className meta: false stamp: stamp prior: priorMethod overrides: overridenMethod ]. - - tokens third == #methodsFor: ifTrue: [ - ^ self scanCategory: tokens fourth class: className meta: true stamp: stamp prior: priorMethod overrides: overridenMethod ]. - - self error: 'Unsupported method definition' -! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 23:23:14' prior: 50479833! - scanMethodRemoval: tokens - - | doItOnlyIfInBaseSystem removeType isMeta sourceCode methodReference className description record selector stamp | - - removeType _ tokens first. - className _ tokens second. - doItOnlyIfInBaseSystem _ removeType == #methodMoveToSomePackage:. - - sourceCode _ file nextChunk. - isMeta _ tokens third == #class. - selector _ isMeta ifTrue: [ tokens fourth ] ifFalse: [ tokens third ]. - stamp _ CompiledMethod stampFrom: tokens. - - methodReference _ MethodReference new - setClassSymbol: className - classIsMeta: isMeta - methodSymbol: selector - stringVersion: className, (isMeta ifTrue: [' class '] ifFalse: [' ']), selector,'; ', stamp. - - record _ MethodDeletionChangeRecord - methodReference: methodReference - doItOnlyIfInBaseSystem: doItOnlyIfInBaseSystem - source: sourceCode - stamp: stamp. - - description _ doItOnlyIfInBaseSystem - ifTrue: ['method move to some package: '] - ifFalse: ['method removal: ']. - - self - addItem: record - text: description, methodReference stringVersion! ! -!VersionsBrowser methodsFor: 'init & update' stamp: 'jmv 4/2/2020 12:51:19' prior: 16942342! - scanVersionsOf: method class: class meta: meta category: category selector: selector - | position stamp prevPos prevFileIndex preamble tokens sourceFilesCopy | - selectorOfMethod _ selector. - currentCompiledMethod _ method. - classOfMethod _ meta ifTrue: [class class] ifFalse: [class]. - changeList _ OrderedCollection new. - list _ OrderedCollection new. - self addedChangeRecord ifNotNil: [ :change | - self addItem: change text: ('{1} (in {2})' format: { change stamp. change fileName }) ]. - listIndex _ 0. - position _ method filePosition. - sourceFilesCopy _ SourceFiles collect: - [:x | x ifNotNil: [ x name asFileEntry readStream ]]. - method fileIndex = 0 ifTrue: [^ nil]. - file _ sourceFilesCopy at: method fileIndex. - [position notNil & file notNil] - whileTrue: - [file position: (0 max: position-150). "Skip back to before the preamble" - [file position < (position-1)] "then pick it up from the front" - whileTrue: [ - preamble _ file nextChunk. - file skipSeparators "Skip any padding" - ]. - - "Preamble is likely a linked method preamble, if we're in - a changes file (not the sources file). Try to parse it - for prior source position and file index" - prevFileIndex _ nil. - prevPos _ nil. - stamp _ ''. - (preamble includesSubString: 'methodsFor:') - ifTrue: [ - tokens _ Scanner new scanTokens: preamble. - stamp _ CompiledMethod stampFrom: tokens. - (CompiledMethod priorReferenceFrom: tokens) ifNotNil: [ :priorMethodRef | - prevFileIndex _ sourceFilesCopy fileIndexFromSourcePointer: priorMethodRef. - prevPos _ sourceFilesCopy filePositionFromSourcePointer: priorMethodRef ]]. - self addItem: - (ChangeRecord new file: file position: position type: #method - class: class name category: category meta: meta stamp: stamp) - text: stamp , ' ' , class name , (meta ifTrue: [' class '] ifFalse: [' ']) , selector. - position _ prevPos. - prevPos notNil ifTrue: [ - file _ sourceFilesCopy at: prevFileIndex]]. - sourceFilesCopy do: [:x | x notNil ifTrue: [x close]]. - self clearSelections! ! -!ClassCommentVersionsBrowser methodsFor: 'basic function' stamp: 'jmv 4/2/2020 12:55:42' prior: 16805352! - scanVersionsOf: class - "Scan for all past versions of the class comment of the given class" - - | oldCommentRemoteStr sourceFilesCopy position prevPos stamp preamble tokens prevFileIndex | - - classOfMethod _ class. - oldCommentRemoteStr _ class organization commentRemoteStr. - currentCompiledMethod _ oldCommentRemoteStr. - selectorOfMethod _ #Comment. - changeList _ OrderedCollection new. - list _ OrderedCollection new. - listIndex _ 0. - oldCommentRemoteStr ifNil:[^ nil] ifNotNil: [oldCommentRemoteStr sourcePointer]. - - sourceFilesCopy _ SourceFiles collect: [ :x | x ifNotNil: [x name asFileEntry readStream]]. - position _ oldCommentRemoteStr position. - file _ sourceFilesCopy at: oldCommentRemoteStr sourceFileNumber. - [ position notNil & file notNil] whileTrue: [ - file position: (0 max: position-150). " Skip back to before the preamble" - [file position < (position-1)] "then pick it up from the front" - whileTrue: [ - preamble _ file nextChunk. - file skipSeparators "Skip any padding" - ]. - - prevPos _ nil. - stamp _ ''. - (preamble includesSubString: 'commentStamp:') - ifTrue: [ - tokens _ Scanner new scanTokens: preamble. - stamp _ CompiledMethod field: #commentStamp: from: tokens ifAbsentOrNil: [ '' ]. - (CompiledMethod priorReferenceFrom: tokens) ifNotNil: [ :priorRef | - prevFileIndex _ sourceFilesCopy fileIndexFromSourcePointer: priorRef. - prevPos _ sourceFilesCopy filePositionFromSourcePointer: priorRef ]] - ifFalse: [ - "The stamp get lost, maybe after a condenseChanges" - stamp _ '']. - self addItem: - (ChangeRecord new file: file position: position type: #classComment - class: class name category: nil meta: class isMeta stamp: stamp) - text: stamp , ' ' , class name , ' class comment'. - prevPos = 0 ifTrue: [ prevPos _ nil ]. - position _ prevPos. - prevPos notNil ifTrue: [ file _ sourceFilesCopy at: prevFileIndex ]]. - sourceFilesCopy do: [ :x | x notNil ifTrue: [ x close ]]. - self clearSelections! ! -!CompiledMethod methodsFor: 'time stamp' stamp: 'jmv 4/2/2020 12:23:16' prior: 50381386! - timeStamp - "Answer the authoring time-stamp for the given method, retrieved from the sources or changes file. Answer the empty string if no time stamp is available. - (CompiledMethod compiledMethodAt: #timeStamp) timeStamp - " - | preamble tokens | - preamble _ self getPreamble. - (preamble includesSubString: 'methodsFor:') ifFalse: [ ^'']. - tokens _ Scanner new scanTokens: preamble. - ^CompiledMethod stampFrom: tokens! ! -!SystemDictionary methodsFor: 'retrieving' stamp: 'jmv 4/2/2020 12:18:19' prior: 16921749! - allMethodsWithString: aString - "Answer a sorted Collection of all the methods that contain, in a string literal, aString as a substring. 2/1/96 sw. The search is case-sensitive, and does not dive into complex literals, confining itself to string constants. - 5/2/96 sw: fixed so that duplicate occurrences of aString in the same method don't result in duplicated entries in the browser" - | aStringSize list | - aStringSize _ aString size. - list _ Set new. - self allBehaviorsDo: [ :class | - class selectorsDo: [ :sel | - (class compiledMethodAt: sel) literalsDo: [ :aLiteral | - ((aLiteral isMemberOf: String) and: [ aLiteral size >= aStringSize ]) ifTrue: [ - (aLiteral includesSubString: aString) ifTrue: [ - list add: - (MethodReference new - setStandardClass: class - methodSymbol: sel) ]]]]]. - ^ list asArray sort! ! -!CodeWindow methodsFor: 'menu commands' stamp: 'jmv 4/2/2020 13:09:20' prior: 16813417! - browseVersions - "Create and schedule a Versions Browser, showing all versions of the - currently selected message. Answer the browser or nil." - | selector class | - selector _ model selectedMessageName. - (selector isNil or: [ MessageSet isPseudoSelector: selector ]) ifTrue: [ - ^ VersionsBrowserWindow - browseCommentOf: model selectedClass ]. - class _ model selectedClassOrMetaClass. - ^ VersionsBrowserWindow - browseVersionsOf: (class compiledMethodAt: selector) - class: model selectedClass - meta: class isMeta - category: (class organization categoryOfElement: selector) - selector: selector! ! - -ChangeList removeSelector: #field:from:ifAbsentOrNil:! - -!methodRemoval: ChangeList #field:from:ifAbsentOrNil: stamp: 'Install-4103-FixMethodPreambleAccess-JuanVuletich-2020Apr02-15h40m-jmv.001.cs.st 4/3/2020 11:07:12'! -field: aFieldName from: tokens ifAbsentOrNil: aBlock - - | fieldValue fieldIndex | - - fieldIndex _ tokens indexOf: aFieldName ifAbsent: [ ^aBlock value ]. - fieldValue _ tokens at: fieldIndex + 1 ifAbsent: [ ^aBlock value ]. - - ^ fieldValue ifNil: aBlock! - -ChangeList removeSelector: #overridenMethodReferenceFrom:! - -!methodRemoval: ChangeList #overridenMethodReferenceFrom: stamp: 'Install-4103-FixMethodPreambleAccess-JuanVuletich-2020Apr02-15h40m-jmv.001.cs.st 4/3/2020 11:07:12'! -overridenMethodReferenceFrom: tokens - - | overridenMethodReference tagIndex | - - tagIndex _ tokens indexOf: #overrides: ifAbsent: [ ^ nil ]. - overridenMethodReference _ tokens at: tagIndex + 1. - - ^ overridenMethodReference -! - -ChangeList removeSelector: #classCategoryFrom:! - -!methodRemoval: ChangeList #classCategoryFrom: stamp: 'Install-4103-FixMethodPreambleAccess-JuanVuletich-2020Apr02-15h40m-jmv.001.cs.st 4/3/2020 11:07:12'! -classCategoryFrom: tokens - - ^self field: #category: from: tokens ifAbsentOrNil: [ Categorizer default ]! - -ChangeList removeSelector: #priorMethodReferenceFrom:! - -!methodRemoval: ChangeList #priorMethodReferenceFrom: stamp: 'Install-4103-FixMethodPreambleAccess-JuanVuletich-2020Apr02-15h40m-jmv.001.cs.st 4/3/2020 11:07:12'! -priorMethodReferenceFrom: tokens - - | priorMethodReference tagIndex | - - tagIndex _ tokens indexOf: #prior: ifAbsent: [ ^ nil ]. - priorMethodReference _ tokens at: tagIndex + 1. - - ^ priorMethodReference -! - -ChangeList removeSelector: #stampFrom:! - -!methodRemoval: ChangeList #stampFrom: stamp: 'Install-4103-FixMethodPreambleAccess-JuanVuletich-2020Apr02-15h40m-jmv.001.cs.st 4/3/2020 11:07:12'! -stampFrom: tokens - - ^self field: #stamp: from: tokens ifAbsentOrNil: [ '' ] - -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4103-FixMethodPreambleAccess-JuanVuletich-2020Apr02-15h40m-jmv.001.cs.st----! - -----SNAPSHOT----(3 April 2020 11:07:17) Cuis5.0-4103-32.image priorSource: 5523870! - -----QUIT----(3 April 2020 11:07:25) Cuis5.0-4103-32.image priorSource: 5539371! - -----STARTUP---- (14 April 2020 17:28:28) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4103-32.image! - - -'From Cuis 5.0 [latest update: #4103] on 4 April 2020 at 1:04:53 pm'! - -Object subclass: #FeatureRequirement - instanceVariableNames: 'name minVersion minRevision maxVersion pathName codePackageFile ' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Package Support'! - -!classDefinition: #FeatureRequirement category: #'System-Package Support' stamp: 'Install-4104-FasterPackageLoad-JuanVuletich-2020Apr04-13h03m-jmv.001.cs.st 4/14/2020 17:28:32'! -Object subclass: #FeatureRequirement - instanceVariableNames: 'name minVersion minRevision maxVersion pathName codePackageFile' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Package Support'! -!FeatureRequirement methodsFor: 'accessing' stamp: 'jmv 4/4/2020 12:24:23'! - codePackageFile - codePackageFile isNil ifTrue: [ - codePackageFile _ CodePackageFile onFileEntry: pathName asFileEntry. - pathName _ nil ]. - ^codePackageFile! ! -!CodePackageFile methodsFor: 'services' stamp: 'jmv 4/4/2020 12:54:10'! - install - "Create, install and answer a (sub)instance of CodePackage - Replace all existing code in the possibly existing CodePackage, removing any code that is not included in us." - | localName newCodePackage pckClass currentCS | - - localName _ fullName asFileEntry name. - ChangeSet installing: packageName do: [ - "This change set will capture a possible class definition for a subclass of CodePackage. - If it only has that, then remove it after package install. - One example needing this is 'Color-Extras.pck.st'" - currentCS _ ChangeSet changeSetForBaseSystem. - currentCS isEmpty ifFalse: [ currentCS _ nil ]. - pckClass _ CodePackage. - classes do: [ :ee | - (ee hasDefinition and: [ee superclassName = 'CodePackage']) ifTrue: [ - ee fileInDefinitionAndMetaclass. - pckClass _ Smalltalk at: ee name ]]. - newCodePackage _ pckClass - named: packageName - createIfAbsent: true - registerIfNew: true. - newCodePackage - fullFileName: fullName; - sourceSystem: sourceSystem; - description: description; - featureSpec: featureSpec. - - fullName asFileEntry readStreamDo: [ :stream | stream fileInAnnouncing: 'Installing ', localName, '...' ]. - methodsToRemove do: [ :methodReference | methodReference actualClass removeSelector: methodReference selector ]. - classesToRemove do: [ :className | (Smalltalk at: className) removeFromSystem ]. - currentCS ifNotNil: [ ChangeSet removeChangeSet: currentCS ]]. - - newCodePackage hasUnsavedChanges: false; triggerEvent: #dirtyFlagChanged. - DataStream initialize. "Just in case" - "If we are installing an already installed package, zap the change set with possible changes done, - as they are irrelevant now: we have the package from disk" - ChangeSet removeChangeSet: (ChangeSet existingOrNewChangeSetForPackage: newCodePackage). - Preferences transcriptLogVerbose ifTrue: [ - Transcript newLine; show: 'Package ', packageName, ' successfully installed'; newLine. - Smalltalk cleanOutUndeclared. - Undeclared notEmpty ifTrue: [ - ('Undeclared: ', Undeclared printString) print ]]. - ^newCodePackage! ! -!CodePackageFile methodsFor: 'accessing' stamp: 'jmv 4/4/2020 12:07:26'! - packageName - ^packageName! ! -!CodePackageFile class methodsFor: 'instance creation' stamp: 'jmv 4/4/2020 11:55:38'! - onFileEntry: aFileEntry - | fullFileName instance pkName | - fullFileName _ aFileEntry pathName. - pkName _ CodePackageFile packageNameFrom: fullFileName. - aFileEntry readStreamDo: [ :stream | - instance _ self new. - instance buildFileStream: stream packageName: pkName fullName: fullFileName ]. - ^instance! ! -!ChangeList methodsFor: 'scanning' stamp: 'jmv 4/4/2020 11:38:19' prior: 50478939! - scanFile: aFile from: startPosition to: stopPosition - - file _ aFile. - changeList _ OrderedCollection new. - list _ OrderedCollection new. - listIndex _ 0. - file position: startPosition. - - 'Scanning ', aFile localName - displayProgressAt: Sensor mousePoint - from: startPosition to: stopPosition - during: [ :barBlock | self scanUpTo: stopPosition informing: barBlock ]. - - self clearSelections! ! -!ChangeList class methodsFor: 'public access' stamp: 'jmv 4/4/2020 12:29:13' prior: 50478996! - browsePackageContents: aFileEntry - "Opens a changeList on a fileStream" - | changeList packageFile | - packageFile _ CodePackageFile onFileEntry: aFileEntry. - aFileEntry readStreamDo: [ :stream | - changeList _ self new scanFile: stream from: 0 to: stream size ]. - "Add deletions of methods and classes that are in the CodePackage (i.e., active in the system) - but are no longer in the CodePackageFile being viewed." - packageFile methodsToRemove do: [ :methodReference | - changeList - addItem: (MethodDeletionChangeRecord new methodReference: methodReference) - text: 'method no longer in package: ', methodReference stringVersion ]. - packageFile classesToRemove do: [ :clsName | - changeList - addItem: (ClassDeletionChangeRecord new className: clsName) - text: 'class no longer in package: ', clsName ]. - changeList clearSelections. - ChangeListWindow open: changeList label: aFileEntry name! ! -!FeatureRequirement methodsFor: 'accessing' stamp: 'jmv 4/4/2020 12:22:56' prior: 16840754! - pathName: aPathNameString - - pathName _ aPathNameString. - codePackageFile _ nil! ! -!FeatureRequirement methodsFor: 'accessing' stamp: 'jmv 4/4/2020 11:58:01' prior: 16840759! - requirements - "Answer my requirements" - - ^self codePackageFile requires! ! -!FeatureRequirement methodsFor: 'requires' stamp: 'jmv 4/4/2020 12:25:19' prior: 50476029! - findPackageFileAsReqOf: mainFeatureOrNil - "Look in known places for packages providing required feature. - Answer wether search was successful." - | packageFileName entry | - pathName ifNotNil: [ - pathName asFileEntry exists ifTrue: [ ^ true ]]. - packageFileName _ self packageFileName. - (mainFeatureOrNil ifNil: [ self ]) placesToLookForPackagesDo: [ :directory | - entry _ directory // packageFileName. - entry exists ifTrue: [ - "Try this one. If success, keep it." - self pathName: entry pathName. - self checkRequirement ifTrue: [ ^true ]. - "Nope. Don't keep it." - self pathName: nil ]]. - ^ false! ! -!FeatureRequirement methodsFor: 'requires' stamp: 'jmv 4/4/2020 12:24:31' prior: 16840785! - install - "Preconditions have been satisfied. Install the required package." - - | existing | - existing _ CodePackage named: self codePackageFile packageName createIfAbsent: false registerIfNew: false. - (existing isNil - or: [ existing hasUnsavedChanges not - or: [ self confirm: 'If you install this package, there are unsaved changes that will be lost.', String newLineString, 'Continue?' ]]) ifTrue: [ - self codePackageFile install. - ]! ! -!FeatureRequirement methodsFor: 'testing' stamp: 'jmv 4/4/2020 11:59:07' prior: 50476049! - checkRequirement - "Answer if I am satisfied by package found at pathName" - - | featureSpec | - featureSpec _ self codePackageFile featureSpec. - ^ featureSpec notNil and: [featureSpec provides satisfies: self ]! ! - -CodePackageFile class removeSelector: #buildFileStream:packageName:fullName:! - -!methodRemoval: CodePackageFile class #buildFileStream:packageName:fullName: stamp: 'Install-4104-FasterPackageLoad-JuanVuletich-2020Apr04-13h03m-jmv.001.cs.st 4/14/2020 17:28:32'! -buildFileStream: aFileStream packageName: pkName fullName: fullFileName - | instance | - instance _ self new. - instance buildFileStream: aFileStream packageName: pkName fullName: fullFileName. - ^instance! - -CodePackageFile class removeSelector: #installFileStream:packageName:fullName:! - -!methodRemoval: CodePackageFile class #installFileStream:packageName:fullName: stamp: 'Install-4104-FasterPackageLoad-JuanVuletich-2020Apr04-13h03m-jmv.001.cs.st 4/14/2020 17:28:32'! -installFileStream: aFileStream packageName: pkName fullName: fullFileName - | instance | - instance _ self new. - instance installFileStream: aFileStream packageName: pkName fullName: fullFileName. - ^instance! - -CodePackageFile class removeSelector: #buildFileStream:! - -!methodRemoval: CodePackageFile class #buildFileStream: stamp: 'Install-4104-FasterPackageLoad-JuanVuletich-2020Apr04-13h03m-jmv.001.cs.st 4/14/2020 17:28:32'! -buildFileStream: aStream - - | fullFileName pkName | - fullFileName _ aStream name. - pkName _ CodePackageFile packageNameFrom: fullFileName. - ^self buildFileStream: aStream packageName: pkName fullName: fullFileName! - -CodePackageFile class removeSelector: #basicInstallPackageStream:! - -!methodRemoval: CodePackageFile class #basicInstallPackageStream: stamp: 'Install-4104-FasterPackageLoad-JuanVuletich-2020Apr04-13h03m-jmv.001.cs.st 4/14/2020 17:28:32'! -basicInstallPackageStream: aStream - - | fullName pkName existing | - fullName _ aStream name. - pkName _ CodePackageFile packageNameFrom: fullName. - existing _ CodePackage named: pkName createIfAbsent: false registerIfNew: false. - (existing isNil - or: [ existing hasUnsavedChanges not - or: [ self confirm: 'If you install this package, there are unsaved changes that will be lost.', String newLineString, 'Continue?' ]]) ifTrue: [ - CodePackageFile - installFileStream: aStream - packageName: pkName - fullName: fullName ]! - -CodePackageFile removeSelector: #install:! - -!methodRemoval: CodePackageFile #install: stamp: 'Install-4104-FasterPackageLoad-JuanVuletich-2020Apr04-13h03m-jmv.001.cs.st 4/14/2020 17:28:32'! -install: aFileStream - "Installs the package. Replace all existing code in the CodePackage, removing any code that is not included in us." - | localName newCodePackage pckClass currentCS | - - "Give reasonable warnings if there is stuff that can't be properly cleaned. Give the user the chance to abort." - Preferences transcriptLogVerbose ifTrue: [ - '=============' print. - classesToRemove notEmpty ifTrue: [ - ('classesToRemove: ', classesToRemove printString) print. - '=============' print ]. - methodsToRemove notEmpty ifTrue: [ - 'methodsToRemove: ' print. - methodsToRemove do: [ :methodReference | methodReference print ]. - '=============' print ]]. - - "Create, install and answer a (sub)instance of CodePackage" - localName _ fullName asFileEntry name. - ChangeSet installing: packageName do: [ - "This change set will capture a possible class definition for a subclass of CodePackage. - If it only has that, then remove it after package install. - One example needing this is 'Color-Extras.pck.st'" - currentCS _ ChangeSet changeSetForBaseSystem. - currentCS isEmpty ifFalse: [ currentCS _ nil ]. - pckClass _ CodePackage. - classes do: [ :ee | - (ee hasDefinition and: [ee superclassName = 'CodePackage']) ifTrue: [ - ee fileInDefinitionAndMetaclass. - pckClass _ Smalltalk at: ee name ]]. - newCodePackage _ pckClass - named: packageName - createIfAbsent: true - registerIfNew: true. - newCodePackage - fullFileName: fullName; - sourceSystem: sourceSystem; - description: description; - featureSpec: featureSpec. - aFileStream fileInAnnouncing: 'Installing ', localName, '...'. - methodsToRemove do: [ :methodReference | methodReference actualClass removeSelector: methodReference selector ]. - classesToRemove do: [ :className | (Smalltalk at: className) removeFromSystem ]. - currentCS ifNotNil: [ ChangeSet removeChangeSet: currentCS ]]. - newCodePackage hasUnsavedChanges: false; triggerEvent: #dirtyFlagChanged. - DataStream initialize. "Just in case" - "If we are installing an already installed package, zap the change set with possible changes done, - as they are irrelevant now: we have the package from disk" - ChangeSet removeChangeSet: (ChangeSet existingOrNewChangeSetForPackage: newCodePackage). - Preferences transcriptLogVerbose ifTrue: [ - Transcript newLine; show: 'Package ', packageName, ' successfully installed'; newLine. - Smalltalk cleanOutUndeclared. - Undeclared notEmpty ifTrue: [ - ('Undeclared: ', Undeclared printString) print ]]. - ^newCodePackage! - -CodePackageFile removeSelector: #installFileStream:packageName:fullName:! - -!methodRemoval: CodePackageFile #installFileStream:packageName:fullName: stamp: 'Install-4104-FasterPackageLoad-JuanVuletich-2020Apr04-13h03m-jmv.001.cs.st 4/14/2020 17:28:32'! -installFileStream: aFileStream packageName: pkName fullName: fullFileName - - self buildFileStream: aFileStream packageName: pkName fullName: fullFileName. - aFileStream reset. - self install: aFileStream! - -Object subclass: #FeatureRequirement - instanceVariableNames: 'name minVersion minRevision maxVersion pathName codePackageFile' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Package Support'! - -!classDefinition: #FeatureRequirement category: #'System-Package Support' stamp: 'Install-4104-FasterPackageLoad-JuanVuletich-2020Apr04-13h03m-jmv.001.cs.st 4/14/2020 17:28:32'! -Object subclass: #FeatureRequirement - instanceVariableNames: 'name minVersion minRevision maxVersion pathName codePackageFile' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Package Support'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4104-FasterPackageLoad-JuanVuletich-2020Apr04-13h03m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4106] on 4 April 2020 at 12:47:59 pm'! -!Dictionary methodsFor: 'removing' stamp: 'jmv 4/4/2020 12:47:43' prior: 50365745! - unreferencedKeys - | currentClass associations referencedAssociations | - currentClass := nil. - associations := self associations asIdentitySet. - referencedAssociations := IdentitySet new: associations size. - Smalltalk allSelect: [ :m | - m methodClass ~~ currentClass ifTrue: [ - currentClass := m methodClass ]. - m literalsDo: [ :l | - (l isVariableBinding and: [associations includes: l]) ifTrue: [ - referencedAssociations add: l]]. - false ]. - ^((associations reject: [:assoc | referencedAssociations includes: assoc]) collect: [:assoc| assoc key]) asSet! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4105-removeUnnededProgressBar-JuanVuletich-2020Apr04-12h47m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4105] on 4 April 2020 at 1:23:47 pm'! -!String methodsFor: 'displaying' stamp: 'jmv 7/17/2017 15:41:46' prior: 50501283! - 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 mousePoint - from: 0 to: 100 - during: [:barBlock | - 1 to: 100 do: [:x | - (Delay forMilliseconds: 10) wait. - barBlock value: x.]]. - -['Now here''s some Real Progress' - displayProgressAt: Sensor mousePoint - from: 0 to: 100 - during: [:barBlock | - 1 to: 100 do: [:x | barBlock value: x. - (Delay forMilliseconds: 100) wait]].] fork - -['Now here''s some Real Progress' - displayProgressAt: Sensor mousePoint - from: 0 to: 10 - during: [:barBlock | - 1 to: 30 do: [:x | barBlock value: x \\ 11. - (Delay forMilliseconds: 100) wait]]] fork - -'Now here''s some Real Progress' - displayProgressAt: Sensor mousePoint - from: 0 to: 10 - during: [:barBlock | - 1 to: 30 do: [:x | barBlock value: nil. - (Delay forMilliseconds: 200) 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. - -The use of ProgressInitiationException allows for avoiding actual -progress display, by catching the exception. -" - ^ProgressInitiationException - display: self - at: aPoint - from: minVal - to: maxVal - during: workBlock! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4106-removeProgressBarLoggingToTranscript-JuanVuletich-2020Apr04-13h21m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4106] on 6 April 2020 at 12:00:48 am'! - -"Change Set: 4107-CuisCore-AuthorName-2020Apr05-23h12m -Date: 5 April 2020 -Author: Nahuel Garbezza - -Allow extract method refactoring to extract declaration of temp variables if they are not used outside of the selection interval. Also refactored parse nodes to parameterize detection logic outside of the applier"! - -Object subclass: #ExtractMethodParametersDetector - instanceVariableNames: 'intervalToExtract methodNodeToRefactor' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractMethodParametersDetector category: #'Tools-Refactoring' stamp: 'Install-4107-CuisCore-NahuelGarbezza-2020Apr05-23h12m-RNG.001.cs.st 4/14/2020 17:28:32'! -Object subclass: #ExtractMethodParametersDetector - instanceVariableNames: 'intervalToExtract methodNodeToRefactor' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!ExtractMethodParametersDetector commentStamp: '' prior: 0! - I am responsible for returning the parse nodes we need to parameterize before performing an extract method refactoring.! -!CodeNode methodsFor: 'accessing' stamp: 'RNG 4/5/2020 19:45:20'! - temporariesDeclaration - - self subclassResponsibility! ! -!CodeNode methodsFor: 'accessing' stamp: 'RNG 4/5/2020 19:45:28'! - temporariesDeclaration: aTemporariesDeclarationNode - - self subclassResponsibility! ! -!CodeNode methodsFor: 'testing' stamp: 'RNG 4/5/2020 19:45:40'! - hasTemporaryVariables - - ^ self temporariesDeclaration declaresAnyVariable! ! -!MethodNode methodsFor: 'accessing' stamp: 'RNG 4/5/2020 19:45:58'! - numberOfStatements - - ^ block statements size! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 4/5/2020 19:46:24'! - findSourceRangeOfNextStatementIn: listOfAncestors - - ^ listOfAncestors - detect: [ :assoc | assoc key isBlockNode or: [ assoc key class = LeafNode ] ] - ifFound: [ :assoc | - (listOfAncestors at: (listOfAncestors indexOf: assoc) - 1) value ] - ifNone: [ listOfAncestors last value ]! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 4/5/2020 19:46:34'! - isNotInsideATempDeclaration - - methodNode completeSourceRangesDo: [ :parseNode :sourceRanges | - (parseNode isTemporariesDeclaration - and: [ sourceRanges anySatisfy: [ :sourceRange | - sourceRange first < intervalToExtract first and: [ sourceRange last > intervalToExtract last ] ] ]) - ifTrue: [ ^ false ] ]. - ^ true! ! -!ExtractMethodParametersDetector methodsFor: 'evaluating' stamp: 'RNG 4/5/2020 22:44:44' overrides: 16881508! - value - - | parseNodesFound | - parseNodesFound := OrderedCollection new. - methodNodeToRefactor completeSourceRangesDo: [ :parseNode :sourceRanges | - (self shouldBeParameterized: parseNode appearingIn: sourceRanges) - ifTrue: [ parseNodesFound add: parseNode ] - ]. - ^ parseNodesFound! ! -!ExtractMethodParametersDetector methodsFor: 'initialization' stamp: 'RNG 4/5/2020 22:48:06'! - initializeFor: aMethodNodeToRefactor at: anIntervalToExtract - - methodNodeToRefactor := aMethodNodeToRefactor. - intervalToExtract := anIntervalToExtract! ! -!ExtractMethodParametersDetector methodsFor: 'private' stamp: 'RNG 4/5/2020 22:45:20'! - blockNodesEnclosingIntervalToExtract - - | nodes | - nodes := Set new. - methodNodeToRefactor completeSourceRangesDo: [ :parseNode :sourceRanges | - (parseNode isBlockNode and: [ self intervalToExtractIsCoveredByAnyOf: sourceRanges ]) - ifTrue: [ nodes add: parseNode ] ]. - ^ nodes! ! -!ExtractMethodParametersDetector methodsFor: 'private' stamp: 'RNG 4/5/2020 22:35:53'! - definedInOuterScope: parseNode - - ^ self nodesThatAddVariablesToScope - anySatisfy: [ :node | node hasLocallyArgumentOrTemporaryNamed: parseNode name ]! ! -!ExtractMethodParametersDetector methodsFor: 'private' stamp: 'RNG 4/5/2020 22:46:47'! - intervalToExtractIncludesAnyOf: sourceRanges - - ^ sourceRanges anySatisfy: [ :sourceRange | - intervalToExtract includes: sourceRange first ]! ! -!ExtractMethodParametersDetector methodsFor: 'private' stamp: 'RNG 4/5/2020 22:38:04'! - intervalToExtractIsCoveredByAnyOf: sourceRanges - - ^ sourceRanges anySatisfy: [ :sourceRange | - sourceRange first < intervalToExtract first - and: [ sourceRange last > intervalToExtract last ] ]! ! -!ExtractMethodParametersDetector methodsFor: 'private' stamp: 'RNG 4/5/2020 22:47:03'! - isNotExtractedAlongWithItsDeclaration: parseNode - - ^ (methodNodeToRefactor - anyParseNodeWithin: intervalToExtract - satisfy: [ :parseNodeInInterval | - parseNodeInInterval isTemporariesDeclaration - and: [ parseNode isVariableNode ] - and: [ parseNodeInInterval declaresVariable: parseNode ] ]) not! ! -!ExtractMethodParametersDetector methodsFor: 'private' stamp: 'RNG 4/5/2020 22:47:08'! - nodesThatAddVariablesToScope - - ^ (Set with: methodNodeToRefactor) - addAll: self blockNodesEnclosingIntervalToExtract; - yourself! ! -!ExtractMethodParametersDetector methodsFor: 'private' stamp: 'RNG 4/5/2020 22:46:30'! - shouldBeParameterized: parseNode appearingIn: sourceRanges - - ^ (self intervalToExtractIncludesAnyOf: sourceRanges) - and: [ parseNode isTempOrArg ] - and: [ self definedInOuterScope: parseNode ] - and: [ self isNotExtractedAlongWithItsDeclaration: parseNode ]! ! -!ExtractMethodParametersDetector class methodsFor: 'instance creation' stamp: 'RNG 4/5/2020 22:47:48'! - for: aMethodNodeToRefactor at: anIntervalToExtract - - ^ self new initializeFor: aMethodNodeToRefactor at: anIntervalToExtract! ! -!ExtractMethodParametersDetector class methodsFor: 'evaluating' stamp: 'RNG 4/5/2020 22:47:55'! -valueFor: aMethodNodeToRefactor at: anIntervalToExtract - - ^ (self for: aMethodNodeToRefactor at: anIntervalToExtract) value! ! -!ExtractMethod class methodsFor: 'validations' stamp: 'RNG 4/5/2020 23:42:05'! - assert: newMessage hasValidParametersForExtracting: anIntervalToExtract from: aMethodNodeToRefactor - - | parseNodesToParameterize | - parseNodesToParameterize := ExtractMethodParametersDetector - valueFor: aMethodNodeToRefactor - at: anIntervalToExtract. - newMessage arguments size = parseNodesToParameterize size - ifFalse: [ self signalExtractMethodWithWrongNumberOfArgumentsError ]! ! -!ExtractMethod class methodsFor: 'error messages' stamp: 'RNG 4/5/2020 22:53:43'! - wrongNumberOrArgumentsGivenErrorMessage - - ^ 'The number of arguments in the given selector is not correct'! ! -!ExtractMethod class methodsFor: 'exceptions' stamp: 'RNG 4/5/2020 23:02:46'! - signalExtractMethodWithWrongNumberOfArgumentsError - - self refactoringError: self wrongNumberOrArgumentsGivenErrorMessage! ! -!ExtractMethodApplier methodsFor: 'refactoring - creation' stamp: 'RNG 4/5/2020 23:40:59'! - refactoringClass - - ^ ExtractMethod! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 4/5/2020 19:46:51' prior: 50503051! - containsValidNodes - - ^ self isNotLeftSideOfAssignment - and: [ self thereAreNoLocalVariableAssignmentsWithoutDeclaration ] - and: [ self thereAreNoReturnExpressions ] - and: [ self isNotATempDeclarationWithUsagesOutOfIntervalToExtract ] - and: [ self isNotInsideATempDeclaration ]! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 4/5/2020 19:47:16' prior: 50489383! - intervalMatchesBeginningOfStatement - - ^ (self findSourceRangeOfNextStatementIn: initialNodeAncestors) value first = intervalToExtract first! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 4/5/2020 19:47:25' prior: 50489390! - intervalMatchesEndOfStatement - - ^ (self findSourceRangeOfNextStatementIn: finalNodeAncestors) last = intervalToExtract last! ! -!ExtractMethod methodsFor: 'private - source code' stamp: 'RNG 4/5/2020 19:47:58' prior: 50488796! - returnCharacterIfNeeded - - | extractedMethodNode | - extractedMethodNode _ Parser parse: extractedSourceCode class: self sourceClass noPattern: true. - ^ (extractedMethodNode numberOfStatements > 1 or: [ extractedMethodNode hasTemporaryVariables ]) - ifTrue: [ '' ] ifFalse: [ '^ ' ]! ! -!ExtractMethod class methodsFor: 'instance creation' stamp: 'RNG 4/5/2020 23:42:05' prior: 50492106! - fromInterval: anIntervalToExtract of: aMethodToExtractCodeFrom to: newMessage categorizedAs: aCategory - - | trimmedIntervalToExtract | - trimmedIntervalToExtract := ExtractMethodIntervalTrimmer - trim: anIntervalToExtract locatedIn: aMethodToExtractCodeFrom sourceCode. - self - assert: newMessage selector canBeDefinedIn: aMethodToExtractCodeFrom methodClass; - assert: trimmedIntervalToExtract isValidIntervalOn: aMethodToExtractCodeFrom; - assert: newMessage hasValidParametersForExtracting: anIntervalToExtract from: aMethodToExtractCodeFrom methodNode. - - ^ self new - initializeFrom: trimmedIntervalToExtract - of: aMethodToExtractCodeFrom - to: newMessage - in: aCategory! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 4/5/2020 22:48:26' prior: 50489032! - parseNodesToParameterize - - ^ ExtractMethodParametersDetector - valueFor: methodToExtractCodeFrom methodNode - at: intervalToExtract! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 4/5/2020 23:40:39' prior: 50489101! - validateRequiredParameters: parseNodesToParameterize haveACorrespondingKeywordIn: newSelectorKeywords - - newSelectorKeywords size = parseNodesToParameterize size - ifFalse: [ self refactoringClass signalExtractMethodWithWrongNumberOfArgumentsError ]! ! -!ExtractMethodApplier methodsFor: 'refactoring - creation' stamp: 'RNG 4/5/2020 23:41:07' prior: 50489158 overrides: 50441327! - createRefactoring - - ^ self refactoringClass - fromInterval: intervalToExtract - of: methodToExtractCodeFrom - to: self buildNewMessage - categorizedAs: methodToExtractCodeFrom category! ! - -ExtractMethodApplier removeSelector: #shouldBeParameterized:appearingIn:! - -!methodRemoval: ExtractMethodApplier #shouldBeParameterized:appearingIn: stamp: 'Install-4107-CuisCore-NahuelGarbezza-2020Apr05-23h12m-RNG.001.cs.st 4/14/2020 17:28:32'! -shouldBeParameterized: parseNode appearingIn: sourceRanges - - ^ (sourceRanges anySatisfy: [ :sourceRange | intervalToExtract includes: sourceRange first ]) - and: [ parseNode isTempOrArg ] - and: [ self definedInOuterScope: parseNode ]! - -ExtractMethodApplier removeSelector: #intervalToExtractIsCoveredByAnyOf:! - -!methodRemoval: ExtractMethodApplier #intervalToExtractIsCoveredByAnyOf: stamp: 'Install-4107-CuisCore-NahuelGarbezza-2020Apr05-23h12m-RNG.001.cs.st 4/14/2020 17:28:32'! -intervalToExtractIsCoveredByAnyOf: sourceRanges - - ^ sourceRanges anySatisfy: [ :sourceRange | - sourceRange first < intervalToExtract first - and: [ sourceRange last > intervalToExtract last ] ]! - -ExtractMethodApplier removeSelector: #nodesThatAddVariablesToScope! - -!methodRemoval: ExtractMethodApplier #nodesThatAddVariablesToScope stamp: 'Install-4107-CuisCore-NahuelGarbezza-2020Apr05-23h12m-RNG.001.cs.st 4/14/2020 17:28:32'! -nodesThatAddVariablesToScope - - ^ (Set with: methodToExtractCodeFrom methodNode) - addAll: self blockNodesEnclosingIntervalToExtract; - yourself! - -ExtractMethodApplier removeSelector: #signalExtractMethodWithWrongNumberOfArgumentsError! - -!methodRemoval: ExtractMethodApplier #signalExtractMethodWithWrongNumberOfArgumentsError stamp: 'Install-4107-CuisCore-NahuelGarbezza-2020Apr05-23h12m-RNG.001.cs.st 4/14/2020 17:28:32'! -signalExtractMethodWithWrongNumberOfArgumentsError - - ^ ExtractMethod refactoringError: 'The number of arguments in the entered selector is not correct'! - -ExtractMethodApplier removeSelector: #blockNodesEnclosingIntervalToExtract! - -!methodRemoval: ExtractMethodApplier #blockNodesEnclosingIntervalToExtract stamp: 'Install-4107-CuisCore-NahuelGarbezza-2020Apr05-23h12m-RNG.001.cs.st 4/14/2020 17:28:32'! -blockNodesEnclosingIntervalToExtract - - | nodes | - nodes _ Set new. - methodToExtractCodeFrom methodNode completeSourceRangesDo: [ :parseNode :sourceRanges | - (parseNode isBlockNode and: [ self intervalToExtractIsCoveredByAnyOf: sourceRanges ]) - ifTrue: [ nodes add: parseNode ] ]. - ^ nodes! - -ExtractMethodApplier removeSelector: #definedInOuterScope:! - -!methodRemoval: ExtractMethodApplier #definedInOuterScope: stamp: 'Install-4107-CuisCore-NahuelGarbezza-2020Apr05-23h12m-RNG.001.cs.st 4/14/2020 17:28:32'! -definedInOuterScope: parseNode - - ^ self nodesThatAddVariablesToScope - anySatisfy: [ :node | node hasLocallyArgumentOrTemporaryNamed: parseNode name ]! - -ExtractMethodExpressionValidation removeSelector: #isDeclaredWithinIntervalToExtract:! - -!methodRemoval: ExtractMethodExpressionValidation #isDeclaredWithinIntervalToExtract: stamp: 'Install-4107-CuisCore-NahuelGarbezza-2020Apr05-23h12m-RNG.001.cs.st 4/14/2020 17:28:32'! -isDeclaredWithinIntervalToExtract: aVariableNode - - ^ methodNode - allParseNodesWithin: intervalToExtract - satisfy: [ :parseNode | parseNode isBlockNode - and: [ parseNode temporaries includes: aVariableNode ] ]! - -ExtractMethodExpressionValidation removeSelector: #isNotATempDeclaration! - -!methodRemoval: ExtractMethodExpressionValidation #isNotATempDeclaration stamp: 'Install-4107-CuisCore-NahuelGarbezza-2020Apr05-23h12m-RNG.001.cs.st 4/14/2020 17:28:32'! -isNotATempDeclaration - - | startOfFirstOccurrence sourceRanges tempKey allTempSourceRanges | - initialNode key isTemp ifFalse: [ ^ true ]. - sourceRanges _ methodNode rawSourceRanges. - tempKey _ sourceRanges keys detect: [ :parseNode | parseNode isTemp and: [ parseNode equivalentTo: initialNode key ] ]. - allTempSourceRanges _ sourceRanges at: tempKey. - startOfFirstOccurrence _ allTempSourceRanges isInterval - ifTrue: [ allTempSourceRanges first ] ifFalse: [ allTempSourceRanges first first ]. - ^ startOfFirstOccurrence ~= intervalToExtract first! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4107-CuisCore-NahuelGarbezza-2020Apr05-23h12m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4103] on 6 April 2020 at 12:05:43 am'! - -"Change Set: 4104-CuisCore-AuthorName-2020Apr06-00h03m -Date: 6 April 2020 -Author: Nahuel Garbezza - -Change Symbol>>isValidSelector implementation to support binary messages"! -!Symbol methodsFor: 'testing' stamp: 'RNG 3/29/2020 19:56:14'! - isValidBinarySelector - - ^ self isInfix and: [ self allSatisfy: [ :character | character isValidInBinarySelectors ] ]! ! -!Symbol methodsFor: 'testing' stamp: 'RNG 3/29/2020 19:56:38'! - isValidKeywordSelector - - ^ self isKeyword and: [ self keywords allSatisfy: [ :keywordString | keywordString allButLast asSymbol isValidSelector ] ]! ! -!Symbol methodsFor: 'testing' stamp: 'RNG 3/29/2020 19:56:03'! - isValidUnarySelector - - ^ self isUnary and: [ self allSatisfy: [ :character | character isValidInIdentifiers ] ]! ! -!Symbol methodsFor: 'testing' stamp: 'RNG 3/29/2020 19:56:45' prior: 50488468! - isValidSelector - - ^ self isValidUnarySelector - or: [ self isValidBinarySelector ] - or: [ self isValidKeywordSelector ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4108-CuisCore-NahuelGarbezza-2020Apr06-00h03m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4106] on 9 April 2020 at 4:16:20 pm'! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'HAW 4/9/2020 16:11:38'! - addReferencesOf: anInstVarName at: anInstVarIndex to: references - - | reference | - - self methodsDo: [ :aMethod | - (aMethod accessorDescriptionOf: anInstVarName at: anInstVarIndex) ifNotEmpty: [ :description | - reference := MethodReference method: aMethod. - reference prefixStringVersionWith: '[',description, '] - '. - references add: reference ]]. - ! ! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'HAW 4/9/2020 16:12:05'! - allAccessesTo: instVarName - - | references instVarIndex definingClass | - - definingClass _ self whichClassDefinesInstanceVariable: instVarName ifNone: [ ^#() ]. - instVarIndex _ self indexOfInstanceVariable: instVarName. - references _ SortedCollection sortBlock: [ :left :right | left stringVersion <= right stringVersion ]. - - definingClass withAllSubclassesDo: [ :class | class addReferencesOf: instVarName at: instVarIndex to: references ]. - - ^ references ! ! -!InstructionStream methodsFor: 'as yet unclassified' stamp: 'HAW 4/9/2020 15:36:10'! - movePcForward - - pc := self followingPc. -! ! -!CompiledMethod methodsFor: 'accessing' stamp: 'HAW 4/7/2020 15:48:05'! - accessorDescriptionOf: anInstVarName at: anInstVarIndex - - | isReader isWriter | - - (self isGetterOf: anInstVarName at: anInstVarIndex) ifTrue: [ ^ 'getter' ]. - (self isSetterOf: anInstVarName at: anInstVarIndex) ifTrue: [ ^ 'setter' ]. - - isReader := self readsField: anInstVarIndex. - isWriter := self writesField: anInstVarIndex. - - (isReader and: [ isWriter ]) ifTrue: [ ^ 'write/read' ]. - isReader ifTrue: [ ^ 'read' ]. - isWriter ifTrue: [ ^ 'write' ]. - - ^''! ! -!CompiledMethod methodsFor: 'testing' stamp: 'HAW 4/5/2020 23:27:48'! - isGetterOf: anInstVarName at: anInstVarIndex - - ^ self selector = anInstVarName - and: [ self isReturnField - and: [ self returnField + 1 = anInstVarIndex ]]. -! ! -!CompiledMethod methodsFor: 'testing' stamp: 'HAW 4/9/2020 15:36:10'! - isSetterOf: anInstVarName at: anInstVarIndex - - | varIndexCode scanner | - - self isQuick ifTrue: [ ^false ]. - self selector = (anInstVarName, ':') ifFalse: [ ^false ]. - - "I could have use the AST of the method, but parsing the source code could generate errors - that it is why I decided to check the bytecodes - Hernan" - varIndexCode := anInstVarIndex - 1. - scanner := InstructionStream on: self. - scanner nextByte = 16r10 ifFalse: [ ^false ]. - scanner movePcForward. - (self writesFieldCode: varIndexCode with: scanner nextByte using: scanner) ifFalse: [ ^false ]. - scanner movePcForward. - ^scanner nextByte = 16r78 - - ! ! -!CompiledMethod methodsFor: 'scanning' stamp: 'HAW 4/5/2020 23:00:20'! - writesFieldCode: varIndexCode with: byteCode using: scanner - - ^byteCode >= 96 - and: [byteCode <= 103 - ifTrue: [byteCode - 96 = varIndexCode] - ifFalse: - [(byteCode = 129 or: [byteCode = 130]) - ifTrue: [scanner followingByte = varIndexCode and: [varIndexCode <= 63]] - ifFalse: - [byteCode = 132 - and: [(scanner followingByte between: 160 and: 223) - and: [scanner thirdByte = varIndexCode]]]]] -! ! -!MethodReference methodsFor: 'setting' stamp: 'HAW 4/5/2020 22:31:48'! - prefixStringVersionWith: aString - - stringVersion := aString, stringVersion ! ! -!InstructionStream methodsFor: 'scanning' stamp: 'HAW 4/7/2020 15:58:47' prior: 16858255! - scanFor: scanBlock - "Check all bytecode instructions with scanBlock, answer true if scanBlock answers true. - This can be used to, e.g., check whether a method contains 'push closure' bytecodes like this: - aMethod scanFor: [ :b | b = 143 ]" - - | method encoderClass end byteCode | - - method := self method. - end := method endPC. - encoderClass := method encoderClass. - - [pc <= end] whileTrue: [ - byteCode := method at: pc. - (scanBlock value: byteCode) ifTrue: [^true]. - pc := pc + (encoderClass bytecodeSize: byteCode)]. - - ^false! ! -!CompiledMethod methodsFor: 'testing' stamp: 'HAW 4/5/2020 23:29:55' prior: 50491770! - isValid - - "To be polimorphic with MethodReference, important for refactorings - Hernan" - ^true! ! -!CompiledMethod methodsFor: 'scanning' stamp: 'HAW 4/7/2020 15:56:58' prior: 16820348! - writesField: varIndex - "Answer whether the receiver stores into the instance variable indexed - by the argument." - "eem 5/24/2008 Rewritten to no longer assume the compler uses the - most compact encoding available (for EncoderForLongFormV3 support)." - - | varIndexCode scanner | - - self isQuick ifTrue: [^false]. - - varIndexCode := varIndex - 1. - ^(scanner := InstructionStream on: self) scanFor: [:byteCode| - self writesFieldCode: varIndexCode with: byteCode using: scanner ] -! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'HAW 4/9/2020 16:14:03' prior: 16923827! - browseAllAccessesTo: instVarName from: aClass - "Create and schedule a Message Set browser for all the receiver's methods - or any methods of a subclass/superclass that refer to the instance variable name." - - "self new browseAllAccessesTo: 'contents' from: Collection." - - ^ self - browseMessageList: (aClass allAccessesTo: instVarName) - name: 'Accesses to ' , instVarName - autoSelect: instVarName! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4109-ShowAccessInInstVarAccesorBrowser-HernanWilkinson-2020Apr05-20h06m-HAW.003.cs.st----! - -'From Cuis 5.0 [latest update: #4106] on 6 April 2020 at 9:36:16 am'! - -"Change Set: 4110-AddIdIvarToMorph-JuanVuletich-2020Apr06-09h34m -Date: 6 April 2020 -Author: Juan Vuletich - -Adding an instance variable to Morph is tricky. Hence this preamble." -| ui b cs | -Utilities authorInitialsPerSe ifNil: [ Utilities setAuthor ]. -(nil confirm: 'In order to add a new instance variable to Morph, -we need to restart the User Interface process. -You''ll need to re-start the image update to install the next updates.') ifFalse: [ self halt ]. -[ - ui _ UISupervisor ui. - UISupervisor stopUIProcess. - b _ ClassBuilder isSilent. - ClassBuilder beSilent: true. - ClassBuilder new - superclass: Object - subclass: #Morph - instanceVariableNames: 'owner submorphs location layoutNeeded layoutSpec properties id' - classVariableNames: 'LastMorphId' - poolDictionaries: '' - category: 'Morphic-Kernel'. - ClassBuilder beSilent: b. - UISupervisor spawnNewMorphicProcessFor: ui. - ChangeSet installing: '4110-AddIdIvarToMorph-JuanVuletich-2020Apr06-09h34m-jmv.003.cs.st' do: []. - cs _ ChangeSet changeSetForBaseSystem. - (cs name beginsWith: '4110') ifTrue: [ - ChangeSet removeChangeSet: cs ]. - 'Done adding ivar ''id'' to Morph.' print. - 'Please restart [Install New Updates].' print. -] forkAt: 41! - -'From Cuis 5.0 [latest update: #4106] on 6 April 2020 at 10:55:58 am'! - -Object subclass: #Morph - instanceVariableNames: 'owner submorphs location layoutNeeded layoutSpec properties id ' - classVariableNames: 'LastMorphId ' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -!classDefinition: #Morph category: #'Morphic-Kernel' stamp: 'Install-4111-AddIvarIdToMorph-p2-JuanVuletich-2020Apr06-10h53m-jmv.001.cs.st 4/14/2020 17:28:41'! -Object subclass: #Morph - instanceVariableNames: 'owner submorphs location layoutNeeded layoutSpec properties id' - classVariableNames: 'LastMorphId' - poolDictionaries: '' - category: 'Morphic-Kernel'! -!Morph methodsFor: 'accessing' stamp: 'jmv 4/6/2020 10:48:47'! - morphId - "Non zero. Zero id means no Morph." - id isNil ifTrue: [ - LastMorphId isNil ifTrue: [ LastMorphId _ 0 ]. - LastMorphId _ LastMorphId + 1. - id _ LastMorphId ]. - ^id! ! -!Morph class methodsFor: 'initialize-release' stamp: 'jmv 4/6/2020 10:48:10' overrides: 50417628! - releaseClassCachedState - - LastMorphId _ nil. - self allSubInstancesDo: [ :each | - each releaseCachedState ]! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 4/4/2020 19:32:35'! - clippingMorph: aMorph! ! -!Morph methodsFor: 'caching' stamp: 'jmv 4/6/2020 10:45:56' prior: 16874130! - releaseCachedState - "Release any state that can be recomputed on demand, such as the pixel values for a color gradient or the editor state for a TextMorph. This method may be called to save space when a morph becomes inaccessible. Implementations of this method should do 'super releaseCachedState'." - id _ nil.! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 4/4/2020 19:32:57' prior: 16877482! - fullDraw: aMorph - "Draw the full Morphic structure on us" - - "We are already set with a proper transformation from aMorph owner's coordinates to those of our target form." - - | oldClipRect | - self flag: #jmvVer3. - aMorph visible ifFalse: [^ self]. - self into: aMorph. - - currentMorph layoutSubmorphsIfNeeded. - - currentMorph isKnownFailing ifTrue: [ - self drawCurrentAsError. - self outOfMorph. - ^ self]. - - (currentMorph isOwnedByHand and: [ Preferences cheapWindowReframe ]) ifTrue: [ - self drawCurrentAsOutline. - self outOfMorph. - ^ self]. - - "Draw current Morph" - self isCurrentMorphVisible ifTrue: [ - currentMorph drawOn: self ]. - - "Display submorphs back to front" - "coordinate system stack already set up for aMorph - ('ivars transformations' and 'currentTransformation')" - currentMorph hasSubmorphs ifTrue: [ - currentMorph clippedSubmorph ifNotNil: [ :clipped | - self clippingMorph: currentMorph. - oldClipRect _ self clipRect. - self setClipRect: (oldClipRect intersect: self clippingRectForCurrentMorph). - self fullDraw: clipped. - self setClipRect: oldClipRect. - self clippingMorph: nil ]. - currentMorph unclippedSubmorphsReverseDo: [ :m | - self fullDraw: m ]. - ]. - self outOfMorph! ! - -MorphicCanvas removeSelector: #currentOwnerIfClips:! - -!methodRemoval: MorphicCanvas #currentOwnerIfClips: stamp: 'Install-4111-AddIvarIdToMorph-p2-JuanVuletich-2020Apr06-10h53m-jmv.001.cs.st 4/14/2020 17:28:41'! -currentOwnerIfClips: currentMorphOwnerOrNil! - -PasteUpMorph class removeSelector: #releaseClassCachedState! - -!methodRemoval: PasteUpMorph class #releaseClassCachedState stamp: 'Install-4111-AddIvarIdToMorph-p2-JuanVuletich-2020Apr06-10h53m-jmv.001.cs.st 4/14/2020 17:28:41'! -releaseClassCachedState - - "Should use some other way to find relevant instances" - self flag: #jmvVer2. - self allInstancesDo: [ :each | - each releaseCachedState ]! - -Object subclass: #Morph - instanceVariableNames: 'owner submorphs location layoutNeeded layoutSpec properties id' - classVariableNames: 'LastMorphId' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -!classDefinition: #Morph category: #'Morphic-Kernel' stamp: 'Install-4111-AddIvarIdToMorph-p2-JuanVuletich-2020Apr06-10h53m-jmv.001.cs.st 4/14/2020 17:28:41'! -Object subclass: #Morph - instanceVariableNames: 'owner submorphs location layoutNeeded layoutSpec properties id' - classVariableNames: 'LastMorphId' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4111-AddIvarIdToMorph-p2-JuanVuletich-2020Apr06-10h53m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4106] on 5 April 2020 at 9:27:25 pm'! -!String methodsFor: 'displaying' stamp: 'jmv 4/5/2020 21:19:20' prior: 50386209! - 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` - " - 'Display' displayOn: Display at: 10@10. Display forceToScreen. - "! ! -!MenuItemMorph methodsFor: 'private' stamp: 'jmv 4/5/2020 21:18:11' prior: 50388333! - offImage - "Return the form to be used for indicating an '' marker" - | form | - form _ Form extent: (self fontToUse ascent-2) asPoint depth: 32. - form getCanvas - frameAndFillRectangle: form boundingBox fillColor: `(Color gray: 0.9)` - borderWidth: 1 borderColor: `Color black`. - ^form! ! -!MenuItemMorph methodsFor: 'private' stamp: 'jmv 4/5/2020 21:18:07' prior: 50388345! - onImage - "Return the form to be used for indicating an '' marker" - | form | - form _ Form extent: (self fontToUse ascent-2) asPoint depth: 32. - form getCanvas - frameAndFillRectangle: form boundingBox fillColor: `Color gray: 0.8` - borderWidth: 1 borderColor: `Color black`; - fillRectangle: (form boundingBox insetBy: 2) color: `Color black`. - ^form! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4112-UseOnly32BitCanvas-JuanVuletich-2020Apr05-21h18m-jmv.001.cs.st----! - -----SNAPSHOT----(14 April 2020 17:28:46) Cuis5.0-4112-32.image priorSource: 5539456! - -----QUIT----(14 April 2020 17:28:57) Cuis5.0-4112-32.image priorSource: 5583655! - -----STARTUP---- (26 May 2020 17:08:28) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4112-32.image! - - -'From Cuis 5.0 [latest update: #4112] on 14 April 2020 at 6:03:54 pm'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 4/14/2020 17:53:47'! - clippingByCurrentMorphDo: aBlock - | prevClipRect | - - prevClipRect _ self clipRect. - self setClipRect: (prevClipRect intersect: self clippingRectForCurrentMorph). - self clippingMorph: currentMorph. - aBlock ensure: [ - self clippingMorph: nil. - self setClipRect: prevClipRect. ]! ! -!TextModelMorph methodsFor: 'drawing' stamp: 'jmv 3/6/2020 20:03:32' prior: 50461179 overrides: 16790395! - drawOn: aCanvas - "Include a thin red inset border for unaccepted edits, or, if the unaccepted edits are known to conflict with a change made somewhere else to the same method (typically), put a thick red frame" - | bw bc | - self flag: #todo. - "Integrate this method with the Theme system. --cbr" - super drawOn: aCanvas. - bw _ Preferences focusIndicatorWidth. - bc _ nil. - self wantsFrameAdornments ifTrue: [ - model refusesToAccept - ifTrue: [ "Put up feedback showing that code cannot be submitted in this state" - bc _ Color tan ] - ifFalse: [ - self textMorph hasEditingConflicts - ifTrue: [ - bw _ 3. - bc _ Color red ] - ifFalse: [ - self textMorph hasUnacceptedEdits ifTrue: [ bc _ Color red ]]]]. - (drawKeyboardFocusIndicator and: [ self textMorph hasKeyboardFocus ]) - ifTrue: [ bc ifNil: [ bc _ Theme current focusIndicator ]] - ifFalse: [ - bc ifNotNil: [ - bc _ bc - alphaMixed: 0.4 - with: Color white ]]. - bc ifNotNil: [ - aCanvas - frameRectangle: self focusIndicatorRectangle - borderWidth: bw - color: bc ]. - model actualContents isEmpty ifTrue: [ - self - valueOfProperty: #emptyTextDisplayMessage - ifPresentDo: [ :msg | - aCanvas clippingByCurrentMorphDo: [ - aCanvas - drawString: msg - at: self viewableAreaTopLeft - font: nil - color: Theme current textEmptyDisplayMessage ]]].! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 4/14/2020 18:01:25' prior: 50463619! - clippingRectForCurrentMorph - "This rectangle is used for clipping submorphs in BitBltCanvas. - In VectorCanvas we support clipping by any shape, not just rectangles. Then, this rectangle is used as an optimization of the area to be redrawn." - - self subclassResponsibility! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 4/14/2020 17:55:05' prior: 50506010! - fullDraw: aMorph - "Draw the full Morphic structure on us" - - "We are already set with a proper transformation from aMorph owner's coordinates to those of our target form." - - - self flag: #jmvVer3. - aMorph visible ifFalse: [^ self]. - self into: aMorph. - - currentMorph layoutSubmorphsIfNeeded. - - currentMorph isKnownFailing ifTrue: [ - self drawCurrentAsError. - self outOfMorph. - ^ self]. - - (currentMorph isOwnedByHand and: [ Preferences cheapWindowReframe ]) ifTrue: [ - self drawCurrentAsOutline. - self outOfMorph. - ^ self]. - - "Draw current Morph" - self isCurrentMorphVisible ifTrue: [ - currentMorph drawOn: self ]. - - "Display submorphs back to front" - "coordinate system stack already set up for aMorph - ('ivars transformations' and 'currentTransformation')" - currentMorph hasSubmorphs ifTrue: [ - currentMorph clippedSubmorph ifNotNil: [ :clipped | - self clippingByCurrentMorphDo: [ self fullDraw: clipped ]]. - currentMorph unclippedSubmorphsReverseDo: [ :m | - self fullDraw: m ]. - ]. - self outOfMorph! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4113-emptyTextDisplayMessage-fix-JuanVuletich-2020Apr14-17h51m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4113] on 15 April 2020 at 5:38:57 pm'! -!GeometryTransformation commentStamp: '' prior: 16849934! - Superclass of several Geometry Transformations used mainly to specify locations of Morphs. - -Morphs specify a coordinate system in which they and their submorphs are expressed. A Morph's coordinate system is defined by a GeometryTransformation that is applied to points in inner space to convert them to points in outer space. Therefore #externalizePosition: is equivalent of #transform: and #internalizePosition: is equivalent to #inverseTransform:! -!Morph commentStamp: '' prior: 50408180! - A Morph (from the Greek "shape" or "form") is an interactive graphical object. General information on the Morphic system can be found at http://wiki.squeak.org/squeak/morph. - -Morphs exist in a tree, rooted at a World (generally a PasteUpMorph). The morphs owned by a morph are its submorphs. Morphs are drawn recursively; if a Morph has no owner it never gets drawn. To hide a Morph and its submorphs, set its #visible property to false using the #visible: method. - -Structure: -instance var Type Description -owner Morph My parent Morph, or nil for the top-level Morph, which is a - or nil world, typically a PasteUpMorph. -submorphs Array My child Morphs. -location GeometryTransformation Specifies position (and possibly, angle of rotation and scale change) inside owner - See comment at GeometryTransformation -extension MorphExtension Allows extra properties to be stored without adding a - or nil storage burden to all morphs. -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4114-CoupleOfClassComments-JuanVuletich-2020Apr15-17h22m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4109] on 13 April 2020 at 12:10:39 am'! - -"Change Set: 4104-CuisCore-AuthorName-2020Apr04-12h34m -Date: 13 April 2020 -Author: Nahuel Garbezza - -Alpha version of the Extract to Temporary refactoring"! - -ParseNode subclass: #TemporariesDeclarationNode - instanceVariableNames: 'tempDeclarationNodes declarationWritten ' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #TemporariesDeclarationNode category: #'Compiler-ParseNodes' stamp: 'Install-4115-ExtractToTemporary-NahuelGarbezza-2020Apr04-12h34m-RNG.001.cs.st 5/26/2020 17:08:32'! -ParseNode subclass: #TemporariesDeclarationNode - instanceVariableNames: 'tempDeclarationNodes declarationWritten' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -Refactoring subclass: #ExtractToTemporary - instanceVariableNames: 'newVariableName parseNodeToExtract methodNodeToRefactor methodToRefactor updatedSourceCode intervalToExtract sourceCodeToExtract parseNodeWithNewVariableScope' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractToTemporary category: #'Tools-Refactoring' stamp: 'Install-4115-ExtractToTemporary-NahuelGarbezza-2020Apr04-12h34m-RNG.001.cs.st 5/26/2020 17:08:32'! -Refactoring subclass: #ExtractToTemporary - instanceVariableNames: 'newVariableName parseNodeToExtract methodNodeToRefactor methodToRefactor updatedSourceCode intervalToExtract sourceCodeToExtract parseNodeWithNewVariableScope' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #ExtractToTemporaryApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newVariable' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractToTemporaryApplier category: #'Tools-Refactoring' stamp: 'Install-4115-ExtractToTemporary-NahuelGarbezza-2020Apr04-12h34m-RNG.001.cs.st 5/26/2020 17:08:32'! -RefactoringApplier subclass: #ExtractToTemporaryApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newVariable' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!Interval methodsFor: 'refactorings' stamp: 'RNG 4/13/2020 00:06:02'! - shouldTrimToMatchExpressionOn: sourceCode atIndex: currentIndex - - | currentChar | - currentChar := sourceCode at: currentIndex ifAbsent: [ ^ false ]. - ^ currentChar isSeparator or: [ currentChar = $. ] -! ! -!Interval methodsFor: 'refactorings' stamp: 'RNG 4/13/2020 00:05:57'! - trimMatchingParenthesesOn: aSourceCode - - | trimmedInterval | - trimmedInterval := self. - [ - | initialChar endingChar | - initialChar := aSourceCode at: trimmedInterval first ifAbsent: [ nil ]. - endingChar := aSourceCode at: trimmedInterval last ifAbsent: [ nil ]. - initialChar = $( and: [ endingChar = $) ] - ] - whileTrue: [ trimmedInterval _ trimmedInterval first + 1 to: trimmedInterval last - 1 ]. - ^ trimmedInterval! ! -!Interval methodsFor: 'refactorings' stamp: 'RNG 4/13/2020 00:06:21'! - trimToMatchExpressionOn: aSourceCode - - | trimmedInterval | - trimmedInterval := self. - [ self shouldTrimToMatchExpressionOn: aSourceCode atIndex: trimmedInterval first ] - whileTrue: [ trimmedInterval := trimmedInterval first + 1 to: trimmedInterval last ]. - [ self shouldTrimToMatchExpressionOn: aSourceCode atIndex: trimmedInterval last ] - whileTrue: [ trimmedInterval := trimmedInterval first to: trimmedInterval last - 1 ]. - - ^ trimmedInterval trimMatchingParenthesesOn: aSourceCode! ! -!ParseNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 13:03:46'! - isBraceNode - - ^ false! ! -!ParseNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 13:09:00'! - isSelectorNode - - ^ false! ! -!ParseNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 12:54:25'! - isTemporaryDeclaration - - ^ false! ! -!AssignmentNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 12:56:01' overrides: 50488478! - equivalentTo: aParseNode - - ^ aParseNode isAssignmentNode - and: [ self variable equivalentTo: aParseNode variable ] - and: [ self value equivalentTo: aParseNode value ]! ! -!BraceNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 13:07:05' overrides: 50488478! - equivalentTo: aParseNode - - ^ aParseNode isBraceNode and: [ self hasEquivalentElementsTo: aParseNode ]! ! -!BraceNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 13:03:33' overrides: 50506431! - isBraceNode - - ^ true! ! -!BraceNode methodsFor: 'private' stamp: 'RNG 4/4/2020 13:06:30'! - hasEquivalentElementsTo: aBraceNode - - elements with: aBraceNode elements do: [ :myElement :otherElement | - (myElement equivalentTo: otherElement) ifFalse: [ ^ false ] ]. - ^ true! ! -!CodeNode methodsFor: 'accessing' stamp: 'RNG 4/5/2020 19:45:20' prior: 50505300! - temporariesDeclaration - - self subclassResponsibility! ! -!CodeNode methodsFor: 'accessing' stamp: 'RNG 4/5/2020 19:45:28' prior: 50505304! - temporariesDeclaration: aTemporariesDeclarationNode - - self subclassResponsibility! ! -!CodeNode methodsFor: 'private' stamp: 'RNG 4/4/2020 13:41:00'! - hasEquivalentArgumentsWith: aCodeNode - - self arguments with: aCodeNode arguments do: [ :myArgument :otherCodeNodeArgument | - (myArgument equivalentTo: otherCodeNodeArgument) ifFalse: [ ^ false ] ]. - ^ true! ! -!CodeNode methodsFor: 'private' stamp: 'RNG 4/12/2020 20:44:29'! - hasEquivalentTemporariesDeclarationWith: aCodeNode - - ^ (self temporariesDeclaration isNil and: [ aCodeNode temporariesDeclaration isNil ]) - or: [ self temporariesDeclaration equivalentTo: aCodeNode temporariesDeclaration ]! ! -!CodeNode methodsFor: 'testing' stamp: 'RNG 4/5/2020 19:45:40' prior: 50505309! - hasTemporaryVariables - - ^ self temporariesDeclaration declaresAnyVariable! ! -!BlockNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 13:40:17' overrides: 50488478! - equivalentTo: aParseNode - - ^ aParseNode isBlockNode - and: [ self hasEquivalentArgumentsWith: aParseNode ] - and: [ self hasEquivalentTemporariesDeclarationWith: aParseNode ] - and: [ self hasEquivalentStatementsWith: aParseNode ]! ! -!BlockNode methodsFor: 'private' stamp: 'RNG 4/12/2020 17:14:17'! - hasEquivalentStatementsWith: aCodeNode - - self statements with: aCodeNode statements do: [ :myStatement :otherCodeNodeStatement | - (myStatement equivalentTo: otherCodeNodeStatement) ifFalse: [ ^ false ] ]. - ^ true! ! -!MethodNode methodsFor: 'source mapping' stamp: 'RNG 4/4/2020 20:02:38'! - singleCompleteSourceRangeOf: requestedParseNode - "Returns the source range associated with the requested parse node. - Fails if there is no source range, or if there are multiple source ranges." - - self completeSourceRangesDo: [ :parseNode :sourceRanges | - (parseNode equivalentTo: requestedParseNode) ifTrue: [ - sourceRanges size > 1 ifTrue: [ self error: 'there are multiple source ranges for this parse node' ]. - ^ sourceRanges first ] ]. - self error: 'could not find source range for this parse node'! ! -!LeafNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 13:35:08' overrides: 50488478! - equivalentTo: aParseNode - - ^ self class = aParseNode class and: [ self key = aParseNode key ]! ! -!SelectorNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 13:21:32' overrides: 50506542! - equivalentTo: aParseNode - - ^ aParseNode isSelectorNode and: [ super equivalentTo: aParseNode ]! ! -!SelectorNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 13:08:43' overrides: 50506434! - isSelectorNode - - ^ true! ! -!VariableNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 13:21:40' overrides: 50506542! - equivalentTo: aParseNode - - ^ aParseNode isVariableNode and: [ super equivalentTo: aParseNode ]! ! -!MessageNode methodsFor: 'equation translation' stamp: 'RNG 4/12/2020 20:42:11'! - originalArguments - - ^ originalArguments! ! -!MessageNode methodsFor: 'equation translation' stamp: 'RNG 4/12/2020 20:39:00'! - originalReceiver - - ^ originalReceiver! ! -!MessageNode methodsFor: 'private' stamp: 'RNG 4/12/2020 23:20:49'! - compare: myArguments with: othersArguments - - myArguments with: othersArguments do: [ :myArgument :otherArgument | - (myArgument equivalentTo: otherArgument) ifFalse: [ ^ false ] ]. - ^ true! ! -!MessageNode methodsFor: 'private' stamp: 'RNG 4/12/2020 23:21:37'! - hasEquivalentReceiverWith: aMessageNode - - ^ self isCascade - ifTrue: [ originalReceiver equivalentTo: aMessageNode originalReceiver ] - ifFalse: [ receiver equivalentTo: aMessageNode receiver ]! ! -!ReturnNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 12:50:40' overrides: 50488478! - equivalentTo: aParseNode - - ^ aParseNode isReturn and: [ expr equivalentTo: aParseNode expr ]! ! -!TemporariesDeclarationNode methodsFor: 'initialization' stamp: 'RNG 4/4/2020 12:51:49'! - initializeWithAll: aCollectionOfTempDeclarationNodes declarationWritten: aBoolean - - tempDeclarationNodes := aCollectionOfTempDeclarationNodes. - declarationWritten := aBoolean! ! -!TemporariesDeclarationNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 12:53:45'! - declarationWritten - - ^ declarationWritten! ! -!TemporariesDeclarationNode methodsFor: 'testing' stamp: 'RNG 4/13/2020 00:09:45'! -declaresSameVariablesThan: aTemporariesDeclarationNode - - self temporaryDeclarationNodes with: aTemporariesDeclarationNode temporaryDeclarationNodes do: [ :myTempDeclaration :otherTempDeclaration | - (myTempDeclaration equivalentTo: otherTempDeclaration) ifFalse: [ ^ false ] ]. - ^ true! ! -!TemporariesDeclarationNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 12:52:52' overrides: 50488478! - equivalentTo: aParseNode - - ^ aParseNode isTemporariesDeclaration - and: [ self declaresSameVariablesThan: aParseNode ]! ! -!TemporariesDeclarationNode class methodsFor: 'instance creation' stamp: 'RNG 4/4/2020 12:51:26'! - withAll: tempDeclarationNodes declarationWritten: aBoolean - - ^ self new initializeWithAll: tempDeclarationNodes declarationWritten: aBoolean! ! -!TemporaryDeclarationNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 12:54:43' overrides: 50488478! - equivalentTo: aParseNode - - ^ aParseNode isTemporaryDeclaration - and: [ self declaresVariable: aParseNode variableNode ]! ! -!TemporaryDeclarationNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 12:54:00' overrides: 50506437! -isTemporaryDeclaration - - ^ true! ! -!SmalltalkEditor methodsFor: 'extract to temporary' stamp: 'RNG 4/4/2020 13:28:28'! - extractToTemporary - - self ifSourceCodeRefactoringCanBeAppliedDo: [ - ExtractToTemporaryApplier createAndValueHandlingExceptions: [ - ExtractToTemporaryApplier for: self selectionInterval of: self codeProvider currentCompiledMethod ] ]! ! -!SmalltalkEditor methodsFor: 'extract to temporary' stamp: 'RNG 4/4/2020 13:28:19'! - extractToTemporary: aKeyboardEvent - - self extractToTemporary. - ^true! ! -!SmalltalkEditor methodsFor: 'private' stamp: 'RNG 4/4/2020 13:29:56'! - hasValidCurrentCompiledMethod - - ^ (self codeProvider respondsTo: #currentCompiledMethod) - and: [ self codeProvider currentCompiledMethod notNil ]! ! -!ExtractToTemporary methodsFor: 'applying' stamp: 'RNG 2/25/2020 19:06:03' overrides: 50438490! - apply - - self - replaceExtractedCodeWithNewTemporaryVariable; - writeAssignmentStatementOfNewTemporaryVariable; - declareNewTemporaryVariable; - reflectSourceCodeChanges! ! -!ExtractToTemporary methodsFor: 'initialization' stamp: 'RNG 3/29/2020 23:13:34'! - initializeNamed: aNewVariable extractingCodeAt: anIntervalToExtract from: aMethodToRefactor declaringTempIn: blockNodeOfNewVariable - - newVariableName _ aNewVariable. - intervalToExtract _ anIntervalToExtract. - methodToRefactor _ aMethodToRefactor. - methodNodeToRefactor _ methodToRefactor methodNode. - updatedSourceCode _ aMethodToRefactor sourceCode. - sourceCodeToExtract _ updatedSourceCode copyFrom: intervalToExtract first to: intervalToExtract last. - parseNodeWithNewVariableScope _ blockNodeOfNewVariable! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 4/4/2020 19:32:46'! - addNewTemporaryVariableToExistingDeclarationStatement - - | sourceRangeOfLastTempDeclaration positionOfLastTempDeclaration | - parseNodeWithNewVariableScope hasTemporaryVariables - ifTrue: [ - sourceRangeOfLastTempDeclaration := methodNodeToRefactor singleCompleteSourceRangeOf: self lastTemporaryDeclaration. - positionOfLastTempDeclaration := sourceRangeOfLastTempDeclaration last + 1 ] - ifFalse: [ - sourceRangeOfLastTempDeclaration := methodNodeToRefactor singleCompleteSourceRangeOf: parseNodeWithNewVariableScope temporariesDeclaration. - positionOfLastTempDeclaration := sourceRangeOfLastTempDeclaration last - 1 ]. - - self insertAt: positionOfLastTempDeclaration newCodeWith: ' ' , newVariableName! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 3/29/2020 23:16:07'! - declareNewTemporaryVariable - - self hasTemporariesDeclarationBlock - ifTrue: [ self addNewTemporaryVariableToExistingDeclarationStatement ] - ifFalse: [ self insertNewTemporaryDeclarationWithNewVariable ]! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 4/13/2020 00:03:15'! - formattedNewVariableAssignment - - | newVariableAssignment | - newVariableAssignment := newVariableName , ' ' , self preferredAssignmentOperator , ' ' , sourceCodeToExtract , '.'. - ^ newVariableAssignment , String newLineString , String tab! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 3/29/2020 23:38:38'! - hasTemporariesDeclarationBlock - - ^ parseNodeWithNewVariableScope temporariesDeclaration declarationWritten! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 4/13/2020 00:02:27'! - insertAt: aPositionInSourceCode newCodeWith: sourceCodeContents - - updatedSourceCode := updatedSourceCode - copyReplaceFrom: aPositionInSourceCode - to: aPositionInSourceCode - 1 - with: sourceCodeContents! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 4/13/2020 00:02:42'! - insertNewTemporaryDeclarationWithNewVariable - - | newVariableDeclaration positionToInsertTempVarDeclaration sourceRangeOfFirstStatement | - sourceRangeOfFirstStatement := methodNodeToRefactor singleCompleteSourceRangeOf: self siblingStatementsOfTemporaryAssignment first. - positionToInsertTempVarDeclaration := sourceRangeOfFirstStatement first. - newVariableDeclaration := '| ' , newVariableName , ' |' , String newLineString , String tab. - - self insertAt: positionToInsertTempVarDeclaration newCodeWith: newVariableDeclaration! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 3/29/2020 23:14:02'! - lastTemporaryDeclaration - - ^ parseNodeWithNewVariableScope temporariesDeclaration temporaryDeclarationNodes last! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 2/26/2020 12:36:45'! - positionToInsertNewTemporaryVariableAssignment - - ^ (methodNodeToRefactor singleCompleteSourceRangeOf: self statementNodeIncludingCodeToExtract) first! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 3/24/2020 22:21:22'! - preferredAssignmentOperator - - ^ Preferences leftArrowAssignmentsInGeneratedCodeWithComputedDefault - ifTrue: [ '_' ] - ifFalse: [ ':=' ]! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 4/2/2020 22:29:19'! - reflectSourceCodeChanges - - self flag: #RNG. "remove the error handler once all the cases are supported" - - [ methodToRefactor methodClass - compile: updatedSourceCode - classified: methodToRefactor category ] - on: SyntaxErrorNotification - do: [ :syntaxError | self class refactoringError: 'Syntax error: unsupported refactoring case' ]! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 4/13/2020 00:03:26'! - replaceExtractedCodeWithNewTemporaryVariable - - updatedSourceCode := updatedSourceCode - copyReplaceFrom: intervalToExtract first - to: intervalToExtract last - with: newVariableName! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 3/29/2020 23:18:06'! - siblingStatementsOfTemporaryAssignment - - ^ parseNodeWithNewVariableScope isBlockNode - ifTrue: [ parseNodeWithNewVariableScope statements ] - ifFalse: [ parseNodeWithNewVariableScope block statements ]! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 4/13/2020 00:03:00'! - statementNodeIncludingCodeToExtract - - ^ self siblingStatementsOfTemporaryAssignment detect: [ :statement | - (methodNodeToRefactor singleCompleteSourceRangeOf: statement) last >= intervalToExtract last ]! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 2/26/2020 12:37:27'! - writeAssignmentStatementOfNewTemporaryVariable - - self - insertAt: self positionToInsertNewTemporaryVariableAssignment - newCodeWith: self formattedNewVariableAssignment! ! -!ExtractToTemporary class methodsFor: 'error messages' stamp: 'RNG 4/12/2020 20:13:23'! - errorMessageForSourceCodeIncludingAnInvalidExpression - - ^ 'The source code selection contains an invalid expression'! ! -!ExtractToTemporary class methodsFor: 'error messages' stamp: 'RNG 2/25/2020 15:14:33'! - errorMessageForSourceCodeSelectionOutOfBounds - - ^ 'The source code selection interval is out of bounds'! ! -!ExtractToTemporary class methodsFor: 'error messages' stamp: 'RNG 2/24/2020 22:59:12'! - errorMessageForSourceCodeToExtractCanNotBeEmpty - - ^ 'Source code to extract can not be empty'! ! -!ExtractToTemporary class methodsFor: 'error messages' stamp: 'RNG 2/24/2020 23:02:10'! - errorMessageForSourceCodeToExtractCanNotIncludeReturn - - ^ 'An expression containing a return can not be extracted'! ! -!ExtractToTemporary class methodsFor: 'error messages' stamp: 'RNG 2/24/2020 22:59:08'! - errorMessageForSourceCodeToExtractHasSyntaxError: anErrorDescription - - ^ 'Can not extract a source code with syntax error: ', anErrorDescription ! ! -!ExtractToTemporary class methodsFor: 'error messages' stamp: 'RNG 2/24/2020 23:00:15'! - errorMessageForSourceCodeToExtractHasToBeOneStatement - - ^ 'Can not extract more than one statement'! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/30/2017 06:34:15'! - signalColaborationToExtractHasSyntaxError: aSyntaxErrorNotification - - self refactoringError: (self errorMessageForSourceCodeToExtractHasSyntaxError: aSyntaxErrorNotification messageText)! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'RNG 2/24/2020 23:00:16'! - signalColaborationToExtractHasToBeOneStatement - - self refactoringError: self errorMessageForSourceCodeToExtractHasToBeOneStatement ! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'RNG 2/25/2020 15:21:32'! - signalOutOfBoundsIntervalError - - self refactoringError: self errorMessageForSourceCodeSelectionOutOfBounds! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'RNG 4/12/2020 23:09:03'! - signalSourceCodeSelectionIncludesAnInvalidExpression - - self refactoringError: self errorMessageForSourceCodeIncludingAnInvalidExpression! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'RNG 2/24/2020 22:58:36'! -signalSourceCodeToExtractCanNotBeEmpty - - self refactoringError: self errorMessageForSourceCodeToExtractCanNotBeEmpty! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'RNG 2/24/2020 23:02:10'! - signalSourceCodeToExtractCanNotIncludeReturn - - self refactoringError: self errorMessageForSourceCodeToExtractCanNotIncludeReturn ! ! -!ExtractToTemporary class methodsFor: 'instance creation' stamp: 'RNG 4/12/2020 23:54:43'! -named: aNewVariable at: anIntervalToExtract from: aMethodToRefactor - - | trimmedNewVariable trimmedIntervalToExtract codeNodeForNewVariable methodNodeToRefactor | - - self assertCanApplyRefactoringOn: aMethodToRefactor at: anIntervalToExtract. - methodNodeToRefactor := aMethodToRefactor methodNode. - trimmedNewVariable := aNewVariable withBlanksTrimmed. - trimmedIntervalToExtract := anIntervalToExtract trimToMatchExpressionOn: aMethodToRefactor sourceCode. - codeNodeForNewVariable := self methodOrBlockNodeIncluding: anIntervalToExtract in: methodNodeToRefactor. - self newTemporaryPreconditionClass valueFor: trimmedNewVariable in: codeNodeForNewVariable of: methodNodeToRefactor. - - ^ self new - initializeNamed: trimmedNewVariable - extractingCodeAt: trimmedIntervalToExtract - from: aMethodToRefactor - declaringTempIn: codeNodeForNewVariable! ! -!ExtractToTemporary class methodsFor: 'preconditions' stamp: 'RNG 4/12/2020 23:54:29'! - assertCanApplyRefactoringOn: aMethodToRefactor at: anIntervalToExtract - - | trimmedSourceCodeToExtract methodNodeToExtract sourceCodeToExtract trimmedIntervalToExtract originalSourceCode | - - self assert: anIntervalToExtract isValidIntervalOn: aMethodToRefactor. - originalSourceCode := aMethodToRefactor sourceCode. - sourceCodeToExtract := originalSourceCode copyFrom: anIntervalToExtract first to: anIntervalToExtract last. - trimmedSourceCodeToExtract := sourceCodeToExtract withBlanksTrimmed. - trimmedIntervalToExtract := anIntervalToExtract trimToMatchExpressionOn: originalSourceCode. - self assertSourceCodeIsNotEmpty: trimmedSourceCodeToExtract. - methodNodeToExtract := self tryToParse: trimmedSourceCodeToExtract on: aMethodToRefactor methodClass. - self assertHasOneStatement: methodNodeToExtract. - self assertIsNotReturn: trimmedSourceCodeToExtract. - self assert: trimmedIntervalToExtract enclosesAValidExpressionOn: aMethodToRefactor.! ! -!ExtractToTemporary class methodsFor: 'private - parsing' stamp: 'RNG 2/25/2020 15:18:08'! - is: anIntervalToExtract withinBoundsOf: aSourceCode - - ^ anIntervalToExtract first >= 1 and: [ anIntervalToExtract last <= aSourceCode size ]! ! -!ExtractToTemporary class methodsFor: 'private - parsing' stamp: 'RNG 4/4/2020 12:41:16'! - methodOrBlockNodeIncluding: anIntervalToExtract in: methodNodeToRefactor - "Finds the appropriate block node to define a variable that will reference the code in the interval to extract. - The possibles results are the top-level methodNode or a block node inside some of the method statements." - - self flag: #RNG. "use Interval>>isIncludedIn: once is merged" - methodNodeToRefactor completeSourceRangesDo: [ :parseNode :sourceRanges | - (parseNode isBlockNode - and: [ parseNode ~= methodNodeToRefactor block ] - and: [ sourceRanges anySatisfy: [ :sourceRange | - (sourceRange rangeIncludes: anIntervalToExtract first) and: [ sourceRange rangeIncludes: anIntervalToExtract last ] ] ]) - ifTrue: [ ^ parseNode ] - ]. - ^ methodNodeToRefactor! ! -!ExtractToTemporary class methodsFor: 'private - parsing' stamp: 'RNG 4/12/2020 19:21:29'! - tryToParse: aSourceCode on: aClassToRefactor - - ^ [ Parser parse: aSourceCode class: aClassToRefactor noPattern: true ] - on: SyntaxErrorNotification - do: [ :anError | self signalColaborationToExtractHasSyntaxError: anError ]! ! -!ExtractToTemporary class methodsFor: 'private - preconditions' stamp: 'RNG 4/12/2020 23:54:12'! - anySourceRangeOf: aMethodToRefactor matches: anIntervalToExtract - - | sourceRangeCollections allSourceRanges sourceCode | - sourceRangeCollections := aMethodToRefactor methodNode completeSourceRanges values. - allSourceRanges := sourceRangeCollections - inject: Set new - into: [ :sourceRanges :sourceRangeCollection | sourceRanges addAll: sourceRangeCollection; yourself ]. - sourceCode := aMethodToRefactor sourceCode. - ^ allSourceRanges anySatisfy: [ :sourceRange | - (sourceRange trimToMatchExpressionOn: sourceCode) = anIntervalToExtract ]! ! -!ExtractToTemporary class methodsFor: 'private - preconditions' stamp: 'RNG 4/12/2020 23:28:52'! - assert: anIntervalToExtract enclosesAValidExpressionOn: aMethodToRefactor - - (self anySourceRangeOf: aMethodToRefactor matches: anIntervalToExtract) - ifFalse: [ self signalSourceCodeSelectionIncludesAnInvalidExpression ]! ! -!ExtractToTemporary class methodsFor: 'private - preconditions' stamp: 'RNG 4/12/2020 23:08:37'! - assert: anIntervalToExtract isValidIntervalOn: aMethodToRefactor - - (self is: anIntervalToExtract withinBoundsOf: aMethodToRefactor sourceCode) - ifFalse: [ self signalOutOfBoundsIntervalError ]! ! -!ExtractToTemporary class methodsFor: 'private - preconditions' stamp: 'RNG 4/12/2020 23:14:04'! - assertHasOneStatement: aMethodNodeToExtract - - aMethodNodeToExtract numberOfStatements ~= 1 - ifTrue: [ self signalColaborationToExtractHasToBeOneStatement ]! ! -!ExtractToTemporary class methodsFor: 'private - preconditions' stamp: 'RNG 4/12/2020 23:08:48'! - assertIsNotReturn: aSourceCodeToExtract - - "I have to use the source code to check this because parsing it returns the same methodNode for - 1 and ^1, that is, using methodNode does not help to distinguish if there was or not a return - Hernan" - - aSourceCodeToExtract withBlanksTrimmed first = $^ - ifTrue: [ self signalSourceCodeToExtractCanNotIncludeReturn ]! ! -!ExtractToTemporary class methodsFor: 'private - preconditions' stamp: 'RNG 2/24/2020 22:57:24'! - assertSourceCodeIsNotEmpty: aSourceCodeToExtract - - aSourceCodeToExtract isEmpty ifTrue: [ self signalSourceCodeToExtractCanNotBeEmpty ]! ! -!ExtractToTemporary class methodsFor: 'private - preconditions' stamp: 'RNG 2/22/2020 22:09:40'! - newTemporaryPreconditionClass - - ^ NewTemporaryPrecondition! ! -!ExtractToTemporaryApplier methodsFor: 'initialization' stamp: 'RNG 2/15/2020 16:16:53'! - initializeFor: anIntervalToExtract of: aMethodToExtractCodeFrom - - intervalToExtract _ anIntervalToExtract. - methodToExtractCodeFrom _ aMethodToExtractCodeFrom.! ! -!ExtractToTemporaryApplier methodsFor: 'refactoring - changes' stamp: 'RNG 2/15/2020 16:50:13' overrides: 50441450! - showChanges - - ! ! -!ExtractToTemporaryApplier methodsFor: 'refactoring - creation' stamp: 'RNG 2/15/2020 17:05:41' overrides: 50441327! - createRefactoring - - ^ self refactoringClass - named: newVariable - at: intervalToExtract - from: methodToExtractCodeFrom! ! -!ExtractToTemporaryApplier methodsFor: 'refactoring - creation' stamp: 'RNG 2/15/2020 16:26:52'! - refactoringClass - - ^ ExtractToTemporary! ! -!ExtractToTemporaryApplier methodsFor: 'refactoring - parameters request' stamp: 'RNG 4/13/2020 00:04:58'! - askNewVariableName - - newVariable := (self request: 'Enter new temp name:' initialAnswer: '') withBlanksTrimmed! ! -!ExtractToTemporaryApplier methodsFor: 'refactoring - parameters request' stamp: 'RNG 2/15/2020 16:22:35' overrides: 50441345! - requestRefactoringParameters - - self askNewVariableName! ! -!ExtractToTemporaryApplier class methodsFor: 'as yet unclassified' stamp: 'RNG 3/24/2020 23:40:22'! - assertCanApplyRefactoringOn: aMethodToRefactor at: anIntervalToExtract - - ExtractToTemporary - assertCanApplyRefactoringOn: aMethodToRefactor - at: anIntervalToExtract! ! -!ExtractToTemporaryApplier class methodsFor: 'as yet unclassified' stamp: 'RNG 2/25/2020 16:36:24'! - for: anIntervalToExtract of: aMethodToExtractCodeFrom - - self assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: anIntervalToExtract. - - ^ self new initializeFor: anIntervalToExtract of: aMethodToExtractCodeFrom! ! -!ParseNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 13:01:23' prior: 50488478! - equivalentTo: aParseNode - - ^ false! ! -!LiteralNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 13:21:24' prior: 50488609 overrides: 50506542! - equivalentTo: aParseNode - - ^ aParseNode isLiteralNode and: [ super equivalentTo: aParseNode ]! ! -!MessageNode methodsFor: 'testing' stamp: 'RNG 4/12/2020 20:34:23' prior: 50502806 overrides: 50507189! - equivalentTo: aParseNode - - ^ aParseNode isMessageNode - and: [ self hasEquivalentReceiverWith: aParseNode ] - and: [ self selector equivalentTo: aParseNode selector ] - and: [ self hasEquivalentArgumentsWith: aParseNode ]! ! -!MessageNode methodsFor: 'private' stamp: 'RNG 4/12/2020 23:20:14' prior: 50502795! - hasEquivalentArgumentsWith: aMessageNode - - ^ self isCascade - ifTrue: [ self compare: originalArguments with: aMessageNode originalArguments ] - ifFalse: [ self compare: arguments with: aMessageNode arguments ]! ! -!TemporariesDeclarationNode class methodsFor: 'instance creation' stamp: 'RNG 4/4/2020 12:52:12' prior: 50502008! - empty - - ^ self withAll: #() declarationWritten: false! ! -!TemporariesDeclarationNode class methodsFor: 'instance creation' stamp: 'RNG 4/4/2020 12:52:06' prior: 50502013! - withAll: tempDeclarationNodes - - ^ self new initializeWithAll: tempDeclarationNodes declarationWritten: true! ! -!SmalltalkEditor methodsFor: 'extract method' stamp: 'RNG 4/4/2020 13:29:24' prior: 50489717! - extractMethod - - "To prevent the extract method to be evaluated on editors w/o methods like the workspace" - self hasValidCurrentCompiledMethod ifFalse: [ ^ nil ]. - - self ifSourceCodeRefactoringCanBeAppliedDo: [ - ExtractMethodApplier createAndValueHandlingExceptions: [ - ExtractMethodApplier for: self selectionInterval of: self codeProvider currentCompiledMethod ] ]! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 4/12/2020 23:49:38' prior: 50489487! - trimmed: anInterval - - ^ anInterval trimToMatchExpressionOn: sourceCode! ! -!ExtractMethod class methodsFor: 'instance creation' stamp: 'RNG 4/12/2020 23:47:26' prior: 50505525! - fromInterval: anIntervalToExtract of: aMethodToExtractCodeFrom to: newMessage categorizedAs: aCategory - - | trimmedIntervalToExtract | - trimmedIntervalToExtract := anIntervalToExtract trimToMatchExpressionOn: aMethodToExtractCodeFrom sourceCode. - self - assert: newMessage selector canBeDefinedIn: aMethodToExtractCodeFrom methodClass; - assert: trimmedIntervalToExtract isValidIntervalOn: aMethodToExtractCodeFrom; - assert: newMessage hasValidParametersForExtracting: anIntervalToExtract from: aMethodToExtractCodeFrom methodNode. - - ^ self new - initializeFrom: trimmedIntervalToExtract - of: aMethodToExtractCodeFrom - to: newMessage - in: aCategory! ! -!ExtractMethodApplier class methodsFor: 'instance creation' stamp: 'RNG 4/13/2020 00:01:51' prior: 50489171! - for: anIntervalToExtract of: aMethodToExtractCodeFrom - - | trimmedIntervalToExtract sourceCode | - sourceCode := aMethodToExtractCodeFrom sourceCode. - trimmedIntervalToExtract := anIntervalToExtract trimToMatchExpressionOn: sourceCode. - - self assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: trimmedIntervalToExtract. - - ^ self new initializeFor: trimmedIntervalToExtract of: aMethodToExtractCodeFrom! ! -!RefactoringMenues class methodsFor: 'editor menus' stamp: 'RNG 4/4/2020 13:32:20' prior: 50491964! - smalltalkEditorMenuOptions - - ^`{ - { - #itemGroup -> 35. - #itemOrder -> 10. - #label -> 'Rename... (R)'. - #selector -> #contextualRename. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 20. - #label -> 'Extract Temporary... (J)'. - #selector -> #extractToTemporary. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 30. - #label -> 'Extract Method... (K)'. - #selector -> #extractMethod. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 40. - #label -> 'More Refactorings...'. - #selector -> #openSmalltalkEditorRefactoringMenu. - #icon -> #listAddIcon - } asDictionary. - }`! ! -!RefactoringMenues class methodsFor: 'shortcuts' stamp: 'RNG 4/4/2020 13:27:51' prior: 50489911! - smalltalkEditorCmdShortcutsSpec - - ^#( - #($R #contextualRename: 'Renames what is under cursor') - #($A #contextualAddParameter: 'Adds parameter to message that is under cursor') - #($S #contextualRemoveParameter: 'Removes parameter to message that is under cursor') - #($O #temporaryToInstanceVariable: 'Extracts temporary variable to instance variable') - #($J #extractToTemporary: 'Extracts the selected code into a temporary variable') - #($K #extractMethod: 'Extracts the selected code into a separate method') - )! ! - -TemporaryDeclarationNode removeSelector: #isTemporariesDeclaration! - -!methodRemoval: TemporaryDeclarationNode #isTemporariesDeclaration stamp: 'Install-4115-ExtractToTemporary-NahuelGarbezza-2020Apr04-12h34m-RNG.001.cs.st 5/26/2020 17:08:32'! -isTemporariesDeclaration - - ^ true! - -ParseNode subclass: #TemporariesDeclarationNode - instanceVariableNames: 'tempDeclarationNodes declarationWritten' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #TemporariesDeclarationNode category: #'Compiler-ParseNodes' stamp: 'Install-4115-ExtractToTemporary-NahuelGarbezza-2020Apr04-12h34m-RNG.001.cs.st 5/26/2020 17:08:32'! -ParseNode subclass: #TemporariesDeclarationNode - instanceVariableNames: 'tempDeclarationNodes declarationWritten' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -Smalltalk removeClassNamed: #ExtractMethodIntervalTrimmer! - -!classRemoval: #ExtractMethodIntervalTrimmer stamp: 'Install-4115-ExtractToTemporary-NahuelGarbezza-2020Apr04-12h34m-RNG.001.cs.st 5/26/2020 17:08:32'! -Object subclass: #ExtractMethodIntervalTrimmer - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -"Postscript:" -SmalltalkEditor initializeCmdShortcuts.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4115-ExtractToTemporary-NahuelGarbezza-2020Apr04-12h34m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4113] on 14 April 2020 at 8:53:11 pm'! -!Parser methodsFor: 'expression types' stamp: 'RNG 4/14/2020 20:50:40'! - createCascadeNodeWith: receiverNode and: messageNodes - - | sourceRangeOfFirstMessage | - - parseNode := CascadeNode new receiver: receiverNode messages: messageNodes. - sourceRangeOfFirstMessage := encoder rawSourceRanges at: messageNodes first. - sourceRangeOfFirstMessage ifNotNil: [ - | cascadeSourceRangeStart | - cascadeSourceRangeStart := sourceRangeOfFirstMessage first. - encoder noteSourceRange: (cascadeSourceRangeStart to: hereMark + 1) forNode: parseNode ]! ! -!CascadeNode methodsFor: 'source ranges' stamp: 'RNG 4/14/2020 20:45:23' overrides: 50495111! - expandRanges: aSourceRange basedOn: sourceRanges using: sourceCode - - | receiverExpandedRanges expandedRangeWithReceiver | - receiverExpandedRanges _ receiver expandRanges: (sourceRanges at: receiver) basedOn: sourceRanges using: sourceCode. - expandedRangeWithReceiver _ self - expandRange: (aSourceRange isInterval ifTrue: [ aSourceRange ] ifFalse: [ aSourceRange first ]) - basedOn: receiverExpandedRanges. - ^ super - expandRanges: expandedRangeWithReceiver - basedOn: expandedRangeWithReceiver - using: sourceCode! ! -!Parser methodsFor: 'expression types' stamp: 'RNG 4/14/2020 20:50:21' prior: 16886034! - cascade - " {; message} => CascadeNode." - - | receiverNode messageNodes sourceRangeOfFirstMessage | - parseNode canCascade ifFalse: - [^self expected: 'Cascading not']. - parseNode ensureCanCascade: encoder. - receiverNode := parseNode cascadeReceiver. - messageNodes := OrderedCollection with: parseNode. - [self match: #semicolon] - whileTrue: - [parseNode := receiverNode. - (self messagePart: 3 repeat: false) - ifFalse: [^self expected: 'Cascade']. - parseNode canCascade ifFalse: - [^self expected: '<- No special messages']. - parseNode ensureCanCascade: encoder. - parseNode cascadeReceiver. - messageNodes addLast: parseNode]. - self flag: #RNG. "to be replaced by self createCascadeNodeWith: receiverNode and: messageNodes in next changeset" - parseNode := CascadeNode new receiver: receiverNode messages: messageNodes. - sourceRangeOfFirstMessage := encoder rawSourceRanges at: messageNodes first. - sourceRangeOfFirstMessage ifNotNil: [ - | cascadeSourceRangeStart | - cascadeSourceRangeStart := sourceRangeOfFirstMessage first. - encoder noteSourceRange: (cascadeSourceRangeStart to: hereMark + 1) forNode: parseNode ]! ! -!MessageNode methodsFor: 'source ranges' stamp: 'RNG 4/14/2020 20:42:46' prior: 50497491 overrides: 50495111! - expandRanges: aSourceRange basedOn: sourceRanges using: sourceCode - - | receiverExpandedRanges expandedRangeWithReceiver | - receiverExpandedRanges _ self isCascade - ifTrue: [ aSourceRange ] "not expanded because expansion is handled in CascadeNode" - ifFalse: [ receiver expandRanges: (self receiverSourceRangesFrom: sourceRanges) basedOn: sourceRanges using: sourceCode ]. - expandedRangeWithReceiver _ self - expandRange: (aSourceRange isInterval ifTrue: [ aSourceRange ] ifFalse: [ aSourceRange first ]) - basedOn: receiverExpandedRanges. - ^ super - expandRanges: expandedRangeWithReceiver - basedOn: expandedRangeWithReceiver - using: sourceCode! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4116-CascadeMessagesRanges-NahuelGarbezza-2020Apr14-20h09m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4113] on 14 April 2020 at 8:54:36 pm'! -!Parser methodsFor: 'expression types' stamp: 'RNG 4/14/2020 20:53:34' prior: 50507430! - cascade - " {; message} => CascadeNode." - - | receiverNode messageNodes | - parseNode canCascade ifFalse: - [^self expected: 'Cascading not']. - parseNode ensureCanCascade: encoder. - receiverNode := parseNode cascadeReceiver. - messageNodes := OrderedCollection with: parseNode. - [self match: #semicolon] - whileTrue: - [parseNode := receiverNode. - (self messagePart: 3 repeat: false) - ifFalse: [^self expected: 'Cascade']. - parseNode canCascade ifFalse: - [^self expected: '<- No special messages']. - parseNode ensureCanCascade: encoder. - parseNode cascadeReceiver. - messageNodes addLast: parseNode]. - self createCascadeNodeWith: receiverNode and: messageNodes! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4117-CascadeMessagesRanges2-NahuelGarbezza-2020Apr14-20h53m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4117] on 21 April 2020 at 12:44:16 pm'! -!FeatureRequirement methodsFor: 'private' stamp: 'KenD 4/12/2020 11:26:48' prior: 50475957! - placesToLookForPackagesDo: aBlock - - | myDir base packagesDirectory | - - "Look inside my own folder" - pathName ifNotNil: [ - myDir _ pathName asFileEntry parent. - aBlock value: myDir ]. - - "Look in codePackageFile folder" - codePackageFile ifNotNil: [ - myDir := codePackageFile fullName asFileEntry parent. - aBlock value: myDir ]. - - "Look in Cuis image folder and reasonable subfolders" - base _ DirectoryEntry smalltalkImageDirectory. - aBlock value: base. - packagesDirectory _ base / 'Packages'. - aBlock value: packagesDirectory. - packagesDirectory allRegularDirectoriesDo: aBlock. - base regularDirectoriesDo: [ :child | - child = packagesDirectory ifFalse: [ - aBlock value: child. - child allRegularDirectoriesDo: aBlock]]. - - "Look in parent directory and reasonable subfolders. - Useful when image is stored in a subdirectory of the main app directory. - This could be the case when the package comes from a 'main' git repo, and image is copied from gitHub. - First try directories including the word Cuis in the name. Then try others." - base parent regularDirectoriesDo: [ :dir | - dir ~= base ifTrue: [ - ('*Cuis*' match: dir name) - ifTrue: [aBlock value: dir. dir allRegularDirectoriesDo: aBlock]]]. - base parent regularDirectoriesDo: [ :dir | - dir ~= base ifTrue: [ - ('*Cuis*' match: dir name) - ifFalse: [aBlock value: dir. dir allRegularDirectoriesDo: aBlock]]]. - - "Also look in host OS current directory" - (base ~= DirectoryEntry currentDirectory and: [base parent ~= DirectoryEntry currentDirectory]) - ifTrue: [ - base _ DirectoryEntry currentDirectory. - base allRegularDirectoriesDo: aBlock ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4118-placesToLookForPackagesDo-KenDickey-2020Apr21-12h43m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4118] on 21 April 2020 at 1:03:06 pm'! -!Refactoring class methodsFor: 'services - source code' stamp: 'jmv 4/21/2020 12:53:58'! - shouldTrimToMatchExpressionOn: sourceCode atIndex: currentIndex - - | currentChar | - currentChar := sourceCode at: currentIndex ifAbsent: [ ^ false ]. - ^ currentChar isSeparator or: [ currentChar = $. ] -! ! -!Refactoring class methodsFor: 'services - source code' stamp: 'jmv 4/21/2020 12:53:25'! - trim: anInterval matchingParenthesesOn: aSourceCode - - | trimmedInterval | - trimmedInterval := anInterval. - [ - | initialChar endingChar | - initialChar := aSourceCode at: trimmedInterval first ifAbsent: [ nil ]. - endingChar := aSourceCode at: trimmedInterval last ifAbsent: [ nil ]. - initialChar = $( and: [ endingChar = $) ] - ] - whileTrue: [ trimmedInterval _ trimmedInterval first + 1 to: trimmedInterval last - 1 ]. - ^ trimmedInterval! ! -!Refactoring class methodsFor: 'services - source code' stamp: 'jmv 4/21/2020 12:59:54'! - trim: anInterval toMatchExpressionOn: aSourceCode - - | trimmedInterval | - trimmedInterval := anInterval. - [ self shouldTrimToMatchExpressionOn: aSourceCode atIndex: trimmedInterval first ] - whileTrue: [ trimmedInterval := trimmedInterval first + 1 to: trimmedInterval last ]. - [ self shouldTrimToMatchExpressionOn: aSourceCode atIndex: trimmedInterval last ] - whileTrue: [ trimmedInterval := trimmedInterval first to: trimmedInterval last - 1 ]. - - ^ self trim: trimmedInterval matchingParenthesesOn: aSourceCode! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'jmv 4/21/2020 12:55:38' prior: 50507251! - trimmed: anInterval - - ^ Refactoring trim: anInterval toMatchExpressionOn: sourceCode! ! -!ExtractMethod class methodsFor: 'instance creation' stamp: 'jmv 4/21/2020 12:55:14' prior: 50507257! - fromInterval: anIntervalToExtract of: aMethodToExtractCodeFrom to: newMessage categorizedAs: aCategory - - | trimmedIntervalToExtract | - trimmedIntervalToExtract := Refactoring trim: anIntervalToExtract toMatchExpressionOn: aMethodToExtractCodeFrom sourceCode. - self - assert: newMessage selector canBeDefinedIn: aMethodToExtractCodeFrom methodClass; - assert: trimmedIntervalToExtract isValidIntervalOn: aMethodToExtractCodeFrom; - assert: newMessage hasValidParametersForExtracting: anIntervalToExtract from: aMethodToExtractCodeFrom methodNode. - - ^ self new - initializeFrom: trimmedIntervalToExtract - of: aMethodToExtractCodeFrom - to: newMessage - in: aCategory! ! -!ExtractToTemporary class methodsFor: 'instance creation' stamp: 'jmv 4/21/2020 12:56:09' prior: 50506943! - named: aNewVariable at: anIntervalToExtract from: aMethodToRefactor - - | trimmedNewVariable trimmedIntervalToExtract codeNodeForNewVariable methodNodeToRefactor | - - self assertCanApplyRefactoringOn: aMethodToRefactor at: anIntervalToExtract. - methodNodeToRefactor := aMethodToRefactor methodNode. - trimmedNewVariable := aNewVariable withBlanksTrimmed. - trimmedIntervalToExtract := Refactoring trim: anIntervalToExtract toMatchExpressionOn: aMethodToRefactor sourceCode. - codeNodeForNewVariable := self methodOrBlockNodeIncluding: anIntervalToExtract in: methodNodeToRefactor. - self newTemporaryPreconditionClass valueFor: trimmedNewVariable in: codeNodeForNewVariable of: methodNodeToRefactor. - - ^ self new - initializeNamed: trimmedNewVariable - extractingCodeAt: trimmedIntervalToExtract - from: aMethodToRefactor - declaringTempIn: codeNodeForNewVariable! ! -!ExtractToTemporary class methodsFor: 'preconditions' stamp: 'jmv 4/21/2020 12:55:58' prior: 50506973! - assertCanApplyRefactoringOn: aMethodToRefactor at: anIntervalToExtract - - | trimmedSourceCodeToExtract methodNodeToExtract sourceCodeToExtract trimmedIntervalToExtract originalSourceCode | - - self assert: anIntervalToExtract isValidIntervalOn: aMethodToRefactor. - originalSourceCode := aMethodToRefactor sourceCode. - sourceCodeToExtract := originalSourceCode copyFrom: anIntervalToExtract first to: anIntervalToExtract last. - trimmedSourceCodeToExtract := sourceCodeToExtract withBlanksTrimmed. - trimmedIntervalToExtract := Refactoring trim: anIntervalToExtract toMatchExpressionOn: originalSourceCode. - self assertSourceCodeIsNotEmpty: trimmedSourceCodeToExtract. - methodNodeToExtract := self tryToParse: trimmedSourceCodeToExtract on: aMethodToRefactor methodClass. - self assertHasOneStatement: methodNodeToExtract. - self assertIsNotReturn: trimmedSourceCodeToExtract. - self assert: trimmedIntervalToExtract enclosesAValidExpressionOn: aMethodToRefactor.! ! -!ExtractToTemporary class methodsFor: 'private - preconditions' stamp: 'jmv 4/21/2020 12:55:47' prior: 50507052! - anySourceRangeOf: aMethodToRefactor matches: anIntervalToExtract - - | sourceRangeCollections allSourceRanges sourceCode | - sourceRangeCollections := aMethodToRefactor methodNode completeSourceRanges values. - allSourceRanges := sourceRangeCollections - inject: Set new - into: [ :sourceRanges :sourceRangeCollection | sourceRanges addAll: sourceRangeCollection; yourself ]. - sourceCode := aMethodToRefactor sourceCode. - ^ allSourceRanges anySatisfy: [ :sourceRange | - (Refactoring trim: sourceRange toMatchExpressionOn: sourceCode) = anIntervalToExtract ]! ! -!ExtractMethodApplier class methodsFor: 'instance creation' stamp: 'jmv 4/21/2020 12:55:26' prior: 50507281! - for: anIntervalToExtract of: aMethodToExtractCodeFrom - - | trimmedIntervalToExtract sourceCode | - sourceCode := aMethodToExtractCodeFrom sourceCode. - trimmedIntervalToExtract := Refactoring trim: anIntervalToExtract toMatchExpressionOn: sourceCode. - - self assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: trimmedIntervalToExtract. - - ^ self new initializeFor: trimmedIntervalToExtract of: aMethodToExtractCodeFrom! ! - -Interval removeSelector: #trimToMatchExpressionOn:! - -!methodRemoval: Interval #trimToMatchExpressionOn: stamp: 'Install-4119-Interval-cleanup-JuanVuletich-2020Apr21-12h58m-jmv.001.cs.st 5/26/2020 17:08:32'! -trimToMatchExpressionOn: aSourceCode - - | trimmedInterval | - trimmedInterval := self. - [ self shouldTrimToMatchExpressionOn: aSourceCode atIndex: trimmedInterval first ] - whileTrue: [ trimmedInterval := trimmedInterval first + 1 to: trimmedInterval last ]. - [ self shouldTrimToMatchExpressionOn: aSourceCode atIndex: trimmedInterval last ] - whileTrue: [ trimmedInterval := trimmedInterval first to: trimmedInterval last - 1 ]. - - ^ trimmedInterval trimMatchingParenthesesOn: aSourceCode! - -Interval removeSelector: #shouldTrimToMatchExpressionOn:atIndex:! - -!methodRemoval: Interval #shouldTrimToMatchExpressionOn:atIndex: stamp: 'Install-4119-Interval-cleanup-JuanVuletich-2020Apr21-12h58m-jmv.001.cs.st 5/26/2020 17:08:32'! -shouldTrimToMatchExpressionOn: sourceCode atIndex: currentIndex - - | currentChar | - currentChar := sourceCode at: currentIndex ifAbsent: [ ^ false ]. - ^ currentChar isSeparator or: [ currentChar = $. ] -! - -Interval removeSelector: #trimMatchingParenthesesOn:! - -!methodRemoval: Interval #trimMatchingParenthesesOn: stamp: 'Install-4119-Interval-cleanup-JuanVuletich-2020Apr21-12h58m-jmv.001.cs.st 5/26/2020 17:08:32'! -trimMatchingParenthesesOn: aSourceCode - - | trimmedInterval | - trimmedInterval := self. - [ - | initialChar endingChar | - initialChar := aSourceCode at: trimmedInterval first ifAbsent: [ nil ]. - endingChar := aSourceCode at: trimmedInterval last ifAbsent: [ nil ]. - initialChar = $( and: [ endingChar = $) ] - ] - whileTrue: [ trimmedInterval _ trimmedInterval first + 1 to: trimmedInterval last - 1 ]. - ^ trimmedInterval! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4119-Interval-cleanup-JuanVuletich-2020Apr21-12h58m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4112] on 22 April 2020 at 10:49:25 pm'! -!ImageReadWriter class methodsFor: 'instance creation' stamp: 'KenD 4/22/2020 16:41:45'! - fileReaderServicesForFileEntry: filename suffix: suffix - "FileList buttons that read a TrueType font on contents." - - ( self allTypicalFileExtensions includes: suffix) ifTrue: [ - ^ { self serviceReadImage } ]. - - ^#()! ! -!ImageReadWriter class methodsFor: 'instance creation' stamp: 'KenD 4/22/2020 16:44:34'! - imageMorphFromFileEntry: imageFileEntry - "Import an image from a file" - - (ImageMorph new image: (ImageReadWriter formFromFileEntry: imageFileEntry) ) openInWorld. - ! ! -!ImageReadWriter class methodsFor: 'instance creation' stamp: 'KenD 4/22/2020 16:43:53'! - serviceReadImage - "Answer the service of importing an image" - - ^ (SimpleServiceEntry - provider: self - label: 'import as ImageMorph' - selector: #imageMorphFromFileEntry: - description: 'import image as ImageMorph' - buttonLabel: 'import image' - icon: ((Theme content from: 'Theme' get: {'16x16'. 'mimetypes'}) at: 'image-x-generic.png') - ) argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'jmv 4/22/2020 22:41:52'! - formFromFileEntry: aFileEntry - "Answer a Form stored on the file with the given name." - - ^ aFileEntry readStreamDo: [ :stream | - stream useBytes. - self formFromStream: stream ]! ! -!ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'jmv 4/22/2020 22:41:57' prior: 16854457! - formFromFileNamed: fileName - "Answer a Form stored on the file with the given name." - - ^fileName asFileEntry readStreamDo: [ :stream | - stream useBytes. - self formFromStream: stream ]! ! -!ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'jmv 4/22/2020 22:42:34' prior: 16854466! - formFromStream: aBinaryStream - "Answer a Form stored on the given stream." - | reader readerClass form featureName | - - readerClass _ self withAllSubclasses - detect: [ :subclass | subclass understandsImageFormat: aBinaryStream reset ] - ifNone: [ - featureName _ 'Graphics-Files-Additional'. - ^(FeatureRequirement name: featureName) isAlreadySatisfied - ifTrue: [ self error: 'Unsupported image file format.' ] - ifFalse: [ - self error: 'Unsupported image format. Try "', featureName, '".']]. - reader _ readerClass onBinaryStream: aBinaryStream reset. - form _ reader nextImage. - ^ form! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4120-FileList-ImportPicures-JuanVuletich-2020Apr22-22h48m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4120] on 25 April 2020 at 11:03:53 am'! -!False methodsFor: 'controlling' stamp: 'LC 4/25/2020 10:34:34'! - orNot: alternativeBlock - - ^alternativeBlock value not! ! -!True methodsFor: 'controlling' stamp: 'LC 4/25/2020 10:34:49'! - orNot: alternativeBlock - "Nonevaluating disjunction -- answer true since the receiver is true." - - ^self! ! -!String methodsFor: 'grammar' stamp: 'LC 4/25/2020 10:35:17'! - article - | article first letter second | - self isEmpty ifTrue: [^self]. - article := self first isVowel ifTrue: ['an'] ifFalse: ['a']. - first := self first asLowercase. - letter := self size = 1. - second := letter ifFalse: [self second asLowercase]. - (first = $f and: [letter orNot: ['aeiloru' includes: second]]) - ifTrue: [^'an']. - first = $u ifTrue: [ - (letter or: ['ck' includes: second]) ifTrue: [^'a']. - second = $n - ifTrue: [(self size = 2 or: [self third isVowel]) ifTrue: [^'a']]]. - (first = $e and: [second = $u]) ifTrue: [^'a']. - ^article! ! -!String methodsFor: 'grammar' stamp: 'LC 4/25/2020 10:29:48'! - asPlural - | k trimmed plural n | - k := self findFirst: [:ch | ch isSeparator not]. - k > 1 - ifTrue: [^(self copyFrom: 1 to: k - 1) , (self allButFirst: k - 1) asPlural]. - trimmed := self withBlanksTrimmed. - trimmed isEmpty ifTrue: [^'']. - plural := trimmed asLowercase lowercasePlural. - n := trimmed size min: plural size. - 1 to: n do: [:i | - (trimmed at: i) isUppercase - ifTrue: [plural at: i put: (plural at: i) asUppercase]]. - ^plural! ! -!String methodsFor: 'grammar' stamp: 'LC 4/25/2020 10:25:30'! - exceptionalPlural - | singular plural index | - singular := #( - 'addendum' 'aircraft' 'alga' 'alumnus' 'amoeba' 'antenna' 'appendix' - 'bacterium' 'barracks' - 'cactus' 'child' 'criterion' 'curriculum' - 'datum' 'deer' 'dwarf' - 'echo' 'ephemeris' 'embargo' - 'fish' 'focus' 'foot' 'forum' 'fungus' - 'gallows' 'genus' 'goose' - 'hero' - 'index' 'is' - 'larva' 'louse' - 'matrix' 'means' 'memorandum' 'mithos' 'money' 'mouse' - 'nucleus' - 'offspring' 'ox' - 'person' 'phenomenon' 'potato' 'proof' - 'roof' - 'series' 'sheep' 'species' 'spoof' 'stimulus' 'syllabus' - 'tomato' 'tooth' 'torpedo' 'trilby' - 'vertebra' 'veto' - 'was'). - plural := #( - 'addenda' 'aircraft' 'algae' 'alumni' 'amoebae' 'antennae' 'appendices' - 'bacteria' 'barracks' - 'cacti' 'children' 'criteria' 'curricula' - 'data' 'deer' 'dwarfs' - 'echoes' 'ephemerides' 'embargoes' - 'fish' 'foci' 'feet' 'fora' 'fungi' - 'gallows' 'genera' 'geese' - 'heroes' - 'indices' - 'are' - 'larvae' 'lice' - 'matrices' 'means' 'memoranda' 'mythoi' 'moneys' 'mice' - 'nuclei' - 'offspring' 'oxen' - 'people' 'phenomena' 'potatoes' 'proofs' - 'roofs' - 'series' 'sheep' 'species' 'spoofs' 'stimuli' 'syllabi' - 'tomatoes' 'teeth' 'torpedoes' 'trilbys' - 'vertebrae' 'vetoes' - 'were'). - index := singular indexOf: self. - ^index > 0 ifTrue: [plural at: index]! ! -!String methodsFor: 'grammar' stamp: 'LC 4/25/2020 10:25:45'! - isUninflictedNoun - | nouns | - nouns := #( - 'bison' 'bream' 'breeches' 'britches' - 'carp' 'chassis' 'clippers' 'cod' 'contretemps' 'corps' - 'debris' 'diabetes' 'djinn' - 'eland' 'elk' - 'flounder' - 'gallows' 'graffiti' - 'headquarters' 'herpes' 'high-jinks' 'homework' - 'innings' - 'jackanapes' - 'mackerel' 'measles' 'mews' 'mumps' - 'news' - 'pincers' 'pliers' 'proceedings' - 'rabies' - 'salmon' 'scissors' 'sea-bass' 'series' 'shears' 'species' 'swine' - 'trout' 'tuna' - 'whiting' 'wildebeest'). - ^nouns includes: self! ! -!String methodsFor: 'grammar' stamp: 'LC 4/25/2020 10:24:38'! - lowercasePlural - | last | - self exceptionalPlural ifNotNil: [:pl | ^pl]. - self isUninflictedNoun ifTrue: [^self]. - last := self last. - last = $y ifTrue: [ - #('ay' 'ey' 'oy' 'uy') do: [:t | - (self endsWith: t) ifTrue: [^self , 's']. - ^self allButLast , 'ies']]. - #('zz' 'ch' 'sh') do: [:t | (self endsWith: t) ifTrue: [^self , 'es']]. - last = $s ifTrue: [ - self = 'its' ifTrue: [^'their']. - #('bs' 'cs' 'ds' 'ks' 'ls' 'ms' 'rs' 'ts' 'ws') - do: [:t | (self endsWith: t) ifTrue: [^self]]. - #('sis' 'xis') - do: [:t | (self endsWith: t) ifTrue: [^(self allButLast: 2) , 'es']]]. - last = $z ifTrue: [^self , 'zes']. - (last = $x or: [last = $s]) ifTrue: [^self , 'es']. - (self endsWith: 'man') ifTrue: [^(self allButLast: 2) , 'en']. - last = $f ifTrue: [^self allButLast , 'ves']. - (self endsWith: 'fe') ifTrue: [^(self allButLast: 2) , 'ves']. - ^self , 's'! ! -!String methodsFor: 'grammar' stamp: 'LC 4/25/2020 10:26:19'! -pluralize: aBoolean - ^aBoolean ifTrue: [self asPlural] ifFalse: [self]! ! -!String methodsFor: 'grammar' stamp: 'LC 4/25/2020 10:45:49'! - withArticle - ^self article , ' ' , self! ! -!Semaphore methodsFor: 'printing' stamp: 'LC 4/25/2020 10:32:35' overrides: 16814613! - printOn: aStream - super printOn: aStream. - aStream - nextPutAll: ' with '; - nextPutAll: excessSignals asString; - space; - nextPutAll: ('signal' pluralize: excessSignals ~= 1)! ! -!Object methodsFor: 'message handling' stamp: 'LC 4/25/2020 11:00:15' prior: 50368108! - argumentName - | name | - name _ self argumentNameSufix. - ^name article, name! ! -!Object methodsFor: 'printing' stamp: 'LC 4/25/2020 11:01:36' prior: 50368231! - printOn: aStream - "Append to the argument, aStream, a sequence of characters that - identifies the receiver." - - aStream - nextPutAll: self class name withArticle! ! -!Object methodsFor: 'printing' stamp: 'LC 4/25/2020 11:02:06' prior: 50368241! - printWithClosureAnalysisOn: aStream - "Append to the argument, aStream, a sequence of characters that - identifies the receiver." - - aStream - nextPutAll: self class name withArticle! ! -!ContextPart methodsFor: 'debugger access' stamp: 'LC 4/25/2020 11:02:34' prior: 50368252! - print: anObject on: aStream - "Safely print anObject in the face of direct ProtoObject subclasses." - | objClass | - objClass _ self objectClass: anObject. - (objClass canUnderstand: #printOn:) ifTrue: [ - ^anObject printOn: aStream]. - aStream nextPutAll: objClass name withArticle! ! - -String removeSelector: #aOrAnPrefix! - -!methodRemoval: String #aOrAnPrefix stamp: 'Install-4121-String-plurals-indefiniteArticles-LeandroCaniglia-2020Apr25-10h24m-LC.001.cs.st 5/26/2020 17:08:32'! -aOrAnPrefix - - ^self isEmpty - ifTrue: [ self ] - ifFalse: [ self first isVowel ifTrue: ['an'] ifFalse: ['a'] ] -! - -String removeSelector: #prefixedWithAOrAn! - -!methodRemoval: String #prefixedWithAOrAn stamp: 'Install-4121-String-plurals-indefiniteArticles-LeandroCaniglia-2020Apr25-10h24m-LC.001.cs.st 5/26/2020 17:08:32'! -prefixedWithAOrAn - - ^self aOrAnPrefix, self! - -String removeSelector: #trackwithArticle! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4121-String-plurals-indefiniteArticles-LeandroCaniglia-2020Apr25-10h24m-LC.001.cs.st----! - -'From Cuis 5.0 [latest update: #4121] on 25 April 2020 at 12:26:07 pm'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4122-Cleanup-JuanVuletich-2020Apr25-12h25m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4122] on 26 April 2020 at 9:46:37 pm'! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 4/26/2020 21:46:01'! - privateFixedHeight - - ^fixedHeight! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 4/26/2020 21:46:11'! - privateProportionalHeight - - ^ proportionalHeight! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4123-LayoutSpec-PrivateAccessors-JuanVuletich-2020Apr26-21h43m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4123] on 27 April 2020 at 5:32:08 pm'! -!UpdatingStringMorph methodsFor: 'accessing' stamp: 'KenD 4/26/2020 07:11:30'! - showPrintStringFor: anObject - - self contents: anObject printString! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4124-HandyMethodInUpdatingStringMorph-KenDickey-2020Apr27-17h31m-KenD.001.cs.st----! - -'From Cuis 5.0 [latest update: #4124] on 28 April 2020 at 10:15:56 am'! -!Utilities class methodsFor: 'support windows' stamp: 'jmv 4/28/2020 10:11:55' prior: 50400719! - codeManagementInCuisContents - ^ self class firstCommentAt: #codeManagementInCuisContents - -" -Managing your code in Cuis -================== - -(https://github.com/Cuis-Smalltalk/Cuis-Smalltalk-Dev/blob/master/Documentation/CodeManagementInCuis.md) - -Cuis includes tools and procedures for managing Smalltalk code. Code that is not part of the Cuis Core image itself, like applications, frameworks and libraries, should be stored in Packages. New code that are meant as patches, fixes or additions; that could eventually become part of Cuis itself, is not part of any Package, and is therefore automatically stored in ChangeSets. - - -Packages ------------ - -Let's start with Packages. The Package implementation in Cuis is based on PackageInfo, the standard way to specify packages in Squeak and its derivatives, and used, for example, by Monticello. It uses Package names to specify prefixes for Class and Method categories. Classes and Methods whose categories match a Package's prefixes belong in that Package. More details about how PackageInfo decides what code belongs in a package are available at http://wiki.squeak.org/squeak/3329 . - -To install packages (.pck.st files) in Cuis, use the FileList, navigate to the appropriate directory (on disk, or in a GitHub repository, etc), select the package file and click on [Install Package]. - -Cuis includes a tool to manage installed Packages. It is at World / Open / Installed Packages. To create a new package (instead of installing an existing one from a file), click on [Create Package] This creates a new package, and associates with it all the existing code in the image that matches the package name. - -The operations available on installed or newly created packages are: - -[Save] Saves a package on the file system. Overwrites any existing version. It is good to save the package from time to time, to reduce the risk of losing code. - -[Delete] Removes the Package instance from the image. Does not remove any code. This means, effectively, to merge back the code into Cuis. - -[Browse unsaved Changes] This opens a ChangeSorter on the ChangeSet that captures all the changes done to the Package since it was last saved. Therefore it shows the work done on the package that would be lost if the package is not saved. - -[Browse package code] This opens a Class Browser that only shows the code that belongs in the package. This is useful for working on a package, or studying it. - -[Add requirement] This opens a select list of loaded packages. Each package provides a Feature. You can CANCEL, require the current Cuis base version (at a minimum) or require any of the packages on the list. Required packages will be loaded before the selected package (Feature require: #'your-package'.). When a package is selected, the lower browser pane shows its requirents, which may be deleted. Don't forget to Save your package after adding or deleting requirements!! - -The tool shows, for each Package, the name, whether it is dirty (has unsaved changes) and the file it was installed from / saved to. - -Handling Packages like this, Cuis behaves as a sort of document editor (like, for example a regular text editor) whose documents are Package files (.pck.st). Cuis doesn't handle Package versions, ancestries, etc. If versioning of Packages is desired, the best is to use a versioning file repository, such as Git or Mercurial. The recommendation is to use a GitHub repository with a name beginning with 'Cuis-Smalltalk-', so it will be easy for anybody to find it. Cuis Package files are uncompressed, use Lf (ASCII 10) as newLine, and are encoded in ISO 8859-15. This means they are Git friendly, and Git/GitHub can diff and merge them, and browse them with syntax highlighting. - -This is not unlike using Git or GitHub with a file-based development environment such as Eclipse or a text editor. Like Cuis, these tools don't do version handling themselves, they just load and save files; and let Git do its magic. - - -Changes to the Cuis base image ------------------------------------------ - -The way ChangeSets are created and managed in Cuis is different from Squeak. This was done to make ChangeSets a good way to manage changes to the base Cuis Core image, while keeping code in Packages out of the way, so they don't get mixed together. - -What is not in a Package belongs (at least temporarily) to the Cuis Core image. Such code is automatically captured in a ChangeSet. The ChangeSet for Core changes is created automatically and named like '1243-CuisCore-JuanVuletich-2012Apr03-22h50m'. The number at the beginning is the next number for the Cuis update stream, and is provided only as a suggestion. The 'CuisCore' part is to reveal that the code belongs in the base image and not in some package. Then we have author name and date / time of creation. These ChangeSets are created automatically. There is no longer a way to manually create them, or make them 'current' or 'active'. It is best to rename them, replacing 'CuisCore' with some meaningful name. These ChangeSets will not capture any code that belongs in a Package. - -Opening a Change Sorter will show the CuisCore change set. This is useful, for example, to check that no code that was intended for a Package ends here by mistake (because of the wrong class or method category). But it is also useful when doing changes to the base system. Now, we can do changes both to the base system and to a number of packages, all in the same session, without having to be careful about selecting the proper change set before saving a method: The code is automatically added to the proper Package or ChangeSet, simply following the class or method category. Gone are the days of messed up change sets and lost code!! - -When the changes to the base system are complete, it is a good time to review the CuisCore change set and, maybe remove from it changes that we don't want to keep (for example, experiments, halts, etc). Then, just do right click / File out and remove. This saves the ChangeSet on disk. It also removes it from the ChangeSorter (but it doesn't remove any code). This is good, because the next changes done will end in a new CuisCore change set, and there's no risk of having undesired changes in the old one. As changes to the base image progress, and several CuisCore ChangeSets are saved to disk, these numbered files are created in sequence. They will be ready to be loaded back in proper order in a fresh Cuis image, or to be sent to Cuis maintainers for integration in the update stream and in next releases of Cuis. - -Installing ChangeSet files into Cuis - -[Install] loads all the code in the file into a separate, new ChangeSet object (viewable in the ChangeSorter tool). This is appropriate for loading Cuis updates, or other code that we are not authoring, as it doesn't add new items (class or method definitions) to the current ChangeSet used to record the changes we make to Cuis. Usually any ChangeSets should be installed before doing changes to the image. The reason is that an installed ChangeSet could overwrite changes done by you, or packages you have installed. If this is the case, the affected packages would appear as dirty, and your change set would include any installed changes (that don't belong in a package). Be careful when saving packages or change sets if this was the case!! - -Cherry picking individual changes from ChangeSet or Package files ------------------------------------------------------------------------------------ - -Additionally, you can study a Package (.pck.st) or ChangeSet (.cs) file without installing it. To do this, use the FileList, navigate to the appropriate directory, select the file and click on [Contents]. You will get a ChangeList tool with the contents of the file. You can select each change, to see the code, and compare it with what is currently loaded in the system (if that is the case). You can also various filters on the list. See the right-click menu. Once you have one or more changes selected, you can do right-click / 'fileIn selections'. Changes that belong in a package that is already there will be captured by that package, that will now be dirty. Code that doesn't belong in a loaded package will be included in the current ChangeSet, together with code you save in a Browser. A new Package or ChangeSet will not be created. This is especially useful when reviewing code, or when we are combining code from more than one source into a single ChangeSet or Package. -" - -" -Utilities codeManagementInCuisContents edit -"! ! -!Utilities class methodsFor: 'support windows' stamp: 'jmv 4/28/2020 10:14:31' prior: 16941308! - cuisAndGitHubContents - ^ self class firstCommentAt: #cuisAndGitHubContents - -" -Using Git and GitHub to host and manage Cuis code -=================================== - -(https://github.com/Cuis-Smalltalk/Cuis-Smalltalk-Dev/blob/master/Documentation/CuisAndGitHub.md) - -Cuis includes tools and procedures for managing Smalltalk code. Central to this is the management of Packages and Package Files (.pck). But Cuis doesn't do version control. Instead, we suggest using external VCS tools. In particular, we're using [GitHub](http://www.github.com/), and the first project we're hosting there is [StyledTextEditor](https://github.com/bpieber/Cuis-StyledTextEditor). - -The guiding principle is to *not duplicate concepts and behavior*. As we're using an external tool (Git) for version control, then we use it as it meant to be used. Most people use Git for version control and a file based IDE such as Eclipse for development. Such IDEs don't do version control themselves. It is done by Git. Do the same: do not include package version control in Cuis. This is a departure from the Monticello /Git integration (smallsource and MonticelloFileTree) by Otto Behrens, Dale Henrichs, etc. - -We use GitHub to host, version, diff and merge external packages (.pck files), i.e. code that is maintained independently and outside Cuis. - -Package files need to be simple text files. Cuis encoding for latin alphabet (ISO 8859-15) is handled without problems by GitHub. Cuis uses the LF (ascii code 10) newline convention, as preferred in GitHub. This allows Git/GitHub to diff versions, and merge branches. - -Each GitHub repository has one set of users and permissions. Each GitHub repository has one state (Git commits repositories, not individual files). Branch and merges are done on the whole repository and not on individual files. Therefore, we need a separate GitHub repository for each project, i.e., for each package or set of closely related packages that are always loaded and maintained together as a whole. - -Development process for External Packages --------------------------------------------------------- - -This is the suggested procedure for developing external packages. Usually do this every day. - -* Start with a standard (i.e. fresh) Cuis image. Never save the image. - -* Set up Git repositories for external packages (if not already done) - -* Install packages from Git repositories. - -* Develop. Modify and/or create packages. - -* Save own packages (to Git repositories). - -* Git add / commit / push as appropriate. - -* Fileout changes that are not part of any package. These are automatically captured in numbered changesets, separated from changes to packages. - -* Exit the image. Usually without saving. -" - -" -Utilities cuisAndGitHubContents edit -"! ! -!Utilities class methodsFor: 'support windows' stamp: 'jmv 4/28/2020 09:56:12' prior: 16941390! - openCodeManagementInCuis - " - Utilities openCodeManagementInCuis - " - - self codeManagementInCuisContents editLabel: 'Managing your code in Cuis'! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4125-UpdateInImageDocs-JuanVuletich-2020Apr28-09h56m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4125] on 28 April 2020 at 12:21:30 pm'! -!ChangeList class methodsFor: 'public access' stamp: 'jmv 4/28/2020 12:19:04' prior: 50499421! - browseRecentLogOn: origChangesFileEntry startingFrom: initialPos - "Prompt with a menu of how far back to go when browsing a changes file." - - | end banners positions pos chunk i | - origChangesFileEntry readStreamDo: [ :changesFile | - banners _ OrderedCollection new. - positions _ OrderedCollection new. - end _ changesFile size. - pos _ initialPos. - [pos = 0 - or: [banners size > 20]] "Go back at most 20 image exits" - whileFalse: [ - changesFile position: pos. - chunk _ changesFile nextChunk. - i _ chunk indexOfSubCollection: 'priorSource: ' startingAt: 1. - i > 0 - ifTrue: [ - positions addLast: pos. - banners addLast: (chunk copyFrom: 5 to: i - 2). - pos _ Number readFrom: (chunk copyFrom: i + 13 to: chunk size)] - ifFalse: [ - pos _ 0]]. - ]. - positions isEmpty - ifTrue: [ pos _ 0 ] - ifFalse: [ - positions addLast: 0. - banners addLast: 'Whole file'. - pos _ (SelectionMenu labelList: banners selections: positions) - startUpWithCaption: 'Browse as far back as...'. - pos - ifNil: [^ self]]. - self browseRecent: end - pos on: origChangesFileEntry! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4126-AvoidRecentChangesMenuIfUseless-JuanVuletich-2020Apr28-12h20m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4126] on 28 April 2020 at 3:39:34 pm'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4127-removeEmptyCategories-JuanVuletich-2020Apr28-15h39m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4120] on 26 April 2020 at 3:30:07 pm'! - -"Change Set: 4121-CuisCore-AuthorName-2020Apr24-20h33m -Date: 26 April 2020 -Author: Nahuel Garbezza - -Changes on Extract Temporary refactoring: - -* make sure it is not possible to extract the left side of an assignment -* allow to extract cascade expressions -* allow to extract entire blocks into variables -* validate new temporary is not a reserved name - -Changes on Extract Method refactoring: - -* solve bug where 2 statements (one being a block) could not be extracted - -Changes on Rename Temporary refactoring: - -* validate new temporary is not a reserved name"! - -Refactoring subclass: #ExtractToTemporary - instanceVariableNames: 'newVariableName parseNodeToExtract methodNodeToRefactor methodToRefactor updatedSourceCode intervalToExtract sourceCodeToExtract parseNodeWithNewVariableScope ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractToTemporary category: #'Tools-Refactoring' stamp: 'Install-4128-ExtractToTemporaryRefactoring-NahuelGarbezza-2020Apr24-20h33m-RNG.001.cs.st 5/26/2020 17:08:32'! -Refactoring subclass: #ExtractToTemporary - instanceVariableNames: 'newVariableName parseNodeToExtract methodNodeToRefactor methodToRefactor updatedSourceCode intervalToExtract sourceCodeToExtract parseNodeWithNewVariableScope' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!ParseNode methodsFor: 'testing' stamp: 'RNG 4/25/2020 13:17:19'! - isCascadeNode - - ^ false! ! -!CascadeNode methodsFor: 'testing' stamp: 'RNG 4/25/2020 13:17:36' overrides: 50507189! - equivalentTo: aParseNode - - ^ aParseNode isCascadeNode - and: [ receiver equivalentTo: aParseNode receiver ] - and: [ self hasEquivalentMessagesWith: aParseNode ]! ! -!CascadeNode methodsFor: 'testing' stamp: 'RNG 4/25/2020 13:17:44'! - hasEquivalentMessagesWith: aCascadeNode - - messages with: aCascadeNode messages do: [ :myMessage :otherNodeMessage | - (myMessage equivalentTo: otherNodeMessage) ifFalse: [ ^ false ] ]. - ^ true! ! -!CascadeNode methodsFor: 'testing' stamp: 'RNG 4/25/2020 13:17:29' overrides: 50508641! - isCascadeNode - - ^ true! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 4/24/2020 20:42:39'! - findSourceRangeOfCloserStatementIn: listOfAncestors - - ^ (listOfAncestors - detect: [ :assoc | assoc key isBlockNode ] - ifFound: [ :assoc | listOfAncestors before: assoc ifNone: [ listOfAncestors last ] ] - ifNone: [ listOfAncestors last ]) value! ! -!ExtractToTemporary class methodsFor: 'private - preconditions' stamp: 'RNG 4/25/2020 13:20:06'! - assert: anIntervalToExtract enclosesACompleteExpressionOn: aMethodToRefactor - - (self anySourceRangeOf: aMethodToRefactor matches: anIntervalToExtract) - ifFalse: [ self signalSourceCodeSelectionIncludesAnInvalidExpression ]! ! -!ExtractToTemporary class methodsFor: 'private - preconditions' stamp: 'RNG 4/25/2020 13:20:22'! - assert: anIntervalToExtract enclosesAValidNodeOn: aMethodToRefactor - - (self parseNodeUnder: anIntervalToExtract canBeExtractedToAVariableOn: aMethodToRefactor) - ifFalse: [ self signalSourceCodeSelectionIncludesAnInvalidExpression ]! ! -!ExtractToTemporary class methodsFor: 'private - preconditions' stamp: 'RNG 4/25/2020 13:20:32'! - parseNodeUnder: anIntervalToExtract canBeExtractedToAVariableOn: aMethodToRefactor - - aMethodToRefactor methodNode completeSourceRangesDo: [ :parseNode :sourceRanges | - (parseNode isAssignmentNode - and: [ sourceRanges anySatisfy: [ :sourceRange | sourceRange first = anIntervalToExtract first ] ]) - ifTrue: [ ^ false ] - ]. - ^ true! ! -!NewTemporaryPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 4/26/2020 15:16:59'! - assertIsNotAReservedName - - (ClassBuilder reservedNames includes: newTemporaryVariableName) - ifTrue: [ self signalNewTemporaryVariableCanNotBeAReservedName ]! ! -!NewTemporaryPrecondition methodsFor: 'exceptions' stamp: 'RNG 4/26/2020 15:19:20'! - signalNewTemporaryVariableCanNotBeAReservedName - - self refactoringError: ( - self class errorMessageForNewTemporaryVariableCanNotBeAReservedName: newTemporaryVariableName)! ! -!NewTemporaryPrecondition class methodsFor: 'error messages' stamp: 'RNG 4/26/2020 15:19:20'! - errorMessageForNewTemporaryVariableCanNotBeAReservedName: aName - - ^ '''', aName, ''' can not be used as temporary variable name because it is a reserved name'! ! -!Encoder methodsFor: 'source mapping' stamp: 'RNG 4/25/2020 12:51:38' prior: 50488539! - completeSourceRangesBasedOn: sourceCode - - | completeSourceRanges | - completeSourceRanges _ Dictionary new. - sourceRanges keysAndValuesDo: [ :parseNode :nodeRanges | - "leaf nodes excluded because they have the same complete source ranges than the block nodes they wrap - Nahuel" - parseNode class = LeafNode ifFalse: [ - | expandedNodeSourceRanges | - expandedNodeSourceRanges _ parseNode expandRanges: nodeRanges basedOn: sourceRanges using: sourceCode. - completeSourceRanges at: parseNode put: expandedNodeSourceRanges ] ]. - ^ completeSourceRanges! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 4/25/2020 12:54:00' prior: 50505495! - intervalMatchesBeginningOfStatement - - ^ (self findSourceRangeOfCloserStatementIn: initialNodeAncestors) first = intervalToExtract first! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 4/24/2020 20:37:59' prior: 50505504! - intervalMatchesEndOfStatement - - ^ (self findSourceRangeOfCloserStatementIn: finalNodeAncestors) last = intervalToExtract last! ! -!ExtractToTemporary class methodsFor: 'preconditions' stamp: 'RNG 4/25/2020 13:21:54' prior: 50507702! - assertCanApplyRefactoringOn: aMethodToRefactor at: anIntervalToExtract - - | trimmedSourceCodeToExtract methodNodeToExtract sourceCodeToExtract trimmedIntervalToExtract originalSourceCode | - - self assert: anIntervalToExtract isValidIntervalOn: aMethodToRefactor. - originalSourceCode := aMethodToRefactor sourceCode. - sourceCodeToExtract := originalSourceCode copyFrom: anIntervalToExtract first to: anIntervalToExtract last. - trimmedSourceCodeToExtract := sourceCodeToExtract withBlanksTrimmed. - trimmedIntervalToExtract := Refactoring trim: anIntervalToExtract toMatchExpressionOn: originalSourceCode. - self assertSourceCodeIsNotEmpty: trimmedSourceCodeToExtract. - methodNodeToExtract := self tryToParse: trimmedSourceCodeToExtract on: aMethodToRefactor methodClass. - self - assertHasOneStatement: methodNodeToExtract; - assertIsNotReturn: trimmedSourceCodeToExtract; - assert: trimmedIntervalToExtract enclosesACompleteExpressionOn: aMethodToRefactor; - assert: trimmedIntervalToExtract enclosesAValidNodeOn: aMethodToRefactor! ! -!ExtractToTemporary class methodsFor: 'private - parsing' stamp: 'RNG 4/25/2020 12:54:15' prior: 50507014! - methodOrBlockNodeIncluding: anIntervalToExtract in: methodNodeToRefactor - "Finds the appropriate block node to define a variable that will reference the code in the interval to extract. - The possibles results are the top-level methodNode or a block node inside some of the method statements." - - methodNodeToRefactor completeSourceRangesDo: [ :parseNode :sourceRanges | - (parseNode isBlockNode - and: [ parseNode ~= methodNodeToRefactor block ] - and: [ sourceRanges anySatisfy: [ :sourceRange | - sourceRange first < anIntervalToExtract first and: [ sourceRange last > anIntervalToExtract last ] ] ]) - ifTrue: [ ^ parseNode ] - ]. - ^ methodNodeToRefactor! ! -!NewTemporaryPrecondition methodsFor: 'evaluating' stamp: 'RNG 4/26/2020 15:14:43' prior: 50497332 overrides: 50497302! - value - - self - assertIsNotEmpty; - assertIsValidVariableName; - assertIsNotAReservedName; - assertIsNotDefinedAsInstanceVariableInHierarchyOfMethodClass; - assertIsNotDeclaredInParentsOrChildrenScopes! ! - -NewTemporaryPrecondition removeSelector: #signalNewInstanceVariableCanNotBeAReservedName! - -ExtractToTemporary class removeSelector: #assert:enclosesAValidExpressionOn:! - -!methodRemoval: ExtractToTemporary class #assert:enclosesAValidExpressionOn: stamp: 'Install-4128-ExtractToTemporaryRefactoring-NahuelGarbezza-2020Apr24-20h33m-RNG.001.cs.st 5/26/2020 17:08:32'! -assert: anIntervalToExtract enclosesAValidExpressionOn: aMethodToRefactor - - (self anySourceRangeOf: aMethodToRefactor matches: anIntervalToExtract) - ifFalse: [ self signalSourceCodeSelectionIncludesAnInvalidExpression ]! - -ExtractMethodExpressionValidation removeSelector: #findSourceRangeOfNextStatementIn:! - -!methodRemoval: ExtractMethodExpressionValidation #findSourceRangeOfNextStatementIn: stamp: 'Install-4128-ExtractToTemporaryRefactoring-NahuelGarbezza-2020Apr24-20h33m-RNG.001.cs.st 5/26/2020 17:08:32'! -findSourceRangeOfNextStatementIn: listOfAncestors - - ^ listOfAncestors - detect: [ :assoc | assoc key isBlockNode or: [ assoc key class = LeafNode ] ] - ifFound: [ :assoc | - (listOfAncestors at: (listOfAncestors indexOf: assoc) - 1) value ] - ifNone: [ listOfAncestors last value ]! - -Refactoring subclass: #ExtractToTemporary - instanceVariableNames: 'newVariableName methodNodeToRefactor methodToRefactor updatedSourceCode intervalToExtract sourceCodeToExtract parseNodeWithNewVariableScope' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractToTemporary category: #'Tools-Refactoring' stamp: 'Install-4128-ExtractToTemporaryRefactoring-NahuelGarbezza-2020Apr24-20h33m-RNG.001.cs.st 5/26/2020 17:08:32'! -Refactoring subclass: #ExtractToTemporary - instanceVariableNames: 'newVariableName methodNodeToRefactor methodToRefactor updatedSourceCode intervalToExtract sourceCodeToExtract parseNodeWithNewVariableScope' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4128-ExtractToTemporaryRefactoring-NahuelGarbezza-2020Apr24-20h33m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4109] on 2 May 2020 at 12:13:20 am'! - -Object subclass: #Refactoring - instanceVariableNames: '' - classVariableNames: 'AllowedToRefactorClassCompilers ' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #Refactoring category: #'Tools-Refactoring' stamp: 'Install-4129-RefactoringCheckForCompilerClass-HernanWilkinson-2020Apr23-16h31m-HAW.001.cs.st 5/26/2020 17:08:32'! -Object subclass: #Refactoring - instanceVariableNames: '' - classVariableNames: 'AllowedToRefactorClassCompilers' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!Refactoring class methodsFor: 'testing' stamp: 'HAW 5/1/2020 23:58:00'! - canRefactor: aPotentialClassToRefactor - - ^self allowedToRefactorClassCompilersIncludes: aPotentialClassToRefactor compilerClass! ! -!Refactoring class methodsFor: 'allowed to refactor class compilers' stamp: 'HAW 5/2/2020 00:03:05'! - addAllowedToRefactorClassCompiler: aCompiler - - self allowedToRefactorClassCompilers add: aCompiler ! ! -!Refactoring class methodsFor: 'allowed to refactor class compilers' stamp: 'HAW 5/1/2020 23:59:39'! - allowedToRefactorClassCompilers - - AllowedToRefactorClassCompilers ifNil: [ - AllowedToRefactorClassCompilers := Set with: Compiler ]. - - ^AllowedToRefactorClassCompilers! ! -!Refactoring class methodsFor: 'allowed to refactor class compilers' stamp: 'HAW 5/1/2020 23:58:58'! - allowedToRefactorClassCompilersIncludes: aCompiler - - ^self allowedToRefactorClassCompilers includes: aCompiler ! ! -!ChangeSelector class methodsFor: 'implementors and senders' stamp: 'HAW 5/1/2020 23:55:29' prior: 50499290! -addImplementorsOf: anOldSelector to: implementors andSendersTo: senders of: aPotentialClassToRefactor - - | potentialImplementor | - - "Phil B. requested to avoid refactoring OMeta2 classes, so right now - it avoids implementors and senders whose compilerClass is not register - as allowed compiler - Hernan" - (self canRefactor: aPotentialClassToRefactor) ifFalse: [ ^self ]. - - potentialImplementor := aPotentialClassToRefactor compiledMethodAt: anOldSelector ifAbsent: [ nil ]. - potentialImplementor ifNotNil: [ implementors add: potentialImplementor ]. - - (aPotentialClassToRefactor whichSelectorsReferTo: anOldSelector) do: [ :aSelector | - senders add: (MethodReference class: aPotentialClassToRefactor selector: aSelector) ]! ! - -Object subclass: #Refactoring - instanceVariableNames: '' - classVariableNames: 'AllowedToRefactorClassCompilers' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #Refactoring category: #'Tools-Refactoring' stamp: 'Install-4129-RefactoringCheckForCompilerClass-HernanWilkinson-2020Apr23-16h31m-HAW.001.cs.st 5/26/2020 17:08:33'! -Object subclass: #Refactoring - instanceVariableNames: '' - classVariableNames: 'AllowedToRefactorClassCompilers' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4129-RefactoringCheckForCompilerClass-HernanWilkinson-2020Apr23-16h31m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4129] on 2 May 2020 at 12:48:49 pm'! -!Interval methodsFor: 'testing' stamp: 'HAW 5/2/2020 11:53:30' prior: 50464399 overrides: 16906982! - includes: aNumber - - | index | - - aNumber isNumber ifFalse: [ ^ false ]. - - ^ start = stop - ifTrue: [ start = aNumber ] - ifFalse: [ - index := (aNumber - start) / (stop-start) * (count-1) + 1. - index isInteger and: [ index between: 1 and: count ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4130-IntervalIncludes-HernanWilkinson-2020May02-11h21m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4129] on 2 May 2020 at 12:49:24 pm'! -!NewInstanceVariablePrecondition methodsFor: 'pre-conditions' stamp: 'HAW 5/2/2020 12:48:57' prior: 50482540! - assertIsNotAlreadyDefinedInSuperclasses - - ^ (classToAddInstVar classThatDefinesInstanceVariable: instVarName) - ifNotNil: [ :definingClass | self signalAlreadyDefinedInAll: {definingClass} ] - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4131-NewInstanceVariablePreconditionFix-HernanWilkinson-2020May02-12h48m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4129] on 3 May 2020 at 2:02:23 am'! - -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser selectorsClasses possibleInvalidSelectors canShowSelectorDocumentation possibleBinarySendRange' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #SmalltalkCompleter category: #'Tools-Autocompletion' stamp: 'Install-4132-AutoCompleterImprovement-HernanWilkinson-2020May02-18h09m-HAW.001.cs.st 5/26/2020 17:08:33'! -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser selectorsClasses possibleInvalidSelectors canShowSelectorDocumentation possibleBinarySendRange' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! -!SequenceableCollection methodsFor: 'accessing' stamp: 'HAW 5/3/2020 00:48:51'! - antepenultimate - - ^self antepenultimateIfAbsent: [ self errorCollectionTooSmall ]! ! -!SequenceableCollection methodsFor: 'accessing' stamp: 'HAW 5/3/2020 00:47:42'! - antepenultimateIfAbsent: aBlock - - | size | - - size := self size. - size >= 3 ifTrue: [ ^self at: size - 2 ]. - ^aBlock value! ! -!SequenceableCollection methodsFor: 'accessing' stamp: 'HAW 5/3/2020 00:39:34'! - penultimateIfAbsent: aBlock - - | size | - - size := self size. - size >= 2 ifTrue: [ ^self at: size-1 ]. - ^aBlock value! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 5/3/2020 01:42:05'! - possibleBinarySendRangeFrom: allRanges - - | penultimate antepenultimate | - - penultimate := allRanges penultimateIfAbsent: [ SHRange nilObject ]. - antepenultimate := allRanges antepenultimateIfAbsent: [ SHRange nilObject ]. - - possibleBinarySendRange _ penultimate rangeType = #arrayStart - ifTrue: [ antepenultimate rangeType = #symbol - ifTrue: [ allRanges at: allRanges size - 3 ifAbsent: [ SHRange nilObject ] ]] - ifFalse: [ - ({#leftBrace. #'$'. #symbol. #blockStart. } includes: penultimate rangeType) - ifTrue: [ antepenultimate ] - ifFalse: [ penultimate ]]! ! -!SmalltalkCompleter class methodsFor: 'accessing' stamp: 'HAW 5/2/2020 20:47:22'! - changeEntriesLimitTo: aNewLimit during: aBlock - - | previousLimit | - - previousLimit := EntriesLimit. - EntriesLimit := aNewLimit. - - ^aBlock ensure: [ EntriesLimit := previousLimit ]! ! -!SHParserST80 methodsFor: 'accessing' stamp: 'HAW 5/3/2020 00:14:19'! - rangesWithoutExcessCode - - ^ranges - ifEmpty: [ ranges ] - ifNotEmpty: [ - ranges last rangeType = #excessCode - ifTrue: [ ranges allButLast ] - ifFalse: [ ranges ]]! ! -!SHParserST80 methodsFor: 'testing' stamp: 'HAW 5/3/2020 00:27:29'! - isIdentifier: aSymbol - - ^ #(#incompleteIdentifier - #blockTempVar #blockArg #tempVar #methodArg - #instVar #classVar - #workspaceVar #poolConstant #globalVar ) statePointsTo:aSymbol! ! -!SHParserST80 methodsFor: 'testing' stamp: 'HAW 5/3/2020 00:27:56'! - isReservedName: aSymbol - - ^ self reservedNames statePointsTo: aSymbol! ! -!SHRange class methodsFor: 'instance creation' stamp: 'HAW 5/3/2020 01:10:44'! - nilObject - - "I can not reference self inside backtick - Hernan" - ^`SHRange start: 0 end: 0 type: nil`! ! -!SequenceableCollection methodsFor: 'accessing' stamp: 'HAW 5/3/2020 00:42:09' prior: 50419380! - penultimate - "Answer the penultimate element of the receiver. - Raise an error if the collection is empty or has just one element." - - ^self penultimateIfAbsent: [self errorCollectionTooSmall]. -! ! -!SmalltalkCompleter methodsFor: 'entries' stamp: 'HAW 5/3/2020 01:41:33' prior: 50480469 overrides: 16781250! - computeEntries - - | allSource contextClass specificModel allRanges range | - - allSource _ model actualContents string. - specificModel _ self textProviderOrModel. - contextClass _ self selectedClassOrMetaClassIn: specificModel. - allRanges _ self parse: allSource in: contextClass and: specificModel. - range _ allRanges ifEmpty: [ ^entries _ #() ] ifNotEmpty: [ allRanges last ]. - possibleInvalidSelectors _ #(). - - range end = position - ifTrue: [ self computeEntriesOfMessageOrIdentifiersFor: allSource using: allRanges at: range in: contextClass and: specificModel ] - ifFalse: [ self computeMessageEntriesWithEmptyPrefixFor: allSource using: allRanges at: range in: contextClass and: specificModel ]. - - ! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 5/3/2020 01:09:40' prior: 50480152! - canComputeMessageEntriesFor: prevRange - - ^ prevRange rangeType notNil ! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 5/3/2020 00:15:12' prior: 50414959! - computeEntriesOfMessageOrIdentifiersFor: allSource using: allRanges at: range in: contextClass and: specificModel - - prefix _ allSource copyFrom: range start to: range end. - (parser isMessage: range rangeType) ifTrue: [ - ^self computeMessageEntriesWhenSendinMessageFor: allSource using: allRanges in: contextClass and: specificModel ]. - (parser isPartialOrFullIdentifier: range rangeType) ifTrue: [ ^self computeIdentifierEntries ]. - - "If we don't know what to do, do nothing" - entries _ #() ! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 5/3/2020 00:14:30' prior: 50485648! - parse: allSource in: contextClass and: specificModel - - | isMethod | - - parser _ SHParserST80 new. - parser - workspace: ((specificModel is: #providesBindings) ifTrue: [specificModel]); - classOrMetaClass: contextClass; - source: (allSource copyFrom: 1 to: position); - allSource: allSource. - - isMethod := (specificModel is: #Browser) - ifTrue: [ specificModel isEditingClass not ] - ifFalse: [ specificModel is: #CodeProvider ]. - parser parse: isMethod. - - ^ parser rangesWithoutExcessCode. -! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 5/3/2020 01:41:14' prior: 50483529! - computeMessageEntriesWhenSendinMessageFor: allSource using: allRanges in: contextClass and: specificModel - - | prevRange | - - "If previous range is a constant or a well known identifier, we might filter messages" - prevRange _ allRanges penultimateIfAbsent: [ SHRange nilObject ]. - possibleBinarySendRange _ allRanges antepenultimateIfAbsent: [ SHRange nilObject ]. - - ^ (self canComputeMessageEntriesFor: prevRange) - ifTrue: [ self computeMessageEntriesFor: allSource at: prevRange in: contextClass and: specificModel ] - ifFalse: [ self computeMessageEntriesForUnknowClass ] -! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 5/3/2020 00:58:01' prior: 50483549! - computeMessageEntriesWithEmptyPrefixFor: allSource using: allRanges at: range in: contextClass and: specificModel - - self possibleBinarySendRangeFrom: allRanges. - prefix _ ''. - - self computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel .! ! -!SHParserST80 methodsFor: 'testing' stamp: 'HAW 5/3/2020 00:28:13' prior: 50368740! - isPartialOrFullIdentifier: aSymbol - - ^(self isIdentifier: aSymbol) or: [ self isReservedName: aSymbol ]! ! - -SHParserST80 removeSelector: #isPartialIdentifier:! - -SmalltalkCompleter removeSelector: #initialize! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4132-AutoCompleterImprovement-HernanWilkinson-2020May02-18h09m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4127] on 4 May 2020 at 4:40:37 pm'! -!QSystemTally methodsFor: 'report' stamp: 'jmv 5/4/2020 16:31:25' prior: 50378341 overrides: 16897317! - printOn: textStream linesOn: linesStream talliesOn: talliesStreams tabs: tabsAndTreeLines total: total totalTime: totalTime parent: parentTally - - | aSelector aClass percentage line | - line _ String streamContents: [ :lineStream | - tabsAndTreeLines do: [ :tabOrLineChar | lineStream nextPutAll: tabOrLineChar ]. - percentage _ tally asFloat / total * 100.0. - percentage printOn: lineStream fractionDigits: 2. - lineStream nextPutAll: '% ('. - percentage * totalTime / 100 printOn: lineStream fractionDigits: 1. - lineStream nextPutAll: ' ms) '. - aSelector _ class selectorAtMethod: method setClass: [ :c | aClass _ c]. - blockNesting > 0 ifTrue: [ - lineStream - next: blockNesting put: $[; - next: blockNesting put: $]; - space ]. - lineStream - nextPutAll: class name; - nextPutAll: (aClass == class - ifTrue: ['>>'] - ifFalse: ['(' , aClass name , ')>>']); - nextPutAll: aSelector. - wasInPrimitive ifTrue: [ - self flag: #profilerFriendlyCall:. - parentTally methodSymbol == #profilerFriendlyCall: - ifTrue: [ - lineStream nextPutAll: ' -- primitive (reported properly)' ] - ifFalse: [ - lineStream nextPutAll: ' -- primitive (real sender possibly omitted, see #profilerFriendlyCall:)' ] - ]. - ]. - textStream nextPutAll: line; newLine. - linesStream nextPut: line. - talliesStreams nextPut: self! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4133-MessageTally-fix-JuanVuletich-2020May04-16h31m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #3866] on 1 May 2020 at 4:43:58 pm'! -!EventSensor methodsFor: 'private-I/O' stamp: 'tg 5/1/2020 13:21:30' prior: 16839672! - processSensorEvent: evt discardingMouseEvents: discardMouseEvents - "Process a single event. This method is run at high priority." - | type | - type _ evt at: 1. - - "Check if the event is a user interrupt" - (type = EventSensor eventTypeKeyboard and: [ (evt at: 4) = 0 and: [ - ((evt at: 3) bitOr: (((evt at: 5) bitAnd: 8) bitShift: 8)) = interruptKey]]) - ifTrue: [ - "interrupt key is meta - not reported as event" - ^interruptSemaphore signal]. - - "Store the event in the queue if there's any" - type = EventSensor eventTypeMouse ifTrue: [ - "Only swap secondary and tertiary buttons if there is no command or option modifier keys. - This swap is done so a 3-button mouse is - left -> mouseButton1 (select) - center -> mouseButton3 (halo) - right -> mouseButton2 (menu). - This is only needed on the Mac, Window VM does this mapping by default. - We avoid ding the swap if there are modifier keys, because in that case the buttons were generated by the VM as follows: - left -> mouseButton1 - macOption + left -> mouseButton3 - command + left -> mouseButton2, - but Mac users are already used to - macOption + left -> menu - command + left -> halo. - See #installMouseDecodeTable" - ((evt at: 6) anyMask: 12) ifFalse: [ - evt at: 5 put: (ButtonDecodeTable at: (evt at: 5) + 1)]]. - - (discardMouseEvents and: [ type = EventSensor eventTypeMouse ]) ifFalse: [ - self queueEvent: evt ]. - - "Update state for InputSensor." - type = EventSensor eventTypeMouse ifTrue: [ - self processMouseSensorEvent: evt ]. - type = EventSensor eventTypeKeyboard ifTrue: [ - self processKeyboardSensorEvent: evt ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4134-FixInterruptKeyForFrenchKeyboard-ThierryGoubier-2020May01-13h21m-tg.1.cs.st----! - -'From Cuis 5.0 [latest update: #4134] on 6 May 2020 at 12:17:40 pm'! -!SystemWindow methodsFor: 'label' stamp: 'len 5/1/2020 06:34:51' prior: 50471991! - labelHeight - "Answer the height for the window label." - Theme current minimalWindows ifTrue: [^ 0]. - ^ Preferences windowTitleFont lineSpacing+1! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4135-minimalWindows-fix-LucianoEstebanNotarfrancesco-2020May06-12h17m-len.001.cs.st----! - -'From Cuis 5.0 [latest update: #4132] on 3 May 2020 at 3:16:45 pm'! -!BoxedFloat64 methodsFor: 'printing' stamp: 'HAW 5/3/2020 15:05:51' overrides: 50418767! - storeOn: aStream base: base - - self isFinite - ifTrue: [ super storeOn: aStream base: base ] - ifFalse: [ self isNaN - ifTrue: [aStream nextPutAll: 'Float nan'] - ifFalse: [self > 0.0 - ifTrue: [aStream nextPutAll: 'Float infinity'] - ifFalse: [aStream nextPutAll: 'Float infinity negated']]]! ! -!Float methodsFor: 'printing' stamp: 'HAW 5/3/2020 15:06:05' prior: 50418767 overrides: 16880428! - storeOn: aStream base: base - - "Print the Number exactly so it can be interpreted back unchanged" - - self sign = -1 ifTrue: [aStream nextPutAll: '-']. - base = 10 ifFalse: [aStream print: base; nextPut: $r]. - self isZero - ifTrue: [aStream nextPutAll: '0.0'] - ifFalse: [self abs absPrintExactlyOn: aStream base: base]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4136-FloatStoreOnImprovement-HernanWilkinson-2020May03-12h35m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4132] on 6 May 2020 at 11:46:42 pm'! - -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser selectorsClasses possibleInvalidSelectors canShowSelectorDocumentation possibleBinarySendRange allRanges ' - classVariableNames: 'AccessLock EntriesLimit Selectors ' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #SmalltalkCompleter category: #'Tools-Autocompletion' stamp: 'Install-4137-AutoCompleteImprovements-HernanWilkinson-2020May03-15h16m-HAW.001.cs.st 5/26/2020 17:08:33'! -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser selectorsClasses possibleInvalidSelectors canShowSelectorDocumentation possibleBinarySendRange allRanges' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -Object subclass: #SHParserST80 - instanceVariableNames: 'classOrMetaClass source workspace arguments sourcePosition currentToken currentTokenFirst temporaries instanceVariables errorBlock currentTokenSourcePosition blockDepth bracketDepth ranges blockDepths blockDepthsStartIndexes allSource braceDepth ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -!classDefinition: #SHParserST80 category: #'Tools-Syntax Highlighting' stamp: 'Install-4137-AutoCompleteImprovements-HernanWilkinson-2020May03-15h16m-HAW.001.cs.st 5/26/2020 17:08:33'! -Object subclass: #SHParserST80 - instanceVariableNames: 'classOrMetaClass source workspace arguments sourcePosition currentToken currentTokenFirst temporaries instanceVariables errorBlock currentTokenSourcePosition blockDepth bracketDepth ranges blockDepths blockDepthsStartIndexes allSource braceDepth' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! -!SequenceableCollection methodsFor: 'accessing' stamp: 'HAW 5/4/2020 00:39:03'! - lastIfEmpty: aBlock - - ^self ifEmpty: aBlock ifNotEmpty: [ self at: self size ]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 5/4/2020 02:07:45'! - computeEntriesOfMessageOrIdentifiersFor: allSource at: range in: contextClass and: specificModel - - prefix _ allSource copyFrom: range start to: range end. - (parser isMessage: range rangeType) ifTrue: [ - ^self computeMessageEntriesWhenSendinMessageFor: allSource in: contextClass and: specificModel ]. - (parser isPartialOrFullIdentifier: range rangeType) ifTrue: [ ^self computeIdentifierEntries ]. - - "If we don't know what to do, do nothing" - entries _ #() ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 5/4/2020 15:42:32'! - computeMessageEntriesWhenSendinMessageFor: allSource in: contextClass and: specificModel - - | lastRange | - - allRanges removeLast. - lastRange _ allRanges lastIfEmpty: [ SHRange nilObject ]. - possibleBinarySendRange _ self lookForBinarySendRange. - - ^ (self canComputeMessageEntriesFor: lastRange) - ifTrue: [ self computeMessageEntriesFor: allSource at: lastRange in: contextClass and: specificModel ] - ifFalse: [ self computeMessageEntriesForUnknowClass ] -! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 5/4/2020 15:42:32'! - computeMessageEntriesWithEmptyPrefixFor: allSource at: range in: contextClass and: specificModel - - possibleBinarySendRange _ self lookForBinarySendRange. - prefix _ ''. - - self computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel .! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 5/4/2020 15:49:19'! - lookForBinarySelectorAfter: aStopToken startingAt: anIndex with: aCandidate - - | currentRange currentIndex | - - currentIndex := anIndex. - [ currentRange := allRanges at: currentIndex. - currentRange rangeType ~= aStopToken and: [ currentIndex > 1 ]] whileTrue: [ currentIndex := currentIndex - 1 ]. - - ^currentIndex > 1 - ifTrue: [ allRanges at: currentIndex - 1 ] - ifFalse: [ aCandidate ]. -! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 5/4/2020 15:43:49'! - lookForBinarySelectorAfterArrayStartStartingAt: anIndex with: aCandidate - - | foundRange foundRangeIndex | - - foundRange := self lookForBinarySelectorAfter: #arrayStart startingAt: anIndex with: aCandidate. - - ^foundRange rangeType = #symbol - ifTrue: [ - foundRangeIndex := allRanges indexOf: foundRange. - allRanges at: foundRangeIndex - 1 ifAbsent: [ aCandidate ]] - ifFalse: [ aCandidate ]! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 5/4/2020 15:45:27'! - lookForBinarySendRange - - | penultimate currentIndex currentRangeType | - - currentIndex := self lookForNoUnaryMessageSend. - penultimate := allRanges at: currentIndex - 1 ifAbsent: [ SHRange nilObject ]. - - currentRangeType := (allRanges at: currentIndex) rangeType. - currentRangeType = #rightParenthesis ifTrue: [ - ^self lookForBinarySelectorAfter: #leftParenthesis startingAt: currentIndex with: penultimate ]. - currentRangeType = #rightBrace ifTrue: [ - ^self lookForBinarySelectorAfter: #leftBrace startingAt: currentIndex with: penultimate ]. - currentRangeType = #blockEnd ifTrue: [ - ^self lookForBinarySelectorAfter: #blockStart startingAt: currentIndex with: penultimate ]. - currentRangeType = #arrayEnd ifTrue: [ - ^self lookForBinarySelectorAfterArrayStartStartingAt: currentIndex with: penultimate ]. - - ^({#'$'. #symbol} includes: penultimate rangeType) - ifTrue: [ allRanges at: currentIndex - 2 ifAbsent: [ SHRange nilObject ] ] - ifFalse: [ penultimate ]! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 5/4/2020 15:46:02'! - lookForNoUnaryMessageSend - - | currentIndex currentRangeType | - - currentIndex := allRanges size. - [ currentRangeType := (allRanges at: currentIndex) rangeType. - currentRangeType = #unary and: [ currentIndex > 1 ]] whileTrue: [ currentIndex := currentIndex - 1 ]. - - ^currentIndex! ! -!SmalltalkCompleter methodsFor: 'entries' stamp: 'HAW 5/4/2020 02:09:47' prior: 50509160 overrides: 16781250! - computeEntries - - | allSource contextClass specificModel range | - - allSource _ model actualContents string. - specificModel _ self textProviderOrModel. - contextClass _ self selectedClassOrMetaClassIn: specificModel. - allRanges _ self parse: allSource in: contextClass and: specificModel. - "For debugging porpouses: - allRanges collect: [ :r | r rangeType ] - " - range _ allRanges lastIfEmpty: [ ^entries _ #() ]. - possibleInvalidSelectors _ #(). - - range end = position - ifTrue: [ self computeEntriesOfMessageOrIdentifiersFor: allSource at: range in: contextClass and: specificModel ] - ifFalse: [ self computeMessageEntriesWithEmptyPrefixFor: allSource at: range in: contextClass and: specificModel ]. - - ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 5/4/2020 16:06:03' prior: 50483350! - computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel - - | id rangeType | - - canShowSelectorDocumentation _ true. - id _ allSource copyFrom: range start to: range end. - rangeType _ range rangeType. - - rangeType == #globalVar - ifTrue: [ ^self computeMessageEntriesForClass: (Smalltalk at: id asSymbol) class ]. - rangeType == #self - ifTrue: [ ^self computeMessageEntriesForClass: contextClass ]. - rangeType == #super - ifTrue: [ ^self computeMessageEntriesForClass: contextClass superclass ]. - rangeType == #true - ifTrue: [ ^self computeMessageEntriesForClass: True ]. - rangeType == #false - ifTrue: [ ^self computeMessageEntriesForClass: False ]. - rangeType == #nil - ifTrue: [ ^self computeMessageEntriesForClass: UndefinedObject ]. - rangeType == #character - ifTrue: [ ^self computeMessageEntriesForClass: id first class ]. - rangeType == #number - ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #string - ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #symbol - ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #stringSymbol - ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #instVar - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofInstVarNamed: id ]. - rangeType == #methodArg - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofTempVarNamed: id ]. - rangeType == #tempVar - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofTempVarNamed: id ]. - rangeType == #blockArg - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofBlockArgNamed: id ]. - rangeType == #blockTempVar - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofBlockTempVarNamed: id ]. - rangeType == #workspaceVar - ifTrue: [ ^self computeMessageEntriesForClassOrNil: (specificModel classOfWorkspaceVarNamed: id) ]. - rangeType == #thisContext - ifTrue: [ ^self computeMessageEntriesForClass: (specificModel classOfThisContext) ]. - rangeType == #classVar - ifTrue: [ ^self computeMessageEntriesForClassOrNil: (self classOfLocalBindingNamed: id in: contextClass) ]. - rangeType == #poolConstant - ifTrue: [ ^self computeMessageEntriesForClassOrNil: (self classOfLocalBindingNamed: id in: contextClass) ]. - (rangeType beginsWith: #blockEnd) - ifTrue: [ ^self computeMessageEntriesForClass: BlockClosure ]. - rangeType == #arrayEnd - ifTrue: [ ^self computeMessageEntriesForClass: Array ]. - (rangeType beginsWith: #rightBrace) - ifTrue: [ ^self computeMessageEntriesForClass: Array ]. - rangeType == #unary - ifTrue: [ ^self computeEntriesOfUnaryMessageReturnNamed: id at: range ]. - (rangeType beginsWith: #rightParenthesis) - ifTrue: [ ^self computeMessageEntriesOfEnclosedExpressionReturnAt: range ]. - rangeType == #cascadeSeparator - ifTrue: [ ^self computeMessageEntriesOfCascadeReceiverAt: range ]. - - self computeMessageEntriesForUnknowClass - - ! ! -!SHParserST80 methodsFor: 'parse' stamp: 'HAW 5/3/2020 21:54:53' prior: 50446227! - parse: isAMethod - "Parse the receiver's text. If isAMethod is true - then treat text as a method, if false as an - expression with no message pattern" - - | continue prevSourcePosition | - self initializeInstanceVariables. - sourcePosition _ 1. - arguments _ Dictionary new. - temporaries _ Dictionary new. - blockDepth _ bracketDepth _ braceDepth _ 0. - blockDepths _ OrderedCollection with: blockDepth. - blockDepthsStartIndexes _ OrderedCollection with: sourcePosition. - ranges ifNil: [ ranges := OrderedCollection new: 100] ifNotNil: [ ranges reset]. - errorBlock _ [^false]. - [ - self scanNext. - isAMethod - ifTrue: [ - self parseMessagePattern. - self parsePragmaSequence]. - self parseMethodTemporaries. - isAMethod ifTrue: [self parsePragmaSequence]. - "Iterate once for methods, but pontentially several times for workspaces - (to recover after errors, for possible good next lines or chunks)" - continue _ true. - [ continue ] whileTrue: [ - prevSourcePosition _ sourcePosition. - self parseStatementList. - continue _ sourcePosition > prevSourcePosition. - isAMethod - ifTrue: [ - "Only if we are parsing a method, consider everything after this point as error." - currentToken ifNotNil: [ self error ]. - continue _ false] - ifFalse: [ - sourcePosition > source size ifTrue: [continue _ false]]]. - ] ensure: [errorBlock _ nil]. - ^true! ! -!SHParserST80 methodsFor: 'parse' stamp: 'HAW 5/3/2020 21:56:35' prior: 16902482! - parseBraceArray - self parseStatementListForBraceArray. - self failUnless: currentTokenFirst == $}. - self scanPast: #rightBrace level: braceDepth. - braceDepth := braceDepth - 1! ! -!SHParserST80 methodsFor: 'parse' stamp: 'HAW 5/3/2020 21:57:08' prior: 50386110! - parseTerm - self failWhen: currentToken isNil. - currentTokenFirst == $( - ifTrue: [ - bracketDepth := bracketDepth + 1. - self scanPast: #leftParenthesis level: bracketDepth. - self parseExpression. - self failUnless: currentTokenFirst == $). - self scanPast: #rightParenthesis level: bracketDepth. - bracketDepth := bracketDepth - 1. - ^self ]. - currentTokenFirst == $[ ifTrue: [^self parseBlock]. - currentTokenFirst == $` ifTrue: [^self parseBacktick]. - currentTokenFirst == ${ - ifTrue: [ - braceDepth := braceDepth + 1. - self scanPast: #leftBrace level: braceDepth. - self parseBraceArray. - ^self ]. - self isName ifTrue: [^self scanPast: (self resolve: currentToken)]. - self parseLiteral: false! ! - -SmalltalkCompleter removeSelector: #lookForBinarySelectorAfter:in:startingAt:with:! - -SmalltalkCompleter removeSelector: #computeMessageEntriesWhenSendinMessageFor:using:in:and:! - -!methodRemoval: SmalltalkCompleter #computeMessageEntriesWhenSendinMessageFor:using:in:and: stamp: 'Install-4137-AutoCompleteImprovements-HernanWilkinson-2020May03-15h16m-HAW.001.cs.st 5/26/2020 17:08:33'! -computeMessageEntriesWhenSendinMessageFor: allSource using: allRanges in: contextClass and: specificModel - - | prevRange | - - "If previous range is a constant or a well known identifier, we might filter messages" - prevRange _ allRanges penultimateIfAbsent: [ SHRange nilObject ]. - possibleBinarySendRange _ allRanges antepenultimateIfAbsent: [ SHRange nilObject ]. - - ^ (self canComputeMessageEntriesFor: prevRange) - ifTrue: [ self computeMessageEntriesFor: allSource at: prevRange in: contextClass and: specificModel ] - ifFalse: [ self computeMessageEntriesForUnknowClass ] -! - -SmalltalkCompleter removeSelector: #computeEntriesOfMessageOrIdentifiersFor:using:at:in:and:! - -!methodRemoval: SmalltalkCompleter #computeEntriesOfMessageOrIdentifiersFor:using:at:in:and: stamp: 'Install-4137-AutoCompleteImprovements-HernanWilkinson-2020May03-15h16m-HAW.001.cs.st 5/26/2020 17:08:33'! -computeEntriesOfMessageOrIdentifiersFor: allSource using: allRanges at: range in: contextClass and: specificModel - - prefix _ allSource copyFrom: range start to: range end. - (parser isMessage: range rangeType) ifTrue: [ - ^self computeMessageEntriesWhenSendinMessageFor: allSource using: allRanges in: contextClass and: specificModel ]. - (parser isPartialOrFullIdentifier: range rangeType) ifTrue: [ ^self computeIdentifierEntries ]. - - "If we don't know what to do, do nothing" - entries _ #() ! - -SmalltalkCompleter removeSelector: #moveUpTo:from:! - -SmalltalkCompleter removeSelector: #xinitialize! - -SmalltalkCompleter removeSelector: #moveUpTo:from:in:! - -SmalltalkCompleter removeSelector: #initialize! - -SmalltalkCompleter removeSelector: #startingAt:with:! - -SmalltalkCompleter removeSelector: #eatParenthesisFrom:in:! - -SmalltalkCompleter removeSelector: #possibleBinarySendRangeFrom:! - -!methodRemoval: SmalltalkCompleter #possibleBinarySendRangeFrom: stamp: 'Install-4137-AutoCompleteImprovements-HernanWilkinson-2020May03-15h16m-HAW.001.cs.st 5/26/2020 17:08:33'! -possibleBinarySendRangeFrom: allRanges - - | penultimate antepenultimate | - - penultimate := allRanges penultimateIfAbsent: [ SHRange nilObject ]. - antepenultimate := allRanges antepenultimateIfAbsent: [ SHRange nilObject ]. - - possibleBinarySendRange _ penultimate rangeType = #arrayStart - ifTrue: [ antepenultimate rangeType = #symbol - ifTrue: [ allRanges at: allRanges size - 3 ifAbsent: [ SHRange nilObject ] ]] - ifFalse: [ - ({#leftBrace. #'$'. #symbol. #blockStart. } includes: penultimate rangeType) - ifTrue: [ antepenultimate ] - ifFalse: [ penultimate ]]! - -SmalltalkCompleter removeSelector: #possibleBinarySendRangeFrom! - -SmalltalkCompleter removeSelector: #lookForBinarySelectorAfter:in:startingAt:! - -SmalltalkCompleter removeSelector: #lookForBinarySelectorAfterArrayStartIn:startingAt:with:! - -SmalltalkCompleter removeSelector: #computeMessageEntriesWithEmptyPrefixFor:using:at:in:and:! - -!methodRemoval: SmalltalkCompleter #computeMessageEntriesWithEmptyPrefixFor:using:at:in:and: stamp: 'Install-4137-AutoCompleteImprovements-HernanWilkinson-2020May03-15h16m-HAW.001.cs.st 5/26/2020 17:08:33'! -computeMessageEntriesWithEmptyPrefixFor: allSource using: allRanges at: range in: contextClass and: specificModel - - self possibleBinarySendRangeFrom: allRanges. - prefix _ ''. - - self computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel .! - -SmalltalkCompleter removeSelector: #lookForBinarySelectorAfterArrayStartIn:startingAt:! - -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser selectorsClasses possibleInvalidSelectors canShowSelectorDocumentation possibleBinarySendRange allRanges' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #SmalltalkCompleter category: #'Tools-Autocompletion' stamp: 'Install-4137-AutoCompleteImprovements-HernanWilkinson-2020May03-15h16m-HAW.001.cs.st 5/26/2020 17:08:33'! -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser selectorsClasses possibleInvalidSelectors canShowSelectorDocumentation possibleBinarySendRange allRanges' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -Object subclass: #SHParserST80 - instanceVariableNames: 'classOrMetaClass source workspace arguments sourcePosition currentToken currentTokenFirst temporaries instanceVariables errorBlock currentTokenSourcePosition blockDepth bracketDepth ranges blockDepths blockDepthsStartIndexes allSource braceDepth' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -!classDefinition: #SHParserST80 category: #'Tools-Syntax Highlighting' stamp: 'Install-4137-AutoCompleteImprovements-HernanWilkinson-2020May03-15h16m-HAW.001.cs.st 5/26/2020 17:08:33'! -Object subclass: #SHParserST80 - instanceVariableNames: 'classOrMetaClass source workspace arguments sourcePosition currentToken currentTokenFirst temporaries instanceVariables errorBlock currentTokenSourcePosition blockDepth bracketDepth ranges blockDepths blockDepthsStartIndexes allSource braceDepth' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4137-AutoCompleteImprovements-HernanWilkinson-2020May03-15h16m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4137] on 7 May 2020 at 4:30:44 pm'! -!PseudoClass methodsFor: 'as yet unclassified' stamp: 'HAW 5/7/2020 13:02:06'! - printHierarchy - - ^'Hierarchy view not supported'! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4139-PseudoClass-printHierarchy fix-HernanWilkinson-2020May07-13h01m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4139] on 8 May 2020 at 12:00:19 pm'! -!Morph methodsFor: 'caching' stamp: 'jmv 5/8/2020 11:43:26'! - clearId - id _ nil.! ! -!Morph class methodsFor: 'initialize-release' stamp: 'jmv 5/8/2020 11:53:06' overrides: 16785014! - releaseClassState - - LastMorphId _ nil. - self allSubInstancesDo: [ :each | - each clearId. - each releaseCachedState ]! ! -!Behavior methodsFor: 'system startup' stamp: 'jmv 5/8/2020 11:39:03' prior: 50417628! - releaseClassCachedState - "Will be called for each class on shutdown or snapshot. - All class vars or class instVar vars that can be cheaply recreated lazily on demand, should be nilled. - For more expensive stuff to clean and recreate, consider #releaseClassState that is not called on every image save. - See implementors for examples"! ! -!Behavior methodsFor: 'system startup' stamp: 'jmv 5/8/2020 11:40:43' prior: 16785014! - releaseClassState - "Will be called for each class on 'Save as new version'. - All class vars or class instVar vars that can be recreated lazily on demand, should be nilled. This is done not only to save space, but more importantly, to prepare Cuis for a complete bootstrap from sources. For this, it should be possible to recreate all class state, at least with default values. - See implementors for examples"! ! -!Morph methodsFor: 'caching' stamp: 'jmv 5/8/2020 11:44:22' prior: 50505997! - releaseCachedState - "Release any state that can be recomputed on demand, such as the pixel values for a color gradient or the editor state for a TextMorph. This method may be called to save space when a morph becomes inaccessible. Implementations of this method should do 'super releaseCachedState'."! ! - -Morph class removeSelector: #releaseClassCachedState! - -!methodRemoval: Morph class #releaseClassCachedState stamp: 'Install-4140-AvoidExpensiveClearOnEveryImageSave-JuanVuletich-2020May08-11h57m-jmv.001.cs.st 5/26/2020 17:08:33'! -releaseClassCachedState - - LastMorphId _ nil. - self allSubInstancesDo: [ :each | - each releaseCachedState ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4140-AvoidExpensiveClearOnEveryImageSave-JuanVuletich-2020May08-11h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4140] on 14 May 2020 at 4:58:32 pm'! - -Bitmap removeSelector: #byteSize! - -!methodRemoval: Bitmap #byteSize stamp: 'Install-4141-RemoveSuperfluousMethods-JuanVuletich-2020May14-15h34m-jmv.001.cs.st 5/26/2020 17:08:33'! -byteSize - ^self size * 4! - -WordArray removeSelector: #byteSize! - -!methodRemoval: WordArray #byteSize stamp: 'Install-4141-RemoveSuperfluousMethods-JuanVuletich-2020May14-15h34m-jmv.001.cs.st 5/26/2020 17:08:33'! -byteSize - ^self size * 4! - -ByteArray removeSelector: #byteSize! - -!methodRemoval: ByteArray #byteSize stamp: 'Install-4141-RemoveSuperfluousMethods-JuanVuletich-2020May14-15h34m-jmv.001.cs.st 5/26/2020 17:08:33'! -byteSize - ^self size! - -String removeSelector: #byteSize! - -!methodRemoval: String #byteSize stamp: 'Install-4141-RemoveSuperfluousMethods-JuanVuletich-2020May14-15h34m-jmv.001.cs.st 5/26/2020 17:08:33'! -byteSize - ^self size! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4141-RemoveSuperfluousMethods-JuanVuletich-2020May14-15h34m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4140] on 14 May 2020 at 5:15:37 pm'! - -Object variableWordSubclass: #ThirtyTwoBitSlotsObject - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Objects'! - -!classDefinition: #ThirtyTwoBitSlotsObject category: #'Kernel-Objects' stamp: 'Install-4142-ThirtyTwoBitSlotsObject-JuanVuletich-2020May14-16h58m-jmv.001.cs.st 5/26/2020 17:08:33'! -Object variableWordSubclass: #ThirtyTwoBitSlotsObject - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Objects'! -!ThirtyTwoBitSlotsObject commentStamp: '' prior: 0! - Abstract superclass for objects whose slots are 32 bit values. -- Each can be Float or Integer, but always 32 bit. -- They have a fixed size, defined by the class. -- They don't have collection protocol.! -!Float32SlotsObject methodsFor: 'private' stamp: 'jmv 5/14/2020 17:04:33'! - floatSlotAt: index - - ^Float fromIEEE32Bit: (self basicAt: index)! ! -!Float32SlotsObject methodsFor: 'private' stamp: 'jmv 5/14/2020 17:05:55'! - floatSlotAt: index put: value - - value isFloat - ifTrue: [ self basicAt: index put: value asIEEE32BitWord ] - ifFalse: [ self floatSlotAt: index put: value asFloat ]. - ^value! ! -!ThirtyTwoBitSlotsObject methodsFor: 'accessing' stamp: 'jmv 5/14/2020 17:01:35'! - byteSize - ^self size * 4! ! -!ThirtyTwoBitSlotsObject methodsFor: 'private' stamp: 'jmv 5/14/2020 17:13:27'! - bytesAt: index - "Answer a ByteArray of 4 elements. - The 32-bit word is split in 4 bytes, in little endian format - ThirtyTwoBitSlotsObject new:1 :: at: 1 put: 16rFF32791B ; bytesAt: 1 :: hex - " - - | bytes word | - bytes _ ByteArray new: 4. - word _ self basicAt: index. "Usually a SmallInteger, but may be a Large Integer in 32-bit images" - 1 to: 4 do: [ :i | bytes at: i put: (word digitAt: i) ]. - ^ bytes! ! -!ThirtyTwoBitSlotsObject methodsFor: 'private' stamp: 'jmv 5/14/2020 17:14:38'! - bytesAt: index put: aByteArray - "Takes a ByteArray of 4 elements. - Store the 32-bit word made with those byes, in little endian format - ThirtyTwoBitSlotsObject new: 1 :: bytesAt: 1 put: #[16r1B 16r79 16r32 16rFF]; basicAt: 1 :: hex - " - - | word | - word _ 0. - 4 to: 1 by: -1 do: [ :i | word _ word * 256 + (aByteArray at: i) ]. - self basicAt: index put: word! ! -!ThirtyTwoBitSlotsObject methodsFor: 'private' stamp: 'jmv 5/14/2020 17:03:42'! - floatSlotAt: index - - ^Float fromIEEE32Bit: (self basicAt: index)! ! -!ThirtyTwoBitSlotsObject methodsFor: 'private' stamp: 'jmv 5/14/2020 17:05:41'! - floatSlotAt: index put: value - - value isFloat - ifTrue: [ self basicAt: index put: value asIEEE32BitWord ] - ifFalse: [ self floatSlotAt: index put: value asFloat ]. - ^value! ! -!ThirtyTwoBitSlotsObject methodsFor: 'private' stamp: 'jmv 5/14/2020 17:07:17'! - integerSlotAt: index - "Return the integer at the given index" - | word | - - word _ self basicAt: index. - word < 16r3FFFFFFF ifTrue:[^word]. "Avoid LargeInteger computations" - ^word >= 16r80000000 "Negative?!!" - ifTrue:["word - 16r100000000" - (word bitInvert32 + 1) negated] - ifFalse:[word]! ! -!ThirtyTwoBitSlotsObject methodsFor: 'private' stamp: 'jmv 5/14/2020 17:07:30'! - integerSlotAt: index put: anInteger - "Store the integer at the given index" - | word | - - anInteger < 0 - ifTrue:["word _ 16r100000000 + anInteger" - word _ (anInteger + 1) negated bitInvert32] - ifFalse:[word _ anInteger]. - self basicAt: index put: word. - ^anInteger! ! -!ThirtyTwoBitSlotsObject methodsFor: 'private' stamp: 'jmv 5/14/2020 17:15:15'! - unsignedIntAt: index - - ^self basicAt: index! ! -!ThirtyTwoBitSlotsObject methodsFor: 'private' stamp: 'jmv 5/14/2020 17:15:24'! - unsignedIntAt: index put: anInteger - - ^self basicAt: index put: anInteger! ! -!ThirtyTwoBitSlotsObject class methodsFor: 'instance creation' stamp: 'jmv 5/14/2020 17:01:35' overrides: 16783533! - new - "Answer a new instance of me, with size = 0, unles a specific size is used." - - ^self new: self numSlots! ! -!ThirtyTwoBitSlotsObject class methodsFor: 'instance creation' stamp: 'jmv 5/14/2020 17:01:35'! - numSlots - ^0! ! -!WordArray methodsFor: 'as yet unclassified' stamp: 'jmv 5/14/2020 17:09:03' overrides: 16880774! - at: x - ^super at: x! ! -!WordArray methodsFor: 'as yet unclassified' stamp: 'jmv 5/14/2020 17:09:10' overrides: 16880792! - at: x put: y - ^super at: x put: y! ! -!WordArray methodsFor: 'as yet unclassified' stamp: 'jmv 5/14/2020 17:10:29' overrides: 16880817! - basicAt: index - ^super basicAt: index ! ! -!WordArray methodsFor: 'as yet unclassified' stamp: 'jmv 5/14/2020 17:10:45' overrides: 16880833! - basicAt: x put: y - ^super basicAt: x put: y! ! -!Color methodsFor: 'access' stamp: 'jmv 5/14/2020 17:04:45' prior: 50475101! - blue - "Return the blue component of this color, a float in the range [0.0..1.0]." - - ^ self floatSlotAt: 3! ! -!Color methodsFor: 'access' stamp: 'jmv 5/14/2020 17:04:54' prior: 50475107! - green - "Return the green component of this color, a float in the range [0.0..1.0]." - - ^ self floatSlotAt: 2! ! -!Color methodsFor: 'access' stamp: 'jmv 5/14/2020 17:05:16' prior: 50475113! - red - "Return the red component of this color, a float in the range [0.0..1.0]." - - ^ self floatSlotAt: 1! ! -!Color methodsFor: 'conversions' stamp: 'jmv 5/14/2020 17:05:10' prior: 50475119! - pixelValueForDepth: d - "Returns an integer representing the bits that appear in a single pixel of this color in a Form of the given depth. The depth must be one of 1, 2, 4, 8, 16, or 32. Contrast with pixelWordForDepth: and bitPatternForDepth:, which return either a 32-bit word packed with the given pixel value or a multiple-word Bitmap containing a pattern. The inverse is the class message colorFromPixelValue:depth:" - "Details: For depths of 8 or less, the result is a colorMap index. For depths of 16 and 32, it is a direct color value with 5 or 8 bits per color component." - "Transparency: The pixel value zero is reserved for transparent. For depths greater than 8 and less than 32 (no Indexed colors, no real alpha), black maps to the darkest possible blue. - Note that - Color transparent class = TranslucentColor - this special case is handled in TranslucentColor >> #pixelValueForDepth: - " - - | bitBltFakeBlack val | - "Most common case" - "eight bits per component; top 8 bits set to all ones (opaque alpha)" - d = 32 ifTrue: [ - ^ 16rFF000000 bitOr: - ((((self floatSlotAt: 1) * 255.999) truncated bitShift: 16) bitOr: - ((((self floatSlotAt: 2) * 255.999) truncated bitShift: 8) bitOr: - (((self floatSlotAt: 3) * 255.999) truncated))) ]. - -"Faster in 32 bit systems, but slower in 64 bits" -" d = 32 ifTrue: [ - val _ LargePositiveInteger new: 4. - val at: 3 put: ((self at: 1) * 255.999) truncated. - val at: 2 put: ((self at: 2) * 255.999) truncated. - val at: 1 put: ((self at: 3) * 255.999) truncated. - val at: 4 put: 16rFF. - ^ val normalize]." - - d = 8 ifTrue: [^ self closestPixelValue8]. "common case" - d < 8 ifTrue: [ - d = 4 ifTrue: [^ self closestPixelValue4]. - d = 2 ifTrue: [^ self closestPixelValue2]. - d = 1 ifTrue: [^ self closestPixelValue1]]. - - "For the depth 16, pixelValue = 0 means transparent, black is represented as 16r8000 (rgb=0, pixelvalue !!= 0)." - (d = 16) | (d = 15) ifTrue: [ - "five bits per component; top bits ignored" - val _ ((self red * 31) rounded bitShift: 10) bitOr: - (((self green * 31) rounded bitShift: 5) bitOr: - ((self blue * 31) rounded)). - ^ val = 0 - ifTrue: [d = 16 ifTrue: [16r8000] ifFalse: [1]] - ifFalse: [val]]. - - "For the rest of the depths, pixelValue = 0 means transparent, and darkest blue is considered to be black." - bitBltFakeBlack := 1. "closest black that is not transparent in RGB - Not for depths <=8 (Indexed) or = 32 (RGBA)" - d = 12 ifTrue: [ "for indexing a color map with 4 bits per color component" - val _ ((self red * 15) rounded bitShift: 8) bitOr: - (((self green * 15) rounded bitShift: 4) bitOr: - ((self blue * 15) rounded)). - ^ val = 0 ifTrue: [bitBltFakeBlack] ifFalse: [val]]. - - d = 9 ifTrue: [ "for indexing a color map with 3 bits per color component" - val _ ((self red * 7) rounded bitShift: 6) bitOr: - (((self green * 7) rounded bitShift: 3) bitOr: - ((self blue * 7) rounded)). - ^ val = 0 ifTrue: [bitBltFakeBlack] ifFalse: [val]]. - - self error: 'unknown pixel depth: ', d printString! ! -!Color methodsFor: 'queries' stamp: 'jmv 5/14/2020 17:04:58' prior: 50475216! - isBlack - "Return true if the receiver represents black" - (self floatSlotAt: 1) = 0.0 ifFalse: [ ^ false ]. - (self floatSlotAt: 2) = 0.0 ifFalse: [ ^ false ]. - (self floatSlotAt: 3) = 0.0 ifFalse: [ ^ false ]. - ^ true! ! -!Color methodsFor: 'queries' stamp: 'jmv 5/14/2020 17:05:03' prior: 50475225! - isWhite - "Return true if the receiver represents white" - (self floatSlotAt: 1) = 1.0 ifFalse: [ ^ false ]. - (self floatSlotAt: 2) = 1.0 ifFalse: [ ^ false ]. - (self floatSlotAt: 3) = 1.0 ifFalse: [ ^ false ]. - ^ true! ! -!Color methodsFor: 'private' stamp: 'jmv 5/14/2020 17:05:35' prior: 50475234! - basicSetRed: r green: g blue: b - "Initialize this color's r, g, and b components to the given values in the range [0.0..1.0]." - - self - floatSlotAt: 1 put: r; - floatSlotAt: 2 put: g; - floatSlotAt: 3 put: b! ! -!Color methodsFor: 'private' stamp: 'jmv 5/14/2020 17:05:49' prior: 50475243! - clipToValidValues - | v | - 1 to: self size do: [ :i | - v _ self floatSlotAt: i. - v > 1 ifTrue: [self floatSlotAt: i put: 1.0]. - v < 0 ifTrue: [self floatSlotAt: i put: 0.0]]! ! -!TranslucentColor methodsFor: 'accessing' stamp: 'jmv 5/14/2020 17:05:20' prior: 50475251 overrides: 50353221! - alpha - "Return my alpha value, a number between 0.0 and 1.0 where 0.0 is completely transparent and 1.0 is completely opaque." - - ^ self floatSlotAt: 4! ! -!TranslucentColor methodsFor: 'private' stamp: 'jmv 5/14/2020 17:06:02' prior: 50475259! - setRed: r green: g blue: b alpha: alphaValue - - self basicSetRed: r green: g blue: b. - self floatSlotAt: 4 put: alphaValue! ! - -ThirtyTwoBitSlotsObject removeSelector: #integerSloatAt:! - -ThirtyTwoBitSlotsObject removeSelector: #slotAt:put:! - -ThirtyTwoBitSlotsObject removeSelector: #slotAt:! - -Float32SlotsObject removeSelector: #slotAt:! - -!methodRemoval: Float32SlotsObject #slotAt: stamp: 'Install-4142-ThirtyTwoBitSlotsObject-JuanVuletich-2020May14-16h58m-jmv.001.cs.st 5/26/2020 17:08:33'! -slotAt: index - - ^Float fromIEEE32Bit: (self basicAt: index)! - -Float32SlotsObject removeSelector: #slotAt:put:! - -!methodRemoval: Float32SlotsObject #slotAt:put: stamp: 'Install-4142-ThirtyTwoBitSlotsObject-JuanVuletich-2020May14-16h58m-jmv.001.cs.st 5/26/2020 17:08:33'! -slotAt: index put: value - - value isFloat - ifTrue: [ self basicAt: index put: value asIEEE32BitWord ] - ifFalse: [ self slotAt: index put: value asFloat ]. - ^value! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4142-ThirtyTwoBitSlotsObject-JuanVuletich-2020May14-16h58m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4140] on 14 May 2020 at 5:15:56 pm'! - -ThirtyTwoBitSlotsObject variableWordSubclass: #Color - instanceVariableNames: '' - classVariableNames: 'CachedColormaps FromGrayColormaps GrayToIndexMap IndexedColors MaskingMap ToGrayColormaps ' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -!classDefinition: #Color category: #'Graphics-Primitives' stamp: 'Install-4143-ColorIsThirtyTwoBitSlotsObject-JuanVuletich-2020May14-17h15m-jmv.001.cs.st 5/26/2020 17:08:33'! -ThirtyTwoBitSlotsObject variableWordSubclass: #Color - instanceVariableNames: '' - classVariableNames: 'CachedColormaps FromGrayColormaps GrayToIndexMap IndexedColors MaskingMap ToGrayColormaps' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -ThirtyTwoBitSlotsObject variableWordSubclass: #Color - instanceVariableNames: '' - classVariableNames: 'CachedColormaps FromGrayColormaps GrayToIndexMap IndexedColors MaskingMap ToGrayColormaps' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -!classDefinition: #Color category: #'Graphics-Primitives' stamp: 'Install-4143-ColorIsThirtyTwoBitSlotsObject-JuanVuletich-2020May14-17h15m-jmv.001.cs.st 5/26/2020 17:08:33'! -ThirtyTwoBitSlotsObject variableWordSubclass: #Color - instanceVariableNames: '' - classVariableNames: 'CachedColormaps FromGrayColormaps GrayToIndexMap IndexedColors MaskingMap ToGrayColormaps' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4143-ColorIsThirtyTwoBitSlotsObject-JuanVuletich-2020May14-17h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4140] on 14 May 2020 at 5:16:14 pm'! - -Smalltalk removeClassNamed: #Float32SlotsObject! - -!classRemoval: #Float32SlotsObject stamp: 'Install-4144-remove-Float32SlotsObject-JuanVuletich-2020May14-17h15m-jmv.001.cs.st 5/26/2020 17:08:33'! -Object variableWordSubclass: #Float32SlotsObject - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Objects'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4144-remove-Float32SlotsObject-JuanVuletich-2020May14-17h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4140] on 14 May 2020 at 5:49:46 pm'! -!ThirtyTwoBitSlotsObject methodsFor: 'private' stamp: 'jmv 5/14/2020 17:49:24'! - intSlotAt: index - "Return the integer at the given index" - | word | - - word _ self basicAt: index. - word < 16r3FFFFFFF ifTrue:[^word]. "Avoid LargeInteger computations" - ^word >= 16r80000000 "Negative?!!" - ifTrue:["word - 16r100000000" - (word bitInvert32 + 1) negated] - ifFalse:[word]! ! -!ThirtyTwoBitSlotsObject methodsFor: 'private' stamp: 'jmv 5/14/2020 17:49:30'! - intSlotAt: index put: anInteger - "Store the integer at the given index" - | word | - - anInteger < 0 - ifTrue:["word _ 16r100000000 + anInteger" - word _ (anInteger + 1) negated bitInvert32] - ifFalse:[word _ anInteger]. - self basicAt: index put: word. - ^anInteger! ! - -ThirtyTwoBitSlotsObject removeSelector: #integerSlotAt:! - -!methodRemoval: ThirtyTwoBitSlotsObject #integerSlotAt: stamp: 'Install-4145-ThirtyTwoBitSlotsObject-tweaks-JuanVuletich-2020May14-17h16m-jmv.001.cs.st 5/26/2020 17:08:33'! -integerSlotAt: index - "Return the integer at the given index" - | word | - - word _ self basicAt: index. - word < 16r3FFFFFFF ifTrue:[^word]. "Avoid LargeInteger computations" - ^word >= 16r80000000 "Negative?!!" - ifTrue:["word - 16r100000000" - (word bitInvert32 + 1) negated] - ifFalse:[word]! - -ThirtyTwoBitSlotsObject removeSelector: #integerSlotAt:put:! - -!methodRemoval: ThirtyTwoBitSlotsObject #integerSlotAt:put: stamp: 'Install-4145-ThirtyTwoBitSlotsObject-tweaks-JuanVuletich-2020May14-17h16m-jmv.001.cs.st 5/26/2020 17:08:33'! -integerSlotAt: index put: anInteger - "Store the integer at the given index" - | word | - - anInteger < 0 - ifTrue:["word _ 16r100000000 + anInteger" - word _ (anInteger + 1) negated bitInvert32] - ifFalse:[word _ anInteger]. - self basicAt: index put: word. - ^anInteger! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4145-ThirtyTwoBitSlotsObject-tweaks-JuanVuletich-2020May14-17h16m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4146] on 17 May 2020 at 5:49:20 am'! -!Fraction commentStamp: '' prior: 16849428! - Fraction provides methods for dealing with rational numbers like 1/3 as true fractions (not approximations as a Float 0.33333...). All public arithmetic operations answer reduced fractions, or Integers when the denominator is 1. - -Examples: (note the parentheses required to get the right answers in Smalltalk): - -(2/3) + (2/3) -(6/4) "Fractions are reduced to the smallest numerator and denominator possible" -(1/-3) "Denominator is kept positive, the sign is always in the numerator" -(2/3) + (1/3) "When the denominator reduces to 1, the answer is an Integer" -! -!Integer commentStamp: '' prior: 16858841! - I am a common abstract superclass for all Integer implementations. My implementation subclasses are SmallInteger, LargePositiveInteger, and LargeNegativeInteger. - -There are three implementation of Euclidean division of 'a' by 'b', where 'a' and 'b' are Integers considered as elements of the rational integers ring Z: - - Euclidean division with the quotient rounded towards negative infinity: // and \\ answer 'q' and 'r' such that 'a = bq + r' with 'r abs < b abs', where 'r' is 0 or has the same sign as 'b'. This is sometimes called Knuth's division, and it matches the division commonly implemented in CPUs. - - Euclidean division with the quotient rounded towards zero: #quo: and #rem: answer 'q' and 'r' such that 'a = bq + r' with 'r abs < b abs', where 'r' is 0 or has the same sign as 'a'. - - Euclidean division with non-negative remainder: #div: and #mod: answer 'q' and 'r' such that 'a = bq + r' with '0 <= r < b abs'. -Note that, taking the absolute value as Euclidean function, all of these divisions comply with the definition of Euclidean division. However requiring only 'r abs < b abs' is not enough for producing a unique quotient and remainder, and the additional requirements for the sign of 'r' (different in each of the three kinds of division) guarantee a unique choice of quotient and remainder. - -Additionally, the division in the rational field is implemented with the message / that answers a Fraction 'a/b' if the result is not a whole integer. Note that in the current design of the Number hierarchy, because Fractions reduce to Integers when the denominator is 1, an Integer per-se doesn't know if it is an element of the rational integers ring Z or a member of the rational field Q. In the rational field Q, the quotient of the Euclidean division is / and the remainder is always 0, and the other three divisions are not Euclidean divisions.! -!Number methodsFor: 'arithmetic' stamp: 'len 5/17/2020 05:40:28' prior: 16879694! - div: aNumber - "Integer division with non-negative remainder. - (9 div:4) = 2 - (-9 div: 4) = -3 - (-0.9 div: 0.4) = -3 - #mod: answers the remainder from this division. See comments and examples there. - See #//, #quo:, #div:" - "Answer an integer q such that: - for some r, aNumber * q + r = self - with 0 <= r < | aNumber |" - - aNumber positive ifTrue: [ ^self // aNumber ]. - ^ (self // aNumber abs) negated! ! -!Number methodsFor: 'arithmetic' stamp: 'len 5/17/2020 05:39:46' prior: 50405306! - mod: divisor - "Modulo operation. Remainder of the integer division #div:. - Answer a Number that is never negative (it is positive or zero). - (9 mod: 4) = 1 - (-9 mod: 4) = 3 - (9 mod: -4) = 1 - (0.9 mod: 0.4) = 0.1 - See http://en.wikipedia.org/wiki/Modulo_operation - See #\\, #rem: and #mod: - See detailed discussion at http://mathforum.org/library/drmath/view/52343.html - And https://biblio.ugent.be/input/download?func=downloadFile&recordOId=314490&fileOId=452146 - " - "Answer r such that: - for some integer q, aNumber * q + r = self - with 0 <= r < | aNumber |" - - ^self \\ divisor abs - - "Evaluate the following:" -" -| g d | -d _ 1. -Feature require: 'Morphic-Widgets-Extras'. -g _ FunctionGraphMorph new. -g domain: (-4 to: 4). -g addFunction: [ :x | x mod: d ] color: Color green. -g addFunction: [ :x | x div: d ] color: Color red. -g openInWorld -" -" -| g d | -d _ -1. -Feature require: 'Morphic-Widgets-Extras'. -g _ FunctionGraphMorph new. -g domain: (-4 to: 4). -g addFunction: [ :x | x mod: d ] color: Color green. -g addFunction: [ :x | x div: d ] color: Color red. -g openInWorld -" -! ! -!Number methodsFor: 'arithmetic' stamp: 'len 5/17/2020 05:35:19' prior: 16879748! - quo: aNumber - "Integer division with truncation towards zero. - (-9 quo: 4) = -2 - (-0.9 quo: 0.4) = -2 - #rem: answers the remainder from this division. - See #//, #quo:, #div:" - - ^ (self / aNumber) truncated! ! -!Number methodsFor: 'arithmetic' stamp: 'len 5/17/2020 05:41:49' prior: 16879763! - rem: divisor - "Modulo operation. Remainder of the integer division #quo: (division with truncation towards zero). - Answer a Number with the same sign as dividend (i.e., self). - (9 rem: 4) = 1. - (-9 rem: 4) = -1. - (0.9 rem: 0.4) = 0.1. - See http://en.wikipedia.org/wiki/Modulo_operation - See #\\, #rem: and #mod: - See detailed discussion at http://mathforum.org/library/drmath/view/52343.html - " - - ^self - ((self quo: divisor) * divisor) - - "Evaluate the following:" -" -| g d | -d _ 1. -g _ FunctionGraphMorph new. -g domain: (-4 to: 4). -g addFunction: [ :x | x rem: d ] color: Color green. -g addFunction: [ :x | x quo: d ] color: Color red. -g openInWorld -" -" -| g d | -d _ -1. -g _ FunctionGraphMorph new. -g domain: (-4 to: 4). -g addFunction: [ :x | x rem: d ] color: Color green. -g addFunction: [ :x | x quo: d ] color: Color red. -g openInWorld -"! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4146-DivisionDocumentation-LucianoEstebanNotarfrancesco-2020May17-05h31m-len.001.cs.st----! - -'From Cuis 5.0 [latest update: #4145] on 18 May 2020 at 2:54:04 pm'! -!Number methodsFor: 'arithmetic' stamp: 'jmv 5/18/2020 14:53:46' prior: 50510728! - mod: divisor - "Modulo operation. Remainder of the integer division #div: (Euclidean division) - Answer a Number that is never negative (it is positive or zero). - (9 mod: 4) = 1 - (-9 mod: 4) = 3 - (9 mod: -4) = 1 - (0.9 mod: 0.4) = 0.1 - See http://en.wikipedia.org/wiki/Modulo_operation - See #\\, #rem: and #mod: - See detailed discussion at http://mathforum.org/library/drmath/view/52343.html - And 'The Euclidean Definition of the Functions div and mod' by Raymond T. Boute, https://core.ac.uk/download/pdf/55698442.pdf - " - "Answer r such that: - for some integer q, aNumber * q + r = self - with 0 <= r < | aNumber |" - - ^self \\ divisor abs - - "Evaluate the following:" -" -| g d | -d _ 1. -Feature require: 'Morphic-Widgets-Extras'. -g _ FunctionGraphMorph new. -g domain: (-4 to: 4). -g addFunction: [ :x | x mod: d ] color: Color green. -g addFunction: [ :x | x div: d ] color: Color red. -g openInWorld -" -" -| g d | -d _ -1. -Feature require: 'Morphic-Widgets-Extras'. -g _ FunctionGraphMorph new. -g domain: (-4 to: 4). -g addFunction: [ :x | x mod: d ] color: Color green. -g addFunction: [ :x | x div: d ] color: Color red. -g openInWorld -" -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4147-FixMissingWebLink-JuanVuletich-2020May18-14h53m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4147] on 18 May 2020 at 3:09:14 pm'! -!Number methodsFor: 'arithmetic' stamp: 'jmv 5/18/2020 15:07:11' prior: 50405274! - \\ divisor - "Modulo operation. Remainder of the integer division #// (Floored division, truncated to minus infinity, a.k.a Knuth's division) - Answer a Number with the same sign as divisor. - 9\\4 = 1 - -9\\4 = 3 - 9\\-4 = -3 - 0.9\\0.4 = 0.1 - See http://en.wikipedia.org/wiki/Modulo_operation - See #\\, #rem: and #mod: - See detailed discussion at http://mathforum.org/library/drmath/view/52343.html - " - - ^self - (self // divisor * divisor) - - "Evaluate the following:" -" -Compiler evaluate: ' - | g d | - d _ 1. - Feature require: ''Morphic-Widgets-Extras''. - g _ FunctionGraphMorph new. - g domain: (-4 to: 4). - g addFunction: [ :x | x \\ d ] color: Color green. - g addFunction: [ :x | x // d ] color: Color red. - g openInWorld' -" -" -Compiler evaluate: ' - | g d | - d _ -1. - Feature require: ''Morphic-Widgets-Extras''. - g _ FunctionGraphMorph new. - g domain: (-4 to: 4). - g addFunction: [ :x | x \\ d ] color: Color green. - g addFunction: [ :x | x // d ] color: Color red. - g openInWorld' -"! ! -!Number methodsFor: 'arithmetic' stamp: 'jmv 5/18/2020 15:07:30' prior: 50510812! - mod: divisor - "Modulo operation. Remainder of the integer division #div: (Euclidean division) - Answer a Number that is never negative (it is positive or zero). - (9 mod: 4) = 1 - (-9 mod: 4) = 3 - (9 mod: -4) = 1 - (0.9 mod: 0.4) = 0.1 - See http://en.wikipedia.org/wiki/Modulo_operation - See #\\, #rem: and #mod: - See detailed discussion at http://mathforum.org/library/drmath/view/52343.html - And 'The Euclidean Definition of the Functions div and mod' by Raymond T. Boute, https://core.ac.uk/download/pdf/55698442.pdf - " - "Answer r such that: - for some integer q, aNumber * q + r = self - with 0 <= r < | aNumber |" - - ^self \\ divisor abs - - "Evaluate the following:" -" -Compiler evaluate: ' - | g d | - d _ 1. - Feature require: ''Morphic-Widgets-Extras''. - g _ FunctionGraphMorph new. - g domain: (-4 to: 4). - g addFunction: [ :x | x mod: d ] color: Color green. - g addFunction: [ :x | x div: d ] color: Color red. - g openInWorld' -" -" -Compiler evaluate: ' - | g d | - d _ -1. - Feature require: ''Morphic-Widgets-Extras''. - g _ FunctionGraphMorph new. - g domain: (-4 to: 4). - g addFunction: [ :x | x mod: d ] color: Color green. - g addFunction: [ :x | x div: d ] color: Color red. - g openInWorld' -" -! ! -!Number methodsFor: 'arithmetic' stamp: 'jmv 5/18/2020 15:08:09' prior: 50510775! - rem: divisor - "Modulo operation. Remainder of the integer division #quo: (division with truncation towards zero). - Answer a Number with the same sign as dividend (i.e., self). - (9 rem: 4) = 1. - (-9 rem: 4) = -1. - (0.9 rem: 0.4) = 0.1. - See http://en.wikipedia.org/wiki/Modulo_operation - See #\\, #rem: and #mod: - See detailed discussion at http://mathforum.org/library/drmath/view/52343.html - " - - ^self - ((self quo: divisor) * divisor) - - "Evaluate the following:" -" -Compiler evaluate: ' - | g d | - d _ 1. - Feature require: ''Morphic-Widgets-Extras''. - g _ FunctionGraphMorph new. - g domain: (-4 to: 4). - g addFunction: [ :x | x rem: d ] color: Color green. - g addFunction: [ :x | x quo: d ] color: Color red. - g openInWorld' -" -" -Compiler evaluate: ' - | g d | - d _ -1. - Feature require: ''Morphic-Widgets-Extras''. - g _ FunctionGraphMorph new. - g domain: (-4 to: 4). - g addFunction: [ :x | x rem: d ] color: Color green. - g addFunction: [ :x | x quo: d ] color: Color red. - g openInWorld' -"! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 5/18/2020 15:08:33' prior: 50410404! - smoothIsAbsBelow: threshold - "A Function that is 1 at zero, 0 outside a bounded interval of size 4*threshold, and is continuous and differentiable. - - It is a 'smooth' version of an #isAbsBelow: function: x abs < threshold. - Useful when we need to 'count' stuff, but still want continuous and differentiable stuff." - " -Compiler evaluate: ' - | g | - Feature require: ''Morphic-Widgets-Extras''. - g _ FunctionGraphMorph new. - g domain: (-4 to: 4). - g addFunction: [ :x | x abs < Float halfPi ifTrue: [1] ifFalse:[0] ] color: Color brown. - g addFunction: [ :x | x smoothIsAbsBelow: Float halfPi ] color: Color red. - (g embeddedInMorphicWindowLabeled: ''graph'') openInWorld' - " - | scaled | - scaled _ self / threshold. - ^ scaled abs < 2 ifTrue: [ (scaled * Float halfPi) cos + 1.0 * 0.5 ] ifFalse: [ 0 ]! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 5/18/2020 15:08:52' prior: 50467990! - smoothStep - "A Function that is - x <= -1 -> 1 - -1 < x < 1 -> smooth differentiable transition from 1 to 0 - 1 <= x -> 0 - - It is a 'smooth' version of an #negative - Has countless applications. For example in image and signal processing, but also in other fields." - " -Compiler evaluate: ' - | g | - Feature require: ''Morphic-Widgets-Extras''. - g _ FunctionGraphMorph new. - g domain: (-4 to: 4). - g addFunction: [ :x | x abs < 1 ifTrue: [1] ifFalse:[0] ] color: Color brown. - g addFunction: [ :x | x smoothStep ] color: Color red. - (g embeddedInMorphicWindowLabeled: ''graph'') openInWorld' - " - self isNaN ifTrue: [ ^self ]. - self > -1 ifFalse: [ ^ 1 ]. - 1 > self ifFalse: [ ^ 0 ]. - ^ (self +2 * Float halfPi) sin * 0.5 + 0.5! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4148-FixBrokenExamplesInComments-JuanVuletich-2020May18-15h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4148] on 18 May 2020 at 5:29:26 pm'! -!SequenceableCollection methodsFor: 'accessing' stamp: 'sqr 5/17/2020 00:15:12'! - head: anInteger - "Answer the first anInteger objects in the receiver, subject to availability" - - ^self first: (anInteger min: self size)! ! -!SequenceableCollection methodsFor: 'accessing' stamp: 'sqr 5/17/2020 00:15:23'! - tail: anInteger - "Answer the last anInteger objects in the receiver, subject to availability" - - ^self last: (anInteger min: self size)! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4149-head-tail-AndresValloud-2020May18-17h28m-sqr.001.cs.st----! - -'From Cuis 5.0 [latest update: #4149] on 20 May 2020 at 3:25:56 pm'! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 5/20/2020 15:18:06' prior: 50494838 overrides: 50463529! - drawString: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | p1 font | - "Don't waste any time if NOP" - lastIndex = 0 ifTrue: [ - ^nil ]. - - p1 _ (currentTransformation transform: aPoint rounded) rounded. - engine colorMap: nil. - font _ fontOrNil ifNil: [ AbstractFont default ]. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: aColor! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4150-TrueTypeFix-JuanVuletich-2020May20-15h25m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4145] on 17 May 2020 at 9:11:22 am'! -!BlockClosure methodsFor: 'evaluating' stamp: 'jmv 5/16/2020 21:40:20'! - microsecondsToRun - "Answer the number of microseconds taken to execute this block." - - ^ Time microsecondsToRun: self -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4151-microsecondsToRun-JuanVuletich-2020May17-09h08m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4151] on 21 May 2020 at 2:29:11 pm'! -!Parser methodsFor: 'expression types' stamp: 'jmv 5/21/2020 14:12:42'! - method: noPattern context: ctxt - " pattern [ | temporaries ] block => MethodNode." - - | sap block primitives tempsDeclarationNode messageComment methodNode | - - sap := self pattern: noPattern inContext: ctxt. - "sap={selector, arguments, precedence}" - self properties selector: (sap at: 1). - encoder selector: (sap at: 1). - (sap at: 2) do: [:argNode | argNode beMethodArg]. - - noPattern ifFalse: [self pragmaSequence]. - tempsDeclarationNode := self temporaries. - messageComment := currentComment. - currentComment := nil. - noPattern ifFalse: [self pragmaSequence]. - primitives := self pragmaPrimitives. - - self statements: #() innerBlock: noPattern. - block := parseNode. - noPattern - ifTrue: [block returnLast] - ifFalse: [block returnSelfIfNoOther: encoder]. - hereType == #doIt ifFalse: [^self expected: 'Nothing more']. - - methodNode := self newMethodNode comment: messageComment. - methodNode - selector: (sap at: 1) - arguments: (sap at: 2) - precedence: (sap at: 3) - temporariesDeclaration: tempsDeclarationNode - block: block - encoder: encoder - primitive: primitives - properties: properties - selectorKeywordsRanges: (sap at: 4). - - self interactive ifTrue: [ self performInteractiveChecks: methodNode ]. - - ^methodNode! ! -!Parser methodsFor: 'public access' stamp: 'jmv 5/21/2020 14:13:11'! - parse: sourceStream class: class category: aCategory noPattern: noPattern context: aContext notifying: aRequestor ifFail: aBlock - - "Answer a MethodNode for the argument, sourceStream, that is the root of - a parse tree. Parsing is done with respect to the argument, class, to find - instance, class, and pool variables; and with respect to the argument, - ctxt, to find temporary variables. Errors in parsing are reported to the - argument, req, if not nil; otherwise aBlock is evaluated. The argument - noPattern is a Boolean that is true if the the sourceStream does not - contain a method header (i.e., for DoIts)." - - | methNode repeatNeeded myStream sourceCode startPosition | - - category _ aCategory. - myStream _ sourceStream. - [ - repeatNeeded _ false. - startPosition _ myStream position. - sourceCode _ myStream upToEnd. - myStream position: startPosition. - self encoder init: class context: aContext notifying: self. - self init: myStream notifying: aRequestor failBlock: [^ aBlock value ]. - doitFlag _ noPattern. - failBlock _ aBlock. - [ methNode _ self method: noPattern context: aContext ] - on: ReparseAfterSourceEditing - do: [ :ex | - repeatNeeded _ true. - myStream _ ReadStream on: requestor text string ]. - repeatNeeded - ] whileTrue: [ encoder _ self encoder class new ]. - - methNode sourceText: sourceCode. - "See #xBacktick" - sentInLiterals do: [ :sym | encoder noteOptimizedSelector: sym ]. - - ^ methNode! ! -!Decompiler methodsFor: 'private' stamp: 'eem 9/6/2008 08:45' prior: 16832035! - blockScopeRefersOnlyOnceToTemp: offset - | nRefs byteCode extension scanner scan | - scanner := InstructionStream on: method. - nRefs := 0. - scan := offset <= 15 - ifTrue: - [byteCode := 16 + offset. - [:instr | - instr = byteCode ifTrue: - [nRefs := nRefs + 1]. - nRefs > 1]] - ifFalse: - [extension := 64 + offset. - [:instr | - (instr = 128 and: [scanner followingByte = extension]) ifTrue: - [nRefs := nRefs + 1]. - nRefs > 1]]. - self scanBlockScopeFor: pc from: method initialPC to: method endPC with: scan scanner: scanner. - ^nRefs = 1! ! -!Compiler methodsFor: 'private' stamp: 'jmv 5/21/2020 14:14:22' prior: 50445117! - translate: aStream noPattern: noPattern ifFail: failBlock - - ^self parser - ignoreBacktick: false; - parse: aStream - class: class - category: category - noPattern: noPattern - context: context - notifying: requestor - ifFail: [^failBlock value]! ! -!Parser methodsFor: 'public access' stamp: 'jmv 5/21/2020 14:13:27' prior: 50445176! - parse: sourceStream class: class noPattern: noPattern context: aContext notifying: aRequestor ifFail: aBlock - - ^self parse: sourceStream class: class category: nil noPattern: noPattern context: aContext notifying: aRequestor ifFail: aBlock ! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'jmv 5/21/2020 14:16:37' prior: 50452078! - compileSelectionFor: anObject in: evalContext ifFail: failBlock - - | methodNode method sourceCode compiler | - - sourceCode := self selectionDoItSourceCodeIn: evalContext. - - methodNode _ [ - compiler _ Compiler new. - compiler - compileNoPattern: sourceCode - in: anObject class - context: evalContext - notifying: self - ifFail: [ ^ failBlock value ]] - on: OutOfScopeNotification - do: [ :ex | ex resume: true ]. - - methodNode block returnLast. - method _ methodNode generate. - method methodNode: methodNode. - - ^{ #method -> method. #compiler -> compiler } asDictionary -! ! - -Parser removeSelector: #parse:class:category:noPattern:doIt:context:notifying:ifFail:! - -!methodRemoval: Parser #parse:class:category:noPattern:doIt:context:notifying:ifFail: stamp: 'Install-4152-ParserClanup-JuanVuletich-2020May21-14h10m-jmv.001.cs.st 5/26/2020 17:08:33'! -parse: sourceStream class: class category: aCategory noPattern: noPattern doIt: doIt context: aContext notifying: aRequestor ifFail: aBlock - - "Answer a MethodNode for the argument, sourceStream, that is the root of - a parse tree. Parsing is done with respect to the argument, class, to find - instance, class, and pool variables; and with respect to the argument, - ctxt, to find temporary variables. Errors in parsing are reported to the - argument, req, if not nil; otherwise aBlock is evaluated. The argument - noPattern is a Boolean that is true if the the sourceStream does not - contain a method header (i.e., for DoIts)." - - | methNode repeatNeeded myStream sourceCode startPosition | - - category _ aCategory. - myStream _ sourceStream. - [ - repeatNeeded _ false. - startPosition _ myStream position. - sourceCode _ myStream upToEnd. - myStream position: startPosition. - self encoder init: class context: aContext notifying: self. - self init: myStream notifying: aRequestor failBlock: [^ aBlock value ]. - doitFlag _ noPattern. - failBlock _ aBlock. - [ methNode _ self method: noPattern doIt: doIt context: aContext ] - on: ReparseAfterSourceEditing - do: [ :ex | - repeatNeeded _ true. - myStream _ ReadStream on: requestor text string ]. - repeatNeeded - ] whileTrue: [ encoder _ self encoder class new ]. - - methNode sourceText: sourceCode. - "See #xBacktick" - sentInLiterals do: [ :sym | encoder noteOptimizedSelector: sym ]. - - ^ methNode! - -Parser removeSelector: #method:doIt:context:! - -!methodRemoval: Parser #method:doIt:context: stamp: 'Install-4152-ParserClanup-JuanVuletich-2020May21-14h10m-jmv.001.cs.st 5/26/2020 17:08:33'! -method: noPattern doIt: doIt context: ctxt - " pattern [ | temporaries ] block => MethodNode." - - | sap block primitives tempsDeclarationNode messageComment methodNode | - - sap := self pattern: noPattern inContext: ctxt. - "sap={selector, arguments, precedence}" - self properties selector: (sap at: 1). - encoder selector: (sap at: 1). - (sap at: 2) do: [:argNode | argNode beMethodArg]. - - doIt ifFalse: [self pragmaSequence]. - tempsDeclarationNode := self temporaries. - messageComment := currentComment. - currentComment := nil. - doIt ifFalse: [self pragmaSequence]. - primitives := self pragmaPrimitives. - - self statements: #() innerBlock: doIt. - block := parseNode. - doIt - ifTrue: [block returnLast] - ifFalse: [block returnSelfIfNoOther: encoder]. - hereType == #doIt ifFalse: [^self expected: 'Nothing more']. - - methodNode := self newMethodNode comment: messageComment. - methodNode - selector: (sap at: 1) - arguments: (sap at: 2) - precedence: (sap at: 3) - temporariesDeclaration: tempsDeclarationNode - block: block - encoder: encoder - primitive: primitives - properties: properties - selectorKeywordsRanges: (sap at: 4). - - self interactive ifTrue: [ self performInteractiveChecks: methodNode ]. - - ^methodNode! - -Compiler removeSelector: #translate:noPattern:doIt:ifFail:! - -!methodRemoval: Compiler #translate:noPattern:doIt:ifFail: stamp: 'Install-4152-ParserClanup-JuanVuletich-2020May21-14h10m-jmv.001.cs.st 5/26/2020 17:08:33'! -translate: aStream noPattern: noPattern doIt: doIt ifFail: failBlock - - ^self parser - ignoreBacktick: false; - parse: aStream - class: class - category: category - noPattern: noPattern - doIt: doIt - context: context - notifying: requestor - ifFail: [^failBlock value]! - -Compiler removeSelector: #compileDoIt:in:context:notifying:ifFail:! - -!methodRemoval: Compiler #compileDoIt:in:context:notifying:ifFail: stamp: 'Install-4152-ParserClanup-JuanVuletich-2020May21-14h10m-jmv.001.cs.st 5/26/2020 17:08:33'! -compileDoIt: textOrStream in: aClass context: aContext notifying: aRequestor ifFail: failBlock - "Similar to #compile:in:notifying:ifFail:, but the compiled code is - expected to be a do-it expression, with no message pattern." - - self from: textOrStream - class: aClass - context: aContext - notifying: aRequestor. - ^self - translate: sourceStream - noPattern: false - doIt: true - ifFail: failBlock! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4152-ParserClanup-JuanVuletich-2020May21-14h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4152] on 21 May 2020 at 2:41:16 pm'! -!Character class methodsFor: 'class initialization' stamp: 'len 5/21/2020 08:23:36'! - blackboardLetters - "Answer the 'blackboard bold' or 'double struck' letters included in our font within the ASCII range. - These are considered uppercase letters and can be used as identifiers (variable names, keyword or unary messages, etc)." - ^ '‚ƒ„…†‡'! ! -!Character class methodsFor: 'class initialization' stamp: 'len 5/21/2020 08:24:19'! - greekLowercaseLetters - "Answer the lowercase greek letters included in our font within the ASCII range. - These are considered lowercase letters and can be used as identifiers (variable names, keyword or unary messages, etc)." - ^ 'ˆ‰Š‹ŒŽµ'! ! -!Character class methodsFor: 'class initialization' stamp: 'len 5/21/2020 08:24:46'! - greekUppercaseLetters - "Answer the uppercase greek letters included in our font within the ASCII range. - These are considered uppercase letters and can be used as identifiers (variable names, keyword or unary messages, etc)." - ^ '–—˜'! ! -!Character class methodsFor: 'constants' stamp: 'len 5/21/2020 08:26:58'! - namedCharactersTable - "Table of named characters that we can enter in an editor using \name. - Please keep the names short and try to follow the naming convention used in LaTeX." - ^ #((left $) (right $) (up $) (down $) (oplus $) (otimes $‘) (times $×) (div $÷) #(circ $’) (dot $·) (bullet $“) (diamond $”) (star $•) (alpha $ˆ) (beta $‰) (gamma $Š) (delta $‹) (epsilon $Œ) (lambda $) (mu $µ) (pi $Ž) (zeta $) (Delta $–) (Gamma $—) (Omega $˜) (N $‚) (Z $ƒ) (Q $„) (R $…) (C $†) (P $‡) (infty $€) (aleph $) (sqrt $Ÿ) (partial $ž) (degree $°))! ! -!SmalltalkEditor methodsFor: 'typing/selecting keys' stamp: 'len 5/21/2020 06:41:21' overrides: 16836703! - normalCharacter: aKeyboardEvent - "A nonspecial character is to be added to the stream of characters." - - | stopIndex startIndex string key | - aKeyboardEvent keyCharacter isLetter ifTrue: [^ super normalCharacter: aKeyboardEvent]. - "Allow to enter named (otherwise untypable) characters like the alpha greek letter as \alpha." - string _ self privateCurrentString. - stopIndex _ self pointIndex - 1. - (stopIndex between: 2 and: string size) - ifFalse: [^ super normalCharacter: aKeyboardEvent]. - startIndex _ stopIndex. - "Look backwards and find a character that is not a letter (we want to find '\' just a few characters behind):" - [startIndex > 0 and: [stopIndex - startIndex < 7 and: [(string at: startIndex) isLetter]]] whileTrue: [startIndex _ startIndex - 1]. - (startIndex > 0 and: [(string at: startIndex) = $\]) - ifFalse: [^ super normalCharacter: aKeyboardEvent]. - key _ string copyFrom: startIndex+1 to: stopIndex. - (Character namedCharactersTable detect: [:one| key = one first] ifNone: []) - ifNotNil: [:aPair| self selectFrom: startIndex to: stopIndex; replaceSelectionWith: aPair second asString]. - ^ super normalCharacter: aKeyboardEvent! ! -!Character class methodsFor: 'class initialization' stamp: 'len 5/21/2020 06:35:42' prior: 50375733! - initializeLookupTables - LowercaseMappingTable _ Array new: 256. - LowercaseTruthTable _ Array new: 256. - UppercaseMappingTable _ Array new: 256. - UppercaseTruthTable _ Array new: 256. - LetterTruthTable _ Array new: 256. - UnaccentedTable _ ByteArray new: 256. - 0 - to: 255 - do: [ :idx | | char | - "Default to an identity mapping with a false truth mapping" - char _ self numericValue: idx. - LowercaseMappingTable - at: idx + 1 - put: char. - LowercaseTruthTable - at: idx + 1 - put: false. - UppercaseMappingTable - at: idx + 1 - put: char. - UppercaseTruthTable - at: idx + 1 - put: false. - LetterTruthTable - at: idx + 1 - put: false. - UnaccentedTable at: idx + 1 put: idx]. - "Now override as needed" - Character uppercaseLowercaseAndUnaccentedLetters do: [ :group | | uppercase lowercase | - group size > 1 - ifTrue: [ | lowercaseChar uppercaseChar | - uppercase _ group first numericValue. - lowercase _ group second numericValue. - lowercaseChar _ self numericValue: lowercase. - uppercaseChar _ self numericValue: uppercase. - LowercaseMappingTable - at: lowercase + 1 - put: lowercaseChar. - LowercaseMappingTable - at: uppercase + 1 - put: lowercaseChar. - LowercaseTruthTable - at: lowercase + 1 - put: true. - LetterTruthTable - at: lowercase + 1 - put: true. - UppercaseMappingTable - at: lowercase + 1 - put: uppercaseChar. - UppercaseMappingTable - at: uppercase + 1 - put: uppercaseChar. - UppercaseTruthTable - at: uppercase + 1 - put: true. - LetterTruthTable - at: uppercase + 1 - put: true. - group size > 2 - ifTrue: [|unaccentedUppercase unaccentedLowercase| - unaccentedUppercase _ group third numericValue. - unaccentedLowercase _ group fourth numericValue. - UnaccentedTable at: uppercase+1 put: unaccentedUppercase. - UnaccentedTable at: lowercase+1 put: unaccentedLowercase]] - ifFalse: [ | lowercaseChar | - lowercase _ group first numericValue. - lowercaseChar _ self numericValue: lowercase. - LowercaseMappingTable - at: lowercase + 1 - put: lowercaseChar. - UppercaseMappingTable - at: lowercase + 1 - put: lowercaseChar. - LowercaseTruthTable - at: lowercase + 1 - put: true. - UppercaseTruthTable - at: lowercase + 1 - put: false. - LetterTruthTable - at: lowercase + 1 - put: true ]]. - Character greekLowercaseLetters do: [:each| - LowercaseTruthTable at: each numericValue + 1 put: true. - LetterTruthTable at: each numericValue + 1 put: true]. - Character greekUppercaseLetters do: [:each| - LowercaseTruthTable at: each numericValue + 1 put: true. - LetterTruthTable at: each numericValue + 1 put: true]. - Character blackboardLetters do: [:each| - UppercaseTruthTable at: each numericValue + 1 put: true. - LetterTruthTable at: each numericValue + 1 put: true]! ! -!Character class methodsFor: 'class initialization' stamp: 'len 5/20/2020 17:34:43' prior: 50495560! - initializeUnicodeCodePoints - " - Character initializeUnicodeCodePoints - String streamContents: [ :strm | 28 to: 255 do: [ :i | strm nextPut: (Character numericValue: i) ]] - " - - "Initialize the table of Unicode code points" - UnicodeCodePoints _ Array new: 256. - 0 to: 255 do: [ :code | - UnicodeCodePoints at: code + 1 put: code ]. - - "Arrows" - UnicodeCodePoints at: 28+1 put: 8592. "left arrow" - UnicodeCodePoints at: 29+1 put: 8594. "right arrow" - UnicodeCodePoints at: 30+1 put: 8593. "up arrow" - UnicodeCodePoints at: 31+1 put: 8595. "down arrow" - - "The following codes are different in ISO 8859-15 from those in ISO 8859-1, - so the character code is not equal to the Unicode code point" - UnicodeCodePoints at: 16rA4+1 put: 16r20AC. "euro sign" - UnicodeCodePoints at: 16rA6+1 put: 16r160. "latin capital letter S with caron" - UnicodeCodePoints at: 16rA8+1 put: 16r161. "latin small letter s with caron" - UnicodeCodePoints at: 16rB4+1 put: 16r17D. "latin capital letter Z with caron" - UnicodeCodePoints at: 16rB8+1 put: 16r17E. "latin small letter z with caron" - UnicodeCodePoints at: 16rBC+1 put: 16r152. "latin capital ligature OE" - UnicodeCodePoints at: 16rBD+1 put: 16r153. "latin small ligature oe" - UnicodeCodePoints at: 16rBE+1 put: 16r178. "latin capital letter Y with diaeresis" - - - UnicodeCodePoints at: 16r80+1 put: 16r221E. "INFINITY" - UnicodeCodePoints at: 16r81+1 put: 16r2135. "ALEF SYMBOL" - UnicodeCodePoints at: 16r82+1 put: 16r2115. "DOUBLE-STRUCK CAPITAL N" - UnicodeCodePoints at: 16r83+1 put: 16r2124. "DOUBLE-STRUCK CAPITAL Z" - UnicodeCodePoints at: 16r84+1 put: 16r211A. "DOUBLE-STRUCK CAPITAL Q" - UnicodeCodePoints at: 16r85+1 put: 16r211D. "DOUBLE-STRUCK CAPITAL R" - UnicodeCodePoints at: 16r86+1 put: 16r2102. "DOUBLE-STRUCK CAPITAL C" - UnicodeCodePoints at: 16r87+1 put: 16r2119. "DOUBLE-STRUCK CAPITAL P" - UnicodeCodePoints at: 16r88+1 put: 16r03B1. "alpha" - UnicodeCodePoints at: 16r89+1 put: 16r03B2. "beta" - UnicodeCodePoints at: 16r8A+1 put: 16r03B3. "gamma" - UnicodeCodePoints at: 16r8B+1 put: 16r03B4. "delta" - UnicodeCodePoints at: 16r8C+1 put: 16r03B5. "epsilon" - UnicodeCodePoints at: 16r8D+1 put: 16r03BB. "lambda" - UnicodeCodePoints at: 16r8E+1 put: 16r03C0. "pi" - UnicodeCodePoints at: 16r8F+1 put: 16r03B6. "zeta" - UnicodeCodePoints at: 16r90+1 put: 16r2295. "OPLUS" - UnicodeCodePoints at: 16r91+1 put: 16r2297. "OTIMES" - UnicodeCodePoints at: 16r92+1 put: 16r2218. "RING OPERATOR (circ)" - UnicodeCodePoints at: 16r93+1 put: 16r2219. "BULLET OPERATOR" - UnicodeCodePoints at: 16r94+1 put: 16r22C4. "DIAMOND OPERATOR" - UnicodeCodePoints at: 16r95+1 put: 16r22C6. "STAR OPERATOR" - UnicodeCodePoints at: 16r96+1 put: 16r0394. "Delta" - UnicodeCodePoints at: 16r97+1 put: 16r0393. "Gamma" - UnicodeCodePoints at: 16r98+1 put: 16r03A9. "Omega" - UnicodeCodePoints at: 16r99+1 put: 16r21A0. "SURJECTIVE ARROW" - UnicodeCodePoints at: 16r9A+1 put: 16r21A3. "INJECTIVE ARROW" - UnicodeCodePoints at: 16r9B+1 put: 16r2194. "BIJECTIVE ARROW" - UnicodeCodePoints at: 16r9C+1 put: 16r21AA. "INCLUSION ARROW" - UnicodeCodePoints at: 16r9D+1 put: 16r21A6. "MAPPING ARROW" - UnicodeCodePoints at: 16r9E+1 put: 16r2202. "PARTIAL DIFFERENTIAL" - UnicodeCodePoints at: 16r9F+1 put: 16r221A. "SQUARE ROOT" -! ! -!Scanner class methodsFor: 'cached class state' stamp: 'len 5/21/2020 08:07:57' prior: 50422130! - initTypeTable - | newTable | - newTable := Array new: 256 withAll: #xIllegal. "default" - newTable atAll: #(9 10 12 13 32 ) put: #xDelimiter. "tab lf ff cr space" - - 1 to: 255 - do: [:index | - (Character numericValue: index) isValidInIdentifiers - ifTrue: [ - "Digits and $_ are overwritten later" - newTable at: index put: #xLetter ]]. - - newTable atAll: ($0 numericValue to: $9 numericValue) put: #xDigit. - newTable atAll: '¡!!%&+-*/\·×÷¬­¯,<=>«»¿?@~‘’“”•žŸ™š›œ' asByteArray put: #xBinary. - newTable at: self doItCharacterValue put: #doIt. - newTable at: $" numericValue put: #xDoubleQuote. - newTable at: $# numericValue put: #xLitQuote. - newTable at: $$ numericValue put: #xDollar. - newTable at: $' numericValue put: #xSingleQuote. - newTable at: $` numericValue put: #xBacktick. - newTable at: $: numericValue put: #xColon. - newTable at: $( numericValue put: #leftParenthesis. - newTable at: $) numericValue put: #rightParenthesis. - newTable at: $. numericValue put: #period. - newTable at: $; numericValue put: #semicolon. - newTable at: $[ numericValue put: #leftBracket. - newTable at: $] numericValue put: #rightBracket. - newTable at: ${ numericValue put: #leftBrace. - newTable at: $} numericValue put: #rightBrace. - newTable at: $^ numericValue put: #upArrow. - newTable at: $_ numericValue put: #xUnderscore. - newTable at: $| numericValue put: #verticalBar. - TypeTable := newTable "bon voyage!!" - - " - Scanner initTypeTable - "! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Character initialize. -Scanner initialize.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4153-MathSymbolsUpdate-LucianoEstebanNotarfrancesco-2020May21-14h39m-len.001.cs.st----! - -'From Cuis 5.0 [latest update: #4153] on 21 May 2020 at 2:43:56 pm'! - -Character class removeSelector: #aleph! - -!methodRemoval: Character class #aleph stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:08:34'! -aleph - " - Character aleph - " - ^ $‚! - -Character class removeSelector: #zeta! - -!methodRemoval: Character class #zeta stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:08:34'! -zeta - " - Character zeta - " - ^ $…! - -Character class removeSelector: #PP! - -!methodRemoval: Character class #PP stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:08:34'! -PP - " - Character PP - " - ^ $‹! - -Character class removeSelector: #QQ! - -!methodRemoval: Character class #QQ stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:08:34'! -QQ - " - Character QQ - " - ^ $Œ! - -Character class removeSelector: #circ! - -!methodRemoval: Character class #circ stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:08:34'! -circ - " - Character circ - " - ^ $•! - -Character class removeSelector: #div! - -!methodRemoval: Character class #div stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:08:34'! -div - " - Character div - " - ^ $÷! - -Character class removeSelector: #NN! - -!methodRemoval: Character class #NN stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:08:34'! -NN - " - Character NN - " - ^ $Š! - -Character class removeSelector: #pi! - -!methodRemoval: Character class #pi stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:08:34'! -pi - " - Character pi - " - ^ $ƒ! - -Character class removeSelector: #otimes! - -!methodRemoval: Character class #otimes stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:08:34'! -otimes - " - Character otimes - " - ^ $‘! - -Character class removeSelector: #FF! - -!methodRemoval: Character class #FF stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:08:34'! -FF - " - Character FF - " - ^ $! - -Character class removeSelector: #RR! - -!methodRemoval: Character class #RR stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:08:34'! -RR - " - Character RR - " - ^ $! - -Character class removeSelector: #infinity! - -!methodRemoval: Character class #infinity stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:08:34'! -infinity - " - Character infinity - " - ^ $! - -Character class removeSelector: #epsilon! - -!methodRemoval: Character class #epsilon stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:08:34'! -epsilon - " - Character epsilon - " - ^ $„! - -Character class removeSelector: #dot! - -!methodRemoval: Character class #dot stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:08:34'! -dot - " - Character dot - " - ^ $·! - -Character class removeSelector: #degree! - -!methodRemoval: Character class #degree stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:08:34'! -degree - " - Character degree - " - ^ $°! - -Character class removeSelector: #emptySet! - -!methodRemoval: Character class #emptySet stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:08:34'! -emptySet - " - Character emptySet - " - ^ $€! - -Character class removeSelector: #HH! - -!methodRemoval: Character class #HH stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:08:34'! -HH - " - Character HH - " - ^ $‰! - -Character class removeSelector: #sqrt! - -!methodRemoval: Character class #sqrt stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:08:34'! -sqrt - " - Character sqrt - " - ^ $Ÿ! - -Character class removeSelector: #ZZ! - -!methodRemoval: Character class #ZZ stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:08:34'! -ZZ - " - Character ZZ - " - ^ $Ž! - -Character class removeSelector: #CC! - -!methodRemoval: Character class #CC stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:08:34'! -CC - " - Character CC - " - ^ $ˆ! - -Character class removeSelector: #oplus! - -!methodRemoval: Character class #oplus stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:08:34'! -oplus - " - Character oplus - " - ^ $! - -Character class removeSelector: #times! - -!methodRemoval: Character class #times stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:08:34'! -times - " - Character times - " - ^ $×! - -Character class removeSelector: #bullet! - -!methodRemoval: Character class #bullet stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:08:34'! -bullet - " - Character bullet - " - ^ $–! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st----! - -'From Cuis 5.0 [latest update: #4154] on 21 May 2020 at 3:21:23 pm'! -!LayoutMorph methodsFor: 'geometry' stamp: 'jmv 5/21/2020 15:12:52'! - desiredLayoutHeight - - | fixed proportional | - proportional _ 0. - fixed _ 0. - self submorphsToLayout do: [ :m | | ls | - ls _ m layoutSpec. - ls isProportionalHeight ifTrue: [ - proportional _ proportional max: ls fixedOrMinimumLayoutHeight / ls proportionalLayoutHeight ] - ifFalse: [ - fixed _ fixed + ls fixedOrMinimumLayoutHeight ]]. - ^fixed + proportional! ! -!LayoutMorph methodsFor: 'geometry' stamp: 'jmv 4/30/2020 17:13:46'! - desiredLayoutWidth - - | fixed proportional | - proportional _ 0. - fixed _ 0. - self submorphsToLayout do: [ :m | | ls | - ls _ m layoutSpec. - ls isProportionalWidth ifTrue: [ - proportional _ proportional max: ls fixedOrMinimumLayoutWidth / ls proportionalLayoutWidth ] - ifFalse: [ - fixed _ fixed + ls fixedOrMinimumLayoutWidth ]]. - ^fixed + proportional! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 5/21/2020 15:11:39'! - heightForComfortable: availableSpace - "Similar to #heightFor:. To be used when we know availableSpace is more than the minimum required to apply proportional layout and still get more than our minimum. See senders." - - ^proportionalHeight isNil - ifTrue: [fixedHeight ifNil: [morph morphHeight]] - ifFalse: [proportionalHeight * availableSpace]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 5/21/2020 15:12:30'! - proportionalLayoutHeight - - ^ proportionalHeight ifNil: [ 0 ]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 4/30/2020 17:01:00'! - widthForComfortable: availableSpace - "Similar to #widthFor:. To be used when we know availableSpace is more than the minimum required to apply proportional layout and still get more than our minimum. See senders." - - ^proportionalWidth isNil - ifTrue: [fixedWidth ifNil: [morph morphWidth]] - ifFalse: [proportionalWidth * availableSpace]! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 4/30/2020 17:13:33' prior: 50499714! - layoutSubmorphsHorizontallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - | xSep ySep usableWidth normalizationFactor - fractionalWidths integerWidths theLeft usableHeight boundsTop boundsRight theTop minWidth submorphsToLayout - nextMorph ht wd ls theRight boundsBottom theBottom alternativeWidths count diff i desiredLayoutWidth | - - boundsForLayout extent > `2@2` "self minimumExtent" - ifFalse: [ ^self ]. "Too small. Don't bother!!" - - submorphsToLayout := self submorphsToLayout. - xSep := self xSeparation. - ySep := self ySeparation. - usableWidth := boundsForLayout width - ((submorphsToLayout size + 1) * xSep). - - desiredLayoutWidth _ self desiredLayoutWidth. - normalizationFactor := self proportionalWidthNormalizationFactor. - usableWidth > desiredLayoutWidth - ifTrue: [ - fractionalWidths := submorphsToLayout collect: [ :m | m layoutSpec widthForComfortable: usableWidth*normalizationFactor ]] - ifFalse: [ | sumOfFixedOrMinimum availableForPropWidth | - sumOfFixedOrMinimum := submorphsToLayout sum: [ :m | m minimumLayoutExtent x max: m layoutSpec fixedOrMinimumLayoutWidth ]. - availableForPropWidth := usableWidth - sumOfFixedOrMinimum max: 0. - fractionalWidths := submorphsToLayout collect: [ :m | m layoutSpec widthFor: availableForPropWidth * normalizationFactor ]]. - "Compute integer widths, mostly rounding but with occasional #floor or #ceiling as needed to keep sum" - integerWidths _ fractionalWidths collect: [ :w | w rounded ]. - diff _ integerWidths sum - fractionalWidths sum rounded. - alternativeWidths _ diff > 0 ifTrue: [ fractionalWidths collect: [ :w | w floor ]] ifFalse: [ fractionalWidths collect: [ :w | w ceiling ]]. - count _ diff abs. - i _ 1. - [ count > 0] whileTrue: [ - (integerWidths at: i) = (alternativeWidths at: i) ifFalse: [ - integerWidths at: i put: (alternativeWidths at: i). - count _ count -1 ]. - i _ i + 1 ]. - minWidth := integerWidths sum. - theLeft := ((usableWidth - minWidth) * (padding ifNil: [0]) max: 0) + boundsForLayout left + xSep. - usableHeight := boundsForLayout height - (ySep * 2) max: 0. - boundsTop := boundsForLayout top + ySep. - boundsRight := boundsForLayout right - xSep. - boundsBottom := boundsForLayout bottom - ySep. - - submorphsToLayout size to: 1 by: -1 do: [ :index | - nextMorph := submorphsToLayout at: index. - "major direction" - wd := integerWidths at: index. - "minor direction" - ls := nextMorph layoutSpec. - ht := (ls heightFor: usableHeight) min: usableHeight. - theTop := ((usableHeight - ht) * ls minorDirectionPadding) floor + boundsTop. - theBottom := (theTop + ht) ceiling min: boundsBottom. - theRight := (theLeft + (wd min: minWidth)) "ceiling "min: boundsRight. - "Set bounds and adjust major direction for next step" - self flag: #jmvVer2. "should extent be set in m's coordinate system? what if its scale is not 1?" - ls usesMorphExtent - ifTrue: [ - nextMorph morphPosition: theLeft floor @ theTop floor ] - ifFalse: [ - nextMorph morphPosition: theLeft floor @ theTop floor extent: theRight - theLeft @ (theBottom - theTop) ]. - theLeft := theRight + xSep - ]! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 5/21/2020 15:19:28' prior: 50499808! - layoutSubmorphsVerticallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - | xSep ySep usableHeight normalizationFactor - fractionalHeights integerHeights theTop usableWidth boundsLeft boundsBottom theLeft minHeight submorphsToLayout - nextMorph ht wd ls theBottom boundsRight theRight alternativeHeights count diff i desiredLayoutHeight | - - boundsForLayout extent > `2@2` "self minimumExtent" - ifFalse: [ ^self ]. "Too small. Don't bother!!" - - submorphsToLayout := self submorphsToLayout. - xSep := self xSeparation. - ySep := self ySeparation. - usableHeight := boundsForLayout height - ((submorphsToLayout size + 1) * ySep). - - desiredLayoutHeight _ self desiredLayoutHeight. - normalizationFactor := self proportionalHeightNormalizationFactor. - usableHeight > desiredLayoutHeight - ifTrue: [ - fractionalHeights := submorphsToLayout collect: [ :m | m layoutSpec heightForComfortable: usableHeight*normalizationFactor ]] - ifFalse: [ | sumOfFixedOrMinimum availableForPropHeight | - sumOfFixedOrMinimum := submorphsToLayout sum: [ :m | m minimumLayoutExtent y max: m layoutSpec fixedOrMinimumLayoutHeight ]. - availableForPropHeight := usableHeight - sumOfFixedOrMinimum max: 0. - fractionalHeights := submorphsToLayout collect: [ :m | m layoutSpec heightFor: availableForPropHeight * normalizationFactor ]]. - - "Compute integer widths, mostly rounding but with occasional #floor or #ceiling as needed to keep sum" - integerHeights _ fractionalHeights collect: [ :w | w rounded ]. - diff _ integerHeights sum - fractionalHeights sum rounded. - alternativeHeights _ diff > 0 ifTrue: [ fractionalHeights collect: [ :w | w floor ]] ifFalse: [ fractionalHeights collect: [ :w | w ceiling ]]. - count _ diff abs. - i _ 1. - [ count > 0] whileTrue: [ - (integerHeights at: i) = (alternativeHeights at: i) ifFalse: [ - integerHeights at: i put: (alternativeHeights at: i). - count _ count -1 ]. - i _ i + 1 ]. - minHeight := integerHeights sum. - theTop := ((usableHeight - minHeight) * (padding ifNil: [0]) max: 0) + boundsForLayout top + ySep. - usableWidth := boundsForLayout width - (xSep * 2) max: 0. - boundsLeft := boundsForLayout left + xSep. - boundsBottom := boundsForLayout bottom - ySep. - boundsRight := boundsForLayout right - xSep. - - submorphsToLayout size to: 1 by: -1 do: [ :index | - nextMorph := submorphsToLayout at: index. - "major direction" - ht := integerHeights at: index. - "minor direction" - ls := nextMorph layoutSpec. - wd := (ls widthFor: usableWidth) min: usableWidth. - theLeft := ((usableWidth - wd) * ls minorDirectionPadding) floor + boundsLeft. - theRight := (theLeft + wd) ceiling min: boundsRight. - theBottom := (theTop + (ht min: minHeight)) "ceiling" min: boundsBottom. - "Set bounds and adjust major direction for next step" - self flag: #jmvVer2. "should extent be set in m's coordinate system? what if its scale is not 1?" - ls usesMorphExtent - ifTrue: [ - nextMorph morphPosition: theLeft floor @ theTop floor ] - ifFalse: [ - nextMorph morphPosition: theLeft floor @ theTop floor extent: theRight - theLeft @ (theBottom - theTop) ]. - theTop := theBottom + ySep - ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4155-ProportionalLayoutEnh-JuanVuletich-2020May21-15h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4133] on 9 May 2020 at 4:10:58 pm'! - -"Change Set: 4134-CuisCore-AuthorName-2020May04-19h23m -Date: 9 May 2020 -Author: Nahuel Garbezza - -Main changes: - -Introduce the SourceCodeInterval class as an especialization of Interval, capable of dealing with source code transformations. Start to use SourceCodeInterval in the source ranges reported by the Parser, and on the intervals created on refactorings. This helped us to reduce utilitary methods related source code on the Refactoring and ParseNode classes. - -Changes on refactorings: - -* [extract temporary] allow to extract entire statements without introducing an unnecessary extra statement -* [extract temporary] do not allow the user to extract on a smalltalk editor that does not contain a method -* [extract temporary] change the #apply message to return the updated source code -* [extract method] allow to extract expressions with multiple levels of parentheses and spaces between them"! - -Interval subclass: #SourceCodeInterval - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #SourceCodeInterval category: #'Compiler-Kernel' stamp: 'Install-4156-SourceCodeRange-NahuelGarbezza-2020May04-19h23m-RNG.001.cs.st 5/26/2020 17:08:34'! -Interval subclass: #SourceCodeInterval - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! -!SourceCodeInterval commentStamp: 'RNG 5/8/2020 22:10:02' prior: 0! - I represent a special case of interval, I refer to source code intervals. There are two main users of me: - -* The debugger (to display which is the current piece of code being debugged) -* Refactorings (to select code for refactoring, validating against other intervals and rewriting code)! -!Interval methodsFor: 'converting' stamp: 'RNG 5/8/2020 20:59:03'! - asSourceCodeInterval - - ^ SourceCodeInterval from: start to: stop! ! -!SourceCodeInterval methodsFor: 'source code' stamp: 'RNG 5/9/2020 15:41:07'! - expandToMatchExpressionOn: aSourceCode - "takes a source code and if the source range references an expression - that can be expanded and still is valid, it returns the source range - 'grown'. Examples: (*3 + 4*) to *(3 + 4)*; `*3 + 4*` to *`3 + 4`*" - - | firstChar lastChar | - firstChar _ aSourceCode at: start - 1 ifAbsent: [ nil ]. - lastChar _ aSourceCode at: stop + 1 ifAbsent: [ nil ]. - ^ (self canBeExpandedStartingWith: firstChar endingWith: lastChar) - ifTrue: [ (self expandBy: 1) expandToMatchExpressionOn: aSourceCode ] - ifFalse: [ self ]! ! -!SourceCodeInterval methodsFor: 'source code' stamp: 'RNG 5/8/2020 21:42:20'! - trimToMatchExpressionOn: aSourceCode - - | startOffset endOffset initialChar endingChar shouldTrimStart shouldTrimEnd shouldTrimBoth | - startOffset := 0. - endOffset := 0. - initialChar := aSourceCode at: start ifAbsent: [ nil ]. - endingChar := aSourceCode at: stop ifAbsent: [ nil ]. - shouldTrimBoth := initialChar = $( and: [ endingChar = $) ]. - shouldTrimStart := self canBeTrimmed: initialChar. - shouldTrimEnd := self canBeTrimmed: endingChar. - (shouldTrimBoth or: [ shouldTrimStart ]) ifTrue: [ startOffset := 1 ]. - (shouldTrimBoth or: [ shouldTrimEnd ]) ifTrue: [ endOffset := 1 ]. - ^ (shouldTrimBoth or: [ shouldTrimStart ] or: [ shouldTrimEnd ]) - ifTrue: [ (self trimLeft: startOffset right: endOffset) trimToMatchExpressionOn: aSourceCode ] - ifFalse: [ self ]! ! -!SourceCodeInterval methodsFor: 'private - source code' stamp: 'RNG 5/9/2020 15:39:55'! - canBeExpandedStartingWith: firstChar endingWith: lastChar - - ^ (firstChar = $( and: [ lastChar = $) ]) or: [ firstChar = $` and: [ lastChar = $` ] ]! ! -!SourceCodeInterval methodsFor: 'private - source code' stamp: 'RNG 5/8/2020 21:30:59'! - canBeTrimmed: initialChar - - ^ initialChar notNil and: [ initialChar isSeparator or: [ initialChar = $. ] ]! ! -!SourceCodeInterval methodsFor: 'private - source code' stamp: 'RNG 5/9/2020 15:38:43'! - expandBy: quantity - - ^ (start - quantity to: stop + quantity) asSourceCodeInterval! ! -!SourceCodeInterval methodsFor: 'private - source code' stamp: 'RNG 5/8/2020 21:41:42'! - trimLeft: startOffset right: endOffset - - ^ (start + startOffset to: stop - endOffset) asSourceCodeInterval! ! -!ParseNode methodsFor: 'source ranges' stamp: 'RNG 5/8/2020 21:59:21'! - expandRange: parentSourceRange basedOnChildRange: childSourceRange - - ^ ((parentSourceRange first min: childSourceRange first) to: parentSourceRange last) asSourceCodeInterval! ! -!MethodNode methodsFor: 'source mapping' stamp: 'RNG 5/6/2020 23:25:56'! - singleCompleteSourceRangeOf: requestedParseNode ifPresent: sourceRangePresentBlock ifAbsent: sourceRangeAbsentBlock - "Finds the source range associated with the requested parse node. - If it is present, evaluates sourceRangePresentBlock with the result. - Otherwise, it evaluates sourceRangeAbsentBlock. - Raises an error if the requested parse node has multiple source ranges" - - self completeSourceRangesDo: [ :parseNode :sourceRanges | - (parseNode equivalentTo: requestedParseNode) ifTrue: [ - sourceRanges size > 1 ifTrue: [ - self error: 'there are multiple source ranges for the parse node: ' , requestedParseNode printString ]. - ^ sourceRangePresentBlock value: sourceRanges first ] ]. - ^ sourceRangeAbsentBlock value! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 5/4/2020 19:29:08'! - addAssignmentToCurrentStatement - - self - insertAt: intervalToExtract first - newCodeWith: newVariableName , ' ' , self preferredAssignmentOperator , ' '! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 5/6/2020 23:20:14'! - extractingAnEntireStatement - - ^ self siblingStatementsOfTemporaryAssignment anySatisfy: [ :statement | - methodNodeToRefactor - singleCompleteSourceRangeOf: statement - ifPresent: [ :sourceRange | sourceRange = intervalToExtract ] - ifAbsent: [ false ] ]! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 5/6/2020 22:46:32'! - positionToInsertNewVariableDeclaration - - ^ (methodNodeToRefactor singleCompleteSourceRangeOf: parseNodeWithNewVariableScope temporariesDeclaration) last - 1! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 5/4/2020 19:32:43'! - resolveNewVariableAssignment - - self extractingAnEntireStatement - ifTrue: [ self addAssignmentToCurrentStatement ] - ifFalse: [ - self - replaceExtractedCodeWithNewTemporaryVariable; - writeAssignmentStatementOfNewTemporaryVariable ]! ! -!ParseNode methodsFor: 'source ranges' stamp: 'RNG 5/8/2020 21:59:47' prior: 50488511! - expandRange: aSourceRange basedOn: sourceRangesOfChildNode - - | intervals | - intervals := self consolidateAsCollection: sourceRangesOfChildNode. - intervals withIndexDo: [ :interval :index | - (interval first > aSourceRange first) ifTrue: [ - ^ self expandRange: aSourceRange basedOnChildRange: (intervals at: index - 1 ifAbsent: [ intervals last ]) ] ]. - ^ self expandRange: aSourceRange basedOnChildRange: intervals last! ! -!ParseNode methodsFor: 'source ranges' stamp: 'RNG 5/9/2020 15:41:07' prior: 50495111! -expandRanges: sourceRanges basedOn: allSourceRanges using: sourceCode - - ^ (self consolidateAsCollection: sourceRanges) - collect: [ :sourceRange | sourceRange expandToMatchExpressionOn: sourceCode ]! ! -!Encoder methodsFor: 'source mapping' stamp: 'RNG 5/8/2020 21:10:16' prior: 50408682! -addMultiRange: aRange for: aNode - - | ranges | - - "I'm using an OrderedCollection because ranges are added in order, while parsing the source code. - If this constrain is not hold, a SortedCollection should be used - Hernan" - ranges := sourceRanges at: aNode ifAbsentPut: [ OrderedCollection new ]. - ranges add: aRange asSourceCodeInterval. - - ^aNode ! ! -!Encoder methodsFor: 'source mapping' stamp: 'RNG 5/8/2020 21:10:23' prior: 16837644! - noteSourceRange: range forNode: node - - sourceRanges at: node put: range asSourceCodeInterval! ! -!BraceNode methodsFor: 'private' stamp: 'RNG 5/6/2020 23:50:26' prior: 50506459! - hasEquivalentElementsTo: aBraceNode - - elements size ~= aBraceNode elements size ifTrue: [ ^ false ]. - - elements with: aBraceNode elements do: [ :myElement :otherElement | - (myElement equivalentTo: otherElement) ifFalse: [ ^ false ] ]. - ^ true! ! -!CascadeNode methodsFor: 'testing' stamp: 'RNG 5/6/2020 23:51:24' prior: 50508653! - hasEquivalentMessagesWith: aCascadeNode - - messages size ~= aCascadeNode messages size ifTrue: [ ^ false ]. - - messages with: aCascadeNode messages do: [ :myMessage :otherNodeMessage | - (myMessage equivalentTo: otherNodeMessage) ifFalse: [ ^ false ] ]. - ^ true! ! -!CodeNode methodsFor: 'private' stamp: 'RNG 5/6/2020 23:52:46' prior: 50506478! - hasEquivalentArgumentsWith: aCodeNode - - self arguments size ~= aCodeNode arguments size ifTrue: [ ^ false ]. - - self arguments with: aCodeNode arguments do: [ :myArgument :otherCodeNodeArgument | - (myArgument equivalentTo: otherCodeNodeArgument) ifFalse: [ ^ false ] ]. - ^ true! ! -!BlockNode methodsFor: 'private' stamp: 'RNG 5/6/2020 23:54:27' prior: 50506513! - hasEquivalentStatementsWith: aBlockNode - - statements size ~= aBlockNode statements size ifTrue: [ ^ false ]. - - statements with: aBlockNode statements do: [ :myStatement :otherBlockNodeStatement | - (myStatement equivalentTo: otherBlockNodeStatement) ifFalse: [ ^ false ] ]. - ^ true! ! -!MethodNode methodsFor: 'source mapping' stamp: 'RNG 5/6/2020 23:24:10' prior: 50506523! - singleCompleteSourceRangeOf: requestedParseNode - "Returns the source range associated with the requested parse node. - Fails if there is no source range, or if there are multiple source ranges." - - self - singleCompleteSourceRangeOf: requestedParseNode - ifPresent: [ :sourceRange | ^ sourceRange ] - ifAbsent: [ self error: 'could not find source range for node: ' , requestedParseNode printString ]! ! -!MessageNode methodsFor: 'private' stamp: 'RNG 5/6/2020 23:53:18' prior: 50506572! - compare: myArguments with: othersArguments - - myArguments size ~= othersArguments size ifTrue: [ ^ false ]. - - myArguments with: othersArguments do: [ :myArgument :otherArgument | - (myArgument equivalentTo: otherArgument) ifFalse: [ ^ false ] ]. - ^ true! ! -!TemporariesDeclarationNode methodsFor: 'testing' stamp: 'RNG 5/6/2020 23:55:08' prior: 50506609! - declaresSameVariablesThan: aTemporariesDeclarationNode - - tempDeclarationNodes size ~= aTemporariesDeclarationNode temporaryDeclarationNodes size ifTrue: [ ^ false ]. - - tempDeclarationNodes with: aTemporariesDeclarationNode temporaryDeclarationNodes do: [ :myTempDeclaration :otherTempDeclaration | - (myTempDeclaration equivalentTo: otherTempDeclaration) ifFalse: [ ^ false ] ]. - ^ true! ! -!SmalltalkEditor methodsFor: 'extract to temporary' stamp: 'RNG 5/8/2020 21:30:47' prior: 50506648! - extractToTemporary - - "To prevent the refactoring to be evaluated on editors w/o methods like the workspace - Nahuel" - self hasValidCurrentCompiledMethod ifFalse: [ ^ nil ]. - - self ifSourceCodeRefactoringCanBeAppliedDo: [ - ExtractToTemporaryApplier createAndValueHandlingExceptions: [ - ExtractToTemporaryApplier - for: self selectionInterval asSourceCodeInterval - of: self codeProvider currentCompiledMethod ] ]! ! -!SmalltalkEditor methodsFor: 'extract method' stamp: 'RNG 5/8/2020 21:30:28' prior: 50507235! - extractMethod - - "To prevent the refactoring to be evaluated on editors w/o methods like the workspace - Nahuel" - self hasValidCurrentCompiledMethod ifFalse: [ ^ nil ]. - - self ifSourceCodeRefactoringCanBeAppliedDo: [ - ExtractMethodApplier createAndValueHandlingExceptions: [ - ExtractMethodApplier - for: self selectionInterval asSourceCodeInterval - of: self codeProvider currentCompiledMethod ] ]! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 5/8/2020 21:12:34' prior: 50489375! - intervalCoversCompleteAstNodes - - ^ (self trimmed: (initialNode value first to: finalNode value last) asSourceCodeInterval) = intervalToExtract! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 5/8/2020 21:12:12' prior: 50507640! - trimmed: aSourceCodeInterval - - ^ aSourceCodeInterval trimToMatchExpressionOn: sourceCode! ! -!ExtractMethod class methodsFor: 'instance creation' stamp: 'RNG 5/8/2020 21:03:17' prior: 50507646! - fromInterval: anIntervalToExtract of: aMethodToExtractCodeFrom to: newMessage categorizedAs: aCategory - - | trimmedIntervalToExtract | - trimmedIntervalToExtract := anIntervalToExtract trimToMatchExpressionOn: aMethodToExtractCodeFrom sourceCode. - self - assert: newMessage selector canBeDefinedIn: aMethodToExtractCodeFrom methodClass; - assert: trimmedIntervalToExtract isValidIntervalOn: aMethodToExtractCodeFrom; - assert: newMessage hasValidParametersForExtracting: anIntervalToExtract from: aMethodToExtractCodeFrom methodNode. - - ^ self new - initializeFrom: trimmedIntervalToExtract - of: aMethodToExtractCodeFrom - to: newMessage - in: aCategory! ! -!ExtractToTemporary methodsFor: 'applying' stamp: 'RNG 5/9/2020 15:12:17' prior: 50506672 overrides: 50438490! - apply - - self - resolveNewVariableAssignment; - declareNewTemporaryVariable; - reflectSourceCodeChanges. - ^ updatedSourceCode! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 5/6/2020 22:46:41' prior: 50506699! - addNewTemporaryVariableToExistingDeclarationStatement - - self - insertAt: self positionToInsertNewVariableDeclaration - newCodeWith: ' ' , newVariableName! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 5/6/2020 23:28:33' prior: 50506806! - reflectSourceCodeChanges - - methodToRefactor methodClass - compile: updatedSourceCode - classified: methodToRefactor category! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 5/6/2020 23:29:53' prior: 50506839! - statementNodeIncludingCodeToExtract - - ^ self siblingStatementsOfTemporaryAssignment detect: [ :statement | - methodNodeToRefactor - singleCompleteSourceRangeOf: statement - ifPresent: [ :sourceRange | sourceRange last >= intervalToExtract last ] - ifAbsent: [ false ] ]! ! -!ExtractToTemporary class methodsFor: 'instance creation' stamp: 'RNG 5/8/2020 21:04:28' prior: 50507671! - named: aNewVariable at: anIntervalToExtract from: aMethodToRefactor - - | trimmedNewVariable trimmedIntervalToExtract codeNodeForNewVariable methodNodeToRefactor | - - self assertCanApplyRefactoringOn: aMethodToRefactor at: anIntervalToExtract. - methodNodeToRefactor := aMethodToRefactor methodNode. - trimmedNewVariable := aNewVariable withBlanksTrimmed. - trimmedIntervalToExtract := anIntervalToExtract trimToMatchExpressionOn: aMethodToRefactor sourceCode. - codeNodeForNewVariable := self methodOrBlockNodeIncluding: anIntervalToExtract in: methodNodeToRefactor. - self newTemporaryPreconditionClass valueFor: trimmedNewVariable in: codeNodeForNewVariable of: methodNodeToRefactor. - - ^ self new - initializeNamed: trimmedNewVariable - extractingCodeAt: trimmedIntervalToExtract - from: aMethodToRefactor - declaringTempIn: codeNodeForNewVariable! ! -!ExtractToTemporary class methodsFor: 'preconditions' stamp: 'RNG 5/8/2020 21:04:18' prior: 50508778! - assertCanApplyRefactoringOn: aMethodToRefactor at: anIntervalToExtract - - | trimmedSourceCodeToExtract methodNodeToExtract sourceCodeToExtract trimmedIntervalToExtract originalSourceCode | - - self assert: anIntervalToExtract isValidIntervalOn: aMethodToRefactor. - originalSourceCode := aMethodToRefactor sourceCode. - sourceCodeToExtract := originalSourceCode copyFrom: anIntervalToExtract first to: anIntervalToExtract last. - trimmedSourceCodeToExtract := sourceCodeToExtract withBlanksTrimmed. - trimmedIntervalToExtract := anIntervalToExtract trimToMatchExpressionOn: originalSourceCode. - self assertSourceCodeIsNotEmpty: trimmedSourceCodeToExtract. - methodNodeToExtract := self tryToParse: trimmedSourceCodeToExtract on: aMethodToRefactor methodClass. - self - assertHasOneStatement: methodNodeToExtract; - assertIsNotReturn: trimmedSourceCodeToExtract; - assert: trimmedIntervalToExtract enclosesACompleteExpressionOn: aMethodToRefactor; - assert: trimmedIntervalToExtract enclosesAValidNodeOn: aMethodToRefactor! ! -!ExtractToTemporary class methodsFor: 'private - preconditions' stamp: 'RNG 5/8/2020 21:04:03' prior: 50507736! - anySourceRangeOf: aMethodToRefactor matches: anIntervalToExtract - - | sourceRangeCollections allSourceRanges sourceCode | - sourceRangeCollections := aMethodToRefactor methodNode completeSourceRanges values. - allSourceRanges := sourceRangeCollections - inject: Set new - into: [ :sourceRanges :sourceRangeCollection | sourceRanges addAll: sourceRangeCollection; yourself ]. - sourceCode := aMethodToRefactor sourceCode. - ^ allSourceRanges anySatisfy: [ :sourceRange | - (sourceRange trimToMatchExpressionOn: sourceCode) = anIntervalToExtract ]! ! -!ExtractMethodApplier class methodsFor: 'instance creation' stamp: 'RNG 5/8/2020 21:03:23' prior: 50507757! - for: anIntervalToExtract of: aMethodToExtractCodeFrom - - | trimmedIntervalToExtract sourceCode | - sourceCode := aMethodToExtractCodeFrom sourceCode. - trimmedIntervalToExtract := anIntervalToExtract trimToMatchExpressionOn: sourceCode.. - - self assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: trimmedIntervalToExtract. - - ^ self new initializeFor: trimmedIntervalToExtract of: aMethodToExtractCodeFrom! ! - -ExtractToTemporary removeSelector: #lastTemporaryDeclaration! - -!methodRemoval: ExtractToTemporary #lastTemporaryDeclaration stamp: 'Install-4156-SourceCodeRange-NahuelGarbezza-2020May04-19h23m-RNG.001.cs.st 5/26/2020 17:08:34'! -lastTemporaryDeclaration - - ^ parseNodeWithNewVariableScope temporariesDeclaration temporaryDeclarationNodes last! - -Refactoring class removeSelector: #trim:toMatchExpressionOn:! - -!methodRemoval: Refactoring class #trim:toMatchExpressionOn: stamp: 'Install-4156-SourceCodeRange-NahuelGarbezza-2020May04-19h23m-RNG.001.cs.st 5/26/2020 17:08:34'! -trim: anInterval toMatchExpressionOn: aSourceCode - - | trimmedInterval | - trimmedInterval := anInterval. - [ self shouldTrimToMatchExpressionOn: aSourceCode atIndex: trimmedInterval first ] - whileTrue: [ trimmedInterval := trimmedInterval first + 1 to: trimmedInterval last ]. - [ self shouldTrimToMatchExpressionOn: aSourceCode atIndex: trimmedInterval last ] - whileTrue: [ trimmedInterval := trimmedInterval first to: trimmedInterval last - 1 ]. - - ^ self trim: trimmedInterval matchingParenthesesOn: aSourceCode! - -Refactoring class removeSelector: #trim:matchingParenthesesOn:! - -!methodRemoval: Refactoring class #trim:matchingParenthesesOn: stamp: 'Install-4156-SourceCodeRange-NahuelGarbezza-2020May04-19h23m-RNG.001.cs.st 5/26/2020 17:08:34'! -trim: anInterval matchingParenthesesOn: aSourceCode - - | trimmedInterval | - trimmedInterval := anInterval. - [ - | initialChar endingChar | - initialChar := aSourceCode at: trimmedInterval first ifAbsent: [ nil ]. - endingChar := aSourceCode at: trimmedInterval last ifAbsent: [ nil ]. - initialChar = $( and: [ endingChar = $) ] - ] - whileTrue: [ trimmedInterval _ trimmedInterval first + 1 to: trimmedInterval last - 1 ]. - ^ trimmedInterval! - -Refactoring class removeSelector: #shouldTrimToMatchExpressionOn:atIndex:! - -!methodRemoval: Refactoring class #shouldTrimToMatchExpressionOn:atIndex: stamp: 'Install-4156-SourceCodeRange-NahuelGarbezza-2020May04-19h23m-RNG.001.cs.st 5/26/2020 17:08:34'! -shouldTrimToMatchExpressionOn: sourceCode atIndex: currentIndex - - | currentChar | - currentChar := sourceCode at: currentIndex ifAbsent: [ ^ false ]. - ^ currentChar isSeparator or: [ currentChar = $. ] -! - -ParseNode removeSelector: #expandIfEnclosed:on:! - -!methodRemoval: ParseNode #expandIfEnclosed:on: stamp: 'Install-4156-SourceCodeRange-NahuelGarbezza-2020May04-19h23m-RNG.001.cs.st 5/26/2020 17:08:34'! -expandIfEnclosed: sourceRange on: sourceCode - "takes a source range and a source code and if the source range represents an - expression that can be expanded and still is valid, it returns the source range - 'grown'. Examples: (*3 + 4*) to *(3 + 4)*; `*3 + 4*` to *`3 + 4`*" - - | firstChar lastChar | - firstChar _ sourceCode at: sourceRange first - 1 ifAbsent: [ nil ]. - lastChar _ sourceCode at: sourceRange last + 1 ifAbsent: [ nil ]. - ^ ((firstChar = $( and: [ lastChar = $) ]) - or: [ firstChar = $` and: [ lastChar = $` ] ]) - ifTrue: [ sourceRange first - 1 to: sourceRange last + 1 ] - ifFalse: [ sourceRange ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4156-SourceCodeRange-NahuelGarbezza-2020May04-19h23m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4156] on 21 May 2020 at 5:06:14 pm'! -!SequenceableCollection methodsFor: 'accessing' stamp: 'HAW 5/21/2020 16:56:01'! - firstAvailable: numberOfObjects - "Answer the first numberOfObjects in the receiver, subject to availability" - - ^self first: (numberOfObjects min: self size)! ! -!SequenceableCollection methodsFor: 'accessing' stamp: 'HAW 5/21/2020 16:56:32'! - lastAvailable: numberOfObjects - "Answer the last numberOfObjects in the receiver, subject to availability" - - ^self last: (numberOfObjects min: self size)! ! - -SequenceableCollection removeSelector: #head:! - -!methodRemoval: SequenceableCollection #head: stamp: 'Install-4157-headToFirstAvailableRename-HernanWilkinson-2020May21-16h50m-HAW.001.cs.st 5/26/2020 17:08:34'! -head: anInteger - "Answer the first anInteger objects in the receiver, subject to availability" - - ^self first: (anInteger min: self size)! - -SequenceableCollection removeSelector: #tail:! - -!methodRemoval: SequenceableCollection #tail: stamp: 'Install-4157-headToFirstAvailableRename-HernanWilkinson-2020May21-16h50m-HAW.001.cs.st 5/26/2020 17:08:34'! -tail: anInteger - "Answer the last anInteger objects in the receiver, subject to availability" - - ^self last: (anInteger min: self size)! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4157-headToFirstAvailableRename-HernanWilkinson-2020May21-16h50m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4156] on 21 May 2020 at 5:35:24 pm'! -!SequenceableCollection methodsFor: 'accessing' stamp: 'HAW 5/21/2020 17:34:06'! - head: anInteger - "Answer the first anInteger objects in the receiver, subject to availability" - - ^self firstAvailable: anInteger ! ! -!SequenceableCollection methodsFor: 'accessing' stamp: 'HAW 5/21/2020 17:34:34'! - tail: anInteger - "Answer the last anInteger objects in the receiver, subject to availability" - - ^self lastAvailable: anInteger ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4158-headTail-HernanWilkinson-2020May21-17h06m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4158] on 21 May 2020 at 5:47:22 pm'! -!Compiler methodsFor: 'public access' stamp: 'HAW 3/11/2019 09:04:53'! - compileDoIt: textOrStream in: aClass context: aContext notifying: aRequestor ifFail: failBlock - "Similar to #compile:in:notifying:ifFail:, but the compiled code is - expected to be a do-it expression, with no message pattern." - - self from: textOrStream - class: aClass - context: aContext - notifying: aRequestor. - ^self - translate: sourceStream - noPattern: false - doIt: true - ifFail: failBlock! ! -!Compiler methodsFor: 'private' stamp: 'jmv 4/17/2019 15:15:58'! - translate: aStream noPattern: noPattern doIt: doIt ifFail: failBlock - - ^self parser - ignoreBacktick: false; - parse: aStream - class: class - category: category - noPattern: noPattern - doIt: doIt - context: context - notifying: requestor - ifFail: [^failBlock value]! ! -!Parser methodsFor: 'expression types' stamp: 'RNG 3/13/2020 00:27:50'! - method: noPattern doIt: doIt context: ctxt - " pattern [ | temporaries ] block => MethodNode." - - | sap block primitives tempsDeclarationNode messageComment methodNode | - - sap := self pattern: noPattern inContext: ctxt. - "sap={selector, arguments, precedence}" - self properties selector: (sap at: 1). - encoder selector: (sap at: 1). - (sap at: 2) do: [:argNode | argNode beMethodArg]. - - doIt ifFalse: [self pragmaSequence]. - tempsDeclarationNode := self temporaries. - messageComment := currentComment. - currentComment := nil. - doIt ifFalse: [self pragmaSequence]. - primitives := self pragmaPrimitives. - - self statements: #() innerBlock: doIt. - block := parseNode. - doIt - ifTrue: [block returnLast] - ifFalse: [block returnSelfIfNoOther: encoder]. - hereType == #doIt ifFalse: [^self expected: 'Nothing more']. - - methodNode := self newMethodNode comment: messageComment. - methodNode - selector: (sap at: 1) - arguments: (sap at: 2) - precedence: (sap at: 3) - temporariesDeclaration: tempsDeclarationNode - block: block - encoder: encoder - primitive: primitives - properties: properties - selectorKeywordsRanges: (sap at: 4). - - self interactive ifTrue: [ self performInteractiveChecks: methodNode ]. - - ^methodNode! ! -!Parser methodsFor: 'public access' stamp: 'jmv 4/17/2019 15:17:07'! - parse: sourceStream class: class category: aCategory noPattern: noPattern doIt: doIt context: aContext notifying: aRequestor ifFail: aBlock - - "Answer a MethodNode for the argument, sourceStream, that is the root of - a parse tree. Parsing is done with respect to the argument, class, to find - instance, class, and pool variables; and with respect to the argument, - ctxt, to find temporary variables. Errors in parsing are reported to the - argument, req, if not nil; otherwise aBlock is evaluated. The argument - noPattern is a Boolean that is true if the the sourceStream does not - contain a method header (i.e., for DoIts)." - - | methNode repeatNeeded myStream sourceCode startPosition | - - category _ aCategory. - myStream _ sourceStream. - [ - repeatNeeded _ false. - startPosition _ myStream position. - sourceCode _ myStream upToEnd. - myStream position: startPosition. - self encoder init: class context: aContext notifying: self. - self init: myStream notifying: aRequestor failBlock: [^ aBlock value ]. - doitFlag _ noPattern. - failBlock _ aBlock. - [ methNode _ self method: noPattern doIt: doIt context: aContext ] - on: ReparseAfterSourceEditing - do: [ :ex | - repeatNeeded _ true. - myStream _ ReadStream on: requestor text string ]. - repeatNeeded - ] whileTrue: [ encoder _ self encoder class new ]. - - methNode sourceText: sourceCode. - "See #xBacktick" - sentInLiterals do: [ :sym | encoder noteOptimizedSelector: sym ]. - - ^ methNode! ! -!Compiler methodsFor: 'private' stamp: 'HAW 3/11/2019 07:07:06' prior: 50511201! - translate: aStream noPattern: noPattern ifFail: failBlock - - ^self translate: aStream noPattern: noPattern doIt: noPattern ifFail: failBlock ! ! -!Parser methodsFor: 'public access' stamp: 'HAW 3/11/2019 08:31:06' prior: 50511212! - parse: sourceStream class: class noPattern: noPattern context: aContext notifying: aRequestor ifFail: aBlock - - ^self parse: sourceStream class: class category: nil noPattern: noPattern doIt: noPattern context: aContext notifying: aRequestor ifFail: aBlock ! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'jmv 4/17/2019 15:15:33' prior: 50511223! - compileSelectionFor: anObject in: evalContext ifFail: failBlock - - | methodNode method sourceCode compiler | - - sourceCode := self selectionDoItSourceCodeIn: evalContext. - - methodNode _ [ - compiler _ Compiler new. - compiler - compileDoIt: sourceCode - in: anObject class - context: evalContext - notifying: self - ifFail: [ ^ failBlock value ]] - on: OutOfScopeNotification - do: [ :ex | ex resume: true ]. - - methodNode block returnLast. - method _ methodNode generate. - method methodNode: methodNode. - - ^{ #method -> method. #compiler -> compiler } asDictionary -! ! - -Parser removeSelector: #parse:class:category:noPattern:context:notifying:ifFail:! - -!methodRemoval: Parser #parse:class:category:noPattern:context:notifying:ifFail: stamp: 'Install-4159-rollback-4152-JuanVuletich-2020May21-17h46m-jmv.001.cs.st 5/26/2020 17:08:34'! -parse: sourceStream class: class category: aCategory noPattern: noPattern context: aContext notifying: aRequestor ifFail: aBlock - - "Answer a MethodNode for the argument, sourceStream, that is the root of - a parse tree. Parsing is done with respect to the argument, class, to find - instance, class, and pool variables; and with respect to the argument, - ctxt, to find temporary variables. Errors in parsing are reported to the - argument, req, if not nil; otherwise aBlock is evaluated. The argument - noPattern is a Boolean that is true if the the sourceStream does not - contain a method header (i.e., for DoIts)." - - | methNode repeatNeeded myStream sourceCode startPosition | - - category _ aCategory. - myStream _ sourceStream. - [ - repeatNeeded _ false. - startPosition _ myStream position. - sourceCode _ myStream upToEnd. - myStream position: startPosition. - self encoder init: class context: aContext notifying: self. - self init: myStream notifying: aRequestor failBlock: [^ aBlock value ]. - doitFlag _ noPattern. - failBlock _ aBlock. - [ methNode _ self method: noPattern context: aContext ] - on: ReparseAfterSourceEditing - do: [ :ex | - repeatNeeded _ true. - myStream _ ReadStream on: requestor text string ]. - repeatNeeded - ] whileTrue: [ encoder _ self encoder class new ]. - - methNode sourceText: sourceCode. - "See #xBacktick" - sentInLiterals do: [ :sym | encoder noteOptimizedSelector: sym ]. - - ^ methNode! - -Parser removeSelector: #method:context:! - -!methodRemoval: Parser #method:context: stamp: 'Install-4159-rollback-4152-JuanVuletich-2020May21-17h46m-jmv.001.cs.st 5/26/2020 17:08:34'! -method: noPattern context: ctxt - " pattern [ | temporaries ] block => MethodNode." - - | sap block primitives tempsDeclarationNode messageComment methodNode | - - sap := self pattern: noPattern inContext: ctxt. - "sap={selector, arguments, precedence}" - self properties selector: (sap at: 1). - encoder selector: (sap at: 1). - (sap at: 2) do: [:argNode | argNode beMethodArg]. - - noPattern ifFalse: [self pragmaSequence]. - tempsDeclarationNode := self temporaries. - messageComment := currentComment. - currentComment := nil. - noPattern ifFalse: [self pragmaSequence]. - primitives := self pragmaPrimitives. - - self statements: #() innerBlock: noPattern. - block := parseNode. - noPattern - ifTrue: [block returnLast] - ifFalse: [block returnSelfIfNoOther: encoder]. - hereType == #doIt ifFalse: [^self expected: 'Nothing more']. - - methodNode := self newMethodNode comment: messageComment. - methodNode - selector: (sap at: 1) - arguments: (sap at: 2) - precedence: (sap at: 3) - temporariesDeclaration: tempsDeclarationNode - block: block - encoder: encoder - primitive: primitives - properties: properties - selectorKeywordsRanges: (sap at: 4). - - self interactive ifTrue: [ self performInteractiveChecks: methodNode ]. - - ^methodNode! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4159-rollback-4152-JuanVuletich-2020May21-17h46m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4159] on 21 May 2020 at 6:36:14 pm'! -!LayoutSpec methodsFor: 'accessing' stamp: 'jmv 5/21/2020 18:18:34'! - fixedHeight - ^proportionalHeight isNil ifTrue: [fixedHeight ifNil: [morph morphHeight]] ifFalse: [ 0 ]! ! -!LayoutSpec methodsFor: 'accessing' stamp: 'jmv 5/21/2020 18:13:55'! - fixedWidth - ^proportionalWidth isNil ifTrue: [ fixedWidth ] ifFalse: [ 0 ]! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 5/21/2020 18:35:44' prior: 50512082! - layoutSubmorphsVerticallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - | xSep ySep usableHeight normalizationFactor - fractionalHeights integerHeights theTop usableWidth boundsLeft boundsBottom theLeft minHeight submorphsToLayout - nextMorph ht wd ls theBottom boundsRight theRight alternativeHeights count diff i desiredLayoutHeight | - - boundsForLayout extent > `2@2` "self minimumExtent" - ifFalse: [ ^self ]. "Too small. Don't bother!!" - - submorphsToLayout := self submorphsToLayout. - xSep := self xSeparation. - ySep := self ySeparation. - usableHeight := boundsForLayout height - ((submorphsToLayout size + 1) * ySep). - - desiredLayoutHeight _ self desiredLayoutHeight. - normalizationFactor := self proportionalHeightNormalizationFactor. - usableHeight > desiredLayoutHeight - ifTrue: [ | sumOfFixed | - sumOfFixed := submorphsToLayout sum: [ :m | m layoutSpec fixedHeight ]. - {usableHeight*normalizationFactor - sumOfFixed. usableHeight*normalizationFactor. usableHeight.normalizationFactor. sumOfFixed} print. - fractionalHeights := submorphsToLayout collect: [ :m | m layoutSpec heightForComfortable: usableHeight - sumOfFixed * normalizationFactor]. - fractionalHeights print. - ] - ifFalse: [ | sumOfFixedOrMinimum availableForPropHeight | - sumOfFixedOrMinimum := submorphsToLayout sum: [ :m | m minimumLayoutExtent y max: m layoutSpec fixedOrMinimumLayoutHeight ]. - availableForPropHeight := usableHeight - sumOfFixedOrMinimum max: 0. - fractionalHeights := submorphsToLayout collect: [ :m | m layoutSpec heightFor: availableForPropHeight * normalizationFactor ]]. - - "Compute integer widths, mostly rounding but with occasional #floor or #ceiling as needed to keep sum" - integerHeights _ fractionalHeights collect: [ :w | w rounded ]. - diff _ integerHeights sum - fractionalHeights sum rounded. - alternativeHeights _ diff > 0 ifTrue: [ fractionalHeights collect: [ :w | w floor ]] ifFalse: [ fractionalHeights collect: [ :w | w ceiling ]]. - count _ diff abs. - i _ 1. - [ count > 0] whileTrue: [ - (integerHeights at: i) = (alternativeHeights at: i) ifFalse: [ - integerHeights at: i put: (alternativeHeights at: i). - count _ count -1 ]. - i _ i + 1 ]. - minHeight := integerHeights sum. - theTop := ((usableHeight - minHeight) * (padding ifNil: [0]) max: 0) + boundsForLayout top + ySep. - usableWidth := boundsForLayout width - (xSep * 2) max: 0. - boundsLeft := boundsForLayout left + xSep. - boundsBottom := boundsForLayout bottom - ySep. - boundsRight := boundsForLayout right - xSep. - - submorphsToLayout size to: 1 by: -1 do: [ :index | - nextMorph := submorphsToLayout at: index. - "major direction" - ht := integerHeights at: index. - "minor direction" - ls := nextMorph layoutSpec. - wd := (ls widthFor: usableWidth) min: usableWidth. - theLeft := ((usableWidth - wd) * ls minorDirectionPadding) floor + boundsLeft. - theRight := (theLeft + wd) ceiling min: boundsRight. - theBottom := (theTop + (ht min: minHeight)) "ceiling" min: boundsBottom. - "Set bounds and adjust major direction for next step" - self flag: #jmvVer2. "should extent be set in m's coordinate system? what if its scale is not 1?" - ls usesMorphExtent - ifTrue: [ - nextMorph morphPosition: theLeft floor @ theTop floor ] - ifFalse: [ - nextMorph morphPosition: theLeft floor @ theTop floor extent: theRight - theLeft @ (theBottom - theTop) ]. - theTop := theBottom + ySep - ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4160-ProportionalLayoutFix-JuanVuletich-2020May21-18h09m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4160] on 21 May 2020 at 6:53:25 pm'! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 5/21/2020 18:39:54' prior: 50511982! - layoutSubmorphsHorizontallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - | xSep ySep usableWidth normalizationFactor - fractionalWidths integerWidths theLeft usableHeight boundsTop boundsRight theTop minWidth submorphsToLayout - nextMorph ht wd ls theRight boundsBottom theBottom alternativeWidths count diff i desiredLayoutWidth | - - boundsForLayout extent > `2@2` "self minimumExtent" - ifFalse: [ ^self ]. "Too small. Don't bother!!" - - submorphsToLayout := self submorphsToLayout. - xSep := self xSeparation. - ySep := self ySeparation. - usableWidth := boundsForLayout width - ((submorphsToLayout size + 1) * xSep). - - desiredLayoutWidth _ self desiredLayoutWidth. - normalizationFactor := self proportionalWidthNormalizationFactor. - usableWidth > desiredLayoutWidth - ifTrue: [ | sumOfFixed | - sumOfFixed := submorphsToLayout sum: [ :m | m layoutSpec fixedWidth ]. - fractionalWidths := submorphsToLayout collect: [ :m | m layoutSpec widthForComfortable: usableWidth-sumOfFixed * normalizationFactor]] - ifFalse: [ | sumOfFixedOrMinimum availableForPropWidth | - sumOfFixedOrMinimum := submorphsToLayout sum: [ :m | m minimumLayoutExtent x max: m layoutSpec fixedOrMinimumLayoutWidth ]. - availableForPropWidth := usableWidth - sumOfFixedOrMinimum max: 0. - fractionalWidths := submorphsToLayout collect: [ :m | m layoutSpec widthFor: availableForPropWidth * normalizationFactor ]]. - "Compute integer widths, mostly rounding but with occasional #floor or #ceiling as needed to keep sum" - integerWidths _ fractionalWidths collect: [ :w | w rounded ]. - diff _ integerWidths sum - fractionalWidths sum rounded. - alternativeWidths _ diff > 0 ifTrue: [ fractionalWidths collect: [ :w | w floor ]] ifFalse: [ fractionalWidths collect: [ :w | w ceiling ]]. - count _ diff abs. - i _ 1. - [ count > 0] whileTrue: [ - (integerWidths at: i) = (alternativeWidths at: i) ifFalse: [ - integerWidths at: i put: (alternativeWidths at: i). - count _ count -1 ]. - i _ i + 1 ]. - minWidth := integerWidths sum. - theLeft := ((usableWidth - minWidth) * (padding ifNil: [0]) max: 0) + boundsForLayout left + xSep. - usableHeight := boundsForLayout height - (ySep * 2) max: 0. - boundsTop := boundsForLayout top + ySep. - boundsRight := boundsForLayout right - xSep. - boundsBottom := boundsForLayout bottom - ySep. - - submorphsToLayout size to: 1 by: -1 do: [ :index | - nextMorph := submorphsToLayout at: index. - "major direction" - wd := integerWidths at: index. - "minor direction" - ls := nextMorph layoutSpec. - ht := (ls heightFor: usableHeight) min: usableHeight. - theTop := ((usableHeight - ht) * ls minorDirectionPadding) floor + boundsTop. - theBottom := (theTop + ht) ceiling min: boundsBottom. - theRight := (theLeft + (wd min: minWidth)) "ceiling "min: boundsRight. - "Set bounds and adjust major direction for next step" - self flag: #jmvVer2. "should extent be set in m's coordinate system? what if its scale is not 1?" - ls usesMorphExtent - ifTrue: [ - nextMorph morphPosition: theLeft floor @ theTop floor ] - ifFalse: [ - nextMorph morphPosition: theLeft floor @ theTop floor extent: theRight - theLeft @ (theBottom - theTop) ]. - theLeft := theRight + xSep - ]! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 5/21/2020 18:39:48' prior: 50513186! - layoutSubmorphsVerticallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - | xSep ySep usableHeight normalizationFactor - fractionalHeights integerHeights theTop usableWidth boundsLeft boundsBottom theLeft minHeight submorphsToLayout - nextMorph ht wd ls theBottom boundsRight theRight alternativeHeights count diff i desiredLayoutHeight | - - boundsForLayout extent > `2@2` "self minimumExtent" - ifFalse: [ ^self ]. "Too small. Don't bother!!" - - submorphsToLayout := self submorphsToLayout. - xSep := self xSeparation. - ySep := self ySeparation. - usableHeight := boundsForLayout height - ((submorphsToLayout size + 1) * ySep). - - desiredLayoutHeight _ self desiredLayoutHeight. - normalizationFactor := self proportionalHeightNormalizationFactor. - usableHeight > desiredLayoutHeight - ifTrue: [ | sumOfFixed | - sumOfFixed := submorphsToLayout sum: [ :m | m layoutSpec fixedHeight ]. - fractionalHeights := submorphsToLayout collect: [ :m | m layoutSpec heightForComfortable: usableHeight-sumOfFixed * normalizationFactor]] - ifFalse: [ | sumOfFixedOrMinimum availableForPropHeight | - sumOfFixedOrMinimum := submorphsToLayout sum: [ :m | m minimumLayoutExtent y max: m layoutSpec fixedOrMinimumLayoutHeight ]. - availableForPropHeight := usableHeight - sumOfFixedOrMinimum max: 0. - fractionalHeights := submorphsToLayout collect: [ :m | m layoutSpec heightFor: availableForPropHeight * normalizationFactor ]]. - - "Compute integer widths, mostly rounding but with occasional #floor or #ceiling as needed to keep sum" - integerHeights _ fractionalHeights collect: [ :w | w rounded ]. - diff _ integerHeights sum - fractionalHeights sum rounded. - alternativeHeights _ diff > 0 ifTrue: [ fractionalHeights collect: [ :w | w floor ]] ifFalse: [ fractionalHeights collect: [ :w | w ceiling ]]. - count _ diff abs. - i _ 1. - [ count > 0] whileTrue: [ - (integerHeights at: i) = (alternativeHeights at: i) ifFalse: [ - integerHeights at: i put: (alternativeHeights at: i). - count _ count -1 ]. - i _ i + 1 ]. - minHeight := integerHeights sum. - theTop := ((usableHeight - minHeight) * (padding ifNil: [0]) max: 0) + boundsForLayout top + ySep. - usableWidth := boundsForLayout width - (xSep * 2) max: 0. - boundsLeft := boundsForLayout left + xSep. - boundsBottom := boundsForLayout bottom - ySep. - boundsRight := boundsForLayout right - xSep. - - submorphsToLayout size to: 1 by: -1 do: [ :index | - nextMorph := submorphsToLayout at: index. - "major direction" - ht := integerHeights at: index. - "minor direction" - ls := nextMorph layoutSpec. - wd := (ls widthFor: usableWidth) min: usableWidth. - theLeft := ((usableWidth - wd) * ls minorDirectionPadding) floor + boundsLeft. - theRight := (theLeft + wd) ceiling min: boundsRight. - theBottom := (theTop + (ht min: minHeight)) "ceiling" min: boundsBottom. - "Set bounds and adjust major direction for next step" - self flag: #jmvVer2. "should extent be set in m's coordinate system? what if its scale is not 1?" - ls usesMorphExtent - ifTrue: [ - nextMorph morphPosition: theLeft floor @ theTop floor ] - ifFalse: [ - nextMorph morphPosition: theLeft floor @ theTop floor extent: theRight - theLeft @ (theBottom - theTop) ]. - theTop := theBottom + ySep - ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4161-YAlayoutFix-JuanVuletich-2020May21-18h53m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4161] on 21 May 2020 at 7:47:20 pm'! -!LayoutSpec methodsFor: 'accessing' stamp: 'jmv 5/21/2020 19:46:50' prior: 50513180! - fixedWidth - ^proportionalWidth isNil ifTrue: [fixedWidth ifNil: [morph morphWidth]] ifFalse: [ 0 ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4162-yetAnotherLayoutFix-JuanVuletich-2020May21-19h46m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4162] on 21 May 2020 at 10:31:06 pm'! -!BoxedFloat64 methodsFor: 'truncation and round off' stamp: 'jmv 5/21/2020 22:23:44' prior: 50468072 overrides: 16880628! - truncated - "Answer with a SmallInteger equal to the value of the receiver without - its fractional part. The primitive fails if the truncated value cannot be - represented as a SmallInteger. In that case, the code below will compute - a LargeInteger truncated value. - Raise an exception if no conversion to integer is possible, i.e. for Infinities and NaN. - Essential. See Object documentation whatIsAPrimitive. " - - - self isFinite ifFalse: [ ^self ]. - ^ self partValues: [ :sign :exponent :mantissa | - sign * (mantissa bitShift: exponent - 52) ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4163-InfinityAndNaN-truncated-fix-JuanVuletich-2020May21-22h30m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4163] on 23 May 2020 at 8:51:22 pm'! - -BorderedRectMorph subclass: #StringRequestMorph - instanceVariableNames: 'response acceptBlock cancelBlock validationBlock' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #StringRequestMorph category: #'Morphic-Widgets' stamp: 'Install-4164-NonModalStringRequests-LucianoEstebanNotarfrancesco-2020May23-20h43m-len.001.cs.st 5/26/2020 17:08:34'! -BorderedRectMorph subclass: #StringRequestMorph - instanceVariableNames: 'response acceptBlock cancelBlock validationBlock' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -StringRequestMorph subclass: #ClassNameRequestMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #ClassNameRequestMorph category: #'Morphic-Widgets' stamp: 'Install-4164-NonModalStringRequests-LucianoEstebanNotarfrancesco-2020May23-20h43m-len.001.cs.st 5/26/2020 17:08:34'! -StringRequestMorph subclass: #ClassNameRequestMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! -!Object methodsFor: 'user interface' stamp: 'len 5/20/2020 04:00:44'! - request: queryString do: aBlock - ^ self request: queryString initialAnswer: '' verifying: [:aString| true] do: aBlock orCancel: []! ! -!Object methodsFor: 'user interface' stamp: 'len 5/20/2020 06:32:35'! - request: queryString initialAnswer: defaultAnswer - "This is deprecated because using it requires blocking the user interface until the user provides a response. Please use the variants that are not modal." - ^ self request: queryString initialAnswer: defaultAnswer orCancel: ['']! ! -!Object methodsFor: 'user interface' stamp: 'len 5/20/2020 04:11:48'! -request: queryString initialAnswer: defaultAnswer do: aBlock - ^ self request: queryString initialAnswer: defaultAnswer verifying: [:aString| true] do: aBlock orCancel: []! ! -!Object methodsFor: 'user interface' stamp: 'len 5/20/2020 03:59:45'! - request: queryString initialAnswer: defaultAnswer do: aBlock orCancel: cancelBlock - ^ self request: queryString initialAnswer: defaultAnswer verifying: [:aString| true] do: aBlock orCancel: cancelBlock! ! -!Object methodsFor: 'user interface' stamp: 'len 5/20/2020 04:50:27'! - request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock - "This is deprecated because using it requires blocking the user interface until the user provides a response. Please use the variants that are not modal." - ^ StringRequestMorph request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock! ! -!Object methodsFor: 'user interface' stamp: 'len 5/20/2020 07:37:39'! - request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock - ^ self request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: []! ! -!Object methodsFor: 'user interface' stamp: 'len 5/20/2020 07:38:05'! - request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock - ^ StringRequestMorph request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock! ! -!StringRequestMorph methodsFor: 'accessing' stamp: 'len 5/19/2020 06:58:15'! - emptyTextDisplayMessage: aString - self - setProperty: #emptyTextDisplayMessage - toValue: aString.! ! -!StringRequestMorph methodsFor: 'accessing' stamp: 'len 5/19/2020 08:23:39'! - response - ^ response -! ! -!StringRequestMorph methodsFor: 'accessing' stamp: 'len 5/20/2020 04:06:50'! - response: aText - "Sent when text pane accepts." - response _ aText. - validationBlock ifNotNil: [(validationBlock value: aText asString) ifFalse: [self flash. ^ false]]. - [acceptBlock ifNotNil: [acceptBlock value: aText asString]] ensure: [self delete]. - ^ true! ! -!StringRequestMorph methodsFor: 'drawing' stamp: 'len 5/19/2020 06:59:55' overrides: 16790395! - drawOn: aCanvas - - | roundCorners | - roundCorners _ Theme current roundWindowCorners. - roundCorners - ifTrue: [ - aCanvas roundRect: self morphLocalBounds color: color radius: Theme current roundedWindowRadius ] - ifFalse: [ - aCanvas fillRectangle: self morphLocalBounds color: color borderWidth: borderWidth borderStyleSymbol: #raised baseColorForBorder: color ]! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'len 5/20/2020 04:03:27'! - acceptBlock: aBlock - acceptBlock _ aBlock! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'len 5/20/2020 09:00:16'! - addTextPane - | result | - result _ (TextModelMorph - textProvider: self - textGetter: #response - textSetter: #response: - selectionGetter: #selectionInterval) emptyTextDisplayMessage: 'Enter response'. - self - valueOfProperty: #emptyTextDisplayMessage - ifPresentDo: [ :msg | - result emptyTextDisplayMessage: msg ]. - result - hasUnacceptedEdits: true; - acceptOnCR: true; - escAction: [ self cancel ]. - "If the initial response is big or has multiple lines we make the text pane bigger and with scrollbars:" - (response size > 20 or: [response includes: Character lf]) - ifTrue: [result morphExtent: 32 @ 3 * AbstractFont default lineSpacing] - ifFalse: - [result hideScrollBarsIndefinitely; - morphExtent: 18 @ 1 * AbstractFont default lineSpacing + (0@8).]. - self addMorphBack: result. - ^ result.! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'len 5/19/2020 08:18:15'! - addTitle: aString - | titleMorph s pp w | - titleMorph _ RectangleLikeMorph new. - titleMorph color: Theme current menuTitleBar. - pp _ `8@2`. - aString asString linesDo: [ :line | - s _ StringMorph new - contents: line; - font: Preferences standardMenuFont bold. - titleMorph addMorphBack: s position: pp. - pp _ pp + (0@(s morphHeight+2)) ]. - w _ titleMorph submorphs inject: 0 into: [ :prev :each | - prev max: each morphWidth ]. - titleMorph morphExtent: (w + 16) @ (pp y). - self addMorphFront: titleMorph.! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'len 5/20/2020 04:03:33'! - cancelBlock: aBlock - cancelBlock _ aBlock! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'len 5/19/2020 07:00:19' overrides: 16790416! - defaultBorderWidth - ^ (Theme current roundWindowCorners or: [Theme current minimalWindows]) - ifTrue: [0] - ifFalse: [Preferences menuBorderWidth]! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'len 5/19/2020 07:00:42' overrides: 50387680! - defaultColor - ^ Theme current menu! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'len 5/20/2020 08:54:26' overrides: 16790421! - initialize - super initialize. - extent _ `20@10`. - response _ ''! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'len 5/19/2020 19:27:25' overrides: 16875917! - intoWorld: aWorld - "The receiver has just appeared in a new world. Note: - * aWorld can be nil (due to optimizations in other places) - * owner is already set - * owner's submorphs may not include receiver yet. - Important: Keep this method fast - it is run whenever morphs are added." - super intoWorld: aWorld. - self adjustSubmorphsLayout. -"this doesnt work: aWorld ifNotNil: [aWorld activeHand newKeyboardFocus: textPane]"! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'len 5/19/2020 19:27:47'! - setQuery: queryString initialAnswer: initialAnswer - response _ initialAnswer. - self addTitle: queryString. - self addTextPane! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'len 5/20/2020 04:03:48'! - validationBlock: aBlock - validationBlock _ aBlock! ! -!StringRequestMorph methodsFor: 'private' stamp: 'len 5/19/2020 07:38:08'! -adjustSubmorphsLayout - "Enlarge the width of submorphs as needed - so all of them are have the same width, and no less than #minWidth. - Also adjust their vertical position. - Finally, set our own extent." - - | w p h | - - submorphs isEmpty ifTrue: [ ^self ]. - w _ submorphs inject: 0 into: [ :prev :each | - prev max: each minItemWidth]. - - w _ w + 1. - p _ `5 @ 5`. - submorphs do: [ :m | - h _ m morphHeight. - m morphPosition: p extent: w@h. - p _ p + (0@(h + 1)) ]. - - self morphExtent: w+4 @ p y + 5! ! -!StringRequestMorph methodsFor: 'private' stamp: 'len 5/19/2020 08:55:51'! -cancel - self delete. - cancelBlock ifNotNil: [cancelBlock value]! ! -!StringRequestMorph methodsFor: 'private' stamp: 'len 5/20/2020 05:01:41'! - getUserResponseOrCancel: aBlock - "Wait for the user to accept or cancel, and answer the result string. Answers the empty string if the user cancels." - "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop." - | w delay done canceled | - w _ self world. - w isNil ifTrue: [^ response asString]. - done _ false. - canceled _ false. -" textPane focusText." - acceptBlock _ [:aString| done _ true]. - cancelBlock _ [done _ true. canceled _ true]. - delay _ Delay forMilliseconds: 10. - [done not and: [self isInWorld]] whileTrue: [ w doOneMinimalCycleNow. delay wait ]. - self delete. - w doOneMinimalCycleNow. - canceled ifTrue: [^ aBlock value]. - ^ response asString! ! -!StringRequestMorph methodsFor: 'private' stamp: 'len 5/19/2020 06:58:15'! - selectionInterval - ^ 1 to: response size -! ! -!StringRequestMorph class methodsFor: 'instance creation' stamp: 'len 5/20/2020 06:02:15'! - request: queryString centeredAt: aPoint initialAnswer: defaultAnswer validationBlock: validationBlock acceptBlock: acceptBlock cancelBlock: cancelBlock - | answer | - answer _ self new - setQuery: queryString - initialAnswer: defaultAnswer; - validationBlock: validationBlock; - acceptBlock: acceptBlock; - cancelBlock: cancelBlock. - self runningWorld addMorph: answer centeredNear: aPoint - self deltaToTextPane. - ^ answer! ! -!StringRequestMorph class methodsFor: 'instance creation' stamp: 'len 5/20/2020 06:00:53' overrides: 50513613! - request: queryString initialAnswer: defaultAnswer do: acceptBlock - ^ self request: queryString centeredAt: self runningWorld activeHand morphPosition initialAnswer: defaultAnswer validationBlock: [:aString| true] acceptBlock: acceptBlock cancelBlock: []! ! -!StringRequestMorph class methodsFor: 'instance creation' stamp: 'len 5/20/2020 04:48:06' overrides: 50513630! - request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock - | morph world | - morph _ self new - setQuery: queryString - initialAnswer: defaultAnswer. - (world _ self runningWorld) addMorph: morph centeredNear: world activeHand morphPosition - self deltaToTextPane. - ^ morph getUserResponseOrCancel: cancelBlock! ! -!StringRequestMorph class methodsFor: 'instance creation' stamp: 'len 5/20/2020 07:38:12' overrides: 50513652! - request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock - ^ self request: queryString centeredAt: self runningWorld activeHand morphPosition initialAnswer: defaultAnswer validationBlock: validationBlock acceptBlock: acceptBlock cancelBlock: cancelBlock! ! -!StringRequestMorph class methodsFor: 'private' stamp: 'len 5/19/2020 19:32:56'! - deltaToTextPane - "Answer a distance to translate an instance of the receiver by when it is opened in the world in order to have the hand be over the text pane (so the text pane has focus)." - ^ 40@40! ! -!CodeProvider methodsFor: 'categories' stamp: 'len 5/20/2020 08:08:08' prior: 16811919! - categoryFromUserWithPrompt: aPrompt for: aClass - "self new categoryFromUserWithPrompt: 'testing' for: SystemDictionary" - - | labels myCategories reject lines newName menuIndex | - labels _ OrderedCollection with: 'new...'. - labels addAll: (myCategories _ aClass organization categories asArray copy sort: - [ :a :b | a asLowercase < b asLowercase ]). - reject _ myCategories asSet. - reject - add: ClassOrganizer nullCategory; - add: ClassOrganizer default. - lines _ OrderedCollection with: 1 with: (myCategories size + 1). - - aClass allSuperclasses do: [ :cls | | cats | - cats _ cls organization categories reject: [ :cat | reject includes: cat]. - cats isEmpty ifFalse: [ - lines add: labels size. - labels addAll: (cats asArray sort: [ :a :b | a asLowercase < b asLowercase]). - reject addAll: cats]]. - - (labels size = 1 or: [ - menuIndex _ (PopUpMenu labelArray: labels lines: lines) - startUpWithCaption: aPrompt. - menuIndex = 0 ifTrue: [^ nil]. - menuIndex = 1]) - ifTrue:[ - newName _ self request: 'New category name?' initialAnswer: 'Category-Name'. - newName isEmpty ifTrue: [ ^nil ]] - ifFalse: [ newName _ labels at: menuIndex ]. - ^ newName ifNotNil: [ newName asSymbol ]! ! -!Browser methodsFor: 'class functions' stamp: 'len 5/20/2020 07:23:01' prior: 16791541! - copyClass - | originalClass originalName copysName newDefinition newMetaDefinition newClass | - selectedClassName ifNil: [^ self]. - originalClass _ self selectedClass. - originalName _ originalClass name. - self request: 'New class name?' - initialAnswer: originalName - verifying: [:aString| aString notEmpty and: [aString ~= originalName]] - do: [:aString| - copysName _ aString asSymbol. - (Smalltalk includesKey: copysName) - ifTrue: [self error: copysName , ' already exists']. - newDefinition _ originalClass definition - copyReplaceAll: originalName printString - with: copysName printString. - newClass _ Compiler evaluate: newDefinition logged: true. - newMetaDefinition _ originalClass class definition - copyReplaceAll: originalClass class name - with: newClass class name. - Compiler evaluate: newMetaDefinition logged: true. - newClass copyAllCategoriesFrom: originalClass. - newClass class copyAllCategoriesFrom: originalClass class. - originalClass hasComment ifTrue: [newClass comment: originalClass comment]. - self classListIndex: 0. - self changed: #classList]! ! -!Browser methodsFor: 'message category functions' stamp: 'len 5/20/2020 07:00:28' prior: 50426790! - newMethodCategoryNameIfNone: aNoneBlock - - | labels lines menuIndex newName reject | - - labels _ OrderedCollection with: 'new...'. - reject _ Set new. - reject - addAll: self selectedClassOrMetaClass organization categories; - add: ClassOrganizer nullCategory; - add: ClassOrganizer default. - lines _ OrderedCollection new. - self selectedClassOrMetaClass allSuperclasses do: [:cls | | cats | - cls = Object ifFalse: [ - cats _ cls organization categories reject: - [:cat | reject includes: cat]. - cats isEmpty ifFalse: [ - lines add: labels size. - labels addAll: cats asArray sort. - reject addAll: cats]]]. - newName _ (labels size = 1 or: [ - menuIndex _ (PopUpMenu labelArray: labels lines: lines) - startUpWithCaption: 'Add Category'. - menuIndex = 0 ifTrue: [^ aNoneBlock value]. - menuIndex = 1]) - ifTrue: [ - self request: 'New category name?' - initialAnswer: 'Category-Name'] - ifFalse: [ - labels at: menuIndex]. - - ^ newName isEmpty - ifTrue: aNoneBlock - ifFalse: [newName asSymbol]! ! -!Browser methodsFor: 'message category functions' stamp: 'len 5/20/2020 07:25:11' prior: 16792115! - renameCategory - "Prompt for a new category name and add it before the - current selection, or at the end if no current selection" - | oldIndex oldName newName | - selectedClassName ifNil: [^ self]. - selectedMessageCategory ifNil: [ ^self ]. - oldIndex _ self messageCategoryListIndex. - oldName _ self selectedMessageCategoryName. - newName _ self - request: 'New category name?' - initialAnswer: oldName - verifying: [:aString| aString notEmpty and: [aString ~= oldName]] - do: [:aString| - newName _ aString asSymbol. - self classOrMetaClassOrganizer - renameCategory: oldName - toBe: newName. - self classListIndex: self classListIndex. - self messageCategoryListIndex: oldIndex. - self changed: #messageCategoryList]! ! -!Browser methodsFor: 'system category functions' stamp: 'len 5/20/2020 06:58:53' prior: 50426825! - newSystemCategoryNameIfNone: aNoneBlock - - | newName | - - newName _ self - request: 'New category name?' - initialAnswer: 'Category-Name'. - - ^newName isEmpty - ifTrue: aNoneBlock - ifFalse: [newName asSymbol].! ! -!Browser methodsFor: 'system category functions' stamp: 'len 5/20/2020 07:26:14' prior: 16792688! - renameSystemCategory - "Prompt for a new category name and add it before the - current selection, or at the end if no current selection - - 21-Mar-2012 jmv Note: This is not recorded appropriately in change sets. - The easiest solution is to trigger #classRecategorized for all classes in the category. - But this is not a real solution, as the resulting changeset would not do a rename, - but create a new category (that would go to the bottom) with all the classes. - - In the meantime, disable the menu entry. This is not so important after all. - " - | oldIndex oldName newName | - selectedSystemCategory ifNil: [ ^ self]. "no selection" - oldIndex _ self systemCategoryListIndex. - oldName _ selectedSystemCategory. - newName _ self - request: 'New category name?' - initialAnswer: oldName - verifying: [:aString| aString notEmpty and: [aString ~= oldName]] - do: [:aString| - newName _ aString asSymbol. - systemOrganizer - renameCategory: oldName - toBe: newName. - self systemCategoryListIndex: oldIndex. - self changed: #systemCategoryList]! ! -!MessageSet methodsFor: 'filtering' stamp: 'len 5/20/2020 06:47:08' prior: 16870166! - filterToImplementorsOf - "Filter the receiver's list down to only those items with a given selector." - - self request: 'Enter selector:' initialAnswer: '' verifying: [:aString| aString notEmpty] do: [:aString| - Symbol hasInterned: aString withBlanksTrimmed ifTrue: - [:aSymbol | - self filterFrom: - [:aClass :aSelector | - aSelector == aSymbol]]]! ! -!MessageSet methodsFor: 'filtering' stamp: 'len 5/20/2020 06:44:54' prior: 16870268! - filterToNotImplementorsOf - "Filter the receiver's list down to only those items whose selector is NOT one solicited from the user." - - self request: 'Enter selector:' initialAnswer: '' verifying: [:aString| aString notEmpty] do: [:aString| - Symbol hasInterned: aString withBlanksTrimmed ifTrue: - [:aSymbol | - self filterFrom: - [:aClass :aSelector | - aSelector ~~ aSymbol]]]! ! -!MessageSet methodsFor: 'filtering' stamp: 'len 5/20/2020 06:47:00' prior: 16870286! - filterToNotSendersOf - "Filter the receiver's list down to only those items which do not send a given selector." - - self request: 'Enter selector:' initialAnswer: '' verifying: [:aString| aString notEmpty] do: [:aString| - Symbol hasInterned: aString withBlanksTrimmed ifTrue: - [:aSymbol | - self filterFrom: - [:aClass :aSelector | | aMethod | - (aMethod _ aClass compiledMethodAt: aSelector) isNil or: - [(aMethod hasLiteralThorough: aSymbol) not]]]]! ! -!MessageSet methodsFor: 'filtering' stamp: 'len 5/20/2020 06:47:19' prior: 16870306! - filterToSendersOf - "Filter the receiver's list down to only those items which send a given selector." - - self request: 'Enter selector:' initialAnswer: '' verifying: [:aString| aString notEmpty] do: [:aString| - Symbol hasInterned: aString withBlanksTrimmed ifTrue: - [:aSymbol | - self filterFrom: - [:aClass :aSelector | | aMethod | - (aMethod _ aClass compiledMethodAt: aSelector) notNil and: - [aMethod hasLiteralThorough: aSymbol]]]]! ! -!CodeFileBrowser methodsFor: 'class list' stamp: 'len 5/20/2020 07:28:17' prior: 50492891 overrides: 50482950! - renameClass - | oldName newName | - selectedClassName ifNil: [ ^self ]. - oldName _ self selectedClass name. - self request: 'New class name?' - initialAnswer: oldName - verifying: [:aString| aString notEmpty and: [aString ~= oldName]] - do: [:aString| - newName _ aString asSymbol. - (caseCodeSource classDictionary includesKey: newName) - ifTrue: [self error: newName , ' already exists in the CodeFile']. - systemOrganizer classify: newName under: selectedSystemCategory. - systemOrganizer removeElement: oldName. - caseCodeSource renameClass: self selectedClass to: newName. - self changed: #classList. - self classListIndex: ((systemOrganizer listAtCategoryNamed: selectedSystemCategory) indexOf: newName)]! ! -!ChangeList methodsFor: 'menu actions' stamp: 'len 5/20/2020 04:12:13' prior: 50344440! - fileOutCurrentVersionsOfSelections - self request: 'Enter file name' initialAnswer: 'Filename.st' do: [:aString| - aString asFileEntry writeStreamDo: [ :stream | - stream timeStamp. - self currentVersionsOfSelections do: [ :methodRef | - methodRef actualClass - printMethodChunk: methodRef methodSymbol - withPreamble: true - on: stream - moveSource: false - toFile: 0 ]]]! ! -!ChangeList methodsFor: 'menu actions' stamp: 'len 5/20/2020 04:12:37' prior: 16796233! - fileOutSelections - self request: 'Enter file name' initialAnswer: 'Filename.st' do: [ :aString | - aString asFileEntry writeStreamDo: [ :stream | - stream timeStamp. - listSelections with: changeList do: [ :selected :item | - selected ifTrue: [ item fileOutOn: stream ]]]]! ! -!ChangeSorter methodsFor: 'changeSet menu' stamp: 'len 5/20/2020 06:13:26' prior: 16799624! - rename - "Store a new name string into the selected ChangeSet. reject duplicate name; allow user to back out" - - self request: 'New name for this change set' initialAnswer: myChangeSet name do: [:newName| - (newName = myChangeSet name or: [newName size = 0]) - ifTrue: [Smalltalk beep] - ifFalse: - [(ChangeSet changeSetNamed: newName) notNil - ifTrue: [self inform: 'Sorry that name is already used'] - ifFalse: - [myChangeSet name: newName. - self update. - self changed: #mainButtonName. - self changed: #relabel]]]! ! -!Debugger methodsFor: 'context stack menu' stamp: 'len 5/20/2020 08:27:52' prior: 50476468! - askForCategoryIn: aClass default: aDefaultCategory - - | categories index category classCategories | - - categories := OrderedCollection with: 'new ...'. - - aClass isMeta ifTrue: [ categories add: Categorizer instanceCreation ]. - classCategories := aClass allMethodCategoriesIntegratedThrough: Object. - aClass isMeta ifTrue: [ classCategories remove: Categorizer instanceCreation ifAbsent: []]. - - categories addAll: classCategories. - index := PopUpMenu - withCaption: 'Please provide a good category for the new method!!' - chooseFrom: categories. - index = 0 ifTrue: [^ aDefaultCategory]. - category := index = 1 - ifTrue: [self request: 'Enter category name:' initialAnswer: ''] - ifFalse: [categories at: index]. - - ^ category isEmpty ifTrue: [aDefaultCategory] ifFalse: [category]! ! -!FileList methodsFor: 'file menu action' stamp: 'len 5/20/2020 06:39:43' prior: 16842467! - addNew: aString byEvaluating: aBlock - "A parameterization of earlier versions of #addNewDirectory and - #addNewFile. Fixes the bug in each that pushing the cancel button - in the FillInTheBlank dialog gave a walkback." - - | newName index | - self request: ('New {1} name?' format: {aString}) - initialAnswer: ('{1}Name' format: {aString}) - verifying: [:response| response notEmpty] - do: [:response| - newName _ response asFileName. - aBlock value: newName. - self updateFileList. - index _(1 to: list size) detect: [ :i | - (list at: i) includesSubString: newName ] ifNone: [ 0 ]. - self fileListIndex: index]! ! -!FileList methodsFor: 'file menu action' stamp: 'len 5/20/2020 06:39:51' prior: 16842489! - addNewDirectory - - self - addNew: 'directory' - byEvaluating: [ :newName | (directory / newName) assureExistence ]. - self updateDirectory. - self changed: #initialDirectoryList! ! -!FileList methodsFor: 'file menu action' stamp: 'len 5/20/2020 06:39:54' prior: 16842497! - addNewFile - - self - addNew: 'file' - byEvaluating: [ :newName | (directory // newName) assureExistence ] -! ! -!FileList methodsFor: 'file menu action' stamp: 'len 5/20/2020 06:39:31' prior: 16842534! - renameFile - "Rename the currently selected file" - listIndex = 0 ifTrue: [^ self]. - self request: 'New file name?' - initialAnswer: fileName - verifying: [:response| response notEmpty and: [response asFileName ~= fileName]] - do: [:response| - | newName | - newName _ response asFileName. - directory // fileName rename: newName. - self updateFileList. - listIndex _ list findFirst: [:item | (self fileNameFromFormattedItem: item) = newName]. - listIndex > 0 ifTrue: [fileName _ newName]. - self changed: #fileListIndex. - self triggerEvent: #updateButtonRow]! ! -!TestRunner methodsFor: 'menus' stamp: 'len 5/20/2020 04:15:57' prior: 16928148! - setFilter - self - request: 'Pattern for added test cases (#* OK)' - initialAnswer: '*' - do: [:aString| - filter _ aString. - (filter endsWith: '*') ifFalse: [ filter _ filter, '*' ]. - selectedSuites _ (tests asOrderedCollection with: selectedSuites collect: [ :ea :sel | - sel or: [ filter match: ea asString ] - ]). - selectedSuite _ selectedSuites indexOf: true ifAbsent: [0]. - self changed: #allSelections]! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'len 5/20/2020 06:20:10' prior: 50365822! - condenseSources - "Move all the changes onto a compacted sources file." - "Smalltalk condenseSources" - - | classCount oldChanges oldChangesLocalName oldChangesPathName newChangesPathName newSourcesName | - self request: 'Please name the new sources file' initialAnswer: SourceFileVersionString verifying: [:newVersionString| newVersionString ~= SourceFileVersionString] do: [:newVersionString| - SourceFileVersionString _ newVersionString. - - "Write all sources with fileIndex 1" - newSourcesName _ self defaultSourcesName. - newSourcesName asFileEntry writeStreamDo: [ :f | - f timeStamp. - 'Condensing Sources File...' - displayProgressAt: Sensor mousePoint - from: 0 to: Smalltalk classNames size - during: [ :barBlock | - classCount _ 0. - Smalltalk allClassesDo: [ :class | - barBlock value: (classCount _ classCount + 1). - class fileOutOn: f moveSource: true toFile: 1]]]. - - CompiledMethod allInstancesDo: [ :e | - e isInstalled ifFalse: [ e destroySourcePointer ] ]. - - "Make a new empty changes file" - oldChanges _ SourceFiles at: 2. - oldChangesPathName _ oldChanges name. - oldChangesLocalName _ oldChanges localName. - self closeSourceFiles. - oldChangesPathName ifNotNil: [ - (oldChangesPathName, '.old') asFileEntry delete. - oldChangesPathName asFileEntry rename: oldChangesLocalName, '.old' ]. - newChangesPathName _ self defaultChangesName. - newChangesPathName asFileEntry writeStreamDo: [ :stream | - stream timeStamp ]. - LastQuitLogPosition _ 0. - - self openSourceFiles. - self inform: 'Source files have been rewritten!! - -Check that all is well, and then save/quit. - -Otherwise, remove new sources/changes, -replace them with the former ones, and -exit without saving the image. - ']! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'len 5/20/2020 08:37:42' prior: 16922729! - saveAs - "Put up the 'saveAs' prompt, obtain a name, and save the image under that new name." - - self request: 'New file name?' initialAnswer: self imageName asFileEntry name do: [:newName| - ((((self fullNameForImageNamed: newName) asFileEntry exists not - and: [(self fullNameForChangesNamed: newName) asFileEntry exists not]) - or: [self confirm: ('{1} already exists. Overwrite?' format: {newName})]) - and: [self okayToSave]) - ifTrue: - [self saveAs: newName andQuit: false clearAllClassState: false]]! ! -!StandardFileStream class methodsFor: 'error handling' stamp: 'len 5/20/2020 08:30:22' prior: 16913757! - fileDoesNotExistUserHandling: fullFileName - - | selection newName | - selection _ (PopUpMenu labels: -'create a new file -choose another name -cancel') - startUpWithCaption: fullFileName asFileEntry name, ' -does not exist.'. - selection = 1 ifTrue: - [^ self new open: fullFileName forWrite: true]. - selection = 2 ifTrue: - [ newName _ self request: 'Enter a new file name' - initialAnswer: fullFileName. - ^ FileIOAccessor default privateWriteableFile: newName asFileEntry ]. - self halt! ! -!StandardFileStream class methodsFor: 'error handling' stamp: 'len 5/20/2020 08:30:28' prior: 16913776! - fileExistsUserHandling: fullFileName - | dir localName choice newName entry | - entry _ fullFileName asFileEntry. - dir _ entry parent. - localName _ entry name. - choice _ (PopUpMenu - labels: -'overwrite that file\choose another name\cancel' withNewLines) - startUpWithCaption: localName, ' -already exists.'. - - choice = 1 ifTrue: [ - dir removeKey: localName - ifAbsent: [self error: 'Could not delete the old version of that file']. - ^ self new open: fullFileName forWrite: true]. - - choice = 2 ifTrue: [ - newName _ self request: 'Enter a new file name' initialAnswer: fullFileName. - ^ FileIOAccessor default privateNewFile: newName asFileEntry ]. - - self error: 'Please close this to abort file opening'! ! -!StandardFileStream class methodsFor: 'error handling' stamp: 'len 5/20/2020 08:31:13' prior: 50425027! - readOnlyFileDoesNotExistUserHandling: fullFileName - - | dir files choices selection newName fileName | - dir _ fullFileName asFileEntry parent. - files _ dir fileNames. - fileName _ fullFileName asFileEntry name. - choices _ fileName correctAgainst: files. - choices add: 'Choose another name'. - choices add: 'Cancel'. - selection _ (PopUpMenu labelArray: choices lines: (Array with: 5) ) - startUpWithCaption: fullFileName asFileEntry name, ' -does not exist.'. - selection = choices size ifTrue:["cancel" ^ nil "should we raise another exception here?"]. - selection < (choices size - 1) ifTrue: [ - newName _ (dir pathName , '/', (choices at: selection))]. - selection = (choices size - 1) ifTrue: [ - newName _ self request: 'Enter a new file name' initialAnswer: fileName. - "If Cancel was pressed, no file should be opened - Hernan" - newName isEmpty ifTrue: [ ^nil ]]. - newName = '' ifFalse: [^ FileIOAccessor default privateReadOnlyFile: newName asFileEntry ]. - ^ self error: 'Could not open a file'! ! -!SmartRefStream methodsFor: 'class changed shape' stamp: 'len 5/20/2020 08:30:12' prior: 16911567! - writeClassRenameMethod: sel was: oldName fromInstVars: oldList - "The class coming is unknown. Ask the user for the existing class it maps to. If got one, write a method, and restart the obj fileIn. If none, write a dummy method and get the user to complete it later. " - - | tell choice newName answ code oldVer newList newVer instSel | - self flag: #bobconv. - tell := 'Reading an instance of ' , oldName - , '. -Which modern class should it translate to?'. - answ := (PopUpMenu - labels: 'Let me type the name now -Let me think about it -Let me find a conversion file on the disk') - startUpWithCaption: tell. - answ = 1 - ifTrue: [ - tell := 'Name of the modern class {1} should translate to:' format: {oldName}. - choice := self request: tell initialAnswer: ''. "class name" - choice size = 0 - ifTrue: [answ := 'conversion method needed'] - ifFalse: - [newName := choice. - answ := Smalltalk at: newName asSymbol - ifAbsent: ['conversion method needed']. - answ class == String - ifFalse: [renamed at: oldName asSymbol put: answ name]]]. - answ = 3 | (answ = 0) - ifTrue: [ - byteStream close. - ^'conversion method needed']. - answ = 2 ifTrue: [answ := 'conversion method needed']. - answ = 'conversion method needed' - ifTrue: [ - byteStream close. - newName := 'PutNewClassHere']. - answ class == String - ifFalse: - [oldVer := self versionSymbol: (structures at: oldName). - newList := (Array with: answ classVersion) , answ allInstVarNames. - newVer := self versionSymbol: newList. - instSel := 'convert' , oldVer , ':' , newVer , ':']. - code := WriteStream on: (String new: 500). - code - nextPutAll: sel; - newLine. - answ class == String - ifFalse: [ - code - newLine; - tab; - nextPutAll: 'reshaped at: #' , oldName , ' put: #' , instSel , '.'. - code - newLine; - tab; - tab; - nextPutAll: '"Be sure to define that conversion method in class ' - , answ name , '"']. - code - newLine; - tab; - nextPutAll: '^ ' , newName. "Return new class" - self class compile: code contents classified: 'conversion'. - newName = 'PutNewClassHere' - ifTrue: [ - self - inform: 'Please complete the following method and -then read-in the object file again.'. - Smalltalk browseAllImplementorsOf: sel asSymbol]. - self flag: #violateBasicLayerPrinciples. - "SmartRefStream should not refer to UI!!!!!!!!!! (sd)" - - "The class version number only needs to change under one specific circumstance. That is when the first letters of the instance variables have stayed the same, but their meaning has changed. A conversion method is needed, but this system does not know it. - If this is true for class Foo, define classVersion in Foo class. - Beware of previous object fileouts already written after the change in meaning, but before bumping the version number. They have the old (wrong) version number, say 2. If this is true, your method must be able to test the data and successfully read files that say version 2 but are really 3." - ^answ! ! -!Parser methodsFor: 'error correction' stamp: 'len 5/20/2020 08:28:19' prior: 16886638! - defineClass: className - "prompts the user to define a new class, - asks for it's category, and lets the users edit further - the definition" - | sym cat def d2 | - sym := className asSymbol. - cat := self request: 'Enter class category : ' initialAnswer: self encoder classEncoding theNonMetaClass category. - cat - ifEmpty: [cat := 'Unknown']. - def := 'Object subclass: #' , sym , ' - instanceVariableNames: '''' - classVariableNames: '''' - poolDictionaries: '''' - category: ''' , cat , ''''. - d2 := self request: 'Edit class definition : ' initialAnswer: def. - d2 - ifEmpty: [d2 := def]. - Compiler evaluate: d2. - ^ encoder - global: (Smalltalk associationAt: sym) - name: sym! ! -!TextEditor methodsFor: 'menu messages' stamp: 'len 5/20/2020 06:23:28' prior: 16932150! - find - "Prompt the user for a string to search for, and search the receiver from the current selection onward for it. 1/26/96 sw" - - self - request: 'Find what?' - initialAnswer: self class findText - do: [:aString| - aString isEmpty ifFalse: - ["Set focus on our text morph, so that cmd-g does the search again" - morph world activeHand newKeyboardFocus: morph. - self setSearch: aString. - ChangeText _ self class findText. "Implies no replacement to againOnce: method" - (self findAndReplaceMany: false) - ifFalse: [ self flash ]]]. - -" morph installEditorToReplace: self"! ! -!Utilities class methodsFor: 'identification' stamp: 'len 5/22/2020 04:30:45' prior: 16940801! - setAuthor - "Put up a dialog allowing the user to specify the author's initials. - Utilities setAuthor - " - | authorName | - AuthorInitials _ (self - request: 'Please type your initials: ' - initialAnswer: (AuthorInitials ifNil: [''])) withBlanksTrimmed. - authorName _ (Smalltalk knownInitialsAndNames - detect: [ :pair | - pair first = AuthorInitials ] - ifNone: [ - AuthorName _ (self - request: 'Please type your name:' - initialAnswer: 'Your Name') withBlanksTrimmed. - ^ self ]) second withBlanksTrimmed. - (self confirm: 'Are you ' , authorName , '?') - ifTrue: [ AuthorName _ authorName ] - ifFalse: [ - self inform: 'Please enter different initials, then'. - self setAuthor ]! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'len 5/20/2020 05:09:58' prior: 16875706! - editBalloonHelpContent: aString - self - request: 'Edit the balloon help text for ' , (self printStringLimitedTo: 40) - initialAnswer: (aString ifNil: [self noHelpString] ifNotNil: [aString]) - do: [:reply| - (reply isEmpty or: [reply asString = self noHelpString]) - ifTrue: [self setBalloonText: nil] - ifFalse: [self setBalloonText: reply]]! ! -!Morph methodsFor: 'menus' stamp: 'len 5/20/2020 06:16:32' prior: 16876285! - exportAsBMP - "Export the receiver's image as a BMP." - self request: 'Enter file name' - initialAnswer: (self printStringLimitedTo: 20),'.bmp' - do: [:aString| (self imageForm: 32) writeBMPfileNamed: aString]! ! -!Morph methodsFor: 'menus' stamp: 'len 5/20/2020 06:16:41' prior: 16876294! - exportAsJPEG - "Export the receiver's image as a JPEG." - self request: 'Enter file name' - initialAnswer: (self printStringLimitedTo: 20),'.jpeg' - do: [:aString| (self imageForm: 32) writeJPEGfileNamed: aString]! ! -!SystemWindow methodsFor: 'label' stamp: 'len 5/20/2020 06:20:49' prior: 16926337! - relabel - self request: 'New title for this window' initialAnswer: labelString verifying: [:aString| aString notEmpty] do: [:aString| self setLabel: aString]! ! -!SystemWindow methodsFor: 'user interface' stamp: 'len 5/20/2020 06:57:02' prior: 50448412! - saveContents - "Prompts the user for a file name and saves the contents to the file" - self hasSaveAs ifFalse: [^self]. - self request: 'Enter file name' initialAnswer: '' verifying: [:aString| aString notEmpty] do: [:fileName| self saveContentsTo: fileName]! ! -!CodePackageListWindow methodsFor: 'commands' stamp: 'len 5/20/2020 04:08:36' prior: 16811622! - createPackage - self request: 'Name for new package?' do: [:aString| - aString ifNotEmpty: - [CodePackage - named: aString - createIfAbsent: true - registerIfNew: true]]! ! -!CodeWindow methodsFor: 'misc' stamp: 'len 5/20/2020 08:09:08' prior: 16813655! - getSelectorAndSendQuery: querySelector to: queryPerformer with: queryArgs - "Obtain a selector relevant to the current context, and then send the querySelector to the queryPerformer with the selector obtained and queryArgs as its arguments. If no message is currently selected, then obtain a method name from a user type-in" - - | strm array | - strm _ WriteStream on: (array _ Array new: queryArgs size + 1). - strm nextPut: nil. - strm nextPutAll: queryArgs. - - model selectedMessageName ifNil: [ | selector | - selector _ self request: 'Type selector:' initialAnswer: 'flag:'. - ^ selector isEmpty ifFalse: [ - (Symbol hasInterned: selector - ifTrue: [ :aSymbol | - array at: 1 put: aSymbol. - queryPerformer perform: querySelector withArguments: array]) - ifFalse: [ self inform: 'no such selector'] - ] - ]. - - self selectMessageAndEvaluate: [:selector | - array at: 1 put: selector. - queryPerformer perform: querySelector withArguments: array - ]! ! -!CodeWindow methodsFor: 'misc' stamp: 'len 5/20/2020 08:15:43' prior: 16813720! - sendQuery: querySelector to: queryPerformer - "Apply a query to the primary selector associated with the current context. If no such selection exists, obtain one by user type-in. Then send querySelector to queryPerformer with the selector as its argument." - - model selectedMessageName ifNotNil: [^ queryPerformer perform: querySelector with: querySelector]. - self request: 'Type selector:' initialAnswer: 'flag:' verifying: [:aString| aString notEmpty] do: [:aString| - (Symbol hasInterned: aString ifTrue: [ :aSymbol | queryPerformer perform: querySelector with: aSymbol]) - ifFalse: [self inform: 'no such selector']]! ! -!CodeWindow methodsFor: 'misc' stamp: 'len 5/20/2020 08:15:27' prior: 16813743! -useSelector: incomingSelector orGetSelectorAndSendQuery: querySelector to: queryPerformer - "If incomingSelector is not nil, use it, else obtain a selector from user type-in. Using the determined selector, send the query to the performer provided." - - incomingSelector ifNotNil: [^ queryPerformer perform: querySelector with: incomingSelector]. - self request: 'Type selector:' initialAnswer: 'flag:' verifying: [:aString| aString notEmpty] do: [:aString| - (Symbol hasInterned: aString ifTrue: [:aSymbol| queryPerformer perform: querySelector with: aSymbol]) - ifFalse: [self inform: 'no such selector']]! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'len 5/19/2020 15:57:32' prior: 50448718! - buildMorphicWindow - "Create a pluggable version of all the morphs for a Browser in Morphic" - - | upperPanes messageCatList messageList systemCatList classList | - - systemCatList _ self buildMorphicSystemCatList. - classList _ self buildMorphicClassList. - messageCatList _ self buildMorphicMessageCatList. - messageList _ self buildMorphicMessageList. - - systemCatList rightSibling: classList. - classList leftSibling: systemCatList rightSibling: messageCatList. - messageCatList leftSibling: classList rightSibling: messageList. - messageList leftSibling: messageCatList. - -" classList makeItemsDraggable." - systemCatList - acceptDropsFrom: classList - performing: #categorizeUnderCategoryAt:class: - whenOutsideList: #categorizeUnderNewCategoryClass:. - -" messageList makeItemsDraggable." - messageCatList - acceptDropsFrom: messageList - performing: #categorizeUnderCategoryAt:selector: - whenOutsideList: #categorizeUnderNewCategorySelector:. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: systemCatList proportionalWidth: 0.2; - addAdjusterAndMorph: (self buildMorphicClassColumnWith: classList) proportionalWidth: 0.2; - addAdjusterAndMorph: messageCatList proportionalWidth: 0.2; - addAdjusterAndMorph: messageList proportionalWidth: 0.4. - - self layoutMorph - addMorph: upperPanes proportionalHeight: 0.3; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.7. - - model changed: #editSelection! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'len 5/19/2020 15:57:45' prior: 50493829! - buildNoSysCatMorphicWindow - "A Browser without the class categories list" - - | mySingletonList upperPanes messageCatList messageList classColumn classList | - mySingletonList _ PluggableListMorph - model: model - listGetter: #systemCategorySingleton - indexGetter: #indexIsOne - indexSetter: #indexIsOne: - mainView: self - menuGetter: #systemCatSingletonMenu - keystrokeAction: #systemCatSingletonKey:from:. - mySingletonList hideScrollBarsIndefinitely. - - classList _ self buildMorphicClassList. - classColumn _ self buildMorphicClassColumnWith: classList. - messageCatList _ self buildMorphicMessageCatList. - messageList _ self buildMorphicMessageList. - - classList rightSibling: messageCatList. - messageCatList leftSibling: classList rightSibling: messageList. - messageList leftSibling: messageCatList. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: classColumn proportionalWidth: 0.3; - addAdjusterAndMorph: messageCatList proportionalWidth: 0.3; - addAdjusterAndMorph: messageList proportionalWidth: 0.4. - -" messageList makeItemsDraggable." - messageCatList - acceptDropsFrom: messageList - performing: #categorizeUnderCategoryAt:selector: - whenOutsideList: #categorizeUnderNewCategorySelector:. - - self layoutMorph - addMorph: mySingletonList fixedHeight: Preferences standardCodeFont lineSpacing + 10; - addAdjusterAndMorph: upperPanes proportionalHeight: 0.3; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.7. - - model changed: #editSelection! ! -!BrowserWindow class methodsFor: 'GUI building' stamp: 'len 5/20/2020 06:06:03' prior: 50446807! - findClassFrom: potentialClassNames ifFound: aBlock - | classNames exactMatch foundClass index toMatch | - ClassNameRequestMorph request: 'Class name or fragment?' initialAnswer: '' do: [:pattern| - pattern isEmpty - ifTrue: [self flash] - ifFalse: - [toMatch _ (pattern copyWithout: $.) asLowercase withBlanksTrimmed. - classNames _ (pattern last = $. or: [pattern last = $ ]) - ifTrue: [potentialClassNames select: [:nm | nm asLowercase = toMatch]] - ifFalse: [potentialClassNames select: [:n | n includesSubstring: toMatch caseSensitive: false]]. - classNames isEmpty - ifTrue: [self flash] - ifFalse: - [exactMatch _ classNames detect: [ :each | each asLowercase = toMatch] ifNone: nil. - - index _ classNames size = 1 - ifTrue: [ 1 ] - ifFalse: [ exactMatch - ifNil: [(PopUpMenu labelArray: classNames lines: #()) startUpMenu] - ifNotNil: [classNames addFirst: exactMatch. - (PopUpMenu labelArray: classNames lines: #(1)) startUpMenu]]. - - index = 0 - ifTrue: [self flash] - ifFalse: - [foundClass _ Smalltalk at: (classNames at: index) asSymbol. - - aBlock value: foundClass]]]]! ! -!CodeFileBrowserWindow methodsFor: 'commands' stamp: 'len 5/20/2020 06:54:25' prior: 50493259 overrides: 50447140! - findClass - | pattern foundClass classNames index foundCodeFile | - self okToChange ifFalse: [^ self flash]. - self request: 'Class name?' do: [:aString| - aString isEmpty ifFalse: - [pattern _ aString asLowercase. - classNames _ Set new. - classNames addAll: model caseCodeSource classDictionary keys. - classNames _ classNames asArray select: - [:n | (n asLowercase indexOfSubCollection: pattern startingAt: 1) > 0]. - classNames isEmpty ifFalse: - [index _ classNames size = 1 - ifTrue: [1] - ifFalse: [(PopUpMenu labelArray: classNames lines: #()) startUpMenu]. - index = 0 ifFalse: - [foundCodeFile _ nil. - foundClass _ nil. - (model caseCodeSource classDictionary includesKey: (classNames at: index)) - ifTrue: - [foundClass := model caseCodeSource classDictionary at: (classNames at: index). - foundCodeFile := model caseCodeSource]. - foundClass ifNotNil: - [model systemCategoryListIndex: (model systemCategoryList indexOf: foundCodeFile name asSymbol). - model classListIndex: (model classList indexOf: foundClass name)]]]]]! ! -!MessageSetWindow class methodsFor: 'opening' stamp: 'len 5/20/2020 04:09:03' prior: 50481442! - findInSourceCode - self request: 'Text to search source code for?' do: [:aString| - Smalltalk browseMethodsWithSourceString: aString]! ! -!ChangeSelectorWizardStepWindow methodsFor: 'actions' stamp: 'len 5/20/2020 05:59:49' prior: 50438176! - do: aBlock withEnteredClassLabeled: aLabel - ClassNameRequestMorph - request: aLabel - initialAnswer: '' - do: [:className| self withClassNamed: className do: aBlock]! ! -!ChangeSelectorSendersStepWindow methodsFor: 'actions' stamp: 'len 5/20/2020 08:07:14' prior: 50438417! - askAndAddSenderOf: classOfSenderToAdd - - | senderSelector senderToAdd | - - senderSelector := self request: 'Selector of sender of #', self oldSelector initialAnswer: '' orCancel: [^self ]. - senderToAdd := classOfSenderToAdd - compiledMethodAt: senderSelector asSymbol - ifAbsent: [ ^self inform: classOfSenderToAdd doesNotImplement: senderSelector asSymbol]. - - (senderToAdd sendsOrRefersTo: self oldSelector) ifFalse: [ ^self inform: senderToAdd classAndSelector, ' does not refer to #', self oldSelector ]. - - self addToList: senderToAdd ! ! -!DebuggerWindow methodsFor: 'menu commands' stamp: 'len 5/20/2020 05:04:59' prior: 16831221! - returnValue - self request: 'Enter expression for return value:' do: [:aString| model returnValue: aString]! ! -!InspectorWindow methodsFor: 'menu commands' stamp: 'len 5/20/2020 05:08:06' prior: 16857283! - addEntry - self request: -'Enter new key, then type RETURN. -(Expression will be evaluated for value.) -Examples: #Fred ''a string'' 3+4' - do: [:aString| - model addEntry: (Compiler evaluate: aString)]! ! -!InspectorWindow methodsFor: 'menu commands' stamp: 'len 5/20/2020 06:15:29' prior: 16857364! - renameEntry - self request: -'Enter new key, then type RETURN. -(Expression will be evaluated for value.) -Examples: #Fred ''a string'' 3+4' - initialAnswer: model selectedKey printString - do: [:aString| aString isEmpty ifFalse: [model renameEntryTo: (Compiler evaluate: aString)]]! ! -!ProcessBrowserWindow methodsFor: 'menu commands' stamp: 'len 5/20/2020 07:34:54' prior: 16895419! - changePriority - | newPriority rule | - rule _ (model class rulesFor: model selectedProcess) second. - rule - ifFalse: [self inform: 'Nope, won''t change priority of ' , model selectedProcess name. - ^ self]. - self request: 'New priority' - initialAnswer: model selectedProcess priority asString - verifying: [:aString| ([aString asNumber asInteger] on: Error do: []) isInteger] - do: [:aString| - newPriority _ aString asNumber asInteger. - (newPriority between: 1 and: Processor highestPriority) - ifTrue: - [model class setProcess: model selectedProcess toPriority: newPriority. - model updateProcessList] - ifFalse: [self inform: 'Bad priority']]! ! -!ProcessBrowserWindow methodsFor: 'menu commands' stamp: 'len 5/20/2020 07:35:42' prior: 16895469! - findContext - self request: 'Enter a string to search for in the process stack lists' - initialAnswer: model searchString - do: [:searchString| model findContext: searchString]! ! -!ImageMorph methodsFor: 'menu commands' stamp: 'len 5/20/2020 06:17:35' prior: 16854152! - readFromFile - self request: 'Enter file name' - initialAnswer: 'fileName' - do: [:fileName| self image: (Form fromFileNamed: fileName)]! ! -!TheWorldMenu methodsFor: 'commands' stamp: 'len 5/20/2020 04:09:37' prior: 16934644! - saveWorldInFile - "Save the world's submorphs, model, and stepList in a file. " - - self request: 'File name for this morph?' do: [ :fileName | - fileName isEmpty ifTrue: [^ self]. "abort" - "Save only model, stepList, submorphs in this world" - myWorld submorphsDo: [ :m | m allMorphsDo: [ :subM | subM prepareToBeSaved ]]. "Amen" - (fileName, '.morph') asFileEntry writeStreamDo: [ :fileStream | - fileStream fileOutObject: myWorld ]]! ! -!TextComposition methodsFor: 'display' stamp: 'len 5/19/2020 05:56:06' prior: 16930849! - displaySelectionStartBlock: startBlock stopBlock: stopBlock InLine: line on: aCanvas textTopLeft: textTopLeft selectionColor: sc - "textTopLeft is relative to the morph currently being drawn" - - | leftX rightX idx textCursorFont t b textCursorAttributes | - - startBlock ifNil: [^self]. "No selection" - startBlock = stopBlock - ifTrue: [ - "Only show text cursor on line where clicked" - startBlock textLine first = line first ifFalse: [ - ^self ]. - showTextCursor ifTrue: [ - leftX _ textTopLeft x + startBlock left. - idx _ startBlock stringIndex. - textCursorAttributes _ editor ifNotNil: [ editor currentAttributes ]. - textCursorFont _ textCursorAttributes - ifNil: [ model actualContents fontAt: idx default: self defaultFont ] - ifNotNil: [ model actualContents fontIfApplying: textCursorAttributes default: self defaultFont ]. - b _ textTopLeft y + line top + line baseline + textCursorFont descent-1. - t _ textTopLeft y + line top + line baseline - textCursorFont ascent+1. - lastTextCursorRect _ nil. - self - displayTextCursorAtX: leftX - top: t - bottom: b - emphasis: textCursorFont emphasis - on: aCanvas - textLeft: textTopLeft x ]] - ifFalse: [ - "Test entire selection before or after here" - (stopBlock stringIndex < line first - or: [startBlock stringIndex > (line last + 1)]) - ifTrue: [^self]. "No selection on this line" - (stopBlock stringIndex = line first - and: [stopBlock textLine ~= line]) - ifTrue: [^self]. "Selection ends on line above" - (startBlock stringIndex = (line last + 1) - and: [stopBlock textLine ~= line]) - ifTrue: [^self]. - lastTextCursorRect _ nil. - leftX _ textTopLeft x + (startBlock stringIndex < line first - ifTrue: [ line ] - ifFalse: [ startBlock ]) left. - rightX _ textTopLeft x + ((stopBlock stringIndex > (line last + 1) or: [ - stopBlock stringIndex = (line last + 1) - and: [stopBlock textLine ~= line]]) - ifTrue: [line right] - ifFalse: [stopBlock left]). - aCanvas - fillRectangle: (leftX @ (line top + textTopLeft y) corner: rightX @ (line bottom + textTopLeft y)) - color: sc ]. "Selection begins on line below"! ! -!CodeFile methodsFor: 'fileIn/fileOut' stamp: 'len 5/20/2020 04:15:19' prior: 16808956! - fileOut - self request: 'Enter the file name' initialAnswer: '' do: [ :aString | - aString asFileEntry writeStreamDo: [ :stream | - sourceSystem isEmpty - ifFalse: [ stream nextChunkPut: sourceSystem printString; newLine ]. - self fileOutOn: stream. - stream newLine; newLine. - classes do: [ :cls | - cls needsInitialize - ifTrue: [ stream newLine; nextChunkPut: cls name,' initialize']]. - stream newLine ]]! ! -!RefactoringApplier methodsFor: 'request information' stamp: 'len 5/20/2020 05:00:03' prior: 50441435 overrides: 50513602! - request: aLabel initialAnswer: anAnswer - ^self request: aLabel initialAnswer: anAnswer orCancel: requestExitBlock ! ! - -RefactoringApplier removeSelector: #request:initialAnswer:onCancel:! - -!methodRemoval: RefactoringApplier #request:initialAnswer:onCancel: stamp: 'Install-4164-NonModalStringRequests-LucianoEstebanNotarfrancesco-2020May23-20h43m-len.001.cs.st 5/26/2020 17:08:34'! -request: aLabel initialAnswer: anAnswer onCancel: cancelBlock - - ^FillInTheBlankMorph request: aLabel initialAnswer: anAnswer onCancel: cancelBlock ! - -SystemDictionary removeSelector: #getFileNameFromUser! - -!methodRemoval: SystemDictionary #getFileNameFromUser stamp: 'Install-4164-NonModalStringRequests-LucianoEstebanNotarfrancesco-2020May23-20h43m-len.001.cs.st 5/26/2020 17:08:34'! -getFileNameFromUser - - | newName | - newName _ FillInTheBlankMorph - request: 'New File Name?' - initialAnswer: self imageName asFileEntry name. - newName isEmpty ifTrue: [ ^nil ]. - ((self fullNameForImageNamed: newName) asFileEntry exists or: [ - (self fullNameForChangesNamed: newName) asFileEntry exists ] ) ifTrue: [ - (self confirm: ('{1} already exists. Overwrite?' format: {newName})) - ifFalse: [ ^nil ]]. - ^newName -! - -Text class removeSelector: #fromUser! - -!methodRemoval: Text class #fromUser stamp: 'Install-4164-NonModalStringRequests-LucianoEstebanNotarfrancesco-2020May23-20h43m-len.001.cs.st 5/26/2020 17:08:34'! -fromUser - "Answer an instance of me obtained by requesting the user to type a string." - "Text fromUser" - - ^ self fromString: - (FillInTheBlankMorph request: 'Enter text followed by [Return]') -! - -Browser removeSelector: #request:initialAnswer:! - -!methodRemoval: Browser #request:initialAnswer: stamp: 'Install-4164-NonModalStringRequests-LucianoEstebanNotarfrancesco-2020May23-20h43m-len.001.cs.st 5/26/2020 17:08:34'! -request: prompt initialAnswer: initialAnswer - - ^ FillInTheBlankMorph - request: prompt - initialAnswer: initialAnswer -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4164-NonModalStringRequests-LucianoEstebanNotarfrancesco-2020May23-20h43m-len.001.cs.st----! - -'From Cuis 5.0 [latest update: #4163] on 23 May 2020 at 9:00:17 pm'! -!Object methodsFor: 'user interface' stamp: 'jmv 5/23/2020 21:00:08' prior: 50513630! - request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock - "This is deprecated because using it requires blocking the user interface until the user provides a response. Please use the variants that are not modal." - ^ UISupervisor ui request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock! ! -!Object methodsFor: 'user interface' stamp: 'jmv 5/23/2020 21:00:11' prior: 50513652! - request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock - ^ UISupervisor ui request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock! ! -!PasteUpMorph methodsFor: 'ui services' stamp: 'jmv 5/23/2020 21:00:01' overrides: 50515282! - request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock - "This is deprecated because using it requires blocking the user interface until the user provides a response. Please use the variants that are not modal." - ^ StringRequestMorph request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock! ! -!PasteUpMorph methodsFor: 'ui services' stamp: 'jmv 5/23/2020 21:00:05' overrides: 50515295! - request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock - ^ StringRequestMorph request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4165-AvoidMorphRefsInObject-JuanVuletich-2020May23-20h59m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4165] on 23 May 2020 at 9:08:32 pm'! -!FillInTheBlankMorph commentStamp: '' prior: 16844083! - A simple dialog with an entry field and accept / cancel buttons. - -This class is deprecated. Please use StringRequestMorph instead. This class will be deleted in the future.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4166-Mark-FillInTheBlankMorph-asObsolete-JuanVuletich-2020May23-21h07m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4166] on 24 May 2020 at 9:40:32 am'! -!StringRequestMorph class methodsFor: 'new-morph participation' stamp: 'KenD 5/23/2020 19:20:43' overrides: 16877229! - initializedInstance -" - StringRequestMorph initializedInstance. -" - | stringRequestMorph | - stringRequestMorph _ self - request: 'Enter answer here' - initialAnswer: 'What is the Answer?' - do: [:answer | PopUpMenu inform: answer ]. - ^stringRequestMorph! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4167-StringRequestMorph-new-morphParticipation-KenDickey-2020May24-09h38m-KenD.001.cs.st----! - -'From Cuis 5.0 [latest update: #4166] on 24 May 2020 at 9:41:25 am'! -!StringRequestMorph commentStamp: '' prior: 0! - This is a simple morph that allows the user to input a string. The user has the option to cancel (with the Esc key), or input a string and then accept (pressing Enter). For example: - - StringRequestMorph - request: 'What''s your name?' - initialAnswer: 'Jose' - do: [:aString| PopUpMenu inform: 'Hello ', aString, '!!'] - -Note that the request is not modal and a handler block must be provided. When the user accepts the input, the handler block is called with the user-provided string as argument. There's also the option to handle cancellation: - - StringRequestMorph - request: 'What''s your name?' - initialAnswer: 'Jose' - do: [:aString| PopUpMenu inform: 'Hello ', aString, '!!'] - orCancel: [PopUpMenu inform: 'Ok, nevermind'] - -And there's the option to provide a validation block that prevents from accepting invalid input: - - StringRequestMorph - request: 'Guess an even number between 1 and 3' - initialAnswer: '42' - verifying: [:aString| aString size > 0 and: [aString allSatisfy: [:each| each isDigit]]] - do: [:aString| PopUpMenu inform: (aString asInteger = 2 ifTrue: ['Yeah!!'] ifFalse: ['Nope'])] -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4168-StringRequestMorph-ClassComment-LucianoEstebanNotarfrancesco-2020May24-09h40m-len.001.cs.st----! - -'From Cuis 5.0 [latest update: #4166] on 24 May 2020 at 9:48:05 am'! -!Integer commentStamp: '' prior: 50510650! - I am a common abstract superclass for all Integer implementations. My implementation subclasses are SmallInteger, LargePositiveInteger, and LargeNegativeInteger. - -There are three implementations of division with remainder. For 'a' and 'b' Integers: - - Floored division, with the quotient rounded towards negative infinity: // and \\ answer 'q' and 'r' such that 'a = bq + r' with 'r abs < b abs', where 'r' is 0 or has the same sign as 'b'; - - Truncated division, with the quotient rounded towards zero: #quo: and #rem: answer 'q' and 'r' such that 'a = bq + r' with 'r abs < b abs', where 'r' is 0 or has the same sign as 'a'; - - Euclidean division with non-negative remainder: #div: and #mod: answer 'q' and 'r' such that 'a = bq + r' with '0 <= r < b abs'. - -Note that, strictly speaking, all of these divisions satisfy the definition of Euclidean division. The requirements imposed on the sign of the remainder (different for each type of division) guarantee a unique choice of quotient and remainder. - -Additionally, the division in the rational field is implemented with the message / that answers a Fraction 'a/b' if the result is not a whole integer.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4169-DivisionDocumentationFixed-LucianoEstebanNotarfrancesco-2020May24-09h41m-len.001.cs.st----! - -'From Cuis 5.0 [latest update: #4163] on 22 May 2020 at 7:13:13 am'! -!PasteUpMorph methodsFor: 'defaul desktop' stamp: 'len 5/22/2020 05:21:04' prior: 50495047! - recreateDefaultDesktop - | editor | - self whenUIinSafeState: [ - self hideTaskbar. - (submorphs - select: [ :ea | ea class == SystemWindow or: [ea class == TranscriptWindow]]) - do: [ :ea | ea delete ]. - TranscriptWindow openTranscript - morphPosition: 5 @ 290; - morphExtent: 990 @ 400. - editor _ TextEditor openTextEditor - morphPosition: 456 @ 10; - morphExtent: 900 @ 680. - editor setLabel: 'About Cuis'. - editor model actualContents: Utilities defaultTextEditorContents. - Theme current useTaskbar ifTrue: [self showTaskbar]. - ].! ! -!SystemWindow methodsFor: 'initialization' stamp: 'len 5/22/2020 05:29:29' prior: 16926321 overrides: 50379676! - openInWorld - "Ensure all widgets have proper colors before opening" - self widgetsColor: self windowColor. - super openInWorld! ! -!SystemWindow methodsFor: 'open/close' stamp: 'len 5/22/2020 05:30:12' prior: 16926561 overrides: 16876882! - delete - | thisWorld | - self okToChange ifFalse: [^self]. - thisWorld _ self world. - SystemWindow noteTopWindowIn: thisWorld but: self. - self sendToBack. - self removeHalo. - super delete. - self model: nil! ! - -Theme removeSelector: #windowClosed:! - -!methodRemoval: Theme #windowClosed: stamp: 'Install-4170-ThemeCleanupAndRespectTaksbarThemeSetting-LucianoEstebanNotarfrancesco-2020May22-05h14m-len.001.cs.st 5/26/2020 17:08:34'! -windowClosed: aSystemWindow - ^ self! - -Theme removeSelector: #windowOpen:! - -!methodRemoval: Theme #windowOpen: stamp: 'Install-4170-ThemeCleanupAndRespectTaksbarThemeSetting-LucianoEstebanNotarfrancesco-2020May22-05h14m-len.001.cs.st 5/26/2020 17:08:34'! -windowOpen: aSystemWindow - ^ self! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4170-ThemeCleanupAndRespectTaksbarThemeSetting-LucianoEstebanNotarfrancesco-2020May22-05h14m-len.001.cs.st----! - -'From Cuis 5.0 [latest update: #4170] on 24 May 2020 at 10:08:42 am'! -!PasteUpMorph methodsFor: 'geometry' stamp: 'jmv 5/24/2020 10:07:38' prior: 50500249 overrides: 16875287! - fontPreferenceChanged - self submorphsDo: [ :m | - m morphExtent: (m morphExtent max: m minimumExtent). - m fontPreferenceChanged ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4171-DontBeSoPedanticWithTheDefaultDesktop-JuanVuletich-2020May24-10h07m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4163] on 22 May 2020 at 7:49:10 pm'! -!Inspector methodsFor: 'constants' stamp: 'sqr 5/21/2020 18:34:19'! - indexHead - "This is the max index shown before skipping to the - last i2 elements of very long arrays" - ^ 500! ! -!Inspector methodsFor: 'constants' stamp: 'sqr 5/21/2020 18:41:19'! - indexLabelsForSize: aSize - - ^aSize <= self indexSize - ifTrue: [(1 to: aSize) collect: [:i | i printString]] - ifFalse: [(1 to: self indexHead) , (aSize - self indexTail + 1 to: aSize) collect: [:i | i printString]]! ! -!Inspector methodsFor: 'constants' stamp: 'sqr 5/21/2020 18:34:42'! - indexSize - ^self indexHead + self indexTail! ! -!Inspector methodsFor: 'constants' stamp: 'sqr 5/21/2020 18:34:25'! - indexTail - "This is the number of elements to show at the end - of very long arrays" - ^ 30! ! -!Inspector methodsFor: 'constants' stamp: 'sqr 5/21/2020 17:37:50'! - lastMetaField - "This value must be synchronized with the base field list, the - string selection indices, and the senders of this message" - - ^2! ! -!Inspector methodsFor: 'constants' stamp: 'sqr 5/21/2020 17:26:53'! - printStringLimit - - ^12000! ! -!Inspector methodsFor: 'constants' stamp: 'sqr 5/21/2020 17:30:31'! - stringSelectionIndices - - ^#(0 2)! ! -!Inspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 17:36:21'! - safelyPrintWith: aBlock - - ^aBlock - on: UnhandledError - do: - [:ex | - ex return: - (self printStringErrorText - addAttribute: TextColor red; - yourself) - ]! ! -!Inspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:52:35'! - selectedObjectIndex - "Answer the index of the inspectee's collection that the current selection refers to." - - | basicIndex | - basicIndex _ self selectionIndexNonMeta - self objectClassInstSize. - ^(self objectSize <= self indexSize or: [basicIndex <= self indexHead]) - ifTrue: [basicIndex] - ifFalse: [self objectSize - self indexSize + basicIndex]! ! -!Inspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:20:57'! - selectionIndexNonMeta - - ^self selectionIndex - self lastMetaField! ! -!Inspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:18:07'! - selectionIsMeta - - ^self selectionIndex <= self lastMetaField! ! -!Inspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:18:36'! - selectionIsUnmodifiable - "Answer if the current selected variable is modifiable via acceptance in the code pane. For most inspectors, no selection and a selection of self (selectionIndex = 1) are unmodifiable" - - ^self selectionIsMeta! ! -!Inspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:20:18'! - selectionMeta - "Answer the value of the selected meta field" - - self selectionIndex = 0 ifTrue: [^ '']. - self selectionIndex = 1 ifTrue: [^ object]. - self selectionIndex = 2 ifTrue: [^ self safelyPrintWith: [object longPrintStringLimitedTo: self printStringLimit]]. - ^self selectionMetaUnknown! ! -!Inspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:20:01'! - selectionMetaUnknown - - ^''! ! -!Inspector methodsFor: 'private' stamp: 'sqr 5/21/2020 18:51:48'! - objectClassInstSize - - ^object class instSize! ! -!Inspector methodsFor: 'private' stamp: 'sqr 5/21/2020 18:59:15'! - objectSize - - ^object basicSize! ! -!Inspector methodsFor: 'private' stamp: 'sqr 5/21/2020 18:18:45'! - printStringErrorFieldName - - ^self selectionIsUnmodifiable - ifTrue: ['self'] - ifFalse: [self selectedSlotName ifNil: ['??']]! ! -!CompiledMethodInspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:27:08' overrides: 50515618! - selectionIsUnmodifiable - "Answer if the current selected variable is unmodifiable via acceptance in the code pane. For most inspectors, no selection and a selection of self (selectionIndex = 1) are unmodifiable" - - ^ true! ! -!CompiledMethodInspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 19:09:37' overrides: 50515628! - selectionMeta - - self selectionIndex = 0 ifTrue: [^ '']. - self selectionIndex = 1 ifTrue: [^ object ]. - self selectionIndex = 2 ifTrue: [^ self safelyPrintWith: [object symbolic]]. - self selectionIndex = 3 ifTrue: [^ self safelyPrintWith: [object headerDescription]]. - ^self selectionMetaUnknown! ! -!CompiledMethodInspector methodsFor: 'constants' stamp: 'sqr 5/21/2020 17:55:47' overrides: 50515571! - lastMetaField - "This value must be synchronized with the base field list, the - string selection indices, and the senders of this message" - - ^3! ! -!CompiledMethodInspector methodsFor: 'constants' stamp: 'sqr 5/21/2020 17:57:32' overrides: 50515582! - stringSelectionIndices - - ^#(0 2 3)! ! -!DictionaryInspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:03:31'! - nonFixedSelectionIndex - ^self selectionIndex - self numberOfFixedFields! ! -!DictionaryInspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:01:20'! - selectionIndexFixed - ^self selectionIndex <= self numberOfFixedFields! ! -!DictionaryInspector methodsFor: 'constants' stamp: 'sqr 5/21/2020 17:57:08' overrides: 50515582! - stringSelectionIndices - - ^#(0)! ! -!OrderedCollectionInspector methodsFor: 'accessing' stamp: 'sqr 5/22/2020 19:47:10' overrides: 50515650! - objectSize - - ^object size! ! -!OrderedCollectionInspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 19:33:54' overrides: 16856992! - selectedSlotName - - self selectionIsMeta ifTrue: [^super selectedSlotName]. - self selectionIndexNonMeta <= self objectClassInstSize ifTrue: [^super selectedSlotName]. - ^'(self at: ', super selectedSlotName, ')'! ! -!Inspector methodsFor: 'accessing' stamp: 'sqr 5/21/2020 19:03:54' prior: 16856867! - fieldList - "Answer the base field list plus an abbreviated list of indices." - - object class isVariable ifFalse: [^ self baseFieldList]. - ^ self baseFieldList , (self indexLabelsForSize: self objectSize)! ! -!Inspector methodsFor: 'accessing' stamp: 'sqr 5/21/2020 18:18:41' prior: 16856897! - object: anObject - "Set anObject to be the object being inspected by the receiver." - - | oldIndex | - anObject == object - ifTrue: [self update] - ifFalse: - [oldIndex := self selectionIsUnmodifiable ifTrue: [selectionIndex] ifFalse: [0]. - self inspect: anObject. - oldIndex := oldIndex min: self fieldList size. - self changed: #inspectObject. - oldIndex > 0 - ifTrue: [self toggleIndex: oldIndex]. - self changed: #fieldList. - self acceptedContentsChanged ]! ! -!Inspector methodsFor: 'accessing' stamp: 'sqr 5/21/2020 18:18:50' prior: 16856914! - selectedClass - "Answer the class of the receiver's current selection" - - self selectionIsUnmodifiable ifTrue: [^ object class]. - ^ self selection class! ! -!Inspector methodsFor: 'accessing' stamp: 'sqr 5/21/2020 17:38:47' prior: 16856926! - update - "Reshow contents, assuming selected value may have changed." - - selectionIndex = 0 ifTrue: [^self]. - acceptedContentsCache _ self selectionPrintString. - self acceptedContentsChanged. - self changed: #selectionIndex! ! -!Inspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 19:01:51' prior: 16856963! - replaceSelectionValue: anObject - "The receiver has a list of variables of its inspected object. One of these - is selected. The value of the selected variable is set to the value, - anObject." - | si instVarIndex | - self selectionIsUnmodifiable ifTrue: [ - self toggleIndex: (si := selectionIndex). - self toggleIndex: si. - ^ object]. - instVarIndex := self selectionIndexNonMeta. - instVarIndex > self objectClassInstSize - ifFalse: [^ object instVarAt: instVarIndex put: anObject]. - object class isVariable or: [self error: 'Cannot replace selection']. - ^object basicAt: self selectedObjectIndex put: anObject! ! -!Inspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 19:01:10' prior: 16856997! - selection - "The receiver has a list of variables of its inspected object. - One of these is selected. Answer the value of the selected variable." - | index | - self selectionIsMeta ifTrue: [^self selectionMeta]. - self selectionIndexNonMeta <= self objectClassInstSize - ifTrue: [^ object instVarAt: self selectionIndexNonMeta]. - index _ self selectedObjectIndex. - ^object isString - ifTrue: [ object at: index ] - ifFalse: [ object basicAt: index ]! ! -!Inspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:30:40' prior: 16857030! - selectionPrintString - - (self stringSelectionIndices includes: self selectionIndex) ifTrue: [^self selection]. - ^self safelyPrintWith: [self selection printTextLimitedTo: self printStringLimit]! ! -!Inspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 19:16:57' prior: 16857048! - toggleIndex: anInteger - "The receiver has a list of variables of its inspected object. One of these - is selected. If anInteger is the index of this variable, then deselect it. - Otherwise, make the variable whose index is anInteger be the selected - item." - - selectionIndex := selectionIndex = anInteger ifTrue: [0] ifFalse: [anInteger]. - acceptedContentsCache _ self selectionPrintString. - self acceptedContentsChanged. - self changed: #selectionIndex! ! -!Inspector methodsFor: 'stepping' stamp: 'sqr 5/21/2020 17:43:15' prior: 16857091 overrides: 16882488! - stepAt: millisecondSinceLast - | newText | - newText := self selectionPrintString. - newText = acceptedContentsCache ifFalse: [ - acceptedContentsCache _ newText. - self acceptedContentsChanged ]! ! -!Inspector methodsFor: 'private' stamp: 'sqr 5/21/2020 17:46:30' prior: 16857082! - printStringErrorText - - ^('') asText! ! -!CompiledMethodInspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:28:30' prior: 16821748 overrides: 50515797! - selection - - | bytecodeIndex | - self selectionIsMeta ifTrue: [^self selectionMeta]. - self selectionIndexNonMeta <= object numLiterals - ifTrue: [ ^ object objectAt: selectionIndex - self lastMetaField + 1 ]. - bytecodeIndex _ selectionIndex - object numLiterals - self lastMetaField. - ^ object at: object initialPC + bytecodeIndex - 1! ! -!ContextInspector methodsFor: 'accessing' stamp: 'sqr 5/21/2020 18:54:07' prior: 16823498 overrides: 50515797! - selection - "The receiver has a list of variables of its inspected object. - One of these is selected. Answer the value of the selected variable." - | basicIndex | - self selectionIsMeta ifTrue: [^self selectionMeta]. - self selectionIndexNonMeta <= self objectClassInstSize - ifTrue: [^ object instVarAt: self selectionIndexNonMeta]. - basicIndex := self selectionIndexNonMeta - self objectClassInstSize. - ^object debuggerMap namedTempAt: basicIndex in: object -! ! -!DictionaryInspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:04:32' prior: 16833959 overrides: 50515775! - replaceSelectionValue: anObject - self selectionIndexFixed ifTrue: [^ super replaceSelectionValue: anObject]. - ^ object - at: (keyArray at: self nonFixedSelectionIndex) - put: anObject! ! -!DictionaryInspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:04:40' prior: 16833969! - selectedKey - "Create a browser on all senders of the selected key" - | i | - i _ self nonFixedSelectionIndex. - i > 0 ifFalse: [ ^ nil ]. - ^keyArray at: i! ! -!DictionaryInspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:04:52' prior: 16833977 overrides: 50515797! - selection - - self selectionIndexFixed ifTrue: [^ super selection]. - ^ object at: (keyArray at: self nonFixedSelectionIndex) ifAbsent: nil! ! -!DictionaryInspector methodsFor: 'menu' stamp: 'sqr 5/21/2020 18:04:11' prior: 16833985! - removeSelection - selectionIndex = 0 ifTrue: [^ self changed: #flash]. - object removeKey: (keyArray at: self nonFixedSelectionIndex). - selectionIndex := 0. - acceptedContentsCache _ ''. - self calculateKeyArray. - self changed: #inspectObject. - self changed: #selectionIndex. - self changed: #fieldList! ! -!DictionaryInspector methodsFor: 'menu' stamp: 'sqr 5/21/2020 18:05:08' prior: 16833998! - renameEntryTo: newKey - - | value | - value := object at: (keyArray at: self nonFixedSelectionIndex). - object removeKey: (keyArray at: self nonFixedSelectionIndex). - object at: newKey put: value. - self calculateKeyArray. - selectionIndex := self numberOfFixedFields + (keyArray indexOf: newKey). - self changed: #selectionIndex. - self changed: #inspectObject. - self changed: #fieldList. - self update! ! -!DictionaryInspector methodsFor: 'private' stamp: 'sqr 5/21/2020 18:54:20' prior: 16834014! - numberOfFixedFields - ^self lastMetaField + self objectClassInstSize! ! -!OrderedCollectionInspector methodsFor: 'accessing' stamp: 'sqr 5/22/2020 19:47:49' prior: 50367183 overrides: 50515729! -fieldList - - | fieldsHere | - object isNil ifTrue: [^#()]. - fieldsHere _ [self indexLabelsForSize: self objectSize] - on: UnhandledError - do: [:ex | ex return: #()]. - ^self baseFieldList , fieldsHere -" -OrderedCollection new inspect -(OrderedCollection newFrom: #(3 5 7 123)) inspect -(OrderedCollection newFrom: (1 to: 1000)) inspect -"! ! -!OrderedCollectionInspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:54:40' prior: 16884354 overrides: 50515775! - replaceSelectionValue: anObject - "The receiver has a list of variables of its inspected object. One of these - is selected. The value of the selected variable is set to the value, anObject." - - self selectionIndexNonMeta <= self objectClassInstSize - ifTrue: [^ super replaceSelectionValue: anObject]. - object at: self selectedObjectIndex put: anObject! ! -!OrderedCollectionInspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:53:08' prior: 16884382 overrides: 50515797! - selection - "The receiver has a list of variables of its inspected object. - One of these is selected. Answer the value of the selected variable." - - self selectionIndexNonMeta <= self objectClassInstSize ifTrue: [^ super selection]. - ^ object at: self selectedObjectIndex! ! -!SetInspector methodsFor: 'menu' stamp: 'sqr 5/21/2020 18:53:25' prior: 16907441! - removeSelection - selectionIndex <= self objectClassInstSize ifTrue: [^ self changed: #flash]. - object remove: self selection. - selectionIndex := 0. - acceptedContentsCache _ ''. - self changed: #inspectObject. - self changed: #fieldList. - self changed: #selectionIndex.! ! -!SetInspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:53:34' prior: 16907463 overrides: 50515797! - selection - self selectionIsMeta ifTrue: [^self selectionMeta]. - self selectionIndexNonMeta <= self objectClassInstSize - ifTrue: [^ object instVarAt: self selectionIndexNonMeta]. - ^ object array at: self arrayIndexForSelection! ! -!Float64Array methodsFor: 'inspecting' stamp: 'sqr 5/22/2020 19:48:34' prior: 16846169 overrides: 16881790! - inspectorClass - "Answer the class of the inspector to be used on the receiver. Called by inspect; - use basicInspect to get a normal (less useful) type of inspector." - - ^OrderedCollectionInspector! ! - -OrderedCollectionInspector removeSelector: #selectedObjectIndex! - -!methodRemoval: OrderedCollectionInspector #selectedObjectIndex stamp: 'Install-4172-InspectorRefactorAndFixes-AndresValloud-2020May22-19h44m-sqr.001.cs.st 5/26/2020 17:08:34'! -selectedObjectIndex - "Answer the index of the inspectee's collection that the current selection refers to." - - | basicIndex | - basicIndex _ selectionIndex - 2 - object class instSize. - ^ (object size <= (self i1 + self i2) or: [basicIndex <= self i1]) - ifTrue: [basicIndex] - ifFalse: [object size - (self i1 + self i2) + basicIndex]! - -DictionaryInspector removeSelector: #contentsIsString! - -!methodRemoval: DictionaryInspector #contentsIsString stamp: 'Install-4172-InspectorRefactorAndFixes-AndresValloud-2020May22-19h44m-sqr.001.cs.st 5/26/2020 17:08:34'! -contentsIsString - "Hacked so contents empty when deselected" - - ^ (selectionIndex = 0)! - -CompiledMethodInspector removeSelector: #selectionUnmodifiable! - -!methodRemoval: CompiledMethodInspector #selectionUnmodifiable stamp: 'Install-4172-InspectorRefactorAndFixes-AndresValloud-2020May22-19h44m-sqr.001.cs.st 5/26/2020 17:08:34'! -selectionUnmodifiable - "Answer if the current selected variable is unmodifiable via acceptance in the code pane. For most inspectors, no selection and a selection of self (selectionIndex = 1) are unmodifiable" - - ^ true! - -CompiledMethodInspector removeSelector: #contentsIsString! - -!methodRemoval: CompiledMethodInspector #contentsIsString stamp: 'Install-4172-InspectorRefactorAndFixes-AndresValloud-2020May22-19h44m-sqr.001.cs.st 5/26/2020 17:08:34'! -contentsIsString - "Hacked so contents empty when deselected" - - ^ #(0 2 3) includes: selectionIndex! - -Inspector removeSelector: #selectionUnmodifiable! - -!methodRemoval: Inspector #selectionUnmodifiable stamp: 'Install-4172-InspectorRefactorAndFixes-AndresValloud-2020May22-19h44m-sqr.001.cs.st 5/26/2020 17:08:34'! -selectionUnmodifiable - "Answer if the current selected variable is modifiable via acceptance in the code pane. For most inspectors, no selection and a selection of self (selectionIndex = 1) are unmodifiable" - - ^ selectionIndex <= 2! - -Inspector removeSelector: #contentsIsString! - -!methodRemoval: Inspector #contentsIsString stamp: 'Install-4172-InspectorRefactorAndFixes-AndresValloud-2020May22-19h44m-sqr.001.cs.st 5/26/2020 17:08:34'! -contentsIsString - "Hacked so contents empty when deselected and = long printString when item 2" - - ^ (selectionIndex = 2) | (selectionIndex = 0)! - -Inspector removeSelector: #i2! - -!methodRemoval: Inspector #i2 stamp: 'Install-4172-InspectorRefactorAndFixes-AndresValloud-2020May22-19h44m-sqr.001.cs.st 5/26/2020 17:08:34'! -i2 - "This is the number of elements to show at the end - of very long arrays" - ^ 30! - -Inspector removeSelector: #i1! - -!methodRemoval: Inspector #i1 stamp: 'Install-4172-InspectorRefactorAndFixes-AndresValloud-2020May22-19h44m-sqr.001.cs.st 5/26/2020 17:08:34'! -i1 - "This is the max index shown before skipping to the - last i2 elements of very long arrays" - ^ 500! - -Smalltalk removeClassNamed: #SequenceableCollectionInspector! - -!classRemoval: #SequenceableCollectionInspector stamp: 'Install-4172-InspectorRefactorAndFixes-AndresValloud-2020May22-19h44m-sqr.001.cs.st 5/26/2020 17:08:34'! -Inspector subclass: #SequenceableCollectionInspector - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Inspector'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4172-InspectorRefactorAndFixes-AndresValloud-2020May22-19h44m-sqr.001.cs.st----! - -'From Cuis 5.0 [latest update: #4164] on 22 May 2020 at 7:53:38 pm'! - -Smalltalk renameClassNamed: #OrderedCollectionInspector as: #SequenceableCollectionInspector! - -!classRenamed: #OrderedCollectionInspector as: #SequenceableCollectionInspector stamp: 'Install-4173-OrderedCollectionInspector-rename-AndresValloud-2020May22-19h53m-sqr.001.cs.st 5/26/2020 17:08:34'! -Smalltalk renameClassNamed: #OrderedCollectionInspector as: #SequenceableCollectionInspector! -!Float64Array methodsFor: 'inspecting' stamp: 'sqr 5/22/2020 19:53:21' prior: 50516016 overrides: 16881790! - inspectorClass - "Answer the class of the inspector to be used on the receiver. Called by inspect; - use basicInspect to get a normal (less useful) type of inspector." - - ^SequenceableCollectionInspector! ! -!FloatArray methodsFor: 'inspecting' stamp: 'sqr 5/22/2020 19:53:21' prior: 16846648 overrides: 16881790! - inspectorClass - "Answer the class of the inspector to be used on the receiver. Called by inspect; - use basicInspect to get a normal (less useful) type of inspector." - - ^SequenceableCollectionInspector! ! -!OrderedCollection methodsFor: 'inspecting' stamp: 'sqr 5/22/2020 19:53:21' prior: 16884066 overrides: 16881790! -inspectorClass - "Answer the class of the inspector to be used on the receiver. Called by inspect; - use basicInspect to get a normal (less useful) type of inspector." - - ^SequenceableCollectionInspector! ! -!AffineTransformation methodsFor: 'inspecting' stamp: 'sqr 5/22/2020 19:53:21' prior: 16778870 overrides: 16881790! - inspectorClass - "Answer the class of the inspector to be used on the receiver. Called by inspect; - use basicInspect to get a normal (less useful) type of inspector." - - ^SequenceableCollectionInspector! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4173-OrderedCollectionInspector-rename-AndresValloud-2020May22-19h53m-sqr.001.cs.st----! - -'From Cuis 5.0 [latest update: #4165] on 22 May 2020 at 6:01:28 pm'! -!Inspector methodsFor: 'initialization' stamp: 'sqr 5/22/2020 17:29:29'! - initializeEvents - - SystemChangeNotifier uniqueInstance - when: #classDefinitionChanged send: #classDefinitionChangedFrom:to: to: self! ! -!Inspector methodsFor: 'user interface support' stamp: 'sqr 5/22/2020 17:46:24'! - displayLabel - - | label | - label := [self object printStringLimitedTo: 64] - on: UnhandledError - do: [:ex | ex return: self objectClass printString, ' (printing failed)']. - "Note this is ambiguous: what happens with (Array with: Array)?" - (label includesSubString: self objectClass name) ifTrue: [^label]. - ^self objectClass name, ': ', label! ! -!Inspector methodsFor: 'user interface support' stamp: 'sqr 5/22/2020 17:58:49'! - suggestObjectSpecificMenuItemsFor: aMenu from: aWindow - - ^self! ! -!Inspector methodsFor: 'private' stamp: 'sqr 5/22/2020 17:30:31'! - classDefinitionChangedFrom: oldClass to: newClass - - self objectClass = newClass ifTrue: [self changed: #fieldList]! ! -!Inspector methodsFor: 'private' stamp: 'sqr 5/22/2020 17:20:22'! - objectClass - - ^self objectClass: self object! ! -!Inspector methodsFor: 'private - mirror interface' stamp: 'sqr 5/22/2020 17:19:32'! - object: anObject basicAt: index - "Answer the value of an indexable element in the argument anObject without sending - it a message. Fail if the argument index is not an Integer or is out of bounds, or if - anObject is not indexable. This mimics the action of the VM when it indexes an object. - Used to simulate the execution machinery by, for example, the debugger. - Primitive. See Object documentation whatIsAPrimitive." - - - index isInteger ifTrue: [self errorSubscriptBounds: index]. - index isNumber - ifTrue: [^self object: anObject basicAt: index asInteger] - ifFalse: [self errorNonIntegerIndex]! ! -!Inspector methodsFor: 'private - mirror interface' stamp: 'sqr 5/22/2020 17:19:26'! - object: anObject instVarAt: anIndex - "Primitive. Answer a fixed variable in an object. The numbering of the - variables corresponds to the named instance variables. Fail if the index - is not an Integer or is not the index of a fixed variable. Essential for the - debugger. See Object documentation whatIsAPrimitive." - - - "Access beyond fixed variables." - ^self object: anObject basicAt: anIndex - (self objectClass: anObject) instSize! ! -!Inspector methodsFor: 'private - mirror interface' stamp: 'sqr 5/22/2020 17:19:03'! - objectClass: anObject - - - self primitiveFailed! ! -!Inspector methodsFor: 'private - mirror interface' stamp: 'sqr 5/22/2020 17:19:20'! - objectSize: anObject - "Answer the number of indexable variables in the argument anObject without sending - it a message. This mimics the action of the VM when it fetches an object's variable size. - Used to simulate the execution machinery by, for example, the debugger. - Primitive. See Object documentation whatIsAPrimitive." - - - "The number of indexable fields of fixed-length objects is 0" - ^0! ! -!DictionaryInspector methodsFor: 'user interface support' stamp: 'sqr 5/22/2020 17:59:18' overrides: 50516221! - suggestObjectSpecificMenuItemsFor: aMenu from: aWindow - - aMenu addItemsFromDictionaries: aWindow menuOptionsForDictionary! ! -!SetInspector methodsFor: 'user interface support' stamp: 'sqr 5/22/2020 17:59:43' overrides: 50516221! - suggestObjectSpecificMenuItemsFor: aMenu from: aWindow - - aMenu addItemsFromDictionaries: aWindow menuOptionsForSet! ! -!Object methodsFor: 'inspecting' stamp: 'sqr 5/22/2020 17:57:17' prior: 16881767! - basicInspect - "Create and schedule an Inspector in which the user can examine the - receiver's variables. This method should not be overriden." - - Inspector openOn: self! ! -!Inspector methodsFor: 'initialization' stamp: 'sqr 5/22/2020 17:29:42' prior: 16857107 overrides: 16896425! - initialize - - super initialize. - acceptedContentsCache _ ''. - selectionIndex := 0. - self initializeEvents! ! -!Inspector methodsFor: 'private' stamp: 'sqr 5/22/2020 17:20:12' prior: 50515646! - objectClassInstSize - - ^self objectClass instSize! ! -!Inspector methodsFor: 'private' stamp: 'sqr 5/22/2020 17:20:38' prior: 50515650! - objectSize - - ^self objectSize: self object! ! -!InspectorWindow methodsFor: 'GUI building' stamp: 'sqr 5/22/2020 17:26:00' prior: 50467399! - buildMorphicWindow - " Inspector openOn: SystemOrganization " - | contentsText list upperRow evaluatorText | - - "Build widgets. We'll assemble them below." - list _ self buildList. - contentsText _ self buildContentsText. - evaluatorText _ self buildEvaluatorText. - - "Upper row has two widgets, side by side: the list of variables at the left side, and the variable contents pane at the right side." - upperRow _ LayoutMorph newRow. - upperRow - addMorph: list proportionalWidth: 0.3; - addAdjusterAndMorph: contentsText proportionalWidth: 0.7. - "Inspector Window has two rows: At the top, the one we just bult. Below it, the evaluation pane." - self layoutMorph - addMorph: upperRow proportionalHeight: 0.7; - addAdjusterAndMorph: evaluatorText proportionalHeight: 0.3. - "Set label" - self setLabel: model displayLabel! ! -!InspectorWindow methodsFor: 'menu building' stamp: 'sqr 5/22/2020 17:44:18' prior: 50495498! - fieldListMenu - "Arm the supplied menu with items for the field-list of the receiver" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addItemsFromDictionaries: self basicMenuOptions. - self model suggestObjectSpecificMenuItemsFor: aMenu from: self. - aMenu addItemsFromDictionaries: self menuOptionsForBrowsing. - ^ aMenu! ! - -InspectorWindow removeSelector: #classDefinitionChangedFrom:to:! - -!methodRemoval: InspectorWindow #classDefinitionChangedFrom:to: stamp: 'Install-4174-Inspector-MirrorPrimitives-AndresValloud-2020May22-17h15m-sqr.001.cs.st 5/26/2020 17:08:34'! -classDefinitionChangedFrom: oldClass to: newClass - - model ifNotNil: [ model object class = newClass ifTrue: [ model changed: #fieldList ]]! - -InspectorWindow removeSelector: #addCollectionSpecificMenuOptionsTo:! - -!methodRemoval: InspectorWindow #addCollectionSpecificMenuOptionsTo: stamp: 'Install-4174-Inspector-MirrorPrimitives-AndresValloud-2020May22-17h15m-sqr.001.cs.st 5/26/2020 17:08:34'! -addCollectionSpecificMenuOptionsTo: aMenu - - | object | - object _ model object. - (object is: #Dictionary) ifTrue: [ - aMenu addItemsFromDictionaries: self menuOptionsForDictionary ] - ifFalse: [ (object is: #Set) ifTrue: [ - aMenu addItemsFromDictionaries: self menuOptionsForSet ]]! - -InspectorWindow removeSelector: #model:! - -!methodRemoval: InspectorWindow #model: stamp: 'Install-4174-Inspector-MirrorPrimitives-AndresValloud-2020May22-17h15m-sqr.001.cs.st 5/26/2020 17:08:34'! -model: aModel - - super model: aModel. - model ifNotNil: [ - SystemChangeNotifier uniqueInstance - when: #classDefinitionChanged send: #classDefinitionChangedFrom:to: to: self ] -! - -Inspector removeSelector: #suggestObjectSpecificMenuItemsTo:for:! - -Smalltalk removeClassNamed: #BasicInspector! - -!classRemoval: #BasicInspector stamp: 'Install-4174-Inspector-MirrorPrimitives-AndresValloud-2020May22-17h15m-sqr.001.cs.st 5/26/2020 17:08:34'! -Inspector subclass: #BasicInspector - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Inspector'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4174-Inspector-MirrorPrimitives-AndresValloud-2020May22-17h15m-sqr.001.cs.st----! - -'From Cuis 5.0 [latest update: #4166] on 23 May 2020 at 8:15:03 pm'! -!ProtoObject methodsFor: 'testing' stamp: 'jmv 5/23/2020 19:54:19'! - isObject - ^false! ! -!Object methodsFor: 'testing' stamp: 'jmv 5/23/2020 19:54:03' overrides: 50516442! - isObject - ^true! ! -!Inspector methodsFor: 'accessing' stamp: 'jmv 5/23/2020 19:59:02' prior: 16856846! - baseFieldList - "Answer an Array consisting of 'self' - and the instance variable names of the inspected object." - - ^ (Array with: 'self' with: 'all inst vars') - , self objectClass allInstVarNames! ! -!Inspector methodsFor: 'accessing' stamp: 'jmv 5/23/2020 19:59:18' prior: 50515729! - fieldList - "Answer the base field list plus an abbreviated list of indices." - - self objectClass isVariable ifFalse: [^ self baseFieldList]. - ^ self baseFieldList , (self indexLabelsForSize: self objectSize)! ! -!Inspector methodsFor: 'accessing' stamp: 'jmv 5/23/2020 19:59:47' prior: 50515757! - selectedClass - "Answer the class of the receiver's current selection" - - self selectionIsUnmodifiable ifTrue: [^ self objectClass]. - ^ self selection class! ! -!Inspector methodsFor: 'selecting' stamp: 'jmv 5/23/2020 19:59:34' prior: 50515775! - replaceSelectionValue: anObject - "The receiver has a list of variables of its inspected object. One of these - is selected. The value of the selected variable is set to the value, - anObject." - | si instVarIndex | - self selectionIsUnmodifiable ifTrue: [ - self toggleIndex: (si := selectionIndex). - self toggleIndex: si. - ^ object]. - instVarIndex := self selectionIndexNonMeta. - instVarIndex > self objectClassInstSize - ifFalse: [^ object instVarAt: instVarIndex put: anObject]. - self objectClass isVariable or: [self error: 'Cannot replace selection']. - ^object basicAt: self selectedObjectIndex put: anObject! ! -!Inspector methodsFor: 'selecting' stamp: 'jmv 5/23/2020 20:12:32' prior: 50515797! -selection - "The receiver has a list of variables of its inspected object. - One of these is selected. Answer the value of the selected variable." - | index | - self selectionIsMeta ifTrue: [^self selectionMeta]. - self selectionIndexNonMeta <= self objectClassInstSize - ifTrue: [^ self object: object instVarAt: self selectionIndexNonMeta]. - index _ self selectedObjectIndex. - ^(object isObject and: [object isString]) - ifTrue: [ object at: index ] - ifFalse: [ self object: object basicAt: index ]! ! -!Inspector methodsFor: 'shout styling' stamp: 'jmv 5/23/2020 19:59:09' prior: 50367388! - bindingNamesDo: aBlock - self objectClass allInstVarNames do: aBlock! ! -!Inspector methodsFor: 'shout styling' stamp: 'jmv 5/23/2020 19:59:25' prior: 50367393! - hasBindingOf: aString - ^ self objectClass allInstVarNames includes: aString! ! -!Inspector methodsFor: 'user interface support' stamp: 'jmv 5/23/2020 20:02:35' prior: 50516207! - displayLabel - - | label | - object isObject ifFalse: [^self objectClass name]. - label := [object printStringLimitedTo: 64] - on: UnhandledError - do: [:ex | ex return: self objectClass printString, ' (printing failed)']. - "Note this is ambiguous: what happens with (Array with: Array)?" - (label includesSubString: self objectClass name) ifTrue: [^label]. - ^self objectClass name, ': ', label! ! -!Inspector methodsFor: 'private' stamp: 'sqr 5/23/2020 19:47:40' prior: 50516232! - objectClass - - ^self objectClass: object! ! -!Inspector methodsFor: 'private' stamp: 'sqr 5/23/2020 19:47:52' prior: 50516334! - objectSize - - ^self objectSize: object! ! - -Inspector removeSelector: #object! - -!methodRemoval: Inspector #object stamp: 'Install-4175-AvoidUnwantedMaterialization-JuanVuletich-2020May23-20h14m-jmv.001.cs.st 5/26/2020 17:08:34'! -object - "Answer the object being inspected by the receiver." - - ^object! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4175-AvoidUnwantedMaterialization-JuanVuletich-2020May23-20h14m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4167] on 23 May 2020 at 5:08:44 pm'! -!Inspector methodsFor: 'accessing' stamp: 'sqr 5/23/2020 17:05:55' prior: 50515739! - object: anObject - "Set anObject to be the object being inspected by the receiver." - - | oldIndex | - anObject == object ifTrue: [^self update]. - oldIndex := self selectionIsUnmodifiable ifTrue: [selectionIndex] ifFalse: [0]. - self inspect: anObject. - oldIndex := oldIndex min: self fieldList size. - self changed: #inspectObject. - oldIndex > 0 ifTrue: [self toggleIndex: oldIndex]. - self changed: #fieldList. - self acceptedContentsChanged! ! -!Inspector methodsFor: 'accessing' stamp: 'sqr 5/23/2020 17:06:28' prior: 50515765! - update - "Reshow contents, assuming selected value may have changed." - - selectionIndex = 0 ifFalse: [self changedSelectionIndex]! ! -!Inspector methodsFor: 'selecting' stamp: 'sqr 5/23/2020 17:06:21' prior: 50515823! - toggleIndex: anInteger - "The receiver has a list of variables of its inspected object. One of these - is selected. If anInteger is the index of this variable, then deselect it. - Otherwise, make the variable whose index is anInteger be the selected - item." - - selectionIndex := selectionIndex = anInteger ifTrue: [0] ifFalse: [anInteger]. - self changedSelectionIndex! ! -!Inspector methodsFor: 'private' stamp: 'sqr 5/23/2020 17:05:06'! - changedSelectionIndex - - acceptedContentsCache _ self selectionPrintString. - self acceptedContentsChanged. - self changed: #selectionIndex! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4176-AdditionalInspectorCleanup-AndresValloud-2020May23-17h04m-sqr.001.cs.st----! - -'From Cuis 5.0 [latest update: #4176] on 24 May 2020 at 8:20:17 pm'! -!SequenceableCollectionInspector methodsFor: 'accessing' stamp: 'sqr 5/24/2020 06:32:42' prior: 50515951 overrides: 50516459! - fieldList - - | fieldsHere | - object isNil ifTrue: [^#()]. - fieldsHere _ self indexLabelsForSize: self objectSize. - ^self baseFieldList , fieldsHere -" -OrderedCollection new inspect -(OrderedCollection newFrom: #(3 5 7 123)) inspect -(OrderedCollection newFrom: (1 to: 1000)) inspect -"! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4177-RemoveExtraneousExceptionHandler-AndresValloud-2020May24-20h19m-sqr.001.cs.st----! - -'From Cuis 5.0 [latest update: #4176] on 24 May 2020 at 8:25:32 pm'! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'jmv 5/24/2020 20:25:23' prior: 50415447! - selectedClassOrMetaClassIn: specificModel - - (specificModel is: #CodeProvider) ifTrue: [ ^ specificModel selectedClassOrMetaClass ]. - - "I can not use #selectedClassOrMetaClass becuase it changes with the selection but when compiling to evaluate it assumes object as receiver - Hernan" - ^ (specificModel isKindOf: Inspector) ifTrue: [ specificModel objectClass ] ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4178-FixSmalltalkCompleterInInspector-JuanVuletich-2020May24-20h20m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4176] on 24 May 2020 at 9:22:20 pm'! -!SetInspector methodsFor: 'selecting' stamp: 'jmv 5/24/2020 21:18:03'! - selectionIndexFixed - ^self selectionIndexNonMeta <= self objectClassInstSize! ! -!DictionaryInspector methodsFor: 'menu' stamp: 'jmv 5/24/2020 21:15:04' prior: 50515916! - removeSelection - - self selectionIndexFixed ifTrue: [^ self changed: #flash]. - object removeKey: (keyArray at: self nonFixedSelectionIndex). - selectionIndex := 0. - acceptedContentsCache _ ''. - self calculateKeyArray. - self changed: #inspectObject. - self changed: #selectionIndex. - self changed: #fieldList! ! -!DictionaryInspector methodsFor: 'menu' stamp: 'jmv 5/24/2020 21:15:48' prior: 50515929! - renameEntryTo: newKey - - | oldKey value | - self selectionIndexFixed ifTrue: [^ self changed: #flash]. - oldKey _ keyArray at: self nonFixedSelectionIndex. - value _ object at: oldKey. - object removeKey: oldKey. - object at: newKey put: value. - self calculateKeyArray. - selectionIndex := self numberOfFixedFields + (keyArray indexOf: newKey). - self changed: #selectionIndex. - self changed: #inspectObject. - self changed: #fieldList. - self update! ! -!SetInspector methodsFor: 'menu' stamp: 'jmv 5/24/2020 21:18:19' prior: 50515993! - removeSelection - - self selectionIndexFixed ifTrue: [^ self changed: #flash]. - object remove: self selection. - selectionIndex := 0. - acceptedContentsCache _ ''. - self changed: #inspectObject. - self changed: #fieldList. - self changed: #selectionIndex.! ! -!SetInspector methodsFor: 'selecting' stamp: 'jmv 5/24/2020 21:20:23' prior: 16907457 overrides: 50516477! - replaceSelectionValue: anObject - self selectionIndexFixed ifTrue: [^ super replaceSelectionValue: anObject]. - ^ object array at: self arrayIndexForSelection put: anObject! ! -!SetInspector methodsFor: 'selecting' stamp: 'jmv 5/24/2020 21:21:47' prior: 50516005 overrides: 50516499! - selection - - self selectionIndexFixed ifTrue: [^ super selection]. - ^ object array at: self arrayIndexForSelection! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4179-InspectorFixes-JuanVuletich-2020May24-20h25m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4179] on 24 May 2020 at 9:02:58 pm'! -!SequenceableCollectionInspector methodsFor: 'accessing' stamp: 'sqr 5/24/2020 21:00:15' prior: 50516622 overrides: 50516459! - fieldList - "Must tolerate malformed objects" - - | fieldsHere | - object isNil ifTrue: [^#()]. - fieldsHere _ [self indexLabelsForSize: self objectSize] - on: UnhandledError - do: [:ex | ex return: #()]. - ^self baseFieldList , fieldsHere -" -OrderedCollection new inspect -(OrderedCollection newFrom: #(3 5 7 123)) inspect -(OrderedCollection newFrom: (1 to: 1000)) inspect -"! ! -!SequenceableCollectionInspector methodsFor: 'accessing' stamp: 'sqr 5/24/2020 21:00:01' prior: 50515714 overrides: 50516548! - objectSize - "Must tolerate malformed objects" - - ^[object size] - on: UnhandledError - do: [:ex | ex return: 0]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4180-InspectorTolerance-AndresValloud-2020May24-20h58m-sqr.001.cs.st----! - -'From Cuis 5.0 [latest update: #4179] on 24 May 2020 at 9:15:22 pm'! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'sqr 5/24/2020 21:13:36'! - doItProfiling: aBoolean - "Set the context to include pool vars of the model. Then evaluate. - Print the result on the Transcript" - ^ self - evaluateSelectionAndDo: [ :result | - Transcript finishEntry. - [result print] - on: UnhandledError - do: [:ex | 'printing doIt result failed' print]] - ifFail: nil - profiled: aBoolean! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'sqr 5/24/2020 21:13:48' prior: 50431457! - doIt - - ^self doItProfiling: false! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'sqr 5/24/2020 21:14:03' prior: 16909753! - profileIt - - ^self doItProfiling: true! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4181-SmalltalkEditorTolerance-AndresValloud-2020May24-21h02m-sqr.001.cs.st----! - -'From Cuis 5.0 [latest update: #4171] on 24 May 2020 at 10:21:53 am'! -!Preferences class methodsFor: 'shout' stamp: 'len 5/22/2020 20:10:48'! -useAlwaysLeftArrow - " - Preferences useAlwaysLeftArrow - " - Preferences setPreference: #assignmentGlyphSelector toValue: #useAlwaysLeftArrow. - AbstractFont withAllSubclassesDo: [ :fontClass | fontClass assignmentGlyphSelectorPreferenceChanged ].! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'len 5/22/2020 20:09:51'! - useAlwaysLeftArrow - ^ self useLeftArrow! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4182-useAlwaysLeftArrow-LucianoEstebanNotarfrancesco-2020May24-10h18m-len.001.cs.st----! - -'From Cuis 5.0 [latest update: #4172] on 24 May 2020 at 10:50:45 am'! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 5/24/2020 10:36:55'! - loadOnlyLatinGlyphData - ^ self - valueOfFlag: #loadOnlyLatinGlyphData - ifAbsent: [true]! ! -!FontFamily methodsFor: 'caching' stamp: 'jmv 5/24/2020 10:46:19'! - releaseCachedState - - baseFontBySizes keysAndValuesDo: [ :size :font | - font releaseCachedState ]! ! -!FontFamily class methodsFor: 'cached state access' stamp: 'jmv 5/24/2020 10:46:40' overrides: 50510040! - releaseClassCachedState - - AvailableFamilies keysAndValuesDo: [ :familyName :fontFamily | - fontFamily releaseCachedState ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4183-loadOnlyLatin-releaseFontCachedData-JuanVuletich-2020May24-10h48m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4183] on 25 May 2020 at 10:31:26 am'! -!CodeWindow methodsFor: 'misc' stamp: 'len 5/25/2020 07:08:44' prior: 50514776! - sendQuery: querySelector to: queryPerformer - "Apply a query to the primary selector associated with the current context. If no such selection exists, obtain one by user type-in. Then send querySelector to queryPerformer with the selector as its argument." - - model selectedMessageName ifNotNil: [:aSymbol| ^ queryPerformer perform: querySelector with: aSymbol]. - self request: 'Type selector:' initialAnswer: 'flag:' verifying: [:aString| aString notEmpty] do: [:aString| - (Symbol hasInterned: aString ifTrue: [ :aSymbol | queryPerformer perform: querySelector with: aSymbol]) - ifFalse: [self inform: 'no such selector']]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4184-sendQueryto-fix-LucianoEstebanNotarfrancesco-2020May25-10h31m-len.001.cs.st----! - -'From Cuis 5.0 [latest update: #4176] on 24 May 2020 at 9:30:33 pm'! -!TaskbarMorph methodsFor: 'resize' stamp: 'jmv 5/24/2020 21:29:40'! - scaleSmall - - self scale: 1/2! ! -!TaskbarMorph methodsFor: 'menus' stamp: 'jmv 5/24/2020 21:29:02' prior: 50337327 overrides: 16874769! - mouseButton2Activity - - | menu | - menu _ MenuMorph new defaultTarget: self. - menu - addLine; - add: 'Small Height' action: #scaleSmall; - add: 'Normal Height' action: #scaleNormal; - add: 'Scale x 2' action: #scaleX2; - add: 'Scale x 4' action: #scaleX4. - menu popUpInWorld! ! -!TaskbarMorph methodsFor: 'resize' stamp: 'jmv 5/24/2020 21:30:02' prior: 50337337! - scale: anInteger - - (anInteger between: 1/2 and: 4) ifFalse: [ self error: 'scale should be 1/2, 1, 2 or 4' ]. - scale := anInteger. - self screenSizeChanged. "rescale self" - viewBox ifNotNil: [ "rescale buttons" - viewBox submorphs do: [ :button | - button layoutSpec fixedWidth: self defaultHeight - ] - ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4185-TaskbarScaleOneHalf-JuanVuletich-2020May24-21h22m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4176] on 24 May 2020 at 9:41:38 pm'! - -PluggableMorph subclass: #PluggableButtonMorph - instanceVariableNames: 'label font icon getStateSelector actionSelector isPressed mouseIsOver magnifiedIcon actWhen roundButtonStyle iconName secondaryActionSelector ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #PluggableButtonMorph category: #'Morphic-Views' stamp: 'Install-4186-rightClickInTaskbar-JuanVuletich-2020May24-21h30m-jmv.001.cs.st 5/26/2020 17:08:35'! -PluggableMorph subclass: #PluggableButtonMorph - instanceVariableNames: 'label font icon getStateSelector actionSelector isPressed mouseIsOver magnifiedIcon actWhen roundButtonStyle iconName secondaryActionSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! -!PluggableButtonMorph methodsFor: 'events' stamp: 'jmv 5/24/2020 21:38:17' overrides: 16874580! - mouseButton2Up: aMouseButtonEvent localPosition: localEventPosition - - secondaryActionSelector ifNotNil: [ - model perform: secondaryActionSelector ]. - self redrawNeeded! ! -!PluggableButtonMorph methodsFor: 'initialization' stamp: 'jmv 5/24/2020 21:36:57'! -secondaryActionSelector: actionSel - - secondaryActionSelector _ actionSel.! ! -!HoverableButtonMorph methodsFor: 'initialization' stamp: 'jmv 5/24/2020 21:35:06' prior: 50431893! - model: anObject stateGetter: getStateSel action: actionSel onMouseEnterSend: aMouseEnterSelector onMouseLeaveSend: aMouseLeaveSelector - - self model: anObject stateGetter: getStateSel action: actionSel label: nil. - mouseEnterSelector _ aMouseEnterSelector. - mouseLeaveSelector _ aMouseLeaveSelector.! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 5/24/2020 21:40:25' prior: 50500338! - addButtonFor: aMorph - - | button | - aMorph == self ifFalse: [ - button _ HoverableButtonMorph - model: aMorph - stateGetter: nil - action: #endPreviewAndToggleCollapseOrShow - onMouseEnterSend: #beginPreview - onMouseLeaveSend: #endPreview. - (aMorph is: #SystemWindow) ifTrue: [ - button - secondaryActionSelector: #offerWindowMenu ]. - button - color: self color; - icon: (aMorph imageForm: 400@300 depth: 32); - setBalloonText: #label. - button icon: button magnifiedIcon. - viewBox - addMorph: button - fixedWidth: self defaultHeight ]! ! - -PluggableMorph subclass: #PluggableButtonMorph - instanceVariableNames: 'label font icon getStateSelector actionSelector isPressed mouseIsOver magnifiedIcon actWhen roundButtonStyle iconName secondaryActionSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #PluggableButtonMorph category: #'Morphic-Views' stamp: 'Install-4186-rightClickInTaskbar-JuanVuletich-2020May24-21h30m-jmv.001.cs.st 5/26/2020 17:08:35'! -PluggableMorph subclass: #PluggableButtonMorph - instanceVariableNames: 'label font icon getStateSelector actionSelector isPressed mouseIsOver magnifiedIcon actWhen roundButtonStyle iconName secondaryActionSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4186-rightClickInTaskbar-JuanVuletich-2020May24-21h30m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4171] on 25 May 2020 at 12:59:52 am'! - -"Change Set: 4172-CuisCore-AuthorName-2020May24-19h34m -Date: 25 May 2020 -Author: Nahuel Garbezza - -[extract temporary / rename temporary] - - fix error message for instance variable already defined in class - - allow to perform the refactoring in a debugger - -[extract method] - - extracting to an existing selector (in the current class or any superclass) now raises a warning - - allow to perform the refactoring in a debugger - - improve error messages and validation logic - -[documentation] - - add a comment on RefactoringPrecondition class"! - -RefactoringApplier subclass: #ExtractMethodApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newSelector newMessageArguments codeProvider ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractMethodApplier category: #'Tools-Refactoring' stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:08:35'! -RefactoringApplier subclass: #ExtractMethodApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newSelector newMessageArguments codeProvider' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #ExtractToTemporaryApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newVariable codeProvider ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractToTemporaryApplier category: #'Tools-Refactoring' stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:08:35'! -RefactoringApplier subclass: #ExtractToTemporaryApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newVariable codeProvider' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!RefactoringPrecondition commentStamp: '' prior: 0! - I represent a precondition, a prerequisite for a refactoring to be evaluated successfully. My public instance protocol includes only one message, #value, which could raise either a RefactoringError (in case the refactoring cannot be performed) or a RefactoringWarning (in case something needs the programmer's attention, but it can be resumed to continue with the refactoring).! - -Smalltalk renameClassNamed: #ExtractMethodExpressionValidation as: #SourceCodeOfMethodToBeExtractedPrecondition! - -!classRenamed: #ExtractMethodExpressionValidation as: #SourceCodeOfMethodToBeExtractedPrecondition stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:08:35'! -Smalltalk renameClassNamed: #ExtractMethodExpressionValidation as: #SourceCodeOfMethodToBeExtractedPrecondition! - -RefactoringPrecondition subclass: #SourceCodeOfMethodToBeExtractedPrecondition - instanceVariableNames: 'method intervalToExtract methodNode sourceCode initialNode finalNode initialNodeAncestors finalNodeAncestors ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #SourceCodeOfMethodToBeExtractedPrecondition category: #'Tools-Refactoring' stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:08:35'! -RefactoringPrecondition subclass: #SourceCodeOfMethodToBeExtractedPrecondition - instanceVariableNames: 'method intervalToExtract methodNode sourceCode initialNode finalNode initialNodeAncestors finalNodeAncestors' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!SourceCodeOfMethodToBeExtractedPrecondition commentStamp: '' prior: 50497190! - I check if a piece of source code selected for extract method can actually be extracted. - -Many conditions have to happen: -* we are selecting from the beginning of an AST node to an end of an AST node -* it is a smalltalk expression, a single statement or a sequence of complete statements -* the expression does not contain returns, or temporary variable assignments (if there is a temporary variable assignment, the declaration and all the usages should be extracted as well)! -!CodeProvider methodsFor: 'contents' stamp: 'RNG 5/24/2020 21:27:20'! - currentMethodRefactored - - self acceptedContentsChanged -! ! -!Debugger methodsFor: 'contents' stamp: 'RNG 5/24/2020 21:27:20' overrides: 50517146! - currentMethodRefactored - - | newMethod | - - newMethod := self selectedClass compiledMethodAt: self selectedContext selector. - self resetToSelectedContextWith: newMethod ! ! -!SmalltalkEditor methodsFor: 'private' stamp: 'RNG 5/24/2020 21:34:17'! - performCodeExtractionRefactoringWith: aRefactoringApplierClass - - "To prevent the refactoring to be evaluated on editors w/o methods like the workspace - Nahuel" - self hasValidCurrentCompiledMethod ifFalse: [ ^ nil ]. - - self ifSourceCodeRefactoringCanBeAppliedDo: [ - - aRefactoringApplierClass createAndValueHandlingExceptions: [ - aRefactoringApplierClass - on: self codeProvider - for: self selectionInterval asSourceCodeInterval - of: self codeProvider currentCompiledMethod ] ]! ! -!ExtractMethod class methodsFor: 'error messages' stamp: 'RNG 5/24/2020 19:50:32'! - wrongNumberOfArgumentsGivenErrorMessage - - ^ 'The number of arguments in the given selector is not correct'! ! -!ExtractMethod class methodsFor: 'pre-conditions' stamp: 'RNG 5/24/2020 22:36:58'! - assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: anIntervalToExtract - - self - assertIntervalToExtractIsNotEmpty: anIntervalToExtract; - assert: anIntervalToExtract isWithinBoundsOf: aMethodToExtractCodeFrom sourceCode; - assert: aMethodToExtractCodeFrom containsValidCodeToBeExtractedAt: anIntervalToExtract! ! -!ExtractMethod class methodsFor: 'private - pre-conditions' stamp: 'RNG 5/24/2020 22:33:47'! - assert: aMethodToRefactor containsValidCodeToBeExtractedAt: anIntervalToExtract - - SourceCodeOfMethodToBeExtractedPrecondition valueFor: anIntervalToExtract of: aMethodToRefactor! ! -!ExtractMethod class methodsFor: 'private - pre-conditions' stamp: 'RNG 5/24/2020 22:37:04'! - assert: anIntervalToExtract isWithinBoundsOf: sourceCode - - (self is: anIntervalToExtract withinBoundsOf: sourceCode) - ifFalse: [ self signalOutOfBoundsIntervalError ]! ! -!ExtractMethod class methodsFor: 'private - pre-conditions' stamp: 'RNG 5/24/2020 22:35:01'! - assertIntervalToExtractIsNotEmpty: anIntervalToExtract - - (self isNotEmpty: anIntervalToExtract) - ifFalse: [ self signalNoSelectedCodeError ]! ! -!ExtractMethodApplier methodsFor: 'initialization' stamp: 'RNG 5/24/2020 21:11:57'! - initializeOn: aCodeProvider for: anIntervalToExtract of: aMethodToExtractCodeFrom - - codeProvider := aCodeProvider. - intervalToExtract := anIntervalToExtract. - methodToExtractCodeFrom := aMethodToExtractCodeFrom. - newMessageArguments := Dictionary new! ! -!ExtractMethodApplier class methodsFor: 'instance creation' stamp: 'RNG 5/24/2020 22:32:42'! - on: aCodeProvider for: anIntervalToExtract of: aMethodToRefactor - - | trimmedIntervalToExtract sourceCode | - sourceCode := aMethodToRefactor sourceCode. - trimmedIntervalToExtract := anIntervalToExtract trimToMatchExpressionOn: sourceCode.. - - self assertCanApplyRefactoringOn: aMethodToRefactor at: trimmedIntervalToExtract. - - ^ self new initializeOn: aCodeProvider for: trimmedIntervalToExtract of: aMethodToRefactor! ! -!ExtractToTemporaryApplier methodsFor: 'initialization' stamp: 'RNG 5/24/2020 21:12:30'! - initializeOn: aCodeProvider for: anIntervalToExtract of: aMethodToExtractCodeFrom - - codeProvider := aCodeProvider. - intervalToExtract := anIntervalToExtract. - methodToExtractCodeFrom := aMethodToExtractCodeFrom.! ! -!ExtractToTemporaryApplier class methodsFor: 'instance creation' stamp: 'RNG 5/24/2020 21:10:47'! - on: aCodeProvider for: anIntervalToExtract of: aMethodToExtractCodeFrom - - self assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: anIntervalToExtract. - - ^ self new initializeOn: aCodeProvider for: anIntervalToExtract of: aMethodToExtractCodeFrom! ! -!ExtractMethodNewSelectorPrecondition methodsFor: 'evaluating - private' stamp: 'RNG 5/24/2020 20:25:43'! - assertNewSelectorIsNotAlreadyDefinedWithinTheClassHierarchy - - (classToDefineSelector whichClassIncludesSelector: selectorToValidate) - ifNotNil: [ :classDefiningSelector | self warn: selectorToValidate isAlreadyDefinedIn: classDefiningSelector ]! ! -!ExtractMethodNewSelectorPrecondition methodsFor: 'warnings' stamp: 'RNG 5/24/2020 20:37:46'! - warn: aSelector isAlreadyDefinedIn: aClassDefiningSelector - - self refactoringWarning: (self class warningMessageFor: aSelector isAlreadyDefinedIn: aClassDefiningSelector)! ! -!ExtractMethodNewSelectorPrecondition class methodsFor: 'warning messages' stamp: 'RNG 5/24/2020 20:41:41'! - warningMessageFor: existingSelector isAlreadyDefinedIn: classDefiningSelector - - ^ existingSelector , ' is already defined in ' , classDefiningSelector name! ! -!NewTemporaryPrecondition class methodsFor: 'error messages' stamp: 'RNG 5/24/2020 20:01:16'! - errorMessageFor: aNewVariable canNotBeNamedDueToInstanceVariableDefinedIn: aClass - - ^ aNewVariable, ' cannot be used as temporary variable name because it is an instance variable defined in ', aClass name! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'evaluating' stamp: 'RNG 5/25/2020 00:51:57' overrides: 50497302! - value - - self - initializeParseNodesMatchingSelectionInterval; - assertSourceCodeDoesNotIncludeReturnExpressions; - assertSourceCodeIsNotLeftSideOfAssignment; - assertSourceCodeIsNotPartOfTemporariesDeclaration; - assertSourceCodeDoesNotIncludeTemporaryAssignmentsWithoutDeclaration; - assertSourceCodeDoesNotHaveTemporaryVariablesUsedOutsideOfSelectionInterval; - assertSourceCodeContainsAValidExpression! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'exceptions' stamp: 'RNG 5/24/2020 22:08:41'! - signalExtractingLeftSideOfAssignmentError - - self refactoringError: self class errorMessageForExtractingLeftSideOfAssignment! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'exceptions' stamp: 'RNG 5/25/2020 00:13:13'! - signalExtractingTemporaryVariableDefinitionError - - self refactoringError: self class errorMessageForExtractingTemporaryVariablesDefinition! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'exceptions' stamp: 'RNG 5/25/2020 00:48:13'! - signalSourceCodeContainsAnInvalidExpressionError - - self refactoringError: self class errorMessageForSourceCodeContainingInvalidExpression! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'exceptions' stamp: 'RNG 5/24/2020 21:57:41'! - signalSourceCodeIncludesAReturnStatementError - - self refactoringError: self class errorMessageForSourceCodeIncludingAReturnStatement! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'exceptions' stamp: 'RNG 5/25/2020 00:54:43'! - signalTemporaryAssignmentUsedOutsideOfSelectionIntervalError - - self refactoringError: self class errorMessageForTemporaryAssignmentWithUsagesOutsideOfSelectionInterval! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'exceptions' stamp: 'RNG 5/25/2020 00:30:02'! - signalTemporaryAssignmentWithoutDeclarationError - - self refactoringError: self class errorMessageForExtractedTemporaryAssignmentWithoutItsDeclaration! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 5/25/2020 00:52:33'! - assertSourceCodeContainsAValidExpression - - (self intervalCoversCompleteAstNodes and: [ self startAndEndNodesShareAParentNode - or: [ self intervalMatchesBeginningOfStatement and: [ self intervalMatchesEndOfStatement ] ] ]) - - ifFalse: [ self signalSourceCodeContainsAnInvalidExpressionError ]! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 5/25/2020 00:39:55'! - assertSourceCodeDoesNotHaveTemporaryVariablesUsedOutsideOfSelectionInterval - - self isNotATempDeclarationWithUsagesOutOfIntervalToExtract - ifFalse: [ self signalTemporaryAssignmentUsedOutsideOfSelectionIntervalError ]! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 5/24/2020 22:03:51'! - assertSourceCodeDoesNotIncludeReturnExpressions - - self thereAreReturnExpressions - ifTrue: [ self signalSourceCodeIncludesAReturnStatementError ]! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 5/25/2020 00:28:44'! -assertSourceCodeDoesNotIncludeTemporaryAssignmentsWithoutDeclaration - - self thereAreNoLocalVariableAssignmentsWithoutDeclaration - ifFalse: [ self signalTemporaryAssignmentWithoutDeclarationError ]! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 5/25/2020 00:07:42'! - assertSourceCodeIsNotLeftSideOfAssignment - - self isLeftSideOfAssignment - ifTrue: [ self signalExtractingLeftSideOfAssignmentError ]! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 5/25/2020 00:12:37'! - assertSourceCodeIsNotPartOfTemporariesDeclaration - - self isNotInsideATempDeclaration - ifFalse: [ self signalExtractingTemporaryVariableDefinitionError ]! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'private' stamp: 'RNG 5/25/2020 00:47:29'! - initializeParseNodesMatchingSelectionInterval - - initialNodeAncestors := methodNode parseNodesPathAt: intervalToExtract first ifAbsent: [ self signalSourceCodeContainsAnInvalidExpressionError ]. - finalNodeAncestors := methodNode parseNodesPathAt: intervalToExtract last ifAbsent: [ self signalSourceCodeContainsAnInvalidExpressionError ]. - initialNode := initialNodeAncestors first. - finalNode := finalNodeAncestors first! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'private' stamp: 'RNG 5/25/2020 00:22:31'! - intervalToExtractIsIncludedInAnyOf: sourceRanges - - ^ sourceRanges anySatisfy: [ :sourceRange | - sourceRange first <= intervalToExtract first and: [ sourceRange last >= intervalToExtract last ] ]! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'private' stamp: 'RNG 5/25/2020 00:44:55' prior: 50489462! - startAndEndParseNodesAreTheSame - - ^ initialNode key = finalNode key! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'private' stamp: 'RNG 5/24/2020 22:03:51'! - thereAreReturnExpressions - - ^ (methodNode - allParseNodesWithin: intervalToExtract - satisfy: [ :parseNode | parseNode isReturn ]) not! ! -!SourceCodeOfMethodToBeExtractedPrecondition class methodsFor: 'error messages' stamp: 'RNG 5/25/2020 00:26:39'! - errorMessageForExtractedTemporaryAssignmentWithoutItsDeclaration - - ^ self extractMethodErrorMessagePrefix , 'an assignment is being extracted without its declaration'! ! -!SourceCodeOfMethodToBeExtractedPrecondition class methodsFor: 'error messages' stamp: 'RNG 5/24/2020 22:14:48'! - errorMessageForExtractingLeftSideOfAssignment - - ^ self extractMethodErrorMessagePrefix , 'it is not possible to extract the left side of an assignment'! ! -!SourceCodeOfMethodToBeExtractedPrecondition class methodsFor: 'error messages' stamp: 'RNG 5/24/2020 22:57:11'! - errorMessageForExtractingTemporaryVariablesDefinition - - ^ self extractMethodErrorMessagePrefix , 'it is not possible to extract temporary variable definitions'! ! -!SourceCodeOfMethodToBeExtractedPrecondition class methodsFor: 'error messages' stamp: 'RNG 5/25/2020 00:48:55'! - errorMessageForSourceCodeContainingInvalidExpression - - ^ self extractMethodErrorMessagePrefix , 'the selected code contains an invalid expression'! ! -!SourceCodeOfMethodToBeExtractedPrecondition class methodsFor: 'error messages' stamp: 'RNG 5/24/2020 22:15:04'! - errorMessageForSourceCodeIncludingAReturnStatement - - ^ self extractMethodErrorMessagePrefix , 'the selected code includes a return statement'! ! -!SourceCodeOfMethodToBeExtractedPrecondition class methodsFor: 'error messages' stamp: 'RNG 5/25/2020 00:38:28'! - errorMessageForTemporaryAssignmentWithUsagesOutsideOfSelectionInterval - - ^ self extractMethodErrorMessagePrefix , 'there are temporary variables used outside of the code selection'! ! -!SourceCodeOfMethodToBeExtractedPrecondition class methodsFor: 'evaluating' stamp: 'RNG 5/24/2020 22:19:38'! - valueFor: anIntervalToExtract of: aMethod - - ^ (self for: anIntervalToExtract of: aMethod) value! ! -!SourceCodeOfMethodToBeExtractedPrecondition class methodsFor: 'private - error messages' stamp: 'RNG 5/24/2020 22:14:33'! - extractMethodErrorMessagePrefix - - ^ 'Cannot extract method: '! ! -!MethodNode methodsFor: 'testing' stamp: 'RNG 5/24/2020 21:54:35' prior: 50489631! - allParseNodesWithin: aSourceCodeInterval satisfy: aCondition - - self completeSourceRangesDo: [ :parseNode :sourceRanges | - (aCondition value: parseNode) ifTrue: [ - (sourceRanges anySatisfy: [ :sourceRange | aSourceCodeInterval rangeIncludes: sourceRange first ]) - ifTrue: [ ^ false ] ] ]. - ^ true! ! -!SmalltalkEditor methodsFor: 'extract to temporary' stamp: 'RNG 5/24/2020 21:35:15' prior: 50512532! - extractToTemporary - - self performCodeExtractionRefactoringWith: ExtractToTemporaryApplier! ! -!SmalltalkEditor methodsFor: 'extract method' stamp: 'RNG 5/24/2020 21:34:55' prior: 50512549! - extractMethod - - self performCodeExtractionRefactoringWith: ExtractMethodApplier! ! -!ExtractMethod class methodsFor: 'error messages' stamp: 'RNG 5/24/2020 21:38:48' prior: 50488905! - outOfBoundsSelectionErrorMessage - - ^ 'The requested source code selection interval is out of bounds'! ! -!ExtractMethod class methodsFor: 'exceptions' stamp: 'RNG 5/24/2020 19:50:32' prior: 50505470! - signalExtractMethodWithWrongNumberOfArgumentsError - - self refactoringError: self wrongNumberOfArgumentsGivenErrorMessage! ! -!ExtractMethod class methodsFor: 'instance creation' stamp: 'RNG 5/24/2020 22:37:50' prior: 50512582! - fromInterval: anIntervalToExtract of: aMethodToExtractCodeFrom to: newMessage categorizedAs: aCategory - - | trimmedIntervalToExtract | - trimmedIntervalToExtract := anIntervalToExtract trimToMatchExpressionOn: aMethodToExtractCodeFrom sourceCode. - self - assert: newMessage selector canBeDefinedIn: aMethodToExtractCodeFrom methodClass; - assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: trimmedIntervalToExtract; - assert: newMessage hasValidParametersForExtracting: anIntervalToExtract from: aMethodToExtractCodeFrom methodNode. - - ^ self new - initializeFrom: trimmedIntervalToExtract - of: aMethodToExtractCodeFrom - to: newMessage - in: aCategory! ! -!ExtractMethodApplier methodsFor: 'refactoring - changes' stamp: 'RNG 5/24/2020 21:27:20' prior: 50489167 overrides: 50441450! - showChanges - - codeProvider currentMethodRefactored! ! -!ExtractMethodApplier class methodsFor: 'pre-conditions' stamp: 'RNG 5/24/2020 22:32:28' prior: 50492181! -assertCanApplyRefactoringOn: aMethodToRefactor at: anIntervalToExtract - - ExtractMethod - assertCanApplyRefactoringOn: aMethodToRefactor - at: anIntervalToExtract! ! -!ExtractToTemporaryApplier methodsFor: 'refactoring - changes' stamp: 'RNG 5/24/2020 21:27:20' prior: 50507140 overrides: 50441450! - showChanges - - codeProvider currentMethodRefactored! ! -!RenameInstanceVariableApplier methodsFor: 'refactoring - changes' stamp: 'RNG 5/24/2020 21:27:51' prior: 50476629! - informChangesToBrowser - - browser currentMethodRefactored! ! -!ExtractMethodNewSelectorPrecondition methodsFor: 'evaluating' stamp: 'RNG 5/24/2020 20:14:39' prior: 50489280 overrides: 50497302! - value - - self - assertNewSelectorIsNotEmpty; - assertNewSelectorDoesNotContainSeparators; - assertNewSelectorBeginsWithAValidCharacter; - assertNewSelectorContainsOnlyValidCharacters; - assertNewSelectorIsNotAlreadyDefinedWithinTheClassHierarchy! ! -!NewTemporaryPrecondition methodsFor: 'exceptions' stamp: 'RNG 5/24/2020 20:01:16' prior: 50497413! - signalNewVariableCanNotHideInstanceVariableDefinedIn: aClass - - self refactoringError: ( - self class - errorMessageFor: newTemporaryVariableName - canNotBeNamedDueToInstanceVariableDefinedIn: aClass)! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'initialization' stamp: 'RNG 5/24/2020 22:50:39' prior: 50489516! - initializeFor: anIntervalToExtract of: aMethodUnderValidation - - intervalToExtract := anIntervalToExtract. - method := aMethodUnderValidation. - methodNode := method methodNode. - sourceCode := method sourceCode.! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'private' stamp: 'RNG 5/25/2020 00:45:10' prior: 50492042! - isLeftSideOfAssignment - - ^ initialNodeAncestors size > 1 - and: [ self startAndEndParseNodesAreTheSame ] - and: [ initialNodeAncestors second key isAssignmentNode ] - and: [ initialNodeAncestors second key variable = initialNode key ]! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'private' stamp: 'RNG 5/25/2020 00:22:21' prior: 50505332! - isNotInsideATempDeclaration - - methodNode completeSourceRangesDo: [ :parseNode :sourceRanges | - (parseNode isTemporariesDeclaration - and: [ self intervalToExtractIsIncludedInAnyOf: sourceRanges ]) - ifTrue: [ ^ false ] ]. - ^ true! ! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #thereAreNoReturnExpressions! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition #thereAreNoReturnExpressions stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:08:35'! -thereAreNoReturnExpressions - - ^ methodNode - allParseNodesWithin: intervalToExtract - satisfy: [ :parseNode | parseNode isReturn ]! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #isNotLeftSideOfAssignment! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition #isNotLeftSideOfAssignment stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:08:35'! -isNotLeftSideOfAssignment - - ^ (self startAndEndParseNodesAreTheSame and: [ self isLeftSideOfAssignment ]) not! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #passed! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition #passed stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:08:35'! -passed - - methodNode _ method methodNode. - sourceCode _ method sourceCode. - initialNodeAncestors _ methodNode parseNodesPathAt: intervalToExtract first ifAbsent: [ ^ false]. - finalNodeAncestors _ methodNode parseNodesPathAt: intervalToExtract last ifAbsent: [ ^ false ]. - initialNode _ initialNodeAncestors first. - finalNode _ finalNodeAncestors first. - - ^ self intervalCoversCompleteAstNodes - and: [ self containsValidNodes ] - and: [ self startAndEndParseNodesAreTheSame - or: [ self startAndEndNodesShareAParentNode ] - or: [ self intervalMatchesBeginningOfStatement and: [ self intervalMatchesEndOfStatement ] ] ]! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #containsValidNodes! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition #containsValidNodes stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:08:35'! -containsValidNodes - - ^ self isNotLeftSideOfAssignment - and: [ self thereAreNoLocalVariableAssignmentsWithoutDeclaration ] - and: [ self thereAreNoReturnExpressions ] - and: [ self isNotATempDeclarationWithUsagesOutOfIntervalToExtract ] - and: [ self isNotInsideATempDeclaration ]! - -NewTemporaryPrecondition class removeSelector: #errorMessageFor:canNotBeNamedAsInstanceVariableDefinedIn:! - -!methodRemoval: NewTemporaryPrecondition class #errorMessageFor:canNotBeNamedAsInstanceVariableDefinedIn: stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:08:35'! -errorMessageFor: aNewVariable canNotBeNamedAsInstanceVariableDefinedIn: aClass - - ^ aNewVariable, ' can not be named as instance variable defined in ', aClass name! - -ExtractMethodNewSelectorPrecondition class removeSelector: #newSelectorAlreadyDefinedOnTheClassErrorMessage! - -!methodRemoval: ExtractMethodNewSelectorPrecondition class #newSelectorAlreadyDefinedOnTheClassErrorMessage stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:08:35'! -newSelectorAlreadyDefinedOnTheClassErrorMessage - - ^ 'New selector is already defined on this class'! - -ExtractMethodNewSelectorPrecondition removeSelector: #assertNewSelectorIsNotAlreadyDefinedInTheClass! - -!methodRemoval: ExtractMethodNewSelectorPrecondition #assertNewSelectorIsNotAlreadyDefinedInTheClass stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:08:35'! -assertNewSelectorIsNotAlreadyDefinedInTheClass - - (classToDefineSelector includesSelector: selectorToValidate) - ifTrue: [ self signalNewSelectorIsAlreadyDefinedInTheClassError ]! - -ExtractMethodNewSelectorPrecondition removeSelector: #signalNewSelectorIsAlreadyDefinedInTheClassError! - -!methodRemoval: ExtractMethodNewSelectorPrecondition #signalNewSelectorIsAlreadyDefinedInTheClassError stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:08:35'! -signalNewSelectorIsAlreadyDefinedInTheClassError - - self refactoringError: self class newSelectorAlreadyDefinedOnTheClassErrorMessage! - -ExtractToTemporaryApplier class removeSelector: #for:of:! - -!methodRemoval: ExtractToTemporaryApplier class #for:of: stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:08:35'! -for: anIntervalToExtract of: aMethodToExtractCodeFrom - - self assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: anIntervalToExtract. - - ^ self new initializeFor: anIntervalToExtract of: aMethodToExtractCodeFrom! - -ExtractToTemporaryApplier removeSelector: #initializeFor:of:! - -!methodRemoval: ExtractToTemporaryApplier #initializeFor:of: stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:08:35'! -initializeFor: anIntervalToExtract of: aMethodToExtractCodeFrom - - intervalToExtract _ anIntervalToExtract. - methodToExtractCodeFrom _ aMethodToExtractCodeFrom.! - -ExtractMethodApplier class removeSelector: #for:of:! - -!methodRemoval: ExtractMethodApplier class #for:of: stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:08:35'! -for: anIntervalToExtract of: aMethodToExtractCodeFrom - - | trimmedIntervalToExtract sourceCode | - sourceCode := aMethodToExtractCodeFrom sourceCode. - trimmedIntervalToExtract := anIntervalToExtract trimToMatchExpressionOn: sourceCode.. - - self assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: trimmedIntervalToExtract. - - ^ self new initializeFor: trimmedIntervalToExtract of: aMethodToExtractCodeFrom! - -ExtractMethodApplier removeSelector: #initializeFor:of:! - -!methodRemoval: ExtractMethodApplier #initializeFor:of: stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:08:35'! -initializeFor: anIntervalToExtract of: aMethodToExtractCodeFrom - - intervalToExtract _ anIntervalToExtract. - methodToExtractCodeFrom _ aMethodToExtractCodeFrom. - newMessageArguments _ Dictionary new! - -ExtractMethod class removeSelector: #assert:isValidIntervalOn:! - -!methodRemoval: ExtractMethod class #assert:isValidIntervalOn: stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:08:35'! -assert: anIntervalToExtract isValidIntervalOn: aMethodToExtractCodeFrom - - (self isNotEmpty: anIntervalToExtract) - ifFalse: [ self signalNoSelectedCodeError ]. - (self is: anIntervalToExtract withinBoundsOf: aMethodToExtractCodeFrom sourceCode) - ifFalse: [ self signalOutOfBoundsIntervalError ]. - (self method: aMethodToExtractCodeFrom containsAValidExpressionOn: anIntervalToExtract) - ifFalse: [ self signalSelectedCodeIsInvalidForExtractError ].! - -ExtractMethod class removeSelector: #signalSelectedCodeIsInvalidForExtractError! - -!methodRemoval: ExtractMethod class #signalSelectedCodeIsInvalidForExtractError stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:08:35'! -signalSelectedCodeIsInvalidForExtractError - - self refactoringError: self selectedCodeInvalidForExtractErrorMessage! - -ExtractMethod class removeSelector: #wrongNumberOrArgumentsGivenErrorMessage! - -!methodRemoval: ExtractMethod class #wrongNumberOrArgumentsGivenErrorMessage stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:08:35'! -wrongNumberOrArgumentsGivenErrorMessage - - ^ 'The number of arguments in the given selector is not correct'! - -ExtractMethod class removeSelector: #selectedCodeInvalidForExtractErrorMessage! - -!methodRemoval: ExtractMethod class #selectedCodeInvalidForExtractErrorMessage stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:08:35'! -selectedCodeInvalidForExtractErrorMessage - - ^ 'The selected code can not be extracted to a method'! - -ExtractMethod class removeSelector: #method:containsAValidExpressionOn:! - -!methodRemoval: ExtractMethod class #method:containsAValidExpressionOn: stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:08:35'! -method: aMethod containsAValidExpressionOn: anIntervalToExtract - - ^ (ExtractMethodExpressionValidation for: anIntervalToExtract of: aMethod) passed! - -Debugger removeSelector: #instanceVariableRenamed! - -!methodRemoval: Debugger #instanceVariableRenamed stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:08:35'! -instanceVariableRenamed - - | newMethod | - - newMethod := self selectedClass compiledMethodAt: self selectedContext selector. - self resetToSelectedContextWith: newMethod ! - -CodeProvider removeSelector: #instanceVariablePushedUp! - -!methodRemoval: CodeProvider #instanceVariablePushedUp stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:08:35'! -instanceVariablePushedUp - - self acceptedContentsChanged -! - -CodeProvider removeSelector: #instanceVariableRenamed! - -!methodRemoval: CodeProvider #instanceVariableRenamed stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:08:35'! -instanceVariableRenamed - - self acceptedContentsChanged -! - -RefactoringApplier subclass: #ExtractMethodApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newSelector newMessageArguments codeProvider' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractMethodApplier category: #'Tools-Refactoring' stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:08:35'! -RefactoringApplier subclass: #ExtractMethodApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newSelector newMessageArguments codeProvider' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #ExtractToTemporaryApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newVariable codeProvider' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractToTemporaryApplier category: #'Tools-Refactoring' stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:08:35'! -RefactoringApplier subclass: #ExtractToTemporaryApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newVariable codeProvider' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringPrecondition subclass: #SourceCodeOfMethodToBeExtractedPrecondition - instanceVariableNames: 'method intervalToExtract methodNode sourceCode initialNode finalNode initialNodeAncestors finalNodeAncestors' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #SourceCodeOfMethodToBeExtractedPrecondition category: #'Tools-Refactoring' stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:08:35'! -RefactoringPrecondition subclass: #SourceCodeOfMethodToBeExtractedPrecondition - instanceVariableNames: 'method intervalToExtract methodNode sourceCode initialNode finalNode initialNodeAncestors finalNodeAncestors' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4187] on 25 May 2020 at 10:51:22 pm'! -!Morph methodsFor: 'previewing' stamp: 'jmv 5/25/2020 22:49:11' prior: 50431849! - endPreview - - self previewing ifTrue: [ - self visible: self visibleBeforePreview. - owner notNil ifTrue: [ owner addMorph: self inFrontOf: self morphBehindBeforePreview ]. - self previewing: false. ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4188-FixTaskbarEndDuringPreview-JuanVuletich-2020May25-22h50m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4188] on 26 May 2020 at 11:42:00 am'! -!StringRequestMorph class methodsFor: 'private' stamp: 'KenD 5/25/2020 12:37:58' prior: 50513914! - deltaToTextPane - "Answer a distance to translate an instance of the receiver by when it is opened in the world in order to have the hand be over the text pane (so the text pane has focus). - Distance is relative to font size" - | e | - e _ Preferences windowTitleFont lineSpacing. - ^ (2 * e)@(1.5 * e)! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4189-StringRequestMorph-deltaToTextPane-KenDickey-2020May26-11h41m-KenD.001.cs.st----! - -'From Cuis 5.0 [latest update: #4189] on 26 May 2020 at 2:56:59 pm'! -!Workspace methodsFor: 'user interface support' stamp: 'jmv 5/26/2020 14:55:37' overrides: 50368786! - formatAndStyleIfNeededWith: anSHTextStyler - | separator fragmentStart fragmentEnd done| - (anSHTextStyler notNil and: [self shouldStyle: self actualContents with: anSHTextStyler]) - ifFalse: [^ self]. - - actualContents _ actualContents optimizedForMutationSpeed. - anSHTextStyler formatWorkspace: actualContents. - separator _ String newLineString, String newLineString. - fragmentStart _ 1. - done _ false. - [done] whileFalse: [ - fragmentEnd _ actualContents - indexOfSubCollection: separator - startingAt: fragmentStart - ifAbsent: [done _ true. actualContents size]. - anSHTextStyler styleWorkspaceFrom: fragmentStart to: fragmentEnd. - fragmentStart _ fragmentEnd+separator size ]. - self changed: #shoutStyled! ! -!SHTextStylerST80 methodsFor: 'styling' stamp: 'jmv 5/26/2020 14:15:23'! - formatWorkspace: text - "Do first stage of styling. - Afterweards, call #styleWorkspaceFrom:to: as needed. - Note: classOrMetaClass is assumed to be nil" - - self terminateBackgroundStylingProcess. - formattedText _ text. - self privateFormatAndConvert. - formattedText removeAttributesThat: [ :attribute | attribute isForShout ]. - - parser ifNil: [ parser := SHParserST80 new ]. - parser - workspace: workspace; - classOrMetaClass: nil! ! -!SHTextStylerST80 methodsFor: 'styling' stamp: 'jmv 5/26/2020 14:23:29'! - styleWorkspaceFrom: start to: end - "Style a copy of part of the model text. Then apply attributes to model text. Useful for Workspaces. - Call #formatWorkspace: becore calling us. - Note: classOrMetaClass is assumed to be nil. - Note: after last call, do `textModel changed: #shoutStyled`" - - parser - source: (formattedText asString copyFrom: start to: end). - parser parse. - parser ranges ifNotNil: [ :ranges | - ranges do: [ :range | - (self attributesFor: range rangeType) ifNotNil: [ :attributes | - attributes do: [ :each | - formattedText - addAttribute: each - from: range start +start-1 - to: range end +start-1 ]]]].! ! -!SHTextStyler methodsFor: 'styling' stamp: 'jmv 5/26/2020 14:22:37' prior: 50500411! - formatAndStyle: text allowBackgroundStyleProcess: aBoolean - "Do the styling on the model text. - After finishing, tell model, by triggering #shoutStyled." - self terminateBackgroundStylingProcess. - formattedText _ text. - self privateFormatAndConvert. - (aBoolean and: [formattedText size > 4096]) - ifTrue: [ - formattedText size < 65536 ifTrue: [ - self styleInBackgroundProcess ]] - ifFalse: [ - self privateStyle. - textModel changed: #shoutStyled ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4190-ShoutWorkspacesInParagraphs-JuanVuletich-2020May26-14h53m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4112] on 26 May 2020 at 5:03:49 pm'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 5/26/2020 16:58:40' prior: 50473070! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag - "WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " - | activeProc | - activeProc _ Processor activeProcess. - [ | isARealStartup guiRootObject guiRootObjectClass | - save not & quit - ifTrue: [ - (SourceFiles at: 2) ifNotNil: [ :changes | - ChangesInitialFileSize ifNotNil: [ changes truncate: ChangesInitialFileSize ]]] - ifFalse: [ - self - logSnapshot: save - andQuit: quit ]. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | - each isInWorld ifTrue: [ - each delete.]]. - UISupervisor ui tearDownDesktop. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - "Cosas que levanto explicitamente abajo" - guiRootObjectClass _ UISupervisor ui class. - guiRootObject _ UISupervisor ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "guiRootObject _ clearAllStateFlag ifFalse: [ UISupervisor ui ]." - UISupervisor stopUIProcess. - activeProc isTerminated ifFalse: [ activeProc terminate ]. - "Clean Globals" - Smalltalk - at: #Sensor - put: nil. - Smalltalk - at: #Display - put: nil. - Smalltalk closeSourceFiles. - Smalltalk - at: #SourceFiles - put: nil. - Smalltalk allClassesDo: [ :cls | - cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | - cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ - Smalltalk printStuffToCleanOnImageSave. - "Remove this call to actually see the image clean report." - Transcript clear. - ]. - "Do image save & quit as apropriate" - (Cursor cursorAt: #writeCursor) activateCursor. - save - ifTrue: [ - "The snapshot primitive answers false if it was just called to do the snapshot. - But image startup is resumed by returning (again) from the primitive, but this time answering true." - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk - at: #Sensor - put: nil. - Smalltalk - at: #Display - put: DisplayScreen new. - Smalltalk - at: #SourceFiles - put: (Array new: 2). - Smalltalk openSourceFiles. - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | - cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - UISupervisor spawnNewMorphicProcessFor: (guiRootObject ifNil: [ guiRootObject _ guiRootObjectClass newWorld ]). - Display triggerEvent: #screenSizeChanged. - self restoreLostChangesIfNecessary. - clearAllStateFlag ifTrue: [ - UISupervisor whenUIinSafeState: [ - guiRootObject recreateDefaultDesktop ]]. - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - UISupervisor whenUIinSafeState: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]] - forkAt: Processor timingPriority - 1 - named: 'Startup process'.! ! -!PasteUpMorph methodsFor: 'defaul desktop' stamp: 'jmv 5/26/2020 17:03:06' prior: 50515467! - recreateDefaultDesktop - | editor | - self whenUIinSafeState: [ - self hideTaskbar. - (submorphs - select: [ :ea | ea class == SystemWindow or: [ea class == TranscriptWindow]]) - do: [ :ea | ea delete ]. - TranscriptWindow openTranscript - morphPosition: 5 @ 283; - morphExtent: 990 @ 400. - editor _ TextEditor openTextEditor - morphPosition: 456 @ 3; - morphExtent: 900 @ 680. - editor setLabel: 'About Cuis'. - editor model actualContents: Utilities defaultTextEditorContents. - Theme current useTaskbar ifTrue: [self showTaskbar]. - ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4191-ImageSaveTweaks-JuanVuletich-2020May26-17h00m-jmv.001.cs.st----! - -----SNAPSHOT----(26 May 2020 17:08:40) Cuis5.0-4191-32.image priorSource: 5583741! - -----STARTUP---- (25 June 2020 16:06:46) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4191-32.image! - - -'From Cuis 5.0 [latest update: #4191] on 27 May 2020 at 12:05:23 am'! -!Morph methodsFor: 'previewing' stamp: 'jmv 5/27/2020 00:04:36' prior: 50518072! - endPreview - - self previewing ifTrue: [ - owner notNil ifTrue: [ - self visible: self visibleBeforePreview. - owner addMorph: self inFrontOf: self morphBehindBeforePreview ]. - self previewing: false. ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4192-FixTaskbarEndDuringPreview-again-JuanVuletich-2020May27-00h04m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4192] on 27 May 2020 at 10:45:48 am'! -!Preferences class methodsFor: 'standard queries'! - showAnnotations - ^ self - valueOfFlag: #showAnnotations - ifAbsent: [ true ]! ! -!CodeProvider methodsFor: 'annotation' stamp: 'len 5/27/2020 06:05:39' prior: 16811688! - addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream - "add an annotation detailing the prior versions count" - | versionsCount | - - versionsCount _ VersionsBrowser versionCountForSelector: aSelector class: aClass. - aStream nextPutAll: - ((versionsCount > 1 - ifTrue: - [versionsCount = 2 ifTrue: - ['1 prior version'] - ifFalse: - [versionsCount printString, ' prior versions']] - ifFalse: - ['no prior versions']))! ! -!CodeProvider methodsFor: 'annotation' stamp: 'len 5/27/2020 05:54:38' prior: 16811738! - annotationForClassDefinitionFor: aClass - "Provide a line of content for an annotation pane, given that the receiver is pointing at the class definition of the given class." - - | separator | - separator _ self annotationSeparator. - ^ String streamContents: [ :strm | - strm - nextPutAll: 'class definition for '; - nextPutAll: aClass name; - nextPutAll: separator; - print: aClass theNonMetaClass selectors size; - nextPutAll: ' instance methods'; - nextPutAll: separator; - print: aClass theMetaClass selectors size; - nextPutAll: ' class methods'; - nextPutAll: separator; - print: aClass theNonMetaClass linesOfCode; - nextPutAll: ' total lines of code' ]! ! -!CodeProvider methodsFor: 'annotation' stamp: 'len 5/27/2020 06:41:23' prior: 50419091! - annotationForSelector: aSelector ofClass: aClass - "Provide a line of content for an annotation pane, representing - information about the given selector and class" - | stamp sendersCount implementorsCount aCategory separator aString aList aComment stream requestList | - aSelector == #Comment - ifTrue: [^ self annotationForClassCommentFor: aClass]. - aSelector == #Definition - ifTrue: [^ self annotationForClassDefinitionFor: aClass]. - aSelector == #Hierarchy - ifTrue: [^ self annotationForHierarchyFor: aClass]. - stream _ WriteStream on: String new. - requestList _ self annotationRequests. - separator _ self annotationSeparator. - requestList - do: [:aRequest | - aRequest == #firstComment - ifTrue: [ - aComment _ aClass firstCommentAt: aSelector. - aComment isEmptyOrNil - ifFalse: [stream position = 0 ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: aComment]]. - aRequest == #masterComment - ifTrue: [ - aComment _ aClass supermostPrecodeCommentFor: aSelector. - aComment isEmptyOrNil - ifFalse: [stream position = 0 ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: aComment]]. - aRequest == #documentation - ifTrue: [ - aComment _ aClass precodeCommentOrInheritedCommentFor: aSelector. - aComment isEmptyOrNil - ifFalse: [stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: aComment]]. - aRequest == #timeStamp - ifTrue: [ - stamp _ self timeStamp. - stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: (stamp size > 0 ifTrue: [stamp] ifFalse: ['no timestamp'])]. - aRequest == #messageCategory - ifTrue: [ - aCategory _ aClass organization categoryOfElement: aSelector. - aCategory - ifNotNil: ["woud be nil for a method no longer present, - e.g. in a recent-submissions browser" - stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: aCategory]]. - aRequest == #sendersCount - ifTrue: [ - sendersCount _ Smalltalk numberOfSendersOf: aSelector. - sendersCount _ sendersCount = 1 - ifTrue: ['1 sender'] - ifFalse: [sendersCount printString , ' senders']. - stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: sendersCount]. - aRequest == #implementorsCount - ifTrue: [ - implementorsCount _ Smalltalk numberOfImplementorsOf: aSelector. - implementorsCount _ implementorsCount = 1 - ifTrue: ['1 implementor'] - ifFalse: [implementorsCount printString , ' implementors']. - stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: implementorsCount]. - aRequest == #priorVersionsCount - ifTrue: [ - stream isEmpty ifFalse: [stream nextPutAll: separator]. - self - addPriorVersionsCountForSelector: aSelector - ofClass: aClass - to: stream]. - aRequest == #priorTimeStamp - ifTrue: [ - stamp _ VersionsBrowser - timeStampFor: aSelector - class: aClass - reverseOrdinal: 2. - stamp - ifNotNil: [stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: 'prior timestamp: ' , stamp]]. - aRequest == #packages - ifTrue: [ - (aClass compiledMethodAt: aSelector ifAbsent: nil) ifNotNil: [ :cm | - stream isEmpty ifFalse: [stream nextPutAll: separator]. - (CodePackage packageOfMethod: cm methodReference ifNone: nil) - ifNil: [ stream nextPutAll: 'in no package' ] - ifNotNil: [ :codePackage | - stream nextPutAll: 'in package '; nextPutAll: codePackage packageName ]]]. - aRequest == #changeSets - ifTrue: [ - stream isEmpty ifFalse: [stream nextPutAll: separator]. - aList _ ChangeSet allChangeSetsWithClass: aClass selector: aSelector. - aList size > 0 - ifTrue: [aList size = 1 - ifTrue: [stream nextPutAll: 'only in change set'] - ifFalse: [stream nextPutAll: 'in change sets:']. - aList - do: [:aChangeSet | stream nextPut: Character space; nextPutAll: aChangeSet name ] - separatedBy: [ stream nextPut: $, ]] - ifFalse: [stream nextPutAll: 'in no change set']]. - aRequest == #allChangeSets - ifTrue: [ - stream isEmpty ifFalse: [stream nextPutAll: separator]. - aList _ ChangeSet allChangeSetsWithClass: aClass selector: aSelector. - aList size > 0 - ifTrue: [aList size = 1 - ifTrue: [stream nextPutAll: 'only in change set'] - ifFalse: [stream nextPutAll: 'in change sets:']. - aList - do: [:aChangeSet | stream nextPut: Character space; nextPutAll: aChangeSet name ] - separatedBy: [ stream nextPut: $, ]] - ifFalse: [stream nextPutAll: 'in no change set']]. - aRequest == #allBaseSystemChangeSets - ifTrue: [ - stream isEmpty ifFalse: [stream nextPutAll: separator]. - aList _ (ChangeSet allChangeSetsWithClass: aClass selector: aSelector) select: [ :it | it isForBaseSystem ]. - aList size > 0 - ifTrue: [ - aList size = 1 - ifTrue: [stream nextPutAll: 'only in base system change set'] - ifFalse: [stream nextPutAll: 'in base system change sets:']. - aList - do: [:aChangeSet | stream nextPut: Character space; nextPutAll: aChangeSet name ] - separatedBy: [ stream nextPut: $, ]] - ifFalse: [stream nextPutAll: 'in no base system change set']]. - aRequest == #closuresInfo - ifTrue: [ - aString _ aClass closuresInfoAt: aSelector. - aString size > 0 - ifTrue: [stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: aString]]. - ]. - ^ stream contents! ! -!VersionsBrowser methodsFor: 'misc' stamp: 'len 5/27/2020 06:16:00' prior: 16942576 overrides: 50518388! - addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream - "Add an annotation detailing the prior versions count. Specially handled here for the case of a selector no longer in the system, whose prior versions are seen in a versions browser -- in this case, the inherited version of this method will not work." - - (aClass includesSelector: aSelector) ifTrue: - [^ super addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream]. - - aStream nextPutAll: - ((changeList size > 0 - ifTrue: - [changeList size = 1 - ifTrue: - ['deleted - one prior version'] - ifFalse: - ['deleted - ', changeList size printString, ' prior versions']] - ifFalse: - ['surprisingly, no prior versions']))! ! -!ChangeSorter methodsFor: 'annotation' stamp: 'len 5/27/2020 06:05:47' prior: 16799915 overrides: 50518388! - addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream - "Add an annotation detailing the prior versions count. Specially handled here for the case of a selector no longer in the system, whose prior version is pointed to by the lost-method pointer in the change held on to by the changeset" - - (aClass includesSelector: aSelector) ifTrue: - [^ super addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream]. - aStream nextPutAll: - ((myChangeSet methodInfoFromRemoval: {aClass name. aSelector}) - ifNil: - ['no prior versions'] - ifNotNil: - ['version(s) retrievable here'])! ! -!CodeWindow methodsFor: 'GUI building' stamp: 'len 5/27/2020 05:41:56' prior: 16812956! - buildLowerPanes - | codeAndButtons codeButtonsAndAnnotations | - codeAndButtons _ LayoutMorph newColumn. - Preferences optionalButtons ifTrue: [ - codeAndButtons - addMorph: self optionalButtonRow fixedHeight: self defaultButtonPaneHeight; - addAdjusterMorph ]. - codeAndButtons - addMorph: self buildMorphicCodePane proportionalHeight: 1.0. - Preferences showAnnotations ifFalse: [ - ^codeAndButtons ]. - codeButtonsAndAnnotations _ LayoutMorph newColumn. - codeButtonsAndAnnotations - addMorph: self buildMorphicAnnotationsPane fixedHeight: self defaultAnnotationPaneHeight; - addAdjusterMorph; - addMorph: codeAndButtons proportionalHeight: 1.0. - ^codeButtonsAndAnnotations! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'len 5/27/2020 05:42:09' prior: 16793009 overrides: 50518657! - buildLowerPanes - | codeAndButtons codeButtonsAndAnnotations comment separator | - comment _ self buildMorphicCommentPane. - separator _ LayoutAdjustingMorph new. - comment separator: separator. - codeAndButtons _ LayoutMorph newColumn. - Preferences optionalButtons ifTrue: [ - codeAndButtons - addMorph: self optionalButtonRow fixedHeight: self defaultButtonPaneHeight; - addAdjusterMorph ]. - codeAndButtons - addMorph: self buildMorphicCodePane proportionalHeight: 2.0; - addMorph: separator fixedHeight: 4; - addMorph: comment proportionalHeight: 2.0. - Preferences showAnnotations ifFalse: [ - ^codeAndButtons ]. - codeButtonsAndAnnotations _ LayoutMorph newColumn. - codeButtonsAndAnnotations - addMorph: self buildMorphicAnnotationsPane fixedHeight: self defaultAnnotationPaneHeight; - addAdjusterMorph; - addMorph: codeAndButtons proportionalHeight: 1.0. - ^codeButtonsAndAnnotations! ! -!MessageSetWindow methodsFor: 'GUI building' stamp: 'len 5/27/2020 05:43:00' prior: 50452794 overrides: 50518682! - buildLowerPanes - | codeAndButtons codeButtonsAndAnnotations | - codeAndButtons _ LayoutMorph newColumn. - Preferences optionalButtons ifTrue: [ - codeAndButtons - addMorph: self optionalButtonRow fixedHeight: self defaultButtonPaneHeight; - addAdjusterMorph ]. - codeAndButtons - addMorph: self buildMorphicCodePane proportionalHeight: 1.0. - Preferences showAnnotations ifFalse: [ - ^codeAndButtons ]. - codeButtonsAndAnnotations _ LayoutMorph newColumn. - codeButtonsAndAnnotations - addMorph: self buildMorphicAnnotationsPane fixedHeight: self defaultAnnotationPaneHeight; - addAdjusterMorph; - addMorph: codeAndButtons proportionalHeight: 1.0. - ^codeButtonsAndAnnotations! ! -!MessageSetWindow methodsFor: 'GUI building' stamp: 'len 6/30/2016 07:20' prior: 16870437 overrides: 50514820! - buildMorphicWindow - "Answer a morphic window with the given label that can display the receiver" - - self layoutMorph - addMorph: self buildMorphicMessageList proportionalHeight: 0.4; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.6. - model changed: #editSelection! ! -!VersionsBrowserWindow methodsFor: 'menu building' stamp: 'len 5/27/2020 06:34:56' prior: 50396659! - methodVersionsMenu - "Fill aMenu with menu items appropriate to the receiver" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Versions'. - aMenu addStayUpIcons. - model listIndex > 0 ifTrue:[ - (model list size > 1 ) ifTrue: [ - aMenu addItemsFromDictionaries: `{ - { - #label -> 'compare to current'. - #object -> #model. - #selector -> #compareToCurrentVersion. - #balloonText -> 'compare selected version to the current version' - } asDictionary. - { - #label -> 'compare to version...'. - #object -> #model. - #selector -> #compareToOtherVersion. - #balloonText -> 'compare selected version to another selected version' - } asDictionary. - }` ]. - "Note: Revert to selected should be visible for lists of length one for having the ability to revert to an accidentally deleted method" - aMenu addItemsFromDictionaries: `{ - { - #label -> 'revert to selected version (z)'. - #object -> #model. - #selector -> #fileInSelections. - #balloonText -> 'resubmit the selected version, so that it becomes the current version' - } asDictionary. - }` ]. - - aMenu addItemsFromDictionaries: `{ - { - #label -> 'edit current method (O)'. - #selector -> #openSingleMessageBrowser. - #balloonText -> 'open a single-message browser on the current version of this method' - } asDictionary. - nil. - { - #label -> 'toggle diffing (D)'. - #object -> #model. - #selector -> #toggleDiffing. - #balloonText -> 'toggle whether or not diffs should be shown here' - } asDictionary. - { - #label -> 'update list'. - #object -> #model. - #selector -> #reformulateList. - #balloonText -> 'reformulate the list of versions, in case it somehow got out of synch with reality' - } asDictionary. - nil. - { - #label -> 'senders (n)'. - #selector -> #browseSenders. - #balloonText -> 'browse all senders of this selector' - } asDictionary. - { - #label -> 'implementors (m)'. - #selector -> #browseImplementors. - #balloonText -> 'browse all implementors of this selector' - } asDictionary. - nil. - { - #label -> 'help...'. - #object -> #model. - #selector -> #offerVersionsHelp. - #balloonText -> 'provide an explanation of the use of this tool' - } asDictionary. - }`. - ^aMenu! ! -!VersionsBrowserWindow methodsFor: 'keyboard shortcuts' stamp: 'len 5/27/2020 06:32:28' prior: 16942855 overrides: 16797291! - changeListKey: aChar from: view - "Respond to a Command key in the list pane. of the versions browser" - - aChar == $z ifTrue: [^ model fileInSelections]. - ^ self messageListKey: aChar from: view! ! -!DebuggerWindow methodsFor: 'GUI building' stamp: 'len 5/27/2020 05:42:49' prior: 16830991 overrides: 50518657! - buildLowerPanes - | codeAndButtons codeButtonsAndAnnotations twoRowsOfButtons h | - twoRowsOfButtons _ LayoutMorph newColumn. - h _ self defaultButtonPaneHeight. - Preferences optionalButtons ifTrue: [ - h _ self defaultButtonPaneHeight * 2. - twoRowsOfButtons - addMorph: self optionalButtonRow proportionalHeight: 1.0; - addAdjusterMorph ]. - twoRowsOfButtons - addMorph: self customButtonRow proportionalHeight: 1.0. - codeAndButtons _ LayoutMorph newColumn. - codeAndButtons - addMorph: twoRowsOfButtons fixedHeight: h; - addAdjusterMorph; - addMorph: self buildMorphicCodePane proportionalHeight: 1.0. - Preferences showAnnotations ifFalse: [ - ^codeAndButtons ]. - codeButtonsAndAnnotations _ LayoutMorph newColumn. - codeButtonsAndAnnotations - addMorph: self buildMorphicAnnotationsPane fixedHeight: self defaultAnnotationPaneHeight; - addAdjusterMorph; - addMorph: codeAndButtons proportionalHeight: 1.0. - ^codeButtonsAndAnnotations! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4193-AnnotationsTweaks-LucianoEstebanNotarfrancesco-2020May27-10h45m-len.001.cs.st----! - -'From Cuis 5.0 [latest update: #4193] on 28 May 2020 at 11:21:51 am'! -!CodeProvider methodsFor: 'categories' stamp: 'len 5/28/2020 11:20:47' prior: 50513924! - categoryFromUserWithPrompt: aPrompt for: aClass - "self new categoryFromUserWithPrompt: 'testing' for: SystemDictionary" - - | labels myCategories reject lines newName menuIndex | - labels _ OrderedCollection with: 'new...'. - labels addAll: (myCategories _ aClass organization categories asArray copy sort: - [ :a :b | a asLowercase < b asLowercase ]). - reject _ myCategories asSet. - reject - add: ClassOrganizer nullCategory; - add: ClassOrganizer default. - lines _ OrderedCollection with: 1 with: (myCategories size + 1). - - aClass allSuperclasses do: [ :cls | | cats | - cats _ cls organization categories reject: [ :cat | reject includes: cat]. - cats isEmpty ifFalse: [ - lines add: labels size. - labels addAll: (cats asArray sort: [ :a :b | a asLowercase < b asLowercase]). - reject addAll: cats]]. - - (labels size = 1 or: [ - menuIndex _ (PopUpMenu labelArray: labels lines: lines) - startUpWithCaption: aPrompt. - menuIndex = 0 ifTrue: [^ nil]. - menuIndex = 1]) - ifTrue:[ - newName _ self request: 'New category name?' initialAnswer: 'category-name'. - newName isEmpty ifTrue: [ ^nil ]] - ifFalse: [ newName _ labels at: menuIndex ]. - ^ newName ifNotNil: [ newName asSymbol ]! ! -!Browser methodsFor: 'message category functions' stamp: 'len 5/28/2020 11:19:42' prior: 50514003! - newMethodCategoryNameIfNone: aNoneBlock - - | labels lines menuIndex newName reject | - - labels _ OrderedCollection with: 'new...'. - reject _ Set new. - reject - addAll: self selectedClassOrMetaClass organization categories; - add: ClassOrganizer nullCategory; - add: ClassOrganizer default. - lines _ OrderedCollection new. - self selectedClassOrMetaClass allSuperclasses do: [:cls | | cats | - cls = Object ifFalse: [ - cats _ cls organization categories reject: - [:cat | reject includes: cat]. - cats isEmpty ifFalse: [ - lines add: labels size. - labels addAll: cats asArray sort. - reject addAll: cats]]]. - newName _ (labels size = 1 or: [ - menuIndex _ (PopUpMenu labelArray: labels lines: lines) - startUpWithCaption: 'Add Category'. - menuIndex = 0 ifTrue: [^ aNoneBlock value]. - menuIndex = 1]) - ifTrue: [ - self request: 'New category name?' - initialAnswer: 'category-name'] - ifFalse: [ - labels at: menuIndex]. - - ^ newName isEmpty - ifTrue: aNoneBlock - ifFalse: [newName asSymbol]! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'RNG 3/16/2019 14:29:57' prior: 50514820! - buildMorphicWindow - "Create a pluggable version of all the morphs for a Browser in Morphic" - - | upperPanes messageCatList messageList systemCatList classList | - - systemCatList _ self buildMorphicSystemCatList. - classList _ self buildMorphicClassList. - messageCatList _ self buildMorphicMessageCatList. - messageList _ self buildMorphicMessageList. - - systemCatList rightSibling: classList. - classList leftSibling: systemCatList rightSibling: messageCatList. - messageCatList leftSibling: classList rightSibling: messageList. - messageList leftSibling: messageCatList. - - classList makeItemsDraggable. - systemCatList - acceptDropsFrom: classList - performing: #categorizeUnderCategoryAt:class: - whenOutsideList: #categorizeUnderNewCategoryClass:. - - messageList makeItemsDraggable. - messageCatList - acceptDropsFrom: messageList - performing: #categorizeUnderCategoryAt:selector: - whenOutsideList: #categorizeUnderNewCategorySelector:. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: systemCatList proportionalWidth: 0.2; - addAdjusterAndMorph: (self buildMorphicClassColumnWith: classList) proportionalWidth: 0.2; - addAdjusterAndMorph: messageCatList proportionalWidth: 0.2; - addAdjusterAndMorph: messageList proportionalWidth: 0.4. - - self layoutMorph - addMorph: upperPanes proportionalHeight: 0.3; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.7. - - model changed: #editSelection! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'jmv 1/10/2020 14:38:33' prior: 50514868! - buildNoSysCatMorphicWindow - "A Browser without the class categories list" - - | mySingletonList upperPanes messageCatList messageList classColumn classList | - mySingletonList _ PluggableListMorph - model: model - listGetter: #systemCategorySingleton - indexGetter: #indexIsOne - indexSetter: #indexIsOne: - mainView: self - menuGetter: #systemCatSingletonMenu - keystrokeAction: #systemCatSingletonKey:from:. - mySingletonList hideScrollBarsIndefinitely. - - classList _ self buildMorphicClassList. - classColumn _ self buildMorphicClassColumnWith: classList. - messageCatList _ self buildMorphicMessageCatList. - messageList _ self buildMorphicMessageList. - - classList rightSibling: messageCatList. - messageCatList leftSibling: classList rightSibling: messageList. - messageList leftSibling: messageCatList. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: classColumn proportionalWidth: 0.3; - addAdjusterAndMorph: messageCatList proportionalWidth: 0.3; - addAdjusterAndMorph: messageList proportionalWidth: 0.4. - - messageList makeItemsDraggable. - messageCatList - acceptDropsFrom: messageList - performing: #categorizeUnderCategoryAt:selector: - whenOutsideList: #categorizeUnderNewCategorySelector:. - - self layoutMorph - addMorph: mySingletonList fixedHeight: Preferences standardCodeFont lineSpacing + 10; - addAdjusterAndMorph: upperPanes proportionalHeight: 0.3; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.7. - - model changed: #editSelection! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4194-RestoreDnDAndCategoryNamePromptTweak-LucianoEstebanNotarfrancesco-2020May28-11h08m-len.001.cs.st----! - -'From Cuis 5.0 [latest update: #4194] on 29 May 2020 at 4:32:09 pm'! -!Workspace methodsFor: 'testing' stamp: 'jmv 5/29/2020 16:30:47'! - styleByParagraphs - "Answer true if each paragraph should be styled independent of the others. - This is useful in Workspaces, where the whole contents might not be valid Smalltalk. - Note that this precludes multi paragraph comments. Multiple comments are required in such cases." - - ^true! ! -!Workspace methodsFor: 'user interface support' stamp: 'jmv 5/29/2020 16:31:26' prior: 50518110 overrides: 50368786! - formatAndStyleIfNeededWith: anSHTextStyler - | separator fragmentStart fragmentEnd done| - (anSHTextStyler notNil and: [self shouldStyle: self actualContents with: anSHTextStyler]) - ifFalse: [^ self]. - - self styleByParagraphs ifFalse: [ - ^super formatAndStyleIfNeededWith: anSHTextStyler ]. - - actualContents _ actualContents optimizedForMutationSpeed. - anSHTextStyler formatWorkspace: actualContents. - separator _ String newLineString, String newLineString. - fragmentStart _ 1. - done _ false. - [done] whileFalse: [ - fragmentEnd _ actualContents - indexOfSubCollection: separator - startingAt: fragmentStart - ifAbsent: [done _ true. actualContents size]. - anSHTextStyler styleWorkspaceFrom: fragmentStart to: fragmentEnd. - fragmentStart _ fragmentEnd+separator size ]. - self changed: #shoutStyled! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4195-AllowWorkspaceSubclassesUseWholeContentsStyling-JuanVuletich-2020May29-16h29m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4195] on 31 May 2020 at 3:50:57 pm'! -!LayoutAdjustingMorph commentStamp: '' prior: 0! - When added to the submorphs of a LayoutMorph, -I am a way of directly adjusting layout width or height. - -I take care of the user interactions and delegate the actual changes to my containing LayoutMorph. -See LayoutAdjustingMorph>>adjustOwnerAt: - -The way adjustments are made differs between fixed and proportional Morphs. - -If I am between two proportional Morphs, the relative Morph proportions on both sides of me are adjusted. - -If the user is moving me between a fixed and a proportional morph, the fixed size is adjusted. - -The general effect is that if between 2 proportional Morphs, the proportions are adjusted and the -user sees the boundary between two morphs change. If one Morph is fixed, then the user sees -the proportional Morphs ALL adjust. An "accordian like" effect. This is NOT due to a change -in relative proportions but just the proportional expansion or squeezing of the proportional -Morphs themselves. - -E.g. note LayoutMorph class>>example11 which has a fixed Morph at each end. -! -!WindowEdgeAdjustingMorph commentStamp: '' prior: 0! - I am a LayoutAdjustingMorph which acts on window edges or corners. -! -!Symbol methodsFor: 'testing' stamp: 'KenD 4/30/2020 11:52:10' overrides: 50468414! - is: aSymbol - "Answer false if I am not a Symbol. - ??Note: A Symbol is also a String; should we check for #String and answer false??" - ^#Symbol = aSymbol or: [ super is: aSymbol]! ! -!Morph methodsFor: 'geometry' stamp: 'KenD 5/21/2020 15:17:30'! - allocHeightForFactor: aFactor - - "Morphs with LayoutSpecs may specify propottional layouts and minimum extents - amountToAlloc * proportion * factor >= minHeight - so breakeven is when - amountToAlloc = minHeight / proportion * factor" - | minHeight | - minHeight := self minimumLayoutHeight. - ^(self isProportionalHeight) - ifFalse: [ minHeight ] - ifTrue: [ minHeight / (aFactor * self layoutSpec privateProportionalHeight) ]! ! -!Morph methodsFor: 'geometry' stamp: 'KenD 5/21/2020 13:46:57'! - allocWidthForFactor: aFactor - - "Morphs with LayoutSpecs may specify propottional layouts and minimum extents - amountToAlloc * proportion * factor >= minWidth - so breakeven is when - amountToAlloc = minWidth / proportion * factor" - | minWidth | - minWidth := self minimumLayoutWidth. - ^(self isProportionalWidth) - ifFalse: [ minWidth ] - ifTrue: [ minWidth / (aFactor * self layoutSpec privateProportionalWidth) ]! ! -!Morph methodsFor: 'layout' stamp: 'KenD 5/11/2020 12:48:34'! - minLayoutHeight - - self flag: #deprecated. - ^ self layoutSpecOrNil - ifNil: [ self morphHeight ] - ifNotNil: [ :ls | ls minimumSpecHeight ] -! ! -!Morph methodsFor: 'layout' stamp: 'KenD 5/11/2020 12:48:26'! - minLayoutWidth - - self flag: #deprecated. - ^ self layoutSpecOrNil - ifNil: [ self morphWidth ] - ifNotNil: [ :ls | ls minimumSpecWidth ]! ! -!Morph methodsFor: 'layout' stamp: 'KenD 5/11/2020 12:42:30'! - minimumLayoutHeight - "I combine information from a Morph and its optional LayoutSpec" - | minHeight | - - minHeight _ self minimumExtent y. "from morph (me)." - ^ self layoutSpecOrNil - ifNil: [ minHeight ] - ifNotNil: [ :ls | minHeight max: (ls minimumSpecHeight )] -! ! -!Morph methodsFor: 'layout' stamp: 'KenD 5/11/2020 12:43:28'! - minimumLayoutWidth - "I combine information from a Morph and its optional LayoutSpec" - | minWidth | - - minWidth _ self minimumExtent x. "from morph (me)." - ^ self layoutSpecOrNil - ifNil: [ minWidth ] - ifNotNil: [ :ls | minWidth max: (ls minimumSpecWidth )] -! ! -!Morph methodsFor: 'layout' stamp: 'KenD 5/28/2020 21:38:39'! - minimumShrinkExtent - "This returns the minimum extent that the morph may be shrunk to. - It is expressed in the morph own coordinates, like morphExtent." - - | minExtent | - minExtent _ self minimumExtent. - ^ layoutSpec - ifNil: [ minExtent ] - ifNotNil: [ minExtent max: layoutSpec minimumShrinkWidth @ layoutSpec minimumShrinkHeight ]! ! -!Morph methodsFor: 'layout' stamp: 'KenD 5/31/2020 14:20:14'! - minimumShrinkHeight - "This returns the minimum height that the morph may be shrunk to by a LayoutAdjustingMorph. - It is expressed in the morph own coordinates, like morphExtent." - - | minShrinkHeight | - minShrinkHeight _ self minimumExtent y. - ^ layoutSpec - ifNil: [ minShrinkHeight ] - ifNotNil: [ minShrinkHeight max: layoutSpec minimumShrinkHeight ]! ! -!Morph methodsFor: 'layout' stamp: 'KenD 5/28/2020 21:47:43'! - minimumShrinkWidth - "This returns the minimum width that the morph may be shrunk to by a LayoutAdjustingMorph. - It is expressed in the morph own coordinates, like morphExtent." - - | minShrinkWidth | - minShrinkWidth _ self minimumExtent x. - ^ layoutSpec - ifNil: [ minShrinkWidth ] - ifNotNil: [ minShrinkWidth max: layoutSpec minimumShrinkWidth ]! ! -!Morph methodsFor: 'testing' stamp: 'KenD 5/11/2020 13:04:22'! - isProportionalHeight - "Answer true if I have a layoutSpec which specifies a proportional layout" - - ^self layoutSpecOrNil - ifNil: [ false ] - ifNotNil: [ :ls | ls isProportionalHeight ]! ! -!Morph methodsFor: 'testing' stamp: 'KenD 5/11/2020 13:04:10'! - isProportionalWidth - "Answer true if I have a layoutSpec which specifies a proportional layout" - - ^self layoutSpecOrNil - ifNil: [ false ] - ifNotNil: [ :ls | ls isProportionalWidth ]! ! -!PluggableButtonMorph methodsFor: 'geometry' stamp: 'KenD 5/5/2020 12:15:55' overrides: 50519192! -minLayoutHeight - - ^ self minimumExtent y! ! -!PluggableButtonMorph methodsFor: 'geometry' stamp: 'KenD 5/5/2020 12:16:08' overrides: 50519199! - minLayoutWidth - - ^ self minimumExtent x! ! -!PluggableButtonMorph methodsFor: 'geometry' stamp: 'KenD 5/5/2020 17:07:16' overrides: 50499535! - minimumExtent - - | e | - e _ Preferences windowTitleFont pointSize + 2. - ^e@e! ! -!LayoutMorph methodsFor: 'accessing' stamp: 'KenD 5/2/2020 15:09:07'! - axisEdgeWeight - - ^ padding! ! -!LayoutMorph methodsFor: 'accessing' stamp: 'KenD 4/30/2020 11:54:47'! - axisEdgeWeight: aSymbolOrNumber - "Along the Major or Layout Axis, subMorphs may be attracted toward one side (0.0) or the other (1.0). This is the LayoutMorph's axisEdgeWeight. A numeric value is between 0.0 and 1.0 - - If a Row, one can specify this weight symbolically as - { #rowLeft (0.0), #center (0.5), #rowRight (1.0)} - - If a Column, one can specify the weight symbolically as: - { #columnTop (0.0), #center (0.5), #columnBottom (1.0) }" -" - self axisEdgeWeight: #rowLeft. -- axis must be horizontal - self axisEdgeWeight: #columnTop. -- axis must be vertical -" - | edgeWeight | - (aSymbolOrNumber is: #Number) - ifTrue: [ (aSymbolOrNumber between: 0.0 and: 1.0) - ifTrue: [edgeWeight := aSymbolOrNumber ] - ifFalse: [self error: 'axisEdgeWeight ', aSymbolOrNumber printString, ' is out of range 0.0 to 1.0'] - ] - ifFalse: [ - (self direction = #horizontal) - ifTrue: [ "Row" - edgeWeight := aSymbolOrNumber - caseOf: { - [ #rowLeft ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #rowRight ] -> [ 1.0 ] - } - otherwise: [ self error: 'bad axisEdgeWeight for Row: ', aSymbolOrNumber printString ]. - ] - ifFalse: [ "vertical => Column" - edgeWeight := aSymbolOrNumber - caseOf: { - [ #columnTop ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #columnBottom ] -> [ 1.0 ] - } - otherwise: [ self error: 'bad axisEdgeWeight for Column: ', aSymbolOrNumber printString ]. - ] - ]. - padding := edgeWeight. - "self layoutSubmorphs"! ! -!LayoutMorph methodsFor: 'layout' stamp: 'KenD 5/27/2020 12:32:46'! - heightsFor: visibleSubs within: overallHeight - "Answer array of morphHeights for visibleSubs." - "Preconditions: - ySepararations already subtracted from overallHeight. - overallHeight is large enough to contain minimumLayoutHeights of visibleSubs." - - | numSubs scaleFactor heightToAllocate - sumOfPropMin sumOfPropDesired sumOfFixedMin - allocatedHeights propIndices desiredProps - maxOfMinAllocHeight - | - numSubs := visibleSubs size. - sumOfFixedMin := 0. "pixels" - sumOfPropMin := 0. "pixels" - sumOfPropDesired := 0. "sum of percentage fractions; may be more than 100%" - allocatedHeights := Array ofSize: numSubs. - desiredProps := Array ofSize: numSubs. - propIndices := Set new. "keep set of proportional morph indices" - 1 to: numSubs do: [ :index | | sm layoutHeightMin | - sm := visibleSubs at: index. - layoutHeightMin := sm minimumLayoutHeight. - allocatedHeights at: index put: layoutHeightMin. - (sm isProportionalHeight) - ifTrue: [ | propDesired | - propIndices add: index. - propDesired := sm layoutSpec privateProportionalHeight. - desiredProps at: index put: propDesired. - sumOfPropDesired := sumOfPropDesired + propDesired. - sumOfPropMin := sumOfPropMin + layoutHeightMin. - ] - ifFalse: [ "Allocate height for non-proportional-height morphs" - sumOfFixedMin := sumOfFixedMin + layoutHeightMin. - ] - ]. - - ((propIndices size = 0) "already finished" - or: [(overallHeight - (sumOfFixedMin + sumOfPropMin)) < 2]) "close enough" - ifTrue: [ ^ allocatedHeights ]. - - "All fixed heights allocated; rest is for proportional + leftOver" - heightToAllocate := (overallHeight - sumOfFixedMin) max: 0. - scaleFactor := 1.0 / (sumOfPropDesired max: 1.0). "if > 100% then below 1" - - "Do simple default scaling" - propIndices do: [ :morphIndex | - allocatedHeights at: morphIndex - put: ((allocatedHeights at: morphIndex) max: - (heightToAllocate - * scaleFactor - * (desiredProps at: morphIndex))) - ]. - - "Find the min alloc size at which adding height is above max of minHeights - Keep the proportions over the minHeights at this allocation." - maxOfMinAllocHeight := propIndices max: [ :morphIndex | - (visibleSubs at: morphIndex) allocHeightForFactor: scaleFactor - ]. - - "Below the balance point, calculate proportions from belowBalanceDeltas, - above, use desiredProps" - (heightToAllocate <= maxOfMinAllocHeight) ifTrue: [ | belowBalanceDeltas sumOfDeltas | - (sumOfPropDesired < 1.0) "Trim off space to save" - ifTrue: [ heightToAllocate := heightToAllocate * sumOfPropDesired ]. - belowBalanceDeltas := Array ofSize: visibleSubs size. - propIndices do: [ :morphIndex | | heightAtBalance | - heightAtBalance := maxOfMinAllocHeight * scaleFactor * (desiredProps at: morphIndex). - belowBalanceDeltas at: morphIndex - put: heightAtBalance "delta above min height" - - ((visibleSubs at: morphIndex) minimumLayoutHeight) - ]. - sumOfDeltas := belowBalanceDeltas sum: [ :b | b ifNil: [0]]. - (sumOfDeltas > propIndices size) ifTrue: [ "space desired < 100%" - propIndices do: [ :morphIndex | - allocatedHeights at: morphIndex - put: ((visibleSubs at: morphIndex) minimumLayoutHeight) - + (((heightToAllocate - sumOfPropMin ) max: 0.0) - * (belowBalanceDeltas at: morphIndex) / sumOfDeltas) - ] - ] - ]. - - ^ allocatedHeights! ! -!LayoutMorph methodsFor: 'layout' stamp: 'KenD 5/12/2020 14:07:31'! - offHorizontalMetricFor: aMorph withinExtent: boundsForLayout - "Answer a point: height@y for a single morph -- offAxis calculation for a Row" - - | spec minMorphHeight theSeparation proportionalHeight - availableForPropHeight actualPropHeight - leftOver yPos | - spec := aMorph layoutSpec. - theSeparation := self ySeparation. - minMorphHeight := aMorph minimumLayoutHeight. - availableForPropHeight := (boundsForLayout height) - (2 * theSeparation).. - proportionalHeight := spec proportionalLayoutHeight min: 1.0. - actualPropHeight := (availableForPropHeight * proportionalHeight) - max: minMorphHeight. - leftOver := availableForPropHeight - actualPropHeight. - - yPos := boundsForLayout origin y - + theSeparation - + (leftOver * spec offAxisEdgeWeight). "first Y, edge shifted" - - ^ actualPropHeight @ yPos - - ! ! -!LayoutMorph methodsFor: 'layout' stamp: 'KenD 5/12/2020 14:07:42'! - offVerticalMetricFor: aMorph withinExtent: boundsForLayout - "Answer a point: x@width for a single morph -- offAxis calculation for a Column" - - | spec minMorphWidth theSeparation proportionalWidth - availableForPropWidth actualPropWidth - leftOver xPos | - spec := aMorph layoutSpec. - theSeparation := self xSeparation. - minMorphWidth := aMorph minimumLayoutWidth. - availableForPropWidth := (boundsForLayout width) - (2 * theSeparation). - proportionalWidth := spec proportionalLayoutWidth min: 1.0. - actualPropWidth := (availableForPropWidth * proportionalWidth) - max: minMorphWidth. - leftOver := availableForPropWidth - actualPropWidth. - - xPos := boundsForLayout origin x - + theSeparation - + (leftOver * spec offAxisEdgeWeight). "first X, edge shifted" - - ^ xPos @ actualPropWidth - ! ! -!LayoutMorph methodsFor: 'layout' stamp: 'KenD 5/27/2020 12:33:28'! - widthsFor: visibleSubs within: overallWidth - "Answer array of morphWidths for visibleSubs." - "Preconditions: - xSepararations already subtracted from overallWidth. - overallWidth is large enough to contain minimumLayoutWidths of visibleSubs." - - | numSubs scaleFactor widthToAllocate - sumOfPropMin sumOfPropDesired sumOfFixedMin - allocatedWidths propIndices desiredProps - maxOfMinAllocWidth - | - numSubs := visibleSubs size. - sumOfFixedMin := 0. "pixels" - sumOfPropMin := 0. "pixels" - sumOfPropDesired := 0. "sum of percentage fractions; may be more than 100%" - allocatedWidths := Array ofSize: numSubs. - desiredProps := Array ofSize: numSubs. - propIndices := Set new. "keep set of proportional morph indices" - 1 to: numSubs do: [ :index | | sm layoutWidthMin | - sm := visibleSubs at: index. - layoutWidthMin := sm minimumLayoutWidth. - allocatedWidths at: index put: layoutWidthMin. - (sm isProportionalWidth) - ifTrue: [ | propDesired | - propIndices add: index. - propDesired := sm layoutSpec privateProportionalWidth. - desiredProps at: index put: propDesired. - sumOfPropDesired := sumOfPropDesired + propDesired. - sumOfPropMin := sumOfPropMin + layoutWidthMin. - ] - ifFalse: [ "Allocate width for non-proportional-width morphs" - sumOfFixedMin := sumOfFixedMin + layoutWidthMin. - ] - ]. - - ((propIndices size = 0) "already finished" - or: [(overallWidth - (sumOfFixedMin + sumOfPropMin)) < 2]) "close enough" - ifTrue: [ ^ allocatedWidths ]. - - "All fixed widths allocated; rest is for proportional + leftOver" - widthToAllocate := (overallWidth - sumOfFixedMin) max: 0. - scaleFactor := 1.0 / (sumOfPropDesired max: 1.0). "if > 100% then below 1" - - "Do simple default scaling" - propIndices do: [ :morphIndex | - allocatedWidths at: morphIndex - put: ((allocatedWidths at: morphIndex) max: - (widthToAllocate - * scaleFactor - * (desiredProps at: morphIndex))) - ]. - - "Find the min alloc size at which adding width is above max of minWidths - Keep the proportions over the minWidths at this allocation." - maxOfMinAllocWidth := propIndices max: [ :morphIndex | - (visibleSubs at: morphIndex) allocWidthForFactor: scaleFactor - ]. - - "Below the balance point, calculate proportions from belowBalanceDeltas, - above, use desiredProps" - (widthToAllocate <= maxOfMinAllocWidth) ifTrue: [ | belowBalanceDeltas sumOfDeltas | - (sumOfPropDesired < 1.0) "Trim off space to save" - ifTrue: [ widthToAllocate := widthToAllocate * sumOfPropDesired ]. - belowBalanceDeltas := Array ofSize: visibleSubs size. - propIndices do: [ :morphIndex | | widthAtBalance | - widthAtBalance := maxOfMinAllocWidth * scaleFactor * (desiredProps at: morphIndex). - belowBalanceDeltas at: morphIndex - put: widthAtBalance "delta above min width" - - ((visibleSubs at: morphIndex) minimumLayoutWidth) - ]. - sumOfDeltas := belowBalanceDeltas sum: [ :b | b ifNil: [0]]. - (sumOfDeltas > propIndices size) ifTrue: [ "space desired < 100%" - propIndices do: [ :morphIndex | - allocatedWidths at: morphIndex - put: ((visibleSubs at: morphIndex) minimumLayoutWidth) - + (((widthToAllocate - sumOfPropMin ) max: 0.0) - * (belowBalanceDeltas at: morphIndex) / sumOfDeltas) - ] - ] - ]. - - ^ allocatedWidths! ! -!LayoutMorph methodsFor: 'submorphs-add/remove' stamp: 'KenD 5/26/2020 15:14:45' overrides: 16876848! - addMorphFront: aMorph - "Add a submorph, at the bottom or right, with a default LayoutSpec if none was provided." - - aMorph layoutSpec. - super addMorphFront: aMorph! ! -!LayoutMorph methodsFor: 'submorphs-add/remove' stamp: 'KenD 5/28/2020 07:33:52' overrides: 16876964! - removedMorph: aMorph - "One of my submorphs has been removed." - - super removedMorph: aMorph. - self layoutSubmorphs! ! -!LayoutMorph methodsFor: 'testing' stamp: 'KenD 5/4/2020 12:58:45'! - isColumn - - ^ direction = #vertical! ! -!LayoutMorph methodsFor: 'testing' stamp: 'KenD 5/4/2020 12:57:59'! - isRow - - ^ direction = #horizontal! ! -!LayoutMorph methodsFor: 'private' stamp: 'KenD 5/29/2020 13:57:00' overrides: 16877049! - privateAddAllMorphs: aCollection atIndex: index - aCollection do: [ :m | m layoutSpec ]. - ^super privateAddAllMorphs: aCollection atIndex: index! ! -!LayoutMorph methodsFor: 'private' stamp: 'KenD 5/29/2020 13:57:16' overrides: 16877086! - privateAddMorph: aMorph atIndex: index - aMorph layoutSpec. - ^super privateAddMorph: aMorph atIndex: index! ! -!LayoutMorph methodsFor: 'private' stamp: 'KenD 5/29/2020 13:57:32' overrides: 16877128! - privateAddMorph: aMorph atIndex: index position: aPoint - aMorph layoutSpec. - ^super privateAddMorph: aMorph atIndex: index position: aPoint! ! -!LayoutMorph methodsFor: 'deprecated' stamp: 'KenD 5/31/2020 14:13:54'! - padding - - self flag: #deprecated - ^ padding! ! -!LayoutMorph methodsFor: '*morphic-misc1' stamp: 'KenD 12/24/2013 15:14'! - direction: horizOrVert - - self flag: #jmvVer. "Move to category #accessing" - - direction := horizOrVert! ! -!LayoutSpec methodsFor: 'accessing' stamp: 'KenD 4/30/2020 09:34:28'! - offAxisEdgeWeight - ^minorDirectionPadding! ! -!LayoutSpec methodsFor: 'accessing' stamp: 'KenD 5/28/2020 07:31:23'! - offAxisEdgeWeight: aSymbolOrNumber - "A LayoutSpec may indicate a weighting perpendicular to the Layout Axis. - - This is the LayoutSpec's offAxisEdgeWeight which is between 0.0 and 1.0. - - As with LayoutSpec's a symbol may be used. - - If in a Row (preferred): { #rowTop (0.0), #center (0.5), #rowBottom (1.0)} - - If in a Column (preferred): { #columnLeft (0.0), #center (0.5), #columnRight (1.0) } - - Also accepted: { #leftOrTop (0.0), #center (0.5), #rightOrBottom (1.0) } - " - | edgeWeight | - edgeWeight := (aSymbolOrNumber is: #Number) - ifTrue: [ (aSymbolOrNumber between: 0.0 and: 1.0) - ifTrue: [ aSymbolOrNumber ] - ifFalse: [self error: 'axisEdgeWeight ', aSymbolOrNumber printString, ' is out of range 0.0 to 1.0'] - ] - ifFalse: [ aSymbolOrNumber - caseOf: { - [ #leftOrTop ] -> [ 0.0 ]. - [ #rowTop ] -> [ 0.0 ]. - [ #columnLeft ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #rightOrBottom ] -> [ 1.0 ]. - [ #rowBottom ] -> [ 1.0 ]. - [ #columnRight ] -> [ 1.0 ] - } - otherwise: [ self error: 'bad offAxisEdgeWeight specifier: ', aSymbolOrNumber printString ] - ]. - minorDirectionPadding _ edgeWeight! ! -!LayoutSpec methodsFor: 'layout' stamp: 'KenD 5/28/2020 21:35:37'! - minimumShrinkHeight - "Generally prefer asking the morph itself!!" - - proportionalHeight ifNil: [ ^0 ]. - ^fixedHeight ifNil: [0]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'KenD 5/28/2020 21:35:20'! - minimumShrinkWidth - "Generally prefer asking the morph itself!!" - - proportionalWidth ifNil: [ ^0 ]. - ^fixedWidth ifNil: [0]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'KenD 5/11/2020 12:51:04'! - minimumSpecExtent - - ^ self minimumSpecWidth @ self minimumSpecHeight ! ! -!LayoutSpec methodsFor: 'layout' stamp: 'KenD 5/11/2020 12:36:37'! - minimumSpecHeight - "If fixedHeight is not nil, use it. - If fixdHeight and propostionlHeight are nil, use morphHeight" - - ^ fixedHeight ifNil: [ proportionalHeight ifNotNil: [ 0 ] ifNil: [ morph morphHeight ] ]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'KenD 5/11/2020 12:37:14'! - minimumSpecWidth - "If fixedWidth is not nil, use it. - If fixdWidth and propostionlWidth are nil, use morphWidth" - - ^ fixedWidth ifNil: [ proportionalWidth ifNotNil: [ 0 ] ifNil: [ morph morphWidth ] ]! ! -!LayoutSpec methodsFor: 'deprecated' stamp: 'KenD 5/31/2020 14:19:05'! - fixedOrMorphHeight - - self flag: #deprecated. - - ^fixedHeight ifNil: [ morph morphHeight ]! ! -!LayoutSpec methodsFor: 'deprecated' stamp: 'KenD 5/31/2020 14:18:45'! - fixedOrMorphWidth - - self flag: #deprecated. - - ^fixedWidth ifNil: [ morph morphWidth ]! ! -!LayoutSpec methodsFor: '*morphic-misc1' stamp: 'KenD 4/18/2015 20:18'! - morph - "For #showHalo" - ^ morph! ! -!LayoutSpec methodsFor: '*morphic-misc1' stamp: 'KenD 12/24/2013 15:15'! - privateFixedWidth - - ^ fixedWidth! ! -!LayoutSpec methodsFor: '*morphic-misc1' stamp: 'KenD 12/24/2013 15:15'! - privateProportionalWidth - - ^ proportionalWidth ! ! -!LayoutSpec class methodsFor: 'instance creation' stamp: 'KenD 5/22/2020 13:49:12'! - fixedWidth: aNumber fixedHeight: otherNumber offAxisEdgeWeight: aSymbolOrNumber - ^ LayoutSpec new - fixedWidth: aNumber; - fixedHeight: otherNumber; - offAxisEdgeWeight: aSymbolOrNumber! ! -!LayoutSpec class methodsFor: 'instance creation' stamp: 'KenD 5/22/2020 13:54:56'! - fixedWidth: aNumber proportionalHeight: otherNumber offAxisEdgeWeight: aSymbolOrNumber - - ^self new - fixedWidth: aNumber; - proportionalHeight: otherNumber; - offAxisEdgeWeight: aSymbolOrNumber! ! -!LayoutSpec class methodsFor: 'instance creation' stamp: 'KenD 5/22/2020 13:55:19'! - proportionalWidth: aNumber fixedHeight: otherNumber offAxisEdgeWeight: aSymbolOrNumber - - ^self new - proportionalWidth: aNumber; - fixedHeight: otherNumber; - offAxisEdgeWeight: aSymbolOrNumber! ! -!LayoutSpec class methodsFor: 'instance creation' stamp: 'KenD 5/22/2020 13:56:21'! - proportionalWidth: aNumber proportionalHeight: otherNumber offAxisEdgeWeight: aSymbolOrNumber - - ^self new - proportionalWidth: aNumber; - proportionalHeight: otherNumber; - offAxisEdgeWeight: aSymbolOrNumber! ! -!Morph methodsFor: 'geometry' stamp: 'KenD 5/29/2020 14:15:06' prior: 50500189! - minimumLayoutExtent - "This returns the minimum extent that the morph may be shrunk to, - when resizing LayoutMorphs. - It is expressed in the morph own coordinates, like morphExtent." - - "This method combines the information from a Morph and its optional LayoutSpec" - | minExtent | - minExtent _ self minimumExtent. - ^ layoutSpec - ifNil: [ minExtent ] - ifNotNil: [ minExtent max: ( layoutSpec minimumSpecWidth @ layoutSpec minimumSpecHeight ) ]! ! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'KenD 5/29/2020 14:03:30' prior: 16876780! - addAllMorphs: aCollection - ^ (aCollection size > 0) - ifTrue: [ self privateAddAllMorphs: aCollection atIndex: submorphs size ] - ifFalse: [ self ]! ! -!BrowserCommentTextMorph methodsFor: 'displaying' stamp: 'KenD 5/5/2020 17:24:59' prior: 50499566! - hidePane - - self hide. - separator visible ifTrue: [ - proportionalHeight _ self layoutSpec proportionalLayoutHeight. - separatorHeight _ separator layoutSpec fixedOrMorphHeight ]. - separator layoutSpec fixedHeight: 0. - self layoutSpec proportionalHeight: 0. - separator ifNotNil: [ separator hide ]! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'KenD 5/22/2020 13:59:53' prior: 50432052! - buildRequirementsPane - - | requirements deleteReqButton "editReqButton" reqLayout buttonLayout updateReqButton | - requirements := PluggableListMorph - model: (PackageRequirementsList fromCodePackageList: model) - listGetter: #requirementsStrings - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - requirements color: Theme current textPane. - - deleteReqButton := PluggableButtonMorph - model: requirements model - action: #deleteSelectedRequirement - label: 'delete'. - deleteReqButton color: self widgetsColor. - updateReqButton _ PluggableButtonMorph - model: requirements model - action: #updateSelectedRequirement - label: 'update'. - updateReqButton color: self widgetsColor. - - buttonLayout := LayoutMorph newRow. - buttonLayout - addMorph: deleteReqButton - layoutSpec: (LayoutSpec - proportionalWidth: 1.0 - proportionalHeight: 1.0 - offAxisEdgeWeight: #leftOrTop); - color: self widgetsColor quiteWhiter; - addMorph: updateReqButton - layoutSpec: (LayoutSpec - proportionalWidth: 1.0 - proportionalHeight: 1.0 - offAxisEdgeWeight: #leftOrTop); - color: self widgetsColor quiteWhiter. - - model when: #changed: send: #updateRequirementsFromPackageList to: requirements model. - self when: #changed: send: #updateRequirementsFromPackageList to: requirements model. - requirements model when: #changed: send: #verifyContents to: requirements. - self when: #changed: send: #verifyContents to: requirements. - - reqLayout := LayoutMorph newRow. - ^ reqLayout - doAdoptWidgetsColor; - addMorph: requirements - layoutSpec: (LayoutSpec - proportionalWidth: 0.8 - proportionalHeight: 1.0 - offAxisEdgeWeight: #leftOrTop); - addMorph: buttonLayout - layoutSpec: (LayoutSpec - proportionalWidth: 0.2 - proportionalHeight: 1.0 - offAxisEdgeWeight: #rightOrBottom); - color: `Color transparent`; - yourself - ! ! -!StringRequestMorph class methodsFor: 'private' stamp: 'KenD 5/25/2020 12:37:58' prior: 50518089! - deltaToTextPane - "Answer a distance to translate an instance of the receiver by when it is opened in the world in order to have the hand be over the text pane (so the text pane has focus). - Distance is relative to font size" - | e | - e _ Preferences windowTitleFont lineSpacing. - ^ (2 * e)@(1.5 * e)! ! -!LayoutMorph methodsFor: 'accessing' stamp: 'KenD 5/15/2020 17:49:30' prior: 50500242 overrides: 16876867! - addMorphFrontFromWorldPosition: aMorph - - aMorph layoutSpecOrNil ifNil: [aMorph layoutSpec: LayoutSpec keepMorphExtent ]. - self addMorphFront: aMorph. - self layoutSubmorphs. -! ! -!LayoutMorph methodsFor: 'adjust' stamp: 'KenD 5/31/2020 15:38:28' prior: 16863051! - adjustBy: aLayoutAdjustMorph at: aPoint - "See Class Comment of LayoutAdjustingMorph" - - direction == #horizontal ifTrue: [ - self adjustHorizontallyBy: aLayoutAdjustMorph at: aPoint ]. - - direction == #vertical ifTrue: [ - self adjustVerticallyBy: aLayoutAdjustMorph at: aPoint ].! ! -!LayoutMorph methodsFor: 'adjust' stamp: 'KenD 5/28/2020 21:46:22' prior: 50499585! - adjustHorizontallyBy: aLayoutAdjustMorph at: aPoint - | delta l ls r rs lNewWidth rNewWidth i lCurrentWidth rCurrentWidth | - i _ submorphs indexOf: aLayoutAdjustMorph. - l _ self submorphs at: i +1. - ls _ l layoutSpec. - lCurrentWidth _ l morphWidth max: 1. "avoid division by zero" - r _ self submorphs at: i - 1. - rs _ r layoutSpec. - rCurrentWidth _ r morphWidth max: 1. "avoid division by zero" - delta _ aPoint x - aLayoutAdjustMorph referencePosition x. - delta _ delta max: l minimumShrinkWidth - lCurrentWidth. - delta _ delta min: rCurrentWidth - r minimumShrinkWidth. - delta = 0 ifTrue: [ ^self ]. - rNewWidth _ rCurrentWidth - delta. - lNewWidth _ lCurrentWidth + delta. - (ls isProportionalWidth and: [ rs isProportionalWidth ]) - ifTrue: [ | leftNewProportion rightNewProportion toDistribute | "If both proportional, update them" - leftNewProportion _ lNewWidth / (lNewWidth + rNewWidth). - rightNewProportion _ 1.0 - leftNewProportion. - toDistribute _ ls proportionalLayoutWidth + rs proportionalLayoutWidth. - ls setProportionalWidth: leftNewProportion * toDistribute. - rs setProportionalWidth: rightNewProportion * toDistribute ] - ifFalse: ["If at least one is fixed, update only the fixed" - ls isProportionalWidth ifFalse: [ - ls fixedOrMorphWidth: lNewWidth ]. - rs isProportionalWidth ifFalse: [ - rs fixedOrMorphWidth: rNewWidth ]]. - self layoutSubmorphs.! ! -!LayoutMorph methodsFor: 'adjust' stamp: 'KenD 5/28/2020 21:49:25' prior: 50499631! - adjustVerticallyBy: aLayoutAdjustMorph at: aPoint - | delta t ts b bs tNewHeight bNewHeight i tCurrentHeight bCurrentHeight | - i _ submorphs indexOf: aLayoutAdjustMorph. - t _ self submorphs at: i +1. - ts _ t layoutSpec. - tCurrentHeight _ t morphHeight max: 1. "avoid division by zero" - b _ self submorphs at: i - 1. - bs _ b layoutSpec. - bCurrentHeight _ b morphHeight max: 1. "avoid division by zero" - delta _ aPoint y - aLayoutAdjustMorph referencePosition y. - delta _ delta max: t minimumShrinkHeight - tCurrentHeight. - delta _ delta min: bCurrentHeight - b minimumShrinkHeight. - delta = 0 ifTrue: [ ^self ]. - tNewHeight _ tCurrentHeight + delta. - bNewHeight _ bCurrentHeight - delta. - (ts isProportionalHeight and: [ bs isProportionalHeight ]) - ifTrue: [ | bottomNewProportion toDistribute topNewProportion | "If both proportional, update them" - topNewProportion _ tNewHeight / (tNewHeight + bNewHeight). - bottomNewProportion _ 1.0 - topNewProportion. - toDistribute _ ts proportionalLayoutHeight + bs proportionalLayoutHeight. - ts setProportionalHeight: topNewProportion * toDistribute. - bs setProportionalHeight: bottomNewProportion * toDistribute ] - ifFalse: ["If at least one is fixed, update only the fixed" - ts isProportionalHeight ifFalse: [ - ts fixedOrMorphHeight: tNewHeight ]. - bs isProportionalHeight ifFalse: [ - bs fixedOrMorphHeight: bNewHeight ]]. - self layoutSubmorphs! ! -!LayoutMorph methodsFor: 'geometry' stamp: 'KenD 5/15/2020 19:24:31' prior: 50500783 overrides: 50499535! - minimumExtent - "Answer size sufficient to frame my submorphs." - - | width height | - width := 0. - height := 0. - (self direction = #vertical) - ifTrue: [ "Column" - self submorphsToLayout do: [ :sm | - "use maximum width across submorphs" - width := width max: sm minimumLayoutWidth. - "sum up submorph heights, including separation" - height := height + (sm minimumLayoutHeight) + self ySeparation. - ]. - width := width + (2 * self xSeparation). "separation on each side" - height := height + self ySeparation. "one side already separated" - ] - ifFalse: [ "Row" - self submorphsToLayout do: [ :sm | - "sum up submorphs width" - width := width + (sm minimumLayoutWidth) + self xSeparation. - "use maximum height across submorph" - height := height max: sm minimumLayoutHeight. - ]. - height := height + (2 * self ySeparation). "separation on each side" - width := width + self xSeparation. "one side already separated" - ]. - - ^ (width @ height) + self extentBorder! ! -!LayoutMorph methodsFor: 'initialization' stamp: 'KenD 5/12/2020 09:23:30' prior: 50500477! - beColumn - "Establish the major layout axis, with default edge weight" - - direction _ #vertical. - self axisEdgeWeight ifNil: [self axisEdgeWeight: #center]. - self layoutSubmorphs.! ! -!LayoutMorph methodsFor: 'initialization' stamp: 'KenD 5/12/2020 09:23:35' prior: 50500483! - beRow - "Establish the major layout axis, with default edge weight" - - direction _ #horizontal. - self axisEdgeWeight ifNil: [self axisEdgeWeight: #rowLeft]. - self layoutSubmorphs.! ! -!LayoutMorph methodsFor: 'layout' stamp: 'pb 3/17/2020 13:41:27' prior: 50503574! - layoutBounds - "Return the bounds for laying out children of the receiver" - - ^ self morphLocalBounds! ! -!LayoutMorph methodsFor: 'layout' stamp: 'KenD 5/9/2020 14:25:12' prior: 16863321 overrides: 16876028! - layoutSubmorphs - "Compute a new layout based on the given layout bounds." - - submorphs isEmpty ifTrue: [ - layoutNeeded _ false. - ^self]. - - "Invariant: morphExtent >= minimumLayoutExtent" - self refreshExtent. - - direction == #horizontal ifTrue: [ - self layoutSubmorphsHorizontallyIn: self layoutBounds ]. - - direction == #vertical ifTrue: [ - self layoutSubmorphsVerticallyIn: self layoutBounds ]. - - layoutNeeded _ false! ! -!LayoutMorph methodsFor: 'layout' stamp: 'KenD 5/12/2020 14:10:38' prior: 50513303! - layoutSubmorphsHorizontallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - - | visibleSubmorphs sumOfWidths theSeparation widthsArray - widthToAllocate leftOver nextX | - "Preconditions: self isRow & morphExtent >= minimumLayoutExtent" - visibleSubmorphs := self submorphsToLayout reversed. "Display Order" - theSeparation := self xSeparation. - - widthToAllocate := (boundsForLayout width - ((visibleSubmorphs size + 1) * theSeparation)). - widthsArray := self widthsFor: visibleSubmorphs within: widthToAllocate. - sumOfWidths := widthsArray sum: [ :w | w ] . - leftOver := widthToAllocate - sumOfWidths. - nextX := boundsForLayout origin x - + theSeparation - + (leftOver * self axisEdgeWeight). "first X, edge shifted" -"Transcript log: 'first X=', nextX asString, ' leftOver=', leftOver asString; cr. -" 1 to: visibleSubmorphs size do: [ :index | | sm smX smWidth heightAndY newExtent | - sm := visibleSubmorphs at: index. - smX := nextX. - smWidth := widthsArray at: index. - nextX := smX + smWidth + theSeparation. - heightAndY := self offHorizontalMetricFor: sm withinExtent: boundsForLayout. - sm morphPosition: smX @ (heightAndY y). - newExtent := smWidth @ (heightAndY x). - (sm morphExtent = newExtent) ifFalse: [ sm morphExtent: newExtent ]. - ] -! ! -!LayoutMorph methodsFor: 'layout' stamp: 'KenD 5/12/2020 14:09:59' prior: 50513406! - layoutSubmorphsVerticallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - - | visibleSubmorphs sumOfHeights theSeparation heightsArray - heightToAllocate leftOver nextY | - "Preconditions: self isRow & morphExtent >= minimumLayoutExtent" - visibleSubmorphs := self submorphsToLayout reversed. "Display Order" - - theSeparation := self ySeparation. - heightToAllocate := (boundsForLayout height - ((visibleSubmorphs size + 1) * theSeparation)). - heightsArray := self heightsFor: visibleSubmorphs within: heightToAllocate. - sumOfHeights := heightsArray sum: [ :w | w ] . - leftOver := heightToAllocate - sumOfHeights. - nextY := boundsForLayout origin y - + theSeparation - + (leftOver * self axisEdgeWeight). "first Y, edge shifted" -"Transcript log: 'first Y=', nextY asString, ' leftOver=', leftOver asString; cr. -" 1 to: visibleSubmorphs size do: [ :index | | sm smY smHeight xAndWidth newExtent | - sm := visibleSubmorphs at: index. - smY := nextY. - smHeight := heightsArray at: index. - nextY := smY + smHeight + theSeparation. - xAndWidth := self offVerticalMetricFor: sm withinExtent: boundsForLayout. - sm morphPosition: (xAndWidth x) @ smY. - newExtent := (xAndWidth y) @ smHeight. - (sm morphExtent = newExtent) ifFalse: [ sm morphExtent: newExtent ]. - ] -! ! -!LayoutMorph methodsFor: 'layout' stamp: 'KenD 5/9/2020 14:24:33' prior: 50500264! - refreshExtent - "Invariant: my morphExtent >= my minimumExtent" - - self morphExtent: (self morphExtent max: self minimumExtent)! ! -!LayoutMorph methodsFor: 'submorphs-add/remove' stamp: 'KenD 5/26/2020 15:15:01' prior: 16863540 overrides: 16876794! - addMorph: aMorph - "Add a submorph, at the bottom or right, with a default LayoutSpec if none was provided." - - aMorph layoutSpec. - super addMorphFront: aMorph! ! -!LayoutMorph methodsFor: 'submorphs-add/remove' stamp: 'KenD 5/26/2020 15:15:38' prior: 16863548! - addMorph: aMorph layoutSpec: aLayoutSpec - - "Add a submorph, at the bottom or right, with aLayoutSpec" - aMorph layoutSpec: aLayoutSpec. - super addMorphFront: aMorph! ! -!LayoutMorph methodsFor: 'deprecated' stamp: 'KenD 5/28/2020 07:27:28' prior: 16863013! - padding: aSymbolOrNumber - "This sets how extra space is used when doing layout. For example, a column might have extra , unneded vertical space. #top means widgets are set close to the top, and extra space is at bottom. Conversely, #bottom means widgets are set close to the bottom, and extra space is at top. Valid values include #left and #right (for rows) and #center. Alternatively, any number between 0.0 and 1.0 might be used. - self new padding: #center - self new padding: 0.9 - " - self flag: #deprecated. - padding _ aSymbolOrNumber - caseOf: { - [ #top ] -> [ 0.0 ]. - [ #left ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #right ] -> [ 1.0 ]. - [ #bottom ] -> [ 1.0 ] - } - otherwise: [ aSymbolOrNumber ]! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'KenD 5/22/2020 13:57:31' prior: 50360129! - example13 - " - self example13 - " - | pane row innerRow | -pane _ (LayoutMorph newColumn separation: 5) name: #example13. - pane color: Color red. - row _ (LayoutMorph newRow separation: 5) name: #Row. - innerRow _ (LayoutMorph newRow separation: 5) name: #InnerRow; - color: Color red. - innerRow - addMorph: (BorderedRectMorph new name: #Box1) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (BorderedRectMorph new name: #Box2) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (BorderedRectMorph new name: #Bar) - layoutSpec: (LayoutSpec proportionalWidth: 1.0 fixedHeight: 10). - row - color: (Color h: 270 s: 0.2 v: 0.6); - addMorph: innerRow - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 30 offAxisEdgeWeight: #center); - addMorph: LayoutAdjustingMorph new layoutSpec: (LayoutSpec fixedWidth: 5); - addMorph: (BorderedRectMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #Rect1) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40 offAxisEdgeWeight: #leftOrTop); - addMorph: LayoutAdjustingMorph new layoutSpec: (LayoutSpec fixedWidth: 5); - addMorph: (BorderedRectMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #Rect2) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). - pane addMorph: row layoutSpec: (LayoutSpec proportionalHeight: 0.9). - pane morphPosition: 250@130 extent: 400@300. - pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'KenD 5/22/2020 13:55:23' prior: 50360238! - example2 - " - self example2 - " - | pane row | - pane _ (LayoutMorph newColumn separation: 5) name: #example2. - pane color: Color red. - row _ (LayoutMorph newRow separation: 5) name: #Row. - row - color: (Color h: 270 s: 0.2 v: 0.6); - addMorph: (BorderedRectMorph new color: (Color h: 120 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8 offAxisEdgeWeight: #rightOrBottom); - addMorph: (BorderedRectMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8 fixedHeight: 40 offAxisEdgeWeight: #leftOrTop); - addMorph: (BorderedRectMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 0.7 offAxisEdgeWeight: #center). - pane addMorph: row layoutSpec: (LayoutSpec proportionalHeight: 0.9). - pane morphPosition: 200@180 extent: 400@300. - pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'KenD 5/22/2020 13:58:02' prior: 50360293! - example3 - " - self example3 - " - | pane row innerRow | -pane _ (LayoutMorph newColumn separation: 5) name: #example3. - pane color: Color red. - row _ (LayoutMorph newRow separation: 5) name: #Row. - innerRow _ (LayoutMorph newRow separation: 5) name: #InnerRow; - color: Color red. - innerRow - addMorph: (BorderedRectMorph new name: #Box1) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (BorderedRectMorph new name: #Box2) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (BorderedRectMorph new name: #Bar) - layoutSpec: (LayoutSpec proportionalWidth: 1.0 fixedHeight: 10). - row - color: (Color h: 270 s: 0.2 v: 0.6); - addMorph: innerRow - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 30 offAxisEdgeWeight: #center); - addMorph: (BorderedRectMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #Rect1) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40 offAxisEdgeWeight: #leftOrTop); - addMorph: (BorderedRectMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #Rect2) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). - pane addMorph: row layoutSpec: (LayoutSpec proportionalHeight: 0.9). - pane morphPosition: 250@130 extent: 400@300. - pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'KenD 5/22/2020 13:51:32' prior: 50360336! - example6 - " - Useful example contributed by Ken Dickey - All these should look the same, right? (mmmh this should be a test...) - self example6 - " -| pane rect1 rect2 | -pane _ LayoutMorph newRow separation: 5. "1" -pane addMorph: (StringMorph contents: '1'). - -rect1 := BorderedRectMorph new color: (Color lightOrange); - morphExtent: 20 @ 30. -pane addMorphFront: rect1. -rect2 := BorderedRectMorph new color: (Color cyan); - morphExtent: 20 @ 30. -pane addMorphFront: rect2. -pane - color: Color lightGreen; - morphPosition: 120 @ 50 extent: 180 @ 100; - openInWorld. - -pane _ LayoutMorph newRow separation: 5. "2" -pane addMorph: (StringMorph contents: '2'). - -rect1 := BorderedRectMorph new color: (Color lightOrange); - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 offAxisEdgeWeight: #center). -pane addMorph: rect1. -rect2 := BorderedRectMorph new color: (Color cyan). -pane addMorph: rect2 - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 offAxisEdgeWeight: #center). -pane - color: Color lightGreen; - morphPosition: 320 @ 50 extent: 180 @ 100; - openInWorld. - - -pane _ LayoutMorph newRow separation: 5. "3" -pane addMorph: (StringMorph contents: '3'). - -rect1 := BorderedRectMorph new color: (Color lightOrange). -pane addMorph: rect1 - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 offAxisEdgeWeight: #center). -rect2 := BorderedRectMorph new color: (Color cyan); - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 offAxisEdgeWeight: #center). -pane addMorph: rect2. -pane - color: Color lightGreen; - morphPosition: 520 @ 50 extent: 180 @ 100; - openInWorld! ! -!TaskbarMorph methodsFor: 'initialization' stamp: 'KenD 5/22/2020 14:00:30' prior: 50472821 overrides: 16863310! - initialize - super initialize. - viewBox _ LayoutMorph newRow color: self defaultColor. - self - addMorph: UpdatingStringMorph initializedInstance - layoutSpec: (LayoutSpec morphWidthProportionalHeight: 0.5). - self - addMorph: viewBox - layoutSpec: (LayoutSpec - proportionalWidth: 1.0 - proportionalHeight: 1.0 - offAxisEdgeWeight: #rightOrBottom). - viewBox separation: self defaultHeight // 8 -! ! -!LayoutSpec methodsFor: 'accessing' stamp: 'KenD 5/5/2020 08:16:57' prior: 16864181! - fixedOrMorphHeight: aNumber - "aNumber is taken as the fixed height to use. - No proportional part." - fixedHeight - ifNotNil: [ fixedHeight _ aNumber ] - ifNil: [ fixedHeight _ aNumber. - morph morphHeight: aNumber - ]. - proportionalHeight _ nil! ! -!LayoutSpec methodsFor: 'accessing' stamp: 'KenD 5/5/2020 08:17:15' prior: 16864190! - fixedOrMorphWidth: aNumber - "aNumber is taken as the fixed width to use. - No proportional part." - fixedWidth - ifNotNil: [ fixedWidth _ aNumber ] - ifNil: [ fixedWidth _ aNumber. morph morphWidth: aNumber ]. - proportionalWidth _ nil! ! -!LayoutSpec methodsFor: 'layout' stamp: 'KenD 5/5/2020 17:24:59' prior: 50511963! - proportionalLayoutHeight - - ^ proportionalHeight ifNil: [ 0 ]! ! -!LayoutSpec methodsFor: 'deprecated' stamp: 'KenD 5/28/2020 07:28:09' prior: 16864206! - minorDirectionPadding - self flag: #deprecated. - ^minorDirectionPadding! ! -!LayoutSpec methodsFor: 'deprecated' stamp: 'KenD 5/28/2020 07:27:51' prior: 16864210! - minorDirectionPadding: aSymbolOrNumber - "This sets how padding is done in the secondary direction. For instance, if the owning morph is set in a row, the row will control horizontal layout. But if there is unused vertical space, it will be used according to this parameter. For instance, #top sets the owning morph at the top. Same for #bottom and #center. If the owner is contained in a column, #left, #center or #right should be used. Alternatively, any number between 0.0 and 1.0 can be used. - self new minorDirectionPadding: #center - self new minorDirectionPadding: 0.9 - " - self flag: #deprecated. - minorDirectionPadding _ aSymbolOrNumber - caseOf: { - [ #top ] -> [ 0.0 ]. - [ #left ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #right ] -> [ 1.0 ]. - [ #bottom ] -> [ 1.0 ] - } - otherwise: [ aSymbolOrNumber ]! ! -!LayoutSpec methodsFor: '*morphic-misc1' stamp: 'KenD 12/24/2013 15:14' prior: 50508144! - privateFixedHeight - - ^ fixedHeight! ! -!LayoutSpec methodsFor: '*morphic-misc1' stamp: 'KenD 12/24/2013 15:15' prior: 50508148! - privateProportionalHeight - - ^ proportionalHeight! ! -!LayoutSpec class methodsFor: 'deprecated' stamp: 'KenD 5/28/2020 07:29:16' prior: 16864440! - fixedWidth: aNumber fixedHeight: otherNumber minorDirectionPadding: aSymbolOrNumber - self flag: #deprecated. - ^ LayoutSpec new - fixedWidth: aNumber; - fixedHeight: otherNumber; - minorDirectionPadding: aSymbolOrNumber! ! -!LayoutSpec class methodsFor: 'deprecated' stamp: 'KenD 5/28/2020 07:29:23' prior: 16864456! - fixedWidth: aNumber proportionalHeight: otherNumber minorDirectionPadding: aSymbolOrNumber - self flag: #deprecated. - ^self new - fixedWidth: aNumber; - proportionalHeight: otherNumber; - minorDirectionPadding: aSymbolOrNumber! ! -!LayoutSpec class methodsFor: 'deprecated' stamp: 'KenD 5/28/2020 07:29:29' prior: 16864513! - proportionalWidth: aNumber fixedHeight: otherNumber minorDirectionPadding: aSymbolOrNumber - self flag: #deprecated. - ^self new - proportionalWidth: aNumber; - fixedHeight: otherNumber; - minorDirectionPadding: aSymbolOrNumber! ! -!LayoutSpec class methodsFor: 'deprecated' stamp: 'KenD 5/28/2020 07:30:00' prior: 16864529! - proportionalWidth: aNumber proportionalHeight: otherNumber minorDirectionPadding: aSymbolOrNumber - self flag: #deprecated. - ^self new - proportionalWidth: aNumber; - proportionalHeight: otherNumber; - minorDirectionPadding: aSymbolOrNumber! ! -!Theme methodsFor: 'other options' stamp: 'KenD 5/31/2020 08:09:44' prior: 16935688! - layoutAdjusterThickness - - self flag: #todo. "Revisit this; consider moving proportional stuff out of Theme entirely." - - ^ Preferences standardListFont pointSize // 2! ! - -LayoutMorph removeSelector: #proportionalHeightNormalizationFactor! - -!methodRemoval: LayoutMorph #proportionalHeightNormalizationFactor stamp: 'Install-4196-BetterLayoutAlgorithms-KenDickey-2020May29-07h19m-KenD.005.cs.st 6/25/2020 16:06:51'! -proportionalHeightNormalizationFactor - - | sumOfProportional | - sumOfProportional _ self submorphsToLayout sum: [ :m | m layoutSpec proportionaLayoutlHeight ]. - ^1.0 / (sumOfProportional max: 1.0).! - -LayoutMorph removeSelector: #addAllMorphs:! - -LayoutMorph removeSelector: #addAllMorphs:after:! - -LayoutMorph removeSelector: #proportionalWidthNormalizationFactor! - -!methodRemoval: LayoutMorph #proportionalWidthNormalizationFactor stamp: 'Install-4196-BetterLayoutAlgorithms-KenDickey-2020May29-07h19m-KenD.005.cs.st 6/25/2020 16:06:51'! -proportionalWidthNormalizationFactor - - | sumOfProportional | - sumOfProportional _ self submorphsToLayout sum: [ :m | m layoutSpec proportionalLayoutWidth ]. - ^1.0 / (sumOfProportional max: 1.0).! - -Morph removeSelector: #requiredWidthOrSpec! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4196-BetterLayoutAlgorithms-KenDickey-2020May29-07h19m-KenD.005.cs.st----! - -'From Cuis 5.0 [latest update: #4171] on 25 May 2020 at 12:59:52 am'! - -"Change Set: 4192-CuisCore-NahuelGarbezza-2020May27-18h58m -Date: 27 May 2020 -Author: Nahuel Garbezza - -* Fix confusing error message in extract temporary refactoring -* Redefine #asSourceCodeInterval in SourceCodeInterval for performance reasons"! -!SourceCodeInterval methodsFor: 'converting' stamp: 'RNG 5/28/2020 00:00:00' overrides: 50512245! - asSourceCodeInterval - - ^ self! ! -!NewTemporaryPrecondition class methodsFor: 'error messages' stamp: 'RNG 5/28/2020 00:28:53' prior: 50517300! - errorMessageFor: aNewVariable canNotBeNamedDueToInstanceVariableDefinedIn: aClass - - ^ aNewVariable, ' cannot be used as a temporary variable name because it is defined as an instance variable in ', aClass name! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4197-BetterErrorMessage-NahuelGarbezza-2020May27-18h58m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4197] on 1 June 2020 at 8:50:00 pm'! -!LayoutMorph methodsFor: 'adjust' stamp: 'KenD 6/1/2020 20:48:47' prior: 50519957! - adjustHorizontallyBy: aLayoutAdjustMorph at: aPoint - | delta l ls r rs lNewWidth rNewWidth i lCurrentWidth rCurrentWidth | - i _ submorphs indexOf: aLayoutAdjustMorph. - ((i = 1) or: [i = self submorphs size]) ifTrue: [ - self inform: 'LayoutAdjustingMorphs require morphs before and after'. - ^self - ]. - l _ self submorphs at: i +1. - ls _ l layoutSpec. - lCurrentWidth _ l morphWidth max: 1. "avoid division by zero" - r _ self submorphs at: i - 1. - rs _ r layoutSpec. - rCurrentWidth _ r morphWidth max: 1. "avoid division by zero" - delta _ aPoint x - aLayoutAdjustMorph referencePosition x. - delta _ delta max: l minimumShrinkWidth - lCurrentWidth. - delta _ delta min: rCurrentWidth - r minimumShrinkWidth. - delta = 0 ifTrue: [ ^self ]. - rNewWidth _ rCurrentWidth - delta. - lNewWidth _ lCurrentWidth + delta. - (ls isProportionalWidth and: [ rs isProportionalWidth ]) - ifTrue: [ | leftNewProportion rightNewProportion toDistribute | "If both proportional, update them" - leftNewProportion _ lNewWidth / (lNewWidth + rNewWidth). - rightNewProportion _ 1.0 - leftNewProportion. - toDistribute _ ls proportionalLayoutWidth + rs proportionalLayoutWidth. - ls setProportionalWidth: leftNewProportion * toDistribute. - rs setProportionalWidth: rightNewProportion * toDistribute ] - ifFalse: ["If at least one is fixed, update only the fixed" - ls isProportionalWidth ifFalse: [ - ls fixedOrMorphWidth: lNewWidth ]. - rs isProportionalWidth ifFalse: [ - rs fixedOrMorphWidth: rNewWidth ]]. - self layoutSubmorphs.! ! -!LayoutMorph methodsFor: 'adjust' stamp: 'KenD 6/1/2020 20:49:20' prior: 50520003! - adjustVerticallyBy: aLayoutAdjustMorph at: aPoint - | delta t ts b bs tNewHeight bNewHeight i tCurrentHeight bCurrentHeight | - i _ submorphs indexOf: aLayoutAdjustMorph. - ((i = 1) or: [i = self submorphs size]) ifTrue: [ - self inform: 'LayoutAdjustingMorphs require morphs above and below'. - ^self - ]. t _ self submorphs at: i +1. - ts _ t layoutSpec. - tCurrentHeight _ t morphHeight max: 1. "avoid division by zero" - b _ self submorphs at: i - 1. - bs _ b layoutSpec. - bCurrentHeight _ b morphHeight max: 1. "avoid division by zero" - delta _ aPoint y - aLayoutAdjustMorph referencePosition y. - delta _ delta max: t minimumShrinkHeight - tCurrentHeight. - delta _ delta min: bCurrentHeight - b minimumShrinkHeight. - delta = 0 ifTrue: [ ^self ]. - tNewHeight _ tCurrentHeight + delta. - bNewHeight _ bCurrentHeight - delta. - (ts isProportionalHeight and: [ bs isProportionalHeight ]) - ifTrue: [ | bottomNewProportion toDistribute topNewProportion | "If both proportional, update them" - topNewProportion _ tNewHeight / (tNewHeight + bNewHeight). - bottomNewProportion _ 1.0 - topNewProportion. - toDistribute _ ts proportionalLayoutHeight + bs proportionalLayoutHeight. - ts setProportionalHeight: topNewProportion * toDistribute. - bs setProportionalHeight: bottomNewProportion * toDistribute ] - ifFalse: ["If at least one is fixed, update only the fixed" - ts isProportionalHeight ifFalse: [ - ts fixedOrMorphHeight: tNewHeight ]. - bs isProportionalHeight ifFalse: [ - bs fixedOrMorphHeight: bNewHeight ]]. - self layoutSubmorphs! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4198-GuardedAdjuster-KenDickey-2020Jun01-20h40m-KenD.001.cs.st----! - -'From Cuis 5.0 [latest update: #4195] on 1 June 2020 at 9:26:30 am'! -!Form methodsFor: 'other' stamp: 'jmv 5/31/2020 19:00:18'! - divideByAlpha - "Divide each pixel by its alpha. Needed after using rule 24 (alphaBlend) on translucent forms." - - | v a r g b | - depth = 32 ifFalse: [^self]. - 1 to: bits size do: [ :i | - v := bits at: i. - a := v bitShift: -24. - a = 0 ifFalse: [ - r := ((v bitShift: -16) bitAnd: 255) * 255 // a. - g := ((v bitShift: -8) bitAnd: 255) * 255 // a. - b := (v bitAnd: 255) * 255 // a. - bits at: i put: (a bitShift: 24) + (r bitShift: 16) + (g bitShift: 8) + b]].! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 5/31/2020 19:01:47' prior: 16874318! - imageForm: depth - | canvas | - canvas _ BitBltCanvas depth: depth over: (self morphPosition extent: self morphExtent). - canvas fullDraw: self. - ^ canvas form divideByAlpha! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 5/31/2020 19:01:52' prior: 50500291! - imageForm: extent depth: depth - | canvas | - canvas _ BitBltCanvas depth: depth over: (self morphPosition extent: (self morphExtent min: extent)). - canvas fullDraw: self. - ^ canvas form divideByAlpha! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4199-translucent-imageForm-fix-JuanVuletich-2020Jun01-09h25m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4199] on 3 June 2020 at 10:10:23 am'! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/3/2020 10:09:36'! - fromRgbOrRgba: list - ^ list size caseOf: { - [0] -> [ `Color transparent` ]. - [3] -> [ Color r: list first g: list second b: list third ]. - [4] -> [ TranslucentColor r: list first g: list second b: list third alpha: list fourth ] - }! ! -!ColorForm methodsFor: 'fileIn/Out' stamp: 'jmv 6/3/2020 10:06:41'! - colorsFromArray: anArrayOfTriplesOrQuartets - "Set my color palette to the given collection." - - | colorCount newColors | - anArrayOfTriplesOrQuartets ifNil: [ - colors _ cachedDepth _ cachedColormap _ nil. - ^ self]. - - colorCount _ anArrayOfTriplesOrQuartets size. - newColors _ ColorArray new: (1 bitShift: self depth). - 1 to: newColors size do: [:i | - i <= colorCount - ifTrue: [newColors at: i put: (Color fromRgbOrRgba: (anArrayOfTriplesOrQuartets at: i))] - ifFalse: [newColors at: i put: `Color transparent` ]]. - - colors _ newColors. - cachedDepth _ nil. - cachedColormap _ nil. -! ! -!ColorForm methodsFor: 'accessing' stamp: 'jmv 6/3/2020 09:57:14' prior: 50387362! - colors: colorList - "Set my color palette to the given collection." - - | colorArray colorCount newColors | - colorList ifNil: [ - colors _ cachedDepth _ cachedColormap _ nil. - ^ self]. - - colorArray _ colorList asArray. - colorCount _ colorArray size. - newColors _ ColorArray new: (1 bitShift: self depth). - 1 to: newColors size do: [:i | - i <= colorCount - ifTrue: [newColors at: i put: (colorArray at: i)] - ifFalse: [newColors at: i put: `Color transparent` ]]. - - colors _ newColors. - cachedDepth _ nil. - cachedColormap _ nil. -! ! -!ColorForm methodsFor: 'private' stamp: 'jmv 6/3/2020 09:57:24' prior: 16818950! - setColors: colorArray cachedColormap: aBitmap depth: anInteger - "Semi-private. Set the color array, cached colormap, and cached colormap depth to avoid having to recompute the colormap when switching color palettes in animations." - - colors _ colorArray asColorArray. - cachedDepth _ anInteger. - cachedColormap _ aBitmap. -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4200-ColorForm-fix-JuanVuletich-2020Jun03-09h53m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4200] on 3 June 2020 at 10:31:53 am'! -!ImageMorph class methodsFor: 'cached state access' stamp: 'jmv 6/3/2020 10:31:25' prior: 16854167! - defaultForm - " - On an Inspector on the Form, do - self writeBMPfileNamed: 'DefaultForm.bmp' - self writeJPEGfileNamed: 'DefaultForm.jpg' - (Base64MimeConverter mimeEncode: ( 'DefaultForm.jpg' asFileEntry binaryContents readStream)) upToEnd edit - Select all, copy, paste in the String literal in this method. - ImageMorph defaultForm display - " - - DefaultForm ifNotNil: [ ^DefaultForm ]. - DefaultForm _ Form fromBinaryStream: - '/9j/4AAQSkZJRgABAQAAAQABAAD/2wBDAAgGBgcGBQgHBwcJCQgKDBQNDAsLDBkSEw8UHRof -Hh0aHBwgJC4nICIsIxwcKDcpLDAxNDQ0Hyc5PTgyPC4zNDL/2wBDAQkJCQwLDBgNDRgyIRwh -MjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjL/wAAR -CAA5AFUDASIAAhEBAxEB/8QAHwAAAQUBAQEBAQEAAAAAAAAAAAECAwQFBgcICQoL/8QAtRAA -AgEDAwIEAwUFBAQAAAF9AQIDAAQRBRIhMUEGE1FhByJxFDKBkaEII0KxwRVS0fAkM2JyggkK -FhcYGRolJicoKSo0NTY3ODk6Q0RFRkdISUpTVFVWV1hZWmNkZWZnaGlqc3R1dnd4eXqDhIWG -h4iJipKTlJWWl5iZmqKjpKWmp6ipqrKztLW2t7i5usLDxMXGx8jJytLT1NXW19jZ2uHi4+Tl -5ufo6erx8vP09fb3+Pn6/8QAHwEAAwEBAQEBAQEBAQAAAAAAAAECAwQFBgcICQoL/8QAtREA -AgECBAQDBAcFBAQAAQJ3AAECAxEEBSExBhJBUQdhcRMiMoEIFEKRobHBCSMzUvAVYnLRChYk -NOEl8RcYGRomJygpKjU2Nzg5OkNERUZHSElKU1RVVldYWVpjZGVmZ2hpanN0dXZ3eHl6goOE -hYaHiImKkpOUlZaXmJmaoqOkpaanqKmqsrO0tba3uLm6wsPExcbHyMnK0tPU1dbX2Nna4uPk -5ebn6Onq8vP09fb3+Pn6/9oADAMBAAIRAxEAPwD3+iisbxP4ks/C+jvfXWHkJ2W9uGw08nZR -/MnsAT2oA5nxP8UbXwx4oOlXGntJbQxpJc3AnCugfONsePmHT+IHrgHu1fjL4UN2sBOoKu8I -8rWrBUyCQT39OACeRxjJHjHinxJHe64us67KjX0iCOMRR4WNAScADnALHlsnnrgYFe80qC5s -540jUSur7HPJVmOc5+tAH1PYX9pqljDfWNxHcWsy7o5Y2yrD/PFTySJFG0kjqiICzMxwAB1J -NfMfhrXNf0SF5bDWLq1WchzEu1ozwMkI4YKWIJJAB55NP1C9vtXZm1XULq/LNvK3MpaMN6rH -9xT/ALqigD3Sb4ieEYJmifX7QspwdhLD8CAQauaX4w8Oa1P5Gna1ZT3H/PETASHpyEOCRyOc -Yr55AAGAMCmyRpKu10DDryKAPqOivA/D/j/XvDgSIP8A2nYr/wAu11IQ6jGAEk5I7cEEcY4z -ket+GvGmj+KXnisZJY7mEBnt7hNj7f7w5IYZ4yCefqMgHQ0UUUAFfNviK/vr/wAWaodVdjfQ -zvEUIOIow3yIvGNuCD75z3r6SrjfF/w503xXcC8W4m06/wABZLi3APmqOgdTwSOx644zjigD -wyW3gnZGmhjkKHKF1B2n1GelSV0XjD4fa34VsItQt72PUbVFP2t/s/liHnhiN5IXHBbJx1Ix -05Lzb2QYS3ij/wBt5Nwx7ADn9KAJ5ZkhVS+fmZUAHUknFSVXhtdriWaQzSjozAAL/ujt/P3q -xQAUUUUAFTWmoXOkX9vqdmC1zaOJUUHG/HVeo4YZH41DRQB9NWV5b6jYW99aSCW2uYlmikAI -DIwyDz6giiub+Gs3nfD3SP8AWYiR4Bv64jkZBj2wvHtiigDq6KKKAEZVdSrAFSMEEcEV8za7 -p58O6/qWkRxNLFZXBjTY2SsTKskY55JCOoPfIPWvpiSRIo2kkdURAWZmOAAOpJrwNLT/AITn -4n30cMhW3vLqSSSeEZAt4QsQdW5HzhEIJ4+fPtQBzMU0cy7o3DD9R9R2p9dV8Thoenavp9to -8US/YrFxciAbgQSvlKTzlwFfrz8wJzkV3WifC/w7aaRE2sWCXl+yB7medj8pxkqMHAVeQB+J -JJJIB43UYuIWnaASp5q8lM/Nj1x6V6RqNx8IJHuIlwjsxzcada3LKDnPyPGpQj6ZHavMtZm0 -eXU7i10aO/1KziAKPdRKjh+cjdwOOMHCn2JGaALNM0qz1DVtWGj6apubmYZikYfLHyQTIQOF -X169RycZghvLZtL8pbC4i1G2QCa5F/5sHqTIpT5SFzwGHIHOM16J8MtF1+28Sw6lb2clrpNz -ETdyyIqi4XafL2g/NncwO4DBAOSeKAPWtH0yDRdGstMts+TaQrCpPVtoxk+56n3NFXaKACii -igDmvGPgy18a2dtZ3t/eW1tC5kZLYqPMOMDO5WHHUcflVTRPhtoWg2d7DbyX00t5ataS3U9w -TL5ZGCFIACnvkDORXYUUAef6b8HfDGmzxyK+ozrHL5qxzXPycNuC4AGQD/LnNd9JGksbRyIr -o4KsrDIIPUEU6igDn/8AhBfCO3b/AMItopXOQDYREA8dBt46CiTwL4SleNn8M6QfLBCr9jj2 -9AOVxg8DjPTtXQUUAZ+maFo+ieb/AGTpVjYedjzPslukW/GcZ2gZxk9fU1oUUUAFFFFAH//Z' - base64Decoded asByteArray readStream. - ^DefaultForm! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4201-defaultForm-fixComment-JuanVuletich-2020Jun03-10h23m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4200] on 3 June 2020 at 1:39:17 pm'! -!CodeWindow methodsFor: 'keyboard shortcuts' stamp: 'len 5/31/2020 06:15:22' prior: 50436765! - messageCatListKey: aChar from: view - - aChar == $o ifTrue: [^ model fileOutMessageCategories ]. - aChar == $t ifTrue: [^ model runMessageCategoryTests ]. - aChar == $x ifTrue: [^ model removeMessageCategory ]. - aChar == $R ifTrue: [ ^model renameCategory ]. - aChar == $n ifTrue: [^model addCategory ]. - aChar == $e ifTrue: [^model removeEmptyCategories ]. - aChar == $c ifTrue: [^model categorizeAllUncategorizedMethods ]. - aChar == $a ifTrue: [ ^ model alphabetizeMessageCategories ]. - aChar == $r ifTrue: [ ^ model editMessageCategories ]! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'len 5/31/2020 06:14:40' prior: 50436782! - messageCategoryMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'fileOut (o)'. - #object -> #model. - #selector -> #fileOutMessageCategories. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'reorganize (r)'. - #object -> #model. - #selector -> #editMessageCategories. - #icon -> #sendReceiveIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'alphabetize (a)'. - #object -> #model. - #selector -> #alphabetizeMessageCategories. - #icon -> #fontXGenericIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'remove empty categories (e)'. - #object -> #model. - #selector -> #removeEmptyCategories. - #icon -> #listRemoveIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 40. - #label -> 'categorize all uncategorized (c)'. - #object -> #model. - #selector -> #categorizeAllUncategorizedMethods. - #icon -> #packageIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 50. - #label -> 'new category... (n)'. - #object -> #model. - #selector -> #addCategory. - #icon -> #newIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'rename... (R)'. - #object -> #model. - #selector -> #renameCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'remove (x)'. - #object -> #model. - #selector -> #removeMessageCategory. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'run tests (t)'. - #object -> #model. - #selector -> #runMessageCategoryTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - }`. - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4202-MessageCategoriesShortcuts-LucianoEstebanNotarfrancesco-2020Jun03-13h37m-len.001.cs.st----! - -'From Cuis 5.0 [latest update: #4200] on 3 June 2020 at 1:37:27 pm'! -!HaloMorph methodsFor: 'private' stamp: 'len 6/3/2020 13:07:09' prior: 50388435! - addNameString: aString - "Add a name display centered beneath the bottom of the outer rectangle. Return the handle." - - | nameMorph verticalNamePosition namePosition nameBackground | - nameBackground _ RectangleLikeMorph new - color: ((target is: #SystemWindow) ifTrue: [target windowColor] ifFalse: [`Color lightBlue alpha: 0.9`]). - nameMorph _ StringMorph contents: aString. - nameMorph color: `Color black`. - nameBackground morphExtent: nameMorph morphExtent + 4. - verticalNamePosition _ haloBox bottom + self class handleSize. - self world ifNotNil: [:w| verticalNamePosition + nameMorph morphHeight > w morphHeight ifTrue: [verticalNamePosition _ haloBox bottom - nameMorph morphHeight - self class handleSize]]. - namePosition _ haloBox width - nameMorph morphWidth // 2 + haloBox left @ verticalNamePosition. - self addMorph: nameBackground. - nameBackground morphPositionInWorld: namePosition - 2. - self addMorph: nameMorph. - nameMorph morphPositionInWorld: namePosition. - ^nameMorph! ! -!HaloMorph methodsFor: 'stepping' stamp: 'len 6/3/2020 13:09:52' prior: 50332875 overrides: 16876533! - step - self comeToFront. - (target isNil or: [target isInWorld not]) ifTrue: [self delete]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4203-HaloFixes-LucianoEstebanNotarfrancesco-2020Jun03-13h36m-len.001.cs.st----! - -'From Cuis 5.0 [latest update: #4203] on 3 June 2020 at 2:26:53 pm'! -!Point methodsFor: 'testing' stamp: 'jmv 6/3/2020 11:55:20'! - isIntegerPoint - ^x isInteger and:[y isInteger]! ! -!Rectangle methodsFor: 'truncation and round off' stamp: 'jmv 6/3/2020 11:56:00'! - encompassingIntegerRectangle - "Answer a Rectangle whose origin and corner are integer, and that completely includes the receiver." - - (origin isIntegerPoint and: [ corner isIntegerPoint ]) ifTrue: [ ^self ]. - ^Rectangle origin: origin floor corner: self corner ceiling! ! -!Rectangle class methodsFor: 'instance creation' stamp: 'jmv 6/3/2020 14:23:25'! -encompassingInteger: listOfPoints - "Like #encompassing:, but with integer coordinates." - | topLeft bottomRight | - topLeft _ bottomRight _ nil. - listOfPoints do: [ :p | - topLeft - ifNil: [ - topLeft _ p floor. - bottomRight _ p ceiling] - ifNotNil: [ - topLeft _ topLeft min: p floor. - bottomRight _ bottomRight max: p ceiling]]. - ^ topLeft corner: bottomRight! ! -!AffineTransformation methodsFor: 'transforming rects' stamp: 'jmv 6/3/2020 11:45:09' prior: 50384126! - displayBoundsOfTransformOf: aRectangle - "Externalize aRectangle, and find a bounding rectangle with horizontal - and vertical bounds and integer coordinates (i.e. adisplayBounds)." - - ^Rectangle encompassingInteger: (aRectangle corners collect: [ :pt | - self transform: pt ])! ! -!MorphicTranslation methodsFor: 'transforming rects' stamp: 'jmv 6/3/2020 11:45:54' prior: 50419064! - displayBoundsOfTransformOf: aRectangle - "Externalize aRectangle, and find a bounding rectangle with horizontal - and vertical bounds and integer coordinates (i.e. adisplayBounds)." - - ^(aRectangle translatedBy: self translation) encompassingIntegerRectangle! ! -!DamageRecorder methodsFor: 'private' stamp: 'jmv 6/3/2020 11:56:09' prior: 50462515! - pvtInnerRecordInvalidRect: requestedRect - "Record the given rectangle in my damage list, a list of rectangular areas of the display that should be redraw on the next display cycle. - Rectangles are specified in world coordinates (might be not the same as Display coordinates if there is some origin set on some canvas. Usually there will be none, but we can't be sure) - " - "Details: Damaged rectangles are often identical or overlap significantly. In these cases, we merge them to reduce the number of damage rectangles that must be processed when the display is updated. Moreover, above a certain threshold, we ignore the individual rectangles completely, and simply do a complete repaint on the next cycle. - jmv: Important. There should be no overlapping rectangles in the list. If there are, translucent morphs might be drawn several times, with visible defects. - WRT performance, the different paths for various intersections seem a bit complicated. I could not find strong evidence of the best way. - Leave it as it is right now." - | newRect mergeRect indexToReuse | - totalRepaint ifTrue: [ ^ self ]. - "planning full repaint; don't bother collecting damage" - indexToReuse _ nil. - newRect _ requestedRect encompassingIntegerRectangle. - invalidRects withIndexDo: [ :oldRect :index | - oldRect - ifNil: [ indexToReuse ifNil: [ indexToReuse _ index ]] - ifNotNil: [ - "No two rectangles should intersect" - (oldRect intersects: newRect) ifTrue: [ - "newRect already in. Nothing to do then." - (oldRect containsRect: newRect) ifTrue: [ ^ self ]. - "Some oldRect included in newRect. Remove it and continue, as newRect could still intersect others." - (newRect containsRect: oldRect) ifTrue: [ - invalidRects - at: index - put: nil. - "Effectively like 'invalidRects remove: rect', but without performance penalty." - indexToReuse ifNil: [ indexToReuse _ index ]]. - "Merge rectangles if they overlap significantly, i.e. if the merge is not much larger than separated rectangles." - mergeRect _ (oldRect origin min: newRect origin) corner: (oldRect corner max: newRect corner). - mergeRect area > (newRect area + oldRect area * 2) - ifTrue: [ - "Avoid intersections!!" - newRect - areasOutside: oldRect - do: [ :nonIntersection | - "We have brand new newRects. Start all over with each of them." - self pvtInnerRecordInvalidRect: nonIntersection ]. - "newRect no longer needed, then." - ^ self ] - ifFalse: [ - "Merge into newRect, as any overlap with forecoming rectangles in the iteration is detected and treated." - newRect _ mergeRect. - invalidRects - at: index - put: nil. - "Effectively like 'invalidRects remove: rect', but without performance penalty." - indexToReuse ifNil: [ indexToReuse _ index ]]]]]. - invalidRects size >= 10 ifTrue: [ - "if there are too many separate areas, merge them all" - mergeRect _ Rectangle merging: invalidRects. - self pvtReset. - mergeRect ifNotNil: [ invalidRects addLast: mergeRect ]. - indexToReuse _ nil ]. - "Add the given rectangle to the damage list" - indexToReuse - ifNil: [ invalidRects addLast: newRect ] - ifNotNil: [ - invalidRects - at: indexToReuse - put: newRect ].! ! - -AffineTransformation removeSelector: #primDisplayBoundsOfTransformOf:into:! - -!methodRemoval: AffineTransformation #primDisplayBoundsOfTransformOf:into: stamp: 'Install-4204-DrawingArtifactsFix-JuanVuletich-2020Jun03-14h21m-jmv.001.cs.st 6/25/2020 16:06:51'! -primDisplayBoundsOfTransformOf: srcRect into: dstRect - "Externalize srcRect, and find a bounding rectangle with horizontal and vertical bounds and integer coordinates (i.e. adisplayBounds). - Store result into dstRect." - - "Warning: the answer is rounded to integers by the primitive - Warning: if answer is not strictly positive, it is off by one. Evaluate: - - AffineTransformation new primDisplayBoundsOfTransformOf: (-2@ 2 extent: 10@10) into: Rectangle new - AffineTransformation new primDisplayBoundsOfTransformOf: (-12@ 12 extent: 10@10) into: Rectangle new - (AffineTransformation withTranslation: 2) primDisplayBoundsOfTransformOf: (-4@ 2 extent: 10@10) into: Rectangle new - (AffineTransformation withTranslation: -4) primDisplayBoundsOfTransformOf: (2@ 2 extent: 10@10) into: Rectangle new - (AffineTransformation withTranslation: 2) primDisplayBoundsOfTransformOf: (-14@ 2 extent: 10@10) into: Rectangle new - (AffineTransformation withTranslation: 4) primDisplayBoundsOfTransformOf: (-12@ 2 extent: 10@10) into: Rectangle new - (AffineTransformation withTranslation: -4) primDisplayBoundsOfTransformOf: (12@ 2 extent: 10@10) into: Rectangle new - - These are Ok (answer is positive) - (AffineTransformation withTranslation: -2) primDisplayBoundsOfTransformOf: (4@ 2 extent: 10@10) into: Rectangle new - (AffineTransformation withTranslation: 4) primDisplayBoundsOfTransformOf: (-2@ 2 extent: 10@10) into: Rectangle new - " - - - ^nil! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4204-DrawingArtifactsFix-JuanVuletich-2020Jun03-14h21m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4204] on 4 June 2020 at 9:32:52 pm'! -!Form methodsFor: 'fileIn/Out' stamp: 'jmv 6/4/2020 21:30:35' prior: 16847841! - storeOn: aStream base: anInteger - "Store the receiver out as an expression that can be evaluated to recreate a Form with the same contents as the original." - - aStream nextPut: $(. - aStream nextPutAll: self species name. - aStream newLineTab: 1. - aStream nextPutAll: 'extent: '. - self extent printOn: aStream. - aStream newLineTab: 1. - aStream nextPutAll: 'depth: '. - self nativeDepth printOn: aStream. - aStream newLineTab: 1. - aStream nextPutAll: 'fromArray: #('. - self storeBitsOn:aStream base:anInteger. - aStream nextPut: $). - aStream newLineTab: 1. - aStream nextPutAll: 'offset: '. - self offset printOn: aStream. - aStream nextPut: $). -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4205-FormSerializationFix-JuanVuletich-2020Jun04-20h27m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4204] on 4 June 2020 at 2:26:09 pm'! - -RectangleLikeMorph subclass: #LayoutMorph - instanceVariableNames: 'direction separation padding doAdoptWidgetsColor axisEdgeWeight ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -!classDefinition: #LayoutMorph category: #'Morphic-Layouts' stamp: 'Install-4206-LayoutCleanup-KenDickey-2020Jun04-13h11m-KenD.003.cs.st 6/25/2020 16:06:52'! -RectangleLikeMorph subclass: #LayoutMorph - instanceVariableNames: 'direction separation padding doAdoptWidgetsColor axisEdgeWeight' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -Object subclass: #LayoutSpec - instanceVariableNames: 'morph fixedWidth fixedHeight minorDirectionPadding proportionalWidth proportionalHeight offAxisEdgeWeight ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -!classDefinition: #LayoutSpec category: #'Morphic-Layouts' stamp: 'Install-4206-LayoutCleanup-KenDickey-2020Jun04-13h11m-KenD.003.cs.st 6/25/2020 16:06:52'! -Object subclass: #LayoutSpec - instanceVariableNames: 'morph fixedWidth fixedHeight minorDirectionPadding proportionalWidth proportionalHeight offAxisEdgeWeight' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! -!LayoutMorph methodsFor: 'accessing' stamp: 'KenD 6/4/2020 13:11:42' prior: 50519300! - axisEdgeWeight - - ^ axisEdgeWeight! ! -!LayoutMorph methodsFor: 'accessing' stamp: 'KenD 6/4/2020 13:11:42' prior: 50519304! - axisEdgeWeight: aSymbolOrNumber - "Along the Major or Layout Axis, subMorphs may be attracted toward one side (0.0) or the other (1.0). This is the LayoutMorph's axisEdgeWeight. A numeric value is between 0.0 and 1.0 - - If a Row, one can specify this weight symbolically as - { #rowLeft (0.0), #center (0.5), #rowRight (1.0)} - - If a Column, one can specify the weight symbolically as: - { #columnTop (0.0), #center (0.5), #columnBottom (1.0) }" -" - self axisEdgeWeight: #rowLeft. -- axis must be horizontal - self axisEdgeWeight: #columnTop. -- axis must be vertical -" - | edgeWeight | - (aSymbolOrNumber is: #Number) - ifTrue: [ (aSymbolOrNumber between: 0.0 and: 1.0) - ifTrue: [edgeWeight := aSymbolOrNumber ] - ifFalse: [self error: 'axisEdgeWeight ', aSymbolOrNumber printString, ' is out of range 0.0 to 1.0'] - ] - ifFalse: [ - (self direction = #horizontal) - ifTrue: [ "Row" - edgeWeight := aSymbolOrNumber - caseOf: { - [ #rowLeft ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #rowRight ] -> [ 1.0 ] - } - otherwise: [ self error: 'bad axisEdgeWeight for Row: ', aSymbolOrNumber printString ]. - ] - ifFalse: [ "vertical => Column" - edgeWeight := aSymbolOrNumber - caseOf: { - [ #columnTop ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #columnBottom ] -> [ 1.0 ] - } - otherwise: [ self error: 'bad axisEdgeWeight for Column: ', aSymbolOrNumber printString ]. - ] - ]. - axisEdgeWeight := edgeWeight. - "self layoutSubmorphs"! ! -!LayoutMorph methodsFor: 'accessing' stamp: 'KenD 6/4/2020 13:13:50' prior: 50519674! - direction: horizOrVert - - direction := horizOrVert! ! -!LayoutMorph methodsFor: 'initialization' stamp: 'KenD 6/4/2020 14:22:33' prior: 16863310 overrides: 50384234! - initialize - super initialize. - separation _ 0. - axisEdgeWeight _ 0.0. - doAdoptWidgetsColor _ false! ! -!LayoutMorph methodsFor: 'layout' stamp: 'KenD 6/4/2020 14:25:55' prior: 50520127! - layoutSubmorphsHorizontallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - - | visibleSubmorphs sumOfWidths theSeparation widthsArray - widthToAllocate leftOver nextX | - "Preconditions: self isRow & morphExtent >= minimumLayoutExtent" - visibleSubmorphs := self submorphsToLayout reversed. "Display Order" - theSeparation := self xSeparation. - - widthToAllocate := (boundsForLayout width - ((visibleSubmorphs size + 1) * theSeparation)). - widthsArray := self widthsFor: visibleSubmorphs within: widthToAllocate. - sumOfWidths := widthsArray sum: [ :w | w ] . - leftOver := widthToAllocate - sumOfWidths. - nextX := boundsForLayout origin x - + theSeparation - + (leftOver * (self axisEdgeWeight ifNil: [0.0])). "first X, edge shifted" -"Transcript log: 'first X=', nextX asString, ' leftOver=', leftOver asString; cr. -" 1 to: visibleSubmorphs size do: [ :index | | sm smX smWidth heightAndY newExtent | - sm := visibleSubmorphs at: index. - smX := nextX. - smWidth := widthsArray at: index. - nextX := smX + smWidth + theSeparation. - heightAndY := self offHorizontalMetricFor: sm withinExtent: boundsForLayout. - sm morphPosition: smX @ (heightAndY y). - newExtent := smWidth @ (heightAndY x). - (sm morphExtent = newExtent) ifFalse: [ sm morphExtent: newExtent ]. - ] -! ! -!LayoutMorph methodsFor: 'layout' stamp: 'KenD 6/4/2020 14:26:19' prior: 50520170! - layoutSubmorphsVerticallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - - | visibleSubmorphs sumOfHeights theSeparation heightsArray - heightToAllocate leftOver nextY | - "Preconditions: self isRow & morphExtent >= minimumLayoutExtent" - visibleSubmorphs := self submorphsToLayout reversed. "Display Order" - - theSeparation := self ySeparation. - heightToAllocate := (boundsForLayout height - ((visibleSubmorphs size + 1) * theSeparation)). - heightsArray := self heightsFor: visibleSubmorphs within: heightToAllocate. - sumOfHeights := heightsArray sum: [ :w | w ] . - leftOver := heightToAllocate - sumOfHeights. - nextY := boundsForLayout origin y - + theSeparation - + (leftOver * (self axisEdgeWeight ifNil: [0.5])). "first Y, edge shifted" -"Transcript log: 'first Y=', nextY asString, ' leftOver=', leftOver asString; cr. -" 1 to: visibleSubmorphs size do: [ :index | | sm smY smHeight xAndWidth newExtent | - sm := visibleSubmorphs at: index. - smY := nextY. - smHeight := heightsArray at: index. - nextY := smY + smHeight + theSeparation. - xAndWidth := self offVerticalMetricFor: sm withinExtent: boundsForLayout. - sm morphPosition: (xAndWidth x) @ smY. - newExtent := (xAndWidth y) @ smHeight. - (sm morphExtent = newExtent) ifFalse: [ sm morphExtent: newExtent ]. - ] -! ! -!LayoutMorph methodsFor: 'layout' stamp: 'KenD 6/4/2020 14:21:05' prior: 50519462! - offHorizontalMetricFor: aMorph withinExtent: boundsForLayout - "Answer a point: height@y for a single morph -- offAxis calculation for a Row" - - | spec minMorphHeight theSeparation proportionalHeight - availableForPropHeight actualPropHeight - leftOver yPos | - spec := aMorph layoutSpec. - theSeparation := self ySeparation. - minMorphHeight := aMorph minimumLayoutHeight. - availableForPropHeight := (boundsForLayout height) - (2 * theSeparation).. - proportionalHeight := spec proportionalLayoutHeight min: 1.0. - actualPropHeight := (availableForPropHeight * proportionalHeight) - max: minMorphHeight. - leftOver := availableForPropHeight - actualPropHeight. - - yPos := boundsForLayout origin y - + theSeparation - + (leftOver * (spec offAxisEdgeWeight ifNil: [0.5])). "first Y, edge shifted" - - ^ actualPropHeight @ yPos - - ! ! -!LayoutMorph methodsFor: 'layout' stamp: 'KenD 6/4/2020 14:21:30' prior: 50519490! - offVerticalMetricFor: aMorph withinExtent: boundsForLayout - "Answer a point: x@width for a single morph -- offAxis calculation for a Column" - - | spec minMorphWidth theSeparation proportionalWidth - availableForPropWidth actualPropWidth - leftOver xPos | - spec := aMorph layoutSpec. - theSeparation := self xSeparation. - minMorphWidth := aMorph minimumLayoutWidth. - availableForPropWidth := (boundsForLayout width) - (2 * theSeparation). - proportionalWidth := spec proportionalLayoutWidth min: 1.0. - actualPropWidth := (availableForPropWidth * proportionalWidth) - max: minMorphWidth. - leftOver := availableForPropWidth - actualPropWidth. - - xPos := boundsForLayout origin x - + theSeparation - + (leftOver * (spec offAxisEdgeWeight ifNil: [0.5])). "first X, edge shifted" - - ^ xPos @ actualPropWidth - ! ! -!LayoutMorph methodsFor: 'deprecated' stamp: 'KenD 6/4/2020 13:14:39' prior: 50519670! - padding - - self flag: #deprecated. "use axisEdgeWeight" - ^ axisEdgeWeight! ! -!LayoutMorph methodsFor: 'deprecated' stamp: 'KenD 6/4/2020 13:14:22' prior: 50520239! - padding: aSymbolOrNumber - "This sets how extra space is used when doing layout. For example, a column might have extra , unneded vertical space. #top means widgets are set close to the top, and extra space is at bottom. Conversely, #bottom means widgets are set close to the bottom, and extra space is at top. Valid values include #left and #right (for rows) and #center. Alternatively, any number between 0.0 and 1.0 might be used. - self new padding: #center - self new padding: 0.9 - " - self flag: #deprecated. "use axisEdgeWeight:" - axisEdgeWeight _ aSymbolOrNumber - caseOf: { - [ #top ] -> [ 0.0 ]. - [ #left ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #right ] -> [ 1.0 ]. - [ #bottom ] -> [ 1.0 ] - } - otherwise: [ aSymbolOrNumber ]! ! -!LayoutSpec methodsFor: 'initialization' stamp: 'KenD 6/4/2020 13:11:57' prior: 16864165 overrides: 16896425! - initialize - "Just some reasonable defaults, use all available space" - offAxisEdgeWeight _ 0.5. - fixedWidth _ 0. - fixedHeight _ 0. - proportionalWidth _ 1.0. - proportionalHeight _ 1.0! ! -!LayoutSpec methodsFor: 'accessing' stamp: 'KenD 6/4/2020 13:14:56' prior: 50519771! - morph - "For #showHalo" - ^ morph! ! -!LayoutSpec methodsFor: 'accessing' stamp: 'KenD 6/4/2020 13:11:57' prior: 50519680! - offAxisEdgeWeight - ^offAxisEdgeWeight! ! -!LayoutSpec methodsFor: 'accessing' stamp: 'KenD 6/4/2020 13:11:57' prior: 50519684! - offAxisEdgeWeight: aSymbolOrNumber - "A LayoutSpec may indicate a weighting perpendicular to the Layout Axis. - - This is the LayoutSpec's offAxisEdgeWeight which is between 0.0 and 1.0. - - As with LayoutSpec's a symbol may be used. - - If in a Row (preferred): { #rowTop (0.0), #center (0.5), #rowBottom (1.0)} - - If in a Column (preferred): { #columnLeft (0.0), #center (0.5), #columnRight (1.0) } - - Also accepted: { #leftOrTop (0.0), #center (0.5), #rightOrBottom (1.0) } - " - | edgeWeight | - edgeWeight := (aSymbolOrNumber is: #Number) - ifTrue: [ (aSymbolOrNumber between: 0.0 and: 1.0) - ifTrue: [ aSymbolOrNumber ] - ifFalse: [self error: 'axisEdgeWeight ', aSymbolOrNumber printString, ' is out of range 0.0 to 1.0'] - ] - ifFalse: [ aSymbolOrNumber - caseOf: { - [ #leftOrTop ] -> [ 0.0 ]. - [ #rowTop ] -> [ 0.0 ]. - [ #columnLeft ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #rightOrBottom ] -> [ 1.0 ]. - [ #rowBottom ] -> [ 1.0 ]. - [ #columnRight ] -> [ 1.0 ] - } - otherwise: [ self error: 'bad offAxisEdgeWeight specifier: ', aSymbolOrNumber printString ] - ]. - offAxisEdgeWeight _ edgeWeight! ! -!LayoutSpec methodsFor: 'deprecated' stamp: 'KenD 6/4/2020 13:16:05' prior: 50520481! - minorDirectionPadding - self flag: #deprecated. "use offAxisEdgeWeight" - ^offAxisEdgeWeight! ! -!LayoutSpec methodsFor: 'deprecated' stamp: 'KenD 6/4/2020 13:15:55' prior: 50520487! - minorDirectionPadding: aSymbolOrNumber - "This sets how padding is done in the secondary direction. For instance, if the owning morph is set in a row, the row will control horizontal layout. But if there is unused vertical space, it will be used according to this parameter. For instance, #top sets the owning morph at the top. Same for #bottom and #center. If the owner is contained in a column, #left, #center or #right should be used. Alternatively, any number between 0.0 and 1.0 can be used. - self new minorDirectionPadding: #center - self new minorDirectionPadding: 0.9 - " - self flag: #deprecated. "use offAxisEdgeWeight:" - offAxisEdgeWeight _ aSymbolOrNumber - caseOf: { - [ #top ] -> [ 0.0 ]. - [ #left ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #right ] -> [ 1.0 ]. - [ #bottom ] -> [ 1.0 ] - } - otherwise: [ aSymbolOrNumber ]! ! - -RectangleLikeMorph subclass: #LayoutMorph - instanceVariableNames: 'direction separation axisEdgeWeight doAdoptWidgetsColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -!classDefinition: #LayoutMorph category: #'Morphic-Layouts' stamp: 'Install-4206-LayoutCleanup-KenDickey-2020Jun04-13h11m-KenD.003.cs.st 6/25/2020 16:06:52'! -RectangleLikeMorph subclass: #LayoutMorph - instanceVariableNames: 'direction separation axisEdgeWeight doAdoptWidgetsColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -Object subclass: #LayoutSpec - instanceVariableNames: 'morph fixedWidth fixedHeight offAxisEdgeWeight proportionalWidth proportionalHeight' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -!classDefinition: #LayoutSpec category: #'Morphic-Layouts' stamp: 'Install-4206-LayoutCleanup-KenDickey-2020Jun04-13h11m-KenD.003.cs.st 6/25/2020 16:06:52'! -Object subclass: #LayoutSpec - instanceVariableNames: 'morph fixedWidth fixedHeight offAxisEdgeWeight proportionalWidth proportionalHeight' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4206-LayoutCleanup-KenDickey-2020Jun04-13h11m-KenD.003.cs.st----! - -'From Cuis 5.0 [latest update: #4202] on 3 June 2020 at 3:28:27 pm'! -!LayoutMorph methodsFor: 'accessing' stamp: 'KenD 6/2/2020 19:15:47' prior: 50521413! - axisEdgeWeight: aSymbolOrNumber - "Along the Major or Layout Axis, subMorphs may be attracted toward one side (0.0) or the other (1.0). This is the LayoutMorph's axisEdgeWeight. A numeric value is between 0.0 and 1.0 - - If a Row, one can specify this weight symbolically as - { #rowLeft (0.0), #center (0.5), #rowRight (1.0)} - - If a Column, one can specify the weight symbolically as: - { #columnTop (0.0), #center (0.5), #columnBottom (1.0) }" -" - self axisEdgeWeight: #rowLeft. -- axis must be horizontal - self axisEdgeWeight: #columnTop. -- axis must be vertical -" - | edgeWeight | - (aSymbolOrNumber is: #Number) - ifTrue: [ (aSymbolOrNumber between: 0.0 and: 1.0) - ifTrue: [edgeWeight := aSymbolOrNumber ] - ifFalse: [self error: 'axisEdgeWeight ', aSymbolOrNumber printString, ' is out of range 0.0 to 1.0'] - ] - ifFalse: [ - (self direction = #horizontal) - ifTrue: [ "Row" - edgeWeight := aSymbolOrNumber - caseOf: { - [ #rowLeft ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #rowRight ] -> [ 1.0 ] - } - otherwise: [ self error: 'bad axisEdgeWeight for Row: ', aSymbolOrNumber printString ]. - ] - ifFalse: [ "vertical => Column" - edgeWeight := aSymbolOrNumber - caseOf: { - [ #columnTop ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #columnBottom ] -> [ 1.0 ] - } - otherwise: [ self error: 'bad axisEdgeWeight for Column: ', aSymbolOrNumber printString ]. - ] - ]. - axisEdgeWeight := edgeWeight. - self layoutSubmorphs! ! -!LayoutMorph methodsFor: 'accessing' stamp: 'KenD 6/2/2020 19:16:08' prior: 16863037! - separation: aNumberOrPoint - separation _ aNumberOrPoint. - self layoutSubmorphs! ! - -LayoutSpec removeSelector: #widthFor:! - -!methodRemoval: LayoutSpec #widthFor: stamp: 'Install-4207-LayoutUpdate-KenDickey-2020Jun02-18h41m-KenD.001.cs.st 6/25/2020 16:06:52'! -widthFor: availableSpace - "If proportional is zero, answer stored fixed extent, or actual morph extent if undefined. - Otherwise, we do proportional layout, and the stored extent is a minimum extent. - If there is no minimum extent, it should be set to zero." - - ^proportionalWidth isNil - ifTrue: [fixedWidth ifNil: [morph morphWidth]] - ifFalse: [proportionalWidth * availableSpace + morph minimumLayoutExtent x]! - -LayoutSpec removeSelector: #widthForComfortable:! - -!methodRemoval: LayoutSpec #widthForComfortable: stamp: 'Install-4207-LayoutUpdate-KenDickey-2020Jun02-18h41m-KenD.001.cs.st 6/25/2020 16:06:52'! -widthForComfortable: availableSpace - "Similar to #widthFor:. To be used when we know availableSpace is more than the minimum required to apply proportional layout and still get more than our minimum. See senders." - - ^proportionalWidth isNil - ifTrue: [fixedWidth ifNil: [morph morphWidth]] - ifFalse: [proportionalWidth * availableSpace]! - -LayoutMorph removeSelector: #desiredLayoutWidth! - -!methodRemoval: LayoutMorph #desiredLayoutWidth stamp: 'Install-4207-LayoutUpdate-KenDickey-2020Jun02-18h41m-KenD.001.cs.st 6/25/2020 16:06:52'! -desiredLayoutWidth - - | fixed proportional | - proportional _ 0. - fixed _ 0. - self submorphsToLayout do: [ :m | | ls | - ls _ m layoutSpec. - ls isProportionalWidth ifTrue: [ - proportional _ proportional max: ls fixedOrMinimumLayoutWidth / ls proportionalLayoutWidth ] - ifFalse: [ - fixed _ fixed + ls fixedOrMinimumLayoutWidth ]]. - ^fixed + proportional! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4207-LayoutUpdate-KenDickey-2020Jun02-18h41m-KenD.001.cs.st----! - -'From Cuis 5.0 [latest update: #4206] on 4 June 2020 at 6:40:09 pm'! -!LayoutMorph methodsFor: 'accessing' stamp: 'KenD 6/4/2020 18:28:12' prior: 50521787! - axisEdgeWeight: aSymbolOrNumber - "Along the Major or Layout Axis, subMorphs may be attracted toward one side (0.0) or the other (1.0). This is the LayoutMorph's axisEdgeWeight. A numeric value is between 0.0 and 1.0 - - If a Row, one can specify this weight symbolically as - { #rowLeft (0.0), #center (0.5), #rowRight (1.0)} - - If a Column, one can specify the weight symbolically as: - { #columnTop (0.0), #center (0.5), #columnBottom (1.0) }" -" - self axisEdgeWeight: #rowLeft. -- axis must be horizontal - self axisEdgeWeight: #columnTop. -- axis must be vertical -" - | edgeWeight | - (aSymbolOrNumber is: #Number) - ifTrue: [ (aSymbolOrNumber between: 0.0 and: 1.0) - ifTrue: [edgeWeight := aSymbolOrNumber ] - ifFalse: [self error: 'axisEdgeWeight ', aSymbolOrNumber printString, ' is out of range 0.0 to 1.0'] - ] - ifFalse: [ - (self direction = #horizontal) - ifTrue: [ "Row" - edgeWeight := aSymbolOrNumber - caseOf: { - [ #rowLeft ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #rowRight ] -> [ 1.0 ] - } - otherwise: [ self error: 'bad axisEdgeWeight for Row: ', aSymbolOrNumber printString ]. - ] - ifFalse: [ "vertical => Column" - edgeWeight := aSymbolOrNumber - caseOf: { - [ #columnTop ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #columnBottom ] -> [ 1.0 ] - } - otherwise: [ self error: 'bad axisEdgeWeight for Column: ', aSymbolOrNumber printString ]. - ] - ]. - axisEdgeWeight := edgeWeight. - self layoutSubmorphs! ! -!LayoutMorph methodsFor: 'accessing' stamp: 'KenD 6/4/2020 18:27:53' prior: 50521837! - separation: aNumberOrPoint - separation _ aNumberOrPoint. - self layoutSubmorphs ! ! -!LayoutSpec class methodsFor: 'deprecated' stamp: 'KenD 6/4/2020 18:39:02' prior: 50520525! - fixedWidth: aNumber fixedHeight: otherNumber minorDirectionPadding: aSymbolOrNumber - self flag: #deprecated. "use fixedWidth:fixedHeight:offAxisEdgeWeight:" - ^ LayoutSpec new - fixedWidth: aNumber; - fixedHeight: otherNumber; - minorDirectionPadding: aSymbolOrNumber! ! -!LayoutSpec class methodsFor: 'deprecated' stamp: 'KenD 6/4/2020 18:40:09' prior: 50520535! - fixedWidth: aNumber proportionalHeight: otherNumber minorDirectionPadding: aSymbolOrNumber - self flag: #deprecated. "use fixedWidth:proportionalHeight:offAxisEdgeWeight:" - ^self new - fixedWidth: aNumber; - proportionalHeight: otherNumber; - minorDirectionPadding: aSymbolOrNumber! ! -!LayoutSpec class methodsFor: 'deprecated' stamp: 'KenD 6/4/2020 18:41:13' prior: 50520546! - proportionalWidth: aNumber fixedHeight: otherNumber minorDirectionPadding: aSymbolOrNumber - self flag: #deprecated. "proportionalWidth:fixedHeight:offAxisEdgeWeight:" - ^self new - proportionalWidth: aNumber; - fixedHeight: otherNumber; - minorDirectionPadding: aSymbolOrNumber! ! -!LayoutSpec class methodsFor: 'deprecated' stamp: 'KenD 6/4/2020 18:42:09' prior: 50520557! - proportionalWidth: aNumber proportionalHeight: otherNumber minorDirectionPadding: aSymbolOrNumber - self flag: #deprecated. "use proportionalWidth:proportionalHeight:offAxisEdgeWeight: -" - ^self new - proportionalWidth: aNumber; - proportionalHeight: otherNumber; - minorDirectionPadding: aSymbolOrNumber! ! - -LayoutSpec removeSelector: #minimumLayoutHeight! - -!methodRemoval: LayoutSpec #minimumLayoutHeight stamp: 'Install-4208-LayoutRemoveUnused-KenDickey-2020Jun04-18h22m-KenD.003.cs.st 6/25/2020 16:06:52'! -minimumLayoutHeight - "Generally prefer asking the morph itself!!" - - proportionalHeight ifNil: [ ^0 ]. - ^fixedHeight ifNil: [0]! - -LayoutSpec removeSelector: #heightFor:! - -!methodRemoval: LayoutSpec #heightFor: stamp: 'Install-4208-LayoutRemoveUnused-KenDickey-2020Jun04-18h22m-KenD.003.cs.st 6/25/2020 16:06:52'! -heightFor: availableSpace - "If proportional is zero, answer stored fixed extent, or actual morph extent if undefined. - Otherwise, we do proportional layout, and the stored extent is a minimum extent. - If there is no minimum extent, it should be set to zero." - - ^proportionalHeight isNil - ifTrue: [fixedHeight ifNil: [morph morphHeight]] - ifFalse: [proportionalHeight * availableSpace + morph minimumLayoutExtent y]! - -LayoutSpec removeSelector: #widthFor:! - -LayoutSpec removeSelector: #fixedOrMorphWidth! - -!methodRemoval: LayoutSpec #fixedOrMorphWidth stamp: 'Install-4208-LayoutRemoveUnused-KenDickey-2020Jun04-18h22m-KenD.003.cs.st 6/25/2020 16:06:52'! -fixedOrMorphWidth - - self flag: #deprecated. - - ^fixedWidth ifNil: [ morph morphWidth ]! - -LayoutSpec removeSelector: #heightForComfortable:! - -!methodRemoval: LayoutSpec #heightForComfortable: stamp: 'Install-4208-LayoutRemoveUnused-KenDickey-2020Jun04-18h22m-KenD.003.cs.st 6/25/2020 16:06:52'! -heightForComfortable: availableSpace - "Similar to #heightFor:. To be used when we know availableSpace is more than the minimum required to apply proportional layout and still get more than our minimum. See senders." - - ^proportionalHeight isNil - ifTrue: [fixedHeight ifNil: [morph morphHeight]] - ifFalse: [proportionalHeight * availableSpace]! - -LayoutSpec removeSelector: #minimumLayoutWidth! - -!methodRemoval: LayoutSpec #minimumLayoutWidth stamp: 'Install-4208-LayoutRemoveUnused-KenDickey-2020Jun04-18h22m-KenD.003.cs.st 6/25/2020 16:06:52'! -minimumLayoutWidth - "Generally prefer asking the morph itself!!" - - proportionalWidth ifNil: [ ^0 ]. - ^fixedWidth ifNil: [0]! - -LayoutSpec removeSelector: #widthForComfortable:! - -Morph removeSelector: #minLayoutWidth! - -!methodRemoval: Morph #minLayoutWidth stamp: 'Install-4208-LayoutRemoveUnused-KenDickey-2020Jun04-18h22m-KenD.003.cs.st 6/25/2020 16:06:52'! -minLayoutWidth - - self flag: #deprecated. - ^ self layoutSpecOrNil - ifNil: [ self morphWidth ] - ifNotNil: [ :ls | ls minimumSpecWidth ]! - -Morph removeSelector: #minLayoutHeight! - -!methodRemoval: Morph #minLayoutHeight stamp: 'Install-4208-LayoutRemoveUnused-KenDickey-2020Jun04-18h22m-KenD.003.cs.st 6/25/2020 16:06:52'! -minLayoutHeight - - self flag: #deprecated. - ^ self layoutSpecOrNil - ifNil: [ self morphHeight ] - ifNotNil: [ :ls | ls minimumSpecHeight ] -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4208-LayoutRemoveUnused-KenDickey-2020Jun04-18h22m-KenD.003.cs.st----! - -'From Cuis 5.0 [latest update: #4208] on 5 June 2020 at 10:41:48 am'! - -TextModelMorph subclass: #BrowserCommentTextMorph - instanceVariableNames: 'separator separatorHeight proportionalHeight ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #BrowserCommentTextMorph category: #'Morphic-Views' stamp: 'Install-4209-Layouts-mark-deprecated-methods-JuanVuletich-2020Jun05-10h22m-jmv.002.cs.st 6/25/2020 16:06:52'! -TextModelMorph subclass: #BrowserCommentTextMorph - instanceVariableNames: 'separator separatorHeight proportionalHeight' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! -!BrowserCommentTextMorph methodsFor: 'displaying' stamp: 'jmv 6/5/2020 10:38:23' prior: 50519846! - hidePane - - self hide. - separator visible ifTrue: [ - proportionalHeight _ self layoutSpec proportionalLayoutHeight ]. - separator layoutSpec fixedHeight: 0. - self layoutSpec proportionalHeight: 0. - separator ifNotNil: [ separator hide ]! ! -!BrowserCommentTextMorph methodsFor: 'displaying' stamp: 'jmv 6/5/2020 10:38:45' prior: 16792967! - showPane - - self show. - proportionalHeight ifNotNil: [ - self layoutSpec proportionalHeight: proportionalHeight ]. - separator ifNotNil: [ - separator layoutSpec fixedHeight: Theme current layoutAdjusterThickness. - separator show ]! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'jmv 6/5/2020 10:38:00' prior: 50518682 overrides: 50518657! - buildLowerPanes - | codeAndButtons codeButtonsAndAnnotations comment separator | - comment _ self buildMorphicCommentPane. - separator _ LayoutAdjustingMorph new. - comment separator: separator. - codeAndButtons _ LayoutMorph newColumn. - Preferences optionalButtons ifTrue: [ - codeAndButtons - addMorph: self optionalButtonRow fixedHeight: self defaultButtonPaneHeight; - addAdjusterMorph ]. - codeAndButtons - addMorph: self buildMorphicCodePane proportionalHeight: 2.0; - addMorph: separator fixedHeight: Theme current layoutAdjusterThickness; - addMorph: comment proportionalHeight: 2.0. - Preferences showAnnotations ifFalse: [ - ^codeAndButtons ]. - codeButtonsAndAnnotations _ LayoutMorph newColumn. - codeButtonsAndAnnotations - addMorph: self buildMorphicAnnotationsPane fixedHeight: self defaultAnnotationPaneHeight; - addAdjusterMorph; - addMorph: codeAndButtons proportionalHeight: 1.0. - ^codeButtonsAndAnnotations! ! -!LayoutMorph methodsFor: 'deprecated' stamp: 'jmv 6/5/2020 10:22:53' prior: 50521621! - padding - - self deprecatedMethod. "use axisEdgeWeight" - ^ axisEdgeWeight! ! -!LayoutMorph methodsFor: 'deprecated' stamp: 'jmv 6/5/2020 10:23:08' prior: 50521627! - padding: aSymbolOrNumber - "This sets how extra space is used when doing layout. For example, a column might have extra , unneded vertical space. #top means widgets are set close to the top, and extra space is at bottom. Conversely, #bottom means widgets are set close to the bottom, and extra space is at top. Valid values include #left and #right (for rows) and #center. Alternatively, any number between 0.0 and 1.0 might be used. - self new padding: #center - self new padding: 0.9 - " - self deprecatedMethod. "use axisEdgeWeight:" - axisEdgeWeight _ aSymbolOrNumber - caseOf: { - [ #top ] -> [ 0.0 ]. - [ #left ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #right ] -> [ 1.0 ]. - [ #bottom ] -> [ 1.0 ] - } - otherwise: [ aSymbolOrNumber ]! ! -!LayoutSpec methodsFor: 'deprecated' stamp: 'jmv 6/5/2020 10:23:12' prior: 50519759! - fixedOrMorphHeight - - self deprecatedMethod. - - ^fixedHeight ifNil: [ morph morphHeight ]! ! -!LayoutSpec methodsFor: 'deprecated' stamp: 'jmv 6/5/2020 10:23:15' prior: 50521709! - minorDirectionPadding - self deprecatedMethod. "use offAxisEdgeWeight" - ^offAxisEdgeWeight! ! -!LayoutSpec methodsFor: 'deprecated' stamp: 'jmv 6/5/2020 10:23:19' prior: 50521715! - minorDirectionPadding: aSymbolOrNumber - "This sets how padding is done in the secondary direction. For instance, if the owning morph is set in a row, the row will control horizontal layout. But if there is unused vertical space, it will be used according to this parameter. For instance, #top sets the owning morph at the top. Same for #bottom and #center. If the owner is contained in a column, #left, #center or #right should be used. Alternatively, any number between 0.0 and 1.0 can be used. - self new minorDirectionPadding: #center - self new minorDirectionPadding: 0.9 - " - self deprecatedMethod. "use offAxisEdgeWeight:" - offAxisEdgeWeight _ aSymbolOrNumber - caseOf: { - [ #top ] -> [ 0.0 ]. - [ #left ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #right ] -> [ 1.0 ]. - [ #bottom ] -> [ 1.0 ] - } - otherwise: [ aSymbolOrNumber ]! ! -!LayoutSpec class methodsFor: 'deprecated' stamp: 'jmv 6/5/2020 10:23:22' prior: 50521958! - fixedWidth: aNumber fixedHeight: otherNumber minorDirectionPadding: aSymbolOrNumber - self deprecatedMethod. "use fixedWidth:fixedHeight:offAxisEdgeWeight:" - ^ LayoutSpec new - fixedWidth: aNumber; - fixedHeight: otherNumber; - minorDirectionPadding: aSymbolOrNumber! ! -!LayoutSpec class methodsFor: 'deprecated' stamp: 'jmv 6/5/2020 10:23:25' prior: 50521970! - fixedWidth: aNumber proportionalHeight: otherNumber minorDirectionPadding: aSymbolOrNumber - self deprecatedMethod. "use fixedWidth:proportionalHeight:offAxisEdgeWeight:" - ^self new - fixedWidth: aNumber; - proportionalHeight: otherNumber; - minorDirectionPadding: aSymbolOrNumber! ! -!LayoutSpec class methodsFor: 'deprecated' stamp: 'jmv 6/5/2020 10:23:27' prior: 50521982! - proportionalWidth: aNumber fixedHeight: otherNumber minorDirectionPadding: aSymbolOrNumber - self deprecatedMethod. "proportionalWidth:fixedHeight:offAxisEdgeWeight:" - ^self new - proportionalWidth: aNumber; - fixedHeight: otherNumber; - minorDirectionPadding: aSymbolOrNumber! ! -!LayoutSpec class methodsFor: 'deprecated' stamp: 'jmv 6/5/2020 10:23:34' prior: 50521994! - proportionalWidth: aNumber proportionalHeight: otherNumber minorDirectionPadding: aSymbolOrNumber - self deprecatedMethod. "use proportionalWidth:proportionalHeight:offAxisEdgeWeight: -" - ^self new - proportionalWidth: aNumber; - proportionalHeight: otherNumber; - minorDirectionPadding: aSymbolOrNumber! ! -!Theme methodsFor: 'other options' stamp: 'jmv 6/5/2020 10:39:44' prior: 50520568! - layoutAdjusterThickness - - self flag: #todo. "Revisit this; consider moving proportional stuff out of Theme entirely." - - ^ Preferences standardListFont pointSize // 3! ! - -PluggableButtonMorph removeSelector: #minLayoutWidth! - -!methodRemoval: PluggableButtonMorph #minLayoutWidth stamp: 'Install-4209-Layouts-mark-deprecated-methods-JuanVuletich-2020Jun05-10h22m-jmv.002.cs.st 6/25/2020 16:06:52'! -minLayoutWidth - - ^ self minimumExtent x! - -PluggableButtonMorph removeSelector: #minLayoutHeight! - -!methodRemoval: PluggableButtonMorph #minLayoutHeight stamp: 'Install-4209-Layouts-mark-deprecated-methods-JuanVuletich-2020Jun05-10h22m-jmv.002.cs.st 6/25/2020 16:06:52'! -minLayoutHeight - - ^ self minimumExtent y! - -TextModelMorph subclass: #BrowserCommentTextMorph - instanceVariableNames: 'separator proportionalHeight' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #BrowserCommentTextMorph category: #'Morphic-Views' stamp: 'Install-4209-Layouts-mark-deprecated-methods-JuanVuletich-2020Jun05-10h22m-jmv.002.cs.st 6/25/2020 16:06:52'! -TextModelMorph subclass: #BrowserCommentTextMorph - instanceVariableNames: 'separator proportionalHeight' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4209-Layouts-mark-deprecated-methods-JuanVuletich-2020Jun05-10h22m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4209] on 8 June 2020 at 10:55:41 am'! - -LayoutSpec class removeSelector: #proportionalWidth:proportionalHeight:minorDirectionPadding:! - -!methodRemoval: LayoutSpec class #proportionalWidth:proportionalHeight:minorDirectionPadding: stamp: 'Install-4210-Layouts-delete-deprecated-methods-JuanVuletich-2020Jun08-10h49m-jmv.001.cs.st 6/25/2020 16:06:52'! -proportionalWidth: aNumber proportionalHeight: otherNumber minorDirectionPadding: aSymbolOrNumber - self deprecatedMethod. "use proportionalWidth:proportionalHeight:offAxisEdgeWeight: -" - ^self new - proportionalWidth: aNumber; - proportionalHeight: otherNumber; - minorDirectionPadding: aSymbolOrNumber! - -LayoutSpec class removeSelector: #proportionalWidth:fixedHeight:minorDirectionPadding:! - -!methodRemoval: LayoutSpec class #proportionalWidth:fixedHeight:minorDirectionPadding: stamp: 'Install-4210-Layouts-delete-deprecated-methods-JuanVuletich-2020Jun08-10h49m-jmv.001.cs.st 6/25/2020 16:06:52'! -proportionalWidth: aNumber fixedHeight: otherNumber minorDirectionPadding: aSymbolOrNumber - self deprecatedMethod. "proportionalWidth:fixedHeight:offAxisEdgeWeight:" - ^self new - proportionalWidth: aNumber; - fixedHeight: otherNumber; - minorDirectionPadding: aSymbolOrNumber! - -LayoutSpec class removeSelector: #fixedWidth:fixedHeight:minorDirectionPadding:! - -!methodRemoval: LayoutSpec class #fixedWidth:fixedHeight:minorDirectionPadding: stamp: 'Install-4210-Layouts-delete-deprecated-methods-JuanVuletich-2020Jun08-10h49m-jmv.001.cs.st 6/25/2020 16:06:52'! -fixedWidth: aNumber fixedHeight: otherNumber minorDirectionPadding: aSymbolOrNumber - self deprecatedMethod. "use fixedWidth:fixedHeight:offAxisEdgeWeight:" - ^ LayoutSpec new - fixedWidth: aNumber; - fixedHeight: otherNumber; - minorDirectionPadding: aSymbolOrNumber! - -LayoutSpec class removeSelector: #fixedWidth:proportionalHeight:minorDirectionPadding:! - -!methodRemoval: LayoutSpec class #fixedWidth:proportionalHeight:minorDirectionPadding: stamp: 'Install-4210-Layouts-delete-deprecated-methods-JuanVuletich-2020Jun08-10h49m-jmv.001.cs.st 6/25/2020 16:06:52'! -fixedWidth: aNumber proportionalHeight: otherNumber minorDirectionPadding: aSymbolOrNumber - self deprecatedMethod. "use fixedWidth:proportionalHeight:offAxisEdgeWeight:" - ^self new - fixedWidth: aNumber; - proportionalHeight: otherNumber; - minorDirectionPadding: aSymbolOrNumber! - -LayoutSpec removeSelector: #minorDirectionPadding! - -!methodRemoval: LayoutSpec #minorDirectionPadding stamp: 'Install-4210-Layouts-delete-deprecated-methods-JuanVuletich-2020Jun08-10h49m-jmv.001.cs.st 6/25/2020 16:06:52'! -minorDirectionPadding - self deprecatedMethod. "use offAxisEdgeWeight" - ^offAxisEdgeWeight! - -LayoutSpec removeSelector: #fixedOrMorphHeight! - -!methodRemoval: LayoutSpec #fixedOrMorphHeight stamp: 'Install-4210-Layouts-delete-deprecated-methods-JuanVuletich-2020Jun08-10h49m-jmv.001.cs.st 6/25/2020 16:06:52'! -fixedOrMorphHeight - - self deprecatedMethod. - - ^fixedHeight ifNil: [ morph morphHeight ]! - -LayoutSpec removeSelector: #minorDirectionPadding:! - -!methodRemoval: LayoutSpec #minorDirectionPadding: stamp: 'Install-4210-Layouts-delete-deprecated-methods-JuanVuletich-2020Jun08-10h49m-jmv.001.cs.st 6/25/2020 16:06:52'! -minorDirectionPadding: aSymbolOrNumber - "This sets how padding is done in the secondary direction. For instance, if the owning morph is set in a row, the row will control horizontal layout. But if there is unused vertical space, it will be used according to this parameter. For instance, #top sets the owning morph at the top. Same for #bottom and #center. If the owner is contained in a column, #left, #center or #right should be used. Alternatively, any number between 0.0 and 1.0 can be used. - self new minorDirectionPadding: #center - self new minorDirectionPadding: 0.9 - " - self deprecatedMethod. "use offAxisEdgeWeight:" - offAxisEdgeWeight _ aSymbolOrNumber - caseOf: { - [ #top ] -> [ 0.0 ]. - [ #left ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #right ] -> [ 1.0 ]. - [ #bottom ] -> [ 1.0 ] - } - otherwise: [ aSymbolOrNumber ]! - -LayoutMorph removeSelector: #padding:! - -!methodRemoval: LayoutMorph #padding: stamp: 'Install-4210-Layouts-delete-deprecated-methods-JuanVuletich-2020Jun08-10h49m-jmv.001.cs.st 6/25/2020 16:06:52'! -padding: aSymbolOrNumber - "This sets how extra space is used when doing layout. For example, a column might have extra , unneded vertical space. #top means widgets are set close to the top, and extra space is at bottom. Conversely, #bottom means widgets are set close to the bottom, and extra space is at top. Valid values include #left and #right (for rows) and #center. Alternatively, any number between 0.0 and 1.0 might be used. - self new padding: #center - self new padding: 0.9 - " - self deprecatedMethod. "use axisEdgeWeight:" - axisEdgeWeight _ aSymbolOrNumber - caseOf: { - [ #top ] -> [ 0.0 ]. - [ #left ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #right ] -> [ 1.0 ]. - [ #bottom ] -> [ 1.0 ] - } - otherwise: [ aSymbolOrNumber ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4210-Layouts-delete-deprecated-methods-JuanVuletich-2020Jun08-10h49m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4208] on 8 June 2020 at 11:06:28 am'! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 6/8/2020 11:05:56' overrides: 50388601! - drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - - ^super drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint x @ (aPoint y // 2 * 2) font: fontOrNil color: aColor! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4211-EmbossedTextFix-JuanVuletich-2020Jun08-11h02m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4208] on 8 June 2020 at 11:42:03 am'! -!ProgressMorph methodsFor: 'accessing' stamp: 'jmv 6/8/2020 11:41:25' prior: 50444427! - label: aString subLabel: otherString - | label subLabel n | - label _ aString. - subLabel _ otherString. - layoutSpec notNil ifTrue: [ - n _ label size * self morphWidth * 0.95 // (AbstractFont default widthOfString: label). - label _ label squeezedTo: n. - n _ subLabel size * self morphWidth * 0.95 // (AbstractFont default widthOfString: subLabel). - subLabel _ subLabel squeezedTo: n ]. - self whenUIinSafeState: [ - labelMorph contents: label. - subLabelMorph contents: subLabel. - self updatePositionAndExtent. ]! ! -!ProgressMorph methodsFor: 'accessing' stamp: 'jmv 6/8/2020 11:26:00' prior: 50491104! - updatePositionAndExtent - | w newExtent | - layoutSpec notNil ifTrue: [ - ^self ]. - w _ ((labelMorph measureContents x max: subLabelMorph measureContents x) max: 200) + 18. - w _ w min: Display extent x. - newExtent _ w > extent x - ifTrue: [ w@(labelMorph morphHeight + subLabelMorph morphHeight + progress morphHeight + 10) ] - ifFalse: [ extent ]. - self world - ifNotNil: [ :world | - self morphPosition: world morphExtent - newExtent // 2 extent: newExtent ] - ifNil: [ self morphExtent: newExtent ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4212-ProgressMorph-fix-JuanVuletich-2020Jun08-11h06m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4212] on 8 June 2020 at 12:13:53 pm'! - -LayoutMorph removeSelector: #padding! - -!methodRemoval: LayoutMorph #padding stamp: 'Install-4213-delete-deprecated-methods-JuanVuletich-2020Jun08-12h13m-jmv.001.cs.st 6/25/2020 16:06:52'! -padding - - self deprecatedMethod. "use axisEdgeWeight" - ^ axisEdgeWeight! - -AbstractFont removeSelector: #height! - -!methodRemoval: AbstractFont #height stamp: 'Install-4213-delete-deprecated-methods-JuanVuletich-2020Jun08-12h13m-jmv.001.cs.st 6/25/2020 16:06:52'! -height - "Answer the line spacing. Prefer calling #lineSpacing, that is more explicit. - Besides, #height is false polymorphism, Fonts are not interchangeable with Form or Rectangle!!" - - self deprecatedMethod. - ^self lineSpacing! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4213-delete-deprecated-methods-JuanVuletich-2020Jun08-12h13m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4213] on 11 June 2020 at 10:10:34 am'! -!FontFamily class methodsFor: 'defaults' stamp: 'jmv 6/11/2020 09:58:10'! -defaultLineSpacing - ^FontFamily defaultFamilyAndPointSize lineSpacing! ! -!Object methodsFor: 'private' stamp: 'jmv 6/11/2020 10:01:05' prior: 50453293! - primitiveError: aString - "This method is called when the error handling results in a recursion in - calling on error: or halt or halt:." - - | context emergencyEvaluator lines r | - r _ `10@10` extent: (Display extent -20 min: `700@1000`). - lines _ r height // FontFamily defaultLineSpacing. - emergencyEvaluator _ Transcripter newInFrame: r. - emergencyEvaluator - nextPutAll: '***System error handling failed***'; newLine; - nextPutAll: aString; newLine; - nextPutAll: '-------------------------------'; newLine. - context _ thisContext sender sender. - (30 min: lines - 10) timesRepeat: [context ifNotNil: [emergencyEvaluator print: (context _ context sender); newLine]]. - emergencyEvaluator - nextPutAll: '-------------------------------'; newLine; - nextPutAll: 'Type ''revert'' to revert your last method change.'; newLine; - nextPutAll: 'Type ''exit'' to exit the emergency evaluator.'; newLine. - emergencyEvaluator readEvalPrint! ! -!Text methodsFor: 'emphasis' stamp: 'jmv 6/11/2020 10:07:59' prior: 50471624! - fontIfApplying: textAttributes default: defaultFont - "Answer the font for characters as specified by the argument." - - | fn ps | - self withAttributeValues: textAttributes do: [ :familyName :pointSize :emphasis :color :alignment :characterStyle :paragraphStyle :backgroundColor | - fn _ familyName ifNil: [ defaultFont ifNotNil: [ defaultFont familyName ] ifNil: [ FontFamily defaultFamilyName ]]. - ps _ pointSize ifNil: [ defaultFont ifNotNil: [ defaultFont pointSize ] ifNil: [ FontFamily defaultPointSize ]]. - ^((FontFamily familyName: fn pointSize: ps) ifNil: [ - FontFamily familyName: fn aroundPointSize: ps]) - emphasized: emphasis ]! ! -!Transcripter methodsFor: 'accessing' stamp: 'jmv 6/11/2020 10:01:22' prior: 50453325! - 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]. - textComposition - setModel: (TextModel withText: c asText); - extentForComposing: frame width-8 @9999. - textComposition composeAll. - d _ textComposition usedHeight - frame height. - d > 0 ifTrue: [ - "Scroll up to keep all contents visible" - cb _ textComposition characterBlockAtPoint: - `0@0` + (0@(d+FontFamily defaultLineSpacing)). - self on: (c copyFrom: cb stringIndex to: c size). - readLimit _ position _ collection size. - ^ self endEntry]. - Display fill: (frame insetBy: -2) fillColor: self black; - fill: frame fillColor: self white. - Display getCanvas - textComposition: textComposition - bounds: (`4@4` + frame topLeft extent: Display extent) - color: `Color black` - selectionColor: `Color blue`. - DisplayScreen screenUpdateRequired: nil! ! -!ProgressInitiationException methodsFor: 'exceptionDescription' stamp: 'jmv 6/11/2020 10:03:05' prior: 50477757 overrides: 16839987! - defaultAction - - | delta textFrame barFrame outerFrame result range width filledWidth f h textWidth textForm innerBarFrame oldFilledWidth oldFilledWidth2 prevContents | - f _ FontFamily defaultFamilyAndPointSize. - h _ f lineSpacing * 3//2. - textWidth _ (f widthOfString: progressTitle) + h. - width _ 150 max: textWidth. - - textForm _ Form extent: width@h depth: 32. - textForm fillBlack. - textForm fillWhite: (textForm boundingBox insetBy: 2). - progressTitle displayOn: textForm at: (width-textWidth+h//2@4). - barFrame _ Rectangle center: aPoint extent: width@h. - textFrame _ `0@0` extent: width@h. - textFrame _ textFrame - aligned: textFrame bottomCenter - with: barFrame topCenter + `0@2`. - outerFrame _ barFrame merge: textFrame. - delta _ outerFrame amountToTranslateWithin: Display boundingBox. - barFrame _ barFrame translatedBy: delta. - textFrame _ textFrame translatedBy: delta. - outerFrame _ outerFrame translatedBy: delta. - prevContents _ Form fromDisplay: outerFrame. - range _ maxVal = minVal ifTrue: [1] ifFalse: [maxVal - minVal]. "Avoid div by 0" - innerBarFrame _ barFrame insetBy: 2. - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - oldFilledWidth _ 0. - oldFilledWidth2 _ 0. - result _ workBlock value: "Supply the bar-update block for evaluation in the work block" - [ :barVal | - barVal - ifNotNil: [ currentVal _ barVal ] - ifNil: [ - currentVal _ currentVal + 1. - currentVal >= maxVal - ifTrue: [ currentVal _ minVal ]]. - filledWidth _ ((barFrame width-4) asFloat * ((currentVal-minVal) asFloat / range min: 1.0)) asInteger. - filledWidth > oldFilledWidth ifTrue: [ - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - Display fillGray: (barFrame topLeft + `2@2` extent: filledWidth@(h-4)). - filledWidth -200 > oldFilledWidth2 - ifFalse: [ - "Usually just request an update, to be done asynchronously." - DisplayScreen screenUpdateRequired: outerFrame ] - ifTrue: [ - "Once in a while, force a real screen update (warning: really slow on MacOS if done too often)" - Display forceToScreen: outerFrame. oldFilledWidth2 _ filledWidth ]. - oldFilledWidth _ filledWidth ]]. - prevContents displayAt: outerFrame topLeft. - self resume: result! ! -!TextEditor methodsFor: 'initialization' stamp: 'jmv 6/11/2020 10:03:22' prior: 16933051 overrides: 16896425! - initialize - selectionStartBlocks _ #(). - selectionStopBlocks _ #(). - initialSelectionStart _ nil. - initialSelectionStop _ nil. - doWordSelection _ false. - doParagraphSelection _ false. - defaultFont _ FontFamily defaultFamilyAndPointSize! ! -!TextFontFamilyAndSize methodsFor: 'accessing' stamp: 'jmv 6/11/2020 10:08:22' prior: 16933393! - font - - ^ FontFamily familyName: familyName pointSize: pointSize! ! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 6/11/2020 10:07:40' prior: 16892967! - setDefaultFonts: defaultFontsSpec - - | font | - defaultFontsSpec do: [ :triplet | - font _ FontFamily familyName: triplet second pointSize: triplet third. - font ifNil: [ font _ FontFamily defaultFamilyAndPointSize ]. - triplet size > 3 ifTrue: [ - font _ font emphasized: triplet fourth ]. - self - perform: triplet first - with: font]! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 6/11/2020 10:03:24' prior: 50453460! - displayOn: aForm in: aRectangle - " - 1 to: 2000 do: [ :i | i print ]. - 1 to: 750 do: [ :i | i print ]. - Transcript displayOn: Display in: bounds - " - | font count string x y fh canvas innerR index | - aForm fill: aRectangle fillColor: `Color white`. - font _ FontFamily defaultFamilyAndPointSize. - - innerR _ aRectangle insetBy: self padding. - canvas _ aForm getCanvas. - canvas newClipRect: innerR. - x _ innerR left. - y _ innerR top. - fh _ font lineSpacing. - count _ lastIndex - firstIndex \\ self maxEntries + 1 min: innerR height // fh - 1. - index _ lastIndex - count \\ self maxEntries + 1. - count timesRepeat: [ - string _ entries at: index. - canvas drawString: string at: x@y font: font color: `Color veryDarkGray`. - y _ y + fh. - index _ index \\ self maxEntries + 1 ]. - string _ unfinishedEntry contents. - canvas drawString: string at: x@y font: font color: `Color veryDarkGray`! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 6/11/2020 10:03:26' prior: 50453491! - displayUnfinishedEntryOn: aForm - - | font count string x y fh canvas r innerR | - innerR _ bounds insetBy: self padding. - lastDisplayPosition < innerR right ifTrue: [ - font _ FontFamily defaultFamilyAndPointSize. - fh _ font lineSpacing. - count _ innerR height // fh-1. - x _ innerR left. - string _ unfinishedEntry contents. - y _ ((lastIndex - firstIndex \\ self maxEntries) min: count-1) + 1 * font lineSpacing + innerR top. - canvas _ aForm getCanvas. - r _ innerR left: lastDisplayPosition. - canvas newClipRect: r. - (canvas drawString: string at: x@y font: font color: `Color veryDarkGray`) ifNotNil: [ :lastPoint | - lastDisplayPosition _ lastPoint x. - ^r ]]. - ^nil! ! -!AbstractFont methodsFor: 'measuring' stamp: 'jmv 6/11/2020 10:02:52' prior: 16777299! - widthOfString: aString - aString ifNil:[^0]. - ^self widthOfString: aString from: 1 to: aString size. -" - FontFamily defaultFamilyAndPointSize widthOfString: 'zort' -"! ! -!AbstractFont class methodsFor: 'instance accessing' stamp: 'jmv 5/5/2019 11:11:03' prior: 50456996! - default - " - Compatibility. - AbstractFont default - " - false ifTrue: [ self deprecatedMethod ]. "Too much senders to activate warnings right now!!" - ^FontFamily defaultFamilyAndPointSize! ! -!AbstractFont class methodsFor: 'instance accessing' stamp: 'jmv 6/11/2020 10:09:27' prior: 50393006! - fromUser: priorFont - " - AbstractFont fromUser - " - "Present a menu of available fonts, and if one is chosen, return it. - Otherwise return nil. - Show only baseFonts i.e. FamilyName, pointSize (but do not include emphasis, such as italic or bold)" - - | fontList fontMenu active ptMenu label spec | - fontList := FontFamily familyNames. - fontMenu := MenuMorph new defaultTarget: self. - fontList do: [:fontName | - active := priorFont familyName sameAs: fontName. - ptMenu := MenuMorph new defaultTarget: self. - (FontFamily pointSizesFor:fontName ) do: [ :pt | - (active and: [pt = priorFont pointSize]) - ifTrue: [label := ''] - ifFalse: [label := '']. - label := label , pt printString , ' pt'. - ptMenu - add: label - target: fontMenu - action: #modalSelection: - argument: { - fontName. - pt}]. - active ifTrue: [label := ''] ifFalse: [label := '']. - label := label , fontName. - fontMenu add: label subMenu: ptMenu]. - spec := fontMenu invokeModal. - spec ifNil: [^nil]. - ^FontFamily familyName: spec first pointSize: spec last! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 6/11/2020 10:03:13' prior: 50498781! - glyphAt: character put: characterForm - "Copy characterForm over the glyph for the argument, character." - | ascii leftX rightX widthDif newGlyphs | - ascii _ character numericValue. - ascii < minAscii ifTrue: [^ self error: 'Cant store characters below min ascii']. - ascii > maxAscii ifTrue: - [(self confirm: -'This font does not accomodate ascii values higher than ' , maxAscii printString , '. -Do you wish to extend it permanently to handle values up to ' , ascii printString) - ifTrue: [self extendMaxAsciiTo: ascii] - ifFalse: [^ self error: 'No change made']]. - leftX _ xTable at: ascii + 1. - rightX _ xTable at: ascii + 2. - widthDif _ characterForm width - (rightX - leftX). - widthDif ~= 0 ifTrue: - ["Make new glyphs with more or less space for this char" - newGlyphs _ Form extent: (glyphs width + widthDif) @ glyphs height depth: glyphs depth. - newGlyphs copy: (`0@0` corner: leftX@glyphs height) - from: `0@0` in: glyphs rule: Form over. - newGlyphs copy: ((rightX+widthDif)@0 corner: newGlyphs width@glyphs height) - from: rightX@0 in: glyphs rule: Form over. - glyphs _ newGlyphs. - "adjust further entries on xTable" - xTable _ xTable copy. - ascii+2 to: xTable size - do: [:i | xTable at: i put: (xTable at: i) + widthDif]]. - glyphs copy: (leftX @ 0 extent: characterForm extent) - from: 0@0 in: characterForm rule: Form over -" -| f | f _ FontFamily defaultFamilyAndPointSize. -f glyphAt: $ put: (Form extent: (f widthOf: $ )+10@f lineSpacing) -"! ! -!TextModelMorph methodsFor: 'geometry' stamp: 'jmv 6/11/2020 10:01:19' prior: 50453668 overrides: 16889728! - scrollDeltaHeight - "Return the increment in pixels which this pane should be scrolled." - - ^ FontFamily defaultLineSpacing! ! -!CodeWindow methodsFor: 'GUI building' stamp: 'jmv 6/11/2020 10:00:39' prior: 50453697! - defaultAnnotationPaneHeight - "Answer the receiver's preferred default height for new annotation panes." - - ^ FontFamily defaultLineSpacing * 2 + 8! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'jmv 6/11/2020 10:00:16' prior: 50453705! - buildMorphicClassColumnWith: classList - - | column | - - column _ LayoutMorph newColumn. - column - addMorphUseAll: classList; - addAdjusterAndMorph: self buildMorphicSwitches fixedHeight: - (Theme current minimalWindows - ifTrue: [FontFamily defaultLineSpacing + 4] - ifFalse: [FontFamily defaultLineSpacing *2-4]). - - ^column! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'jmv 6/11/2020 10:01:17' prior: 50513704! - addTextPane - | result | - result _ (TextModelMorph - textProvider: self - textGetter: #response - textSetter: #response: - selectionGetter: #selectionInterval) emptyTextDisplayMessage: 'Enter response'. - self - valueOfProperty: #emptyTextDisplayMessage - ifPresentDo: [ :msg | - result emptyTextDisplayMessage: msg ]. - result - hasUnacceptedEdits: true; - acceptOnCR: true; - escAction: [ self cancel ]. - "If the initial response is big or has multiple lines we make the text pane bigger and with scrollbars:" - (response size > 20 or: [response includes: Character lf]) - ifTrue: [result morphExtent: 32 @ 3 * FontFamily defaultLineSpacing] - ifFalse: - [result hideScrollBarsIndefinitely; - morphExtent: 18 @ 1 * FontFamily defaultLineSpacing + (0@8).]. - self addMorphBack: result. - ^ result.! ! -!StringMorph methodsFor: 'accessing' stamp: 'jmv 6/11/2020 10:03:16' prior: 16918173! - fontToUse - | fontToUse | - fontToUse := font ifNil: [FontFamily defaultFamilyAndPointSize]. - ^(emphasis isNil or: [emphasis = 0]) - ifTrue: [ fontToUse] - ifFalse: [ fontToUse emphasized: emphasis]! ! -!ProgressMorph methodsFor: 'accessing' stamp: 'jmv 6/11/2020 10:03:58' prior: 50522529! - label: aString subLabel: otherString - | label subLabel n | - label _ aString. - subLabel _ otherString. - layoutSpec notNil ifTrue: [ - n _ label size * self morphWidth * 0.95 // (FontFamily defaultFamilyAndPointSize widthOfString: label). - label _ label squeezedTo: n. - n _ subLabel size * self morphWidth * 0.95 // (FontFamily defaultFamilyAndPointSize widthOfString: subLabel). - subLabel _ subLabel squeezedTo: n ]. - self whenUIinSafeState: [ - labelMorph contents: label. - subLabelMorph contents: subLabel. - self updatePositionAndExtent. ]! ! -!ProgressMorph methodsFor: 'initialization' stamp: 'jmv 6/11/2020 10:03:55' prior: 50472468 overrides: 50521469! - initialize - super initialize. - self separation: 0. - labelMorph _ StringMorph contents: '' font: FontFamily defaultFamilyAndPointSize. - subLabelMorph _ StringMorph contents: '' font: FontFamily defaultFamilyAndPointSize. - progress _ ProgressBarMorph new. - progress morphExtent: 200 @ FontFamily defaultLineSpacing. - self addMorphFront: labelMorph. - self addMorphFront: subLabelMorph. - self addMorph: progress fixedHeight: FontFamily defaultLineSpacing! ! -!InnerListMorph methodsFor: 'drawing' stamp: 'jmv 6/11/2020 10:02:59' prior: 16855228! - font: newFont - font _ newFont ifNil: [ FontFamily defaultFamilyAndPointSize ]. - self adjustExtent! ! -!InnerTextMorph methodsFor: 'geometry' stamp: 'jmv 6/11/2020 10:00:48' prior: 50453909 overrides: 50499535! - minimumExtent - - ^(9@(FontFamily defaultLineSpacing+2))! ! -!InnerTextMorph methodsFor: 'private' stamp: 'jmv 6/11/2020 10:00:45' prior: 50453914! - fit - "Adjust my bounds to fit the text. - Required after the text changes, - or if wrapFlag is true and the user attempts to change the extent." - - | newExtent newHeight newWidth | - newWidth _ extent x. - "Adjust width only if we don't wrap text to own width!!" - wrapFlag ifFalse: [ - newWidth _ self textComposition usedWidth max: 9 ]. - newHeight _ self textComposition usedHeight max: FontFamily defaultLineSpacing + 2. - newExtent _ newWidth @ newHeight. - extent = newExtent - ifTrue: [ - self redrawNeeded. - "Too conservative: only text composition (because of changes in text or styles, etc) - should cause invalidation. - Try to avoid calling #fit unless needed." - ] - ifFalse: [ - extent = newExtent ifFalse: [ - self redrawNeeded. - extent _ newExtent. - self someSubmorphPositionOrExtentChanged. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]]. - - owner innerHeight: newExtent y! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jmv 6/11/2020 10:00:42' prior: 50453947! - sizeUnit - ^FontFamily defaultLineSpacing! ! -!FontPicker class methodsFor: 'prompting user' stamp: 'jmv 6/11/2020 10:05:21' prior: 50504109! - promptUser - "Present a menu of font families, answer selection. - FontPicker promptUser - " - ^self promptUserWithFamilies: FontFamily familyNames.! ! -!FontPicker class methodsFor: 'prompting user' stamp: 'jmv 6/11/2020 10:05:24' prior: 50503767! - promptUserAndSetDefault - "Present a menu of available font families, and if one is chosen, change to it." - self promptUserAndSetDefaultWithFamilies: FontFamily familyNames.! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 6/11/2020 10:02:56' prior: 50511051 overrides: 50463529! - drawString: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | p1 font | - "Don't waste any time if NOP" - lastIndex = 0 ifTrue: [ - ^nil ]. - - p1 _ (currentTransformation transform: aPoint rounded) rounded. - engine colorMap: nil. - font _ fontOrNil ifNil: [ FontFamily defaultFamilyAndPointSize ]. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: aColor! ! -!TextComposer methodsFor: 'accessing' stamp: 'jmv 6/11/2020 10:03:18' prior: 16930647! - defaultFont - ^editor ifNil: [ FontFamily defaultFamilyAndPointSize ] ifNotNil: [ editor defaultFont ]! ! -!TextComposition methodsFor: 'access' stamp: 'jmv 6/11/2020 10:03:20' prior: 16930683! -defaultFont - ^editor ifNil: [ FontFamily defaultFamilyAndPointSize ] ifNotNil: [ editor defaultFont ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4214-Font-Cleanup-JuanVuletich-2020Jun11-09h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4214] on 11 June 2020 at 10:21:51 am'! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 6/10/2020 22:06:23' prior: 50457982! - setDefaultFont: fontFamilyName spec: defaultFontsSpec - - | font | - defaultFontsSpec do: [ :triplet | - font _ FontFamily familyName: fontFamilyName pointSize: triplet second. - font ifNil: [ font _ FontFamily defaultFamilyAndPointSize ]. - triplet size > 2 ifTrue: [ - font _ font emphasized: triplet third ]. - self - perform: triplet first - with: font]! ! -!FontFamily class methodsFor: 'initialization' stamp: 'jmv 6/10/2020 22:07:13' prior: 50495884! - defaultFamilyName: aStringOrNil defaultPointSize: aNumberOrNil - "Nil just means leave it as it is now." - - aStringOrNil ifNotNil: [DefaultFamilyName _ aStringOrNil]. - aNumberOrNil ifNotNil: [DefaultPointSize _ aNumberOrNil].! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 6/11/2020 10:19:09' prior: 50504117! - preferencesMenu - "Build the preferences menu for the world." - - ^ (self menu: 'Preferences...') - addItemsFromDictionaries: { - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Font Sizes...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Set font...'. - #object -> FontPicker. - #selector -> #promptUserAndSetDefaultWithFamilies:. - #arguments -> {FontPicker familyNames}. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'change the current font family.' - } asDictionary. - { - #label -> 'Load extra fonts'. - #object -> FontFamily. - #selector -> #readAdditionalTrueTypeFonts. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'Load additional TrueType fonts included with Cuis.' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }! ! - -FontPicker class removeSelector: #promptUserAndSetDefaultInstallIfNecessaryWithFamilies:! - -!methodRemoval: FontPicker class #promptUserAndSetDefaultInstallIfNecessaryWithFamilies: stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:06:52'! -promptUserAndSetDefaultInstallIfNecessaryWithFamilies: fontFamilies - " - Present a menu of available font families, and if one is chosen, - install it if necessary, and change to it. - " - self promptUserWithFamilies: fontFamilies withMessageOnSelection: #setDefaultAndInstallIfNecessary:! - -FontPicker class removeSelector: #setDefaultAndInstallIfNecessary:! - -!methodRemoval: FontPicker class #setDefaultAndInstallIfNecessary: stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:06:52'! -setDefaultAndInstallIfNecessary: aFontName - "install the font if necessary, and change to it on the whole system without changing point sizes." - self installFontIfNecessary: aFontName. - self setDefaultFont: aFontName. -! - -FontPicker class removeSelector: #installFontIfNecessary:! - -!methodRemoval: FontPicker class #installFontIfNecessary: stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:06:52'! -installFontIfNecessary: aFontName - | isFontInstalled | - isFontInstalled _ FontFamily familyNames includes: aFontName. - isFontInstalled ifFalse: [StrikeFont install: aFontName.].! - -StrikeFont class removeSelector: #install:! - -!methodRemoval: StrikeFont class #install: stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:06:52'! -install: aString -" -StrikeFont install: 'DejaVu'. -" -" -StrikeFont install: 'DejaVu Sans Mono'. -FontFamily defaultFamilyName: 'DejaVu Sans Mono'. -Preferences bigFonts. -Character initialize. -" -" -StrikeFont install: 'DejaVu Sans'. -StrikeFont buildLargerPunctuation: 'DejaVu Sans'. -FontFamily defaultFamilyName: 'DejaVu Sans'. -Preferences standardFonts. -Character initialize. -" -" -StrikeFont install: 'Inconsolata' -StrikeFont install: '#PilGi' -StrikeFont install: 'Optima' -StrikeFont install: 'Herculanum' -StrikeFont install: 'Papyrus' -StrikeFont install: 'Handwriting - Dakota' -StrikeFont install: 'Times New Roman' -StrikeFont install: 'Apple Chancery' -StrikeFont install: 'Cochin' -StrikeFont install: 'Cracked' -StrikeFont install: 'Zapfino' -StrikeFont install: 'Brush Script MT' -StrikeFont install: 'Chalkboard' -" - | family | - family _ nil. - 1 to: 200 do: [ :s | - (self create: aString size: s bold: true italic: true boldItalic: false) ifNotNil: [ :font | - font print. - family ifNil: [ - family _ StrikeFontFamily new. - family familyName: aString.]. - family atPointSize: s put: font ]]. - family ifNotNil: [ - FontFamily addFamily: family ]! - -StrikeFont class removeSelector: #create:size:bold:italic:boldItalic:! - -!methodRemoval: StrikeFont class #create:size:bold:italic:boldItalic: stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:06:52'! -create: fontName size: pointSize bold: includeBold italic: includeItalic boldItalic: includeBoldItalic - " - self create: 'DejaVu Sans Mono' size: 12 bold: true italic: true boldItalic: true - " - | folder base bold oblique boldOblique point | - folder _ DirectoryEntry smalltalkImageDirectory / 'AdditionalFontData'. - point _ pointSize asString. - base _ [ (StrikeFont new - buildFromForm: ((Form fromFileEntry: folder // (fontName, '-0-', point, '.bmp')) asFormOfDepth: 16) - data: (folder // (fontName, '-0-', point, '.txt')) fileContents substrings - name: fontName, ' ', point) - pointSize: pointSize ] on: FileDoesNotExistException do: [ : ex | nil ]. - includeBold ifTrue: [ - bold _ [ (StrikeFont new - buildFromForm: ((Form fromFileEntry: folder // (fontName, '-1-', point, '.bmp')) asFormOfDepth: 16) - data: (folder // (fontName, '-1-', point, '.txt')) fileContents substrings - name: fontName, ' ', point, 'B') - emphasis: 1; - pointSize: pointSize ] on: FileDoesNotExistException do: [ : ex | nil ]]. - includeItalic ifTrue: [ - oblique _ [ (StrikeFont new - buildFromForm: ((Form fromFileEntry: folder // (fontName, '-2-', point, '.bmp')) asFormOfDepth: 16) - data: (folder // (fontName, '-2-', point, '.txt')) fileContents substrings - name: fontName, ' ', point, 'I') - emphasis: 2; - pointSize: pointSize ] on: FileDoesNotExistException do: [ : ex | nil ]]. - includeBoldItalic ifTrue: [ - boldOblique _ [ (StrikeFont new - buildFromForm: ((Form fromFileEntry: folder // (fontName, '-3-', point, '.bmp')) asFormOfDepth: 16) - data: (folder // (fontName, '-3-', point, '.txt')) fileContents substrings - name: fontName, ' ', point, 'BI') - emphasis: 3; - pointSize: pointSize ] on: FileDoesNotExistException do: [ : ex | nil ]]. - "We have a regular, base font. Make others derivatives of it" - base ifNotNil: [ - bold ifNotNil: [ - base derivativeFont: bold at: 1 ]. - oblique ifNotNil: [ - base derivativeFont: oblique at: 2]. - boldOblique ifNotNil: [ - base derivativeFont: boldOblique at: 3 ]. - ^base ]. - "We don't have a base, regular font." - oblique ifNotNil: [ - oblique emphasis: 0. "Hacky. Non regular fonts can not have derivatives. Should change this?" - bold ifNotNil: [ - oblique derivativeFont: bold at: 1 ]. - boldOblique ifNotNil: [ - oblique derivativeFont: boldOblique at: 3 ]. - ^oblique ]. - bold ifNotNil: [ - bold emphasis: 0. "Hacky. Non regular fonts can not have derivatives. Should change this?" - boldOblique ifNotNil: [ - bold derivativeFont: boldOblique at: 3 ]. - ^bold ]. - boldOblique ifNotNil: [ - ^boldOblique ]. - ^nil! - -StrikeFont class removeSelector: #buildLargerPunctuation:! - -!methodRemoval: StrikeFont class #buildLargerPunctuation: stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:06:52'! -buildLargerPunctuation: familyName - " - StrikeFont buildLargerPunctuation: 'DejaVu Sans' - " - | form form2 f10 f11 f12 f9 | - - f9 _ AbstractFont familyName: familyName pointSize: 9. - f10 _ AbstractFont familyName: familyName pointSize: 10. - f11 _ AbstractFont familyName: familyName pointSize: 11. - f12 _ AbstractFont familyName: familyName pointSize: 12. - - - f9 takeGlyphFor: $. from: $. in: f12. - f9 takeGlyphFor: $, from: $, in: f12. - - form _ f9 glyphAt: $.. - form copy: (0@9 extent: 3@14) from: form to: 0@4 rule: Form and. - f9 glyphAt: $: put: form. - - form _ f9 glyphAt: $,. - form2 _ f9 glyphAt: $.. - form copy: (0@9 extent: 3@14) from: form2 to: 1@4 rule: Form and. - f9 glyphAt: $; put: form. - - - - f10 takeGlyphFor: $. from: $. in: f12. - f10 takeGlyphFor: $, from: $, in: f12. - - form _ f10 glyphAt: $. . - form copy: (0@9 extent: 3@14) from: form to: 0@4 rule: Form and. - f10 glyphAt: $: put: form. - - form _ f10 glyphAt: $,. - form2 _ f10 glyphAt: $.. - form copy: (0@9 extent: 3@14) from: form2 to: 1@4 rule: Form and. - f10 glyphAt: $; put: form. - - - - f11 takeGlyphFor: $. from: $. in: f12. - f11 takeGlyphFor: $, from: $, in: f12. - f11 takeGlyphFor: $: from: $: in: f12. - f11 takeGlyphFor: $; from: $; in: f12! - -StrikeFont removeSelector: #fixDerivatives! - -!methodRemoval: StrikeFont #fixDerivatives stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:06:52'! -fixDerivatives - self isBaseFont - ifTrue: [ - baseFont _ nil. - derivativeFonts ifNotNil: [ - derivativeFonts valuesDo: [ :der | - der ifNotNil: [ - der baseFont: self. - der fixDerivatives ]]]] - ifFalse: [ - derivativeFonts _ nil ].! - -StrikeFont removeSelector: #widen:by:! - -!methodRemoval: StrikeFont #widen:by: stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:06:52'! -widen: char by: delta - | newForm | - ^ self alter: char formBlock: "Make a new form, wider or narrower..." - [:charForm | newForm _ Form extent: charForm extent + (delta@0). - charForm displayOn: newForm. "Copy this image into it" - newForm] "and substitute it in the font"! - -StrikeFont removeSelector: #derivativeFont:at:! - -!methodRemoval: StrikeFont #derivativeFont:at: stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:06:52'! -derivativeFont: aStrikeFontOrNil at: index - "Store aStrikeFontOrNil at index - If arg is nil, then remove font at index. But if index = 0, then remove all derivatives." - - (aStrikeFontOrNil isNil and: [ index = 0 ]) - ifTrue: [ - derivativeFonts _ nil. - ^ self]. - - self isBaseFont ifFalse: [ - derivativeFonts _ nil. - self error: 'Derivative fonts can not have derivatives' ]. - - derivativeFonts ifNil: [ derivativeFonts _ Dictionary new ]. - aStrikeFontOrNil - ifNil: [ derivativeFonts removeKey: index ] - ifNotNil: [ - derivativeFonts at: index put: aStrikeFontOrNil. - aStrikeFontOrNil baseFont: self ]! - -StrikeFont removeSelector: #pointSize:! - -!methodRemoval: StrikeFont #pointSize: stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:06:52'! -pointSize: anInteger - pointSize _ anInteger! - -StrikeFont removeSelector: #checkCharacter:! - -!methodRemoval: StrikeFont #checkCharacter: stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:06:52'! -checkCharacter: character - "Answer a Character that is within the ascii range of the receiver--either - character or the last character in the receiver." - - | ascii | - ascii _ character numericValue. - ((ascii < minAscii) or: [ascii > maxAscii]) - ifTrue: [^maxAscii asCharacter] - ifFalse: [^character] -! - -StrikeFont removeSelector: #characterToGlyphMap:! - -!methodRemoval: StrikeFont #characterToGlyphMap: stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:06:52'! -characterToGlyphMap: anArray - characterToGlyphMap _ anArray.! - -StrikeFont removeSelector: #takeGlyphFor:from:in:! - -!methodRemoval: StrikeFont #takeGlyphFor:from:in: stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:06:52'! -takeGlyphFor: aCharacter from: sourceCharacter in: aFont - "Copy characterForm over the glyph for the argument, character." - | f r characterForm | - characterForm _ aFont glyphAt: sourceCharacter. - r _ 0@(0 + aFont ascent - self ascent) extent: characterForm width @ glyphs height. - f _ characterForm copy: r. - self glyphAt: aCharacter put: f! - -StrikeFont removeSelector: #alter:formBlock:! - -!methodRemoval: StrikeFont #alter:formBlock: stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:06:52'! -alter: char formBlock: formBlock - self - glyphAt: char - put: (formBlock value: (self glyphAt: char))! - -StrikeFont removeSelector: #buildFromForm:data:name:! - -!methodRemoval: StrikeFont #buildFromForm:data:name: stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:06:52'! -buildFromForm: allGlyphs data: data name: aString - - | x shortUnderscore firstGlyphInFiles | - pointSize _ data first asNumber. - ascent _ data second asNumber. - descent _ data third asNumber. - - firstGlyphInFiles _ 257-(data size-3). - minAscii _ 1. - maxAscii _ 255. - name _ aString. - type _ 0. "ignored for now" - superscript _ ascent - descent // 3. - subscript _ descent - ascent // 3. - emphasis _ 0. - - xTable _ (Array new: 258) atAllPut: 0. - maxWidth _ 0. - glyphs _ allGlyphs depth > 16 ifTrue: [ allGlyphs asFormOfDepth: 16 ] ifFalse: [ allGlyphs ]. - x _ 0. - 4 to: data size do: [ :i | - x _ (data at: i) asNumber. - xTable at: i+firstGlyphInFiles+1-4 put: x]. - xTable at: 258 put: x. - self reset. - derivativeFonts _ nil. - - self makeCrVisible. - - "Replace glyph for 127 (a box) with a short version of the underscore (used to optionally mark subscript in code)" - shortUnderscore _ self glyphAt: $_. - shortUnderscore _ shortUnderscore copy: (`0@0` extent: 1@shortUnderscore height). - self glyphAt: (Character numericValue: 127) put: shortUnderscore! - -StrikeFont removeSelector: #maxWidth! - -!methodRemoval: StrikeFont #maxWidth stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:06:52'! -maxWidth - "Answer the integer that is the width of the receiver's widest character." - - ^maxWidth! - -StrikeFont removeSelector: #derivativeFonts! - -!methodRemoval: StrikeFont #derivativeFonts stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:06:52'! -derivativeFonts - ^derivativeFonts! - -AbstractFont removeSelector: #derivativeFonts! - -!methodRemoval: AbstractFont #derivativeFonts stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:06:52'! -derivativeFonts - ^#()! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4214] on 11 June 2020 at 10:25:09 am'! - -AbstractFont class removeSelector: #familyName:pointSize:! - -!methodRemoval: AbstractFont class #familyName:pointSize: stamp: 'Install-4216-Font-Cleanup-JuanVuletich-2020Jun11-10h21m-jmv.001.cs.st 6/25/2020 16:06:52'! -familyName: aString pointSize: aNumber - " - Compatibility. - AbstractFont familyName: Preferences defaultFontFamily pointSize: 12 - " - false ifTrue: [ self deprecatedMethod ]. "Too much senders to activate warnings right now!!" - ^FontFamily familyName: aString pointSize: aNumber! - -AbstractFont class removeSelector: #default! - -!methodRemoval: AbstractFont class #default stamp: 'Install-4216-Font-Cleanup-JuanVuletich-2020Jun11-10h21m-jmv.001.cs.st 6/25/2020 16:06:52'! -default - " - Compatibility. - AbstractFont default - " - false ifTrue: [ self deprecatedMethod ]. "Too much senders to activate warnings right now!!" - ^FontFamily defaultFamilyAndPointSize! - -AbstractFont class removeSelector: #familyName:aroundPointSize:! - -!methodRemoval: AbstractFont class #familyName:aroundPointSize: stamp: 'Install-4216-Font-Cleanup-JuanVuletich-2020Jun11-10h21m-jmv.001.cs.st 6/25/2020 16:06:52'! -familyName: aString aroundPointSize: aNumber - " - Compatibility. - AbstractFont familyName: Preferences defaultFontFamily aroundPointSize: 120 - " - false ifTrue: [ self deprecatedMethod ]. "Too much senders to activate warnings right now!!" - ^FontFamily familyName: aString aroundPointSize: aNumber! - -AbstractFont class removeSelector: #pointSizesFor:! - -!methodRemoval: AbstractFont class #pointSizesFor: stamp: 'Install-4216-Font-Cleanup-JuanVuletich-2020Jun11-10h21m-jmv.001.cs.st 6/25/2020 16:06:52'! -pointSizesFor: aString - " - Compatibility. - AbstractFont pointSizesFor: Preferences defaultFontFamily - " - false ifTrue: [ self deprecatedMethod ]. "Too much senders to activate warnings right now!!" - ^FontFamily pointSizesFor: aString! - -AbstractFont class removeSelector: #familyNames! - -!methodRemoval: AbstractFont class #familyNames stamp: 'Install-4216-Font-Cleanup-JuanVuletich-2020Jun11-10h21m-jmv.001.cs.st 6/25/2020 16:06:52'! -familyNames - " - Compatibility. - AbstractFont familyNames - " - false ifTrue: [ self deprecatedMethod ]. "Too much senders to activate warnings right now!!" - ^FontFamily familyNames! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4216-Font-Cleanup-JuanVuletich-2020Jun11-10h21m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4214] on 11 June 2020 at 10:27:04 am'! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 6/11/2020 10:26:23' prior: 50523203! - preferencesMenu - "Build the preferences menu for the world." - - ^ (self menu: 'Preferences...') - addItemsFromDictionaries: { - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Font Sizes...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Set font...'. - #object -> FontPicker. - #selector -> #promptUserAndSetDefaultWithFamilies:. - #arguments -> {FontFamily familyNames}. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'change the current font family.' - } asDictionary. - { - #label -> 'Load extra fonts'. - #object -> FontFamily. - #selector -> #readAdditionalTrueTypeFonts. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'Load additional TrueType fonts included with Cuis.' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }! ! - -FontPicker class removeSelector: #familyNames! - -!methodRemoval: FontPicker class #familyNames stamp: 'Install-4217-Font-Cleanup-JuanVuletich-2020Jun11-10h25m-jmv.001.cs.st 6/25/2020 16:06:52'! -familyNames - | monospacedStrikeFont options | - monospacedStrikeFont _ 'DejaVu Sans Mono'. - options _ FontFamily familyNames. - (options includes: monospacedStrikeFont) ifFalse: [ - options _ options copyWith: monospacedStrikeFont ]. - ^ options! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4217-Font-Cleanup-JuanVuletich-2020Jun11-10h25m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4214] on 11 June 2020 at 10:33:07 am'! -!Text methodsFor: 'emphasis' stamp: 'jmv 6/11/2020 10:32:11' prior: 50522639! - fontIfApplying: textAttributes default: defaultFont - "Answer the font for characters as specified by the argument." - - | fn ps | - self withAttributeValues: textAttributes do: [ :familyName :pointSize :emphasis :color :alignment :characterStyle :paragraphStyle :backgroundColor | - fn _ familyName ifNil: [ defaultFont ifNotNil: [ defaultFont familyName ] ifNil: [ FontFamily defaultFamilyName ]]. - ps _ pointSize ifNil: [ defaultFont ifNotNil: [ defaultFont pointSize ] ifNil: [ FontFamily defaultPointSize ]]. - ^((FontFamily familyName: fn pointSize: ps) ifNil: [ FontFamily defaultFamilyAndPointSize ]) - emphasized: emphasis ]! ! -!AbstractFont class methodsFor: 'instance accessing' stamp: 'jmv 6/10/2020 23:17:59' prior: 16777426! - fromUser - " - AbstractFont fromUser - " - ^self fromUser: FontFamily defaultFamilyAndPointSize ! ! -!StrikeFont methodsFor: 'objects from disk' stamp: 'jmv 6/11/2020 10:30:27' prior: 50459088 overrides: 16881992! - objectForDataStream: refStrm - - "I am about to be written on an object file. Write a textual reference instead. - Warning: This saves a lot of space, but might fail if using other fonts than those in AvailableFonts" - - ^ DiskProxy - global: #FontFamily - selector: #familyName:pointSize: - args: (Array with: self familyName with: self pointSize)! ! -!StrikeFont methodsFor: 'synthetic derivatives' stamp: 'jmv 6/11/2020 10:30:32' prior: 50458850! - syntheticSubscript - "Build and answer a derivative that is Subscript." - - | derivative | - derivative _ ((FontFamily familyName: self familyName pointSize: pointSize * 0.58) - emphasized: emphasis) - copy. - derivative useShortUnderscore. - ^ derivative - -" -StrikeFont allInstances do: [ :a | a reset ]. -('Hi ', (Text string: 'there' attribute: TextEmphasis superscript), ' how ', (Text string: 'are' attribute: TextEmphasis subscript), ' you?') edit. -"! ! -!StrikeFont methodsFor: 'synthetic derivatives' stamp: 'jmv 6/11/2020 10:30:38' prior: 50458868! - syntheticSuperscript - "Build and answer a derivative that is Superscript." - - | derivative | - derivative _ ((FontFamily familyName: self familyName pointSize: pointSize * 0.58) - emphasized: emphasis) - copy. - derivative name: self name , 'Sup'. - ^ derivative - -" -StrikeFont allInstances do: [ :a | a reset ]. -('Hi ', (Text string: 'there' attribute: TextEmphasis superscript), ' how ', (Text string: 'are' attribute: TextEmphasis subscript), ' you?') edit. -"! ! -!FontFamily methodsFor: 'accessing' stamp: 'jmv 6/11/2020 10:29:28' prior: 50457051! - atPointSize: aNumber -" - ^baseFontBySizes at: aNumber ifAbsent: nil -" - ^baseFontBySizes at: aNumber ifAbsent: [ |found | - found _ nil. - baseFontBySizes do: [ :font | - (found isNil or: [ (found pointSize - aNumber) abs > (font pointSize - aNumber) abs ]) - ifTrue: [ found _ font ]]. - found - ]! ! - -FontFamily class removeSelector: #familyName:aroundPointSize:! - -!methodRemoval: FontFamily class #familyName:aroundPointSize: stamp: 'Install-4218-Font-Cleanup-JuanVuletich-2020Jun11-10h27m-jmv.001.cs.st 6/25/2020 16:06:52'! -familyName: aString aroundPointSize: aNumber - " - FontFamily familyName: 'DejaVu' aroundPointSize: 120 - " - | family | - family _ AvailableFamilies at: aString ifAbsent: [^nil]. - ^family aroundPointSize: aNumber! - -FontFamily removeSelector: #aroundPointSize:! - -!methodRemoval: FontFamily #aroundPointSize: stamp: 'Install-4218-Font-Cleanup-JuanVuletich-2020Jun11-10h27m-jmv.001.cs.st 6/25/2020 16:06:52'! -aroundPointSize: aNumber - ^baseFontBySizes at: aNumber ifAbsent: [ |found | - found _ nil. - baseFontBySizes do: [ :font | - (found isNil or: [ (found pointSize - aNumber) abs > (font pointSize - aNumber) abs ]) - ifTrue: [ found _ font ]]. - found - ]! - -Preferences class removeSelector: #setDefaultFonts:! - -!methodRemoval: Preferences class #setDefaultFonts: stamp: 'Install-4218-Font-Cleanup-JuanVuletich-2020Jun11-10h27m-jmv.001.cs.st 6/25/2020 16:06:52'! -setDefaultFonts: defaultFontsSpec - - | font | - defaultFontsSpec do: [ :triplet | - font _ FontFamily familyName: triplet second pointSize: triplet third. - font ifNil: [ font _ FontFamily defaultFamilyAndPointSize ]. - triplet size > 3 ifTrue: [ - font _ font emphasized: triplet fourth ]. - self - perform: triplet first - with: font]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4218-Font-Cleanup-JuanVuletich-2020Jun11-10h27m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4218] on 12 June 2020 at 11:30:20 am'! -!FontFamily class methodsFor: 'accessing fonts' stamp: 'jmv 6/11/2020 16:47:20' prior: 50456871! - familyName: aString pointSize: aNumber - " - FontFamily familyName: FontFamily defaultFamilyName pointSize: 12 - FontFamily defaultFamilyPointSize: 12 - " - | family | - family _ AvailableFamilies at: aString ifAbsent: [^nil]. - ^family atPointSize: aNumber! ! -!FontFamily class methodsFor: 'accessing fonts' stamp: 'jmv 6/11/2020 16:52:09' prior: 50503742! - familyNamed: aString - " - FontFamily familyNamed: FontFamily defaultFamilyName - " - ^AvailableFamilies at: aString ifAbsent: [].! ! -!FontFamily class methodsFor: 'accessing fonts' stamp: 'jmv 6/11/2020 16:39:34' prior: 50456921! - pointSizesFor: aString - " - FontFamily pointSizesFor: FontFamily defaultFamilyName - " - | family | - family _ AvailableFamilies at: aString ifAbsent: [^nil]. - ^family pointSizes! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -dict _ (FontFamily bindingOf: 'AvailableFamilies') value. -#('DejaVu Sans Mono' 'DejaVu') do: [ :familyName | - family _ FontFamily familyNamed: familyName. - family class = StrikeFontFamily ifTrue: [ - newName _ familyName, ' Bitmap'. - family instVarNamed: 'familyName' put: newName. - dict at: newName put: family. - dict removeKey: familyName. - FontFamily defaultFamilyName = familyName ifTrue: [ - FontPicker setDefaultFont: newName. - "FontFamily defaultFamilyName: newName defaultPointSize: nil" ]. - StrikeFont allInstancesDo: [ :sf | - ((sf name beginsWith: familyName) and: [ (sf name beginsWith: newName) not]) - ifTrue: [ sf name: (newName, (sf name copyFrom: familyName size+1 to: sf name size)) ]] - ]. -]. -StrikeFont allInstances collect: [ :sf | sf pointSize > 14 ifTrue: [ sf setGlyphsDepthAtMost: 4 ]]. -UISupervisor whenUIinSafeState: [self runningWorld recreateDefaultDesktop] -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4219-Font-Cleanup-JuanVuletich-2020Jun12-11h28m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4219] on 15 June 2020 at 1:43:33 pm'! -!WeakMessageSend commentStamp: '' prior: 16944070! - Instances of WeakMessageSend encapsulate message sends to objects, like MessageSend. Unlike MessageSend it is not necessarily a valid mesage. A request to value only results in a send if in fact it is valid. - -See MessageSendComments also. WeakMessageSend is used primarily for event regristration. - -Unlike MessageSend WeakMessageSend stores the receiver (object receiving the message send) as the first and only element of its array as opposed to a named ivar. -But like MessageSend, it does have - selector Symbol -- message selector - arguments Array -- bound arguments -and it also has - shouldBeNil Boolean -- used to ensure array of arguments is not all nils! -!Float commentStamp: '' prior: 50451040! - A note About Floating Point numbers and Floating Point Arithmetic. - -The following is not specific to Cuis or Smalltalk at all. This is about the properties of Float numbers in any computer implementation. - -If you haven't done so already, read https://en.wikipedia.org/wiki/Floating-point_arithmetic - -But if you find the Wikipedia article too detailed, or hard to read, then try http://fabiensanglard.net/floating_point_visually_explained/ (get past "How Floating Point are usually explained" and read "A different way to explain..."). - -Other great reads are: - "Why don't my numbers add up?": - http://floating-point-gui.de/ -and - "What Every Computer Scientist Should Know About Floating-Point Arithmetic": - http://docs.oracle.com/cd/E19957-01/806-3568/ncg_goldberg.html -and also maybe - "Comparing floating point numbers" - https://randomascii.wordpress.com/2012/02/25/comparing-floating-point-numbers-2012-edition/ - -Now that you read them, and we are on the same boat, some further comments (from jmv): - -Floats are (conceptually) approximate real numbers. That's why trig and other trascendental functions always answer Floats. That's why it is ok to round the result of operations. That's why Float is considered more general than Fraction in ST-80 and most Smalltalks. So, when we have a Float value, we must not think about it as a Rational but as a Real (actually as some unknown Real that could hopefully be close to the Rational we can actually represent). Keep this in mind when dealing with Floats, and especially avoid comparing them for equality. - -When doing mixed operations with Floats and Fractions, Cuis, as most other Smalltalks, converts all values to Floats. Some other systems, including Pharo Smalltalk, Scheme and Lisp have two rules: when the answer is a Number, they convert to Float. But when the answer is a boolean (#<, #=, #<=, etc.) they convert to Fraction. We think this is a mistake. There should never be implicit conversions from Float to Fraction. Fractions are to hold exact values, and people expect Fractions to be exact. On the other hand, Floats are to hold approximations (and people should be aware of that!!). But an implicit conversion from Float to Fraction would give a Fraction that should not be considered an exact value (the value comes from an inexact Float), but that knowledge is lost, as it is an instance of Fraction. - -If you want exact arithmetic, usual mathematical properties (like transitivity of equality), can live in the limited world of Rational numbers, and can afford a slight performance penalty, use Fraction instead. Avoid trascendental functions and never convert to Float. - -In any case, most numeric computation is done on Float numbers. There are good reasons for that. One is that in most cases we don't need an exact answer. And in many cases we can't really have it: the inputs to algorithms already have a limited precision, or they use transcendental functions. And even when exact arithmetic is possible, if we are doing sound synthesis, 24 bits of resolution is enough. For image processing and graphics, the result is never more than 16 bits per channel. So, these fields don't really need 64 bit Doubles. 32 bit Floats are enough. Other fields do need 64 bit Doubles, like physics simulations and geometry. Games usually prefer special, faster 32 bit Float operations in GPUs that have greater errors but are faster. - -There are some things that can be done to increase the confidence you can have on Float results. One is to do an error propagation analysis on the code you are running. This is not easy, but it is done for any widely used numerical method. Then, you can know real bounds and/or estimates of the errors made. So, understanding your inputs and your algorithms (for example error propagation, condition number, numeric stability), and using Float number if appropriate, is the usual advice. - -Perhaps you have heard about "interval arithmetic". It is a bit better than simple Float, but doesn't really fix the problems. - -The ultimate solution is to do Monte Carlo analysis, with random perturbation of inputs. After the Monte Carlo run, it is needed to do statistical analysis of possible correlations between the distributions of the random noise added to imputs and the result of the algorithm. - -Additional food for thought: http://www.cs.berkeley.edu/~wkahan/Mindless.pdf . According to this, doing Monte Carlo as described above attacks a slightly different problem. This might be yet another reason (besides performance) to try something like the next paragraph. I (jmv) came up with it, and I don't really know if it has been described and or tried before or not. Mhhh. Maybe a defensive publication is in order. - -A possibility that could be a practical solution, being much cheaper than Monte Carlo, but better than interval arithmetic, is to represent each value by 2 Floats: an estimation of the real value (i.e. an estimation of the mean value of the distribution of the corresponding Monte Carlo result), and an estimation of the error (i.e. an estimation of the standard deviation of the corresponding Monte Carlo result). Or perhaps even 3 of them. In addition to the estimation of the real value and an estimation of the error, we could add a hard bound on the error. In many cases it will be useless, because the error can not really be bound. But in those cases where it is possible to bound it, applications could really know about the quality of computed values. - -======================================================================= - -My instances represent IEEE 754 floating-point double-precision numbers. They have about 16 decimal digits of accuracy and their range is between plus and minus 10^307. Some valid examples are: - - 8.0 13.3 0.3 2.5e6 1.27e-30 1.27e-31 -12.987654e12 - -Mainly: no embedded blanks, little e for tens power, and a digit on both sides of the decimal point. It is actually possible to specify a radix for Float constants. This is great for teaching about numbers, but may be confusing to the average reader: - - 3r20.2 --> 6.66666666666667 - 8r20.2 --> 16.25 - -If you don't have access to the definition of IEEE754, you can figure out what is going on by printing various simple values in Float hex. It may help you to know that the basic format is... - sign 1 bit - exponent 11 bits with bias of 1023 (16r3FF), substracted to produce an actual exponent in the range -1022 .. +1023 - - 16r000: - significand = 0: Float zero - significand ~= 0: Denormal number (actual exponent is -1022, not -1023. No implicit leading '1' bit in mantissa) - - 16r7FF: - significand = 0: Infinity - significand ~= 0: Not A Number (NaN) representation - mantissa 53 bits, but only 52 are stored (20 in the first word, 32 in the second). This is because a normalized mantissa, by definition, has a 1 to the right of its floating point, and IEEE 754 omits this redundant bit to gain an extra bit of precision instead. People talk about the mantissa without its leading one as the FRACTION, and with its leading 1 as the SIGNFICAND. - -The single-precision format is... - sign 1 bit - exponent 8 bits with bias of 127 (16r7F, substracted to produce an actual exponent in the range -126 .. +127 - - 16r00: - significand = 0: Float zero - significand ~= 0: Denormal number (actual exponent is -126, not -127. No implicit leading '1' bit in mantissa) - - 16rFF: - significand = 0: Infinity - significand ~= 0: Not A Number (NaN) representation - mantissa 24 bits, but only 23 are stored -This format is used in FloatArray (qv), and much can be learned from the conversion routines, Float asIEEE32BitWord, and Float class fromIEEE32Bit:. - -You might also check https://en.wikipedia.org/wiki/IEEE_754_revision - -Other great reads (covering broader but interesting issues): -https://randomascii.wordpress.com/2013/07/16/floating-point-determinism/ -https://web.archive.org/web/20150909015114/http://www.ima.umn.edu/2010-2011/W1.10-14.11/activities/Leeser-Miriam/Leeser-GPU-IMA-Jan2011.pdf -! -!SmallInteger commentStamp: '' prior: 16908586! - In 32-bit images my instances are 31-bit numbers, stored in twos complement form. The allowable range is approximately +- 1 billion. - -In 64-bit images my instances are 61-bit numbers, stored in twos complement form. The allowable range is approximately +- 10^18 (+- 1 quintillion) - -(See SmallInteger minVal, maxVal). - -Of the various classes in the Number hierarchy, SmallInteger gives: -- Maximum performance -- Top precision -- Restricted possible values - -LargePositive(Negative)Integer and Fraction give increasing generality (more possible values) at the expense of performance. - -Float gives more generality at the expense of precision. - -Please see the class comments of the other Number classes.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4220-CommentFixes-DouglasBrebner-2020Jun15-13h40m-db.001.cs.st----! - -'From Cuis 5.0 [latest update: #4219] on 13 June 2020 at 5:33:51 pm'! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 6/13/2020 17:06:24'! - setDefaultFont: aFontName - "Change the font on the whole system without changing point sizes." - FontFamily defaultFamilyName: aFontName. - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: { - {#setListFontTo:. Preferences standardListFont pointSize.}. - {#setMenuFontTo:. Preferences standardMenuFont pointSize.}. - {#setWindowTitleFontTo:. Preferences windowTitleFont pointSize.}. - {#setCodeFontTo:. Preferences standardCodeFont pointSize.}. - {#setButtonFontTo:. Preferences standardButtonFont pointSize.}. - }. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]. - -! ! -!FontFamily class methodsFor: 'ui' stamp: 'jmv 6/13/2020 17:32:17'! - promptUser - "Present a menu of font families, answer selection. - FontFamily promptUser - " - | fontMenu priorFontFamily | - priorFontFamily _ FontFamily defaultFamilyName. - fontMenu _ MenuMorph new. - FontFamily familyNames do: [:fontName | - fontMenu - add: ((priorFontFamily sameAs: fontName) ifTrue: [''] ifFalse: [''] ), fontName - target: fontMenu - action: #modalSelection: - argument: fontName. - ]. - ^FontFamily familyNamed: fontMenu invokeModal.! ! -!FontFamily class methodsFor: 'ui' stamp: 'jmv 6/13/2020 17:32:58'! - promptUserAndSetDefault - "Present a menu of available font families, and if one is chosen, change to it. - FontFamily promptUserAndSetDefault - " - self promptUser ifNotNil: [ :fontFamily | Preferences setDefaultFont: fontFamily familyName ]! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 6/13/2020 17:32:34' prior: 50523783! - preferencesMenu - "Build the preferences menu for the world." - - ^ (self menu: 'Preferences...') - addItemsFromDictionaries: { - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Font Sizes...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Set System Font...'. - #object -> FontFamily. - #selector -> #promptUserAndSetDefault. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'change the current system font family.' - } asDictionary. - { - #label -> 'Load extra fonts'. - #object -> FontFamily. - #selector -> #readAdditionalTrueTypeFonts. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'Load additional TrueType fonts included with Cuis.' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }! ! - -Smalltalk removeClassNamed: #FontPicker! - -!classRemoval: #FontPicker stamp: 'Install-4221-FontPicker-remove-JuanVuletich-2020Jun13-17h23m-jmv.002.cs.st 6/25/2020 16:06:52'! -Object subclass: #FontPicker - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4221-FontPicker-remove-JuanVuletich-2020Jun13-17h23m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4221] on 16 June 2020 at 6:17:57 pm'! -!MenuItemMorph methodsFor: 'layout' stamp: 'jmv 6/14/2020 18:18:47'! - magnifiedIcon - - | iconForm w h factor magnifiedExtent magnifiedIcon | - icon ifNil: [ ^nil ]. - iconForm _ isEnabled ifTrue: [ icon ] ifFalse: [ icon asGrayScaleAndTransparent ]. - magnifiedIcon _ iconForm. - w _ iconForm width. - h _ iconForm height. - w*h = 0 ifFalse: [ - factor _ extent y * 0.8 / h. - factor = 1.0 ifFalse: [ - magnifiedExtent _ (iconForm extent * factor) rounded. - magnifiedIcon _ iconForm magnifyTo: magnifiedExtent ]]. - ^magnifiedIcon! ! -!MenuItemMorph methodsFor: 'drawing' stamp: 'jmv 6/14/2020 18:19:11' prior: 50503530 overrides: 50503483! - drawOn: aCanvas - | stringColor leftEdge magnifiedIcon | - - stringColor _ color. - isSelected & isEnabled - ifTrue: [ - aCanvas fillRectangle: self morphLocalBounds color: Theme current menuHighlight]. - leftEdge _ 0. - - self hasMarker ifTrue: [ - leftEdge _ leftEdge + submorphs first morphWidth + 8 ]. - - icon ifNotNil: [ - magnifiedIcon _ self magnifiedIcon. - aCanvas image: magnifiedIcon at: leftEdge+1 @ (magnifiedIcon height *1//10). - leftEdge _ magnifiedIcon width *12//10 + leftEdge]. - - aCanvas - drawString: contents - at: leftEdge @ 1 - font: self fontToUse - color: stringColor. - subMenu ifNotNil: [ - aCanvas - image: self class subMenuMarker - at: extent x - 8 @ (extent y - self class subMenuMarker height // 2) ]! ! -!MenuItemMorph methodsFor: 'layout' stamp: 'jmv 6/14/2020 18:19:22' prior: 50472369 overrides: 16876050! - minItemWidth - | fontToUse iconWidth subMenuWidth markerWidth | - fontToUse _ self fontToUse. - subMenuWidth _ self hasSubMenu - ifFalse: [0] - ifTrue: [10]. - iconWidth _ icon - ifNotNil: [self magnifiedIcon width * 12//10] - ifNil: [0]. - markerWidth _ self hasMarker - ifTrue: [ submorphs first morphWidth + 8 ] - ifFalse: [ 0 ]. - ^ (fontToUse widthOfString: contents) - + subMenuWidth + iconWidth + markerWidth.! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 6/14/2020 18:04:51' prior: 50524483! -preferencesMenu - "Build the preferences menu for the world." - - ^ (self menu: 'Preferences...') - addItemsFromDictionaries: { - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Font Sizes...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Set System Font...'. - #object -> FontFamily. - #selector -> #promptUserAndSetDefault. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'change the current system font family.' - } asDictionary. - { - #label -> 'Load all TrueType Fonts'. - #object -> FontFamily. - #selector -> #readAdditionalTrueTypeFonts. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'Load additional TrueType fonts included with Cuis.' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }! ! - -MenuItemMorph removeSelector: #iconSeparation! - -!methodRemoval: MenuItemMorph #iconSeparation stamp: 'Install-4222-MenuFix-JuanVuletich-2020Jun16-18h17m-jmv.001.cs.st 6/25/2020 16:06:52'! -iconSeparation - ^5! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4222-MenuFix-JuanVuletich-2020Jun16-18h17m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4222] on 16 June 2020 at 6:59:04 pm'! -!FontFamily methodsFor: 'accessing' stamp: 'jmv 6/16/2020 18:30:05'! - folderName - ^nil! ! -!FontFamily class methodsFor: 'accessing' stamp: 'jmv 6/16/2020 18:43:47'! - availableFamilies - ^AvailableFamilies! ! -!FontFamily class methodsFor: 'ui' stamp: 'jmv 6/16/2020 18:56:36'! - promptUserAlt - "Present a menu of font families, answer selection. - Alternative implementation: Show only installed fonts. - FontFamily promptUserAlt - " - | fontMenu priorFontFamily | - priorFontFamily _ FontFamily defaultFamilyName. - fontMenu _ MenuMorph new. - FontFamily familyNames do: [:fontName | - fontMenu - add: ((priorFontFamily sameAs: fontName) ifTrue: [''] ifFalse: [''] ), fontName - target: fontMenu - action: #modalSelection: - argument: fontName. - ]. - ^FontFamily familyNamed: fontMenu invokeModal.! ! -!FontFamily class methodsFor: 'ui' stamp: 'jmv 6/16/2020 18:58:14' prior: 50524455! - promptUser - "Present a menu of font families, answer selection. - FontFamily promptUser - " - | menu selectedDirectory dejaVuBitmap current this | - current _ (FontFamily familyNamed: FontFamily defaultFamilyName) folderName. - menu _ MenuMorph new. - ((DirectoryEntry smalltalkImageDirectory / 'TrueTypeFonts') - directories sorted: [ :a :b | a name < b name ]) do: [ :dir | | subDirs | - subDirs _ dir directories sorted: [ :a :b | a name < b name ]. - subDirs isEmpty - ifTrue: [ - this _ dir name. - menu - add: (this=current ifTrue: [''] ifFalse: ['']), this - target: menu - action: #modalSelection: - argument: dir ] - ifFalse: [ | submenu | - submenu _ MenuMorph new. - subDirs do: [ :subdir | - this _ subdir name. - submenu - add: (this=current ifTrue: [''] ifFalse: ['']), this - target: menu - action: #modalSelection: - argument: subdir ]. - menu add: dir name, '... ' subMenu: submenu - ]]. - dejaVuBitmap _ 'DejaVu Bitmap'. - menu - add: (dejaVuBitmap = FontFamily defaultFamilyName ifTrue: [''] ifFalse: ['']), dejaVuBitmap - target: menu - action: #modalSelection: - argument: this. - selectedDirectory _ menu invokeModal. - selectedDirectory = this - ifTrue: [ ^FontFamily familyNamed: dejaVuBitmap ]. - selectedDirectory isNil ifTrue: [ ^nil ]. - ^FontFamily availableFamilies values - detect: [ :any | any folderName = selectedDirectory name ] - ifNone: [ - Feature require: 'VectorGraphics'. - FontFamily familyNamed: ((Smalltalk at: #TrueTypeFontFamily) read: selectedDirectory) anyOne ]! ! -!FontFamily class methodsFor: 'ui' stamp: 'jmv 6/13/2020 17:32:58' prior: 50524472! - promptUserAndSetDefault - "Present a menu of available font families, and if one is chosen, change to it. - FontFamily promptUserAndSetDefault - " - self promptUser ifNotNil: [ :fontFamily | Preferences setDefaultFont: fontFamily familyName ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4223-NewFontMenu-JuanVuletich-2020Jun16-18h21m-jmv.003.cs.st----! - -'From Cuis 5.0 [latest update: #4223] on 16 June 2020 at 7:25:31 pm'! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 6/16/2020 19:24:29' prior: 50522511 overrides: 50388601! - drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - | p1 font | - p1 _ (currentTransformation transform: aPoint rounded) rounded. - engine colorMap: nil. - font _ fontOrNil ifNil: [ FontFamily defaultFamilyAndPointSize ]. - - aColor = `Color black` ifFalse: [ | topColor | - topColor _ aColor alphaMixed: 0.25 with: `Color black`. - font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: topColor ]. - aColor = `Color white` ifFalse: [ | bottomColor | - bottomColor _ aColor alphaMixed: 0.22 with: `Color white`. - font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + `0@2` - color: bottomColor ]. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + `0@1` - color: aColor.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4224-EmbossedTextFix-JuanVuletich-2020Jun16-19h12m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4224] on 16 June 2020 at 7:41:14 pm'! -!Text methodsFor: 'emphasis' stamp: 'jmv 6/16/2020 19:36:42' prior: 50370548! - withAttributeValues: attributes do: aBlock - "Evaluate aBlock with the values of various attributes that affect text formatting, applied in the correct order - The order is (each overwriting the previous one) - 1) basic defaults - 2) ParagraphStyleReferene - 3) CharacterStyleReference - 4) TextFontReference - 5) TextEmphasis" - - | paragraphStyle characterStyle familyName pointSize emphasis alignment color backgroundColor | - paragraphStyle _ nil. - characterStyle _ nil. - familyName _ nil. - pointSize _ nil. - emphasis _ 0. - alignment _ 0. - color _ nil. - backgroundColor _ nil. - - "ParagraphStyle is the first to set several values" - attributes do: [ :attribute | - attribute forParagraphStyleReferenceDo: [ :s | - paragraphStyle _ s. - familyName _ s familyName. - pointSize _ s pointSize. - emphasis _ s emphasis. - alignment _ s alignment. - s color ifNotNil: [ :c | color _ c ]]]. - - "CharacterStyle, if present, can override font and color" - attributes do: [ :attribute | - attribute forCharacterStyleReferenceDo: [ :s | - characterStyle _ s. - familyName _ s familyName. - pointSize _ s pointSize. - emphasis _ s emphasis. - s color ifNotNil: [ :c | color _ c ]]]. - - "These will not interfere with each other, and all of them take precedence over previous values" - attributes do: [ :attribute | - attribute forFontFamilyAndSizeDo: [ :fn :ps | fn notNil ifTrue: [familyName _ fn]. pointSize _ ps ]. - attribute forTextEmphasisDo: [ :e | emphasis _ emphasis bitOr: e ]. - attribute forTextColorDo: [ :c | color _ c ]. - attribute forTextBackgroundColorDo: [ :c | backgroundColor _ c ]. - attribute forTextAlignmentDo: [ :a | alignment _ a ]. - ]. - - "Done. Now evaluate the block." - ^aBlock valueWithArguments: { familyName. pointSize. emphasis. color. alignment. characterStyle. paragraphStyle. backgroundColor }! ! -!TextFontFamilyAndSize methodsFor: 'accessing' stamp: 'jmv 6/16/2020 19:37:03' prior: 16933387! - familyName: aStringOrNil pointSize: aNumber - familyName _ aStringOrNil. - pointSize _ aNumber! ! -!TextFontFamilyAndSize methodsFor: 'accessing' stamp: 'jmv 6/16/2020 19:35:53' prior: 50522785! -font - - ^familyName isNil - ifTrue: [ FontFamily defaultFamilyPointSize: pointSize] - ifFalse: [ FontFamily familyName: familyName pointSize: pointSize ]! ! -!TextFontFamilyAndSize class methodsFor: 'instance creation' stamp: 'jmv 6/16/2020 19:39:55' prior: 50471655! - pointSize: aNumber - "Reference only default family baseFont. Any emphasis should be done with TextEmphasis. - Store only pointSize" - ^ self new familyName: nil pointSize: aNumber! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4225-TextAttributesFix-JuanVuletich-2020Jun16-19h33m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4225] on 16 June 2020 at 8:00:35 pm'! -!FontFamily class methodsFor: 'ui' stamp: 'jmv 6/16/2020 19:59:24' prior: 50524807! - promptUser - "Present a menu of font families, answer selection. - FontFamily promptUser - " - | menu selectedNameOrDirectory familyName current | - current _ (FontFamily familyNamed: FontFamily defaultFamilyName) folderName. - menu _ MenuMorph new. - ((DirectoryEntry smalltalkImageDirectory / 'TrueTypeFonts') - directories sorted: [ :a :b | a name < b name ]) do: [ :dir | | subDirs | - subDirs _ dir directories sorted: [ :a :b | a name < b name ]. - subDirs isEmpty - ifTrue: [ | this | - this _ dir name. - menu - add: (this=current ifTrue: [''] ifFalse: ['']), this - target: menu - action: #modalSelection: - argument: dir ] - ifFalse: [ | submenu this | - submenu _ MenuMorph new. - subDirs do: [ :subdir | - this _ subdir name. - submenu - add: (this=current ifTrue: [''] ifFalse: ['']), this - target: menu - action: #modalSelection: - argument: subdir ]. - menu add: dir name, '... ' subMenu: submenu - ]]. - FontFamily availableFamilies values do: [ :family | - family folderName isNil ifTrue: [ - familyName _ family familyName. - menu - add: (familyName = FontFamily defaultFamilyName ifTrue: [''] ifFalse: ['']), familyName - target: menu - action: #modalSelection: - argument: familyName ]]. - selectedNameOrDirectory _ menu invokeModal. - selectedNameOrDirectory isNil ifTrue: [ ^nil ]. - (FontFamily familyNamed: selectedNameOrDirectory) - ifNotNil: [ :it | ^it ]. - ^FontFamily availableFamilies values - detect: [ :any | any folderName = selectedNameOrDirectory name ] - ifNone: [ - Feature require: 'VectorGraphics'. - FontFamily familyNamed: ((Smalltalk at: #TrueTypeFontFamily) read: selectedNameOrDirectory) anyOne ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4226-FontMenuFix-JuanVuletich-2020Jun16-19h49m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4226] on 18 June 2020 at 9:33:45 am'! -!BrowserWindow class methodsFor: 'GUI building' stamp: 'HAW 6/18/2020 09:31:57'! - classNameRequester - - ^ClassNameRequestMorph! ! -!BrowserWindow class methodsFor: 'GUI building' stamp: 'HAW 6/18/2020 09:32:01'! - findClassDialogTitle - - ^ 'Class name or fragment?'! ! -!BrowserWindow class methodsFor: 'GUI building' stamp: 'HAW 6/18/2020 09:27:38' prior: 50514918! - findClassFrom: potentialClassNames ifFound: aBlock - | classNames exactMatch foundClass index toMatch | - self classNameRequester request: self findClassDialogTitle initialAnswer: '' do: [:pattern| - pattern isEmpty - ifTrue: [self flash] - ifFalse: - [toMatch _ (pattern copyWithout: $.) asLowercase withBlanksTrimmed. - classNames _ (pattern last = $. or: [pattern last = $ ]) - ifTrue: [potentialClassNames select: [:nm | nm asLowercase = toMatch]] - ifFalse: [potentialClassNames select: [:n | n includesSubstring: toMatch caseSensitive: false]]. - classNames isEmpty - ifTrue: [self flash] - ifFalse: - [exactMatch _ classNames detect: [ :each | each asLowercase = toMatch] ifNone: nil. - - index _ classNames size = 1 - ifTrue: [ 1 ] - ifFalse: [ exactMatch - ifNil: [(PopUpMenu labelArray: classNames lines: #()) startUpMenu] - ifNotNil: [classNames addFirst: exactMatch. - (PopUpMenu labelArray: classNames lines: #(1)) startUpMenu]]. - - index = 0 - ifTrue: [self flash] - ifFalse: - [foundClass _ Smalltalk at: (classNames at: index) asSymbol. - - aBlock value: foundClass]]]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4227-findClassCustomization-HernanWilkinson-2020Jun17-16h06m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4226] on 18 June 2020 at 4:10:54 pm'! -!Scanner methodsFor: 'xBacktick processing - private' stamp: 'HAW 6/18/2020 16:09:06'! - assertNodesIn: methodNode canBeReferencedInsideBacktickUsing: compiler - - ^ methodNode nodesDo: [ :aNode | - (self canNotBeReferencedInsideBacktick: aNode) ifTrue: [ - compiler notify: (self class canNotReferencePseudoVarInsideBacktickErrorDescriptionFor: aNode key) ]]! ! -!Scanner methodsFor: 'xBacktick processing - private' stamp: 'HAW 6/18/2020 16:09:27'! - canNotBeReferencedInsideBacktick: aNode - - ^ aNode isSelfPseudoVariable - or: [ aNode isSuperPseudoVariable - or: [ aNode isThisContextPseudoVariable ]]! ! -!Scanner class methodsFor: 'xBacktick processing - private' stamp: 'HAW 6/18/2020 15:39:25'! - canNotReferencePseudoVarInsideBacktickErrorDescriptionFor: pseudoVariable - - ^ 'Can not reference ', pseudoVariable, ' inside backtick'! ! -!Scanner methodsFor: 'xBacktick processing - private' stamp: 'HAW 6/18/2020 16:09:14' prior: 50445145! - compileBacktickCode - - | compiler method methodNode | - - compiler _ Compiler new. - methodNode _ compiler compileNoPattern: buffer contents in: UndefinedObject context: nil notifying: nil ifFail: []. - self assertNodesIn: methodNode canBeReferencedInsideBacktickUsing: compiler. - method _ methodNode generate. - - "Grab all messages sent while evaluating literal, so the main method will be shown as senders of them" - sentInLiterals addAll: method messages. - method literalsDo: [ :literal | literal isSymbol ifTrue: [ literal = self class doItSelector ifFalse: [sentInLiterals add: literal ]]]. - - "Evaluate now." - token _ nil withArgs: #() executeMethod: method ! ! - -Scanner removeSelector: #canNotReferencePseudoVarInsideBacktickErrorDescriptionFor:! - -Scanner removeSelector: #canNotReferencePseudoVarInsideBacktickErrorDescriptionFor! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4228-CanNotReferenceSelfSuperThisContextInsideBacktick-HernanWilkinson-2020Jun18-15h25m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4228] on 19 June 2020 at 1:29:46 pm'! -!String methodsFor: 'grammar' stamp: 'LC 6/19/2020 12:52:49' prior: 50507966! - exceptionalPlural - | singular plural index | - singular := #( - 'addendum' 'aircraft' 'alga' 'alumna' 'alumnus' 'amoeba' 'antenna' 'appendix' 'automaton' - 'bacillus' 'bacterium' 'barracks' - 'cactus' 'calculus' 'child' 'cicatrix' 'colossus' 'corpus' 'corrigendum' 'criterion' 'curriculum' - 'datum' 'deer' 'desideratum' 'dwarf' - 'echo' 'embargo' 'ephemeris' 'erratum' 'extremum' - 'fish' 'focus' 'foot' 'forum' 'fungus' - 'gallows' 'genus' 'goose' - 'hero' - 'index' 'infimum' 'is' - 'lacuna' 'larva' 'louse' - 'matrix' 'maximum' 'means' 'memorandum' 'minimum' 'mythos' 'money' 'mouse' - 'nucleus' - 'offspring' 'optimum' 'opus' 'ox' - 'person' 'phenomenon' 'phylum' 'potato' 'proof' - 'quantum' - 'roof' - 'series' 'sheep' 'species' 'spoof' 'stimulus' 'stratum' 'syllabus' - 'tomato' 'tooth' 'torpedo' 'trilby' - 'vertebra' 'vertex' 'veto' - 'was'). - plural := #( - 'addenda' 'aircraft' 'algae' 'alumnae' 'alumni' 'amoebae' 'antennae' 'appendices' 'automata' - 'bacilli' 'bacteria' 'barracks' - 'cacti' 'calculi' 'children' 'cicatrices' 'colossi' 'corpora' 'corrigenda' 'criteria' 'curricula' - 'data' 'deer' 'desiderata' 'dwarfs' - 'echoes' 'embargoes' 'ephemerides' 'errata' 'extrema' - 'fish' 'foci' 'feet' 'fora' 'fungi' - 'gallows' 'genera' 'geese' - 'heroes' - 'indices' 'infima' 'are' - 'lacunae' 'larvae' 'lice' - 'matrices' 'maxima' 'means' 'memoranda' 'minima' 'mythoi' 'moneys' 'mice' - 'nuclei' - 'offspring' 'optima' 'opera' 'oxen' - 'people' 'phenomena' 'phyla' 'potatoes' 'proofs' - 'quanta' - 'roofs' - 'series' 'sheep' 'species' 'spoofs' 'stimuli' 'strata' 'syllabi' - 'tomatoes' 'teeth' 'torpedoes' 'trilbys' - 'vertebrae' 'vertices' 'vetoes' - 'were'). - index := singular indexOf: self. - ^index > 0 ifTrue: [plural at: index]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4229-asPlural-improvements-LeandroCaniglia-2020Jun19-12h52m-LC.001.cs.st----! - -'From Cuis 5.0 [latest update: #4213] on 16 June 2020 at 7:48:29 pm'! - -"Change Set: 4214-CuisCore-AuthorName-2020Jun08-23h50m -Date: 16 June 2020 -Author: Nahuel Garbezza - -Use consistently class methods to create MethodReference instances"! -!ProtocolBrowser methodsFor: 'private' stamp: 'RNG 6/9/2020 00:16:22' prior: 16896698! - onSubProtocolOf: aClass - "Initialize with the entire protocol for the class, aClass, - but excluding those inherited from Object." - | selectors | - selectors _ Set new. - (aClass withAllSuperclassesPreviousTo: Object) - do: [ :each | selectors addAll: each selectors ]. - self - initListFrom: selectors asArray sort - highlighting: aClass.! ! -!ChangeList methodsFor: 'menu actions' stamp: 'RNG 6/8/2020 23:53:46' prior: 16796147! - currentVersionsOfSelections - "Opens a message-list browser on the current in-memory versions of all methods that are currently seleted" - | aList | - - aList _ OrderedCollection new. - 1 to: changeList size do: [ :i | - (listSelections at: i) ifTrue: [ - | aClass aChange | - aChange _ changeList at: i. - (aChange changeType == #method - and: [(aClass _ aChange changeClass) notNil - and: [aClass includesSelector: aChange methodSelector]]) - ifTrue: [ - aList add: (MethodReference - class: aClass - selector: aChange methodSelector)]]]. - ^ aList! ! -!SystemDictionary methodsFor: 'retrieving' stamp: 'RNG 6/9/2020 00:10:27' prior: 16921493! - allCallsOn: firstLiteral and: secondLiteral - "Answer a SortedCollection of all the methods that call on both aLiteral - and secondLiteral." - - | aCollection secondArray firstSpecial secondSpecial firstByte secondByte | - aCollection _ SortedCollection new. - firstSpecial _ self hasSpecialSelector: firstLiteral ifTrueSetByte: [:b | firstByte _ b]. - secondSpecial _ self hasSpecialSelector: secondLiteral ifTrueSetByte: [:b | secondByte _ b]. - self allBehaviorsDo: [ :class | - secondArray _ class - whichSelectorsReferTo: secondLiteral - special: secondSpecial - byte: secondByte. - ((class whichSelectorsReferTo: firstLiteral special: firstSpecial byte: firstByte) select: [ :aSel | - (secondArray includes: aSel)]) do: [ :sel | - aCollection add: (MethodReference class: class selector: sel )]]. - ^aCollection! ! -!SystemDictionary methodsFor: 'retrieving' stamp: 'RNG 6/9/2020 00:10:45' prior: 16921626! - allImplementorsOf: aSelector - "Answer a SortedCollection of all the methods that implement the message - aSelector." - - | aCollection | - - aCollection _ SortedCollection new. - self allBehaviorsDo: [ :class | - (class includesSelector: aSelector) ifTrue: [ - aCollection add: (MethodReference class: class selector: aSelector )]]. - ^aCollection! ! -!SystemDictionary methodsFor: 'retrieving' stamp: 'RNG 6/9/2020 00:01:28' prior: 16921641! - allImplementorsOf: aSelector localTo: aClass - "Answer a sorted Collection of all the methods that implement the message - aSelector in, above, or below the given class." - - | aSet cls | - aSet _ Set new. - cls _ aClass theNonMetaClass. - cls withAllSuperAndSubclassesDoGently: [ :class | - (class includesSelector: aSelector) - ifTrue: [ aSet add: (MethodReference class: class selector: aSelector) ] ]. - cls class withAllSuperAndSubclassesDoGently: [ :class | - (class includesSelector: aSelector) - ifTrue: [ aSet add: (MethodReference class: class selector: aSelector) ] ]. - ^aSet asArray sort! ! -!SystemDictionary methodsFor: 'retrieving' stamp: 'RNG 6/8/2020 23:50:24' prior: 16921665! - allMethodsInCategory: category - | aCollection | - aCollection := SortedCollection new. - self allBehaviorsDo: [ :x | - (x organization listAtCategoryNamed: category) do: [ :sel | - aCollection add: (MethodReference class: x method: sel)]]. - ^aCollection! ! -!SystemDictionary methodsFor: 'retrieving' stamp: 'RNG 6/8/2020 23:56:43' prior: 50366127! - allMethodsSourceStringMatching: aString - "Answer a sorted Collection of all the methods that contain, in source code, aString as a substring. - Search the class comments also. - Argument might include $*, that matches any subsequence. - For example, try: - ensure:*[*close*] - " - | list classCount adder | - list _ Set new. - adder _ [ :mrClass :mrSel | - list add: (MethodReference class: mrClass selector: mrSel) ]. - 'Searching all source code...' - displayProgressAt: Sensor mousePoint - from: 0 - to: Smalltalk classNames size - during: [ :barBlock | - classCount _ 0. - Smalltalk allClassesDo: [ :class | - barBlock value: (classCount _ classCount + 1). - (Array - with: class - with: class class) do: [ :cl | - cl selectorsDo: [ :sel | - (aString match: (cl sourceCodeAt: sel)) ifTrue: [ - adder - value: cl - value: sel ]]. - - (aString match: cl organization classComment asString) ifTrue: [ - adder - value: cl - value: #Comment ]]]]. - ^ list asArray sort.! ! -!SystemDictionary methodsFor: 'retrieving' stamp: 'RNG 6/8/2020 23:56:34' prior: 50366163! - allMethodsWithSourceString: aString matchCase: caseSensitive - "Answer a sorted Collection of all the methods that contain, in source code, aString as a substring. Search the class comments also" - | list classCount adder | - list _ Set new. - adder _ [ :mrClass :mrSel | - list add: (MethodReference class: mrClass selector: mrSel) ]. - 'Searching all source code...' - displayProgressAt: Sensor mousePoint - from: 0 - to: Smalltalk classNames size - during: [ :barBlock | - classCount _ 0. - Smalltalk allClassesDo: [ :class | - barBlock value: (classCount _ classCount + 1). - (Array - with: class - with: class class) do: [ :cl | - cl selectorsDo: [ :sel | - ((cl sourceCodeAt: sel) - findString: aString - startingAt: 1 - caseSensitive: caseSensitive) > 0 ifTrue: [ - adder - value: cl - value: sel ]]. - (cl organization classComment asString - findString: aString - startingAt: 1 - caseSensitive: caseSensitive) > 0 ifTrue: [ - adder - value: cl - value: #Comment ]]]]. - ^ list asArray sort.! ! -!SystemDictionary methodsFor: 'retrieving' stamp: 'RNG 6/8/2020 23:57:01' prior: 50504639! - allMethodsWithString: aString - "Answer a sorted Collection of all the methods that contain, in a string literal, aString as a substring. 2/1/96 sw. The search is case-sensitive, and does not dive into complex literals, confining itself to string constants. - 5/2/96 sw: fixed so that duplicate occurrences of aString in the same method don't result in duplicated entries in the browser" - | aStringSize list | - aStringSize _ aString size. - list _ Set new. - self allBehaviorsDo: [ :class | - class selectorsDo: [ :sel | - (class compiledMethodAt: sel) literalsDo: [ :aLiteral | - ((aLiteral isMemberOf: String) and: [ aLiteral size >= aStringSize ]) ifTrue: [ - (aLiteral includesSubString: aString) ifTrue: [ - list add: (MethodReference class: class selector: sel) ]]]]]. - ^ list asArray sort! ! -!SystemDictionary methodsFor: 'retrieving' stamp: 'RNG 6/8/2020 23:57:40' prior: 16921865! - allSelect: aBlock - "Answer a SortedCollection of each method that, when used as the block - argument to aBlock, gives a true result." - | aCollection | - aCollection _ SortedCollection new. - self allBehaviorsDo: [ :class | - class selectorsDo: [ :sel | - (aBlock value: (class compiledMethodAt: sel)) ifTrue: [ - aCollection add: (MethodReference class: class selector: sel) - ]]]. - ^ aCollection! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'RNG 6/8/2020 23:58:01' prior: 16924016! - browseAllStoresInto: instVarName from: aClass - "Create and schedule a Message Set browser for all the receiver's methods - or any methods of a subclass/superclass that refer to the instance variable name." - - "self new browseAllStoresInto: 'contents' from: Collection." - - | coll | - coll _ OrderedCollection new. - aClass withAllSubAndSuperclassesDo: [:class | - (class whichSelectorsStoreInto: instVarName) do: [:sel | - coll add: (MethodReference class: class selector: sel)]]. - ^ self - browseMessageList: coll - name: 'Stores into ' , instVarName - autoSelect: instVarName! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'RNG 6/8/2020 23:59:45' prior: 16924061! - browseClassCommentsWithString: aString - "Smalltalk browseClassCommentsWithString: 'my instances' " - "Launch a message list browser on all class comments containing aString as a substring." - | caseSensitive suffix list | - suffix _ (caseSensitive _ Sensor shiftPressed) - ifTrue: [ ' (case-sensitive)' ] - ifFalse: [ ' (use shift for case-sensitive)' ]. - list _ Set new. - Smalltalk allClassesDo: [ :class | - (class organization classComment asString - findString: aString - startingAt: 1 - caseSensitive: caseSensitive) > 0 ifTrue: [ - list add: (MethodReference class: class selector: #Comment) ]]. - ^ self - browseMessageList: list asArray sort - name: 'Class comments containing ', aString printString, suffix - autoSelect: aString.! ! -!CodePackage methodsFor: 'testing' stamp: 'RNG 6/8/2020 23:54:20' prior: 16810396! - referenceForMethod: aSymbol ofClass: aClass - ^ MethodReference class: aClass selector: aSymbol! ! -!CodeWindow methodsFor: 'menu commands' stamp: 'RNG 6/8/2020 23:54:34' prior: 16813521! - openSingleMessageBrowser - | msgName mr | - "Create and schedule a message list browser populated only by the currently selected message" - - (msgName _ model selectedMessageName) ifNil: [^ self]. - - mr _ MethodReference - class: model selectedClassOrMetaClass - selector: msgName. - - Smalltalk - browseMessageList: (Array with: mr) - name: mr stringVersion - autoSelect: nil! ! -!MethodReference methodsFor: 'setting' stamp: 'RNG 6/9/2020 00:03:27' prior: 16873098! - setClass: aClass methodSymbol: methodSym stringVersion: aString - - self - setClassSymbol: aClass theNonMetaClass name - classIsMeta: aClass isMeta - methodSymbol: methodSym - stringVersion: aString! ! -!MethodReference methodsFor: 'setting' stamp: 'RNG 6/9/2020 00:04:05' prior: 16873116! - setStandardClass: aClass methodSymbol: methodSym - - self - setClass: aClass - methodSymbol: methodSym - stringVersion: aClass name , ' ' , methodSym! ! -!ChangeSelector methodsFor: 'rename senders - private' stamp: 'RNG 6/9/2020 00:08:19' prior: 50438691! - renameSendersIn: aMethod - - | newSource rangesToNewStrings | - - rangesToNewStrings := self rangesToKeywordsOf: aMethod. - newSource := aMethod sourceCode copyReplacing: rangesToNewStrings. - aMethod methodClass compile: newSource. - - changes add: (MethodReference method: aMethod)! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4230-MethodReferenceInstantiationRefactoring-NahuelGarbezza-2020Jun08-23h50m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4226] on 22 June 2020 at 4:18:36 pm'! - -ParseNode subclass: #BacktickNode - instanceVariableNames: 'sourceCode expression literalNode parser range' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #BacktickNode category: #'Compiler-ParseNodes' stamp: 'Install-4231-BacktickParseNode-HernanWilkinson-2020Jun18-09h33m-HAW.001.cs.st 6/25/2020 16:06:53'! -ParseNode subclass: #BacktickNode - instanceVariableNames: 'sourceCode expression literalNode parser range' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! -!Parser methodsFor: 'as yet unclassified' stamp: 'HAW 6/22/2020 16:05:36'! - addToSentInLiterals: aSymbol - - sentInLiterals add: aSymbol ! ! -!Parser methodsFor: 'as yet unclassified' stamp: 'HAW 6/22/2020 16:15:27'! - backtickExpression - - | start range | - - start := self startOfNextToken. - self advance. - self expression ifFalse: [^self expected: 'expression']. - (self match: #backtick) ifFalse: [^self expected: 'backtick']. - range := start to: prevEnd. - - parseNode := BacktickNode - expression: parseNode - source: (source contents copyFrom: range first+1 to: range last-1) - parser: self - range: range. - - encoder noteSourceRange: range forNode: parseNode.! ! -!BacktickNode methodsFor: 'initialization' stamp: 'HAW 6/22/2020 16:07:07'! - addSymbolsOfExpressionToParser - - expression nodesDo: [ :aNode | - aNode isMessageNode ifTrue: [ parser addToSentInLiterals: aNode selector key ]. - aNode isLiteralNode ifTrue: [ (aNode literalValue isSymbol and: [ aNode literalValue ~= Scanner doItSelector ]) - ifTrue: [ parser addToSentInLiterals: aNode literalValue ]]]! ! -!BacktickNode methodsFor: 'initialization' stamp: 'HAW 6/22/2020 16:06:52'! - initializeExpression: anExpression source: aSourceCode parser: aParser range: aRange - - expression := anExpression. - sourceCode := aSourceCode. - parser := aParser. - range := aRange. - - self addSymbolsOfExpressionToParser.! ! -!BacktickNode methodsFor: 'literal node' stamp: 'HAW 6/21/2020 17:09:55'! - evaluateBacktickSourceCode - - ^[[[Compiler evaluate: sourceCode ] - on: SyntaxErrorNotification - do: [ :ex | parser notify: 'Can not compile: ', ex errorMessage at: range first ]] - on: UndeclaredVariableReference - do: [ :ex | parser notify: 'Can not compile: Variable ''', ex varName, ''' is not declared' at: range first ]] - on: Error - do: [ :ex | parser notify: 'Can not evaluate code: ', ex description at: range first ].! ! -!BacktickNode methodsFor: 'literal node' stamp: 'HAW 6/21/2020 17:09:36'! - initializeLiteralNode - - | backtickValue | - - backtickValue := self evaluateBacktickSourceCode. - literalNode := parser encoder encodeLiteral: backtickValue range: range - -! ! -!BacktickNode methodsFor: 'literal node' stamp: 'HAW 6/22/2020 15:22:48'! - literalNode - - "The literalNode is initialize if really needed. There are situations when only the method node of a compiled method is needed - and therefore the literal generated for the backtick is not necessary. - The literal is needed when compiling the source code and sadly, when debugging because the debugger needs to regenerate - the code for the temp bindings and the relationship between the bytecodes and the source ranges of the nodes. - - If some message of the backtick source code has changed since the time the method was compiled, the resulting literal - could be different to the one generated when the method was originally compiled. - The change could include signaling an exception. That could happen while debuggin. That would mean that the backtick - code is not compliant with what currently should happen, so although it is a bothering solution, it is the more correct one - since it shows the difference - Hernan" - - literalNode ifNil: [ self initializeLiteralNode ]. - ^literalNode! ! -!BacktickNode methodsFor: 'visiting' stamp: 'HAW 6/21/2020 13:20:00' overrides: 16884650! - accept: aVisitor - - aVisitor visitBacktickNode: self. - ! ! -!BacktickNode methodsFor: 'visiting' stamp: 'HAW 6/21/2020 13:25:36'! -visitExpressionWith: aVisitor - - expression accept: aVisitor! ! -!BacktickNode methodsFor: 'visiting' stamp: 'HAW 6/22/2020 15:13:14'! - visitLiteralWith: aVisitor - - "Remember that creating the literal can signal an exception if the message sent in the expression - has changed since the method was compiled - Hernan" - self literalNode accept: aVisitor ! ! -!BacktickNode methodsFor: 'printing' stamp: 'HAW 6/22/2020 10:34:24' overrides: 16884940! - printOn: aStream indent: level - - aStream nextPut: $`. - expression printOn: aStream indent: level. - aStream nextPut: $`.! ! -!BacktickNode methodsFor: 'code generation' stamp: 'HAW 6/21/2020 13:27:32'! - analyseTempsWithin: scopeBlock rootNode: rootNode assignmentPools: assignmentPools - - ^self! ! -!BacktickNode methodsFor: 'code generation' stamp: 'HAW 6/21/2020 17:10:23'! - emitCodeForValue: aParseStack encoder: anEncoder - - ^self literalNode emitCodeForValue: aParseStack encoder: anEncoder ! ! -!BacktickNode methodsFor: 'code generation' stamp: 'HAW 6/21/2020 17:10:44'! - sizeCodeForValue: anEncoder - - ^self literalNode sizeCodeForValue: anEncoder ! ! -!BacktickNode class methodsFor: 'instance creation' stamp: 'HAW 6/22/2020 16:07:16'! - expression: anExpression source: aSourceCode parser: aParser range: aRange - - self assertNodesIn: anExpression canBeReferencedInsideBacktickUsing: aParser startingAt: aRange first. - - ^self new initializeExpression: anExpression source: aSourceCode parser: aParser range: aRange ! ! -!BacktickNode class methodsFor: 'assertions' stamp: 'HAW 6/22/2020 16:03:49'! - assertNodesIn: anExpression canBeReferencedInsideBacktickUsing: aParser startingAt: aPosition - - ^ anExpression nodesDo: [ :aNode | - (self canNotBeReferencedInsideBacktick: aNode) ifTrue: [ - aParser - notify: (self canNotReferencePseudoVarInsideBacktickErrorDescriptionFor: aNode key) - at: aPosition ]]! ! -!BacktickNode class methodsFor: 'assertions' stamp: 'HAW 6/22/2020 15:59:58'! - canNotBeReferencedInsideBacktick: aNode - - ^ aNode isSelfPseudoVariable - or: [ aNode isSuperPseudoVariable - or: [ aNode isThisContextPseudoVariable ]]! ! -!BacktickNode class methodsFor: 'assertions' stamp: 'HAW 6/22/2020 15:59:41'! - canNotReferencePseudoVarInsideBacktickErrorDescriptionFor: pseudoVariable - - ^ 'Can not reference ', pseudoVariable, ' inside backtick'! ! -!ParseNodeVisitor methodsFor: 'visiting' stamp: 'HAW 6/22/2020 15:11:41'! - visitBacktickNode: aBacktickNode - - "By default only visits the expresion of the backtick and not its literal. - If visiting the literal is necessary, you can use the message visitLiteralWith: but - remember that the litercal can be nil if the expresion was not evaluated - Hernan" - - aBacktickNode visitExpressionWith: self.! ! -!ParseNodeEnumerator methodsFor: 'visiting' stamp: 'HAW 6/21/2020 12:43:54' overrides: 50525806! - visitBacktickNode: aBacktickNode - - (theSelectBlock isNil or: [theSelectBlock value: aBacktickNode]) ifFalse: - [^nil]. - theBlock value: aBacktickNode. - ^super visitBacktickNode: aBacktickNode! ! -!Compiler methodsFor: 'private' stamp: 'HAW 6/22/2020 16:10:03' prior: 50512929! - translate: aStream noPattern: noPattern doIt: doIt ifFail: failBlock - - ^self parser - parse: aStream - class: class - category: category - noPattern: noPattern - doIt: doIt - context: context - notifying: requestor - ifFail: [^failBlock value]! ! -!Scanner methodsFor: 'expression types - private' stamp: 'HAW 8/15/2018 19:53:35' prior: 50409829! - skipDelimitersAndBacktickIfNecessary - - [self skipDelimiters. - self isBacktickAndShouldIgnoreIt ] whileTrue: [self step]. ! ! -!Scanner methodsFor: 'expression types' stamp: 'HAW 6/22/2020 16:11:44' prior: 50409884! - scanToken - - "Skip delimiters fast, there almost always is one." - self skipDelimiters. - - mark := source position - 1. - (tokenType at: 1) = $x "x as first letter" - ifTrue: [self perform: tokenType "means perform to compute token & type"] - ifFalse: [token := self step asSymbol "else just unique the first char"]. - ^token! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'HAW 6/22/2020 16:08:32' prior: 50410262! - xBacktick - - token := $` asSymbol. - tokenType := #backtick. - self step.! ! -!Scanner methodsFor: 'initialization' stamp: 'HAW 6/22/2020 16:10:19' prior: 50409836! - initScanner - - buffer := WriteStream on: (String new: 40). - typeTable := Scanner typeTable. - isForTokenization := false. - sentInLiterals := Set new. - ! ! -!Scanner methodsFor: 'initialization' stamp: 'HAW 6/22/2020 16:10:23' prior: 50409845! - initScannerForTokenization - "Don't raise xIllegal when enocuntering an _" - "Simpler implementation for Cuis" - isForTokenization _ true. - ! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 6/22/2020 16:16:06' prior: 50409512! - primaryExpression - - hereType == #word - ifTrue: [ - parseNode _ self variable. - - " - (parseNode isUndefTemp and: [self interactive] and: [ - ((requestor isKindOf: Editor) or: [ requestor is: #Morph ])]) - " - "If the requestor is of an exotic kind (like a telnet server) we might not be - allowed to open a PupUpMenu for querying the user" - - (parseNode isUndefTemp and: [ self interactive ]) - ifTrue: [self queryUndefined]. - parseNode nowHasRef. - ^ true]. - hereType == #leftBracket - ifTrue: [ - self advance. - self blockExpression. - ^true]. - hereType == #leftBrace - ifTrue: [ - self braceExpression. - ^true]. - hereType == #leftParenthesis - ifTrue: [ - self advance. - self expression ifFalse: [^self expected: 'expression']. - (self match: #rightParenthesis) - ifFalse: [^self expected: 'right parenthesis']. - ^true]. - (hereType == #string or: [hereType == #number or: [hereType == #literal]]) - ifTrue: [ - parseNode := self advanceWithRangeDo: [ :lexema :range | encoder encodeLiteral: lexema range: range ]. - ^true]. - (here == #- and: [tokenType == #number]) - ifTrue: [ - self advanceWithRangeDo: [ :minusChar :minusRange | - self advanceWithRangeDo: [ :number :numberRange | - parseNode := encoder encodeLiteral: number negated range: (minusRange first to: numberRange last)]]. - ^true]. - - hereType == #backtick - ifTrue: [ - self backtickExpression. - ^true ]. - - ^false! ! - -BacktickNode class removeSelector: #addSymbolsOf:to:! - -BacktickNode class removeSelector: #of:source:! - -BacktickNode class removeSelector: #expression:literal:! - -BacktickNode class removeSelector: #expression:source:encoder:range:! - -BacktickNode class removeSelector: #assertNodesIn:canBeReferencedInsideBacktickStartingAt:! - -BacktickNode class removeSelector: #of:! - -BacktickNode removeSelector: #initializeExpression:literal:! - -BacktickNode removeSelector: #addSymbolsOf:to:! - -BacktickNode removeSelector: #initializeLiteral! - -BacktickNode removeSelector: #initializeOf:! - -BacktickNode removeSelector: #literal! - -BacktickNode removeSelector: #assertWasCompiledNotIgnoringBacktick! - -BacktickNode removeSelector: #expression! - -BacktickNode removeSelector: #initializeOf:source:! - -BacktickNode removeSelector: #initializeExpression:source:encoder:range:! - -Parser class removeSelector: #canNotReferencePseudoVarInsideBacktickErrorDescriptionFor:! - -Parser removeSelector: #compileBacktickCodeHandlingErrors:! - -Parser removeSelector: #canNotBeReferencedInsideBacktick:! - -Parser removeSelector: #compileBacktickCodeHandlingErrors:at:! - -Parser removeSelector: #evaluateBacktickCode:handlingErrorsAt:! - -Scanner removeSelector: #compileBacktickCodeHandlingErrors! - -!methodRemoval: Scanner #compileBacktickCodeHandlingErrors stamp: 'Install-4231-BacktickParseNode-HernanWilkinson-2020Jun18-09h33m-HAW.001.cs.st 6/25/2020 16:06:53'! -compileBacktickCodeHandlingErrors - - [[[self compileBacktickCode ] - on: SyntaxErrorNotification - do: [ :ex | self notify: 'Can not compile: ', ex errorMessage at: mark]] - on: UndeclaredVariableReference - do: [ :ex | self notify: 'Can not compile: Variable ''', ex varName, ''' is not declared' at: mark ]] - on: Error - do: [ :ex | self notify: 'Can not evaluate code: ', ex description at: mark ]. - - tokenType _ #literal! - -Scanner removeSelector: #compileBacktickCode:! - -Scanner removeSelector: #compileBacktickCode! - -!methodRemoval: Scanner #compileBacktickCode stamp: 'Install-4231-BacktickParseNode-HernanWilkinson-2020Jun18-09h33m-HAW.001.cs.st 6/25/2020 16:06:53'! -compileBacktickCode - - | compiler method methodNode | - - compiler _ Compiler new. - methodNode _ compiler compileNoPattern: buffer contents in: UndefinedObject context: nil notifying: nil ifFail: []. - self assertNodesIn: methodNode canBeReferencedInsideBacktickUsing: compiler. - method _ methodNode generate. - - "Grab all messages sent while evaluating literal, so the main method will be shown as senders of them" - sentInLiterals addAll: method messages. - method literalsDo: [ :literal | literal isSymbol ifTrue: [ literal = self class doItSelector ifFalse: [sentInLiterals add: literal ]]]. - - "Evaluate now." - token _ nil withArgs: #() executeMethod: method ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4231-BacktickParseNode-HernanWilkinson-2020Jun18-09h33m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4226] on 22 June 2020 at 4:38:20 pm'! - -Object subclass: #Scanner - instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable isForTokenization sentInLiterals ignoreBacktick ' - classVariableNames: 'DoItCharacter TypeTable ' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #Scanner category: #'Compiler-Kernel' stamp: 'Install-4232-BacktickParseNode-HernanWilkinson-2020Jun22-16h27m-HAW.001.cs.st 6/25/2020 16:06:53'! -Object subclass: #Scanner - instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable isForTokenization sentInLiterals ignoreBacktick' - classVariableNames: 'DoItCharacter TypeTable' - poolDictionaries: '' - category: 'Compiler-Kernel'! -!ParseNode methodsFor: 'testing' stamp: 'HAW 6/22/2020 16:35:06'! - isBacktickNode - - ^false! ! -!BacktickNode methodsFor: 'expression' stamp: 'HAW 6/22/2020 16:34:36'! - expression - - ^expression! ! -!BacktickNode methodsFor: 'testing' stamp: 'HAW 6/22/2020 16:33:53' overrides: 50507189! - equivalentTo: aParseNode - - ^ aParseNode isBacktickNode - and: [ expression equivalentTo: aParseNode expression ]! ! -!BacktickNode methodsFor: 'testing' stamp: 'HAW 6/22/2020 16:34:24' overrides: 50526046! - isBacktickNode - - ^true! ! - -Scanner removeSelector: #skipDelimitersAndBacktickIfNecessary! - -!methodRemoval: Scanner #skipDelimitersAndBacktickIfNecessary stamp: 'Install-4232-BacktickParseNode-HernanWilkinson-2020Jun22-16h27m-HAW.001.cs.st 6/25/2020 16:06:53'! -skipDelimitersAndBacktickIfNecessary - - [self skipDelimiters. - self isBacktickAndShouldIgnoreIt ] whileTrue: [self step]. ! - -Scanner removeSelector: #isBacktickAndShouldIgnoreIt! - -!methodRemoval: Scanner #isBacktickAndShouldIgnoreIt stamp: 'Install-4232-BacktickParseNode-HernanWilkinson-2020Jun22-16h27m-HAW.001.cs.st 6/25/2020 16:06:53'! -isBacktickAndShouldIgnoreIt - - "I compare with true because there are many ways to initialize the scanner and ingoreBacktick could be nil - Hernan" - ^ ignoreBacktick == true and: [tokenType = #xBacktick]! - -Scanner removeSelector: #ignoreBacktick:! - -!methodRemoval: Scanner #ignoreBacktick: stamp: 'Install-4232-BacktickParseNode-HernanWilkinson-2020Jun22-16h27m-HAW.001.cs.st 6/25/2020 16:06:53'! -ignoreBacktick: aBoolean - - ignoreBacktick := aBoolean ! - -Object subclass: #Scanner - instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable isForTokenization sentInLiterals' - classVariableNames: 'DoItCharacter TypeTable' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #Scanner category: #'Compiler-Kernel' stamp: 'Install-4232-BacktickParseNode-HernanWilkinson-2020Jun22-16h27m-HAW.001.cs.st 6/25/2020 16:06:53'! -Object subclass: #Scanner - instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable isForTokenization sentInLiterals' - classVariableNames: 'DoItCharacter TypeTable' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4232-BacktickParseNode-HernanWilkinson-2020Jun22-16h27m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4230] on 22 June 2020 at 4:43:45 pm'! - -Scanner removeSelector: #canNotBeReferencedInsideBacktick:! - -!methodRemoval: Scanner #canNotBeReferencedInsideBacktick: stamp: 'Install-4233-BacktickParseNode-HernanWilkinson-2020Jun22-16h19m-HAW.001.cs.st 6/25/2020 16:06:53'! -canNotBeReferencedInsideBacktick: aNode - - ^ aNode isSelfPseudoVariable - or: [ aNode isSuperPseudoVariable - or: [ aNode isThisContextPseudoVariable ]]! - -Scanner removeSelector: #assertNodesIn:canBeReferencedInsideBacktickUsing:! - -!methodRemoval: Scanner #assertNodesIn:canBeReferencedInsideBacktickUsing: stamp: 'Install-4233-BacktickParseNode-HernanWilkinson-2020Jun22-16h19m-HAW.001.cs.st 6/25/2020 16:06:53'! -assertNodesIn: methodNode canBeReferencedInsideBacktickUsing: compiler - - ^ methodNode nodesDo: [ :aNode | - (self canNotBeReferencedInsideBacktick: aNode) ifTrue: [ - compiler notify: (self class canNotReferencePseudoVarInsideBacktickErrorDescriptionFor: aNode key) ]]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4233-BacktickParseNode-HernanWilkinson-2020Jun22-16h19m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4233] on 23 June 2020 at 4:11:05 pm'! - -Scanner class removeSelector: #canNotReferencePseudoVarInsideBacktickErrorDescriptionFor:! - -!methodRemoval: Scanner class #canNotReferencePseudoVarInsideBacktickErrorDescriptionFor: stamp: 'Install-4234-BacktickParseNode-HernanWilkinson-2020Jun23-15h40m-HAW.001.cs.st 6/25/2020 16:06:53'! -canNotReferencePseudoVarInsideBacktickErrorDescriptionFor: pseudoVariable - - ^ 'Can not reference ', pseudoVariable, ' inside backtick'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4234-BacktickParseNode-HernanWilkinson-2020Jun23-15h40m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4233] on 23 June 2020 at 6:59:08 pm'! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'HAW 6/23/2020 18:58:46'! - fileOutOrganizationOn: aFileStream excludingExtensions: shouldExcludeExtensions - "File a description of the receiver's organization on aFileStream. - Excludes extentions categories if shouldExcludeExtensions" - - | organizationString | - - aFileStream newLine; nextPut: $!!. - aFileStream nextChunkPut: self name, ' reorganize'; newLine. - organizationString := String streamContents: [ :aStream | - self organization printOn: aStream excludingExtensions: shouldExcludeExtensions ]. - aFileStream nextChunkPut: organizationString; newLine! ! -!Categorizer methodsFor: 'printing' stamp: 'HAW 6/23/2020 18:35:31'! - printCategory: aCategory at: aCategoryIndex with: aStartElementIndex on: aStream - - | elementIndex | - - elementIndex := aStartElementIndex. - aStream nextPut: $(. - aCategory printOn: aStream. - - [elementIndex <= (categoryStops at: aCategoryIndex)] whileTrue: [ - aStream space; nextPutAll: (elementArray at: elementIndex). - elementIndex _ elementIndex + 1]. - - aStream nextPut: $); newLine. - - ^elementIndex ! ! -!Categorizer methodsFor: 'printing' stamp: 'HAW 6/23/2020 18:57:52'! -printOn: aStream excludingExtensions: shouldExcludeExtensions - "Refer to the comment in Object|printOn:." - - | elementIndex | - - elementIndex _ 1. - 1 to: categoryArray size do: [ :categoryIndex | | category | - category _ (categoryArray at: categoryIndex) asString. - (shouldExcludeExtensions and: [ self isPackageCategoryExtension: category ]) ifFalse: [ - elementIndex _ self printCategory: category at: categoryIndex with: elementIndex on: aStream.]]! ! -!Categorizer methodsFor: 'testing' stamp: 'HAW 6/23/2020 18:55:22'! - isPackageCategoryExtension: aCategory - - ^aCategory beginsWith: '*'! ! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'HAW 6/23/2020 18:58:23' prior: 16806784! - fileOutOrganizationOn: aFileStream - "File a description of the receiver's organization on aFileStream." - - self fileOutOrganizationOn: aFileStream excludingExtensions: false! ! -!ClassDescription class methodsFor: 'utilities' stamp: 'HAW 6/23/2020 18:55:22' prior: 50426708! - printPackageExtensionCategories - "In a bare image, without any packages, should print nothing - ClassDescription printPackageExtensionCategories - ClassOrganizer allInstancesDo: [:co | co removeEmptyCategories]. - " - ClassDescription allSubInstances do: [ :class | | classOrganization | - classOrganization _ class organization. - classOrganization categories do: [ :category | - (classOrganization isPackageCategoryExtension: category) ifTrue: [ - {class. category} print ]]].! ! -!Categorizer methodsFor: 'printing' stamp: 'HAW 6/23/2020 18:57:52' prior: 16795740 overrides: 50508082! - printOn: aStream - "Refer to the comment in Object|printOn:." - - self printOn: aStream excludingExtensions: false! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 6/23/2020 18:58:23' prior: 50482150! - fileOutPSFor: class on: stream - "Write out removals and initialization for this class." - - | dict classRecord currentDef | - classRecord _ changeRecords at: class name ifAbsent: [^ self]. - dict _ classRecord methodChangeTypes. - ((dict includesKey: #initialize) and: [ class isMeta ]) ifTrue: [ - stream nextChunkPut: class soleInstance name, ' initialize'; newLine]. - ((classRecord includesChangeType: #change) - and: [(currentDef _ class definition) ~= (self fatDefForClass: class)]) ifTrue: [ - stream - nextPut: $!!; - nextChunkPut: class definitionPreambleWithoutStamp; newLine; - nextChunkPut: currentDef; newLine]. - (classRecord includesChangeType: #reorganize) ifTrue: [ - class fileOutOrganizationOn: stream excludingExtensions: true. - stream newLine]! ! - -Categorizer removeSelector: #printOn:excludingExtentions:! - -Categorizer removeSelector: #isPackageCategoryExtention:! - -ClassDescription removeSelector: #fileOutOrganizationOn:excludingExtentions:! - -ClassDescription removeSelector: #organizationExcludingExtentions:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4235-ExcludeExtensionCategories-HernanWilkinson-2020Jun23-16h11m-HAW.003.cs.st----! - -'From Cuis 5.0 [latest update: #4235] on 24 June 2020 at 3:55:33 pm'! -!LargePositiveInteger methodsFor: 'bit manipulation' stamp: 'jmv 6/24/2020 11:23:30' prior: 16862407 overrides: 16859251! - bitReverse: highBit - "This implementation is faster than super" - - | digitSize reversed adjust | - highBit < self highBit ifTrue: [ self error: 'Not enough bits.' ]. - digitSize := highBit + 7 // 8. - reversed := self class new: digitSize. - 1 to: self digitLength do: [:i | - reversed digitAt: digitSize + 1 - i put: (self digitAt: i) byteReversed]. - adjust _ highBit - (digitSize * 8). - ^adjust = 0 - ifTrue: [reversed normalize] - ifFalse: [reversed bitShift: adjust]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4236-bitReverse-fix-JuanVuletich-2020Jun24-15h55m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4236] on 24 June 2020 at 4:08:25 pm'! - -FileEntry removeSelector: #baseDirectory! - -!methodRemoval: FileEntry #baseDirectory stamp: 'Install-4237-cleanup-JuanVuletich-2020Jun24-16h07m-jmv.001.cs.st 6/25/2020 16:06:53'! -baseDirectory - "The directory this file is located in" - ^ DirectoryEntry - withPathComponents: self pathComponents allButLast - drive: nil.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4237-cleanup-JuanVuletich-2020Jun24-16h07m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4236] on 24 June 2020 at 4:10:29 pm'! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'jmv 6/22/2020 16:07:44' prior: 50505763! - allAccessesTo: instVarName - - | references instVarIndex | - - instVarIndex _ self indexOfInstanceVariable: instVarName. - references _ SortedCollection sortBlock: [ :left :right | left stringVersion <= right stringVersion ]. - - self withAllSubAndSuperclassesDo: [:class | class addReferencesOf: instVarName at: instVarIndex to: references ]. - - ^ references ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4238-ivarAccessTool-fix-JuanVuletich-2020Jun24-16h08m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4230] on 23 June 2020 at 12:29:05 pm'! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jmv 6/23/2020 10:48:01' prior: 50378815! - handleUserInterrupt - Utilities reportCPUandRAM. - Preferences cmdDotEnabled ifTrue: [ - [ UISupervisor userInterrupt ] fork]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4239-DebugAidsOnBreak-JuanVuletich-2020Jun23-12h28m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4219] on 15 June 2020 at 8:08:32 pm'! - -Object subclass: #CharacterScanner - instanceVariableNames: 'destX lastIndex xTable destY stopConditions text alignment leftMargin rightMargin font line runStopIndex spaceCount spaceWidth tabWidth kern paragraphStyle defaultFont lastTabX lastTabIndex tabCount ' - classVariableNames: 'DefaultStopConditions StopConditionsWithPaddedSpace StopConditionsWithSpace ' - poolDictionaries: '' - category: 'Graphics-Text'! - -!classDefinition: #CharacterScanner category: #'Graphics-Text' stamp: 'Install-4240-TabHandling-JuanVuletich-2020Jun15-19h22m-jmv.001.cs.st 6/25/2020 16:06:53'! -Object subclass: #CharacterScanner - instanceVariableNames: 'destX lastIndex xTable destY stopConditions text alignment leftMargin rightMargin font line runStopIndex spaceCount spaceWidth tabWidth kern paragraphStyle defaultFont lastTabX lastTabIndex tabCount' - classVariableNames: 'DefaultStopConditions StopConditionsWithPaddedSpace StopConditionsWithSpace' - poolDictionaries: '' - category: 'Graphics-Text'! -!Integer methodsFor: 'benchmarks' stamp: 'jmv 6/15/2020 20:07:36' prior: 50381984! - tinyBenchmarks - "Report the results of running the two tiny Squeak benchmarks. - ar 9/10/1999: Adjusted to run at least 1 sec to get more stable results - - - Performance of early 80's experimental Smalltalk systems. - Estimations from - http://wiki.c2.com/?GreenBook - http://www.wirfs-brock.com/allen/things/smalltalk-things/tektronix-smalltalk-document-archive/1982-qtr4-magnolia-perf-graph.pdf - http://www.wirfs-brock.com/allen/things/smalltalk-things/tektronix-smalltalk-document-archive/1983-Magnolia-st-perf.pdf - - DEC PDP-11/23 5,000 bytecodes/sec (Green Book, p.128) - Apple 5MHz 68000 9,000 to 11,000 bytecodes/sec (Green Book, p.187, awb) 5000 clocks/bytecode - VAX-11/780 5MHz C HP Smalltalk 5,000 to 25,000 bytecodes/sec (Green Book, p.235) 330 clocks/bytecode - VAX-11/780 5MHz C Berkeley Smalltalk 12,000 to 23000 bytecodes/sec (Green Book, p.203, awb) 300 clocks/bytecode - DEC VAX-11/780 5MHz assembly 20,000 to 25,000 bytecodes/sec (Green Book, p.149, awb) 200 clocks/bytecode - Xerox Dolphin µcode 20,000 to 40,000 bytecodes/sec (Green Book, p.44, p.203, awb) - TEK Magnolia 10MHz 68000 50,000 bytecodes/sec (awb) 200 clocks/bytecode - Xerox Dorado 14MHz µcode 400,000 to 500,000 bytecodes/sec (G.B., p.44, p.203, awb) 28 clocks/bytecode - - - 0 tinyBenchmarks - - 292 MHz G3 Mac: 22,727,272 bytecodes/sec; 984,169 sends/sec 12.8 clocks/bytecode - 400 MHz PII/Win98: 18,028,169 bytecodes/sec; 1,081,272 sends/sec 22.2 clocks/bytecode - - 900MHz RasPi2 - StackVM: 37,758,112 bytecodes/sec; 2,412,667 sends/sec 16.2 clocks/bytecode - 900MHz RasPi2- CogSSpur: 157,441,574 bytecodes/sec; 10,946,039 sends/sec 5.7 clocks/bytecode - - 1GHz C.H.I.P. (*1) - StackVM: 55,315,471 bytecodes/sec; 3,348,667 sends/sec 18.1 clocks/bytecode - 1GHz C.H.I.P. (*1) - CogSpur: 253,716,551 bytecodes/sec; 16,853,816 sends/sec 3.9 clocks/bytecode - - 1.2GHz RasPi3B - StackSpur: 44,107,512 bytecodes/sec; 2,767,863 sends/sec 27.2 clocks/bytecode - 1.2GHz RasPi3B - CogSpur: 281,783,159 bytecodes/sec; 16,404,381 sends/sec 6.6 clocks/bytecode - - 1.66GHz Atom N450 - Cog: 244,274,809 bytecodes/sec; 28,795,277 sends/sec 6.8 clocks/bytecode - 1.66GHz Atom N450 - CogSpur: 469,724,770 bytecodes/sec; 30,754,699 sends/sec 3.5 clocks/bytecode - - 1.33GHz Atom 3735G - Cog: 326,114,649 bytecodes/sec; 34,985,976 sends/sec 4.1 clocks/bytecode - 1.33GHz Atom 3735G - CogSpur: 632,098,765 bytecodes/sec; 33,692,910 sends/sec 2.1 clocks/bytecode - - 1.5GHz AMD A4-5000 APU - Cog: 390,243,902 bytecodes/sec; 47,507,997 sends/sec 3.8 clocks/bytecode - 1.5GHz AMD A4-5000 APU - CogSpur: 675,907,590 bytecodes/sec; 40,669,724 sends/sec 2.2 clocks/bytecode - 1.5GHz AMD A4-5000 APU - CogSpur64: 659,368,963 bytecodes/sec; 50,338,916 sends/sec 2.2 clocks/bytecode - - 2.3GHz Tegra (*2) - StackVM: 258,847,320 bytecodes/sec; 13,014,759 sends/sec 8.9 clocks/bytecode - 2.3GHz Tegra (*2) - CogSpur: 1,083,024,854 bytecodes/sec; 64,289,750 sends/sec 2.1 clocks/bytecode - - 3.1GHz Core i3-2100 - Cog: 1,203,290,246 bytecodes/sec; 165,723,327 sends/sec 2.6 clocks/bytecode - 3.1GHz Core i3-2100 - CogSpur: 2,042,892,768 bytecodes/sec; 127,837,794 sends/sec 1.5 clocks/bytecode - - 2.70GHz Core i5-6400 -CogSpur64: 3,162,934,362 bytecodes/sec; 243,321,293 sends/sec 0.85 clocks/bytecode - - (*1) C.H.I.P. $9 Computer [Next Thing Co], Allwinner R8 Single-Core ARM Cortex-A8 - 1 GHz - (*2) ACER Chromebook CB5-311 - NVIDIA Tegra K1 Quad-Core ARM Cortex-A15 'r3' - 2.3 GHz - - It is interesting to note that Spur for the first time brings ARM hardware (RasPi and C.H.I.P.) into a 'Morphic is confortable and nice to use' level of performance. - " - | t1 t2 r n1 n2 | - n1 _ 1. - [ - t1 _ Time millisecondsToRun: [n1 benchmark]. - t1 < 1000] - whileTrue: [n1 _ n1 * 2]. "Note: #benchmark's runtime is about O(n)" - - n2 _ 28. - [ - t2 _ Time millisecondsToRun: [r _ n2 benchFib]. - t2 < 1000] - whileTrue: [n2 _ n2 + 1]. - "Note: #benchFib's runtime is about O(k^n), - where k is the golden number = (1 + 5 sqrt) / 2 = 1.618...." - - ^String streamContents: [ :strm | - (n1 * 500000 * 1000) // t1 withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixName; - nextPutAll: 'Bytecodes/second; ' ]. - (r * 1000) // t2 withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixName; - nextPutAll: 'Sends/second' ]]! ! -!CharacterScanner methodsFor: 'private' stamp: 'jmv 6/15/2020 19:49:07' prior: 50410476! - setFont - | attributes | - "Set the font and other emphasis. - In fact set actual ParagraphStyle (or nil), alignment, font and emphasis" - - self setActualFont: (text fontAt: lastIndex default: defaultFont). - attributes _ text attributesAt: lastIndex. - text - withAttributeValues: attributes - do: [ :familyNameInText :pointSizeInText :emphasisInText :colorInText :alignmentInText :characterStyleInText :paragraphStyleInText :backgroundColorInText | - colorInText ifNotNil: [ self textColor: colorInText ]. - self backgroundColor: backgroundColorInText. - alignment _ alignmentInText. - paragraphStyle _ paragraphStyleInText ]. - - "Hardcoded color for TextAction" - attributes do: [ :attribute | - attribute forTextActionInfoDo: [ :info | - self textColor: TextAction textActionColor ]]. - - "Install various parameters from the font." - spaceWidth _ font widthOf: Character space. - tabWidth _ (font widthOf: $0) * 4. - xTable _ font xTable! ! -!CharacterScanner methodsFor: 'stop conditions' stamp: 'jmv 6/15/2020 19:56:51' prior: 50410509! - tabDestX - "This is the basic method of adjusting destX for a tab." - - ^paragraphStyle - ifNotNil: [ - paragraphStyle - nextTabXFrom: destX - leftMargin: leftMargin - rightMargin: rightMargin ] - ifNil: [ - (tabCount+1 * tabWidth max: spaceWidth//3 + destX) min: rightMargin ].! ! -!CharacterScanner methodsFor: 'initialization' stamp: 'jmv 6/15/2020 19:32:08' prior: 50410524 overrides: 16896425! - initialize - tabCount _ destX _ destY _ leftMargin _ rightMargin _ 0.! ! -!CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'jmv 6/15/2020 19:31:56' prior: 50410530 overrides: 16802069! - tab - | currentX | - currentX _ self tabDestX. - lastSpaceOrTabWidth _ currentX - destX max: 0. - currentX >= characterPoint x - ifTrue: [ - lastCharacterWidth _ lastSpaceOrTabWidth. - ^ self crossedX ]. - destX _ currentX. - lastIndex _ lastIndex + 1. - tabCount _ tabCount + 1. - ^false! ! -!CharacterBlockScanner methodsFor: 'scanning' stamp: 'jmv 6/15/2020 19:31:39' prior: 50454801! - characterBlockAtPoint: aPoint index: index in: textLine - "This method is the Morphic characterBlock finder." - | runLength lineStop stopCondition | - line _ textLine. - rightMargin _ line rightMargin. - lastIndex _ line first. - tabCount _ 0. - self setFont. - self setStopConditions. - characterIndex _ index. "nil means scanning for point" - characterPoint _ aPoint. - (characterPoint isNil or: [ characterPoint y > line bottom ]) - ifTrue: [ characterPoint _ line bottomRight ]. - (text isEmpty or: [( characterPoint y < line top or: [ characterPoint x < line left ]) - or: [ characterIndex notNil and: [ characterIndex < line first ]]]) - ifTrue: [^ CharacterBlock - stringIndex: line first - text: text - topLeft: line leftMargin@line top - extent: 0 @ line lineHeight - textLine: line]. - destX _ leftMargin _ line leftMarginForAlignment: alignment. - destY _ line top. - runLength _ text runLengthFor: line first. - lineStop _ characterIndex "scanning for index" - ifNil: [ line last ]. "scanning for point" - runStopIndex _ lastIndex + (runLength - 1) min: lineStop. - lastCharacterWidth _ 0. - spaceCount _ 0. - - self placeEmbeddedObject. - [ - stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex - in: text string rightX: characterPoint x - stopConditions: stopConditions kern: font baseKern. - "see setStopConditions for stopping conditions for character block operations." - lastCharacterWidth _ specialWidth ifNil: [ font widthOf: (text at: lastIndex) ]. - (self perform: stopCondition) ifTrue: [ - ^characterIndex - ifNil: [ "Result for characterBlockAtPoint: " - CharacterBlock - stringIndex: lastIndex - text: text - topLeft: characterPoint x@line top - extent: lastCharacterWidth @ line lineHeight - textLine: line ] - ifNotNil: [ "Result for characterBlockForIndex: " - CharacterBlock - stringIndex: characterIndex - text: text - topLeft: characterPoint x@line top - extent: lastCharacterWidth @ line lineHeight - textLine: line ]] - ] repeat! ! -!CompositionScanner methodsFor: 'scanning' stamp: 'jmv 6/15/2020 19:33:05' prior: 50500582! - composeFrom: startIndex inRectangle: lineRectangle firstLine: firstLine leftSide: leftSide rightSide: rightSide - - "Answer an instance of TextLineInterval that represents the next line in the paragraph." - | runLength stopCondition xtraSpaceBefore spaceAfterParagraph | - - lastIndex _ startIndex. "scanning sets last index" - tabCount _ 0. - destY _ lineRectangle top. - lineHeight _ baseline _ 0. "Will be increased by setFont" - self setFont. - self setStopConditions. - - "Set up margins" - leftMargin _ lineRectangle left. - rightMargin _ lineRectangle right. - xtraSpaceBefore _ 0. - spaceAfterParagraph _ 0. - paragraphStyle ifNotNil: [ - leftSide ifTrue: [ - leftMargin _ leftMargin + - ((firstLine and: [ paragraphStyle isListStyle not ]) - ifTrue: [ paragraphStyle firstIndent ] - ifFalse: [ paragraphStyle restIndent ])]. - rightSide ifTrue: [ - rightMargin _ rightMargin - paragraphStyle rightIndent]. - firstLine ifTrue: [ xtraSpaceBefore _ paragraphStyle spaceBefore ]. - spaceAfterParagraph _ paragraphStyle spaceAfter ]. - destX _ spaceX _ leftMargin. - - runLength _ text runLengthFor: startIndex. - runStopIndex _ lastIndex + runLength - 1. - line _ (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0) - rectangle: lineRectangle. - line isFirstLine: firstLine. - spaceCount _ 0. - lastLineBreakingSpace _ 0. - leftMargin _ destX. - line leftMargin: leftMargin. - - self placeEmbeddedObject. - [ - stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex - in: text string rightX: rightMargin stopConditions: stopConditions - kern: font baseKern. - "See setStopConditions for stopping conditions for composing." - (self perform: stopCondition) ifTrue: [ - ^ line - lineHeight: lineHeight + xtraSpaceBefore + - (stopCondition == #doNewLine ifTrue: [spaceAfterParagraph] ifFalse: [0]) - baseline: baseline + xtraSpaceBefore ] - ] repeat! ! -!CompositionScanner methodsFor: 'stop conditions' stamp: 'jmv 6/15/2020 19:33:16' prior: 50410673 overrides: 16802069! - tab - "Advance destination x according to tab settings in the current - ParagraphStyle. Answer whether the character has crossed the right edge of - the composition rectangle of the TextComposition." - - destX _ self tabDestX. - destX > rightMargin ifTrue: [^self crossedX]. - lastIndex _ lastIndex + 1. - tabCount _ tabCount + 1. - ^false -! ! -!MorphicScanner methodsFor: 'scanning' stamp: 'jmv 6/15/2020 19:34:49' prior: 50410687! - displayLine: textLine textTopLeft: textTopLeft leftInRun: leftInRun - "The call on the primitive (scanCharactersFrom:to:in:rightX:) will be interrupted according to an array of stop conditions passed to the scanner at which time the code to handle the stop condition is run and the call on the primitive continued until a stop condition returns true (which means the line has terminated). leftInRun is the # of characters left to scan in the current run; when 0, it is time to call setStopConditions." - - "textTopLeft is relative to the morph currently being drawn" - | stopCondition nowLeftInRun startIndex string lastPos x1 | - - topLeft _ textTopLeft. - line _ textLine. - lineY _ line top + textTopLeft y. - rightMargin _ line rightMargin + textTopLeft x. - lastIndex _ line first. - tabCount _ 0. - leftInRun <= 0 ifTrue: [ - self setFont. - self setStopConditions ]. - leftMargin _ (line leftMarginForAlignment: alignment) + textTopLeft x. - destX _ leftMargin. - destY _ lineY + line baseline - font ascent. - - textLine isEmptyLine ifTrue: [ - textLine paragraphStyle ifNotNil: [ :ps | - ps = paragraphStyle ifFalse: [ - foregroundColor _ defaultColor. - self setActualFont: ps font. - ps color ifNotNil: [ :color | self textColor: color ]. - alignment _ ps alignment. - paragraphStyle _ ps. - spaceWidth _ font widthOf: Character space. - xTable _ font xTable. - self setStopConditions. - text ifNotNil: [ destY _ lineY + line baseline - font ascent ]]]. - self displayBulletIfAppropriateFor: textLine textLeft: textTopLeft x. - ^leftInRun ]. - - self displayBulletIfAppropriateFor: textLine textLeft: textTopLeft x. - - leftInRun <= 0 - ifTrue: [nowLeftInRun _ text runLengthFor: lastIndex] - ifFalse: [nowLeftInRun _ leftInRun]. - runStopIndex _ lastIndex + (nowLeftInRun - 1) min: line last. - spaceCount _ 0. - string _ text string. - - self placeEmbeddedObject. - [ - startIndex _ lastIndex. - lastPos _ destX@destY. - stopCondition _ self - scanCharactersFrom: lastIndex to: runStopIndex - in: string rightX: rightMargin stopConditions: stopConditions - kern: font baseKern. - backgroundColor ifNotNil: [ - x1 _ destX. - (Preferences backgroundColorFillsAllBackground and: [startIndex > line last]) ifTrue: [ - x1 _ rightMargin ]. - canvas - fillRectangle: (lastPos corner: x1 @ (line bottom + textTopLeft y)) - color: backgroundColor. - (Preferences backgroundColorFillsAllBackground and: [stopCondition = #tab]) ifTrue: [ - canvas - fillRectangle: (destX @ lastPos y corner: self tabDestX @ (line bottom + textTopLeft y)) - color: backgroundColor ]]. - lastIndex >= startIndex ifTrue: [ - canvas - drawString: string - from: startIndex - to: lastIndex - at: lastPos - font: font - color: foregroundColor ]. - "see setStopConditions for stopping conditions for displaying." - (self perform: stopCondition) ifTrue: [ - "Number of characters remaining in the current run" - ^ runStopIndex - lastIndex ] - ] repeat! ! -!MorphicScanner methodsFor: 'stop conditions' stamp: 'jmv 6/15/2020 19:33:48' prior: 50410783 overrides: 16802069! - tab - destX _ self tabDestX. - lastIndex _ lastIndex + 1. - tabCount _ tabCount + 1. - ^ false! ! - -Object subclass: #CharacterScanner - instanceVariableNames: 'destX lastIndex xTable destY stopConditions text alignment leftMargin rightMargin font line runStopIndex spaceCount spaceWidth tabWidth kern paragraphStyle defaultFont tabCount' - classVariableNames: 'DefaultStopConditions StopConditionsWithPaddedSpace StopConditionsWithSpace' - poolDictionaries: '' - category: 'Graphics-Text'! - -!classDefinition: #CharacterScanner category: #'Graphics-Text' stamp: 'Install-4240-TabHandling-JuanVuletich-2020Jun15-19h22m-jmv.001.cs.st 6/25/2020 16:06:53'! -Object subclass: #CharacterScanner - instanceVariableNames: 'destX lastIndex xTable destY stopConditions text alignment leftMargin rightMargin font line runStopIndex spaceCount spaceWidth tabWidth kern paragraphStyle defaultFont tabCount' - classVariableNames: 'DefaultStopConditions StopConditionsWithPaddedSpace StopConditionsWithSpace' - poolDictionaries: '' - category: 'Graphics-Text'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4240-TabHandling-JuanVuletich-2020Jun15-19h22m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4228] on 18 June 2020 at 3:07:00 pm'! -!Integer methodsFor: 'benchmarks' stamp: 'jmv 6/18/2020 15:05:55' prior: 50526428! - tinyBenchmarks - "Report the results of running the two tiny Squeak benchmarks. - ar 9/10/1999: Adjusted to run at least 1 sec to get more stable results - - Estimations from - https://dl.acm.org/doi/epdf/10.1145/3386335 ('The evolution of Smalltalk: from Smalltalk-72 through Squeak' by Dan Ingalls, p.96) - http://wiki.c2.com/?GreenBook - http://www.wirfs-brock.com/allen/things/smalltalk-things/tektronix-smalltalk-document-archive/1982-qtr4-magnolia-perf-graph.pdf - http://www.wirfs-brock.com/allen/things/smalltalk-things/tektronix-smalltalk-document-archive/1983-Magnolia-st-perf.pdf - - Xerox PARC systems - Alto Smalltalk-72 5MHz µcode 694 bytecodes/sec 54 sends/sec 7200 µclocks/bytecode - Alto Smalltalk-74 5MHz µcode 607 bytecodes/sec 46 sends/sec 8200 µclocks/bytecode - Alto Smalltalk-76 5MHz µcode 16k bytecodes/sec 118 sends/sec 310 µclocks/bytecode - NoteTaker Smalltalk-78 5MHz 8086 30k bytecodes/sec 250 sends/sec 166.67 clocks/bytecode - Dorado Smalltalk-76 16.67MHz µcode 1M bytecodes/sec 50k sends/sec 16.67 µClocks/bytecode - - Green Book systems - DEC PDP-11/23 5k bytecodes/sec (Green Book, p.128) - Apple 5MHz 68000 11k bytecodes/sec (Green Book, p.187, awb) 5000 clocks/bytecode - VAX-11/780 5MHz C HP Smalltalk 10k bytecodes/sec (Green Book, p.235) 450 clocks/bytecode - VAX-11/780 5MHz C Berkeley St 17k bytecodes/sec (Green Book, p.203, awb) 300 clocks/bytecode - DEC VAX-11/780 5MHz assembly 20k bytecodes/sec (Green Book, p.149, awb) 250 clocks/bytecode - TEK Magnolia 10MHz 68000 50k bytecodes/sec (awb) 200 clocks/bytecode - - Squeak & Cuis - 110 MHz PowerPC Mac 8100 4M bytecodes/sec; 175k sends/sec 26.8 clocks/bytecode - 292 MHz G3 Mac: 23M bytecodes/sec; 984k sends/sec 12.8 clocks/bytecode - 400 MHz PII/Win98: 18M bytecodes/sec; 1.08M sends/sec 22.2 clocks/bytecode - - 900MHz RasPi2 - StackVM: 38M bytecodes/sec; 2.41M sends/sec 16.2 clocks/bytecode - 900MHz RasPi2- CogSSpur: 157M bytecodes/sec; 10.95M sends/sec 5.7 clocks/bytecode - - 1GHz C.H.I.P. (*1) - StackVM: 55M bytecodes/sec; 3.35M sends/sec 18.1 clocks/bytecode - 1GHz C.H.I.P. (*1) - CogSpur: 254M bytecodes/sec; 16.85M sends/sec 3.9 clocks/bytecode - - 1.2GHz RasPi3B - StackSpur: 44M bytecodes/sec; 2.77M sends/sec 27.2 clocks/bytecode - 1.2GHz RasPi3B - CogSpur: 282M bytecodes/sec; 16.40M sends/sec 6.6 clocks/bytecode - - 1.66GHz Atom N450 - Cog: 244M bytecodes/sec; 28.80M sends/sec 6.8 clocks/bytecode - 1.66GHz Atom N450 - CogSpur: 470M bytecodes/sec; 30.75M sends/sec 3.5 clocks/bytecode - - 1.33GHz Atom 3735G - Cog: 326M bytecodes/sec; 34.99M sends/sec 4.1 clocks/bytecode - 1.33GHz Atom 3735G - CogSpur: 632M bytecodes/sec; 33.69M sends/sec 2.1 clocks/bytecode - - 1.5GHz AMD A4-5000 - Cog: 390M bytecodes/sec; 47.51M sends/sec 3.8 clocks/bytecode - 1.5GHz AMD A4-5000 - CogSpur: 676M bytecodes/sec; 40.67M sends/sec 2.2 clocks/bytecode - 1.5GHz AMD A4-5000 - CogSpur64: 659M bytecodes/sec; 50.34M sends/sec 2.2 clocks/bytecode - - 2.3GHz Tegra (*2) - StackVM: 259M bytecodes/sec; 13.01M sends/sec 8.9 clocks/bytecode - 2.3GHz Tegra (*2) - CogSpur: 1.08G bytecodes/sec; 64.29M sends/sec 2.1 clocks/bytecode - - 3.1GHz Core i3-2100 - Cog: 1.20G bytecodes/sec; 165.72M sends/sec 2.6 clocks/bytecode - 3.1GHz Core i3-2100 - CogSpur: 2.04G bytecodes/sec; 127.84M sends/sec 1.5 clocks/bytecode - - 2.70GHz Core i5-6400 -CogSpur64 3.16G bytecodes/sec; 243.32M sends/sec 0.85 clocks/bytecode - - (*1) C.H.I.P. $9 Computer [Next Thing Co], Allwinner R8 Single-Core ARM Cortex-A8 - 1 GHz - (*2) ACER Chromebook CB5-311 - NVIDIA Tegra K1 Quad-Core ARM Cortex-A15 'r3' - 2.3 GHz - - It is interesting to note that Spur for the first time brings ARM hardware (RasPi and C.H.I.P.) into a 'Morphic is confortable and nice to use' level of performance, - i.e. around 100 Dorados. - " - | t1 t2 r n1 n2 | - n1 _ 1. - [ - t1 _ Time millisecondsToRun: [n1 benchmark]. - t1 < 1000] - whileTrue: [n1 _ n1 * 2]. "Note: #benchmark's runtime is about O(n)" - - n2 _ 28. - [ - t2 _ Time millisecondsToRun: [r _ n2 benchFib]. - t2 < 1000] - whileTrue: [n2 _ n2 + 1]. - "Note: #benchFib's runtime is about O(k^n), - where k is the golden number = (1 + 5 sqrt) / 2 = 1.618...." - - ^String streamContents: [ :strm | - (n1 * 500000 * 1000) // t1 withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixName; - nextPutAll: 'Bytecodes/second; ' ]. - (r * 1000) // t2 withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixName; - nextPutAll: 'Sends/second' ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4241-tinyBenchmarks-update-JuanVuletich-2020Jun18-12h17m-jmv.001.cs.st----! - -----SNAPSHOT----(25 June 2020 16:06:58) Cuis5.0-4241-32.image priorSource: 5974592! - -----STARTUP---- (5 August 2020 22:21:29) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4241-32.image! - - -'From Cuis 5.0 [latest update: #4241] on 26 June 2020 at 5:06:35 pm'! -!BitBlt commentStamp: 'jmv 6/26/2020 15:21:57' prior: 16785227! - WARNING: BitBlt's shape cannot be modified since WarpBlt relies on the exact layout. Important primitives will break if you fail to heed this warning. - -I represent a block transfer (BLT) of pixels from one Form ( the sourceForm) into a rectangle (destX, destY, width, height) of the destinationForm, as modified by a combination rule, a possible halftoneForm and a possible color map. - -The source of pixels may be a similar rectangle (at sourceX, sourceY) in the sourceForm, or the halftoneForm, or both. If both are specified, their pixel values are combined by a logical AND function prior to any further combination rule processing. The halftoneForm may be an actual Form or a simple WordArray of 32 bit values usually intended to represent Color values. In either case the 'top' of the form is effectively aligned with the top of the destinationForm and for each scanline the destination y modulo the size of the halftoneForm gives the index of the word to use. This makes it easy to make horizontal stripes, for example. - -In any case, the pixels from the source (AND'd with the halftone, remember) are combined with those of the destination by as specified by the combinationRules below- - name rule result - - 0 always 0 - and 1 src AND dst - 2 src AND not(dst) - over 3 src only - erase 4 not(src) AND dst - 5 dst only - reverse 6 src XOR dst - under 7 src OR dst - 8 not(src) AND not(dst) - 9 not(src) XOR dst - 10 not(dst) - 11 src OR not(dst) - 12 not(src) - 13 not(src) OR dst - 14 not(src) OR not(dst) - 15 always 1 -(You can find an interesting explanation of how this comes to be in http://dev-docs.atariforge.org/files/BLiTTER_1-25-1990.pdf - which interestingly fails to mention any connection to Smalltalk and PARC.) - -Forms may be of different depths, see the comment in class Form. - -In addition to the original 16 combination rules invented for monochrome Forms, this BitBlt supports - 16 fails (to simulate paint bits) - 17 fails (to simulate erase bits) - 18 sourceWord + destinationWord - 19 sourceWord - destinationWord - 20 rgbAdd: sourceWord with: destinationWord. Sum of color components - 21 rgbSub: sourceWord with: destinationWord. Difference of color components - 22 OLDrgbDiff: sourceWord with: destinationWord. Sum of abs of differences in components - 23 OLDtallyIntoMap: destinationWord. Tallies pixValues into a colorMap - these old versions don't do bitwise dest clipping. Use 32 and 33 now. - blend 24 alphaBlend: sourceWord with: destinationWord. 32-bit source and dest only. Blend sourceWord - with destinationWord, assuming both are 32-bit pixels. The source is assumed to have 255*alpha - in the high 8 bits of each pixel, while the high 8 bits of the destinationWord will be ignored. - The blend produced is alpha*source + (1-alpha)*dest, with the computation being performed - independently on each color component. The high byte of the result will be 0. - paint 25 pixPaint: sourceWord with: destinationWord. Wherever the sourceForm is non-zero, it replaces - the destination. Can be used with a 1-bit source color mapped to (0, FFFFFFFF), and a fillColor - to fill the dest with that color wherever the source is 1. - erase1BitShape 26 pixMask: sourceWord with: destinationWord. Like pixPaint, but fills with 0. - 27 rgbMax: sourceWord with: destinationWord. Max of each color component. - 28 rgbMin: sourceWord with: destinationWord. Min of each color component. - 29 rgbMin: sourceWord bitInvert32 with: destinationWord. Min with (max-source) - blendAlpha 30 alphaBlendConst: sourceWord with: destinationWord. alpha is an arg. works in 16 bits. Blend - sourceWord with destinationWord using a constant alpha. Alpha is encoded as 0 meaning - 0.0, and 255 meaning 1.0. The blend produced is alpha*source + (1.0-alpha)*dest, with - the computation being performed independently on each color component. - paintAlpha 31 alphaPaintConst: sourceWord with: destinationWord. alpha is an arg. works in 16 bits. - 32 rgbDiff: sourceWord with: destinationWord. Sum of abs of differences in components - 33 tallyIntoMap: destinationWord. Tallies pixValues into a colorMap - Those tallied are exactly - those in the destination rectangle. Note that the source should be specified == destination, - in order for the proper color map checks be performed at setup. - blendAlphaScaled 34 alphaBlendScaled: srcWord with: dstWord. Alpha blend of scaled srcWord and destWord. In contrast - to alphaBlend:with: the color produced is srcColor + (1-srcAlpha) * dstColor - 35 & 36 not used - rgbMul 37 rgbMul: srcWord with: dstWord. - 38 pixSwap: srcWord with: dstWord. - 39 pixClear: srcWord with: dstWord. Clear all pixels in destinationWord for which the pixels of - sourceWord have the same values. Used to clear areas of some constant color to zero. - 40 fixAlpha: srcWord with: dstWord. For any non-zero pixel value in destinationWord with zero alpha - channel take the alpha from sourceWord and fill it in. Intended for fixing alpha channels left at - zero during 16->32 bpp conversions. - 41 rgbComponentAlpha: srcWord with: dstWord. - -Any transfer specified is further clipped by the specified clipping rectangle (clipX, clipY, clipWidth, clipHeight), and also by the bounds of the source and destination forms. - To make a small Form repeat and fill a big form, use an InfiniteForm as the source. - -Pixels copied from a source to a destination whose pixels have a different depth are converted based on the optional colorMap. If colorMap is nil, then conversion to more bits is done by filling the new high-order bits with zero, and conversion to fewer bits is done by truncating the lost high-order bits. - -The colorMap, if specified, must be a either word array (ie Bitmap) with 2^n elements, where n is the pixel depth of the source, or a fully specified ColorMap which may contain a lookup table (ie Bitmap) and/or four separate masks and shifts which are applied to the pixels. For every source pixel, BitBlt will first perform masking and shifting and then index the lookup table, and select the corresponding pixelValue and mask it to the destination pixel size before storing. - When blitting from a 32 or 16 bit deep Form to one 8 bits or less, the default is truncation. This will produce very strange colors, since truncation of the high bits does not produce the nearest encoded color. Supply a 512 long colorMap, and red, green, and blue will be shifted down to 3 bits each, and mapped. The message copybits...stdColors will use the best map to the standard colors for destinations of depths 8, 4, 2 and 1. Two other sized of colorMaps are allowed, 4096 (4 bits per color) and 32786 (five bits per color). - Normal blits between 16 and 32 bit forms truncates or pads the colors automatically to provide the best preservation of colors. - Colors can be remapped at the same depth. Sometimes a Form is in terms of colors that are not the standard colors for this depth, for example in a GIF file. Convert the Form to a MaskedForm and send colorMap: the list of colors that the picture is in terms of. (Note also that a Form can be copied to itself, and transformed in the process, if a non-nil colorMap is supplied.)! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 6/26/2020 16:01:09' prior: 50453436! - standardWindowExtent - "Answer the standard default extent for new windows. " - - | grid allowedArea maxLevel | - "NOTE: following copied from strictlyStaggeredInitialFrameFor:" - allowedArea _ self maximumUsableArea insetBy: ( - self scrollBarSetback @ self screenTopSetback extent: `0@0` - ). - "Number to be staggered at each corner (less on small screens)" - maxLevel _ allowedArea area > 700000 ifTrue: [3] ifFalse: [2]. - "Amount by which to stagger (less on small screens)" - grid _ allowedArea area > 700000 ifTrue: [40] ifFalse: [20]. - ^ ((allowedArea extent - (grid*(maxLevel+1*2) + (grid//2))) min: `52@40` * Preferences standardCodeFont lineSpacing) rounded! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4242-MakeDefaultWindowBoundsIntegers-JuanVuletich-2020Jun26-17h06m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4241] on 27 June 2020 at 6:50:36 pm'! - -Scanner subclass: #Parser - instanceVariableNames: 'here hereType hereMark hereEnd prevMark prevEnd encoder requestor parseNode failBlock requestorOffset tempsMark doitFlag properties category advanced ' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #Parser category: #'Compiler-Kernel' stamp: 'Install-4243-ParserRefactoring-HernanWilkinson-2020Jun27-18h34m-HAW.001.cs.st 8/5/2020 22:21:34'! -Scanner subclass: #Parser - instanceVariableNames: 'here hereType hereMark hereEnd prevMark prevEnd encoder requestor parseNode failBlock requestorOffset tempsMark doitFlag properties category advanced' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! -!Parser methodsFor: 'expression types' stamp: 'HAW 6/27/2020 18:41:23'! - literalExpression - - parseNode := self advanceWithRangeDo: [ :lexema :range | encoder encodeLiteral: lexema range: range ]. - - ^true! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 6/27/2020 18:41:41'! - literalNumberExpression - - self advanceWithRangeDo: [ :minusChar :minusRange | - self advanceWithRangeDo: [ :number :numberRange | - parseNode := encoder encodeLiteral: number negated range: (minusRange first to: numberRange last)]]. - - ^true! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 6/27/2020 18:47:00'! - parenthesisExpression - - self advance. - self expression ifFalse: [^self expected: 'expression']. - (self match: #rightParenthesis) ifFalse: [^self expected: 'right parenthesis']. - - ^true! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 6/27/2020 18:40:19'! - variableExpression - - parseNode _ self variable. - - " - (parseNode isUndefTemp and: [self interactive] and: [ - ((requestor isKindOf: Editor) or: [ requestor is: #Morph ])]) - " - "If the requestor is of an exotic kind (like a telnet server) we might not be - allowed to open a PupUpMenu for querying the user" - - (parseNode isUndefTemp and: [ self interactive ]) - ifTrue: [self queryUndefined]. - parseNode nowHasRef. - - ^true! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 6/27/2020 18:46:12' prior: 50502450! -blockExpression - "[ ({:var} |) (| {temps} |) (statements) ] => BlockNode." - - | blockNode tempsDeclarationNode variableNodes temporaryBlockVariables start | - - blockNode := BlockNode new. - variableNodes := OrderedCollection new. - start := prevMark + requestorOffset. - "Gather parameters." - [self match: #colon] whileTrue: - [self argumentNameWithRangeDo: [ :argumentName :range | - variableNodes addLast: (encoder bindBlockArg: argumentName within: blockNode range: range)]]. - (variableNodes size > 0 & (hereType ~~ #rightBracket) and: [(self match: #verticalBar) not]) ifTrue: - [^self expected: 'Vertical bar']. - - tempsDeclarationNode := self temporaryBlockVariablesFor: blockNode. - temporaryBlockVariables := tempsDeclarationNode allDeclaredVariableNodes. - self statements: variableNodes innerBlock: true blockNode: blockNode. - blockNode temporariesDeclaration: tempsDeclarationNode. - - (self match: #rightBracket) ifFalse: [^self expected: 'Period or right bracket']. - - blockNode noteSourceRangeStart: start end: self endOfLastToken encoder: encoder. - - "The scope of the parameters and temporary block variables is no longer active." - temporaryBlockVariables do: [:variable | variable scope: -1]. - variableNodes do: [:variable | variable scope: -1]. - - ^true! ! -!Parser methodsFor: 'backtick' stamp: 'HAW 6/27/2020 18:47:29' prior: 50525622! - backtickExpression - - | start range | - - start := self startOfNextToken. - self advance. - self expression ifFalse: [^self expected: 'expression']. - (self match: #backtick) ifFalse: [^self expected: 'backtick']. - range := start to: prevEnd. - - parseNode := BacktickNode - expression: parseNode - source: (source contents copyFrom: range first+1 to: range last-1) - parser: self - range: range. - - encoder noteSourceRange: range forNode: parseNode. - - ^true! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 6/27/2020 19:05:25' prior: 50525883! - primaryExpression - - hereType == #word - ifTrue: [ - parseNode _ self variable. - - " - (parseNode isUndefTemp and: [self interactive] and: [ - ((requestor isKindOf: Editor) or: [ requestor is: #Morph ])]) - " - "If the requestor is of an exotic kind (like a telnet server) we might not be - allowed to open a PupUpMenu for querying the user" - - (parseNode isUndefTemp and: [ self interactive ]) - ifTrue: [self queryUndefined]. - parseNode nowHasRef. - ^ true]. - hereType == #leftBracket - ifTrue: [ - advanced := true. - self advance. - self blockExpression. - ^true]. - hereType == #leftBrace - ifTrue: [ - self braceExpression. - ^true]. - hereType == #leftParenthesis - ifTrue: [ - self advance. - self expression ifFalse: [^self expected: 'expression']. - (self match: #rightParenthesis) - ifFalse: [^self expected: 'right parenthesis']. - ^true]. - (hereType == #string or: [hereType == #number or: [hereType == #literal]]) - ifTrue: [ - parseNode := self advanceWithRangeDo: [ :lexema :range | encoder encodeLiteral: lexema range: range ]. - ^true]. - (here == #- and: [tokenType == #number]) - ifTrue: [ - self advanceWithRangeDo: [ :minusChar :minusRange | - self advanceWithRangeDo: [ :number :numberRange | - parseNode := encoder encodeLiteral: number negated range: (minusRange first to: numberRange last)]]. - ^true]. - - hereType == #backtick - ifTrue: [ - self backtickExpression. - ^true ]. - - ^false! ! - -Scanner subclass: #Parser - instanceVariableNames: 'here hereType hereMark hereEnd prevMark prevEnd encoder requestor parseNode failBlock requestorOffset tempsMark doitFlag properties category advanced' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #Parser category: #'Compiler-Kernel' stamp: 'Install-4243-ParserRefactoring-HernanWilkinson-2020Jun27-18h34m-HAW.001.cs.st 8/5/2020 22:21:34'! -Scanner subclass: #Parser - instanceVariableNames: 'here hereType hereMark hereEnd prevMark prevEnd encoder requestor parseNode failBlock requestorOffset tempsMark doitFlag properties category advanced' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4243-ParserRefactoring-HernanWilkinson-2020Jun27-18h34m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4242] on 27 June 2020 at 7:07:50 pm'! -!Parser methodsFor: 'expression types' stamp: 'HAW 6/27/2020 19:06:38' prior: 50527451! - blockExpression - "[ ({:var} |) (| {temps} |) (statements) ] => BlockNode." - - | blockNode tempsDeclarationNode variableNodes temporaryBlockVariables start | - - advanced == true ifFalse: [ self advance ]. - - blockNode := BlockNode new. - variableNodes := OrderedCollection new. - start := prevMark + requestorOffset. - "Gather parameters." - [self match: #colon] whileTrue: - [self argumentNameWithRangeDo: [ :argumentName :range | - variableNodes addLast: (encoder bindBlockArg: argumentName within: blockNode range: range)]]. - (variableNodes size > 0 & (hereType ~~ #rightBracket) and: [(self match: #verticalBar) not]) ifTrue: - [^self expected: 'Vertical bar']. - - tempsDeclarationNode := self temporaryBlockVariablesFor: blockNode. - temporaryBlockVariables := tempsDeclarationNode allDeclaredVariableNodes. - self statements: variableNodes innerBlock: true blockNode: blockNode. - blockNode temporariesDeclaration: tempsDeclarationNode. - - (self match: #rightBracket) ifFalse: [^self expected: 'Period or right bracket']. - - blockNode noteSourceRangeStart: start end: self endOfLastToken encoder: encoder. - - "The scope of the parameters and temporary block variables is no longer active." - temporaryBlockVariables do: [:variable | variable scope: -1]. - variableNodes do: [:variable | variable scope: -1]. - - ^true! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4244-ParserRefactoring-HernanWilkinson-2020Jun27-19h05m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4242] on 27 June 2020 at 7:09:35 pm'! -!Parser methodsFor: 'expression types' stamp: 'HAW 6/27/2020 19:08:46'! - isLiteralExpression - - ^ hereType == #string or: [hereType == #number or: [hereType == #literal]]! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 6/27/2020 19:09:05'! - isLiteralNumberExpression - - ^ here == #- and: [tokenType == #number]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4245-ParserRefactoring-HernanWilkinson-2020Jun27-19h07m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4242] on 27 June 2020 at 7:13:18 pm'! -!Parser methodsFor: 'expression types' stamp: 'HAW 6/27/2020 19:12:36' prior: 50527510! - primaryExpression - - hereType == #word ifTrue: [ ^self variableExpression ]. - hereType == #leftBracket ifTrue: [ ^self blockExpression ]. - hereType == #leftBrace ifTrue: [ ^self braceExpression ]. - hereType == #leftParenthesis ifTrue: [ ^self parenthesisExpression ]. - (self isLiteralExpression) ifTrue: [ ^self literalExpression ]. - (self isLiteralNumberExpression) ifTrue: [ ^self literalNumberExpression ]. - hereType == #backtick ifTrue: [ ^self backtickExpression ]. - - ^false! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4246-ParserRefactoring-HernanWilkinson-2020Jun27-19h09m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4242] on 27 June 2020 at 7:14:34 pm'! - -Scanner subclass: #Parser - instanceVariableNames: 'here hereType hereMark hereEnd prevMark prevEnd encoder requestor parseNode failBlock requestorOffset tempsMark doitFlag properties category advanced ' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #Parser category: #'Compiler-Kernel' stamp: 'Install-4247-ParserExpression-HernanWilkinson-2020Jun27-19h13m-HAW.001.cs.st 8/5/2020 22:21:34'! -Scanner subclass: #Parser - instanceVariableNames: 'here hereType hereMark hereEnd prevMark prevEnd encoder requestor parseNode failBlock requestorOffset tempsMark doitFlag properties category advanced' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! -!Parser methodsFor: 'expression types' stamp: 'HAW 6/27/2020 19:13:39' prior: 50527590! - blockExpression - "[ ({:var} |) (| {temps} |) (statements) ] => BlockNode." - - | blockNode tempsDeclarationNode variableNodes temporaryBlockVariables start | - - self advance. - - blockNode := BlockNode new. - variableNodes := OrderedCollection new. - start := prevMark + requestorOffset. - "Gather parameters." - [self match: #colon] whileTrue: - [self argumentNameWithRangeDo: [ :argumentName :range | - variableNodes addLast: (encoder bindBlockArg: argumentName within: blockNode range: range)]]. - (variableNodes size > 0 & (hereType ~~ #rightBracket) and: [(self match: #verticalBar) not]) ifTrue: - [^self expected: 'Vertical bar']. - - tempsDeclarationNode := self temporaryBlockVariablesFor: blockNode. - temporaryBlockVariables := tempsDeclarationNode allDeclaredVariableNodes. - self statements: variableNodes innerBlock: true blockNode: blockNode. - blockNode temporariesDeclaration: tempsDeclarationNode. - - (self match: #rightBracket) ifFalse: [^self expected: 'Period or right bracket']. - - blockNode noteSourceRangeStart: start end: self endOfLastToken encoder: encoder. - - "The scope of the parameters and temporary block variables is no longer active." - temporaryBlockVariables do: [:variable | variable scope: -1]. - variableNodes do: [:variable | variable scope: -1]. - - ^true! ! - -Scanner subclass: #Parser - instanceVariableNames: 'here hereType hereMark hereEnd prevMark prevEnd encoder requestor parseNode failBlock requestorOffset tempsMark doitFlag properties category' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #Parser category: #'Compiler-Kernel' stamp: 'Install-4247-ParserExpression-HernanWilkinson-2020Jun27-19h13m-HAW.001.cs.st 8/5/2020 22:21:34'! -Scanner subclass: #Parser - instanceVariableNames: 'here hereType hereMark hereEnd prevMark prevEnd encoder requestor parseNode failBlock requestorOffset tempsMark doitFlag properties category' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4247-ParserExpression-HernanWilkinson-2020Jun27-19h13m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4246] on 27 June 2020 at 7:52:55 pm'! -!BrowserWindow class methodsFor: 'GUI building' stamp: 'HAW 6/27/2020 19:48:57'! - classNamesFrom: potentialClassNames with: pattern matching: toMatch - - ^ (pattern last = $. or: [pattern last = $ ]) - ifTrue: [potentialClassNames select: [:className | className asLowercase = toMatch]] - ifFalse: [potentialClassNames select: [:className | className includesSubstring: toMatch caseSensitive: false]]! ! -!BrowserWindow class methodsFor: 'GUI building' stamp: 'HAW 6/27/2020 19:48:57'! - findClassFrom: potentialClassNames ifFound: aBlock with: pattern - - | exactMatch foundClass index classNames toMatch | - - pattern isEmpty ifTrue: [^self flash]. - - toMatch _ (pattern copyWithout: $.) asLowercase withBlanksTrimmed. - classNames _ self classNamesFrom: potentialClassNames with: pattern matching: toMatch. - classNames isEmpty ifTrue: [^self flash]. - - exactMatch _ classNames detect: [ :each | each asLowercase = toMatch] ifNone: [ nil ]. - index _ self indexOfClassFrom: classNames exactMatch: exactMatch. - index = 0 ifTrue: [^self flash]. - - foundClass _ Smalltalk at: (classNames at: index) asSymbol. - aBlock value: foundClass! ! -!BrowserWindow class methodsFor: 'GUI building' stamp: 'HAW 6/27/2020 19:51:15'! - indexOfClassFrom: classNames exactMatch: exactMatch - - | options | - - classNames size = 1 ifTrue: [ ^1 ]. - - options := exactMatch - ifNil: [ PopUpMenu labelArray: classNames lines: #()] - ifNotNil: [ - classNames remove: exactMatch ifAbsent: []. - classNames addFirst: exactMatch. - PopUpMenu labelArray: classNames lines: #(1)]. - - ^options startUpMenu! ! -!BrowserWindow methodsFor: 'commands' stamp: 'HAW 6/27/2020 19:43:29' prior: 50447140! -findClass - - | scopedClassNames | - - scopedClassNames _ model potentialClassNames asOrderedCollection. - - self class - findClassFrom: scopedClassNames - ifFound: [:foundClass | - model selectCategoryForClass: foundClass. - model selectClass: foundClass ]! ! -!BrowserWindow class methodsFor: 'GUI building' stamp: 'HAW 6/27/2020 19:49:27' prior: 50525084! - findClassFrom: potentialClassNames ifFound: aBlock - - self classNameRequester - request: self findClassDialogTitle - initialAnswer: '' - do: [ :pattern | self findClassFrom: potentialClassNames ifFound: aBlock with: pattern ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4248-FindClassRefactoring-HernanWilkinson-2020Jun27-19h22m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4242] on 29 June 2020 at 1:45:03 pm'! -!Behavior methodsFor: 'accessing' stamp: 'HAW 6/28/2020 10:57:39'! - theNonMetaClass - - self subclassResponsibility ! ! -!Behavior methodsFor: 'printing' stamp: 'HAW 6/28/2020 12:25:41'! - printSubclassesOn: aStream level: level - "As part of the algorithm for printing a description of the receiver, print the - subclass on the file stream, aStream, indenting level times." - | subclassNames | - aStream newLineTab: level. - aStream nextPutAll: self name. - aStream - space; - print: self instVarNames. - self == Class ifTrue: [ - aStream - newLineTab: level + 1; - nextPutAll: '[ ... all the Metaclasses ... ]'. - ^ self ]. - subclassNames _ self subclasses asArray sort: [ :c1 :c2 | - c1 name <= c2 name ]. - "Print subclasses in alphabetical order" - subclassNames do: [ :subclass | - subclass - printSubclassesOn: aStream - level: level + 1 ].! ! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'HAW 6/28/2020 12:05:30'! - subclassesDo: aBlock - "Evaluate the argument, aBlock, for each of the receiver's immediate subclasses." - ^self subclasses do: aBlock! ! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'jmv 6/29/2020 13:06:24'! - subclassesDoGently: aBlock - "Evaluate the argument, aBlock, for each of the receiver's immediate subclasses." - - ^self subclassesDo: aBlock! ! -!Behavior methodsFor: 'accessing method dictionary' stamp: 'HAW 6/28/2020 12:20:34'! - recoverFromMDFaultWithTrace - - self subclassResponsibility ! ! -!Behavior methodsFor: 'accessing method dictionary' stamp: 'HAW 6/28/2020 12:22:58'! - ultimateSourceCodeAt: selector ifAbsent: aBlock - "Return the source code at selector, deferring to superclass if necessary" - - ^ self - sourceCodeAt: selector - ifAbsent: [ - superclass - ifNil: [aBlock value] - ifNotNil: [superclass ultimateSourceCodeAt: selector ifAbsent: aBlock]]! ! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'HAW 6/28/2020 11:54:26'! - allBroadAccessesTo: instVarName - - | references instVarIndex definingClass | - - definingClass _ self whichClassDefinesInstanceVariable: instVarName ifNone: [ ^#() ]. - instVarIndex _ self indexOfInstanceVariable: instVarName. - references _ SortedCollection sortBlock: [ :left :right | left stringVersion <= right stringVersion ]. - - definingClass withAllSubclassesDo: [ :class | class addReferencesOf: instVarName at: instVarIndex to: references ]. - - ^ references ! ! -!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'HAW 6/28/2020 12:18:42' overrides: 16783715! - changeRecordsAt: selector - "Return a list of ChangeRecords for all versions of the method at selector. Source code can be retrieved by sending string to any one. Return nil if the method is absent." - - "(Pen changeRecordsAt: #go:) collect: [:cRec | cRec string]" - | aList | - aList _ VersionsBrowser new - scanVersionsOf: (self compiledMethodAt: selector ifAbsent: [^ nil]) - class: self meta: self isMeta - category: (self whichCategoryIncludesSelector: selector) - selector: selector. - ^ aList ifNotNil: [aList changeList]! ! -!ClassDescription methodsFor: 'accessing instances and variables' stamp: 'HAW 6/28/2020 12:13:50' overrides: 50407126! - allUnreferencedInstanceVariables - - "Return a list of the instance variables known to the receiver which are not referenced in the receiver or any of its subclasses OR superclasses" - - ^ self allInstVarNames reject: [ :instanceVariableName | | definingClass | - definingClass _ self classThatDefinesInstanceVariable: instanceVariableName. - definingClass isInstanceVariableNamedReferencedInHierarchy: instanceVariableName ]! ! -!ClassDescription methodsFor: 'pool variables' stamp: 'HAW 6/28/2020 12:30:46'! - classPool - - self subclassResponsibility ! ! -!Class methodsFor: 'private' stamp: 'jmv 6/29/2020 13:02:26' overrides: 50430646! - becomeCompact - "Here are the restrictions on compact classes in order for export segments to work: A compact class index may not be reused. If a class was compact in a release of Squeak, no other class may use that index. The class might not be compact later, and there should be nil in its place in the array." - | cct index | - - Smalltalk isSpur ifTrue: [^ self halt: 'No Compact Classes support in Spur']. - self isWeak ifTrue:[^ self halt: 'You must not make a weak class compact']. - cct _ Smalltalk compactClassesArray. - (self indexIfCompact > 0 or: [cct includes: self]) - ifTrue: [^ self halt: self name , 'is already compact']. - index _ cct indexOf: nil - ifAbsent: [^ self halt: 'compact class table is full']. - "Install this class in the compact class table" - cct at: index put: self. - "Update instspec so future instances will be compact" - format _ format + (index bitShift: 11). - "Make up new instances and become old ones into them" - self updateInstancesFrom: self. - "Purge any old instances" - Smalltalk garbageCollect.! ! -!Class methodsFor: 'private' stamp: 'jmv 6/29/2020 13:03:05' overrides: 16784763! - becomeCompactSimplyAt: index - "Make me compact, but don't update the instances. For importing segments." -"Here are the restrictions on compact classes in order for export segments to work: A compact class index may not be reused. If a class was compact in a release of Squeak, no other class may use that index. The class might not be compact later, and there should be nil in its place in the array." - | cct | - - Smalltalk isSpur ifTrue: [^ self halt: 'No Compact Classes support in Spur']. - self isWeak ifTrue:[^ self halt: 'You must not make a weak class compact']. - cct _ Smalltalk compactClassesArray. - (self indexIfCompact > 0 or: [cct includes: self]) - ifTrue: [^ self halt: self name , 'is already compact']. - (cct at: index) ifNotNil: [^ self halt: 'compact table slot already in use']. - "Install this class in the compact class table" - cct at: index put: self. - "Update instspec so future instances will be compact" - format _ format + (index bitShift: 11). - "Caller must convert the instances" -! ! -!Class methodsFor: 'private' stamp: 'jmv 6/29/2020 13:02:15' overrides: 50430681! - becomeUncompact - | cct index | - cct _ Smalltalk compactClassesArray. - (index _ self indexIfCompact) = 0 - ifTrue: [^ self]. - (cct includes: self) - ifFalse: [^ self halt "inconsistent state"]. - "Update instspec so future instances will not be compact" - format _ format - (index bitShift: 11). - "Make up new instances and become old ones into them" - self updateInstancesFrom: self. - "Make sure there are no compact ones left around" - Smalltalk garbageCollect. - "Remove this class from the compact class table" - cct at: index put: nil. -! ! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'jmv 6/29/2020 13:18:25' prior: 16784063! - allRegularInstVarNames - "Answer an Array of the names of the receiver's instance variables. The - Array ordering is the order in which the variables are stored and - accessed by the interpreter. - - Quite like asking #allInstVarNames, but do not include Behavior state (i.e. Smalltalk internals)" - - ^ (self == ProtoObject class or: [ superclass isNil ]) - ifTrue: [self instVarNames copy] "Guarantee a copy is answered." - ifFalse: [superclass allRegularInstVarNames , self instVarNames].! ! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'HAW 6/28/2020 12:34:05' prior: 16806705! - fileOutChangedMessages: aSet on: aFileStream moveSource: moveSource toFile: fileIndex - "File a description of the messages of this class that have been - changed (i.e., are entered into the argument, aSet) onto aFileStream. If - moveSource, is true, then set the method source pointer to the new file position. - Note when this method is called with moveSource=true, it is condensing the - .changes file, and should only write a preamble for every method." - - | org categories | - - org _ self organization. - categories _ org categories. - - categories ifNotNil: [ categories do: [ :cat | | sels | - sels _ (org listAtCategoryNamed: cat) select: [:sel | aSet includes: sel]. - sels do: [:sel | - self printMethodChunk: sel withPreamble: true on: aFileStream moveSource: moveSource toFile: fileIndex]]]! ! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'HAW 6/28/2020 12:38:48' prior: 50482125! - fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex - "File a description of the receiver on aFileStream. If the boolean - argument, moveSource, is true, then set the trailing bytes to the position - of aFileStream and to fileIndex in order to indicate where to find the - source code." - - | categories | - - aFileStream nextPut: $!!; nextChunkPut: self definitionPreambleWithoutStamp; newLine. - aFileStream nextChunkPut: self definition. - - self organization - putCommentOnFile: aFileStream - numbered: fileIndex - moveSource: moveSource - forClass: self. - categories := self organization categories. - categories ifNotNil: [ categories do: [ :heading | - self fileOutCategory: heading - on: aFileStream - moveSource: moveSource - toFile: fileIndex]]! ! -!Class methodsFor: 'class variables' stamp: 'HAW 6/28/2020 16:34:20' prior: 16802479! - removeClassVarName: aString - "Remove the class variable whose name is the argument, aString, from - the names defined in the receiver, a class. Create an error notification if - aString is not a class variable or if it is still being used in the code of - the class." - - | aSymbol | - aSymbol _ aString asSymbol. - (classPool isNil or: [(classPool includesKey: aSymbol) not]) - ifTrue: [ ^self error: aString, ' is not a class variable']. - self withAllSubclasses do:[:subclass | - (Array with: subclass with: subclass class) do: [ :classOrMeta | - (classOrMeta whichSelectorsReferTo: (classPool associationAt: aSymbol)) - isEmpty ifFalse: [ - InMidstOfFileinNotification signal ifTrue: [ - Transcript newLine; show: self name, ' (' , aString , ' is Undeclared) '. - ^Undeclared declare: aSymbol from: classPool ]. - (self confirm: (aString,' is still used in code of class ', classOrMeta name, - '.\Is it okay to move it to Undeclared?') withNewLines) - ifTrue: [ ^Undeclared declare: aSymbol from: classPool ] - ifFalse: [ ^self ]]]]. - classPool removeKey: aSymbol. - classPool isEmpty ifTrue: [ classPool _ nil ]! ! -!Class methodsFor: 'pool variables' stamp: 'HAW 6/28/2020 16:39:55' prior: 16802546! - removeSharedPool: aDictionary - "Remove the pool dictionary, aDictionary, as one of the receiver's pool - dictionaries. Create an error notification if the dictionary is not one of - the pools. - : Note that it removes the wrong one if there are two empty Dictionaries in the list." - - | satisfiedSet workingSet aSubclass | - - (sharedPools isNil or: [(sharedPools includes: aDictionary) not ]) - ifTrue: [^self error: 'the dictionary is not in my pool']. - - "first see if it is declared in a superclass in which case we can remove it." - (self selectSuperclasses: [:class | class sharedPools includes: aDictionary]) isEmpty - ifFalse: [sharedPools remove: aDictionary. - sharedPools isEmpty ifTrue: [sharedPools _ nil]. - ^self]. - - "second get all the subclasses that reference aDictionary through me rather than a - superclass that is one of my subclasses." - - workingSet _ self subclasses asOrderedCollection. - satisfiedSet _ Set new. - [workingSet isEmpty] whileFalse: - [aSubclass _ workingSet removeFirst. - (aSubclass sharedPools includes: aDictionary) - ifFalse: - [satisfiedSet add: aSubclass. - workingSet addAll: aSubclass subclasses]]. - - "for each of these, see if they refer to any of the variables in aDictionary because - if they do, we can not remove the dictionary." - satisfiedSet add: self. - satisfiedSet do: - [:sub | - aDictionary associationsDo: - [:aGlobal | - (sub whichSelectorsReferTo: aGlobal) isEmpty - ifFalse: [^self error: aGlobal key - , ' is still used in code of class ' - , sub name]]]. - sharedPools remove: aDictionary. - sharedPools isEmpty ifTrue: [sharedPools _ nil]! ! -!Class methodsFor: 'release' stamp: 'HAW 6/28/2020 16:32:41' prior: 16803101! - removeFromSystem: logged - "Forget the receiver from the Smalltalk global dictionary. Any existing - instances will refer to an obsolete version of the receiver." - - "keep the class name and category for triggering the system change message. If we wait to long, then we get obsolete information which is not what we want." - - "tell class to unload itself" - self unload. - self superclass ifNotNil: [:aSuperclass | - "If we have no superclass there's nothing to be remembered" - aSuperclass addObsoleteSubclass: self]. - Smalltalk forgetClass: self logged: logged. - self obsolete.! ! -!Metaclass methodsFor: 'accessing instances and variables' stamp: 'HAW 6/28/2020 11:38:18' overrides: 16784017! - allClassVarNames - - "Metaclasses do not define class vars - Hernan" - - ^superclass allClassVarNames! ! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'HAW 6/28/2020 11:34:48' prior: 16784017! - allClassVarNames - "Answer a Set of the names of the receiver's and the receiver's ancestor's - class variables." - - self subclassResponsibility ! ! - -ClassDescription removeSelector: #subclassesDo:! - -!methodRemoval: ClassDescription #subclassesDo: stamp: 'Install-4249-BehaviorHierarchyTypeErrorFixes-HernanWilkinson-JuanVuletich-2020Jun29-13h02m-jmv.001.cs.st 8/5/2020 22:21:34'! -subclassesDo: aBlock - "Evaluate the argument, aBlock, for each of the receiver's immediate subclasses." - ^self subclasses do: aBlock! - -ClassDescription removeSelector: #printSubclassesOn:level:! - -!methodRemoval: ClassDescription #printSubclassesOn:level: stamp: 'Install-4249-BehaviorHierarchyTypeErrorFixes-HernanWilkinson-JuanVuletich-2020Jun29-13h02m-jmv.001.cs.st 8/5/2020 22:21:34'! -printSubclassesOn: aStream level: level - "As part of the algorithm for printing a description of the receiver, print the - subclass on the file stream, aStream, indenting level times." - | subclassNames | - aStream newLineTab: level. - aStream nextPutAll: self name. - aStream - space; - print: self instVarNames. - self == Class ifTrue: [ - aStream - newLineTab: level + 1; - nextPutAll: '[ ... all the Metaclasses ... ]'. - ^ self ]. - subclassNames _ self subclasses asArray sort: [ :c1 :c2 | - c1 name <= c2 name ]. - "Print subclasses in alphabetical order" - subclassNames do: [ :subclass | - subclass - printSubclassesOn: aStream - level: level + 1 ].! - -ClassDescription removeSelector: #ultimateSourceCodeAt:ifAbsent:! - -!methodRemoval: ClassDescription #ultimateSourceCodeAt:ifAbsent: stamp: 'Install-4249-BehaviorHierarchyTypeErrorFixes-HernanWilkinson-JuanVuletich-2020Jun29-13h02m-jmv.001.cs.st 8/5/2020 22:21:34'! -ultimateSourceCodeAt: selector ifAbsent: aBlock - "Return the source code at selector, deferring to superclass if necessary" - ^ self sourceCodeAt: selector ifAbsent: - [superclass - ifNil: - [aBlock value] - ifNotNil: - [superclass ultimateSourceCodeAt: selector ifAbsent: aBlock]]! - -Behavior removeSelector: #becomeUncompact! - -!methodRemoval: Behavior #becomeUncompact stamp: 'Install-4249-BehaviorHierarchyTypeErrorFixes-HernanWilkinson-JuanVuletich-2020Jun29-13h02m-jmv.001.cs.st 8/5/2020 22:21:34'! -becomeUncompact - | cct index | - cct _ Smalltalk compactClassesArray. - (index _ self indexIfCompact) = 0 - ifTrue: [^ self]. - (cct includes: self) - ifFalse: [^ self halt "inconsistent state"]. - "Update instspec so future instances will not be compact" - format _ format - (index bitShift: 11). - "Make up new instances and become old ones into them" - self updateInstancesFrom: self. - "Make sure there are no compact ones left around" - Smalltalk garbageCollect. - "Remove this class from the compact class table" - cct at: index put: nil. -! - -Behavior removeSelector: #becomeCompact! - -!methodRemoval: Behavior #becomeCompact stamp: 'Install-4249-BehaviorHierarchyTypeErrorFixes-HernanWilkinson-JuanVuletich-2020Jun29-13h02m-jmv.001.cs.st 8/5/2020 22:21:34'! -becomeCompact - "Here are the restrictions on compact classes in order for export segments to work: A compact class index may not be reused. If a class was compact in a release of Squeak, no other class may use that index. The class might not be compact later, and there should be nil in its place in the array." - | cct index | - - Smalltalk isSpur ifTrue: [^ self halt: 'No Compact Classes support in Spur']. - self isWeak ifTrue:[^ self halt: 'You must not make a weak class compact']. - cct _ Smalltalk compactClassesArray. - (self indexIfCompact > 0 or: [cct includes: self]) - ifTrue: [^ self halt: self name , 'is already compact']. - index _ cct indexOf: nil - ifAbsent: [^ self halt: 'compact class table is full']. - "Install this class in the compact class table" - cct at: index put: self. - "Update instspec so future instances will be compact" - format _ format + (index bitShift: 11). - "Make up new instances and become old ones into them" - self updateInstancesFrom: self. - "Purge any old instances" - Smalltalk garbageCollect.! - -Behavior removeSelector: #allUnreferencedInstanceVariables! - -!methodRemoval: Behavior #allUnreferencedInstanceVariables stamp: 'Install-4249-BehaviorHierarchyTypeErrorFixes-HernanWilkinson-JuanVuletich-2020Jun29-13h02m-jmv.001.cs.st 8/5/2020 22:21:34'! -allUnreferencedInstanceVariables - - "Return a list of the instance variables known to the receiver which are not referenced in the receiver or any of its subclasses OR superclasses" - - ^ self allInstVarNames reject: [ :instanceVariableName | | definingClass | - definingClass _ self classThatDefinesInstanceVariable: instanceVariableName. - definingClass isInstanceVariableNamedReferencedInHierarchy: instanceVariableName ]! - -Behavior removeSelector: #becomeCompactSimplyAt:! - -!methodRemoval: Behavior #becomeCompactSimplyAt: stamp: 'Install-4249-BehaviorHierarchyTypeErrorFixes-HernanWilkinson-JuanVuletich-2020Jun29-13h02m-jmv.001.cs.st 8/5/2020 22:21:34'! -becomeCompactSimplyAt: index - "Make me compact, but don't update the instances. For importing segments." -"Here are the restrictions on compact classes in order for export segments to work: A compact class index may not be reused. If a class was compact in a release of Squeak, no other class may use that index. The class might not be compact later, and there should be nil in its place in the array." - | cct | - - Smalltalk isSpur ifTrue: [^ self halt: 'No Compact Classes support in Spur']. - self isWeak ifTrue:[^ self halt: 'You must not make a weak class compact']. - cct _ Smalltalk compactClassesArray. - (self indexIfCompact > 0 or: [cct includes: self]) - ifTrue: [^ self halt: self name , 'is already compact']. - (cct at: index) ifNotNil: [^ self halt: 'compact table slot already in use']. - "Install this class in the compact class table" - cct at: index put: self. - "Update instspec so future instances will be compact" - format _ format + (index bitShift: 11). - "Caller must convert the instances" -! - -Behavior removeSelector: #changeRecordsAt:! - -!methodRemoval: Behavior #changeRecordsAt: stamp: 'Install-4249-BehaviorHierarchyTypeErrorFixes-HernanWilkinson-JuanVuletich-2020Jun29-13h02m-jmv.001.cs.st 8/5/2020 22:21:34'! -changeRecordsAt: selector - "Return a list of ChangeRecords for all versions of the method at selector. Source code can be retrieved by sending string to any one. Return nil if the method is absent." - - "(Pen changeRecordsAt: #go:) collect: [:cRec | cRec string]" - | aList | - aList _ VersionsBrowser new - scanVersionsOf: (self compiledMethodAt: selector ifAbsent: [^ nil]) - class: self meta: self isMeta - category: (self whichCategoryIncludesSelector: selector) - selector: selector. - ^ aList ifNotNil: [aList changeList]! - -Behavior removeSelector: #allSharedPools! - -!methodRemoval: Behavior #allSharedPools stamp: 'Install-4249-BehaviorHierarchyTypeErrorFixes-HernanWilkinson-JuanVuletich-2020Jun29-13h02m-jmv.001.cs.st 8/5/2020 22:21:34'! -allSharedPools - "Answer a Set of the names of the pools (Dictionaries or SharedPool subclasses) that the receiver and the receiver's ancestors share." - - ^superclass allSharedPools! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4249-BehaviorHierarchyTypeErrorFixes-HernanWilkinson-JuanVuletich-2020Jun29-13h02m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4249] on 1 July 2020 at 5:10:38 pm'! -!KeyboardEvent methodsFor: 'testing' stamp: 'db 7/1/2020 17:09:47'! - isQuestionMark - - ^ self keyCharacter = $? ! ! -!AutoCompleter methodsFor: 'keyboard' stamp: 'db 7/1/2020 17:09:47' prior: 50436217! - handleKeystrokeBefore: kbEvent - - "I return a boolean. true when I have handled the event and no futher processing is needed by the caller." - - | shouldOpenMorph | - - shouldOpenMorph _ self shouldOpenMorph. - - "Stuff to do if the menu is not open" - menuMorph ifNil: [ ^ self openCompletionMenuFor: kbEvent if: shouldOpenMorph ]. - - "Starting here, stuff to do if the menu is open" - menuMorph stillActive. - - kbEvent isEsc ifTrue: [ self closeMenu. ^ true]. - kbEvent isBackspace ifTrue: [ shouldOpenMorph ifFalse: [ self closeMenu ]. ^ false]. - kbEvent isHome ifTrue: [ menuMorph goHome. ^ true ]. - kbEvent isEnd ifTrue: [ menuMorph goToEnd. ^ true]. - kbEvent isQuestionMark ifTrue: [ menuMorph help. ^true]. - kbEvent isArrowUp ifTrue: [ menuMorph goUp. ^ true]. - kbEvent isArrowDown ifTrue: [ menuMorph goDown. ^ true]. - kbEvent isPageUp ifTrue: [ menuMorph goPageUp. ^ true]. - kbEvent isPageDown ifTrue: [ menuMorph goPageDown. ^ true]. - - self canShowSelectorDocumentation - ifTrue: [ - kbEvent isArrowRight ifTrue: [ menuMorph showSelectorDocumentation. ^ true ]. - kbEvent isArrowLeft ifTrue: [ menuMorph hideSelectorDocumentation. ^ true ]] - ifFalse: [ - "If it is showing identifiers I eat the right arrow key because the user is used to it when - showing selectors, so to avoid an unexpected behavior I do nothing with it -Hernan" - kbEvent isArrowRight ifTrue: [ ^ true ]]. - - (self shouldInsertSelected: kbEvent) ifTrue: [ self insertSelected ifTrue: [^ true]]. - (self shouldCloseMenu: kbEvent) ifTrue: [ self closeMenu ]. - - ^false! ! - -KeyboardEvent removeSelector: #isQuesitonMark! - -!methodRemoval: KeyboardEvent #isQuesitonMark stamp: 'Install-4250-fixTypoInSelector-DouglasBrebner-2020Jul01-17h08m-db.001.cs.st 8/5/2020 22:21:34'! -isQuesitonMark - - ^ self keyCharacter = $? ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4250-fixTypoInSelector-DouglasBrebner-2020Jul01-17h08m-db.001.cs.st----! - -'From Cuis 5.0 [latest update: #4249] on 1 July 2020 at 5:36:25 pm'! -!RunNotArray commentStamp: '' prior: 16901565! - A replacement for RunArray that does not optimize space. Essentially just an array, with a few idiosyncratic methods for compatibility with RunArray. - -Rationale: When styling Smalltalk text, runs are very short. Space saving is not significant. Maybe 90% of the time is spent building and coalescing RunArrays. So, don't save space. Save time!!! -!Editor commentStamp: '' prior: 16836270! - New text editors. -TextEditor provides most of the functionality that used to be in TextMorphEditor. -SmalltalkEditor has Smalltalk code specific features. -SimpleEditor provides basic functionality for single line text editing. It does not handle fonts and styles, aligning and Smalltalk utilities. It handles one single line.! -!TextAlignment commentStamp: '' prior: 16930019! - Warning: TextAlignment and ParagraphStyleReference (What is this referring to?) should always be applied to whole 'paragraphs' in the text. See #isParagraphAttribute - -( -(Text string: 'This text has no style set', String crString), -(Text string: 'This is centered', String crString attribute: TextAlignment centered), -(Text string: 'This text has no style set', String crString) -) edit! -!StringMorph commentStamp: '' prior: 16918124! - StringMorph is a "lightweight" Morph to display a String. It supports only a single font, color, and emphasis combination. For multiple text styles, use TextModelMorph. - -Structure: -instance var Type Description -font StrikeFont (normally nil; then the accessor #font gives back a Font or nil #defaultFont) -emphasis SmallInteger bitmask determining character attributes (underline, bold, italics, struckThrough) -contents String The text that will be displayed. -! -!TaskbarMorph commentStamp: '' prior: 50337082! - A simple task bar written for Cuis. - -dashBoard contains views/controls -viewBox contains graphic buttons of "iconized" windows/morphs. -scale allows 1x 2x 4x taskbar height. [scale= 1,2,4]! -!AutoCompleter commentStamp: '' prior: 16781109! - An InnerTextMorph can have an autocompleter in the same way it might have a styler. My instances implement autocompletion.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4251-fixTyposInComments-DouglasBrebner-2020Jul01-17h10m-db.001.cs.st----! - -'From Cuis 5.0 [latest update: #4249] on 5 July 2020 at 4:48:41 pm'! -!String methodsFor: 'grammar' stamp: 'LC 7/5/2020 16:47:58' prior: 50507930! - article - | article first letter second | - self isEmpty ifTrue: [^self]. - article := self first isVowel ifTrue: ['an'] ifFalse: ['a']. - first := self first asLowercase. - letter := self size = 1. - second := letter ifFalse: [self second asLowercase]. - (first = $f and: [letter orNot: ['aeiloru' includes: second]]) - ifTrue: [^'an']. - first = $u ifTrue: [ - (letter or: ['cks' includes: second]) ifTrue: [^'a']. - second = $n - ifTrue: [(self size = 2 or: [self third isVowel]) ifTrue: [^'a']]]. - (first = $e and: [second = $u]) ifTrue: [^'a']. - ^article! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4252-article-tweaks-LeandroCaniglia-2020Jul05-16h47m-LC.001.cs.st----! - -'From Cuis 5.0 [latest update: #4249] on 6 July 2020 at 10:16:58 am'! - -BorderedRectMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity originalPosition showUp itemsPerPage ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #AutoCompleterMorph category: #'Tools-Autocompletion' stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:21:34'! -BorderedRectMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity originalPosition showUp itemsPerPage' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -AutoCompleterMorph subclass: #SmalltalkCompleterMorph - instanceVariableNames: 'selectorDocumentation' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #SmalltalkCompleterMorph category: #'Tools-Autocompletion' stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:21:34'! -AutoCompleterMorph subclass: #SmalltalkCompleterMorph - instanceVariableNames: 'selectorDocumentation' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! -!SmalltalkCompleterMorph commentStamp: '' prior: 0! - Specific for Smalltalk code.! -!SmalltalkCompleterMorph methodsFor: 'selector documentation' stamp: 'jmv 7/6/2020 09:28:19' overrides: 50433654! - crPressedOnSelectorDocumentation - - self hideSelectorDocumentation. - self activeHand newKeyboardFocus: completer textMorph ! ! -!SmalltalkCompleterMorph methodsFor: 'selector documentation' stamp: 'jmv 7/6/2020 09:26:11' overrides: 50433661! - hideSelectorDocumentation - - selectorDocumentation ifNotNil: [ selectorDocumentation hide ]. - self stillActive ! ! -!SmalltalkCompleterMorph methodsFor: 'selector documentation' stamp: 'jmv 7/6/2020 09:26:19' overrides: 50433668! - initializeSelectorDocumentation - - selectorDocumentation := TextModelMorph withText: ''. - selectorDocumentation textMorph - acceptOnCR: false; - crAction: [ self crPressedOnSelectorDocumentation ]. - - selectorDocumentation - wrapFlag: true; - borderColor: Color black; - borderWidth: 1; - disableEditing; - openInWorld - ! ! -!SmalltalkCompleterMorph methodsFor: 'selector documentation' stamp: 'jmv 7/6/2020 09:26:24' overrides: 50433681! - isShowingSelectorDocumentation - - ^selectorDocumentation notNil and: [ selectorDocumentation visible ]! ! -!SmalltalkCompleterMorph methodsFor: 'selector documentation' stamp: 'jmv 7/6/2020 09:27:58' overrides: 50433688! - methodDocumentationSeparator - - ^ Text - string: String newLineString, '------------------------------------------------------------------------------------------------', String newLineString - attribute: TextColor black.! ! -!SmalltalkCompleterMorph methodsFor: 'selector documentation' stamp: 'jmv 7/6/2020 09:27:17' overrides: 50446776! - selectorDefaultDocumentationLocation - - | relativeSelected | - - relativeSelected := (self selected - self firstVisible) min: self itemsPerPage - 1 max: 0. - - ^location externalizePosition: extent x@(relativeSelected * self itemHeight + 1). - - ! ! -!SmalltalkCompleterMorph methodsFor: 'selector documentation' stamp: 'jmv 7/6/2020 09:26:58' overrides: 50433709! - selectorDocumentation - - selectorDocumentation ifNil: [ self initializeSelectorDocumentation ]. - ^selectorDocumentation ! ! -!SmalltalkCompleterMorph methodsFor: 'selector documentation' stamp: 'jmv 7/6/2020 09:27:08' overrides: 50436698! - selectorDocumentationExtent - - ^`600@250`! ! -!SmalltalkCompleterMorph methodsFor: 'selector documentation' stamp: 'jmv 7/6/2020 09:27:22' overrides: 50433721! - selectorDocumentationText - - | selectedEntry selectorsClasses | - - selectedEntry := completer selectedEntry. - (completer isCategoryEntry: selectedEntry) ifTrue: [ ^'' ]. - selectedEntry := selectedEntry asSymbol. - selectorsClasses := completer selectorsClasses. - - ^ selectorsClasses isEmpty - ifTrue: [ self selectorDocumentationTextForAllImplementorsOf: selectedEntry ] - ifFalse: [ self selectorDocumentationTextOf: selectedEntry forAll: selectorsClasses ]. - ! ! -!SmalltalkCompleterMorph methodsFor: 'selector documentation' stamp: 'jmv 7/6/2020 09:27:27' overrides: 50433739! -selectorDocumentationTextForAllI: aMethodsCollection - - | selectorDocumentationText implementors methodDocumentationSeparator | - - selectorDocumentationText := Text new. - methodDocumentationSeparator := self methodDocumentationSeparator. - implementors := aMethodsCollection asSortedCollection: [ :leftMethod :rightMethod | leftMethod methodClass classDepth < rightMethod methodClass classDepth ]. - - implementors - do: [ :implementor | selectorDocumentationText := selectorDocumentationText append: (completer documentationOf: implementor)] - separatedBy: [ selectorDocumentationText := selectorDocumentationText append: methodDocumentationSeparator ]. - - ^ selectorDocumentationText! ! -!SmalltalkCompleterMorph methodsFor: 'selector documentation' stamp: 'jmv 7/6/2020 09:27:34' overrides: 50433764! - selectorDocumentationTextForAllImplementorsOf: selectedEntry - - ^ self selectorDocumentationTextForAllI: (Smalltalk allImplementorsOf: selectedEntry). - - ! ! -!SmalltalkCompleterMorph methodsFor: 'selector documentation' stamp: 'jmv 7/6/2020 09:27:38' overrides: 50433772! - selectorDocumentationTextOf: selectedEntry forAll: selectorsClasses - - | methodsToShow | - - methodsToShow := selectorsClasses - inject: IdentitySet new - into: [ :methods :aClass | - (aClass lookupSelector: selectedEntry) ifNotNil: [ :method | methods add: method ]. - methods ]. - - ^self selectorDocumentationTextForAllI: methodsToShow ! ! -!SmalltalkCompleterMorph methodsFor: 'selector documentation' stamp: 'jmv 7/6/2020 09:27:44' overrides: 50433786! - showSelectorDocumentation - - | selectorDocumentationLocation selectorDocumentationExtent | - - selectorDocumentationLocation := self selectorDefaultDocumentationLocation. - selectorDocumentationExtent := self selectorDocumentationExtent. - selectorDocumentationLocation := self adjust: selectorDocumentationLocation ifOutOfScreenWith: selectorDocumentationExtent xOffset: extent x yOffset: self itemHeight negated. - - self setDefaultColors. - - self selectorDocumentation - model: (TextModel withText: self selectorDocumentationText); - morphPosition: selectorDocumentationLocation extent: selectorDocumentationExtent; - wrapFlag: false; - show. - - ! ! -!SmalltalkCompleterMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 7/6/2020 09:28:43' overrides: 50433810! - delete - - selectorDocumentation ifNotNil: [ - selectorDocumentation delete. - selectorDocumentation := nil ]. - - ^super delete ! ! -!SmalltalkCompleterMorph methodsFor: 'actions' stamp: 'jmv 7/6/2020 10:12:40' overrides: 50446688! - resetMenu - - self hideSelectorDocumentation. - super resetMenu! ! -!SmalltalkCompleterMorph methodsFor: 'accessing' stamp: 'jmv 7/6/2020 10:15:33' overrides: 50446677! - selected: aNumber - "Set the value of selected" - - ((aNumber between: 1 and: self entryCount) and: [ aNumber ~= selected ]) - ifTrue: [ - selected _ aNumber. - self isShowingSelectorDocumentation ifTrue: [ self showSelectorDocumentation ]]! ! -!SmalltalkCompleterMorph methodsFor: 'stepping' stamp: 'jmv 7/6/2020 10:16:05' overrides: 50434365! - stepAt: millisecondSinceLast - - self isShowingSelectorDocumentation ifTrue: [ ^self ]. - super stepAt: millisecondSinceLast! ! -!AutoCompleter methodsFor: 'menu morph' stamp: 'jmv 7/6/2020 09:23:02'! - morphClass - ^AutoCompleterMorph! ! -!AutoCompleter methodsFor: 'keyboard' stamp: 'jmv 7/6/2020 10:05:22'! - handleLeftArrowKeystrokeBefore: kbEvent - "Subclasses might do something" - ^true! ! -!AutoCompleter methodsFor: 'keyboard' stamp: 'jmv 7/6/2020 10:05:28'! - handleRightArrowKeystrokeBefore: kbEvent - "Subclasses might do something" - ^true! ! -!ClassNameCompleter methodsFor: 'menu morph' stamp: 'jmv 7/6/2020 09:23:38' overrides: 50528916! - morphClass - ^SmalltalkCompleterMorph! ! -!SmalltalkCompleter methodsFor: 'menu morph' stamp: 'jmv 7/6/2020 09:23:50' overrides: 50528916! - morphClass - ^SmalltalkCompleterMorph! ! -!SmalltalkCompleter methodsFor: 'keyboard' stamp: 'jmv 7/6/2020 10:06:22' overrides: 50528920! - handleLeftArrowKeystrokeBefore: kbEvent - canShowSelectorDocumentation ifTrue: [ - menuMorph hideSelectorDocumentation ]. - ^ true! ! -!SmalltalkCompleter methodsFor: 'keyboard' stamp: 'jmv 7/6/2020 10:06:11' overrides: 50528925! - handleRightArrowKeystrokeBefore: kbEvent - canShowSelectorDocumentation ifTrue: [ - menuMorph showSelectorDocumentation ]. - ^ true! ! -!AutoCompleterMorph methodsFor: 'accessing' stamp: 'jmv 7/6/2020 10:15:09' prior: 50446677! - selected: aNumber - "Set the value of selected" - - ((aNumber between: 1 and: self entryCount) and: [ aNumber ~= selected ]) - ifTrue: [ - selected _ aNumber ]! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'jmv 7/6/2020 10:12:50' prior: 50446688! - resetMenu - | width newExtent | - - self calculateItemsPerPage. - - self firstVisible: 1. - self selected: self firstSelectableEntryIndex. - - width _ self calculateWidth. - newExtent _ width + 4 @ (self itemsPerPage * self itemHeight + 2). - - self morphPosition: originalPosition extent: newExtent. - "redraw is needed even if position and extent haven't changed" - self redrawNeeded ! ! -!AutoCompleterMorph methodsFor: 'stepping' stamp: 'jmv 7/6/2020 10:16:14' prior: 50434365 overrides: 16876536! - stepAt: millisecondSinceLast - - self timeOfLastActivity > self timeout - ifTrue: [ self delete. completer menuClosed ] - ifFalse: [self updateColor]! ! -!AutoCompleterMorph class methodsFor: 'instance creation' stamp: 'jmv 7/6/2020 09:24:40' prior: 50385100 overrides: 16877229! - initializedInstance - | completer m | - completer _ SmalltalkCompleter withModel: (TextModel withText: 'Small'). - completer - instVarNamed: 'position' - put: 5. - completer computeEntries. - m _ completer morphClass - completer: completer - position: `200 @ 200`. - completer instVarNamed: 'menuMorph' put: m. - ^m! ! -!AutoCompleter methodsFor: 'menu morph' stamp: 'jmv 7/6/2020 09:24:31' prior: 50434389! - openCompletionMenu - - | theEditor | - - theEditor _ textMorph editor. - position _ theEditor startIndex - 1. - self closeMenu. - self computeEntries. - entries notEmpty - ifTrue: [ | startIndex characterBlock cursorIndex | - cursorIndex := theEditor pointIndex. - startIndex := (theEditor text at: cursorIndex-1) = Character space - ifTrue: [ cursorIndex ] - ifFalse: [ theEditor previousWordStart: (cursorIndex > theEditor text size ifTrue: [ cursorIndex-1 ] ifFalse: [ cursorIndex ])]. - characterBlock := theEditor characterBlockForIndex: startIndex. - menuMorph _ self morphClass - completer: self - position: characterBlock bottomLeft + textMorph morphPositionInWorld ]. -! ! -!AutoCompleter methodsFor: 'keyboard' stamp: 'jmv 7/6/2020 10:10:44' prior: 50528503! - handleKeystrokeBefore: kbEvent - "I return a boolean. true when I have handled the event and no futher processing is needed by the caller." - - | shouldOpenMorph | - shouldOpenMorph _ self shouldOpenMorph. - - "Stuff to do if the menu is not open" - menuMorph ifNil: [ ^ self openCompletionMenuFor: kbEvent if: shouldOpenMorph ]. - - "Starting here, stuff to do if the menu is open" - menuMorph stillActive. - - kbEvent isEsc ifTrue: [ self closeMenu. ^ true]. - kbEvent isBackspace ifTrue: [ shouldOpenMorph ifFalse: [ self closeMenu ]. ^ false]. - kbEvent isHome ifTrue: [ menuMorph goHome. ^ true ]. - kbEvent isEnd ifTrue: [ menuMorph goToEnd. ^ true]. - kbEvent isQuestionMark ifTrue: [ menuMorph help. ^true]. - kbEvent isArrowUp ifTrue: [ menuMorph goUp. ^ true]. - kbEvent isArrowDown ifTrue: [ menuMorph goDown. ^ true]. - kbEvent isPageUp ifTrue: [ menuMorph goPageUp. ^ true]. - kbEvent isPageDown ifTrue: [ menuMorph goPageDown. ^ true]. - - kbEvent isArrowRight ifTrue: [ ^self handleRightArrowKeystrokeBefore: kbEvent ]. - kbEvent isArrowLeft ifTrue: [ ^self handleLeftArrowKeystrokeBefore: kbEvent ]. - - (self shouldInsertSelected: kbEvent) ifTrue: [ self insertSelected ifTrue: [^ true]]. - (self shouldCloseMenu: kbEvent) ifTrue: [ self closeMenu ]. - - ^false! ! - -SmalltalkCompleter removeSelector: #handleKeystrokeBefore:! - -SmalltalkCompleter removeSelector: #canShowSelectorDocumentation! - -!methodRemoval: SmalltalkCompleter #canShowSelectorDocumentation stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:21:34'! -canShowSelectorDocumentation - - ^canShowSelectorDocumentation ! - -ClassNameCompleter removeSelector: #canShowSelectorDocumentation! - -!methodRemoval: ClassNameCompleter #canShowSelectorDocumentation stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:21:34'! -canShowSelectorDocumentation - - ^false! - -AutoCompleter removeSelector: #canShowSelectorDocumentation! - -!methodRemoval: AutoCompleter #canShowSelectorDocumentation stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:21:34'! -canShowSelectorDocumentation - - self subclassResponsibility! - -AutoCompleterMorph removeSelector: #isShowingSelectorDocumentation! - -!methodRemoval: AutoCompleterMorph #isShowingSelectorDocumentation stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:21:34'! -isShowingSelectorDocumentation - - ^selectorDocumentation notNil and: [ selectorDocumentation visible ]! - -AutoCompleterMorph removeSelector: #selectorDefaultDocumentationLocation! - -!methodRemoval: AutoCompleterMorph #selectorDefaultDocumentationLocation stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:21:34'! -selectorDefaultDocumentationLocation - - | relativeSelected | - - relativeSelected := (self selected - self firstVisible) min: self itemsPerPage - 1 max: 0. - - ^location externalizePosition: extent x@(relativeSelected * self itemHeight + 1). - - ! - -AutoCompleterMorph removeSelector: #methodDocumentationSeparator! - -!methodRemoval: AutoCompleterMorph #methodDocumentationSeparator stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:21:34'! -methodDocumentationSeparator - - ^ Text - string: String newLineString, '------------------------------------------------------------------------------------------------', String newLineString - attribute: TextColor black.! - -AutoCompleterMorph removeSelector: #initializeSelectorDocumentation! - -!methodRemoval: AutoCompleterMorph #initializeSelectorDocumentation stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:21:34'! -initializeSelectorDocumentation - - selectorDocumentation := TextModelMorph withText: ''. - selectorDocumentation textMorph - acceptOnCR: false; - crAction: [ self crPressedOnSelectorDocumentation ]. - - selectorDocumentation - wrapFlag: true; - borderColor: Color black; - borderWidth: 1; - disableEditing; - openInWorld - ! - -AutoCompleterMorph removeSelector: #selectorDocumentationExtent! - -!methodRemoval: AutoCompleterMorph #selectorDocumentationExtent stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:21:34'! -selectorDocumentationExtent - - ^`600@250`! - -AutoCompleterMorph removeSelector: #selectorDocumentationTextOf:forAll:! - -!methodRemoval: AutoCompleterMorph #selectorDocumentationTextOf:forAll: stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:21:34'! -selectorDocumentationTextOf: selectedEntry forAll: selectorsClasses - - | methodsToShow | - - methodsToShow := selectorsClasses - inject: IdentitySet new - into: [ :methods :aClass | - (aClass lookupSelector: selectedEntry) ifNotNil: [ :method | methods add: method ]. - methods ]. - - ^self selectorDocumentationTextForAllI: methodsToShow ! - -AutoCompleterMorph removeSelector: #showSelectorDocumentation! - -!methodRemoval: AutoCompleterMorph #showSelectorDocumentation stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:21:34'! -showSelectorDocumentation - - | selectorDocumentationLocation selectorDocumentationExtent | - - selectorDocumentationLocation := self selectorDefaultDocumentationLocation. - selectorDocumentationExtent := self selectorDocumentationExtent. - selectorDocumentationLocation := self adjust: selectorDocumentationLocation ifOutOfScreenWith: selectorDocumentationExtent xOffset: extent x yOffset: self itemHeight negated. - - self setDefaultColors. - - self selectorDocumentation - model: (TextModel withText: self selectorDocumentationText); - morphPosition: selectorDocumentationLocation extent: selectorDocumentationExtent; - wrapFlag: false; - show. - - ! - -AutoCompleterMorph removeSelector: #crPressedOnSelectorDocumentation! - -!methodRemoval: AutoCompleterMorph #crPressedOnSelectorDocumentation stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:21:34'! -crPressedOnSelectorDocumentation - - self hideSelectorDocumentation. - self activeHand newKeyboardFocus: completer textMorph ! - -AutoCompleterMorph removeSelector: #selectorDocumentation! - -!methodRemoval: AutoCompleterMorph #selectorDocumentation stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:21:34'! -selectorDocumentation - - selectorDocumentation ifNil: [ self initializeSelectorDocumentation ]. - ^selectorDocumentation ! - -AutoCompleterMorph removeSelector: #selectorDocumentationTextForAllI:! - -!methodRemoval: AutoCompleterMorph #selectorDocumentationTextForAllI: stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:21:34'! -selectorDocumentationTextForAllI: aMethodsCollection - - | selectorDocumentationText implementors methodDocumentationSeparator | - - selectorDocumentationText := Text new. - methodDocumentationSeparator := self methodDocumentationSeparator. - implementors := aMethodsCollection asSortedCollection: [ :leftMethod :rightMethod | leftMethod methodClass classDepth < rightMethod methodClass classDepth ]. - - implementors - do: [ :implementor | selectorDocumentationText := selectorDocumentationText append: (completer documentationOf: implementor)] - separatedBy: [ selectorDocumentationText := selectorDocumentationText append: methodDocumentationSeparator ]. - - ^ selectorDocumentationText! - -AutoCompleterMorph removeSelector: #selectorDocumentationTextForAllImplementorsOf:! - -!methodRemoval: AutoCompleterMorph #selectorDocumentationTextForAllImplementorsOf: stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:21:34'! -selectorDocumentationTextForAllImplementorsOf: selectedEntry - - ^ self selectorDocumentationTextForAllI: (Smalltalk allImplementorsOf: selectedEntry). - - ! - -AutoCompleterMorph removeSelector: #hideSelectorDocumentation! - -!methodRemoval: AutoCompleterMorph #hideSelectorDocumentation stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:21:34'! -hideSelectorDocumentation - - selectorDocumentation ifNotNil: [ selectorDocumentation hide ]. - self stillActive ! - -AutoCompleterMorph removeSelector: #selectorDocumentationText! - -!methodRemoval: AutoCompleterMorph #selectorDocumentationText stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:21:34'! -selectorDocumentationText - - | selectedEntry selectorsClasses | - - selectedEntry := completer selectedEntry. - (completer isCategoryEntry: selectedEntry) ifTrue: [ ^'' ]. - selectedEntry := selectedEntry asSymbol. - selectorsClasses := completer selectorsClasses. - - ^ selectorsClasses isEmpty - ifTrue: [ self selectorDocumentationTextForAllImplementorsOf: selectedEntry ] - ifFalse: [ self selectorDocumentationTextOf: selectedEntry forAll: selectorsClasses ]. - ! - -AutoCompleterMorph removeSelector: #delete! - -!methodRemoval: AutoCompleterMorph #delete stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:21:34'! -delete - - selectorDocumentation ifNotNil: [ - selectorDocumentation delete. - selectorDocumentation := nil ]. - - ^super delete ! - -BorderedRectMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity originalPosition showUp itemsPerPage' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #AutoCompleterMorph category: #'Tools-Autocompletion' stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:21:34'! -BorderedRectMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity originalPosition showUp itemsPerPage' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4253] on 12 July 2020 at 7:19:18 pm'! - -"Change Set: 4254-CuisCore-AuthorName-2020Jul12-15h05m -Date: 12 July 2020 -Author: Nahuel Garbezza - -Improvements on ExtractMethod and ExtractToTemporary refactorings: - -* update class comments and introduce new ones for some classes -* extract source code interval validations from the extract temporary class to a precondition class -* make hierarchy of source code preconditions for extract method and extract temporary -* fix a bug where argument names from the method signature can be extracted -* renamed ExtractMethodNewSelectorPrecondition to NewSelectorPrecondition because it does not have anything in particular for extract method"! -!RefactoringWarning commentStamp: '' prior: 0! - I represent a situation that needs user intervention, in the scope of refactorings. It can be resumed or not. For instance, trying to override an existing method.! -!ExtractMethod commentStamp: '' prior: 50497250! - I am a refactoring that extracts a selected piece of code to a separate method. The input is the following: - -* interval of code to extract (from index - to index) -* the CompiledMethod where this change applies -* the new method selector + argument names (instance of Message) -* the category name for the new method - -Many conditions have to be satisfied for this refactoring to be made, I delegate into SourceCodeOfMethodToBeExtractedPrecondition and NewSelectorPrecondition most of these checks. Refer to those classes' comments for more information.! -!ExtractToTemporary commentStamp: '' prior: 0! - I am a refactoring that extracts a selected piece of code to a temporary variable. The input is the following: - -* interval of code to extract (from index - to index) -* the CompiledMethod where this change applies -* the new temporary variable name - -Many conditions have to be satisfied for this refactoring to be made, I delegate into SourceCodeOfTemporaryToBeExtractedPrecondition and NewTemporaryPrecondition most of these checks. Refer to those classes' comments for more information.! -!NewInstanceVariablePrecondition commentStamp: '' prior: 0! - I am responsible for checking if a new instance variable can be introduced in a specific class. If that is not possible, I raise a refactoring error.! - -Smalltalk renameClassNamed: #ExtractMethodNewSelectorPrecondition as: #NewSelectorPrecondition! - -!classRenamed: #ExtractMethodNewSelectorPrecondition as: #NewSelectorPrecondition stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -Smalltalk renameClassNamed: #ExtractMethodNewSelectorPrecondition as: #NewSelectorPrecondition! -!NewSelectorPrecondition commentStamp: '' prior: 0! - I am responsible for checking if a new method with a given name can be introduced in a specific class. If that is not possible, I raise a refactoring error.! - -RefactoringPrecondition subclass: #SourceCodeIntervalPrecondition - instanceVariableNames: 'intervalToExtract method sourceCode methodNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #SourceCodeIntervalPrecondition category: #'Tools-Refactoring' stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -RefactoringPrecondition subclass: #SourceCodeIntervalPrecondition - instanceVariableNames: 'intervalToExtract method sourceCode methodNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!SourceCodeIntervalPrecondition commentStamp: '' prior: 0! - I am an abstract class that validates things that are required for source code intervals.! - -SourceCodeIntervalPrecondition subclass: #SourceCodeOfMethodToBeExtractedPrecondition - instanceVariableNames: 'initialNode finalNode initialNodeAncestors finalNodeAncestors ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #SourceCodeOfMethodToBeExtractedPrecondition category: #'Tools-Refactoring' stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -SourceCodeIntervalPrecondition subclass: #SourceCodeOfMethodToBeExtractedPrecondition - instanceVariableNames: 'initialNode finalNode initialNodeAncestors finalNodeAncestors' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!SourceCodeOfMethodToBeExtractedPrecondition commentStamp: '' prior: 50517128! - I check if a piece of source code selected for ExtractMethod can actually be extracted. - -Many conditions have to happen: -* we are selecting from the beginning of an AST node to an end of an AST node -* it is a smalltalk expression, a single statement or a sequence of complete statements -* the expression does not contain returns, or temporary variable assignments (if there is a temporary variable assignment, the declaration and all the usages should be extracted as well)! - -SourceCodeIntervalPrecondition subclass: #SourceCodeOfTemporaryToBeExtractedPrecondition - instanceVariableNames: 'sourceCodeToExtract parseNodeToExtract' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #SourceCodeOfTemporaryToBeExtractedPrecondition category: #'Tools-Refactoring' stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -SourceCodeIntervalPrecondition subclass: #SourceCodeOfTemporaryToBeExtractedPrecondition - instanceVariableNames: 'sourceCodeToExtract parseNodeToExtract' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!SourceCodeOfTemporaryToBeExtractedPrecondition commentStamp: '' prior: 0! - I check if a piece of source code selected for ExtractToTemporary can actually be extracted. - -Many conditions have to happen: -* we are selecting from the beginning of an AST node to an end of an AST node -* it is a complete smalltalk expression, a single statement or a sequence of complete statements -* the expression does not contain returns, nor assignments! -!SourceCodeIntervalPrecondition methodsFor: 'evaluating' stamp: 'RNG 7/12/2020 18:53:35' overrides: 50497302! - value - - self subclassResponsibility! ! -!SourceCodeIntervalPrecondition methodsFor: 'exceptions' stamp: 'RNG 7/12/2020 18:56:32'! - signalExtractingPartOfMethodSignatureError - - self refactoringError: self class errorMessageForExtractingPartOfMethodSignature! ! -!SourceCodeIntervalPrecondition methodsFor: 'exceptions' stamp: 'RNG 7/12/2020 18:56:36'! - signalExtractingTemporaryVariableDefinitionError - - self refactoringError: self class errorMessageForExtractingTemporaryVariablesDefinition! ! -!SourceCodeIntervalPrecondition methodsFor: 'exceptions' stamp: 'RNG 7/12/2020 18:57:12'! - signalSourceCodeContainsAnInvalidExpressionError - - self refactoringError: self class errorMessageForSourceCodeContainingInvalidExpression! ! -!SourceCodeIntervalPrecondition methodsFor: 'exceptions' stamp: 'RNG 7/12/2020 18:54:41'! - signalSourceCodeIncludesAReturnStatementError - - self refactoringError: self class errorMessageForSourceCodeIncludingAReturnStatement! ! -!SourceCodeIntervalPrecondition methodsFor: 'initialization' stamp: 'RNG 7/12/2020 19:02:30'! - initializeFor: anIntervalToExtract of: aMethodUnderValidation - - intervalToExtract := anIntervalToExtract. - method := aMethodUnderValidation. - methodNode := method methodNode. - sourceCode := method sourceCode.! ! -!SourceCodeIntervalPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 7/12/2020 18:54:20'! - assertSourceCodeDoesNotIncludeReturnExpressions - - self thereAreReturnExpressions - ifTrue: [ self signalSourceCodeIncludesAReturnStatementError ]! ! -!SourceCodeIntervalPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 7/12/2020 18:56:09'! - assertSourceCodeIsNotPartOfMethodSignature - - self intervalToExtractIncludesPartOfMethodSignature - ifTrue: [ self signalExtractingPartOfMethodSignatureError ]! ! -!SourceCodeIntervalPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 7/12/2020 18:56:16'! -assertSourceCodeIsNotPartOfTemporariesDeclaration - - self isNotInsideATempDeclaration - ifFalse: [ self signalExtractingTemporaryVariableDefinitionError ]! ! -!SourceCodeIntervalPrecondition methodsFor: 'private' stamp: 'RNG 7/12/2020 19:03:03'! - firstParseNodeOfMethodDefinition - - ^ methodNode hasTemporaryVariables - ifTrue: [ methodNode temporariesDeclaration ] - ifFalse: [ methodNode block statements first - ifNotNil: [ :statement | statement ] - ifNil: [ methodNode ] ]! ! -!SourceCodeIntervalPrecondition methodsFor: 'private' stamp: 'RNG 7/12/2020 19:03:15'! - intervalToExtractIncludesPartOfMethodSignature - - ^ intervalToExtract first < self methodDefinitionStartPosition! ! -!SourceCodeIntervalPrecondition methodsFor: 'private' stamp: 'RNG 7/12/2020 19:05:39'! - intervalToExtractIsIncludedInAnyOf: sourceRanges - - ^ sourceRanges anySatisfy: [ :sourceRange | - sourceRange first <= intervalToExtract first and: [ sourceRange last >= intervalToExtract last ] ]! ! -!SourceCodeIntervalPrecondition methodsFor: 'private' stamp: 'RNG 7/12/2020 19:03:37'! - isNotInsideATempDeclaration - - methodNode completeSourceRangesDo: [ :parseNode :sourceRanges | - (parseNode isTemporariesDeclaration - and: [ self intervalToExtractIsIncludedInAnyOf: sourceRanges ]) - ifTrue: [ ^ false ] ]. - ^ true! ! -!SourceCodeIntervalPrecondition methodsFor: 'private' stamp: 'RNG 7/12/2020 19:03:22'! - methodDefinitionStartPosition - - ^ methodNode - singleCompleteSourceRangeOf: self firstParseNodeOfMethodDefinition - ifPresent: [ :sourceRange | sourceRange first ] - ifAbsent: [ sourceCode size ]! ! -!SourceCodeIntervalPrecondition methodsFor: 'private' stamp: 'RNG 7/12/2020 19:03:28'! - thereAreReturnExpressions - - ^ (methodNode - allParseNodesWithin: intervalToExtract - satisfy: [ :parseNode | parseNode isReturn ]) not! ! -!SourceCodeIntervalPrecondition class methodsFor: 'instance creation' stamp: 'RNG 7/12/2020 19:07:02'! - for: anIntervalToExtract of: aMethod - - ^ self new initializeFor: anIntervalToExtract of: aMethod! ! -!SourceCodeIntervalPrecondition class methodsFor: 'evaluating' stamp: 'RNG 7/12/2020 19:07:07'! - valueFor: anIntervalToExtract of: aMethod - - ^ (self for: anIntervalToExtract of: aMethod) value! ! -!SourceCodeIntervalPrecondition class methodsFor: 'private - error messages' stamp: 'RNG 7/12/2020 19:07:39'! - refactoringErrorMessagePrefix - - self subclassResponsibility! ! -!SourceCodeIntervalPrecondition class methodsFor: 'error messages' stamp: 'RNG 7/12/2020 19:08:04'! - errorMessageForExtractingPartOfMethodSignature - - ^ self refactoringErrorMessagePrefix , 'it is not possible to extract part of method signature'! ! -!SourceCodeIntervalPrecondition class methodsFor: 'error messages' stamp: 'RNG 7/12/2020 19:08:09'! - errorMessageForExtractingTemporaryVariablesDefinition - - ^ self refactoringErrorMessagePrefix , 'it is not possible to extract temporary variable definitions'! ! -!SourceCodeIntervalPrecondition class methodsFor: 'error messages' stamp: 'RNG 7/12/2020 19:08:19'! - errorMessageForSourceCodeContainingInvalidExpression - - ^ self refactoringErrorMessagePrefix , 'the selected code contains an invalid expression'! ! -!SourceCodeIntervalPrecondition class methodsFor: 'error messages' stamp: 'RNG 7/12/2020 19:08:23'! - errorMessageForSourceCodeIncludingAReturnStatement - - ^ self refactoringErrorMessagePrefix , 'the selected code includes a return statement'! ! -!SourceCodeOfMethodToBeExtractedPrecondition class methodsFor: 'private - error messages' stamp: 'RNG 7/12/2020 15:57:25' overrides: 50529689! - refactoringErrorMessagePrefix - - ^ 'Cannot extract method: '! ! -!SourceCodeOfTemporaryToBeExtractedPrecondition methodsFor: 'evaluating' stamp: 'RNG 7/12/2020 16:52:51' overrides: 50529550! - value - - self - initializeParseNodeToExtract; - assertSourceCodeDoesNotIncludeReturnExpressions; - assertSourceCodeIsNotPartOfTemporariesDeclaration; - assertSourceCodeIsNotPartOfMethodSignature; - assertSourceCodeHasOneStatement; - assertSourceCodeIsACompleteExpression; - assertSourceCodeContainValidNodes! ! -!SourceCodeOfTemporaryToBeExtractedPrecondition methodsFor: 'exceptions' stamp: 'RNG 7/12/2020 17:04:38'! -signalCollaborationToExtractHasSyntaxError: aSyntaxErrorNotification - - self refactoringError: (self class errorMessageForSourceCodeToExtractHasSyntaxError: aSyntaxErrorNotification messageText)! ! -!SourceCodeOfTemporaryToBeExtractedPrecondition methodsFor: 'exceptions' stamp: 'RNG 7/12/2020 17:04:50'! - signalCollaborationToExtractHasToBeOneStatementError - - self refactoringError: self class errorMessageForSourceCodeToExtractHasToBeOneStatement! ! -!SourceCodeOfTemporaryToBeExtractedPrecondition methodsFor: 'initialization' stamp: 'RNG 7/12/2020 19:02:49' overrides: 50529586! - initializeFor: anIntervalToExtract of: aMethodUnderValidation - - super initializeFor: anIntervalToExtract of: aMethodUnderValidation. - sourceCodeToExtract := sourceCode copyFrom: intervalToExtract first to: intervalToExtract last! ! -!SourceCodeOfTemporaryToBeExtractedPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 7/12/2020 18:58:24'! - assertSourceCodeContainValidNodes - - self parseNodeUnderIntervalToExtractCanBeExtractedToAVariable - ifFalse: [ self signalSourceCodeContainsAnInvalidExpressionError ]! ! -!SourceCodeOfTemporaryToBeExtractedPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 7/12/2020 17:03:34'! - assertSourceCodeHasOneStatement - - parseNodeToExtract numberOfStatements ~= 1 - ifTrue: [ self signalCollaborationToExtractHasToBeOneStatementError ]! ! -!SourceCodeOfTemporaryToBeExtractedPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 7/12/2020 16:26:44'! - assertSourceCodeIsACompleteExpression - - self anySourceRangeMatchesExactlyTheIntervalToExtract - ifFalse: [ self signalSourceCodeContainsAnInvalidExpressionError ]! ! -!SourceCodeOfTemporaryToBeExtractedPrecondition methodsFor: 'private' stamp: 'RNG 7/12/2020 17:08:18'! - anySourceRangeMatchesExactlyTheIntervalToExtract - - | sourceRangeCollections allSourceRanges | - sourceRangeCollections := methodNode completeSourceRanges values. - allSourceRanges := sourceRangeCollections - inject: Set new - into: [ :sourceRanges :sourceRangeCollection | sourceRanges addAll: sourceRangeCollection; yourself ]. - ^ allSourceRanges anySatisfy: [ :sourceRange | - (sourceRange trimToMatchExpressionOn: sourceCode) = intervalToExtract ]! ! -!SourceCodeOfTemporaryToBeExtractedPrecondition methodsFor: 'private' stamp: 'RNG 7/12/2020 17:03:15'! - initializeParseNodeToExtract - - parseNodeToExtract := [ Parser parse: sourceCodeToExtract class: method methodClass noPattern: true ] - on: SyntaxErrorNotification - do: [ :anError | self signalCollaborationToExtractHasSyntaxError: anError ]! ! -!SourceCodeOfTemporaryToBeExtractedPrecondition methodsFor: 'private' stamp: 'RNG 7/12/2020 17:07:28'! - parseNodeUnderIntervalToExtractCanBeExtractedToAVariable - - methodNode completeSourceRangesDo: [ :parseNode :sourceRanges | - (parseNode isAssignmentNode - and: [ sourceRanges anySatisfy: [ :sourceRange | sourceRange first = intervalToExtract first ] ]) - ifTrue: [ ^ false ] - ]. - ^ true! ! -!SourceCodeOfTemporaryToBeExtractedPrecondition class methodsFor: 'error messages' stamp: 'RNG 7/12/2020 16:54:14'! - errorMessageForSourceCodeToExtractHasSyntaxError: anErrorDescription - - ^ 'Can not extract a source code with syntax error: ', anErrorDescription ! ! -!SourceCodeOfTemporaryToBeExtractedPrecondition class methodsFor: 'error messages' stamp: 'RNG 7/12/2020 16:19:18'! - errorMessageForSourceCodeToExtractHasToBeOneStatement - - ^ self refactoringErrorMessagePrefix , 'cannot extract more than one statement'! ! -!SourceCodeOfTemporaryToBeExtractedPrecondition class methodsFor: 'private - error messages' stamp: 'RNG 7/12/2020 15:58:44' overrides: 50529689! - refactoringErrorMessagePrefix - - ^ 'Cannot extract temporary: '! ! -!MethodNode methodsFor: 'testing' stamp: 'RNG 7/12/2020 16:57:24' prior: 50503001! - anyParseNodeWithin: aSourceCodeInterval satisfy: aCondition - - self completeSourceRangesDo: [ :parseNode :sourceRanges | - (aCondition value: parseNode) ifTrue: [ - (sourceRanges anySatisfy: [ :sourceRange | aSourceCodeInterval rangeIncludes: sourceRange first ]) - ifTrue: [ ^ true ] ] ]. - ^ false! ! -!ExtractMethod class methodsFor: 'private - pre-conditions' stamp: 'RNG 7/12/2020 19:13:15' prior: 50492007! - assert: aSelector canBeDefinedIn: aClass - - NewSelectorPrecondition valueFor: aSelector on: aClass! ! -!ExtractToTemporary class methodsFor: 'preconditions' stamp: 'RNG 7/12/2020 16:58:30' prior: 50512673! - assertCanApplyRefactoringOn: aMethodToRefactor at: anIntervalToExtract - - | trimmedSourceCodeToExtract sourceCodeToExtract trimmedIntervalToExtract originalSourceCode | - - self assert: anIntervalToExtract isValidIntervalOn: aMethodToRefactor. - originalSourceCode := aMethodToRefactor sourceCode. - sourceCodeToExtract := originalSourceCode copyFrom: anIntervalToExtract first to: anIntervalToExtract last. - trimmedSourceCodeToExtract := sourceCodeToExtract withBlanksTrimmed. - trimmedIntervalToExtract := anIntervalToExtract trimToMatchExpressionOn: originalSourceCode. - self assertSourceCodeIsNotEmpty: trimmedSourceCodeToExtract. - - SourceCodeOfTemporaryToBeExtractedPrecondition - valueFor: trimmedIntervalToExtract of: aMethodToRefactor! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'evaluating' stamp: 'RNG 7/12/2020 15:05:27' prior: 50517311 overrides: 50529550! - value - - self - initializeParseNodesMatchingSelectionInterval; - assertSourceCodeDoesNotIncludeReturnExpressions; - assertSourceCodeIsNotLeftSideOfAssignment; - assertSourceCodeIsNotPartOfTemporariesDeclaration; - assertSourceCodeIsNotPartOfMethodSignature; - assertSourceCodeDoesNotIncludeTemporaryAssignmentsWithoutDeclaration; - assertSourceCodeDoesNotHaveTemporaryVariablesUsedOutsideOfSelectionInterval; - assertSourceCodeContainsAValidExpression! ! -!SourceCodeOfMethodToBeExtractedPrecondition class methodsFor: 'error messages' stamp: 'RNG 7/12/2020 15:57:56' prior: 50517477! - errorMessageForExtractedTemporaryAssignmentWithoutItsDeclaration - - ^ self refactoringErrorMessagePrefix , 'an assignment is being extracted without its declaration'! ! -!SourceCodeOfMethodToBeExtractedPrecondition class methodsFor: 'error messages' stamp: 'RNG 7/12/2020 15:58:04' prior: 50517486! - errorMessageForExtractingLeftSideOfAssignment - - ^ self refactoringErrorMessagePrefix , 'it is not possible to extract the left side of an assignment'! ! -!SourceCodeOfMethodToBeExtractedPrecondition class methodsFor: 'error messages' stamp: 'RNG 7/12/2020 15:58:17' prior: 50517522! - errorMessageForTemporaryAssignmentWithUsagesOutsideOfSelectionInterval - - ^ self refactoringErrorMessagePrefix , 'there are temporary variables used outside of the code selection'! ! - -SourceCodeOfTemporaryToBeExtractedPrecondition class removeSelector: #errorMessageForExtractingPartOfMethodSignature! - -SourceCodeOfTemporaryToBeExtractedPrecondition class removeSelector: #errorMessageForExtractedTemporaryAssignmentWithoutItsDeclaration! - -SourceCodeOfTemporaryToBeExtractedPrecondition class removeSelector: #errorMessageForSourceCodeContainingInvalidExpression! - -SourceCodeOfTemporaryToBeExtractedPrecondition class removeSelector: #extractMethodErrorMessagePrefix! - -SourceCodeOfTemporaryToBeExtractedPrecondition class removeSelector: #errorMessageForExtractingTemporaryVariablesDefinition! - -SourceCodeOfTemporaryToBeExtractedPrecondition class removeSelector: #for:of:! - -SourceCodeOfTemporaryToBeExtractedPrecondition class removeSelector: #errorMessageForSourceCodeIncludingAReturnStatement! - -SourceCodeOfTemporaryToBeExtractedPrecondition class removeSelector: #errorMessageForSourceCodeToExtractCanNotIncludeReturn! - -SourceCodeOfTemporaryToBeExtractedPrecondition class removeSelector: #errorMessageForTemporaryAssignmentWithUsagesOutsideOfSelectionInterval! - -SourceCodeOfTemporaryToBeExtractedPrecondition class removeSelector: #errorMessageForExtractingLeftSideOfAssignment! - -SourceCodeOfTemporaryToBeExtractedPrecondition class removeSelector: #valueFor:of:! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #thereAreNoLocalVariableAssignmentsWithoutDeclaration! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #assertSourceCodeDoesNotIncludeReturnExpressions! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #assertSourceCodeIsNotLeftSideOfAssignment! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #assertSourceCodeDoesNotIncludeTemporaryAssignmentsWithoutDeclaration! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #intervalMatchesBeginningOfStatement! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #isLeftSideOfAssignment! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #signalSourceCodeContainsAnInvalidExpressionError! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #trimmed:! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #signalTemporaryAssignmentUsedOutsideOfSelectionIntervalError! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #intervalToExtractIsIncludedInAnyOf:! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #isNotInsideATempDeclaration! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #firstParseNodeOfMethodDefinition! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #intervalMatchesEndOfStatement! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #signalExtractingLeftSideOfAssignmentError! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #startAndEndNodesShareAParentNode! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #signalSourceCodeSelectionIncludesAnInvalidExpressionError! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #intervalToExtractIncludesPartOfMethodSignature! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #isNotATempDeclarationWithUsagesOutOfIntervalToExtract! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #assertSourceCodeIsNotPartOfTemporariesDeclaration! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #assertSourceCodeIsNotPartOfMethodSignature! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #parseNodesInCommon! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #assertSourceCodeDoesNotHaveTemporaryVariablesUsedOutsideOfSelectionInterval! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #signalColaborationToExtractHasToBeOneStatementError! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #findSourceRangeOfCloserStatementIn:! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #signalSourceCodeIncludesAReturnStatementError! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #signalTemporaryAssignmentWithoutDeclarationError! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #intervalCoversCompleteAstNodes! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #methodDefinitionStartPosition! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #signalExtractingPartOfMethodSignatureError! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #initializeParseNodesMatchingSelectionInterval! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #startAndEndParseNodesAreTheSame! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #signalExtractingTemporaryVariableDefinitionError! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #assertSourceCodeContainsAValidExpression! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #thereAreReturnExpressions! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #isNotDeclaredWithinIntervalToExtract:! - -SourceCodeOfMethodToBeExtractedPrecondition class removeSelector: #errorMessageForExtractingPartOfMethodSignature! - -SourceCodeOfMethodToBeExtractedPrecondition class removeSelector: #errorMessageForExtractingPartOfMethodDefinition! - -SourceCodeOfMethodToBeExtractedPrecondition class removeSelector: #extractMethodErrorMessagePrefix! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition class #extractMethodErrorMessagePrefix stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -extractMethodErrorMessagePrefix - - ^ 'Cannot extract method: '! - -SourceCodeOfMethodToBeExtractedPrecondition class removeSelector: #errorMessageForSourceCodeContainingInvalidExpression! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition class #errorMessageForSourceCodeContainingInvalidExpression stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -errorMessageForSourceCodeContainingInvalidExpression - - ^ self extractMethodErrorMessagePrefix , 'the selected code contains an invalid expression'! - -SourceCodeOfMethodToBeExtractedPrecondition class removeSelector: #errorMessageForExtractingTemporaryVariablesDefinition! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition class #errorMessageForExtractingTemporaryVariablesDefinition stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -errorMessageForExtractingTemporaryVariablesDefinition - - ^ self extractMethodErrorMessagePrefix , 'it is not possible to extract temporary variable definitions'! - -SourceCodeOfMethodToBeExtractedPrecondition class removeSelector: #for:of:! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition class #for:of: stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -for: anIntervalToExtract of: aMethod - - ^ self new initializeFor: anIntervalToExtract of: aMethod! - -SourceCodeOfMethodToBeExtractedPrecondition class removeSelector: #errorMessageForSourceCodeIncludingAReturnStatement! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition class #errorMessageForSourceCodeIncludingAReturnStatement stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -errorMessageForSourceCodeIncludingAReturnStatement - - ^ self extractMethodErrorMessagePrefix , 'the selected code includes a return statement'! - -SourceCodeOfMethodToBeExtractedPrecondition class removeSelector: #valueFor:of:! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition class #valueFor:of: stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -valueFor: anIntervalToExtract of: aMethod - - ^ (self for: anIntervalToExtract of: aMethod) value! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #initializeFor:of:! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition #initializeFor:of: stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -initializeFor: anIntervalToExtract of: aMethodUnderValidation - - intervalToExtract := anIntervalToExtract. - method := aMethodUnderValidation. - methodNode := method methodNode. - sourceCode := method sourceCode.! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #isNotInsideATempDeclaration! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition #isNotInsideATempDeclaration stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -isNotInsideATempDeclaration - - methodNode completeSourceRangesDo: [ :parseNode :sourceRanges | - (parseNode isTemporariesDeclaration - and: [ self intervalToExtractIsIncludedInAnyOf: sourceRanges ]) - ifTrue: [ ^ false ] ]. - ^ true! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #intervalToExtractIsIncludedInAnyOf:! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition #intervalToExtractIsIncludedInAnyOf: stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -intervalToExtractIsIncludedInAnyOf: sourceRanges - - ^ sourceRanges anySatisfy: [ :sourceRange | - sourceRange first <= intervalToExtract first and: [ sourceRange last >= intervalToExtract last ] ]! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #signalExtractingPartOfMethodSignatureError! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #assertSourceCodeDoesNotIncludeReturnExpressions! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition #assertSourceCodeDoesNotIncludeReturnExpressions stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -assertSourceCodeDoesNotIncludeReturnExpressions - - self thereAreReturnExpressions - ifTrue: [ self signalSourceCodeIncludesAReturnStatementError ]! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #signalExtractingTemporaryVariableDefinitionError! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition #signalExtractingTemporaryVariableDefinitionError stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -signalExtractingTemporaryVariableDefinitionError - - self refactoringError: self class errorMessageForExtractingTemporaryVariablesDefinition! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #assertSourceCodeIsNotPartOfTemporariesDeclaration! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition #assertSourceCodeIsNotPartOfTemporariesDeclaration stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -assertSourceCodeIsNotPartOfTemporariesDeclaration - - self isNotInsideATempDeclaration - ifFalse: [ self signalExtractingTemporaryVariableDefinitionError ]! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #assertSourceCodeIsNotPartOfMethodSignature! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #signalSourceCodeContainsAnInvalidExpressionError! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition #signalSourceCodeContainsAnInvalidExpressionError stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -signalSourceCodeContainsAnInvalidExpressionError - - self refactoringError: self class errorMessageForSourceCodeContainingInvalidExpression! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #thereAreReturnExpressions! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition #thereAreReturnExpressions stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -thereAreReturnExpressions - - ^ (methodNode - allParseNodesWithin: intervalToExtract - satisfy: [ :parseNode | parseNode isReturn ]) not! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #signalSourceCodeIncludesAReturnStatementError! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition #signalSourceCodeIncludesAReturnStatementError stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -signalSourceCodeIncludesAReturnStatementError - - self refactoringError: self class errorMessageForSourceCodeIncludingAReturnStatement! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #intervalToExtractIncludesPartOfMethodSignature! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #methodDefinitionStartPosition! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #firstParseNodeOfMethodDefinition! - -ExtractToTemporary class removeSelector: #assert:enclosesAValidNodeOn:! - -!methodRemoval: ExtractToTemporary class #assert:enclosesAValidNodeOn: stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -assert: anIntervalToExtract enclosesAValidNodeOn: aMethodToRefactor - - (self parseNodeUnder: anIntervalToExtract canBeExtractedToAVariableOn: aMethodToRefactor) - ifFalse: [ self signalSourceCodeSelectionIncludesAnInvalidExpression ]! - -ExtractToTemporary class removeSelector: #parseNodeUnder:canBeExtractedToAVariableOn:! - -!methodRemoval: ExtractToTemporary class #parseNodeUnder:canBeExtractedToAVariableOn: stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -parseNodeUnder: anIntervalToExtract canBeExtractedToAVariableOn: aMethodToRefactor - - aMethodToRefactor methodNode completeSourceRangesDo: [ :parseNode :sourceRanges | - (parseNode isAssignmentNode - and: [ sourceRanges anySatisfy: [ :sourceRange | sourceRange first = anIntervalToExtract first ] ]) - ifTrue: [ ^ false ] - ]. - ^ true! - -ExtractToTemporary class removeSelector: #signalSourceCodeSelectionIncludesAnInvalidExpression! - -!methodRemoval: ExtractToTemporary class #signalSourceCodeSelectionIncludesAnInvalidExpression stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -signalSourceCodeSelectionIncludesAnInvalidExpression - - self refactoringError: self errorMessageForSourceCodeIncludingAnInvalidExpression! - -ExtractToTemporary class removeSelector: #signalColaborationToExtractHasSyntaxError:! - -!methodRemoval: ExtractToTemporary class #signalColaborationToExtractHasSyntaxError: stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -signalColaborationToExtractHasSyntaxError: aSyntaxErrorNotification - - self refactoringError: (self errorMessageForSourceCodeToExtractHasSyntaxError: aSyntaxErrorNotification messageText)! - -ExtractToTemporary class removeSelector: #anySourceRangeOf:matches:! - -!methodRemoval: ExtractToTemporary class #anySourceRangeOf:matches: stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -anySourceRangeOf: aMethodToRefactor matches: anIntervalToExtract - - | sourceRangeCollections allSourceRanges sourceCode | - sourceRangeCollections := aMethodToRefactor methodNode completeSourceRanges values. - allSourceRanges := sourceRangeCollections - inject: Set new - into: [ :sourceRanges :sourceRangeCollection | sourceRanges addAll: sourceRangeCollection; yourself ]. - sourceCode := aMethodToRefactor sourceCode. - ^ allSourceRanges anySatisfy: [ :sourceRange | - (sourceRange trimToMatchExpressionOn: sourceCode) = anIntervalToExtract ]! - -ExtractToTemporary class removeSelector: #signalSourceCodeToExtractCanNotIncludeReturn! - -!methodRemoval: ExtractToTemporary class #signalSourceCodeToExtractCanNotIncludeReturn stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -signalSourceCodeToExtractCanNotIncludeReturn - - self refactoringError: self errorMessageForSourceCodeToExtractCanNotIncludeReturn ! - -ExtractToTemporary class removeSelector: #errorMessageForSourceCodeIncludingAnInvalidExpression! - -!methodRemoval: ExtractToTemporary class #errorMessageForSourceCodeIncludingAnInvalidExpression stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -errorMessageForSourceCodeIncludingAnInvalidExpression - - ^ 'The source code selection contains an invalid expression'! - -ExtractToTemporary class removeSelector: #signalColaborationToExtractHasToBeOneStatement! - -!methodRemoval: ExtractToTemporary class #signalColaborationToExtractHasToBeOneStatement stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -signalColaborationToExtractHasToBeOneStatement - - self refactoringError: self errorMessageForSourceCodeToExtractHasToBeOneStatement ! - -ExtractToTemporary class removeSelector: #assertHasOneStatement:! - -!methodRemoval: ExtractToTemporary class #assertHasOneStatement: stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -assertHasOneStatement: aMethodNodeToExtract - - aMethodNodeToExtract numberOfStatements ~= 1 - ifTrue: [ self signalColaborationToExtractHasToBeOneStatement ]! - -ExtractToTemporary class removeSelector: #assert:enclosesACompleteExpressionOn:! - -!methodRemoval: ExtractToTemporary class #assert:enclosesACompleteExpressionOn: stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -assert: anIntervalToExtract enclosesACompleteExpressionOn: aMethodToRefactor - - (self anySourceRangeOf: aMethodToRefactor matches: anIntervalToExtract) - ifFalse: [ self signalSourceCodeSelectionIncludesAnInvalidExpression ]! - -ExtractToTemporary class removeSelector: #assertIsNotReturn:! - -!methodRemoval: ExtractToTemporary class #assertIsNotReturn: stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -assertIsNotReturn: aSourceCodeToExtract - - "I have to use the source code to check this because parsing it returns the same methodNode for - 1 and ^1, that is, using methodNode does not help to distinguish if there was or not a return - Hernan" - - aSourceCodeToExtract withBlanksTrimmed first = $^ - ifTrue: [ self signalSourceCodeToExtractCanNotIncludeReturn ]! - -ExtractToTemporary class removeSelector: #errorMessageForSourceCodeToExtractHasSyntaxError:! - -!methodRemoval: ExtractToTemporary class #errorMessageForSourceCodeToExtractHasSyntaxError: stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -errorMessageForSourceCodeToExtractHasSyntaxError: anErrorDescription - - ^ 'Can not extract a source code with syntax error: ', anErrorDescription ! - -ExtractToTemporary class removeSelector: #tryToParse:on:! - -!methodRemoval: ExtractToTemporary class #tryToParse:on: stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -tryToParse: aSourceCode on: aClassToRefactor - - ^ [ Parser parse: aSourceCode class: aClassToRefactor noPattern: true ] - on: SyntaxErrorNotification - do: [ :anError | self signalColaborationToExtractHasSyntaxError: anError ]! - -ExtractToTemporary class removeSelector: #errorMessageForSourceCodeToExtractCanNotIncludeReturn! - -!methodRemoval: ExtractToTemporary class #errorMessageForSourceCodeToExtractCanNotIncludeReturn stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -errorMessageForSourceCodeToExtractCanNotIncludeReturn - - ^ 'An expression containing a return can not be extracted'! - -ExtractToTemporary class removeSelector: #errorMessageForSourceCodeToExtractHasToBeOneStatement! - -!methodRemoval: ExtractToTemporary class #errorMessageForSourceCodeToExtractHasToBeOneStatement stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -errorMessageForSourceCodeToExtractHasToBeOneStatement - - ^ 'Can not extract more than one statement'! - -SourceCodeIntervalPrecondition subclass: #SourceCodeOfMethodToBeExtractedPrecondition - instanceVariableNames: 'initialNode finalNode initialNodeAncestors finalNodeAncestors' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #SourceCodeOfMethodToBeExtractedPrecondition category: #'Tools-Refactoring' stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:21:34'! -SourceCodeIntervalPrecondition subclass: #SourceCodeOfMethodToBeExtractedPrecondition - instanceVariableNames: 'initialNode finalNode initialNodeAncestors finalNodeAncestors' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4253] on 27 July 2020 at 6:40:16 pm'! -!ClassNameCompleter methodsFor: 'testing' stamp: 'HAW 2/21/2019 16:01:01'! - canShowSelectorDocumentation - - ^false! ! -!SmalltalkCompleter methodsFor: 'testing' stamp: 'HAW 2/21/2019 16:06:32'! - canShowSelectorDocumentation - - ^canShowSelectorDocumentation ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4255-SmalltalkCompleterFixes-HernanWilkinson-2020Jul27-18h39m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4255] on 28 July 2020 at 5:12:12 pm'! -!Browser methodsFor: 'shout styling' stamp: 'KLG 7/27/2020 19:00:02' prior: 50368830 overrides: 50368821! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text. - Set the classOrMetaClass in anSHTextStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - | type | - - self isModeStyleable ifFalse: [^false]. - type _ self editSelection. - (#(newMessage editMessage editClass newClass) includes: type) ifFalse:[^false]. - anSHTextStyler classOrMetaClass: ((#(editClass newClass) includes: type) ifFalse:[ - self selectedClassOrMetaClass]). - ^true! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4256-NewClassTemplate-styleFix-GeraldKlix-2020Jul28-17h11m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4253] on 10 July 2020 at 11:15:42 pm'! -!RectangleLikeMorph methodsFor: 'drawing' stamp: 'jmv 7/10/2020 17:19:27' overrides: 16874275! - addPossiblyUncoveredAreasIn: aRectangle to: aCollection - "Answer an array of rectangles encompassing those areas in aRectangle not completely - covered by self. - All areas that might possibly be uncovered must be included." - (self isOrthoRectangularMorph and: [ self isOpaqueMorph ]) ifTrue: [ - aRectangle areasOutside: self morphBoundsInWorld do: [ :r | aCollection add: r ]. - ^self ]. - aCollection add: aRectangle! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/10/2020 20:01:06'! - drawCurrentAndSubmorphs - - self isCurrentMorphVisible - ifTrue: [ - currentMorph drawOn: self. - - "Display submorphs back to front" - "coordinate system stack already set up for aMorph - ('ivars transformations' and 'currentTransformation')" - currentMorph hasSubmorphs ifTrue: [ - currentMorph clippedSubmorph ifNotNil: [ :clipped | - self clippingByCurrentMorphDo: [ self fullDraw: clipped ]]. - currentMorph unclippedSubmorphsReverseDo: [ :m | - self fullDraw: m ]. - ]].! ! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 7/9/2020 16:17:45'! - canvasToUse - - ^self.! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 7/10/2020 17:20:04' prior: 16874275! - addPossiblyUncoveredAreasIn: aRectangle to: aCollection - "Answer an array of rectangles encompassing those areas in aRectangle not completely - covered by self. - All areas that might possibly be uncovered must be included." - aCollection add: aRectangle! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/9/2020 18:35:09' prior: 50506222! - fullDraw: aMorph - "Draw the full Morphic structure on us" - - "We are already set with a proper transformation from aMorph owner's coordinates to those of our target form." - - self flag: #jmvVer3. - aMorph visible ifFalse: [^ self]. - self into: aMorph. - - currentMorph layoutSubmorphsIfNeeded. - - currentMorph isKnownFailing ifTrue: [ - self drawCurrentAsError. - self outOfMorph. - ^ self]. - - (currentMorph isOwnedByHand and: [ Preferences cheapWindowReframe ]) ifTrue: [ - self drawCurrentAsOutline. - self outOfMorph. - ^ self]. - - "Draw current Morph and submorphs" - self canvasToUse drawCurrentAndSubmorphs. - - self outOfMorph! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4257-MorphicRefactor-JuanVuletich-2020Jul10-23h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4255] on 10 July 2020 at 11:56:14 pm'! -!TextModelMorph methodsFor: 'drawing' stamp: 'jmv 7/10/2020 23:52:27' prior: 50506164 overrides: 16790395! - drawOn: aCanvas - "Include a thin red inset border for unaccepted edits, or, if the unaccepted edits are known to conflict with a change made somewhere else to the same method (typically), put a thick red frame" - | bw bc | - self flag: #todo. - "Integrate this method with the Theme system. --cbr" - super drawOn: aCanvas. - bw _ Preferences focusIndicatorWidth. - bc _ nil. - self wantsFrameAdornments ifTrue: [ - model refusesToAccept - ifTrue: [ "Put up feedback showing that code cannot be submitted in this state" - bc _ Color tan ] - ifFalse: [ - self textMorph hasEditingConflicts - ifTrue: [ - bw _ 3. - bc _ Color red ] - ifFalse: [ - self textMorph hasUnacceptedEdits ifTrue: [ bc _ Color red ]]]]. - (drawKeyboardFocusIndicator and: [ self textMorph hasKeyboardFocus ]) - ifTrue: [ bc ifNil: [ bc _ Theme current focusIndicator ]] - ifFalse: [ - bc ifNotNil: [ - bc _ bc - alphaMixed: 0.4 - with: Color white ]]. - bc ifNotNil: [ - aCanvas - frameRectangle: self focusIndicatorRectangle - borderWidth: bw - color: bc ].! ! -!InnerTextMorph methodsFor: 'drawing' stamp: 'jmv 7/10/2020 23:54:05' prior: 50503673 overrides: 16899205! - drawOn: aCanvas - "Draw the receiver on a canvas" - - false ifTrue: [ self debugDrawLineRectsOn: aCanvas ]. "show line rects for debugging" - - aCanvas - textComposition: self textComposition - bounds: self morphLocalBounds - color: color - selectionColor: (Theme current textHighlightFocused: self hasKeyboardFocus). - - model actualContents isEmpty ifTrue: [ - owner - valueOfProperty: #emptyTextDisplayMessage - ifPresentDo: [ :msg | - aCanvas - drawString: msg - at: self morphTopLeft - font: nil - color: Theme current textEmptyDisplayMessage ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4258-EmptyTextMessageReimplementation-JuanVuletich-2020Jul10-23h52m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4257] on 11 July 2020 at 8:56:41 pm'! -!MenuMorph methodsFor: 'control' stamp: 'jmv 7/11/2020 17:57:50' prior: 50384889! - popUpAdjacentTo: rightOrLeftPointInWorld from: sourceItem - "Present this menu at the given point under control of the given hand. - Used mostly for submenus." - - | delta tryToPlace selectedOffset | - popUpOwner _ sourceItem. - selectedOffset _ (selectedItem ifNil: [ self items first ]) morphPosition. - sourceItem world addMorphFront: self. - - tryToPlace _ [ :where :mustFit | - self morphPosition: where - selectedOffset. - delta _ self morphBoundsInWorld - amountToTranslateWithin: sourceItem world morphBoundsInWorld. - (delta x = 0 | mustFit) ifTrue: [ - delta = `0@0` ifFalse: [ self morphPosition: self morphPosition + delta ]. - ^ self]]. - tryToPlace - value: rightOrLeftPointInWorld first value: false; - value: rightOrLeftPointInWorld last - (extent x @ 0) value: false; - value: rightOrLeftPointInWorld first value: true! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4259-tweak-JuanVuletich-2020Jul11-20h55m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4260] on 12 July 2020 at 12:18:16 pm'! -!Morph methodsFor: 'private' stamp: 'jmv 7/11/2020 21:57:34'! - privateMoveBackMorph: aMorph - - | oldIndex myWorld index | - myWorld _ self world. - "aMorph's position changes within in the submorph chain" - "moving aMorph to front" - oldIndex _ submorphs indexOf: aMorph. - "moving aMorph to back" - index _ submorphs size. - submorphs replaceFrom: oldIndex to: index-1 with: submorphs startingAt: oldIndex+1. - submorphs at: index put: aMorph. - myWorld ifNotNil: [aMorph redrawNeeded]. - self someSubmorphPositionOrExtentChanged.! ! -!Morph methodsFor: 'private' stamp: 'jmv 7/11/2020 21:58:44'! - privateMoveFrontMorph: aMorph - - | oldIndex myWorld | - myWorld _ self world. - "aMorph's position changes within in the submorph chain" - "moving aMorph to front" - oldIndex _ submorphs indexOf: aMorph. - oldIndex-1 to: 1 by: -1 do: [ :i | - submorphs at: i+1 put: (submorphs at: i)]. - submorphs at: 1 put: aMorph. - myWorld ifNotNil: [aMorph redrawNeeded]. - self someSubmorphPositionOrExtentChanged.! ! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'jmv 7/11/2020 21:58:57' prior: 50431931! - comeToFront - - self atFront ifFalse: [owner privateMoveFrontMorph: self]! ! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'jmv 7/11/2020 21:58:00' prior: 16876912! - goBehind - - owner privateMoveFrontMorph: self. -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4260-MorphicRefactor-JuanVuletich-2020Jul12-12h18m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4263] on 12 July 2020 at 8:59:50 pm'! -!HaloMorph methodsFor: 'event handling' stamp: 'jmv 7/12/2020 20:59:04' overrides: 16877018! - redrawNeeded - "Report that the area occupied by this morph should be redrawn." - - self - invalidateDisplayRect: - ((self morphBoundsInWorld - outsetBy: self class handleSize*2) - extendBy: 0@(FontFamily defaultLineSpacing+self class handleSize)) - from: nil.! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/12/2020 20:54:19' prior: 50385579! - basicBox - | aBox minSide anExtent w | - minSide _ 4 * self class handleSize. - anExtent _ extent + (self class handleSize*2) max: minSide@minSide. - aBox _ Rectangle center: self morphBoundsInWorld center extent: anExtent. - w _ self world ifNil: [ target world ]. - ^ w - ifNil: - [ aBox ] - ifNotNil: - [ aBox intersect: (w viewBox insetBy: `8@8`) ]! ! -!HaloMorph methodsFor: 'stepping' stamp: 'jmv 7/12/2020 18:55:39' prior: 50521106 overrides: 16876533! - step - (target isNil or: [target isInWorld not]) ifTrue: [self delete]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4261-HaloFixes-JuanVuletich-2020Jul12-20h40m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4258] on 17 July 2020 at 5:15:13 pm'! -!Morph methodsFor: 'events-processing' stamp: 'jmv 7/13/2020 16:20:20' prior: 16875151! -rejectsEvent: aMorphicEvent - "Return true to reject the given event. Submorphs might still handle it." - - ^ false! ! -!Morph methodsFor: 'events-processing' stamp: 'jmv 7/13/2020 16:07:54'! - rejectsEventFully: aMorphicEvent - "Return true to reject the given event, for thereceiver and all submorphs." - - ^ self isLocked or: [ self visible not ]! ! -!HaloMorph methodsFor: 'events-processing' stamp: 'jmv 7/13/2020 16:20:15' prior: 16850703 overrides: 50530921! - rejectsEvent: aMorphicEvent - "Return true to reject the given event. Submorphs might still handle it." - - "Only mouseButton3 events are handled by the halo itself" - (aMorphicEvent isMouse and: [ - aMorphicEvent isMouseDown and: [ aMorphicEvent mouseButton3Pressed ]]) - ifTrue: [ - ^ false ]. - ^true! ! -!HaloMorph methodsFor: 'events-processing' stamp: 'jmv 7/13/2020 16:08:07' overrides: 50530927! - rejectsEventFully: anEvent - "Return true to reject the given event, for thereceiver and all submorphs." - - (super rejectsEventFully: anEvent) ifTrue: [^true]. - anEvent isDropEvent ifTrue: [^true]. "never attempt to drop on halos" - ^false! ! -!Morph methodsFor: 'events-processing' stamp: 'jmv 7/13/2020 16:08:20' prior: 16874850! - dispatchEvent: aMorphicEvent localPosition: localPosition - "This is the central entry for dispatching events in morphic. Given some event, find the right receiver and let him handle it. - localPosition is in our coordinates." - - ^ (self rejectsEventFully: aMorphicEvent) - ifTrue: [ #rejected ] - ifFalse: [ aMorphicEvent dispatchWith: self localPosition: localPosition ]! ! -!Morph methodsFor: 'events-processing' stamp: 'jmv 7/13/2020 16:22:57' prior: 50365534! - processMouseOver: aMouseEvent localPosition: localEventPosition - "System level event handling." - self hasMouseFocus ifTrue: [ - "Got this directly through #handleFocusEvent: so check explicitly" - ((self rejectsEvent: aMouseEvent) not and: [self fullContainsPoint: localEventPosition]) ifFalse: [ - ^self ]]. - aMouseEvent hand noticeMouseOver: self event: aMouseEvent. - "Open question: should any unhandled mouse move events be filtered out? (i.e. should mouseHover:localPosition: be called when a mouse button is pressed but the morph doesn't have mouse button handlers? Essentially, what are the limits of what is considered 'hovering'?" - (self handlesMouseHover and: [aMouseEvent wasHandled not]) ifTrue: [ - self - mouseHover: aMouseEvent - localPosition: localEventPosition ].! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/13/2020 12:06:02' prior: 16875588! - fullContainsPoint: aLocalPoint - - "If not visible, won't contain any point at all." - self visible ifFalse: [ ^false ]. - - (self morphContainsPoint: aLocalPoint) ifTrue: [ ^ true ]. "quick acceptance" - self submorphsDrawingOutsideReverseDo: [ :m | - (m fullContainsPoint: (m internalize: aLocalPoint)) ifTrue: [ ^ true ]]. - ^ false! ! -!MorphicEvent methodsFor: 'dispatching' stamp: 'jmv 7/13/2020 16:23:09' prior: 16877793! - dispatchWith: aMorph localPosition: positionInAMorph - "Dispatch me. The event will be passed to the front-most visible submorph that contains the position wrt. to the event." - | handledByInner eventPositionInChild | - - "Try to get out quickly" - (aMorph fullContainsPoint: positionInAMorph) - ifFalse: [ ^#rejected ]. - - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - - "Check for being inside the receiver" - (handledByInner or: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsPoint: positionInAMorph] ]) - ifTrue: [ ^ self sentTo: aMorph localPosition: positionInAMorph ]. - - ^ #rejected! ! -!DropEvent methodsFor: 'dispatching' stamp: 'jmv 7/13/2020 16:21:40' prior: 16835677 overrides: 50531017! - dispatchWith: aMorph localPosition: positionInAMorph - "Drop is done on the innermost target that accepts it." - | eventPositionInChild dropped | - - "Try to get out quickly" - (aMorph fullContainsPoint: positionInAMorph) - ifFalse: [ ^#rejected ]. - - "Go looking if any of our submorphs wants it" - aMorph submorphsDo: [ :eachChild | - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ - ^self ]]. - - (aMorph allowsMorphDrop and: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsPoint: positionInAMorph] ]) - ifTrue: [ - "Do a symmetric check if both morphs like each other" - dropped _ self contents. - ((aMorph wantsDroppedMorph: dropped event: self) "I want her" - and: [dropped wantsToBeDroppedInto: aMorph]) "she wants me" - ifTrue: [ - ^ self sentTo: aMorph localPosition: positionInAMorph ]]. - ^#rejected! ! -!DropFilesEvent methodsFor: 'dispatching' stamp: 'jmv 7/13/2020 16:22:06' prior: 50424942 overrides: 50531017! - dispatchWith: aMorph localPosition: positionInAMorph - "Drop is done on the innermost target that accepts it." - - | eventPositionInChild | - - "Try to get out quickly" - (aMorph fullContainsPoint: positionInAMorph) ifFalse: [ ^#rejected ]. - - "Go looking if any of our submorphs wants it" - aMorph submorphsDo: [ :eachChild | - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ ^self ]]. - - (aMorph allowsFilesDrop and: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsPoint: positionInAMorph] ]) - ifTrue: [^ self sentTo: aMorph localPosition: positionInAMorph ]. - - ^#rejected! ! -!MouseButtonEvent methodsFor: 'dispatching' stamp: 'jmv 7/13/2020 16:23:25' prior: 16878696 overrides: 50531017! - dispatchWith: aMorph localPosition: positionInAMorph - "Find the appropriate receiver for the event and let it handle it. Default rules: - * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. - * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. - * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. - * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. - " - | aMorphHandlesIt grabAMorph handledByInner eventPositionInChild | - "Only for MouseDown" - self isMouseDown ifFalse: [ - ^super dispatchWith: aMorph localPosition: positionInAMorph ]. - - "Try to get out quickly" - (aMorph fullContainsPoint: positionInAMorph) - ifFalse: [ ^#rejected ]. - - "Install the prospective handler for the receiver" - aMorphHandlesIt _ false. - grabAMorph _ false. - self mouseButton3Pressed - ifTrue: [ - (eventHandler isNil or: [ eventHandler isWorldMorph or: [ - self shiftPressed or: [ aMorph is: #HaloMorph ]]]) - ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]] - ifFalse: [ - (aMorph handlesMouseDown: self) ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]. - "If button 1, and both aMorph and the owner allows grabbing with the hand (to initiate drag & drop), so be it." - self mouseButton1Pressed ifTrue: [ - aMorph owner ifNotNil: [ :o | - (o allowsSubmorphDrag and: [ aMorph isSticky not ]) ifTrue: [ - grabAMorph _ true ]]]]. - - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - - (handledByInner or: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsPoint: positionInAMorph] ]) ifTrue: [ - "aMorph is in the top-most unlocked, visible morph in the chain." - aMorphHandlesIt - ifTrue: [ ^self sentTo: aMorph localPosition: positionInAMorph ] - ifFalse: [ - (grabAMorph and: [ handledByInner not ]) ifTrue: [ - self hand - waitForClicksOrDrag: aMorph event: self - dragSel: (Preferences clickGrabsMorphs ifFalse: [#dragEvent:localPosition:]) - clkSel: (Preferences clickGrabsMorphs ifTrue: [#dragEvent:localPosition:]). - "false ifTrue: [ self hand grabMorph: aMorph ]." - Preferences clickGrabsMorphs ifFalse: [aMorph activateWindow]. - self wasHandled: true. - ^self ]]]. - - handledByInner ifTrue: [ ^self ]. - "Mouse was not on aMorph nor any of its children" - ^ #rejected! ! -!MouseScrollEvent methodsFor: 'dispatching' stamp: 'jmv 7/13/2020 16:23:48' prior: 50373755 overrides: 50531017! - dispatchWith: aMorph localPosition: positionInAMorph - "Find the appropriate receiver for the event and let it handle it. Default rules: - * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. - * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. - * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. - * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. - " - "Try to get out quickly" - | aMorphHandlesIt handledByInner eventPositionInChild focus| - focus := self hand keyboardFocus. - "FIXME - this works in all tested cases but one: when the window directly under the mouse doesn't have keyboard focus (i.e. a Transcript window)" - ((aMorph fullContainsPoint: positionInAMorph) and: [(aMorph = focus) or: [focus notNil and: [aMorph notNil and: [focus hasOwner: aMorph]]]]) ifFalse: [ ^ #rejected ]. - "Install the prospective handler for the receiver" - aMorphHandlesIt _ false. - (aMorph handlesMouseScroll: self) ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]. - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild - dispatchEvent: self - localPosition: eventPositionInChild) == #rejected ifFalse: [ "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - (handledByInner or: [ - (aMorph rejectsEvent: self) not and: [aMorph fullContainsPoint: positionInAMorph]]) ifTrue: [ - "aMorph is in the top-most unlocked, visible morph in the chain." - aMorphHandlesIt ifTrue: [ ^ self - sentTo: aMorph - localPosition: positionInAMorph ]]. - handledByInner ifTrue: [ ^ self ]. - "Mouse was not on aMorph nor any of its children" - ^ #rejected.! ! - -HaloMorph removeSelector: #containsPoint:event:! - -!methodRemoval: HaloMorph #containsPoint:event: stamp: 'Install-4262-Morphic-Refactor-JuanVuletich-2020Jul17-17h01m-jmv.001.cs.st 8/5/2020 22:21:35'! -containsPoint: aLocalPoint event: aMorphicEvent - - self visible ifFalse: [ ^false ]. - - "mouseButton3 events are handled by the halo" - (aMorphicEvent isMouse and: [ - aMorphicEvent isMouseDown and: [ aMorphicEvent mouseButton3Pressed ]]) - ifTrue: [ - ^ self morphLocalBounds containsPoint: aLocalPoint ]. - - ^false! - -Morph removeSelector: #containsPoint:event:! - -!methodRemoval: Morph #containsPoint:event: stamp: 'Install-4262-Morphic-Refactor-JuanVuletich-2020Jul17-17h01m-jmv.001.cs.st 8/5/2020 22:21:35'! -containsPoint: aLocalPoint event: anEvent - "Return true if aPoint is considered to be inside the receiver for the given event. - The default implementation treats locked children as integral part of their owners." - - "Should this method be called #fullContainsPoint:event: ? - Should it be merged with #fullContainsPoint: ? - " - self visible ifFalse: [ ^false ]. - (self morphContainsPoint: aLocalPoint) ifTrue: [ ^true ]. - self submorphsDrawingOutsideReverseDo: [ :m | - (m isLocked and: [ m fullContainsPoint: (m internalize: aLocalPoint) ]) - ifTrue: [ ^true ]]. - ^false! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4262-Morphic-Refactor-JuanVuletich-2020Jul17-17h01m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4259] on 17 July 2020 at 5:48:35 pm'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/10/2020 16:20:44'! - boundingRectOfCurrentMorphAfterDraw - "This rectangle is used for clipping submorphs in BitBltCanvas. - In VectorCanvas we support clipping by any shape, not just rectangles. Then, this rectangle is used as an optimization of the area to be redrawn." -" -Y ademas es el rectangulo afectado por la ultima operacion de dibujado. Que se yo. -Renombrarlo onda #currentMorphDisplayBounds o #currentMorphAffectedRect o algo asi. -" -self flag: #puff. - self subclassResponsibility! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 7/17/2020 17:41:13'! - boundingRectOfCurrentMorph - "In targetForm coordinates" - - ^currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 7/10/2020 17:23:40' overrides: 50531329! - boundingRectOfCurrentMorphAfterDraw - "In targetForm coordinates" - self flag: #puff. - ^ self boundingRectOfCurrentMorph! ! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 7/17/2020 17:45:55' prior: 50506151! - clippingByCurrentMorphDo: aBlock - | prevClipRect | - - prevClipRect _ self clipRect. - "Might use the fact that currentMorph has just been drawn." - self setClipRect: (prevClipRect intersect: self boundingRectOfCurrentMorphAfterDraw). - self clippingMorph: currentMorph. - aBlock ensure: [ - self clippingMorph: nil. - self setClipRect: prevClipRect. ]! ! -!BitBltCanvas methodsFor: 'testing' stamp: 'jmv 7/10/2020 17:23:43' prior: 50501584 overrides: 50463635! - isCurrentMorphVisible - | aRectangle myClipRect | - currentMorph visible ifFalse: [ ^false ]. - aRectangle := self boundingRectOfCurrentMorph. - myClipRect := self clipRect. - aRectangle right < myClipRect left ifTrue: [^ false]. - aRectangle left > myClipRect right ifTrue: [^ false]. - aRectangle bottom < myClipRect top ifTrue: [^ false]. - aRectangle top > myClipRect bottom ifTrue: [^ false]. - ^ true -! ! - -BitBltCanvas removeSelector: #clippingRectForCurrentMorph! - -!methodRemoval: BitBltCanvas #clippingRectForCurrentMorph stamp: 'Install-4263-MorphicRefactor-JuanVuletich-2020Jul17-17h38m-jmv.001.cs.st 8/5/2020 22:21:35'! -clippingRectForCurrentMorph - "In targetForm coordinates" - - ^currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds! - -MorphicCanvas removeSelector: #clippingRectForCurrentMorph! - -!methodRemoval: MorphicCanvas #clippingRectForCurrentMorph stamp: 'Install-4263-MorphicRefactor-JuanVuletich-2020Jul17-17h38m-jmv.001.cs.st 8/5/2020 22:21:35'! -clippingRectForCurrentMorph - "This rectangle is used for clipping submorphs in BitBltCanvas. - In VectorCanvas we support clipping by any shape, not just rectangles. Then, this rectangle is used as an optimization of the area to be redrawn." - - self subclassResponsibility! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4263-MorphicRefactor-JuanVuletich-2020Jul17-17h38m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4260] on 17 July 2020 at 5:58:42 pm'! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipRect transformations currentTransformation cti currentMorph drawingMorphStack engine world ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support' stamp: 'Install-4264-Morphic-refactor-JuanVuletich-2020Jul17-17h58m-jmv.001.cs.st 8/5/2020 22:21:35'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipRect transformations currentTransformation cti currentMorph drawingMorphStack engine world' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! -!MorphicCanvas methodsFor: 'initialization' stamp: 'jmv 7/11/2020 00:01:48'! - world: aPasteUpMorph - world _ aPasteUpMorph. - self into: world! ! -!WorldState methodsFor: 'canvas' stamp: 'jmv 7/11/2020 00:01:55' prior: 16945729! - setCanvas: aMorphicCanvas - canvas _ aMorphicCanvas. - canvas world: world. - damageRecorder - ifNil: [ damageRecorder _ DamageRecorder new]. - damageRecorder doFullRepaint! ! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'world form clipRect transformations currentTransformation cti currentMorph drawingMorphStack engine' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support' stamp: 'Install-4264-Morphic-refactor-JuanVuletich-2020Jul17-17h58m-jmv.001.cs.st 8/5/2020 22:21:35'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'world form clipRect transformations currentTransformation cti currentMorph drawingMorphStack engine' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4264-Morphic-refactor-JuanVuletich-2020Jul17-17h58m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4260] on 17 July 2020 at 6:04:24 pm'! - -PasteUpMorph removeSelector: #acceptDroppingMorph:event:! - -!methodRemoval: PasteUpMorph #acceptDroppingMorph:event: stamp: 'Install-4265-Morph-simplify-JuanVuletich-2020Jul17-17h58m-jmv.001.cs.st 8/5/2020 22:21:35'! -acceptDroppingMorph: aMorph event: evt - "The supplied morph, known to be acceptable to the receiver, is now to be assimilated; the precipitating event is supplied" - - self isWorldMorph - ifTrue: [ - "Add the given morph to this world and start stepping it if it wants to be." - self addMorphFront: aMorph. - (aMorph morphFullBoundsInWorld intersects: self viewBox) - ifFalse: [ - Smalltalk beep. - aMorph morphPosition: extent // 2]] - ifFalse: [super acceptDroppingMorph: aMorph event: evt]. - aMorph submorphsDo: [ :m | (m is: #HaloMorph) ifTrue: [ m delete ]]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4265-Morph-simplify-JuanVuletich-2020Jul17-17h58m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4263] on 19 July 2020 at 4:07:56 pm'! -!HaloMorph methodsFor: 'event handling' stamp: 'jmv 7/12/2020 21:28:50' prior: 50530883 overrides: 16877018! - redrawNeeded - "Report that the area occupied by this morph should be redrawn." - - self - invalidateDisplayRect: - ((self morphBoundsInWorld - outsetBy: self class handleSize*2) - extendBy: 0@(FontFamily defaultLineSpacing+self class handleSize)) - from: nil. - "Label could be wider than us..." - self submorphsDrawingOutsideReverseDo: [ :m | m redrawNeeded ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4266-HaloFix-JuanVuletich-2020Jul19-15h56m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4263] on 19 July 2020 at 5:22:10 pm'! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/13/2020 16:59:51'! - fullContainsGlobalPoint: worldPoint -"Answer true even if aLocalPoint is in some unclipped submorph, but outside us " - - "If not visible, won't contain any point at all." - | canvas | - self visible ifFalse: [ ^false ]. - - canvas _ self world canvas. - canvas isNil ifTrue: [ ^false ]. - (canvas morph: self isAtPoint: worldPoint) ifTrue: [ ^ true ]. - self submorphsDrawingOutsideReverseDo: [ :m | - (m fullContainsGlobalPoint: worldPoint) ifTrue: [ ^ true ]]. - ^ false! ! -!RectangleLikeMorph methodsFor: 'geometry testing' stamp: 'jmv 7/13/2020 16:37:51' overrides: 16875610! - morphContainsPoint: aLocalPoint -"Answer true even if aLocalPoint is in asubmorph, as long as it is in our shape" - - "If not visible, won't contain any point at all." - self visible ifFalse: [ ^false ]. - - "Most morphs answer true to to #isOrthoRectangularMorph, or redefine this method..." - self isOrthoRectangularMorph ifTrue: [ - ^ self morphLocalBounds containsPoint: aLocalPoint ]. - - "...But for those who not, provide correct albeit expensive behavior." - "Can't do better. Please redefine in subclasses as appropriate!! (or finish Morphic 3!!)" - "Mhhh. Podria usar el #imageForm: y ver si es transparente... deberia andar" - ^ self morphLocalBounds containsPoint: aLocalPoint! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 7/13/2020 16:43:16'! - morph: aMorph isAtPoint: aPoint - - ^aMorph morphContainsPoint: - (aMorph internalizeFromWorld: aPoint)! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/13/2020 17:00:03' prior: 50531003! -fullContainsPoint: aLocalPoint -"Answer true even if aLocalPoint is in some unclipped submorph, but outside us " - - "If not visible, won't contain any point at all." - self visible ifFalse: [ ^false ]. - - ^self fullContainsGlobalPoint: (self externalizeToWorld: aLocalPoint).! ! - -Morph removeSelector: #morphContainsPoint:! - -!methodRemoval: Morph #morphContainsPoint: stamp: 'Install-4267-fullContainsPoint-JuanVuletich-2020Jul19-17h15m-jmv.001.cs.st 8/5/2020 22:21:35'! -morphContainsPoint: aLocalPoint - - "If not visible, won't contain any point at all." - self visible ifFalse: [ ^false ]. - - "Most morphs answer true to to #isOrthoRectangularMorph, or redefine this method..." - self isOrthoRectangularMorph ifTrue: [ - ^ self morphLocalBounds containsPoint: aLocalPoint ]. - - "...But for those who not, provide correct albeit expensive behavior." - "Can't do better. Please redefine in subclasses as appropriate!! (or finish Morphic 3!!)" - "Mhhh. Podria usar el #imageForm: y ver si es transparente... deberia andar" - ^ self morphLocalBounds containsPoint: aLocalPoint! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4267-fullContainsPoint-JuanVuletich-2020Jul19-17h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4264] on 20 July 2020 at 4:24:39 pm'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/20/2020 16:14:37'! - drawWorld: aPasteUpMorph submorphs: worldSubmorphs repair: aDamageRecorder - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rectsToRepair previousRectsToRepair reuse previousCount morphBounds | - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ aDamageRecorder invalidRectsFullBounds: aPasteUpMorph viewBox. - - rectsToRepair size > 1 ifTrue: [ "Or there is no point in attempting to merge them!!" - previousRectsToRepair _ OrderedCollection new. - - "Until no more rectangles are merged, i.e. each morph intersects at most one rectangle." - previousCount _ 0. - [rectsToRepair size = previousCount] whileFalse: [ - previousCount _ rectsToRepair size. - worldSubmorphs reverseDo: [ :morph | | thisMorphRectangle thisMorphBounds | - morph visible ifTrue: [ - reuse _ previousRectsToRepair. - previousRectsToRepair _ rectsToRepair. - rectsToRepair _ reuse removeAll. - thisMorphRectangle _ nil. - thisMorphBounds _ morph morphFullBoundsInWorld. - previousRectsToRepair do: [ :r | - (thisMorphBounds intersects: r) - ifTrue: [ thisMorphRectangle _ r quickMerge: thisMorphRectangle ] - ifFalse: [ rectsToRepair add: r ]]. - thisMorphRectangle - ifNotNil: [rectsToRepair add: thisMorphRectangle]]]]. - ]. - - "Draw World" - rectsToRepair do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - "Draw morphs" - worldSubmorphs reverseDo: [ :morph | - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - rectsToRepair do: [ :r | - (morphBounds intersects: r) ifTrue: [ - (self newClipRect: r) fullDraw: morph ]]]]. - - ^ rectsToRepair! ! -!Rectangle methodsFor: 'rectangle functions' stamp: 'jmv 7/20/2020 12:44:18' prior: 16898788! - merge: aRectangle - "Answer a Rectangle that contains both the receiver and aRectangle. - See #quickMerge:" - - ^Rectangle - origin: (origin min: aRectangle origin) - corner: (corner max: aRectangle corner)! ! -!Rectangle methodsFor: 'rectangle functions' stamp: 'jmv 7/20/2020 12:44:59' prior: 16898810! - quickMerge: aRectangle - "Answer the receiver if it encloses the given rectangle or the merge of the two rectangles if it doesn't. - This method is an optimization to reduce extra rectangle creations. - Accept nil as argument" - - | useRcvr rOrigin rCorner minX maxX minY maxY | - aRectangle ifNil: [ ^self ]. - - useRcvr _ true. - rOrigin _ aRectangle topLeft. - rCorner _ aRectangle bottomRight. - minX _ rOrigin x < origin x ifTrue: [ useRcvr _ false. rOrigin x ] ifFalse: [ origin x ]. - maxX _ rCorner x > corner x ifTrue: [ useRcvr _ false. rCorner x ] ifFalse: [ corner x ]. - minY _ rOrigin y < origin y ifTrue: [ useRcvr _ false. rOrigin y ] ifFalse: [ origin y ]. - maxY _ rCorner y > corner y ifTrue: [useRcvr _ false. rCorner y ] ifFalse: [ corner y ]. - - ^useRcvr - ifTrue: [ self ] - ifFalse: [ Rectangle origin: minX@minY corner: maxX@maxY ].! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 7/20/2020 12:43:39' prior: 50385122! - savePatchFrom: aCanvas appendDamageTo: aStream - "Save the part of the given canvas under this hand as a Form and return its bounding rectangle." - - "Details: The previously used patch Form is recycled when possible to reduce the burden on storage management." - - | fullBounds | - fullBounds _ self morphFullBoundsInWorld. - fullBounds ifNil: [ ^self ]. - - fullBounds _ fullBounds intersect: (`0@0` extent: aCanvas extent). - (savedPatch isNil or: [savedPatch extent ~= fullBounds extent]) - ifTrue: [ - "allocate new patch form if needed" - savedPatch _ Form extent: fullBounds extent depth: aCanvas depth ]. - aCanvas - contentsOfArea: fullBounds - into: savedPatch. - savedPatch offset: fullBounds topLeft. - prevFullBounds - ifNil: [ aStream nextPut: fullBounds ] - ifNotNil: [ aStream nextPut: (fullBounds quickMerge: prevFullBounds)]. - prevFullBounds _ fullBounds! ! -!WorldState methodsFor: 'drawing' stamp: 'jmv 7/20/2020 16:15:29' prior: 50339616! - displayWorldAndSubmorphs: submorphs - "Update this world's display." - - | deferredUpdateVMMode worldDamageRects handsToDraw allDamage | - self checkIfUpdateNeeded ifFalse: [ ^ self ]. "display is already up-to-date" - "I (jmv) removed the call to 'deferUpdates: false' below. No more need to call this every time." - deferredUpdateVMMode _ self tryDeferredUpdatingAndSetCanvas. - - "repair world's damage on canvas" - worldDamageRects _ canvas drawWorld: world submorphs: submorphs repair: damageRecorder. - - "Check which hands need to be drawn (they are not the hardware mouse pointer)" - handsToDraw _ self selectHandsToDrawForDamage: worldDamageRects. - allDamage _ Array streamContents: [ :strm | - strm nextPutAll: worldDamageRects. - handsToDraw do: [ :h | - h savePatchFrom: canvas appendDamageTo: strm ]]. - - "Draw hands (usually carying morphs) onto world canvas" - canvas newClipRect: nil. - handsToDraw reverseDo: [ :h | canvas fullDrawHand: h ]. - - "quickly copy altered rects of canvas to Display:" - deferredUpdateVMMode ifFalse: [ - "Drawing was done to off-Display canvas. Copy content to Display" - canvas showAt: world viewBox origin invalidRects: allDamage ]. - - "Display deferUpdates: false." - "Display forceDisplayUpdate" - Display forceDamageToScreen: allDamage. - - "Restore world canvas under hands and their carried morphs" - handsToDraw do: [ :h | h restoreSavedPatchOn: canvas ].! ! -!DamageRecorder methodsFor: 'recording' stamp: 'jmv 7/20/2020 15:55:32' prior: 50462780! - invalidRectsFullBounds: aRectangle - "Return a collection of damaged rectangles for the given canvas. - If a total repaint has been requested, return the given rectangle. - Forget about all damage." - | answer | - answer _ totalRepaint ifTrue: [ Array with: aRectangle ]. - self pvtAccessProtect critical: [ - answer ifNil: [ - answer _ invalidRects reject: [ :r | - r isNil ]]. - self pvtReset ]. - ^ answer.! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/20/2020 12:43:25' prior: 16877438! - displayFullBoundsInWorldOf: aMorph - "Answer a rectangle that completely bounds aMorph and submorphs when drawn - (if the world was to be fully drawn, i.e. only to be used on a Canvas on the full world). - Might be larger than strictly required. See comment at #displayBoundsInWorldOf:" - - | r | - "Think about doing a BoundsFinderCanvas even for Morphic 2" - - self flag: #jmvVer2. - - r _ self displayBoundsInWorldOf: aMorph. - aMorph submorphsDrawingOutsideReverseDo: [ :m | - m visible ifTrue: [ - r _ r quickMerge: (self displayFullBoundsInWorldOf: m) ]]. - - ^r! ! - -WorldState class removeSelector: #experiment1! - -!methodRemoval: WorldState class #experiment1 stamp: 'Install-4268-Morphic-Refactor-JuanVuletich-2020Jul20-16h20m-jmv.001.cs.st 8/5/2020 22:21:35'! -experiment1 - "To play with and learn about morphic Display update logic. - Remove the morphs when done!!" - " - WorldState experiment1 - " - | dr morph1 morph2 s w | - morph1 _ RectangleLikeMorph new openInWorld. - morph2 _ RectangleLikeMorph new openInWorld. - morph2 color: `Color green`. - morph2 morphPosition: 200@800 extent: 50@40. - morph1 morphPosition: 120@720 extent: 220@100. - - w _ self runningWorld. - s _ w instVarNamed: 'worldState'. - dr _ s instVarNamed: 'damageRecorder'. - - dr doFullRepaint. - dr reset; - " recordInvalidRect: (100@700 corner: 400@900);" - recordInvalidRect: (100@700 corner: 150@900); - recordInvalidRect: (300@700 corner: 400@900). - Display fillColor: `Color gray`. - "Do not draw the area used by the small rectangle, unless it is also drawn!!" - s drawInvalidAreasSubmorphs: {morph1. morph2 }! - -WorldState removeSelector: #drawInvalidAreasSubmorphs:! - -!methodRemoval: WorldState #drawInvalidAreasSubmorphs: stamp: 'Install-4268-Morphic-Refactor-JuanVuletich-2020Jul20-16h20m-jmv.001.cs.st 8/5/2020 22:21:35'! -drawInvalidAreasSubmorphs: submorphs - "Redraw the damaged areas of the given canvas and clear the damage list. Return a collection of the areas that were redrawn." - - | initialRectsToRepair currentRectsToRepair newRectsToRepair morphsToDraw rectsForEachMorph thisMorphRects reuse i n morph morphBounds morphClipRect | - - "The simple implementation is slowers as it draws morph areas that will later be covered by other morphs. - But it works, and it is easier to understand. - See en.wikipedia.org/wiki/Painter's_algorithm" - true not ifTrue: [ ^self simpleDrawInvalidAreasSubmorphs: submorphs ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - initialRectsToRepair _ damageRecorder invalidRectsFullBounds: world viewBox. - currentRectsToRepair _ OrderedCollection new. - newRectsToRepair _ OrderedCollection withAll: initialRectsToRepair. - morphsToDraw _ OrderedCollection new. - rectsForEachMorph _ OrderedCollection new. - thisMorphRects _ OrderedCollection new. - n _ submorphs size. - i _ 1. - - "The idea here is to iterate morphs front to back, i.e. first the ones on top. - For each morph, record the rectangles it affects. And if a morph is opaque, remove the area behind it from the list of rectangles to be repaired. - This means, for example, that morphs completely covered might even not be redrawn. - this is a huge performance gain when there are many morphs on screen, especially if there are more than ten open windows, and Theme uses opaque colors. - See 'A reverse painter's algorithm' at en.wikipedia.org/wiki/Painter's_algorithm" - [ i <= n and: [ newRectsToRepair notEmpty ]] whileTrue: [ - morph _ submorphs at: i. - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - reuse _ currentRectsToRepair. - currentRectsToRepair _ newRectsToRepair. - newRectsToRepair _ reuse removeAll. - currentRectsToRepair do: [ :r | - (morphBounds intersects: r) - ifTrue: [ - morphClipRect _ morphBounds intersect: r. - thisMorphRects add: morphClipRect. "We could perhaps try and join adjacent rectangles in this collection..." - morph addPossiblyUncoveredAreasIn: r to: newRectsToRepair ] - ifFalse: [ - newRectsToRepair add: r ]]. - thisMorphRects ifNotEmpty: [ - morphsToDraw add: morph. - rectsForEachMorph add: thisMorphRects. - thisMorphRects _ OrderedCollection new. - ]]. - i _ i + 1 ]. - - "*make this true to flash damaged areas for testing*" - Preferences debugShowDamage ifTrue: [ world fillRects: initialRectsToRepair ]. - - "Draw world background on those areas that were not completely covered by opaque morphs" - i > n ifTrue: [ - newRectsToRepair do: [ :r | - world drawOn: (canvas newClipRect: r) ]]. - - "Now, draw the recorded areas of selected morphs, back to front." - morphsToDraw with: rectsForEachMorph reverseDo: [ :m :xrects | - "Here we could think about merging all xrects into just one call... - This would mean drawing each morph just once. - But that would mean drawing pixels we were not told to. There could be other morphs in that area that are not even being drawn!! - See WorldState class >> #experiment1" - "*make this true to flash damaged areas for testing*" - Preferences debugShowDamage2 ifTrue: [ - world fillRects: xrects ]. -" rr _ nil." - xrects do: [ :r | -" rr _ rr ifNil: [ r ] ifNotNil: [ r quickMerge: rr ]." - (canvas newClipRect: r) fullDraw: m. - ]. -" (canvas newClipRect: rr) fullDraw: m" - ]. - - "Answer a list of rectangles to be updated on the Display. - This usually is not performance critical, drawing morphs is slower than just exposing the Display." - "What should we force on Display? Whatever was asked? Each small rect that was updated? A single bigger rect? - Right now, answer whatever was asked... Maybe this could be changed if that enhances performance... - (think of vnc over slow networks)" - ^ initialRectsToRepair! - -WorldState removeSelector: #simpleDrawInvalidAreasSubmorphs:! - -!methodRemoval: WorldState #simpleDrawInvalidAreasSubmorphs: stamp: 'Install-4268-Morphic-Refactor-JuanVuletich-2020Jul20-16h20m-jmv.001.cs.st 8/5/2020 22:21:35'! -simpleDrawInvalidAreasSubmorphs: submorphs - - "mover todo esto al canvas, no? - Y ver que hacer con los argumentos, etc.... Toda esta bananarama!!" - - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - This simple implementation just does as requested: No optimizations are done." - - | rectsToRepair morphBounds | - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ damageRecorder invalidRectsFullBounds: world viewBox. - - "Draw World" - rectsToRepair do: [ :r | - world drawOn: (canvas newClipRect: r) ]. - - "Draw morphs" - submorphs reverseDo: [ :morph | - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - rectsToRepair do: [ :r | - (morphBounds intersects: r) ifTrue: [ - (canvas newClipRect: r) fullDraw: morph ]]]]. - - ^ rectsToRepair! - -SystemWindow removeSelector: #addPossiblyUncoveredAreasIn:to:! - -!methodRemoval: SystemWindow #addPossiblyUncoveredAreasIn:to: stamp: 'Install-4268-Morphic-Refactor-JuanVuletich-2020Jul20-16h20m-jmv.001.cs.st 8/5/2020 22:21:35'! -addPossiblyUncoveredAreasIn: aRectangle to: aCollection - "Answer an array of rectangles encompassing those areas in aRectangle not completely - covered by self. These are the areas that might require further drawing (of morphs below us) - All areas that might possibly be uncovered must be included." - | bounds radious | - color mightBeTranslucent ifTrue: [ - aCollection add: aRectangle. - ^self ]. - - bounds _ self morphBoundsInWorld. - bounds ifNil: [ - aCollection add: aRectangle. - ^self ]. - - "Solid rectangle. - This will be the fastest in many cases. So, please disable rounded corners if on slow hardware!!" - Theme current roundWindowCorners ifFalse: [ - aRectangle areasOutside: bounds do: [ :rect | aCollection add: rect ]. - ^self ]. - - "The solid rectangle does not include the corners. - Report a couple of rows (top and bottom) or columns (left and right) as uncovered areas. - We could also try to be more careful and answer each rounded corner... - Right now, report top and bottom rows as uncovered areas" - radious _ Theme current roundedWindowRadius. - aRectangle areasOutside: (bounds insetBy: 0@radious) do: [ :rect | aCollection add: rect ]! - -RectangleLikeMorph removeSelector: #addPossiblyUncoveredAreasIn:to:! - -!methodRemoval: RectangleLikeMorph #addPossiblyUncoveredAreasIn:to: stamp: 'Install-4268-Morphic-Refactor-JuanVuletich-2020Jul20-16h20m-jmv.001.cs.st 8/5/2020 22:21:35'! -addPossiblyUncoveredAreasIn: aRectangle to: aCollection - "Answer an array of rectangles encompassing those areas in aRectangle not completely - covered by self. - All areas that might possibly be uncovered must be included." - (self isOrthoRectangularMorph and: [ self isOpaqueMorph ]) ifTrue: [ - aRectangle areasOutside: self morphBoundsInWorld do: [ :r | aCollection add: r ]. - ^self ]. - aCollection add: aRectangle! - -Morph removeSelector: #addPossiblyUncoveredAreasIn:to:! - -!methodRemoval: Morph #addPossiblyUncoveredAreasIn:to: stamp: 'Install-4268-Morphic-Refactor-JuanVuletich-2020Jul20-16h20m-jmv.001.cs.st 8/5/2020 22:21:35'! -addPossiblyUncoveredAreasIn: aRectangle to: aCollection - "Answer an array of rectangles encompassing those areas in aRectangle not completely - covered by self. - All areas that might possibly be uncovered must be included." - aCollection add: aRectangle! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4268-Morphic-Refactor-JuanVuletich-2020Jul20-16h20m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4262] on 18 July 2020 at 9:43:11 pm'! -!RectangleLikeMorph commentStamp: '' prior: 16899175! - Hierarchy for morphs that are rectangle like, and that occupy an area that can be specified as a Rectangle. This means that, besides being of rectangular shape, sides are aligned with local coordinate axes. Including rectangles with rounded corners and such. The idea is that the 'extent' ivar is all that's needed to establish our dimensions and shape. Subclasses can add things like 'roundedCornerRadious' or such.! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/18/2020 21:35:00'! - requiresVectorCanvas - "True if we use VectorCanvas protocol, or we are rotated or zoomed. - If false, we occupy a Rectangle in local coordinates. Allows for many optimizations to be done. - Note: If answer is false, but some owner requiresVectorCanvas, then we also do. Canvas takes care of this. - Note: SystemWindow answers false, but implements #addPossiblyUncoveredAreasIn:to: to take care of rounded corners." - - ^true! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/18/2020 21:38:32'! - submorphsMightProtrude - "Answered false by morphs that can guarantee that submorphs, and all morphs in their submorphs tree, will lie inside their bounds, - either 'naturally' (by construction) or by being clipped by their owner (#clipsLastSubmorph). Allows for many optimizations to be done." - - ^true! ! -!RectangleLikeMorph methodsFor: 'geometry testing' stamp: 'jmv 7/18/2020 21:35:08' overrides: 50532139! - requiresVectorCanvas - "True if we use VectorCanvas protocol, or we are rotated or zoomed. - If false, we occupy a Rectangle in local coordinates. Allows for many optimizations to be done. - Note: If answer is false, but some owner requiresVectorCanvas, then we also do. Canvas takes care of this. - Note: SystemWindow answers false, but implements #addPossiblyUncoveredAreasIn:to: to take care of rounded corners." - - ^location isPureTranslation not! ! -!RectangleLikeMorph methodsFor: 'geometry testing' stamp: 'jmv 7/18/2020 21:38:44' overrides: 50532155! - submorphsMightProtrude - "Answered false by morphs that can guarantee that submorphs, and all morphs in their submorphs tree, will lie inside their bounds, - either 'naturally' (by construction) or by being clipped by their owner (#clipsLastSubmorph). Allows for many optimizations to be done." - - ^false! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/18/2020 21:37:13' prior: 16874291! - clipsLastSubmorph - "Answer true if we clip the shape of our last submorph to ours. - Answer true only when clipping by the canvas is needed." - - ^ false! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/18/2020 21:35:45' prior: 16875601! - isOrthoRectangularMorph - "True if we are of rectangular shape, aligned with local coordinate axes. - Doesn't take into account possible rotation of our or some owner's local coordinates. - Note: SystemWindow answers true, but implements #addPossiblyUncoveredAreasIn:to: to take care of rounded corners." - - ^false! ! -!RectangleLikeMorph methodsFor: 'geometry testing' stamp: 'jmv 7/18/2020 21:35:50' prior: 16899320 overrides: 50532207! - isOrthoRectangularMorph - "True if we are of rectangular shape, aligned with local coordinate axes. - Doesn't take into account possible rotation of our or some owner's local coordinates. - Note: SystemWindow answers true, but implements #addPossiblyUncoveredAreasIn:to: to take care of rounded corners." - - ^true! ! -!PluggableScrollPane methodsFor: 'geometry testing' stamp: 'jmv 7/18/2020 21:37:41' prior: 16889528 overrides: 50532199! - clipsLastSubmorph - "Answer true if we clip the shape of our last submorph to ours. - Answer true only when clipping by the canvas is needed." - - ^ true! ! -!WindowEdgeAdjustingMorph methodsFor: 'geometry testing' stamp: 'jmv 7/18/2020 21:32:52' prior: 16945120 overrides: 50532221! - isOrthoRectangularMorph - ^false! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4269-NewProtocolsAndComments-JuanVuletich-2020Jul18-20h52m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4266] on 20 July 2020 at 5:20:13 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/20/2020 17:06:19'! - displayBounds - "At time of last draw. nil if unknown." - - self visible ifFalse: [ ^nil ]. - ^ self valueOfProperty: #displayBounds! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/20/2020 17:12:49'! - displayBounds: aRectangle - "If we update know bounds, chances are last draw operation used incorrect value. Draw again then." - - self displayBounds ~= aRectangle ifTrue: [ - self setProperty: #displayBounds toValue: aRectangle ].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/20/2020 17:11:35'! - displayBoundsOrBogus - "Never answer nil. A bogus value will trigger a draw operation, and bounds will then be corrected." -"Ver si esto aun tiene algun sentido" - ^self displayBounds ifNil: [ - Rectangle center: (self externalizeToWorld: 0@0) extent: 2@2 ]! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/20/2020 17:10:46'! - displayFullBounds - "Answer a rectangle that completely bounds receiver and submorphs when last drawn - (if the world was to be fully drawn, i.e. only to be used on a Canvas on the full world)." - - | answer | - answer _ self displayBounds. - answer isNil ifTrue: [ ^nil ]. - self submorphsDrawingOutsideReverseDo: [ :m | - answer _ answer quickMerge: m displayFullBounds ]. - ^answer! ! -!PasteUpMorph methodsFor: 'geometry' stamp: 'jmv 7/20/2020 17:14:34' overrides: 50532255! - displayBounds - ^self isWorldMorph ifTrue: [0@0 extent: extent] ifFalse: [super displayBounds]! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 7/20/2020 17:16:36' overrides: 50532283! - displayFullBounds -"ver lo que habia hecho. #lastPos, reusar cuando se mueve." - ^super displayFullBounds! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/20/2020 17:18:36' prior: 16877416! - displayBoundsInWorldOf: aMorph - "Answer a rectangle that completely bounds aMorph when drawn on our form. - Might be larger than strictly required. - - In Morphic 2, this could cause clipping artifacts. This doesn't usually happen because: - a) Morphic 2 doesn't use scaling and rotation - b) Most Morphic 2 morphs have rectangular shape. - - In Morphic 3, clipping also considers the real shape of the owner morph. This avoids those artifacts." -"borrar?" - "Think about doing a BoundsFinderCanvas even for Morphic 2" - self flag: #jmvVer2. - - ^self externalizeDisplayBounds: aMorph morphLocalBounds from: aMorph! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/20/2020 17:18:44' prior: 50531823! - displayFullBoundsInWorldOf: aMorph - "Answer a rectangle that completely bounds aMorph and submorphs when drawn - (if the world was to be fully drawn, i.e. only to be used on a Canvas on the full world). - Might be larger than strictly required. See comment at #displayBoundsInWorldOf:" - - | r | - "Think about doing a BoundsFinderCanvas even for Morphic 2" -"borrar?" - self flag: #jmvVer2. - - r _ self displayBoundsInWorldOf: aMorph. - aMorph submorphsDrawingOutsideReverseDo: [ :m | - m visible ifTrue: [ - r _ r quickMerge: (self displayFullBoundsInWorldOf: m) ]]. - - ^r! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/20/2020 17:19:44' prior: 50530668! - drawCurrentAndSubmorphs - - self isCurrentMorphVisible ifTrue: [ - currentMorph drawOn: self. - world notNil ifTrue: [ - currentMorph displayBounds: self boundingRectOfCurrentMorphAfterDraw ]. - "Display submorphs back to front" - "coordinate system stack already set up for aMorph - ('ivars transformations' and 'currentTransformation')" - currentMorph hasSubmorphs ifTrue: [ - currentMorph clippedSubmorph ifNotNil: [ :clipped | - self clippingByCurrentMorphDo: [ self fullDraw: clipped ]]. - currentMorph unclippedSubmorphsReverseDo: [ :m | - self fullDraw: m ]]].! ! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 7/11/2020 09:41:46' prior: 50531329! - boundingRectOfCurrentMorphAfterDraw - "This rectangle is used for clipping submorphs in BitBltCanvas. - In VectorCanvas we support clipping by any shape, not just rectangles. Then, this rectangle is used as an optimization of the area to be redrawn." - - self subclassResponsibility! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4270-Morphic-VG-JuanVuletich-2020Jul20-17h01m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4267] on 21 July 2020 at 11:16:42 am'! -!Morph methodsFor: 'updating' stamp: 'jmv 7/20/2020 17:26:13'! - isRedrawNeeded - "Report that the area occupied by this morph should be redrawn." -"Creo que es mejor transformarlo en una coleccion. Ver." - - self visible ifFalse: [ ^false ]. - ^ self valueOfProperty: #isRedrawNeeded ifAbsent: [ false ]! ! -!WorldState methodsFor: 'drawing' stamp: 'jmv 7/20/2020 17:30:42'! - displayWorldAndSubmorphs - "Update this world's display." - - | deferredUpdateVMMode worldDamageRects handsToDraw allDamage | - self checkIfUpdateNeeded ifFalse: [ ^ self ]. "display is already up-to-date" - "I (jmv) removed the call to 'deferUpdates: false' below. No more need to call this every time." - deferredUpdateVMMode _ self tryDeferredUpdatingAndSetCanvas. - - "repair world's damage on canvas" - worldDamageRects _ canvas drawWorld: world repair: damageRecorder. - - "Check which hands need to be drawn (they are not the hardware mouse pointer)" - handsToDraw _ self selectHandsToDrawForDamage: worldDamageRects. - allDamage _ Array streamContents: [ :strm | - strm nextPutAll: worldDamageRects. - handsToDraw do: [ :h | - h savePatchFrom: canvas appendDamageTo: strm ]]. - - "Draw hands (usually carying morphs) onto world canvas" - canvas newClipRect: nil. - handsToDraw reverseDo: [ :h | canvas fullDrawHand: h ]. - - "quickly copy altered rects of canvas to Display:" - deferredUpdateVMMode ifFalse: [ - "Drawing was done to off-Display canvas. Copy content to Display" - canvas showAt: world viewBox origin invalidRects: allDamage ]. - - "Display deferUpdates: false." - "Display forceDisplayUpdate" - Display forceDamageToScreen: allDamage. - - "Restore world canvas under hands and their carried morphs" - handsToDraw do: [ :h | h restoreSavedPatchOn: canvas ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/20/2020 17:52:34'! - drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rectsToRepair previousRectsToRepair reuse previousCount morphBounds | - - "Add dirty rectangles for all dirty morphs" - aPasteUpMorph allMorphsDo: [ :morph | - morph isRedrawNeeded ifTrue: [ - morph setProperty: #isRedrawNeeded toValue: false. - morph displayFullBounds ifNotNil: [ :r | - aDamageRecorder recordInvalidRect: r ]]]. - - "Aca agregar el seoudodibujado para actualizar los bounds que sean necesarios" - - "Add dirty rectangles for all dirty morphs" - aPasteUpMorph allMorphsDo: [ :morph | - morph isRedrawNeeded ifTrue: [ - morph displayFullBounds ifNotNil: [ :r | - aDamageRecorder recordInvalidRect: r ]]]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ aDamageRecorder invalidRectsFullBounds: aPasteUpMorph viewBox. - - rectsToRepair size > 1 ifTrue: [ "Or there is no point in attempting to merge them!!" - previousRectsToRepair _ OrderedCollection new. - - "Until no more rectangles are merged, i.e. each morph intersects at most one rectangle." - previousCount _ 0. - [rectsToRepair size = previousCount] whileFalse: [ - previousCount _ rectsToRepair size. - aPasteUpMorph submorphsReverseDo: [ :morph | | thisMorphRectangle thisMorphBounds | - morph visible ifTrue: [ - reuse _ previousRectsToRepair. - previousRectsToRepair _ rectsToRepair. - rectsToRepair _ reuse removeAll. - thisMorphRectangle _ nil. - thisMorphBounds _ morph morphFullBoundsInWorld. - previousRectsToRepair do: [ :r | - (thisMorphBounds intersects: r) - ifTrue: [ thisMorphRectangle _ r quickMerge: thisMorphRectangle ] - ifFalse: [ rectsToRepair add: r ]]. - thisMorphRectangle - ifNotNil: [rectsToRepair add: thisMorphRectangle]]]]. - ]. - - "Draw World" - rectsToRepair do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - "Draw morphs" - aPasteUpMorph submorphsReverseDo: [ :morph | - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - rectsToRepair do: [ :r | - (morphBounds intersects: r) ifTrue: [ - (self newClipRect: r) fullDraw: morph ]]]]. - - ^ rectsToRepair! ! -!Morph methodsFor: 'updating' stamp: 'jmv 7/21/2020 10:48:14' prior: 16877018! - redrawNeeded - "Report that the area occupied by this morph should be redrawn." - - self flag: #jmvVer2. - "Invalidate the appropriate display rectangle... Include submorphs if we don't clip!! - Think about it. We don't to know about a specific display rectangle... How do we notify our 'observers' (i.e. the possible canvases we end drawn upon)?" - - self isRedrawNeeded ifFalse: [ - self setProperty: #isRedrawNeeded toValue: true ]. -"Dummy, so #updateIsNeeded answers true if some morph dirty" -self invalidateDisplayRect: (10@10 extent: 2@2) from: nil. -false ifTrue: [ - self morphBoundsInWorld ifNotNil: [ :r | - self invalidateDisplayRect: r from: nil. - "Expensive in many cases..." - self submorphsDrawingOutsideReverseDo: [ :m | m redrawNeeded ]] -]! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 7/20/2020 17:30:57' prior: 50339877! - privateOuterDisplayWorld - - worldState displayWorldAndSubmorphs! ! - -MorphicCanvas removeSelector: #drawWorld:submorphs:repair:! - -!methodRemoval: MorphicCanvas #drawWorld:submorphs:repair: stamp: 'Install-4271-Morphic-VG-JuanVuletich-2020Jul21-10h41m-jmv.001.cs.st 8/5/2020 22:21:35'! -drawWorld: aPasteUpMorph submorphs: worldSubmorphs repair: aDamageRecorder - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rectsToRepair previousRectsToRepair reuse previousCount morphBounds | - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ aDamageRecorder invalidRectsFullBounds: aPasteUpMorph viewBox. - - rectsToRepair size > 1 ifTrue: [ "Or there is no point in attempting to merge them!!" - previousRectsToRepair _ OrderedCollection new. - - "Until no more rectangles are merged, i.e. each morph intersects at most one rectangle." - previousCount _ 0. - [rectsToRepair size = previousCount] whileFalse: [ - previousCount _ rectsToRepair size. - worldSubmorphs reverseDo: [ :morph | | thisMorphRectangle thisMorphBounds | - morph visible ifTrue: [ - reuse _ previousRectsToRepair. - previousRectsToRepair _ rectsToRepair. - rectsToRepair _ reuse removeAll. - thisMorphRectangle _ nil. - thisMorphBounds _ morph morphFullBoundsInWorld. - previousRectsToRepair do: [ :r | - (thisMorphBounds intersects: r) - ifTrue: [ thisMorphRectangle _ r quickMerge: thisMorphRectangle ] - ifFalse: [ rectsToRepair add: r ]]. - thisMorphRectangle - ifNotNil: [rectsToRepair add: thisMorphRectangle]]]]. - ]. - - "Draw World" - rectsToRepair do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - "Draw morphs" - worldSubmorphs reverseDo: [ :morph | - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - rectsToRepair do: [ :r | - (morphBounds intersects: r) ifTrue: [ - (self newClipRect: r) fullDraw: morph ]]]]. - - ^ rectsToRepair! - -WorldState removeSelector: #displayWorldAndSubmorphs:! - -!methodRemoval: WorldState #displayWorldAndSubmorphs: stamp: 'Install-4271-Morphic-VG-JuanVuletich-2020Jul21-10h41m-jmv.001.cs.st 8/5/2020 22:21:35'! -displayWorldAndSubmorphs: submorphs - "Update this world's display." - - | deferredUpdateVMMode worldDamageRects handsToDraw allDamage | - self checkIfUpdateNeeded ifFalse: [ ^ self ]. "display is already up-to-date" - "I (jmv) removed the call to 'deferUpdates: false' below. No more need to call this every time." - deferredUpdateVMMode _ self tryDeferredUpdatingAndSetCanvas. - - "repair world's damage on canvas" - worldDamageRects _ canvas drawWorld: world submorphs: submorphs repair: damageRecorder. - - "Check which hands need to be drawn (they are not the hardware mouse pointer)" - handsToDraw _ self selectHandsToDrawForDamage: worldDamageRects. - allDamage _ Array streamContents: [ :strm | - strm nextPutAll: worldDamageRects. - handsToDraw do: [ :h | - h savePatchFrom: canvas appendDamageTo: strm ]]. - - "Draw hands (usually carying morphs) onto world canvas" - canvas newClipRect: nil. - handsToDraw reverseDo: [ :h | canvas fullDrawHand: h ]. - - "quickly copy altered rects of canvas to Display:" - deferredUpdateVMMode ifFalse: [ - "Drawing was done to off-Display canvas. Copy content to Display" - canvas showAt: world viewBox origin invalidRects: allDamage ]. - - "Display deferUpdates: false." - "Display forceDisplayUpdate" - Display forceDamageToScreen: allDamage. - - "Restore world canvas under hands and their carried morphs" - handsToDraw do: [ :h | h restoreSavedPatchOn: canvas ].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4271-Morphic-VG-JuanVuletich-2020Jul21-10h41m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4268] on 22 July 2020 at 10:20:30 am'! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 7/21/2020 11:21:47' overrides: 50501539! - textComposition: aTextComposition bounds: boundsRect color: c selectionColor: sc - engine ifNil: [ ^nil ]. - -^super textComposition: aTextComposition bounds: boundsRect color: c selectionColor: sc! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 7/21/2020 11:47:47' overrides: 50531361! - clippingByCurrentMorphDo: aBlock -"si clippeamos, tenemos un problemon. -queremos bounds no afectados por el clipping debido a los rectangles a repara -pero si por el owner. OJO!! -Creo que lo que habria que hacer es en #displayBounds:, si clippingMorph no es nil, pedirle sus displayBounds y hacer interseccion. -Y aca, ejecutar normalmente" -" engine ifNil: [ ^self ]." - ^super clippingByCurrentMorphDo: aBlock! ! -!BitBltCanvas methodsFor: 'drawing' stamp: 'jmv 7/21/2020 11:25:28' prior: 50494700 overrides: 50463409! - line: pt1 to: pt2 width: wp color: c - | p1 p2 w | - - engine ifNil: [ ^nil ]. - - (wp > 0 and: [ c isTransparent not ]) ifTrue: [ - p1 _ (currentTransformation transform: pt1) rounded. - p2 _ (currentTransformation transform: pt2) rounded. - w _ currentTransformation externalizeScalar: wp. - self setPaintColor: c. - engine - width: w; - height: w; - drawFrom: p1 to: p2 ]! ! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 7/21/2020 11:24:36' prior: 16786569 overrides: 50463419! - image: aForm at: aPoint - "Draw a translucent image using the best available way of representing translucency." - - - engine ifNil: [ ^nil ]. - - self image: aForm - at: aPoint - sourceRect: aForm boundingBox! ! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 7/21/2020 11:24:40' prior: 50494714 overrides: 50463424! - image: aForm at: aPoint sourceRect: sourceRect - "Draw a translucent image using the best available way of representing translucency. - Note: This will be fixed in the future." - | r p | - - engine ifNil: [ ^nil ]. - - p _ (currentTransformation transform: aPoint) rounded. - r _ (self depth < 32 or: [ aForm mightBeTranslucent not ]) - ifTrue: [ - "Rule Form paint treats pixels with a value of zero as transparent" - Form paint ] - ifFalse: [ Form blend ]. - engine colorMap: (aForm colormapIfNeededFor: form); fillColor: nil. - engine image: aForm at: p sourceRect: sourceRect rule: r. - (self depth = 32 and: [ aForm depth < 32 ]) ifTrue: [ - "If we blit to 32bpp from one of smaller depth, - it will have zero in the alpha channel (until BitBlt is fixed!!) - This is the same workaround as in #asFormOfDepth:" - engine sourceForm: nil. - engine combinationRule: 40. "fixAlpha:with:" - engine copyBits ]! ! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 7/21/2020 11:24:43' prior: 16786616 overrides: 50463434! - stencil: stencilForm at: aPoint color: aColor - "Flood this canvas with aColor wherever stencilForm has non-zero pixels - - Display getCanvas stencil: (Form makeStar asFormOfDepth: 1) at: 20@20 color: Color red. Display forceToScreen - " - - engine ifNil: [ ^nil ]. - - ^self stencil: stencilForm - at: aPoint - sourceRect: stencilForm boundingBox - color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 7/21/2020 11:24:47' prior: 50494745 overrides: 50463439! - stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor - "Flood this canvas with aColor wherever stencilForm has non-zero pixels" - | p | - - engine ifNil: [ ^nil ]. - - p _ (currentTransformation transform: aPoint) rounded. - self setPaintColor: aColor. - engine colorMap: stencilForm maskingMap. - engine stencil: stencilForm - at: p - sourceRect: sourceRect! ! -!BitBltCanvas methodsFor: 'drawing-ovals' stamp: 'jmv 7/21/2020 11:24:27' prior: 50494759 overrides: 50463445! -ellipseCenterX: mcx y: mcy rx: mrx ry: mry borderWidth: mbw borderColor: mbc fillColor: morphFillColor - - | displayRectangle doBorder doFill | - - engine ifNil: [ ^nil ]. - - doBorder _ mbw > 0 and: [ mbc isTransparent not]. - doFill _ morphFillColor isTransparent not. - doBorder | doFill ifTrue: [ - displayRectangle _ (currentTransformation externalizeRectangle: (Rectangle center: mcx@mcy extent: mrx@mry * 2)) rounded. - "draw the border of the oval" - doBorder ifTrue: [ - self setPaintColor: mbc. - engine frameOval: displayRectangle borderWidth: mbw]. - "fill the inside" - doFill ifTrue: [ - self setPaintColor: morphFillColor. - engine fillOval: (displayRectangle insetBy: mbw) ]]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 7/21/2020 11:23:50' prior: 50388629 overrides: 50463452! - fillRectangle: aRectangle color: aColor - "Fill the given rectangle." - - - engine ifNil: [ ^nil ]. - - aColor isTransparent ifFalse: [ - self - frameAndFillRectangle: aRectangle - fillColor: aColor - borderWidth: 0 - borderColor: `Color transparent` ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 7/21/2020 11:23:54' prior: 16786676 overrides: 50463457! - fillRectangle: aRectangle color: aColor borderWidth: borderWidth borderStyleSymbol: aSymbol baseColorForBorder: baseColorForBorder - - - engine ifNil: [ ^nil ]. - - self fillRectangle: (aRectangle insetBy: borderWidth) color: aColor. - self frameRectangle: aRectangle color: baseColorForBorder borderWidth: borderWidth borderStyleSymbol: aSymbol! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 7/21/2020 11:23:59' prior: 16786689 overrides: 50463465! - fillRectangle: aRectangle tilingWith: aForm multipliedBy: aColor - "Fill aRectangle with the equivalent of aForm multiplied by aColor - aForm is a kind of advanced stencil, supplying brightness and opacity at each pixel - Similar to #image:multipliedBy:at: - - - Display getCanvas fillRectangle: (10@10 extent: 100@100) tilingWith: (BitBltCanvas verticalGrayGradient: 30 gradientTop: 0.8 gradientBottom: 0.5) multipliedBy: Color red. Display forceToScreen. - " - - - engine ifNil: [ ^nil ]. - - self class accessProtect critical: [ - self buildAuxWith: aForm multipliedWith: aColor. - "Warning: aForm boundingBox is most likely different from AuxForm boundingBox!!" - self fillRectangle: aRectangle tilingWith: AuxForm sourceRect: aForm boundingBox rule: Form paint ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 7/21/2020 11:24:04' prior: 50494783 overrides: 50463471! - frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor - | rect bw | - - - engine ifNil: [ ^nil ]. - - r area = 0 ifTrue: [ ^self ]. - rect _ (currentTransformation externalizeRectangle: r) rounded. - bw _ currentTransformation externalizeScalar: borderWidth. - - "draw the border of the rectangle" - borderColor isTransparent ifFalse: [ - self setPaintColor: borderColor. - engine frameRect: rect borderWidth: bw ]. - - "fill the inside" - fillColor isTransparent ifFalse: [ - self setPaintColor: fillColor. - engine fillRect: (rect insetBy: bw) ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 7/21/2020 11:24:08' prior: 50494804 overrides: 50463478! - frameRectangle: r borderWidth: borderWidth color: borderColor - " - Display getCanvas - frameRectangle: (10@10 extent: 300@200) - borderWidth: 20 - color: Color red. - Display forceToScreen - " - | rect bw | - - engine ifNil: [ ^nil ]. - - (borderWidth > 0 and: [ borderColor isTransparent not ]) ifTrue: [ - rect _ (currentTransformation externalizeRectangle: r) rounded. - bw _ currentTransformation externalizeScalar: borderWidth. - self setPaintColor: borderColor. - engine - frameRect: rect - borderWidth: bw ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 7/21/2020 11:24:17' prior: 50459996 overrides: 50463484! - frameRectangle: r color: aColor borderWidth: borderWidth borderStyleSymbol: aSymbol - " - Display getCanvas fillRectangle: (10@10 extent: 300@200) color: Color white. Display forceToScreen. - Display getCanvas - frameRectangle: (10@10 extent: 300@200) - color: Color green - borderWidth: 10 - borderStyleSymbol: #raised. - Display forceToScreen. - " - - | displayRectangle bw | - - engine ifNil: [ ^nil ]. - - bw _ (currentTransformation externalizeScalar: borderWidth) rounded. - aSymbol == #raised ifTrue: [ - displayRectangle _ (currentTransformation externalizeRectangle: r) rounded. - ^ self - frameRectangle: displayRectangle - borderWidth: bw - topLeftColor: aColor quiteWhiter - bottomRightColor: aColor quiteBlacker ]. - - aSymbol == #inset ifTrue: [ - displayRectangle _ (currentTransformation externalizeRectangle: r) rounded. - ^ self - frameRectangle: displayRectangle - borderWidth: bw - topLeftColor: aColor quiteBlacker - bottomRightColor: aColor quiteWhiter ]. - - "Unrecognized border style. Draw some border..." - self frameRectangle: r borderWidth: bw color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 7/21/2020 11:24:21' prior: 50494823 overrides: 50463491! - reverseRectangleBorder: r borderWidth: borderWidth - " - Display getCanvas - reverseRectangleBorder: (10@10 extent: 300@200) - borderWidth: 20. - Display forceToScreen - " - | rect | - - engine ifNil: [ ^nil ]. - - rect _ (currentTransformation externalizeRectangle: r) rounded. - engine - sourceForm: nil; - fillColor: `Color gray`; - combinationRule: Form reverse; - frameRect: rect borderWidth: borderWidth! ! -!BitBltCanvas methodsFor: 'drawing-roundedRectangles' stamp: 'jmv 7/21/2020 11:23:29' prior: 16786804 overrides: 50463497! - roundRect: aRectangle color: aColor radius: r - " - Display getCanvas roundRect: (10@10 extent: 200@100) color: Color red radius: 10 - " - - engine ifNil: [ ^nil ]. - - "radious is not scaled properly..." - "top stripe" - self - image: (self class topLeftCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle topLeft. - self - image: (self class topRightCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle topRight - (r@0). - self fillRectangle: ((aRectangle withHeight: r) insetBy: r@0) color: aColor. - - "center stripe" - self fillRectangle: (aRectangle insetBy: (0 @ r corner: 0 @ r)) color: aColor. - - "bottom stripe" - self - image: (self class bottomLeftCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle bottomLeft - (0@r). - self - image: (self class bottomRightCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle bottomRight - (r@r) . - self fillRectangle: ((aRectangle bottomLeft + (r@r negated)) extent: (aRectangle width - r - r@r)) color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-roundedRectangles' stamp: 'jmv 7/21/2020 11:23:34' prior: 16786841 overrides: 50463503! - roundRect: displayRectangle color: aColor radius: r gradientTop: topFactor gradientBottom: bottomFactor gradientHeight: h - " - Display restore. - BitBltCanvas releaseClassCachedState. - Display getCanvas roundRect: (10@10 extent: 200@100) color: Color red radius: 10 gradientTop: 1.0 gradientBottom: 0.5 gradientHeight: 35 - " - | bottomColor | - - engine ifNil: [ ^nil ]. - - "top stripe" - self - image: (self class topLeftCorner: r height: h gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: displayRectangle topLeft. - self - image: (self class topRightCorner: r height: h gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: displayRectangle topRight - (r@0). - self - fillRectangle: ((displayRectangle withHeight: h) insetBy: r@0) - tilingWith: (self class verticalGrayGradient: h gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor. - - bottomColor _ aColor * bottomFactor. - "center stripe" - self fillRectangle: (displayRectangle insetBy: (0 @ h corner: 0 @ r)) color: bottomColor. - - "bottom stripe" - self - image: (self class bottomLeftCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: bottomColor - at: displayRectangle bottomLeft - (0@r). - self - image: (self class bottomRightCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: bottomColor - at: displayRectangle bottomRight - (r@r) . - self fillRectangle: ((displayRectangle bottomLeft + (r@r negated)) extent: (displayRectangle width - r - r@r)) color: bottomColor! ! -!BitBltCanvas methodsFor: 'drawing-roundedRectangles' stamp: 'jmv 7/21/2020 11:23:38' prior: 16786891 overrides: 50463511! -roundRect: aRectangle color: aColor radius: r gradientTop: topFactor gradientCenter: centerFactor gradientBottom: bottomFactor gradient1Height: h1 - " - Display restore. - BitBltCanvas releaseClassCachedState. - Display getCanvas roundRect: (10@10 extent: 200@100) color: Color red radius: 10 gradientTop: 1.0 gradientCenter: 0.0 gradientBottom: 1.0 gradient1Height: 35 - " - | h2 | - - engine ifNil: [ ^nil ]. - - "top stripe" - self - image: (self class topLeftCorner: r height: h1 gradientTop: topFactor gradientBottom: centerFactor) - multipliedBy: aColor - at: aRectangle topLeft. - self - image: (self class topRightCorner: r height: h1 gradientTop: topFactor gradientBottom: centerFactor) - multipliedBy: aColor - at: aRectangle topRight - (r@0). - self - fillRectangle: ((aRectangle withHeight: h1) insetBy: r@0) - tilingWith: (self class verticalGrayGradient: h1 gradientTop: topFactor gradientBottom: centerFactor) - multipliedBy: aColor. - - "bottom stripe" - h2 _ aRectangle height - h1. - self - image: (self class bottomLeftCorner: r height: h2 gradientTop: centerFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: aRectangle topLeft + (0@h1). - self - image: (self class bottomRightCorner: r height: h2 gradientTop: centerFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: aRectangle topRight + (r negated@h1). - self - fillRectangle: ((aRectangle topLeft + (r@h1)) extent: (aRectangle width-r-r@h2)) - tilingWith: (self class verticalGrayGradient: h2 gradientTop: centerFactor gradientBottom: bottomFactor) - multipliedBy: aColor.! ! -!BitBltCanvas methodsFor: 'drawing-roundedRectangles' stamp: 'jmv 7/21/2020 11:23:43' prior: 50376983 overrides: 50463520! - windowFrame: aRectangle color: aColor radius: r border: bw labelHeight: lh gradientTop: topFactor gradientBottom: bottomFactor insideColor: insideColor - " - BitBltCanvas releaseClassCachedState. - Display getCanvas windowFrame: (10@10 extent: 200@100) color: Color red radius: 10 border: 5 labelHeight: 25 gradientTop: 1.0 gradientBottom: 0.5 insideColor: Color green. - Display forceToScreen - " - "top stripe" - | bottomColor he tl tr | - - engine ifNil: [ ^nil ]. - - self - image: (self class topLeftCorner: r height: lh gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: aRectangle topLeft. - self - image: (self class topRightCorner: r height: lh gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: aRectangle topRight - (r@0). - self - fillRectangle: ((aRectangle withHeight: lh) insetBy: r@0) - tilingWith: (self class verticalGrayGradient: lh gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor. - - bottomColor _ aColor * bottomFactor. - - "left and right borders" - tl _ aRectangle topLeft + (0@lh). - tr _ aRectangle topRight + (bw negated@lh). - he _ bw@(aRectangle height - lh - r). - self fillRectangle: (tl extent: he) color: bottomColor. - self fillRectangle: (tr extent: he) color: bottomColor. - - "bottom stripe" - self - image: (self class bottomLeftCorner: r height: r gradientTop: 1 gradientBottom: 1 borderWidth: bw) - multipliedBy: bottomColor - at: aRectangle bottomLeft - (0@r). - self - image: (self class bottomRightCorner: r height: r gradientTop: 1 gradientBottom: 1 borderWidth: bw) - multipliedBy: bottomColor - at: aRectangle bottomRight - (r@r) . - self fillRectangle: ((aRectangle bottomLeft + (r@bw negated)) extent: (aRectangle width - r - r@bw)) color: bottomColor. - - "inside" - self fillRectangle: (aRectangle insetBy: (bw@lh corner: bw@bw)) color: insideColor! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 7/21/2020 11:18:45' prior: 50523138 overrides: 50463529! - drawString: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | p1 font | - engine ifNil: [ ^nil ]. - - "Don't waste any time if NOP" - lastIndex = 0 ifTrue: [ - ^nil ]. - - p1 _ (currentTransformation transform: aPoint rounded) rounded. - engine colorMap: nil. - font _ fontOrNil ifNil: [ FontFamily defaultFamilyAndPointSize ]. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 7/21/2020 11:22:10' prior: 50524879 overrides: 50388601! - drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - | p1 font | - - engine ifNil: [ ^nil ]. - - p1 _ (currentTransformation transform: aPoint rounded) rounded. - engine colorMap: nil. - font _ fontOrNil ifNil: [ FontFamily defaultFamilyAndPointSize ]. - - aColor = `Color black` ifFalse: [ | topColor | - topColor _ aColor alphaMixed: 0.25 with: `Color black`. - font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: topColor ]. - aColor = `Color white` ifFalse: [ | bottomColor | - bottomColor _ aColor alphaMixed: 0.22 with: `Color white`. - font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + `0@2` - color: bottomColor ]. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + `0@1` - color: aColor.! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 7/21/2020 11:28:05' prior: 50495221 overrides: 50501573! - setClipRect: aRectangle - "In targetForm coordinates" - - super setClipRect: aRectangle. - - engine ifNil: [ ^nil ]. - - engine clipRect: aRectangle! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4272-Morphic-VG-JuanVuletich-2020Jul22-10h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4269] on 22 July 2020 at 11:39:02 am'! -!HaloMorph methodsFor: 'geometry testing' stamp: 'jmv 7/22/2020 10:48:50' overrides: 50532186! - submorphsMightProtrude - "Handles and label are usually outside our bounds." - - ^true! ! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 7/21/2020 11:32:17'! - updatingMorphBoundsDo: aBlock - - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/22/2020 11:31:29'! - fullAddRedrawRect: aMorph to: aDamageRecorder - | addMyBounds trySubmorphs | - aMorph visible ifTrue: [ - addMyBounds _ aMorph valueOfProperty: #needsRedraw ifAbsent: [ false ]. - trySubmorphs _ aMorph valueOfProperty: #submorphNeedsRedraw ifAbsent: [ false ]. - (trySubmorphs or: [addMyBounds]) ifTrue: [ - self into: aMorph. - addMyBounds ifTrue: [ - currentMorph setProperty: #needsRedraw toValue: false. - "find bounds. - agregar mi rect" - currentMorph drawOn: self. - world notNil ifTrue: [ -"ATENCION: Este rectangulo deberia tomarse interseccion con el del clipping morph si lo hay. -Registrar el clippingMorph, o al menos su rect, en otra ivar." - aDamageRecorder recordInvalidRect: self boundingRectOfCurrentMorphAfterDraw ]. - ]. - trySubmorphs ifTrue: [ - "llamar recursivo a mis submorphs" - currentMorph setProperty: #submorphNeedsRedraw toValue: false. - currentMorph clippedSubmorph ifNotNil: [ :clipped | - self clippingByCurrentMorphDo: [ self fullAddRedrawRect: clipped to: aDamageRecorder ]]. - currentMorph unclippedSubmorphsReverseDo: [ :m | - self fullAddRedrawRect: m to: aDamageRecorder ] - ]. - self outOfMorph - ]]! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 7/21/2020 11:33:43' overrides: 50533252! - updatingMorphBoundsDo: aBlock - - | prevEngine | - prevEngine _ engine. - [ - engine _ nil. - aBlock value. - ] ensure: [ engine _ prevEngine ]! ! -!Morph methodsFor: 'submorphs-accessing' stamp: 'jmv 7/22/2020 10:49:44' prior: 16876743! - submorphsDrawingOutsideReverseDo: aBlock - "Might be redefined in subclasses that know that its submorphs are never outside itself" - - self submorphsMightProtrude ifTrue: [ - self unclippedSubmorphsReverseDo: aBlock ].! ! -!Morph methodsFor: 'updating' stamp: 'jmv 7/22/2020 11:07:35' prior: 50532393! - isRedrawNeeded - "Report that the area occupied by this morph should be redrawn." -"Creo que es mejor transformarlo en una coleccion. Ver." - - self visible ifFalse: [ ^false ]. - ^ self valueOfProperty: #needsRedraw ifAbsent: [ false ]! ! -!Morph methodsFor: 'updating' stamp: 'jmv 7/22/2020 11:38:50' prior: 50532525! - redrawNeeded - "Report that the area occupied by this morph should be redrawn." - - self flag: #jmvVer2. -"BTW, no method should call #redrawNeeded twice. Just once, before any updates." - "these properties... better store flags in 'id' " - self isRedrawNeeded ifFalse: [ - self setProperty: #needsRedraw toValue: true. - self allOwnersDo: [ :m | m setProperty: #submorphNeedsRedraw toValue: true ]. - self displayFullBounds - ifNil: [ - "Dummy, so #updateIsNeeded answers true if some morph dirty" - "Check if this is really needed. If so, find a cleaner way." - self invalidateDisplayRect: (10@10 extent: 2@2) from: nil ] - ifNotNil: [ :r | - self invalidateDisplayRect: r from: nil ]]. - -"hacer esto en todos los casos? o solo si invalido r?" - self submorphsDrawingOutsideReverseDo: [ :m | m redrawNeeded ]! ! -!HaloMorph methodsFor: 'event handling' stamp: 'jmv 7/22/2020 11:00:46' prior: 50531518 overrides: 50533325! - redrawNeeded - "Report that the area occupied by this morph should be redrawn." -"No debería alcanzar?" -true not ifTrue: [ ^super redrawNeeded ]. - self - invalidateDisplayRect: - ((self morphBoundsInWorld - outsetBy: self class handleSize*2) - extendBy: 0@(FontFamily defaultLineSpacing+self class handleSize)) - from: nil. - "Label could be wider than us..." - self submorphsDrawingOutsideReverseDo: [ :m | m redrawNeeded ]! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/22/2020 11:22:38' prior: 50532354! - drawCurrentAndSubmorphs - - self isCurrentMorphVisible ifTrue: [ - currentMorph drawOn: self. - world notNil ifTrue: [ - currentMorph displayBounds: self boundingRectOfCurrentMorphAfterDraw ]. - "Display submorphs back to front" - "coordinate system stack already set up for aMorph - ('ivars transformations' and 'currentTransformation')" - currentMorph clippedSubmorph ifNotNil: [ :clipped | - self clippingByCurrentMorphDo: [ self fullDraw: clipped ]]. - currentMorph unclippedSubmorphsReverseDo: [ :m | - self fullDraw: m ]].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/22/2020 11:36:38' prior: 50532448! - drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rectsToRepair previousRectsToRepair reuse previousCount morphBounds | - -false -ifFalse: [ -"Add dirty rectangles for all dirty morphs" -aPasteUpMorph allMorphsDo: [ :morph | - morph isRedrawNeeded ifTrue: [ - morph setProperty: #needsRedraw toValue: false. - morph displayFullBounds ifNotNil: [ :r | - aDamageRecorder recordInvalidRect: r ]]]. - -"Aca agregar el seoudodibujado para actualizar los bounds que sean necesarios" - -"Add dirty rectangles for all dirty morphs" -aPasteUpMorph allMorphsDo: [ :morph | - morph isRedrawNeeded ifTrue: [ - morph displayFullBounds ifNotNil: [ :r | - aDamageRecorder recordInvalidRect: r ]]]. -] -ifTrue: [ -"quizas llamarlo #findBoundsDo: o algo asi" - self updatingMorphBoundsDo: [ - aPasteUpMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - ]. -]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ aDamageRecorder invalidRectsFullBounds: aPasteUpMorph viewBox. - - rectsToRepair size > 1 ifTrue: [ "Or there is no point in attempting to merge them!!" - previousRectsToRepair _ OrderedCollection new. - - "Until no more rectangles are merged, i.e. each morph intersects at most one rectangle." - previousCount _ 0. - [rectsToRepair size = previousCount] whileFalse: [ - previousCount _ rectsToRepair size. - aPasteUpMorph submorphsReverseDo: [ :morph | | thisMorphRectangle thisMorphBounds | - morph visible ifTrue: [ - reuse _ previousRectsToRepair. - previousRectsToRepair _ rectsToRepair. - rectsToRepair _ reuse removeAll. - thisMorphRectangle _ nil. - thisMorphBounds _ morph morphFullBoundsInWorld. - previousRectsToRepair do: [ :r | - (thisMorphBounds intersects: r) - ifTrue: [ thisMorphRectangle _ r quickMerge: thisMorphRectangle ] - ifFalse: [ rectsToRepair add: r ]]. - thisMorphRectangle - ifNotNil: [rectsToRepair add: thisMorphRectangle]]]]. - ]. - - "Draw World" - rectsToRepair do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - "Draw morphs" - aPasteUpMorph submorphsReverseDo: [ :morph | - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - rectsToRepair do: [ :r | - (morphBounds intersects: r) ifTrue: [ - (self newClipRect: r) fullDraw: morph ]]]]. - - ^ rectsToRepair! ! - -MorphicCanvas removeSelector: #fullAddRectsToRepair:! - -SystemWindow removeSelector: #submorphsDrawingOutsideReverseDo:! - -!methodRemoval: SystemWindow #submorphsDrawingOutsideReverseDo: stamp: 'Install-4273-Morphic-VG-JuanVuletich-2020Jul22-10h48m-jmv.004.cs.st 8/5/2020 22:21:35'! -submorphsDrawingOutsideReverseDo: aBlock - "All our submorphs are inside us"! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4273-Morphic-VG-JuanVuletich-2020Jul22-10h48m-jmv.004.cs.st----! - -'From Cuis 5.0 [latest update: #4270] on 22 July 2020 at 11:47:36 am'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/22/2020 11:44:39' prior: 50533391! - drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rectsToRepair previousRectsToRepair reuse previousCount morphBounds | - -"quizas llamarlo #findBoundsDo: o algo asi" - self updatingMorphBoundsDo: [ - aPasteUpMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ aDamageRecorder invalidRectsFullBounds: aPasteUpMorph viewBox. - - rectsToRepair size > 1 ifTrue: [ "Or there is no point in attempting to merge them!!" - previousRectsToRepair _ OrderedCollection new. - - "Until no more rectangles are merged, i.e. each morph intersects at most one rectangle." - previousCount _ 0. - [rectsToRepair size = previousCount] whileFalse: [ - previousCount _ rectsToRepair size. - aPasteUpMorph submorphsReverseDo: [ :morph | | thisMorphRectangle thisMorphBounds | - morph visible ifTrue: [ - reuse _ previousRectsToRepair. - previousRectsToRepair _ rectsToRepair. - rectsToRepair _ reuse removeAll. - thisMorphRectangle _ nil. - thisMorphBounds _ morph morphFullBoundsInWorld. - previousRectsToRepair do: [ :r | - (thisMorphBounds intersects: r) - ifTrue: [ thisMorphRectangle _ r quickMerge: thisMorphRectangle ] - ifFalse: [ rectsToRepair add: r ]]. - thisMorphRectangle - ifNotNil: [rectsToRepair add: thisMorphRectangle]]]]. - ]. - - "Draw World" - rectsToRepair do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - "Draw morphs" - aPasteUpMorph submorphsReverseDo: [ :morph | - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - rectsToRepair do: [ :r | - (morphBounds intersects: r) ifTrue: [ - (self newClipRect: r) fullDraw: morph ]]]]. - - ^ rectsToRepair! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4274-Morphic-VG-JuanVuletich-2020Jul22-11h43m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4271] on 22 July 2020 at 12:17:10 pm'! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 7/22/2020 12:11:55' overrides: 16875420! - morphFullBoundsInWorld -"Usando los nombres viejos que estoy por hacer pelota. Repasar. -Ahora es displayFullBounds" - | fullBounds | - fullBounds _ self morphBoundsInWorld. - self submorphsFullBoundsInWorld ifNotNil: [ :b | - fullBounds _ b quickMerge: fullBounds ]. - ^fullBounds! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 7/22/2020 11:53:37'! - submorphsFullBoundsInWorld -"Usando los nombres viejos que estoy por hacer pelota. Repasar." - "Current full bounds of submorphs carried by the hand. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around)." - | fullBounds | - submorphs isEmpty ifTrue: [ ^nil ]. - fullBounds _ nil. - (self valueOfProperty:#lastPos) - ifNil: [ "Just once when a new morph (not in the world) is attached to the hand." - self submorphsDo: [ :m | - m morphFullBoundsInWorld ifNotNil: [ :b | - fullBounds _ fullBounds ifNil: [b] ifNotNil: [ fullBounds merge: b ]]]] - ifNotNil: [ :lastPos | "When carrying morphs around." - self submorphsDo: [ :m | - m displayFullBounds ifNotNil: [ :b | - fullBounds _ fullBounds ifNil: [b] ifNotNil: [ fullBounds merge: b ]]]. - fullBounds ifNil: [ ^nil ]. "bueeeenoooo" - fullBounds _ fullBounds translatedBy: self morphPosition-lastPos ]. - ^fullBounds! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 7/13/2020 09:50:36' prior: 16851618! - fullDrawHandOn: aCanvas - "A HandMorph has an unusual drawing requirement: - The hand itself (i.e., the cursor) appears in front of its submorphs - The illusion is that the hand plucks up morphs and carries them above the world." - - submorphs reverseDo: [ :m | aCanvas fullDraw: m ]. - self drawOn: aCanvas. "draw the hand itself in front of morphs" - self setProperty: #lastPos toValue: (submorphs notEmpty ifTrue: [self morphPosition] ifFalse: [nil])! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 7/22/2020 12:03:21' prior: 50532304 overrides: 50532283! - displayFullBounds -"ver lo que habia hecho. #lastPos, reusar cuando se mueve. -Done. -Por ahora esta en #morphFullBoundsInWorld" - ^super displayFullBounds! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 7/13/2020 10:31:49' prior: 16852062! - grabMorph: aMorph delta: delta - "Grab the given morph (i.e., add it to this hand and remove it from its current owner)." - - | formerOwner | - self releaseMouseFocus. "Break focus" - - "Grab the halo if present" - self halo ifNotNil: [ :h | - h target == aMorph ifTrue: [ - self addMorphBack: h position: h morphPositionInWorld - self morphPositionInWorld ]]. - - "Remember previous owner and position, in case the drop is later rejected" - formerOwner _ aMorph owner. - formerOwner ifNotNil: [ - grabMorphData - at: aMorph - put: { formerOwner. aMorph morphPositionInWorld. } ]. - self addMorphBack: aMorph position: delta. - aMorph justGrabbedFrom: formerOwner. - formerOwner ifNotNil: [ - self setProperty: #lastPos toValue: self morphPosition ].! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 7/22/2020 11:56:13' prior: 16852085! - grabMorph: aMorph moveUnderHand: moveUnderHand - "Grab the given morph (i.e., add it to this hand and remove it from its current owner). - If moveUnderHand is requested or it seems neccesary anyway, move the grabbed morph under the hand." - - | grabbed delta | - "#aboutToGrab: and #aboutToBeGrabbedBy: might mess wildly with our morphs. - If we need it, prepare delta before that happens" - moveUnderHand ifFalse: [ - delta _ aMorph morphPositionInWorld - self morphPositionInWorld ]. - self releaseMouseFocus. "Break focus" - grabbed _ aMorph. - aMorph owner ifNotNil: [ :o | - grabbed _ o aboutToGrab: aMorph ]. - grabbed ifNil: [ ^ self ]. - grabbed _ grabbed aboutToBeGrabbedBy: self. - grabbed ifNil: [ ^ self ]. - (moveUnderHand or: [ (grabbed == aMorph) not ]) - ifTrue: [ - grabbed displayBounds ifNotNil: [ :r | - delta _ (r extent // 2) negated ]]. - ^ self - grabMorph: grabbed - delta: delta! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4275-Morphic-VG-JuanVuletich-2020Jul22-12h16m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4272] on 22 July 2020 at 2:05:09 pm'! -!DisplayScreen methodsFor: 'displaying' stamp: 'jmv 7/22/2020 12:38:36' prior: 16835146! - forceDamageToScreen: allDamage - "Force all the damage rects to the screen." - - "allDamage do: [ :r | - self forceToScreen: r ]." - "Do it at once. Otherwise, some flicking with 'broken' morphs was visible." - (Rectangle merging: allDamage) ifNotNil: [ :r | - self forceToScreen: r ]! ! -!WorldState methodsFor: 'hands' stamp: 'jmv 7/22/2020 12:42:15' prior: 16945757! - selectHandsToDrawForDamage: damageList - "Select the set of hands that must be redrawn because either (a) the hand itself has changed or (b) the hand intersects some damage rectangle." - - | result | - result _ OrderedCollection new. - hands do: [:hand | - hand needsToBeDrawn ifTrue: [ - hand hasChanged - ifTrue: [result add: hand] - ifFalse: [ - hand morphFullBoundsInWorld ifNotNil: [ :handBounds | - (damageList anySatisfy: [ :r | r intersects: handBounds]) ifTrue: [ - result add: hand]]]]]. - ^ result -! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/22/2020 12:36:25' prior: 50533492! - drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rectsToRepair previousRectsToRepair reuse previousCount morphBounds | - -"quizas llamarlo #findBoundsDo: o algo asi" - self updatingMorphBoundsDo: [ - aPasteUpMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ aDamageRecorder invalidRectsFullBounds: aPasteUpMorph viewBox. - - rectsToRepair size = 0 ifTrue: [ - ^rectsToRepair]. - - rectsToRepair size > 1 ifTrue: [ "Or there is no point in attempting to merge them!!" - previousRectsToRepair _ OrderedCollection new. - - "Until no more rectangles are merged, i.e. each morph intersects at most one rectangle." - previousCount _ 0. - [rectsToRepair size = previousCount] whileFalse: [ - previousCount _ rectsToRepair size. - aPasteUpMorph submorphsReverseDo: [ :morph | | thisMorphRectangle thisMorphBounds | - morph visible ifTrue: [ - reuse _ previousRectsToRepair. - previousRectsToRepair _ rectsToRepair. - rectsToRepair _ reuse removeAll. - thisMorphRectangle _ nil. - thisMorphBounds _ morph morphFullBoundsInWorld. - previousRectsToRepair do: [ :r | - (thisMorphBounds intersects: r) - ifTrue: [ thisMorphRectangle _ r quickMerge: thisMorphRectangle ] - ifFalse: [ rectsToRepair add: r ]]. - thisMorphRectangle - ifNotNil: [rectsToRepair add: thisMorphRectangle]]]]. - ]. - - "Draw World" - rectsToRepair do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - "Draw morphs" - aPasteUpMorph submorphsReverseDo: [ :morph | - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - rectsToRepair do: [ :r | - (morphBounds intersects: r) ifTrue: [ - (self newClipRect: r) fullDraw: morph ]]]]. - - ^ rectsToRepair! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4276-Morphic-VG-JuanVuletich-2020Jul22-14h03m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4272] on 22 July 2020 at 2:57:43 pm'! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'world form clipRect transformations currentTransformation cti currentMorph drawingMorphStack engine clippingMorphDisplayBounds ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support' stamp: 'Install-4277-Morphic-VG-JuanVuletich-2020Jul22-14h05m-jmv.001.cs.st 8/5/2020 22:21:35'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'world form clipRect transformations currentTransformation cti currentMorph drawingMorphStack engine clippingMorphDisplayBounds' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! -!MorphicCanvas methodsFor: 'accessing' stamp: 'jmv 7/22/2020 14:51:50' prior: 50385863! - newClipRect: aRectangleOrNil - "aRectangle is in world coordinates. - But ivar clipRect is relative to the form, - For example, if we had previously been built like - aCanvas on: someForm over: (100@100 extent 200@100) - then our origin would be -100 @ -100. - Then, a clipRect argument like (120@120 extent: 40@30) would mean affecting - only (20@20 extent: 40@30) in our form" - - self setClipRect: (aRectangleOrNil - ifNil: [ `0@0` corner: form extent ] - ifNotNil: [ aRectangleOrNil translatedBy: self canvasOrigin ]). - clippingMorphDisplayBounds _ nil.! ! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 7/22/2020 14:47:35' prior: 50531361! - clippingByCurrentMorphDo: aBlock - | prevClipRect prevClippingMorphRect | - - prevClipRect _ self clipRect. - prevClippingMorphRect _ clippingMorphDisplayBounds. - "Might use the fact that currentMorph has just been drawn." - clippingMorphDisplayBounds _ self boundingRectOfCurrentMorphAfterDraw. - self setClipRect: (prevClipRect intersect: clippingMorphDisplayBounds). - self clippingMorph: currentMorph. - aBlock ensure: [ - self clippingMorph: nil. - self setClipRect: prevClipRect. - clippingMorphDisplayBounds _ prevClippingMorphRect ]! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/22/2020 14:51:24' prior: 50533731! - drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rectsToRepair previousRectsToRepair reuse previousCount morphBounds | - -"quizas llamarlo #findBoundsDo: o algo asi" - self updatingMorphBoundsDo: [ - aPasteUpMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ aDamageRecorder invalidRectsFullBounds: aPasteUpMorph viewBox. - - rectsToRepair size = 0 ifTrue: [ - ^rectsToRepair]. - - rectsToRepair size > 1 ifTrue: [ "Or there is no point in attempting to merge them!!" - previousRectsToRepair _ OrderedCollection new. - - "Until no more rectangles are merged, i.e. each morph intersects at most one rectangle." - previousCount _ 0. - [rectsToRepair size = previousCount] whileFalse: [ - previousCount _ rectsToRepair size. - aPasteUpMorph submorphsReverseDo: [ :morph | | thisMorphRectangle thisMorphBounds | - morph visible ifTrue: [ - reuse _ previousRectsToRepair. - previousRectsToRepair _ rectsToRepair. - rectsToRepair _ reuse removeAll. - thisMorphRectangle _ nil. - thisMorphBounds _ morph morphFullBoundsInWorld. - previousRectsToRepair do: [ :r | - (thisMorphBounds intersects: r) - ifTrue: [ thisMorphRectangle _ r quickMerge: thisMorphRectangle ] - ifFalse: [ rectsToRepair add: r ]]. - thisMorphRectangle - ifNotNil: [rectsToRepair add: thisMorphRectangle]]]]. - ]. - - "Draw World" - rectsToRepair do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - "Draw morphs" - aPasteUpMorph submorphsReverseDo: [ :morph | - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - rectsToRepair do: [ :r | - (morphBounds intersects: r) ifTrue: [ - (self newClipRect: r) fullDraw: morph ]]]]. - - ^ rectsToRepair! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/22/2020 14:56:35' prior: 50533257! - fullAddRedrawRect: aMorph to: aDamageRecorder - | addMyBounds trySubmorphs | - aMorph visible ifTrue: [ - addMyBounds _ aMorph valueOfProperty: #needsRedraw ifAbsent: [ false ]. - trySubmorphs _ aMorph valueOfProperty: #submorphNeedsRedraw ifAbsent: [ false ]. - (trySubmorphs or: [addMyBounds]) ifTrue: [ - self into: aMorph. - addMyBounds ifTrue: [ - currentMorph setProperty: #needsRedraw toValue: false. - "find bounds. - agregar mi rect" - currentMorph drawOn: self. - world notNil ifTrue: [ - aDamageRecorder recordInvalidRect: self boundingRectOfCurrentMorphAfterDraw ]. - ]. - trySubmorphs ifTrue: [ - "llamar recursivo a mis submorphs" - currentMorph setProperty: #submorphNeedsRedraw toValue: false. - currentMorph clippedSubmorph ifNotNil: [ :clipped | - self clippingByCurrentMorphDo: [ self fullAddRedrawRect: clipped to: aDamageRecorder ]]. - currentMorph unclippedSubmorphsReverseDo: [ :m | - self fullAddRedrawRect: m to: aDamageRecorder ] - ]. - self outOfMorph - ]]! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 7/22/2020 14:55:26' prior: 50531354 overrides: 50532375! - boundingRectOfCurrentMorphAfterDraw - "In targetForm coordinates" - - ^ clippingMorphDisplayBounds - ifNotNil: [ :ownerClips | self boundingRectOfCurrentMorph intersect: ownerClips ] - ifNil: [ self boundingRectOfCurrentMorph ]! ! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'world form clipRect transformations currentTransformation cti currentMorph drawingMorphStack engine clippingMorphDisplayBounds' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support' stamp: 'Install-4277-Morphic-VG-JuanVuletich-2020Jul22-14h05m-jmv.001.cs.st 8/5/2020 22:21:35'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'world form clipRect transformations currentTransformation cti currentMorph drawingMorphStack engine clippingMorphDisplayBounds' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4277-Morphic-VG-JuanVuletich-2020Jul22-14h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4272] on 22 July 2020 at 3:10:31 pm'! -!SystemWindow methodsFor: 'top window' stamp: 'jmv 7/22/2020 15:07:10' prior: 16926823! - activateAndSendTopToBack: aBoolean - "Bring me to the front and make me able to respond to mouse and keyboard" - - | oldTop | - owner - ifNil: [^self "avoid spurious activate when drop in trash"]. - oldTop _ TopWindow. - TopWindow _ self. - - oldTop ifNotNil: [ - aBoolean ifTrue: [ - | bottomWindow | - bottomWindow _ oldTop owner submorphs reverse detect: [:one | one is: #SystemWindow]. - oldTop owner addMorph: oldTop behind: bottomWindow]]. - - owner firstSubmorph == self - ifFalse: [ - "Bring me to the top if not already" - owner addMorphFront: self]. - - "Set keyboard focus" - self world ifNotNil: [ :w | - w activeHand newKeyboardFocus: self submorphToFocusKeyboard ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4278-Morphic-VG-JuanVuletich-2020Jul22-14h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4275] on 22 July 2020 at 3:53:04 pm'! -!Morph methodsFor: 'updating' stamp: 'jmv 7/22/2020 15:51:59' prior: 50533325! - redrawNeeded - "Report that the area occupied by this morph should be redrawn." - - self flag: #jmvVer2. -"BTW, no method should call #redrawNeeded twice. Just once, before any updates." - "these properties... better store flags in 'id' " - self setProperty: #needsRedraw toValue: true. - self allOwnersDo: [ :m | m setProperty: #submorphNeedsRedraw toValue: true ]. - self displayFullBounds - ifNil: [ - "Dummy, so #updateIsNeeded answers true if some morph dirty" - "Check if this is really needed. If so, find a cleaner way." - self invalidateDisplayRect: (10@10 extent: 2@2) from: nil ] - ifNotNil: [ :r | - self invalidateDisplayRect: r from: nil ]. - -"hacer esto en todos los casos? o solo si invalido r?" - self submorphsDrawingOutsideReverseDo: [ :m | m redrawNeeded ]! ! - -Morph removeSelector: #isRedrawNeeded! - -!methodRemoval: Morph #isRedrawNeeded stamp: 'Install-4279-Morphic-VG-JuanVuletich-2020Jul22-15h51m-jmv.001.cs.st 8/5/2020 22:21:35'! -isRedrawNeeded - "Report that the area occupied by this morph should be redrawn." -"Creo que es mejor transformarlo en una coleccion. Ver." - - self visible ifFalse: [ ^false ]. - ^ self valueOfProperty: #needsRedraw ifAbsent: [ false ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4279-Morphic-VG-JuanVuletich-2020Jul22-15h51m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4276] on 22 July 2020 at 8:03:20 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/22/2020 19:06:16' prior: 16875556! - worldBoundsForHalo - "Answer the rectangle to be used as the inner dimension of my halos. - Allow for showing either bounds or fullBounds, and compensate for the optional bounds rectangle." - - ^ Preferences haloEnclosesFullBounds - ifFalse: [ self displayBounds ] - ifTrue: [ self displayFullBounds ]! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/22/2020 19:56:15' prior: 50533371! - drawCurrentAndSubmorphs - - self isCurrentMorphVisible ifTrue: [ - currentMorph drawOn: self. - world notNil ifTrue: [ "Only if we are drawing the world" - currentMorph displayBounds: self boundingRectOfCurrentMorphAfterDraw ]. - "Display submorphs back to front" - "coordinate system stack already set up for aMorph - ('ivars transformations' and 'currentTransformation')" - currentMorph clippedSubmorph ifNotNil: [ :clipped | - self clippingByCurrentMorphDo: [ self fullDraw: clipped ]]. - currentMorph unclippedSubmorphsReverseDo: [ :m | - self fullDraw: m ]].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/22/2020 20:02:11' prior: 50533866! - drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rectsToRepair previousRectsToRepair reuse previousCount | - -"quizas llamarlo #findBoundsDo: o algo asi" - self updatingMorphBoundsDo: [ - aPasteUpMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ aDamageRecorder invalidRectsFullBounds: aPasteUpMorph viewBox. - - rectsToRepair size = 0 ifTrue: [ - ^rectsToRepair]. - - rectsToRepair size > 1 ifTrue: [ "Or there is no point in attempting to merge them!!" - previousRectsToRepair _ OrderedCollection new. - - "Until no more rectangles are merged, i.e. each morph intersects at most one rectangle." - previousCount _ 0. - [rectsToRepair size = previousCount] whileFalse: [ - previousCount _ rectsToRepair size. - aPasteUpMorph submorphsReverseDo: [ :morph | | thisMorphRectangle thisMorphBounds | - morph visible ifTrue: [ - reuse _ previousRectsToRepair. - previousRectsToRepair _ rectsToRepair. - rectsToRepair _ reuse removeAll. - thisMorphRectangle _ nil. - thisMorphBounds _ morph displayFullBounds ifNil: [10@10 extent: 10@10]. - previousRectsToRepair do: [ :r | - (thisMorphBounds intersects: r) - ifTrue: [ thisMorphRectangle _ r quickMerge: thisMorphRectangle ] - ifFalse: [ rectsToRepair add: r ]]. - thisMorphRectangle - ifNotNil: [rectsToRepair add: thisMorphRectangle]]]]. - ]. - - "Draw World" - rectsToRepair do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - "Draw morphs" - aPasteUpMorph submorphsReverseDo: [ :morph | | morphBounds | - morph visible ifTrue: [ - morphBounds _ morph displayFullBounds ifNil: [10@10 extent: 10@10]. - rectsToRepair do: [ :r | - (morphBounds intersects: r) ifTrue: [ - (self newClipRect: r) fullDraw: morph ]]]]. - - ^ rectsToRepair! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/22/2020 19:58:44' prior: 50533933! - fullAddRedrawRect: aMorph to: aDamageRecorder - | addMyBounds trySubmorphs currentMorphBounds | - aMorph visible ifTrue: [ - addMyBounds _ aMorph valueOfProperty: #needsRedraw ifAbsent: [ false ]. - trySubmorphs _ aMorph valueOfProperty: #submorphNeedsRedraw ifAbsent: [ false ]. - (trySubmorphs or: [addMyBounds]) ifTrue: [ - self into: aMorph. - addMyBounds ifTrue: [ - currentMorph setProperty: #needsRedraw toValue: false. - currentMorph drawOn: self. - currentMorphBounds _ self boundingRectOfCurrentMorphAfterDraw. - currentMorph displayBounds: currentMorphBounds. - aDamageRecorder recordInvalidRect: currentMorphBounds. - ]. - trySubmorphs ifTrue: [ - currentMorph setProperty: #submorphNeedsRedraw toValue: false. - currentMorph clippedSubmorph ifNotNil: [ :clipped | - self clippingByCurrentMorphDo: [ self fullAddRedrawRect: clipped to: aDamageRecorder ]]. - currentMorph unclippedSubmorphsReverseDo: [ :m | - self fullAddRedrawRect: m to: aDamageRecorder ] - ]. - self outOfMorph - ]]! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Preferences enable: #logDebuggerStackToFile. -Morph allSubInstancesDo: [ :m | m redrawNeeded ]. -self runningWorld restoreDisplay; displayWorldSafely! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4280-Morphic-VG-JuanVuletich-2020Jul22-19h47m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4276] on 22 July 2020 at 8:45:12 pm'! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 7/22/2020 20:41:16' overrides: 50532255! - displayBounds - ^self morphPosition extent: self morphExtent ! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 7/22/2020 20:12:48'! - submorphsDisplayFullBounds -"Usando los nombres viejos que estoy por hacer pelota. Repasar." - "Current full bounds of submorphs carried by the hand. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around)." - | fullBounds | - submorphs isEmpty ifTrue: [ ^nil ]. - fullBounds _ nil. - (self valueOfProperty: #lastPos) - ifNil: [ "Just once when a new morph (not in the world) is attached to the hand." - self submorphsDo: [ :m | - m displayFullBounds ifNotNil: [ :b | - fullBounds _ fullBounds ifNil: [b] ifNotNil: [ fullBounds merge: b ]]]] - ifNotNil: [ :lastPos | "When carrying morphs around." - self submorphsDo: [ :m | - m displayFullBounds ifNotNil: [ :b | - fullBounds _ fullBounds ifNil: [b] ifNotNil: [ fullBounds merge: b ]]]. - fullBounds ifNil: [ ^nil ]. "bueeeenoooo" - fullBounds _ fullBounds translatedBy: self morphPosition-lastPos ]. - ^fullBounds! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 7/22/2020 20:16:07' prior: 50531730! - savePatchFrom: aCanvas appendDamageTo: aStream - "Save the part of the given canvas under this hand as a Form and return its bounding rectangle." - - "Details: The previously used patch Form is recycled when possible to reduce the burden on storage management." - - | fullBounds | - fullBounds _ self displayFullBounds. - fullBounds ifNil: [ ^self ]. - - fullBounds _ fullBounds intersect: (`0@0` extent: aCanvas extent). - (savedPatch isNil or: [savedPatch extent ~= fullBounds extent]) - ifTrue: [ - "allocate new patch form if needed" - savedPatch _ Form extent: fullBounds extent depth: aCanvas depth ]. - aCanvas - contentsOfArea: fullBounds - into: savedPatch. - savedPatch offset: fullBounds topLeft. - prevFullBounds - ifNil: [ aStream nextPut: fullBounds ] - ifNotNil: [ aStream nextPut: (fullBounds quickMerge: prevFullBounds)]. - prevFullBounds _ fullBounds! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 7/22/2020 20:13:51' prior: 50533626 overrides: 50532283! - displayFullBounds - | fullBounds | - fullBounds _ self displayBounds. - self submorphsDisplayFullBounds ifNotNil: [ :b | - fullBounds _ b quickMerge: fullBounds ]. - ^fullBounds! ! -!WorldState methodsFor: 'hands' stamp: 'jmv 7/22/2020 20:42:49' prior: 50533711! - selectHandsToDrawForDamage: damageList - "Select the set of hands that must be redrawn because either (a) the hand itself has changed or (b) the hand intersects some damage rectangle." - - | result | - result _ OrderedCollection new. - hands do: [:hand | - hand needsToBeDrawn ifTrue: [ - hand hasChanged - ifTrue: [result add: hand] - ifFalse: [ - hand displayFullBounds ifNotNil: [ :handBounds | - (damageList anySatisfy: [ :r | r intersects: handBounds]) ifTrue: [ - result add: hand]]]]]. - ^ result! ! - -HandMorph removeSelector: #morphFullBoundsInWorld! - -!methodRemoval: HandMorph #morphFullBoundsInWorld stamp: 'Install-4281-Morphic-VG-JuanVuletich-2020Jul22-20h03m-jmv.004.cs.st 8/5/2020 22:21:36'! -morphFullBoundsInWorld -"Usando los nombres viejos que estoy por hacer pelota. Repasar. -Ahora es displayFullBounds" - | fullBounds | - fullBounds _ self morphBoundsInWorld. - self submorphsFullBoundsInWorld ifNotNil: [ :b | - fullBounds _ b quickMerge: fullBounds ]. - ^fullBounds! - -HandMorph removeSelector: #submorphsFullBoundsInWorld! - -!methodRemoval: HandMorph #submorphsFullBoundsInWorld stamp: 'Install-4281-Morphic-VG-JuanVuletich-2020Jul22-20h03m-jmv.004.cs.st 8/5/2020 22:21:36'! -submorphsFullBoundsInWorld -"Usando los nombres viejos que estoy por hacer pelota. Repasar." - "Current full bounds of submorphs carried by the hand. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around)." - | fullBounds | - submorphs isEmpty ifTrue: [ ^nil ]. - fullBounds _ nil. - (self valueOfProperty:#lastPos) - ifNil: [ "Just once when a new morph (not in the world) is attached to the hand." - self submorphsDo: [ :m | - m morphFullBoundsInWorld ifNotNil: [ :b | - fullBounds _ fullBounds ifNil: [b] ifNotNil: [ fullBounds merge: b ]]]] - ifNotNil: [ :lastPos | "When carrying morphs around." - self submorphsDo: [ :m | - m displayFullBounds ifNotNil: [ :b | - fullBounds _ fullBounds ifNil: [b] ifNotNil: [ fullBounds merge: b ]]]. - fullBounds ifNil: [ ^nil ]. "bueeeenoooo" - fullBounds _ fullBounds translatedBy: self morphPosition-lastPos ]. - ^fullBounds! - -Morph removeSelector: #morphFullBoundsInWorld! - -!methodRemoval: Morph #morphFullBoundsInWorld stamp: 'Install-4281-Morphic-VG-JuanVuletich-2020Jul22-20h03m-jmv.004.cs.st 8/5/2020 22:21:36'! -morphFullBoundsInWorld - "Morphs should know nothing about absolute coordinates..." - - self flag: #jmvVer2. - self visible ifFalse: [ ^nil ]. - ^self world ifNotNil: [ :w | w canvas displayFullBoundsInWorldOf: self ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4281-Morphic-VG-JuanVuletich-2020Jul22-20h03m-jmv.004.cs.st----! - -'From Cuis 5.0 [latest update: #4278] on 22 July 2020 at 10:57:40 pm'! - -MorphicCanvas removeSelector: #displayFullBoundsInWorldOf:! - -!methodRemoval: MorphicCanvas #displayFullBoundsInWorldOf: stamp: 'Install-4282-Morphic-VG-JuanVuletich-2020Jul22-22h57m-jmv.001.cs.st 8/5/2020 22:21:36'! -displayFullBoundsInWorldOf: aMorph - "Answer a rectangle that completely bounds aMorph and submorphs when drawn - (if the world was to be fully drawn, i.e. only to be used on a Canvas on the full world). - Might be larger than strictly required. See comment at #displayBoundsInWorldOf:" - - | r | - "Think about doing a BoundsFinderCanvas even for Morphic 2" -"borrar?" - self flag: #jmvVer2. - - r _ self displayBoundsInWorldOf: aMorph. - aMorph submorphsDrawingOutsideReverseDo: [ :m | - m visible ifTrue: [ - r _ r quickMerge: (self displayFullBoundsInWorldOf: m) ]]. - - ^r! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4282-Morphic-VG-JuanVuletich-2020Jul22-22h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4278] on 22 July 2020 at 11:05:50 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/22/2020 23:05:38' prior: 50532283! - displayFullBounds - "Answer a rectangle that completely bounds receiver and submorphs when last drawn - (if the world was to be fully drawn, i.e. only to be used on a Canvas on the full world)." - - | answer | - answer _ self displayBounds. - self submorphsDrawingOutsideReverseDo: [ :m | - m displayFullBounds ifNotNil: [ :mb | - answer _ answer ifNil: [ mb ] ifNotNil: [ answer quickMerge: mb ]]]. - ^answer! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/22/2020 20:02:11' prior: 50534120! - drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rectsToRepair previousRectsToRepair reuse previousCount | - -"quizas llamarlo #findBoundsDo: o algo asi" - self updatingMorphBoundsDo: [ - aPasteUpMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ aDamageRecorder invalidRectsFullBounds: aPasteUpMorph viewBox. - - rectsToRepair size = 0 ifTrue: [ - ^rectsToRepair]. - - rectsToRepair size > 1 ifTrue: [ "Or there is no point in attempting to merge them!!" - previousRectsToRepair _ OrderedCollection new. - - "Until no more rectangles are merged, i.e. each morph intersects at most one rectangle." - previousCount _ 0. - [rectsToRepair size = previousCount] whileFalse: [ - previousCount _ rectsToRepair size. - aPasteUpMorph submorphsReverseDo: [ :morph | | thisMorphRectangle thisMorphBounds | - morph visible ifTrue: [ - reuse _ previousRectsToRepair. - previousRectsToRepair _ rectsToRepair. - rectsToRepair _ reuse removeAll. - thisMorphRectangle _ nil. - thisMorphBounds _ morph displayFullBounds ifNil: [10@10 extent: 10@10]. - previousRectsToRepair do: [ :r | - (thisMorphBounds intersects: r) - ifTrue: [ thisMorphRectangle _ r quickMerge: thisMorphRectangle ] - ifFalse: [ rectsToRepair add: r ]]. - thisMorphRectangle - ifNotNil: [rectsToRepair add: thisMorphRectangle]]]]. - ]. - - "Draw World" - rectsToRepair do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - "Draw morphs" - aPasteUpMorph submorphsReverseDo: [ :morph | | morphBounds | - morph visible ifTrue: [ - morphBounds _ morph displayFullBounds ifNil: [10@10 extent: 10@10]. - rectsToRepair do: [ :r | - (morphBounds intersects: r) ifTrue: [ - (self newClipRect: r) fullDraw: morph ]]]]. - - ^ rectsToRepair! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4283-Morphic-VG-JuanVuletich-2020Jul22-22h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4280] on 22 July 2020 at 11:10:21 pm'! -!HandleMorph methodsFor: 'stepping and presenter' stamp: 'jmv 7/22/2020 23:08:01' prior: 16852452 overrides: 16876536! - stepAt: millisecondSinceLast - - pointBlock value: self displayBounds center! ! -!MenuItemMorph methodsFor: 'selecting' stamp: 'jmv 7/22/2020 23:08:37' prior: 50385302! - select - self isSelected: true. - owner activeSubmenu: subMenu. - subMenu ifNotNil: [ - subMenu delete. - subMenu - popUpAdjacentTo: (Array with: self displayBounds topRight + `10@0` - with: self displayBounds topLeft) - from: self. - subMenu selectItem: nil ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4284-Morphic-VG-JuanVuletich-2020Jul22-23h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4280] on 22 July 2020 at 11:17:45 pm'! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 7/22/2020 23:13:46' prior: 50341309! - maximumUsableAreaInWorld: aWorldOrNil - - | allowedArea | - allowedArea _ Display boundingBox. - aWorldOrNil ifNotNil: [ - allowedArea _ allowedArea intersect: aWorldOrNil viewBox. - aWorldOrNil taskbar ifNotNil: [ :tb | - tb displayBounds ifNotNil: [ :r | - allowedArea _ (allowedArea areasOutside: r) first ]]]. - ^allowedArea -! ! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 7/22/2020 23:13:55' prior: 50383246! - strictlyStaggeredInitialFrameFor: aStandardSystemView initialExtent: initialExtent world: aWorld - "This method implements a staggered window placement policy that I (di) like. - Basically it provides for up to 4 windows, staggered from each of the 4 corners. - The windows are staggered so that there will always be a corner visible." - - | allowedArea grid initialFrame otherFrames cornerSel corner delta putativeCorner free maxLevel | - allowedArea := (self maximumUsableAreaInWorld: aWorld) - insetBy: (self scrollBarSetback @ self screenTopSetback extent: `0 @ 0`). - "Number to be staggered at each corner (less on small screens)" - maxLevel := allowedArea area > 300000 ifTrue: [3] ifFalse: [2]. - "Amount by which to stagger (less on small screens)" - grid := allowedArea area > 500000 ifTrue: [40] ifFalse: [20]. - initialFrame := `0 @ 0` extent: initialExtent. - "min: (allowedArea extent - (grid*(maxLevel+1*2) + (grid//2)))) - min: 600@400" - otherFrames := (SystemWindow windowsIn: aWorld satisfying: [ :w | w visible and: [w isCollapsed not]]) - collect: [:w | w displayBounds]. - otherFrames _ otherFrames reject: [ :f | f isNil ]. - 0 to: maxLevel do: [ :level | - 1 to: 4 do: [:ci | - cornerSel := #(#topLeft #topRight #bottomRight #bottomLeft) at: ci. - corner := allowedArea perform: cornerSel. - "The extra grid//2 in delta helps to keep title tabs distinct" - delta := ((maxLevel - level) * grid + (grid // 2)) @ (level * grid). - 1 to: ci - 1 do: [ :i | delta _ delta y negated @ delta x ]. "slow way" - putativeCorner := corner + delta. - free := true. - otherFrames do: [ :w | - free := free & ((w perform: cornerSel) ~= putativeCorner)]. - free - ifTrue: [ - ^(initialFrame aligned: (initialFrame perform: cornerSel) - with: putativeCorner) translatedAndSquishedToBeWithin: allowedArea]]]. - "If all else fails..." - ^(self scrollBarSetback @ self screenTopSetback - extent: initialFrame extent) translatedAndSquishedToBeWithin: allowedArea! ! -!Morph methodsFor: 'macpal' stamp: 'jmv 7/22/2020 23:12:08' prior: 16876092 overrides: 16881798! - flash - - self displayBounds ifNotNil: [ :r | - Display flash: r ]! ! -!Morph methodsFor: 'macpal' stamp: 'jmv 7/22/2020 23:12:24' prior: 50336170! - flashWith: aColor - - self displayBounds ifNotNil: [ :r | Display flash: r with: aColor ]! ! -!Morph methodsFor: 'meta-actions' stamp: 'jmv 7/22/2020 23:13:02' prior: 50460230! - potentialEmbeddingTargets - "Return the potential targets for embedding the receiver" - | myRect myWorld | - owner ifNil:[^#()]. - myWorld := owner world ifNil:[^#()]. - myRect := self displayBounds. - ^myWorld submorphs select: [ :m | - m isReallyVisible - and: [ m isLocked not - and: [(m displayBounds intersects: myRect) - and: [(m ~= self) - and: [(m isKindOf: HaloMorph) not]]]] - ]! ! -!SystemWindow methodsFor: 'menu' stamp: 'jmv 7/22/2020 23:15:08' prior: 16926478! - fullScreen - "Zoom Window to Full World size with possible DeskMargins" - - "SystemWindow fullScreen" - - | left right possibleBounds | - (self hasProperty: #originalBounds) - ifFalse: [ "Expand" - self setProperty: #originalBounds toValue: self displayBounds. - left := right := 0. - possibleBounds := (RealEstateAgent maximumUsableAreaInWorld: self world) - insetBy: (left @ 0 corner: right @ 0). - possibleBounds := possibleBounds insetBy: Theme current fullScreenDeskMargin - ] - ifTrue: [ "Contract" - possibleBounds := self valueOfProperty: #originalBounds. - self removeProperty: #originalBounds. - ]. - self morphPosition: possibleBounds topLeft extent: possibleBounds extent! ! -!SystemWindow methodsFor: 'resize/collapse' stamp: 'jmv 7/22/2020 23:15:18' prior: 16926614! - resize: boundingBox - (self hasProperty: #originalBounds) ifFalse: [ - self setProperty: #originalBounds toValue: self displayBounds]. - self morphPosition: boundingBox origin extent: boundingBox extent! ! -!TranscriptMorph methodsFor: 'drawing' stamp: 'jmv 7/22/2020 23:17:11' prior: 50503698 overrides: 16899205! - drawOn: aCanvas - Transcript - showOnDisplay: true; - displayOn: form in: self morphLocalBounds. - aCanvas image: form at: self morphTopLeft. - Transcript - bounds: self displayBounds; - showOnDisplay: doImmediateUpdates. - self updateWorkspace! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4285-Morphic-VG-JuanVuletich-2020Jul22-23h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4282] on 23 July 2020 at 10:29:47 am'! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'jmv 7/23/2020 10:19:48' overrides: 16875373! - morphBoundsInWorld: newBounds - | oldExtent newExtent | - - "remove senders and implementors" - self flag: #jmvVer2. - - oldExtent _ self morphExtentInWorld. - newExtent _ newBounds extent. - "Moving stuff around is most likely the most common operation. - Optimize it" - oldExtent = newExtent ifTrue: [ - ^self morphPositionInWorld: newBounds topLeft ]. - (oldExtent dotProduct: oldExtent) <= (newExtent dotProduct: newExtent) ifTrue:[ - "We're growing. First move then resize." - self morphPositionInWorld: newBounds topLeft; morphExtent: newExtent. - ] ifFalse: [ - "We're shrinking. First resize then move." - self morphExtent: newExtent; morphPositionInWorld: newBounds topLeft. - ].! ! -!Transcripter methodsFor: 'command line' stamp: 'jmv 7/23/2020 10:04:22' prior: 16938877! - readEvalPrint - | line | - [ #('quit' 'exit' 'done' ) includes: (line _ self request: '>') ] whileFalse: [ - line caseOf: { - [ 'revert' ] -> []. - } - otherwise: [ - self - newLine; - show: - ([ Compiler evaluate: line ] ifError: [ :err :ex | err ]) ]]! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 7/23/2020 10:29:28' prior: 50533661! - grabMorph: aMorph moveUnderHand: moveUnderHand - "Grab the given morph (i.e., add it to this hand and remove it from its current owner). - If moveUnderHand is requested or it seems neccesary anyway, move the grabbed morph under the hand." - - | grabbed delta | - "#aboutToGrab: and #aboutToBeGrabbedBy: might mess wildly with our morphs. - If we need it, prepare delta before that happens" - moveUnderHand ifFalse: [ - delta _ aMorph morphPositionInWorld - self morphPositionInWorld ]. - self releaseMouseFocus. "Break focus" - grabbed _ aMorph. - aMorph owner ifNotNil: [ :o | - grabbed _ o aboutToGrab: aMorph ]. - grabbed ifNil: [ ^ self ]. - grabbed _ grabbed aboutToBeGrabbedBy: self. - grabbed ifNil: [ ^ self ]. - (moveUnderHand or: [ (grabbed == aMorph) not ]) - ifTrue: [ - delta _ (grabbed morphExtent // 2) negated ]. - ^ self - grabMorph: grabbed - delta: delta! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/23/2020 10:20:27' prior: 50530894! - basicBox - | aBox minSide anExtent w hs | - hs _ self class handleSize. - minSide _ 4 * hs. - anExtent _ extent + (hs*2) max: minSide@minSide. - aBox _ Rectangle center: target displayBounds center extent: anExtent. - w _ self world ifNil: [ target world ]. - ^ w - ifNil: - [ aBox ] - ifNotNil: - [ aBox intersect: (w viewBox insetBy: hs@hs) ]! ! - -HaloMorph removeSelector: #redrawNeeded! - -!methodRemoval: HaloMorph #redrawNeeded stamp: 'Install-4286-Morphic-VG-JuanVuletich-2020Jul23-10h02m-jmv.001.cs.st 8/5/2020 22:21:36'! -redrawNeeded - "Report that the area occupied by this morph should be redrawn." -"No debería alcanzar?" -true not ifTrue: [ ^super redrawNeeded ]. - self - invalidateDisplayRect: - ((self morphBoundsInWorld - outsetBy: self class handleSize*2) - extendBy: 0@(FontFamily defaultLineSpacing+self class handleSize)) - from: nil. - "Label could be wider than us..." - self submorphsDrawingOutsideReverseDo: [ :m | m redrawNeeded ]! - -Morph removeSelector: #morphBoundsInWorld:! - -!methodRemoval: Morph #morphBoundsInWorld: stamp: 'Install-4286-Morphic-VG-JuanVuletich-2020Jul23-10h02m-jmv.001.cs.st 8/5/2020 22:21:36'! -morphBoundsInWorld: newBounds - | oldExtent newExtent | - - "remove senders and implementors" - self flag: #jmvVer2. - - oldExtent _ self morphExtentInWorld. - newExtent _ newBounds extent. - "Moving stuff around is most likely the most common operation. - Optimize it" - oldExtent = newExtent ifTrue: [ - ^self morphPositionInWorld: newBounds topLeft ]. - (oldExtent dotProduct: oldExtent) <= (newExtent dotProduct: newExtent) ifTrue:[ - "We're growing. First move then resize." - self morphPositionInWorld: newBounds topLeft; morphExtent: newExtent. - ] ifFalse: [ - "We're shrinking. First resize then move." - self morphExtent: newExtent; morphPositionInWorld: newBounds topLeft. - ].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4286-Morphic-VG-JuanVuletich-2020Jul23-10h02m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4283] on 23 July 2020 at 11:32:30 am'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/23/2020 11:17:01'! - updateDisplayBounds: aMorph - "Update displayBounds for if never set. - Useful for new morph, that are created and attached to the hand." - - aMorph visible ifTrue: [ - aMorph displayBounds ifNil: [ - self into: aMorph. - currentMorph drawOn: self. - currentMorph displayBounds: self boundingRectOfCurrentMorphAfterDraw. - currentMorph clippedSubmorph ifNotNil: [ :clipped | - self clippingByCurrentMorphDo: [ self updateDisplayBounds: clipped ]]. - currentMorph unclippedSubmorphsReverseDo: [ :m | - self updateDisplayBounds: m ]. - self outOfMorph - ]]! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/23/2020 11:26:42'! - updateHandsDisplayBounds: aPasteUpMorph - "Update displayBounds for carried morphs if never set. - Useful for new morph, that are created and attached to the hand." - - aPasteUpMorph handsDo: [ :hand | - self into: hand. - hand submorphsDo: [ :morph | - self updateDisplayBounds: morph ]. - self outOfMorph ]! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/20/2020 17:10:46' prior: 50534445! - displayFullBounds - "Answer a rectangle that completely bounds receiver and submorphs when last drawn - (if the world was to be fully drawn, i.e. only to be used on a Canvas on the full world)." - - | answer | - answer _ self displayBounds. - answer isNil ifTrue: [ ^nil ]. - self submorphsDrawingOutsideReverseDo: [ :m | - answer _ answer quickMerge: m displayFullBounds ]. - ^answer! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 7/23/2020 11:32:11' prior: 50534250! - submorphsDisplayFullBounds - "Current full bounds of submorphs carried by the hand. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around)." - | fullBounds | - submorphs isEmpty ifTrue: [ ^nil ]. - fullBounds _ nil. - (self valueOfProperty: #lastPos) - ifNil: [ "Just once when a new morph (not in the world) is attached to the hand." - self submorphsDo: [ :m | - m displayFullBounds ifNotNil: [ :b | - fullBounds _ fullBounds ifNil: [b] ifNotNil: [ fullBounds merge: b ]]]] - ifNotNil: [ :lastPos | "When carrying morphs around." - self submorphsDo: [ :m | - m displayFullBounds ifNotNil: [ :b | - fullBounds _ fullBounds ifNil: [b] ifNotNil: [ fullBounds merge: b ]]]. - fullBounds _ fullBounds translatedBy: self morphPosition-lastPos ]. - ^fullBounds! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/23/2020 11:26:59' prior: 50534461! -drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rectsToRepair previousRectsToRepair reuse previousCount | - -"quizas llamarlo #findBoundsDo: o algo asi" - self updatingMorphBoundsDo: [ - aPasteUpMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - self updateHandsDisplayBounds: aPasteUpMorph. - ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ aDamageRecorder invalidRectsFullBounds: aPasteUpMorph viewBox. - - rectsToRepair size = 0 ifTrue: [ - ^rectsToRepair]. - - rectsToRepair size > 1 ifTrue: [ "Or there is no point in attempting to merge them!!" - previousRectsToRepair _ OrderedCollection new. - - "Until no more rectangles are merged, i.e. each morph intersects at most one rectangle." - previousCount _ 0. - [rectsToRepair size = previousCount] whileFalse: [ - previousCount _ rectsToRepair size. - aPasteUpMorph submorphsReverseDo: [ :morph | | thisMorphRectangle thisMorphBounds | - morph visible ifTrue: [ - reuse _ previousRectsToRepair. - previousRectsToRepair _ rectsToRepair. - rectsToRepair _ reuse removeAll. - thisMorphRectangle _ nil. - thisMorphBounds _ morph displayFullBounds ifNil: [10@10 extent: 10@10]. - previousRectsToRepair do: [ :r | - (thisMorphBounds intersects: r) - ifTrue: [ thisMorphRectangle _ r quickMerge: thisMorphRectangle ] - ifFalse: [ rectsToRepair add: r ]]. - thisMorphRectangle - ifNotNil: [rectsToRepair add: thisMorphRectangle]]]]. - ]. - - "Draw World" - rectsToRepair do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - "Draw morphs" - aPasteUpMorph submorphsReverseDo: [ :morph | | morphBounds | - morph visible ifTrue: [ - morphBounds _ morph displayFullBounds ifNil: [10@10 extent: 10@10]. - rectsToRepair do: [ :r | - (morphBounds intersects: r) ifTrue: [ - (self newClipRect: r) fullDraw: morph ]]]]. - - ^ rectsToRepair! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4287-Morphic-VG-JuanVuletich-2020Jul23-11h31m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4284] on 23 July 2020 at 11:43:33 am'! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 7/23/2020 11:43:17' prior: 50534314 overrides: 50534890! - displayFullBounds - "Current full bounds of hand and carried submorphs. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around)." - | fullBounds | - fullBounds _ self displayBounds. - self submorphsDo: [ :m | - fullBounds _ fullBounds quickMerge: m displayFullBounds]. - (self valueOfProperty: #lastPos) - ifNotNil: [ :lastPos | "When already carrying morphs around." - fullBounds _ fullBounds translatedBy: self morphPosition-lastPos. - fullBounds _ fullBounds quickMerge: self displayBounds ]. - ^fullBounds! ! - -HandMorph removeSelector: #submorphsDisplayFullBounds! - -!methodRemoval: HandMorph #submorphsDisplayFullBounds stamp: 'Install-4288-Morphic-VG-JuanVuletich-2020Jul23-11h39m-jmv.001.cs.st 8/5/2020 22:21:36'! -submorphsDisplayFullBounds - "Current full bounds of submorphs carried by the hand. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around)." - | fullBounds | - submorphs isEmpty ifTrue: [ ^nil ]. - fullBounds _ nil. - (self valueOfProperty: #lastPos) - ifNil: [ "Just once when a new morph (not in the world) is attached to the hand." - self submorphsDo: [ :m | - m displayFullBounds ifNotNil: [ :b | - fullBounds _ fullBounds ifNil: [b] ifNotNil: [ fullBounds merge: b ]]]] - ifNotNil: [ :lastPos | "When carrying morphs around." - self submorphsDo: [ :m | - m displayFullBounds ifNotNil: [ :b | - fullBounds _ fullBounds ifNil: [b] ifNotNil: [ fullBounds merge: b ]]]. - fullBounds _ fullBounds translatedBy: self morphPosition-lastPos ]. - ^fullBounds! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4288-Morphic-VG-JuanVuletich-2020Jul23-11h39m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4284] on 23 July 2020 at 11:58:52 am'! -!Morph methodsFor: 'change reporting' stamp: 'jmv 7/23/2020 11:56:45' prior: 16874147! - invalidateDisplayRect: damageRect from: aMorph - - | clippedRect b | - - "warning. Senders are using global coordinates. Redesign!!" - "local now!!!!!!!!!!" - self flag: #jmvVer2. "ok?" - - self visible ifFalse: [ ^self]. - - clippedRect _ damageRect. - aMorph ifNotNil: [ - aMorph == self clippedSubmorph - ifTrue: [ - b _ self displayBounds. - b ifNil: [ ^self ]. - clippedRect _ damageRect intersect: b ]]. - owner ifNotNil: [ - owner invalidateDisplayRect: clippedRect from: self ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4289-Morphic-VG-JuanVuletich-2020Jul23-11h43m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4286] on 23 July 2020 at 3:34:20 pm'! -!PasteUpMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 7/23/2020 14:47:46' prior: 16887726! - addMorph: aMorph centeredNear: aPoint - "Add the given morph to this world, attempting to keep its center as close to the given point possible while also keeping the it entirely within the bounds of this world." - - | trialRect delta | - trialRect _ Rectangle center: aPoint extent: aMorph morphExtent. - delta _ trialRect amountToTranslateWithin: self displayBounds. - self addMorph: aMorph. - aMorph morphPositionInWorld: trialRect origin + delta.! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 7/23/2020 15:25:53' prior: 50530797! - popUpAdjacentTo: rightOrLeftPointInWorld from: sourceItem - "Present this menu at the given point under control of the given hand. - Used mostly for submenus." - - | trialRect e | - popUpOwner _ sourceItem. - sourceItem world addMorphFront: self position: rightOrLeftPointInWorld first. - e _ self morphExtent. - trialRect _ rightOrLeftPointInWorld first extent: e. - trialRect right > sourceItem world morphWidth ifTrue: [ - self morphPosition: rightOrLeftPointInWorld second - (e x@0)]. - self fitInWorld.! ! -!MenuMorph methodsFor: 'private' stamp: 'jmv 7/23/2020 15:01:17' prior: 50385017! - fitInWorld - - | delta trialRect | - trialRect _ Rectangle origin: self morphPosition extent: self morphExtent. - delta _ trialRect amountToTranslateWithin: owner displayBounds. - self morphPosition: trialRect origin + delta.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4290-Morphic-VG-JuanVuletich-2020Jul23-15h33m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4286] on 23 July 2020 at 3:43:50 pm'! -!TextDoIt class methodsFor: 'as yet unclassified' stamp: 'jmv 7/23/2020 15:42:42' prior: 16931228! - evalString: str - " - ('Some text. ', - (Text string: '' attribute: (TextDoIt evalString: '123456 print')), - ' more regular text') edit - " - ^ self new evalString: str! ! -!TranscriptMorph methodsFor: 'drawing' stamp: 'jmv 7/23/2020 15:42:02' prior: 50534704 overrides: 16899205! -drawOn: aCanvas - Transcript - showOnDisplay: true; - displayOn: form in: self morphLocalBounds. - aCanvas image: form at: self morphTopLeft. - self displayBounds ifNotNil: [ :r | - Transcript bounds:r ]. - Transcript - showOnDisplay: doImmediateUpdates. - self updateWorkspace! ! -!TextComposition methodsFor: 'editing' stamp: 'jmv 7/23/2020 15:43:30' prior: 16930965! - clickAt: clickPoint - "Give sensitive text a chance to fire. Display flash: (100@100 extent: 100@100)." - | startBlock action target range boxes box t | - action _ false. - startBlock _ self characterBlockAtPoint: clickPoint. - t _ model actualContents. - (t attributesAt: startBlock stringIndex) do: [ :att | - att mayActOnClick ifTrue: [ - (target _ model) ifNil: [ target _ editor morph]. - range _ t rangeOf: att startingAt: startBlock stringIndex. - boxes _ self selectionRectsFrom: (self characterBlockForIndex: range first) - to: (self characterBlockForIndex: range last+1). - box _ boxes detect: [ :each | each containsPoint: clickPoint] ifNone: nil. - box ifNotNil: [ - box _ editor morph displayBounds. - editor morph allOwnersDo: [ :m | box _ box intersect: (m displayBounds) ]. - Utilities - awaitMouseUpIn: box - repeating: nil - ifSucceed: [(att actOnClickFor: target in: self at: clickPoint editor: editor) ifTrue: [action _ true]]. - ]]]. - ^ action! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4291-Morphic-VG-JuanVuletich-2020Jul23-15h34m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4288] on 23 July 2020 at 3:48:31 pm'! -!LayoutAdjustingMorph methodsFor: 'stepping' stamp: 'jmv 7/23/2020 15:48:18' prior: 50500439 overrides: 16876536! - stepAt: millisecondSinceLast - "got the #mouseLeave: message" - | p | - hand ifNil: [ - Cursor currentCursor == self cursor ifTrue: [ Cursor defaultCursor activateCursor ]. - ^ self stopStepping ]. - "hasn't got the #mouseLeave: message (yet)" - p _ hand morphPosition. - hand lastMouseEvent mouseButton1Pressed - ifTrue: [ - self adjustOwnerAt: p. - (Preferences cheapWindowReframe or: [ millisecondSinceLast > 200]) ifTrue: [ - owner displayBounds newRectFrom: [ :f | - self adjustOwnerAt: Sensor mousePoint. - owner morphPosition extent: owner morphExtent ]]] - ifFalse: [ - self stopStepping. - "If the button was unpressed outside the morph (can happen if you try to go outside container), - we might not get the #mouseLeave: message" - (self morphContainsPoint: (self internalizeFromWorld: p)) ifFalse: [ - hand _ nil. - Cursor defaultCursor activateCursor ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4292-Morphic-VG-JuanVuletich-2020Jul23-15h46m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4288] on 23 July 2020 at 4:05:24 pm'! -!Morph methodsFor: 'drawing' stamp: 'jmv 7/23/2020 16:02:54' prior: 50432325! -visible: aBoolean - "set the 'visible' attribute of the receiver to aBoolean" - - self visible == aBoolean - ifTrue: [ ^ self ]. - self setProperty: #visible toValue: aBoolean. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/23/2020 15:59:54' prior: 50469773! - morphPosition: aPoint - "Change the position of this morph. Argument is in owner's coordinates." - (location isTranslation: aPoint) ifTrue: [ "Null change" - ^ self ]. - location _ location withTranslation: aPoint. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/23/2020 15:58:19' prior: 16875467! - morphPositionInWorld: newPositionInWorld - "Change the position of this morph." - "El tema es, que tipo de coordenadas tenemos? - En un mundo relativista, no hay un marco de referencia absoluto. - No tiene sentido hablar de coordenadas del mundo... El mundo podria estar escalado... - Que tienen de especial las coordenadas del mundo? - Coordenadas 'del hardware'? No deberia saber mucho sobre el... Puede haber multiples displays, hands de diverso tipo, remotas, virtuales... - - En ppio, un par de coordenadas pueden ser relativas a cualquier morph. Pareciera que necesito metodos de conversion de cualquier morph hacia mi, y de mi hacia cualquier morph... Como encontrar un marco de referencia comun???? - Dejar esto para despues. En realidad, para empezar, preciso menos: Solo preciso saber si las coordenadas estan en el morph o en su owner. Nada mas. Los eventos se iran transformando apropiadamente al moverse por el arbol, o al menos, llevaran consigo una transformacion (AffineTransformation) que se ira actualizando" - - | newPositionInOwner | - self flag: #jmvVer2. - "This method MUST die" - - newPositionInOwner _ owner - ifNotNil: [ owner internalizeFromWorld: newPositionInWorld ] - ifNil: [ newPositionInWorld ]. - - (location isTranslation: newPositionInOwner) ifTrue: [ - ^ self ]. "Null change". - - location _ location withTranslation: newPositionInOwner. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/23/2020 16:01:24' prior: 16875527! - rotateBy: radians - "Change the scale of this morph. Argument is an angle." - location _ location rotatedBy: radians. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/23/2020 16:01:33' prior: 16875536! - rotation: radians scale: scale - "Change the scale of this morph. Arguments are an angle and a scale." - location _ location withRotation: radians scale: scale. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/23/2020 16:01:42' prior: 16875547! - scaleBy: scaleFactor - "Change the scale of this morph. Argument is a factor." - location _ location scaledBy: scaleFactor. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'jmv 7/23/2020 16:00:57' prior: 16876922! - removeAllMorphs - | oldMorphs | - submorphs isEmpty ifTrue: [ ^self ]. - submorphs do: [ :m | - m privateOwner: nil ]. - oldMorphs _ submorphs. - submorphs _ #(). - oldMorphs do: [ :m | - self removedMorph: m ]. - self someSubmorphPositionOrExtentChanged. - self redrawNeeded.! ! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'jmv 7/23/2020 16:01:05' prior: 16876933! - removeAllMorphsIn: aCollection - "greatly speeds up the removal of *lots* of submorphs" - | set | - aCollection isEmpty ifTrue: [ ^self ]. - set _ IdentitySet new: aCollection size * 4 // 3. - aCollection do: [ :each | each owner == self ifTrue: [ set add: each ]]. - set isEmpty ifTrue: [ ^self ]. - set do: [ :m | m privateOwner: nil ]. - submorphs _ submorphs reject: [ :each | set includes: each]. - set do: [ :m | self removedMorph: m ]. - self someSubmorphPositionOrExtentChanged. - self redrawNeeded.! ! -!Morph methodsFor: 'updating' stamp: 'jmv 7/23/2020 16:00:42' prior: 50534039! - redrawNeeded - "Report that the area occupied by this morph should be redrawn." - - self flag: #jmvVer2. - "these properties... better store flags in 'id' " - self setProperty: #needsRedraw toValue: true. - self allOwnersDo: [ :m | m setProperty: #submorphNeedsRedraw toValue: true ]. - self displayFullBounds - ifNil: [ - "Dummy, so #updateIsNeeded answers true if some morph dirty" - "Check if this is really needed. If so, find a cleaner way." - self invalidateDisplayRect: (10@10 extent: 2@2) from: nil ] - ifNotNil: [ :r | - self invalidateDisplayRect: r from: nil ]. - - self submorphsDrawingOutsideReverseDo: [ :m | m redrawNeeded ]! ! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'jmv 7/23/2020 15:52:14' prior: 16899221 overrides: 16875404! - morphExtent: newExtent - "assume it is always in our coordinates!!" - - extent = newExtent ifFalse: [ - (self privateExtent: newExtent) ifTrue: [ - self someSubmorphPositionOrExtentChanged. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]]! ! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'jmv 7/23/2020 15:53:07' prior: 50367559! - morphPosition: newPos extent: newExtent - "Change the position of this morph. Argument is in owner's coordinates." - - | someChange | - someChange _ false. - (location isTranslation: newPos) ifFalse: [ - location _ location withTranslation: newPos. - someChange _ true ]. - - extent = newExtent ifFalse: [ - (self privateExtent: newExtent) ifTrue: [ - someChange _ true ]]. - - someChange ifTrue: [ - self someSubmorphPositionOrExtentChanged. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]! ! -!ImageMorph methodsFor: 'accessing' stamp: 'jmv 7/23/2020 15:59:02' prior: 16854113! - image: anImage - | newExtent | - image _ anImage depth = 1 - ifTrue: [ ColorForm mappingWhiteToTransparentFrom: anImage ] - ifFalse: [ anImage ]. - newExtent _ image extent. - extent = newExtent ifFalse: [ - extent _ newExtent. - self someSubmorphPositionOrExtentChanged. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]]. - self redrawNeeded.! ! -!InnerTextMorph methodsFor: 'accessing' stamp: 'jmv 7/23/2020 15:57:32' prior: 16855509! - model: aTextModel wrappedTo: width - "Accept new text contents. Lay it out, wrapping to width. - Then fit my height to the result." - | newExtent | - wrapFlag _ true. - newExtent _ width truncated@extent y. - extent = newExtent ifFalse: [ - extent _ newExtent. - self someSubmorphPositionOrExtentChanged. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]. - self model: aTextModel! ! -!InnerTextMorph methodsFor: 'private' stamp: 'jmv 7/23/2020 15:57:00' prior: 50523083! - fit - "Adjust my bounds to fit the text. - Required after the text changes, - or if wrapFlag is true and the user attempts to change the extent." - - | newExtent newHeight newWidth | - newWidth _ extent x. - "Adjust width only if we don't wrap text to own width!!" - wrapFlag ifFalse: [ - newWidth _ self textComposition usedWidth max: 9 ]. - newHeight _ self textComposition usedHeight max: FontFamily defaultLineSpacing + 2. - newExtent _ newWidth @ newHeight. - extent = newExtent - ifTrue: [ - self redrawNeeded. - "Too conservative: only text composition (because of changes in text or styles, etc) - should cause invalidation. - Try to avoid calling #fit unless needed." - ] - ifFalse: [ - extent = newExtent ifFalse: [ - extent _ newExtent. - self someSubmorphPositionOrExtentChanged. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]]. - - owner innerHeight: newExtent y! ! - -MorphicCanvas removeSelector: #displayBoundsInWorldOf:! - -!methodRemoval: MorphicCanvas #displayBoundsInWorldOf: stamp: 'Install-4293-Morphic-VG-JuanVuletich-2020Jul23-15h48m-jmv.001.cs.st 8/5/2020 22:21:36'! -displayBoundsInWorldOf: aMorph - "Answer a rectangle that completely bounds aMorph when drawn on our form. - Might be larger than strictly required. - - In Morphic 2, this could cause clipping artifacts. This doesn't usually happen because: - a) Morphic 2 doesn't use scaling and rotation - b) Most Morphic 2 morphs have rectangular shape. - - In Morphic 3, clipping also considers the real shape of the owner morph. This avoids those artifacts." -"borrar?" - "Think about doing a BoundsFinderCanvas even for Morphic 2" - self flag: #jmvVer2. - - ^self externalizeDisplayBounds: aMorph morphLocalBounds from: aMorph! - -Morph removeSelector: #morphBoundsInWorld! - -!methodRemoval: Morph #morphBoundsInWorld stamp: 'Install-4293-Morphic-VG-JuanVuletich-2020Jul23-15h48m-jmv.001.cs.st 8/5/2020 22:21:36'! -morphBoundsInWorld - "Morphs should know nothing about absolute coordinates..." - - self flag: #jmvVer2. - self visible ifFalse: [ ^nil ]. - ^self world ifNotNil: [ :w | w canvas ifNotNil: [ :c | c displayBoundsInWorldOf: self ]]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4293-Morphic-VG-JuanVuletich-2020Jul23-15h48m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4288] on 23 July 2020 at 4:08:26 pm'! -!Morph methodsFor: 'change reporting' stamp: 'jmv 7/23/2020 16:08:22' prior: 16874165! - invalidateLocalRect: localRectangle - - self invalidateDisplayRect: (self externalizeDisplayBounds: localRectangle) from: nil! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4294-Morphic-VG-JuanVuletich-2020Jul23-16h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4288] on 24 July 2020 at 10:43:56 am'! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/24/2020 10:21:33'! - displayBoundsForHalo - "Answer the rectangle to be used as the inner dimension of my halos. - Allow for showing either bounds or fullBounds, and compensate for the optional bounds rectangle." - - ^ Preferences haloEnclosesFullBounds - ifFalse: [ self displayBounds ] - ifTrue: [ self displayFullBounds ]! ! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'jmv 7/24/2020 10:22:57' overrides: 16875357! - morphBounds: aRectangle - self morphPosition: aRectangle topLeft. - self morphExtent: aRectangle extent! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 7/24/2020 10:23:24' prior: 16875638! - addHalo: evt - | halo | - halo _ HaloMorph new. - halo popUpFor: self event: evt. - halo morphBounds: self displayBoundsForHalo. - ^halo! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/24/2020 10:43:34' prior: 50385545! - addHandle: handleSpec - "Add a handle within the halo box as per the haloSpec, and set it up to respond to the given event by sending the given selector to the given recipient. Return the handle." - - | handle aPoint colorToUse form icon e | - aPoint _ self - positionIn: haloBox - horizontalPlacement: handleSpec horizontalPlacement - verticalPlacement: handleSpec verticalPlacement. - colorToUse _ Color colorFrom: handleSpec color. - handle _ HaloHandleMorph new color: colorToUse. - self addMorph: handle. - e _ self class handleSize asPoint. - handle morphPosition: aPoint-(e//2) extent: e. - handleSpec iconSymbol ifNotNil: [ :iconName | - form _ self class icons at: iconName ifAbsent: [self class perform: iconName]. - form ifNotNil: [ - icon _ ImageMorph new - image: form; - color: colorToUse makeForegroundColor; - lock. - handle addMorphFront: icon position: `0@0` ]]. - handle mouseUpSelector: #endInteraction. - handle setBalloonText: handleSpec hoverHelp. - ^ handle! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/24/2020 10:23:20' prior: 16850908! - addHandles - - self removeAllMorphs. "remove old handles, if any" - self morphBounds: target displayBoundsForHalo. "update my size" - haloBox _ self basicBox. - target addHandlesTo: self box: haloBox. - self addNameString: (target printStringLimitedTo: 40). - growingOrRotating _ false. - self redrawNeeded! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/24/2020 10:42:30' prior: 50521071! - addNameString: aString - "Add a name display centered beneath the bottom of the outer rectangle. Return the handle." - - | nameMorph verticalNamePosition namePosition nameBackground | - nameBackground _ RectangleLikeMorph new - color: ((target is: #SystemWindow) - ifTrue: [target windowColor] - ifFalse: [`Color lightBlue alpha: 0.9`]). - nameMorph _ StringMorph contents: aString. - nameMorph color: `Color black`. - nameBackground morphExtent: nameMorph morphExtent + 4. - verticalNamePosition _ haloBox bottom + self class handleSize. - namePosition _ haloBox width - nameMorph morphWidth // 2 + haloBox left @ verticalNamePosition. - self addMorph: nameBackground. - nameBackground morphPosition: namePosition - 2. - self addMorph: nameMorph. - nameMorph morphPosition: namePosition. - ^nameMorph! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/24/2020 10:42:12' prior: 50534789! - basicBox - "basicBox is in local coordinates" - | aBox minSide anExtent w hs targetBounds | - hs _ self class handleSize. - minSide _ 4 * hs. - anExtent _ extent + (hs*2) max: minSide@minSide. - targetBounds _ target displayBounds. - aBox _ Rectangle center: targetBounds center extent: anExtent. - w _ self world ifNil: [ target world ]. - aBox _ w - ifNil: - [ aBox ] - ifNotNil: - [ aBox intersect: (w viewBox insetBy: (hs@hs corner: hs@(hs*3))) ]. - ^aBox translatedBy: self morphPosition negated! ! - -RectangleLikeMorph removeSelector: #morphBoundsInWorld:! - -!methodRemoval: RectangleLikeMorph #morphBoundsInWorld: stamp: 'Install-4295-Morphic-VG-JuanVuletich-2020Jul23-16h08m-jmv.001.cs.st 8/5/2020 22:21:36'! -morphBoundsInWorld: newBounds - | oldExtent newExtent | - - "remove senders and implementors" - self flag: #jmvVer2. - - oldExtent _ self morphExtentInWorld. - newExtent _ newBounds extent. - "Moving stuff around is most likely the most common operation. - Optimize it" - oldExtent = newExtent ifTrue: [ - ^self morphPositionInWorld: newBounds topLeft ]. - (oldExtent dotProduct: oldExtent) <= (newExtent dotProduct: newExtent) ifTrue:[ - "We're growing. First move then resize." - self morphPositionInWorld: newBounds topLeft; morphExtent: newExtent. - ] ifFalse: [ - "We're shrinking. First resize then move." - self morphExtent: newExtent; morphPositionInWorld: newBounds topLeft. - ].! - -Morph removeSelector: #worldBoundsForHalo! - -!methodRemoval: Morph #worldBoundsForHalo stamp: 'Install-4295-Morphic-VG-JuanVuletich-2020Jul23-16h08m-jmv.001.cs.st 8/5/2020 22:21:36'! -worldBoundsForHalo - "Answer the rectangle to be used as the inner dimension of my halos. - Allow for showing either bounds or fullBounds, and compensate for the optional bounds rectangle." - - ^ Preferences haloEnclosesFullBounds - ifFalse: [ self displayBounds ] - ifTrue: [ self displayFullBounds ]! - -Morph removeSelector: #morphBounds:! - -!methodRemoval: Morph #morphBounds: stamp: 'Install-4295-Morphic-VG-JuanVuletich-2020Jul23-16h08m-jmv.001.cs.st 8/5/2020 22:21:36'! -morphBounds: aRectangle - self morphPosition: aRectangle topLeft. - self morphExtent: aRectangle extent! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4295-Morphic-VG-JuanVuletich-2020Jul23-16h08m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4292] on 24 July 2020 at 10:57:32 am'! -!MorphicCanvas methodsFor: 'testing' stamp: 'jmv 7/24/2020 10:56:35' prior: 50463635! - isCurrentMorphVisible - "Note: answer true if we are not sure." - | aRectangle myClipRect | - currentMorph visible ifFalse: [ ^false ]. - aRectangle := self boundingRectOfCurrentMorphAfterDraw. - aRectangle ifNil: [ ^true ]. - myClipRect := self clipRect. - aRectangle right < myClipRect left ifTrue: [^ false]. - aRectangle left > myClipRect right ifTrue: [^ false]. - aRectangle bottom < myClipRect top ifTrue: [^ false]. - aRectangle top > myClipRect bottom ifTrue: [^ false]. - ^ true -! ! - -BitBltCanvas removeSelector: #isCurrentMorphVisible! - -!methodRemoval: BitBltCanvas #isCurrentMorphVisible stamp: 'Install-4296-Morphic-VG-JuanVuletich-2020Jul24-10h53m-jmv.001.cs.st 8/5/2020 22:21:36'! -isCurrentMorphVisible - | aRectangle myClipRect | - currentMorph visible ifFalse: [ ^false ]. - aRectangle := self boundingRectOfCurrentMorph. - myClipRect := self clipRect. - aRectangle right < myClipRect left ifTrue: [^ false]. - aRectangle left > myClipRect right ifTrue: [^ false]. - aRectangle bottom < myClipRect top ifTrue: [^ false]. - aRectangle top > myClipRect bottom ifTrue: [^ false]. - ^ true -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4296-Morphic-VG-JuanVuletich-2020Jul24-10h53m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4292] on 24 July 2020 at 11:21:45 am'! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/24/2020 11:16:52' prior: 50532272! - displayBoundsOrBogus - "Never answer nil. A bogus value will trigger a draw operation, and bounds will later be corrected." - ^self displayBounds ifNil: [ - Rectangle center: (self externalizeToWorld: 0@0) extent: 2@2 ]! ! -!Morph methodsFor: 'updating' stamp: 'jmv 7/24/2020 11:17:30' prior: 50535384! - redrawNeeded - "Report that the area occupied by this morph should be redrawn." - - self setProperty: #needsRedraw toValue: true. - self allOwnersDo: [ :m | m setProperty: #submorphNeedsRedraw toValue: true ]. - self invalidateDisplayRect: self displayBoundsOrBogus from: nil. - self submorphsDrawingOutsideReverseDo: [ :m | m redrawNeeded ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4297-Morphic-VG-JuanVuletich-2020Jul24-10h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4292] on 24 July 2020 at 2:15:52 pm'! - -WindowEdgeAdjustingMorph removeSelector: #isOpaqueMorph! - -!methodRemoval: WindowEdgeAdjustingMorph #isOpaqueMorph stamp: 'Install-4298-Morphic-VG-JuanVuletich-2020Jul24-11h21m-jmv.001.cs.st 8/5/2020 22:21:36'! -isOpaqueMorph - "Not really needed, as we also answer false to #isOrthoRectangularMorph" - ^false! - -LayoutAdjustingMorph removeSelector: #isOpaqueMorph! - -!methodRemoval: LayoutAdjustingMorph #isOpaqueMorph stamp: 'Install-4298-Morphic-VG-JuanVuletich-2020Jul24-11h21m-jmv.001.cs.st 8/5/2020 22:21:36'! -isOpaqueMorph - "Any submorph that answers true to #isOrthoRectangularMorph (to optimize #morphContainsPoint:) - but is not an opaque rectangle covering bounds MUST answer false to this message" - color mightBeTranslucent ifTrue: [ - ^false ]. - ^true! - -SystemWindow removeSelector: #isOpaqueMorph! - -!methodRemoval: SystemWindow #isOpaqueMorph stamp: 'Install-4298-Morphic-VG-JuanVuletich-2020Jul24-11h21m-jmv.001.cs.st 8/5/2020 22:21:36'! -isOpaqueMorph - "Not really used, as we also reimplement #addPossiblyUncoveredAreasIn:to:" - ^(Theme current roundWindowCorners or: [ color mightBeTranslucent ]) not! - -BorderedRectMorph removeSelector: #isOpaqueMorph! - -!methodRemoval: BorderedRectMorph #isOpaqueMorph stamp: 'Install-4298-Morphic-VG-JuanVuletich-2020Jul24-11h21m-jmv.001.cs.st 8/5/2020 22:21:36'! -isOpaqueMorph - "Any submorph that answers true to #isOrthoRectangularMorph (to optimize #morphContainsPoint:) - but is not an opaque rectangle covering bounds MUST answer false to this message" - color mightBeTranslucent ifTrue: [ - ^false ]. - borderWidth > 0 ifTrue: [ - borderColor mightBeTranslucent ifTrue: [ - ^false ]]. - ^true! - -Morph removeSelector: #isOpaqueMorph! - -!methodRemoval: Morph #isOpaqueMorph stamp: 'Install-4298-Morphic-VG-JuanVuletich-2020Jul24-11h21m-jmv.001.cs.st 8/5/2020 22:21:36'! -isOpaqueMorph - "Just answer false in the general case, to simplify submorphs. - See the implementation and comment in BorderedMorph. and see also senders. - If the answer is true, there is an optimization in world draw" - ^false! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4298-Morphic-VG-JuanVuletich-2020Jul24-11h21m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4295] on 24 July 2020 at 3:03:15 pm'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/24/2020 15:00:40'! - fullAddCurrentRect: addCurrentBounds submorphs: trySubmorphs to: aDamageRecorder - | currentMorphBounds | - addCurrentBounds ifTrue: [ - currentMorph setProperty: #needsRedraw toValue: false. - currentMorph drawOn: self. - currentMorphBounds _ self boundingRectOfCurrentMorphAfterDraw. - currentMorph displayBounds: currentMorphBounds. - aDamageRecorder recordInvalidRect: currentMorphBounds. - ]. - trySubmorphs ifTrue: [ - currentMorph setProperty: #submorphNeedsRedraw toValue: false. - currentMorph clippedSubmorph ifNotNil: [ :clipped | - self clippingByCurrentMorphDo: [ self fullAddRedrawRect: clipped to: aDamageRecorder ]]. - currentMorph unclippedSubmorphsReverseDo: [ :m | - self fullAddRedrawRect: m to: aDamageRecorder ] - ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/24/2020 15:03:08' prior: 50534189! - fullAddRedrawRect: aMorph to: aDamageRecorder - | addCurrentBounds trySubmorphs | - aMorph visible ifTrue: [ - addCurrentBounds _ aMorph valueOfProperty: #needsRedraw ifAbsent: [ false ]. - trySubmorphs _ aMorph valueOfProperty: #submorphNeedsRedraw ifAbsent: [ false ]. - (trySubmorphs or: [addCurrentBounds]) ifTrue: [ - self into: aMorph. - self canvasToUse - fullAddCurrentRect: addCurrentBounds - submorphs: trySubmorphs - to: aDamageRecorder. - self outOfMorph - ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4299-Morphic-VG-JuanVuletich-2020Jul24-15h00m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4296] on 25 July 2020 at 9:31:11 am'! -!DamageRecorder methodsFor: 'recording' stamp: 'jmv 7/25/2020 09:07:22' prior: 50531807! - invalidRectsFullBounds: aRectangle - "Return a collection of damaged rectangles for the given canvas. - If a total repaint has been requested, return the given rectangle. - Forget about all damage." - | answer | - answer _ totalRepaint ifTrue: [ Array with: aRectangle ]. - self pvtAccessProtect critical: [ - answer ifNil: [ - answer _ OrderedCollection new. - invalidRects do: [ :r | - r ifNotNil: [ - (aRectangle containsRect: r) - ifTrue: [ answer add: r ] - ifFalse: [ answer add: (r intersect: aRectangle) ]. - ]]]. - self pvtReset ]. - ^ answer.! ! -!MorphicCanvas methodsFor: 'testing' stamp: 'jmv 7/25/2020 08:58:56' prior: 50535740! - isCurrentMorphVisible - "Note: answer true if we are not sure." - | aRectangle myClipRect | - currentMorph visible ifFalse: [ ^false ]. - aRectangle := currentMorph displayBounds. - aRectangle ifNil: [ ^true ]. - myClipRect := self clipRect. - aRectangle right < myClipRect left ifTrue: [^ false]. - aRectangle left > myClipRect right ifTrue: [^ false]. - aRectangle bottom < myClipRect top ifTrue: [^ false]. - aRectangle top > myClipRect bottom ifTrue: [^ false]. - ^ true -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4300-Morphic-VG-JuanVuletich-2020Jul25-09h25m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4297] on 25 July 2020 at 3:14:40 pm'! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 7/25/2020 15:10:59' prior: 50534576! - strictlyStaggeredInitialFrameFor: aStandardSystemView initialExtent: initialExtent world: aWorld - "This method implements a staggered window placement policy that I (di) like. - Basically it provides for up to 4 windows, staggered from each of the 4 corners. - The windows are staggered so that there will always be a corner visible." - - | allowedArea grid initialFrame otherFrames cornerSel corner delta putativeCorner free maxLevel | - allowedArea := (self maximumUsableAreaInWorld: aWorld) - insetBy: (self scrollBarSetback @ self screenTopSetback extent: `0 @ 0`). - "Number to be staggered at each corner (less on small screens)" - maxLevel := allowedArea area > 300000 ifTrue: [3] ifFalse: [2]. - "Amount by which to stagger (less on small screens)" - grid := allowedArea area > 500000 ifTrue: [40] ifFalse: [20]. - initialFrame := `0 @ 0` extent: initialExtent. - "min: (allowedArea extent - (grid*(maxLevel+1*2) + (grid//2)))) - min: 600@400" - otherFrames := (SystemWindow windowsIn: aWorld satisfying: [ :w | w visible and: [w isCollapsed not]]) - collect: [:w | w displayBounds]. - otherFrames _ otherFrames reject: [ :f | f isNil ]. - 0 to: maxLevel do: [ :level | - 1 to: 4 do: [ :ci | - cornerSel := #(#topLeft #topRight #bottomRight #bottomLeft) at: ci. - corner := allowedArea perform: cornerSel. - "The extra grid//2 in delta helps to keep title tabs distinct" - delta := ((maxLevel - level) * grid + (grid // 2)) @ (level * grid). - 1 to: ci - 1 do: [ :i | delta _ delta y negated @ delta x ]. "slow way" - putativeCorner := corner + delta. - free := true. - otherFrames do: [ :w | - free := free & ((w perform: cornerSel) ~= putativeCorner)]. - free - ifTrue: [ - ^(initialFrame aligned: (initialFrame perform: cornerSel) - with: putativeCorner) translatedAndSquishedToBeWithin: allowedArea]]]. - "If all else fails..." - ^(self scrollBarSetback @ self screenTopSetback - extent: initialFrame extent) translatedAndSquishedToBeWithin: allowedArea! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/25/2020 15:09:48' prior: 50532262! - displayBounds: aRectangle - - self displayBounds ~= aRectangle ifTrue: [ - self setProperty: #displayBounds toValue: aRectangle ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/25/2020 15:06:54' prior: 50534934! -drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rectsToRepair previousRectsToRepair reuse previousCount | - "Update #displayBounds for all dirty morphs (marked as such with #redrawNeeded). - Also add the updated bounds to aDamageRecorder." - self updatingMorphBoundsDo: [ - aPasteUpMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - self updateHandsDisplayBounds: aPasteUpMorph ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ aDamageRecorder invalidRectsFullBounds: aPasteUpMorph viewBox. - - rectsToRepair size = 0 ifTrue: [ - ^rectsToRepair]. - - rectsToRepair size > 1 ifTrue: [ "Or there is no point in attempting to merge them!!" - previousRectsToRepair _ OrderedCollection new. - - "Until no more rectangles are merged, i.e. each morph intersects at most one rectangle." - previousCount _ 0. - [rectsToRepair size = previousCount] whileFalse: [ - previousCount _ rectsToRepair size. - aPasteUpMorph submorphsReverseDo: [ :morph | | thisMorphRectangle thisMorphBounds | - morph visible ifTrue: [ - reuse _ previousRectsToRepair. - previousRectsToRepair _ rectsToRepair. - rectsToRepair _ reuse removeAll. - thisMorphRectangle _ nil. - thisMorphBounds _ morph displayFullBounds. - previousRectsToRepair do: [ :r | - (thisMorphBounds intersects: r) - ifTrue: [ thisMorphRectangle _ r quickMerge: thisMorphRectangle ] - ifFalse: [ rectsToRepair add: r ]]. - thisMorphRectangle - ifNotNil: [rectsToRepair add: thisMorphRectangle]]]]. - ]. - - "Draw World" - rectsToRepair do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - "Draw morphs" - aPasteUpMorph submorphsReverseDo: [ :morph | | morphBounds | - morph visible ifTrue: [ - morphBounds _ morph displayFullBounds. - rectsToRepair do: [ :r | - (morphBounds intersects: r) ifTrue: [ - (self newClipRect: r) fullDraw: morph ]]]]. - - ^ rectsToRepair! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 7/25/2020 15:08:35' prior: 50532678 overrides: 50501539! - textComposition: aTextComposition bounds: boundsRect color: c selectionColor: sc - - engine ifNil: [ ^nil ]. - ^super textComposition: aTextComposition bounds: boundsRect color: c selectionColor: sc! ! - -BitBltCanvas removeSelector: #clippingByCurrentMorphDo:! - -!methodRemoval: BitBltCanvas #clippingByCurrentMorphDo: stamp: 'Install-4301-Morphic-VG-JuanVuletich-2020Jul25-15h06m-jmv.001.cs.st 8/5/2020 22:21:36'! -clippingByCurrentMorphDo: aBlock -"si clippeamos, tenemos un problemon. -queremos bounds no afectados por el clipping debido a los rectangles a repara -pero si por el owner. OJO!! -Creo que lo que habria que hacer es en #displayBounds:, si clippingMorph no es nil, pedirle sus displayBounds y hacer interseccion. -Y aca, ejecutar normalmente" -" engine ifNil: [ ^self ]." - ^super clippingByCurrentMorphDo: aBlock! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4301-Morphic-VG-JuanVuletich-2020Jul25-15h06m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4298] on 27 July 2020 at 1:32:21 am'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/27/2020 00:28:46'! - fullUpdateBounds: aMorph - - aMorph visible ifTrue: [ - self into: aMorph. - self canvasToUse fullUpdateCurrentBounds. - self outOfMorph - ]! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/27/2020 00:28:33'! - fullUpdateCurrentBounds - | currentMorphBounds | - currentMorph drawOn: self. - currentMorphBounds _ self boundingRectOfCurrentMorphAfterDraw. - currentMorph displayBounds: currentMorphBounds. - currentMorph submorphsDo: [ :m | - self fullUpdateBounds: m ]! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/27/2020 01:31:46' prior: 50535885! - fullAddCurrentRect: addCurrentBounds submorphs: trySubmorphs to: aDamageRecorder - | currentMorphBounds | - addCurrentBounds ifTrue: [ - currentMorph setProperty: #needsRedraw toValue: false. - currentMorph drawOn: self. - currentMorphBounds _ self boundingRectOfCurrentMorphAfterDraw. - currentMorph displayBounds: currentMorphBounds. - aDamageRecorder recordInvalidRect: currentMorphBounds. - currentMorph submorphsDo: [ :m | self fullUpdateBounds: m ]. - ]. - trySubmorphs ifTrue: [ - currentMorph setProperty: #submorphNeedsRedraw toValue: false. - currentMorph clippedSubmorph ifNotNil: [ :clipped | - self clippingByCurrentMorphDo: [ self fullAddRedrawRect: clipped to: aDamageRecorder ]]. - currentMorph unclippedSubmorphsReverseDo: [ :m | - self fullAddRedrawRect: m to: aDamageRecorder ] - ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4302-Morphic-VG-JuanVuletich-2020Jul27-01h31m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4298] on 26 July 2020 at 7:51:01 pm'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/26/2020 19:46:44'! - restorePatch: savedPatch - "Argument must previously be obtained by calling #savePatch:bounds: - Senders should not assume anything about the returned object, except that it will not be nil." - - self - image: savedPatch - at: savedPatch offset.! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/26/2020 19:45:54'! - savePatch: prevSavedPatch bounds: aRectangle - "Senders don't need to know any details of what is answered, but just store it for further calls, and calls to restorePatch:" - "Details: The previously used patch Form is recycled when possible to reduce the burden on storage management." - | savedPatch bb | - savedPatch _ prevSavedPatch. - (savedPatch isNil or: [savedPatch extent ~= aRectangle extent]) - ifTrue: [ - "allocate new patch form if needed" - savedPatch _ Form extent: aRectangle extent depth: form depth ]. - bb _ BitBlt toForm: savedPatch. - bb sourceForm: form; combinationRule: Form over; - sourceX: aRectangle left; sourceY: aRectangle top; - width: aRectangle width; height: aRectangle height; - copyBits. - savedPatch offset: aRectangle topLeft. - ^savedPatch! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 7/26/2020 19:39:19' prior: 50471093! - restoreSavedPatchOn: aCanvas - "Clear the changed flag and restore the part of the given canvas under this hand from the previously saved patch. If necessary, handle the transition to using the hardware cursor." - hasChanged _ false. - savedPatch ifNotNil: [ - aCanvas restorePatch: savedPatch. - submorphs notEmpty ifTrue: [ ^ self ]. - "Make the transition to using hardware cursor. Clear savedPatch and - report one final damage rectangle to erase the image of the software cursor." - " owner invalidateDisplayRect: (savedPatch offset extent: savedPatch extent) from: nil." - self - invalidateDisplayRect: (self morphPosition extent: extent) - from: nil. - Cursor currentCursor == Cursor defaultCursor ifFalse: [ Cursor defaultCursor activateCursor ]. - "show hardware cursor" - savedPatch _ nil ].! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 7/26/2020 19:44:48' prior: 50534283! - savePatchFrom: aCanvas appendDamageTo: aStream - "Save the part of the given canvas under this hand as a Form and return its bounding rectangle." - - | fullBounds | - fullBounds _ self displayFullBounds ifNil: [ ^self ]. - fullBounds _ fullBounds intersect: (`0@0` extent: aCanvas extent). - savedPatch _ aCanvas savePatch: savedPatch bounds: fullBounds. - prevFullBounds - ifNil: [ aStream nextPut: fullBounds ] - ifNotNil: [ aStream nextPut: (fullBounds quickMerge: prevFullBounds)]. - prevFullBounds _ fullBounds! ! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 7/26/2020 19:40:48' prior: 50532730 overrides: 50463424! - image: aForm at: aPoint sourceRect: sourceRect - "Draw a translucent image using the best available way of representing translucency. - Note: This will be fixed in the future." - | r p | - - engine ifNil: [ ^nil ]. - - p _ (currentTransformation transform: aPoint) rounded. - r _ (form depth < 32 or: [ aForm mightBeTranslucent not ]) - ifTrue: [ - "Rule Form paint treats pixels with a value of zero as transparent" - Form paint ] - ifFalse: [ Form blend ]. - engine colorMap: (aForm colormapIfNeededFor: form); fillColor: nil. - engine image: aForm at: p sourceRect: sourceRect rule: r. - (form depth = 32 and: [ aForm depth < 32 ]) ifTrue: [ - "If we blit to 32bpp from one of smaller depth, - it will have zero in the alpha channel (until BitBlt is fixed!!) - This is the same workaround as in #asFormOfDepth:" - engine sourceForm: nil. - engine combinationRule: 40. "fixAlpha:with:" - engine copyBits ]! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 7/26/2020 19:40:38' prior: 50494938! - setPaintColor: aColor - "Install a new color used for filling." - | paintColor | - paintColor _ aColor ifNil: [ `Color transparent` ]. - (paintColor is: #Color) ifFalse: [ - ^ self error: 'Cannot install color' ]. - - "Okay, so paintColor really *is* a color" - engine sourceForm: nil. - (paintColor isOpaque or: [ form depth < 32]) ifTrue: [ - engine fillColor: paintColor. - engine combinationRule: Form paint. - ^ self ]. - - "BitBlt setup for alpha mapped transfer" - engine fillColor: paintColor. - engine combinationRule: Form blend! ! - -MorphicCanvas removeSelector: #depth! - -!methodRemoval: MorphicCanvas #depth stamp: 'Install-4303-Morphic-VG-JuanVuletich-2020Jul26-19h35m-jmv.001.cs.st 8/5/2020 22:21:36'! -depth - - ^ form depth! - -MorphicCanvas removeSelector: #contentsOfArea:into:! - -!methodRemoval: MorphicCanvas #contentsOfArea:into: stamp: 'Install-4303-Morphic-VG-JuanVuletich-2020Jul26-19h35m-jmv.001.cs.st 8/5/2020 22:21:36'! -contentsOfArea: aRectangle into: aForm - | bb | - bb _ BitBlt toForm: aForm. - bb sourceForm: form; combinationRule: Form over; - sourceX: aRectangle left; sourceY: aRectangle top; - width: aRectangle width; height: aRectangle height; - copyBits. - ^aForm! - -Form removeSelector: #contentsOfArea:into:! - -!methodRemoval: Form #contentsOfArea:into: stamp: 'Install-4303-Morphic-VG-JuanVuletich-2020Jul26-19h35m-jmv.001.cs.st 8/5/2020 22:21:36'! -contentsOfArea: aRect into: newForm - "Return a new form which derives from the portion of the original form delineated by aRect." - ^ newForm copyBits: aRect from: self at: `0@0` - clippingBox: newForm boundingBox rule: Form over! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4303-Morphic-VG-JuanVuletich-2020Jul26-19h35m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4300] on 27 July 2020 at 12:40:53 am'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/26/2020 20:47:43' prior: 50536213! - restorePatch: savedPatch - "Argument must previously be obtained by calling #savePatch:bounds: - Senders should not assume anything about the returned object, except that it will not be nil." - -self flag: #jmvHacks. -"Podriamos usar un BitBlt guardado. Este metodo termina haciendo demasiadas cosas... (innecesarias)" - self - image: savedPatch - at: savedPatch offset.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4304-Morphic-VG-JuanVuletich-2020Jul27-00h40m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4300] on 27 July 2020 at 1:26:06 am'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/27/2020 00:53:40' prior: 50536223! - savePatch: prevSavedPatch bounds: aRectangle - "Senders don't need to know any details of what is answered, but just store it for further calls, and calls to restorePatch:" - "Details: The previously used patch Form is recycled when possible to reduce the burden on storage management." - | savedPatch bb | - savedPatch _ prevSavedPatch. - (savedPatch isNil or: [savedPatch extent ~= aRectangle extent]) - ifTrue: [ - "allocate new patch form if needed" - savedPatch _ Form extent: aRectangle extent depth: form depth ]. - bb _ BitBlt toForm: savedPatch. - bb sourceForm: form; combinationRule: Form over; - sourceX: aRectangle left; sourceY: aRectangle top; - width: aRectangle width; height: aRectangle height; - copyBits. - savedPatch offset: aRectangle topLeft. - ^savedPatch! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/27/2020 01:24:01' prior: 50536054! - drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rectsToRepair previousRectsToRepair reuse previousCount | - "Update #displayBounds for all dirty morphs (marked as such with #redrawNeeded). - Also add the updated bounds to aDamageRecorder." - self updatingMorphBoundsDo: [ - aPasteUpMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - self updateHandsDisplayBounds: aPasteUpMorph ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ aDamageRecorder invalidRectsFullBounds: aPasteUpMorph viewBox. - - rectsToRepair size = 0 ifTrue: [ - ^rectsToRepair]. - - rectsToRepair size > 1 ifTrue: [ "Or there is no point in attempting to merge them!!" - previousRectsToRepair _ OrderedCollection new. - - "Until no more rectangles are merged, i.e. each morph intersects at most one rectangle." - previousCount _ 0. - [rectsToRepair size = previousCount] whileFalse: [ - previousCount _ rectsToRepair size. - aPasteUpMorph submorphsReverseDo: [ :morph | | thisMorphRectangle thisMorphBounds | - morph visible ifTrue: [ - reuse _ previousRectsToRepair. - previousRectsToRepair _ rectsToRepair. - rectsToRepair _ reuse removeAll. - thisMorphRectangle _ nil. - thisMorphBounds _ morph displayFullBounds ifNil: [0@0 extent: 10@10]. - previousRectsToRepair do: [ :r | - (thisMorphBounds intersects: r) - ifTrue: [ thisMorphRectangle _ r quickMerge: thisMorphRectangle ] - ifFalse: [ rectsToRepair add: r ]]. - thisMorphRectangle - ifNotNil: [rectsToRepair add: thisMorphRectangle]]]]. - ]. - - "Draw World" - rectsToRepair do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - "Repair rects. Draw morphs" - rectsToRepair do: [ :r | - self newClipRect: r. - aPasteUpMorph submorphsReverseDo: [ :morph | | morphBounds | - morph visible ifTrue: [ - morphBounds _ morph displayFullBounds ifNil: [0@0 extent: 10@10]. - (morphBounds intersects: r) ifTrue: [ - self fullDraw: morph ]]]]. - - ^ rectsToRepair! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Preferences enable: #logDebuggerStackToFile. -Morph allSubInstancesDo: [ :m | m redrawNeeded ]. -self runningWorld restoreDisplay; displayWorldSafely! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4305-Morphic-VG-JuanVuletich-2020Jul27-00h40m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4302] on 27 July 2020 at 10:25:14 am'! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 7/27/2020 10:22:15' prior: 50532375! - boundingRectOfCurrentMorphAfterDraw - "This rectangle is used for clipping submorphs in BitBltCanvas. - Clipped to owner if appropriate. - In VectorCanvas we support clipping by any shape, not just rectangles. Then, this rectangle is used as an optimization of the area to be redrawn." - - self subclassResponsibility! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 7/27/2020 10:21:41' prior: 50531346! - boundingRectOfCurrentMorph - "In targetForm coordinates. - Answer morph bounds, ignoring possible clipping by owner." - - ^currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 7/27/2020 10:21:10' prior: 50533969 overrides: 50536532! - boundingRectOfCurrentMorphAfterDraw - "In targetForm coordinates. - Clipped to owner if appropriate." - - ^ clippingMorphDisplayBounds - ifNotNil: [ :ownerClips | self boundingRectOfCurrentMorph intersect: ownerClips ] - ifNil: [ self boundingRectOfCurrentMorph ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4306-Morphic-VG-JuanVuletich-2020Jul27-10h19m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4302] on 27 July 2020 at 10:27:08 am'! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'jmv 7/27/2020 10:26:53' prior: 50530871! - goBehind - - owner privateMoveBackMorph: self. -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4307-Morphic-VG-JuanVuletich-2020Jul27-10h25m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4304] on 27 July 2020 at 10:32:55 am'! -!HandMorph methodsFor: 'geometry testing' stamp: 'jmv 7/27/2020 10:31:41' overrides: 50532186! - submorphsMightProtrude - "Morphs we carry are usually larger than us." - - ^true! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4308-Morphic-VG-JuanVuletich-2020Jul27-10h31m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4305] on 27 July 2020 at 1:42:34 pm'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/27/2020 13:17:46'! - updateCurrentDisplayBounds - "Update displayBounds for if never set. - Useful for new morph, that are created and attached to the hand." - - currentMorph drawOn: self. - currentMorph displayBounds: self boundingRectOfCurrentMorphAfterDraw. - currentMorph clippedSubmorph ifNotNil: [ :clipped | - self clippingByCurrentMorphDo: [ self updateDisplayBounds: clipped ]]. - currentMorph unclippedSubmorphsReverseDo: [ :m | - self updateDisplayBounds: m ].! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 7/27/2020 13:24:09' prior: 50534759! - grabMorph: aMorph moveUnderHand: moveUnderHand - "Grab the given morph (i.e., add it to this hand and remove it from its current owner). - If moveUnderHand is requested or it seems neccesary anyway, move the grabbed morph under the hand." - - | grabbed delta | - "#aboutToGrab: and #aboutToBeGrabbedBy: might mess wildly with our morphs. - If we need it, prepare delta before that happens. Use 0@0 if we don't know." - delta _ `0@0`. - moveUnderHand ifFalse: [ - delta _ aMorph morphPositionInWorld - self morphPositionInWorld ]. - self releaseMouseFocus. "Break focus" - grabbed _ aMorph. - aMorph owner ifNotNil: [ :o | - grabbed _ o aboutToGrab: aMorph ]. - grabbed ifNil: [ ^ self ]. - grabbed _ grabbed aboutToBeGrabbedBy: self. - grabbed ifNil: [ ^ self ]. - (moveUnderHand or: [ (grabbed == aMorph) not ]) - ifTrue: [ - grabbed displayBounds ifNotNil: [ :r | - delta _ (r extent // 2) negated ]]. - ^ self - grabMorph: grabbed - delta: delta! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/27/2020 13:18:09' prior: 50534856! - updateDisplayBounds: aMorph - "Update displayBounds for if never set. - Useful for new morph, that are created and attached to the hand." - - aMorph visible ifTrue: [ - aMorph displayBounds ifNil: [ - self into: aMorph. - self canvasToUse updateCurrentDisplayBounds. - self outOfMorph - ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4309-Morphic-VG-JuanVuletich-2020Jul27-13h41m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4306] on 27 July 2020 at 2:48:09 pm'! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'world form clipRect transformations currentTransformation cti currentMorph drawingMorphStack engine clippingMorphDisplayBounds ' - classVariableNames: 'ActiveSubclass ' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support' stamp: 'Install-4310-Morphic-VG-JuanVuletich-2020Jul27-14h44m-jmv.001.cs.st 8/5/2020 22:21:37'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'world form clipRect transformations currentTransformation cti currentMorph drawingMorphStack engine clippingMorphDisplayBounds' - classVariableNames: 'ActiveSubclass' - poolDictionaries: '' - category: 'Morphic-Support'! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 7/27/2020 14:45:07'! - activeSubclass - ActiveSubclass ifNil: [ - ActiveSubclass _ BitBltCanvas ]. - ^ActiveSubclass! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 7/27/2020 13:37:39'! - activeSubclass: aMorphicCanvasSubclass - ActiveSubclass _ aMorphicCanvasSubclass! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 7/27/2020 14:47:45'! - subclassToUse - "If asked to a specific subclass, use that." - - ^ self == MorphicCanvas - ifFalse: [ self ] - ifTrue: [ self activeSubclass ]! ! -!Form methodsFor: 'accessing' stamp: 'jmv 7/27/2020 13:39:10' prior: 16846769! - getCanvas - "Return a Canvas that can be used to draw onto the receiver" - ^MorphicCanvas onForm: self! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 7/27/2020 13:39:07' prior: 50520773! - imageForm: depth - | canvas | - canvas _ MorphicCanvas depth: depth over: (self morphPosition extent: self morphExtent). - canvas fullDraw: self. - ^ canvas form divideByAlpha! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 7/27/2020 13:39:04' prior: 50520781! - imageForm: extent depth: depth - | canvas | - canvas _ MorphicCanvas depth: depth over: (self morphPosition extent: (self morphExtent min: extent)). - canvas fullDraw: self. - ^ canvas form divideByAlpha! ! -!WorldState methodsFor: 'canvas' stamp: 'jmv 7/27/2020 13:39:01' prior: 50337502! - ensureNonDisplayCanvas - (canvas isNil or: [ - canvas drawsOnDisplay or: [ - (canvas extent ~= world morphExtent) or: [ - canvas form depth ~= Display depth]]]) ifTrue: [ - "allocate a new offscreen canvas the size of the window" - self setCanvas: (MorphicCanvas withExtent: world morphExtent depth: Display depth)]! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 7/27/2020 14:47:53' prior: 16877732! - on: aForm over: aRectangle - "Warning: aForm extent must equal aRectangle extent" - - ^ self subclassToUse basicNew - initializeWith: aForm origin: aRectangle topLeft negated! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 7/27/2020 14:47:56' prior: 50385962! - onForm: aForm - - ^ self subclassToUse basicNew - initializeWith: aForm origin: `0@0`! ! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'world form clipRect transformations currentTransformation cti currentMorph drawingMorphStack engine clippingMorphDisplayBounds' - classVariableNames: 'ActiveSubclass' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support' stamp: 'Install-4310-Morphic-VG-JuanVuletich-2020Jul27-14h44m-jmv.001.cs.st 8/5/2020 22:21:37'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'world form clipRect transformations currentTransformation cti currentMorph drawingMorphStack engine clippingMorphDisplayBounds' - classVariableNames: 'ActiveSubclass' - poolDictionaries: '' - category: 'Morphic-Support'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4310-Morphic-VG-JuanVuletich-2020Jul27-14h44m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4307] on 27 July 2020 at 2:54:38 pm'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/27/2020 14:52:25' prior: 50536411! - savePatch: prevSavedPatch bounds: aRectangle - "Senders don't need to know any details of what is answered, but just store it for further calls, and calls to restorePatch:" - "Details: The previously used patch Form is recycled when possible to reduce the burden on storage management." - | savedPatch bb | - savedPatch _ prevSavedPatch. - ((savedPatch is: #Form) not or: [savedPatch extent ~= aRectangle extent]) - ifTrue: [ - "allocate new patch form if needed" - savedPatch _ Form extent: aRectangle extent depth: form depth ]. - bb _ BitBlt toForm: savedPatch. - bb sourceForm: form; combinationRule: Form over; - sourceX: aRectangle left; sourceY: aRectangle top; - width: aRectangle width; height: aRectangle height; - copyBits. - savedPatch offset: aRectangle topLeft. - ^savedPatch! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4311-Morphic-VG-JuanVuletich-2020Jul27-14h52m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4307] on 27 July 2020 at 2:58:50 pm'! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 7/27/2020 14:58:44' prior: 50536696! - activeSubclass: aMorphicCanvasSubclass - ActiveSubclass _ aMorphicCanvasSubclass. - PasteUpMorph allInstancesDo: [ :w | w clearCanvas ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4312-Morphic-VG-JuanVuletich-2020Jul27-14h54m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4309] on 27 July 2020 at 4:05:39 pm'! -!MorphicCanvas methodsFor: 'testing' stamp: 'jmv 7/27/2020 16:03:48' prior: 50535957! - isCurrentMorphVisible - "Note: answer true if we are not sure." - | aRectangle myClipRect | - currentMorph visible ifFalse: [ ^false ]. - aRectangle := currentMorph displayBounds. - aRectangle ifNil: [ ^true ]. - (currentMorph firstOwnerSuchThat: [ :m | m is: #HandMorph ]) notNil ifTrue: [ ^true ]. - myClipRect := self clipRect. - aRectangle right < myClipRect left ifTrue: [^ false]. - aRectangle left > myClipRect right ifTrue: [^ false]. - aRectangle bottom < myClipRect top ifTrue: [^ false]. - aRectangle top > myClipRect bottom ifTrue: [^ false]. - ^ true -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4313-Morphic-VG-JuanVuletich-2020Jul27-16h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4309] on 27 July 2020 at 4:50:50 pm'! - -RectangleLikeMorph subclass: #HaloMorph - instanceVariableNames: 'target positionOffset angleOffset growingOrRotating haloBox scaleOffset ' - classVariableNames: 'HandleSize Icons ' - poolDictionaries: '' - category: 'Morphic-Halos'! - -!classDefinition: #HaloMorph category: #'Morphic-Halos' stamp: 'Install-4314-Morphic-VG-JuanVuletich-2020Jul27-16h05m-jmv.001.cs.st 8/5/2020 22:21:37'! -RectangleLikeMorph subclass: #HaloMorph - instanceVariableNames: 'target positionOffset angleOffset growingOrRotating haloBox scaleOffset' - classVariableNames: 'HandleSize Icons' - poolDictionaries: '' - category: 'Morphic-Halos'! -!Preferences class methodsFor: 'halos' stamp: 'jmv 7/27/2020 16:34:43' prior: 50344316! - iconicHaloSpecifications - "Answer an array that characterizes the locations, colors, icons, and selectors of the halo handles that may be used in the iconic halo scheme" - - " - Preferences resetHaloSpecifications - " - -^ #( - "selector horiz vert color info icon key balloon help - --------- ------ ----------- -------------------------- -------------------------- ---------------" - (addCollapseHandle: left topCenter (tan) haloCollapseIcon 'Collapse') - (addDebugHandle: right topCenter (orange) haloDebugIcon 'Debug') - (addDismissHandle: left top (red) haloDismissIcon 'Remove') - (addRotateHandle: left bottom (blue) haloRotateIcon 'Rotate') - (addMenuHandle: leftCenter top (blue lighter) haloMenuIcon 'Menu') - (addGrabHandle: center top (black) haloGrabIcon 'Pick up') - (addDragHandle: rightCenter top (brown) haloDragIcon 'Move') - (addDupHandle: right top (green) haloDuplicateIcon 'Duplicate') - (addHelpHandle: center bottom (lightBlue) haloHelpIcon 'Help') - (addGrowHandle: right bottom (yellow) haloScaleIcon 'Change size') - (addFontSizeHandle: leftCenter bottom (lightGreen) haloFontSizeIcon 'Change font') - (addFontEmphHandle: rightCenter bottom (lightBrown darker) haloFontEmphasisIcon 'Emphasis & alignment') - "FIXME - Currently non-functional... - (addRecolorHandle: right bottomCenter (magenta darker) haloColorIcon 'Change color') - " -)! ! -!AffineTransformation methodsFor: 'modifying' stamp: 'jmv 7/27/2020 16:24:40' prior: 16778620! - rotatedBy: radians - "rotate the receiver by radians angle. - Answer the modified object. In this implementation is self, but some classes of transformations, - more restricted ones (like MorphicTranslation) could require the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself." - - | s c a11 a12 a21 a22 | - s _ radians sin. - c _ radians cos. - a11 _ self a11. - a12 _ self a12. - a21 _ self a21. - a22 _ self a22. - self a11: (c * a11) - (s * a21). - self a12: (c * a12) - (s * a22). - self a21: (s * a11) + (c * a21). - self a22: (s * a12) + (c * a22). - ^ self! ! -!AffineTransformation methodsFor: 'modifying' stamp: 'jmv 7/27/2020 16:28:09' prior: 16778671! - scaledByNumber: aNumber rotatedBy: radians - "rotate the receiver by radians angle. Also scale by aNumber. - Note: the scale factor is a number, not a point. Therefore, the same scale is applied in all directions. - This means that there is no difference between scaling then rotating and rotating then scaling. - - Answer the modified object. In this implementation is self, but some classes of transformations, - more restricted ones (like MorphicTranslation) could require the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself." - - | s c a11 a12 a21 a22 | - s _ radians sin. - c _ radians cos. - a11 _ self a11 * aNumber. - a12 _ self a12 * aNumber. - a21 _ self a21 * aNumber. - a22 _ self a22 * aNumber. - self a11: (c * a11) - (s * a21). - self a12: (c * a12) - (s * a22). - self a21: (s * a11) + (c * a21). - self a22: (s * a12) + (c * a22). - ^self! ! -!MorphicTranslation methodsFor: 'accessing' stamp: 'jmv 7/27/2020 16:49:10' prior: 16878289! - scale - "Answer the *scalar* scale applied by the receiver. Will not work correctly for shear (skew) transformations, or different scale in x and y. - Will work correctly for scaling (if equal in all directions, i.e. if scale is a scalar), for rotations, translations, and compositions of these." - - ^1.0! ! -!Morph methodsFor: 'as yet unclassified' stamp: 'jmv 7/27/2020 16:37:56' prior: 16874117! - rotationDegrees: degrees - location _ location rotatedBy: degrees degreesToRadians - location radians. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 7/27/2020 16:29:42' prior: 50344369! - wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph - "Answer whether the receiver would like to offer the halo handle with the given selector (e.g. #addCollapseHandle:)" - - (#(addRecolorHandle:) statePointsTo: aSelector) - ifTrue: ["FIXME - hack to disable for non-functional halo items" - ^ false]. - - Preferences selectiveHalos ifFalse: [ - ^true ]. - - (#(#addDismissHandle: ) includes: aSelector) - ifTrue: [ ^ self resistsRemoval not ]. - (#(#addDragHandle: ) includes: aSelector) - ifTrue: [ ^ self okayToBrownDragEasily ]. - (#(#addGrowHandle: ) includes: aSelector) - ifTrue: [ ^ self okayToResizeEasily ]. - (#(#addRotateHandle: ) includes: aSelector) - ifTrue: [ ^ self okayToRotateEasily ]. - (#(#addRecolorHandle: ) includes: aSelector) - ifTrue: [ ^ self wantsRecolorHandle ]. - ^ true! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/27/2020 16:50:25' prior: 50388458! - doRot: evt with: rotHandle - "Update the rotation of my target if it is rotatable. Keep the relevant command object up to date." - - | radians scale | -self revisar. - self flag: #jmvVer2. - evt hand obtainHalo: self. - radians _ (evt eventPosition - target referencePosition) theta. - radians _ radians - angleOffset theta. - "degrees _ degrees detentBy: 10.0 atMultiplesOf: 90.0 snap: false." - radians = 0.0 - ifTrue: [rotHandle color: `Color lightBlue`] - ifFalse: [rotHandle color: `Color blue`]. - rotHandle submorphsDo: - [:m | m color: rotHandle color makeForegroundColor]. - scale _ (evt eventPosition - target referencePosition) rho * scaleOffset. - self removeAllHandlesBut: rotHandle. - target rotation: radians scale: scale. - rotHandle morphPositionInWorld: evt eventPosition - (rotHandle morphExtent // 2)! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/27/2020 16:48:47' prior: 16851166! - startRot: evt with: rotHandle - "Initialize rotation of my target if it is rotatable. Launch a command object to represent the action" - - evt hand obtainHalo: self. "Make sure the event's hand correlates with the receiver" - growingOrRotating _ true. - - self removeAllHandlesBut: rotHandle. "remove all other handles" - angleOffset _ evt eventPosition - target referencePosition. - angleOffset _ Point - r: angleOffset r - degrees: angleOffset degrees - target rotationDegrees. - scaleOffset _ target location scale / (evt eventPosition - target referencePosition) rho. - -! ! - -RectangleLikeMorph subclass: #HaloMorph - instanceVariableNames: 'target positionOffset angleOffset growingOrRotating haloBox scaleOffset' - classVariableNames: 'HandleSize Icons' - poolDictionaries: '' - category: 'Morphic-Halos'! - -!classDefinition: #HaloMorph category: #'Morphic-Halos' stamp: 'Install-4314-Morphic-VG-JuanVuletich-2020Jul27-16h05m-jmv.001.cs.st 8/5/2020 22:21:37'! -RectangleLikeMorph subclass: #HaloMorph - instanceVariableNames: 'target positionOffset angleOffset growingOrRotating haloBox scaleOffset' - classVariableNames: 'HandleSize Icons' - poolDictionaries: '' - category: 'Morphic-Halos'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4314-Morphic-VG-JuanVuletich-2020Jul27-16h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4309] on 27 July 2020 at 5:10:43 pm'! -!Morph methodsFor: 'fileIn/out' stamp: 'jmv 7/27/2020 17:07:00' prior: 16875174 overrides: 16882034! - storeDataOn: aDataStream - "Let all Morphs be written out. All owners are weak references. They only go out if the owner is in the tree being written." - | cntInstVars cntIndexedVars ti instVarNames | - - "block my owner unless he is written out by someone else" - cntInstVars _ self class instSize. - cntIndexedVars _ self basicSize. - instVarNames _ self class allInstVarNames. - ti _ 1. - ((instVarNames at: ti) = 'owner') & (Morph superclass == Object) ifFalse: [ - self error: 'this method is out of date']. - aDataStream - beginInstance: self class - size: cntInstVars + cntIndexedVars. - 1 to: cntInstVars do: [ :i | - (instVarNames at: i) caseOf: { - ['owner'] -> [aDataStream nextPutWeak: owner]. "owner only written if in our tree" - ['id'] -> [ aDataStream nextPut: nil ]. - } - otherwise: [ aDataStream nextPut: (self instVarAt: i)]]. - 1 to: cntIndexedVars do: [ :i | - aDataStream nextPut: (self basicAt: i)]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4315-Morphic-VG-JuanVuletich-2020Jul27-16h50m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4312] on 27 July 2020 at 5:13:53 pm'! -!MorphicCanvas methodsFor: 'testing' stamp: 'jmv 7/27/2020 17:13:44' prior: 50536839! - isCurrentMorphVisible - "Note: answer true if we are not sure." - | aRectangle myClipRect | - currentMorph visible ifFalse: [ ^false ]. - aRectangle := currentMorph displayBounds. - aRectangle ifNil: [ ^true ]. - (currentMorph firstOwnerSuchThat: [ :m | m is: #HandMorph ]) notNil ifTrue: [ ^true ]. - -self flag: #jmvHacks. - true ifTrue: [ ^true ]. - myClipRect := self clipRect. - aRectangle right < myClipRect left ifTrue: [^ false]. - aRectangle left > myClipRect right ifTrue: [^ false]. - aRectangle bottom < myClipRect top ifTrue: [^ false]. - aRectangle top > myClipRect bottom ifTrue: [^ false]. - ^ true -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4316-Morphic-VG-JuanVuletich-2020Jul27-17h13m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4315] on 28 July 2020 at 12:03:43 pm'! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/28/2020 12:02:21' prior: 50531539! - fullContainsGlobalPoint: worldPoint - "Answer true even if aLocalPoint is in some submorph, regardless of being also inside our shape." - - "If not visible, won't contain any point at all." - | canvas | - self visible ifFalse: [ ^false ]. - - canvas _ self world canvas. - canvas isNil ifTrue: [ ^false ]. - (canvas morph: self isAtPoint: worldPoint) ifTrue: [ ^ true ]. - self submorphsDo: [ :m | - (m fullContainsGlobalPoint: worldPoint) ifTrue: [ ^ true ]]. - ^ false! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/28/2020 12:01:54' prior: 50531587! - fullContainsPoint: aLocalPoint - "Answer true even if aLocalPoint is in some submorph, regardless of being also inside our shape." - - "If not visible, won't contain any point at all." - self visible ifFalse: [ ^false ]. - - ^self fullContainsGlobalPoint: (self externalizeToWorld: aLocalPoint).! ! -!PasteUpMorph methodsFor: 'misc' stamp: 'jmv 7/28/2020 12:00:02' prior: 16887369! - buildMagnifiedBackgroundImage - | image old | - old _ backgroundImage. - backgroundImageData - ifNil: [ backgroundImage _ nil ] - ifNotNil: [ - [image _ Form fromBinaryStream: backgroundImageData readStream. - backgroundImage _ image magnifyTo: extent. - self canvas ifNotNil: [ :c | - (backgroundImage depth = 32 and: [ c form depth < 32 ]) ifTrue: [ - backgroundImage _ backgroundImage orderedDither32To16 ]] - ] on: Error do: [backgroundImage := nil]. "Can happen if JPEG plugin not built" - ]. - old == backgroundImage ifFalse: [ - self redrawNeeded ]! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -self runningWorld buildMagnifiedBackgroundImage; clearCanvas! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4317-Morphic-VG-JuanVuletich-2020Jul28-11h59m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4316] on 28 July 2020 at 12:19:29 pm'! -!RectangleLikeMorph methodsFor: 'geometry testing' stamp: 'jmv 7/28/2020 12:16:53' prior: 50531557! - morphContainsPoint: aLocalPoint - "Answer true even if aLocalPoint is in a submorph, as long as it is in our shape" - - "If not visible, won't contain any point at all." - self visible ifFalse: [ ^false ]. - - "Most morphs answer true to to #isOrthoRectangularMorph, or redefine this method..." - self isOrthoRectangularMorph ifTrue: [ - ^ self morphLocalBounds containsPoint: aLocalPoint ]. - - "...But for those who not, provide correct albeit expensive behavior." - "Can't do better. Please redefine in subclasses as appropriate!! (or finish Morphic 3!!)" - "Mhhh. Podria usar el #imageForm: y ver si es transparente... deberia andar" - ^ self morphLocalBounds containsPoint: aLocalPoint! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 7/28/2020 12:18:56' prior: 50531581! -morph: aMorph isAtPoint: aPoint - aMorph displayBounds ifNotNil: [ :r | - (r containsPoint: aPoint) ifFalse: [ - ^false ]]. - ^aMorph morphContainsPoint: - (aMorph internalizeFromWorld: aPoint)! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4318-Morphic-VG-JuanVuletich-2020Jul28-12h16m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4317] on 28 July 2020 at 12:23:29 pm'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/28/2020 12:23:22' prior: 50536439! - drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rectsToRepair previousRectsToRepair reuse previousCount | - "Update #displayBounds for all dirty morphs (marked as such with #redrawNeeded). - Also add the updated bounds to aDamageRecorder." - self updatingMorphBoundsDo: [ - aPasteUpMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - self updateHandsDisplayBounds: aPasteUpMorph ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ aDamageRecorder invalidRectsFullBounds: aPasteUpMorph viewBox. - - rectsToRepair size = 0 ifTrue: [ - ^rectsToRepair]. - - rectsToRepair size > 1 ifTrue: [ "Or there is no point in attempting to merge them!!" - previousRectsToRepair _ OrderedCollection new. - - "Until no more rectangles are merged, i.e. each morph intersects at most one rectangle." - previousCount _ 0. - [rectsToRepair size = previousCount] whileFalse: [ - previousCount _ rectsToRepair size. - aPasteUpMorph submorphsReverseDo: [ :morph | | thisMorphRectangle thisMorphBounds | - morph visible ifTrue: [ - reuse _ previousRectsToRepair. - previousRectsToRepair _ rectsToRepair. - rectsToRepair _ reuse removeAll. - thisMorphRectangle _ nil. - thisMorphBounds _ morph displayFullBounds. - previousRectsToRepair do: [ :r | - (thisMorphBounds intersects: r) - ifTrue: [ thisMorphRectangle _ r quickMerge: thisMorphRectangle ] - ifFalse: [ rectsToRepair add: r ]]. - thisMorphRectangle - ifNotNil: [rectsToRepair add: thisMorphRectangle]]]]. - ]. - - "Draw World" - rectsToRepair do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - "Repair rects. Draw morphs" - rectsToRepair do: [ :r | - self newClipRect: r. - aPasteUpMorph submorphsReverseDo: [ :morph | | morphBounds | - morph visible ifTrue: [ - morphBounds _ morph displayFullBounds. - (morphBounds intersects: r) ifTrue: [ - self fullDraw: morph ]]]]. - - ^ rectsToRepair! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4319-Morphic-VG-JuanVuletich-2020Jul28-12h23m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4319] on 31 July 2020 at 3:42:14 pm'! - -RectangleLikeMorph subclass: #HandMorph - instanceVariableNames: 'mouseFocus keyboardFocus mouseClickState mouseOverHandler lastMouseEvent damageRecorder hasChanged savedPatch lastEventBuffer lastKeyDownValue lastMouseEventTime prevFullBounds grabMorphData lastPosition ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -!classDefinition: #HandMorph category: #'Morphic-Kernel' stamp: 'Install-4320-lastPosition-Hand-ivar-JuanVuletich-2020Jul31-15h24m-jmv.001.cs.st 8/5/2020 22:21:37'! -RectangleLikeMorph subclass: #HandMorph - instanceVariableNames: 'mouseFocus keyboardFocus mouseClickState mouseOverHandler lastMouseEvent damageRecorder hasChanged savedPatch lastEventBuffer lastKeyDownValue lastMouseEventTime prevFullBounds grabMorphData lastPosition' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/31/2020 15:24:00' prior: 50535784! - displayBoundsOrBogus - "Never answer nil. A bogus value will trigger a draw operation, and bounds will later be corrected." - ^self displayBounds ifNil: [ - Rectangle center: (self externalizeToWorld: `0@0`) extent: `2@2` ]! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 7/31/2020 15:41:33' prior: 50533608! - fullDrawHandOn: aCanvas - "A HandMorph has an unusual drawing requirement: - The hand itself (i.e., the cursor) appears in front of its submorphs - The illusion is that the hand plucks up morphs and carries them above the world." - - submorphs reverseDo: [ :m | aCanvas fullDraw: m ]. - self drawOn: aCanvas. "draw the hand itself in front of morphs" - lastPosition _ submorphs notEmpty ifTrue: [self morphPosition].! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 7/31/2020 15:41:15' prior: 50535011 overrides: 50534890! - displayFullBounds - "Current full bounds of hand and carried submorphs. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around)." - | fullBounds | - fullBounds _ self displayBounds. - self submorphsDo: [ :m | - fullBounds _ fullBounds quickMerge: m displayFullBounds]. - lastPosition - ifNotNil: [ :lastPos | "When already carrying morphs around." - fullBounds _ fullBounds translatedBy: self morphPosition-lastPos. - fullBounds _ fullBounds quickMerge: self displayBounds ]. - ^fullBounds! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 7/31/2020 15:41:42' prior: 50533634! - grabMorph: aMorph delta: delta - "Grab the given morph (i.e., add it to this hand and remove it from its current owner)." - - | formerOwner | - self releaseMouseFocus. "Break focus" - - "Grab the halo if present" - self halo ifNotNil: [ :h | - h target == aMorph ifTrue: [ - self addMorphBack: h position: h morphPositionInWorld - self morphPositionInWorld ]]. - - "Remember previous owner and position, in case the drop is later rejected" - formerOwner _ aMorph owner. - formerOwner ifNotNil: [ - grabMorphData - at: aMorph - put: { formerOwner. aMorph morphPositionInWorld. } ]. - self addMorphBack: aMorph position: delta. - aMorph justGrabbedFrom: formerOwner. - formerOwner ifNotNil: [ - lastPosition _ self morphPosition ].! ! - -RectangleLikeMorph subclass: #HandMorph - instanceVariableNames: 'mouseFocus keyboardFocus mouseClickState mouseOverHandler lastMouseEvent damageRecorder hasChanged savedPatch lastEventBuffer lastKeyDownValue lastMouseEventTime prevFullBounds grabMorphData lastPosition' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -!classDefinition: #HandMorph category: #'Morphic-Kernel' stamp: 'Install-4320-lastPosition-Hand-ivar-JuanVuletich-2020Jul31-15h24m-jmv.001.cs.st 8/5/2020 22:21:37'! -RectangleLikeMorph subclass: #HandMorph - instanceVariableNames: 'mouseFocus keyboardFocus mouseClickState mouseOverHandler lastMouseEvent damageRecorder hasChanged savedPatch lastEventBuffer lastKeyDownValue lastMouseEventTime prevFullBounds grabMorphData lastPosition' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4320-lastPosition-Hand-ivar-JuanVuletich-2020Jul31-15h24m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4319] on 31 July 2020 at 4:13:32 pm'! -!Morph commentStamp: 'jmv 7/31/2020 16:05:32' prior: 50506280! - A Morph (from the Greek "shape" or "form") is an interactive graphical object. General information on the Morphic system can be found at http://wiki.squeak.org/squeak/morph. - -Morphs exist in a tree, rooted at a World (generally a PasteUpMorph). The morphs owned by a morph are its submorphs. Morphs are drawn recursively; if a Morph has no owner it never gets drawn. To hide a Morph and its submorphs, send the #visible: message. - -Structure: -instance var Type Description -owner Morph My parent Morph, or nil for the top-level Morph, which is a - or nil world, typically a PasteUpMorph. -submorphs Array My child Morphs. -location GeometryTransformation Specifies position (and possibly, angle of rotation and scale change) inside owner - See comment at GeometryTransformation -extension MorphExtension Allows extra properties to be stored without adding a - or nil storage burden to all morphs. -! -!Morph methodsFor: 'accessing - flags' stamp: 'jmv 7/31/2020 16:08:29'! - isLayoutNeeded - - ^ self privateFlagAt: 4! ! -!Morph methodsFor: 'accessing - flags' stamp: 'jmv 7/31/2020 16:08:33'! - isRedrawNeeded - - ^ self privateFlagAt: 1! ! -!Morph methodsFor: 'accessing - flags' stamp: 'jmv 7/31/2020 16:12:00'! - isSubmorphRedrawNeeded - - ^ self privateFlagAt: 2! ! -!Morph methodsFor: 'accessing - flags' stamp: 'jmv 7/31/2020 16:08:56'! - layoutNeeded: aBoolean - - ^self privateFlagAt: 4 put: aBoolean! ! -!Morph methodsFor: 'accessing - flags' stamp: 'jmv 7/31/2020 16:08:43'! - needsRedraw: aBoolean - - ^self privateFlagAt: 1 put: aBoolean! ! -!Morph methodsFor: 'accessing - flags' stamp: 'jmv 7/31/2020 16:11:49'! - submorphNeedsRedraw: aBoolean - - ^self privateFlagAt: 2 put: aBoolean! ! -!Morph methodsFor: 'private' stamp: 'jmv 7/31/2020 15:56:13'! - privateFlagAt: bitIndex - "We can hold up to 8 1-bit flags. - Initial value of all flags is false." - - id ifNil: [ self morphId ]. - ^(id bitAt: bitIndex) = 1! ! -!Morph methodsFor: 'private' stamp: 'jmv 7/31/2020 15:56:19'! - privateFlagAt: bitIndex put: aBoolean - "We can hold up to 8 1-bit flags. - Initial value of all flags is false." - - id ifNil: [ self morphId ]. - id _ id bitAt: bitIndex put: (aBoolean ifTrue: [1] ifFalse: [0])! ! -!Morph class methodsFor: 'initialize-release' stamp: 'jmv 7/31/2020 15:46:22'! - clearIds - - LastMorphId _ nil. - self allSubInstancesDo: [ :each | - each clearId ]! ! -!Morph methodsFor: 'accessing' stamp: 'jmv 7/31/2020 15:52:47' prior: 50505978! - morphId - "Non zero. Zero id means no Morph. - reserve lower 8 bits of numeric ivar for boolean flags." - " - Morph clearIds - " - id ifNil: [ - LastMorphId isNil ifTrue: [ LastMorphId _ 0 ]. - LastMorphId _ LastMorphId + 1. - id _ LastMorphId << 8 ]. - ^id >> 8! ! -!Morph methodsFor: 'accessing - flags' stamp: 'jmv 7/31/2020 16:09:44' prior: 16874339! - visible - "Answer if I am visible -- default is true. - Store value of 'hidden', because flags default to false." - - ^ (self privateFlagAt: 3) not! ! -!Morph methodsFor: 'caching' stamp: 'jmv 7/31/2020 15:56:42' prior: 50510029! - clearId - "Also clear flags (i.e. sets all flags to false)" - - id _ nil.! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 7/31/2020 16:05:51' prior: 50535252! - visible: aBoolean - "set the 'visible' attribute of the receiver to aBoolean - Store value of 'hidden', because flags default to false." - - self visible == aBoolean - ifTrue: [ ^ self ]. - self privateFlagAt: 3 put: aBoolean not. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded! ! -!Morph methodsFor: 'initialization' stamp: 'jmv 7/31/2020 16:00:26' prior: 16875910 overrides: 16896425! - initialize - "initialize the state of the receiver" - - owner _ nil. - submorphs _ #(). - location _ MorphicTranslation new.! ! -!Morph methodsFor: 'layout' stamp: 'jmv 7/31/2020 16:00:40' prior: 16876028! - layoutSubmorphs - "Compute a new layout of submorphs based on the given layout bounds." - "Only specific subclasses do layout. They redefine this method. - Remember to call super, or set layoutNeeded ivar to false!!" - - self layoutNeeded: false! ! -!Morph methodsFor: 'layout' stamp: 'jmv 7/31/2020 15:59:49' prior: 16876038! - layoutSubmorphsIfNeeded - "Return self. Recompute the layout if necessary." - - "Check senders. Many many not be needed. Others might be just to compute fullBounds, that we hope to elliminate!! Keep those that really need layout. of submorphs" - self flag: #jmvVer2. - - self isLayoutNeeded ifTrue: [ - self layoutSubmorphs ].! ! -!Morph methodsFor: 'layout' stamp: 'jmv 7/31/2020 15:59:02' prior: 16876053! - someSubmorphPositionOrExtentChanged - "Our extent, or some submorph changed. Must layout submorphs again." - - self layoutNeeded: true.! ! -!Morph methodsFor: 'updating' stamp: 'jmv 7/31/2020 16:13:02' prior: 50535794! - redrawNeeded - "Report that the area occupied by this morph should be redrawn." - - self needsRedraw: true. - self allOwnersDo: [ :m | m submorphNeedsRedraw: true ]. - self invalidateDisplayRect: self displayBoundsOrBogus from: nil. - self submorphsDrawingOutsideReverseDo: [ :m | m redrawNeeded ]! ! -!SystemWindow methodsFor: 'layout' stamp: 'jmv 7/31/2020 15:59:34' prior: 50384757 overrides: 50537642! - layoutSubmorphs - "Compute a new layout of submorphs based on the given layout bounds." - - | h thickness w cornerExtent wh ww pos | - thickness _ 4. - cornerExtent _ 20. - ww _ extent x. - wh _ extent y. - w _ ww - cornerExtent - cornerExtent. - h _ wh - cornerExtent - cornerExtent. - (adjusters at: #topAdjuster) morphPosition: cornerExtent@0 extent: w@thickness. - (adjusters at: #bottomAdjuster) morphPosition: cornerExtent@(wh-thickness) extent: w@thickness. - (adjusters at: #leftAdjuster) morphPosition: 0@cornerExtent extent: thickness@h. - (adjusters at: #rightAdjuster) morphPosition: ww-thickness@cornerExtent extent: thickness@h. - (adjusters at: #topLeftAdjuster) morphPosition: `0@0` extent: cornerExtent@cornerExtent. - (adjusters at: #bottomLeftAdjuster) morphPosition: 0@(wh-cornerExtent) extent: cornerExtent@cornerExtent. - (adjusters at: #topRightAdjuster) morphPosition: ww-cornerExtent@0 extent: cornerExtent@cornerExtent. - (adjusters at: #bottomRightAdjuster) morphPosition: ww@wh-cornerExtent extent: cornerExtent@cornerExtent. - - layoutMorph ifNotNil: [ - pos _ borderWidth @ (borderWidth + self labelHeight). - layoutMorph - morphPosition: pos - extent: extent - pos - borderWidth ]. - - self layoutNeeded: false.! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 7/31/2020 16:00:14' prior: 50520111 overrides: 50537642! - layoutSubmorphs - "Compute a new layout based on the given layout bounds." - - submorphs isEmpty ifTrue: [ - self layoutNeeded: false. - ^self]. - - "Invariant: morphExtent >= minimumLayoutExtent" - self refreshExtent. - - direction == #horizontal ifTrue: [ - self layoutSubmorphsHorizontallyIn: self layoutBounds ]. - - direction == #vertical ifTrue: [ - self layoutSubmorphsVerticallyIn: self layoutBounds ]. - - self layoutNeeded: false.! ! -!ProgressMorph methodsFor: 'initialization' stamp: 'jmv 7/31/2020 15:59:11' prior: 50444443 overrides: 50384224! - openInWorld: aWorld - "This msg and its callees result in the window being activeOnlyOnTop" - aWorld addMorph: self. - self updatePositionAndExtent. - labelMorph fitContents. - subLabelMorph fitContents. - self layoutNeeded: true.! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/31/2020 16:13:11' prior: 50536178! -fullAddCurrentRect: addCurrentBounds submorphs: trySubmorphs to: aDamageRecorder - | currentMorphBounds | - addCurrentBounds ifTrue: [ - currentMorph needsRedraw: false. - currentMorph drawOn: self. - currentMorphBounds _ self boundingRectOfCurrentMorphAfterDraw. - currentMorph displayBounds: currentMorphBounds. - aDamageRecorder recordInvalidRect: currentMorphBounds. - currentMorph submorphsDo: [ :m | self fullUpdateBounds: m ]. - ]. - trySubmorphs ifTrue: [ - currentMorph submorphNeedsRedraw: false. - currentMorph clippedSubmorph ifNotNil: [ :clipped | - self clippingByCurrentMorphDo: [ self fullAddRedrawRect: clipped to: aDamageRecorder ]]. - currentMorph unclippedSubmorphsReverseDo: [ :m | - self fullAddRedrawRect: m to: aDamageRecorder ] - ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/31/2020 16:12:51' prior: 50535911! - fullAddRedrawRect: aMorph to: aDamageRecorder - | addCurrentBounds trySubmorphs | - aMorph visible ifTrue: [ - addCurrentBounds _ aMorph isRedrawNeeded. - trySubmorphs _ aMorph isSubmorphRedrawNeeded. - (trySubmorphs or: [addCurrentBounds]) ifTrue: [ - self into: aMorph. - self canvasToUse - fullAddCurrentRect: addCurrentBounds - submorphs: trySubmorphs - to: aDamageRecorder. - self outOfMorph - ]]! ! - -Morph removeSelector: #privateFlag:! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Morph allSubInstancesDo: [ :m | (m valueOfProperty: #visible ifAbsent: [true]) ifFalse: [m privateFlagAt: 3 put: true]]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4321-Morph-flags-JuanVuletich-2020Jul31-15h42m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4319] on 31 July 2020 at 4:16:04 pm'! - -"Change Set: 4322-AddPrivateDisplayBoundsIvarToMorph-JuanVuletich-2020Jul31-16h13m -Date: 31 July 2020 -Author: Juan Vuletich - -Adding an instance variable to Morph is tricky. Hence this preamble." -| ui b cs | -Utilities authorInitialsPerSe ifNil: [ Utilities setAuthor ]. -(nil confirm: 'In order to add a new instance variable to Morph, -we need to restart the User Interface process. -You''ll need to re-start the image update to install later updates.') ifFalse: [ self halt ]. -[ - ui _ UISupervisor ui. - UISupervisor stopUIProcess. - b _ ClassBuilder isSilent. - ClassBuilder beSilent: true. - ClassBuilder new - superclass: Object - subclass: #Morph - instanceVariableNames: 'owner submorphs location layoutSpec properties id privateDisplayBounds' - classVariableNames: 'LastMorphId' - poolDictionaries: '' - category: 'Morphic-Kernel'. - ClassBuilder beSilent: b. - UISupervisor spawnNewMorphicProcessFor: ui. - ChangeSet installing: '4322-AddPrivateDisplayBoundsIvarToMorph-JuanVuletich-2020Jul31-16h13m-jmv.001.cs.st' do: []. - cs _ ChangeSet changeSetForBaseSystem. - (cs name beginsWith: '4322') ifTrue: [ - ChangeSet removeChangeSet: cs ]. - 'Done adding ivar ''privateDisplayBounds'' to Morph.' print. - 'Installed ChangeSet: 4322-AddPrivateDisplayBoundsIvarToMorph-JuanVuletich-2020Jul31-16h13m-jmv.001.cs.st' print. - 'Please restart [Install New Updates].' print. -] forkAt: 41! - -'From Cuis 5.0 [latest update: #4322] on 31 July 2020 at 4:52:46 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/31/2020 16:48:16' prior: 50536047! - displayBounds: aRectangle - - self displayBounds ~= aRectangle ifTrue: [ - privateDisplayBounds _ aRectangle. - self setProperty: #displayBounds toValue: aRectangle ].! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Morph allSubInstancesDo: [ :m | m displayBounds ifNotNil: [ :r | m instVarNamed: 'privateDisplayBounds' put: r ]]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4323-set-privateDisplayBounds-JuanVuletich-2020Jul31-16h48m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4322] on 31 July 2020 at 4:53:32 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/31/2020 16:53:06' prior: 50532255! - displayBounds - "At time of last draw. nil if unknown." - - self visible ifFalse: [ ^nil ]. - ^ privateDisplayBounds! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/31/2020 16:53:12' prior: 50537865! - displayBounds: aRectangle - - self displayBounds ~= aRectangle ifTrue: [ - privateDisplayBounds _ aRectangle ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4324-use-privateDisplayBounds-JuanVuletich-2020Jul31-16h52m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4324] on 31 July 2020 at 5:00:35 pm'! -!Morph methodsFor: 'fileIn/out' stamp: 'jmv 7/31/2020 16:59:49' prior: 50537124 overrides: 16882034! - storeDataOn: aDataStream - "Let all Morphs be written out. All owners are weak references. They only go out if the owner is in the tree being written." - | cntInstVars cntIndexedVars ti instVarNames | - - "block my owner unless he is written out by someone else" - cntInstVars _ self class instSize. - cntIndexedVars _ self basicSize. - instVarNames _ self class allInstVarNames. - ti _ 1. - ((instVarNames at: ti) = 'owner') & (Morph superclass == Object) ifFalse: [ - self error: 'this method is out of date']. - aDataStream - beginInstance: self class - size: cntInstVars + cntIndexedVars. - 1 to: cntInstVars do: [ :i | - (instVarNames at: i) caseOf: { - ['owner'] -> [aDataStream nextPutWeak: owner]. "owner only written if in our tree" - ['id'] -> [ aDataStream nextPut: (id bitAnd: 255) ]. "Clear id, but keep flags." - } - otherwise: [ aDataStream nextPut: (self instVarAt: i)]]. - 1 to: cntIndexedVars do: [ :i | - aDataStream nextPut: (self basicAt: i)]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4325-Morph-copy-keepFlags-JuanVuletich-2020Jul31-16h59m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4325] on 1 August 2020 at 6:09:38 pm'! -!SystemWindow methodsFor: 'top window' stamp: 'jmv 8/1/2020 18:08:13' prior: 50534008! - activateAndSendTopToBack: aBoolean - "Bring me to the front and make me able to respond to mouse and keyboard" - - | oldTop | - owner - ifNil: [^self "avoid spurious activate when drop in trash"]. - oldTop _ TopWindow. - TopWindow _ self. - self redrawNeeded. - - oldTop ifNotNil: [ - oldTop redrawNeeded. - aBoolean ifTrue: [ - | bottomWindow | - bottomWindow _ oldTop owner submorphs reverse detect: [:one | one is: #SystemWindow]. - oldTop owner addMorph: oldTop behind: bottomWindow]]. - - owner firstSubmorph == self - ifFalse: [ - "Bring me to the top if not already" - owner addMorphFront: self]. - - "Set keyboard focus" - self world ifNotNil: [ :w | - w activeHand newKeyboardFocus: self submorphToFocusKeyboard ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4326-WindowRedrawOnFocusChange-JuanVuletich-2020Aug01-18h07m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4326] on 1 August 2020 at 6:37:52 pm'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/1/2020 18:33:03'! - updateHandsDisplayBounds: aPasteUpMorph addDamageTo: aDamageRecorder - "Update displayBounds for carried morphs if never set. - Useful for new morph, that are created and attached to the hand." - - aPasteUpMorph handsDo: [ :hand | - self into: hand. - hand submorphsDo: [ :morph | - self updateDisplayBounds: morph ]. - aDamageRecorder recordInvalidRect: hand displayFullBounds. - self outOfMorph ]! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 8/1/2020 18:30:18' prior: 50537434 overrides: 50534890! - displayFullBounds - "Current full bounds of hand and carried submorphs. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around)." - | fullBounds | - fullBounds _ self displayBounds. - self submorphsDo: [ :m | - fullBounds _ fullBounds quickMerge: m displayFullBounds]. - lastPosition - ifNotNil: [ :lastPos | "When already carrying morphs around. Include also the rectangle updated to current hand position." - fullBounds _ fullBounds quickMerge: (fullBounds translatedBy: self morphPosition-lastPos) ]. - ^fullBounds! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/1/2020 18:34:10' prior: 50537302! - drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rectsToRepair previousRectsToRepair reuse previousCount | - "Update #displayBounds for all dirty morphs (marked as such with #redrawNeeded). - Also add the updated bounds to aDamageRecorder." - self updatingMorphBoundsDo: [ - aPasteUpMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - self updateHandsDisplayBounds: aPasteUpMorph addDamageTo: aDamageRecorder ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ aDamageRecorder invalidRectsFullBounds: aPasteUpMorph viewBox. - - rectsToRepair size = 0 ifTrue: [ - ^rectsToRepair]. - - rectsToRepair size > 1 ifTrue: [ "Or there is no point in attempting to merge them!!" - previousRectsToRepair _ OrderedCollection new. - - "Until no more rectangles are merged, i.e. each morph intersects at most one rectangle." - previousCount _ 0. - [rectsToRepair size = previousCount] whileFalse: [ - previousCount _ rectsToRepair size. - aPasteUpMorph submorphsReverseDo: [ :morph | | thisMorphRectangle thisMorphBounds | - morph visible ifTrue: [ - reuse _ previousRectsToRepair. - previousRectsToRepair _ rectsToRepair. - rectsToRepair _ reuse removeAll. - thisMorphRectangle _ nil. - thisMorphBounds _ morph displayFullBounds. - previousRectsToRepair do: [ :r | - (thisMorphBounds intersects: r) - ifTrue: [ thisMorphRectangle _ r quickMerge: thisMorphRectangle ] - ifFalse: [ rectsToRepair add: r ]]. - thisMorphRectangle - ifNotNil: [rectsToRepair add: thisMorphRectangle]]]]. - ]. - - "Draw World" - rectsToRepair do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - "Repair rects. Draw morphs" - rectsToRepair do: [ :r | - self newClipRect: r. - aPasteUpMorph submorphsReverseDo: [ :morph | | morphBounds | - morph visible ifTrue: [ - morphBounds _ morph displayFullBounds. - (morphBounds intersects: r) ifTrue: [ - self fullDraw: morph ]]]]. - - ^ rectsToRepair! ! - -MorphicCanvas removeSelector: #updateHandsDisplayBounds:! - -!methodRemoval: MorphicCanvas #updateHandsDisplayBounds: stamp: 'Install-4327-FixHandDamageRect-JuanVuletich-2020Aug01-18h17m-jmv.001.cs.st 8/5/2020 22:21:45'! -updateHandsDisplayBounds: aPasteUpMorph - "Update displayBounds for carried morphs if never set. - Useful for new morph, that are created and attached to the hand." - - aPasteUpMorph handsDo: [ :hand | - self into: hand. - hand submorphsDo: [ :morph | - self updateDisplayBounds: morph ]. - self outOfMorph ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4327-FixHandDamageRect-JuanVuletich-2020Aug01-18h17m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4327] on 3 August 2020 at 10:29:34 am'! -!StringRequestMorph methodsFor: 'initialization' stamp: 'jmv 7/31/2020 21:32:04' prior: 50522995! - addTextPane - | result lineCount | - result _ (TextModelMorph - textProvider: self - textGetter: #response - textSetter: #response: - selectionGetter: #selectionInterval) emptyTextDisplayMessage: 'Enter response'. - self - valueOfProperty: #emptyTextDisplayMessage - ifPresentDo: [ :msg | - result emptyTextDisplayMessage: msg ]. - result - hasUnacceptedEdits: true; - acceptOnCR: true; - escAction: [ self cancel ]. - "If the initial response is big or has multiple lines we make the text pane bigger and with scrollbars:" - lineCount _ response lineCount. - lineCount > 1 - ifTrue: [result morphExtent: 40 @ (lineCount*2) * FontFamily defaultLineSpacing] - ifFalse: - [result hideScrollBarsIndefinitely; - morphExtent: response size @ 1 * FontFamily defaultLineSpacing + (0@8).]. - self addMorphBack: result. - ^ result.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4328-StringRequestMorph-MoreRoom-JuanVuletich-2020Aug03-10h28m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4327] on 3 August 2020 at 10:31:05 am'! -!Morph methodsFor: 'previewing' stamp: 'jmv 8/3/2020 10:30:35' prior: 50518366! - endPreview - - self previewing ifTrue: [ - owner notNil ifTrue: [ - self redrawNeeded. - self visible: self visibleBeforePreview. - owner addMorph: self inFrontOf: self morphBehindBeforePreview ]. - self previewing: false. ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4329-MinimizedWindowPreviewFix-JuanVuletich-2020Aug03-10h29m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4329] on 3 August 2020 at 2:34:23 pm'! -!PluggableListMorph methodsFor: 'events' stamp: 'jmv 8/3/2020 14:31:56' prior: 50437025 overrides: 16874501! - dragEvent: aMouseEvent localPosition: localEventPosition - - | row dragged listItem sm | - self listMorph highlightedRow: nil. - row _ self rowAtLocation: localEventPosition ifNone: [ ^self ]. - listItem _ self getListItem: row. - - sm _ StringMorph contents: listItem. - dragged _ DraggingGuideMorph new. - dragged addMorph: sm. - dragged morphExtent: sm morphExtent. - dragged setProperty: #dragSource toValue: self. - dragged setProperty: #dropSelectorArgument toValue: listItem. - - aMouseEvent hand attachMorphBeside: dragged.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4330-DragAndDropFix-JuanVuletich-2020Aug03-14h22m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4330] on 3 August 2020 at 5:01:25 pm'! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'jmv 8/3/2020 16:59:07'! - canAdd: aMorph - self world ifNotNil: [ :w | - ^w canHandle: aMorph ]. - ^true! ! -!PasteUpMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 8/3/2020 16:58:11'! - canHandle: aMorph - ^self canvas canDraw: aMorph! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 8/3/2020 16:57:53'! - canDraw: aMorph - ^true! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 8/3/2020 16:58:06' overrides: 50538214! - canDraw: aMorph - ^aMorph requiresVectorCanvas not! ! -!Morph methodsFor: 'private' stamp: 'jmv 8/3/2020 17:01:17' prior: 16877049! - privateAddAllMorphs: aCollection atIndex: index - "Private. Add aCollection of morphs to the receiver" - | myWorld itsWorld otherSubmorphs | - (aCollection allSatisfy: [ :m | self canAdd: m]) ifFalse: [ - ^self error: 'We can''t add requested morph. Maybe install and activate VectorGraphics canvas.' ]. - myWorld _ self world. - otherSubmorphs _ submorphs copyWithoutAll: aCollection. - (index between: 0 and: otherSubmorphs size) - ifFalse: [^ self error: 'index out of range']. - index = 0 - ifTrue:[ submorphs _ aCollection asArray, otherSubmorphs] - ifFalse:[ index = otherSubmorphs size - ifTrue:[ submorphs _ otherSubmorphs, aCollection] - ifFalse:[ submorphs _ otherSubmorphs copyReplaceFrom: index + 1 to: index with: aCollection ]]. - aCollection do: [:m | | itsOwner | - itsOwner _ m owner. - itsOwner ifNotNil: [ - itsWorld _ m world. - (itsWorld == myWorld) ifFalse: [ - itsWorld ifNotNil: [m redrawNeeded]]. - (itsOwner ~~ self) ifTrue: [ - m owner privateRemove: m. - m owner removedMorph: m ]]. - m privateOwner: self. - myWorld ifNotNil: [m redrawNeeded]. - (myWorld == itsWorld) ifFalse: [m intoWorld: myWorld]. - itsOwner == self ifFalse: [ - self addedMorph: m. - m noteNewOwner: self ]. - ]. - self someSubmorphPositionOrExtentChanged! ! -!Morph methodsFor: 'private' stamp: 'jmv 8/3/2020 17:00:36' prior: 16877086! - privateAddMorph: aMorph atIndex: index - - | oldIndex myWorld itsWorld oldOwner | - (self canAdd: aMorph) ifFalse: [ - ^self error: 'We can''t add requested morph. Maybe install and activate VectorGraphics canvas.' ]. - ((index >= 1) and: [index <= (submorphs size + 1)]) - ifFalse: [^ self error: 'index out of range']. - myWorld _ self world. - oldOwner _ aMorph owner. - (oldOwner == self and: [(oldIndex _ submorphs indexOf: aMorph) > 0]) ifTrue:[ - "aMorph's position changes within in the submorph chain" - oldIndex < index ifTrue:[ - "moving aMorph to back" - submorphs replaceFrom: oldIndex to: index-2 with: submorphs startingAt: oldIndex+1. - submorphs at: index-1 put: aMorph. - ] ifFalse:[ - "moving aMorph to front" - oldIndex-1 to: index by: -1 do:[:i| - submorphs at: i+1 put: (submorphs at: i)]. - submorphs at: index put: aMorph. - ]. - ] ifFalse:[ - "adding a new morph" - oldOwner ifNotNil:[ - itsWorld _ aMorph world. - itsWorld ifNotNil: [aMorph redrawNeeded]. - oldOwner privateRemove: aMorph. - oldOwner removedMorph: aMorph. - ]. - aMorph privateOwner: self. - submorphs _ submorphs copyReplaceFrom: index to: index-1 with: (Array with: aMorph). - (itsWorld == myWorld) ifFalse: [aMorph intoWorld: myWorld]. - ]. - myWorld ifNotNil:[aMorph redrawNeeded]. - self someSubmorphPositionOrExtentChanged. - oldOwner == self ifFalse: [ - self addedMorph: aMorph. - aMorph noteNewOwner: self ]. -! ! -!Morph methodsFor: 'private' stamp: 'jmv 8/3/2020 17:00:40' prior: 16877128! - privateAddMorph: aMorph atIndex: index position: aPoint - - | oldIndex myWorld itsWorld oldOwner | - (self canAdd: aMorph) ifFalse: [ - ^self error: 'We can''t add requested morph. Maybe install and activate VectorGraphics canvas.' ]. - ((index >= 1) and: [index <= (submorphs size + 1)]) - ifFalse: [^ self error: 'index out of range']. - myWorld _ self world. - oldOwner _ aMorph owner. - (oldOwner == self and: [(oldIndex _ submorphs indexOf: aMorph) > 0]) ifTrue: [ - "aMorph's position changes within in the submorph chain" - oldIndex < index ifTrue:[ - "moving aMorph to back" - submorphs replaceFrom: oldIndex to: index-2 with: submorphs startingAt: oldIndex+1. - submorphs at: index-1 put: aMorph. - ] ifFalse:[ - "moving aMorph to front" - oldIndex-1 to: index by: -1 do:[:i| - submorphs at: i+1 put: (submorphs at: i)]. - submorphs at: index put: aMorph. - ]. - aMorph privatePosition: aPoint. - ] ifFalse: [ - "adding a new morph" - oldOwner ifNotNil: [ - itsWorld _ aMorph world. - itsWorld ifNotNil: [aMorph redrawNeeded]. - oldOwner privateRemove: aMorph. - oldOwner removedMorph: aMorph. - ]. - aMorph privateOwner: self. - submorphs _ submorphs copyReplaceFrom: index to: index-1 with: (Array with: aMorph). - aMorph privatePosition: aPoint. - (itsWorld == myWorld) ifFalse: [aMorph intoWorld: myWorld]. - ]. - myWorld ifNotNil: [aMorph redrawNeeded]. - self someSubmorphPositionOrExtentChanged. - oldOwner == self ifFalse: [ - self addedMorph: aMorph. - aMorph noteNewOwner: self ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4331-FailGracefullyIfNoVGSupport-JuanVuletich-2020Aug03-16h54m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4330] on 3 August 2020 at 5:30:57 pm'! -!Color class methodsFor: 'instance creation' stamp: 'jmv 8/3/2020 17:30:42' prior: 50389463! - fromHexString: aString - "For HTML color spec: #FFCCAA. - See http://www.w3schools.com/cssref/css_colors_legal.asp - Also handles 3 digit shorthand." - " - Color fromHexString: '#FFCCAA'. - " - (aString size = 7 and: [ aString first = $# ]) ifTrue: [ - | aColorHexU red green blue | - aColorHexU _ aString asUppercase. - red _ ('16r', (aColorHexU copyFrom: 2 to: 3)) asNumber/255. - green _ ('16r', (aColorHexU copyFrom: 4 to: 5)) asNumber/255. - blue _ ('16r', (aColorHexU copyFrom: 6 to: 7)) asNumber/255. - ^ self r: red g: green b: blue]. - (aString size = 4 and: [ aString first = $# ]) ifTrue: [ - | aColorHexU red green blue | - aColorHexU _ aString asUppercase. - red _ aColorHexU at: 2. - green _ aColorHexU at: 3. - blue _ aColorHexU at: 4. - red _ ('16r', (String with: red with: red)) asNumber/255. - green _ ('16r', (String with: green with: green)) asNumber/255. - blue _ ('16r', (String with: blue with: blue)) asNumber/255. - ^ self r: red g: green b: blue]. - ^ nil! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4332-Color-fromHex-enh-JuanVuletich-2020Aug03-17h30m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4332] on 3 August 2020 at 7:04:29 pm'! -!FontFamily methodsFor: 'testing' stamp: 'jmv 8/3/2020 19:00:28'! - isTrueTypeFontFamily - ^false! ! -!FontFamily class methodsFor: 'accessing fonts' stamp: 'jmv 8/3/2020 19:01:01'! - defaultOrTrueTypeFamilyAndPointSize - " - FontFamily defaultOrTrueTypeFamilyAndPointSize - " - | family | - family _ AvailableFamilies at: DefaultFamilyName. - family isTrueTypeFontFamily ifFalse: [ - family _ AvailableFamilies detect: [ :any | any isTrueTypeFontFamily ] ifNone: [ ^nil ]]. - ^family atPointSize: DefaultPointSize ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4333-DefaultTrueType-JuanVuletich-2020Aug03-19h00m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4333] on 4 August 2020 at 10:32:23 am'! - -Object subclass: #DamageRecorder - instanceVariableNames: 'invalidRects totalRepaint drSemaphore damageByRoot ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #DamageRecorder category: #'Morphic-Support' stamp: 'Install-4334-DamageRecorder-redesign-JuanVuletich-2020Aug04-09h10m-jmv.002.cs.st 8/5/2020 22:21:45'! -Object subclass: #DamageRecorder - instanceVariableNames: 'invalidRects totalRepaint drSemaphore damageByRoot' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! -!Morph methodsFor: 'change reporting' stamp: 'jmv 8/4/2020 10:04:10'! - invalidateDisplayRect: damageRect fromSubmorph: submorphOrNil for: aMorph - "If we clip aMorph, then we clip damageRect. - When calling from self, second argument should be nil, i.e. we are not reporting damage for some submorph." - - | clippedRect b | - - "warning. Senders are using global coordinates. Redesign!!" - "local now!!!!!!!!!!" - self flag: #jmvVer2. "ok?" - - self visible ifFalse: [ ^self]. - - clippedRect _ damageRect. - submorphOrNil ifNotNil: [ - submorphOrNil == self clippedSubmorph - ifTrue: [ - b _ self displayBounds. - b ifNil: [ ^self ]. - clippedRect _ damageRect intersect: b ]]. - owner ifNotNil: [ - owner invalidateDisplayRect: clippedRect fromSubmorph: self for: aMorph ]! ! -!PasteUpMorph methodsFor: 'change reporting' stamp: 'jmv 8/4/2020 10:05:54' overrides: 50538451! - invalidateDisplayRect: damageRect fromSubmorph: submorphOrNil for: aMorph - "Clip damage reports to my bounds, since drawing is _always_ clipped to my bounds." - - self == self world - ifTrue: [ worldState recordDamagedRect: (damageRect intersect: self morphLocalBounds ) for: aMorph ] - ifFalse: [ super invalidateDisplayRect: damageRect fromSubmorph: submorphOrNil for: aMorph ]! ! -!WorldState methodsFor: 'canvas' stamp: 'jmv 8/4/2020 10:02:25'! - recordDamagedRect: damageRect for: aMorph - - damageRecorder ifNotNil: [ - damageRecorder recordInvalidRect: damageRect for: aMorph ]! ! -!DamageRecorder methodsFor: 'recording' stamp: 'jmv 8/4/2020 10:29:51'! - recordInvalidRect: requestedRect for: aMorph - "aRootMorph should be #root" - - ^ self pvtAccessProtect critical: [ - self pvtInnerRecordInvalidRect: requestedRect for: (aMorph ifNotNil: [aMorph root]) ]! ! -!DamageRecorder methodsFor: 'private' stamp: 'jmv 8/4/2020 10:30:38'! - pvtInnerRecordInvalidRect: requestedRect for: aRootMorph - "Record the given rectangle in my damage list, a list of rectangular areas of the display that should be redraw on the next display cycle. - Rectangles are specified in world coordinates (might be not the same as Display coordinates if there is some origin set on some canvas. Usually there will be none, but we can't be sure) - aRootMorph is the top owner of the morph originally reporting requestedRect. It might be nil if irrelevant. - " - "Details: Damaged rectangles are often identical or overlap significantly. In these cases, we merge them to reduce the number of damage rectangles that must be processed when the display is updated. Moreover, above a certain threshold, we ignore the individual rectangles completely, and simply do a complete repaint on the next cycle. - jmv: Important. There should be no overlapping rectangles in the list. If there are, translucent morphs might be drawn several times, with visible defects. - WRT performance, the different paths for various intersections seem a bit complicated. I could not find strong evidence of the best way. - Leave it as it is right now." - | newRect mergeRect indexToReuse oc | - totalRepaint ifTrue: [ ^ self ]. - "planning full repaint; don't bother collecting damage" - indexToReuse _ nil. - newRect _ requestedRect encompassingIntegerRectangle. - aRootMorph ifNotNil: [ - oc _ damageByRoot at: aRootMorph ifAbsentPut: [OrderedCollection new]. - oc add: newRect ]. - invalidRects withIndexDo: [ :oldRect :index | - oldRect - ifNil: [ indexToReuse ifNil: [ indexToReuse _ index ]] - ifNotNil: [ - "No two rectangles should intersect" - (oldRect intersects: newRect) ifTrue: [ - "newRect already in. Nothing to do then." - (oldRect containsRect: newRect) ifTrue: [ ^ self ]. - "Some oldRect included in newRect. Remove it and continue, as newRect could still intersect others." - (newRect containsRect: oldRect) ifTrue: [ - invalidRects - at: index - put: nil. - "Effectively like 'invalidRects remove: rect', but without performance penalty." - indexToReuse ifNil: [ indexToReuse _ index ]]. - "Merge rectangles if they overlap significantly, i.e. if the merge is not much larger than separated rectangles." - mergeRect _ (oldRect origin min: newRect origin) corner: (oldRect corner max: newRect corner). - mergeRect area > (newRect area + oldRect area * 2) - ifTrue: [ - "Avoid intersections!!" - newRect - areasOutside: oldRect - do: [ :nonIntersection | - "We have brand new newRects. Start all over with each of them." - self pvtInnerRecordInvalidRect: nonIntersection for: nil ]. - "newRect no longer needed, then." - ^ self ] - ifFalse: [ - "Merge into newRect, as any overlap with forecoming rectangles in the iteration is detected and treated." - newRect _ mergeRect. - invalidRects - at: index - put: nil. - "Effectively like 'invalidRects remove: rect', but without performance penalty." - indexToReuse ifNil: [ indexToReuse _ index ]]]]]. - invalidRects size >= 10 ifTrue: [ - "if there are too many separate areas, merge them all" - mergeRect _ Rectangle merging: invalidRects. - invalidRects removeAll. - mergeRect ifNotNil: [ invalidRects addLast: mergeRect ]. - indexToReuse _ nil ]. - "Add the given rectangle to the damage list" - indexToReuse - ifNil: [ invalidRects addLast: newRect ] - ifNotNil: [ - invalidRects - at: indexToReuse - put: newRect ].! ! -!Morph methodsFor: 'change reporting' stamp: 'jmv 8/4/2020 10:07:09' prior: 50535548! - invalidateLocalRect: localRectangle - - self invalidateDisplayRect: (self externalizeDisplayBounds: localRectangle) fromSubmorph: nil for: self! ! -!Morph methodsFor: 'updating' stamp: 'jmv 8/4/2020 10:07:29' prior: 50537673! - redrawNeeded - "Report that the area occupied by this morph should be redrawn." - - self needsRedraw: true. - self allOwnersDo: [ :m | m submorphNeedsRedraw: true ]. - self invalidateDisplayRect: self displayBoundsOrBogus fromSubmorph: nil for: nil. - self submorphsDrawingOutsideReverseDo: [ :m | m redrawNeeded ]! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 8/4/2020 10:06:52' prior: 50536250! - restoreSavedPatchOn: aCanvas - "Clear the changed flag and restore the part of the given canvas under this hand from the previously saved patch. If necessary, handle the transition to using the hardware cursor." - hasChanged _ false. - savedPatch ifNotNil: [ - aCanvas restorePatch: savedPatch. - submorphs notEmpty ifTrue: [ ^ self ]. - "Make the transition to using hardware cursor. Clear savedPatch and - report one final damage rectangle to erase the image of the software cursor." - " owner invalidateDisplayRect: (savedPatch offset extent: savedPatch extent) from: nil." - self - invalidateDisplayRect: (self morphPosition extent: extent) - fromSubmorph: nil - for: nil. - Cursor currentCursor == Cursor defaultCursor ifFalse: [ Cursor defaultCursor activateCursor ]. - "show hardware cursor" - savedPatch _ nil ].! ! -!HandMorph methodsFor: 'initialization' stamp: 'jmv 8/4/2020 10:15:10' prior: 50471122 overrides: 50384234! - initialize - super initialize. - self initForEvents. - keyboardFocus _ nil. - mouseFocus _ nil. - extent _ CursorWithMask defaultCursor extent. - grabMorphData _ IdentityDictionary new. - self initForEvents.! ! -!DamageRecorder methodsFor: 'initialization' stamp: 'jmv 8/4/2020 10:21:05' prior: 50462504 overrides: 16896425! - initialize - super initialize . - invalidRects _ OrderedCollection new: 15. - totalRepaint _ false. - damageByRoot _ IdentityDictionary new! ! -!DamageRecorder methodsFor: 'recording' stamp: 'jmv 8/4/2020 09:10:22' prior: 50535936! - invalidRectsFullBounds: aRectangle - "Return a collection of damaged rectangles for the given canvas. Take only intersection with aRectangle. - If a total repaint has been requested, return the given rectangle. - Forget about all damage." - | answer | - answer _ totalRepaint ifTrue: [ Array with: aRectangle ]. - self pvtAccessProtect critical: [ - answer ifNil: [ - answer _ OrderedCollection new. - invalidRects do: [ :r | - r ifNotNil: [ - (aRectangle containsRect: r) - ifTrue: [ answer add: r ] - ifFalse: [ answer add: (r intersect: aRectangle) ]. - ]]]. - self pvtReset ]. - ^ answer.! ! -!DamageRecorder methodsFor: 'private' stamp: 'jmv 8/4/2020 10:21:17' prior: 50462619! - pvtReset - "Clear the damage list." - invalidRects removeAll. - totalRepaint _ false. - damageByRoot removeAll.! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/4/2020 10:01:36' prior: 50537756! - fullAddCurrentRect: addCurrentBounds submorphs: trySubmorphs to: aDamageRecorder - | currentMorphBounds | - addCurrentBounds ifTrue: [ - currentMorph needsRedraw: false. - currentMorph drawOn: self. - currentMorphBounds _ self boundingRectOfCurrentMorphAfterDraw. - currentMorph displayBounds: currentMorphBounds. - aDamageRecorder recordInvalidRect: currentMorphBounds for: currentMorph. - currentMorph submorphsDo: [ :m | self fullUpdateBounds: m ]. - ]. - trySubmorphs ifTrue: [ - currentMorph submorphNeedsRedraw: false. - currentMorph clippedSubmorph ifNotNil: [ :clipped | - self clippingByCurrentMorphDo: [ self fullAddRedrawRect: clipped to: aDamageRecorder ]]. - currentMorph unclippedSubmorphsReverseDo: [ :m | - self fullAddRedrawRect: m to: aDamageRecorder ] - ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/4/2020 09:55:53' prior: 50537989! - updateHandsDisplayBounds: aPasteUpMorph addDamageTo: aDamageRecorder - "Update displayBounds for carried morphs if never set. - Useful for new morph, that are created and attached to the hand." - - aPasteUpMorph handsDo: [ :hand | - self into: hand. - hand submorphsDo: [ :morph | - self updateDisplayBounds: morph ]. - aDamageRecorder recordInvalidRect: hand displayFullBounds for: nil. - self outOfMorph ]! ! - -DamageRecorder removeSelector: #recordInvalidRect:from:! - -DamageRecorder removeSelector: #pvtInnerRecordInvalidRect:! - -!methodRemoval: DamageRecorder #pvtInnerRecordInvalidRect: stamp: 'Install-4334-DamageRecorder-redesign-JuanVuletich-2020Aug04-09h10m-jmv.002.cs.st 8/5/2020 22:21:45'! -pvtInnerRecordInvalidRect: requestedRect - "Record the given rectangle in my damage list, a list of rectangular areas of the display that should be redraw on the next display cycle. - Rectangles are specified in world coordinates (might be not the same as Display coordinates if there is some origin set on some canvas. Usually there will be none, but we can't be sure) - " - "Details: Damaged rectangles are often identical or overlap significantly. In these cases, we merge them to reduce the number of damage rectangles that must be processed when the display is updated. Moreover, above a certain threshold, we ignore the individual rectangles completely, and simply do a complete repaint on the next cycle. - jmv: Important. There should be no overlapping rectangles in the list. If there are, translucent morphs might be drawn several times, with visible defects. - WRT performance, the different paths for various intersections seem a bit complicated. I could not find strong evidence of the best way. - Leave it as it is right now." - | newRect mergeRect indexToReuse | - totalRepaint ifTrue: [ ^ self ]. - "planning full repaint; don't bother collecting damage" - indexToReuse _ nil. - newRect _ requestedRect encompassingIntegerRectangle. - invalidRects withIndexDo: [ :oldRect :index | - oldRect - ifNil: [ indexToReuse ifNil: [ indexToReuse _ index ]] - ifNotNil: [ - "No two rectangles should intersect" - (oldRect intersects: newRect) ifTrue: [ - "newRect already in. Nothing to do then." - (oldRect containsRect: newRect) ifTrue: [ ^ self ]. - "Some oldRect included in newRect. Remove it and continue, as newRect could still intersect others." - (newRect containsRect: oldRect) ifTrue: [ - invalidRects - at: index - put: nil. - "Effectively like 'invalidRects remove: rect', but without performance penalty." - indexToReuse ifNil: [ indexToReuse _ index ]]. - "Merge rectangles if they overlap significantly, i.e. if the merge is not much larger than separated rectangles." - mergeRect _ (oldRect origin min: newRect origin) corner: (oldRect corner max: newRect corner). - mergeRect area > (newRect area + oldRect area * 2) - ifTrue: [ - "Avoid intersections!!" - newRect - areasOutside: oldRect - do: [ :nonIntersection | - "We have brand new newRects. Start all over with each of them." - self pvtInnerRecordInvalidRect: nonIntersection ]. - "newRect no longer needed, then." - ^ self ] - ifFalse: [ - "Merge into newRect, as any overlap with forecoming rectangles in the iteration is detected and treated." - newRect _ mergeRect. - invalidRects - at: index - put: nil. - "Effectively like 'invalidRects remove: rect', but without performance penalty." - indexToReuse ifNil: [ indexToReuse _ index ]]]]]. - invalidRects size >= 10 ifTrue: [ - "if there are too many separate areas, merge them all" - mergeRect _ Rectangle merging: invalidRects. - self pvtReset. - mergeRect ifNotNil: [ invalidRects addLast: mergeRect ]. - indexToReuse _ nil ]. - "Add the given rectangle to the damage list" - indexToReuse - ifNil: [ invalidRects addLast: newRect ] - ifNotNil: [ - invalidRects - at: indexToReuse - put: newRect ].! - -DamageRecorder removeSelector: #recordInvalidRect:! - -!methodRemoval: DamageRecorder #recordInvalidRect: stamp: 'Install-4334-DamageRecorder-redesign-JuanVuletich-2020Aug04-09h10m-jmv.002.cs.st 8/5/2020 22:21:45'! -recordInvalidRect: requestedRect - ^ self pvtAccessProtect critical: [ self pvtInnerRecordInvalidRect: requestedRect ]! - -DamageRecorder removeSelector: #pvtInnerRecordInvalidRect:from:! - -WorldState removeSelector: #recordDamagedRect:! - -!methodRemoval: WorldState #recordDamagedRect: stamp: 'Install-4334-DamageRecorder-redesign-JuanVuletich-2020Aug04-09h10m-jmv.002.cs.st 8/5/2020 22:21:45'! -recordDamagedRect: damageRect - - damageRecorder ifNotNil: [damageRecorder recordInvalidRect: damageRect] -! - -WorldState removeSelector: #recordDamagedRect:from:! - -PasteUpMorph removeSelector: #invalidateDisplayRect:from:! - -!methodRemoval: PasteUpMorph #invalidateDisplayRect:from: stamp: 'Install-4334-DamageRecorder-redesign-JuanVuletich-2020Aug04-09h10m-jmv.002.cs.st 8/5/2020 22:21:45'! -invalidateDisplayRect: damageRect from: aMorph - "Clip damage reports to my bounds, since drawing is clipped to my bounds." - - self == self world - ifTrue: [ worldState recordDamagedRect: (damageRect intersect: self morphLocalBounds ) ] - ifFalse: [ super invalidateDisplayRect: damageRect from: aMorph ]! - -PasteUpMorph removeSelector: #invalidateDisplayRect:fromSubmorph:! - -Morph removeSelector: #invalidateDisplayRect:from:! - -!methodRemoval: Morph #invalidateDisplayRect:from: stamp: 'Install-4334-DamageRecorder-redesign-JuanVuletich-2020Aug04-09h10m-jmv.002.cs.st 8/5/2020 22:21:45'! -invalidateDisplayRect: damageRect from: aMorph - - | clippedRect b | - - "warning. Senders are using global coordinates. Redesign!!" - "local now!!!!!!!!!!" - self flag: #jmvVer2. "ok?" - - self visible ifFalse: [ ^self]. - - clippedRect _ damageRect. - aMorph ifNotNil: [ - aMorph == self clippedSubmorph - ifTrue: [ - b _ self displayBounds. - b ifNil: [ ^self ]. - clippedRect _ damageRect intersect: b ]]. - owner ifNotNil: [ - owner invalidateDisplayRect: clippedRect from: self ]! - -Morph removeSelector: #invalidateDisplayRect:fromSubmorph:! - -Object subclass: #DamageRecorder - instanceVariableNames: 'invalidRects totalRepaint drSemaphore damageByRoot' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #DamageRecorder category: #'Morphic-Support' stamp: 'Install-4334-DamageRecorder-redesign-JuanVuletich-2020Aug04-09h10m-jmv.002.cs.st 8/5/2020 22:21:45'! -Object subclass: #DamageRecorder - instanceVariableNames: 'invalidRects totalRepaint drSemaphore damageByRoot' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -DamageRecorder allSubInstancesDo: [ :dr | dr instVarNamed: 'damageByRoot' put: IdentityDictionary new ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4334-DamageRecorder-redesign-JuanVuletich-2020Aug04-09h10m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4334] on 4 August 2020 at 7:30:06 pm'! -!DamageRecorder methodsFor: 'recording' stamp: 'jmv 8/4/2020 10:52:52'! - damageReportedFor: aMorph - ^ self pvtAccessProtect critical: [ damageByRoot at: aMorph ifAbsent: nil ]! ! -!DamageRecorder methodsFor: 'recording' stamp: 'jmv 8/4/2020 17:09:22'! - damageReportedNotVisibleMorphs - | answer | - answer _ OrderedCollection new. - self pvtAccessProtect critical: [ - damageByRoot keysAndValuesDo: [ :m :r | - (m visible not or: [m owner isNil]) ifTrue: [ - answer add: r]]]. - ^answer! ! -!Morph methodsFor: 'updating' stamp: 'jmv 8/4/2020 17:12:13' prior: 50538629! - redrawNeeded - "Report that the area occupied by this morph should be redrawn." - - self needsRedraw: true. - self allOwnersDo: [ :m | m submorphNeedsRedraw: true ]. - self invalidateDisplayRect: self displayBoundsOrBogus fromSubmorph: nil for: self. - self submorphsDrawingOutsideReverseDo: [ :m | m redrawNeeded ]! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 8/4/2020 15:13:36' prior: 50538642! - restoreSavedPatchOn: aCanvas - "Clear the changed flag and restore the part of the given canvas under this hand from the previously saved patch. If necessary, handle the transition to using the hardware cursor." - hasChanged _ false. - savedPatch ifNotNil: [ - aCanvas restorePatch: savedPatch. - submorphs notEmpty ifTrue: [ ^ self ]. - "Make the transition to using hardware cursor. Clear savedPatch and - report one final damage rectangle to erase the image of the software cursor." - " owner invalidateDisplayRect: (savedPatch offset extent: savedPatch extent) from: nil." - self - invalidateDisplayRect: (self morphPosition extent: extent) - fromSubmorph: nil - for: self. - Cursor currentCursor == Cursor defaultCursor ifFalse: [ Cursor defaultCursor activateCursor ]. - "show hardware cursor" - savedPatch _ nil ].! ! -!DamageRecorder methodsFor: 'testing' stamp: 'jmv 8/4/2020 15:10:59' prior: 50462807! - updateIsNeeded - "Return true if the display needs to be updated. - Note: This could give a false positive (i.e. answer true) if invalidRects is not empty but it only contains nils. - Senders should be aware of this." - ^ totalRepaint or: [ self pvtAccessProtect critical: [damageByRoot notEmpty or: [invalidRects notEmpty]] ].! ! -!DamageRecorder methodsFor: 'private' stamp: 'jmv 8/4/2020 15:17:45' prior: 50538508! - pvtInnerRecordInvalidRect: requestedRect for: aRootMorph - "Record the given rectangle in my damage list, a list of rectangular areas of the display that should be redraw on the next display cycle. - Rectangles are specified in world coordinates (might be not the same as Display coordinates if there is some origin set on some canvas. Usually there will be none, but we can't be sure) - aRootMorph is the top owner of the morph originally reporting requestedRect. It might be nil if irrelevant. - " - "Details: Damaged rectangles are often identical or overlap significantly. In these cases, we merge them to reduce the number of damage rectangles that must be processed when the display is updated. Moreover, above a certain threshold, we ignore the individual rectangles completely, and simply do a complete repaint on the next cycle. - jmv: Important. There should be no overlapping rectangles in the list. If there are, translucent morphs might be drawn several times, with visible defects. - WRT performance, the different paths for various intersections seem a bit complicated. I could not find strong evidence of the best way. - Leave it as it is right now." - | newRect mergeRect indexToReuse | - totalRepaint ifTrue: [ ^ self ]. - "planning full repaint; don't bother collecting damage" - indexToReuse _ nil. - newRect _ requestedRect encompassingIntegerRectangle. -"En el futuro no va a poder ser nil" - aRootMorph ifNotNil: [ - damageByRoot at: aRootMorph put: - (damageByRoot at: aRootMorph - ifPresent: [:r | r quickMerge: newRect] - ifAbsent:[newRect]) ]. - invalidRects withIndexDo: [ :oldRect :index | - oldRect - ifNil: [ indexToReuse ifNil: [ indexToReuse _ index ]] - ifNotNil: [ - "No two rectangles should intersect" - (oldRect intersects: newRect) ifTrue: [ - "newRect already in. Nothing to do then." - (oldRect containsRect: newRect) ifTrue: [ ^ self ]. - "Some oldRect included in newRect. Remove it and continue, as newRect could still intersect others." - (newRect containsRect: oldRect) ifTrue: [ - invalidRects - at: index - put: nil. - "Effectively like 'invalidRects remove: rect', but without performance penalty." - indexToReuse ifNil: [ indexToReuse _ index ]]. - "Merge rectangles if they overlap significantly, i.e. if the merge is not much larger than separated rectangles." - mergeRect _ (oldRect origin min: newRect origin) corner: (oldRect corner max: newRect corner). - mergeRect area > (newRect area + oldRect area * 2) - ifTrue: [ - "Avoid intersections!!" - newRect - areasOutside: oldRect - do: [ :nonIntersection | - "We have brand new newRects. Start all over with each of them." - self pvtInnerRecordInvalidRect: nonIntersection for: nil ]. - "newRect no longer needed, then." - ^ self ] - ifFalse: [ - "Merge into newRect, as any overlap with forecoming rectangles in the iteration is detected and treated." - newRect _ mergeRect. - invalidRects - at: index - put: nil. - "Effectively like 'invalidRects remove: rect', but without performance penalty." - indexToReuse ifNil: [ indexToReuse _ index ]]]]]. - invalidRects size >= 10 ifTrue: [ - "if there are too many separate areas, merge them all" - mergeRect _ Rectangle merging: invalidRects. - invalidRects removeAll. - mergeRect ifNotNil: [ invalidRects addLast: mergeRect ]. - indexToReuse _ nil ]. - "Add the given rectangle to the damage list" - indexToReuse - ifNil: [ invalidRects addLast: newRect ] - ifNotNil: [ - invalidRects - at: indexToReuse - put: newRect ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/4/2020 15:12:44' prior: 50538747! - updateHandsDisplayBounds: aPasteUpMorph addDamageTo: aDamageRecorder - "Update displayBounds for carried morphs if never set. - Useful for new morph, that are created and attached to the hand." - - aPasteUpMorph handsDo: [ :hand | - self into: hand. - hand submorphsDo: [ :morph | - self updateDisplayBounds: morph ]. - aDamageRecorder recordInvalidRect: hand displayFullBounds for: hand. - self outOfMorph ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4335-DamageRecorder-redesign-JuanVuletich-2020Aug04-19h27m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4335] on 5 August 2020 at 12:10:32 am'! -!Morph methodsFor: 'drawing' stamp: 'jmv 8/4/2020 11:10:14'! - addPossiblyUncoveredAreasIn: aRectangle to: aCollection - "Answer an array of rectangles encompassing those areas in aRectangle not completely - covered by self. - All areas that might possibly be uncovered must be included." - " CREO QUE NO, que me conformo con optimizar ventanas. O quizas RectangleLike. Ver."" - (self isOrthoRectangularMorph and: [ self isOpaqueMorph ]) ifTrue: [ - aRectangle areasOutside: self morphBoundsInWorld do: [ :r | aCollection add: r ]. - ^self ]. - " - aCollection add: aRectangle! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 8/4/2020 11:09:53' overrides: 50539188! - addPossiblyUncoveredAreasIn: aRectangle to: aCollection - "Answer an array of rectangles encompassing those areas in aRectangle not completely - covered by self. These are the areas that might require further drawing (of morphs below us) - All areas that might possibly be uncovered must be included." - | bounds radious | - color mightBeTranslucent ifTrue: [ - aCollection add: aRectangle. - ^self ]. - - bounds _ self displayBounds. - bounds ifNil: [ - aCollection add: aRectangle. - ^self ]. - - "Solid rectangle. - This will be the fastest in many cases. So, please disable rounded corners if on slow hardware!!" - Theme current roundWindowCorners ifFalse: [ - aRectangle areasOutside: bounds do: [ :rect | aCollection add: rect ]. - ^self ]. - - "The solid rectangle does not include the corners. - Report a couple of rows (top and bottom) or columns (left and right) as uncovered areas. - We could also try to be more careful and answer each rounded corner... - Right now, report top and bottom rows as uncovered areas" - radious _ Theme current roundedWindowRadius. - aRectangle areasOutside: (bounds insetBy: 0@radious) do: [ :rect | aCollection add: rect ]! ! -!DamageRecorder methodsFor: 'recording' stamp: 'jmv 8/4/2020 22:07:50'! - damageReportedNotVisibleAndCarriedByHand - | answer | - answer _ OrderedCollection new. - self pvtAccessProtect critical: [ - damageByRoot keysAndValuesDo: [ :m :r | - (m visible not or: [m owner isNil or: [m owner is: #HandMorph]]) ifTrue: [ - answer add: r]]]. - ^answer! ! -!DamageRecorder methodsFor: 'recording' stamp: 'jmv 8/4/2020 19:33:01'! - reset - self pvtAccessProtect critical: [ - self pvtReset ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/4/2020 21:40:28'! - updateHandsDisplayBounds: aPasteUpMorph - "Update displayBounds for carried morphs if never set. - Useful for new morph, that are created and attached to the hand." - - aPasteUpMorph handsDo: [ :hand | - hand hasSubmorphs ifTrue: [ - self into: hand. - hand submorphsDo: [ :morph | - self updateDisplayBounds: morph ]. - self outOfMorph ]]! ! -!DisplayScreen methodsFor: 'displaying' stamp: 'jmv 8/4/2020 21:44:28' prior: 16835136! - flash: aRectangle - "Flash the area of the screen defined by the given rectangle." - - self reverse: aRectangle. - self forceToScreen: aRectangle. - (Delay forMilliseconds: 100) wait. - self reverse: aRectangle. - self forceToScreen: aRectangle. - (Delay forMilliseconds: 100) wait.! ! -!TranscriptWindow class methodsFor: 'GUI building' stamp: 'jmv 8/4/2020 20:45:45' prior: 50470325! - openTranscript - " - TranscriptWindow openTranscript - " - | win m | - win _ TranscriptWindow new. - win - setLabel: 'Transcript'; - model: Transcript. - m _ TranscriptMorph new. - win layoutMorph addMorph: m proportionalHeight: 1. - win model when: #redraw send: #redrawNeeded to: m. - ^ win openInWorld. -! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/4/2020 22:07:58' prior: 50538027! - drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rootMorphs rootMorphsDamage allDamage | - "Update #displayBounds for all dirty morphs (marked as such with #redrawNeeded). - Also add the updated bounds to aDamageRecorder, and update bounds of morphs carried by hand." - self updatingMorphBoundsDo: [ - aPasteUpMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - self updateHandsDisplayBounds: aPasteUpMorph ]. - - rootMorphs _ aPasteUpMorph privateSubmorphs. - rootMorphsDamage _ Array new: rootMorphs size. - allDamage _ aDamageRecorder damageReportedNotVisibleAndCarriedByHand. - - "Iterate from front to back" - 1 to: rootMorphs size do: [ :i | | morph morphBounds morphDamage | - morph _ rootMorphs at: i. - morph visible ifTrue: [ - morphBounds _ morph displayFullBounds. - morphDamage _ OrderedCollection new. - (aDamageRecorder damageReportedFor: morph) ifNotNil: [ :r | - morphDamage add: r ]. - allDamage do: [ :r | | ri | - ri _ r intersect: morphBounds. - ri hasPositiveExtent ifTrue: [ - morphDamage add: ri ]]. - 1 to: i-1 do: [ :j | | morphBefore oldMorphDamage | - oldMorphDamage _ morphDamage. - morphDamage _ OrderedCollection new. - morphBefore _ rootMorphs at: j. - oldMorphDamage do: [ :r | - morphBefore addPossiblyUncoveredAreasIn: r to: morphDamage ]]. - (Rectangle merging: morphDamage) ifNotNil: [ :morphDamageRect | - rootMorphsDamage at: i put: morphDamageRect. - morph addPossiblyUncoveredAreasIn: morphDamageRect to: allDamage ]]]. - - "Draw World" - allDamage do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - "Iterate from back to front." - rootMorphs size to: 1 by: -1 do: [ :i | | morph morphBounds morphDamage | - morph _ rootMorphs at: i. - morphBounds _ morph displayFullBounds. - morphDamage _ rootMorphsDamage at: i. - allDamage do: [ :r | | intersection | - intersection _ r intersect: morphBounds. - intersection hasPositiveExtent ifTrue: [ - morphDamage _ intersection quickMerge: morphDamage ]]. - morphDamage ifNotNil: [ - self newClipRect: morphDamage. - self fullDraw: morph. - allDamage add: morphDamage ]]. - - aDamageRecorder reset. - ^ allDamage! ! - -MorphicCanvas removeSelector: #updateHandsDisplayBounds:addDamageTo:! - -!methodRemoval: MorphicCanvas #updateHandsDisplayBounds:addDamageTo: stamp: 'Install-4336-DamageRecorder-redesign-JuanVuletich-2020Aug05-00h08m-jmv.001.cs.st 8/5/2020 22:21:45'! -updateHandsDisplayBounds: aPasteUpMorph addDamageTo: aDamageRecorder - "Update displayBounds for carried morphs if never set. - Useful for new morph, that are created and attached to the hand." - - aPasteUpMorph handsDo: [ :hand | - self into: hand. - hand submorphsDo: [ :morph | - self updateDisplayBounds: morph ]. - aDamageRecorder recordInvalidRect: hand displayFullBounds for: hand. - self outOfMorph ]! - -DamageRecorder removeSelector: #damageReportedNotVisibleMorphs! - -!methodRemoval: DamageRecorder #damageReportedNotVisibleMorphs stamp: 'Install-4336-DamageRecorder-redesign-JuanVuletich-2020Aug05-00h08m-jmv.001.cs.st 8/5/2020 22:21:45'! -damageReportedNotVisibleMorphs - | answer | - answer _ OrderedCollection new. - self pvtAccessProtect critical: [ - damageByRoot keysAndValuesDo: [ :m :r | - (m visible not or: [m owner isNil]) ifTrue: [ - answer add: r]]]. - ^answer! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4336-DamageRecorder-redesign-JuanVuletich-2020Aug05-00h08m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4337] on 5 August 2020 at 12:40:43 am'! - -Object subclass: #DamageRecorder - instanceVariableNames: 'invalidRects totalRepaint drSemaphore damageByRoot ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #DamageRecorder category: #'Morphic-Support' stamp: 'Install-4337-DamageRecorder-redesign-JuanVuletich-2020Aug05-00h27m-jmv.001.cs.st 8/5/2020 22:21:45'! -Object subclass: #DamageRecorder - instanceVariableNames: 'invalidRects totalRepaint drSemaphore damageByRoot' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! -!WorldState methodsFor: 'canvas' stamp: 'jmv 8/5/2020 00:37:39' prior: 16945701! - clearCanvas - canvas _ nil. - damageRecorder _ DamageRecorder new.! ! -!WorldState methodsFor: 'canvas' stamp: 'jmv 8/5/2020 00:37:47' prior: 50531450! - setCanvas: aMorphicCanvas - canvas _ aMorphicCanvas. - canvas world: world. - damageRecorder - ifNil: [ damageRecorder _ DamageRecorder new].! ! -!DamageRecorder methodsFor: 'initialization' stamp: 'jmv 8/5/2020 00:37:05' prior: 50538682 overrides: 16896425! - initialize - super initialize. - damageByRoot _ IdentityDictionary new.! ! -!DamageRecorder methodsFor: 'recording' stamp: 'jmv 8/5/2020 00:39:27' prior: 50539257! - reset - "Clear the damage list." - self pvtAccessProtect critical: [ - damageByRoot removeAll ].! ! -!DamageRecorder methodsFor: 'testing' stamp: 'jmv 8/5/2020 00:36:52' prior: 50539036! - updateIsNeeded - "Return true if the display needs to be updated." - ^ self pvtAccessProtect critical: [damageByRoot notEmpty]! ! -!DamageRecorder methodsFor: 'private' stamp: 'jmv 8/5/2020 00:36:33' prior: 50539049! - pvtInnerRecordInvalidRect: requestedRect for: aRootMorph - "Record the given rectangle in my damage list, a list of rectangular areas of the display that should be redraw on the next display cycle." - | newRect | - newRect _ requestedRect encompassingIntegerRectangle. - damageByRoot at: aRootMorph put: - (damageByRoot at: aRootMorph - ifPresent: [:r | r quickMerge: newRect] - ifAbsent:[newRect])! ! - -DamageRecorder removeSelector: #pvtReset! - -!methodRemoval: DamageRecorder #pvtReset stamp: 'Install-4337-DamageRecorder-redesign-JuanVuletich-2020Aug05-00h27m-jmv.001.cs.st 8/5/2020 22:21:45'! -pvtReset - "Clear the damage list." - invalidRects removeAll. - totalRepaint _ false. - damageByRoot removeAll.! - -DamageRecorder removeSelector: #doFullRepaint! - -!methodRemoval: DamageRecorder #doFullRepaint stamp: 'Install-4337-DamageRecorder-redesign-JuanVuletich-2020Aug05-00h27m-jmv.001.cs.st 8/5/2020 22:21:45'! -doFullRepaint - "Record that a full redisplay is needed. No further damage rectangles will be recorded until after the next reset." - - ^ totalRepaint _ true. -! - -DamageRecorder removeSelector: #invalidRectsFullBounds:! - -!methodRemoval: DamageRecorder #invalidRectsFullBounds: stamp: 'Install-4337-DamageRecorder-redesign-JuanVuletich-2020Aug05-00h27m-jmv.001.cs.st 8/5/2020 22:21:45'! -invalidRectsFullBounds: aRectangle - "Return a collection of damaged rectangles for the given canvas. Take only intersection with aRectangle. - If a total repaint has been requested, return the given rectangle. - Forget about all damage." - | answer | - answer _ totalRepaint ifTrue: [ Array with: aRectangle ]. - self pvtAccessProtect critical: [ - answer ifNil: [ - answer _ OrderedCollection new. - invalidRects do: [ :r | - r ifNotNil: [ - (aRectangle containsRect: r) - ifTrue: [ answer add: r ] - ifFalse: [ answer add: (r intersect: aRectangle) ]. - ]]]. - self pvtReset ]. - ^ answer.! - -WorldState removeSelector: #doFullRepaint! - -!methodRemoval: WorldState #doFullRepaint stamp: 'Install-4337-DamageRecorder-redesign-JuanVuletich-2020Aug05-00h27m-jmv.001.cs.st 8/5/2020 22:21:45'! -doFullRepaint - - damageRecorder doFullRepaint -! - -PasteUpMorph removeSelector: #redrawNeeded! - -!methodRemoval: PasteUpMorph #redrawNeeded stamp: 'Install-4337-DamageRecorder-redesign-JuanVuletich-2020Aug05-00h27m-jmv.001.cs.st 8/5/2020 22:21:45'! -redrawNeeded - "Report that the area occupied by this morph should be redrawn." - - self == self world - ifTrue: [worldState doFullRepaint] - ifFalse: [super redrawNeeded] -! - -Object subclass: #DamageRecorder - instanceVariableNames: 'drSemaphore damageByRoot' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #DamageRecorder category: #'Morphic-Support' stamp: 'Install-4337-DamageRecorder-redesign-JuanVuletich-2020Aug05-00h27m-jmv.001.cs.st 8/5/2020 22:21:45'! -Object subclass: #DamageRecorder - instanceVariableNames: 'drSemaphore damageByRoot' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4337-DamageRecorder-redesign-JuanVuletich-2020Aug05-00h27m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4337] on 5 August 2020 at 11:37:36 am'! -!Morph methodsFor: 'drawing' stamp: 'jmv 8/5/2020 11:34:38' prior: 50537621! - visible: aBoolean - "set the 'visible' attribute of the receiver to aBoolean - Store value of 'hidden', because flags default to false." - - self visible == aBoolean - ifTrue: [ ^ self ]. - self redrawNeeded. - self privateFlagAt: 3 put: aBoolean not. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/5/2020 11:27:12' prior: 50539301! - drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rootMorphs rootMorphsDamage allDamage | - "Update #displayBounds for all dirty morphs (marked as such with #redrawNeeded). - Also add the updated bounds to aDamageRecorder, and update bounds of morphs carried by hand." - self updatingMorphBoundsDo: [ - aPasteUpMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - self updateHandsDisplayBounds: aPasteUpMorph ]. - - rootMorphs _ aPasteUpMorph privateSubmorphs. - rootMorphsDamage _ Array new: rootMorphs size. - allDamage _ aDamageRecorder damageReportedNotVisibleAndCarriedByHand. - - "Iterate from front to back" - 1 to: rootMorphs size do: [ :i | | morph morphBounds morphDamage | - morph _ rootMorphs at: i. - morph visible ifTrue: [ - morphBounds _ morph displayFullBounds. - morphDamage _ OrderedCollection new. - (aDamageRecorder damageReportedFor: morph) ifNotNil: [ :r | - morphDamage add: r ]. - allDamage do: [ :r | | ri | - ri _ r intersect: morphBounds. - ri hasPositiveExtent ifTrue: [ - morphDamage add: ri ]]. - 1 to: i-1 do: [ :j | | morphBefore oldMorphDamage | - oldMorphDamage _ morphDamage. - morphDamage _ OrderedCollection new. - morphBefore _ rootMorphs at: j. - oldMorphDamage do: [ :r | - morphBefore addPossiblyUncoveredAreasIn: r to: morphDamage ]]. - (Rectangle merging: morphDamage) ifNotNil: [ :morphDamageRect | - rootMorphsDamage at: i put: morphDamageRect. - morph addPossiblyUncoveredAreasIn: morphDamageRect to: allDamage ]]]. - - "Draw World" - allDamage do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - "Iterate from back to front." - rootMorphs size to: 1 by: -1 do: [ :i | | morph morphBounds morphDamage | - morph _ rootMorphs at: i. - morph visible ifTrue: [ - morphBounds _ morph displayFullBounds. - morphDamage _ rootMorphsDamage at: i. - allDamage do: [ :r | | intersection | - intersection _ r intersect: morphBounds. - intersection hasPositiveExtent ifTrue: [ - morphDamage _ intersection quickMerge: morphDamage ]]. - morphDamage ifNotNil: [ - self newClipRect: morphDamage. - self fullDraw: morph. - allDamage add: morphDamage ]]]. - - aDamageRecorder reset. - ^ allDamage! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4338-DamageRecorder-redesign-JuanVuletich-2020Aug05-11h37m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4338] on 5 August 2020 at 8:48:09 pm'! -!Morph methodsFor: 'updating' stamp: 'jmv 8/5/2020 12:17:02'! - invalidateBounds - "Report that the area occupied by this morph should be redrawn, - but most likely we are not going to be redrawn on it, or maybe we'll not be fully visible. See senders." - - self invalidateDisplayRect: self displayBoundsOrBogus fromSubmorph: nil for: owner.! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 8/5/2020 12:23:18' prior: 50539575! - visible: aBoolean - "set the 'visible' attribute of the receiver to aBoolean - Store value of 'hidden', because flags default to false." - - self visible == aBoolean - ifTrue: [ ^ self ]. - aBoolean - ifTrue: [ self redrawNeeded ] - ifFalse: [ self invalidateBounds ]. - self privateFlagAt: 3 put: aBoolean not. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ].! ! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'jmv 8/5/2020 12:04:47' prior: 16876951! - removeMorph: aMorph - "Remove the given morph from my submorphs" - - aMorph owner == self ifFalse: [^self]. - aMorph redrawNeeded. - self privateRemove: aMorph. - aMorph privateOwner: nil. - self removedMorph: aMorph. - self someSubmorphPositionOrExtentChanged.! ! -!Morph methodsFor: 'private' stamp: 'jmv 8/5/2020 14:53:22' prior: 50538223! - privateAddAllMorphs: aCollection atIndex: index - "Private. Add aCollection of morphs to the receiver" - | myWorld itsWorld otherSubmorphs | - (aCollection allSatisfy: [ :m | self canAdd: m]) ifFalse: [ - (self confirm: 'Some requested morph requires VectorGraphics support. Do you want to install and activate it?') - ifTrue: [ - Feature require: 'VectorGraphics'. - MorphicCanvas activeSubclass: (Smalltalk at: #HybridCanvas) ] - ifFalse: [ - ^self error: 'We can''t add requested morphs.' ]]. - myWorld _ self world. - otherSubmorphs _ submorphs copyWithoutAll: aCollection. - (index between: 0 and: otherSubmorphs size) - ifFalse: [^ self error: 'index out of range']. - index = 0 - ifTrue:[ submorphs _ aCollection asArray, otherSubmorphs] - ifFalse:[ index = otherSubmorphs size - ifTrue:[ submorphs _ otherSubmorphs, aCollection] - ifFalse:[ submorphs _ otherSubmorphs copyReplaceFrom: index + 1 to: index with: aCollection ]]. - aCollection do: [:m | | itsOwner | - itsOwner _ m owner. - itsOwner ifNotNil: [ - itsWorld _ m world. - (itsWorld == myWorld) ifFalse: [ - itsWorld ifNotNil: [m redrawNeeded]]. - (itsOwner ~~ self) ifTrue: [ - m owner privateRemove: m. - m owner removedMorph: m ]]. - m privateOwner: self. - myWorld ifNotNil: [m redrawNeeded]. - (myWorld == itsWorld) ifFalse: [m intoWorld: myWorld]. - itsOwner == self ifFalse: [ - self addedMorph: m. - m noteNewOwner: self ]. - ]. - self someSubmorphPositionOrExtentChanged! ! -!Morph methodsFor: 'private' stamp: 'jmv 8/5/2020 14:53:05' prior: 50538265! - privateAddMorph: aMorph atIndex: index - - | oldIndex myWorld itsWorld oldOwner | - (self canAdd: aMorph) ifFalse: [ - (self confirm: 'The requested morph requires VectorGraphics support. Do you want to install and activate it?') - ifTrue: [ - Feature require: 'VectorGraphics'. - MorphicCanvas activeSubclass: (Smalltalk at: #HybridCanvas) ] - ifFalse: [ - ^self error: 'We can''t add requested morph.' ]]. - ((index >= 1) and: [index <= (submorphs size + 1)]) - ifFalse: [^ self error: 'index out of range']. - myWorld _ self world. - oldOwner _ aMorph owner. - (oldOwner == self and: [(oldIndex _ submorphs indexOf: aMorph) > 0]) ifTrue:[ - "aMorph's position changes within in the submorph chain" - oldIndex < index ifTrue:[ - "moving aMorph to back" - submorphs replaceFrom: oldIndex to: index-2 with: submorphs startingAt: oldIndex+1. - submorphs at: index-1 put: aMorph. - ] ifFalse:[ - "moving aMorph to front" - oldIndex-1 to: index by: -1 do:[:i| - submorphs at: i+1 put: (submorphs at: i)]. - submorphs at: index put: aMorph. - ]. - ] ifFalse:[ - "adding a new morph" - oldOwner ifNotNil:[ - itsWorld _ aMorph world. - itsWorld ifNotNil: [aMorph invalidateBounds]. - oldOwner privateRemove: aMorph. - oldOwner removedMorph: aMorph. - ]. - aMorph privateOwner: self. - submorphs _ submorphs copyReplaceFrom: index to: index-1 with: (Array with: aMorph). - (itsWorld == myWorld) ifFalse: [aMorph intoWorld: myWorld]. - ]. - myWorld ifNotNil: [aMorph invalidateBounds]. - self someSubmorphPositionOrExtentChanged. - oldOwner == self ifFalse: [ - self addedMorph: aMorph. - aMorph noteNewOwner: self ]. -! ! -!Morph methodsFor: 'private' stamp: 'jmv 8/5/2020 14:53:11' prior: 50538312! - privateAddMorph: aMorph atIndex: index position: aPoint - - | oldIndex myWorld itsWorld oldOwner | - (self canAdd: aMorph) ifFalse: [ - (self confirm: 'The requested morph requires VectorGraphics support. Do you want to install and activate it?') - ifTrue: [ - Feature require: 'VectorGraphics'. - MorphicCanvas activeSubclass: (Smalltalk at: #HybridCanvas) ] - ifFalse: [ - ^self error: 'We can''t add requested morph.' ]]. - ((index >= 1) and: [index <= (submorphs size + 1)]) - ifFalse: [^ self error: 'index out of range']. - myWorld _ self world. - oldOwner _ aMorph owner. - (oldOwner == self and: [(oldIndex _ submorphs indexOf: aMorph) > 0]) ifTrue: [ - "aMorph's position changes within in the submorph chain" - oldIndex < index ifTrue:[ - "moving aMorph to back" - submorphs replaceFrom: oldIndex to: index-2 with: submorphs startingAt: oldIndex+1. - submorphs at: index-1 put: aMorph. - ] ifFalse:[ - "moving aMorph to front" - oldIndex-1 to: index by: -1 do:[:i| - submorphs at: i+1 put: (submorphs at: i)]. - submorphs at: index put: aMorph. - ]. - aMorph privatePosition: aPoint. - ] ifFalse: [ - "adding a new morph" - oldOwner ifNotNil: [ - itsWorld _ aMorph world. - itsWorld ifNotNil: [aMorph redrawNeeded]. - oldOwner privateRemove: aMorph. - oldOwner removedMorph: aMorph. - ]. - aMorph privateOwner: self. - submorphs _ submorphs copyReplaceFrom: index to: index-1 with: (Array with: aMorph). - aMorph privatePosition: aPoint. - (itsWorld == myWorld) ifFalse: [aMorph intoWorld: myWorld]. - ]. - myWorld ifNotNil: [aMorph redrawNeeded]. - self someSubmorphPositionOrExtentChanged. - oldOwner == self ifFalse: [ - self addedMorph: aMorph. - aMorph noteNewOwner: self ]! ! -!Morph methodsFor: 'previewing' stamp: 'jmv 8/5/2020 12:21:15' prior: 50538159! - endPreview - - self previewing ifTrue: [ - owner notNil ifTrue: [ - self visible: self visibleBeforePreview. - owner addMorph: self inFrontOf: self morphBehindBeforePreview ]. - self previewing: false. ]! ! -!PasteUpMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 8/5/2020 14:55:30' prior: 50538210! - canHandle: aMorph - self canvas ifNil: [^false]. - ^self canvas canDraw: aMorph! ! -!DamageRecorder methodsFor: 'recording' stamp: 'jmv 8/5/2020 11:44:26' prior: 50539246! - damageReportedNotVisibleAndCarriedByHand - | answer | - answer _ OrderedCollection new. - self pvtAccessProtect critical: [ - damageByRoot keysAndValuesDo: [ :m :r | - (m isNil or: [ - m visible not or: [m owner isNil or: [m owner is: #HandMorph]]]) ifTrue: [ - answer add: r]]]. - ^answer! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4339-DamageRecorder-redesign-JuanVuletich-2020Aug05-20h47m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4256] on 31 July 2020 at 2:29:03 pm'! -!SystemDictionary methodsFor: 'retrieving' stamp: 'tsl 7/31/2020 14:28:14' prior: 50525367! - allMethodsInCategory: category - | aCollection | - aCollection := SortedCollection new. - self allBehaviorsDo: [ :x | - (x organization listAtCategoryNamed: category) do: [ :sel | - aCollection add: (MethodReference class: x selector: sel)]]. - ^aCollection! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4340-allMethodsInCategory-fix-ThiagoLino-2020Jul31-14h28m-tsl.001.cs.st----! - -'From Cuis 5.0 [latest update: #4241] on 5 August 2020 at 3:18:32 pm'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 8/5/2020 15:15:39' prior: 50481226! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('AY' 'Angel Yan') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('bgs' 'Boris G. Shingarov') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('EB' 'Eric Brandwein') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('FGJ' 'Fernando Gasperi Jabalera') - #('FJG' 'Facundo Javier Gelatti') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hlsf' 'Hilaire Fernandes') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('KLG' 'Gerald Klix') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MM' 'Mariano Montone') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('pmon' 'Paolo Montrasi') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('sjd' 'Santiago Jose Dandois') - #('SLD' 'Steve Davies') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('ss' 'Sebastian Sujarchuk') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tsl' 'Thiago da Silva Lino') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4341-AddHilaireAndThiagoAsKnownUsers-JuanVuletich-2020Aug05-15h14m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4319] on 31 July 2020 at 4:16:04 pm'! - -"Change Set: 4342-RemoveUnusedIvarFromHandMorph-JuanVuletich-2020Jul31-16h13m -Date: 31 July 2020 -Author: Juan Vuletich - -Modifying instance variables definition of core to Morphs is tricky. Hence this preamble." -| ui b cs | -Utilities authorInitialsPerSe ifNil: [ Utilities setAuthor ]. -(nil confirm: 'In order to modify instance variables of HandMorph, -we need to restart the User Interface process. -You''ll need to re-start the image update to install later updates.') ifFalse: [ self halt ]. -[ - ui _ UISupervisor ui. - UISupervisor stopUIProcess. - b _ ClassBuilder isSilent. - ClassBuilder beSilent: true. - ClassBuilder new - superclass: RectangleLikeMorph - subclass: #HandMorph - instanceVariableNames: 'mouseFocus keyboardFocus mouseClickState mouseOverHandler lastMouseEvent hasChanged savedPatch lastEventBuffer lastKeyDownValue lastMouseEventTime prevFullBounds grabMorphData lastPosition' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'. - ClassBuilder beSilent: b. - UISupervisor spawnNewMorphicProcessFor: ui. - ChangeSet installing: '4342-RemoveUnusedIvarFromHandMorph-JuanVuletich-2020Jul31-16h13m-jmv.001.cs.st' do: []. - cs _ ChangeSet changeSetForBaseSystem. - (cs name beginsWith: '4342') ifTrue: [ - ChangeSet removeChangeSet: cs ]. - 'Done removing unused ivar damageRecorder from HandMorph.' print. - 'Installed ChangeSet: 4342-RemoveUnusedIvarFromHandMorph-JuanVuletich-2020Jul31-16h13m-jmv.001.cs.st' print. - 'Please restart [Install New Updates].' print. -] forkAt: 41! - -----SNAPSHOT----(5 August 2020 22:21:58) Cuis5.0-4342-32.image priorSource: 6254731! - -----STARTUP---- (19 August 2020 10:24:08) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4342-32.image! - - -'From Cuis 5.0 [latest update: #4342] on 6 August 2020 at 2:30:57 pm'! -!PasteUpMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 8/6/2020 14:30:22' prior: 50539880! - canHandle: aMorph - - ^self canvas canDraw: aMorph! ! -!WorldState methodsFor: 'canvas' stamp: 'jmv 8/6/2020 14:29:23' prior: 50539438! - clearCanvas - self setCanvas: Display getCanvas. - damageRecorder _ DamageRecorder new.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4343-Canvas-AlwaysHaveOne-JuanVuletich-2020Aug06-14h22m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4343] on 6 August 2020 at 3:29:00 pm'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/6/2020 15:22:52' prior: 50539588! - drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rootMorphs rootMorphsDamage allDamage | - "Update #displayBounds for all dirty morphs (marked as such with #redrawNeeded). - Also add the updated bounds to aDamageRecorder, and update bounds of morphs carried by hand." - self updatingMorphBoundsDo: [ - aPasteUpMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - self updateHandsDisplayBounds: aPasteUpMorph ]. - - rootMorphs _ aPasteUpMorph privateSubmorphs. - rootMorphsDamage _ Array new: rootMorphs size. - - allDamage _ self drawWorldComputeDamage: aPasteUpMorph repair: aDamageRecorder rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage. - - "Draw World" - allDamage do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - self drawWorld: aPasteUpMorph rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage allDamage: allDamage. - - aDamageRecorder reset. - ^ allDamage! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/6/2020 15:24:32'! - drawWorld: aPasteUpMorph rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage allDamage: allDamage - "Redraw the damaged areas. - Draw each morph just once, merging rectanges to be repaired as needed." - - | morph morphBounds morphDamage | - - "Iterate from back to front." - rootMorphs size to: 1 by: -1 do: [ :i | - morph _ rootMorphs at: i. - morph visible ifTrue: [ - morphBounds _ morph displayFullBounds. - morphDamage _ rootMorphsDamage at: i. - allDamage do: [ :r | | intersection | - intersection _ r intersect: morphBounds. - intersection hasPositiveExtent ifTrue: [ - morphDamage _ intersection quickMerge: morphDamage ]]. - morphDamage ifNotNil: [ - self newClipRect: morphDamage. - self fullDraw: morph. - allDamage add: morphDamage ]]].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/6/2020 15:28:40'! - drawWorldComputeDamage: aPasteUpMorph repair: aDamageRecorder rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage - "Iterate front to back while computing damage to actually repair for each morph, and for world background." - - | allDamage morph morphBounds morphDamage oldMorphDamage reuse ri morphBefore | - morphDamage _ OrderedCollection new. - oldMorphDamage _ OrderedCollection new. - allDamage _ aDamageRecorder damageReportedNotVisibleAndCarriedByHand. - "Iterate from front to back" - 1 to: rootMorphs size do: [ :i | - morph _ rootMorphs at: i. - morph visible ifTrue: [ - morphBounds _ morph displayFullBounds. - morphDamage removeAll. - (aDamageRecorder damageReportedFor: morph) ifNotNil: [ :r | - morphDamage add: r ]. - allDamage do: [ :r | - ri _ r intersect: morphBounds. - ri hasPositiveExtent ifTrue: [ - morphDamage add: ri ]]. - 1 to: i-1 do: [ :j | - reuse _ oldMorphDamage. - oldMorphDamage _ morphDamage. - morphDamage _ reuse removeAll. - morphBefore _ rootMorphs at: j. - oldMorphDamage do: [ :r | - morphBefore addPossiblyUncoveredAreasIn: r to: morphDamage ]]. - (Rectangle merging: morphDamage) ifNotNil: [ :morphDamageRect | - rootMorphsDamage at: i put: morphDamageRect. - morph addPossiblyUncoveredAreasIn: morphDamageRect to: allDamage ]]]. - - ^ allDamage! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4344-WorldDrawRefactor-JuanVuletich-2020Aug06-15h19m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4344] on 6 August 2020 at 5:47:04 pm'! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 8/6/2020 17:46:03' prior: 50539007! - restoreSavedPatchOn: aCanvas - "Clear the changed flag and restore the part of the given canvas under this hand from the previously saved patch. If necessary, handle the transition to using the hardware cursor." - hasChanged _ false. - savedPatch ifNotNil: [ - aCanvas restorePatch: savedPatch. - submorphs notEmpty ifTrue: [ ^ self ]. - "Make the transition to using hardware cursor. Clear savedPatch and - report one final damage rectangle to erase the image of the software cursor." - " owner invalidateDisplayRect: (savedPatch offset extent: savedPatch extent) from: nil." - self - invalidateDisplayRect: (self morphPosition extent: extent) - fromSubmorph: nil - for: nil. - Cursor currentCursor == Cursor defaultCursor ifFalse: [ Cursor defaultCursor activateCursor ]. - "show hardware cursor" - savedPatch _ nil ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4345-RemoveDragHandPointer-JuanVuletich-2020Aug06-17h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4344] on 6 August 2020 at 7:39:03 pm'! - -"Make all ids notNil" -Morph allSubInstances do: [ :m | (m instVarNamed: 'id') ifNil: [ m instVarNamed: 'id' put: 0 ]]! -!Morph methodsFor: 'accessing' stamp: 'jmv 8/6/2020 19:37:15' prior: 50537597! - morphId - "Non zero. Zero id means no Morph. - reserve lower 8 bits of numeric ivar for boolean flags." - " - Morph clearIds - " - | morphId | - morphId _ id >> 8. - morphId = 0 ifTrue: [ - LastMorphId isNil ifTrue: [ LastMorphId _ 0 ]. - LastMorphId _ LastMorphId + 1. - id _ LastMorphId << 8 + id. "Keep any flags" - morphId _ LastMorphId ]. - ^morphId! ! -!Morph methodsFor: 'caching' stamp: 'jmv 8/6/2020 19:36:23' prior: 50537616! - clearId - "But keep flags. - Morph clearIds - " - - id _ id bitAnd: 255.! ! -!Morph methodsFor: 'initialization' stamp: 'jmv 8/6/2020 19:31:28' prior: 50537635 overrides: 16896425! - initialize - "initialize the state of the receiver" - - owner _ nil. - submorphs _ #(). - location _ MorphicTranslation new. - id _ 0.! ! -!Morph methodsFor: 'private' stamp: 'jmv 8/6/2020 19:37:39' prior: 50537574! - privateFlagAt: bitIndex - "We can hold up to 8 1-bit flags. - Initial value of all flags is false." - - ^(id bitAt: bitIndex) = 1! ! -!Morph methodsFor: 'private' stamp: 'jmv 8/6/2020 19:37:46' prior: 50537581! - privateFlagAt: bitIndex put: aBoolean - "We can hold up to 8 1-bit flags. - Initial value of all flags is false." - - id _ id bitAt: bitIndex put: (aBoolean ifTrue: [1] ifFalse: [0])! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 8/6/2020 18:05:52' prior: 50536790! - savePatch: prevSavedPatch bounds: aRectangle - "Senders don't need to know any details of what is answered, but just store it for further calls, and calls to restorePatch:" - "Details: The previously used patch Form is recycled when possible to reduce the burden on storage management." - | savedPatch bb | - savedPatch _ prevSavedPatch. - ((savedPatch is: #Form) not or: [savedPatch extent ~= aRectangle extent]) - ifTrue: [ - "allocate new patch form if needed" - savedPatch _ Form extent: aRectangle extent depth: form depth ] - ifFalse: [ - savedPatch offset: 0@0 ]. - bb _ BitBlt toForm: savedPatch. - bb sourceForm: form; combinationRule: Form over; - sourceX: aRectangle left; sourceY: aRectangle top; - width: aRectangle width; height: aRectangle height; - copyBits. - savedPatch offset: aRectangle topLeft. - ^savedPatch! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Morph clearIds! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4346-MorphId-fix-JuanVuletich-2020Aug06-17h47m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4346] on 6 August 2020 at 9:43:13 pm'! -!Morph methodsFor: 'user interface' stamp: 'jmv 8/6/2020 21:41:56' prior: 16877042! - activateWindowAndSendTopToBack: aBoolean - - self owningWindow ifNotNil: [ :w | - w activateAndSendTopToBack: aBoolean]! ! -!SystemWindow methodsFor: 'top window' stamp: 'jmv 8/6/2020 21:40:32' prior: 50537956! - activateAndSendTopToBack: aBoolean - "Bring me to the front and make me able to respond to mouse and keyboard" - - | oldTop | - owner - ifNil: [^self "avoid spurious activate when drop in trash"]. - - self isTopWindow ifTrue: [ - self comeToFront. - ^self ]. - - oldTop _ TopWindow. - TopWindow _ self. - self redrawNeeded. - - oldTop ifNotNil: [ - oldTop redrawNeeded. - aBoolean ifTrue: [ - | bottomWindow | - bottomWindow _ oldTop owner submorphs reverse detect: [:one | one is: #SystemWindow]. - oldTop owner addMorph: oldTop behind: bottomWindow]]. - - self comeToFront. - - "Set keyboard focus" - self world ifNotNil: [ :w | - w activeHand newKeyboardFocus: self submorphToFocusKeyboard ]! ! -!HandMorph methodsFor: 'focus handling' stamp: 'jmv 8/6/2020 21:40:56' prior: 16851883! - activateNextWindow - - self nextFocusWindow ifNotNil: [ :w | - w activateAndSendTopToBack: true ]! ! -!HandMorph methodsFor: 'focus handling' stamp: 'jmv 8/6/2020 21:41:04' prior: 16851890! - activatePreviousWindow - - self previousFocusWindow ifNotNil: [ :w | - w activateAndSendTopToBack: false ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4347-ActivateWindow-JuanVuletich-2020Aug06-21h33m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4347] on 6 August 2020 at 10:10:41 pm'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/6/2020 22:08:50'! - drawWorld: aPasteUpMorph rects: allDamage - "Draw allDamage rects for aPasteUpMorph" - - allDamage do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/6/2020 22:09:08' prior: 50540220! - drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rootMorphs rootMorphsDamage allDamage | - "Update #displayBounds for all dirty morphs (marked as such with #redrawNeeded). - Also add the updated bounds to aDamageRecorder, and update bounds of morphs carried by hand." - self updatingMorphBoundsDo: [ - aPasteUpMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - self updateHandsDisplayBounds: aPasteUpMorph ]. - - rootMorphs _ aPasteUpMorph privateSubmorphs. - rootMorphsDamage _ Array new: rootMorphs size. - - allDamage _ self drawWorldComputeDamage: aPasteUpMorph repair: aDamageRecorder - rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage. - - self drawWorld: aPasteUpMorph rects: allDamage. - - self drawWorld: aPasteUpMorph rootMorphs: rootMorphs - rootMorphsDamage: rootMorphsDamage allDamage: allDamage. - - aDamageRecorder reset. - ^ allDamage! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4348-DrawWorld-refactor-JuanVuletich-2020Aug06-22h07m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4348] on 7 August 2020 at 4:23:03 pm'! -!LayoutMorph methodsFor: 'layout' stamp: 'KLG 8/7/2020 16:22:34' prior: 50521475! - layoutSubmorphsHorizontallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - - | visibleSubmorphs sumOfWidths theSeparation widthsArray - widthToAllocate leftOver nextX | - "Preconditions: self isRow & morphExtent >= minimumLayoutExtent" - (visibleSubmorphs := self submorphsToLayout reversed "Display Order") - ifEmpty: [ ^ self. " Nothing to layout, `sum` would fai" ]. - - theSeparation := self xSeparation. - - widthToAllocate := (boundsForLayout width - ((visibleSubmorphs size + 1) * theSeparation)). - widthsArray := self widthsFor: visibleSubmorphs within: widthToAllocate. - sumOfWidths := widthsArray sum: [ :w | w ] . - leftOver := widthToAllocate - sumOfWidths. - nextX := boundsForLayout origin x - + theSeparation - + (leftOver * (self axisEdgeWeight ifNil: [0.0])). "first X, edge shifted" -"Transcript log: 'first X=', nextX asString, ' leftOver=', leftOver asString; cr. -" 1 to: visibleSubmorphs size do: [ :index | | sm smX smWidth heightAndY newExtent | - sm := visibleSubmorphs at: index. - smX := nextX. - smWidth := widthsArray at: index. - nextX := smX + smWidth + theSeparation. - heightAndY := self offHorizontalMetricFor: sm withinExtent: boundsForLayout. - sm morphPosition: smX @ (heightAndY y). - newExtent := smWidth @ (heightAndY x). - (sm morphExtent = newExtent) ifFalse: [ sm morphExtent: newExtent ]. - ] -! ! -!LayoutMorph methodsFor: 'layout' stamp: 'KLG 8/7/2020 16:17:20' prior: 50521519! - layoutSubmorphsVerticallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - - | visibleSubmorphs sumOfHeights theSeparation heightsArray - heightToAllocate leftOver nextY | - "Preconditions: self isRow & morphExtent >= minimumLayoutExtent" - (visibleSubmorphs := self submorphsToLayout reversed "Display Order") - ifEmpty: [ ^ self. "Nothing to layout, besides `sum` below, would fail" ]. - - theSeparation := self ySeparation. - heightToAllocate := (boundsForLayout height - ((visibleSubmorphs size + 1) * theSeparation)). - heightsArray := self heightsFor: visibleSubmorphs within: heightToAllocate. - sumOfHeights := heightsArray sum: [ :w | w ] . - leftOver := heightToAllocate - sumOfHeights. - nextY := boundsForLayout origin y - + theSeparation - + (leftOver * (self axisEdgeWeight ifNil: [0.5])). "first Y, edge shifted" -"Transcript log: 'first Y=', nextY asString, ' leftOver=', leftOver asString; cr. -" 1 to: visibleSubmorphs size do: [ :index | | sm smY smHeight xAndWidth newExtent | - sm := visibleSubmorphs at: index. - smY := nextY. - smHeight := heightsArray at: index. - nextY := smY + smHeight + theSeparation. - xAndWidth := self offVerticalMetricFor: sm withinExtent: boundsForLayout. - sm morphPosition: (xAndWidth x) @ smY. - newExtent := (xAndWidth y) @ smHeight. - (sm morphExtent = newExtent) ifFalse: [ sm morphExtent: newExtent ]. - ] -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4349-LayoutMorphNoVisibleSubMorphs-GeraldKlix-2020Aug07-KLG.002.cs.st----! - -'From Cuis 5.0 [latest update: #4349] on 17 August 2020 at 1:45:32 pm'! -!PasteUpMorph methodsFor: 'initialization' stamp: 'jmv 8/17/2020 13:41:01'! - setCanvas - worldState setCanvas! ! -!WorldState methodsFor: 'canvas' stamp: 'jmv 8/17/2020 13:41:08'! - setCanvas - self setCanvas: Display getCanvas. - damageRecorder _ DamageRecorder new.! ! -!StrikeFont class methodsFor: 'class cached access' stamp: 'jmv 8/17/2020 12:48:37' prior: 50417608 overrides: 50510054! - releaseClassState - "Do not remove them in every image save (#releaseClassCachedState) to save startup time." - " - StrikeFont releaseClassState - " - "Deallocate synthetically derived copies of base fonts to save space" - self allInstancesDo: [ :sf | sf reset ]! ! -!Morph class methodsFor: 'initialize-release' stamp: 'jmv 8/17/2020 13:22:58' prior: 50510033 overrides: 50510054! - releaseClassState - - self allInstancesDo: [ :each | - each releaseCachedState. - each clearId ]. - LastMorphId _ nil.! ! -!PasteUpMorph methodsFor: 'geometry' stamp: 'jmv 8/17/2020 13:41:41' prior: 50337717 overrides: 16899309! - privateExtent: newExtent - - ^ (super privateExtent: newExtent) - ifTrue: [ - self buildMagnifiedBackgroundImage. - worldState ifNotNil: [ - worldState setCanvas ]]; - yourself! ! -!PasteUpMorph methodsFor: 'interaction loop' stamp: 'jmv 8/17/2020 13:41:37' prior: 50378678! - mainLoop - - - self clearWaitDelay. - self setCanvas. - [ - self doOneCycle. - Processor yield. - true ] - whileTrue: []! ! -!WorldState methodsFor: 'canvas' stamp: 'jmv 8/17/2020 13:42:46' prior: 50540207! - clearCanvas - canvas _ nil. - damageRecorder _ nil.! ! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 8/17/2020 13:41:43' prior: 50339476! - displayWorldSafely - "Update this world's display and keep track of errors during draw methods." - - [world displayWorld] ifError: [:err :rcvr | - "Handle a drawing error" - | errCtx errMorph | - errCtx _ thisContext. - [ - errCtx _ errCtx sender. - "Search the sender chain to find the morph causing the problem" - [errCtx notNil and: [ (errCtx receiver is: #Morph) not ]] - whileTrue:[errCtx _ errCtx sender]. - "If we're at the root of the context chain then we have a fatal drawing problem" - errCtx ifNil:[^self handleFatalDrawingError: err]. - errMorph _ errCtx receiver. - "If the morph causing the problem has already the #drawError flag set, - then search for the next morph above in the caller chain." - errMorph isKnownFailing - ] whileTrue. - errMorph drawingFails. - self setCanvas. - "Install the old error handler, so we can re-raise the error" - rcvr error: err. - ]! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/17/2020 13:41:33' prior: 50536825! - activeSubclass: aMorphicCanvasSubclass - ActiveSubclass _ aMorphicCanvasSubclass. - PasteUpMorph allInstancesDo: [ :w | w setCanvas ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4350-WorldStateFix-JuanVuletich-2020Aug17-13h44m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4349] on 16 August 2020 at 9:01:34 am'! -!Feature methodsFor: 'testing' stamp: 'jmv 8/16/2020 08:49:11'! - isLaterThan: aFeature - ^self version > aFeature version or: [ - self version = aFeature version and: [ - self revision > aFeature revision ]]! ! -!CodePackageList methodsFor: 'accessing' stamp: 'jmv 8/9/2020 19:02:18' prior: 16811249! - packageFullNames - - ^ packages collect: [ :each | each fullFileName ifNil: '---Never saved yet' ]! ! -!CodePackage methodsFor: 'accessing' stamp: 'jmv 8/9/2020 19:02:15' prior: 16810682! - fullFileName - - ^fullFileName! ! -!ChangeSet class methodsFor: 'services' stamp: 'jmv 8/16/2020 09:00:39' prior: 16799313! - installNewUpdates: updatesFileDirectory - - | warnUser | - (self newUpdates: updatesFileDirectory) do: [ :each | - self install: each ]. - - warnUser _ false. - CodePackage installedPackages keysAndValuesDo: [ :pckName :package | - package fullFileName ifNotNil: [ :fullFileName | | codePackageFile | - codePackageFile _ CodePackageFile onFileEntry: fullFileName asFileEntry. - (codePackageFile provides isLaterThan: package provides) ifTrue: [ - warnUser _ true. - package hasUnsavedChanges - ifTrue: [ 'Package: ', pckName, '. Package has unsaved changes, but there is a newer version of the file.' print ] - ifFalse: [ 'Package: ', pckName, '. There is a newer version than the currently loaded.' print ]]]]. - warnUser - ifTrue: [ - self inform: SystemVersion current version, ' - ', Smalltalk lastUpdateString, String newLineString, -'Some package(s) loaded in the image -have updated package file on disk. -Please see Transcript.' ] - ifFalse: [ - Smalltalk aboutThisSystem ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4351-WarnAboutUpdatedPackages-JuanVuletich-2020Aug16-08h45m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4351] on 18 August 2020 at 4:23:23 pm'! -!WorldState methodsFor: 'canvas' stamp: 'jmv 8/18/2020 16:13:52' prior: 50540671! -setCanvas - self setCanvas: Display getCanvas. - damageRecorder _ DamageRecorder new. - world redrawNeeded! ! -!Preferences class methodsFor: 'start up' stamp: 'jmv 8/18/2020 16:22:58' prior: 50370747! - checkLostChangesOnStartUp - ^ "self - valueOfFlag: #checkLostChangesOnStartUp - ifAbsent: [ true ]." false! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -(nil confirm: 'After this update, -we need to restart the User Interface process. -Please do World / Changes... / [Install New Updates] again.') ifFalse: [ self halt ]. -[ - ChangeSet installing: '4352-WorldStateCleanup-JuanVuletich-2020Jul31-16h13m-jmv.001.cs.st' do: []. - cs _ ChangeSet changeSetForBaseSystem. - (cs name beginsWith: '4352') ifTrue: [ - ChangeSet removeChangeSet: cs ]. - 'Installed ChangeSet: 4352-WorldStateCleanup-JuanVuletich-2020Jul31-16h13m-jmv.001.cs.st' print. - 'Please do World / Changes... / [Install New Updates] again.' print. -] forkAt: 39. -Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true.! - -----NOP----(19 August 2020 10:24:14) Cuis5.0-4342-32.image priorSource: 6673327! - -'From Cuis 5.0 [latest update: #4351] on 18 August 2020 at 4:34:06 pm'! -!Preferences class methodsFor: 'start up' stamp: 'HAW 9/9/2017 12:07:37' prior: 50540831! - checkLostChangesOnStartUp - ^ self - valueOfFlag: #checkLostChangesOnStartUp - ifAbsent: [ true ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4353-enableBackLostChangesOnStartup-JuanVuletich-2020Aug18-16h33m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4353] on 19 August 2020 at 9:30:04 am'! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/19/2020 09:25:26' prior: 50534890! - displayFullBounds - "Answer a rectangle that completely bounds receiver and submorphs when last drawn - (if the world was to be fully drawn, i.e. only to be used on a Canvas on the full world)." - - | answer | - answer _ self displayBounds. - answer ifNil: [ ^nil ]. - self submorphsDrawingOutsideReverseDo: [ :m | - answer _ answer quickMerge: m displayFullBounds ]. - ^answer! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/19/2020 09:27:55' prior: 50540284! - drawWorldComputeDamage: aPasteUpMorph repair: aDamageRecorder rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage - "Iterate front to back while computing damage to actually repair for each morph, and for world background." - - | allDamage morph morphDamage oldMorphDamage reuse ri morphBefore | - morphDamage _ OrderedCollection new. - oldMorphDamage _ OrderedCollection new. - allDamage _ aDamageRecorder damageReportedNotVisibleAndCarriedByHand. - "Iterate from front to back" - 1 to: rootMorphs size do: [ :i | - morph _ rootMorphs at: i. - morph displayFullBounds ifNotNil: [ :morphBounds | - morphDamage removeAll. - (aDamageRecorder damageReportedFor: morph) ifNotNil: [ :r | - morphDamage add: r ]. - allDamage do: [ :r | - ri _ r intersect: morphBounds. - ri hasPositiveExtent ifTrue: [ - morphDamage add: ri ]]. - 1 to: i-1 do: [ :j | - reuse _ oldMorphDamage. - oldMorphDamage _ morphDamage. - morphDamage _ reuse removeAll. - morphBefore _ rootMorphs at: j. - oldMorphDamage do: [ :r | - morphBefore addPossiblyUncoveredAreasIn: r to: morphDamage ]]. - (Rectangle merging: morphDamage) ifNotNil: [ :morphDamageRect | - rootMorphsDamage at: i put: morphDamageRect. - morph addPossiblyUncoveredAreasIn: morphDamageRect to: allDamage ]]]. - - ^ allDamage! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4354-avoidUnlikelyDrawWorldBreakage-JuanVuletich-2020Aug19-09h17m-jmv.001.cs.st----! - -----SNAPSHOT----(19 August 2020 10:24:24) Cuis5.0-4354-32.image priorSource: 6673327! - -----STARTUP---- (22 August 2020 11:12:59) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4354-32.image! - - -'From Cuis 5.0 [latest update: #4354] on 21 August 2020 at 10:39:26 am'! - -RectangleLikeMorph subclass: #HaloMorph - instanceVariableNames: 'target positionOffset angleOffset growingOrRotating haloBox scaleOffset ' - classVariableNames: 'HandleSize Icons ' - poolDictionaries: '' - category: 'Morphic-Halos'! - -!classDefinition: #HaloMorph category: #'Morphic-Halos' stamp: 'Install-4355-AutomaticallyScaleHalos-JuanVuletich-2020Aug21-10h36m-jmv.001.cs.st 8/22/2020 11:13:03'! -RectangleLikeMorph subclass: #HaloMorph - instanceVariableNames: 'target positionOffset angleOffset growingOrRotating haloBox scaleOffset' - classVariableNames: 'HandleSize Icons' - poolDictionaries: '' - category: 'Morphic-Halos'! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/21/2020 10:34:45'! - haloHandleSize - ^ Preferences standardListFont pointSize * 3 // 2 max: 16! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 8/21/2020 10:38:31' prior: 50535588! - addHandle: handleSpec - "Add a handle within the halo box as per the haloSpec, and set it up to respond to the given event by sending the given selector to the given recipient. Return the handle." - - | handle aPoint colorToUse form icon e | - aPoint _ self - positionIn: haloBox - horizontalPlacement: handleSpec horizontalPlacement - verticalPlacement: handleSpec verticalPlacement. - colorToUse _ Color colorFrom: handleSpec color. - handle _ HaloHandleMorph new color: colorToUse. - self addMorph: handle. - e _ Preferences haloHandleSize asPoint. - handle morphPosition: aPoint-(e//2) extent: e. - handleSpec iconSymbol ifNotNil: [ :iconName | - form _ self class icons at: iconName ifAbsent: [self class perform: iconName]. - form ifNotNil: [ - form extent = e ifFalse: [ - ": Non default size, scale that bugger!!" - form _ form ": Be as smooth as possible, these images are small." - magnify: form boundingBox - to: e - smoothing: 1 ]. - icon _ ImageMorph new - image: form; - color: colorToUse makeForegroundColor; - lock. - handle addMorphFront: icon position: `0@0` ]]. - handle mouseUpSelector: #endInteraction. - handle setBalloonText: handleSpec hoverHelp. - ^ handle! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 8/21/2020 10:38:43' prior: 50535635! - addNameString: aString - "Add a name display centered beneath the bottom of the outer rectangle. Return the handle." - - | nameMorph verticalNamePosition namePosition nameBackground | - nameBackground _ RectangleLikeMorph new - color: ((target is: #SystemWindow) - ifTrue: [target windowColor] - ifFalse: [`Color lightBlue alpha: 0.9`]). - nameMorph _ StringMorph contents: aString. - nameMorph color: `Color black`. - nameBackground morphExtent: nameMorph morphExtent + 4. - verticalNamePosition _ haloBox bottom + Preferences haloHandleSize. - namePosition _ haloBox width - nameMorph morphWidth // 2 + haloBox left @ verticalNamePosition. - self addMorph: nameBackground. - nameBackground morphPosition: namePosition - 2. - self addMorph: nameMorph. - nameMorph morphPosition: namePosition. - ^nameMorph! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 8/21/2020 10:38:51' prior: 50535663! - basicBox - "basicBox is in local coordinates" - | aBox minSide anExtent w hs targetBounds | - hs _ Preferences haloHandleSize. - minSide _ 4 * hs. - anExtent _ extent + (hs*2) max: minSide@minSide. - targetBounds _ target displayBounds. - aBox _ Rectangle center: targetBounds center extent: anExtent. - w _ self world ifNil: [ target world ]. - aBox _ w - ifNil: - [ aBox ] - ifNotNil: - [ aBox intersect: (w viewBox insetBy: (hs@hs corner: hs@(hs*3))) ]. - ^aBox translatedBy: self morphPosition negated! ! -!HaloMorph class methodsFor: 'cached state access' stamp: 'jmv 8/21/2020 10:29:20' prior: 16851310 overrides: 50510040! - releaseClassCachedState - - Icons _ nil! ! - -HaloMorph class removeSelector: #handleSize! - -!methodRemoval: HaloMorph class #handleSize stamp: 'Install-4355-AutomaticallyScaleHalos-JuanVuletich-2020Aug21-10h36m-jmv.001.cs.st 8/22/2020 11:13:03'! -handleSize - HandleSize ifNil: [ - HandleSize _ 16 ]. - ^ HandleSize! - -RectangleLikeMorph subclass: #HaloMorph - instanceVariableNames: 'target positionOffset angleOffset growingOrRotating haloBox scaleOffset' - classVariableNames: 'Icons' - poolDictionaries: '' - category: 'Morphic-Halos'! - -!classDefinition: #HaloMorph category: #'Morphic-Halos' stamp: 'Install-4355-AutomaticallyScaleHalos-JuanVuletich-2020Aug21-10h36m-jmv.001.cs.st 8/22/2020 11:13:03'! -RectangleLikeMorph subclass: #HaloMorph - instanceVariableNames: 'target positionOffset angleOffset growingOrRotating haloBox scaleOffset' - classVariableNames: 'Icons' - poolDictionaries: '' - category: 'Morphic-Halos'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4355-AutomaticallyScaleHalos-JuanVuletich-2020Aug21-10h36m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4355] on 21 August 2020 at 12:03:13 pm'! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/21/2020 11:23:13'! - systemWindowBorderSize - | w | - w _ Preferences standardListFont pointSize / 11. - Theme current minimalWindows ifFalse: [ - w _ w * (Theme current roundWindowCorners ifTrue: [ 4 ] ifFalse: [ 2 ])]. - ^w rounded max: 1! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 8/21/2020 11:57:29' prior: 50471935! - drawLabelOn: aCanvas - - | x0 y0 f w availableW l | - f _ Preferences windowTitleFont. - x0 _ f lineSpacing * 5 + borderWidth. - y0 _ borderWidth * 6 // 10. - availableW _ extent x - x0. - l _ labelString. - w _ f widthOfString: l. - [ w > availableW ] whileTrue: [ - l _ l squeezedTo: (1.0 * l size * availableW / w) truncated. - l isEmpty ifTrue: [ ^self ]. - w _ f widthOfString: l ]. - aCanvas - drawString: l - at: x0@y0 - font: f - color: Theme current windowLabel - embossed: Theme current embossedTitles! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 8/21/2020 10:53:52' prior: 16926261 overrides: 16889446! - defaultBorderWidth - "answer the default border width for the receiver" - ^Preferences systemWindowBorderSize! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 8/21/2020 12:02:19' prior: 50471972! - initializeLabelArea - "Initialize the label area (titlebar) for the window." - - | topLeft spacing | - topLeft _ (self labelHeight + borderWidth - self titleBarButtonsExtent / 2) ceiling asPoint. - spacing _ self titleBarButtonsExtent x *14//10. - self addMorph: self createCloseButton position: topLeft. - self addMorph: self createCollapseButton position: spacing@0 + topLeft. - self addMorph: self createExpandButton position: spacing*2@0 + topLeft. - self addMorph: self createMenuButton position: spacing*3@0 + topLeft! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 8/21/2020 11:59:53' prior: 50471908! - titleBarButtonsExtent - "answer the extent to use for close & other title bar buttons. - - the label height is used to be proportional to the fonts preferences" - | e | - Theme current minimalWindows ifTrue: [^`0@0`]. - e _ Preferences windowTitleFont pointSize * 13 // 10. - ^e@e! ! -!SystemWindow methodsFor: 'label' stamp: 'len 5/1/2020 06:34:51' prior: 50509395! - labelHeight - "Answer the height for the window label." - Theme current minimalWindows ifTrue: [^ 0]. - ^ Preferences windowTitleFont lineSpacing+1! ! -!SystemWindow methodsFor: 'layout' stamp: 'jmv 8/21/2020 11:07:07' prior: 50537686 overrides: 50537642! - layoutSubmorphs - "Compute a new layout of submorphs based on the given layout bounds." - - | h thickness w cornerExtent wh ww pos | - thickness _ self defaultBorderWidth. - cornerExtent _ thickness * 5. - ww _ extent x. - wh _ extent y. - w _ ww - cornerExtent - cornerExtent. - h _ wh - cornerExtent - cornerExtent. - (adjusters at: #topAdjuster) morphPosition: cornerExtent@0 extent: w@thickness. - (adjusters at: #bottomAdjuster) morphPosition: cornerExtent@(wh-thickness) extent: w@thickness. - (adjusters at: #leftAdjuster) morphPosition: 0@cornerExtent extent: thickness@h. - (adjusters at: #rightAdjuster) morphPosition: ww-thickness@cornerExtent extent: thickness@h. - (adjusters at: #topLeftAdjuster) morphPosition: `0@0` extent: cornerExtent@cornerExtent. - (adjusters at: #bottomLeftAdjuster) morphPosition: 0@(wh-cornerExtent) extent: cornerExtent@cornerExtent. - (adjusters at: #topRightAdjuster) morphPosition: ww-cornerExtent@0 extent: cornerExtent@cornerExtent. - (adjusters at: #bottomRightAdjuster) morphPosition: ww@wh-cornerExtent extent: cornerExtent@cornerExtent. - - layoutMorph ifNotNil: [ - pos _ borderWidth @ (borderWidth + self labelHeight). - layoutMorph - morphPosition: pos - extent: extent - pos - borderWidth ]. - - self layoutNeeded: false.! ! -!WindowEdgeAdjustingMorph methodsFor: 'geometry testing' stamp: 'jmv 8/21/2020 11:23:01' prior: 16945124 overrides: 50537261! - morphContainsPoint: aLocalPoint - | sensitiveBorder | - ( self morphLocalBounds containsPoint: aLocalPoint) ifFalse: [ ^false ]. - sensitiveBorder _ owner borderWidth. - selector caseOf: { - [ #windowTopLeft: ] -> [ ^ aLocalPoint x < sensitiveBorder or: [ aLocalPoint y < sensitiveBorder ]]. - [ #windowTopRight: ] -> [ ^ extent x - aLocalPoint x <= sensitiveBorder or: [ aLocalPoint y < sensitiveBorder ]]. - [ #windowBottomLeft: ] -> [ ^ aLocalPoint x < sensitiveBorder or: [ extent y- aLocalPoint y <= sensitiveBorder ]]. - [ #windowBottomRight: ] -> [ ^ extent x - aLocalPoint x <= sensitiveBorder or: [ extent y - aLocalPoint y <= sensitiveBorder ]]. - } - otherwise: [ - "all the morph is sensitive for horizontal and vertical (i.e. non corner) instances." - ^true ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4356-AutomaticallyScaleWindowResizers-JuanVuletich-2020Aug21-11h52m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4356] on 21 August 2020 at 12:34:31 pm'! -!Morph methodsFor: 'updating' stamp: 'jmv 8/21/2020 12:31:46' prior: 50539673! - invalidateBounds - "Report that the area occupied by this morph should be redrawn, - but most likely we are not going to be redrawn on it, or maybe we'll not be fully visible. See senders." - - self invalidateDisplayRect: self displayBoundsOrBogus fromSubmorph: nil for: nil.! ! -!TranscriptWindow class methodsFor: 'GUI building' stamp: 'jmv 8/21/2020 12:28:48' prior: 50539288! - openTranscript - " - TranscriptWindow openTranscript - " - | win m | - win _ TranscriptWindow new. - win - setLabel: 'Transcript'; - model: Transcript. - m _ TranscriptMorph new. - win layoutMorph addMorph: m proportionalHeight: 1. - win model when: #redraw send: #invalidateBounds to: m. - ^ win openInWorld.! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -TranscriptWindow allInstancesDo: [ :t | t delete ]. -TranscriptWindow openTranscript.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4357-TranscriptGlitchFix-JuanVuletich-2020Aug21-12h34m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4357] on 21 August 2020 at 4:34:48 pm'! -!Morph methodsFor: 'change reporting' stamp: 'jmv 8/21/2020 16:14:59' prior: 50538451! - invalidateDisplayRect: damageRect fromSubmorph: submorphOrNil for: aMorph - " - If we clip submorphOrNil, then we clip damageRect. - When calling from self, submorphOrNil should be nil, i.e. we are not reporting damage for some submorph. - - aMorph is the morph that changed and therefore should be redrawn. In some cases, damage reporting is done by no longer occupying some area, and requesting whatever appropriate morph to be drawn there. In such cases, aMorph should be nil. See senders." - - | clippedRect b | - - "warning. Senders are using global coordinates. Redesign!!" - "local now!!!!!!!!!!" - self flag: #jmvVer2. "ok?" - - self visible ifFalse: [ ^self]. - - clippedRect _ damageRect. - submorphOrNil ifNotNil: [ - submorphOrNil == self clippedSubmorph - ifTrue: [ - b _ self displayBounds. - b ifNil: [ ^self ]. - clippedRect _ damageRect intersect: b ]]. - owner ifNotNil: [ - owner invalidateDisplayRect: clippedRect fromSubmorph: self for: aMorph ]! ! -!Morph methodsFor: 'updating' stamp: 'jmv 8/21/2020 16:15:38' prior: 50538994! - redrawNeeded - "Report that the area occupied by this morph should be redrawn. - Usually because we changed in some way." - - self needsRedraw: true. - self allOwnersDo: [ :m | m submorphNeedsRedraw: true ]. - self invalidateDisplayRect: self displayBoundsOrBogus fromSubmorph: nil for: self. - self submorphsDrawingOutsideReverseDo: [ :m | m redrawNeeded ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4358-Comments-JuanVuletich-2020Aug21-16h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4354] on 21 August 2020 at 7:28:31 pm'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 8/21/2020 19:28:21' prior: 50518199! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag - "WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " - | activeProc | - activeProc _ Processor activeProcess. - [ | isARealStartup guiRootObject guiRootObjectClass | - save not & quit - ifTrue: [ - (SourceFiles at: 2) ifNotNil: [ :changes | - ChangesInitialFileSize ifNotNil: [ changes truncate: ChangesInitialFileSize ]]] - ifFalse: [ - self - logSnapshot: save - andQuit: quit ]. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | - each isInWorld ifTrue: [ - each delete.]]. - UISupervisor ui tearDownDesktop. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - "Cosas que levanto explicitamente abajo" - guiRootObjectClass _ UISupervisor ui class. - guiRootObject _ UISupervisor ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "guiRootObject _ clearAllStateFlag ifFalse: [ UISupervisor ui ]." - UISupervisor stopUIProcess. - activeProc isTerminated ifFalse: [ activeProc terminate ]. - "Clean Globals" - Smalltalk - at: #Sensor - put: nil. - Smalltalk - at: #Display - put: nil. - Smalltalk closeSourceFiles. - Smalltalk - at: #SourceFiles - put: nil. - Smalltalk allClassesDo: [ :cls | - cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | - cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ - Smalltalk printStuffToCleanOnImageSave. - "Remove this call to actually see the image clean report." - Transcript clear. - ]. - "Do image save & quit as apropriate" - (Cursor cursorAt: #writeCursor) activateCursor. - save - ifTrue: [ - "The snapshot primitive answers false if it was just called to do the snapshot. - But image startup is resumed by returning (again) from the primitive, but this time answering true." - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk - at: #Sensor - put: nil. - Smalltalk - at: #Display - put: DisplayScreen new. - Smalltalk - at: #SourceFiles - put: (Array new: 2). - Smalltalk openSourceFiles. - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | - cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - UISupervisor spawnNewMorphicProcessFor: (guiRootObject ifNil: [ guiRootObject _ guiRootObjectClass newWorld ]). - self restoreLostChangesIfNecessary. - clearAllStateFlag ifTrue: [ - UISupervisor whenUIinSafeState: [ - guiRootObject recreateDefaultDesktop; restoreDisplay. - Display triggerEvent: #screenSizeChanged ]] - ifFalse: [ - UISupervisor whenUIinSafeState: [ - guiRootObject restoreDisplay. - Display triggerEvent: #screenSizeChanged ]]. - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - UISupervisor whenUIinSafeState: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]] - forkAt: Processor timingPriority - 1 - named: 'Startup process'.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4359-FixStartupGlitches-JuanVuletich-2020Aug21-19h24m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4359] on 21 August 2020 at 9:08:32 pm'! - -Transcript class - instanceVariableNames: 'entries firstIndex lastIndex accessSemaphore unfinishedEntry logToFile showOnDisplay lastDisplayPosition bounds logToStdout displayCanvas '! - -!classDefinition: 'Transcript class' category: #'System-Support' stamp: 'Install-4360-TranscriptEnhancements-JuanVuletich-2020Aug21-20h58m-jmv.001.cs.st 8/22/2020 11:13:04'! -Transcript class - instanceVariableNames: 'entries firstIndex lastIndex accessSemaphore unfinishedEntry logToFile showOnDisplay lastDisplayPosition bounds logToStdout displayCanvas'! - -RectangleLikeMorph subclass: #TranscriptMorph - instanceVariableNames: 'form workspace lastIncludedIndex workspaceWindow lastUnfinishedEntrySize doImmediateUpdates ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #TranscriptMorph category: #'Morphic-Widgets' stamp: 'Install-4360-TranscriptEnhancements-JuanVuletich-2020Aug21-20h58m-jmv.001.cs.st 8/22/2020 11:13:04'! -RectangleLikeMorph subclass: #TranscriptMorph - instanceVariableNames: 'form workspace lastIncludedIndex workspaceWindow lastUnfinishedEntrySize doImmediateUpdates' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! -!Transcript class methodsFor: 'private' stamp: 'jmv 8/21/2020 21:08:10'! - canvas - - (displayCanvas isNil or: [ - displayCanvas class ~= MorphicCanvas activeSubclass]) ifTrue: [ - displayCanvas _ Display getCanvas ]. - ^ displayCanvas! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 8/21/2020 19:51:49'! - displayOnCanvas: aCanvas - " - 1 to: 2000 do: [ :i | i print ]. - 1 to: 750 do: [ :i | i print ]. - Transcript displayOn: Display in: bounds - " - | font count string x y fh innerR index | - "aCanvas form fill: aRectangle fillColor: `Color white`." - font _ FontFamily defaultFamilyAndPointSize. - - "innerR _ aRectangle insetBy: self padding." - innerR _ 0@0 extent: 100@100. - aCanvas newClipRect: innerR. - x _ innerR left. - y _ innerR top. - fh _ font lineSpacing. - count _ lastIndex - firstIndex \\ self maxEntries + 1 min: innerR height // fh - 1. - index _ lastIndex - count \\ self maxEntries + 1. - count timesRepeat: [ - string _ entries at: index. - aCanvas drawString: string at: x@y font: font color: `Color veryDarkGray`. - y _ y + fh. - index _ index \\ self maxEntries + 1 ]. - string _ unfinishedEntry contents. - aCanvas drawString: string at: x@y font: font color: `Color veryDarkGray`! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 8/21/2020 19:59:46'! - displayOnCanvas: aCanvas in: aRectangle - " - 1 to: 2000 do: [ :i | i print ]. - 1 to: 750 do: [ :i | i print ]. - Transcript displayOn: Display in: bounds - " - | font count string x y fh innerR index | - aCanvas - fillRectangle: aRectangle - color: `Color white`. - font _ FontFamily defaultFamilyAndPointSize. - innerR _ aRectangle insetBy: self padding. - x _ innerR left. - y _ innerR top. - fh _ font lineSpacing. - count _ lastIndex - firstIndex \\ self maxEntries + 1 min: innerR height // fh - 1. - index _ lastIndex - count \\ self maxEntries + 1. - count timesRepeat: [ - string _ entries at: index. - aCanvas drawString: string at: x@y font: font color: `Color veryDarkGray`. - y _ y + fh. - index _ index \\ self maxEntries + 1 ]. - string _ unfinishedEntry contents. - aCanvas drawString: string at: x@y font: font color: `Color veryDarkGray`! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 8/21/2020 19:48:07'! - displayUnfinishedEntryOnCanvas: aCanvas - - | font count string x y fh r innerR | - innerR _ bounds insetBy: self padding. - lastDisplayPosition < innerR right ifTrue: [ - font _ FontFamily defaultFamilyAndPointSize. - fh _ font lineSpacing. - count _ innerR height // fh-1. - x _ innerR left. - string _ unfinishedEntry contents. - y _ ((lastIndex - firstIndex \\ self maxEntries) min: count-1) + 1 * font lineSpacing + innerR top. - r _ innerR left: lastDisplayPosition. - aCanvas newClipRect: r. - (aCanvas drawString: string at: x@y font: font color: `Color veryDarkGray`) ifNotNil: [ :lastPoint | - lastDisplayPosition _ lastPoint x. - ^r ]]. - ^nil! ! -!Transcript class methodsFor: 'system startup' stamp: 'jmv 8/21/2020 21:06:26' overrides: 50510040! - releaseClassCachedState - displayCanvas _ nil! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 8/21/2020 20:13:23' prior: 16938463! - display - | c innerR | - showOnDisplay ifTrue: [ - innerR _ bounds insetBy: self padding. - c _ self canvas. - c setClipRect: innerR. - self displayOnCanvas: c in: bounds. - DisplayScreen screenUpdateRequired: bounds ]. - "So any morph in front of us is repaired when Morphic cycles. - This includes, for instance, the TranscriptWindow that shows our contents if showOnDisplay is false" - self triggerEvent: #redraw! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 8/21/2020 20:13:32' prior: 16938504! - displayUnfinishedEntry - showOnDisplay ifTrue: [ - (self displayUnfinishedEntryOnCanvas: self canvas) ifNotNil: [ :damage | - DisplayScreen screenUpdateRequired: damage ]]! ! -!TranscriptMorph methodsFor: 'drawing' stamp: 'jmv 8/21/2020 20:08:05' prior: 50535161 overrides: 16899205! - drawOn: aCanvas - Transcript showOnDisplay: true. - aCanvas clippingByCurrentMorphDo: [ - Transcript displayOnCanvas: aCanvas in: self morphLocalBounds ]. - self displayBounds ifNotNil: [ :r | - Transcript bounds:r ]. - Transcript - showOnDisplay: doImmediateUpdates. - self updateWorkspace! ! - -TranscriptMorph removeSelector: #privateExtent:! - -!methodRemoval: TranscriptMorph #privateExtent: stamp: 'Install-4360-TranscriptEnhancements-JuanVuletich-2020Aug21-20h58m-jmv.001.cs.st 8/22/2020 11:13:04'! -privateExtent: aPoint - - ^ (super privateExtent: aPoint) - ifTrue: [ - (form isNil or: [ form extent ~= aPoint ]) ifTrue: [ - form _ Form extent: aPoint depth: Display depth ]]; yourself! - -Transcript class removeSelector: #displayOn:in:! - -!methodRemoval: Transcript class #displayOn:in: stamp: 'Install-4360-TranscriptEnhancements-JuanVuletich-2020Aug21-20h58m-jmv.001.cs.st 8/22/2020 11:13:04'! -displayOn: aForm in: aRectangle - " - 1 to: 2000 do: [ :i | i print ]. - 1 to: 750 do: [ :i | i print ]. - Transcript displayOn: Display in: bounds - " - | font count string x y fh canvas innerR index | - aForm fill: aRectangle fillColor: `Color white`. - font _ FontFamily defaultFamilyAndPointSize. - - innerR _ aRectangle insetBy: self padding. - canvas _ aForm getCanvas. - canvas newClipRect: innerR. - x _ innerR left. - y _ innerR top. - fh _ font lineSpacing. - count _ lastIndex - firstIndex \\ self maxEntries + 1 min: innerR height // fh - 1. - index _ lastIndex - count \\ self maxEntries + 1. - count timesRepeat: [ - string _ entries at: index. - canvas drawString: string at: x@y font: font color: `Color veryDarkGray`. - y _ y + fh. - index _ index \\ self maxEntries + 1 ]. - string _ unfinishedEntry contents. - canvas drawString: string at: x@y font: font color: `Color veryDarkGray`! - -Transcript class removeSelector: #displayUnfinishedEntryOn:! - -!methodRemoval: Transcript class #displayUnfinishedEntryOn: stamp: 'Install-4360-TranscriptEnhancements-JuanVuletich-2020Aug21-20h58m-jmv.001.cs.st 8/22/2020 11:13:04'! -displayUnfinishedEntryOn: aForm - - | font count string x y fh canvas r innerR | - innerR _ bounds insetBy: self padding. - lastDisplayPosition < innerR right ifTrue: [ - font _ FontFamily defaultFamilyAndPointSize. - fh _ font lineSpacing. - count _ innerR height // fh-1. - x _ innerR left. - string _ unfinishedEntry contents. - y _ ((lastIndex - firstIndex \\ self maxEntries) min: count-1) + 1 * font lineSpacing + innerR top. - canvas _ aForm getCanvas. - r _ innerR left: lastDisplayPosition. - canvas newClipRect: r. - (canvas drawString: string at: x@y font: font color: `Color veryDarkGray`) ifNotNil: [ :lastPoint | - lastDisplayPosition _ lastPoint x. - ^r ]]. - ^nil! - -Transcript class - instanceVariableNames: 'entries firstIndex lastIndex accessSemaphore unfinishedEntry logToFile showOnDisplay lastDisplayPosition bounds logToStdout displayCanvas'! - -!classDefinition: 'Transcript class' category: #'System-Support' stamp: 'Install-4360-TranscriptEnhancements-JuanVuletich-2020Aug21-20h58m-jmv.001.cs.st 8/22/2020 11:13:04'! -Transcript class - instanceVariableNames: 'entries firstIndex lastIndex accessSemaphore unfinishedEntry logToFile showOnDisplay lastDisplayPosition bounds logToStdout displayCanvas'! - -RectangleLikeMorph subclass: #TranscriptMorph - instanceVariableNames: 'workspace lastIncludedIndex workspaceWindow lastUnfinishedEntrySize doImmediateUpdates' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #TranscriptMorph category: #'Morphic-Widgets' stamp: 'Install-4360-TranscriptEnhancements-JuanVuletich-2020Aug21-20h58m-jmv.001.cs.st 8/22/2020 11:13:04'! -RectangleLikeMorph subclass: #TranscriptMorph - instanceVariableNames: 'workspace lastIncludedIndex workspaceWindow lastUnfinishedEntrySize doImmediateUpdates' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4360-TranscriptEnhancements-JuanVuletich-2020Aug21-20h58m-jmv.001.cs.st----! - -----SNAPSHOT----(22 August 2020 11:13:08) Cuis5.0-4360-32.image priorSource: 6697562! - -----STARTUP---- (15 October 2020 19:32:56) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4360-32.image! - - -'From Cuis 5.0 [latest update: #4360] on 22 August 2020 at 4:48:30 pm'! -!Morph methodsFor: 'dropping/grabbing' stamp: 'jmv 8/22/2020 16:40:53' prior: 16876016! -acceptDroppingMorph: aMorph event: evt - "This message is sent when a morph is dropped onto a morph that has agreed to accept the dropped morph by responding 'true' to the wantsDroppedMorph:event: message. This default implementation just adds the given morph to the receiver." - - self addMorph: aMorph! ! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'jmv 8/22/2020 16:35:34' prior: 16899214 overrides: 50384199! - morphExtent - "In our own coordinates!!" - - ^ extent! ! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'jmv 8/22/2020 16:36:56' prior: 16899258! - morphHeight: aNumber - - self morphExtent: extent x@aNumber! ! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'jmv 8/22/2020 16:37:29' prior: 16899302! - morphWidth: aNumber - - self morphExtent: aNumber@extent y! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4361-Morph-helper-methods-JuanVuletich-2020Aug22-16h35m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4361] on 23 August 2020 at 9:26:22 pm'! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 8/23/2020 21:26:07' prior: 50494857! - fillRectangle: aRectangle tilingWith: aForm sourceRect: patternBox rule: aCombinationRule - - | displayRectangle additionalOffset clippedEngine targetTopLeft clipOffset ex - targetBox savedMap top left | - - engine ifNil: [ ^nil ]. - - ex _ patternBox extent. - ex x = 0 ifTrue: [ ^self ]. - ex y = 0 ifTrue: [ ^self ]. - displayRectangle _ (currentTransformation externalizeRectangle: aRectangle) rounded. - - "this is a bit of a kludge to get the form to be aligned where I *think* it should be. - something better is needed, but not now" - - additionalOffset _ `0@0`. - clippedEngine _ engine clippedBy: displayRectangle. - targetTopLeft _ clippedEngine clipRect topLeft truncateTo: ex. - clipOffset _ displayRectangle topLeft - targetTopLeft. - additionalOffset _ (clipOffset \\ ex) - ex. - - "do it iteratively" - targetBox _ clippedEngine clipRect. - savedMap _ clippedEngine colorMap. - clippedEngine sourceForm: aForm; - fillColor: nil; - combinationRule: aCombinationRule; - sourceRect: patternBox; - colorMap: (aForm colormapIfNeededFor: clippedEngine destForm). - top _ (targetBox top truncateTo: patternBox height) + additionalOffset y. - left _ (targetBox left truncateTo: patternBox width) + additionalOffset x. - - left to: (targetBox right - 1) by: patternBox width do: [:x | - top to: (targetBox bottom - 1) by: patternBox height do: [:y | - clippedEngine destOrigin: x@y; copyBits]]. - clippedEngine colorMap: savedMap! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4362-BitBltEngine-fix-JuanVuletich-2020Aug23-21h25m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4362] on 28 August 2020 at 8:36:03 pm'! -!Editor methodsFor: 'new selection' stamp: 'jmv 8/28/2020 20:35:53' prior: 50467332! - wordRangeLeftDelimiters: leftDelimiters rightDelimiters: rightDelimiters - "Select delimited text or word--the result of double-clicking." - - ^ self - wordRangeLeftDelimiters: leftDelimiters - rightDelimiters: rightDelimiters - startingAt: self pointIndex + self markIndex // 2.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4363-fixSelectWordAnnoyance-JuanVuletich-2020Aug28-20h35m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4362] on 28 August 2020 at 8:58:47 pm'! - -MessageSetWindow removeSelector: #activateAndSendTopToBack:! - -!methodRemoval: MessageSetWindow #activateAndSendTopToBack: stamp: 'Install-4364-fixMessageSetClickOnFirstItemToFocusAndSelectAnnoyance-JuanVuletich-2020Aug28-20h36m-jmv.001.cs.st 10/15/2020 19:33:00'! -activateAndSendTopToBack: aBoolean - super activateAndSendTopToBack: aBoolean. - (model messageListIndex = 0 and: [ model messageList notEmpty ]) - ifTrue: [ - model messageListIndex: 1 ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4364-fixMessageSetClickOnFirstItemToFocusAndSelectAnnoyance-JuanVuletich-2020Aug28-20h36m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4364] on 30 August 2020 at 6:56:19 pm'! -!CodeWindow methodsFor: 'updating' stamp: 'HAW 8/30/2020 18:28:24'! - classAdded: addedClass - - "Keep default behavior. Subclasses like BrowserWindow, redefine it - Hernan" - self updateListsAndCode ! ! -!BrowserWindow methodsFor: 'updating' stamp: 'HAW 8/30/2020 18:31:12' overrides: 50541940! - classAdded: addedClass - - self model selectedSystemCategoryName = addedClass category - ifTrue: [ self model changed: #classList ]! ! -!Parser methodsFor: 'error correction' stamp: 'HAW 8/30/2020 18:33:15' prior: 50466462! - correctVariable: proposedVariable interval: aSpot - "Correct the proposedVariable to a known variable, or declare it as a new - variable if such action is requested. We support declaring lowercase - variables as temps or inst-vars, and uppercase variables as Globals or - ClassVars, depending on whether the context is nil (class=UndefinedObject). - Spot is the interval within the test stream of the variable. - rr 3/4/2004 10:26 : adds the option to define a new class. " - - "Check if this is an i-var, that has been corrected already (ugly)" - - "Display the pop-up menu" - - | userSelection action delta spot | - (encoder classEncoding instVarNames includes: proposedVariable) ifTrue: [ - ^InstanceVariableNode new - name: proposedVariable - index: (encoder classEncoding allInstVarNames indexOf: proposedVariable)]. - - "First check to see if the requestor knows anything about the variable" - (requestor bindingOf: proposedVariable) - ifNotNil: [ :binding | ^ encoder global: binding name: proposedVariable]. - - "If we can't ask the user for correction, make it undeclared" - self interactive ifFalse: [^encoder undeclared: proposedVariable]. - - userSelection _ requestor selectionInterval. - delta _ self sourceDelta. - spot _ aSpot first - delta to: aSpot last - delta. - requestor selectFrom: spot first to: spot last. - - "Build the menu with alternatives" - action _ UndeclaredVariable - signalFor: self - name: proposedVariable - inRange: spot. - action ifNil: [^self fail]. - - "Execute the selected action" - requestor selectInvisiblyFrom: userSelection first to: userSelection last. - ^action value ifNil: [self fail]. - ! ! -!Parser methodsFor: 'error correction' stamp: 'HAW 8/30/2020 18:54:32' prior: 50514609! - defineClass: className - "prompts the user to define a new class, - asks for it's category, and lets the users edit further - the definition" - | classNameAsSymbol classCategory classDefinition userClassDefinition newClass | - - classNameAsSymbol := className asSymbol. - classCategory := self - request: 'Enter class category:' - initialAnswer: self encoder classEncoding theNonMetaClass category - orCancel: [ ^nil ]. - classCategory ifEmpty: [classCategory := 'Unknown']. - - classDefinition := 'Object subclass: #' , classNameAsSymbol , ' - instanceVariableNames: '''' - classVariableNames: '''' - poolDictionaries: '''' - category: ''' , classCategory , ''''. - userClassDefinition := self - request: 'Edit class definition:' - initialAnswer: classDefinition - orCancel: [ ^nil ]. - userClassDefinition ifEmpty: [userClassDefinition := classDefinition]. - - ^[ newClass := Compiler evaluate: userClassDefinition. - (newClass isKindOf: Behavior) - ifTrue: [ - encoder - global: (Smalltalk associationAt: classNameAsSymbol) - name: classNameAsSymbol] - ifFalse: [ - self inform: - ('The provided class definition did not created a class but\the object: ', newClass printString) withNewLines. - nil ]] - on: Error - do: [ :anError | - self inform: ('There is an error in the provided class definition:\', anError description) withNewLines. - anError return: nil ]. - - ! ! -!CodeWindow methodsFor: 'notification actions' stamp: 'HAW 8/30/2020 18:27:15' prior: 50496030! - registerNotificationActions - - SystemChangeNotifier uniqueInstance - when: #classAdded send: #classAdded: to: self; - when: #classCommented send: #updateListsAndCode to: self; - when: #classDefinitionChanged send: #updateListsAndCode to: self; - when: #classRecategorized send: #updateListsAndCode to: self; - when: #classRemoved send: #updateListsAndCode to: self; - when: #classRenamed send: #classRenamed:from:to:inCategory: to: self; - when: #classReorganized send: #updateListsAndCode to: self; - when: #methodAddedInProtocol send: #updateListsAndCode to: self; - when: #methodChanged send: #updateListsAndCode to: self; - when: #methodRemoved send: #updateListsAndCode to: self; - when: #selectorRecategorized send: #updateListsAndCode to: self ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4365-BetterClassCreationFeedback-HernanWilkinson-2020Aug29-18h09m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4365] on 3 September 2020 at 5:18:06 pm'! - -Smalltalk renameClassNamed: #FloatArray as: #Float32Array! - -!classRenamed: #FloatArray as: #Float32Array stamp: 'Install-4366-RenameFloatArrayAsFloat32Array-JuanVuletich-2020Sep03-17h12m-jmv.001.cs.st 10/15/2020 19:33:00'! -Smalltalk renameClassNamed: #FloatArray as: #Float32Array! -!Float32Array commentStamp: '' prior: 16846402! - Float32Arrays store 32bit IEEE floating point numbers.! -!Float64Array commentStamp: '' prior: 50376955! - Float64Arrays store 64bit IEEE floating point numbers, i.e. instances of the Float class. -Some support is included for subclasses in the style of Balloon3D-Math. - -Uses the same internal representation as Float. I.e. a Float and a Float64Array of size 1 hold the same bits. See #floatAt: and #floatAt:put:! -!Float methodsFor: 'converting' stamp: 'jmv 9/3/2020 17:15:41' prior: 50418620! - asIEEE32BitWord - "Convert the receiver into a 32 bit Integer value representing the same number in IEEE 32 bit format. - Used for conversion in Float32Arrays only." - - | word1 word2 sign mantissa exponent destWord truncatedBits mask roundToUpper | - - "quickly skip positive and negative zero" - self isZero ifTrue: [^self basicAt: 1]. - - "retrieve 64 bits of IEEE 754 double" - word1 := self basicAt: 1. - word2 := self basicAt: 2. - - "prepare sign exponent and mantissa of 32 bits float" - sign := word1 bitAnd: 16r80000000. - exponent := ((word1 bitShift: -20) bitAnd: 16r7FF) - 1023 + 127. - mantissa := (word2 bitShift: -29) + ((word1 bitAnd: 16rFFFFF) bitShift: 3). - truncatedBits := (word2 bitAnd: 16r1FFFFFFF). - - "We must now honour default IEEE rounding mode (round to nearest even)" - - "we are below gradual underflow, even if rounded to upper mantissa" - exponent < -24 ifTrue: [^sign "this can be negative zero"]. - - "BEWARE: rounding occurs on less than 23bits when gradual underflow" - exponent <= 0 - ifTrue: - [mask := 1 bitShift: exponent negated. - mantissa := mantissa bitOr: 16r800000. - roundToUpper := (mantissa bitAnd: mask) isZero not - and: [truncatedBits isZero not - or: [(mantissa bitAnd: mask - 1) isZero not - or: [(mantissa bitAnd: mask*2) isZero not]]]. - mantissa := mantissa bitShift: exponent - 1. - "exponent := exponent + 1"] - ifFalse: - [roundToUpper := (truncatedBits bitAnd: 16r10000000) isZero not - and: [(mantissa bitAnd: 16r1) isZero not - or: [(truncatedBits bitAnd: 16r0FFFFFFF) isZero not]] - ]. - - "adjust mantissa and exponent due to IEEE rounding mode" - roundToUpper - ifTrue: - [mantissa := mantissa + 1. - mantissa > 16r7FFFFF - ifTrue: - [mantissa := 0. - exponent := exponent+1]]. - - exponent > 254 ifTrue: ["Overflow" - exponent := 255. - self isNaN - ifTrue: [mantissa isZero - ifTrue: ["BEWARE: do not convert a NaN to infinity due to truncatedBits" - mantissa := 1]] - ifFalse: [mantissa := 0]]. - - "Encode the word" - destWord := (sign bitOr: ((exponent max: 0) bitShift: 23)) bitOr: mantissa. - ^ destWord! ! -!Float class methodsFor: 'instance creation' stamp: 'jmv 9/3/2020 17:15:47' prior: 50451379! - fromIEEE32Bit: word - "Convert the given 32 bit word (which is supposed to be a positive 32bit value) from - a 32bit IEEE floating point representation into an actual Float object (being - 64bit wide). Should only be used for conversion in Float32Arrays or likewise objects." - - | sign exponent mantissa exponentBits fractionBits answerFractionBits delta signBit answerExponent | - word negative ifTrue: [ ^ self error: 'Cannot deal with negative numbers' ]. - word = 0 ifTrue: [ ^ Float zero ]. - word = 16r80000000 ifTrue: [ ^Float negativeZero ]. - - signBit _ word bitAnd: 16r80000000. - sign _ (word bitShift: -31) = 0 ifTrue: [1] ifFalse: [-1]. - exponentBits _ (word bitShift: -23) bitAnd: 16rFF. - fractionBits _ word bitAnd: 16r7FFFFF. - - " Special cases: infinites and NaN" - exponentBits = 16rFF ifTrue: [ - fractionBits = 0 ifFalse: [ ^ Float nan ]. - ^ sign positive - ifTrue: [ Float infinity ] - ifFalse: [ Float negativeInfinity ]]. - - " Unbias exponent: 16r3FF is bias" - exponent _ exponentBits - 16r7F. - -"Older version." -false ifTrue: [ - " Replace omitted leading 1 in fraction if appropriate" - "If expPart = 0, I am +/-zero or a denormal value. In such cases, no implicit leading bit in mantissa" - exponentBits = 0 - ifTrue: [ - "gradual underflow (denormalized number) - There is no implied one, but the exponent is -126" - mantissa _ fractionBits. - answerExponent _ exponent + 1 ] - ifFalse: [ - mantissa _ fractionBits + 16r800000. - answerExponent _ exponent ]. - ^ (sign * mantissa) asFloat timesTwoPower: answerExponent - 23 ]. - - "Newer version" - exponentBits = 0 - ifTrue: [ - "gradual underflow (denormalized number) - Remove first bit of mantissa and adjust exponent" - delta := fractionBits highBit. - answerFractionBits := (fractionBits bitAnd: (1 bitShift: delta - 1) - 1) bitShift: 24 - delta. - answerExponent := exponent + delta - 23] - ifFalse: [ - answerFractionBits _ fractionBits. - answerExponent _ exponent ]. - - "Create new float" - ^ (self basicNew: 2) - basicAt: 1 put: ((signBit bitOr: (1023 + answerExponent bitShift: 20)) bitOr: (answerFractionBits bitShift: -3)); - basicAt: 2 put: ((answerFractionBits bitAnd: 7) bitShift: 29); - * 1.0. "reduce to SmallFloat64 if possible" - -" -Float fromIEEE32Bit: Float pi asIEEE32BitWord -(Float fromIEEE32Bit: Float pi asIEEE32BitWord ) = Float pi -(Float fromIEEE32Bit: Float pi asIEEE32BitWord ) - Float pi - -Float fromIEEE32Bit: (Float pi / 1e40) asIEEE32BitWord -(Float fromIEEE32Bit: (Float pi / 1e40) asIEEE32BitWord) = (Float pi / 1e40) -(Float fromIEEE32Bit: (Float pi / 1e40) asIEEE32BitWord) - (Float pi / 1e40) -"! ! -!Collection methodsFor: 'converting' stamp: 'jmv 9/3/2020 17:12:45' prior: 16814057! - asFloatArray - "Answer a FloatArray whose elements are the elements of the receiver" - - ^self as: Float32Array! ! -!Float32Array methodsFor: 'testing' stamp: 'jmv 9/3/2020 17:12:44' prior: 16846657 overrides: 50468405! - is: aSymbol - ^ aSymbol == #Float32Array or: [ super is: aSymbol ]! ! -!Float64Array methodsFor: 'converting' stamp: 'jmv 9/3/2020 17:12:45' prior: 16846338! - asIEEE32BitPrecisionFloat - | answer s | - self class == Float64Array ifFalse: [ - self error: 'please implement' ]. - s _ self size. - answer _ Float32Array new: s. - 1 to: s do: [ :i | answer at: i put: (self at: i) ]. - ^answer! ! -!DataStream class methodsFor: 'as yet unclassified' stamp: 'jmv 9/3/2020 17:12:45' prior: 16827969! - initCachedState - "TypeMap maps Smalltalk classes to type ID numbers which identify the data stream primitive formats. nextPut: writes these IDs to the data stream. NOTE: Changing these type ID numbers will invalidate all extant data stream files. Adding new ones is OK. - Classes named here have special formats in the file. If such a class has a subclass, it will use type 9 and write correctly. It will just be slow. (Later write the class name in the special format, then subclasses can use the type also.) - See nextPut:, next, typeIDFor:, & ReferenceStream>>isAReferenceType:" - " - DataStream initCachedState - " - - | refTypes t | - refTypes _ OrderedCollection new. - t _ TypeMap _ Dictionary new: 80. "sparse for fast hashing" - - t at: UndefinedObject put: 1. refTypes add: 0. - t at: True put: 2. refTypes add: 0. - t at: False put: 3. refTypes add: 0. - t at: SmallInteger put: 4. refTypes add: 0. - t at: String put: 5. refTypes add: 1. - t at: Symbol put: 6. refTypes add: 1. - t at: ByteArray put: 7. refTypes add: 1. - t at: Array put: 8. refTypes add: 1. - "(type ID 9 is for arbitrary instances of any class, cf. typeIDFor:)" - refTypes add: 1. - "(type ID 10 is for references, cf. ReferenceStream>>tryToPutReference:)" - refTypes add: 0. - t at: Bitmap put: 11. refTypes add: 1. - - t at: Metaclass put: 12. refTypes add: 0. - "Type ID 13 is used for HyperSqueak User classes that must be reconstructed." - refTypes add: 1. - - t at: Float put: 14. refTypes add: 1. - t at: BoxedFloat64 put: 14. - t at: SmallFloat64 put: 14. - - "15: Deprecated compact Rects." - refTypes add: 1. - - "type ID 16 is an instance with short header. See beginInstance:size:" - refTypes add: 1. - - t at: String put: 17. refTypes add: 1. "new String format, 1 or 4 bytes of length" - t at: WordArray put: 18. refTypes add: 1. "bitmap-like" - "t at: WordArrayForSegment put: 19." refTypes add: 1. "bitmap-like" - t at: Float32Array put: 20. refTypes add: 1. "And all other word arrays, both 16-bit and 32-bit. See methods in ArrayedCollection. Overridden in SoundBuffer." - "For all classes that are like WordArrays, store them the way ColorArray is stored. As bits, and able to change endianness." - Smalltalk do: [:cls | - cls isInMemory ifTrue: [ - cls isBehavior ifTrue: [ - cls isPointers not & cls isVariable & cls isWords ifTrue: [ - (t includesKey: cls) ifFalse: [t at: cls put: 20]]]]]. - - t at: CompiledMethod put: 21. refTypes add: 1. "special creation method" - - t at: Character put: 22. refTypes add: 0. - - "t at: put: 23. refTypes add: 0." - ReferenceTypes _ refTypes. "save it"! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4366-RenameFloatArrayAsFloat32Array-JuanVuletich-2020Sep03-17h12m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4365] on 3 September 2020 at 5:22:26 pm'! - -ArrayedCollection subclass: #FloatArray - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Collections-Arrayed'! - -!classDefinition: #FloatArray category: #'Collections-Arrayed' stamp: 'Install-4367-CreateAbstractFloatArrayClass-JuanVuletich-2020Sep03-17h18m-jmv.001.cs.st 10/15/2020 19:33:00'! -ArrayedCollection subclass: #FloatArray - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Collections-Arrayed'! -!FloatArray commentStamp: '' prior: 0! - Common behavior of Float32Array and Float64Array! - -FloatArray variableWordSubclass: #Float32Array - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Collections-Arrayed'! - -!classDefinition: #Float32Array category: #'Collections-Arrayed' stamp: 'Install-4367-CreateAbstractFloatArrayClass-JuanVuletich-2020Sep03-17h18m-jmv.001.cs.st 10/15/2020 19:33:00'! -FloatArray variableWordSubclass: #Float32Array - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Collections-Arrayed'! -!Float32Array commentStamp: '' prior: 50542098! - Common behavior of Float32Array and Float64Array.! - -FloatArray variableWordSubclass: #Float64Array - instanceVariableNames: '' - classVariableNames: 'LastSaveOrder ' - poolDictionaries: '' - category: 'Collections-Arrayed'! - -!classDefinition: #Float64Array category: #'Collections-Arrayed' stamp: 'Install-4367-CreateAbstractFloatArrayClass-JuanVuletich-2020Sep03-17h18m-jmv.001.cs.st 10/15/2020 19:33:00'! -FloatArray variableWordSubclass: #Float64Array - instanceVariableNames: '' - classVariableNames: 'LastSaveOrder' - poolDictionaries: '' - category: 'Collections-Arrayed'! - -FloatArray variableWordSubclass: #Float64Array - instanceVariableNames: '' - classVariableNames: 'LastSaveOrder' - poolDictionaries: '' - category: 'Collections-Arrayed'! - -!classDefinition: #Float64Array category: #'Collections-Arrayed' stamp: 'Install-4367-CreateAbstractFloatArrayClass-JuanVuletich-2020Sep03-17h18m-jmv.001.cs.st 10/15/2020 19:33:00'! -FloatArray variableWordSubclass: #Float64Array - instanceVariableNames: '' - classVariableNames: 'LastSaveOrder' - poolDictionaries: '' - category: 'Collections-Arrayed'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4367-CreateAbstractFloatArrayClass-JuanVuletich-2020Sep03-17h18m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4367] on 3 September 2020 at 5:47:35 pm'! -!FloatArray methodsFor: 'arithmetic' stamp: 'jmv 5/14/2015 09:52' overrides: 16813985! - * anObject - - ^self copy *= anObject! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:49'! - *= anObject - ^anObject isNumber - ifTrue:[self primMulScalar: anObject asFloat] - ifFalse:[self primMulArray: anObject]! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'jmv 5/14/2015 09:52' overrides: 16813989! - + anObject - - ^self copy += anObject! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:48' overrides: 50332829! - += anObject - ^anObject isNumber - ifTrue:[self primAddScalar: anObject asFloat] - ifFalse:[self primAddArray: anObject]! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'jmv 5/14/2015 09:52' overrides: 16813993! - - anObject - - ^self copy -= anObject! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:49' overrides: 50332838! - -= anObject - ^anObject isNumber - ifTrue:[self primSubScalar: anObject asFloat] - ifFalse:[self primSubArray: anObject]! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'jmv 5/14/2015 09:52' overrides: 16813997! - / anObject - - ^self copy /= anObject! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'jmv 6/25/2019 17:43:52'! - /= anObject - - ^self divideBy: anObject - ifDivisorZero: [ZeroDivide new signalReceiver: self selector: #/= argument: anObject] - ifBothZero: [ZeroDivide new signalReceiver: self selector: #/= argument: anObject]! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'yo 9/14/2004 17:12'! - \\= 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). - ]. - -! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'nice 11/24/2007 00:10' overrides: 16813942! - 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:[ - "DO NOT USE TRIVIAL CODE - ^self reciprocal * rcvr - BECAUSE OF GRADUAL UNDERFLOW - self should: (1.0e-39 / (FloatArray with: 1.0e-39)) first < 2." - ^(self class new: self size withAll: rcvr) / self - ]. - ^super adaptToNumber: rcvr andSend: selector! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'jmv 7/9/2018 09:41:43'! - divideBy: aFloatArrayOrNumber ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue - ^aFloatArrayOrNumber isNumber - ifTrue:[self divideByScalar: aFloatArrayOrNumber asFloat ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue] - ifFalse:[self divideByArray: aFloatArrayOrNumber ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue]! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'jmv 5/14/2015 09:52' overrides: 16814551! - negated - - ^self copy *= -1! ! -!FloatArray methodsFor: 'accessing' stamp: 'jmv 2/28/2020 12:11:02' overrides: 16880774! - at: index - ^self floatAt: index! ! -!FloatArray methodsFor: 'accessing' stamp: 'jmv 2/28/2020 12:10:34' overrides: 16880792! - at: index put: value - ^self floatAt: index put: value! ! -!FloatArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:19' overrides: 16780286! - defaultElement - "Return the default element of the receiver" - ^0.0! ! -!FloatArray methodsFor: 'accessing' stamp: 'laza 3/24/2000 13:08'! - length - "Return the length of the receiver" - ^self squaredLength sqrt! ! -!FloatArray methodsFor: 'accessing' stamp: 'laza 3/24/2000 13:08'! - squaredLength - "Return the squared length of the receiver" - ^self dot: self! ! -!FloatArray methodsFor: 'interpolating' stamp: 'jmv 9/28/2017 13:36:31'! - interpolateValues: valuesArray at: x - "Interpret self as a domain and valuesArray as a function samples." - - ^self - findBinaryIndex: [ :arg | x - arg ] - do: [ :i | valuesArray at: i ] - ifNone: [ :i :j | - ((valuesArray at: i) interpolateTo: (valuesArray at: j) at: (x - (self at: i)) / ((self at: j) - (self at: i)))]! ! -!FloatArray methodsFor: 'interpolating' stamp: 'jmv 5/6/2015 15:02'! - interpolatedValueAt: floatIndex - "Do a linear interpolation. - Gives usual error if argument outside bounds: - #[ 4 5 ] asFloatArray interpolatedValueAt: 0.999 - #[ 4 5 ] asFloatArray interpolatedValueAt: 1.0 - #[ 4 5 ] asFloatArray interpolatedValueAt: 1.5 - #[ 4 5 ] asFloatArray interpolatedValueAt: 2.0 - #[ 4 5 ] asFloatArray interpolatedValueAt: 2.000001 - #[ 4 5 ] asFloatArray interpolatedValueAt: 3 - " - | size index0 index1 weight0 weight1 | - - size _ self size. - index0 _ floatIndex truncated. "Could be #floor. But as we only care for values >=1, it is the same. But faster." - - weight1 _ floatIndex - index0. - weight0 _ 1.0 - weight1. - - index1 _ (index0 = size and: [ weight1 = 0.0 ]) "Avoid the invalid access if this was true, but don't make it slower the most common, general case." - ifFalse: [ index0 + 1 ] - ifTrue: [ index0 ]. - - "/* perform interpolation */" - ^ (weight0 * (self at: index0)) + (weight1 * (self at: index1))! ! -!FloatArray methodsFor: 'inspecting' stamp: 'sqr 5/22/2020 19:53:21' overrides: 16881790! - inspectorClass - "Answer the class of the inspector to be used on the receiver. Called by inspect; - use basicInspect to get a normal (less useful) type of inspector." - - ^SequenceableCollectionInspector! ! - -Float64Array removeSelector: #interpolatedValueAt:! - -!methodRemoval: Float64Array #interpolatedValueAt: stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -interpolatedValueAt: floatIndex - "Do a linear interpolation. - Gives usual error if argument outside bounds: - #[ 4 5 ] asFloatArray interpolatedValueAt: 0.999 - #[ 4 5 ] asFloatArray interpolatedValueAt: 1.0 - #[ 4 5 ] asFloatArray interpolatedValueAt: 1.5 - #[ 4 5 ] asFloatArray interpolatedValueAt: 2.0 - #[ 4 5 ] asFloatArray interpolatedValueAt: 2.000001 - #[ 4 5 ] asFloatArray interpolatedValueAt: 3 - " - | size index0 index1 weight0 weight1 | - - size _ self size. - index0 _ floatIndex truncated. "Could be #floor. But as we only care for values >=1, it is the same. But faster." - - weight1 _ floatIndex - index0. - weight0 _ 1.0 - weight1. - - index1 _ (index0 = size and: [ weight1 = 0.0 ]) "Avoid the invalid access if this was true, but don't make it slower the most common, general case." - ifFalse: [ index0 + 1 ] - ifTrue: [ index0 ]. - - "/* perform interpolation */" - ^ (weight0 * (self at: index0)) + (weight1 * (self at: index1))! - -Float64Array removeSelector: #squaredLength! - -!methodRemoval: Float64Array #squaredLength stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -squaredLength - "Return the squared length of the receiver" - ^self dot: self! - -Float64Array removeSelector: #*! - -!methodRemoval: Float64Array #* stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -* anObject - - ^self copy *= anObject! - -Float64Array removeSelector: #*=! - -!methodRemoval: Float64Array #*= stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -*= anObject - ^anObject isNumber - ifTrue:[self primMulScalar: anObject asFloat] - ifFalse:[self primMulArray: anObject]! - -Float64Array removeSelector: #-=! - -!methodRemoval: Float64Array #-= stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! --= anObject - ^anObject isNumber - ifTrue:[self primSubScalar: anObject asFloat] - ifFalse:[self primSubArray: anObject]! - -Float64Array removeSelector: #+=! - -!methodRemoval: Float64Array #+= stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -+= anObject - ^anObject isNumber - ifTrue:[self primAddScalar: anObject asFloat] - ifFalse:[self primAddArray: anObject]! - -Float64Array removeSelector: #-! - -!methodRemoval: Float64Array #- stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -- anObject - - ^self copy -= anObject! - -Float64Array removeSelector: #at:! - -!methodRemoval: Float64Array #at: stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -at: index - "Return the element (e.g., 64 bit Float) at the given index" - ^self floatAt: index! - -Float64Array removeSelector: #negated! - -!methodRemoval: Float64Array #negated stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -negated - - ^self copy *= -1! - -Float64Array removeSelector: #inspectorClass! - -!methodRemoval: Float64Array #inspectorClass stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -inspectorClass - "Answer the class of the inspector to be used on the receiver. Called by inspect; - use basicInspect to get a normal (less useful) type of inspector." - - ^SequenceableCollectionInspector! - -Float64Array removeSelector: #+! - -!methodRemoval: Float64Array #+ stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -+ anObject - - ^self copy += anObject! - -Float64Array removeSelector: #/=! - -!methodRemoval: Float64Array #/= stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -/= anObject - - ^self divideBy: anObject - ifDivisorZero: [ZeroDivide new signalReceiver: self selector: #/= argument: anObject] - ifBothZero: [ZeroDivide new signalReceiver: self selector: #/= argument: anObject]! - -Float64Array removeSelector: #interpolateValues:at:! - -!methodRemoval: Float64Array #interpolateValues:at: stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -interpolateValues: valuesArray at: x - "Interpret self as a domain and valuesArray as a function samples." - - ^self - findBinaryIndex: [ :arg | x - arg ] - do: [ :i | valuesArray at: i ] - ifNone: [ :i :j | - ((valuesArray at: i) interpolateTo: (valuesArray at: j) at: (x - (self at: i)) / ((self at: j) - (self at: i)))]! - -Float64Array removeSelector: #length! - -!methodRemoval: Float64Array #length stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -length - "Return the length of the receiver" - ^self squaredLength sqrt! - -Float64Array removeSelector: #divideBy:ifDivisorZero:ifBothZero:! - -!methodRemoval: Float64Array #divideBy:ifDivisorZero:ifBothZero: stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -divideBy: aFloatArrayOrNumber ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue - ^aFloatArrayOrNumber isNumber - ifTrue:[self divideByScalar: aFloatArrayOrNumber asFloat ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue] - ifFalse:[self divideByArray: aFloatArrayOrNumber ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue]! - -Float64Array removeSelector: #at:put:! - -!methodRemoval: Float64Array #at:put: stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -at: index put: aFloat - "Store the argument (e.g., 64 bit Float) at the given index" - ^self floatAt: index put: aFloat! - -Float64Array removeSelector: #defaultElement! - -!methodRemoval: Float64Array #defaultElement stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -defaultElement - "Return the default element of the receiver" - ^0.0! - -Float64Array removeSelector: #/! - -!methodRemoval: Float64Array #/ stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -/ anObject - - ^self copy /= anObject! - -Float32Array removeSelector: #interpolatedValueAt:! - -!methodRemoval: Float32Array #interpolatedValueAt: stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -interpolatedValueAt: floatIndex - "Do a linear interpolation. - Gives usual error if argument outside bounds: - #[ 4 5 ] asFloatArray interpolatedValueAt: 0.999 - #[ 4 5 ] asFloatArray interpolatedValueAt: 1.0 - #[ 4 5 ] asFloatArray interpolatedValueAt: 1.5 - #[ 4 5 ] asFloatArray interpolatedValueAt: 2.0 - #[ 4 5 ] asFloatArray interpolatedValueAt: 2.000001 - #[ 4 5 ] asFloatArray interpolatedValueAt: 3 - " - | size index0 index1 weight0 weight1 | - - size _ self size. - index0 _ floatIndex truncated. "Could be #floor. But as we only care for values >=1, it is the same. But faster." - - weight1 _ floatIndex - index0. - weight0 _ 1.0 - weight1. - - index1 _ (index0 = size and: [ weight1 = 0.0 ]) "Avoid the invalid access if this was true, but don't make it slower the most common, general case." - ifFalse: [ index0 + 1 ] - ifTrue: [ index0 ]. - - "/* perform interpolation */" - ^ (weight0 * (self at: index0)) + (weight1 * (self at: index1))! - -Float32Array removeSelector: #squaredLength! - -!methodRemoval: Float32Array #squaredLength stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -squaredLength - "Return the squared length of the receiver" - ^self dot: self! - -Float32Array removeSelector: #+=! - -!methodRemoval: Float32Array #+= stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -+= anObject - ^anObject isNumber - ifTrue:[self primAddScalar: anObject asFloat] - ifFalse:[self primAddArray: anObject]! - -Float32Array removeSelector: #-=! - -!methodRemoval: Float32Array #-= stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! --= anObject - ^anObject isNumber - ifTrue:[self primSubScalar: anObject asFloat] - ifFalse:[self primSubArray: anObject]! - -Float32Array removeSelector: #-! - -!methodRemoval: Float32Array #- stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -- anObject - - ^self copy -= anObject! - -Float32Array removeSelector: #/=! - -!methodRemoval: Float32Array #/= stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -/= anObject - - ^self divideBy: anObject - ifDivisorZero: [ZeroDivide new signalReceiver: self selector: #/= argument: anObject] - ifBothZero: [ZeroDivide new signalReceiver: self selector: #/= argument: anObject]! - -Float32Array removeSelector: #interpolateValues:at:! - -!methodRemoval: Float32Array #interpolateValues:at: stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -interpolateValues: valuesArray at: x - "Interpret self as a domain and valuesArray as a function samples." - - ^self - findBinaryIndex: [ :arg | x - arg ] - do: [ :i | valuesArray at: i ] - ifNone: [ :i :j | - ((valuesArray at: i) interpolateTo: (valuesArray at: j) at: (x - (self at: i)) / ((self at: j) - (self at: i)))]! - -Float32Array removeSelector: #'\\='! - -!methodRemoval: Float32Array #'\\=' stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -\\= 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). - ]. - -! - -Float32Array removeSelector: #at:put:! - -!methodRemoval: Float32Array #at:put: stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -at: index put: value - ^self floatAt: index put: value! - -Float32Array removeSelector: #defaultElement! - -!methodRemoval: Float32Array #defaultElement stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -defaultElement - "Return the default element of the receiver" - ^0.0! - -Float32Array removeSelector: #negated! - -!methodRemoval: Float32Array #negated stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -negated - - ^self copy *= -1! - -Float32Array removeSelector: #*! - -!methodRemoval: Float32Array #* stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -* anObject - - ^self copy *= anObject! - -Float32Array removeSelector: #*=! - -!methodRemoval: Float32Array #*= stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -*= anObject - ^anObject isNumber - ifTrue:[self primMulScalar: anObject asFloat] - ifFalse:[self primMulArray: anObject]! - -Float32Array removeSelector: #at:! - -!methodRemoval: Float32Array #at: stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -at: index - ^self floatAt: index! - -Float32Array removeSelector: #inspectorClass! - -!methodRemoval: Float32Array #inspectorClass stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -inspectorClass - "Answer the class of the inspector to be used on the receiver. Called by inspect; - use basicInspect to get a normal (less useful) type of inspector." - - ^SequenceableCollectionInspector! - -Float32Array removeSelector: #+! - -!methodRemoval: Float32Array #+ stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -+ anObject - - ^self copy += anObject! - -Float32Array removeSelector: #length! - -!methodRemoval: Float32Array #length stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -length - "Return the length of the receiver" - ^self squaredLength sqrt! - -Float32Array removeSelector: #divideBy:ifDivisorZero:ifBothZero:! - -!methodRemoval: Float32Array #divideBy:ifDivisorZero:ifBothZero: stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -divideBy: aFloatArrayOrNumber ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue - ^aFloatArrayOrNumber isNumber - ifTrue:[self divideByScalar: aFloatArrayOrNumber asFloat ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue] - ifFalse:[self divideByArray: aFloatArrayOrNumber ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue]! - -Float32Array removeSelector: #/! - -!methodRemoval: Float32Array #/ stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -/ anObject - - ^self copy /= anObject! - -Float32Array removeSelector: #adaptToNumber:andSend:! - -!methodRemoval: Float32Array #adaptToNumber:andSend: stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -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:[ - "DO NOT USE TRIVIAL CODE - ^self reciprocal * rcvr - BECAUSE OF GRADUAL UNDERFLOW - self should: (1.0e-39 / (FloatArray with: 1.0e-39)) first < 2." - ^(self class new: self size withAll: rcvr) / self - ]. - ^super adaptToNumber: rcvr andSend: selector! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4367] on 3 September 2020 at 6:23:25 pm'! -!FloatArray methodsFor: 'arithmetic' stamp: 'jmv 9/3/2020 18:10:25'! - divideByArray: floatArray ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue - - 1 to: self size do: [ :i | | dividend divisor quotient | - dividend _ self at: i. - divisor _ floatArray at: i. - quotient _ - divisor isZero - ifTrue: [ - dividend isZero - ifTrue: indeterminateBlockOrValue - ifFalse: zeroDivisionBlockOrValue ] - ifFalse: [dividend / divisor]. - self at: i put: quotient]! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'jmv 9/3/2020 18:19:30'! - divideByScalar: scalarValue ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue - - "This primitive doesn't fail if argument is zeros, just fills with infinity or nan" - scalarValue isZero ifFalse: [ - ^ self primDivScalar: scalarValue ]. - 1 to: self size do:[:i| | dividend quotient | - dividend _ self at: i. - quotient _ dividend isZero - ifTrue: indeterminateBlockOrValue - ifFalse: zeroDivisionBlockOrValue. - self at: i put: quotient]! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'jmv 9/3/2020 18:20:04'! - dot: aFloatVector - "Return the dot product of the receiver and the argument. - Fail if the argument is not of the same size as the receiver." - - | result | - 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! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'jmv 9/3/2020 18:21:43'! - normalize - "Unsafely normalize the receiver in-place (become a unit vector). - Div-by-Zero raised if len 0." - - self /= self length.! ! -!FloatArray methodsFor: 'comparing' stamp: 'jmv 6/11/2019 16:22:31' overrides: 16905999! - = another - self == another ifTrue: [ ^ true ]. - self class == another class ifFalse: [ ^ false ]. - self size > 256 ifTrue: [ - self hashQuick = another hashQuick ifFalse: [ ^false ]]. - ^self primitiveEqual: another! ! -!FloatArray methodsFor: 'comparing' stamp: 'jmv 6/11/2019 16:10:44' overrides: 50464108! - hash - self size > 256 ifTrue: [ ^ self hashQuick ]. - ^ self hashFull! ! -!FloatArray methodsFor: 'comparing' stamp: 'jmv 9/3/2020 17:59:40'! - hashFull - | hash | - hash _ (self species hash + self size hash) hashMultiply. - 1 to: self size do: [:i | hash _ (hash + (self basicAt: i)) hashMultiply]. - ^hash! ! -!FloatArray methodsFor: 'comparing' stamp: 'jmv 9/3/2020 18:02:29'! - primitiveEqual: aFloatArray - | length | - aFloatArray class == self class ifFalse: [^ false]. - length _ self size. - length = aFloatArray size ifFalse: [^ false]. - 1 to: self size do: [:i | (self at: i) - = (aFloatArray at: i) ifFalse: [^ false]]. - ^ true! ! -!FloatArray methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:20:40'! - primAddArray: floatArray - - 1 to: self size do: [ :i | self at: i put: (self at: i) + (floatArray at: i) ].! ! -!FloatArray methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:20:36'! - primAddScalar: scalarValue - - 1 to: self size do: [ :i | self at: i put: (self at: i) + scalarValue ].! ! -!FloatArray methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:17:07'! - primDivArray: floatArray - "Actually only called for Float32Array that redefines this method. - Just a placeholder." - - ^#primitiveFailure! ! -!FloatArray methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:19:24'! - primDivScalar: scalarValue - "This primitive doesn't fail if argument is zero. It fills result with infinity or nan. - For consistency with division with arrays, and general practice, an exception block or value might be used in public protocol. If needed, call directly this method instead. - - #[1.0 2.0 3.141592 0.0] asFloatArray primDivScalar: 0.0. - #[1.0 2.0 3.141592 0.0] asFloatArray / 0.0. - #[1.0 2.0 3.141592 0.0] asFloatArray divideBy: 0.0 ifDivisorZero: -100 ifBothZero: -200 - " - 1 to: self size do: [ :i | self at: i put: (self at: i) / scalarValue].! ! -!FloatArray methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:20:33'! - primMulArray: floatArray - - 1 to: self size do: [ :i | self at: i put: (self at: i) * (floatArray at: i) ].! ! -!FloatArray methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:20:30'! - primMulScalar: scalarValue - - 1 to: self size do: [ :i | self at: i put: (self at: i) * scalarValue ].! ! -!FloatArray methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:20:27'! - primSubArray: floatArray - - 1 to: self size do: [ :i | self at: i put: (self at: i) - (floatArray at: i) ].! ! -!FloatArray methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:20:23'! - primSubScalar: scalarValue - - 1 to: self size do: [ :i | self at: i put: (self at: i) - scalarValue ].! ! -!Float32Array methodsFor: 'arithmetic' stamp: 'jmv 9/3/2020 18:11:02' prior: 50404454 overrides: 50543094! - divideByArray: floatArray ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue - - (self primDivArray: floatArray) == #primitiveFailure ifTrue: [ - super - divideByArray: floatArray - ifDivisorZero: zeroDivisionBlockOrValue - ifBothZero: indeterminateBlockOrValue ]! ! -!Float32Array methodsFor: 'arithmetic' stamp: 'jmv 9/3/2020 18:18:38' prior: 16846498 overrides: 50543127! - 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." - - - ^super dot: aFloatVector! ! -!Float32Array methodsFor: 'arithmetic' stamp: 'jmv 9/3/2020 18:22:00' prior: 16846518 overrides: 50543141! -normalize - "Unsafely normalize the receiver in-place (become a unit vector). - Div-by-Zero raised if len 0." - - - ^super normalize! ! -!Float32Array methodsFor: 'comparing' stamp: 'jmv 9/3/2020 17:59:54' prior: 50464075 overrides: 50543164! - hashFull - - ^super hashFull! ! -!Float32Array methodsFor: 'comparing' stamp: 'jmv 9/3/2020 18:00:15' prior: 16846555 overrides: 50543172! - primitiveEqual: aFloatArray - - - ^super primitiveEqual: aFloatArray! ! -!Float32Array methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:03:03' prior: 16846568 overrides: 50543183! - primAddArray: floatArray - - - ^super primAddArray: floatArray! ! -!Float32Array methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:03:25' prior: 16846576 overrides: 50543189! - primAddScalar: scalarValue - - - ^super primAddScalar: scalarValue! ! -!Float32Array methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:08:15' prior: 50404514 overrides: 50543202! - primDivScalar: scalarValue - "This primitive doesn't fail if argument is zero. It fills result with infinity or nan. - For consistency with division with arrays, and general practice, an exception block or value might be used in public protocol. If needed, call directly this method instead. - - #[1.0 2.0 3.141592 0.0] asFloatArray primDivScalar: 0.0. - #[1.0 2.0 3.141592 0.0] asFloatArray / 0.0. - #[1.0 2.0 3.141592 0.0] asFloatArray divideBy: 0.0 ifDivisorZero: -100 ifBothZero: -200 - " - - ^super primDivScalar: scalarValue! ! -!Float32Array methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:03:54' prior: 16846600 overrides: 50543222! - primMulArray: floatArray - - - ^super primMulArray: floatArray! ! -!Float32Array methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:04:14' prior: 16846608 overrides: 50543228! - primMulScalar: scalarValue - - - ^super primMulScalar: scalarValue! ! -!Float32Array methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:04:35' prior: 16846616 overrides: 50543234! - primSubArray: floatArray - - - ^super primSubArray: floatArray! ! -!Float32Array methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:04:53' prior: 16846624 overrides: 50543240! - primSubScalar: scalarValue - - - ^super primSubScalar: scalarValue! ! - -Float64Array removeSelector: #primSubScalar:! - -!methodRemoval: Float64Array #primSubScalar: stamp: 'Install-4369-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h47m-jmv.001.cs.st 10/15/2020 19:33:00'! -primSubScalar: scalarValue - - "It would be nice to have FloatArrayPlugin or equivalent for Float64Array... - " - 1 to: self size do:[:i| self at: i put: (self at: i) - scalarValue].! - -Float64Array removeSelector: #primAddArray:! - -!methodRemoval: Float64Array #primAddArray: stamp: 'Install-4369-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h47m-jmv.001.cs.st 10/15/2020 19:33:00'! -primAddArray: floatArray - - "It would be nice to have FloatArrayPlugin or equivalent for Float64Array... - " - 1 to: self size do:[:i| self at: i put: (self at: i) + (floatArray at: i)].! - -Float64Array removeSelector: #primMulScalar:! - -!methodRemoval: Float64Array #primMulScalar: stamp: 'Install-4369-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h47m-jmv.001.cs.st 10/15/2020 19:33:00'! -primMulScalar: scalarValue - - "It would be nice to have FloatArrayPlugin or equivalent for Float64Array... - " - 1 to: self size do:[:i| self at: i put: (self at: i) * scalarValue].! - -Float64Array removeSelector: #primAddScalar:! - -!methodRemoval: Float64Array #primAddScalar: stamp: 'Install-4369-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h47m-jmv.001.cs.st 10/15/2020 19:33:00'! -primAddScalar: scalarValue - - "It would be nice to have FloatArrayPlugin or equivalent for Float64Array... - " - 1 to: self size do:[:i| self at: i put: (self at: i) + scalarValue].! - -Float64Array removeSelector: #dot:! - -!methodRemoval: Float64Array #dot: stamp: 'Install-4369-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h47m-jmv.001.cs.st 10/15/2020 19:33:00'! -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 | - "It would be nice to have FloatArrayPlugin or equivalent for Float64Array... - " - self flag: #Float64Primitive. - - 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! - -Float64Array removeSelector: #divideByScalar:ifDivisorZero:ifBothZero:! - -!methodRemoval: Float64Array #divideByScalar:ifDivisorZero:ifBothZero: stamp: 'Install-4369-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h47m-jmv.001.cs.st 10/15/2020 19:33:00'! -divideByScalar: scalarValue ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue - - "It would be nice to have FloatArrayPlugin or equivalent for Float64Array..." - 1 to: self size do:[:i| | dividend quotient | - dividend _ self at: i. - quotient _ - scalarValue isZero - ifTrue: [ - dividend isZero - ifTrue: indeterminateBlockOrValue - ifFalse: zeroDivisionBlockOrValue ] - ifFalse: [dividend / scalarValue]. - self at: i put: quotient]! - -Float64Array removeSelector: #primSubArray:! - -!methodRemoval: Float64Array #primSubArray: stamp: 'Install-4369-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h47m-jmv.001.cs.st 10/15/2020 19:33:00'! -primSubArray: floatArray - - "It would be nice to have FloatArrayPlugin or equivalent for Float64Array... - " - 1 to: self size do:[:i| self at: i put: (self at: i) - (floatArray at: i)].! - -Float64Array removeSelector: #divideByArray:ifDivisorZero:ifBothZero:! - -!methodRemoval: Float64Array #divideByArray:ifDivisorZero:ifBothZero: stamp: 'Install-4369-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h47m-jmv.001.cs.st 10/15/2020 19:33:00'! -divideByArray: floatArray ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue - - "It would be nice to have FloatArrayPlugin or equivalent for Float64Array..." - 1 to: self size do:[:i| | dividend divisor quotient | - dividend _ self at: i. - divisor _ floatArray at: i. - quotient _ - divisor isZero - ifTrue: [ - dividend isZero - ifTrue: indeterminateBlockOrValue - ifFalse: zeroDivisionBlockOrValue ] - ifFalse: [dividend / divisor]. - self at: i put: quotient]! - -Float64Array removeSelector: #normalize! - -!methodRemoval: Float64Array #normalize stamp: 'Install-4369-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h47m-jmv.001.cs.st 10/15/2020 19:33:00'! -normalize - "Unsafely normalize the receiver in-place (become a unit vector). - Div-by-Zero raised if len 0." - "It would be nice to have FloatArrayPlugin or equivalent for Float64Array... - " - self /= self length.! - -Float64Array removeSelector: #primMulArray:! - -!methodRemoval: Float64Array #primMulArray: stamp: 'Install-4369-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h47m-jmv.001.cs.st 10/15/2020 19:33:00'! -primMulArray: floatArray - - "It would be nice to have FloatArrayPlugin or equivalent for Float64Array... - " - 1 to: self size do:[:i| self at: i put: (self at: i) * (floatArray at: i)].! - -Float32Array removeSelector: #=! - -!methodRemoval: Float32Array #= stamp: 'Install-4369-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h47m-jmv.001.cs.st 10/15/2020 19:33:00'! -= another - self == another ifTrue: [ ^ true ]. - self class == another class ifFalse: [ ^ false ]. - self size > 256 ifTrue: [ - self hashQuick = another hashQuick ifFalse: [ ^false ]]. - ^self primitiveEqual: another! - -Float32Array removeSelector: #divideByScalar:ifDivisorZero:ifBothZero:! - -!methodRemoval: Float32Array #divideByScalar:ifDivisorZero:ifBothZero: stamp: 'Install-4369-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h47m-jmv.001.cs.st 10/15/2020 19:33:00'! -divideByScalar: scalarValue ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue - - "This primitive doesn't fail if argument is zeros, just fills with infinity or nan" - scalarValue isZero ifFalse: [ - ^self primDivScalar: scalarValue ]. - 1 to: self size do:[:i| | dividend quotient | - dividend _ self at: i. - quotient _ dividend isZero - ifTrue: indeterminateBlockOrValue - ifFalse: zeroDivisionBlockOrValue. - self at: i put: quotient]! - -Float32Array removeSelector: #hash! - -!methodRemoval: Float32Array #hash stamp: 'Install-4369-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h47m-jmv.001.cs.st 10/15/2020 19:33:00'! -hash - self size > 256 ifTrue: [ ^ self hashQuick ]. - ^ self hashFull! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4369-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h47m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4369] on 3 September 2020 at 6:44:44 pm'! -!Collection methodsFor: 'converting' stamp: 'jmv 9/3/2020 18:37:44'! - asFloat32Array - "Answer a FloatArray whose elements are the elements of the receiver" - - ^self as: Float32Array! ! -!FloatArray methodsFor: 'initialization' stamp: 'jmv 9/3/2020 18:43:04'! - loadFrom: srcObject - - self == srcObject ifTrue: [ ^self ]. - self class == srcObject class - ifTrue: [ self replaceFrom: 1 to: self size with: srcObject startingAt: 1 ] - ifFalse: [ self privateLoadFrom: srcObject ]! ! -!FloatArray methodsFor: 'initialization' stamp: 'jmv 9/3/2020 18:43:51'! - privateLoadFrom: srcObject - "Load the receiver from the given source object. - See inheritance." - self error: 'Cannot load a ', srcObject class name,' into a ', self class name! ! -!FloatArray methodsFor: 'interpolating' stamp: 'jmv 9/3/2020 18:40:49' prior: 50542597! - interpolatedValueAt: floatIndex - "Do a linear interpolation. - Gives usual error if argument outside bounds: - #[ 4 5 ] asFloat32Array interpolatedValueAt: 0.999 - #[ 4 5 ] asFloat32Array interpolatedValueAt: 1.0 - #[ 4 5 ] asFloat32Array interpolatedValueAt: 1.5 - #[ 4 5 ] asFloat32Array interpolatedValueAt: 2.0 - #[ 4 5 ] asFloat32Array interpolatedValueAt: 2.000001 - #[ 4 5 ] asFloat32Array interpolatedValueAt: 3 - " - | size index0 index1 weight0 weight1 | - - size _ self size. - index0 _ floatIndex truncated. "Could be #floor. But as we only care for values >=1, it is the same. But faster." - - weight1 _ floatIndex - index0. - weight0 _ 1.0 - weight1. - - index1 _ (index0 = size and: [ weight1 = 0.0 ]) "Avoid the invalid access if this was true, but don't make it slower the most common, general case." - ifFalse: [ index0 + 1 ] - ifTrue: [ index0 ]. - - "/* perform interpolation */" - ^ (weight0 * (self at: index0)) + (weight1 * (self at: index1))! ! -!FloatArray methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:40:55' prior: 50543202! - primDivScalar: scalarValue - "This primitive doesn't fail if argument is zero. It fills result with infinity or nan. - For consistency with division with arrays, and general practice, an exception block or value might be used in public protocol. If needed, call directly this method instead. - - #[1.0 2.0 3.141592 0.0] asFloat32Array primDivScalar: 0.0. - #[1.0 2.0 3.141592 0.0] asFloat32Array / 0.0. - #[1.0 2.0 3.141592 0.0] asFloat32Array divideBy: 0.0 ifDivisorZero: -100 ifBothZero: -200 - " - 1 to: self size do: [ :i | self at: i put: (self at: i) / scalarValue].! ! -!Float32Array methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:40:33' prior: 50543312 overrides: 50543642! - primDivScalar: scalarValue - "This primitive doesn't fail if argument is zero. It fills result with infinity or nan. - For consistency with division with arrays, and general practice, an exception block or value might be used in public protocol. If needed, call directly this method instead. - - #[1.0 2.0 3.141592 0.0] asFloat32Array primDivScalar: 0.0. - #[1.0 2.0 3.141592 0.0] asFloat32Array / 0.0. - #[1.0 2.0 3.141592 0.0] asFloat32Array divideBy: 0.0 ifDivisorZero: -100 ifBothZero: -200 - " - - ^super primDivScalar: scalarValue! ! - -Float64Array removeSelector: #loadFrom:! - -!methodRemoval: Float64Array #loadFrom: stamp: 'Install-4370-FloatArrayCleanup-JuanVuletich-2020Sep03-18h37m-jmv.001.cs.st 10/15/2020 19:33:00'! -loadFrom: srcObject - - self == srcObject ifTrue: [ ^self ]. - self class == srcObject class - ifTrue: [ self replaceFrom: 1 to: self size with: srcObject startingAt: 1 ] - ifFalse: [ self privateLoadFrom: srcObject ]! - -Float64Array removeSelector: #privateLoadFrom:! - -!methodRemoval: Float64Array #privateLoadFrom: stamp: 'Install-4370-FloatArrayCleanup-JuanVuletich-2020Sep03-18h37m-jmv.001.cs.st 10/15/2020 19:33:00'! -privateLoadFrom: srcObject - "Load the receiver from the given source object." - self error:'Cannot load a ', srcObject class name,' into a ', self class name! - -Collection removeSelector: #asFloatArray! - -!methodRemoval: Collection #asFloatArray stamp: 'Install-4370-FloatArrayCleanup-JuanVuletich-2020Sep03-18h37m-jmv.001.cs.st 10/15/2020 19:33:00'! -asFloatArray - "Answer a FloatArray whose elements are the elements of the receiver" - - ^self as: Float32Array! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4370-FloatArrayCleanup-JuanVuletich-2020Sep03-18h37m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4365] on 2 September 2020 at 9:48:47 pm'! -!Integer methodsFor: 'benchmarks' stamp: 'jmv 9/2/2020 21:46:29' prior: 50526942! - tinyBenchmarks - "Report the results of running the two tiny Squeak benchmarks. - ar 9/10/1999: Adjusted to run at least 1 sec to get more stable results - - Measurements or estimations from - https://smalltalkzoo.computerhistory.org/papers/EvolutionOfSmalltalk.pdf - ('The evolution of Smalltalk: from Smalltalk-72 through Squeak' by Dan Ingalls, p.98) - http://wiki.c2.com/?GreenBook - http://www.wirfs-brock.com/allen/things/smalltalk-things/tektronix-smalltalk-document-archive/1982-qtr4-magnolia-perf-graph.pdf - http://www.wirfs-brock.com/allen/things/smalltalk-things/tektronix-smalltalk-document-archive/1983-Magnolia-st-perf.pdf - - Xerox PARC systems - Alto Smalltalk-72 5MHz µcode 694 bytecodes/sec 54 sends/sec 7200 µclocks/bytecode - Alto Smalltalk-74 5MHz µcode 607 bytecodes/sec 46 sends/sec 8200 µclocks/bytecode - Alto Smalltalk-76 5MHz µcode 16k bytecodes/sec 118 sends/sec 310 µclocks/bytecode - NoteTaker Smalltalk-78 5MHz 8086 30k bytecodes/sec 250 sends/sec 166.67 clocks/bytecode - Dorado Smalltalk-76 16.67MHz µcode 1M bytecodes/sec 50k sends/sec 16.67 µClocks/bytecode - - Green Book systems - DEC PDP-11/23 5k bytecodes/sec (Green Book, p.128) - Apple 5MHz 68000 11k bytecodes/sec (Green Book, p.187, awb) 5000 clocks/bytecode - VAX-11/780 5MHz C HP Smalltalk 10k bytecodes/sec (Green Book, p.235) 450 clocks/bytecode - VAX-11/780 5MHz C Berkeley St 17k bytecodes/sec (Green Book, p.203, awb) 300 clocks/bytecode - DEC VAX-11/780 5MHz assembly 20k bytecodes/sec (Green Book, p.149, awb) 250 clocks/bytecode - TEK Magnolia 10MHz 68000 50k bytecodes/sec (awb) 200 clocks/bytecode - - Squeak & Cuis - 110 MHz PowerPC Mac 8100 4.1M bytecodes/sec; 175k sends/sec 26.8 clocks/bytecode - 292 MHz G3 Mac: 23M bytecodes/sec; 984k sends/sec 12.8 clocks/bytecode - 400 MHz PII/Win98: 18M bytecodes/sec; 1.08M sends/sec 22.2 clocks/bytecode - - 900MHz RasPi2 - StackVM: 38M bytecodes/sec; 2.41M sends/sec 16.2 clocks/bytecode - 900MHz RasPi2- CogSSpur: 157M bytecodes/sec; 10.95M sends/sec 5.7 clocks/bytecode - - 1GHz C.H.I.P. (*1) - StackVM: 55M bytecodes/sec; 3.35M sends/sec 18.1 clocks/bytecode - 1GHz C.H.I.P. (*1) - CogSpur: 254M bytecodes/sec; 16.85M sends/sec 3.9 clocks/bytecode - - 1.2GHz RasPi3B - StackSpur: 44M bytecodes/sec; 2.77M sends/sec 27.2 clocks/bytecode - 1.2GHz RasPi3B - CogSpur: 282M bytecodes/sec; 16.40M sends/sec 6.6 clocks/bytecode - - 1.66GHz Atom N450 - Cog: 244M bytecodes/sec; 28.80M sends/sec 6.8 clocks/bytecode - 1.66GHz Atom N450 - CogSpur: 470M bytecodes/sec; 30.75M sends/sec 3.5 clocks/bytecode - - 1.33GHz Atom 3735G - Cog: 326M bytecodes/sec; 34.99M sends/sec 4.1 clocks/bytecode - 1.33GHz Atom 3735G - CogSpur: 632M bytecodes/sec; 33.69M sends/sec 2.1 clocks/bytecode - - 1.5GHz AMD A4-5000 - Cog: 390M bytecodes/sec; 47.51M sends/sec 3.8 clocks/bytecode - 1.5GHz AMD A4-5000 - CogSpur: 676M bytecodes/sec; 40.67M sends/sec 2.2 clocks/bytecode - 1.5GHz AMD A4-5000 - CogSpur64: 659M bytecodes/sec; 50.34M sends/sec 2.2 clocks/bytecode - - 2.3GHz Tegra (*2) - StackVM: 259M bytecodes/sec; 13.01M sends/sec 8.9 clocks/bytecode - 2.3GHz Tegra (*2) - CogSpur: 1.08G bytecodes/sec; 64.29M sends/sec 2.1 clocks/bytecode - - 3.1GHz Core i3-2100 - Cog: 1.20G bytecodes/sec; 165.72M sends/sec 2.6 clocks/bytecode - 3.1GHz Core i3-2100 - CogSpur: 2.04G bytecodes/sec; 127.84M sends/sec 1.5 clocks/bytecode - - 2.70GHz Core i5-6400 -CogSpur64 3.16G bytecodes/sec; 243.32M sends/sec 0.85 clocks/bytecode - - (*1) C.H.I.P. $9 Computer [Next Thing Co], Allwinner R8 Single-Core ARM Cortex-A8 - 1 GHz - (*2) ACER Chromebook CB5-311 - NVIDIA Tegra K1 Quad-Core ARM Cortex-A15 'r3' - 2.3 GHz - - It is interesting to note that Cog for the first time brings ARM hardware (RasPi and C.H.I.P.) into a 'Morphic is confortable and nice to use' level of performance, - i.e. around 100 Dorados. - " - | t1 t2 r n1 n2 | - n1 _ 1. - [ - t1 _ Time millisecondsToRun: [n1 benchmark]. - t1 < 1000] - whileTrue: [n1 _ n1 * 2]. "Note: #benchmark's runtime is about O(n)" - - n2 _ 28. - [ - t2 _ Time millisecondsToRun: [r _ n2 benchFib]. - t2 < 1000] - whileTrue: [n2 _ n2 + 1]. - "Note: #benchFib's runtime is about O(k^n), - where k is the golden number = (1 + 5 sqrt) / 2 = 1.618...." - - ^String streamContents: [ :strm | - (n1 * 500000 * 1000) // t1 withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixName; - nextPutAll: 'Bytecodes/second; ' ]. - (r * 1000) // t2 withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixName; - nextPutAll: 'Sends/second' ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4371-HistoricalPerformance-JuanVuletich-2020Sep02-21h46m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4365] on 1 September 2020 at 4:50:43 pm'! -!BlockClosure methodsFor: 'exceptions' stamp: 'ar 12/4/2009 18:41' prior: 16788208! - ifCurtailed: aBlock - "Evaluate the receiver with an abnormal termination action. - Evaluate aBlock only if execution is unwound during execution - of the receiver. If execution of the receiver finishes normally do - not evaluate aBlock. N.B. This method is *not* implemented as a - primitive. Primitive 198 always fails. The VM uses prim 198 in a - context's method as the mark for an ensure:/ifCurtailed: activation." - "The abnormal termination is detected by the vm and signalled as an #aboutToReturn:to: message - sent to a reified current context, with the context of the #ifCurtailed: invocation as an argument. - The current context then walks the stack to unwind and execute any unwind blocks (including the - one protected by the #ifCurtailed: invocation) - see Context>>#resume:through" - | complete result | - - result := self valueNoContextSwitch. - complete := true. - ^result! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4372-ifCurtailed-comment-JuanVuletich-2020Sep01-16h49m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4372] on 7 September 2020 at 1:10:40 pm'! -!MessageNames methodsFor: 'class list' stamp: 'KLG 9/1/2020 21:48:42' overrides: 16869966! - selectedClassOrMetaClass - "Answer the currently selected class (or metaclass). - - If no method is selected, try to interpret the selected message name - as a class" - - ^ super selectedClassOrMetaClass ifNil: [ - self selectedMessageName ifNotNil: [ :className | | mayBeClass | - (mayBeClass _ Smalltalk - at: className ifAbsent: [^ nil ]) isBehavior - ifTrue: [ mayBeClass ] - ifFalse: [ mayBeClass class ] ] ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4373-MessageNames-fix-GeraldKlix-2020Sep07-13h08m-KLG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4373] on 11 September 2020 at 5:35:59 pm'! -!DamageRecorder methodsFor: 'recording' stamp: 'jmv 9/11/2020 17:30:25'! - damageReportedOther - "Answer damage reported for no specific morph, for morphs that are not visible, and for morphs that are carried by the Hand." - | answer | - answer _ OrderedCollection new. - self pvtAccessProtect critical: [ - damageByRoot keysAndValuesDo: [ :m :r | - (m isNil or: [ - m visible not or: [m owner isNil or: [m owner is: #HandMorph]]]) ifTrue: [ - answer add: r]]]. - ^answer! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 9/11/2020 17:34:47'! - computeDamage: aPasteUpMorph repair: aDamageRecorder rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage - "Iterate front to back while computing damage to actually repair for each morph, and for world background." - - | uncoveredDamage morph morphDamage prevMorphDamage reuseInstance ri morphBefore | - morphDamage _ OrderedCollection new. - prevMorphDamage _ OrderedCollection new. - uncoveredDamage _ aDamageRecorder damageReportedOther. - "Iterate from front to back" - 1 to: rootMorphs size do: [ :i | - morph _ rootMorphs at: i. - morph displayFullBounds ifNotNil: [ :morphBounds | - morphDamage removeAll. - (aDamageRecorder damageReportedFor: morph) ifNotNil: [ :r | - morphDamage add: r ]. - uncoveredDamage do: [ :r | - ri _ r intersect: morphBounds. - ri hasPositiveExtent ifTrue: [ - morphDamage add: ri ]]. - 1 to: i-1 do: [ :j | - reuseInstance _ prevMorphDamage. - prevMorphDamage _ morphDamage. - morphDamage _ reuseInstance removeAll. - morphBefore _ rootMorphs at: j. - prevMorphDamage do: [ :r | - morphBefore addPossiblyUncoveredAreasIn: r to: morphDamage ]]. - (Rectangle merging: morphDamage) ifNotNil: [ :morphDamageRect | - rootMorphsDamage at: i put: morphDamageRect. - morph addPossiblyUncoveredAreasIn: morphDamageRect to: uncoveredDamage ]]]. - - ^ uncoveredDamage! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 9/11/2020 16:37:58'! - drawWorldBackground: aPasteUpMorph rects: worldBackgroundDamage - "Draw worldBackgroundDamage rects for aPasteUpMorph. - Do not include submorphs." - - worldBackgroundDamage do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 9/11/2020 17:24:04' prior: 50540523! - drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rootMorphs rootMorphsDamage worldDamage | - "Update #displayBounds for all dirty morphs (marked as such with #redrawNeeded). - Also add the updated bounds to aDamageRecorder, and update bounds of morphs carried by hand." - self updatingMorphBoundsDo: [ - aPasteUpMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - self updateHandsDisplayBounds: aPasteUpMorph ]. - - rootMorphs _ aPasteUpMorph privateSubmorphs. - rootMorphsDamage _ Array new: rootMorphs size. - - worldDamage _ self computeDamage: aPasteUpMorph repair: aDamageRecorder - rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage. - - self drawWorldBackground: aPasteUpMorph rects: worldDamage. - - self drawWorld: aPasteUpMorph - rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage - allDamage: worldDamage. - - aDamageRecorder reset. - ^ worldDamage! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 9/11/2020 17:32:32' prior: 50540257! - drawWorld: aPasteUpMorph rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage allDamage: worldDamage - "Redraw the damaged areas. - Draw each morph just once, merging rectanges to be repaired as needed." - - | morph morphBounds morphDamage | - - "Iterate from back to front." - rootMorphs size to: 1 by: -1 do: [ :i | - morph _ rootMorphs at: i. - morph visible ifTrue: [ - morphBounds _ morph displayFullBounds. - morphDamage _ rootMorphsDamage at: i. - worldDamage do: [ :r | | intersection | - intersection _ r intersect: morphBounds. - intersection hasPositiveExtent ifTrue: [ - morphDamage _ intersection quickMerge: morphDamage ]]. - morphDamage ifNotNil: [ - self newClipRect: morphDamage. - self fullDraw: morph. - worldDamage add: morphDamage ]]].! ! - -MorphicCanvas removeSelector: #drawWorld:rects:! - -!methodRemoval: MorphicCanvas #drawWorld:rects: stamp: 'Install-4374-cleanup-JuanVuletich-2020Sep11-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -drawWorld: aPasteUpMorph rects: allDamage - "Draw allDamage rects for aPasteUpMorph" - - allDamage do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ].! - -MorphicCanvas removeSelector: #drawWorldComputeDamage:repair:rootMorphs:rootMorphsDamage:! - -!methodRemoval: MorphicCanvas #drawWorldComputeDamage:repair:rootMorphs:rootMorphsDamage: stamp: 'Install-4374-cleanup-JuanVuletich-2020Sep11-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -drawWorldComputeDamage: aPasteUpMorph repair: aDamageRecorder rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage - "Iterate front to back while computing damage to actually repair for each morph, and for world background." - - | allDamage morph morphDamage oldMorphDamage reuse ri morphBefore | - morphDamage _ OrderedCollection new. - oldMorphDamage _ OrderedCollection new. - allDamage _ aDamageRecorder damageReportedNotVisibleAndCarriedByHand. - "Iterate from front to back" - 1 to: rootMorphs size do: [ :i | - morph _ rootMorphs at: i. - morph displayFullBounds ifNotNil: [ :morphBounds | - morphDamage removeAll. - (aDamageRecorder damageReportedFor: morph) ifNotNil: [ :r | - morphDamage add: r ]. - allDamage do: [ :r | - ri _ r intersect: morphBounds. - ri hasPositiveExtent ifTrue: [ - morphDamage add: ri ]]. - 1 to: i-1 do: [ :j | - reuse _ oldMorphDamage. - oldMorphDamage _ morphDamage. - morphDamage _ reuse removeAll. - morphBefore _ rootMorphs at: j. - oldMorphDamage do: [ :r | - morphBefore addPossiblyUncoveredAreasIn: r to: morphDamage ]]. - (Rectangle merging: morphDamage) ifNotNil: [ :morphDamageRect | - rootMorphsDamage at: i put: morphDamageRect. - morph addPossiblyUncoveredAreasIn: morphDamageRect to: allDamage ]]]. - - ^ allDamage! - -DamageRecorder removeSelector: #damageReportedNotVisibleAndCarriedByHand! - -!methodRemoval: DamageRecorder #damageReportedNotVisibleAndCarriedByHand stamp: 'Install-4374-cleanup-JuanVuletich-2020Sep11-17h28m-jmv.001.cs.st 10/15/2020 19:33:00'! -damageReportedNotVisibleAndCarriedByHand - | answer | - answer _ OrderedCollection new. - self pvtAccessProtect critical: [ - damageByRoot keysAndValuesDo: [ :m :r | - (m isNil or: [ - m visible not or: [m owner isNil or: [m owner is: #HandMorph]]]) ifTrue: [ - answer add: r]]]. - ^answer! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4374-cleanup-JuanVuletich-2020Sep11-17h28m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4373] on 11 September 2020 at 5:39:28 pm'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 9/11/2020 17:38:48' prior: 50543977! - computeDamage: aPasteUpMorph repair: aDamageRecorder rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage - "Iterate front to back while computing damage to actually repair for each morph, and for world background. - Answer uncoveredDamage, the areas where World background needs to be redrawn." - - | uncoveredDamage morph morphDamage prevMorphDamage reuseInstance morphBefore | - morphDamage _ OrderedCollection new. - prevMorphDamage _ OrderedCollection new. - uncoveredDamage _ aDamageRecorder damageReportedOther. - "Iterate from front to back" - 1 to: rootMorphs size do: [ :i | - morph _ rootMorphs at: i. - morphDamage removeAll. - (aDamageRecorder damageReportedFor: morph) ifNotNil: [ :r | - morphDamage add: r ]. - 1 to: i-1 do: [ :j | - reuseInstance _ prevMorphDamage. - prevMorphDamage _ morphDamage. - morphDamage _ reuseInstance removeAll. - morphBefore _ rootMorphs at: j. - prevMorphDamage do: [ :r | - morphBefore addPossiblyUncoveredAreasIn: r to: morphDamage ]]. - (Rectangle merging: morphDamage) ifNotNil: [ :morphDamageRect | - rootMorphsDamage at: i put: morphDamageRect. - morph addPossiblyUncoveredAreasIn: morphDamageRect to: uncoveredDamage ]]. - - ^ uncoveredDamage! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 9/11/2020 17:37:15' prior: 50544069! - drawWorld: aPasteUpMorph rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage allDamage: worldDamage - "Redraw the damaged areas. - Draw each morph just once, merging rectanges to be repaired as needed." - - | morph morphDamage | - - "Iterate from back to front." - rootMorphs size to: 1 by: -1 do: [ :i | - morph _ rootMorphs at: i. - morph visible ifTrue: [ - morphDamage _ rootMorphsDamage at: i. - morph displayFullBounds ifNotNil: [ :morphFullBounds | - worldDamage do: [ :r | | intersection | - intersection _ r intersect: morphFullBounds. - intersection hasPositiveExtent ifTrue: [ - morphDamage _ intersection quickMerge: morphDamage ]]]. - morphDamage ifNotNil: [ - self newClipRect: morphDamage. - self fullDraw: morph. - worldDamage add: morphDamage ]]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4375-WorldDrawFix-JuanVuletich-2020Sep11-17h35m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4375] on 14 September 2020 at 11:19:51 am'! -!Morph methodsFor: 'events' stamp: 'jmv 9/14/2020 10:56:37' prior: 16874588! - mouseButton3Down: aMouseButtonEvent localPosition: localEventPosition - "Special gestures (cmd-mouse on the Macintosh; Alt-mouse on Windows and Unix) allow a mouse-sensitive morph to be moved or bring up a halo for the morph." - | h doNotDrag | - h _ aMouseButtonEvent hand halo. - "Prevent wrap around halo transfers originating from throwing the event back in" - doNotDrag _ false. - h ifNotNil: [ - (h target == self) ifTrue: [ doNotDrag _ true]. - (h target hasOwner: self) ifTrue: [ doNotDrag _ true]. - (self hasOwner: h target) ifTrue: [ doNotDrag _ true]]. - - "cmd-drag on flexed morphs works better this way" - h _ self addHalo: aMouseButtonEvent. - doNotDrag ifTrue: [ ^self ]. - h ifNotNil: [ - "Initiate drag transition if requested" - "good gesture. implement it" - aMouseButtonEvent hand - waitForClicksOrDrag: h - event: aMouseButtonEvent - clkSel: nil - dblClkSel: nil. - "Pass focus explicitly here" - aMouseButtonEvent hand newMouseFocus: h ]! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 9/14/2020 10:54:31' prior: 50535581! - addHalo: evt - | halo | - self displayBoundsForHalo ifNotNil: [ :r | - halo _ HaloMorph new. - halo popUpFor: self event: evt. - halo morphBounds: r ]. - ^halo! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 9/14/2020 10:52:56' prior: 16875831! - transferHalo: event from: formerHaloOwner - "Progressively transfer the halo to the next likely recipient" - | eventLocalPos | - - formerHaloOwner == self - ifFalse: [ ^self addHalo: event ]. - - eventLocalPos _ self internalizeFromWorld: event eventPosition. - event shiftPressed ifTrue: [ - "Pass it outwards" - owner ifNotNil: [ ^owner transferHalo: event from: formerHaloOwner ]. - "We're at the top level; just keep it on ourselves" - ^self ]. - - self submorphsDo: [ :m | - (m wantsHalo and: [ m fullContainsPoint: (m internalize: eventLocalPos) ]) - ifTrue: [ ^m transferHalo: event from: formerHaloOwner ]]. - "We're at the bottom most level; just keep halo on ourselves"! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 9/14/2020 10:59:33' prior: 50535622! - addHandles - - self removeAllMorphs. "remove old handles, if any" - target displayBoundsForHalo ifNotNil: [ :r | - self morphBounds: r. "update my size" - haloBox _ self basicBox. - target addHandlesTo: self box: haloBox. - self addNameString: (target printStringLimitedTo: 40). - growingOrRotating _ false. - self redrawNeeded ].! ! - -Morph removeSelector: #addHalo:from:! - -!methodRemoval: Morph #addHalo:from: stamp: 'Install-4376-Halo-fix-JuanVuletich-2020Sep14-11h19m-jmv.001.cs.st 10/15/2020 19:33:00'! -addHalo: evt from: formerHaloOwner - "Transfer a halo from the former halo owner to the receiver" - ^self addHalo: evt! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4376-Halo-fix-JuanVuletich-2020Sep14-11h19m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4375] on 14 September 2020 at 11:36:44 am'! -!TextEditor methodsFor: 'private' stamp: 'jmv 9/14/2020 11:34:18' prior: 16932861! - storeSelectionInComposition - "for proper display of selected text" - - pointBlock ifNil: [ ^self ]. - textComposition - selectionStartBlocks: (selectionStartBlocks copyWith: self startBlock) - selectionStopBlocks: (selectionStopBlocks copyWith: self stopBlock)! ! -!TextEditor methodsFor: 'initialization' stamp: 'jmv 9/14/2020 11:35:52' prior: 16933061! - resetState - "Establish the initial conditions for editing the paragraph: place text cursor - before first character and set the emphasis to that of the first character" - - markBlock _ textComposition defaultCharacterBlock. - pointBlock _ markBlock. - selectionStartBlocks _ #(). - selectionStopBlocks _ #()! ! -!InnerTextMorph methodsFor: 'private' stamp: 'jmv 9/14/2020 11:27:57' prior: 16856003! - installEditorAndTextComposition - "Install an editor for my textComposition. Install also the textComposition." - | e tc | - - "Editor and TextComposition are assigned here atomically." - e _ model editorClass new morph: self. - e model: model. - tc _ TextComposition new. - "Keep critical section short" - self mutex critical: [ - editor _ e. - textComposition _ tc. - tc - setModel: model; - extentForComposing: self extentForComposing. - e textComposition: tc. - tc editor: e ]. - e setEmphasisHereFromText. - tc composeAll. - e resetState. - self fit. - self selectionChanged. - - "Add extras. Text Styler and Autocompleter" - self stylerClass: - (Preferences syntaxHighlightingAsYouType ifTrue: [ - model textStylerClass ]). - self autoCompleterClass: - model autoCompleterClass! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4377-TextEditorFix-JuanVuletich-2020Sep14-11h19m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4377] on 24 September 2020 at 10:54:34 am'! -!TheWorldMenu class methodsFor: 'menu building' stamp: 'jmv 9/24/2020 10:53:18' prior: 50411916! - worldMenuOptions - - ^`{{ - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Open...'. - #selector -> #openOpenMenu. - #icon -> #openIcon. - #balloonText -> 'Submenu to open various system tools'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'New morph...'. - #selector -> #newMorph. - #icon -> #morphsIcon. - #balloonText -> 'Offers a variety of ways to create new objects'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Preferences...'. - #selector -> #openPreferencesMenu. - #icon -> #preferencesIcon. - #balloonText -> 'Opens a menu offering many controls over appearance and system preferences.'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'Windows...'. - #selector -> #openWindowsMenu. - #icon -> #windowIcon. - #balloonText -> 'Manage open windows'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 50. - #label -> 'Help...'. - #selector -> #openHelpMenu. - #icon -> #helpIcon. - #balloonText -> 'Opens a menu of useful items for updating the system, determining what version you are running, and much else'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Changes...'. - #selector -> #openChangesMenu. - #icon -> #changesIcon. - #balloonText -> 'Opens a menu of useful tools for dealing with changes'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Debug...'. - #selector -> #openDebugMenu. - #icon -> #debugIcon. - #balloonText -> 'a menu of debugging items'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'Restore Display (r)'. - #object -> #myWorld. - #selector -> #restoreDisplay. - #icon -> #displayIcon. - #balloonText -> 'Repaint the screen -- useful for removing unwanted display artifacts, lingering cursors, etc.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Save'. - #object -> Smalltalk. - #selector -> #saveSession. - #icon -> #saveIcon. - #balloonText -> 'Save the current version of the image on disk'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Save as...'. - #object -> Smalltalk. - #selector -> #saveAs. - #icon -> #saveAsIcon. - #balloonText -> 'Save the current version of the image on disk under a new name.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'Save new Cuis Release'. - #object -> Smalltalk. - #selector -> #saveAsNewVersion. - #icon -> #saveAsNewVersionIcon. - #balloonText -> ('Save as a new release of Cuis.\Use an updated version-stamped name\and save it under that name on disk.\', - 'Clear all user preferences and user state (class vars).') withNewLines. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 40. - #label -> 'Save and Quit'. - #selector -> #saveAndQuit. - #icon -> #saveAndQuitIcon. - #balloonText -> 'Save the image and quit out of Cuis.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 50. - #label -> 'Quit'. - #selector -> #quitSession. - #icon -> #quitIcon. - #balloonText -> 'Quit out of Cuis.'. - } asDictionary. -}`! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4378-BetterWordingOfSaveAsNewVersion-JuanVuletich-2020Sep24-10h44m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4365] on 23 September 2020 at 7:26:03 pm'! -!StringRequestMorph class methodsFor: 'instance creation' stamp: 'HAW 9/23/2020 18:49:48'! - defaultInitialAnswer - - ^''! ! -!StringRequestMorph class methodsFor: 'instance creation' stamp: 'HAW 9/23/2020 18:49:25'! - request: queryString orCancel: cancelBlock - - ^self request: queryString initialAnswer: self defaultInitialAnswer orCancel: cancelBlock ! ! -!StringRequestMorph class methodsFor: 'instance creation' stamp: 'HAW 9/23/2020 18:47:29' prior: 50513875 overrides: 50513613! - request: queryString initialAnswer: defaultAnswer do: acceptBlock - - ^ self - request: queryString - centeredAt: self runningWorld activeHand morphPosition - initialAnswer: defaultAnswer - validationBlock: [:aString| true] - acceptBlock: acceptBlock - cancelBlock: []! ! -!StringRequestMorph class methodsFor: 'instance creation' stamp: 'HAW 9/23/2020 18:47:57' prior: 50513887 overrides: 50515282! - request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock - - | morph world | - - morph _ self new - setQuery: queryString - initialAnswer: defaultAnswer. - (world _ self runningWorld) addMorph: morph centeredNear: world activeHand morphPosition - self deltaToTextPane. - - ^ morph getUserResponseOrCancel: cancelBlock! ! -!StringRequestMorph class methodsFor: 'instance creation' stamp: 'HAW 9/23/2020 18:48:44' prior: 50513901 overrides: 50515295! - request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock - - ^ self - request: queryString - centeredAt: self runningWorld activeHand morphPosition - initialAnswer: defaultAnswer - validationBlock: validationBlock - acceptBlock: acceptBlock - cancelBlock: cancelBlock! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4379-requestOrCancel-HernanWilkinson-2020Sep23-18h39m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4379] on 24 September 2020 at 11:22:55 am'! -!MenuMorph methodsFor: 'accessing' stamp: 'KLG 9/22/2020 20:59:54' overrides: 16876446! - label - "Answer a nice label. - - Pinned menus in the taskbar are easier to identify on big screens." - - titleMorph ifNil: [ ^ super label ]. - titleMorph submorphsDo: [ :stringMorph | - "Be careful" - [ ^ stringMorph contents ] onDNU: #contents do: [] ]. - ^ super label ":] One never knows"! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4380-MenuMorph-label-GeraldKlix-2020Sep24-11h19m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4373] on 18 September 2020 at 1:40:56 pm'! -!ProtocolBrowser methodsFor: 'class list' stamp: 'KenD 9/18/2020 13:21:11' overrides: 16869956! - selectedClass - "Answer the class that is currently selected. - Answer base if no selection exists." - | className | - className := (self selectiveClassListIndex = 0) - ifTrue: [self selectiveClassList last] - ifFalse: [self selectiveClassList at: self selectiveClassListIndex]. - ^ Smalltalk at: ((className findTokens: ' ') first asSymbol)! ! -!ProtocolBrowser methodsFor: 'class list' stamp: 'KenD 9/18/2020 12:40:47' overrides: 16869966! - selectedClassOrMetaClass - "I ignore metaClass, so.." - ^ self selectedClass! ! -!ProtocolBrowserWindow methodsFor: 'menu building' stamp: 'KenD 9/18/2020 12:37:51'! - protocolClassListMenu - "Fill aMenu with items appropriate for the class list" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Class List'. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - - }`. - ^ aMenu! ! -!ProtocolBrowserWindow methodsFor: 'keyboard shortcuts' stamp: 'KenD 9/18/2020 13:39:04'! - protocolClassListKey: aChar from: view - "Respond to a Command key. I am a model with a list of - classes and a list of methods. The - view knows how to get the list and selection." - - aChar == $b ifTrue: [^ self browseMethodFull ]. - aChar == $h ifTrue: [^ self browseHierarchy]. - - ^ nil! ! -!ProtocolBrowserWindow methodsFor: 'GUI building' stamp: 'KenD 9/18/2020 13:37:59' prior: 50374691! - buildSelectiveClassList - "Define the class hierarchy list pane" - - ^PluggableListMorph - model: model - listGetter: #selectiveClassList - indexGetter: #selectiveClassListIndex - indexSetter: #selectiveClassListIndex: - mainView: self - menuGetter: #protocolClassListMenu - keystrokeAction: #protocolClassListKey:from: ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4381-ProtocolClassMenu-KenDickey-2020Aug28-11h56m-KenD.002.cs.st----! - -'From Cuis 5.0 [latest update: #4381] on 24 September 2020 at 3:51:28 pm'! -!Dictionary methodsFor: 'printing' stamp: 'jmv 9/24/2020 15:49:52' prior: 16833727 overrides: 16814619! - storeOn: aStream - | noneYet | - aStream nextPutAll: '(('. - aStream nextPutAll: self class name. - aStream nextPutAll: ' new)'. - noneYet _ true. - self keysSortedSafely do: [ :key | - noneYet - ifTrue: [noneYet _ false] - ifFalse: [aStream nextPut: $;]. - aStream nextPutAll: ' add: '. - aStream store: (self associationAt: key)]. - noneYet ifFalse: [aStream nextPutAll: '; yourself']. - aStream nextPut: $)! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4382-Dictionary-deterministic-storeOn-ifPossible-JuanVuletich-2020Sep24-15h49m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4382] on 24 September 2020 at 8:08:04 pm'! -!Categorizer methodsFor: 'accessing' stamp: 'HAW 9/24/2020 19:59:20' prior: 50493611! - addCategory: catString before: nextCategory - "Add a new category named heading. - If default category exists and is empty, remove it. - If nextCategory is nil, then add the new one at the end, - otherwise, insert it before nextCategory." - - | index newCategory | - - newCategory _ catString withBlanksTrimmed. - - "heading already exists, so done" - (categoryArray indexOf: newCategory) > 0 ifTrue: [^self]. - - index _ categoryArray indexOf: nextCategory ifAbsent: [categoryArray size + 1]. - categoryArray _ categoryArray - copyReplaceFrom: index - to: index-1 - with: (Array with: newCategory). - categoryStops _ categoryStops - copyReplaceFrom: index - to: index-1 - with: (Array with: (index = 1 - ifTrue: [0] - ifFalse: [categoryStops at: index-1])). - - "remove empty default category" - (newCategory ~= Default and: [(self listAtCategoryNamed: Default) isEmpty]) - ifTrue: [self removeCategory: Default]! ! -!Categorizer methodsFor: 'accessing' stamp: 'HAW 9/24/2020 20:02:50' prior: 50493642! - classify: element under: heading suppressIfDefault: aBoolean - "Store the argument, element, in the category named heading. If aBoolean is true, then invoke special logic such that the classification is NOT done if the new heading is the Default and the element already had a non-Default classification -- useful for filein" - - | catName catIndex elemIndex realHeading | - - ((heading = NullCategory) or: [heading == nil]) - ifTrue: [realHeading _ Default] - ifFalse: [realHeading _ heading withBlanksTrimmed ]. - - "done if already under that category" - (catName _ self categoryOfElement: element) = realHeading ifTrue: [^ self]. - - catName ifNotNil: [ - "return if non-Default category already assigned in memory" - (aBoolean and: [realHeading = Default]) ifTrue: [^ self]. - "remove if in another category" - self removeElement: element]. - - (categoryArray indexOf: realHeading) = 0 ifTrue: [self addCategory: realHeading]. - - catIndex _ categoryArray indexOf: realHeading. - elemIndex _ catIndex > 1 - ifTrue: [categoryStops at: catIndex - 1] - ifFalse: [0]. - [(elemIndex _ elemIndex + 1) <= (categoryStops at: catIndex) - and: [element >= (elementArray at: elemIndex)]] whileTrue. - - "elemIndex is now the index for inserting the element. Do the insertion before it." - elementArray _ elementArray copyReplaceFrom: elemIndex to: elemIndex-1 with: (Array with: element). - - "add one to stops for this and later categories" - catIndex to: categoryArray size do: - [:i | categoryStops at: i put: (categoryStops at: i) + 1]. - - (self listAtCategoryNamed: Default) size = 0 ifTrue: [self removeCategory: Default]! ! -!Categorizer methodsFor: 'accessing' stamp: 'HAW 9/24/2020 20:04:28' prior: 16795704! - renameCategory: oldCatString toBe: newCatString - "Rename a category. No action if new name already exists, or if old name does not exist." - - | index newCategory | - - newCategory _ newCatString withBlanksTrimmed. - "new name exists, so no action" - (categoryArray indexOf: newCategory) > 0 ifTrue: [^ self]. - - "old name not found, so no action" - (index _ categoryArray indexOf: oldCatString) = 0 ifTrue: [^ self]. - - "need to change identity so smart list update will notice the change" - categoryArray _ categoryArray copy. - categoryArray at: index put: newCategory! ! -!ClassOrganizer methodsFor: 'accessing' stamp: 'HAW 9/24/2020 20:05:51' prior: 16807592 overrides: 50544797! - renameCategory: oldCatString toBe: newCatString - - | newCategory oldElementsBefore oldElementsAfter | - - newCategory _ newCatString withBlanksTrimmed. - oldElementsBefore _ self listAtCategoryNamed: oldCatString. - SystemChangeNotifier uniqueInstance doSilently: [ - super renameCategory: oldCatString toBe: newCatString]. - - oldElementsAfter _ (self listAtCategoryNamed: oldCatString) asSet. - oldElementsBefore do: [:each | (oldElementsAfter includes: each) - ifFalse: [self notifyOfChangedSelector: each from: oldCatString to: newCategory]]. - - self notifyOfChangedCategoryFrom: oldCatString to: newCategory.! ! -!ClassBuilder methodsFor: 'class definition' stamp: 'HAW 9/24/2020 16:24:14' prior: 50430805! - name: className subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category unsafe: unsafe - "Define a new class. - If unsafe is true do not run any validation checks. - This facility is provided to implement important system changes." - - | oldClass newClass organization instVars classVars force needNew oldCategory copyOfOldClass newCategory | - - instVars _ Scanner new scanFieldNames: instVarString. - classVars _ (Scanner new scanFieldNames: classVarString) collect: [:x | x asSymbol]. - - "Validate the proposed name" - unsafe ifFalse:[(self validateClassName: className) ifFalse:[^nil]]. - oldClass _ Smalltalk at: className ifAbsent: nil. - oldClass isBehavior - ifFalse:[oldClass _ nil]. "Already checked in #validateClassName:" - copyOfOldClass _ oldClass copy. - - unsafe ifFalse:[ - "Run validation checks so we know that we have a good chance for recompilation" - (self validateSuperclass: newSuper forSubclass: oldClass) ifFalse:[^nil]. - (self validateInstvars: instVars from: oldClass forSuper: newSuper) ifFalse:[^nil]. - (self validateClassvars: classVars from: oldClass forSuper: newSuper) ifFalse:[^nil]. - (self validateSubclassFormat: type from: oldClass forSuper: newSuper extra: instVars size) ifFalse:[^nil]]. - - "See if we need a new subclass" - needNew _ self needsSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass. - needNew ifNil: [^nil]. "some error" - - (needNew and:[unsafe not]) ifTrue:[ - "Make sure we don't redefine any dangerous classes" - (self tooDangerousClasses includes: oldClass name) ifTrue:[ - self error: oldClass name, ' cannot be changed'. - ]. - "Check if the receiver should not be redefined" - (oldClass notNil and:[oldClass shouldNotBeRedefined]) ifTrue:[ - self notify: oldClass name asText allBold, - ' should not be redefined!! \Proceed to store over it.' withNewLines]]. - - needNew ifTrue:[ - "Create the new class" - newClass _ self - newSubclassOf: newSuper - type: type - instanceVariables: instVars - from: oldClass. - newClass ifNil: [ ^nil]. "Some error" - newClass setName: className. - ] ifFalse:[ - "Reuse the old class" - newClass _ oldClass. - ]. - - "Install the class variables and pool dictionaries... " - force _ (newClass declare: classVarString) | (newClass sharing: poolString). - - "... classify ..." - newCategory _ category withBlanksTrimmed. - organization _ Smalltalk organization. - oldClass ifNotNil: [oldCategory := (organization categoryOfElement: oldClass name) asSymbol]. - organization classify: newClass name under: newCategory. - - "... recompile ..." - newClass _ self recompile: force from: oldClass to: newClass mutate: false. - - "... export if not yet done ..." - (Smalltalk at: newClass name ifAbsent: nil) == newClass ifFalse:[ - [Smalltalk at: newClass name put: newClass] - on: AttemptToWriteReadOnlyGlobal do:[:ex| ex resume: true]. - Smalltalk flushClassNameCache. - ]. - - self doneCompiling: newClass. - - "... notify interested clients ..." - oldClass ifNil: [ - SystemChangeNotifier uniqueInstance classAdded: newClass inCategory: newCategory. - ^ newClass]. - SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass. - newCategory ~= oldCategory - ifTrue: [SystemChangeNotifier uniqueInstance classRecategorized: newClass from: oldCategory to: newCategory ]. - ^newClass! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4383-CategoriesWithoutBlanks-HernanWilkinson-2020Sep24-16h22m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4382] on 27 September 2020 at 10:30:51 pm'! - -"Change Set: 4383-CuisCore-AuthorName-2020Sep27-22h11m -Date: 27 September 2020 -Author: Nahuel Garbezza - -Add missing visitor protocol (temporaries declaration) for ParseNodeEnumerator"! -!ParseNodeEnumerator methodsFor: 'visiting' stamp: 'RNG 9/27/2020 22:25:46' overrides: 50502563! - visitTemporariesDeclarationNode: aTemporariesDeclarationNode - - (theSelectBlock isNil or: [theSelectBlock value: aTemporariesDeclarationNode]) ifFalse: - [^nil]. - theBlock value: aTemporariesDeclarationNode. - ^ super visitTemporariesDeclarationNode: aTemporariesDeclarationNode! ! -!ParseNodeEnumerator methodsFor: 'visiting' stamp: 'RNG 9/27/2020 22:28:33' overrides: 50502572! - visitTemporaryDeclarationNode: aTemporaryDeclarationNode - - (theSelectBlock isNil or: [theSelectBlock value: aTemporaryDeclarationNode]) ifFalse: - [^nil]. - theBlock value: aTemporaryDeclarationNode. - ^ super visitTemporaryDeclarationNode: aTemporaryDeclarationNode! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4384-ParseNodeEnumerator-NahuelGarbezza-2020Sep27-22h11m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4384] on 29 September 2020 at 10:52:57 am'! -!SmartRefStream methodsFor: 'read write' stamp: 'jmv 9/29/2020 10:52:42' overrides: 16827608! - readWordLike - | refPosn className newName newClass anObject | - "Can be used by any class that is bits and not bytes (WordArray, Bitmap, SoundBuffer, etc)." - - refPosn _ self getCurrentReference. - className _ self next asSymbol. - newName _ renamed at: className ifAbsent: [className]. - newClass _ Smalltalk at: newName. - anObject _ newClass newFromStream: byteStream. - "Size is number of long words." - self setCurrentReference: refPosn. "before returning to next" - ^ anObject -! ! -!SmartRefStream methodsFor: 'read write' stamp: 'jmv 9/29/2020 10:39:04' prior: 16911003! - initKnownRenames - "Stuff like" - " - renamed - at: #FlasherMorph put: #Flasher; - yourself - " - renamed - at: #FloatArray put: #Float32Array; - yourself! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4385-SmartRefStream-FloatArray-Float32Array-JuanVuletich-2020Sep29-10h39m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4382] on 28 September 2020 at 11:22:59 am'! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 9/28/2020 11:03:19'! - morphContainsPoint: aLocalPoint - "Not very good. False positives for non-rectangular morphs. - Only useful as a backstop if the Canvas can't do better." - - ^ self morphLocalBounds containsPoint: aLocalPoint! ! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'jmv 9/28/2020 11:19:35' overrides: 50384217! - morphTopLeft - "Our hierarchy occupies a rectangle specified by #morphTopLef and #morphExtent" - ^`0@0`! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 9/28/2020 10:57:58' prior: 50503281! - morphPositionInWorld - - self flag: #jmvVer2. - "Most likely we don't want to use global coordinates... - In fact, we could be in many frames of reference at the same time... - This method makes no sense at all!!" - - ^self externalizeToWorld: `0@0`! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 9/28/2020 11:20:07' prior: 50384217! - morphTopLeft - "By default, morphs occupy a rectangle specified by #morphExtent" - ^self morphExtent // 2 negated! ! - -Morph removeSelector: #morphBounds! - -!methodRemoval: Morph #morphBounds stamp: 'Install-4386-Morph-topLeftMightNotBeOrigin-JuanVuletich-2020Sep28-10h33m-jmv.001.cs.st 10/15/2020 19:33:01'! -morphBounds - ^ self morphPosition extent: self morphExtent! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4386-Morph-topLeftMightNotBeOrigin-JuanVuletich-2020Sep28-10h33m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4384] on 28 September 2020 at 12:05:40 pm'! -!StepMessage methodsFor: 'evaluating' stamp: 'jmv 9/28/2020 12:05:32' prior: 50340401 overrides: 16877275! - valueAtTime: millisecondClock - - | nArgs millisecondsSinceLast answer | - numArgs ifNil: [numArgs _ selector numArgs]. - nArgs _ arguments ifNil: [0] ifNotNil: [arguments size]. - lastEvaluationTime ifNil: [ lastEvaluationTime _ millisecondClock ]. - millisecondsSinceLast _ millisecondClock - lastEvaluationTime. - lastEvaluationTime _ millisecondClock. - nArgs = numArgs ifTrue: [ - "Ignore extra argument" - ^self value ]. - [ - arguments - ifNil: [ answer _ receiver perform: selector with: millisecondsSinceLast] - ifNotNil: [ answer _ receiver perform: selector withArguments: (arguments copyWith: millisecondsSinceLast) ] - ] ifError: [ :err :rcvr | - receiver stopStepping. - { 'Error while stepping: '. self. rcvr. err } print. - "Install the old error handler, so we can re-raise the error" - rcvr error: err. - ]. - ^answer! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4387-stepping-ErrorHandling-JuanVuletich-2020Sep28-12h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4388] on 29 September 2020 at 11:08:32 am'! -!HaloMorph methodsFor: 'private' stamp: 'jmv 9/29/2020 11:08:03' prior: 50537048! - doRot: evt with: rotHandle - "Update the rotation of my target if it is rotatable. Keep the relevant command object up to date." - - | radians scale | -self revisar. - self flag: #jmvVer2. - evt hand obtainHalo: self. - radians _ (evt eventPosition - target referencePosition) theta. - radians _ radians - angleOffset theta. - "degrees _ degrees detentBy: 10.0 atMultiplesOf: 90.0 snap: false." - radians = 0.0 - ifTrue: [rotHandle color: `Color lightBlue`] - ifFalse: [rotHandle color: `Color blue`]. - rotHandle submorphsDo: - [:m | m color: rotHandle color makeForegroundColor]. - scale _ (evt eventPosition - target referencePosition) rho * scaleOffset. - self removeAllHandlesBut: rotHandle. - target rotation: radians scale: "scale" 1. "Please use another handle for scale!!" - rotHandle morphPositionInWorld: evt eventPosition - (rotHandle morphExtent // 2)! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4388-RotateHandle-doNotScales-JuanVuletich-2020Sep29-11h08m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4388] on 28 September 2020 at 3:59:52 pm'! -!BitBltCanvas methodsFor: 'drawing' stamp: 'jmv 9/28/2020 15:57:04' prior: 50532704 overrides: 50463409! - line: pt1 to: pt2 width: wp color: c - | p1 p2 w | - - engine ifNil: [ ^nil ]. - - (wp > 0 and: [ c isTransparent not ]) ifTrue: [ - p1 _ (currentTransformation transform: pt1) rounded. - p2 _ (currentTransformation transform: pt2) rounded. - w _ (currentTransformation externalizeScalar: wp) rounded. - self setPaintColor: c. - engine - width: w; - height: w; - drawFrom: p1 to: p2 ]! ! -!BitBltCanvas methodsFor: 'drawing-ovals' stamp: 'jmv 9/28/2020 15:58:00' prior: 50532792 overrides: 50463445! - ellipseCenterX: mcx y: mcy rx: mrx ry: mry borderWidth: mbw borderColor: mbc fillColor: morphFillColor - - | displayRectangle doBorder doFill | - - engine ifNil: [ ^nil ]. - - doBorder _ mbw > 0 and: [ mbc isTransparent not]. - doFill _ morphFillColor isTransparent not. - doBorder | doFill ifTrue: [ - displayRectangle _ (currentTransformation externalizeRectangle: (Rectangle center: mcx@mcy extent: mrx@mry * 2)) rounded. - "draw the border of the oval" - doBorder ifTrue: [ - self setPaintColor: mbc. - engine frameOval: displayRectangle borderWidth: mbw rounded]. - "fill the inside" - doFill ifTrue: [ - self setPaintColor: morphFillColor. - engine fillOval: (displayRectangle insetBy: mbw rounded) ]]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 9/28/2020 15:58:21' prior: 50532873 overrides: 50463471! - frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor - | rect bw | - - - engine ifNil: [ ^nil ]. - - r area = 0 ifTrue: [ ^self ]. - rect _ (currentTransformation externalizeRectangle: r) rounded. - bw _ (currentTransformation externalizeScalar: borderWidth) rounded. - - "draw the border of the rectangle" - borderColor isTransparent ifFalse: [ - self setPaintColor: borderColor. - engine frameRect: rect borderWidth: bw ]. - - "fill the inside" - fillColor isTransparent ifFalse: [ - self setPaintColor: fillColor. - engine fillRect: (rect insetBy: bw) ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 9/28/2020 15:58:33' prior: 50532895 overrides: 50463478! - frameRectangle: r borderWidth: borderWidth color: borderColor - " - Display getCanvas - frameRectangle: (10@10 extent: 300@200) - borderWidth: 20 - color: Color red. - Display forceToScreen - " - | rect bw | - - engine ifNil: [ ^nil ]. - - (borderWidth > 0 and: [ borderColor isTransparent not ]) ifTrue: [ - rect _ (currentTransformation externalizeRectangle: r) rounded. - bw _ (currentTransformation externalizeScalar: borderWidth) rounded. - self setPaintColor: borderColor. - engine - frameRect: rect - borderWidth: bw ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4389-BitBltCanvas-roundLineWidth-JuanVuletich-2020Sep28-14h36m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4389] on 28 September 2020 at 4:33:47 pm'! -!HaloMorph methodsFor: 'private' stamp: 'jmv 9/28/2020 16:32:38' prior: 16850976! - doDrag: evt with: dragHandle - | thePoint | - evt hand obtainHalo: self. - thePoint _ evt eventPosition - positionOffset. - target morphPositionInWorld: thePoint. - self morphPositionInWorld: thePoint + target morphTopLeft! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4390-HaloMorph-fix-JuanVuletich-2020Sep28-16h20m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4391] on 4 October 2020 at 8:20:56 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/4/2020 20:20:33'! - rotation: radians - "Change the rotation of this morph. Argument is an angle to be taken as the new rotation." - - self rotation: radians scale: 1.! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/4/2020 20:20:39' prior: 50535323! - rotateBy: radians - "Change the rotation of this morph. Argument is an angle (possibly negative), to be added to current rotation." - - location _ location rotatedBy: radians. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4391-Morph-rotation-JuanVuletich-2020Oct04-20h19m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4360] on 5 October 2020 at 10:52:58 am'! -!SystemDictionary methodsFor: 'system attributes' stamp: 'jmv 10/5/2020 10:52:42' prior: 16925057! - maxIdentityHash - "Answer the maximum identityHash value supported by the VM. - Usually the VM is able to answer. It seems that SqueakJS (as of October 5, 2020) isn't. - On primitive failure, still give a correct answer." - - - ^self isSpur - ifTrue: [ 16r3FFFFF ] "22 bits in Spur" - ifFalse: [ 16rFFF ] "12 bits in V3 images"! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4392-MakeCuisRunAgainOnSqueakJSvm-JuanVuletich-2020Oct05-10h52m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4384] on 4 October 2020 at 6:54:26 pm'! -!SHTextStylerST80 class methodsFor: 'preferences' stamp: 'HAW 10/4/2020 18:53:16'! - initializeSyntaxHighlightingAsYouType - - (Preferences preferenceAt: #syntaxHighlightingAsYouType) ifNil:[ - Preferences - disable: #browseWithPrettyPrint. - Preferences - addPreference: #syntaxHighlightingAsYouType - categories: #(browsing) - default: true - balloonHelp: 'Enable, or disable, Shout - Syntax Highlighting As You Type. When enabled, code in Browsers and Workspaces is styled to reveal its syntactic structure. When the code is changed (by typing some characters, for example), the styling is changed so that it remains in sync with the modified code']! ! -!SHTextStylerST80 class methodsFor: 'preferences' stamp: 'HAW 10/4/2020 18:53:26'! - initializeSyntaxHighlightingAsYouTypeAnsiAssignment - - (Preferences preferenceAt: #syntaxHighlightingAsYouTypeAnsiAssignment) ifNil:[ - Preferences - addPreference: #syntaxHighlightingAsYouTypeAnsiAssignment - categories: #(browsing) - default: false - balloonHelp: 'If true, and syntaxHighlightingAsYouType is enabled, all left arrow assignments ( _ ) will be converted to the ANSI format ( := ) when a method is selected in a Browser. Whilst editing a method, this setting has no effect - both the left arrow and the ansi format may be used'. - - (Preferences preferenceAt: #syntaxHighlightingAsYouTypeAnsiAssignment) - changeInformee: self - changeSelector: #ansiAssignmentPreferenceChanged]! ! -!SHTextStylerST80 class methodsFor: 'preferences' stamp: 'HAW 10/4/2020 18:53:30'! - initializeSyntaxHighlightingAsYouTypeLeftArrowAssignment - - ^ (Preferences preferenceAt: #syntaxHighlightingAsYouTypeLeftArrowAssignment) ifNil:[ - Preferences - addPreference: #syntaxHighlightingAsYouTypeLeftArrowAssignment - categories: #(browsing) - default: false - balloonHelp: 'If true, and syntaxHighlightingAsYouType is enabled, all ANSI format assignments ( := ) will be converted to left arrows ( _ ) when a method is selected in a Browser. Whilst editing a method, this setting has no effect - both the left arrow and the ansi format may be used'. - - (Preferences preferenceAt: #syntaxHighlightingAsYouTypeLeftArrowAssignment) - changeInformee: self - changeSelector: #leftArrowAssignmentPreferenceChanged ]! ! -!SHTextStylerST80 class methodsFor: 'preferences' stamp: 'HAW 10/4/2020 18:51:43' prior: 16903434! - initializePreferences - - self - initializeSyntaxHighlightingAsYouType; - initializeSyntaxHighlightingAsYouTypeAnsiAssignment; - initializeSyntaxHighlightingAsYouTypeLeftArrowAssignment.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4393-StylerPreferenceInitialization-HernanWilkinson-2020Oct04-18h50m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4384] on 5 October 2020 at 12:24:21 pm'! - -Object subclass: #SHST80RangeType - instanceVariableNames: 'sourceCode messageRange receiverRange messageRangeType receiverRangeType classOrMetaClass' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -!classDefinition: #SHST80RangeType category: #'Tools-Syntax Highlighting' stamp: 'Install-4394-SyntaxHighlightImprovement-HernanWilkinson-2020Oct04-18h54m-HAW.002.cs.st 10/15/2020 19:33:01'! -Object subclass: #SHST80RangeType - instanceVariableNames: 'sourceCode messageRange receiverRange messageRangeType receiverRangeType classOrMetaClass' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -SHST80RangeType class - instanceVariableNames: ''! - -!classDefinition: 'SHST80RangeType class' category: #'Tools-Syntax Highlighting' stamp: 'Install-4394-SyntaxHighlightImprovement-HernanWilkinson-2020Oct04-18h54m-HAW.002.cs.st 10/15/2020 19:33:01'! -SHST80RangeType class - instanceVariableNames: ''! -!Class methodsFor: 'class variables' stamp: 'HAW 10/5/2020 08:09:51'! - classVarBindingOf: varNameSymbol - - ^self classPool bindingOf: varNameSymbol! ! -!Class methodsFor: 'class variables' stamp: 'HAW 10/5/2020 08:09:57'! - classVarValueOf: varNameSymbol - - ^(self classPool bindingOf: varNameSymbol) ifNotNil: [:binding | binding value ]! ! -!SHRange methodsFor: 'printing' stamp: 'HAW 10/4/2020 19:12:52' overrides: 50508082! - printOn: aStream - - aStream - nextPutAll: type; - space; - nextPut: $(; - print: start; - nextPutAll: ' to: '; - print: end; - nextPut: $)! ! -!SHST80RangeType methodsFor: 'initialize' stamp: 'HAW 10/5/2020 09:19:59'! - initializeFor: aSourceCode in: aClassOrMetaclass - - sourceCode := aSourceCode. - classOrMetaClass := aClassOrMetaclass ! ! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'HAW 10/5/2020 08:36:53'! - doesReceiverRespondsToMessageIn: aReceiver - - ^aReceiver respondsTo: self messageName! ! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'HAW 10/5/2020 09:22:07'! - messageName - - ^ (self sourceCodeIn: messageRange) asSymbol! ! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'HAW 10/5/2020 08:35:06'! - messageUndefinedType - - messageRangeType = #unary ifTrue: [ ^#undefinedUnary ]. - messageRangeType = #binary ifTrue: [ ^#undefinedBinary ]. - - ^#invalid - ! ! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'HAW 10/5/2020 09:22:07'! - receiverAsNumber - - ^ (self sourceCodeIn: receiverRange) asNumber! ! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'HAW 10/5/2020 09:22:07'! - receiverAsSymbol - - ^ (self sourceCodeIn: receiverRange) asSymbol! ! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'HAW 10/5/2020 09:22:07'! - sourceCodeIn: aRange - - ^ sourceCode copyFrom: aRange start to: aRange end! ! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'HAW 10/5/2020 09:55:09'! - typeWhenSendTo: receiver - - ^(self doesReceiverRespondsToMessageIn: receiver) - ifTrue: [ messageRangeType ] - ifFalse: [ self messageUndefinedType ] - - -! ! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'HAW 10/5/2020 09:55:09'! - typeWhenSendToClassVar - - | classVarValue | - - ^ classOrMetaClass - ifNil: [ messageRangeType ] - ifNotNil: [ - classVarValue := classOrMetaClass theNonMetaClass classVarValueOf: (self sourceCodeIn: receiverRange). - self typeWhenSendTo: classVarValue ]! ! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'HAW 10/5/2020 09:55:09'! - typeWhenSendToGlobal - - ^ Smalltalk - at: self receiverAsSymbol - ifPresent: [ :globalValue | self typeWhenSendTo: globalValue ] - ifAbsent: [ messageRangeType ]! ! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'HAW 10/5/2020 09:53:59'! - typeWhenSendToInstanceOf: aClass - - ^ (aClass canUnderstand: self messageName) - ifTrue: [ messageRangeType ] - ifFalse: [ self messageUndefinedType ]! ! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'HAW 10/5/2020 09:55:09'! - typeWhenSendToNumber - - ^self typeWhenSendTo: self receiverAsNumber - ! ! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'HAW 10/5/2020 09:54:17'! - typeWhenSendToSelf - - ^ classOrMetaClass - ifNil: [ messageRangeType ] - ifNotNil: [ self typeWhenSendToInstanceOf: classOrMetaClass ]! ! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'HAW 10/5/2020 09:54:28'! - typeWhenSendToSuper - - ^ classOrMetaClass - ifNil: [ messageRangeType ] - ifNotNil: [ - classOrMetaClass theNonMetaClass superclass isNil - ifTrue: [ self messageUndefinedType ] - ifFalse: [ self typeWhenSendToInstanceOf: classOrMetaClass superclass]]! ! -!SHST80RangeType methodsFor: 'range type' stamp: 'HAW 10/5/2020 09:35:07'! - lastRange: aRange - - receiverRange := aRange ! ! -!SHST80RangeType methodsFor: 'range type' stamp: 'HAW 10/5/2020 09:59:50'! - ofCurrentRangeOrMessageSendIn: aPotentialMessageRange - - | potentialMessageRangeType | - - potentialMessageRangeType := aPotentialMessageRange rangeType. - - (#(unary binary) includes: potentialMessageRangeType) ifFalse: [ ^potentialMessageRangeType ]. - receiverRange ifNil: [ ^potentialMessageRangeType ]. - - messageRange := aPotentialMessageRange. - messageRangeType := potentialMessageRangeType. - receiverRangeType := receiverRange rangeType. - - receiverRangeType = #number ifTrue: [ ^self typeWhenSendToNumber ]. - receiverRangeType = #string ifTrue: [ ^self typeWhenSendToInstanceOf: String ]. - receiverRangeType = #symbol ifTrue: [ ^self typeWhenSendToInstanceOf: Symbol ]. - receiverRangeType = #arrayEnd ifTrue: [ ^self typeWhenSendToInstanceOf: Array ]. - receiverRangeType = #rightBrace ifTrue: [ ^self typeWhenSendToInstanceOf: Array ]. - receiverRangeType = #blockEnd ifTrue: [ ^self typeWhenSendToInstanceOf: BlockClosure ]. - receiverRangeType = #character ifTrue: [ ^self typeWhenSendToInstanceOf: Character ]. - receiverRangeType = #nil ifTrue: [ ^self typeWhenSendToInstanceOf: nil class ]. - receiverRangeType = #true ifTrue: [ ^self typeWhenSendToInstanceOf: true class ]. - receiverRangeType = #false ifTrue: [ ^self typeWhenSendToInstanceOf: false class ]. - receiverRangeType = #self ifTrue: [^self typeWhenSendToSelf ]. - receiverRangeType = #super ifTrue: [^self typeWhenSendToSuper ]. - receiverRangeType = #globalVar ifTrue: [^self typeWhenSendToGlobal ]. - receiverRangeType = #classVar ifTrue: [^self typeWhenSendToClassVar ]. - - ^messageRangeType ! ! -!SHST80RangeType class methodsFor: 'instance creation' stamp: 'HAW 10/5/2020 09:20:06'! - for: aSourceCode in: aClassOrMetaclass - - ^self new initializeFor: aSourceCode in: aClassOrMetaclass! ! -!SHTextStylerST80 methodsFor: 'private - show subscript' stamp: 'HAW 10/4/2020 19:23:15'! - formatAsSubscript: range - - ^ formattedText lastIndexOf: $_ startingAt: range end endingAt: range start do: [ :i | - formattedText addAttribute: ShoutTextEmphasis subscript from: i to: range end ]! ! -!SHTextStylerST80 methodsFor: 'private - show subscript' stamp: 'HAW 10/4/2020 19:22:30'! - hasToShowSubscriptOf: range - - ^ #(instVar classVar globalVar workspaceVar poolConstant - patternArg methodArg patternTempVar tempVar - blockPatternArg blockArg blockPatternTempVar blockTempVar - incompleteIdentifier undefinedIdentifier) pointsTo: range rangeType! ! -!SHTextStylerST80 methodsFor: 'private - show subscript' stamp: 'HAW 10/4/2020 19:22:08'! - showAsSubscriptIfAppropriate: range - - classOrMetaClass ifNotNil: [ - classOrMetaClass theNonMetaClass lastUnderscoreMeansSubscript ifTrue: [ - (self hasToShowSubscriptOf: range ) ifTrue: [ self formatAsSubscript: range ]]]! ! -!SHTextStylerST80 methodsFor: 'private' stamp: 'HAW 10/5/2020 10:00:44'! - applySmalltalkStylingIn: range using: st80RangeType - - | rangeType | - - rangeType := st80RangeType ofCurrentRangeOrMessageSendIn: range. - (self attributesFor: rangeType) ifNotNil: [ :attributes | - attributes do: [ :each | formattedText addAttribute: each from: range start to: range end ]]. -! ! -!SHTextStylerST80 methodsFor: 'private' stamp: 'HAW 10/5/2020 09:17:13'! - optimizeForMutationSpeed: ranges - - "Optimize for mutation speed unless method is really large but with very few distict elements: - Source code that includes just big literals is better served by conventional Text+RunArray" - "Do it only if we are not breaking textModel!! (for instance, StyledTextEditor asks for formatting just sections, not whole #actualContents)." - formattedText == textModel actualContents ifTrue: [ - (formattedText size > 2000 and: [ ranges size < 50 ]) ifFalse: [ - formattedText _ formattedText optimizedForMutationSpeed. - textModel basicActualContents: formattedText ]]. - -! ! -!Class methodsFor: 'compiling' stamp: 'HAW 10/5/2020 08:08:59' prior: 16802636 overrides: 50450045! -localBindingOf: varNameSymbol - "Answer the binding of some variable resolved in the scope of the receiver." - - "First look in classVar dictionary." - (self classVarBindingOf: varNameSymbol) ifNotNil: [ :binding | ^binding ]. - - "Next look in shared pools." - self sharedPools do: [ :pool | - (pool bindingOf: varNameSymbol) ifNotNil: [ :binding | ^binding ]. - ]. - - "Finally look higher up the superclass chain and fail at the end." - ^superclass ifNotNil: [ superclass localBindingOf: varNameSymbol ]! ! -!SHTextStylerST80 methodsFor: 'private' stamp: 'HAW 10/5/2020 09:59:08' prior: 50371045! - setAttributesFromRanges: ranges - - | st80RangeType | - - formattedText removeAttributesThat: [ :attribute | attribute isForShout ]. - self optimizeForMutationSpeed: ranges. - st80RangeType := SHST80RangeType for: formattedText string in: classOrMetaClass. - - ranges do: [ :currentRange | - self - applySmalltalkStylingIn: currentRange using: st80RangeType; - showAsSubscriptIfAppropriate: currentRange. - st80RangeType lastRange: currentRange ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4394-SyntaxHighlightImprovement-HernanWilkinson-2020Oct04-18h54m-HAW.002.cs.st----! - -'From Cuis 5.0 [latest update: #4392] on 12 October 2020 at 7:18:56 pm'! -!MenuItemMorph methodsFor: 'selecting' stamp: 'jmv 10/12/2020 19:17:55' prior: 50534543! - select - self isSelected: true. - owner activeSubmenu: subMenu. - subMenu ifNotNil: [ - self displayBounds ifNotNil: [ :r | - subMenu delete. - subMenu - popUpAdjacentTo: (Array with: r topRight + `10@0` with: r topLeft) - from: self ]. - subMenu selectItem: nil ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4395-MenuFix-JuanVuletich-2020Oct12-19h11m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4402] on 12 October 2020 at 9:31:21 pm'! -!Morph methodsFor: 'menus' stamp: 'jmv 10/12/2020 21:29:49' prior: 50393392! - addHaloActionsTo: aMenu - "Add items to aMenu representing actions requestable via halo" - - | subMenu | - subMenu := MenuMorph new defaultTarget: self. - subMenu addTitle: (self printStringLimitedTo: 40). - subMenu addStayUpIcons. - subMenu addLine. - (subMenu add: 'delete' action: #dismissViaHalo) - setBalloonText: 'Delete this object -- warning -- can be destructive!!' . - self maybeAddCollapseItemTo: subMenu. - (subMenu add: 'grab' action: #openInHand) - setBalloonText: 'Pick this object up -- warning, since this removes it from its container, it can have adverse effects.' . - subMenu addLine. - (subMenu add: 'duplicate' action: #maybeDuplicateMorph) - setBalloonText: 'Hand me a copy of this object'. - (subMenu - add: 'set color' - target: self - action: #changeColor) - setBalloonText: 'Change the color of this object'. - (subMenu - add: 'inspect' - target: self - action: #inspect) - setBalloonText: 'Open an Inspector on this object'. - aMenu add: 'halo actions...' subMenu: subMenu! ! - -Morph removeSelector: #resizeFromMenu! - -!methodRemoval: Morph #resizeFromMenu stamp: 'Install-4396-ResizeFromMenu-removal-JuanVuletich-2020Oct12-21h29m-jmv.001.cs.st 10/15/2020 19:33:01'! -resizeFromMenu - "Commence an interaction that will resize the receiver" - - self resizeMorph! - -Morph removeSelector: #resizeMorph! - -!methodRemoval: Morph #resizeMorph stamp: 'Install-4396-ResizeFromMenu-removal-JuanVuletich-2020Oct12-21h29m-jmv.001.cs.st 10/15/2020 19:33:01'! -resizeMorph - | handle | - handle _ HandleMorph new - forEachPointDo: [ :newPoint | self morphExtent: newPoint - self morphPositionInWorld]. - self runningWorld activeHand attachMorph: handle. - handle startStepping! - -Smalltalk removeClassNamed: #HandleMorph! - -!classRemoval: #HandleMorph stamp: 'Install-4396-ResizeFromMenu-removal-JuanVuletich-2020Oct12-21h29m-jmv.001.cs.st 10/15/2020 19:33:01'! -EllipseMorph subclass: #HandleMorph - instanceVariableNames: 'pointBlock' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4396-ResizeFromMenu-removal-JuanVuletich-2020Oct12-21h29m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4392] on 12 October 2020 at 8:38:23 pm'! - -SystemOrganization removeSystemCategory: 'Tools-GUI'.! - -SystemOrganization renameCategory: 'Morphic-Widgets' toBe: 'Morphic-Composite Widgets'.! - -SystemOrganization renameCategory: 'Morphic-Views' toBe: 'Morphic-Widgets'.! - -SystemOrganization renameCategory: 'Morphic-Tools' toBe: 'Morphic-Tool Windows'.! - -Morph subclass: #WidgetMorph - instanceVariableNames: 'extent color borderWidth borderColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #WidgetMorph category: 'Morphic-Widgets' stamp: 'Install-4397-WidgetMorph-JuanVuletich-2020Oct12-19h11m-jmv.003.cs.st 10/15/2020 19:33:01'! -Morph subclass: #WidgetMorph - instanceVariableNames: 'extent color borderWidth borderColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! -!WidgetMorph commentStamp: '' prior: 0! - Hierarchy for morphs that are rectangle like, and that occupy an area that can be specified as a Rectangle. This means that, besides being of rectangular shape, sides are aligned with local coordinate axes. Including rectangles with rounded corners and such. The idea is that the 'extent' ivar is all that's needed to establish our dimensions and shape. Subclasses can add things like 'roundedCornerRadious' or such.! -!WidgetMorph methodsFor: 'accessing' stamp: 'jmv 8/21/2012 16:12'! - borderColor - ^ borderColor! ! -!WidgetMorph methodsFor: 'accessing' stamp: 'jmv 8/21/2012 16:12'! - borderColor: aColor - borderColor = aColor ifFalse: [ - borderColor _ aColor. - self redrawNeeded]! ! -!WidgetMorph methodsFor: 'accessing' stamp: 'gsa 12/28/2013 15:25'! - borderWidth - ^ borderWidth! ! -!WidgetMorph methodsFor: 'accessing' stamp: 'jmv 7/30/2014 09:24'! - borderWidth: anInteger - borderWidth = anInteger ifFalse: [ - borderWidth _ anInteger max: 0. - self redrawNeeded ]! ! -!WidgetMorph methodsFor: 'accessing' stamp: 'jmv 8/21/2012 21:54' overrides: 50387666! - color - - ^ color! ! -!WidgetMorph methodsFor: 'accessing' stamp: 'jmv 8/21/2012 21:59'! - color: aColor - "Set the receiver's color. " - color = aColor ifFalse: [ - color _ aColor. - self redrawNeeded ]! ! -!WidgetMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 21:45:32'! - defaultBorderColor - "answer the default border color/fill style for the receiver" - ^ `Color gray`! ! -!WidgetMorph methodsFor: 'initialization' stamp: 'jmv 8/21/2012 16:12'! - defaultBorderWidth - "answer the default border width for the receiver" - ^ 2! ! -!WidgetMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 21:56:39'! - defaultColor - ^ `Color orange`! ! -!WidgetMorph methodsFor: 'initialization' stamp: 'jmv 10/12/2020 20:38:00' overrides: 50540396! - initialize - super initialize. - extent _ `50@40`. - color _ self defaultColor. - borderColor _ self defaultBorderColor. - borderWidth _ self defaultBorderWidth.! ! -!WidgetMorph methodsFor: 'drawing' stamp: 'jmv 12/20/2014 14:58' overrides: 50387670! - drawOn: aCanvas - "A canvas is already set with a proper transformation from our coordinates to those of the Canvas target." - "If you redefine this method in a subclass, please take a look at the comment at #isOpaqueMorph" - aCanvas - fillRectangle: self morphLocalBounds - color: color - borderWidth: borderWidth - borderStyleSymbol: #simple - baseColorForBorder: borderColor! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 7/24/2020 10:22:57'! - morphBounds: aRectangle - self morphPosition: aRectangle topLeft. - self morphExtent: aRectangle extent! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/22/2020 16:35:34' overrides: 50384199! - morphExtent - "In our own coordinates!!" - - ^ extent! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 7/23/2020 15:52:14' overrides: 16875404! - morphExtent: newExtent - "assume it is always in our coordinates!!" - - extent = newExtent ifFalse: [ - (self privateExtent: newExtent) ifTrue: [ - self someSubmorphPositionOrExtentChanged. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]]! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 7/8/2014 11:41' overrides: 16875415! - morphExtentInWorld: newExtent - "world coordinates" - self flag: #jmvVer2. - self morphExtent: (self internalizeDistanceFromWorld: newExtent)! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 9/22/2012 14:56' overrides: 16875429! - morphHeight - -"Ensure everybody wants our coordinates!!" - self flag: #jmvVer2. - ^ extent y! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/22/2020 16:36:56'! - morphHeight: aNumber - - self morphExtent: extent x@aNumber! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 7/23/2020 15:53:07'! - morphPosition: newPos extent: newExtent - "Change the position of this morph. Argument is in owner's coordinates." - - | someChange | - someChange _ false. - (location isTranslation: newPos) ifFalse: [ - location _ location withTranslation: newPos. - someChange _ true ]. - - extent = newExtent ifFalse: [ - (self privateExtent: newExtent) ifTrue: [ - someChange _ true ]]. - - someChange ifTrue: [ - self someSubmorphPositionOrExtentChanged. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 9/28/2020 11:19:35' overrides: 50545058! - morphTopLeft - "Our hierarchy occupies a rectangle specified by #morphTopLef and #morphExtent" - ^`0@0`! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 9/22/2012 14:57' overrides: 16875521! - morphWidth - -"Ensure everybody wants our coordinates!!" - self flag: #jmvVer2. - ^ extent x! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/22/2020 16:37:29'! - morphWidth: aNumber - - self morphExtent: aNumber@extent y! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 7/20/2014 09:59'! - privateExtent: aPoint - "Answer whether extent was actually changed. - If some subclass may reject the update, answer false in those cases." - - | newExtent | - newExtent _ aPoint max: self minimumExtent. - ^extent = newExtent - ifFalse: [ extent _ newExtent ]; not! ! -!WidgetMorph methodsFor: 'geometry testing' stamp: 'jmv 7/18/2020 21:35:50' overrides: 50532207! - isOrthoRectangularMorph - "True if we are of rectangular shape, aligned with local coordinate axes. - Doesn't take into account possible rotation of our or some owner's local coordinates. - Note: SystemWindow answers true, but implements #addPossiblyUncoveredAreasIn:to: to take care of rounded corners." - - ^true! ! -!WidgetMorph methodsFor: 'geometry testing' stamp: 'jmv 7/28/2020 12:16:53' overrides: 50545031! - morphContainsPoint: aLocalPoint - "Answer true even if aLocalPoint is in a submorph, as long as it is in our shape" - - "If not visible, won't contain any point at all." - self visible ifFalse: [ ^false ]. - - "Most morphs answer true to to #isOrthoRectangularMorph, or redefine this method..." - self isOrthoRectangularMorph ifTrue: [ - ^ self morphLocalBounds containsPoint: aLocalPoint ]. - - "...But for those who not, provide correct albeit expensive behavior." - "Can't do better. Please redefine in subclasses as appropriate!! (or finish Morphic 3!!)" - "Mhhh. Podria usar el #imageForm: y ver si es transparente... deberia andar" - ^ self morphLocalBounds containsPoint: aLocalPoint! ! -!WidgetMorph methodsFor: 'geometry testing' stamp: 'jmv 7/18/2020 21:35:08' overrides: 50532139! - requiresVectorCanvas - "True if we use VectorCanvas protocol, or we are rotated or zoomed. - If false, we occupy a Rectangle in local coordinates. Allows for many optimizations to be done. - Note: If answer is false, but some owner requiresVectorCanvas, then we also do. Canvas takes care of this. - Note: SystemWindow answers false, but implements #addPossiblyUncoveredAreasIn:to: to take care of rounded corners." - - ^location isPureTranslation not! ! -!WidgetMorph methodsFor: 'geometry testing' stamp: 'jmv 7/18/2020 21:38:44' overrides: 50532155! - submorphsMightProtrude - "Answered false by morphs that can guarantee that submorphs, and all morphs in their submorphs tree, will lie inside their bounds, - either 'naturally' (by construction) or by being clipped by their owner (#clipsLastSubmorph). Allows for many optimizations to be done." - - ^false! ! -!WidgetMorph methodsFor: 'layout-properties' stamp: 'jmv 2/16/2016 13:05' overrides: 16876070! - layoutSpec: aLayoutSpec - "Layout specific. Set the layout spec describing where the receiver should appear in a proportional layout" - self layoutSpec == aLayoutSpec ifTrue: [ ^self ]. - aLayoutSpec morph: self. - layoutSpec := aLayoutSpec. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]! ! -!WidgetMorph methodsFor: 'testing' stamp: 'jmv 3/17/2013 22:54' overrides: 16876981! - is: aSymbol - ^ aSymbol == #WidgetMorph or: [ super is: aSymbol ]! ! -!WidgetMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:47:05'! - categoryInNewMorphMenu - ^ 'Kernel'! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4397-WidgetMorph-JuanVuletich-2020Oct12-19h11m-jmv.003.cs.st----! - -'From Cuis 5.0 [latest update: #4392] on 12 October 2020 at 8:42:06 pm'! - -WidgetMorph subclass: #PluggableMorph - instanceVariableNames: 'model' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #PluggableMorph category: 'Morphic-Widgets' stamp: 'Install-4398-MakeBorderedRectMorphSubclassesBeWidgets-JuanVuletich-2020Oct12-20h38m-jmv.001.cs.st 10/15/2020 19:33:02'! -WidgetMorph subclass: #PluggableMorph - instanceVariableNames: 'model' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -WidgetMorph subclass: #TileResizeMorph - instanceVariableNames: 'selectedResize selectionColor action' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #TileResizeMorph category: 'Morphic-Widgets' stamp: 'Install-4398-MakeBorderedRectMorphSubclassesBeWidgets-JuanVuletich-2020Oct12-20h38m-jmv.001.cs.st 10/15/2020 19:33:02'! -WidgetMorph subclass: #TileResizeMorph - instanceVariableNames: 'selectedResize selectionColor action' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -WidgetMorph subclass: #ProgressBarMorph - instanceVariableNames: 'value progressColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Composite Widgets'! - -!classDefinition: #ProgressBarMorph category: 'Morphic-Composite Widgets' stamp: 'Install-4398-MakeBorderedRectMorphSubclassesBeWidgets-JuanVuletich-2020Oct12-20h38m-jmv.001.cs.st 10/15/2020 19:33:02'! -WidgetMorph subclass: #ProgressBarMorph - instanceVariableNames: 'value progressColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Composite Widgets'! - -WidgetMorph subclass: #StringRequestMorph - instanceVariableNames: 'response acceptBlock cancelBlock validationBlock' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Composite Widgets'! - -!classDefinition: #StringRequestMorph category: 'Morphic-Composite Widgets' stamp: 'Install-4398-MakeBorderedRectMorphSubclassesBeWidgets-JuanVuletich-2020Oct12-20h38m-jmv.001.cs.st 10/15/2020 19:33:02'! -WidgetMorph subclass: #StringRequestMorph - instanceVariableNames: 'response acceptBlock cancelBlock validationBlock' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Composite Widgets'! - -WidgetMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp titleMorph activeSubMenu popUpOwner' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #MenuMorph category: #'Morphic-Menus' stamp: 'Install-4398-MakeBorderedRectMorphSubclassesBeWidgets-JuanVuletich-2020Oct12-20h38m-jmv.001.cs.st 10/15/2020 19:33:02'! -WidgetMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp titleMorph activeSubMenu popUpOwner' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -WidgetMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity originalPosition showUp itemsPerPage' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #AutoCompleterMorph category: #'Tools-Autocompletion' stamp: 'Install-4398-MakeBorderedRectMorphSubclassesBeWidgets-JuanVuletich-2020Oct12-20h38m-jmv.001.cs.st 10/15/2020 19:33:02'! -WidgetMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity originalPosition showUp itemsPerPage' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4398-MakeBorderedRectMorphSubclassesBeWidgets-JuanVuletich-2020Oct12-20h38m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4395] on 12 October 2020 at 8:55:55 pm'! - -WidgetMorph subclass: #DraggingGuideMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #DraggingGuideMorph category: 'Morphic-Widgets' stamp: 'Install-4399-MakeRectangleLikeMorphSubclassesBeWidgets-JuanVuletich-2020Oct12-20h53m-jmv.001.cs.st 10/15/2020 19:33:02'! -WidgetMorph subclass: #DraggingGuideMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -WidgetMorph subclass: #LayoutAdjustingMorph - instanceVariableNames: 'hand' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -!classDefinition: #LayoutAdjustingMorph category: #'Morphic-Layouts' stamp: 'Install-4399-MakeRectangleLikeMorphSubclassesBeWidgets-JuanVuletich-2020Oct12-20h53m-jmv.001.cs.st 10/15/2020 19:33:02'! -WidgetMorph subclass: #LayoutAdjustingMorph - instanceVariableNames: 'hand' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -WidgetMorph subclass: #FillInTheBlankMorph - instanceVariableNames: 'response done textPane responseUponCancel' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Composite Widgets'! - -!classDefinition: #FillInTheBlankMorph category: 'Morphic-Composite Widgets' stamp: 'Install-4399-MakeRectangleLikeMorphSubclassesBeWidgets-JuanVuletich-2020Oct12-20h53m-jmv.001.cs.st 10/15/2020 19:33:02'! -WidgetMorph subclass: #FillInTheBlankMorph - instanceVariableNames: 'response done textPane responseUponCancel' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Composite Widgets'! - -WidgetMorph subclass: #HoverHelpMorph - instanceVariableNames: 'contents textComposition' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Composite Widgets'! - -!classDefinition: #HoverHelpMorph category: 'Morphic-Composite Widgets' stamp: 'Install-4399-MakeRectangleLikeMorphSubclassesBeWidgets-JuanVuletich-2020Oct12-20h53m-jmv.001.cs.st 10/15/2020 19:33:02'! -WidgetMorph subclass: #HoverHelpMorph - instanceVariableNames: 'contents textComposition' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Composite Widgets'! -!DraggingGuideMorph methodsFor: 'initialization' stamp: 'jmv 10/12/2020 20:43:42' overrides: 50545893! - defaultBorderWidth - "answer the default border width for the receiver" - ^ 0! ! -!LayoutAdjustingMorph methodsFor: 'initialization' stamp: 'jmv 10/12/2020 20:47:51' overrides: 50545893! - defaultBorderWidth - "answer the default border width for the receiver" - ^ 0! ! -!HoverHelpMorph methodsFor: 'initialization' stamp: 'jmv 10/12/2020 20:46:53' overrides: 50545893! - defaultBorderWidth - "answer the default border width for the receiver" - ^ 0! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4399-MakeRectangleLikeMorphSubclassesBeWidgets-JuanVuletich-2020Oct12-20h53m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4396] on 12 October 2020 at 9:01:52 pm'! - -WidgetMorph subclass: #ResizeMorph - instanceVariableNames: 'gridLineWidth gridColor selectionColor outlineMorph grid from to action' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #ResizeMorph category: 'Morphic-Widgets' stamp: 'Install-4400-MakeRectangleLikeMorphSubclassesBeWidgets-JuanVuletich-2020Oct12-20h58m-jmv.001.cs.st 10/15/2020 19:33:02'! -WidgetMorph subclass: #ResizeMorph - instanceVariableNames: 'gridLineWidth gridColor selectionColor outlineMorph grid from to action' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -WidgetMorph subclass: #TranscriptMorph - instanceVariableNames: 'workspace lastIncludedIndex workspaceWindow lastUnfinishedEntrySize doImmediateUpdates' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Composite Widgets'! - -!classDefinition: #TranscriptMorph category: 'Morphic-Composite Widgets' stamp: 'Install-4400-MakeRectangleLikeMorphSubclassesBeWidgets-JuanVuletich-2020Oct12-20h58m-jmv.001.cs.st 10/15/2020 19:33:02'! -WidgetMorph subclass: #TranscriptMorph - instanceVariableNames: 'workspace lastIncludedIndex workspaceWindow lastUnfinishedEntrySize doImmediateUpdates' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Composite Widgets'! - -WidgetMorph subclass: #MenuLineMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #MenuLineMorph category: #'Morphic-Menus' stamp: 'Install-4400-MakeRectangleLikeMorphSubclassesBeWidgets-JuanVuletich-2020Oct12-20h58m-jmv.001.cs.st 10/15/2020 19:33:02'! -WidgetMorph subclass: #MenuLineMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! -!ResizeMorph methodsFor: 'initialization' stamp: 'jmv 10/12/2020 21:00:28' overrides: 50545893! - defaultBorderWidth - "answer the default border width for the receiver" - ^ 0! ! -!TranscriptMorph methodsFor: 'initialization' stamp: 'jmv 10/12/2020 21:00:55' overrides: 50545893! - defaultBorderWidth - "answer the default border width for the receiver" - ^ 0! ! -!MenuLineMorph methodsFor: 'initialization' stamp: 'jmv 10/12/2020 20:59:41' overrides: 50545893! - defaultBorderWidth - "answer the default border width for the receiver" - ^ 2! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4400-MakeRectangleLikeMorphSubclassesBeWidgets-JuanVuletich-2020Oct12-20h58m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4396] on 12 October 2020 at 9:05:07 pm'! - -Smalltalk renameClassNamed: #StringMorph as: #LabelMorph! - -!classRenamed: #StringMorph as: #LabelMorph stamp: 'Install-4401-RenameStringMorphAsLabelMorph-JuanVuletich-2020Oct12-21h01m-jmv.001.cs.st 10/15/2020 19:33:02'! -Smalltalk renameClassNamed: #StringMorph as: #LabelMorph! -!LabelMorph commentStamp: 'jmv 10/12/2020 21:03:15' prior: 50528609! - LabelMorph is a "lightweight" Morph to display a String. It supports only a single font, color, and emphasis combination. For multiple text styles, use TextModelMorph. - -Structure: -instance var Type Description -font StrikeFont (normally nil; then the accessor #font gives back a Font or nil #defaultFont) -emphasis SmallInteger bitmask determining character attributes (underline, bold, italics, struckThrough) -contents String The text that will be displayed. -! -!IndentingListItemMorph commentStamp: 'jmv 10/12/2020 21:03:00' prior: 16854563! -An IndentingListItemMorph is a LabelMorph that draws itself with an optional toggle at its left, as part of the display of the SimpleHierarchicalListMorph. - -It will also display lines around the toggle if the #showLinesInHierarchyViews Preference is set. - -Instance variables: - -indentLevel the indent level, from 0 at the root and increasing by 1 at each level of the hierarchy. - -isExpanded true if this item is expanded (showing its children) - -complexContents an adapter wrapping my represented item that can answer its children, etc. - -firstChild my first child, or nil if none - -container my container - -nextSibling the next item in the linked list of siblings, or nil if none. - -icon a 16 x 16 form or nil - -Contributed by Bob Arning as part of the ObjectExplorer package. -Don't blame him if it's not perfect. We wanted to get it out for people to play with.! - -Smalltalk renameClassNamed: #UpdatingStringMorph as: #UpdatingLabelMorph! - -!classRenamed: #UpdatingStringMorph as: #UpdatingLabelMorph stamp: 'Install-4401-RenameStringMorphAsLabelMorph-JuanVuletich-2020Oct12-21h01m-jmv.001.cs.st 10/15/2020 19:33:02'! -Smalltalk renameClassNamed: #UpdatingStringMorph as: #UpdatingLabelMorph! -!UpdatingLabelMorph commentStamp: '' prior: 50337064! - UpdatingLabelMorph new - target: [self runningWorld activeHand morphPosition asString]; - getSelector: #value; - stepTime: 10; - openInWorld! -!LabelMorph methodsFor: 'initialization' stamp: 'jmv 10/12/2020 21:06:00'! - defaultBorderWidth - "answer the default border width for the receiver" - ^ 0! ! -!LabelMorph class methodsFor: 'instance creation' stamp: 'jmv 10/12/2020 21:04:02' prior: 16918283! - contents: aString - - ^ self contents: aString font: nil! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 10/12/2020 21:02:19' prior: 50520386! - example6 - " - Useful example contributed by Ken Dickey - All these should look the same, right? (mmmh this should be a test...) - self example6 - " -| pane rect1 rect2 | -pane _ LayoutMorph newRow separation: 5. "1" -pane addMorph: (LabelMorph contents: '1'). - -rect1 := BorderedRectMorph new color: (Color lightOrange); - morphExtent: 20 @ 30. -pane addMorphFront: rect1. -rect2 := BorderedRectMorph new color: (Color cyan); - morphExtent: 20 @ 30. -pane addMorphFront: rect2. -pane - color: Color lightGreen; - morphPosition: 120 @ 50 extent: 180 @ 100; - openInWorld. - -pane _ LayoutMorph newRow separation: 5. "2" -pane addMorph: (LabelMorph contents: '2'). - -rect1 := BorderedRectMorph new color: (Color lightOrange); - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 offAxisEdgeWeight: #center). -pane addMorph: rect1. -rect2 := BorderedRectMorph new color: (Color cyan). -pane addMorph: rect2 - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 offAxisEdgeWeight: #center). -pane - color: Color lightGreen; - morphPosition: 320 @ 50 extent: 180 @ 100; - openInWorld. - - -pane _ LayoutMorph newRow separation: 5. "3" -pane addMorph: (LabelMorph contents: '3'). - -rect1 := BorderedRectMorph new color: (Color lightOrange). -pane addMorph: rect1 - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 offAxisEdgeWeight: #center). -rect2 := BorderedRectMorph new color: (Color cyan); - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 offAxisEdgeWeight: #center). -pane addMorph: rect2. -pane - color: Color lightGreen; - morphPosition: 520 @ 50 extent: 180 @ 100; - openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 10/12/2020 21:02:19' prior: 16864083! - example7 - " - Useful example contributed by Ken Dickey - All these should look the same, right? (mmmh this should be a test...) - self example7 - " - "============================================" - | c colorHexValue colorName r w | - w := SystemWindow new. - r := LayoutMorph newRow separation: 30 @ 10. - c := LayoutMorph newColumn separation: 20 @ 10. - colorHexValue := LabelMorph contents: 'F97306'. - colorName := LabelMorph contents: 'cornSilk'. - - r addMorph: colorHexValue. - r addMorph: colorName. - c addMorph: RectangleLikeMorph new. - c addMorph: r. - w addMorph: c . - w openInWorld. - "============================================"! ! -!ProgressMorph methodsFor: 'initialization' stamp: 'jmv 10/12/2020 21:02:19' prior: 50523054 overrides: 50521469! - initialize - super initialize. - self separation: 0. - labelMorph _ LabelMorph contents: '' font: FontFamily defaultFamilyAndPointSize. - subLabelMorph _ LabelMorph contents: '' font: FontFamily defaultFamilyAndPointSize. - progress _ ProgressBarMorph new. - progress morphExtent: 200 @ FontFamily defaultLineSpacing. - self addMorphFront: labelMorph. - self addMorphFront: subLabelMorph. - self addMorph: progress fixedHeight: FontFamily defaultLineSpacing! ! -!TaskbarMorph methodsFor: 'initialization' stamp: 'jmv 10/12/2020 21:02:38' prior: 50520439 overrides: 50521469! - initialize - super initialize. - viewBox _ LayoutMorph newRow color: self defaultColor. - self - addMorph: UpdatingLabelMorph initializedInstance - layoutSpec: (LayoutSpec morphWidthProportionalHeight: 0.5). - self - addMorph: viewBox - layoutSpec: (LayoutSpec - proportionalWidth: 1.0 - proportionalHeight: 1.0 - offAxisEdgeWeight: #rightOrBottom). - viewBox separation: self defaultHeight // 8 -! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 10/12/2020 21:02:19' prior: 50541025! - addNameString: aString - "Add a name display centered beneath the bottom of the outer rectangle. Return the handle." - - | nameMorph verticalNamePosition namePosition nameBackground | - nameBackground _ RectangleLikeMorph new - color: ((target is: #SystemWindow) - ifTrue: [target windowColor] - ifFalse: [`Color lightBlue alpha: 0.9`]). - nameMorph _ LabelMorph contents: aString. - nameMorph color: `Color black`. - nameBackground morphExtent: nameMorph morphExtent + 4. - verticalNamePosition _ haloBox bottom + Preferences haloHandleSize. - namePosition _ haloBox width - nameMorph morphWidth // 2 + haloBox left @ verticalNamePosition. - self addMorph: nameBackground. - nameBackground morphPosition: namePosition - 2. - self addMorph: nameMorph. - nameMorph morphPosition: namePosition. - ^nameMorph! ! -!PluggableListMorph methodsFor: 'events' stamp: 'jmv 10/12/2020 21:02:19' prior: 50538178 overrides: 16874501! - dragEvent: aMouseEvent localPosition: localEventPosition - - | row dragged listItem sm | - self listMorph highlightedRow: nil. - row _ self rowAtLocation: localEventPosition ifNone: [ ^self ]. - listItem _ self getListItem: row. - - sm _ LabelMorph contents: listItem. - dragged _ DraggingGuideMorph new. - dragged addMorph: sm. - dragged morphExtent: sm morphExtent. - dragged setProperty: #dragSource toValue: self. - dragged setProperty: #dropSelectorArgument toValue: listItem. - - aMouseEvent hand attachMorphBeside: dragged.! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'jmv 10/12/2020 21:02:19' prior: 50455548! - buildMorphicWindow - " - CodePackageListWindow open: CodePackageList new - " - | dirtyFlags names fileNames upperRow description summary backColor labelBackground | - backColor := self textBackgroundColor. - labelBackground := Theme current background. - - dirtyFlags := PluggableListMorph - model: model - listGetter: #packageDirtyFlags - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - dirtyFlags color: backColor. - dirtyFlags := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: ' Unsaved?'); - addMorphUseAll: dirtyFlags. - - names := PluggableListMorph - model: model - listGetter: #packageNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - names color: backColor. - names := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: ' Package Name'); - addMorphUseAll: names. - - fileNames := PluggableListMorph - model: model - listGetter: #packageFullNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - fileNames color: backColor. - fileNames := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: ' File Name'); - addMorphUseAll: fileNames. - - upperRow := LayoutMorph newRow. - upperRow - addMorph: dirtyFlags proportionalWidth: 0.13; - addAdjusterAndMorph: names proportionalWidth: 0.27; - addAdjusterAndMorph: fileNames proportionalWidth: 0.6. - - description := (TextModelMorph - textProvider: model - textGetter: #description - textSetter: #description:) emptyTextDisplayMessage: 'Please enter a description for this package'. - - summary := (TextModelMorph - textProvider: model - textGetter: #summary) emptyTextDisplayMessage: 'Package summary (No package selected?)'. - - self layoutMorph - addMorph: upperRow proportionalHeight: 0.6; - addAdjusterAndMorph: self buildButtonPane fixedHeight: Theme current buttonPaneHeight; - addAdjusterAndMorph: summary fixedHeight: 60; - addAdjusterAndMorph: description proportionalHeight: 0.25; - addAdjusterAndMorph: self buildRequirementsPane proportionalHeight: 0.15. - self setLabel: 'Installed Packages'! ! -!ChangeSorterWindow methodsFor: 'GUI building' stamp: 'jmv 10/12/2020 21:02:19' prior: 50388041! - buildMorphicWindow - "Add a set of change sorter views to the given top view offset by the given amount. To create a single change sorter, call this once with an offset of 0@0. To create a dual change sorter, call it twice with offsets of 0@0 and 0.5@0." - - | dirtyFlags changeSetList classList messageList upperPanes backColor labelBackground | - backColor _ self textBackgroundColor. - labelBackground _ Theme current background. - model myChangeSet ifNil: [ - self flag: #ojo. "Or whatever was last changed, or is top of list, or whatever" - model myChangeSet: ChangeSet changeSetForBaseSystem ]. - - dirtyFlags _ PluggableListMorph - model: model - listGetter: #changeSetDirtyFlags - indexGetter: nil - indexSetter: nil. - dirtyFlags color: backColor. - dirtyFlags _ LayoutMorph newColumn - color: Theme current background; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: ' Unsaved?'); - addMorphUseAll: dirtyFlags. - - changeSetList _ (PluggableListMorphByItem - model: model - listGetter: #changeSetList - indexGetter: #currentCngSet - indexSetter: #showChangeSetNamed: - mainView: self - menuGetter: #changeSetMenu - keystrokeAction: #changeSetListKey:from:) - autoDeselect: false. - changeSetList color: backColor. - changeSetList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: 'Change Set name'); - addMorphUseAll: changeSetList. - - classList _ PluggableListMorphByItem - model: model - listGetter: #classList - indexGetter: #currentClassName - indexSetter: #currentClassName: - mainView: self - menuGetter: #classListMenu - keystrokeAction: #classListKey:from:. - classList color: backColor. - classList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: 'Classes'); - addMorphUseAll: classList. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: dirtyFlags proportionalWidth: 0.13; - addAdjusterAndMorph: changeSetList proportionalWidth: 0.47; - addAdjusterAndMorph: classList proportionalWidth: 0.4. - - messageList _ PluggableListMorphByItem - model: model - listGetter: #messageList - indexGetter: #currentSelector - indexSetter: #currentSelector: - mainView: self - menuGetter: #messageMenu - keystrokeAction: #messageListKey:from:. - messageList color: backColor. - messageList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: 'Methods'); - addMorphUseAll: messageList. - - self layoutMorph - addMorph: upperPanes proportionalHeight: 0.25; - addAdjusterAndMorph: messageList proportionalHeight: 0.2; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.55. - - self setLabel: model labelString! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jmv 10/12/2020 21:02:19' prior: 50385746! - createQueryTextMorph: queryString - "create the queryTextMorph" - | result | - result _ LabelMorph new contents: queryString. - result lock. - result morphExtent: `24@2` * self sizeUnit. - self addMorph: result position: `2@0.5` * self sizeUnit // 1. - ^ result! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'jmv 10/12/2020 21:02:19' prior: 50513732! - addTitle: aString - | titleMorph s pp w | - titleMorph _ RectangleLikeMorph new. - titleMorph color: Theme current menuTitleBar. - pp _ `8@2`. - aString asString linesDo: [ :line | - s _ LabelMorph new - contents: line; - font: Preferences standardMenuFont bold. - titleMorph addMorphBack: s position: pp. - pp _ pp + (0@(s morphHeight+2)) ]. - w _ titleMorph submorphs inject: 0 into: [ :prev :each | - prev max: each morphWidth ]. - titleMorph morphExtent: (w + 16) @ (pp y). - self addMorphFront: titleMorph.! ! -!MenuMorph methodsFor: 'accessing' stamp: 'jmv 10/12/2020 21:04:14' prior: 50544594 overrides: 16876446! - label - "Answer a nice label. - - Pinned menus in the taskbar are easier to identify on big screens." - - titleMorph ifNil: [ ^ super label ]. - titleMorph submorphsDo: [ :labelMorph | - "Be careful" - [ ^ labelMorph contents ] onDNU: #contents do: [] ]. - ^ super label ":] One never knows"! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 10/12/2020 21:02:19' prior: 50384862! - addTitle: aString - "Add a title line at the top of this menu Make aString its initial - contents. - If aSelector is not nil, then periodically obtain fresh values for its - contents by sending aSelector to aTarget.." - - | s pp w | - - titleMorph _ RectangleLikeMorph new. - titleMorph color: Theme current menuTitleBar. - pp _ `8@2`. - aString asString linesDo: [ :line | - s _ LabelMorph new - contents: line; - font: Preferences standardMenuFont bold. - titleMorph addMorphBack: s position: pp. - pp _ pp + (0@(s morphHeight+2)) ]. - w _ titleMorph submorphs inject: 0 into: [ :prev :each | - prev max: each morphWidth ]. - titleMorph morphExtent: (w + 16) @ (pp y). - self addMorphFront: titleMorph. - - (self hasProperty: #needsStayUpIcons) ifTrue: [ self addStayUpIcons ]! ! -!MenuMorph methodsFor: 'keyboard control' stamp: 'jmv 10/12/2020 21:02:19' prior: 50388221! - displayFiltered: evt - | matchStr allItems isMatch matches feedbackMorph | - matchStr _ self valueOfProperty: #matchString. - allItems _ self submorphs select: [ :m | - m is: #MenuItemMorph ]. - matches _ allItems select: [ :m | - isMatch _ matchStr isEmpty or: [ - m contents - includesSubstring: matchStr - caseSensitive: false ]. - m isEnabled: isMatch. - isMatch ]. - feedbackMorph _ self valueOfProperty: #feedbackMorph. - feedbackMorph ifNil: [ - feedbackMorph _ LabelMorph new color: `Color veryDarkGray`. - self addMorphBack: feedbackMorph lock position: `0@ -20`. - self - setProperty: #feedbackMorph - toValue: feedbackMorph ]. - feedbackMorph contents: '<' , matchStr , '>'. - matchStr isEmpty ifTrue: [ - feedbackMorph delete. - self removeProperty: #feedbackMorph ]. - matches notEmpty ifTrue: [ - self selectItem: matches first ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4401-RenameStringMorphAsLabelMorph-JuanVuletich-2020Oct12-21h01m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4411] on 15 October 2020 at 9:20:32 am'! - -"Change Set: 4402-MakeLabelMorphAWidget-JuanVuletich-2020Oct15-19h03m-jmv.001.cs.st -Date: 15 October 2020 -Author: Juan Vuletich - -Modifying class definition of core to Morphs is tricky. Hence this preamble." -| ui b cs | -Utilities authorInitialsPerSe ifNil: [ Utilities setAuthor ]. -(nil confirm: 'In order to modify instance definition of LabelMorph, -we need to restart the User Interface process. -You''ll need to do [Install New Updates] again, to install later updates.') ifFalse: [ self halt ]. -[ - ui _ UISupervisor ui. - UISupervisor stopUIProcess. - b _ ClassBuilder isSilent. - ClassBuilder beSilent: true. - ClassBuilder new - superclass: WidgetMorph - subclass: #LabelMorph - instanceVariableNames: 'font emphasis contents' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'. - ClassBuilder new - superclass: LabelMorph - subclass: #UpdatingLabelMorph - instanceVariableNames: 'target getSelector stepTime' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'. - ClassBuilder beSilent: b. - UISupervisor spawnNewMorphicProcessFor: ui. - (Delay forSeconds: 1) wait. - ChangeSet installing: '4402-MakeLabelMorphAWidget-JuanVuletich-2020Oct15-19h03m-jmv.001.cs.st' do: []. - cs _ ChangeSet changeSetForBaseSystem. - (cs name beginsWith: '4402') ifTrue: [ - ChangeSet removeChangeSet: cs ]. - 'Done updating definition of LabelMorph.' print. - 'Installed ChangeSet: 4402-MakeLabelMorphAWidget-JuanVuletich-2020Oct15-19h03m-jmv.001.cs.st' print. - 'Please do [Install New Updates] again.' print. -] forkAt: 41! - -'From Cuis 5.0 [latest update: #4396] on 12 October 2020 at 9:09:20 pm'! -!LayoutMorph methodsFor: 'initialization' stamp: 'jmv 10/12/2020 21:09:06' overrides: 16899205! - drawOn: aCanvas - "A canvas is already set with a proper transformation from our coordinates to those of the Canvas target." - "If you redefine this method in a subclass, please take a look at the comment at #isOpaqueMorph" - aCanvas - fillRectangle: self morphLocalBounds - color: color - borderWidth: 0 - borderStyleSymbol: #simple - baseColorForBorder: Color white! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4403-LayoutMorphBeWidget-01-JuanVuletich-2020Oct12-21h07m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4396] on 12 October 2020 at 9:10:58 pm'! - -WidgetMorph subclass: #LayoutMorph - instanceVariableNames: 'direction separation axisEdgeWeight doAdoptWidgetsColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -!classDefinition: #LayoutMorph category: #'Morphic-Layouts' stamp: 'Install-4404-LayoutMorphBeWidget-02-JuanVuletich-2020Oct12-21h09m-jmv.001.cs.st 10/15/2020 19:33:11'! -WidgetMorph subclass: #LayoutMorph - instanceVariableNames: 'direction separation axisEdgeWeight doAdoptWidgetsColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! -!LayoutMorph methodsFor: 'initialization' stamp: 'jmv 10/12/2020 21:00:28' overrides: 50545893! - defaultBorderWidth - "answer the default border width for the receiver" - ^ 0! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -LayoutMorph allSubInstancesDo: [ :each | each instVarNamed: 'borderWidth' put: 0; instVarNamed: 'borderColor' put: Color white ].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4404-LayoutMorphBeWidget-02-JuanVuletich-2020Oct12-21h09m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4396] on 12 October 2020 at 9:11:28 pm'! - -LayoutMorph removeSelector: #drawOn:! - -!methodRemoval: LayoutMorph #drawOn: stamp: 'Install-4405-LayoutMorphBeWidget-03-JuanVuletich-2020Oct12-21h10m-jmv.001.cs.st 10/15/2020 19:33:11'! -drawOn: aCanvas - "A canvas is already set with a proper transformation from our coordinates to those of the Canvas target." - "If you redefine this method in a subclass, please take a look at the comment at #isOpaqueMorph" - aCanvas - fillRectangle: self morphLocalBounds - color: color - borderWidth: 0 - borderStyleSymbol: #simple - baseColorForBorder: Color white! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4405-LayoutMorphBeWidget-03-JuanVuletich-2020Oct12-21h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4403] on 12 October 2020 at 9:31:21 pm'! - -WidgetMorph subclass: #InnerPluggableMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #InnerPluggableMorph category: 'Morphic-Widgets' stamp: 'Install-4406-InnerPluggableMorphBeWidget-JuanVuletich-2020Jul31-16h13m-jmv.001.cs.st 10/15/2020 19:33:11'! -WidgetMorph subclass: #InnerPluggableMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4406-InnerPluggableMorphBeWidget-JuanVuletich-2020Jul31-16h13m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4404] on 12 October 2020 at 9:46:07 pm'! - -WidgetMorph subclass: #ImageMorph - instanceVariableNames: 'image' - classVariableNames: 'DefaultForm ' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #ImageMorph category: 'Morphic-Widgets' stamp: 'Install-4407-ImageMorphBeWidget-JuanVuletich-2020Oct12-21h45m-jmv.001.cs.st 10/15/2020 19:33:11'! -WidgetMorph subclass: #ImageMorph - instanceVariableNames: 'image' - classVariableNames: 'DefaultForm' - poolDictionaries: '' - category: 'Morphic-Widgets'! -!ImageMorph methodsFor: 'initialization' stamp: 'jmv 10/12/2020 21:45:40' overrides: 50545893! - defaultBorderWidth - "answer the default border width for the receiver" - ^ 0! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4407-ImageMorphBeWidget-JuanVuletich-2020Oct12-21h45m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4407] on 14 October 2020 at 9:50:53 pm'! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 3/6/2020 16:06:23' prior: 50499921! - example1 -" - self example1 -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example1. -pane color: Color red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Color red; - addMorph: (WidgetMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addMorph: (WidgetMorph new color: (Color blue); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addMorph: (WidgetMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 200 fixedHeight: 200). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Color red; - addMorph: (WidgetMorph new color: (Color blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #G) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Color red; - addMorph: (WidgetMorph new color: (Color h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8); - addMorph: (WidgetMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (WidgetMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -pane morphPosition: 150@130 extent: 400@300. -pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/12/2015 16:42' prior: 50359992! - example10 -" - self example10 openInWorld -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example10. -pane color: Color red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Color red; - addMorph: (WidgetMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addAdjusterMorph; - addMorph: (WidgetMorph new color: (Color blue); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addAdjusterMorph; - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addAdjusterMorph; - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addAdjusterMorph; - addMorph: (WidgetMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 20). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Color red; - addMorph: (WidgetMorph new color: (Color blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #G) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Color red; - addMorph: (WidgetMorph new color: (Color h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8); - addMorph: (WidgetMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (WidgetMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -^ pane! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/5/2015 10:55' prior: 50360060! - example11 -" - self example11 -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example11. -pane color: Color red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Color red; - addMorph: (WidgetMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addAdjusterMorph; - addMorph: (WidgetMorph new color: (Color blue); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addAdjusterMorph; - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addAdjusterMorph; - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addAdjusterMorph; - addMorph: (WidgetMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 20). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Color red; - addMorph: (WidgetMorph new color: (Color blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #G) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Color red; - addMorph: (WidgetMorph new color: (Color h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8); - addMorph: (WidgetMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (WidgetMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -pane morphPosition: 150@130 extent: 400@300. -pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'KenD 5/22/2020 13:57:31' prior: 50520265! - example13 - " - self example13 - " - | pane row innerRow | -pane _ (LayoutMorph newColumn separation: 5) name: #example13. - pane color: Color red. - row _ (LayoutMorph newRow separation: 5) name: #Row. - innerRow _ (LayoutMorph newRow separation: 5) name: #InnerRow; - color: Color red. - innerRow - addMorph: (WidgetMorph new name: #Box1) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (WidgetMorph new name: #Box2) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (WidgetMorph new name: #Bar) - layoutSpec: (LayoutSpec proportionalWidth: 1.0 fixedHeight: 10). - row - color: (Color h: 270 s: 0.2 v: 0.6); - addMorph: innerRow - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 30 offAxisEdgeWeight: #center); - addMorph: LayoutAdjustingMorph new layoutSpec: (LayoutSpec fixedWidth: 5); - addMorph: (WidgetMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #Rect1) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40 offAxisEdgeWeight: #leftOrTop); - addMorph: LayoutAdjustingMorph new layoutSpec: (LayoutSpec fixedWidth: 5); - addMorph: (WidgetMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #Rect2) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). - pane addMorph: row layoutSpec: (LayoutSpec proportionalHeight: 0.9). - pane morphPosition: 250@130 extent: 400@300. - pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 2/16/2016 13:27' prior: 50360177! - example1b -" -Based on #example1, but using some Morph instead of RectangleLikeMorph -> extent is not adjustable - self example1b -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example1. -pane color: Color red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Color red; - addMorph: (WidgetMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addMorph: (Morph new name: #B); - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addMorph: (WidgetMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 20). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Color red; - addMorph: (WidgetMorph new color: (Color blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (Morph new name: #G); - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Color red; - addMorph: (Morph new name: #J); - addMorph: (WidgetMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (WidgetMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -pane morphPosition: 150@130 extent: 400@300. -pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'KenD 5/22/2020 13:55:23' prior: 50520312! - example2 - " - self example2 - " - | pane row | - pane _ (LayoutMorph newColumn separation: 5) name: #example2. - pane color: Color red. - row _ (LayoutMorph newRow separation: 5) name: #Row. - row - color: (Color h: 270 s: 0.2 v: 0.6); - addMorph: (WidgetMorph new color: (Color h: 120 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8 offAxisEdgeWeight: #rightOrBottom); - addMorph: (WidgetMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8 fixedHeight: 40 offAxisEdgeWeight: #leftOrTop); - addMorph: (WidgetMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 0.7 offAxisEdgeWeight: #center). - pane addMorph: row layoutSpec: (LayoutSpec proportionalHeight: 0.9). - pane morphPosition: 200@180 extent: 400@300. - pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 11/18/2015 09:45' prior: 50360270! - example20 -" - self example20 -" -| column | - -column _ (LayoutMorph newColumn separation: 5) name: #Column. -column - color: Color red; - addMorph: (WidgetMorph new color: (Color h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec proportionalWidth: 0.8 fixedHeight: 20); - addMorph: (WidgetMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec fixedWidth: 40 proportionalHeight: 0.5); - addMorph: (WidgetMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec proportionalWidth: 1.0 fixedHeight: 30). -column morphPosition: 150@130 extent: 400@300. -column openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'KenD 5/22/2020 13:58:02' prior: 50520344! - example3 - " - self example3 - " - | pane row innerRow | -pane _ (LayoutMorph newColumn separation: 5) name: #example3. - pane color: Color red. - row _ (LayoutMorph newRow separation: 5) name: #Row. - innerRow _ (LayoutMorph newRow separation: 5) name: #InnerRow; - color: Color red. - innerRow - addMorph: (WidgetMorph new name: #Box1) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (WidgetMorph new name: #Box2) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (WidgetMorph new name: #Bar) - layoutSpec: (LayoutSpec proportionalWidth: 1.0 fixedHeight: 10). - row - color: (Color h: 270 s: 0.2 v: 0.6); - addMorph: innerRow - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 30 offAxisEdgeWeight: #center); - addMorph: (WidgetMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #Rect1) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40 offAxisEdgeWeight: #leftOrTop); - addMorph: (WidgetMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #Rect2) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). - pane addMorph: row layoutSpec: (LayoutSpec proportionalHeight: 0.9). - pane morphPosition: 250@130 extent: 400@300. - pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 10/12/2020 21:02:19' prior: 50546495! - example6 - " - Useful example contributed by Ken Dickey - All these should look the same, right? (mmmh this should be a test...) - self example6 - " -| pane rect1 rect2 | -pane _ LayoutMorph newRow separation: 5. "1" -pane addMorph: (LabelMorph contents: '1'). - -rect1 := WidgetMorph new color: (Color lightOrange); - morphExtent: 20 @ 30. -pane addMorphFront: rect1. -rect2 := WidgetMorph new color: (Color cyan); - morphExtent: 20 @ 30. -pane addMorphFront: rect2. -pane - color: Color lightGreen; - morphPosition: 120 @ 50 extent: 180 @ 100; - openInWorld. - -pane _ LayoutMorph newRow separation: 5. "2" -pane addMorph: (LabelMorph contents: '2'). - -rect1 := WidgetMorph new color: (Color lightOrange); - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 offAxisEdgeWeight: #center). -pane addMorph: rect1. -rect2 := WidgetMorph new color: (Color cyan). -pane addMorph: rect2 - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 offAxisEdgeWeight: #center). -pane - color: Color lightGreen; - morphPosition: 320 @ 50 extent: 180 @ 100; - openInWorld. - - -pane _ LayoutMorph newRow separation: 5. "3" -pane addMorph: (LabelMorph contents: '3'). - -rect1 := WidgetMorph new color: (Color lightOrange). -pane addMorph: rect1 - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 offAxisEdgeWeight: #center). -rect2 := WidgetMorph new color: (Color cyan); - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 offAxisEdgeWeight: #center). -pane addMorph: rect2. -pane - color: Color lightGreen; - morphPosition: 520 @ 50 extent: 180 @ 100; - openInWorld! ! -!ResizeMorph methodsFor: 'events' stamp: 'jmv 3/10/2018 21:31:55' prior: 50388525 overrides: 16874541! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - from _ self toGridPoint: localEventPosition. - outlineMorph _ WidgetMorph new - borderColor: `Color black`; - color: `Color transparent`; - openInWorld; - hide. - self selectTo: localEventPosition! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4408-FixReferencesToBorderedRectMorph-JuanVuletich-2020Oct14-21h46m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4407] on 14 October 2020 at 10:01:55 pm'! -!WidgetMorph methodsFor: 'initialization' stamp: 'jmv 10/14/2020 21:55:52'! - noBorder - borderWidth _ 0.! ! -!ClassDescription methodsFor: 'instance variables' stamp: 'jmv 8/21/2012 16:53' prior: 16805859! - allInstVarNamesEverywhere - "Answer the set of inst var names used by the receiver, all superclasses, and all subclasses" - - | aList | - aList _ OrderedCollection new. - (self allSuperclasses , self withAllSubclasses asOrderedCollection) do: - [:cls | aList addAll: cls instVarNames]. - ^ aList asSet - - "WidgetMorph allInstVarNamesEverywhere"! ! -!Morph methodsFor: 'stepping' stamp: 'jmv 10/14/2020 21:57:23' prior: 16876536 overrides: 16882488! - stepAt: millisecondSinceLast - "Do some periodic activity. Use startStepping/stopStepping to start and stop getting sent this message. - The desired time between steps is specified by this morph's answer to the stepTime message. - The millisecondSinceLast parameter gives the time elapsed since the previous step." - " - m _ WidgetMorph new. - m color: Color random. - m openInWorld. - m morphPosition: 10@10. - t _ 0. - m when: #morphicStep evaluate: [ :delta | - t _ t + delta. - t < 10000 - ifTrue: [ - (m owner is: #HandMorph) ifFalse: [ - m morphPosition: 3@2 * t // 100 ]] - ifFalse: [ m stopStepping ]]. - m startSteppingStepTime: 20. - " - self step. - self triggerEvent: #morphicStep with: millisecondSinceLast! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 10/14/2020 21:59:31' prior: 50546606! -addNameString: aString - "Add a name display centered beneath the bottom of the outer rectangle. Return the handle." - - | nameMorph verticalNamePosition namePosition nameBackground | - nameBackground _ WidgetMorph new noBorder - color: ((target is: #SystemWindow) - ifTrue: [target windowColor] - ifFalse: [`Color lightBlue alpha: 0.9`]). - nameMorph _ LabelMorph contents: aString. - nameMorph color: `Color black`. - nameBackground morphExtent: nameMorph morphExtent + 4. - verticalNamePosition _ haloBox bottom + Preferences haloHandleSize. - namePosition _ haloBox width - nameMorph morphWidth // 2 + haloBox left @ verticalNamePosition. - self addMorph: nameBackground. - nameBackground morphPosition: namePosition - 2. - self addMorph: nameMorph. - nameMorph morphPosition: namePosition. - ^nameMorph! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 10/14/2020 21:59:16' prior: 50546548! - example7 - " - Useful example contributed by Ken Dickey - All these should look the same, right? (mmmh this should be a test...) - self example7 - " - "============================================" - | c colorHexValue colorName r w | - w := SystemWindow new. - r := LayoutMorph newRow separation: 30 @ 10. - c := LayoutMorph newColumn separation: 20 @ 10. - colorHexValue := LabelMorph contents: 'F97306'. - colorName := LabelMorph contents: 'cornSilk'. - - r addMorph: colorHexValue. - r addMorph: colorName. - c addMorph: WidgetMorph new. - c addMorph: r. - w addMorph: c . - w openInWorld. - "============================================"! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'jmv 10/14/2020 21:59:49' prior: 50546655! - buildMorphicWindow - " - CodePackageListWindow open: CodePackageList new - " - | dirtyFlags names fileNames upperRow description summary backColor labelBackground | - backColor := self textBackgroundColor. - labelBackground := Theme current background. - - dirtyFlags := PluggableListMorph - model: model - listGetter: #packageDirtyFlags - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - dirtyFlags color: backColor. - dirtyFlags := LayoutMorph newColumn - color: labelBackground; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: ' Unsaved?'); - addMorphUseAll: dirtyFlags. - - names := PluggableListMorph - model: model - listGetter: #packageNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - names color: backColor. - names := LayoutMorph newColumn - color: labelBackground; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: ' Package Name'); - addMorphUseAll: names. - - fileNames := PluggableListMorph - model: model - listGetter: #packageFullNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - fileNames color: backColor. - fileNames := LayoutMorph newColumn - color: labelBackground; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: ' File Name'); - addMorphUseAll: fileNames. - - upperRow := LayoutMorph newRow. - upperRow - addMorph: dirtyFlags proportionalWidth: 0.13; - addAdjusterAndMorph: names proportionalWidth: 0.27; - addAdjusterAndMorph: fileNames proportionalWidth: 0.6. - - description := (TextModelMorph - textProvider: model - textGetter: #description - textSetter: #description:) emptyTextDisplayMessage: 'Please enter a description for this package'. - - summary := (TextModelMorph - textProvider: model - textGetter: #summary) emptyTextDisplayMessage: 'Package summary (No package selected?)'. - - self layoutMorph - addMorph: upperRow proportionalHeight: 0.6; - addAdjusterAndMorph: self buildButtonPane fixedHeight: Theme current buttonPaneHeight; - addAdjusterAndMorph: summary fixedHeight: 60; - addAdjusterAndMorph: description proportionalHeight: 0.25; - addAdjusterAndMorph: self buildRequirementsPane proportionalHeight: 0.15. - self setLabel: 'Installed Packages'! ! -!ChangeSorterWindow methodsFor: 'GUI building' stamp: 'jmv 10/14/2020 21:59:56' prior: 50546733! - buildMorphicWindow - "Add a set of change sorter views to the given top view offset by the given amount. To create a single change sorter, call this once with an offset of 0@0. To create a dual change sorter, call it twice with offsets of 0@0 and 0.5@0." - - | dirtyFlags changeSetList classList messageList upperPanes backColor labelBackground | - backColor _ self textBackgroundColor. - labelBackground _ Theme current background. - model myChangeSet ifNil: [ - self flag: #ojo. "Or whatever was last changed, or is top of list, or whatever" - model myChangeSet: ChangeSet changeSetForBaseSystem ]. - - dirtyFlags _ PluggableListMorph - model: model - listGetter: #changeSetDirtyFlags - indexGetter: nil - indexSetter: nil. - dirtyFlags color: backColor. - dirtyFlags _ LayoutMorph newColumn - color: Theme current background; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: ' Unsaved?'); - addMorphUseAll: dirtyFlags. - - changeSetList _ (PluggableListMorphByItem - model: model - listGetter: #changeSetList - indexGetter: #currentCngSet - indexSetter: #showChangeSetNamed: - mainView: self - menuGetter: #changeSetMenu - keystrokeAction: #changeSetListKey:from:) - autoDeselect: false. - changeSetList color: backColor. - changeSetList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: 'Change Set name'); - addMorphUseAll: changeSetList. - - classList _ PluggableListMorphByItem - model: model - listGetter: #classList - indexGetter: #currentClassName - indexSetter: #currentClassName: - mainView: self - menuGetter: #classListMenu - keystrokeAction: #classListKey:from:. - classList color: backColor. - classList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: 'Classes'); - addMorphUseAll: classList. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: dirtyFlags proportionalWidth: 0.13; - addAdjusterAndMorph: changeSetList proportionalWidth: 0.47; - addAdjusterAndMorph: classList proportionalWidth: 0.4. - - messageList _ PluggableListMorphByItem - model: model - listGetter: #messageList - indexGetter: #currentSelector - indexSetter: #currentSelector: - mainView: self - menuGetter: #messageMenu - keystrokeAction: #messageListKey:from:. - messageList color: backColor. - messageList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: 'Methods'); - addMorphUseAll: messageList. - - self layoutMorph - addMorph: upperPanes proportionalHeight: 0.25; - addAdjusterAndMorph: messageList proportionalHeight: 0.2; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.55. - - self setLabel: model labelString! ! -!ScrollBar methodsFor: 'initialization' stamp: 'jmv 10/14/2020 21:58:16' prior: 16904663! - initializeSlider - "initialize the receiver's slider" - - sliderShadow _ WidgetMorph new noBorder. - self addMorph: sliderShadow. - sliderShadow hide. - - slider _ self sliderClass new. - slider model: self. - slider grabSelector: #sliderGrabbedAt:. - slider dragSelector: #scrollTo:. - slider action: #sliderReleased. - self addMorph: slider. - - self computeSlider! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'jmv 10/14/2020 21:58:39' prior: 50546844! - addTitle: aString - | titleMorph s pp w | - titleMorph _ WidgetMorph new noBorder. - titleMorph color: Theme current menuTitleBar. - pp _ `8@2`. - aString asString linesDo: [ :line | - s _ LabelMorph new - contents: line; - font: Preferences standardMenuFont bold. - titleMorph addMorphBack: s position: pp. - pp _ pp + (0@(s morphHeight+2)) ]. - w _ titleMorph submorphs inject: 0 into: [ :prev :each | - prev max: each morphWidth ]. - titleMorph morphExtent: (w + 16) @ (pp y). - self addMorphFront: titleMorph.! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 10/14/2020 22:00:03' prior: 50471997! - addStayUpIcons - | closeButton pinButton w buttonHW | - Preferences optionalButtons ifFalse: [ ^self ]. - (self valueOfProperty: #hasStayUpIcons ifAbsent: [ false ]) - ifTrue: [ - self removeProperty: #needsStayUpIcons. - ^self ]. - titleMorph ifNil: [ - "Title not yet there. Flag ourself, so this method is called again when adding title." - self setProperty: #needsStayUpIcons toValue: true. - ^ self]. - buttonHW _ Preferences windowTitleFont pointSize. - closeButton _ PluggableButtonMorph model: self action: #delete. - closeButton icon: Theme current closeIcon; color: `Color transparent`. - pinButton _ PluggableButtonMorph model: self action: #stayUp. - pinButton icon: Theme current pushPinIcon; color: `Color transparent`. - w _ (titleMorph hasSubmorphs ifTrue: [ titleMorph firstSubmorph morphWidth ] ifFalse: [ 0 ]) + 60. - self addMorphFront: - (LayoutMorph newRow - "Make room for buttons" - morphExtent: w @ (titleMorph morphHeight max: buttonHW); - color: `Color transparent`; - addMorph: closeButton fixedWidth: buttonHW; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedWidth: buttonHW//3; - addMorph: titleMorph proportionalWidth: 1; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedWidth: buttonHW//3; - addMorph: pinButton fixedWidth: buttonHW). - - self setProperty: #hasStayUpIcons toValue: true. - self removeProperty: #needsStayUpIcons! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 10/14/2020 21:58:47' prior: 50546876! - addTitle: aString - "Add a title line at the top of this menu Make aString its initial - contents. - If aSelector is not nil, then periodically obtain fresh values for its - contents by sending aSelector to aTarget.." - - | s pp w | - - titleMorph _ WidgetMorph new noBorder. - titleMorph color: Theme current menuTitleBar. - pp _ `8@2`. - aString asString linesDo: [ :line | - s _ LabelMorph new - contents: line; - font: Preferences standardMenuFont bold. - titleMorph addMorphBack: s position: pp. - pp _ pp + (0@(s morphHeight+2)) ]. - w _ titleMorph submorphs inject: 0 into: [ :prev :each | - prev max: each morphWidth ]. - titleMorph morphExtent: (w + 16) @ (pp y). - self addMorphFront: titleMorph. - - (self hasProperty: #needsStayUpIcons) ifTrue: [ self addStayUpIcons ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4409-FixReferencesToRectangleLikeMorph-JuanVuletich-2020Oct14-21h50m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4396] on 14 October 2020 at 10:13:30 pm'! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 10/14/2020 22:13:15' prior: 50547378! - example1b -" -Based on #example1, but using some ImageMorph instead of RectangleLikeMorph, so extent is not adjustable - self example1b -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example1. -pane color: Color red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Color red; - addMorph: (WidgetMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addMorph: (ImageMorph new name: #B); - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addMorph: (WidgetMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 20). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Color red; - addMorph: (WidgetMorph new color: (Color blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (ImageMorph new name: #G); - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Color red; - addMorph: (ImageMorph new name: #J); - addMorph: (WidgetMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (WidgetMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -pane morphPosition: 150@130 extent: 400@300. -pane openInWorld! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4410-LayoutExampleFix-JuanVuletich-2020Oct14-22h12m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4410] on 15 October 2020 at 9:10:32 am'! - -Smalltalk renameClassNamed: #RectangleLikeMorph as: #KernelMorph! - -!classRenamed: #RectangleLikeMorph as: #KernelMorph stamp: 'Install-4411-KernelMorphsReorganization-JuanVuletich-2020Oct15-09h03m-jmv.001.cs.st 10/15/2020 19:33:11'! -Smalltalk renameClassNamed: #RectangleLikeMorph as: #KernelMorph! -!WidgetMorph commentStamp: '' prior: 50545841! - Hierarchy for morphs that are rectangle like, and that occupy an area that can be specified as a Rectangle. This means that, besides being of rectangular shape, sides are aligned with local coordinate axes. Including rectangles with rounded corners and such. The idea is that the 'extent' ivar is all that's needed to establish our dimensions and shape. Instances may have a border, see instanceVariables borderWidth and borderColor. Subclasses can use a variety of border styles: simple, inset, raised -Subclasses can add things like 'roundedCornerRadious' or such.! -!KernelMorph methodsFor: 'geometry testing' stamp: 'jmv 10/15/2020 09:09:42' prior: 50532168 overrides: 50532139! - requiresVectorCanvas - "Kernel morphs can run with the older BitBltCanvas" - - ^false! ! - -KernelMorph removeSelector: #layoutSpec:! - -!methodRemoval: KernelMorph #layoutSpec: stamp: 'Install-4411-KernelMorphsReorganization-JuanVuletich-2020Oct15-09h03m-jmv.001.cs.st 10/15/2020 19:33:11'! -layoutSpec: aLayoutSpec - "Layout specific. Set the layout spec describing where the receiver should appear in a proportional layout" - self layoutSpec == aLayoutSpec ifTrue: [ ^self ]. - aLayoutSpec morph: self. - layoutSpec := aLayoutSpec. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]! - -Smalltalk removeClassNamed: #EllipseMorph! - -!classRemoval: #EllipseMorph stamp: 'Install-4411-KernelMorphsReorganization-JuanVuletich-2020Oct15-09h03m-jmv.001.cs.st 10/15/2020 19:33:11'! -BorderedRectMorph subclass: #EllipseMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Basic'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4411-KernelMorphsReorganization-JuanVuletich-2020Oct15-09h03m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4411] on 15 October 2020 at 9:20:32 am'! - -"Change Set: 4412-ChangePastUpMorphSuperclass-JuanVuletich-2020Oct15-19h03m-jmv.001.cs.st -Date: 15 October 2020 -Author: Juan Vuletich - -Modifying class definition of core to Morphs is tricky. Hence this preamble." -| ui b cs | -Utilities authorInitialsPerSe ifNil: [ Utilities setAuthor ]. -(nil confirm: 'In order to modify instance definition of PasteUpMorph, -we need to restart the User Interface process. -You''ll need to do [Install New Updates] again, to install later updates.') ifFalse: [ self halt ]. -[ - ui _ UISupervisor ui. - UISupervisor stopUIProcess. - b _ ClassBuilder isSilent. - ClassBuilder beSilent: true. - ClassBuilder new - superclass: KernelMorph - subclass: #PasteUpMorph - instanceVariableNames: 'worldState backgroundImage backgroundImageData taskbar' - classVariableNames: 'WindowEventHandler' - poolDictionaries: '' - category: 'Morphic-Kernel'. - ClassBuilder beSilent: b. - UISupervisor spawnNewMorphicProcessFor: ui. - (Delay forSeconds: 1) wait. - ChangeSet installing: '4412-ChangePastUpMorphSuperclass-JuanVuletich-2020Oct15-19h03m-jmv.001.cs.st' do: []. - cs _ ChangeSet changeSetForBaseSystem. - (cs name beginsWith: '4412') ifTrue: [ - ChangeSet removeChangeSet: cs ]. - 'Done updating superclass of PasteUpMorph.' print. - 'Installed ChangeSet: 4412-ChangePastUpMorphSuperclass-JuanVuletich-2020Oct15-19h03m-jmv.001.cs.st' print. - 'Please do [Install New Updates] again.' print. -] forkAt: 41! - -'From Cuis 5.0 [latest update: #4412] on 15 October 2020 at 9:31:49 am'! - -Object subclass: #DropFilesAction - instanceVariableNames: 'dropFilesEvent selectedFileEntry shouldAskToStop stopHereBlock' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -!classDefinition: #DropFilesAction category: #'Morphic-Kernel' stamp: 'Install-4413-AdditionalMorphReorganization-JuanVuletich-2020Oct15-09h30m-jmv.001.cs.st 10/15/2020 19:33:18'! -Object subclass: #DropFilesAction - instanceVariableNames: 'dropFilesEvent selectedFileEntry shouldAskToStop stopHereBlock' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -Object subclass: #WorldState - instanceVariableNames: 'hands viewBox canvas damageRecorder stepList lastStepTime lastStepMessage lastCycleTime alarms lastAlarmTime remoteServer drawingFailingMorphs waitDelay pause lastCycleHadAnyEvent activeHand world' - classVariableNames: 'DeferredUIMessages' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -!classDefinition: #WorldState category: #'Morphic-Kernel' stamp: 'Install-4413-AdditionalMorphReorganization-JuanVuletich-2020Oct15-09h30m-jmv.001.cs.st 10/15/2020 19:33:18'! -Object subclass: #WorldState - instanceVariableNames: 'hands viewBox canvas damageRecorder stepList lastStepTime lastStepMessage lastCycleTime alarms lastAlarmTime remoteServer drawingFailingMorphs waitDelay pause lastCycleHadAnyEvent activeHand world' - classVariableNames: 'DeferredUIMessages' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -Smalltalk removeClassNamed: #BorderedRectMorph! - -!classRemoval: #BorderedRectMorph stamp: 'Install-4413-AdditionalMorphReorganization-JuanVuletich-2020Oct15-09h30m-jmv.001.cs.st 10/15/2020 19:33:18'! -KernelMorph subclass: #BorderedRectMorph - instanceVariableNames: 'borderWidth borderColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - -SystemOrganization removeSystemCategory: 'Morphic-Basic'. -SystemOrganization removeSystemCategory: 'Morphic-Worlds'.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4413-AdditionalMorphReorganization-JuanVuletich-2020Oct15-09h30m-jmv.001.cs.st----! - -----SNAPSHOT----(15 October 2020 19:33:22) Cuis5.0-4413-32.image priorSource: 6724743! - -----STARTUP---- (24 October 2020 17:29:12) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4413-32.image! - - -'From Cuis 5.0 [latest update: #4360] on 15 October 2020 at 10:24:51 am'! -!ReturnNode methodsFor: 'testing' stamp: 'FGJ 10/15/2020 10:19:23' prior: 50443687! - isImplicitSelfReturnIn: aMethodNode - - self isReturnSelf ifFalse: [^false]. - aMethodNode encoder rangeForNode: self ifAbsent: [^true]. - - ^false! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4414-CuisCore-FernandoGasperiJabalera-2020Oct15-10h19m-FGJ.001.cs.st----! - -'From Cuis 5.0 [latest update: #4414] on 22 October 2020 at 3:50:04 pm'! -!SystemDictionary methodsFor: 'code authors' stamp: 'db 10/22/2020 15:49:32' prior: 50539925! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('AY' 'Angel Yan') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('bgs' 'Boris G. Shingarov') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('db' 'Douglas Brebner') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('EB' 'Eric Brandwein') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('FGJ' 'Fernando Gasperi Jabalera') - #('FJG' 'Facundo Javier Gelatti') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hlsf' 'Hilaire Fernandes') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('KLG' 'Gerald Klix') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MM' 'Mariano Montone') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('pmon' 'Paolo Montrasi') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('sjd' 'Santiago Jose Dandois') - #('SLD' 'Steve Davies') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('ss' 'Sebastian Sujarchuk') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tsl' 'Thiago da Silva Lino') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4415-AddDouglasBrebnerAsKnownAuthor-DouglasBrebner-2020Oct22-15h49m-db.001.cs.st----! - -'From Cuis 5.0 [latest update: #4415] on 23 October 2020 at 12:44:10 pm'! -!LabelMorph methodsFor: 'font' stamp: 'KenD 10/23/2020 08:09:09' prior: 16918193! - emphasis: aNumber - "Set the receiver's emphasis as indicated. aNumber is a bitmask with the following format: - - bit attribute - 1 bold - 2 italic - 4 underlined - 8 struckThrough - 16 withUnderscoreGlyphs - " - - "examples: 0 -> plain. - 1 -> bold. 2 -> italic. 3 -> bold italic. 4 -> underlined - 5 -> bold underlined. 6 -> italic underlined. 7 -> bold italic underlined - etc... - - Prefer AbstractFont method category: 'derivatives - emphasis' - to raw numbers: - self emphasis: AbstractFont boldItalic. - etc." - - emphasis _ aNumber. - ^ self font: font emphasis: emphasis! ! -!LabelMorph methodsFor: 'geometry' stamp: 'KenD 10/16/2020 14:43:51' prior: 16918273 overrides: 50499535! - minimumExtent - - ^ self measureContents + (2 * self borderWidth)! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4416-LabelMorph-Tweaks-KenDickey-2020Oct23-12h42m-KenD.001.cs.st----! - -'From Cuis 5.0 [latest update: #4416] on 23 October 2020 at 4:14:51 pm'! - -LayoutMorph subclass: #StringRequestMorph - instanceVariableNames: 'response acceptBlock cancelBlock validationBlock ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Composite Widgets'! - -!classDefinition: #StringRequestMorph category: 'Morphic-Composite Widgets' stamp: 'Install-4417-StringRequestMorph-Resizeable-JuanVuletich-2020Oct23-16h05m-jmv.001.cs.st 10/24/2020 17:29:16'! -LayoutMorph subclass: #StringRequestMorph - instanceVariableNames: 'response acceptBlock cancelBlock validationBlock' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Composite Widgets'! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 10/23/2020 15:37:44' prior: 50520104! - layoutBounds - "Return the bounds for laying out children of the receiver" - - ^ self morphLocalBounds insetBy: borderWidth! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'jmv 10/23/2020 16:06:31' prior: 50538123! - addTextPane - | result | - result _ (TextModelMorph - textProvider: self - textGetter: #response - textSetter: #response: - selectionGetter: #selectionInterval) emptyTextDisplayMessage: 'Enter response'. - self - valueOfProperty: #emptyTextDisplayMessage - ifPresentDo: [ :msg | - result emptyTextDisplayMessage: msg ]. - result - hasUnacceptedEdits: true; - acceptOnCR: true; - escAction: [ self cancel ]. - self addMorph: result layoutSpec: LayoutSpec useAll.! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'jmv 10/23/2020 16:14:23' prior: 50547890! - addTitle: aString - | titleMorph s pp w | - titleMorph _ WidgetMorph new noBorder. - titleMorph color: Theme current menuTitleBar. - pp _ `8@2`. - aString asString linesDo: [ :line | - s _ LabelMorph new - contents: line; - font: Preferences standardMenuFont bold. - titleMorph addMorphBack: s position: pp. - pp _ pp + (0@(s morphHeight+2)) ]. - w _ titleMorph submorphs inject: 0 into: [ :prev :each | - prev max: each morphWidth ]. - titleMorph morphExtent: (w + 24) @ (pp y). - self addMorphKeepMorphHeight: titleMorph. - ^titleMorph morphWidth! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'jmv 10/23/2020 15:45:59' prior: 50513756 overrides: 50547033! - defaultBorderWidth - "answer the default border width for the receiver" - ^ 5! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'jmv 10/23/2020 16:14:08' prior: 50513791! - setQuery: queryString initialAnswer: initialAnswer - | lineCount newExtent w | - response _ initialAnswer. - w _ self addTitle: queryString. - self addTextPane. - "If the initial response is big or has multiple lines we make the text pane bigger and with scrollbars:" - lineCount _ response lineCount. - newExtent _ lineCount > 1 - ifTrue: [ 40 @ (lineCount*2) * FontFamily defaultLineSpacing ] - ifFalse: [ (response size max: 12) @ 3.2 * FontFamily defaultLineSpacing ]. - self morphExtent: (newExtent max: w@0)! ! -!StringRequestMorph class methodsFor: 'instance creation' stamp: 'jmv 10/23/2020 15:32:25' prior: 50513858! - request: queryString centeredAt: aPoint initialAnswer: defaultAnswer validationBlock: validationBlock acceptBlock: acceptBlock cancelBlock: cancelBlock - | answer | - answer _ self newColumn - setQuery: queryString - initialAnswer: defaultAnswer; - validationBlock: validationBlock; - acceptBlock: acceptBlock; - cancelBlock: cancelBlock. - self runningWorld addMorph: answer centeredNear: aPoint - self deltaToTextPane. - ^ answer! ! -!StringRequestMorph class methodsFor: 'instance creation' stamp: 'jmv 10/23/2020 15:32:30' prior: 50544558 overrides: 50515282! - request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock - - | morph world | - - morph _ self newColumn - setQuery: queryString - initialAnswer: defaultAnswer. - (world _ self runningWorld) addMorph: morph centeredNear: world activeHand morphPosition - self deltaToTextPane. - - ^ morph getUserResponseOrCancel: cancelBlock! ! -!StringRequestMorph class methodsFor: 'private' stamp: 'jmv 10/23/2020 15:54:06' prior: 50519923! - deltaToTextPane - "Answer a distance to translate an instance of the receiver by when it is opened in the world in order to have the hand be over the text pane (so the text pane has focus). - Distance is relative to font size" - | e | - e _ Preferences windowTitleFont lineSpacing. - ^ (0)@(0.5 * e)! ! - -StringRequestMorph removeSelector: #intoWorld:! - -!methodRemoval: StringRequestMorph #intoWorld: stamp: 'Install-4417-StringRequestMorph-Resizeable-JuanVuletich-2020Oct23-16h05m-jmv.001.cs.st 10/24/2020 17:29:16'! -intoWorld: aWorld - "The receiver has just appeared in a new world. Note: - * aWorld can be nil (due to optimizations in other places) - * owner is already set - * owner's submorphs may not include receiver yet. - Important: Keep this method fast - it is run whenever morphs are added." - super intoWorld: aWorld. - self adjustSubmorphsLayout. -"this doesnt work: aWorld ifNotNil: [aWorld activeHand newKeyboardFocus: textPane]"! - -StringRequestMorph removeSelector: #adjustSubmorphsLayout! - -!methodRemoval: StringRequestMorph #adjustSubmorphsLayout stamp: 'Install-4417-StringRequestMorph-Resizeable-JuanVuletich-2020Oct23-16h05m-jmv.001.cs.st 10/24/2020 17:29:16'! -adjustSubmorphsLayout - "Enlarge the width of submorphs as needed - so all of them are have the same width, and no less than #minWidth. - Also adjust their vertical position. - Finally, set our own extent." - - | w p h | - - submorphs isEmpty ifTrue: [ ^self ]. - w _ submorphs inject: 0 into: [ :prev :each | - prev max: each minItemWidth]. - - w _ w + 1. - p _ `5 @ 5`. - submorphs do: [ :m | - h _ m morphHeight. - m morphPosition: p extent: w@h. - p _ p + (0@(h + 1)) ]. - - self morphExtent: w+4 @ p y + 5! - -LayoutMorph subclass: #StringRequestMorph - instanceVariableNames: 'response acceptBlock cancelBlock validationBlock' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Composite Widgets'! - -!classDefinition: #StringRequestMorph category: 'Morphic-Composite Widgets' stamp: 'Install-4417-StringRequestMorph-Resizeable-JuanVuletich-2020Oct23-16h05m-jmv.001.cs.st 10/24/2020 17:29:16'! -LayoutMorph subclass: #StringRequestMorph - instanceVariableNames: 'response acceptBlock cancelBlock validationBlock' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Composite Widgets'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4417-StringRequestMorph-Resizeable-JuanVuletich-2020Oct23-16h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4414] on 21 October 2020 at 3:03:43 pm'! -!Morph commentStamp: 'jmv 10/21/2020 14:49:13' prior: 50537514! - A Morph (from the Greek "shape" or "form") is an interactive graphical object. General information on the Morphic system can be found at http://wiki.squeak.org/squeak/morph. - -Morphs exist in a tree, rooted at a World (a WorldMorph). The morphs owned by a morph are its submorphs. Morphs are drawn recursively; if a Morph has no owner it never gets -drawn. To hide a Morph and its submorphs, send the #visible: message. - -Every morph has a local coordinate system to interpret positions. -Local coordinates are used in the #drawOn: method (the Canvas understands positions in the local coordinate system), for the positions of submorphs (for example #morphPosition and #morphPosition:) and for positions carried by mouse events. - -Events are delivered to morphs in Z-order, i.e. if a morph occludes another the event is only delivered to the foremost (just like physical objects). Events received by a morph carry positions in the local coordinate system. - -Morphs can be translated by an offset, rotated around their center, orbited (rotated around the owner center), and zoomed (i.e. scaled). - -Every morph has an associated transformation that defines the inner space where the morph is drawn and where the submorphs live. These transformations don't change anything from the internal point of view of the morph. - -Structure: -instance var Type Description -owner Morph My parent Morph, or nil for the top-level Morph, which is a - or nil world, typically a PasteUpMorph. -submorphs Array My child Morphs. -location GeometryTransformation Specifies position (and possibly, angle of rotation and scale change) inside owner - See comment at GeometryTransformation! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 15:01:06'! - orbitBy: radians - "Change the scale of this morph. Arguments are an angle and a scale." - location _ (AffineTransformation withRadians: radians) composedWith: location. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 14:56:59' prior: 50545265! - rotation: radians - "Change the rotation of this morph. Argument is an angle to be taken as the new rotation." - - self rotation: radians scale: location scale.! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 14:56:28' prior: 50535332! - rotation: radians scale: scale - "Change the rotation and scale of this morph. Arguments are an angle and a scale." - location _ location withRotation: radians scale: scale. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4418-MorphTweaks-JuanVuletich-2020Oct21-14h49m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4414] on 21 October 2020 at 4:20:37 pm'! - -Smalltalk renameClassNamed: #PasteUpMorph as: #OldPasteUpMorph! - -!classRenamed: #PasteUpMorph as: #OldPasteUpMorph stamp: 'Install-4419-RenamePasteUpMorphAsOldPasteUpMorph-JuanVuletich-2020Oct21-16h20m-jmv.001.cs.st 10/24/2020 17:29:16'! -Smalltalk renameClassNamed: #PasteUpMorph as: #OldPasteUpMorph! -!SystemDictionary methodsFor: 'shrinking' stamp: 'jmv 10/21/2020 16:20:05' prior: 50476068! - reduceCuis - " - Smalltalk reduceCuis - " - | keep n unused newDicts oldDicts | - - self nominallyUnsent: #reduceCuis. - - "Remove icons" - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - OldPasteUpMorph allInstancesDo: [ :w | - w backgroundImageData: nil. - w submorphsDo: [ :a | a delete ]]. - Preferences useNoMenuIcons. - Theme current initialize. - Theme content: nil. - Color shutDown. - BitBltCanvas releaseClassCachedState. - - Transcript clear. - Clipboard default initialize. - - - "Remove some methods, even if they have senders." - Utilities removeSelector: #vmStatisticsReportString. - SystemDictionary removeSelector: #recreateSpecialObjectsArray. - - StrikeFont saveSpace. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - - keep := OrderedCollection new. - keep addAll: #(SpaceTally DynamicTypingSmalltalkCompleter). - AppLauncher appGlobalName ifNotNil: [ :any | - keep add: any ]. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - [ - #hereWeGo print. - unused do: [:c | - c print. - (Smalltalk at: c) removeFromSystem]. - n := Smalltalk removeAllUnSentMessages. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - n > 0 or: [ - unused notEmpty ]] whileTrue. - ChangeSet zapAllChangeSets. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - Symbol rehash. - - "Shrink method dictionaries." - Smalltalk garbageCollect. - oldDicts _ MethodDictionary allInstances. - newDicts _ Array new: oldDicts size. - oldDicts withIndexDo: [:d :index | - newDicts at: index put: d rehashWithoutBecome ]. - oldDicts elementsExchangeIdentityWith: newDicts. - oldDicts _ newDicts _ nil. - - SmalltalkCompleter initialize . - - "Sanity checks" -" Undeclared - Smalltalk cleanOutUndeclared - Smalltalk browseUndeclaredReferences - Smalltalk obsoleteClasses - Smalltalk obsoleteBehaviors - Smalltalk browseObsoleteMethodReferences - SmalltalkImage current fixObsoleteReferences - Smalltalk browseAllUnimplementedCalls"! ! -!Morph methodsFor: 'testing' stamp: 'jmv 10/21/2020 16:20:05' prior: 50500233! - isOwnedByWorld - ^owner is: #OldPasteUpMorph! ! -!OldPasteUpMorph methodsFor: 'testing' stamp: 'jmv 10/21/2020 16:20:05' prior: 50500237 overrides: 16876981! - is: aSymbol - ^ aSymbol == #OldPasteUpMorph or: [ super is: aSymbol ]! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 10/21/2020 16:20:05' prior: 50540751! - activeSubclass: aMorphicCanvasSubclass - ActiveSubclass _ aMorphicCanvasSubclass. - OldPasteUpMorph allInstancesDo: [ :w | w setCanvas ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4419-RenamePasteUpMorphAsOldPasteUpMorph-JuanVuletich-2020Oct21-16h20m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4416] on 21 October 2020 at 5:18:31 pm'! - -KernelMorph subclass: #PasteUpMorph - instanceVariableNames: 'backgroundImage backgroundImageData' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -!classDefinition: #PasteUpMorph category: #'Morphic-Kernel' stamp: 'Install-4420-NewPasteUpMorphAndWorldMorph-JuanVuletich-2020Oct21-17h15m-jmv.001.cs.st 10/24/2020 17:29:16'! -KernelMorph subclass: #PasteUpMorph - instanceVariableNames: 'backgroundImage backgroundImageData' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! -!PasteUpMorph commentStamp: 'jmv 2/21/2016 18:32' prior: 0! - A World, the entire Smalltalk screen, is a PasteUpMorph. A World responds true to isWorld. A PasteUpMorph that is a world, builds its menu in HandMorph buildWorldMenu. - -worldState If I am also a World, keeps the hands, damageRecorder, stepList etc. -! - -PasteUpMorph subclass: #WorldMorph - instanceVariableNames: 'activeHand hands canvas damageRecorder stepList lastCycleTime alarms lastAlarmTime deferredUIMessages drawingFailingMorphs waitDelay pause lastCycleHadAnyEvent taskbar' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -!classDefinition: #WorldMorph category: #'Morphic-Kernel' stamp: 'Install-4420-NewPasteUpMorphAndWorldMorph-JuanVuletich-2020Oct21-17h15m-jmv.001.cs.st 10/24/2020 17:29:16'! -PasteUpMorph subclass: #WorldMorph - instanceVariableNames: 'activeHand hands canvas damageRecorder stepList lastCycleTime alarms lastAlarmTime deferredUIMessages drawingFailingMorphs waitDelay pause lastCycleHadAnyEvent taskbar' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! -!WorldMorph commentStamp: '' prior: 0! - A WorldMorph is a kind of PasteUpMorph that can act as the root morph of a Morphic system. Usually uses the whole Display. - -activeHand -- a HandMorph -hands -- Array of HandMorphs (typically only one) representing the Cursor and its event queue. -canvas -- BitBlitCanvas on the DisplayScreen. (Display getCanvas) -damageRecorder -- the DamageRecorder for the Display -stepList -- a Heap of StepMessage. Each morph which wants stepping has a StepMessage here. - See comment in #Morph>>stepAt: -lastStepTime -- 'now' as last sampled at step. (Time localMillisecondClock) -lastStepMessage -- nil or a selector -lastCycleTime -- 'now' as last sampled (Time localMillisecondClock) -alarms -- a Heap of MorphicAlarm. See comment in #Morph>>addAlarm:after: - An _alarm_ is an action to be done once, vs a _step_ which is cycled. -lastAlarm -- 'now' as sampled at last alarm (Time localMillisecondClock). -drawingFailureMorphs -- a WeakIdentitySet of Morphs with drawing failures -waitDelay -- a Delay (set in #WorldState>>doOneCycleFor:) -pause -- A 'phase-locked loop' style value to help regularise the step/alarm/event service rate. - (set in #WorldState>>doOneCycleFor:) -lastCycleHadAnyEvent -- a boolean (set in #WorldState>>doOneCycleFor:) -world -- a PasteUpMorph -! -!PasteUpMorph methodsFor: 'accessing' stamp: 'jmv 10/21/2020 16:24:51' overrides: 16882824! - activeHand - "Answer the currently active hand, if any..." - ^self world ifNotNil: [ :w | w activeHand ]! ! -!PasteUpMorph methodsFor: 'accessing' stamp: 'jmv 11/19/2010 13:56' overrides: 16899189! - color: aColor - super color: aColor. - self backgroundImageData: nil! ! -!PasteUpMorph methodsFor: 'accessing' stamp: 'GC 3/17/2019 08:16:08' overrides: 16874712! -handlesKeyboard - - ^ true ! ! -!PasteUpMorph methodsFor: 'caching' stamp: 'jmv 10/21/2020 16:44:28' overrides: 50510070! - releaseCachedState - super releaseCachedState. - backgroundImage _ nil.! ! -!PasteUpMorph methodsFor: 'change reporting' stamp: 'jmv 1/16/2017 09:56:14' overrides: 16874142! - addedMorph: aMorph - "Notify the receiver that the given morph was just added." - super addedMorph: aMorph. - self taskbar ifNotNil: [ :tb | - tb wasOpened: aMorph ]! ! -!PasteUpMorph methodsFor: 'change reporting' stamp: 'jmv 1/16/2017 09:56:07' overrides: 16876964! - removedMorph: aMorph - "Notify the receiver that aMorph was just removed from its children" - super removedMorph: aMorph. - self taskbar ifNotNil: [ :tb | - tb wasDeleted: aMorph ]! ! -!PasteUpMorph methodsFor: 'drawing' stamp: 'jmv 10/21/2020 16:40:25' overrides: 16899205! - drawOn: aCanvas - - "draw background image." - backgroundImage - ifNotNil: [ - aCanvas image: backgroundImage at: `0@0` ] - ifNil: [ - super drawOn: aCanvas ]! ! -!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'HAW 12/24/2018 07:13:56' overrides: 50424799! - allowsFilesDrop - - ^ true! ! -!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'jmv 1/19/2013 15:24' overrides: 16874692! - allowsMorphDrop - "Answer whether we accept dropping morphs. By default answer false." - - ^ true! ! -!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'jmv 1/19/2013 15:25' overrides: 16874701! - allowsSubmorphDrag - "Answer whether our morphs can just be grabbed with the hand, instead of requiring the use of the halo. By default answer false. - Both 'aMorph allowsGrabWithHand' and 'aMorph owner allowsSubmorphDrag' must be true for aMorph to be grabbed by the hand. It is also required that 'aMorph handlesMouseDown:' be false." - - ^ true! ! -!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'HAW 12/24/2018 10:27:39' overrides: 50424793! - dropFiles: aDropFilesEvent - - (DropFilesAction for: aDropFilesEvent) value! ! -!PasteUpMorph methodsFor: 'events' stamp: 'jmv 10/28/2019 18:13:11' overrides: 50449239! - keyStroke: aKeyboardEvent - "Handle a keystroke event." - (aKeyboardEvent commandAltKeyPressed or: [ aKeyboardEvent controlKeyPressed ]) - ifTrue: [ - aKeyboardEvent keyCharacter = $b ifTrue: [ BrowserWindow openBrowser ]. - aKeyboardEvent keyCharacter = $f ifTrue: [ BrowserWindow findClass ]. - aKeyboardEvent keyCharacter = $F ifTrue: [ MessageSetWindow findInSourceCode ]. - ]. - "aKeyboardEvent keyCharacter print." - ^ super keyStroke: aKeyboardEvent! ! -!PasteUpMorph methodsFor: 'events' stamp: 'jmv 1/18/2013 12:38' overrides: 16874541! -mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - "Handle a mouse down event." - - super mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition. - - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: #click:localPosition: - clkNHalf: nil - dblClkSel: #doubleClick:localPosition: - dblClkNHalfSel: nil - tripleClkSel: nil! ! -!PasteUpMorph methodsFor: 'events' stamp: 'jmv 10/21/2020 15:41:41' overrides: 16874682! - windowEvent: aMorphicEvent - - aMorphicEvent windowEventType == #windowClose - ifTrue: [ - ^TheWorldMenu basicNew quitSession] -! ! -!PasteUpMorph methodsFor: 'event handling testing' stamp: 'jmv 8/20/2012 18:56' overrides: 16874721! - handlesMouseDown: aMouseButtonEvent - ^true! ! -!PasteUpMorph methodsFor: 'event handling' stamp: 'jmv 3/10/2011 16:02' overrides: 16874769! - mouseButton2Activity - - ^self invokeWorldMenu! ! -!PasteUpMorph methodsFor: 'event handling' stamp: 'jmv 10/21/2020 16:48:08'! - wantsWindowEvent: anEvent - ^false! ! -!PasteUpMorph methodsFor: 'geometry' stamp: 'jmv 5/24/2020 10:07:38' overrides: 16875287! - fontPreferenceChanged - self submorphsDo: [ :m | - m morphExtent: (m morphExtent max: m minimumExtent). - m fontPreferenceChanged ]! ! -!PasteUpMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 16:33:43' overrides: 16899309! - privateExtent: newExtent - - ^ (super privateExtent: newExtent) - ifTrue: [ self buildMagnifiedBackgroundImage ]; - yourself! ! -!PasteUpMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 20:58:35'! - defaultBorderColor - "answer the default border color/fill style for the receiver" - ^ `Color - r: 0.861 - g: 1.0 - b: 0.722`! ! -!PasteUpMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:38'! - defaultBorderWidth - "answer the default border width for the receiver" - ^ 1! ! -!PasteUpMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 20:58:44' overrides: 50387680! - defaultColor - "answer the default color/fill style for the receiver" - ^ `Color - r: 0.8 - g: 1.0 - b: 0.6`! ! -!PasteUpMorph methodsFor: 'interaction loop' stamp: 'jmv 8/17/2020 13:41:37'! - mainLoop - - - self clearWaitDelay. - self setCanvas. - [ - self doOneCycle. - Processor yield. - true ] - whileTrue: []! ! -!PasteUpMorph methodsFor: 'interaction loop' stamp: 'HAW 12/26/2019 10:05:45'! - runProcess - - | process | - - process _ [ self mainLoop ] newProcess. - process - priority: Processor userSchedulingPriority; - name: 'Morphic UI'; - animatedUI: self. - - ^ process! ! -!PasteUpMorph methodsFor: 'menu & halo' stamp: 'jmv 1/19/2013 15:14'! - addWorldHaloMenuItemsTo: aMenu hand: aHandMorph - "Add standard halo items to the menu, given that the receiver is a World" - - | unlockables | - self addColorMenuItems: aMenu hand: aHandMorph. - -" aMenu addLine. - self addWorldToggleItemsToHaloMenu: aMenu." - aMenu addLine. - self addCopyItemsTo: aMenu. - self addExportMenuItems: aMenu hand: aHandMorph. - - self addDebuggingItemsTo: aMenu hand: aHandMorph. - - aMenu addLine. - aMenu defaultTarget: self. - - aMenu addLine. - - unlockables _ self submorphs select: - [ :m | m isLocked]. - unlockables size = 1 ifTrue: [ - aMenu add: ('unlock "{1}"' format:{unlockables first printStringLimitedTo: 40})action: #unlockContents]. - unlockables size > 1 ifTrue: [ - aMenu add: 'unlock all contents' action: #unlockContents. - aMenu add: 'unlock...' action: #unlockOneSubpart]. - - aMenu defaultTarget: aHandMorph. -! ! -!PasteUpMorph methodsFor: 'misc' stamp: 'jmv 3/2/2011 11:10'! - backgroundImage - ^backgroundImage! ! -!PasteUpMorph methodsFor: 'misc' stamp: 'jmv 12/8/2013 15:11'! - backgroundImageData: aByteArray - " - | filename | - filename _ 'bg/free-3d-art-pictures-gallery-wallpaper-desktop-18.jpg'. - filename _ 'bg/free-desktop-wallpaper.jpg'. - filename _ 'bg/jellyfish-thumb.jpg'. - filename _ 'bg/splash_by_beefpepsi.jpg'. - filename _ 'bg/gray ocean and pier.jpg'. - filename _ 'bg/newyork.jpg'. - filename _ 'bg/download-free-desktop-wallpaper-nature-conquestofparadise-marirs-pic.jpg'. - filename _ 'bg/desktop-wallpaper-tropical-1280x1024.jpg'. - - filename _ 'bg/free-3d-art-pictures-gallery-wallpaper-desktop-18.jpg'. - self runningWorld backgroundImageData: (FileStream readOnlyFileNamed: filename) binary contentsOfEntireFile. - " - backgroundImageData _ aByteArray. - self buildMagnifiedBackgroundImage! ! -!PasteUpMorph methodsFor: 'misc' stamp: 'jmv 10/21/2020 16:30:09'! - buildMagnifiedBackgroundImage - | image old | - old _ backgroundImage. - backgroundImageData - ifNil: [ backgroundImage _ nil ] - ifNotNil: [ - [image _ Form fromBinaryStream: backgroundImageData readStream. - backgroundImage _ image magnifyTo: extent. - ] on: Error do: [backgroundImage := nil]. "Can happen if JPEG plugin not built" - ]. - old == backgroundImage ifFalse: [ - self redrawNeeded ]! ! -!PasteUpMorph methodsFor: 'stepping and presenter' stamp: 'jmv 6/11/2012 09:59' overrides: 16876574! - wantsSteps - "Return true if the receiver wants to its #step or #stepAt: methods be run ALL THE TIME. - Morphs that send #startStepping and #stopStepping at appropriate times (i.e. when they are already in the world!!) don't need to answer true to this message. - jmv: Not really sure. Sub-world stepping needs some review." - - ^true! ! -!PasteUpMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 7/23/2020 14:47:46'! - addMorph: aMorph centeredNear: aPoint - "Add the given morph to this world, attempting to keep its center as close to the given point possible while also keeping the it entirely within the bounds of this world." - - | trialRect delta | - trialRect _ Rectangle center: aPoint extent: aMorph morphExtent. - delta _ trialRect amountToTranslateWithin: self displayBounds. - self addMorph: aMorph. - aMorph morphPositionInWorld: trialRect origin + delta.! ! -!PasteUpMorph methodsFor: 'testing' stamp: 'jmv 3/9/2020 10:13:47' overrides: 16876981! - is: aSymbol - ^ aSymbol == #PasteUpMorph or: [ super is: aSymbol ]! ! -!PasteUpMorph methodsFor: 'testing' stamp: 'jmv 10/21/2020 16:42:59' overrides: 16877003! - isReallyVisible - "Answer true only if all the owner chain is visible (i.e. if we are really visible!!)" - ^self visible and: [owner isReallyVisible ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 8/13/2013 09:17'! - bringWindowsFullOnscreen - "Make ever SystemWindow on the desktop be totally on-screen, whenever possible." - (SystemWindow - windowsIn: self - satisfying: [ :w | - w visible ]) do: [ :each | - each makeMeFullyVisible ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 8/13/2013 09:18'! - closeUnchangedWindows - "Present a menu of window titles for all windows with changes, - and activate the one that gets chosen." - (SelectionMenu confirm: 'Do you really want to close all windows -except those with unaccepted edits?') ifFalse: [ ^ self ]. - (SystemWindow - windowsIn: self - satisfying: [ :w | - w visible and: [ w canDiscardEdits ]]) do: [ :w | - w delete ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 1/24/2016 21:58'! - collapseNonWindows - self allNonWindowRelatedSubmorphs do: [ :m | - m collapse]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 1/24/2016 21:58'! - deleteNonWindows - (SelectionMenu confirm: -'Do you really want to discard all objects -that are not in windows?') - ifFalse: [^ self]. - - self allNonWindowRelatedSubmorphs do: [:m | - m delete ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 3/21/2012 17:23'! - findAChangeSorter: evt - "Locate a change sorter, open it, and bring it to the front. Create one if necessary" - self - findAWindowSatisfying: [ :aWindow | - aWindow model isMemberOf: ChangeSorter] - orMakeOneUsing: [ ChangeSorterWindow open: ChangeSorter new label: nil ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 7/4/2016 22:20'! - findAFileList: evt - "Locate a file list, open it, and bring it to the front. - Create one if necessary, respecting the Preference." - self - findAWindowSatisfying: [ :aWindow | - aWindow model class == FileList ] - orMakeOneUsing: [ - FileListWindow openFileList ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 7/4/2016 22:21'! - findAMessageNamesWindow: evt - "Locate a MessageNames tool, open it, and bring it to the front. Create one if necessary" - self - findAWindowSatisfying: [ :aWindow | - aWindow model class == MessageNames ] - orMakeOneUsing: [ - MessageNamesWindow open: MessageNames new label: 'Message Names' ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 7/30/2014 09:01'! - findATranscript: evt - "Locate a transcript, open it, and bring it to the front. Create one if necessary" - - self findATranscript! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 10/25/2010 21:29'! - findAWindowSatisfying: qualifyingBlock orMakeOneUsing: makeBlock - "Locate a window satisfying a block, open it, and bring it to the front. Create one if necessary, by using the makeBlock" - | aWindow | - submorphs do: [ :aMorph | - (((aWindow _ aMorph) is: #SystemWindow) and: [ qualifyingBlock value: aWindow ]) ifTrue: [ - aWindow isCollapsed ifTrue: [ aWindow expand ]. - aWindow activateAndForceLabelToShow. - ^ self ]]. - "None found, so create one" - makeBlock value.! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 7/5/2016 09:42'! - findDirtyBrowsers: evt - "Present a menu of window titles for browsers with changes, - and activate the one that gets chosen." - | menu | - menu _ MenuMorph new. - (SystemWindow - windowsIn: self - satisfying: [ :w | - w visible and: [ - (w model is: #CodeProvider) and: [ w canDiscardEdits not ]]]) do: [ :w | - menu - add: w label - target: w - action: #activate ]. - menu submorphs notEmpty ifTrue: [ menu popUpInWorld: self ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 8/13/2013 09:20'! - findDirtyWindows: evt - "Present a menu of window titles for all windows with changes, - and activate the one that gets chosen." - | menu | - menu _ MenuMorph new. - (SystemWindow - windowsIn: self - satisfying: [ :w | - w visible and: [ w canDiscardEdits not ]]) do: [ :w | - menu - add: w label - target: w - action: #activate ]. - menu submorphs notEmpty ifTrue: [ menu popUpInWorld: self ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 3/10/2018 22:02:53'! - findWindow: evt - "Present a menu names of windows and naked morphs, and activate the one that gets chosen. Collapsed windows appear below line, expand if chosen; naked morphs appear below second line; if any of them has been given an explicit name, that is what's shown, else the class-name of the morph shows; if a naked morph is chosen, bring it to front and have it don a halo." - | menu expanded collapsed nakedMorphs | - menu _ MenuMorph new. - expanded _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed not ]. - collapsed _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed ]. - nakedMorphs _ self submorphsSatisfying: [ :m | - (m is: #SystemWindow) not ]. - expanded isEmpty & (collapsed isEmpty & nakedMorphs isEmpty) ifTrue: [ ^ Smalltalk beep ]. - (expanded asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #activateAndForceLabelToShow. - w canDiscardEdits ifFalse: [ menu lastItem color: `Color red` ]]. - expanded isEmpty | (collapsed isEmpty & nakedMorphs isEmpty) ifFalse: [ menu addLine ]. - (collapsed asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #expand. - w canDiscardEdits ifFalse: [ menu lastItem color: `Color red` ]]. - nakedMorphs isEmpty ifFalse: [ menu addLine ]. - (nakedMorphs asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #comeToFrontAndAddHalo ]. - menu addTitle: 'find window'. - menu popUpInWorld: self! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'HAW 7/5/2018 18:24:37'! - invokeWorldMenu - "Put up the world menu, triggered by the passed-in event. - Perhaps a good place to disable it if needed" - - | menu | - menu _ (TheWorldMenu new - world: self - hand: self activeHand) buildWorldMenu. - menu addTitle: Preferences desktopMenuTitle. - menu popUpInWorld: self! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 1/8/2017 16:44:57'! - allNonWindowRelatedSubmorphs - "Answer all non-window submorphs that are not flap-related" - - ^submorphs - reject: [ :m | (m is: #SystemWindow) or: [ m is: #TaskbarMorph ] ]! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 2/28/2011 15:16'! - deleteAllHalos - self haloMorphs do: - [ :m | m delete]! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 9/13/2013 09:18'! -fullRepaintNeeded - self redrawNeeded. - SystemWindow - windowsIn: self - satisfying: [ :w | - w visible ifTrue: [ w makeMeVisible ]. - false ]! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'ar 9/28/2000 18:00'! - haloMorphs - ^ self hands collect:[:h| h halo] thenSelect:[:halo| halo notNil]! ! -!PasteUpMorph methodsFor: 'halos and balloon help' stamp: 'jmv 10/21/2020 16:46:33' overrides: 50537020! - wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph - "Answer whether the receiver would like to offer the halo handle with the given selector (e.g. #addCollapseHandle:)" - (#(addHelpHandle: addRotateHandle: addRecolorHandle:) statePointsTo: aSelector) - ifTrue: ["FIXME - hack to disable for non-functional halo items" - ^ false]. - - ^super wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph! ! -!PasteUpMorph methodsFor: 'object serialization' stamp: 'jmv 6/8/2014 18:28' overrides: 16876452! - objectForDataStream: refStrm - "I am about to be written on an object file. Write a path to me in the other system instead." - - | dp | - dp _ DiskProxy global: #Smalltalk selector: #runningWorld args: #(). - refStrm replace: self with: dp. - ^ dp! ! -!PasteUpMorph methodsFor: 'windows' stamp: 'jmv 7/30/2014 09:00'! - findATranscript - "Locate a transcript, open it, and bring it to the front. Create one if necessary" - - self - findAWindowSatisfying: [ :aWindow | aWindow model == Transcript] - orMakeOneUsing: [ TranscriptWindow openTranscript ]! ! -!PasteUpMorph methodsFor: 'ui services' stamp: 'jmv 5/23/2020 21:00:01' overrides: 50515282! - request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock - "This is deprecated because using it requires blocking the user interface until the user provides a response. Please use the variants that are not modal." - ^ StringRequestMorph request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock! ! -!PasteUpMorph methodsFor: 'ui services' stamp: 'jmv 5/23/2020 21:00:05' overrides: 50515295! - request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock - ^ StringRequestMorph request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock! ! -!PasteUpMorph class methodsFor: 'system startup' stamp: 'jmv 10/21/2020 16:49:47' overrides: 16784996! - initClassCachedState - "Should use some other way to find relevant instances" - self flag: #jmvVer2. - self allInstancesDo: [ :each | - each buildMagnifiedBackgroundImage ]. - Cursor defaultCursor activateCursor.! ! -!PasteUpMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:51:39' overrides: 50344178! - categoryInNewMorphMenu - ^ 'Worlds'! ! -!WorldMorph methodsFor: 'alarms' stamp: 'jmv 3/3/2017 09:33:59'! - addAlarm: aSelector withArguments: argArray for: aTarget at: scheduledTime - "Add a new alarm with the given set of parameters" - - alarms add: - (MorphicAlarm - receiver: aTarget - selector: aSelector - arguments: argArray - at: scheduledTime)! ! -!WorldMorph methodsFor: 'alarms' stamp: 'jmv 3/3/2017 09:34:03'! - adjustAlarmTimes: nowTime - "Adjust the alarm times after some clock weirdness (such as image-startup etc)" - | deltaTime | - deltaTime _ nowTime - lastAlarmTime. - alarms do: [ :alarm | - alarm scheduledTime: alarm scheduledTime + deltaTime ]! ! -!WorldMorph methodsFor: 'alarms' stamp: 'jmv 5/11/2016 09:53'! - alarmSortBlock - - ^[ :alarm1 :alarm2 | alarm1 scheduledTime < alarm2 scheduledTime ]! ! -!WorldMorph methodsFor: 'alarms' stamp: 'jmv 3/3/2017 11:54:00'! - removeAlarm: aSelector for: aTarget - "Remove the alarm with the given selector" - - | alarm | - alarm _ alarms - detect: [ :any | any receiver == aTarget and: [any selector == aSelector]] - ifNone: nil. - alarm ifNotNil: [ alarms remove: alarm ]! ! -!WorldMorph methodsFor: 'alarms' stamp: 'jmv 3/3/2017 09:35:03'! - triggerAlarmsBefore: nowTime - "Trigger all pending alarms that are to be executed before nowTime." - - nowTime - lastAlarmTime > 10000 - ifTrue: [ self adjustAlarmTimes: nowTime ]. - [ alarms notEmpty and: [ alarms first scheduledTime < nowTime ]] - whileTrue: [ alarms removeFirst valueAtTime: nowTime ]. - lastAlarmTime _ nowTime! ! -!WorldMorph methodsFor: 'canvas' stamp: 'di 6/7/1999 17:44'! - canvas - - ^ canvas! ! -!WorldMorph methodsFor: 'canvas' stamp: 'jmv 8/17/2020 13:42:46'! - clearCanvas - canvas _ nil. - damageRecorder _ nil.! ! -!WorldMorph methodsFor: 'canvas' stamp: 'jmv 10/21/2020 15:17:06'! - ensureNonDisplayCanvas - (canvas isNil or: [ - canvas drawsOnDisplay or: [ - (canvas extent ~= self morphExtent) or: [ - canvas form depth ~= Display depth]]]) ifTrue: [ - "allocate a new offscreen canvas the size of the window" - self setCanvas: (MorphicCanvas withExtent: self morphExtent depth: Display depth)]! ! -!WorldMorph methodsFor: 'canvas' stamp: 'jmv 8/4/2020 10:02:25'! - recordDamagedRect: damageRect for: aMorph - - damageRecorder ifNotNil: [ - damageRecorder recordInvalidRect: damageRect for: aMorph ]! ! -!WorldMorph methodsFor: 'canvas' stamp: 'jmv 10/21/2020 15:17:17'! - setCanvas - self setCanvas: Display getCanvas. - damageRecorder _ DamageRecorder new. - self redrawNeeded! ! -!WorldMorph methodsFor: 'canvas' stamp: 'jmv 10/21/2020 15:17:24'! - setCanvas: aMorphicCanvas - canvas _ aMorphicCanvas. - canvas world: self. - damageRecorder - ifNil: [ damageRecorder _ DamageRecorder new].! ! -!WorldMorph methodsFor: 'hands' stamp: 'jmv 9/25/2012 22:39' overrides: 50549027! - activeHand - ^activeHand! ! -!WorldMorph methodsFor: 'hands' stamp: 'di 6/7/1999 17:40'! - hands - - ^ hands! ! -!WorldMorph methodsFor: 'hands' stamp: 'RAA 5/24/2000 10:13'! - handsDo: aBlock - - ^ hands do: aBlock! ! -!WorldMorph methodsFor: 'hands' stamp: 'RAA 5/24/2000 12:09'! - handsReverseDo: aBlock - - ^ hands reverseDo: aBlock! ! -!WorldMorph methodsFor: 'hands' stamp: 'jmv 7/22/2020 20:42:49'! - selectHandsToDrawForDamage: damageList - "Select the set of hands that must be redrawn because either (a) the hand itself has changed or (b) the hand intersects some damage rectangle." - - | result | - result _ OrderedCollection new. - hands do: [:hand | - hand needsToBeDrawn ifTrue: [ - hand hasChanged - ifTrue: [result add: hand] - ifFalse: [ - hand displayFullBounds ifNotNil: [ :handBounds | - (damageList anySatisfy: [ :r | r intersects: handBounds]) ifTrue: [ - result add: hand]]]]]. - ^ result! ! -!WorldMorph methodsFor: 'initialization' stamp: 'jmv 6/20/2014 20:24:55'! - clearWaitDelay - waitDelay ifNotNil: [ - waitDelay unschedule. - waitDelay _ nil ]. - "Needed if for some reason Cuis is started with an earlier DateTime than the image was saved. - Might happen, especially on RasPi or other systems without an RTC" - lastCycleTime _ Time localMillisecondClock. - lastAlarmTime _ 0.! ! -!WorldMorph methodsFor: 'initialization' stamp: 'jmv 10/21/2020 16:05:30' overrides: 50384234! - initialize - - super initialize. - activeHand _ HandMorph new. - hands _ { activeHand }. - damageRecorder _ DamageRecorder new. - stepList _ Heap sortBlock: self stepListSortBlock. - alarms _ Heap sortBlock: self alarmSortBlock. - lastAlarmTime _ 0. - deferredUIMessages _ SharedQueue new. - drawingFailingMorphs _ WeakIdentitySet new. - pause _ 20. - lastCycleTime _ Time localMillisecondClock. - lastCycleHadAnyEvent _ false! ! -!WorldMorph methodsFor: 'initialization' stamp: 'jmv 2/2/2014 21:05'! - stepListSortBlock - - ^ [ :stepMsg1 :stepMsg2 | - stepMsg1 scheduledTime <= stepMsg2 scheduledTime ]! ! -!WorldMorph methodsFor: 'stepping' stamp: 'jmv 10/21/2020 15:16:15'! - cleanseStepList - "Remove morphs from the step list that are not in this World." - - | deletions | - deletions _ OrderedCollection new. - stepList do: [ :entry | - entry receiver world == self ifFalse: [ - deletions add: entry]]. - deletions do: [ :entry| - stepList remove: entry ]. - - deletions _ OrderedCollection new. - alarms do: [ :entry | - ((entry receiver is: #Morph) and: [ entry receiver world == self ]) ifFalse: [ - deletions add: entry]]. - deletions do: [ :entry| - alarms remove: entry ]! ! -!WorldMorph methodsFor: 'stepping' stamp: 'jmv 10/21/2020 15:35:50'! - runLocalStepMethods: nowTime - "Run morph 'step' methods (LOCAL TO THIS WORLD) whose time has come. Purge any morphs that are no longer in this world." - - | stepMessage | - [ stepList notEmpty and: [ stepList first scheduledTime <= nowTime ]] - whileTrue: [ - stepMessage _ stepList first. - (stepMessage receiver shouldGetStepsFrom: self) - ifFalse: [ stepList removeFirst ] - ifTrue: [ - stepMessage valueAtTime: nowTime. - stepMessage rescheduleAfter: nowTime. - "We've just updated the scheduled time for stepMessage. - It might have been that stepMessage was removed altogether from stepList. - It also may be the case that stepList got added or removed other elements while on #valueAtTime: - Just reSort. It will be ok in any case." - stepList reSort. - ] - ]! ! -!WorldMorph methodsFor: 'stepping' stamp: 'jmv 10/21/2020 15:34:17'! - runStepMethods - "Perform periodic activity inbetween event cycles" - | readyToProcess | - - "Processing the queue until empty is wrong if a block in it calls #addDeferredUIMessage: itself, because this loop will never end. - Instead, process no more than entries already in queue befor we start iterating!!" - readyToProcess _ deferredUIMessages size. - readyToProcess timesRepeat: [ - deferredUIMessages nextOrNil ifNotNil: [ :block | - block value - ] - ]. - self triggerAlarmsBefore: lastCycleTime. - self runLocalStepMethods: lastCycleTime. - - "we are using a normal #step for these now" - "aWorld allLowerWorldsDo: [ :each | each runLocalStepMethods ]." -! ! -!WorldMorph methodsFor: 'stepping' stamp: 'jmv 2/3/2014 21:15'! - startStepping: aMorph at: scheduledTime selector: aSelector stepTime: stepTimeOrNil - "Add the given morph to the step list" - - self stopStepping: aMorph selector: aSelector. - stepList add: ( - StepMessage - receiver: aMorph - selector: aSelector - at: scheduledTime - stepTime: stepTimeOrNil)! ! -!WorldMorph methodsFor: 'stepping' stamp: 'jmv 3/3/2017 11:39:34'! - stopStepping: aMorph selector: aSelector - "Remove the given morph from the step list." - stepList removeAll: (stepList select:[:stepMsg| stepMsg receiver == aMorph and: [ stepMsg selector == aSelector ]])! ! -!WorldMorph methodsFor: 'stepping' stamp: 'jmv 3/3/2017 11:39:22'! - stopSteppingMorph: aMorph - "Remove the given morph from the step list." - stepList removeAll: (stepList select: [ :stepMsg | stepMsg receiver == aMorph])! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'RAA 5/24/2000 13:13'! - checkIfUpdateNeeded - - damageRecorder updateIsNeeded ifTrue: [^true]. - hands do: [:h | (h hasChanged and: [h needsToBeDrawn]) ifTrue: [^true]]. - ^false "display is already up-to-date" -! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 10/21/2020 15:16:56'! - displayWorldSafely - "Update this world's display and keep track of errors during draw methods." - - [self displayWorld] ifError: [:err :rcvr | - "Handle a drawing error" - | errCtx errMorph | - errCtx _ thisContext. - [ - errCtx _ errCtx sender. - "Search the sender chain to find the morph causing the problem" - [errCtx notNil and: [ (errCtx receiver is: #Morph) not ]] - whileTrue:[errCtx _ errCtx sender]. - "If we're at the root of the context chain then we have a fatal drawing problem" - errCtx ifNil:[^self handleFatalDrawingError: err]. - errMorph _ errCtx receiver. - "If the morph causing the problem has already the #drawError flag set, - then search for the next morph above in the caller chain." - errMorph isKnownFailing - ] whileTrue. - errMorph drawingFails. - self setCanvas. - "Install the old error handler, so we can re-raise the error" - rcvr error: err. - ]! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 10/21/2020 15:33:56'! - doOneCycle - "Do one cycle of the interaction loop. This method is called repeatedly when the world is running. - - Make for low cpu usage if the ui is inactive, but quick response when ui is in use. - However, after some inactivity, there will be a larger delay before the ui gets responsive again." - - | wait waitUntil | - waitDelay ifNil: [ waitDelay _ Delay forMilliseconds: 50 ]. - lastCycleHadAnyEvent | deferredUIMessages isEmpty not - ifTrue: [ - pause _ 20. "This value will only be used when there are no more events to serve." - wait _ 0 ] "Don't wait" - ifFalse: [ - pause < 200 "No events processed? Start saving CPU!! But never make the user wait more than 200ms for being responsive again." - ifTrue: [ pause _ pause * 21//20 ]. - waitUntil _ lastCycleTime + pause. - "Earlier if steps" - stepList isEmpty not ifTrue: [ - waitUntil _ waitUntil min: stepList first scheduledTime ]. - "Earlier if alarms" - alarms ifNotNil: [ - alarms isEmpty not ifTrue: [ - waitUntil _ waitUntil min: alarms first scheduledTime ]]. - - wait _ waitUntil - Time localMillisecondClock ]. - Preferences serverMode - ifTrue: [ wait _ wait max: 50 ]. "Always wait at least a bit on servers, even if this makes the UI slow." - wait > 0 - ifFalse: [ Processor yield ] - ifTrue: [ - waitDelay beingWaitedOn - ifFalse: [ waitDelay setDelay: wait; wait ] - ifTrue: [ - "If we are called from a different process than that of the main UI, we might be called in the main - interCyclePause. In such case, use a new Delay to avoid 'This Delay has already been scheduled' errors" - (Delay forMilliseconds: wait) wait ]]. - - "Record start time of this cycle, and do cycle" - lastCycleTime _ Time localMillisecondClock. - lastCycleHadAnyEvent _ self doOneCycleNow! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 10/21/2020 16:04:46'! - doOneCycleNow - "Immediately do one cycle of the interaction loop. - Only used for a few tests." - "See #eventTickler" - | hadAnyEvent | - Cursor currentCursor = (Cursor cursorAt: #waitCursor) ifTrue: [ Cursor defaultCursor activateCursor ]. - "Repair visual damage." - DisplayScreen checkForNewScreenSize. - self displayWorldSafely. - "Run steps, alarms and deferred UI messages" - self runStepMethods. - "Process user input events. Run all event triggered code." - hadAnyEvent _ false. - self handsDo: [ :h | - activeHand _ h. - hadAnyEvent _ hadAnyEvent | h processEventQueue. - activeHand _ nil ]. - "The default is the primary hand" - activeHand _ self hands first. - ^ hadAnyEvent.! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 3/2/2017 20:06:48'! - doOneMinimalCycleNow - "Immediately do one cycle of the interaction loop. - Only repair display and process events. For modal menus and such." - - "Repair visual damage." - self displayWorldSafely. - - "Process user input events. Run all event triggered code." - ^activeHand processEventQueue! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 6/26/2015 14:36'! - handleFatalDrawingError: errMsg - "Handle a fatal drawing error." - - self primitiveError: - 'Fatal Morphic drawing error', String newLineString, - errMsg. - - "Hm... we should jump into a 'safe' WorldMorph here, but how do we find it?!!"! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 10/21/2020 15:17:28'! - tryDeferredUpdatingAndSetCanvas - "If this platform supports deferred updates, then make my canvas be the Display (or a rectangular portion of it), set the Display to deferred update mode, and answer true. Otherwise, set a non-Disply canvas and answer false.." - | properDisplay | - - "As this is the only sender of #deferUpdates: , this could be done in Morphic or image startup, and never efterwards..." - (Display deferUpdates: true) ifNil: [ - "deferred updates not supported by the VM, do them in the image!!" - self ensureNonDisplayCanvas. - ^ false]. - - "if no canvas, or canvas was offscreen, from a platform that didnt support defers, then fix it" - properDisplay _ canvas notNil and: [canvas drawsOnDisplay]. - properDisplay ifFalse: [ - self morphPosition: `0@0` extent: Display extent. - self setCanvas: Display getCanvas. - ]. - ^ true! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 10/21/2020 15:34:22' overrides: 50444405! - whenUIinSafeState: evaluableObject - "Please call - UISupervisor whenUIinSafeState: evaluableObject - " - deferredUIMessages nextPut: evaluableObject! ! -!WorldMorph methodsFor: 'errors on draw' stamp: 'jmv 11/5/2007 22:59'! - addKnownFailing: aMorph - drawingFailingMorphs add: aMorph! ! -!WorldMorph methodsFor: 'errors on draw' stamp: 'jmv 11/5/2007 22:59'! - isKnownFailing: aMorph - ^drawingFailingMorphs includes: aMorph! ! -!WorldMorph methodsFor: 'errors on draw' stamp: 'jmv 10/21/2020 15:54:35'! - removeAllKnownFailing - drawingFailingMorphs _ WeakIdentitySet new. - self redrawNeeded! ! -!WorldMorph methodsFor: 'errors on draw' stamp: 'jmv 11/5/2007 22:59'! -removeKnownFailing: aMorph - drawingFailingMorphs remove: aMorph! ! -!WorldMorph methodsFor: 'drawing' stamp: 'jmv 10/21/2020 17:06:37'! - displayWorld - "Update this world's display." - - | deferredUpdateVMMode worldDamageRects handsToDraw allDamage | - self checkIfUpdateNeeded ifFalse: [ ^ self ]. "display is already up-to-date" - "I (jmv) removed the call to 'deferUpdates: false' below. No more need to call this every time." - deferredUpdateVMMode _ self tryDeferredUpdatingAndSetCanvas. - - "repair world's damage on canvas" - worldDamageRects _ canvas drawWorld: self repair: damageRecorder. - - "Check which hands need to be drawn (they are not the hardware mouse pointer)" - handsToDraw _ self selectHandsToDrawForDamage: worldDamageRects. - allDamage _ Array streamContents: [ :strm | - strm nextPutAll: worldDamageRects. - handsToDraw do: [ :h | - h savePatchFrom: canvas appendDamageTo: strm ]]. - - "Draw hands (usually carying morphs) onto world canvas" - canvas newClipRect: nil. - handsToDraw reverseDo: [ :h | canvas fullDrawHand: h ]. - - "quickly copy altered rects of canvas to Display:" - deferredUpdateVMMode ifFalse: [ - "Drawing was done to off-Display canvas. Copy content to Display" - canvas showAt: self viewBox origin invalidRects: allDamage ]. - - "Display deferUpdates: false." - "Display forceDisplayUpdate" - Display forceDamageToScreen: allDamage. - - "Restore world canvas under hands and their carried morphs" - handsToDraw do: [ :h | h restoreSavedPatchOn: canvas ].! ! -!WorldMorph methodsFor: 'drawing' stamp: 'jmv 10/21/2020 16:41:02' overrides: 50549067! - drawOn: aCanvas - - "draw background image." - backgroundImage - ifNotNil: [ - aCanvas image: backgroundImage at: `0@0` ] - ifNil: [ - "draw background fill" - (aCanvas drawsOnDisplay and: [ color mightBeTranslucent ]) - ifTrue: [ - "Special case so a translucent background on the Display allows you to see through the main Cuis Window. - Requires proper handling of translucent Display in the VM. - Seems to work only on Linux when using a composing window manager." - (BitBlt toForm: Display) clipRect: aCanvas clipRect; - copy: Display boundingBox - from: `0@0` in: nil - fillColor: color rule: Form over. - Display forceToScreen] - ifFalse: [ super drawOn: aCanvas ]]! ! -!WorldMorph methodsFor: 'event handling' stamp: 'jmv 10/21/2020 16:48:04' overrides: 50549157! - wantsWindowEvent: anEvent - ^true! ! -!WorldMorph methodsFor: 'classification' stamp: 'jmv 10/21/2020 15:47:06' overrides: 16874177! - isWorldMorph - - ^ true! ! -!WorldMorph methodsFor: 'submorphs-accessing' stamp: 'jmv 10/21/2020 16:26:04' overrides: 16876668! - allMorphsDo: aBlock - "Enumerate all morphs in the world, including those held in hands." - - super allMorphsDo: aBlock. - self handsReverseDo: [:h | h allMorphsDo: aBlock].! ! -!WorldMorph methodsFor: 'submorphs-accessing' stamp: 'jmv 10/21/2020 16:31:21'! - canHandle: aMorph - - ^ canvas canDraw: aMorph! ! -!WorldMorph methodsFor: 'submorphs-accessing' stamp: 'jmv 10/21/2020 15:49:31'! -firstHand - - ^ hands first! ! -!WorldMorph methodsFor: 'change reporting' stamp: 'jmv 10/21/2020 15:50:52' overrides: 50541311! - invalidateDisplayRect: damageRect fromSubmorph: submorphOrNil for: aMorph - "Clip damage reports to my bounds, since drawing is _always_ clipped to my bounds." - - self recordDamagedRect: (damageRect intersect: self morphLocalBounds ) for: aMorph! ! -!WorldMorph methodsFor: 'testing' stamp: 'jmv 10/21/2020 16:43:17' overrides: 50549319! - isReallyVisible - "Answer true only if all the owner chain is visible (i.e. if we are really visible!!)" - ^self visible! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 16:39:39' overrides: 50537893! - displayBounds - ^0@0 extent: extent! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 16:41:28' overrides: 50463607! - externalizeDisplayBounds: r - - ^ r! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 16:41:55' overrides: 16875276! - externalizeToWorld: aPoint - "aPoint is in own coordinates. Answer is in world coordinates." - ^ aPoint! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 16:42:23' overrides: 16875326! - internalizeFromWorld: aPoint - "aPoint is in World coordinates. Answer is in own coordinates." - ^ aPoint! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 16:43:37' overrides: 50545047! - morphPositionInWorld - - self flag: #jmvVer2. "Solo para evitar los warning por falta de owner... pensar despues este caso" - ^ `0@0`! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 15:52:21' overrides: 50549169! - privateExtent: newExtent - - ^ (super privateExtent: newExtent) - ifTrue: [ - self setCanvas ]; - yourself! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 15:55:32'! - viewBox - - ^ self morphLocalBounds! ! -!WorldMorph methodsFor: 'caching' stamp: 'jmv 10/21/2020 15:54:07' overrides: 50549043! - releaseCachedState - super releaseCachedState. - self cleanseStepList. - self clearCanvas! ! -!WorldMorph methodsFor: 'structure' stamp: 'jmv 10/21/2020 15:56:00' overrides: 16876664! - world - ^self! ! -!WorldMorph methodsFor: 'misc' stamp: 'jmv 10/21/2020 16:29:57' overrides: 50549268! - buildMagnifiedBackgroundImage - super buildMagnifiedBackgroundImage. - - canvas ifNotNil: [ :c | - (backgroundImage depth = 32 and: [ c form depth < 32 ]) ifTrue: [ - backgroundImage _ backgroundImage orderedDither32To16 ]]! ! -!WorldMorph methodsFor: 'misc' stamp: 'jmv 10/21/2020 16:52:25'! - fillRects: rectangleList - "For testing. Flashes the given list of rectangles on the Display so you can watch incremental redisplay at work." - - - | blt screenRect | - blt _ (BitBlt toForm: Display) - sourceForm: nil; - sourceOrigin: `0@0`; - clipRect: self viewBox; - combinationRule: Form over. - - rectangleList do: [:r | - screenRect _ r translatedBy: self viewBox origin. - blt fillColor: Color random. - blt destRect: screenRect; copyBits. - Display forceToScreen: screenRect ]. - - (Delay forMilliseconds: 50) wait! ! -!WorldMorph methodsFor: 'misc' stamp: 'jmv 10/21/2020 16:36:53'! - restoreDisplay - self - morphExtent: Display extent; - handsDo: [ :h | h visible: true ]; - fullRepaintNeeded! ! -!WorldMorph methodsFor: 'menu & halo' stamp: 'jmv 10/21/2020 16:39:09' overrides: 16876144! - addCustomMenuItems: menu hand: aHandMorph - "Add morph-specific menu itemns to the menu for the hand" - - super addCustomMenuItems: menu hand: aHandMorph. - menu - add: 'desktop menu...' - target: self - action: #invokeWorldMenu. - menu addLine! ! -!WorldMorph methodsFor: 'printing' stamp: 'jmv 10/21/2020 16:44:07' overrides: 50500307! - printOn: aStream - "Reimplemented to add a tag showing that the receiver is currently functioning as a 'world', if it is" - - aStream nextPutAll: ' [world]'! ! -!WorldMorph methodsFor: 'halos and balloon help' stamp: 'jmv 10/21/2020 16:46:19'! - deleteBalloonTarget: aMorph - "Delete the balloon help targeting the given morph" - self handsDo:[:h| h deleteBalloonTarget: aMorph].! ! -!WorldMorph methodsFor: 'halos and balloon help' stamp: 'jmv 10/21/2020 16:47:14' overrides: 50549544! - wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph - "Answer whether the receiver would like to offer the halo handle with the given selector (e.g. #addCollapseHandle:)" - - ^#(addDebugHandle: addMenuHandle: addHelpHandle:) - statePointsTo: aSelector! ! -!WorldMorph methodsFor: 'taskbar' stamp: 'jmv 10/21/2020 17:00:39'! - hideTaskbar - taskbar ifNotNil: [ - taskbar delete. - taskbar _ nil ]! ! -!WorldMorph methodsFor: 'taskbar' stamp: 'jmv 10/21/2020 17:00:47'! - showTaskbar - - taskbar ifNil: [ - taskbar _ TaskbarMorph newRow. - taskbar openInWorld: self ]! ! -!WorldMorph methodsFor: 'taskbar' stamp: 'jmv 10/21/2020 17:00:30' overrides: 50337100! - taskbar - ^taskbar! ! -!WorldMorph methodsFor: 'taskbar' stamp: 'jmv 10/21/2020 17:01:03'! - taskbarDeleted - taskbar _ nil! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/21/2020 17:04:22'! - collapseAll - "Collapse all windows" - (SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed not ]) - reverseDo: [ :w | w collapse. self displayWorld]. - self collapseNonWindows! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/21/2020 17:00:27'! - restoreAll - "Expand all windows to their previous state" - taskbar - ifNotNil: [ :tb | tb restoreAll ]! ! -!WorldMorph methodsFor: 'defaul desktop' stamp: 'jmv 10/21/2020 17:08:07'! - recreateDefaultDesktop - | editor | - self whenUIinSafeState: [ - self hideTaskbar. - (submorphs - select: [ :ea | ea class == SystemWindow or: [ea class == TranscriptWindow]]) - do: [ :ea | ea delete ]. - TranscriptWindow openTranscript - morphPosition: 5 @ 283; - morphExtent: 990 @ 400. - editor _ TextEditor openTextEditor - morphPosition: 456 @ 3; - morphExtent: 900 @ 680. - editor setLabel: 'About Cuis'. - editor model actualContents: Utilities defaultTextEditorContents. - Theme current useTaskbar ifTrue: [self showTaskbar]. - ].! ! -!WorldMorph methodsFor: 'defaul desktop' stamp: 'jmv 10/21/2020 17:08:22'! - tearDownDesktop - self whenUIinSafeState: [ - self hideTaskbar. - submorphs - do: [ :ea | (ea is: #SystemWindow) ifTrue: [ ea delete ]]].! ! -!WorldMorph methodsFor: 'events' stamp: 'jmv 10/21/2020 17:11:53' overrides: 16874466! - click: aMouseButtonEvent localPosition: localEventPosition - ^self whenUIinSafeState: [self mouseButton2Activity]! ! -!WorldMorph class methodsFor: 'instance creation' stamp: 'jmv 10/21/2020 15:38:59'! - newWorld - " -[ - UISupervisor stopUIProcess. - UISupervisor spawnNewMorphicProcessFor: WorldMorph newWorld -] fork. - " - | w | - w _ self new. - w morphPosition: `0@0` extent: Display extent. - w setCanvas: Display getCanvas. - w handsDo: [ :h | - h privateOwner: w ]. - ^w! ! -!WorldMorph class methodsFor: 'system startup' stamp: 'jmv 10/21/2020 16:49:42' overrides: 50549607! - initClassCachedState - "Should use some other way to find relevant instances" - self flag: #jmvVer2. - self allInstancesDo: [ :each | - each buildMagnifiedBackgroundImage. - each redrawNeeded ]. - Cursor defaultCursor activateCursor.! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 10/21/2020 17:02:09' prior: 50524664! - preferencesMenu - "Build the preferences menu for the world." - - ^ (self menu: 'Preferences...') - addItemsFromDictionaries: { - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Font Sizes...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Set System Font...'. - #object -> FontFamily. - #selector -> #promptUserAndSetDefault. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'change the current system font family.' - } asDictionary. - { - #label -> 'Load all TrueType Fonts'. - #object -> FontFamily. - #selector -> #readAdditionalTrueTypeFonts. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'Load additional TrueType fonts included with Cuis.' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }! ! -!TheWorldMenu methodsFor: 'windows & flaps menu' stamp: 'jmv 10/21/2020 16:56:57' prior: 50413324! - windowsMenu - "Build the windows menu for the world." - - ^ (self menu: 'Windows') - addItemsFromDictionaries: `{ - { - #label -> 'Find Window'. - #object -> #myWorld. - #selector -> #findWindow:. - #icon -> #windowIcon. - #balloonText -> 'Presents a list of all windows; if you choose one from the list, it becomes the active window.' - } asDictionary. - { - #label -> 'Find changed Browsers...'. - #object -> #myWorld. - #selector -> #findDirtyBrowsers:. - #icon -> #editFindReplaceIcon. - #balloonText -> 'Presents a list of browsers that have unsubmitted changes; if you choose one from the list, it becomes the active window.' - } asDictionary. - { - #label -> 'Find changed Windows...'. - #object -> #myWorld. - #selector -> #findDirtyWindows:. - #icon -> #newWindowIcon. - #balloonText -> 'Presents a list of all windows that have unsubmitted changes; if you choose one from the list, it becomes the active window.' - } asDictionary. - nil. - { - #label -> 'Find a Transcript'. - #object -> #myWorld. - #selector -> #findATranscript:. - #icon -> #printerIcon. - #balloonText -> 'Brings an open Transcript to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find a FileList'. - #object -> #myWorld. - #selector -> #findAFileList:. - #icon -> #systemFileManagerIcon. - #balloonText -> 'Brings an open fileList to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find a Change Sorter'. - #object -> #myWorld. - #selector -> #findAChangeSorter:. - #icon -> #changesIcon. - #balloonText -> 'Brings an open change sorter to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find Message Names'. - #object -> #myWorld. - #selector -> #findAMessageNamesWindow:. - #icon -> #inspectIcon. - #balloonText -> 'Brings an open MessageNames window to the front, creating one if necessary, and makes it the active window' - } asDictionary. - nil. - { - #label -> 'Tile open windows'. - #object -> TileResizeMorph. - #selector -> #tileOpenWindows. - #icon -> #windowIcon. - #balloonText -> 'Tile open windows'. - } asDictionary. - { - #label -> 'Collapse all Windows'. - #object -> #myWorld. - #selector -> #collapseAll. - #icon -> #collapseIcon. - #balloonText -> 'Reduce all open windows to collapsed forms that only show titles.' - } asDictionary. - { - #label -> 'Restore all Windows'. - #object -> #myWorld. - #selector -> #restoreAll. - #icon -> #expandIcon. - #balloonText -> 'Restore all collapsed windows back to their previous forms.' - } asDictionary. - { - #label -> 'Close top Window'. - #object -> SystemWindow. - #selector -> #closeTopWindow. - #icon -> #closeIcon. - #balloonText -> 'Close the topmost window if possible.' - } asDictionary. - { - #label -> 'Send top Window to back'. - #object -> SystemWindow. - #selector -> #sendTopWindowToBack. - #icon -> #goBottomIcon. - #balloonText -> 'Make the topmost window become the backmost one, and activate the window just beneath it.' - } asDictionary. - { - #label -> 'Move Windows onscreen'. - #object -> #myWorld. - #selector -> #bringWindowsFullOnscreen. - #icon -> #displayIcon. - #balloonText -> 'Make all windows fully visible on the screen' - } asDictionary. - nil. - { - #label -> 'Delete unchanged Windows'. - #object -> #myWorld. - #selector -> #closeUnchangedWindows. - #icon -> #warningIcon. - #balloonText -> 'Deletes all windows that do not have unsaved text edits.' - } asDictionary. - { - #label -> 'Delete non Windows'. - #object -> #myWorld. - #selector -> #deleteNonWindows. - #icon -> #warningIcon. - #balloonText -> 'Deletes all non-window morphs lying on the world.' - } asDictionary. - { - #label -> 'Delete Both of the Above'. - #selector -> #cleanUpWorld. - #icon -> #warningIcon. - #balloonText -> 'Deletes all unchanged windows and also all non-window morphs lying on the world, other than flaps.' - } asDictionary. - }`! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -[ - | oldWorld ba roots w | - oldWorld _ UISupervisor ui. - ba _ oldWorld instVarNamed: 'backgroundImageData'. - roots _ oldWorld instVarNamed: 'submorphs'. - roots _ roots reject: [ :m | m is: #TaskbarMorph ]. - oldWorld _ nil. - UISupervisor stopUIProcess. - w _ WorldMorph newWorld. - w - "recreateDefaultDesktop;" - backgroundImageData: ba; - addAllMorphs: roots; - showTaskbar. - UISupervisor spawnNewMorphicProcessFor: w. - 'Please do [Install New Updates] again.' print. -] fork. -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4420-NewPasteUpMorphAndWorldMorph-JuanVuletich-2020Oct21-17h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4416] on 21 October 2020 at 5:18:31 pm'! - -KernelMorph subclass: #PasteUpMorph - instanceVariableNames: 'backgroundImage backgroundImageData' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -!classDefinition: #PasteUpMorph category: #'Morphic-Kernel' stamp: 'Install-4420-NewPasteUpMorphAndWorldMorph-JuanVuletich-2020Oct21-17h15m-jmv.001.cs.st 10/24/2020 17:29:20'! -KernelMorph subclass: #PasteUpMorph - instanceVariableNames: 'backgroundImage backgroundImageData' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! -!PasteUpMorph commentStamp: 'jmv 2/21/2016 18:32' prior: 50548946! - A World, the entire Smalltalk screen, is a PasteUpMorph. A World responds true to isWorld. A PasteUpMorph that is a world, builds its menu in HandMorph buildWorldMenu. - -worldState If I am also a World, keeps the hands, damageRecorder, stepList etc. -! - -PasteUpMorph subclass: #WorldMorph - instanceVariableNames: 'activeHand hands canvas damageRecorder stepList lastCycleTime alarms lastAlarmTime deferredUIMessages drawingFailingMorphs waitDelay pause lastCycleHadAnyEvent taskbar' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -!classDefinition: #WorldMorph category: #'Morphic-Kernel' stamp: 'Install-4420-NewPasteUpMorphAndWorldMorph-JuanVuletich-2020Oct21-17h15m-jmv.001.cs.st 10/24/2020 17:29:20'! -PasteUpMorph subclass: #WorldMorph - instanceVariableNames: 'activeHand hands canvas damageRecorder stepList lastCycleTime alarms lastAlarmTime deferredUIMessages drawingFailingMorphs waitDelay pause lastCycleHadAnyEvent taskbar' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! -!WorldMorph commentStamp: '' prior: 50548981! - A WorldMorph is a kind of PasteUpMorph that can act as the root morph of a Morphic system. Usually uses the whole Display. - -activeHand -- a HandMorph -hands -- Array of HandMorphs (typically only one) representing the Cursor and its event queue. -canvas -- BitBlitCanvas on the DisplayScreen. (Display getCanvas) -damageRecorder -- the DamageRecorder for the Display -stepList -- a Heap of StepMessage. Each morph which wants stepping has a StepMessage here. - See comment in #Morph>>stepAt: -lastStepTime -- 'now' as last sampled at step. (Time localMillisecondClock) -lastStepMessage -- nil or a selector -lastCycleTime -- 'now' as last sampled (Time localMillisecondClock) -alarms -- a Heap of MorphicAlarm. See comment in #Morph>>addAlarm:after: - An _alarm_ is an action to be done once, vs a _step_ which is cycled. -lastAlarm -- 'now' as sampled at last alarm (Time localMillisecondClock). -drawingFailureMorphs -- a WeakIdentitySet of Morphs with drawing failures -waitDelay -- a Delay (set in #WorldState>>doOneCycleFor:) -pause -- A 'phase-locked loop' style value to help regularise the step/alarm/event service rate. - (set in #WorldState>>doOneCycleFor:) -lastCycleHadAnyEvent -- a boolean (set in #WorldState>>doOneCycleFor:) -world -- a PasteUpMorph -! -!PasteUpMorph methodsFor: 'accessing' stamp: 'jmv 10/21/2020 16:24:51' prior: 50549027 overrides: 16882824! - activeHand - "Answer the currently active hand, if any..." - ^self world ifNotNil: [ :w | w activeHand ]! ! -!PasteUpMorph methodsFor: 'accessing' stamp: 'jmv 11/19/2010 13:56' prior: 50549034 overrides: 16899189! - color: aColor - super color: aColor. - self backgroundImageData: nil! ! -!PasteUpMorph methodsFor: 'accessing' stamp: 'GC 3/17/2019 08:16:08' prior: 50549039 overrides: 16874712! - handlesKeyboard - - ^ true ! ! -!PasteUpMorph methodsFor: 'caching' stamp: 'jmv 10/21/2020 16:44:28' prior: 50549043 overrides: 50510070! - releaseCachedState - super releaseCachedState. - backgroundImage _ nil.! ! -!PasteUpMorph methodsFor: 'change reporting' stamp: 'jmv 1/16/2017 09:56:14' prior: 50549049 overrides: 16874142! - addedMorph: aMorph - "Notify the receiver that the given morph was just added." - super addedMorph: aMorph. - self taskbar ifNotNil: [ :tb | - tb wasOpened: aMorph ]! ! -!PasteUpMorph methodsFor: 'change reporting' stamp: 'jmv 1/16/2017 09:56:07' prior: 50549058 overrides: 16876964! - removedMorph: aMorph - "Notify the receiver that aMorph was just removed from its children" - super removedMorph: aMorph. - self taskbar ifNotNil: [ :tb | - tb wasDeleted: aMorph ]! ! -!PasteUpMorph methodsFor: 'drawing' stamp: 'jmv 10/21/2020 16:40:25' prior: 50549067 overrides: 16899205! - drawOn: aCanvas - - "draw background image." - backgroundImage - ifNotNil: [ - aCanvas image: backgroundImage at: `0@0` ] - ifNil: [ - super drawOn: aCanvas ]! ! -!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'HAW 12/24/2018 07:13:56' prior: 50549076 overrides: 50424799! - allowsFilesDrop - - ^ true! ! -!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'jmv 1/19/2013 15:24' prior: 50549080 overrides: 16874692! - allowsMorphDrop - "Answer whether we accept dropping morphs. By default answer false." - - ^ true! ! -!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'jmv 1/19/2013 15:25' prior: 50549087 overrides: 16874701! - allowsSubmorphDrag - "Answer whether our morphs can just be grabbed with the hand, instead of requiring the use of the halo. By default answer false. - Both 'aMorph allowsGrabWithHand' and 'aMorph owner allowsSubmorphDrag' must be true for aMorph to be grabbed by the hand. It is also required that 'aMorph handlesMouseDown:' be false." - - ^ true! ! -!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'HAW 12/24/2018 10:27:39' prior: 50549101 overrides: 50424793! - dropFiles: aDropFilesEvent - - (DropFilesAction for: aDropFilesEvent) value! ! -!PasteUpMorph methodsFor: 'events' stamp: 'jmv 10/28/2019 18:13:11' prior: 50549107 overrides: 50449239! - keyStroke: aKeyboardEvent - "Handle a keystroke event." - (aKeyboardEvent commandAltKeyPressed or: [ aKeyboardEvent controlKeyPressed ]) - ifTrue: [ - aKeyboardEvent keyCharacter = $b ifTrue: [ BrowserWindow openBrowser ]. - aKeyboardEvent keyCharacter = $f ifTrue: [ BrowserWindow findClass ]. - aKeyboardEvent keyCharacter = $F ifTrue: [ MessageSetWindow findInSourceCode ]. - ]. - "aKeyboardEvent keyCharacter print." - ^ super keyStroke: aKeyboardEvent! ! -!PasteUpMorph methodsFor: 'events' stamp: 'jmv 1/18/2013 12:38' prior: 50549124 overrides: 16874541! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - "Handle a mouse down event." - - super mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition. - - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: #click:localPosition: - clkNHalf: nil - dblClkSel: #doubleClick:localPosition: - dblClkNHalfSel: nil - tripleClkSel: nil! ! -!PasteUpMorph methodsFor: 'events' stamp: 'jmv 10/21/2020 15:41:41' prior: 50549140 overrides: 16874682! - windowEvent: aMorphicEvent - - aMorphicEvent windowEventType == #windowClose - ifTrue: [ - ^TheWorldMenu basicNew quitSession] -! ! -!PasteUpMorph methodsFor: 'event handling testing' stamp: 'jmv 8/20/2012 18:56' prior: 50549148 overrides: 16874721! - handlesMouseDown: aMouseButtonEvent - ^true! ! -!PasteUpMorph methodsFor: 'event handling' stamp: 'jmv 3/10/2011 16:02' prior: 50549153 overrides: 16874769! - mouseButton2Activity - - ^self invokeWorldMenu! ! -!PasteUpMorph methodsFor: 'event handling' stamp: 'jmv 10/21/2020 16:48:08' prior: 50549157! - wantsWindowEvent: anEvent - ^false! ! -!PasteUpMorph methodsFor: 'geometry' stamp: 'jmv 5/24/2020 10:07:38' prior: 50549161 overrides: 16875287! - fontPreferenceChanged - self submorphsDo: [ :m | - m morphExtent: (m morphExtent max: m minimumExtent). - m fontPreferenceChanged ]! ! -!PasteUpMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 16:33:43' prior: 50549169 overrides: 16899309! - privateExtent: newExtent - - ^ (super privateExtent: newExtent) - ifTrue: [ self buildMagnifiedBackgroundImage ]; - yourself! ! -!PasteUpMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 20:58:35' prior: 50549176! - defaultBorderColor - "answer the default border color/fill style for the receiver" - ^ `Color - r: 0.861 - g: 1.0 - b: 0.722`! ! -!PasteUpMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:38' prior: 50549183! - defaultBorderWidth - "answer the default border width for the receiver" - ^ 1! ! -!PasteUpMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 20:58:44' prior: 50549189 overrides: 50387680! - defaultColor - "answer the default color/fill style for the receiver" - ^ `Color - r: 0.8 - g: 1.0 - b: 0.6`! ! -!PasteUpMorph methodsFor: 'interaction loop' stamp: 'jmv 8/17/2020 13:41:37' prior: 50549195! - mainLoop - - - self clearWaitDelay. - self setCanvas. - [ - self doOneCycle. - Processor yield. - true ] - whileTrue: []! ! -!PasteUpMorph methodsFor: 'interaction loop' stamp: 'HAW 12/26/2019 10:05:45' prior: 50549202! - runProcess - - | process | - - process _ [ self mainLoop ] newProcess. - process - priority: Processor userSchedulingPriority; - name: 'Morphic UI'; - animatedUI: self. - - ^ process! ! -!PasteUpMorph methodsFor: 'menu & halo' stamp: 'jmv 1/19/2013 15:14' prior: 50549210! - addWorldHaloMenuItemsTo: aMenu hand: aHandMorph - "Add standard halo items to the menu, given that the receiver is a World" - - | unlockables | - self addColorMenuItems: aMenu hand: aHandMorph. - -" aMenu addLine. - self addWorldToggleItemsToHaloMenu: aMenu." - aMenu addLine. - self addCopyItemsTo: aMenu. - self addExportMenuItems: aMenu hand: aHandMorph. - - self addDebuggingItemsTo: aMenu hand: aHandMorph. - - aMenu addLine. - aMenu defaultTarget: self. - - aMenu addLine. - - unlockables _ self submorphs select: - [ :m | m isLocked]. - unlockables size = 1 ifTrue: [ - aMenu add: ('unlock "{1}"' format:{unlockables first printStringLimitedTo: 40})action: #unlockContents]. - unlockables size > 1 ifTrue: [ - aMenu add: 'unlock all contents' action: #unlockContents. - aMenu add: 'unlock...' action: #unlockOneSubpart]. - - aMenu defaultTarget: aHandMorph. -! ! -!PasteUpMorph methodsFor: 'misc' stamp: 'jmv 3/2/2011 11:10' prior: 50549239! - backgroundImage - ^backgroundImage! ! -!PasteUpMorph methodsFor: 'misc' stamp: 'jmv 12/8/2013 15:11' prior: 50549243! - backgroundImageData: aByteArray - " - | filename | - filename _ 'bg/free-3d-art-pictures-gallery-wallpaper-desktop-18.jpg'. - filename _ 'bg/free-desktop-wallpaper.jpg'. - filename _ 'bg/jellyfish-thumb.jpg'. - filename _ 'bg/splash_by_beefpepsi.jpg'. - filename _ 'bg/gray ocean and pier.jpg'. - filename _ 'bg/newyork.jpg'. - filename _ 'bg/download-free-desktop-wallpaper-nature-conquestofparadise-marirs-pic.jpg'. - filename _ 'bg/desktop-wallpaper-tropical-1280x1024.jpg'. - - filename _ 'bg/free-3d-art-pictures-gallery-wallpaper-desktop-18.jpg'. - self runningWorld backgroundImageData: (FileStream readOnlyFileNamed: filename) binary contentsOfEntireFile. - " - backgroundImageData _ aByteArray. - self buildMagnifiedBackgroundImage! ! -!PasteUpMorph methodsFor: 'misc' stamp: 'jmv 10/21/2020 16:30:09' prior: 50549268! - buildMagnifiedBackgroundImage - | image old | - old _ backgroundImage. - backgroundImageData - ifNil: [ backgroundImage _ nil ] - ifNotNil: [ - [image _ Form fromBinaryStream: backgroundImageData readStream. - backgroundImage _ image magnifyTo: extent. - ] on: Error do: [backgroundImage := nil]. "Can happen if JPEG plugin not built" - ]. - old == backgroundImage ifFalse: [ - self redrawNeeded ]! ! -!PasteUpMorph methodsFor: 'stepping and presenter' stamp: 'jmv 6/11/2012 09:59' prior: 50549284 overrides: 16876574! - wantsSteps - "Return true if the receiver wants to its #step or #stepAt: methods be run ALL THE TIME. - Morphs that send #startStepping and #stopStepping at appropriate times (i.e. when they are already in the world!!) don't need to answer true to this message. - jmv: Not really sure. Sub-world stepping needs some review." - - ^true! ! -!PasteUpMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 7/23/2020 14:47:46' prior: 50549297! - addMorph: aMorph centeredNear: aPoint - "Add the given morph to this world, attempting to keep its center as close to the given point possible while also keeping the it entirely within the bounds of this world." - - | trialRect delta | - trialRect _ Rectangle center: aPoint extent: aMorph morphExtent. - delta _ trialRect amountToTranslateWithin: self displayBounds. - self addMorph: aMorph. - aMorph morphPositionInWorld: trialRect origin + delta.! ! -!PasteUpMorph methodsFor: 'testing' stamp: 'jmv 3/9/2020 10:13:47' prior: 50549314 overrides: 16876981! - is: aSymbol - ^ aSymbol == #PasteUpMorph or: [ super is: aSymbol ]! ! -!PasteUpMorph methodsFor: 'testing' stamp: 'jmv 10/21/2020 16:42:59' prior: 50549319 overrides: 16877003! - isReallyVisible - "Answer true only if all the owner chain is visible (i.e. if we are really visible!!)" - ^self visible and: [owner isReallyVisible ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 8/13/2013 09:17' prior: 50549326! - bringWindowsFullOnscreen - "Make ever SystemWindow on the desktop be totally on-screen, whenever possible." - (SystemWindow - windowsIn: self - satisfying: [ :w | - w visible ]) do: [ :each | - each makeMeFullyVisible ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 8/13/2013 09:18' prior: 50549336! - closeUnchangedWindows - "Present a menu of window titles for all windows with changes, - and activate the one that gets chosen." - (SelectionMenu confirm: 'Do you really want to close all windows -except those with unaccepted edits?') ifFalse: [ ^ self ]. - (SystemWindow - windowsIn: self - satisfying: [ :w | - w visible and: [ w canDiscardEdits ]]) do: [ :w | - w delete ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 1/24/2016 21:58' prior: 50549350! - collapseNonWindows - self allNonWindowRelatedSubmorphs do: [ :m | - m collapse]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 1/24/2016 21:58' prior: 50549355! - deleteNonWindows - (SelectionMenu confirm: -'Do you really want to discard all objects -that are not in windows?') - ifFalse: [^ self]. - - self allNonWindowRelatedSubmorphs do: [:m | - m delete ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 3/21/2012 17:23' prior: 50549364! - findAChangeSorter: evt - "Locate a change sorter, open it, and bring it to the front. Create one if necessary" - self - findAWindowSatisfying: [ :aWindow | - aWindow model isMemberOf: ChangeSorter] - orMakeOneUsing: [ ChangeSorterWindow open: ChangeSorter new label: nil ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 7/4/2016 22:20' prior: 50549375! - findAFileList: evt - "Locate a file list, open it, and bring it to the front. - Create one if necessary, respecting the Preference." - self - findAWindowSatisfying: [ :aWindow | - aWindow model class == FileList ] - orMakeOneUsing: [ - FileListWindow openFileList ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 7/4/2016 22:21' prior: 50549386! -findAMessageNamesWindow: evt - "Locate a MessageNames tool, open it, and bring it to the front. Create one if necessary" - self - findAWindowSatisfying: [ :aWindow | - aWindow model class == MessageNames ] - orMakeOneUsing: [ - MessageNamesWindow open: MessageNames new label: 'Message Names' ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 7/30/2014 09:01' prior: 50549398! -findATranscript: evt - "Locate a transcript, open it, and bring it to the front. Create one if necessary" - - self findATranscript! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 10/25/2010 21:29' prior: 50549405! - findAWindowSatisfying: qualifyingBlock orMakeOneUsing: makeBlock - "Locate a window satisfying a block, open it, and bring it to the front. Create one if necessary, by using the makeBlock" - | aWindow | - submorphs do: [ :aMorph | - (((aWindow _ aMorph) is: #SystemWindow) and: [ qualifyingBlock value: aWindow ]) ifTrue: [ - aWindow isCollapsed ifTrue: [ aWindow expand ]. - aWindow activateAndForceLabelToShow. - ^ self ]]. - "None found, so create one" - makeBlock value.! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 7/5/2016 09:42' prior: 50549423! - findDirtyBrowsers: evt - "Present a menu of window titles for browsers with changes, - and activate the one that gets chosen." - | menu | - menu _ MenuMorph new. - (SystemWindow - windowsIn: self - satisfying: [ :w | - w visible and: [ - (w model is: #CodeProvider) and: [ w canDiscardEdits not ]]]) do: [ :w | - menu - add: w label - target: w - action: #activate ]. - menu submorphs notEmpty ifTrue: [ menu popUpInWorld: self ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 8/13/2013 09:20' prior: 50549439! - findDirtyWindows: evt - "Present a menu of window titles for all windows with changes, - and activate the one that gets chosen." - | menu | - menu _ MenuMorph new. - (SystemWindow - windowsIn: self - satisfying: [ :w | - w visible and: [ w canDiscardEdits not ]]) do: [ :w | - menu - add: w label - target: w - action: #activate ]. - menu submorphs notEmpty ifTrue: [ menu popUpInWorld: self ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 3/10/2018 22:02:53' prior: 50549454! - findWindow: evt - "Present a menu names of windows and naked morphs, and activate the one that gets chosen. Collapsed windows appear below line, expand if chosen; naked morphs appear below second line; if any of them has been given an explicit name, that is what's shown, else the class-name of the morph shows; if a naked morph is chosen, bring it to front and have it don a halo." - | menu expanded collapsed nakedMorphs | - menu _ MenuMorph new. - expanded _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed not ]. - collapsed _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed ]. - nakedMorphs _ self submorphsSatisfying: [ :m | - (m is: #SystemWindow) not ]. - expanded isEmpty & (collapsed isEmpty & nakedMorphs isEmpty) ifTrue: [ ^ Smalltalk beep ]. - (expanded asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #activateAndForceLabelToShow. - w canDiscardEdits ifFalse: [ menu lastItem color: `Color red` ]]. - expanded isEmpty | (collapsed isEmpty & nakedMorphs isEmpty) ifFalse: [ menu addLine ]. - (collapsed asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #expand. - w canDiscardEdits ifFalse: [ menu lastItem color: `Color red` ]]. - nakedMorphs isEmpty ifFalse: [ menu addLine ]. - (nakedMorphs asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #comeToFrontAndAddHalo ]. - menu addTitle: 'find window'. - menu popUpInWorld: self! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'HAW 7/5/2018 18:24:37' prior: 50549507! - invokeWorldMenu - "Put up the world menu, triggered by the passed-in event. - Perhaps a good place to disable it if needed" - - | menu | - menu _ (TheWorldMenu new - world: self - hand: self activeHand) buildWorldMenu. - menu addTitle: Preferences desktopMenuTitle. - menu popUpInWorld: self! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 1/8/2017 16:44:57' prior: 50549519! - allNonWindowRelatedSubmorphs - "Answer all non-window submorphs that are not flap-related" - - ^submorphs - reject: [ :m | (m is: #SystemWindow) or: [ m is: #TaskbarMorph ] ]! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 2/28/2011 15:16' prior: 50549527! - deleteAllHalos - self haloMorphs do: - [ :m | m delete]! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 9/13/2013 09:18' prior: 50549531! - fullRepaintNeeded - self redrawNeeded. - SystemWindow - windowsIn: self - satisfying: [ :w | - w visible ifTrue: [ w makeMeVisible ]. - false ]! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'ar 9/28/2000 18:00' prior: 50549538! - haloMorphs - ^ self hands collect:[:h| h halo] thenSelect:[:halo| halo notNil]! ! -!PasteUpMorph methodsFor: 'halos and balloon help' stamp: 'jmv 10/21/2020 16:46:33' prior: 50549544 overrides: 50537020! - wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph - "Answer whether the receiver would like to offer the halo handle with the given selector (e.g. #addCollapseHandle:)" - (#(addHelpHandle: addRotateHandle: addRecolorHandle:) statePointsTo: aSelector) - ifTrue: ["FIXME - hack to disable for non-functional halo items" - ^ false]. - - ^super wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph! ! -!PasteUpMorph methodsFor: 'object serialization' stamp: 'jmv 6/8/2014 18:28' prior: 50549560 overrides: 16876452! - objectForDataStream: refStrm - "I am about to be written on an object file. Write a path to me in the other system instead." - - | dp | - dp _ DiskProxy global: #Smalltalk selector: #runningWorld args: #(). - refStrm replace: self with: dp. - ^ dp! ! -!PasteUpMorph methodsFor: 'windows' stamp: 'jmv 7/30/2014 09:00' prior: 50549570! - findATranscript - "Locate a transcript, open it, and bring it to the front. Create one if necessary" - - self - findAWindowSatisfying: [ :aWindow | aWindow model == Transcript] - orMakeOneUsing: [ TranscriptWindow openTranscript ]! ! -!PasteUpMorph methodsFor: 'ui services' stamp: 'jmv 5/23/2020 21:00:01' prior: 50549581 overrides: 50515282! - request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock - "This is deprecated because using it requires blocking the user interface until the user provides a response. Please use the variants that are not modal." - ^ StringRequestMorph request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock! ! -!PasteUpMorph methodsFor: 'ui services' stamp: 'jmv 5/23/2020 21:00:05' prior: 50549595 overrides: 50515295! - request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock - ^ StringRequestMorph request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock! ! -!PasteUpMorph class methodsFor: 'system startup' stamp: 'jmv 10/21/2020 16:49:47' prior: 50549607 overrides: 16784996! - initClassCachedState - "Should use some other way to find relevant instances" - self flag: #jmvVer2. - self allInstancesDo: [ :each | - each buildMagnifiedBackgroundImage ]. - Cursor defaultCursor activateCursor.! ! -!PasteUpMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:51:39' prior: 50549618 overrides: 50344178! - categoryInNewMorphMenu - ^ 'Worlds'! ! -!WorldMorph methodsFor: 'alarms' stamp: 'jmv 3/3/2017 09:33:59' prior: 50549622! - addAlarm: aSelector withArguments: argArray for: aTarget at: scheduledTime - "Add a new alarm with the given set of parameters" - - alarms add: - (MorphicAlarm - receiver: aTarget - selector: aSelector - arguments: argArray - at: scheduledTime)! ! -!WorldMorph methodsFor: 'alarms' stamp: 'jmv 3/3/2017 09:34:03' prior: 50549632! - adjustAlarmTimes: nowTime - "Adjust the alarm times after some clock weirdness (such as image-startup etc)" - | deltaTime | - deltaTime _ nowTime - lastAlarmTime. - alarms do: [ :alarm | - alarm scheduledTime: alarm scheduledTime + deltaTime ]! ! -!WorldMorph methodsFor: 'alarms' stamp: 'jmv 5/11/2016 09:53' prior: 50549642! - alarmSortBlock - - ^[ :alarm1 :alarm2 | alarm1 scheduledTime < alarm2 scheduledTime ]! ! -!WorldMorph methodsFor: 'alarms' stamp: 'jmv 3/3/2017 11:54:00' prior: 50549647! - removeAlarm: aSelector for: aTarget - "Remove the alarm with the given selector" - - | alarm | - alarm _ alarms - detect: [ :any | any receiver == aTarget and: [any selector == aSelector]] - ifNone: nil. - alarm ifNotNil: [ alarms remove: alarm ]! ! -!WorldMorph methodsFor: 'alarms' stamp: 'jmv 3/3/2017 09:35:03' prior: 50549657! - triggerAlarmsBefore: nowTime - "Trigger all pending alarms that are to be executed before nowTime." - - nowTime - lastAlarmTime > 10000 - ifTrue: [ self adjustAlarmTimes: nowTime ]. - [ alarms notEmpty and: [ alarms first scheduledTime < nowTime ]] - whileTrue: [ alarms removeFirst valueAtTime: nowTime ]. - lastAlarmTime _ nowTime! ! -!WorldMorph methodsFor: 'canvas' stamp: 'di 6/7/1999 17:44' prior: 50549670! - canvas - - ^ canvas! ! -!WorldMorph methodsFor: 'canvas' stamp: 'jmv 8/17/2020 13:42:46' prior: 50549673! - clearCanvas - canvas _ nil. - damageRecorder _ nil.! ! -!WorldMorph methodsFor: 'canvas' stamp: 'jmv 10/21/2020 15:17:06' prior: 50549677! - ensureNonDisplayCanvas - (canvas isNil or: [ - canvas drawsOnDisplay or: [ - (canvas extent ~= self morphExtent) or: [ - canvas form depth ~= Display depth]]]) ifTrue: [ - "allocate a new offscreen canvas the size of the window" - self setCanvas: (MorphicCanvas withExtent: self morphExtent depth: Display depth)]! ! -!WorldMorph methodsFor: 'canvas' stamp: 'jmv 8/4/2020 10:02:25' prior: 50549689! - recordDamagedRect: damageRect for: aMorph - - damageRecorder ifNotNil: [ - damageRecorder recordInvalidRect: damageRect for: aMorph ]! ! -!WorldMorph methodsFor: 'canvas' stamp: 'jmv 10/21/2020 15:17:17' prior: 50549696! - setCanvas - self setCanvas: Display getCanvas. - damageRecorder _ DamageRecorder new. - self redrawNeeded! ! -!WorldMorph methodsFor: 'canvas' stamp: 'jmv 10/21/2020 15:17:24' prior: 50549702! - setCanvas: aMorphicCanvas - canvas _ aMorphicCanvas. - canvas world: self. - damageRecorder - ifNil: [ damageRecorder _ DamageRecorder new].! ! -!WorldMorph methodsFor: 'hands' stamp: 'jmv 9/25/2012 22:39' prior: 50549709 overrides: 50550781! - activeHand - ^activeHand! ! -!WorldMorph methodsFor: 'hands' stamp: 'di 6/7/1999 17:40' prior: 50549712! - hands - - ^ hands! ! -!WorldMorph methodsFor: 'hands' stamp: 'RAA 5/24/2000 10:13' prior: 50549715! - handsDo: aBlock - - ^ hands do: aBlock! ! -!WorldMorph methodsFor: 'hands' stamp: 'RAA 5/24/2000 12:09' prior: 50549719! - handsReverseDo: aBlock - - ^ hands reverseDo: aBlock! ! -!WorldMorph methodsFor: 'hands' stamp: 'jmv 7/22/2020 20:42:49' prior: 50549723! - selectHandsToDrawForDamage: damageList - "Select the set of hands that must be redrawn because either (a) the hand itself has changed or (b) the hand intersects some damage rectangle." - - | result | - result _ OrderedCollection new. - hands do: [:hand | - hand needsToBeDrawn ifTrue: [ - hand hasChanged - ifTrue: [result add: hand] - ifFalse: [ - hand displayFullBounds ifNotNil: [ :handBounds | - (damageList anySatisfy: [ :r | r intersects: handBounds]) ifTrue: [ - result add: hand]]]]]. - ^ result! ! -!WorldMorph methodsFor: 'initialization' stamp: 'jmv 6/20/2014 20:24:55' prior: 50549742! -clearWaitDelay - waitDelay ifNotNil: [ - waitDelay unschedule. - waitDelay _ nil ]. - "Needed if for some reason Cuis is started with an earlier DateTime than the image was saved. - Might happen, especially on RasPi or other systems without an RTC" - lastCycleTime _ Time localMillisecondClock. - lastAlarmTime _ 0.! ! -!WorldMorph methodsFor: 'initialization' stamp: 'jmv 10/21/2020 16:05:30' prior: 50549755 overrides: 50384234! - initialize - - super initialize. - activeHand _ HandMorph new. - hands _ { activeHand }. - damageRecorder _ DamageRecorder new. - stepList _ Heap sortBlock: self stepListSortBlock. - alarms _ Heap sortBlock: self alarmSortBlock. - lastAlarmTime _ 0. - deferredUIMessages _ SharedQueue new. - drawingFailingMorphs _ WeakIdentitySet new. - pause _ 20. - lastCycleTime _ Time localMillisecondClock. - lastCycleHadAnyEvent _ false! ! -!WorldMorph methodsFor: 'initialization' stamp: 'jmv 2/2/2014 21:05' prior: 50549771! - stepListSortBlock - - ^ [ :stepMsg1 :stepMsg2 | - stepMsg1 scheduledTime <= stepMsg2 scheduledTime ]! ! -!WorldMorph methodsFor: 'stepping' stamp: 'jmv 10/21/2020 15:16:15' prior: 50549777! - cleanseStepList - "Remove morphs from the step list that are not in this World." - - | deletions | - deletions _ OrderedCollection new. - stepList do: [ :entry | - entry receiver world == self ifFalse: [ - deletions add: entry]]. - deletions do: [ :entry| - stepList remove: entry ]. - - deletions _ OrderedCollection new. - alarms do: [ :entry | - ((entry receiver is: #Morph) and: [ entry receiver world == self ]) ifFalse: [ - deletions add: entry]]. - deletions do: [ :entry| - alarms remove: entry ]! ! -!WorldMorph methodsFor: 'stepping' stamp: 'jmv 10/21/2020 15:35:50' prior: 50549795! - runLocalStepMethods: nowTime - "Run morph 'step' methods (LOCAL TO THIS WORLD) whose time has come. Purge any morphs that are no longer in this world." - - | stepMessage | - [ stepList notEmpty and: [ stepList first scheduledTime <= nowTime ]] - whileTrue: [ - stepMessage _ stepList first. - (stepMessage receiver shouldGetStepsFrom: self) - ifFalse: [ stepList removeFirst ] - ifTrue: [ - stepMessage valueAtTime: nowTime. - stepMessage rescheduleAfter: nowTime. - "We've just updated the scheduled time for stepMessage. - It might have been that stepMessage was removed altogether from stepList. - It also may be the case that stepList got added or removed other elements while on #valueAtTime: - Just reSort. It will be ok in any case." - stepList reSort. - ] - ]! ! -!WorldMorph methodsFor: 'stepping' stamp: 'jmv 10/21/2020 15:34:17' prior: 50549823! - runStepMethods - "Perform periodic activity inbetween event cycles" - | readyToProcess | - - "Processing the queue until empty is wrong if a block in it calls #addDeferredUIMessage: itself, because this loop will never end. - Instead, process no more than entries already in queue befor we start iterating!!" - readyToProcess _ deferredUIMessages size. - readyToProcess timesRepeat: [ - deferredUIMessages nextOrNil ifNotNil: [ :block | - block value - ] - ]. - self triggerAlarmsBefore: lastCycleTime. - self runLocalStepMethods: lastCycleTime. - - "we are using a normal #step for these now" - "aWorld allLowerWorldsDo: [ :each | each runLocalStepMethods ]." -! ! -!WorldMorph methodsFor: 'stepping' stamp: 'jmv 2/3/2014 21:15' prior: 50549846! - startStepping: aMorph at: scheduledTime selector: aSelector stepTime: stepTimeOrNil - "Add the given morph to the step list" - - self stopStepping: aMorph selector: aSelector. - stepList add: ( - StepMessage - receiver: aMorph - selector: aSelector - at: scheduledTime - stepTime: stepTimeOrNil)! ! -!WorldMorph methodsFor: 'stepping' stamp: 'jmv 3/3/2017 11:39:34' prior: 50549858! - stopStepping: aMorph selector: aSelector - "Remove the given morph from the step list." - stepList removeAll: (stepList select:[:stepMsg| stepMsg receiver == aMorph and: [ stepMsg selector == aSelector ]])! ! -!WorldMorph methodsFor: 'stepping' stamp: 'jmv 3/3/2017 11:39:22' prior: 50549867! - stopSteppingMorph: aMorph - "Remove the given morph from the step list." - stepList removeAll: (stepList select: [ :stepMsg | stepMsg receiver == aMorph])! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'RAA 5/24/2000 13:13' prior: 50549875! - checkIfUpdateNeeded - - damageRecorder updateIsNeeded ifTrue: [^true]. - hands do: [:h | (h hasChanged and: [h needsToBeDrawn]) ifTrue: [^true]]. - ^false "display is already up-to-date" -! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 10/21/2020 15:16:56' prior: 50549884! - displayWorldSafely - "Update this world's display and keep track of errors during draw methods." - - [self displayWorld] ifError: [:err :rcvr | - "Handle a drawing error" - | errCtx errMorph | - errCtx _ thisContext. - [ - errCtx _ errCtx sender. - "Search the sender chain to find the morph causing the problem" - [errCtx notNil and: [ (errCtx receiver is: #Morph) not ]] - whileTrue:[errCtx _ errCtx sender]. - "If we're at the root of the context chain then we have a fatal drawing problem" - errCtx ifNil:[^self handleFatalDrawingError: err]. - errMorph _ errCtx receiver. - "If the morph causing the problem has already the #drawError flag set, - then search for the next morph above in the caller chain." - errMorph isKnownFailing - ] whileTrue. - errMorph drawingFails. - self setCanvas. - "Install the old error handler, so we can re-raise the error" - rcvr error: err. - ]! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 10/21/2020 15:33:56' prior: 50549915! - doOneCycle - "Do one cycle of the interaction loop. This method is called repeatedly when the world is running. - - Make for low cpu usage if the ui is inactive, but quick response when ui is in use. - However, after some inactivity, there will be a larger delay before the ui gets responsive again." - - | wait waitUntil | - waitDelay ifNil: [ waitDelay _ Delay forMilliseconds: 50 ]. - lastCycleHadAnyEvent | deferredUIMessages isEmpty not - ifTrue: [ - pause _ 20. "This value will only be used when there are no more events to serve." - wait _ 0 ] "Don't wait" - ifFalse: [ - pause < 200 "No events processed? Start saving CPU!! But never make the user wait more than 200ms for being responsive again." - ifTrue: [ pause _ pause * 21//20 ]. - waitUntil _ lastCycleTime + pause. - "Earlier if steps" - stepList isEmpty not ifTrue: [ - waitUntil _ waitUntil min: stepList first scheduledTime ]. - "Earlier if alarms" - alarms ifNotNil: [ - alarms isEmpty not ifTrue: [ - waitUntil _ waitUntil min: alarms first scheduledTime ]]. - - wait _ waitUntil - Time localMillisecondClock ]. - Preferences serverMode - ifTrue: [ wait _ wait max: 50 ]. "Always wait at least a bit on servers, even if this makes the UI slow." - wait > 0 - ifFalse: [ Processor yield ] - ifTrue: [ - waitDelay beingWaitedOn - ifFalse: [ waitDelay setDelay: wait; wait ] - ifTrue: [ - "If we are called from a different process than that of the main UI, we might be called in the main - interCyclePause. In such case, use a new Delay to avoid 'This Delay has already been scheduled' errors" - (Delay forMilliseconds: wait) wait ]]. - - "Record start time of this cycle, and do cycle" - lastCycleTime _ Time localMillisecondClock. - lastCycleHadAnyEvent _ self doOneCycleNow! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 10/21/2020 16:04:46' prior: 50549973! - doOneCycleNow - "Immediately do one cycle of the interaction loop. - Only used for a few tests." - "See #eventTickler" - | hadAnyEvent | - Cursor currentCursor = (Cursor cursorAt: #waitCursor) ifTrue: [ Cursor defaultCursor activateCursor ]. - "Repair visual damage." - DisplayScreen checkForNewScreenSize. - self displayWorldSafely. - "Run steps, alarms and deferred UI messages" - self runStepMethods. - "Process user input events. Run all event triggered code." - hadAnyEvent _ false. - self handsDo: [ :h | - activeHand _ h. - hadAnyEvent _ hadAnyEvent | h processEventQueue. - activeHand _ nil ]. - "The default is the primary hand" - activeHand _ self hands first. - ^ hadAnyEvent.! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 3/2/2017 20:06:48' prior: 50549997! - doOneMinimalCycleNow - "Immediately do one cycle of the interaction loop. - Only repair display and process events. For modal menus and such." - - "Repair visual damage." - self displayWorldSafely. - - "Process user input events. Run all event triggered code." - ^activeHand processEventQueue! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 6/26/2015 14:36' prior: 50550009! - handleFatalDrawingError: errMsg - "Handle a fatal drawing error." - - self primitiveError: - 'Fatal Morphic drawing error', String newLineString, - errMsg. - - "Hm... we should jump into a 'safe' WorldMorph here, but how do we find it?!!"! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 10/21/2020 15:17:28' prior: 50550019! - tryDeferredUpdatingAndSetCanvas - "If this platform supports deferred updates, then make my canvas be the Display (or a rectangular portion of it), set the Display to deferred update mode, and answer true. Otherwise, set a non-Disply canvas and answer false.." - | properDisplay | - - "As this is the only sender of #deferUpdates: , this could be done in Morphic or image startup, and never efterwards..." - (Display deferUpdates: true) ifNil: [ - "deferred updates not supported by the VM, do them in the image!!" - self ensureNonDisplayCanvas. - ^ false]. - - "if no canvas, or canvas was offscreen, from a platform that didnt support defers, then fix it" - properDisplay _ canvas notNil and: [canvas drawsOnDisplay]. - properDisplay ifFalse: [ - self morphPosition: `0@0` extent: Display extent. - self setCanvas: Display getCanvas. - ]. - ^ true! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 10/21/2020 15:34:22' prior: 50550049 overrides: 50444405! -whenUIinSafeState: evaluableObject - "Please call - UISupervisor whenUIinSafeState: evaluableObject - " - deferredUIMessages nextPut: evaluableObject! ! -!WorldMorph methodsFor: 'errors on draw' stamp: 'jmv 11/5/2007 22:59' prior: 50550056! - addKnownFailing: aMorph - drawingFailingMorphs add: aMorph! ! -!WorldMorph methodsFor: 'errors on draw' stamp: 'jmv 11/5/2007 22:59' prior: 50550061! - isKnownFailing: aMorph - ^drawingFailingMorphs includes: aMorph! ! -!WorldMorph methodsFor: 'errors on draw' stamp: 'jmv 10/21/2020 15:54:35' prior: 50550066! - removeAllKnownFailing - drawingFailingMorphs _ WeakIdentitySet new. - self redrawNeeded! ! -!WorldMorph methodsFor: 'errors on draw' stamp: 'jmv 11/5/2007 22:59' prior: 50550071! - removeKnownFailing: aMorph - drawingFailingMorphs remove: aMorph! ! -!WorldMorph methodsFor: 'drawing' stamp: 'jmv 10/21/2020 17:06:37' prior: 50550076! - displayWorld - "Update this world's display." - - | deferredUpdateVMMode worldDamageRects handsToDraw allDamage | - self checkIfUpdateNeeded ifFalse: [ ^ self ]. "display is already up-to-date" - "I (jmv) removed the call to 'deferUpdates: false' below. No more need to call this every time." - deferredUpdateVMMode _ self tryDeferredUpdatingAndSetCanvas. - - "repair world's damage on canvas" - worldDamageRects _ canvas drawWorld: self repair: damageRecorder. - - "Check which hands need to be drawn (they are not the hardware mouse pointer)" - handsToDraw _ self selectHandsToDrawForDamage: worldDamageRects. - allDamage _ Array streamContents: [ :strm | - strm nextPutAll: worldDamageRects. - handsToDraw do: [ :h | - h savePatchFrom: canvas appendDamageTo: strm ]]. - - "Draw hands (usually carying morphs) onto world canvas" - canvas newClipRect: nil. - handsToDraw reverseDo: [ :h | canvas fullDrawHand: h ]. - - "quickly copy altered rects of canvas to Display:" - deferredUpdateVMMode ifFalse: [ - "Drawing was done to off-Display canvas. Copy content to Display" - canvas showAt: self viewBox origin invalidRects: allDamage ]. - - "Display deferUpdates: false." - "Display forceDisplayUpdate" - Display forceDamageToScreen: allDamage. - - "Restore world canvas under hands and their carried morphs" - handsToDraw do: [ :h | h restoreSavedPatchOn: canvas ].! ! -!WorldMorph methodsFor: 'drawing' stamp: 'jmv 10/21/2020 16:41:02' prior: 50550121 overrides: 50550823! - drawOn: aCanvas - - "draw background image." - backgroundImage - ifNotNil: [ - aCanvas image: backgroundImage at: `0@0` ] - ifNil: [ - "draw background fill" - (aCanvas drawsOnDisplay and: [ color mightBeTranslucent ]) - ifTrue: [ - "Special case so a translucent background on the Display allows you to see through the main Cuis Window. - Requires proper handling of translucent Display in the VM. - Seems to work only on Linux when using a composing window manager." - (BitBlt toForm: Display) clipRect: aCanvas clipRect; - copy: Display boundingBox - from: `0@0` in: nil - fillColor: color rule: Form over. - Display forceToScreen] - ifFalse: [ super drawOn: aCanvas ]]! ! -!WorldMorph methodsFor: 'event handling' stamp: 'jmv 10/21/2020 16:48:04' prior: 50550147 overrides: 50550918! - wantsWindowEvent: anEvent - ^true! ! -!WorldMorph methodsFor: 'classification' stamp: 'jmv 10/21/2020 15:47:06' prior: 50550152 overrides: 16874177! - isWorldMorph - - ^ true! ! -!WorldMorph methodsFor: 'submorphs-accessing' stamp: 'jmv 10/21/2020 16:26:04' prior: 50550156 overrides: 16876668! - allMorphsDo: aBlock - "Enumerate all morphs in the world, including those held in hands." - - super allMorphsDo: aBlock. - self handsReverseDo: [:h | h allMorphsDo: aBlock].! ! -!WorldMorph methodsFor: 'submorphs-accessing' stamp: 'jmv 10/21/2020 16:31:21' prior: 50550164! - canHandle: aMorph - - ^ canvas canDraw: aMorph! ! -!WorldMorph methodsFor: 'submorphs-accessing' stamp: 'jmv 10/21/2020 15:49:31' prior: 50550168! - firstHand - - ^ hands first! ! -!WorldMorph methodsFor: 'change reporting' stamp: 'jmv 10/21/2020 15:50:52' prior: 50550172 overrides: 50541311! - invalidateDisplayRect: damageRect fromSubmorph: submorphOrNil for: aMorph - "Clip damage reports to my bounds, since drawing is _always_ clipped to my bounds." - - self recordDamagedRect: (damageRect intersect: self morphLocalBounds ) for: aMorph! ! -!WorldMorph methodsFor: 'testing' stamp: 'jmv 10/21/2020 16:43:17' prior: 50550183 overrides: 50551088! - isReallyVisible - "Answer true only if all the owner chain is visible (i.e. if we are really visible!!)" - ^self visible! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 16:39:39' prior: 50550190 overrides: 50537893! - displayBounds - ^0@0 extent: extent! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 16:41:28' prior: 50550194 overrides: 50463607! - externalizeDisplayBounds: r - - ^ r! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 16:41:55' prior: 50550198 overrides: 16875276! - externalizeToWorld: aPoint - "aPoint is in own coordinates. Answer is in world coordinates." - ^ aPoint! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 16:42:23' prior: 50550205 overrides: 16875326! - internalizeFromWorld: aPoint - "aPoint is in World coordinates. Answer is in own coordinates." - ^ aPoint! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 16:43:37' prior: 50550212 overrides: 50545047! - morphPositionInWorld - - self flag: #jmvVer2. "Solo para evitar los warning por falta de owner... pensar despues este caso" - ^ `0@0`! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 15:52:21' prior: 50550219 overrides: 50550931! - privateExtent: newExtent - - ^ (super privateExtent: newExtent) - ifTrue: [ - self setCanvas ]; - yourself! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 15:55:32' prior: 50550225! - viewBox - - ^ self morphLocalBounds! ! -!WorldMorph methodsFor: 'caching' stamp: 'jmv 10/21/2020 15:54:07' prior: 50550229 overrides: 50550799! - releaseCachedState - super releaseCachedState. - self cleanseStepList. - self clearCanvas! ! -!WorldMorph methodsFor: 'structure' stamp: 'jmv 10/21/2020 15:56:00' prior: 50550235 overrides: 16876664! - world - ^self! ! -!WorldMorph methodsFor: 'misc' stamp: 'jmv 10/21/2020 16:29:57' prior: 50550239 overrides: 50551033! - buildMagnifiedBackgroundImage - super buildMagnifiedBackgroundImage. - - canvas ifNotNil: [ :c | - (backgroundImage depth = 32 and: [ c form depth < 32 ]) ifTrue: [ - backgroundImage _ backgroundImage orderedDither32To16 ]]! ! -!WorldMorph methodsFor: 'misc' stamp: 'jmv 10/21/2020 16:52:25' prior: 50550249! - fillRects: rectangleList - "For testing. Flashes the given list of rectangles on the Display so you can watch incremental redisplay at work." - - - | blt screenRect | - blt _ (BitBlt toForm: Display) - sourceForm: nil; - sourceOrigin: `0@0`; - clipRect: self viewBox; - combinationRule: Form over. - - rectangleList do: [:r | - screenRect _ r translatedBy: self viewBox origin. - blt fillColor: Color random. - blt destRect: screenRect; copyBits. - Display forceToScreen: screenRect ]. - - (Delay forMilliseconds: 50) wait! ! -!WorldMorph methodsFor: 'misc' stamp: 'jmv 10/21/2020 16:36:53' prior: 50550268! - restoreDisplay - self - morphExtent: Display extent; - handsDo: [ :h | h visible: true ]; - fullRepaintNeeded! ! -!WorldMorph methodsFor: 'menu & halo' stamp: 'jmv 10/21/2020 16:39:09' prior: 50550275 overrides: 16876144! - addCustomMenuItems: menu hand: aHandMorph - "Add morph-specific menu itemns to the menu for the hand" - - super addCustomMenuItems: menu hand: aHandMorph. - menu - add: 'desktop menu...' - target: self - action: #invokeWorldMenu. - menu addLine! ! -!WorldMorph methodsFor: 'printing' stamp: 'jmv 10/21/2020 16:44:07' prior: 50550286 overrides: 50500307! - printOn: aStream - "Reimplemented to add a tag showing that the receiver is currently functioning as a 'world', if it is" - - aStream nextPutAll: ' [world]'! ! -!WorldMorph methodsFor: 'halos and balloon help' stamp: 'jmv 10/21/2020 16:46:19' prior: 50550294! -deleteBalloonTarget: aMorph - "Delete the balloon help targeting the given morph" - self handsDo:[:h| h deleteBalloonTarget: aMorph].! ! -!WorldMorph methodsFor: 'halos and balloon help' stamp: 'jmv 10/21/2020 16:47:14' prior: 50550302 overrides: 50551324! - wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph - "Answer whether the receiver would like to offer the halo handle with the given selector (e.g. #addCollapseHandle:)" - - ^#(addDebugHandle: addMenuHandle: addHelpHandle:) - statePointsTo: aSelector! ! -!WorldMorph methodsFor: 'taskbar' stamp: 'jmv 10/21/2020 17:00:39' prior: 50550313! - hideTaskbar - taskbar ifNotNil: [ - taskbar delete. - taskbar _ nil ]! ! -!WorldMorph methodsFor: 'taskbar' stamp: 'jmv 10/21/2020 17:00:47' prior: 50550318! - showTaskbar - - taskbar ifNil: [ - taskbar _ TaskbarMorph newRow. - taskbar openInWorld: self ]! ! -!WorldMorph methodsFor: 'taskbar' stamp: 'jmv 10/21/2020 17:00:30' prior: 50550324 overrides: 50337100! - taskbar - ^taskbar! ! -!WorldMorph methodsFor: 'taskbar' stamp: 'jmv 10/21/2020 17:01:03' prior: 50550327! - taskbarDeleted - taskbar _ nil! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/21/2020 17:04:22' prior: 50550331! - collapseAll - "Collapse all windows" - (SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed not ]) - reverseDo: [ :w | w collapse. self displayWorld]. - self collapseNonWindows! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/21/2020 17:00:27' prior: 50550340! - restoreAll - "Expand all windows to their previous state" - taskbar - ifNotNil: [ :tb | tb restoreAll ]! ! -!WorldMorph methodsFor: 'defaul desktop' stamp: 'jmv 10/21/2020 17:08:07' prior: 50550346! - recreateDefaultDesktop - | editor | - self whenUIinSafeState: [ - self hideTaskbar. - (submorphs - select: [ :ea | ea class == SystemWindow or: [ea class == TranscriptWindow]]) - do: [ :ea | ea delete ]. - TranscriptWindow openTranscript - morphPosition: 5 @ 283; - morphExtent: 990 @ 400. - editor _ TextEditor openTextEditor - morphPosition: 456 @ 3; - morphExtent: 900 @ 680. - editor setLabel: 'About Cuis'. - editor model actualContents: Utilities defaultTextEditorContents. - Theme current useTaskbar ifTrue: [self showTaskbar]. - ].! ! -!WorldMorph methodsFor: 'defaul desktop' stamp: 'jmv 10/21/2020 17:08:22' prior: 50550366! - tearDownDesktop - self whenUIinSafeState: [ - self hideTaskbar. - submorphs - do: [ :ea | (ea is: #SystemWindow) ifTrue: [ ea delete ]]].! ! -!WorldMorph methodsFor: 'events' stamp: 'jmv 10/21/2020 17:11:53' prior: 50550374 overrides: 16874466! - click: aMouseButtonEvent localPosition: localEventPosition - ^self whenUIinSafeState: [self mouseButton2Activity]! ! -!WorldMorph class methodsFor: 'instance creation' stamp: 'jmv 10/21/2020 15:38:59' prior: 50550381! - newWorld - " -[ - UISupervisor stopUIProcess. - UISupervisor spawnNewMorphicProcessFor: WorldMorph newWorld -] fork. - " - | w | - w _ self new. - w morphPosition: `0@0` extent: Display extent. - w setCanvas: Display getCanvas. - w handsDo: [ :h | - h privateOwner: w ]. - ^w! ! -!WorldMorph class methodsFor: 'system startup' stamp: 'jmv 10/21/2020 16:49:42' prior: 50550393 overrides: 50551389! -initClassCachedState - "Should use some other way to find relevant instances" - self flag: #jmvVer2. - self allInstancesDo: [ :each | - each buildMagnifiedBackgroundImage. - each redrawNeeded ]. - Cursor defaultCursor activateCursor.! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 10/21/2020 17:02:09' prior: 50550404! - preferencesMenu - "Build the preferences menu for the world." - - ^ (self menu: 'Preferences...') - addItemsFromDictionaries: { - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Font Sizes...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Set System Font...'. - #object -> FontFamily. - #selector -> #promptUserAndSetDefault. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'change the current system font family.' - } asDictionary. - { - #label -> 'Load all TrueType Fonts'. - #object -> FontFamily. - #selector -> #readAdditionalTrueTypeFonts. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'Load additional TrueType fonts included with Cuis.' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }! ! -!TheWorldMenu methodsFor: 'windows & flaps menu' stamp: 'jmv 10/21/2020 16:56:57' prior: 50550508! - windowsMenu - "Build the windows menu for the world." - - ^ (self menu: 'Windows') - addItemsFromDictionaries: `{ - { - #label -> 'Find Window'. - #object -> #myWorld. - #selector -> #findWindow:. - #icon -> #windowIcon. - #balloonText -> 'Presents a list of all windows; if you choose one from the list, it becomes the active window.' - } asDictionary. - { - #label -> 'Find changed Browsers...'. - #object -> #myWorld. - #selector -> #findDirtyBrowsers:. - #icon -> #editFindReplaceIcon. - #balloonText -> 'Presents a list of browsers that have unsubmitted changes; if you choose one from the list, it becomes the active window.' - } asDictionary. - { - #label -> 'Find changed Windows...'. - #object -> #myWorld. - #selector -> #findDirtyWindows:. - #icon -> #newWindowIcon. - #balloonText -> 'Presents a list of all windows that have unsubmitted changes; if you choose one from the list, it becomes the active window.' - } asDictionary. - nil. - { - #label -> 'Find a Transcript'. - #object -> #myWorld. - #selector -> #findATranscript:. - #icon -> #printerIcon. - #balloonText -> 'Brings an open Transcript to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find a FileList'. - #object -> #myWorld. - #selector -> #findAFileList:. - #icon -> #systemFileManagerIcon. - #balloonText -> 'Brings an open fileList to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find a Change Sorter'. - #object -> #myWorld. - #selector -> #findAChangeSorter:. - #icon -> #changesIcon. - #balloonText -> 'Brings an open change sorter to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find Message Names'. - #object -> #myWorld. - #selector -> #findAMessageNamesWindow:. - #icon -> #inspectIcon. - #balloonText -> 'Brings an open MessageNames window to the front, creating one if necessary, and makes it the active window' - } asDictionary. - nil. - { - #label -> 'Tile open windows'. - #object -> TileResizeMorph. - #selector -> #tileOpenWindows. - #icon -> #windowIcon. - #balloonText -> 'Tile open windows'. - } asDictionary. - { - #label -> 'Collapse all Windows'. - #object -> #myWorld. - #selector -> #collapseAll. - #icon -> #collapseIcon. - #balloonText -> 'Reduce all open windows to collapsed forms that only show titles.' - } asDictionary. - { - #label -> 'Restore all Windows'. - #object -> #myWorld. - #selector -> #restoreAll. - #icon -> #expandIcon. - #balloonText -> 'Restore all collapsed windows back to their previous forms.' - } asDictionary. - { - #label -> 'Close top Window'. - #object -> SystemWindow. - #selector -> #closeTopWindow. - #icon -> #closeIcon. - #balloonText -> 'Close the topmost window if possible.' - } asDictionary. - { - #label -> 'Send top Window to back'. - #object -> SystemWindow. - #selector -> #sendTopWindowToBack. - #icon -> #goBottomIcon. - #balloonText -> 'Make the topmost window become the backmost one, and activate the window just beneath it.' - } asDictionary. - { - #label -> 'Move Windows onscreen'. - #object -> #myWorld. - #selector -> #bringWindowsFullOnscreen. - #icon -> #displayIcon. - #balloonText -> 'Make all windows fully visible on the screen' - } asDictionary. - nil. - { - #label -> 'Delete unchanged Windows'. - #object -> #myWorld. - #selector -> #closeUnchangedWindows. - #icon -> #warningIcon. - #balloonText -> 'Deletes all windows that do not have unsaved text edits.' - } asDictionary. - { - #label -> 'Delete non Windows'. - #object -> #myWorld. - #selector -> #deleteNonWindows. - #icon -> #warningIcon. - #balloonText -> 'Deletes all non-window morphs lying on the world.' - } asDictionary. - { - #label -> 'Delete Both of the Above'. - #selector -> #cleanUpWorld. - #icon -> #warningIcon. - #balloonText -> 'Deletes all unchanged windows and also all non-window morphs lying on the world, other than flaps.' - } asDictionary. - }`! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -[ - | oldWorld ba roots w | - oldWorld _ UISupervisor ui. - ba _ oldWorld instVarNamed: 'backgroundImageData'. - roots _ oldWorld instVarNamed: 'submorphs'. - roots _ roots reject: [ :m | m is: #TaskbarMorph ]. - oldWorld _ nil. - UISupervisor stopUIProcess. - w _ WorldMorph newWorld. - w - "recreateDefaultDesktop;" - backgroundImageData: ba; - addAllMorphs: roots; - showTaskbar. - UISupervisor spawnNewMorphicProcessFor: w. - 'Please do [Install New Updates] again.' print. -] fork. -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4420-NewPasteUpMorphAndWorldMorph-JuanVuletich-2020Oct21-17h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4417] on 21 October 2020 at 5:50:56 pm'! -!Morph commentStamp: 'jmv 10/21/2020 17:46:54' prior: 50548733! - A Morph (from the Greek "shape" or "form") is an interactive graphical object. General information on the Morphic system can be found at http://wiki.squeak.org/squeak/morph. - -Morphs exist in a tree, rooted at a World (a WorldMorph). The morphs owned by a morph are its submorphs. Morphs are drawn recursively; if a Morph has no owner it never gets -drawn. To hide a Morph and its submorphs, send the #visible: message. - -Every morph has a local coordinate system to interpret positions. -Local coordinates are used in the #drawOn: method (the Canvas understands positions in the local coordinate system), for the positions of submorphs (for example #morphPosition and #morphPosition:) and for positions carried by mouse events. - -Events are delivered to morphs in Z-order, i.e. if a morph occludes another the event is only delivered to the foremost (just like physical objects). Events received by a morph carry positions in the local coordinate system. - -Morphs can be translated by an offset, rotated around their center, orbited (rotated around the owner center), and zoomed (i.e. scaled). - -Every morph has an associated transformation that defines the inner space where the morph is drawn and where the submorphs live. These transformations don't change anything from the internal point of view of the morph. - -Structure: -instance var Type Description -owner Morph or nil My parent Morph, or nil for the top-level Morph, which is a WorldMorph -submorphs Array My child Morphs. -location GeometryTransformation Specifies position (and possibly, angle of rotation and scale change) inside owner - See comment at GeometryTransformation! -!PasteUpMorph commentStamp: '' prior: 50550700! - My instances are free areas where you can play with Morphs. Most important, the World is an instance of my subclass WorldMorph.! -!WorldMorph commentStamp: '' prior: 50550735! - A WorldMorph is a kind of PasteUpMorph that can act as the root morph of a Morphic system. Usually uses the whole Display. - -activeHand -- a HandMorph -hands -- Array of HandMorphs (typically only one) representing the Cursor and its event queue. -canvas -- BitBlitCanvas on the DisplayScreen. (Display getCanvas) -damageRecorder -- the DamageRecorder for the Display -stepList -- a Heap of StepMessage. Each morph which wants stepping has a StepMessage here. - See comment in #Morph>>stepAt: -lastStepTime -- 'now' as last sampled at step. (Time localMillisecondClock) -lastStepMessage -- nil or a selector -lastCycleTime -- 'now' as last sampled (Time localMillisecondClock) -alarms -- a Heap of MorphicAlarm. See comment in #Morph>>addAlarm:after: - An _alarm_ is an action to be done once, vs a _step_ which is cycled. -lastAlarm -- 'now' as sampled at last alarm (Time localMillisecondClock). -drawingFailureMorphs -- a WeakIdentitySet of Morphs with drawing failures -waitDelay -- a Delay -pause -- A 'phase-locked loop' style value to help regularise the step/alarm/event service rate. -lastCycleHadAnyEvent -- a boolean -! -!SystemDictionary methodsFor: 'shrinking' stamp: 'jmv 10/21/2020 17:40:03' prior: 50548836! - reduceCuis - " - Smalltalk reduceCuis - " - | keep n unused newDicts oldDicts | - - self nominallyUnsent: #reduceCuis. - - "Remove icons" - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - WorldMorph allInstancesDo: [ :w | - w backgroundImageData: nil. - w submorphsDo: [ :a | a delete ]]. - Preferences useNoMenuIcons. - Theme current initialize. - Theme content: nil. - Color shutDown. - BitBltCanvas releaseClassCachedState. - - Transcript clear. - Clipboard default initialize. - - - "Remove some methods, even if they have senders." - Utilities removeSelector: #vmStatisticsReportString. - SystemDictionary removeSelector: #recreateSpecialObjectsArray. - - StrikeFont saveSpace. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - - keep := OrderedCollection new. - keep addAll: #(SpaceTally DynamicTypingSmalltalkCompleter). - AppLauncher appGlobalName ifNotNil: [ :any | - keep add: any ]. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - [ - #hereWeGo print. - unused do: [:c | - c print. - (Smalltalk at: c) removeFromSystem]. - n := Smalltalk removeAllUnSentMessages. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - n > 0 or: [ - unused notEmpty ]] whileTrue. - ChangeSet zapAllChangeSets. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - Symbol rehash. - - "Shrink method dictionaries." - Smalltalk garbageCollect. - oldDicts _ MethodDictionary allInstances. - newDicts _ Array new: oldDicts size. - oldDicts withIndexDo: [:d :index | - newDicts at: index put: d rehashWithoutBecome ]. - oldDicts elementsExchangeIdentityWith: newDicts. - oldDicts _ newDicts _ nil. - - SmalltalkCompleter initialize . - - "Sanity checks" -" Undeclared - Smalltalk cleanOutUndeclared - Smalltalk browseUndeclaredReferences - Smalltalk obsoleteClasses - Smalltalk obsoleteBehaviors - Smalltalk browseObsoleteMethodReferences - SmalltalkImage current fixObsoleteReferences - Smalltalk browseAllUnimplementedCalls"! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 17:47:25' prior: 16875287! - fontPreferenceChanged - "Preferred fonts scale a number of window relations. - Let morphs which rely on this updte themselves. - - Note that the fontPreferenceChanged message is typically - sent to the current world. As WorldMorph inherits from me - the code below works fine for this." - - "I do nothing myself but my submorphs may." - - self submorphsDo: [ :m | m fontPreferenceChanged. ]! ! -!Morph methodsFor: 'testing' stamp: 'jmv 10/21/2020 17:38:51' prior: 50548904! - isOwnedByWorld - ^owner isWorldMorph! ! -!MorphicCanvas methodsFor: 'initialization' stamp: 'jmv 10/21/2020 17:49:39' prior: 50531445! - world: aWorldMorph - world _ aWorldMorph. - self into: world! ! - -'From Cuis 5.0 [latest update: #4417] on 21 October 2020 at 5:50:56 pm'! -!Morph commentStamp: 'jmv 10/21/2020 17:46:54' prior: 50552500! - A Morph (from the Greek "shape" or "form") is an interactive graphical object. General information on the Morphic system can be found at http://wiki.squeak.org/squeak/morph. - -Morphs exist in a tree, rooted at a World (a WorldMorph). The morphs owned by a morph are its submorphs. Morphs are drawn recursively; if a Morph has no owner it never gets -drawn. To hide a Morph and its submorphs, send the #visible: message. - -Every morph has a local coordinate system to interpret positions. -Local coordinates are used in the #drawOn: method (the Canvas understands positions in the local coordinate system), for the positions of submorphs (for example #morphPosition and #morphPosition:) and for positions carried by mouse events. - -Events are delivered to morphs in Z-order, i.e. if a morph occludes another the event is only delivered to the foremost (just like physical objects). Events received by a morph carry positions in the local coordinate system. - -Morphs can be translated by an offset, rotated around their center, orbited (rotated around the owner center), and zoomed (i.e. scaled). - -Every morph has an associated transformation that defines the inner space where the morph is drawn and where the submorphs live. These transformations don't change anything from the internal point of view of the morph. - -Structure: -instance var Type Description -owner Morph or nil My parent Morph, or nil for the top-level Morph, which is a WorldMorph -submorphs Array My child Morphs. -location GeometryTransformation Specifies position (and possibly, angle of rotation and scale change) inside owner - See comment at GeometryTransformation! -!PasteUpMorph commentStamp: '' prior: 50552555! - My instances are free areas where you can play with Morphs. Most important, the World is an instance of my subclass WorldMorph.! -!WorldMorph commentStamp: '' prior: 50552561! - A WorldMorph is a kind of PasteUpMorph that can act as the root morph of a Morphic system. Usually uses the whole Display. - -activeHand -- a HandMorph -hands -- Array of HandMorphs (typically only one) representing the Cursor and its event queue. -canvas -- BitBlitCanvas on the DisplayScreen. (Display getCanvas) -damageRecorder -- the DamageRecorder for the Display -stepList -- a Heap of StepMessage. Each morph which wants stepping has a StepMessage here. - See comment in #Morph>>stepAt: -lastStepTime -- 'now' as last sampled at step. (Time localMillisecondClock) -lastStepMessage -- nil or a selector -lastCycleTime -- 'now' as last sampled (Time localMillisecondClock) -alarms -- a Heap of MorphicAlarm. See comment in #Morph>>addAlarm:after: - An _alarm_ is an action to be done once, vs a _step_ which is cycled. -lastAlarm -- 'now' as sampled at last alarm (Time localMillisecondClock). -drawingFailureMorphs -- a WeakIdentitySet of Morphs with drawing failures -waitDelay -- a Delay -pause -- A 'phase-locked loop' style value to help regularise the step/alarm/event service rate. -lastCycleHadAnyEvent -- a boolean -! -!SystemDictionary methodsFor: 'shrinking' stamp: 'jmv 10/21/2020 17:40:03' prior: 50552602! - reduceCuis - " - Smalltalk reduceCuis - " - | keep n unused newDicts oldDicts | - - self nominallyUnsent: #reduceCuis. - - "Remove icons" - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - WorldMorph allInstancesDo: [ :w | - w backgroundImageData: nil. - w submorphsDo: [ :a | a delete ]]. - Preferences useNoMenuIcons. - Theme current initialize. - Theme content: nil. - Color shutDown. - BitBltCanvas releaseClassCachedState. - - Transcript clear. - Clipboard default initialize. - - - "Remove some methods, even if they have senders." - Utilities removeSelector: #vmStatisticsReportString. - SystemDictionary removeSelector: #recreateSpecialObjectsArray. - - StrikeFont saveSpace. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - - keep := OrderedCollection new. - keep addAll: #(SpaceTally DynamicTypingSmalltalkCompleter). - AppLauncher appGlobalName ifNotNil: [ :any | - keep add: any ]. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - [ - #hereWeGo print. - unused do: [:c | - c print. - (Smalltalk at: c) removeFromSystem]. - n := Smalltalk removeAllUnSentMessages. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - n > 0 or: [ - unused notEmpty ]] whileTrue. - ChangeSet zapAllChangeSets. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - Symbol rehash. - - "Shrink method dictionaries." - Smalltalk garbageCollect. - oldDicts _ MethodDictionary allInstances. - newDicts _ Array new: oldDicts size. - oldDicts withIndexDo: [:d :index | - newDicts at: index put: d rehashWithoutBecome ]. - oldDicts elementsExchangeIdentityWith: newDicts. - oldDicts _ newDicts _ nil. - - SmalltalkCompleter initialize . - - "Sanity checks" -" Undeclared - Smalltalk cleanOutUndeclared - Smalltalk browseUndeclaredReferences - Smalltalk obsoleteClasses - Smalltalk obsoleteBehaviors - Smalltalk browseObsoleteMethodReferences - SmalltalkImage current fixObsoleteReferences - Smalltalk browseAllUnimplementedCalls"! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 17:47:25' prior: 50552669! - fontPreferenceChanged - "Preferred fonts scale a number of window relations. - Let morphs which rely on this updte themselves. - - Note that the fontPreferenceChanged message is typically - sent to the current world. As WorldMorph inherits from me - the code below works fine for this." - - "I do nothing myself but my submorphs may." - - self submorphsDo: [ :m | m fontPreferenceChanged. ]! ! -!Morph methodsFor: 'testing' stamp: 'jmv 10/21/2020 17:38:51' prior: 50552684! - isOwnedByWorld - ^owner isWorldMorph! ! -!MorphicCanvas methodsFor: 'initialization' stamp: 'jmv 10/21/2020 17:49:39' prior: 50552689! - world: aWorldMorph - world _ aWorldMorph. - self into: world! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/21/2020 17:48:51' prior: 50544180! - computeDamage: aWorldMorph repair: aDamageRecorder rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage - "Iterate front to back while computing damage to actually repair for each morph, and for world background. - Answer uncoveredDamage, the areas where World background needs to be redrawn." - - | uncoveredDamage morph morphDamage prevMorphDamage reuseInstance morphBefore | - morphDamage _ OrderedCollection new. - prevMorphDamage _ OrderedCollection new. - uncoveredDamage _ aDamageRecorder damageReportedOther. - "Iterate from front to back" - 1 to: rootMorphs size do: [ :i | - morph _ rootMorphs at: i. - morphDamage removeAll. - (aDamageRecorder damageReportedFor: morph) ifNotNil: [ :r | - morphDamage add: r ]. - 1 to: i-1 do: [ :j | - reuseInstance _ prevMorphDamage. - prevMorphDamage _ morphDamage. - morphDamage _ reuseInstance removeAll. - morphBefore _ rootMorphs at: j. - prevMorphDamage do: [ :r | - morphBefore addPossiblyUncoveredAreasIn: r to: morphDamage ]]. - (Rectangle merging: morphDamage) ifNotNil: [ :morphDamageRect | - rootMorphsDamage at: i put: morphDamageRect. - morph addPossiblyUncoveredAreasIn: morphDamageRect to: uncoveredDamage ]]. - - ^ uncoveredDamage! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/21/2020 17:48:42' prior: 50544032! - drawWorld: aWorldMorph repair: aDamageRecorder - "Redraw the damaged areas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rootMorphs rootMorphsDamage worldDamage | - "Update #displayBounds for all dirty morphs (marked as such with #redrawNeeded). - Also add the updated bounds to aDamageRecorder, and update bounds of morphs carried by hand." - self updatingMorphBoundsDo: [ - aWorldMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - self updateHandsDisplayBounds: aWorldMorph ]. - - rootMorphs _ aWorldMorph privateSubmorphs. - rootMorphsDamage _ Array new: rootMorphs size. - - worldDamage _ self computeDamage: aWorldMorph repair: aDamageRecorder - rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage. - - self drawWorldBackground: aWorldMorph rects: worldDamage. - - self drawWorld: aWorldMorph - rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage - allDamage: worldDamage. - - aDamageRecorder reset. - ^ worldDamage! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/21/2020 17:49:10' prior: 50544221! - drawWorld: aWorldMorph rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage allDamage: worldDamage - "Redraw the damaged areas. - Draw each morph just once, merging rectanges to be repaired as needed." - - | morph morphDamage | - - "Iterate from back to front." - rootMorphs size to: 1 by: -1 do: [ :i | - morph _ rootMorphs at: i. - morph visible ifTrue: [ - morphDamage _ rootMorphsDamage at: i. - morph displayFullBounds ifNotNil: [ :morphFullBounds | - worldDamage do: [ :r | | intersection | - intersection _ r intersect: morphFullBounds. - intersection hasPositiveExtent ifTrue: [ - morphDamage _ intersection quickMerge: morphDamage ]]]. - morphDamage ifNotNil: [ - self newClipRect: morphDamage. - self fullDraw: morph. - worldDamage add: morphDamage ]]].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/21/2020 17:49:27' prior: 50544021! - drawWorldBackground: aWorldMorph rects: worldBackgroundDamage - "Draw worldBackgroundDamage rects for aWorldMorph. - Do not include submorphs." - - worldBackgroundDamage do: [ :r | - aWorldMorph drawOn: (self newClipRect: r) ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/21/2020 17:49:33' prior: 50539262! -updateHandsDisplayBounds: aWorldMorph - "Update displayBounds for carried morphs if never set. - Useful for new morph, that are created and attached to the hand." - - aWorldMorph handsDo: [ :hand | - hand hasSubmorphs ifTrue: [ - self into: hand. - hand submorphsDo: [ :morph | - self updateDisplayBounds: morph ]. - self outOfMorph ]]! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 10/21/2020 17:39:15' prior: 50548915! - activeSubclass: aMorphicCanvasSubclass - ActiveSubclass _ aMorphicCanvasSubclass. - WorldMorph allInstancesDo: [ :w | w setCanvas ]! ! - -PasteUpMorph removeSelector: #is:! - -!methodRemoval: PasteUpMorph #is: stamp: 'Install-4421-RemoveOldPasteUpMorphAndWorldState-JuanVuletich-2020Oct21-17h35m-jmv.001.cs.st 10/24/2020 17:29:27'! -is: aSymbol - ^ aSymbol == #PasteUpMorph or: [ super is: aSymbol ]! - -Smalltalk removeClassNamed: #OldPasteUpMorph! - -!classRemoval: #OldPasteUpMorph stamp: 'Install-4421-RemoveOldPasteUpMorphAndWorldState-JuanVuletich-2020Oct21-17h35m-jmv.001.cs.st 10/24/2020 17:29:27'! -KernelMorph subclass: #OldPasteUpMorph - instanceVariableNames: 'worldState backgroundImage backgroundImageData taskbar' - classVariableNames: 'WindowEventHandler' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -Smalltalk removeClassNamed: #WorldState! - -!classRemoval: #WorldState stamp: 'Install-4421-RemoveOldPasteUpMorphAndWorldState-JuanVuletich-2020Oct21-17h35m-jmv.001.cs.st 10/24/2020 17:29:27'! -Object subclass: #WorldState - instanceVariableNames: 'hands viewBox canvas damageRecorder stepList lastStepTime lastStepMessage lastCycleTime alarms lastAlarmTime remoteServer drawingFailingMorphs waitDelay pause lastCycleHadAnyEvent activeHand world' - classVariableNames: 'DeferredUIMessages' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4421-RemoveOldPasteUpMorphAndWorldState-JuanVuletich-2020Oct21-17h35m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4418] on 22 October 2020 at 12:37:46 pm'! -!WorldMorph methodsFor: 'accessing' stamp: 'jmv 10/22/2020 12:31:25' overrides: 50550794! - handlesKeyboard - - ^ true ! ! -!WorldMorph methodsFor: 'change reporting' stamp: 'jmv 10/22/2020 12:23:07' overrides: 50550805! - addedMorph: aMorph - "Notify the receiver that the given morph was just added." - super addedMorph: aMorph. - self taskbar ifNotNil: [ :tb | - tb wasOpened: aMorph ]! ! -!WorldMorph methodsFor: 'change reporting' stamp: 'jmv 10/22/2020 12:33:24' overrides: 50550814! - removedMorph: aMorph - "Notify the receiver that aMorph was just removed from its children" - super removedMorph: aMorph. - self taskbar ifNotNil: [ :tb | - tb wasDeleted: aMorph ]! ! -!WorldMorph methodsFor: 'dropping/grabbing' stamp: 'jmv 10/22/2020 12:25:35' overrides: 50550832! - allowsFilesDrop - - ^ true! ! -!WorldMorph methodsFor: 'dropping/grabbing' stamp: 'jmv 10/22/2020 12:25:43' overrides: 50550859! - dropFiles: aDropFilesEvent - - (DropFilesAction for: aDropFilesEvent) value! ! -!WorldMorph methodsFor: 'event handling' stamp: 'jmv 10/22/2020 12:20:47' overrides: 50550913! - mouseButton2Activity - - ^self invokeWorldMenu! ! -!WorldMorph methodsFor: 'events' stamp: 'jmv 10/22/2020 12:32:01' overrides: 50550865! - keyStroke: aKeyboardEvent - "Handle a keystroke event." - (aKeyboardEvent commandAltKeyPressed or: [ aKeyboardEvent controlKeyPressed ]) - ifTrue: [ - aKeyboardEvent keyCharacter = $b ifTrue: [ BrowserWindow openBrowser ]. - aKeyboardEvent keyCharacter = $f ifTrue: [ BrowserWindow findClass ]. - aKeyboardEvent keyCharacter = $F ifTrue: [ MessageSetWindow findInSourceCode ]. - ]. - "aKeyboardEvent keyCharacter print." - ^ super keyStroke: aKeyboardEvent! ! -!WorldMorph methodsFor: 'events' stamp: 'jmv 10/22/2020 12:35:57' overrides: 50550900! - windowEvent: aMorphicEvent - - aMorphicEvent windowEventType == #windowClose - ifTrue: [ - ^TheWorldMenu basicNew quitSession] -! ! -!WorldMorph methodsFor: 'interaction loop' stamp: 'jmv 10/22/2020 12:32:35' overrides: 50550958! - mainLoop - - - self clearWaitDelay. - self setCanvas. - [ - self doOneCycle. - Processor yield. - true ] - whileTrue: []! ! -!WorldMorph methodsFor: 'interaction loop' stamp: 'jmv 10/22/2020 12:37:28' overrides: 50550965! - runProcess - - | process | - - process _ [ self mainLoop ] newProcess. - process - priority: Processor userSchedulingPriority; - name: 'Morphic UI'; - animatedUI: self. - - ^ process! ! -!WorldMorph methodsFor: 'menu & halo' stamp: 'jmv 10/22/2020 12:22:45' overrides: 50550974! - addWorldHaloMenuItemsTo: aMenu hand: aHandMorph - "Add standard halo items to the menu, given that the receiver is a World" - - | unlockables | - self addColorMenuItems: aMenu hand: aHandMorph. - -" aMenu addLine. - self addWorldToggleItemsToHaloMenu: aMenu." - aMenu addLine. - self addCopyItemsTo: aMenu. - self addExportMenuItems: aMenu hand: aHandMorph. - - self addDebuggingItemsTo: aMenu hand: aHandMorph. - - aMenu addLine. - aMenu defaultTarget: self. - - aMenu addLine. - - unlockables _ self submorphs select: - [ :m | m isLocked]. - unlockables size = 1 ifTrue: [ - aMenu add: ('unlock "{1}"' format:{unlockables first printStringLimitedTo: 40})action: #unlockContents]. - unlockables size > 1 ifTrue: [ - aMenu add: 'unlock all contents' action: #unlockContents. - aMenu add: 'unlock...' action: #unlockOneSubpart]. - - aMenu defaultTarget: aHandMorph. -! ! -!WorldMorph methodsFor: 'object serialization' stamp: 'jmv 10/22/2020 12:32:58' overrides: 50551341! - objectForDataStream: refStrm - "I am about to be written on an object file. Write a path to me in the other system instead." - - | dp | - dp _ DiskProxy global: #Smalltalk selector: #runningWorld args: #(). - refStrm replace: self with: dp. - ^ dp! ! -!WorldMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 10/22/2020 12:22:24' overrides: 50551064! - addMorph: aMorph centeredNear: aPoint - "Add the given morph to this world, attempting to keep its center as close to the given point possible while also keeping the it entirely within the bounds of this world." - - | trialRect delta | - trialRect _ Rectangle center: aPoint extent: aMorph morphExtent. - delta _ trialRect amountToTranslateWithin: self displayBounds. - self addMorph: aMorph. - aMorph morphPositionInWorld: trialRect origin + delta.! ! -!WorldMorph methodsFor: 'ui services' stamp: 'jmv 10/22/2020 12:34:19' overrides: 50551363! - request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock - "This is deprecated because using it requires blocking the user interface until the user provides a response. Please use the variants that are not modal." - ^ StringRequestMorph request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock! ! -!WorldMorph methodsFor: 'ui services' stamp: 'jmv 10/22/2020 12:34:32' overrides: 50551377! - request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock - ^ StringRequestMorph request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock! ! -!WorldMorph methodsFor: 'windows' stamp: 'jmv 10/22/2020 12:28:19' overrides: 50551352! - findATranscript - "Locate a transcript, open it, and bring it to the front. Create one if necessary" - - self - findAWindowSatisfying: [ :aWindow | aWindow model == Transcript] - orMakeOneUsing: [ TranscriptWindow openTranscript ]! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:26:09' overrides: 50551096! - bringWindowsFullOnscreen - "Make ever SystemWindow on the desktop be totally on-screen, whenever possible." - (SystemWindow - windowsIn: self - satisfying: [ :w | - w visible ]) do: [ :each | - each makeMeFullyVisible ]! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:26:30' overrides: 50551106! - closeUnchangedWindows - "Present a menu of window titles for all windows with changes, - and activate the one that gets chosen." - (SelectionMenu confirm: 'Do you really want to close all windows -except those with unaccepted edits?') ifFalse: [ ^ self ]. - (SystemWindow - windowsIn: self - satisfying: [ :w | - w visible and: [ w canDiscardEdits ]]) do: [ :w | - w delete ]! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:23:43' overrides: 50551121! - collapseNonWindows - self allNonWindowRelatedSubmorphs do: [ :m | - m collapse]! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:23:50' overrides: 50551127! - deleteNonWindows - (SelectionMenu confirm: -'Do you really want to discard all objects -that are not in windows?') - ifFalse: [^ self]. - - self allNonWindowRelatedSubmorphs do: [:m | - m delete ]! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:27:41' overrides: 50551136! - findAChangeSorter: evt - "Locate a change sorter, open it, and bring it to the front. Create one if necessary" - self - findAWindowSatisfying: [ :aWindow | - aWindow model isMemberOf: ChangeSorter] - orMakeOneUsing: [ ChangeSorterWindow open: ChangeSorter new label: nil ]! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:27:48' overrides: 50551148! - findAFileList: evt - "Locate a file list, open it, and bring it to the front. - Create one if necessary, respecting the Preference." - self - findAWindowSatisfying: [ :aWindow | - aWindow model class == FileList ] - orMakeOneUsing: [ - FileListWindow openFileList ]! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:27:57' overrides: 50551159! - findAMessageNamesWindow: evt - "Locate a MessageNames tool, open it, and bring it to the front. Create one if necessary" - self - findAWindowSatisfying: [ :aWindow | - aWindow model class == MessageNames ] - orMakeOneUsing: [ - MessageNamesWindow open: MessageNames new label: 'Message Names' ]! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:28:13' overrides: 50551171! - findATranscript: evt - "Locate a transcript, open it, and bring it to the front. Create one if necessary" - - self findATranscript! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:28:35' overrides: 50551178! - findAWindowSatisfying: qualifyingBlock orMakeOneUsing: makeBlock - "Locate a window satisfying a block, open it, and bring it to the front. Create one if necessary, by using the makeBlock" - | aWindow | - submorphs do: [ :aMorph | - (((aWindow _ aMorph) is: #SystemWindow) and: [ qualifyingBlock value: aWindow ]) ifTrue: [ - aWindow isCollapsed ifTrue: [ aWindow expand ]. - aWindow activateAndForceLabelToShow. - ^ self ]]. - "None found, so create one" - makeBlock value.! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:28:49' overrides: 50551196! - findDirtyBrowsers: evt - "Present a menu of window titles for browsers with changes, - and activate the one that gets chosen." - | menu | - menu _ MenuMorph new. - (SystemWindow - windowsIn: self - satisfying: [ :w | - w visible and: [ - (w model is: #CodeProvider) and: [ w canDiscardEdits not ]]]) do: [ :w | - menu - add: w label - target: w - action: #activate ]. - menu submorphs notEmpty ifTrue: [ menu popUpInWorld: self ]! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:28:59' overrides: 50551213! - findDirtyWindows: evt - "Present a menu of window titles for all windows with changes, - and activate the one that gets chosen." - | menu | - menu _ MenuMorph new. - (SystemWindow - windowsIn: self - satisfying: [ :w | - w visible and: [ w canDiscardEdits not ]]) do: [ :w | - menu - add: w label - target: w - action: #activate ]. - menu submorphs notEmpty ifTrue: [ menu popUpInWorld: self ]! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:29:06' overrides: 50551229! - findWindow: evt - "Present a menu names of windows and naked morphs, and activate the one that gets chosen. Collapsed windows appear below line, expand if chosen; naked morphs appear below second line; if any of them has been given an explicit name, that is what's shown, else the class-name of the morph shows; if a naked morph is chosen, bring it to front and have it don a halo." - | menu expanded collapsed nakedMorphs | - menu _ MenuMorph new. - expanded _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed not ]. - collapsed _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed ]. - nakedMorphs _ self submorphsSatisfying: [ :m | - (m is: #SystemWindow) not ]. - expanded isEmpty & (collapsed isEmpty & nakedMorphs isEmpty) ifTrue: [ ^ Smalltalk beep ]. - (expanded asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #activateAndForceLabelToShow. - w canDiscardEdits ifFalse: [ menu lastItem color: `Color red` ]]. - expanded isEmpty | (collapsed isEmpty & nakedMorphs isEmpty) ifFalse: [ menu addLine ]. - (collapsed asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #expand. - w canDiscardEdits ifFalse: [ menu lastItem color: `Color red` ]]. - nakedMorphs isEmpty ifFalse: [ menu addLine ]. - (nakedMorphs asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #comeToFrontAndAddHalo ]. - menu addTitle: 'find window'. - menu popUpInWorld: self! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:20:57' overrides: 50551283! - invokeWorldMenu - "Put up the world menu, triggered by the passed-in event. - Perhaps a good place to disable it if needed" - - | menu | - menu _ (TheWorldMenu new - world: self - hand: self activeHand) buildWorldMenu. - menu addTitle: Preferences desktopMenuTitle. - menu popUpInWorld: self! ! -!WorldMorph methodsFor: 'world state' stamp: 'jmv 10/22/2020 12:24:00' overrides: 50551295! - allNonWindowRelatedSubmorphs - "Answer all non-window submorphs that are not flap-related" - - ^submorphs - reject: [ :m | (m is: #SystemWindow) or: [ m is: #TaskbarMorph ] ]! ! -!WorldMorph methodsFor: 'world state' stamp: 'jmv 10/22/2020 12:27:17' overrides: 50551304! - deleteAllHalos - self haloMorphs do: - [ :m | m delete]! ! -!WorldMorph methodsFor: 'world state' stamp: 'jmv 10/22/2020 12:30:43' overrides: 50551309! - fullRepaintNeeded - self redrawNeeded. - SystemWindow - windowsIn: self - satisfying: [ :w | - w visible ifTrue: [ w makeMeVisible ]. - false ]! ! -!WorldMorph methodsFor: 'world state' stamp: 'jmv 10/22/2020 12:27:23' overrides: 50551317! - haloMorphs - ^ self hands collect:[:h| h halo] thenSelect:[:halo| halo notNil]! ! - -PasteUpMorph removeSelector: #findWindow:! - -!methodRemoval: PasteUpMorph #findWindow: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -findWindow: evt - "Present a menu names of windows and naked morphs, and activate the one that gets chosen. Collapsed windows appear below line, expand if chosen; naked morphs appear below second line; if any of them has been given an explicit name, that is what's shown, else the class-name of the morph shows; if a naked morph is chosen, bring it to front and have it don a halo." - | menu expanded collapsed nakedMorphs | - menu _ MenuMorph new. - expanded _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed not ]. - collapsed _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed ]. - nakedMorphs _ self submorphsSatisfying: [ :m | - (m is: #SystemWindow) not ]. - expanded isEmpty & (collapsed isEmpty & nakedMorphs isEmpty) ifTrue: [ ^ Smalltalk beep ]. - (expanded asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #activateAndForceLabelToShow. - w canDiscardEdits ifFalse: [ menu lastItem color: `Color red` ]]. - expanded isEmpty | (collapsed isEmpty & nakedMorphs isEmpty) ifFalse: [ menu addLine ]. - (collapsed asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #expand. - w canDiscardEdits ifFalse: [ menu lastItem color: `Color red` ]]. - nakedMorphs isEmpty ifFalse: [ menu addLine ]. - (nakedMorphs asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #comeToFrontAndAddHalo ]. - menu addTitle: 'find window'. - menu popUpInWorld: self! - -PasteUpMorph removeSelector: #closeUnchangedWindows! - -!methodRemoval: PasteUpMorph #closeUnchangedWindows stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -closeUnchangedWindows - "Present a menu of window titles for all windows with changes, - and activate the one that gets chosen." - (SelectionMenu confirm: 'Do you really want to close all windows -except those with unaccepted edits?') ifFalse: [ ^ self ]. - (SystemWindow - windowsIn: self - satisfying: [ :w | - w visible and: [ w canDiscardEdits ]]) do: [ :w | - w delete ]! - -PasteUpMorph removeSelector: #findATranscript:! - -!methodRemoval: PasteUpMorph #findATranscript: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -findATranscript: evt - "Locate a transcript, open it, and bring it to the front. Create one if necessary" - - self findATranscript! - -PasteUpMorph removeSelector: #keyStroke:! - -!methodRemoval: PasteUpMorph #keyStroke: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -keyStroke: aKeyboardEvent - "Handle a keystroke event." - (aKeyboardEvent commandAltKeyPressed or: [ aKeyboardEvent controlKeyPressed ]) - ifTrue: [ - aKeyboardEvent keyCharacter = $b ifTrue: [ BrowserWindow openBrowser ]. - aKeyboardEvent keyCharacter = $f ifTrue: [ BrowserWindow findClass ]. - aKeyboardEvent keyCharacter = $F ifTrue: [ MessageSetWindow findInSourceCode ]. - ]. - "aKeyboardEvent keyCharacter print." - ^ super keyStroke: aKeyboardEvent! - -PasteUpMorph removeSelector: #addedMorph:! - -!methodRemoval: PasteUpMorph #addedMorph: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -addedMorph: aMorph - "Notify the receiver that the given morph was just added." - super addedMorph: aMorph. - self taskbar ifNotNil: [ :tb | - tb wasOpened: aMorph ]! - -PasteUpMorph removeSelector: #mouseButton2Activity! - -!methodRemoval: PasteUpMorph #mouseButton2Activity stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -mouseButton2Activity - - ^self invokeWorldMenu! - -PasteUpMorph removeSelector: #findATranscript! - -!methodRemoval: PasteUpMorph #findATranscript stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -findATranscript - "Locate a transcript, open it, and bring it to the front. Create one if necessary" - - self - findAWindowSatisfying: [ :aWindow | aWindow model == Transcript] - orMakeOneUsing: [ TranscriptWindow openTranscript ]! - -PasteUpMorph removeSelector: #fullRepaintNeeded! - -!methodRemoval: PasteUpMorph #fullRepaintNeeded stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -fullRepaintNeeded - self redrawNeeded. - SystemWindow - windowsIn: self - satisfying: [ :w | - w visible ifTrue: [ w makeMeVisible ]. - false ]! - -PasteUpMorph removeSelector: #request:initialAnswer:orCancel:! - -!methodRemoval: PasteUpMorph #request:initialAnswer:orCancel: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock - "This is deprecated because using it requires blocking the user interface until the user provides a response. Please use the variants that are not modal." - ^ StringRequestMorph request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock! - -PasteUpMorph removeSelector: #windowEvent:! - -!methodRemoval: PasteUpMorph #windowEvent: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -windowEvent: aMorphicEvent - - aMorphicEvent windowEventType == #windowClose - ifTrue: [ - ^TheWorldMenu basicNew quitSession] -! - -PasteUpMorph removeSelector: #deleteAllHalos! - -!methodRemoval: PasteUpMorph #deleteAllHalos stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -deleteAllHalos - self haloMorphs do: - [ :m | m delete]! - -PasteUpMorph removeSelector: #request:initialAnswer:verifying:do:orCancel:! - -!methodRemoval: PasteUpMorph #request:initialAnswer:verifying:do:orCancel: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock - ^ StringRequestMorph request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock! - -PasteUpMorph removeSelector: #findDirtyWindows:! - -!methodRemoval: PasteUpMorph #findDirtyWindows: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -findDirtyWindows: evt - "Present a menu of window titles for all windows with changes, - and activate the one that gets chosen." - | menu | - menu _ MenuMorph new. - (SystemWindow - windowsIn: self - satisfying: [ :w | - w visible and: [ w canDiscardEdits not ]]) do: [ :w | - menu - add: w label - target: w - action: #activate ]. - menu submorphs notEmpty ifTrue: [ menu popUpInWorld: self ]! - -PasteUpMorph removeSelector: #mainLoop! - -!methodRemoval: PasteUpMorph #mainLoop stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -mainLoop - - - self clearWaitDelay. - self setCanvas. - [ - self doOneCycle. - Processor yield. - true ] - whileTrue: []! - -PasteUpMorph removeSelector: #dropFiles:! - -!methodRemoval: PasteUpMorph #dropFiles: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -dropFiles: aDropFilesEvent - - (DropFilesAction for: aDropFilesEvent) value! - -PasteUpMorph removeSelector: #handlesKeyboard! - -!methodRemoval: PasteUpMorph #handlesKeyboard stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -handlesKeyboard - - ^ true ! - -PasteUpMorph removeSelector: #findAMessageNamesWindow:! - -!methodRemoval: PasteUpMorph #findAMessageNamesWindow: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -findAMessageNamesWindow: evt - "Locate a MessageNames tool, open it, and bring it to the front. Create one if necessary" - self - findAWindowSatisfying: [ :aWindow | - aWindow model class == MessageNames ] - orMakeOneUsing: [ - MessageNamesWindow open: MessageNames new label: 'Message Names' ]! - -PasteUpMorph removeSelector: #collapseNonWindows! - -!methodRemoval: PasteUpMorph #collapseNonWindows stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -collapseNonWindows - self allNonWindowRelatedSubmorphs do: [ :m | - m collapse]! - -PasteUpMorph removeSelector: #findAChangeSorter:! - -!methodRemoval: PasteUpMorph #findAChangeSorter: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -findAChangeSorter: evt - "Locate a change sorter, open it, and bring it to the front. Create one if necessary" - self - findAWindowSatisfying: [ :aWindow | - aWindow model isMemberOf: ChangeSorter] - orMakeOneUsing: [ ChangeSorterWindow open: ChangeSorter new label: nil ]! - -PasteUpMorph removeSelector: #findAWindowSatisfying:orMakeOneUsing:! - -!methodRemoval: PasteUpMorph #findAWindowSatisfying:orMakeOneUsing: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -findAWindowSatisfying: qualifyingBlock orMakeOneUsing: makeBlock - "Locate a window satisfying a block, open it, and bring it to the front. Create one if necessary, by using the makeBlock" - | aWindow | - submorphs do: [ :aMorph | - (((aWindow _ aMorph) is: #SystemWindow) and: [ qualifyingBlock value: aWindow ]) ifTrue: [ - aWindow isCollapsed ifTrue: [ aWindow expand ]. - aWindow activateAndForceLabelToShow. - ^ self ]]. - "None found, so create one" - makeBlock value.! - -PasteUpMorph removeSelector: #findAFileList:! - -!methodRemoval: PasteUpMorph #findAFileList: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -findAFileList: evt - "Locate a file list, open it, and bring it to the front. - Create one if necessary, respecting the Preference." - self - findAWindowSatisfying: [ :aWindow | - aWindow model class == FileList ] - orMakeOneUsing: [ - FileListWindow openFileList ]! - -PasteUpMorph removeSelector: #findDirtyBrowsers:! - -!methodRemoval: PasteUpMorph #findDirtyBrowsers: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -findDirtyBrowsers: evt - "Present a menu of window titles for browsers with changes, - and activate the one that gets chosen." - | menu | - menu _ MenuMorph new. - (SystemWindow - windowsIn: self - satisfying: [ :w | - w visible and: [ - (w model is: #CodeProvider) and: [ w canDiscardEdits not ]]]) do: [ :w | - menu - add: w label - target: w - action: #activate ]. - menu submorphs notEmpty ifTrue: [ menu popUpInWorld: self ]! - -PasteUpMorph removeSelector: #activeHand! - -!methodRemoval: PasteUpMorph #activeHand stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -activeHand - "Answer the currently active hand, if any..." - ^self world ifNotNil: [ :w | w activeHand ]! - -PasteUpMorph removeSelector: #haloMorphs! - -!methodRemoval: PasteUpMorph #haloMorphs stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -haloMorphs - ^ self hands collect:[:h| h halo] thenSelect:[:halo| halo notNil]! - -PasteUpMorph removeSelector: #deleteNonWindows! - -!methodRemoval: PasteUpMorph #deleteNonWindows stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -deleteNonWindows - (SelectionMenu confirm: -'Do you really want to discard all objects -that are not in windows?') - ifFalse: [^ self]. - - self allNonWindowRelatedSubmorphs do: [:m | - m delete ]! - -PasteUpMorph removeSelector: #invokeWorldMenu! - -!methodRemoval: PasteUpMorph #invokeWorldMenu stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -invokeWorldMenu - "Put up the world menu, triggered by the passed-in event. - Perhaps a good place to disable it if needed" - - | menu | - menu _ (TheWorldMenu new - world: self - hand: self activeHand) buildWorldMenu. - menu addTitle: Preferences desktopMenuTitle. - menu popUpInWorld: self! - -PasteUpMorph removeSelector: #addMorph:centeredNear:! - -!methodRemoval: PasteUpMorph #addMorph:centeredNear: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -addMorph: aMorph centeredNear: aPoint - "Add the given morph to this world, attempting to keep its center as close to the given point possible while also keeping the it entirely within the bounds of this world." - - | trialRect delta | - trialRect _ Rectangle center: aPoint extent: aMorph morphExtent. - delta _ trialRect amountToTranslateWithin: self displayBounds. - self addMorph: aMorph. - aMorph morphPositionInWorld: trialRect origin + delta.! - -PasteUpMorph removeSelector: #objectForDataStream:! - -!methodRemoval: PasteUpMorph #objectForDataStream: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -objectForDataStream: refStrm - "I am about to be written on an object file. Write a path to me in the other system instead." - - | dp | - dp _ DiskProxy global: #Smalltalk selector: #runningWorld args: #(). - refStrm replace: self with: dp. - ^ dp! - -PasteUpMorph removeSelector: #runProcess! - -!methodRemoval: PasteUpMorph #runProcess stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -runProcess - - | process | - - process _ [ self mainLoop ] newProcess. - process - priority: Processor userSchedulingPriority; - name: 'Morphic UI'; - animatedUI: self. - - ^ process! - -PasteUpMorph removeSelector: #bringWindowsFullOnscreen! - -!methodRemoval: PasteUpMorph #bringWindowsFullOnscreen stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -bringWindowsFullOnscreen - "Make ever SystemWindow on the desktop be totally on-screen, whenever possible." - (SystemWindow - windowsIn: self - satisfying: [ :w | - w visible ]) do: [ :each | - each makeMeFullyVisible ]! - -PasteUpMorph removeSelector: #allowsFilesDrop! - -!methodRemoval: PasteUpMorph #allowsFilesDrop stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -allowsFilesDrop - - ^ true! - -PasteUpMorph removeSelector: #allNonWindowRelatedSubmorphs! - -!methodRemoval: PasteUpMorph #allNonWindowRelatedSubmorphs stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -allNonWindowRelatedSubmorphs - "Answer all non-window submorphs that are not flap-related" - - ^submorphs - reject: [ :m | (m is: #SystemWindow) or: [ m is: #TaskbarMorph ] ]! - -PasteUpMorph removeSelector: #addWorldHaloMenuItemsTo:hand:! - -!methodRemoval: PasteUpMorph #addWorldHaloMenuItemsTo:hand: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -addWorldHaloMenuItemsTo: aMenu hand: aHandMorph - "Add standard halo items to the menu, given that the receiver is a World" - - | unlockables | - self addColorMenuItems: aMenu hand: aHandMorph. - -" aMenu addLine. - self addWorldToggleItemsToHaloMenu: aMenu." - aMenu addLine. - self addCopyItemsTo: aMenu. - self addExportMenuItems: aMenu hand: aHandMorph. - - self addDebuggingItemsTo: aMenu hand: aHandMorph. - - aMenu addLine. - aMenu defaultTarget: self. - - aMenu addLine. - - unlockables _ self submorphs select: - [ :m | m isLocked]. - unlockables size = 1 ifTrue: [ - aMenu add: ('unlock "{1}"' format:{unlockables first printStringLimitedTo: 40})action: #unlockContents]. - unlockables size > 1 ifTrue: [ - aMenu add: 'unlock all contents' action: #unlockContents. - aMenu add: 'unlock...' action: #unlockOneSubpart]. - - aMenu defaultTarget: aHandMorph. -! - -PasteUpMorph removeSelector: #removedMorph:! - -!methodRemoval: PasteUpMorph #removedMorph: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:29:27'! -removedMorph: aMorph - "Notify the receiver that aMorph was just removed from its children" - super removedMorph: aMorph. - self taskbar ifNotNil: [ :tb | - tb wasDeleted: aMorph ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st----! - -'From Cuis 5.0 [latest update: #4422] on 23 October 2020 at 8:32:07 pm'! - -Morph subclass: #MovableMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -!classDefinition: #MovableMorph category: #'Morphic-Kernel' stamp: 'Install-4423-MovableMorph-JuanVuletich-2020Oct23-19h51m-jmv.001.cs.st 10/24/2020 17:29:27'! -Morph subclass: #MovableMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -MovableMorph subclass: #KernelMorph - instanceVariableNames: 'extent color' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -!classDefinition: #KernelMorph category: #'Morphic-Kernel' stamp: 'Install-4423-MovableMorph-JuanVuletich-2020Oct23-19h51m-jmv.001.cs.st 10/24/2020 17:29:27'! -MovableMorph subclass: #KernelMorph - instanceVariableNames: 'extent color' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -MovableMorph subclass: #WidgetMorph - instanceVariableNames: 'extent color borderWidth borderColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #WidgetMorph category: 'Morphic-Widgets' stamp: 'Install-4423-MovableMorph-JuanVuletich-2020Oct23-19h51m-jmv.001.cs.st 10/24/2020 17:29:28'! -MovableMorph subclass: #WidgetMorph - instanceVariableNames: 'extent color borderWidth borderColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4423-MovableMorph-JuanVuletich-2020Oct23-19h51m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4423] on 23 October 2020 at 11:01:16 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:52:00'! - scale - ^1! ! -!MovableMorph methodsFor: 'accessing' stamp: 'jmv 10/23/2020 20:34:55' overrides: 16873949! - location - ^location! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 21:51:57' overrides: 50519160! - allocHeightForFactor: aFactor - - "Morphs with LayoutSpecs may specify propottional layouts and minimum extents - amountToAlloc * proportion * factor >= minHeight - so breakeven is when - amountToAlloc = minHeight / proportion * factor" - | minHeight | - minHeight := self minimumLayoutHeight. - ^(self isProportionalHeight) - ifFalse: [ minHeight ] - ifTrue: [ minHeight / (aFactor * self layoutSpec privateProportionalHeight) ]! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 21:52:01' overrides: 50519176! - allocWidthForFactor: aFactor - - "Morphs with LayoutSpecs may specify propottional layouts and minimum extents - amountToAlloc * proportion * factor >= minWidth - so breakeven is when - amountToAlloc = minWidth / proportion * factor" - | minWidth | - minWidth := self minimumLayoutWidth. - ^(self isProportionalWidth) - ifFalse: [ minWidth ] - ifTrue: [ minWidth / (aFactor * self layoutSpec privateProportionalWidth) ]! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:35:29' overrides: 16875240! - externalize: aPoint - "aPoint is in own coordinates. Answer is in owner's coordinates." - "Must include scale and rotation!!" - self flag: #jmvVer2. - ^ location externalizePosition: aPoint! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:36:02' overrides: 50463607! - externalizeDisplayBounds: r - - | inOwners | - "All senders of #displayBoundsOfTransformOf: should be rethought..." - self flag: #jmvVer2. - - inOwners _ location displayBoundsOfTransformOf: r. - ^owner - ifNotNil: [ owner externalizeDisplayBounds: inOwners ] - ifNil: [ inOwners ]! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:36:07' overrides: 16875257! - externalizeDistance: aPoint - "aPoint is in own coordinates. Answer is in owner's coordinates." - ^ location externalizeDelta: aPoint! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:36:17' overrides: 16875302! - internalize: aPoint - "aPoint is in owner's coordinates. Answer is in own coordinates." - ^ location internalizePosition: aPoint! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:36:22' overrides: 16875308! - internalizeDistance: aPoint - "aPoint is in owner's coordinates. Answer is in own coordinates." - ^ location internalizeDelta: aPoint! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:38:46' overrides: 50519821! - minimumLayoutExtent - "This returns the minimum extent that the morph may be shrunk to, - when resizing LayoutMorphs. - It is expressed in the morph own coordinates, like morphExtent." - - "This method combines the information from a Morph and its optional LayoutSpec" - | minExtent | - minExtent _ self minimumExtent. - ^ layoutSpec - ifNil: [ minExtent ] - ifNotNil: [ minExtent max: ( layoutSpec minimumSpecWidth @ layoutSpec minimumSpecHeight ) ]! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 21:59:39' overrides: 16875347! - morphAlign: aPoint with: anotherPoint - ^ self morphPosition: self morphPosition + anotherPoint - aPoint! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:36:27' overrides: 16875439! - morphPosition - "Answer our position inside our owner, in owner's coordinates." - - ^ location translation! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:36:47' overrides: 50535263! - morphPosition: aPoint - "Change the position of this morph. Argument is in owner's coordinates." - (location isTranslation: aPoint) ifTrue: [ "Null change" - ^ self ]. - location _ location withTranslation: aPoint. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:36:52' overrides: 50535275! - morphPositionInWorld: newPositionInWorld - "Change the position of this morph." - "El tema es, que tipo de coordenadas tenemos? - En un mundo relativista, no hay un marco de referencia absoluto. - No tiene sentido hablar de coordenadas del mundo... El mundo podria estar escalado... - Que tienen de especial las coordenadas del mundo? - Coordenadas 'del hardware'? No deberia saber mucho sobre el... Puede haber multiples displays, hands de diverso tipo, remotas, virtuales... - - En ppio, un par de coordenadas pueden ser relativas a cualquier morph. Pareciera que necesito metodos de conversion de cualquier morph hacia mi, y de mi hacia cualquier morph... Como encontrar un marco de referencia comun???? - Dejar esto para despues. En realidad, para empezar, preciso menos: Solo preciso saber si las coordenadas estan en el morph o en su owner. Nada mas. Los eventos se iran transformando apropiadamente al moverse por el arbol, o al menos, llevaran consigo una transformacion (AffineTransformation) que se ira actualizando" - - | newPositionInOwner | - self flag: #jmvVer2. - "This method MUST die" - - newPositionInOwner _ owner - ifNotNil: [ owner internalizeFromWorld: newPositionInWorld ] - ifNil: [ newPositionInWorld ]. - - (location isTranslation: newPositionInOwner) ifTrue: [ - ^ self ]. "Null change". - - location _ location withTranslation: newPositionInOwner. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:36:56' overrides: 50548789! - orbitBy: radians - "Change the scale of this morph. Arguments are an angle and a scale." - location _ (AffineTransformation withRadians: radians) composedWith: location. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 22:12:43' overrides: 16875568! - referencePosition - "Return the current reference position of the receiver" - "a rather ugly way to say #center . At least, we avoid false polymorphism" - "remove some day" - self flag: #jmvVer2. - ^self morphExtentInWorld // 2 + self morphPositionInWorld! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 22:12:37' overrides: 16875578! - referencePosition: aPoint - "a rather ugly way to say #center: . Just for consistency with #referencePosition" - "remove some day" - self flag: #jmvVer2. - self morphPositionInWorld: aPoint - (self morphExtentInWorld // 2)! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:37:10' overrides: 50545273! - rotateBy: radians - "Change the rotation of this morph. Argument is an angle (possibly negative), to be added to current rotation." - - location _ location rotatedBy: radians. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:36:39' overrides: 50548800! - rotation: radians - "Change the rotation of this morph. Argument is an angle to be taken as the new rotation." - - self rotation: radians scale: location scale.! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:37:14' overrides: 50548808! - rotation: radians scale: scale - "Change the rotation and scale of this morph. Arguments are an angle and a scale." - location _ location withRotation: radians scale: scale. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:49:21' overrides: 50537011! - rotationDegrees: degrees - location _ location rotatedBy: degrees degreesToRadians - location radians. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:51:47' overrides: 50554051! - scale - ^location scale! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:37:22' overrides: 50535343! - scaleBy: scaleFactor - "Change the scale of this morph. Argument is a factor." - location _ location scaledBy: scaleFactor. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!MovableMorph methodsFor: 'initialization' stamp: 'jmv 10/23/2020 20:38:03' overrides: 50540396! - initialize - "initialize the state of the receiver" - - super initialize. - location _ MorphicTranslation new.! ! -!MovableMorph methodsFor: 'initialization' stamp: 'jmv 10/23/2020 21:41:33' overrides: 50384224! - openInWorld: aWorld - "Add this morph to the requested World." - location isIdentity - ifTrue: [ aWorld addMorph: self position: `50@50` ] - ifFalse: [ aWorld addMorph: self ]! ! -!MovableMorph methodsFor: 'layout' stamp: 'jmv 10/23/2020 21:54:32' overrides: 50519206! - minimumLayoutHeight - "I combine information from a Morph and its optional LayoutSpec" - | minHeight | - - minHeight _ self minimumExtent y. "from morph (me)." - ^ layoutSpec - ifNil: [ minHeight ] - ifNotNil: [ :ls | minHeight max: (ls minimumSpecHeight )] -! ! -!MovableMorph methodsFor: 'layout' stamp: 'jmv 10/23/2020 21:54:35' overrides: 50519217! - minimumLayoutWidth - "I combine information from a Morph and its optional LayoutSpec" - | minWidth | - - minWidth _ self minimumExtent x. "from morph (me)." - ^ layoutSpec - ifNil: [ minWidth ] - ifNotNil: [ :ls | minWidth max: (ls minimumSpecWidth )] -! ! -!MovableMorph methodsFor: 'layout' stamp: 'jmv 10/23/2020 20:38:51' overrides: 50519228! - minimumShrinkExtent - "This returns the minimum extent that the morph may be shrunk to. - It is expressed in the morph own coordinates, like morphExtent." - - | minExtent | - minExtent _ self minimumExtent. - ^ layoutSpec - ifNil: [ minExtent ] - ifNotNil: [ minExtent max: layoutSpec minimumShrinkWidth @ layoutSpec minimumShrinkHeight ]! ! -!MovableMorph methodsFor: 'layout' stamp: 'jmv 10/23/2020 20:38:57' overrides: 50519241! - minimumShrinkHeight - "This returns the minimum height that the morph may be shrunk to by a LayoutAdjustingMorph. - It is expressed in the morph own coordinates, like morphExtent." - - | minShrinkHeight | - minShrinkHeight _ self minimumExtent y. - ^ layoutSpec - ifNil: [ minShrinkHeight ] - ifNotNil: [ minShrinkHeight max: layoutSpec minimumShrinkHeight ]! ! -!MovableMorph methodsFor: 'layout' stamp: 'jmv 10/23/2020 20:39:01' overrides: 50519255! - minimumShrinkWidth - "This returns the minimum width that the morph may be shrunk to by a LayoutAdjustingMorph. - It is expressed in the morph own coordinates, like morphExtent." - - | minShrinkWidth | - minShrinkWidth _ self minimumExtent x. - ^ layoutSpec - ifNil: [ minShrinkWidth ] - ifNotNil: [ minShrinkWidth max: layoutSpec minimumShrinkWidth ]! ! -!MovableMorph methodsFor: 'private' stamp: 'jmv 10/23/2020 20:37:02' overrides: 16877173! - privateOwner: aMorph - "Private!! Should only be used by methods that maintain the ower/submorph invariant." - - | oldGlobalPosition prevOwner | - - self flag: #jmvVer2. - "Is this the best behavior???" - prevOwner _ owner. - prevOwner - ifNotNil: [ - "Had an owner. Maintain my global position..." - oldGlobalPosition _ self morphPositionInWorld ]. - owner _ aMorph. - owner - ifNil: [ - "Won't have any owner. Keep local position, as it will be maintained in my new owner later" - ] - ifNotNil: [ - prevOwner - ifNil: [ - "Didn't have any owner. Assume my local position is to be maintained in my new owner" - ] - ifNotNil: [ - "Had an owner. Maintain my global position..." - location _ location withTranslation: (owner internalizeFromWorld: oldGlobalPosition). - self flag: #jmvVer2. - "extent _ owner internalizeDistanceFromWorld: oldGlobalExtent" "or something like this!!" - ]]! ! -!MovableMorph methodsFor: 'private' stamp: 'jmv 10/23/2020 20:37:06' overrides: 16877204! - privatePosition: aPoint - "Change the position of this morph. Argument is in owner's coordinates." - - (location isTranslation: aPoint) ifTrue: [ - ^ self ]. "Null change" - - location _ location withTranslation: aPoint! ! -!MovableMorph methodsFor: 'layout-properties' stamp: 'jmv 10/23/2020 20:39:08' overrides: 16876060! - layoutSpec - "Layout specific. Return the layout spec describing where the - receiver should appear in a proportional layout" - - layoutSpec ifNotNil: [ :ls | ^ ls ]. - layoutSpec := LayoutSpec keepMorphExtent. - layoutSpec morph: self. - - ^ layoutSpec ! ! -!MovableMorph methodsFor: 'layout-properties' stamp: 'jmv 10/23/2020 20:39:14' overrides: 16876070! - layoutSpec: aLayoutSpec - "Layout specific. Set the layout spec describing where the receiver should appear in a proportional layout" - aLayoutSpec - useMorphWidth; - useMorphHeight. - self layoutSpec == aLayoutSpec ifTrue: [ ^self ]. - aLayoutSpec morph: self. - layoutSpec := aLayoutSpec. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]! ! -!MovableMorph methodsFor: 'testing' stamp: 'jmv 10/23/2020 21:54:25' overrides: 50519268! - isProportionalHeight - "Answer true if I have a layoutSpec which specifies a proportional layout" - - ^ layoutSpec - ifNil: [ false ] - ifNotNil: [ :ls | ls isProportionalHeight ]! ! -!MovableMorph methodsFor: 'testing' stamp: 'jmv 10/23/2020 21:54:29' overrides: 50519276! - isProportionalWidth - "Answer true if I have a layoutSpec which specifies a proportional layout" - - ^ layoutSpec - ifNil: [ false ] - ifNotNil: [ :ls | ls isProportionalWidth ]! ! -!Morph methodsFor: 'accessing' stamp: 'jmv 10/23/2020 21:16:48' prior: 16873949! - location - ^nil! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 21:18:12' prior: 16875240! - externalize: aPoint - "aPoint is in own coordinates. Answer is in owner's coordinates." - "Must include scale and rotation!!" - ^ aPoint! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 21:20:39' prior: 50463607! - externalizeDisplayBounds: r - - "All senders of #displayBoundsOfTransformOf: should be rethought..." - self flag: #jmvVer2. - - ^owner - ifNotNil: [ owner externalizeDisplayBounds: r ] - ifNil: [ r encompassingIntegerRectangle ]! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 21:22:26' prior: 16875257! - externalizeDistance: aPoint - "aPoint is in own coordinates. Answer is in owner's coordinates." - ^ aPoint! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 21:22:46' prior: 16875302! - internalize: aPoint - "aPoint is in owner's coordinates. Answer is in own coordinates." - ^ aPoint! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 21:23:01' prior: 16875308! - internalizeDistance: aPoint - "aPoint is in owner's coordinates. Answer is in own coordinates." - ^ aPoint! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 21:21:42' prior: 16875409! - morphExtentInWorld - "eventually, remove." - self flag: #jmvVer2. - ^(self externalizeDistanceToWorld: self morphExtent) ceiling! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 22:00:55' prior: 16875439! - morphPosition - "Answer our position inside our owner, in owner's coordinates." - self flag: #jmvVer2. self revisar. "useless" - ^ 0@0! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 22:59:44' prior: 50535263! - morphPosition: aPoint - "Change the position of this morph. Argument is in owner's coordinates. - Ignored by morphs that are not resizeable"! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 23:00:38' prior: 50535275! - morphPositionInWorld: newPositionInWorld - "Change the position of this morph. Argument is in world coordinates. - Ignored by morphs that are not movable"! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 22:15:39' prior: 16875568! - referencePosition - "Return the current reference position of the receiver" - "a rather ugly way to say #center . At least, we avoid false polymorphism" - "remove some day" - self flag: #jmvVer2. self revisar. "useless" - ^0@0! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 22:04:37' prior: 50548808! - rotation: radians scale: scale - "Change the rotation and scale of this morph. Arguments are an angle and a scale. - Ignored by us. Redefined in some subclasses." - self flag: #jmvVer2. self revisar. "useless?"! ! -!Morph methodsFor: 'initialization' stamp: 'jmv 10/23/2020 20:38:06' prior: 50540396 overrides: 16896425! - initialize - "initialize the state of the receiver" - - owner _ nil. - submorphs _ #(). - id _ 0.! ! -!Morph methodsFor: 'initialization' stamp: 'jmv 10/23/2020 21:41:47' prior: 50384224! - openInWorld: aWorld - "Add this morph to the requested World." - aWorld addMorph: self! ! -!Morph methodsFor: 'layout' stamp: 'jmv 10/23/2020 21:28:05' prior: 50519206! - minimumLayoutHeight - "I combine information from a Morph and its optional LayoutSpec" - - ^self minimumExtent y.! ! -!Morph methodsFor: 'layout' stamp: 'jmv 10/23/2020 21:27:56' prior: 50519217! -minimumLayoutWidth - "I combine information from a Morph and its optional LayoutSpec" - - ^self minimumExtent x.! ! -!Morph methodsFor: 'layout' stamp: 'jmv 10/23/2020 21:46:12' prior: 50519228! - minimumShrinkExtent - "This returns the minimum extent that the morph may be shrunk to. - It is expressed in the morph own coordinates, like morphExtent." - - ^ self minimumExtent.! ! -!Morph methodsFor: 'layout' stamp: 'jmv 10/23/2020 21:46:40' prior: 50519241! - minimumShrinkHeight - "This returns the minimum height that the morph may be shrunk to by a LayoutAdjustingMorph. - It is expressed in the morph own coordinates, like morphExtent." - - ^ self minimumExtent y.! ! -!Morph methodsFor: 'layout' stamp: 'jmv 10/23/2020 21:46:53' prior: 50519255! - minimumShrinkWidth - "This returns the minimum width that the morph may be shrunk to by a LayoutAdjustingMorph. - It is expressed in the morph own coordinates, like morphExtent." - - ^ self minimumExtent x.! ! -!Morph methodsFor: 'testing' stamp: 'jmv 10/23/2020 21:26:45' prior: 50519268! - isProportionalHeight - "Answer true if I have a layoutSpec which specifies a proportional layout" - - ^false! ! -!Morph methodsFor: 'testing' stamp: 'jmv 10/23/2020 21:49:21' prior: 50519276! - isProportionalWidth - "Answer true if I have a layoutSpec which specifies a proportional layout" - - ^ false! ! -!Morph methodsFor: 'private' stamp: 'jmv 10/23/2020 21:48:13' prior: 16877173! - privateOwner: aMorph - "Private!! Should only be used by methods that maintain the ower/submorph invariant." - - owner _ aMorph.! ! -!Morph methodsFor: 'private' stamp: 'jmv 10/23/2020 23:00:44' prior: 16877204! - privatePosition: aPoint - "Change the position of this morph. Argument is in owner's coordinates. - Ignored by morphs that are not movable"! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 10/23/2020 20:52:06' prior: 50537076! -startRot: evt with: rotHandle - "Initialize rotation of my target if it is rotatable. Launch a command object to represent the action" - - evt hand obtainHalo: self. "Make sure the event's hand correlates with the receiver" - growingOrRotating _ true. - - self removeAllHandlesBut: rotHandle. "remove all other handles" - angleOffset _ evt eventPosition - target referencePosition. - angleOffset _ Point - r: angleOffset r - degrees: angleOffset degrees - target rotationDegrees. - scaleOffset _ target scale / (evt eventPosition - target referencePosition) rho. - -! ! -!LayoutMorph methodsFor: 'accessing' stamp: 'jmv 10/23/2020 21:56:12' prior: 50519936 overrides: 16876867! - addMorphFrontFromWorldPosition: aMorph - - aMorph layoutSpec. - self addMorphFront: aMorph. - self layoutSubmorphs. -! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 10/23/2020 21:16:03' prior: 50408043! - into: aMorph - | locationOrNil previousLast | - locationOrNil _ aMorph location. - currentMorph _ aMorph. - cti _ cti + 1. - transformations size < cti - ifTrue: [ - drawingMorphStack add: aMorph. - currentTransformation _ locationOrNil - ifNotNil: [ currentTransformation composedWith: locationOrNil] - ifNil: [ currentTransformation copy ]. - transformations add: currentTransformation ] - ifFalse: [ - drawingMorphStack at: cti put: aMorph. - previousLast _ currentTransformation. - locationOrNil - ifNil: [ - "Podriamos reusar la instancia si nos sirve." - currentTransformation _ previousLast copy. - transformations at: cti put: currentTransformation ] - ifNotNil: [ :location | - currentTransformation _ transformations at: cti. - "reuse the instance if possible" - (previousLast class == location class and: [ previousLast class == currentTransformation class ]) - ifTrue: [ - previousLast composedWith: location into: currentTransformation ] - ifFalse: [ - currentTransformation _ previousLast composedWith: location. - transformations at: cti put: currentTransformation ] - ] - ]! ! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 10/23/2020 21:19:51' prior: 16877337! - externalizeDisplayBounds: r from: aMorph - "r is a Rectangle, expressed in aMorph's coordinate system. - Answer another rectangle, that bounds r when translated to World coordinates" - - "Should translate only to whatever world or PasteUp we are displaying. - Fix when implementing multiple Canvases (Displays) showing different - (potentially nested Worlds)" - | inOwners owner | - self flag: #jmvVer2. - - inOwners _ aMorph location - ifNil: [ r ] - ifNotNil: [ :tx | tx displayBoundsOfTransformOf: r ]. - owner _ aMorph owner. - ^owner - ifNotNil: [ self externalizeDisplayBounds: inOwners from: owner] - ifNil: [ inOwners encompassingIntegerRectangle ]! ! - -MovableMorph removeSelector: #addMorphFrontFromWorldPosition:! - -Morph removeSelector: #layoutSpec:! - -!methodRemoval: Morph #layoutSpec: stamp: 'Install-4424-PushDownStuffToMovableMorph-JuanVuletich-2020Oct23-22h41m-jmv.002.cs.st 10/24/2020 17:29:28'! -layoutSpec: aLayoutSpec - "Layout specific. Set the layout spec describing where the receiver should appear in a proportional layout" - aLayoutSpec - useMorphWidth; - useMorphHeight. - self layoutSpec == aLayoutSpec ifTrue: [ ^self ]. - aLayoutSpec morph: self. - layoutSpec := aLayoutSpec. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]! - -Morph removeSelector: #referencePosition:! - -!methodRemoval: Morph #referencePosition: stamp: 'Install-4424-PushDownStuffToMovableMorph-JuanVuletich-2020Oct23-22h41m-jmv.002.cs.st 10/24/2020 17:29:28'! -referencePosition: aPoint - "a rather ugly way to say #center: . Just for consistency with #referencePosition" - "remove some day" - self flag: #jmvVer2. - self morphPositionInWorld: aPoint - (self morphExtentInWorld // 2)! - -Morph removeSelector: #morphAlign:with:! - -!methodRemoval: Morph #morphAlign:with: stamp: 'Install-4424-PushDownStuffToMovableMorph-JuanVuletich-2020Oct23-22h41m-jmv.002.cs.st 10/24/2020 17:29:28'! -morphAlign: aPoint with: anotherPoint - ^ self morphPosition: self morphPosition + anotherPoint - aPoint! - -Morph removeSelector: #rotation:! - -!methodRemoval: Morph #rotation: stamp: 'Install-4424-PushDownStuffToMovableMorph-JuanVuletich-2020Oct23-22h41m-jmv.002.cs.st 10/24/2020 17:29:28'! -rotation: radians - "Change the rotation of this morph. Argument is an angle to be taken as the new rotation." - - self rotation: radians scale: location scale.! - -Morph removeSelector: #rotationDegrees:! - -!methodRemoval: Morph #rotationDegrees: stamp: 'Install-4424-PushDownStuffToMovableMorph-JuanVuletich-2020Oct23-22h41m-jmv.002.cs.st 10/24/2020 17:29:28'! -rotationDegrees: degrees - location _ location rotatedBy: degrees degreesToRadians - location radians. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! - -Morph removeSelector: #orbitBy:! - -!methodRemoval: Morph #orbitBy: stamp: 'Install-4424-PushDownStuffToMovableMorph-JuanVuletich-2020Oct23-22h41m-jmv.002.cs.st 10/24/2020 17:29:28'! -orbitBy: radians - "Change the scale of this morph. Arguments are an angle and a scale." - location _ (AffineTransformation withRadians: radians) composedWith: location. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! - -Morph removeSelector: #rotateBy:! - -!methodRemoval: Morph #rotateBy: stamp: 'Install-4424-PushDownStuffToMovableMorph-JuanVuletich-2020Oct23-22h41m-jmv.002.cs.st 10/24/2020 17:29:28'! -rotateBy: radians - "Change the rotation of this morph. Argument is an angle (possibly negative), to be added to current rotation." - - location _ location rotatedBy: radians. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! - -Morph removeSelector: #minimumLayoutExtent! - -!methodRemoval: Morph #minimumLayoutExtent stamp: 'Install-4424-PushDownStuffToMovableMorph-JuanVuletich-2020Oct23-22h41m-jmv.002.cs.st 10/24/2020 17:29:28'! -minimumLayoutExtent - "This returns the minimum extent that the morph may be shrunk to, - when resizing LayoutMorphs. - It is expressed in the morph own coordinates, like morphExtent." - - "This method combines the information from a Morph and its optional LayoutSpec" - | minExtent | - minExtent _ self minimumExtent. - ^ layoutSpec - ifNil: [ minExtent ] - ifNotNil: [ minExtent max: ( layoutSpec minimumSpecWidth @ layoutSpec minimumSpecHeight ) ]! - -Morph removeSelector: #scaleBy:! - -!methodRemoval: Morph #scaleBy: stamp: 'Install-4424-PushDownStuffToMovableMorph-JuanVuletich-2020Oct23-22h41m-jmv.002.cs.st 10/24/2020 17:29:28'! -scaleBy: scaleFactor - "Change the scale of this morph. Argument is a factor." - location _ location scaledBy: scaleFactor. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! - -Morph removeSelector: #layoutSpec! - -!methodRemoval: Morph #layoutSpec stamp: 'Install-4424-PushDownStuffToMovableMorph-JuanVuletich-2020Oct23-22h41m-jmv.002.cs.st 10/24/2020 17:29:28'! -layoutSpec - "Layout specific. Return the layout spec describing where the - receiver should appear in a proportional layout" - - layoutSpec ifNotNil: [ :ls | ^ ls ]. - layoutSpec := LayoutSpec keepMorphExtent. - layoutSpec morph: self. - - ^ layoutSpec ! - -Morph removeSelector: #allocHeightForFactor:! - -!methodRemoval: Morph #allocHeightForFactor: stamp: 'Install-4424-PushDownStuffToMovableMorph-JuanVuletich-2020Oct23-22h41m-jmv.002.cs.st 10/24/2020 17:29:28'! -allocHeightForFactor: aFactor - - "Morphs with LayoutSpecs may specify propottional layouts and minimum extents - amountToAlloc * proportion * factor >= minHeight - so breakeven is when - amountToAlloc = minHeight / proportion * factor" - | minHeight | - minHeight := self minimumLayoutHeight. - ^(self isProportionalHeight) - ifFalse: [ minHeight ] - ifTrue: [ minHeight / (aFactor * self layoutSpec privateProportionalHeight) ]! - -Morph removeSelector: #allocWidthForFactor:! - -!methodRemoval: Morph #allocWidthForFactor: stamp: 'Install-4424-PushDownStuffToMovableMorph-JuanVuletich-2020Oct23-22h41m-jmv.002.cs.st 10/24/2020 17:29:28'! -allocWidthForFactor: aFactor - - "Morphs with LayoutSpecs may specify propottional layouts and minimum extents - amountToAlloc * proportion * factor >= minWidth - so breakeven is when - amountToAlloc = minWidth / proportion * factor" - | minWidth | - minWidth := self minimumLayoutWidth. - ^(self isProportionalWidth) - ifFalse: [ minWidth ] - ifTrue: [ minWidth / (aFactor * self layoutSpec privateProportionalWidth) ]! - -Morph removeSelector: #layoutSpecOrNil! - -!methodRemoval: Morph #layoutSpecOrNil stamp: 'Install-4424-PushDownStuffToMovableMorph-JuanVuletich-2020Oct23-22h41m-jmv.002.cs.st 10/24/2020 17:29:28'! -layoutSpecOrNil - "Layout specific. Return the layout spec describing where the - receiver should appear in a proportional layout. - Answer nil if none!!" - - ^ layoutSpec ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4424-PushDownStuffToMovableMorph-JuanVuletich-2020Oct23-22h41m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4424] on 23 October 2020 at 11:02:34 pm'! - -"Change Set: 4425-MovableMorphShape-JuanVuletich-2020Oct23-23h01m-jmv.001.cs.st -Date: 23 October 2020 -Author: Juan Vuletich - -Modifying class definition of core to Morphs is tricky. Hence this preamble." -| ui b cs d1 d2 | -Utilities authorInitialsPerSe ifNil: [ Utilities setAuthor ]. -(nil confirm: 'In order to modify instance definition of Morph and MovableMorph, -we need to restart the User Interface process. -You''ll need to do [Install New Updates] again, to install later updates.') ifFalse: [ self halt ]. -[ - ui _ UISupervisor ui. - UISupervisor stopUIProcess. - d1 _ IdentityDictionary new. - MovableMorph allSubInstancesDo: [ :m | - d2 _ Dictionary new. - d1 at: m put: d2. - d2 at: #location put: (m instVarNamed: 'location'). - d2 at: #layoutSpec put: (m instVarNamed: 'layoutSpec'). - d2 at: #properties put: (m instVarNamed: 'properties'). - d2 at: #id put: (m instVarNamed: 'id'). - d2 at: #privateDisplayBounds put: (m instVarNamed: 'privateDisplayBounds'). ]. - b _ ClassBuilder isSilent. - ClassBuilder beSilent: true. - [ - ClassBuilder new - superclass: Object - subclass: #Morph - instanceVariableNames: 'owner submorphs properties id privateDisplayBounds' - classVariableNames: 'LastMorphId' - poolDictionaries: '' - category: 'Morphic-Kernel'. - ] - on: InMidstOfFileinNotification, UndeclaredVariableWarning, PoolDefinitionNotification - do: [ :ex | ex resume: true ]. - ClassBuilder new - superclass: Morph - subclass: #MovableMorph - instanceVariableNames: 'location layoutSpec' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'. - ClassBuilder beSilent: b. - MovableMorph allSubInstancesDo: [ :m | - d2 _ d1 at: m. - m instVarNamed: 'properties' put: (d2 at: #properties). - m instVarNamed: 'id' put: (d2 at: #id). - m instVarNamed: 'privateDisplayBounds' put: (d2 at: #privateDisplayBounds). - m instVarNamed: 'location' put: (d2 at: #location). - m instVarNamed: 'layoutSpec' put: (d2 at: #layoutSpec). ]. - d1 _ nil. d2 _ nil. - UISupervisor spawnNewMorphicProcessFor: ui. - (Delay forSeconds: 1) wait. - ChangeSet installing: '4425-MovableMorphShape-JuanVuletich-2020Oct23-23h01m-jmv.001.cs.st' do: []. - cs _ ChangeSet changeSetForBaseSystem. - (cs name beginsWith: '4425') ifTrue: [ - ChangeSet removeChangeSet: cs ]. - 'Done updating definition of LabelMorph.' print. - 'Installed ChangeSet: 4425-MovableMorphShape-JuanVuletich-2020Oct23-23h01m-jmv.001.cs.st' print. - 'Please do [Install New Updates] again.' print. -] forkAt: 41! - -----SNAPSHOT----(24 October 2020 17:29:46) Cuis5.0-4425-32.image priorSource: 6931148! - -----STARTUP---- (24 October 2020 23:08:05) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4425-32.image! - - -'From Cuis 5.0 [latest update: #4425] on 24 October 2020 at 11:01:52 pm'! -!ChangeSet class methodsFor: 'services' stamp: 'jmv 10/24/2020 23:01:03' prior: 50540783! -installNewUpdates: updatesFileDirectory - - | warnUser | - (self newUpdates: updatesFileDirectory) do: [ :each | - self install: each ]. - - warnUser _ false. - CodePackage installedPackages keysAndValuesDo: [ :pckName :package | - package fullFileName ifNotNil: [ :fullFileName | | codePackageFile | - codePackageFile _ CodePackageFile onFileEntry: fullFileName asFileEntry. - (codePackageFile provides isLaterThan: package provides) ifTrue: [ - warnUser _ true. - package hasUnsavedChanges - ifTrue: [ 'Package: ', pckName, '. Package has unsaved changes, but there is a newer version of the file.' print ] - ifFalse: [ 'Package: ', pckName, '. There is a newer version than the currently loaded.' print ]]]]. - warnUser - ifTrue: [ - self inform: SystemVersion current version, ' - ', Smalltalk lastUpdateString, String newLineString, -'Some package(s) loaded in the image -have updated package file on disk. -Please see Transcript.' ] - ifFalse: [ - Smalltalk systemInformationString print ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4426-RemovePopUpAfterInstallUpdates-JuanVuletich-2020Oct24-23h01m-jmv.001.cs.st----! - -----SNAPSHOT----(24 October 2020 23:08:12) Cuis5.0-4426-32.image priorSource: 7147426! - -----STARTUP---- (30 December 2020 14:47:30) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4426-32.image! - - -'From Cuis 5.0 [latest update: #4426] on 25 October 2020 at 8:34:32 pm'! -!CodePackage methodsFor: 'accessing' stamp: 'jmv 10/25/2020 20:33:45' prior: 50400994! - codePackageClass - "Answer the specific CodePackage subclass to use." - - self class == CodePackage ifFalse: [ - ^ self class ]. - self classesDo: [ :cls | - (cls inheritsFrom: CodePackage) - ifTrue: [ - ((self packageName asIdentifier: true), 'Package') = cls name ifTrue: [ - ^ cls ]]]. - ^ nil! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4427-BeMoreCarefulAboutCodePackageSubclasses-JuanVuletich-2020Oct25-20h29m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4427] on 26 October 2020 at 10:05:48 am'! -!CodePackageFile methodsFor: 'services' stamp: 'jmv 10/26/2020 10:05:36' prior: 50504794! - install - "Create, install and answer a (sub)instance of CodePackage - Replace all existing code in the possibly existing CodePackage, removing any code that is not included in us." - | localName newCodePackage pckClass currentCS | - - localName _ fullName asFileEntry name. - ChangeSet installing: packageName do: [ - "This change set will capture a possible class definition for a subclass of CodePackage. - If it only has that, then remove it after package install. - One example needing this is 'Color-Extras.pck.st'" - currentCS _ ChangeSet changeSetForBaseSystem. - currentCS isEmpty ifFalse: [ currentCS _ nil ]. - pckClass _ CodePackage. - classes do: [ :ee | - (ee hasDefinition and: [ee superclassName = 'CodePackage']) ifTrue: [ - ((self packageName asIdentifier: true), 'Package') = ee name ifTrue: [ - ee fileInDefinitionAndMetaclass. - pckClass _ Smalltalk at: ee name ]]]. - newCodePackage _ pckClass - named: packageName - createIfAbsent: true - registerIfNew: true. - newCodePackage - fullFileName: fullName; - sourceSystem: sourceSystem; - description: description; - featureSpec: featureSpec. - - fullName asFileEntry readStreamDo: [ :stream | stream fileInAnnouncing: 'Installing ', localName, '...' ]. - methodsToRemove do: [ :methodReference | methodReference actualClass removeSelector: methodReference selector ]. - classesToRemove do: [ :className | (Smalltalk at: className) removeFromSystem ]. - currentCS ifNotNil: [ ChangeSet removeChangeSet: currentCS ]]. - - newCodePackage hasUnsavedChanges: false; triggerEvent: #dirtyFlagChanged. - DataStream initialize. "Just in case" - "If we are installing an already installed package, zap the change set with possible changes done, - as they are irrelevant now: we have the package from disk" - ChangeSet removeChangeSet: (ChangeSet existingOrNewChangeSetForPackage: newCodePackage). - Preferences transcriptLogVerbose ifTrue: [ - Transcript newLine; show: 'Package ', packageName, ' successfully installed'; newLine. - Smalltalk cleanOutUndeclared. - Undeclared notEmpty ifTrue: [ - ('Undeclared: ', Undeclared printString) print ]]. - ^newCodePackage! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4428-BeMoreCarefulAboutCodePackageSubclasses-part2-JuanVuletich-2020Oct26-10h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4428] on 26 October 2020 at 11:30:04 am'! -!LabelMorph methodsFor: 'drawing' stamp: 'KenD 10/23/2020 13:37:36' prior: 50503483 overrides: 50545911! - drawOn: aCanvas - aCanvas - drawString: (contents ifNil: [ '' ]) - at: self morphTopLeft + borderWidth - font: self fontToUse - color: color. - (borderWidth > 0) ifTrue: [ - aCanvas - frameRectangle: (0@0 extent: extent) - color: borderColor - borderWidth: borderWidth - borderStyleSymbol: #simple ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4429-LabelMorph-HonorPossibleBorderWidth-KenDickey-2020Oct26-11h27m-KenD.001.cs.st----! - -'From Cuis 5.0 [latest update: #4426] on 26 October 2020 at 11:56:27 am'! -!InputSensor methodsFor: 'keyboard' stamp: 'jmv 10/26/2020 11:55:46' prior: 50386171! - kbdTest - " - Sensor kbdTest - " - "This test routine will print the unmodified character, its keycode, - and the OR of all its modifier bits, until the character x is typed - -Also useful: - Sensor test - " - | char | - char _ nil. - [ char = $x ] whileFalse: [ - [ self keyboardPressed ] whileFalse. - char _ self keyboard. - Display fill: `5@5 extent: 400@50` fillColor: `Color white`. - (String streamContents: [ :s | - s - nextPut: $-; - nextPut: char; - nextPut: $-; - space; - print: char numericValue; - space. - self isMouseButton3Pressed ifTrue: [ s nextPutAll: ' mouseButton3/blue/tertiary/halo ' ]. - self isMouseButton2Pressed ifTrue: [ s nextPutAll: ' mouseButton2/yellow/secondary/menu ' ]. - self isMouseButton1Pressed ifTrue: [ s nextPutAll: ' mouseButton1/red/primary ' ]. - self shiftPressed ifTrue: [ s nextPutAll: ' shift ' ]. - self controlKeyPressed ifTrue: [ s nextPutAll: ' control/ctrl ' ]. - (self primMouseButtons anyMask: 32) ifTrue: [ s nextPutAll: ' macOption ' ]. - self commandAltKeyPressed ifTrue: [ s nextPutAll: ' macCommand/winAlt ' ]. - Time primMillisecondClock printOn: s - ]) - displayAt: 10 @ 10 ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4430-kbdTestTweak-JuanVuletich-2020Oct26-11h44m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4428] on 26 October 2020 at 4:06:09 pm'! -!WorldMorph methodsFor: 'misc' stamp: 'KLG 10/26/2020 16:05:08' prior: 50552052 overrides: 50551033! - buildMagnifiedBackgroundImage - super buildMagnifiedBackgroundImage. - backgroundImage ifNil: [ ^ self ]. - - canvas ifNotNil: [ :c | - (backgroundImage depth = 32 and: [ c form depth < 32 ]) ifTrue: [ - backgroundImage _ backgroundImage orderedDither32To16 ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4431-WorldMorphFix-GeraldKlix-2020Oct26-16h03m-KLG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4431] on 26 October 2020 at 4:42:31 pm'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 10/26/2020 16:18:31'! - currentMorphDrawingFails - currentMorph drawingFails! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 10/26/2020 16:19:30' prior: 50551680! - displayWorldSafely - "Update this world's display and keep track of errors during draw methods." - - [self displayWorld] ifError: [ :err :rcvr | - "Handle a drawing error" - canvas currentMorphDrawingFails. - self setCanvas. - "Install the old error handler, so we can re-raise the error" - rcvr error: err. - ]! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/26/2020 16:34:26' prior: 50538719! - fullAddCurrentRect: addCurrentBounds submorphs: trySubmorphs to: aDamageRecorder - - addCurrentBounds ifTrue: [ - currentMorph needsRedraw: false. - self fullUpdateCurrentBounds. - aDamageRecorder recordInvalidRect: currentMorph displayBounds for: currentMorph. - ]. - trySubmorphs ifTrue: [ - currentMorph submorphNeedsRedraw: false. - currentMorph clippedSubmorph ifNotNil: [ :clipped | - self clippingByCurrentMorphDo: [ self fullAddRedrawRect: clipped to: aDamageRecorder ]]. - currentMorph unclippedSubmorphsReverseDo: [ :m | - self fullAddRedrawRect: m to: aDamageRecorder ] - ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/26/2020 16:28:23' prior: 50536167! - fullUpdateCurrentBounds - | currentMorphBounds isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph drawOn: self ]. - currentMorphBounds _ self boundingRectOfCurrentMorphAfterDraw. - currentMorph displayBounds: currentMorphBounds. - isKnownFailing ifFalse: [ - currentMorph submorphsDo: [ :m | - self fullUpdateBounds: m ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4432-MorphicDrawingErrorFixes-JuanVuletich-2020Oct26-16h41m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4432] on 26 October 2020 at 4:48:09 pm'! -!WidgetMorph methodsFor: 'geometry' stamp: 'KenD 10/26/2020 12:16:38' overrides: 16875232! - extentBorder - "This is the number of pixels to add to internal minimum to calculate - my minimumExtent. " - - ^ 2 * borderWidth ! ! - -Morph removeSelector: #extentBorder! - -!methodRemoval: Morph #extentBorder stamp: 'Install-4433-MoveExtentBorderToWidget-KenDickey-2020Oct26-16h47m-KenD.001.cs.st 12/30/2020 14:47:34'! -extentBorder - "This is the number of pixels to add to internal minimum to calculate - my minimumExtent. I don;t have to do anything here. - This is the default for my subclasses" - - ^ 0 - -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4433-MoveExtentBorderToWidget-KenDickey-2020Oct26-16h47m-KenD.001.cs.st----! - -'From Cuis 5.0 [latest update: #4433] on 26 October 2020 at 6:59:40 pm'! -!Morph methodsFor: 'private' stamp: 'jmv 10/26/2020 18:32:03' prior: 50539760! - privateAddMorph: aMorph atIndex: index - - self privateAddMorph: aMorph atIndex: index position: nil! ! -!Morph methodsFor: 'private' stamp: 'jmv 10/26/2020 18:29:17' prior: 50539814! - privateAddMorph: aMorph atIndex: index position: aPointOrNil - - | oldIndex myWorld itsWorld oldOwner | - (self canAdd: aMorph) ifFalse: [ - (self confirm: 'The requested morph requires VectorGraphics support. Do you want to install and activate it?') - ifTrue: [ - Feature require: 'VectorGraphics'. - MorphicCanvas activeSubclass: (Smalltalk at: #HybridCanvas) ] - ifFalse: [ - ^self error: 'We can''t add requested morph.' ]]. - ((index >= 1) and: [index <= (submorphs size + 1)]) - ifFalse: [^ self error: 'index out of range']. - myWorld _ self world. - oldOwner _ aMorph owner. - (oldOwner == self and: [(oldIndex _ submorphs indexOf: aMorph) > 0]) ifTrue: [ - "aMorph's position changes within in the submorph chain" - oldIndex < index ifTrue:[ - "moving aMorph to back" - submorphs replaceFrom: oldIndex to: index-2 with: submorphs startingAt: oldIndex+1. - submorphs at: index-1 put: aMorph. - ] ifFalse:[ - "moving aMorph to front" - oldIndex-1 to: index by: -1 do:[:i| - submorphs at: i+1 put: (submorphs at: i)]. - submorphs at: index put: aMorph. - ]. - aPointOrNil ifNotNil: [aMorph privatePosition: aPointOrNil]. - ] ifFalse: [ - "adding a new morph" - oldOwner ifNotNil: [ - itsWorld _ aMorph world. - itsWorld ifNotNil: [aMorph invalidateBounds]. - oldOwner privateRemove: aMorph. - oldOwner removedMorph: aMorph. - ]. - aMorph privateOwner: self. - submorphs _ submorphs copyReplaceFrom: index to: index-1 with: (Array with: aMorph). - aPointOrNil ifNotNil: [aMorph privatePosition: aPointOrNil]. - (itsWorld == myWorld) ifFalse: [aMorph intoWorld: myWorld]. - ]. - myWorld ifNotNil: [aMorph redrawNeeded]. - self someSubmorphPositionOrExtentChanged. - oldOwner == self ifFalse: [ - self addedMorph: aMorph. - aMorph noteNewOwner: self ]! ! -!TheWorldMenu class methodsFor: 'menu building' stamp: 'jmv 10/26/2020 17:22:51' prior: 50544410! - worldMenuOptions - - ^`{{ - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Open...'. - #selector -> #openOpenMenu. - #icon -> #openIcon. - #balloonText -> 'Submenu to open various system tools'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'New morph...'. - #selector -> #newMorph. - #icon -> #morphsIcon. - #balloonText -> 'Offers a variety of ways to create new objects'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Preferences...'. - #selector -> #openPreferencesMenu. - #icon -> #preferencesIcon. - #balloonText -> 'Opens a menu offering many controls over appearance and system preferences.'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'Windows...'. - #selector -> #openWindowsMenu. - #icon -> #windowIcon. - #balloonText -> 'Manage open windows'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 50. - #label -> 'Help...'. - #selector -> #openHelpMenu. - #icon -> #helpIcon. - #balloonText -> 'Opens a menu of useful items for updating the system, determining what version you are running, and much else'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Changes...'. - #selector -> #openChangesMenu. - #icon -> #changesIcon. - #balloonText -> 'Opens a menu of useful tools for dealing with changes'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Debug...'. - #selector -> #openDebugMenu. - #icon -> #debugIcon. - #balloonText -> 'a menu of debugging items'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'Restore Display'. - #object -> #myWorld. - #selector -> #restoreDisplay. - #icon -> #displayIcon. - #balloonText -> 'Repaint the screen -- useful for removing unwanted display artifacts, lingering cursors, etc.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Save'. - #object -> Smalltalk. - #selector -> #saveSession. - #icon -> #saveIcon. - #balloonText -> 'Save the current version of the image on disk'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Save as...'. - #object -> Smalltalk. - #selector -> #saveAs. - #icon -> #saveAsIcon. - #balloonText -> 'Save the current version of the image on disk under a new name.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'Save new Cuis Release'. - #object -> Smalltalk. - #selector -> #saveAsNewVersion. - #icon -> #saveAsNewVersionIcon. - #balloonText -> ('Save as a new release of Cuis.\Use an updated version-stamped name\and save it under that name on disk.\', - 'Clear all user preferences and user state (class vars).') withNewLines. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 40. - #label -> 'Save and Quit'. - #selector -> #saveAndQuit. - #icon -> #saveAndQuitIcon. - #balloonText -> 'Save the image and quit out of Cuis.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 50. - #label -> 'Quit'. - #selector -> #quitSession. - #icon -> #quitIcon. - #balloonText -> 'Quit out of Cuis.'. - } asDictionary. -}`! ! - -LayoutMorph removeSelector: #privateAddMorph:atIndex:! - -!methodRemoval: LayoutMorph #privateAddMorph:atIndex: stamp: 'Install-4434-AddMorphInvalidationFix-JuanVuletich-2020Oct26-18h54m-jmv.001.cs.st 12/30/2020 14:47:34'! -privateAddMorph: aMorph atIndex: index - aMorph layoutSpec. - ^super privateAddMorph: aMorph atIndex: index! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4434-AddMorphInvalidationFix-JuanVuletich-2020Oct26-18h54m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4426] on 27 October 2020 at 10:40:23 am'! -!BlockClosure methodsFor: 'printing' stamp: 'jmv 10/27/2020 10:40:01' overrides: 16882265! - storeOn: aStream - " - [] storeString - " - aStream nextPut: $(. - self asSerializable storeOn: aStream. - aStream nextPutAll: ' asEvaluable)'! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4435-BlockClosure-storeOn-JuanVuletich-2020Oct27-10h33m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4426] on 27 October 2020 at 10:41:33 am'! -!Preferences class methodsFor: 'exception handling' stamp: 'jmv 10/27/2020 10:41:23' prior: 50478080! -warnAboutNonLocalReturnsInExceptionHandlers - ^ self - valueOfFlag: #warnAboutNonLocalReturnsInExceptionHandlers - ifAbsent: [ false ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4436-NLSinExceptionsWarning-disableByDefault-JuanVuletich-2020Oct27-10h40m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4434] on 27 October 2020 at 12:05:52 pm'! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 10/27/2020 12:05:33' prior: 50536615! - grabMorph: aMorph moveUnderHand: moveUnderHand - "Grab the given morph (i.e., add it to this hand and remove it from its current owner). - If moveUnderHand is requested or it seems neccesary anyway, move the grabbed morph under the hand." - - | grabbed delta | - self releaseMouseFocus. "Break focus" - grabbed _ aMorph. - aMorph owner ifNotNil: [ :o | - grabbed _ o aboutToGrab: aMorph ]. - grabbed ifNil: [ ^ self ]. - grabbed _ grabbed aboutToBeGrabbedBy: self. - grabbed ifNil: [ ^ self ]. - "If we find a case where this doesn't work, asking the position to aMorph instead of grabbed is possible." - delta _ grabbed morphPositionInWorld - self morphPositionInWorld. - grabbed displayBounds ifNotNil: [ :r | - (moveUnderHand or: [ (r containsPoint: self morphPositionInWorld) not ]) - ifTrue: [ - delta _ (r extent // 2) negated ]]. - ^ self - grabMorph: grabbed - delta: delta print! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4437-GrabMorphWithHandFix-JuanVuletich-2020Oct27-11h39m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4437] on 31 October 2020 at 9:03:58 am'! -!Workspace methodsFor: 'binding' stamp: 'KLG 10/30/2020 16:59:30' prior: 16945389! - initializeBindings - - bindings _ Dictionary new. - self changed: #actualContents. -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4438-WorkspaceInitializeBindings-GeraldKlix-2020Oct31-09h02m-KLG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4437] on 28 October 2020 at 10:16:36 am'! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 10/28/2020 10:16:27' prior: 50555570! - grabMorph: aMorph moveUnderHand: moveUnderHand - "Grab the given morph (i.e., add it to this hand and remove it from its current owner). - If moveUnderHand is requested or it seems neccesary anyway, move the grabbed morph under the hand." - - | grabbed positionInHandCoordinates | - self releaseMouseFocus. "Break focus" - grabbed _ aMorph. - aMorph owner ifNotNil: [ :o | grabbed _ o aboutToGrab: aMorph ]. - grabbed ifNil: [ ^ self ]. - grabbed _ grabbed aboutToBeGrabbedBy: self. - grabbed ifNil: [ ^ self ]. - moveUnderHand - ifFalse: [ - positionInHandCoordinates _ (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) - morphPositionInWorld - self morphPositionInWorld ] - ifTrue: [ - "We can possibly do better, especially for non WidgetMorphs" - positionInHandCoordinates _ -30 @ -10. - grabbed isInWorld ifTrue: [ - grabbed displayBounds ifNotNil: [ :r | - positionInHandCoordinates _ (r extent // 2) negated ]]]. - ^ self - grabMorph: grabbed - delta: positionInHandCoordinates! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4439-GrabMorphFix-JuanVuletich-2020Oct28-08h49m-jmv.003.cs.st----! - -'From Cuis 5.0 [latest update: #4438] on 6 November 2020 at 12:43:41 pm'! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 11/6/2020 12:38:36' prior: 50537455! - grabMorph: aMorph delta: delta - "Grab the given morph (i.e., add it to this hand and remove it from its current owner)." - - | formerOwner formerPositionInWorld | - self releaseMouseFocus. "Break focus" - - "Grab the halo if present" - self halo ifNotNil: [ :h | - h target == aMorph ifTrue: [ - self addMorphBack: h position: h morphPositionInWorld - self morphPositionInWorld ]]. - - "Remember previous owner and position, in case the drop is later rejected" - formerOwner _ aMorph owner. - formerOwner ifNotNil: [ - formerPositionInWorld _ aMorph morphPositionInWorld. - grabMorphData - at: aMorph - put: { formerOwner. formerPositionInWorld. } ]. - self addMorphBack: aMorph position: delta. - aMorph displayBounds ifNotNil: [ :r | | d | - d _ aMorph morphPositionInWorld - formerPositionInWorld. - d isZero ifFalse: [ - aMorph displayBounds: (r translatedBy: d)]]. - aMorph justGrabbedFrom: formerOwner. - formerOwner ifNotNil: [ - lastPosition _ self morphPosition ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4440-GrabMorphFix-JuanVuletich-2020Nov06-12h43m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4438] on 6 November 2020 at 9:58:08 am'! -!PseudoClass methodsFor: 'methods' stamp: 'jmv 11/6/2020 09:57:50' prior: 50493790! - removeSelector: aSelector - | catName | - catName := self class removedCategoryName asString. - self organization addCategory: catName before: self organization categories first. - self organization classify: aSelector under: catName. - self sourceCodeAt: aSelector put:'methodWasRemoved' asText.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4441-PseudoClass-removeSelector-fix-JuanVuletich-2020Nov06-09h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4433] on 26 October 2020 at 1:18:49 pm'! -!WidgetMorph methodsFor: 'geometry' stamp: 'KenD 10/26/2020 13:16:01'! - ensureMinimimExtent - - self privateExtent: extent! ! -!WidgetMorph methodsFor: 'accessing' stamp: 'KenD 10/26/2020 13:16:39' prior: 50545871! - borderWidth: anInteger - borderWidth = anInteger ifFalse: [ - borderWidth _ anInteger max: 0. - self ensureMinimimExtent; - redrawNeeded ]! ! -!LabelMorph methodsFor: 'geometry' stamp: 'KenD 10/26/2020 13:02:40' prior: 50548517 overrides: 50499535! - minimumExtent - - ^ self measureContents + self extentBorder! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4442-CuisCore-EnsureMinExt-2020Oct26-13h02m-KenD.001.cs.st----! - -'From Cuis 5.0 [latest update: #4442] on 9 November 2020 at 12:12:47 pm'! -!ImageMorph methodsFor: 'drawing' stamp: 'KenD 10/29/2020 13:33:06' prior: 50503477 overrides: 50545911! - drawOn: aCanvas - - aCanvas image: image at: self morphTopLeft + self borderWidth. - (borderWidth > 0) ifTrue: [ - aCanvas - frameRectangle: (0@0 extent: self morphExtent) - color: borderColor - borderWidth: borderWidth - borderStyleSymbol: #simple ]! ! -!ImageMorph methodsFor: 'drawing' stamp: 'KenD 10/29/2020 13:21:26' prior: 16854132 overrides: 50499535! - minimumExtent - ^image extent + self extentBorder ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4443-ImageMorphFix-KenDickey-2020Nov09-12h11m-KenD.001.cs.st----! - -'From Cuis 5.0 [latest update: #4443] on 9 November 2020 at 3:30:17 pm'! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 11/9/2020 15:25:35'! - frameRectangle: aRectangle topLeftColor: tlColor bottomRightColor: brColor borderWidth: borderWidth - " - (BitBltCanvas onForm: Display) - frameRectangle: (10@10 extent: 300@200) - color: Color green - borderWidth: 10 - borderStyleSymbol: #raised. - Display forceToScreen. - " - - | displayRectangle bw | - - engine ifNil: [ ^nil ]. - - bw _ (currentTransformation externalizeScalar: borderWidth) rounded. - displayRectangle _ (currentTransformation externalizeRectangle: aRectangle) rounded. - self - frameRectangle: displayRectangle - borderWidth: bw - topLeftColor: tlColor - bottomRightColor: brColor.! ! -!MorphicCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 11/9/2020 15:28:39' prior: 50463457! - fillRectangle: aRectangle color: aColor borderWidth: borderWidth borderStyleSymbol: aSymbol baseColorForBorder: baseColorForBorder - " - (BitBltCanvas onForm: Display) - fillRectangle: (10@10 extent: 300@200) - color: Color green - borderWidth: 10 - borderStyleSymbol: #raised - baseColorForBorder: Color red. - Display forceToScreen. - " - - self fillRectangle: (aRectangle insetBy: borderWidth) color: aColor. - self frameRectangle: aRectangle color: baseColorForBorder borderWidth: borderWidth borderStyleSymbol: aSymbol! ! -!MorphicCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 11/9/2020 15:26:49' prior: 50463484! - frameRectangle: aRectangle color: aColor borderWidth: borderWidth borderStyleSymbol: aSymbol - " - (BitBltCanvas onForm: Display) - frameRectangle: (10@10 extent: 300@200) - color: Color green - borderWidth: 10 - borderStyleSymbol: #raised. - Display forceToScreen. - " - - | tlColor brColor | - - engine ifNil: [ ^nil ]. - - tlColor _ aColor. - brColor _ aColor. - aSymbol == #raised ifTrue: [ - tlColor _ aColor quiteWhiter. - brColor _ aColor quiteBlacker ]. - - aSymbol == #inset ifTrue: [ - tlColor _ aColor quiteBlacker. - brColor _ aColor quiteWhiter ]. - - self frameRectangle: aRectangle topLeftColor: tlColor bottomRightColor: brColor borderWidth: borderWidth! ! - -BitBltCanvas removeSelector: #fillRectangle:color:borderWidth:borderStyleSymbol:baseColorForBorder:! - -!methodRemoval: BitBltCanvas #fillRectangle:color:borderWidth:borderStyleSymbol:baseColorForBorder: stamp: 'Install-4444-MorphicCanvas-borderStyleTweaks-JuanVuletich-2020Nov09-15h03m-jmv.001.cs.st 12/30/2020 14:47:34'! -fillRectangle: aRectangle color: aColor borderWidth: borderWidth borderStyleSymbol: aSymbol baseColorForBorder: baseColorForBorder - - - engine ifNil: [ ^nil ]. - - self fillRectangle: (aRectangle insetBy: borderWidth) color: aColor. - self frameRectangle: aRectangle color: baseColorForBorder borderWidth: borderWidth borderStyleSymbol: aSymbol! - -BitBltCanvas removeSelector: #frameRectangle:color:borderWidth:borderStyleSymbol:! - -!methodRemoval: BitBltCanvas #frameRectangle:color:borderWidth:borderStyleSymbol: stamp: 'Install-4444-MorphicCanvas-borderStyleTweaks-JuanVuletich-2020Nov09-15h03m-jmv.001.cs.st 12/30/2020 14:47:34'! -frameRectangle: r color: aColor borderWidth: borderWidth borderStyleSymbol: aSymbol - " - Display getCanvas fillRectangle: (10@10 extent: 300@200) color: Color white. Display forceToScreen. - Display getCanvas - frameRectangle: (10@10 extent: 300@200) - color: Color green - borderWidth: 10 - borderStyleSymbol: #raised. - Display forceToScreen. - " - - | displayRectangle bw | - - engine ifNil: [ ^nil ]. - - bw _ (currentTransformation externalizeScalar: borderWidth) rounded. - aSymbol == #raised ifTrue: [ - displayRectangle _ (currentTransformation externalizeRectangle: r) rounded. - ^ self - frameRectangle: displayRectangle - borderWidth: bw - topLeftColor: aColor quiteWhiter - bottomRightColor: aColor quiteBlacker ]. - - aSymbol == #inset ifTrue: [ - displayRectangle _ (currentTransformation externalizeRectangle: r) rounded. - ^ self - frameRectangle: displayRectangle - borderWidth: bw - topLeftColor: aColor quiteBlacker - bottomRightColor: aColor quiteWhiter ]. - - "Unrecognized border style. Draw some border..." - self frameRectangle: r borderWidth: bw color: aColor! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4444-MorphicCanvas-borderStyleTweaks-JuanVuletich-2020Nov09-15h03m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4444] on 10 November 2020 at 2:20:59 pm'! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 11/10/2020 14:20:44' prior: 50555664! - grabMorph: aMorph delta: delta - "Grab the given morph (i.e., add it to this hand and remove it from its current owner)." - - | formerOwner formerPositionInWorld | - self releaseMouseFocus. "Break focus" - - "Grab the halo if present" - self halo ifNotNil: [ :h | - h target == aMorph ifTrue: [ - self addMorphBack: h position: h morphPositionInWorld - self morphPositionInWorld ]]. - - "Remember previous owner and position, in case the drop is later rejected" - formerOwner _ aMorph owner. - formerOwner ifNotNil: [ - formerPositionInWorld _ aMorph morphPositionInWorld. - grabMorphData - at: aMorph - put: { formerOwner. formerPositionInWorld. } ]. - self addMorphBack: aMorph position: delta. - aMorph displayBounds ifNotNil: [ :r | | d | - formerPositionInWorld ifNotNil: [ - d _ aMorph morphPositionInWorld - formerPositionInWorld. - d isZero ifFalse: [ - aMorph displayBounds: (r translatedBy: d)]]]. - aMorph justGrabbedFrom: formerOwner. - formerOwner ifNotNil: [ - lastPosition _ self morphPosition ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4445-HandMorphFix-JuanVuletich-2020Nov10-14h20m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4444] on 10 November 2020 at 2:37:36 pm'! -!GeometryTransformation class methodsFor: 'instance creation' stamp: 'jmv 10/23/2020 19:44:01'! - identity - ^MorphicTranslation withTranslation: 0@0! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 11/10/2020 14:29:48' prior: 50554229! - orbitBy: radians - "Rotate the receiver around the origin (0@0) in owner coordinates. - Argument is an angle (possibly negative), to be added to current rotation." - - location _ (AffineTransformation withRadians: radians) composedWith: location. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 11/10/2020 14:32:19' prior: 50554291! - rotationDegrees: degrees - "Change the rotation of this morph. Argument is an angle to be taken as the new rotation." - - self rotation: degrees degreesToRadians! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4446-Morphic-tweaks-JuanVuletich-2020Nov10-14h20m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4446] on 10 November 2020 at 3:42:56 pm'! -!Morph methodsFor: 'private' stamp: 'jmv 11/10/2020 15:40:44' prior: 50555348! - privateAddMorph: aMorph atIndex: index position: aPointOrNil - - | oldIndex myWorld itsWorld oldOwner | - (self canAdd: aMorph) ifFalse: [ - (self confirm: 'The requested morph requires VectorGraphics support. Do you want to install and activate it?') - ifTrue: [ - Feature require: 'VectorGraphics'. - MorphicCanvas activeSubclass: (Smalltalk at: #HybridCanvas) ] - ifFalse: [ - ^self error: 'We can''t add requested morph.' ]]. - ((index >= 1) and: [index <= (submorphs size + 1)]) - ifFalse: [^ self error: 'index out of range']. - myWorld _ self world. - oldOwner _ aMorph owner. - (oldOwner == self and: [(oldIndex _ submorphs indexOf: aMorph) > 0]) ifTrue: [ - "aMorph's position changes within in the submorph chain" - oldIndex < index ifTrue:[ - "moving aMorph to back" - submorphs replaceFrom: oldIndex to: index-2 with: submorphs startingAt: oldIndex+1. - submorphs at: index-1 put: aMorph. - ] ifFalse:[ - "moving aMorph to front" - oldIndex-1 to: index by: -1 do:[:i| - submorphs at: i+1 put: (submorphs at: i)]. - submorphs at: index put: aMorph. - ]. - aPointOrNil ifNotNil: [aMorph privatePosition: aPointOrNil]. - ] ifFalse: [ - "adding a new morph" - oldOwner ifNotNil: [ - itsWorld _ aMorph world. - itsWorld ifNotNil: [aMorph invalidateBounds]. - oldOwner privateRemove: aMorph. - oldOwner removedMorph: aMorph. - ]. - aMorph privateOwner: self. - submorphs _ submorphs copyReplaceFrom: index to: index-1 with: (Array with: aMorph). - aPointOrNil ifNotNil: [aMorph privatePosition: aPointOrNil]. - (itsWorld == myWorld) ifFalse: [aMorph intoWorld: myWorld]. - ]. - myWorld ifNotNil: [ - index = 1 - ifTrue: [aMorph redrawNeeded ] - ifFalse: [aMorph invalidateBounds]]. - self someSubmorphPositionOrExtentChanged. - oldOwner == self ifFalse: [ - self addedMorph: aMorph. - aMorph noteNewOwner: self ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4447-MorphInvalidationFix-JuanVuletich-2020Nov10-15h42m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4447] on 10 November 2020 at 4:31:24 pm'! -!MovableMorph methodsFor: 'dropping/grabbing' stamp: 'jmv 11/10/2020 16:14:40' overrides: 16874358! - aboutToBeGrabbedBy: aHand - "The receiver is being grabbed by a hand. - Perform necessary adjustments (if any) and return the actual morph - that should be added to the hand. - Answer nil to reject the drag." - - ^self "Grab me"! ! -!Morph methodsFor: 'dropping/grabbing' stamp: 'jmv 11/10/2020 16:15:25' prior: 16874358! - aboutToBeGrabbedBy: aHand - "The receiver is being grabbed by a hand. - Perform necessary adjustments (if any) and return the actual morph - that should be added to the hand. - Answer nil to reject the drag." - - ^nil "MovableMorphs can be grabbed and moved around with the hand"! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 11/10/2020 16:09:55' prior: 50388583! - drawCurrentAsError - "The morph (or one of its submorphs) had an error in its drawing method." - | r w | - r _ currentMorph morphLocalBounds intersect: clipRect. - r hasPositiveExtent ifFalse: [r _ clipRect ]. - w _ r extent > `50@50` - ifTrue: [ 6 ] - ifFalse: [ 2 ]. - self - frameAndFillRectangle: r - fillColor: `Color red` - borderWidth: w - borderColor: `Color yellow`. - self line: r topLeft to: r bottomRight-w width: w color: `Color yellow`. - self line: r topRight -(w@0) to: r bottomLeft -(0@w)width: w color: `Color yellow`! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4448-NonMovableMorphFixes-JuanVuletich-2020Nov10-16h30m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4448] on 11 November 2020 at 11:59:15 am'! -!LabelMorph methodsFor: 'initialization' stamp: 'jmv 11/11/2020 11:58:43' prior: 50333120 overrides: 50545903! - initialize - super initialize. - font _ nil. - emphasis _ 0. - self contents: 'Label Morph' -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4449-ItsLabelMorphNotStringMorph-JuanVuletich-2020Nov11-11h58m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4449] on 11 November 2020 at 1:03:24 pm'! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 11/11/2020 12:58:43' prior: 50494622 overrides: 50463562! - setForm: aForm - super setForm: aForm. - engine _ BitBltCanvasEngine toForm: form. - "Init BitBlt so that the first call to the 'primitiveDisplayString' primitive will not fail" - engine sourceX: 0; width: 0. - self newClipRect: nil.! ! - -BitBltCanvas removeSelector: #initializeWith:origin:! - -!methodRemoval: BitBltCanvas #initializeWith:origin: stamp: 'Install-4450-BitBltCanvasFix-JuanVuletich-2020Nov11-12h55m-jmv.001.cs.st 12/30/2020 14:47:34'! -initializeWith: aForm origin: aPoint - - super initializeWith: aForm origin: aPoint. - self resetEngine! - -BitBltCanvas removeSelector: #resetEngine! - -!methodRemoval: BitBltCanvas #resetEngine stamp: 'Install-4450-BitBltCanvasFix-JuanVuletich-2020Nov11-12h55m-jmv.001.cs.st 12/30/2020 14:47:34'! -resetEngine - "Private!! Create a new BitBltCanvasEngine for a new copy." - - engine _ BitBltCanvasEngine toForm: form. - "Init BitBlt so that the first call to the 'primitiveDisplayString' primitive will not fail" - engine sourceX: 0; width: 0! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4450-BitBltCanvasFix-JuanVuletich-2020Nov11-12h55m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4450] on 12 November 2020 at 10:50:18 am'! -!Morph methodsFor: 'accessing' stamp: 'jmv 11/12/2020 09:51:47' prior: 50540376! - morphId - "Non zero. A zero id in, for example, VectorEngine, means no Morph. - reserve lower 8 bits of numeric ivar for boolean flags." - " - Morph clearIds - " - | morphId | - morphId _ id >> 8. - morphId = 0 ifTrue: [ - LastMorphId isNil ifTrue: [ LastMorphId _ 0 ]. - LastMorphId _ LastMorphId + 1. - id _ LastMorphId << 8 + id. "Keep any flags" - morphId _ LastMorphId ]. - ^morphId! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4451-morphIdComment-JuanVuletich-2020Nov12-09h51m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4451] on 15 November 2020 at 10:26:39 am'! -!PluggableScrollPane methodsFor: 'access options' stamp: 'jmv 11/15/2020 09:30:29'! - alwaysShowVerticalScrollbar - - hideScrollBars _ #alwaysShowVertical. - self vShowScrollBar.! ! -!SystemWindow class methodsFor: 'instance creation' stamp: 'jmv 11/15/2020 10:25:36'! - editWordWrapText: aTextModel label: labelString - | textMorph window | - textMorph _ TextModelMorph withModel: aTextModel. - textMorph wrapFlag: true. - textMorph alwaysShowVerticalScrollbar. - window _ self new model: aTextModel. - window setLabel: labelString. - window layoutMorph - addMorph: textMorph - proportionalHeight: 1. - ^ window openInWorld! ! -!Workspace methodsFor: 'gui' stamp: 'jmv 11/15/2020 10:25:48' prior: 16945408 overrides: 16933891! -openLabel: aString - "Create a standard system view of the model, me, and open it." - | win | - win _ WorkspaceWindow editWordWrapText: self label: aString. - self changed: #actualContents. - ^win! ! -!PluggableScrollPane methodsFor: 'access options' stamp: 'jmv 11/15/2020 09:28:38' prior: 16889522! - hideScrollBarsIndefinitely - - hideScrollBars _ #hide. - self vHideScrollBar. - self hHideScrollBar.! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 11/15/2020 09:28:06' prior: 16889776! - updateScrollBarsBounds - - | t | - hideScrollBars = #hide ifTrue: [^self]. - t _ self scrollBarClass scrollbarThickness. - scrollBar - morphPosition: extent x - t - borderWidth @ borderWidth - extent: t @ self vScrollBarHeight. - hScrollBar - morphPosition: borderWidth @ (extent y - t - borderWidth) - extent: self hScrollBarWidth@t! ! -!PluggableScrollPane methodsFor: 'initialization' stamp: 'jmv 11/15/2020 09:28:59' prior: 50384498 overrides: 50384377! - initialize - - "initialize the state of the receiver" - super initialize. - hideScrollBars _ #showIfNeeded. - - "initialize the receiver's scrollBars" - scrollBar _ self scrollBarClass new model: self setValueSelector: #vScrollBarValue:. - hScrollBar _ self scrollBarClass new model: self setValueSelector: #hScrollBarValue:. - drawKeyboardFocusIndicator _ true. - - scroller _ self innerMorphClass new. - self addMorph: scroller. - self scrollerOffset: `0@ 0`. - self addMorph: scrollBar. - self addMorph: hScrollBar! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'jmv 11/15/2020 09:28:22' prior: 16889904! - hIsScrollbarNeeded - "Return whether the horz scrollbar is needed" - - self mightNeedHorizontalScrollBar ifFalse: [ ^false ]. - - "Don't show it if we were told not to." - hideScrollBars = #hide ifTrue: [ ^false ]. - - ^self hLeftoverScrollRange > 0! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'jmv 11/15/2020 09:31:36' prior: 16890016! - vIsScrollbarNeeded - "Return whether the vertical scrollbar is needed" - - "Don't show it if we were told not to." - hideScrollBars = #hide ifTrue: [ ^false ]. - - hideScrollBars = #alwaysShowVertical ifTrue: [ ^true ]. - - ^self vLeftoverScrollRange > 0! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4452-WorkspacesWithScrollBar-JuanVuletich-2020Nov15-10h23m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4451] on 15 November 2020 at 10:30:55 am'! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'jmv 11/15/2020 08:26:13' prior: 50516766! - doItProfiling: aBoolean - "Set the context to include pool vars of the model. Then evaluate. - Print the result on the Transcript" - | answer | - answer _ self - evaluateSelectionAndDo: [ :result | - Transcript finishEntry. - [result print] - on: UnhandledError - do: [:ex | 'printing doIt result failed' print]] - ifFail: nil - profiled: aBoolean. - morph formatAndStyleIfNeeded. "Needed to re-shout workspaces, that might have new variables binded." - ^answer! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'jmv 11/15/2020 08:25:28' prior: 50445249! - evaluateSelectionAndDo: aBlock ifFail: failBlock profiled: doProfile - "Treat the current selection as an expression; evaluate it and return the result - 3 +4 - " - | provider result receiver context methodAndCompiler | - - self lineSelectAndEmptyCheck: [^ '']. - - provider _ self codeProvider. - (provider respondsTo: #doItReceiver) - ifTrue: [ - receiver _ provider doItReceiver. - context _ provider doItContext] - ifFalse: [receiver _ context _ nil]. - - methodAndCompiler _ self compileSelectionFor: receiver in: context ifFail: [^ failBlock value]. - - result _ (methodAndCompiler at: #compiler) - evaluateMethod: (methodAndCompiler at: #method) - to: receiver - logged: true - profiled: doProfile. - - ^ aBlock value: result! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'jmv 11/15/2020 08:27:53' prior: 16909726! - exploreIt - - self - evaluateSelectionAndDo: [ :result | result explore ] - ifFail: [ morph flash ] - profiled: false. - morph formatAndStyleIfNeeded. "Needed to re-shout workspaces, that might have new variables binded."! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'jmv 11/15/2020 08:26:35' prior: 50452865! - inspectSelectionOrLine - - self - evaluateSelectionAndDo: [ :result | result inspect ] - ifFail: [ morph flash ] - profiled: false. - morph formatAndStyleIfNeeded. "Needed to re-shout workspaces, that might have new variables binded."! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4453-AvoidUnnededRestyles-JuanVuletich-2020Nov15-10h26m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4453] on 15 November 2020 at 2:07:57 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 11/15/2020 14:04:05'! - extentChanged: oldExtent - "Our extent changed. Must layout submorphs again." - - self layoutNeeded: true.! ! -!PasteUpMorph methodsFor: 'geometry' stamp: 'jmv 11/15/2020 11:32:36' overrides: 50556356! - extentChanged: oldExtent - "Our extent changed. Must layout submorphs again." - - super extentChanged: oldExtent. - self buildMagnifiedBackgroundImage.! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 11/15/2020 11:33:14' overrides: 50556363! - extentChanged: oldExtent - "Our extent changed. Must layout submorphs again." - - super extentChanged: oldExtent. - self setCanvas! ! -!InnerTextMorph methodsFor: 'geometry' stamp: 'jmv 11/15/2020 14:05:15' overrides: 50556356! - extentChanged: oldExtent - "Our extent changed. Reflow text." - super extentChanged: oldExtent. - wrapFlag ifTrue: [ - extent x = oldExtent x ifFalse: [ - self resetTextComposition. - self editor recomputeSelection. - owner - updateScrollBarsBounds; - setScrollDeltas ]]! ! -!PluggableButtonMorph methodsFor: 'geometry' stamp: 'jmv 11/15/2020 11:34:23' overrides: 50556356! - extentChanged: oldExtent - "Our extent changed. Must layout submorphs again." - - super extentChanged: oldExtent. - magnifiedIcon _ nil! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 11/15/2020 11:34:59' overrides: 50556356! - extentChanged: oldExtent - "Our extent changed. Must layout submorphs again." - - super extentChanged: oldExtent. - "Now reset widget sizes" - scroller adjustExtent. - self updateScrollBarsBounds. - self setScrollDeltas. - self scrollSelectionIntoView ! ! -!ScrollBar methodsFor: 'geometry' stamp: 'jmv 11/15/2020 11:36:06' overrides: 50556356! - extentChanged: oldExtent - "Our extent changed. Must layout submorphs again." - | isH wasH | - - super extentChanged: oldExtent. - wasH _ self isHorizontal. - "Doesn't move!!" - "upButton morphPosition: borderWidth@borderWidth." - downButton morphPosition: extent - borderWidth - downButton morphExtent. - isH _ self isHorizontal. - isH = wasH ifFalse: [ - isH - ifTrue: [ - upButton updateLeftButtonImage. - downButton updateRightButtonImage ] - ifFalse: [ - upButton updateUpButtonImage. - downButton updateDownButtonImage ]].! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 11/15/2020 10:59:42' prior: 50535408 overrides: 16875404! - morphExtent: newExtent - "assume it is always in our coordinates!!" - - | oldExtent | - extent = newExtent ifFalse: [ - oldExtent _ extent. - (self privateExtent: newExtent) ifTrue: [ - self extentChanged: oldExtent. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]]! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 11/15/2020 11:00:00' prior: 50535420! - morphPosition: newPos extent: newExtent - "Change the position of this morph. Argument is in owner's coordinates." - - | someChange oldExtent | - someChange _ false. - (location isTranslation: newPos) ifFalse: [ - location _ location withTranslation: newPos. - someChange _ true ]. - - extent = newExtent ifFalse: [ - oldExtent _ extent. - (self privateExtent: newExtent) ifTrue: [ - someChange _ true ]]. - - someChange ifTrue: [ - self extentChanged: oldExtent. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 11/15/2020 11:15:33' prior: 50555725! - ensureMinimimExtent - - | oldExtent | - oldExtent _ extent. - (self privateExtent: extent) ifTrue: [ - self extentChanged: oldExtent ].! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 11/15/2020 11:00:16' prior: 50545937 overrides: 16875404! - morphExtent: newExtent - "assume it is always in our coordinates!!" - - | oldExtent | - extent = newExtent ifFalse: [ - oldExtent _ extent. - (self privateExtent: newExtent) ifTrue: [ - self extentChanged: oldExtent. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]]! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 11/15/2020 11:00:31' prior: 50545968! - morphPosition: newPos extent: newExtent - "Change the position of this morph. Argument is in owner's coordinates." - - | someChange oldExtent | - someChange _ false. - (location isTranslation: newPos) ifFalse: [ - location _ location withTranslation: newPos. - someChange _ true ]. - - extent = newExtent ifFalse: [ - oldExtent _ extent. - (self privateExtent: newExtent) ifTrue: [ - someChange _ true ]]. - - someChange ifTrue: [ - self extentChanged: oldExtent. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]! ! -!ImageMorph methodsFor: 'accessing' stamp: 'jmv 11/15/2020 10:58:37' prior: 50535440! - image: anImage - | newExtent oldExtent | - image _ anImage depth = 1 - ifTrue: [ ColorForm mappingWhiteToTransparentFrom: anImage ] - ifFalse: [ anImage ]. - newExtent _ image extent. - extent = newExtent ifFalse: [ - oldExtent _ extent. - extent _ newExtent. - self extentChanged: oldExtent. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]]. - self redrawNeeded.! ! -!InnerTextMorph methodsFor: 'accessing' stamp: 'jmv 11/15/2020 11:30:31' prior: 50535455! - model: aTextModel wrappedTo: width - "Accept new text contents. Lay it out, wrapping to width. - Then fit my height to the result." - | newExtent | - wrapFlag _ true. - model _ aTextModel. - newExtent _ width truncated@extent y. - extent = newExtent ifFalse: [ - extent _ newExtent. - self someSubmorphPositionOrExtentChanged. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]. - self model: aTextModel! ! -!InnerTextMorph methodsFor: 'geometry' stamp: 'jmv 11/15/2020 11:16:56' prior: 16855887 overrides: 50546004! - privateExtent: aPoint - | newExtent | - - "Resist changing the extent if no wordwrap. this should be checked." - wrapFlag ifFalse: [ ^ false ]. - - "Just update width. Height is set by ourselves. See #fit" - newExtent _ aPoint x truncated @ extent y. - - ^ super privateExtent: newExtent! ! -!InnerTextMorph methodsFor: 'private' stamp: 'jmv 11/15/2020 10:59:06' prior: 50535471! - fit - "Adjust my bounds to fit the text. - Required after the text changes, - or if wrapFlag is true and the user attempts to change the extent." - - | newExtent newHeight newWidth oldExtent | - newWidth _ extent x. - "Adjust width only if we don't wrap text to own width!!" - wrapFlag ifFalse: [ - newWidth _ self textComposition usedWidth max: 9 ]. - newHeight _ self textComposition usedHeight max: FontFamily defaultLineSpacing + 2. - newExtent _ newWidth @ newHeight. - extent = newExtent - ifTrue: [ - self redrawNeeded. - "Too conservative: only text composition (because of changes in text or styles, etc) - should cause invalidation. - Try to avoid calling #fit unless needed." - ] - ifFalse: [ - extent = newExtent ifFalse: [ - oldExtent _ extent. - extent _ newExtent. - self extentChanged: oldExtent. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]]. - - owner innerHeight: newExtent y! ! - -ScrollBar removeSelector: #privateExtent:! - -!methodRemoval: ScrollBar #privateExtent: stamp: 'Install-4454-extentChanged-JuanVuletich-2020Nov15-14h03m-jmv.001.cs.st 12/30/2020 14:47:34'! -privateExtent: aPoint - | isH wasH | - wasH _ self isHorizontal. - ^ (super privateExtent: aPoint) - ifTrue: [ - "Doesn't move!!" - "upButton morphPosition: borderWidth@borderWidth." - downButton morphPosition: extent - borderWidth - downButton morphExtent. - isH _ self isHorizontal. - isH = wasH ifFalse: [ - isH - ifTrue: [ - upButton updateLeftButtonImage. - downButton updateRightButtonImage ] - ifFalse: [ - upButton updateUpButtonImage. - downButton updateDownButtonImage ]]. - ]; yourself! - -PluggableScrollPane removeSelector: #privateExtent:! - -!methodRemoval: PluggableScrollPane #privateExtent: stamp: 'Install-4454-extentChanged-JuanVuletich-2020Nov15-14h03m-jmv.001.cs.st 12/30/2020 14:47:34'! -privateExtent: aPoint - - ^ (super privateExtent: aPoint) - ifTrue: [ - "Now reset widget sizes" - scroller adjustExtent. - self updateScrollBarsBounds. - self setScrollDeltas. - self scrollSelectionIntoView ]; yourself! - -PluggableButtonMorph removeSelector: #privateExtent:! - -!methodRemoval: PluggableButtonMorph #privateExtent: stamp: 'Install-4454-extentChanged-JuanVuletich-2020Nov15-14h03m-jmv.001.cs.st 12/30/2020 14:47:34'! -privateExtent: aPoint - - ^ (super privateExtent: aPoint) - ifTrue: [ - magnifiedIcon _ nil ]; yourself! - -WorldMorph removeSelector: #privateExtent:! - -!methodRemoval: WorldMorph #privateExtent: stamp: 'Install-4454-extentChanged-JuanVuletich-2020Nov15-14h03m-jmv.001.cs.st 12/30/2020 14:47:34'! -privateExtent: newExtent - - ^ (super privateExtent: newExtent) - ifTrue: [ - self setCanvas ]; - yourself! - -PasteUpMorph removeSelector: #privateExtent:! - -!methodRemoval: PasteUpMorph #privateExtent: stamp: 'Install-4454-extentChanged-JuanVuletich-2020Nov15-14h03m-jmv.001.cs.st 12/30/2020 14:47:34'! -privateExtent: newExtent - - ^ (super privateExtent: newExtent) - ifTrue: [ self buildMagnifiedBackgroundImage ]; - yourself! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4454-extentChanged-JuanVuletich-2020Nov15-14h03m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4453] on 15 November 2020 at 2:26:04 pm'! -!TextModel methodsFor: 'accessing' stamp: 'jmv 11/15/2020 14:25:21' prior: 16933710! - textSize - actualContents ifNil: [ ^0 ]. - ^actualContents size! ! -!InnerTextMorph methodsFor: 'accessing' stamp: 'jmv 11/15/2020 14:25:48' prior: 50556518! - model: aTextModel wrappedTo: width - "Accept new text contents. Lay it out, wrapping to width. - Then fit my height to the result." - | newExtent oldExtent | - wrapFlag _ true. - model _ aTextModel. - newExtent _ width truncated@extent y. - extent = newExtent ifFalse: [ - oldExtent _ extent. - extent _ newExtent. - self extentChanged: oldExtent. - self someSubmorphPositionOrExtentChanged. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]. - self model: aTextModel! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4455-extentChangedCoda-JuanVuletich-2020Nov15-14h07m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4453] on 15 November 2020 at 2:54:41 pm'! -!TextEmphasis commentStamp: '' prior: 16933273! - A TextEmphasis, encodes a characteristic applicable to all fonts. The encoding is as follows: - 1 bold - 2 italic - 4 underlined - 8 struck out - 16 Superscript - 32 Subscript - 64 with ST-80 Glyphs! -!TextModel methodsFor: 'user interface support' stamp: 'jmv 11/15/2020 14:54:14'! - allowStylingWithEmphasis - "Default for Smalltalk methods" - - ^true! ! -!Workspace methodsFor: 'user interface support' stamp: 'jmv 11/15/2020 14:53:54' overrides: 50556692! - allowStylingWithEmphasis - "Faster styling of large contents, as text metrics are not affected." - - ^false! ! -!SHTextStylerST80 methodsFor: 'styling' stamp: 'jmv 11/15/2020 14:51:24'! - styleWorkspaceFrom: start to: end allowEmphasis: aBoolean - "Style a copy of part of the model text. Then apply attributes to model text. Useful for Workspaces. - Call #formatWorkspace: becore calling us. - Note: classOrMetaClass is assumed to be nil. - Note: after last call, do `textModel changed: #shoutStyled`" - - parser - source: (formattedText asString copyFrom: start to: end). - parser parse. - parser ranges ifNotNil: [ :ranges | - ranges do: [ :range | - (self attributesFor: range rangeType) ifNotNil: [ :attributes | - attributes do: [ :each | - "For Workspaces, avoid attributes that affect text layout: very large contents would be slow." - (aBoolean or: [each emphasisCode noMask: 3]) ifTrue: [ - formattedText - addAttribute: each - from: range start +start-1 - to: range end +start-1 ]]]]].! ! -!Workspace methodsFor: 'user interface support' stamp: 'jmv 11/15/2020 14:47:17' prior: 50519077 overrides: 50368786! - formatAndStyleIfNeededWith: anSHTextStyler - | separator fragmentStart fragmentEnd done| - (anSHTextStyler notNil and: [self shouldStyle: self actualContents with: anSHTextStyler]) - ifFalse: [^ self]. - - self styleByParagraphs ifFalse: [ - ^super formatAndStyleIfNeededWith: anSHTextStyler ]. - - actualContents _ actualContents optimizedForMutationSpeed. - anSHTextStyler formatWorkspace: actualContents. - separator _ String newLineString, String newLineString. - fragmentStart _ 1. - done _ false. - [done] whileFalse: [ - fragmentEnd _ actualContents - indexOfSubCollection: separator - startingAt: fragmentStart - ifAbsent: [done _ true. actualContents size]. - anSHTextStyler styleWorkspaceFrom: fragmentStart to: fragmentEnd allowEmphasis: self allowStylingWithEmphasis. - fragmentStart _ fragmentEnd+separator size ]. - self changed: #shoutStyled! ! -!InnerTextMorph methodsFor: 'shout' stamp: 'jmv 11/15/2020 14:47:31' prior: 16856215! - stylerStyled - - model allowStylingWithEmphasis ifTrue: [ - self textComposition composeAll ]. - self editor recomputeSelection. - self updateFromTextComposition. - self editor blinkParen. - self scrollSelectionIntoView! ! -!SHTextStylerST80 methodsFor: 'styling' stamp: 'jmv 11/15/2020 09:51:23' prior: 50518135! - formatWorkspace: text - "Do first stage of styling. - Afterwards, call #styleWorkspaceFrom:to: as needed. - Note: classOrMetaClass is assumed to be nil" - - self terminateBackgroundStylingProcess. - formattedText _ text. - self privateFormatAndConvert. - formattedText removeAttributesThat: [ :attribute | attribute isForShout ]. - - parser ifNil: [ parser := SHParserST80 new ]. - parser - workspace: workspace; - classOrMetaClass: nil! ! - -SHTextStylerST80 removeSelector: #styleWorkspaceFrom:to:! - -!methodRemoval: SHTextStylerST80 #styleWorkspaceFrom:to: stamp: 'Install-4456-DisableWorkspaceShoutBoldItalic-JuanVuletich-2020Nov15-14h26m-jmv.001.cs.st 12/30/2020 14:47:34'! -styleWorkspaceFrom: start to: end - "Style a copy of part of the model text. Then apply attributes to model text. Useful for Workspaces. - Call #formatWorkspace: becore calling us. - Note: classOrMetaClass is assumed to be nil. - Note: after last call, do `textModel changed: #shoutStyled`" - - parser - source: (formattedText asString copyFrom: start to: end). - parser parse. - parser ranges ifNotNil: [ :ranges | - ranges do: [ :range | - (self attributesFor: range rangeType) ifNotNil: [ :attributes | - attributes do: [ :each | - formattedText - addAttribute: each - from: range start +start-1 - to: range end +start-1 ]]]].! - -Workspace removeSelector: #allowEmphasis! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4456-DisableWorkspaceShoutBoldItalic-JuanVuletich-2020Nov15-14h26m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4456] on 16 November 2020 at 10:59:06 am'! - -TextModel subclass: #Workspace - instanceVariableNames: 'bindings mustDeclareVariables shouldStyle fullPrintIt ' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Text'! - -!classDefinition: #Workspace category: #'System-Text' stamp: 'Install-4457-Workspace-fullPrintIt-option-JuanVuletich-2020Nov16-10h41m-jmv.001.cs.st 12/30/2020 14:47:34'! -TextModel subclass: #Workspace - instanceVariableNames: 'bindings mustDeclareVariables shouldStyle fullPrintIt' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Text'! -!TextModel methodsFor: 'user interface support' stamp: 'jmv 11/16/2020 10:57:17'! - fullPrintIt - ^true! ! -!Workspace methodsFor: 'user interface support' stamp: 'jmv 11/16/2020 10:48:58' overrides: 50556844! - fullPrintIt - - ^fullPrintIt ifNil: [ Preferences fullPrintItInWorkspaces]! ! -!Workspace methodsFor: 'user interface support' stamp: 'jmv 11/16/2020 10:51:34'! - toggleFullPrintIt - - fullPrintIt _ self fullPrintIt not.! ! -!Workspace methodsFor: 'user interface support' stamp: 'jmv 11/16/2020 10:50:46'! - toggleFullPrintItLabel - - ^self fullPrintIt - ifTrue: [ ' full printIt' ] - ifFalse: [ ' full printIt' ]! ! -!Preferences class methodsFor: 'personalization' stamp: 'jmv 11/16/2020 10:48:24'! - fullPrintItInWorkspaces - ^ self - valueOfFlag: #fullPrintItInWorkspaces - ifAbsent: [false]! ! -!Workspace methodsFor: 'initialization' stamp: 'jmv 11/16/2020 10:41:49' prior: 16945446 overrides: 16933882! - initialize - - super initialize. - self initializeBindings. - mustDeclareVariables _ false. - fullPrintIt _ false.! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'jmv 11/16/2020 10:58:25' prior: 16909738! - printIt - "Treat the current text selection as an expression; evaluate it. Insert the - description of the result of evaluation after the selection and then make - this description the new text selection." - | rpt | - self - evaluateSelectionAndDo: [ :result | - rpt _ model fullPrintIt - ifTrue: [result printText] - ifFalse: [result printTextLimitedTo: 10000]. - self afterSelectionInsertAndSelect: - ((' ', rpt, ' ') initialFontFrom: emphasisHere)] - ifFail: [ morph flash ] - profiled: false.! ! -!WorkspaceWindow methodsFor: 'menu' stamp: 'jmv 11/16/2020 10:50:55' prior: 50375071 overrides: 16926415! - addCustomMenuItems: aCustomMenu hand: aHandMorph - super addCustomMenuItems: aCustomMenu hand: aHandMorph. - aCustomMenu addLine. - aCustomMenu - add: 'reset variables' - target: model - action: #initializeBindings. - aCustomMenu - addUpdating: #mustDeclareVariableWording - target: model - action: #toggleVariableDeclarationMode. - aCustomMenu - addUpdating: #toggleStylingLabel - target: model - action: #toggleStyling. - aCustomMenu - addUpdating: #toggleFullPrintItLabel - target: model - action: #toggleFullPrintIt.! ! -!WorkspaceWindow methodsFor: 'menu' stamp: 'jmv 11/16/2020 10:53:20' prior: 50400085 overrides: 16926510! - offerWindowMenu - | aMenu | - aMenu _ self buildWindowMenu. - aMenu addLine. - aMenu - add: 'reset variables' - target: model - action: #initializeBindings - icon: #warningIcon. - aMenu - addUpdating: #mustDeclareVariableWording - target: model - action: #toggleVariableDeclarationMode. - aMenu - addUpdating: #toggleStylingLabel - target: model - action: #toggleStyling. - aMenu - addUpdating: #toggleFullPrintItLabel - target: model - action: #toggleFullPrintIt. - aMenu popUpInWorld: self world! ! - -TextModel subclass: #Workspace - instanceVariableNames: 'bindings mustDeclareVariables shouldStyle fullPrintIt' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Text'! - -!classDefinition: #Workspace category: #'System-Text' stamp: 'Install-4457-Workspace-fullPrintIt-option-JuanVuletich-2020Nov16-10h41m-jmv.001.cs.st 12/30/2020 14:47:34'! -TextModel subclass: #Workspace - instanceVariableNames: 'bindings mustDeclareVariables shouldStyle fullPrintIt' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Text'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4457-Workspace-fullPrintIt-option-JuanVuletich-2020Nov16-10h41m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4451] on 17 November 2020 at 9:25:23 am'! -!Morph methodsFor: 'change reporting' stamp: 'jmv 11/16/2020 23:00:04'! - invalidateDisplayRect: damageRect for: aMorph - " - If we clip submorphs, then we clip damageRect. - - aMorph is the morph that changed and therefore should be redrawn. In some cases, damage reporting is done by no longer occupying some area, and requesting whatever appropriate morph to be drawn there. In such cases, aMorph should be nil. See senders." - - | clippedRect b | - - "warning. Senders are using global coordinates. Redesign!!" - "local now!!!!!!!!!!" - self flag: #jmvVer2. "ok?" - - self visible ifFalse: [ ^self]. - - clippedRect _ damageRect. - self clipsSubmorphs ifTrue: [ - b _ self displayBounds. - b ifNil: [ ^self ]. - clippedRect _ damageRect intersect: b ]. - owner ifNotNil: [ - owner invalidateDisplayRect: clippedRect for: aMorph ]! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 11/16/2020 22:40:52'! - clipsSubmorphs - "Answer true if we clip the shape of our submorphs to our own. - Answer true only when clipping by the canvas is needed. - Morphs that can guarantee that submorphs don't protrude and answer false to - #submorphsMightProtrude should answer false for better performance" - - ^ false! ! -!WorldMorph methodsFor: 'change reporting' stamp: 'jmv 11/16/2020 22:55:54' overrides: 50556962! - invalidateDisplayRect: damageRect for: aMorph - "Clip damage reports to my bounds, since drawing is _always_ clipped to my bounds." - - self recordDamagedRect: (damageRect intersect: self morphLocalBounds ) for: aMorph! ! -!PluggableScrollPane methodsFor: 'geometry testing' stamp: 'jmv 11/16/2020 22:41:33' overrides: 50556988! - clipsSubmorphs - "Answer true if we clip the shape of our submorphs to our own. - Answer true only when clipping by the canvas is needed. - Morphs that can guarantee that submorphs don't protrude and answer false to - #submorphsMightProtrude should answer false for better performance" - - ^ true! ! -!Morph methodsFor: 'change reporting' stamp: 'jmv 11/16/2020 23:00:45' prior: 50538622! - invalidateLocalRect: localRectangle - - self invalidateDisplayRect: (self externalizeDisplayBounds: localRectangle) for: self! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 11/16/2020 23:07:15' prior: 50540886! - displayFullBounds - "Answer a rectangle that completely bounds receiver and submorphs when last drawn - (if the world was to be fully drawn, i.e. only to be used on a Canvas on the full world)." - - | answer | - answer _ self displayBounds. - answer ifNil: [ ^nil ]. - (self submorphsMightProtrude and: [self clipsSubmorphs not]) ifTrue: [ - self submorphsReverseDo: [ :m | - answer _ answer quickMerge: m displayFullBounds ]]. - ^answer! ! -!Morph methodsFor: 'updating' stamp: 'jmv 11/16/2020 23:00:32' prior: 50541268! - invalidateBounds - "Report that the area occupied by this morph should be redrawn, - but most likely we are not going to be redrawn on it, or maybe we'll not be fully visible. See senders." - - self invalidateDisplayRect: self displayBoundsOrBogus for: nil.! ! -!Morph methodsFor: 'updating' stamp: 'jmv 11/16/2020 23:07:38' prior: 50541344! - redrawNeeded - "Report that the area occupied by this morph should be redrawn. - Usually because we changed in some way." - - self needsRedraw: true. - self allOwnersDo: [ :m | m submorphNeedsRedraw: true ]. - self invalidateDisplayRect: self displayBoundsOrBogus for: self. - (self submorphsMightProtrude and: [self clipsSubmorphs not]) ifTrue: [ - self submorphsReverseDo: [ :m | m redrawNeeded ]].! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 11/16/2020 23:00:22' prior: 50540336! -restoreSavedPatchOn: aCanvas - "Clear the changed flag and restore the part of the given canvas under this hand from the previously saved patch. If necessary, handle the transition to using the hardware cursor." - hasChanged _ false. - savedPatch ifNotNil: [ - aCanvas restorePatch: savedPatch. - submorphs notEmpty ifTrue: [ ^ self ]. - "Make the transition to using hardware cursor. Clear savedPatch and - report one final damage rectangle to erase the image of the software cursor." - " owner invalidateDisplayRect: (savedPatch offset extent: savedPatch extent) from: nil." - self invalidateDisplayRect: (self morphPosition extent: extent) for: nil. - Cursor currentCursor == Cursor defaultCursor ifFalse: [ Cursor defaultCursor activateCursor ]. - "show hardware cursor" - savedPatch _ nil ].! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 11/16/2020 23:04:23' prior: 50534099! - drawCurrentAndSubmorphs - - self isCurrentMorphVisible ifTrue: [ - currentMorph drawOn: self. - world notNil ifTrue: [ "Only if we are drawing the world" - currentMorph displayBounds: self boundingRectOfCurrentMorphAfterDraw ]. - "Display submorphs back to front" - "coordinate system stack already set up for aMorph - ('ivars transformations' and 'currentTransformation')" - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | self fullDraw: m ]]].! ! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 11/16/2020 23:03:34' prior: 50533846! - clippingByCurrentMorphDo: aBlock - "Do clipping only if currentMorph says so" - - | prevClipRect prevClippingMorphRect | - - currentMorph clipsSubmorphs ifFalse: [ ^aBlock value ]. - - prevClipRect _ self clipRect. - prevClippingMorphRect _ clippingMorphDisplayBounds. - "Might use the fact that currentMorph has just been drawn." - clippingMorphDisplayBounds _ self boundingRectOfCurrentMorphAfterDraw. - self setClipRect: (prevClipRect intersect: clippingMorphDisplayBounds). - self clippingMorph: currentMorph. - aBlock ensure: [ - self clippingMorph: nil. - self setClipRect: prevClipRect. - clippingMorphDisplayBounds _ prevClippingMorphRect ]! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 11/16/2020 23:04:52' prior: 50555270! - fullAddCurrentRect: addCurrentBounds submorphs: trySubmorphs to: aDamageRecorder - - addCurrentBounds ifTrue: [ - currentMorph needsRedraw: false. - self fullUpdateCurrentBounds. - aDamageRecorder recordInvalidRect: currentMorph displayBounds for: currentMorph ]. - trySubmorphs ifTrue: [ - currentMorph submorphNeedsRedraw: false. - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | - self fullAddRedrawRect: m to: aDamageRecorder ]]].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 11/16/2020 23:05:08' prior: 50536598! - updateCurrentDisplayBounds - "Update displayBounds for if never set. - Useful for new morph, that are created and attached to the hand." - - currentMorph drawOn: self. - currentMorph displayBounds: self boundingRectOfCurrentMorphAfterDraw. - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | self updateDisplayBounds: m ]].! ! - -PluggableScrollPane removeSelector: #clipsLastSubmorph! - -!methodRemoval: PluggableScrollPane #clipsLastSubmorph stamp: 'Install-4458-ClipAllSubmorphsNotJustLast-JuanVuletich-2020Nov17-09h24m-jmv.001.cs.st 12/30/2020 14:47:34'! -clipsLastSubmorph - "Answer true if we clip the shape of our last submorph to ours. - Answer true only when clipping by the canvas is needed." - - ^ true! - -WorldMorph removeSelector: #invalidateDisplayRect:fromSubmorph:for:! - -!methodRemoval: WorldMorph #invalidateDisplayRect:fromSubmorph:for: stamp: 'Install-4458-ClipAllSubmorphsNotJustLast-JuanVuletich-2020Nov17-09h24m-jmv.001.cs.st 12/30/2020 14:47:34'! -invalidateDisplayRect: damageRect fromSubmorph: submorphOrNil for: aMorph - "Clip damage reports to my bounds, since drawing is _always_ clipped to my bounds." - - self recordDamagedRect: (damageRect intersect: self morphLocalBounds ) for: aMorph! - -Morph removeSelector: #clippedSubmorph! - -!methodRemoval: Morph #clippedSubmorph stamp: 'Install-4458-ClipAllSubmorphsNotJustLast-JuanVuletich-2020Nov17-09h24m-jmv.001.cs.st 12/30/2020 14:47:34'! -clippedSubmorph - | i | - ^(self clipsLastSubmorph and: [ - i _ submorphs size. - i ~= 0]) ifTrue: [ - submorphs at: i ]! - -Morph removeSelector: #unclippedSubmorphsReverseDo:! - -!methodRemoval: Morph #unclippedSubmorphsReverseDo: stamp: 'Install-4458-ClipAllSubmorphsNotJustLast-JuanVuletich-2020Nov17-09h24m-jmv.001.cs.st 12/30/2020 14:47:34'! -unclippedSubmorphsReverseDo: aBlock - | lastClippedIndex | - lastClippedIndex _ submorphs size. - self clipsLastSubmorph ifTrue: [ - lastClippedIndex _ lastClippedIndex - 1 ]. - lastClippedIndex to: 1 by: -1 do: [ :index | - aBlock value: (submorphs at: index) ]! - -Morph removeSelector: #clipsLastSubmorph! - -!methodRemoval: Morph #clipsLastSubmorph stamp: 'Install-4458-ClipAllSubmorphsNotJustLast-JuanVuletich-2020Nov17-09h24m-jmv.001.cs.st 12/30/2020 14:47:34'! -clipsLastSubmorph - "Answer true if we clip the shape of our last submorph to ours. - Answer true only when clipping by the canvas is needed." - - ^ false! - -Morph removeSelector: #submorphsDrawingOutsideReverseDo:! - -!methodRemoval: Morph #submorphsDrawingOutsideReverseDo: stamp: 'Install-4458-ClipAllSubmorphsNotJustLast-JuanVuletich-2020Nov17-09h24m-jmv.001.cs.st 12/30/2020 14:47:34'! -submorphsDrawingOutsideReverseDo: aBlock - "Might be redefined in subclasses that know that its submorphs are never outside itself" - - self submorphsMightProtrude ifTrue: [ - self unclippedSubmorphsReverseDo: aBlock ].! - -Morph removeSelector: #invalidateDisplayRect:fromSubmorph:for:! - -!methodRemoval: Morph #invalidateDisplayRect:fromSubmorph:for: stamp: 'Install-4458-ClipAllSubmorphsNotJustLast-JuanVuletich-2020Nov17-09h24m-jmv.001.cs.st 12/30/2020 14:47:34'! -invalidateDisplayRect: damageRect fromSubmorph: submorphOrNil for: aMorph - " - If we clip submorphOrNil, then we clip damageRect. - When calling from self, submorphOrNil should be nil, i.e. we are not reporting damage for some submorph. - - aMorph is the morph that changed and therefore should be redrawn. In some cases, damage reporting is done by no longer occupying some area, and requesting whatever appropriate morph to be drawn there. In such cases, aMorph should be nil. See senders." - - | clippedRect b | - - "warning. Senders are using global coordinates. Redesign!!" - "local now!!!!!!!!!!" - self flag: #jmvVer2. "ok?" - - self visible ifFalse: [ ^self]. - - clippedRect _ damageRect. - submorphOrNil ifNotNil: [ - submorphOrNil == self clippedSubmorph - ifTrue: [ - b _ self displayBounds. - b ifNil: [ ^self ]. - clippedRect _ damageRect intersect: b ]]. - owner ifNotNil: [ - owner invalidateDisplayRect: clippedRect fromSubmorph: self for: aMorph ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4458-ClipAllSubmorphsNotJustLast-JuanVuletich-2020Nov17-09h24m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4453] on 17 November 2020 at 2:53:21 pm'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 11/17/2020 14:51:05'! - clipCurrentMorph: aBoolean! ! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 11/17/2020 14:51:56' prior: 50557120! - clippingByCurrentMorphDo: aBlock - "Do clipping only if currentMorph says so" - - | prevClipRect prevClippingMorphRect | - - currentMorph clipsSubmorphs ifFalse: [ ^aBlock value ]. - - prevClipRect _ self clipRect. - prevClippingMorphRect _ clippingMorphDisplayBounds. - "Might use the fact that currentMorph has just been drawn." - clippingMorphDisplayBounds _ self boundingRectOfCurrentMorphAfterDraw. - self setClipRect: (prevClipRect intersect: clippingMorphDisplayBounds). - self clipCurrentMorph: true. - aBlock ensure: [ - self clipCurrentMorph: false. - self setClipRect: prevClipRect. - clippingMorphDisplayBounds _ prevClippingMorphRect ]! ! - -MorphicCanvas removeSelector: #clippingMorph:! - -!methodRemoval: MorphicCanvas #clippingMorph: stamp: 'Install-4459-clipCurrentMorph-JuanVuletich-2020Nov17-14h51m-jmv.001.cs.st 12/30/2020 14:47:34'! -clippingMorph: aMorph! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4459-clipCurrentMorph-JuanVuletich-2020Nov17-14h51m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4459] on 17 November 2020 at 4:06:36 pm'! -!TranscriptMorph methodsFor: 'geometry testing' stamp: 'jmv 11/17/2020 16:06:01' overrides: 50556988! - clipsSubmorphs - "Answer true if we clip the shape of our submorphs to our own. - Answer true only when clipping by the canvas is needed. - Morphs that can guarantee that submorphs don't protrude and answer false to - #submorphsMightProtrude should answer false for better performance" - - ^ true! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4460-Transcript-fix-JuanVuletich-2020Nov17-16h03m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4460] on 19 November 2020 at 1:16:10 pm'! -!Color class methodsFor: 'color from user' stamp: 'jmv 11/19/2020 11:13:32' prior: 50498334! - colorPaletteForDepth: depth extent: chartExtent - "Display a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." - "Note: It is slow to build this palette, so it should be cached for quick access." - "(Color colorPaletteForDepth: 16 extent: 190@60) display" - - | basicHue x y startHue palette transHt vSteps grayWidth hSteps | - palette _ Form extent: chartExtent depth: depth. - transHt _ FontFamily defaultPointSize * 3//2. - palette fillWhite: (`0@0` extent: palette width@transHt). - palette fillBlack: (0@transHt extent: palette width@1). - 'no color' displayOn: palette at: palette boundingBox topCenter - ((transHt * 2)@0). - grayWidth _ 10. - startHue _ 338.0. - vSteps _ palette height - transHt // 2. - hSteps _ palette width - grayWidth. - x _ 0. - startHue to: startHue + 360.0 by: 360.0/hSteps do: [ :h | - basicHue _ Color h: h asFloat s: 1.0 v: 1.0. - y _ transHt+1. - 0 to: vSteps do: [ :n | | c | - c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Color white. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - 1 to: vSteps do: [ :n | | c | - c _ Color black mixed: (n asFloat / vSteps asFloat) with: basicHue. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - x _ x + 1]. - y _ transHt + 1. - 1 to: vSteps * 2 do: [ :n | | c | - c _ Color black mixed: (n asFloat / (vSteps*2) asFloat) with: Color white. - palette fill: (x@y extent: 10@1) fillColor: c. - y _ y + 1]. - ^ palette -! ! -!Color class methodsFor: 'color from user' stamp: 'jmv 11/19/2020 11:13:56' prior: 50357403! - colorTest: depth extent: chartExtent colorMapper: colorMapper - "Create a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." - "Note: It is slow to build this palette, so it should be cached for quick access." - "(Color colorTest: 32 extent: 570@180 colorMapper: [:c | c]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 7) asInteger / 7 - g: (c green * 7) asInteger / 7 - b: (c blue * 3) asInteger / 3]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 5) asInteger / 5 - g: (c green * 5) asInteger / 5 - b: (c blue * 5) asInteger / 5]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 15) asInteger / 15 - g: (c green * 15) asInteger / 15 - b: (c blue * 15) asInteger / 15]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 31) asInteger / 31 - g: (c green * 31) asInteger / 31 - b: (c blue * 31) asInteger / 31]) display" - - | basicHue x y c startHue palette transHt vSteps grayWidth hSteps | - palette _ Form extent: chartExtent depth: depth. - transHt _ FontFamily defaultPointSize * 3//2. - palette fillWhite: (0@0 extent: palette width@transHt). - palette fillBlack: (0@transHt extent: palette width@1). - 'no color' displayOn: palette at: palette boundingBox topCenter - ((transHt * 2)@0). - grayWidth _ 10. - startHue _ 338.0. - vSteps _ palette height - transHt // 2. - hSteps _ palette width - grayWidth. - x _ 0. - startHue to: startHue + 360.0 by: 360.0/hSteps do: [:h | - basicHue _ Color h: h asFloat s: 1.0 v: 1.0. - y _ transHt+1. - 0 to: vSteps do: [:n | - c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Color white. - c _ colorMapper value: c. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - 1 to: vSteps do: [:n | - c _ Color black mixed: (n asFloat / vSteps asFloat) with: basicHue. - c _ colorMapper value: c. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - x _ x + 1]. - y _ transHt + 1. - 1 to: vSteps * 2 do: [:n | - c _ Color black mixed: (n asFloat / (vSteps*2) asFloat) with: Color white. - c _ colorMapper value: c. - palette fill: (x@y extent: 10@1) fillColor: c. - y _ y + 1]. - ^ palette -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4461-ColorPalette-titleHackRemoval-JuanVuletich-2020Nov19-13h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4460] on 19 November 2020 at 1:17:25 pm'! -!Form methodsFor: 'fileIn/Out' stamp: 'jmv 11/19/2020 11:42:10'! - storeSmall1BitBitsOn: aStream - "Only valid for 1 bit narrow Forms." - - | shift | - shift _ 32 - width. - bits do: [ :word | - "Print binary with radix, but padded, so the bit pattern is easy to see." - aStream newLineTab: 2. - aStream nextPut: $2. - aStream nextPut: $r. - word >> shift printOn: aStream base: 2 length: width padded: true ]! ! -!Form methodsFor: 'fileIn/Out' stamp: 'jmv 11/19/2020 11:40:21'! - storeSmall1BitOn: aStream - "Store the receiver out as an expression that can be evaluated to recreate a Form with the same contents as the original." - aStream nextPut: $(. - aStream nextPutAll: self species name. - aStream newLineTab: 1. - aStream nextPutAll: 'small1BitExtent: '. - self extent printOn: aStream. - aStream newLineTab: 1. - aStream nextPutAll: 'pixelBits: #('. - self storeSmall1BitBitsOn: aStream. - aStream nextPut: $). - aStream newLineTab: 1. - aStream nextPutAll: 'offset: '. - self offset printOn: aStream. - aStream nextPut: $). -! ! -!Form methodsFor: 'private' stamp: 'jmv 11/19/2020 11:03:44'! - fillSmall1BitWith: pixelBits - "Fill a narrow 1 bit Form. - Each value in argument holds pixels (i.e. bits) for one line. - Useful for Cursors and small icons." - - | shift | - self assert: depth = 1. - self assert: width <= 32. "meaning self wordsPerLine = 1." - shift _ 32 - width. - 1 to: (height min: pixelBits size) do: [ :i | - bits at: i put: (pixelBits at: i) << shift ].! ! -!Form class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:53:49'! - small1BitExtent: extentPoint pixelBits: pixelBits - "Answer an instance of me of depth 1 with bitmap initialized from pixelBits. - Requested width can be no more than 32. Result has one 32 bit word per line." - - ^ (self extent: extentPoint depth: 1) - fillSmall1BitWith: pixelBits! ! -!Form class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 11:21:04'! - small1BitExtent: extentPoint pixelBits: pixelBits offset: offsetPoint - "Answer an instance of me of depth 1 with bitmap initialized from pixelBits. - Requested width can be no more than 32. Result has one 32 bit word per line." - - ^ (self extent: extentPoint depth: 1) - offset: offsetPoint; - fillSmall1BitWith: pixelBits! ! -!Form methodsFor: 'fileIn/Out' stamp: 'jmv 11/19/2020 12:34:21' prior: 50521341! - storeOn: aStream base: anInteger - "Store the receiver out as an expression that can be evaluated to recreate a Form with the same contents as the original." - - (depth = 1 and: [ width <= 32 ]) ifTrue: [ - ^self storeSmall1BitOn: aStream ]. - - aStream nextPut: $(. - aStream nextPutAll: self species name. - aStream newLineTab: 1. - aStream nextPutAll: 'extent: '. - self extent printOn: aStream. - aStream newLineTab: 1. - aStream nextPutAll: 'depth: '. - self nativeDepth printOn: aStream. - aStream newLineTab: 1. - aStream nextPutAll: 'fromArray: #('. - self storeBitsOn: aStream base: anInteger. - aStream nextPut: $). - aStream newLineTab: 1. - aStream nextPutAll: 'offset: '. - self offset printOn: aStream. - aStream nextPut: $). -! ! -!CursorWithMask methodsFor: 'mask' stamp: 'jmv 11/19/2020 11:45:59' prior: 16826678 overrides: 50557568! - storeOn: aStream base: anInteger - - aStream nextPut: $(. - super storeOn: aStream base: anInteger. - aStream newLine; nextPutAll: ' setMaskForm: '. - maskForm storeOn: aStream base: anInteger. - aStream nextPut: $)! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4462-OneBPPsmallFormsCreation-JuanVuletich-2020Nov19-13h16m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4460] on 19 November 2020 at 1:23:00 pm'! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:42:18' prior: 50498392! - bottomLeftCursor - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1111111111111100 - 2r1111111111111100 - 2r0000000000000000 - 2r0000000000000000) - offset: `0@-16`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:42:23' prior: 50498401! - bottomRightCursor - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r1111111111111100 - 2r1111111111111100 - 2r0000000000000000 - 2r0000000000000000) - offset: `-16@-16`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:42:28' prior: 50498409! - cornerCursor - "Answer the instance of me that is the shape of the bottom right corner - of a rectangle." - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r1111111111111100 - 2r1111111111111100 - 2r0000000000000000 - 2r0000000000000000) - offset: `-16@-16`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:42:11' prior: 50498420! - crossHairCursor - "Answer the instance of me that is the shape of a cross." - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0000000000000000 - 2r0000000100000000 - 2r0000000100000000 - 2r0000000100000000 - 2r0000000100000000 - 2r0000000100000000 - 2r0000000100000000 - 2r0111111111111100 - 2r0000000100000000 - 2r0000000100000000 - 2r0000000100000000 - 2r0000000100000000 - 2r0000000100000000 - 2r0000000100000000 - 2r0000000000000000 - 2r0000000000000000) - offset: `-7@-7`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:42:48' prior: 50498430! - downCursor - "Answer the instance of me that is the shape of an arrow facing - downward." - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0011000000000000 - 2r0011000000000000 - 2r0011000000000000 - 2r0011000000000000 - 2r0011000000000000 - 2r0011000000000000 - 2r0011000000000000 - 2r1111110000000000 - 2r0111100000000000 - 2r0011000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000) - offset: `0@0`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:43:03' prior: 50498441! - executeCursor - "Answer the instance of me that is the shape of an arrow slanted left - with a star next to it." - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r1000000000100000 - 2r1100000000100000 - 2r1110000001110000 - 2r1111001111111110 - 2r1111100110001100 - 2r1111110010001000 - 2r1111111011111000 - 2r1111000011011000 - 2r1101100110001100 - 2r1001100100000100 - 2r0000110000000000 - 2r0000110000000000 - 2r0000011000000000 - 2r0000011000000000 - 2r0000000000000000 - 2r0000000000000000) - offset: `0@0`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:43:25' prior: 50498473! - markerCursor - "Answer the instance of me that is the shape of a small ball." - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0111000000000000 - 2r1111100000000000 - 2r1111100000000000 - 2r0111000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000) - offset: `0@0`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:43:43' prior: 50498482! - menuCursor - "Answer the instance of me that is the shape of a menu." - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r1111111111100000 - 2r1000000000100000 - 2r1010011000100000 - 2r1000000000100000 - 2r1101001101100000 - 2r1111111111100000 - 2r1000000000100000 - 2r1011001010100000 - 2r1000000000100000 - 2r1010110010100000 - 2r1000000000100000 - 2r1010010100100000 - 2r1000000000100000 - 2r1111111111100000 - 2r0000000000000000 - 2r1111111111100000) - offset: `0@0`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:44:13' prior: 50498492! - moveCursor - "Answer the instance of me that is the shape of a cross inside a square." - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r1111111111111100 - 2r1111111111111100 - 2r1100001100001100 - 2r1100001100001100 - 2r1100001100001100 - 2r1100001100001100 - 2r1111111111111100 - 2r1111111111111100 - 2r1100001100001100 - 2r1100001100001100 - 2r1100001100001100 - 2r1100001100001100 - 2r1111111111111100 - 2r1111111111111100 - 2r0000000000000000 - 2r0000000000000000) - offset: `0@0`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:45:16' prior: 50498503 overrides: 16783533! -new - - ^ self extent: `16 @ 16`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:45:39' prior: 50498510! - normalCursor - "Answer the instance of me that is the shape of an arrow slanted left." - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r1000000000000000 - 2r1100000000000000 - 2r1110000000000000 - 2r1111000000000000 - 2r1111100000000000 - 2r1111110000000000 - 2r1111111000000000 - 2r1111100000000000 - 2r1111100000000000 - 2r1001100000000000 - 2r0000110000000000 - 2r0000110000000000 - 2r0000011000000000 - 2r0000011000000000 - 2r0000001100000000 - 2r0000001100000000) - offset: `0@0`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:38:05' prior: 50498521! - normalCursorWithMask - "Cursor initNormalWithMask. Cursor normal show" - "Next two lines work simply for any cursor..." - " - self initNormal. - NormalCursor _ CursorWithMask derivedFrom: NormalCursor. - " - "But for a good looking cursor, you have to tweak things..." - ^ ((CursorWithMask - small1BitExtent: `16@16` - pixelBits: #( - 2r0000000000000000 - 2r0100000000000000 - 2r0110000000000000 - 2r0111000000000000 - 2r0111100000000000 - 2r0111110000000000 - 2r0111111000000000 - 2r0111111100000000 - 2r0111111110000000 - 2r0111110000000000 - 2r0110110000000000 - 2r0100011000000000 - 2r0000011000000000 - 2r0000001100000000 - 2r0000001100000000 - 2r0000000000000000) - offset: `-1@-1`) - setMaskForm: - (Form - small1BitExtent: `16@16` - pixelBits: #( - 2r1100000000000000 - 2r1110000000000000 - 2r1111000000000000 - 2r1111100000000000 - 2r1111110000000000 - 2r1111111000000000 - 2r1111111100000000 - 2r1111111110000000 - 2r1111111111000000 - 2r1111111111100000 - 2r1111111000000000 - 2r1110111100000000 - 2r1100111100000000 - 2r1000011110000000 - 2r0000011110000000 - 2r0000001110000000) - offset: `0@0`))! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:46:00' prior: 50498548! - originCursor - "Answer the instance of me that is the shape of the top left corner of a rectangle." - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r1111111111111100 - 2r1111111111111100 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r0000000000000000 - 2r0000000000000000) - offset: `0@0`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:46:26' prior: 50498559! - readCursor - "Answer the instance of me that is the shape of eyeglasses." - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0000000000000000 - 2r0000000000000000 - 2r0001000000001000 - 2r0010100000010100 - 2r0100000000100000 - 2r1111101111100000 - 2r1000010000100000 - 2r1000010000100000 - 2r1011010110100000 - 2r0111101111000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000) - offset: `0@0`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:48:25' prior: 50498569! - resizeLeftCursor - ^ (Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0000000000000000 - 2r0000010010000000 - 2r0000010010000000 - 2r0000010010000000 - 2r0001010010100000 - 2r0011010010110000 - 2r0111010010111000 - 2r1111110011111100 - 2r0111010010111000 - 2r0011010010110000 - 2r0001010010100000 - 2r0000010010000000 - 2r0000010010000000 - 2r0000010010000000 - 2r0000000000000000 - 2r0000000000000000) - offset: `-7@-7`) withMask.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:48:48' prior: 50498578! - resizeTopCursor - ^ (Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0000000100000000 - 2r0000001110000000 - 2r0000011111000000 - 2r0000111111100000 - 2r0000000100000000 - 2r0111111111111100 - 2r0000000000000000 - 2r0000000000000000 - 2r0111111111111100 - 2r0000000100000000 - 2r0000111111100000 - 2r0000011111000000 - 2r0000001110000000 - 2r0000000100000000 - 2r0000000000000000 - 2r0000000100000000) - offset: `-7@-7`) withMask.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:49:16' prior: 50498586! - resizeTopLeftCursor - ^ (Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0000000000000000 - 2r0111110000010000 - 2r0111100000100000 - 2r0111000001000100 - 2r0110100010001000 - 2r0100010100010000 - 2r0000001000100000 - 2r0000010001000000 - 2r0000100010000000 - 2r0001000101000100 - 2r0010001000101100 - 2r0000010000011100 - 2r0000100000111100 - 2r0000000001111100 - 2r0000000000000000 - 2r0000000000000000) - offset: `-7@-7`) withMask.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:49:34' prior: 50498595! - resizeTopRightCursor - ^ (Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0000000000000000 - 2r0001000001111100 - 2r0000100000111100 - 2r0100010000011100 - 2r0010001000101100 - 2r0001000101000100 - 2r0000100010000000 - 2r0000010001000000 - 2r0000001000100000 - 2r0100010100010000 - 2r0110100010001000 - 2r0111000001000000 - 2r0111100000100000 - 2r0111110000000000 - 2r0000000000000000 - 2r0000000000000000) - offset: `-7@-7`) withMask.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:49:59' prior: 50498604! - rightArrowCursor - "Answer the instance of me that is the shape of an arrow pointing to the right." - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0000011000000000 - 2r0000011110000000 - 2r0000011111100000 - 2r1111111111111000 - 2r0000011111100000 - 2r0000011110000000 - 2r0000011000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000) - offset: `0@0`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:50:16' prior: 50498614! - squareCursor - "Answer the instance of me that is the shape of a square." - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000001111000000 - 2r0000001111000000 - 2r0000001111000000 - 2r0000001111000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000) - offset: `-8@-8`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:50:33' prior: 50498623! - targetCursor - "Answer the instance of me that is the shape of a gunsight." - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0000011111000000 - 2r0001100100110000 - 2r0010000100001000 - 2r0100000100000100 - 2r0100001110000100 - 2r1000000100000010 - 2r1000100100100010 - 2r1111111011111110 - 2r1000100100100010 - 2r1000000100000010 - 2r0100001110000100 - 2r0100000100000100 - 2r0010000100001000 - 2r0001100100110000 - 2r0000011111000000 - 2r0000000000000000) - offset: `-7@-7`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:50:50' prior: 50498634! - topLeftCursor - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r1111111111111100 - 2r1111111111111100 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r0000000000000000 - 2r0000000000000000) - offset: `0@0`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:51:05' prior: 50498643! - topRightCursor - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r1111111111111100 - 2r1111111111111100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000000000 - 2r0000000000000000) - offset: `-16@0`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:51:20' prior: 50498651! - upCursor - "Answer the instance of me that is the shape of an arrow facing upward." - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0011000000000000 - 2r0111100000000000 - 2r1111110000000000 - 2r0011000000000000 - 2r0011000000000000 - 2r0011000000000000 - 2r0011000000000000 - 2r0011000000000000 - 2r0011000000000000 - 2r0011000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000) - offset: `0@0`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:51:35' prior: 50498661! - waitCursor - "Answer the instance of me that is the shape of an Hourglass (was in the - shape of three small balls)." - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r1111111111111100 - 2r1000000000000100 - 2r0100000000001000 - 2r0010000000010000 - 2r0001110011100000 - 2r0000111111000000 - 2r0000011110000000 - 2r0000011110000000 - 2r0000100101000000 - 2r0001000100100000 - 2r0010000110010000 - 2r0100001111001000 - 2r1000111111110100 - 2r1111111111111100 - 2r0000000000000000 - 2r1111111111111100) - offset: `0@0`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:52:17' prior: 50498673! - webLinkCursor - "Return a cursor that can be used for emphasizing web links" - ^ (CursorWithMask - small1BitExtent: `16@16` - pixelBits: #( - 2r0000110000000000 - 2r0001001000000000 - 2r0001001000000000 - 2r0001001000000000 - 2r0001001000000000 - 2r0001001110110110 - 2r0001001001001001 - 2r0111001001001001 - 2r1001001001001001 - 2r1001001001001001 - 2r1000000000000001 - 2r1000000000000001 - 2r1100000000000011 - 2r0100000000000010 - 2r0110000000000110 - 2r0011111111111100) - offset: `-5@0`) - setMaskForm: (Form - small1BitExtent: `16@16` - pixelBits: #( - 2r0000110000000000 - 2r0001111000000000 - 2r0001111000000000 - 2r0001111000000000 - 2r0001111000000000 - 2r0001111110110110 - 2r0001111111111111 - 2r0111111111111111 - 2r1111111111111111 - 2r1111111111111111 - 2r1111111111111111 - 2r1111111111111111 - 2r1111111111111111 - 2r0111111111111110 - 2r0111111111111110 - 2r0011111111111100) - offset: `0@0`)! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:52:33' prior: 50498691! - writeCursor - "Answer the instance of me that is the shape of a pen writing." - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0000000000011000 - 2r0000000000111100 - 2r0000000001001000 - 2r0000000010010000 - 2r0000000100100000 - 2r0000001001000100 - 2r0000010010000100 - 2r0000100100001100 - 2r0001001000010000 - 2r0010010000010000 - 2r0111100000001000 - 2r0101000011111000 - 2r1110000110000000 - 2r0111111100000000 - 2r0000000000000000 - 2r0000000000000000) - offset: `0@0`! ! -!MenuItemMorph class methodsFor: 'cached state access' stamp: 'jmv 11/19/2020 12:54:04' prior: 50385315! - subMenuMarker - - | f | - SubMenuMarker ifNotNil: [ ^SubMenuMarker ]. - f _ Form - small1BitExtent: `5@9` - pixelBits: #( - 2r10000 - 2r11000 - 2r11100 - 2r11110 - 2r11111 - 2r11110 - 2r11100 - 2r11000 - 2r10000). - SubMenuMarker _ ColorForm mappingWhiteToTransparentFrom: f. - ^SubMenuMarker! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4463-CursorAndSmallFormsCreation-JuanVuletich-2020Nov19-13h17m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4463] on 19 November 2020 at 1:56:46 pm'! -!Form methodsFor: 'private' stamp: 'jmv 11/19/2020 13:55:50' prior: 16848775! - initFromArray: array - "Fill the bitmap from array. If the array is shorter, - then cycle around in its contents until the bitmap is filled." - | ax aSize | - ax _ 0. - aSize _ array size. - 1 to: bits size do: [ :index | - (ax _ ax + 1) > aSize ifTrue: [ax _ 1]. - bits at: index put: (array at: ax)]! ! -!Form class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:57:50' prior: 16848949! - extent: extentPoint depth: bitsPerPixel fromArray: anArray offset: offsetPoint - "Answer an instance of me with a pixmap of the given depth initialized from anArray." - "See Form >> storeOn:base:" - - ^ (self extent: extentPoint depth: bitsPerPixel) - offset: offsetPoint; - initFromArray: anArray -! ! - -Cursor class removeSelector: #extent:fromArray:offset:! - -!methodRemoval: Cursor class #extent:fromArray:offset: stamp: 'Install-4464-FormCreationCleanup-JuanVuletich-2020Nov19-13h37m-jmv.001.cs.st 12/30/2020 14:47:34'! -extent: extentPoint fromArray: anArray offset: offsetPoint - "Answer a new instance of me with width and height specified by - extentPoint, offset by offsetPoint, and bits from anArray. - NOTE: This has been kluged to take an array of 16-bit constants, - and shift them over so they are left-justified in a 32-bit bitmap" - - extentPoint = (`16 @ 16`) - ifTrue: - [^ super - extent: extentPoint - fromArray: (anArray collect: [:bits | bits bitShift: 16]) - offset: offsetPoint] - ifFalse: [self error: 'cursors must be 16@16']! - -Form class removeSelector: #extent:fromArray:offset:! - -!methodRemoval: Form class #extent:fromArray:offset: stamp: 'Install-4464-FormCreationCleanup-JuanVuletich-2020Nov19-13h37m-jmv.001.cs.st 12/30/2020 14:47:34'! -extent: extentPoint fromArray: anArray offset: offsetPoint - "Answer an instance of me of depth 1 with bitmap initialized from anArray." - - ^ (self extent: extentPoint depth: 1) - offset: offsetPoint; - initFromArray: anArray -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4464-FormCreationCleanup-JuanVuletich-2020Nov19-13h37m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4464] on 19 November 2020 at 4:53:48 pm'! -!HaloMorph methodsFor: 'handles' stamp: 'jmv 11/19/2020 16:39:17'! - addResizeHandle: haloSpec - - (self addHandle: haloSpec) - mouseDownSelector: #startResize:with:; - mouseMoveSelector: #doResize:with:! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/19/2020 16:44:22'! - doResize: evt with: resizeHandle - "Called while the mouse is down in the grow handle" - - | newExtent | -self revisar. - self flag: #jmvVer2. - evt hand obtainHalo: self. -"Como podria andar el resize de un morph embebido en otro? andara ahora?" -newExtent _ evt eventPosition - positionOffset - target morphPositionInWorld. - evt shiftPressed ifTrue: [newExtent _ (newExtent x max: newExtent y) asPoint]. - (newExtent x = 0 or: [newExtent y = 0]) ifTrue: [^ self]. - target morphExtentInWorld: newExtent. - resizeHandle morphPositionInWorld: evt eventPosition - (resizeHandle morphExtent // 2)! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/19/2020 16:47:00'! - startResize: evt with: resizeHandle - "Initialize resizing of my target." - - | botRt | - evt hand obtainHalo: self. "Make sure the event's hand correlates with the receiver" - self removeAllHandlesBut: resizeHandle. "remove all other handles" - botRt _ target morphPositionInWorld + target morphExtentInWorld. - positionOffset _ (self world viewBox containsPoint: botRt) - ifTrue: [evt eventPosition - botRt] - ifFalse: [`0@0`]! ! -!HaloMorph class methodsFor: 'accessing - icons' stamp: 'jmv 11/19/2020 16:40:22'! - haloResizeIcon - - ^ self icons - at: #haloResizeIcon - ifAbsentPut: [ Theme current haloResizeIcon ]! ! -!Theme methodsFor: 'icons' stamp: 'jmv 11/19/2020 16:49:17'! - haloResizeIcon - - ^ Form - small1BitExtent: 16@16 - pixelBits: #( - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000111111010000 - 2r0000100001010000 - 2r0000100001010000 - 2r0000100001010000 - 2r0000100001010000 - 2r0000111111010000 - 2r0000000000010000 - 2r0000111111110000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000) - offset: 0@0! ! -!Preferences class methodsFor: 'halos' stamp: 'jmv 11/19/2020 16:40:31' prior: 50536886! - iconicHaloSpecifications - "Answer an array that characterizes the locations, colors, icons, and selectors of the halo handles that may be used in the iconic halo scheme" - - " - Preferences resetHaloSpecifications - " - -^ #( - "selector horiz vert color info icon key balloon help - --------- ------ ----------- -------------------------- -------------------------- ---------------" - (addCollapseHandle: left topCenter (tan) haloCollapseIcon 'Collapse') - (addDebugHandle: right topCenter (orange) haloDebugIcon 'Debug') - (addDismissHandle: left top (red) haloDismissIcon 'Remove') - (addRotateHandle: left bottom (blue) haloRotateIcon 'Rotate') - (addMenuHandle: leftCenter top (blue lighter) haloMenuIcon 'Menu') - (addGrabHandle: center top (black) haloGrabIcon 'Pick up') - (addDragHandle: rightCenter top (brown) haloDragIcon 'Move') - (addDupHandle: right top (green) haloDuplicateIcon 'Duplicate') - (addHelpHandle: center bottom (lightBlue) haloHelpIcon 'Help') - (addResizeHandle: right bottom (yellow) haloResizeIcon 'Change size') - (addFontSizeHandle: leftCenter bottom (lightGreen) haloFontSizeIcon 'Change font') - (addFontEmphHandle: rightCenter bottom (lightBrown darker) haloFontEmphasisIcon 'Emphasis & alignment') - "FIXME - Currently non-functional... - (addRecolorHandle: right bottomCenter (magenta darker) haloColorIcon 'Change color') - " -)! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 11/19/2020 16:39:54' prior: 50537020! - wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph - "Answer whether the receiver would like to offer the halo handle with the given selector (e.g. #addCollapseHandle:)" - - (#(addRecolorHandle:) statePointsTo: aSelector) - ifTrue: ["FIXME - hack to disable for non-functional halo items" - ^ false]. - - Preferences selectiveHalos ifFalse: [ - ^true ]. - - (#(#addDismissHandle: ) includes: aSelector) - ifTrue: [ ^ self resistsRemoval not ]. - (#(#addDragHandle: ) includes: aSelector) - ifTrue: [ ^ self okayToBrownDragEasily ]. - (#(#addResizeHandle: ) includes: aSelector) - ifTrue: [ ^ self okayToResizeEasily ]. - (#(#addRotateHandle: ) includes: aSelector) - ifTrue: [ ^ self okayToRotateEasily ]. - (#(#addRecolorHandle: ) includes: aSelector) - ifTrue: [ ^ self wantsRecolorHandle ]. - ^ true! ! - -Theme removeSelector: #haloScaleIcon! - -!methodRemoval: Theme #haloScaleIcon stamp: 'Install-4465-ResizeNotGrowOrScale-JuanVuletich-2020Nov19-16h38m-jmv.001.cs.st 12/30/2020 14:47:34'! -haloScaleIcon - - ^ self fetch: #( '16x16' 'smalltalk' 'halo-scale' ) -! - -HaloMorph class removeSelector: #haloScaleIcon! - -!methodRemoval: HaloMorph class #haloScaleIcon stamp: 'Install-4465-ResizeNotGrowOrScale-JuanVuletich-2020Nov19-16h38m-jmv.001.cs.st 12/30/2020 14:47:34'! -haloScaleIcon - - ^ self icons - at: #haloScaleIcon - ifAbsentPut: [ Theme current haloScaleIcon ]! - -HaloMorph removeSelector: #doGrow:with:! - -!methodRemoval: HaloMorph #doGrow:with: stamp: 'Install-4465-ResizeNotGrowOrScale-JuanVuletich-2020Nov19-16h38m-jmv.001.cs.st 12/30/2020 14:47:34'! -doGrow: evt with: growHandle - "Called while the mouse is down in the grow handle" - - | newExtent | -self revisar. - self flag: #jmvVer2. - evt hand obtainHalo: self. -"Como podria andar el grow de un morph embebido en otro? andara ahora?" -newExtent _ evt eventPosition - positionOffset - target morphPositionInWorld. - evt shiftPressed ifTrue: [newExtent _ (newExtent x max: newExtent y) asPoint]. - (newExtent x = 0 or: [newExtent y = 0]) ifTrue: [^ self]. - target morphExtentInWorld: newExtent. - growHandle morphPositionInWorld: evt eventPosition - (growHandle morphExtent // 2)! - -HaloMorph removeSelector: #addGrowHandle:! - -!methodRemoval: HaloMorph #addGrowHandle: stamp: 'Install-4465-ResizeNotGrowOrScale-JuanVuletich-2020Nov19-16h38m-jmv.001.cs.st 12/30/2020 14:47:34'! -addGrowHandle: haloSpec - - (self addHandle: haloSpec) - mouseDownSelector: #startGrow:with:; - mouseMoveSelector: #doGrow:with:! - -HaloMorph removeSelector: #startGrow:with:! - -!methodRemoval: HaloMorph #startGrow:with: stamp: 'Install-4465-ResizeNotGrowOrScale-JuanVuletich-2020Nov19-16h38m-jmv.001.cs.st 12/30/2020 14:47:34'! -startGrow: evt with: growHandle - "Initialize resizing of my target. Launch a command representing it, to support Undo" - - | botRt | - evt hand obtainHalo: self. "Make sure the event's hand correlates with the receiver" - self removeAllHandlesBut: growHandle. "remove all other handles" - botRt _ target morphPositionInWorld + target morphExtentInWorld. - positionOffset _ (self world viewBox containsPoint: botRt) - ifTrue: [evt eventPosition - botRt] - ifFalse: [`0@0`]! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - -Preferences resetHaloSpecifications! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4465-ResizeNotGrowOrScale-JuanVuletich-2020Nov19-16h38m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4464] on 19 November 2020 at 4:57:02 pm'! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/18/2020 16:41:51' prior: 50545118! - doRot: evt with: rotHandle - "Update the rotation of my target if it is rotatable." - - | radians | - evt hand obtainHalo: self. - radians _ (evt eventPosition - target referencePosition) theta. - radians _ radians - angleOffset theta. - "degrees _ degrees detentBy: 10.0 atMultiplesOf: 90.0 snap: false." - radians = 0.0 - ifTrue: [rotHandle color: `Color lightBlue`] - ifFalse: [rotHandle color: `Color blue`]. - rotHandle submorphsDo: - [:m | m color: rotHandle color makeForegroundColor]. - self removeAllHandlesBut: rotHandle. - target rotation: radians. - rotHandle morphPositionInWorld: evt eventPosition - (rotHandle morphExtent // 2)! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/18/2020 16:45:01' prior: 50554644! - startRot: evt with: rotHandle - "Initialize rotation of my target if it is rotatable." - - evt hand obtainHalo: self. "Make sure the event's hand correlates with the receiver" - growingOrRotating _ true. - - self removeAllHandlesBut: rotHandle. "remove all other handles" - angleOffset _ evt eventPosition - target referencePosition. - angleOffset _ Point - r: angleOffset r - degrees: angleOffset degrees - target rotationDegrees.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4466-RotationHandleCleanup-JuanVuletich-2020Nov19-16h53m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4466] on 19 November 2020 at 5:26:30 pm'! -!AffineTransformation methodsFor: 'modifying' stamp: 'jmv 11/18/2020 16:51:10'! - withScale: scale - "Set scaling according to parameters. - Answer the modified object. In this implementation this requires the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself, - as if the receiver is already an AffineTransformation." - - self scaledBy: scale / self scale! ! -!MorphicTranslation methodsFor: 'modifying' stamp: 'jmv 11/18/2020 17:00:28'! - withScale: scale - "Set scaling according to parameters. - Answer the modified object. In this implementation this requires the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself, - as if the receiver is already an AffineTransformation." - - ^self scaledBy: scale! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 11/18/2020 16:54:07'! - scale: scale - "Change the scale of this morph. Arguments are an angle and a scale." - location _ location withScale: scale. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!HaloMorph methodsFor: 'handles' stamp: 'jmv 11/19/2020 17:06:08'! - addScaleHandle: haloSpec - - (self addHandle: haloSpec) - mouseDownSelector: #startScale:with:; - mouseMoveSelector: #doScale:with:! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/19/2020 17:10:02'! - doScale: evt with: scaleHandle - "Update the scale of my target if it is scalable." - - | scale | - evt hand obtainHalo: self. - scale _ (evt eventPosition - target referencePosition) rho * scaleOffset. - scale = 1.0 - ifTrue: [scaleHandle color: `Color lightBlue`] - ifFalse: [scaleHandle color: `Color blue`]. - scaleHandle submorphsDo: - [:m | m color: scaleHandle color makeForegroundColor]. - self removeAllHandlesBut: scaleHandle. - target scale: scale. - scaleHandle morphPositionInWorld: evt eventPosition - (scaleHandle morphExtent // 2)! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/19/2020 17:10:27'! - startScale: evt with: scaleHandle - "Initialize scale of my target if it is scalable." - - evt hand obtainHalo: self. "Make sure the event's hand correlates with the receiver" - growingOrRotating _ true. - - self removeAllHandlesBut: scaleHandle. "remove all other handles" - scaleOffset _ target scale / (evt eventPosition - target referencePosition) rho. - -! ! -!HaloMorph class methodsFor: 'accessing - icons' stamp: 'jmv 11/19/2020 17:10:59'! - haloScaleIcon - - ^ self icons - at: #haloScaleIcon - ifAbsentPut: [ Theme current haloScaleIcon ]! ! -!Theme methodsFor: 'icons' stamp: 'jmv 11/19/2020 17:21:02'! - haloScaleIcon - - ^ Form - small1BitExtent: 16@16 - pixelBits: #( - 2r0000000000000000 - 2r0000000000000000 - 2r0000111110000000 - 2r0001000001000000 - 2r0010001000100000 - 2r0010001000100000 - 2r0010111110100000 - 2r0010001000100000 - 2r0010001000100000 - 2r0001000001100000 - 2r0000111110010000 - 2r0000000000001000 - 2r0000000000000100 - 2r0000000000000010 - 2r0000000000000000 - 2r0000000000000000) - offset: 0@0! ! -!Preferences class methodsFor: 'halos' stamp: 'jmv 11/19/2020 17:13:26' prior: 50558288! - iconicHaloSpecifications - "Answer an array that characterizes the locations, colors, icons, and selectors of the halo handles that may be used in the iconic halo scheme" - - " - Preferences resetHaloSpecifications - " - -^ #( - "selector horiz vert color info icon key balloon help - --------- ------ ----------- -------------------------- -------------------------- ---------------" - (addCollapseHandle: left topCenter (tan) haloCollapseIcon 'Collapse') - (addDebugHandle: right topCenter (orange) haloDebugIcon 'Debug') - (addDismissHandle: left top (red) haloDismissIcon 'Remove') - (addRotateHandle: left bottom (blue) haloRotateIcon 'Rotate') - (addMenuHandle: leftCenter top (blue lighter) haloMenuIcon 'Menu') - (addGrabHandle: center top (black) haloGrabIcon 'Pick up') - (addDragHandle: rightCenter top (brown) haloDragIcon 'Move') - (addDupHandle: right top (green) haloDuplicateIcon 'Duplicate') - (addHelpHandle: center bottom (lightBlue) haloHelpIcon 'Help') - (addResizeHandle: right bottom (yellow) haloResizeIcon 'Change size') - (addScaleHandle: right center (blue) haloScaleIcon 'Change scale') - (addFontSizeHandle: leftCenter bottom (lightGreen) haloFontSizeIcon 'Change font') - (addFontEmphHandle: rightCenter bottom (lightBrown darker) haloFontEmphasisIcon 'Emphasis & alignment') - "FIXME - Currently non-functional... - (addRecolorHandle: right bottomCenter (magenta darker) haloColorIcon 'Change color') - " -)! ! -!AffineTransformation methodsFor: 'modifying' stamp: 'jmv 11/18/2020 16:47:32' prior: 16778647! - scaledBy: aPointOrNumber - "Multiply by a scale. - Argument can be a point, applying different scaling in x and in y directions. - Keep the transformed position of 0@0, i.e. don't change offset. - - Answer the modified object. In this implementation is self, but some classes of transformations, - more restricted ones (like MorphicTranslation) could require the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself." - - | pt sx sy | - pt _ aPointOrNumber asPoint. - sx _ pt x. - sy _ pt y. - self a11: self a11 * sx. - self a12: self a12 * sx. - self a21: self a21 * sy. - self a22: self a22 * sy. - ^ self! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - -Preferences resetHaloSpecifications! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4467-ScaleHandle-JuanVuletich-2020Nov19-17h19m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4466] on 19 November 2020 at 5:27:20 pm'! - -KernelMorph subclass: #HaloMorph - instanceVariableNames: 'target positionOffset angleOffset growingOrRotating haloBox scaleOffset ' - classVariableNames: 'Icons ' - poolDictionaries: '' - category: 'Morphic-Halos'! - -!classDefinition: #HaloMorph category: #'Morphic-Halos' stamp: 'Install-4468-HaloMorph-cleanup-JuanVuletich-2020Nov19-17h26m-jmv.001.cs.st 12/30/2020 14:47:34'! -KernelMorph subclass: #HaloMorph - instanceVariableNames: 'target positionOffset angleOffset growingOrRotating haloBox scaleOffset' - classVariableNames: 'Icons' - poolDictionaries: '' - category: 'Morphic-Halos'! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/19/2020 17:26:35' prior: 50544321! - addHandles - - self removeAllMorphs. "remove old handles, if any" - target displayBoundsForHalo ifNotNil: [ :r | - self morphBounds: r. "update my size" - haloBox _ self basicBox. - target addHandlesTo: self box: haloBox. - self addNameString: (target printStringLimitedTo: 40). - self redrawNeeded ].! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/19/2020 17:26:45' prior: 50558484! - startRot: evt with: rotHandle - "Initialize rotation of my target if it is rotatable." - - evt hand obtainHalo: self. "Make sure the event's hand correlates with the receiver" - - self removeAllHandlesBut: rotHandle. "remove all other handles" - angleOffset _ evt eventPosition - target referencePosition. - angleOffset _ Point - r: angleOffset r - degrees: angleOffset degrees - target rotationDegrees.! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/19/2020 17:26:50' prior: 50558572! - startScale: evt with: scaleHandle - "Initialize scale of my target if it is scalable." - - evt hand obtainHalo: self. "Make sure the event's hand correlates with the receiver" - - self removeAllHandlesBut: scaleHandle. "remove all other handles" - scaleOffset _ target scale / (evt eventPosition - target referencePosition) rho. - -! ! - -HaloMorph removeSelector: #initialize! - -!methodRemoval: HaloMorph #initialize stamp: 'Install-4468-HaloMorph-cleanup-JuanVuletich-2020Nov19-17h26m-jmv.001.cs.st 12/30/2020 14:47:34'! -initialize - "initialize the state of the receiver" - super initialize. - "" - growingOrRotating _ false! - -KernelMorph subclass: #HaloMorph - instanceVariableNames: 'target positionOffset angleOffset scaleOffset haloBox' - classVariableNames: 'Icons' - poolDictionaries: '' - category: 'Morphic-Halos'! - -!classDefinition: #HaloMorph category: #'Morphic-Halos' stamp: 'Install-4468-HaloMorph-cleanup-JuanVuletich-2020Nov19-17h26m-jmv.001.cs.st 12/30/2020 14:47:35'! -KernelMorph subclass: #HaloMorph - instanceVariableNames: 'target positionOffset angleOffset scaleOffset haloBox' - classVariableNames: 'Icons' - poolDictionaries: '' - category: 'Morphic-Halos'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4468-HaloMorph-cleanup-JuanVuletich-2020Nov19-17h26m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4468] on 20 November 2020 at 10:22:22 am'! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 11/20/2020 09:53:28'! - hasOwnLocation - ^false! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 11/20/2020 09:54:41'! - hasVariableExtent - ^false! ! -!MovableMorph methodsFor: 'geometry testing' stamp: 'jmv 11/20/2020 09:53:46' overrides: 50558803! -hasOwnLocation - ^true! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 11/20/2020 10:20:34' overrides: 50554240! - referencePosition - "Return the current reference position of the receiver" - "a rather ugly way to say #center . At least, we avoid false polymorphism" - "remove some day" - self flag: #jmvVer2. - ^self morphExtentInWorld // 2 + self morphPositionInWorld! ! -!WidgetMorph methodsFor: 'geometry testing' stamp: 'jmv 11/20/2020 09:54:52' overrides: 50558807! -hasVariableExtent - ^true! ! -!Preferences class methodsFor: 'halos' stamp: 'jmv 11/20/2020 10:02:58' prior: 50558609! - iconicHaloSpecifications - "Answer an array that characterizes the locations, colors, icons, and selectors of the halo handles that may be used in the iconic halo scheme" - - " - Preferences resetHaloSpecifications - " - -^ #( - "selector horiz vert color info icon key balloon help - --------- ------ ----------- -------------------------- -------------------------- ---------------" - (addCollapseHandle: left topCenter (tan) haloCollapseIcon 'Collapse') - (addDebugHandle: right topCenter (orange) haloDebugIcon 'Debug') - (addDismissHandle: left top (red) haloDismissIcon 'Remove') - (addRotateHandle: left bottom (blue) haloRotateIcon 'Rotate') - (addMenuHandle: leftCenter top (blue lighter) haloMenuIcon 'Menu') - (addGrabHandle: center top (black) haloGrabIcon 'Pick up') - (addDragHandle: rightCenter top (brown) haloDragIcon 'Move') - (addDupHandle: right top (green) haloDuplicateIcon 'Duplicate') - (addHelpHandle: center bottom (lightBlue) haloHelpIcon 'Help') - (addResizeHandle: right bottom (yellow) haloResizeIcon 'Change size') - (addScaleHandle: right bottom (blue) haloScaleIcon 'Change scale') - (addFontSizeHandle: leftCenter bottom (lightGreen) haloFontSizeIcon 'Change font') - (addFontEmphHandle: rightCenter bottom (lightBrown darker) haloFontEmphasisIcon 'Emphasis & alignment') - "FIXME - Currently non-functional... - (addRecolorHandle: right bottomCenter (magenta darker) haloColorIcon 'Change color') - " -)! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 11/20/2020 09:57:32' prior: 50384199! - morphExtent - "In our own coordinates!!" -"Quizas eventualmente borrar este tambien? (no se usa mucho...)" - self flag: #jmvVer2. - ^`150 @ 140`! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 11/20/2020 10:20:45' prior: 50554240 overrides: 50554547! - referencePosition - "Return the current reference position of the receiver" - "a rather ugly way to say #center . At least, we avoid false polymorphism" - "remove some day" - self flag: #jmvVer2. - ^self morphPositionInWorld! ! -!HaloMorph methodsFor: 'handles' stamp: 'jmv 11/20/2020 09:56:12' prior: 50558221! - addResizeHandle: haloSpec - - target hasVariableExtent ifTrue: [ - (self addHandle: haloSpec) - mouseDownSelector: #startResize:with:; - mouseMoveSelector: #doResize:with: ]! ! -!HaloMorph methodsFor: 'handles' stamp: 'jmv 11/20/2020 10:02:21' prior: 16850820! - addRotateHandle: haloSpec - -target hasVariableExtent ifFalse: [ - target hasOwnLocation ifTrue: [ - (self addHandle: haloSpec) - mouseDownSelector: #startRot:with:; - mouseMoveSelector: #doRot:with: ] -]! ! -!HaloMorph methodsFor: 'handles' stamp: 'jmv 11/20/2020 10:02:32' prior: 50558546! - addScaleHandle: haloSpec - -target hasVariableExtent ifFalse: [ - target hasOwnLocation ifTrue: [ - (self addHandle: haloSpec) - mouseDownSelector: #startScale:with:; - mouseMoveSelector: #doScale:with: ] -]! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/19/2020 17:10:02' prior: 50558553! - doScale: evt with: scaleHandle - "Update the scale of my target if it is scalable." - - | scale | - evt hand obtainHalo: self. - scale _ (evt eventPosition - target referencePosition) rho * scaleOffset. - scale = 1.0 - ifTrue: [scaleHandle color: `Color lightBlue`] - ifFalse: [scaleHandle color: `Color blue`]. - scaleHandle submorphsDo: - [:m | m color: scaleHandle color makeForegroundColor]. - self removeAllHandlesBut: scaleHandle. - target scale: scale. - scaleHandle morphPositionInWorld: evt eventPosition - (scaleHandle morphExtent // 2)! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/20/2020 10:12:35' prior: 50558740! - startRot: evt with: rotHandle - "Initialize rotation of my target if it is rotatable." - - evt hand obtainHalo: self. "Make sure the event's hand correlates with the receiver" - - self removeAllHandlesBut: rotHandle. "remove all other handles" - angleOffset _ evt eventPosition - target referencePosition. - angleOffset _ Point - r: 1.0 - degrees: angleOffset degrees - target rotationDegrees.! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/20/2020 10:09:48' prior: 50558756! - startScale: evt with: scaleHandle - "Initialize scale of my target if it is scalable." - - evt hand obtainHalo: self. "Make sure the event's hand correlates with the receiver" - - self removeAllHandlesBut: scaleHandle. "remove all other handles" - scaleOffset _ target scale / (evt eventPosition - target referencePosition) rho.! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Preferences resetHaloSpecifications! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4469-HaloMorphScaleAndRotateNotForWidgets-JuanVuletich-2020Nov20-09h51m-jmv.003.cs.st----! - -'From Cuis 5.0 [latest update: #4469] on 20 November 2020 at 10:50:38 am'! -!MouseClickState class methodsFor: 'cached state access' stamp: 'jmv 11/20/2020 10:49:00' prior: 16879030! - doubleClickTimeout - DoubleClickTimeout ifNil: [ - DoubleClickTimeout _ 500 ]. - ^DoubleClickTimeout! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -MouseClickState releaseClassCachedState! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4470-LargerDoubleClickTimeout-JuanVuletich-2020Nov20-10h48m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4469] on 20 November 2020 at 10:58:54 am'! -!Debugger methodsFor: 'class list' stamp: 'jmv 11/20/2020 10:56:52' prior: 16830015 overrides: 16812883! - selectedClass - "Answer the class in which the currently selected context's method was found." - - ^self selectedContext ifNotNil: [ :ctx | - (#(doesNotUnderstand: halt halt:) statePointsTo: ctx selector) - ifTrue: [ctx receiver class] - ifFalse: [ctx methodClass ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4471-haltOrDNUselectedClassIsReceivers-JuanVuletich-2020Nov20-10h50m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4471] on 20 November 2020 at 3:35:54 pm'! -!Object methodsFor: 'object serialization' stamp: 'jmv 11/20/2020 15:34:27'! - releaseCachedState - "Some subclasses might"! ! -!PluggableTextModel methodsFor: 'misc' stamp: 'jmv 11/20/2020 15:26:17' overrides: 50559046! - releaseCachedState - textProvider releaseCachedState! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4472-TextMorph-duplication-fix-JuanVuletich-2020Nov20-15h35m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4472] on 20 November 2020 at 3:47:57 pm'! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/20/2020 15:47:38' prior: 16850985! - doDup: evt with: dupHandle - "Ask hand to duplicate my target." - - | hand positionInHandCoordinates | - hand _ evt hand. - positionInHandCoordinates _ target morphPositionInWorld - hand morphPositionInWorld. - "Duplicate has no meaningful position, as it is not in the world. Grab position from original!!" - target _ target duplicateMorph: evt. - self addNameString: (target printStringLimitedTo: 40). - hand - obtainHalo: self; - grabMorph: target delta: positionInHandCoordinates! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4473-MorphDuplicationPositionFix-JuanVuletich-2020Nov20-15h47m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4473] on 20 November 2020 at 3:43:54 pm'! -!InnerTextMorph methodsFor: 'copying' stamp: 'jmv 11/20/2020 14:59:51' overrides: 16876458! - okayToDuplicate - "Answered false by morphs that can't simply be duplicated" - - ^ false! ! -!Morph methodsFor: 'copying' stamp: 'jmv 11/20/2020 14:59:43' prior: 16876458! - okayToDuplicate - "Answered false by morphs that can't simply be duplicated" - - ^ true! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/20/2020 15:42:13' prior: 50559063! - doDup: evt with: dupHandle - "Ask hand to duplicate my target." - - | hand positionInHandCoordinates | - target okayToDuplicate ifFalse: [^ self]. - hand _ evt hand. - positionInHandCoordinates _ target morphPositionInWorld - hand morphPositionInWorld. - "Duplicate has no meaningful position, as it is not in the world. Grab position from original!!" - target _ target duplicateMorph: evt. - self addNameString: (target printStringLimitedTo: 40). - hand - obtainHalo: self; - grabMorph: target delta: positionInHandCoordinates! ! - -HaloMorph removeSelector: #maybeDoDup:with:! - -!methodRemoval: HaloMorph #maybeDoDup:with: stamp: 'Install-4474-ForbidInnerTextMorphDuplication-JuanVuletich-2020Nov20-15h38m-jmv.001.cs.st 12/30/2020 14:47:35'! -maybeDoDup: evt with: dupHandle - evt hand obtainHalo: self. - ^ target okayToDuplicate ifTrue: - [self doDup: evt with: dupHandle]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4474-ForbidInnerTextMorphDuplication-JuanVuletich-2020Nov20-15h38m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4438] on 5 November 2020 at 12:32:31 pm'! -!Browser methodsFor: 'system category functions' stamp: 'KLG 11/5/2020 12:23:10'! - newSystemCategoryNameInitialAnswer - "Make a suggestion for a new sytems category. - - Can be redefined in subclasses to provide something meore meaningfull." - - ^ 'Category-Name'. -! ! -!SinglePackageBrowser methodsFor: 'system category functions' stamp: 'KLG 11/5/2020 12:28:53' overrides: 50559139! - newSystemCategoryNameInitialAnswer - "Make a suggestion for a new sytems category. - - Provide something more usefull, e.g. the package name or a sensible derivate of it." - - | packageName | - ^ self systemCategoryList includes: (packageName _ package packageName) :: - ifTrue: [ packageName, ' - Sub-Category-Name' ] - ifFalse: [ packageName ] -! ! -!Browser methodsFor: 'system category functions' stamp: 'KLG 11/5/2020 12:23:23' prior: 50514064! - newSystemCategoryNameIfNone: aNoneBlock - - | newName | - - newName _ self - request: 'New category name?' - initialAnswer: self newSystemCategoryNameInitialAnswer. - - ^newName isEmpty - ifTrue: aNoneBlock - ifFalse: [newName asSymbol].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4475-InitialSystemCategoryAnswer-GeraldKlix-2020Oct31-20h05m-KLG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4475] on 24 November 2020 at 12:18:10 pm'! - -KernelMorph subclass: #HaloMorph - instanceVariableNames: 'target positionOffset angleOffset scaleOffset haloBox haloDelta ' - classVariableNames: 'Icons ' - poolDictionaries: '' - category: 'Morphic-Halos'! - -!classDefinition: #HaloMorph category: #'Morphic-Halos' stamp: 'Install-4476-HaloFixes-JuanVuletich-2020Nov24-12h11m-jmv.001.cs.st 12/30/2020 14:47:35'! -KernelMorph subclass: #HaloMorph - instanceVariableNames: 'target positionOffset angleOffset scaleOffset haloBox haloDelta' - classVariableNames: 'Icons' - poolDictionaries: '' - category: 'Morphic-Halos'! -!Morph methodsFor: 'geometry' stamp: 'jmv 11/24/2020 11:40:08'! - rotation - ^0! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 11/24/2020 11:39:08'! - rotationDegrees: degrees - "Change the rotation of this morph. Argument is an angle to be taken as the new rotation." - - self rotation: degrees degreesToRadians! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 11/24/2020 11:41:25' overrides: 50559198! - rotation - ^location radians! ! -!Number methodsFor: 'truncation and round off' stamp: 'di 2/19/98 21:58' prior: 16880499! - detentBy: detent atMultiplesOf: grid snap: snap - "Map all values that are within detent/2 of any multiple of grid to that multiple. Otherwise, if snap is true, return self, meaning that the values in the dead zone will never be returned. If snap is false, then expand the range between dead zones so that it covers the range between multiples of the grid, and scale the value by that factor." - | r1 r2 | - r1 _ self roundTo: grid. "Nearest multiple of grid" - (self - r1) abs <= detent ifTrue: [^ r1]. "Snap to that multiple..." - snap ifTrue: [^ self]. "...or return self" - - r2 _ self < r1 "Nearest end of dead zone" - ifTrue: [r1 - (detent asFloat/2)] - ifFalse: [r1 + (detent asFloat/2)]. - "Scale values between dead zones to fill range between multiples" - ^ r1 + ((self - r2) * grid asFloat / (grid - detent)) -" - (170 to: 190 by: 2) collect: [:a | a detentBy: 10 atMultiplesOf: 90 snap: true] (170 to: 190 by: 2) collect: [:a | a detentBy: 10 atMultiplesOf: 90 snap: false] - (3.9 to: 4.1 by: 0.02) collect: [:a | a detentBy: 0.1 atMultiplesOf: 1.0 snap: true] (-3.9 to: -4.1 by: -0.02) collect: [:a | a detentBy: 0.1 atMultiplesOf: 1.0 snap: false] -"! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 11/24/2020 10:33:48' prior: 50554547! - referencePosition - "Return the current reference position of the receiver" - "a rather ugly way to say #center . At least, we avoid false polymorphism" - "remove some day" - - self displayBounds ifNotNil: [ :r | r center ]. - ^0@0! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 11/24/2020 11:40:19' prior: 16876483! - rotationDegrees - - self rotation radiansToDegrees! ! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'jmv 11/24/2020 12:17:21' prior: 50535353! - removeAllMorphs - | oldMorphs | - submorphs isEmpty ifTrue: [ ^self ]. - submorphs do: [ :m | - m invalidateBounds. - m privateOwner: nil ]. - oldMorphs _ submorphs. - submorphs _ #(). - oldMorphs do: [ :m | - self removedMorph: m ]. - self someSubmorphPositionOrExtentChanged. -! ! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'jmv 11/24/2020 11:31:31' prior: 50539700! - removeMorph: aMorph - "Remove the given morph from my submorphs" - - aMorph owner == self ifFalse: [^self]. - aMorph invalidateBounds. - self privateRemove: aMorph. - aMorph privateOwner: nil. - self removedMorph: aMorph. - self someSubmorphPositionOrExtentChanged. -! ! -!Morph methodsFor: 'updating' stamp: 'jmv 11/24/2020 12:16:24' prior: 50557048! - invalidateBounds - "Report that the area occupied by this morph and submorphs should be redrawn, - but most likely we are not going to be redrawn on it, or maybe we'll not be fully visible. See senders." - - self displayFullBounds ifNotNil: [ :r | self invalidateDisplayRect: r for: nil ]. -! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 11/24/2020 10:33:58' prior: 50558895 overrides: 50559252! - referencePosition - "Return the current reference position of the receiver" - "a rather ugly way to say #center . At least, we avoid false polymorphism" - "remove some day" - self flag: #jmvVer2. - self displayBounds ifNotNil: [ :r | r center ]. - ^self morphPositionInWorld! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 11/24/2020 10:34:03' prior: 50558815 overrides: 50559303! - referencePosition - "Return the current reference position of the receiver" - "a rather ugly way to say #center . At least, we avoid false polymorphism" - "remove some day" - self flag: #jmvVer2. - self displayBounds ifNotNil: [ :r | r center ]. - ^self morphExtentInWorld // 2 + self morphPositionInWorld! ! -!HaloMorph methodsFor: 'dropping/grabbing' stamp: 'jmv 11/24/2020 11:17:47' prior: 16850627! - startDrag: evt with: dragHandle - "Drag my target without removing it from its owner." - - | p | - evt hand obtainHalo: self. "Make sure the event's hand correlates with the receiver" - p _ target morphPositionInWorld. - positionOffset _ dragHandle referencePosition - p. - haloDelta _ self morphPositionInWorld - p. -! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/24/2020 11:31:40' prior: 50558727! - addHandles - - self removeAllMorphs. "remove old handles, if any" - target displayBoundsForHalo ifNotNil: [ :r | - self morphBounds: r. "update my size" - haloBox _ self basicBox. - target addHandlesTo: self box: haloBox. - self addNameString: (target printStringLimitedTo: 40). - self redrawNeeded ]. -! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/24/2020 11:17:51' prior: 50545248! - doDrag: evt with: dragHandle - | thePoint | - evt hand obtainHalo: self. - thePoint _ evt eventPosition - positionOffset. - target morphPositionInWorld: thePoint. - self morphPositionInWorld: thePoint + haloDelta. -! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/24/2020 11:55:32' prior: 50558461! - doRot: evt with: rotHandle - "Update the rotation of my target if it is rotatable." - - | radians | - evt hand obtainHalo: self. - radians _ (evt eventPosition - target referencePosition) theta + angleOffset. - radians _ radians detentBy: 0.05 atMultiplesOf: Float pi / 4 snap: false. - radians = 0.0 - ifTrue: [rotHandle color: `Color lightBlue`] - ifFalse: [rotHandle color: `Color blue`]. - rotHandle submorphsDo: - [:m | m color: rotHandle color makeForegroundColor]. - target rotation: radians. - rotHandle morphPositionInWorld: evt eventPosition - (rotHandle morphExtent // 2)! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/24/2020 11:19:54' prior: 50558934! - doScale: evt with: scaleHandle - "Update the scale of my target if it is scalable." - - | scale | - evt hand obtainHalo: self. - scale _ (evt eventPosition - target referencePosition) rho * scaleOffset. - scale = 1.0 - ifTrue: [scaleHandle color: `Color lightBlue`] - ifFalse: [scaleHandle color: `Color blue`]. - scaleHandle submorphsDo: - [:m | m color: scaleHandle color makeForegroundColor]. - target scale: scale. - scaleHandle morphPositionInWorld: evt eventPosition - (scaleHandle morphExtent // 2)! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/24/2020 11:44:08' prior: 50558954! - startRot: evt with: rotHandle - "Initialize rotation of my target if it is rotatable." - - evt hand obtainHalo: self. "Make sure the event's hand correlates with the receiver" - - self removeAllHandlesBut: rotHandle. "remove all other handles" - angleOffset _ target rotation - (evt eventPosition - target referencePosition) theta.! ! - -MovableMorph removeSelector: #rotationDegrees:! - -!methodRemoval: MovableMorph #rotationDegrees: stamp: 'Install-4476-HaloFixes-JuanVuletich-2020Nov24-12h11m-jmv.001.cs.st 12/30/2020 14:47:35'! -rotationDegrees: degrees - "Change the rotation of this morph. Argument is an angle to be taken as the new rotation." - - self rotation: degrees degreesToRadians! - -KernelMorph subclass: #HaloMorph - instanceVariableNames: 'target positionOffset angleOffset scaleOffset haloBox haloDelta' - classVariableNames: 'Icons' - poolDictionaries: '' - category: 'Morphic-Halos'! - -!classDefinition: #HaloMorph category: #'Morphic-Halos' stamp: 'Install-4476-HaloFixes-JuanVuletich-2020Nov24-12h11m-jmv.001.cs.st 12/30/2020 14:47:35'! -KernelMorph subclass: #HaloMorph - instanceVariableNames: 'target positionOffset angleOffset scaleOffset haloBox haloDelta' - classVariableNames: 'Icons' - poolDictionaries: '' - category: 'Morphic-Halos'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4476-HaloFixes-JuanVuletich-2020Nov24-12h11m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4476] on 24 November 2020 at 3:39:52 pm'! -!TextEditor methodsFor: 'menu messages' stamp: 'jmv 11/24/2020 15:39:08' prior: 50514634! - find - "Prompt the user for a string to search for, and search the receiver from the current selection onward for it. 1/26/96 sw" - - self - request: 'Find what?' - initialAnswer: self class findText - do: [:aString| - aString isEmpty ifFalse: - ["Set focus on our text morph, so that cmd-g does the search again" - morph world activeHand newKeyboardFocus: morph. - self setSearch: aString. - ChangeText _ self class findText. "Implies no replacement to againOnce: method" - (self findAndReplaceMany: false) - ifFalse: [ self flash ]. - morph scrollSelectionIntoView ]]. - -" morph installEditorToReplace: self"! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4477-find-scrollSelectionIntoView-JuanVuletich-2020Nov24-15h38m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4477] on 24 November 2020 at 5:12:33 pm'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 11/24/2020 17:12:19' prior: 50552890! - computeDamage: aWorldMorph repair: aDamageRecorder rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage - "Iterate front to back while computing damage to actually repair for each morph, and for world background. - Answer uncoveredDamage, the areas where World background needs to be redrawn." - - | uncoveredDamage morph morphDamage prevMorphDamage reuseInstance morphBefore | - morphDamage _ OrderedCollection new. - prevMorphDamage _ OrderedCollection new. - uncoveredDamage _ aDamageRecorder damageReportedOther. - "Iterate from front to back" - 1 to: rootMorphs size do: [ :i | - morph _ rootMorphs at: i. - morphDamage removeAll. - (aDamageRecorder damageReportedFor: morph) ifNotNil: [ :r | - morphDamage add: r ]. - morph displayFullBounds ifNotNil: [ :morphFullBounds | - uncoveredDamage do: [ :r | | intersection | - intersection _ r intersect: morphFullBounds. - intersection hasPositiveExtent ifTrue: [ - morphDamage add: intersection ]]]. - 1 to: i-1 do: [ :j | - reuseInstance _ prevMorphDamage. - prevMorphDamage _ morphDamage. - morphDamage _ reuseInstance removeAll. - morphBefore _ rootMorphs at: j. - prevMorphDamage do: [ :r | - morphBefore addPossiblyUncoveredAreasIn: r to: morphDamage ]]. - (Rectangle merging: morphDamage) ifNotNil: [ :morphDamageRect | - rootMorphsDamage at: i put: morphDamageRect. - morph addPossiblyUncoveredAreasIn: morphDamageRect to: uncoveredDamage ]]. - - ^ uncoveredDamage! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 11/24/2020 17:12:08' prior: 50552968! - drawWorld: aWorldMorph rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage allDamage: worldDamage - "Redraw the damaged areas. - Draw each morph just once, merging rectanges to be repaired as needed." - - | morph morphDamage | - - "Iterate from back to front." - rootMorphs size to: 1 by: -1 do: [ :i | - morph _ rootMorphs at: i. - morph visible ifTrue: [ - morphDamage _ rootMorphsDamage at: i. - morph displayFullBounds ifNotNil: [ :morphFullBounds | - worldDamage do: [ :r | | intersection | - intersection _ r intersect: morphFullBounds. - intersection hasPositiveExtent ifTrue: [ - morphDamage _ intersection quickMerge: morphDamage ]]]. - morphDamage ifNotNil: [ - self newClipRect: morphDamage. - self fullDraw: morph. - worldDamage add: morphDamage ]]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4478-MorphicRepairFix-JuanVuletich-2020Nov24-16h50m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4478] on 25 November 2020 at 3:59:41 pm'! -!Morph methodsFor: 'drawing' stamp: 'jmv 11/25/2020 13:10:56' prior: 16874306! - drawingFails - self world addKnownFailing: self. - self redrawNeeded. -! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 11/25/2020 13:10:51' prior: 16874310! - drawingFailsNot - self world removeKnownFailing: self. - self redrawNeeded. -! ! -!WorldMorph methodsFor: 'errors on draw' stamp: 'jmv 11/25/2020 13:10:47' prior: 50551865! - removeAllKnownFailing - drawingFailingMorphs do: [ :m | m redrawNeeded ]. - drawingFailingMorphs _ WeakIdentitySet new. -! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 11/25/2020 12:53:08' prior: 50556078! - drawCurrentAsError - "The morph (or one of its submorphs) had an error in its drawing method." - | r w | - r _ currentMorph morphLocalBounds. - w _ r extent > `50@50` - ifTrue: [ 6 ] - ifFalse: [ 2 ]. - self - frameAndFillRectangle: r - fillColor: `Color red` - borderWidth: w - borderColor: `Color yellow`. - self line: r topLeft to: r bottomRight width: w color: `Color yellow`. - self line: r topRight to: r bottomLeft width: w color: `Color yellow`. - world notNil ifTrue: [ "Only if we are drawing the world" - currentMorph displayBounds: self boundingRectOfCurrentMorphAfterDraw ].! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 11/25/2020 12:34:48' prior: 50530701! - fullDraw: aMorph - "Draw the full Morphic structure on us" - - "We are already set with a proper transformation from aMorph owner's coordinates to those of our target form." - - self flag: #jmvVer3. - aMorph visible ifFalse: [^ self]. - self into: aMorph. - - currentMorph layoutSubmorphsIfNeeded. - - currentMorph isKnownFailing ifTrue: [ - self canvasToUse drawCurrentAsError. - self outOfMorph. - ^ self]. - - (currentMorph isOwnedByHand and: [ Preferences cheapWindowReframe ]) ifTrue: [ - self drawCurrentAsOutline. - self outOfMorph. - ^ self]. - - "Draw current Morph and submorphs" - self canvasToUse drawCurrentAndSubmorphs. - - self outOfMorph! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4479-Morph-drawAsError-fixes-JuanVuletich-2020Nov25-15h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4479] on 26 November 2020 at 3:03:59 pm'! -!Preferences class methodsFor: 'standard queries' stamp: 'jmv 11/26/2020 15:03:12' prior: 0! - haloEnclosesFullBounds - ^ self - valueOfFlag: #haloEnclosesFullBounds - ifAbsent: [ true ].! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/26/2020 13:05:43' prior: 50541053! - basicBox - "basicBox is in local coordinates" - - | minSide e hs box | - hs _ Preferences haloHandleSize. - minSide _ 4 * hs. - e _ extent + (hs*2) max: minSide@minSide. - box _ target displayBoundsForHalo. - box _ Rectangle center: box center extent: e. - self world ifNotNil: [ :w | box _ box intersect: (w viewBox insetBy: (hs@hs corner: hs@(hs*3))) ]. - ^box translatedBy: self morphPosition negated. -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4480-haloBoundsFix-JuanVuletich-2020Nov26-15h03m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4479] on 26 November 2020 at 3:07:55 pm'! -!Morph methodsFor: 'accessing' stamp: 'jmv 11/26/2020 15:05:00'! - location: aGeometryTransformation! ! -!Morph methodsFor: 'submorphs-accessing' stamp: 'jmv 11/26/2020 14:34:52'! - allMorphsBut: aMorph do: aBlock - "Evaluate the given block for all morphs in this composite morph (including the receiver), - but avoid aMorph and all its submorphs." - - self == aMorph ifFalse: [ - submorphs do: [:m | m allMorphsBut: aMorph do: aBlock ]. - aBlock value: self ].! ! -!MovableMorph methodsFor: 'accessing' stamp: 'jmv 11/26/2020 13:27:14' overrides: 50559666! - location: aGeometryTransformation - location _ aGeometryTransformation! ! -!WorldMorph methodsFor: 'submorphs-accessing' stamp: 'jmv 11/26/2020 14:34:48' overrides: 50559670! - allMorphsBut: aMorph do: aBlock - "Evaluate the given block for all morphs in this composite morph (including the receiver), - but avoid aMorph and all its submorphs." - - self == aMorph ifFalse: [ - submorphs do: [:m | m allMorphsBut: aMorph do: aBlock ]. - aBlock value: self. - self handsReverseDo: [:h | h allMorphsBut: aMorph do: aBlock ]].! ! -!Morph methodsFor: 'meta-actions' stamp: 'jmv 11/26/2020 15:05:27' prior: 50534654! - potentialEmbeddingTargets - "Return the potential targets for embedding the receiver" - | myRect myWorld | - owner ifNil:[^#()]. - myWorld := owner world ifNil: [^#()]. - myRect := self displayBounds. - ^Array streamContents: [ :strm | - myWorld allMorphsBut: self do: [ :m | - (m isReallyVisible - and: [ m isLocked not - and: [(m displayBounds intersects: myRect) - and: [(m ~= self) - and: [(m isKindOf: HaloMorph) not]]]]) ifTrue: [ strm nextPut: m ]]]! ! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'jmv 11/26/2020 15:06:40' prior: 16876867! - addMorphFrontFromWorldPosition: aMorph - - | tx | - tx _ GeometryTransformation identity. - aMorph withAllOwnersDo: [ :o | - tx _ o location composedWith: tx ]. - self withAllOwnersReverseDo: [ :o | - tx _ o location inverseTransformation composedWith: tx ]. - self addMorphFront: aMorph. - aMorph location: tx! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 11/26/2020 15:06:03' prior: 50426109! - attachMorphBeside: aMorph - - "Position the given morph beside this hand, then grab it." - - aMorph aboutToBeGrabbedBy: self. - self grabMorph: aMorph delta: (self morphWidth)@0. -! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 11/26/2020 15:00:56' prior: 50555622! - grabMorph: aMorph moveUnderHand: moveUnderHand - "Grab the given morph (i.e., add it to this hand and remove it from its current owner). - If moveUnderHand is requested or it seems neccesary anyway, move the grabbed morph under the hand." - - | grabbed positionInHandCoordinates tx | - self releaseMouseFocus. "Break focus" - grabbed _ aMorph. - aMorph owner ifNotNil: [ :o | grabbed _ o aboutToGrab: aMorph ]. - grabbed ifNil: [ ^ self ]. - grabbed _ grabbed aboutToBeGrabbedBy: self. - grabbed ifNil: [ ^ self ]. - - moveUnderHand - ifTrue: [ - "We can possibly do better, especially for non WidgetMorphs" - positionInHandCoordinates _ -30 @ -10. - grabbed isInWorld ifTrue: [ - grabbed displayBounds ifNotNil: [ :r | - positionInHandCoordinates _ (r extent // 2) negated ]]. - self - grabMorph: grabbed - delta: positionInHandCoordinates. - ^self ]. - - positionInHandCoordinates _ (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) - morphPositionInWorld - self morphPositionInWorld. - - tx _ GeometryTransformation identity. - aMorph withAllOwnersDo: [ :o | - tx _ o location composedWith: tx ]. - self withAllOwnersReverseDo: [ :o | - tx _ o location inverseTransformation composedWith: tx ]. - - self - grabMorph: grabbed - delta: positionInHandCoordinates. - - aMorph location: tx.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4481-correctLocationWhenEmbeddingMorphs-JuanVuletich-2020Nov26-15h03m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4481] on 26 November 2020 at 3:18:46 pm'! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 11/26/2020 15:17:14' prior: 50555912! - grabMorph: aMorph delta: delta - "Grab the given morph (i.e., add it to this hand and remove it from its current owner)." - - | formerOwner formerPositionInWorld | - self releaseMouseFocus. "Break focus" - - "Grab the halo if present" - self halo ifNotNil: [ :h | - (h target == aMorph or: [h target hasOwner: aMorph]) ifTrue: [ - self addMorphBack: h position: h morphPositionInWorld - self morphPositionInWorld ]]. - - "Remember previous owner and position, in case the drop is later rejected" - formerOwner _ aMorph owner. - formerOwner ifNotNil: [ - formerPositionInWorld _ aMorph morphPositionInWorld. - grabMorphData - at: aMorph - put: { formerOwner. formerPositionInWorld. } ]. - self addMorphBack: aMorph position: delta. - aMorph displayBounds ifNotNil: [ :r | | d | - formerPositionInWorld ifNotNil: [ - d _ aMorph morphPositionInWorld - formerPositionInWorld. - d isZero ifFalse: [ - aMorph displayBounds: (r translatedBy: d)]]]. - aMorph justGrabbedFrom: formerOwner. - formerOwner ifNotNil: [ - lastPosition _ self morphPosition ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4482-grabWithHaloFix-JuanVuletich-2020Nov26-15h18m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4482] on 30 November 2020 at 12:38:38 pm'! -!Morph methodsFor: 'meta-actions' stamp: 'jmv 11/27/2020 17:58:00' prior: 50559702! - potentialEmbeddingTargets - "Return the potential targets for embedding the receiver" - | myRect myWorld | - owner ifNil:[^#()]. - myWorld := owner world ifNil: [^#()]. - myRect := self displayBounds. - ^Array streamContents: [ :strm | - myWorld allMorphsBut: self do: [ :m | - (m isReallyVisible - and: [ m isLocked not - and: [(m displayBounds intersects: myRect) - and: [(m ~= self) - and: [(#(HaloMorph HaloHandleMorph) statePointsTo: m class name) not]]]]) - ifTrue: [ strm nextPut: m ]]].! ! -!Morph methodsFor: 'submorphs-accessing' stamp: 'jmv 11/27/2020 18:04:44' prior: 50559670! - allMorphsBut: aMorph do: aBlock - "Evaluate the given block for all morphs in this composite morph (including the receiver), - but avoid aMorph and all its submorphs. - Also avoid halos (might happen when called on the World) and Hands" - - self == aMorph ifTrue: [ ^self ]. - (self is: #HaloMorph) ifTrue: [ ^self ]. - submorphs do: [:m | m allMorphsBut: aMorph do: aBlock ]. - aBlock value: self.! ! - -WorldMorph removeSelector: #allMorphsBut:do:! - -!methodRemoval: WorldMorph #allMorphsBut:do: stamp: 'Install-4483-EmbeddingTargetsFix-JuanVuletich-2020Nov30-12h37m-jmv.001.cs.st 12/30/2020 14:47:35'! -allMorphsBut: aMorph do: aBlock - "Evaluate the given block for all morphs in this composite morph (including the receiver), - but avoid aMorph and all its submorphs." - - self == aMorph ifFalse: [ - submorphs do: [:m | m allMorphsBut: aMorph do: aBlock ]. - aBlock value: self. - self handsReverseDo: [:h | h allMorphsBut: aMorph do: aBlock ]].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4483-EmbeddingTargetsFix-JuanVuletich-2020Nov30-12h37m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4483] on 1 December 2020 at 10:45:05 am'! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 12/1/2020 10:39:59'! - clipsSubmorphsReally - "Currently only one level of clipping is supported. - This means that if a morph clipsSubmorphs, then no submorph in its tree can't do it. - This is a current limitation of VectorCanvas" - - self clipsSubmorphs ifFalse: [ ^false ]. - self allOwnersDo: [ :o | o clipsSubmorphs ifTrue: [ ^false ]]. - ^true! ! -!Morph methodsFor: 'change reporting' stamp: 'jmv 12/1/2020 10:40:16' prior: 50556962! - invalidateDisplayRect: damageRect for: aMorph - " - If we clip submorphs, then we clip damageRect. - - aMorph is the morph that changed and therefore should be redrawn. In some cases, damage reporting is done by no longer occupying some area, and requesting whatever appropriate morph to be drawn there. In such cases, aMorph should be nil. See senders." - - | clippedRect b | - - "warning. Senders are using global coordinates. Redesign!!" - "local now!!!!!!!!!!" - self flag: #jmvVer2. "ok?" - - self visible ifFalse: [ ^self]. - - clippedRect _ damageRect. - self clipsSubmorphsReally ifTrue: [ - b _ self displayBounds. - b ifNil: [ ^self ]. - clippedRect _ damageRect intersect: b ]. - owner ifNotNil: [ - owner invalidateDisplayRect: clippedRect for: aMorph ]! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 12/1/2020 10:40:08' prior: 50557031! - displayFullBounds - "Answer a rectangle that completely bounds receiver and submorphs when last drawn - (if the world was to be fully drawn, i.e. only to be used on a Canvas on the full world)." - - | answer | - answer _ self displayBounds. - answer ifNil: [ ^nil ]. - (self submorphsMightProtrude and: [self clipsSubmorphsReally not]) ifTrue: [ - self submorphsReverseDo: [ :m | - answer _ answer quickMerge: m displayFullBounds ]]. - ^answer! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 12/1/2020 10:42:27' prior: 50556988! - clipsSubmorphs - "Answer true if we clip the shape of our submorphs to our own. - Answer true only when clipping by the canvas is needed. - Morphs that can guarantee that submorphs don't protrude and answer false to - #submorphsMightProtrude should answer false for better performance. - Note: Currently we are limited to only one clipping morph in an owner / submorph chain. - See #clipsSubmorphsReally" - - ^ false! ! -!Morph methodsFor: 'updating' stamp: 'jmv 12/1/2020 10:40:19' prior: 50557059! - redrawNeeded - "Report that the area occupied by this morph should be redrawn. - Usually because we changed in some way." - - self needsRedraw: true. - self allOwnersDo: [ :m | m submorphNeedsRedraw: true ]. - self invalidateDisplayRect: self displayBoundsOrBogus for: self. - (self submorphsMightProtrude and: [self clipsSubmorphsReally not]) ifTrue: [ - self submorphsReverseDo: [ :m | m redrawNeeded ]].! ! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 12/1/2020 10:40:22' prior: 50557302! - clippingByCurrentMorphDo: aBlock - "Do clipping only if currentMorph says so" - - | prevClipRect prevClippingMorphRect | - - currentMorph clipsSubmorphsReally ifFalse: [ ^aBlock value ]. - - prevClipRect _ self clipRect. - prevClippingMorphRect _ clippingMorphDisplayBounds. - "Might use the fact that currentMorph has just been drawn." - clippingMorphDisplayBounds _ self boundingRectOfCurrentMorphAfterDraw. - self setClipRect: (prevClipRect intersect: clippingMorphDisplayBounds). - self clipCurrentMorph: true. - aBlock ensure: [ - self clipCurrentMorph: false. - self setClipRect: prevClipRect. - clippingMorphDisplayBounds _ prevClippingMorphRect ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4484-ClippingMorphsCantContainClippingMorphs-JuanVuletich-2020Dec01-10h44m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4484] on 8 December 2020 at 8:56:57 am'! -!ColorForm methodsFor: 'private' stamp: 'jmv 12/8/2020 08:44:09' prior: 50358626! - ensureColorArrayExists - "Return my color palette." - - | colorsToUse | - colors ifNil: [ - self depth > 8 ifTrue: [^ self error: 'ColorForms only support depths up to 8 bits']. - colorsToUse _ Color indexedColors copyFrom: 1 to: (1 bitShift: self depth). - "Note: zero is transparent except when depth is one-bit deep" - self depth > 1 ifTrue: [ - colorsToUse at: 1 put: Color transparent ]. - self colors: colorsToUse]. -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4485-ColorForm-fix-JuanVuletich-2020Dec08-08h47m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4484] on 8 December 2020 at 9:11:10 am'! -!Color class methodsFor: 'class initialization' stamp: 'jmv 12/8/2020 09:02:12'! - oneBitColors - "Answer the colors available for 1 bit Forms. - Note: For depths 2 to 8, first entry is Color transparent, not white. See #initializeIndexedColors" - - ^ `{ Color white. Color black }`! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 12/8/2020 09:04:11' prior: 50386260! - colorFromPixelValue: p depth: d - "Convert a pixel value for the given display depth into a color." - "Details: For depths of 8 or less, the pixel value is simply looked up in a table. For greater depths, the color components are extracted and converted into a color." - "Warning: In BitBlt, a pixel with pixelValue = 0 is transparent. - Squeak usually assumes that r=g=b=0 => transparent. But this is false if we have alpha (opacity). - A color with r=g=b=0 and opacity = 255 is BLACK, not TRANSPARENT. - Squeak also answers darkest possible blue when asked for black. Again, this is not needed in 32 bits (with alpha). It is also not really needed for 16 bits as we have an extra, unused bit: 16r8000 is not zero, but rgb=0, and hence, black. - The real rule is that pixelValue=0 means transparent. - And that darkest blue must be used instead of black, but only for depths >8 and < 16 (no indexed colors, no alpha) - This method is updated to reflect that." - - | r g b alpha | - - d = 1 ifTrue: [^ self oneBitColors at: (p bitAnd: 16r01) + 1]. - - d = 8 ifTrue: [^ self indexedColors at: (p bitAnd: 16rFF) + 1]. - d = 4 ifTrue: [^ self indexedColors at: (p bitAnd: 16r0F) + 1]. - d = 2 ifTrue: [^ self indexedColors at: (p bitAnd: 16r03) + 1]. - - d = 32 ifTrue: [ - "eight bits per component; 8 bits of alpha" - alpha _ p bitShift: -24. - alpha = 0 ifTrue: [ ^`Color transparent` ]. - r _ (p bitShift: -16) bitAnd: 16rFF. - g _ (p bitShift: -8) bitAnd: 16rFF. - b _ p bitAnd: 16rFF. - ^alpha < 255 - ifTrue: [ (Color r: r g: g b: b range: 255) alpha: alpha asFloat / 255.0 ] - ifFalse: [ Color r: r g: g b: b range: 255 ]]. - - d = 16 ifTrue: [ - "five bits per component. The most significant bit, unused, allows having real black, without p being zero" - r _ (p bitShift: -10) bitAnd: 16r1F. - g _ (p bitShift: -5) bitAnd: 16r1F. - b _ p bitAnd: 16r1F. - ^ Color r: r g: g b: b range: 31]. - - d = 15 ifTrue: [ - "five bits per component" - r _ (p bitShift: -10) bitAnd: 16r1F. - g _ (p bitShift: -5) bitAnd: 16r1F. - b _ p bitAnd: 16r1F. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^`Color black` ]. - ^ Color r: r g: g b: b range: 31]. - - d = 12 ifTrue: [ - "four bits per component" - r _ (p bitShift: -8) bitAnd: 16rF. - g _ (p bitShift: -4) bitAnd: 16rF. - b _ p bitAnd: 16rF. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^`Color black` ]. - ^ Color r: r g: g b: b range: 15]. - - d = 9 ifTrue: [ - "three bits per component" - r _ (p bitShift: -6) bitAnd: 16r7. - g _ (p bitShift: -3) bitAnd: 16r7. - b _ p bitAnd: 16r7. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^`Color black` ]. - ^ Color r: r g: g b: b range: 7]. - - self error: 'unknown pixel depth: ', d printString! ! -!Color class methodsFor: 'class initialization' stamp: 'jmv 12/8/2020 09:03:11' prior: 50398116! - initializeIndexedColors - "Build an array of colors corresponding to the fixed colormap used - for depths of 2, 4, or 8 bits." - " - Color initializeIndexedColors - " - " -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: (Color r: 1 g: 0 b: 0); display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: (Color r: 0 g: 1 b: 0); display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: (Color r: 0 g: 0 b: 1); display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: (Color r: 0.5 g: 0.5 b: 0.5); display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: Color blue; display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: Color green; display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: Color red; display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: Color cyan; display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: Color yellow; display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: Color magenta; display. - " - - | a index grayVal | - a _ Array new: 256. - - "1-bit colors (monochrome)" - a at: 1 put: `Color transparent`. "Note: For 1bpp forms, it is white" - a at: 2 put: `Color r: 0.0 g: 0.0 b: 0.0`. "black" - - "additional colors for 2-bit color" - a at: 3 put: `Color r: 1.0 g: 1.0 b: 1.0`. "opaque white" - a at: 4 put: `Color r: 0.5 g: 0.5 b: 0.5`. "1/2 gray" - - "additional colors for 4-bit color" - a at: 5 put: Color red. - a at: 6 put: Color green. - a at: 7 put: Color blue. - a at: 8 put: Color cyan. - a at: 9 put: Color yellow. - a at: 10 put: Color magenta. - - a at: 11 put: `Color r: 0.125 g: 0.125 b: 0.125`. "1/8 gray" - a at: 12 put: `Color r: 0.25 g: 0.25 b: 0.25`. "2/8 gray" - a at: 13 put: `Color r: 0.375 g: 0.375 b: 0.375`. "3/8 gray" - a at: 14 put: `Color r: 0.625 g: 0.625 b: 0.625`. "5/8 gray" - a at: 15 put: `Color r: 0.75 g: 0.75 b: 0.75`. "6/8 gray" - a at: 16 put: `Color r: 0.875 g: 0.875 b: 0.875`. "7/8 gray" - - "additional colors for 8-bit color" - "24 more shades of gray (1/32 increments but not repeating 1/8 increments)" - index _ 17. - 1 to: 31 do: [:v | - (v \\ 4) = 0 ifFalse: [ - grayVal _ v / 32.0. - a at: index put: (Color r: grayVal g: grayVal b: grayVal). - index _ index + 1]]. - - "The remainder of color table defines a color cube with six steps - for each primary color. Note that the corners of this cube may repeat - previous colors, but this simplifies the mapping between RGB colors - and color map indices. This color cube spans indices 40 through 255 - (indices 41-256 in this 1-based array)." - 0 to: 5 do: [:r | - 0 to: 5 do: [:g | - 0 to: 5 do: [:b | - index _ 41 + ((36 * r) + (6 * b) + g). - index > 256 ifTrue: [ - self error: 'index out of range in color table compuation']. - a at: index put: (Color r: r g: g b: b range: 5)]]]. - - IndexedColors _ a. -! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 12/8/2020 09:07:06' prior: 50355398! - computeColormapForGray8bppFrom: sourceDepth - "Compute a colorMap for translatingfrom the given depth to the 8bpp grays" - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | map | - sourceDepth < 16 ifTrue: [ - "source is 1-, 2-, 4-, or 8-bit indexed color" - map _ sourceDepth = 1 ifTrue: [ self oneBitColors ] ifFalse: [ self indexedColors ]. - map _ (map copyFrom: 1 to: (1 bitShift: sourceDepth)) - collect: [ :c | (c luminance * 255) rounded]. - map _ map as: Bitmap. - ^ map ]. - ^ self computeRGBColormapForGray8! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 12/8/2020 09:08:06' prior: 50355428! - computeColormapFrom: sourceDepth to: destDepth - "Compute a colorMap for translating between the given depths. A colormap is a Bitmap whose entries contain the pixel values for the destination depth. Typical clients use cachedColormapFrom:to: instead." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | map bitsPerColor | - sourceDepth < 16 ifTrue: [ - "source is 1-, 2-, 4-, or 8-bit indexed color" - map _ sourceDepth = 1 ifTrue: [ self oneBitColors ] ifFalse: [ self indexedColors ]. - map _ (map copyFrom: 1 to: (1 bitShift: sourceDepth)) - collect: [:c | c pixelValueForDepth: destDepth]. - ^map as: Bitmap ]. - "source is 16-bit or 32-bit RGB" - destDepth > 8 - ifTrue: [bitsPerColor _ 5] "retain maximum color resolution" - ifFalse: [bitsPerColor _ 4]. - ^self computeRGBColormapFor: destDepth bitsPerColor: bitsPerColor! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 12/8/2020 09:08:57' prior: 50386436! - computeIndexedColorConvertingMap: targetColor from: sourceDepth to: destDepth - | map | - - map _ sourceDepth = 1 ifTrue: [ self oneBitColors ] ifFalse: [ self indexedColors ]. - map _ (map copyFrom: 1 to: (1 bitShift: sourceDepth)) collect: [ :cc | | f c | - f _ 1.0 - (cc red + cc green + cc blue / 3.0 ). - c _ targetColor - ifNotNil: [ - destDepth = 32 - ifTrue: [ targetColor * f alpha: f] - ifFalse: [ targetColor alphaMixed: f*1.5 with: `Color white` ]] - ifNil: [ cc ]. - destDepth = 32 - ifTrue: [ c pixelValueForDepth: destDepth] - ifFalse: [ - f = 0.0 - ifTrue: [ 0 ] - ifFalse: [ c pixelValueForDepth: destDepth ]]]. - ^map as: Bitmap! ! -!Form methodsFor: 'converting' stamp: 'jmv 12/8/2020 09:10:47' prior: 50386948! - as8BitColorForm - "Simple conversion of zero pixels to transparent. Force it to 8 bits." - - | f | - f _ ColorForm extent: self extent depth: 8. - self displayOn: f at: self offset negated. - f colors: Color indexedColors copy. - f offset: self offset. - ^ f! ! -!ColorForm methodsFor: 'private' stamp: 'jmv 12/8/2020 09:09:50' prior: 50560015! - ensureColorArrayExists - "Return my color palette." - - colors ifNil: [ - self depth > 8 ifTrue: [^ self error: 'ColorForms only support depths up to 8 bits']. - self colors: (Color indexedColors copyFrom: 1 to: (1 bitShift: self depth)) ].! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Color initializeIndexedColors! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4486-IndexedColors-firstEntryTransparent-JuanVuletich-2020Dec08-08h56m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4484] on 3 December 2020 at 8:14:04 pm'! -!ChangeList methodsFor: 'scanning' stamp: 'KLG 12/3/2020 20:05:53' prior: 50501201! - scanSpecificChangeRecordType - "Scan anything that involves more than one chunk" - - | itemPosition item tokens firstToken secondToken | - - itemPosition _ file position. - item _ file nextChunk. - - (self itemIsRecognized: item) ifFalse: [ - "Maybe a preamble, but not one we recognize; bail out with the preamble trick" - ^ self scanAndIgnore: item in: itemPosition ]. - - tokens _ Scanner new scanTokens: item. - tokens size >= 2 ifTrue: [ - firstToken _ tokens first. - secondToken _ tokens second. - - firstToken == #classDefinition: - ifTrue: [ ^ self scanClassDefinition: tokens ]. - (firstToken == #classRemoval: or: [ firstToken == #classMoveToSomePackage: ]) - ifTrue: [ ^ self scanClassRemoval: tokens ]. - (firstToken == #methodRemoval: or: [ firstToken == #methodMoveToSomePackage: ]) - ifTrue: [ ^ self scanMethodRemoval: tokens ]. - (secondToken == #methodsFor: or: [ - tokens size > 2 and: [ tokens third == #methodsFor: ] ]) - ifTrue: [ ^ self scanMethodDefinition: tokens ]. - secondToken == #commentStamp: - ifTrue: [ ^ self scanClassComment: tokens ]. - firstToken == #provides: - ifTrue: [ ^ self scanFeatureProvision: tokens ]. - firstToken == #requires: - ifTrue: [ ^ self scanFeatureRequirement: tokens ]. - firstToken == #classRenamed: - ifTrue: [ ^ self scanClassRenamed: tokens ]. - ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4487-ChangeList-scanSpecificChangeRecordType-GeraldKlix-2020Dec03-12h01m-KLG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4384] on 7 December 2020 at 4:30:41 pm'! -!StringRequestMorph methodsFor: 'private' stamp: 'MJR 12/7/2020 16:29:34'! - textBox - - ^submorphs at: 2! ! -!StringRequestMorph methodsFor: 'private' stamp: 'MJR 12/7/2020 16:30:05' prior: 50513825! - getUserResponseOrCancel: aBlock - "Wait for the user to accept or cancel, and answer the result string. Answers the empty string if the user cancels." - "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop." - | w delay done canceled | - w _ self world. - w isNil ifTrue: [^ response asString]. - done _ false. - canceled _ false. - Preferences focusFollowsMouse ifFalse: [self textBox focusText]. - acceptBlock _ [:aString| done _ true]. - cancelBlock _ [done _ true. canceled _ true]. - delay _ Delay forMilliseconds: 10. - [done not and: [self isInWorld]] whileTrue: [ w doOneMinimalCycleNow. delay wait ]. - self delete. - w doOneMinimalCycleNow. - canceled ifTrue: [^ aBlock value]. - ^ response asString! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4488-StringRequestMorphFix-MauroRizzi-2020Dec07-16h29m-MJR.001.cs.st----! - -'From Cuis 5.0 [latest update: #4384] on 9 December 2020 at 9:23:41 pm'! -!StringRequestMorph class methodsFor: 'instance creation' stamp: 'MJR 12/9/2020 21:23:01' prior: 50548620! - request: queryString centeredAt: aPoint initialAnswer: defaultAnswer validationBlock: validationBlock acceptBlock: acceptBlock cancelBlock: cancelBlock - | answer | - answer _ self newColumn - setQuery: queryString - initialAnswer: defaultAnswer; - validationBlock: validationBlock; - acceptBlock: acceptBlock; - cancelBlock: cancelBlock. - self runningWorld addMorph: answer centeredNear: aPoint - self deltaToTextPane. - Preferences focusFollowsMouse ifFalse: [answer textBox focusText]. - ^ answer! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4489-StringRequestMorphFix-II-MauroJulianRizzi-2020Dec09-21h23m-MJR.001.cs.st----! - -'From Cuis 5.0 [latest update: #4489] on 18 December 2020 at 3:54:30 pm'! -!CodePackage methodsFor: 'naming' stamp: 'KenD 12/16/2020 13:04:33'! - packageDirectoryName - - ^self fullFileName withoutSuffix: self packageFileName! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4490-CodePackage-packageDirectoryName-KenDickey-2020Dec18-15h53m-KenD.001.cs.st----! - -'From Cuis 5.0 [latest update: #4490] on 18 December 2020 at 9:22:56 pm'! -!StringRequestMorph methodsFor: 'private' stamp: 'MJR 12/18/2020 21:19:20' prior: 50560421! - textBox - - ^submorphs detect: [:aSubmorph | aSubmorph isKindOf: TextModelMorph]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4491-StringRequestMorphFix-III-MauroJulianRizzi-2020Dec18-20h52m-MJR.001.cs.st----! - -'From Cuis 5.0 [latest update: #4490] on 20 December 2020 at 11:30:12 am'! -!Morph methodsFor: 'halos and balloon help' stamp: 'KLG 12/19/2020 13:17:06' prior: 50468598! - setBalloonText: stringTextOrSymbol - "Set receiver's balloon help text. Pass nil to remove the help." - - stringTextOrSymbol - ifNil: [ self removeProperty: #balloonText ] - ifNotNil: [ - self - setProperty: #balloonText - toValue: stringTextOrSymbol ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4492-AllowTextInHoverHelp-GeraldKlix-2020Dec20-11h25m-KLG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4384] on 18 December 2020 at 12:16:51 pm'! -!SystemWindow methodsFor: 'resize/collapse' stamp: 'MJR 12/18/2020 12:14:43'! - allowedArea - ^(RealEstateAgent maximumUsableAreaInWorld: self world) insetBy: Theme current fullScreenDeskMargin! ! -!SystemWindow methodsFor: 'resize/collapse' stamp: 'MJR 12/18/2020 12:14:00' prior: 16926623! - resizeBottom - self resize: (self allowedArea top: self allowedArea height // 2)! ! -!SystemWindow methodsFor: 'resize/collapse' stamp: 'MJR 12/18/2020 12:14:00' prior: 16926628! - resizeBottomLeft - self resize: (self allowedArea leftCenter corner: self allowedArea bottomCenter)! ! -!SystemWindow methodsFor: 'resize/collapse' stamp: 'MJR 12/18/2020 12:14:00' prior: 16926634! - resizeBottomRight - self resize: (self allowedArea center corner: self allowedArea corner)! ! -!SystemWindow methodsFor: 'resize/collapse' stamp: 'MJR 12/18/2020 12:14:00' prior: 16926640! - resizeFull - self resize: self allowedArea! ! -!SystemWindow methodsFor: 'resize/collapse' stamp: 'MJR 12/18/2020 12:14:00' prior: 16926644! - resizeLeft - self resize: (self allowedArea right: self allowedArea width // 2)! ! -!SystemWindow methodsFor: 'resize/collapse' stamp: 'MJR 12/18/2020 12:14:00' prior: 16926649! - resizeRight - self resize: (self allowedArea left: self allowedArea width // 2)! ! -!SystemWindow methodsFor: 'resize/collapse' stamp: 'MJR 12/18/2020 12:14:00' prior: 16926654! - resizeTop - self resize: (self allowedArea bottom: self allowedArea height // 2)! ! -!SystemWindow methodsFor: 'resize/collapse' stamp: 'MJR 12/18/2020 12:14:00' prior: 16926659! - resizeTopLeft - self resize: (self allowedArea origin corner: self allowedArea center)! ! -!SystemWindow methodsFor: 'resize/collapse' stamp: 'MJR 12/18/2020 12:14:00' prior: 16926665! - resizeTopRight - self resize: (self allowedArea topCenter corner: self allowedArea rightCenter)! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4493-WindowResizeEnhancements-MauroJulianRizzi-2020Dec18-12h03m-MJR.001.cs.st----! - -'From Cuis 5.0 [latest update: #4488] on 18 December 2020 at 11:16:52 am'! -!IndentingListItemMorph methodsFor: 'initialization' stamp: 'KLG 12/18/2020 11:13:07' prior: 50451886! -initWithContents: anObject prior: priorMorph forList: hostList indentLevel: newLevel - - | o | - container _ hostList. - complexContents _ anObject. - self initWithContents: anObject asString font: Preferences standardListFont emphasis: nil. - indentLevel _ 0. - isExpanded _ false. - nextSibling _ firstChild _ nil. - priorMorph ifNotNil: [ - priorMorph nextSibling: self. - ]. - o _ anObject withoutListWrapper. - icon _ o ifNotNil: [ (o respondsTo: #icon) ifTrue: [ o icon ] ]. - icon isSymbol ifTrue: [ icon _ Theme current perform: icon ]. - indentLevel _ newLevel. -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4494-IndentingListItemMorph-icon-GeraldKlix-2020Dec18-11h10m-KLG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4498] on 23 December 2020 at 12:45:45 pm'! -!HandMorph methodsFor: 'double click support' stamp: 'jmv 12/23/2020 12:35:37'! - waitingForMoreClicks - "Answer true " - - ^mouseClickState notNil! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 12/23/2020 12:45:06' prior: 50551711! - doOneCycle - "Do one cycle of the interaction loop. This method is called repeatedly when the world is running. - - Make for low cpu usage if the ui is inactive, but quick response when ui is in use. - However, after some inactivity, there will be a larger delay before the ui gets responsive again." - - | wait waitUntil | - waitDelay ifNil: [ waitDelay _ Delay forMilliseconds: 50 ]. - (lastCycleHadAnyEvent or: [ - deferredUIMessages isEmpty not or: [ - hands anySatisfy: [ :h | - h waitingForMoreClicks ]]]) - ifTrue: [ - pause _ 20. "This value will only be used when there are no more events to serve." - wait _ 0 ] "Don't wait" - ifFalse: [ - pause < 200 "No events processed? Start saving CPU!! But never make the user wait more than 200ms for being responsive again." - ifTrue: [ pause _ pause * 21//20 ]. - waitUntil _ lastCycleTime + pause. - "Earlier if steps" - stepList isEmpty not ifTrue: [ - waitUntil _ waitUntil min: stepList first scheduledTime ]. - "Earlier if alarms" - alarms ifNotNil: [ - alarms isEmpty not ifTrue: [ - waitUntil _ waitUntil min: alarms first scheduledTime ]]. - - wait _ waitUntil - Time localMillisecondClock ]. - Preferences serverMode - ifTrue: [ wait _ wait max: 50 ]. "Always wait at least a bit on servers, even if this makes the UI slow." - wait > 0 - ifFalse: [ Processor yield ] - ifTrue: [ - waitDelay beingWaitedOn - ifFalse: [ waitDelay setDelay: wait; wait ] - ifTrue: [ - "If we are called from a different process than that of the main UI, we might be called in the main - interCyclePause. In such case, use a new Delay to avoid 'This Delay has already been scheduled' errors" - (Delay forMilliseconds: wait) wait ]]. - - "Record start time of this cycle, and do cycle" - lastCycleTime _ Time localMillisecondClock. - lastCycleHadAnyEvent _ self doOneCycleNow! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4495-FixOccasionalSlowdown-JuanVuletich-2020Dec23-12h43m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4494] on 23 December 2020 at 10:11:41 am'! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'jmv 12/22/2020 11:41:26'! - withPreviousCyclicDo: twoArgBlock - "Evaluate the block with each element and the one before it. - For the first element, previous is the last one. i.e. each object is at some point the first of the pair, and at some other point the second of the pair - (1 to: 10) asArray withPreviousCyclicDo: [ :each :previous | {previous. each} print ] - #(1 2 3) asArray withPreviousCyclicDo: [ :each :previous | {previous. each} print ] - #(1 2) asArray withPreviousCyclicDo: [ :each :previous | {previous. each} print ] - #(1) asArray withPreviousCyclicDo: [ :each :previous | {previous. each} print ] - #() withPreviousCyclicDo: [ :a :b | {a. b} print ] - " - | previous | - self size < 2 ifTrue: [^self ]. - previous _ self last. - self do: [ :each | - twoArgBlock value: each value: previous. - previous _ each ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4496-SequenceableCollection-withPreviousCyclicDo-JuanVuletich-2020Dec23-10h11m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4494] on 23 December 2020 at 10:12:26 am'! -!GeometryTransformation methodsFor: 'testing' stamp: 'jmv 12/17/2020 14:43:53'! - doesMirror - "Return true if the receiver mirrors points around some rect." - - ^false! ! -!AffineTransformation methodsFor: 'testing' stamp: 'jmv 12/21/2020 17:06:08' overrides: 50560741! - doesMirror - "Return true if the receiver mirrors points around some rect." - - | f | - f _ self a11 * self a22. - ^ f = 0.0 - ifTrue: [ self a12 * self a21 > 0.0] - ifFalse: [ f < 0.0 ]! ! -!AffineTransformation methodsFor: 'transforming rects' stamp: 'jmv 12/21/2020 18:31:50'! - boundsOfInverseTransformOf: aRectangle - "Internalize aRectangle, and find a bounding rectangle with horizontal - and vertical bounds" - - ^Rectangle encompassing: (aRectangle corners collect: [ :pt | - self inverseTransform: pt ])! ! -!MorphicTranslation methodsFor: 'transforming rects' stamp: 'jmv 12/21/2020 18:35:37'! -boundsOfInverseTransformOf: aRectangle - "Externalize aRectangle, and find a bounding rectangle with horizontal - and vertical bounds and integer coordinates (i.e. adisplayBounds)." - - ^aRectangle translatedBy: self translation negated! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4497-GeometryTransformation-enh-JuanVuletich-2020Dec23-10h11m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4494] on 23 December 2020 at 10:14:31 am'! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 12/21/2020 17:47:59'! - drawString: s atBaseline: pt font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - ^self drawString: s from: 1 to: s size atBaseline: pt font: fontOrNil color: aColor! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 12/21/2020 17:58:56'! - drawString: s atCenterX: pt font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | font | - font _ self fontToUse: fontOrNil. - ^font - ifNil: [ pt ] - ifNotNil: [ - self - drawString: s - from: 1 to: s size - at: pt - ((font widthOfString: s) / 2 @ 0) - font: fontOrNil color: aColor ]! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 12/21/2020 17:47:24'! - drawString: s atWaist: pt font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - ^self drawString: s from: 1 to: s size atWaist: pt font: fontOrNil color: aColor! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 12/21/2020 17:52:31'! - drawString: s atWaistRight: pt font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | font | - font _ self fontToUse: fontOrNil. - ^font - ifNil: [ pt ] - ifNotNil: [ - self - drawString: s - from: 1 to: s size - atWaist: pt - ((font widthOfString: s) @ 0) - font: fontOrNil color: aColor ]! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 12/21/2020 17:26:18'! - drawString: aString from: firstIndex to: lastIndex atBaseline: aPoint font: fontOrNil color: aColor - self subclassResponsibility ! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 12/21/2020 17:32:21'! - drawString: aString from: firstIndex to: lastIndex atWaist: aPoint font: fontOrNil color: aColor - self subclassResponsibility ! ! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 12/21/2020 17:36:19'! - fontToUse: fontOrNil - "Answer a suitable font, aFont if possible." - - self subclassResponsibility ! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 12/21/2020 17:38:00' overrides: 50560832! - drawString: aString from: firstIndex to: lastIndex atBaseline: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | p1 font | - engine ifNil: [ ^nil ]. - - "Don't waste any time if NOP" - lastIndex = 0 ifTrue: [ - ^nil ]. - - p1 _ (currentTransformation transform: aPoint rounded) rounded. - engine colorMap: nil. - font _ self fontToUse: fontOrNil. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + (0@(0 - (font ascent + font lineGap-1))) - color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 12/21/2020 17:46:18' overrides: 50560839! - drawString: aString from: firstIndex to: lastIndex atWaist: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | p1 font | - engine ifNil: [ ^nil ]. - - "Don't waste any time if NOP" - lastIndex = 0 ifTrue: [ - ^nil ]. - - p1 _ (currentTransformation transform: aPoint rounded) rounded. - engine colorMap: nil. - font _ self fontToUse: fontOrNil. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + (0@(0 - (font ascent * 2 // 3 + font lineGap-1))) - color: aColor! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 12/21/2020 17:36:15' overrides: 50560846! - fontToUse: fontOrNil - "Answer a suitable font, aFont if possible." - - ^fontOrNil ifNil: [ FontFamily defaultFamilyAndPointSize ].! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 12/21/2020 17:37:33' prior: 50533176 overrides: 50463529! - drawString: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | p1 | - engine ifNil: [ ^nil ]. - - "Don't waste any time if NOP" - lastIndex = 0 ifTrue: [ - ^nil ]. - - p1 _ (currentTransformation transform: aPoint rounded) rounded. - engine colorMap: nil. - ^(self fontToUse: fontOrNil) - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 12/21/2020 17:38:13' prior: 50533197 overrides: 50388601! - drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - | p1 font | - - engine ifNil: [ ^nil ]. - - p1 _ (currentTransformation transform: aPoint rounded) rounded. - engine colorMap: nil. - font _ self fontToUse: fontOrNil. - - aColor = `Color black` ifFalse: [ | topColor | - topColor _ aColor alphaMixed: 0.25 with: `Color black`. - font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: topColor ]. - aColor = `Color white` ifFalse: [ | bottomColor | - bottomColor _ aColor alphaMixed: 0.22 with: `Color white`. - font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + `0@2` - color: bottomColor ]. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + `0@1` - color: aColor.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4498-MorphicCanvas-additional-drawString-protocol-JuanVuletich-2020Dec23-10h12m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4494] on 23 December 2020 at 10:12:54 am'! -!HaloMorph methodsFor: 'initialization' stamp: 'jmv 12/22/2020 16:57:41' overrides: 16876882! - delete - - super delete. - target ifNotNil: [ target redrawNeeded ].! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 12/22/2020 16:59:58' prior: 50544289! - addHalo: evt - | halo | - self displayBoundsForHalo ifNotNil: [ :r | - halo _ HaloMorph new. - halo popUpFor: self event: evt. - halo morphBounds: r ]. - self whenUIinSafeState: [self redrawNeeded]. - ^halo! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4499-HaloMorph-tweak-JuanVuletich-2020Dec23-10h12m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4499] on 23 December 2020 at 1:18:50 pm'! -!StrikeFont methodsFor: 'accessing' stamp: 'jmv 12/23/2020 13:11:47'! - lineGap - "Leading of the font." - ^0! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 12/22/2020 14:59:45'! - postDrawOn: aCanvas - "A canvas is already set with a proper transformation from our coordinates to those of the Canvas target. - Possible second stage of drawing, after drawing submorphs, and on top of them"! ! -!BitBltCanvas methodsFor: 'drawing' stamp: 'jmv 12/23/2020 13:15:20'! - drawCoordinateSystem: aRectangle - | c stepX stepY x0 x1 y0 y1 | - stepX _ 100. - stepY _ 50. - - self fillRectangle: aRectangle color: `Color lightGray alpha: 0.4`. - - x0 _ aRectangle left. - x1 _ aRectangle right-1. - y0 _ aRectangle top. - y1 _ aRectangle bottom-1. - - c _ `Color white alpha: 0.6`. - self line: x0@0 to: x1@0 width: 2 color: c. - self line: 0@y0 to: 0@y1 width: 2 color: c. - - (x0 truncateTo: stepX) to: (x1 - stepX truncateTo: stepX) by: stepX do: [ :x | - self line: x @ -5 to: x @ 5 width: 2 color: c. - self drawString: x printString atCenterX: x @ 5 font: nil color: c ]. - self drawString: 'x' atCenterX: x1 - 15 @ 0 font: nil color: c. - - (y0 truncateTo: stepY) to: (y1 - stepY truncateTo: stepY) by: stepY do: [ :y | - self line: -5 @ y to: 5 @ y width: 2 color: c. - self drawString: y printString, ' ' atWaist: 5 @ y font: nil color: c ]. - self drawString: 'y' atWaist: 0 @ (y1 - 20) font: nil color: c.! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 12/23/2020 13:15:32' overrides: 50557102! - drawCurrentAndSubmorphs - | b | - self isCurrentMorphVisible ifTrue: [ - currentMorph drawOn: self. - world notNil ifTrue: [ "Only if we are drawing the world" - currentMorph halo ifNotNil: [ b _ currentMorph morphLocalBounds ]. - currentMorph displayBounds: self boundingRectOfCurrentMorphAfterDraw ]. - "Display submorphs back to front" - "coordinate system stack already set up for aMorph - ('ivars transformations' and 'currentTransformation')" - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | self fullDraw: m ]]. - currentMorph postDrawOn: self. - b ifNotNil: [ - self drawCoordinateSystem: b ]. - world notNil ifTrue: [ "Only if we are drawing the world" - currentMorph displayBounds: - (currentMorph displayBounds quickMerge: self boundingRectOfCurrentMorphAfterDraw) ]].! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 12/23/2020 12:52:05' prior: 50557102! - drawCurrentAndSubmorphs - - self isCurrentMorphVisible ifTrue: [ - currentMorph drawOn: self. - world notNil ifTrue: [ "Only if we are drawing the world" - currentMorph displayBounds: self boundingRectOfCurrentMorphAfterDraw ]. - "Display submorphs back to front" - "coordinate system stack already set up for aMorph - ('ivars transformations' and 'currentTransformation')" - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | self fullDraw: m ]]. - currentMorph postDrawOn: self. - world notNil ifTrue: [ "Only if we are drawing the world" - currentMorph displayBounds: - (currentMorph displayBounds quickMerge: self boundingRectOfCurrentMorphAfterDraw) ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4500-HaloDrawsCoordinateSystem-JuanVuletich-2020Dec23-13h17m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4500] on 23 December 2020 at 3:41:35 pm'! -!EventSensor methodsFor: 'mouse' stamp: 'jmv 12/23/2020 15:40:29' prior: 16839399! - createMouseEvent - "create and return a new mouse event from the current mouse - position; this is useful for restarting normal event queue - processing after manual polling" - - | buttons modifiers pos mapped eventBuffer | - eventBuffer _ Array new: 8. - buttons _ self primMouseButtons. - pos _ self primMousePt. - modifiers _ buttons bitShift: -3. - buttons _ buttons bitAnd: 7. - mapped _ self mapButtons: buttons modifiers: modifiers. - eventBuffer - at: 1 put: EventSensor eventTypeMouse; - at: 2 put: Time millisecondClockValue; "VMs report events using #millisecondClockValue" - at: 3 put: pos x; - at: 4 put: pos y; - at: 5 put: mapped; - at: 6 put: modifiers. - ^ eventBuffer! ! -!EventSensor methodsFor: 'private-I/O' stamp: 'jmv 12/23/2020 15:40:15' prior: 16839601! - primGetNextEvent: array - "Store the next OS event available into the provided array. - Essential. If the VM is not event driven the ST code will fall - back to the old-style mechanism and use the state based - primitives instead." - | kbd buttons modifiers pos mapped | - - "Simulate the events" - array at: 1 put: EventSensor eventTypeNone. "assume no more events" - - "First check for keyboard" - kbd _ super primKbdNext. - kbd ifNotNil: [ - "simulate keyboard event" - array at: 1 put: EventSensor eventTypeKeyboard. "evt type" - array at: 2 put: Time millisecondClockValue. "VMs report events using #millisecondClockValue" - array at: 3 put: (kbd bitAnd: 255). "char code" - array at: 4 put: EventSensor eventKeyChar. "key press/release" - array at: 5 put: (kbd bitShift: -8). "modifier keys" - ^self]. - - "Then check for mouse" - buttons _ super primMouseButtons. - pos _ super primMousePt. - modifiers _ buttons bitShift: -3. - buttons _ buttons bitAnd: 7. - mapped _ self mapButtons: buttons modifiers: modifiers. - (pos = mousePosition and:[(mapped bitOr: (modifiers bitShift: 3)) = mouseButtons]) - ifTrue:[^self]. - array - at: 1 put: EventSensor eventTypeMouse; - at: 2 put: Time millisecondClockValue; "VMs report events using #millisecondClockValue" - at: 3 put: pos x; - at: 4 put: pos y; - at: 5 put: mapped; - at: 6 put: modifiers. -! ! -!EventSensor methodsFor: 'test' stamp: 'jmv 12/23/2020 15:39:38' prior: 16839733! - printEventBuffer: evtBuf - - | type buttons macRomanCode modifiers position pressType stamp unicodeCodePoint | - type _ evtBuf first. - stamp _ evtBuf second. - stamp = 0 ifTrue: [ stamp := Time millisecondClockValue ]. "VMs report events using #millisecondClockValue" - type = EventSensor eventTypeMouse - ifTrue: [ - position _ evtBuf third @ evtBuf fourth. - buttons _ evtBuf fifth. - modifiers _ evtBuf sixth. - Transcript - newLine; - show: 'Mouse'; - show: ' position:', position printString; - show: ' buttons:', buttons printString; - show: ' modifiers:', modifiers printString. - ]. - type = EventSensor eventTypeKeyboard - ifTrue: [ - macRomanCode _ evtBuf third. - unicodeCodePoint _ evtBuf sixth. - pressType _ evtBuf fourth. - modifiers _ evtBuf fifth. - pressType = EventSensor eventKeyDown ifTrue: [ - type _ #keyDown]. - pressType = EventSensor eventKeyUp ifTrue: [ - type _ #keyUp]. - pressType = EventSensor eventKeyChar ifTrue: [ - type _ #keystroke]. - Transcript - newLine; - show: type; - show: ' macRomanCode:', macRomanCode printString, '-', - (Character numericValue: (Character macRomanToLatin1: macRomanCode)) asString, '-'; - show: ' unicodeCodePoint:', unicodeCodePoint printString. - (Character iso8859s15CodeForUnicodeCodePoint: unicodeCodePoint) ifNotNil: [ :latin15 | - Transcript show: '-', (Character numericValue: latin15) asString, '-' ]. - Transcript - show: ' modifiers:', modifiers printString. - (modifiers anyMask: 8) ifTrue: [ Transcript show: ' [commandWinAlt]' ]. - (modifiers anyMask: 4) ifTrue: [ Transcript show: ' [macOption]' ]. - (modifiers anyMask: 2) ifTrue: [ Transcript show: ' [control]' ]. - (modifiers anyMask: 1) ifTrue: [ Transcript show: ' [shift]' ]. - ].! ! -!HandMorph methodsFor: 'private events' stamp: 'jmv 12/23/2020 15:38:50' prior: 50424836! - generateDropFilesEvent: evtBuf - "Generate the appropriate mouse event for the given raw event buffer" - - | position stamp numberOfFiles dragType | - - stamp := evtBuf second. - stamp = 0 ifTrue: [stamp := Time millisecondClockValue]. "VMs report events using #millisecondClockValue" - dragType := evtBuf third. - position := evtBuf fourth @ evtBuf fifth. - numberOfFiles := evtBuf seventh. - - ^ dragType = 4 ifTrue: [ DropFilesEvent at: position with: numberOfFiles from: self]. -! ! -!HandMorph methodsFor: 'private events' stamp: 'jmv 12/23/2020 15:38:47' prior: 50466195! - generateKeyboardEvent: evtBuf - "Generate the appropriate mouse event for the given raw event buffer" - | buttons modifiers type keyValue pressType stamp mouseScrollDirection | - stamp _ evtBuf second. - stamp = 0 ifTrue: [ stamp _ Time millisecondClockValue ]. "VMs report events using #millisecondClockValue" - (evtBuf sixth <= 0 or: [ (keyValue _ Character iso8859s15CodeForUnicodeCodePoint: evtBuf sixth) isNil ]) ifTrue: [ keyValue _ Character macRomanToLatin1: evtBuf third ]. - Sensor peekEvent ifNotNil: [ :nxt | - "start: Combining diacritical marks (i.e. accents in the Linux VM)" - (nxt fourth = EventSensor eventKeyDown and: [ nxt third > 255 ]) ifTrue: [ - keyValue _ ((Character numericValue: keyValue) withDiacriticalMark: nxt third) iso8859s15Code. - Sensor - nextEvent; - nextEvent; - nextEvent ]. - "end: Combining diacritical marks (i.e. accents in the Linux VM)" - "start: Spurious LF after CR on Ctrl-Enter on Windows VM" - ((evtBuf fourth = EventSensor eventKeyChar and: [ evtBuf third = 13 ]) and: [ - nxt fourth = EventSensor eventKeyChar and: [ nxt third = 10 ]]) ifTrue: [ Sensor nextEvent - "print " ]]. - modifiers _ evtBuf fifth. - pressType _ evtBuf fourth. - pressType = EventSensor eventKeyDown ifTrue: [ - type _ #keyDown. - lastKeyDownValue _ keyValue ]. - pressType = EventSensor eventKeyUp ifTrue: [ - (keyValue = 9 and: [(modifiers anyMask: 1) and: [Smalltalk platformName = 'unix']]) - ifTrue: [ - "Linux VMs don't generate shift-tab keystroke. Turn #keyUp into #keystroke" - pressType _ EventSensor eventKeyChar ] - ifFalse: [type _ #keyUp ]]. - pressType = EventSensor eventKeyChar ifTrue: [ - type _ #keystroke. - "If Control key pressed, and the VM answers a code below 27, - it means it did the translation, convert it back to regular character: - We want to handle the meaning of ctrl ourselves." - (modifiers anyMask: 2) ifTrue: [ - "Control key pressed" - keyValue < 27 ifTrue: [ - "But we don't want to do it for Home/End/PgUp/PgDn, just for alphabetic keys" - lastKeyDownValue = keyValue ifFalse: [ - "If equal, real Home/End/PgUp/PgDn in Windows => don't translate" - (keyValue + 64 = lastKeyDownValue or: [ "If Equal, Ctrl-alphabetic in Windows => do translate" - lastKeyDownValue < 47 ]) ifTrue: [ - "Not on windows. If less (not sure about the bound, but do not translate 48: tab on Mac), alphabetic on Mac => do translate" - keyValue _ (modifiers anyMask: 1) - ifTrue: [ keyValue + 64 ] - ifFalse: [ keyValue + 96 - "shift not pressed: conver to lowercase letter" ]]]]. - "On Windows, ctrl-backSpace is reported as ctrl-forwardDelete. But keyDown is ok, so we can know and fix." - (keyValue = 127 and: [ lastKeyDownValue = 8 ]) - ifTrue: [ keyValue _ 8 ]. - "Act as if command/alt was pressed for some usual Windows ctrl-key combinations" - (self shouldControlEmulateAltFor: keyValue) ifTrue: [ modifiers _ modifiers bitOr: 8 ]]]. - buttons _ modifiers bitShift: 3. - "Linux and Windows VM send keyboard ctrl-upArrow and ctrl-downArrow when the user tries to scroll using the mouse wheel - Mac VM sends cmd-option-ctrl-shift-upArrow and cmd-option-ctrl-shift-downArrow for trackpad vertical scroll gestures, - and cmd-option-ctrl-shift-leftArrow and cmd-option-ctrl-shift-rightArrow for horizontal scroll gestures. - This way of reporting scroll events by the VM also enables scrolling using the keyboard (actually, we can't tell if user gesture was on Mouse, Trackpad or Keyboard). - But ctrl-shift and cmdAlt-shift are needed used for selecting while moving by word, line, etc. - Additionally, #ctrlArrowsScrollHorizontally allows chosing between keyboard horizontal scroll and moving word by word in text editors." - mouseScrollDirection _ nil. - "Ctrl for Keyboard or Mouse wheel gestures. All modifiers for Trackpad gestures." - (buttons = InputSensor controlKey or: [buttons = InputSensor cmdAltOptionCtrlShiftModifierKeys]) ifTrue: [ - keyValue = 30 - ifTrue: [mouseScrollDirection _ #up] - ifFalse: [keyValue = 31 - ifTrue: [mouseScrollDirection _ #down]]]. - "Ctrl for Keyboard or Mouse wheel gestures, only if preference is set. All modifiers for Trackpad gestures." - ((buttons = InputSensor controlKey and: [Preferences ctrlArrowsScrollHorizontally]) or: [buttons = InputSensor cmdAltOptionCtrlShiftModifierKeys]) ifTrue: [ - keyValue = 28 - ifTrue: [mouseScrollDirection _ #left] - ifFalse: [keyValue = 29 - ifTrue: [mouseScrollDirection _ #right]]]. - mouseScrollDirection ifNotNil: [ - ^ MouseScrollEvent new - setType: #mouseScroll - position: self morphPosition - direction: mouseScrollDirection - buttons: buttons - hand: self - stamp: stamp ]. - ^ KeyboardEvent new - setType: type - buttons: buttons - position: self morphPosition - keyValue: keyValue - hand: self - stamp: stamp! ! -!HandMorph methodsFor: 'private events' stamp: 'jmv 12/23/2020 15:38:43' prior: 16852308! - generateMouseEvent: evtBuf - "Generate the appropriate mouse event for the given raw event buffer" - - | pos buttons modifiers type trail stamp oldButtons | - stamp := evtBuf second. - stamp = 0 ifTrue: [ stamp := Time millisecondClockValue ]. "VMs report events using #millisecondClockValue" - pos := evtBuf third @ evtBuf fourth. - buttons := evtBuf fifth. - modifiers := evtBuf sixth. - type := buttons = 0 - ifTrue: [ - lastEventBuffer fifth = 0 ifTrue: [#mouseMove] ifFalse: [#mouseUp]] - ifFalse: [ - lastEventBuffer fifth = 0 - ifTrue: [#mouseDown] - ifFalse: [#mouseMove]]. - buttons := buttons bitOr: (modifiers bitShift: 3). - oldButtons := lastEventBuffer fifth - bitOr: (lastEventBuffer sixth bitShift: 3). - lastEventBuffer := evtBuf. - type == #mouseMove - ifTrue: [ - trail := self mouseTrailFrom: evtBuf. - ^MouseMoveEvent new - setType: type - position: trail last - buttons: buttons - hand: self - stamp: stamp]. - ^MouseButtonEvent new - setType: type - position: pos - which: (oldButtons bitXor: buttons) - buttons: buttons - hand: self - stamp: stamp! ! -!HandMorph methodsFor: 'private events' stamp: 'jmv 12/23/2020 15:38:39' prior: 16852343! - generateWindowEvent: evtBuf - "Generate the appropriate window event for the given raw event buffer" - - | evt | - evt := WindowEvent new. - evt setTimeStamp: evtBuf second. - evt timeStamp = 0 ifTrue: [evt setTimeStamp: Time millisecondClockValue]. "VMs report events using #millisecondClockValue" - evt windowAction: evtBuf third. - evt rectangle: (Rectangle origin: evtBuf fourth @ evtBuf fifth corner: evtBuf sixth @ evtBuf seventh ). - - ^evt! ! -!MorphicEvent methodsFor: 'accessing' stamp: 'jmv 12/23/2020 15:39:20' prior: 16877771! - timeStamp - "Return the millisecond clock value at which the event was generated" - ^timeStamp ifNil:[timeStamp _ Time millisecondClockValue ]. "VMs report events using #millisecondClockValue"! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4501-SyntheticEventsUseSameTimerAsVMevents-JuanVuletich-2020Dec23-15h21m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4501] on 28 December 2020 at 2:58:24 pm'! -!NegativePowerError methodsFor: 'exceptionDescription' stamp: 'jmv 12/28/2020 14:58:01' overrides: 50466128! - defaultAction - - "Disable this preference to have Float nan answer (if Float receiver or argument) or Error message" - | answer | - Preferences askToInstallComplexPackage ifTrue: [ - answer _ PopUpMenu - withCaption: -'Square (or even) Root of a negative Number: -Complex number support is not loaded -Would you like me to load it for you now?' - chooseFrom: #( - 'Load Complex package' - 'Do not load Complex package' - 'Do not load Complex package and don''t ask again'). - answer = 1 ifTrue: [ - Feature require: #'Complex'. - Smalltalk at: #Complex ifPresent: [ :cplx | - ^ (cplx basicReal: receiver imaginary: 0) perform: selector withArguments: arguments ]]. - answer = 3 ifTrue: [ - Preferences disable: #askToInstallComplexPackage ]]. - ^ super defaultAction! ! -!Preferences class methodsFor: 'personalization' stamp: 'jmv 12/26/2020 14:14:32'! - askToInstallComplexPackage - ^ self - valueOfFlag: #askToInstallComplexPackage - ifAbsent: [ true ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4502-AskToInstallComplexPackage-JuanVuletich-2020Dec28-14h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4502] on 28 December 2020 at 3:49:26 pm'! -!CompiledMethod methodsFor: 'copying' stamp: 'KLG 12/23/2020 18:11:13' overrides: 50459180! - flattenTo: flattenedStream - "No senese in flattening the method's bytes." - - flattenedStream nextPut: self! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4503-CompiledMethod-flattenTo-GeraldKlix-2020Dec28-15h49m-KLG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4503] on 29 December 2020 at 2:43:10 pm'! -!Character class methodsFor: 'instance creation' stamp: 'jmv 12/29/2020 14:32:32'! - codePoint: codePoint trySimilar: aBoolean - " - Answer an appropriante Character. - If we don't have a suitable Character for codePoint, answer nil. - But if aBoolean, answer a similar Character if possible. - - self assert: (Character codePoint: 16r41 convertToASCII: false) = $A. - self assert: (Character codePoint: 16r20AC convertToASCII: false) = $¤. - " - | codePoints similarCharacters | - aBoolean ifTrue: [ - (codePoint between: 16r2018 and: 16r201B) ifTrue: [ - ^$' ]. - (codePoint between: 16r201C and: 16r201F) ifTrue: [ - ^$" ]. - (codePoint between: 16r2000 and: 16r200D) ifTrue: [ - ^$ ]. - (codePoint between: 16r2010 and: 16r2015) ifTrue: [ - ^$- ]. - (codePoint between: 16r2024 and: 16r2026) ifTrue: [ - ^$- ]. - codePoints _ #(16r2190 16r2191 16r2022 16r2023 16r2027 16r2032 16r2033 16r2035 16r2036 16r2039 16r203A). - similarCharacters _ #($_ $^ $° $° $- $' $" $` $" $< $>). - (codePoints statePointsTo: codePoint) ifTrue: [ - ^ similarCharacters at: (codePoints indexOf: codePoint) ]]. - - ^ (self iso8859s15CodeForUnicodeCodePoint: codePoint) - ifNotNil: [ :code | Character numericValue: code ]! ! -!Character class methodsFor: 'instance creation' stamp: 'jmv 12/29/2020 14:04:54' prior: 16800965! - codePoint: codePoint - " - Answer nil if the Unicode codePoint is not a valid ISO 8859-15 character - - self assert: (Character codePoint: 16r41) = $A. - self assert: (Character codePoint: 16r20AC) = $¤. - " - ^ self codePoint: codePoint trySimilar: false! ! -!String class methodsFor: 'instance creation' stamp: 'jmv 12/29/2020 13:03:32' prior: 16917779! - addUnicodeCodePoint: codePoint to: strm hex: useHexForNCRs - "Convert the given Unicode codePoint to the internal encoding: ISO Latin 9 (ISO 8859-15)" - "For unicode chars not in ISO Latin 9 (ISO 8859-15), embed Decimal NCRs or Hexadecimal NCRs according to useHex. - - See http://en.wikipedia.org/wiki/Numeric_character_reference - See http://rishida.net/tools/conversion/. Tests prepared there. - - Note: The conversion of NCRs is reversible. See #asUtf8: - This allows handling the full Unicode in Cuis tools, that can only display the Latin alphabet, by editing the NCRs. - The conversions can be done when reading / saving files, or when pasting from Clipboard and storing back on it." - - (Character codePoint: codePoint trySimilar: true) - ifNotNil: [ :char | strm nextPut: char] - ifNil: [ - useHexForNCRs - ifTrue: [ - strm nextPutAll: '&#x'. - codePoint printOn: strm base: 16 length: 4 padded: true. - strm nextPut: $; ] - ifFalse: [ - strm nextPutAll: '&#'. - codePoint printOn: strm base: 10. - strm nextPut: $; ]]! ! - -Character class removeSelector: #safeCodePoint:! - -!methodRemoval: Character class #safeCodePoint: stamp: 'Install-4504-AutoConvertSomeUnicode-JuanVuletich-2020Dec29-14h42m-jmv.001.cs.st 12/30/2020 14:47:35'! -safeCodePoint: asciiCodeOrCodePoint - "Answer the Character whose value is anInteger. - Handle unicode code points > 255 without errors, trying to answer something reasonable" - - "Note: senders of #value:or: in '1002-RTFParser.cs' has many automatic conversion to ISO-8859-15 characters, that would be valuable here." - (#(16r2019 16r201B) includes: asciiCodeOrCodePoint) ifTrue: [ - ^$' ]. - (#(16r201C 16r201D 16r201F) includes: asciiCodeOrCodePoint) ifTrue: [ - ^$" ]. - ^(self codePoint: asciiCodeOrCodePoint) - ifNil: [Character numericValue: 255 ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4504-AutoConvertSomeUnicode-JuanVuletich-2020Dec29-14h42m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4503] on 29 December 2020 at 12:16:28 pm'! -!Debugger methodsFor: 'private' stamp: 'HAW 12/29/2020 12:15:11' prior: 16830205! - selectedContext - contextStackIndex = 0 - ifTrue: [^contextStackTop] - ifFalse: [^contextStack ifNotNil: [ :aContextStack | aContextStack at: contextStackIndex]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4505-contextStackCanBeNilFix-HernanWilkinson-2020Dec29-12h15m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4505] on 29 December 2020 at 4:43:13 pm'! -!Scanner class methodsFor: 'error descriptions' stamp: 'HAW 12/29/2020 13:17:59'! - unmatechedCommentQuoteErrorDescription - - ^'Unmatched comment quote'! ! -!String methodsFor: 'converting' stamp: 'jmv 12/29/2020 16:46:01' prior: 16916985! - withoutEnclosing: aCharacter - " - '*Hello*' withoutEnclosing: $* - " - | s | - s _ self size. - s = 0 ifTrue: [ ^ self ]. - ^((self at: 1) = aCharacter and: [ (self at: s) = aCharacter ]) - ifTrue: [ self copyFrom: 2 to: s-1 ] - ifFalse: [ self ]! ! -!String methodsFor: 'converting' stamp: 'jmv 12/29/2020 16:42:03' prior: 50422533! - findSelector - "Revised to use scanner for better removal of extraneous stuff" - | potentialSelector colonIndex | - potentialSelector _ self withBlanksTrimmed withoutEnclosing: $". - colonIndex _ potentialSelector indexOf: $:. - "possible keyword selector" - (colonIndex > 1 and: [ (potentialSelector at: colonIndex - 1) isLetter ]) ifTrue: [ - potentialSelector _ [ Scanner findSelectorIn: potentialSelector ] on: Error do: [ :anError | - anError messageText = Scanner unmatechedCommentQuoteErrorDescription - ifTrue: [ - potentialSelector _ potentialSelector copyWithout: $". - anError retry ] - ifFalse: [ anError return: '']]]. - - potentialSelector isEmpty ifTrue: [ ^ nil ]. - Symbol - hasInterned: potentialSelector - ifTrue: [ :aSymbol | ^ aSymbol ]. - - ^ nil.! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'HAW 12/29/2020 13:18:18' prior: 50427998! - xDoubleQuote - "Collect a comment." - "wod 1/10/98: Allow 'empty' comments by testing the first character -for $"" rather than blindly adding it to the comment being collected." - | aStream stopChar | - stopChar := DoItCharacter. - aStream := WriteStream on: (String new: 200). - self step. - [hereChar == $"] - whileFalse: - [(hereChar == stopChar and: [source atEnd]) - ifTrue: [^self offEnd: self class unmatechedCommentQuoteErrorDescription]. - aStream nextPut: self step.]. - self step. - currentComment == nil - ifTrue: [currentComment := OrderedCollection with: aStream contents] - ifFalse: [currentComment add: aStream contents]. - self scanToken! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4506-findSelectorFix-HernanWilkinson-2020Dec29-16h36m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4506] on 30 December 2020 at 2:38:52 pm'! -!String methodsFor: 'converting' stamp: 'jmv 12/30/2020 14:38:23' prior: 50561668! - findSelector - "Revised to use scanner for better removal of extraneous stuff" - | potentialSelector colonIndex | - potentialSelector _ self withBlanksTrimmed withoutEnclosing: $". - colonIndex _ potentialSelector indexOf: $:. - "possible keyword selector" - (colonIndex > 1 and: [ (potentialSelector at: colonIndex - 1) isValidInIdentifiers ]) ifTrue: [ - potentialSelector _ [ Scanner findSelectorIn: potentialSelector ] on: Error do: [ :anError | - anError messageText = Scanner unmatechedCommentQuoteErrorDescription - ifTrue: [ - potentialSelector _ potentialSelector copyWithout: $". - anError retry ] - ifFalse: [ anError return: '']]]. - - potentialSelector isEmpty ifTrue: [ ^ nil ]. - Symbol - hasInterned: potentialSelector - ifTrue: [ :aSymbol | ^ aSymbol ]. - - ^ nil.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4507-findSelectorFix-JuanVuletich-2020Dec30-14h38m-jmv.001.cs.st----! - -----SNAPSHOT----(30 December 2020 14:47:39) Cuis5.0-4507-32.image priorSource: 7148984! - -----STARTUP---- (7 January 2021 16:17:31) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4507-32.image! - - -'From Cuis 5.0 [latest update: #4506] on 29 December 2020 at 7:19:51 pm'! -!MethodContext methodsFor: 'instruction decoding (closures)' stamp: 'HAW 12/29/2020 19:19:31'! - callPrimitive: primNumber - "Evaluate the primitive, either normal or inlined, and answer the new context resulting from that - (either the sender if a successful non-inlined primitive, or the current context, if not)." - "Copied from Squeak, Context>>#callPrimitive: - The message callInlinedPrimitive: is not implemented in Squeak also - Hernan" - - | maybePrimFailToken | - primNumber >= (1 << 15) ifTrue: "Inlined primitive, cannot fail" - [^self callInlinedPrimitive: primNumber]. - maybePrimFailToken := self doPrimitive: primNumber - method: method - receiver: receiver - args: self arguments. - "Normal primitive. Always at the beginning of methods." - (self isPrimFailToken: maybePrimFailToken) ifFalse: "On success return the result" - [^self methodReturnTop]. - "On failure, store the error code if appropriate and keep interpreting the method" - (method encoderClass isStoreAt: pc in: method) ifTrue: - [self at: stackp put: maybePrimFailToken last]. - ^self! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4508-callPrimitive-HernanWilkinson-2020Dec29-19h19m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4384] on 30 December 2020 at 7:32:37 pm'! -!ContextPart methodsFor: 'closure support' stamp: 'HAW 12/30/2020 19:31:45'! - contextTag - "Context tags may be used for referring to contexts instead of contexts themselves as they can be copied and will continue to work in other processes (continuations). By default, we use the context itself to as its tag." - ^self! ! - -MethodContext removeSelector: #contextTag! - -!methodRemoval: MethodContext #contextTag stamp: 'Install-4509-contextTagMovedToSuper-HernanWilkinson-2020Dec30-19h30m-HAW.001.cs.st 1/7/2021 16:17:35'! -contextTag - "Context tags may be used for referring to contexts instead of contexts themselves as they can be copied and will continue to work in other processes (continuations). By default, we use the context itself to as its tag." - ^self! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4509-contextTagMovedToSuper-HernanWilkinson-2020Dec30-19h30m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4384] on 30 December 2020 at 7:34:30 pm'! -!TestCase methodsFor: 'assertions' stamp: 'HAW 12/30/2020 19:33:44' prior: 16927604! - assert: expected equals: actual - ^ self - assert: expected = actual - description: [ self comparingStringBetween: expected and: actual ] -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4510-assertEqualsDescriptionsDelayedUntilNeccesary-HernanWilkinson-2020Dec30-19h32m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4494] on 1 January 2021 at 3:56:49 pm'! - -PluggableScrollPane subclass: #PluggableListMorph - instanceVariableNames: 'list getListSelector getIndexSelector setIndexSelector keystrokeActionSelector autoDeselect lastKeystrokeTime lastKeystrokes doubleClickSelector menuGetter mainView leftSibling rightSibling scrollSiblings ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #PluggableListMorph category: 'Morphic-Widgets' stamp: 'Install-4511-MultiListScroll-KenDickey-2020Dec31-11h39m-KenD.002.cs.st 1/7/2021 16:17:35'! -PluggableScrollPane subclass: #PluggableListMorph - instanceVariableNames: 'list getListSelector getIndexSelector setIndexSelector keystrokeActionSelector autoDeselect lastKeystrokeTime lastKeystrokes doubleClickSelector menuGetter mainView leftSibling rightSibling scrollSiblings' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! -!PluggableListMorph commentStamp: '' prior: 16888551! - ... - -When a PluggableListMorph is in focus, type in a letter (or several -letters quickly) to go to the next item that begins with that letter. -Special keys (up, down, home, etc.) are also supported. - -leftSibling and rightSibling have two uses. - [A] One can use left and right arrow keys to shift focus to a sibling - [B] When scrollSiblings is true, one can do "multiscrolling" -- vertical scroll siblings with self - -For [B] Sample usage see: CodePackageListWindow >>buildMorphicWindow! -!PluggableScrollPane methodsFor: 'access options' stamp: 'KenD 12/31/2020 13:05:54'! - alwaysHideVerticalScrollbar - - hideScrollBars _ #alwaysHideVertical. - self vHideScrollBar.! ! -!PluggableListMorph methodsFor: 'siblings' stamp: 'KenD 1/1/2021 13:10:42'! - scrollSiblings - "Do I scroll my siblings with myself?" - ^ scrollSiblings! ! -!PluggableListMorph methodsFor: 'siblings' stamp: 'KenD 1/1/2021 13:11:00'! - scrollSiblings: aBoolean - "Do I scroll my siblings with myself?" - scrollSiblings := aBoolean! ! -!PluggableListMorph methodsFor: 'scrolling' stamp: 'KenD 1/1/2021 13:14:57' overrides: 50406131! - scrollBy: delta - "Scroll self and any siblings" - super scrollBy: delta. - self scrollMySiblings! ! -!PluggableListMorph methodsFor: 'scrolling' stamp: 'KenD 1/1/2021 15:34:25'! - scrollMySiblings - "vertical scroll my siblings along with my self" - | yOffset | - yOffset := self scrollerOffset y. - scrollSiblings ifTrue: [ - self vScrollLeftSibling: yOffset; - vScrollRightSibling: yOffset - ]! ! -!PluggableListMorph methodsFor: 'scrolling' stamp: 'KenD 1/1/2021 13:14:49' prior: 50365049 overrides: 16889986! - scrollSelectionIntoView - "make sure that the current selection is visible" - | row r | - row _ self getCurrentSelectionIndex. - row = 0 - ifTrue: [ - "Value is 0, but we need to propagate it to model" - scrollBar internalScrollValue: scrollBar scrollValue ] - ifFalse: [ - self flag: #jmvVer2. - r _ self listMorph drawBoundsForRow: row. - r _ ((self listMorph externalize: r origin) extent: r extent). - self scrollToShow: r ]. - self scrollMySiblings -! ! -!PluggableListMorph methodsFor: 'scrolling' stamp: 'KenD 1/1/2021 13:14:29' overrides: 50455277! - scrollToShow: aRectangle - - super scrollToShow: aRectangle. - self scrollMySiblings ! ! -!PluggableListMorph methodsFor: 'scrolling' stamp: 'KenD 1/1/2021 15:41:31'! - vPrivateScrollTo: scrollValue - - self scrollerOffset: (self scrollerOffset x @ scrollValue)! ! -!PluggableListMorph methodsFor: 'scrolling' stamp: 'KenD 1/1/2021 15:43:22' overrides: 16890025! - vScrollBarValue: scrollValue - - super vScrollBarValue: scrollValue. - self scrollMySiblings! ! -!PluggableListMorph methodsFor: 'scrolling' stamp: 'KenD 1/1/2021 15:32:18'! - vScrollLeftSibling: yOffset - "vertical scroll my LEFT siblings along with my self" - self vPrivateScrollTo: yOffset. - scrollSiblings ifTrue: [ - leftSibling ifNotNil: [ :left | - left vScrollLeftSibling: yOffset ] - ]! ! -!PluggableListMorph methodsFor: 'scrolling' stamp: 'KenD 1/1/2021 15:32:25'! - vScrollRightSibling: yOffset - "vertical scroll my RIGHT siblings along with my self" - self vPrivateScrollTo: yOffset. - scrollSiblings ifTrue: [ - rightSibling ifNotNil: [ :left | - left vScrollRightSibling: yOffset ] - ]! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'KenD 12/31/2020 13:09:16' prior: 50556221! - updateScrollBarsBounds - - | t | - hideScrollBars = #hide ifTrue: [^self]. - t _ self scrollBarClass scrollbarThickness. - (hideScrollBars = #hideVertical) - ifFalse: [ - scrollBar - morphPosition: extent x - t - borderWidth @ borderWidth - extent: t @ self vScrollBarHeight. - ]. - hScrollBar - morphPosition: borderWidth @ (extent y - t - borderWidth) - extent: self hScrollBarWidth@t! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'KenD 12/31/2020 13:18:18' prior: 50556266! - vIsScrollbarNeeded - "Return whether the vertical scrollbar is needed" - - "Don't show it if we were told not to." - hideScrollBars = #hide ifTrue: [ ^false ]. - - hideScrollBars = #alwaysHideVertical ifTrue: [ ^false ]. - - hideScrollBars = #alwaysShowVertical ifTrue: [ ^true ]. - - ^self vLeftoverScrollRange > 0! ! -!PluggableListMorph methodsFor: 'initialization' stamp: 'KenD 1/1/2021 13:11:40' prior: 50492520 overrides: 50556236! - initialize - super initialize. - scroller morphWidth: extent x. - scrollSiblings := false. "user must override"! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'KenD 1/1/2021 15:49:40' prior: 50547698! - buildMorphicWindow - " - CodePackageListWindow open: CodePackageList new - " - | dirtyFlags names fileNames dirtyFlagsPane namesPane fileNamesPane - upperRow description summary backColor labelBackground | - backColor := self textBackgroundColor. - labelBackground := Theme current background. - - dirtyFlags := PluggableListMorph - model: model - listGetter: #packageDirtyFlags - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - dirtyFlags color: backColor; - hideScrollBarsIndefinitely. - dirtyFlagsPane := LayoutMorph newColumn - color: labelBackground; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: ' Unsaved?'); - addMorphUseAll: dirtyFlags. - - names := PluggableListMorph - model: model - listGetter: #packageNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - names color: backColor. - namesPane := LayoutMorph newColumn - color: labelBackground; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: ' Package Name'); - addMorphUseAll: names. - - fileNames := PluggableListMorph - model: model - listGetter: #packageFullNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - fileNames color: backColor; - alwaysHideVerticalScrollbar. - fileNamesPane := LayoutMorph newColumn - color: labelBackground; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: ' File Name'); - addMorphUseAll: fileNames. - - upperRow := LayoutMorph newRow. - upperRow - addMorph: dirtyFlagsPane proportionalWidth: 0.13; - addAdjusterAndMorph: namesPane proportionalWidth: 0.27; - addAdjusterAndMorph: fileNamesPane proportionalWidth: 0.6. - - description := (TextModelMorph - textProvider: model - textGetter: #description - textSetter: #description:) emptyTextDisplayMessage: 'Please enter a description for this package'. - - summary := (TextModelMorph - textProvider: model - textGetter: #summary) emptyTextDisplayMessage: 'Package summary (No package selected?)'. - - names leftSibling: dirtyFlags rightSibling: fileNames; scrollSiblings: true. - dirtyFlags rightSibling: names; scrollSiblings: true. - fileNames leftSibling: names; scrollSiblings: true. - - self layoutMorph - addMorph: upperRow proportionalHeight: 0.6; - addAdjusterAndMorph: self buildButtonPane fixedHeight: Theme current buttonPaneHeight; - addAdjusterAndMorph: summary fixedHeight: 60; - addAdjusterAndMorph: description proportionalHeight: 0.25; - addAdjusterAndMorph: self buildRequirementsPane proportionalHeight: 0.15. - self setLabel: 'Installed Packages'! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'KenD 12/31/2020 11:40:22' prior: 50519859! - buildRequirementsPane - - | requirements deleteReqButton "editReqButton" reqLayout buttonLayout updateReqButton | - requirements := PluggableListMorph - model: (PackageRequirementsList fromCodePackageList: model) - listGetter: #requirementsStrings - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - requirements color: Theme current textPane. - - deleteReqButton := PluggableButtonMorph - model: requirements model - action: #deleteSelectedRequirement - label: 'delete':: - setBalloonText: 'Remove selected Feature requirement'. - deleteReqButton color: self widgetsColor. - updateReqButton _ PluggableButtonMorph - model: requirements model - action: #updateSelectedRequirement - label: 'update':: - setBalloonText: 'Update requirement to current Feature revision'. - updateReqButton color: self widgetsColor. - - buttonLayout := LayoutMorph newRow. - buttonLayout - addMorph: deleteReqButton - layoutSpec: (LayoutSpec - proportionalWidth: 1.0 - proportionalHeight: 1.0 - offAxisEdgeWeight: #leftOrTop); - color: self widgetsColor quiteWhiter; - addMorph: updateReqButton - layoutSpec: (LayoutSpec - proportionalWidth: 1.0 - proportionalHeight: 1.0 - offAxisEdgeWeight: #leftOrTop); - color: self widgetsColor quiteWhiter. - - model when: #changed: send: #updateRequirementsFromPackageList to: requirements model. - self when: #changed: send: #updateRequirementsFromPackageList to: requirements model. - requirements model when: #changed: send: #verifyContents to: requirements. - self when: #changed: send: #verifyContents to: requirements. - - reqLayout := LayoutMorph newRow. - ^ reqLayout - doAdoptWidgetsColor; - addMorph: requirements - layoutSpec: (LayoutSpec - proportionalWidth: 0.8 - proportionalHeight: 1.0 - offAxisEdgeWeight: #leftOrTop); - addMorph: buttonLayout - layoutSpec: (LayoutSpec - proportionalWidth: 0.2 - proportionalHeight: 1.0 - offAxisEdgeWeight: #rightOrBottom); - color: `Color transparent`; - yourself - ! ! -!ChangeSorterWindow methodsFor: 'GUI building' stamp: 'KenD 1/1/2021 15:54:53' prior: 50547776! - buildMorphicWindow - "Add a set of change sorter views to the given top view offset by the given amount. To create a single change sorter, call this once with an offset of 0@0. To create a dual change sorter, call it twice with offsets of 0@0 and 0.5@0." - - | dirtyFlags changeSetList classList dirtyFlagsPane changeSetListPane classListPane - messageList upperPanes backColor labelBackground | - backColor _ self textBackgroundColor. - labelBackground _ Theme current background. - model myChangeSet ifNil: [ - self flag: #ojo. "Or whatever was last changed, or is top of list, or whatever" - model myChangeSet: ChangeSet changeSetForBaseSystem ]. - - dirtyFlags _ PluggableListMorph - model: model - listGetter: #changeSetDirtyFlags - indexGetter: nil - indexSetter: nil. - dirtyFlags color: backColor. - dirtyFlagsPane _ LayoutMorph newColumn - color: Theme current background; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: ' Unsaved?'); - addMorphUseAll: dirtyFlags. - - changeSetList _ (PluggableListMorphByItem - model: model - listGetter: #changeSetList - indexGetter: #currentCngSet - indexSetter: #showChangeSetNamed: - mainView: self - menuGetter: #changeSetMenu - keystrokeAction: #changeSetListKey:from:) - autoDeselect: false. - changeSetList color: backColor. - changeSetListPane _ LayoutMorph newColumn - color: labelBackground; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: 'Change Set name'); - addMorphUseAll: changeSetList. - - classList _ PluggableListMorphByItem - model: model - listGetter: #classList - indexGetter: #currentClassName - indexSetter: #currentClassName: - mainView: self - menuGetter: #classListMenu - keystrokeAction: #classListKey:from:. - classList color: backColor. - classListPane _ LayoutMorph newColumn - color: labelBackground; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: 'Classes'); - addMorphUseAll: classList. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: dirtyFlagsPane proportionalWidth: 0.13; - addAdjusterAndMorph: changeSetListPane proportionalWidth: 0.47; - addAdjusterAndMorph: classListPane proportionalWidth: 0.4. - - "Scroll Sibling Panes together." - changeSetList leftSibling: dirtyFlags; scrollSiblings: true. - dirtyFlags rightSibling: changeSetList; scrollSiblings: true. - - messageList _ PluggableListMorphByItem - model: model - listGetter: #messageList - indexGetter: #currentSelector - indexSetter: #currentSelector: - mainView: self - menuGetter: #messageMenu - keystrokeAction: #messageListKey:from:. - messageList color: backColor. - messageList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: 'Methods'); - addMorphUseAll: messageList. - - - self layoutMorph - addMorph: upperPanes proportionalHeight: 0.25; - addAdjusterAndMorph: messageList proportionalHeight: 0.2; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.55. - - self setLabel: model labelString! ! - -PluggableScrollPane subclass: #PluggableListMorph - instanceVariableNames: 'list getListSelector getIndexSelector setIndexSelector keystrokeActionSelector autoDeselect lastKeystrokeTime lastKeystrokes doubleClickSelector menuGetter mainView leftSibling rightSibling scrollSiblings' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #PluggableListMorph category: 'Morphic-Widgets' stamp: 'Install-4511-MultiListScroll-KenDickey-2020Dec31-11h39m-KenD.002.cs.st 1/7/2021 16:17:35'! -PluggableScrollPane subclass: #PluggableListMorph - instanceVariableNames: 'list getListSelector getIndexSelector setIndexSelector keystrokeActionSelector autoDeselect lastKeystrokeTime lastKeystrokes doubleClickSelector menuGetter mainView leftSibling rightSibling scrollSiblings' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4511-MultiListScroll-KenDickey-2020Dec31-11h39m-KenD.002.cs.st----! - -'From Cuis 5.0 [latest update: #4511] on 5 January 2021 at 10:59:27 am'! -!HandMorph methodsFor: 'events-processing' stamp: 'KenD 1/4/2021 11:09:49' prior: 50373838! - startMouseDispatch: aMouseEvent - - aMouseEvent isMouseOver ifTrue: [ - ^self mouseFocus - ifNotNil: [ mouseFocus handleFocusEvent: aMouseEvent ] - ifNil: [ owner dispatchEvent: aMouseEvent localPosition: aMouseEvent eventPosition ]]. - - "any mouse event but mouseOver" - lastMouseEvent _ aMouseEvent. - lastMouseEventTime _ Time localMillisecondClock. - - "Check for pending drag or double click operations." - mouseClickState ifNotNil: [ - (mouseClickState handleEvent: aMouseEvent from: self) ifTrue: [ - "Possibly dispatched #click: or something. Do not further process this event." - ^self mouseOverHandler processMouseOver: lastMouseEvent ]]. - - aMouseEvent isMove - ifTrue: [ - self morphPosition: aMouseEvent eventPosition. - self mouseFocus - ifNotNil: [ mouseFocus handleFocusEvent: aMouseEvent ] - ifNil: [ owner dispatchEvent: aMouseEvent localPosition: aMouseEvent eventPosition ] - ] ifFalse: [ - aMouseEvent isMouseScroll ifTrue: [ - owner dispatchEvent: aMouseEvent localPosition: aMouseEvent eventPosition - ] ifFalse: [ - "Issue a synthetic move event if we're not at the position of the event" - aMouseEvent eventPosition = self morphPosition ifFalse: [ - "Issue a mouse move event to make the receiver appear at the given position" - self startMouseDispatch: (MouseMoveEvent new - setType: #mouseMove - position: aMouseEvent eventPosition - buttons: aMouseEvent buttons - hand: self - stamp: aMouseEvent timeStamp) ]. - "Drop submorphs on button events" - self hasSubmorphs - ifTrue: [ - "Not if we are grabbing them" - mouseClickState ifNil: [ - "Want to drop on mouseUp, NOT mouseDown" - aMouseEvent isMouseUp ifTrue: [ - self dropMorphs: aMouseEvent ] - ] - ] ifFalse: [ - self mouseFocus - ifNotNil: [ mouseFocus handleFocusEvent: aMouseEvent ] - ifNil: [ owner dispatchEvent: aMouseEvent localPosition: aMouseEvent eventPosition ]]]]. - self mouseOverHandler processMouseOver: self lastMouseEvent! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'KenD 1/3/2021 13:44:18' prior: 50559742! - grabMorph: aMorph moveUnderHand: moveUnderHand - "Grab the given morph (i.e., add it to this hand and remove it from its current owner). - If moveUnderHand is requested or it seems neccesary anyway, move the grabbed morph under the hand." - - | grabbed positionInHandCoordinates tx | - self releaseMouseFocus. "Break focus" - grabbed _ aMorph. - aMorph owner ifNotNil: [ :o | grabbed _ o aboutToGrab: aMorph ]. - grabbed ifNil: [ ^ self ]. - grabbed _ grabbed aboutToBeGrabbedBy: self. - grabbed ifNil: [ ^ self ]. - - moveUnderHand - ifTrue: [ - "We can possibly do better, especially for non WidgetMorphs" - positionInHandCoordinates _ -30 @ -10. - grabbed isInWorld ifTrue: [ - grabbed displayBounds ifNotNil: [ :r | - positionInHandCoordinates _ (r extent // 2) negated ]]. - self - grabMorph: grabbed - delta: positionInHandCoordinates. - ^self ]. - - positionInHandCoordinates _ (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) - morphPositionInWorld - self morphPositionInWorld. - - tx _ GeometryTransformation identity. - aMorph withAllOwnersDo: [ :o | - tx _ o location composedWith: tx ]. - self withAllOwnersReverseDo: [ :o | - tx _ o location inverseTransformation composedWith: tx ]. - - self - grabMorph: grabbed - delta: positionInHandCoordinates. - - grabbed location: tx.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4512-HandMorph-fixes-KenDickey-2021Jan05-10h58m-KenD.001.cs.st----! - -'From Cuis 5.0 [latest update: #4512] on 5 January 2021 at 11:26:28 am'! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 1/5/2021 11:20:58'! - containsGlobalPoint: worldPoint - - "If not visible, won't contain any point at all." - | canvas | - self visible ifFalse: [ ^false ]. - - canvas _ self world canvas. - canvas isNil ifTrue: [ ^false ]. - (canvas morph: self isAtPoint: worldPoint) ifTrue: [ ^ true ]. - ^ false! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 1/5/2021 11:21:34' prior: 50537192! - fullContainsGlobalPoint: worldPoint - "Answer true if worldPoint is in some submorph, even if not inside our shape." - - "If not visible, won't contain any point at all." - | canvas | - self visible ifFalse: [ ^false ]. - - canvas _ self world canvas. - canvas isNil ifTrue: [ ^false ]. - (canvas morph: self isAtPoint: worldPoint) ifTrue: [ ^ true ]. - self submorphsDo: [ :m | - (m fullContainsGlobalPoint: worldPoint) ifTrue: [ ^ true ]]. - ^ false! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 1/5/2021 11:22:11' prior: 16851032! - doRecolor: event with: aHandle - "The mouse went down in the 'recolor' halo handle. Allow the user to change the color of the innerTarget" - - event hand obtainHalo: self. - (aHandle containsGlobalPoint: event eventPosition) - ifFalse: [ "only do it if mouse still in handle on mouse up" - self delete. - target addHalo: event] - ifTrue: [ - target changeColor]! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 1/5/2021 11:22:14' prior: 16851082! - maybeCollapse: event with: aHandle - "Ask hand to collapse my target if mouse comes up in it." - - event hand obtainHalo: self. - self delete. - (aHandle containsGlobalPoint: event eventPosition) - ifFalse: [ - target addHalo: event ] - ifTrue: [ - target collapse ]! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 1/5/2021 11:22:19' prior: 16851094! - maybeDismiss: event with: aHandle - "Ask hand to dismiss my target if mouse comes up in it." - - event hand obtainHalo: self. - (aHandle containsGlobalPoint: event eventPosition) - ifFalse: [ - self delete. - target addHalo: event] - ifTrue: [ - target resistsRemoval ifTrue: [ - (PopUpMenu - confirm: 'Really throw this away' - trueChoice: 'Yes' - falseChoice: 'Um, no, let me reconsider') ifFalse: [^ self]]. - - self delete. - target dismissViaHalo]! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 1/5/2021 11:22:25' prior: 50388484! - setDismissColor: event with: aHandle - "Called on mouseStillDown in the dismiss handle; set the color appropriately." - - | colorToUse | - event hand obtainHalo: self. - colorToUse _ (aHandle containsGlobalPoint: event eventPosition) - ifFalse: [ `Color red muchLighter` ] - ifTrue: [ `Color lightGray` ]. - aHandle color: colorToUse! ! -!LayoutAdjustingMorph methodsFor: 'stepping' stamp: 'jmv 1/5/2021 11:24:34' prior: 50535215 overrides: 50547622! - stepAt: millisecondSinceLast - "got the #mouseLeave: message" - | p | - hand ifNil: [ - Cursor currentCursor == self cursor ifTrue: [ Cursor defaultCursor activateCursor ]. - ^ self stopStepping ]. - "hasn't got the #mouseLeave: message (yet)" - p _ hand morphPosition. - hand lastMouseEvent mouseButton1Pressed - ifTrue: [ - self adjustOwnerAt: p. - (Preferences cheapWindowReframe or: [ millisecondSinceLast > 200]) ifTrue: [ - owner displayBounds newRectFrom: [ :f | - self adjustOwnerAt: Sensor mousePoint. - owner morphPosition extent: owner morphExtent ]]] - ifFalse: [ - self stopStepping. - "If the button was unpressed outside the morph (can happen if you try to go outside container), - we might not get the #mouseLeave: message" - (self containsGlobalPoint: p) ifFalse: [ - hand _ nil. - Cursor defaultCursor activateCursor ]].! ! -!MenuItemMorph methodsFor: 'events' stamp: 'jmv 1/5/2021 11:24:48' prior: 50341032! - activateOwnerMenu: evt - "Activate our owner menu; e.g., pass control to it" - owner ifNil: [ ^false ]. "not applicable" - (owner containsGlobalPoint: evt eventPosition) - ifFalse: [ ^false ]. - owner activate: evt. - ^true! ! -!MenuItemMorph methodsFor: 'events' stamp: 'jmv 1/5/2021 11:25:19' prior: 50408564! - activateSubmenu: event - "Activate our submenu; e.g., pass control to it" - - subMenu ifNil: [ ^false ]. "not applicable" - (subMenu containsGlobalPoint: event eventPosition) ifFalse: [^false]. - subMenu activate: event. - ^true! ! -!PluggableButtonMorph methodsFor: 'events' stamp: 'jmv 1/5/2021 11:22:49' prior: 16888243 overrides: 16874556! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - - isPressed _ false. - mouseIsOver _ false. - (actWhen == #buttonUp and: [ - self containsGlobalPoint: aMouseButtonEvent eventPosition ]) - ifTrue: [ self performAction ]. - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'events' stamp: 'jmv 1/5/2021 11:24:01' prior: 50436630 overrides: 16874556! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - - (self containsGlobalPoint: aMouseButtonEvent eventPosition) - ifTrue: [ - ((self upButtonPosition extent: ScrollBar scrollbarThickness) containsPoint: localEventPosition) - ifTrue: [ ^self stillActive; goUp ]. - ((self downButtonPosition extent: ScrollBar scrollbarThickness) containsPoint: localEventPosition) - ifTrue: [ ^self stillActive; goDown ]. - self selected: (localEventPosition y // self itemHeight) + self firstVisible. - completer insertSelected ] - ifFalse: [ self delete. completer menuClosed ]! ! -!KeyboardEvent methodsFor: 'actions' stamp: 'jmv 1/5/2021 11:23:35' prior: 50455368! - closeCurrentWindowOf: aMorph - - aMorph owningWindow ifNotNil: [ :w | - (w containsGlobalPoint: self eventPosition) - ifTrue: [ w delete ] ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4513-avoid-morphContainsPoint-JuanVuletich-2021Jan05-11h12m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4513] on 5 January 2021 at 11:35:12 am'! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 1/5/2021 11:33:43' prior: 50544297! - transferHalo: event from: formerHaloOwner - "Progressively transfer the halo to the next likely recipient" - - formerHaloOwner == self - ifFalse: [ ^self addHalo: event ]. - - event shiftPressed ifTrue: [ - "Pass it outwards" - owner ifNotNil: [ ^owner transferHalo: event from: formerHaloOwner ]. - "We're at the top level; just keep it on ourselves" - ^self ]. - - self submorphsDo: [ :m | - (m wantsHalo and: [ m fullContainsGlobalPoint: event eventPosition ]) - ifTrue: [ ^m transferHalo: event from: formerHaloOwner ]]. - "We're at the bottom most level; just keep halo on ourselves"! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4514-avoid-fullContainsPoint-JuanVuletich-2021Jan05-11h33m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4513] on 5 January 2021 at 11:46:24 am'! -!MorphicEvent methodsFor: 'accessing' stamp: 'jmv 1/5/2021 11:42:09'! - eventPosition - self subclassResponsibility! ! -!Morph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 11:44:31' prior: 50530975! - processMouseOver: aMouseEvent localPosition: localEventPosition - "System level event handling." - self hasMouseFocus ifTrue: [ - "Got this directly through #handleFocusEvent: so check explicitly" - ((self rejectsEvent: aMouseEvent) not and: [self fullContainsGlobalPoint: aMouseEvent eventPosition]) ifFalse: [ - ^self ]]. - aMouseEvent hand noticeMouseOver: self event: aMouseEvent. - "Open question: should any unhandled mouse move events be filtered out? (i.e. should mouseHover:localPosition: be called when a mouse button is pressed but the morph doesn't have mouse button handlers? Essentially, what are the limits of what is considered 'hovering'?" - (self handlesMouseHover and: [aMouseEvent wasHandled not]) ifTrue: [ - self - mouseHover: aMouseEvent - localPosition: localEventPosition ].! ! -!MenuMorph methodsFor: 'events' stamp: 'jmv 1/5/2021 11:43:53' prior: 16866892 overrides: 16874541! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - "Handle a mouse down event." - (stayUp or: [ self fullContainsGlobalPoint: aMouseButtonEvent eventPosition ]) - ifFalse: [ ^self deleteIfPopUp: aMouseButtonEvent ]. "click outside" - - "Grab the menu and drag it to some other place - This is reimplemented here because we handle the event, and if the following lines are commented, a menu can't be grabbed with the hand. This is not nice and shouldn't be needed" - self isSticky ifTrue: [ ^self ]. - aMouseButtonEvent hand grabMorph: self! ! -!MenuMorph methodsFor: 'events' stamp: 'jmv 1/5/2021 11:44:12' prior: 16866911 overrides: 16874556! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - "Handle a mouse up event. - Note: This might be sent from a modal shell." - (self fullContainsGlobalPoint: aMouseButtonEvent eventPosition) ifFalse:[ - "Mouse up outside. Release eventual focus and delete if pop up." - aMouseButtonEvent hand ifNotNil: [ :h | h releaseMouseFocus: self ]. - ^ self deleteIfPopUp: aMouseButtonEvent ]. - stayUp ifFalse: [ - "Still in pop-up transition; keep focus" - aMouseButtonEvent hand newMouseFocus: self ]! ! -!MorphicEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 11:44:50' prior: 50531017! - dispatchWith: aMorph localPosition: positionInAMorph - "Dispatch me. The event will be passed to the front-most visible submorph that contains the position wrt. to the event." - | handledByInner eventPositionInChild | - - "Try to get out quickly" - (aMorph fullContainsGlobalPoint: self eventPosition) - ifFalse: [ ^#rejected ]. - - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - - "Check for being inside the receiver" - (handledByInner or: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: self eventPosition] ]) - ifTrue: [ ^ self sentTo: aMorph localPosition: positionInAMorph ]. - - ^ #rejected! ! -!DropEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 11:39:39' prior: 50531051 overrides: 50562736! - dispatchWith: aMorph localPosition: positionInAMorph - "Drop is done on the innermost target that accepts it." - | eventPositionInChild dropped | - - "Try to get out quickly" - (aMorph fullContainsGlobalPoint: position) - ifFalse: [ ^#rejected ]. - - "Go looking if any of our submorphs wants it" - aMorph submorphsDo: [ :eachChild | - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ - ^self ]]. - - (aMorph allowsMorphDrop and: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position] ]) - ifTrue: [ - "Do a symmetric check if both morphs like each other" - dropped _ self contents. - ((aMorph wantsDroppedMorph: dropped event: self) "I want her" - and: [dropped wantsToBeDroppedInto: aMorph]) "she wants me" - ifTrue: [ - ^ self sentTo: aMorph localPosition: positionInAMorph ]]. - ^#rejected! ! -!DropFilesEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 11:40:08' prior: 50531084 overrides: 50562736! - dispatchWith: aMorph localPosition: positionInAMorph - "Drop is done on the innermost target that accepts it." - - | eventPositionInChild | - - "Try to get out quickly" - (aMorph fullContainsGlobalPoint: position) ifFalse: [ ^#rejected ]. - - "Go looking if any of our submorphs wants it" - aMorph submorphsDo: [ :eachChild | - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ ^self ]]. - - (aMorph allowsFilesDrop and: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position] ]) - ifTrue: [^ self sentTo: aMorph localPosition: positionInAMorph ]. - - ^#rejected! ! -!KeyboardEvent methodsFor: 'actions' stamp: 'jmv 1/5/2021 11:39:47' prior: 50562619! - closeCurrentWindowOf: aMorph - - aMorph owningWindow ifNotNil: [ :w | - (w containsGlobalPoint: position) - ifTrue: [ w delete ] ].! ! -!MouseButtonEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 11:45:08' prior: 50531110 overrides: 50562736! - dispatchWith: aMorph localPosition: positionInAMorph - "Find the appropriate receiver for the event and let it handle it. Default rules: - * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. - * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. - * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. - * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. - " - | aMorphHandlesIt grabAMorph handledByInner eventPositionInChild | - "Only for MouseDown" - self isMouseDown ifFalse: [ - ^super dispatchWith: aMorph localPosition: positionInAMorph ]. - - "Try to get out quickly" - (aMorph fullContainsGlobalPoint: position) - ifFalse: [ ^#rejected ]. - - "Install the prospective handler for the receiver" - aMorphHandlesIt _ false. - grabAMorph _ false. - self mouseButton3Pressed - ifTrue: [ - (eventHandler isNil or: [ eventHandler isWorldMorph or: [ - self shiftPressed or: [ aMorph is: #HaloMorph ]]]) - ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]] - ifFalse: [ - (aMorph handlesMouseDown: self) ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]. - "If button 1, and both aMorph and the owner allows grabbing with the hand (to initiate drag & drop), so be it." - self mouseButton1Pressed ifTrue: [ - aMorph owner ifNotNil: [ :o | - (o allowsSubmorphDrag and: [ aMorph isSticky not ]) ifTrue: [ - grabAMorph _ true ]]]]. - - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - - (handledByInner or: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position] ]) ifTrue: [ - "aMorph is in the top-most unlocked, visible morph in the chain." - aMorphHandlesIt - ifTrue: [ ^self sentTo: aMorph localPosition: positionInAMorph ] - ifFalse: [ - (grabAMorph and: [ handledByInner not ]) ifTrue: [ - self hand - waitForClicksOrDrag: aMorph event: self - dragSel: (Preferences clickGrabsMorphs ifFalse: [#dragEvent:localPosition:]) - clkSel: (Preferences clickGrabsMorphs ifTrue: [#dragEvent:localPosition:]). - "false ifTrue: [ self hand grabMorph: aMorph ]." - Preferences clickGrabsMorphs ifFalse: [aMorph activateWindow]. - self wasHandled: true. - ^self ]]]. - - handledByInner ifTrue: [ ^self ]. - "Mouse was not on aMorph nor any of its children" - ^ #rejected! ! -!MouseScrollEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 11:45:22' prior: 50531210 overrides: 50562736! - dispatchWith: aMorph localPosition: positionInAMorph - "Find the appropriate receiver for the event and let it handle it. Default rules: - * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. - * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. - * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. - * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. - " - "Try to get out quickly" - | aMorphHandlesIt handledByInner eventPositionInChild focus| - focus := self hand keyboardFocus. - "FIXME - this works in all tested cases but one: when the window directly under the mouse doesn't have keyboard focus (i.e. a Transcript window)" - ((aMorph fullContainsGlobalPoint: position) and: [(aMorph = focus) or: [focus notNil and: [aMorph notNil and: [focus hasOwner: aMorph]]]]) ifFalse: [ ^ #rejected ]. - "Install the prospective handler for the receiver" - aMorphHandlesIt _ false. - (aMorph handlesMouseScroll: self) ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]. - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild - dispatchEvent: self - localPosition: eventPositionInChild) == #rejected ifFalse: [ "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - (handledByInner or: [ - (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position]]) ifTrue: [ - "aMorph is in the top-most unlocked, visible morph in the chain." - aMorphHandlesIt ifTrue: [ ^ self - sentTo: aMorph - localPosition: positionInAMorph ]]. - handledByInner ifTrue: [ ^ self ]. - "Mouse was not on aMorph nor any of its children" - ^ #rejected.! ! - -Morph removeSelector: #fullContainsPoint:! - -!methodRemoval: Morph #fullContainsPoint: stamp: 'Install-4515-remove-fullContainsPoint-JuanVuletich-2021Jan05-11h35m-jmv.001.cs.st 1/7/2021 16:17:36'! -fullContainsPoint: aLocalPoint - "Answer true even if aLocalPoint is in some submorph, regardless of being also inside our shape." - - "If not visible, won't contain any point at all." - self visible ifFalse: [ ^false ]. - - ^self fullContainsGlobalPoint: (self externalizeToWorld: aLocalPoint).! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4515-remove-fullContainsPoint-JuanVuletich-2021Jan05-11h35m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4515] on 5 January 2021 at 12:53:31 pm'! -!Morph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 11:51:09'! - processDropFiles: aDropFilesEvent - "Handle a dropping file." - - aDropFilesEvent wasHandled ifTrue: [ ^self ]. - - aDropFilesEvent wasHandled: true. - self dropFiles: aDropFilesEvent! ! -!Morph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 11:50:19'! - processDropMorph: aDropEvent - "Handle a dropping morph." - | aMorph | - - aDropEvent wasHandled ifTrue: [ ^self ]. "Do it just once, for one drop destination" - - aMorph _ aDropEvent contents. - aDropEvent wasHandled: true. - self acceptDroppingMorph: aMorph event: aDropEvent. - aMorph justDroppedInto: self event: aDropEvent! ! -!Morph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 11:52:40'! - processKeyDown: aKeyboardEvent - "System level event handling." - - aKeyboardEvent wasHandled ifTrue: [^self]. - self handlesKeyboard ifFalse: [^self]. - aKeyboardEvent wasHandled: true. - ^self keyDown: aKeyboardEvent! ! -!Morph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 11:52:57'! - processKeyUp: aKeyboardEvent - "System level event handling." - - aKeyboardEvent wasHandled ifTrue: [^self]. - self handlesKeyboard ifFalse: [^self]. - aKeyboardEvent wasHandled: true. - ^self keyUp: aKeyboardEvent! ! -!Morph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 11:51:54'! - processKeystroke: aKeyboardEvent - "System level event handling." - - aKeyboardEvent wasHandled ifTrue: [^self]. - self handlesKeyboard ifFalse: [^self]. - aKeyboardEvent wasHandled: true. - ^self keyStroke: aKeyboardEvent! ! -!Morph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 11:53:33'! - processUnknownEvent: aMorphicEvent - "An event of an unknown type was sent to the receiver. What shall we do?!!" - - Smalltalk beep. - aMorphicEvent printString displayAt: `0@0`. - aMorphicEvent wasHandled: true! ! -!Morph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 12:03:21'! - processWindowEvent: aWindowEvent - "Handle an event concerning our host window" - - aWindowEvent wasHandled ifTrue: [^self]. "not interested" - (self wantsWindowEvent: aWindowEvent) ifFalse: [^self]. - aWindowEvent wasHandled: true. - self windowEvent: aWindowEvent. -! ! -!InnerTextMorph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 11:51:44' overrides: 50563070! - processKeystroke: aKeyboardEvent - "System level event handling." - - aKeyboardEvent wasHandled ifTrue:[^self]. - self handlesKeyboard ifFalse: [^ self]. - aKeyboardEvent wasHandled: true. - self keyStroke: aKeyboardEvent! ! -!MorphicEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 11:53:47'! - sendEventTo: aMorph - "Dispatch the receiver into aMorph" - - ^ aMorph processUnknownEvent: self! ! -!DropEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 11:50:38' overrides: 50563111! - sendEventTo: aMorph - "Dispatch the receiver into aMorph" - - ^aMorph processDropMorph: self! ! -!DropFilesEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 11:51:15' overrides: 50563111! - sendEventTo: aMorph - "Dispatch the receiver into aMorph" - - ^aMorph processDropFiles: self! ! -!KeyboardEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 11:53:19' overrides: 50563111! - sendEventTo: aMorph - "Dispatch the receiver into anObject" - type == #keystroke ifTrue: [ - self isFindClassShortcut - ifTrue: [ ^ BrowserWindow findClass]. - self isCloseWindowShortcut - ifTrue: [ ^ self closeCurrentWindowOf: aMorph ]. - ^ aMorph processKeystroke: self ]. - type == #keyDown ifTrue: [ - ^ aMorph processKeyDown: self ]. - type == #keyUp ifTrue: [ - ^ aMorph processKeyUp: self ]. - ^ super sendEventTo: aMorph.! ! -!MouseEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:02:08' overrides: 50563111! - sendEventTo: aMorph - "Dispatch the receiver into aMorph" - - type == #mouseOver ifTrue: [ - ^aMorph processMouseOver: self localPosition: (aMorph internalizeFromWorld: position) ]. - type == #mouseEnter ifTrue: [ - ^ aMorph processMouseEnter: self localPosition: (aMorph internalizeFromWorld: position) ]. - type == #mouseLeave ifTrue: [ - ^aMorph processMouseLeave: self localPosition: (aMorph internalizeFromWorld: position) ]. - ^ super sendEventTo: aMorph! ! -!MouseButtonEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:00:01' overrides: 50563146! - sendEventTo: aMorph - "Dispatch the receiver into anObject" - - type == #mouseDown ifTrue: [ - ^aMorph processMouseDown: self localPosition: (aMorph internalizeFromWorld: position) ]. - type == #mouseUp ifTrue: [ - ^aMorph processMouseUp: self localPosition: (aMorph internalizeFromWorld: position) ]. - ^super sendEventTo: aMorph! ! -!MouseMoveEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:02:43' overrides: 50563146! - sendEventTo: aMorph - "Dispatch the receiver into anObject" - - type == #mouseMove ifTrue: [ - ^aMorph processMouseMove: self localPosition: (aMorph internalizeFromWorld: position) ]. - ^ super sendEventTo: aMorph! ! -!MouseScrollEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:03:02' overrides: 50563146! - sendEventTo: aMorph - "Dispatch the receiver into anObject" - ^ aMorph - processMouseScroll: self - localPosition: (aMorph internalizeFromWorld: position).! ! -!WindowEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:03:28' overrides: 50563111! - sendEventTo: aMorph - "Dispatch the receiver into anObject" - - ^ aMorph processWindowEvent: self! ! -!Morph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 12:04:44' prior: 16874935! - handleFocusEvent: aMorphicEvent - "Handle the given event. This message is sent if the receiver currently has the focus and is therefore receiving events directly from some hand." - - ^aMorphicEvent sendEventTo: self! ! -!MenuMorph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 12:04:29' prior: 50341085 overrides: 50563202! - handleFocusEvent: aMorphicEvent - "Handle focus events. Valid menu transitions are determined based on the menu currently holding the focus after the mouse went down on one of its children." - | eventPositionInOurCoordinates | - eventPositionInOurCoordinates _ self internalizeFromWorld: aMorphicEvent eventPosition. - - self dispatchEvent: aMorphicEvent localPosition: eventPositionInOurCoordinates. - - "Need to handle keyboard input if we have the focus." - aMorphicEvent isKeyboard ifTrue: [ ^ aMorphicEvent sendEventTo: self ]. - - "We need to handle button clicks outside and transitions to local popUps so throw away everything else" - (aMorphicEvent isMouseOver or: [aMorphicEvent isMouse not]) ifTrue: [ ^self ]. - "What remains are mouse buttons and moves" - aMorphicEvent isMove ifFalse: [ ^ aMorphicEvent sendEventTo: self ]. "handle clicks outside by regular means" - "Now it's getting tricky. On #mouseMove we might transfer control to *either* the currently active submenu or the pop up owner, if any. Since the active sub menu is always displayed upfront check it first." - selectedItem ifNotNil:[(selectedItem activateSubmenu: aMorphicEvent) ifTrue: [^self]]. - "Note: The following does not traverse upwards but it's the best I can do for now" - popUpOwner ifNotNil:[(popUpOwner activateOwnerMenu: aMorphicEvent) ifTrue: [^self]].! ! -!MorphicEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:04:55' prior: 50562736! - dispatchWith: aMorph localPosition: positionInAMorph - "Dispatch me. The event will be passed to the front-most visible submorph that contains the position wrt. to the event." - | handledByInner eventPositionInChild | - - "Try to get out quickly" - (aMorph fullContainsGlobalPoint: self eventPosition) - ifFalse: [ ^#rejected ]. - - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - - "Check for being inside the receiver" - (handledByInner or: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: self eventPosition] ]) - ifTrue: [ ^ self sendEventTo: aMorph ]. - - ^ #rejected! ! -!DropEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:03:56' prior: 50562770 overrides: 50563258! - dispatchWith: aMorph localPosition: positionInAMorph - "Drop is done on the innermost target that accepts it." - | eventPositionInChild dropped | - - "Try to get out quickly" - (aMorph fullContainsGlobalPoint: position) - ifFalse: [ ^#rejected ]. - - "Go looking if any of our submorphs wants it" - aMorph submorphsDo: [ :eachChild | - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ - ^self ]]. - - (aMorph allowsMorphDrop and: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position] ]) - ifTrue: [ - "Do a symmetric check if both morphs like each other" - dropped _ self contents. - ((aMorph wantsDroppedMorph: dropped event: self) "I want her" - and: [dropped wantsToBeDroppedInto: aMorph]) "she wants me" - ifTrue: [ - ^ self sendEventTo: aMorph ]]. - ^#rejected! ! -!DropFilesEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:04:05' prior: 50562803 overrides: 50563258! - dispatchWith: aMorph localPosition: positionInAMorph - "Drop is done on the innermost target that accepts it." - - | eventPositionInChild | - - "Try to get out quickly" - (aMorph fullContainsGlobalPoint: position) ifFalse: [ ^#rejected ]. - - "Go looking if any of our submorphs wants it" - aMorph submorphsDo: [ :eachChild | - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ ^self ]]. - - (aMorph allowsFilesDrop and: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position] ]) - ifTrue: [^ self sendEventTo: aMorph ]. - - ^#rejected! ! -!MouseButtonEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:05:04' prior: 50562836 overrides: 50563258! - dispatchWith: aMorph localPosition: positionInAMorph - "Find the appropriate receiver for the event and let it handle it. Default rules: - * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. - * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. - * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. - * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. - " - | aMorphHandlesIt grabAMorph handledByInner eventPositionInChild | - "Only for MouseDown" - self isMouseDown ifFalse: [ - ^super dispatchWith: aMorph localPosition: positionInAMorph ]. - - "Try to get out quickly" - (aMorph fullContainsGlobalPoint: position) - ifFalse: [ ^#rejected ]. - - "Install the prospective handler for the receiver" - aMorphHandlesIt _ false. - grabAMorph _ false. - self mouseButton3Pressed - ifTrue: [ - (eventHandler isNil or: [ eventHandler isWorldMorph or: [ - self shiftPressed or: [ aMorph is: #HaloMorph ]]]) - ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]] - ifFalse: [ - (aMorph handlesMouseDown: self) ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]. - "If button 1, and both aMorph and the owner allows grabbing with the hand (to initiate drag & drop), so be it." - self mouseButton1Pressed ifTrue: [ - aMorph owner ifNotNil: [ :o | - (o allowsSubmorphDrag and: [ aMorph isSticky not ]) ifTrue: [ - grabAMorph _ true ]]]]. - - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - - (handledByInner or: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position] ]) ifTrue: [ - "aMorph is in the top-most unlocked, visible morph in the chain." - aMorphHandlesIt - ifTrue: [ ^self sendEventTo: aMorph ] - ifFalse: [ - (grabAMorph and: [ handledByInner not ]) ifTrue: [ - self hand - waitForClicksOrDrag: aMorph event: self - dragSel: (Preferences clickGrabsMorphs ifFalse: [#dragEvent:localPosition:]) - clkSel: (Preferences clickGrabsMorphs ifTrue: [#dragEvent:localPosition:]). - "false ifTrue: [ self hand grabMorph: aMorph ]." - Preferences clickGrabsMorphs ifFalse: [aMorph activateWindow]. - self wasHandled: true. - ^self ]]]. - - handledByInner ifTrue: [ ^self ]. - "Mouse was not on aMorph nor any of its children" - ^ #rejected! ! -!MouseScrollEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:06:25' prior: 50562936 overrides: 50563258! - dispatchWith: aMorph localPosition: positionInAMorph - "Find the appropriate receiver for the event and let it handle it. Default rules: - * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. - * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. - * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. - * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. - " - "Try to get out quickly" - | aMorphHandlesIt handledByInner eventPositionInChild focus| - focus := self hand keyboardFocus. - "FIXME - this works in all tested cases but one: when the window directly under the mouse doesn't have keyboard focus (i.e. a Transcript window)" - ((aMorph fullContainsGlobalPoint: position) and: [(aMorph = focus) or: [focus notNil and: [aMorph notNil and: [focus hasOwner: aMorph]]]]) ifFalse: [ ^ #rejected ]. - "Install the prospective handler for the receiver" - aMorphHandlesIt _ false. - (aMorph handlesMouseScroll: self) ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]. - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild - dispatchEvent: self - localPosition: eventPositionInChild) == #rejected ifFalse: [ "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - (handledByInner or: [ - (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position]]) ifTrue: [ - "aMorph is in the top-most unlocked, visible morph in the chain." - aMorphHandlesIt ifTrue: [ ^ self sendEventTo: aMorph ]]. - handledByInner ifTrue: [ ^ self ]. - "Mouse was not on aMorph nor any of its children" - ^ #rejected.! ! -!WindowEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:06:35' prior: 16945210 overrides: 50563258! - dispatchWith: aMorph localPosition: positionInAMorph - "Host window events do not have a position and are only dispatched to the World" - - aMorph isWorldMorph ifFalse: [ ^#rejected ]. - self wasHandled ifTrue: [ ^self ]. - ^ self sendEventTo: aMorph! ! -!MouseOverHandler methodsFor: 'event handling' stamp: 'jmv 1/5/2021 12:06:07' prior: 16879290! - processMouseOver: aMouseEvent - "Re-establish the z-order for all morphs wrt the given event" - - | hand focus evt | - hand := aMouseEvent hand. - leftMorphs := mouseOverMorphs asIdentitySet. - "Assume some coherence for the number of objects in over list" - overMorphs := WriteStream on: (Array new: leftMorphs size). - enteredMorphs := WriteStream on: #(). - "Now go looking for eventual mouse overs" - hand startEventDispatch: aMouseEvent asMouseOver. - "Get out early if there's no change" - (leftMorphs isNil or: [ "Should never happen, but it could if you halt during layout." - (leftMorphs isEmpty and: [enteredMorphs position = 0])]) - ifTrue: [^leftMorphs := enteredMorphs := overMorphs := nil]. - focus := hand mouseFocus. - "Send #mouseLeave as appropriate" - evt := aMouseEvent asMouseLeave. - "Keep the order of the left morphs by recreating it from the mouseOverMorphs" - leftMorphs size > 1 - ifTrue: [leftMorphs := mouseOverMorphs select: [:m | leftMorphs includes: m]]. - leftMorphs do: [ :m | - (m == focus or: [m hasOwner: focus]) - ifTrue: [ - evt sendEventTo: m ] - ifFalse: [overMorphs nextPut: m]]. - "Send #mouseEnter as appropriate" - evt := aMouseEvent asMouseEnter. - enteredMorphs ifNil: [ - "inform: was called in handleEvent:" - ^ leftMorphs := enteredMorphs := overMorphs := nil]. - enteredMorphs := enteredMorphs contents. - enteredMorphs reverseDo: [ :m | - (m == focus or: [m hasOwner: focus]) - ifTrue: [ - evt sendEventTo: m ]]. - "And remember the over list" - overMorphs ifNil: [ - "inform: was called in handleEvent:" - ^leftMorphs := enteredMorphs := overMorphs := nil]. - mouseOverMorphs := overMorphs contents. - leftMorphs := enteredMorphs := overMorphs := nil! ! - -WindowEvent removeSelector: #sentTo:localPosition:! - -!methodRemoval: WindowEvent #sentTo:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:17:36'! -sentTo: aMorph localPosition: positionInAMorph - "Dispatch the receiver into anObject" - - ^ aMorph processWindowEvent: self localPosition: positionInAMorph! - -MouseScrollEvent removeSelector: #sentTo:localPosition:! - -!methodRemoval: MouseScrollEvent #sentTo:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:17:36'! -sentTo: aMorph localPosition: positionInAMorph - "Dispatch the receiver into anObject" - ^ aMorph - processMouseScroll: self - localPosition: positionInAMorph.! - -MouseMoveEvent removeSelector: #sentTo:localPosition:! - -!methodRemoval: MouseMoveEvent #sentTo:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:17:36'! -sentTo: aMorph localPosition: positionInAMorph - "Dispatch the receiver into anObject" - - type == #mouseMove ifTrue: [ - ^aMorph processMouseMove: self localPosition: positionInAMorph ]. - ^ super sentTo: aMorph localPosition: positionInAMorph! - -MouseButtonEvent removeSelector: #sentTo:localPosition:! - -!methodRemoval: MouseButtonEvent #sentTo:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:17:36'! -sentTo: aMorph localPosition: positionInAMorph - "Dispatch the receiver into anObject" - - type == #mouseDown ifTrue: [ - ^aMorph processMouseDown: self localPosition: positionInAMorph ]. - type == #mouseUp ifTrue: [ - ^aMorph processMouseUp: self localPosition: positionInAMorph ]. - ^super sentTo: aMorph localPosition: positionInAMorph! - -MouseEvent removeSelector: #sentTo:localPosition:! - -!methodRemoval: MouseEvent #sentTo:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:17:36'! -sentTo: aMorph localPosition: positionInAMorph - "Dispatch the receiver into aMorph" - - type == #mouseOver ifTrue: [ - ^aMorph processMouseOver: self localPosition: positionInAMorph ]. - type == #mouseEnter ifTrue: [ - ^ aMorph processMouseEnter: self localPosition: positionInAMorph ]. - type == #mouseLeave ifTrue: [ - ^aMorph processMouseLeave: self localPosition: positionInAMorph ]. - ^ super sentTo: aMorph localPosition: positionInAMorph! - -KeyboardEvent removeSelector: #sentTo:localPosition:! - -!methodRemoval: KeyboardEvent #sentTo:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:17:36'! -sentTo: aMorph localPosition: positionInAMorph - "Dispatch the receiver into anObject" - type == #keystroke ifTrue: [ - self isFindClassShortcut - ifTrue: [ ^ BrowserWindow findClass]. - self isCloseWindowShortcut - ifTrue: [ ^ self closeCurrentWindowOf: aMorph ]. - ^ aMorph - processKeystroke: self - localPosition: positionInAMorph ]. - type == #keyDown ifTrue: [ - ^ aMorph - processKeyDown: self - localPosition: positionInAMorph ]. - type == #keyUp ifTrue: [ - ^ aMorph - processKeyUp: self - localPosition: positionInAMorph ]. - ^ super - sentTo: aMorph - localPosition: positionInAMorph.! - -DropFilesEvent removeSelector: #sentTo:localPosition:! - -!methodRemoval: DropFilesEvent #sentTo:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:17:36'! -sentTo: aMorph localPosition: positionInAMorph - "Dispatch the receiver into aMorph" - - ^aMorph processDropFiles: self localPosition: positionInAMorph! - -DropEvent removeSelector: #sentTo:localPosition:! - -!methodRemoval: DropEvent #sentTo:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:17:36'! -sentTo: aMorph localPosition: positionInAMorph - "Dispatch the receiver into aMorph" - - ^aMorph processDropMorph: self localPosition: positionInAMorph! - -MorphicEvent removeSelector: #sentTo:localPosition:! - -!methodRemoval: MorphicEvent #sentTo:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:17:36'! -sentTo: aMorph localPosition: positionInAMorph - "Dispatch the receiver into aMorph" - - ^ aMorph processUnknownEvent: self localPosition: positionInAMorph! - -InnerTextMorph removeSelector: #processKeystroke:localPosition:! - -!methodRemoval: InnerTextMorph #processKeystroke:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:17:36'! -processKeystroke: aKeyboardEvent localPosition: localEventPosition - "System level event handling." - "localEventPosition?????" - - aKeyboardEvent wasHandled ifTrue:[^self]. - self handlesKeyboard ifFalse: [^ self]. - aKeyboardEvent wasHandled: true. - self keyStroke: aKeyboardEvent! - -Morph removeSelector: #processWindowEvent:localPosition:! - -!methodRemoval: Morph #processWindowEvent:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:17:36'! -processWindowEvent: aWindowEvent localPosition: localEventPosition - "Handle an event concerning our host window" - - aWindowEvent wasHandled ifTrue: [^self]. "not interested" - (self wantsWindowEvent: aWindowEvent) ifFalse: [^self]. - aWindowEvent wasHandled: true. - self windowEvent: aWindowEvent. -! - -Morph removeSelector: #processKeyDown:localPosition:! - -!methodRemoval: Morph #processKeyDown:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:17:36'! -processKeyDown: aKeyboardEvent localPosition: localEventPosition - "System level event handling." - "localEventPosition?????" - - aKeyboardEvent wasHandled ifTrue: [^self]. - self handlesKeyboard ifFalse: [^self]. - aKeyboardEvent wasHandled: true. - ^self keyDown: aKeyboardEvent! - -Morph removeSelector: #processDropFiles:localPosition:! - -!methodRemoval: Morph #processDropFiles:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:17:36'! -processDropFiles: aDropFilesEvent localPosition: localEventPosition - "Handle a dropping file." - - aDropFilesEvent wasHandled ifTrue: [ ^self ]. - - aDropFilesEvent wasHandled: true. - self dropFiles: aDropFilesEvent! - -Morph removeSelector: #processDropMorph:localPosition:! - -!methodRemoval: Morph #processDropMorph:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:17:36'! -processDropMorph: aDropEvent localPosition: localEventPosition - "Handle a dropping morph." - | aMorph | - - aDropEvent wasHandled ifTrue: [ ^self ]. "Do it just once, for one drop destination" - - aMorph _ aDropEvent contents. - aDropEvent wasHandled: true. - self acceptDroppingMorph: aMorph event: aDropEvent. - aMorph justDroppedInto: self event: aDropEvent! - -Morph removeSelector: #processKeystroke:localPosition:! - -!methodRemoval: Morph #processKeystroke:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:17:36'! -processKeystroke: aKeyboardEvent localPosition: localEventPosition - "System level event handling." - "localEventPosition?????" - - aKeyboardEvent wasHandled ifTrue: [^self]. - self handlesKeyboard ifFalse: [^self]. - aKeyboardEvent wasHandled: true. - ^self keyStroke: aKeyboardEvent! - -Morph removeSelector: #processKeyUp:localPosition:! - -!methodRemoval: Morph #processKeyUp:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:17:36'! -processKeyUp: aKeyboardEvent localPosition: localEventPosition - "System level event handling." - "localEventPosition?????" - - aKeyboardEvent wasHandled ifTrue: [^self]. - self handlesKeyboard ifFalse: [^self]. - aKeyboardEvent wasHandled: true. - ^self keyUp: aKeyboardEvent! - -Morph removeSelector: #processUnknownEvent:localPosition:! - -!methodRemoval: Morph #processUnknownEvent:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:17:36'! -processUnknownEvent: aMorphicEvent localPosition: localEventPosition - "An event of an unknown type was sent to the receiver. What shall we do?!!" - - Smalltalk beep. - aMorphicEvent printString displayAt: `0@0`. - aMorphicEvent wasHandled: true! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4513] on 5 January 2021 at 12:15:13 pm'! -!Morph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 12:08:39'! - dispatchEvent: aMorphicEvent - "This is the central entry for dispatching events in morphic. Given some event, find the right receiver and let him handle it." - - ^ (self rejectsEventFully: aMorphicEvent) - ifTrue: [ #rejected ] - ifFalse: [ aMorphicEvent dispatchWith: self ]! ! -!MorphicEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:09:46'! - dispatchWith: aMorph - "Dispatch me. The event will be passed to the front-most visible submorph that contains the position wrt. to the event." - | handledByInner | - - "Try to get out quickly" - (aMorph fullContainsGlobalPoint: self eventPosition) - ifFalse: [ ^#rejected ]. - - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - (eachChild dispatchEvent: self) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - - "Check for being inside the receiver" - (handledByInner or: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: self eventPosition] ]) - ifTrue: [ ^ self sendEventTo: aMorph ]. - - ^ #rejected! ! -!DropEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:08:46' overrides: 50563868! - dispatchWith: aMorph - "Drop is done on the innermost target that accepts it." - | dropped | - - "Try to get out quickly" - (aMorph fullContainsGlobalPoint: position) - ifFalse: [ ^#rejected ]. - - "Go looking if any of our submorphs wants it" - aMorph submorphsDo: [ :eachChild | - (eachChild dispatchEvent: self) == #rejected ifFalse: [ - ^self ]]. - - (aMorph allowsMorphDrop and: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position] ]) - ifTrue: [ - "Do a symmetric check if both morphs like each other" - dropped _ self contents. - ((aMorph wantsDroppedMorph: dropped event: self) "I want her" - and: [dropped wantsToBeDroppedInto: aMorph]) "she wants me" - ifTrue: [ - ^ self sendEventTo: aMorph ]]. - ^#rejected! ! -!DropFilesEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:09:18' overrides: 50563868! - dispatchWith: aMorph - "Drop is done on the innermost target that accepts it." - - "Try to get out quickly" - (aMorph fullContainsGlobalPoint: position) ifFalse: [ ^#rejected ]. - - "Go looking if any of our submorphs wants it" - aMorph submorphsDo: [ :eachChild | - (eachChild dispatchEvent: self) == #rejected ifFalse: [ ^self ]]. - - (aMorph allowsFilesDrop and: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position] ]) - ifTrue: [^ self sendEventTo: aMorph ]. - - ^#rejected! ! -!MouseButtonEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:10:27' overrides: 50563868! - dispatchWith: aMorph - "Find the appropriate receiver for the event and let it handle it. Default rules: - * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. - * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. - * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. - * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. - " - | aMorphHandlesIt grabAMorph handledByInner | - "Only for MouseDown" - self isMouseDown ifFalse: [ - ^super dispatchWith: aMorph ]. - - "Try to get out quickly" - (aMorph fullContainsGlobalPoint: position) - ifFalse: [ ^#rejected ]. - - "Install the prospective handler for the receiver" - aMorphHandlesIt _ false. - grabAMorph _ false. - self mouseButton3Pressed - ifTrue: [ - (eventHandler isNil or: [ eventHandler isWorldMorph or: [ - self shiftPressed or: [ aMorph is: #HaloMorph ]]]) - ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]] - ifFalse: [ - (aMorph handlesMouseDown: self) ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]. - "If button 1, and both aMorph and the owner allows grabbing with the hand (to initiate drag & drop), so be it." - self mouseButton1Pressed ifTrue: [ - aMorph owner ifNotNil: [ :o | - (o allowsSubmorphDrag and: [ aMorph isSticky not ]) ifTrue: [ - grabAMorph _ true ]]]]. - - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - (eachChild dispatchEvent: self) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - - (handledByInner or: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position] ]) ifTrue: [ - "aMorph is in the top-most unlocked, visible morph in the chain." - aMorphHandlesIt - ifTrue: [ ^self sendEventTo: aMorph ] - ifFalse: [ - (grabAMorph and: [ handledByInner not ]) ifTrue: [ - self hand - waitForClicksOrDrag: aMorph event: self - dragSel: (Preferences clickGrabsMorphs ifFalse: [#dragEvent:localPosition:]) - clkSel: (Preferences clickGrabsMorphs ifTrue: [#dragEvent:localPosition:]). - "false ifTrue: [ self hand grabMorph: aMorph ]." - Preferences clickGrabsMorphs ifFalse: [aMorph activateWindow]. - self wasHandled: true. - ^self ]]]. - - handledByInner ifTrue: [ ^self ]. - "Mouse was not on aMorph nor any of its children" - ^ #rejected! ! -!MouseScrollEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:10:57' overrides: 50563868! - dispatchWith: aMorph - "Find the appropriate receiver for the event and let it handle it. Default rules: - * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. - * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. - * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. - * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. - " - "Try to get out quickly" - | aMorphHandlesIt handledByInner focus| - focus := self hand keyboardFocus. - "FIXME - this works in all tested cases but one: when the window directly under the mouse doesn't have keyboard focus (i.e. a Transcript window)" - ((aMorph fullContainsGlobalPoint: position) and: [(aMorph = focus) or: [focus notNil and: [aMorph notNil and: [focus hasOwner: aMorph]]]]) ifFalse: [ ^ #rejected ]. - "Install the prospective handler for the receiver" - aMorphHandlesIt _ false. - (aMorph handlesMouseScroll: self) ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]. - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - (eachChild dispatchEvent: self) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - (handledByInner or: [ - (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position]]) ifTrue: [ - "aMorph is in the top-most unlocked, visible morph in the chain." - aMorphHandlesIt ifTrue: [ ^ self sendEventTo: aMorph ]]. - handledByInner ifTrue: [ ^ self ]. - "Mouse was not on aMorph nor any of its children" - ^ #rejected.! ! -!WindowEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:11:04' overrides: 50563868! - dispatchWith: aMorph - "Host window events do not have a position and are only dispatched to the World" - - aMorph isWorldMorph ifFalse: [ ^#rejected ]. - self wasHandled ifTrue: [ ^self ]. - ^ self sendEventTo: aMorph! ! -!HandMorph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 12:12:30' prior: 16851794! - startDropEventDispatch: aDropEvent - - owner dispatchEvent: aDropEvent. - self mouseOverHandler processMouseOver: lastMouseEvent! ! -!HandMorph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 12:12:36' prior: 50424827! - startDropFilesEventDispatch: aDropFilesEvent - - owner dispatchEvent: aDropFilesEvent. - self mouseOverHandler processMouseOver: lastMouseEvent! ! -!HandMorph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 12:13:52' prior: 50562332! - startMouseDispatch: aMouseEvent - - aMouseEvent isMouseOver ifTrue: [ - ^self mouseFocus - ifNotNil: [ mouseFocus handleFocusEvent: aMouseEvent ] - ifNil: [ owner dispatchEvent: aMouseEvent ]]. - - "any mouse event but mouseOver" - lastMouseEvent _ aMouseEvent. - lastMouseEventTime _ Time localMillisecondClock. - - "Check for pending drag or double click operations." - mouseClickState ifNotNil: [ - (mouseClickState handleEvent: aMouseEvent from: self) ifTrue: [ - "Possibly dispatched #click: or something. Do not further process this event." - ^self mouseOverHandler processMouseOver: lastMouseEvent ]]. - - aMouseEvent isMove - ifTrue: [ - self morphPosition: aMouseEvent eventPosition. - self mouseFocus - ifNotNil: [ mouseFocus handleFocusEvent: aMouseEvent ] - ifNil: [ owner dispatchEvent: aMouseEvent ] - ] ifFalse: [ - aMouseEvent isMouseScroll ifTrue: [ - owner dispatchEvent: aMouseEvent - ] ifFalse: [ - "Issue a synthetic move event if we're not at the position of the event" - aMouseEvent eventPosition = self morphPosition ifFalse: [ - "Issue a mouse move event to make the receiver appear at the given position" - self startMouseDispatch: (MouseMoveEvent new - setType: #mouseMove - position: aMouseEvent eventPosition - buttons: aMouseEvent buttons - hand: self - stamp: aMouseEvent timeStamp) ]. - "Drop submorphs on button events" - self hasSubmorphs - ifTrue: [ - "Not if we are grabbing them" - mouseClickState ifNil: [ - "Want to drop on mouseUp, NOT mouseDown" - aMouseEvent isMouseUp ifTrue: [ - self dropMorphs: aMouseEvent ] - ] - ] ifFalse: [ - self mouseFocus - ifNotNil: [ mouseFocus handleFocusEvent: aMouseEvent ] - ifNil: [ owner dispatchEvent: aMouseEvent ]]]]. - self mouseOverHandler processMouseOver: self lastMouseEvent! ! -!HandMorph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 12:12:53' prior: 16851875! - startWindowEventDispatch: aWindowEvent - - owner dispatchEvent: aWindowEvent. - self mouseOverHandler processMouseOver: lastMouseEvent! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 1/5/2021 12:12:23' prior: 16852020! - dropMorph: aMorph event: aMouseEvent - "Drop the given morph which was carried by the hand" - | morphData dropEvent | - morphData := self grabMorphDataFor: aMorph. - dropEvent _ DropEvent new - setPosition: self morphPosition - contents: aMorph - hand: self - formerOwner: (morphData at: 1) - formerPosition: (morphData at: 2). - owner dispatchEvent: dropEvent. - dropEvent wasHandled ifFalse: [ aMorph rejectDropMorphEvent: dropEvent ]. - self forgetGrabMorphDataFor: aMorph. - self mouseOverHandler processMouseOver: aMouseEvent! ! -!MenuMorph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 12:13:16' prior: 50563213 overrides: 50563202! - handleFocusEvent: aMorphicEvent - "Handle focus events. Valid menu transitions are determined based on the menu currently holding the focus after the mouse went down on one of its children." - - self dispatchEvent: aMorphicEvent. - - "Need to handle keyboard input if we have the focus." - aMorphicEvent isKeyboard ifTrue: [ ^ aMorphicEvent sendEventTo: self ]. - - "We need to handle button clicks outside and transitions to local popUps so throw away everything else" - (aMorphicEvent isMouseOver or: [aMorphicEvent isMouse not]) ifTrue: [ ^self ]. - "What remains are mouse buttons and moves" - aMorphicEvent isMove ifFalse: [ ^ aMorphicEvent sendEventTo: self ]. "handle clicks outside by regular means" - "Now it's getting tricky. On #mouseMove we might transfer control to *either* the currently active submenu or the pop up owner, if any. Since the active sub menu is always displayed upfront check it first." - selectedItem ifNotNil:[(selectedItem activateSubmenu: aMorphicEvent) ifTrue: [^self]]. - "Note: The following does not traverse upwards but it's the best I can do for now" - popUpOwner ifNotNil:[(popUpOwner activateOwnerMenu: aMorphicEvent) ifTrue: [^self]].! ! - -WindowEvent removeSelector: #dispatchWith:localPosition:! - -!methodRemoval: WindowEvent #dispatchWith:localPosition: stamp: 'Install-4517-remove-dispatchWithlocalPosition-JuanVuletich-2021Jan05-12h08m-jmv.001.cs.st 1/7/2021 16:17:36'! -dispatchWith: aMorph localPosition: positionInAMorph - "Host window events do not have a position and are only dispatched to the World" - - aMorph isWorldMorph ifFalse: [ ^#rejected ]. - self wasHandled ifTrue: [ ^self ]. - ^ self sendEventTo: aMorph! - -MouseScrollEvent removeSelector: #dispatchWith:localPosition:! - -!methodRemoval: MouseScrollEvent #dispatchWith:localPosition: stamp: 'Install-4517-remove-dispatchWithlocalPosition-JuanVuletich-2021Jan05-12h08m-jmv.001.cs.st 1/7/2021 16:17:36'! -dispatchWith: aMorph localPosition: positionInAMorph - "Find the appropriate receiver for the event and let it handle it. Default rules: - * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. - * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. - * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. - * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. - " - "Try to get out quickly" - | aMorphHandlesIt handledByInner eventPositionInChild focus| - focus := self hand keyboardFocus. - "FIXME - this works in all tested cases but one: when the window directly under the mouse doesn't have keyboard focus (i.e. a Transcript window)" - ((aMorph fullContainsGlobalPoint: position) and: [(aMorph = focus) or: [focus notNil and: [aMorph notNil and: [focus hasOwner: aMorph]]]]) ifFalse: [ ^ #rejected ]. - "Install the prospective handler for the receiver" - aMorphHandlesIt _ false. - (aMorph handlesMouseScroll: self) ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]. - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild - dispatchEvent: self - localPosition: eventPositionInChild) == #rejected ifFalse: [ "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - (handledByInner or: [ - (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position]]) ifTrue: [ - "aMorph is in the top-most unlocked, visible morph in the chain." - aMorphHandlesIt ifTrue: [ ^ self sendEventTo: aMorph ]]. - handledByInner ifTrue: [ ^ self ]. - "Mouse was not on aMorph nor any of its children" - ^ #rejected.! - -MouseButtonEvent removeSelector: #dispatchWith:localPosition:! - -!methodRemoval: MouseButtonEvent #dispatchWith:localPosition: stamp: 'Install-4517-remove-dispatchWithlocalPosition-JuanVuletich-2021Jan05-12h08m-jmv.001.cs.st 1/7/2021 16:17:36'! -dispatchWith: aMorph localPosition: positionInAMorph - "Find the appropriate receiver for the event and let it handle it. Default rules: - * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. - * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. - * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. - * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. - " - | aMorphHandlesIt grabAMorph handledByInner eventPositionInChild | - "Only for MouseDown" - self isMouseDown ifFalse: [ - ^super dispatchWith: aMorph localPosition: positionInAMorph ]. - - "Try to get out quickly" - (aMorph fullContainsGlobalPoint: position) - ifFalse: [ ^#rejected ]. - - "Install the prospective handler for the receiver" - aMorphHandlesIt _ false. - grabAMorph _ false. - self mouseButton3Pressed - ifTrue: [ - (eventHandler isNil or: [ eventHandler isWorldMorph or: [ - self shiftPressed or: [ aMorph is: #HaloMorph ]]]) - ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]] - ifFalse: [ - (aMorph handlesMouseDown: self) ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]. - "If button 1, and both aMorph and the owner allows grabbing with the hand (to initiate drag & drop), so be it." - self mouseButton1Pressed ifTrue: [ - aMorph owner ifNotNil: [ :o | - (o allowsSubmorphDrag and: [ aMorph isSticky not ]) ifTrue: [ - grabAMorph _ true ]]]]. - - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - - (handledByInner or: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position] ]) ifTrue: [ - "aMorph is in the top-most unlocked, visible morph in the chain." - aMorphHandlesIt - ifTrue: [ ^self sendEventTo: aMorph ] - ifFalse: [ - (grabAMorph and: [ handledByInner not ]) ifTrue: [ - self hand - waitForClicksOrDrag: aMorph event: self - dragSel: (Preferences clickGrabsMorphs ifFalse: [#dragEvent:localPosition:]) - clkSel: (Preferences clickGrabsMorphs ifTrue: [#dragEvent:localPosition:]). - "false ifTrue: [ self hand grabMorph: aMorph ]." - Preferences clickGrabsMorphs ifFalse: [aMorph activateWindow]. - self wasHandled: true. - ^self ]]]. - - handledByInner ifTrue: [ ^self ]. - "Mouse was not on aMorph nor any of its children" - ^ #rejected! - -DropFilesEvent removeSelector: #dispatchWith:localPosition:! - -!methodRemoval: DropFilesEvent #dispatchWith:localPosition: stamp: 'Install-4517-remove-dispatchWithlocalPosition-JuanVuletich-2021Jan05-12h08m-jmv.001.cs.st 1/7/2021 16:17:36'! -dispatchWith: aMorph localPosition: positionInAMorph - "Drop is done on the innermost target that accepts it." - - | eventPositionInChild | - - "Try to get out quickly" - (aMorph fullContainsGlobalPoint: position) ifFalse: [ ^#rejected ]. - - "Go looking if any of our submorphs wants it" - aMorph submorphsDo: [ :eachChild | - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ ^self ]]. - - (aMorph allowsFilesDrop and: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position] ]) - ifTrue: [^ self sendEventTo: aMorph ]. - - ^#rejected! - -DropEvent removeSelector: #dispatchWith:localPosition:! - -!methodRemoval: DropEvent #dispatchWith:localPosition: stamp: 'Install-4517-remove-dispatchWithlocalPosition-JuanVuletich-2021Jan05-12h08m-jmv.001.cs.st 1/7/2021 16:17:36'! -dispatchWith: aMorph localPosition: positionInAMorph - "Drop is done on the innermost target that accepts it." - | eventPositionInChild dropped | - - "Try to get out quickly" - (aMorph fullContainsGlobalPoint: position) - ifFalse: [ ^#rejected ]. - - "Go looking if any of our submorphs wants it" - aMorph submorphsDo: [ :eachChild | - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ - ^self ]]. - - (aMorph allowsMorphDrop and: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position] ]) - ifTrue: [ - "Do a symmetric check if both morphs like each other" - dropped _ self contents. - ((aMorph wantsDroppedMorph: dropped event: self) "I want her" - and: [dropped wantsToBeDroppedInto: aMorph]) "she wants me" - ifTrue: [ - ^ self sendEventTo: aMorph ]]. - ^#rejected! - -MorphicEvent removeSelector: #dispatchWith:localPosition:! - -!methodRemoval: MorphicEvent #dispatchWith:localPosition: stamp: 'Install-4517-remove-dispatchWithlocalPosition-JuanVuletich-2021Jan05-12h08m-jmv.001.cs.st 1/7/2021 16:17:36'! -dispatchWith: aMorph localPosition: positionInAMorph - "Dispatch me. The event will be passed to the front-most visible submorph that contains the position wrt. to the event." - | handledByInner eventPositionInChild | - - "Try to get out quickly" - (aMorph fullContainsGlobalPoint: self eventPosition) - ifFalse: [ ^#rejected ]. - - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - - "Check for being inside the receiver" - (handledByInner or: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: self eventPosition] ]) - ifTrue: [ ^ self sendEventTo: aMorph ]. - - ^ #rejected! - -Morph removeSelector: #dispatchEvent:localPosition:! - -!methodRemoval: Morph #dispatchEvent:localPosition: stamp: 'Install-4517-remove-dispatchWithlocalPosition-JuanVuletich-2021Jan05-12h08m-jmv.001.cs.st 1/7/2021 16:17:36'! -dispatchEvent: aMorphicEvent localPosition: localPosition - "This is the central entry for dispatching events in morphic. Given some event, find the right receiver and let him handle it. - localPosition is in our coordinates." - - ^ (self rejectsEventFully: aMorphicEvent) - ifTrue: [ #rejected ] - ifFalse: [ aMorphicEvent dispatchWith: self localPosition: localPosition ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4517-remove-dispatchWithlocalPosition-JuanVuletich-2021Jan05-12h08m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4517] on 5 January 2021 at 1:15:41 pm'! -!TextEditor methodsFor: 'typing support' stamp: 'jmv 1/5/2021 13:14:39'! - processKeystrokeEvent: aKeyboardEvent - "Key struck on the keyboard. Find out which one and, if special, carry - out the associated special action. Otherwise, add the character to the - stream of characters." - - (self dispatchOn: aKeyboardEvent) ifTrue: [ - self storeSelectionInComposition. - ^self]. - - markBlock _ pointBlock. - self storeSelectionInComposition! ! -!InnerTextMorph methodsFor: 'event handling' stamp: 'jmv 1/5/2021 13:14:54'! - processKeystrokeEvent: evt - | action | - - (acceptOnCR and: [evt isReturnKey]) ifTrue: [^ self acceptContents]. - - self pauseBlinking. - - "Return - check for special action" - evt isReturnKey ifTrue: [ - action _ self crAction. - action ifNotNil: [ ^action value]]. - - "Esc - check for special action" - evt isEsc ifTrue: [ - action _ self escAction. - action ifNotNil: [ ^action value]]. - - self handleInteraction: [ editor processKeystrokeEvent: evt ]. - self scrollSelectionIntoView! ! -!InnerTextMorph methodsFor: 'events' stamp: 'jmv 1/5/2021 13:14:49' prior: 50466047 overrides: 50449239! - keyStroke: aKeyboardEvent - - (self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - - autoCompleter - ifNil: [ self processKeystrokeEvent: aKeyboardEvent ] - ifNotNil: [ - autoCompleter - autoCompletionAround: [ self processKeystrokeEvent: aKeyboardEvent ] - keyStroke: aKeyboardEvent ]. - - super keyStroke: aKeyboardEvent! ! - -InnerTextMorph removeSelector: #processKeyStroke:! - -!methodRemoval: InnerTextMorph #processKeyStroke: stamp: 'Install-4518-AvoidConfusingSelector-JuanVuletich-2021Jan05-13h08m-jmv.001.cs.st 1/7/2021 16:17:36'! -processKeyStroke: evt - | action | - - (acceptOnCR and: [evt isReturnKey]) ifTrue: [^ self acceptContents]. - - self pauseBlinking. - - "Return - check for special action" - evt isReturnKey ifTrue: [ - action _ self crAction. - action ifNotNil: [ ^action value]]. - - "Esc - check for special action" - evt isEsc ifTrue: [ - action _ self escAction. - action ifNotNil: [ ^action value]]. - - self handleInteraction: [ editor processKeyStroke: evt ]. - self scrollSelectionIntoView! - -TextEditor removeSelector: #processKeyStroke:! - -!methodRemoval: TextEditor #processKeyStroke: stamp: 'Install-4518-AvoidConfusingSelector-JuanVuletich-2021Jan05-13h08m-jmv.001.cs.st 1/7/2021 16:17:36'! -processKeyStroke: aKeyboardEvent - "Key struck on the keyboard. Find out which one and, if special, carry - out the associated special action. Otherwise, add the character to the - stream of characters." - - (self dispatchOn: aKeyboardEvent) ifTrue: [ - self storeSelectionInComposition. - ^self]. - - markBlock _ pointBlock. - self storeSelectionInComposition! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4518-AvoidConfusingSelector-JuanVuletich-2021Jan05-13h08m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4518] on 5 January 2021 at 2:48:26 pm'! -!MorphicEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 14:47:51'! - sentTo: aMorph localPosition: positionInAMorph - "Dispatch the receiver into aMorph" - - ^ self wasHandled: true! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -[ - (Delay forSeconds: 1) wait. - SystemChangeNotifier uniqueInstance doSilently: [ - MorphicEvent removeSelector: #sentTo:localPosition:. - SmalltalkCompleter initialize] -] fork! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4519-AvoidWalkback-JuanVuletich-2021Jan05-14h47m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4519] on 6 January 2021 at 12:01:26 pm'! -!String methodsFor: 'converting' stamp: 'jmv 1/6/2021 11:51:13'! - findPositiveInteger - "Answer the Integer created by interpreting the receiver as the string representation of an integer. - Answer nil if no digits, else find the first digit and then all consecutive digits after that" - - | startPosition tail endPosition | - startPosition _ self findFirst: [:ch | ch isDigit]. - startPosition = 0 ifTrue: [^ nil]. - tail _ self copyFrom: startPosition to: self size. - endPosition _ tail findFirst: [:ch | ch isDigit not]. - endPosition = 0 ifTrue: [endPosition _ tail size + 1]. - ^ Number readFrom: (tail copyFrom: 1 to: endPosition - 1) readStream - -" -'1796exportFixes-tkMX' findPositiveInteger -'1848recentLogFile-sw' findPositiveInteger -'donald' findPositiveInteger -'abc234def567' findPositiveInteger -"! ! - -String removeSelector: #asInteger! - -!methodRemoval: String #asInteger stamp: 'Install-4520-Rename-String-asInteger-to-findPositiveInteger-JuanVuletich-2021Jan06-11h51m-jmv.001.cs.st 1/7/2021 16:17:36'! -asInteger - "Answer the Integer created by interpreting the receiver as the string representation of an integer. Answer nil if no digits, else find the first digit and then all consecutive digits after that" - - | startPosition tail endPosition | - startPosition _ self findFirst: [:ch | ch isDigit]. - startPosition = 0 ifTrue: [^ nil]. - tail _ self copyFrom: startPosition to: self size. - endPosition _ tail findFirst: [:ch | ch isDigit not]. - endPosition = 0 ifTrue: [endPosition _ tail size + 1]. - ^ Number readFrom: (tail copyFrom: 1 to: endPosition - 1) readStream - -" -'1796exportFixes-tkMX' asInteger -'1848recentLogFile-sw' asInteger -'donald' asInteger -'abc234def567' asInteger -"! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4520-Rename-String-asInteger-to-findPositiveInteger-JuanVuletich-2021Jan06-11h51m-jmv.001.cs.st----! - -----SNAPSHOT----(7 January 2021 16:17:59) Cuis5.0-4520-32.image priorSource: 7363541! - -----STARTUP---- (16 January 2021 19:16:51) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4520-32.image! - - -'From Cuis 5.0 [latest update: #4520] on 13 January 2021 at 12:03:37 pm'! - -MenuItemMorph subclass: #HighlightingMenuItemMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #HighlightingMenuItemMorph category: #'Morphic-Menus' stamp: 'Install-4521-HighlightEmbeddingTargetWhenHoveringMenu-JuanVuletich-2021Jan13-12h02m-jmv.001.cs.st 1/16/2021 19:16:55'! -MenuItemMorph subclass: #HighlightingMenuItemMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! -!HighlightingMenuItemMorph commentStamp: '' prior: 0! - Highlights the target when hovered.! -!Morph methodsFor: 'accessing - flags' stamp: 'jmv 1/13/2021 11:03:38'! - highlighted: aBoolean - - self privateFlagAt: 5 put: aBoolean. - self redrawNeeded! ! -!Morph methodsFor: 'accessing - flags' stamp: 'jmv 1/13/2021 09:54:34'! - isHighlighted - - ^ self privateFlagAt: 5! ! -!HighlightingMenuItemMorph methodsFor: 'selecting' stamp: 'jmv 1/13/2021 10:41:50' overrides: 16866146! - isSelected: aBoolean - - super isSelected: aBoolean. - target highlighted: aBoolean.! ! -!MenuMorph methodsFor: 'accessing' stamp: 'jmv 1/13/2021 10:57:10'! - itemsDo: aBlock - - submorphs do: [ :m | - (m is: #MenuItemMorph) ifTrue: [ - aBlock value: m ]].! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 1/13/2021 10:44:39'! - add: aString targetHighlight: target action: aSymbol argumentList: argList - "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument. - Highlight target when hovering over item. - Answer the appended menu item." - - | item | - item _ HighlightingMenuItemMorph new - contents: aString; - target: target selector: aSymbol arguments: argList asArray. - self addMorphBack: item. - ^ item! ! -!BitBltCanvas methodsFor: 'drawing' stamp: 'jmv 1/13/2021 11:57:47'! - drawCurrentMorphHighlight - - currentMorph displayBounds ifNotNil: [ :r | - engine - sourceForm: nil; - colorMap: nil; - combinationRule: Form blend; - fillColor: `Color black`; - frameRect: r borderWidth: 4; - fillColor: `Color pink alpha: 0.2`; - fillRect: (r insetBy: 4). - ]! ! -!Morph methodsFor: 'meta-actions' stamp: 'jmv 1/13/2021 10:43:33' prior: 50393083! - addEmbeddingMenuItemsTo: aMenu hand: aHandMorph - | menu | - menu _ MenuMorph new defaultTarget: self. - self potentialEmbeddingTargets reverseDo: [:m | - menu - add: m class name asString - targetHighlight: m - action: #addMorphFrontFromWorldPosition: - argumentList: {self}]. - aMenu ifNotNil:[ - menu submorphCount > 0 - ifTrue:[aMenu add:'embed into' subMenu: menu]. - ]. - ^menu! ! -!MenuMorph methodsFor: 'initialization' stamp: 'jmv 1/13/2021 10:58:22' prior: 50341027 overrides: 16876882! - delete - activeSubMenu ifNotNil: [activeSubMenu delete]. - self itemsDo: [ :i | i deselect ]. - ^super delete! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 1/13/2021 11:12:00' prior: 50561032 overrides: 50561061! - drawCurrentAndSubmorphs - | b | - self isCurrentMorphVisible ifTrue: [ - currentMorph drawOn: self. - world notNil ifTrue: [ "Only if we are drawing the world" - currentMorph halo ifNotNil: [ b _ currentMorph morphLocalBounds ]. - currentMorph displayBounds: self boundingRectOfCurrentMorphAfterDraw ]. - "Display submorphs back to front" - "coordinate system stack already set up for aMorph - ('ivars transformations' and 'currentTransformation')" - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | self fullDraw: m ]]. - currentMorph postDrawOn: self. - b ifNotNil: [ - self drawCoordinateSystem: b ]. - world notNil ifTrue: [ "Only if we are drawing the world" - currentMorph displayBounds: - (currentMorph displayBounds quickMerge: self boundingRectOfCurrentMorphAfterDraw) ]. - - currentMorph isHighlighted ifTrue: [ - self drawCurrentMorphHighlight ]. - ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4521-HighlightEmbeddingTargetWhenHoveringMenu-JuanVuletich-2021Jan13-12h02m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4520] on 13 January 2021 at 10:30:53 am'! -!Morph methodsFor: 'accessing - flags' stamp: 'jmv 1/13/2021 09:59:07' prior: 50537559! - layoutNeeded: aBoolean - - self privateFlagAt: 4 put: aBoolean! ! -!Morph methodsFor: 'accessing - flags' stamp: 'jmv 1/13/2021 09:59:11' prior: 50537564! - needsRedraw: aBoolean - - self privateFlagAt: 1 put: aBoolean! ! -!Morph methodsFor: 'accessing - flags' stamp: 'jmv 1/13/2021 09:59:15' prior: 50537569! - submorphNeedsRedraw: aBoolean - - self privateFlagAt: 2 put: aBoolean! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4522-SmallCleanup-JuanVuletich-2021Jan13-10h30m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4522] on 14 January 2021 at 6:08:02 pm'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 1/14/2021 18:07:38' prior: 50561061! - drawCurrentAndSubmorphs - - self subclassResponsibility! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4523-Cleanup-JuanVuletich-2021Jan14-18h07m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4523] on 15 January 2021 at 5:05:05 pm'! -!HandMorph methodsFor: 'double click support' stamp: 'jmv 1/14/2021 18:49:09' prior: 16851481! - dontWaitForMoreClicks - "Reset the double-click detection state to normal (i.e., not waiting for a double-click). - This happens after timeout, regardless of multiple clicks having been detected or not." - - mouseClickState _ nil.! ! -!HandMorph methodsFor: 'event handling' stamp: 'jmv 1/15/2021 16:51:21' prior: 50426483! - processEventQueue - "Process user input events from the local input devices. - Answer true if any event was handled (but ignore MouseMove)" - - | evt evtBuf type hadAny mcs hadAnyMouseEvent | - mcs _ mouseClickState. - hadAny := false. - hadAnyMouseEvent := false. - [ (evtBuf := Sensor nextEvent) isNil ] whileFalse: [ - type := evtBuf first. - evt := self createEventFrom: evtBuf ofType: type. - evt ifNotNil: [ - "Finally, handle it" - self startEventDispatch: evt. - hadAny := true. - evt isMouse ifTrue: [ - hadAnyMouseEvent := true ]]]. - hadAnyMouseEvent ifFalse: [ - mcs - ifNotNil: [ - "No mouse events during this cycle. Make sure click states time out accordingly" - mcs - handleEvent: (self lastMouseEvent asMouseMove: (Time localMillisecondClock - self lastMouseEventTime max: 0)) - from: self ]]. - ^hadAny! ! -!WorldMorph methodsFor: 'interaction loop' stamp: 'jmv 1/15/2021 16:14:27' prior: 50553136! - mainLoop - - - self clearWaitDelay. - self setCanvas. - [ - self doOneCycle. - true ] - whileTrue: []! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 1/15/2021 17:04:27' prior: 50560637! - doOneCycle - "Do one cycle of the interaction loop. This method is called repeatedly when the world is running. - - Make for low cpu usage if the ui is inactive, but quick response when ui is in use. - However, after some inactivity, there will be a larger delay before the ui gets responsive again." - - | wait waitUntil a | - waitDelay ifNil: [ waitDelay _ Delay forMilliseconds: 50 ]. - (lastCycleHadAnyEvent or: [ deferredUIMessages isEmpty not ]) - ifTrue: [ - pause _ 20. "This value will only be used later, when there are no more events to serve or deferred UI messages to process." - wait _ 0. "Don't wait this time"] - ifFalse: [ - "wait between 20 and 200 milliseconds" - (hands anySatisfy: [ :h | h waitingForMoreClicks ]) - ifTrue: [ pause _ 20 ] - ifFalse: [ pause < 200 ifTrue: [ pause _ pause * 21//20 ] ]. - waitUntil _ lastCycleTime + pause. - "Earlier if steps" - stepList isEmpty not ifTrue: [ - waitUntil _ waitUntil min: stepList first scheduledTime ]. - "Earlier if alarms" - alarms ifNotNil: [ - alarms isEmpty not ifTrue: [ - waitUntil _ waitUntil min: alarms first scheduledTime ]]. - wait _ waitUntil - Time localMillisecondClock max: 0 ]. - Preferences serverMode - ifTrue: [ wait _ wait max: 50 ]. "Always wait at least a bit on servers, even if this makes the UI slow." - wait = 0 - ifTrue: [ Processor yield ] - ifFalse: [ - waitDelay beingWaitedOn - ifFalse: [ waitDelay setDelay: wait; wait ] - ifTrue: [ - "If we are called from a different process than that of the main UI, we might be called in the main - interCyclePause. In such case, use a new Delay to avoid 'This Delay has already been scheduled' errors" - (Delay forMilliseconds: wait) wait ]]. - - "Record start time of this cycle, and do cycle" - lastCycleTime _ Time localMillisecondClock. - lastCycleHadAnyEvent _ self doOneCycleNow.! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 1/15/2021 16:51:48' prior: 50551770! - doOneCycleNow - "Immediately do one cycle of the interaction loop. - Only used for a few tests." - "See #eventTickler" - | hadAny | - Cursor currentCursor = (Cursor cursorAt: #waitCursor) ifTrue: [ Cursor defaultCursor activateCursor ]. - "Repair visual damage." - DisplayScreen checkForNewScreenSize. - self displayWorldSafely. - "Run steps, alarms and deferred UI messages" - self runStepMethods. - "Process user input events. Run all event triggered code." - hadAny _ false. - self handsDo: [ :h | - activeHand _ h. - hadAny _ hadAny | h processEventQueue. - activeHand _ nil ]. - "The default is the primary hand" - activeHand _ self hands first. - ^ hadAny.! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -| guiRootObject | -Utilities authorInitialsPerSe ifNil: [ Utilities setAuthor ]. -(nil confirm: 'We need to restart the User Interface process. -You''ll need to do [Install New Updates] again, to install later updates.') ifFalse: [ self halt ]. -[ - guiRootObject _ UISupervisor ui. - UISupervisor stopUIProcess. - UISupervisor spawnNewMorphicProcessFor: guiRootObject. - (Delay forSeconds: 1) wait. - ChangeSet installing: '4524-MorphicEventsCleanup-JuanVuletich-2021Jan15-16h08m-jmv.003.cs.st' do: []. - cs _ ChangeSet changeSetForBaseSystem. - (cs name beginsWith: '4524') ifTrue: [ - ChangeSet removeChangeSet: cs ]. - 'Done updating Morphic ui process code.' print. - 'Installed ChangeSet: 4524-MorphicEventsCleanup-JuanVuletich-2021Jan15-16h08m-jmv.003.cs.st' print. - 'Please do [Install New Updates] again.' print. -] forkAt: 41! - -'From Cuis 5.0 [latest update: #4523] on 15 January 2021 at 5:36:41 pm'! -!MouseEvent methodsFor: 'converting' stamp: 'jmv 1/14/2021 21:22:43'! - asMouseMove - - ^ MouseMoveEvent new - setType: #mouseMove - position: position - buttons: buttons - hand: source - stamp: Time millisecondClockValue "VMs report events using #millisecondClockValue"! ! -!HandMorph methodsFor: 'event handling' stamp: 'jmv 1/15/2021 17:35:56' prior: 50564945! - processEventQueue - "Process user input events from the local input devices. - Answer true if any event was handled (but ignore MouseMove)" - - | evt evtBuf type hadAny mcs hadAnyMouseEvent | - mcs _ mouseClickState. - hadAny := false. - hadAnyMouseEvent := false. - [ (evtBuf := Sensor nextEvent) isNil ] whileFalse: [ - type := evtBuf first. - evt := self createEventFrom: evtBuf ofType: type. - evt ifNotNil: [ - "Finally, handle it" - self startEventDispatch: evt. - hadAny := true. - evt isMouse ifTrue: [ - hadAnyMouseEvent := true ]]]. - hadAnyMouseEvent ifFalse: [ - mcs - ifNotNil: [ - "No mouse events during this cycle. Make sure click states time out accordingly" - mcs - handleEvent: lastMouseEvent asMouseMove - from: self ]]. - ^hadAny! ! -!HandMorph methodsFor: 'events-processing' stamp: 'jmv 1/15/2021 17:15:12' prior: 50447151! - startKeyboardDispatch: aKeyboardEvent - - | focusedElement | - - focusedElement _ self keyboardFocus ifNil: [ self world ]. - focusedElement handleFocusEvent: aKeyboardEvent. - - self mouseOverHandler processMouseOver: lastMouseEvent! ! -!HandMorph methodsFor: 'events-processing' stamp: 'jmv 1/15/2021 17:15:17' prior: 50564125! - startMouseDispatch: aMouseEvent - - aMouseEvent isMouseOver ifTrue: [ - ^self mouseFocus - ifNotNil: [ mouseFocus handleFocusEvent: aMouseEvent ] - ifNil: [ owner dispatchEvent: aMouseEvent ]]. - - "any mouse event but mouseOver" - lastMouseEvent _ aMouseEvent. - lastMouseEventTime _ Time localMillisecondClock. - - "Check for pending drag or double click operations." - mouseClickState ifNotNil: [ - (mouseClickState handleEvent: aMouseEvent from: self) ifTrue: [ - "Possibly dispatched #click: or something. Do not further process this event." - ^self mouseOverHandler processMouseOver: lastMouseEvent ]]. - - aMouseEvent isMove - ifTrue: [ - self morphPosition: aMouseEvent eventPosition. - self mouseFocus - ifNotNil: [ mouseFocus handleFocusEvent: aMouseEvent ] - ifNil: [ owner dispatchEvent: aMouseEvent ] - ] ifFalse: [ - aMouseEvent isMouseScroll ifTrue: [ - owner dispatchEvent: aMouseEvent - ] ifFalse: [ - "Issue a synthetic move event if we're not at the position of the event" - aMouseEvent eventPosition = self morphPosition ifFalse: [ - "Issue a mouse move event to make the receiver appear at the given position" - self startMouseDispatch: (MouseMoveEvent new - setType: #mouseMove - position: aMouseEvent eventPosition - buttons: aMouseEvent buttons - hand: self - stamp: aMouseEvent timeStamp) ]. - "Drop submorphs on button events" - self hasSubmorphs - ifTrue: [ - "Not if we are grabbing them" - mouseClickState ifNil: [ - "Want to drop on mouseUp, NOT mouseDown" - aMouseEvent isMouseUp ifTrue: [ - self dropMorphs: aMouseEvent ] - ] - ] ifFalse: [ - self mouseFocus - ifNotNil: [ mouseFocus handleFocusEvent: aMouseEvent ] - ifNil: [ owner dispatchEvent: aMouseEvent ]]]]. - self mouseOverHandler processMouseOver: lastMouseEvent! ! - -MouseEvent removeSelector: #asMouseMove:! - -!methodRemoval: MouseEvent #asMouseMove: stamp: 'Install-4525-MorphicEventsCleanup-JuanVuletich-2021Jan15-17h35m-jmv.001.cs.st 1/16/2021 19:17:02'! -asMouseMove: deltaTime - "Convert the receiver into a mouse move. adjust timestamp by the provided delta" - - ^ MouseMoveEvent new - setType: #mouseMove - position: position - buttons: buttons - hand: source - stamp: timeStamp + deltaTime! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4525-MorphicEventsCleanup-JuanVuletich-2021Jan15-17h35m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4524] on 14 January 2021 at 9:26:43 pm'! -!MouseClickState methodsFor: 'actions' stamp: 'jmv 1/14/2021 21:23:34' prior: 16878916! - handleEvent: aMouseEvent from: aHand - "Process the given mouse event to detect a click, double-click, or drag. - Return true if the event should be processed by the sender, false if it shouldn't. - NOTE: This method heavily relies on getting *all* mouse button events." - - | timedOut distance | - timedOut _ (aMouseEvent timeStamp - lastClickDown timeStamp) > self class doubleClickTimeout. - timedOut ifTrue: [ aHand dontWaitForMoreClicks ]. - distance _ (aMouseEvent eventPosition - lastClickDown eventPosition) r. - "Real action dispatch might be done after the triggering event, for example, because of waiting for timeout. - So, count the button downs and ups(clicks), to be processed, maybe later, maybe in a mouseMove..." - aMouseEvent isMouseDown ifTrue: [ - lastClickDown _ aMouseEvent. - buttonDownCount _ buttonDownCount + 1 ]. - aMouseEvent isMouseUp ifTrue: [ - buttonUpCount _ buttonUpCount + 1 ]. - - "Simulate button 2 if timeout during first click (i.e. tap & hold). Useful for opening menus on pen computers." - (buttonDownCount = 1 and: [ buttonUpCount = 0]) ifTrue: [ - (timedOut and: [ sendMouseButton2Activity and: [ distance = 0]]) ifTrue: [ - aHand dontWaitForMoreClicks. - clickClient mouseButton2Activity. - ^ false ]. - "If we have already moved, then it won't be a double or triple click... why wait?" - (timedOut or: [distance > 0]) ifTrue: [ - aHand dontWaitForMoreClicks. - dragSelector - ifNotNil: [ self didDrag ] - ifNil: [ self didClick ]. - ^ false ]]. - - "If we're over triple click, or timed out, or mouse moved, don't allow more clicks." - (buttonDownCount = 4 or: [ timedOut or: [ distance > 0 ]]) ifTrue: [ - aHand dontWaitForMoreClicks. - ^ false ]. - - "Simple click." - (buttonDownCount = 1 and: [ buttonUpCount = 1 ]) ifTrue: [ - self didClick ]. - - "Click & hold" - (buttonDownCount = 2 and: [ buttonUpCount = 1]) ifTrue: [ - self didClickAndHalf ]. - - "Double click." - (buttonDownCount = 2 and: [ buttonUpCount = 2]) ifTrue: [ - self didDoubleClick ]. - - "Double click & hold." - (buttonDownCount = 3 and: [ buttonUpCount = 2]) ifTrue: [ - self didDoubleClickAndHalf ]. - - "Triple click" - (buttonDownCount = 3 and: [ buttonUpCount = 3]) ifTrue: [ - self didTripleClick ]. - - "This means: if a mouseDown, then don't further process this event (so we can turn it into a double or triple click on next buttonUp)" - ^ aMouseEvent isMouseDown! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4526-MorphicEventsCleanup-JuanVuletich-2021Jan14-21h23m-jmv.001.cs.st----! - -----SNAPSHOT----(16 January 2021 19:17:04) Cuis5.0-4526-32.image priorSource: 7459285! - -----STARTUP---- (9 April 2021 16:04:07) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4526-32.image! - - -'From Cuis 5.0 [latest update: #4526] on 20 January 2021 at 5:24:31 pm'! -!BacktickNode methodsFor: 'visiting' stamp: 'NPM 1/20/2021 17:23:50' prior: 50525721 overrides: 16884650! - accept: aVisitor - - ^ aVisitor visitBacktickNode: self. - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4527-CuisCore-NicolasPapagnaMaldonado-2021Jan20-17h23m-NPM.001.cs.st----! - -'From Cuis 5.0 [latest update: #4526] on 29 January 2021 at 5:03:31 pm'! -!Preferences class methodsFor: 'class finder' stamp: 'NPM 1/29/2021 17:00:27'! - classFinder - - ^ self - valueOfFlag: #classFinder - ifAbsent: [ self restoreDefaultClassFinder ]! ! -!Preferences class methodsFor: 'class finder' stamp: 'NPM 1/29/2021 16:55:13'! - classFinder: aBlock - - self - setPreference: #classFinder - toValue: aBlock! ! -!Preferences class methodsFor: 'class finder' stamp: 'NPM 1/29/2021 17:02:24'! - restoreDefaultClassFinder - - | defaultClassFinder | - defaultClassFinder _ [ BrowserWindow findClass ]. - - self classFinder: defaultClassFinder. - - ^ defaultClassFinder! ! -!KeyboardEvent methodsFor: 'dispatching' stamp: 'NPM 1/29/2021 16:56:56' prior: 50563129 overrides: 50563111! - sendEventTo: aMorph - "Dispatch the receiver into anObject" - type == #keystroke ifTrue: [ - self isFindClassShortcut - ifTrue: [ ^ Preferences classFinder value ]. - self isCloseWindowShortcut - ifTrue: [ ^ self closeCurrentWindowOf: aMorph ]. - ^ aMorph processKeystroke: self ]. - type == #keyDown ifTrue: [ - ^ aMorph processKeyDown: self ]. - type == #keyUp ifTrue: [ - ^ aMorph processKeyUp: self ]. - ^ super sendEventTo: aMorph.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4528-CuisCore-NicolasPapagnaMaldonado-2021Jan29-16h51m-NPM.001.cs.st----! - -'From Cuis 5.0 [latest update: #4528] on 8 February 2021 at 5:52:57 pm'! -!ScrollBar methodsFor: 'initialization' stamp: 'jmv 2/8/2021 17:17:37'! - updateDownButton: aPluggableButtonMorph - "update the argument as a downButton. put a new image inside" - - aPluggableButtonMorph - icon: (BitBltCanvas arrowOfDirection: #down size: ScrollBar scrollbarThickness); - iconName: #drawDownIcon; - action: #scrollDown; - roundButtonStyle: false; - redrawNeeded! ! -!ScrollBar methodsFor: 'initialization' stamp: 'jmv 2/8/2021 17:36:03'! - updateLeftButton: aPluggableButtonMorph - "update the argument as a leftButton. put a new image inside" - - aPluggableButtonMorph - icon: (BitBltCanvas arrowOfDirection: #left size: ScrollBar scrollbarThickness); - iconName: #drawLeftIcon; - action: #scrollUp; - roundButtonStyle: false; - redrawNeeded! ! -!ScrollBar methodsFor: 'initialization' stamp: 'jmv 2/8/2021 17:19:03'! - updateRightButton: aPluggableButtonMorph - "update the argument as a rightButton. put a new image inside" - - aPluggableButtonMorph - icon: (BitBltCanvas arrowOfDirection: #right size: ScrollBar scrollbarThickness); - iconName: #drawRightIcon; - action: #scrollDown; - roundButtonStyle: false; - redrawNeeded! ! -!ScrollBar methodsFor: 'initialization' stamp: 'jmv 2/8/2021 17:19:41'! - updateUpButton: aPluggableButtonMorph - "update the argument as a rightButton. put a new image inside" - - aPluggableButtonMorph - icon: (BitBltCanvas arrowOfDirection: #up size: ScrollBar scrollbarThickness); - iconName: #drawUpIcon; - action: #scrollUp; - roundButtonStyle: false; - redrawNeeded! ! -!ScrollBar methodsFor: 'geometry' stamp: 'jmv 2/8/2021 17:51:52' prior: 50556409 overrides: 50556356! - extentChanged: oldExtent - "Our extent changed. Must layout submorphs again." - | isH wasH | - - super extentChanged: oldExtent. - "Doesn't move!!" - "upButton morphPosition: borderWidth@borderWidth." - downButton morphPosition: extent - borderWidth - downButton morphExtent. - wasH _ oldExtent notNil and: [oldExtent x > oldExtent y]. - isH _ self isHorizontal. - isH = wasH ifFalse: [ - isH - ifTrue: [ - self updateLeftButton: upButton. - self updateRightButton: downButton ] - ifFalse: [ - self updateUpButton: upButton. - self updateDownButton: downButton ]].! ! -!ScrollBar methodsFor: 'initialization' stamp: 'jmv 2/8/2021 17:21:07' prior: 16904645! - initializeDownButton - "initialize the receiver's downButton" - - | e | - e _ self buttonExtent. - downButton _ self buttonClass new. - downButton model: self. - downButton morphExtent: e@e. - Theme current minimalWindows ifTrue: [^ self]. - self addMorph: downButton position: extent - borderWidth - e. - downButton - actWhen: #buttonStillDown. "to enable multiple action if held down". - self isHorizontal - ifTrue: [ self updateRightButton: downButton ] - ifFalse: [ self updateDownButton: downButton ]! ! -!ScrollBar methodsFor: 'initialization' stamp: 'jmv 2/8/2021 17:35:47' prior: 16904677! - initializeUpButton - "initialize the receiver's upButton" - - | e | - e _ self buttonExtent. - upButton _ self buttonClass new. - upButton model: self. - upButton morphExtent: e@e. - Theme current minimalWindows ifTrue: [^ self]. - self addMorph: upButton position: borderWidth@borderWidth. - upButton - actWhen: #buttonStillDown. "to enable multiple action if held down" - self isHorizontal - ifTrue: [ self updateLeftButton: upButton ] - ifFalse: [ self updateUpButton: upButton ]. -! ! - -PluggableButtonMorph removeSelector: #updateDownButtonImage! - -!methodRemoval: PluggableButtonMorph #updateDownButtonImage stamp: 'Install-4529-ScrollbarFix-JuanVuletich-2021Feb08-17h50m-jmv.001.cs.st 4/9/2021 16:04:12'! -updateDownButtonImage - "update the receiver's as a downButton. put a new image inside" - - icon _ BitBltCanvas arrowOfDirection: #down size: ScrollBar scrollbarThickness. - self iconName: #drawDownIcon. - actionSelector _ #scrollDown. - self - roundButtonStyle: false; - redrawNeeded! - -PluggableButtonMorph removeSelector: #updateUpButtonImage! - -!methodRemoval: PluggableButtonMorph #updateUpButtonImage stamp: 'Install-4529-ScrollbarFix-JuanVuletich-2021Feb08-17h50m-jmv.001.cs.st 4/9/2021 16:04:12'! -updateUpButtonImage - "update the receiver's as a upButton. put a new image inside" - - icon _ BitBltCanvas arrowOfDirection: #up size: ScrollBar scrollbarThickness. - self iconName: #drawUpIcon. - actionSelector _ #scrollUp. - self - roundButtonStyle: false; - redrawNeeded! - -PluggableButtonMorph removeSelector: #updateLeftButtonImage! - -!methodRemoval: PluggableButtonMorph #updateLeftButtonImage stamp: 'Install-4529-ScrollbarFix-JuanVuletich-2021Feb08-17h50m-jmv.001.cs.st 4/9/2021 16:04:12'! -updateLeftButtonImage - "update the receiver's as a downButton. put a new image inside" - - icon _ BitBltCanvas arrowOfDirection: #left size: ScrollBar scrollbarThickness. - self iconName: #drawLeftIcon. - actionSelector _ #scrollUp. - self - roundButtonStyle: false; - redrawNeeded! - -PluggableButtonMorph removeSelector: #updateRightButtonImage! - -!methodRemoval: PluggableButtonMorph #updateRightButtonImage stamp: 'Install-4529-ScrollbarFix-JuanVuletich-2021Feb08-17h50m-jmv.001.cs.st 4/9/2021 16:04:12'! -updateRightButtonImage - "update the receiver's as a downButton. put a new image inside" - - icon _ BitBltCanvas arrowOfDirection: #right size: ScrollBar scrollbarThickness. - self iconName: #drawRightIcon. - actionSelector _ #scrollDown. - self - roundButtonStyle: false; - redrawNeeded! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4529-ScrollbarFix-JuanVuletich-2021Feb08-17h50m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4529] on 9 February 2021 at 11:59:05 am'! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 2/8/2021 19:08:52'! - exponent - "Usually run as a primitive in specific subclass. - Consider the receiver to be represented as a power of two - multiplied by a mantissa between one and two or between -1 and -2 (#significand). - Answer with the SmallInteger to whose power two is raised. - Note: invalid for infinities, NaN and zero. - See also #signPart, #significandAsInteger and #exponentPart - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. f significand . f exponent. f significand * (2 raisedToInteger: f exponent) = f } print ]. - " - - self = 0.0 ifTrue: [^MinValLogBase2-1]. - self isFinite ifFalse: [^Float emax+1]. - self isDenormalized ifTrue: [^MinValLogBase2 + self mantissaPart asFloat exponent]. - ^self exponentPart! ! -!BoxedFloat64 methodsFor: 'truncation and round off' stamp: 'jmv 2/8/2021 18:54:45' prior: 50467743 overrides: 50565554! - exponent - "Primitive. Consider the receiver to be represented as a power of two - multiplied by a mantissa between one and two or between -1 and -2 (#significand). - Answer with the SmallInteger to whose power two is raised. - Optional. See Object documentation whatIsAPrimitive. - Note: invalid for infinities, NaN and zero. - See also #signPart, #significandAsInteger and #exponentPart - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. f significand . f exponent. f significand * (2 raisedToInteger: f exponent) = f } print ]. - " - - - ^super exponent! ! -!SmallFloat64 methodsFor: 'truncation and round off' stamp: 'jmv 2/8/2021 18:54:52' prior: 50467774 overrides: 50565554! - exponent - "Primitive. Consider the receiver to be represented as a power of two - multiplied by a mantissa between one and two (#significand). - Answer with the SmallInteger to whose power two is raised. - Optional. See Object documentation whatIsAPrimitive. - Note: invalid for infinities, NaN and zero. - See comment at BoxedFloat64" - - - ^super exponent! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4530-Float-exponent-nonPrimitive-Fix-JuanVuletich-2021Feb09-11h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4530] on 9 February 2021 at 3:15:43 pm'! -!MenuItemMorph methodsFor: 'events' stamp: 'jmv 1/30/2021 15:59:33' prior: 50562574! -activateSubmenu: event - "Activate our submenu; e.g., pass control to it" - - subMenu ifNil: [ ^false ]. "not applicable" - subMenu isInWorld ifFalse: [ ^false ]. - (subMenu containsGlobalPoint: event eventPosition) ifFalse: [^false]. - subMenu activate: event. - ^true! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4531-MenuFix-JuanVuletich-2021Feb09-15h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4531] on 2 March 2021 at 2:59:41 pm'! -!SystemDictionary class methodsFor: 'copyright' stamp: 'jmv 3/2/2021 14:58:54' prior: 50381636! - copyright - "The Cuis Smalltalk copyright. - Parts are copyright of many contributors to Squeak and Cuis projects." - - ^ -'Portions of Cuis are: -Copyright (c) Xerox Corp. 1981, 1982. -Copyright (c) Apple Computer, Inc. 1985-1996. -Copyright (c) Contributors to Squeak project. 1997-2021. -Copyright (c) Contributors to Cuis Smalltalk project. 2009-2021.'! ! -!Utilities class methodsFor: 'default desktop' stamp: 'jmv 3/2/2021 14:57:29' prior: 50491153! - defaultTextEditorContents - ^ (' -', -('Cuis Smalltalk - -' centered blue pointSize: FontFamily defaultPointSize * 3), -(' -"Yay, Juan. You GO, guy!! ...a great example of malleable software (and a clever mind) at work." -' rightFlush pointSize: FontFamily defaultPointSize * 0.6), -('Dan Ingalls -' italic rightFlush pointSize: FontFamily defaultPointSize * 0.6), -(' -"I like it... It''s nice and clean and simple and pretty. Nice stuff!!" -' rightFlush pointSize: FontFamily defaultPointSize * 0.6), -('Alan Kay -' italic rightFlush pointSize: FontFamily defaultPointSize * 0.6), -(' -"I think you have a very elegant design aesthetic." -' rightFlush pointSize: FontFamily defaultPointSize * 0.6), -('John Maloney -'italic rightFlush pointSize: FontFamily defaultPointSize * 0.6), -' - -', -'Cuis is a modern, Open Source, multiplatform, Smalltalk-80 system. - - -', -'Cuis is: - -' bold, -' - Small - - Clean - - Appropriable -' blue, -' - -Additionally, Cuis is: - -' bold, -' - Open Source - - Multiplatform -' blue, -' - -Like other Smalltalk systems, Cuis is also: - -' bold, -' - A complete development environment written in itself - - A pure, dynamic Object Oriented language -' blue, -' - -Cuis assumes very little on the underlying platform, and this lets it run out-of-the-box on Windows, MacOS, Linux, ChromeOS and WebBrowsers. Cuis shares the [OpenSmalltalk Virtual Machine] (http://www.opensmalltalk.org) with Squeak, Pharo and Newspeak. - -What sets Cuis apart from the other members of the Squeak family is the focus on Smalltalk-80 and an active attitude towards system complexity: - -Unbound complexity growth, together with development strategies focused only in the short term, are the worst long term enemies of all software systems. As systems grow older, they usually become more complex. New features are added as layers on top of whatever is below, sometimes without really understanding it, and almost always without modifying it. Complexity and size grow without control. Evolution slows down. Understanding the system becomes harder every day. Bugs are harder to fix. Codebases become huge for no clear reason. At some point, the system can''t evolve anymore and becomes "legacy code". - -Complexity puts a limit to the level of understanding of the system a person might reach, and therefore limits the things that can be done with it. Dan Ingalls says all this in ["Design Principles Behind Smalltalk"] (http://www.cs.virginia.edu/~evans/cs655/readings/smalltalk.html). Even if you have already done so, please go and read it again!! - -Cuis Smalltalk is our attempt at this challenge. Furthermore, we believe we are doing something else that no other Smalltalk, commercial or open source, does. We attempt to give the true Smalltalk-80 experience, and keep Smalltalk-80 not as legacy software historic significance, but as a live, evolving system. We feel we are the keepers of the Smalltalk-80 heritage, and enablers of the Dynabook experience. - -As Cuis evolves, we keep on these values. Every update, be it a bug fix or a feature enhancement, is reviewed carefully to avoid adding unneded complexity to the system. Every opportunity to remove unneded complexity is followed. As we go, features are enhanced, and any reported bugs fixed. We also adopt selected enhancements from Squeak and Pharo, and share our work with the wider Smalltalk community. - - -' justified, -'License -' bold, -' -Cuis is distributed subject to the MIT License, as in http://www.opensource.org/licenses/mit-license.php . Any contribution submitted for incorporation into or for distribution with Cuis shall be presumed subject to the same license. - -Portions of Cuis are: -Copyright (c) Xerox Corp. 1981, 1982 -Copyright (c) Apple Computer, Inc. 1985-1996 -Copyright (c) Contributors to Squeak project. 1997-2021 -Copyright (c) Contributors to Cuis Smalltalk project. 2009-2021')! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4532-CopyrightUpdate-JuanVuletich-2021Mar02-14h34m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4532] on 13 March 2021 at 9:52:08 am'! -!Preferences class methodsFor: 'standard queries' stamp: 'jmv 3/13/2021 09:50:37' prior: 0! - tapAndHoldEmulatesButton2 - ^ self - valueOfFlag: #tapAndHoldEmulatesButton2 - ifAbsent: [ false ].! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Preferences disable: #tapAndHoldEmulatesButton2! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4533-AvoidUnintendedTapAndHoldEvents-JuanVuletich-2021Mar13-09h50m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4533] on 15 March 2021 at 4:33:30 pm'! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 3/15/2021 16:33:03' prior: 50564860 overrides: 50564923! - drawCurrentAndSubmorphs - - self isCurrentMorphVisible ifTrue: [ - - currentMorph drawOn: self. - world notNil ifTrue: [ "Only if we are drawing the world" - currentMorph displayBounds: self boundingRectOfCurrentMorphAfterDraw ]. - - "Display submorphs back to front" - "coordinate system stack already set up for aMorph - ('ivars transformations' and 'currentTransformation')" - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | self fullDraw: m ]]. - - currentMorph postDrawOn: self. - world notNil ifTrue: [ "Only if we are drawing the world" - currentMorph displayBounds: - (currentMorph displayBounds quickMerge: self boundingRectOfCurrentMorphAfterDraw) ]. - - currentMorph isHighlighted ifTrue: [ - self drawCurrentMorphHighlight ]. - world notNil ifTrue: [ - currentMorph halo ifNotNil: [ - self drawCoordinateSystem: currentMorph morphLocalBounds ]]. - - world notNil ifTrue: [ "Only if we are drawing the world" - currentMorph displayBounds: - (currentMorph displayBounds quickMerge: self boundingRectOfCurrentMorphAfterDraw) ]. - ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4534-BitBltCanvasTweaks-JuanVuletich-2021Mar15-16h33m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4534] on 16 March 2021 at 9:05:21 am'! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/16/2021 08:47:32' prior: 16877608! - drawString: s at: pt font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - ^self drawString: s from: 1 to: s size at: pt font: (self fontToUse: fontOrNil) color: aColor! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/16/2021 08:47:48' prior: 16877617! - drawString: s at: pt font: fontOrNil color: aColor embossed: aBoolean - "Answer last affected pixel position - Answer nil if nothing was done" - - ^aBoolean - ifTrue: [ self drawStringEmbossed: s from: 1 to: s size at: pt font: (self fontToUse: fontOrNil) color: aColor ] - ifFalse: [ self drawString: s from: 1 to: s size at: pt font: (self fontToUse: fontOrNil) color: aColor ]! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/16/2021 08:40:05' prior: 50560784! - drawString: s atBaseline: pt font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | font | - font _ self fontToUse: fontOrNil. - ^self drawString: s from: 1 to: s size atBaseline: pt font: font color: aColor! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/16/2021 08:49:16' prior: 50560794! - drawString: s atCenterX: pt font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | font | - font _ self fontToUse: fontOrNil. - ^self - drawString: s - from: 1 to: s size - at: pt - ((font widthOfString: s) / 2 @ 0) - font: font color: aColor! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/16/2021 08:42:31' prior: 50560808! - drawString: s atWaist: pt font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | font | - font _ self fontToUse: fontOrNil. - ^self drawString: s from: 1 to: s size atWaist: pt font: font color: aColor! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/16/2021 08:43:49' prior: 50560818! - drawString: s atWaistRight: pt font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | font | - font _ self fontToUse: fontOrNil. - ^self - drawString: s - from: 1 to: s size - atWaist: pt - ((font widthOfString: s) @ 0) - font: font color: aColor! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/16/2021 08:57:07' prior: 50463529! - drawString: aString from: firstIndex to: lastIndex at: aPoint font: font color: aColor - "Eventually, convert all senders to the 'Baseline' protocol" - - ^self drawString: aString from: firstIndex to: lastIndex - atBaseline: aPoint + (0@(font ascent + font lineGap-1)) - font: font color: aColor! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/16/2021 08:34:31' prior: 50560832! - drawString: aString from: firstIndex to: lastIndex atBaseline: aPoint font: font color: aColor - self subclassResponsibility ! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/16/2021 08:59:54' prior: 50560839! - drawString: aString from: firstIndex to: lastIndex atWaist: aPoint font: font color: aColor - - ^self drawString: aString from: firstIndex to: lastIndex - atBaseline: aPoint + (0@(font ascent / 3)) - font: font color: aColor! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/16/2021 08:50:14' prior: 50388601! - drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint font: font color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - aColor = `Color black` ifFalse: [ | topColor | - topColor _ aColor alphaMixed: 0.25 with: `Color black`. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint - font: font - color: topColor ]. - aColor = `Color white` ifFalse: [ | bottomColor | - bottomColor _ aColor alphaMixed: 0.22 with: `Color white`. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + `0@2` - font: font - color: bottomColor ]. - ^self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + `0@1` - font: font - color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/16/2021 08:56:16' prior: 50560853 overrides: 50565947! - drawString: aString from: firstIndex to: lastIndex atBaseline: aPoint font: font color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | p1 | - engine ifNil: [ ^nil ]. - - "Don't waste any time if NOP" - lastIndex = 0 ifTrue: [ - ^nil ]. - - p1 _ currentTransformation transform: aPoint rounded. - p1 _ p1 + (0@(0 - (font ascent + font lineGap-1))). - p1 _ p1 rounded. - engine colorMap: nil. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/16/2021 08:50:44' prior: 50560923 overrides: 50565964! - drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint font: font color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - | p1 | - - engine ifNil: [ ^nil ]. - - p1 _ (currentTransformation transform: aPoint rounded) rounded. - engine colorMap: nil. - - aColor = `Color black` ifFalse: [ | topColor | - topColor _ aColor alphaMixed: 0.25 with: `Color black`. - font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: topColor ]. - aColor = `Color white` ifFalse: [ | bottomColor | - bottomColor _ aColor alphaMixed: 0.22 with: `Color white`. - font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + `0@2` - color: bottomColor ]. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + `0@1` - color: aColor.! ! - -BitBltCanvas removeSelector: #drawString:from:to:atWaist:font:color:! - -!methodRemoval: BitBltCanvas #drawString:from:to:atWaist:font:color: stamp: 'Install-4535-Canvas-String-Protocol-Cleanup-JuanVuletich-2021Mar16-08h29m-jmv.001.cs.st 4/9/2021 16:04:12'! -drawString: aString from: firstIndex to: lastIndex atWaist: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | p1 font | - engine ifNil: [ ^nil ]. - - "Don't waste any time if NOP" - lastIndex = 0 ifTrue: [ - ^nil ]. - - p1 _ (currentTransformation transform: aPoint rounded) rounded. - engine colorMap: nil. - font _ self fontToUse: fontOrNil. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + (0@(0 - (font ascent * 2 // 3 + font lineGap-1))) - color: aColor! - -BitBltCanvas removeSelector: #drawString:from:to:at:font:color:! - -!methodRemoval: BitBltCanvas #drawString:from:to:at:font:color: stamp: 'Install-4535-Canvas-String-Protocol-Cleanup-JuanVuletich-2021Mar16-08h29m-jmv.001.cs.st 4/9/2021 16:04:12'! -drawString: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | p1 | - engine ifNil: [ ^nil ]. - - "Don't waste any time if NOP" - lastIndex = 0 ifTrue: [ - ^nil ]. - - p1 _ (currentTransformation transform: aPoint rounded) rounded. - engine colorMap: nil. - ^(self fontToUse: fontOrNil) - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: aColor! - -BitBltCanvas removeSelector: #drawString:from:to:atTop:font:color:! - -MorphicCanvas removeSelector: #drawString:from:to:atTop:font:color:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4535-Canvas-String-Protocol-Cleanup-JuanVuletich-2021Mar16-08h29m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4532] on 5 March 2021 at 3:39:13 pm'! -!MorphicTranslation methodsFor: 'polymorphism with AffineTransformation' stamp: 'jmv 3/5/2021 15:38:04'! - a11 - ^1.0! ! -!MorphicTranslation methodsFor: 'polymorphism with AffineTransformation' stamp: 'jmv 3/5/2021 15:38:11'! - a12 - ^0.0! ! -!MorphicTranslation methodsFor: 'polymorphism with AffineTransformation' stamp: 'jmv 3/5/2021 15:38:27'! - a13 - ^deltaX! ! -!MorphicTranslation methodsFor: 'polymorphism with AffineTransformation' stamp: 'jmv 3/5/2021 15:38:41'! - a21 - ^0.0! ! -!MorphicTranslation methodsFor: 'polymorphism with AffineTransformation' stamp: 'jmv 3/5/2021 15:38:49'! - a22 - ^1.0! ! -!MorphicTranslation methodsFor: 'polymorphism with AffineTransformation' stamp: 'jmv 3/5/2021 15:39:00'! - a23 - ^deltaY! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4536-MorphicTranslationAffineElements-CuisCore-JuanVuletich-2021Mar05-15h08m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4536] on 17 March 2021 at 9:53:17 am'! -!PluggableListMorphOfMany methodsFor: 'events' stamp: 'jmv 3/17/2021 09:53:05' prior: 16889271 overrides: 50391338! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - - dragOnOrOff _ false. "So improperly started drags will have not effect" - dragStartRow _ nil! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4537-PluggableListMorphOfMany-fix-JuanVuletich-2021Mar17-09h53m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4537] on 21 March 2021 at 5:16:51 pm'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 3/21/2021 13:05:45'! - restorePatch: savedPatch bounds: savedBounds - "Argument must previously be obtained by calling #savePatch:bounds: - Senders should not assume anything about the returned object, except that it will not be nil." - -self flag: #jmvHacks. -"Podriamos usar un BitBlt guardado. Este metodo termina haciendo demasiadas cosas... (innecesarias)" - self - image: savedPatch - at: savedBounds origin - sourceRect: (0@0 extent: savedBounds extent)! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 3/21/2021 12:44:53' prior: 50536723! - imageForm: extent depth: depth - | canvas | - canvas _ MorphicCanvas depth: depth over: (self morphPosition extent: (self morphExtent min: extent)) encompassingIntegerRectangle. - canvas fullDraw: self. - ^ canvas form divideByAlpha! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 3/21/2021 07:20:22' prior: 50559935! - displayFullBounds - "Answer a rectangle that completely bounds receiver and submorphs when last drawn - (if the world was to be fully drawn, i.e. only to be used on a Canvas on the full world)." - - | answer | - answer _ self displayBounds. - answer ifNil: [ ^nil ]. - (self submorphsMightProtrude and: [self clipsSubmorphsReally not]) ifTrue: [ - self submorphsReverseDo: [ :m | - answer _ answer quickMerge: m displayFullBounds ]]. - ^answer encompassingIntegerRectangle! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 3/21/2021 17:07:13' prior: 50471046! - needsToBeDrawn - "Return true if this hand must be drawn explicitely instead of being drawn via the hardware cursor. This is the case if it (a) it is a remote hand, (b) it is showing a temporary cursor, or (c) it is not empty and there are any visible submorphs. If using the software cursor, ensure that the hardware cursor is hidden." - "Details: Return true if this hand has a saved patch to ensure that is is processed by the world. This saved patch will be deleted after one final display pass when it becomes possible to start using the hardware cursor again. This trick gives us one last display cycle to allow us to remove the software cursor from the display." - "Note. We draw the hand as a regular morph (using #drawOn:), disabling the hardware cursor, when we carry submorphs. The reason is to lock the mouse pointer and the carried morph together. Otherwhise the carried morph would lag behind the mouse pointer. - This method answers whether the regular #drawOn: drawing mechanism is used for us. - - Check senders. Hand drawing is handled explicitly by the world, because the Hand is not a submorph of the world!!" - | blankCursor | - (prevFullBounds notNil or: [ - submorphs anySatisfy: [ :ea | - ea visible ]]) ifTrue: [ - "using the software cursor; hide the hardware one" - blankCursor _ Cursor cursorAt: #blankCursor. - Cursor currentCursor == blankCursor ifFalse: [ blankCursor activateCursor ]. - ^ true ]. - ^ false.! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 3/21/2021 17:06:17' prior: 50557074! - restoreSavedPatchOn: aCanvas - "Clear the changed flag and restore the part of the given canvas under this hand from the previously saved patch. If necessary, handle the transition to using the hardware cursor." - hasChanged _ false. - prevFullBounds ifNotNil: [ - aCanvas restorePatch: savedPatch bounds: prevFullBounds. - submorphs notEmpty ifTrue: [ ^ self ]. - "Make the transition to using hardware cursor. Clear savedPatch and - report one final damage rectangle to erase the image of the software cursor." - " owner invalidateDisplayRect: (savedPatch offset extent: savedPatch extent) from: nil." - self invalidateDisplayRect: (self morphPosition extent: extent) for: nil. - Cursor currentCursor == Cursor defaultCursor ifFalse: [ Cursor defaultCursor activateCursor ]. - "show hardware cursor" - prevFullBounds _ nil ].! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 3/21/2021 07:20:15' prior: 50538005 overrides: 50566181! - displayFullBounds - "Current full bounds of hand and carried submorphs. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around)." - | fullBounds | - fullBounds _ self displayBounds. - self submorphsDo: [ :m | - fullBounds _ fullBounds quickMerge: m displayFullBounds]. - lastPosition - ifNotNil: [ :lastPos | "When already carrying morphs around. Include also the rectangle updated to current hand position." - fullBounds _ fullBounds quickMerge: (fullBounds translatedBy: self morphPosition-lastPos) ]. - ^fullBounds encompassingIntegerRectangle! ! -!WorldMorph methodsFor: 'interaction loop' stamp: 'jmv 3/21/2021 07:27:48' prior: 50564974! - mainLoop - - - self clearWaitDelay. - [ - self doOneCycle. - true ] - whileTrue: []! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 3/21/2021 07:28:10' prior: 50555257! - displayWorldSafely - "Update this world's display and keep track of errors during draw methods." - - [self displayWorld] ifError: [ :err :rcvr | - "Handle a drawing error" - canvas currentMorphDrawingFails. - "Install the old error handler, so we can re-raise the error" - rcvr error: err. - ]! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 3/21/2021 17:16:08' prior: 50540419! - savePatch: prevSavedPatch bounds: aRectangle - "Senders don't need to know any details of what is answered, but just store it for further calls, and calls to restorePatch:" - "Details: The previously used patch Form is recycled when possible to reduce the burden on storage management." - | savedPatch bb prevExtent extent | - savedPatch _ prevSavedPatch. - prevExtent _ 0@0. - ((savedPatch is: #Form) and: [ - prevExtent _ savedPatch extent. - prevExtent >= aRectangle extent]) - ifTrue: [ - savedPatch offset: 0@0 ] - ifFalse: [ - "allocate new patch form if needed" - extent _ aRectangle extent max: prevExtent. - extent _ (extent x // 64 + 2 * 64) @ (extent y + 64). "Make it slightly larger, and even width." - savedPatch _ Form extent: extent depth: form depth ]. - bb _ BitBlt toForm: savedPatch. - bb sourceForm: form; combinationRule: Form over; - sourceX: aRectangle left; sourceY: aRectangle top; - width: aRectangle width; height: aRectangle height; - copyBits. - ^savedPatch! ! - -MorphicCanvas removeSelector: #restorePatch:! - -!methodRemoval: MorphicCanvas #restorePatch: stamp: 'Install-4538-MorphicFrameworkTweaks-JuanVuletich-2021Mar21-16h57m-jmv.001.cs.st 4/9/2021 16:04:12'! -restorePatch: savedPatch - "Argument must previously be obtained by calling #savePatch:bounds: - Senders should not assume anything about the returned object, except that it will not be nil." - -self flag: #jmvHacks. -"Podriamos usar un BitBlt guardado. Este metodo termina haciendo demasiadas cosas... (innecesarias)" - self - image: savedPatch - at: savedPatch offset.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4538-MorphicFrameworkTweaks-JuanVuletich-2021Mar21-16h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4538] on 22 March 2021 at 4:36:29 pm'! -!SetInspector methodsFor: 'selecting' stamp: 'jmv 3/22/2021 16:35:54' prior: 16907452! - arrayIndexForSelection - ^ (self fieldList at: selectionIndex) asNumber! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4539-SetInspectorFix-JuanVuletich-2021Mar22-16h00m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4526] on 14 February 2021 at 10:27:09 am'! -!Inspector methodsFor: 'contents' stamp: 'jpb 2/14/2021 09:59:32' prior: 50369355 overrides: 16934336! - acceptedStringOrText - "We need our cache not to be modified by user changes" - ^(acceptedContentsCache ifNil: '') copy! ! -!Inspector methodsFor: 'selecting' stamp: 'jpb 2/14/2021 10:24:54' prior: 50515814! - selectionPrintString - "Returns the current selection as a string" - ^self safelyPrintWith: [ - | selectedValue | - selectedValue _ self selection. - (selectedValue is: #String) - ifTrue: [ selectedValue ] - ifFalse: [ selectedValue printTextLimitedTo: self printStringLimit]]! ! - -Inspector removeSelector: #stringSelectionIndices! - -!methodRemoval: Inspector #stringSelectionIndices stamp: 'Install-4540-InspectorFix-JosefPhilipBernhart-2021Feb14-09h30m-jpb.001.cs.st 4/9/2021 16:04:12'! -stringSelectionIndices - - ^#(0 2)! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4540-InspectorFix-JosefPhilipBernhart-2021Feb14-09h30m-jpb.001.cs.st----! - -'From Cuis 5.0 [latest update: #4540] on 22 March 2021 at 5:11:12 pm'! - -DictionaryInspector removeSelector: #stringSelectionIndices! - -!methodRemoval: DictionaryInspector #stringSelectionIndices stamp: 'Install-4541-Cleanup-JuanVuletich-2021Mar22-17h10m-jmv.001.cs.st 4/9/2021 16:04:12'! -stringSelectionIndices - - ^#(0)! - -CompiledMethodInspector removeSelector: #stringSelectionIndices! - -!methodRemoval: CompiledMethodInspector #stringSelectionIndices stamp: 'Install-4541-Cleanup-JuanVuletich-2021Mar22-17h10m-jmv.001.cs.st 4/9/2021 16:04:12'! -stringSelectionIndices - - ^#(0 2 3)! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4541-Cleanup-JuanVuletich-2021Mar22-17h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4541] on 22 March 2021 at 5:18:56 pm'! -!Preferences class methodsFor: 'personalization' stamp: 'jmv 3/22/2021 17:18:15'! -stylingWithEmphasisInWorkspaces - ^ self - valueOfFlag: #stylingWithEmphasisInWorkspaces - ifAbsent: [false]! ! -!Workspace methodsFor: 'user interface support' stamp: 'jmv 3/22/2021 17:17:29' prior: 50556698 overrides: 50556692! - allowStylingWithEmphasis - "Disabled by default for faster styling of large contents, as text metrics are not affected by styling." - - ^ Preferences stylingWithEmphasisInWorkspaces! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4542-StylingWithEmphasisInWorkspacesPreference-JuanVuletich-2021Mar22-17h16m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4542] on 23 March 2021 at 1:03:48 pm'! -!BitBltCanvasEngine methodsFor: 'text' stamp: 'jmv 3/23/2021 13:02:51' prior: 50453515! - basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font - "Answer position to place next glyph" - - destY _ aPoint y. - destX _ aPoint x. - - "the following are not really needed, but theBitBlt primitive will fail if not set" - sourceX ifNil: [sourceX _ 100]. - width ifNil: [width _ 100]. - - self primDisplayString: aString from: startIndex to: stopIndex - map: font characterToGlyphMap xTable: font xTable - kern: font baseKern. - ^ destX@(destY+font lineSpacing)! ! -!BitBltCanvasEngine methodsFor: 'text' stamp: 'jmv 3/23/2021 13:03:01' prior: 50453533! - displayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: aStrikeFont color: foregroundColor - "If required, do a second pass with new rule and colorMap. - Answer position to place next glyph - Answer nil if nothing was done - " - - | answer prevRule secondPassMap sourceDepth destDepth | - - "Slight optimization when there's nothing to do." - clipHeight = 0 ifTrue: [^nil]. - clipWidth = 0 ifTrue: [^nil]. - - self installStrikeFont: aStrikeFont foregroundColor: (foregroundColor alpha: 1). - - "If combinationRule is rgbMul, we might need the special two-pass technique for component alpha blending. - If not, do it simply" - combinationRule = 37 "rgbMul" ifFalse: [ - ^self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: aStrikeFont ]. - - "We need to do a second pass. The colormap set is for use in the second pass." - secondPassMap _ colorMap. - sourceDepth _ sourceForm depth. - destDepth _ destForm depth. - colorMap _ sourceDepth ~= destDepth - ifTrue: [ Color cachedColormapFrom: sourceDepth to: destDepth ]. - answer := self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: aStrikeFont. - colorMap := secondPassMap. - secondPassMap ifNotNil: [ - prevRule := combinationRule. - combinationRule := 20. "rgbAdd" - self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: aStrikeFont. - combinationRule := prevRule ]. - ^answer! ! -!AbstractFont methodsFor: 'BitBltCanvas support' stamp: 'jmv 3/23/2021 13:02:41' prior: 50495017! - onBitBltCanvasEngine: engine displayString: aString from: firstIndex to: lastIndex at: p color: color - "Answer position to place next glyph - Answer nil if nothing was done" - - self subclassResponsibility! ! -!StrikeFont methodsFor: 'BitBltCanvas support' stamp: 'jmv 3/23/2021 13:03:31' prior: 50495027 overrides: 50566538! - onBitBltCanvasEngine: engine displayString: aString from: firstIndex to: lastIndex at: p color: color - "Answer position to place next glyph. - Answer nil if nothing was done." - - ^ engine - displayString: aString - from: firstIndex - to: lastIndex - at: p - strikeFont: self - color: color! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/23/2021 13:03:09' prior: 50565861! - drawString: s at: pt font: fontOrNil color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - - ^self drawString: s from: 1 to: s size at: pt font: (self fontToUse: fontOrNil) color: aColor! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/23/2021 13:03:12' prior: 50565871! - drawString: s at: pt font: fontOrNil color: aColor embossed: aBoolean - "Answer position to place next glyph - Answer nil if nothing was done" - - ^aBoolean - ifTrue: [ self drawStringEmbossed: s from: 1 to: s size at: pt font: (self fontToUse: fontOrNil) color: aColor ] - ifFalse: [ self drawString: s from: 1 to: s size at: pt font: (self fontToUse: fontOrNil) color: aColor ]! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/23/2021 13:03:19' prior: 50565886! - drawString: s atBaseline: pt font: fontOrNil color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - - | font | - font _ self fontToUse: fontOrNil. - ^self drawString: s from: 1 to: s size atBaseline: pt font: font color: aColor! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/23/2021 13:03:21' prior: 50565897! - drawString: s atCenterX: pt font: fontOrNil color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - - | font | - font _ self fontToUse: fontOrNil. - ^self - drawString: s - from: 1 to: s size - at: pt - ((font widthOfString: s) / 2 @ 0) - font: font color: aColor! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/23/2021 13:03:23' prior: 50565910! - drawString: s atWaist: pt font: fontOrNil color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - - | font | - font _ self fontToUse: fontOrNil. - ^self drawString: s from: 1 to: s size atWaist: pt font: font color: aColor! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/23/2021 13:03:25' prior: 50565921! - drawString: s atWaistRight: pt font: fontOrNil color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - - | font | - font _ self fontToUse: fontOrNil. - ^self - drawString: s - from: 1 to: s size - atWaist: pt - ((font widthOfString: s) @ 0) - font: font color: aColor! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/23/2021 13:03:27' prior: 50565964! - drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint font: font color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - - aColor = `Color black` ifFalse: [ | topColor | - topColor _ aColor alphaMixed: 0.25 with: `Color black`. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint - font: font - color: topColor ]. - aColor = `Color white` ifFalse: [ | bottomColor | - bottomColor _ aColor alphaMixed: 0.22 with: `Color white`. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + `0@2` - font: font - color: bottomColor ]. - ^self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + `0@1` - font: font - color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/23/2021 13:02:43' prior: 50565991 overrides: 50565947! - drawString: aString from: firstIndex to: lastIndex atBaseline: aPoint font: font color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - - | p1 | - engine ifNil: [ ^nil ]. - - "Don't waste any time if NOP" - lastIndex = 0 ifTrue: [ - ^nil ]. - - p1 _ currentTransformation transform: aPoint rounded. - p1 _ p1 + (0@(0 - (font ascent + font lineGap-1))). - p1 _ p1 rounded. - engine colorMap: nil. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/23/2021 13:02:45' prior: 50566012 overrides: 50566634! - drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint font: font color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - | p1 | - - engine ifNil: [ ^nil ]. - - p1 _ (currentTransformation transform: aPoint rounded) rounded. - engine colorMap: nil. - - aColor = `Color black` ifFalse: [ | topColor | - topColor _ aColor alphaMixed: 0.25 with: `Color black`. - font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: topColor ]. - aColor = `Color white` ifFalse: [ | bottomColor | - bottomColor _ aColor alphaMixed: 0.22 with: `Color white`. - font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + `0@2` - color: bottomColor ]. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + `0@1` - color: aColor.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4543-CommentFixes-JuanVuletich-2021Mar23-13h02m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4543] on 25 March 2021 at 4:34:25 pm'! -!String class methodsFor: 'instance creation' stamp: 'jmv 3/25/2021 16:33:56' prior: 50504065! - utf32FromUtf8: aByteArray - "Convert the given string from UTF-8 to UTF-32" - - ^WordArray streamContents: [ :strm | | bytes codePoint | - bytes _ aByteArray readStream. - [ bytes atEnd ] whileFalse: [ - codePoint _ (Character nextUnicodeCodePointFromUtf8: bytes). - codePoint ifNotNil: [ - strm nextPut: codePoint ]]]! ! -!String class methodsFor: 'instance creation' stamp: 'jmv 3/25/2021 16:33:31' prior: 50504078! - utf8FromUtf32: aWordArray - "Convert the given string from UTF-8 to UTF-32" - - ^ByteArray streamContents: [ :strm | - aWordArray do: [ :codePoint | - Character - evaluate: [ :byte | strm nextPut: byte ] - withUtf8BytesOfUnicodeCodePoint: codePoint ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4544-WordArrayForUtf32-JuanVuletich-2021Mar25-15h55m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4542] on 25 March 2021 at 7:24:40 pm'! -!BitBltCanvas methodsFor: 'drawing' stamp: 'jmv 3/25/2021 19:23:57' prior: 50561000! - drawCoordinateSystem: aRectangle - | c stepX stepY x0 x1 y0 y1 | - stepX _ 100. - stepY _ 50. - - self frameRectangle: aRectangle borderWidth: 4 color: `Color lightGray alpha: 0.4`. - - x0 _ aRectangle left. - x1 _ aRectangle right-1. - y0 _ aRectangle top. - y1 _ aRectangle bottom-1. - - c _ `Color lightGray alpha: 0.6`. - self line: x0@0 to: x1@0 width: 2 color: c. - self line: 0@y0 to: 0@y1 width: 2 color: c. - - (x0 truncateTo: stepX) to: (x1 - stepX truncateTo: stepX) by: stepX do: [ :x | - self line: x @ -5 to: x @ 5 width: 2 color: c. - self drawString: x printString atCenterX: x @ 5 font: nil color: c ]. - self drawString: 'x' atCenterX: x1 - 15 @ 0 font: nil color: c. - - (y0 truncateTo: stepY) to: (y1 - stepY truncateTo: stepY) by: stepY do: [ :y | - self line: -5 @ y to: 5 @ y width: 2 color: c. - self drawString: y printString, ' ' atWaist: 5 @ y font: nil color: c ]. - self drawString: 'y' atWaist: 0 @ (y1 - 20) font: nil color: c.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4545-LessInvasiveCoordinateAxes-JuanVuletich-2021Mar25-19h23m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4545] on 26 March 2021 at 10:12:37 am'! - -StrikeFont removeSelector: #useRightArrow! - -!methodRemoval: StrikeFont #useRightArrow stamp: 'Install-4546-RemoveSupportForRightArrowAssignment-JuanVuletich-2021Mar26-09h35m-jmv.001.cs.st 4/9/2021 16:04:12'! -useRightArrow - "Use right arrow glyph instead of underscore, and up arrow glyph instead of caret" - self characterToGlyphMap. - characterToGlyphMap at: 96 put: 29. - characterToGlyphMap at: 95 put: 30! - -Preferences class removeSelector: #useAssignmentGlyphRightArrow! - -!methodRemoval: Preferences class #useAssignmentGlyphRightArrow stamp: 'Install-4546-RemoveSupportForRightArrowAssignment-JuanVuletich-2021Mar26-09h35m-jmv.001.cs.st 4/9/2021 16:04:12'! -useAssignmentGlyphRightArrow - " - Preferences useAssignmentGlyphRightArrow - " - Preferences setPreference: #assignmentGlyphSelector toValue: #useRightArrow. - AbstractFont withAllSubclassesDo: [ :fontClass | fontClass assignmentGlyphSelectorPreferenceChanged ].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4546-RemoveSupportForRightArrowAssignment-JuanVuletich-2021Mar26-09h35m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4546] on 26 March 2021 at 3:52:33 pm'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 3/26/2021 15:52:10' prior: 16877475! - drawCurrentAsOutline - - self isCurrentMorphVisible ifTrue: [ - self - reverseRectangleBorder: currentMorph morphLocalBounds - borderWidth: 2. - world notNil ifTrue: [ "Only if we are drawing the world" - currentMorph displayBounds: self boundingRectOfCurrentMorphAfterDraw ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4547-CheapWindowReframe-fix-JuanVuletich-2021Mar26-15h51m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4547] on 26 March 2021 at 4:09:31 pm'! -!Morph methodsFor: 'halos and balloon help' stamp: 'ar 11/7/1999 18:57' prior: 16875632! - addHalo - "Invoke a halo programatically (e.g., not from a meta gesture)" - ^self addHalo: nil! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 3/26/2021 16:09:26' prior: 50560971! - addHalo: evt - "Defer execution until next cycle, so if you evaluate - BrowserWindow openBrowser addHalo - the window is in the world and with proper bounds, before adding the halo. - " - | halo | - self whenUIinSafeState: [ - self displayBoundsForHalo ifNotNil: [ :r | - halo _ HaloMorph new. - halo popUpFor: self event: evt. - halo morphBounds: r ]. - self redrawNeeded]. - ^halo! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4548-AddHaloFix-JuanVuletich-2021Mar26-16h06m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4547] on 26 March 2021 at 4:19:22 pm'! -!Preferences class methodsFor: 'standard queries' stamp: 'jmv 3/26/2021 16:16:18'! - halosShowCoordinateSystem - ^ self - valueOfFlag: #halosShowCoordinateSystem - ifAbsent: [ true ]! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 3/26/2021 16:16:00' prior: 50565816 overrides: 50564923! - drawCurrentAndSubmorphs - - self isCurrentMorphVisible ifTrue: [ - - currentMorph drawOn: self. - world notNil ifTrue: [ "Only if we are drawing the world" - currentMorph displayBounds: self boundingRectOfCurrentMorphAfterDraw ]. - - "Display submorphs back to front" - "coordinate system stack already set up for aMorph - ('ivars transformations' and 'currentTransformation')" - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | self fullDraw: m ]]. - - currentMorph postDrawOn: self. - world notNil ifTrue: [ "Only if we are drawing the world" - currentMorph displayBounds: - (currentMorph displayBounds quickMerge: self boundingRectOfCurrentMorphAfterDraw) ]. - - currentMorph isHighlighted ifTrue: [ - self drawCurrentMorphHighlight ]. - world notNil ifTrue: [ - currentMorph halo ifNotNil: [ - Preferences halosShowCoordinateSystem ifTrue: [ - self drawCoordinateSystem: currentMorph morphLocalBounds ]]]. - - world notNil ifTrue: [ "Only if we are drawing the world" - currentMorph displayBounds: - (currentMorph displayBounds quickMerge: self boundingRectOfCurrentMorphAfterDraw) ]. - ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4549-halosShowCoordinateSystem-preference-JuanVuletich-2021Mar26-16h09m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4549] on 29 March 2021 at 3:26:32 am'! -!WorldMorph methodsFor: 'interaction loop' stamp: 'jmv 3/29/2021 03:26:19' prior: 50566299! - mainLoop - - - self clearWaitDelay. - canvas isNil ifTrue: [ - self setCanvas: Display getCanvas. - damageRecorder _ DamageRecorder new ]. - self redrawNeeded. - [ - self doOneCycle. - true ] - whileTrue: []! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4550-NewReleaseStartupFix-JuanVuletich-2021Mar29-03h26m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4550] on 29 March 2021 at 10:28:21 am'! -!Compiler class methodsFor: 'evaluating' stamp: 'HAW 3/29/2021 10:26:03' prior: 16822115! - evaluate: textOrString - "See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs, - a Syntax Error view is created rather than notifying any requestor. - Compilation is carried out with respect to nil, i.e., no object, and the - invocation is not logged." - - "See SHST80RangeType>>#receiverAsNumber - Hernan" - ^[ self evaluate: textOrString for: nil logged: false ] - on: SyntaxErrorNotification - do: [ :anError | anError return: nil ]! ! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'HAW 3/29/2021 10:16:33' prior: 50545479! - receiverAsNumber - - "if the user typed 1xe for example, asNumber will throw an exception because it is not a valid number - even though the SHParser recognized it as such. I return nil because it is not really a number. - Thank you Luciano for reporting the bug - Hernan" - ^[ (self sourceCodeIn: receiverRange) asNumber ] - on: Error - do: [ :anError | anError return: nil ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4551-InvalidNumberOnSyntaxHL-HernanWilkinson-2021Mar29-10h16m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4551] on 30 March 2021 at 6:33:01 am'! - -Object subclass: #Random - instanceVariableNames: '' - classVariableNames: 'ConcreteSubclass DefaultInstance MutexForDefaultInstance ' - poolDictionaries: '' - category: 'Kernel-Numbers'! - -!classDefinition: #Random category: #'Kernel-Numbers' stamp: 'Install-4552-RandomDoubleInitializationFix-LucianoEstebanNotarfrancesco-2021Mar30-06h22m-len.001.cs.st 4/9/2021 16:04:12'! -Object subclass: #Random - instanceVariableNames: '' - classVariableNames: 'ConcreteSubclass DefaultInstance MutexForDefaultInstance' - poolDictionaries: '' - category: 'Kernel-Numbers'! -!Random class methodsFor: 'instance creation' stamp: 'len 3/30/2021 06:24:49' prior: 16897870 overrides: 16783533! - new - ^ self seed: Time millisecondClockValue! ! -!Random class methodsFor: 'instance creation' stamp: 'len 3/30/2021 06:26:50' prior: 16897880! - seed: anInteger - ^ (self = Random ifTrue: [ParkMiller93Random] ifFalse: [self]) basicNew seed: anInteger! ! -!Random class methodsFor: 'cached state access' stamp: 'len 3/30/2021 06:27:11' prior: 16897895 overrides: 50510040! - releaseClassCachedState - DefaultInstance _ nil. - MutexForDefaultInstance _ nil! ! -!LaggedFibonacciRandom methodsFor: 'private' stamp: 'len 3/30/2021 06:31:16' prior: 50462929 overrides: 16897855! - seed: anInteger - ring isNil ifTrue: [ring _ self newRing]. - self last: 1. - self initializeRingWith: (ParkMiller93Random seed: anInteger)! ! - -ParkMiller88Random removeSelector: #initialize! - -!methodRemoval: ParkMiller88Random #initialize stamp: 'Install-4552-RandomDoubleInitializationFix-LucianoEstebanNotarfrancesco-2021Mar30-06h22m-len.001.cs.st 4/9/2021 16:04:12'! -initialize - "Output stabilization is the user's responsibility" - - [ - seed _ (Time localMillisecondClock + self identityHash) hashMultiply \\ self m. - seed = 0 "zero seeds are unacceptable" - ] whileTrue. - seed _ seed asFloat! - -LaggedFibonacciRandom removeSelector: #initialize! - -!methodRemoval: LaggedFibonacciRandom #initialize stamp: 'Install-4552-RandomDoubleInitializationFix-LucianoEstebanNotarfrancesco-2021Mar30-06h22m-len.001.cs.st 4/9/2021 16:04:12'! -initialize - - self ring: self newRing. - self last: 1. - self initializeRingWith: ParkMiller93Random new! - -Random class removeSelector: #concreteRandomClass! - -!methodRemoval: Random class #concreteRandomClass stamp: 'Install-4552-RandomDoubleInitializationFix-LucianoEstebanNotarfrancesco-2021Mar30-06h22m-len.001.cs.st 4/9/2021 16:04:12'! -concreteRandomClass - - ConcreteSubclass ifNil: [ - ConcreteSubclass _ ParkMiller93Random ]. - ^ConcreteSubclass! - -Random class removeSelector: #newDefault! - -!methodRemoval: Random class #newDefault stamp: 'Install-4552-RandomDoubleInitializationFix-LucianoEstebanNotarfrancesco-2021Mar30-06h22m-len.001.cs.st 4/9/2021 16:04:12'! -newDefault - - ^self concreteRandomClass new! - -Object subclass: #Random - instanceVariableNames: '' - classVariableNames: 'DefaultInstance MutexForDefaultInstance' - poolDictionaries: '' - category: 'Kernel-Numbers'! - -!classDefinition: #Random category: #'Kernel-Numbers' stamp: 'Install-4552-RandomDoubleInitializationFix-LucianoEstebanNotarfrancesco-2021Mar30-06h22m-len.001.cs.st 4/9/2021 16:04:12'! -Object subclass: #Random - instanceVariableNames: '' - classVariableNames: 'DefaultInstance MutexForDefaultInstance' - poolDictionaries: '' - category: 'Kernel-Numbers'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4552-RandomDoubleInitializationFix-LucianoEstebanNotarfrancesco-2021Mar30-06h22m-len.001.cs.st----! - -'From Cuis 5.0 [latest update: #4552] on 5 April 2021 at 12:31:08 pm'! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 4/5/2021 12:26:36' prior: 50566850! - addHalo - "Invoke a halo programatically (e.g., not from a meta gesture)" - self addHalo: nil! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 4/5/2021 12:29:16' prior: 50562634! - transferHalo: event from: formerHaloOwner - "Progressively transfer the halo to the next likely recipient" - - formerHaloOwner == self - ifFalse: [ - self addHalo: event. - ^self ]. - - event shiftPressed ifTrue: [ - "Pass it outwards" - owner ifNotNil: [ - owner transferHalo: event from: formerHaloOwner. - ^self ]. - "We're at the top level; just keep it on ourselves" - ^self ]. - - self submorphsDo: [ :m | - (m wantsHalo and: [ m fullContainsGlobalPoint: event eventPosition ]) - ifTrue: [ - m transferHalo: event from: formerHaloOwner. - ^self ]]. - "We're at the bottom most level; just keep halo on ourselves"! ! -!HaloMorph methodsFor: 'event handling' stamp: 'jmv 4/5/2021 12:28:21' prior: 16850681! - transferHalo: event localPosition: localEventPosition - "Transfer the halo to the next likely recipient" - target ifNil: [ - self delete. - ^ self ]. - target transferHalo: event from: target.! ! -!MenuMorph methodsFor: 'initialization' stamp: 'jmv 4/5/2021 12:27:42' prior: 50564853 overrides: 16876882! - delete - activeSubMenu ifNotNil: [activeSubMenu delete]. - self itemsDo: [ :i | i deselect ]. - super delete! ! -!SmalltalkCompleterMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 4/5/2021 12:27:30' prior: 50528884 overrides: 16876882! - delete - - selectorDocumentation ifNotNil: [ - selectorDocumentation delete. - selectorDocumentation := nil ]. - - super delete ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4553-RemoveUnnededReturns-JuanVuletich-2021Apr05-12h26m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4552] on 5 April 2021 at 12:32:57 pm'! -!HaloMorph methodsFor: 'events' stamp: 'jmv 4/5/2021 12:32:51' prior: 16850637 overrides: 50544256! - mouseButton3Down: aMouseButtonEvent localPosition: localEventPosition - "Transfer the halo to the next likely recipient" - target ifNil: [ - self delete. - ^self]. - aMouseButtonEvent hand obtainHalo: self. - positionOffset _ aMouseButtonEvent eventPosition - target morphPositionInWorld. - "wait for click to transfer halo" - aMouseButtonEvent hand - waitForClicksOrDrag: self - event: aMouseButtonEvent - clkSel: #transferHalo:localPosition: - dblClkSel: nil! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4554-RemoveUnnededReturn-JuanVuletich-2021Apr05-12h31m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4552] on 5 April 2021 at 12:40:13 pm'! -!Morph methodsFor: 'events' stamp: 'jmv 4/5/2021 12:39:04' prior: 50544256! - mouseButton3Down: aMouseButtonEvent localPosition: localEventPosition - - self addHalo: aMouseButtonEvent.! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 4/5/2021 12:39:28' prior: 50566856! - addHalo: evt - "Defer execution until next cycle, so if you evaluate - BrowserWindow openBrowser addHalo - the window is in the world and with proper bounds, before adding the halo. - " - | halo | - self whenUIinSafeState: [ - self displayBoundsForHalo ifNotNil: [ :r | - halo _ HaloMorph new. - halo popUpFor: self event: evt. - halo morphBounds: r ]. - self redrawNeeded].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4555-RemoveMiddleButtonDrag-JuanVuletich-2021Apr05-12h32m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4552] on 5 April 2021 at 12:43:44 pm'! -!MenuMorph methodsFor: 'as yet unclassified' stamp: 'jmv 4/5/2021 12:42:02' overrides: 50567198! - addHalo: evt - self stayUp. - super addHalo: evt! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4556-MenusStayUpIfHalo-JuanVuletich-2021Apr05-12h40m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4552] on 5 April 2021 at 12:47:10 pm'! -!HaloMorph methodsFor: 'private' stamp: 'jmv 4/5/2021 12:46:44' prior: 50562491! - maybeCollapse: event with: aHandle - "Ask hand to collapse my target if mouse comes up in it." - - event hand obtainHalo: self. - (aHandle containsGlobalPoint: event eventPosition) - ifTrue: [ - target collapse ]. - self delete.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4557-FixCollapseBug-JuanVuletich-2021Apr05-12h43m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4552] on 5 April 2021 at 1:02:00 pm'! -!HaloMorph methodsFor: 'event handling' stamp: 'jmv 4/5/2021 12:56:17'! - popUpFor: aMorph handPosition: handPosition hand: hand - - hand halo: self. - hand world addMorphFront: self. - self target: aMorph. - positionOffset _ handPosition - aMorph morphPositionInWorld! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 4/5/2021 12:59:49' prior: 50567198! - addHalo: aMorphicEvent - "Defer execution until next cycle, so if you evaluate - BrowserWindow openBrowser addHalo - the window is in the world and with proper bounds, before adding the halo. - " - - | hand position | - aMorphicEvent - ifNil: [ - hand _ self world activeHand. - hand ifNil: [ hand _ self world firstHand ]. - position _ hand lastMouseEvent eventPosition ] - ifNotNil: [ - hand _ aMorphicEvent hand. - position _ aMorphicEvent eventPosition ]. - - self whenUIinSafeState: [ - HaloMorph new popUpFor: self handPosition: position hand: hand - ]! ! - -HaloMorph removeSelector: #popUpFor:event:! - -!methodRemoval: HaloMorph #popUpFor:event: stamp: 'Install-4558-AddHaloRefactor-JuanVuletich-2021Apr05-12h47m-jmv.001.cs.st 4/9/2021 16:04:12'! -popUpFor: aMorph event: aMorphicEvent - "This message is sent by morphs that explicitly request the halo on a button click. Note: anEvent is in aMorphs coordinate frame." - - | hand anEvent | - self flag: #workAround. "We should really have some event/hand here..." - anEvent _ aMorphicEvent - ifNil: [ - hand _ aMorph world activeHand. - hand ifNil: [ hand _ aMorph world firstHand ]. - hand lastMouseEvent ] - ifNotNil: [ - hand _ aMorphicEvent hand. - aMorphicEvent ]. - hand halo: self. - hand world addMorphFront: self. - self target: aMorph. - positionOffset _ anEvent eventPosition - aMorph morphPositionInWorld! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4558-AddHaloRefactor-JuanVuletich-2021Apr05-12h47m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4558] on 5 April 2021 at 3:39:29 pm'! -!UISupervisor class methodsFor: 'gui process' stamp: 'jmv 4/5/2021 15:37:00'! - userInterrupt: aProcess - "Create a Notifier on the active scheduling process with the given label." - | process | - process _ aProcess. - - "Only debug aProcess if its priority is >= UIProcess' priority" - UIProcess ifNotNil: [ - process priority < UIProcess priority ifTrue: [ - process _ UIProcess ]]. - - Debugger interruptProcess: process label: 'User Interrupt'! ! -!ProcessBrowser class methodsFor: 'CPU utilization' stamp: 'jmv 4/5/2021 15:30:04' prior: 50379405! - dumpPigStackOn: aStream - "Must run forked on its own process, so the monitored behavior is not affected too much" - - | promise tally process depth stack suspendedContext | - promise := Processor tallyCPUUsageFor: 1 every: 10. - tally := promise value. - "UISupervisor whenUIinSafeState: [self dumpTallyOnTranscript: tally]." - aStream nextPutAll: '====Al processes===='; newLine. - self dumpTally: tally on: aStream. - aStream newLine; nextPutAll: '====Process using most CPU===='; newLine. - process _ tally sortedCounts first value. - (100.0 * (tally occurrencesOf: process) / tally size) rounded printOn: aStream. - aStream - nextPutAll: ' % '; - nextPutAll: (process browserPrintStringFull: false); - newLine. - depth _ 20. - stack _ process == Processor activeProcess - ifTrue: [thisContext stackOfSize: depth] - ifFalse: [suspendedContext _ process suspendedContext. - suspendedContext - ifNotNil: [suspendedContext stackOfSize: depth]]. - stack - ifNil: [ aStream nextPutAll: 'No context'; newLine] - ifNotNil: [ - stack do: [ :c | - c printOn: aStream. - aStream newLine ]]. - ^process! ! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jmv 4/5/2021 15:37:58' prior: 50526383! - handleUserInterrupt - | p | - p _ Utilities reportCPUandRAM. - Preferences cmdDotEnabled ifTrue: [ - [ UISupervisor userInterrupt: p ] fork]! ! -!Utilities class methodsFor: 'vm statistics' stamp: 'jmv 4/5/2021 15:39:00' prior: 16941529! - reportCPUandRAM - "Write several text files with useful analysis for profiling purposes. - Overwrites any existing report. - Utilities reportCPUandRAM - " - - | profiler pig | - - "VM statistics (Memory use and GC, mainly)" - 'MemoryStats.txt' asFileEntry forceWriteStreamDo: [ :stream | - stream nextPutAll: self vmStatisticsReportString ]. - - "Process list" - 'ProcessList.txt' asFileEntry forceWriteStreamDo: [ :stream | - ProcessBrowser new processNameList - do: [ :each | - stream nextPutAll: each; newLine ]]. - - "Process taking most CPU" - 'ThePig.txt' asFileEntry forceWriteStreamDo: [ :stream | - pig _ ProcessBrowser dumpPigStackOn: stream ]. - - "Tally of all processes" - AndreasSystemProfiler canWork ifTrue: [ - 'FullTally.txt' asFileEntry forceWriteStreamDo: [ :stream | - profiler _ AndreasSystemProfiler new. - profiler spyOn: [ (Delay forMilliseconds: 1000) wait ]. - profiler - reportTextOn: stream - linesOn: (DummyStream on: nil) - talliesOn: (DummyStream on: nil) ]]. - - "Memory Analysis" - 'MemoryAnalysis.txt' asFileEntry forceWriteStreamDo: [ :stream | - SpaceTally new printSpaceAnalysis: 1 on: stream ]. - - ^pig! ! - -UISupervisor class removeSelector: #userInterrupt! - -!methodRemoval: UISupervisor class #userInterrupt stamp: 'Install-4559-UserInterruptFix-JuanVuletich-2021Apr05-15h37m-jmv.001.cs.st 4/9/2021 16:04:12'! -userInterrupt - "Create a Notifier on the active scheduling process with the given label." - | preemptedProcess | - preemptedProcess _ Processor preemptedProcess. - - "Only debug preempted process if its priority is >= UIProcess' priority" - UIProcess ifNotNil: [ - preemptedProcess priority < UIProcess priority ifTrue: [ - preemptedProcess _ UIProcess ]]. - - Debugger interruptProcess: preemptedProcess label: 'User Interrupt'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4559-UserInterruptFix-JuanVuletich-2021Apr05-15h37m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4558] on 5 April 2021 at 3:50:39 pm'! -!HaloMorph methodsFor: 'private' stamp: 'jmv 4/5/2021 14:52:12'! - addHandles: aDisplayRectangle - "update my size. owner is world, therefore owner coordinates are Display coordinates." - - self morphBounds: aDisplayRectangle. - haloBox _ self handlesBox. - target addHandlesTo: self box: haloBox. - self addNameString: (target printStringLimitedTo: 40). - self redrawNeeded.! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 4/5/2021 14:40:52'! - handlesBox - "handlesBox is in local coordinates. - We assume we are direct submorph of the world, without any scaling or rotation." - - | minSide hs c e box | - hs _ Preferences haloHandleSize. - minSide _ 4 * hs. - e _ extent + (hs*2) max: minSide@minSide. - c _ extent // 2 + self morphPosition. - box _ Rectangle center: c extent: e. - self world ifNotNil: [ :w | box _ box intersect: (w viewBox insetBy: (hs@hs corner: hs@(hs*3))) ]. - "Make it local" - ^box translatedBy: self morphPosition negated. -! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 4/5/2021 14:50:49' prior: 50567259! - addHalo: aMorphicEventOrNil - - | hand position | - aMorphicEventOrNil - ifNil: [ - hand _ self world activeHand. - hand ifNil: [ hand _ self world firstHand ]. - position _ hand lastMouseEvent eventPosition ] - ifNotNil: [ - hand _ aMorphicEventOrNil hand. - position _ aMorphicEventOrNil eventPosition ]. - - HaloMorph new popUpFor: self handPosition: position hand: hand! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 4/5/2021 15:50:34' prior: 50559341! - addHandles - - self removeAllMorphs. "remove old handles, if any" - target isInWorld ifTrue: [ "If not in world, not even bother" - target displayBoundsForHalo - ifNotNil: [ :r | self addHandles: r] "If target has already been drawn and has bounds, go ahead" - ifNil: [ - self whenUIinSafeState: [ "Otherwise, see if in next cycle target gets drawn and its bounds known" - target displayBoundsForHalo - ifNotNil: [ :r | self addHandles: r]]] - ]! ! - -HaloMorph removeSelector: #basicBox! - -!methodRemoval: HaloMorph #basicBox stamp: 'Install-4560-AddHaloFix-JuanVuletich-2021Apr05-15h39m-jmv.001.cs.st 4/9/2021 16:04:12'! -basicBox - "basicBox is in local coordinates" - - | minSide e hs box | - hs _ Preferences haloHandleSize. - minSide _ 4 * hs. - e _ extent + (hs*2) max: minSide@minSide. - box _ target displayBoundsForHalo. - box _ Rectangle center: box center extent: e. - self world ifNotNil: [ :w | box _ box intersect: (w viewBox insetBy: (hs@hs corner: hs@(hs*3))) ]. - ^box translatedBy: self morphPosition negated. -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4560-AddHaloFix-JuanVuletich-2021Apr05-15h39m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4558] on 5 April 2021 at 4:14:24 pm'! -!BitBltCanvas methodsFor: 'drawing' stamp: 'jmv 4/5/2021 16:14:13' prior: 50566753! - drawCoordinateSystem: aRectangle - | c stepX stepY x0 x1 y0 y1 prevClipRect | - stepX _ 100. - stepY _ 50. - - prevClipRect _ self clipRect. - self setClipRect: (prevClipRect intersect:currentMorph displayBounds). - - self frameRectangle: aRectangle borderWidth: 4 color: `Color lightGray alpha: 0.4`. - - x0 _ aRectangle left. - x1 _ aRectangle right-1. - y0 _ aRectangle top. - y1 _ aRectangle bottom-1. - - c _ `Color lightGray alpha: 0.6`. - self line: x0@0 to: x1@0 width: 2 color: c. - self line: 0@y0 to: 0@y1 width: 2 color: c. - - (x0 truncateTo: stepX) to: (x1 - stepX truncateTo: stepX) by: stepX do: [ :x | - self line: x @ -5 to: x @ 5 width: 2 color: c. - self drawString: x printString atCenterX: x @ 5 font: nil color: c ]. - self drawString: 'x' atCenterX: x1 - 15 @ 0 font: nil color: c. - - (y0 truncateTo: stepY) to: (y1 - stepY truncateTo: stepY) by: stepY do: [ :y | - self line: -5 @ y to: 5 @ y width: 2 color: c. - self drawString: y printString, ' ' atWaist: 5 @ y font: nil color: c ]. - self drawString: 'y' atWaist: 0 @ (y1 - 20) font: nil color: c. - - self setClipRect: prevClipRect.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4561-BitBltCanvas-CoordinateSystem-fix-JuanVuletich-2021Apr05-15h51m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4561] on 8 April 2021 at 11:10:49 am'! -!Morph methodsFor: 'change reporting' stamp: 'jmv 4/8/2021 10:57:19' prior: 50559908! - invalidateDisplayRect: damageRect for: aMorph - " - If we clip submorphs, then we clip damageRect. - - aMorph is the morph that changed and therefore should be redrawn. In some cases, damage reporting is done by no longer occupying some area, and requesting whatever appropriate morph to be drawn there. In such cases, aMorph should be nil. See senders." - - | clippedRect b | - self visible ifFalse: [ ^self]. - - clippedRect _ damageRect. - self clipsSubmorphsReally ifTrue: [ - b _ self displayBounds. - b ifNil: [ ^self ]. - clippedRect _ damageRect intersect: b ]. - owner ifNotNil: [ - owner invalidateDisplayRect: clippedRect for: aMorph ].! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 4/8/2021 10:53:31' prior: 50559315 overrides: 50559303! - referencePosition - "Return the current reference position of the receiver" - "a rather ugly way to say #center . At least, we avoid false polymorphism" - "remove some day" - self flag: #jmvVer2. - self displayBounds ifNotNil: [ :r | r center ]. - ^ self morphExtentInWorld // 2 + self morphPositionInWorld! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 4/8/2021 10:59:15' prior: 50534245 overrides: 50537893! - displayBounds - ^ self morphPosition extent: self morphExtent ! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 4/8/2021 10:59:19' prior: 50551997 overrides: 50537893! - displayBounds - ^ 0@0 extent: extent! ! -!BitBltCanvas methodsFor: 'drawing' stamp: 'jmv 4/8/2021 10:52:51' prior: 50567527! - drawCoordinateSystem: aRectangle - | c stepX stepY x0 x1 y0 y1 prevClipRect | - stepX _ 100. - stepY _ 50. - - prevClipRect _ self clipRect. - self setClipRect: (prevClipRect intersect: currentMorph displayBounds). - - self frameRectangle: aRectangle borderWidth: 4 color: `Color lightGray alpha: 0.4`. - - x0 _ aRectangle left. - x1 _ aRectangle right-1. - y0 _ aRectangle top. - y1 _ aRectangle bottom-1. - - c _ `Color lightGray alpha: 0.6`. - self line: x0@0 to: x1@0 width: 2 color: c. - self line: 0@y0 to: 0@y1 width: 2 color: c. - - (x0 truncateTo: stepX) to: (x1 - stepX truncateTo: stepX) by: stepX do: [ :x | - self line: x @ -5 to: x @ 5 width: 2 color: c. - self drawString: x printString atCenterX: x @ 5 font: nil color: c ]. - self drawString: 'x' atCenterX: x1 - 15 @ 0 font: nil color: c. - - (y0 truncateTo: stepY) to: (y1 - stepY truncateTo: stepY) by: stepY do: [ :y | - self line: -5 @ y to: 5 @ y width: 2 color: c. - self drawString: y printString, ' ' atWaist: 5 @ y font: nil color: c ]. - self drawString: 'y' atWaist: 0 @ (y1 - 20) font: nil color: c. - - self setClipRect: prevClipRect.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4562-minorTweaks-JuanVuletich-2021Apr08-11h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4562] on 8 April 2021 at 4:07:46 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 4/8/2021 15:14:43'! - adjustDisplayBoundsBy: delta - "Private for framework use. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - aRectangle is clipped appropiately if some owner clips us." - - privateDisplayBounds ifNotNil: [ - privateDisplayBounds _ privateDisplayBounds translatedBy: delta ]. - self allMorphsDo: [ :m | m adjustDisplayBoundsBy: delta ].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 4/8/2021 15:54:04'! - displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - aRectangle is clipped appropiately if some owner clips us." - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphAfterDraw ]]].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 4/8/2021 15:27:31'! - displayBoundsUpdateFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - aRectangle is clipped appropiately if some owner clips us." - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c == aCanvas ifTrue: [ - privateDisplayBounds _ privateDisplayBounds - quickMerge: aCanvas boundingRectOfCurrentMorphAfterDraw ]]].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 4/8/2021 15:15:10' prior: 50537893! - displayBounds - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - aRectangle is clipped appropiately if some owner clips us." - - self visible ifFalse: [ ^nil ]. - ^ privateDisplayBounds! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 4/8/2021 15:09:29' prior: 50559794! - grabMorph: aMorph delta: delta - "Grab the given morph (i.e., add it to this hand and remove it from its current owner)." - - | formerOwner formerPositionInWorld | - self releaseMouseFocus. "Break focus" - - "Grab the halo if present" - self halo ifNotNil: [ :h | - (h target == aMorph or: [h target hasOwner: aMorph]) ifTrue: [ - self addMorphBack: h position: h morphPositionInWorld - self morphPositionInWorld ]]. - - "Remember previous owner and position, in case the drop is later rejected" - formerOwner _ aMorph owner. - formerOwner ifNotNil: [ - formerPositionInWorld _ aMorph morphPositionInWorld. - grabMorphData - at: aMorph - put: { formerOwner. formerPositionInWorld. } ]. - self addMorphBack: aMorph position: delta. - - aMorph displayBounds ifNotNil: [ :r | | d | - formerPositionInWorld ifNotNil: [ - d _ aMorph morphPositionInWorld - formerPositionInWorld. - d isZero ifFalse: [ - aMorph adjustDisplayBoundsBy: d ]]]. - - aMorph justGrabbedFrom: formerOwner. - formerOwner ifNotNil: [ - lastPosition _ self morphPosition ].! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 4/8/2021 15:32:07' prior: 50559585! -drawCurrentAsError - "The morph (or one of its submorphs) had an error in its drawing method." - | r w | - r _ currentMorph morphLocalBounds. - w _ r extent > `50@50` - ifTrue: [ 6 ] - ifFalse: [ 2 ]. - self - frameAndFillRectangle: r - fillColor: `Color red` - borderWidth: w - borderColor: `Color yellow`. - self line: r topLeft to: r bottomRight width: w color: `Color yellow`. - self line: r topRight to: r bottomLeft width: w color: `Color yellow`. - currentMorph displayBoundsSetFrom: self.! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 4/8/2021 15:32:21' prior: 50566830! - drawCurrentAsOutline - - self isCurrentMorphVisible ifTrue: [ - self - reverseRectangleBorder: currentMorph morphLocalBounds - borderWidth: 2. - currentMorph displayBoundsSetFrom: self ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 4/8/2021 15:45:16' prior: 50555292! - fullUpdateCurrentBounds - | isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph drawOn: self ]. - currentMorph displayBoundsSetFrom: self. - isKnownFailing ifFalse: [ - currentMorph submorphsDo: [ :m | - self fullUpdateBounds: m ]]! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 4/8/2021 15:56:00' prior: 50557161! - updateCurrentDisplayBounds - "Update displayBounds for if never set. - Useful for new morph, that are created and attached to the hand." - - currentMorph drawOn: self. - currentMorph displayBoundsSetFrom: self. - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | self updateDisplayBounds: m ]].! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 4/8/2021 15:29:15' prior: 50566885 overrides: 50564923! - drawCurrentAndSubmorphs - - self isCurrentMorphVisible ifTrue: [ - - currentMorph drawOn: self. - currentMorph displayBoundsSetFrom: self. - - "Display submorphs back to front" - "coordinate system stack already set up for aMorph - ('ivars transformations' and 'currentTransformation')" - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | self fullDraw: m ]]. - - currentMorph postDrawOn: self. - currentMorph displayBoundsUpdateFrom: self. - - currentMorph isHighlighted ifTrue: [ - self drawCurrentMorphHighlight ]. - world notNil ifTrue: [ - currentMorph halo ifNotNil: [ - Preferences halosShowCoordinateSystem ifTrue: [ - self drawCoordinateSystem: currentMorph morphLocalBounds ]]]. - - currentMorph displayBoundsUpdateFrom: self. - ].! ! - -Morph removeSelector: #displayBounds:! - -!methodRemoval: Morph #displayBounds: stamp: 'Install-4563-displayBounds-refactor-JuanVuletich-2021Apr08-16h06m-jmv.001.cs.st 4/9/2021 16:04:12'! -displayBounds: aRectangle - - self displayBounds ~= aRectangle ifTrue: [ - privateDisplayBounds _ aRectangle ].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4563-displayBounds-refactor-JuanVuletich-2021Apr08-16h06m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4562] on 8 April 2021 at 5:14:06 pm'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 4/8/2021 16:56:40'! - updateCurrentDisplayBoundsAndMerge: aRectangle - "Update displayBounds for if never set. - Useful for new morph, that are created and attached to the hand." - - | r | - currentMorph drawOn: self. - currentMorph displayBoundsSetFrom: self. - r _ self boundingRectOfCurrentMorphAfterDraw. - r _ r quickMerge: aRectangle. - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | - r _ self updateDisplayBounds: m andMerge: r ]]. - ^r! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 4/8/2021 16:56:43'! - updateDisplayBounds: aMorph andMerge: aRectangle - "Update displayBounds for if never set. - Useful for new morph, that are created and attached to the hand." - - | r | - r _ aRectangle. - aMorph visible ifTrue: [ - self into: aMorph. - r _ self canvasToUse updateCurrentDisplayBoundsAndMerge: r. - self outOfMorph - ]. - ^r! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 4/8/2021 17:13:57' prior: 50553006! - updateHandsDisplayBounds: aWorldMorph - "Update displayBounds for carried morphs if never set. - Useful for new morph, that are created and attached to the hand." - - aWorldMorph handsDo: [ :hand | - hand hasSubmorphs ifTrue: [ - self into: hand. - hand submorphsDo: [ :morph | - morph displayBounds ifNil: [ - self updateDisplayBounds: morph andMerge: nil ]]. - self outOfMorph ]]! ! - -MorphicCanvas removeSelector: #updateCurrentDisplayBounds! - -!methodRemoval: MorphicCanvas #updateCurrentDisplayBounds stamp: 'Install-4564-displayBounds-refactor-JuanVuletich-2021Apr08-16h15m-jmv.003.cs.st 4/9/2021 16:04:12'! -updateCurrentDisplayBounds - "Update displayBounds for if never set. - Useful for new morph, that are created and attached to the hand." - - currentMorph drawOn: self. - currentMorph displayBoundsSetFrom: self. - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | self updateDisplayBounds: m ]].! - -MorphicCanvas removeSelector: #updateDisplayBounds:! - -!methodRemoval: MorphicCanvas #updateDisplayBounds: stamp: 'Install-4564-displayBounds-refactor-JuanVuletich-2021Apr08-16h15m-jmv.003.cs.st 4/9/2021 16:04:12'! -updateDisplayBounds: aMorph - "Update displayBounds for if never set. - Useful for new morph, that are created and attached to the hand." - - aMorph visible ifTrue: [ - aMorph displayBounds ifNil: [ - self into: aMorph. - self canvasToUse updateCurrentDisplayBounds. - self outOfMorph - ]]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4564-displayBounds-refactor-JuanVuletich-2021Apr08-16h15m-jmv.003.cs.st----! - -'From Cuis 5.0 [latest update: #4564] on 9 April 2021 at 2:13:37 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 4/9/2021 14:13:23' prior: 50567695! - displayBoundsUpdateFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - aRectangle is clipped appropiately if some owner clips us." - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - privateDisplayBounds _ privateDisplayBounds - quickMerge: aCanvas boundingRectOfCurrentMorphAfterDraw ]]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4565-displayBounds-fix-JuanVuletich-2021Apr09-14h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4564] on 9 April 2021 at 11:56:16 am'! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jmv 4/9/2021 11:54:27'! - detectBuiltInModule: aBlock - " - Smalltalk detectBuiltInModule: [ :n | n beginsWith: 'BitBltPlugin' ] - Smalltalk detectBuiltInModule: [ :n | n beginsWith: 'Nope' ] - " - "Look for a matching builtin module (e.g., plugins). Builtin plugins are those that are compiled with the VM directly, as opposed to plugins residing in an external shared library. - Answer nil if none." - | index name | - index _ 1. - [ (name _ self listBuiltinModule: index) notNil ] whileTrue: [ - (aBlock value: name) ifTrue: [ ^name ]. - index _ index + 1. - ]. - ^nil! ! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jmv 4/9/2021 11:52:53'! - isModuleAvailable: moduleNamePrefix - " - Smalltalk isModuleAvailable: 'BitBltPlugin' - Smalltalk isModuleAvailable: 'WrongName' - " - "Look for a matching builtin module (e.g., plugins). Builtin plugins are those that are compiled with the VM directly, as opposed to plugins residing in an external shared library." - - ^ (self detectBuiltInModule: [ :n | n beginsWith: moduleNamePrefix ]) notNil! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4566-QueryVMplugins-JuanVuletich-2021Apr09-11h39m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4566] on 9 April 2021 at 2:41:58 pm'! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 4/9/2021 14:41:51' prior: 50524433! - setDefaultFont: aFontName - "Change the font on the whole system without changing point sizes." - FontFamily defaultFamilyName: aFontName. - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: { - {#setListFontTo:. Preferences standardListFont pointSize.}. - {#setMenuFontTo:. Preferences standardMenuFont pointSize.}. - {#setWindowTitleFontTo:. Preferences windowTitleFont pointSize.}. - {#setCodeFontTo:. Preferences standardCodeFont pointSize.}. - {#setButtonFontTo:. Preferences standardButtonFont pointSize.}. - }. - UISupervisor ui ifNotNil: [ :w | w fontPreferenceChanged ] - -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4567-BetterAccessorToWorld-JuanVuletich-2021Apr09-14h41m-jmv.001.cs.st----! - -----SNAPSHOT----(9 April 2021 16:04:15) Cuis5.0-4567-32.image priorSource: 7477158! - -----STARTUP---- (20 May 2021 10:28:00) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4567-32.image! - - -'From Cuis 5.0 [latest update: #4550] on 29 March 2021 at 10:53:54 am'! -!Theme methodsFor: 'other options' stamp: 'len 3/29/2021 10:36:18'! - buttonBorderWidth - ^ 1! ! -!Theme methodsFor: 'other options' stamp: 'len 3/29/2021 10:34:25'! - menuBorderWidth - ^ self roundWindowCorners ifTrue: [0] ifFalse: [1]! ! -!Theme methodsFor: 'other options' stamp: 'len 3/29/2021 10:46:06'! - scrollbarShowButtons - ^ true! ! -!Theme methodsFor: 'other options' stamp: 'len 3/29/2021 10:39:24'! - windowBorderWidth - | w | - w _ Preferences standardListFont pointSize / 11. - w _ w * (self roundWindowCorners ifTrue: [4] ifFalse: [2]). - ^ w rounded max: 1! ! -!PluggableButtonMorph methodsFor: 'initialization' stamp: 'len 3/29/2021 10:36:35' prior: 16888310 overrides: 16889446! - defaultBorderWidth - ^ Theme current buttonBorderWidth! ! -!SystemWindow methodsFor: 'drawing' stamp: 'len 3/29/2021 10:41:37' prior: 50337726 overrides: 50545911! - drawOn: aCanvas - | titleColor roundCorners | - titleColor _ self widgetsColor. - self isTopWindow - ifTrue: [ titleColor _ titleColor lighter ]. - roundCorners _ Theme current roundWindowCorners. - roundCorners - ifTrue: [ - "Round corners. Optional title gradient." - self drawRoundedFrameOn: aCanvas color: titleColor ] - ifFalse: [ - "No round corners. No title gradient." - self drawClassicFrameOn: aCanvas color: titleColor ]. - labelString ifNotNil: [ self drawLabelOn: aCanvas ]! ! -!SystemWindow methodsFor: 'initialization' stamp: 'len 3/29/2021 10:39:47' prior: 50541142 overrides: 16889446! - defaultBorderWidth - "Answer the default border width for the receiver." - ^ Theme current windowBorderWidth! ! -!SystemWindow methodsFor: 'initialization' stamp: 'len 3/29/2021 10:42:48' prior: 50541169! - titleBarButtonsExtent - "Answer the extent to use for close & other title bar buttons. - The label height is used to be proportional to the fonts preferences." - | e | - e _ Preferences windowTitleFont pointSize * 13 // 10. - ^e@e! ! -!SystemWindow methodsFor: 'label' stamp: 'len 3/29/2021 10:42:01' prior: 50541181! - labelHeight - "Answer the height for the window label." - ^ Preferences windowTitleFont lineSpacing+1! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'len 3/29/2021 10:52:17' prior: 50522981! - buildMorphicClassColumnWith: classList - | column | - column _ LayoutMorph newColumn. - column - addMorphUseAll: classList; - addAdjusterAndMorph: self buildMorphicSwitches fixedHeight: Theme current buttonPaneHeight. - ^column! ! -!ScrollBar methodsFor: 'geometry' stamp: 'len 3/29/2021 10:46:54' prior: 16904557! - computeSlider - - | delta | - delta _ (Theme current scrollbarShowButtons ifTrue: [self buttonExtent] ifFalse: [0]) + (self freeSliderRoom * value) asInteger. - self isHorizontal - ifTrue: [ - slider morphPosition: borderWidth + delta @ borderWidth ] - ifFalse: [ - slider morphPosition: borderWidth @ (borderWidth + delta) ] ! ! -!ScrollBar methodsFor: 'geometry' stamp: 'len 3/29/2021 10:47:46' prior: 50371514! - freeSliderRoom - "Answer the length or height of the free slider area, i.e. subtract the slider itself. - If we are really too short of room, lie a little bit. Answering at least 4, even when the - free space might be actually negative, makes the scrollbar somewhat usable." - | buttonsRoom | - buttonsRoom _ Theme current scrollbarShowButtons ifTrue: [self buttonExtent * 2] ifFalse: [0]. - ^ ((self isHorizontal - ifTrue: [extent x - slider morphWidth] - ifFalse: [extent y - slider morphHeight]) - - (borderWidth * 2) - buttonsRoom) max: 4! ! -!ScrollBar methodsFor: 'initialization' stamp: 'len 3/29/2021 10:48:07' prior: 50565448! - initializeDownButton - "initialize the receiver's downButton" - - | e | - e _ self buttonExtent. - downButton _ self buttonClass new. - downButton model: self. - downButton morphExtent: e@e. - Theme current scrollbarShowButtons ifFalse: [^ self]. - self addMorph: downButton position: extent - borderWidth - e. - downButton - actWhen: #buttonStillDown. "to enable multiple action if held down". - self isHorizontal - ifTrue: [ self updateRightButton: downButton ] - ifFalse: [ self updateDownButton: downButton ]! ! -!ScrollBar methodsFor: 'initialization' stamp: 'len 3/29/2021 10:48:16' prior: 50565467! - initializeUpButton - "initialize the receiver's upButton" - - | e | - e _ self buttonExtent. - upButton _ self buttonClass new. - upButton model: self. - upButton morphExtent: e@e. - Theme current scrollbarShowButtons ifTrue: [^ self]. - self addMorph: upButton position: borderWidth@borderWidth. - upButton - actWhen: #buttonStillDown. "to enable multiple action if held down" - self isHorizontal - ifTrue: [ self updateLeftButton: upButton ] - ifFalse: [ self updateUpButton: upButton ]. -! ! -!MenuMorph methodsFor: 'initialization' stamp: 'len 3/29/2021 10:35:08' prior: 16866999 overrides: 50545893! - defaultBorderWidth - ^ Theme current menuBorderWidth! ! - -Theme removeSelector: #minimalWindows! - -!methodRemoval: Theme #minimalWindows stamp: 'Install-4568-MinimalWindowsCleanup-LucianoEstebanNotarfrancesco-2021Mar29-10h32m-len.001.cs.st 5/20/2021 10:28:08'! -minimalWindows - ^ false! - -Theme removeSelector: #showScrollbarButtons! - -Theme removeSelector: #steButtons! - -!methodRemoval: Theme #steButtons stamp: 'Install-4568-MinimalWindowsCleanup-LucianoEstebanNotarfrancesco-2021Mar29-10h32m-len.001.cs.st 5/20/2021 10:28:08'! -steButtons - ^false! - -Preferences class removeSelector: #menuBorderWidth! - -!methodRemoval: Preferences class #menuBorderWidth stamp: 'Install-4568-MinimalWindowsCleanup-LucianoEstebanNotarfrancesco-2021Mar29-10h32m-len.001.cs.st 5/20/2021 10:28:08'! -menuBorderWidth - - ^self parameters at: #menuBorderWidth ifAbsentPut: [ 1 ]! - -Preferences class removeSelector: #systemWindowBorderSize! - -!methodRemoval: Preferences class #systemWindowBorderSize stamp: 'Install-4568-MinimalWindowsCleanup-LucianoEstebanNotarfrancesco-2021Mar29-10h32m-len.001.cs.st 5/20/2021 10:28:08'! -systemWindowBorderSize - | w | - w _ Preferences standardListFont pointSize / 11. - Theme current minimalWindows ifFalse: [ - w _ w * (Theme current roundWindowCorners ifTrue: [ 4 ] ifFalse: [ 2 ])]. - ^w rounded max: 1! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4568-MinimalWindowsCleanup-LucianoEstebanNotarfrancesco-2021Mar29-10h32m-len.001.cs.st----! - -'From Cuis 5.0 [latest update: #4568] on 17 April 2021 at 7:46:45 pm'! -!ScrollBar methodsFor: 'initialization' stamp: 'jmv 4/17/2021 19:44:08' prior: 50568184! - initializeUpButton - "initialize the receiver's upButton" - - | e | - e _ self buttonExtent. - upButton _ self buttonClass new. - upButton model: self. - upButton morphExtent: e@e. - Theme current scrollbarShowButtons ifFalse: [^ self]. - self addMorph: upButton position: borderWidth@borderWidth. - upButton - actWhen: #buttonStillDown. "to enable multiple action if held down" - self isHorizontal - ifTrue: [ self updateLeftButton: upButton ] - ifFalse: [ self updateUpButton: upButton ]. -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4569-ScrollbarFix-JuanVuletich-2021Apr17-19h46m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4569] on 19 April 2021 at 12:34:32 pm'! -!ChangeSet class methodsFor: 'services' stamp: 'jmv 4/19/2021 12:33:55' prior: 50555017! - installNewUpdates: updatesFileDirectory - - | warnUser | - (self newUpdates: updatesFileDirectory) do: [ :each | - self install: each ]. - - warnUser _ false. - CodePackage installedPackages keysAndValuesDo: [ :pckName :package | - package fullFileName ifNotNil: [ :fullFileName | | codePackageFile | - codePackageFile _ CodePackageFile onFileEntry: fullFileName asFileEntry. - (codePackageFile provides isLaterThan: package provides) ifTrue: [ - warnUser _ true. - package hasUnsavedChanges - ifTrue: [ ('Package: ', pckName, '. Package has unsaved changes, but there is a newer version of the file.') print ] - ifFalse: [ ('Package: ', pckName, '. There is a newer version than the currently loaded.') print ]]]]. - warnUser - ifTrue: [ - self inform: SystemVersion current version, ' - ', Smalltalk lastUpdateString, String newLineString, -'Some package(s) loaded in the image -have updated package file on disk. -Please see Transcript.' ] - ifFalse: [ - Smalltalk systemInformationString print ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4570-NewerPackagesWarning-fix-JuanVuletich-2021Apr19-12h33m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4570] on 27 April 2021 at 3:20:35 pm'! -!Number class methodsFor: 'instance creation' stamp: 'jmv 4/27/2021 15:20:21' prior: 50454614 overrides: 16882927! - readFrom: stringOrStream - "Answer a number as described on aStream. The number may - include a leading radix specification, as in 16rFADE" - | value base aStream sign | - aStream _ (stringOrStream isMemberOf: String) - ifTrue: [ReadStream on: stringOrStream] - ifFalse: [stringOrStream]. - (aStream nextMatchAll: 'NaN') ifTrue: [^ Float nan]. - sign _ (aStream peekFor: $-) ifTrue: [-1] ifFalse: [aStream peekFor: $+. 1]. - (aStream nextMatchAll: 'Infinity') ifTrue: [^ Float infinity * sign]. - base _ 10. - aStream peek = $. - ifTrue: [ value _ 0 ] - ifFalse: [ - value _ Integer readFrom: aStream base: base. - (aStream peekFor: $r) - ifTrue: [ - "r" - (base _ value) < 2 ifTrue: [ - base = 1 ifTrue: [ ^Integer readBaseOneFrom: aStream ]. - ^self error: 'Invalid radix']. - (aStream peekFor: $-) ifTrue: [sign _ sign negated]. - value _ Integer readFrom: aStream base: base]. - (aStream peekFor: $x) - ifTrue: [ - "0x" "Hexadecimal" - base _ 16. - (aStream peekFor: $-) ifTrue: [sign _ sign negated]. - value _ Integer readFrom: aStream base: base]]. - ^ self readRemainderOf: value from: aStream base: base withSign: sign.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4571-AllowMissingLeadingZeroForFloatNumberFromString-JuanVuletich-2021Apr27-15h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4571] on 28 April 2021 at 11:51:28 am'! -!FontFamily class methodsFor: 'ui' stamp: 'jmv 4/28/2021 11:38:29'! - promptUserFolders - "Present a menu of font folders, answer selection. - FontFamily promptUserFolders - " - | menu familyName current | - current _ (FontFamily familyNamed: FontFamily defaultFamilyName) folderName. - menu _ MenuMorph new. - ((DirectoryEntry smalltalkImageDirectory / 'TrueTypeFonts') - directories sorted: [ :a :b | a name < b name ]) do: [ :dir | | subDirs | - subDirs _ dir directories sorted: [ :a :b | a name < b name ]. - subDirs isEmpty - ifTrue: [ | this | - this _ dir name. - menu - add: (this=current ifTrue: [''] ifFalse: ['']), this - target: menu - action: #modalSelection: - argument: dir ] - ifFalse: [ | submenu this | - submenu _ MenuMorph new. - subDirs do: [ :subdir | - this _ subdir name. - submenu - add: (this=current ifTrue: [''] ifFalse: ['']), this - target: menu - action: #modalSelection: - argument: subdir ]. - menu add: dir name, '... ' subMenu: submenu - ]]. - FontFamily availableFamilies values do: [ :family | - family folderName isNil ifTrue: [ - familyName _ family familyName. - menu - add: (familyName = FontFamily defaultFamilyName ifTrue: [''] ifFalse: ['']), familyName - target: menu - action: #modalSelection: - argument: familyName ]]. - ^menu invokeModal! ! -!FontFamily class methodsFor: 'file read write' stamp: 'jmv 4/28/2021 11:25:43' prior: 50457963! - readAdditionalTrueTypeFonts - Feature require: 'VectorGraphics'. - UISupervisor whenUIinSafeState: [ - Smalltalk at: #TrueTypeFontFamily ifPresent: [ :cls | cls readAdditionalFonts ]]! ! -!FontFamily class methodsFor: 'ui' stamp: 'jmv 4/28/2021 11:41:10' prior: 50525010! - promptUser - "Present a menu of font families, answer selection. - FontFamily promptUser - " - | selectedNameOrDirectory | - selectedNameOrDirectory _ self promptUserFolders. - selectedNameOrDirectory isNil ifTrue: [ ^nil ]. - (FontFamily familyNamed: selectedNameOrDirectory) - ifNotNil: [ :it | ^it ]. - ^FontFamily availableFamilies values - detect: [ :any | any folderName = selectedNameOrDirectory name ] - ifNone: [ - FontFamily familyNamed: ((Smalltalk at: #TrueTypeFontFamily) read: selectedNameOrDirectory) anyOne ]! ! -!FontFamily class methodsFor: 'ui' stamp: 'jmv 4/28/2021 11:51:19' prior: 50524860! - promptUserAndSetDefault - "Present a menu of available font families, and if one is chosen, change to it. - FontFamily promptUserAndSetDefault - " - | selectedNameOrDirectory fontFamily | - selectedNameOrDirectory _ self promptUserFolders. - selectedNameOrDirectory isNil ifTrue: [ ^nil ]. - (FontFamily familyNamed: selectedNameOrDirectory) - ifNotNil: [ :it | ^Preferences setDefaultFont: it familyName ]. - Feature require: 'VectorGraphics'. - UISupervisor whenUIinSafeState: [ - fontFamily _ FontFamily availableFamilies values - detect: [ :any | any folderName = selectedNameOrDirectory name ] - ifNone: [ - FontFamily familyNamed: ((Smalltalk at: #TrueTypeFontFamily) read: selectedNameOrDirectory) anyOne ]. - Preferences setDefaultFont: fontFamily familyName ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4572-FontLoadFix-JuanVuletich-2021Apr28-11h50m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4570] on 26 April 2021 at 3:43:21 pm'! -!Scanner methodsFor: 'multi-character scans' stamp: 'jmv 4/26/2021 15:26:05' prior: 50410271! - xSingleQuote - - "String." - - self readUpToNext: $' ifNotFound: [ - ^self notify: 'Unmatched string quote' at: mark + 1]. - tokenType := #string! ! -!Parser methodsFor: 'public access' stamp: 'jmv 4/26/2021 15:12:23' prior: 50512981! - parse: sourceStream class: class category: aCategory noPattern: noPattern doIt: doIt context: aContext notifying: aRequestor ifFail: aBlock - - "Answer a MethodNode for the argument, sourceStream, that is the root of - a parse tree. Parsing is done with respect to the argument, class, to find - instance, class, and pool variables; and with respect to the argument, - ctxt, to find temporary variables. Errors in parsing are reported to the - argument, req, if not nil; otherwise aBlock is evaluated. The argument - noPattern is a Boolean that is true if the the sourceStream does not - contain a method header (i.e., for DoIts)." - - | methNode repeatNeeded myStream sourceCode startPosition | - - category _ aCategory. - myStream _ sourceStream. - [ - repeatNeeded _ false. - startPosition _ myStream position. - sourceCode _ myStream upToEnd. - myStream position: startPosition. - self encoder init: class context: aContext notifying: self. - "Protect against possible parsing failure" - doIt ifTrue: [ - (sourceCode beginsWith: Scanner doItInSelector) - ifTrue: [encoder selector: Scanner doItInSelector] - ifFalse: [ - (sourceCode beginsWith: Scanner doItSelector) - ifTrue: [encoder selector: Scanner doItSelector]]]. - self init: myStream notifying: aRequestor failBlock: [^ aBlock value ]. - doitFlag _ noPattern. - failBlock _ aBlock. - [ methNode _ self method: noPattern doIt: doIt context: aContext ] - on: ReparseAfterSourceEditing - do: [ :ex | - repeatNeeded _ true. - myStream _ ReadStream on: requestor text string ]. - repeatNeeded - ] whileTrue: [ encoder _ self encoder class new ]. - - methNode sourceText: sourceCode. - "See #xBacktick" - sentInLiterals do: [ :sym | encoder noteOptimizedSelector: sym ]. - - ^ methNode! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4573-NotificationPositionFixes-JuanVuletich-2021Apr26-15h41m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4571] on 26 April 2021 at 7:33:07 pm'! -!SmalltalkCompleter methodsFor: 'accessing' stamp: 'jmv 4/26/2021 19:28:15'! - allSource - ^model actualContents string! ! -!SmalltalkCompleter methodsFor: 'entries' stamp: 'jmv 4/26/2021 19:31:49' prior: 50509632 overrides: 16781250! - computeEntries - - | allSource source contextClass specificModel range - separator fragmentStart fragmentEnd done | - - allSource _ self allSource. - separator _ String newLineString, String newLineString. - fragmentStart _ 1. - done _ false. - [done] whileFalse: [ - fragmentEnd _ allSource - indexOfSubCollection: separator - startingAt: fragmentStart - ifAbsent: [allSource size]. - fragmentEnd >= position ifTrue: [ - source _ allSource copyFrom: fragmentStart to: position. - done _ true ]. - fragmentStart _ fragmentEnd+separator size ]. - - specificModel _ self textProviderOrModel. - contextClass _ self selectedClassOrMetaClassIn: specificModel. - allRanges _ self parse: source in: contextClass and: specificModel. - range _ allRanges lastIfEmpty: [ ^entries _ #() ]. - possibleInvalidSelectors _ #(). - - range end = source size - ifTrue: [ self computeEntriesOfMessageOrIdentifiersFor: source at: range in: contextClass and: specificModel ] - ifFalse: [ self computeMessageEntriesWithEmptyPrefixFor: source at: range in: contextClass and: specificModel ]. - - ! ! -!SmalltalkCompleter methodsFor: 'entries - private' stamp: 'jmv 4/26/2021 19:32:47' prior: 50509211! - parse: source in: contextClass and: specificModel - - | isMethod | - parser _ SHParserST80 new. - parser - workspace: ((specificModel is: #providesBindings) ifTrue: [specificModel]); - classOrMetaClass: contextClass; - source: source. - - isMethod := (specificModel is: #Browser) - ifTrue: [ specificModel isEditingClass not ] - ifFalse: [ specificModel is: #CodeProvider ]. - parser parse: isMethod. - - ^ parser rangesWithoutExcessCode.! ! - -SHParserST80 removeSelector: #allSource! - -!methodRemoval: SHParserST80 #allSource stamp: 'Install-4574-AutoCompletebyParagraphsInWorkspaces-JuanVuletich-2021Apr26-19h11m-jmv.003.cs.st 5/20/2021 10:28:08'! -allSource - - ^allSource! - -SHParserST80 removeSelector: #allSource:! - -!methodRemoval: SHParserST80 #allSource: stamp: 'Install-4574-AutoCompletebyParagraphsInWorkspaces-JuanVuletich-2021Apr26-19h11m-jmv.003.cs.st 5/20/2021 10:28:08'! -allSource: aSourceCode - - allSource _ aSourceCode! - -SmalltalkCompleter removeSelector: #changePositionTo:! - -!methodRemoval: SmalltalkCompleter #changePositionTo: stamp: 'Install-4574-AutoCompletebyParagraphsInWorkspaces-JuanVuletich-2021Apr26-19h11m-jmv.003.cs.st 5/20/2021 10:28:08'! -changePositionTo: newPosition - - position _ newPosition! - -Object subclass: #SHParserST80 - instanceVariableNames: 'classOrMetaClass source workspace arguments sourcePosition currentToken currentTokenFirst temporaries instanceVariables errorBlock currentTokenSourcePosition blockDepth bracketDepth ranges blockDepths blockDepthsStartIndexes braceDepth' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -!classDefinition: #SHParserST80 category: #'Tools-Syntax Highlighting' stamp: 'Install-4574-AutoCompletebyParagraphsInWorkspaces-JuanVuletich-2021Apr26-19h11m-jmv.003.cs.st 5/20/2021 10:28:08'! -Object subclass: #SHParserST80 - instanceVariableNames: 'classOrMetaClass source workspace arguments sourcePosition currentToken currentTokenFirst temporaries instanceVariables errorBlock currentTokenSourcePosition blockDepth bracketDepth ranges blockDepths blockDepthsStartIndexes braceDepth' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4574-AutoCompletebyParagraphsInWorkspaces-JuanVuletich-2021Apr26-19h11m-jmv.003.cs.st----! - -'From Cuis 5.0 [latest update: #4567] on 13 April 2021 at 2:15:10 pm'! -!BlockClosure methodsFor: 'private' stamp: 'jmv 4/13/2021 13:50:00'! - valueEnsured - "Protect against process termination. - Suggested by Esteban Maringolo at Martin McClure's 'Threads, Critical Sections, and Termination' (Smalltalks 2019 conference)" - [] ensure: self! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4575-valueEnsured-JuanVuletich-2021Apr13-13h50m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4568] on 13 April 2021 at 2:30:43 pm'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 4/13/2021 14:22:47' prior: 50548274! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('AY' 'Angel Yan') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('bgs' 'Boris G. Shingarov') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('db' 'Douglas Brebner') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('EB' 'Eric Brandwein') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('FGJ' 'Fernando Gasperi Jabalera') - #('FJG' 'Facundo Javier Gelatti') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hlsf' 'Hilaire Fernandes') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('jar' 'Jaromir Matas') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('KLG' 'Gerald Klix') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MM' 'Mariano Montone') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('pmon' 'Paolo Montrasi') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('sjd' 'Santiago Jose Dandois') - #('SLD' 'Steve Davies') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('ss' 'Sebastian Sujarchuk') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tsl' 'Thiago da Silva Lino') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4576-AddJaromirAsKnownAuthor-JuanVuletich-2021Apr13-14h30m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4567] on 29 April 2021 at 2:52:18 pm'! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 4/29/2021 14:52:10' prior: 50566305! - displayWorldSafely - "Update this world's display and keep track of errors during draw methods." - - [self displayWorld] ifError: [ :err :rcvr | - "Handle a drawing error" - canvas currentMorphDrawingFails. - self setCanvas. - "Install the old error handler, so we can re-raise the error" - rcvr error: err. - ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4577-MorphicDrawingErrorFix-JuanVuletich-2021Apr29-14h52m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4579] on 29 April 2021 at 3:43:12 pm'! -!DirectoryEntry methodsFor: 'actions-directory' stamp: 'jmv 4/29/2021 15:42:46' prior: 16834552! - rename: newName - - | fileEntry directoryEntry | - fileEntry _ self parent // newName. - fileEntry exists - ifTrue: [ Error signal: 'There already exists a file named: ', fileEntry printString ]. - directoryEntry _ self parent / newName. - directoryEntry exists - ifTrue: [ Error signal: 'There already exists a directory named: ', fileEntry printString ]. - self fileAccessor renameDirectory: self pathName to: directoryEntry pathName. - self name: newName! ! -!FileEntry methodsFor: 'actions-file' stamp: 'jmv 4/29/2021 15:42:52' prior: 16841325! - rename: newName - - | fileEntry directoryEntry | - fileEntry _ self parent // newName. - fileEntry exists - ifTrue: [ Error signal: 'There already exists a file named: ', fileEntry printString ]. - directoryEntry _ self parent / newName. - directoryEntry exists - ifTrue: [ Error signal: 'There already exists a directory named: ', fileEntry printString ]. - self fileAccessor rename: self pathName to: fileEntry pathName. - self name: newName.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4578-FileRename-avoid-overwrite-JuanVuletich-2021Apr29-15h38m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4574] on 29 April 2021 at 4:13:04 pm'! -!SmalltalkCompleter methodsFor: 'entries' stamp: 'jmv 4/29/2021 16:12:50' prior: 50568557 overrides: 16781250! - computeEntries - - | allSource source contextClass specificModel range - separator fragmentStart fragmentEnd done | - - specificModel _ self textProviderOrModel. - contextClass _ self selectedClassOrMetaClassIn: specificModel. - - allSource _ self allSource. - (specificModel is: #CodeProvider) - ifTrue: [source _ allSource copyFrom: 1 to: position] - ifFalse: [ - separator _ String newLineString, String newLineString. - fragmentStart _ 1. - done _ false. - [done] whileFalse: [ - fragmentEnd _ allSource - indexOfSubCollection: separator - startingAt: fragmentStart - ifAbsent: [allSource size]. - fragmentEnd >= position ifTrue: [ - source _ allSource copyFrom: fragmentStart to: position. - done _ true ]. - fragmentStart _ fragmentEnd+separator size ]]. - - allRanges _ self parse: source in: contextClass and: specificModel. - range _ allRanges lastIfEmpty: [ ^entries _ #() ]. - possibleInvalidSelectors _ #(). - - range end = source size - ifTrue: [ self computeEntriesOfMessageOrIdentifiersFor: source at: range in: contextClass and: specificModel ] - ifFalse: [ self computeMessageEntriesWithEmptyPrefixFor: source at: range in: contextClass and: specificModel ]. - - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4579-AutocompleteByParagraphsONLYinWorkspaces-JuanVuletich-2021Apr29-16h06m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4527] on 12 April 2021 at 10:16:03 pm'! -!BlockClosure methodsFor: 'scheduling' stamp: 'jar 4/8/2021 19:59:08' prior: 16788378! -newProcess - "Answer a Process running the code in the receiver. The process is not - scheduled." - "Simulation guard" - ^Process - forContext: - [self value. - Processor activeProcess suspend] asContext - priority: Processor activePriority! ! -!BlockClosure methodsFor: 'scheduling' stamp: 'jar 4/8/2021 19:59:28' prior: 16788389! - newProcessWith: anArray - "Answer a Process running the code in the receiver. The receiver's block - arguments are bound to the contents of the argument, anArray. The - process is not scheduled." - "Simulation guard" - ^Process - forContext: - [self valueWithArguments: anArray. - Processor activeProcess suspend] asContext - priority: Processor activePriority! ! -!Process methodsFor: 'changing process state' stamp: 'jar 4/12/2021 20:42:03' prior: 16894147! - terminate - "Stop the process that the receiver represents forever. Unwind to execute pending ensure:/ifCurtailed: blocks before terminating." - - | ctxt unwindBlock oldList outerMost | - self isRunning ifTrue: [ - "If terminating the active process, suspend it first and terminate it as a suspended process." - [self terminate] fork. - ^self suspend]. - - "Always suspend the process first so it doesn't accidentally get woken up" - oldList _ self suspend. - suspendedContext ifNotNil:[ - "Figure out if we are terminating the process while waiting in Semaphore>>critical: - In this case, pop the suspendedContext so that we leave the ensure: block inside - Semaphore>>critical: without signaling the semaphore." - (oldList class == Semaphore and:[ - suspendedContext method == (Semaphore compiledMethodAt: #critical:)]) ifTrue: [ - suspendedContext _ suspendedContext home. - ]. - - "If terminating a process halfways through an unwind, try to complete that unwind block first; - if there are multiple such nested unwind blocks, try to complete the outer-most one; the inner - blocks will be completed in the process." - ctxt _ suspendedContext. - [(ctxt _ ctxt findNextUnwindContextUpTo: nil) isNil] whileFalse: - "Contexts under evaluation have already set their complete (tempAt: 2) to true." - [(ctxt tempAt:2) ifNotNil: [outerMost _ ctxt]]. - outerMost ifNotNil: [ - "This is the outer-most unwind context currently under evaluation; - let's find an inner context executing outerMost's argument block (tempAt: 1)" - (suspendedContext findContextSuchThat: [:ctx | - ctx closure == (outerMost tempAt: 1)]) ifNotNil: [:inner | - "Let's finish the unfinished unwind context only (i.e. up to inner) and return here" - suspendedContext runUntilErrorOrReturnFrom: inner. - "Update the receiver's suspendedContext (the previous step reset its sender to nil); - return, if the execution stack reached its bottom (e.g. in case of non-local returns)." - (suspendedContext _ outerMost sender) ifNil: [^self]]]. - - "Now all unwind blocks caught halfway through have been completed; - let's execute the ones still pending. Note: #findNextUnwindContextUpTo: starts - searching from the receiver's sender but the receiver itself may be an unwind context." - ctxt _ suspendedContext. - ctxt isUnwindContext ifFalse: [ctxt _ ctxt findNextUnwindContextUpTo: nil]. - [ctxt isNil] whileFalse: [ - (ctxt tempAt: 2) ifNil: [ - ctxt tempAt: 2 put: true. - unwindBlock _ ctxt tempAt: 1. - "Create a context for the unwind block and execute it on the unwind block's stack. - Note: using #value instead of #runUntilErrorOrReturnFrom: would lead to executing - the unwind on the wrong stack preventing the correct execution of non-local returns." - suspendedContext _ unwindBlock asContextWithSender: ctxt. - suspendedContext runUntilErrorOrReturnFrom: suspendedContext]. - ctxt _ ctxt findNextUnwindContextUpTo: nil]. - - "Reset the context's pc and sender to nil for the benefit of isTerminated." - suspendedContext terminate]! ! -!Process methodsFor: 'testing' stamp: 'jar 4/8/2021 23:39:52' prior: 16894723! - isTerminated - "Answer if the receiver is terminated. A process is considered terminated - if the suspendedContext is the bottomContext and the pc is at the endPC" - - self isRunning ifTrue: [^ false]. - ^suspendedContext isNil or: [ - suspendedContext isBottomContext and: [ - suspendedContext isDead or: [suspendedContext atEnd]]] -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4580-terminate-fixes-JaromirMatas-2021Apr08-21h20m-jar.002.cs.st----! - -'From Cuis 5.0 [latest update: #4577] on 29 April 2021 at 12:45:09 pm'! -!Process methodsFor: 'changing process state' stamp: 'jmv 4/29/2021 12:44:59' prior: 50569048! - terminate - "Stop the process that the receiver represents forever. Unwind to execute pending ensure:/ifCurtailed: blocks before terminating." - - | ctxt unwindBlock oldList outerMost | - self isRunning ifTrue: [ - "If terminating the active process, suspend it first and terminate it as a suspended process." - [self terminate] fork. - ^self suspend]. - - "Always suspend the process first so it doesn't accidentally get woken up" - oldList _ self suspend. - suspendedContext ifNotNil:[ - "Figure out if we are terminating the process while waiting in Semaphore>>critical: - In this case, pop the suspendedContext so that we leave the ensure: block inside - Semaphore>>critical: without signaling the semaphore." - (oldList class == Semaphore and:[ - suspendedContext method == (Semaphore compiledMethodAt: #critical:)]) ifTrue: [ - suspendedContext _ suspendedContext home. - ]. - - "If terminating a process halfways through an unwind, try to complete that unwind block first; - if there are multiple such nested unwind blocks, try to complete the outer-most one; the inner - blocks will be completed in the process." - ctxt _ suspendedContext. - [(ctxt _ ctxt findNextUnwindContextUpTo: nil) isNil] whileFalse: - "Contexts under evaluation have already set their complete (tempAt: 2) to true." - [(ctxt tempAt:2) ifNotNil: [outerMost _ ctxt]]. - outerMost ifNotNil: [ - "This is the outer-most unwind context currently under evaluation; - let's find an inner context executing outerMost's argument block (tempAt: 1)" - (suspendedContext findContextSuchThat: [:ctx | - ctx closure == (outerMost tempAt: 1)]) ifNotNil: [:inner | - "Let's finish the unfinished unwind context only (i.e. up to inner) and return here" - outerMost _ (suspendedContext runUntilErrorOrReturnFrom: inner) first. - "Update the receiver's suspendedContext (the previous step reset its sender to nil); - return, if the execution stack reached its bottom (e.g. in case of non-local returns)." - (suspendedContext _ outerMost sender) ifNil: [^self]]]. - - "Now all unwind blocks caught halfway through have been completed; - let's execute the ones still pending. Note: #findNextUnwindContextUpTo: starts - searching from the receiver's sender but the receiver itself may be an unwind context." - ctxt _ suspendedContext. - ctxt isUnwindContext ifFalse: [ctxt _ ctxt findNextUnwindContextUpTo: nil]. - [ctxt isNil] whileFalse: [ - (ctxt tempAt: 2) ifNil: [ - ctxt tempAt: 2 put: true. - unwindBlock _ ctxt tempAt: 1. - "Create a context for the unwind block and execute it on the unwind block's stack. - Note: using #value instead of #runUntilErrorOrReturnFrom: would lead to executing - the unwind on the wrong stack preventing the correct execution of non-local returns." - suspendedContext _ unwindBlock asContextWithSender: ctxt. - suspendedContext runUntilErrorOrReturnFrom: suspendedContext]. - ctxt _ ctxt findNextUnwindContextUpTo: nil]. - - "Reset the context's pc and sender to nil for the benefit of isTerminated." - suspendedContext terminate]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4581-terminate-fix-JuanVuletich-2021Apr29-12h43m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4579] on 1 May 2021 at 11:38:01 pm'! -!ProgressInitiationException methodsFor: 'exceptionDescription' stamp: 'nice 5/1/2021 23:36:25' prior: 16896161! - sendNotificationsTo: aNewBlock - - signalContext resumeEvaluating: [ - workBlock value: [ :barVal | - aNewBlock value: minVal value: maxVal value: barVal - ] - ] -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4582-ProgressInitiationException-nice-2021May01-23h24m-nice.002.cs.st----! - -'From Cuis 5.0 [latest update: #4582] on 3 May 2021 at 10:59:54 am'! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 5/3/2021 10:57:05' prior: 50562398! - grabMorph: aMorph moveUnderHand: moveUnderHand - "Grab the given morph (i.e., add it to this hand and remove it from its current owner). - If moveUnderHand is requested or it seems neccesary anyway, move the grabbed morph under the hand." - - | grabbed positionInHandCoordinates tx | - self releaseMouseFocus. "Break focus" - grabbed _ aMorph. - aMorph owner ifNotNil: [ :o | grabbed _ o aboutToGrab: aMorph ]. - grabbed ifNil: [ ^ self ]. - grabbed _ grabbed aboutToBeGrabbedBy: self. - grabbed ifNil: [ ^ self ]. - - moveUnderHand - ifTrue: [ - "We can possibly do better, especially for non WidgetMorphs" - positionInHandCoordinates _ -30 @ -10. - grabbed isInWorld ifTrue: [ - grabbed displayBounds ifNotNil: [ :r | - positionInHandCoordinates _ (r extent // 2) negated ]]. - self - grabMorph: grabbed - delta: positionInHandCoordinates. - ^self ]. - - positionInHandCoordinates _ (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) - morphPositionInWorld - self morphPositionInWorld. - - tx _ GeometryTransformation identity. - grabbed withAllOwnersDo: [ :o | - tx _ o location composedWith: tx ]. - self withAllOwnersReverseDo: [ :o | - tx _ o location inverseTransformation composedWith: tx ]. - - self - grabMorph: grabbed - delta: positionInHandCoordinates. - - grabbed location: tx.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4583-MorphGrabFix-JuanVuletich-2021May03-10h59m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4583] on 3 May 2021 at 5:40:42 pm'! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 5/3/2021 17:39:58' prior: 50569288! - grabMorph: aMorph moveUnderHand: moveUnderHand - "Grab the given morph (i.e., add it to this hand and remove it from its current owner). - If moveUnderHand is requested or it seems neccesary anyway, move the grabbed morph under the hand." - - | grabbed positionInHandCoordinates tx | - self releaseMouseFocus. "Break focus" - grabbed _ aMorph. - aMorph owner ifNotNil: [ :o | grabbed _ o aboutToGrab: aMorph ]. - grabbed ifNil: [ ^ self ]. - grabbed _ grabbed aboutToBeGrabbedBy: self. - grabbed ifNil: [ ^ self ]. - - moveUnderHand - ifTrue: [ - "We can possibly do better, especially for non WidgetMorphs" - positionInHandCoordinates _ -30 @ -10. - grabbed isInWorld ifTrue: [ - grabbed displayBounds ifNotNil: [ :r | - positionInHandCoordinates _ (r extent // 2) negated ]]. - self - grabMorph: grabbed - delta: positionInHandCoordinates. - ^self ]. - - positionInHandCoordinates _ (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) - morphPositionInWorld - self morphPositionInWorld. - - tx _ GeometryTransformation identity. - (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) withAllOwnersDo: [ :o | - tx _ o location composedWith: tx ]. - self withAllOwnersReverseDo: [ :o | - tx _ o location inverseTransformation composedWith: tx ]. - self - grabMorph: grabbed - delta: positionInHandCoordinates. - - grabbed location: tx.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4584-MorphGrabFix-retry-JuanVuletich-2021May03-17h36m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4581] on 1 May 2021 at 7:42:39 pm'! -!Morph methodsFor: 'structure' stamp: 'jmv 5/1/2021 19:34:50'! -topmostWorld - "Answer the last morph in the owner chain (i.e. the morph without owner) if it is a WorldMorph, or nil." - ^owner - ifNotNil: [ owner topmostWorld ]! ! -!WorldMorph methodsFor: 'structure' stamp: 'jmv 5/1/2021 19:34:53' overrides: 50569390! - topmostWorld - "Answer the last morph in the owner chain (i.e. the morph without owner) if it is a WorldMorph, or nil." - owner - ifNotNil: [ ^owner topmostWorld ]. - ^self! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 5/1/2021 19:41:56' prior: 50562448! - containsGlobalPoint: worldPoint - - self visible ifTrue: [ - self topmostWorld ifNotNil: [ :w | - w canvas ifNotNil: [ :canvas | - ^ canvas morph: self isAtPoint: worldPoint ]]]. - ^ false! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 5/1/2021 19:40:01' prior: 50562460! - fullContainsGlobalPoint: worldPoint - "Answer true if worldPoint is in some submorph, even if not inside our shape." - - self visible ifTrue: [ - self topmostWorld ifNotNil: [ :w | - w canvas ifNotNil: [ :canvas | - (canvas morph: self isAtPoint: worldPoint) ifTrue: [ ^ true ]. - self submorphsDo: [ :m | - (m fullContainsGlobalPoint: worldPoint) ifTrue: [ ^ true ]]]]]. - ^ false! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4585-containsGlobalPoint-fix-JuanVuletich-2021May01-19h39m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4585] on 5 May 2021 at 3:29:14 pm'! - -TextModelMorph subclass: #BrowserCommentTextMorph - instanceVariableNames: 'separator proportionalHeight code ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #BrowserCommentTextMorph category: 'Morphic-Widgets' stamp: 'Install-4586-BrowserCommentAdjusterFix-JuanVuletich-2021May05-15h12m-jmv.001.cs.st 5/20/2021 10:28:08'! -TextModelMorph subclass: #BrowserCommentTextMorph - instanceVariableNames: 'separator proportionalHeight code' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! -!BrowserCommentTextMorph methodsFor: 'accessing' stamp: 'jmv 5/5/2021 14:56:15'! - separator: adjusterMorph code: codeMorph - separator _ adjusterMorph. - code _ codeMorph.! ! -!BrowserCommentTextMorph methodsFor: 'displaying' stamp: 'jmv 5/5/2021 15:06:08' prior: 50522121! - hidePane - - self hide. - separator visible ifTrue: [ - proportionalHeight _ self layoutSpec proportionalLayoutHeight ]. - separator layoutSpec fixedHeight: 0. - self layoutSpec proportionalHeight: 0. - code layoutSpec proportionalHeight: 1.0. - separator ifNotNil: [ separator hide ]! ! -!BrowserCommentTextMorph methodsFor: 'displaying' stamp: 'jmv 5/5/2021 15:03:35' prior: 50522132! - showPane - - self show. - proportionalHeight ifNotNil: [ - self layoutSpec proportionalHeight: proportionalHeight. - code layoutSpec proportionalHeight: 1.0 - proportionalHeight ]. - separator ifNotNil: [ - separator layoutSpec fixedHeight: Theme current layoutAdjusterThickness. - separator show ]! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'jmv 5/5/2021 14:59:00' prior: 50522143 overrides: 50518657! - buildLowerPanes - | codeAndButtons codeButtonsAndAnnotations code comment separator | - code _ self buildMorphicCodePane. - comment _ self buildMorphicCommentPane. - separator _ LayoutAdjustingMorph new. - comment separator: separator code: code. - codeAndButtons _ LayoutMorph newColumn. - Preferences optionalButtons ifTrue: [ - codeAndButtons - addMorph: self optionalButtonRow fixedHeight: self defaultButtonPaneHeight; - addAdjusterMorph ]. - codeAndButtons - addMorph: code proportionalHeight: 0.5; - addMorph: separator fixedHeight: Theme current layoutAdjusterThickness; - addMorph: comment proportionalHeight: 0.5. - Preferences showAnnotations ifFalse: [ - ^codeAndButtons ]. - codeButtonsAndAnnotations _ LayoutMorph newColumn. - codeButtonsAndAnnotations - addMorph: self buildMorphicAnnotationsPane fixedHeight: self defaultAnnotationPaneHeight; - addAdjusterMorph; - addMorph: codeAndButtons proportionalHeight: 1.0. - ^codeButtonsAndAnnotations! ! - -BrowserCommentTextMorph removeSelector: #separator:! - -!methodRemoval: BrowserCommentTextMorph #separator: stamp: 'Install-4586-BrowserCommentAdjusterFix-JuanVuletich-2021May05-15h12m-jmv.001.cs.st 5/20/2021 10:28:08'! -separator: aMorph - separator _ aMorph! - -TextModelMorph subclass: #BrowserCommentTextMorph - instanceVariableNames: 'separator code proportionalHeight' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #BrowserCommentTextMorph category: 'Morphic-Widgets' stamp: 'Install-4586-BrowserCommentAdjusterFix-JuanVuletich-2021May05-15h12m-jmv.001.cs.st 5/20/2021 10:28:08'! -TextModelMorph subclass: #BrowserCommentTextMorph - instanceVariableNames: 'separator code proportionalHeight' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4586-BrowserCommentAdjusterFix-JuanVuletich-2021May05-15h12m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4586] on 5 May 2021 at 3:49:52 pm'! -!LayoutAdjustingMorph methodsFor: 'stepping' stamp: 'jmv 5/5/2021 15:46:30' prior: 50562534 overrides: 50547622! - stepAt: millisecondSinceLast - "got the #mouseLeave: message" - | p | - hand ifNil: [ - Cursor currentCursor == self cursor ifTrue: [ Cursor defaultCursor activateCursor ]. - ^ self stopStepping ]. - "hasn't got the #mouseLeave: message (yet)" - p _ hand morphPosition. - hand lastMouseEvent mouseButton1Pressed - ifTrue: [ - self adjustOwnerAt: p. - (Preferences cheapWindowReframe or: [ millisecondSinceLast > 200]) ifTrue: [ - owner displayBounds newRectFrom: [ :f | - self adjustOwnerAt: Sensor mousePoint. - owner morphPosition extent: owner morphExtent ]]] - ifFalse: [ - self stopStepping. - hand _ nil. - Cursor defaultCursor activateCursor ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4587-ReturnToDefaultCursor-JuanVuletich-2021May05-15h48m-jmv.001.cs.st----! - -'From Haver 5.0 [latest update: #4587] on 6 May 2021 at 3:57:03 pm'! -!MenuMorph methodsFor: 'construction' stamp: 'KLG 5/6/2021 15:45:51' prior: 50547956! - addTitle: aString - "Add a title line at the top of this menu Make aString its initial - contents. - If aSelector is not nil, then periodically obtain fresh values for its - contents by sending aSelector to aTarget.." - - | s pp w newMorph | - - newMorph _ WidgetMorph new noBorder. - newMorph color: Theme current menuTitleBar. - pp _ `8@2`. - aString asString linesDo: [ :line | - s _ LabelMorph new - contents: line; - font: Preferences standardMenuFont bold. - newMorph addMorphBack: s position: pp. - pp _ pp + (0@(s morphHeight+2)) ]. - w _ newMorph submorphs inject: 0 into: [ :prev :each | - prev max: each morphWidth ]. - newMorph morphExtent: (w + 16) @ (pp y). - titleMorph - ifNil: [ - titleMorph _ newMorph. - self addMorphFront: titleMorph ] - ifNotNil: [ self addMorphBack: newMorph ]. - - (self hasProperty: #needsStayUpIcons) ifTrue: [ self addStayUpIcons ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4588-AllowSubtitlesInMenus-GeraldKlix-2021May06-13h10m-KLG.001.cs.st----! - -'From Haver 5.0 [latest update: #4587] on 6 May 2021 at 4:36:32 pm'! -!MenuMorph methodsFor: 'construction' stamp: 'KLG 5/6/2021 16:35:55' prior: 50569585! - addTitle: aString - "Add a title line at the top of this menu Make aString its initial - contents. - If aSelector is not nil, then periodically obtain fresh values for its - contents by sending aSelector to aTarget.." - - | s pp w newMorph | - - newMorph _ WidgetMorph new noBorder. - newMorph color: Theme current menuTitleBar. - pp _ `8@2`. - aString asString linesDo: [ :line | | font | - font _ Preferences standardMenuFont. - s _ LabelMorph new - contents: line; - font: (titleMorph - ifNil: [ font bold ] - ifNotNil: [ font italic ]).. - newMorph addMorphBack: s position: pp. - pp _ pp + (0@(s morphHeight+2)) ]. - w _ newMorph submorphs inject: 0 into: [ :prev :each | - prev max: each morphWidth ]. - newMorph morphExtent: (w + 16) @ (pp y). - titleMorph - ifNil: [ - titleMorph _ newMorph. - self addMorphFront: titleMorph ] - ifNotNil: [ self addMorphBack: newMorph ]. - - (self hasProperty: #needsStayUpIcons) ifTrue: [ self addStayUpIcons ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4589-NicerSubtitlesInMenus-GeraldKlix-2021May06-15h57m-KLG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4589] on 10 May 2021 at 12:24:06 pm'! -!BrowserCommentTextMorph methodsFor: 'displaying' stamp: 'jmv 5/10/2021 12:20:29' prior: 50569462! - hidePane - - self hide. - separator visible ifTrue: [ - proportionalHeight _ self layoutSpec proportionalLayoutHeight ]. - separator layoutSpec fixedHeight: 0. - self layoutSpec proportionalHeight: 0. - code layoutSpec proportionalHeight: 1.0. - separator hide.! ! -!BrowserCommentTextMorph methodsFor: 'displaying' stamp: 'jmv 5/10/2021 12:20:45' prior: 50569474! - showPane - - self show. - proportionalHeight ifNotNil: [ - self layoutSpec proportionalHeight: proportionalHeight. - code layoutSpec proportionalHeight: 1.0 - proportionalHeight ]. - separator layoutSpec fixedHeight: Theme current layoutAdjusterThickness. - separator show! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4590-BrowserCommentTextMorph-tweaks-JuanVuletich-2021May10-12h20m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4589] on 10 May 2021 at 12:33:22 pm'! -!MorphicCanvas methodsFor: 'drawing-ovals' stamp: 'jmv 5/10/2021 10:54:20'! - ellipseCenter: center radius: radiusPointOrNumber borderWidth: mbw borderColor: mbc fillColor: morphFillColor - self subclassResponsibility ! ! -!BitBltCanvas methodsFor: 'drawing-ovals' stamp: 'jmv 5/10/2021 10:53:57' overrides: 50569695! - ellipseCenter: center radius: radiusPointOrNumber borderWidth: mbw borderColor: mbc fillColor: morphFillColor - - | displayRectangle doBorder doFill | - - engine ifNil: [ ^nil ]. - - doBorder _ mbw > 0 and: [ mbc isTransparent not]. - doFill _ morphFillColor isTransparent not. - doBorder | doFill ifTrue: [ - displayRectangle _ (currentTransformation externalizeRectangle: (Rectangle center: center extent: radiusPointOrNumber asPoint * 2)) rounded. - "draw the border of the oval" - doBorder ifTrue: [ - self setPaintColor: mbc. - engine frameOval: displayRectangle borderWidth: mbw rounded]. - "fill the inside" - doFill ifTrue: [ - self setPaintColor: morphFillColor. - engine fillOval: (displayRectangle insetBy: mbw rounded) ]]! ! -!MorphicCanvas methodsFor: 'drawing-ovals' stamp: 'jmv 5/10/2021 12:32:42' prior: 50463445! - ellipseCenterX: mcx y: mcy rx: mrx ry: mry borderWidth: mbw borderColor: mbc fillColor: morphFillColor - "Prefer #ellipseCenter:radius:borderWidth:borderColor:fillColor:" - - self ellipseCenter: mcx@mcy radius: mrx@mry borderWidth: mbw borderColor: mbc fillColor: morphFillColor! ! - -BitBltCanvas removeSelector: #ellipseCenterX:y:rx:ry:borderWidth:borderColor:fillColor:! - -!methodRemoval: BitBltCanvas #ellipseCenterX:y:rx:ry:borderWidth:borderColor:fillColor: stamp: 'Install-4591-PreferPointOrientedProtocol-JuanVuletich-2021May10-12h30m-jmv.001.cs.st 5/20/2021 10:28:08'! -ellipseCenterX: mcx y: mcy rx: mrx ry: mry borderWidth: mbw borderColor: mbc fillColor: morphFillColor - - | displayRectangle doBorder doFill | - - engine ifNil: [ ^nil ]. - - doBorder _ mbw > 0 and: [ mbc isTransparent not]. - doFill _ morphFillColor isTransparent not. - doBorder | doFill ifTrue: [ - displayRectangle _ (currentTransformation externalizeRectangle: (Rectangle center: mcx@mcy extent: mrx@mry * 2)) rounded. - "draw the border of the oval" - doBorder ifTrue: [ - self setPaintColor: mbc. - engine frameOval: displayRectangle borderWidth: mbw rounded]. - "fill the inside" - doFill ifTrue: [ - self setPaintColor: morphFillColor. - engine fillOval: (displayRectangle insetBy: mbw rounded) ]]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4591-PreferPointOrientedProtocol-JuanVuletich-2021May10-12h30m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4589] on 10 May 2021 at 1:55:42 pm'! -!KernelMorph commentStamp: '' prior: 50532123! - Hierarchy for morphs that are rectangle like, and that occupy an area that can be specified as a Rectangle. This means that, besides being of rectangular shape, sides are aligned with local coordinate axes. Including rectangles with rounded corners and such. The idea is that the 'extent' ivar is all that's needed to establish our dimensions and shape. Subclasses can add things like 'roundedCornerRadius' or such.! -!WidgetMorph commentStamp: '' prior: 50548067! - Hierarchy for morphs that are rectangle like, and that occupy an area that can be specified as a Rectangle. This means that, besides being of rectangular shape, sides are aligned with local coordinate axes. Including rectangles with rounded corners and such. The idea is that the 'extent' ivar is all that's needed to establish our dimensions and shape. Instances may have a border, see instanceVariables borderWidth and borderColor. Subclasses can use a variety of border styles: simple, inset, raised -Subclasses can add things like 'roundedCornerRadius' or such.! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 5/10/2021 13:29:02' prior: 50539207 overrides: 50539188! - addPossiblyUncoveredAreasIn: aRectangle to: aCollection - "Answer an array of rectangles encompassing those areas in aRectangle not completely - covered by self. These are the areas that might require further drawing (of morphs below us) - All areas that might possibly be uncovered must be included." - | bounds radius | - color mightBeTranslucent ifTrue: [ - aCollection add: aRectangle. - ^self ]. - - bounds _ self displayBounds. - bounds ifNil: [ - aCollection add: aRectangle. - ^self ]. - - "Solid rectangle. - This will be the fastest in many cases. So, please disable rounded corners if on slow hardware!!" - Theme current roundWindowCorners ifFalse: [ - aRectangle areasOutside: bounds do: [ :rect | aCollection add: rect ]. - ^self ]. - - "The solid rectangle does not include the corners. - Report a couple of rows (top and bottom) or columns (left and right) as uncovered areas. - We could also try to be more careful and answer each rounded corner... - Right now, report top and bottom rows as uncovered areas" - radius _ Theme current roundedWindowRadius. - aRectangle areasOutside: (bounds insetBy: 0@radius) do: [ :rect | aCollection add: rect ]! ! -!BitBltCanvas methodsFor: 'drawing-roundedRectangles' stamp: 'jmv 5/10/2021 13:27:52' prior: 50532970 overrides: 50463497! - roundRect: aRectangle color: aColor radius: r - " - Display getCanvas roundRect: (10@10 extent: 200@100) color: Color red radius: 10 - " - - engine ifNil: [ ^nil ]. - - "radius is not scaled properly..." - "top stripe" - self - image: (self class topLeftCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle topLeft. - self - image: (self class topRightCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle topRight - (r@0). - self fillRectangle: ((aRectangle withHeight: r) insetBy: r@0) color: aColor. - - "center stripe" - self fillRectangle: (aRectangle insetBy: (0 @ r corner: 0 @ r)) color: aColor. - - "bottom stripe" - self - image: (self class bottomLeftCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle bottomLeft - (0@r). - self - image: (self class bottomRightCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle bottomRight - (r@r) . - self fillRectangle: ((aRectangle bottomLeft + (r@r negated)) extent: (aRectangle width - r - r@r)) color: aColor! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4592-fixAFewTypos-JuanVuletich-2021May10-12h33m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4589] on 10 May 2021 at 2:22:25 pm'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 5/10/2021 14:22:14' prior: 50567862! - updateCurrentDisplayBoundsAndMerge: aRectangle - "Update displayBounds for if never set. - Useful for new morph, that are created and attached to the hand." - - | isKnownFailing r | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph drawOn: self ]. - currentMorph displayBoundsSetFrom: self. - r _ self boundingRectOfCurrentMorphAfterDraw. - r _ r quickMerge: aRectangle. - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | - r _ self updateDisplayBounds: m andMerge: r ]]. - ^r! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4593-MorphicDrawFix-JuanVuletich-2021May10-14h22m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4593] on 10 May 2021 at 3:29:06 pm'! -!Mutex methodsFor: 'mutual exclusion' stamp: 'jmv 5/10/2021 15:26:17'! - releaseIfOwnerNotReadyToRun - "If process owning us is not ready to run, release. - This means that the critical section might be already running, and suspended or blocked, for example, because of an open Debugger. - If so, critical section will be reentered for next requester without any wait. - Use with care!! - " - (owner notNil and: [ owner isReady not ]) - ifTrue: [ - owner _ nil. - semaphore _ Semaphore forMutualExclusion ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4594-Mutex-releaseIfOwnerNotReadyToRun-JuanVuletich-2021May10-15h28m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4594] on 11 May 2021 at 10:28:42 am'! -!AffineTransformation class methodsFor: 'instance creation' stamp: 'jmv 5/11/2021 09:51:57'! - withScale: aNumber position: otherPoint - " - (AffineTransformation withScale: 4 position: 0.2@0.7) transform: 1@1 - " - ^self new - setPointScale: aNumber@aNumber; - setTranslation: otherPoint! ! -!AffineTransformation class methodsFor: 'instance creation' stamp: 'jmv 5/11/2021 09:51:35' prior: 50497888! - withPointScale: aPoint position: otherPoint - " - (AffineTransformation withPointScale: 4@3 position: 0.2@0.7) transform: 1@1 - " - ^self new - setPointScale: aPoint; - setTranslation: otherPoint! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4595-AffineTransformationTweaks-JuanVuletich-2021May11-09h51m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4595] on 12 May 2021 at 1:06:30 pm'! -!MorphicCanvas methodsFor: 'initialization' stamp: 'jmv 5/12/2021 11:10:35' prior: 50407972! - initializeWith: aForm origin: aPoint - self initialize. - self setForm: aForm. - - "Set up these only on initialization. - This is safe (wrt walkbacks during world redraw) because a new instance is created - on draw error. See #displayWorldSafely" - currentTransformation _ MorphicTranslation withTranslation: aPoint. - cti _ 1. - transformations - ifNil: [ transformations _ OrderedCollection with: currentTransformation ] - ifNotNil: [ transformations at: cti put: currentTransformation ]. - drawingMorphStack - ifNil: [ drawingMorphStack _ OrderedCollection with: nil ] - ifNotNil: [ drawingMorphStack at: cti put: nil ].! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 5/12/2021 11:11:22' prior: 50554672! -into: aMorph - | locationOrNil previousLast | - locationOrNil _ aMorph location. - currentMorph _ aMorph. - cti _ cti + 1. - transformations size < cti - ifTrue: [ - drawingMorphStack add: aMorph. - currentTransformation _ locationOrNil - ifNotNil: [ currentTransformation composedWith: locationOrNil] - ifNil: [ currentTransformation copy ]. - transformations add: currentTransformation ] - ifFalse: [ - drawingMorphStack at: cti put: aMorph. - previousLast _ currentTransformation. - locationOrNil - ifNil: [ - currentTransformation _ previousLast copy. - transformations at: cti put: currentTransformation ] - ifNotNil: [ :location | - currentTransformation _ transformations at: cti. - "reuse the instance if possible" - (previousLast class == location class and: [ previousLast class == currentTransformation class ]) - ifTrue: [ - previousLast composedWith: location into: currentTransformation ] - ifFalse: [ - currentTransformation _ previousLast composedWith: location. - transformations at: cti put: currentTransformation ] - ] - ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4596-CommentsTweaks-JuanVuletich-2021May12-13h06m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4596] on 13 May 2021 at 6:24:06 pm'! -!Float32Array commentStamp: 'jmv 5/13/2021 17:12:39' prior: 50542418! - Float32rrays store 32bit IEEE floating point numbers, i.e. what usually called float in the C world. - -A possible way to create literal Float32Arrays is by using backticks: -`#[ 1.0 2.0 3.0 ] asFloat32Array`! -!Float64Array commentStamp: 'jmv 5/13/2021 17:11:37' prior: 50542102! - Float64Arrays store 64bit IEEE floating point numbers, i.e. instances of the Float class. -Some support is included for subclasses in the style of Balloon3D-Math. - -Uses the same internal representation as Float. I.e. a Float and a Float64Array of size 1 hold the same bits. See #floatAt: and #floatAt:put: - -Can be created as literals like: -#[ 1.0 2.0 3.0 ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4597-FloatArray-comments-JuanVuletich-2021May13-18h23m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4597] on 16 May 2021 at 10:08:16 am'! -!Inspector methodsFor: 'user interface support' stamp: 'jmv 5/14/2021 11:38:18' prior: 50516529! - displayLabel - - | label | - object isObject ifFalse: [^ 'Inspect: ', self objectClass name]. - label := [object printStringLimitedTo: 64] - on: UnhandledError - do: [:ex | ex return: self objectClass printString, ' (printing failed)']. - "Note this is ambiguous: what happens with (Array with: Array)?" - (label includesSubString: self objectClass name) ifTrue: [^'Inspect: ', label]. - ^ 'Inspect: ', self objectClass name, ': ', label! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4598-InspectorLabelTweak-JuanVuletich-2021May16-10h07m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4597] on 16 May 2021 at 10:17:29 am'! -!Morph methodsFor: 'geometry' stamp: 'jmv 5/16/2021 10:16:34' prior: 50567663! - adjustDisplayBoundsBy: delta - "Private for framework use. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us." - - privateDisplayBounds ifNotNil: [ - privateDisplayBounds _ privateDisplayBounds translatedBy: delta ]. - self allMorphsDo: [ :m | m adjustDisplayBoundsBy: delta ].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 5/16/2021 10:16:38' prior: 50567713! - displayBounds - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us." - - self visible ifFalse: [ ^nil ]. - ^ privateDisplayBounds! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 5/16/2021 10:16:42' prior: 50567678! - displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us." - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphAfterDraw ]]].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 5/16/2021 10:16:46' prior: 50567947! - displayBoundsUpdateFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us." - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - privateDisplayBounds _ privateDisplayBounds - quickMerge: aCanvas boundingRectOfCurrentMorphAfterDraw ]]].! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 5/14/2021 11:44:08' prior: 50501539! - textComposition: aTextComposition bounds: boundsRect color: c selectionColor: sc - | displayScanner leftInRun line possibleVisibleLocalRect textTopLeft | - - textTopLeft _ boundsRect topLeft. - possibleVisibleLocalRect _ currentTransformation boundsOfInverseTransformOf: self clipRect. - - displayScanner _ MorphicScanner new - defaultFont: aTextComposition defaultFont; - text: aTextComposition textComposed - foreground: c. - displayScanner canvas: self. - - leftInRun _ 0. - "Take clipRect into account. Extrememly fast scrolls and redraws of huge files (like .sources)" - (aTextComposition lineIndexForPoint: (possibleVisibleLocalRect topLeft - textTopLeft max: `0@0`) ) - to: (aTextComposition lineIndexForPoint: possibleVisibleLocalRect bottomRight - textTopLeft) - do: [ :i | - line _ aTextComposition lines at: i. - aTextComposition - displaySelectionInLine: line - on: self - textTopLeft: textTopLeft - selectionColor: sc. - leftInRun _ displayScanner displayLine: line textTopLeft: textTopLeft leftInRun: leftInRun ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4599-Comments-JuanVuletich-2021May16-10h08m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4597] on 15 May 2021 at 8:27:04 pm'! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 5/15/2021 19:44:30' prior: 50566247! - restoreSavedPatchOn: aCanvas - "Clear the changed flag and restore the part of the given canvas under this hand from the previously saved patch. If necessary, handle the transition to using the hardware cursor." - - self needsRedraw: false. - prevFullBounds ifNotNil: [ - aCanvas restorePatch: savedPatch bounds: prevFullBounds. - submorphs notEmpty ifTrue: [ ^ self ]. - "Make the transition to using hardware cursor. Clear savedPatch and - report one final damage rectangle to erase the image of the software cursor." - " owner invalidateDisplayRect: (savedPatch offset extent: savedPatch extent) from: nil." - self invalidateDisplayRect: (self morphPosition extent: extent) for: nil. - Cursor currentCursor == Cursor defaultCursor ifFalse: [ Cursor defaultCursor activateCursor ]. - "show hardware cursor" - prevFullBounds _ nil ].! ! -!WorldMorph methodsFor: 'hands' stamp: 'jmv 5/15/2021 20:26:17' prior: 50551516! - selectHandsToDrawForDamage: damageList - "Select the set of hands that must be redrawn because either (a) the hand itself has changed or (b) the hand intersects some damage rectangle." - - | result | - result _ OrderedCollection new. - hands do: [:hand | - hand needsToBeDrawn ifTrue: [ - hand isRedrawNeeded - ifTrue: [result add: hand] - ifFalse: [ - hand displayFullBounds ifNotNil: [ :handBounds | - (damageList anySatisfy: [ :r | r intersects: handBounds]) ifTrue: [ - result add: hand]]]]]. - ^ result! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 5/15/2021 20:26:07' prior: 50551671! - checkIfUpdateNeeded - - damageRecorder updateIsNeeded ifTrue: [^true]. - hands do: [:h | (h isRedrawNeeded and: [h needsToBeDrawn]) ifTrue: [^true]]. - ^false "display is already up-to-date" -! ! - -HandMorph removeSelector: #hasChanged! - -!methodRemoval: HandMorph #hasChanged stamp: 'Install-4600-HandMorphCleanup-JuanVuletich-2021May15-20h25m-jmv.001.cs.st 5/20/2021 10:28:09'! -hasChanged - "Return true if this hand has changed, either because it has moved or because some morph it is holding has changed." - - ^ hasChanged ifNil: [ true ] -! - -HandMorph removeSelector: #redrawNeeded! - -!methodRemoval: HandMorph #redrawNeeded stamp: 'Install-4600-HandMorphCleanup-JuanVuletich-2021May15-20h25m-jmv.001.cs.st 5/20/2021 10:28:09'! -redrawNeeded - - hasChanged _ true! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4600-HandMorphCleanup-JuanVuletich-2021May15-20h25m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4597] on 15 May 2021 at 8:32:28 pm'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 5/15/2021 18:45:04' prior: 50567790! - fullUpdateCurrentBounds - | isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph drawOn: self. - currentMorph postDrawOn: self. ]. - currentMorph displayBoundsSetFrom: self. - isKnownFailing ifFalse: [ - currentMorph submorphsDo: [ :m | - self fullUpdateBounds: m ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4601-UpdateBoundsFix-JuanVuletich-2021May15-20h27m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4601] on 16 May 2021 at 10:30:50 am'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 5/15/2021 20:34:13' prior: 50570290! - fullUpdateCurrentBounds - | isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph drawOn: self. - currentMorph postDrawOn: self ]. - currentMorph displayBoundsSetFrom: self. - isKnownFailing ifFalse: [ - currentMorph submorphsDo: [ :m | - self fullUpdateBounds: m ]]! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 5/15/2021 20:46:17' prior: 50567892! - updateHandsDisplayBounds: aWorldMorph - "Update displayBounds for carried morphs if never set. - Useful for new morph, that are created and attached to the hand." - - aWorldMorph handsDo: [ :hand | - hand hasSubmorphs ifTrue: [ - self into: hand. - hand submorphsDo: [ :morph | - morph displayBounds ifNil: [ - self fullUpdateBounds: morph ]]. - self outOfMorph ]]! ! - -MorphicCanvas removeSelector: #updateCurrentDisplayBoundsAndMerge:! - -!methodRemoval: MorphicCanvas #updateCurrentDisplayBoundsAndMerge: stamp: 'Install-4602-Cleanup-JuanVuletich-2021May16-10h27m-jmv.001.cs.st 5/20/2021 10:28:09'! -updateCurrentDisplayBoundsAndMerge: aRectangle - "Update displayBounds for if never set. - Useful for new morph, that are created and attached to the hand." - - | isKnownFailing r | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph drawOn: self ]. - currentMorph displayBoundsSetFrom: self. - r _ self boundingRectOfCurrentMorphAfterDraw. - r _ r quickMerge: aRectangle. - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | - r _ self updateDisplayBounds: m andMerge: r ]]. - ^r! - -MorphicCanvas removeSelector: #updateDisplayBounds:andMerge:! - -!methodRemoval: MorphicCanvas #updateDisplayBounds:andMerge: stamp: 'Install-4602-Cleanup-JuanVuletich-2021May16-10h27m-jmv.001.cs.st 5/20/2021 10:28:09'! -updateDisplayBounds: aMorph andMerge: aRectangle - "Update displayBounds for if never set. - Useful for new morph, that are created and attached to the hand." - - | r | - r _ aRectangle. - aMorph visible ifTrue: [ - self into: aMorph. - r _ self canvasToUse updateCurrentDisplayBoundsAndMerge: r. - self outOfMorph - ]. - ^r! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4602-Cleanup-JuanVuletich-2021May16-10h27m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4601] on 16 May 2021 at 10:56:12 am'! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 5/15/2021 22:25:32'! - boundingRectOfCurrentMorphFromLocalBounds - "In targetForm coordinates. - Clipped to owner if appropriate." - - | boundingRect | - boundingRect _ currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds. - ^ clippingMorphDisplayBounds - ifNotNil: [ :ownerClips | boundingRect intersect: ownerClips ] - ifNil: [ boundingRect ]! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 5/16/2021 10:54:52' prior: 50570129! - displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - aRectangle is clipped appropiately if some owner clips us." - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - privateDisplayBounds _ self isOrthoRectangularMorph - ifTrue: [ - "In these cases, #drawOn: might not be able to find bounds (InnerTextMorph, for example), - but it is OK to compute them from #morphLocalBounds. This is not true for non-orthoRectangular morphs!!" - aCanvas boundingRectOfCurrentMorphFromLocalBounds] - ifFalse: [aCanvas boundingRectOfCurrentMorphAfterDraw]]]].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 5/16/2021 10:54:57' prior: 50570312! - fullUpdateCurrentBounds - - | isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph isOrthoRectangularMorph ifFalse: [ - "In these cases, #drawOn: is required to find bounds. - #displayBoundsSetFrom: will use the bounds found by us in these case. - See #displayBoundsSetFrom:" - currentMorph drawOn: self. - currentMorph postDrawOn: self ]. - currentMorph displayBoundsSetFrom: self. - currentMorph submorphsDo: [ :m | - self fullUpdateBounds: m ]]! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 5/16/2021 10:41:36' prior: 50536555 overrides: 50536532! - boundingRectOfCurrentMorphAfterDraw - "In targetForm coordinates. - Clipped to owner if appropriate. - BitBltCanvas doesn't keep track of Morph bounds as it draws them. But it is limited to drawing bounds where - #morphLocalBounds is known. Use it, then." - - | boundingRect | - boundingRect _ currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds. - ^ clippingMorphDisplayBounds - ifNotNil: [ :ownerClips | boundingRect intersect: ownerClips ] - ifNil: [ boundingRect ]! ! - -BitBltCanvas removeSelector: #boundingRectOfCurrentMorph! - -!methodRemoval: BitBltCanvas #boundingRectOfCurrentMorph stamp: 'Install-4603-BoundsUpdatesFixes-JuanVuletich-2021May16-10h30m-jmv.001.cs.st 5/20/2021 10:28:09'! -boundingRectOfCurrentMorph - "In targetForm coordinates. - Answer morph bounds, ignoring possible clipping by owner." - - ^currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4603-BoundsUpdatesFixes-JuanVuletich-2021May16-10h30m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4603] on 18 May 2021 at 5:32:21 pm'! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 5/18/2021 17:27:09' overrides: 50418015! - rounded - "Answer the integer nearest the receiver." - "See https://en.wikipedia.org/wiki/Rounding#Round_half_to_even" - - | truncated fractionPart | - truncated _ self truncated. - fractionPart _ self - truncated. - (fractionPart > -0.5 and: [fractionPart < 0.5]) - ifTrue: [^truncated]. - fractionPart > 0.5 - ifTrue: [ ^truncated + 1 ]. - fractionPart < -0.5 - ifTrue: [ ^truncated - 1 ]. - truncated even ifTrue: [^truncated]. - self > 0 - ifTrue: [ ^truncated + 1 ] - ifFalse: [ ^truncated - 1 ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4604-FastFloatRounded-JuanVuletich-2021May18-17h14m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4603] on 18 May 2021 at 2:37:49 pm'! -!BitBlt methodsFor: 'copying' stamp: 'jmv 5/18/2021 14:37:40' prior: 16785666! - copyBits - "Primitive. Perform the movement of bits from the source form to the - destination form. Fail if any variables are not of the right type (Integer, - Float, or Form) or if the combination rule is not implemented. - In addition to the original 16 combination rules, this BitBlt supports - 16 fail (to simulate paint) - 17 fail (to simulate mask) - 18 sourceWord + destinationWord - 19 sourceWord - destinationWord - 20 rgbAdd: sourceWord with: destinationWord - 21 rgbSub: sourceWord with: destinationWord - 22 rgbDiff: sourceWord with: destinationWord - 23 tallyIntoMap: destinationWord - 24 alphaBlend: sourceWord with: destinationWord - 25 pixPaint: sourceWord with: destinationWord - 26 pixMask: sourceWord with: destinationWord - 27 rgbMax: sourceWord with: destinationWord - 28 rgbMin: sourceWord with: destinationWord - 29 rgbMin: sourceWord bitInvert32 with: destinationWord -" - - - "No alpha specified -- re-run with alpha = 1.0" - (combinationRule >= 30 and: [combinationRule <= 31]) ifTrue: [ - ^ self copyBitsTranslucent: 255]. - - "Check for unimplmented rules" - combinationRule = Form oldPaint ifTrue: [^ self oldPaintBits]. - combinationRule = Form oldErase1bitShape ifTrue: [^ self oldErase1bitShapeBits]. - - "Check if BitBlt doesn't support full color maps" - (colorMap notNil and:[colorMap isColormap]) ifTrue:[ - colorMap _ colorMap colors. - ^self copyBits]. - "Check if clipping gots us way out of range" - self clipRange ifTrue:[self roundVariables. ^self copyBitsAgain]. - - 'Bad BitBlt argument (Maybe a Float or Fraction?); will retry rounding.' print. - "Convert all numeric parameters to integers and try again." - self roundVariables. - ^ self copyBitsAgain! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4605-DontErrorOnBatBitBltArg-JuanVuletich-2021May18-14h34m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4605] on 19 May 2021 at 10:56:14 am'! -!Random class methodsFor: 'services' stamp: 'jmv 5/19/2021 10:19:03'! - next - "Answer a Float in [0.0 .. 1.0) - Random next - " - - ^self withDefaultDo: [ :random | random next ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4606-Random-next-JuanVuletich-2021May19-10h56m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4605] on 19 May 2021 at 5:14:29 pm'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 5/19/2021 17:11:36' prior: 50552931! - drawWorld: aWorldMorph repair: aDamageRecorder - "Redraw the damaged areas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | visibleRootMorphs visibleRootsDamage worldDamage | - "Update #displayBounds for all dirty morphs (marked as such with #redrawNeeded). - Also add the updated bounds to aDamageRecorder, and update bounds of morphs carried by hand." - self updatingMorphBoundsDo: [ - aWorldMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - self updateHandsDisplayBounds: aWorldMorph ]. - - visibleRootMorphs _ aWorldMorph privateSubmorphs select: [ :m | m visible ]. - visibleRootsDamage _ Array new: visibleRootMorphs size. - - worldDamage _ self computeDamage: aWorldMorph repair: aDamageRecorder - rootMorphs: visibleRootMorphs rootMorphsDamage: visibleRootsDamage. - - self drawWorldBackground: aWorldMorph rects: worldDamage. - - self drawWorld: aWorldMorph - rootMorphs: visibleRootMorphs rootMorphsDamage: visibleRootsDamage - allDamage: worldDamage. - - aDamageRecorder reset. - ^ worldDamage! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 5/19/2021 17:10:47' prior: 50559532! - drawWorld: aWorldMorph rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage allDamage: worldDamage - "Redraw the damaged areas. - Draw each morph just once, merging rectanges to be repaired as needed." - - | morph morphDamage | - - "Iterate from back to front." - rootMorphs size to: 1 by: -1 do: [ :i | - morph _ rootMorphs at: i. - morphDamage _ rootMorphsDamage at: i. - morph displayFullBounds ifNotNil: [ :morphFullBounds | - worldDamage do: [ :r | | intersection | - intersection _ r intersect: morphFullBounds. - intersection hasPositiveExtent ifTrue: [ - morphDamage _ intersection quickMerge: morphDamage ]]]. - morphDamage ifNotNil: [ - self newClipRect: morphDamage. - self fullDraw: morph. - worldDamage add: morphDamage ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4607-MorphicWorldDrawFix-JuanVuletich-2021May19-17h13m-jmv.001.cs.st----! - -----SNAPSHOT----(20 May 2021 10:28:12) Cuis5.0-4607-32.image priorSource: 7564549! - -----STARTUP---- (29 May 2021 17:28:06) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4607-32.image! - - -'From Haver 5.0 [latest update: #4589] on 8 May 2021 at 3:33:56 pm'! -!Theme methodsFor: 'tool colors' stamp: 'KLG 5/8/2021 15:12:47'! - autoCompleter - "Answer the autocompleter's color for entries." - - ^ self text! ! -!Theme methodsFor: 'tool colors' stamp: 'KLG 5/8/2021 15:26:51'! - autoCompleterDefaultBorderColor - "Answer the auto comleters default border color." - - ^ `Color gray`! ! -!Theme methodsFor: 'tool colors' stamp: 'KLG 5/8/2021 15:09:00'! - autoCompleterMaybeInvalid - "Answer the autocompleter's color for possible invalid entries." - - ^ `Color blue`! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'KLG 5/8/2021 15:10:07' prior: 50433545! - colorOf: entry - - ^(completer isPossibleInvalidEntry: entry) - ifTrue: [ Theme current autoCompleterMaybeInvalid ] - ifFalse: [ Theme current autoCompleter ] - ! ! -!AutoCompleterMorph methodsFor: 'initialization' stamp: 'KLG 5/8/2021 15:27:47' prior: 50388302 overrides: 50545887! - defaultBorderColor - "My default border color. - - Note: My background color is derived from this color." - ^ Theme current autoCompleterDefaultBorderColor ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4608-AutoCompleterThemeSupport-GeraldKlix-2021May08-15h06m-KLG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4608] on 24 May 2021 at 9:47:26 am'! -!WorldMorph methodsFor: 'world state' stamp: 'jmv 5/24/2021 09:45:48'! - haloMorphsDo: aBlock - self handsDo: [ :hand | hand halo ifNotNil: [ :halo | aBlock value: halo ]].! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 5/24/2021 09:44:42' prior: 16875728! - halo - self world ifNotNil: [ :w | - w haloMorphsDo: [ :h | - h target == self ifTrue: [^ h]]]. - ^ nil! ! -!WorldMorph methodsFor: 'world state' stamp: 'jmv 5/24/2021 09:45:30' prior: 50553456! - deleteAllHalos - | c | - c _ OrderedCollection new. - self haloMorphsDo: [ :halo | c add: halo ]. - self removeAllMorphsIn: c! ! - -WorldMorph removeSelector: #haloMorphs! - -!methodRemoval: WorldMorph #haloMorphs stamp: 'Install-4609-HaloSmallRefactor-JuanVuletich-2021May24-09h42m-jmv.001.cs.st 5/29/2021 17:28:10'! -haloMorphs - ^ self hands collect:[:h| h halo] thenSelect:[:halo| halo notNil]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4609-HaloSmallRefactor-JuanVuletich-2021May24-09h42m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4610] on 24 May 2021 at 12:12:48 pm'! -!MethodReference methodsFor: 'comparisons' stamp: 'jmv 5/24/2021 10:02:56' prior: 16873130! - <= anotherMethodReference - - methodSymbol < anotherMethodReference methodSymbol ifTrue: [^true]. - methodSymbol > anotherMethodReference methodSymbol ifTrue: [^false]. - classSymbol < anotherMethodReference classSymbol ifTrue: [^true]. - classSymbol > anotherMethodReference classSymbol ifTrue: [^false]. - classIsMeta == anotherMethodReference classIsMeta ifFalse: [^classIsMeta not]. - ^true! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4610-SortSendersBySelector-JuanVuletich-2021May24-12h12m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4610] on 26 May 2021 at 12:04:38 pm'! -!HaloMorph methodsFor: 'drawing' stamp: 'jmv 5/26/2021 11:17:25'! - drawCoordinateSystemOn: aCanvas - - | x0 x1 y0 y1 c stepX stepY haloTargetTx prevTx | - haloTargetTx _ MorphicTranslation identity. - target allOwnersReverseDo: [ :o | haloTargetTx _ haloTargetTx composedWith: o location ]. - haloTargetTx _ haloTargetTx composedWith: target location. - - x0 _ x1 _ y0 _ y1 _ 0. - target displayFullBounds corners collect: [ :pt | | p | - p _ haloTargetTx inverseTransform: pt . - x0 _ x0 min: p x. - x1 _ x1 max: p x. - y0 _ y0 min: p y. - y1 _ y1 max: p y.]. - x1-x0 < 1000 ifTrue: [ - stepX _ 50. - stepY _ 20 ] - ifFalse: [ - stepX _ 100. - stepY _ 50 ]. - - prevTx _ aCanvas currentTransformation. - aCanvas geometryTransformation: haloTargetTx. - - c _ `Color black alpha: 0.6`. - aCanvas line: x0@0 to: x1@0 width: 2 color: c. - aCanvas line: 0@y0 to: 0@y1 width: 2 color: c. - - (x0 truncateTo: stepX) to: (x1 - stepX truncateTo: stepX) by: stepX do: [ :x | - aCanvas line: x @ -5 to: x @ 5 width: 2 color: c. - aCanvas drawString: x printString atCenterXBaselineY: x @ -10 font: nil color: c ]. - aCanvas drawString: 'x' atCenterX: x1 - 15 @ 0 font: nil color: c. - - (y0 truncateTo: stepY) to: (y1 - stepY truncateTo: stepY) by: stepY do: [ :y | - aCanvas line: -5 @ y to: 5 @ y width: 2 color: c. - aCanvas drawString: y printString, ' ' atWaistRight: -5 @ y font: nil color: c ]. - aCanvas drawString: 'y' atWaistRight: -5 @ (y1 - 20) font: nil color: c. - - aCanvas geometryTransformation: prevTx.! ! -!HaloMorph methodsFor: 'geometry testing' stamp: 'jmv 5/26/2021 09:02:31' overrides: 50569407! - containsGlobalPoint: worldPoint - - self visible ifTrue: [ - self topmostWorld ifNotNil: [ :w | - ^self morphLocalBounds containsPoint: - (self internalizeFromWorld: worldPoint) ]]. - ^ false! ! -!HaloMorph methodsFor: 'geometry testing' stamp: 'jmv 5/26/2021 09:03:21' overrides: 50548089! - requiresVectorCanvas - - target ifNotNil: [ - ^target requiresVectorCanvas ]. - ^false! ! -!MorphicCanvas methodsFor: 'accessing' stamp: 'jmv 5/26/2021 08:44:50'! - geometryTransformation: aGeometryTransformation - "Only used for testing. Usually, transformations are handled as we traverse the Morphs tree." - - currentTransformation _ aGeometryTransformation.! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 5/26/2021 11:00:07'! - drawString: s atCenterXBaselineY: pt font: fontOrNil color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - - | font | - font _ self fontToUse: fontOrNil. - ^self - drawString: s - from: 1 to: s size - atBaseline: pt - ((font widthOfString: s) / 2 @ 0) - font: font color: aColor! ! -!MorphicCanvas methodsFor: 'drawing - Global Coordinates' stamp: 'jmv 5/26/2021 11:25:46'! - frameAndFillGlobalRect: rect fillColor: fillColor borderWidth: borderWidth color: borderColor - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing - Global Coordinates' stamp: 'jmv 5/26/2021 10:15:12'! - frameGlobalRect: rect borderWidth: borderWidth color: borderColor - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing - Global Coordinates' stamp: 'jmv 5/26/2021 09:54:36'! - reverseGlobalRectangleBorder: r borderWidth: borderWidth - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 5/26/2021 11:31:02'! -drawHighlight: aMorph - - aMorph displayBounds ifNotNil: [ :r | - self - frameAndFillGlobalRect: r - fillColor: `Color pink alpha: 0.2` - borderWidth: 4 - color: `Color black` ].! ! -!BitBltCanvas methodsFor: 'drawing - Global Coordinates' stamp: 'jmv 5/26/2021 11:26:23' overrides: 50570861! - frameAndFillGlobalRect: rect fillColor: fillColor borderWidth: borderWidth color: borderColor - " - (BitBltCanvas onForm: Display) - frameAndFillGlobalRect: (10@10 extent: 300@200) - fillColor: Color green - borderWidth: 20 - color: Color red. - Display forceToScreen - " - engine ifNil: [ ^nil ]. - engine - combinationRule: (borderColor isOpaque ifTrue: [Form paint] ifFalse: [Form blend]); - fillColor: borderColor; - frameRect: rect borderWidth: borderWidth; - combinationRule: (fillColor isOpaque ifTrue: [Form paint] ifFalse: [Form blend]); - fillColor: fillColor; - fillRect: (rect insetBy: borderWidth). - ! ! -!BitBltCanvas methodsFor: 'drawing - Global Coordinates' stamp: 'jmv 5/26/2021 10:25:18' overrides: 50570868! - frameGlobalRect: rect borderWidth: borderWidth color: borderColor - " - (BitBltCanvas onForm: Display) - frameGlobalRect: (10@10 extent: 300@200) - borderWidth: 20 - color: Color red. - Display forceToScreen - " - engine ifNil: [ ^nil ]. - engine - combinationRule: (borderColor isOpaque ifTrue: [Form paint] ifFalse: [Form blend]); - fillColor: borderColor; - frameRect: rect borderWidth: borderWidth.! ! -!BitBltCanvas methodsFor: 'drawing - Global Coordinates' stamp: 'jmv 5/26/2021 10:18:16' overrides: 50570874! - reverseGlobalRectangleBorder: rect borderWidth: borderWidth - " - (BitBltCanvas onForm: Display) - reverseGlobalRectangleBorder: (10@10 extent: 300@200) - borderWidth: 20. - Display forceToScreen - " - engine ifNil: [ ^nil ]. - engine - sourceForm: nil; - fillColor: `Color gray`; - combinationRule: Form reverse; - frameRect: rect borderWidth: borderWidth! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 5/25/2021 20:24:49' prior: 50569416! - fullContainsGlobalPoint: worldPoint - "Answer true if worldPoint is in some submorph, even if not inside our shape." - - self visible ifTrue: [ - self topmostWorld ifNotNil: [ :w | - (self containsGlobalPoint: worldPoint) ifTrue: [ ^ true ]. - self submorphsDo: [ :m | - (m fullContainsGlobalPoint: worldPoint) ifTrue: [ ^ true ]]]]. - ^ false! ! -!HaloMorph methodsFor: 'drawing' stamp: 'jmv 5/26/2021 10:43:15' prior: 16850621 overrides: 16899205! - drawOn: aCanvas - - | b | - target ifNil: [^super drawOn: aCanvas]. - - Preferences halosShowCoordinateSystem ifTrue: [ - target displayFullBounds ifNotNil: [ :fb | - aCanvas frameGlobalRect: fb borderWidth: 3 color: `Color black alpha: 0.2`. - b _ target displayBounds. - b area > 0 ifTrue: [ - aCanvas frameGlobalRect: b borderWidth: 3 color: `Color black alpha: 0.4` ]. - self drawCoordinateSystemOn: aCanvas ]].! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 5/26/2021 11:09:15' prior: 50567438! - addHandles: aDisplayRectangle - "update my size. owner is world, therefore owner coordinates are Display coordinates." - - self morphBounds: (aDisplayRectangle outsetBy: 30@30). - haloBox _ self handlesBox. - target addHandlesTo: self box: haloBox. - self addNameString: (target printStringLimitedTo: 40). - self redrawNeeded.! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 5/26/2021 10:55:19' prior: 50558228! - doResize: evt with: resizeHandle - "Called while the mouse is down in the grow handle" - - | newExtent | -self revisar. - self flag: #jmvVer2. - evt hand obtainHalo: self. -"MUST fix resize / rescale / rotation of embedded morphs!!!!!!" -newExtent _ evt eventPosition - positionOffset - target morphPositionInWorld. - evt shiftPressed ifTrue: [newExtent _ (newExtent x max: newExtent y) asPoint]. - (newExtent x = 0 or: [newExtent y = 0]) ifTrue: [^ self]. - target morphExtentInWorld: newExtent. - resizeHandle morphPositionInWorld: evt eventPosition - (resizeHandle morphExtent // 2). - self redrawNeeded.! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 5/26/2021 10:55:23' prior: 50559364! - doRot: evt with: rotHandle - "Update the rotation of my target if it is rotatable." - - | radians | -"MUST fix resize / rescale / rotation of embedded morphs!!!!!!" - evt hand obtainHalo: self. - radians _ (evt eventPosition - target referencePosition) theta + angleOffset. - radians _ radians detentBy: 0.05 atMultiplesOf: Float pi / 4 snap: false. - radians = 0.0 - ifTrue: [rotHandle color: `Color lightBlue`] - ifFalse: [rotHandle color: `Color blue`]. - rotHandle submorphsDo: - [:m | m color: rotHandle color makeForegroundColor]. - target rotation: radians. - rotHandle morphPositionInWorld: evt eventPosition - (rotHandle morphExtent // 2). - self redrawNeeded.! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 5/26/2021 10:55:25' prior: 50559385! - doScale: evt with: scaleHandle - "Update the scale of my target if it is scalable." - - | scale | -"MUST fix resize / rescale / rotation of embedded morphs!!!!!!" - evt hand obtainHalo: self. - scale _ (evt eventPosition - target referencePosition) rho * scaleOffset. - scale = 1.0 - ifTrue: [scaleHandle color: `Color lightBlue`] - ifFalse: [scaleHandle color: `Color blue`]. - scaleHandle submorphsDo: - [:m | m color: scaleHandle color makeForegroundColor]. - target scale: scale. - scaleHandle morphPositionInWorld: evt eventPosition - (scaleHandle morphExtent // 2). - self redrawNeeded.! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 5/26/2021 09:30:19' prior: 50567818 overrides: 50564923! - drawCurrentAndSubmorphs - - self isCurrentMorphVisible ifTrue: [ - - currentMorph drawOn: self. - currentMorph displayBoundsSetFrom: self. - - "Display submorphs back to front" - "coordinate system stack already set up for aMorph - ('ivars transformations' and 'currentTransformation')" - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | self fullDraw: m ]]. - - currentMorph postDrawOn: self. - currentMorph displayBoundsUpdateFrom: self. - - currentMorph isHighlighted ifTrue: [ - self drawHighlight: currentMorph ]. - ].! ! - -BitBltCanvas removeSelector: #drawCoordinateSystem:! - -!methodRemoval: BitBltCanvas #drawCoordinateSystem: stamp: 'Install-4611-CoordinateSystemsRefactor-JuanVuletich-2021May26-11h54m-jmv.001.cs.st 5/29/2021 17:28:10'! -drawCoordinateSystem: aRectangle - | c stepX stepY x0 x1 y0 y1 prevClipRect | - stepX _ 100. - stepY _ 50. - - prevClipRect _ self clipRect. - self setClipRect: (prevClipRect intersect: currentMorph displayBounds). - - self frameRectangle: aRectangle borderWidth: 4 color: `Color lightGray alpha: 0.4`. - - x0 _ aRectangle left. - x1 _ aRectangle right-1. - y0 _ aRectangle top. - y1 _ aRectangle bottom-1. - - c _ `Color lightGray alpha: 0.6`. - self line: x0@0 to: x1@0 width: 2 color: c. - self line: 0@y0 to: 0@y1 width: 2 color: c. - - (x0 truncateTo: stepX) to: (x1 - stepX truncateTo: stepX) by: stepX do: [ :x | - self line: x @ -5 to: x @ 5 width: 2 color: c. - self drawString: x printString atCenterX: x @ 5 font: nil color: c ]. - self drawString: 'x' atCenterX: x1 - 15 @ 0 font: nil color: c. - - (y0 truncateTo: stepY) to: (y1 - stepY truncateTo: stepY) by: stepY do: [ :y | - self line: -5 @ y to: 5 @ y width: 2 color: c. - self drawString: y printString, ' ' atWaist: 5 @ y font: nil color: c ]. - self drawString: 'y' atWaist: 0 @ (y1 - 20) font: nil color: c. - - self setClipRect: prevClipRect.! - -BitBltCanvas removeSelector: #drawCurrentMorphHighlight! - -!methodRemoval: BitBltCanvas #drawCurrentMorphHighlight stamp: 'Install-4611-CoordinateSystemsRefactor-JuanVuletich-2021May26-11h54m-jmv.001.cs.st 5/29/2021 17:28:10'! -drawCurrentMorphHighlight - - currentMorph displayBounds ifNotNil: [ :r | - engine - sourceForm: nil; - colorMap: nil; - combinationRule: Form blend; - fillColor: `Color black`; - frameRect: r borderWidth: 4; - fillColor: `Color pink alpha: 0.2`; - fillRect: (r insetBy: 4). - ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4611-CoordinateSystemsRefactor-JuanVuletich-2021May26-11h54m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4611] on 26 May 2021 at 12:26:45 pm'! -!MorphicCanvas methodsFor: 'drawing - Global Coordinates' stamp: 'jmv 5/26/2021 12:12:14'! - frameReverseGlobalRect: r borderWidth: borderWidth - self subclassResponsibility.! ! -!BitBltCanvas methodsFor: 'drawing - Global Coordinates' stamp: 'jmv 5/26/2021 12:12:48' overrides: 50571139! - frameReverseGlobalRect: rect borderWidth: borderWidth - " - (BitBltCanvas onForm: Display) - frameReverseGlobalRect: (10@10 extent: 300@200) - borderWidth: 20. - Display forceToScreen - " - engine ifNil: [ ^nil ]. - engine - sourceForm: nil; - fillColor: `Color gray`; - combinationRule: Form reverse; - frameRect: rect borderWidth: borderWidth! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 5/26/2021 12:12:26' prior: 50567781! - drawCurrentAsOutline - - self isCurrentMorphVisible ifTrue: [ - self frameReverseGlobalRect: currentMorph displayBounds borderWidth: 2. - currentMorph displayBoundsSetFrom: self ].! ! - -BitBltCanvas removeSelector: #reverseRectangleBorder:borderWidth:! - -!methodRemoval: BitBltCanvas #reverseRectangleBorder:borderWidth: stamp: 'Install-4612-BetterNaming-JuanVuletich-2021May26-12h26m-jmv.001.cs.st 5/29/2021 17:28:10'! -reverseRectangleBorder: r borderWidth: borderWidth - " - Display getCanvas - reverseRectangleBorder: (10@10 extent: 300@200) - borderWidth: 20. - Display forceToScreen - " - | rect | - - engine ifNil: [ ^nil ]. - - rect _ (currentTransformation externalizeRectangle: r) rounded. - engine - sourceForm: nil; - fillColor: `Color gray`; - combinationRule: Form reverse; - frameRect: rect borderWidth: borderWidth! - -BitBltCanvas removeSelector: #reverseGlobalRectangleBorder:borderWidth:! - -!methodRemoval: BitBltCanvas #reverseGlobalRectangleBorder:borderWidth: stamp: 'Install-4612-BetterNaming-JuanVuletich-2021May26-12h26m-jmv.001.cs.st 5/29/2021 17:28:10'! -reverseGlobalRectangleBorder: rect borderWidth: borderWidth - " - (BitBltCanvas onForm: Display) - reverseGlobalRectangleBorder: (10@10 extent: 300@200) - borderWidth: 20. - Display forceToScreen - " - engine ifNil: [ ^nil ]. - engine - sourceForm: nil; - fillColor: `Color gray`; - combinationRule: Form reverse; - frameRect: rect borderWidth: borderWidth! - -MorphicCanvas removeSelector: #reverseRectangleBorder:borderWidth:! - -!methodRemoval: MorphicCanvas #reverseRectangleBorder:borderWidth: stamp: 'Install-4612-BetterNaming-JuanVuletich-2021May26-12h26m-jmv.001.cs.st 5/29/2021 17:28:10'! -reverseRectangleBorder: r borderWidth: borderWidth - self subclassResponsibility.! - -MorphicCanvas removeSelector: #reverseGlobalRectangleBorder:borderWidth:! - -!methodRemoval: MorphicCanvas #reverseGlobalRectangleBorder:borderWidth: stamp: 'Install-4612-BetterNaming-JuanVuletich-2021May26-12h26m-jmv.001.cs.st 5/29/2021 17:28:10'! -reverseGlobalRectangleBorder: r borderWidth: borderWidth - self subclassResponsibility.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4612-BetterNaming-JuanVuletich-2021May26-12h26m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4612] on 26 May 2021 at 2:48:21 pm'! -!Morph methodsFor: 'submorphs-accessing' stamp: 'jmv 5/26/2021 14:45:18'! -allSubmorphsDo: aBlock - "Evaluate the given block for all morphs in this composite morph (including the receiver)." - - submorphs do: [ :m | - aBlock value: m. - m allSubmorphsDo: aBlock].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 5/26/2021 14:45:29' prior: 50570101! - adjustDisplayBoundsBy: delta - "Private for framework use. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us." - - privateDisplayBounds ifNotNil: [ - privateDisplayBounds _ privateDisplayBounds translatedBy: delta ]. - self allSubmorphsDo: [ :m | m adjustDisplayBoundsBy: delta ].! ! -!Morph methodsFor: 'submorphs-accessing' stamp: 'jmv 5/26/2021 14:46:46' prior: 16876668! - allMorphsDo: aBlock - "Evaluate the given block for all morphs in this composite morph (including the receiver)." - - aBlock value: self. - self allSubmorphsDo: aBlock! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4613-allSubmorphsDo-JuanVuletich-2021May26-14h44m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4613] on 28 May 2021 at 1:10:02 pm'! - -LabelMorph subclass: #MenuItemMorph - instanceVariableNames: 'isEnabled subMenu isSelected target selector arguments icon contentString ' - classVariableNames: 'SubMenuMarker OnImage OffImage ' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #MenuItemMorph category: #'Morphic-Menus' stamp: 'Install-4614-MenuItemMorph-form-caching-JuanVuletich-2021May28-13h09m-jmv.001.cs.st 5/29/2021 17:28:10'! -LabelMorph subclass: #MenuItemMorph - instanceVariableNames: 'isEnabled subMenu isSelected target selector arguments icon contentString' - classVariableNames: 'OffImage OnImage SubMenuMarker' - poolDictionaries: '' - category: 'Morphic-Menus'! -!MenuItemMorph methodsFor: 'private' stamp: 'jmv 5/28/2021 10:21:25' prior: 50506109! - offImage - "Return the form to be used for indicating an '' marker" - | e | - e _ (self fontToUse ascent-2) rounded asPoint. - (OffImage isNil or: [ OffImage extent ~= e ]) ifTrue: [ - OffImage _ Form extent: e depth: 32. - OffImage getCanvas - frameAndFillRectangle: OffImage boundingBox fillColor: `(Color gray: 0.9)` - borderWidth: 1 borderColor: `Color black` ]. - ^OffImage! ! -!MenuItemMorph methodsFor: 'private' stamp: 'jmv 5/28/2021 10:21:32' prior: 50506121! - onImage - "Return the form to be used for indicating an '' marker" - | e | - e _ (self fontToUse ascent-2) rounded asPoint. - (OnImage isNil or: [ OnImage extent ~= e ]) ifTrue: [ - OnImage _ Form extent: e depth: 32. - OnImage getCanvas - frameAndFillRectangle: OnImage boundingBox fillColor: `Color gray: 0.8` - borderWidth: 1 borderColor: `Color black`; - fillRectangle: (OnImage boundingBox insetBy: 2) color: `Color black` ]. - ^OnImage! ! - -LabelMorph subclass: #MenuItemMorph - instanceVariableNames: 'isEnabled subMenu isSelected target selector arguments icon contentString' - classVariableNames: 'OffImage OnImage SubMenuMarker' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #MenuItemMorph category: #'Morphic-Menus' stamp: 'Install-4614-MenuItemMorph-form-caching-JuanVuletich-2021May28-13h09m-jmv.001.cs.st 5/29/2021 17:28:10'! -LabelMorph subclass: #MenuItemMorph - instanceVariableNames: 'isEnabled subMenu isSelected target selector arguments icon contentString' - classVariableNames: 'OffImage OnImage SubMenuMarker' - poolDictionaries: '' - category: 'Morphic-Menus'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4614-MenuItemMorph-form-caching-JuanVuletich-2021May28-13h09m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4613] on 28 May 2021 at 1:11:15 pm'! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 5/28/2021 10:41:02' prior: 50557881! - resizeLeftCursor - ^ `(Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0000000000000000 - 2r0000010010000000 - 2r0000010010000000 - 2r0000010010000000 - 2r0001010010100000 - 2r0011010010110000 - 2r0111010010111000 - 2r1111110011111100 - 2r0111010010111000 - 2r0011010010110000 - 2r0001010010100000 - 2r0000010010000000 - 2r0000010010000000 - 2r0000010010000000 - 2r0000000000000000 - 2r0000000000000000) - offset: `-7@-7`) withMask`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 5/28/2021 10:41:13' prior: 50557898! - resizeTopCursor - ^ `(Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0000000100000000 - 2r0000001110000000 - 2r0000011111000000 - 2r0000111111100000 - 2r0000000100000000 - 2r0111111111111100 - 2r0000000000000000 - 2r0000000000000000 - 2r0111111111111100 - 2r0000000100000000 - 2r0000111111100000 - 2r0000011111000000 - 2r0000001110000000 - 2r0000000100000000 - 2r0000000000000000 - 2r0000000100000000) - offset: `-7@-7`) withMask`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 5/28/2021 10:41:21' prior: 50557915! - resizeTopLeftCursor - ^ `(Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0000000000000000 - 2r0111110000010000 - 2r0111100000100000 - 2r0111000001000100 - 2r0110100010001000 - 2r0100010100010000 - 2r0000001000100000 - 2r0000010001000000 - 2r0000100010000000 - 2r0001000101000100 - 2r0010001000101100 - 2r0000010000011100 - 2r0000100000111100 - 2r0000000001111100 - 2r0000000000000000 - 2r0000000000000000) - offset: `-7@-7`) withMask`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 5/28/2021 10:41:28' prior: 50557932! - resizeTopRightCursor - ^ `(Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0000000000000000 - 2r0001000001111100 - 2r0000100000111100 - 2r0100010000011100 - 2r0010001000101100 - 2r0001000101000100 - 2r0000100010000000 - 2r0000010001000000 - 2r0000001000100000 - 2r0100010100010000 - 2r0110100010001000 - 2r0111000001000000 - 2r0111100000100000 - 2r0111110000000000 - 2r0000000000000000 - 2r0000000000000000) - offset: `-7@-7`) withMask`.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4615-Cursor-makeInstancesLiteral-JuanVuletich-2021May28-13h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4613] on 28 May 2021 at 1:11:50 pm'! -!AutoCompleterMorph methodsFor: 'testing' stamp: 'jmv 5/28/2021 11:16:16' prior: 50433817! - isXOutOfScreen: aLocation with: anExtent - - ^aLocation x + anExtent x > Display width! ! -!AutoCompleterMorph methodsFor: 'testing' stamp: 'jmv 5/28/2021 11:16:23' prior: 50433823! - isYOutOfScreen: aLocation with: anExtent - - ^aLocation y + anExtent y > Display height! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4616-Cleanup-JuanVuletich-2021May28-13h11m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4613] on 28 May 2021 at 1:20:12 pm'! -!DisplayScreen class methodsFor: 'display box access' stamp: 'jmv 5/28/2021 11:13:51'! - isDisplayExtentOk - "False if Cuis main window size has changed, but Display hasn't been updated yet." - - ^Display extent = DisplayScreen actualScreenSize! ! -!DisplayScreen class methodsFor: 'screen update' stamp: 'jmv 5/28/2021 11:38:25'! - terminateScreenUpdater - - ScreenUpdaterProcess ifNotNil: [ - ScreenUpdaterProcess terminate. - ScreenUpdaterProcess _ nil ]! ! -!Transcripter methodsFor: 'accessing' stamp: 'jmv 5/28/2021 11:14:54' prior: 50522662! - endEntry - | c d cb | - c _ self contents. - DisplayScreen isDisplayExtentOk ifFalse: [ - "Handle case of user resizing physical window" - DisplayScreen startUp. - frame _ frame intersect: Display boundingBox. - ^ self clear; show: c]. - textComposition - setModel: (TextModel withText: c asText); - extentForComposing: frame width-8 @9999. - textComposition composeAll. - d _ textComposition usedHeight - frame height. - d > 0 ifTrue: [ - "Scroll up to keep all contents visible" - cb _ textComposition characterBlockAtPoint: - `0@0` + (0@(d+FontFamily defaultLineSpacing)). - self on: (c copyFrom: cb stringIndex to: c size). - readLimit _ position _ collection size. - ^ self endEntry]. - Display fill: (frame insetBy: -2) fillColor: self black; - fill: frame fillColor: self white. - Display getCanvas - textComposition: textComposition - bounds: (`4@4` + frame topLeft extent: Display extent) - color: `Color black` - selectionColor: `Color blue`. - DisplayScreen screenUpdateRequired: nil! ! -!UISupervisor class methodsFor: 'services' stamp: 'jmv 5/28/2021 13:17:39' prior: 50470945! - restoreDisplay - self ui ifNotNil: [ :guiRootObject | - DisplayScreen isDisplayExtentOk ifFalse: [ - "Deallocate before allocating could mean less memory stress." - guiRootObject clearCanvas ]]. - DisplayScreen startUp. - self ui ifNotNil: [ :guiRootObject | - guiRootObject restoreDisplay ]. - self whenUIinSafeState: [ Cursor defaultCursor activateCursor ].! ! -!DisplayScreen class methodsFor: 'display box access' stamp: 'jmv 5/28/2021 11:14:20' prior: 50379648! - checkForNewScreenSize - "Check whether the screen size has changed and if so take appropriate actions" - - self isDisplayExtentOk ifFalse: [ - UISupervisor restoreDisplay ]! ! -!DisplayScreen class methodsFor: 'snapshots' stamp: 'jmv 5/28/2021 11:38:55' prior: 50383995 overrides: 16785023! - shutDown - "Minimize Display memory saved in image" - Display setExtent: `240@120` depth: Display nativeDepth. - self terminateScreenUpdater! ! -!DisplayScreen class methodsFor: 'snapshots' stamp: 'jmv 5/28/2021 11:39:19' prior: 16835532 overrides: 50335344! -startUp - " - DisplayScreen startUp - " - self terminateScreenUpdater. - Display setExtent: self actualScreenSize depth: Display nativeDepth. - Display beDisplay. - self installScreenUpdater! ! -!DisplayScreen class methodsFor: 'screen update' stamp: 'jmv 5/28/2021 11:39:06' prior: 16835540! - installScreenUpdater - "Initialize the event tickler process. Terminate the old process if any." - " - DisplayScreen installScreenUpdater - " - - self terminateScreenUpdater. - ScreenUpdaterProcess _ [ self screenUpdater ] newProcess. - ScreenUpdaterProcess priority: Processor lowIOPriority. - ScreenUpdaterProcess name: 'Background Screen updater'. - ScreenUpdaterProcess resume! ! -!DisplayScreen class methodsFor: 'screen update' stamp: 'jmv 5/28/2021 11:33:49' prior: 16835564! - screenUpdater - | delay | - delay _ Delay forMilliseconds: 50. - ScreenUpdaterSemaphore _ Semaphore new. - Damage _ nil. - [ - delay wait. - ScreenUpdaterSemaphore wait. - Display forceToScreen: Damage. - ScreenUpdaterSemaphore initSignals. - Damage _ nil. - ] repeat! ! -!WorldMorph methodsFor: 'canvas' stamp: 'jmv 5/28/2021 13:16:50' prior: 50551485! - setCanvas - self clearCanvas. "Deallocate before allocating could mean less memory stress." - self setCanvas: Display getCanvas. - damageRecorder _ DamageRecorder new. - self redrawNeeded! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - DisplayScreen installScreenUpdater! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4617-FixOccasionalCrashOnMainWindowResize-JuanVuletich-2021May28-13h11m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4613] on 28 May 2021 at 2:14:09 pm'! -!MorphicCanvas methodsFor: 'initialization' stamp: 'jmv 5/28/2021 10:08:06'! - initializeWith: aForm origin: aPoint preferSubPixelAntiAliasing: aBoolean - self initialize. - self setForm: aForm preferSubPixelAntiAliasing: aBoolean. - - "Set up these only on initialization. - This is safe (wrt walkbacks during world redraw) because a new instance is created - on draw error. See #displayWorldSafely" - currentTransformation _ MorphicTranslation withTranslation: aPoint. - cti _ 1. - transformations - ifNil: [ transformations _ OrderedCollection with: currentTransformation ] - ifNotNil: [ transformations at: cti put: currentTransformation ]. - drawingMorphStack - ifNil: [ drawingMorphStack _ OrderedCollection with: nil ] - ifNotNil: [ drawingMorphStack at: cti put: nil ].! ! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 5/28/2021 10:03:45'! - setForm: aForm preferSubPixelAntiAliasing: aBoolean - form _ aForm.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 5/28/2021 10:06:37'! - onFormWithSubPixelAntiAliasing: aForm - - ^ self subclassToUse basicNew - initializeWith: aForm origin: `0@0` preferSubPixelAntiAliasing: true! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 5/28/2021 10:08:10' overrides: 50571617! - setForm: aForm preferSubPixelAntiAliasing: aBoolean - super setForm: aForm preferSubPixelAntiAliasing: aBoolean. - engine _ BitBltCanvasEngine toForm: form. - "Init BitBlt so that the first call to the 'primitiveDisplayString' primitive will not fail" - engine sourceX: 0; width: 0. - self newClipRect: nil.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 5/28/2021 10:05:53' prior: 50536746! - on: aForm over: aRectangle - "Warning: aForm extent must equal aRectangle extent" - - ^ self subclassToUse basicNew - initializeWith: aForm origin: aRectangle topLeft negated preferSubPixelAntiAliasing: false! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 5/28/2021 10:06:00' prior: 50536755! - onForm: aForm - - ^ self subclassToUse basicNew - initializeWith: aForm origin: `0@0` preferSubPixelAntiAliasing: false! ! - -BitBltCanvas removeSelector: #setForm:! - -!methodRemoval: BitBltCanvas #setForm: stamp: 'Install-4618-OptimizeInstanceCreation-JuanVuletich-2021May28-13h20m-jmv.001.cs.st 5/29/2021 17:28:11'! -setForm: aForm - super setForm: aForm. - engine _ BitBltCanvasEngine toForm: form. - "Init BitBlt so that the first call to the 'primitiveDisplayString' primitive will not fail" - engine sourceX: 0; width: 0. - self newClipRect: nil.! - -MorphicCanvas removeSelector: #setForm:! - -!methodRemoval: MorphicCanvas #setForm: stamp: 'Install-4618-OptimizeInstanceCreation-JuanVuletich-2021May28-13h20m-jmv.001.cs.st 5/29/2021 17:28:11'! -setForm: aForm - form _ aForm.! - -MorphicCanvas removeSelector: #initializeWith:origin:! - -!methodRemoval: MorphicCanvas #initializeWith:origin: stamp: 'Install-4618-OptimizeInstanceCreation-JuanVuletich-2021May28-13h20m-jmv.001.cs.st 5/29/2021 17:28:11'! -initializeWith: aForm origin: aPoint - self initialize. - self setForm: aForm. - - "Set up these only on initialization. - This is safe (wrt walkbacks during world redraw) because a new instance is created - on draw error. See #displayWorldSafely" - currentTransformation _ MorphicTranslation withTranslation: aPoint. - cti _ 1. - transformations - ifNil: [ transformations _ OrderedCollection with: currentTransformation ] - ifNotNil: [ transformations at: cti put: currentTransformation ]. - drawingMorphStack - ifNil: [ drawingMorphStack _ OrderedCollection with: nil ] - ifNotNil: [ drawingMorphStack at: cti put: nil ].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4618-OptimizeInstanceCreation-JuanVuletich-2021May28-13h20m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4618] on 29 May 2021 at 5:24:45 pm'! -!Utilities class methodsFor: 'default desktop' stamp: 'jmv 5/29/2021 17:24:04' prior: 50565660! - defaultTextEditorContents - ^ (' -', -('Cuis Smalltalk - -' centered blue pointSize: FontFamily defaultPointSize * 3), -(' -"Yay, Juan. You GO, guy!! ...a great example of malleable software (and a clever mind) at work." -' rightFlush pointSize: FontFamily defaultPointSize * 0.6), -('Dan Ingalls -' italic rightFlush pointSize: FontFamily defaultPointSize * 0.6), -(' -"I like it... It''s nice and clean and simple and pretty. Nice stuff!!" -' rightFlush pointSize: FontFamily defaultPointSize * 0.6), -('Alan Kay -' italic rightFlush pointSize: FontFamily defaultPointSize * 0.6), -(' -"I think you have a very elegant design aesthetic." -' rightFlush pointSize: FontFamily defaultPointSize * 0.6), -('John Maloney -'italic rightFlush pointSize: FontFamily defaultPointSize * 0.6), -' - -', -'Cuis is a modern, Open Source, multiplatform, Smalltalk-80 system. - - -', -'Cuis is: - -' bold, -' - Small - - Clean - - Appropriable -' blue, -' - -Additionally, Cuis is: - -' bold, -' - Open Source - - Multiplatform -' blue, -' - -Like other Smalltalk systems, Cuis is also: - -' bold, -' - A complete development environment written in itself - - A pure, dynamic Object Oriented language -' blue, -' - -Cuis assumes very little on the underlying platform, and this lets it run out-of-the-box on Windows, MacOS, Linux, ChromeOS and WebBrowsers. Cuis shares the [OpenSmalltalk Virtual Machine] (http://www.opensmalltalk.org) with Squeak, Pharo and Newspeak. - -What sets Cuis apart from the other members of the Squeak family is the focus on Smalltalk-80 and an active attitude towards system complexity: - -Unbound complexity growth, together with development strategies focused only in the short term, are the worst long term enemies of all software systems. As systems grow older, they usually become more complex. New features are added as layers on top of whatever is below, sometimes without really understanding it, and almost always without modifying it. Complexity and size grow without control. Evolution slows down. Understanding the system becomes harder every day. Bugs are harder to fix. Codebases become huge for no clear reason. At some point, the system can''t evolve anymore and becomes "legacy code". - -Complexity puts a limit to the level of understanding of the system a person might reach, and therefore limits the things that can be done with it. Dan Ingalls says all this in ["Design Principles Behind Smalltalk"] (http://www.cs.virginia.edu/~evans/cs655/readings/smalltalk.html). Even if you have already done so, please go and read it again!! - -Cuis Smalltalk is our attempt at this challenge. Furthermore, we believe we are doing something else that no other Smalltalk, commercial or open source, does. We attempt to give the true Smalltalk-80 experience, and keep Smalltalk-80 not as legacy software of historic significance, but as a live, evolving system. We feel we are the keepers of the Smalltalk-80 heritage, and enablers of the Dynabook experience. - -As Cuis evolves, we keep on these values. Every update, be it a bug fix or a feature enhancement, is reviewed carefully to avoid adding unneded complexity to the system. Every opportunity to remove unneded complexity is followed. As we go, features are enhanced, and any reported bugs fixed. We also adopt selected enhancements from Squeak and Pharo, and share our work with the wider Smalltalk community. - - -' justified, -'License -' bold, -' -Cuis is distributed subject to the MIT License, as in http://www.opensource.org/licenses/mit-license.php . Any contribution submitted for incorporation into or for distribution with Cuis shall be presumed subject to the same license. - -Portions of Cuis are: -Copyright (c) Xerox Corp. 1981, 1982 -Copyright (c) Apple Computer, Inc. 1985-1996 -Copyright (c) Contributors to Squeak project. 1997-2021 -Copyright (c) Contributors to Cuis Smalltalk project. 2009-2021')! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4619-AboutCuisCorrection-JuanVuletich-2021May29-17h24m-jmv.001.cs.st----! - -----SNAPSHOT----(29 May 2021 17:28:13) Cuis5.0-4619-32.image priorSource: 7648494! - -----STARTUP---- (20 July 2021 16:51:43) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4619-32.image! - - -'From Cuis 5.0 [latest update: #4619] on 31 May 2021 at 4:25:47 pm'! -!Color methodsFor: 'access' stamp: 'jmv 6/18/2017 20:31:54' prior: 50418788! - hue - "Return the hue of this color, an angle in the range [0.0..360.0]. - Color orange hue - " - - | r g b max min span h | - r _ self red. - g _ self green. - b _ self blue. - max _ (r max: g) max: b. - min _ (r min: g) min: b. - span _ (max - min) asFloat. - span = 0.0 ifTrue: [ ^ 0.0 ]. - - r = max ifTrue: [ - h _ ((g - b) asFloat / span) * 60.0. - ] ifFalse: [ - g = max - ifTrue: [ h _ 120.0 + (((b - r) asFloat / span) * 60.0). ] - ifFalse: [ h _ 240.0 + (((r - g) asFloat / span) * 60.0). ]. - ]. - - ^h mod: 360.0! ! -!Color methodsFor: 'access' stamp: 'jmv 6/18/2017 20:34:08' prior: 50418807! - saturation - "Return the saturation of this color, a value between 0.0 and 1.0. - Color red saturation - Color gray saturation - " - - | r g b max min | - r _ self red. - g _ self green. - b _ self blue. - max _ (r max: g) max: b. - min _ (r min: g) min: b. - max = 0.0 ifTrue: [ ^0.0 ]. - ^max - min / max! ! -!Color methodsFor: 'conversions' stamp: 'jmv 5/31/2021 10:13:33' prior: 50353403! - closestPixelValue8 - "Return the nearest approximation to this color for an 8-bit deep Form. - Note: Answer values in the standard Color indexedColors. - Not useful for ColorForms with custom palettes!!" - - "fast special cases" - self isBlack ifTrue: [^ 1]. "black" - self isWhite ifTrue: [^ 255]. "white" - - ^self saturation < 0.2 - ifTrue: [ - ^ self class grayToIndexMap at:(self green * 255) rounded + 1. "nearest gray" - ] - ifFalse: [ - "compute nearest entry in the color cube" - 40 + - ((self red * 5) rounded * 36) + - ((self blue * 5) rounded * 6) + - (self green * 5) rounded ]! ! -!Color class methodsFor: 'class initialization' stamp: 'jmv 4/17/2015 15:06' prior: 50418820! - initializeGrayToIndexMap - "Build an array of gray values available in the 8-bit colormap. This array is indexed by a gray level between black (1) and white (256) and returns the pixel value for the corresponding gray level." - "Note: This method must be called after initializeIndexedColors, since it uses IndexedColors." - " - Color initializeGrayToIndexMap - " - - | grayLevels grayIndices c distToClosest dist indexOfClosest indexedColors | - "record the level and index of each gray in the 8-bit color table" - grayLevels _ OrderedCollection new. - grayIndices _ OrderedCollection new. - indexedColors _ self indexedColors. - "Note: skip the first entry, which is reserved for transparent" - 2 to: indexedColors size do: [:i | - c _ indexedColors at: i. - c saturation = 0.0 ifTrue: [ "c is a gray" - grayLevels add: (c green * 255) rounded. "0 to 255; R, G, and B are the same" - grayIndices add: i - 1]]. "pixel values are zero-based" - grayLevels _ grayLevels asArray. - grayIndices _ grayIndices asArray. - - "for each gray level in [0..255], select the closest match" - GrayToIndexMap _ ByteArray new: 256. - 0 to: 255 do: [ :level | - distToClosest _ 10000. "greater than distance to any real gray" - 1 to: grayLevels size do: [:i | - dist _ (level - (grayLevels at: i)) abs. - dist < distToClosest ifTrue: [ - distToClosest _ dist. - indexOfClosest _ grayIndices at: i]]. - GrayToIndexMap at: (level + 1) put: indexOfClosest]! ! -!TranslucentColor methodsFor: 'queries' stamp: 'jmv 6/18/2017 20:41:54' prior: 50418868 overrides: 50353829! - isTransparent - ^ self alpha = 0.0! ! -!Float methodsFor: 'converting' stamp: 'nice 4/23/2011 02:24' prior: 50418689 overrides: 16879954! - withNegativeSign - "Same as super, but handle the subtle case of Float negativeZero" - - self = 0.0 ifTrue: [^self class negativeZero]. - ^super withNegativeSign! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 5/31/2021 07:43:09' prior: 50421975! - ulp - "Answer the unit of least precision of the receiver. - Follow John Harrison's definition as described at - https://en.wikipedia.org/wiki/Unit_in_the_last_place" - - self isFinite ifFalse: [^self abs]. - self = 0.0 ifTrue: [^0.0 nextAwayFromZero]. - ^ (self - self nextTowardsZero) abs! ! -!Float methodsFor: 'printing' stamp: 'jmv 7/11/2018 17:45:59' prior: 50418729! - printAsIEEE32BitPrecisionFloatOn: aStream base: base - "Handle sign, zero, and NaNs; all other values passed to absPrintOn:base:mantissaSignificantBits: - Print as a 32 bit Float" - - self isNaN ifTrue: [aStream nextPutAll: 'NaN'. ^ self]. "check for NaN before sign" - self > 0.0 - ifTrue: [self absPrintOn: aStream base: base mantissaSignificantBits: 24] - ifFalse: - [self sign = -1 - ifTrue: [aStream nextPutAll: '-']. - self = 0.0 - ifTrue: [aStream nextPutAll: '0.0'. ^ self] - ifFalse: [self negated absPrintOn: aStream base: base mantissaSignificantBits: 24]]! ! -!Float methodsFor: 'printing' stamp: 'jmv 5/31/2021 07:37:11' prior: 50421394 overrides: 16880278! - printOn: aStream base: base - "Handle sign, zero, and NaNs; all other values passed to absPrintOn:base:" - - self isNaN ifTrue: [aStream nextPutAll: 'NaN'. ^ self]. "check for NaN before sign" - self > 0.0 - ifTrue: [self absPrintOn: aStream base: base] - ifFalse: - [self sign = -1 - ifTrue: [aStream nextPutAll: '-']. - self = 0.0 - ifTrue: [aStream nextPutAll: '0.0'] - ifFalse: [self negated absPrintOn: aStream base: base]]! ! -!Float methodsFor: 'printing' stamp: 'jmv 5/31/2021 07:41:56' prior: 50509424 overrides: 16880428! - storeOn: aStream base: base - - "Print the Number exactly so it can be interpreted back unchanged" - - self sign = -1 ifTrue: [aStream nextPutAll: '-']. - base = 10 ifFalse: [aStream print: base; nextPut: $r]. - self = 0.0 - ifTrue: [aStream nextPutAll: '0.0'] - ifFalse: [self abs absPrintExactlyOn: aStream base: base]! ! -!Form methodsFor: 'converting' stamp: 'jmv 5/31/2021 07:19:06' prior: 50383487! - asGrayForm - | answer map | - - "For lower bit depths, the 15 bit ColorMap loses no information, - and answers the real #luminance of each pixel." - self depth < 32 ifTrue: [ - answer _ GrayForm extent: width@height. - map _ self colormapIfNeededForGray8bpp. - (BitBlt toForm: answer) - colorMap: map; - copy: self boundingBox - from: `0@0` in: self - fillColor: nil rule: Form over. - answer offset: self offset. - ^ answer ]. - - "For 32bpp, the approach above would use just 5bits per component. - Generally it is best to extract a component in full 8bpp and keep full dynamic range. - Green usually is a good choice." - ^ self asGrayForm: 3! ! -!Form methodsFor: 'converting' stamp: 'jmv 5/31/2021 07:20:06' prior: 16847530! - orderedDither32To16 - "Do an ordered dithering for converting from 32 to 16 bit depth." - | ditherMatrix ii out inBits outBits index pv dmv r di dmi dmo g b pvOut outIndex | - self depth = 32 ifFalse:[^self error:'Must be 32bit for this']. - ditherMatrix _ #( - 0 8 2 10 - 12 4 14 6 - 3 11 1 9 - 15 7 13 5). - ii _ (0 to: 31) collect:[:i| i]. - out _ Form extent: self extent depth: 16. - inBits _ self bits. - outBits _ out bits. - index _ outIndex _ 0. - pvOut _ 0. - 0 to: self height-1 do:[:y| - 0 to: self width-1 do:[:x| - pv _ inBits at: (index _ index + 1). - dmv _ ditherMatrix at: (y bitAnd: 3) * 4 + (x bitAnd: 3) + 1. - r _ pv bitAnd: 255. di _ r * 496 bitShift: -8. - dmi _ di bitAnd: 15. dmo _ di bitShift: -4. - r _ dmv < dmi ifTrue:[ii at: 2+dmo] ifFalse:[ii at: 1+dmo]. - g _ (pv bitShift: -8) bitAnd: 255. di _ g * 496 bitShift: -8. - dmi _ di bitAnd: 15. dmo _ di bitShift: -4. - g _ dmv < dmi ifTrue:[ii at: 2+dmo] ifFalse:[ii at: 1+dmo]. - b _ (pv bitShift: -16) bitAnd: 255. di _ b * 496 bitShift: -8. - dmi _ di bitAnd: 15. dmo _ di bitShift: -4. - b _ dmv < dmi ifTrue:[ii at: 2+dmo] ifFalse:[ii at: 1+dmo]. - pvOut _ (pvOut bitShift: 16) + - (b bitShift: 10) + (g bitShift: 5) + r. - (x bitAnd: 1) = 1 ifTrue:[ - outBits at: (outIndex _ outIndex+1) put: pvOut. - pvOut _ 0]. - ]. - (self width bitAnd: 1) = 1 ifTrue:[ - outBits at: (outIndex _ outIndex+1) put: (pvOut bitShift: -16). - pvOut _ 0]. - ]. - ^out! ! -!Form methodsFor: 'displaying-generic' stamp: 'jmv 5/31/2021 09:14:11' prior: 16847738! - displayOn: aForm at: aDisplayPoint - "Display the receiver located at aDisplayPoint with default settings for - rule and halftone." - - | toBeDrawn rule | - "Rule Form paint treats pixels with a value of zero as transparent" - toBeDrawn _ self. - (aForm depth = 32 and: [ self depth = 32 ]) - ifTrue: [ rule _ Form blend ] "Handle translucent pixels correctly. Requires both source and dest of 32bpp" - ifFalse: [ - "Warning. Using 'Form paint' with a 32bpp source that includes - traslucent or transparent alphas will give incorrect results (alpha values will be ignored). - Doing what follows might be terribly slow. It is best to convert to lower depth on image load." - "self depth = 32 ifTrue: [ - toBeDrawn _ self asFormOfDepth: aForm depth ]." - rule _ Form paint ]. - toBeDrawn displayOn: aForm - at: aDisplayPoint - clippingBox: aForm boundingBox - rule: rule! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4620-Cleanup-JuanVuletich-2021May31-16h23m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4620] on 31 May 2021 at 4:40:37 pm'! -!Form methodsFor: 'converting' stamp: 'jmv 5/31/2021 11:07:39'! - as8BitStandardPaletteColorForm - "Simple conversion of zero pixels to transparent. Force it to 8 bits." - - | f | - f _ ColorForm extent: self extent depth: 8. - f colors: Color indexedColors copy. - self displayOn: f at: self offset negated. - f offset: self offset. - ^ f! ! -!Form methodsFor: 'converting' stamp: 'jmv 5/31/2021 16:28:18'! - asColorFormOfDepth: destDepth - " - Answer a ColorForm with a custom optimized palette of up to 256, 16 or 4 entries. - self runningWorld backgroundImage asColorFormOfDepth: 8 :: display - self runningWorld backgroundImage orderedDither32To16 asColorFormOfDepth: 8 :: display - self runningWorld backgroundImage orderedDither32To16 asColorFormOfDepth: 4 :: display - " - | answer bitsPerColor clusterIndexToSplit clusterToSplit clusters colors desiredNumberOfClusters errors firstCluster map metricToSplitOn tally valueToSplitOn box hueWeightFactor brightnessWeightFactor saturationWeightFactor | - self depth > 8 ifFalse: [ - ^self error: 'Only for 16 bit and 32 bit Forms' ]. - desiredNumberOfClusters _ 1 bitShift: destDepth. - - "Wheights to balance error on each color metric" - hueWeightFactor _ 8.0 / 360.0. - saturationWeightFactor _ 1.0. - brightnessWeightFactor _ 3.0. - destDepth < 8 ifTrue: [ - brightnessWeightFactor _ 13.0. - destDepth < 4 ifTrue: [ - hueWeightFactor _ 0.0. - saturationWeightFactor _ 0.0. ]]. - "Assign all pixels to a single cluster" - tally _ self tallyPixelValues. - firstCluster _ OrderedCollection new. - tally withIndexDo: [ :pixelCount :pixelValuePlusOne | - pixelCount = 0 ifFalse: [ |c| - c _ Color colorFromPixelValue: pixelValuePlusOne -1 depth: 16. - firstCluster add: {c hue. c saturation. c brightness. pixelCount. pixelValuePlusOne } ]]. - clusters _ OrderedCollection with: firstCluster. - - "Pick the existing cluster with the largest error, and split it." - [clusters size < desiredNumberOfClusters and: [ clusters anySatisfy: [:eachCluster | eachCluster size > 1]]] whileTrue: [ | cluster1 cluster2 | - "Detect cluster with largest error, and split it" - errors _ clusters collect: [ :eachCluster | | sum average error | - sum _ (eachCluster sum: [ :e | {e first * e fourth. e second * e fourth. e third * e fourth. e fourth }]). - average _ {sum first. sum second. sum third} / sum fourth. - error _ eachCluster sum: [ :e | | hueError | - hueError _ (e first - average first) abs. hueError > (360/2) ifTrue: [hueError _ 360 - hueError]. - {hueError * hueWeightFactor. (e second-average second) abs * saturationWeightFactor. (e third-average third) abs * brightnessWeightFactor} * e fourth ]. - {error max. error indexOfMax. average at: error indexOfMax} ]. - clusterIndexToSplit _ (errors collect: [ :e | e first]) indexOfMax. - metricToSplitOn _ (errors at: clusterIndexToSplit) second. - valueToSplitOn _ (errors at: clusterIndexToSplit) third. - clusterToSplit _ clusters at: clusterIndexToSplit. - cluster1 _ OrderedCollection new. - cluster2 _ OrderedCollection new. - clusterToSplit do: [ :pixelMetricsAndCount | - (pixelMetricsAndCount at: metricToSplitOn) < valueToSplitOn - ifTrue: [cluster1 add: pixelMetricsAndCount] - ifFalse: [cluster2 add: pixelMetricsAndCount]]. - clusters at: clusterIndexToSplit put: cluster1. - clusters add: cluster2. - ]. - - colors _ clusters collect: [ :eachCluster | | sum average | - average _ eachCluster average. - sum _ (eachCluster sum: [ :a | {a first * a fourth. a second * a fourth. a third * a fourth. a fourth }]). - average _ {sum first. sum second. sum third} / sum fourth. - Color hue: average first saturation: average second brightness: average third ]. - answer _ ColorForm extent: self extent depth: destDepth. - answer colors: colors. - - "Build colormap for displaying self on answer" - bitsPerColor _ 5. "To read 16bpp source" - map _ Bitmap new: (1 bitShift: 3*bitsPerColor). - clusters withIndexDo: [ :eachCluster :clusterIndex | - eachCluster do: [ :pixMetrixsAndCount | - map at: pixMetrixsAndCount fifth put: clusterIndex-1 ]]. - - box _ self boundingBox. - answer copyBits: box from: self at: 0@0 clippingBox: box rule: Form over map: map. - ^answer -! ! -!Form methodsFor: 'converting' stamp: 'jmv 5/31/2021 16:27:21' prior: 50560330! - as8BitColorForm - "Answer an 8 bit ColorForm with an optimized palette with up to 256 entries." - - ^self asColorFormOfDepth: 8! ! -!PasteUpMorph methodsFor: 'misc' stamp: 'jmv 5/31/2021 16:36:26' prior: 50551033! - buildMagnifiedBackgroundImage - | image | - backgroundImageData - ifNil: [ backgroundImage _ nil ] - ifNotNil: [ - [image _ Form fromBinaryStream: backgroundImageData readStream. - backgroundImage _ image magnifyTo: extent. - backgroundImage _ backgroundImage orderedDither32To16 asColorFormOfDepth: 8. - ] on: Error do: [backgroundImage := nil]. "Can happen if JPEG plugin not built" - self redrawNeeded - ]! ! - -WorldMorph removeSelector: #buildMagnifiedBackgroundImage! - -!methodRemoval: WorldMorph #buildMagnifiedBackgroundImage stamp: 'Install-4621-8bppBackground-JuanVuletich-2021May31-16h39m-jmv.001.cs.st 7/20/2021 16:51:47'! -buildMagnifiedBackgroundImage - super buildMagnifiedBackgroundImage. - backgroundImage ifNil: [ ^ self ]. - - canvas ifNotNil: [ :c | - (backgroundImage depth = 32 and: [ c form depth < 32 ]) ifTrue: [ - backgroundImage _ backgroundImage orderedDither32To16 ]]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4621-8bppBackground-JuanVuletich-2021May31-16h39m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4621] on 1 June 2021 at 1:56:23 pm'! -!Decompiler methodsFor: 'control' stamp: 'jmv 6/1/2021 13:55:50' prior: 16831460! - doClosureCopyCopiedValues: blockCopiedValues numArgs: numArgs blockSize: blockSize - | startpc savedTemps savedTempVarCount savedNumLocalTemps - jump blockArgs blockTemps blockTempsOffset block tmpNumberBase | - tmpNumberBase := statements size. - savedTemps := tempVars. - savedTempVarCount := tempVarCount. - savedNumLocalTemps := numLocalTemps. - jump := blockSize + (startpc := pc). - numLocalTemps := BlockLocalTempCounter tempCountForBlockStartingAt: pc in: method. - blockTempsOffset := numArgs + blockCopiedValues size. - (blockStartsToTempVars notNil "implies we were intialized with temp names." - and: [blockStartsToTempVars includesKey: pc]) - ifTrue: - [tempVars := blockStartsToTempVars at: pc] - ifFalse: - [blockArgs := (1 to: numArgs) collect: - [:i| (constructor - codeTemp: i - 1 - named: 'argm', tmpNumberBase printString, '_', (tempVarCount + i) printString) - beBlockArg]. - blockTemps := (1 to: numLocalTemps) collect: - [:i| constructor - codeTemp: i + blockTempsOffset - 1 - named: 'temp', tmpNumberBase printString, '_', (tempVarCount + i + numArgs) printString]. - tempVars := blockArgs, blockCopiedValues, blockTemps]. - numLocalTemps timesRepeat: - [self interpretNextInstructionFor: self. - stack removeLast]. - tempVarCount := tempVarCount + numArgs + numLocalTemps. - block := self blockTo: jump. - stack addLast: ((constructor - codeArguments: (tempVars copyFrom: 1 to: numArgs) - temps: (tempVars copyFrom: blockTempsOffset + 1 to: blockTempsOffset + numLocalTemps) - block: block) - pc: startpc; - yourself). - tempVars := savedTemps. - tempVarCount := savedTempVarCount. - numLocalTemps := savedNumLocalTemps! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4622-DecompilerTweak-toEaseDecompilerTests-JuanVuletich-2021Jun01-12h01m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4622] on 1 June 2021 at 2:37:09 pm'! -!CodePackage methodsFor: 'saving' stamp: 'jmv 6/1/2021 14:36:41' prior: 50389791! - write: classes initializersOn: aStream - "Write the call to #initialize method of classes defined in us." - - classes do: [ :class | - (class class includesSelector: #initialize) ifTrue: [ - aStream nextChunkPut: class name, ' initialize'; newLine ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4623-WriteInitializersInSafeOrder-JuanVuletich-2021Jun01-14h36m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4607] on 24 May 2021 at 2:20:35 pm'! -!Float class methodsFor: 'testing' stamp: 'dtl 5/24/2021 14:17:21'! - nativeWordOrdering - "True if this image stores float objects internally in native word order. - If false, double word floats are stored in big-endian order regardless - of the machine native word order." - - ^ Smalltalk imageFormatVersion anyMask: 1 -! ! -!Float64Array methodsFor: 'accessing' stamp: 'dtl 5/24/2021 14:17:31' prior: 50334213! - floatAt: index put: aNumber - "Store the argument (e.g., 64 bit Float) at the given index - Use the same internal representation as BoxedFloat64. I.e. a BoxedFloat64 and a Float64Array of size 1 hold the same bits. - Allow subclasses to redefine #at:put:" - - "This breaks with SmallFloat64" - "self replaceWordsFrom: index * 2 - 1 to: index * 2 with: aFloat asFloat startingAt: 1." - - "Float >>basicAt: acts as if Floats were stored in big endian format. Our instances are in platform endianess." - | aFloat | - aFloat _ aNumber asFloat. - (Smalltalk isLittleEndian and: [Float nativeWordOrdering]) - ifTrue: [ - self basicAt: index * 2 - 1 put: (aFloat basicAt: 2). - self basicAt: index * 2 put: (aFloat basicAt: 1) ] - ifFalse: [ - self basicAt: index * 2 - 1 put: (aFloat basicAt: 1). - self basicAt: index * 2 put: (aFloat basicAt: 2) ]. - ^aFloat! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4624-Float64Array-fixForBigEndianFloatImageFormats-DaveLewis-2021May24-00h02m-dtl.001.cs.st----! - -'From Cuis 5.0 [latest update: #4624] on 2 June 2021 at 9:15:33 am'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 6/2/2021 09:08:33' prior: 50567762! - drawCurrentAsError - "The morph (or one of its submorphs) had an error in its drawing method." - | r r2 w | - r _ currentMorph morphLocalBounds. - w _ r extent > `50@50` - ifTrue: [ 6 ] - ifFalse: [ 2 ]. - r2 _ r origin corner: r corner-w. - self - frameAndFillRectangle: r - fillColor: `Color red` - borderWidth: w - borderColor: `Color yellow`. - self line: r2 topLeft to: r2 bottomRight width: w color: `Color yellow`. - self line: r2 topRight to: r2 bottomLeft width: w color: `Color yellow`. - currentMorph displayBoundsSetFrom: self.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4625-Nicer-drawCurrentAsError-JuanVuletich-2021Jun02-09h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4587] on 1 June 2021 at 1:31:25 pm'! - -Warning subclass: #ProceedBlockCannotReturn - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #ProceedBlockCannotReturn category: #'Exceptions Kernel' stamp: 'Install-4626-terminate-exceptions-JaromirMatas-2021May09-20h43m-jar.004.cs.st 7/20/2021 16:51:47'! -Warning subclass: #ProceedBlockCannotReturn - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! -!ContextPart methodsFor: 'private' stamp: 'jar 6/1/2021 10:06:30'! - runUnwindUntilErrorOrReturnFrom: aSender - "ASSUMES aSender is a sender of self. Execute self's stack until aSender returns or an unhandled exception is raised. Return a pair containing the new top context and a possibly nil exception. The exception is not nil if it was raised before aSender returned and it was not handled. The exception is returned rather than openning the debugger, giving the caller the choice of how to handle it." - "Self is run by jumping directly to it (the active process abandons thisContext and executes self). However, before jumping to self we insert an ensure block under aSender that jumps back to thisContext when evaluated. We also insert an exception handler under aSender that jumps back to thisContext when an unhandled exception is raised. In either case, the inserted ensure and exception handler are removed once control jumps back to thisContext." - "This method is used by Process>>#complete:to: for unwinding during termination." - - | error ctxt here topContext | - here _ thisContext. - - "Insert ensure and exception handler contexts under aSender" - error _ nil. - ctxt _ aSender insertSender: (ContextPart - contextOn: UnhandledError do: [:ex | - error ifNil: [ - error _ ex exception. - topContext _ thisContext. - here jump. - ex signalerContext restart] "re-signal the error if jumped back" - ifNotNil: [ex pass] - ]). - ctxt _ ctxt insertSender: (ContextPart - contextEnsure: [error ifNil: [ - topContext _ thisContext. - here jump] - ]). - self jump. "Control jumps to self" - - "Control resumes here once above ensure block or exception handler is executed" - ^ error ifNil: [ "No error was raised, return the sender of the above ensure context (see Note 1)" - {ctxt sender. nil} - - ] ifNotNil: [ "Error was raised, remove inserted above contexts then return signaler context" - aSender terminateTo: ctxt sender. "remove above ensure and handler contexts" - {topContext. error} - ] - -"Note 1: It doesn't matter 'ctxt sender' is not a proper top context because #terminate will use it only as a starting point in the search for the next unwind context and the computation will never return here. Removing the inserted ensure context (i.e. ctxt) by stepping until popped (as in #runUntilErrorOrReturnFrom:) when executing non-local returns is not applicable here and would fail testTerminationDuringNestedUnwindWithReturn1 through 4." -! ! -!Process methodsFor: 'private' stamp: 'jar 6/1/2021 10:14:38'! - complete: topContext to: aContext - "Run topContext on behalf of self on topContext's stack until aContext is popped or an unhandled - error is raised. Return self's new top context. Note: topContext must be a stack top context. - Note: This method is meant to be called primarily by Process>>#terminate." - - | pair top error | - pair _ topContext runUnwindUntilErrorOrReturnFrom: aContext. - top _ pair first. - error _ pair second. - "If an error was detected jump back to the debugged process and re-signal the error; - some errors may require a special care - see notes below." - error ifNotNil: [ - error class == ProceedBlockCannotReturn ifTrue: [^top]. "do not jump back" - error class == MessageNotUnderstood ifTrue: [error initialize]. "reset reachedDefaultHandler" - top jump]. - ^top - -"Note 1: To prevent an infinite recursion of the MessageNotUnderstood error, reset reachedDefaultHandler before jumping back; this will prevent #doesNotUnderstand: from resending the unknown message. -Note 2; To prevent returning from the BlockCannotReturn error, do not jump back when ProceedBlockCannotReturn warning has been raised."! ! -!ContextPart methodsFor: 'instruction decoding' stamp: 'jar 6/1/2021 12:14:16' prior: 16823895! - return: value from: aSender - "For simulation. Roll back self to aSender and return value from it. Execute any unwind blocks on the way. ASSUMES aSender is a sender of self" - - | newTop | - aSender isDead ifTrue: [ - ^ self send: #cannotReturn: to: self with: {value} super: false]. - newTop _ aSender sender. - (self findNextUnwindContextUpTo: newTop) ifNotNil: [ - ^ self send: #aboutToReturn:through: to: self with: {value. nil} super: false]. - self releaseTo: newTop. - newTop ifNotNil: [newTop push: value]. - ^ newTop -! ! -!ContextPart methodsFor: 'controlling' stamp: 'jar 6/1/2021 12:16:39' prior: 16824364! - resume: value through: firstUnwindCtxt - "Unwind thisContext to self and resume with value as result of last send. - Execute any unwind blocks while unwinding. - ASSUMES self is a sender of thisContext." - - | ctxt unwindBlock | - self isDead ifTrue: [self cannotReturn: value to: self]. - ctxt _ firstUnwindCtxt ifNil: [thisContext findNextUnwindContextUpTo: self]. - [ctxt isNil] whileFalse: - [(ctxt tempAt: 2) ifNil: - [ctxt tempAt: 2 put: true. - unwindBlock _ ctxt tempAt: 1. - thisContext terminateTo: ctxt. - unwindBlock value]. - ctxt _ ctxt findNextUnwindContextUpTo: self]. - thisContext terminateTo: self. - ^value -! ! -!MethodContext methodsFor: 'private' stamp: 'jar 6/1/2021 13:22:36' prior: 16871756! - cannotReturn: result - closureOrNil ifNotNil: [ - self cannotReturn: result to: self home sender. - ProceedBlockCannotReturn new signal: 'This block has ended, continue with sender?'. - ^thisContext privSender: self sender]. - Debugger - openContext: thisContext - label: 'computation has been terminated' - contents: nil! ! -!Process methodsFor: 'test support' stamp: 'jar 6/1/2021 11:57:00' prior: 50569166! - terminate - "Stop the process that the receiver represents forever. Unwind to execute pending ensure:/ifCurtailed: blocks before terminating. - Process termination and exception handling in border cases has been the subject of a deep overhaul in the first months of 2021, by Jaromir Matas. - See, for instance - https://lists.cuis.st/mailman/archives/cuis-dev/2021-May/003171.html - https://lists.cuis.st/mailman/archives/cuis-dev/2021-June/003187.html - You can also look for other related mail threads in the Cuis mail list. - Many new tests were added to BaseImageTests.pck.st - Thank you Jaromir for this important contribution!!" - - | ctxt unwindBlock oldList outerMost top newTop | - self isRunning ifTrue: [ - "If terminating the active process, suspend it first and terminate it as a suspended process." - [self terminate] fork. - ^self suspend]. - - [ "run the whole termination wrapped in #valueEnsured to ensure unwind is completed even if - the process terminating another process gets terminated - see #testTerminateInTerminate" - "Always suspend the process first so it doesn't accidentally get woken up" - oldList _ self suspend. - suspendedContext ifNil: [^self]. "self is already terminated" - "Figure out if we are terminating the process while waiting in Semaphore>>critical: - In this case, pop the suspendedContext so that we leave the ensure: block inside - Semaphore>>critical: without signaling the semaphore." - (oldList class == Semaphore and:[ - suspendedContext method == (Semaphore compiledMethodAt: #critical:)]) ifTrue: [ - suspendedContext _ suspendedContext home. - ]. - - top _ suspendedContext. - suspendedContext _ nil. "disable this process while running its stack in active process below" - "If terminating a process halfways through an unwind, try to complete that unwind block first; - if there are multiple such nested unwind blocks, try to complete the outer-most one; nested - unwind blocks will be completed in the process. Halfway-through blocks have already set the - complete variable (tempAt: 2) in their defining #ensure:/#ifCurtailed contexts from nil to true. - Note: #findNextUnwindContextUpTo: starts searching from the receiver's sender but the receiver - itself may be an unwind context." - ctxt _ top. - ctxt isUnwindContext ifFalse: [ctxt _ ctxt findNextUnwindContextUpTo: nil]. - [ctxt isNil] whileFalse: [ - (ctxt tempAt:2) ifNotNil: [ - outerMost _ ctxt]. - ctxt _ ctxt findNextUnwindContextUpTo: nil]. - outerMost ifNotNil: [newTop _ self complete: top to: outerMost]. - - "By now no halfway-through unwind blocks are on the stack. Create a new top context for each - pending unwind block (tempAt: 1) and execute it on the unwind block's stack. - Note: using #value instead of #complete:to: would lead to incorrect evaluation of non-local returns. - Note: newTop sender points to the former outerMost sender, i.e. the next unexplored context." - ctxt _ newTop ifNil: [top] ifNotNil: [newTop sender]. - ctxt isUnwindContext ifFalse: [ctxt _ ctxt findNextUnwindContextUpTo: nil]. - [ctxt isNil] whileFalse: [ - (ctxt tempAt: 2) ifNil: [ - ctxt tempAt: 2 put: true. - unwindBlock _ ctxt tempAt: 1. - top _ unwindBlock asContextWithSender: ctxt. - self complete: top to: top]. - ctxt _ ctxt findNextUnwindContextUpTo: nil] - ] valueEnsured! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4626-terminate-exceptions-JaromirMatas-2021May09-20h43m-jar.004.cs.st----! - -'From Cuis 5.0 [latest update: #4627] on 4 June 2021 at 10:08:56 am'! -!Process class methodsFor: 'documentation' stamp: 'jmv 6/4/2021 10:07:54'! - terminateExamples -" -This is the contents of the examples posted by Jaromir to exercise his worn on process termination and exceptions. -It was posted to the Cuis mail list at https://lists.cuis.st/mailman/archives/cuis-dev/2021-May/003171.html -(or maybe, it is a later version of edition of it if this comment is not up to date!!) - -Thanks Jaromir for this great contribution!! - -Workspace new - contents: Process terminateExamples; - openLabel: 'Jaromir Mata''s Process - terminate examples Cuis'. -" -^ - - - 'Process - Cuis terminate examples - -Some examples to illustrate the termination bugs and test the proposed rewrite of #terminate - -========================================== -terminate suspended: - -| p | -p := [ - [ - [ ] ensure: [ - [Processor activeProcess suspend] ensure: [ - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] - ] ensure: [ - Transcript show: ''''x3'''']. - Transcript show: ''''x4'''' -] newProcess. -p resume. -Processor yield. -p terminate. -Transcript show: p isTerminated printString - -"prints x1 x2 x3" - -| p | -p := [ - [ - [ ] ensure: [ - [ ] ensure: [ - Processor activeProcess suspend. - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] - ] ensure: [ - Transcript show: ''''x3'''']. - Transcript show: ''''x4'''' -] newProcess. -p resume. -Processor yield. -p terminate. -Transcript show: p isTerminated printString - -"prints x1 x2 x3" - -....................................... -terminate runnable: - -| p | -p := [ - [ - [ ] ensure: [ - [Processor yield] ensure: [ - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] - ] ensure: [ - Transcript show: ''''x3'''']. - Transcript show: ''''x4'''' -] newProcess. -p resume. -Processor yield. -p terminate. -Transcript show: p isTerminated printString - -"prints x1 x2 x3" - -| p | -p := [ - [ - [ ] ensure: [ - [ ] ensure: [ - Processor yield. - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] - ] ensure: [ - Transcript show: ''''x3'''']. - Transcript show: ''''x4'''' -] newProcess. -p resume. -Processor yield. -p terminate. -Transcript show: p isTerminated printString - -"prints x1 x2 x3" -....................................... -terminate blocked: - -| p s | -s := Semaphore new. -p := [ - [ - [ ] ensure: [ - [s wait] ensure: [ - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] - ] ensure: [ - Transcript show: ''''x3'''']. - Transcript show: ''''x4'''' -] newProcess. -p resume. -Processor yield. -p terminate. -Transcript show: p isTerminated printString - -"prints x1 x2 x3" - - -| p s | -s := Semaphore new. -p := [ - [ - [ ] ensure: [ - [ ] ensure: [ - s wait. - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] - ] ensure: [ - Transcript show: ''''x3'''']. - Transcript show: ''''x4'''' -] newProcess. -p resume. -Processor yield. -p terminate. -Transcript show: p isTerminated printString - -"prints x1 x2 x3" - -....................................... -terminate active: - -| p | -p := [ - [ - [ ] ensure: [ - [Processor activeProcess terminate] ensure: [ - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] - ] ensure: [ - Transcript show: ''''x3'''']. - Transcript show: ''''x4'''' -] newProcess. -p resume. -"Two yields necessary: terminate active is a two-step procedure" -Processor yield. Processor yield. -Transcript show: p isTerminated printString - -"prints x1 x2 x3" - - -| p | -p := [ - [ - [ ] ensure: [ - [ ] ensure: [ - Processor activeProcess terminate. - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] - ] ensure: [ - Transcript show: ''''x3'''']. - Transcript show: ''''x4'''' -] newProcess. -p resume. -"Two yields necessary: terminate active is a two-step procedure" -Processor yield. Processor yield. -Transcript show: p isTerminated printString - -"prints x1 x2 x3" - - - -========================================== -unhandled error: - -Termination happens when the user hits Abandon on the Debugger window. -"cf.: prints x1 x2 x3 x4 when hit Proceed" - -[ - [ ] ensure: [ - [self error: ''''unwind test''''] ensure: [ - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] -] ensure: [ - Transcript show: ''''x3'''']. -Transcript show: ''''x4'''' - -"prints x1 x2 x3" - - -[ - [ ] ensure: [ - [ ] ensure: [ - self error: ''''unwind test''''. - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] -] ensure: [ - Transcript show: ''''x3'''']. -Transcript show: ''''x4'''' - -"prints x1 x2 x3" - -........................ -nested unhandled errors: - -| p | -p := [ - [ - [ ] ensure: [ - [self error: ''''unwind test outer''''] ensure: [ - self error: ''''unwind test inner''''. - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] - ] ensure: [ - Transcript show: ''''x3'''']. - Transcript show: ''''x4'''' -] newProcess. -p resume. -Processor yield. -"prints x1 x2 x3" - - -triple nested errors: - -[self error: ''''outer error''''] ensure: [ - [self error: ''''middle error''''] ensure: [ - [self error: ''''inner error''''] ensure: [ - Transcript show: ''''x1'''']. - Transcript show: ''''x2'''']. - Transcript show: ''''x3'''']. -Transcript show: ''''x4'''' -"prints x1 x2 x3" -"same result when wrapped in fork" - - -[] ensure: [ -[self error: ''''outer error''''] ensure: [ - [self error: ''''middle error''''] ensure: [ - [self error: ''''inner error''''] ensure: [ - Transcript show: ''''x1'''']. - Transcript show: ''''x2'''']. - Transcript show: ''''x3'''']. -Transcript show: ''''x4''''] -"prints x1 x2 x3 x4" -"same result when wrapped in fork" - - - -========================================= -error and non-local return combined: - -Termination happens when the user hits Abandon on the Debugger window. - -........................ -non-local return inside inner-most halfway thru unwind block: - -[ - [ ] ensure: [ - [self error: ''''unwind test''''] ensure: [ - ^Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] -] ensure: [ - Transcript show: ''''x3'''']. -Transcript show: ''''x4'''' - -"prints x1 x3" - - -[ - [ ] ensure: [ - [ ] ensure: [ - self error: ''''unwind test''''. - ^Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] -] ensure: [ - Transcript show: ''''x3'''']. -Transcript show: ''''x4'''' - -"prints x1 x3" - -........................ -non-local return inside outer-most halfway thru unwind block: - -[ - [ ] ensure: [ - [self error: ''''unwind test''''] ensure: [ - Transcript show: ''''x1'''']. - ^Transcript show: ''''x2''''] -] ensure: [ - Transcript show: ''''x3'''']. -Transcript show: ''''x4'''' - -"prints x1 x2 x3" - - -[ - [ ] ensure: [ - [ ] ensure: [ - self error: ''''unwind test''''. - Transcript show: ''''x1'''']. - ^Transcript show: ''''x2''''] -] ensure: [ - Transcript show: ''''x3'''']. -Transcript show: ''''x4'''' - - -"prints x1 x2 x3" - - -"one more level..." -[ - [ - [ ] ensure: [ - [ ] ensure: [ - self error: ''''unwind test''''. - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] - ] ensure: [ - ^Transcript show: ''''x3''''] -] ensure: [ - Transcript show: ''''x4''''] - -"prints x1 x2 x3 x4 (even if wrapped in #fork)" - - - -............................. -non-local return outside halfway thru unwind blocks: - -[ - [ ] ensure: [ - [self error: ''''unwind test''''] ensure: [ - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] -] ensure: [ - ^Transcript show: ''''x3'''']. -Transcript show: ''''x4'''' - -"prints x1 x2 x3" - - -[ - [ ] ensure: [ - [ ] ensure: [ - self error: ''''unwind test''''. - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] -] ensure: [ - ^Transcript show: ''''x3'''']. -Transcript show: ''''x4'''' - - -"prints x1 x2 x3" - - -============================================================ -For comparison only: - -The tests presented here are not affected by the new #terminate. - -(A) an unhandled error unwind in the preceding examples followed the new termination logic completing all unwind blocks halfway through their execution -(B) a handled error unwind follows the traditional ''''direct'''' unwind path using simpler semantics - it doesn''''t complete unwind blocks halfway through their execution - -......................................... -handled error: - - -[ - [ - [ ] ensure: [ - [self error: ''''unwind test''''] ensure: [ - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] - ] ensure: [ - Transcript show: ''''x3''''] -] on: Error do: []. -Transcript show: ''''x4'''' - -"prints x1 x3 x4, skips x2" - -[ - [ - [ ] ensure: [ - [] ensure: [ - self error: ''''unwind test''''. - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] - ] ensure: [ - Transcript show: ''''x3''''] -] on: Error do: []. -Transcript show: ''''x4'''' - -"prints x3 x4, skips x1 x2" - -............................................ -nested handled errors: - -| p | -p := [ - [ - [ - [ ] ensure: [ - [self error: ''''unwind test outer''''] ensure: [ - self error: ''''unwind test inner''''. - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] - ] ensure: [ - Transcript show: ''''x3''''] - ] on: Error do: []. - Transcript show: ''''x4'''' -] newProcess. -p resume. -Processor yield. Processor yield. - -"prints x3 x4, skips x1 x2" - - - -............................................ -non-local return: - -Similarly a simple non-local return execution follows a ''''direct'''' unwind path logic in #resume[:through:] using simpler semantics. - -[ - [ ] ensure: [ - [^1] ensure: [ - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] -] ensure: [ - Transcript show: ''''x3'''']. -Transcript show: ''''x4'''' - -"prints x1 x3, skips x2" - - -[ - [ ] ensure: [ - [] ensure: [ - ^Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] -] ensure: [ - Transcript show: ''''x3'''']. -Transcript show: ''''x4'''' - -"prints x1 x3, skips x2" - - - -========================================== -Crazies: - -These tests explore new #teminate behavior under more extreme circumstances. - -Unwind after active process termination - -[ ] ensure: [ - [Processor activeProcess terminate] ensure: [Transcript show: ''''x1'''']. - Transcript show: ''''x2'''' - ] -"prints x1 x2 and terminates UI - recoverable via Alt+. or cmd+." - - -Unwind after active process suspension during termination: - -| p | -p := [ - [ - [ ] ensure: [ - [Processor activeProcess suspend] ensure: [ - Processor activeProcess suspend. - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] - ] ensure: [ - Transcript show: ''''x3''''] -] newProcess. -p resume. -Processor yield. -p terminate -"suspends UI and prints x1 x2 x3 after Alt+. recovery" - - -Unwind after double active process termination: - -| p | -p := [ - [ - [ ] ensure: [ - [Processor activeProcess terminate] ensure: [ - Processor activeProcess terminate. - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] - ] ensure: [ - Transcript show: ''''x3'''']. - Transcript show: ''''x4'''' -] newProcess. -p resume. -Processor yield. Processor yield. Processor yield. Processor yield. -Transcript show: p isTerminated printString -"lets UI live and prints x1 x2 x3" - - -| p | -p := [ - [] ensure: [ - Processor activeProcess terminate. Transcript show: ''''x1''''. - Processor activeProcess terminate. Transcript show: ''''x2'''']. -] newProcess. -p resume. -Processor yield. Processor yield. Processor yield. Processor yield. -Transcript show: p isTerminated printString -"lets current UI live and prints x1 x2" - - -| p ap | -p := [ - [ ap := Processor activeProcess. ap terminate. Transcript show: ''''x1'''' ] - ensure: [ ap terminate. Transcript show: ''''x2'''' ]. -] newProcess. -p resume. -Processor yield. Processor yield. Processor yield. -Transcript show: p isTerminated printString -"lets current UI live and prints x2" - - -| p | -p := [ - [ Processor activeProcess terminate ] - ensure: [ Processor activeProcess terminate ]. -] newProcess. -p resume. -Processor yield. Processor yield. Processor yield. -Transcript show: p isTerminated printString -"answers true, no error" - - - -Unwind after active process termination combined with non-local return: - -| p | -p := [ - [] ensure: [ - Processor activeProcess terminate. Transcript show: ''''x1''''. - true ifTrue: [^2]. - Processor activeProcess terminate. Transcript show: ''''x2''''] -] newProcess. -p resume. -Processor yield. Processor yield. -Transcript show: p isTerminated printString -"prints x1 and correctly raises BlockCannotReturn error" - - -Unwind after BlockCannotReturn error: - -| p a | - -a := Array new: 4 withAll: false. -p := [ - [ - [ ] ensure: [ - [Processor activeProcess suspend] ensure: [ - ^a at: 1 put: true]. - a at: 2 put: true] - ] ensure: [a at: 3 put: true]. - a at: 4 put: true - ] newProcess. -p resume. -Processor yield. -"make sure p is suspended and none of the unwind blocks has finished yet" -self assert: p isSuspended. -a noneSatisfy: [ :b | b ]. -"now terminate the process and make sure all unwind blocks have finished" -p terminate. -self assert: p isTerminated. -self assert: a first & a third. -self assert: (a second | a fourth) not. -"---> #(true false true false) ...OK" - - -Triple nested active process terminate: - -[ x := ''''''''. - [Processor activeProcess terminate] ensure: [ - [Processor activeProcess terminate] ensure: [ - [Processor activeProcess terminate] ensure: [ - x:=x,''''3'''']. - x:=x,''''2'''']. - x:=x,''''1'''']. - x:=x,''''0'''' -] fork -x -"---> ''''321'''' ...OK" - -Same as before but without fork: - -x := ''''''''. -[Processor activeProcess terminate] ensure: [ - [Processor activeProcess terminate] ensure: [ - [Processor activeProcess terminate] ensure: [ - x:=x,''''3'''']. - x:=x,''''2'''']. - x:=x,''''1'''']. -x:=x,''''0'''' -x -"terminates UI and answers ---> ''''321'''' after Alt+. recovery" -(Squeak crashes irrecoverably)" - - -Triple nested active process terminate: - -p := -[ x := ''''''''. - [] ensure: [ - [Processor activeProcess suspend] ensure: [ - [Processor activeProcess suspend] ensure: [ - [Processor activeProcess suspend] ensure: [ - x:=x,''''3'''']. - x:=x,''''2'''']. - x:=x,''''1'''']. - x:=x,''''0''''] -] newProcess resume. -Processor yield. -p terminate -x -"Cuis suspends UI repeatedly but answers ---> ''''3210'''' after repeated Alt+. recovery -Squeak answers ---> ''''3210'''' without suspending UI - why the difference? -Without fork Squeak suspends UI just once but Cuis 3 times, both answer x correctly" - - -These behave as expected and won''''t crash the image even after proceeding the BlockCannotReturn error: - -[^2] fork - -[[self error: ''''error''''] ensure: [^2]] fork - -do-it: -"Both statements need to be executed separately in a Workspace" -a := [true ifTrue: [^ 1] yourself] -[a value] on: BlockCannotReturn do: [:ex | ex resume] - -do-it: -"Both statements need to be executed separately in a Workspace" -a := [true ifTrue: [^ 1]. 2] -a value - -These will deal with MessageNotUnderstood correctly and won''''t crash the image or loop infinitely - -[] ensure: [self gotcha. Transcript show: ''''0''''] - -[] ensure: [[self gotcha] ensure: [self halt. Transcript show: ''''0'''']] - -[self error: ''''error''''] ensure: [[self gotcha] ensure: [Transcript show: ''''0'''']] - -[self error: ''''error''''] ensure: [self gotcha. Transcript show: ''''0''''] - -This one freezes UI after Halt -> Proceed but recoverable via Alt+. -[[] ensure: [[self gotcha] ensure: [self halt. Transcript show: ''''0'''']]] fork. - - - -=============== -Some additional unsorted examples: - -"This example should show both ZeroDivide and MessageNotUnderstood errors" - -x1 := x2 := x3 := nil. -p:=[ - [ - [ ] ensure: [ "halfway through completion when suspended" - [ ] ensure: [ "halfway through completion when suspended" - Processor activeProcess suspend. - x1 := (2 / 0 "error!!") > 0]. - x2 := true] - ] ensure: [ "not started yet when suspended" - x3 := true] -] newProcess resume. -Processor yield. -p terminate -{x1 . x2 . x3} ---> #(MessageNotUnderstood: ZeroDivide>>> true true) - - -'! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4627-Jaromir-s-Process-terminate-examples-JuanVuletich-2021Jun04-10h00m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4627] on 4 June 2021 at 3:38:24 pm'! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'jmv 6/4/2021 15:35:46' prior: 50486387! - withMethodNodeAndClassDo: aBlock ifErrorsParsing: anErrorBlock - - | selectedClass methodNode | - - "I have to do this because some codeProviders do no answer selectedClassOrMetaClass like the Workspace - Hernan" - selectedClass := [ self codeProvider selectedClassOrMetaClass ] on: Error do: [ :anError | anError return: UndefinedObject ]. - [ - [ methodNode := selectedClass methodNodeFor: model actualContents asString ] - on: UndeclaredVariableWarning do: [ :ex | ex resume ] - ] on: Error do: [ :anError | ^ anErrorBlock value: anError ]. - - ^aBlock value: methodNode value: selectedClass.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4628-AvoidSuperfluousNotification-JuanVuletich-2021Jun04-15h37m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4532] on 5 June 2021 at 8:38:51 pm'! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 6/5/2021 20:32:51'! - implementorsIsOnlyOneTestMethod - - ^ implementors size = 1 and: [ implementors anyOne isTestMethod ]! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 6/5/2021 20:32:58' prior: 50441616! - startWizard - - self implementorsIsOnlyOneTestMethod - ifTrue: [ self doNotShowChanges; wizardEnded ] - ifFalse: [ ChangeSelectorImplementorsStepWindow openFrom: self ]! ! -!ChangeSelectorApplier methodsFor: 'refactoring - changes' stamp: 'HAW 6/5/2021 20:27:47' prior: 50441650! - closeBrowser - - wizardStepWindow ifNotNil: [ wizardStepWindow delete ] ! ! -!ChangeSelectorApplier methodsFor: 'evaluation' stamp: 'HAW 6/5/2021 20:12:33' prior: 50441748 overrides: 50441454! - value - - requestExitBlock := [ ^self ]. - - self requestRefactoringParametersHandlingRefactoringExceptions. - - self - ifHasNoSendersAndOneImplementor: [ :anImplementor | - self createAndApplyRefactoringWhenNoSendersAndOneImplementor: anImplementor ] - ifNot: [ self askForImplementosAndSenders ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4629-RenameTestUIAcceleration-HernanWilkinson-2021Apr30-19h32m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4532] on 5 June 2021 at 8:39:29 pm'! -!PluggableListMorphOfMany methodsFor: 'events' stamp: 'HAW 6/5/2021 20:39:06' prior: 50380553 overrides: 50426137! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - - | oldIndex oldVal row w | - self hasKeyboardFocus ifFalse: [ - aMouseButtonEvent hand newKeyboardFocus: self ]. - - row _ self rowAtLocation: localEventPosition. - - row = 0 ifTrue: [ - ^super mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition ]. - - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self listMorph highlightedRow: row. - - w _ self owningWindow. - (w isNil or: [ w okToChange ]) ifTrue: [ "No change if model is locked" - - "Set meaning for subsequent dragging of selection" - dragOnOrOff _ (self listSelectionAt: row) not. - dragStartRow _ row. - oldIndex _ self getCurrentSelectionIndex. - oldIndex ~= 0 ifTrue: [oldVal _ self listSelectionAt: oldIndex]. - - "Different from PluggableListMorph. There, we highlight on mouse down, and act on mouse up. - Here, we act on mouse down, because we support dragging of selection, so mouse up will - only happen after user is finished dragging. In order to get the highlight visible for the user, - update the model on next world cycle." - UISupervisor whenUIinSafeState: [ - "Set or clear new primary selection (listIndex)" - dragOnOrOff == true - ifTrue: [self setSelectionIndex: row] - ifFalse: [self setSelectionIndex: 0]. - "Need to restore the old one, due to how model works, and set new one." - oldIndex ~= 0 ifTrue: [self listSelectionAt: oldIndex put: oldVal]. - self listSelectionAt: row put: dragOnOrOff ]. - ]. - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: nil - clkNHalf: nil - dblClkSel: #doubleClick:localPosition: - dblClkNHalfSel: nil - tripleClkSel: nil! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4630-PluggableListMorphOfMany-HernanWilkinson-2021Jun05-20h38m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4630] on 6 June 2021 at 7:13:11 pm'! -!Editor methodsFor: 'new selection' stamp: 'jmnv 6/6/2021 19:12:36' prior: 50541899! - wordRangeLeftDelimiters: leftDelimiters rightDelimiters: rightDelimiters - "Select delimited text or word--the result of double-clicking." - ^ self - wordRangeLeftDelimiters: leftDelimiters - rightDelimiters: rightDelimiters - startingAt: self pointIndex.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4631-WordSelectionFix-YourName-2021Jun06-18h59m-jmnv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4631] on 6 June 2021 at 7:50:16 pm'! -!TextModelMorph methodsFor: 'events' stamp: 'jmnv 6/6/2021 19:23:59' prior: 50458727 overrides: 50458668! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - - | eventPositionLocalToScroller | - eventPositionLocalToScroller _ localEventPosition - scroller morphPosition. - scroller mouseButton1Down: aMouseButtonEvent localPosition: eventPositionLocalToScroller. - - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: nil - clkNHalf: #clickAndHalf:localPosition: - dblClkSel: nil - dblClkNHalfSel: #doubleClickAndHalf:localPosition: - tripleClkSel: nil! ! - -TextModelMorph removeSelector: #doubleClick:localPosition:! - -!methodRemoval: TextModelMorph #doubleClick:localPosition: stamp: 'Install-4632-TextModelMorph-cleanup-JuanVuletich-2021Jun06-19h49m-jmv.001.cs.st 7/20/2021 16:51:47'! -doubleClick: aMouseButtonEvent localPosition: localEventPosition - - self textMorph doubleClick: aMouseButtonEvent localPosition: localEventPosition! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4632-TextModelMorph-cleanup-JuanVuletich-2021Jun06-19h49m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4630] on 6 June 2021 at 7:32:25 pm'! -!TextEditor methodsFor: 'events' stamp: 'jmnv 6/6/2021 19:30:28' prior: 16931964! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - | b | - - initialSelectionStart _ nil. - initialSelectionStop _ nil. - doWordSelection _ false. - doParagraphSelection _ false. - - "Multiple selection of text. - Windows uses Control, Mac uses Command (i.e. commandAlt) - On the Mac, command-button1 is translated to command-button3 by the VM. do: - Preferences disable: #commandClickOpensHalo - to disable this behavior and make command-button1 work for multiple selection. " - (aMouseButtonEvent controlKeyPressed or: [ aMouseButtonEvent commandAltKeyPressed ]) ifTrue: [ - self selectionInterval size > 0 ifTrue: [ - selectionStartBlocks _ selectionStartBlocks copyWith: self startBlock. - selectionStopBlocks _ selectionStopBlocks copyWith: self stopBlock ]] - ifFalse: [ - selectionStartBlocks _ #(). - selectionStopBlocks _ #() ]. - - b _ textComposition characterBlockAtPoint: localEventPosition. - - (textComposition clickAt: localEventPosition) ifTrue: [ - markBlock _ b. - pointBlock _ b. - aMouseButtonEvent hand releaseKeyboardFocus: self. - ^ self ]. - - aMouseButtonEvent shiftPressed - ifFalse: [ - markBlock _ b. - pointBlock _ b. - self setEmphasisHereFromText ]! ! -!MouseClickState methodsFor: 'actions' stamp: 'jmnv 6/6/2021 19:32:17' prior: 50565230! - handleEvent: aMouseEvent from: aHand - "Process the given mouse event to detect a click, double-click, or drag. - Return true if the event should be processed by the sender, false if it shouldn't. - NOTE: This method heavily relies on getting *all* mouse button events." - - | timedOut distance | - timedOut _ (aMouseEvent timeStamp - lastClickDown timeStamp) > self class doubleClickTimeout. - timedOut ifTrue: [ aHand dontWaitForMoreClicks ]. - distance _ (aMouseEvent eventPosition - lastClickDown eventPosition) r. - "Real action dispatch might be done after the triggering event, for example, because of waiting for timeout. - So, count the button downs and ups(clicks), to be processed, maybe later, maybe in a mouseMove..." - aMouseEvent isMouseDown ifTrue: [ - lastClickDown _ aMouseEvent. - buttonDownCount _ buttonDownCount + 1 ]. - aMouseEvent isMouseUp ifTrue: [ - buttonUpCount _ buttonUpCount + 1 ]. - - "Simulate button 2 if timeout during first click (i.e. tap & hold). Useful for opening menus on pen computers." - (buttonDownCount = 1 and: [ buttonUpCount = 0]) ifTrue: [ - (timedOut and: [ sendMouseButton2Activity and: [ distance = 0]]) ifTrue: [ - aHand dontWaitForMoreClicks. - clickClient mouseButton2Activity. - ^ false ]. - "If we have already moved, then it won't be a double or triple click... why wait?" - (timedOut or: [distance > 0]) ifTrue: [ - aHand dontWaitForMoreClicks. - dragSelector - ifNotNil: [ self didDrag ]. - ^ false ]]. - - "If we're over triple click, or timed out, or mouse moved, don't allow more clicks." - (buttonDownCount = 4 or: [ timedOut or: [ distance > 0 ]]) ifTrue: [ - aHand dontWaitForMoreClicks. - ^ false ]. - - "Simple click." - (buttonDownCount = 1 and: [ buttonUpCount = 1 ]) ifTrue: [ - self didClick ]. - - "Click & hold" - (buttonDownCount = 2 and: [ buttonUpCount = 1]) ifTrue: [ - self didClickAndHalf ]. - - "Double click." - (buttonDownCount = 2 and: [ buttonUpCount = 2]) ifTrue: [ - self didDoubleClick ]. - - "Double click & hold." - (buttonDownCount = 3 and: [ buttonUpCount = 2]) ifTrue: [ - self didDoubleClickAndHalf ]. - - "Triple click" - (buttonDownCount = 3 and: [ buttonUpCount = 3]) ifTrue: [ - self didTripleClick ]. - - "This means: if a mouseDown, then don't further process this event (so we can turn it into a double or triple click on next buttonUp)" - ^ aMouseEvent isMouseDown! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4633-TextEditorFix-YourName-2021Jun06-19h25m-jmnv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4630] on 6 June 2021 at 7:13:11 pm'! -!Editor methodsFor: 'new selection' stamp: 'jmv 6/6/2021 19:12:36' prior: 50573417! - wordRangeLeftDelimiters: leftDelimiters rightDelimiters: rightDelimiters - "Select delimited text or word--the result of double-clicking." - ^ self - wordRangeLeftDelimiters: leftDelimiters - rightDelimiters: rightDelimiters - startingAt: self pointIndex.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4634-WordSelectionFix-JuanVuletich-2021Jun06-18h59m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4630] on 6 June 2021 at 7:32:25 pm'! -!TextEditor methodsFor: 'events' stamp: 'jmv 6/6/2021 19:30:28' prior: 50573475! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - | b | - - initialSelectionStart _ nil. - initialSelectionStop _ nil. - doWordSelection _ false. - doParagraphSelection _ false. - - "Multiple selection of text. - Windows uses Control, Mac uses Command (i.e. commandAlt) - On the Mac, command-button1 is translated to command-button3 by the VM. do: - Preferences disable: #commandClickOpensHalo - to disable this behavior and make command-button1 work for multiple selection. " - (aMouseButtonEvent controlKeyPressed or: [ aMouseButtonEvent commandAltKeyPressed ]) ifTrue: [ - self selectionInterval size > 0 ifTrue: [ - selectionStartBlocks _ selectionStartBlocks copyWith: self startBlock. - selectionStopBlocks _ selectionStopBlocks copyWith: self stopBlock ]] - ifFalse: [ - selectionStartBlocks _ #(). - selectionStopBlocks _ #() ]. - - b _ textComposition characterBlockAtPoint: localEventPosition. - - (textComposition clickAt: localEventPosition) ifTrue: [ - markBlock _ b. - pointBlock _ b. - aMouseButtonEvent hand releaseKeyboardFocus: self. - ^ self ]. - - aMouseButtonEvent shiftPressed - ifFalse: [ - markBlock _ b. - pointBlock _ b. - self setEmphasisHereFromText ]! ! -!MouseClickState methodsFor: 'actions' stamp: 'jmv 6/6/2021 19:32:17' prior: 50573516! -handleEvent: aMouseEvent from: aHand - "Process the given mouse event to detect a click, double-click, or drag. - Return true if the event should be processed by the sender, false if it shouldn't. - NOTE: This method heavily relies on getting *all* mouse button events." - - | timedOut distance | - timedOut _ (aMouseEvent timeStamp - lastClickDown timeStamp) > self class doubleClickTimeout. - timedOut ifTrue: [ aHand dontWaitForMoreClicks ]. - distance _ (aMouseEvent eventPosition - lastClickDown eventPosition) r. - "Real action dispatch might be done after the triggering event, for example, because of waiting for timeout. - So, count the button downs and ups(clicks), to be processed, maybe later, maybe in a mouseMove..." - aMouseEvent isMouseDown ifTrue: [ - lastClickDown _ aMouseEvent. - buttonDownCount _ buttonDownCount + 1 ]. - aMouseEvent isMouseUp ifTrue: [ - buttonUpCount _ buttonUpCount + 1 ]. - - "Simulate button 2 if timeout during first click (i.e. tap & hold). Useful for opening menus on pen computers." - (buttonDownCount = 1 and: [ buttonUpCount = 0]) ifTrue: [ - (timedOut and: [ sendMouseButton2Activity and: [ distance = 0]]) ifTrue: [ - aHand dontWaitForMoreClicks. - clickClient mouseButton2Activity. - ^ false ]. - "If we have already moved, then it won't be a double or triple click... why wait?" - (timedOut or: [distance > 0]) ifTrue: [ - aHand dontWaitForMoreClicks. - dragSelector - ifNotNil: [ self didDrag ]. - ^ false ]]. - - "If we're over triple click, or timed out, or mouse moved, don't allow more clicks." - (buttonDownCount = 4 or: [ timedOut or: [ distance > 0 ]]) ifTrue: [ - aHand dontWaitForMoreClicks. - ^ false ]. - - "Simple click." - (buttonDownCount = 1 and: [ buttonUpCount = 1 ]) ifTrue: [ - self didClick ]. - - "Click & hold" - (buttonDownCount = 2 and: [ buttonUpCount = 1]) ifTrue: [ - self didClickAndHalf ]. - - "Double click." - (buttonDownCount = 2 and: [ buttonUpCount = 2]) ifTrue: [ - self didDoubleClick ]. - - "Double click & hold." - (buttonDownCount = 3 and: [ buttonUpCount = 2]) ifTrue: [ - self didDoubleClickAndHalf ]. - - "Triple click" - (buttonDownCount = 3 and: [ buttonUpCount = 3]) ifTrue: [ - self didTripleClick ]. - - "This means: if a mouseDown, then don't further process this event (so we can turn it into a double or triple click on next buttonUp)" - ^ aMouseEvent isMouseDown! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4635-TextEditorFix-JuanVuletich-2021Jun06-19h25m-jmnv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4635] on 9 June 2021 at 12:46:01 pm'! -!FileIOAccessor methodsFor: 'primitives' stamp: 'jmv 6/9/2021 12:37:54'! - primFixedNameLookupEntryIn: fullPathAsUTF8 index: index - "Fix the malformed String answered by the primitive. See comment at #primLookupEntryIn:index:" - - | answer | - answer _ self primLookupEntryIn: fullPathAsUTF8 index: index. - answer isArray ifTrue: [ - answer at: 1 put: (String fromUtf8: answer first asByteArray) ]. - ^answer! ! -!FileList methodsFor: 'private' stamp: 'jmv 6/9/2021 12:38:46' prior: 16843033! - readContentsBrief: brevityFlag - "Read the contents of the receiver's selected file, unless it is too long, in which case show just the first 5000 characters. Don't create a file if it doesn't already exist." - | fileSize first50000 | - -directory // fileName readStreamDo: [ :f | - f ifNil: [^ 'For some reason, this file cannot be read' halt]. - (brevityFlag not or: [(fileSize := f size) <= 2000000]) ifTrue: [ - acceptedContentsCache _ f contentsOfEntireFile. - brevityState := #fullFile. "don't change till actually read" - ^ acceptedContentsCache ]. - - "if brevityFlag is true, don't display long files when first selected" - first50000 := f next: 50000. -]. - acceptedContentsCache _ -'File ''{1}'' is {2} bytes long. -You may use the ''get'' command to read the entire file. - -Here are the first 50000 characters... ------------------------------------------- -{3} ------------------------------------------- -... end of the first 50000 characters.' format: {fileName. fileSize. first50000}. - brevityState := #briefFile. "don't change till actually read" - ^ acceptedContentsCache! ! -!StandardFileStream methodsFor: 'open/close' stamp: 'jmv 6/9/2021 12:43:48' prior: 16912957! - open: fileName forWrite: writeMode - "Open the file with the given name. If writeMode is true, allow writing, otherwise open the file in read-only mode." - "Changed to do a GC and retry before failing ar 3/21/98 17:25" - fileID _ StandardFileStream retryWithGC: [ self primOpen: (fileName asUtf8: true) writable: writeMode ] - until: [ :id | id notNil ] - forFileNamed: fileName. - fileID ifNil: [^ nil]. "allows sender to detect failure" - name _ fileName. - "jmv: Register after setting name. Name is assumed to be defined for registered objects." - self register. - rwmode _ writeMode. - buffer1 _ String new: 1. - self enableReadBuffering -! ! -!StandardFileStream methodsFor: 'primitives' stamp: 'jmv 6/9/2021 12:42:59' prior: 16913551! - primOpen: fileNameAsUTF8 writable: writableFlag - "Open a file of the given name, and return the file ID obtained. - If writableFlag is true, then - if there is none with this name, then create one - else prepare to overwrite the existing from the beginning - otherwise - if the file exists, open it read-only - else return nil" - - - ^ nil -! ! -!FileIOAccessor methodsFor: 'actions' stamp: 'jmv 6/9/2021 12:19:11' prior: 16841682! - createDirectory: fullPathName - self primCreateDirectory: (fullPathName asUtf8: true)! ! -!FileIOAccessor methodsFor: 'actions' stamp: 'jmv 6/9/2021 12:19:31' prior: 16841687! - deleteDirectory: fullPathName - self primDeleteDirectory: (fullPathName asUtf8: true)! ! -!FileIOAccessor methodsFor: 'actions' stamp: 'jmv 6/9/2021 12:12:22' prior: 16841697! - deleteFile: fullPathName ifAbsent: failBlock - ^(self - try: [self primDeleteFileNamed: (fullPathName asUtf8: true)] - forFileNamed: fullPathName) - ifFalse: [^ failBlock value]! ! -!FileIOAccessor methodsFor: 'actions' stamp: 'jmv 6/9/2021 12:16:29' prior: 16841716! - rename: oldFileFullName to: newFileFullName - | selection | - (self try: [self primRename: (oldFileFullName asUtf8: true) to: (newFileFullName asUtf8: true) ] - forFileNamed: oldFileFullName) ifTrue: [^ self]. - - oldFileFullName asFileEntry exists ifFalse: [^ self error: 'Attempt to rename a non-existent file']. - (newFileFullName asFileEntry exists or: [ newFileFullName asDirectoryEntry exists ]) - ifTrue: [ - selection := (PopUpMenu labels: 'delete old version -cancel') - startUpWithCaption: 'Trying to rename a file to be -' , newFileFullName , ' -and it already exists.'. - selection = 1 - ifTrue: [self deleteFile: newFileFullName. - ^ self rename: oldFileFullName to: newFileFullName]]. - ^ self error: 'Failed to rename file'! ! -!FileIOAccessor methodsFor: 'actions' stamp: 'jmv 6/9/2021 12:16:54' prior: 16841741! -renameDirectory: oldFileFullName to: newFileFullName - | selection | - (self try: [self primRename: (oldFileFullName asUtf8: true) to: (newFileFullName asUtf8: true) ] - forFileNamed: oldFileFullName) ifTrue: [^ self]. - - oldFileFullName asDirectoryEntry exists ifFalse: [^ self error: 'Attempt to rename a non-existent file']. - newFileFullName asDirectoryEntry exists - ifTrue: [selection := (PopUpMenu labels: 'delete old version -cancel') - startUpWithCaption: 'Trying to rename a directory to be -' , newFileFullName , ' -and it already exists.'. - selection = 1 - ifTrue: [newFileFullName asDirectoryEntry recursiveDelete. - ^ self renameDirectory: oldFileFullName to: newFileFullName]]. - ^ self error: 'Failed to rename file'! ! -!FileIOAccessor methodsFor: 'private' stamp: 'jmv 6/9/2021 12:36:06' prior: 50422957! - basicDirectoryExists: fullPathName - - ^( - (self primLookupEntryIn: (fullPathName asUtf8: true) index: 1) - == #badDirectoryPath - ) not! ! -!FileIOAccessor methodsFor: 'private' stamp: 'jmv 6/9/2021 12:33:47' prior: 50406489! - entriesIn: parentEntryOrNil - " - Warning: Private. Only to be called from within FileMan. - Accepts nil as argument, but behavior depends on platform. - -Windows (nil means root) -FileIOAccessor default entriesIn: nil #(C:\ D:\) -(FileIOAccessor default entriesIn: '' asDirectoryEntry) = (FileIOAccessor default entriesIn: '.' asDirectoryEntry) true -FileIOAccessor default entriesIn: '/' asDirectoryEntry #(\$Recycle.Bin \Config.Msi \Documents and Settings \gratMusic \hiberfil.sys \Intel \pagefile.sys \PerfLogs \Program Files \Program Files (x86) \ProgramData \Python27 \Recovery \SimuloHoy \System Volume Information \totalcmd \Users \Windows) - -Linux (nil means current dir, like '' and '.') -FileIOAccessor default entriesIn: nil #(Lots of stuff in current directory) -(FileIOAccessor default entriesIn: nil) = (FileIOAccessor default entriesIn: '.' asDirectoryEntry) true -(FileIOAccessor default entriesIn: '' asDirectoryEntry) = (FileIOAccessor default entriesIn: '.' asDirectoryEntry) true -FileIOAccessor default entriesIn: '/' asDirectoryEntry #(/vmlinuz /boot /sbin /srv /lib /lib32 /tmp /sys /home /etc /initrd.img /bin /dev /opt /proc /lost+found /var /root /lib64 /mnt /usr /run /media) - -MacOsX (nil means current dir, like '' and '.') -FileIOAccessor default entriesIn: nil #(/Volumes/SanDisk32-NTFS/CuisTest/2554-REVISAR-JuanVuletich-2015Oct21-16h40m-jmv.1.cs.st /Volumes/SanDisk32-NTFS/CuisTest/Cog.app /Volumes/SanDisk32-NTFS/CuisTest/Cog.app.tgz /Volumes/SanDisk32-NTFS/CuisTest/Cuis4.2-2553.changes /Volumes/SanDisk32-NTFS/CuisTest/Cuis4.2-2553.image /Volumes/SanDisk32-NTFS/CuisTest/CuisV4.sources) -(FileIOAccessor default entriesIn: '' asDirectoryEntry) = (FileIOAccessor default entriesIn: '.' asDirectoryEntry) true -FileIOAccessor default entriesIn: '/' asDirectoryEntry #(/.dbfseventsd /.DocumentRevisions-V100 /.DS_Store /.file /.fseventsd /.hotfiles.btree /.Spotlight-V100 /.Trashes /.vol /Applications /bin /cores /dev /etc /home /installer.failurerequests /Library /net /Network /opt /private /sbin /System /tmp /Users /usr /var /Volumes) - - " - | entries index done entryArray entry isDirectory lookIn | - entries _ OrderedCollection new: 200. - index _ 1. - done _ false. - lookIn _ parentEntryOrNil ifNil: [''] ifNotNil: [parentEntryOrNil pathName]. - [done] whileFalse: [ - entryArray _ self primFixedNameLookupEntryIn: (lookIn asUtf8: true) index: index. - #badDirectoryPath == entryArray ifTrue: [ - ^#()]. - entryArray == nil - ifTrue: [done _ true] - ifFalse: [ - isDirectory _ entryArray at: 4. - entry _ isDirectory ifTrue: [DirectoryEntry new] ifFalse: [FileEntry new]. - entry name: (entryArray at: 1) parent: parentEntryOrNil. - entry updateFrom: entryArray entryInParent: index. - entries addLast: entry ]. - index _ index + 1]. - - ^entries asArray! ! -!FileIOAccessor methodsFor: 'private' stamp: 'jmv 6/9/2021 12:34:06' prior: 50406745! - updateEntry: aFileSystemEntry - | entryArray index lookIn isDirectory | - - "If the index in aFileSystemEntry is valid, use it. No need to iterate over all entries." - aFileSystemEntry primEntryInParent ifNotNil: [ :tentativeIndex | - (self primFixedNameLookupEntryIn: (aFileSystemEntry parent pathName asUtf8: true) index: tentativeIndex) ifNotNil: [ :found | - found == #badDirectoryPath ifFalse: [ - aFileSystemEntry name = (found at: 1) ifTrue: [ - aFileSystemEntry updateFrom: found entryInParent: tentativeIndex. - ^ self ]]]]. - - "Otherwise, do a full iteration" - lookIn _ aFileSystemEntry parent pathName. - index _ 1. - [ - entryArray _ self primFixedNameLookupEntryIn: (lookIn asUtf8: true) index: index. - #badDirectoryPath == entryArray ifTrue: [ - ^ self]. - entryArray == nil ifTrue: [ - ^ self]. - isDirectory _ entryArray at: 4. - aFileSystemEntry name = (entryArray at: 1) ifTrue: [ - isDirectory == aFileSystemEntry isDirectory ifTrue: [ - aFileSystemEntry updateFrom: entryArray entryInParent: index ]. - "If found, exit even if invalid. No point to keep iterating." - ^ self ]. - index _ index + 1] repeat! ! -!FileIOAccessor methodsFor: 'primitives' stamp: 'jmv 6/9/2021 12:42:23' prior: 16842189! - primCreateDirectory: fullPathAsUTF8 - "Create a directory named by the given path. Fail if the path is bad or if a file or directory by that name already exists." - - - self primitiveFailed -! ! -!FileIOAccessor methodsFor: 'primitives' stamp: 'jmv 6/9/2021 12:42:19' prior: 16842199! - primDeleteDirectory: fullPathAsUTF8 - "Delete the directory named by the given path. Fail if the path is bad or if a directory by that name does not exist." - - - self primitiveFailed -! ! -!FileIOAccessor methodsFor: 'primitives' stamp: 'jmv 6/9/2021 12:42:14' prior: 16842209! - primDeleteFileNamed: aFileNameAsUTF8 - "Delete the file of the given name. Return self if the primitive succeeds, nil otherwise." - - - ^ nil -! ! -!FileIOAccessor methodsFor: 'primitives' stamp: 'jmv 6/9/2021 12:31:59' prior: 16842218! - primLookupEntryIn: fullPathAsUTF8 index: index - "Look up the index-th entry of the directory with the given fully-qualified path (i.e., starting from the root of the file hierarchy) and return an array containing: - - - - On MacOS and Windows, the empty string enumerates the mounted volumes/drives. - - On Linux, it is equivalent to '.', and lists the contents of DirectoryEntry currentDirectory. - - The creation and modification times are in seconds since the start of the Smalltalk time epoch. DirFlag is true if the entry is a directory. FileSize the file size in bytes or zero for directories. The primitive returns nil when index is past the end of the directory. It fails if the given path is bad. - - Warning: The 'name' field is an instance of String, but in reality it contains the bytes for its UTF-8 representation. - For instance, if the real name is 'puño' we'll get 'puño', as - (String withAll: ('puño' asUtf8 asArray collect: [ :n | Character numericValue: n ])) = 'puño' - Senders MUST do appropriate conversion. - - Consider calling #primFixedNameLookupEntryIn:index: instead. - " - - - ^ #badDirectoryPath - -! ! -!FileIOAccessor methodsFor: 'primitives' stamp: 'jmv 6/9/2021 12:15:55' prior: 16842256! - primRename: oldFileFullNameAsUTF8 to: newFileFullNameAsUTF8 - "Rename the file of the given name to the new name. Fail if there is no file of the old name or if there is an existing file with the new name. - Changed to return nil instead of failing ar 3/21/98 18:04" - - - ^nil! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4636-UnicodeInFilenames-JuanVuletich-2021Jun09-12h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4636] on 16 June 2021 at 11:26:02 am'! -!DebuggerWindow methodsFor: 'context stack menu' stamp: 'jmv 6/16/2021 11:25:26'! - peelToFirst - - ^ self ifOkToChangeCodePaneDo: [ model peelToFirst ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4637-DebuggerWindowPeelToFirst-JuanVuletich-2021Jun16-11h25m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4637] on 17 June 2021 at 1:03:07 pm'! -!Preferences class methodsFor: 'standard queries' stamp: 'jmv 6/17/2021 13:02:51' prior: 0! - tapAndHoldEmulatesButton2 - " - Preferences preferencesDictionary removeKey: #tapAndHoldEmulatesButton2 - " - ^ self - valueOfFlag: #tapAndHoldEmulatesButton2 - ifAbsent: [ false ].! ! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'jmv 6/17/2021 12:07:59' prior: 16876882! - delete - "Remove the receiver as a submorph of its owner and make its - new owner be nil." - - | aWorld | - aWorld _ self world ifNil: [ self runningWorld ]. - aWorld ifNotNil: [ - aWorld activeHand ifNotNil: [ :h | h - releaseKeyboardFocus: self; - releaseMouseFocus: self ]]. - owner ifNotNil:[ self privateDelete].! ! -!HandMorph methodsFor: 'double click support' stamp: 'jmv 6/17/2021 12:54:54' prior: 16851566! - waitForClicksOrDragOrSimulatedMouseButton2: aMorph event: evt clkSel: clkSel clkNHalf: clkNHalfSel dblClkSel: dblClkSel dblClkNHalfSel: dblClkNHalfSel tripleClkSel: tripleClkSel - - "Wait until the difference between click, double-click, or drag gesture is known, then inform the given morph what transpired. This message is sent when the given morph first receives a mouse-down event. If the mouse button goes up, then down again within DoubleClickTime, then 'doubleClick: evt' is sent to the morph. If the mouse button goes up but not down again within DoubleClickTime, then the message 'click: evt' is sent to the morph. Finally, if the button does not go up within DoubleClickTime, then 'drag: evt' is sent to the morph. In all cases, the event supplied is the original mouseDown event that initiated the gesture. mouseMove: and mouseUp: events are not sent to the morph until it becomes the mouse focus, which is typically done by the client in its click:, doubleClick:, or drag: methods." - - mouseClickState _ - MouseClickState new - client: aMorph - drag: nil - click: clkSel - clickAndHalf: clkNHalfSel - dblClick: dblClkSel - dblClickAndHalf: dblClkNHalfSel - tripleClick: tripleClkSel - event: evt - sendMouseButton2Activity: Preferences tapAndHoldEmulatesButton2. - - "It seems the Mac VM may occasionally lose button up events triggering bogus activations. - Hence Preferences tapAndHoldEmulatesButton2"! ! -!HandMorph methodsFor: 'double click support' stamp: 'jmv 6/17/2021 12:54:58' prior: 50426091! - waitForClicksOrDragOrSimulatedMouseButton2: aMorph event: evt clkSel: clkSel clkNHalf: clkNHalfSel dblClkSel: dblClkSel dblClkNHalfSel: dblClkNHalfSel tripleClkSel: tripleClkSel dragSel: dragSel - - mouseClickState _ - MouseClickState new - client: aMorph - drag: dragSel - click: clkSel - clickAndHalf: clkNHalfSel - dblClick: dblClkSel - dblClickAndHalf: dblClkNHalfSel - tripleClick: tripleClkSel - event: evt - sendMouseButton2Activity: Preferences tapAndHoldEmulatesButton2. - - "It seems the Mac VM may occasionally lose button up events triggering bogus activations. - Hence Preferences tapAndHoldEmulatesButton2"! ! -!MouseClickState methodsFor: 'actions' stamp: 'jmv 6/17/2021 13:01:32' prior: 50573657! - handleEvent: aMouseEvent from: aHand - "Process the given mouse event to detect a click, double-click, or drag. - Return true if the event should be processed by the sender, false if it shouldn't. - NOTE: This method heavily relies on getting *all* mouse button events." - - | timedOut distance | - timedOut _ (aMouseEvent timeStamp - lastClickDown timeStamp) > self class doubleClickTimeout. - timedOut ifTrue: [ aHand dontWaitForMoreClicks ]. - distance _ (aMouseEvent eventPosition - lastClickDown eventPosition) r. - "Real action dispatch might be done after the triggering event, for example, because of waiting for timeout. - So, count the button downs and ups(clicks), to be processed, maybe later, maybe in a mouseMove..." - aMouseEvent isMouseDown ifTrue: [ - lastClickDown _ aMouseEvent. - buttonDownCount _ buttonDownCount + 1 ]. - aMouseEvent isMouseUp ifTrue: [ - buttonUpCount _ buttonUpCount + 1 ]. - - "Drag, or tap & hold" - (buttonDownCount = 1 and: [ buttonUpCount = 0]) ifTrue: [ - distance > 0 ifTrue: [ - aHand dontWaitForMoreClicks. - dragSelector - ifNotNil: [ self didDrag ] - "If we have already moved, then it won't be a double or triple click... why wait?" - ifNil: [ self didClick ]. - ^ false ]. - timedOut ifTrue: [ - aHand dontWaitForMoreClicks. - "Simulate button 2 via tap & hold. Useful for opening menus on pen computers." - sendMouseButton2Activity ifTrue: [ - clickClient mouseButton2Activity ]. - ^ false ]]. - - "If we're over triple click, or timed out, or mouse moved, don't allow more clicks." - (buttonDownCount = 4 or: [ timedOut or: [ distance > 0 ]]) ifTrue: [ - aHand dontWaitForMoreClicks. - ^ false ]. - - "Simple click." - (buttonDownCount = 1 and: [ buttonUpCount = 1 ]) ifTrue: [ - self didClick ]. - - "Click & hold" - (buttonDownCount = 2 and: [ buttonUpCount = 1]) ifTrue: [ - self didClickAndHalf ]. - - "Double click." - (buttonDownCount = 2 and: [ buttonUpCount = 2]) ifTrue: [ - self didDoubleClick ]. - - "Double click & hold." - (buttonDownCount = 3 and: [ buttonUpCount = 2]) ifTrue: [ - self didDoubleClickAndHalf ]. - - "Triple click" - (buttonDownCount = 3 and: [ buttonUpCount = 3]) ifTrue: [ - self didTripleClick ]. - - "This means: if a mouseDown, then don't further process this event (so we can turn it into a double or triple click on next buttonUp)" - ^ aMouseEvent isMouseDown! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - Preferences preferencesDictionary removeKey: #tapAndHoldEmulatesButton2! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4638-tapNholdTweaks-JuanVuletich-2021Jun17-12h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4638] on 18 June 2021 at 11:52:40 am'! -!Stream methodsFor: 'nonhomogeneous accessing' stamp: 'jmv 6/18/2021 11:51:28' prior: 50413477! - nextNumber - "Answer a number from the (text) stream." - - |element| - [(element := self next) isNil or: [element isDigit or: [element = $- or: [element = $. or: [element = $)]]]]] whileFalse. - element ifNil: [^nil]. - self skip: -1. - element = $) ifTrue: [^nil]. - ^Number readFrom: self! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4639-AllowMissingLeadingZeroForStreamnextNumber-JuanVuletich-2021Jun18-11h51m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4639] on 18 June 2021 at 3:42:08 pm'! -!Form methodsFor: 'displaying-generic' stamp: 'jmv 6/18/2021 15:21:59' prior: 16847720! - displayAt: aDisplayPoint - "Display the receiver located at aDisplayPoint with default settings for - the displayMedium, rule and halftone." - - self displayOn: Display at: aDisplayPoint.! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 6/18/2021 14:48:15' prior: 50570404! - displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - aRectangle is clipped appropiately if some owner clips us." - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - privateDisplayBounds _ self isOrthoRectangularMorph - ifTrue: [ - "In these cases, #drawOn: might not be able to find bounds (InnerTextMorph, for example), - but it is OK to compute them from #morphLocalBounds. This is not true for non-orthoRectangular morphs!!" - aCanvas boundingRectOfCurrentMorphFromLocalBounds] - ifFalse: [ - "In this cases, we use the bounds bound by #drawOn. This method must therefore be called after calling - #drawOn: and #postDrawOn: . See senders." - aCanvas boundingRectOfCurrentMorphAfterDraw]]]].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 6/18/2021 14:49:16' prior: 50536160! - fullUpdateBounds: aMorph - - aMorph visible ifTrue: [ - self into: aMorph. - self canvasToUse fullUpdateCurrentBounds. - self outOfMorph ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 6/18/2021 14:49:49' prior: 50570432! - fullUpdateCurrentBounds - - | isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph isOrthoRectangularMorph ifFalse: [ - "In these cases, #drawOn: is required to find bounds. - #displayBoundsSetFrom: will use the bounds found by us in these case. - See #displayBoundsSetFrom:" - currentMorph drawOn: self. - currentMorph postDrawOn: self ]. - currentMorph displayBoundsSetFrom: self. - currentMorph submorphsDo: [ :m | - self fullUpdateBounds: m ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4640-Form-displayAt-fix-JuanVuletich-2021Jun18-14h48m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4639] on 18 June 2021 at 4:58:09 pm'! - -Point removeSelector: #enclosingRectangleWith:! - -!methodRemoval: Point #enclosingRectangleWith: stamp: 'Install-4641-Cleanup-JuanVuletich-2021Jun18-16h04m-jmv.001.cs.st 7/20/2021 16:51:47'! -enclosingRectangleWith: aPoint - "Answer a Rectangle with integer coordinates that includes self and aPoint." - - self flag: #revisarM3. - ^Rectangle - origin: (x min: aPoint x) floor @ (y min: aPoint y) floor - corner: (x max: aPoint x) ceiling @ (y max: aPoint y ceiling) +1! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4641-Cleanup-JuanVuletich-2021Jun18-16h04m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4641] on 24 June 2021 at 10:24:59 am'! -!Duration class methodsFor: 'squeak protocol' stamp: 'jmv 6/24/2021 10:19:10' prior: 16836156! - fromString: aString - " - Extended to accept non-ANSI formats, such as: - Duration fromString: '1:50:00' - Duration fromString: '5:30.5' - Duration fromString: '1:6:50:00' - Duration fromString: '3.5h' - Duration fromString: '2.5min' - Duration fromString: '1.5s' - Duration fromString: '200s' - Duration fromString: '200ms' - " - | colons s | - - "If aString includes at least one $:, complete ANSI format" - colons _ aString occurrencesOf: $:. - colons > 0 ifTrue: [ - s _ aString. - [colons < 3] whileTrue: [ - s _ '00:', s. - colons _ colons + 1 ]. - ^ self readFrom: (ReadStream on: s) ]. - - "'3.5h' means 3.5 hours" - (aString endsWith: 'h') ifTrue: [ - ^self hours: aString asNumber ]. - - "'3.5min' means 3.5 minutes" - (aString endsWith: 'min') ifTrue: [ - ^self minutes: aString asNumber ]. - - "'3ms' means 3 milliseconds" - (aString endsWith: 'ms') ifTrue: [ - ^self milliSeconds: aString asNumber ]. - - "'3.5s' means 3.5 seconds" - (aString endsWith: 's') ifTrue: [ - ^self seconds: aString asNumber ]. - - ^nil! ! -!Duration class methodsFor: 'squeak protocol' stamp: 'jmv 6/24/2021 10:17:17' prior: 50467797 overrides: 16882927! - readFrom: aStream - "Formatted as per ANSI 5.8.2.16: [-]D:HH:MM:SS[.S]" - - | sign days hours minutes seconds nanos nanosBuffer | - sign := (aStream peekFor: $-) ifTrue: [-1] ifFalse: [1]. - days := (aStream upTo: $:) findPositiveInteger * sign. - hours := (aStream upTo: $:) findPositiveInteger * sign. - minutes := (aStream upTo: $:) findPositiveInteger * sign. - seconds := (aStream upTo: $.) findPositiveInteger * sign. - nanosBuffer := '000000000' copy. - nanos := WriteStream on: nanosBuffer. - [aStream atEnd not and: [aStream peek isDigit]] - whileTrue: [nanos nextPut: aStream next]. - - ^ self - days: days - hours: hours - minutes: minutes - seconds: seconds - nanoSeconds: (nanosBuffer findPositiveInteger * sign) - - " - Duration readFrom: '0:00:00:00' readStream - Duration readFrom: '0:00:00:00.000000001' readStream - Duration readFrom: '0:00:00:00.9' readStream - Duration readFrom: '0:00:00:00.99' readStream - Duration readFrom: '0:00:00:00.99999999' readStream - Duration readFrom: '0:00:00:00.999999999' readStream - Duration readFrom: '0:00:00:00.100000000' readStream - Duration readFrom: '0:00:00:00.001 ' readStream - Duration readFrom: '0:00:00:00.1' readStream - Duration readFrom: '0:00:00:01 ' readStream - Duration readFrom: '0:12:45:45' readStream - Duration readFrom: '1:00:00:00' readStream - Duration readFrom: '365:00:00:00' readStream - Duration readFrom: '-7:09:12:06.10' readStream - Duration readFrom: '+0:01:02:3' readStream - "! ! -!String methodsFor: 'converting' stamp: 'jmv 6/24/2021 10:20:25' prior: 16916433! - 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 inString | - - "Hack in some minimal workaround for Unicode stuff" - inString _ self copyReplaceAll: '’' with: $' asString. - "Check if we can handle this in #safeValue: in some way..." - inString = self ifFalse: [ self halt ]. - - in _ ReadStream on: inString. - 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: $"]. - rest first = $# ifTrue: [ out nextPut: (Character numericValue: rest findPositiveInteger) ]. - did = out position ifTrue: [ - out nextPut: $&; nextPutAll: rest. - "self error: 'unknown encoded HTML char'." - "Please add it to this method"]] - ifFalse: [out nextPut: char]]. - ]. - ^ out contents! ! -!RemoteString methodsFor: 'private' stamp: 'jmv 6/24/2021 10:22:10' prior: 16900641! - checkSum: aString - "Construct a checksum of the string. A three byte number represented as Base64 characters." - | sum shift bytes | - sum := aString size. - shift := 0. - aString do: [:char | - (shift := shift + 7) > 16 ifTrue: [shift := shift - 17]. - "shift by 7 to keep a change of adjacent chars from xoring to same value" - sum := sum bitXor: (char numericValue bitShift: shift) - ]. - bytes := ByteArray new: 3. - sum := sum + 16r10000000000. - 1 to: 3 do: [:ind | bytes at: ind put: (sum digitAt: ind)]. - ^bytes base64Encoded! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4642-fixSendersOfStringasInteger-JuanVuletich-2021Jun24-10h08m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4636] on 19 June 2021 at 11:08:05 pm'! - -WidgetMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp titleMorph activeSubMenu popUpOwner prevMouseFocus prevKbdFocus ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #MenuMorph category: #'Morphic-Menus' stamp: 'Install-4643-RestoreFocusOnMenuExit-HilaireFernandes-2021Jun19-22h28m-hlsf.002.cs.st 7/20/2021 16:51:47'! -WidgetMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp titleMorph activeSubMenu popUpOwner prevMouseFocus prevKbdFocus' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! -!MenuMorph methodsFor: 'control' stamp: 'hlsf 6/19/2021 22:50:33' prior: 50399789! - popUpAt: aPoint forHand: hand allowKeyboard: aBoolean - "Present this menu at the given point under control of the given hand." - - | evt | - self items isEmpty ifTrue: [^self]. - self addBlankIconsIfNecessary. - (self submorphs select: [ :m | m is: #UpdatingMenuItemMorph ]) - do: [ :m | m updateContents]. - self runningWorld addMorphFront: self position: aPoint - `2 @ 8`. - self fitInWorld. - "Acquire focus for valid pop up behavior" - prevKbdFocus _ hand keyboardFocus. - prevMouseFocus _ hand mouseFocus. - hand newMouseFocus: self. - aBoolean ifTrue: [ hand newKeyboardFocus: self ]. - evt _ hand lastMouseEvent. - (evt isKeyboard or: [ evt isMouse and: [ evt anyButtonPressed not ]]) - ifTrue: [ - "Select first item if button not down" - self moveSelectionDown: 1 event: evt ]! ! -!MenuMorph methodsFor: 'control' stamp: 'hlsf 6/19/2021 22:50:09' prior: 50399814! - popUpAt: aPoint forHand: hand in: aWorld allowKeyboard: aBoolean - "Present this menu at the given point under control of the given hand." - - self items isEmpty ifTrue: [ ^self ]. - self addBlankIconsIfNecessary. - (self submorphs select: [ :m | m is: #UpdatingMenuItemMorph]) - do: [ :m | m updateContents]. - aWorld addMorphFront: self position: aPoint - `2 @ 8`. - self fitInWorld. - "Acquire focus for valid pop up behavior" - prevKbdFocus _ hand keyboardFocus. - prevMouseFocus _ hand mouseFocus. - hand newMouseFocus: self. - aBoolean ifTrue: [ hand newKeyboardFocus: self ]! ! -!MenuMorph methodsFor: 'events' stamp: 'hlsf 6/19/2021 23:05:11' prior: 50562696 overrides: 16874541! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - "Handle a mouse down event." - (stayUp or: [ self fullContainsGlobalPoint: aMouseButtonEvent eventPosition ]) - ifFalse: [ - self deleteIfPopUp: aMouseButtonEvent. - self activeHand - newKeyboardFocus: prevKbdFocus; - newMouseFocus: prevMouseFocus. - ^ self ]. "click outside" - - "Grab the menu and drag it to some other place - This is reimplemented here because we handle the event, and if the following lines are commented, a menu can't be grabbed with the hand. This is not nice and shouldn't be needed" - self isSticky ifTrue: [ ^self ]. - aMouseButtonEvent hand grabMorph: self! ! -!MenuMorph methodsFor: 'events' stamp: 'hlsf 6/19/2021 23:05:34' prior: 50562717 overrides: 16874556! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - "Handle a mouse up event. - Note: This might be sent from a modal shell." - (self fullContainsGlobalPoint: aMouseButtonEvent eventPosition) ifFalse:[ - "Mouse up outside. Release eventual focus and delete if pop up." - aMouseButtonEvent hand ifNotNil: [ :h | h releaseMouseFocus: self ]. - self deleteIfPopUp: aMouseButtonEvent. - self activeHand - newKeyboardFocus: prevKbdFocus; - newMouseFocus: prevMouseFocus. - ^ self]. - stayUp ifFalse: [ - "Still in pop-up transition; keep focus" - aMouseButtonEvent hand newMouseFocus: self ]! ! -!MenuMorph methodsFor: 'initialization' stamp: 'hlsf 6/19/2021 23:01:58' prior: 50567143 overrides: 50574156! - delete - activeSubMenu ifNotNil: [activeSubMenu delete]. - self itemsDo: [ :i | i deselect ]. - super delete.! ! - -WidgetMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp titleMorph activeSubMenu popUpOwner prevKbdFocus prevMouseFocus' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #MenuMorph category: #'Morphic-Menus' stamp: 'Install-4643-RestoreFocusOnMenuExit-HilaireFernandes-2021Jun19-22h28m-hlsf.002.cs.st 7/20/2021 16:51:47'! -WidgetMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp titleMorph activeSubMenu popUpOwner prevKbdFocus prevMouseFocus' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4643-RestoreFocusOnMenuExit-HilaireFernandes-2021Jun19-22h28m-hlsf.002.cs.st----! - -'From Cuis 5.0 [latest update: #4642] on 25 June 2021 at 10:10:12 am'! -!MenuMorph methodsFor: 'events' stamp: 'jmv 6/25/2021 10:09:08' prior: 50431720 overrides: 50449239! - keyStroke: aKeyboardEvent - | matchString char asc selectable | - char := aKeyboardEvent keyCharacter. - asc := char numericValue. - aKeyboardEvent isReturnKey - ifTrue: [ - selectedItem ifNotNil: [ - selectedItem hasSubMenu - ifTrue: [ - aKeyboardEvent hand newMouseFocus: selectedItem subMenu. - ^aKeyboardEvent hand newKeyboardFocus: selectedItem subMenu] - ifFalse: [ - "self delete." - ^selectedItem invokeWithEvent: aKeyboardEvent]]. - (selectable := self items) size = 1 - ifTrue: [^selectable first invokeWithEvent: aKeyboardEvent]. - ^self]. - asc = 27 - ifTrue: [ - "escape key" - self - valueOfProperty: #matchString - ifPresentDo: [ :str | - str isEmpty - ifFalse: [ - "If filtered, first ESC removes filter" - self setProperty: #matchString toValue: String new. - self selectItem: nil. - ^self displayFiltered: aKeyboardEvent]]. - "If a stand-alone menu, just delete it" - self delete. - self activeHand - newKeyboardFocus: prevKbdFocus; - newMouseFocus: prevMouseFocus. - ^self]. - (asc = 28 or: [asc = 29]) - ifTrue: [ - "left or right arrow key" - (selectedItem notNil and: [selectedItem hasSubMenu]) - ifTrue: [ - aKeyboardEvent hand newMouseFocus: selectedItem subMenu. - selectedItem subMenu moveSelectionDown: 1 event: aKeyboardEvent. - ^aKeyboardEvent hand newKeyboardFocus: selectedItem subMenu] - ifFalse: [^ self]]. - asc = 30 ifTrue: [^self moveSelectionDown: -1 event: aKeyboardEvent]. "up arrow key" - asc = 31 ifTrue: [^self moveSelectionDown: 1 event: aKeyboardEvent]. "down arrow key" - asc = 11 ifTrue: [^self moveSelectionDown: -5 event: aKeyboardEvent]. "page up key" - asc = 12 ifTrue: [^self moveSelectionDown: 5 event: aKeyboardEvent]. "page down key" - matchString := self valueOfProperty: #matchString ifAbsent: [String new]. - matchString := char = Character backspace - ifTrue: [ - matchString isEmpty ifTrue: [matchString] ifFalse: [matchString allButLast]] - ifFalse: [matchString copyWith: aKeyboardEvent keyCharacter]. - self setProperty: #matchString toValue: matchString. - self displayFiltered: aKeyboardEvent! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4644-AlsoOnEsc-JuanVuletich-2021Jun25-10h09m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4644] on 25 June 2021 at 12:07:37 pm'! -!MenuItemMorph methodsFor: 'initialization' stamp: 'jmv 6/25/2021 12:02:54' prior: 50385284 overrides: 50556106! - initialize - "initialize the state of the receiver" - super initialize. - isEnabled _ true. - subMenu _ nil. - isSelected _ false. - target _ nil. - selector _ nil. - arguments _ nil. - font _ Preferences standardMenuFont. - self contents: ''.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4645-MenuItemCreationFix-JuanVuletich-2021Jun25-12h07m-jmv.001.cs.st----! - -'From Haver 5.0 [latest update: #4638] on 18 June 2021 at 8:49:05 am'! -!TestRunner methodsFor: 'processing' stamp: 'KLG 6/18/2021 08:42:36' prior: 50379359! - runSuiteProfiled: suite - running ifNotNil: [ ^self inform: 'already running' ]. - suite addDependent: self. - totalTests _ suite tests size. - completedTests _ 0. - running _ [ - [ result _ TimeProfileBrowser onBlock: [suite run] ] - ensure: [ - running _ nil. - suite removeDependent: self. - runSemaphore signal. - UISupervisor whenUIinSafeState: [ - self updateWindow: result. - self changed: #runTests. - self changed: #runOneTest. - ]. - ]. - ] newProcess. - self runWindow. - self changed: #runTests. - self changed: #runOneTest. - running - name: 'TestRunner'; -" priority: Processor userBackgroundPriority;" - resume. -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4646-TimeProfileBrowser_in_TestRrunner-GeraldKlix-2021Jun17-12h54m-KLG.001.cs.st----! - -'From Haver 5.0 [latest update: #4641] on 19 June 2021 at 3:50:44 pm'! -!Compiler methodsFor: 'public access' stamp: 'KLG 6/19/2021 15:45:45' prior: 50444928! - evaluateMethod: method to: receiver logged: doLog profiled: doProfile - - "See evaluate:in:to:notifying:ifFail:logged:profiled: - It does the same but without compiling because it recevies the result of the compilation - as the parameter method. - self should have compile method" - - | value toLog itsSelection itsSelectionString | - - "(jmv) Log before evaluating. This way, if the evaluation is halted by whatever reason, it is logged anyway" - doLog ifTrue: [ - toLog _ ((requestor respondsTo: #selection) - and: [ (itsSelection _ requestor selection) notNil - and: [ (itsSelectionString _ itsSelection asString) isEmptyOrNil not ]]) - ifTrue: [ itsSelectionString ] - ifFalse: [ sourceStream contents ]. - SystemChangeNotifier uniqueInstance evaluated: toLog context: context ]. - - "Evaluate now." - doProfile - ifTrue: [ - TimeProfileBrowser onBlock: [ - value _ receiver - withArgs: (context ifNil: [#()] ifNotNil: [{context}]) - executeMethod: method ]] - ifFalse: [ - value _ receiver - withArgs: (context ifNil: [#()] ifNotNil: [{context}]) - executeMethod: method ]. - - ^ value! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4647-TimeProfileBrowser_in_Compiler-GeraldKlix-2021Jun19-12h27m-KLG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4647] on 25 June 2021 at 12:34:07 pm'! -!Encoder methodsFor: 'private' stamp: 'MM 6/25/2021 11:55:34' prior: 50476779! - warnAboutShadowed: name - - | msg transcriptMsg | - - msg _ 'There already exists a variable named ', name, ' '. - requestor addWarning: msg. - - transcriptMsg _ msg, ' (', class className, '>>', selector printString,')'. - Transcript newLine; show: transcriptMsg. - - InMidstOfFileinNotification signal - ifFalse: [ - requestor interactive - ifTrue: [ - self notify: msg] - ifFalse: [ - (RecompilationFailure - class: class - messageText: msg, String newLineString, 'Please use a different name') signal ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4648-BetterTranscriptWarnAboutShadowed-MarianoMontone-2021Jun25-12h33m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4648] on 29 June 2021 at 10:53:04 am'! -!SystemDictionary methodsFor: 'startup' stamp: 'MM 6/28/2021 23:26:17' prior: 16925412! - processCommandLineArgument: rawArgStream storeStartUpScriptArgsOn: startUpScriptArgs - " - Smalltalk processCommandLineArguments - - A possible example (duplicated single quotes: '' should be double quotes, but not allowed in a Smalltalk comment): - Squeak.exe Cuis4.2-2211x.image -r RequiredFeature1 -rRequiredFeature2 -d ''Transcript show: 'popo1'; newLine'' -d''Transcript show: 'popo2'; newLine'' -s smalltalkScript.st paramAlScript1 paramAlSCript2 ''parametro al script ->>>--// 3'' - " - | p data entry | - p _ rawArgStream next. - - (p first = $- and: [ p size > 1 ]) ifTrue: [ - "If the command is not included in p, it is next argument" - p size = 2 - ifTrue: [ - "as in -r RequiredFeature1" - data _ rawArgStream next ] - ifFalse: [ - "as in -rRequiredFeature2" - data _ p copyFrom: 3 to: p size ]. - p second caseOf: { - [ $r ] -> [ "as in -rRequiredFeature2" - { 'Feature require: '. data } print. - [ Feature require: data ] on: UnhandledError do: [:ex | ex return] ]. - [ $d ] -> [ "as in -d ''Transcript show: 'popo1'; newLine'' -d''Transcript show: 'popo2'; newLine'' (duplicated singleQuotes should read doubleQuote)" - { 'Compiler evaluate: '. data } print. - [ Compiler evaluate: data ] on: UnhandledError do: [:ex | ex return] ]. - [$l ] -> ["file in the file" - { 'File in: '. data} print. - [(CodeFile newFromFile: data asFileEntry) fileIn] on: UnhandledError do: [:ex | ex return]]. - [ $s ] -> [ "as in -s smalltalkScript.st paramAlScript1 paramAlSCript2 ''parametro al script ->>>--// 3'' (duplicated singleQuotes should read doubleQuote)" - [ rawArgStream atEnd ] whileFalse: [ - startUpScriptArgs nextPut: rawArgStream next ]. - "Can use 'Smalltalk startUpScriptArguments' inside the startUp script - { 'Compiler evaluate contents of file named: '. data. ' arguments: '. Smalltalk startUpScriptArguments } print." - entry _ data asFileEntry. - entry exists ifTrue: [ - entry readStreamDo: [ :stream | - [ Compiler evaluate: stream contentsOfEntireFile ] on: UnhandledError do: [:ex | ex return]]]. - "Maybe we decide to clear them after startup script execution - startUpScriptArguments _ nil" ] - } - otherwise: [] - ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4649-fileInStartUpOption-MarianoMontone-2021Jun29-10h52m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4649] on 29 June 2021 at 11:26:31 am'! -!Editor methodsFor: 'new selection' stamp: 'jmv 6/29/2021 11:23:28'! - selectWordOrDelimitedText - "Select delimited text or word--the result of double-clicking." - - ^self selectWordLeftDelimiters: self wordLeftDelimiters rightDelimiters: self wordRightDelimiters ! ! -!Editor methodsFor: 'new selection' stamp: 'jmv 6/29/2021 11:21:01' prior: 50452487! - selectWord - "Select exactly one word. - See also #selectWordOrDelimitedText" - - ^self selectWordLeftDelimiters: '' rightDelimiters: ''! ! -!TextEditor methodsFor: 'events' stamp: 'jmv 6/29/2021 11:23:47' prior: 16931943! - clickAndHalf - - self selectWordOrDelimitedText. - - doWordSelection _ true. - doParagraphSelection _ false. - initialSelectionStart _ self startBlock. - initialSelectionStop _ self stopBlock! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4650-WordSelectionFix-JuanVuletich-2021Jun29-11h23m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4649] on 29 June 2021 at 11:30:08 am'! -!ObjectExplorerWindow methodsFor: 'building menus' stamp: 'MM 6/29/2021 09:56:27' prior: 50399357! - genericMenu - "Borrow a menu from my inspector" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - model getCurrentSelection - ifNil: [ - aMenu - add: '*nothing selected*' - target: self - action: #yourself] - ifNotNil: [ - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'inspect (i)'. - #selector -> #inspectSelection. - #icon -> #inspectIcon - } asDictionary. - { - #label -> 'explore (I)'. - #selector -> #exploreSelection. - #icon -> #exploreIcon - } asDictionary. - { - #label -> 'copy to clipboard (c)'. - #selector -> #copySelectionToClipboard. - #icon -> #copyIcon - } asDictionary. - { - #label -> 'basic inspect'. - #selector -> #inspectBasic. - #icon -> #inspectIcon - } asDictionary. - { - #label -> 'references finder'. - #selector -> #openReferencesFinder. - #icon -> #exploreIcon - } asDictionary. - { - #label -> 'weight explorer'. - #selector -> #openWeightExplorer. - #icon -> #exploreIcon - } asDictionary. - nil. - { - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - }`. - model getCurrentSelection ifNotNil: [ :currSel | - (currSel item is: #Morph) ifTrue: [ - aMenu addLine. - aMenu add: 'show morph halo' target: currSel item action: #addHalo]]. - aMenu addLine; - add: 'monitor changes' - target: self - action: #monitor: - argument: model getCurrentSelection. - model class == ReferencesExplorer ifTrue: [ - aMenu addLine; - add: 'rescan' - target: self - action: #rescan ]]. - model basicMonitorList isEmptyOrNil - ifFalse: [ - aMenu addLine; - add: 'stop monitoring all' - target: self - action: #stopMonitoring ]. - ^ aMenu! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4651-ShowMorphHalo-optionInExplorers-MarianoMontone-2021Jun29-11h26m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4651] on 5 July 2021 at 2:36:45 pm'! -!Debugger class methodsFor: 'constants' stamp: 'jmv 7/5/2021 14:31:30'! - defaultDebugStackSize - ^50! ! -!Debugger methodsFor: 'context stack (message list)' stamp: 'jmv 7/5/2021 14:32:39' prior: 16829722! - expandStack - "A Notifier is being turned into a full debugger. Show a substantial amount of stack in the context pane." - - self newStack: (contextStackTop stackOfSize: Debugger defaultDebugStackSize). - contextStackIndex _ 0. - receiverInspector _ Inspector inspect: nil. - contextVariablesInspector _ ContextVariablesInspector inspect: nil. - proceedValue _ nil! ! -!ProcessBrowser methodsFor: 'stack list' stamp: 'jmv 7/5/2021 14:34:21' prior: 16895044! - updateStackList - self updateStackList: Debugger defaultDebugStackSize! ! -!ProcessBrowser class methodsFor: 'CPU utilization' stamp: 'jmv 7/5/2021 14:32:32' prior: 50567327! - dumpPigStackOn: aStream - "Must run forked on its own process, so the monitored behavior is not affected too much" - - | promise tally process stack suspendedContext | - promise := Processor tallyCPUUsageFor: 1 every: 10. - tally := promise value. - "UISupervisor whenUIinSafeState: [self dumpTallyOnTranscript: tally]." - aStream nextPutAll: '====Al processes===='; newLine. - self dumpTally: tally on: aStream. - aStream newLine; nextPutAll: '====Process using most CPU===='; newLine. - process _ tally sortedCounts first value. - (100.0 * (tally occurrencesOf: process) / tally size) rounded printOn: aStream. - aStream - nextPutAll: ' % '; - nextPutAll: (process browserPrintStringFull: false); - newLine. - stack _ process == Processor activeProcess - ifTrue: [thisContext stackOfSize: Debugger defaultDebugStackSize] - ifFalse: [ - suspendedContext _ process suspendedContext. - suspendedContext - ifNotNil: [suspendedContext stackOfSize: Debugger defaultDebugStackSize]]. - stack - ifNil: [ aStream nextPutAll: 'No context'; newLine] - ifNotNil: [ - stack do: [ :c | - c printOn: aStream. - aStream newLine ]]. - ^process! ! -!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'jmv 7/5/2021 14:33:38' prior: 16806209 overrides: 50527903! - recoverFromMDFaultWithTrace - "This method handles emthodDict faults to support, eg, discoverActiveClasses (qv)." - self recoverFromMDFault. - Smalltalk at: #MDFaultDict ifPresent: - [:faultDict | faultDict at: self name put: - (String streamContents: [ :strm | - (thisContext stackOfSize: Debugger defaultDebugStackSize) do: [ :item | - strm print: item; newLine]])] - -"Execute the following statement to induce MD fault tracing. This means that, not only will all active classes be recorded but, after a test run, MDFaultDict will contain, for every class used, a stack trace showing how it came to be used. This statement should be executed just prior to any such text, in order to clear the traces. - - Smalltalk at: #MDFaultDict put: Dictionary new. - -"! ! -!ContextPart methodsFor: 'debugger access' stamp: 'jmv 7/5/2021 14:35:18' prior: 16823996! - errorReportOn: strm - "Write a detailed error report on the stack (above me) on a stream. For both the error file, and emailing a bug report. Suppress any errors while getting printStrings. Limit the length." - - | cnt aContext startPos | - strm print: Date today; space; print: Time now; newLine. - strm newLine. - strm nextPutAll: 'VM: '; - nextPutAll: Smalltalk platformName asString; - nextPutAll: ' - '; - nextPutAll: Smalltalk vmVersion asString; - newLine. - strm nextPutAll: 'Image: '; - nextPutAll: Smalltalk version asString; - nextPutAll: ' ['; - nextPutAll: Smalltalk lastUpdateString asString; - nextPutAll: ']'; - newLine. - strm newLine. - - "Note: The following is an open-coded version of ContextPart>>stackOfSize: since this method may be called during a low space condition and we might run out of space for allocating the full stack." - cnt _ 0. startPos _ strm position. - aContext _ self. - [aContext notNil and: [(cnt _ cnt + 1) < Debugger defaultDebugStackSize]] whileTrue: [ - aContext printDetails: strm. "variable values" - strm newLine. - aContext _ aContext sender]. - - strm newLine; nextPutAll: '--- The full stack ---'; newLine. - aContext _ self. - cnt _ 0. - [aContext == nil] whileFalse: [ - cnt _ cnt + 1. - cnt = Debugger defaultDebugStackSize ifTrue: [strm nextPutAll: ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -'; newLine ]. - strm print: aContext; newLine. "just class>>selector" - - strm position > (startPos+40000) ifTrue: [strm nextPutAll: '...etc...'. - ^ self]. "exit early" - cnt > 100 ifTrue: [strm nextPutAll: '-- and more not shown --'. ^ self]. - aContext _ aContext sender]. -! ! -!ContextPart methodsFor: 'debugger access' stamp: 'jmv 7/5/2021 14:35:26' prior: 50373285! - shortErrorReportOn: strm - "Write a short error report on the stack (above me) on a stream. For both the error file, and emailing a bug report. " - - | cnt aContext | - strm print: Date today; space; print: Time now; newLine. - aContext _ self. - cnt _ 0. - [aContext notNil and: [(cnt _ cnt + 1) < Debugger defaultDebugStackSize]] whileTrue: [ - strm print: aContext; newLine. "just class>>selector" - aContext _ aContext sender]! ! -!ContextPart methodsFor: 'debugger access' stamp: 'jmv 7/5/2021 14:33:53' prior: 16824120! - shortStack - "Answer a String showing the top ten contexts on my sender chain." - - ^ String streamContents: [ :strm | - (self stackOfSize: Debugger defaultDebugStackSize) - do: [:item | strm print: item; newLine]]! ! - -ContextPart removeSelector: #longStack! - -!methodRemoval: ContextPart #longStack stamp: 'Install-4652-LargerStackDumpsByDefault-JuanVuletich-2021Jul05-14h31m-jmv.001.cs.st 7/20/2021 16:51:48'! -longStack - "Answer a String showing the top 100 contexts on my sender chain." - - ^ String streamContents: [ :strm | - (self stackOfSize: 100) - do: [:item | strm print: item; newLine]]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4652-LargerStackDumpsByDefault-JuanVuletich-2021Jul05-14h31m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4651] on 5 July 2021 at 2:38:05 pm'! -!ArrayedCollection methodsFor: 'printing' stamp: 'jmv 7/5/2021 13:26:23' overrides: 16814609! - printNameOn: aStream - - aStream - nextPutAll: self class name withArticle; - nextPut: $:; - print: self size! ! -!Collection methodsFor: 'printing' stamp: 'jmv 7/5/2021 13:24:54' prior: 16814609! - printNameOn: aStream - - aStream - nextPutAll: self class name withArticle! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4653-ArraySizeInPrintString-JuanVuletich-2021Jul05-14h36m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4651] on 5 July 2021 at 2:42:08 pm'! -!Morph methodsFor: 'drawing' stamp: 'jmv 7/5/2021 14:03:10' prior: 50560991! - postDrawOn: aCanvas - "A canvas is already set with a proper transformation from our coordinates to those of the Canvas target. - Possible second stage of drawing, after drawing submorphs, and on top of them. - Answer true if anything was drawn." - - ^false! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/5/2021 14:05:34' prior: 50574405! - fullUpdateCurrentBounds - - | isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph isOrthoRectangularMorph - ifTrue: [currentMorph displayBoundsSetFrom: self] - ifFalse: [ - "In these cases, #drawOn: is required to find bounds. - #displayBoundsSetFrom: will use the bounds found by us in these case. - See #displayBoundsSetFrom:" - currentMorph - drawOn: self; - displayBoundsSetFrom: self. - (currentMorph postDrawOn: self) ifTrue: [ - currentMorph displayBoundsUpdateFrom: self ]]. - currentMorph submorphsDo: [ :m | - self fullUpdateBounds: m ]].! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 7/5/2021 14:03:57' prior: 50571054 overrides: 50564923! - drawCurrentAndSubmorphs - - self isCurrentMorphVisible ifTrue: [ - - currentMorph drawOn: self. - currentMorph displayBoundsSetFrom: self. - - "Display submorphs back to front" - "coordinate system stack already set up for aMorph - ('ivars transformations' and 'currentTransformation')" - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | self fullDraw: m ]]. - - (currentMorph postDrawOn: self) ifTrue: [ - currentMorph displayBoundsUpdateFrom: self ]. - - currentMorph isHighlighted ifTrue: [ - self drawHighlight: currentMorph ]. - ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4654-postDrawOn-optimization-JuanVuletich-2021Jul05-14h38m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4651] on 5 July 2021 at 2:45:39 pm'! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/5/2021 10:20:27'! - knowsContour - "True if a morph requires the Canvas to update a #morphContour property on us. - Any subclass might answer true, if it #requiresVectorCanvas." - - ^false! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/5/2021 10:43:23' prior: 50574364! - displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - aRectangle is clipped appropiately if some owner clips us. - See also #displayBoundsUpdateFrom:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - self isOrthoRectangularMorph - ifTrue: [ - "In these cases, #drawOn: might not be able to find bounds (InnerTextMorph, for example), - but it is OK to compute them from #morphLocalBounds. This is not true for non-orthoRectangular morphs!!" - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphFromLocalBounds ] - ifFalse: [ - "In this cases, we use the bounds bound by #drawOn. This method must therefore be called after calling #drawOn:." - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphAfterDraw. - self knowsContour ifTrue: [ - self setProperty: #contour - toValue: (aCanvas contourOfCurrentMorphAfterDrawInto: (self valueOfProperty: #contour)). - ] - ]]]].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/5/2021 14:01:16' prior: 50570146! - displayBoundsUpdateFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us. - To be called after #postDrawOn:. See also #displayBoundsSetFrom:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - self isOrthoRectangularMorph ifFalse: [ "Like in #displayBoundsSetFrom:" - | oldTop oldBottom | - oldTop _ privateDisplayBounds top. - oldBottom _ privateDisplayBounds bottom-1. - privateDisplayBounds _ privateDisplayBounds - quickMerge: aCanvas boundingRectOfCurrentMorphAfterDraw. - self knowsContour ifTrue: [ - self setProperty: #contour - toValue: (aCanvas - contourOfCurrentMorphAfterDrawUpdate: (self valueOfProperty: #contour) - oldTop: oldTop - oldBottom: oldBottom) ]]]]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4655-knowsContour-JuanVuletich-2021Jul05-14h42m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4656] on 6 July 2021 at 5:21:09 pm'! -!HandMorph methodsFor: 'focus handling' stamp: 'jmv 7/6/2021 17:18:31' prior: 16851917! - mouseFocus - - mouseFocus ifNotNil: [ - (mouseFocus isWorldMorph or: [mouseFocus isInWorld not]) - ifTrue: [ mouseFocus _ nil ]]. - ^mouseFocus! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4656-WorldCantTakeMouseFocus-JuanVuletich-2021Jul06-17h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4656] on 7 July 2021 at 4:07:27 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/7/2021 15:56:26' prior: 16875404! - morphExtent: aPoint - "In our own coordinates!! - Ignored by morphs that are not resizeable."! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/7/2021 15:56:17' prior: 16875415! - morphExtentInWorld: newExtent - "Argument is in world coordinates. - Ignored by morphs that are not resizeable."! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/7/2021 15:55:29' prior: 50554532! -morphPosition: aPoint - "Change the position of this morph. Argument is in owner's coordinates. - Ignored by morphs that are not movable."! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/7/2021 15:55:58' prior: 50554539! - morphPositionInWorld: newPositionInWorld - "Change the position of this morph. Argument is in world coordinates. - Ignored by morphs that are not movable."! ! -!Morph methodsFor: 'private' stamp: 'jmv 7/7/2021 15:56:03' prior: 50554637! - privatePosition: aPoint - "Change the position of this morph. Argument is in owner's coordinates. - Ignored by morphs that are not movable."! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4657-comments-JuanVuletich-2021Jul07-16h06m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4656] on 7 July 2021 at 4:07:59 pm'! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/7/2021 15:27:25'! - collides: aMorph - "Answer whether the pixels used by morphs touch at least at one place." - - privateDisplayBounds ifNil: [ - ^false ]. - - "Quick check with display bounds" - (aMorph displayBoundsIntersects: (privateDisplayBounds outsetBy: 1)) ifFalse: [ - ^false ]. - - "Precise check with contour, if available" - (self valueOfProperty: #contour) ifNotNil: [ :contour | | contourTop contourBottom | - contourTop _ privateDisplayBounds top max: 0. - contourBottom _ privateDisplayBounds bottom-1. - ^ aMorph contourIntersects: contour top: contourTop bottom: contourBottom ]. - - "If contour is not available, and both displayBounds overlap, answer true, as it is the best we can know." - ^ true! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/7/2021 15:50:00'! - contourIntersects: aContourArray top: aContourTop bottom: aContourBottom - "Precise check with contour, if available. - If contour is not available, use displayBounds" - - | contour contourTop contourBottom x0Own x1Own x0Arg x1Arg | - contour _ self valueOfProperty: #contour. - contourTop _ privateDisplayBounds top max: 0. - contourBottom _ privateDisplayBounds bottom-1. - - "Check if contours intersect, or touch horizontally" - (contourTop max: aContourTop) to: (contourBottom min: aContourBottom) do: [ :y | - x0Own _ contour ifNil:[privateDisplayBounds left] ifNotNil: [ contour at: (y - contourTop) * 2 + 1 ]. - x1Own _ contour ifNil:[privateDisplayBounds right-1] ifNotNil: [ contour at: (y - contourTop) * 2 + 2 ]. - x0Arg _ aContourArray at: (y - aContourTop) * 2 + 1. - x1Arg _ aContourArray at: (y - aContourTop) * 2 + 2. - (x0Own <= x1Arg and: [ x0Arg <= x1Own ]) - ifTrue: [ ^true ]]. - - "Check if aContour bottom touches our top and is above us" - contourTop-1 = aContourBottom ifTrue: [ - x0Own _ contour ifNil:[privateDisplayBounds left] ifNotNil: [ contour at: 1 ]. - x1Own _ contour ifNil:[privateDisplayBounds right-1] ifNotNil: [ contour at: 2 ]. - x0Arg _ aContourArray at: (aContourBottom - aContourTop) * 2 + 1. - x1Arg _ aContourArray at: (aContourBottom - aContourTop) * 2 + 2. - (x0Own < x1Arg and: [ x0Arg < x1Own ]) - ifTrue: [ ^true ]]. - - "Check if aContour top touches our bottom and is below us" - aContourTop-1 = contourBottom ifTrue: [ - x0Own _ contour ifNil:[privateDisplayBounds left] ifNotNil: [ contour at: (contourBottom - contourTop) * 2 + 1 ]. - x1Own _ contour ifNil:[privateDisplayBounds right-1] ifNotNil: [ contour at: (contourBottom - contourTop) * 2 + 2 ]. - x0Arg _ aContourArray at: 1. - x1Arg _ aContourArray at: 2. - (x0Own < x1Arg and: [ x0Arg < x1Own ]) - ifTrue: [ ^true ]]. - - ^false! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/7/2021 15:22:13'! - displayBoundsIntersects: aRectangle - - privateDisplayBounds ifNil: [ - ^false ]. - ^privateDisplayBounds intersects: aRectangle! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/7/2021 14:56:58'! - isCloserThan: aNumber toPoint: aPoint - "Answer true if our closest point to aPoint is less than aNumber pixels away. - In target surface (i.e. Display) coordinates. - Uses precise testing of the morph contour if available. See #knowsContour." - - | center contourTop contourBottom | - privateDisplayBounds ifNil: [ - ^false ]. - center _ privateDisplayBounds center. - "Quick checks: If not even within aNumber distance to display bounds, fail" - (center y - aPoint y) abs < (privateDisplayBounds height // 2 + aNumber) ifFalse: [ - ^false ]. - (center x - aPoint x) abs < (privateDisplayBounds width // 2 + aNumber) ifFalse: [ - ^false ]. - contourTop _ privateDisplayBounds top max: 0. - contourBottom _ privateDisplayBounds bottom-1. - "Precise check with contour, if available" - (self valueOfProperty: #contour) ifNotNil: [ :contour | | y0 y1 x0 x1 | - "Contour rows to consider are those within requested distance." - y0 _ aPoint y - aNumber max: contourTop. - y1 _ aPoint y + aNumber min: contourBottom. - y0 to: y1 do: [ :y | - x0 _ (contour at: (y - contourTop) * 2 + 1) - aNumber. - x1 _ (contour at: (y - contourTop) * 2 + 2) + aNumber. - "If a vertical line of 2*aNumber height centered on aPoint is inside the contour, quick exit" - (aPoint x between: x0 and: x1) ifTrue: [ ^true ]. - "Check if aPoint is close enough to contour" - (x0@y - aPoint) r < aNumber ifTrue: [ ^true ]. - (x1@y - aPoint) r < aNumber ifTrue: [ ^true ]]. - "Not inside, not close enough to contour" - ^ false ]. - "If contour is not available, and aPoint is close enough to displayBounds, answer true, as it is the best we can know." - ^ true! ! -!Morph methodsFor: 'testing' stamp: 'jmv 7/7/2021 11:56:01'! - isOwnedByWorldOrHand - "I.e. are we a top morph?" - - ^ self isOwnedByWorld or: [ self isOwnedByHand ]! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/7/2021 11:53:35' prior: 50575439! - displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - aRectangle is clipped appropiately if some owner clips us. - See also #displayBoundsUpdateFrom:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - self isOrthoRectangularMorph - ifTrue: [ - "In these cases, #drawOn: might not be able to find bounds (InnerTextMorph, for example), - but it is OK to compute them from #morphLocalBounds. This is not true for non-orthoRectangular morphs!!" - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphFromLocalBounds ] - ifFalse: [ - "In this cases, we use the bounds bound by #drawOn. This method must therefore be called after calling #drawOn:." - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphAfterDraw. - self setProperty: #contour toValue: ( - self knowsContour ifTrue: [ aCanvas contourOfCurrentMorphAfterDrawInto: (self valueOfProperty: #contour) ])]]]].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/7/2021 14:57:23' prior: 50575478! - displayBoundsUpdateFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us. - To be called after #postDrawOn:. See also #displayBoundsSetFrom:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - self isOrthoRectangularMorph ifFalse: [ "Like in #displayBoundsSetFrom:" - | oldTop oldBottom | - oldTop _ privateDisplayBounds top max: 0. - oldBottom _ privateDisplayBounds bottom-1. - privateDisplayBounds _ privateDisplayBounds - quickMerge: aCanvas boundingRectOfCurrentMorphAfterDraw. - self setProperty: #contour toValue: - (self knowsContour ifTrue: [ - aCanvas - contourOfCurrentMorphAfterDrawUpdate: (self valueOfProperty: #contour) - oldTop: oldTop - oldBottom: oldBottom ])]]]].! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/7/2021 11:56:38' prior: 50575431! - knowsContour - "True if a morph requires the Canvas to update a #morphContour property on us. - Any subclass might answer true, if it #requiresVectorCanvas. - By default, any top morph that is drawn by VectorCanvas." - - ^self requiresVectorCanvas and: [ self isOwnedByWorldOrHand ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4658-collisionDetection-JuanVuletich-2021Jul07-16h07m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4658] on 8 July 2021 at 10:50:45 am'! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/8/2021 10:48:34' prior: 50575763! - displayBoundsUpdateFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us. - To be called after #postDrawOn:. See also #displayBoundsSetFrom: - This more complicated update is needed because the contour information from #drawOn: was possibly - when drawing submorphs. So, the controur from #drawOn: needs to be retrieved, and updated with the - new contour information from #postDrawOn:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - self isOrthoRectangularMorph ifFalse: [ "Like in #displayBoundsSetFrom:" - | oldTop oldBottom | - oldTop _ privateDisplayBounds top max: 0. - oldBottom _ privateDisplayBounds bottom-1. - privateDisplayBounds _ privateDisplayBounds - quickMerge: aCanvas boundingRectOfCurrentMorphAfterDraw. - self setProperty: #contour toValue: - (self knowsContour ifTrue: [ - aCanvas - contourOfCurrentMorphAfterDrawUpdate: (self valueOfProperty: #contour) - oldTop: oldTop - oldBottom: oldBottom ])]]]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4659-comment-JuanVuletich-2021Jul08-10h48m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4659] on 8 July 2021 at 12:16:12 pm'! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/8/2021 12:09:56' prior: 50575599! - contourIntersects: aContourArray top: aContourTop bottom: aContourBottom - "Check if contours intersect. - If contour is not available, use displayBounds" - - | contour contourTop contourBottom x0Own x1Own x0Arg x1Arg | - contour _ self valueOfProperty: #contour. - contourTop _ privateDisplayBounds top max: 0. - contourBottom _ privateDisplayBounds bottom-1. - - (contourTop max: aContourTop) to: (contourBottom min: aContourBottom) do: [ :y | - x0Own _ contour ifNil:[privateDisplayBounds left] ifNotNil: [ contour at: (y - contourTop) * 2 + 1 ]. - x1Own _ contour ifNil:[privateDisplayBounds right-1] ifNotNil: [ contour at: (y - contourTop) * 2 + 2 ]. - x0Arg _ aContourArray at: (y - aContourTop) * 2 + 1. - x1Arg _ aContourArray at: (y - aContourTop) * 2 + 2. - (x0Own <= x1Arg and: [ x0Arg <= x1Own ]) - ifTrue: [ ^true ]]. - - ^false! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4660-simplify-JuanVuletich-2021Jul08-11h38m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4660] on 13 July 2021 at 9:59:40 am'! -!AffineTransformation class methodsFor: 'instance creation' stamp: 'jmv 7/12/2021 17:06:17'! -withRadians: radians around: rotationCenter - - ^(AffineTransformation withTranslation: rotationCenter) composedWith: - ((AffineTransformation withRadians: radians) composedWith: - (AffineTransformation withTranslation: rotationCenter negated)).! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/13/2021 09:58:42'! - wantsContour - "True if a morph requires the Canvas to update a #morphContour property on us. - Any subclass might answer true, if it #requiresVectorCanvas. - By default, any top morph that is drawn by VectorCanvas." - - ^self requiresVectorCanvas and: [ self isOwnedByWorldOrHand ]! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 7/13/2021 09:40:08' prior: 50559303 overrides: 50559252! - referencePosition - ^self externalizeToWorld: self rotationCenter! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 7/13/2021 09:52:20'! - rotationCenter - "In own coordinates. - Subclasses might redefine if desired." - - self valueOfProperty: #rotationCenter ifPresentDo: [ :p | ^p ]. - self displayFullBounds ifNotNil: [ :r | - ^self setProperty: #rotationCenter toValue: (self internalizeFromWorld: r center) ]. - ^`0@0`.! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 7/12/2021 16:02:51' overrides: 50575929! - rotationCenter - "In own coordinates." - - ^ extent / 2.0.! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 7/12/2021 16:02:56' overrides: 50575929! - rotationCenter - "In own coordinates." - - ^ extent / 2.0.! ! -!AffineTransformation methodsFor: 'composing' stamp: 'jmv 7/12/2021 16:26:13' prior: 16778310! - composedWith: innerTransformation - "Return the composition of the receiver and the transformation passed in. - The result is a transformation whose application (transform:) is equivalent - to first applying innerTransformation and then self. - In other words - self externalize: (innerTransformation externalize: aPoint) - innerTransformation internalize: (self internalize: aPoint)." - - ^innerTransformation innerComposedWithAffineTransformation: self! ! -!MorphicTranslation methodsFor: 'composing' stamp: 'jmv 7/12/2021 16:26:33' prior: 16878326! - composedWith: innerTransformation - "Return the composition of the receiver and the transformation passed in. - The result is a transformation whose application (transform:) is equivalent - to first applying innerTransformation and then self. - In other words - self externalize: (innerTransformation externalize: aPoint) - innerTransformation internalize: (self internalize: aPoint)." - - ^innerTransformation innerComposedWithTranslation: self! ! -!Morph methodsFor: 'accessing - properties' stamp: 'jmv 7/13/2021 09:51:15' prior: 16874042! - setProperty: aSymbol toValue: anObject - "change the receiver's property named aSymbol to anObject" - - "the properties dictionary never has nil as value. - Asking for a nil value is the same as removing the property." - - anObject ifNil: [ - self removeProperty: aSymbol. - ^nil]. - properties ifNil: [ properties _ IdentityDictionary new ]. - properties at: aSymbol put: anObject. - ^anObject! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/13/2021 09:58:46' prior: 50575725! - displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - aRectangle is clipped appropiately if some owner clips us. - See also #displayBoundsUpdateFrom:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - self isOrthoRectangularMorph - ifTrue: [ - "In these cases, #drawOn: might not be able to find bounds (InnerTextMorph, for example), - but it is OK to compute them from #morphLocalBounds. This is not true for non-orthoRectangular morphs!!" - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphFromLocalBounds ] - ifFalse: [ - "In this cases, we use the bounds bound by #drawOn. This method must therefore be called after calling #drawOn:." - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphAfterDraw. - self setProperty: #contour toValue: ( - self wantsContour ifTrue: [ aCanvas contourOfCurrentMorphAfterDrawInto: (self valueOfProperty: #contour) ])]]]].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/13/2021 09:58:48' prior: 50575816! - displayBoundsUpdateFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us. - To be called after #postDrawOn:. See also #displayBoundsSetFrom: - This more complicated update is needed because the contour information from #drawOn: was possibly - when drawing submorphs. So, the controur from #drawOn: needs to be retrieved, and updated with the - new contour information from #postDrawOn:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - self isOrthoRectangularMorph ifFalse: [ "Like in #displayBoundsSetFrom:" - | oldTop oldBottom | - oldTop _ privateDisplayBounds top max: 0. - oldBottom _ privateDisplayBounds bottom-1. - privateDisplayBounds _ privateDisplayBounds - quickMerge: aCanvas boundingRectOfCurrentMorphAfterDraw. - self setProperty: #contour toValue: - (self wantsContour ifTrue: [ - aCanvas - contourOfCurrentMorphAfterDrawUpdate: (self valueOfProperty: #contour) - oldTop: oldTop - oldBottom: oldBottom ])]]]].! ! -!Morph methodsFor: 'meta-actions' stamp: 'jmv 7/12/2021 17:37:54' prior: 50559837! - potentialEmbeddingTargets - "Return the potential targets for embedding the receiver" - | myRect myWorld | - owner ifNil:[^#()]. - myWorld := owner world ifNil: [^#()]. - myRect := self displayFullBounds. - ^Array streamContents: [ :strm | - myWorld allMorphsBut: self do: [ :m | - (m isReallyVisible - and: [ m isLocked not - and: [(m displayFullBounds intersects: myRect) - and: [(m ~= self) - and: [(#(HaloMorph HaloHandleMorph) statePointsTo: m class name) not]]]]) - ifTrue: [ strm nextPut: m ]]].! ! -!MovableMorph methodsFor: 'accessing' stamp: 'jmv 7/8/2021 19:01:42' prior: 50559682 overrides: 50559666! - location: aGeometryTransformation - location _ aGeometryTransformation. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/13/2021 09:43:07' prior: 50571008! - doRot: evt with: rotHandle - "Update the rotation of my target if it is rotatable." - - | radians prevLocation | - evt hand obtainHalo: self. - radians _ (evt eventPosition - target referencePosition) theta + angleOffset. - radians _ radians detentBy: 0.05 atMultiplesOf: Float pi / 4 snap: false. - rotHandle color: (radians = 0.0 - ifTrue: [`Color lightBlue`] - ifFalse: [`Color blue`]). - rotHandle submorphsDo: [ :m | - m color: rotHandle color makeForegroundColor]. - prevLocation _ target location. - target location: (prevLocation composedWith: ( - AffineTransformation withRadians: radians-prevLocation radians around: target rotationCenter)). - rotHandle morphPositionInWorld: evt eventPosition - (rotHandle morphExtent // 2). - self redrawNeeded.! ! -!InnerTextMorph methodsFor: 'accessing' stamp: 'jmv 7/13/2021 09:48:52' prior: 50433829! - crAction: aBlock - "Sets the action to perform when user presses key" - self setProperty: #crAction toValue: aBlock! ! -!InnerTextMorph methodsFor: 'accessing' stamp: 'jmv 7/13/2021 09:49:29' prior: 50432749! - escAction: aBlock - "Sets the action to perform when user presses key" - - self setProperty: #escAction toValue: aBlock.! ! - -KernelMorph removeSelector: #referencePosition! - -!methodRemoval: KernelMorph #referencePosition stamp: 'Install-4661-RotationCenter-JuanVuletich-2021Jul13-09h35m-jmv.002.cs.st 7/20/2021 16:51:48'! -referencePosition - "Return the current reference position of the receiver" - "a rather ugly way to say #center . At least, we avoid false polymorphism" - "remove some day" - self flag: #jmvVer2. - self displayBounds ifNotNil: [ :r | r center ]. - ^ self morphExtentInWorld // 2 + self morphPositionInWorld! - -MovableMorph removeSelector: #referencePosition:! - -!methodRemoval: MovableMorph #referencePosition: stamp: 'Install-4661-RotationCenter-JuanVuletich-2021Jul13-09h35m-jmv.002.cs.st 7/20/2021 16:51:48'! -referencePosition: aPoint - "a rather ugly way to say #center: . Just for consistency with #referencePosition" - "remove some day" - self flag: #jmvVer2. - self morphPositionInWorld: aPoint - (self morphExtentInWorld // 2)! - -Morph removeSelector: #knowsContour! - -!methodRemoval: Morph #knowsContour stamp: 'Install-4661-RotationCenter-JuanVuletich-2021Jul13-09h35m-jmv.002.cs.st 7/20/2021 16:51:48'! -knowsContour - "True if a morph requires the Canvas to update a #morphContour property on us. - Any subclass might answer true, if it #requiresVectorCanvas. - By default, any top morph that is drawn by VectorCanvas." - - ^self requiresVectorCanvas and: [ self isOwnedByWorldOrHand ]! - -Morph removeSelector: #rotationCenter! - -Morph removeSelector: #referencePosition! - -!methodRemoval: Morph #referencePosition stamp: 'Install-4661-RotationCenter-JuanVuletich-2021Jul13-09h35m-jmv.002.cs.st 7/20/2021 16:51:48'! -referencePosition - "Return the current reference position of the receiver" - "a rather ugly way to say #center . At least, we avoid false polymorphism" - "remove some day" - - self displayBounds ifNotNil: [ :r | r center ]. - ^0@0! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4661-RotationCenter-JuanVuletich-2021Jul13-09h35m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4661] on 13 July 2021 at 11:16:45 am'! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/13/2021 11:16:25' prior: 50571032! - doScale: evt with: scaleHandle - "Update the scale of my target if it is scalable." - - | scale | -"MUST fix resize / rescale / rotation of embedded morphs!!!!!!" - evt hand obtainHalo: self. - scale _ (evt eventPosition - target morphPositionInWorld) rho * scaleOffset. - scale = 1.0 - ifTrue: [scaleHandle color: `Color lightBlue`] - ifFalse: [scaleHandle color: `Color blue`]. - scaleHandle submorphsDo: - [:m | m color: scaleHandle color makeForegroundColor]. - target scale: scale. - scaleHandle morphPositionInWorld: evt eventPosition - (scaleHandle morphExtent // 2). - self redrawNeeded.! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/13/2021 11:16:31' prior: 50558970! - startScale: evt with: scaleHandle - "Initialize scale of my target if it is scalable." - - evt hand obtainHalo: self. "Make sure the event's hand correlates with the receiver" - - self removeAllHandlesBut: scaleHandle. "remove all other handles" - scaleOffset _ target scale / (evt eventPosition - target morphPositionInWorld) rho.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4662-ScalingFix-JuanVuletich-2021Jul13-11h16m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4662] on 13 July 2021 at 11:29:20 am'! -!Morph methodsFor: 'drawing' stamp: 'jmv 7/13/2021 10:20:27' prior: 50500300! - icon - ^ (self imageForm: 16@16 depth: 32) - ifNil: [ Theme current morphsIcon ]! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 7/13/2021 11:25:11' prior: 50566171! - imageForm: extent depth: depth - - ^(self imageForm: depth) magnifyTo: extent! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 7/13/2021 11:28:28' prior: 50516962! - addButtonFor: aMorph - - | button | - aMorph == self ifFalse: [ - button _ HoverableButtonMorph - model: aMorph - stateGetter: nil - action: #endPreviewAndToggleCollapseOrShow - onMouseEnterSend: #beginPreview - onMouseLeaveSend: #endPreview. - (aMorph is: #SystemWindow) ifTrue: [ - button - secondaryActionSelector: #offerWindowMenu ]. - button - color: self color; - icon: (aMorph imageForm: self defaultHeight*5//4 @ self defaultHeight depth: 32); - setBalloonText: #label. - viewBox - addMorph: button - fixedWidth: self defaultHeight ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4663-TaskbarButtonTweak-JuanVuletich-2021Jul13-11h23m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4663] on 13 July 2021 at 4:16:54 pm'! - -Object subclass: #SHST80RangeType - instanceVariableNames: 'sourceCode messageRange receiverRange messageRangeType receiverRangeType classOrMetaClass lastRange ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -!classDefinition: #SHST80RangeType category: #'Tools-Syntax Highlighting' stamp: 'Install-4664-ShoutRangeTypeFix-JuanVuletich-2021Jul13-16h10m-jmv.001.cs.st 7/20/2021 16:51:48'! -Object subclass: #SHST80RangeType - instanceVariableNames: 'sourceCode messageRange receiverRange messageRangeType receiverRangeType classOrMetaClass lastRange' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'jmv 7/13/2021 16:11:41' prior: 50566967! - receiverAsNumber - - "if the user typed 1xe for example, asNumber will throw an exception because it is not a valid number - even though the SHParser recognized it as such. I return nil because it is not really a number. - Thank you Luciano for reporting the bug - Hernan" - ^[ (self sourceCodeIn: lastRange) asNumber ] - on: Error - do: [ :anError | anError return: nil ]! ! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'jmv 7/13/2021 16:11:41' prior: 50545484! - receiverAsSymbol - - ^ (self sourceCodeIn: lastRange) asSymbol! ! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'jmv 7/13/2021 16:11:41' prior: 50545503! - typeWhenSendToClassVar - - | classVarValue | - - ^ classOrMetaClass - ifNil: [ messageRangeType ] - ifNotNil: [ - classVarValue := classOrMetaClass theNonMetaClass classVarValueOf: (self sourceCodeIn: lastRange). - self typeWhenSendTo: classVarValue ]! ! -!SHST80RangeType methodsFor: 'range type' stamp: 'jmv 7/13/2021 16:11:41' prior: 50545553! - lastRange: aRange - - lastRange := aRange ! ! -!SHST80RangeType methodsFor: 'range type' stamp: 'jmv 7/13/2021 16:15:55' prior: 50545557! - ofCurrentRangeOrMessageSendIn: aPotentialMessageRange - - | potentialMessageRangeType lastRangeType | - - potentialMessageRangeType := aPotentialMessageRange rangeType. - - potentialMessageRangeType = #unary ifFalse: [ ^potentialMessageRangeType ]. - lastRange ifNil: [ ^potentialMessageRangeType ]. - - messageRange := aPotentialMessageRange. - messageRangeType := potentialMessageRangeType. - lastRangeType := lastRange rangeType. - - lastRangeType = #number ifTrue: [ ^self typeWhenSendToNumber ]. - lastRangeType = #string ifTrue: [ ^self typeWhenSendToInstanceOf: String ]. - lastRangeType = #symbol ifTrue: [ ^self typeWhenSendToInstanceOf: Symbol ]. - lastRangeType = #arrayEnd ifTrue: [ ^self typeWhenSendToInstanceOf: Array ]. - lastRangeType = #rightBrace ifTrue: [ ^self typeWhenSendToInstanceOf: Array ]. - lastRangeType = #blockEnd ifTrue: [ ^self typeWhenSendToInstanceOf: BlockClosure ]. - lastRangeType = #character ifTrue: [ ^self typeWhenSendToInstanceOf: Character ]. - lastRangeType = #nil ifTrue: [ ^self typeWhenSendToInstanceOf: nil class ]. - lastRangeType = #true ifTrue: [ ^self typeWhenSendToInstanceOf: true class ]. - lastRangeType = #false ifTrue: [ ^self typeWhenSendToInstanceOf: false class ]. - lastRangeType = #self ifTrue: [^self typeWhenSendToSelf ]. - lastRangeType = #super ifTrue: [^self typeWhenSendToSuper ]. - lastRangeType = #globalVar ifTrue: [^self typeWhenSendToGlobal ]. - lastRangeType = #classVar ifTrue: [^self typeWhenSendToClassVar ]. - - ^messageRangeType.! ! - -Object subclass: #SHST80RangeType - instanceVariableNames: 'sourceCode messageRange messageRangeType lastRange classOrMetaClass' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -!classDefinition: #SHST80RangeType category: #'Tools-Syntax Highlighting' stamp: 'Install-4664-ShoutRangeTypeFix-JuanVuletich-2021Jul13-16h10m-jmv.001.cs.st 7/20/2021 16:51:48'! -Object subclass: #SHST80RangeType - instanceVariableNames: 'sourceCode messageRange messageRangeType lastRange classOrMetaClass' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4664-ShoutRangeTypeFix-JuanVuletich-2021Jul13-16h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4664] on 13 July 2021 at 4:40:17 pm'! -!FileSystemEntry methodsFor: 'testing' stamp: 'jmv 7/13/2021 16:40:01'! - updateExists - - self subclassResponsibility! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4665-cleanup-JuanVuletich-2021Jul13-16h39m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4665] on 15 July 2021 at 10:48:24 am'! -!Debugger methodsFor: 'context stack menu' stamp: 'HAW 7/15/2021 10:09:27'! - addCategoriesOf: aClass to: categories separatingWith: lines - - | classCategories reject | - - classCategories := aClass methodCategoriesAsSortedCollection. - reject := classCategories asSet. - aClass isMeta ifTrue: [ - categories add: Categorizer instanceCreation. - classCategories remove: Categorizer instanceCreation ifAbsent: []. - reject add: Categorizer instanceCreation]. - reject - add: ClassOrganizer nullCategory; - add: ClassOrganizer default. - categories addAll: classCategories. - - aClass allSuperclasses do: [ :superclass | | superclassCategories | - superclassCategories := superclass methodCategoriesAsSortedCollection reject: [ :cat | reject includes: cat]. - superclassCategories isEmpty ifFalse: [ - lines add: categories size. - categories addAll: superclassCategories. - reject addAll: superclassCategories]]. - -! ! -!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'HAW 7/15/2021 09:58:10'! - methodCategories - - | categories | - - categories := OrderedCollection withAll: self organization categories. - categories remove: ClassOrganizer nullCategory asSymbol ifAbsent: nil. - - ^categories ! ! -!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'HAW 7/15/2021 09:54:49'! - methodCategoriesAsSortedCollection - - ^self methodCategories asSortedCollection: [ :leftCategory :rightCategory | leftCategory asLowercase < rightCategory asLowercase ] -! ! -!Debugger methodsFor: 'context stack menu' stamp: 'HAW 7/15/2021 10:09:20' prior: 50514249! - askForCategoryIn: aClass default: aDefaultCategory - - | categories index category lines | - - categories := OrderedCollection with: 'new ...'. - lines := OrderedCollection with: 1. - self addCategoriesOf: aClass to: categories separatingWith: lines. - - index := (PopUpMenu labelArray: categories lines: lines) - startUpWithCaption: 'Please provide a good category for the new method!!'. - index = 0 ifTrue: [^ aDefaultCategory]. - category := index = 1 - ifTrue: [self request: 'Enter category name:' initialAnswer: ''] - ifFalse: [categories at: index]. - - ^ category isEmpty ifTrue: [aDefaultCategory] ifFalse: [category]! ! -!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'HAW 7/15/2021 09:59:16' prior: 50476506! - allMethodCategoriesIntegratedThrough: mostGenericClass - "Answer a list of all the method categories of the receiver and all its superclasses, up through mostGenericClass" - - | aColl | - aColl _ OrderedCollection new. - self withAllSuperclasses do: [ :aClass | - (aClass includesBehavior: mostGenericClass) - ifTrue: [ aColl addAll: aClass methodCategories ]]. - - ^ aColl asSet asSortedCollection: [ :a :b | a asLowercase < b asLowercase ] - -"ColorTileMorph allMethodCategoriesIntegratedThrough: TileMorph"! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4666-CuisCore-JoaquinSinguerHernanWilkinson-2021Jul15-09h37m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4666] on 15 July 2021 at 2:30:43 pm'! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/15/2021 14:30:32' prior: 50570986! - doResize: evt with: resizeHandle - "Called while the mouse is down in the grow handle" - - | newExtent | - evt hand obtainHalo: self. - newExtent _ (evt eventPosition - target morphPositionInWorld) - positionOffset. - (newExtent x = 0 or: [newExtent y = 0]) ifTrue: [^ self]. - target morphExtentInWorld: newExtent. - resizeHandle morphPositionInWorld: evt eventPosition - (resizeHandle morphExtent // 2). - self redrawNeeded.! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/15/2021 14:28:28' prior: 50576214! - doScale: evt with: scaleHandle - "Update the scale of my target if it is scalable." - - | scale | - evt hand obtainHalo: self. - scale _ (evt eventPosition - target morphPositionInWorld) rho * scaleOffset. - scale = 1.0 - ifTrue: [scaleHandle color: `Color lightBlue`] - ifFalse: [scaleHandle color: `Color blue`]. - scaleHandle submorphsDo: - [:m | m color: scaleHandle color makeForegroundColor]. - target scale: scale. - scaleHandle morphPositionInWorld: evt eventPosition - (scaleHandle morphExtent // 2). - self redrawNeeded.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4667-Halo-cleanup-JuanVuletich-2021Jul15-14h28m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4666] on 15 July 2021 at 3:09:36 pm'! -!TextEditor methodsFor: 'attributes' stamp: 'jmv 7/15/2021 15:05:21'! - offerFontStyleMenu - "This is a user command, and generates undo" - - | emphases menuStrings entries reply code startIndex attribute | - startIndex _ self startIndex. - code _ model actualContents emphasisAt: startIndex. - emphases _ #(bold italic underlined struckThrough superscript subscript withST80Glyphs). - menuStrings _ Array streamContents: [ :strm | - strm nextPut:(code isZero ifTrue: [''] ifFalse: ['']), 'normal'. - emphases do: [ :emph | - strm nextPut: - ((code anyMask: (TextEmphasis perform: emph) emphasisCode) - ifTrue: [''] ifFalse: ['']), - emph asString ]]. - entries _ `#(normal)`, emphases. - reply _ (SelectionMenu labelList: menuStrings lines: #(1) selections: entries) startUpMenu. - reply ifNotNil: [ - attribute _ TextEmphasis perform: reply. - ((menuStrings at: (entries indexOf: reply)) beginsWith: '') - ifTrue: [ self unapplyAttributes: {attribute} ] - ifFalse: [ self applyAttribute: attribute ]]. - morph updateFromTextComposition.! ! -!TextEditor methodsFor: 'menu' stamp: 'jmv 7/15/2021 15:03:50' prior: 50474136! - addStyleMenuSectionTo: aMenu - "Adds to the given menu text styiling related operations" - - aMenu - addItemsFromDictionaries: - `{ - { - #label -> 'Toggle WordWrap'. - #selector -> #wrapOnOff. - #icon -> #genericTextIcon - } asDictionary. - { - #label -> 'Set Font... (k)'. - #selector -> #offerFontMenu. - #icon -> #preferencesDesktopFontIcon - } asDictionary. - { - #label -> 'Clear Font'. - #selector -> #clearFont. - #icon -> #newIcon - } asDictionary. - { - #label -> 'Set Font Style'. - #selector -> #offerFontStyleMenu. - #icon -> #preferencesDesktopFontIcon - } asDictionary. - { - #label -> 'Set Default Font...'. - #selector -> #offerDefaultFontMenu. - #icon -> #fontXGenericIcon - } asDictionary. - { - #label -> 'Set Alignment...'. - #selector -> #chooseAlignment. - #icon -> #formatJustifyLeftIcon - } asDictionary. - }`. - ^aMenu! ! -!Preferences class methodsFor: 'halos' stamp: 'jmv 7/15/2021 15:07:49' prior: 50558830! - iconicHaloSpecifications - "Answer an array that characterizes the locations, colors, icons, and selectors of the halo handles that may be used in the iconic halo scheme" - - " - Preferences resetHaloSpecifications - " - -^ #( - "selector horiz vert color info icon key balloon help - --------- ------ ----------- -------------------------- -------------------------- ---------------" - (addCollapseHandle: left topCenter (tan) haloCollapseIcon 'Collapse') - (addDebugHandle: right topCenter (orange) haloDebugIcon 'Debug') - (addDismissHandle: left top (red) haloDismissIcon 'Remove') - (addRotateHandle: left bottom (blue) haloRotateIcon 'Rotate') - (addMenuHandle: leftCenter top (blue lighter) haloMenuIcon 'Menu') - (addGrabHandle: center top (black) haloGrabIcon 'Pick up') - (addDragHandle: rightCenter top (brown) haloDragIcon 'Move') - (addDupHandle: right top (green) haloDuplicateIcon 'Duplicate') - (addHelpHandle: center bottom (lightBlue) haloHelpIcon 'Help') - (addResizeHandle: right bottom (yellow) haloResizeIcon 'Change size') - (addScaleHandle: right bottom (blue) haloScaleIcon 'Change scale') - "FIXME - Currently non-functional... - (addRecolorHandle: right bottomCenter (magenta darker) haloColorIcon 'Change color') - " -)! ! - -InnerTextMorph removeSelector: #chooseFont! - -!methodRemoval: InnerTextMorph #chooseFont stamp: 'Install-4668-FontStyleMenu-JuanVuletich-2021Jul15-14h30m-jmv.001.cs.st 7/20/2021 16:51:48'! -chooseFont - self editor offerFontMenu. - self updateFromTextComposition.! - -InnerTextMorph removeSelector: #chooseEmphasisOrAlignment! - -!methodRemoval: InnerTextMorph #chooseEmphasisOrAlignment stamp: 'Install-4668-FontStyleMenu-JuanVuletich-2021Jul15-14h30m-jmv.001.cs.st 7/20/2021 16:51:48'! -chooseEmphasisOrAlignment - self editor changeEmphasisOrAlignment. - self updateFromTextComposition! - -InnerTextMorph removeSelector: #chooseEmphasis! - -HaloMorph removeSelector: #chooseEmphasisOrAlignment! - -!methodRemoval: HaloMorph #chooseEmphasisOrAlignment stamp: 'Install-4668-FontStyleMenu-JuanVuletich-2021Jul15-14h30m-jmv.001.cs.st 7/20/2021 16:51:48'! -chooseEmphasisOrAlignment - target chooseEmphasisOrAlignment! - -HaloMorph removeSelector: #chooseFont! - -!methodRemoval: HaloMorph #chooseFont stamp: 'Install-4668-FontStyleMenu-JuanVuletich-2021Jul15-14h30m-jmv.001.cs.st 7/20/2021 16:51:48'! -chooseFont - target chooseFont! - -HaloMorph removeSelector: #addFontEmphHandle:! - -!methodRemoval: HaloMorph #addFontEmphHandle: stamp: 'Install-4668-FontStyleMenu-JuanVuletich-2021Jul15-14h30m-jmv.001.cs.st 7/20/2021 16:51:48'! -addFontEmphHandle: haloSpec - - (target is: #InnerTextMorph) ifTrue: [ - (self addHandle: haloSpec) mouseDownSelector: #chooseEmphasisOrAlignment ]! - -HaloMorph removeSelector: #addFontSizeHandle:! - -!methodRemoval: HaloMorph #addFontSizeHandle: stamp: 'Install-4668-FontStyleMenu-JuanVuletich-2021Jul15-14h30m-jmv.001.cs.st 7/20/2021 16:51:48'! -addFontSizeHandle: haloSpec - - (target is: #InnerTextMorph) ifTrue: [ - (self addHandle: haloSpec) mouseDownSelector: #chooseFont]! - -TextEditor removeSelector: #changeEmphasis! - -TextEditor removeSelector: #changeEmphasisOrAlignment! - -!methodRemoval: TextEditor #changeEmphasisOrAlignment stamp: 'Install-4668-FontStyleMenu-JuanVuletich-2021Jul15-14h30m-jmv.001.cs.st 7/20/2021 16:51:48'! -changeEmphasisOrAlignment - "This is a user command, and generates undo" - - | menuStrings aList reply code align menuList startIndex attribute | - startIndex _ self startIndex. - aList _ #(normal bold italic underlined struckThrough leftFlush centered rightFlush justified). - align _ model actualContents alignmentAt: startIndex. - code _ model actualContents emphasisAt: startIndex. - menuList _ WriteStream on: Array new. - menuList nextPut: (code isZero ifTrue:[''] ifFalse:['']), 'normal'. - menuList nextPutAll: (#(bold italic underlined struckThrough superscript subscript withST80Glyphs) collect: [ :emph | - (code anyMask: (TextEmphasis perform: emph) emphasisCode) - ifTrue: [ '', emph asString ] - ifFalse: [ '', emph asString ]]). - menuList nextPutAll: (#(leftFlush centered rightFlush justified) withIndexCollect: [ :type :i | - align = (i-1) - ifTrue: [ '', type asString ] - ifFalse: [ '', type asString ]]). - menuStrings _ menuList contents. - aList _ #(normal bold italic underlined struckThrough superscript subscript withST80Glyphs leftFlush centered rightFlush justified). - reply _ (SelectionMenu labelList: menuStrings lines: #(1 8) selections: aList) startUpMenu. - reply ifNotNil: [ - (#(leftFlush centered rightFlush justified) includes: reply) - ifTrue: [ - attribute _ TextAlignment perform: reply] - ifFalse: [ - attribute _ TextEmphasis perform: reply]. - ((menuStrings at: (aList indexOf: reply)) beginsWith: '') - ifTrue: [ self unapplyAttributes: {attribute} ] - ifFalse: [ self applyAttribute: attribute ]]. - ^ true! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4668-FontStyleMenu-JuanVuletich-2021Jul15-14h30m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4666] on 15 July 2021 at 3:29:59 pm'! -!TextEditor methodsFor: 'attributes' stamp: 'jmv 7/15/2021 15:23:41' prior: 50357866! - offerColorMenu - "Present a menu of available colors, and if one is chosen, apply it to the current selection." - "This is a user command, and generates undo" - - | attribute colors index thisSel | - thisSel _ self selection. - colors _ #(#black #magenta #red #yellow #green #blue #cyan #white ). - index _ (PopUpMenu - labelArray: colors , #('choose color...' ) - lines: (Array with: colors size + 1)) startUpMenu. - index = 0 ifTrue: [ ^ true ]. - index <= colors size - ifTrue: [ attribute _ TextColor color: (Color perform: (colors at: index)) ] - ifFalse: [ - index _ index - colors size - 1. - "Re-number!!!!!!" - index = 0 ifTrue: [ attribute _ self chooseColor ]. - thisSel ifNil: [ ^ true ]]. - attribute ifNotNil: [ self applyAttribute: attribute ]. - morph updateFromTextComposition. - ^ true.! ! -!TextEditor methodsFor: 'menu' stamp: 'jmv 7/15/2021 15:29:16' prior: 50576613! - addStyleMenuSectionTo: aMenu - "Adds to the given menu text styiling related operations" - - aMenu - addItemsFromDictionaries: - `{ - { - #label -> 'Toggle WordWrap'. - #selector -> #wrapOnOff. - #icon -> #genericTextIcon - } asDictionary. - { - #label -> 'Set Font... (k)'. - #selector -> #offerFontMenu. - #icon -> #preferencesDesktopFontIcon - } asDictionary. - { - #label -> 'Clear Font'. - #selector -> #clearFont. - #icon -> #newIcon - } asDictionary. - { - #label -> 'Set Font Style'. - #selector -> #offerFontStyleMenu. - #icon -> #preferencesDesktopFontIcon - } asDictionary. - { - #label -> 'Set Text Color'. - #selector -> #offerColorMenu. - #icon -> #graphicsIcon - } asDictionary. - { - #label -> 'Set Default Font...'. - #selector -> #offerDefaultFontMenu. - #icon -> #fontXGenericIcon - } asDictionary. - { - #label -> 'Set Alignment...'. - #selector -> #chooseAlignment. - #icon -> #formatJustifyLeftIcon - } asDictionary. - }`. - ^aMenu! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4669-TextColorMenu-JuanVuletich-2021Jul15-15h09m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4669] on 15 July 2021 at 4:20:55 pm'! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 7/15/2021 16:20:29'! - okayToScaleEasily - "Answer whether it is appropriate for a scale handle to be shown for the receiver." - - ^ self hasOwnLocation and: [MorphicCanvas activeSubclass ~~ BitBltCanvas ]! ! -!HaloMorph methodsFor: 'handles' stamp: 'jmv 7/15/2021 15:35:39'! - addExploreHandle: handleSpec - - Preferences debugHaloHandle ifTrue: [ - (self addHandle: handleSpec) - mouseDownSelector: #doExplore:with: ] -! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/15/2021 15:41:53'! - doExplore: evt with: aHandle - - evt hand obtainHalo: self. - ^ target explore! ! -!Preferences class methodsFor: 'halos' stamp: 'jmv 7/15/2021 15:35:00' prior: 50576647! - iconicHaloSpecifications - "Answer an array that characterizes the locations, colors, icons, and selectors of the halo handles that may be used in the iconic halo scheme" - - " - Preferences resetHaloSpecifications - " - -^ #( - "selector horiz vert color info icon key balloon help - --------- ------ ------- --------- ------------ ----------" - (addDismissHandle: left top (red) haloDismissIcon 'Remove') - (addMenuHandle: leftCenter top (blue lighter) haloMenuIcon 'Menu') - (addGrabHandle: center top (black) haloGrabIcon 'Pick up') - (addDragHandle: rightCenter top (brown) haloDragIcon 'Move') - (addDupHandle: right top (green) haloDuplicateIcon 'Duplicate') - - (addExploreHandle: left topCenter (orange) haloDebugIcon 'Explore') - (addDebugHandle: right topCenter (orange) haloDebugIcon 'Debug') - (addCollapseHandle: left center (tan) haloCollapseIcon 'Collapse') - (addScaleHandle: right center (blue) haloScaleIcon 'Change scale') - - (addRotateHandle: left bottom (blue) haloRotateIcon 'Rotate') - (addHelpHandle: center bottom (lightBlue) haloHelpIcon 'Help') - (addResizeHandle: right bottom (yellow) haloResizeIcon 'Change size') - - "FIXME - Currently non-functional... - (addRecolorHandle: right bottomCenter (magenta darker) haloColorIcon 'Change color') - " -)! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 7/15/2021 15:50:50' prior: 16875762! - okayToResizeEasily - "Answer whether it is appropriate to have the receiver be easily resized by the user from the halo" - - ^ self hasVariableExtent! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 7/15/2021 16:20:37' prior: 16875779! - okayToRotateEasily - "Answer whether it is appropriate for a rotation handle to be shown for the receiver." - - ^ self hasOwnLocation and: [MorphicCanvas activeSubclass ~~ BitBltCanvas ]! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 7/15/2021 15:56:06' prior: 50558343! - wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph - "Answer whether the receiver would like to offer the halo handle with the given selector (e.g. #addCollapseHandle:)" - - (#(addRecolorHandle:) statePointsTo: aSelector) - ifTrue: ["FIXME - hack to disable for non-functional halo items" - ^ false]. - - Preferences selectiveHalos ifFalse: [ - ^true ]. - - (#(#addDismissHandle: ) includes: aSelector) - ifTrue: [ ^ self resistsRemoval not ]. - (#(#addDragHandle: ) includes: aSelector) - ifTrue: [ ^ self okayToBrownDragEasily ]. - (#(#addResizeHandle: ) includes: aSelector) - ifTrue: [ ^ self okayToResizeEasily | self okayToScaleEasily ]. - (#(#addRotateHandle: ) includes: aSelector) - ifTrue: [ ^ self okayToRotateEasily ]. - (#(#addScaleHandle: ) includes: aSelector) - ifTrue: [ ^ self okayToScaleEasily ]. - (#(#addRecolorHandle: ) includes: aSelector) - ifTrue: [ ^ self wantsRecolorHandle ]. - ^ true! ! -!HaloMorph methodsFor: 'handles' stamp: 'jmv 7/15/2021 15:57:34' prior: 50558905! - addResizeHandle: haloSpec - - target okayToResizeEasily ifTrue: [ - ^(self addHandle: haloSpec) - mouseDownSelector: #startResize:with:; - mouseMoveSelector: #doResize:with: ]. - - target okayToScaleEasily ifTrue: [ - ^(self addHandle: haloSpec) - mouseDownSelector: #startScale:with:; - mouseMoveSelector: #doScale:with: ].! ! -!HaloMorph methodsFor: 'handles' stamp: 'jmv 7/15/2021 15:52:54' prior: 50558914! - addRotateHandle: haloSpec - - (self addHandle: haloSpec) - mouseDownSelector: #startRot:with:; - mouseMoveSelector: #doRot:with:! ! -!HaloMorph methodsFor: 'handles' stamp: 'jmv 7/15/2021 15:54:51' prior: 50558924! - addScaleHandle: haloSpec - - (self addHandle: haloSpec) - mouseDownSelector: #startScale:with:; - mouseMoveSelector: #doScale:with:! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/15/2021 15:41:47' prior: 16850958! - doDebug: evt with: menuHandle - "Ask hand to invoke the a debugging menu for my inner target. If shift key is down, immediately put up an inspector on the inner target" - - | menu | - evt hand obtainHalo: self. - evt shiftPressed ifTrue: [ - ^ target inspect]. - - menu _ target buildDebugMenu: evt hand. - menu addTitle: (target printStringLimitedTo: 40). - menu popUpInWorld: self world! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/15/2021 15:42:00' prior: 16851019! - doMenu: evt with: menuHandle - "Ask hand to invoke the halo menu for my inner target." - - | menu | - evt hand obtainHalo: self. - menu _ target buildHandleMenu: evt hand. - target addTitleForHaloMenu: menu. - menu popUpInWorld: self world. -! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - Preferences resetHaloSpecifications! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4670-ExploreScaleAndRotateHalos-JuanVuletich-2021Jul15-16h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4670] on 16 July 2021 at 6:24:47 pm'! -!Morph methodsFor: 'accessing - properties' stamp: 'jmv 7/16/2021 17:42:29'! - valueOfProperty: aSymbol ifAbsentPut: aBlock - "if the receiver possesses a property of the given name, answer - its value. If not then evaluate aBlock to obtain the value to be - stored and answered." - - ^ self valueOfProperty: aSymbol ifAbsent: [ - self setProperty: aSymbol toValue: aBlock value ]! ! -!TaskbarMorph methodsFor: 'initialization' stamp: 'jmv 7/16/2021 16:57:24' prior: 50453853! - defaultHeight - - ^ (Preferences windowTitleFont lineSpacing * 2 * self scale) asInteger! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 7/16/2021 17:44:19' prior: 50576267! - addButtonFor: aMorph - - | button taskbarButtonIcon | - aMorph == self ifFalse: [ - button _ HoverableButtonMorph - model: aMorph - stateGetter: nil - action: #endPreviewAndToggleCollapseOrShow - onMouseEnterSend: #beginPreview - onMouseLeaveSend: #endPreview. - (aMorph is: #SystemWindow) ifTrue: [ - button - secondaryActionSelector: #offerWindowMenu ]. - taskbarButtonIcon _ aMorph - valueOfProperty: #taskbarButtonIcon - ifAbsentPut: [aMorph imageForm: self defaultHeight*5//4 @ self defaultHeight depth: 32]. - button - color: self color; - icon: taskbarButtonIcon; - setBalloonText: #label. - viewBox - addMorph: button - fixedWidth: self defaultHeight ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4671-TaskbarButtonOptimization-JuanVuletich-2021Jul16-18h23m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4670] on 16 July 2021 at 6:27:13 pm'! -!Morph methodsFor: 'testing' stamp: 'jmv 7/16/2021 17:50:02'! - isIncludedInTaskbar - "Answer true a button for us should be added to any TaskbarMorph." - - ^ true! ! -!HandMorph methodsFor: 'testing' stamp: 'jmv 7/16/2021 18:19:02' overrides: 50577132! - isIncludedInTaskbar - "Answer true a button for us should be added to any TaskbarMorph." - - ^ false! ! -!HaloHandleMorph methodsFor: 'testing' stamp: 'jmv 7/16/2021 18:18:32' overrides: 50577132! - isIncludedInTaskbar - "Answer true a button for us should be added to any TaskbarMorph." - - ^ false! ! -!HaloMorph methodsFor: 'testing' stamp: 'jmv 7/16/2021 18:18:39' overrides: 50577132! - isIncludedInTaskbar - "Answer true a button for us should be added to any TaskbarMorph." - - ^ false! ! -!HoverHelpMorph methodsFor: 'testing' stamp: 'jmv 7/16/2021 18:19:17' overrides: 50577132! -isIncludedInTaskbar - "Answer true a button for us should be added to any TaskbarMorph." - - ^ false! ! -!MenuMorph methodsFor: 'testing' stamp: 'jmv 7/16/2021 18:20:02' overrides: 50577132! - isIncludedInTaskbar - "Answer true a button for us should be added to any TaskbarMorph." - - ^ false! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 7/16/2021 18:17:58' prior: 50432338! - wasOpened: aMorph - "aMorph was added to the world. Add button for aMorph if appropriate." - - aMorph isIncludedInTaskbar ifTrue: [ - self addButtonFor: aMorph ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4672-HalosHoverAndMenusNotInTaskbar-JuanVuletich-2021Jul16-18h24m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4672] on 16 July 2021 at 6:35:31 pm'! -!Morph methodsFor: 'drawing' stamp: 'jmv 7/16/2021 18:35:07' prior: 50536715! - imageForm: depth - - ^self imageForm: nil depth: depth.! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 7/16/2021 18:34:40' prior: 50576261! - imageForm: extentOrNil depth: depth - - | extent answer auxCanvas | - extent _ self morphExtent. - extentOrNil ifNotNil: [ extent _ extent min: extentOrNil * 4 ]. - auxCanvas _ BitBltCanvas depth: depth over: (self morphPosition floor extent: extent ceiling). - auxCanvas fullDraw: self. - answer _ auxCanvas form divideByAlpha. - extentOrNil ifNotNil: [ answer _ answer magnifyTo: extent ]. - ^answer.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4673-imageForm-JuanVuletich-2021Jul16-18h34m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4673] on 16 July 2021 at 7:47:04 pm'! -!WidgetMorph methodsFor: 'geometry testing' stamp: 'jmv 7/16/2021 19:44:54' prior: 50546054 overrides: 50532139! - requiresVectorCanvas - "True if we use VectorCanvas protocol, or we are rotated or zoomed. - If false, we occupy a Rectangle in local coordinates. Allows for many optimizations to be done. - Note: If answer is false, but some owner requiresVectorCanvas, then we also do. Canvas takes care of this. - Note: SystemWindow answers false, but implements #addPossiblyUncoveredAreasIn:to: to take care of rounded corners." - - ^location isPureTranslation not or: [ owner notNil and: [ owner requiresVectorCanvas ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4674-requiresVectorCanvas-fix-JuanVuletich-2021Jul16-19h44m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4674] on 17 July 2021 at 8:34:32 pm'! -!BitBlt methodsFor: 'private' stamp: 'jmv 7/17/2021 20:31:38' prior: 16785963! - copyBitsAgain - "Primitive. See BitBlt|copyBits, also a Primitive. Essential. See Object - documentation whatIsAPrimitive." - - - '#copyBitsAgain failed. Requested BitBlt operation not performed.' print! ! -!BitBlt methodsFor: 'private' stamp: 'jmv 7/17/2021 20:34:09' prior: 16786050! - roundVariables - - | maxVal minVal | - 'BitBlt >> copyBits failed. Will retry with parameters rounded. Requested parameters are:' print. - {'dest, source, halftone, rule:' . destForm . sourceForm . halftoneForm . combinationRule } print. - {'dest, extent, source, clipOrigin, clipExtent'. destX@destY. width@height. sourceX@sourceY. clipX@clipY. clipWidth@clipHeight } print. - {'colorMap'. colorMap } print. - maxVal _ SmallInteger maxVal. - minVal _ SmallInteger minVal. - destX _ destX asInteger min: maxVal max: minVal. - destY _ destY asInteger min: maxVal max: minVal. - width _ width asInteger min: maxVal max: minVal. - height _ height asInteger min: maxVal max: minVal. - sourceX _ sourceX asInteger min: maxVal max: minVal. - sourceY _ sourceY asInteger min: maxVal max: minVal. - clipX _ clipX asInteger min: maxVal max: minVal. - clipY _ clipY asInteger min: maxVal max: minVal. - clipWidth _ clipWidth asInteger min: maxVal max: minVal. - clipHeight _ clipHeight asInteger min: maxVal max: minVal. -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4675-BitBltFailureEnh-JuanVuletich-2021Jul17-20h30m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4675] on 18 July 2021 at 7:06:37 pm'! - -PluggableMorph subclass: #ScrollBar - instanceVariableNames: 'slider value setValueSelector sliderShadow upButton downButton scrollDelta pageDelta interval nextPageDirection grabPosition' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #ScrollBar category: 'Morphic-Widgets' stamp: 'Install-4676-Scrollbar-is-a-widget-JuanVuletich-2021Jul18-19h05m-jmv.001.cs.st 7/20/2021 16:51:48'! -PluggableMorph subclass: #ScrollBar - instanceVariableNames: 'slider value setValueSelector sliderShadow upButton downButton scrollDelta pageDelta interval nextPageDirection grabPosition' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4676-Scrollbar-is-a-widget-JuanVuletich-2021Jul18-19h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4677] on 19 July 2021 at 10:14:17 am'! -!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jmv 7/18/2021 19:23:08' overrides: 16876446! - label - ^label! ! -!MorphicCanvas methodsFor: 'drawing-widgets' stamp: 'jmv 7/18/2021 19:39:56'! - drawButton3D: aPluggableButtonMorph - - | borderStyleSymbol c | - borderStyleSymbol _ aPluggableButtonMorph isPressed ifFalse: [ #raised ] ifTrue: [ #inset ]. - c _ aPluggableButtonMorph color. - aPluggableButtonMorph mouseIsOver ifTrue: [ c _ c lighter ]. - self - fillRectangle: aPluggableButtonMorph morphLocalBounds - color: c - borderWidth: aPluggableButtonMorph borderWidth - borderStyleSymbol: borderStyleSymbol - baseColorForBorder: c. - - self drawButtonRegularLabel: aPluggableButtonMorph.! ! -!MorphicCanvas methodsFor: 'drawing-widgets' stamp: 'jmv 7/18/2021 19:33:54'! - drawButton: aPluggableButtonMorph - aPluggableButtonMorph isRoundButton - ifTrue: [ - (self drawButtonIcon: aPluggableButtonMorph) ifFalse: [ - self drawButtonRoundGradient: aPluggableButtonMorph ]] - ifFalse: [ - self drawButton3D: aPluggableButtonMorph. - self drawButtonIcon: aPluggableButtonMorph ]! ! -!MorphicCanvas methodsFor: 'drawing-widgets' stamp: 'jmv 7/18/2021 19:34:08'! - drawButtonEmbossedLabel: aPluggableButtonMorph - - | availableW center colorForLabel f l labelMargin targetSize w x y label | - label _ aPluggableButtonMorph label. - label ifNotNil: [ - colorForLabel _ Theme current buttonLabel. - aPluggableButtonMorph isPressed - ifFalse: [ - aPluggableButtonMorph mouseIsOver - ifFalse: [ colorForLabel _ colorForLabel adjustSaturation: -0.10 brightness: 0.10 ]] - ifTrue: [ colorForLabel _ colorForLabel adjustSaturation: 0.0 brightness: -0.07 ]. - f _ aPluggableButtonMorph fontToUse. - center _ aPluggableButtonMorph morphExtent // 2. - labelMargin _ 3. - w _ f widthOfString: label. - availableW _ aPluggableButtonMorph morphExtent x - labelMargin - labelMargin. - availableW >= w - ifTrue: [ - l _ label ] - ifFalse: [ - x _ labelMargin. - targetSize _ label size * availableW // w. - l _ label squeezedTo: targetSize. - (f widthOfString: l) > availableW ifTrue: [ - targetSize _ targetSize - 1. - l _ label squeezedTo: targetSize ]]. - - w _ f widthOfString: l. - x _ center x - (w // 2). - y _ center y - (f lineSpacing // 2). - self - drawString: l - at: x@y - font: f - color: colorForLabel - embossed: true ]! ! -!MorphicCanvas methodsFor: 'drawing-widgets' stamp: 'jmv 7/18/2021 19:34:59'! - drawButtonIcon: aPluggableButtonMorph - "We assume that we are drawing a PluggableButtonMorph, - or some morph that conforms the required protocol. - Answer true if we were able to draw it." - - self subclassResponsibility! ! -!MorphicCanvas methodsFor: 'drawing-widgets' stamp: 'jmv 7/18/2021 19:34:29'! - drawButtonRegularLabel: aPluggableButtonMorph - - | w f center x y availableW l labelMargin label | - - label _ aPluggableButtonMorph label. - f _ aPluggableButtonMorph fontToUse. - center _ aPluggableButtonMorph morphExtent // 2. - - label ifNotNil: [ - labelMargin _ 4. - w _ f widthOfString: label. - availableW _ aPluggableButtonMorph morphExtent x - labelMargin - labelMargin - 1. - availableW >= w - ifTrue: [ - x _ center x - (w // 2). - l _ label ] - ifFalse: [ - x _ labelMargin. - l _ label squeezedTo: (label size * availableW / w) rounded ]. - y _ center y - (f lineSpacing // 2). - aPluggableButtonMorph isPressed ifTrue: [ - x _ x + 1. - y _ y + 1 ]. - self - drawString: l - at: x@y - font: f - color: Theme current buttonLabel ]! ! -!MorphicCanvas methodsFor: 'drawing-widgets' stamp: 'jmv 7/18/2021 19:34:36'! - drawButtonRoundGradient: aPluggableButtonMorph - | r colorForButton rect bottomFactor topFactor color | - color _ aPluggableButtonMorph color. - aPluggableButtonMorph isPressed - ifFalse: [ - topFactor _ Theme current buttonGradientTopFactor. - bottomFactor _ Theme current buttonGradientBottomFactor. - aPluggableButtonMorph mouseIsOver - ifTrue: [ - colorForButton _ Color h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ - colorForButton _ color ]] - ifTrue: [ - topFactor _ Theme current buttonGradientBottomFactor. - bottomFactor _ Theme current buttonGradientTopFactor. - colorForButton _ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - Theme current useButtonGradient - ifTrue: [ - rect _ aPluggableButtonMorph morphLocalBounds insetBy: `1@3`. - self - roundRect: rect - color: colorForButton - radius: r - gradientTop: topFactor - gradientBottom: bottomFactor - gradientHeight: Theme current buttonGradientHeight ] - ifFalse: [ - rect _ aPluggableButtonMorph morphLocalBounds insetBy: `1@3`. - self roundRect: rect color: colorForButton radius: r ] - ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawButtonEmbossedLabel: aPluggableButtonMorph ] - ifFalse: [ self drawButtonRegularLabel: aPluggableButtonMorph ].! ! -!BitBltCanvas methodsFor: 'drawing-widgets' stamp: 'jmv 7/18/2021 19:29:05' overrides: 50577395! - drawButtonIcon: aPluggableButtonMorph - "We assume that we are drawing a PluggableButtonMorph, - or some morph that conforms the required protocol. - Answer true if we were able to draw it." - - aPluggableButtonMorph magnifiedIcon ifNotNil: [ :theIcon | | iconColor | - iconColor _ aPluggableButtonMorph isPressed - ifTrue: [ `Color gray: 0.75` ] - ifFalse: [ - aPluggableButtonMorph mouseIsOver - ifTrue: [ `Color gray: 0.75` ] - ifFalse: [ `Color white` ]]. - self - image: theIcon - multipliedBy: iconColor - at: (aPluggableButtonMorph morphExtent - theIcon extent //2). - ^true ]. - ^false! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 7/18/2021 19:09:00' prior: 16888132 overrides: 50545911! - drawOn: aCanvas - - aCanvas drawButton: self! ! - -BitBltCanvas removeSelector: #drawButtonIconFromCurrentMorph! - -!methodRemoval: BitBltCanvas #drawButtonIconFromCurrentMorph stamp: 'Install-4677-buttonDrawingInCanvas-JuanVuletich-2021Jul19-10h09m-jmv.001.cs.st 7/20/2021 16:51:49'! -drawButtonIconFromCurrentMorph - "We assume that we are drawing a PluggableButtonMorph, - or some morph that conforms the required protocol. - Answer true if we were able to draw it." - - currentMorph magnifiedIcon ifNotNil: [ :theIcon | - self - image: theIcon - multipliedBy: currentMorph iconColor - at: (currentMorph morphExtent - theIcon extent //2). - ^true ]. - ^false! - -MorphicCanvas removeSelector: #drawButtonIconFromCurrentMorph! - -!methodRemoval: MorphicCanvas #drawButtonIconFromCurrentMorph stamp: 'Install-4677-buttonDrawingInCanvas-JuanVuletich-2021Jul19-10h09m-jmv.001.cs.st 7/20/2021 16:51:49'! -drawButtonIconFromCurrentMorph - self subclassResponsibility ! - -PluggableButtonMorph removeSelector: #draw3DLookOn:! - -!methodRemoval: PluggableButtonMorph #draw3DLookOn: stamp: 'Install-4677-buttonDrawingInCanvas-JuanVuletich-2021Jul19-10h09m-jmv.001.cs.st 7/20/2021 16:51:49'! -draw3DLookOn: aCanvas - - | borderStyleSymbol c | - borderStyleSymbol _ self isPressed ifFalse: [ #raised ] ifTrue: [ #inset ]. - c _ color. - self mouseIsOver ifTrue: [ c _ c lighter ]. - aCanvas - fillRectangle: self morphLocalBounds - color: c - borderWidth: borderWidth - borderStyleSymbol: borderStyleSymbol - baseColorForBorder: c. - - self drawRegularLabelOn: aCanvas! - -PluggableButtonMorph removeSelector: #iconColor! - -!methodRemoval: PluggableButtonMorph #iconColor stamp: 'Install-4677-buttonDrawingInCanvas-JuanVuletich-2021Jul19-10h09m-jmv.001.cs.st 7/20/2021 16:51:49'! -iconColor - - ^ self isPressed - ifTrue: [ `Color gray: 0.75` ] - ifFalse: [ - self mouseIsOver - ifTrue: [ `Color gray: 0.75` ] - ifFalse: [ `Color white` ]].! - -PluggableButtonMorph removeSelector: #drawRoundGradientLookOn:! - -!methodRemoval: PluggableButtonMorph #drawRoundGradientLookOn: stamp: 'Install-4677-buttonDrawingInCanvas-JuanVuletich-2021Jul19-10h09m-jmv.001.cs.st 7/20/2021 16:51:49'! -drawRoundGradientLookOn: aCanvas - | r colorForButton rect bottomFactor topFactor | - - self isPressed - ifFalse: [ - topFactor _ Theme current buttonGradientTopFactor. - bottomFactor _ Theme current buttonGradientBottomFactor. - self mouseIsOver - ifTrue: [ - colorForButton _ Color h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ - colorForButton _ color ]] - ifTrue: [ - topFactor _ Theme current buttonGradientBottomFactor. - bottomFactor _ Theme current buttonGradientTopFactor. - colorForButton _ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - Theme current useButtonGradient - ifTrue: [ - rect _ self morphLocalBounds insetBy: `1@3`. - aCanvas - roundRect: rect - color: colorForButton - radius: r - gradientTop: topFactor - gradientBottom: bottomFactor - gradientHeight: Theme current buttonGradientHeight ] - ifFalse: [ - rect _ self morphLocalBounds insetBy: `1@3`. - aCanvas roundRect: rect color: colorForButton radius: r ] - ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawEmbossedLabelOn: aCanvas ] - ifFalse: [ self drawRegularLabelOn: aCanvas ]! - -PluggableButtonMorph removeSelector: #drawEmbossedLabelOn:! - -!methodRemoval: PluggableButtonMorph #drawEmbossedLabelOn: stamp: 'Install-4677-buttonDrawingInCanvas-JuanVuletich-2021Jul19-10h09m-jmv.001.cs.st 7/20/2021 16:51:49'! -drawEmbossedLabelOn: aCanvas - - | availableW center colorForLabel f l labelMargin targetSize w x y | - label ifNotNil: [ - colorForLabel _ Theme current buttonLabel. - self isPressed - ifFalse: [ - self mouseIsOver - ifFalse: [ colorForLabel _ colorForLabel adjustSaturation: -0.10 brightness: 0.10 ]] - ifTrue: [ colorForLabel _ colorForLabel adjustSaturation: 0.0 brightness: -0.07 ]. - f _ self fontToUse. - center _ extent // 2. - labelMargin _ 3. - w _ f widthOfString: label. - availableW _ extent x - labelMargin - labelMargin. - availableW >= w - ifTrue: [ - l _ label ] - ifFalse: [ - x _ labelMargin. - targetSize _ label size * availableW // w. - l _ label squeezedTo: targetSize. - (f widthOfString: l) > availableW ifTrue: [ - targetSize _ targetSize - 1. - l _ label squeezedTo: targetSize ]]. - - w _ f widthOfString: l. - x _ center x - (w // 2). - y _ center y - (f lineSpacing // 2). - aCanvas - drawString: l - at: x@y - font: f - color: colorForLabel - embossed: true ]! - -PluggableButtonMorph removeSelector: #drawRegularLabelOn:! - -!methodRemoval: PluggableButtonMorph #drawRegularLabelOn: stamp: 'Install-4677-buttonDrawingInCanvas-JuanVuletich-2021Jul19-10h09m-jmv.001.cs.st 7/20/2021 16:51:49'! -drawRegularLabelOn: aCanvas - - | w f center x y availableW l labelMargin | - - f _ self fontToUse. - center _ extent // 2. - - label ifNotNil: [ - labelMargin _ 4. - w _ f widthOfString: label. - availableW _ extent x - labelMargin - labelMargin - 1. - availableW >= w - ifTrue: [ - x _ center x - (w // 2). - l _ label ] - ifFalse: [ - x _ labelMargin. - l _ label squeezedTo: (label size * availableW / w) rounded ]. - y _ center y - (f lineSpacing // 2). - self isPressed ifTrue: [ - x _ x + 1. - y _ y + 1 ]. - aCanvas - drawString: l - at: x@y - font: f - color: Theme current buttonLabel ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4677-buttonDrawingInCanvas-JuanVuletich-2021Jul19-10h09m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4677] on 19 July 2021 at 10:48:28 am'! -!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jmv 7/19/2021 10:42:16'! - iconDrawSelector - "Must be understood by drawing canvas." - - ^iconName! ! -!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jmv 7/19/2021 10:41:45'! - iconDrawSelector: aSymbol - "aSymbol must be understood by drawing canvas." - - iconName _ aSymbol! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 10:34:59'! - drawCloseIcon - | icon | - icon _ self class windowButtonIcon: #closeIcon size: currentMorph morphWidth. - self pvtDrawButtonIcon: icon.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 10:35:03'! - drawCollapseIcon - | icon | - icon _ self class windowButtonIcon: #collapseIcon size: currentMorph morphWidth. - self pvtDrawButtonIcon: icon.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 10:35:07'! - drawDownIcon - | icon | - icon _ BitBltCanvas arrowOfDirection: #down size: ScrollBar scrollbarThickness. - self pvtDrawButtonIcon: icon.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 10:35:11'! - drawExpandIcon - | icon | - icon _ self class windowButtonIcon: #expandIcon size: currentMorph morphWidth. - self pvtDrawButtonIcon: icon.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 10:35:14'! - drawLeftIcon - | icon | - icon _ BitBltCanvas arrowOfDirection: #left size: ScrollBar scrollbarThickness. - self pvtDrawButtonIcon: icon.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 10:35:18'! - drawMenuIcon - | icon | - icon _ self class windowButtonIcon: #windowMenuIcon size: currentMorph morphWidth. - self pvtDrawButtonIcon: icon.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 10:35:22'! - drawPushPinIcon - | icon | - icon _ self class windowButtonIcon: #pushPinIcon size: currentMorph morphWidth. - self pvtDrawButtonIcon: icon.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 10:35:25'! - drawRightIcon - | icon | - icon _ BitBltCanvas arrowOfDirection: #right size: ScrollBar scrollbarThickness. - self pvtDrawButtonIcon: icon.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 10:35:29'! - drawUpIcon - | icon | - icon _ BitBltCanvas arrowOfDirection: #up size: ScrollBar scrollbarThickness. - self pvtDrawButtonIcon: icon.! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 7/19/2021 10:34:41'! - pvtDrawButtonIcon: icon - "We assume that we are drawing a PluggableButtonMorph, - or some morph that conforms the required protocol. - Answer true if we were able to draw it." - - | iconColor | - iconColor _ currentMorph isPressed - ifTrue: [ `Color gray: 0.75` ] - ifFalse: [ - currentMorph mouseIsOver - ifTrue: [ `Color gray: 0.75` ] - ifFalse: [ `Color white` ]]. - self - image: icon - multipliedBy: iconColor - at: (currentMorph morphExtent - icon extent //2).! ! -!BitBltCanvas class methodsFor: 'cached button forms' stamp: 'jmv 7/18/2021 19:57:10'! - windowButtonIcon: aSymbol size: finalSizeInteger - ^self cachedForms - at: { aSymbol . finalSizeInteger } - ifAbsentPut: [ - | icon w h factor magnifiedExtent magnifiedIcon | - icon _ Theme current perform: aSymbol. - magnifiedIcon _ icon. - w _ icon width. - h _ icon height. - w*h = 0 ifFalse: [ - factor _ 1.0 * finalSizeInteger / w min: 1.0 * finalSizeInteger / h. - factor = 1.0 ifFalse: [ - magnifiedExtent _ (icon extent * factor) rounded. - magnifiedIcon _ icon magnifyTo: magnifiedExtent ]]. - magnifiedIcon ]! ! -!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jmv 7/18/2021 20:25:15' prior: 16888050! - icon: aForm -"estos 2 lo quiero eliminar. Es todo mambo del canvas, no del boton." - icon _ aForm. - magnifiedIcon _ nil! ! -!PluggableButtonMorph methodsFor: 'private' stamp: 'jmv 7/18/2021 20:27:22' prior: 50471920! - magnifiedIcon -"que quede solo en MenuItemMorph, de donde debe volar tambien eventualmente." - | factor magnifiedExtent w h | - - icon ifNil: [ ^nil ]. - magnifiedIcon ifNil: [ - magnifiedIcon _ icon. - w _ icon width. - h _ icon height. - w*h = 0 ifFalse: [ - factor _ 1.0 * extent x / w min: 1.0 * extent y / h. - factor = 1.0 ifFalse: [ - magnifiedExtent _ (icon extent * factor) rounded. - magnifiedIcon _ icon magnifyTo: magnifiedExtent ]]]. - ^magnifiedIcon! ! -!PluggableButtonMorph methodsFor: 'geometry' stamp: 'jmv 7/18/2021 20:27:02' prior: 50556390 overrides: 50556356! - extentChanged: oldExtent - "Our extent changed. Must layout submorphs again." -"este vuela, claro." - super extentChanged: oldExtent. - magnifiedIcon _ nil! ! -!PluggableButtonMorph methodsFor: 'geometry testing' stamp: 'jmv 7/18/2021 20:26:09' prior: 50503390 overrides: 50546029! - morphContainsPoint: aLocalPoint - - | iconOrigin | - (self morphLocalBounds containsPoint: aLocalPoint) ifFalse: [ ^false ]. -"mhhhhhhh" - ^ self isOrthoRectangularMorph or: [ - magnifiedIcon isNil or: [ - iconOrigin _ extent - magnifiedIcon extent // 2. - (magnifiedIcon isTransparentAt: (aLocalPoint - iconOrigin) rounded) not ]]! ! -!ScrollBar methodsFor: 'initialization' stamp: 'jmv 7/19/2021 10:44:22' prior: 50565378! - updateDownButton: aPluggableButtonMorph - "Update the argument as a downButton." - - aPluggableButtonMorph - iconDrawSelector: #drawDownIcon; - action: #scrollDown; - roundButtonStyle: false; - redrawNeeded! ! -!ScrollBar methodsFor: 'initialization' stamp: 'jmv 7/19/2021 10:44:13' prior: 50565390! - updateLeftButton: aPluggableButtonMorph - "Update the argument as a leftButton." - - aPluggableButtonMorph - iconDrawSelector: #drawLeftIcon; - action: #scrollUp; - roundButtonStyle: false; - redrawNeeded! ! -!ScrollBar methodsFor: 'initialization' stamp: 'jmv 7/19/2021 10:44:04' prior: 50565402! - updateRightButton: aPluggableButtonMorph - "Update the argument as a rightButton." - - aPluggableButtonMorph - iconDrawSelector: #drawRightIcon; - action: #scrollDown; - roundButtonStyle: false; - redrawNeeded! ! -!ScrollBar methodsFor: 'initialization' stamp: 'jmv 7/19/2021 10:43:51' prior: 50565414! - updateUpButton: aPluggableButtonMorph - "Update the argument as an upButton." - - aPluggableButtonMorph - iconDrawSelector: #drawUpIcon; - action: #scrollUp; - roundButtonStyle: false; - redrawNeeded! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 7/19/2021 10:42:53' prior: 50471868! - createCloseButton - ^ (PluggableButtonMorph model: self action: #closeBoxHit) - iconDrawSelector: #drawCloseIcon; - setBalloonText: 'close this window'; - morphExtent: self titleBarButtonsExtent! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 7/19/2021 10:42:58' prior: 50471878! - createCollapseButton - ^(PluggableButtonMorph model: self action: #collapse) - iconDrawSelector: #drawCollapseIcon; - setBalloonText: 'collapse this window'; - morphExtent: self titleBarButtonsExtent! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 7/19/2021 10:43:02' prior: 50471888! - createExpandButton - ^ (PluggableButtonMorph model: self action: #expandBoxHit) - iconDrawSelector: #drawExpandIcon; - setBalloonText: 'expand to full screen'; - morphExtent: self titleBarButtonsExtent! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 7/19/2021 10:43:06' prior: 50471898! - createMenuButton - ^ (PluggableButtonMorph model: self action: #offerWindowMenu) - iconDrawSelector: #drawMenuIcon; - setBalloonText: 'window menu'; - morphExtent: self titleBarButtonsExtent! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 7/19/2021 10:42:49' prior: 50547909! - addStayUpIcons - | closeButton pinButton w buttonHW | - Preferences optionalButtons ifFalse: [ ^self ]. - (self valueOfProperty: #hasStayUpIcons ifAbsent: [ false ]) - ifTrue: [ - self removeProperty: #needsStayUpIcons. - ^self ]. - titleMorph ifNil: [ - "Title not yet there. Flag ourself, so this method is called again when adding title." - self setProperty: #needsStayUpIcons toValue: true. - ^ self]. - buttonHW _ Preferences windowTitleFont pointSize. - closeButton _ PluggableButtonMorph model: self action: #delete. - closeButton iconDrawSelector: #drawCloseIcon; color: `Color transparent`. - pinButton _ PluggableButtonMorph model: self action: #stayUp. - pinButton iconDrawSelector: #drawPushPinIcon; color: `Color transparent`. - w _ (titleMorph hasSubmorphs ifTrue: [ titleMorph firstSubmorph morphWidth ] ifFalse: [ 0 ]) + 60. - self addMorphFront: - (LayoutMorph newRow - "Make room for buttons" - morphExtent: w @ (titleMorph morphHeight max: buttonHW); - color: `Color transparent`; - addMorph: closeButton fixedWidth: buttonHW; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedWidth: buttonHW//3; - addMorph: titleMorph proportionalWidth: 1; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedWidth: buttonHW//3; - addMorph: pinButton fixedWidth: buttonHW). - - self setProperty: #hasStayUpIcons toValue: true. - self removeProperty: #needsStayUpIcons! ! -!BitBltCanvas methodsFor: 'drawing-widgets' stamp: 'jmv 7/19/2021 10:42:23' prior: 50577479 overrides: 50577395! - drawButtonIcon: aPluggableButtonMorph - "We assume that we are drawing a PluggableButtonMorph, - or some morph that conforms the required protocol. - Answer true if we were able to draw it." - - aPluggableButtonMorph iconDrawSelector ifNotNil: [ :selector | -(#(drawLeftIcon drawRightIcon drawUpIcon drawDownIcon drawCloseIcon drawCollapseIcon drawExpandIcon drawMenuIcon drawPushPinIcon) includes: selector) -ifTrue: [ - self perform: selector. - ^true ]. -]. - - aPluggableButtonMorph magnifiedIcon ifNotNil: [ :theIcon | | iconColor | - iconColor _ aPluggableButtonMorph isPressed - ifTrue: [ `Color gray: 0.75` ] - ifFalse: [ - aPluggableButtonMorph mouseIsOver - ifTrue: [ `Color gray: 0.75` ] - ifFalse: [ `Color white` ]]. - self - image: theIcon - multipliedBy: iconColor - at: (aPluggableButtonMorph morphExtent - theIcon extent //2). - ^true ]. - ^false! ! - -BitBltCanvas removeSelector: #drawIcon:for:! - -PluggableButtonMorph removeSelector: #iconName:! - -!methodRemoval: PluggableButtonMorph #iconName: stamp: 'Install-4678-buttonIconDrawingInCanvas-JuanVuletich-2021Jul19-10h14m-jmv.001.cs.st 7/20/2021 16:51:49'! -iconName: aSymbol - iconName _ aSymbol! - -PluggableButtonMorph removeSelector: #iconName! - -!methodRemoval: PluggableButtonMorph #iconName stamp: 'Install-4678-buttonIconDrawingInCanvas-JuanVuletich-2021Jul19-10h14m-jmv.001.cs.st 7/20/2021 16:51:49'! -iconName - ^iconName! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4678-buttonIconDrawingInCanvas-JuanVuletich-2021Jul19-10h14m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4675] on 18 July 2021 at 8:45:13 pm'! -!Theme methodsFor: 'icons' stamp: 'jmv 7/18/2021 20:39:39'! - fontIcon - ^(Theme content from: 'Theme' get: {'16x16'. 'mimetypes'}) at: 'font-x-generic.png'! ! -!Theme methodsFor: 'icons' stamp: 'jmv 7/18/2021 20:40:31'! - imageIcon - ^((Theme content from: 'Theme' get: {'16x16'. 'mimetypes'}) at: 'image-x-generic.png')! ! -!SimpleServiceEntry methodsFor: 'accessing' stamp: 'jmv 7/18/2021 20:42:47' prior: 50426965! - icon: iconSymbol - - icon := iconSymbol ! ! -!SimpleServiceEntry class methodsFor: 'instance creation' stamp: 'jmv 7/18/2021 20:41:32' prior: 50426969! - provider: anObject label: aString selector: aSymbol description: anotherString buttonLabel: aLabel icon: iconSymbol - - ^ (self provider: anObject label: aString selector: aSymbol description: anotherString buttonLabel: aLabel) - icon: iconSymbol; - yourself! ! -!SimpleServiceEntry class methodsFor: 'instance creation' stamp: 'jmv 7/18/2021 20:42:36' prior: 50426980! - provider: anObject label: aString selector: aSymbol description: anotherString icon: iconSymbol - - ^(self provider: anObject label: aString selector: aSymbol description: anotherString) - icon: iconSymbol; - yourself! ! -!ImageReadWriter class methodsFor: 'instance creation' stamp: 'jmv 7/18/2021 20:40:40' prior: 50507855! - serviceReadImage - "Answer the service of importing an image" - - ^ (SimpleServiceEntry - provider: self - label: 'import as ImageMorph' - selector: #imageMorphFromFileEntry: - description: 'import image as ImageMorph' - buttonLabel: 'import image' - icon: #imageIcon - ) argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4679-Cleanup-JuanVuletich-2021Jul18-20h33m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4675] on 18 July 2021 at 7:05:16 pm'! -!Morph methodsFor: 'drawing' stamp: 'jmv 7/18/2021 19:05:09' prior: 50577190! - imageForm: extentOrNil depth: depth - - | extent answer auxCanvas | - extent _ self morphExtent. - extentOrNil ifNotNil: [ extent _ extent min: extentOrNil * 4 ]. - auxCanvas _ MorphicCanvas depth: depth over: (self morphPosition floor extent: extent ceiling). - auxCanvas fullDraw: self. - answer _ auxCanvas form divideByAlpha. - extentOrNil ifNotNil: [ answer _ answer magnifyTo: extentOrNil ]. - ^answer.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4680-imageForm-again-JuanVuletich-2021Jul18-19h00m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4680] on 19 July 2021 at 5:08:58 pm'! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 7/19/2021 11:33:16'! - pvtDrawButtonFaceForm: aForm - "We assume that we are drawing a PluggableButtonMorph, - or some morph that conforms the required protocol. - Answer true if we were able to draw it." - - | color | - color _ currentMorph isPressed - ifTrue: [ `Color gray: 0.75` ] - ifFalse: [ - currentMorph mouseIsOver - ifTrue: [ `Color gray: 0.75` ] - ifFalse: [ `Color white` ]]. - self - image: aForm - multipliedBy: color - at: (currentMorph morphExtent - aForm extent //2).! ! -!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jmv 7/19/2021 17:06:53' prior: 50577795! - icon: aForm - icon _ aForm. - magnifiedIcon _ nil! ! -!PluggableButtonMorph methodsFor: 'private' stamp: 'jmv 7/19/2021 17:06:35' prior: 50577802! - magnifiedIcon - | factor magnifiedExtent w h | - - icon ifNil: [ ^nil ]. - magnifiedIcon ifNil: [ - magnifiedIcon _ icon. - w _ icon width. - h _ icon height. - w*h = 0 ifFalse: [ - factor _ 1.0 * extent x / w min: 1.0 * extent y / h. - factor = 1.0 ifFalse: [ - magnifiedExtent _ (icon extent * factor) rounded. - magnifiedIcon _ icon magnifyTo: magnifiedExtent ]]]. - ^magnifiedIcon! ! -!PluggableButtonMorph methodsFor: 'geometry' stamp: 'jmv 11/15/2020 11:34:23' prior: 50577821 overrides: 50556356! - extentChanged: oldExtent - "Our extent changed. Must layout submorphs again." - - super extentChanged: oldExtent. - magnifiedIcon _ nil! ! -!MorphicCanvas methodsFor: 'drawing-widgets' stamp: 'jmv 7/19/2021 17:07:46' prior: 50577395! - drawButtonIcon: aPluggableButtonMorph - "We assume that we are drawing a PluggableButtonMorph, - or some morph that conforms the required protocol. - Answer true if we were able to draw it." - - aPluggableButtonMorph iconDrawSelector ifNotNil: [ :selector | - self perform: selector. - ^true ]. - - aPluggableButtonMorph magnifiedIcon ifNotNil: [ :theIcon | - self pvtDrawButtonFaceForm: theIcon. - ^true ]. - - ^false! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 11:33:25' prior: 50577694! - drawCloseIcon - | icon | - icon _ self class windowButtonIcon: #closeIcon size: currentMorph morphWidth. - self pvtDrawButtonFaceForm: icon.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 11:33:29' prior: 50577701! - drawCollapseIcon - | icon | - icon _ self class windowButtonIcon: #collapseIcon size: currentMorph morphWidth. - self pvtDrawButtonFaceForm: icon.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 11:33:32' prior: 50577708! - drawDownIcon - | icon | - icon _ BitBltCanvas arrowOfDirection: #down size: ScrollBar scrollbarThickness. - self pvtDrawButtonFaceForm: icon.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 11:33:36' prior: 50577715! - drawExpandIcon - | icon | - icon _ self class windowButtonIcon: #expandIcon size: currentMorph morphWidth. - self pvtDrawButtonFaceForm: icon.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 11:33:40' prior: 50577722! - drawLeftIcon - | icon | - icon _ BitBltCanvas arrowOfDirection: #left size: ScrollBar scrollbarThickness. - self pvtDrawButtonFaceForm: icon.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 11:33:43' prior: 50577729! - drawMenuIcon - | icon | - icon _ self class windowButtonIcon: #windowMenuIcon size: currentMorph morphWidth. - self pvtDrawButtonFaceForm: icon.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 11:33:47' prior: 50577736! - drawPushPinIcon - | icon | - icon _ self class windowButtonIcon: #pushPinIcon size: currentMorph morphWidth. - self pvtDrawButtonFaceForm: icon.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 11:33:50' prior: 50577743! - drawRightIcon - | icon | - icon _ BitBltCanvas arrowOfDirection: #right size: ScrollBar scrollbarThickness. - self pvtDrawButtonFaceForm: icon.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 11:33:53' prior: 50577750! - drawUpIcon - | icon | - icon _ BitBltCanvas arrowOfDirection: #up size: ScrollBar scrollbarThickness. - self pvtDrawButtonFaceForm: icon.! ! - -BitBltCanvas removeSelector: #drawButtonIcon:! - -!methodRemoval: BitBltCanvas #drawButtonIcon: stamp: 'Install-4681-PluggableButtonMorph-tweaks-JuanVuletich-2021Jul19-16h59m-jmv.001.cs.st 7/20/2021 16:51:49'! -drawButtonIcon: aPluggableButtonMorph - "We assume that we are drawing a PluggableButtonMorph, - or some morph that conforms the required protocol. - Answer true if we were able to draw it." - - aPluggableButtonMorph iconDrawSelector ifNotNil: [ :selector | -(#(drawLeftIcon drawRightIcon drawUpIcon drawDownIcon drawCloseIcon drawCollapseIcon drawExpandIcon drawMenuIcon drawPushPinIcon) includes: selector) -ifTrue: [ - self perform: selector. - ^true ]. -]. - - aPluggableButtonMorph magnifiedIcon ifNotNil: [ :theIcon | | iconColor | - iconColor _ aPluggableButtonMorph isPressed - ifTrue: [ `Color gray: 0.75` ] - ifFalse: [ - aPluggableButtonMorph mouseIsOver - ifTrue: [ `Color gray: 0.75` ] - ifFalse: [ `Color white` ]]. - self - image: theIcon - multipliedBy: iconColor - at: (aPluggableButtonMorph morphExtent - theIcon extent //2). - ^true ]. - ^false! - -BitBltCanvas removeSelector: #drawButtonForm:! - -BitBltCanvas removeSelector: #pvtDrawButtonIcon:! - -!methodRemoval: BitBltCanvas #pvtDrawButtonIcon: stamp: 'Install-4681-PluggableButtonMorph-tweaks-JuanVuletich-2021Jul19-16h59m-jmv.001.cs.st 7/20/2021 16:51:49'! -pvtDrawButtonIcon: icon - "We assume that we are drawing a PluggableButtonMorph, - or some morph that conforms the required protocol. - Answer true if we were able to draw it." - - | iconColor | - iconColor _ currentMorph isPressed - ifTrue: [ `Color gray: 0.75` ] - ifFalse: [ - currentMorph mouseIsOver - ifTrue: [ `Color gray: 0.75` ] - ifFalse: [ `Color white` ]]. - self - image: icon - multipliedBy: iconColor - at: (currentMorph morphExtent - icon extent //2).! - -MorphicCanvas removeSelector: #drawButtonForm:! - -PluggableButtonMorph removeSelector: #morphContainsPoint:! - -!methodRemoval: PluggableButtonMorph #morphContainsPoint: stamp: 'Install-4681-PluggableButtonMorph-tweaks-JuanVuletich-2021Jul19-16h59m-jmv.001.cs.st 7/20/2021 16:51:49'! -morphContainsPoint: aLocalPoint - - | iconOrigin | - (self morphLocalBounds containsPoint: aLocalPoint) ifFalse: [ ^false ]. -"mhhhhhhh" - ^ self isOrthoRectangularMorph or: [ - magnifiedIcon isNil or: [ - iconOrigin _ extent - magnifiedIcon extent // 2. - (magnifiedIcon isTransparentAt: (aLocalPoint - iconOrigin) rounded) not ]]! - -PluggableButtonMorph removeSelector: #scaledForm! - -PluggableButtonMorph removeSelector: #form:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4681-PluggableButtonMorph-tweaks-JuanVuletich-2021Jul19-16h59m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4681] on 19 July 2021 at 5:31:24 pm'! -!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jmv 7/19/2021 17:30:51'! - iconName - self valueOfProperty: #iconName! ! -!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jmv 7/19/2021 17:30:25'! - iconName: name - self setProperty: #iconName toValue: name! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4682-PluggableButtonMorph-iconName-JuanVuletich-2021Jul19-17h30m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4681] on 19 July 2021 at 5:44:30 pm'! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 7/19/2021 16:09:05' prior: 50461045! - focusIndicatorBottom - ^ self hIsScrollbarShowing - ifTrue: [ extent y - borderWidth - ScrollBar scrollbarThickness ] - ifFalse: [ extent y - borderWidth ]! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 7/19/2021 16:09:11' prior: 50461057! - focusIndicatorRight - ^ self vIsScrollbarShowing - ifTrue: [ extent x - borderWidth - ScrollBar scrollbarThickness ] - ifFalse: [ extent x - borderWidth ]! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 7/19/2021 16:09:41' prior: 50499543 overrides: 50499535! - minimumExtent - | minW minH | - "Figure out the minimum extent for this pane so that either content, or at least required scrollbars, will fit" - minW _ self xtraBorder * 2 + scroller morphWidth min: ScrollBar scrollbarThickness * 2. - self vIsScrollbarShowing - ifTrue: [ - minW _ minW + ScrollBar scrollbarThickness]. - minH _ self xtraBorder * 2 + scroller morphHeight. - self hIsScrollbarShowing - ifTrue: [ - minH _ minH + ScrollBar scrollbarThickness]. - minH _ minH min: ScrollBar scrollbarThickness * 2. - ^ (minW + (borderWidth * 2)) @ (minH + (borderWidth * 2))! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 7/19/2021 16:09:54' prior: 50561997! - updateScrollBarsBounds - - | t | - hideScrollBars = #hide ifTrue: [^self]. - t _ ScrollBar scrollbarThickness. - (hideScrollBars = #hideVertical) - ifFalse: [ - scrollBar - morphPosition: extent x - t - borderWidth @ borderWidth - extent: t @ self vScrollBarHeight. - ]. - hScrollBar - morphPosition: borderWidth @ (extent y - t - borderWidth) - extent: self hScrollBarWidth@t! ! -!PluggableScrollPane methodsFor: 'initialization' stamp: 'jmv 7/19/2021 16:09:22' prior: 50556236 overrides: 50384377! - initialize - - "initialize the state of the receiver" - super initialize. - hideScrollBars _ #showIfNeeded. - - "initialize the receiver's scrollBars" - scrollBar _ ScrollBar new model: self setValueSelector: #vScrollBarValue:. - hScrollBar _ ScrollBar new model: self setValueSelector: #hScrollBarValue:. - drawKeyboardFocusIndicator _ true. - - scroller _ self innerMorphClass new. - self addMorph: scroller. - self scrollerOffset: `0@ 0`. - self addMorph: scrollBar. - self addMorph: hScrollBar! ! -!ScrollBar methodsFor: 'initialization' stamp: 'jmv 7/19/2021 16:06:58' prior: 50568165! -initializeDownButton - "initialize the receiver's downButton" - - | e | - e _ self buttonExtent. - downButton _ PluggableButtonMorph new. - downButton model: self. - downButton morphExtent: e@e. - Theme current scrollbarShowButtons ifFalse: [^ self]. - self addMorph: downButton position: extent - borderWidth - e. - downButton - actWhen: #buttonStillDown. "to enable multiple action if held down". - self isHorizontal - ifTrue: [ self updateRightButton: downButton ] - ifFalse: [ self updateDownButton: downButton ]! ! -!ScrollBar methodsFor: 'initialization' stamp: 'jmv 7/19/2021 16:08:11' prior: 50547875! - initializeSlider - "initialize the receiver's slider" - - sliderShadow _ WidgetMorph new noBorder. - self addMorph: sliderShadow. - sliderShadow hide. - - slider _ DraggeableButtonMorph new. - slider model: self. - slider grabSelector: #sliderGrabbedAt:. - slider dragSelector: #scrollTo:. - slider action: #sliderReleased. - self addMorph: slider. - - self computeSlider! ! -!ScrollBar methodsFor: 'initialization' stamp: 'jmv 7/19/2021 16:07:05' prior: 50568255! - initializeUpButton - "initialize the receiver's upButton" - - | e | - e _ self buttonExtent. - upButton _ PluggableButtonMorph new. - upButton model: self. - upButton morphExtent: e@e. - Theme current scrollbarShowButtons ifFalse: [^ self]. - self addMorph: upButton position: borderWidth@borderWidth. - upButton - actWhen: #buttonStillDown. "to enable multiple action if held down" - self isHorizontal - ifTrue: [ self updateLeftButton: upButton ] - ifFalse: [ self updateUpButton: upButton ]. -! ! - -ScrollBar removeSelector: #sliderClass! - -!methodRemoval: ScrollBar #sliderClass stamp: 'Install-4683-ScrollbarCleanup-JuanVuletich-2021Jul19-17h40m-jmv.001.cs.st 7/20/2021 16:51:49'! -sliderClass - ^DraggeableButtonMorph! - -ScrollBar removeSelector: #buttonClass! - -!methodRemoval: ScrollBar #buttonClass stamp: 'Install-4683-ScrollbarCleanup-JuanVuletich-2021Jul19-17h40m-jmv.001.cs.st 7/20/2021 16:51:49'! -buttonClass - ^PluggableButtonMorph! - -PluggableScrollPane removeSelector: #scrollBarClass! - -!methodRemoval: PluggableScrollPane #scrollBarClass stamp: 'Install-4683-ScrollbarCleanup-JuanVuletich-2021Jul19-17h40m-jmv.001.cs.st 7/20/2021 16:51:49'! -scrollBarClass - ^ScrollBar! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4683-ScrollbarCleanup-JuanVuletich-2021Jul19-17h40m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4683] on 20 July 2021 at 12:50:59 pm'! -!SystemWindow methodsFor: 'panes' stamp: 'jmv 7/20/2021 11:17:26'! - windowFrameColor - - | windowFrameColor | - windowFrameColor _ self borderColor. - self isTopWindow - ifTrue: [ windowFrameColor _ windowFrameColor lighter ]. - ^windowFrameColor! ! -!MorphicCanvas methodsFor: 'drawing-widgets' stamp: 'jmv 7/20/2021 10:24:23'! - drawButtonRound: aPluggableButtonMorph - | r colorForButton rect color | - color _ aPluggableButtonMorph color. - colorForButton _ aPluggableButtonMorph isPressed - ifFalse: [ - aPluggableButtonMorph mouseIsOver - ifTrue: [ Color h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ color ]] - ifTrue: [ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - rect _ aPluggableButtonMorph morphLocalBounds insetBy: `1@3`. - self roundRect: rect color: colorForButton radius: r ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawButtonEmbossedLabel: aPluggableButtonMorph ] - ifFalse: [ self drawButtonRegularLabel: aPluggableButtonMorph ].! ! -!MorphicCanvas methodsFor: 'drawing-windows' stamp: 'jmv 7/20/2021 09:40:57'! - drawRoundedFrame: aRectangle border: borderWidth color: borderColor insideColor: insideColor labelHeight: labelHeight - - self subclassResponsibility.! ! -!BitBltCanvas methodsFor: 'drawing-windows' stamp: 'jmv 7/20/2021 09:40:38' overrides: 50578529! - drawRoundedFrame: aRectangle border: borderWidth color: borderColor insideColor: insideColor labelHeight: labelHeight - "Title area is not inside window borders" - | bottomFactor topFactor | - Theme current useWindowTitleGradient - ifTrue: [ - topFactor _ Theme current titleGradientTopFactor. - bottomFactor _ Theme current titleGradientBottomFactor ] - ifFalse: [ - topFactor _ 1. - bottomFactor _ 1 ]. - self - windowFrame: aRectangle - color: borderColor * Theme current titleGradientExtraLightness - radius: Theme current roundedWindowRadius - border: borderWidth - labelHeight: labelHeight + borderWidth - gradientTop: topFactor - gradientBottom: bottomFactor - insideColor: insideColor! ! -!BitBltCanvas methodsFor: 'drawing-windows' stamp: 'jmv 7/20/2021 10:57:33'! - roundBottomLeftCornerX: cornerX y: cornerY length: l border: borderWidth color: borderColor - "NOP here"! ! -!BitBltCanvas methodsFor: 'drawing-windows' stamp: 'jmv 7/20/2021 10:57:40'! - roundBottomRightCornerX: cornerX y: cornerY length: l border: borderWidth color: borderColor - "NOP here"! ! -!BitBltCanvas methodsFor: 'drawing-windows' stamp: 'jmv 7/20/2021 11:22:31'! - roundEdge: aRectangle color: aColor - "NOP here"! ! -!BitBltCanvas methodsFor: 'drawing-windows' stamp: 'jmv 7/20/2021 10:45:30'! -roundTopLeftCornerX: cornerX y: cornerY length: l border: borderWidth color: borderColor - "NOP here"! ! -!BitBltCanvas methodsFor: 'drawing-windows' stamp: 'jmv 7/20/2021 10:51:07'! - roundTopRightCornerX: cornerX y: cornerY length: l border: borderWidth color: borderColor - "NOP here"! ! -!WindowEdgeAdjustingMorph methodsFor: 'drawing' stamp: 'jmv 7/20/2021 11:23:14' prior: 16945110 overrides: 50503568! - drawOn: aCanvas - - | c | - c _ owner windowFrameColor. - selector caseOf: { - [ #windowTopLeft: ] -> [ - aCanvas roundTopLeftCornerX: 0 y: 0 length: extent x border: owner borderWidth color: c. - ]. - [ #windowTopRight: ] -> [ - aCanvas roundTopRightCornerX: 0 y: 0 length: extent x border: owner borderWidth color: c. - ]. - [ #windowBottomLeft: ] -> [ - aCanvas roundBottomLeftCornerX: 0 y: 0 length: extent x border: owner borderWidth color: c. - ]. - [ #windowBottomRight: ] -> [ - aCanvas roundBottomRightCornerX: 0 y: 0 length: extent x border: owner borderWidth color: c. - ]. - } - otherwise: [ - "all the morph is sensitive for horizontal and vertical (i.e. non corner) instances." - aCanvas roundEdge: self morphLocalBounds color: c ].! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 7/20/2021 11:18:36' prior: 50503415! - drawClassicFrameOn: aCanvas color: windowFrameColor - "Window border encompasses title area. No round corners. No title gradient." - - aCanvas fillRectangle: self morphLocalBounds color: color borderWidth: borderWidth borderStyleSymbol: #simple baseColorForBorder: self widgetsColor. - - "A border was drawn at the left, top and right of the title area. - The look is that the title area is inside the window" - aCanvas fillRectangle: (borderWidth@borderWidth extent: extent x - (2*borderWidth)@ self labelHeight) color: windowFrameColor! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 7/20/2021 11:24:42' prior: 50568079 overrides: 50545911! - drawOn: aCanvas - | windowFrameColor roundCorners | - windowFrameColor _ self windowFrameColor. - roundCorners _ Theme current roundWindowCorners. - roundCorners - ifTrue: [ - "Round corners. Optional title gradient." - self drawRoundedFrameOn: aCanvas color: windowFrameColor ] - ifFalse: [ - "No round corners. No title gradient." - self drawClassicFrameOn: aCanvas color: windowFrameColor ]. - labelString ifNotNil: [ self drawLabelOn: aCanvas ]! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 7/20/2021 09:50:55' prior: 50503434! - drawRoundedFrameOn: aCanvas color: widgetsColor - - aCanvas - drawRoundedFrame: self morphLocalBounds - border: borderWidth - color: widgetsColor - insideColor: color - labelHeight: self labelHeight.! ! -!MorphicCanvas methodsFor: 'drawing-widgets' stamp: 'jmv 7/20/2021 10:24:29' prior: 50577342! - drawButton: aPluggableButtonMorph - aPluggableButtonMorph isRoundButton - ifTrue: [ - (self drawButtonIcon: aPluggableButtonMorph) ifFalse: [ - self drawButtonRound: aPluggableButtonMorph ]] - ifFalse: [ - self drawButton3D: aPluggableButtonMorph. - self drawButtonIcon: aPluggableButtonMorph ]! ! -!BitBltCanvas methodsFor: 'drawing-windows' stamp: 'jmv 7/20/2021 12:49:42' prior: 50533114 overrides: 50463520! - windowFrame: aRectangle color: aColor radius: r border: bw labelHeight: lh gradientTop: topFactor gradientBottom: bottomFactor insideColor: insideColor - " - BitBltCanvas releaseClassCachedState. - Display getCanvas windowFrame: (10@10 extent: 200@100) color: Color red radius: 10 border: 5 labelHeight: 25 gradientTop: 1.0 gradientBottom: 0.5 insideColor: Color green. - Display forceToScreen - " - "top stripe" - | bottomColor he tl tr | - - engine ifNil: [ ^nil ]. - - self - image: (self class topLeftCorner: r height: lh gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: aRectangle topLeft. - self - image: (self class topRightCorner: r height: lh gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: aRectangle topRight - (r@0). - self - fillRectangle: ((aRectangle withHeight: lh) insetBy: r@0) - tilingWith: (self class verticalGrayGradient: lh gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor. - - bottomColor _ aColor * bottomFactor. - - "left and right borders" - tl _ aRectangle topLeft + (0@lh). - tr _ aRectangle topRight + (bw negated@lh). - he _ bw@(aRectangle height - lh - r). - self fillRectangle: (tl extent: he) color: bottomColor. - self fillRectangle: (tr extent: he) color: bottomColor. - - "bottom stripe" - self - image: (self class bottomLeftCorner: r height: r gradientTop: 1 gradientBottom: 1 borderWidth: bw) - multipliedBy: bottomColor - at: aRectangle bottomLeft - (0@r). - self - image: (self class bottomRightCorner: r height: r gradientTop: 1 gradientBottom: 1 borderWidth: bw) - multipliedBy: bottomColor - at: aRectangle bottomRight - (r@r) . - self fillRectangle: ((aRectangle bottomLeft + (r@bw negated)) extent: (aRectangle width - r - r@bw)) color: bottomColor. - - "inside" - self fillRectangle: (aRectangle insetBy: (bw@lh corner: bw@bw)) color: insideColor! ! -!Theme methodsFor: 'other options' stamp: 'jmv 7/20/2021 11:12:18' prior: 16935707! - roundedWindowRadius - "Only effective if #roundWindowCorners answers true. - Provide a reasonable default for subclasses." - ^14! ! - -Theme removeSelector: #buttonGradientHeight! - -!methodRemoval: Theme #buttonGradientHeight stamp: 'Install-4684-WindowBitBltStuffToBitBltCanvas-JuanVuletich-2021Jul20-12h41m-jmv.001.cs.st 7/20/2021 16:51:49'! -buttonGradientHeight - "Only effective if #roundButtons answers true. - Provide a reasonable default for subclasses." - ^14! - -Theme removeSelector: #buttonGradientBottomFactor! - -!methodRemoval: Theme #buttonGradientBottomFactor stamp: 'Install-4684-WindowBitBltStuffToBitBltCanvas-JuanVuletich-2021Jul20-12h41m-jmv.001.cs.st 7/20/2021 16:51:49'! -buttonGradientBottomFactor - "Will only be used for color themes that answer true to #roundButtons" - ^0.92! - -Theme removeSelector: #buttonGradientTopFactor! - -!methodRemoval: Theme #buttonGradientTopFactor stamp: 'Install-4684-WindowBitBltStuffToBitBltCanvas-JuanVuletich-2021Jul20-12h41m-jmv.001.cs.st 7/20/2021 16:51:49'! -buttonGradientTopFactor - "Will only be used for color themes that answer true to #roundButtons" - ^1.0! - -Theme removeSelector: #useButtonGradient! - -!methodRemoval: Theme #useButtonGradient stamp: 'Install-4684-WindowBitBltStuffToBitBltCanvas-JuanVuletich-2021Jul20-12h41m-jmv.001.cs.st 7/20/2021 16:51:49'! -useButtonGradient - ^false! - -BitBltCanvas class removeSelector: #steButtonForm:! - -!methodRemoval: BitBltCanvas class #steButtonForm: stamp: 'Install-4684-WindowBitBltStuffToBitBltCanvas-JuanVuletich-2021Jul20-12h41m-jmv.001.cs.st 7/20/2021 16:51:49'! -steButtonForm: extent - ^self cachedForms - at: { #steButton . extent } - ifAbsentPut: [ - | form canvas | - form _ Form extent: extent depth: 32. - canvas _ form getCanvas. - canvas - roundRect: (`0@0` extent: extent) - color: `Color gray: 0.4` - radius: 4. - canvas - roundRect: (`1@1` extent: extent-2) - color: `Color white` - radius: 4 - gradientTop: 1.0 - gradientCenter: 0.73 - gradientBottom: 0.94 - gradient1Height: (extent y-8+1 max: extent y//2). - form]! - -BitBltCanvas removeSelector: #roundRect:color:radius:gradientTop:gradientCenter:gradientBottom:gradient1Height:! - -!methodRemoval: BitBltCanvas #roundRect:color:radius:gradientTop:gradientCenter:gradientBottom:gradient1Height: stamp: 'Install-4684-WindowBitBltStuffToBitBltCanvas-JuanVuletich-2021Jul20-12h41m-jmv.001.cs.st 7/20/2021 16:51:49'! -roundRect: aRectangle color: aColor radius: r gradientTop: topFactor gradientCenter: centerFactor gradientBottom: bottomFactor gradient1Height: h1 - " - Display restore. - BitBltCanvas releaseClassCachedState. - Display getCanvas roundRect: (10@10 extent: 200@100) color: Color red radius: 10 gradientTop: 1.0 gradientCenter: 0.0 gradientBottom: 1.0 gradient1Height: 35 - " - | h2 | - - engine ifNil: [ ^nil ]. - - "top stripe" - self - image: (self class topLeftCorner: r height: h1 gradientTop: topFactor gradientBottom: centerFactor) - multipliedBy: aColor - at: aRectangle topLeft. - self - image: (self class topRightCorner: r height: h1 gradientTop: topFactor gradientBottom: centerFactor) - multipliedBy: aColor - at: aRectangle topRight - (r@0). - self - fillRectangle: ((aRectangle withHeight: h1) insetBy: r@0) - tilingWith: (self class verticalGrayGradient: h1 gradientTop: topFactor gradientBottom: centerFactor) - multipliedBy: aColor. - - "bottom stripe" - h2 _ aRectangle height - h1. - self - image: (self class bottomLeftCorner: r height: h2 gradientTop: centerFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: aRectangle topLeft + (0@h1). - self - image: (self class bottomRightCorner: r height: h2 gradientTop: centerFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: aRectangle topRight + (r negated@h1). - self - fillRectangle: ((aRectangle topLeft + (r@h1)) extent: (aRectangle width-r-r@h2)) - tilingWith: (self class verticalGrayGradient: h2 gradientTop: centerFactor gradientBottom: bottomFactor) - multipliedBy: aColor.! - -BitBltCanvas removeSelector: #roundRect:color:radius:gradientTop:gradientBottom:gradientHeight:! - -!methodRemoval: BitBltCanvas #roundRect:color:radius:gradientTop:gradientBottom:gradientHeight: stamp: 'Install-4684-WindowBitBltStuffToBitBltCanvas-JuanVuletich-2021Jul20-12h41m-jmv.001.cs.st 7/20/2021 16:51:49'! -roundRect: displayRectangle color: aColor radius: r gradientTop: topFactor gradientBottom: bottomFactor gradientHeight: h - " - Display restore. - BitBltCanvas releaseClassCachedState. - Display getCanvas roundRect: (10@10 extent: 200@100) color: Color red radius: 10 gradientTop: 1.0 gradientBottom: 0.5 gradientHeight: 35 - " - | bottomColor | - - engine ifNil: [ ^nil ]. - - "top stripe" - self - image: (self class topLeftCorner: r height: h gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: displayRectangle topLeft. - self - image: (self class topRightCorner: r height: h gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: displayRectangle topRight - (r@0). - self - fillRectangle: ((displayRectangle withHeight: h) insetBy: r@0) - tilingWith: (self class verticalGrayGradient: h gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor. - - bottomColor _ aColor * bottomFactor. - "center stripe" - self fillRectangle: (displayRectangle insetBy: (0 @ h corner: 0 @ r)) color: bottomColor. - - "bottom stripe" - self - image: (self class bottomLeftCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: bottomColor - at: displayRectangle bottomLeft - (0@r). - self - image: (self class bottomRightCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: bottomColor - at: displayRectangle bottomRight - (r@r) . - self fillRectangle: ((displayRectangle bottomLeft + (r@r negated)) extent: (displayRectangle width - r - r@r)) color: bottomColor! - -MorphicCanvas removeSelector: #roundRect:color:radius:gradientTop:gradientCenter:gradientBottom:gradient1Height:! - -!methodRemoval: MorphicCanvas #roundRect:color:radius:gradientTop:gradientCenter:gradientBottom:gradient1Height: stamp: 'Install-4684-WindowBitBltStuffToBitBltCanvas-JuanVuletich-2021Jul20-12h41m-jmv.001.cs.st 7/20/2021 16:51:49'! -roundRect: aRectangle color: aColor radius: r gradientTop: topFactor gradientCenter: centerFactor gradientBottom: bottomFactor gradient1Height: h1 - self subclassResponsibility.! - -MorphicCanvas removeSelector: #roundRect:color:radius:gradientTop:gradientBottom:gradientHeight:! - -!methodRemoval: MorphicCanvas #roundRect:color:radius:gradientTop:gradientBottom:gradientHeight: stamp: 'Install-4684-WindowBitBltStuffToBitBltCanvas-JuanVuletich-2021Jul20-12h41m-jmv.001.cs.st 7/20/2021 16:51:49'! -roundRect: displayRectangle color: aColor radius: r gradientTop: topFactor gradientBottom: bottomFactor gradientHeight: h - self subclassResponsibility.! - -MorphicCanvas removeSelector: #windowFrame:color:radius:border:labelHeight:gradientTop:gradientBottom:insideColor:! - -!methodRemoval: MorphicCanvas #windowFrame:color:radius:border:labelHeight:gradientTop:gradientBottom:insideColor: stamp: 'Install-4684-WindowBitBltStuffToBitBltCanvas-JuanVuletich-2021Jul20-12h41m-jmv.001.cs.st 7/20/2021 16:51:49'! -windowFrame: aRectangle color: aColor radius: r border: bw labelHeight: lh gradientTop: topFactor gradientBottom: bottomFactor insideColor: insideColor - self subclassResponsibility.! - -MorphicCanvas removeSelector: #drawButtonRoundGradient:! - -!methodRemoval: MorphicCanvas #drawButtonRoundGradient: stamp: 'Install-4684-WindowBitBltStuffToBitBltCanvas-JuanVuletich-2021Jul20-12h41m-jmv.001.cs.st 7/20/2021 16:51:49'! -drawButtonRoundGradient: aPluggableButtonMorph - | r colorForButton rect bottomFactor topFactor color | - color _ aPluggableButtonMorph color. - aPluggableButtonMorph isPressed - ifFalse: [ - topFactor _ Theme current buttonGradientTopFactor. - bottomFactor _ Theme current buttonGradientBottomFactor. - aPluggableButtonMorph mouseIsOver - ifTrue: [ - colorForButton _ Color h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ - colorForButton _ color ]] - ifTrue: [ - topFactor _ Theme current buttonGradientBottomFactor. - bottomFactor _ Theme current buttonGradientTopFactor. - colorForButton _ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - Theme current useButtonGradient - ifTrue: [ - rect _ aPluggableButtonMorph morphLocalBounds insetBy: `1@3`. - self - roundRect: rect - color: colorForButton - radius: r - gradientTop: topFactor - gradientBottom: bottomFactor - gradientHeight: Theme current buttonGradientHeight ] - ifFalse: [ - rect _ aPluggableButtonMorph morphLocalBounds insetBy: `1@3`. - self roundRect: rect color: colorForButton radius: r ] - ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawButtonEmbossedLabel: aPluggableButtonMorph ] - ifFalse: [ self drawButtonRegularLabel: aPluggableButtonMorph ].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4684-WindowBitBltStuffToBitBltCanvas-JuanVuletich-2021Jul20-12h41m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4683] on 20 July 2021 at 1:48:24 pm'! - -KernelMorph subclass: #HaloHandleMorph - instanceVariableNames: 'mouseDownSelector mouseUpSelector mouseMoveSelector ' - classVariableNames: 'CircleForm ' - poolDictionaries: '' - category: 'Morphic-Halos'! - -!classDefinition: #HaloHandleMorph category: #'Morphic-Halos' stamp: 'Install-4685-HaloTweaks-JuanVuletich-2021Jul20-12h50m-jmv.001.cs.st 7/20/2021 16:51:49'! -KernelMorph subclass: #HaloHandleMorph - instanceVariableNames: 'mouseDownSelector mouseUpSelector mouseMoveSelector' - classVariableNames: 'CircleForm' - poolDictionaries: '' - category: 'Morphic-Halos'! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 7/20/2021 12:14:54' prior: 50540979! - haloHandleSize - ^ Preferences standardListFont pointSize * 5 // 3 max: 16! ! -!HaloHandleMorph methodsFor: 'drawing' stamp: 'jmv 7/20/2021 12:11:58' prior: 50503581 overrides: 16899205! - drawOn: aCanvas - - aCanvas - ellipseCenter: extent // 2 radius: extent // 2 borderWidth: 0 borderColor: nil fillColor: color! ! -!HaloMorph methodsFor: 'drawing' stamp: 'jmv 7/20/2021 12:30:56' prior: 50570776! - drawCoordinateSystemOn: aCanvas - - | x0 x1 y0 y1 c stepX stepY haloTargetTx prevTx | - haloTargetTx _ MorphicTranslation identity. - target allOwnersReverseDo: [ :o | haloTargetTx _ haloTargetTx composedWith: o location ]. - haloTargetTx _ haloTargetTx composedWith: target location. - - x0 _ x1 _ y0 _ y1 _ 0. - target displayFullBounds corners collect: [ :pt | | p | - p _ haloTargetTx inverseTransform: pt . - x0 _ x0 min: p x. - x1 _ x1 max: p x. - y0 _ y0 min: p y. - y1 _ y1 max: p y.]. - x1-x0 < 1000 ifTrue: [ - stepX _ 50. - stepY _ 20 ] - ifFalse: [ - stepX _ 100. - stepY _ 50 ]. - - prevTx _ aCanvas currentTransformation. - aCanvas geometryTransformation: haloTargetTx. - - c _ `Color black alpha: 0.4`. - aCanvas line: x0@0 to: x1@0 width: 2 color: c. - aCanvas line: 0@y0 to: 0@y1 width: 2 color: c. - - (x0 truncateTo: stepX) to: (x1 - stepX truncateTo: stepX) by: stepX do: [ :x | - aCanvas line: x @ -5 to: x @ 5 width: 2 color: c. - aCanvas drawString: x printString atCenterXBaselineY: x @ -10 font: nil color: c ]. - aCanvas drawString: 'x' atCenterX: x1 - 15 @ 0 font: nil color: c. - - (y0 truncateTo: stepY) to: (y1 - stepY truncateTo: stepY) by: stepY do: [ :y | - aCanvas line: -5 @ y to: 5 @ y width: 2 color: c. - aCanvas drawString: y printString, ' ' atWaistRight: -5 @ y font: nil color: c ]. - aCanvas drawString: 'y' atWaistRight: -5 @ (y1 - 20) font: nil color: c. - - aCanvas geometryTransformation: prevTx.! ! -!HaloMorph methodsFor: 'drawing' stamp: 'jmv 7/20/2021 12:36:34' prior: 50570957 overrides: 16899205! - drawOn: aCanvas - - | b | - target ifNil: [^super drawOn: aCanvas]. - - Preferences halosShowCoordinateSystem ifTrue: [ - target displayFullBounds ifNotNil: [ :fb | - aCanvas frameGlobalRect: fb borderWidth: 3 color: `Color black alpha: 0.3`. - b _ target displayBounds. - b = fb ifFalse: [ - b area > 0 ifTrue: [ - aCanvas frameGlobalRect: b borderWidth: 3 color: `Color black alpha: 0.3` ]]. - self drawCoordinateSystemOn: aCanvas ]].! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/20/2021 12:17:13' prior: 50540984! - addHandle: handleSpec - "Add a handle within the halo box as per the haloSpec, and set it up to respond to the given event by sending the given selector to the given recipient. Return the handle." - - | handle aPoint colorToUse form icon e | - aPoint _ self - positionIn: haloBox - horizontalPlacement: handleSpec horizontalPlacement - verticalPlacement: handleSpec verticalPlacement. - colorToUse _ Color colorFrom: handleSpec color. - handle _ HaloHandleMorph new color: colorToUse. - self addMorph: handle. - e _ Preferences haloHandleSize asPoint. - handle morphPosition: aPoint-(e//2) extent: e. - handleSpec iconSymbol ifNotNil: [ :iconName | - form _ self class icons at: iconName ifAbsent: [self class perform: iconName]. - form ifNotNil: [ - form extent = e ifFalse: [ - ": Non default size, scale that bugger!!" - form _ form ": Be as smooth as possible, these images are small." - magnify: form boundingBox - to: e - smoothing: 2 ]. - icon _ ImageMorph new - image: form; - color: colorToUse makeForegroundColor; - lock. - handle addMorphFront: icon position: `0@0` ]]. - handle mouseUpSelector: #endInteraction. - handle setBalloonText: handleSpec hoverHelp. - ^ handle! ! - -HaloHandleMorph class removeSelector: #circleForm:! - -!methodRemoval: HaloHandleMorph class #circleForm: stamp: 'Install-4685-HaloTweaks-JuanVuletich-2021Jul20-12h50m-jmv.001.cs.st 7/20/2021 16:51:49'! -circleForm: extent - " - CircleForm _ nil - " - | r d l bw center | - (CircleForm isNil or: [ CircleForm extent ~= extent ]) ifTrue: [ - center _ extent -1 * 0.5. - r _ center r * 0.75. - bw _ 1.3. - CircleForm _ Form extent: extent depth: 32. - 0 to: extent y - 1 do: [ :y | - 0 to: extent x - 1 do: [ :x | - d _ (x@y - center) r. - l _ (r - d max: 0.0) min: bw. - CircleForm - colorAt: x @ y - put: (`Color white` alpha: (l / bw)) - ]]. - ]. - ^CircleForm! - -HaloHandleMorph class removeSelector: #releaseClassCachedState! - -!methodRemoval: HaloHandleMorph class #releaseClassCachedState stamp: 'Install-4685-HaloTweaks-JuanVuletich-2021Jul20-12h50m-jmv.001.cs.st 7/20/2021 16:51:49'! -releaseClassCachedState - - CircleForm _ nil! - -KernelMorph subclass: #HaloHandleMorph - instanceVariableNames: 'mouseDownSelector mouseUpSelector mouseMoveSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Halos'! - -!classDefinition: #HaloHandleMorph category: #'Morphic-Halos' stamp: 'Install-4685-HaloTweaks-JuanVuletich-2021Jul20-12h50m-jmv.001.cs.st 7/20/2021 16:51:49'! -KernelMorph subclass: #HaloHandleMorph - instanceVariableNames: 'mouseDownSelector mouseUpSelector mouseMoveSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Halos'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4685-HaloTweaks-JuanVuletich-2021Jul20-12h50m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4683] on 20 July 2021 at 1:50:30 pm'! -!MorphicCanvas class methodsFor: 'services' stamp: 'jmv 7/20/2021 12:20:34'! - isVectorGraphicsActive - " - MorphicCanvas isVectorGraphicsActive - " - ^MorphicCanvas activeSubclass ~~ BitBltCanvas ! ! -!MorphicCanvas class methodsFor: 'services' stamp: 'jmv 7/20/2021 12:28:17'! - isVectorGraphicsPluginActive - " - MorphicCanvas isVectorGraphicsPluginActive - " - ^self isVectorGraphicsActive and: [ - (Smalltalk at: #VectorEngineWithPlugin) isPluginAvailable ]! ! -!MorphicCanvas class methodsFor: 'services' stamp: 'jmv 7/20/2021 12:21:10'! - isVectorGraphicsUsedForAllRendering - " - MorphicCanvas isVectorGraphicsUsedForAllRendering - " - ^MorphicCanvas activeSubclass name == #VectorCanvas! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 7/20/2021 12:28:28' prior: 50576971! - okayToRotateEasily - "Answer whether it is appropriate for a rotation handle to be shown for the receiver." - - ^ self hasOwnLocation and: [MorphicCanvas isVectorGraphicsPluginActive]! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 7/20/2021 12:28:33' prior: 50576890! - okayToScaleEasily - "Answer whether it is appropriate for a scale handle to be shown for the receiver." - - ^ self hasOwnLocation and: [MorphicCanvas isVectorGraphicsPluginActive]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4686-RotateZoomHandlesOnlyIfPluginVectorGraphics-JuanVuletich-2021Jul20-13h48m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4619] on 20 July 2021 at 2:33:16 pm'! -!FeatureRequirement methodsFor: 'requires' stamp: 'jmv 7/20/2021 14:32:53' prior: 50477288! - requireUnlessIn: toLoad main: mainFeatureOrNil requiringFeature: requiringFeatureOrNil - "See if all the requirements can be met and answer the load order" - - self isAlreadySatisfied ifFalse: [ - (toLoad anySatisfy: [ :featReq | featReq sameNameAs: self]) ifFalse: [ - (self findPackageFileAsReqOf: mainFeatureOrNil) - ifTrue: [ | otherRequirements | - otherRequirements := self requirements. - otherRequirements ifNotNil: [ - otherRequirements do: [ :requires | - requires requireUnlessIn: toLoad main: (mainFeatureOrNil ifNil: [self]) requiringFeature: self ]]. - self == mainFeatureOrNil ifFalse: [ - self addToLoad: toLoad withMyRequirements: otherRequirements ]. - ] - ifFalse: [ - | failureMessage | - failureMessage _ name = #'Cuis-Base' ifTrue: [ - 'Installing ', requiringFeatureOrNil name, String newLineString, - 'requires base system updated to #', self minRevision printString, String newLineString, - 'But this system is updated to #', SystemVersion current versionRevision second printString, String newLineString, - 'Please install Cuis base system updates' ] - ifFalse: [ - 'Installing', requiringFeatureOrNil name, String newLineString, - 'Requires: ', self printString ]. - FeatureRequirementUnsatisfied signal: failureMessage. - ]]]. - - ^ toLoad! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4687-BetterRequirementFailureMessage-JuanVuletich-2021Jul20-14h06m-jmv.001.cs.st----! - -----SNAPSHOT----(20 July 2021 16:51:52) Cuis5.0-4687-32.image priorSource: 7686126! - -----STARTUP---- (21 July 2021 20:11:23) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4687-32.image! - - -'From Cuis 5.0 [latest update: #4687] on 20 July 2021 at 11:02:51 pm'! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:42:18'! - draw3DLookOn: aCanvas - - | borderStyleSymbol c | - borderStyleSymbol _ self isPressed ifFalse: [ #raised ] ifTrue: [ #inset ]. - c _ color. - self mouseIsOver ifTrue: [ c _ c lighter ]. - aCanvas - fillRectangle: self morphLocalBounds - color: c - borderWidth: borderWidth - borderStyleSymbol: borderStyleSymbol - baseColorForBorder: c. - - self drawRegularLabelOn: aCanvas! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 4/24/2019 20:58:58'! -drawEmbossedLabelOn: aCanvas - - | availableW center colorForLabel f l labelMargin targetSize w x y | - label ifNotNil: [ - colorForLabel _ Theme current buttonLabel. - self isPressed - ifFalse: [ - self mouseIsOver - ifFalse: [ colorForLabel _ colorForLabel adjustSaturation: -0.10 brightness: 0.10 ]] - ifTrue: [ colorForLabel _ colorForLabel adjustSaturation: 0.0 brightness: -0.07 ]. - f _ self fontToUse. - center _ extent // 2. - labelMargin _ 3. - w _ f widthOfString: label. - availableW _ extent x - labelMargin - labelMargin. - availableW >= w - ifTrue: [ - l _ label ] - ifFalse: [ - x _ labelMargin. - targetSize _ label size * availableW // w. - l _ label squeezedTo: targetSize. - (f widthOfString: l) > availableW ifTrue: [ - targetSize _ targetSize - 1. - l _ label squeezedTo: targetSize ]]. - - w _ f widthOfString: l. - x _ center x - (w // 2). - y _ center y - (f lineSpacing // 2). - aCanvas - drawString: l - at: x@y - font: f - color: colorForLabel - embossed: true ]! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 4/24/2019 20:59:05'! - drawRegularLabelOn: aCanvas - - | w f center x y availableW l labelMargin | - - f _ self fontToUse. - center _ extent // 2. - - label ifNotNil: [ - labelMargin _ 4. - w _ f widthOfString: label. - availableW _ extent x - labelMargin - labelMargin - 1. - availableW >= w - ifTrue: [ - x _ center x - (w // 2). - l _ label ] - ifFalse: [ - x _ labelMargin. - l _ label squeezedTo: (label size * availableW / w) rounded ]. - y _ center y - (f lineSpacing // 2). - self isPressed ifTrue: [ - x _ x + 1. - y _ y + 1 ]. - aCanvas - drawString: l - at: x@y - font: f - color: Theme current buttonLabel ]! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 7/20/2021 22:47:56'! - drawRoundLookOn: aCanvas - | r colorForButton rect | - colorForButton _ self isPressed - ifFalse: [ - self mouseIsOver - ifTrue: [ Color h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ color ]] - ifTrue: [ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - rect _ self morphLocalBounds insetBy: `1@3`. - aCanvas roundRect: rect color: colorForButton radius: r ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawEmbossedLabelOn: aCanvas ] - ifFalse: [ self drawRegularLabelOn: aCanvas ].! ! -!MorphicCanvas methodsFor: 'drawing-widgets' stamp: 'jmv 7/20/2021 22:51:58'! - drawButtonIconFromCurrentMorph - "We assume that we are drawing a PluggableButtonMorph, - or some morph that conforms the required protocol. - Answer true if we were able to draw it." - - currentMorph iconDrawSelector ifNotNil: [ :selector | - self perform: selector. - ^true ]. - - currentMorph magnifiedIcon ifNotNil: [ :theIcon | - self pvtDrawButtonFaceForm: theIcon. - ^true ]. - - ^false! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 7/20/2021 22:52:40' prior: 50577502 overrides: 50545911! - drawOn: aCanvas - - self isRoundButton - ifTrue: [ - aCanvas drawButtonIconFromCurrentMorph ifFalse: [ - self drawRoundLookOn: aCanvas ]] - ifFalse: [ - self draw3DLookOn: aCanvas. - aCanvas drawButtonIconFromCurrentMorph ].! ! - -MorphicCanvas removeSelector: #drawButtonRegularLabel:! - -!methodRemoval: MorphicCanvas #drawButtonRegularLabel: stamp: 'Install-4688-moveSomeBackToPluggableButtonMorph-JuanVuletich-2021Jul20-22h31m-jmv.003.cs.st 7/21/2021 20:11:28'! -drawButtonRegularLabel: aPluggableButtonMorph - - | w f center x y availableW l labelMargin label | - - label _ aPluggableButtonMorph label. - f _ aPluggableButtonMorph fontToUse. - center _ aPluggableButtonMorph morphExtent // 2. - - label ifNotNil: [ - labelMargin _ 4. - w _ f widthOfString: label. - availableW _ aPluggableButtonMorph morphExtent x - labelMargin - labelMargin - 1. - availableW >= w - ifTrue: [ - x _ center x - (w // 2). - l _ label ] - ifFalse: [ - x _ labelMargin. - l _ label squeezedTo: (label size * availableW / w) rounded ]. - y _ center y - (f lineSpacing // 2). - aPluggableButtonMorph isPressed ifTrue: [ - x _ x + 1. - y _ y + 1 ]. - self - drawString: l - at: x@y - font: f - color: Theme current buttonLabel ]! - -MorphicCanvas removeSelector: #drawButtonIcon:! - -!methodRemoval: MorphicCanvas #drawButtonIcon: stamp: 'Install-4688-moveSomeBackToPluggableButtonMorph-JuanVuletich-2021Jul20-22h31m-jmv.003.cs.st 7/21/2021 20:11:28'! -drawButtonIcon: aPluggableButtonMorph - "We assume that we are drawing a PluggableButtonMorph, - or some morph that conforms the required protocol. - Answer true if we were able to draw it." - - aPluggableButtonMorph iconDrawSelector ifNotNil: [ :selector | - self perform: selector. - ^true ]. - - aPluggableButtonMorph magnifiedIcon ifNotNil: [ :theIcon | - self pvtDrawButtonFaceForm: theIcon. - ^true ]. - - ^false! - -MorphicCanvas removeSelector: #drawButton3D:! - -!methodRemoval: MorphicCanvas #drawButton3D: stamp: 'Install-4688-moveSomeBackToPluggableButtonMorph-JuanVuletich-2021Jul20-22h31m-jmv.003.cs.st 7/21/2021 20:11:28'! -drawButton3D: aPluggableButtonMorph - - | borderStyleSymbol c | - borderStyleSymbol _ aPluggableButtonMorph isPressed ifFalse: [ #raised ] ifTrue: [ #inset ]. - c _ aPluggableButtonMorph color. - aPluggableButtonMorph mouseIsOver ifTrue: [ c _ c lighter ]. - self - fillRectangle: aPluggableButtonMorph morphLocalBounds - color: c - borderWidth: aPluggableButtonMorph borderWidth - borderStyleSymbol: borderStyleSymbol - baseColorForBorder: c. - - self drawButtonRegularLabel: aPluggableButtonMorph.! - -MorphicCanvas removeSelector: #drawButton:! - -!methodRemoval: MorphicCanvas #drawButton: stamp: 'Install-4688-moveSomeBackToPluggableButtonMorph-JuanVuletich-2021Jul20-22h31m-jmv.003.cs.st 7/21/2021 20:11:28'! -drawButton: aPluggableButtonMorph - aPluggableButtonMorph isRoundButton - ifTrue: [ - (self drawButtonIcon: aPluggableButtonMorph) ifFalse: [ - self drawButtonRound: aPluggableButtonMorph ]] - ifFalse: [ - self drawButton3D: aPluggableButtonMorph. - self drawButtonIcon: aPluggableButtonMorph ]! - -MorphicCanvas removeSelector: #drawButtonEmbossedLabel:! - -!methodRemoval: MorphicCanvas #drawButtonEmbossedLabel: stamp: 'Install-4688-moveSomeBackToPluggableButtonMorph-JuanVuletich-2021Jul20-22h31m-jmv.003.cs.st 7/21/2021 20:11:28'! -drawButtonEmbossedLabel: aPluggableButtonMorph - - | availableW center colorForLabel f l labelMargin targetSize w x y label | - label _ aPluggableButtonMorph label. - label ifNotNil: [ - colorForLabel _ Theme current buttonLabel. - aPluggableButtonMorph isPressed - ifFalse: [ - aPluggableButtonMorph mouseIsOver - ifFalse: [ colorForLabel _ colorForLabel adjustSaturation: -0.10 brightness: 0.10 ]] - ifTrue: [ colorForLabel _ colorForLabel adjustSaturation: 0.0 brightness: -0.07 ]. - f _ aPluggableButtonMorph fontToUse. - center _ aPluggableButtonMorph morphExtent // 2. - labelMargin _ 3. - w _ f widthOfString: label. - availableW _ aPluggableButtonMorph morphExtent x - labelMargin - labelMargin. - availableW >= w - ifTrue: [ - l _ label ] - ifFalse: [ - x _ labelMargin. - targetSize _ label size * availableW // w. - l _ label squeezedTo: targetSize. - (f widthOfString: l) > availableW ifTrue: [ - targetSize _ targetSize - 1. - l _ label squeezedTo: targetSize ]]. - - w _ f widthOfString: l. - x _ center x - (w // 2). - y _ center y - (f lineSpacing // 2). - self - drawString: l - at: x@y - font: f - color: colorForLabel - embossed: true ]! - -MorphicCanvas removeSelector: #drawButtonRound:! - -!methodRemoval: MorphicCanvas #drawButtonRound: stamp: 'Install-4688-moveSomeBackToPluggableButtonMorph-JuanVuletich-2021Jul20-22h31m-jmv.003.cs.st 7/21/2021 20:11:28'! -drawButtonRound: aPluggableButtonMorph - | r colorForButton rect color | - color _ aPluggableButtonMorph color. - colorForButton _ aPluggableButtonMorph isPressed - ifFalse: [ - aPluggableButtonMorph mouseIsOver - ifTrue: [ Color h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ color ]] - ifTrue: [ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - rect _ aPluggableButtonMorph morphLocalBounds insetBy: `1@3`. - self roundRect: rect color: colorForButton radius: r ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawButtonEmbossedLabel: aPluggableButtonMorph ] - ifFalse: [ self drawButtonRegularLabel: aPluggableButtonMorph ].! - -PluggableButtonMorph removeSelector: #drawButtonRoundOn:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4688-moveSomeBackToPluggableButtonMorph-JuanVuletich-2021Jul20-22h31m-jmv.003.cs.st----! - -'From Cuis 5.0 [latest update: #4688] on 21 July 2021 at 12:09:48 pm'! - -LayoutAdjustingMorph subclass: #WindowEdgeAdjustingMorph - instanceVariableNames: 'selector coordinateGetter cursorKey ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -!classDefinition: #WindowEdgeAdjustingMorph category: #'Morphic-Layouts' stamp: 'Install-4689-LayoutAdjustingWithScalingAndRotation-JuanVuletich-2021Jul21-10h30m-jmv.005.cs.st 7/21/2021 20:11:28'! -LayoutAdjustingMorph subclass: #WindowEdgeAdjustingMorph - instanceVariableNames: 'selector coordinateGetter cursorKey' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 7/21/2021 10:40:53'! - referencePositionInOwner - ^self externalize: self rotationCenter! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 7/21/2021 11:38:57'! - morphBottomLeft - "Local coordinates - Must be consistent with #morphTopLef and #morphExtent" - - ^0 @ extent y.! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 7/21/2021 11:28:32'! - morphBottomRight - "Local coordinates - Must be consistent with #morphTopLef and #morphExtent" - - ^extent.! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 7/21/2021 11:28:51'! - morphTopRight - "Local coordinates - Must be consistent with #morphTopLef and #morphExtent" - - ^extent x @ 0.! ! -!Morph methodsFor: 'events' stamp: 'jmv 7/21/2021 12:08:56' prior: 16874501! - dragEvent: aMouseEvent localPosition: aPoint - - aMouseEvent hand halo: nil. - aMouseEvent hand grabMorph: self! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 4/8/2021 15:09:29' prior: 50567727! - grabMorph: aMorph delta: delta - "Grab the given morph (i.e., add it to this hand and remove it from its current owner)." - - | formerOwner formerPositionInWorld | - self releaseMouseFocus. "Break focus" - - "Grab the halo if present" - self halo ifNotNil: [ :h | - (h target == aMorph or: [h target hasOwner: aMorph]) ifTrue: [ - self addMorphBack: h position: h morphPositionInWorld - self morphPositionInWorld ]]. - - "Remember previous owner and position, in case the drop is later rejected" - formerOwner _ aMorph owner. - formerOwner ifNotNil: [ - formerPositionInWorld _ aMorph morphPositionInWorld. - grabMorphData - at: aMorph - put: { formerOwner. formerPositionInWorld. } ]. - self addMorphBack: aMorph position: delta. - - aMorph displayBounds ifNotNil: [ :r | | d | - formerPositionInWorld ifNotNil: [ - d _ aMorph morphPositionInWorld - formerPositionInWorld. - d isZero ifFalse: [ - aMorph adjustDisplayBoundsBy: d ]]]. - - aMorph justGrabbedFrom: formerOwner. - formerOwner ifNotNil: [ - lastPosition _ self morphPosition ].! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 7/21/2021 11:29:26' prior: 50545988 overrides: 50545058! - morphTopLeft - "Local coordinates. - Our hierarchy occupies a rectangle specified by #morphTopLef and #morphExtent" - - ^`0@0`.! ! -!WidgetMorph methodsFor: 'geometry testing' stamp: 'jmv 7/21/2021 11:57:06' prior: 50546016 overrides: 50532207! - isOrthoRectangularMorph - "True if we are of rectangular shape, aligned with local coordinate axes. - Doesn't take into account possible rotation of our or some owner's local coordinates. - Note: SystemWindow answers true, but implements #addPossiblyUncoveredAreasIn:to: to take care of rounded corners." - - ^self requiresVectorCanvas not! ! -!LayoutAdjustingMorph methodsFor: 'adjusting' stamp: 'jmv 7/21/2021 10:49:13' prior: 16862879! - adjustOwnerAt: aGlobalPoint - - owner - adjustBy: self - at: aGlobalPoint! ! -!LayoutAdjustingMorph methodsFor: 'stepping' stamp: 'jmv 7/21/2021 11:59:05' prior: 50569554 overrides: 50547622! - stepAt: millisecondSinceLast - "got the #mouseLeave: message" - | p | - hand ifNil: [ - Cursor currentCursor == self cursor ifTrue: [ Cursor defaultCursor activateCursor ]. - ^ self stopStepping ]. - "hasn't got the #mouseLeave: message (yet)" - p _ hand morphPosition. - hand lastMouseEvent mouseButton1Pressed - ifTrue: [ - self adjustOwnerAt: p. - (owner isOrthoRectangularMorph and: [ - Preferences cheapWindowReframe or: [ - millisecondSinceLast > 200]]) ifTrue: [ - owner displayBounds newRectFrom: [ :f | - self adjustOwnerAt: Sensor mousePoint. - owner morphPosition extent: owner morphExtent ]]] - ifFalse: [ - self stopStepping. - hand _ nil. - Cursor defaultCursor activateCursor ].! ! -!WindowEdgeAdjustingMorph methodsFor: 'initialization' stamp: 'jmv 7/21/2021 10:58:37' prior: 50471178! - initializeBottom - selector _ #windowBottom:. - cursorKey _ #resizeBottomCursor! ! -!WindowEdgeAdjustingMorph methodsFor: 'initialization' stamp: 'jmv 7/21/2021 10:58:42' prior: 50471185! - initializeBottomLeft - selector _ #windowBottomLeft:. - cursorKey _ #resizeBottomLeftCursor! ! -!WindowEdgeAdjustingMorph methodsFor: 'initialization' stamp: 'jmv 7/21/2021 10:59:29' prior: 50471193! - initializeBottomRight - selector _ #windowBottomRight:. - cursorKey _ #resizeBottomRightCursor! ! -!WindowEdgeAdjustingMorph methodsFor: 'initialization' stamp: 'jmv 7/21/2021 10:59:35' prior: 50471201! - initializeLeft - selector _ #windowLeft:. - cursorKey _ #resizeLeftCursor! ! -!WindowEdgeAdjustingMorph methodsFor: 'initialization' stamp: 'jmv 7/21/2021 10:59:39' prior: 50471208! - initializeRight - selector _ #windowRight:. - cursorKey _ #resizeRightCursor! ! -!WindowEdgeAdjustingMorph methodsFor: 'initialization' stamp: 'jmv 7/21/2021 10:59:44' prior: 50471215! - initializeTop - selector _ #windowTop:. - cursorKey _ #resizeTopCursor! ! -!WindowEdgeAdjustingMorph methodsFor: 'initialization' stamp: 'jmv 7/21/2021 10:59:54' prior: 50471222! - initializeTopLeft - selector _ #windowTopLeft:. - cursorKey _ #resizeTopLeftCursor! ! -!WindowEdgeAdjustingMorph methodsFor: 'initialization' stamp: 'jmv 7/21/2021 10:59:58' prior: 50471229! - initializeTopRight - selector _ #windowTopRight:. - cursorKey _ #resizeTopRightCursor! ! -!WindowEdgeAdjustingMorph methodsFor: 'adjusting' stamp: 'jmv 7/21/2021 10:58:28' prior: 16945096 overrides: 50579727! - adjustOwnerAt: aGlobalPoint - | pointInTargetOwners | - - owner ifNotNil: [ - pointInTargetOwners _ aGlobalPoint + 1. - owner owner ifNotNil: [ :parent | - pointInTargetOwners _ parent internalizeFromWorld: pointInTargetOwners ]. - owner perform: selector with: pointInTargetOwners ]! ! -!WindowEdgeAdjustingMorph methodsFor: 'drawing' stamp: 'jmv 7/21/2021 10:30:19' prior: 50578591 overrides: 50503568! - drawOn: aCanvas - - | c | - c _ owner windowFrameColor. - selector caseOf: { - [ #windowTopLeft: ] -> [ - aCanvas roundTopLeftCornerX: 0 y: 0 length: extent x border: owner borderWidth color: c ]. - [ #windowTopRight: ] -> [ - aCanvas roundTopRightCornerX: 0 y: 0 length: extent x border: owner borderWidth color: c ]. - [ #windowBottomLeft: ] -> [ - aCanvas roundBottomLeftCornerX: 0 y: 0 length: extent x border: owner borderWidth color: c ]. - [ #windowBottomRight: ] -> [ - aCanvas roundBottomRightCornerX: 0 y: 0 length: extent x border: owner borderWidth color: c ]. - } - otherwise: [ - "all the morph is sensitive for horizontal and vertical (i.e. non corner) instances." - aCanvas roundEdge: self morphLocalBounds color: c ].! ! -!LayoutMorph methodsFor: 'adjust' stamp: 'jmv 7/21/2021 10:42:59' prior: 50519945! - adjustBy: aLayoutAdjustMorph at: aGlobalPoint - "See Class Comment of LayoutAdjustingMorph" - - | localPoint | - localPoint _ self internalizeFromWorld: aGlobalPoint. - direction == #horizontal ifTrue: [ - self adjustHorizontallyBy: aLayoutAdjustMorph at: localPoint ]. - - direction == #vertical ifTrue: [ - self adjustVerticallyBy: aLayoutAdjustMorph at: localPoint ].! ! -!LayoutMorph methodsFor: 'adjust' stamp: 'jmv 7/21/2021 10:44:12' prior: 50520646! - adjustHorizontallyBy: aLayoutAdjustMorph at: localPoint - | delta l ls r rs lNewWidth rNewWidth i lCurrentWidth rCurrentWidth | - i _ submorphs indexOf: aLayoutAdjustMorph. - ((i = 1) or: [i = self submorphs size]) ifTrue: [ - self inform: 'LayoutAdjustingMorphs require morphs before and after'. - ^self - ]. - l _ self submorphs at: i +1. - ls _ l layoutSpec. - lCurrentWidth _ l morphWidth max: 1. "avoid division by zero" - r _ self submorphs at: i - 1. - rs _ r layoutSpec. - rCurrentWidth _ r morphWidth max: 1. "avoid division by zero" - delta _ localPoint x - aLayoutAdjustMorph referencePositionInOwner x. - delta _ delta max: l minimumShrinkWidth - lCurrentWidth. - delta _ delta min: rCurrentWidth - r minimumShrinkWidth. - delta = 0 ifTrue: [ ^self ]. - rNewWidth _ rCurrentWidth - delta. - lNewWidth _ lCurrentWidth + delta. - (ls isProportionalWidth and: [ rs isProportionalWidth ]) - ifTrue: [ | leftNewProportion rightNewProportion toDistribute | "If both proportional, update them" - leftNewProportion _ lNewWidth / (lNewWidth + rNewWidth). - rightNewProportion _ 1.0 - leftNewProportion. - toDistribute _ ls proportionalLayoutWidth + rs proportionalLayoutWidth. - ls setProportionalWidth: leftNewProportion * toDistribute. - rs setProportionalWidth: rightNewProportion * toDistribute ] - ifFalse: ["If at least one is fixed, update only the fixed" - ls isProportionalWidth ifFalse: [ - ls fixedOrMorphWidth: lNewWidth ]. - rs isProportionalWidth ifFalse: [ - rs fixedOrMorphWidth: rNewWidth ]]. - self layoutSubmorphs.! ! -!LayoutMorph methodsFor: 'adjust' stamp: 'jmv 7/21/2021 10:41:44' prior: 50520697! - adjustVerticallyBy: aLayoutAdjustMorph at: localPoint - | delta t ts b bs tNewHeight bNewHeight i tCurrentHeight bCurrentHeight | - i _ submorphs indexOf: aLayoutAdjustMorph. - ((i = 1) or: [i = self submorphs size]) ifTrue: [ - self inform: 'LayoutAdjustingMorphs require morphs above and below'. - ^self - ]. t _ self submorphs at: i +1. - ts _ t layoutSpec. - tCurrentHeight _ t morphHeight max: 1. "avoid division by zero" - b _ self submorphs at: i - 1. - bs _ b layoutSpec. - bCurrentHeight _ b morphHeight max: 1. "avoid division by zero" - delta _ localPoint y - aLayoutAdjustMorph referencePositionInOwner y. - delta _ delta max: t minimumShrinkHeight - tCurrentHeight. - delta _ delta min: bCurrentHeight - b minimumShrinkHeight. - delta = 0 ifTrue: [ ^self ]. - tNewHeight _ tCurrentHeight + delta. - bNewHeight _ bCurrentHeight - delta. - (ts isProportionalHeight and: [ bs isProportionalHeight ]) - ifTrue: [ | bottomNewProportion toDistribute topNewProportion | "If both proportional, update them" - topNewProportion _ tNewHeight / (tNewHeight + bNewHeight). - bottomNewProportion _ 1.0 - topNewProportion. - toDistribute _ ts proportionalLayoutHeight + bs proportionalLayoutHeight. - ts setProportionalHeight: topNewProportion * toDistribute. - bs setProportionalHeight: bottomNewProportion * toDistribute ] - ifFalse: ["If at least one is fixed, update only the fixed" - ts isProportionalHeight ifFalse: [ - ts fixedOrMorphHeight: tNewHeight ]. - bs isProportionalHeight ifFalse: [ - bs fixedOrMorphHeight: bNewHeight ]]. - self layoutSubmorphs! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 7/21/2021 12:01:11' prior: 50569815 overrides: 50539188! - addPossiblyUncoveredAreasIn: aRectangle to: aCollection - "Answer an array of rectangles encompassing those areas in aRectangle not completely - covered by self. These are the areas that might require further drawing (of morphs below us) - All areas that might possibly be uncovered must be included." - - | bounds radius | - self isOrthoRectangularMorph ifFalse: [ - aCollection add: aRectangle. - ^self ]. - - color mightBeTranslucent ifTrue: [ - aCollection add: aRectangle. - ^self ]. - - bounds _ self displayBounds. - bounds ifNil: [ - aCollection add: aRectangle. - ^self ]. - - "Solid rectangle. - This will be the fastest in many cases. So, please disable rounded corners if on slow hardware!!" - Theme current roundWindowCorners ifFalse: [ - aRectangle areasOutside: bounds do: [ :rect | aCollection add: rect ]. - ^self ]. - - "The solid rectangle does not include the corners. - Report a couple of rows (top and bottom) or columns (left and right) as uncovered areas. - We could also try to be more careful and answer each rounded corner... - Right now, report top and bottom rows as uncovered areas" - radius _ Theme current roundedWindowRadius. - aRectangle areasOutside: (bounds insetBy: 0@radius) do: [ :rect | aCollection add: rect ]! ! -!SystemWindow methodsFor: 'resizing' stamp: 'jmv 7/21/2021 11:43:49' prior: 16926671! - windowBottom: aPointInOwner - "aPointInOwner is in the owner's coordinate system" - - self morphHeight: (self internalize: aPointInOwner) y.! ! -!SystemWindow methodsFor: 'resizing' stamp: 'jmv 7/21/2021 11:39:10' prior: 16926678! - windowBottomLeft: aPointInOwner - "aPointInOwner is in the owner's coordinate system" - - | delta | - delta _ (self internalize: aPointInOwner) - self morphBottomLeft. - self morphExtent: self morphExtent + (delta x negated @ delta y). - self morphPosition: self morphPosition + aPointInOwner - (self externalize: self morphBottomLeft).! ! -!SystemWindow methodsFor: 'resizing' stamp: 'jmv 7/21/2021 11:12:57' prior: 16926689! - windowBottomRight: aPointInOwner - "aPointInOwner is in the owner's coordinate system" - - self morphExtent: (self internalize: aPointInOwner).! ! -!SystemWindow methodsFor: 'resizing' stamp: 'jmv 7/21/2021 11:52:58' prior: 16926696! - windowLeft: aPointInOwner - "aPointInOwner is in the owner's coordinate system" - - | cornerInOwner newPositionInOwnCoordinates | - cornerInOwner _ self externalize: extent. - newPositionInOwnCoordinates _ (self internalize: aPointInOwner) x @ 0. - self morphPosition: (self externalize: newPositionInOwnCoordinates). - self morphExtent: (self internalize: cornerInOwner).! ! -!SystemWindow methodsFor: 'resizing' stamp: 'jmv 7/21/2021 11:44:22' prior: 16926706! - windowRight: aPointInOwner - "aPointInOwner is in the owner's coordinate system" - - self morphWidth: (self internalize: aPointInOwner) x.! ! -!SystemWindow methodsFor: 'resizing' stamp: 'jmv 7/21/2021 11:53:56' prior: 16926713! - windowTop: aPointInOwner - "aPointInOwner is in the owner's coordinate system" - - | cornerInOwner newPositionInOwnCoordinates | - cornerInOwner _ self externalize: extent. - newPositionInOwnCoordinates _ 0 @ (self internalize: aPointInOwner) y. - self morphPosition: (self externalize: newPositionInOwnCoordinates). - self morphExtent: (self internalize: cornerInOwner).! ! -!SystemWindow methodsFor: 'resizing' stamp: 'jmv 7/21/2021 11:18:31' prior: 16926723! - windowTopLeft: aPointInOwner - "aPointInOwner is in the owner's coordinate system" - - | cornerInOwner | - cornerInOwner _ self externalize: extent. - self morphPosition: aPointInOwner. - self morphExtent: (self internalize: cornerInOwner).! ! -!SystemWindow methodsFor: 'resizing' stamp: 'jmv 7/21/2021 11:35:50' prior: 16926732! - windowTopRight: aPointInOwner - "aPointInOwner is in the owner's coordinate system" - - | delta | - delta _ (self internalize: aPointInOwner) - self morphTopRight. - self morphExtent: self morphExtent + (delta x @ delta y negated). - self morphPosition: self morphPosition + aPointInOwner - (self externalize: self morphTopRight).! ! - -LayoutAdjustingMorph subclass: #WindowEdgeAdjustingMorph - instanceVariableNames: 'selector cursorKey' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -!classDefinition: #WindowEdgeAdjustingMorph category: #'Morphic-Layouts' stamp: 'Install-4689-LayoutAdjustingWithScalingAndRotation-JuanVuletich-2021Jul21-10h30m-jmv.005.cs.st 7/21/2021 20:11:28'! -LayoutAdjustingMorph subclass: #WindowEdgeAdjustingMorph - instanceVariableNames: 'selector cursorKey' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4689-LayoutAdjustingWithScalingAndRotation-JuanVuletich-2021Jul21-10h30m-jmv.005.cs.st----! - -----SNAPSHOT----(21 July 2021 20:11:31) Cuis5.0-4689-32.image priorSource: 7925425! - -----STARTUP---- (6 August 2021 11:44:18) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4689-32.image! - - -'From Cuis 5.0 [latest update: #4689] on 22 July 2021 at 6:36:33 pm'! - -Object subclass: #MethodCategoriesPrompter - instanceVariableNames: 'startClass rejectingFirst prompt categories lines reject' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Text'! - -!classDefinition: #MethodCategoriesPrompter category: #'System-Text' stamp: 'Install-4690-CuisCore-JoaquinSingerHernanWilkinson-2021Jul22-15h23m-HAW.001.cs.st 8/6/2021 11:44:22'! -Object subclass: #MethodCategoriesPrompter - instanceVariableNames: 'startClass rejectingFirst prompt categories lines reject' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Text'! -!MethodCategoriesPrompter methodsFor: 'initialization' stamp: 'HAW 7/22/2021 17:12:06'! - initializeStaringFrom: aClass rejectingFirst: aRejectingFirst prompting: aPrompt - - startClass := aClass. - rejectingFirst := aRejectingFirst. - prompt := aPrompt ! ! -!MethodCategoriesPrompter methodsFor: 'value' stamp: 'HAW 7/22/2021 18:31:08'! - valueIfNone: aNoneBlock - - | selectedCategoryIndex categoryName | - - self initializeCategories. - - selectedCategoryIndex := self promptCategory. - selectedCategoryIndex = 0 ifTrue: [^ aNoneBlock value]. - - categoryName := selectedCategoryIndex = 1 ifTrue: [ self requestNewCategory ] ifFalse: [ categories at: selectedCategoryIndex ]. - categoryName isEmpty ifTrue: [ ^aNoneBlock value ]. - - ^categoryName - ! ! -!MethodCategoriesPrompter methodsFor: 'categories initialization - private' stamp: 'HAW 7/22/2021 18:16:53'! - addCategories - - startClass allSuperclasses do: [ :superclass | self addCategoriesOf: superclass ]! ! -!MethodCategoriesPrompter methodsFor: 'categories initialization - private' stamp: 'HAW 7/22/2021 18:20:44'! - addCategoriesOf: aSuperclass - - | superclassCategories | - - superclassCategories := aSuperclass methodCategoriesAsSortedCollection reject: [ :category | reject includes: category]. - - superclassCategories isEmpty ifFalse: [ - lines add: categories size. - categories addAll: superclassCategories. - reject addAll: superclassCategories]! ! -!MethodCategoriesPrompter methodsFor: 'categories initialization - private' stamp: 'HAW 7/22/2021 18:30:11'! - createCategories - - | classCategories | - - categories := OrderedCollection with: 'new ...'. - lines := OrderedCollection with: 1. - classCategories := startClass methodCategoriesAsSortedCollection. - - reject := classCategories asSet. - reject - add: ClassOrganizer nullCategory; - add: ClassOrganizer default. - - startClass isMeta ifTrue: [ self initializeCategoriesWhenMeta: classCategories]. - rejectingFirst ifFalse: [ categories addAll: classCategories ]! ! -!MethodCategoriesPrompter methodsFor: 'categories initialization - private' stamp: 'HAW 7/22/2021 18:30:11'! - initializeCategories - - self - createCategories; - addCategories! ! -!MethodCategoriesPrompter methodsFor: 'categories initialization - private' stamp: 'HAW 7/22/2021 18:21:19'! - initializeCategoriesWhenMeta: classCategories - - categories add: Categorizer instanceCreation. - classCategories remove: Categorizer instanceCreation ifAbsent: []. - reject add: Categorizer instanceCreation! ! -!MethodCategoriesPrompter methodsFor: 'prompting - private' stamp: 'HAW 7/22/2021 18:21:47'! - promptCategory - - | selectedLabelIndex | - - selectedLabelIndex := categories size = 1 - ifTrue: [ 1 ] - ifFalse: [ (PopUpMenu labelArray: categories lines: lines) startUpWithCaption: prompt ]. - - ^selectedLabelIndex! ! -!MethodCategoriesPrompter methodsFor: 'prompting - private' stamp: 'HAW 7/22/2021 17:18:46'! - requestNewCategory - - ^self request: 'New category name?' initialAnswer: 'category-name'! ! -!MethodCategoriesPrompter class methodsFor: 'instance creation' stamp: 'HAW 7/22/2021 17:10:52'! - staringFrom: aClass rejectingFirst: rejectingFirst prompting: aPrompt - - ^self new initializeStaringFrom: aClass rejectingFirst: rejectingFirst prompting: aPrompt -! ! -!CodeProvider methodsFor: 'categories' stamp: 'HAW 7/22/2021 17:09:38' prior: 50518882! - categoryFromUserWithPrompt: aPrompt for: aClass - "self new categoryFromUserWithPrompt: 'testing' for: SystemDictionary" - - ^(MethodCategoriesPrompter - staringFrom: aClass - rejectingFirst: false - prompting: aPrompt) valueIfNone: [ nil ]! ! -!Browser methodsFor: 'message category functions' stamp: 'HAW 7/22/2021 17:09:55' prior: 50518923! - newMethodCategoryNameIfNone: aNoneBlock - - ^(MethodCategoriesPrompter - staringFrom: self selectedClassOrMetaClass - rejectingFirst: true - prompting: 'Add Category') valueIfNone: aNoneBlock! ! -!Debugger methodsFor: 'context stack menu' stamp: 'HAW 7/22/2021 18:24:24' prior: 50576488! -askForCategoryIn: aClass default: aDefaultCategory - - ^(MethodCategoriesPrompter - staringFrom: aClass - rejectingFirst: false - prompting: 'Select category for the new method' ) valueIfNone: [ aDefaultCategory ]! ! - -MethodCategoriesPrompter removeSelector: #initializeCategoriesAndLines! - -MethodCategoriesPrompter removeSelector: #createCategoriesAndLines! - -MethodCategoriesPrompter removeSelector: #calculateCategoriesAndLines! - -MethodCategoriesPrompter removeSelector: #addMethodCategories! - -MethodCategoriesPrompter removeSelector: #selectedIndexFrom:separatedWith:propting:! - -MethodCategoriesPrompter removeSelector: #selectCategory! - -MethodCategoriesPrompter removeSelector: #addMethodCategoriesOf:! - -MethodCategoriesPrompter removeSelector: #initializeLabelsAndLines! - -MethodCategoriesPrompter removeSelector: #initializeLabelsWhenClassIsMeta:! - -Debugger removeSelector: #addCategoriesStartingFrom:to:separatingWith:! - -Debugger removeSelector: #addCategoriesStartingFrom:to:separatingWith:rejectingStartingCategories:! - -Debugger removeSelector: #addCategoriesOf:to:separatingWith:! - -!methodRemoval: Debugger #addCategoriesOf:to:separatingWith: stamp: 'Install-4690-CuisCore-JoaquinSingerHernanWilkinson-2021Jul22-15h23m-HAW.001.cs.st 8/6/2021 11:44:22'! -addCategoriesOf: aClass to: categories separatingWith: lines - - | classCategories reject | - - classCategories := aClass methodCategoriesAsSortedCollection. - reject := classCategories asSet. - aClass isMeta ifTrue: [ - categories add: Categorizer instanceCreation. - classCategories remove: Categorizer instanceCreation ifAbsent: []. - reject add: Categorizer instanceCreation]. - reject - add: ClassOrganizer nullCategory; - add: ClassOrganizer default. - categories addAll: classCategories. - - aClass allSuperclasses do: [ :superclass | | superclassCategories | - superclassCategories := superclass methodCategoriesAsSortedCollection reject: [ :cat | reject includes: cat]. - superclassCategories isEmpty ifFalse: [ - lines add: categories size. - categories addAll: superclassCategories. - reject addAll: superclassCategories]]. - -! - -CodeProvider removeSelector: #requestNewCategory! - -CodeProvider removeSelector: #addMethodCategoriesStartingFrom:to:separatingWith:rejecting:! - -CodeProvider removeSelector: #addCategoriesStartingFrom:rejectingStartingCategories:! - -CodeProvider removeSelector: #selectCategoryFrom:propting:ifNone:! - -CodeProvider removeSelector: #selectedIndexFrom:separatedWith:propting:! - -CodeProvider removeSelector: #methodCategoriesStartingFrom:rejectingFirst:! - -CodeProvider removeSelector: #addCategoriesOf:to:separatingWith:! - -CodeProvider removeSelector: #addCategoriesStartingFrom:to:separatingWith:! - -CodeProvider removeSelector: #addCategoriesStartingFrom:to:separatingWith:rejectingStartingCategories:! - -CodeProvider removeSelector: #addCategoriesStartingFrom:separatingWith:rejectingStartingCategories:! - -CodeProvider removeSelector: #selectCategoryFrom:separatedWith:propting:ifNone:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4690-CuisCore-JoaquinSingerHernanWilkinson-2021Jul22-15h23m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4690] on 25 July 2021 at 8:01:51 pm'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 7/25/2021 19:37:31' prior: 50568689! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('AY' 'Angel Yan') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('bgs' 'Boris G. Shingarov') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('db' 'Douglas Brebner') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('EB' 'Eric Brandwein') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('FGJ' 'Fernando Gasperi Jabalera') - #('FJG' 'Facundo Javier Gelatti') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hlsf' 'Hilaire Fernandes') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('jar' 'Jaromir Matas') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('KLG' 'Gerald Klix') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MM' 'Mariano Montone') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('pmon' 'Paolo Montrasi') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('sjd' 'Santiago Jose Dandois') - #('SLD' 'Steve Davies') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('ss' 'Sebastian Sujarchuk') - #('SSS' 'Samuel S. Shuster') - #('ST-80' 'Smalltalk-80, version 2, of April 1, 1983') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tsl' 'Thiago da Silva Lino') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4691-Add-ST-80-asKnownAuthor-JuanVuletich-2021Jul25-20h00m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4691] on 26 July 2021 at 9:05:09 am'! -!Object methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16880937! - yourself - "Answer self."! ! -!Object methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16882689! - errorImproperStore - "Create an error notification that an improper store was attempted." - - self error: 'Improper store into indexable object'! ! -!Object methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16882695! - errorNonIntegerIndex - "Create an error notification that an improper object was used as an index." - - self error: 'only integers should be used as indices'! ! -!Object methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16882747! - species - "Answer the preferred class for reconstructing the receiver. For example, - collections create new collections whenever enumeration messages such as - collect: or select: are invoked. The new kind of collection is determined by - the species of the original collection. Species and class are not always the - same. For example, the species of Interval is Array." - - ^self class! ! -!Object class methodsFor: 'documentation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16883027! - whatIsAPrimitive - "Some messages in the system are responded to primitively. A primitive - response is performed directly by the interpreter rather than by evaluating - expressions in a method. The methods for these messages indicate the - presence of a primitive response by including before the - first expression in the method. - - Primitives exist for several reasons. Certain basic or 'primitive' - operations cannot be performed in any other way. Smalltalk without - primitives can move values from one variable to another, but cannot add two - SmallIntegers together. Many methods for arithmetic and comparison - between numbers are primitives. Some primitives allow Smalltalk to - communicate with I/O devices such as the disk, the display, and the keyboard. - Some primitives exist only to make the system run faster; each does the same - thing as a certain Smalltalk method, and its implementation as a primitive is - optional. - - When the Smalltalk interpreter begins to execute a method which specifies a - primitive response, it tries to perform the primitive action and to return a - result. If the routine in the interpreter for this primitive is successful, - it will return a value and the expressions in the method will not be evaluated. - If the primitive routine is not successful, the primitive 'fails', and the - Smalltalk expressions in the method are executed instead. These - expressions are evaluated as though the primitive routine had not been - called. - - The Smalltalk code that is evaluated when a primitive fails usually - anticipates why that primitive might fail. If the primitive is optional, the - expressions in the method do exactly what the primitive would have done (See - Number @). If the primitive only works on certain classes of arguments, the - Smalltalk code tries to coerce the argument or appeals to a superclass to find - a more general way of doing the operation (see SmallInteger +). If the - primitive is never supposed to fail, the expressions signal an error (see - SmallInteger asFloat). - - Each method that specifies a primitive has a comment in it. If the primitive is - optional, the comment will say 'Optional'. An optional primitive that is not - implemented always fails, and the Smalltalk expressions do the work - instead. - - If a primitive is not optional, the comment will say, 'Essential'. Some - methods will have the comment, 'No Lookup'. See Object - howToModifyPrimitives for an explanation of special selectors which are - not looked up. - - For the primitives for +, -, *, and bitShift: in SmallInteger, and truncated - in Float, the primitive constructs and returns a 16-bit - LargePositiveInteger when the result warrants it. Returning 16-bit - LargePositiveIntegers from these primitives instead of failing is - optional in the same sense that the LargePositiveInteger arithmetic - primitives are optional. The comments in the SmallInteger primitives say, - 'Fails if result is not a SmallInteger', even though the implementor has the - option to construct a LargePositiveInteger. For further information on - primitives, see the 'Primitive Methods' part of the chapter on the formal - specification of the interpreter in the Smalltalk book." - - self error: 'comment only'! ! -!Switch methodsFor: 'state' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16918345! - switch - "Change the state of the receiver from 'on' to 'off' or from 'off' to 'on' (see - Switch|turnOn, Switch|turnOff)." - - self isOn - ifTrue: [self turnOff] - ifFalse: [self turnOn]! ! -!Switch class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16918403 overrides: 16783533! - new - "Answer an instance of me such that the on and off actions are set to nil - ('no action'), and the state is set to 'off'." - - ^self newOff! ! -!Boolean methodsFor: 'logical operations' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16790147! - eqv: aBoolean - "Answer true if the receiver is equivalent to aBoolean." - - ^self == aBoolean! ! -!Boolean methodsFor: 'copying' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16790326 overrides: 16881231! - shallowCopy - "Receiver has two concrete subclasses, True and False. - Only one instance of each should be made, so return self."! ! -!Boolean class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16790349 overrides: 16783533! - new - self error: 'You may not create any more Booleans - this is two-valued logic'! ! -!False methodsFor: 'logical operations' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16840417 overrides: 16790140! - & alternativeObject - "Evaluating conjunction -- answer false since receiver is false." - - ^self! ! -!False methodsFor: 'logical operations' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16840422 overrides: 16790152! - not - "Negation -- answer true since the receiver is false." - - ^true! ! -!False methodsFor: 'logical operations' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16840431 overrides: 16790158! - | aBoolean - "Evaluating disjunction (OR) -- answer with the argument, aBoolean." - - ^aBoolean! ! -!False methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16840436 overrides: 16790165! - and: alternativeBlock - "Nonevaluating conjunction -- answer with false since the receiver is false." - - ^self! ! -!False methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16840441 overrides: 16790222! - ifFalse: alternativeBlock - "Answer the value of alternativeBlock. Execution does not actually - reach here because the expression is compiled in-line." - - ^alternativeBlock value! ! -!False methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16840448 overrides: 16790236! - ifFalse: falseAlternativeBlock ifTrue: trueAlternativeBlock - "Answer the value of falseAlternativeBlock. Execution does not - actually reach here because the expression is compiled in-line." - - ^falseAlternativeBlock value! ! -!False methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16840457 overrides: 16790241! - ifTrue: alternativeBlock - "Since the condition is false, answer the value of the false alternative, - which is nil. Execution does not actually reach here because the - expression is compiled in-line." - - ^nil! ! -!False methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16840465 overrides: 16790255! - ifTrue: trueAlternativeBlock ifFalse: falseAlternativeBlock - "Answer the value of falseAlternativeBlock. Execution does not - actually reach here because the expression is compiled in-line." - - ^falseAlternativeBlock value! ! -!False methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16840474 overrides: 16790271! - or: alternativeBlock - "Nonevaluating disjunction -- answer value of alternativeBlock." - - ^alternativeBlock value! ! -!True methodsFor: 'logical operations' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16939769 overrides: 16790140! - & alternativeObject - "Evaluating conjunction -- answer alternativeObject since receiver is true." - - ^alternativeObject! ! -!True methodsFor: 'logical operations' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16939775 overrides: 16790152! - not - "Negation--answer false since the receiver is true." - - ^false! ! -!True methodsFor: 'logical operations' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16939785 overrides: 16790158! - | aBoolean - "Evaluating disjunction (OR) -- answer true since the receiver is true." - - ^self! ! -!True methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16939790 overrides: 16790165! - and: alternativeBlock - "Nonevaluating conjunction -- answer the value of alternativeBlock since - the receiver is true." - - ^alternativeBlock value! ! -!True methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16939796 overrides: 16790222! - ifFalse: alternativeBlock - "Since the condition is true, the value is the true alternative, which is nil. - Execution does not actually reach here because the expression is compiled - in-line." - - ^nil! ! -!True methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16939804 overrides: 16790236! - ifFalse: falseAlternativeBlock ifTrue: trueAlternativeBlock - "Answer the value of trueAlternativeBlock. Execution does not - actually reach here because the expression is compiled in-line." - - ^trueAlternativeBlock value! ! -!True methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16939813 overrides: 16790241! - ifTrue: alternativeBlock - "Answer the value of alternativeBlock. Execution does not actually - reach here because the expression is compiled in-line." - - ^alternativeBlock value! ! -!True methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16939820 overrides: 16790255! - ifTrue: trueAlternativeBlock ifFalse: falseAlternativeBlock - "Answer with the value of trueAlternativeBlock. Execution does not - actually reach here because the expression is compiled in-line." - - ^trueAlternativeBlock value! ! -!True methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16939829 overrides: 16790271! - or: alternativeBlock - "Nonevaluating disjunction -- answer true since the receiver is true." - - ^self! ! -!UndefinedObject methodsFor: 'copying' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16940070 overrides: 16881231! - shallowCopy - "Only one instance of UndefinedObject should ever be made, so answer - with self."! ! -!UndefinedObject class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16940236 overrides: 16783533! -new - self error: 'You may not create any more undefined objects--use nil'! ! -!Behavior methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16783027! - isFixed - "Answer whether the receiver does not have a variable (indexable) part." - - ^self isVariable not! ! -!Behavior methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16783057! - isPointers - "Answer whether the receiver contains just pointers (not bits)." - - ^self isBits not! ! -!Behavior methodsFor: 'compiling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16783323! - compileAll - ^ self compileAllFrom: self! ! -!Behavior methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16784815! - flushCache - "Tell the interpreter to remove the contents of its method lookup cache, if it has - one. Essential. See Object documentation whatIsAPrimitive." - - - self primitiveFailed! ! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16806753! - fileOutOn: aFileStream - "File a description of the receiver on aFileStream." - - self fileOutOn: aFileStream - moveSource: false - toFile: 0! ! -!ClassDescription methodsFor: 'instance variables' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16805852! - addInstVarName: aString - "Add the argument, aString, as one of the receiver's instance variables." - - self subclassResponsibility! ! -!ClassDescription methodsFor: 'organization' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16806301! - category - "Answer the system organization category for the receiver." - - ^SystemOrganization categoryOfElement: self name! ! -!ClassDescription methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16807052! - errorCategoryName - self error: 'Category name must be a String'! ! -!Metaclass methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16870966 overrides: 16783050! - isMeta - ^ true! ! -!Metaclass methodsFor: 'instance variables' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16871007 overrides: 50580986! - addInstVarName: aString - "Add the argument, aString, as one of the receiver's instance variables." - - | fullString | - fullString _ aString. - self instVarNames do: [:aString2 | fullString _ aString2 , ' ' , fullString]. - self instanceVariableNames: fullString! ! -!Metaclass methodsFor: 'pool variables' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16871032 overrides: 50527976! - classPool - "Answer the dictionary of class variables." - - ^thisClass classPool! ! -!Magnitude methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16865581 overrides: 16881029! - = aMagnitude - "Compare the receiver with the argument and answer with true if the - receiver is equal to the argument. Otherwise answer false." - - ^self subclassResponsibility! ! -!Magnitude methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16865606 overrides: 16881052! - hash - "Hash must be redefined whenever = is redefined." - - ^self subclassResponsibility! ! -!Number methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16880440! - even - "Answer whether the receiver is an even number." - - ^self \\ 2 = 0! ! -!Number methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16880476! - sign - "Answer 1 if the receiver is greater than 0, -1 if less than 0, else 0." - - self > 0 ifTrue: [^1]. - self < 0 ifTrue: [^-1]. - ^0! ! -!Number methodsFor: 'truncation and round off' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16880537! - floor - "Answer the integer nearest the receiver toward negative infinity." - - | truncation | - truncation _ self truncated. - self >= 0 ifTrue: [^truncation]. - self = truncation - ifTrue: [^truncation] - ifFalse: [^truncation - 1]! ! -!Float class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16845853 overrides: 50568324! - readFrom: aStream - "Answer a new Float as described on the stream, aStream." - - ^(super readFrom: aStream) asFloat! ! -!LargePositiveInteger methodsFor: 'arithmetic' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16862367 overrides: 16879678! - abs! ! -!Association methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16780903! - key: aKey value: anObject - "Store the arguments as the variables of the receiver." - - key _ aKey. - value _ anObject! ! -!Character class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16800996 overrides: 16783533! - new - "Creating new characters is not allowed." - - self error: 'cannot create new characters'! ! -!InstructionStream methodsFor: 'scanning' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16858216! - method - "Answer the compiled method that supplies the receiver's bytecodes." - - ^sender "method access when used alone (not as part of a context)"! ! -!InstructionStream methodsFor: 'scanning' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16858237! - pc - "Answer the index of the next bytecode." - - ^pc! ! -!ContextPart methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16823651! - home - "Answer the context in which the receiver was defined." - - self subclassResponsibility! ! -!ContextPart methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16823670! - receiver - "Answer the receiver of the message that created this context." - - self subclassResponsibility! ! -!ContextPart methodsFor: 'debugger access' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16824114! - sender - "Answer the context that sent the message that created the receiver." - - ^sender! ! -!ContextPart methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16824575! - top - "Answer the top of the receiver's stack." - - ^self at: stackp! ! -!Decompiler methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16831571! - blockReturnTop - "No action needed"! ! -!Message class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16867470! - selector: aSymbol - "Answer an instance of me with unary selector, aSymbol." - - ^self new setSelector: aSymbol arguments: (Array new: 0)! ! -!InputSensor methodsFor: 'keyboard' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16856301! -flushKeyboard - "Remove all characters from the keyboard buffer." - - [self keyboardPressed] - whileTrue: [self keyboard]! ! -!ProcessorScheduler methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16895607! - activePriority - "Answer the priority level of the currently running Process." - - ^activeProcess priority! ! -!ProcessorScheduler methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16895612! - activeProcess - "Answer the currently running Process." - - ^activeProcess! ! -!ProcessorScheduler methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16895621! - highestPriority - "Answer the number of priority levels currently available for use." - - ^quiescentProcessLists size! ! -!ProcessorScheduler methodsFor: 'process state change' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16895684! - suspendFirstAt: aPriority - "Suspend the first Process that is waiting to run with priority aPriority." - - ^self suspendFirstAt: aPriority - ifNone: [self error: 'No Process to suspend']! ! -!ProcessorScheduler methodsFor: 'process state change' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16895704! - terminateActive - "Terminate the process that is currently running." - - activeProcess terminate! ! -!ProcessorScheduler class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16895845 overrides: 16783533! - new - "New instances of ProcessorScheduler should not be created." - - self error: -'New ProcessSchedulers should not be created since -the integrity of the system depends on a unique scheduler'! ! -!Collection methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16813919 overrides: 16880927! - size - "Answer how many elements the receiver contains." - - | tally | - tally _ 0. - self do: [:each | tally _ tally + 1]. - ^tally! ! -!Collection methodsFor: 'enumerating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16814339! - do: aBlock - "Evaluate aBlock with each of the receiver's elements as the argument." - - self subclassResponsibility! ! -!Collection methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16814946! - 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! ! -!SequenceableCollection methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16905982! - 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! ! -!SequenceableCollection methodsFor: 'copying' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16906251 overrides: 16814138! - 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! ! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16906561! - 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! ! -!SequenceableCollection methodsFor: 'removing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16906950 overrides: 16814694! - remove: oldObject ifAbsent: anExceptionBlock - "SequencableCollections cannot implement removing." - - self shouldNotImplement! ! -!ArrayedCollection class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16780639 overrides: 16815113! - with: anObject - "Answer a new instance of me, containing only anObject." - - | newCollection | - newCollection _ self new: 1. - newCollection at: 1 put: anObject. - ^newCollection! ! -!ArrayedCollection class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16780647 overrides: 16815119! - 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! ! -!Array methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16779841 overrides: 16780275! - 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]! ! -!CompiledMethod methodsFor: 'literals' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16820102! - literalAt: index - "Answer the literal indexed by the argument." - - ^self objectAt: index + 1! ! -!CompiledMethod methodsFor: 'scanning' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16820193! - messages - "Answer a Set of all the message selectors sent by this method." - - | scanner aSet | - aSet _ Set new. - scanner _ InstructionStream on: self. - scanner - scanFor: - [:x | - scanner addSelectorTo: aSet. - false "keep scanning"]. - ^aSet! ! -!Interval methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16861170 overrides: 16880792! - at: anInteger put: anObject - "Storing into an Interval is not allowed." - - self error: 'you can not store into an interval'! ! -!Interval methodsFor: 'removing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16861230 overrides: 16814683! - remove: newObject - "Removing from an Interval is not allowed." - - self error: 'elements cannot be removed from an Interval'! ! -!Semaphore class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16905283 overrides: 16783533! - new - "Answer a new instance of Semaphore that contains no signals." - - ^self basicNew initSignals! ! -!OrderedCollection methodsFor: 'copying' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16883953 overrides: 50581234! - 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! ! -!Text methodsFor: 'emphasis' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16929479! - runLengthFor: characterIndex - "Answer the count of characters remaining in run beginning with - characterIndex." - - ^runs runLengthAt: characterIndex! ! -!Dictionary methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16833518 overrides: 16907352! - 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! ! -!Dictionary methodsFor: 'enumerating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16833694! - keysDo: aBlock - "Evaluate aBlock for each of the receiver's keys." - - self associationsDo: [:association | aBlock value: association key]! ! -!SharedQueue methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16907712 overrides: 16880927! - size - "Answer the number of objects that have been sent through the - receiver and not yet received by anyone." - - ^writePosition - readPosition! ! -!SharedQueue class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16907787 overrides: 16783533! - new - "Answer a new instance of SharedQueue that has 10 elements." - - ^self new: 10! ! -!PositionableStream methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16891203 overrides: 16914001! - contents - "Answer with a copy of my collection from 1 to readLimit." - - ^collection copyFrom: 1 to: readLimit! ! -!PositionableStream methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16891873! - 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'! ! -!ReadStream class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898063 overrides: 16892260! - 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! ! -!WriteStream methodsFor: 'character writing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16946501! - space - "Append a space character to the receiver." - - self nextPut: Character space! ! -!WriteStream methodsFor: 'character writing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16946512! - tab - "Append a tab character to the receiver." - - self nextPut: Character tab! ! -!ReadWriteStream methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898084 overrides: 16946360! - contents - "Answer with a copy of my collection from 1 to readLimit." - - readLimit _ readLimit max: position. - ^collection copyFrom: 1 to: readLimit! ! -!FileStream methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16843528 overrides: 16891209! -contentsOfEntireFile - "Read all of the contents of the receiver." - - | s | - self readOnly. - self reset. - s _ self next: self size. - self close. - ^s! ! -!Process methodsFor: 'changing suspended state' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16894253! - install: aContext - "Replace the suspendedContext with aContext." - - self == Processor activeProcess - ifTrue: [^self error: 'The active process cannot install contexts']. - suspendedContext _ aContext! ! -!Scanner methodsFor: 'error handling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16903866! - offEnd: aString - "Parser overrides this" - - ^self notify: aString! ! -!ReturnNode methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16901054 overrides: 16884669! - asReturnNode! ! -!Form methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16846749! -bits: aBitmap - "Reset the Bitmap containing the receiver's bits." - - bits _ aBitmap! ! -!Point methodsFor: 'point functions' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16890503! - dist: aPoint - "Answer the distance between aPoint and the receiver." - - ^(aPoint - self) r! ! -!Point methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16890716 overrides: 50508082! - printOn: aStream - "The receiver prints on aStream in terms of infix notation." - - x printOn: aStream. - aStream nextPut: $@. - y printOn: aStream! ! -!Rectangle methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898870! - containsPoint: aPoint - "Answer whether aPoint is within the receiver." - - ^origin <= aPoint and: [aPoint < corner]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4692-ST-80-timestamps-JuanVuletich-2021Jul26-09h01m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4691] on 26 July 2021 at 9:08:22 am'! -!Boolean methodsFor: 'logical operations' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16790140! - & aBoolean - "Evaluating conjunction -- Evaluate the argument. Then answer true if both the - receiver and the argument are true." - self subclassResponsibility! ! -!Boolean methodsFor: 'logical operations' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16790158! - | aBoolean - "Evaluating disjunction (OR) -- Evaluate the argument. Then answer true if - either the receiver or the argument is true." - self subclassResponsibility! ! -!Boolean methodsFor: 'logical operations' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16790152! - not - "Negation-- answer true if the receiver is false, answer false if the receiver is true." - self subclassResponsibility! ! -!Boolean methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16790165! - and: alternativeBlock - "Nonevaluating conjunction -- if the receiver is true, answer the value of - the argument, alternativeBlock; otherwise answer false without evaluating the - argument." - self subclassResponsibility! ! -!Boolean methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16790222! - ifFalse: alternativeBlock - "If the receiver is true (i.e., the condition is true), then the value is the true - alternative, which is nil. Otherwise answer the result of evaluating the argument, - alternativeBlock. Create an error if the receiver is nonBoolean. Execution does not - actually reach here because the expression is compiled in-line." - self subclassResponsibility! ! -!Boolean methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16790236! - ifFalse: falseAlternativeBlock ifTrue: trueAlternativeBlock - "Same as ifTrue:ifFalse:" - self subclassResponsibility! ! -!Boolean methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16790241! - ifTrue: alternativeBlock - "If the receiver is false (i.e., the condition is false), then the value is the false - alternative, which is nil. Otherwise answer the result of evaluating the argument, - alternativeBlock. Create an error if the receiver is nonBoolean. Execution does not - actually reach here because the expression is compiled in-line." - self subclassResponsibility! ! -!Boolean methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16790255! - ifTrue: trueAlternativeBlock ifFalse: falseAlternativeBlock - "If the receiver is true (i.e., the condition is true), then answer the value of the - argument trueAlternativeBlock. If the receiver is false, answer the result of - evaluating the argument falseAlternativeBlock. If the receiver is a nonBoolean - then create an error message. Execution does not actually reach here because the - expression is compiled in-line." - self subclassResponsibility! ! -!Boolean methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16790271! - or: alternativeBlock - "Nonevaluating disjunction -- if the receiver is false, answer the value of - the argument, alternativeBlock; otherwise answer true without evaluating the - argument." - self subclassResponsibility! ! -!Boolean methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16790335 overrides: 16882265! - storeOn: aStream - self printOn: aStream! ! -!False methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16840479 overrides: 50508082! - printOn: aStream - "Print false." - aStream nextPutAll: 'false'! ! -!True methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16939834 overrides: 50508082! - printOn: aStream - aStream nextPutAll: 'true'! ! -!UndefinedObject methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16940075 overrides: 50508082! - printOn: aStream - aStream nextPutAll: 'nil'! ! -!UndefinedObject methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16940080 overrides: 16882265! - storeOn: aStream - aStream nextPutAll: 'nil'! ! -!UndefinedObject methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16940117 overrides: 16896461! - isNil - ^true! ! -!UndefinedObject methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16940121 overrides: 16896466! - notNil - ^false! ! -!UndefinedObject methodsFor: 'dependents access' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16940125 overrides: 16881272! - addDependent: ignored - self error: 'Nil should not have dependents'! ! -!Number methodsFor: 'arithmetic' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16879621! - * aNumber - "Answer the result of multiplying the receiver by aNumber." - self subclassResponsibility! ! -!Number methodsFor: 'arithmetic' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16879626! - + aNumber - "Answer the sum of the receiver and aNumber." - self subclassResponsibility! ! -!Number methodsFor: 'arithmetic' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16879630! - - aNumber - "Answer the difference between the receiver and aNumber." - self subclassResponsibility! ! -!Number methodsFor: 'arithmetic' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16879635! - / aNumber - "Answer the result of dividing receiver by aNumber." - self subclassResponsibility! ! -!Number methodsFor: 'arithmetic' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16879678! - abs - "Answer a Number that is the absolute value (positive magnitude) of the receiver." - - self < 0 - ifTrue: [^self negated] - ifFalse: [^self]! ! -!Number methodsFor: 'arithmetic' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16879743! - negated - "Answer a Number that is the negation of the receiver." - ^0 - self! ! -!Number methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16879804! - @ y - "Answer a new Point whose x value is the receiver and whose y value is the - argument. Optional. No Lookup. See Object documentation whatIsAPrimitive." - - - ^Point x: self y: y! ! -!Number methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16879864! - asInteger - "Answer an integer nearest the receiver toward zero." - ^self truncated! ! -!Number methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16879876! - asPoint - "Answer a new Point with the receiver as both coordinates; - often used to supply the same value in two dimensions, as with - symmetrical gridding or scaling." - - ^self @ self! ! -!Number methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16879903! - degreesToRadians - "The receiver is assumed to represent degrees. Answer the - conversion to radians." - ^self asFloat degreesToRadians! ! -!Number methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16879939! - radiansToDegrees - "The receiver is assumed to represent radians. Answer the - conversion to degrees." - ^self asFloat radiansToDegrees! ! -!Number methodsFor: 'intervals' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16879959! - to: stop - "Answer an Interval from the receiver up to the argument, stop, - incrementing by 1." - - ^Interval from: self to: stop by: 1! ! -!Number methodsFor: 'intervals' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16879965! - to: stop by: step - "Answer an Interval from the receiver up to the argument, stop, - incrementing by step." - - ^Interval from: self to: stop by: step! ! -!Number methodsFor: 'mathematical functions' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16880099! - exp - "Answer the exponential of the receiver as a floating point number." - ^self asFloat exp! ! -!Number methodsFor: 'mathematical functions' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16880244! - squared - "Answer the receiver multipled by itself." - ^self * self! ! -!Number methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16880465! - odd - "Answer whether the receiver is an odd number." - ^self even == false! ! -!Number methodsFor: 'truncation and round off' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16880628! - truncated - "Answer an integer nearest the receiver toward zero." - ^self quo: 1! ! -!Float methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16844904 overrides: 50581706! - degreesToRadians - ^self * RadiansPerDegree! ! -!Float methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16844968 overrides: 50581713! - radiansToDegrees - ^self / RadiansPerDegree! ! -!Float class methodsFor: 'constants' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16845948! - pi - "Answer the constant, Pi." - ^Pi! ! -!Fraction methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16849619! - asFraction - "Answer with the receiver itself." - ^self! ! -!Fraction methodsFor: 'truncation and round off' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16849879 overrides: 50581752! - truncated - ^numerator quo: denominator! ! -!Fraction methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16849883! - denominator - ^denominator! ! -!Fraction methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16849885! - numerator - ^numerator! ! -!Fraction methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16849887! - reduced - | gcd numer denom | - numerator = 0 ifTrue: [^0]. - gcd _ numerator gcd: denominator. - numer _ numerator // gcd. - denom _ denominator // gcd. - denom = 1 ifTrue: [^numer]. - ^Fraction numerator: numer denominator: denom! ! -!Integer methodsFor: 'bit manipulation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16859110! - allMask: mask - "Treat the argument as a bit mask. Answer true if all of the - bits that are 1 in the argument are 1 in the receiver." - - ^mask = (self bitAnd: mask)! ! -!Integer methodsFor: 'bit manipulation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16859158! - anyMask: mask - "Treat the argument as a bit mask. Answer true if any of the - bits that are 1 in the argument are 1 in the receiver." - - ^0 ~= (self bitAnd: mask)! ! -!Integer methodsFor: 'bit manipulation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16859383! -noMask: mask - "Treat the argument as a bit mask. Answer true if none of the bits - that are 1 in the argument are 1 in the receiver." - - ^0 = (self bitAnd: mask)! ! -!Integer methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16859479! - asFraction - "Answer with a Fraction that represents the receiver." - - ^Fraction numerator: self denominator: 1! ! -!Integer methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16859488 overrides: 50581691! - asInteger - "Answer with the receiver itself." - - ^self! ! -!Integer methodsFor: 'enumerating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 50481644! - timesRepeat: aBlock - "Evaluate the argument, aBlock, the number of times represented by - the receiver." - - | count | - count _ 1. - [count <= self] - whileTrue: - [aBlock value. - count _ count + 1]! ! -!Integer methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16859936 overrides: 16882096! - isLiteral - ^true! ! -!Integer methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16860583! - growby: n - ^self growto: self digitLength + n! ! -!Integer methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16860586! - growto: n - ^self copyto: (self species new: n)! ! -!Integer class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16860824! - new: length neg: neg - "Answer an instance of a large integer whose size is length. neg is a flag determining - whether the integer is negative or not." - - neg - ifTrue: [^LargeNegativeInteger new: length] - ifFalse: [^LargePositiveInteger new: length]! ! -!LargeNegativeInteger methodsFor: 'arithmetic' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16862104 overrides: 50581077! - abs - ^self negated! ! -!LargeNegativeInteger methodsFor: 'arithmetic' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16862107 overrides: 16862369! - negated - ^self copyto: (LargePositiveInteger new: self digitLength)! ! -!SmallInteger methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16908840 overrides: 16860202! - even - ^(self bitAnd: 1) = 0! ! -!SmallInteger methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16908843 overrides: 50581746! - odd - ^(self bitAnd: 1) = 1! ! -!SmallInteger methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16908846 overrides: 16859391! - < aNumber - "Compare the receiver with the argument and answer with true if the receiver is less - than the argument. Otherwise answer false. Fail if the argument is not a - SmallInteger. Essential. No Lookup. See Object documentation whatIsAPrimitive." - - - ^super < aNumber! ! -!SmallInteger methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16908857 overrides: 16859402! - <= aNumber - "Compare the receiver with the argument and answer true if the receiver is less - than or equal to the argument. Otherwise answer false. Fail if the argument is - not a SmallInteger. Optional. No Lookup. See Object documentation - whatIsAPrimitive. " - - - ^super <= aNumber! ! -!SmallInteger methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16908868 overrides: 16859413! -= aNumber - "Compare the receiver with the argument and answer true if the receiver is - equal to the argument. Otherwise answer false. Fail if the argument is not a - SmallInteger. Essential. No Lookup. See Object documentation - whatIsAPrimitive. " - - - ^super = aNumber! ! -!SmallInteger methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16908879 overrides: 16859424! - > aNumber - "Compare the receiver with the argument and answer true if the receiver is - greater than the argument. Otherwise answer false. Fail if the argument is not a - SmallInteger. Essential. No Lookup. See Object documentation whatIsAPrimitive." - - - ^super > aNumber! ! -!SmallInteger methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16908890 overrides: 16859435! - >= aNumber - "Compare the receiver with the argument and answer true if the receiver is - greater than or equal to the argument. Otherwise answer false. Fail if the - argument is not a SmallInteger. Optional. No Lookup. See Object - documentation whatIsAPrimitive." - - - ^super >= aNumber! ! -!SmallInteger methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16908902 overrides: 16881037! - ~= aNumber - "Compare the receiver with the argument and answer true if the receiver is not - equal to the argument. Otherwise answer false. Fail if the argument is not a - SmallInteger. Essential. No Lookup. See Object documentation - whatIsAPrimitive. " - - - ^super ~= aNumber! ! -!LookupKey methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16865294! - key - "Answer the lookup key of the receiver." - ^key! ! -!LookupKey methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16865297! - key: anObject - "Store the argument, anObject, as the lookup key of the receiver." - key _ anObject! ! -!LookupKey methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16865307 overrides: 16865571! - < aLookupKey - ^key < aLookupKey key! ! -!LookupKey class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16865409! - key: aKey - "Answer a new instance of me with the argument as the lookup up." - ^self new key: aKey! ! -!Association methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16780908 overrides: 16881508! - value - "Answer the value of the receiver." - ^value! ! -!Association methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16780911! - value: anObject - "Store the argument, anObject, as the value of the receiver." - value _ anObject! ! -!Association class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16781010! - key: newKey value: newValue - "Answer a new instance of me with the arguments as the key and - value of the association." - ^(super key: newKey) value: newValue! ! -!MessageTally methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16870680 overrides: 16865571! - < aMessageTally - ^tally > aMessageTally tally! ! -!MessageTally methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16870693 overrides: 16865588! - > aMessageTally - ^tally < aMessageTally tally! ! -!MessageTally methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16870838! - class: aClass method: aMethod - class _ aClass. - method _ aMethod. - tally _ 0. - receivers _ Array new: 0! ! -!MessageTally methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16870849! - method - ^method! ! -!MessageTally methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16870851! - primitives: anInteger - tally _ anInteger. - receivers _ nil! ! -!MessageTally methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16870799! - tally - ^tally! ! -!Character methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16800477! - isAlphaNumeric - "Answer whether the receiver is a letter or a digit." - ^self isLetter or: [self isDigit]! ! -!Character methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16800581 overrides: 16882096! - isLiteral - ^true! ! -!Character methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16800583 overrides: 50508082! - printOn: aStream - aStream nextPut: $$. - aStream nextPut: self! ! -!Character methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16800587 overrides: 16882265! - storeOn: aStream - "Character literals are preceded by '$'." - aStream nextPut: $$; nextPut: self! ! -!Character methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16800592! - asCharacter - "Answer the receiver itself." - ^self! ! -!Character class methodsFor: 'constants' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16801187! - characterTable - "Answer the class variable in which unique Characters are stored." - ^CharacterTable! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4693-ST-80-timestamps-JuanVuletich-2021Jul26-09h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4690] on 25 July 2021 at 8:28:11 pm'! -!LargePositiveInteger methodsFor: 'system primitives' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16862772! - digitAt: index put: value - "Store the second argument (value) in the indexable field of the receiver - indicated by index. Fail if the value is negative or is larger than 255. Fail if the - index is not an Integer or is out of bounds. Answer with the value that was - stored. Essential. See Object documentation whatIsAPrimitive." - - - ^super at: index put: value! ! -!LargePositiveInteger methodsFor: 'system primitives' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16862786! - digitLength - "Answer with the number of indexable fields in the receiver. This value is the - same as the largest legal subscript. Essential. See Object documentation - whatIsAPrimitive." - - - self primitiveFailed! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4694-ST-80-timestamps-JuanVuletich-2021Jul25-20h22m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4690] on 25 July 2021 at 8:34:18 pm'! -!LargePositiveInteger commentStamp: 'jmv 7/25/2021 20:34:03' prior: 16862260! - I represent positive integers beyond the range of SmallInteger. They and are encoded here as an array of 8-bit digits. Care must be taken, when new values are computed, that any result that COULD BE a SmallInteger MUST BE a SmallInteger (see normalize). - -Note that the bit manipulation primitives, bitAnd:, bitShift:, etc., = and ~= run without failure (and therefore fast) if the value fits in 32 bits. This is a great help to the simulator.! -!LargePositiveInteger methodsFor: 'arithmetic' stamp: 'jmv 7/25/2021 20:29:54' prior: 16862278 overrides: 16858857! - * anInteger - "Primitive is optional. - See Object class >> #whatIsAPrimitive. " - - - ^super * anInteger.! ! -!LargePositiveInteger methodsFor: 'arithmetic' stamp: 'jmv 7/25/2021 20:30:04' prior: 16862290 overrides: 16858866! - + anInteger - "Primitive is optional. - See Object class >> #whatIsAPrimitive. " - - - ^super + anInteger.! ! -!LargePositiveInteger methodsFor: 'arithmetic' stamp: 'jmv 7/25/2021 20:30:14' prior: 16862302 overrides: 16858876! - - anInteger - "Primitive is optional. - See Object class >> #whatIsAPrimitive. " - - - ^super - anInteger.! ! -!LargePositiveInteger methodsFor: 'arithmetic' stamp: 'jmv 7/25/2021 20:30:39' prior: 16862314 overrides: 16858886! - / anInteger - "Primitive is optional. - See Object class >> #whatIsAPrimitive. " - - - ^super / anInteger.! ! -!LargePositiveInteger methodsFor: 'arithmetic' stamp: 'jmv 7/25/2021 20:30:54' prior: 16862329 overrides: 50468206! - // anInteger - "Primitive is optional. - See Object class >> #whatIsAPrimitive. " - - - ^super // anInteger.! ! -!LargePositiveInteger methodsFor: 'arithmetic' stamp: 'jmv 7/25/2021 20:32:41' prior: 16862344 overrides: 50510858! - \\ anInteger - "Primitive is optional. - See Object class >> #whatIsAPrimitive. " - - - ^super \\ anInteger.! ! -!LargePositiveInteger methodsFor: 'arithmetic' stamp: 'jmv 7/25/2021 20:32:54' prior: 16862375 overrides: 16858942! - quo: anInteger - "Primitive is optional. - See Object class >> #whatIsAPrimitive. " - - - ^super quo: anInteger.! ! -!LargePositiveInteger methodsFor: 'comparing' stamp: 'jmv 7/25/2021 20:31:02' prior: 16862460 overrides: 16859391! - < anInteger - "Primitive is optional. - See Object class >> #whatIsAPrimitive. " - - - ^super < anInteger.! ! -!LargePositiveInteger methodsFor: 'comparing' stamp: 'jmv 7/25/2021 20:31:21' prior: 16862473 overrides: 16859402! - <= anInteger - "Primitive is optional. - See Object class >> #whatIsAPrimitive. " - - - ^super <= anInteger.! ! -!LargePositiveInteger methodsFor: 'comparing' stamp: 'jmv 7/25/2021 20:31:57' prior: 16862486 overrides: 16859424! - > anInteger - "Primitive is optional. - See Object class >> #whatIsAPrimitive. " - - - ^super > anInteger.! ! -!LargePositiveInteger methodsFor: 'comparing' stamp: 'jmv 7/25/2021 20:32:06' prior: 16862499 overrides: 16859435! - >= anInteger - "Primitive is optional. - See Object class >> #whatIsAPrimitive. " - - - ^super >= anInteger.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4695-LargeInteger-fixComments-JuanVuletich-2021Jul25-20h28m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4695] on 26 July 2021 at 9:13:32 am'! -!Object methodsFor: 'updating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16881286! - changed - "Receiver changed in a general way; inform all the dependents by sending - each dependent an update: message." - - self changed: self! ! -!Object methodsFor: 'updating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16881312! - update: aParameter - "Receive a change notice from an object of whom the receiver is a dependent. - The default behavior is to do nothing; a subclass might want to change - itself in some way." - - ^self! ! -!FileList methodsFor: 'file name list' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16842398! - fileName - ^ fileName! ! -!Inspector methodsFor: 'doIt/accept/explain' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857076! - doItReceiver - "Answer the object that should be informed of the result of evaluating a - text selection." - ^object! ! -!Behavior methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16782773! - format - "Answer an Integer that encodes the kinds and numbers of variables of instances - of the receiver." - - ^format! ! -!Behavior methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16783243 overrides: 50508082! - printOn: aStream - aStream nextPutAll: 'a descendent of '. - superclass printOn: aStream! ! -!Behavior methodsFor: 'compiling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16782761! - compilerClass - "Return a compiler class appropriate for source methods of this class." - - ^Compiler! ! -!Behavior methodsFor: 'compiling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16783339! - decompile: selector - "Find the compiled code associated with the argument, selector, as a message selector - in the receiver's method dictionary and decompile it. Answer the resulting source - code as a string. Create an error if the selector is not in the receiver's method - dictionary." - - ^self decompilerClass new decompile: selector in: self! ! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16784142! - classVarNames - "Answer a Set of the receiver's class variable names. Since the receiver does - not retain knowledge of class variables, the method fakes it by creating an empty set." - - ^Set new! ! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16784233! - instanceCount - "Answer the number of instances of the receiver that are currently in use." - - | count | - count _ 0. - self allInstancesDo: [:x | count _ count + 1]. - ^count! ! -!Behavior methodsFor: 'creating method dictionary' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16783851! - methodDictionary: aDictionary - "Store the argument, aDictionary, as the method dictionary of the receiver." - - methodDict _ aDictionary! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4696-ST-80-timestamps-JuanVuletich-2021Jul26-09h11m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4695] on 26 July 2021 at 9:18:13 am'! -!Date class methodsFor: 'general inquiries' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16828497! - dateAndTimeNow - "Answer an array with first element Date today and second element Time now." - - ^Time dateAndTimeNow! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857689 overrides: 16857466! - blockReturnTop - "Print the ReturnTopOfStack bytecode." - self print: 'blockReturn'! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857701 overrides: 16857486! - doDup - "Print the Duplicate Top of Stack bytecode." - self print: 'dup'! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857706 overrides: 16857491! - doPop - "Print the Remove Top of Stack bytecode." - self print: 'pop'! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857732 overrides: 16857505! - methodReturnConstant: value - "Print the Return Constant bytecode." - self print: 'return: ' , value printString! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857738 overrides: 16857510! - methodReturnReceiver - "Print the Return Self bytecode." - self print: 'returnSelf'! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857743 overrides: 16857515! - methodReturnTop - "Print the Return Top of Stack bytecode." - self print: 'returnTop'! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857748 overrides: 16857520! - popIntoLiteralVariable: anAssociation - "Print the Removes the Top of the Stack and Stores it into a Literal Variable - bytecode." - self print: 'popIntoLit: ' , anAssociation key! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857755 overrides: 16857526! - popIntoReceiverVariable: offset - "Print the Removes the Top of the Stack and Stores it into an Instance Variable - bytecode." - self print: 'popIntoRcvr: ' , offset printString! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857771 overrides: 16857539! - popIntoTemporaryVariable: offset - "Print the Removes the Top of the Stack and Stores it into a Temporary Variable - bytecode." - self print: 'popIntoTemp: ' , offset printString! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857778 overrides: 16857545! - pushActiveContext - "Print the Push the Active Context on the Top of its Own Stack bytecode." - self print: 'pushThisContext: '! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857825 overrides: 16857571! - pushLiteralVariable: anAssociation - "Print the Push the Contents of anAssociation on the Top of the Stack bytecode." - self print: 'pushLit: ' , anAssociation key! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857838 overrides: 16857583! - pushReceiver - "Print the Push the Active Context's Receiver on the Top of the Stack bytecode." - self print: 'self'! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857844 overrides: 16857588! - pushReceiverVariable: offset - "Print the Push the Contents of the Receiver's Instance Variable whose Index - is the argument, offset, on the Top of the Stack bytecode." - self print: 'pushRcvr: ' , offset printString! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857861 overrides: 16857603! - pushTemporaryVariable: offset - "Print the Push the Contents of the Temporary Variable whose Index is the - argument, offset, on the Top of the Stack bytecode." - self print: 'pushTemp: ' , offset printString! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857888 overrides: 16857624! - storeIntoLiteralVariable: anAssociation - "Print the Store the Top of the Stack into a Literal Variable of the Method bytecode." - self print: 'storeIntoLit: ' , anAssociation key! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857896 overrides: 16857630! - storeIntoReceiverVariable: offset - "Print the Store the Top of the Stack into an Instance Variable of the Method - bytecode." - self print: 'storeIntoRcvr: ' , offset printString! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857912 overrides: 16857643! - storeIntoTemporaryVariable: offset - "Print the Store the Top of the Stack into a Temporary Variable of the Method - bytecode." - self print: 'storeIntoTemp: ' , offset printString! ! -!InstructionStream methodsFor: 'scanning' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16858191! - followingByte - "Answer the following bytecode." - ^self method at: pc + 1! ! -!InstructionStream methodsFor: 'scanning' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16858223! - nextByte - "Answer the next bytecode." - ^self method at: pc! ! -!InstructionStream methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16858417! - method: method pc: startpc - sender _ method. - "allows this class to stand alone as a method scanner" - pc _ startpc! ! -!InstructionStream class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16858774! - on: method - "Answer a new InstructionStream on the argument, method." - - ^self new method: method pc: method initialPC! ! -!ContextPart methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16823703! - doDup - "Simulates the action of a 'duplicate top of stack' bytecode." - - self push: self top! ! -!ContextPart methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16823708! - doPop - "Simulates the action of a 'remove top of stack' bytecode." - - self pop! ! -!ContextPart methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16823713! - jump: distance - "Simulates the action of a 'unconditional jump' bytecode whose - offset is the argument, distance." - - pc _ pc + distance! ! -!ContextPart methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16823805! - pushActiveContext - "Simulates the action of bytecode that pushes the the active - context on the top of its own stack." - - self push: self! ! -!ContextPart methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16823831! - pushConstant: value - "Simulates the action of bytecode that pushes the constant, value, on - the top of the stack." - - self push: value! ! -!ContextPart methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16823853! - pushReceiver - "Simulates the action of bytecode that pushes the the active - context's receiver on the top of the stack." - - self push: self receiver! ! -!ContextPart methodsFor: 'debugger access' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16823986! - depthBelow: aContext - "Answer how many calls between this and aContext." - | this depth | - this _ self. - depth _ 0. - [this == aContext or: [this == nil]] - whileFalse: - [this _ this sender. - depth _ depth + 1]. - ^depth! ! -!ContextPart methodsFor: 'debugger access' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16824230! - hasSender: context - "Answer true if the receiver is strictly above context on the stack." - - | s | - self == context ifTrue: [^false]. - s _ sender. - [s == nil] - whileFalse: - [s == context ifTrue: [^true]. - s _ s sender]. - ^false! ! -!ContextPart methodsFor: 'debugger access' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16824097! - releaseTo: caller - "Remove information from the receiver and the contexts on its - sender chain up to caller in order to break circularities." - - | c s | - c _ self. - [c == nil or: [c == caller]] - whileFalse: - [s _ c sender. - c singleRelease. - c _ s]! ! -!ContextPart methodsFor: 'debugger access' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16824150! - stack - "Answer an array of the contexts on the receiver's sender chain." - ^self stackOfSize: 9999! ! -!ContextPart methodsFor: 'debugger access' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16824167! - swapSender: coroutine - "Replace the receiver's sender with coroutine and answer the receiver's previous sender. - For use in coroutining." - - | oldSender | - oldSender _ sender. - sender _ coroutine. - ^oldSender! ! -!ContextPart methodsFor: 'system simulation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16824662! - step - "Simulate the execution of the receiver's next bytecode. - Answer the context that would be the active context - after this bytecode." - - ^self interpretNextInstructionFor: self! ! -!ContextPart methodsFor: 'temporaries' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16823690! - tempAt: index - "Answer the value of the temporary variable whose index is the argument, index." - self subclassResponsibility! ! -!ContextPart methodsFor: 'temporaries' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16823696! - tempAt: index put: value - "Store the argument, value, as the temporary variable whose - index is the argument, index." - self subclassResponsibility! ! -!ContextPart class methodsFor: 'examples' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16825445! - runSimulated: aBlock - "The simulator is a group of methods in class ContextPart which do what the - Smalltalk interpreter does. They execute Smalltalk bytecodes. By adding code - to the simulator, you could take statistics on the running of Smalltalk methods. - See also trace: callStatistics: and instructionStatistics: for sample uses" - - ^ thisContext sender - runSimulated: aBlock - contextAtEachStep: [:ignored] - - "ContextPart runSimulated: [Pen new defaultNib: 5; go: 100]"! ! -!MethodContext methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16871511 overrides: 16823656! - method - ^method! ! -!MethodContext methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16871528 overrides: 50581113! -receiver - ^receiver! ! -!MethodContext methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16871532! - removeSelf - "Nil the receiver pointer and answer the former value." - - | tempSelf | - tempSelf _ receiver. - receiver _ nil. - ^tempSelf! ! -!Decompiler methodsFor: 'control' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16831545! - statementsTo: end - | blockPos stackPos t | - "Decompile the method from pc up to end and return an array of - expressions. If at run time this block will leave a value on - the stack, set hasValue to true. If the block ends with a jump or return, - set exit to the destination of the jump, or the end of the method; - otherwise, set exit = end. Leave pc = end." - blockPos _ statements size. - stackPos _ stack size. - [pc < end] - whileTrue: - [lastPc _ pc. limit _ end. "for performs" - self interpretNextInstructionFor: self]. - "If there is an additional item on the stack, it will be the value - of this block." - (hasValue _ stack size > stackPos) - ifTrue: - [statements addLast: stack removeLast]. - lastJumpPc = lastPc ifFalse: [exit _ pc]. - ^self popTo: blockPos! ! -!Decompiler methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16831782! - methodReturnConstant: value - self pushConstant: value; methodReturnTop! ! -!Decompiler methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16831786! - methodReturnReceiver - self pushReceiver; methodReturnTop! ! -!Decompiler methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16831802! - popIntoLiteralVariable: value - self pushLiteralVariable: value; doStore: statements! ! -!Decompiler methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16831807! - popIntoReceiverVariable: offset - self pushReceiverVariable: offset; doStore: statements! ! -!Decompiler methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16831864! - pushActiveContext - stack addLast: constructor codeThisContext! ! -!Decompiler methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16831889! - pushConstant: value - | node | - node _ value == true ifTrue: [constTable at: 2] - ifFalse: [value == false ifTrue: [constTable at: 3] - ifFalse: [value == nil ifTrue: [constTable at: 4] - ifFalse: [constructor codeAnyLiteral: value]]]. - stack addLast: node! ! -!Decompiler methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16831899! - pushLiteralVariable: assoc - stack addLast: (constructor codeAnyLitInd: assoc)! ! -!Decompiler methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16831910! - pushReceiver - stack addLast: (constTable at: 1)! ! -!Decompiler methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16832012! - storeIntoLiteralVariable: assoc - self pushLiteralVariable: assoc; doStore: stack! ! -!Decompiler methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16832017! - storeIntoReceiverVariable: offset - self pushReceiverVariable: offset; doStore: stack! ! -!Decompiler methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16832030! - storeIntoTemporaryVariable: offset - self pushTemporaryVariable: offset; doStore: stack! ! -!Decompiler methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16832154! - popTo: oldPos - | t | - t _ Array new: statements size - oldPos. - (t size to: 1 by: -1) do: - [:i | t at: i put: statements removeLast]. - ^t! ! -!Message methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16867355! - arguments - "Answer the arguments of the receiver." - ^args! ! -!Message methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16867366! - selector - "Answer the selector of the receiver." - ^selector! ! -!Message methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16867403! - setSelector: aSymbol arguments: anArray - selector _ aSymbol. - args _ anArray! ! -!Message class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16867476! - selector: aSymbol argument: anObject - "Answer an instance of me whose selector is aSymbol and single argument - is anObject." - - ^self new setSelector: aSymbol arguments: (Array with: anObject)! ! -!Message class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16867484! - selector: aSymbol arguments: anArray - "Answer an instance of me with selector, aSymbol, and arguments, - anArray." - - ^self new setSelector: aSymbol arguments: anArray! ! -!Delay methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16832768! - resumptionTime - "Answer the value of the system's millisecondClock at which the receiver's - suspended Process will resume." - - ^resumptionTime! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4697-ST-80-timestamps-JuanVuletich-2021Jul26-09h13m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4695] on 26 July 2021 at 9:24:54 am'! -!InputSensor methodsFor: 'mouse' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16856457! - mousePoint - "Answer a Point indicating the coordinates of the current mouse location." - ^self primMousePt! ! -!InputSensor methodsFor: 'mouse' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16856505! -waitClickButton - "Wait for the user to click (press and then release) any mouse button and then - answer with the current location of the cursor." - self waitButton. - ^self waitNoButton! ! -!ProcessorScheduler methodsFor: 'removing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16895673! - remove: aProcess ifAbsent: aBlock - "Remove aProcess from the list on which it is waiting for the processor. If - it is not waiting, evaluate aBlock." - - (quiescentProcessLists at: aProcess priority) - remove: aProcess ifAbsent: aBlock. - ^aProcess! ! -!ProcessorScheduler methodsFor: 'process state change' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16895692! - suspendFirstAt: aPriority ifNone: noneBlock - "Suspend the first Process that is waiting to run with priority aPriority. - If no Process is waiting, evaluate noneBlock" - - | aList | - aList _ quiescentProcessLists at: aPriority. - aList isEmpty - ifTrue: [^noneBlock value] - ifFalse: [^aList first suspend]! ! -!Collection methodsFor: 'adding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16813962! - add: newObject - "Include newObject as one of the receiver's elements. Answer newObject. - This message should not be sent to instances of subclasses of ArrayedCollection." - - self subclassResponsibility! ! -!Collection methodsFor: 'adding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16813977! - addAll: aCollection - "Include all the elements of aCollection as the receiver's elements. Answer - aCollection." - - aCollection do: [:each | self add: each]. - ^aCollection! ! -!Collection methodsFor: 'enumerating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16814191! - collect: aBlock - "Evaluate aBlock with each of the receiver's elements as the argument. Collect the - resulting values into a collection that is like the receiver. Answer the new - collection. " - - | newCollection | - newCollection _ self species new. - self do: [:each | newCollection add: (aBlock value: each)]. - ^newCollection! ! -!Collection methodsFor: 'enumerating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16814267! - 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." - - self do: [:each | (aBlock value: each) ifTrue: [^each]]. - ^exceptionBlock value! ! -!Collection methodsFor: 'enumerating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16814413! - inject: thisValue into: binaryBlock - "Accumulate a running value associated with evaluating the argument, - binaryBlock, with the current value and the receiver as block arguments. - The initial value is the value of the argument, thisValue. - For instance, to sum a collection, use: - collection inject: 0 into: [:subTotal :next | subTotal + next]." - - | nextValue | - nextValue _ thisValue. - self do: [:each | nextValue _ binaryBlock value: nextValue value: each]. - ^nextValue! ! -!Collection methodsFor: 'enumerating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16814457! - 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]! ! -!Collection methodsFor: 'enumerating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16814468! - 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! ! -!Collection methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16814619 overrides: 16882265! -storeOn: aStream - | 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: $)! ! -!Collection methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16814634! - emptyCheck - self isEmpty ifTrue: [self errorEmptyCollection]! ! -!Collection methodsFor: 'removing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16814694! - remove: oldObject ifAbsent: anExceptionBlock - "Remove oldObject as one of the receiver's elements. If several of the - elements are equal to oldObject, only one is removed. If no element is equal to - oldObject, answer the result of evaluating anExceptionBlock. Otherwise, - answer the argument, oldObject. - - SequenceableCollections can not respond to this message." - - self subclassResponsibility! ! -!Collection methodsFor: 'removing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16814709! - removeAll: aCollection - "Remove each element of aCollection from the receiver. If successful for each, - answer aCollection." - - aCollection do: [:each | self remove: each]. - ^aCollection! ! -!SequenceableCollection methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16905706! - indexOf: anElement - "Answer the index of anElement within the receiver. If the receiver does - not contain anElement, answer 0." - - ^self indexOf: anElement ifAbsent: [0]! ! -!SequenceableCollection methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16905758! - 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]! ! -!SequenceableCollection methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16905930! - 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! ! -!SequenceableCollection methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16905945! - 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 collection, replacement. Answer the - receiver. No range checks are performed - this may be primitively implemented." - - | index repOff | - repOff _ repStart - start. - index _ start - 1. - [(index _ index + 1) <= stop] - whileTrue: [self at: index put: (replacement at: repOff + index)]! ! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16906725! - 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 in do:." - - self size to: 1 by: -1 do: [:index | aBlock value: (self at: index)]! ! -!SequenceableCollection methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16906931! -errorOutOfBounds - self error: 'indices are out of bounds'! ! -!ArrayedCollection methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16780261 overrides: 50581199! - size - "Answer the number of indexable fields in the receiver. This value is the - same as the largest legal subscript. Primitive is specified here to override - SequenceableCollection size. Essential. See Object documentation - whatIsAPrimitive. " - - - ^self basicSize! ! -!ArrayedCollection methodsFor: 'adding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16780272 overrides: 50582864! - add: newObject - self shouldNotImplement! ! -!ArrayedCollection methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16780275 overrides: 50582953! - storeOn: aStream - aStream nextPutAll: '(('. - aStream nextPutAll: self class name. - aStream nextPutAll: ' new: '. - aStream store: self size. - aStream nextPut: $). - (self storeElementsFrom: 1 to: self size on: aStream) - ifFalse: [aStream nextPutAll: '; yourself']. - aStream nextPut: $)! ! -!ArrayedCollection methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16780286! - defaultElement - ^nil! ! -!ArrayedCollection methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16780289! - storeElementsFrom: firstIndex to: lastIndex on: aStream - | noneYet defaultElement arrayElement | - noneYet _ true. - defaultElement _ self defaultElement. - firstIndex to: lastIndex do: - [:index | - arrayElement _ self at: index. - arrayElement = defaultElement - ifFalse: - [noneYet - ifTrue: [noneYet _ false] - ifFalse: [aStream nextPut: $;]. - aStream nextPutAll: ' at: '. - aStream store: index. - aStream nextPutAll: ' put: '. - aStream store: arrayElement]]. - ^noneYet! ! -!ArrayedCollection class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16780595! - new: size withAll: value - "Answer a new instance of me, whose every element is equal to the argument, - value." - - ^(self new: size) atAllPut: value! ! -!ArrayedCollection class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16780657 overrides: 16815127! - with: firstObject with: secondObject with: thirdObject - "Answer a new instance of me, containing only these three objects." - - | newCollection | - newCollection _ self new: 3. - newCollection at: 1 put: firstObject. - newCollection at: 2 put: secondObject. - newCollection at: 3 put: thirdObject. - ^newCollection! ! -!ArrayedCollection class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16780669 overrides: 16815137! - with: firstObject with: secondObject with: thirdObject with: fourthObject - "Answer a new instance of me, containing the four arguments as the 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! ! -!String methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16915802! - string - "Answer the receiver itself. This is for compatibility with other text classes." - ^self! ! -!String methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16916420 overrides: 16881101! - asString - "Answer the receiver itself." - ^self! ! -!String methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16916423! - asSymbol - "Answer the unique symbol whose characters are the characters of the string." - ^Symbol intern: self! ! -!String methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16916428! - asText - "Answer a Text whose string is the receiver." - ^Text fromString: self! ! -!String methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16917109 overrides: 16882096! - isLiteral - ^true! ! -!String class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16917898 overrides: 16882927! - readFrom: inStream - "Answer a new String that is determined by reading the stream, inStream. Embedded - double quotes become the quote Character." - - | outStream char done | - outStream _ WriteStream on: (String new: 16). - "go to first quote" - inStream skipTo: $'. - done _ false. - [done or: [inStream atEnd]] - whileFalse: - [char _ inStream next. - char = $' - ifTrue: - [char _ inStream next. - char = $' - ifTrue: [outStream nextPut: char] - ifFalse: [done _ true]] - ifFalse: [outStream nextPut: char]]. - ^outStream contents! ! -!Symbol methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16918436 overrides: 50463991! - at: anInteger put: anObject - "you can not modify the receiver." - - self errorNoModification! ! -!Symbol methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16918457 overrides: 50335640! - replaceFrom: start to: stop with: replacement startingAt: repStart - self errorNoModification! ! -!Symbol methodsFor: 'copying' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16918471 overrides: 16881231! - shallowCopy - "Answer with me, because Symbols are unique."! ! -!Symbol methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16918475 overrides: 50583177! - asString - | newString | - newString _ String new: self size. - 1 to: self size do: [:index | newString at: index put: (self at: index)]. - ^newString! ! -!Symbol methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16918483 overrides: 50583182! - asSymbol! ! -!Symbol methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16918536! - errorNoModification - self error: 'symbols can not be modified.'! ! -!Symbol methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16918540 overrides: 50463970! - species - ^String! ! -!Symbol methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16918542! - string: aString - 1 to: aString size do: [:j | super at: j put: (aString at: j)]. - ^self! ! -!ByteArray methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16793798 overrides: 50583109! - defaultElement - ^0! ! -!CompiledMethod methodsFor: 'literals' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16820061! - header - "Answer the word containing the information about the form of the - receiver and the form of the context needed to run the receiver." - - ^self objectAt: 1! ! -!CompiledMethod methodsFor: 'literals' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16820107! - literalAt: index put: value - "Replace the literal indexed by the first argument with the - second argument." - - ^self objectAt: index + 1 put: value! ! -!CompiledMethod methodsFor: 'literals' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16820144! - objectAt: index - "Answer with the method header (if index=1) or a literal (if index >1) from the - receiver. Essential. See Object documentation whatIsAPrimitive." - - - self primitiveFailed! ! -!CompiledMethod methodsFor: 'literals' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16820153! - objectAt: index put: value - "Store the value argument into a literal in the receiver. An index of 2 - corresponds to the first literal. Fails if the index is less than 2 or greater than - the number of literals. Answer the value as the result. Normally only the - compiler sends this message, because only the compiler stores values in - CompiledMethods. Essential. See Object documentation whatIsAPrimitive." - - - self primitiveFailed! ! -!CompiledMethod methodsFor: 'scanning' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16820284! - scanLongLoad: extension - "Answer whether the receiver contains a long load whose extension is the - argument." - - | scanner | - scanner _ InstructionStream on: self. - ^scanner scanFor: [:instr | instr = 128 and: [scanner followingByte = extension]]! ! -!Interval methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16861181 overrides: 16905641! - first - ^start! ! -!Interval methodsFor: 'adding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16861226 overrides: 50582864! - add: newObject - "Adding to an Interval is not allowed." - self shouldNotImplement! ! -!Interval methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16861269 overrides: 50582953! - storeOn: aStream - "This is possible because we know numbers store and print the same" - - self printOn: aStream! ! -!Interval methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16861285 overrides: 50463970! - species - ^Array! ! -!LinkedList methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16864798 overrides: 16905641! - first - "Answer the first link; create an error if the receiver is empty." - - self emptyCheck. - ^firstLink! ! -!LinkedList methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16864804 overrides: 16905811! - last - "Answer the last link; create an error if the receiver is empty." - - self emptyCheck. - ^lastLink! ! -!LinkedList methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16864809 overrides: 16814924! - isEmpty - ^firstLink == nil! ! -!LinkedList methodsFor: 'adding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16864812 overrides: 50582864! - add: aLink - "Add aLink to the end of the receiver's list." - - ^self addLast: aLink! ! -!LinkedList methodsFor: 'adding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16864830! - addFirst: aLink - "Add aLink to the beginning of the receiver's list." - - self isEmpty ifTrue: [lastLink _ aLink]. - aLink nextLink: firstLink. - firstLink _ aLink. - ^aLink! ! -!LinkedList methodsFor: 'adding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16864837! -addLast: aLink - "Add aLink to the end of the receiver's list." - - self isEmpty - ifTrue: [firstLink _ aLink] - ifFalse: [lastLink nextLink: aLink]. - lastLink _ aLink. - ^aLink! ! -!LinkedList methodsFor: 'removing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16864865! - removeFirst - "Remove the first element. If the receiver is empty, cause an error; - otherwise answer the removed element. Using the sequence addFirst:/removeFirst - causes the receiver to behave as a stack; using addLast:/removeFirst causes the - receiver to behave as a queue." - - | oldLink | - self emptyCheck. - oldLink _ firstLink. - firstLink == lastLink - ifTrue: [firstLink _ nil. lastLink _ nil] - ifFalse: [firstLink _ oldLink nextLink]. - oldLink nextLink: nil. - ^oldLink! ! -!LinkedList methodsFor: 'removing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16864876! - removeLast - "Remove the receiver's last element. If the receiver is empty, cause an error; - otherwise answer the removed element. Using addLast:/removeLast causes the - receiver to behave as a stack; using addFirst:/removeLast causes the receiver to - behave as a queue." - - | 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! ! -!LinkedList methodsFor: 'enumerating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16864892 overrides: 16906383! - do: aBlock - | aLink | - aLink _ firstLink. - [aLink == nil] whileFalse: - [aBlock value: aLink. - aLink _ aLink nextLink]! ! -!Semaphore methodsFor: 'communication' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16905087! - signal - "Send a signal through the receiver. If one or more processes have been - suspended trying to receive a signal, allow the first one to proceed. If no - process is waiting, remember the excess signal. Essential. See Object documentation - whatIsAPrimitive. " - - - self primitiveFailed - - "self isEmpty - ifTrue: [excessSignals _ excessSignals+1] - ifFalse: [Processor resume: self removeFirstLink]"! ! -!Semaphore methodsFor: 'communication' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16905103! - wait - "The active Process must receive a signal through the receiver before - proceeding. If no signal has been sent, the active Process will be suspended - until one is sent. Essential. See - Object whatIsAPrimitive." - - - self primitiveFailed - - "excessSignals>0 - ifTrue: [excessSignals _ excessSignals-1] - ifFalse: [self addLastLink: Processor activeProcess suspend]"! ! -!Semaphore methodsFor: 'initialize-release' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16905258! - initSignals - "Consume any excess signals the receiver may have accumulated." - - excessSignals _ 0! ! -!Semaphore class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16905275! - forMutualExclusion - "Answer a new instance of me that contains a single signal. - This new instance can now be used for mutual exclusion (see the - critical: message to Semaphore)." - - ^self new signal! ! -!OrderedCollection methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16883785 overrides: 50581199! - size - ^lastIndex - firstIndex + 1! ! -!OrderedCollection methodsFor: 'adding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16883788 overrides: 50582864! - add: newObject - ^self addLast: newObject! ! -!OrderedCollection methodsFor: 'adding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16883791! - add: newObject after: oldObject - "Add the argument, newObject, as an element of the receiver. Put it - in the position just succeeding oldObject. Answer newObject." - - | index | - index _ self find: oldObject. - self insert: newObject before: index + 1. - ^newObject! ! -!OrderedCollection methodsFor: 'adding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16883813! - add: newObject before: oldObject - "Add the argument, newObject, as an element of the receiver. Put it - in the position just preceding oldObject. Answer newObject." - - | index | - index _ self find: oldObject. - self insert: newObject before: index. - ^newObject! ! -!OrderedCollection methodsFor: 'adding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16883836! - addAllFirst: anOrderedCollection - "Add each element of anOrderedCollection at the beginning of the receiver. - Answer anOrderedCollection." - - anOrderedCollection reverseDo: [:each | self addFirst: each]. - ^anOrderedCollection! ! -!OrderedCollection methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16884171! - errorNoSuchElement - self error: 'attempt to index non-existent element in an ordered collection'! ! -!OrderedCollection class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16884315 overrides: 16783533! - new - ^self new: 10! ! -!RunArray methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16901467! - values - "Answer the values in the receiver." - ^values! ! -!RunArray methodsFor: 'copying' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16901359 overrides: 50332597! - copyReplaceFrom: start to: stop with: replacement - ^(self copyFrom: 1 to: start - 1) - , replacement - , (self copyFrom: stop + 1 to: self size)! ! -!RunArray methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16901372 overrides: 50582953! - storeOn: aStream - aStream nextPut: $(. - aStream nextPutAll: self class name. - aStream nextPutAll: ' runs: '. - runs storeOn: aStream. - aStream nextPutAll: ' values: '. - values storeOn: aStream. - aStream nextPut: $)! ! -!RunArray methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16901458! - runs - ^runs! ! -!RunArray class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16901509 overrides: 16783533! - new - ^self runs: Array new values: Array new! ! -!RunArray class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16901513! - 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)! ! -!RunArray class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16901549! - runs: newRuns values: newValues - "Answer a new instance of RunArray with runs and values specified - by the arguments." - - | instance | - instance _ self basicNew. - instance setRuns: newRuns setValues: newValues. - ^instance! ! -!Text methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16928921 overrides: 16880774! - at: index - ^string at: index! ! -!Text methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16928966! - findString: aString startingAt: start - "Answer the index of subString within the receiver, starting at position start. - If the receiver does not contain subString, answer 0." - - ^string findString: aString asString startingAt: start! ! -!Text methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16929024 overrides: 50581199! - size - ^string size! ! -!Text methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16929026! - string - "Answer the string representation of the receiver." - ^string! ! -!Text methodsFor: 'copying' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16929088 overrides: 16906162! - copyFrom: start to: stop - "Answer with a copied subrange of this text" - - | 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)! ! -!Text methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16929127! - asNumber - "Answer the number created by interpreting the receiver as the textual - representation of a number." - - ^string asNumber! ! -!Text methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16929133 overrides: 16881101! - asString - "Answer a String representation of the textual receiver." - ^string! ! -!Text methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16929137! - asText - "Answer the receiver itself." - ^self! ! -!Text methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16929554 overrides: 50582953! - storeOn: aStream - aStream nextPutAll: '(Text string: '; - store: string; - nextPutAll: ' runs: '; - store: runs; - nextPut: $)! ! -!Text methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16929649! - runs - ^runs! ! -!Text class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16929843 overrides: 16783541! - new: stringSize - ^self fromString: (String new: stringSize)! ! -!Text class methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16929918! - string: aString runs: anArray - ^self basicNew setString: aString setRuns: anArray! ! -!Bag methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16782029 overrides: 16880774! - at: index - self errorNotKeyed! ! -!Bag methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16782032 overrides: 16880792! - at: index put: anObject - self errorNotKeyed! ! -!Bag methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16782050! - sortedCounts - "Answer with a collection of counts with elements, sorted by decreasing count." - | counts | - counts _ SortedCollection sortBlock: [:x :y | x >= y]. - contents associationsDo: - [:assn | - counts add: (Association key: assn value value: assn key)]. - ^ counts! ! -!Bag methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16782060! - sortedElements - "Answer with a collection of elements with counts, sorted by element." - | elements | - elements _ SortedCollection new. - contents associationsDo: [:assn | elements add: assn]. - ^ elements! ! -!Bag methodsFor: 'adding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16782068 overrides: 50582864! - add: newObject - ^self add: newObject withOccurrences: 1! ! -!Bag methodsFor: 'enumerating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16782111 overrides: 50581206! - do: aBlock - contents associationsDo: [:assoc | assoc value timesRepeat: [aBlock value: assoc key]]! ! -!Bag methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16782146 overrides: 16814878! - includes: anObject - ^contents includesKey: anObject! ! -!Bag methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16782155 overrides: 50581213! - occurrencesOf: anObject - (self includes: anObject) - ifTrue: [^contents at: anObject] - ifFalse: [^0]! ! -!Set methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16907135 overrides: 50581199! - size - ^tally! ! -!Dictionary methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16833284! - associationAt: key - "Answer the association at key. If key is not found, create an error message." - - ^self associationAt: key ifAbsent: [self errorKeyNotFound]! ! -!Dictionary methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16833307 overrides: 16880774! - at: key - "Answer the value at key. If key is not found, create an error message." - - ^self at: key ifAbsent: [self errorKeyNotFound]! ! -!Dictionary methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16833420! - keyAtValue: value - "Answer the key whose value equals the argument, value. If there is none, - cause an error." - - ^self keyAtValue: value ifAbsent: [self errorValueNotFound]! ! -!Dictionary methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16833490 overrides: 16907343! - includes: anObject - self do: [:each | anObject = each ifTrue: [^true]]. - ^false! ! -!Dictionary methodsFor: 'removing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16833600 overrides: 16814683! - remove: anObject - self shouldNotImplement! ! -!Dictionary methodsFor: 'removing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16833603 overrides: 16907321! - remove: anObject ifAbsent: exceptionBlock - self shouldNotImplement! ! -!Dictionary methodsFor: 'removing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16833607! - removeKey: key - "Remove key from the receiver. If key is not in the receiver, create an error - message. Otherwise, answer the value associated with key." - - ^self removeKey: key ifAbsent: [self errorKeyNotFound]! ! -!Dictionary methodsFor: 'enumerating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16833664 overrides: 16814182! - associationsDo: aBlock - "Evaluate aBlock for each of the receiver's key/value associations." - - super do: aBlock! ! -!Dictionary methodsFor: 'enumerating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16833684 overrides: 16907172! -do: aBlock - super do: [:assoc | aBlock value: assoc value]! ! -!Dictionary methodsFor: 'enumerating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16833700 overrides: 50582938! - 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! ! -!Dictionary methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16833744! - errorValueNotFound - self error: 'value not found'! ! -!SystemDictionary methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16920794! - exitToDebugger - "Enter the machine language debugger, if one exists. Essential. See Object - documentation whatIsAPrimitive. " - - - self primitiveFailed! ! -!SystemDictionary methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16922694! - quitPrimitive - "Exit to another operating system on the host machine, if one exists. All - state changes in the object space since the last snapshot are lost. Essential. - See Object documentation whatIsAPrimitive." - - - self primitiveFailed! ! -!SystemDictionary methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16923729! - specialSelectors - "Used by SystemTracer only" - - ^SpecialSelectors! ! -!SystemDictionary methodsFor: 'special selectors' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16923470! - hasSpecialSelector: aLiteral ifTrueSetByte: aBlock - 1 to: self specialSelectorSize do: - [:index | - (self specialSelectorAt: index) == aLiteral - ifTrue: [aBlock value: index + 16rAF. ^true]]. - ^false! ! -!SharedQueue methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16907683! - 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! ! -!SharedQueue methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16907718! - isEmpty - "Answer whether any objects have been sent through the receiver - and not yet received by anyone." - - ^readPosition = writePosition! ! -!Stream methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16914001! -contents - "Answer the contents of the receiver." - self subclassResponsibility! ! -!Stream class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16914138 overrides: 16783533! - new - self error: 'Streams are created with on: and with:'! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4698-ST-80-timestamps-JuanVuletich-2021Jul26-09h18m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4695] on 26 July 2021 at 9:34:59 am'! -!PositionableStream methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16891443! - peekFor: anObject - "Answer false and do not move the position if self next ~= anObject or if the - receiver is at the end. Answer true and increment position if self next = 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! ! -!PositionableStream methodsFor: 'positioning' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16891646! -position - "Answer the current position of accessing the stream." - ^position! ! -!PositionableStream methodsFor: 'positioning' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16891651! - position: anInteger - "Set position to anInteger as long as anInteger is within the bounds of the - receiver's contents. If it is not, cause an error." - - anInteger >= 0 & (anInteger <= readLimit) - ifTrue: [position _ anInteger] - ifFalse: [self positionError]! ! -!PositionableStream methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16891868! - on: aCollection - collection _ aCollection. - readLimit _ aCollection size. - position _ 0. - self reset! ! -!PositionableStream class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16892254! - on: aCollection - "Answer a new instance of me, streaming over aCollection." - - ^self basicNew on: aCollection! ! -!PositionableStream class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16892260! - on: aCollection from: firstIndex to: lastIndex - "Answer a new instance of me, streaming over a copy of aCollection from - firstIndex to lastIndex." - - ^self basicNew on: (aCollection copyFrom: firstIndex to: lastIndex)! ! -!ReadStream methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898008 overrides: 16914044! - nextPut: anObject - self shouldNotImplement! ! -!ReadStream methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898041! - 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]! ! -!WriteStream methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16946360 overrides: 50581394! - contents - readLimit _ readLimit max: position. - ^collection copyFrom: 1 to: position! ! -!WriteStream methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16946364 overrides: 16914011! - next - self shouldNotImplement! ! -!WriteStream methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16946418 overrides: 16880927! - size - ^readLimit _ readLimit max: position! ! -!WriteStream methodsFor: 'positioning' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16946421 overrides: 50583928! - position: anInteger - readLimit _ readLimit max: position. - super position: anInteger! ! -!WriteStream methodsFor: 'positioning' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16946427 overrides: 16891663! - reset - readLimit _ readLimit max: position. - position _ 0! ! -!FileStream methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16843534 overrides: 50332180! - next - (position >= readLimit and: [self atEnd]) - ifTrue: [^nil] - ifFalse: [^collection at: (position _ position + 1)]! ! -!Link methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16864746! - nextLink - "Answer the Link to which the receiver points." - ^nextLink! ! -!Link methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16864750! - nextLink: aLink - "Store the argument, as the Link to which the receiver refers." - ^nextLink _ aLink! ! -!Process methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16894413! - priority - "Answer the priority of the receiver." - ^priority! ! -!Process methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16894496! - suspendedContext: aContext - suspendedContext _ aContext! ! -!Process class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16894754! - forContext: aContext priority: anInteger - "Answer an instance of me that has suspended aContext at priority anInteger." - - | newProcess | - newProcess _ self new. - newProcess suspendedContext: aContext. - newProcess priority: anInteger. - ^newProcess! ! -!Compiler methodsFor: 'public access' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16821978! - format: textOrStream in: aClass notifying: aRequestor - "Compile a parse tree from the incoming text, and then print the parse tree to yield the answer, a string containing the original code in standard format." - - | aNode | - self from: textOrStream - class: aClass - context: nil - notifying: aRequestor. - aNode _ self format: sourceStream noPattern: false ifFail: [^nil]. - ^aNode decompileString! ! -!Scanner methodsFor: 'error handling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16903857 overrides: 16882681! - notify: string - self error: string! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16904046! - xDelimiter - "ignore blanks etc." - - self scanToken! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16904065! - xDollar - "form a Character literal" - - self step. "pass over $" - token _ self step. - tokenType _ #number "really should be Char, but rest of compiler doesn't know"! ! -!Parser methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16885491! - addComment - parseNode ~~ nil - ifTrue: - [parseNode comment: currentComment. - currentComment _ nil]! ! -!Parser methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16885506! - initPattern: aString notifying: req return: aBlock - | result | - self - init: (ReadStream on: aString asString) - notifying: req - failBlock: [^nil]. - encoder _ self. - result _ aBlock value: (self pattern: false inContext: nil). - encoder _ failBlock _ nil. "break cycles" - ^result! ! -!Parser methodsFor: 'expression types' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16885948 overrides: 50508077! - argumentName - hereType == #word - ifFalse: [^self expected: 'Argument name']. - ^self advance! ! -!Parser methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16885762! - match: type - "Answer with true if next tokens type matches" - - hereType == type - ifTrue: - [self advance. - ^true]. - ^false! ! -!Parser methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16885771! - matchToken: thing - "matches the token, not its type" - - here = thing ifTrue: [self advance. ^true]. - ^false! ! -!Parser methodsFor: 'temporaries' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16886425! - bindTemp: name - ^name! ! -!ParseNode methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16884669! - asReturnNode - ^ReturnNode new expr: self! ! -!ParseNode methodsFor: 'encoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16884864! -encodeSelector: selector - ^nil! ! -!ParseNode methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16884940! - printOn: aStream indent: anInteger - "If control gets here, avoid recursion loop" - - super printOn: aStream! ! -!ParseNode methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16884945! - printOn: aStream indent: level precedence: p - self printOn: aStream indent: level! ! -!ParseNode methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16884680! - canCascade - ^false! ! -!ParseNode methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16884685! - isArg - ^false! ! -!ParseNode methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16884737! - isReturnSelf - ^false! ! -!ParseNode methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16884739! - isReturningIf - ^false! ! -!ParseNode methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16884758! - isVariableReference - ^false! ! -!ParseNode methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16884778! - comment - ^comment! ! -!ParseNode methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16884780! - comment: newComment - "self halt." - - comment _ newComment! ! -!Encoder methodsFor: 'encoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16837438! - cantStoreInto: varName - ^ StdVariables includesKey: varName! ! -!Encoder methodsFor: 'error handling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16837688 overrides: 16882681! - notify: string - | req | - requestor == nil - ifFalse: - [req _ requestor. - self release. - req notify: string]. - ^false! ! -!Encoder methodsFor: 'initialize-release' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16837770! - noteSuper - supered _ true! ! -!Encoder methodsFor: 'initialize-release' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16837786! - release - requestor _ nil! ! -!Encoder methodsFor: 'temporaries' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16837426! - maxTemp - ^nTemps! ! -!AssignmentNode methodsFor: 'initialize-release' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16780825! - variable: aVariable value: expression - variable _ aVariable. - value _ expression! ! -!BlockNode methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 50488060 overrides: 50488041! - arguments: argNodes - "decompile" - - arguments _ argNodes! ! -!BlockNode methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16789615! - numberOfArguments - ^arguments size! ! -!BlockNode methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16789621! - returnLast - self returns - ifFalse: - [returns _ true. - statements at: statements size put: statements last asReturnNode]! ! -!BlockNode methodsFor: 'code generation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16789714! - code - ^statements first code! ! -!BlockNode methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16789686 overrides: 16884701! - isJust: node - returns ifTrue: [^false]. - ^statements size = 1 and: [statements first == node]! ! -!BlockNode methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16789710! - returns - ^returns or: [statements last isReturningIf]! ! -!MethodNode methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16872877! - tempNames - ^encoder tempNames! ! -!LeafNode methodsFor: 'code generation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16864602! - code - ^code! ! -!LeafNode methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16864647! - key - ^key! ! -!LeafNode methodsFor: 'initialize-release' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16864650! - key: object code: byte - key _ object. - code _ byte! ! -!LeafNode methodsFor: 'initialize-release' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16864660! - name: ignored key: object code: byte - key _ object. - code _ byte! ! -!VariableNode methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16941869 overrides: 50584165! - isVariableReference - ^true! ! -!VariableNode methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16942023 overrides: 50584136! - printOn: aStream indent: level - aStream nextPutAll: name! ! -!MessageNode methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16868020! - precedence - ^precedence! ! -!MessageNode methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16869137! - transform: encoder - special = 0 ifTrue: [^false]. - (self perform: (MacroTransformers at: special) with: encoder) - ifTrue: - [^true] - ifFalse: - [special _ 0. ^false]! ! -!MessageNode methodsFor: 'initialize-release' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16869491! - receiver: rcvr selector: selName arguments: args precedence: p from: encoder sourceRange: range - "compile" - - encoder noteSourceRange: range forNode: self. - ^self - receiver: rcvr - selector: selName - arguments: args - precedence: p - from: encoder! ! -!MessageNode methodsFor: 'expression types' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16868566! - cascadeReceiver - "nil out rcvr (to indicate cascade) and return what it had been" - - | rcvr | - rcvr _ receiver. - receiver _ nil. - ^rcvr! ! -!ReturnNode methodsFor: 'code generation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16901056! - code - ^expr code! ! -!ReturnNode methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16901103 overrides: 50584157! - isReturnSelf - ^expr == NodeSelf! ! -!ReturnNode methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16901109 overrides: 50584165! - isVariableReference - ^expr isVariableReference! ! -!ReturnNode methodsFor: 'initialize-release' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16901112! - expr: e - expr _ e! ! -!ReturnNode methodsFor: 'initialize-release' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16901115! - expr: e encoder: encoder sourceRange: range - expr _ e. - encoder noteSourceRange: range forNode: self! ! -!DecompilerConstructor methodsFor: 'constructor' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16832467! - codeAnyLitInd: association - ^VariableNode new - name: association key - key: association - index: 0 - type: LdLitIndType! ! -!DecompilerConstructor methodsFor: 'constructor' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16832473! - codeAnyLiteral: value - ^LiteralNode new - key: value - index: 0 - type: LdLitType! ! -!DecompilerConstructor methodsFor: 'constructor' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16832478! - codeAnySelector: selector - ^SelectorNode new - key: selector - index: 0 - type: SendType! ! -!DecompilerConstructor methodsFor: 'constructor' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16832483! - codeArguments: args block: block - ^block arguments: args! ! -!DecompilerConstructor methodsFor: 'constructor' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16832493! - codeAssignTo: variable value: expression - ^AssignmentNode new variable: variable value: expression! ! -!DecompilerConstructor methodsFor: 'constructor' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16832517! - codeCascadedMessage: selector arguments: arguments - ^self - codeMessage: nil - selector: selector - arguments: arguments! ! -!DecompilerConstructor methodsFor: 'constructor' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16832619! - codeSelector: sel code: code - ^SelectorNode new key: sel code: code! ! -!DecompilerConstructor methodsFor: 'constructor' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16832623! - codeSuper - ^NodeSuper! ! -!DecompilerConstructor methodsFor: 'constructor' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16832639! - codeThisContext - ^NodeThisContext! ! -!DecompilerConstructor methodsFor: 'initialize-release' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16832676! - method: aMethod class: aClass literals: literals - method _ aMethod. - instVars _ aClass allInstVarNames. - nArgs _ method numArgs. - literalValues _ literals! ! -!ParseStack methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16885449! - pop: n - (position _ position - n) < 0 - ifTrue: [self error: 'Parse stack underflow']! ! -!ParseStack methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16885458! - push: n - (position _ position + n) > length - ifTrue: [length _ position]! ! -!ParseStack methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16885462 overrides: 16880927! - size - ^length! ! -!ParseStack methodsFor: 'results' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16885464! - position - ^position! ! -!ParseStack methodsFor: 'initialize-release' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16885472! - init - length _ position _ 0! ! -!RemoteString methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16900612! - sourceFileNumber - "Answer the index of the file on which the string is stored." - ^sourceFileNumber! ! -!RemoteString class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16900698! - newFileNumber: sourceIndex position: anInteger - "Answer a new instance of RemoteString for file indexed by sourceIndex, - at the position anInteger. Assumes that the string is already stored - on the file and the instance will be used to access it." - - ^self new fileNumber: sourceIndex position: anInteger! ! -!RemoteString class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16900710! - newString: aString onFileNumber: sourceIndex - "Answer a new instance of RemoteString for string, aString, on file indexed by - sourceIndex. Puts the string on the file and creates the remote reference." - - ^self new string: aString onFileNumber: sourceIndex! ! -!RemoteString class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16900720! - newString: aString onFileNumber: sourceIndex toFile: aFileStream - "Answer a new instance of RemoteString for string, aString, on file indexed by - sourceIndex. Puts the string on the file, aFileStream, and creates the remote - reference. Assumes that the index corresponds properly to aFileStream." - - ^self new string: aString onFileNumber: sourceIndex toFile: aFileStream! ! -!Form methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16846745! - bits - "Answer the receiver's Bitmap containing its bits." - ^bits! ! -!Form methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16846784! - offset: aPoint - offset _ aPoint! ! -!Form class methodsFor: 'mode constants' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16849119! - and - "Answer the integer denoting the logical 'and' combination rule." - ^1! ! -!Form class methodsFor: 'mode constants' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16849133! - erase - "Answer the integer denoting mode erase." - ^4! ! -!Form class methodsFor: 'mode constants' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16849149! - over - "Answer the integer denoting mode over." - ^3! ! -!Form class methodsFor: 'mode constants' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16849163! - reverse - "Answer the integer denoting mode reverse." - ^6! ! -!Form class methodsFor: 'mode constants' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16849174! - under - "Answer the integer denoting mode under." - ^7! ! -!Cursor methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16825837 overrides: 50333000! - printOn: aStream - self storeOn: aStream base: 2! ! -!Cursor class methodsFor: 'current cursor' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16826408! - currentCursor - "Answer the instance of Cursor that is the one currently displayed." - ^CurrentCursor! ! -!DisplayScreen methodsFor: 'displaying' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16835301! - beDisplay - "Tell the interpreter to use the receiver as the current display image. Fail if the - form is too wide to fit on the physical display. Essential. See Object - documentation whatIsAPrimitive." - - - self primitiveFailed! ! -!BitBlt methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16785524! - destOrigin: aPoint - "Set the destination coordinates to be those of aPoint." - destX _ aPoint x. - destY _ aPoint y! ! -!BitBlt methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16785530! - destRect: aRectangle - "Set the destination coordinates to be those of aRectangle top left and - the width and height of the receiver to be the width and height of aRectangle." - destX _ aRectangle left. - destY _ aRectangle top. - width _ aRectangle width. - height _ aRectangle height! ! -!Point methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16890219! - x - "Answer the x coordinate." - ^x! ! -!Point methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16890222! - y - "Answer the y coordinate." - ^y! ! -!Point methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16890277! - < aPoint - "Answer whether the receiver is 'above and to the left' of aPoint." - ^x < aPoint x and: [y < aPoint y]! ! -!Point methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16890282! - <= aPoint - "Answer whether the receiver is 'neither below nor to the right' of aPoint." - - ^x <= aPoint x and: [y <= aPoint y]! ! -!Point methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16890294! - > aPoint - "Answer whether the receiver is 'below and to the right' of aPoint." - - ^x > aPoint x and: [y > aPoint y]! ! -!Point methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16890299! - >= aPoint - "Answer whether the receiver is 'neither above nor to the left' of aPoint." - - ^x >= aPoint x and: [y >= aPoint y]! ! -!Point methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16890358! - asPoint - "Answer the receiver itself." - ^self! ! -!Point methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16890361! - corner: aPoint - "Answer a new Rectangle whose origin is the receiver and whose corner is aPoint. - This is one of the infix ways of expressing the creation of a rectangle." - - ^Rectangle origin: self corner: aPoint! ! -!Point methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16890380! - extent: aPoint - "Answer a new Rectangle whose origin is the receiver and whose extent is aPoint. - This is one of the infix ways of expressing the creation of a rectangle." - - ^Rectangle origin: self extent: aPoint! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898507! - bottom - "Answer the position of the receiver's bottom horizontal line." - ^corner y! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898515! - bottomCenter - "Answer the point at the center of the bottom horizontal line of the receiver." - ^self center x @ self bottom! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898521! - bottomLeft - "Answer the point at the left edge of the bottom horizontal line of the receiver." - ^origin x @ corner y! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898526! - bottomRight - "Answer the point at the right edge of the bottom horizontal line of the receiver." - ^corner! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898533! - center - "Answer the point at the center of the receiver." - ^self topLeft + self bottomRight // 2! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898538! - corner - "Answer the point at the bottom right corner of the receiver." - ^corner! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898550! - extent - "Answer with a rectangle with origin 0@0 and corner the receiver's - width @ the receiver's height." - ^corner - origin! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898556! - height - "Answer the height of the receiver." - ^corner y - origin y! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898571! - left - "Answer the position of the receiver's left vertical line." - ^origin x! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898579! - leftCenter - "Answer the point at the center of the receiver's left vertical line." - ^self left @ self center y! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898584! - origin - "Answer the point at the top left corner of the receiver." - ^origin! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898588! - right - "Answer the position of the receiver's right vertical line." - ^corner x! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898596! - rightCenter - "Answer the point at the center of the receiver's right vertical line." - ^self right @ self center y! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898601! - top - "Answer the position of the receiver's top horizontal line." - ^origin y! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898609! - topCenter - "Answer the point at the center of the receiver's top horizontal line." - ^self center x @ self top! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898614! - topLeft - "Answer the point at the top left corner of the receiver's top horizontal line." - ^origin! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898619! - topRight - "Answer the point at the top right corner of the receiver's top horizontal line." - ^corner x @ origin y! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898624! - width - "Answer the width of the receiver." - ^corner x - origin x! ! -!Rectangle methodsFor: 'rectangle functions' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898753! - insetOriginBy: originDeltaPoint cornerBy: cornerDeltaPoint - "Answer a Rectangle that is inset from the receiver by a given amount in the - origin and corner." - - ^Rectangle - origin: origin + originDeltaPoint - corner: corner - cornerDeltaPoint! ! -!Rectangle methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16899045 overrides: 50508082! -printOn: aStream - origin printOn: aStream. - aStream nextPutAll: ' corner: '. - corner printOn: aStream! ! -!CharacterBlock methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16801540! - stringIndex - "Answer the position of the receiver in the string it indexes." - ^stringIndex! ! -!CharacterBlock methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16801549! - < aCharacterBlock - "Answer whether the string index of the receiver precedes that of aCharacterBlock." - ^stringIndex < aCharacterBlock stringIndex! ! -!CharacterBlock methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16801556! - <= aCharacterBlock - "Answer whether the string index of the receiver does not come after that of - aCharacterBlock." - ^(self > aCharacterBlock) not! ! -!CharacterBlock methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16801571! - > aCharacterBlock - "Answer whether the string index of the receiver comes after that of - aCharacterBlock." - ^aCharacterBlock < self! ! -!CharacterBlock methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16801577! - >= aCharacterBlock - "Answer whether the string index of the receiver does not precede that of - aCharacterBlock." - ^(self < aCharacterBlock) not! ! -!StrikeFont methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16914273! - glyphs - "Answer a Form containing the bits representing the characters of the receiver." - ^glyphs! ! -!StrikeFont methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16914298! - name: aString - "Set the receiver's name." - name _ aString.! ! -!StrikeFont methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16914314! - subscript - "Answer an integer that is the further vertical offset relative to the - baseline for positioning characters as subscripts." - ^subscript! ! -!StrikeFont methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16914320! - superscript - "Answer an integer that is the further vertical offset relative to the - baseline for positioning characters as superscripts." - ^superscript! ! -!StrikeFont methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16914342 overrides: 16777261! - xTable - "Answer an array of the left x-coordinate of characters in glyphs." - ^xTable! ! -!CompositionScanner methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16823103! - rightX - "Meaningful only when a line has just been composed -- refers to the line most recently composed. This is a subtrefuge to allow for easy resizing of a composition rectangle to the width of the maximum line. Useful only when there is only one line in the form or when each line is terminated by a carriage return. Handy for sizing menus and lists." - - ^spaceX! ! -!PopUpMenu class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16891083! - labels: aString - "Answer an instance of me whose items are in aString." - ^self labels: aString lines: nil! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4699-ST-80-timestamps-JuanVuletich-2021Jul26-09h24m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4695] on 26 July 2021 at 9:38:32 am'! -!Object methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16881029! - = anObject - "Answer true if the receiver and the argument represent the same object - and false otherwise. If = is redefined in any subclass, consider also - redefining the message hash." - - ^self == anObject! ! -!Object methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16881037! - ~= anObject - "Answer true if the receiver and the argument do not represent the same - object and false otherwise." - - ^self = anObject == false! ! -!Object methodsFor: 'error handling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16881489! - shouldNotImplement - "Announce that although the receiver inherits this message, it - should not implement it." - - self error: 'This message is not appropriate for this object'! ! -!Object methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16882265! - storeOn: aStream - "Append to the argument aStream a sequence of characters that is an expression - whose evaluation creates an object similar to the receiver." - - aStream nextPut: $(. - self class isVariable - ifTrue: [aStream nextPutAll: '(', self class name, ' basicNew: '; - store: self basicSize; - nextPutAll: ') '] - ifFalse: [aStream nextPutAll: self class name, ' basicNew']. - 1 to: self class instSize do: - [:i | - aStream nextPutAll: ' instVarAt: '; - store: i; - nextPutAll: ' put: '; - store: (self instVarAt: i); - nextPut: $;]. - 1 to: self basicSize do: - [:i | - aStream nextPutAll: ' basicAt: '; - store: i; - nextPutAll: ' put: '; - store: (self basicAt: i); - nextPut: $;]. - aStream nextPutAll: ' yourself)'! ! -!Switch methodsFor: 'state' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16918328! - isOff - "Answer whether the receiver is set off or not." - ^on not! ! -!Switch methodsFor: 'state' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16918332! - isOn - "Answer whether the receiver is set on or not." - ^on! ! -!Switch methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16918390! - initializeOff - on _ false. - onAction _ nil. - offAction _ nil! ! -!Switch methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16918394! - initializeOn - on _ true. - onAction _ nil. - offAction _ nil! ! -!Switch class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16918410! - newOff - "Answer an instance of me such that the on and off actions are set to nil - ('no action'), and the state is set to 'off'." - - ^super new initializeOff! ! -!Switch class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16918417! -newOn - "Answer an instance of me such that the on and off actions are set to nil - ('no action'), and the state is set to 'on'." - - ^super new initializeOn! ! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16784249! - someInstance - "Answer the first instance of this receiver. See Object nextInstance. Fails - if there are none. Essential. See Object documentation whatIsAPrimitive." - - - ^nil! ! -!ClassDescription methodsFor: 'compiling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16806381! -compile: code classified: heading - "Compile the argument, code, as source code in the context of the receiver and - install the result in the receiver's method dictionary under the classification - indicated by the second argument, heading. nil is to be notified if an error occurs. - The argument code is either a string or an object that converts to a string or a - PositionableStream on an object that converts to a string." - - ^self - compile: code - classified: heading - notifying: nil! ! -!ClassDescription methodsFor: 'copying' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16805742! - copyAll: selArray from: class - "Install all the methods found in the method dictionary of the second argument, class, - as the receiver's methods. Classify the messages under -as yet not classified-" - - self copyAll: selArray - from: class - classified: nil! ! -!ClassDescription methodsFor: 'copying' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16805752! - copyAll: selArray from: class classified: cat - "Install all the methods found in the method dictionary of the second argument, class, - as the receiver's methods. Classify the messages under the third argument, cat." - - selArray do: - [:s | self copy: s - from: class - classified: cat]! ! -!ClassDescription methodsFor: 'copying' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16805763! - copyAllCategoriesFrom: aClass - "Specify that the categories of messages for the receiver include all of those found - in the class, aClass. Install each of the messages found in these categories into the - method dictionary of the receiver, classified under the appropriate categories." - - aClass organization categories do: [:cat | self copyCategory: cat from: aClass]! ! -!ClassDescription methodsFor: 'copying' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16805786! - copyCategory: cat from: aClass classified: newCat - "Specify that one of the categories of messages for the receiver is the third argument, - newCat. Copy each message found in the category cat in class aClass into this - new category." - - self copyAll: (aClass organization listAtCategoryNamed: cat) - from: aClass - classified: newCat! ! -!ClassDescription methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16805827 overrides: 50582271! - printOn: aStream - aStream nextPutAll: self name! ! -!Metaclass methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16870978! - soleInstance - "The receiver has only one instance. Answer it." - - ^thisClass! ! -!Metaclass methodsFor: 'instance variables' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16871017 overrides: 16806072! - removeInstVarName: aString - "Remove the argument, aString, as one of the receiver's instance variables." - - - | newArray newString | - (self instVarNames includes: aString) - ifFalse: [self error: aString , ' is not one of my instance variables']. - newArray _ self instVarNames copyWithout: aString. - newString _ ''. - newArray do: [:aString2 | newString _ aString2 , ' ' , newString]. - self instanceVariableNames: newString! ! -!Magnitude methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16865571! - < aMagnitude - "Compare the receiver with the argument and answer with true if the - receiver is less than the argument. Otherwise answer false." - - ^self subclassResponsibility! ! -!Magnitude methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16865576! - <= aMagnitude - "Compare the receiver with the argument and answer with true if the - receiver is less than or equal to the argument. Otherwise answer false." - - ^(self > aMagnitude) not! ! -!Magnitude methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16865588! - > aMagnitude - "Compare the receiver with the argument and answer with true if the - receiver is greater than the argument. Otherwise answer false." - - ^aMagnitude < self! ! -!Magnitude methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16865599! - between: min and: max - "Answer whether the receiver is less than or equal to the argument, max, - and greater than or equal to the argument, min." - - ^self >= min and: [self <= max]! ! -!Magnitude methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16865610! - max: aMagnitude - "Answer the receiver or the argument, whichever has the greater magnitude." - - self > aMagnitude - ifTrue: [^self] - ifFalse: [^aMagnitude]! ! -!Magnitude methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16865617! - min: aMagnitude - "Answer the receiver or the argument, whichever has the lesser magnitude." - - self < aMagnitude - ifTrue: [^self] - ifFalse: [^aMagnitude]! ! -!Float methodsFor: 'mathematical functions' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16844579 overrides: 16880035! - arcCos - "Answers with the angle in radians." - - ^Halfpi - self arcSin! ! -!Float methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16844776! - asFloat - "Answer with the receiver itself." - ^self! ! -!Float methodsFor: 'truncation and round off' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16844988 overrides: 16880554! - integerPart - "Answer with a new Float whose value is the receiver's truncated value." - - ^self - self fractionPart! ! -!Fraction methodsFor: 'arithmetic' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16849493 overrides: 50581676! - negated - ^Fraction numerator: numerator negated denominator: denominator! ! -!Integer methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16860202 overrides: 50581045! - even - ^((self digitAt: 1) bitAnd: 1) = 0! ! -!Integer methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16860206 overrides: 16882573! - isInteger - ^true! ! -!Character methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16800606! - asSymbol - ^Symbol internCharacter: self! ! -!WriteStream methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16946547! - store: anObject - "Have anObject print on me for rereading." - - anObject storeOn: self! ! -!WriteStream methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16946581 overrides: 50583940! - on: aCollection - super on: aCollection. - readLimit _ 0. - writeLimit _ aCollection size! ! -!WriteStream methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16946585! - 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]! ! -!WriteStream methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16946616! - with: aCollection - super on: aCollection. - position _ readLimit _ writeLimit _ aCollection size! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4700-ST-80-timestamps-JuanVuletich-2021Jul26-09h34m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4695] on 26 July 2021 at 10:42:52 am'! -!MessageSet methodsFor: 'message list' stamp: 'jmv 7/26/2021 10:39:19'! - sortByClass - "Sort the message-list by class / selector" - - messageList _ messageList sort: [ :a :b | - a classSymbol = b classSymbol - ifTrue: [ - a methodSymbol == #Comment - ifTrue: [ true ] - ifFalse: [ - b methodSymbol == #Comment - ifTrue: [ false ] - ifFalse: [ - a classIsMeta = b classIsMeta - ifTrue: [ a methodSymbol < b methodSymbol ] - ifFalse: [ a classIsMeta ] ]]] - ifFalse: [ a classSymbol < b classSymbol ] - ]. - messageList do: [ :each | each removeStringVersionPrefix ]. - self changed: #messageList! ! -!MessageSet methodsFor: 'message list' stamp: 'jmv 7/26/2021 10:38:30'! - sortBySelector - "Sort the message-list by selector / class" - - messageList _ messageList sort: [ :a :b | - a methodSymbol == #Comment - ifTrue: [ true ] - ifFalse: [ - b methodSymbol == #Comment - ifTrue: [ false ] - ifFalse: [ - a methodSymbol = b methodSymbol - ifTrue: [ - a classSymbol = b classSymbol - ifTrue: [ a classIsMeta ] - ifFalse: [ a classSymbol < b classSymbol ]] - ifFalse: [ a methodSymbol < b methodSymbol ]]] - ]. - messageList do: [ :each | each prefixStringVersionWith: each methodSymbol ]. - self changed: #messageList! ! -!MethodReference methodsFor: 'setting' stamp: 'jmv 7/26/2021 10:36:08'! - removeStringVersionPrefix - - | i prefixCoda | - prefixCoda _ '] - '. - i _ stringVersion findString: prefixCoda. - i = 0 ifFalse: [ - stringVersion _ stringVersion copyFrom: i + prefixCoda size to: stringVersion size ].! ! -!MessageSet methodsFor: 'message list' stamp: 'jmv 7/26/2021 10:41:18' prior: 16869875! - sortByDate - "Sort the message-list by date of time-stamp" - - | assocs aCompiledMethod aDate inOrder | - assocs _ messageList collect: [ :aRef | - aDate _ aRef methodSymbol == #Comment - ifTrue: [ - aRef actualClass organization dateCommentLastSubmitted] - ifFalse: [ - aCompiledMethod _ aRef actualClass compiledMethodAt: aRef methodSymbol ifAbsent: nil. - aCompiledMethod ifNotNil: [aCompiledMethod dateMethodLastSubmitted]]. - aRef -> (aDate ifNil: [Date fromString: '01/01/1996'])]. "The dawn of Squeak history" - inOrder _ assocs asArray sort: [ :a :b | a value < b value]. - - inOrder do: [ :each | each key prefixStringVersionWith: each value yyyymmdd ]. - messageList _ inOrder collect: [ :assoc | assoc key ]. - self changed: #messageList! ! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'jmv 7/26/2021 10:33:47' prior: 50505748! - addReferencesOf: anInstVarName at: anInstVarIndex to: references - - | reference | - - self methodsDo: [ :aMethod | - (aMethod accessorDescriptionOf: anInstVarName at: anInstVarIndex) ifNotEmpty: [ :description | - reference := MethodReference method: aMethod. - reference prefixStringVersionWith: description. - references add: reference ]]. - ! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'jmv 7/26/2021 09:52:12' prior: 50411211! - messageListMenu2 - "Fill aMenu with the items appropriate when the shift key is held down" - - ^DynamicMenuBuilder - buildTitled: 'Message List' - targeting: self - collectingMenuOptionsWith: #messageListMenu2Options - changingThemWith: [ :options | - self addExtraMenu2ItemsTo: options. - model canShowMultipleMessageCategories ifTrue: [ - options add: `{ - #itemGroup -> 40. - #itemOrder -> 45. - #label -> 'show category (C)'. - #object -> #model. - #selector -> #showHomeCategory. - #icon -> #packageIcon - } asDictionary` ]]. - - ! ! -!MessageSetWindow methodsFor: 'menu building' stamp: 'jmv 7/26/2021 09:58:13' prior: 50411887 overrides: 50403936! - addExtraMenu2ItemsTo: options - "The shifted selector-list menu is being built. Add items specific to MessageSet" - - model growable ifTrue: [ - options add: `{ - #itemGroup -> 40. - #itemOrder -> 31. - #label -> 'remove from this browser'. - #object -> #model. - #selector -> #removeMessageFromBrowser. - #icon -> #listRemoveIcon - } asDictionary`. - options add:`{ - #itemGroup -> 40. - #itemOrder -> 32. - #label -> 'filter message list...'. - #selector -> #filterMessageList. - #icon -> #findIcon - } asDictionary` ]. - - options add: `{ - #itemGroup -> 41. - #itemOrder -> 33. - #label -> 'sort by class'. - #object -> #model. - #selector -> #sortByClass. - #icon -> #dateIcon - } asDictionary`. - options add: `{ - #itemGroup -> 41. - #itemOrder -> 34. - #label -> 'sort by selector'. - #object -> #model. - #selector -> #sortBySelector. - #icon -> #dateIcon - } asDictionary`. - options add: `{ - #itemGroup -> 41. - #itemOrder -> 35. - #label -> 'sort by date'. - #object -> #model. - #selector -> #sortByDate. - #icon -> #dateIcon - } asDictionary`. - -! ! -!MethodReference methodsFor: 'setting' stamp: 'jmv 7/26/2021 10:36:43' prior: 50505848! - prefixStringVersionWith: aString - - self removeStringVersionPrefix. - stringVersion _ '[', aString, '] - ', stringVersion.! ! -!MethodReference methodsFor: 'comparisons' stamp: 'jmv 7/26/2021 10:26:17' prior: 50570754! - <= anotherMethodReference - "By default, sort by class" - - ^self classSymbol = anotherMethodReference classSymbol - ifTrue: [ - self methodSymbol == #Comment - ifTrue: [ true ] - ifFalse: [ - anotherMethodReference methodSymbol == #Comment - ifTrue: [ false ] - ifFalse: [ - self classIsMeta = anotherMethodReference classIsMeta - ifTrue: [ self methodSymbol < anotherMethodReference methodSymbol ] - ifFalse: [ self classIsMeta ] ]]] - ifFalse: [ self classSymbol < anotherMethodReference classSymbol ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4701-AddSortBy-toImplementorsAndSenders-JuanVuletich-2021Jul26-09h38m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4701] on 27 July 2021 at 4:44:30 pm'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 7/27/2021 16:13:35' prior: 50580381! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('AY' 'Angel Yan') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('bgs' 'Boris G. Shingarov') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('db' 'Douglas Brebner') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('EB' 'Eric Brandwein') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('FGJ' 'Fernando Gasperi Jabalera') - #('FJG' 'Facundo Javier Gelatti') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hlsf' 'Hilaire Fernandes') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('jar' 'Jaromir Matas') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('KLG' 'Gerald Klix') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MM' 'Mariano Montone') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('pmon' 'Paolo Montrasi') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('sjd' 'Santiago Jose Dandois') - #('SLD' 'Steve Davies') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('Squeak1.0' 'Squeak 1.0, September 20, 1996') - #('Squeak1.1' 'Squeak 1.1, September 23, 1996') - #('Squeak1.2' 'Squeak 1.2, June 29, 1997') - #('Squeak1.3' 'Squeak 1.3, January 16, 1998') - #('sr' 'Stephan Rudlof') - #('ss' 'Sebastian Sujarchuk') - #('SSS' 'Samuel S. Shuster') - #('ST-80' 'Smalltalk-80, version 2, of April 1, 1983') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tsl' 'Thiago da Silva Lino') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4702-Add-Squeak-asCodeAuthors-JuanVuletich-2021Jul27-16h44m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4702] on 27 July 2021 at 7:23:32 pm'! -!Object methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16880817! - basicAt: index - "Primitive. Assumes receiver is indexable. Answer the value of an - indexable element in the receiver. Fail if the argument index is not an - Integer or is out of bounds. Essential. Do not override in a subclass. See - Object documentation whatIsAPrimitive." - - - index isInteger ifTrue: [self errorSubscriptBounds: index]. - index isNumber - ifTrue: [^self basicAt: index asInteger] - ifFalse: [self errorNonIntegerIndex]! ! -!Object methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16880833! - basicAt: index put: value - "Primitive. Assumes receiver is indexable. Store the second argument - value in the indexable element of the receiver indicated by index. Fail - if the index is not an Integer or is out of bounds. Or fail if the value is - not of the right type for this kind of collection. Answer the value that - was stored. Essential. Do not override in a subclass. See Object - documentation whatIsAPrimitive." - - - index isInteger - ifTrue: [(index >= 1 and: [index <= self size]) - ifTrue: [self errorImproperStore] - ifFalse: [self errorSubscriptBounds: index]]. - index isNumber - ifTrue: [^self basicAt: index asInteger put: value] - ifFalse: [self errorNonIntegerIndex]! ! -!Object methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16880857! -basicSize - "Primitive. Answer the number of indexable variables in the receiver. - This value is the same as the largest legal subscript. Essential. Do not - override in any subclass. See Object documentation whatIsAPrimitive." - - - "The number of indexable fields of fixed-length objects is 0" - ^0 ! ! -!Object methodsFor: 'binding' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16880949! - bindingOf: aString - ^nil! ! -!Object methodsFor: 'casing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16880951! - caseOf: aBlockAssociationCollection - "The elements of aBlockAssociationCollection are associations between blocks. - Answer the evaluated value of the first association in aBlockAssociationCollection - whose evaluated key equals the receiver. If no match is found, report an error." - - ^ self caseOf: aBlockAssociationCollection otherwise: [self caseError] - -"| z | z _ {[#a]->[1+1]. ['b' asSymbol]->[2+2]. [#c]->[3+3]}. #b caseOf: z" -"| z | z _ {[#a]->[1+1]. ['d' asSymbol]->[2+2]. [#c]->[3+3]}. #b caseOf: z" -"The following are compiled in-line:" -"#b caseOf: {[#a]->[1+1]. ['b' asSymbol]->[2+2]. [#c]->[3+3]}" -"#b caseOf: {[#a]->[1+1]. ['d' asSymbol]->[2+2]. [#c]->[3+3]}"! ! -!Object methodsFor: 'casing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16880974! - caseOf: aBlockAssociationCollection otherwise: aBlock - "The elements of aBlockAssociationCollection are associations between blocks. - Answer the evaluated value of the first association in aBlockAssociationCollection - whose evaluated key equals the receiver. If no match is found, answer the result - of evaluating aBlock." - - aBlockAssociationCollection associationsDo: - [:assoc | (assoc key value = self) ifTrue: [^assoc value value]]. - ^ aBlock value - -"| z | z _ {[#a]->[1+1]. ['b' asSymbol]->[2+2]. [#c]->[3+3]}. #b caseOf: z otherwise: [0]" -"| z | z _ {[#a]->[1+1]. ['d' asSymbol]->[2+2]. [#c]->[3+3]}. #b caseOf: z otherwise: [0]" -"The following are compiled in-line:" -"#b caseOf: {[#a]->[1+1]. ['b' asSymbol]->[2+2]. [#c]->[3+3]} otherwise: [0]" -"#b caseOf: {[#a]->[1+1]. ['d' asSymbol]->[2+2]. [#c]->[3+3]} otherwise: [0]"! ! -!Object methodsFor: 'class membership' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16881002! - class - "Primitive. Answer the object which is the receiver's class. Essential. See - Object documentation whatIsAPrimitive." - - - self primitiveFailed! ! -!Object methodsFor: 'class membership' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16881009! - isKindOf: aClass - "Answer whether the class, aClass, is a superclass or class of the receiver." - - self class == aClass - ifTrue: [^true] - ifFalse: [^self class inheritsFrom: aClass]! ! -!Object methodsFor: 'class membership' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16881017! - isMemberOf: aClass - "Answer whether the receiver is an instance of the class, aClass." - - ^self class == aClass! ! -!Object methodsFor: 'class membership' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16881022! - respondsTo: aSymbol - "Answer whether the method dictionary of the receiver's class contains - aSymbol as a message selector." - - ^self class canUnderstand: aSymbol! ! -!Object methodsFor: 'error handling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16881336! - caseError - "Report an error from an in-line or explicit case statement." - - self error: 'Case not found, and no otherwise clause'! ! -!Object methodsFor: 'error handling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16881441! -notify: aString at: location - "Create and schedule a Notifier with the argument as the message in - order to request confirmation before a process can proceed. Subclasses can - override this and insert an error message at location within aString." - - self notify: aString - - "nil notify: 'confirmation message' at: 12"! ! -!Object methodsFor: 'system primitives' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16882467! - someObject - "Primitive. Answer the first object in the enumeration of all - objects." - - - self primitiveFailed.! ! -!Object methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16882573! - isInteger - "Overridden to return true in Integer." - - ^ false! ! -!Object methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16882582! - isNumber - "Overridden to return true in Number, natch" - ^ false! ! -!Object methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16882761! - storeAt: offset inTempFrame: aContext - "This message had to get sent to an expression already on the stack - as a Block argument being accessed by the debugger. - Just re-route it to the temp frame." - ^ aContext tempAt: offset put: self! ! -!Browser methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16791445! - editSelection - ^editSelection! ! -!Browser methodsFor: 'metaclass' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16792487! - indicateClassMessages - "Indicate that the message selection should come from the metaclass - messages." - - self metaClassIndicated: true! ! -!Browser methodsFor: 'metaclass' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16792493! - indicateInstanceMessages - "Indicate that the message selection should come from the class (instance) - messages." - - self metaClassIndicated: false! ! -!Browser methodsFor: 'metaclass' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16792507! - metaClassIndicated - "Answer the boolean flag that indicates which of the method dictionaries, - class or metaclass." - - ^metaClassIndicated! ! -!Browser methodsFor: 'system category list' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16792771! - systemCategoryList - "Answer the class categories modelled by the receiver." - - ^systemOrganizer categories! ! -!MessageSet methodsFor: 'message list' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16869850 overrides: 50492552! - messageList - "Answer the current list of messages." - - ^messageList! ! -!MessageSet methodsFor: 'class list' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16869949 overrides: 50585802! - metaClassIndicated - "Answer the boolean flag that indicates whether - this is a class method." - - ^ self selectedClassOrMetaClass isMeta! ! -!MessageSet methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16870031! - autoSelectString - "Return the string to be highlighted when making new selections" - ^ autoSelectString! ! -!MessageSet methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16870036! - autoSelectString: aString - "Set the string to be highlighted when making new selections" - autoSelectString _ aString! ! -!MessageSet class methodsFor: 'instance creation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16870388! - messageList: anArray - "Answer an instance of me with message list anArray." - - ^self new initializeMessageList: anArray! ! -!ChangeList methodsFor: 'viewing access' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16796709! - list - ^ list! ! -!ChangeList methodsFor: 'viewing access' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16796711! - listIndex - ^ listIndex! ! -!ChangeList methodsFor: 'viewing access' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16796714! - listSelectionAt: index - ^ listSelections at: index! ! -!ChangeList methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16796754! - changeList - ^ changeList! ! -!ChangeList methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16796770! - file - ^file! ! -!Debugger methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16829629! - contextVariablesInspector - "Answer the instance of Inspector that is providing a view of the - variables of the selected context." - - ^contextVariablesInspector! ! -!Debugger methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16829640! - interruptedContext - "Answer the suspended context of the interrupted process." - - ^contextStackTop! ! -!Debugger methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16829645! - interruptedProcess - "Answer the interrupted process." - - ^interruptedProcess! ! -!Debugger methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16829667! - proceedValue - "Answer the value to return to the selected context when the interrupted - process proceeds." - - ^proceedValue! ! -!Debugger methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16829673! - proceedValue: anObject - "Set the value to be returned to the selected context when the interrupted - process proceeds." - - proceedValue _ anObject! ! -!Debugger methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16829679! - receiver - "Answer the receiver of the selected context, if any. Answer nil - otherwise." - - contextStackIndex = 0 - ifTrue: [^nil] - ifFalse: [^self selectedContext receiver]! ! -!Debugger methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16829686! - receiverInspector - "Answer the instance of Inspector that is providing a view of the - variables of the selected context's receiver." - - ^receiverInspector! ! -!Debugger methodsFor: 'code pane' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16829974 overrides: 16812895! - doItContext - "Answer the context in which a text selection can be evaluated." - - contextStackIndex = 0 - ifTrue: [^super doItContext] - ifFalse: [^self selectedContext]! ! -!Debugger methodsFor: 'code pane' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16829981! - doItReceiver - "Answer the object that should be informed of the result of evaluating a - text selection." - - ^self receiver! ! -!Debugger methodsFor: 'context stack (message list)' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16829712! - contextStackIndex - "Answer the index of the selected context." - - ^contextStackIndex! ! -!Debugger methodsFor: 'context stack (message list)' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16829717! - contextStackList - "Answer the array of contexts." - - ^contextStackList! ! -!Debugger methodsFor: 'context stack (message list)' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16829744! - messageListIndex - "Answer the index of the currently selected context." - - ^contextStackIndex! ! -!Debugger methodsFor: 'context stack (message list)' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16829772! - toggleContextStackIndex: anInteger - "If anInteger is the same as the index of the selected context, deselect it. - Otherwise, the context whose index is anInteger becomes the selected - context." - - self contextStackIndex: - (contextStackIndex = anInteger - ifTrue: [0] - ifFalse: [anInteger]) - oldContextWas: - (contextStackIndex = 0 - ifTrue: [nil] - ifFalse: [contextStack at: contextStackIndex])! ! -!Debugger methodsFor: 'context stack menu' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16829925! - selectPC - "Toggle the flag telling whether to automatically select the expression - currently being executed by the selected context." - - selectingPC _ selectingPC not! ! -!Debugger methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16830079! - externalInterrupt: aBoolean - - externalInterrupt _ aBoolean ! ! -!Debugger methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16830124! - newStack: stack - | oldStack diff | - oldStack _ contextStack. - contextStack _ stack. - (oldStack == nil or: [oldStack last ~~ stack last]) - ifTrue: [contextStackList _ contextStack collect: [:ctx | ctx printString]. - ^ self]. - "May be able to re-use some of previous list" - diff _ stack size - oldStack size. - contextStackList _ diff <= 0 - ifTrue: [contextStackList copyFrom: 1-diff to: oldStack size] - ifFalse: [diff > 1 - ifTrue: [contextStack collect: [:ctx | ctx printString]] - ifFalse: [(Array with: stack first printString) , contextStackList]]! ! -!FileList methodsFor: 'file list' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16842375! - fileList - "Answer the list of files in the current volume." - - ^ list! ! -!FileList methodsFor: 'file list' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16842379! - fileListIndex - "Answer the index of the currently selected file." - - ^ listIndex! ! -!FileList methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16842981! - folderString - ^ ' [...]'! ! -!Inspector methodsFor: 'selecting' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16857022! - selectionIndex - "The receiver has a list of variables of its inspected object. One of these - is selected. Answer the index into the list of the selected variable." - - ^selectionIndex! ! -!ContextVariablesInspector methodsFor: 'code' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16825635 overrides: 16857072! - doItContext - - ^object! ! -!ContextVariablesInspector methodsFor: 'code' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16825638 overrides: 50582257! - doItReceiver - - ^object receiver! ! -!Color class methodsFor: 'instance creation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 50354615! - r: r g: g b: b alpha: alpha - ^ (self r: r g: g b: b) alpha: alpha! ! -!UndefinedObject methodsFor: 'dependents access' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16940131! - suspend - "Kills off processes that didn't terminate properly" - "Display reverse; reverse." "<-- So we can catch the suspend bug" - Processor terminateActive! ! -!Behavior methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16782789! - parserClass - "Answer a parser class to use for parsing method headers." - - ^self compilerClass parserClass! ! -!Behavior methodsFor: 'compiling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16783282! - compile: code - "Compile the argument, code, as source code in the context of the - receiver. Create an error notification if the code can not be compiled. - The argument is either a string or an object that converts to a string or a - PositionableStream on an object that converts to a string." - - ^self compile: code notifying: nil! ! -!Behavior methodsFor: 'compiling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16783402! - recompileChanges - "Compile all the methods that are in the changes file. - This validates sourceCode and variable references and forces - methods to use the current bytecode set" - - self selectorsDo: - [:sel | (self compiledMethodAt: sel) fileIndex > 1 ifTrue: - [self recompile: sel from: self]]! ! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16783625! - superclass - "Answer the receiver's superclass, a Class." - - ^superclass! ! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16784241! - sharedPools - "Answer a Set of the names of the pools (Dictionaries) that the receiver - shares. - 9/12/96 tk sharedPools have an order now" - - ^ OrderedCollection new! ! -!Behavior methodsFor: 'testing class hierarchy' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16784263! - inheritsFrom: aClass - "Answer whether the argument, aClass, is on the receiver's superclass - chain." - - | aSuperclass | - aSuperclass _ superclass. - [aSuperclass == nil] - whileFalse: - [aSuperclass == aClass ifTrue: [^true]. - aSuperclass _ aSuperclass superclass]. - ^false! ! -!Behavior methodsFor: 'testing method dictionary' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16784336! - allUnsentMessages - "Answer an array of all the messages defined by the receiver that are not sent anywhere in the system. 5/8/96 sw" - - ^ Smalltalk allUnSentMessagesIn: self selectors! ! -!Behavior methodsFor: 'enumerating' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16784542! - allSubclassesDo: aBlock - "Evaluate the argument, aBlock, for each of the receiver's subclasses." - - self subclassesDo: - [:cl | - aBlock value: cl. - cl allSubclassesDo: aBlock]! ! -!Behavior methodsFor: 'enumerating' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16784568! - selectSuperclasses: aBlock - "Evaluate the argument, aBlock, with the receiver's superclasses as the - argument. Collect into an OrderedCollection only those superclasses for - which aBlock evaluates to true. In addition, evaluate aBlock for the - superclasses of each of these successful superclasses and collect into the - OrderedCollection ones for which aBlock evaluates to true. Answer the - resulting OrderedCollection." - - | aSet | - aSet _ Set new. - self allSuperclasses do: - [:aSuperclass | - (aBlock value: aSuperclass) ifTrue: [aSet add: aSuperclass]]. - ^aSet! ! -!Behavior methodsFor: 'enumerating' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16784588! - withAllSubclassesDo: aBlock - "Evaluate the argument, aBlock, for the receiver and each of its - subclasses." - - aBlock value: self. - self allSubclassesDo: aBlock! ! -!ClassDescription methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16805702 overrides: 50527860! - theNonMetaClass - "Sent to a class or metaclass, always return the class" - - ^self! ! -!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16806234! - removeCategory: aString - "Remove each of the messages categorized under aString in the method - dictionary of the receiver. Then remove the category aString." - | categoryName | - categoryName _ aString asSymbol. - (self organization listAtCategoryNamed: categoryName) do: - [:sel | self removeSelector: sel]. - self organization removeCategory: categoryName! ! -!ClassDescription methodsFor: 'compiling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16806373! - acceptsLoggingOfCompilation - "weird name is so that it will come lexically before #compile, so that a clean build can make it through. 7/7/96 sw" - - ^ true! ! -!ClassDescription methodsFor: 'compiling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16806440 overrides: 50495977! - compile: code notifying: requestor - "Refer to the comment in Behavior|compile:notifying:." - - ^self compile: code - classified: ClassOrganizer default - notifying: requestor! ! -!ClassDescription methodsFor: 'compiling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16806529! - wantsChangeSetLogging - "Answer whether code submitted for the receiver should be remembered by the changeSet mechanism. 7/12/96 sw" - - - ^ true! ! -!ClassDescription methodsFor: 'copying' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16805706! - copy: sel from: class - "Install the method associated with the first argument, sel, a message - selector, found in the method dictionary of the second argument, class, - as one of the receiver's methods. Classify the message under -As yet not - classified-." - - self copy: sel - from: class - classified: nil! ! -!ClassDescription methodsFor: 'copying' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16805777! - copyCategory: cat from: class - "Specify that one of the categories of messages for the receiver is cat, as - found in the class, class. Copy each message found in this category." - - self copyCategory: cat - from: class - classified: cat! ! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16806694! - fileOutChangedMessages: aSet on: aFileStream - "File a description of the messages of the receiver that have been - changed (i.e., are entered into the argument, aSet) onto aFileStream." - - self fileOutChangedMessages: aSet - on: aFileStream - moveSource: false - toFile: 0! ! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16806814! - methodsFor: aString priorSource: sourcePosition inFile: fileIndex - "Prior source pointer ignored when filing in." - ^ self methodsFor: aString! ! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16807021! - reformatAll - "Reformat all methods in this class. - Leaves old code accessible to version browsing" - self selectorsDo: [:sel | self reformatMethodAt: sel]! ! -!ClassDescription methodsFor: 'instance variables' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16806072! - removeInstVarName: aString - "Remove the argument, aString, as one of the receiver's instance - variables. Create an error notification if the argument is not found." - - self subclassResponsibility! ! -!ClassDescription methodsFor: 'printing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16805847 overrides: 50584862! - storeOn: aStream - "Classes and Metaclasses have global names." - - aStream nextPutAll: self name! ! -!Class methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16802332 overrides: 16784373! - hasMethods - "Answer a Boolean according to whether any methods are defined for the - receiver (includes whether there are methods defined in the receiver's - metaclass)." - - ^super hasMethods or: [self class hasMethods]! ! -!Class methodsFor: 'compiling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16802626 overrides: 16783327! - compileAllFrom: oldClass - "Recompile all the methods in the receiver's method dictionary (not the - subclasses). Also recompile the methods in the metaclass." - - super compileAllFrom: oldClass. - self class compileAllFrom: oldClass class! ! -!Class methodsFor: 'fileIn/Out' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16802908 overrides: 50586267! - reformatAll - "Reformat all methods in this class. - Leaves old code accessible to version browsing" - super reformatAll. "me..." - self class reformatAll "...and my metaclass"! ! -!Class methodsFor: 'fileIn/Out' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16802915! - shouldFileOutPool: aPoolName - "respond with true if the user wants to file out aPoolName" - ^self confirm: ('FileOut the sharedPool ', aPoolName, '?')! ! -!Class methodsFor: 'fileIn/Out' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16802921! - shouldFileOutPools - "respond with true if the user wants to file out the shared pools" - ^self confirm: 'FileOut selected sharedPools?'! ! -!Metaclass methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16870987 overrides: 50586175! - theNonMetaClass - "Sent to a class or metaclass, always return the class" - - ^thisClass! ! -!Metaclass methodsFor: 'compiling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16871101 overrides: 50586197! - acceptsLoggingOfCompilation - "Answer whether the receiver's method submisions and class defintions should be logged to the changes file and to the current change set. The metaclass follows the rule of the class itself. 6/18/96 sw" - - ^ thisClass acceptsLoggingOfCompilation! ! -!Metaclass methodsFor: 'compiling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16871115! - possibleVariablesFor: misspelled continuedFrom: oldResults - - ^ thisClass possibleVariablesFor: misspelled continuedFrom: oldResults -! ! -!Metaclass methodsFor: 'compiling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16871121 overrides: 50586215! - wantsChangeSetLogging - "Answer whether code submitted for the receiver should be remembered by the changeSet mechanism.The metaclass follows the rule of the class itself. 7/12/96 sw" - - ^ thisClass wantsChangeSetLogging! ! -!Magnitude methodsFor: 'comparing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16865624! - min: aMin max: aMax - - ^ (self min: aMin) max: aMax! ! -!Number methodsFor: 'intervals' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16880004! - to: stop do: aBlock - "Normally compiled in-line, and therefore not overridable. - Evaluate aBlock for each element of the interval (self to: stop by: 1)." - | nextValue | - nextValue _ self. - [nextValue <= stop] - whileTrue: - [aBlock value: nextValue. - nextValue _ nextValue + 1]! ! -!Number methodsFor: 'mathematical functions' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16880035! - arcCos - "The receiver is the cosine of an angle. Answer the angle measured in - radians." - - ^self asFloat arcCos! ! -!Number methodsFor: 'mathematical functions' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16880041! - arcSin - "The receiver is the sine of an angle. Answer the angle measured in - radians." - - ^self asFloat arcSin! ! -!Number methodsFor: 'mathematical functions' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16880071! - cos - "The receiver represents an angle measured in radians. Answer its cosine." - - ^self asFloat cos! ! -!Number methodsFor: 'mathematical functions' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16880229! - sin - "The receiver represents an angle measured in radians. Answer its sine." - - ^self asFloat sin! ! -!Number methodsFor: 'mathematical functions' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16880248! - tan - "The receiver represents an angle measured in radians. Answer its - tangent." - - ^self asFloat tan! ! -!Number methodsFor: 'printing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16880407! -printStringBase: base - ^ String streamContents: - [:strm | self printOn: strm base: base]! ! -!Number methodsFor: 'printing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16880436! - storeStringBase: base - ^ String streamContents: [:strm | self storeOn: strm base: base]! ! -!Number methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16880456 overrides: 50585766! - isNumber - ^ true! ! -!Integer methodsFor: 'arithmetic' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16858919! - alignedTo: anInteger - "Answer the smallest number not less than receiver that is a multiple of anInteger." - - ^(self+anInteger-1//anInteger)*anInteger - -"5 alignedTo: 2" -"12 alignedTo: 3"! ! -!Integer methodsFor: 'bit manipulation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16859098! - << shiftAmount "left shift" - shiftAmount < 0 ifTrue: [self error: 'negative arg']. - ^ self bitShift: shiftAmount! ! -!Integer methodsFor: 'bit manipulation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16859233! - bitInvert32 - "Answer the 32-bit complement of the receiver." - - ^ self bitXor: 16rFFFFFFFF! ! -!Integer methodsFor: 'system primitives' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16860193! - replaceFrom: start to: stop with: replacement startingAt: repStart - | j | "Catches failure if LgInt replace primitive fails" - j _ repStart. - start to: stop do: - [:i | - self digitAt: i put: (replacement digitAt: j). - j _ j+1]! ! -!Integer methodsFor: 'truncation and round off' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16860281! - normalize - "SmallInts OK; LgInts override" - ^ self! ! -!Integer methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16860295! - copyto: x - | stop | - stop _ self digitLength min: x digitLength. - ^ x replaceFrom: 1 to: stop with: self startingAt: 1! ! -!Integer class methodsFor: 'instance creation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16860870 overrides: 50568324! - readFrom: aStream - "Answer a new Integer as described on the stream, aStream. - Embedded radix specifiers not allowed - use Number readFrom: for that." - ^self readFrom: aStream base: 10! ! -!LargePositiveInteger methodsFor: 'arithmetic' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16862369 overrides: 50581676! - negated - ^ (self copyto: (LargeNegativeInteger new: self digitLength)) - normalize "Need to normalize to catch SmallInteger minVal"! ! -!SmallInteger methodsFor: 'arithmetic' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16908626 overrides: 16858876! - - aNumber - "Primitive. Subtract the argument from the receiver and answer with the - result if it is a SmallInteger. Fail if the argument or the result is not a - SmallInteger. Essential. No Lookup. See Object documentation - whatIsAPrimitive." - - - ^super - aNumber! ! -!SmallInteger methodsFor: 'converting' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16908919 overrides: 16859473! - asFloat - "Primitive. Answer a Float that represents the value of the receiver. - Essential. See Object documentation whatIsAPrimitive." - - - self primitiveFailed! ! -!LookupKey methodsFor: 'comparing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16865318 overrides: 50581039! -hash - "Hash is reimplemented because = is implemented." - - ^key hash! ! -!Association methodsFor: 'printing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16780922 overrides: 50584862! - storeOn: aStream - "Store in the format (key->value)" - aStream nextPut: $(. - key storeOn: aStream. - aStream nextPutAll: '->'. - value storeOn: aStream. - aStream nextPut: $)! ! -!MessageTally methodsFor: 'collecting leaves' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16870641! - bump: hitCount - tally _ tally + hitCount! ! -!MessageTally methodsFor: 'comparing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16870702! - isPrimitives - "Detect pseudo node used to carry tally of local hits" - ^ receivers == nil! ! -!Date methodsFor: 'printing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16828135! - printFormat: formatArray - "Answer a String describing the receiver using the format denoted by the - argument, formatArray." - - | aStream | - aStream _ WriteStream on: (String new: 16). - self printOn: aStream format: formatArray. - ^aStream contents! ! -!Date methodsFor: 'printing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16828144 overrides: 16938074! - printOn: aStream - - self printOn: aStream format: #(1 2 3 $ 3 1 )! ! -!ContextPart methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16823639! - client - "Answer the client, that is, the object that sent the message that created this context." - - ^sender receiver! ! -!ContextPart methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16823656 overrides: 50581094! - method - "Answer the method of this context." - - self subclassResponsibility! ! -!ContextPart methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16824909! - stackPtr "For use only by the SystemTracer" - ^ stackp! ! -!Decompiler methodsFor: 'control' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16831421! - blockTo: end - "Decompile a range of code as in statementsTo:, but return a block node." - | exprs block oldBase | - oldBase _ blockStackBase. - blockStackBase _ stack size. - exprs _ self statementsTo: end. - block _ constructor codeBlock: exprs returns: lastReturnPc = lastPc. - blockStackBase _ oldBase. - lastReturnPc _ -1. "So as not to mislead outer calls" - ^block! ! -!Decompiler methodsFor: 'public access' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16832302! - tempAt: offset - "Needed by BraceConstructor - ^ self primCursorLocPutAgain: aPoint rounded! ! -!InputSensor methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16856647! - primCursorLocPutAgain: aPoint - "Do nothing if primitive is not implemented." - - - ^ self! ! -!InputSensor methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16856652! - primKbdNext - - ^ nil! ! -!InputSensor methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16856655! - primKbdPeek - - ^ nil! ! -!InputSensor methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16856658! - primMouseButtons - - ^ 0! ! -!ProcessorScheduler methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16895627! - highestPriority: newHighestPriority - "Change the number of priority levels currently available for use." - - | continue newProcessLists | - (quiescentProcessLists size > newHighestPriority - and: [self anyProcessesAbove: newHighestPriority]) - ifTrue: [self error: 'There are processes with priority higher than ' - ,newHighestPriority printString]. - newProcessLists _ Array new: newHighestPriority. - 1 to: ((quiescentProcessLists size) min: (newProcessLists size)) do: - [:priority | newProcessLists at: priority put: (quiescentProcessLists at: priority)]. - quiescentProcessLists size to: newProcessLists size do: - [:priority | newProcessLists at: priority put: LinkedList new]. - quiescentProcessLists _ newProcessLists! ! -!Collection methodsFor: 'enumerating' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16814182! - 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! ! -!Collection methodsFor: 'enumerating' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16814233! - collect: collectBlock thenSelect: selectBlock - ^ (self collect: collectBlock) select: selectBlock! ! -!Collection methodsFor: 'enumerating' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16814481! - select: selectBlock thenCollect: collectBlock - ^ (self select: selectBlock) collect: collectBlock! ! -!Collection methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16814884! - includesAllOf: aCollection - "Answer whether all the elements of aCollection are in the receiver." - aCollection do: [:elem | (self includes: elem) ifFalse: [^ false]]. - ^ true! ! -!Collection methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16814891! - includesAnyOf: aCollection - "Answer whether any element of aCollection is one of the receiver's elements." - aCollection do: [:elem | (self includes: elem) ifTrue: [^ true]]. - ^ false! ! -!SequenceableCollection methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16905774! - 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! ! -!SequenceableCollection methodsFor: 'copying' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16906173! - 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'"! ! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16906342 overrides: 50582883! - collect: aBlock - "Refer to the comment in Collection|collect:." - | result | - result _ self species new: self size. - 1 to: self size do: - [:index | result at: index put: (aBlock value: (self at: index))]. - ^ result! ! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16906737! - 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)]! ! -!String methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16915489! - 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! ! -!String methodsFor: 'copying' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16916211! - 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'"! ! -!String methodsFor: 'converting' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16916618! - 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! ! -!String methodsFor: 'converting' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16916848 overrides: 16814592! - 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]! ! -!String methodsFor: 'printing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16917121 overrides: 50583097! -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: $'! ! -!Symbol class methodsFor: 'instance creation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16918799 overrides: 16780604! - 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 -"! ! -!CompiledMethod methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16819501! - numTemps - "Answer the number of temporary variables used by the receiver." - - ^ (self header bitShift: -18) bitAnd: 16r3F! ! -!CompiledMethod methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16819555! - returnField - "Answer the index of the instance variable returned by a quick return - method." - | prim | - prim _ self primitive. - prim < 264 - ifTrue: [self error: 'only meaningful for quick-return'] - ifFalse: [^ prim - 264]! ! -!CompiledMethod methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16819788! - isReturnSelf - "Answer whether the receiver is a quick return of self." - - ^ self primitive = 256! ! -!CompiledMethod methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16819793! -isReturnSpecial - "Answer whether the receiver is a quick return of self or constant." - - ^ self primitive between: 256 and: 263! ! -!CompiledMethod methodsFor: 'printing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16819929! -storeLiteralsOn: aStream forClass: aBehavior - "Store the literals referenced by the receiver on aStream, each terminated by a space." - - | literal | - 2 to: self numLiterals + 1 do: - [:index | - aBehavior storeLiteral: (self objectAt: index) on: aStream. - aStream space]! ! -!CompiledMethod methodsFor: 'literals' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16820126! - literals - "Answer an Array of the literals referenced by the receiver." - | literals numberLiterals | - literals _ Array new: (numberLiterals _ self numLiterals). - 1 to: numberLiterals do: - [:index | - literals at: index put: (self objectAt: index + 1)]. - ^literals! ! -!Bitmap methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16787462! - bitPatternForDepth: depth - "The raw call on BitBlt needs a Bitmap to represent this color. I already am Bitmap like. I am already adjusted for a specific depth. Interpret me as an array of (32/depth) Color pixelValues. BitBlt aligns the first element of this array with the top scanline of the destinationForm, the second with the second, and so on, cycling through the color array as necessary. 6/18/96 tk" - - ^ self! ! -!Semaphore methodsFor: 'initialization' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16905263! - terminateProcess - "Terminate the process waiting on this semaphore, if any." - - self isEmpty ifFalse: [ self removeFirst terminate ].! ! -!OrderedCollection methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16883759 overrides: 16880774! - 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]! ! -!OrderedCollection methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16883770 overrides: 16880792! - 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]! ! -!OrderedCollection methodsFor: 'adding' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16883853! - 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! ! -!OrderedCollection methodsFor: 'adding' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16883862! - 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! ! -!OrderedCollection methodsFor: 'adding' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16883886! - growSize - ^ array size max: 2! ! -!OrderedCollection methodsFor: 'removing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16884110! - 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! ! -!OrderedCollection methodsFor: 'removing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16884129! - 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! ! -!OrderedCollection class methodsFor: 'instance creation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16884318 overrides: 16783541! - new: anInteger - "If a subclass adds fields, then it is necessary for that subclass to - reimplement new:." - - ^ super new setCollection: (Array new: anInteger)! ! -!RunArray methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16901186 overrides: 50581199! - size - | size | - size _ 0. - 1 to: runs size do: [:i | size _ size + (runs at: i)]. - ^size! ! -!RunArray methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16901390! - 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"! ! -!RunArray class methodsFor: 'instance creation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16901522 overrides: 16815105! - 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 -"! ! -!Set methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16907193! - array - ^ array! ! -!Set methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16907255! - growSize - ^ array size max: 2! ! -!Set methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16907257! - init: n - "Initialize array to an array size of n" - array _ Array new: n. - tally _ 0! ! -!Set methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16907266! - noCheckAdd: anObject - array at: (self findElementOrNil: anObject) put: anObject. - tally _ tally + 1! ! -!Set methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16907271 overrides: 16896594! - rehash - | newSelf | - newSelf _ self species new: self size. - self do: [:each | newSelf noCheckAdd: each]. - array _ newSelf array! ! -!Set methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16907308! - withArray: anArray - "private -- for use only in copy" - array _ anArray! ! -!Set class methodsFor: 'instance creation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16907374 overrides: 16783533! -new - ^ self new: 4! ! -!Set class methodsFor: 'instance creation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16907377 overrides: 16783541! - new: nElements - "Create a Set large enough to hold nElements without growing" - ^ super new init: (self sizeFor: nElements)! ! -!Set class methodsFor: 'instance creation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16907383! -sizeFor: nElements - "Large enough size to hold nElements with some slop (see fullCheck)" - nElements <= 0 ifTrue: [^ 1]. - ^ nElements+1*4//3! ! -!Dictionary methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16833288! - 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! ! -!Dictionary methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16833754 overrides: 50587130! - 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! ! -!Dictionary methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16833770 overrides: 50587137! - rehash - "Smalltalk rehash." - | newSelf | - newSelf _ self species new: self size. - self associationsDo: [:each | newSelf noCheckAdd: each]. - array _ newSelf array! ! -!Dictionary methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16833803! - 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)]! ! -!MethodDictionary methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16872013 overrides: 16833527! - add: anAssociation - ^ self at: anAssociation key put: anAssociation value! ! -!MethodDictionary methodsFor: 'removing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16872084 overrides: 16833614! - removeKey: key ifAbsent: errorBlock - "The interpreter might be using this MethodDict while - this method is running!! Therefore we perform the removal - in a copy, and then atomically become that copy" - | copy | - copy _ self copy. - copy removeDangerouslyKey: key ifAbsent: [^ errorBlock value]. - self become: copy! ! -!MethodDictionary methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16872156 overrides: 50496994! - keyAt: index - - ^ self basicAt: index! ! -!MethodDictionary methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16872159! - methodArray - ^ array! ! -!MethodDictionary methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16872230 overrides: 50496986! - swap: oneIndex with: otherIndex - | element | - element _ self basicAt: oneIndex. - self basicAt: oneIndex put: (self basicAt: otherIndex). - self basicAt: otherIndex put: element. - super swap: oneIndex with: otherIndex. -! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16920119! - verifyChanges "Smalltalk verifyChanges" - "Recompile all methods in the changes file." - Smalltalk allBehaviorsDo: [:class | class recompileChanges]. -! ! -!SystemDictionary methodsFor: 'image, changes name' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16920232! - imageName: newName - "Set the the full path name for the current image. All further snapshots will use this." - - - ^ self primitiveFailed! ! -!SystemDictionary methodsFor: 'memory space' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16920288! -bytesLeft - "Answer the number of bytes of space available. Does a full garbage collection." - - ^ self garbageCollect -! ! -!SystemDictionary methodsFor: 'memory space' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16920332! - createStackOverflow - "For testing the low space handler..." - "Smalltalk installLowSpaceWatcher; createStackOverflow" - - self createStackOverflow. "infinite recursion"! ! -!SystemDictionary methodsFor: 'memory space' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16920347! - garbageCollectMost - "Primitive. Reclaims recently created garbage (which is usually most of it) fairly quickly and answers the number of bytes of available space." - - - ^ self primBytesLeft! ! -!SystemDictionary methodsFor: 'memory space' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16920460! - primBytesLeft - "Primitive. Answer the number of bytes available for new object data. - Not accurate unless preceded by - Smalltalk garbageCollectMost (for reasonable accuracy), or - Smalltalk garbageCollect (for real accuracy). - See Object documentation whatIsAPrimitive." - - - ^ 0! ! -!SystemDictionary methodsFor: 'memory space' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16920471! - primLowSpaceSemaphore: aSemaphore - "Primitive. Register the given Semaphore to be signalled when the - number of free bytes drops below some threshold. Disable low-space - interrupts if the argument is nil." - - - self primitiveFailed! ! -!SystemDictionary methodsFor: 'memory space' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16920481! - primSignalAtBytesLeft: numBytes - "Tell the interpreter the low-space threshold in bytes. When the free - space falls below this threshold, the interpreter will signal the low-space - semaphore, if one has been registered. Disable low-space interrupts if the - argument is zero. Fail if numBytes is not an Integer." - - - self primitiveFailed! ! -!SystemDictionary methodsFor: 'memory space' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16920502! - signalLowSpace - "Signal the low-space semaphore to alert the user that space is running low." - - LowSpaceSemaphore signal.! ! -!SystemDictionary methodsFor: 'profiling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16921399! - clearProfile - "Clear the profile database." - - -! ! -!SystemDictionary methodsFor: 'profiling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16921403! - dumpProfile - "Dump the profile database to a file." - - -! ! -!SystemDictionary methodsFor: 'profiling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16921407! - profile: aBlock - "Make a virtual machine profile of the given block." - "Note: Profiling support is provided so that VM implementors - can better understand and improve the efficiency of the virtual - machine. To use it, you must be running a version of the - virtual machine compiled with profiling enabled (which - makes it much slower than normal even when not profiling). - You will also need the CodeWarrior profile reader application." - - self stopProfiling. - self clearProfile. - self startProfiling. - aBlock value. - self stopProfiling. - self dumpProfile.! ! -!SystemDictionary methodsFor: 'profiling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16921426! - startProfiling - "Start profiling the virtual machine." - - -! ! -!SystemDictionary methodsFor: 'profiling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16921430! - stopProfiling - "Stop profiling the virtual machine." - - -! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16922539! - lastQuitLogPosition - ^ LastQuitLogPosition! ! -!SystemDictionary methodsFor: 'special objects' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16923432! - compactClassesArray "Smalltalk compactClassesArray" - "Return the array of 31 classes whose instances may be - represented compactly" - ^ Smalltalk specialObjectsArray at: 29! ! -!SystemDictionary methodsFor: 'special objects' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16923710! - specialObjectsArray "Smalltalk specialObjectsArray at: 1" - - ^ self primitiveFailed! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16923867! - browseAllCallsOn: literal1 and: literal2 - "Create and schedule a message browser on each method that calls on the - two Symbols, literal1 and literal2. For example, Smalltalk - browseAllCallsOn: #at: and: #at:put:." - - ^self - browseMessageList: (self allCallsOn: literal1 and: literal2) - name: literal1 printString , ' -and- ' , literal2 printString! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16923917! - browseAllImplementorsOf: selector - "Create and schedule a message browser on each method that implements - the message whose selector is the argument, selector. For example, - Smalltalk browseAllImplementorsOf: #at:put:." - - ^self browseMessageList: (self allImplementorsOf: selector) name: 'Implementors of ' , selector! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16923947! - browseAllImplementorsOfList: selectorList - "Create and schedule a message browser on each method that implements - the message whose selector is in the argument selectorList. For example, - Smalltalk browseAllImplementorsOf: #(at:put: size). - 1/16/96 sw: defer to the titled version" - - self browseAllImplementorsOfList: selectorList title: 'Implementors of all'! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16923987! - browseAllSelect: aBlock - "Create and schedule a message browser on each method that, when used - as the block argument to aBlock gives a true result. For example, - Smalltalk browseAllSelect: [:method | method numLiterals > 10]." - - ^self browseMessageList: (self allSelect: aBlock) name: 'selected messages'! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16924163! - browseMessageList: messageList name: label - "Create and schedule a MessageSet browser on messageList." - ^ self browseMessageList: messageList name: label autoSelect: nil! ! -!Stream methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16914011! - next - "Answer the next object accessible by the receiver." - - self subclassResponsibility! ! -!Stream methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16914015! - next: anInteger - "Answer the next anInteger number of objects accessible by the receiver." - - | aCollection | - aCollection _ OrderedCollection new. - anInteger timesRepeat: [aCollection addLast: self next]. - ^aCollection! ! -!Stream methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16914024! - 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! ! -!Stream methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16914032! - 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! ! -!Stream methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16914044! - nextPut: anObject - "Insert the argument, anObject, as the next object accessible by the - receiver. Answer anObject." - - self subclassResponsibility! ! -!Stream methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16914050! - 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! ! -!Stream methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16914077! - atEnd - "Answer whether the receiver can access any more objects." - - self subclassResponsibility! ! -!Stream methodsFor: 'enumerating' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16914117! - do: aBlock - "Evaluate aBlock for each of the objects accessible by receiver." - - [self atEnd] - whileFalse: [aBlock value: self next]! ! -!PositionableStream methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16891420! - originalContents - "Answer the receiver's actual contents collection, NOT a copy. 1/29/96 sw" - - ^ collection! ! -!PositionableStream methodsFor: 'positioning' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16891663! - reset - "Set the receiver's position to the beginning of the sequence of objects." - - position _ 0! ! -!PositionableStream methodsFor: 'positioning' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16891674! - setToEnd - "Set the position of the receiver to the end of the sequence of objects." - - position _ readLimit! ! -!PositionableStream methodsFor: 'positioning' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16891687! - 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! ! -!PositionableStream methodsFor: 'fileIn/Out' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16891852! - 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" - ]. - ! ! -!PositionableStream methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16891883! - setFrom: newStart to: newStop - - position _ newStart - 1. - readLimit _ newStop! ! -!WriteStream methodsFor: 'fileIn/Out' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16946522! - 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; nextPut: terminator! ! -!WriteStream class methodsFor: 'instance creation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16946643 overrides: 50583954! - 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! ! -!WriteStream class methodsFor: 'instance creation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16946655! - with: aCollection - "Answer an instance of me on the argument, aCollection, positioned to - store objects at the end of aCollection." - - ^self basicNew with: aCollection! ! -!WriteStream class methodsFor: 'instance creation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16946663! - 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)! ! -!ReadWriteStream methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16898091 overrides: 16882612! - name - ^ 'a stream' "for fileIn compatibility"! ! -!ReadWriteStream methodsFor: 'fileIn/Out' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16898134! - fileNameEndsWith: aString - "See comment in FileStream fileNameEndsWith:" - - ^false! ! -!FileStream methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16843561 overrides: 50332169! - nextPut: aByte - "1/31/96 sw: subclassResponsibility" - - self subclassResponsibility! ! -!FileStream methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16843565 overrides: 50335230! - nextPutAll: aCollection - "1/31/96 sw: made subclass responsibility" - - self subclassResponsibility! ! -!FileStream methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16843570 overrides: 50583994! - size - "Answer the size of the file in characters. - 1/31/96 sw: made subclass responsibility" - - self subclassResponsibility! ! -!FileStream methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16843576 overrides: 50332155! - atEnd - "Answer true if the current position is >= the end of file position. - 1/31/96 sw: subclassResponsibility" - - self subclassResponsibility! ! -!FileStream methodsFor: 'positioning' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16843585 overrides: 50583922! - position - "Answer the current character position in the file. - 1/31/96 sw: subclassResponsibility" - - self subclassResponsibility! ! -!FileStream methodsFor: 'positioning' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16843591 overrides: 50583999! - position: pos - "Set the current character position in the file to pos. - 1/31/96 sw: made subclassResponsibility" - - self subclassResponsibility! ! -!FileStream methodsFor: 'positioning' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16843597 overrides: 50584006! - reset - "Set the current character position to the beginning of the file. - 1/31/96 sw: subclassResponsibility" - - self subclassResponsibility! ! -!FileStream methodsFor: 'positioning' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16843603 overrides: 16946437! - setToEnd - "Set the current character position to the end of the File. The same as - self position: self size. 1/31/96 sw: made subclassResponsibility" - - self subclassResponsibility! ! -!FileStream methodsFor: 'positioning' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16843610 overrides: 16891680! - skip: n - "Set the character position to n characters from the current position. - Error if not enough characters left in the file - 1/31/96 sw: made subclassResponsibility." - - self subclassResponsibility! ! -!FileStream methodsFor: 'file accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16843700 overrides: 50587658! - name - "Answer the name of the file for the page the receiver is streaming over. 1/31/96 sw: made subclassResponsibility" - - self subclassResponsibility! ! -!StandardFileStream methodsFor: 'open/close' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16912978 overrides: 16914059! - openReadOnly - "Open the receiver as a read-only file. 1/31/96 sw" - - ^ self open: name forWrite: false! ! -!StandardFileStream methodsFor: 'properties-setting' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16913001 overrides: 16891544! - isBinary - ^ buffer1 class == ByteArray! ! -!StandardFileStream methodsFor: 'access' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16913045! - isDirectory - "Answer whether the receiver represents a directory. For the post-transition case, uncertain what to do. 2/14/96 sw" - ^ false! ! -!StandardFileStream methodsFor: 'access' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16913073 overrides: 16914062! - printOn: aStream - "Put a printed version of the receiver onto aStream. 1/31/96 sw" - - aStream nextPutAll: self class name; nextPutAll: ': '; print: name! ! -!StandardFileStream methodsFor: 'access' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16913084 overrides: 50587684! - size - "Answer the size of the file in characters. 2/12/96 sw" - - ^ self primSize: fileID! ! -!StandardFileStream methodsFor: 'read, write, position' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16913445 overrides: 50587727! - setToEnd - "Set the position of the receiver to the end of file. 1/31/96 sw" - - self position: self size! ! -!DataStream methodsFor: 'write and read' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827175! - beginReference: anObject - "WeÕre starting to read anObject. Remember it and its reference - position (if we care; ReferenceStream cares). Answer the - reference position." - - ^ 0! ! -!DataStream methodsFor: 'write and read' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827183! - getCurrentReference - "PRIVATE -- Return the currentReference posn. - Overridden by ReferenceStream." - - ^ 0! ! -!DataStream methodsFor: 'write and read' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827305! - noteCurrentReference: typeID - "PRIVATE -- If we support references for type typeID, remember - the current byteStream position so we can add the next object to - the ÔobjectsÕ dictionary, and return true. Else return false. - This method is here to be overridden by ReferenceStream" - - ^ false! ! -!DataStream methodsFor: 'write and read' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827375! - readBitmap - "PRIVATE -- Read the contents of a Bitmap." - - ^ Bitmap newFromStream: byteStream - "Note that the reader knows that the size is in long words, but the data is in bytes."! ! -!DataStream methodsFor: 'write and read' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827405! - readFalse - "PRIVATE -- Read the contents of a False." - - ^ false! ! -!DataStream methodsFor: 'write and read' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827504! - readNil - "PRIVATE -- Read the contents of an UndefinedObject." - - ^ nil! ! -!DataStream methodsFor: 'write and read' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827574! - readSymbol - "PRIVATE -- Read the contents of a Symbol." - - ^ self readString asSymbol! ! -!DataStream methodsFor: 'write and read' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827579! - readTrue - "PRIVATE -- Read the contents of a True." - - ^ true! ! -!DataStream methodsFor: 'write and read' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827636! - setCurrentReference: refPosn - "PRIVATE -- Set currentReference to refPosn. - Noop here. Cf. ReferenceStream."! ! -!DataStream methodsFor: 'write and read' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827642! - tryToPutReference: anObject typeID: typeID - "PRIVATE -- If we support references for type typeID, and if - anObject already appears in my output stream, then put a - reference to the place where anObject already appears. If we - support references for typeID but didnÕt already put anObject, - then associate the current stream position with anObject in - case one wants to nextPut: it again. - Return true after putting a reference; false if the object still - needs to be put. - For DataStream this is trivial. ReferenceStream overrides this." - - ^ false! ! -!DataStream methodsFor: 'write and read' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827743! - writeFalse: aFalse - "PRIVATE -- Write the contents of a False."! ! -!DataStream methodsFor: 'write and read' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827756! - writeInstance: anObject - "PRIVATE -- Write the contents of an arbitrary instance." - - ^ anObject storeDataOn: self! ! -!DataStream methodsFor: 'write and read' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827770! - writeNil: anUndefinedObject - "PRIVATE -- Write the contents of an UndefinedObject."! ! -!DataStream methodsFor: 'write and read' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827796! - writeSymbol: aSymbol - "PRIVATE -- Write the contents of a Symbol." - - self writeString: aSymbol! ! -!DataStream methodsFor: 'write and read' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827801! - writeTrue: aTrue - "PRIVATE -- Write the contents of a True."! ! -!DataStream methodsFor: 'write and read' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827805! - writeUser: anObject - "Write the contents of an arbitrary User instance (and its devoted class)." - " 7/29/96 tk" - - "If anObject is an instance of a unique user class, will lie and say it has a generic class" - ^ anObject storeDataOn: self! ! -!DataStream methodsFor: 'other' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827827 overrides: 50587540! - atEnd - "Answer true if the stream is at the end." - - ^ byteStream atEnd! ! -!DataStream methodsFor: 'other' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827853 overrides: 16914006! - flush - "Guarantee that any writes to me are actually recorded on disk. -- 11/17/92 jhm" - - ^ byteStream flush! ! -!DataStream methodsFor: 'other' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827858 overrides: 50587491! - next: anInteger - "Answer an Array of the next anInteger objects in the stream." - | array | - - array _ Array new: anInteger. - 1 to: anInteger do: [:i | - array at: i put: self next]. - ^ array! ! -!DataStream methodsFor: 'other' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827866! - reset - "Reset the stream." - - byteStream reset! ! -!DataStream methodsFor: 'other' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827903 overrides: 16880927! - size - "Answer the stream's size." - - ^ byteStream size! ! -!DummyStream methodsFor: 'error handling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16835845 overrides: 16881497! - subclassResponsibility - "Do nothing. Most messages to class Stream are defined as subclassResponsibility. Just accept them. 8/17/96 tk" - - "No error. Just go on."! ! -!DummyStream methodsFor: 'positioning' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16835830! - position - "Return any random number. Here is where the real lying begins. We are a DummyStream afterall. 8/17/96 tk" - - ^ 47 ! ! -!Compiler methodsFor: 'error handling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16822073 overrides: 16882681! - notify: aString - "Refer to the comment in Object|notify:." - - ^self notify: aString at: sourceStream position + 1! ! -!Compiler class methodsFor: 'evaluating' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16822127! - evaluate: textOrString for: anObject logged: logFlag - "See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs, - a Syntax Error view is created rather than notifying any requestor." - - ^self evaluate: textOrString for: anObject notifying: nil logged: logFlag! ! -!Compiler class methodsFor: 'evaluating' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16822158! - evaluate: textOrString logged: logFlag - "See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs, - a Syntax Error view is created rather than notifying any requestor. - Compilation is carried out with respect to nil, i.e., no object." - - ^self evaluate: textOrString for: nil logged: logFlag! ! -!Scanner methodsFor: 'expression types' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16903674! - advance - - | prevToken | - prevToken _ token. - self scanToken. - ^prevToken! ! -!Scanner methodsFor: 'initialization' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16904207! - scan: inputStream - "Bind the input stream, fill the character buffers and first token buffer." - - source _ inputStream. - self step. - self step. - self scanToken! ! -!Parser methodsFor: 'error handling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16885707 overrides: 50584067! - notify: aString - "Notify problem at token before 'here'." - - ^self notify: aString at: prevMark + requestorOffset! ! -!Parser methodsFor: 'scanning' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16885776! - startOfNextToken - "Return starting position in source of next token." - - hereType == #doIt ifTrue: [^source position + 1]. - ^hereMark! ! -!Parser methodsFor: 'primitives' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16885813! -allocateLiteral: lit - encoder litIndex: lit! ! -!Parser methodsFor: 'error correction' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16886751! - substituteSelector: selectorParts wordIntervals: spots - "Substitute the correctSelector into the (presuamed interactive) receiver." - | offset | - offset _ 0. - selectorParts with: spots do: - [ :word :interval | - offset _ self substituteWord: word wordInterval: interval offset: offset ] -! ! -!ParseNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16884672! - assignmentCheck: encoder at: location - "For messageNodes masquerading as variables for the debugger. - For now we let this through - ie we allow stores ev - into args. Should check against numArgs, though." - ^ -1! ! -!ParseNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16884693 overrides: 16882560! - isComplex - "Used for pretty printing to determine whether to start a new line" - - ^false! ! -!ParseNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16884697! - isConstantNumber "Overridden in LiteralNode" - ^false! ! -!ParseNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16884709! - isMessage: selSymbol receiver: rcvrPred arguments: argsPred - "See comment in MessageNode." - - ^false! ! -!ParseNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16884746! - isSpecialConstant - ^ false! ! -!ParseNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16884773! - toDoIncrement: ignored - "Only meant for Messages or Assignments - else return nil" - ^ nil! ! -!Encoder methodsFor: 'results' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16837214! - literals - "Should only be used for decompiling primitives" - ^ literalStream contents! ! -!Encoder methodsFor: 'encoding' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16837445! - encodeLiteral: object - - ^self - name: object - key: (class literalScannedAs: object notifying: self) - class: LiteralNode - type: LdLitType - set: litSet! ! -!Encoder methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16837571! - classEncoding - "This is a hack so that the parser may findout what class it was parsing for when it wants to create a syntax error view." - ^ class! ! -!Encoder methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16837627! - reallyBind: name - - | node | - node _ self newTemp: name. - scopeTable at: name put: node. - ^node! ! -!Encoder methodsFor: 'error handling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16837696 overrides: 50585741! - notify: string at: location - - | req | - requestor == nil - ifFalse: - [req _ requestor. - self release. - req notify: string at: location]. - ^false! ! -!AssignmentNode methodsFor: 'equation translation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16780812! - variable - ^variable! ! -!AssignmentNode methodsFor: 'initialization' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16780815 overrides: 50588101! - toDoIncrement: var - var = variable ifFalse: [^ nil]. - (value isMemberOf: MessageNode) - ifTrue: [^ value toDoIncrement: var] - ifFalse: [^ nil]! ! -!AssignmentNode methodsFor: 'initialization' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16780822 overrides: 16881508! - value - ^ value! ! -!BraceNode methodsFor: 'enumerating' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16790981! - casesForwardDo: aBlock - "For each case in forward order, evaluate aBlock with three arguments: - the key block, the value block, and whether it is the last case." - - | numCases case | - 1 to: (numCases _ elements size) do: - [:i | - case _ elements at: i. - aBlock value: case receiver value: case arguments first value: i=numCases]! ! -!BraceNode methodsFor: 'enumerating' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16790993! - casesReverseDo: aBlock - "For each case in reverse order, evaluate aBlock with three arguments: - the key block, the value block, and whether it is the last case." - - | numCases case | - (numCases _ elements size) to: 1 by: -1 do: - [:i | - case _ elements at: i. - aBlock value: case receiver value: case arguments first value: i=numCases]! ! -!BraceNode methodsFor: 'initialization' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16791107! - elements: collection - "Decompile." - - elements _ collection! ! -!BraceNode methodsFor: 'initialization' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16791111! - elements: collection sourceLocations: locations - "Compile." - - elements _ collection. - sourceLocations _ locations! ! -!BraceNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16790978! - numElements - - ^ elements size! ! -!CascadeNode methodsFor: 'printing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16795225 overrides: 50584136! - printOn: aStream indent: level - self printOn: aStream indent: level precedence: 0! ! -!CascadeNode methodsFor: 'initialization' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16795271! - receiver: receivingObject messages: msgs - " Transcript show: 'abc'; cr; show: 'def' " - - receiver _ receivingObject. - messages _ msgs! ! -!BlockNode methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16789601! - firstArgument - ^ arguments first! ! -!BlockNode methodsFor: 'equation translation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16790009! - statements - ^statements! ! -!BlockNode methodsFor: 'equation translation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16790012! -statements: val - statements _ val! ! -!BlockNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16789691! - isJustCaseError - - ^ statements size = 1 and: - [statements first - isMessage: #caseError - receiver: [:r | r==NodeSelf] - arguments: nil]! ! -!BlockNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16789697! - isQuick - ^ statements size = 1 - and: [statements first isVariableReference - or: [statements first isSpecialConstant]]! ! -!MethodNode methodsFor: 'code generation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16872469! - encoder - ^ encoder! ! -!LiteralNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16865085 overrides: 50588086! - isConstantNumber - ^ key isNumber! ! -!LiteralNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16865091 overrides: 50588097! - isSpecialConstant - ^ code between: LdTrue and: LdMinus1+3! ! -!LiteralNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16865095! - literalValue - - ^key! ! -!SelectorNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16905022! - isPvtSelector - "Answer if this selector node is a private message selector." - - ^key isPvtSelector! ! -!VariableNode methodsFor: 'initialization' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16942032! - asStorableNode: encoder - ^ self! ! -!MessageNode methodsFor: 'equation translation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16867985! - arguments - ^arguments! ! -!MessageNode methodsFor: 'equation translation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16868005! -receiver - ^receiver! ! -!MessageNode methodsFor: 'equation translation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16868013! - selector - ^selector! ! -!MessageNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16868504 overrides: 50588091! - isMessage: selSymbol receiver: rcvrPred arguments: argsPred - "Answer whether selector is selSymbol, and the predicates rcvrPred and argsPred - evaluate to true with respect to receiver and the list of arguments. If selSymbol or - either predicate is nil, it means 'don't care'. Note that argsPred takes numArgs - arguments. All block arguments are ParseNodes." - - ^(selSymbol isNil or: [selSymbol==selector key]) and: - [(rcvrPred isNil or: [rcvrPred value: receiver]) and: - [(argsPred isNil or: [argsPred valueWithArguments: arguments])]]! ! -!MessageNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16868553 overrides: 50588101! - toDoIncrement: variable - (receiver = variable and: [selector key = #+]) - ifFalse: [^ nil]. - arguments first isConstantNumber - ifTrue: [^ arguments first] - ifFalse: [^ nil]! ! -!MessageNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16868560! - toDoLimit: variable - (receiver = variable and: [selector key = #<= or: [selector key = #>=]]) - ifTrue: [^ arguments first] - ifFalse: [^ nil]! ! -!ReturnNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16901106 overrides: 50588097! -isSpecialConstant - - ^expr isSpecialConstant! ! -!DecompilerConstructor methodsFor: 'constructor' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16832504! - codeBrace: elements - - ^BraceNode new elements: elements! ! -!ParseStack methodsFor: 'printing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16885466 overrides: 50508082! - printOn: aStream - - super printOn: aStream. - aStream nextPutAll: ' at '; print: position; nextPutAll: ' of '; print: length! ! -!DiskProxy class methodsFor: 'as yet unclassified' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16835074! - global: globalNameSymbol selector: selectorSymbol args: argArray - "Create a new DiskProxy constructor with the given - globalNameSymbol, selectorSymbol, and argument Array. - It will internalize itself by looking up the global object name - in the SystemDictionary (Smalltalk) and sending it this message - with these arguments." - - ^ self new global: globalNameSymbol - selector: selectorSymbol - args: argArray! ! -!Form methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16846766! -extent - ^ width @ height! ! -!Form methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16846774! - height - ^ height! ! -!Form methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16846795! - width - ^ width! ! -!Form methodsFor: 'analyzing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16846848! - innerPixelRectFor: pv orNot: not - "Return a rectangle describing the smallest part of me that includes - all pixels of value pv. - Note: If orNot is true, then produce a copy that includes all pixels - that are DIFFERENT from the supplied (background) value" - - | xTally yTally | - xTally _ self xTallyPixelValue: pv orNot: not. - yTally _ self yTallyPixelValue: pv orNot: not. - ^ ((xTally findFirst: [:t | t>0]) - 1) @ ((yTally findFirst: [:t | t>0]) - 1) - corner: - (xTally findLast: [:t | t>0])@(yTally findLast: [:t | t>0])! ! -!Form methodsFor: 'fileIn/Out' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16847837 overrides: 50584862! - storeOn: aStream - - self storeOn: aStream base: 10! ! -!Form methodsFor: 'filling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16847961! - fillFromXColorBlock: colorBlock - "Horizontal Gradient Fill. - Supply relative x in [0.0 ... 1.0] to colorBlock, - and paint each pixel with the color that comes back" - | xRel | - 0 to: width-1 do: - [:x | xRel _ x asFloat / (width-1) asFloat. - self fill: (x@0 extent: 1@height) - fillColor: (colorBlock value: xRel)] -" -((Form extent: 100@100 depth: Display depth) - fillFromXColorBlock: [:x | Color r: x g: 0.0 b: 0.5]) display -"! ! -!Form methodsFor: 'filling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16847998! - fillFromYColorBlock: colorBlock - "Vertical Gradient Fill. - Supply relative y in [0.0 ... 1.0] to colorBlock, - and paint each pixel with the color that comes back" - | yRel | - 0 to: height-1 do: - [:y | yRel _ y asFloat / (height-1) asFloat. - self fill: (0@y extent: width@1) - fillColor: (colorBlock value: yRel)] -" -((Form extent: 100@100 depth: Display depth) - fillFromYColorBlock: [:y | Color r: y g: 0.0 b: 0.5]) display -"! ! -!Form class methodsFor: 'instance creation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16849047! - fromDisplay: aRectangle - "Answer an instance of me with bitmap initialized from the area of the - display screen defined by aRectangle." - - ^ (self extent: aRectangle extent depth: Display depth) - fromDisplay: aRectangle! ! -!Form class methodsFor: 'mode constants' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16849123! - blend - "Answer the integer denoting BitBlt's alpha blend combination rule." - ^24! ! -!Cursor class methodsFor: 'class initialization' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16826361 overrides: 50335344! - startUp - self currentCursor: self currentCursor! ! -!BitBlt methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16785492! - clipRect - "Answer the receiver's clipping area rectangle." - - ^clipX @ clipY extent: clipWidth @ clipHeight! ! -!BitBlt methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16785515! - combinationRule: anInteger - "Set the receiver's combination rule to be the argument, anInteger, a - number in the range 0-15." - - combinationRule _ anInteger! ! -!BitBlt methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16785522! - destForm - ^ destForm! ! -!BitBlt methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16785542! - destX: anInteger - "Set the top left x coordinate of the receiver's destination form to be the - argument, anInteger." - - destX _ anInteger! ! -!BitBlt methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16785554! - destY: anInteger - "Set the top left y coordinate of the receiver's destination form to be the - argument, anInteger." - - destY _ anInteger! ! -!BitBlt methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16785590! - height: anInteger - "Set the receiver's destination form height to be the argument, anInteger." - - height _ anInteger! ! -!BitBlt methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16785597! - sourceForm: aForm - "Set the receiver's source form to be the argument, aForm." - - sourceForm _ aForm! ! -!BitBlt methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16785602! - sourceOrigin: aPoint - "Set the receiver's source form coordinates to be those of the argument, - aPoint." - - sourceX _ aPoint x. - sourceY _ aPoint y! ! -!BitBlt methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16785608! - sourceRect: aRectangle - "Set the receiver's source form top left x and y, width and height to be - the top left coordinate and extent of the argument, aRectangle." - - sourceX _ aRectangle left. - sourceY _ aRectangle top. - width _ aRectangle width. - height _ aRectangle height! ! -!BitBlt methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16785618! - sourceX: anInteger - "Set the receiver's source form top left x to be the argument, anInteger." - - sourceX _ anInteger! ! -!BitBlt methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16785623! - sourceY: anInteger - "Set the receiver's source form top left y to be the argument, anInteger." - - sourceY _ anInteger! ! -!BitBlt methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16785628! - width: anInteger - "Set the receiver's destination form width to be the argument, anInteger." - - width _ anInteger! ! -!BitBlt methodsFor: 'copying' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16785755! - copyForm: srcForm to: destPt rule: rule fillColor: color - sourceForm _ srcForm. - self fillColor: color. "sets halftoneForm" - combinationRule _ rule. - destX _ destPt x + sourceForm offset x. - destY _ destPt y + sourceForm offset y. - sourceX _ 0. - sourceY _ 0. - width _ sourceForm width. - height _ sourceForm height. - self copyBits! ! -!BitBlt methodsFor: 'copying' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16785783! - fill: destRect fillColor: grayForm rule: rule - "Fill with a Color, not a Form. 6/18/96 tk" - sourceForm _ nil. - self fillColor: grayForm. "sets halftoneForm" - combinationRule _ rule. - destX _ destRect left. - destY _ destRect top. - sourceX _ 0. - sourceY _ 0. - width _ destRect width. - height _ destRect height. - self copyBits! ! -!BitBlt class methodsFor: 'instance creation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16786233! - toForm: aForm - ^ self new setDestForm: aForm! ! -!Point methodsFor: 'arithmetic' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16890272! - abs - "Answer a Point whose x and y are the absolute values of the receiver's x - and y." - - ^ x abs @ y abs! ! -!Point methodsFor: 'comparing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16890318! - max: aPoint - "Answer the lower right corner of the rectangle uniquely defined by the - receiver and the argument, aPoint." - - ^ (x max: aPoint x) @ (y max: aPoint y)! ! -!Point methodsFor: 'comparing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16890325! - min: aPoint - "Answer the upper left corner of the rectangle uniquely defined by the - receiver and the argument, aPoint." - - ^ (x min: aPoint x) @ (y min: aPoint y)! ! -!Point methodsFor: 'comparing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16890332! - min: aMin max: aMax - - ^ (self min: aMin) max: aMax! ! -!Point methodsFor: 'converting' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16890355! - asIntegerPoint - ^ x asInteger @ y asInteger! ! -!Point methodsFor: 'point functions' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16890595! - normal - "Answer a Point representing the unit vector rotated 90 deg clockwise." - - | n | - n _ y negated @ x. - ^n / (n x * n x + (n y * n y)) sqrt! ! -!Point methodsFor: 'printing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16890722 overrides: 50584862! - storeOn: aStream - "x@y printed form is good for storing too" - self printOn: aStream! ! -!Point methodsFor: 'truncation and round off' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16890822! - truncateTo: grid - "Answer a Point that is the receiver's x and y truncated to grid x and - grid y." - | gridPoint | - gridPoint _ grid asPoint. - ^(x truncateTo: gridPoint x) @ (y truncateTo: gridPoint y)! ! -!Rectangle methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16898531! - boundingBox - ^ self! ! -!Rectangle methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16898542! - corners - "Return an array of corner points in the order of a quadrilateral spec for WarpBlt" - ^ Array with: self topLeft with: self bottomLeft with: self bottomRight with: self topRight! ! -!Rectangle methodsFor: 'comparing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16898639 overrides: 16881052! - hash - "Hash is reimplemented because = is implemented." - - ^origin hash bitXor: corner hash! ! -!Rectangle methodsFor: 'rectangle functions' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16898644! - amountToTranslateWithin: aRectangle - "Answer a Point, delta, such that self + delta is forced within aRectangle." - "Altered so as to prefer to keep self topLeft inside when all of self - cannot be made to fit 7/27/96 di" - | dx dy | - dx _ 0. dy _ 0. - self right > aRectangle right ifTrue: [dx _ aRectangle right - self right]. - self bottom > aRectangle bottom ifTrue: [dy _ aRectangle bottom - self bottom]. - (self left + dx) < aRectangle left ifTrue: [dx _ aRectangle left - self left]. - (self top + dy) < aRectangle top ifTrue: [dy _ aRectangle top - self top]. - ^ dx@dy! ! -!Rectangle methodsFor: 'rectangle functions' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16898707! - encompass: aPoint - "Answer a Rectangle that contains both the receiver and aPoint. 5/30/96 sw" - - ^ Rectangle - origin: (origin min: aPoint) - corner: (corner max: aPoint)! ! -!Rectangle methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16898881! - hasPositiveExtent - ^ (corner x > origin x) and: [corner y > origin y]! ! -!Rectangle methodsFor: 'truncation and round off' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16898926! - truncateTo: grid - "Answer a Rectangle whose origin and corner are truncated to grid x and grid y." - - ^Rectangle origin: (origin truncateTo: grid) - corner: (corner truncateTo: grid)! ! -!StrikeFont methodsFor: 'emphasis' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16914427! - emphasis - "Answer the integer code for synthetic bold, italic, underline, and - strike-out." - - ^emphasis! ! -!ChangeSet methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16797742! - name: anObject - name _ anObject! ! -!ChangeSet methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16797745 overrides: 50508082! - printOn: aStream - "2/7/96 sw: provide the receiver's name in the printout" - super printOn: aStream. - aStream nextPutAll: ' named ', self name! ! -!ChangeSet methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16797770! - isMoribund - "Answer whether the receiver is obsolete and about to die; part of an effort to get such guys cleared out from the change sorter. 2/7/96 sw" - - ^ name == nil ! ! -!PopUpMenu methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16890913! - labelString - - ^ labelString! ! -!PopUpMenu methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16890916! - lineArray - - ^ lineArray! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4703-Squeak1.0-stamps-JuanVuletich-2021Jul27-19h21m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4702] on 27 July 2021 at 7:24:05 pm'! -!Object methodsFor: 'translation support' stamp: 'Squeak1.1 9/23/1996 20:34:59' prior: 16882640! - var: varSymbol declareC: declString - "For translation only; noop when running in Smalltalk."! ! -!SequenceableCollection methodsFor: 'accessing' stamp: 'Squeak1.1 9/23/1996 20:34:59' prior: 16905736! - indexOf: anElement startingAt: start 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." - start to: self size do: - [:i | (self at: i) = anElement ifTrue: [^ i]]. - ^ exceptionBlock value! ! -!FileStream class methodsFor: 'concrete classes' stamp: 'Squeak1.1 9/23/1996 20:34:59' prior: 16843725! - concreteStream - "Who should we really direct class queries to? 9/21/96 tk" - ^ StandardFileStream! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4704-Squeak1.1-stamps-JuanVuletich-2021Jul27-19h23m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4702] on 27 July 2021 at 7:25:19 pm'! -!Object methodsFor: 'comparing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16881052! - hash - "Answer a SmallInteger whose value is related to the receiver's identity. - May be overridden, and should be overridden in any classes that define = " - - ^ self identityHash! ! -!Object methodsFor: 'translation support' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16882631! - inline: inlineFlag - "For translation only; noop when running in Smalltalk."! ! -!Browser methodsFor: 'metaclass' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16792478! - classOrMetaClassOrganizer - "Answer the class organizer for the metaclass or class, depending on - which (instance or class) is indicated." - - self metaClassIndicated - ifTrue: [^metaClassOrganizer] - ifFalse: [^classOrganizer]! ! -!HierarchyBrowser methodsFor: 'initialization' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16853552! - initAlphabeticListing - | tab stab index | - self systemOrganizer: SystemOrganization. - metaClassIndicated _ false. - classList _ Smalltalk classNames.! ! -!Color methodsFor: 'conversions' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50353566! - pixelWordForDepth: depth - "Return to a 32-bit word that concatenates enough copies of the receiver's pixel value to fill the word (i.e., 32/depth copies). Depth should be one of 1, 2, 4, 8, 16, or 32. The pixel value should be an integer in 0..2^depth-1." - - | pixelValue | - pixelValue _ self pixelValueForDepth: depth. - ^ self pixelWordFor: depth filledWith: pixelValue -! ! -!Color methodsFor: 'queries' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50353829! - isTransparent - - ^ false -! ! -!Color methodsFor: 'private' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50354198! - attemptToMutateError - "A color is immutable. Once a color's red, green, and blue have been initialized, you cannot change them. Instead, create a new Color and use it." - - self error: 'Color objects are immutable once created' -! ! -!Color class methodsFor: 'examples' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50357098! - showColorCube - "Show a 12x12x12 color cube." - "Color showColorCube" - - 0 to: 11 do: [:r | - 0 to: 11 do: [:g | - 0 to: 11 do: [:b | - Display fill: (((r*60) + (b*5)) @ (g*5) extent: 5@5) - fillColor: (Color r: r g: g b: b range: 11)]]]. -! ! -!Color class methodsFor: 'examples' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50357108! - showHSVPalettes - "Shows a palette of hues, varying the saturation and brightness for each one. Best results are with depths 16 and 32." - "Color showHSVPalettes" - - | left top c | - left _ top _ 0. - 0 to: 179 by: 15 do: [:h | - 0 to: 10 do: [:s | - left _ (h * 4) + (s * 4). - 0 to: 10 do: [:v | - c _ Color h: h s: s asFloat / 10.0 v: v asFloat / 10.0. - top _ (v * 4). - Display fill: (left@top extent: 4@4) fillColor: c. - - c _ Color h: h + 180 s: s asFloat / 10.0 v: v asFloat / 10.0. - top _ (v * 4) + 50. - Display fill: (left@top extent: 4@4) fillColor: c]]]. -! ! -!Color class methodsFor: 'examples' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50357129! - wheel: thisMany - "Return a collection of thisMany colors evenly spaced around the color wheel." - "Color showColors: (Color wheel: 12)" - - ^ Color wheel: thisMany saturation: 0.9 brightness: 0.7 -! ! -!Color class methodsFor: 'examples' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50357138! -wheel: thisMany saturation: s brightness: v - "Return a collection of thisMany colors evenly spaced around the color wheel, all of the given saturation and brightness." - "Color showColors: (Color wheel: 12 saturation: 0.4 brightness: 1.0)" - "Color showColors: (Color wheel: 12 saturation: 0.8 brightness: 0.5)" - - ^ (Color h: 0.0 s: s v: v) wheel: thisMany -! ! -!Color class methodsFor: 'colormaps' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50357152! - colorMapIfNeededFrom: sourceDepth to: destDepth - "Return a colormap for mapping between the given depths, or nil if no colormap is needed." - "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" - - sourceDepth = destDepth ifTrue: [^ nil]. "not needed if depths are the same" - - (sourceDepth >= 16) & (destDepth >= 16) ifTrue: [ - "mapping is done in BitBlt by zero-filling or truncating each color component" - ^ nil]. - - ^ Color cachedColormapFrom: sourceDepth to: destDepth -! ! -!UndefinedObject methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16940085 overrides: 16896431! - ifNil: aBlock - "A convenient test, in conjunction with Object ifNil:" - - ^ aBlock value! ! -!UndefinedObject methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16940090 overrides: 16896436! - ifNil: nilBlock ifNotNil: ifNotNilBlock - "Evaluate the block for nil because I'm == nil" - - ^ nilBlock value! ! -!UndefinedObject methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16940095 overrides: 16896443! - ifNotNil: aBlock - "A convenient test, in conjunction with Object ifNotNil:" - - ^ self! ! -!UndefinedObject methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16940100 overrides: 16896449! - ifNotNil: ifNotNilBlock ifNil: nilBlock - "If I got here, I am nil, so evaluate the block nilBlock" - - ^ nilBlock value! ! -!Float methodsFor: 'mathematical functions' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16844629 overrides: 50586409! - cos - "Answer the cosine of the receiver taken as an angle in radians." - - ^ (self + Halfpi) sin! ! -!Float methodsFor: 'mathematical functions' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16844660 overrides: 16880129! - log - "Answer the base 10 logarithm of the receiver." - - ^ self ln / Ln10! ! -!Float methodsFor: 'mathematical functions' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16844743 overrides: 50586423! - tan - "Answer the tangent of the receiver taken as an angle in radians." - - ^ self sin / self cos! ! -!Float methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16845080 overrides: 16882565! - isFloat - ^ true! ! -!Fraction methodsFor: 'converting' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16849622 overrides: 16882569! - isFraction - ^ true! ! -!Integer methodsFor: 'private' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16860530! - digitRshift: anInteger bytes: b lookfirst: a - "Shift right 8*b+anInteger bits, 0<=n<8. - Discard all digits beyond a, and all zeroes at or below a." - | n x r f m digit count i | - n _ 0 - anInteger. - x _ 0. - f _ n + 8. - i _ a. - m _ 255 bitShift: 0 - f. - digit _ self digitAt: i. - [((digit bitShift: n) bitOr: x) = 0 and: [i ~= 1]] whileTrue: - [x _ digit bitShift: f "Can't exceed 8 bits". - i _ i - 1. - digit _ self digitAt: i]. - i <= b ifTrue: [^Integer new: 0 neg: self negative]. "All bits lost" - r _ Integer new: i - b neg: self negative. - count _ i. - x _ (self digitAt: b + 1) bitShift: n. - b + 1 to: count do: - [:j | digit _ self digitAt: j + 1. - r digitAt: j - b put: (((digit bitAnd: m) bitShift: f) bitOr: x) - "Avoid values > 8 bits". - x _ digit bitShift: n]. - ^r! ! -!SmallInteger methodsFor: 'comparing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16908913 overrides: 50496965! - identityHash - - ^self! ! -!MessageTally methodsFor: 'tallying' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16870803! - bumpBy: count - - tally _ tally + count! ! -!ContextPart class methodsFor: 'examples' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16825361! - tallyInstructions: aBlock - "This method uses the simulator to count the number of occurrences of - each of the Smalltalk instructions executed during evaluation of aBlock. - Results appear in order of the byteCode set." - | tallies | - tallies _ Bag new. - thisContext sender - runSimulated: aBlock - contextAtEachStep: - [:current | tallies add: current nextByte]. - ^tallies sortedElements - - "ContextPart tallyInstructions: [3.14159 printString]"! ! -!InputSensor methodsFor: 'joystick' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16856269! - joystickButtons: index - - ^ ((self primReadJoystick: index) bitShift: -22) bitAnd: 16r71F - ! ! -!InputSensor methodsFor: 'joystick' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16856274! - joystickOn: index - - ^ (((self primReadJoystick: index) bitShift: -27) bitAnd: 1) ~= 0 - ! ! -!InputSensor methodsFor: 'joystick' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16856279! - joystickXY: index - - | inputWord x y | - inputWord _ self primReadJoystick: index. - x _ (inputWord bitAnd: 16r7FF) - 16r400. - y _ ((inputWord bitShift: -11) bitAnd: 16r7FF) - 16r400. - ^ x@y - ! ! -!String methodsFor: 'accessing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16915787! - 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! ! -!ByteArray methodsFor: 'converting' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16793767 overrides: 16881101! - 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! ! -!CompiledMethod methodsFor: 'printing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16819939 overrides: 16793841! - storeOn: aStream - | noneYet | - aStream nextPutAll: '(('. - aStream nextPutAll: self class name. - aStream nextPutAll: ' newMethod: '. - aStream store: self size - self initialPC + 1. - aStream nextPutAll: ' header: '. - aStream store: self header. - aStream nextPut: $). - noneYet _ self storeElementsFrom: self initialPC to: self endPC on: aStream. - 1 to: self numLiterals do: - [:index | - noneYet - ifTrue: [noneYet _ false] - ifFalse: [aStream nextPut: $;]. - aStream nextPutAll: ' literalAt: '. - aStream store: index. - aStream nextPutAll: ' put: '. - aStream store: (self literalAt: index)]. - noneYet ifFalse: [aStream nextPutAll: '; yourself']. - aStream nextPut: $)! ! -!CompiledMethod methodsFor: 'scanning' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16820294! - scanLongStore: extension - "Answer whether the receiver contains a long store whose extension is - the argument." - | scanner | - scanner _ InstructionStream on: self. - ^scanner scanFor: - [:instr | (instr = 129 or: [instr = 130]) and: [scanner followingByte = extension]]! ! -!CompiledMethod methodsFor: 'scanning' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16820304! - scanVeryLongLoad: extension offset: offset - "Answer whether the receiver contains a long load whose extension is the - argument." - | scanner | - scanner _ InstructionStream on: self. - ^ scanner scanFor: [:instr | (instr = 132 and: [scanner followingByte = extension]) - and: [scanner thirdByte = offset]]! ! -!CompiledMethod methodsFor: 'scanning' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16820337! - sendsToSuper - "Answer whether the receiver sends any message to super." - | scanner | - scanner _ InstructionStream on: self. - ^ scanner scanFor: - [:instr | instr = 16r85 or: [instr = 16r84 - and: [scanner followingByte between: 16r20 and: 16r3F]]]! ! -!CompiledMethod class methodsFor: 'instance creation' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16821370 overrides: 50474859! - new - "This will not make a meaningful method, but it could be used - to invoke some otherwise useful method in this class." - ^ self newMethod: 0 header: 0! ! -!Bitmap methodsFor: 'accessing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16787561! - 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." - - - self errorImproperStore.! ! -!OrderedCollection methodsFor: 'copying' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16883908 overrides: 50332597! - 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! ! -!RunArray methodsFor: 'accessing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16901164 overrides: 16880774! - at: index - - self at: index setRunOffsetAndValue: [:run :offset :value | ^value]! ! -!RunArray methodsFor: 'accessing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16901179! - runLengthAt: index - "Answer the length remaining in run beginning at index." - - self at: index - setRunOffsetAndValue: [:run :offset :value | ^(runs at: run) - offset]! ! -!Set methodsFor: 'private' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16907201! - 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!!'.! ! -!Set methodsFor: 'private' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16907277! - 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 | - 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) == 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"! ! -!Dictionary methodsFor: 'removing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16833629! - removeUnreferencedKeys "Undeclared removeUnreferencedKeys" - - ^ self unreferencedKeys do: [:key | self removeKey: key].! ! -!Dictionary methodsFor: 'private' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16833777 overrides: 50589257! - 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 | - 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) == 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"! ! -!MethodDictionary methodsFor: 'private' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16872204 overrides: 50589292! - 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 | - start _ (anObject identityHash \\ array size) + 1. - finish _ array size. - - "Search from (hash mod size) to the end." - start to: finish do: - [:index | ((element _ self basicAt: index) == nil or: [element == anObject]) - ifTrue: [^ index ]]. - - "Search from 1 to where we started." - 1 to: start-1 do: - [:index | ((element _ self basicAt: index) == nil or: [element == anObject]) - ifTrue: [^ index ]]. - - ^ 0 "No match AND no empty slot"! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16919596! - cleanOutUndeclared - Undeclared removeUnreferencedKeys! ! -!SystemDictionary methodsFor: 'memory space' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16920436! - okayToProceedEvenIfSpaceIsLow - "Return true if either there is enough memory to do so safely or if the user gives permission after being given fair warning." - - self garbageCollectMost > self lowSpaceThreshold ifTrue: [^ true]. "quick" - self garbageCollect > self lowSpaceThreshold ifTrue: [^ true]. "work harder" - - ^ self confirm: -'WARNING: There is not enough space to start the low space watcher. -If you proceed, you will not be warned again, and the system may -run out of memory and crash. If you do proceed, you can start the -low space notifier when more space becomes available simply by -opening and then closing a debugger (e.g., by hitting Cmd-period.) -Do you want to proceed?' -! ! -!SystemDictionary methodsFor: 'retrieving' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16922107! - pointersTo: anObject - "Find all occurrences in the system of pointers to the argument anObject." - "(Smalltalk pointersTo: Browser) inspect." - - ^ self pointersTo: anObject except: #() -! ! -!SystemDictionary methodsFor: 'special objects' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16923703! - specialNargsAt: anInteger - "Answer the number of arguments for the special selector at: anInteger." - - ^ (self specialObjectsArray at: 24) at: anInteger * 2! ! -!SystemDictionary methodsFor: 'special objects' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16923715! - specialSelectorAt: anInteger - "Answer the special message selector from the interleaved specialSelectors array." - - ^ (self specialObjectsArray at: 24) at: anInteger * 2 - 1! ! -!SystemDictionary methodsFor: 'special objects' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16923723! - specialSelectorSize - "Answer the number of special selectors in the system." - - ^ (self specialObjectsArray at: 24) size // 2! ! -!DataStream methodsFor: 'other' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16827831! - byteStream - ^ byteStream! ! -!SmartRefStream methodsFor: 'read write' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16911414! - structures - ^ structures! ! -!Parser methodsFor: 'temps' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16886422! - bindArg: name - - ^ self bindTemp: name! ! -!ParseNode methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16884751! - isUndefTemp - ^ false! ! -!ParseNode methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16884753! - isUnusedTemp - ^ false! ! -!ParseNode methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16884761! - nowHasDef "Ignored in all but VariableNode"! ! -!ParseNode methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16884764! - nowHasRef "Ignored in all but VariableNode"! ! -!Encoder methodsFor: 'temps' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16837428! - newTemp: name - - nTemps _ nTemps + 1. - ^ TempVariableNode new - name: name - index: nTemps - 1 - type: LdTempType - scope: 0! ! -!Encoder methodsFor: 'source mapping' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16837652! - sourceMap - "Answer with a sorted set of associations (pc range)." - - ^ (sourceRanges keys collect: - [:key | Association key: key pc value: (sourceRanges at: key)]) - asSortedCollection! ! -!Encoder methodsFor: 'initialization' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16837706! - fillDict: dict with: nodeClass mapping: keys to: codeArray - | codeStream | - codeStream _ ReadStream on: codeArray. - keys do: - [:key | dict - at: key - put: (nodeClass new name: key key: key code: codeStream next)]! ! -!TempVariableNode methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16927173 overrides: 16884749! - isTemp - ^ true! ! -!TempVariableNode methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16927175 overrides: 50589426! - isUndefTemp - ^ hasDefs not! ! -!TempVariableNode methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16927178 overrides: 50589430! - isUnusedTemp - ^ hasRefs not! ! -!TempVariableNode methodsFor: 'initialization' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16927317 overrides: 50589434! - nowHasDef - hasDefs _ true! ! -!TempVariableNode methodsFor: 'initialization' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16927320 overrides: 50589439! - nowHasRef - hasRefs _ true! ! -!TempVariableNode methodsFor: 'initialization' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16927323! - scope: level - "Note scope of temporary variables. - Currently only the following distinctions are made: - 0 outer level: args and user-declared temps - 1 block args and doLimiT temps - -1 a block temp that is no longer active - -2 a block temp that held limit of to:do:" - scope _ level! ! -!DecompilerConstructor methodsFor: 'constructor' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16832523! - codeConstants - "Answer with an array of the objects representing self, true, false, nil, - -1, 0, 1, 2." - - ^(Array with: NodeSelf with: NodeTrue with: NodeFalse with: NodeNil) - , ((-1 to: 2) collect: [:i | LiteralNode new key: i code: LdMinus1 + i + 1])! ! -!DecompilerConstructor methodsFor: 'constructor' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16832633! - codeTemp: index named: tempName - - ^ TempVariableNode new - name: tempName - index: index - type: LdTempType - scope: 0! ! -!TextAttribute methodsFor: 'as yet unclassified' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16930191! - actOnClickFor: model - "Subclasses may override to provide, eg, hot-spot actions" - ^ false! ! -!TextAttribute methodsFor: 'as yet unclassified' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16930219! - dominates: another - "Subclasses may override condense multiple attributes" - ^ false! ! -!TextAttribute methodsFor: 'as yet unclassified' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16930229! - mayActOnClick - "Subclasses may override to provide, eg, hot-spot actions" - ^ false! ! -!TextAction methodsFor: 'as yet unclassified' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16929976 overrides: 50589542! - mayActOnClick - - ^ true! ! -!TextColor methodsFor: 'accessing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16930335! - color - ^ color! ! -!TextColor methodsFor: 'accessing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16930337! - color: aColor - color _ aColor! ! -!TextColor methodsFor: 'printing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16930349 overrides: 50508082! - printOn: strm - super printOn: strm. - strm nextPutAll: ' code: '; print: color! ! -!TextColor class methodsFor: 'instance creation' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16930401! - color: aColor - ^ self new color: aColor! ! -!TextEmphasis methodsFor: 'as yet unclassified' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16933297 overrides: 16930225! - emphasisCode - ^ emphasisCode! ! -!TextEmphasis methodsFor: 'printing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16933310 overrides: 50508082! - printOn: strm - super printOn: strm. - strm nextPutAll: ' code: '; print: emphasisCode! ! -!RemoteString methodsFor: 'accessing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16900599! - position - "Answer the location of the string on a file." - - ^ filePositionHi! ! -!RemoteString methodsFor: 'private' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16900659! - fileNumber: fileNumber position: position - - sourceFileNumber _ fileNumber. - filePositionHi _ position! ! -!Form methodsFor: 'accessing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16846790 overrides: 16880927! - size - "Should no longer be used -- use bitsSize instead. length of variable part of instance." - ^ super size! ! -!Form methodsFor: 'copying' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16847613! - copy: sourceRectangle from: sourceForm to: destPt rule: rule - ^ self copy: (destPt extent: sourceRectangle extent) - from: sourceRectangle topLeft in: sourceForm rule: rule! ! -!Form methodsFor: 'scaling, rotation' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16848476! - shrink: aRectangle by: scale - | scalePt | - scalePt _ scale asPoint. - ^ self magnify: aRectangle by: (1.0 / scalePt x asFloat) @ (1.0 / scalePt y asFloat)! ! -!Form class methodsFor: 'mode constants' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16849137! - erase1bitShape - "Answer the integer denoting mode erase." - - ^ 26! ! -!Form class methodsFor: 'mode constants' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16849141! - oldErase1bitShape - "Answer the integer denoting mode erase." - - ^ 17! ! -!Form class methodsFor: 'mode constants' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16849145! - oldPaint - "Answer the integer denoting the 'paint' combination rule." - - ^16! ! -!Form class methodsFor: 'mode constants' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16849153! - paint - "Answer the integer denoting the 'paint' combination rule." - - ^25! ! -!ImageReadWriter methodsFor: 'accessing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16854293! - nextImage - "Dencoding an image on stream and answer the image." - - ^self subclassResponsibility! ! -!ImageReadWriter methodsFor: 'accessing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16854298! - nextPutImage: anImage - "Encoding anImage on stream." - - ^self subclassResponsibility! ! -!ImageReadWriter methodsFor: 'stream access' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16854303! - atEnd - - ^stream atEnd! ! -!ImageReadWriter methodsFor: 'stream access' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16854306! - contents - - ^stream contents! ! -!ImageReadWriter methodsFor: 'stream access' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16854309! - next - - ^stream next! ! -!ImageReadWriter methodsFor: 'stream access' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16854312! - next: size - - ^stream next: size! ! -!ImageReadWriter methodsFor: 'stream access' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16854315! - nextPut: aByte - - ^stream nextPut: aByte! ! -!ImageReadWriter methodsFor: 'stream access' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16854318! - nextPutAll: aByteArray - - ^stream nextPutAll: aByteArray! ! -!ImageReadWriter methodsFor: 'stream access' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16854341! - position - - ^stream position! ! -!ImageReadWriter methodsFor: 'stream access' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16854344! - position: anInteger - - ^stream position: anInteger! ! -!ImageReadWriter methodsFor: 'stream access' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16854348 overrides: 16880927! - size - - ^stream size! ! -!ImageReadWriter methodsFor: 'stream access' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16854351! - skip: anInteger - - ^stream skip: anInteger! ! -!ImageReadWriter methodsFor: 'private' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16854366! - changePadOfBits: bits width: width height: height depth: depth from: oldPad -to: newPad - "Change padding size of bits." - - | srcRowByteSize dstRowByteSize newBits srcRowBase rowEndOffset | - (#(8 16 32) includes: oldPad) - ifFalse: [^self error: 'Invalid pad: ', oldPad printString]. - (#(8 16 32) includes: newPad) - ifFalse: [^self error: 'Invalid pad: ', newPad printString]. - srcRowByteSize _ width * depth + oldPad - 1 // oldPad * (oldPad / 8). - srcRowByteSize * height = bits size - ifFalse: [^self error: 'Incorrect bitmap array size.']. - dstRowByteSize _ width * depth + newPad - 1 // newPad * (newPad / 8). - newBits _ ByteArray new: dstRowByteSize * height. - srcRowBase _ 1. - rowEndOffset _ dstRowByteSize - 1. - 1 to: newBits size by: dstRowByteSize do: - [:dstRowBase | - newBits replaceFrom: dstRowBase - to: dstRowBase + rowEndOffset - with: bits - startingAt: srcRowBase. - srcRowBase _ srcRowBase + srcRowByteSize]. - ^newBits! ! -!ImageReadWriter methodsFor: 'private' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16854397! - hasMagicNumber: aByteArray - | position | - position _ stream position. - ((stream size - position) >= aByteArray size and: - [(stream next: aByteArray size) = aByteArray]) - ifTrue: [^true]. - stream position: position. - ^false! ! -!BitBlt methodsFor: 'accessing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16785508! - colorMap - ^ colorMap! ! -!BitBlt methodsFor: 'accessing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16785595! - sourceForm - - ^ sourceForm! ! -!BitBlt methodsFor: 'line drawing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16785822! - drawFrom: startPoint to: stopPoint - - ^ self drawFrom: startPoint to: stopPoint withFirstPoint: true! ! -!WarpBlt methodsFor: 'setup' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16942974! - cellSize - ^ cellSize! ! -!WarpBlt methodsFor: 'primitives' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16943089! - copyQuad: pts toRect: destRect - self sourceQuad: pts destRect: destRect. - self warpBits! ! -!WarpBlt methodsFor: 'primitives' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16943093! - deltaFrom: x1 to: x2 nSteps: n - "Utility routine for computing Warp increments. - x1 is starting pixel, x2 is ending pixel; assumes n >= 1" - | fixedPtOne | - fixedPtOne _ 16384. "1.0 in fixed-pt representation" - x2 > x1 - ifTrue: [^ x2 - x1 + fixedPtOne // (n+1) + 1] - ifFalse: [x2 = x1 ifTrue: [^ 0]. - ^ 0 - (x1 - x2 + fixedPtOne // (n+1) + 1)]! ! -!WarpBlt methodsFor: 'primitives' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16943124! - sourceQuad: pts destRect: aRectangle - | fixedPt1 | - sourceX _ sourceY _ 0. - self destRect: aRectangle. - fixedPt1 _ (pts at: 1) x isInteger ifTrue: [16384] ifFalse: [16384.0]. - p1x _ (pts at: 1) x * fixedPt1. - p2x _ (pts at: 2) x * fixedPt1. - p3x _ (pts at: 3) x * fixedPt1. - p4x _ (pts at: 4) x * fixedPt1. - p1y _ (pts at: 1) y * fixedPt1. - p2y _ (pts at: 2) y * fixedPt1. - p3y _ (pts at: 3) y * fixedPt1. - p4y _ (pts at: 4) y * fixedPt1. - p1z _ p2z _ p3z _ p4z _ 16384. "z-warp ignored for now" -! ! -!WarpBlt methodsFor: 'primitives' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16943141! - startFrom: x1 to: x2 offset: sumOfDeltas - "Utility routine for computing Warp increments." - x2 >= x1 - ifTrue: [^ x1] - ifFalse: [^ x2 - sumOfDeltas]! ! -!WarpBlt class methodsFor: 'initialization' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16943221 overrides: 50588579! - toForm: destinationForm - "Default cell size is 1 (no pixel smoothing)" - ^ (super toForm: destinationForm) cellSize: 1! ! -!Point methodsFor: 'converting' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16890352! - asFloatPoint - ^ x asFloat @ y asFloat! ! -!Rectangle methodsFor: 'rectangle functions' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16898854! - withHeight: height - "Return a copy of me with a different height" - ^ origin corner: corner x @ (origin y + height)! ! -!Rectangle methodsFor: 'rectangle functions' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16898860! - withLeft: x - "Return a copy of me with a different left x" - ^ x @ origin y corner: corner x @ corner y! ! -!Rectangle methodsFor: 'rectangle functions' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16898865! - withRight: x - "Return a copy of me with a different right x" - ^ origin x @ origin y corner: x @ corner y! ! -!Rectangle methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16898875! - containsRect: aRect - "Answer whether aRect is within the receiver (OK to coincide)." - - ^ aRect origin >= origin and: [aRect corner <= corner] -! ! -!Rectangle methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16898913! - isTall - ^ self height > self width! ! -!Rectangle methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16898916! - isWide - ^ self width > self height! ! -!Rectangle methodsFor: 'private' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16899058! - setOrigin: topLeft corner: bottomRight - origin _ topLeft. - corner _ bottomRight! ! -!Morph methodsFor: 'classification' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16874177! - isWorldMorph - - ^ false! ! -!Morph methodsFor: 'structure' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16876616! - owner - "Returns the owner of this morph, which may be nil." - - ^ owner! ! -!Morph methodsFor: 'submorphs-accessing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16876720! - submorphCount - - ^ submorphs size! ! -!Morph methodsFor: 'submorphs-accessing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16876728! - submorphs - - ^ submorphs copy! ! -!Morph methodsFor: 'submorphs-accessing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16876739! -submorphsDo: aBlock - - submorphs do: aBlock.! ! -!Morph methodsFor: 'submorphs-accessing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16876759! - submorphsReverseDo: aBlock - - submorphs reverseDo: aBlock.! ! -!ImageMorph methodsFor: 'menu commands' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16854148! - grabFromScreen - self image: Form fromUser! ! -!ScrollBar methodsFor: 'access' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16904495! - scrollDelta: d1 pageDelta: d2 - "Supply optional increments for better scrolling of, eg, text" - scrollDelta _ d1. - pageDelta _ d2.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4705-Squeak1.2-stamps-JuanVuletich-2021Jul27-19h24m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4702] on 27 July 2021 at 7:25:56 pm'! -!Object methodsFor: 'printing' stamp: 'di 6/20/97 08:57' prior: 16882089! - fullPrintString - "Answer a String whose characters are a description of the receiver." - - ^ String streamContents: [:s | self printOn: s]! ! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16807029! - reformatMethodAt: selector - | newCodeString method | - newCodeString _ (self compilerClass new) - format: (self sourceCodeAt: selector) - in: self - notifying: nil. - method _ self compiledMethodAt: selector. - method - putSource: newCodeString - fromParseNode: nil - class: self - category: (self organization categoryOfElement: selector) - inFile: 2 priorMethod: method! ! -!Float methodsFor: 'mathematical functions' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50585088 overrides: 50586395! - arcCos - "Answer the angle in radians." - - ^ Halfpi - self arcSin! ! -!Float methodsFor: 'mathematical functions' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50588962 overrides: 50586409! - cos - "Answer the cosine of the receiver taken as an angle in radians." - - ^ (self + Halfpi) sin! ! -!Float methodsFor: 'mathematical functions' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50588969 overrides: 16880129! - log - "Answer the base 10 logarithm of the receiver." - - ^ self ln / Ln10! ! -!Float methodsFor: 'mathematical functions' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50410400 overrides: 16879757! - reciprocal - ^ 1.0 / self! ! -!Float methodsFor: 'mathematical functions' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50588976 overrides: 50586423! - tan - "Answer the tangent of the receiver taken as an angle in radians." - - ^ self sin / self cos! ! -!Float methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50588983 overrides: 16882565! - isFloat - ^ true! ! -!CompiledMethod methodsFor: 'initialization' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16821243! - copyWithTrailerBytes: bytes -"Testing: - (CompiledMethod compiledMethodAt: #copyWithTrailerBytes:) - tempNamesPut: 'copy end ' -" - | copy end start | - start _ self initialPC. - end _ self endPC. - copy _ CompiledMethod newMethod: end - start + 1 + bytes size - header: self header. - 1 to: self numLiterals do: [:i | copy literalAt: i put: (self literalAt: i)]. - start to: end do: [:i | copy at: i put: (self at: i)]. - 1 to: bytes size do: [:i | copy at: end + i put: (bytes at: i)]. - ^ copy! ! -!Text class methodsFor: 'instance creation' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16929861! - string: aString attribute: att - "Answer an instance of me whose characters are aString. - att is a TextAttribute." - - ^self string: aString attributes: (Array with: att)! ! -!Text class methodsFor: 'instance creation' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16929869! - 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)! ! -!DataStream methodsFor: 'write and read' stamp: 'jmv 6/30/2011 09:33' prior: 16827317! - objectAt: anInteger - "PRIVATE -- Read & return the object at a given stream position. 08:18 tk anInteger is a relative file position. " - | savedPosn anObject refPosn | - - savedPosn _ byteStream position. "absolute" - refPosn _ self getCurrentReference. "relative position" - - byteStream position: anInteger + basePos. "was relative" - anObject _ self next. - - self setCurrentReference: refPosn. "relative position" - byteStream position: savedPosn. "absolute" - ^ anObject! ! -!VariableNode methodsFor: 'initialization' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16942047 overrides: 50584258! - name: string key: object code: byte - "Only used for initting std variables, nil, true, false, self, etc." - name _ string. - key _ object. - code _ byte! ! -!Form methodsFor: 'pixel access' stamp: 'tk 6/20/96' prior: 16848260! - pixelValueAt: aPoint put: pixelValue - "Store the given raw pixel value at the given point. Typical clients use colorAt:put: to store a color. " - - (BitBlt bitPokerToForm: self) pixelAt: aPoint put: pixelValue. -! ! -!StrikeFont methodsFor: 'emphasis' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16914386! - bonk: glyphForm with: bonkForm - "Bonking means to run through the glyphs clearing out black pixels - between characters to prevent them from straying into an adjacent - character as a result of, eg, bolding or italicizing" - "Uses the bonkForm to erase at every character boundary in glyphs." - | bb offset | - offset _ bonkForm offset x. - bb _ BitBlt toForm: glyphForm. - bb sourceForm: bonkForm; sourceRect: bonkForm boundingBox; - combinationRule: Form erase; destY: 0. - 1 to: xTable size-1 do: [:i | bb destX: (xTable at: i) + offset; copyBits]. -! ! -!CharacterScanner methodsFor: 'private' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16801948! - setActualFont: aFont - "Set the basal font to an isolated font reference." - - font _ aFont! ! -!Morph methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16877010! - stepTime - "Answer the desired time between steps in milliseconds. This default implementation requests that the 'step' method be called once every second." - - ^ 1000! ! -!Morph methodsFor: 'private' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50554630! - privateOwner: aMorph - "Private!! Should only be used by methods that maintain the ower/submorph invariant." - - owner _ aMorph.! ! -!Morph methodsFor: 'private' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16877220! - privateSubmorphs - "Private!! Use 'submorphs' instead." - - ^ submorphs! ! -!WorldMorph methodsFor: 'classification' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50551953 overrides: 50589871! - isWorldMorph - - ^ true! ! -!WorldMorph methodsFor: 'structure' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50552048 overrides: 16876664! - world - - ^ self! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4706-Squeak1.2-stamps-JuanVuletich-2021Jul27-19h25m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4701] on 27 July 2021 at 4:15:04 pm'! -!TextLine methodsFor: 'accessing' stamp: 'Squeak1.3 1/16/1998 17:55:27' prior: 16933475! - baseline - ^ baseline! ! -!TextLine methodsFor: 'accessing' stamp: 'Squeak1.3 1/16/1998 17:55:27' prior: 16933486! - internalSpaces - "Answer the number of spaces in the line." - - ^internalSpaces! ! -!TextLine methodsFor: 'accessing' stamp: 'Squeak1.3 1/16/1998 17:55:27' prior: 16933490! - internalSpaces: spacesInteger - "Set the number of spaces in the line to be spacesInteger." - - internalSpaces _ spacesInteger! ! -!TextLine methodsFor: 'accessing' stamp: 'Squeak1.3 1/16/1998 17:55:27' prior: 16933532! - paddingWidth - "Answer the amount of space to be added to the font." - - ^paddingWidth! ! -!TextLine methodsFor: 'accessing' stamp: 'Squeak1.3 1/16/1998 17:55:27' prior: 16933536! - paddingWidth: padWidthInteger - "Set the amount of space to be added to the font to be padWidthInteger." - - paddingWidth _ padWidthInteger! ! -!TextLine methodsFor: 'scanning' stamp: 'Squeak1.3 1/16/1998 17:55:27' prior: 16933598! - justifiedPadFor: spaceIndex - "Compute the width of pad for a given space in a line of justified text." - - | pad | - internalSpaces = 0 ifTrue: [^0]. - pad _ paddingWidth // internalSpaces. - spaceIndex <= (paddingWidth \\ internalSpaces) - ifTrue: [^pad + 1] - ifFalse: [^pad]! ! -!TextLine methodsFor: 'private' stamp: 'Squeak1.3 1/16/1998 17:55:27' prior: 16933625! - internalSpaces: spacesInteger paddingWidth: padWidthInteger - - internalSpaces _ spacesInteger. - paddingWidth _ padWidthInteger! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4707-Squeak1.3-stamps-JuanVuletich-2021Jul27-16h13m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4707] on 27 July 2021 at 8:09:28 pm'! -!String class methodsFor: 'instance creation' stamp: 'sw 8/5/97 13:55' prior: 16917814! - crString - ^ self with: Character cr! ! -!Base64MimeConverter methodsFor: 'accessing' stamp: 'tk 12/9/97 13:55' prior: 16782361! - dataStream - ^dataStream! ! -!Base64MimeConverter methodsFor: 'accessing' stamp: 'tk 12/9/97 13:53' prior: 16782371! - mimeStream - ^mimeStream! ! -!Encoder methodsFor: 'temps' stamp: 'jm 9/18/97 21:06' prior: 16837306! - bindArg: name - "Declare an argument." - | node | - nTemps >= 15 - ifTrue: [^self notify: 'Too many arguments']. - node _ self bindTemp: name. - ^ node nowHasDef nowHasRef! ! -!TextDoIt methodsFor: 'as yet unclassified' stamp: 'tk 12/5/97 17:01' prior: 16931191 overrides: 50589529! - 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 ! ! -!TextAnchor methodsFor: 'testing' stamp: 'di 11/10/97 14:08' prior: 16930152 overrides: 16930235! - mayBeExtended - "A textAnchor is designed to modify only a single character, and therefore must not be extended by the ParagraphEditor's emphasisHere facility" - ^ false! ! -!BitBlt methodsFor: 'copying' stamp: 'di 7/17/97 10:04' prior: 16785742! - copyForm: srcForm to: destPt rule: rule colorMap: map - sourceForm _ srcForm. - halftoneForm _ nil. - combinationRule _ rule. - destX _ destPt x + sourceForm offset x. - destY _ destPt y + sourceForm offset y. - sourceX _ 0. - sourceY _ 0. - width _ sourceForm width. - height _ sourceForm height. - colorMap _ map. - self copyBits! ! -!CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'di 11/11/97 08:50' prior: 16801819 overrides: 50526594! - setFont - specialWidth _ nil. - super setFont! ! -!CompositionScanner methodsFor: 'stop conditions' stamp: 'di 11/5/97 07:46' prior: 16823068! - space - "Record left x and character index of the space character just encounted. - Used for wrap-around. Answer whether the character has crossed the - right edge of the composition rectangle of the paragraph." - - spaceX _ destX. - destX _ spaceX + spaceWidth. - spaceIndex _ lastIndex. - lineHeightAtSpace _ lineHeight. - baselineAtSpace _ baseline. - lastIndex _ lastIndex + 1. - spaceCount _ spaceCount + 1. - destX > rightMargin ifTrue: [^self crossedX]. - ^false -! ! -!Morph methodsFor: 'accessing - properties' stamp: 'sw 8/4/97 12:05' prior: 16874000! - lock: aBoolean - self setProperty: #locked toValue: aBoolean! ! -!Morph methodsFor: 'caching' stamp: 'jm 11/13/97 16:33' prior: 50510070 overrides: 50559046! - releaseCachedState - "Release any state that can be recomputed on demand, such as the pixel values for a color gradient or the editor state for a TextMorph. This method may be called to save space when a morph becomes inaccessible. Implementations of this method should do 'super releaseCachedState'. This default implementation does nothing." -! ! -!Morph methodsFor: 'focus handling' stamp: 'Squeak1.3 1/16/1998 17:55:27' prior: 16875216! - keyboardFocusChange: aBoolean - "The message is sent to a morph when its keyboard focus change. The given argument indicates that the receiver is gaining keyboard focus (versus losing) the keyboard focus. Morphs that accept keystrokes should change their appearance in some way when they are the current keyboard focus. This default implementation does nothing."! ! -!HandMorph methodsFor: 'focus handling' stamp: 'jm 11/13/97 15:12' prior: 16851923! - newKeyboardFocus: aMorphOrNil - "Make the given morph the new keyboard focus, canceling the previous keyboard focus if any. If the argument is nil, the current keyboard focus is cancelled." - | oldFocus | - oldFocus _ keyboardFocus. - keyboardFocus _ aMorphOrNil. - oldFocus ifNotNil: [oldFocus == aMorphOrNil ifFalse: [oldFocus keyboardFocusChange: false]]. - aMorphOrNil ifNotNil: [aMorphOrNil keyboardFocusChange: true]. -! ! -!HaloMorph methodsFor: 'accessing' stamp: 'jm 7/30/97 15:52' prior: 16850616! - target: aMorph - - target _ aMorph. - target ifNotNil: [self addHandles]. -! ! -!MenuItemMorph methodsFor: 'event handling testing' stamp: 'jm 11/4/97 07:15' prior: 16865920 overrides: 16874721! - handlesMouseDown: evt - - ^ true -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4708-HistoricalAppreciation-JuanVuletich-2021Jul27-19h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4708] on 27 July 2021 at 9:11:16 pm'! -!DifferenceFinder methodsFor: 'accessing' stamp: 'LC 1/24/2010 15:18' prior: 16834033! - base: aCollection case: anotherCollection - base := aCollection. - case := anotherCollection. - x := aCollection. - y := anotherCollection -! ! -!DifferenceFinder methodsFor: 'private' stamp: 'jmv 8/23/2014 23:23' prior: 16834040! - initializeMap - map _ Array2D height: x size width: y size! ! -!DifferenceFinder methodsFor: 'private' stamp: 'jmv 8/23/2014 23:23' prior: 16834045! - initializeMatrix - matrix _ Array2D height: x size width: y size! ! -!DifferenceFinder methodsFor: 'private' stamp: 'jmv 11/16/2015 14:51' prior: 16834050! - keywordsAndBlanksFrom: aString - ^Array streamContents: [:strm | | read keyword tail | - read := aString readStream. - [read atEnd] whileFalse: [ - keyword := read nextKeyword. - keyword notEmpty ifTrue: [ - strm nextPut: keyword ]. - tail := read untilAnySatisfying: [:ch | ch isValidInIdentifiers]. - tail notEmpty ifTrue: [strm nextPut: tail]]] -! ! -!DifferenceFinder methodsFor: 'private' stamp: 'LC 1/24/2010 15:18' prior: 16834063! - linesIn: aString - " - LongestCommonSequenceFinder linesIn: 'x y' - " - ^Array streamContents: [:strm | | cr read | - cr := ' -'. - read := aString readStream. - [read atEnd] whileFalse: [| line | - line := read nextLine. - read skip: -1. - read peek = cr last ifTrue: [line := line , cr]. - read skip: 1. - strm nextPut: line]] -! ! -!DifferenceFinder methodsFor: 'private' stamp: 'jmv 2/22/2010 11:36' prior: 16834076! - maxLength - - (tally width = 0 or: [ tally height = 0 ]) ifTrue: [ ^0 ]. - ^tally i: x size j: y size! ! -!DifferenceFinder methodsFor: 'private' stamp: 'jmv 3/12/2018 15:48:12' prior: 50386134! - maxLengthPoints - | max points | - max := self maxLength. - max = 0 ifTrue: [^Array with: `0 @ 0`]. - points := OrderedCollection new. - tally withIndexesDo: [:i :j :t | t = max ifTrue: [points add: i @ j]]. - ^ points! ! -!DifferenceFinder methodsFor: 'private' stamp: 'LC 1/26/2010 10:21' prior: 16834091! - similitudeProportion - ^self maxLength / (x size + y size / 2)! ! -!DifferenceFinder methodsFor: 'private' stamp: 'LC 1/24/2010 15:18' prior: 16834095! - unfold - | points | - points := OrderedCollection with: x size @ y size. - ^self unfold: points -! ! -!DifferenceFinder methodsFor: 'private' stamp: 'LC 1/24/2010 15:18' prior: 16834100! - unfold: pointCollection - | pending visited point | - pending := OrderedCollection withAll: pointCollection. - visited := OrderedCollection new. - [pending notEmpty] whileTrue: [ - point := pending removeFirst. - (visited includes: point) ifFalse: [ - self unfold: point on: pending. - visited add: point]]. - ^visited -! ! -!DifferenceFinder methodsFor: 'private' stamp: 'jmv 4/17/2015 16:00' prior: 16834113! - unfold: aPoint on: pending - | i j mij | - i := aPoint x. - j := aPoint y. - (i = 0 or: [j = 0]) ifTrue: [^self]. - mij := map i: i j: j. - mij = self class d ifTrue: [ - pending add: i - 1 @ (j - 1). - ^self]. - mij = self class u ifTrue: [ - pending add: i - 1 @ j. - ^self]. - mij = self class l ifTrue: [ - pending add: i @ (j - 1). - ^self]. - mij = self class ul ifTrue: [ - pending add: i - 1 @ j; add: i @ (j - 1). - ^self]. - self assert: false! ! -!DifferenceFinder methodsFor: 'configuration' stamp: 'LC 1/24/2010 15:18' prior: 16834129! - compareCharacters - x := base. - y := case -! ! -!DifferenceFinder methodsFor: 'configuration' stamp: 'LC 1/24/2010 15:18' prior: 16834132! - compareLines - x := self linesIn: base. - y := self linesIn: case -! ! -!DifferenceFinder methodsFor: 'configuration' stamp: 'LC 1/24/2010 15:18' prior: 16834136! - compareWords - x := self keywordsAndBlanksFrom: base. - y := self keywordsAndBlanksFrom: case -! ! -!DifferenceFinder methodsFor: 'computing' stamp: 'jmv 12/21/2012 13:51' prior: 16834142! - compute - ^self compute: false! ! -!DifferenceFinder methodsFor: 'computing' stamp: 'jmv 12/21/2012 13:53' prior: 16834146! - compute: abortIfTooExpensive - "If abortIfTooExpensive, we might abort, and then differences could be nil." - | longestSequences | - self initializeMap; initializeMatrix; computeMap. - longestSequences _ self longestSequences: abortIfTooExpensive. - "If decided computation was too expensive..." - longestSequences ifNil: [ - differences _ nil. - ^self ]. - differences _ longestSequences asArray collect: [ :lcs | - SequenceDifference x: x y: y lcs: lcs]. - differences sort! ! -!DifferenceFinder methodsFor: 'computing' stamp: 'jmv 4/17/2015 16:00' prior: 16834163! - computeLcsAt: i at: j - | mij cij pair left up | - mij := map i: i j: j. - mij = self class d ifTrue: [ - cij := self lcsAt: i - 1 at: j - 1. - pair := Array with: i with: j. - ^cij collect: [:s | s copyWith: pair]]. - mij = self class u ifTrue: [^self lcsAt: i - 1 at: j]. - mij = self class l ifTrue: [^self lcsAt: i at: j - 1]. - mij = self class ul ifTrue: [ - left := self lcsAt: i at: j - 1. - up := self lcsAt: i - 1 at: j. - ^left copy addAll: up; yourself]. - self assert: false! ! -!DifferenceFinder methodsFor: 'computing' stamp: 'jmv 8/23/2014 23:23' prior: 16834181! - computeMap - | m | - tally _ Array2D height: x size width: y size. - 1 to: x size do: [ :i | - 1 to: y size do: [ :j | - m _ self computeMapAt: i at: j. - map i: i j: j put: m ]]! ! -!DifferenceFinder methodsFor: 'computing' stamp: 'jmv 4/17/2015 16:00' prior: 16834189! - computeMapAt: i at: j - | xi yj left up t | - xi := x at: i. - yj := y at: j. - xi = yj ifTrue: [ - t := ((j = 1 or: [i = 1]) - ifTrue: [0] - ifFalse: [tally i: i - 1 j: j - 1]) - + 1. - tally i: i j: j put: t. - ^self class d]. - left := j = 1 ifTrue: [0] ifFalse: [tally i: i j: j - 1]. - up := i = 1 ifTrue: [0] ifFalse: [tally i: i - 1 j: j]. - left < up ifTrue: [ - tally i: i j: j put: up. - ^self class u]. - tally i: i j: j put: left. - ^up < left ifTrue: [self class l] ifFalse: [self class ul] -! ! -!DifferenceFinder methodsFor: 'computing' stamp: 'jmv 4/17/2015 16:35' prior: 16834207! - lcsAt: i at: j - | lcs | - (i = 0 or: [j = 0]) ifTrue: [^Set with: #() "EmptyLCS"]. - lcs := matrix i: i j: j. - lcs ifNil: [ - lcs := self computeLcsAt: i at: j. - matrix i: i j: j put: lcs]. - ^lcs -! ! -!DifferenceFinder methodsFor: 'computing' stamp: 'jmv 12/21/2012 13:50' prior: 16834216! -longestSequences: abortIfTooExpensive - | maxs points answer | - maxs _ self maxLengthPoints. - points _ self unfold: maxs. - abortIfTooExpensive ifTrue: [ - points size > 500 ifTrue: [ ^nil ]. "maybe a bit too much..." - ]. - points - sort: [:p :q | p x < q x or: [p x = q x and: [p y <= q y]]]; - do: [:p | self lcsAt: p x at: p y]. - answer _ Set new. - maxs do: [ :p | | lcs | - lcs _ self lcsAt: p x at: p y. - lcs do: [ :s | - answer add: s]]. - ^answer! ! -!DifferenceFinder methodsFor: 'outputs' stamp: 'LC 1/24/2010 15:18' prior: 16834232! - differences - ^differences -! ! -!DifferenceFinder class methodsFor: 'instance creation' stamp: 'LC 1/24/2010 15:18' prior: 16834241! - base: aCollection case: anotherCollection - ^self new base: aCollection case: anotherCollection -! ! -!DifferenceFinder class methodsFor: 'instance creation' stamp: 'LC 1/24/2010 15:18' prior: 16834246! - charactersOf: aString and: anotherString - | finder | - finder := self base: aString case: anotherString. - finder compareCharacters. - ^finder -! ! -!DifferenceFinder class methodsFor: 'instance creation' stamp: 'LC 1/24/2010 15:18' prior: 16834253! - linesOf: aString and: anotherString - | finder | - finder := self base: aString case: anotherString. - finder compareLines. - ^finder -! ! -!DifferenceFinder class methodsFor: 'instance creation' stamp: 'LC 1/24/2010 15:18' prior: 16834259! - wordsOf: aString and: anotherString - | finder | - finder := self base: aString case: anotherString. - finder compareWords. - ^finder -! ! -!DifferenceFinder class methodsFor: 'compatibility' stamp: 'jmv 2/22/2010 13:08' prior: 16834266! - displayPatchFrom: srcString to: dstString tryWords: aBoolean - | finder | - - aBoolean ifTrue: [ - (self wordsDisplayPatchFrom: srcString to: dstString) - ifNotNil: [ :answer | ^answer ] ]. - - finder _ self base: srcString case: dstString. - finder compareLines; compute. - ^finder differences anyOne asText! ! -!DifferenceFinder class methodsFor: 'compatibility' stamp: 'jmv 8/2/2016 16:45:19' prior: 16834279! - displayPatchFrom: srcString to: dstString tryWords: aBoolean prettyPrintedIn: aClass - | formattedSrcString formattedDstString | - formattedSrcString _ aClass - ifNil: [ srcString ] - ifNotNil: [ - [ - aClass compilerClass new - format: srcString - in: aClass - notifying: nil ] - on: Error - do: [ :ex | - srcString ]]. - formattedDstString _ aClass - ifNil: [ dstString ] - ifNotNil: [ - [ - aClass compilerClass new - format: dstString - in: aClass - notifying: nil ] - on: Error - do: [ :ex | - dstString ]]. - ^ self - displayPatchFrom: formattedSrcString - to: formattedDstString - tryWords: aBoolean! ! -!DifferenceFinder class methodsFor: 'compatibility' stamp: 'jmv 9/13/2016 17:28:22' prior: 16834302! - wordsDisplayPatchFrom: srcString to: dstString - | finder answer src1 dst1 changedCount | - finder _ self base: srcString case: dstString. - finder compareLines; compute. - answer _ '' asText. - src1 _ String new writeStream. - dst1 _ String new writeStream. - changedCount _ 0. - finder differences sort first do: [:item :condition | - condition caseOf: { - [ #unchanged ] -> [ - changedCount > 0 ifTrue: [ - "If the sequence of changed lines is large, comparing words gets too slow and less useful" - changedCount > 30 ifTrue: [ - ^nil ]. - "Compare the just ended sequence of changed lines" - finder base: src1 contents case: dst1 contents. - finder compareWords; compute: true. - finder differences ifNil: [ ^nil ]. - answer _ answer append: finder differences anyOne asText. - src1 resetToStart. - dst1 resetToStart. - changedCount _ 0. - ]. - "This line hasn't changed. Just add it to the result in plain text." - answer append: item ]. - [ #removed ] -> [ - "A removed line belongs in the source" - src1 nextPutAll: item. - changedCount _ changedCount + 1 ]. - [ #inserted ] -> [ - "An added line belongs in the destination" - dst1 nextPutAll: item. - changedCount _ changedCount + 1 ]. - }. - ]. - "If the sequence of changed lines is large, comparing words gets too slow and less useful" - changedCount > 30 ifTrue: [ - ^nil ]. - finder base: src1 contents case: dst1 contents. - finder compareWords; compute: true. - finder differences ifNil: [ ^nil ]. - answer _ answer append: finder differences anyOne asText. - - ^answer! ! -!DifferenceFinder class methodsFor: 'bibliography' stamp: 'LC 1/24/2010 16:30' prior: 16834354! - references - ^'http://en.wikipedia.org/wiki/Longest_common_subsequence' -! ! -!DifferenceFinder class methodsFor: 'constants' stamp: 'jmv 4/17/2015 16:39' prior: 16834359! - d - ^1! ! -!DifferenceFinder class methodsFor: 'constants' stamp: 'jmv 4/17/2015 16:39' prior: 16834362! - l - ^3! ! -!DifferenceFinder class methodsFor: 'constants' stamp: 'jmv 4/17/2015 16:39' prior: 16834365! - u - ^2! ! -!DifferenceFinder class methodsFor: 'constants' stamp: 'jmv 4/17/2015 16:39' prior: 16834368! - ul - ^4! ! -!SequenceDifference methodsFor: 'accessing' stamp: 'jmv 12/21/2012 12:32' prior: 16905296! - lcsSize - ^lcs size! ! -!SequenceDifference methodsFor: 'accessing' stamp: 'LC 1/24/2010 15:18' prior: 16905299! - partsSize - | count last | - count := 0. - self do: [:item :condition | - last = condition ifFalse: [ - count := count + 1. - last := condition]]. - ^count -! ! -!SequenceDifference methodsFor: 'accessing' stamp: 'jmv 8/23/2010 10:31' prior: 16905307! - x: aCollection y: anotherCollection lcs: pairCollection - x := aCollection. - y := anotherCollection. - lcs := pairCollection sort: [ :a :b | a first < b first ]! ! -!SequenceDifference methodsFor: 'printing' stamp: 'LC 1/24/2010 15:18' prior: 16905315! - asText - ^Text streamContents: [:rtf | self printTextOn: rtf]! ! -!SequenceDifference methodsFor: 'printing' stamp: 'pb 1/9/2020 23:51:15' prior: 50493802! - attributesFor: condition - condition == #unchanged - ifTrue: [ - ^ {TextEmphasis normal} ]. - condition == #removed - ifTrue: [ - ^ {TextEmphasis struckThrough. TextColor red} ]. - condition == #inserted - ifTrue: [ - ^ {TextColor green} ]! ! -!SequenceDifference methodsFor: 'printing' stamp: 'LC 1/24/2010 15:13' prior: 16905330! - printTextOn: rtf - self do: [:item :condition | | attributes | - attributes := self attributesFor: condition. - rtf withAttributes: attributes do: [rtf nextPutAll: item asString]]! ! -!SequenceDifference methodsFor: 'enumerating' stamp: 'LC 1/24/2010 15:18' prior: 16905338! - do: aBlock - | j i item | - i := j := 1. - lcs do: [:pair | - [i < pair first] whileTrue: [ - item := x at: i. - aBlock value: item value: #removed. - i := i + 1]. - [j < pair second] whileTrue: [ - item := y at: j. - aBlock value: item value: #inserted. - j := j + 1]. - item := x at: i. - aBlock value: item value: #unchanged. - i := i + 1. - j := j + 1]. - i to: x size do: [:k | - item := x at: k. - aBlock value: item value: #removed]. - j to: y size do: [:k | - item := y at: k. - aBlock value: item value: #inserted] -! ! -!SequenceDifference methodsFor: 'services' stamp: 'LC 1/24/2010 15:18' prior: 16905357! - invert - | swap | - swap := x. - x := y. - y := swap. - lcs := lcs collect: [:pair | pair copy swap: 1 with: 2] -! ! -!SequenceDifference methodsFor: 'services' stamp: 'LC 1/24/2010 15:18' prior: 16905362 overrides: 16880927! - size - ^lcs sum: [:pair | (x at: pair first) size] -! ! -!SequenceDifference methodsFor: 'testing' stamp: 'jmv 12/21/2012 12:38' prior: 16905367! - <= sequence - ^lcs size <= sequence lcsSize -! ! -!SequenceDifference class methodsFor: 'instance creation' stamp: 'LC 1/24/2010 15:18' prior: 16905377! - x: x y: y lcs: sequence - ^self new x: x y: y lcs: sequence -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4709-AddSomeMissingMethodAuthors-JuanVuletich-2021Jul27-21h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4709] on 29 July 2021 at 9:28:28 am'! -!BitBlt methodsFor: 'private' stamp: 'jmv 7/29/2021 09:27:58' prior: 50577239! - copyBitsAgain - "Primitive. See BitBlt|copyBits, also a Primitive. Essential. See Object - documentation whatIsAPrimitive." - - - '#copyBitsAgain failed. Requested BitBlt operation not performed. Call stack follows:' print. - thisContext printStack: 10.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4710-CallStackOnBitBltFailure-JuanVuletich-2021Jul29-09h27m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4710] on 29 July 2021 at 10:09:16 am'! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 7/29/2021 10:01:46' prior: 50498922 overrides: 16899205! - drawOn: aCanvas - "Draw the hand itself (i.e., the cursor)." - "This method is only called when we are carrying morphs around..." - aCanvas - stencil: (Cursor cursorAt: #moveCursor) - at: `-8 @ -8` - color: Color black.! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 7/29/2021 10:08:07' prior: 50570207! - restoreSavedPatchOn: aCanvas - "Clear the changed flag and restore the part of the given canvas under this hand from the previously saved patch. If necessary, handle the transition to using the hardware cursor." - - self needsRedraw: false. - prevFullBounds ifNotNil: [ - aCanvas restorePatch: savedPatch bounds: prevFullBounds. - submorphs notEmpty ifTrue: [ ^ self ]. - "Make the transition to using hardware cursor. Clear savedPatch and - report one final damage rectangle to erase the image of the software cursor." - " owner invalidateDisplayRect: (savedPatch offset extent: savedPatch extent) from: nil." - self invalidateDisplayRect: self displayBounds for: nil. - Cursor currentCursor == Cursor defaultCursor ifFalse: [ Cursor defaultCursor activateCursor ]. - "show hardware cursor" - prevFullBounds _ nil ].! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 7/29/2021 10:09:03' prior: 50567609 overrides: 50570116! - displayBounds - - ^ self morphPosition-8 extent: self morphExtent.! ! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 7/29/2021 09:47:11' prior: 50532762 overrides: 50463434! - stencil: stencilForm at: aPoint color: aColor - "Flood this canvas with aColor wherever stencilForm has non-zero pixels" - " - | dot | - dot := ((Form dotOfSize: 32) asFormOfDepth: 1) offset: 0@0. - dot displayAt: 20@20. - Display getCanvas stencil: dot at: 60@20 color: Color red. - Display forceToScreen - " - ^self stencil: stencilForm - at: aPoint - sourceRect: stencilForm boundingBox - color: aColor! ! - -MorphicCanvas removeSelector: #stencil:at:color:! - -!methodRemoval: MorphicCanvas #stencil:at:color: stamp: 'Install-4711-HandMorph-cleanup-JuanVuletich-2021Jul29-09h57m-jmv.001.cs.st 8/6/2021 11:44:23'! -stencil: stencilForm at: aPoint color: aColor - self subclassResponsibility.! - -MorphicCanvas removeSelector: #stencil:at:sourceRect:color:! - -!methodRemoval: MorphicCanvas #stencil:at:sourceRect:color: stamp: 'Install-4711-HandMorph-cleanup-JuanVuletich-2021Jul29-09h57m-jmv.001.cs.st 8/6/2021 11:44:23'! -stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor - self subclassResponsibility.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4711-HandMorph-cleanup-JuanVuletich-2021Jul29-09h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4711] on 29 July 2021 at 12:09:37 pm'! -!MorphicCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/29/2021 10:32:34'! - drawCloseIcon - "For Window control buttons" - - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/29/2021 10:32:37'! - drawCollapseIcon - "For Window control buttons" - - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/29/2021 10:32:17'! - drawDownIcon - "For Scrollbars" - - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/29/2021 10:32:42'! - drawExpandIcon - "For Window control buttons" - - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/29/2021 10:37:03'! - drawHand - "For the user Hand. Especially when carrying morphs around." - - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/29/2021 10:32:14'! - drawLeftIcon - "For Scrollbars" - - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/29/2021 10:32:46'! - drawMenuIcon - "For Window control buttons" - - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/29/2021 10:33:11'! - drawPushPinIcon - "For Menu stay-up button" - - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/29/2021 10:32:10'! - drawRightIcon - "For Scrollbars" - - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/29/2021 10:32:05'! - drawUpIcon - "For Scrollbars" - - self subclassResponsibility.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/29/2021 10:36:51' overrides: 50590901! - drawHand - self - stencil: (Cursor cursorAt: #moveCursor) - at: `-8 @ -8` - color: `Color black` .! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 7/29/2021 10:37:10' prior: 50590794 overrides: 16899205! - drawOn: aCanvas - "Draw the hand itself (i.e., the cursor)." - "This method is only called when we are carrying morphs around..." - - aCanvas drawHand! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4712-HandMorph-canvas-cleanup-JuanVuletich-2021Jul29-12h08m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4712] on 29 July 2021 at 12:26:42 pm'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/29/2021 12:20:08'! - displayBoundsForHand: aHand - - self subclassResponsibility.! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 7/29/2021 12:21:09' overrides: 50590954! - displayBoundsForHand: aHand - - ^ aHand morphPosition-8 extent: aHand morphExtent.! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 7/29/2021 12:22:05' prior: 50590804! - restoreSavedPatchOn: aCanvas - "Clear the changed flag and restore the part of the given canvas under this hand from the previously saved patch. If necessary, handle the transition to using the hardware cursor." - - self needsRedraw: false. - prevFullBounds ifNotNil: [ - aCanvas restorePatch: savedPatch bounds: prevFullBounds. - submorphs notEmpty ifTrue: [ ^ self ]. - "Make the transition to using hardware cursor. Clear savedPatch and - report one final damage rectangle to erase the image of the software cursor." - " owner invalidateDisplayRect: (savedPatch offset extent: savedPatch extent) from: nil." - self invalidateDisplayRect: (aCanvas displayBoundsForHand: self) for: nil. - Cursor currentCursor == Cursor defaultCursor ifFalse: [ Cursor defaultCursor activateCursor ]. - "show hardware cursor" - prevFullBounds _ nil ].! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/29/2021 12:18:09' prior: 50590901! - drawHand - "For the user Hand. Especially when carrying morphs around." - - self subclassResponsibility.! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 7/29/2021 12:18:20' prior: 50590932 overrides: 50590994! - drawHand - self - stencil: (Cursor cursorAt: #moveCursor) - at: `-8 @ -8` - color: `Color black` .! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4713-MoveHandBoundsToCanvas-JuanVuletich-2021Jul29-12h24m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4713] on 29 July 2021 at 1:05:53 pm'! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 7/29/2021 13:05:24' prior: 50590833 overrides: 50570116! - displayBounds - - ^ self world canvas displayBoundsForHand: self! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4714-MoveHandBoundsToCanvas-JuanVuletich-2021Jul29-12h53m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4714] on 30 July 2021 at 10:12:42 am'! - -LayoutMorph subclass: #TaskbarMorph - instanceVariableNames: 'viewBox scale clock ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Taskbar'! - -!classDefinition: #TaskbarMorph category: #'Tools-Taskbar' stamp: 'Install-4715-TaskbarMorph-HonorDefaultFontChange-JuanVuletich-2021Jul30-10h09m-jmv.001.cs.st 8/6/2021 11:44:24'! -LayoutMorph subclass: #TaskbarMorph - instanceVariableNames: 'viewBox scale clock' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Taskbar'! -!TaskbarMorph methodsFor: 'notifications' stamp: 'jmv 7/29/2021 18:42:06' overrides: 50552865! - fontPreferenceChanged - clock font: nil! ! -!TaskbarMorph methodsFor: 'initialization' stamp: 'jmv 7/29/2021 18:40:36' prior: 50546590 overrides: 50521469! - initialize - super initialize. - viewBox _ LayoutMorph newRow color: self defaultColor. - self - addMorph: (clock _ UpdatingLabelMorph initializedInstance) - layoutSpec: (LayoutSpec morphWidthProportionalHeight: 0.5). - self - addMorph: viewBox - layoutSpec: (LayoutSpec - proportionalWidth: 1.0 - proportionalHeight: 1.0 - offAxisEdgeWeight: #rightOrBottom). - viewBox separation: self defaultHeight // 8 -! ! - -LayoutMorph subclass: #TaskbarMorph - instanceVariableNames: 'viewBox scale clock' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Taskbar'! - -!classDefinition: #TaskbarMorph category: #'Tools-Taskbar' stamp: 'Install-4715-TaskbarMorph-HonorDefaultFontChange-JuanVuletich-2021Jul30-10h09m-jmv.001.cs.st 8/6/2021 11:44:24'! -LayoutMorph subclass: #TaskbarMorph - instanceVariableNames: 'viewBox scale clock' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Taskbar'! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -TaskbarMorph allInstancesDo: [ :tb | tb submorphsDo: [ :m | m class == UpdatingLabelMorph ifTrue: [ tb instVarNamed: 'clock' put: m ]]]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4715-TaskbarMorph-HonorDefaultFontChange-JuanVuletich-2021Jul30-10h09m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4715] on 30 July 2021 at 10:29:05 am'! -!GeometryTransformation methodsFor: 'testing' stamp: 'jmv 7/30/2021 10:24:34'! - doesNotRotate - "Return true if the receiver specifies no rotation." - ^false! ! -!WidgetMorph methodsFor: 'geometry testing' stamp: 'jmv 7/30/2021 10:25:56' prior: 50579713 overrides: 50532207! -isOrthoRectangularMorph - "True if we are of rectangular shape, aligned with local coordinate axes. - Doesn't take into account possible rotation of our or some owner's local coordinates. - Note: SystemWindow answers true, but implements #addPossiblyUncoveredAreasIn:to: to take care of rounded corners." - - ^location doesNotRotate and: [ owner isNil or: [ owner isOrthoRectangularMorph ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4716-ZoomedWindowsStillOrthoRectangular-JuanVuletich-2021Jul30-10h20m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4716] on 30 July 2021 at 3:34:45 pm'! -!KernelMorph methodsFor: 'geometry testing' stamp: 'jmv 7/30/2021 10:53:34' overrides: 50575911! - wantsContour - "Kernel morphs don't usually need contour" - - ^false! ! -!WidgetMorph methodsFor: 'geometry testing' stamp: 'jmv 7/30/2021 10:54:19' overrides: 50575911! - wantsContour - "Widget morphs don't usually need contour" - - ^false! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/30/2021 11:00:12' prior: 50570116! - displayBounds - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us. - Integer pixel coordinates!!" - - self visible ifFalse: [ ^nil ]. - ^ privateDisplayBounds! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/30/2021 11:00:34' prior: 50537407! - displayBoundsOrBogus - "Never answer nil. A bogus value will trigger a draw operation, and bounds will later be corrected. - Integer pixel coordinates!!" - - ^self displayBounds ifNil: [ - Rectangle center: (self externalizeToWorld: `0@0`) extent: `2@2` ]! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/30/2021 15:34:05' prior: 50566181! - displayFullBounds - "Answer a rectangle that completely bounds receiver and submorphs when last drawn - (if the world was to be fully drawn, i.e. only to be used on a Canvas on the full world). - Integer pixel coordinates!!" - - | answer | - answer _ self displayBounds. - answer ifNil: [ ^nil ]. - (self submorphsMightProtrude and: [self clipsSubmorphsReally not]) ifTrue: [ - self submorphsReverseDo: [ :m | - answer _ answer quickMerge: m displayFullBounds ]]. - ^answer encompassingIntegerRectangle! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 7/30/2021 15:34:19' prior: 50566277 overrides: 50591165! - displayFullBounds - "Current full bounds of hand and carried submorphs. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around). - Integer pixel coordinates!!" - - | fullBounds | - fullBounds _ self displayBounds. - self submorphsDo: [ :m | - fullBounds _ fullBounds quickMerge: m displayFullBounds]. - lastPosition - ifNotNil: [ :lastPos | "When already carrying morphs around. Include also the rectangle updated to current hand position." - fullBounds _ fullBounds quickMerge: (fullBounds translatedBy: self morphPosition-lastPos) ]. - ^fullBounds encompassingIntegerRectangle! ! -!InnerPluggableMorph methodsFor: 'geometry' stamp: 'jmv 7/30/2021 10:49:50' prior: 16855347! - adjustExtent - "Morphs intended to be included in PluggableScrollPanes as scrolled content might need to adjust their extent." - - self subclassResponsibility! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4717-Morphic-tweaks-JuanVuletich-2021Jul30-15h32m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4716] on 30 July 2021 at 3:38:36 pm'! -!Morph methodsFor: 'accessing - flags' stamp: 'jmv 7/30/2021 12:11:02'! - fullRedrawNotNeeded - "Clear redraw flags for receiver and all submorphs (but only if set!!)" - - self isSubmorphRedrawNeeded ifTrue: [ - self submorphsDo: [ :m | - m fullRedrawNotNeeded ]]. - - "Equivalent to - self needsRedraw: false. - self submorphNeedsRedraw: false. - " - id _ id bitAnd: `3 bitInvert`! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/30/2021 11:38:26'! - fullUpdateCurrentProtrudingBounds - "Recursively update display bounds, for currentMorph and all submorphs, - but only for those whose bounds may go outside owner bounds." - - | isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph isOrthoRectangularMorph - ifTrue: [currentMorph displayBoundsSetFrom: self] - ifFalse: [ - "In these cases, #drawOn: is required to find bounds. - #displayBoundsSetFrom: will use the bounds found by us in these case. - See #displayBoundsSetFrom:" - currentMorph - drawOn: self; - displayBoundsSetFrom: self. - (currentMorph postDrawOn: self) ifTrue: [ - currentMorph displayBoundsUpdateFrom: self ]]. - (currentMorph submorphsMightProtrude and: [currentMorph clipsSubmorphsReally not]) ifTrue: [ - currentMorph submorphsDo: [ :m | - self fullUpdateProtrudingBounds: m ]]].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/30/2021 11:35:01'! - fullUpdateProtrudingBounds: aMorph - "Recursively update display bounds, for aMorph and all submorphs, - but only for those whose bounds may go outside owner bounds." - - aMorph visible ifTrue: [ - self into: aMorph. - self canvasToUse fullUpdateCurrentProtrudingBounds. - self outOfMorph ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/30/2021 12:22:21'! - updateCurrentBounds - "RUpdate display bounds, for currentMorph only." - - | isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph isOrthoRectangularMorph - ifTrue: [currentMorph displayBoundsSetFrom: self] - ifFalse: [ - "In these cases, #drawOn: is required to find bounds. - #displayBoundsSetFrom: will use the bounds found by us in these case. - See #displayBoundsSetFrom:" - currentMorph - drawOn: self; - displayBoundsSetFrom: self. - (currentMorph postDrawOn: self) ifTrue: [ - currentMorph displayBoundsUpdateFrom: self ]]].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/30/2021 12:22:33' prior: 50557143! - fullAddCurrentRect: addCurrentBounds submorphs: trySubmorphs to: aDamageRecorder - - addCurrentBounds ifTrue: [ - currentMorph needsRedraw: false. - self updateCurrentBounds. - aDamageRecorder recordInvalidRect: currentMorph displayBounds for: currentMorph ]. - trySubmorphs ifTrue: [ - (currentMorph submorphsMightProtrude and: [currentMorph clipsSubmorphsReally not]) - ifTrue: [ - currentMorph submorphNeedsRedraw: false. - currentMorph submorphsReverseDo: [ :m | - self fullAddRedrawRect: m to: aDamageRecorder ]] - ifFalse: [ currentMorph fullRedrawNotNeeded ]].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/30/2021 11:40:17' prior: 50570327! - updateHandsDisplayBounds: aWorldMorph - "Update displayBounds for carried morphs if never set. - Useful for new morph, that are created and attached to the hand." - - aWorldMorph handsDo: [ :hand | - hand hasSubmorphs ifTrue: [ - self into: hand. - hand submorphsDo: [ :morph | - morph displayBounds ifNil: [ - self fullUpdateProtrudingBounds: morph ]]. - self outOfMorph ]]! ! - -MorphicCanvas removeSelector: #fullUpdateCurrentBounds! - -!methodRemoval: MorphicCanvas #fullUpdateCurrentBounds stamp: 'Install-4718-Morphic-Optimization-JuanVuletich-2021Jul30-15h34m-jmv.001.cs.st 8/6/2021 11:44:24'! -fullUpdateCurrentBounds - - | isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph isOrthoRectangularMorph - ifTrue: [currentMorph displayBoundsSetFrom: self] - ifFalse: [ - "In these cases, #drawOn: is required to find bounds. - #displayBoundsSetFrom: will use the bounds found by us in these case. - See #displayBoundsSetFrom:" - currentMorph - drawOn: self; - displayBoundsSetFrom: self. - (currentMorph postDrawOn: self) ifTrue: [ - currentMorph displayBoundsUpdateFrom: self ]]. - currentMorph submorphsDo: [ :m | - self fullUpdateBounds: m ]].! - -MorphicCanvas removeSelector: #fullUpdateBounds:! - -!methodRemoval: MorphicCanvas #fullUpdateBounds: stamp: 'Install-4718-Morphic-Optimization-JuanVuletich-2021Jul30-15h34m-jmv.001.cs.st 8/6/2021 11:44:24'! -fullUpdateBounds: aMorph - - aMorph visible ifTrue: [ - self into: aMorph. - self canvasToUse fullUpdateCurrentBounds. - self outOfMorph ].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4718-Morphic-Optimization-JuanVuletich-2021Jul30-15h34m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4716] on 30 July 2021 at 3:44:24 pm'! -!LayoutAdjustingMorph methodsFor: 'adjusting' stamp: 'jmv 7/30/2021 15:20:27'! - adjustOwnerAt: aGlobalPoint millisecondSinceLast: millisecondSinceLast - - owner - adjustBy: self - at: aGlobalPoint! ! -!WindowEdgeAdjustingMorph methodsFor: 'adjusting' stamp: 'jmv 7/30/2021 15:22:03' overrides: 50591384! - adjustOwnerAt: aGlobalPoint millisecondSinceLast: millisecondSinceLast - - self basicAdjustOwnerAt: aGlobalPoint. - (owner isOrthoRectangularMorph and: [ - Preferences cheapWindowReframe or: [ - millisecondSinceLast > 200]]) ifTrue: [ - owner displayBounds newRectFrom: [ :f | - self basicAdjustOwnerAt: Sensor mousePoint. - owner morphPosition extent: owner morphExtent ]]! ! -!WindowEdgeAdjustingMorph methodsFor: 'adjusting' stamp: 'jmv 7/30/2021 15:18:57'! - basicAdjustOwnerAt: aGlobalPoint - | pointInTargetOwners | - - owner ifNotNil: [ - pointInTargetOwners _ aGlobalPoint + 1. - owner owner ifNotNil: [ :parent | - pointInTargetOwners _ parent internalizeFromWorld: pointInTargetOwners ]. - owner perform: selector with: pointInTargetOwners ]! ! -!LayoutAdjustingMorph methodsFor: 'stepping' stamp: 'jmv 7/30/2021 15:21:34' prior: 50579733 overrides: 50547622! - stepAt: millisecondSinceLast - "got the #mouseLeave: message" - | p | - hand ifNil: [ - Cursor currentCursor == self cursor ifTrue: [ Cursor defaultCursor activateCursor ]. - ^ self stopStepping ]. - "hasn't got the #mouseLeave: message (yet)" - p _ hand morphPosition. - hand lastMouseEvent mouseButton1Pressed - ifTrue: [ - self adjustOwnerAt: p millisecondSinceLast: millisecondSinceLast ] - ifFalse: [ - self stopStepping. - hand _ nil. - Cursor defaultCursor activateCursor ].! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 7/30/2021 15:41:46' prior: 50579968 overrides: 50539188! - addPossiblyUncoveredAreasIn: aRectangle to: aCollection - "Answer an array of rectangles encompassing those areas in aRectangle not completely - covered by self. These are the areas that might require further drawing (of morphs below us) - All areas that might possibly be uncovered must be included." - - | bounds radius | - self isOrthoRectangularMorph ifFalse: [ - aCollection add: aRectangle. - ^self ]. - - color mightBeTranslucent ifTrue: [ - aCollection add: aRectangle. - ^self ]. - - bounds _ self displayBounds. - bounds ifNil: [ - aCollection add: aRectangle. - ^self ]. - - "Solid rectangle. - This will be the fastest in many cases. So, please disable rounded corners if on slow hardware!!" - Theme current roundWindowCorners ifFalse: [ - aRectangle areasOutside: bounds do: [ :rect | aCollection add: rect ]. - ^self ]. - - "The solid rectangle does not include the corners. - Report a couple of rows (top and bottom) or columns (left and right) as uncovered areas. - We could also try to be more careful and answer each rounded corner... - Right now, report left and right columns as uncovered areas" - radius _ Theme current roundedWindowRadius. - aRectangle areasOutside: (bounds insetBy: radius@0) do: [ :rect | aCollection add: rect ].! ! - -WindowEdgeAdjustingMorph removeSelector: #adjustOwnerAt:! - -!methodRemoval: WindowEdgeAdjustingMorph #adjustOwnerAt: stamp: 'Install-4719-LayoutAdjusterFix-JuanVuletich-2021Jul30-15h38m-jmv.001.cs.st 8/6/2021 11:44:24'! -adjustOwnerAt: aGlobalPoint - | pointInTargetOwners | - - owner ifNotNil: [ - pointInTargetOwners _ aGlobalPoint + 1. - owner owner ifNotNil: [ :parent | - pointInTargetOwners _ parent internalizeFromWorld: pointInTargetOwners ]. - owner perform: selector with: pointInTargetOwners ]! - -LayoutAdjustingMorph removeSelector: #adjustOwnerAt:! - -!methodRemoval: LayoutAdjustingMorph #adjustOwnerAt: stamp: 'Install-4719-LayoutAdjusterFix-JuanVuletich-2021Jul30-15h38m-jmv.001.cs.st 8/6/2021 11:44:24'! -adjustOwnerAt: aGlobalPoint - - owner - adjustBy: self - at: aGlobalPoint! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4719-LayoutAdjusterFix-JuanVuletich-2021Jul30-15h38m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4719] on 30 July 2021 at 5:30:29 pm'! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 7/30/2021 17:29:15'! - displayFullBoundsForPatch - "Current full bounds of hand and carried submorphs. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around). - Integer pixel coordinates!!" - - | fullBounds | - fullBounds _ self displayBounds. - self submorphsDo: [ :m | - fullBounds _ fullBounds quickMerge: m displayFullBounds]. - lastPosition - ifNotNil: [ :lastPos | "When already carrying morphs around. Update rectangle to current hand position." - ^(fullBounds translatedBy: self morphPosition-lastPos) encompassingIntegerRectangle ]. - ^fullBounds encompassingIntegerRectangle! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 7/30/2021 17:24:48' prior: 50536278! - savePatchFrom: aCanvas appendDamageTo: aStream - "Save the part of the given canvas under this hand as a Form and return its bounding rectangle." - - | fullBounds | - fullBounds _ self displayFullBoundsForPatch intersect: (`0@0` extent: aCanvas extent). - savedPatch _ aCanvas savePatch: savedPatch bounds: fullBounds. - prevFullBounds _ fullBounds. - aStream nextPut: fullBounds.! ! - -HandMorph removeSelector: #displayFullBounds! - -!methodRemoval: HandMorph #displayFullBounds stamp: 'Install-4720-HandMorph-optimization-JuanVuletich-2021Jul30-17h15m-jmv.001.cs.st 8/6/2021 11:44:24'! -displayFullBounds - "Current full bounds of hand and carried submorphs. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around). - Integer pixel coordinates!!" - - | fullBounds | - fullBounds _ self displayBounds. - self submorphsDo: [ :m | - fullBounds _ fullBounds quickMerge: m displayFullBounds]. - lastPosition - ifNotNil: [ :lastPos | "When already carrying morphs around. Include also the rectangle updated to current hand position." - fullBounds _ fullBounds quickMerge: (fullBounds translatedBy: self morphPosition-lastPos) ]. - ^fullBounds encompassingIntegerRectangle! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4720-HandMorph-optimization-JuanVuletich-2021Jul30-17h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4720] on 31 July 2021 at 9:20:21 am'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 7/31/2021 09:19:37' prior: 50585356! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('AY' 'Angel Yan') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('bgs' 'Boris G. Shingarov') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('db' 'Douglas Brebner') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('EB' 'Eric Brandwein') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('FGJ' 'Fernando Gasperi Jabalera') - #('FJG' 'Facundo Javier Gelatti') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hlsf' 'Hilaire Fernandes') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('jar' 'Jaromir Matas') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('KLG' 'Gerald Klix') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MM' 'Mariano Montone') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('NM' 'Nicola Mingotti') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('pmon' 'Paolo Montrasi') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('sjd' 'Santiago Jose Dandois') - #('SLD' 'Steve Davies') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('Squeak1.0' 'Squeak 1.0, September 20, 1996') - #('Squeak1.1' 'Squeak 1.1, September 23, 1996') - #('Squeak1.2' 'Squeak 1.2, June 29, 1997') - #('Squeak1.3' 'Squeak 1.3, January 16, 1998') - #('sr' 'Stephan Rudlof') - #('ss' 'Sebastian Sujarchuk') - #('SSS' 'Samuel S. Shuster') - #('ST-80' 'Smalltalk-80, version 2, of April 1, 1983') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tsl' 'Thiago da Silva Lino') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4721-AddNicolaAsKnownAuthor-JuanVuletich-2021Jul31-09h19m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4689] on 31 July 2021 at 8:35:26 pm'! -!FeatureRequirementUnsatisfied methodsFor: 'exceptionDescription' stamp: 'jmv 7/31/2021 20:26:38' prior: 50476015 overrides: 16839230! - defaultAction - "The default action taken if the exception is signaled." - - self messageText print. - PopUpMenu inform: self messageText.! ! -!FeatureRequirement methodsFor: 'requires' stamp: 'jmv 7/31/2021 20:34:40' prior: 50579270! - requireUnlessIn: toLoad main: mainFeatureOrNil requiringFeature: requiringFeatureOrNil - "See if all the requirements can be met and answer the load order" - - - self isAlreadySatisfied ifFalse: [ - (toLoad anySatisfy: [ :featReq | featReq sameNameAs: self]) ifFalse: [ - (self findPackageFileAsReqOf: mainFeatureOrNil) - ifTrue: [ | otherRequirements | - otherRequirements := self requirements. - otherRequirements ifNotNil: [ - otherRequirements do: [ :requires | - requires requireUnlessIn: toLoad main: (mainFeatureOrNil ifNil: [self]) requiringFeature: self ]]. - self == mainFeatureOrNil ifFalse: [ - self addToLoad: toLoad withMyRequirements: otherRequirements ]. - ] - ifFalse: [ - | failureMessage | - failureMessage _ name = #'Cuis-Base' - ifTrue: [ - 'Installing [', requiringFeatureOrNil name, - '] requires base system updated to #', self minRevision printString, String newLineString, - 'But this system is updated to #', SystemVersion current versionRevision second printString, String newLineString, - 'Please install Cuis base system updates and retry.' ] - ifFalse: [ - requiringFeatureOrNil notNil - ifTrue: [ - 'Could not find code package file for [', name, '].', String newLineString, - 'Installation of [', requiringFeatureOrNil name, '] failed.'] - ifFalse: [ - 'Could not find code package file for [', name, '].', String newLineString, - 'Installation failed.']]. - FeatureRequirementUnsatisfied signal: failureMessage. - ]]]. - - ^ toLoad! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4722-PackageInstallFailureErrorMessage-JuanVuletich-2021Jul31-18h11m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4722] on 1 August 2021 at 7:18:57 pm'! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 8/1/2021 19:05:12' prior: 50590965! - restoreSavedPatchOn: aCanvas - "Clear the changed flag and restore the part of the given canvas under this hand from the previously saved patch. If necessary, handle the transition to using the hardware cursor." - - self needsRedraw: false. - prevFullBounds ifNotNil: [ - aCanvas restorePatch: savedPatch bounds: prevFullBounds. - self invalidateDisplayRect: prevFullBounds for: nil. - submorphs isEmpty ifTrue: [ - "Dropped carried morph. - Make the transition to using hardware cursor. Clear savedPatch and - report one final damage rectangle to erase the image of the software cursor." - Cursor currentCursor == Cursor defaultCursor ifFalse: [ Cursor defaultCursor activateCursor ]. - "show hardware cursor" - prevFullBounds _ nil ]].! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 7/30/2021 17:24:48' prior: 50591534! - savePatchFrom: aCanvas appendDamageTo: aStream - "Save the part of the given canvas under this hand as a Form and return its bounding rectangle." - - | fullBounds | - fullBounds _ self displayFullBoundsForPatch intersect: (`0@0` extent: aCanvas extent). - savedPatch _ aCanvas savePatch: savedPatch bounds: fullBounds. - prevFullBounds _ fullBounds. - aStream nextPut: fullBounds.! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 8/1/2021 19:14:29' prior: 50591511! - displayFullBoundsForPatch - "Current full bounds of hand and carried submorphs. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around). - Integer pixel coordinates!!" - - | handBounds fullBounds | - handBounds _ self displayBounds. - fullBounds _ handBounds. - self submorphsDo: [ :m | - fullBounds _ fullBounds quickMerge: m displayFullBounds]. - lastPosition - ifNotNil: [ :lastPos | "When already carrying morphs around. Update rectangle to current hand position." - fullBounds _ (fullBounds translatedBy: self morphPosition-lastPos) quickMerge: handBounds ]. - ^fullBounds encompassingIntegerRectangle! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4723-HandMorph-Fixes-JuanVuletich-2021Aug01-19h12m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4723] on 1 August 2021 at 8:11:49 pm'! -!Transcript class methodsFor: 'private' stamp: 'jmv 8/1/2021 20:01:46' prior: 50541548! - canvas - "VectorCanvas is not safe WRT changes in Display extent. - Besides, it is expensive in memory. - The alternative of using (UISupervisor ui canvas) is not safe. We don't know in which state it is (currentMorph, geometry, etc), or it is in midst of state change, and inconsistent. Waiting for a safe stat is not an option: we want immeiate updates. - The only way to no longer need BitBltCanvas is to use BitBlt directly, possibly with a special StrikeFont. - That, of course, would mean that the Morphic version has no hope of ever matching it. - More thought is needed to find a simple and general solution. - " - (displayCanvas isNil or: [ - displayCanvas class ~= BitBltCanvas]) ifTrue: [ - displayCanvas _ BitBltCanvas onForm: Display ]. - ^ displayCanvas! ! -!TranscriptWindow class methodsFor: 'menu-world' stamp: 'jmv 8/1/2021 19:26:46' prior: 50410962! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 10. - #itemOrder -> 50. - #label -> 'Transcript'. - #object -> TranscriptWindow. - #selector -> #openTranscript. - #icon -> #printerIcon. - #balloonText -> 'A window showing contents of the System Transcript'. - } asDictionary}`! ! -!TranscriptMorph methodsFor: 'drawing' stamp: 'jmv 8/1/2021 20:09:40' prior: 50541670 overrides: 50545911! - drawOn: aCanvas - "If we don't call super, clipping fails if zoomed / rotated, and nothing is shown." - super drawOn: aCanvas. - aCanvas clippingByCurrentMorphDo: [ - Transcript displayOnCanvas: aCanvas in: self morphLocalBounds ]. - self displayBounds ifNotNil: [ :r | - Transcript bounds:r ]. - self updateWorkspace! ! - -Transcript class removeSelector: #displayOnCanvas:! - -!methodRemoval: Transcript class #displayOnCanvas: stamp: 'Install-4724-Transcript-fixes-JuanVuletich-2021Aug01-20h04m-jmv.001.cs.st 8/6/2021 11:44:24'! -displayOnCanvas: aCanvas - " - 1 to: 2000 do: [ :i | i print ]. - 1 to: 750 do: [ :i | i print ]. - Transcript displayOn: Display in: bounds - " - | font count string x y fh innerR index | - "aCanvas form fill: aRectangle fillColor: `Color white`." - font _ FontFamily defaultFamilyAndPointSize. - - "innerR _ aRectangle insetBy: self padding." - innerR _ 0@0 extent: 100@100. - aCanvas newClipRect: innerR. - x _ innerR left. - y _ innerR top. - fh _ font lineSpacing. - count _ lastIndex - firstIndex \\ self maxEntries + 1 min: innerR height // fh - 1. - index _ lastIndex - count \\ self maxEntries + 1. - count timesRepeat: [ - string _ entries at: index. - aCanvas drawString: string at: x@y font: font color: `Color veryDarkGray`. - y _ y + fh. - index _ index \\ self maxEntries + 1 ]. - string _ unfinishedEntry contents. - aCanvas drawString: string at: x@y font: font color: `Color veryDarkGray`! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4724-Transcript-fixes-JuanVuletich-2021Aug01-20h04m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4724] on 2 August 2021 at 9:28:20 am'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/2/2021 09:25:35' prior: 50591302! - fullAddCurrentRect: addCurrentBounds submorphs: trySubmorphs to: aDamageRecorder - - | invalidateOwns | - invalidateOwns _ false. - addCurrentBounds ifTrue: [ - currentMorph needsRedraw: false. - self updateCurrentBounds. - invalidateOwns _ true ]. - trySubmorphs ifTrue: [ - (currentMorph submorphsMightProtrude and: [currentMorph clipsSubmorphsReally not]) - ifTrue: [ - currentMorph submorphNeedsRedraw: false. - currentMorph submorphsReverseDo: [ :m | - self fullAddRedrawRect: m to: aDamageRecorder ]] - ifFalse: [ - currentMorph fullRedrawNotNeeded. - invalidateOwns _ true ]]. - invalidateOwns ifTrue: [ - aDamageRecorder recordInvalidRect: currentMorph displayBounds for: currentMorph ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4725-MorphicInvalidationFix-JuanVuletich-2021Aug02-09h27m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4725] on 2 August 2021 at 11:05:07 am'! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/2/2021 11:04:42' prior: 50576001! - displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - aRectangle is clipped appropiately if some owner clips us. - See also #displayBoundsUpdateFrom:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - self isOrthoRectangularMorph - ifTrue: [ - "In these cases, #drawOn: might not be able to find bounds (InnerTextMorph, for example), - but it is OK to compute them from #morphLocalBounds. This is not true for non-orthoRectangular morphs!!" - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphFromLocalBounds ] - ifFalse: [ - "In this cases, we use the bounds bound by #drawOn. This method must therefore be called after calling #drawOn:." - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphAfterDraw. - self setProperty: #contour toValue: ( - self wantsContour ifTrue: [ aCanvas contourOfCurrentMorphAfterDrawInto: (self valueOfProperty: #contour) ]). - privateDisplayBounds hasPositiveExtent ifFalse: [ "This might happen for morphs with empty #drawOn: like, for example, LahoutMorphs." - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphFromLocalBounds ] - ]]]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4726-LayoutMorph-halo-fix-JuanVuletich-2021Aug02-11h03m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4726] on 2 August 2021 at 11:32:01 am'! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 8/2/2021 11:19:09' prior: 16786597 overrides: 50463429! - image: aForm multipliedBy: aColor at: aPoint - "Multiply aForm and aColor, then blend over destination. - aForm is a kind of advanced stencil, supplying brightness and opacity at each pixel - - (BitBltCanvas onForm: Display) image: ((Form dotOfSize: 50) asFormOfDepth: 32) multipliedBy: Color red at: 20@20. Display forceToScreen - " - aColor isTransparent ifFalse: [ - self class accessProtect critical: [ - self buildAuxWith: aForm multipliedWith: aColor. - self image: AuxForm at: aPoint sourceRect: aForm boundingBox ]]! ! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 8/2/2021 11:19:23' prior: 50590839! - stencil: stencilForm at: aPoint color: aColor - "Flood this canvas with aColor wherever stencilForm has non-zero pixels" - " - | dot | - dot := ((Form dotOfSize: 32) asFormOfDepth: 1) offset: 0@0. - dot displayAt: 20@20. - (BitBltCanvas onForm: Display) stencil: dot at: 60@20 color: Color red. - Display forceToScreen - " - ^self stencil: stencilForm - at: aPoint - sourceRect: stencilForm boundingBox - color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 8/2/2021 11:16:46' prior: 50532845 overrides: 50463465! - fillRectangle: aRectangle tilingWith: aForm multipliedBy: aColor - "Fill aRectangle with the equivalent of aForm multiplied by aColor - aForm is a kind of advanced stencil, supplying brightness and opacity at each pixel - Similar to #image:multipliedBy:at: - - - (BitBltCanvas onForm: Display) fillRectangle: (10@10 extent: 100@100) tilingWith: (BitBltCanvas verticalGrayGradient: 30 gradientTop: 0.8 gradientBottom: 0.5) multipliedBy: Color red. Display forceToScreen. - " - - - engine ifNil: [ ^nil ]. - - self class accessProtect critical: [ - self buildAuxWith: aForm multipliedWith: aColor. - "Warning: aForm boundingBox is most likely different from AuxForm boundingBox!!" - self fillRectangle: aRectangle tilingWith: AuxForm sourceRect: aForm boundingBox rule: Form paint ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 8/2/2021 11:16:59' prior: 50545221 overrides: 50463478! - frameRectangle: r borderWidth: borderWidth color: borderColor - " - (BitBltCanvas onForm: Display) - frameRectangle: (10@10 extent: 300@200) - borderWidth: 20 - color: Color red. - Display forceToScreen - " - | rect bw | - - engine ifNil: [ ^nil ]. - - (borderWidth > 0 and: [ borderColor isTransparent not ]) ifTrue: [ - rect _ (currentTransformation externalizeRectangle: r) rounded. - bw _ (currentTransformation externalizeScalar: borderWidth) rounded. - self setPaintColor: borderColor. - engine - frameRect: rect - borderWidth: bw ]! ! -!BitBltCanvas methodsFor: 'drawing-roundedRectangles' stamp: 'jmv 8/2/2021 11:15:28' prior: 50569855 overrides: 50463497! - roundRect: aRectangle color: aColor radius: r - " - (BitBltCanvas onForm: Display) roundRect: (10@10 extent: 200@100) color: Color red radius: 10.5. Display forceToScreen. - " - - engine ifNil: [ ^nil ]. - - "radius is not scaled properly..." - "top stripe" - self - image: (self class topLeftCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle topLeft. - self - image: (self class topRightCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle topRight - (r@0). - self fillRectangle: ((aRectangle withHeight: r) insetBy: r@0) color: aColor. - - "center stripe" - self fillRectangle: (aRectangle insetBy: (0 @ r corner: 0 @ r)) color: aColor. - - "bottom stripe" - self - image: (self class bottomLeftCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle bottomLeft - (0@r). - self - image: (self class bottomRightCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle bottomRight - (r@r) . - self fillRectangle: ((aRectangle bottomLeft + (r@r negated)) extent: (aRectangle width - r - r@r)) color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-windows' stamp: 'jmv 8/2/2021 11:20:54' prior: 50578678! - windowFrame: aRectangle color: aColor radius: r border: bw labelHeight: lh gradientTop: topFactor gradientBottom: bottomFactor insideColor: insideColor - " - BitBltCanvas releaseClassCachedState; releaseClassState. - (BitBltCanvas onForm: Display) windowFrame: (10@10 extent: 200@100) color: Color red radius: 10 border: 5 labelHeight: 25 gradientTop: 1.0 gradientBottom: 0.5 insideColor: Color green. - Display forceToScreen - " - "top stripe" - | bottomColor he tl tr | - - engine ifNil: [ ^nil ]. - - self - image: (self class topLeftCorner: r height: lh gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: aRectangle topLeft. - self - image: (self class topRightCorner: r height: lh gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: aRectangle topRight - (r@0). - self - fillRectangle: ((aRectangle withHeight: lh) insetBy: r@0) - tilingWith: (self class verticalGrayGradient: lh gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor. - - bottomColor _ aColor * bottomFactor. - - "left and right borders" - tl _ aRectangle topLeft + (0@lh). - tr _ aRectangle topRight + (bw negated@lh). - he _ bw@(aRectangle height - lh - r). - self fillRectangle: (tl extent: he) color: bottomColor. - self fillRectangle: (tr extent: he) color: bottomColor. - - "bottom stripe" - self - image: (self class bottomLeftCorner: r height: r gradientTop: 1 gradientBottom: 1 borderWidth: bw) - multipliedBy: bottomColor - at: aRectangle bottomLeft - (0@r). - self - image: (self class bottomRightCorner: r height: r gradientTop: 1 gradientBottom: 1 borderWidth: bw) - multipliedBy: bottomColor - at: aRectangle bottomRight - (r@r) . - self fillRectangle: ((aRectangle bottomLeft + (r@bw negated)) extent: (aRectangle width - r - r@bw)) color: bottomColor. - - "inside" - self fillRectangle: (aRectangle insetBy: (bw@lh corner: bw@bw)) color: insideColor! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 8/2/2021 11:18:01' prior: 50495194! - frameRectangle: rect borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor - "rect and borderWidth are in targetForm coordinates. No transformation is done." - " - (BitBltCanvas onForm: Display) - frameRectangle: (10@10 extent: 300@200) - borderWidth: 20 - topLeftColor: Color green - bottomRightColor: Color red. - (BitBltCanvas onForm: Display) fillRectangle: (100@100 extent: 300@200) color: Color white. - Display forceToScreen. - " - | w h | - - rect area = 0 ifTrue: [^ self]. - - self setPaintColor: topLeftColor. - - engine frameRectTopLeft: rect borderWidth: borderWidth. - - borderWidth isNumber - ifTrue: [w _ h _ borderWidth] - ifFalse: [w _ borderWidth x. h _ borderWidth y]. - self setPaintColor: bottomRightColor. - engine - frameRectRight: rect width: w; - frameRectBottom: rect height: h! ! -!BitBltCanvas class methodsFor: 'cached forms' stamp: 'jmv 8/2/2021 11:29:15' prior: 16787202! - bottomLeftCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - ^self cachedForms - at: { #bottomLeft. r asInteger. height asInteger. (gradientTopFactor*100) asInteger. (gradientBottomFactor*100) asInteger} - ifAbsentPut: [ - Form - bottomLeftCorner: r - height: height - gradientTop: gradientTopFactor - gradientBottom: gradientBottomFactor ]! ! -!BitBltCanvas class methodsFor: 'cached forms' stamp: 'jmv 8/2/2021 11:28:51' prior: 16787216! - bottomLeftCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor borderWidth: bw - ^self cachedForms - at: { #bottomLeft. r asInteger. height asInteger. (gradientTopFactor*100) asInteger. (gradientBottomFactor*100) asInteger. bw asInteger} - ifAbsentPut: [ - Form - bottomLeftCorner: r - height: height - gradientTop: gradientTopFactor - gradientBottom: gradientBottomFactor - borderWidth: bw ]! ! -!BitBltCanvas class methodsFor: 'cached forms' stamp: 'jmv 8/2/2021 11:28:58' prior: 16787231! - bottomRightCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - ^self cachedForms - at: { #bottomRight. r asInteger. height asInteger. (gradientTopFactor*100) asInteger. (gradientBottomFactor*100) asInteger} - ifAbsentPut: [ - Form - bottomRightCorner: r - height: height - gradientTop: gradientTopFactor - gradientBottom: gradientBottomFactor ]! ! -!BitBltCanvas class methodsFor: 'cached forms' stamp: 'jmv 8/2/2021 11:29:31' prior: 16787245! - bottomRightCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor borderWidth: bw - ^self cachedForms - at: { #bottomRight. r asInteger. height asInteger. (gradientTopFactor*100) asInteger. (gradientBottomFactor*100) asInteger. bw asInteger} - ifAbsentPut: [ - Form - bottomRightCorner: r - height: height - gradientTop: gradientTopFactor - gradientBottom: gradientBottomFactor - borderWidth: bw ]! ! -!BitBltCanvas class methodsFor: 'cached forms' stamp: 'jmv 8/2/2021 11:29:37' prior: 16787278! -topLeftCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - ^self cachedForms - at: { #topLeft. r asInteger. height asInteger. (gradientTopFactor*100) asInteger. (gradientBottomFactor*100) asInteger} - ifAbsentPut: [ - Form - topLeftCorner: r - height: height - gradientTop: gradientTopFactor - gradientBottom: gradientBottomFactor ]! ! -!BitBltCanvas class methodsFor: 'cached forms' stamp: 'jmv 8/2/2021 11:29:41' prior: 16787291! - topRightCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - ^self cachedForms - at: { #topRight. r asInteger. height asInteger. (gradientTopFactor*100) asInteger. (gradientBottomFactor*100) asInteger} - ifAbsentPut: [ - Form - topRightCorner: r - height: height - gradientTop: gradientTopFactor - gradientBottom: gradientBottomFactor ]! ! -!BitBltCanvas class methodsFor: 'cached forms' stamp: 'jmv 8/2/2021 11:29:59' prior: 50360858! - verticalGrayGradient: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - ^self cachedForms - at: { #vertical. height asInteger. (gradientTopFactor*100) asInteger. (gradientBottomFactor*100) asInteger} - ifAbsentPut: [ - Form - verticalGradient: height - topColor: (Color gray: gradientTopFactor) - bottomColor: (Color gray: gradientBottomFactor) ]! ! -!BitBltCanvas class methodsFor: 'cached button forms' stamp: 'jmv 8/2/2021 11:26:03' prior: 16787319! - arrowOfDirection: aSymbol size: finalSizeInteger - ^self cachedForms - at: { aSymbol . finalSizeInteger asInteger} - ifAbsentPut: [ - self buildArrowOfDirection: aSymbol size: finalSizeInteger ]! ! -!BitBltCanvas class methodsFor: 'cached button forms' stamp: 'jmv 8/2/2021 11:31:13' prior: 50577775! - windowButtonIcon: aSymbol size: finalSizeInteger - ^self cachedForms - at: { aSymbol . finalSizeInteger asInteger} - ifAbsentPut: [ - | icon w h factor magnifiedExtent magnifiedIcon | - icon _ Theme current perform: aSymbol. - magnifiedIcon _ icon. - w _ icon width. - h _ icon height. - w*h = 0 ifFalse: [ - factor _ 1.0 * finalSizeInteger / w min: 1.0 * finalSizeInteger / h. - factor = 1.0 ifFalse: [ - magnifiedExtent _ (icon extent * factor) rounded. - magnifiedIcon _ icon magnifyTo: magnifiedExtent ]]. - magnifiedIcon ]! ! - -BitBltCanvas class removeSelector: #buildArrowWith:borderForm:! - -!methodRemoval: BitBltCanvas class #buildArrowWith:borderForm: stamp: 'Install-4727-AvoidFloatsAsDictionaryKeys-JuanVuletich-2021Aug02-11h14m-jmv.002.cs.st 8/6/2021 11:44:24'! -buildArrowWith: insideForm borderForm: borderForm - | extent translucentForm color insideSpec borderSpec border background alpha| - " - Display getCanvas - image: (BitBltCanvas buildArrowWith: BitBltCanvas downInsideForm borderForm: BitBltCanvas downBorderForm) - at: 20@20 - Display getCanvas - image: (BitBltCanvas buildArrowWith:BitBltCanvas upInsideForm borderForm: BitBltCanvas upBorderForm) - at: 40@20 - " - extent _ insideForm extent - `1@2`. - translucentForm _ Form extent: insideForm extent depth: 32. - 0 to: extent x-1 do: [ :x | - 0 to: extent y-1 do: [ :y | - insideSpec _ insideForm colorAt: x@(y+1). - borderSpec _ borderForm colorAt: x@(y+1). - insideSpec = `Color r: 0.0 g: 0.0 b: 1.0` - ifTrue: [ color _ `Color transparent` ] - ifFalse: [ - borderSpec = `Color r: 1.0 g: 0.0 b: 0.0` - ifTrue: [ color _ insideSpec ] - ifFalse: [ - border _ x < (extent x//2) - ifTrue: [`Color white`] - ifFalse: [`Color black`]. - background _ borderForm colorAt: extent x@(y+1). - alpha _ borderSpec red asFloat - background red / (border red - background red). - color _ border alpha: (alpha min: 1 max: 0) ]]. - translucentForm colorAt: x@y put: color ]]. - ^translucentForm! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -BitBltCanvas releaseClassCachedState; releaseClassState.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4727-AvoidFloatsAsDictionaryKeys-JuanVuletich-2021Aug02-11h14m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4727] on 2 August 2021 at 2:53:12 pm'! -!MorphicCanvas methodsFor: 'drawing-icons' stamp: 'jmv 8/2/2021 14:21:31'! - drawExpandedAt: aPoint - "For Tree View (IndentingListItemMorph)" - - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-icons' stamp: 'jmv 8/2/2021 14:21:53'! - drawNotExpandedAt: aPoint - "For Tree View (IndentingListItemMorph)" - - self subclassResponsibility.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 8/2/2021 14:50:23' overrides: 50592562! - drawExpandedAt: aPoint - "For Tree View (IndentingListItemMorph)" - - | f | - f _ BitBltCanvas arrowOfDirection: #down size: 17. - self - image: f - at: aPoint x-3 @ (aPoint y - (f height // 2)).! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 8/2/2021 14:50:32' overrides: 50592568! - drawNotExpandedAt: aPoint - "For Tree View (IndentingListItemMorph)" - - | f | - f _ BitBltCanvas arrowOfDirection: #right size: 17. - self - image: f - at: aPoint x-1 @ (aPoint y - (f height // 2)).! ! -!InnerHierarchicalListMorph methodsFor: 'drawing' stamp: 'jmv 8/2/2021 14:45:19' prior: 16854911! - drawLineToggleToTextFor: anIndentingListItemMorph on: aCanvas lineColor: lineColor hasToggle: hasToggle - "If I am not the only item in my container, draw the line between: - - my left edge - - and my text left edge" - - | aMorphCenter hLineY hLineLeft rect right | - anIndentingListItemMorph isSoleItem ifTrue: [ ^ self ]. - hasToggle ifFalse: [ - rect _ anIndentingListItemMorph toggleRectangle. - aMorphCenter _ anIndentingListItemMorph externalize: rect center. - right _ (anIndentingListItemMorph externalize: rect rightCenter) x. - hLineY _ aMorphCenter y. - hLineLeft _ aMorphCenter x - 1. - aCanvas - line: hLineLeft @ hLineY - to: right @ hLineY - width: 1 - color: lineColor ]! ! -!IndentingListItemMorph methodsFor: 'drawing' stamp: 'jmv 8/2/2021 14:18:46' prior: 50503491 overrides: 50555166! - drawOn: aCanvas - - | x colorToUse centeringOffset | - isHighlighted ifTrue: [ - aCanvas - fillRectangle: self morphLocalBounds - color: ((Theme current - listHighlightFocused: owner owner hasKeyboardFocus) alpha: 0.3) ]. - - isSelected ifTrue: [ - aCanvas - fillRectangle: self morphLocalBounds - color: (Theme current - listHighlightFocused: owner owner hasKeyboardFocus) ]. - - x _ 12 * indentLevel. - - complexContents hasContents ifTrue: [ - isExpanded - ifTrue: [ aCanvas drawExpandedAt: x@(extent y//2)] - ifFalse: [ aCanvas drawNotExpandedAt: x@(extent y//2) ]]. - x _ x + 18. - - icon isNil ifFalse: [ - centeringOffset _ ((extent y - icon height) / 2.0) rounded. - aCanvas - image: icon - at: (x @ centeringOffset). - x _ x + 20 ]. - - colorToUse _ complexContents preferredColor ifNil: [ color ]. - aCanvas - drawString: contents asString - at: x@0 - font: self fontToUse - color: colorToUse! ! - -HierarchicalListMorph removeSelector: #notExpandedForm! - -!methodRemoval: HierarchicalListMorph #notExpandedForm stamp: 'Install-4728-TreeMorphEnh-JuanVuletich-2021Aug02-14h09m-jmv.005.cs.st 8/6/2021 11:44:24'! -notExpandedForm - - ^BitBltCanvas arrowOfDirection: #right size: 13! - -HierarchicalListMorph removeSelector: #expandedForm! - -!methodRemoval: HierarchicalListMorph #expandedForm stamp: 'Install-4728-TreeMorphEnh-JuanVuletich-2021Aug02-14h09m-jmv.005.cs.st 8/6/2021 11:44:24'! -expandedForm - - ^BitBltCanvas arrowOfDirection: #down size: 13! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4728-TreeMorphEnh-JuanVuletich-2021Aug02-14h09m-jmv.005.cs.st----! - -'From Cuis 5.0 [latest update: #4728] on 2 August 2021 at 3:53:59 pm'! -!MessageSet methodsFor: 'message list' stamp: 'pb 8/1/2021 18:28:53'! - sortReverse - "Reverse the current sort order" - messageList _ messageList reversed . - self changed: #messageList! ! -!MessageSetWindow methodsFor: 'menu building' stamp: 'jmv 8/2/2021 15:52:15' prior: 50585279 overrides: 50403936! - addExtraMenu2ItemsTo: options - "The shifted selector-list menu is being built. Add items specific to MessageSet" - - model growable ifTrue: [ - options add: `{ - #itemGroup -> 40. - #itemOrder -> 31. - #label -> 'remove from this browser'. - #object -> #model. - #selector -> #removeMessageFromBrowser. - #icon -> #listRemoveIcon - } asDictionary`. - options add:`{ - #itemGroup -> 40. - #itemOrder -> 32. - #label -> 'filter message list...'. - #selector -> #filterMessageList. - #icon -> #findIcon - } asDictionary` ]. - - options add: `{ - #itemGroup -> 41. - #itemOrder -> 33. - #label -> 'sort by class'. - #object -> #model. - #selector -> #sortByClass. - #icon -> #classIcon - } asDictionary`. - options add: `{ - #itemGroup -> 41. - #itemOrder -> 34. - #label -> 'sort by selector'. - #object -> #model. - #selector -> #sortBySelector. - #icon -> #scriptIcon - } asDictionary`. - options add: `{ - #itemGroup -> 41. - #itemOrder -> 35. - #label -> 'sort by date'. - #object -> #model. - #selector -> #sortByDate. - #icon -> #dateIcon - } asDictionary`. - options add: `{ - #itemGroup -> 41. - #itemOrder -> 36. - #label -> 'reverse sort'. - #object -> #model. - #selector -> #sortReverse. - #icon -> #redoIcon - } asDictionary`. - -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4729-MessageSet-sorting-PhilBellalouna-2021Aug02-15h50m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4729] on 2 August 2021 at 9:26:39 pm'! -!Rectangle methodsFor: 'transforming' stamp: 'jmv 8/2/2021 21:22:04' prior: 16899039! - translatedBy: delta - "Answer a Rectangle translated by delta, a Point or a scalar." - - ^Rectangle origin: origin + delta corner: corner + delta! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 8/2/2021 21:25:52' prior: 50569339! - grabMorph: aMorph moveUnderHand: moveUnderHand - "Grab the given morph (i.e., add it to this hand and remove it from its current owner). - If moveUnderHand is requested or it seems neccesary anyway, move the grabbed morph under the hand." - - | grabbed positionInHandCoordinates tx bounds | - self releaseMouseFocus. "Break focus" - grabbed _ aMorph. - aMorph owner ifNotNil: [ :o | grabbed _ o aboutToGrab: aMorph ]. - grabbed ifNil: [ ^ self ]. - grabbed _ grabbed aboutToBeGrabbedBy: self. - grabbed ifNil: [ ^ self ]. - - moveUnderHand ifTrue: [ - bounds _ nil. - grabbed isInWorld ifTrue: [ - grabbed displayBounds ifNotNil: [ :r | - bounds _ r translatedBy: grabbed morphPositionInWorld negated ]]. - bounds ifNil: [ bounds _ grabbed findBounds ]. - positionInHandCoordinates _ (bounds center *2 + bounds bottomRight //3) negated. - self grabMorph: grabbed delta: positionInHandCoordinates. - ^self ]. - - positionInHandCoordinates _ (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) - morphPositionInWorld - self morphPositionInWorld. - - tx _ GeometryTransformation identity. - (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) withAllOwnersDo: [ :o | - tx _ o location composedWith: tx ]. - self withAllOwnersReverseDo: [ :o | - tx _ o location inverseTransformation composedWith: tx ]. - self grabMorph: grabbed delta: positionInHandCoordinates. - - grabbed location: tx.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4730-BetterMoveUnderHand-JuanVuletich-2021Aug02-20h44m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4730] on 3 August 2021 at 11:12:20 am'! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/3/2021 10:00:10'! - basicDisplayBounds - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us. - Integer pixel coordinates!!" - - self visible ifFalse: [ ^nil ]. - ^ privateDisplayBounds! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 8/3/2021 11:04:36' overrides: 50592801! - basicDisplayBounds - - ^ self world canvas displayBoundsForHand: self! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 8/3/2021 11:04:44' overrides: 50592801! - basicDisplayBounds - ^ 0@0 extent: extent! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/3/2021 09:33:14' overrides: 50592084! - displayBoundsSetFrom: aCanvas - "Private for framework use. See super implementation." - - "Widgets don't need contour. Additionally, for InnerTextMorph and LayoutMorph, the bounds - can not be deduced from #drawOn: and should be computed from the 'extent' instance variable." - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - "In these cases, #drawOn: might not be able to find bounds (InnerTextMorph and LayoutMorph, for example), - but it is OK to compute them from #morphLocalBounds. This is not true for non-orthoRectangular morphs!!" - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphFromLocalBounds ]]].! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/3/2021 09:35:25' overrides: 50576039! - displayBoundsUpdateFrom: aCanvas - "Private for framework use. NOP here. See super implementation."! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/3/2021 11:06:31' prior: 50591140! - displayBounds - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us. - Integer pixel coordinates!!" - - | answer | - answer _ self basicDisplayBounds. - answer ifNil: [ ^nil ]. - answer hasPositiveExtent ifTrue: [ ^answer ]. - ^self displayFullBounds.! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/24/2020 10:21:33' prior: 50535561! - displayBoundsForHalo - "Answer the rectangle to be used as the inner dimension of my halos. - Allow for showing either bounds or fullBounds, and compensate for the optional bounds rectangle." - - ^ Preferences haloEnclosesFullBounds - ifFalse: [ self displayBounds ] - ifTrue: [ self displayFullBounds ]! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/3/2021 10:52:38' prior: 50591154! - displayBoundsOrBogus - "Never answer nil. A bogus value will trigger a draw operation, and bounds will later be corrected. - Integer pixel coordinates!!" - - ^self basicDisplayBounds ifNil: [ - Rectangle center: (self externalizeToWorld: `0@0`) extent: `2@2` ]! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/3/2021 09:34:43' prior: 50592084! - displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - aRectangle is clipped appropiately if some owner clips us. - See also #displayBoundsUpdateFrom:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - "Use the bounds bound by #drawOn. This method must therefore be called after calling #drawOn:." - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphAfterDraw. - self setProperty: #contour toValue: ( - self wantsContour ifTrue: [ aCanvas contourOfCurrentMorphAfterDrawInto: (self valueOfProperty: #contour) ])]]].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/3/2021 09:37:16' prior: 50576039! - displayBoundsUpdateFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us. - To be called after #postDrawOn:. See also #displayBoundsSetFrom: - This more complicated update is needed because the contour information from #drawOn: was possibly - when drawing submorphs. So, the controur from #drawOn: needs to be retrieved, and updated with the - new contour information from #postDrawOn:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - | oldTop oldBottom | - oldTop _ privateDisplayBounds top max: 0. - oldBottom _ privateDisplayBounds bottom-1. - privateDisplayBounds _ privateDisplayBounds - quickMerge: aCanvas boundingRectOfCurrentMorphAfterDraw. - self wantsContour ifTrue: [ - self setProperty: #contour toValue: - (aCanvas - contourOfCurrentMorphAfterDrawUpdate: (self valueOfProperty: #contour) - oldTop: oldTop - oldBottom: oldBottom)]]]].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/3/2021 10:52:51' prior: 50591165! - displayFullBounds - "Answer a rectangle that completely bounds receiver and submorphs when last drawn - (if the world was to be fully drawn, i.e. only to be used on a Canvas on the full world). - Integer pixel coordinates!!" - - | answer | - answer _ self basicDisplayBounds. - answer ifNil: [ ^nil ]. - (self submorphsMightProtrude and: [self clipsSubmorphsReally not]) ifTrue: [ - self submorphsReverseDo: [ :m | - answer _ answer quickMerge: m displayFullBounds ]]. - ^answer encompassingIntegerRectangle! ! -!KernelMorph methodsFor: 'geometry testing' stamp: 'jmv 8/3/2021 09:30:04' prior: 50591129 overrides: 50575911! - wantsContour - "Kernel morphs don't need contour" - - ^false! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 8/3/2021 11:09:33' prior: 50592748! - grabMorph: aMorph moveUnderHand: moveUnderHand - "Grab the given morph (i.e., add it to this hand and remove it from its current owner). - If moveUnderHand is requested or it seems neccesary anyway, move the grabbed morph under the hand." - - | grabbed positionInHandCoordinates tx bounds | - self releaseMouseFocus. "Break focus" - grabbed _ aMorph. - aMorph owner ifNotNil: [ :o | grabbed _ o aboutToGrab: aMorph ]. - grabbed ifNil: [ ^ self ]. - grabbed _ grabbed aboutToBeGrabbedBy: self. - grabbed ifNil: [ ^ self ]. - - moveUnderHand ifTrue: [ - bounds _ nil. - grabbed isInWorld ifTrue: [ - grabbed displayBounds ifNotNil: [ :r | - bounds _ r translatedBy: grabbed morphPositionInWorld negated ]]. - bounds ifNil: [ bounds _ grabbed findBounds ]. - positionInHandCoordinates _ (bounds center + bounds bottomRight //2) negated. - self grabMorph: grabbed delta: positionInHandCoordinates. - ^self ]. - - positionInHandCoordinates _ (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) - morphPositionInWorld - self morphPositionInWorld. - - tx _ GeometryTransformation identity. - (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) withAllOwnersDo: [ :o | - tx _ o location composedWith: tx ]. - self withAllOwnersReverseDo: [ :o | - tx _ o location inverseTransformation composedWith: tx ]. - self grabMorph: grabbed delta: positionInHandCoordinates. - - grabbed location: tx.! ! -!HaloMorph methodsFor: 'drawing' stamp: 'jmv 8/3/2021 09:59:35' prior: 50579109 overrides: 16899205! - drawOn: aCanvas - - | b | - target ifNil: [^super drawOn: aCanvas]. - - Preferences halosShowCoordinateSystem ifTrue: [ - target displayFullBounds ifNotNil: [ :fb | - aCanvas frameGlobalRect: fb borderWidth: 3 color: `Color black alpha: 0.3`. - b _ target displayBounds. - b = fb ifFalse: [ - aCanvas frameGlobalRect: b borderWidth: 3 color: `Color black alpha: 0.3` ]. - self drawCoordinateSystemOn: aCanvas ]].! ! -!WidgetMorph methodsFor: 'geometry testing' stamp: 'jmv 8/3/2021 09:29:54' prior: 50591135 overrides: 50575911! - wantsContour - "Widget morphs don't need contour" - - ^false! ! -!WindowEdgeAdjustingMorph methodsFor: 'drawing' stamp: 'jmv 8/3/2021 09:54:38' prior: 50579823 overrides: 50503568! - drawOn: aCanvas - - | c | - (owner is: #SystemWindow) ifFalse: [ - ^super drawOn: aCanvas ]. - - c _ owner windowFrameColor. - selector caseOf: { - [ #windowTopLeft: ] -> [ - aCanvas roundTopLeftCornerX: 0 y: 0 length: extent x border: owner borderWidth color: c ]. - [ #windowTopRight: ] -> [ - aCanvas roundTopRightCornerX: 0 y: 0 length: extent x border: owner borderWidth color: c ]. - [ #windowBottomLeft: ] -> [ - aCanvas roundBottomLeftCornerX: 0 y: 0 length: extent x border: owner borderWidth color: c ]. - [ #windowBottomRight: ] -> [ - aCanvas roundBottomRightCornerX: 0 y: 0 length: extent x border: owner borderWidth color: c ]. - } - otherwise: [ - "all the morph is sensitive for horizontal and vertical (i.e. non corner) instances." - aCanvas roundEdge: self morphLocalBounds color: c ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/3/2021 09:48:56' prior: 50591234! - fullUpdateCurrentProtrudingBounds - "Recursively update display bounds, for currentMorph and all submorphs, - but only for those whose bounds may go outside owner bounds." - - | isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - (currentMorph is: #WidgetMorph) - ifTrue: [currentMorph displayBoundsSetFrom: self] - ifFalse: [ - "In these cases, #drawOn: is required to find bounds. - #displayBoundsSetFrom: will use the bounds found by us in these case. - See #displayBoundsSetFrom:" - currentMorph - drawOn: self; - displayBoundsSetFrom: self. - (currentMorph postDrawOn: self) ifTrue: [ - currentMorph displayBoundsUpdateFrom: self ]]. - (currentMorph submorphsMightProtrude and: [currentMorph clipsSubmorphsReally not]) ifTrue: [ - currentMorph submorphsDo: [ :m | - self fullUpdateProtrudingBounds: m ]]].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/3/2021 09:50:14' prior: 50591278! - updateCurrentBounds - "Update display bounds, for currentMorph only." - - | isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - (currentMorph is: #WidgetMorph) - ifTrue: [currentMorph displayBoundsSetFrom: self] - ifFalse: [ - "In these cases, #drawOn: is required to find bounds. - #displayBoundsSetFrom: will use the bounds found by us in these case. - See #displayBoundsSetFrom:" - currentMorph - drawOn: self; - displayBoundsSetFrom: self. - (currentMorph postDrawOn: self) ifTrue: [ - currentMorph displayBoundsUpdateFrom: self ]]].! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 8/3/2021 10:00:12' prior: 50537285! - morph: aMorph isAtPoint: aPoint - aMorph basicDisplayBounds ifNotNil: [ :r | - (r containsPoint: aPoint) ifFalse: [ - ^false ]]. - ^aMorph morphContainsPoint: - (aMorph internalizeFromWorld: aPoint)! ! - -WorldMorph removeSelector: #displayBounds! - -!methodRemoval: WorldMorph #displayBounds stamp: 'Install-4731-MoveUnderHand-displayBounds-displayFullBounds-JuanVuletich-2021Aug03-10h59m-jmv.003.cs.st 8/6/2021 11:44:24'! -displayBounds - ^ 0@0 extent: extent! - -HandMorph removeSelector: #displayBounds! - -!methodRemoval: HandMorph #displayBounds stamp: 'Install-4731-MoveUnderHand-displayBounds-displayFullBounds-JuanVuletich-2021Aug03-10h59m-jmv.003.cs.st 8/6/2021 11:44:24'! -displayBounds - - ^ self world canvas displayBoundsForHand: self! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4731-MoveUnderHand-displayBounds-displayFullBounds-JuanVuletich-2021Aug03-10h59m-jmv.003.cs.st----! - -'From Cuis 5.0 [latest update: #4731] on 4 August 2021 at 9:37:48 am'! -!Morph methodsFor: 'events' stamp: 'jmv 8/4/2021 09:37:23' prior: 16874629! - mouseEnter: evt - "Handle a mouseEnter event, meaning the mouse just entered my bounds with no button pressed. - Note: a Morph must answer true to #handlesMouseOver: in order to receive this message." - - "Allow instances to dynamically use properties for handling common events." - self - valueOfProperty: #mouseEnter: - ifPresentDo: [ :handler | handler value: evt ]! ! -!Morph methodsFor: 'events' stamp: 'jmv 8/4/2021 09:37:07' prior: 50451018! - mouseLeave: evt - "Handle a mouseLeave event, meaning the mouse just left my bounds with no button pressed. - Note: a Morph must answer true to #handlesMouseOver: in order to receive this message." - - Preferences focusFollowsMouse - ifTrue: [evt hand releaseKeyboardFocus: self]. - "Allow instances to dynamically use properties for handling common events." - self - valueOfProperty: #mouseLeave: - ifPresentDo: [ :handler | handler value: evt ].! ! -!IndentingListItemMorph methodsFor: 'events' stamp: 'jmv 8/4/2021 09:35:18' prior: 50463653 overrides: 50593187! - mouseLeave: event - isHighlighted _ false. - self redrawNeeded. - ^super mouseLeave: event! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4732-mouseEnter-mouseLeave-fixAndComments-JuanVuletich-2021Aug04-09h35m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4732] on 4 August 2021 at 5:11:38 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/4/2021 17:02:09' prior: 50592895! - displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - aRectangle is clipped appropiately if some owner clips us. - See also #displayBoundsUpdateFrom:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - "Use the bounds bound by #drawOn. This method must therefore be called after calling #drawOn:." - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphAfterDraw. - self wantsContour ifTrue: [ - (aCanvas - contourOfCurrentMorphAfterDrawInto: (self valueOfProperty: #contour) - into: [ :contourArray :contourY0 :contourY1 | - self setProperty: #contour toValue: contourArray. - self setProperty: #contourY0 toValue: contourY0. - self setProperty: #contourY1 toValue: contourY1. - ]). - ] ifFalse: [ - self setProperty: #contour toValue: nil. - self setProperty: #contourY0 toValue: nil. - self setProperty: #contourY1 toValue: nil. - ]]]].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/4/2021 17:06:52' prior: 50592921! - displayBoundsUpdateFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us. - To be called after #postDrawOn:. See also #displayBoundsSetFrom: - This more complicated update is needed because the contour information from #drawOn: was possibly - when drawing submorphs. So, the controur from #drawOn: needs to be retrieved, and updated with the - new contour information from #postDrawOn:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - | oldContour oldTop oldBottom | - oldContour _ self valueOfProperty: #contour. - oldTop _ self valueOfProperty: #contourY0. - oldBottom _ self valueOfProperty: #contourY1. - privateDisplayBounds _ privateDisplayBounds - quickMerge: aCanvas boundingRectOfCurrentMorphAfterDraw. - self wantsContour ifTrue: [ - (aCanvas - contourOfCurrentMorphAfterDrawUpdate: oldContour - oldTop: oldTop - oldBottom: oldBottom - into: [ :contourArray :contourY0 :contourY1 | - self setProperty: #contour toValue: contourArray. - self setProperty: #contourY0 toValue: contourY0. - self setProperty: #contourY1 toValue: contourY1. - ])]]]].! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 8/4/2021 17:04:08' prior: 50575575! - collides: aMorph - "Answer whether the pixels used by morphs touch at least at one place." - - privateDisplayBounds ifNil: [ - ^false ]. - - "Quick check with display bounds" - (aMorph displayBoundsIntersects: (privateDisplayBounds outsetBy: 1)) ifFalse: [ - ^false ]. - - "Precise check with contour, if available" - (self valueOfProperty: #contour) ifNotNil: [ :contour | | contourTop contourBottom | - contourTop _ self valueOfProperty: #contourY0. - contourBottom _ self valueOfProperty: #contourY1. - ^ aMorph contourIntersects: contour top: contourTop bottom: contourBottom ]. - - "If contour is not available, and both displayBounds overlap, answer true, as it is the best we can know." - ^ true! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 8/4/2021 17:11:18' prior: 50575865! - contourIntersects: aContourArray top: aContourTop bottom: aContourBottom - "Check if contours intersect. - If contour is not available, use displayBounds" - - | contour contourTop contourBottom x0Own x1Own x0Arg x1Arg | - contour _ self valueOfProperty: #contour. - contourTop _ (self valueOfProperty: #contourY0) ifNil: [aContourTop]. - contourBottom _ (self valueOfProperty: #contourY1) ifNil: [aContourBottom]. - - (contourTop max: aContourTop) to: (contourBottom min: aContourBottom) do: [ :y | - x0Own _ contour ifNil: [privateDisplayBounds left] ifNotNil: [ contour at: (y - contourTop) * 2 + 1 ]. - x1Own _ contour ifNil: [privateDisplayBounds right-1] ifNotNil: [ contour at: (y - contourTop) * 2 + 2 ]. - x0Arg _ aContourArray at: (y - aContourTop) * 2 + 1. - x1Arg _ aContourArray at: (y - aContourTop) * 2 + 2. - (x0Own <= x1Arg and: [ x0Arg <= x1Own ]) - ifTrue: [ ^true ]]. - - ^false! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 8/4/2021 17:06:14' prior: 50575666! - isCloserThan: aNumber toPoint: aPoint - "Answer true if our closest point to aPoint is less than aNumber pixels away. - In target surface (i.e. Display) coordinates. - Uses precise testing of the morph contour if available. See #knowsContour." - - | center contourTop contourBottom | - privateDisplayBounds ifNil: [ - ^false ]. - center _ privateDisplayBounds center. - "Quick checks: If not even within aNumber distance to display bounds, fail" - (center y - aPoint y) abs < (privateDisplayBounds height // 2 + aNumber) ifFalse: [ - ^false ]. - (center x - aPoint x) abs < (privateDisplayBounds width // 2 + aNumber) ifFalse: [ - ^false ]. - "Precise check with contour, if available" - (self valueOfProperty: #contour) ifNotNil: [ :contour | | y0 y1 x0 x1 | - contourTop _ self valueOfProperty: #contourY0. - contourBottom _ self valueOfProperty: #contourY1. - "Contour rows to consider are those within requested distance." - y0 _ aPoint y - aNumber max: contourTop. - y1 _ aPoint y + aNumber min: contourBottom. - y0 to: y1 do: [ :y | - x0 _ (contour at: (y - contourTop) * 2 + 1) - aNumber. - x1 _ (contour at: (y - contourTop) * 2 + 2) + aNumber. - "If a vertical line of 2*aNumber height centered on aPoint is inside the contour, quick exit" - (aPoint x between: x0 and: x1) ifTrue: [ ^true ]. - "Check if aPoint is close enough to contour" - (x0@y - aPoint) r < aNumber ifTrue: [ ^true ]. - (x1@y - aPoint) r < aNumber ifTrue: [ ^true ]]. - "Not inside, not close enough to contour" - ^ false ]. - "If contour is not available, and aPoint is close enough to displayBounds, answer true, as it is the best we can know." - ^ true! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4733-ContourAndBoundsFix-JuanVuletich-2021Aug04-16h40m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4733] on 4 August 2021 at 7:01:09 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/4/2021 18:31:09'! - externalizeBoundsToWorld: r - - ^owner - ifNotNil: [ owner externalizeBoundsToWorld: r ] - ifNil: [ r encompassingIntegerRectangle ]! ! -!MovableMorph methodsFor: 'dropping/grabbing' stamp: 'jmv 8/4/2021 18:31:20' overrides: 50593420! - externalizeBoundsToWorld: r - - | inOwners | - inOwners _ location displayBoundsOfTransformOf: r. - ^owner - ifNotNil: [ owner externalizeBoundsToWorld: inOwners ] - ifNil: [ inOwners ]! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 8/4/2021 18:30:34' overrides: 50593428! - externalizeBoundsToWorld: r - - ^ r! ! -!Morph methodsFor: 'change reporting' stamp: 'jmv 8/4/2021 19:00:12' prior: 50557024! - invalidateLocalRect: localRectangle - - self invalidateDisplayRect: (self externalizeBoundsToWorld: localRectangle) for: self.! ! -!PluggableListMorph methodsFor: 'dropping/grabbing' stamp: 'jmv 8/4/2021 18:28:20' prior: 50426283! - acceptDroppingMorph: aMorph atRow: row withEvent: dropEvent - - | args dropActionSelector | - - dropActionSelector _ self valueOfProperty: #dropActionSelector. - args _ dropActionSelector numArgs. - args = 1 ifTrue: [ ^model perform: dropActionSelector with: row]. - args = 2 ifTrue: [ | dropSelectorArgument | - dropSelectorArgument _ aMorph - valueOfProperty: #dropSelectorArgument - ifAbsent: [self error: 'aMorph is missing dropSelectorArgument property']. - ^model perform: dropActionSelector with: row with: dropSelectorArgument ]. - - self error: 'dropActionSelector must be a 1- or 2-keyword symbol' - - ! ! - -MorphicCanvas removeSelector: #externalizeDisplayBounds:from:! - -!methodRemoval: MorphicCanvas #externalizeDisplayBounds:from: stamp: 'Install-4734-Morphic-Cleanup-JuanVuletich-2021Aug04-18h58m-jmv.001.cs.st 8/6/2021 11:44:24'! -externalizeDisplayBounds: r from: aMorph - "r is a Rectangle, expressed in aMorph's coordinate system. - Answer another rectangle, that bounds r when translated to World coordinates" - - "Should translate only to whatever world or PasteUp we are displaying. - Fix when implementing multiple Canvases (Displays) showing different - (potentially nested Worlds)" - | inOwners owner | - self flag: #jmvVer2. - - inOwners _ aMorph location - ifNil: [ r ] - ifNotNil: [ :tx | tx displayBoundsOfTransformOf: r ]. - owner _ aMorph owner. - ^owner - ifNotNil: [ self externalizeDisplayBounds: inOwners from: owner] - ifNil: [ inOwners encompassingIntegerRectangle ]! - -PluggableListMorph removeSelector: #flashRow:! - -!methodRemoval: PluggableListMorph #flashRow: stamp: 'Install-4734-Morphic-Cleanup-JuanVuletich-2021Aug04-18h58m-jmv.001.cs.st 8/6/2021 11:44:24'! -flashRow: aRow - - ^self listMorph flashRow: aRow.! - -InnerListMorph removeSelector: #flashRow:! - -!methodRemoval: InnerListMorph #flashRow: stamp: 'Install-4734-Morphic-Cleanup-JuanVuletich-2021Aug04-18h58m-jmv.001.cs.st 8/6/2021 11:44:24'! -flashRow: aRow - - self world ifNotNil: [ :world | world canvas ifNotNil: [ :canvas | - Display flash: (canvas externalizeDisplayBounds: (self drawBoundsForRow: aRow) from: self) ]]. - -! - -WorldMorph removeSelector: #externalizeDisplayBounds:! - -!methodRemoval: WorldMorph #externalizeDisplayBounds: stamp: 'Install-4734-Morphic-Cleanup-JuanVuletich-2021Aug04-18h58m-jmv.001.cs.st 8/6/2021 11:44:24'! -externalizeDisplayBounds: r - - ^ r! - -MovableMorph removeSelector: #externalizeDisplayBounds:! - -!methodRemoval: MovableMorph #externalizeDisplayBounds: stamp: 'Install-4734-Morphic-Cleanup-JuanVuletich-2021Aug04-18h58m-jmv.001.cs.st 8/6/2021 11:44:24'! -externalizeDisplayBounds: r - - | inOwners | - "All senders of #displayBoundsOfTransformOf: should be rethought..." - self flag: #jmvVer2. - - inOwners _ location displayBoundsOfTransformOf: r. - ^owner - ifNotNil: [ owner externalizeDisplayBounds: inOwners ] - ifNil: [ inOwners ]! - -Morph removeSelector: #externalizeDisplayBounds:! - -!methodRemoval: Morph #externalizeDisplayBounds: stamp: 'Install-4734-Morphic-Cleanup-JuanVuletich-2021Aug04-18h58m-jmv.001.cs.st 8/6/2021 11:44:24'! -externalizeDisplayBounds: r - - "All senders of #displayBoundsOfTransformOf: should be rethought..." - self flag: #jmvVer2. - - ^owner - ifNotNil: [ owner externalizeDisplayBounds: r ] - ifNil: [ r encompassingIntegerRectangle ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4734-Morphic-Cleanup-JuanVuletich-2021Aug04-18h58m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4733] on 4 August 2021 at 7:02:29 pm'! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 8/4/2021 18:35:22' prior: 50556429 overrides: 50575534! - morphExtent: newExtent - "In our own coordinates!!" - - | oldExtent | - extent = newExtent ifFalse: [ - oldExtent _ extent. - (self privateExtent: newExtent) ifTrue: [ - self extentChanged: oldExtent. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]]! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 8/4/2021 18:36:04' prior: 50541827! - morphHeight: aNumber - "In our own coordinates!!" - - self morphExtent: extent x@aNumber! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 8/4/2021 18:35:59' prior: 50541832! - morphWidth: aNumber - "In our own coordinates!!" - - self morphExtent: aNumber@extent y! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/4/2021 18:35:27' prior: 50556470 overrides: 50575534! -morphExtent: newExtent - "In our own coordinates!!" - - | oldExtent | - extent = newExtent ifFalse: [ - oldExtent _ extent. - (self privateExtent: newExtent) ifTrue: [ - self extentChanged: oldExtent. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]]! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/4/2021 18:36:07' prior: 50545963! - morphHeight: aNumber - "In our own coordinates!!" - - self morphExtent: extent x@aNumber! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/4/2021 18:36:01' prior: 50546000! - morphWidth: aNumber - "In our own coordinates!!" - - self morphExtent: aNumber@extent y! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4735-Comments-JuanVuletich-2021Aug04-19h01m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4733] on 4 August 2021 at 7:06:13 pm'! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 8/4/2021 18:46:45' prior: 50554167 overrides: 50575546! -morphPosition: aPoint - "Change the position of this morph. Argument is in owner's coordinates." - - (location isTranslation: aPoint) ifFalse: [ - location _ location withTranslation: aPoint. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ].! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 8/4/2021 18:53:36' prior: 50556442! - morphPosition: newPos extent: newExtent - "Change the position and extent of this morph. Arguments are owner's coordinates." - - self morphPosition: newPos. - self morphExtent: (self internalizeDistance: newExtent).! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 8/4/2021 19:05:09' prior: 50570973! - addHandles: aDisplayRectangle - "update my size. owner is world, therefore owner coordinates are Display coordinates." - - | b | - b _ aDisplayRectangle outsetBy: 30@30. - self morphPosition: b topLeft extent: b extent. - haloBox _ self handlesBox. - target addHandlesTo: self box: haloBox. - self addNameString: (target printStringLimitedTo: 40). - self redrawNeeded.! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/4/2021 18:53:31' prior: 50556483! - morphPosition: newPos extent: newExtent - "Change the position and extent of this morph. Arguments are owner's coordinates." - - self morphPosition: newPos. - self morphExtent: (self internalizeDistance: newExtent).! ! - -WidgetMorph removeSelector: #morphBounds:! - -!methodRemoval: WidgetMorph #morphBounds: stamp: 'Install-4736-Morphic-Cleanup-JuanVuletich-2021Aug04-19h02m-jmv.001.cs.st 8/6/2021 11:44:24'! -morphBounds: aRectangle - self morphPosition: aRectangle topLeft. - self morphExtent: aRectangle extent! - -KernelMorph removeSelector: #morphBounds:! - -!methodRemoval: KernelMorph #morphBounds: stamp: 'Install-4736-Morphic-Cleanup-JuanVuletich-2021Aug04-19h02m-jmv.001.cs.st 8/6/2021 11:44:24'! -morphBounds: aRectangle - self morphPosition: aRectangle topLeft. - self morphExtent: aRectangle extent! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4736-Morphic-Cleanup-JuanVuletich-2021Aug04-19h02m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4736] on 5 August 2021 at 10:36:30 am'! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/5/2021 10:33:19'! - findFullBoundsInOwner - "Find and answer full bounds in whatever owner. - These might not equal #displayFullBounds at all!!" - - "#morphExtent also valid in owner, because no VectorCanvas => no scaling." - ^(self morphPosition extent: self morphExtent) encompassingIntegerRectangle.! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 8/5/2021 09:51:40' prior: 50592985! - grabMorph: aMorph moveUnderHand: moveUnderHand - "Grab the given morph (i.e., add it to this hand and remove it from its current owner). - If moveUnderHand is requested or it seems neccesary anyway, move the grabbed morph under the hand." - - | grabbed positionInHandCoordinates tx bounds | - self releaseMouseFocus. "Break focus" - grabbed _ aMorph. - aMorph owner ifNotNil: [ :o | grabbed _ o aboutToGrab: aMorph ]. - grabbed ifNil: [ ^ self ]. - grabbed _ grabbed aboutToBeGrabbedBy: self. - grabbed ifNil: [ ^ self ]. - - moveUnderHand ifTrue: [ - bounds _ nil. - grabbed isInWorld ifTrue: [ - grabbed displayBounds ifNotNil: [ :r | - bounds _ r translatedBy: grabbed morphPositionInWorld negated ]]. - bounds ifNil: [ bounds _ grabbed findFullBoundsInOwner ]. - positionInHandCoordinates _ (bounds center + bounds bottomRight //2) negated. - self grabMorph: grabbed delta: positionInHandCoordinates. - ^self ]. - - positionInHandCoordinates _ (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) - morphPositionInWorld - self morphPositionInWorld. - - tx _ GeometryTransformation identity. - (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) withAllOwnersDo: [ :o | - tx _ o location composedWith: tx ]. - self withAllOwnersReverseDo: [ :o | - tx _ o location inverseTransformation composedWith: tx ]. - self grabMorph: grabbed delta: positionInHandCoordinates. - - grabbed location: tx.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4737-findFullBoundsInOwner-JuanVuletich-2021Aug05-10h31m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4737] on 5 August 2021 at 12:51:24 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/5/2021 12:26:43'! - morphLocalBoundsForError - "Only to be used for drawing in an error condition. See senders." - - ^`0@0 corner: 75@70`.! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 8/5/2021 12:33:56' overrides: 50554518! - morphExtentInWorld - "World coordinates" - - ^(self externalizeDistanceToWorld: extent) ceiling! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 8/5/2021 12:21:05' overrides: 16875435! - morphLocalBounds - - ^`0@0` extent: extent.! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 8/5/2021 12:26:40' overrides: 50593753! - morphLocalBoundsForError - "Only to be used for drawing in an error condition. See senders." - - ^self morphLocalBounds.! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/5/2021 12:33:59' overrides: 50554518! - morphExtentInWorld - "World coordinates" - - ^(self externalizeDistanceToWorld: extent) ceiling! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/5/2021 12:21:10' overrides: 16875435! - morphLocalBounds - - ^`0@0` extent: extent.! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/5/2021 12:26:47' overrides: 50593753! - morphLocalBoundsForError - "Only to be used for drawing in an error condition. See senders." - - ^self morphLocalBounds.! ! -!WidgetMorph methodsFor: 'layout' stamp: 'jmv 8/5/2021 12:06:55' overrides: 16876050! - minItemWidth - - ^extent x! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 8/5/2021 12:26:13' prior: 50387670! - drawOn: aCanvas - "A canvas is already set with a proper transformation from our coordinates to those of the Canvas target." - - aCanvas - fillRectangle: `-75@-70 corner: 75@70` - color: `Color blue`! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 8/5/2021 12:33:16' prior: 16899245 overrides: 50575540! - morphExtentInWorld: newExtent - "world coordinates" - - self morphExtent: (self internalizeDistanceFromWorld: newExtent).! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 8/5/2021 12:10:08' prior: 50367553 overrides: 16875429! - morphHeight - "In own's coordinates" - - ^ extent y! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 8/5/2021 12:07:26' prior: 50367591 overrides: 16875521! - morphWidth - "In own's coordinates" - - ^ extent x! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 8/5/2021 12:01:46' prior: 50559733! - attachMorphBeside: aMorph - - "Position the given morph beside this hand, then grab it." - - aMorph aboutToBeGrabbedBy: self. - self grabMorph: aMorph delta: extent x@0. -! ! -!WorldMorph methodsFor: 'canvas' stamp: 'jmv 8/5/2021 11:49:46' prior: 50551465! - ensureNonDisplayCanvas - (canvas isNil or: [ - canvas drawsOnDisplay or: [ - (canvas extent ~= extent) or: [ - canvas form depth ~= Display depth]]]) ifTrue: [ - "allocate a new offscreen canvas the size of the window" - self setCanvas: (MorphicCanvas withExtent: extent depth: Display depth)]! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/5/2021 12:33:12' prior: 50545949 overrides: 50575540! - morphExtentInWorld: newExtent - "world coordinates" - - self morphExtent: (self internalizeDistanceFromWorld: newExtent).! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/5/2021 12:10:12' prior: 50545957 overrides: 16875429! - morphHeight - "In own's coordinates" - - ^ extent y! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/5/2021 12:07:31' prior: 50545994 overrides: 16875521! - morphWidth - "In own's coordinates" - - ^ extent x! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 8/5/2021 11:43:29' prior: 50520214! - refreshExtent - "Invariant: my morphExtent >= my minimumExtent" - - self morphExtent: (extent max: self minimumExtent)! ! -!ProgressMorph methodsFor: 'accessing' stamp: 'jmv 8/5/2021 12:02:29' prior: 50523033! - label: aString subLabel: otherString - | label subLabel n | - label _ aString. - subLabel _ otherString. - layoutSpec notNil ifTrue: [ - n _ label size * extent x * 0.95 // (FontFamily defaultFamilyAndPointSize widthOfString: label). - label _ label squeezedTo: n. - n _ subLabel size * extent x * 0.95 // (FontFamily defaultFamilyAndPointSize widthOfString: subLabel). - subLabel _ subLabel squeezedTo: n ]. - self whenUIinSafeState: [ - labelMorph contents: label. - subLabelMorph contents: subLabel. - self updatePositionAndExtent. ]! ! -!ImageMorph methodsFor: 'drawing' stamp: 'jmv 8/5/2021 12:50:40' prior: 50555751 overrides: 50545911! - drawOn: aCanvas - - aCanvas image: image at: borderWidth@borderWidth. - (borderWidth > 0) ifTrue: [ - aCanvas - frameRectangle: (`0@0` extent: extent) - color: borderColor - borderWidth: borderWidth - borderStyleSymbol: #simple ]! ! -!InnerHierarchicalListMorph methodsFor: 'geometry' stamp: 'jmv 8/5/2021 12:12:41' prior: 50503588! - itemFromPoint: aPoint - "Return the list element (morph) at the given point or nil if outside" - | ptY last | - self hasSubmorphs ifFalse: [ ^nil ]. - (aPoint > `0@0` and: [ aPoint < extent ]) ifFalse: [ ^nil ]. - ptY _ aPoint y. - "note: following assumes that submorphs are vertical, non-overlapping, and ordered" - self firstSubmorph morphPosition y > ptY ifTrue: [ ^nil ]. - last _ self lastSubmorph. - last morphPosition y + last morphHeight < ptY ifTrue: [ ^nil ]. - "now use binary search" - ^self - findSubmorphBinary: [ :m | - (m morphPosition y <= ptY and: [ m morphPosition y + m morphHeight >= ptY ]) - ifTrue: [ 0 ] "found" - ifFalse: [ m morphPosition y + (m morphHeight // 2) > ptY ifTrue: [-1] ifFalse: [1]]]! ! -!InnerTextMorph methodsFor: 'drawing' stamp: 'jmv 8/5/2021 12:13:33' prior: 50530769 overrides: 50545911! - drawOn: aCanvas - "Draw the receiver on a canvas" - - false ifTrue: [ self debugDrawLineRectsOn: aCanvas ]. "show line rects for debugging" - - aCanvas - textComposition: self textComposition - bounds: self morphLocalBounds - color: color - selectionColor: (Theme current textHighlightFocused: self hasKeyboardFocus). - - model actualContents isEmpty ifTrue: [ - owner - valueOfProperty: #emptyTextDisplayMessage - ifPresentDo: [ :msg | - aCanvas - drawString: msg - at: `0@0` - font: nil - color: Theme current textEmptyDisplayMessage ]].! ! -!LabelMorph methodsFor: 'drawing' stamp: 'jmv 8/5/2021 12:14:09' prior: 50555166 overrides: 50545911! - drawOn: aCanvas - aCanvas - drawString: (contents ifNil: [ '' ]) - at: borderWidth@borderWidth - font: self fontToUse - color: color. - (borderWidth > 0) ifTrue: [ - aCanvas - frameRectangle: (`0@0` extent: extent) - color: borderColor - borderWidth: borderWidth - borderStyleSymbol: #simple ]! ! -!SystemWindow methodsFor: 'change reporting' stamp: 'jmv 8/5/2021 12:14:44' prior: 50503403! - invalidateTitleArea - - "not really pretty... also invalidating the top border, regardless of it being above or below the title area - (Different themes use various looks, this covers them all)" - self invalidateLocalRect: (`0@0` extent: extent x @ (self labelHeight + borderWidth))! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 8/5/2021 11:48:18' prior: 50384650! - makeMeFullyVisible - - self world morphExtent > `0@0` ifFalse: [^ self]. - - (self morphPosition >= `0@0` and: [ self morphPosition < (self world morphExtent-extent)]) ifTrue: [ - ^ self "OK -- visible"]. - - self morphPosition: (RealEstateAgent initialFrameFor: self initialExtent: self morphExtentInWorld world: self world) topLeft! ! -!SystemWindow methodsFor: 'resizing' stamp: 'jmv 8/5/2021 11:48:34' prior: 50580018! - windowBottomLeft: aPointInOwner - "aPointInOwner is in the owner's coordinate system" - - | delta | - delta _ (self internalize: aPointInOwner) - self morphBottomLeft. - self morphExtent: extent + (delta x negated @ delta y). - self morphPosition: self morphPosition + aPointInOwner - (self externalize: self morphBottomLeft).! ! -!SystemWindow methodsFor: 'resizing' stamp: 'jmv 8/5/2021 11:48:41' prior: 50580089! - windowTopRight: aPointInOwner - "aPointInOwner is in the owner's coordinate system" - - | delta | - delta _ (self internalize: aPointInOwner) - self morphTopRight. - self morphExtent: extent + (delta x @ delta y negated). - self morphPosition: self morphPosition + aPointInOwner - (self externalize: self morphTopRight).! ! -!HoverHelpMorph methodsFor: 'initialization' stamp: 'jmv 8/5/2021 12:08:28' prior: 16853835! - popUpForHand: aHand - "Pop up the receiver as balloon help for the given hand" - - | newPos x y | - (contents isNil or: [ contents isEmpty ]) ifTrue: [ ^self ]. - x _ aHand morphPosition x - 20. - y _ aHand morphPosition y + 20. - x + extent x > aHand world morphWidth ifTrue: [ - x _ aHand world morphWidth - extent x ]. - y + extent y > aHand world morphHeight ifTrue: [ - y _ aHand morphPosition y - extent y - 12 ]. - newPos _ x@y. - aHand world addMorphFront: self position: newPos. - aHand balloonHelp: self! ! -!MenuLineMorph methodsFor: 'drawing' stamp: 'jmv 8/5/2021 12:14:26' prior: 50503710 overrides: 50545911! - drawOn: aCanvas - | baseColor | - baseColor _ owner color. - aCanvas - fillRectangle: (`0@0` corner: extent x @ (extent y / 2)) - color: baseColor twiceDarker. - - aCanvas - fillRectangle: (0 @ (extent y / 2) corner: extent) - color: baseColor twiceLighter! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 8/5/2021 11:44:30' prior: 50535115! - popUpAdjacentTo: rightOrLeftPointInWorld from: sourceItem - "Present this menu at the given point under control of the given hand. - Used mostly for submenus." - - | trialRect | - popUpOwner _ sourceItem. - sourceItem world addMorphFront: self position: rightOrLeftPointInWorld first. - trialRect _ rightOrLeftPointInWorld first extent: extent. - trialRect right > sourceItem world morphWidth ifTrue: [ - self morphPosition: rightOrLeftPointInWorld second - (extent x@0)]. - self fitInWorld.! ! -!MenuMorph methodsFor: 'private' stamp: 'jmv 8/5/2021 11:43:50' prior: 50535134! - fitInWorld - - | delta trialRect | - trialRect _ Rectangle origin: self morphPosition extent: extent. - delta _ trialRect amountToTranslateWithin: owner displayBounds. - self morphPosition: trialRect origin + delta.! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 8/5/2021 12:27:03' prior: 50572447! - drawCurrentAsError - "The morph (or one of its submorphs) had an error in its drawing method." - | r r2 w | - r _ currentMorph morphLocalBoundsForError. - w _ r extent > `50@50` - ifTrue: [ 6 ] - ifFalse: [ 2 ]. - r2 _ r origin corner: r corner-w. - self - frameAndFillRectangle: r - fillColor: `Color red` - borderWidth: w - borderColor: `Color yellow`. - self line: r2 topLeft to: r2 bottomRight width: w color: `Color yellow`. - self line: r2 topRight to: r2 bottomLeft width: w color: `Color yellow`. - currentMorph displayBoundsSetFrom: self.! ! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 8/5/2021 12:18:57' prior: 50570390! - boundingRectOfCurrentMorphFromLocalBounds - "In targetForm coordinates. - Clipped to owner if appropriate. - Only valid for morphs where #morphLocalBounds is known" - - | boundingRect | - boundingRect _ currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds. - ^ clippingMorphDisplayBounds - ifNotNil: [ :ownerClips | boundingRect intersect: ownerClips ] - ifNil: [ boundingRect ]! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 8/5/2021 12:17:34' prior: 50570453 overrides: 50536532! - boundingRectOfCurrentMorphAfterDraw - "In targetForm coordinates. - Clipped to owner if appropriate. - BitBltCanvas doesn't keep track of Morph bounds as it draws them. But it is limited to drawing morphs where - #morphLocalBounds is known. Use it, then." - - | boundingRect | - boundingRect _ currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds. - ^ clippingMorphDisplayBounds - ifNotNil: [ :ownerClips | boundingRect intersect: ownerClips ] - ifNil: [ boundingRect ]! ! - -PasteUpMorph removeSelector: #fontPreferenceChanged! - -!methodRemoval: PasteUpMorph #fontPreferenceChanged stamp: 'Install-4738-Cleanup-JuanVuletich-2021Aug05-12h50m-jmv.001.cs.st 8/6/2021 11:44:24'! -fontPreferenceChanged - self submorphsDo: [ :m | - m morphExtent: (m morphExtent max: m minimumExtent). - m fontPreferenceChanged ]! - -KernelMorph removeSelector: #morphTopLeft! - -!methodRemoval: KernelMorph #morphTopLeft stamp: 'Install-4738-Cleanup-JuanVuletich-2021Aug05-12h50m-jmv.001.cs.st 8/6/2021 11:44:24'! -morphTopLeft - "Our hierarchy occupies a rectangle specified by #morphTopLef and #morphExtent" - ^`0@0`! - -Morph removeSelector: #morphHeight! - -!methodRemoval: Morph #morphHeight stamp: 'Install-4738-Cleanup-JuanVuletich-2021Aug05-12h50m-jmv.001.cs.st 8/6/2021 11:44:24'! -morphHeight - -"Ensure everybody wants owner's coordinates!!" - self flag: #jmvVer2. - ^ self morphExtent y! - -Morph removeSelector: #morphLocalBounds! - -!methodRemoval: Morph #morphLocalBounds stamp: 'Install-4738-Cleanup-JuanVuletich-2021Aug05-12h50m-jmv.001.cs.st 8/6/2021 11:44:24'! -morphLocalBounds - - ^self morphTopLeft extent: self morphExtent! - -Morph removeSelector: #morphContainsPoint:! - -!methodRemoval: Morph #morphContainsPoint: stamp: 'Install-4738-Cleanup-JuanVuletich-2021Aug05-12h50m-jmv.001.cs.st 8/6/2021 11:44:24'! -morphContainsPoint: aLocalPoint - "Not very good. False positives for non-rectangular morphs. - Only useful as a backstop if the Canvas can't do better." - - ^ self morphLocalBounds containsPoint: aLocalPoint! - -Morph removeSelector: #morphExtentInWorld! - -!methodRemoval: Morph #morphExtentInWorld stamp: 'Install-4738-Cleanup-JuanVuletich-2021Aug05-12h50m-jmv.001.cs.st 8/6/2021 11:44:24'! -morphExtentInWorld - "eventually, remove." - self flag: #jmvVer2. - ^(self externalizeDistanceToWorld: self morphExtent) ceiling! - -Morph removeSelector: #inATwoWayScrollPane! - -!methodRemoval: Morph #inATwoWayScrollPane stamp: 'Install-4738-Cleanup-JuanVuletich-2021Aug05-12h50m-jmv.001.cs.st 8/6/2021 11:44:24'! -inATwoWayScrollPane - "Answer a two-way scroll pane that allows the user to scroll the receiver in either direction. It will have permanent scroll bars unless you take some special action." - " - (EllipseMorph new morphExtent: 500@270) inATwoWayScrollPane openInHand - " - - | widget | - self flag: #jmvVer2. - widget _ PluggableScrollPane new. - widget addToScroller: self. - widget morphExtent: (self morphWidth min: 300 max: 100) @ (self morphHeight min: 150 max: 100). - widget setScrollDeltas. - ^widget! - -Morph removeSelector: #morphExtent! - -!methodRemoval: Morph #morphExtent stamp: 'Install-4738-Cleanup-JuanVuletich-2021Aug05-12h50m-jmv.001.cs.st 8/6/2021 11:44:24'! -morphExtent - "In our own coordinates!!" -"Quizas eventualmente borrar este tambien? (no se usa mucho...)" - self flag: #jmvVer2. - ^`150 @ 140`! - -Morph removeSelector: #morphTopLeft! - -!methodRemoval: Morph #morphTopLeft stamp: 'Install-4738-Cleanup-JuanVuletich-2021Aug05-12h50m-jmv.001.cs.st 8/6/2021 11:44:24'! -morphTopLeft - "By default, morphs occupy a rectangle specified by #morphExtent" - ^self morphExtent // 2 negated! - -Morph removeSelector: #morphExtent:! - -!methodRemoval: Morph #morphExtent: stamp: 'Install-4738-Cleanup-JuanVuletich-2021Aug05-12h50m-jmv.001.cs.st 8/6/2021 11:44:24'! -morphExtent: aPoint - "In our own coordinates!! - Ignored by morphs that are not resizeable."! - -Morph removeSelector: #morphExtentInWorld:! - -!methodRemoval: Morph #morphExtentInWorld: stamp: 'Install-4738-Cleanup-JuanVuletich-2021Aug05-12h50m-jmv.001.cs.st 8/6/2021 11:44:24'! -morphExtentInWorld: newExtent - "Argument is in world coordinates. - Ignored by morphs that are not resizeable."! - -Morph removeSelector: #morphWidth! - -!methodRemoval: Morph #morphWidth stamp: 'Install-4738-Cleanup-JuanVuletich-2021Aug05-12h50m-jmv.001.cs.st 8/6/2021 11:44:24'! -morphWidth - -"Ensure everybody wants owner's coordinates!!" - self flag: #jmvVer2. - ^ self morphExtent x! - -Morph removeSelector: #minItemWidth! - -!methodRemoval: Morph #minItemWidth stamp: 'Install-4738-Cleanup-JuanVuletich-2021Aug05-12h50m-jmv.001.cs.st 8/6/2021 11:44:24'! -minItemWidth - ^self morphWidth! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4738-Cleanup-JuanVuletich-2021Aug05-12h50m-jmv.001.cs.st----! - -----SNAPSHOT----(6 August 2021 11:44:27) Cuis5.0-4738-32.image priorSource: 7951174! - -----STARTUP---- (20 August 2021 16:03:37) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4738-32.image! - - -'From Cuis 5.0 [latest update: #4738] on 6 August 2021 at 5:47:36 pm'! -!Workspace class methodsFor: 'instance creation' stamp: 'jmv 8/6/2021 17:46:59' prior: 16945486! - openWorkspace - ^self new - contents: ''; - openLabel: 'Workspace'. -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4739-openWorkspace-returnsTheWorkspace-JuanVuletich-2021Aug06-17h17m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4738] on 7 August 2021 at 3:13:42 pm'! -!Utilities class methodsFor: 'identification' stamp: 'NM 8/7/2021 15:12:44'! - setAuthorName: aStringName initials: aStringInitials - "Set author name and initials programatically." - - AuthorName _ aStringName. - AuthorInitials _ aStringInitials. - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4740-SetAuthorProgramatically-NicolaMingotti-2021Aug07-15h12m-NM.001.cs.st----! - -'From Cuis 5.0 [latest update: #4740] on 7 August 2021 at 5:06:56 pm'! -!Preferences class methodsFor: 'standard queries' stamp: 'NM 8/7/2021 16:46:25'! - askForSaveOnQuit - ^ self - valueOfFlag: #askForSaveOnQuit - ifAbsent: [ true ].! ! -!Preferences class methodsFor: 'themes' stamp: 'NM 8/7/2021 16:37:36' prior: 50449639! - cuisDefaults - self setPreferencesFrom: #( - #(#askForSaveOnQuit true) - #(#balloonHelpEnabled true ) - #(#biggerCursors false ) - #(#browseWithPrettyPrint false ) - #(#caseSensitiveFinds false ) - #(#checkForSlips true ) - #(#cmdDotEnabled true ) - #(#diffsInChangeList true ) - #(#diffsWithPrettyPrint false ) - #(#menuKeyboardControl true ) - #(#optionalButtons true ) - #(#extraDebuggerButtons true ) - #(#subPixelRenderFonts true ) - #(#thoroughSenders true ) - #(#cheapWindowReframe false ) - #(#syntaxHighlightingAsYouType true ) - #(#tapAndHoldEmulatesButton2 true ) - #(#clickGrabsMorphs false ) - #(#syntaxHighlightingAsYouTypeAnsiAssignment false ) - #(#syntaxHighlightingAsYouTypeLeftArrowAssignment false ) - ). - self useMenuIcons.! ! -!TheWorldMenu methodsFor: 'commands' stamp: 'jmv 8/7/2021 17:06:20' prior: 16934631! -quitSession - - | doSaveImage | - doSaveImage _ Preferences askForSaveOnQuit and: [ - self confirm: 'Save the current image before quitting?' orCancel: [^ self]]. - Smalltalk - snapshot: doSaveImage - andQuit: true - clearAllClassState: false! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4741-askForSaveOnQuitPreference-NicolaMingotti-JuanVuletich-2021Aug07-17h04m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4741] on 8 August 2021 at 2:44:21 pm'! -!Number methodsFor: 'converting' stamp: 'jmv 8/8/2021 14:37:24'! - asFloat - ^ self subclassResponsibility.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4742-Number-asFloat-JuanVuletich-2021Aug08-14h37m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4741] on 8 August 2021 at 2:47:31 pm'! -!Inspector methodsFor: 'selecting' stamp: 'jmv 8/8/2021 14:46:53' prior: 50566397! - selectionPrintString - "Returns the current selection as a string" - ^self safelyPrintWith: [ - self selection printTextLimitedTo: self printStringLimit ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4743-StringInspectorFix-JuanVuletich-2021Aug08-14h44m-jmv.001.cs.st----! - -'From Haver 5.0 [latest update: #4743] on 10 August 2021 at 10:32:48 am'! -!TaskbarMorph methodsFor: 'submorphs-add/remove' stamp: 'KLG 8/10/2021 10:29:46' prior: 50432346 overrides: 16876712! - noteNewOwner: aMorph - "I have just been added as a submorph of aMorph" - - super noteNewOwner: aMorph. - aMorph submorphsDo: [ :subMorph | - subMorph isIncludedInTaskbar ifTrue: [ - self addButtonFor: subMorph ] ]. - self notifyDisplayResize! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4744-MakeTaskbarHonorIsIncludedInTaskbarOnCreation-GeraldKlix-2021Aug09-18h30m-KLG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4744] on 10 August 2021 at 10:14:28 am'! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 8/10/2021 10:13:48'! - refreshTaskbarFor: aMorph - - aMorph isIncludedInTaskbar - ifTrue: [ - (self buttonFor: aMorph) ifNil: [self addButtonFor: aMorph ]] - ifFalse: [ self removeButtonFor: aMorph ].! ! -!MenuMorph methodsFor: 'accessing' stamp: 'jmv 8/10/2021 10:10:57' prior: 16866317! - stayUp: aBoolean - - stayUp _ aBoolean. - aBoolean ifTrue: [ self removeStayUpBox ]. - self taskbar ifNotNil: [ :tb | tb refreshTaskbarFor: self ].! ! -!MenuMorph methodsFor: 'testing' stamp: 'jmv 8/10/2021 10:00:57' prior: 50577163 overrides: 50577132! - isIncludedInTaskbar - "Answer true a button for us should be added to any TaskbarMorph." - - ^ stayUp! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4745-IncludePinnedMenusInTaskbar-JuanVuletich-2021Aug10-10h12m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4745] on 10 August 2021 at 10:36:39 am'! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'jmv 8/10/2021 10:35:47' prior: 16923395! - systemInformationString - "Identify software version" - ^ SystemVersion current version, String newLineString, - self lastUpdateString, String newLineString, - 'Running at :', self imageName.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4746-AddImageFullPathTo-AboutThisSystem-JuanVuletich-2021Aug10-10h34m-jmv.001.cs.st----! - -'From Haver 5.0 [latest update: #4743] on 9 August 2021 at 1:42:55 pm'! -!Theme methodsFor: 'widget colors' stamp: 'KLG 8/9/2021 13:39:35'! - hoverHelp - "Answer the hover help morph's background color." - - ^ `Color r: 1.0 g: 1.0 b: 0.7`! ! -!HoverHelpMorph methodsFor: 'initialization' stamp: 'KLG 8/9/2021 13:40:01' prior: 50388537 overrides: 50545898! - defaultColor - - ^ Theme current hoverHelp! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4747-ThemeableHoverHelpBackgroundColor-GeraldKlix-2021Aug09-13h36m-KLG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4746] on 10 August 2021 at 11:01:18 am'! -!BrowserWindow methodsFor: 'keyboard shortcuts' stamp: 'jmv 8/10/2021 11:00:03' overrides: 50469184! - messageListKey: aChar from: view - "Respond to a Command key. I am a model with a code pane, and I also - have a listView that has a list of methods. The view knows how to get - the list and selection." - - | sel | - sel _ model selectedMessageName. - sel - ifNotNil: [ - "The following require a method selection" - aChar == $R ifTrue: [^ self renameSelector]. - aChar == $U ifTrue: [^ self addParameter ]. - aChar == $I ifTrue: [^ self removeParameter ]]. - super messageListKey: aChar from: view! ! -!CodeWindow methodsFor: 'keyboard shortcuts' stamp: 'jmv 8/10/2021 11:00:35' prior: 50469184! - messageListKey: aChar from: view - "Respond to a Command key. I am a model with a code pane, and I also - have a listView that has a list of methods. The view knows how to get - the list and selection." - - | sel class | - aChar == $D ifTrue: [^ model toggleDiffing]. - - sel _ model selectedMessageName. - aChar == $m ifTrue: [ "These next two put up a type in if no message selected" - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllImplementorsOf: to: Smalltalk]. - aChar == $n ifTrue: [ - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllCallsOn: to: Smalltalk]. - - "The following require a class selection" - (class _ model selectedClassOrMetaClass) ifNil: [^ self ]. - aChar == $b ifTrue: [^ BrowserWindow fullOnClass: class selector: sel]. - aChar == $N ifTrue: [^ self browseClassRefs]. - aChar == $i ifTrue: [^ self methodHierarchy]. - aChar == $h ifTrue: [^ self browseHierarchy]. - aChar == $p ifTrue: [^ self browseFullProtocol]. - - sel - ifNotNil: [ - "The following require a method selection" - aChar == $o ifTrue: [^ model fileOutMessage]. - aChar == $c ifTrue: [^ model copySelector]. - aChar == $v ifTrue: [^ self browseVersions]. - aChar == $C ifTrue: [^ model showHomeCategory]. - aChar == $O ifTrue: [^ self openSingleMessageBrowser]. - aChar == $x ifTrue: [^ model removeMessage]. - aChar == $t ifTrue: [^ model runMethodTest]. - aChar == $r ifTrue: [^ model debugMethodTest]] - ifNil: [ - aChar == $R ifTrue: [^ model renameClass]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4748-NoRefactoringsInChangeSorter-JuanVuletich-2021Aug10-11h00m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4748] on 10 August 2021 at 1:47:40 pm'! -!TaskbarMorph methodsFor: 'notifications' stamp: 'jmv 8/10/2021 13:47:11' prior: 50591043 overrides: 50552865! - fontPreferenceChanged - clock font: nil. - self scale: self scale.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4749-TaskbarHeightAdjust-JuanVuletich-2021Aug10-12h35m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4749] on 13 August 2021 at 11:45:30 am'! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 8/13/2021 11:09:34'! - isOrAnyOwnerIsRotated - "True if we or any owner is rotated." - - ^ false! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 8/13/2021 11:26:48'! - knowsOwnLocalBounds - "Meaning that it doesn't need running #drawOn: and #postDrawOn: to explore affected pixels to deduce actual morph bounds. See senders." - - ^false! ! -!MovableMorph methodsFor: 'geometry testing' stamp: 'jmv 8/13/2021 11:17:24' overrides: 50594555! - isOrAnyOwnerIsRotated - "True if we or any owner is rotated. - A zoomed widget will answer false, but a rotated one will answer true (even if only - some owner is rotated). - Note: unrotated SystemWindow answer true, but they implements - #addPossiblyUncoveredAreasIn:to: to take care of rounded corners." - - ^ location doesNotRotate not or: [ owner notNil and: [ owner isOrAnyOwnerIsRotated ]].! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 8/13/2021 11:44:24' overrides: 50593257! - displayBoundsUpdateFrom: aCanvas - "Private for framework use. NOP here. See super implementation. - See also #knowsOwnLocalBounds and #wantsContour."! ! -!KernelMorph methodsFor: 'geometry testing' stamp: 'jmv 8/13/2021 11:26:52' overrides: 50594560! - knowsOwnLocalBounds - "Meaning that it doesn't need running #drawOn: and #postDrawOn: to explore affected pixels to deduce actual morph bounds. See senders." - - ^true! ! -!WidgetMorph methodsFor: 'geometry testing' stamp: 'jmv 8/13/2021 11:26:58' overrides: 50594560! - knowsOwnLocalBounds - "Meaning that it doesn't need running #drawOn: and #postDrawOn: to explore affected pixels to deduce actual morph bounds. See senders." - - ^true! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 8/13/2021 11:14:36' prior: 50539188! - addPossiblyUncoveredAreasIn: aRectangle to: aCollection - "Answer an array of rectangles encompassing those areas in aRectangle not completely - covered by self. - All areas that might possibly be uncovered must be included." - - aCollection add: aRectangle.! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/13/2021 11:41:56' prior: 50593219! - displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - aRectangle is clipped appropiately if some owner clips us. - See also #displayBoundsUpdateFrom:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - self knowsOwnLocalBounds - ifTrue: [ - "A good optimization in many cases. - But for morphs where #drawOn: might not be able to find bounds (InnerTextMorph and LayoutMorph, - for example) this is essential." - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphFromLocalBounds] - ifFalse: [ - "Use the bounds bound by #drawOn. This method must therefore be called after calling #drawOn:." - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphAfterDraw. - self wantsContour - ifTrue: [ - (aCanvas - contourOfCurrentMorphAfterDrawInto: (self valueOfProperty: #contour) - into: [ :contourArray :contourY0 :contourY1 | - self setProperty: #contour toValue: contourArray. - self setProperty: #contourY0 toValue: contourY0. - self setProperty: #contourY1 toValue: contourY1. - ])] - ifFalse: [ - self setProperty: #contour toValue: nil. - self setProperty: #contourY0 toValue: nil. - self setProperty: #contourY1 toValue: nil ]]]]].! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 8/13/2021 10:35:01' prior: 50532139! - requiresVectorCanvas - "True if we use VectorCanvas protocol, or we are rotated or zoomed. - If False, we can be drawn by BitBltCanvas." - - ^true! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 8/13/2021 10:37:25' prior: 50532155! - submorphsMightProtrude - "Answered false by morphs that can guarantee that submorphs, and all morphs in their - submorphs tree, will lie inside their bounds, either 'naturally' (by construction) or by - being clipped by their owner. See #clipsSubmorphs and clipsSubmorphsReally. - Allows for many optimizations to be done." - - ^ true! ! -!KernelMorph methodsFor: 'geometry services' stamp: 'jmv 8/13/2021 10:59:28' prior: 50537261! - morphContainsPoint: aLocalPoint - "Answer true even if aLocalPoint is in a submorph in front of us, as long as it is inside our shape." - - "If not visible, won't contain any point at all." - self visible ifFalse: [ ^false ]. - - "We know our local bounds, and completely fill them." - ^ self morphLocalBounds containsPoint: aLocalPoint! ! -!KernelMorph methodsFor: 'geometry testing' stamp: 'jmv 8/13/2021 10:31:43' prior: 50548089 overrides: 50594670! - requiresVectorCanvas - "Kernel morphs can run with any kind of Canvas" - - ^false! ! -!KernelMorph methodsFor: 'geometry testing' stamp: 'jmv 8/13/2021 10:37:43' prior: 50532186 overrides: 50594678! - submorphsMightProtrude - "Answered false by morphs that can guarantee that submorphs, and all morphs in their - submorphs tree, will lie inside their bounds, either 'naturally' (by construction) or by - being clipped by their owner. See #clipsSubmorphs and clipsSubmorphsReally. - Allows for many optimizations to be done." - - ^ false! ! -!KernelMorph methodsFor: 'geometry testing' stamp: 'jmv 8/13/2021 11:43:48' prior: 50592980 overrides: 50575911! - wantsContour - "Kernel morphs don't need contour. - See also #knowsOwnLocalBounds and senders." - - ^false! ! -!HaloMorph methodsFor: 'geometry testing' stamp: 'jmv 8/13/2021 10:34:48' prior: 50570834 overrides: 50594706! - requiresVectorCanvas - "Prefer VectorGraphics halos and handled for morphs drawn with VectorCanvas." - - target ifNotNil: [ - ^target requiresVectorCanvas ]. - ^false! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/13/2021 11:44:27' prior: 50592849 overrides: 50593257! - displayBoundsUpdateFrom: aCanvas - "Private for framework use. NOP here. See super implementation. - See also #knowsOwnLocalBounds and #wantsContour."! ! -!WidgetMorph methodsFor: 'geometry services' stamp: 'jmv 8/13/2021 10:59:33' prior: 50546029! - morphContainsPoint: aLocalPoint - "Answer true even if aLocalPoint is in a submorph in front of us, as long as it is inside our shape." - - "If not visible, won't contain any point at all." - self visible ifFalse: [ ^false ]. - - "We know our local bounds, and completely fill them." - ^ self morphLocalBounds containsPoint: aLocalPoint! ! -!WidgetMorph methodsFor: 'geometry testing' stamp: 'jmv 8/13/2021 10:34:13' prior: 50577213 overrides: 50594670! - requiresVectorCanvas - "Widgets can usually run with any kind of Canvas, but not if zoomed or rotated. - Note: Subclasses that use VectorGraphics for their drawing should answer true." - - ^ location isPureTranslation not or: [ owner notNil and: [ owner requiresVectorCanvas ]].! ! -!WidgetMorph methodsFor: 'geometry testing' stamp: 'jmv 8/13/2021 10:37:56' prior: 50546072 overrides: 50594678! - submorphsMightProtrude - "Answered false by morphs that can guarantee that submorphs, and all morphs in their - submorphs tree, will lie inside their bounds, either 'naturally' (by construction) or by - being clipped by their owner. See #clipsSubmorphs and clipsSubmorphsReally. - Allows for many optimizations to be done." - - ^ false! ! -!WidgetMorph methodsFor: 'geometry testing' stamp: 'jmv 8/13/2021 11:43:56' prior: 50593049 overrides: 50575911! - wantsContour - "Widget morphs don't need contour. - See also #knowsOwnLocalBounds and senders." - - ^false! ! -!WindowEdgeAdjustingMorph methodsFor: 'adjusting' stamp: 'jmv 8/13/2021 11:13:41' prior: 50591391 overrides: 50591384! - adjustOwnerAt: aGlobalPoint millisecondSinceLast: millisecondSinceLast - - self basicAdjustOwnerAt: aGlobalPoint. - - "If UI is becoming slow or is optimized for slow systems, resize without - showing window contents, but only edges. But don't do it for rotated Windows!!" - (owner isOrAnyOwnerIsRotated not and: [ - Preferences cheapWindowReframe or: [millisecondSinceLast > 200]]) ifTrue: [ - owner displayBounds newRectFrom: [ :f | - self basicAdjustOwnerAt: Sensor mousePoint. - owner morphPosition extent: owner morphExtent ]].! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 8/13/2021 11:13:25' prior: 50591438 overrides: 50594610! -addPossiblyUncoveredAreasIn: aRectangle to: aCollection - "Answer an array of rectangles encompassing those areas in aRectangle not completely - covered by self. These are the areas that might require further drawing (of morphs below us) - All areas that might possibly be uncovered must be included." - - | bounds radius | - self isOrAnyOwnerIsRotated ifTrue: [ - aCollection add: aRectangle. - ^self ]. - - color mightBeTranslucent ifTrue: [ - aCollection add: aRectangle. - ^self ]. - - bounds _ self displayBounds. - bounds ifNil: [ - aCollection add: aRectangle. - ^self ]. - - "Solid rectangle. - This will be the fastest in many cases. So, please disable rounded corners if on slow hardware!!" - Theme current roundWindowCorners ifFalse: [ - aRectangle areasOutside: bounds do: [ :rect | aCollection add: rect ]. - ^self ]. - - "The solid rectangle does not include the corners. - Report a couple of rows (top and bottom) or columns (left and right) as uncovered areas. - We could also try to be more careful and answer each rounded corner... - Right now, report left and right columns as uncovered areas" - radius _ Theme current roundedWindowRadius. - aRectangle areasOutside: (bounds insetBy: radius@0) do: [ :rect | aCollection add: rect ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/13/2021 11:27:25' prior: 50593083! - fullUpdateCurrentProtrudingBounds - "Recursively update display bounds, for currentMorph and all submorphs, - but only for those whose bounds may go outside owner bounds." - - | isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph knowsOwnLocalBounds - ifTrue: [currentMorph displayBoundsSetFrom: self] - ifFalse: [ - "In these cases, #drawOn: is required to find bounds. - #displayBoundsSetFrom: will use the bounds found by us in these case. - See #displayBoundsSetFrom:" - currentMorph - drawOn: self; - displayBoundsSetFrom: self. - (currentMorph postDrawOn: self) ifTrue: [ - currentMorph displayBoundsUpdateFrom: self ]]. - (currentMorph submorphsMightProtrude and: [currentMorph clipsSubmorphsReally not]) ifTrue: [ - currentMorph submorphsDo: [ :m | - self fullUpdateProtrudingBounds: m ]]].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/13/2021 11:27:37' prior: 50593115! - updateCurrentBounds - "Update display bounds, for currentMorph only." - - | isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph knowsOwnLocalBounds - ifTrue: [currentMorph displayBoundsSetFrom: self] - ifFalse: [ - "In these cases, #drawOn: is required to find bounds. - #displayBoundsSetFrom: will use the bounds found by us in these case. - See #displayBoundsSetFrom:" - currentMorph - drawOn: self; - displayBoundsSetFrom: self. - (currentMorph postDrawOn: self) ifTrue: [ - currentMorph displayBoundsUpdateFrom: self ]]].! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 8/13/2021 11:01:03' prior: 50593139! - morph: aMorph isAtPoint: aPoint - - aMorph basicDisplayBounds ifNotNil: [ :r | - (r containsPoint: aPoint) ifFalse: [ - ^false ]]. - "Give morphs with a non-rectangular shape (corner WindowEdgeAdjustingMorphs) - a chance to have a say." - ^ aMorph morphContainsPoint: - (aMorph internalizeFromWorld: aPoint)! ! - -PluggableButtonMorph removeSelector: #isOrthoRectangularMorph! - -!methodRemoval: PluggableButtonMorph #isOrthoRectangularMorph stamp: 'Install-4750-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h32m-jmv.001.cs.st 8/20/2021 16:03:42'! -isOrthoRectangularMorph - "Answer true if I fill my bounds. I.e. I am a rectangle aligned with Display borders and - specified by my #morphExtent. - If true, #morphContainsPoint: can simply check #morphExtent." - ^self isRoundButton not! - -WindowEdgeAdjustingMorph removeSelector: #isOrthoRectangularMorph! - -!methodRemoval: WindowEdgeAdjustingMorph #isOrthoRectangularMorph stamp: 'Install-4750-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h32m-jmv.001.cs.st 8/20/2021 16:03:42'! -isOrthoRectangularMorph - ^false! - -WidgetMorph removeSelector: #displayBoundsSetFrom:! - -!methodRemoval: WidgetMorph #displayBoundsSetFrom: stamp: 'Install-4750-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h32m-jmv.001.cs.st 8/20/2021 16:03:42'! -displayBoundsSetFrom: aCanvas - "Private for framework use. See super implementation." - - "Widgets don't need contour. Additionally, for InnerTextMorph and LayoutMorph, the bounds - can not be deduced from #drawOn: and should be computed from the 'extent' instance variable." - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - "In these cases, #drawOn: might not be able to find bounds (InnerTextMorph and LayoutMorph, for example), - but it is OK to compute them from #morphLocalBounds. This is not true for non-orthoRectangular morphs!!" - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphFromLocalBounds ]]].! - -WidgetMorph removeSelector: #isOrthoRectangularMorph! - -!methodRemoval: WidgetMorph #isOrthoRectangularMorph stamp: 'Install-4750-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h32m-jmv.001.cs.st 8/20/2021 16:03:42'! -isOrthoRectangularMorph - "True if we are of rectangular shape, aligned with local coordinate axes. - Doesn't take into account possible rotation of our or some owner's local coordinates. - Note: SystemWindow answers true, but implements #addPossiblyUncoveredAreasIn:to: to take care of rounded corners." - - ^location doesNotRotate and: [ owner isNil or: [ owner isOrthoRectangularMorph ]].! - -HaloMorph removeSelector: #isOrthoRectangularMorph! - -!methodRemoval: HaloMorph #isOrthoRectangularMorph stamp: 'Install-4750-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h32m-jmv.001.cs.st 8/20/2021 16:03:42'! -isOrthoRectangularMorph - ^false! - -HaloMorph removeSelector: #morphContainsPoint:! - -!methodRemoval: HaloMorph #morphContainsPoint: stamp: 'Install-4750-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h32m-jmv.001.cs.st 8/20/2021 16:03:42'! -morphContainsPoint: aLocalPoint - - "If not visible, won't contain any point at all." - self visible ifFalse: [ ^false ]. - - "We behave as if we were a rectangle. I.e., we want (specifically mouse button) events that happen inside our bounds" - ^ self morphLocalBounds containsPoint: aLocalPoint! - -KernelMorph removeSelector: #isOrthoRectangularMorph! - -!methodRemoval: KernelMorph #isOrthoRectangularMorph stamp: 'Install-4750-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h32m-jmv.001.cs.st 8/20/2021 16:03:42'! -isOrthoRectangularMorph - "True if we are of rectangular shape, aligned with local coordinate axes. - Doesn't take into account possible rotation of our or some owner's local coordinates. - Note: SystemWindow answers true, but implements #addPossiblyUncoveredAreasIn:to: to take care of rounded corners." - - ^true! - -Morph removeSelector: #isOrthoRectangularMorph! - -!methodRemoval: Morph #isOrthoRectangularMorph stamp: 'Install-4750-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h32m-jmv.001.cs.st 8/20/2021 16:03:42'! -isOrthoRectangularMorph - "True if we are of rectangular shape, aligned with local coordinate axes. - Doesn't take into account possible rotation of our or some owner's local coordinates. - Note: SystemWindow answers true, but implements #addPossiblyUncoveredAreasIn:to: to take care of rounded corners." - - ^false! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4750-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h32m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4749] on 11 August 2021 at 8:02:30 pm'! -!MorphicCanvas methodsFor: 'initialization' stamp: 'jmv 8/11/2021 19:55:39'! - initializeWithOrigin: aPoint - - "Set up these only on initialization. - This is safe (wrt walkbacks during world redraw) because a new instance is created - on draw error. See #displayWorldSafely" - currentTransformation _ MorphicTranslation withTranslation: aPoint. - cti _ 1. - transformations - ifNil: [ transformations _ OrderedCollection with: currentTransformation ] - ifNotNil: [ transformations at: cti put: currentTransformation ]. - drawingMorphStack - ifNil: [ drawingMorphStack _ OrderedCollection with: nil ] - ifNotNil: [ drawingMorphStack at: cti put: nil ].! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/11/2021 19:56:00' prior: 50571643! -on: aForm over: aRectangle - "Warning: aForm extent must equal aRectangle extent" - - ^ self subclassToUse basicNew - setForm: aForm preferSubPixelAntiAliasing: false; - initializeWithOrigin: aRectangle topLeft negated.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/11/2021 19:56:06' prior: 50571653! - onForm: aForm - - ^ self subclassToUse basicNew - setForm: aForm preferSubPixelAntiAliasing: false; - initializeWithOrigin: `0@0`.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/11/2021 19:56:12' prior: 50571622! - onFormWithSubPixelAntiAliasing: aForm - - ^ self subclassToUse basicNew - setForm: aForm preferSubPixelAntiAliasing: true; - initializeWithOrigin: `0@0`.! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 8/11/2021 19:58:00' prior: 50571630 overrides: 50571617! - setForm: aForm preferSubPixelAntiAliasing: aBoolean - form _ aForm. - engine _ BitBltCanvasEngine toForm: form. - "Init BitBlt so that the first call to the 'primitiveDisplayString' primitive will not fail" - engine sourceX: 0; width: 0. - self newClipRect: nil.! ! - -MorphicCanvas removeSelector: #initialize! - -MorphicCanvas removeSelector: #setForm:preferSubPixelAntiAliasing:! - -!methodRemoval: MorphicCanvas #setForm:preferSubPixelAntiAliasing: stamp: 'Install-4751-Morphic-refactorAndCleanup-JuanVuletich-2021Aug11-19h29m-jmv.002.cs.st 8/20/2021 16:03:42'! -setForm: aForm preferSubPixelAntiAliasing: aBoolean - form _ aForm.! - -MorphicCanvas removeSelector: #initializeWith:origin:preferSubPixelAntiAliasing:! - -!methodRemoval: MorphicCanvas #initializeWith:origin:preferSubPixelAntiAliasing: stamp: 'Install-4751-Morphic-refactorAndCleanup-JuanVuletich-2021Aug11-19h29m-jmv.002.cs.st 8/20/2021 16:03:42'! -initializeWith: aForm origin: aPoint preferSubPixelAntiAliasing: aBoolean - self initialize. - self setForm: aForm preferSubPixelAntiAliasing: aBoolean. - - "Set up these only on initialization. - This is safe (wrt walkbacks during world redraw) because a new instance is created - on draw error. See #displayWorldSafely" - currentTransformation _ MorphicTranslation withTranslation: aPoint. - cti _ 1. - transformations - ifNil: [ transformations _ OrderedCollection with: currentTransformation ] - ifNotNil: [ transformations at: cti put: currentTransformation ]. - drawingMorphStack - ifNil: [ drawingMorphStack _ OrderedCollection with: nil ] - ifNotNil: [ drawingMorphStack at: cti put: nil ].! - -MorphicCanvas removeSelector: #initializeWith:origin:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4751-Morphic-refactorAndCleanup-JuanVuletich-2021Aug11-19h29m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4750] on 12 August 2021 at 10:36:24 am'! -!MorphicCanvas methodsFor: 'accessing' stamp: 'jmv 8/12/2021 10:35:37'! - boundsFinderCanvas - ^self! ! -!MorphicCanvas class methodsFor: 'services' stamp: 'jmv 8/12/2021 09:46:30' prior: 50579236! - isVectorGraphicsUsedForAllRendering - " - MorphicCanvas isVectorGraphicsUsedForAllRendering - " - ^MorphicCanvas activeSubclass name == #VectorDrawingCanvas! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4752-Morphic-refactorAndCleanup-JuanVuletich-2021Aug12-10h08m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4752] on 13 August 2021 at 12:13:06 pm'! - -MorphicCanvas subclass: #BitBltBoundsFinderCanvas - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #BitBltBoundsFinderCanvas category: #'Morphic-Support' stamp: 'Install-4753-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h49m-jmv.001.cs.st 8/20/2021 16:03:42'! -MorphicCanvas subclass: #BitBltBoundsFinderCanvas - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -MorphicCanvas subclass: #BitBltCanvas - instanceVariableNames: 'boundsFinderCanvas ' - classVariableNames: 'AccessProtect AuxBlitter AuxForm CachedForms ' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #BitBltCanvas category: #'Morphic-Support' stamp: 'Install-4753-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h49m-jmv.001.cs.st 8/20/2021 16:03:42'! -MorphicCanvas subclass: #BitBltCanvas - instanceVariableNames: 'boundsFinderCanvas' - classVariableNames: 'AccessProtect AuxBlitter AuxForm CachedForms' - poolDictionaries: '' - category: 'Morphic-Support'! -!KernelMorph methodsFor: 'testing' stamp: 'jmv 8/12/2021 15:43:53' overrides: 16876981! - is: aSymbol - ^ aSymbol == #KernelMorph or: [ super is: aSymbol ]! ! -!MorphicCanvas methodsFor: 'testing' stamp: 'jmv 8/12/2021 14:47:25'! - isBoundsFinderCanvas - ^false! ! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 8/12/2021 15:46:21' overrides: 50536532! - boundingRectOfCurrentMorphAfterDraw - "In targetForm coordinates. - Clipped to owner if appropriate. - BitBltCanvas doesn't keep track of Morph bounds as it draws them. But it is limited to drawing morphs where - #morphLocalBounds is known. Use it, then." - - | boundingRect | - boundingRect _ currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds. - ^ clippingMorphDisplayBounds - ifNotNil: [ :ownerClips | boundingRect intersect: ownerClips ] - ifNil: [ boundingRect ]! ! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 8/12/2021 15:47:52' overrides: 50590954! - displayBoundsForHand: aHand - - ^ aHand morphPosition-8 extent: aHand morphExtent.! ! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 8/12/2021 15:03:41' overrides: 50592052! - fullAddCurrentRect: addCurrentBounds submorphs: trySubmorphs to: aDamageRecorder - - | invalidateOwns | - invalidateOwns _ false. - addCurrentBounds ifTrue: [ - currentMorph needsRedraw: false. - self updateCurrentBounds. - invalidateOwns _ true ]. - trySubmorphs ifTrue: [ - (currentMorph submorphsMightProtrude and: [currentMorph clipsSubmorphsReally not]) - ifTrue: [ - currentMorph submorphNeedsRedraw: false. - currentMorph submorphsReverseDo: [ :m | - self fullAddRedrawRect: m to: aDamageRecorder ]] - ifFalse: [ - currentMorph fullRedrawNotNeeded. - invalidateOwns _ true ]]. - invalidateOwns ifTrue: [ - aDamageRecorder recordInvalidRect: currentMorph displayBounds for: currentMorph ]! ! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 8/12/2021 15:07:13' overrides: 50537783! - fullAddRedrawRect: aMorph to: aDamageRecorder - | addCurrentBounds trySubmorphs | - aMorph visible ifTrue: [ - addCurrentBounds _ aMorph isRedrawNeeded. - trySubmorphs _ aMorph isSubmorphRedrawNeeded. - (trySubmorphs or: [addCurrentBounds]) ifTrue: [ - self into: aMorph. - self - fullAddCurrentRect: addCurrentBounds - submorphs: trySubmorphs - to: aDamageRecorder. - self outOfMorph - ]]! ! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 8/12/2021 14:38:59' overrides: 50594862! - fullUpdateCurrentProtrudingBounds - "Recursively update display bounds, for currentMorph and all submorphs, - but only for those whose bounds may go outside owner bounds." - - currentMorph displayBoundsSetFrom: self.! ! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 8/12/2021 15:10:54' overrides: 50591266! - fullUpdateProtrudingBounds: aMorph - "Recursively update display bounds, for aMorph and all submorphs, - but only for those whose bounds may go outside owner bounds." - - aMorph visible ifTrue: [ - self into: aMorph. - self fullUpdateCurrentProtrudingBounds. - self outOfMorph ].! ! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 8/12/2021 15:15:58'! - updateBoundsIn: aWorldMorph addDamageTo: aDamageRecorder - - aWorldMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - self updateHandsDisplayBounds: aWorldMorph.! ! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 8/12/2021 15:16:04' overrides: 50591323! - updateHandsDisplayBounds: aWorldMorph - "Update displayBounds for carried morphs if never set. - Useful for new morph, that are created and attached to the hand." - - aWorldMorph handsDo: [ :hand | - hand hasSubmorphs ifTrue: [ - self into: hand. - hand submorphsDo: [ :morph | - morph displayBounds ifNil: [ - self fullUpdateProtrudingBounds: morph ]]. - self outOfMorph ]].! ! -!BitBltBoundsFinderCanvas methodsFor: 'testing' stamp: 'jmv 8/12/2021 14:47:42' overrides: 50595235! - isBoundsFinderCanvas - ^true! ! -!BitBltCanvas methodsFor: 'accessing' stamp: 'jmv 8/12/2021 14:25:05' overrides: 50595177! - boundsFinderCanvas - ^boundsFinderCanvas! ! -!BitBltCanvas methodsFor: 'initialization' stamp: 'jmv 8/12/2021 14:26:28' overrides: 50595066! - initializeWithOrigin: aPoint - - super initializeWithOrigin: aPoint. - boundsFinderCanvas _ BitBltBoundsFinderCanvas new initializeWithOrigin: aPoint.! ! -!BitBltCanvas methodsFor: 'initialization' stamp: 'jmv 8/12/2021 15:26:38' overrides: 50552885! - world: aWorldMorph - super world: aWorldMorph. - boundsFinderCanvas world: aWorldMorph! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/13/2021 11:58:42' prior: 50594621! - displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - aRectangle is clipped appropiately if some owner clips us. - See also #displayBoundsUpdateFrom:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - (aCanvas isBoundsFinderCanvas or: [c canvasToUse == aCanvas]) ifTrue: [ - self knowsOwnLocalBounds - ifTrue: [ - "A good optimization in many cases. - But for morphs where #drawOn: might not be able to find bounds (InnerTextMorph and LayoutMorph, - for example) this is essential." - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphFromLocalBounds] - ifFalse: [ - "Use the bounds bound by #drawOn. This method must therefore be called after calling #drawOn:." - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphAfterDraw. - self wantsContour - ifTrue: [ - (aCanvas - contourOfCurrentMorphAfterDrawInto: (self valueOfProperty: #contour) - into: [ :contourArray :contourY0 :contourY1 | - self setProperty: #contour toValue: contourArray. - self setProperty: #contourY0 toValue: contourY0. - self setProperty: #contourY1 toValue: contourY1. - ])] - ifFalse: [ - self setProperty: #contour toValue: nil. - self setProperty: #contourY0 toValue: nil. - self setProperty: #contourY1 toValue: nil ]]]]].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/12/2021 14:48:41' prior: 50593257! - displayBoundsUpdateFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us. - To be called after #postDrawOn:. See also #displayBoundsSetFrom: - This more complicated update is needed because the contour information from #drawOn: was possibly - when drawing submorphs. So, the controur from #drawOn: needs to be retrieved, and updated with the - new contour information from #postDrawOn:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - (aCanvas isBoundsFinderCanvas or: [c canvasToUse == aCanvas]) ifTrue: [ - | oldContour oldTop oldBottom | - oldContour _ self valueOfProperty: #contour. - oldTop _ self valueOfProperty: #contourY0. - oldBottom _ self valueOfProperty: #contourY1. - privateDisplayBounds _ privateDisplayBounds - quickMerge: aCanvas boundingRectOfCurrentMorphAfterDraw. - self wantsContour ifTrue: [ - (aCanvas - contourOfCurrentMorphAfterDrawUpdate: oldContour - oldTop: oldTop - oldBottom: oldBottom - into: [ :contourArray :contourY0 :contourY1 | - self setProperty: #contour toValue: contourArray. - self setProperty: #contourY0 toValue: contourY0. - self setProperty: #contourY1 toValue: contourY1. - ])]]]].! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 8/12/2021 15:48:36' prior: 50592815 overrides: 50592801! - basicDisplayBounds - - ^ self world canvas boundsFinderCanvas displayBoundsForHand: self! ! -!MorphicCanvas methodsFor: 'accessing' stamp: 'jmv 8/12/2021 15:01:55' prior: 50595177! - boundsFinderCanvas - ^self subclassResponsibility! ! -!MorphicCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 8/12/2021 16:33:24' prior: 50555817! - frameRectangle: aRectangle color: aColor borderWidth: borderWidth borderStyleSymbol: aSymbol - " - (BitBltCanvas onForm: Display) - frameRectangle: (10@10 extent: 300@200) - color: Color green - borderWidth: 10 - borderStyleSymbol: #raised. - Display forceToScreen. - " - - | tlColor brColor | - tlColor _ aColor. - brColor _ aColor. - aSymbol == #raised ifTrue: [ - tlColor _ aColor quiteWhiter. - brColor _ aColor quiteBlacker ]. - - aSymbol == #inset ifTrue: [ - tlColor _ aColor quiteBlacker. - brColor _ aColor quiteWhiter ]. - - self frameRectangle: aRectangle topLeftColor: tlColor bottomRightColor: brColor borderWidth: borderWidth! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/12/2021 15:12:09' prior: 50570596! - drawWorld: aWorldMorph repair: aDamageRecorder - "Redraw the damaged areas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | visibleRootMorphs visibleRootsDamage worldDamage | - "Update #displayBounds for all dirty morphs (marked as such with #redrawNeeded). - Also add the updated bounds to aDamageRecorder, and update bounds of morphs carried by hand." - self boundsFinderCanvas updateBoundsIn: aWorldMorph addDamageTo: aDamageRecorder. - - visibleRootMorphs _ aWorldMorph privateSubmorphs select: [ :m | m visible ]. - visibleRootsDamage _ Array new: visibleRootMorphs size. - - worldDamage _ self computeDamage: aWorldMorph repair: aDamageRecorder - rootMorphs: visibleRootMorphs rootMorphsDamage: visibleRootsDamage. - - self drawWorldBackground: aWorldMorph rects: worldDamage. - - self drawWorld: aWorldMorph - rootMorphs: visibleRootMorphs rootMorphsDamage: visibleRootsDamage - allDamage: worldDamage. - - aDamageRecorder reset. - ^ worldDamage! ! -!BitBltCanvas methodsFor: 'drawing' stamp: 'jmv 8/12/2021 16:30:30' prior: 50545156 overrides: 50463409! - line: pt1 to: pt2 width: wp color: c - - | p1 p2 w | - (wp > 0 and: [ c isTransparent not ]) ifTrue: [ - p1 _ (currentTransformation transform: pt1) rounded. - p2 _ (currentTransformation transform: pt2) rounded. - w _ (currentTransformation externalizeScalar: wp) rounded. - self setPaintColor: c. - engine - width: w; - height: w; - drawFrom: p1 to: p2 ]! ! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 9/30/2014 19:58' prior: 50532720 overrides: 50463419! - image: aForm at: aPoint - "Draw a translucent image using the best available way of representing translucency." - - self image: aForm - at: aPoint - sourceRect: aForm boundingBox! ! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 8/12/2021 16:30:14' prior: 50536298 overrides: 50463424! - image: aForm at: aPoint sourceRect: sourceRect - "Draw a translucent image using the best available way of representing translucency. - Note: This will be fixed in the future." - - | r p | - p _ (currentTransformation transform: aPoint) rounded. - r _ (form depth < 32 or: [ aForm mightBeTranslucent not ]) - ifTrue: [ - "Rule Form paint treats pixels with a value of zero as transparent" - Form paint ] - ifFalse: [ Form blend ]. - engine colorMap: (aForm colormapIfNeededFor: form); fillColor: nil. - engine image: aForm at: p sourceRect: sourceRect rule: r. - (form depth = 32 and: [ aForm depth < 32 ]) ifTrue: [ - "If we blit to 32bpp from one of smaller depth, - it will have zero in the alpha channel (until BitBlt is fixed!!) - This is the same workaround as in #asFormOfDepth:" - engine sourceForm: nil. - engine combinationRule: 40. "fixAlpha:with:" - engine copyBits ]! ! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 1/11/2020 15:19:17' prior: 50532777! - stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor - "Flood this canvas with aColor wherever stencilForm has non-zero pixels" - | p | - p _ (currentTransformation transform: aPoint) rounded. - self setPaintColor: aColor. - engine colorMap: stencilForm maskingMap. - engine stencil: stencilForm - at: p - sourceRect: sourceRect! ! -!BitBltCanvas methodsFor: 'drawing-ovals' stamp: 'jmv 8/12/2021 16:25:55' prior: 50569703 overrides: 50569695! - ellipseCenter: center radius: radiusPointOrNumber borderWidth: mbw borderColor: mbc fillColor: morphFillColor - - | displayRectangle doBorder doFill | - doBorder _ mbw > 0 and: [ mbc isTransparent not]. - doFill _ morphFillColor isTransparent not. - doBorder | doFill ifTrue: [ - displayRectangle _ (currentTransformation externalizeRectangle: (Rectangle center: center extent: radiusPointOrNumber asPoint * 2)) rounded. - "draw the border of the oval" - doBorder ifTrue: [ - self setPaintColor: mbc. - engine frameOval: displayRectangle borderWidth: mbw rounded]. - "fill the inside" - doFill ifTrue: [ - self setPaintColor: morphFillColor. - engine fillOval: (displayRectangle insetBy: mbw rounded) ]]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 3/10/2018 22:06:13' prior: 50532818 overrides: 50463452! - fillRectangle: aRectangle color: aColor - "Fill the given rectangle." - - aColor isTransparent ifFalse: [ - self - frameAndFillRectangle: aRectangle - fillColor: aColor - borderWidth: 0 - borderColor: `Color transparent` ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 8/12/2021 16:28:24' prior: 50592175 overrides: 50463465! - fillRectangle: aRectangle tilingWith: aForm multipliedBy: aColor - "Fill aRectangle with the equivalent of aForm multiplied by aColor - aForm is a kind of advanced stencil, supplying brightness and opacity at each pixel - Similar to #image:multipliedBy:at: - - - (BitBltCanvas onForm: Display) fillRectangle: (10@10 extent: 100@100) tilingWith: (BitBltCanvas verticalGrayGradient: 30 gradientTop: 0.8 gradientBottom: 0.5) multipliedBy: Color red. Display forceToScreen. - " - self class accessProtect critical: [ - self buildAuxWith: aForm multipliedWith: aColor. - "Warning: aForm boundingBox is most likely different from AuxForm boundingBox!!" - self fillRectangle: aRectangle tilingWith: AuxForm sourceRect: aForm boundingBox rule: Form paint ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 8/12/2021 16:29:04' prior: 50545198 overrides: 50463471! - frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor - - | rect bw | - r area = 0 ifTrue: [ ^self ]. - rect _ (currentTransformation externalizeRectangle: r) rounded. - bw _ (currentTransformation externalizeScalar: borderWidth) rounded. - - "draw the border of the rectangle" - borderColor isTransparent ifFalse: [ - self setPaintColor: borderColor. - engine frameRect: rect borderWidth: bw ]. - - "fill the inside" - fillColor isTransparent ifFalse: [ - self setPaintColor: fillColor. - engine fillRect: (rect insetBy: bw) ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 8/12/2021 16:29:27' prior: 50592203 overrides: 50463478! - frameRectangle: r borderWidth: borderWidth color: borderColor - " - (BitBltCanvas onForm: Display) - frameRectangle: (10@10 extent: 300@200) - borderWidth: 20 - color: Color red. - Display forceToScreen - " - | rect bw | - (borderWidth > 0 and: [ borderColor isTransparent not ]) ifTrue: [ - rect _ (currentTransformation externalizeRectangle: r) rounded. - bw _ (currentTransformation externalizeScalar: borderWidth) rounded. - self setPaintColor: borderColor. - engine - frameRect: rect - borderWidth: bw ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 8/12/2021 16:29:33' prior: 50555775! - frameRectangle: aRectangle topLeftColor: tlColor bottomRightColor: brColor borderWidth: borderWidth - " - (BitBltCanvas onForm: Display) - frameRectangle: (10@10 extent: 300@200) - color: Color green - borderWidth: 10 - borderStyleSymbol: #raised. - Display forceToScreen. - " - - | displayRectangle bw | - bw _ (currentTransformation externalizeScalar: borderWidth) rounded. - displayRectangle _ (currentTransformation externalizeRectangle: aRectangle) rounded. - self - frameRectangle: displayRectangle - borderWidth: bw - topLeftColor: tlColor - bottomRightColor: brColor.! ! -!BitBltCanvas methodsFor: 'drawing-roundedRectangles' stamp: 'jmv 8/12/2021 16:30:58' prior: 50592224 overrides: 50463497! - roundRect: aRectangle color: aColor radius: r - " - (BitBltCanvas onForm: Display) roundRect: (10@10 extent: 200@100) color: Color red radius: 10.5. Display forceToScreen. - " - "radius is not scaled properly..." - - "top stripe" - self - image: (self class topLeftCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle topLeft. - self - image: (self class topRightCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle topRight - (r@0). - self fillRectangle: ((aRectangle withHeight: r) insetBy: r@0) color: aColor. - - "center stripe" - self fillRectangle: (aRectangle insetBy: (0 @ r corner: 0 @ r)) color: aColor. - - "bottom stripe" - self - image: (self class bottomLeftCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle bottomLeft - (0@r). - self - image: (self class bottomRightCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle bottomRight - (r@r) . - self fillRectangle: ((aRectangle bottomLeft + (r@r negated)) extent: (aRectangle width - r - r@r)) color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 8/12/2021 16:25:23' prior: 50566661 overrides: 50565947! - drawString: aString from: firstIndex to: lastIndex atBaseline: aPoint font: font color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - - | p1 | - "Don't waste any time if NOP" - lastIndex = 0 ifTrue: [ - ^nil ]. - - p1 _ currentTransformation transform: aPoint rounded. - p1 _ p1 + (0@(0 - (font ascent + font lineGap-1))). - p1 _ p1 rounded. - engine colorMap: nil. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 8/12/2021 16:25:31' prior: 50566682 overrides: 50566634! - drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint font: font color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - | p1 | - p1 _ (currentTransformation transform: aPoint rounded) rounded. - engine colorMap: nil. - - aColor = `Color black` ifFalse: [ | topColor | - topColor _ aColor alphaMixed: 0.25 with: `Color black`. - font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: topColor ]. - aColor = `Color white` ifFalse: [ | bottomColor | - bottomColor _ aColor alphaMixed: 0.22 with: `Color white`. - font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + `0@2` - color: bottomColor ]. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + `0@1` - color: aColor.! ! -!BitBltCanvas methodsFor: 'drawing-windows' stamp: 'jmv 8/12/2021 16:32:25' prior: 50592263! - windowFrame: aRectangle color: aColor radius: r border: bw labelHeight: lh gradientTop: topFactor gradientBottom: bottomFactor insideColor: insideColor - " - BitBltCanvas releaseClassCachedState; releaseClassState. - (BitBltCanvas onForm: Display) windowFrame: (10@10 extent: 200@100) color: Color red radius: 10 border: 5 labelHeight: 25 gradientTop: 1.0 gradientBottom: 0.5 insideColor: Color green. - Display forceToScreen - " - - | bottomColor he tl tr | - "top stripe" - self - image: (self class topLeftCorner: r height: lh gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: aRectangle topLeft. - self - image: (self class topRightCorner: r height: lh gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: aRectangle topRight - (r@0). - self - fillRectangle: ((aRectangle withHeight: lh) insetBy: r@0) - tilingWith: (self class verticalGrayGradient: lh gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor. - - bottomColor _ aColor * bottomFactor. - - "left and right borders" - tl _ aRectangle topLeft + (0@lh). - tr _ aRectangle topRight + (bw negated@lh). - he _ bw@(aRectangle height - lh - r). - self fillRectangle: (tl extent: he) color: bottomColor. - self fillRectangle: (tr extent: he) color: bottomColor. - - "bottom stripe" - self - image: (self class bottomLeftCorner: r height: r gradientTop: 1 gradientBottom: 1 borderWidth: bw) - multipliedBy: bottomColor - at: aRectangle bottomLeft - (0@r). - self - image: (self class bottomRightCorner: r height: r gradientTop: 1 gradientBottom: 1 borderWidth: bw) - multipliedBy: bottomColor - at: aRectangle bottomRight - (r@r) . - self fillRectangle: ((aRectangle bottomLeft + (r@bw negated)) extent: (aRectangle width - r - r@bw)) color: bottomColor. - - "inside" - self fillRectangle: (aRectangle insetBy: (bw@lh corner: bw@bw)) color: insideColor! ! -!BitBltCanvas methodsFor: 'drawing - Global Coordinates' stamp: 'jmv 8/12/2021 16:28:47' prior: 50570889 overrides: 50570861! - frameAndFillGlobalRect: rect fillColor: fillColor borderWidth: borderWidth color: borderColor - " - (BitBltCanvas onForm: Display) - frameAndFillGlobalRect: (10@10 extent: 300@200) - fillColor: Color green - borderWidth: 20 - color: Color red. - Display forceToScreen - " - engine - combinationRule: (borderColor isOpaque ifTrue: [Form paint] ifFalse: [Form blend]); - fillColor: borderColor; - frameRect: rect borderWidth: borderWidth; - combinationRule: (fillColor isOpaque ifTrue: [Form paint] ifFalse: [Form blend]); - fillColor: fillColor; - fillRect: (rect insetBy: borderWidth). - ! ! -!BitBltCanvas methodsFor: 'drawing - Global Coordinates' stamp: 'jmv 8/12/2021 16:29:13' prior: 50570912 overrides: 50570868! - frameGlobalRect: rect borderWidth: borderWidth color: borderColor - " - (BitBltCanvas onForm: Display) - frameGlobalRect: (10@10 extent: 300@200) - borderWidth: 20 - color: Color red. - Display forceToScreen - " - - engine - combinationRule: (borderColor isOpaque ifTrue: [Form paint] ifFalse: [Form blend]); - fillColor: borderColor; - frameRect: rect borderWidth: borderWidth.! ! -!BitBltCanvas methodsFor: 'drawing - Global Coordinates' stamp: 'jmv 8/12/2021 16:29:43' prior: 50571146 overrides: 50571139! - frameReverseGlobalRect: rect borderWidth: borderWidth - " - (BitBltCanvas onForm: Display) - frameReverseGlobalRect: (10@10 extent: 300@200) - borderWidth: 20. - Display forceToScreen - " - engine - sourceForm: nil; - fillColor: `Color gray`; - combinationRule: Form reverse; - frameRect: rect borderWidth: borderWidth! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 1/11/2020 15:19:54' prior: 50541844! - fillRectangle: aRectangle tilingWith: aForm sourceRect: patternBox rule: aCombinationRule - - | displayRectangle additionalOffset clippedEngine targetTopLeft clipOffset ex - targetBox savedMap top left | - - ex _ patternBox extent. - ex x = 0 ifTrue: [ ^self ]. - ex y = 0 ifTrue: [ ^self ]. - displayRectangle _ (currentTransformation externalizeRectangle: aRectangle) rounded. - - "this is a bit of a kludge to get the form to be aligned where I *think* it should be. - something better is needed, but not now" - - additionalOffset _ `0@0`. - clippedEngine _ engine clippedBy: displayRectangle. - targetTopLeft _ clippedEngine clipRect topLeft truncateTo: ex. - clipOffset _ displayRectangle topLeft - targetTopLeft. - additionalOffset _ (clipOffset \\ ex) - ex. - - "do it iteratively" - targetBox _ clippedEngine clipRect. - savedMap _ clippedEngine colorMap. - clippedEngine sourceForm: aForm; - fillColor: nil; - combinationRule: aCombinationRule; - sourceRect: patternBox; - colorMap: (aForm colormapIfNeededFor: clippedEngine destForm). - top _ (targetBox top truncateTo: patternBox height) + additionalOffset y. - left _ (targetBox left truncateTo: patternBox width) + additionalOffset x. - - left to: (targetBox right - 1) by: patternBox width do: [:x | - top to: (targetBox bottom - 1) by: patternBox height do: [:y | - clippedEngine destOrigin: x@y; copyBits]]. - clippedEngine colorMap: savedMap! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 1/14/2020 09:32:10' prior: 50533232 overrides: 50501573! - setClipRect: aRectangle - "In targetForm coordinates" - - super setClipRect: aRectangle. - engine clipRect: aRectangle! ! - -BitBltCanvas removeSelector: #textComposition:bounds:color:selectionColor:! - -!methodRemoval: BitBltCanvas #textComposition:bounds:color:selectionColor: stamp: 'Install-4753-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h49m-jmv.001.cs.st 8/20/2021 16:03:42'! -textComposition: aTextComposition bounds: boundsRect color: c selectionColor: sc - - engine ifNil: [ ^nil ]. - ^super textComposition: aTextComposition bounds: boundsRect color: c selectionColor: sc! - -BitBltCanvas removeSelector: #updatingMorphBoundsDo:! - -!methodRemoval: BitBltCanvas #updatingMorphBoundsDo: stamp: 'Install-4753-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h49m-jmv.001.cs.st 8/20/2021 16:03:42'! -updatingMorphBoundsDo: aBlock - - | prevEngine | - prevEngine _ engine. - [ - engine _ nil. - aBlock value. - ] ensure: [ engine _ prevEngine ]! - -BitBltCanvas removeSelector: #displayBoundsForHand:! - -!methodRemoval: BitBltCanvas #displayBoundsForHand: stamp: 'Install-4753-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h49m-jmv.001.cs.st 8/20/2021 16:03:42'! -displayBoundsForHand: aHand - - ^ aHand morphPosition-8 extent: aHand morphExtent.! - -MorphicCanvas removeSelector: #fullAddRedrawRect:to:! - -!methodRemoval: MorphicCanvas #fullAddRedrawRect:to: stamp: 'Install-4753-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h49m-jmv.001.cs.st 8/20/2021 16:03:42'! -fullAddRedrawRect: aMorph to: aDamageRecorder - | addCurrentBounds trySubmorphs | - aMorph visible ifTrue: [ - addCurrentBounds _ aMorph isRedrawNeeded. - trySubmorphs _ aMorph isSubmorphRedrawNeeded. - (trySubmorphs or: [addCurrentBounds]) ifTrue: [ - self into: aMorph. - self canvasToUse - fullAddCurrentRect: addCurrentBounds - submorphs: trySubmorphs - to: aDamageRecorder. - self outOfMorph - ]]! - -MorphicCanvas removeSelector: #fullUpdateCurrentProtrudingBounds! - -!methodRemoval: MorphicCanvas #fullUpdateCurrentProtrudingBounds stamp: 'Install-4753-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h49m-jmv.001.cs.st 8/20/2021 16:03:42'! -fullUpdateCurrentProtrudingBounds - "Recursively update display bounds, for currentMorph and all submorphs, - but only for those whose bounds may go outside owner bounds." - - | isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph knowsOwnLocalBounds - ifTrue: [currentMorph displayBoundsSetFrom: self] - ifFalse: [ - "In these cases, #drawOn: is required to find bounds. - #displayBoundsSetFrom: will use the bounds found by us in these case. - See #displayBoundsSetFrom:" - currentMorph - drawOn: self; - displayBoundsSetFrom: self. - (currentMorph postDrawOn: self) ifTrue: [ - currentMorph displayBoundsUpdateFrom: self ]]. - (currentMorph submorphsMightProtrude and: [currentMorph clipsSubmorphsReally not]) ifTrue: [ - currentMorph submorphsDo: [ :m | - self fullUpdateProtrudingBounds: m ]]].! - -MorphicCanvas removeSelector: #displayBoundsForHand:! - -!methodRemoval: MorphicCanvas #displayBoundsForHand: stamp: 'Install-4753-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h49m-jmv.001.cs.st 8/20/2021 16:03:42'! -displayBoundsForHand: aHand - - self subclassResponsibility.! - -MorphicCanvas removeSelector: #updatingMorphBoundsDo:! - -!methodRemoval: MorphicCanvas #updatingMorphBoundsDo: stamp: 'Install-4753-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h49m-jmv.001.cs.st 8/20/2021 16:03:42'! -updatingMorphBoundsDo: aBlock - - self subclassResponsibility.! - -MorphicCanvas removeSelector: #updateHandsDisplayBounds:! - -!methodRemoval: MorphicCanvas #updateHandsDisplayBounds: stamp: 'Install-4753-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h49m-jmv.001.cs.st 8/20/2021 16:03:42'! -updateHandsDisplayBounds: aWorldMorph - "Update displayBounds for carried morphs if never set. - Useful for new morph, that are created and attached to the hand." - - aWorldMorph handsDo: [ :hand | - hand hasSubmorphs ifTrue: [ - self into: hand. - hand submorphsDo: [ :morph | - morph displayBounds ifNil: [ - self fullUpdateProtrudingBounds: morph ]]. - self outOfMorph ]]! - -MorphicCanvas removeSelector: #fullAddCurrentRect:submorphs:to:! - -!methodRemoval: MorphicCanvas #fullAddCurrentRect:submorphs:to: stamp: 'Install-4753-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h49m-jmv.001.cs.st 8/20/2021 16:03:42'! -fullAddCurrentRect: addCurrentBounds submorphs: trySubmorphs to: aDamageRecorder - - | invalidateOwns | - invalidateOwns _ false. - addCurrentBounds ifTrue: [ - currentMorph needsRedraw: false. - self updateCurrentBounds. - invalidateOwns _ true ]. - trySubmorphs ifTrue: [ - (currentMorph submorphsMightProtrude and: [currentMorph clipsSubmorphsReally not]) - ifTrue: [ - currentMorph submorphNeedsRedraw: false. - currentMorph submorphsReverseDo: [ :m | - self fullAddRedrawRect: m to: aDamageRecorder ]] - ifFalse: [ - currentMorph fullRedrawNotNeeded. - invalidateOwns _ true ]]. - invalidateOwns ifTrue: [ - aDamageRecorder recordInvalidRect: currentMorph displayBounds for: currentMorph ]! - -MorphicCanvas removeSelector: #fullUpdateProtrudingBounds:! - -!methodRemoval: MorphicCanvas #fullUpdateProtrudingBounds: stamp: 'Install-4753-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h49m-jmv.001.cs.st 8/20/2021 16:03:42'! -fullUpdateProtrudingBounds: aMorph - "Recursively update display bounds, for aMorph and all submorphs, - but only for those whose bounds may go outside owner bounds." - - aMorph visible ifTrue: [ - self into: aMorph. - self canvasToUse fullUpdateCurrentProtrudingBounds. - self outOfMorph ].! - -MorphicCanvas subclass: #BitBltCanvas - instanceVariableNames: 'boundsFinderCanvas' - classVariableNames: 'AccessProtect AuxBlitter AuxForm CachedForms' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #BitBltCanvas category: #'Morphic-Support' stamp: 'Install-4753-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h49m-jmv.001.cs.st 8/20/2021 16:03:42'! -MorphicCanvas subclass: #BitBltCanvas - instanceVariableNames: 'boundsFinderCanvas' - classVariableNames: 'AccessProtect AuxBlitter AuxForm CachedForms' - poolDictionaries: '' - category: 'Morphic-Support'! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -BitBltCanvas allInstancesDo: [ :c | c instVarNamed: 'boundsFinderCanvas' put: (BitBltBoundsFinderCanvas new initializeWithOrigin: 0@0) ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4753-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h49m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4753] on 13 August 2021 at 4:08:28 pm'! -!HaloMorph methodsFor: 'geometry testing' stamp: 'jmv 8/13/2021 16:07:35' overrides: 50594593! -knowsOwnLocalBounds - "HaloMorph is a bit special because of the drawing of the coordinate systems. - In VectorCanvas, with possible rotation, we must answer false, so #drawOn: is taking into accoung in computing bounds. - In BitBltCanvas, #morphLocalBounds (that leaves extra room for coordinate syste) is enough, especially because there is no rotation. - In this case, #morphLocalBounds will be used. BitBltCanvas cannot do anything else!!" - - ^false! ! -!HaloMorph methodsFor: 'geometry' stamp: 'jmv 8/13/2021 15:51:20' overrides: 50593766! - morphLocalBounds - - "Leave some room for coordinate system labels (in BitBltCanvas)" - ^`-65 @ -30` corner: extent! ! -!HaloMorph methodsFor: 'drawing' stamp: 'jmv 8/13/2021 15:51:43' prior: 50593032 overrides: 16899205! - drawOn: aCanvas - - | b | - target ifNil: [^super drawOn: aCanvas]. - "Debugging aid" - "aCanvas - fillRectangle: haloBox - color: (Color red alpha: 0.2). - aCanvas - fillRectangle: self morphLocalBounds - color: (Color gray alpha: 0.4)." - Preferences halosShowCoordinateSystem ifTrue: [ - target displayFullBounds ifNotNil: [ :fb | - aCanvas frameGlobalRect: fb borderWidth: 3 color: `Color black alpha: 0.3`. - b _ target displayBounds. - b = fb ifFalse: [ - aCanvas frameGlobalRect: b borderWidth: 3 color: `Color black alpha: 0.3` ]. - self drawCoordinateSystemOn: aCanvas ]].! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 8/13/2021 15:56:25' prior: 50593639! - addHandles: aDisplayRectangle - "update my size. owner is world, therefore owner coordinates are Display coordinates." - - self morphPosition: aDisplayRectangle topLeft extent: aDisplayRectangle extent. - haloBox _ self handlesBox. - target addHandlesTo: self box: haloBox. - self addNameString: (target printStringLimitedTo: 40). - self redrawNeeded.! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/13/2021 16:06:55' prior: 50594895! - updateCurrentBounds - "Update display bounds, for currentMorph only." - - | isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph displayBoundsSetFrom: self].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4754-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-15h53m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4754] on 13 August 2021 at 5:35:54 pm'! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 8/13/2021 17:13:59' overrides: 50596276! - updateCurrentBounds - "Update display bounds, for currentMorph only." - - currentMorph displayBoundsSetFrom: self.! ! -!Morph methodsFor: 'updating' stamp: 'jmv 8/13/2021 16:54:28' prior: 50559968! - redrawNeeded - "Report that the area occupied by this morph should be redrawn. - Usually because we changed in some way." - - self needsRedraw: true. - self allOwnersDo: [ :m | m submorphNeedsRedraw: true ]. - self invalidateDisplayRect: (self displayBoundsOrBogus outsetBy: 1) for: self. "Due to anti aliasing in VectorCanvas" - (self submorphsMightProtrude and: [self clipsSubmorphsReally not]) ifTrue: [ - self submorphsReverseDo: [ :m | m redrawNeeded ]].! ! -!HaloMorph methodsFor: 'drawing' stamp: 'jmv 8/13/2021 17:29:23' prior: 50579061! - drawCoordinateSystemOn: aCanvas - - | x0 x1 y0 y1 c stepX stepY haloTargetTx prevTx | - haloTargetTx _ MorphicTranslation identity. - target allOwnersReverseDo: [ :o | haloTargetTx _ haloTargetTx composedWith: o location ]. - haloTargetTx _ haloTargetTx composedWith: target location. - - target knowsOwnLocalBounds - ifTrue: [ | r | - r _ target morphLocalBounds. - x0 _ r left. - x1 _ r right. - y0 _ r top. - y1 _ r bottom ] - ifFalse: [ - x0 _ x1 _ y0 _ y1 _ 0. - target displayFullBounds corners collect: [ :pt | | p | - p _ haloTargetTx inverseTransform: pt. - x0 _ x0 min: p x. - x1 _ x1 max: p x. - y0 _ y0 min: p y. - y1 _ y1 max: p y.]]. - x1-x0 < 1000 ifTrue: [ - stepX _ 50. - stepY _ 20 ] - ifFalse: [ - stepX _ 100. - stepY _ 50 ]. - - prevTx _ aCanvas currentTransformation. - aCanvas geometryTransformation: haloTargetTx. - - c _ `Color black alpha: 0.4`. - aCanvas line: x0@0 to: x1@0 width: 2 color: c. - aCanvas line: 0@y0 to: 0@y1 width: 2 color: c. - - (x0 truncateTo: stepX) to: (x1 - stepX truncateTo: stepX) by: stepX do: [ :x | - aCanvas line: x @ -5 to: x @ 5 width: 2 color: c. - aCanvas drawString: x printString atCenterXBaselineY: x @ -10 font: nil color: c ]. - aCanvas drawString: 'x' atCenterX: x1 - 15 @ 0 font: nil color: c. - - (y0 truncateTo: stepY) to: (y1 - stepY truncateTo: stepY) by: stepY do: [ :y | - aCanvas line: -5 @ y to: 5 @ y width: 2 color: c. - aCanvas drawString: y printString, ' ' atWaistRight: -5 @ y font: nil color: c ]. - aCanvas drawString: 'y' atWaistRight: -5 @ (y1 - 20) font: nil color: c. - - aCanvas geometryTransformation: prevTx.! ! -!HaloMorph methodsFor: 'drawing' stamp: 'jmv 8/13/2021 17:29:49' prior: 50596241 overrides: 16899205! - drawOn: aCanvas - - | b | - target ifNil: [^super drawOn: aCanvas]. - "Debugging aid" - "aCanvas - fillRectangle: haloBox - color: (Color red alpha: 0.2). - aCanvas - fillRectangle: self morphLocalBounds - color: (Color gray alpha: 0.4)." - Preferences halosShowCoordinateSystem ifTrue: [ - target displayFullBounds ifNotNil: [ :fb | - aCanvas frameGlobalRect: fb borderWidth: 3 color: `Color black alpha: 0.1`. - b _ target displayBounds. - b = fb ifFalse: [ - aCanvas frameGlobalRect: b borderWidth: 3 color: `Color black alpha: 0.1` ]. - self drawCoordinateSystemOn: aCanvas ]].! ! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 8/13/2021 16:35:14' prior: 50595240 overrides: 50536532! - boundingRectOfCurrentMorphAfterDraw - "In targetForm coordinates. - Clipped to owner if appropriate. - BitBltCanvas doesn't keep track of Morph bounds as it draws them. But it is limited to drawing morphs where - #morphLocalBounds is known. Use it, then." - - ^self boundingRectOfCurrentMorphFromLocalBounds! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 8/13/2021 16:35:23' prior: 50594112 overrides: 50536532! - boundingRectOfCurrentMorphAfterDraw - "In targetForm coordinates. - Clipped to owner if appropriate. - BitBltCanvas doesn't keep track of Morph bounds as it draws them. But it is limited to drawing morphs where - #morphLocalBounds is known. Use it, then." - - ^self boundingRectOfCurrentMorphFromLocalBounds! ! - -MorphicCanvas removeSelector: #updateCurrentBounds! - -!methodRemoval: MorphicCanvas #updateCurrentBounds stamp: 'Install-4755-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-16h54m-jmv.004.cs.st 8/20/2021 16:03:42'! -updateCurrentBounds - "Update display bounds, for currentMorph only." - - | isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph displayBoundsSetFrom: self].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4755-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-16h54m-jmv.004.cs.st----! - -'From Cuis 5.0 [latest update: #4755] on 14 August 2021 at 7:06:16 pm'! -!PluggableListMorphOfMany methodsFor: 'events' stamp: 'jmv 8/14/2021 19:06:08' prior: 50384537 overrides: 50458702! - mouseMove: aMouseMoveEvent localPosition: localEventPosition - "The mouse has moved, as characterized by the event provided. Adjust the scrollbar, and alter the selection as appropriate" - - | oldIndex oldVal row | - row _ (localEventPosition y < 0 and: [ scrollBar scrollValue > 0.0 ]) - ifTrue: [ - scrollBar scrollUp: 1. - "Leave at least one visible item unaffected, for better visual feedback to the user." - (self rowAtLocation: `0@0`) + 2 ] - ifFalse: [ - (localEventPosition y > extent y and: [ scrollBar scrollValue < 1.0 ]) - ifTrue: [ - scrollBar scrollDown: 1. - "Leave at least one visible item unaffected, for better visual feedback to the user." - (self rowAtLocation: 0@extent y) - 3 ] - ifFalse: [ self rowAtLocation: localEventPosition ]]. - row = 0 ifTrue: [ ^ self ]. - - "No change if model is locked" - self owningWindow ifNotNil: [ :w | - w okToChange ifFalse: [^ self]]. - - dragOnOrOff ifNil: [ - "Was not set at mouse down, which means the mouse must have gone down in an area where there was no list item" - dragOnOrOff _ (self listSelectionAt: row) not. - dragStartRow _ row ]. - - "Set meaning for subsequent dragging of selection" - oldIndex _ self getCurrentSelectionIndex. - oldIndex ~= 0 ifTrue: [ oldVal _ self listSelectionAt: oldIndex ]. - - "Set or clear new primary selection (listIndex)" - dragOnOrOff - ifTrue: [ self setSelectionIndex: row ] - ifFalse: [ self setSelectionIndex: 0 ]. - - "Need to restore the old one, due to how model works, and set new one." - oldIndex ~= 0 ifTrue: [ self listSelectionAt: oldIndex put: oldVal ]. - - "Select all in between if drag was too fast" - "self listSelectionAt: row put: dragOnOrOff." - dragStartRow ifNotNil: [ - (row min: dragStartRow) to: (row max: dragStartRow) do: [ :r | - self listSelectionAt: r put: dragOnOrOff ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4756-PluggableListMorphOfMany-fixAgainstMissingMouseDownEvent-JuanVuletich-2021Aug14-19h06m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4756] on 15 August 2021 at 10:20:46 am'! - -MorphicCanvas removeSelector: #image:multipliedBy:at:! - -!methodRemoval: MorphicCanvas #image:multipliedBy:at: stamp: 'Install-4757-cleanup-JuanVuletich-2021Aug15-10h14m-jmv.001.cs.st 8/20/2021 16:03:42'! -image: aForm multipliedBy: aColor at: aPoint - self subclassResponsibility.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4757-cleanup-JuanVuletich-2021Aug15-10h14m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4757] on 15 August 2021 at 6:37:12 pm'! -!BlockClosure methodsFor: 'evaluating' stamp: 'jmv 8/15/2021 18:36:43'! - ifErrorOrHalt: errorHandlerBlock - "Evaluate the block represented by the receiver, and normally return it's value. If an error occurs, the errorHandlerBlock is evaluated, and it's value is instead returned. The errorHandlerBlock must accept zero, one, or two parameters (the error message and the receiver)." - "Examples: - [1 halt] ifErrorOrHalt: [:err :rcvr | 'huh?']. - [1 whatsUpDoc] ifErrorOrHalt: [:err :rcvr | 'huh?']. - [1 / 0] ifErrorOrHalt: [:err :rcvr | - 'ZeroDivide' = err - ifTrue: [Float infinity] - ifFalse: [self error: err]] -" - - ^ self on: Error, Halt do: [ :ex | - errorHandlerBlock valueWithPossibleArgument: ex description and: ex receiver ]! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 8/15/2021 17:30:09' prior: 50568911! - displayWorldSafely - "Update this world's display and keep track of errors during draw methods." - - [self displayWorld] ifErrorOrHalt: [ :err :rcvr | - "Handle a drawing error" - canvas currentMorphDrawingFails. - self setCanvas. - "Install the old error handler, so we can re-raise the error" - rcvr error: err. - ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4758-Handle-halt-in-drawOn-JuanVuletich-2021Aug15-18h35m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4758] on 16 August 2021 at 3:21:11 pm'! -!WidgetMorph methodsFor: 'drawing' stamp: 'jmv 8/16/2021 15:20:50' prior: 50545911 overrides: 50593800! - drawOn: aCanvas - "A canvas is already set with a proper transformation from our coordinates to those of the Canvas target." - - aCanvas - fillRectangle: self morphLocalBounds - color: color - borderWidth: borderWidth - borderStyleSymbol: #simple - baseColorForBorder: borderColor.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4759-commentTweak-JuanVuletich-2021Aug16-15h20m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4759] on 16 August 2021 at 7:59:21 pm'! -!BitBlt methodsFor: 'private' stamp: 'jmv 8/16/2021 19:54:48' prior: 50590773! - copyBitsAgain - "Primitive. See BitBlt|copyBits, also a Primitive. Essential. See Object - documentation whatIsAPrimitive." - - - '#copyBitsAgain failed. Requested BitBlt operation not performed. Call stack follows:' print. - thisContext printStack: 15.! ! -!BitBlt methodsFor: 'private' stamp: 'jmv 8/16/2021 19:55:03' prior: 50577250! - roundVariables - - | maxVal minVal | - '-----------' print. - 'BitBlt >> copyBits failed. Will retry with parameters rounded. Requested parameters are:' print. - {'dest, source, halftone, rule:' . destForm . sourceForm . halftoneForm . combinationRule } print. - {'dest, extent, source, clipOrigin, clipExtent'. destX@destY. width@height. sourceX@sourceY. clipX@clipY. clipWidth@clipHeight } print. - {'colorMap'. colorMap } print. - maxVal _ SmallInteger maxVal. - minVal _ SmallInteger minVal. - destX _ destX asInteger min: maxVal max: minVal. - destY _ destY asInteger min: maxVal max: minVal. - width _ width asInteger min: maxVal max: minVal. - height _ height asInteger min: maxVal max: minVal. - sourceX _ sourceX asInteger min: maxVal max: minVal. - sourceY _ sourceY asInteger min: maxVal max: minVal. - clipX _ clipX asInteger min: maxVal max: minVal. - clipY _ clipY asInteger min: maxVal max: minVal. - clipWidth _ clipWidth asInteger min: maxVal max: minVal. - clipHeight _ clipHeight asInteger min: maxVal max: minVal. -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4760-BitBlt-roundingArgs-tweaks-JuanVuletich-2021Aug16-19h50m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4760] on 17 August 2021 at 10:30:58 am'! -!Morph methodsFor: 'updating' stamp: 'jmv 8/17/2021 09:16:29' prior: 50559290! - invalidateBounds - "Report that the area occupied by this morph and submorphs should be redrawn, - but most likely we are not going to be redrawn on it, or maybe we'll not be fully visible. See senders." - - self displayFullBounds ifNotNil: [ :r | - "outsetBy: 1 due to anti aliasing in VectorCanvas" - self invalidateDisplayRect: (r outsetBy: 1) for: nil ]. -! ! -!Morph methodsFor: 'updating' stamp: 'jmv 8/17/2021 09:16:15' prior: 50596302! - redrawNeeded - "Report that the area occupied by this morph should be redrawn. - Usually because we changed in some way." - - self needsRedraw: true. - self allOwnersDo: [ :m | m submorphNeedsRedraw: true ]. - "outsetBy: 1 due to anti aliasing in VectorCanvas" - self invalidateDisplayRect: (self displayBoundsOrBogus outsetBy: 1) for: self. - (self submorphsMightProtrude and: [self clipsSubmorphsReally not]) ifTrue: [ - self submorphsReverseDo: [ :m | m redrawNeeded ]].! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 8/17/2021 10:06:42' prior: 50594076! - drawCurrentAsError - "The morph (or one of its submorphs) had an error in its drawing method." - | r w | - r _ currentMorph morphLocalBoundsForError. - w _ r extent > `50@50` - ifTrue: [ 6 ] - ifFalse: [ 2 ]. - self - frameAndFillRectangle: r - fillColor: `Color red` - borderWidth: w - borderColor: `Color yellow`. - self line: r topLeft-0.5 to: r bottomRight-0.5 width: w color: `Color yellow`. - self line: r topRight-0.5 to: r bottomLeft-0.5 width: w color: `Color yellow`. - currentMorph displayBoundsSetFrom: self.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4761-MorphicInvalidationTweaks-JuanVuletich-2021Aug17-10h30m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4761] on 17 August 2021 at 3:53:26 pm'! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/17/2021 14:44:25'! - onFormWithWholePixelAntiAliasing: aForm - - ^ self subclassToUse basicNew - setForm: aForm subPixelAntiAliasing: false; - initializeWithOrigin: `0@0`.! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 8/17/2021 14:43:35'! - setForm: aForm subPixelAntiAliasing: aBooleanOrNil - "nil means use default kind of anti aliasing" - - form _ aForm. - engine _ BitBltCanvasEngine toForm: form. - "Init BitBlt so that the first call to the 'primitiveDisplayString' primitive will not fail" - engine sourceX: 0; width: 0. - self newClipRect: nil.! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/17/2021 14:31:13' prior: 50595378! - displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Clipped appropiately if some owner clips us. - See also #displayBoundsUpdateFrom:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - (aCanvas isBoundsFinderCanvas or: [c canvasToUse == aCanvas]) ifTrue: [ - self knowsOwnLocalBounds - ifTrue: [ - "A good optimization in many cases. - But for morphs where #drawOn: might not be able to find bounds (InnerTextMorph and LayoutMorph, - for example) this is essential." - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphFromLocalBounds] - ifFalse: [ - "Use the bounds bound by #drawOn. This method must therefore be called after calling #drawOn:." - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphAfterDraw. - self wantsContour - ifTrue: [ - (aCanvas - contourOfCurrentMorphAfterDrawInto: (self valueOfProperty: #contour) - into: [ :contourArray :contourY0 :contourY1 | - self setProperty: #contour toValue: contourArray. - self setProperty: #contourY0 toValue: contourY0. - self setProperty: #contourY1 toValue: contourY1. - ])] - ifFalse: [ - self setProperty: #contour toValue: nil. - self setProperty: #contourY0 toValue: nil. - self setProperty: #contourY1 toValue: nil ]]]]].! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 8/17/2021 15:03:24' prior: 50569407! - containsGlobalPoint: worldPoint - "Answer true if pixel worldPoint is covered by us, and we are visible a it. - No other morph above us also covers it." - - self visible ifTrue: [ - self topmostWorld ifNotNil: [ :w | - w canvas ifNotNil: [ :canvas | - ^ canvas morph: self isAtPoint: worldPoint ]]]. - ^ false! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/17/2021 14:43:50' prior: 50595087! - on: aForm over: aRectangle - "Warning: aForm extent must equal aRectangle extent" - - ^ self subclassToUse basicNew - setForm: aForm subPixelAntiAliasing: nil; - initializeWithOrigin: aRectangle topLeft negated.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/17/2021 14:43:57' prior: 50595098! - onForm: aForm - - ^ self subclassToUse basicNew - setForm: aForm subPixelAntiAliasing: nil; - initializeWithOrigin: `0@0`.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/17/2021 14:44:02' prior: 50595106! - onFormWithSubPixelAntiAliasing: aForm - - ^ self subclassToUse basicNew - setForm: aForm subPixelAntiAliasing: true; - initializeWithOrigin: `0@0`.! ! - -BitBltCanvas removeSelector: #setForm:preferSubPixelAntiAliasing:! - -!methodRemoval: BitBltCanvas #setForm:preferSubPixelAntiAliasing: stamp: 'Install-4762-Morphic-refactor-JuanVuletich-2021Aug17-15h51m-jmv.001.cs.st 8/20/2021 16:03:42'! -setForm: aForm preferSubPixelAntiAliasing: aBoolean - form _ aForm. - engine _ BitBltCanvasEngine toForm: form. - "Init BitBlt so that the first call to the 'primitiveDisplayString' primitive will not fail" - engine sourceX: 0; width: 0. - self newClipRect: nil.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4762-Morphic-refactor-JuanVuletich-2021Aug17-15h51m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4762] on 17 August 2021 at 4:09:44 pm'! -!Morph methodsFor: 'updating' stamp: 'jmv 8/17/2021 16:08:53' prior: 50596661! - redrawNeeded - "Report that the area occupied by this morph should be redrawn. - Usually because we changed in some way." - - self needsRedraw: true. - self allOwnersDo: [ :m | m submorphNeedsRedraw: true ]. - "outsetBy: 1 due to anti aliasing in VectorCanvas" - self invalidateDisplayRect: (self displayBoundsOrBogus outsetBy: 1) for: self. - (self submorphsMightProtrude and: [self clipsSubmorphsReally not]) ifTrue: [ - self submorphsReverseDo: [ :m | m redrawNeeded ]]. - self removeProperty: #shadow.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4763-ClearShadowIfAppropriate-JuanVuletich-2021Aug17-15h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4763] on 18 August 2021 at 11:56:50 am'! -!Morph methodsFor: 'private' stamp: 'jmv 8/18/2021 10:21:10'! - privateLocation: aGeometryTransformation! ! -!MovableMorph methodsFor: 'private' stamp: 'jmv 8/18/2021 10:21:31' overrides: 50596863! - privateLocation: aGeometryTransformation - location _ aGeometryTransformation.! ! -!MorphicCanvas methodsFor: 'initialization' stamp: 'jmv 8/18/2021 11:42:50'! - initializeWithTranslation: aPoint - - "Set up these only on initialization. - This is safe (wrt walkbacks during world redraw) because a new instance is created - on draw error. See #displayWorldSafely" - currentTransformation _ MorphicTranslation withTranslation: aPoint. - cti _ 1. - transformations - ifNil: [ transformations _ OrderedCollection with: currentTransformation ] - ifNotNil: [ transformations at: cti put: currentTransformation ]. - drawingMorphStack - ifNil: [ drawingMorphStack _ OrderedCollection with: nil ] - ifNotNil: [ drawingMorphStack at: cti put: nil ].! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/18/2021 11:43:12'! - onForm: aForm over: aRectangle - "Warning: aForm extent must equal aRectangle extent" - - ^ self subclassToUse basicNew - setForm: aForm subPixelAntiAliasing: nil; - initializeWithTranslation: aRectangle topLeft negated.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/18/2021 11:45:55'! - onForm: aForm translation: aPoint - - ^ self subclassToUse basicNew - setForm: aForm subPixelAntiAliasing: nil; - initializeWithTranslation: aPoint.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/18/2021 11:47:19'! - onFormWithSubPixelAntiAliasing: aForm translation: aPoint - - ^ self subclassToUse basicNew - setForm: aForm subPixelAntiAliasing: true; - initializeWithTranslation: aPoint.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/18/2021 11:47:27'! - onFormWithWholePixelAntiAliasing: aForm translation: aPoint - - ^ self subclassToUse basicNew - setForm: aForm subPixelAntiAliasing: false; - initializeWithTranslation: aPoint.! ! -!BitBltCanvas methodsFor: 'initialization' stamp: 'jmv 8/18/2021 11:42:39' overrides: 50596873! - initializeWithTranslation: aPoint - - super initializeWithTranslation: aPoint. - boundsFinderCanvas _ BitBltBoundsFinderCanvas new initializeWithTranslation: aPoint.! ! -!CharacterScanner methodsFor: 'scanning' stamp: 'jmv 8/18/2021 11:18:46' prior: 16802000! -placeEmbeddedObject: anchoredFormOrMorph - "Place the anchoredMorph or return false if it cannot be placed. - In any event, advance destX by its width." - - | w | - w _ (anchoredFormOrMorph is: #Morph) - ifTrue: [ anchoredFormOrMorph fullBoundsInOwner width ] - ifFalse: [ anchoredFormOrMorph width ]. - destX _ destX + w. - (destX > rightMargin and: [ lastIndex ~= line first ]) - "Won't fit, but not at start of a line. Start a new line with it" - ifTrue: [ ^ false]. - lastIndex _ lastIndex + 1. - ^ true! ! -!CharacterBlockScanner methodsFor: 'scanning' stamp: 'jmv 8/18/2021 11:18:52' prior: 16801911 overrides: 50596938! - placeEmbeddedObject: anchoredFormOrMorph - - (super placeEmbeddedObject: anchoredFormOrMorph) ifFalse: [^ false]. - specialWidth _ (anchoredFormOrMorph is: #Morph) - ifTrue: [ anchoredFormOrMorph fullBoundsInOwner width ] - ifFalse: [ anchoredFormOrMorph width ]. - ^ true! ! -!CompositionScanner methodsFor: 'stop conditions' stamp: 'jmv 8/18/2021 11:18:58' prior: 16823045 overrides: 50596938! - placeEmbeddedObject: anchoredFormOrMorph - | descent h | - - (super placeEmbeddedObject: anchoredFormOrMorph) ifFalse: [ - line stop: lastIndex-1. - ^ false]. - descent _ lineHeight - baseline. - h _ (anchoredFormOrMorph is: #Morph) - ifTrue: [ anchoredFormOrMorph fullBoundsInOwner height ] - ifFalse: [ anchoredFormOrMorph height ]. - baseline _ baseline max: h. - lineHeight _ baseline + descent. - line stop: lastIndex. - ^ true! ! -!MorphicScanner methodsFor: 'scanning' stamp: 'jmv 8/18/2021 11:19:24' prior: 50449788 overrides: 50596938! - placeEmbeddedObject: anchoredFormOrMorph - - (super placeEmbeddedObject: anchoredFormOrMorph) ifFalse: [^ false]. - (anchoredFormOrMorph is: #Morph) - ifTrue: [ - anchoredFormOrMorph morphPosition: - (destX@ (lineY+line baseline)) + (anchoredFormOrMorph morphPosition-anchoredFormOrMorph fullBoundsInOwner corner) rounded. - anchoredFormOrMorph show. - canvas fullDraw: anchoredFormOrMorph ] - ifFalse: [ - destY _ lineY. - canvas - image: anchoredFormOrMorph - at: destX - anchoredFormOrMorph width @ (destY + line baseline - anchoredFormOrMorph height) ]. - ^ true! ! -!Morph methodsFor: 'updating' stamp: 'jmv 8/18/2021 11:35:21' prior: 50596837! - redrawNeeded - "Report that the area occupied by this morph should be redrawn. - Usually because we changed in some way." - - self needsRedraw: true. - self allOwnersDo: [ :m | m submorphNeedsRedraw: true ]. - "outsetBy: 1 due to anti aliasing in VectorCanvas" - self invalidateDisplayRect: (self displayBoundsOrBogus outsetBy: 1) for: self. - (self submorphsMightProtrude and: [self clipsSubmorphsReally not]) ifTrue: [ - self submorphsReverseDo: [ :m | m redrawNeeded ]]. - self removeProperty: #bitMask. - self removeProperty: #fullBoundsInOwner.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/18/2021 11:45:10' prior: 16877726! - depth: depth over: aRectangle - - ^self onForm: (Form extent: aRectangle extent depth: depth) translation: aRectangle topLeft negated.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/18/2021 11:48:01' prior: 50596799! - onForm: aForm - - ^ self onForm: aForm translation: `0@0`.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/18/2021 11:48:27' prior: 50596807! - onFormWithSubPixelAntiAliasing: aForm - - ^ self onFormWithSubPixelAntiAliasing: aForm translation: `0@0`.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/18/2021 11:48:09' prior: 50596706! - onFormWithWholePixelAntiAliasing: aForm - - ^ self onFormWithWholePixelAntiAliasing: aForm translation: `0@0`.! ! - -BitBltCanvas removeSelector: #initializeWithOrigin:! - -!methodRemoval: BitBltCanvas #initializeWithOrigin: stamp: 'Install-4764-Morphic-Refactor-JuanVuletich-2021Aug18-11h54m-jmv.001.cs.st 8/20/2021 16:03:42'! -initializeWithOrigin: aPoint - - super initializeWithOrigin: aPoint. - boundsFinderCanvas _ BitBltBoundsFinderCanvas new initializeWithOrigin: aPoint.! - -MorphicCanvas class removeSelector: #on:over:! - -!methodRemoval: MorphicCanvas class #on:over: stamp: 'Install-4764-Morphic-Refactor-JuanVuletich-2021Aug18-11h54m-jmv.001.cs.st 8/20/2021 16:03:42'! -on: aForm over: aRectangle - "Warning: aForm extent must equal aRectangle extent" - - ^ self subclassToUse basicNew - setForm: aForm subPixelAntiAliasing: nil; - initializeWithOrigin: aRectangle topLeft negated.! - -MorphicCanvas removeSelector: #initializeWithOrigin:! - -!methodRemoval: MorphicCanvas #initializeWithOrigin: stamp: 'Install-4764-Morphic-Refactor-JuanVuletich-2021Aug18-11h54m-jmv.001.cs.st 8/20/2021 16:03:42'! -initializeWithOrigin: aPoint - - "Set up these only on initialization. - This is safe (wrt walkbacks during world redraw) because a new instance is created - on draw error. See #displayWorldSafely" - currentTransformation _ MorphicTranslation withTranslation: aPoint. - cti _ 1. - transformations - ifNil: [ transformations _ OrderedCollection with: currentTransformation ] - ifNotNil: [ transformations at: cti put: currentTransformation ]. - drawingMorphStack - ifNil: [ drawingMorphStack _ OrderedCollection with: nil ] - ifNotNil: [ drawingMorphStack at: cti put: nil ].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4764-Morphic-Refactor-JuanVuletich-2021Aug18-11h54m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4764] on 18 August 2021 at 12:12:53 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/18/2021 12:12:18'! - fullBoundsInOwner - "Answer fullBoundsInOwner. Cache the found bounds." - - (self valueOfProperty: #fullBoundsInOwner) ifNotNil: [ :fullBoundsInOwner | - ^fullBoundsInOwner ]. - - ^self setProperty: #fullBoundsInOwner toValue: self findFullBoundsInOwner.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4765-cached-fullBoundsInOwner-JuanVuletich-2021Aug18-12h12m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4765] on 18 August 2021 at 12:19:30 pm'! -!PseudoClass methodsFor: 'testing method dictionary' stamp: 'jmv 8/18/2021 10:11:36'! - canUnderstand: selector - "Answer whether the receiver can respond to the message whose selector - is the argument. The selector can be in the method dictionary of the - receiver's class or any of its superclasses." - - (self includesSelector: selector) ifTrue: [^true]. - self exists ifTrue: [ - ^self realClass canUnderstand: selector ]. - ^false! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4766-CodeFileBrowser-fix-JuanVuletich-2021Aug18-12h18m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4766] on 18 August 2021 at 12:29:42 pm'! -!MessageSet methodsFor: 'message list' stamp: 'jmv 8/18/2021 10:00:10'! - sortByClassHierarchy - "Sort the message-list by class / selector. List classes in hierarchical order." - - | aClass bClass classes classesAndPositions i | - - classes _ Set new. - messageList do: [ :methodReference | - methodReference actualClass ifNotNil: [ :actualClass | classes add: actualClass ]]. - classesAndPositions _ Dictionary new. - i _ 1. - Smalltalk hierarchySorted: classes do: [ :each | - classesAndPositions at: each put: i. - i _ i + 1 ]. - - messageList _ messageList sort: [ :a :b | - (a classSymbol = b classSymbol and: [ b classIsMeta = b classIsMeta ]) - ifTrue: [ - a methodSymbol == #Comment - ifTrue: [ true ] - ifFalse: [ - b methodSymbol == #Comment - ifTrue: [ false ] - ifFalse: [ a methodSymbol < b methodSymbol ]]] - ifFalse: [ - aClass _ a actualClass. - bClass _ b actualClass. - aClass isNil == bClass isNil - ifTrue: [ - aClass isNil - ifTrue: [a classSymbol < b classSymbol] - ifFalse: [(classesAndPositions at: aClass) < (classesAndPositions at: bClass)]] - ifFalse: [aClass isNil]]]. - messageList do: [ :each | each removeStringVersionPrefix ]. - self changed: #messageList.! ! -!MessageSet methodsFor: 'message list' stamp: 'jmv 8/18/2021 10:00:04'! - sortByClassName - "Sort the message-list by class / selector" - - messageList _ messageList sort: [ :a :b | - a classSymbol = b classSymbol - ifTrue: [ - a methodSymbol == #Comment - ifTrue: [ true ] - ifFalse: [ - b methodSymbol == #Comment - ifTrue: [ false ] - ifFalse: [ - a classIsMeta = b classIsMeta - ifTrue: [ a methodSymbol < b methodSymbol ] - ifFalse: [ a classIsMeta ] ]]] - ifFalse: [ a classSymbol < b classSymbol ] - ]. - messageList do: [ :each | each removeStringVersionPrefix ]. - self changed: #messageList! ! -!MessageSetWindow methodsFor: 'menu building' stamp: 'jmv 8/18/2021 10:01:05' prior: 50592684 overrides: 50403936! - addExtraMenu2ItemsTo: options - "The shifted selector-list menu is being built. Add items specific to MessageSet" - - model growable ifTrue: [ - options add: `{ - #itemGroup -> 40. - #itemOrder -> 31. - #label -> 'remove from this browser'. - #object -> #model. - #selector -> #removeMessageFromBrowser. - #icon -> #listRemoveIcon - } asDictionary`. - options add:`{ - #itemGroup -> 40. - #itemOrder -> 32. - #label -> 'filter message list...'. - #selector -> #filterMessageList. - #icon -> #findIcon - } asDictionary` ]. - - options add: `{ - #itemGroup -> 41. - #itemOrder -> 33. - #label -> 'sort by class hierarchy'. - #object -> #model. - #selector -> #sortByClassHierarchy. - #icon -> #classIcon - } asDictionary`. - options add: `{ - #itemGroup -> 41. - #itemOrder -> 34. - #label -> 'sort by class name'. - #object -> #model. - #selector -> #sortByClassName. - #icon -> #classIcon - } asDictionary`. - options add: `{ - #itemGroup -> 41. - #itemOrder -> 35. - #label -> 'sort by selector'. - #object -> #model. - #selector -> #sortBySelector. - #icon -> #scriptIcon - } asDictionary`. - options add: `{ - #itemGroup -> 41. - #itemOrder -> 36. - #label -> 'sort by date'. - #object -> #model. - #selector -> #sortByDate. - #icon -> #dateIcon - } asDictionary`. - options add: `{ - #itemGroup -> 41. - #itemOrder -> 37. - #label -> 'reverse sort'. - #object -> #model. - #selector -> #sortReverse. - #icon -> #redoIcon - } asDictionary`. - -! ! - -MessageSet removeSelector: #sortByClass! - -!methodRemoval: MessageSet #sortByClass stamp: 'Install-4767-MessageSet-sortBy-Enh-JuanVuletich-2021Aug18-12h24m-jmv.001.cs.st 8/20/2021 16:03:42'! -sortByClass - "Sort the message-list by class / selector" - - messageList _ messageList sort: [ :a :b | - a classSymbol = b classSymbol - ifTrue: [ - a methodSymbol == #Comment - ifTrue: [ true ] - ifFalse: [ - b methodSymbol == #Comment - ifTrue: [ false ] - ifFalse: [ - a classIsMeta = b classIsMeta - ifTrue: [ a methodSymbol < b methodSymbol ] - ifFalse: [ a classIsMeta ] ]]] - ifFalse: [ a classSymbol < b classSymbol ] - ]. - messageList do: [ :each | each removeStringVersionPrefix ]. - self changed: #messageList! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4767-MessageSet-sortBy-Enh-JuanVuletich-2021Aug18-12h24m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4767] on 18 August 2021 at 1:45:58 pm'! -!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 8/18/2021 13:45:29'! - browseMessageListUnsorted: methodReferences name: labelString autoSelect: autoSelectString - "Create and schedule a MessageSet browser on the message list. - Don't sort entries by default." - - | messageListSize title | - - messageListSize _ methodReferences size. - messageListSize = 0 ifTrue: [^ PopUpMenu inform: ('There are no\' , labelString) withNewLines ]. - - title _ messageListSize > 1 - ifFalse: [ labelString ] - ifTrue: [ '[', messageListSize printString, '] ', labelString]. - - MessageSetWindow - openMessageListUnsorted: methodReferences - label: title - autoSelect: autoSelectString! ! -!CodeWindow methodsFor: 'menu commands' stamp: 'jmv 8/18/2021 13:35:02'! - methodInheritance - "Create and schedule a method browser on the inheritance of implementors." - - | list aClassNonMeta isMeta theClassOrMeta aClass sel | - aClass _ model selectedClassOrMetaClass. - sel _ model selectedMessageName. - aClass ifNil: [ ^ self ]. - sel ifNil: [ ^ self ]. - aClassNonMeta _ aClass theNonMetaClass. - isMeta _ aClassNonMeta ~~ aClass. - list _ OrderedCollection new. - aClass allSuperclasses reverseDo: [ :cl | - (cl includesSelector: sel) ifTrue: [ - list addLast: (MethodReference class: cl selector: sel) ]]. - aClassNonMeta - allSubclassesWithLevelDo: [ :cl :level | - theClassOrMeta _ isMeta - ifTrue: [ cl class ] - ifFalse: [ cl ]. - (theClassOrMeta includesSelector: sel) ifTrue: [ - list addLast: (MethodReference class: theClassOrMeta selector: sel) ]] - startingLevel: 0. - Smalltalk - browseMessageList: list - name: 'Inheritance of ' , sel.! ! -!CodeFileBrowserWindow methodsFor: 'menu commands' stamp: 'jmv 8/18/2021 13:35:08' overrides: 50597322! - methodInheritance - (model selectedClassOrMetaClass isNil or: - [model selectedClassOrMetaClass hasDefinition]) - ifFalse: [super methodInheritance]! ! -!MessageSetWindow class methodsFor: 'opening' stamp: 'jmv 8/18/2021 13:44:33'! - openMessageListUnsorted: methodReferences label: labelString autoSelect: autoSelectString - "Open a system view for a MessageSet on messageList. - Don't sort entries by default." - - | messageSet | - - messageSet _ MessageSet messageList: methodReferences asArray. - messageSet autoSelectString: autoSelectString. - - ^self open: messageSet label: labelString ! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 8/18/2021 13:33:06' prior: 50365994! - testDecompiler - " - Smalltalk testDecompiler - " - "Decompiles the source for every method in the system, and then compiles that source and verifies that it generates (and decompiles to) identical code. This currently fails in a number of places because some different patterns (esp involving conditionals where the first branch returns) decompile the same." - | methodNode oldMethod newMethod badOnes oldCodeString n | - badOnes _ OrderedCollection new. - 'Decompiling all classes...' - displayProgressAt: Sensor mousePoint - from: 0 - to: CompiledMethod instanceCount - during: [ :barBlock | - n _ 0. - Smalltalk allBehaviorsDo: [ :cls | - "Transcript cr; show: cls name." - cls selectors do: [ :selector | - (n _ n + 1) \\ 100 = 0 ifTrue: [ barBlock value: n ]. - oldMethod _ cls compiledMethodAt: selector. - oldCodeString _ (cls decompilerClass new - decompile: selector - in: cls - method: oldMethod) decompileString. - methodNode _ cls compilerClass new - compile: oldCodeString - in: cls - notifying: nil - ifFail: nil. - newMethod _ methodNode generate: #(0 0 0 0 ). - oldCodeString = - (cls decompilerClass new - decompile: selector - in: cls - method: newMethod) decompileString ifFalse: [ - Transcript - newLine; - show: '***' , cls name , ' ' , selector. - badOnes add: (MethodReference class: cls selector: selector) ]]]]. - Smalltalk - browseMessageList: badOnes - name: 'Decompiler Discrepancies'.! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 8/18/2021 13:33:12' prior: 50366045! - testFormatter - "Smalltalk testFormatter" - "Reformats the source for every method in the system, and then compiles that source and verifies that it generates identical code. - The formatting used will be classic monochrome." - | newCodeString methodNode oldMethod newMethod badOnes n | - badOnes _ OrderedCollection new. - 'Formatting all classes...' - displayProgressAt: Sensor mousePoint - from: 0 - to: CompiledMethod instanceCount - during: [ :barBlock | - n _ 0. - Smalltalk allBehaviorsDo: [ :cls | - "Transcript cr; show: cls name." - cls selectors do: [ :selector | - (n _ n + 1) \\ 100 = 0 ifTrue: [ barBlock value: n ]. - newCodeString _ cls compilerClass new - format: (cls sourceCodeAt: selector) - in: cls - notifying: nil. - methodNode _ cls compilerClass new - compile: newCodeString - in: cls - notifying: nil - ifFail: nil. - newMethod _ methodNode generate: #(0 0 0 0 ). - oldMethod _ cls compiledMethodAt: selector. - oldMethod = newMethod ifFalse: [ - Transcript - newLine; - show: '***' , cls name , ' ' , selector. - badOnes add: cls name , ' ' , selector ]]]]. - Smalltalk - browseMessageList: badOnes - name: 'Formatter Discrepancies'.! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 8/18/2021 13:33:19' prior: 50366087! - testFormatter2 - "Smalltalk testFormatter2" - "Reformats the source for every method in the system, and then verifies that the order of source tokens is unchanged. - The formatting used will be classic monochrome" - | newCodeString badOnes n oldCodeString oldTokens newTokens | - badOnes _ OrderedCollection new. - 'Formatting all classes...' - displayProgressAt: Sensor mousePoint - from: 0 - to: CompiledMethod instanceCount - during: [ :barBlock | - n _ 0. - Smalltalk allBehaviorsDo: [ :cls | - "Transcript cr; show: cls name." - cls selectors do: [ :selector | - (n _ n + 1) \\ 100 = 0 ifTrue: [ barBlock value: n ]. - oldCodeString _ (cls sourceCodeAt: selector) asString. - newCodeString _ cls compilerClass new - format: oldCodeString - in: cls - notifying: nil. - oldTokens _ oldCodeString findTokens: Character separators. - newTokens _ newCodeString findTokens: Character separators. - oldTokens = newTokens ifFalse: [ - Transcript - newLine; - show: '***' , cls name , ' ' , selector. - badOnes add: cls name , ' ' , selector ]]]]. - Smalltalk - browseMessageList: badOnes - name: 'Formatter Discrepancies'.! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 8/18/2021 13:45:39' prior: 50505898! - browseAllAccessesTo: instVarName from: aClass - "Create and schedule a Message Set browser for all the receiver's methods - or any methods of a subclass/superclass that refer to the instance variable name." - - "self new browseAllAccessesTo: 'contents' from: Collection." - - ^ self - browseMessageListUnsorted: (aClass allAccessesTo: instVarName) - name: 'Accesses to ' , instVarName - autoSelect: instVarName! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 8/18/2021 13:25:24' prior: 50452717! - browseAllCallsOn: aLiteral - "Create and schedule a message browser on each method that refers to - aLiteral. For example, Smalltalk browseAllCallsOn: #open:label:." - (aLiteral isKindOf: LookupKey) - ifTrue: [ - self - browseMessageList: (self allCallsOn: aLiteral) - name: 'Users of ' , aLiteral key - autoSelect: aLiteral key ] - ifFalse: [ - self - browseMessageList: (self allCallsOn: aLiteral) - name: 'Senders of ' , aLiteral - autoSelect: aLiteral ].! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 8/18/2021 13:25:36' prior: 50452736! - browseAllCallsOn: aLiteral localTo: aClass - "Create and schedule a message browser on each method in or below the given class that refers to - aLiteral. For example, Smalltalk browseAllCallsOn: #open:label:." - aClass ifNil: [ ^ self inform: 'no selected class' ]. - (aLiteral isKindOf: LookupKey) - ifTrue: [ - self - browseMessageList: (aClass allLocalCallsOn: aLiteral) - name: 'Users of ' , aLiteral key , ' local to ' , aClass name - autoSelect: aLiteral key ] - ifFalse: [ - self - browseMessageList: (aClass allLocalCallsOn: aLiteral) - name: 'Senders of ' , aLiteral , ' local to ' , aClass name - autoSelect: aLiteral ].! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 8/18/2021 13:25:43' prior: 50338411! - browseAllCallsOnClass: aClass - "Create and schedule a message browser on each method that refers to - aClass. For example, Smalltalk browseAllCallsOnClass: Object." - self - browseMessageList: aClass allCallsOn - name: 'Users of class ' , aClass theNonMetaClass name - autoSelect: aClass theNonMetaClass name.! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 8/18/2021 13:30:38' prior: 16923961! - browseAllImplementorsOfList: selectorList title: aTitle - "Create and schedule a message browser on each method that implements the message whose selector is in the argument selectorList. For example, Smalltalk browseAllImplementorsOfList: #(at:put: size) title: 'stuff'." - - | flattenedList | - flattenedList _ Array streamContents: [ :stream | - selectorList do: [ :sel | - stream nextPutAll: (self allImplementorsOf: sel)]]. - ^ self browseMessageList: flattenedList name: aTitle! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 8/18/2021 13:31:29' prior: 50496545! - browseAllReferencesToLiteral: aLiteral - "Create and schedule a message browser on each method that references aLiteral. For example, - Smalltalk browseAllReferencesToLiteral: 47. - Smalltalk browseAllReferencesToLiteral: 0@0. - " - ^ self - browseMessageList: (self allReferencesToLiteral: aLiteral) - name: 'References to literal ' , aLiteral asString.! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 8/18/2021 13:26:04' prior: 50525516! - browseClassCommentsWithString: aString - "Smalltalk browseClassCommentsWithString: 'my instances' " - "Launch a message list browser on all class comments containing aString as a substring." - | caseSensitive suffix list | - suffix _ (caseSensitive _ Sensor shiftPressed) - ifTrue: [ ' (case-sensitive)' ] - ifFalse: [ ' (use shift for case-sensitive)' ]. - list _ Set new. - Smalltalk allClassesDo: [ :class | - (class organization classComment asString - findString: aString - startingAt: 1 - caseSensitive: caseSensitive) > 0 ifTrue: [ - list add: (MethodReference class: class selector: #Comment) ]]. - ^ self - browseMessageList: list - name: 'Class comments containing ', aString printString, suffix - autoSelect: aString.! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 8/18/2021 13:04:28' prior: 50450173! - browseMessageList: methodReferences name: labelString autoSelect: autoSelectString - "Create and schedule a MessageSet browser on the message list." - - | messageListSize title | - - messageListSize _ methodReferences size. - messageListSize = 0 ifTrue: [^ PopUpMenu inform: ('There are no\' , labelString) withNewLines ]. - - title _ messageListSize > 1 - ifFalse: [ labelString ] - ifTrue: [ '[', messageListSize printString, '] ', labelString]. - - MessageSetWindow - openMessageList: methodReferences - label: title - autoSelect: autoSelectString! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 8/18/2021 13:40:57' prior: 50419013! - browseViewReferencesFromNonViews - " - Smalltalk browseViewReferencesFromNonViews - " - | aLiteral aCollection | - - aCollection _ OrderedCollection new. - - "Tweak to look just for pluggables or also for menus (or maybe for all morphs)" -" PopUpMenu withAllSubclasses , MenuMorph withAllSubclasses , PluggableMorph withAllSubclasses do: [ :view |" - PluggableMorph withAllSubclassesDo: [ :view | -" MenuMorph withAllSubclassesDo: [ :view |" - - aLiteral _ view name. - - "tweak to linclude refs to SysWindow subhierarchy or not" - (view includesBehavior: SystemWindow) & false ifFalse: [ - Smalltalk allBehaviorsDo: [ :class | - ((class includesBehavior: Morph) or: [ class includesBehavior: Morph class ]) ifFalse: [ - class addMethodsTo: aCollection thatReferenceTo: aLiteral special: false byte: nil ]]]]. - - Smalltalk - browseMessageList: aCollection asSet - name: 'References to Views from non-Views' - autoSelect: ''.! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'jmv 8/18/2021 13:41:52' prior: 50496569! - referencesToSelectedLiteral - "Evaluate the selected text and browse methods that reference the same literal" - [ - self - evaluateSelectionAndDo: [ :result | - Smalltalk - browseMessageList: (Smalltalk allReferencesToLiteral: result) - name: 'Users of literal: ' , result asString - autoSelect: self selection ] - ifFail: nil - profiled: false ] - on: UndeclaredVariableReference , UnknownSelector - do: [ :ex | - morph flash ]! ! -!CodeWindow methodsFor: 'GUI building' stamp: 'jmv 8/18/2021 13:35:46' prior: 16813052! - optionalButtonTuples - "Answer a tuple buttons, in the format: - button label - selector to send - help message" - - | aList | - - aList _ #( - (10 'browse' browseMethodFull 'view this method in a browser') - (11 'senders' browseSendersOfMessages 'browse senders of...') - (16 'implementors' browseMessages 'browse implementors of...') - (12 'versions' browseVersions 'browse versions')), - - (Preferences decorateBrowserButtons - ifTrue: - [{#(13 'inheritance' methodInheritance 'browse method inheritance -green: sends to super -tan: has override(s) -mauve: both of the above -pink: is an override but doesn''t call super -pinkish tan: has override(s), also is an override but doesn''t call super' )}] - ifFalse: - [{#(13 'inheritance' methodInheritance 'browse method inheritance')}]), - - #( - (12 'hierarchy' browseHierarchy 'browse class hierarchy') - (10 'inst vars' browseInstVarRefs 'inst var refs...') - (11 'class vars' browseClassVarRefs 'class var refs...') - (10 'show...' offerWhatToShowMenu 'menu of what to show in lower pane')). - - ^ aList! ! -!CodeWindow methodsFor: 'accessing' stamp: 'jmv 8/18/2021 13:35:17' prior: 16813155! - inheritanceButton - "If receiver has an Inheritance button, answer it, else answer nil. morphic only at this point" - - ^ self buttonWithSelector: #methodInheritance! ! -!CodeWindow methodsFor: 'keyboard shortcuts' stamp: 'jmv 8/18/2021 13:35:25' prior: 50594485! - messageListKey: aChar from: view - "Respond to a Command key. I am a model with a code pane, and I also - have a listView that has a list of methods. The view knows how to get - the list and selection." - - | sel class | - aChar == $D ifTrue: [^ model toggleDiffing]. - - sel _ model selectedMessageName. - aChar == $m ifTrue: [ "These next two put up a type in if no message selected" - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllImplementorsOf: to: Smalltalk]. - aChar == $n ifTrue: [ - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllCallsOn: to: Smalltalk]. - - "The following require a class selection" - (class _ model selectedClassOrMetaClass) ifNil: [^ self ]. - aChar == $b ifTrue: [^ BrowserWindow fullOnClass: class selector: sel]. - aChar == $N ifTrue: [^ self browseClassRefs]. - aChar == $i ifTrue: [^ self methodInheritance]. - aChar == $h ifTrue: [^ self browseHierarchy]. - aChar == $p ifTrue: [^ self browseFullProtocol]. - - sel - ifNotNil: [ - "The following require a method selection" - aChar == $o ifTrue: [^ model fileOutMessage]. - aChar == $c ifTrue: [^ model copySelector]. - aChar == $v ifTrue: [^ self browseVersions]. - aChar == $C ifTrue: [^ model showHomeCategory]. - aChar == $O ifTrue: [^ self openSingleMessageBrowser]. - aChar == $x ifTrue: [^ model removeMessage]. - aChar == $t ifTrue: [^ model runMethodTest]. - aChar == $r ifTrue: [^ model debugMethodTest]] - ifNil: [ - aChar == $R ifTrue: [^ model renameClass]]! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'jmv 8/18/2021 13:38:26' prior: 50411597! - messageListMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'what to show...'. - #selector -> #offerWhatToShowMenu. - #icon -> #preferencesIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'toggle break on entry'. - #object -> #model. - #selector -> #toggleBreakOnEntry. - #icon -> #debugIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'browse method (O)'. - #selector -> #openSingleMessageBrowser. - #icon -> #scriptIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 40. - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutMessage. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'inspect CompiledMethod'. - #object -> #model. - #selector -> #inspectCompiledMethod. - #icon -> #exploreIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'senders of... (n)'. - #selector -> #browseSendersOfMessages. - #icon -> #mailForwardIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'implementors of... (m)'. - #selector -> #browseMessages. - #icon -> #developmentIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'inheritance (i)'. - #selector -> #methodInheritance. - #icon -> #goDownIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 40. - #label -> 'versions (v)'. - #selector -> #browseVersions. - #icon -> #clockIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'inst var refs...'. - #selector -> #browseInstVarRefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 20. - #label -> 'inst var defs...'. - #selector -> #browseInstVarDefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'class var refs...'. - #selector -> #browseClassVarRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 40. - #label -> 'class variables'. - #selector -> #browseClassVariables. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 50. - #label -> 'class refs (N)'. - #selector -> #browseClassRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'remove method (x)'. - #object -> #model. - #selector -> #removeMessage. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 20. - #label -> 'run test (t)'. - #object -> #model. - #selector -> #runMethodTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 30. - #label -> 'debug test (r)'. - #object -> #model. - #selector -> #debugMethodTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 10. - #label -> 'more...'. - #selector -> #openMessageListMenu2. - #icon -> #listAddIcon - } asDictionary. - }`. - ! ! -!CodeFileBrowserWindow methodsFor: 'menu building' stamp: 'jmv 8/18/2021 13:38:36' prior: 50493218 overrides: 50403977! - messageListMenu - | aMenu itemColl | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Message List'. - itemColl _ OrderedCollection new. - self model baseCodeSource isLiveSmalltalkImage ifTrue: [ - itemColl add: - {#label -> 'fileIn'. #object -> #model. #selector -> #fileInMessage. #icon -> #updateIcon} asDictionary ]. - itemColl addAll: - { - {#label -> 'fileOut'. #object -> #model. #selector -> #fileOutMessage. #icon -> #fileOutIcon} asDictionary. - nil - }. - self model baseCodeSource isLiveSmalltalkImage ifTrue: [ - itemColl addAll: - { - {#label -> 'senders (n)'. #selector -> #browseSenders. #icon -> #mailForwardIcon} asDictionary. - {#label -> 'implementors (m)'. #selector -> #browseImplementors. #icon -> #developmentIcon} asDictionary. - {#label -> 'method inheritance (h)'. #selector -> #methodInheritance. #icon -> #goDownIcon} asDictionary. - {#label -> 'versions (v)'. #selector -> #browseVersions. #icon -> #clockIcon} asDictionary - } ]. - itemColl addAll: - { - nil. - {#label -> 'remove method (x)'. #object -> #model. #selector -> #removeMessage. #icon -> #deleteIcon} asDictionary - }. - aMenu addItemsFromDictionaries: itemColl. - ^ aMenu.! ! -!MessageSetWindow class methodsFor: 'opening' stamp: 'jmv 8/18/2021 13:03:57' prior: 50443934! - openMessageList: methodReferences label: aString - "Create a standard system view for the message set on the list, anArray. - The label of the view is aString." - - | messageSet | - messageSet _ MessageSet messageList: methodReferences asArray. - messageSet sortByClassHierarchy. - ^self open: messageSet label: aString.! ! -!MessageSetWindow class methodsFor: 'opening' stamp: 'jmv 8/18/2021 13:45:03' prior: 50443944! - openMessageList: methodReferences label: labelString autoSelect: autoSelectString - "Open a system view for a MessageSet on messageList." - - | messageSet | - - messageSet _ MessageSet messageList: methodReferences asArray. - messageSet sortByClassHierarchy. - messageSet autoSelectString: autoSelectString. - - ^self open: messageSet label: labelString ! ! -!ChangeSorterWindow methodsFor: 'menu building' stamp: 'jmv 8/18/2021 13:39:15' prior: 50397479! - messageMenu - "Fill aMenu with items appropriate for the message list; could be for a single or double changeSorter" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'message list'. - aMenu addStayUpIcons. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'delete method from changeSet (d)'. - #object -> #model. - #selector -> #forget. - #icon -> #warningIcon - } asDictionary. - nil. - { - #label -> 'remove method from system (x)'. - #object -> #model. - #selector -> #removeMessage. - #icon -> #deleteIcon - } asDictionary. - nil. - { - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #label -> 'browse method (O)'. - #selector -> #openSingleMessageBrowser. - #icon -> #scriptIcon - } asDictionary. - { - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - nil. - { - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutMessage. - #icon -> #fileOutIcon - } asDictionary. - nil. - { - #label -> 'senders of... (n)'. - #selector -> #browseSendersOfMessages. - #icon -> #mailForwardIcon - } asDictionary. - { - #label -> 'implementors of... (m)'. - #selector -> #browseMessages. - #icon -> #developmentIcon - } asDictionary. - { - #label -> 'inheritance (i)'. - #selector -> #methodInheritance. - #icon -> #goDownIcon - } asDictionary. - { - #label -> 'versions (v)'. - #selector -> #browseVersions. - #icon -> #clockIcon - } asDictionary. - }`. - ^ aMenu! ! - -CodeFileBrowserWindow removeSelector: #methodHierarchy! - -!methodRemoval: CodeFileBrowserWindow #methodHierarchy stamp: 'Install-4768-MessageSet-SortByClassHierarchyByDefault-JuanVuletich-2021Aug18-13h00m-jmv.001.cs.st 8/20/2021 16:03:42'! -methodHierarchy - (model selectedClassOrMetaClass isNil or: - [model selectedClassOrMetaClass hasDefinition]) - ifFalse: [super methodHierarchy]! - -CodeWindow removeSelector: #methodHierarchy! - -!methodRemoval: CodeWindow #methodHierarchy stamp: 'Install-4768-MessageSet-SortByClassHierarchyByDefault-JuanVuletich-2021Aug18-13h00m-jmv.001.cs.st 8/20/2021 16:03:42'! -methodHierarchy - "Create and schedule a method browser on the hierarchy of implementors." - - | list aClassNonMeta isMeta theClassOrMeta aClass sel | - aClass _ model selectedClassOrMetaClass. - sel _ model selectedMessageName. - aClass ifNil: [ ^ self ]. - sel ifNil: [ ^ self ]. - aClassNonMeta _ aClass theNonMetaClass. - isMeta _ aClassNonMeta ~~ aClass. - list _ OrderedCollection new. - aClass allSuperclasses reverseDo: [ :cl | - (cl includesSelector: sel) ifTrue: [ - list addLast: (MethodReference class: cl selector: sel) ]]. - aClassNonMeta - allSubclassesWithLevelDo: [ :cl :level | - theClassOrMeta _ isMeta - ifTrue: [ cl class ] - ifFalse: [ cl ]. - (theClassOrMeta includesSelector: sel) ifTrue: [ - list addLast: (MethodReference class: theClassOrMeta selector: sel) ]] - startingLevel: 0. - Smalltalk - browseMessageList: list - name: 'Inheritance of ' , sel.! - -SystemDictionary removeSelector: #browseMessageList:ofSize:name:autoSelect:! - -!methodRemoval: SystemDictionary #browseMessageList:ofSize:name:autoSelect: stamp: 'Install-4768-MessageSet-SortByClassHierarchyByDefault-JuanVuletich-2021Aug18-13h00m-jmv.001.cs.st 8/20/2021 16:03:42'! -browseMessageList: messageList ofSize: messageListSize name: labelString autoSelect: autoSelectString - - | title | - - "Create and schedule a MessageSet browser on the message list." - - messageListSize = 0 ifTrue: [^ PopUpMenu inform: ('There are no\' , labelString) withNewLines ]. - - title _ messageListSize > 1 - ifFalse: [ labelString ] - ifTrue: [ '[', messageListSize printString, '] ', labelString]. - - MessageSetWindow - openMessageList: messageList - label: title - autoSelect: autoSelectString! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4768-MessageSet-SortByClassHierarchyByDefault-JuanVuletich-2021Aug18-13h00m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4768] on 19 August 2021 at 10:40:15 am'! -!Form methodsFor: 'coloring' stamp: 'jmv 8/19/2021 10:35:00' prior: 50386929! - reverse - "Change all the bits in the receiver that are white to black, and the ones - that are black to white. - Display reverse. Display forceToScreen. - " - - (BitBlt toForm: self) - combinationRule: `Form reverse`; - copyBits.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4769-Fix-reverse-for1bpp-JuanVuletich-2021Aug19-10h08m-jmv.001.cs.st----! - -'From Haver 5.0 [latest update: #4768] on 18 August 2021 at 9:24:57 pm'! - -"Change Set: 4770-MouseWheelSupport-GeraldKlix-2021Aug18-21h24m -Date: 18 August 2021 -Author: Gerald Klix - -I provide native support for mice with wheels"! -!EventSensor methodsFor: 'private-I/O' stamp: 'KLG 8/12/2021 20:23:55'! - processMouseSensorWheelEvent: evt - "Process a mouse wheel event, updating EventSensor state. - - Ported from Squeak 5.3." - - | modifiers buttons mapped | - "Only used by #peekWheelDelta in Squeak, which has no senders. - Can be added in the future." - "F: mouseWheelDelta := (evt at: 3) @ (evt at: 4)." - buttons _ evt at: 5. - modifiers _ evt at: 6. - mapped _ self mapButtons: buttons modifiers: modifiers. - mouseButtons _ mapped bitOr: (modifiers bitShift: 3).! ! -!EventSensor methodsFor: 'private-I/O' stamp: 'KLG 8/12/2021 21:58:09' prior: 50509334! - processSensorEvent: evt discardingMouseEvents: discardMouseEvents - "Process a single event. This method is run at high priority." - | type | - type _ evt at: 1. - - "Check if the event is a user interrupt" - (type = EventSensor eventTypeKeyboard and: [ (evt at: 4) = 0 and: [ - ((evt at: 3) bitOr: (((evt at: 5) bitAnd: 8) bitShift: 8)) = interruptKey]]) - ifTrue: [ - "interrupt key is meta - not reported as event" - ^interruptSemaphore signal]. - - "Store the event in the queue if there's any" - type = EventSensor eventTypeMouse ifTrue: [ - "Only swap secondary and tertiary buttons if there is no command or option modifier keys. - This swap is done so a 3-button mouse is - left -> mouseButton1 (select) - center -> mouseButton3 (halo) - right -> mouseButton2 (menu). - This is only needed on the Mac, Window VM does this mapping by default. - We avoid ding the swap if there are modifier keys, because in that case the buttons were generated by the VM as follows: - left -> mouseButton1 - macOption + left -> mouseButton3 - command + left -> mouseButton2, - but Mac users are already used to - macOption + left -> menu - command + left -> halo. - See #installMouseDecodeTable" - ((evt at: 6) anyMask: 12) ifFalse: [ - evt at: 5 put: (ButtonDecodeTable at: (evt at: 5) + 1)]]. - - (discardMouseEvents and: [ type = EventSensor eventTypeMouse ]) ifFalse: [ - self queueEvent: evt ]. - - "Update state for InputSensor." - "KLG: Why not `self class` instead of `EventSensor`?" - type = EventSensor eventTypeMouse ifTrue: [ - self processMouseSensorEvent: evt ]. - type = EventSensor eventTypeKeyboard ifTrue: [ - self processKeyboardSensorEvent: evt ]. - type = EventSensor eventTypeMouseScroll ifTrue: [ - self processMouseSensorWheelEvent: evt ]! ! -!EventSensor methodsFor: 'test' stamp: 'KLG 8/14/2021 19:42:35' prior: 50561162! - printEventBuffer: evtBuf - "Print the event buffer, currently only used by the method `test`." - - | type buttons macRomanCode modifiers pressType stamp unicodeCodePoint | - type _ evtBuf first. - stamp _ evtBuf second. - stamp = 0 ifTrue: [ stamp := Time millisecondClockValue ]. "VMs report events using #millisecondClockValue" - type = EventSensor eventTypeMouse - ifTrue: [ | position | - position _ evtBuf third @ evtBuf fourth. - buttons _ evtBuf fifth. - modifiers _ evtBuf sixth. - Transcript - newLine; - show: 'Mouse'; - show: ' position:', position printString; - show: ' buttons:', buttons printString; - show: ' modifiers:', modifiers printString. - ]. - type = EventSensor eventTypeMouseScroll - ifTrue: [ | delta | - delta _ evtBuf third @ evtBuf fourth. - buttons _ evtBuf fifth. - modifiers _ evtBuf sixth. - Transcript - newLine; - show: 'Scroll'; - show: ' delta:', delta printString; - show: ' buttons:', buttons printString; - show: ' modifiers:', modifiers printString. - ]. - type = EventSensor eventTypeKeyboard - ifTrue: [ - macRomanCode _ evtBuf third. - unicodeCodePoint _ evtBuf sixth. - pressType _ evtBuf fourth. - modifiers _ evtBuf fifth. - pressType = EventSensor eventKeyDown ifTrue: [ - type _ #keyDown]. - pressType = EventSensor eventKeyUp ifTrue: [ - type _ #keyUp]. - pressType = EventSensor eventKeyChar ifTrue: [ - type _ #keystroke]. - Transcript - newLine; - show: type; - show: ' macRomanCode:', macRomanCode printString, '-', - (Character numericValue: (Character macRomanToLatin1: macRomanCode)) asString, '-'; - show: ' unicodeCodePoint:', unicodeCodePoint printString. - (Character iso8859s15CodeForUnicodeCodePoint: unicodeCodePoint) ifNotNil: [ :latin15 | - Transcript show: '-', (Character numericValue: latin15) asString, '-' ]. - Transcript - show: ' modifiers:', modifiers printString. - (modifiers anyMask: 8) ifTrue: [ Transcript show: ' [commandWinAlt]' ]. - (modifiers anyMask: 4) ifTrue: [ Transcript show: ' [macOption]' ]. - (modifiers anyMask: 2) ifTrue: [ Transcript show: ' [control]' ]. - (modifiers anyMask: 1) ifTrue: [ Transcript show: ' [shift]' ]. - ].! ! -!EventSensor class methodsFor: 'constants' stamp: 'KLG 8/12/2021 21:58:09'! - eventTypeMouseScroll - "Types of events, - - I am a mouse wheel event." - ^7! ! -!SystemDictionary methodsFor: 'vm parameters' stamp: 'jmv 8/19/2021 11:57:26'! - sendMouseWheelEvents - "The Cog VM can be instructed to deliver mouse wheel events as mouse wheel events. - By default mouse wheel events are mapped to arrow events. - This flag persists across snapshots, stored in the image header. - - This implementation was copied from Squeak 5.3 and modified: - Non-Cog VMs might not support this flag. If this is the case, just answer false." - - ^ (self vmParameterAt: 48) - ifNil: [ false ] - ifNotNil: [ :properties | properties allMask: 32 ].! ! -!SystemDictionary methodsFor: 'vm parameters' stamp: 'jmv 8/19/2021 11:57:12'! - sendMouseWheelEvents: aBoolean - "The Cog VM can be instructed to deliver mouse wheel events as mouse wheel events. - By default mouse wheel events are mapped to arrow events. - This flag persists across snapshots, stored in the image header. - - This implementation was copied from Squeak 5.3 and modified: - Non-Cog VMs might not support this flag. If this is the case, just ignore it." - - (self vmParameterAt: 48) ifNotNil: [ :properties | - self vmParameterAt: 48 put: (properties bitClear: 32) + (aBoolean ifTrue: [32] ifFalse: [0]) ].! ! -!HandMorph methodsFor: 'event handling' stamp: 'KLG 8/12/2021 21:58:09' prior: 50426466! - createEventFrom: eventBuffer ofType: type - - type = EventSensor eventTypeMouse ifTrue: [ ^self generateMouseEvent: eventBuffer ]. - type = EventSensor eventTypeMouseScroll ifTrue: [ ^self generateMouseScrollEvent: eventBuffer ]. - type = EventSensor eventTypeKeyboard ifTrue: [ ^self generateKeyboardEvent: eventBuffer ]. - type = EventSensor eventTypeWindow ifTrue: [ ^self generateWindowEvent: eventBuffer ]. - type = EventSensor eventTypeDragDropFiles ifTrue: [ ^self generateDropFilesEvent: eventBuffer ]. - - "All other events are ignored" - ^nil ! ! -!HandMorph methodsFor: 'private events' stamp: 'KLG 8/14/2021 21:44:15'! - generateMouseScrollEvent: evtBuf - "Generate the appropriate mouse wheel event for the given raw event buffer - - Copied from Sqeak 5.3 and modifed." - - | buttons modifiers stamp deltaX deltaY direction oldButtons | - stamp _ evtBuf second. - stamp = 0 ifTrue: [stamp := Time millisecondClockValue ]. - deltaX _ evtBuf third. - deltaY _ evtBuf fourth. - "This implementation deliberatly ignores movements in both dimensions:" - direction _ - deltaY negative - ifTrue: [ #down ] - ifFalse: [ deltaY strictlyPositive - ifTrue: [ #up ] - ifFalse: [ deltaX negative - ifTrue: [ #left ] - ifFalse: [ deltaX strictlyPositive - ifTrue: [ #right ] - ifFalse: [ ^ nil "No movement, bailing out" ] ] ] ]. - modifiers _ evtBuf fifth. - buttons _ (modifiers bitShift: 3) bitOr: (lastMouseEvent buttons bitAnd: 7). - oldButtons _ lastEventBuffer fifth - bitOr: (lastEventBuffer sixth bitShift: 3). - lastEventBuffer := evtBuf. - ^ MouseScrollEvent new - setType: #mouseScroll - position: self morphPosition - direction: direction - buttons: (oldButtons bitXor: buttons) - hand: self - stamp: stamp! ! -!MouseScrollEvent methodsFor: 'dispatching' stamp: 'KLG 8/16/2021 21:27:23' prior: 50564034 overrides: 50563868! - dispatchWith: aMorph - "Find the appropriate receiver for the event and let it handle it. Default rules: - * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. - * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. - * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. - * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. - " - "Try to get out quickly" - | aMorphHandlesIt handledByInner | - "FIXME - this works in all tested cases but one: when the window directly under the mouse doesn't have keyboard focus (i.e. a Transcript window)" - aMorph fullContainsGlobalPoint: position :: ifFalse: [ ^ #rejected ]. - "Install the prospective handler for the receiver" - aMorphHandlesIt _ false. - (aMorph handlesMouseScroll: self) ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]. - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - (eachChild dispatchEvent: self) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - (handledByInner or: [ - (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position]]) ifTrue: [ - "aMorph is in the top-most unlocked, visible morph in the chain." - aMorphHandlesIt ifTrue: [ ^ self sendEventTo: aMorph ]]. - handledByInner ifTrue: [ ^ self ]. - "Mouse was not on aMorph nor any of its children" - ^ #rejected.! ! - -"PostScript: - -Initialization code follows:" -Smalltalk sendMouseWheelEvents: true! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4770-MouseWheelSupport-GeraldKlix-2021Aug18-21h24m-KLG.002.cs.st----! - -'From Cuis 5.0 [latest update: #4768] on 18 August 2021 at 10:08:36 pm'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 8/18/2021 19:52:01'! - quit - "Just quit. No questions asked. No validations done. - Smalltalk quit. - " - self snapshot: false andQuit: true embedded: false clearAllClassState: false! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 8/18/2021 21:03:40'! - saveAndQuit - "Save image and quit. No questions asked. - Smalltalk saveAndQuit. - " - ChangeSet zapAllChangeSets. - ^ self - snapshot: true - andQuit: true - embedded: false - clearAllClassState: false.! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 8/18/2021 21:03:59'! - saveAs: newName clearAllClassState: clearAllStateFlag - "Save the image under a new name. Don't quit. - See senders." - - | newChangesName | - self currentChangesName ifNotNil: [ :oldChangesName | - self closeSourceFiles. "so copying the changes file will always work" - newChangesName _ self fullNameForChangesNamed: newName. - FileIOAccessor default copy: oldChangesName asFileEntry to: newChangesName asFileEntry. - ChangesInitialFileSize ifNotNil: [ - oldChangesName asFileEntry appendStreamDo: [ :strm | strm truncate: ChangesInitialFileSize ]]]. - - ChangeSet zapAllChangeSets. - self - changeImageNameTo: (self fullNameForImageNamed: newName); - closeSourceFiles; openSourceFiles; "so SNAPSHOT appears in new changes file" - snapshot: true andQuit: false embedded: false clearAllClassState: clearAllStateFlag.! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 8/18/2021 21:05:18'! - saveImage - "Save image. Don't quit. No questions asked. - Smalltalk saveImage. - " - ChangeSet zapAllChangeSets. - ^ self - snapshot: true - andQuit: false - embedded: false - clearAllClassState: false.! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 8/18/2021 20:26:01' prior: 16922570! - okayToDiscardUnsavedCode - "Answer true unless the user cancels quitting because of some warning given. - Smalltalk okayToDiscardUnsavedCode - " - | baseCSdirty dirtyPackages | - baseCSdirty _ ChangeSet allChangeSets anySatisfy: [ :any | any isForBaseSystem and: [ any hasUnsavedChanges ]]. - "dirtyPackages _ CodePackage installedPackages anySatisfy: [ :pck | pck hasUnsavedChanges ]." - dirtyPackages _ ChangeSet allChangeSets anySatisfy: [ :any | any codePackage notNil and: [ any hasUnsavedChanges ]]. - baseCSdirty & dirtyPackages ifTrue: [ - ^self confirm: 'There are both unsaved Packages', String newLineString, - 'and unsaved Changes to Cuis core.', String newLineString, - 'If you continue, all unsaved changes will be lost.', String newLineString, - 'Continue?' ]. - baseCSdirty ifTrue: [ - ^self confirm: 'Some ChangeSet for Cuis core have unsaved changes.', String newLineString, - 'If you continue, they would be lost.', String newLineString, - 'Continue?' ]. - dirtyPackages ifTrue: [ - ^self confirm: 'There are unsaved Packages.', String newLineString, - 'If you continue, their changes will be lost.', String newLineString, - 'Continue?' ]. - ^true! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 8/18/2021 20:47:51' prior: 50514412! - saveAs - "Put up the 'saveAs' prompt, obtain a name, and save the image under that new name." - - self request: 'New file name?' initialAnswer: self imageName asFileEntry name do: [:newName| - ((((self fullNameForImageNamed: newName) asFileEntry exists not - and: [(self fullNameForChangesNamed: newName) asFileEntry exists not]) - or: [self confirm: ('{1} already exists. Overwrite?' format: {newName})])) - ifTrue: [ - self saveAs: newName clearAllClassState: false]]! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 8/18/2021 21:04:40' prior: 50454958! - saveAsNewVersion - "Save the image/changes using the next available version number. - This is usually only used to prepare updated Cuis images for distribution." - " - Smalltalk saveAsNewVersion - " - | fileName newName changesName systemVersion | - systemVersion _ SystemVersion current. - fileName _ String streamContents: [ :strm | - strm - nextPutAll: 'Cuis'; - print: systemVersion versionMajor; - nextPut: $.; - print: systemVersion versionMinor; - nextPut: $-; - print: systemVersion highestUpdate. - Smalltalk isSpur - ifTrue: [ - Smalltalk wordSize = 4 ifTrue: [ - strm nextPutAll: '-32' ]] - ifFalse: [ - strm nextPutAll: '-v3' ]]. - newName _ fileName, '.image'. - (DirectoryEntry smalltalkImageDirectory // newName) exists ifTrue: [ - newName _ DirectoryEntry smalltalkImageDirectory - nextNameFor: fileName - extension: 'image' ]. - changesName _ self fullNameForChangesNamed: newName. - "Check to see if there is a .changes file that would cause a problem if we saved a new .image file with the new version number" - changesName asFileEntry exists ifTrue: [ - ^ self inform: -'There is already .changes file of the desired name, -', changesName, ' -curiously already present, even though there is no -corresponding .image file. -Please remedy manually and then repeat your request.' ]. - "Try to clear all user state, including all class vars, preferences, etc" - self saveAs: newName clearAllClassState: true! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 8/18/2021 21:54:21' prior: 50541366! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag - "This is the main method for image save and / or quit. - See senders." - "WARNING: Current process will be killed. UI Process will be restarted" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic - checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " - | activeProc | - activeProc _ Processor activeProcess. - [ | isARealStartup guiRootObject guiRootObjectClass | - save not & quit - ifTrue: [ - (SourceFiles at: 2) ifNotNil: [ :changes | - ChangesInitialFileSize ifNotNil: [ changes truncate: ChangesInitialFileSize ]]] - ifFalse: [ - self - logSnapshot: save - andQuit: quit ]. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | - each isInWorld ifTrue: [ - each delete.]]. - UISupervisor ui tearDownDesktop. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - "Cosas que levanto explicitamente abajo" - guiRootObjectClass _ UISupervisor ui class. - guiRootObject _ UISupervisor ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "guiRootObject _ clearAllStateFlag ifFalse: [ UISupervisor ui ]." - UISupervisor stopUIProcess. - activeProc isTerminated ifFalse: [ activeProc terminate ]. - "Clean Globals" - Smalltalk - at: #Sensor - put: nil. - Smalltalk - at: #Display - put: nil. - Smalltalk closeSourceFiles. - Smalltalk - at: #SourceFiles - put: nil. - Smalltalk allClassesDo: [ :cls | - cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | - cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ - Smalltalk printStuffToCleanOnImageSave. - "Remove this call to actually see the image clean report." - Transcript clear. - ]. - "Do image save & quit as apropriate" - (Cursor cursorAt: #writeCursor) activateCursor. - save - ifTrue: [ - "The snapshot primitive answers false if it was just called to do the snapshot. - But image startup is resumed by returning (again) from the primitive, but this time answering true." - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk - at: #Sensor - put: nil. - Smalltalk - at: #Display - put: DisplayScreen new. - Smalltalk - at: #SourceFiles - put: (Array new: 2). - Smalltalk openSourceFiles. - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | - cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - UISupervisor spawnNewMorphicProcessFor: (guiRootObject ifNil: [ guiRootObject _ guiRootObjectClass newWorld ]). - self restoreLostChangesIfNecessary. - clearAllStateFlag ifTrue: [ - UISupervisor whenUIinSafeState: [ - guiRootObject recreateDefaultDesktop; restoreDisplay. - Display triggerEvent: #screenSizeChanged ]] - ifFalse: [ - UISupervisor whenUIinSafeState: [ - guiRootObject restoreDisplay. - Display triggerEvent: #screenSizeChanged ]]. - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - UISupervisor whenUIinSafeState: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]] - forkAt: Processor timingPriority - 1 - named: 'Startup process'.! ! -!Preferences class methodsFor: 'themes' stamp: 'jmv 8/18/2021 20:51:39' prior: 50594308! - cuisDefaults - self setPreferencesFrom: #( - #(#balloonHelpEnabled true ) - #(#biggerCursors false ) - #(#browseWithPrettyPrint false ) - #(#caseSensitiveFinds false ) - #(#checkForSlips true ) - #(#cmdDotEnabled true ) - #(#diffsInChangeList true ) - #(#diffsWithPrettyPrint false ) - #(#menuKeyboardControl true ) - #(#optionalButtons true ) - #(#extraDebuggerButtons true ) - #(#subPixelRenderFonts true ) - #(#thoroughSenders true ) - #(#cheapWindowReframe false ) - #(#syntaxHighlightingAsYouType true ) - #(#tapAndHoldEmulatesButton2 true ) - #(#clickGrabsMorphs false ) - #(#syntaxHighlightingAsYouTypeAnsiAssignment false ) - #(#syntaxHighlightingAsYouTypeLeftArrowAssignment false ) - ). - self useMenuIcons.! ! -!TheWorldMenu methodsFor: 'commands' stamp: 'jmv 8/18/2021 20:15:28' prior: 50594335! - quitSession - - Smalltalk okayToDiscardUnsavedCode ifFalse: [ ^ self ]. - Smalltalk quit! ! -!TheWorldMenu class methodsFor: 'menu building' stamp: 'jmv 8/18/2021 22:04:22' prior: 50555407! - worldMenuOptions - - ^`{{ - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Open...'. - #selector -> #openOpenMenu. - #icon -> #openIcon. - #balloonText -> 'Submenu to open various system tools'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'New morph...'. - #selector -> #newMorph. - #icon -> #morphsIcon. - #balloonText -> 'Offers a variety of ways to create new objects'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Preferences...'. - #selector -> #openPreferencesMenu. - #icon -> #preferencesIcon. - #balloonText -> 'Opens a menu offering many controls over appearance and system preferences.'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'Windows...'. - #selector -> #openWindowsMenu. - #icon -> #windowIcon. - #balloonText -> 'Manage open windows'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 50. - #label -> 'Help...'. - #selector -> #openHelpMenu. - #icon -> #helpIcon. - #balloonText -> 'Opens a menu of useful items for updating the system, determining what version you are running, and much else'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Changes...'. - #selector -> #openChangesMenu. - #icon -> #changesIcon. - #balloonText -> 'Opens a menu of useful tools for dealing with changes'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Debug...'. - #selector -> #openDebugMenu. - #icon -> #debugIcon. - #balloonText -> 'a menu of debugging items'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'Restore Display'. - #object -> #myWorld. - #selector -> #restoreDisplay. - #icon -> #displayIcon. - #balloonText -> 'Repaint the screen -- useful for removing unwanted display artifacts, lingering cursors, etc.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Save Image'. - #object -> Smalltalk. - #selector -> #saveImage. - #icon -> #saveIcon. - #balloonText -> 'Save the current version of the image on disk. Overwrite existing file.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Save as...'. - #object -> Smalltalk. - #selector -> #saveAs. - #icon -> #saveAsIcon. - #balloonText -> 'Save the current version of the image on disk under a new name.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'Save new Cuis Release'. - #object -> Smalltalk. - #selector -> #saveAsNewVersion. - #icon -> #saveAsNewVersionIcon. - #balloonText -> ('Save as a new release of Cuis.\', - 'Use an updated version-stamped name\', - 'and save it under that name on disk.\', - 'Clear all user preferences and user state (class vars).') withNewLines. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 40. - #label -> 'Save and Quit'. - #object -> Smalltalk. - #selector -> #saveAndQuit. - #icon -> #saveAndQuitIcon. - #balloonText -> 'Save the image and quit out of Cuis. Overwrite existing file.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 50. - #label -> 'Quit'. - #selector -> #quitSession. - #icon -> #quitIcon. - #balloonText -> ('Quit out of Cuis without saving the image.\', - 'Ask for confirmation if there are unsaved changes.') withNewLines. - } asDictionary. -}`! ! - -TheWorldMenu removeSelector: #saveAndQuit! - -!methodRemoval: TheWorldMenu #saveAndQuit stamp: 'Install-4771-QuitAndSaveOptions-JuanVuletich-2021Aug18-21h53m-jmv.001.cs.st 8/20/2021 16:03:42'! -saveAndQuit - - Smalltalk snapshot: true andQuit: true clearAllClassState: false! - -Preferences class removeSelector: #askForSaveOnQuit! - -!methodRemoval: Preferences class #askForSaveOnQuit stamp: 'Install-4771-QuitAndSaveOptions-JuanVuletich-2021Aug18-21h53m-jmv.001.cs.st 8/20/2021 16:03:42'! -askForSaveOnQuit - ^ self - valueOfFlag: #askForSaveOnQuit - ifAbsent: [ true ].! - -SystemDictionary removeSelector: #saveAs:andQuit:clearAllClassState:! - -!methodRemoval: SystemDictionary #saveAs:andQuit:clearAllClassState: stamp: 'Install-4771-QuitAndSaveOptions-JuanVuletich-2021Aug18-21h53m-jmv.001.cs.st 8/20/2021 16:03:42'! -saveAs: newName andQuit: aBoolean clearAllClassState: clearAllStateFlag - "Save the image under a new name." - - | newChangesName | - self currentChangesName ifNotNil: [ :oldChangesName | - self closeSourceFiles. "so copying the changes file will always work" - newChangesName _ self fullNameForChangesNamed: newName. - FileIOAccessor default copy: oldChangesName asFileEntry to: newChangesName asFileEntry. - ChangesInitialFileSize ifNotNil: [ - oldChangesName asFileEntry appendStreamDo: [ :strm | strm truncate: ChangesInitialFileSize ]]]. - - self - changeImageNameTo: (self fullNameForImageNamed: newName); - closeSourceFiles; openSourceFiles; "so SNAPSHOT appears in new changes file" - snapshot: true andQuit: aBoolean - clearAllClassState: clearAllStateFlag! - -SystemDictionary removeSelector: #okayToSave! - -!methodRemoval: SystemDictionary #okayToSave stamp: 'Install-4771-QuitAndSaveOptions-JuanVuletich-2021Aug18-21h53m-jmv.001.cs.st 8/20/2021 16:03:42'! -okayToSave - "Answer true unless the user cancels saving because of some warning given." - - | wasCog isCog | - isCog _ Smalltalk isRunningCog. - [ wasCog _ self imageFormatVersionFromFile allMask: 1 ] - on: Error - do: [ :ignore | - "probably save-as to non-existing file" - ^ true ]. - - (isCog and: [wasCog not]) ifTrue: [ - (self confirm: 'You''re running with a Cog VM.', String newLineString, - 'Non-Cog VMs might not be able to open images saved under Cog!!', String newLineString, - '(If you choose "YES", you might only use this image under Cog VMs.)', String newLineString, - '(If you choose "NO", you might save your work in some other way, and later exit Cuis without saving).', String newLineString, - 'Really save?') - ifFalse: [ ^false ]]. - - ^ true! - -SystemDictionary removeSelector: #saveSession! - -!methodRemoval: SystemDictionary #saveSession stamp: 'Install-4771-QuitAndSaveOptions-JuanVuletich-2021Aug18-21h53m-jmv.001.cs.st 8/20/2021 16:03:42'! -saveSession - self snapshot: true andQuit: false clearAllClassState: false! - -SystemDictionary removeSelector: #snapshot:andQuit:clearAllClassState:! - -!methodRemoval: SystemDictionary #snapshot:andQuit:clearAllClassState: stamp: 'Install-4771-QuitAndSaveOptions-JuanVuletich-2021Aug18-21h53m-jmv.001.cs.st 8/20/2021 16:03:42'! -snapshot: save andQuit: quit clearAllClassState: clearAllStateFlag - save - ifTrue: [ - self okayToSave ifFalse: [ ^ self ]. - ChangeSet zapAllChangeSets ] - ifFalse: [ - quit ifTrue: [ - self okayToDiscardUnsavedCode ifFalse: [ ^ self ]]]. - ^ self - snapshot: save - andQuit: quit - embedded: false - clearAllClassState: clearAllStateFlag! - -SystemDictionary removeSelector: #snapshot:andQuit:embedded:! - -!methodRemoval: SystemDictionary #snapshot:andQuit:embedded: stamp: 'Install-4771-QuitAndSaveOptions-JuanVuletich-2021Aug18-21h53m-jmv.001.cs.st 8/20/2021 16:03:42'! -snapshot: save andQuit: quit embedded: embeddedFlag - - self snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: false! - -SystemDictionary removeSelector: #snapshot:andQuit:! - -!methodRemoval: SystemDictionary #snapshot:andQuit: stamp: 'Install-4771-QuitAndSaveOptions-JuanVuletich-2021Aug18-21h53m-jmv.001.cs.st 8/20/2021 16:03:42'! -snapshot: save andQuit: quit - - self snapshot: save andQuit: quit embedded: false clearAllClassState: false! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4771-QuitAndSaveOptions-JuanVuletich-2021Aug18-21h53m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4771] on 19 August 2021 at 12:55:04 pm'! -!ReferenceStream commentStamp: 'jmv 8/19/2021 12:54:08' prior: 16899450! - This is a way of serializing a tree of objects into disk file. A ReferenceStream can store -one or more objects in a persistent form, including sharing and cycles. - -Here is the way to use ReferenceStream: - ReferenceStream dumpOnFile: ('test1.obj' asFileEntry) object: myObj . - -To get it back: - myObj _ ReferenceStream restoreFromFile: ('test1.obj' asFileEntry ). - -ReferenceStreams can now write "weak" references. nextPutWeak: -writes a "weak" reference to an object, which refers to that object -*if* it also gets written to the stream by a normal nextPut:. - -A ReferenceStream should be treated as a read-stream *or* as a write-stream, *not* as a read/write-stream. The reference-remembering mechanism would probably do bad things if you tried to read and write from the same ReferenceStream. - -Instance variables - references -- an IdentityDictionary mapping objects already written - to their byteStream positions. If asked to write any object a - second time, we just write a reference to its stream position. - This handles shared objects and reference cycles between objects. - To implement "weak references" (for Aliases), the references - dictionary also maps objects not (yet?) written to a Collection - of byteStream positions with hopeful weak-references to it. If - asked to definitely write one of these objects, we'll fixup those - weak references. - objects -- an IdentityDictionary mapping relative byte stream positions to - objects already read in. If asked to follow a reference, we - return the object already read. - This handles shared objects and reference cycles between objects. - currentReference -- the current reference position. Positon relative to the - start of object data in this file. (Allows user to cut and paste smalltalk - code from the front of the file without effecting the reference values.) - This variable is used to help install each new object in "objects" as soon - as it's created, **before** we start reading its contents, in - case any of its content objects reference it. - fwdRefEnds -- A weak reference can be a forward reference, which - requires advance-reading the referrent. When we later come to the - object, we must get its value from "objects" and not re-read it so - refs to it don't become refs to copies. fwdRefEnds remembers the - ending byte stream position of advance-read objects. - skipping -- true if - -If the object is referenced before it is done being created, it might get created twice. Just store the object the moment it is created in the 'objects' dictionary. If at the end, comeFullyUpOnReload returns a different object, some refs will have the temporary object (this is an unlikely case). At the moment, no implementor of comeFullyUpOnReload returns a different object except DiskProxy, and that is OK. -! -!ReferenceStream class methodsFor: 'as yet unclassified' stamp: 'jmv 8/19/2021 12:50:34'! - dumpOnFile: aFileEntry object: anObject - "Warning. if the file named aString existis it will be lost. " - - aFileEntry forceWriteStreamDo: [ :stream | - (self on: stream) nextPut: anObject ].! ! -!ReferenceStream class methodsFor: 'as yet unclassified' stamp: 'jmv 8/19/2021 12:52:54'! - restoreFromFile: aFileEntry - - | answer | - aFileEntry readStreamDo: [ :stream | - answer _ (self on: stream) next ]. - ^answer! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4772-ReferenceStream-Comment-helpers-NicolaMingotti-2021Aug19-12h47m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4768] on 19 August 2021 at 3:37:26 pm'! - -Object subclass: #MethodCategoriesPrompter - instanceVariableNames: 'startClass rejectingFirst prompt categories lines reject ' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Text'! - -!classDefinition: #MethodCategoriesPrompter category: #'System-Text' stamp: 'Install-4773-DebuggerTests-HernanWilkinson-2021Aug19-15h15m-HAW.001.cs.st 8/20/2021 16:03:42'! -Object subclass: #MethodCategoriesPrompter - instanceVariableNames: 'startClass rejectingFirst prompt categories lines reject' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Text'! -!MethodCategoriesPrompter methodsFor: 'initialization' stamp: 'HAW 8/19/2021 15:16:33'! - initializeStaringFrom: aClass rejectingFirst: aRejectingFirst - - startClass := aClass. - rejectingFirst := aRejectingFirst. - - self initializeCategories ! ! -!MethodCategoriesPrompter methodsFor: 'prompting' stamp: 'HAW 8/19/2021 15:17:29'! - prompt: aPrompt ifNone: aNoneBlock - - | selectedCategoryIndex categoryName | - - selectedCategoryIndex := self promptCategory: aPrompt. - selectedCategoryIndex = 0 ifTrue: [^ aNoneBlock value]. - - categoryName := selectedCategoryIndex = 1 ifTrue: [ self requestNewCategory ] ifFalse: [ categories at: selectedCategoryIndex ]. - categoryName isEmpty ifTrue: [ ^aNoneBlock value ]. - - ^categoryName - ! ! -!MethodCategoriesPrompter methodsFor: 'prompting - private' stamp: 'HAW 8/19/2021 15:17:44'! - promptCategory: aPrompt - - | selectedLabelIndex | - - selectedLabelIndex := categories size = 1 - ifTrue: [ 1 ] - ifFalse: [ (PopUpMenu labelArray: categories lines: lines) startUpWithCaption: aPrompt ]. - - ^selectedLabelIndex! ! -!MethodCategoriesPrompter methodsFor: 'accessing' stamp: 'HAW 8/19/2021 15:18:46'! - categories - - ^categories! ! -!MethodCategoriesPrompter methodsFor: 'accessing' stamp: 'HAW 8/19/2021 15:19:53'! - lines - - ^lines ! ! -!MethodCategoriesPrompter class methodsFor: 'instance creation' stamp: 'HAW 8/19/2021 15:16:16'! - staringFrom: aClass rejectingFirst: rejectingFirst - - ^self new initializeStaringFrom: aClass rejectingFirst: rejectingFirst -! ! -!CodeProvider methodsFor: 'categories' stamp: 'HAW 8/19/2021 15:15:23' prior: 50580257! - categoryFromUserWithPrompt: aPrompt for: aClass - "self new categoryFromUserWithPrompt: 'testing' for: SystemDictionary" - - ^(MethodCategoriesPrompter - staringFrom: aClass - rejectingFirst: false) prompt: aPrompt ifNone: [ nil ]! ! -!Browser methodsFor: 'message category functions' stamp: 'HAW 8/19/2021 15:15:47' prior: 50580268! - newMethodCategoryNameIfNone: aNoneBlock - - ^(MethodCategoriesPrompter - staringFrom: self selectedClassOrMetaClass - rejectingFirst: true) prompt: 'Add Category' ifNone: aNoneBlock! ! -!Debugger methodsFor: 'context stack menu' stamp: 'HAW 8/19/2021 15:16:05' prior: 50580277! - askForCategoryIn: aClass default: aDefaultCategory - - ^(MethodCategoriesPrompter - staringFrom: aClass - rejectingFirst: false) prompt: 'Select category for the new method' ifNone: [ aDefaultCategory ]! ! - -MethodCategoriesPrompter class removeSelector: #staringFrom:rejectingFirst:prompting:! - -!methodRemoval: MethodCategoriesPrompter class #staringFrom:rejectingFirst:prompting: stamp: 'Install-4773-DebuggerTests-HernanWilkinson-2021Aug19-15h15m-HAW.001.cs.st 8/20/2021 16:03:42'! -staringFrom: aClass rejectingFirst: rejectingFirst prompting: aPrompt - - ^self new initializeStaringFrom: aClass rejectingFirst: rejectingFirst prompting: aPrompt -! - -MethodCategoriesPrompter removeSelector: #promptCategory! - -!methodRemoval: MethodCategoriesPrompter #promptCategory stamp: 'Install-4773-DebuggerTests-HernanWilkinson-2021Aug19-15h15m-HAW.001.cs.st 8/20/2021 16:03:42'! -promptCategory - - | selectedLabelIndex | - - selectedLabelIndex := categories size = 1 - ifTrue: [ 1 ] - ifFalse: [ (PopUpMenu labelArray: categories lines: lines) startUpWithCaption: prompt ]. - - ^selectedLabelIndex! - -MethodCategoriesPrompter removeSelector: #initializeStaringFrom:rejectingFirst:prompting:! - -!methodRemoval: MethodCategoriesPrompter #initializeStaringFrom:rejectingFirst:prompting: stamp: 'Install-4773-DebuggerTests-HernanWilkinson-2021Aug19-15h15m-HAW.001.cs.st 8/20/2021 16:03:42'! -initializeStaringFrom: aClass rejectingFirst: aRejectingFirst prompting: aPrompt - - startClass := aClass. - rejectingFirst := aRejectingFirst. - prompt := aPrompt ! - -MethodCategoriesPrompter removeSelector: #valueIfNone:! - -!methodRemoval: MethodCategoriesPrompter #valueIfNone: stamp: 'Install-4773-DebuggerTests-HernanWilkinson-2021Aug19-15h15m-HAW.001.cs.st 8/20/2021 16:03:42'! -valueIfNone: aNoneBlock - - | selectedCategoryIndex categoryName | - - self initializeCategories. - - selectedCategoryIndex := self promptCategory. - selectedCategoryIndex = 0 ifTrue: [^ aNoneBlock value]. - - categoryName := selectedCategoryIndex = 1 ifTrue: [ self requestNewCategory ] ifFalse: [ categories at: selectedCategoryIndex ]. - categoryName isEmpty ifTrue: [ ^aNoneBlock value ]. - - ^categoryName - ! - -Object subclass: #MethodCategoriesPrompter - instanceVariableNames: 'startClass rejectingFirst categories lines reject' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Text'! - -!classDefinition: #MethodCategoriesPrompter category: #'System-Text' stamp: 'Install-4773-DebuggerTests-HernanWilkinson-2021Aug19-15h15m-HAW.001.cs.st 8/20/2021 16:03:42'! -Object subclass: #MethodCategoriesPrompter - instanceVariableNames: 'startClass rejectingFirst categories lines reject' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Text'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4773-DebuggerTests-HernanWilkinson-2021Aug19-15h15m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4773] on 19 August 2021 at 10:52:53 pm'! -!TranscriptMorph methodsFor: 'initialization' stamp: 'jmv 8/19/2021 22:52:02' prior: 16938595 overrides: 50545903! - initialize - super initialize. - doImmediateUpdates _ true. - Transcript showOnDisplay: doImmediateUpdates! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4774-Transcript-immediateUpdates-fix-JuanVuletich-2021Aug19-22h52m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4774] on 20 August 2021 at 10:09:12 am'! -!Object methodsFor: 'printing' stamp: 'jmv 8/20/2021 09:47:29' prior: 16882216! - printString - "Answer a String whose characters are a description of the receiver. - If you want to print without a character limit, use fullPrintString. - - This description is to be meaningful for a Smalltalk programmer and usually includes - a hint on the class of the object. - - Usually you should not reimplement this method in subclasses, but #printOn: - - See the comments at: - #printString - #displayStringOrText - #asString - #storeString" - - ^ self printStringLimitedTo: 200! ! -!Inspector methodsFor: 'constants' stamp: 'jmv 8/20/2021 09:46:52' prior: 50515578! - printStringLimit - - ^1200! ! -!HierarchicalListMorph methodsFor: 'private' stamp: 'jmv 8/20/2021 09:54:01' prior: 16853456! - addSubmorphsAfter: parentMorph fromCollection: aCollection allowSorting: sortBoolean - - | priorMorph morphList newCollection limit warning | - priorMorph _ nil. - newCollection _ (sortBoolean and: [sortingSelector notNil]) ifTrue: [ - aCollection asOrderedCollection sort: [ :a :b | - (a perform: sortingSelector) <= (b perform: sortingSelector)] - ] ifFalse: [ - aCollection - ]. - "Limit the number of entries shown." - limit _ 51. - newCollection size > limit ifTrue: [ - warning _ 'Only the first ', (limit-1) printString, ' elements included.'. - newCollection _ newCollection copyFrom: 1 to: limit. - newCollection at: limit put: (ListItemWrapper with: warning) ]. - morphList _ OrderedCollection new. - newCollection do: [ :item | - priorMorph _ self indentingItemClass basicNew - initWithContents: item - prior: priorMorph - forList: self - indentLevel: parentMorph indentLevel + 1. - morphList add: priorMorph. - ]. - scroller addAllMorphs: morphList after: parentMorph. - ^morphList - -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4775-LimitStuffShownInInspectorsAndExplorers-JuanVuletich-2021Aug20-10h08m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4775] on 20 August 2021 at 11:41:07 am'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 8/20/2021 11:40:27'! - saveAndQuitAs: newName clearAllClassState: clearAllStateFlag - "Save the image under a new name. Don't quit. - See senders." - - | newChangesName | - self currentChangesName ifNotNil: [ :oldChangesName | - self closeSourceFiles. "so copying the changes file will always work" - newChangesName _ self fullNameForChangesNamed: newName. - FileIOAccessor default copy: oldChangesName asFileEntry to: newChangesName asFileEntry. - ChangesInitialFileSize ifNotNil: [ - oldChangesName asFileEntry appendStreamDo: [ :strm | strm truncate: ChangesInitialFileSize ]]]. - - ChangeSet zapAllChangeSets. - self - changeImageNameTo: (self fullNameForImageNamed: newName); - closeSourceFiles; openSourceFiles; "so SNAPSHOT appears in new changes file" - snapshot: true andQuit: true embedded: false clearAllClassState: clearAllStateFlag.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4776-saveAndQuitAs-clearAllClassState-JuanVuletich-2021Aug20-11h40m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4775] on 20 August 2021 at 11:58:40 am'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 8/20/2021 11:56:37'! - askConfirmationOnQuit - "Answer true unless the user cancels quitting because of some warning given. - Smalltalk askConfirmationOnQuit - " - | baseCSdirty dirtyPackages | - baseCSdirty _ ChangeSet allChangeSets anySatisfy: [ :any | any isForBaseSystem and: [ any hasUnsavedChanges ]]. - "dirtyPackages _ CodePackage installedPackages anySatisfy: [ :pck | pck hasUnsavedChanges ]." - dirtyPackages _ ChangeSet allChangeSets anySatisfy: [ :any | any codePackage notNil and: [ any hasUnsavedChanges ]]. - baseCSdirty & dirtyPackages ifTrue: [ - ^self confirm: 'There are both unsaved Packages', String newLineString, - 'and unsaved Changes to Cuis core.', String newLineString, - 'If you continue, all unsaved changes will be lost.', String newLineString, - 'Do you really want to exit Cuis without saving the image?' ]. - baseCSdirty ifTrue: [ - ^self confirm: 'Some ChangeSet for Cuis core have unsaved changes.', String newLineString, - 'If you continue, they would be lost.', String newLineString, - 'Do you really want to exit Cuis without saving the image?' ]. - dirtyPackages ifTrue: [ - ^self confirm: 'There are unsaved Packages.', String newLineString, - 'If you continue, their changes will be lost.', String newLineString, - 'Do you really want to exit Cuis without saving the image?' ]. - Preferences askConfirmationOnQuit ifTrue: [ - ^self confirm: 'Do you really want to exit Cuis without saving the image?' ]. - ^true! ! -!Preferences class methodsFor: 'personalization' stamp: 'jmv 8/20/2021 11:57:15'! - askConfirmationOnQuit - ^ self - valueOfFlag: #askConfirmationOnQuit - ifAbsent: [ true ].! ! -!TheWorldMenu methodsFor: 'commands' stamp: 'jmv 8/20/2021 11:57:53' prior: 50598818! - quitSession - Smalltalk askConfirmationOnQuit ifFalse: [ ^ self ]. - Smalltalk quit! ! - -SystemDictionary removeSelector: #okayToDiscardUnsavedCode! - -!methodRemoval: SystemDictionary #okayToDiscardUnsavedCode stamp: 'Install-4777-askConfirmationOnQuit-preference-JuanVuletich-2021Aug20-11h41m-jmv.001.cs.st 8/20/2021 16:03:42'! -okayToDiscardUnsavedCode - "Answer true unless the user cancels quitting because of some warning given. - Smalltalk okayToDiscardUnsavedCode - " - | baseCSdirty dirtyPackages | - baseCSdirty _ ChangeSet allChangeSets anySatisfy: [ :any | any isForBaseSystem and: [ any hasUnsavedChanges ]]. - "dirtyPackages _ CodePackage installedPackages anySatisfy: [ :pck | pck hasUnsavedChanges ]." - dirtyPackages _ ChangeSet allChangeSets anySatisfy: [ :any | any codePackage notNil and: [ any hasUnsavedChanges ]]. - baseCSdirty & dirtyPackages ifTrue: [ - ^self confirm: 'There are both unsaved Packages', String newLineString, - 'and unsaved Changes to Cuis core.', String newLineString, - 'If you continue, all unsaved changes will be lost.', String newLineString, - 'Continue?' ]. - baseCSdirty ifTrue: [ - ^self confirm: 'Some ChangeSet for Cuis core have unsaved changes.', String newLineString, - 'If you continue, they would be lost.', String newLineString, - 'Continue?' ]. - dirtyPackages ifTrue: [ - ^self confirm: 'There are unsaved Packages.', String newLineString, - 'If you continue, their changes will be lost.', String newLineString, - 'Continue?' ]. - ^true! - -SystemDictionary removeSelector: #askConfirmationOnQuitDiscardingUnsavedCode! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4777-askConfirmationOnQuit-preference-JuanVuletich-2021Aug20-11h41m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4775] on 20 August 2021 at 12:00:08 pm'! -!Preferences class methodsFor: 'start up' stamp: 'jmv 8/20/2021 11:59:35' prior: 50540872! - checkLostChangesOnStartUp - ^ self - valueOfFlag: #checkLostChangesOnStartUp - ifAbsent: [ false ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4778-checkLostChangesOnStartUp-preference-defaultToFalse-JuanVuletich-2021Aug20-11h58m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4778] on 20 August 2021 at 12:33:23 pm'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 8/20/2021 12:23:03'! - saveAsNewReleaseAndQuit - "Save the image/changes using the next available version number. - This is usually only used to prepare updated Cuis images for distribution." - " - Smalltalk saveAsNewReleaseAndQuit - " - | fileName newName changesName systemVersion | - systemVersion _ SystemVersion current. - fileName _ String streamContents: [ :strm | - strm - nextPutAll: 'Cuis'; - print: systemVersion versionMajor; - nextPut: $.; - print: systemVersion versionMinor; - nextPut: $-; - print: systemVersion highestUpdate. - Smalltalk isSpur - ifTrue: [ - Smalltalk wordSize = 4 ifTrue: [ - strm nextPutAll: '-32' ]] - ifFalse: [ - strm nextPutAll: '-v3' ]]. - newName _ fileName, '.image'. - (DirectoryEntry smalltalkImageDirectory // newName) exists ifTrue: [ - newName _ DirectoryEntry smalltalkImageDirectory - nextNameFor: fileName - extension: 'image' ]. - changesName _ self fullNameForChangesNamed: newName. - "Check to see if there is a .changes file that would cause a problem if we saved a new .image file with the new version number" - changesName asFileEntry exists ifTrue: [ - ^ self inform: -'There is already .changes file of the desired name, -', changesName, ' -curiously already present, even though there is no -corresponding .image file. -Please remedy manually and then repeat your request.' ]. - "Try to clear all user state, including all class vars, preferences, etc" - self saveAndQuitAs: newName clearAllClassState: true! ! -!TheWorldMenu class methodsFor: 'menu building' stamp: 'jmv 8/20/2021 12:32:32' prior: 50598824! - worldMenuOptions - - ^`{{ - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Open...'. - #selector -> #openOpenMenu. - #icon -> #openIcon. - #balloonText -> 'Submenu to open various system tools'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'New morph...'. - #selector -> #newMorph. - #icon -> #morphsIcon. - #balloonText -> 'Offers a variety of ways to create new objects'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Preferences...'. - #selector -> #openPreferencesMenu. - #icon -> #preferencesIcon. - #balloonText -> 'Opens a menu offering many controls over appearance and system preferences.'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'Windows...'. - #selector -> #openWindowsMenu. - #icon -> #windowIcon. - #balloonText -> 'Manage open windows'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 50. - #label -> 'Help...'. - #selector -> #openHelpMenu. - #icon -> #helpIcon. - #balloonText -> 'Opens a menu of useful items for updating the system, determining what version you are running, and much else'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Changes...'. - #selector -> #openChangesMenu. - #icon -> #changesIcon. - #balloonText -> 'Opens a menu of useful tools for dealing with changes'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Debug...'. - #selector -> #openDebugMenu. - #icon -> #debugIcon. - #balloonText -> 'a menu of debugging items'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'Restore Display'. - #object -> #myWorld. - #selector -> #restoreDisplay. - #icon -> #displayIcon. - #balloonText -> 'Repaint the screen -- useful for removing unwanted display artifacts, lingering cursors, etc.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Save Image'. - #object -> Smalltalk. - #selector -> #saveImage. - #icon -> #saveIcon. - #balloonText -> 'Save the current version of the image on disk. Overwrite existing file.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Save as...'. - #object -> Smalltalk. - #selector -> #saveAs. - #icon -> #saveAsIcon. - #balloonText -> 'Save the current version of the image on disk under a new name.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'Save Release and Quit'. - #object -> Smalltalk. - #selector -> #saveAsNewReleaseAndQuit. - #icon -> #saveAsNewVersionIcon. - #balloonText -> ('Save as a new release of Cuis.\', - 'Clear all user preferences and user state (class vars).\', - 'Use an updated version-stamped name\', - 'and save the image with that name on disk.\', - 'Quit Cuis.') withNewLines. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 40. - #label -> 'Save and Quit'. - #object -> Smalltalk. - #selector -> #saveAndQuit. - #icon -> #saveAndQuitIcon. - #balloonText -> 'Save the image and quit out of Cuis. Overwrite existing file.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 50. - #label -> 'Quit without saving'. - #selector -> #quitSession. - #icon -> #quitIcon. - #balloonText -> ('Quit out of Cuis without saving the image.\', - 'Ask for confirmation if there are unsaved changes.') withNewLines. - } asDictionary. -}`! ! - -SystemDictionary removeSelector: #saveAsNewVersion! - -!methodRemoval: SystemDictionary #saveAsNewVersion stamp: 'Install-4779-saveReleaseAndQuit-JuanVuletich-2021Aug20-12h29m-jmv.001.cs.st 8/20/2021 16:03:42'! -saveAsNewVersion - "Save the image/changes using the next available version number. - This is usually only used to prepare updated Cuis images for distribution." - " - Smalltalk saveAsNewVersion - " - | fileName newName changesName systemVersion | - systemVersion _ SystemVersion current. - fileName _ String streamContents: [ :strm | - strm - nextPutAll: 'Cuis'; - print: systemVersion versionMajor; - nextPut: $.; - print: systemVersion versionMinor; - nextPut: $-; - print: systemVersion highestUpdate. - Smalltalk isSpur - ifTrue: [ - Smalltalk wordSize = 4 ifTrue: [ - strm nextPutAll: '-32' ]] - ifFalse: [ - strm nextPutAll: '-v3' ]]. - newName _ fileName, '.image'. - (DirectoryEntry smalltalkImageDirectory // newName) exists ifTrue: [ - newName _ DirectoryEntry smalltalkImageDirectory - nextNameFor: fileName - extension: 'image' ]. - changesName _ self fullNameForChangesNamed: newName. - "Check to see if there is a .changes file that would cause a problem if we saved a new .image file with the new version number" - changesName asFileEntry exists ifTrue: [ - ^ self inform: -'There is already .changes file of the desired name, -', changesName, ' -curiously already present, even though there is no -corresponding .image file. -Please remedy manually and then repeat your request.' ]. - "Try to clear all user state, including all class vars, preferences, etc" - self saveAs: newName clearAllClassState: true! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4779-saveReleaseAndQuit-JuanVuletich-2021Aug20-12h29m-jmv.001.cs.st----! - -----QUIT----(20 August 2021 16:03:46) Cuis5.0-4779-32.image priorSource: 8403603! - -----STARTUP---- (24 August 2021 17:32:13) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4779-32.image! - - -'From Cuis 5.0 [latest update: #4779] on 20 August 2021 at 8:06:06 pm'! -!AffineTransformation methodsFor: 'modifying' stamp: 'jmv 8/20/2021 20:03:28' prior: 16778588! - italizing - "a little shear - Answer the modified object. In this implementation it is self, but some classes of transformations, - more restricted ones (like MorphicTranslation) could require the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself." - - self a12: self a12 + (self scale*0.2). - ^self! ! -!AffineTransformation methodsFor: 'modifying' stamp: 'jmv 8/20/2021 20:03:33' prior: 16778603! - italizing2 - "a little shear - Answer the modified object. In this implementation it is self, but some classes of transformations, - more restricted ones (like MorphicTranslation) could require the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself." - - self a12: self a12 - (self scale*0.2). - self setTranslation: (self scale*0.2)@0 + self translation. - ^self! ! -!AffineTransformation methodsFor: 'modifying' stamp: 'jmv 8/20/2021 20:03:39' prior: 50536941! - rotatedBy: radians - "rotate the receiver by radians angle. - Answer the modified object. In this implementation it is self, but some classes of transformations, - more restricted ones (like MorphicTranslation) could require the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself." - - | s c a11 a12 a21 a22 | - s _ radians sin. - c _ radians cos. - a11 _ self a11. - a12 _ self a12. - a21 _ self a21. - a22 _ self a22. - self a11: (c * a11) - (s * a21). - self a12: (c * a12) - (s * a22). - self a21: (s * a11) + (c * a21). - self a22: (s * a12) + (c * a22). - ^ self! ! -!AffineTransformation methodsFor: 'modifying' stamp: 'jmv 8/20/2021 20:03:48' prior: 50558667! - scaledBy: aPointOrNumber - "Multiply by a scale. - Argument can be a point, applying different scaling in x and in y directions. - Keep the transformed position of 0@0, i.e. don't change offset. - - Answer the modified object. In this implementation it is self, but some classes of transformations, - more restricted ones (like MorphicTranslation) could require the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself." - - | pt sx sy | - pt _ aPointOrNumber asPoint. - sx _ pt x. - sy _ pt y. - self a11: self a11 * sx. - self a12: self a12 * sx. - self a21: self a21 * sy. - self a22: self a22 * sy. - ^ self! ! -!AffineTransformation methodsFor: 'modifying' stamp: 'jmv 8/20/2021 20:04:07' prior: 50536965! -scaledByNumber: aNumber rotatedBy: radians - "rotate the receiver by radians angle. Also scale by aNumber. - Note: the scale factor is a number, not a point. Therefore, the same scale is applied in all directions. - This means that there is no difference between scaling then rotating and rotating then scaling. - - Answer the modified object. In this implementation it is self, but some classes of transformations, - more restricted ones (like MorphicTranslation) could require the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself." - - | s c a11 a12 a21 a22 | - s _ radians sin. - c _ radians cos. - a11 _ self a11 * aNumber. - a12 _ self a12 * aNumber. - a21 _ self a21 * aNumber. - a22 _ self a22 * aNumber. - self a11: (c * a11) - (s * a21). - self a12: (c * a12) - (s * a22). - self a21: (s * a11) + (c * a21). - self a22: (s * a12) + (c * a22). - ^self! ! -!AffineTransformation methodsFor: 'modifying' stamp: 'jmv 8/20/2021 20:04:12' prior: 16778708! - translatedBy: aPoint - "add an offset in the receiver - - Answer the modified object. In this implementation it is self, but some classes of transformations, - more restricted ones (like MorphicTranslation) could require the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself." - - | pt | - pt _ aPoint asPoint. - self a13: self a13 + pt x. - self a23: self a23 + pt y. - ^ self! ! -!AffineTransformation methodsFor: 'modifying' stamp: 'jmv 8/20/2021 20:05:10' prior: 16778726! - withRotation: radians scale: scale - "Set rotation and scaling according to parameters. - Answer the modified object. In this implementation it is self, but some classes of transformations, - more restricted ones (like MorphicTranslation) could require the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself." - - self setRadians: radians scale: scale. - ^self! ! -!AffineTransformation methodsFor: 'modifying' stamp: 'jmv 8/20/2021 20:05:26' prior: 50558508! - withScale: scale - "Set scaling according to parameters. - Answer the modified object. In this implementation it is self, but some classes of transformations, - more restricted ones (like MorphicTranslation) could require the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself." - - self scaledBy: scale / self scale. - ^self! ! -!AffineTransformation methodsFor: 'modifying' stamp: 'jmv 8/20/2021 20:04:16' prior: 16778742! - withTranslation: aPoint - "set an offset in the receiver - - Answer the modified object. In this implementation it is self, but some classes of transformations, - more restricted ones (like a possible NullTransformation or sch) could require the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself." - - | pt | - pt _ aPoint asPoint. - self a13: pt x. - self a23: pt y. - ^ self! ! -!AffineTransformation methodsFor: 'modifying' stamp: 'jmv 8/20/2021 20:05:41' prior: 16778760! - withYAxisNegated - "Swap inneer point Y sign. - Make y increment upwards. - This makes the any matrix transform from standard mathematical coordinates - to standard display coordinates (in addition to the transform it was already doing) - - Answer the modified object. In this implementation it is self, but some classes of transformations, - more restricted ones (like MorphicTranslation) could require the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself." - - self a12: self a12 negated. - self a22: self a22 negated. - ^self! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4780-SomeMethodComments-JuanVuletich-2021Aug20-20h03m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4780] on 20 August 2021 at 8:45:36 pm'! -!MorphicEvent methodsFor: 'testing' stamp: 'jmv 8/20/2021 20:44:30'! - isMouseMove - ^false! ! -!HandMorph methodsFor: 'event handling' stamp: 'jmv 8/20/2021 20:33:25' prior: 50565111! - processEventQueue - "Process user input events from the local input devices. - Answer true if any event was handled (but ignore MouseMove)" - - | evt evtBuf type hadAny mcs hadAnyMouseEvent hadAnyMouseMoveEvent | - mcs _ mouseClickState. - hadAny _ false. - hadAnyMouseEvent _ false. - hadAnyMouseMoveEvent _ false. - [ (evtBuf := Sensor nextEvent) isNil ] whileFalse: [ - type _ evtBuf first. - evt _ self createEventFrom: evtBuf ofType: type. - evt ifNotNil: [ - "Finally, handle it. But process only up to one mouseMove per cycle. Discard the rest." - (evt isMouseMove and: [ hadAnyMouseMoveEvent ]) ifFalse: [ - self startEventDispatch: evt. - hadAny _ true. - evt isMouse ifTrue: [ - hadAnyMouseEvent _ true. - evt isMouseMove ifTrue: [ - hadAnyMouseMoveEvent _ true ]]]]]. - hadAnyMouseEvent ifFalse: [ - mcs - ifNotNil: [ - "No mouse events during this cycle. Make sure click states time out accordingly" - mcs - handleEvent: lastMouseEvent asMouseMove - from: self ]]. - ^hadAny! ! - -KeyboardEvent removeSelector: #isMouseMove! - -!methodRemoval: KeyboardEvent #isMouseMove stamp: 'Install-4781-JustOneMouseMovePerCycle-JuanVuletich-2021Aug20-20h44m-jmv.001.cs.st 8/24/2021 17:32:17'! -isMouseMove - ^false! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4781-JustOneMouseMovePerCycle-JuanVuletich-2021Aug20-20h44m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4781] on 20 August 2021 at 10:51:59 pm'! -!ClassDescription methodsFor: 'initialization' stamp: 'jmv 8/20/2021 22:47:36' prior: 50431389! -updateInstancesFrom: oldClass - "Recreate any existing instances of the argument, oldClass, as instances of - the receiver, which is a newly changed class. Permute variables as necessary, - and forward old instances to new instances.. Answer nil to defeat any clients - that expected the old behaviour of answering the array of old instances." - "ar 7/15/1999: The updating below is possibly dangerous. If there are any - contexts having an old instance as receiver it might crash the system if - the new receiver in which the context is executed has a different layout. - See bottom below for a simple example:" - | allInstances newMethod oldMethod selector | - allInstances _ oldClass allInstances. - allInstances notEmpty ifTrue: [ - Processor - processesDo: [ :p | ] - withStackFramestDo: [ :process :context | - (context receiver isKindOf: oldClass) ifTrue: [ - selector _ context method selector. - oldMethod _ oldClass lookupSelector: selector. - newMethod _ self lookupSelector: selector. - oldMethod = newMethod ifFalse: [ - MethodInCallStackToBecomeInvalid - signal: self class name, ' has some instance running #', selector, ' that would become invalid.' ]]] - runningProcessSearchStart: nil. - self updateInstances: allInstances asArray from: oldClass isMeta: self isMeta ]. - ^nil - -"This attempts to crash the VM by stepping off the end of an instance. - As the doctor says, do not do this." -" | crashingBlock class | - class := Object subclass: #CrashTestDummy - instanceVariableNames: 'instVar' - classVariableNames: '' - poolDictionaries: '' - category: 'Crash-Test'. - class compile:'instVar: value instVar := value'. - class compile:'crashingBlock ^[instVar]'. - crashingBlock := (class new) instVar: 42; crashingBlock. - Object subclass: #CrashTestDummy - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Crash-Test'. - crashingBlock value"! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4782-UpdateInstancesOptimization-JuanVuletich-2021Aug20-22h47m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4782] on 21 August 2021 at 2:35:24 pm'! -!WorldMorph methodsFor: 'stepping' stamp: 'jmv 8/21/2021 14:33:52' prior: 50551590! -runLocalStepMethods: nowTime - "Run morph 'step' methods whose time has come. Purge any morphs that are no longer in this world." - - | stepMessage | - [ stepList notEmpty and: [ (stepMessage _ stepList first) scheduledTime <= nowTime ]] - whileTrue: [ - (stepMessage receiver shouldGetStepsFrom: self) - ifFalse: [ - stepList remove: stepMessage ifAbsent: []] - ifTrue: [ - stepMessage valueAtTime: nowTime. - stepMessage rescheduleAfter: nowTime. - "We've just updated the scheduled time for stepMessage. - It might have been that stepMessage was removed altogether from stepList. - It also may be the case that stepList got added or removed other elements while on #valueAtTime: - Just reSort. It will be ok in any case." - stepList reSort ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4783-runLocalStepMethods-GeraldKilx-JuanVuletich-2021Aug21-14h32m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4782] on 21 August 2021 at 6:41:34 pm'! -!Inspector methodsFor: 'testing' stamp: 'HAW 8/21/2021 18:38:30'! - shouldPrintSelectionAsString - - ^ self selectionIndex = 0 or: [ self selectionIndex = 2 ]! ! -!Inspector methodsFor: 'selecting' stamp: 'HAW 8/21/2021 18:39:53' prior: 50594365! - selectionPrintString - "Returns the current selection as a string" - - ^self shouldPrintSelectionAsString - ifTrue: [ self selection ] - ifFalse: [ self safelyPrintWith: [ self selection printTextLimitedTo: self printStringLimit ] ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4784-InspectorFix-HernanWilkinson-2021Aug21-18h12m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4784] on 21 August 2021 at 8:10:52 pm'! -!HierarchicalListMorph methodsFor: 'private' stamp: 'jmv 11/14/2011 10:40' prior: 50599413! - addSubmorphsAfter: parentMorph fromCollection: aCollection allowSorting: sortBoolean - - | priorMorph morphList newCollection | - priorMorph _ nil. - newCollection _ (sortBoolean and: [sortingSelector notNil]) ifTrue: [ - aCollection asOrderedCollection sort: [ :a :b | - (a perform: sortingSelector) <= (b perform: sortingSelector)] - ] ifFalse: [ - aCollection - ]. - morphList _ OrderedCollection new. - newCollection do: [:item | - priorMorph _ self indentingItemClass basicNew - initWithContents: item - prior: priorMorph - forList: self - indentLevel: parentMorph indentLevel + 1. - morphList add: priorMorph. - ]. - scroller addAllMorphs: morphList after: parentMorph. - ^morphList - -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4785-RollbackFileListBreakageIn4775-JuanVuletich-2021Aug21-20h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4785] on 22 August 2021 at 12:26:01 pm'! -!Object methodsFor: 'printing' stamp: 'jmv 1/10/2014 22:53' prior: 50599391! - printString - "Answer a String whose characters are a description of the receiver. - If you want to print without a character limit, use fullPrintString. - - This description is to be meaningful for a Smalltalk programmer and usually includes - a hint on the class of the object. - - Usually you should not reimplement this method in subclasses, but #printOn: - - See the comments at: - #printString - #displayStringOrText - #asString - #storeString" - - ^ self printStringLimitedTo: 50000! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4786-Rollback-Object-printString-JuanVuletich-2021Aug22-12h25m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4786] on 22 August 2021 at 1:47:52 pm'! -!Object methodsFor: 'printing' stamp: 'jmv 8/22/2021 12:47:48'! - shortPrintString - "Answer a String whose characters are a description of the receiver. - This is a short one, good for showing users (for example, in ObjectExplorers). - If you want to print without a character limit, use fullPrintString. - - This description is to be meaningful for a Smalltalk programmer and usually includes - a hint on the class of the object. - - Usually you should not reimplement this method in subclasses, but #printOn: - - See the comments at: - #printString - #displayStringOrText - #asString - #storeString" - - ^ self printStringLimitedTo: 64.! ! -!Inspector methodsFor: 'user interface support' stamp: 'jmv 8/22/2021 12:47:43' prior: 50570077! - displayLabel - - | label | - object isObject ifFalse: [^ 'Inspect: ', self objectClass name]. - label := [object shortPrintString] - on: UnhandledError - do: [:ex | ex return: self objectClass printString, ' (printing failed)']. - "Note this is ambiguous: what happens with (Array with: Array)?" - (label includesSubString: self objectClass name) ifTrue: [^'Inspect: ', label]. - ^ 'Inspect: ', self objectClass name, ': ', label! ! -!MethodContext methodsFor: 'printing' stamp: 'jmv 8/22/2021 13:25:20' prior: 16871650 overrides: 16824580! - printDetails: strm - "Put my class>>selector and instance variables and arguments and temporaries on the stream. Protect against errors during printing." - - | pe str pos | - self printOn: strm. - strm newLine. - strm tab; nextPutAll: 'Receiver: '. - pe _ '<>'. - strm nextPutAll: ([receiver shortPrintString] ifError: [:err :rcvr | pe]). - - strm newLine; tab; nextPutAll: 'Arguments and temporary variables: '; newLine. - str _ [(self tempsAndValuesLimitedTo: 80 indent: 2) - padded: #right to: 1 with: $x] ifError: [:err :rcvr | pe]. - strm nextPutAll: (str allButLast). - - strm newLine; tab; nextPutAll: 'Receiver''s instance variables: '; newLine. - pos _ strm position. - [receiver longPrintOn: strm limitedTo: 80 indent: 2] ifError: [:err :rcvr | - strm nextPutAll: pe]. - pos = strm position ifTrue: ["normal printString for an Array (it has no inst vars)" - strm nextPutAll: ([receiver shortPrintString] ifError: [:err :rcvr | pe])]. - strm peekLast isLineSeparator ifFalse: [strm newLine].! ! -!Morph methodsFor: 'e-toy support' stamp: 'jmv 8/22/2021 13:23:01' prior: 16874440! - unlockOneSubpart - | unlockables aMenu reply | - unlockables _ self submorphs select: - [ :m | m isLocked]. - unlockables size <= 1 ifTrue: [^ self unlockContents]. - aMenu _ SelectionMenu labelList: (unlockables collect: [:m | m shortPrintString]) selections: unlockables. - reply _ aMenu startUpWithCaption: 'Who should be be unlocked?'. - reply ifNil: [^ self]. - reply unlock.! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 8/22/2021 13:22:30' prior: 50514681! - editBalloonHelpContent: aString - self - request: 'Edit the balloon help text for ' , self shortPrintString - initialAnswer: (aString ifNil: [self noHelpString] ifNotNil: [aString]) - do: [:reply| - (reply isEmpty or: [reply asString = self noHelpString]) - ifTrue: [self setBalloonText: nil] - ifFalse: [self setBalloonText: reply]]! ! -!Morph methodsFor: 'menus' stamp: 'jmv 8/22/2021 13:25:37' prior: 50545744! - addHaloActionsTo: aMenu - "Add items to aMenu representing actions requestable via halo" - - | subMenu | - subMenu := MenuMorph new defaultTarget: self. - subMenu addTitle: self shortPrintString. - subMenu addStayUpIcons. - subMenu addLine. - (subMenu add: 'delete' action: #dismissViaHalo) - setBalloonText: 'Delete this object -- warning -- can be destructive!!' . - self maybeAddCollapseItemTo: subMenu. - (subMenu add: 'grab' action: #openInHand) - setBalloonText: 'Pick this object up -- warning, since this removes it from its container, it can have adverse effects.' . - subMenu addLine. - (subMenu add: 'duplicate' action: #maybeDuplicateMorph) - setBalloonText: 'Hand me a copy of this object'. - (subMenu - add: 'set color' - target: self - action: #changeColor) - setBalloonText: 'Change the color of this object'. - (subMenu - add: 'inspect' - target: self - action: #inspect) - setBalloonText: 'Open an Inspector on this object'. - aMenu add: 'halo actions...' subMenu: subMenu! ! -!Morph methodsFor: 'menus' stamp: 'jmv 8/22/2021 13:26:12' prior: 16876204! - addStandardHaloMenuItemsTo: aMenu hand: aHandMorph - "Add standard halo items to the menu" - - | unlockables | - - self isWorldMorph ifTrue: - [^ self addWorldHaloMenuItemsTo: aMenu hand: aHandMorph]. - - aMenu add: 'send to back' action: #goBehind. - aMenu add: 'bring to front' action: #comeToFront. - self addEmbeddingMenuItemsTo: aMenu hand: aHandMorph. - aMenu addLine. - - self addColorMenuItems: aMenu hand: aHandMorph. - self addHaloActionsTo: aMenu. - aMenu addLine. - self addToggleItemsToHaloMenu: aMenu. - aMenu addLine. - self addCopyItemsTo: aMenu. - self addExportMenuItems: aMenu hand: aHandMorph. - self addDebuggingItemsTo: aMenu hand: aHandMorph. - - aMenu addLine. - aMenu defaultTarget: self. - - aMenu addLine. - - unlockables _ self submorphs select: - [:m | m isLocked]. - unlockables size = 1 ifTrue: - [aMenu - add: ('unlock "{1}"' format: unlockables first shortPrintString) - action: #unlockContents]. - unlockables size > 1 ifTrue: - [aMenu add: 'unlock all contents' action: #unlockContents. - aMenu add: 'unlock...' action: #unlockOneSubpart]. - - aMenu defaultTarget: aHandMorph. -! ! -!Morph methodsFor: 'menus' stamp: 'jmv 8/22/2021 13:22:15' prior: 16876241! - addTitleForHaloMenu: aMenu - aMenu addTitle: self shortPrintString.! ! -!WorldMorph methodsFor: 'menu & halo' stamp: 'jmv 8/22/2021 13:23:11' prior: 50553152! - addWorldHaloMenuItemsTo: aMenu hand: aHandMorph - "Add standard halo items to the menu, given that the receiver is a World" - - | unlockables | - self addColorMenuItems: aMenu hand: aHandMorph. - -" aMenu addLine. - self addWorldToggleItemsToHaloMenu: aMenu." - aMenu addLine. - self addCopyItemsTo: aMenu. - self addExportMenuItems: aMenu hand: aHandMorph. - - self addDebuggingItemsTo: aMenu hand: aHandMorph. - - aMenu addLine. - aMenu defaultTarget: self. - - aMenu addLine. - - unlockables _ self submorphs select: - [ :m | m isLocked]. - unlockables size = 1 ifTrue: [ - aMenu add: ('unlock "{1}"' format:{unlockables first shortPrintString})action: #unlockContents]. - unlockables size > 1 ifTrue: [ - aMenu add: 'unlock all contents' action: #unlockContents. - aMenu add: 'unlock...' action: #unlockOneSubpart]. - - aMenu defaultTarget: aHandMorph. -! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 8/22/2021 13:23:24' prior: 50596262! - addHandles: aDisplayRectangle - "update my size. owner is world, therefore owner coordinates are Display coordinates." - - self morphPosition: aDisplayRectangle topLeft extent: aDisplayRectangle extent. - haloBox _ self handlesBox. - target addHandlesTo: self box: haloBox. - self addNameString: target shortPrintString. - self redrawNeeded.! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 8/22/2021 13:23:56' prior: 50577039! - doDebug: evt with: menuHandle - "Ask hand to invoke the a debugging menu for my inner target. If shift key is down, immediately put up an inspector on the inner target" - - | menu | - evt hand obtainHalo: self. - evt shiftPressed ifTrue: [ - ^ target inspect]. - - menu _ target buildDebugMenu: evt hand. - menu addTitle: target shortPrintString. - menu popUpInWorld: self world! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 8/22/2021 13:24:15' prior: 50559101! - doDup: evt with: dupHandle - "Ask hand to duplicate my target." - - | hand positionInHandCoordinates | - target okayToDuplicate ifFalse: [^ self]. - hand _ evt hand. - positionInHandCoordinates _ target morphPositionInWorld - hand morphPositionInWorld. - "Duplicate has no meaningful position, as it is not in the world. Grab position from original!!" - target _ target duplicateMorph: evt. - self addNameString: target shortPrintString. - hand - obtainHalo: self; - grabMorph: target delta: positionInHandCoordinates! ! -!ObjectExplorerWindow methodsFor: 'GUI building' stamp: 'jmv 8/22/2021 12:48:02' prior: 50455853! - buildMorphicWindow - - | textMorph | - listMorph _ HierarchicalListMorph - model: model - listGetter: #getList - indexGetter: #getCurrentSelection - indexSetter: #noteNewSelection: - mainView: self - menuGetter: #genericMenu - keystrokeAction: #explorerKey:from:. - listMorph autoDeselect: false. - listMorph doubleClickSelector: #inspectSelection. - textMorph _ ((TextModelMorph textProvider: model) - askBeforeDiscardingEdits: false; - emptyTextDisplayMessage: 'Smalltalk expression (self is selected item)'). - self layoutMorph - addMorph: listMorph proportionalHeight: 0.8; - addAdjusterAndMorph: textMorph proportionalHeight: 0.2. - self setLabel: model rootObject shortPrintString.! ! -!ObjectExplorerWrapper methodsFor: 'converting' stamp: 'jmv 8/22/2021 12:33:32' prior: 16883557 overrides: 16864919! - asString - | explorerString | - explorerString _ [ item shortPrintString ] - on: UnhandledError - do: [:ex | ex return: '']. - ^itemName , ': ' , explorerString :: withBlanksCondensed! ! -!TestCase methodsFor: 'assertions' stamp: 'jmv 8/22/2021 13:26:49' prior: 16927611! - comparingStringBetween: expected and: actual - ^ String streamContents: [:stream | - stream - nextPutAll: 'Expected '; - nextPutAll: expected shortPrintString; - nextPutAll: ' but was '; - nextPutAll: actual shortPrintString; - nextPutAll: '.' - ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4787-shortPrintString-InInspectosAndExplorers-JuanVuletich-2021Aug22-13h47m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4787] on 22 August 2021 at 1:51:43 pm'! -!LargePositiveInteger methodsFor: 'testing' stamp: 'jmv 8/22/2021 13:50:42' overrides: 16859514! -hasContentsInExplorer - ^true! ! -!Collection methodsFor: 'testing' stamp: 'jmv 8/22/2021 13:42:46' overrides: 16882664! - hasContentsInExplorer - - ^self class isPointers and: [ self size between: 1 and: 100 ]! ! - -Dictionary removeSelector: #hasContentsInExplorer! - -!methodRemoval: Dictionary #hasContentsInExplorer stamp: 'Install-4788-Explorers-DontExpandLargeCollections-JuanVuletich-2021Aug22-13h49m-jmv.001.cs.st 8/24/2021 17:32:17'! -hasContentsInExplorer - - ^self isEmpty not! - -Set removeSelector: #hasContentsInExplorer! - -!methodRemoval: Set #hasContentsInExplorer stamp: 'Install-4788-Explorers-DontExpandLargeCollections-JuanVuletich-2021Aug22-13h49m-jmv.001.cs.st 8/24/2021 17:32:17'! -hasContentsInExplorer - - ^self notEmpty! - -OrderedCollection removeSelector: #hasContentsInExplorer! - -!methodRemoval: OrderedCollection #hasContentsInExplorer stamp: 'Install-4788-Explorers-DontExpandLargeCollections-JuanVuletich-2021Aug22-13h49m-jmv.001.cs.st 8/24/2021 17:32:17'! -hasContentsInExplorer - - ^self isEmpty not! - -Integer removeSelector: #hasContentsInExplorer! - -!methodRemoval: Integer #hasContentsInExplorer stamp: 'Install-4788-Explorers-DontExpandLargeCollections-JuanVuletich-2021Aug22-13h49m-jmv.001.cs.st 8/24/2021 17:32:17'! -hasContentsInExplorer - ^true! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4788-Explorers-DontExpandLargeCollections-JuanVuletich-2021Aug22-13h49m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4788] on 22 August 2021 at 2:12:35 pm'! -!TextModel methodsFor: 'object serialization' stamp: 'jmv 8/22/2021 13:55:14' prior: 16933867 overrides: 16881985! - convertToCurrentVersion: varDict refStream: smartRefStrm - - "Maybe old instances won't have this variable set." - undoRedoCommands ifNil: [ - undoRedoCommands _ ReadWriteStream on: #() ]! ! -!TextModel methodsFor: 'initialization' stamp: 'jmv 8/22/2021 13:55:23' prior: 16933876! - flushUndoRedoCommands - - undoRedoCommands _ ReadWriteStream on: #(). - lastEditTimeStamp _ nil! ! -!TextModel methodsFor: 'initialization' stamp: 'jmv 8/22/2021 13:55:29' prior: 16933882 overrides: 16896425! - initialize - "Initialize the state of the receiver with its default contents." - - actualContents _ '' asText. - undoRedoCommands _ ReadWriteStream on: #(). - lastEditTimeStamp _ nil! ! -!TextModel methodsFor: 'copying' stamp: 'jmv 8/22/2021 13:55:34' prior: 16933898 overrides: 16777570! - postCopy - super postCopy. - actualContents _ actualContents copy. - undoRedoCommands _ ReadWriteStream on: #(). - lastEditTimeStamp _ nil! ! -!PluggableTextModel methodsFor: 'initialization' stamp: 'jmv 8/22/2021 13:55:38' prior: 16890154! - initWith: aTextProvider - "aTextProvider can be a kind of TextProvider, or perhaps a more exotic object, like an ObjectExplorer or a TranscriptStream." - - textProvider _ aTextProvider. - undoRedoCommands _ ReadWriteStream on: #(). - lastEditTimeStamp _ nil! ! -!TimeProfileBrowser methodsFor: 'private' stamp: 'jmv 8/22/2021 13:56:25' prior: 16937804! - runBlock: aBlock -" - TimeProfileBrowser spyOn: [20 timesRepeat: - [Transcript show: 100 factorial printString]] -" - | result linesStream talliesStream textStream | - - tally := AndreasSystemProfiler new. - tally observedProcess: Processor activeProcess. - result := tally spyOn: aBlock. - - textStream _ DummyStream on: nil. - linesStream _ WriteStream on: #(). - talliesStream _ WriteStream on: #(). - - tally reportTextOn: textStream linesOn: linesStream talliesOn: talliesStream. - self initializeMessageList: linesStream contents talliesList: talliesStream contents. - - self changed: #messageList. - self changed: #messageListIndex. - self triggerEvent: #decorateButtons. - ^result! ! -!UndefinedObject methodsFor: 'class hierarchy' stamp: 'jmv 8/22/2021 14:07:11' prior: 16940179! - subclasses - "Return all the subclasses of nil" - - ^Array streamContents: [ :classList | - self subclassesDo: [ :class | classList nextPut: class ]].! ! -!Categorizer methodsFor: 'accessing' stamp: 'jmv 8/22/2021 13:57:47' prior: 16795624! - removeCategory: cat - "Remove the category named, cat. Create an error notificiation if the - category has any elements in it." - - | index lastStop | - index _ categoryArray indexOf: cat ifAbsent: [^self]. - lastStop _ - index = 1 - ifTrue: [0] - ifFalse: [categoryStops at: index - 1]. - (categoryStops at: index) - lastStop > 0 - ifTrue: [^self error: 'cannot remove non-empty category']. - categoryArray _ categoryArray copyReplaceFrom: index to: index with: #(). - categoryStops _ categoryStops copyReplaceFrom: index to: index with: #(). - categoryArray size = 0 - ifTrue: - [categoryArray _ Array with: Default. - categoryStops _ Array with: 0] -! ! -!WordArray class methodsFor: 'as yet unclassified' stamp: 'jmv 8/22/2021 13:58:10' prior: 16945304! - 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 _ ReadWriteStream on: #[]. - - 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 _ ReadWriteStream 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 printStringBase: 16] - } - ]. - ]. - ^answer explore! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 8/22/2021 14:01:34' prior: 50365961! - obsoleteMethodReferences - " - Smalltalk obsoleteMethodReferences - Smalltalk browseObsoleteMethodReferences - Open a browser on all referenced behaviors that are obsolete" - - | obsClasses obsRefs | - ^Array streamContents: [ :references | - obsClasses _ self obsoleteBehaviors. - 'Scanning for methods referencing obsolete classes' displayProgressAt: Sensor mousePoint - from: 1 to: obsClasses size during: [ :barBlock | - obsClasses keysAndValuesDo: [ :index :each | - barBlock value: index. - obsRefs _ self pointersTo: each except: obsClasses. - obsRefs do: [ :ref | - "Figure out if it may be a global" - (ref isVariableBinding and: [ ref key isString "or Symbol" ]) ifTrue: [ - (self pointersTo: ref) do: [ :meth | - (meth is: #CompiledMethod) ifTrue: [ - meth methodReference ifNotNil: [ :mref | - (mref isValid and: [ mref compiledMethod == meth]) ifTrue: [ - references nextPut: mref ]]]]]]]]].! ! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jmv 8/22/2021 13:56:35' prior: 16921000! - listBuiltinModules - "Smalltalk listBuiltinModules" - "Return a list of all builtin modules (e.g., plugins). Builtin plugins are those that are compiled with the VM directly, as opposed to plugins residing in an external shared library. The list will include all builtin plugins regardless of whether they are currently loaded or not. Note that the list returned is not sorted!!" - | modules index name | - modules _ WriteStream on: #(). - index _ 1. - [true] whileTrue:[ - name _ self listBuiltinModule: index. - name ifNil:[^modules contents]. - modules nextPut: name. - index _ index + 1. - ].! ! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jmv 8/22/2021 13:56:40' prior: 16921029! - listLoadedModules - "Smalltalk listLoadedModules" - "Return a list of all currently loaded modules (e.g., plugins). Loaded modules are those that currently in use (e.g., active). The list returned will contain all currently active modules regardless of whether they're builtin (that is compiled with the VM) or external (e.g., residing in some external shared library). Note that the returned list is not sorted!!" - | modules index name | - modules _ WriteStream on: #(). - index _ 1. - [true] whileTrue:[ - name _ self listLoadedModule: index. - name ifNil:[^modules contents]. - modules nextPut: name. - index _ index + 1. - ].! ! -!ReadWriteStream methodsFor: 'accessing' stamp: 'jmv 8/22/2021 13:55:58' prior: 16898123! - truncateAtPosition - "Truncate the receiver at current position. - For example, this should evaluate to true: - | s | - s _ ReadWriteStream on: #(). - s nextPutAll: 'abcdefg'. - s reset. - s next; next. - s nextPut: $z. - s truncateAtPosition. - s atEnd - " - readLimit _ position! ! -!Parser methodsFor: 'primitives' stamp: 'jmv 8/22/2021 14:01:58' prior: 50333455! - externalFunctionDeclaration - "Parse the function declaration for a call to an external library." - | descriptorClass callType modifier retType externalName args argType module fn | - descriptorClass := Smalltalk at: #ExternalFunction ifAbsent: [ ^ false ]. - callType := descriptorClass callingConventionFor: here. - callType == nil ifTrue:[^false]. - [modifier := descriptorClass callingConventionModifierFor: token. - modifier notNil] whileTrue: - [self advance. - callType := callType bitOr: modifier]. - "Parse return type" - self advance. - retType := self externalType: descriptorClass. - retType == nil ifTrue: [^self expected:'return type']. - "Parse function name or index" - externalName := here. - (self match: #string) - ifTrue:[externalName := externalName asSymbol] - ifFalse:[(self match:#number) ifFalse:[^self expected:'function name or index']]. - (self match: #leftParenthesis) ifFalse:[^self expected:'argument list']. - args := WriteStream on: #(). - [self match: #rightParenthesis] whileFalse:[ - argType := self externalType: descriptorClass. - argType == nil ifTrue:[^self expected:'argument']. - argType isVoid & argType isPointerType not ifFalse:[args nextPut: argType]]. - (self matchToken: 'module:') ifTrue:[ - module := here. - (self match: #string) ifFalse:[^self expected: 'String']. - module := module asSymbol]. - Smalltalk at: #ExternalLibraryFunction ifPresent:[:xfn| - fn := xfn name: externalName - module: module - callType: callType - returnType: retType - argumentTypes: args contents. - self allocateLiteral: fn]. - (self matchToken: 'error:') - ifTrue: - [| errorCodeVariable | - errorCodeVariable := here. - (hereType == #string - or: [hereType == #word]) ifFalse:[^self expected: 'error code (a variable or string)']. - self advance. - self addPragma: (Pragma keyword: #primitive:error: arguments: (Array with: 120 with: errorCodeVariable)). - fn ifNotNil: [fn setErrorCodeName: errorCodeVariable]] - ifFalse: - [self addPragma: (Pragma keyword: #primitive: arguments: #(120))]. - ^true! ! -!SmalltalkEditor methodsFor: 'explain' stamp: 'jmv 8/22/2021 14:10:26' prior: 16910169! - explainClass: symbol - "Is symbol a class variable or a pool variable?" - | provider class reply classes | - provider _ self codeProvider. - (provider respondsTo: #selectedClassOrMetaClass) - ifFalse: [^ nil]. - (class _ provider selectedClassOrMetaClass) ifNil: [^ nil]. - "no class is selected" - (class isKindOf: Metaclass) - ifTrue: [class _ class soleInstance]. - classes _ (Array with: class) - , class allSuperclasses. - "class variables" - reply _ classes detect: [:each | (each classVarNames detect: [:name | symbol = name] - ifNone: nil) - notNil] - ifNone: nil. - reply ifNotNil: [ - ^ String streamContents: [:str | - str - nextPutAll: symbol; - nextPutAll: ' is a class variable, defined in class '; - nextPutAll: reply printString, '\' withNewLines; - nextPutAll: 'Smalltalk browseAllCallsOn: ('; - nextPutAll: reply printString; - nextPutAll: ' classPool associationAt: #'; - nextPutAll: symbol; - nextPutAll: ').']]. - "pool variables" - classes do: [:each | (each sharedPools - detect: [:pool | (pool includesKey: symbol) - and: - [reply _ pool. - true]] - ifNone: nil) - notNil]. - reply - ifNil: [(Undeclared includesKey: symbol) - ifTrue: [ - ^ String streamContents: [:str | - str - nextPutAll: symbol; - nextPutAll: ' is an undeclared variable.'; - nextPutAll: 'Smalltalk browseAllCallsOn: (Undeclared associationAt: #'; - nextPutAll: symbol; - nextPutAll: ').']]] - ifNotNil: - [classes _ Array streamContents: [ :strm | - Smalltalk - allBehaviorsDo: [:each | (each sharedPools - detect: - [:pool | - pool == reply] - ifNone: nil) - notNil ifTrue: [strm nextPut: each]]]. - "Perhaps not print whole list of classes if too long. (unlikely)" - ^ String streamContents: [:str | - str - nextPutAll: symbol; - nextPutAll: ' is a pool variable from the pool '; - nextPutAll: (Smalltalk keyAtIdentityValue: reply) asString; - nextPutAll: ', which is used by the following classes '; - nextPutAll: classes printString , '\' withNewLines; - nextPutAll: 'Smalltalk browseAllCallsOn: ('; - nextPutAll: (Smalltalk keyAtIdentityValue: reply) asString; - nextPutAll: ' bindingOf: #'; - nextPutAll: symbol; - nextPutAll: ').']]. - ^ nil! ! -!TheWorldMenu methodsFor: 'commands' stamp: 'jmv 8/22/2021 14:12:10' prior: 50343938! - splitNewMorphList: list depth: d - | middle c prev next | - d <= 0 ifTrue: [ ^ Array with: list ]. - middle := list size // 2 + 1. - c := (list at: middle) name first: 3. - prev := middle - 1. - [ - prev > 0 and: [ ((list at: prev) name first: 3) = c ]] whileTrue: [ prev := prev - 1 ]. - next := middle + 1. - [ - next <= list size and: [ ((list at: next) name first: 3) = c ]] whileTrue: [ next := next + 1 ]. - "Choose the better cluster" - middle := middle - prev < (next - middle) - ifTrue: [ prev + 1 ] - ifFalse: [ next ]. - middle = 1 ifTrue: [ middle := next ]. - middle >= list size ifTrue: [ middle := prev + 1 ]. - (middle = 1 or: [ middle >= list size ]) ifTrue: [ ^ Array with: list ]. - ^ Array streamContents: [ :out | - out nextPutAll: - (self - splitNewMorphList: - (list - copyFrom: 1 - to: middle - 1) - depth: d - 1). - out nextPutAll: - (self - splitNewMorphList: - (list - copyFrom: middle - to: list size) - depth: d - 1) ].! ! -!CodeFile methodsFor: 'accessing' stamp: 'jmv 8/22/2021 13:58:32' prior: 50492844! - organization - ^ SystemOrganizer defaultList: #().! ! -!WeightTracer methodsFor: 'weight' stamp: 'jmv 8/22/2021 13:58:40' prior: 16944984 overrides: 16808241! - scanClosureSkipping: anArray - - self prepareToScanClosure. - self skipInternalNodesAnd: #(). - self basicScanClosure. - self prepareToWeighClosure. - self skipInternalNodesAnd: anArray. - self basicScanClosure. - self cleanUpAfterScan! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4789-Cleanup-JuanVuletich-2021Aug22-14h06m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4789] on 23 August 2021 at 12:15:23 pm'! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 8/23/2021 11:15:37'! - fullAddCurrentMorphTo: aDamageRecorder - - currentMorph isRedrawNeeded ifTrue: [ - currentMorph needsRedraw: false. - self updateCurrentBounds. - aDamageRecorder recordInvalidRect: currentMorph displayBounds for: currentMorph ]. - currentMorph isSubmorphRedrawNeeded ifTrue: [ - currentMorph submorphNeedsRedraw: false. - currentMorph submorphsReverseDo: [ :m | - self fullAddRedrawRect: m to: aDamageRecorder ]].! ! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 8/23/2021 11:21:37' prior: 50595291! -fullAddRedrawRect: aMorph to: aDamageRecorder - - aMorph visible ifTrue: [ - (aMorph isRedrawNeeded or: [aMorph isSubmorphRedrawNeeded]) ifTrue: [ - self into: aMorph. - self fullAddCurrentMorphTo: aDamageRecorder. - self outOfMorph - ]]! ! - -BitBltBoundsFinderCanvas removeSelector: #fullAddCurrentRect:submorphs:to:! - -!methodRemoval: BitBltBoundsFinderCanvas #fullAddCurrentRect:submorphs:to: stamp: 'Install-4790-BoundsFInderFix-JuanVuletich-2021Aug23-12h13m-jmv.001.cs.st 8/24/2021 17:32:17'! -fullAddCurrentRect: addCurrentBounds submorphs: trySubmorphs to: aDamageRecorder - - | invalidateOwns | - invalidateOwns _ false. - addCurrentBounds ifTrue: [ - currentMorph needsRedraw: false. - self updateCurrentBounds. - invalidateOwns _ true ]. - trySubmorphs ifTrue: [ - (currentMorph submorphsMightProtrude and: [currentMorph clipsSubmorphsReally not]) - ifTrue: [ - currentMorph submorphNeedsRedraw: false. - currentMorph submorphsReverseDo: [ :m | - self fullAddRedrawRect: m to: aDamageRecorder ]] - ifFalse: [ - currentMorph fullRedrawNotNeeded. - invalidateOwns _ true ]]. - invalidateOwns ifTrue: [ - aDamageRecorder recordInvalidRect: currentMorph displayBounds for: currentMorph ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4790-BoundsFInderFix-JuanVuletich-2021Aug23-12h13m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4789] on 23 August 2021 at 12:15:48 pm'! -!InnerListMorph methodsFor: 'list management' stamp: 'jmv 8/22/2021 19:02:22' prior: 16855331! - highlightedRow: n - highlightedRow = n ifFalse: [ - highlightedRow ifNotNil: [ - self invalidateLocalRect: (self drawBoundsForRow: highlightedRow) ]. - highlightedRow _ n. - highlightedRow ifNotNil: [ - self invalidateLocalRect: (self drawBoundsForRow: highlightedRow) ]. - ].! ! -!InnerListMorph methodsFor: 'list management' stamp: 'jmv 8/22/2021 19:03:57' prior: 16855112! - selectedRow: index - "select the index-th row. if nil, remove the current selection" - selectedRow = index ifFalse: [ - selectedRow ifNotNil: [ - self invalidateLocalRect: (self drawBoundsForRow: selectedRow) ]. - highlightedRow ifNotNil: [ - self invalidateLocalRect: (self drawBoundsForRow: highlightedRow) ]. - selectedRow _ index. - highlightedRow _ nil. - selectedRow ifNotNil: [ - self invalidateLocalRect: (self drawBoundsForRow: selectedRow) ]. - ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4791-ListMorphInvalidation-speedup-JuanVuletich-2021Aug23-12h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4789] on 23 August 2021 at 12:17:59 pm'! -!TheWorldMenu class methodsFor: 'menu building' stamp: 'jmv 8/23/2021 10:15:43' prior: 50599670! - worldMenuOptions - - ^`{{ - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Open...'. - #selector -> #openOpenMenu. - #icon -> #openIcon. - #balloonText -> 'Submenu to open various system tools'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'New morph...'. - #selector -> #newMorph. - #icon -> #morphsIcon. - #balloonText -> 'Offers a variety of ways to create new objects'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Preferences...'. - #selector -> #openPreferencesMenu. - #icon -> #preferencesIcon. - #balloonText -> 'Opens a menu offering many controls over appearance and system preferences.'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'Windows...'. - #selector -> #openWindowsMenu. - #icon -> #windowIcon. - #balloonText -> 'Manage open windows'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 50. - #label -> 'Help...'. - #selector -> #openHelpMenu. - #icon -> #helpIcon. - #balloonText -> 'Opens a menu of useful items for updating the system, determining what version you are running, and much else'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Changes...'. - #selector -> #openChangesMenu. - #icon -> #changesIcon. - #balloonText -> 'Opens a menu of useful tools for dealing with changes'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Debug...'. - #selector -> #openDebugMenu. - #icon -> #debugIcon. - #balloonText -> 'a menu of debugging items'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'Restore Display'. - #object -> #myWorld. - #selector -> #restoreDisplay. - #icon -> #displayIcon. - #balloonText -> 'Repaint the screen -- useful for cleaning unwanted display artifacts.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Save Image'. - #object -> Smalltalk. - #selector -> #saveImage. - #icon -> #saveIcon. - #balloonText -> 'Save the current state of the image on disk. Overwrite existing file.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Save Image as...'. - #object -> Smalltalk. - #selector -> #saveAs. - #icon -> #saveAsIcon. - #balloonText -> 'Save the current state of the image on disk under a new name.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'Save Release and Quit'. - #object -> Smalltalk. - #selector -> #saveAsNewReleaseAndQuit. - #icon -> #saveAsNewVersionIcon. - #balloonText -> ('Save as a new release of Cuis.\', - 'Clear all user preferences and user state (class vars).\', - 'Use an updated version-stamped name\', - 'and save the image with that name on disk.\', - 'Quit Cuis.') withNewLines. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 40. - #label -> 'Save Image and Quit'. - #object -> Smalltalk. - #selector -> #saveAndQuit. - #icon -> #saveAndQuitIcon. - #balloonText -> 'Save the image and quit out of Cuis. Overwrite existing file.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 50. - #label -> 'Quit without saving'. - #selector -> #quitSession. - #icon -> #quitIcon. - #balloonText -> ('Quit out of Cuis without saving the image.\', - 'Ask for confirmation if there are unsaved changes.') withNewLines. - } asDictionary. -}`! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4792-WorldMenu-tweaks-HernanWilkinson-JuanVuletich-2021Aug23-12h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4789] on 23 August 2021 at 12:19:38 pm'! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 8/23/2021 10:31:06'! - haloShowsCoordinateSystem - - ^Preferences halosShowCoordinateSystem! ! -!WidgetMorph methodsFor: 'halos and balloon help' stamp: 'jmv 8/23/2021 10:33:53' overrides: 50601321! - haloShowsCoordinateSystem - "We are usually not concerned with this level of detail for Widgets, as they prefer using automatic Layout." - - ^false! ! -!HaloMorph methodsFor: 'drawing' stamp: 'jmv 8/23/2021 10:34:32' prior: 50596373 overrides: 16899205! - drawOn: aCanvas - - | b | - target ifNil: [^super drawOn: aCanvas]. - "Debugging aid" - "aCanvas - fillRectangle: haloBox - color: (Color red alpha: 0.2). - aCanvas - fillRectangle: self morphLocalBounds - color: (Color gray alpha: 0.4)." - target haloShowsCoordinateSystem ifTrue: [ - target displayFullBounds ifNotNil: [ :fb | - aCanvas frameGlobalRect: fb borderWidth: 3 color: `Color black alpha: 0.1`. - b _ target displayBounds. - b = fb ifFalse: [ - aCanvas frameGlobalRect: b borderWidth: 3 color: `Color black alpha: 0.1` ]. - self drawCoordinateSystemOn: aCanvas ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4793-DontShowCoordinateSystemForWidgets-HernanWilkinson-JuanVuletich-2021Aug23-12h17m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4793] on 23 August 2021 at 1:58:19 pm'! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 8/23/2021 13:55:11' overrides: 50593688! - findFullBoundsInOwner - "Find and answer full bounds in whatever owner. - These might not equal #displayFullBounds at all!!" - - self requiresVectorCanvas ifTrue: [ - ^super findFullBoundsInOwner ]. - - "#morphExtent exists, and it is also valid in owner, because #requiresVectorCanvas is false." - ^(self morphPosition extent: self morphExtent) encompassingIntegerRectangle.! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/23/2021 13:55:25' overrides: 50593688! - findFullBoundsInOwner - "Find and answer full bounds in whatever owner. - These might not equal #displayFullBounds at all!!" - - self requiresVectorCanvas ifTrue: [ - ^super findFullBoundsInOwner ]. - - "#morphExtent exists, and it is also valid in owner, because #requiresVectorCanvas is false." - ^(self morphPosition extent: self morphExtent) encompassingIntegerRectangle.! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/23/2021 13:57:28' prior: 50593688! - findFullBoundsInOwner - "Find and answer full bounds in whatever owner. - These might not equal #displayFullBounds at all!! - Subclasses need to redefine this method. - Alternatively, VectorGraphics provides a working implementation as an override." - - self subclassResponsibility.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4794-findFullBoundsInOwner-refactor-JuanVuletich-2021Aug23-13h55m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4794] on 23 August 2021 at 2:35:05 pm'! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 8/23/2021 14:33:25' prior: 50601090! - fullAddCurrentMorphTo: aDamageRecorder - - currentMorph isRedrawNeeded ifTrue: [ - currentMorph needsRedraw: false. - self updateCurrentBounds. - aDamageRecorder recordInvalidRect: currentMorph displayBounds for: currentMorph ]. - currentMorph isSubmorphRedrawNeeded ifTrue: [ - currentMorph submorphNeedsRedraw: false. - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | - self fullAddRedrawRect: m to: aDamageRecorder ]]].! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 8/23/2021 14:31:43' prior: 50595997 overrides: 50501573! - setClipRect: aRectangle - "In targetForm coordinates" - - super setClipRect: aRectangle. - engine clipRect: aRectangle. - boundsFinderCanvas ifNotNil: [ - boundsFinderCanvas setClipRect: aRectangle ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4795-clipRectInBoundsFinder-JuanVuletich-2021Aug23-14h29m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4795] on 23 August 2021 at 5:41:13 pm'! -!Preferences class methodsFor: 'standard queries' stamp: 'jmv 8/23/2021 15:24:10'! - drawKeyboardFocusIndicator - ^ self - valueOfFlag: #drawKeyboardFocusIndicator - ifAbsent: [ true ]! ! -!TextModelMorph methodsFor: 'accessing' stamp: 'jmv 8/23/2021 15:04:09'! - drawKeyboardFocusIndicator - "For InnerTextMorph" - - ^drawKeyboardFocusIndicator! ! -!Preferences class methodsFor: 'themes' stamp: 'jmv 8/23/2021 15:24:54' prior: 50598792! - cuisDefaults - self setPreferencesFrom: #( - #(#drawKeyboardFocusIndicator true ) - #(#balloonHelpEnabled true ) - #(#biggerCursors false ) - #(#browseWithPrettyPrint false ) - #(#caseSensitiveFinds false ) - #(#checkForSlips true ) - #(#cmdDotEnabled true ) - #(#diffsInChangeList true ) - #(#diffsWithPrettyPrint false ) - #(#menuKeyboardControl true ) - #(#optionalButtons true ) - #(#extraDebuggerButtons true ) - #(#subPixelRenderFonts true ) - #(#thoroughSenders true ) - #(#cheapWindowReframe false ) - #(#syntaxHighlightingAsYouType true ) - #(#tapAndHoldEmulatesButton2 true ) - #(#clickGrabsMorphs false ) - #(#syntaxHighlightingAsYouTypeAnsiAssignment false ) - #(#syntaxHighlightingAsYouTypeLeftArrowAssignment false ) - ). - self useMenuIcons.! ! -!Preferences class methodsFor: 'themes' stamp: 'jmv 8/23/2021 15:25:08' prior: 50391996! - slowMachine - " - Preferences slowMachine - " - self setPreferencesFrom: #( - #(#drawKeyboardFocusIndicator false ) - (balloonHelpEnabled false) - (browseWithPrettyPrint false) - (caseSensitiveFinds true) - (checkForSlips false) - (cmdDotEnabled true) - (diffsInChangeList true) - (diffsWithPrettyPrint false) - (menuKeyboardControl false) - (optionalButtons false) - (subPixelRenderFonts true) - (thoroughSenders true) - (cheapWindowReframe true) - (syntaxHighlightingAsYouType false) - (tapAndHoldEmulatesButton2 false) - (clickGrabsMorphs true) - ). - self useNoMenuIcons. - self runningWorld backgroundImageData: nil. - " - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - Taskbar hideTaskbar - "! ! -!Preferences class methodsFor: 'themes' stamp: 'jmv 8/23/2021 15:25:36' prior: 50392020! -smalltalk80 - "A traditional monochrome Smalltalk-80 look and feel, clean and austere, and lacking many features added to Squeak and Cuis in recent years. Caution: turns off the 'smartUpdating' feature that keeps multiple browsers in synch, and much more. - - Preferences smalltalk80 - " - - self setPreferencesFrom: - - #( - (drawKeyboardFocusIndicator false ) - (balloonHelpEnabled false) - (browseWithPrettyPrint false) - (caseSensitiveFinds true) - (checkForSlips false) - (cmdDotEnabled true) - (diffsInChangeList false) - (diffsWithPrettyPrint false) - (menuKeyboardControl false) - (optionalButtons false) - (subPixelRenderFonts true) - (thoroughSenders false) - (cheapWindowReframe true) - (syntaxHighlightingAsYouType false) - (tapAndHoldEmulatesButton2 false) - (clickGrabsMorphs true) - ). - self useNoMenuIcons. - " - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - Taskbar hideTaskbar - "! ! -!InnerTextMorph methodsFor: 'event handling' stamp: 'jmv 8/23/2021 15:05:27' prior: 50381254 overrides: 50590269! -keyboardFocusChange: aBoolean - - "The message is sent to a morph when its keyboard focus changes. - The given argument indicates that the receiver is gaining (versus losing) the keyboard focus. - In this case, all we need to do is to redraw border feedback" - aBoolean - ifTrue: [ - "A hand is wanting to send us characters..." - editor ifNil: [ self editor storeSelectionInComposition ]. "Forces install" - self showsBlinkingCursor ifTrue: [ - editor hasSelection ifFalse: [ - self startBlinking ]]] - ifFalse: [ self stopBlinking ]. - - (owner notNil and: [ owner drawKeyboardFocusIndicator ]) - ifTrue: [ owner redrawNeeded ] - ifFalse: [ - "Selection might be shown differently when focused" - self textComposition selectionRects do: [ :r | self invalidateLocalRect: r ]] .! ! -!PluggableScrollPane methodsFor: 'initialization' stamp: 'jmv 8/23/2021 15:23:44' prior: 50578397 overrides: 50384377! - initialize - - "initialize the state of the receiver" - super initialize. - hideScrollBars _ #showIfNeeded. - - "initialize the receiver's scrollBars" - scrollBar _ ScrollBar new model: self setValueSelector: #vScrollBarValue:. - hScrollBar _ ScrollBar new model: self setValueSelector: #hScrollBarValue:. - drawKeyboardFocusIndicator _ Preferences drawKeyboardFocusIndicator. - - scroller _ self innerMorphClass new. - self addMorph: scroller. - self scrollerOffset: `0@ 0`. - self addMorph: scrollBar. - self addMorph: hScrollBar! ! -!HierarchicalListMorph methodsFor: 'event handling' stamp: 'jmv 8/23/2021 15:20:44' prior: 16853032 overrides: 50590269! - keyboardFocusChange: aBoolean - "The message is sent to a morph when its keyboard focus changes. - The given argument indicates that the receiver is gaining (versus losing) the keyboard focus. - In this case, all we need to do is to redraw focus feedback" - - - drawKeyboardFocusIndicator - ifTrue: [self redrawNeeded] - ifFalse: [ - selectedMorph ifNotNil: [ selectedMorph redrawNeeded ]]! ! -!PluggableListMorph methodsFor: 'event handling' stamp: 'jmv 8/23/2021 15:33:41' prior: 16888689 overrides: 50590269! - keyboardFocusChange: aBoolean - "The message is sent to a morph when its keyboard focus changes. - The given argument indicates that the receiver is gaining (versus losing) the keyboard focus. - In this case, all we need to do is to redraw focus feedback" - - drawKeyboardFocusIndicator - ifTrue: [self redrawNeeded] - ifFalse: [ - scroller selectedRow - ifNotNil: [ :i | - scroller selectedRow: nil; selectedRow: i ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4796-drawKeyboardFocusChange-Preference-JuanVuletich-2021Aug23-17h39m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4796] on 23 August 2021 at 6:55:39 pm'! - -InnerPluggableMorph subclass: #InnerTextMorph - instanceVariableNames: 'model wrapFlag textComposition editor pauseBlinking acceptOnCR hasUnacceptedEdits hasEditingConflicts askBeforeDiscardingEdits styler autoCompleter mutex needsFit ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #InnerTextMorph category: 'Morphic-Widgets' stamp: 'Install-4797-DontRefreshIfTextHasntChanged-JuanVuletich-2021Aug23-18h53m-jmv.001.cs.st 8/24/2021 17:32:18'! -InnerPluggableMorph subclass: #InnerTextMorph - instanceVariableNames: 'model wrapFlag textComposition editor pauseBlinking acceptOnCR hasUnacceptedEdits hasEditingConflicts askBeforeDiscardingEdits styler autoCompleter mutex needsFit' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! -!InnerTextMorph methodsFor: 'editing' stamp: 'jmv 8/23/2021 16:47:31' prior: 50368960! - hasUnacceptedEdits: aBoolean - "Set the hasUnacceptedEdits flag to the given value. " - aBoolean == hasUnacceptedEdits ifFalse: [ - hasUnacceptedEdits _ aBoolean]. - aBoolean ifFalse: [ hasEditingConflicts _ false]. - - "shout: re-style the text iff aBoolean is true - Do not apply any formatting (i.e. changes to the characters in the text), - just styling (i.e. TextAttributes)" - aBoolean ifTrue: [ - self formatAndStyleIfNeeded ]. - needsFit _ aBoolean.! ! -!InnerTextMorph methodsFor: 'initialization' stamp: 'jmv 8/23/2021 16:47:24' prior: 16855909 overrides: 50545903! - initialize - super initialize. - wrapFlag _ true. - acceptOnCR _ false. - hasUnacceptedEdits _ false. - hasEditingConflicts _ false. - askBeforeDiscardingEdits _ true. - needsFit _ false.! ! -!InnerTextMorph methodsFor: 'private' stamp: 'jmv 8/23/2021 18:54:55' prior: 16856088! - updateFromTextComposition - "A change has taken place in my textComposition, as a result of editing and I must be updated. " - - textComposition ifNotNil: [ - editor storeSelectionInComposition. - needsFit ifTrue: [ - self fit. - needsFit _ false ]]. - - owner - updateScrollBarsBounds; - setScrollDeltas.! ! - -InnerPluggableMorph subclass: #InnerTextMorph - instanceVariableNames: 'model wrapFlag textComposition editor pauseBlinking acceptOnCR hasUnacceptedEdits hasEditingConflicts askBeforeDiscardingEdits styler autoCompleter mutex needsFit' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #InnerTextMorph category: 'Morphic-Widgets' stamp: 'Install-4797-DontRefreshIfTextHasntChanged-JuanVuletich-2021Aug23-18h53m-jmv.001.cs.st 8/24/2021 17:32:18'! -InnerPluggableMorph subclass: #InnerTextMorph - instanceVariableNames: 'model wrapFlag textComposition editor pauseBlinking acceptOnCR hasUnacceptedEdits hasEditingConflicts askBeforeDiscardingEdits styler autoCompleter mutex needsFit' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -InnerTextMorph allInstancesDo: [ :it | it instVarNamed: 'needsFit' put: false ].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4797-DontRefreshIfTextHasntChanged-JuanVuletich-2021Aug23-18h53m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4779] on 23 August 2021 at 7:37:18 pm'! - -Object subclass: #DamageRecorder - instanceVariableNames: 'drSemaphore damageByRoot otherDamage ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #DamageRecorder category: #'Morphic-Support' stamp: 'Install-4798-DamageRecorderEnhancements-JuanVuletich-2021Aug23-19h35m-jmv.001.cs.st 8/24/2021 17:32:18'! -Object subclass: #DamageRecorder - instanceVariableNames: 'drSemaphore damageByRoot otherDamage' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! -!DamageRecorder methodsFor: 'initialization' stamp: 'jmv 8/23/2021 18:44:22' prior: 50539451 overrides: 16896425! - initialize - damageByRoot _ IdentityDictionary new. - otherDamage _ OrderedCollection new.! ! -!DamageRecorder methodsFor: 'recording' stamp: 'jmv 8/23/2021 18:51:09' prior: 50543962! - damageReportedOther - "Answer damage reported for no specific morph, for morphs that are not visible, and for morphs that are carried by the Hand." - | answer | - answer _ OrderedCollection new. - self pvtAccessProtect critical: [ - damageByRoot keysAndValuesDo: [ :m :r | - (m visible not or: [m owner isNil or: [m owner is: #HandMorph]]) ifTrue: [ - answer add: r]]. - otherDamage do: [ :r | answer add: r ]. - ]. - ^answer! ! -!DamageRecorder methodsFor: 'recording' stamp: 'jmv 8/23/2021 19:01:20' prior: 50539457! - reset - "Clear the damage list." - self pvtAccessProtect critical: [ - damageByRoot removeAll. - otherDamage removeAll. ].! ! -!DamageRecorder methodsFor: 'testing' stamp: 'jmv 8/23/2021 18:48:47' prior: 50539463! - updateIsNeeded - "Return true if the display needs to be updated." - ^ self pvtAccessProtect critical: [damageByRoot notEmpty or: [otherDamage notEmpty]]! ! -!DamageRecorder methodsFor: 'private' stamp: 'jmv 8/23/2021 18:49:49' prior: 50539470! - pvtInnerRecordInvalidRect: requestedRect for: aRootMorph - "Record the given rectangle in my damage list, a list of rectangular areas of the display that should be redraw on the next display cycle." - | newRect | - newRect _ requestedRect encompassingIntegerRectangle. - aRootMorph ifNotNil: [ - damageByRoot at: aRootMorph put: - (damageByRoot at: aRootMorph - ifPresent: [:r | r quickMerge: newRect] - ifAbsent: [newRect]) ] - ifNil: [otherDamage add: newRect].! ! - -Object subclass: #DamageRecorder - instanceVariableNames: 'drSemaphore damageByRoot otherDamage' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #DamageRecorder category: #'Morphic-Support' stamp: 'Install-4798-DamageRecorderEnhancements-JuanVuletich-2021Aug23-19h35m-jmv.001.cs.st 8/24/2021 17:32:18'! -Object subclass: #DamageRecorder - instanceVariableNames: 'drSemaphore damageByRoot otherDamage' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -DamageRecorder allInstancesDo: [ :dr | dr instVarNamed: 'otherDamage' put: OrderedCollection new ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4798-DamageRecorderEnhancements-JuanVuletich-2021Aug23-19h35m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4797] on 23 August 2021 at 7:19:56 pm'! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 8/23/2021 19:16:24' prior: 50594820 overrides: 50594610! - addPossiblyUncoveredAreasIn: aRectangle to: aCollection - "Answer an array of rectangles encompassing those areas in aRectangle not completely - covered by self. These are the areas that might require further drawing (of morphs below us) - All areas that might possibly be uncovered must be included." - - | bounds r e | - self isOrAnyOwnerIsRotated ifTrue: [ - aCollection add: aRectangle. - ^self ]. - - color mightBeTranslucent ifTrue: [ - aCollection add: aRectangle. - ^self ]. - - bounds _ self displayBounds. - bounds ifNil: [ - aCollection add: aRectangle. - ^self ]. - - "Solid rectangle. - This will be the fastest in many cases. So, please disable rounded corners if on slow hardware!!" - aRectangle areasOutside: bounds do: [ :rect | aCollection add: rect ]. - - "Add area around rounded corners if needed." - Theme current roundWindowCorners ifTrue: [ - r _ Theme current roundedWindowRadius. - e _ r@r. - aCollection add: (aRectangle intersect: (bounds topLeft extent: e)). - aCollection add: (aRectangle intersect: (bounds topRight - (r@0) extent: e)). - aCollection add: (aRectangle intersect: (bounds bottomLeft - (0@r)extent: e)). - aCollection add: (aRectangle intersect: (bounds bottomRight - (r@r) extent: e)). - ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/23/2021 19:19:51' prior: 50595510! - drawWorld: aWorldMorph repair: aDamageRecorder - "Redraw the damaged areas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | visibleRootMorphs visibleRootsDamage worldDamage | - "Update #displayBounds for all dirty morphs (marked as such with #redrawNeeded). - Also add the updated bounds to aDamageRecorder, and update bounds of morphs carried by hand." - self boundsFinderCanvas updateBoundsIn: aWorldMorph addDamageTo: aDamageRecorder. - - visibleRootMorphs _ aWorldMorph privateSubmorphs select: [ :m | m visible ]. - visibleRootsDamage _ Array new: visibleRootMorphs size. - - worldDamage _ self computeDamage: aWorldMorph repair: aDamageRecorder - rootMorphs: visibleRootMorphs rootMorphsDamage: visibleRootsDamage. - - self drawWorldBackground: aWorldMorph rects: worldDamage. - "Debugging aids." - " - worldDamage do: [ :r | Display fill: r fillColor: Color random . Display forceToScreen. (Delay forSeconds: 0.005) wait]. - "" - visibleRootsDamage do: [ :r | r ifNotNil: [ Display fill: r fillColor: Color random . Display forceToScreen. (Delay forSeconds: 0.05) wait]]. - " - self drawWorld: aWorldMorph - rootMorphs: visibleRootMorphs rootMorphsDamage: visibleRootsDamage - allDamage: worldDamage. - - aDamageRecorder reset. - ^ worldDamage! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4799-Morphic-Invalidation-tweaks-JuanVuletich-2021Aug23-19h02m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4799] on 24 August 2021 at 12:00:58 pm'! -!DamageRecorder methodsFor: 'recording' stamp: 'jmv 8/24/2021 11:03:44' prior: 50601769! - damageReportedOther - "Answer damage reported for no specific morph, for morphs that are not visible, and for morphs that are carried by the Hand." - | answer possiblyMoreRectsToMerge | - answer _ OrderedCollection new. - self pvtAccessProtect critical: [ - damageByRoot keysAndValuesDo: [ :m :r | - (m visible not or: [m owner isNil or: [m owner is: #HandMorph]]) ifTrue: [ - answer add: r]]. - otherDamage do: [ :r | answer add: r ]. - ]. - possiblyMoreRectsToMerge _ true. - [possiblyMoreRectsToMerge] whileTrue: [ - possiblyMoreRectsToMerge _ false. - answer withIndexDo: [ :r1 :i | - r1 ifNotNil: [ - i+1 to: answer size do: [ :j | | r2 | - r2 _ answer at: j. - r2 ifNotNil: [ - (r1 intersects: r2) ifTrue: [ - answer at: i put: (r1 quickMerge: r2). - answer at: j put: nil. - possiblyMoreRectsToMerge _ true ]]]]]]. - answer _ answer select: [ :r | r notNil ]. - ^answer! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4800-DamageReporter-mergeOverlappingRects-JuanVuletich-2021Aug24-12h00m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4799] on 24 August 2021 at 11:59:48 am'! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 8/24/2021 10:58:39' prior: 50601855 overrides: 50594610! - addPossiblyUncoveredAreasIn: aRectangle to: aCollection - "Answer an array of rectangles encompassing those areas in aRectangle not completely - covered by self. These are the areas that might require further drawing (of morphs below us) - All areas that might possibly be uncovered must be included." - - | bounds | - self isOrAnyOwnerIsRotated ifTrue: [ - aCollection add: aRectangle. - ^self ]. - - color mightBeTranslucent ifTrue: [ - aCollection add: aRectangle. - ^self ]. - - bounds _ self displayBounds. - bounds ifNil: [ - aCollection add: aRectangle. - ^self ]. - - "Solid rectangle. - This will be the fastest in many cases. So, please disable rounded corners if on slow hardware!!" - Theme current roundWindowCorners ifFalse: [ - aRectangle areasOutside: bounds do: [ :rect | aCollection add: rect ]. - ^self ]. - - "The solid rectangle does not include the corners. - Report a couple of rows (top and bottom) or columns (left and right) as uncovered areas. - We could also try to be more careful and answer each rounded corner... - Right now, report top and bottom rows as uncovered areas: - - Rows are contiguous in Display memory - - Redrawing title area wont trigger redrawing all windows contents." - " - radius _ Theme current roundedWindowRadius. - aRectangle areasOutside: (bounds insetBy: 0@radius) do: [ :rect | aCollection add: rect ]. - " - "Alternative: just include window borders. Almost correct, and cheaper." - aRectangle areasOutside: (bounds insetBy: Theme current windowBorderWidth) do: [ :rect | aCollection add: rect ]. - -"Note: Doing this after the non-rounded-corner case gave bad results. Not letting the size of aCollection grow without bounds is more important than not answering extra areas. - Theme current roundWindowCorners ifTrue: [ - r _ Theme current roundedWindowRadius. - e _ r@r. - aCollection add: (aRectangle intersect: (bounds topLeft extent: e)). - aCollection add: (aRectangle intersect: (bounds topRight - (r@0) extent: e)). - aCollection add: (aRectangle intersect: (bounds bottomLeft - (0@r)extent: e)). - aCollection add: (aRectangle intersect: (bounds bottomRight - (r@r) extent: e)). - ]."! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4801-WindowDamageReportingFix-JuanVuletich-2021Aug24-11h58m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4799] on 24 August 2021 at 12:00:18 pm'! -!CodeWindow methodsFor: 'updating' stamp: 'jmv 8/24/2021 11:42:18' prior: 16813226! - updateListsAndCode - "All code windows receive this message on any code change in the system" - - model ifNotNil: [ - self canDiscardEdits ifTrue: [ - self allMorphsDo: [ :m | (m is: #PluggableListMorph) ifTrue: [ m verifyContents ]]. - model updateIfNeeded ]]! ! -!VersionsBrowserWindow methodsFor: 'updating' stamp: 'jmv 8/24/2021 11:42:36' prior: 16942863 overrides: 50602067! - updateListsAndCode - "All code windows receive this message on any code change in the system" - - model ifNotNil: [ - model updateIfNeeded ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4802-updateListsAndCode-fix-JuanVuletich-2021Aug24-11h59m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4799] on 24 August 2021 at 12:01:35 pm'! -!ChangeSet class methodsFor: 'change set to use' stamp: 'jmv 8/24/2021 11:41:19' prior: 50422659! - installing: aCodePackageOrChangeSetName do: aBlock - - | currentCS currentCSNumber newHighestUpdate | - SystemChangeNotifier uniqueInstance - doSilently: [ - Installing _ 'Install-', aCodePackageOrChangeSetName. - aBlock ensure: [ Installing _ nil ]]. - CodeWindow allSubInstancesDo: [ :w | w updateListsAndCode ]. - Smalltalk forceChangesToDisk. - - SystemVersion current registerUpdate: aCodePackageOrChangeSetName. - newHighestUpdate _ SystemVersion current highestUpdate. - - currentCSNumber _ self currentBaseCSNumber. - currentCS _ self changeSetForBaseSystem. - currentCS isEmpty ifTrue: [ - ChangeSet removeChangeSet: currentCS. - currentCSNumber > newHighestUpdate ifFalse: [ - CurrentBaseCSNumber _ newHighestUpdate + 1 ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4803-FasterPackageAndChangeSetInstall-JuanVuletich-2021Aug24-12h00m-jmv.001.cs.st----! -!FileList methodsFor: 'user interface' stamp: 'KLG 8/23/2021 20:51:44'! - toggleInitialDirectory - "Toggle the initial directory setting of the currently selected directory." - - | directoryEntry | - Preferences isInitialFileListDirectory: (directoryEntry _ currentDirectorySelected item):: - ifTrue: [ - Preferences removeInitialFileListDirectory: directoryEntry ] - ifFalse: [ - Preferences addInitialFileListDirectory: directoryEntry ]! ! -!Preferences class methodsFor: 'file list' stamp: 'KLG 8/23/2021 20:33:08'! - addInitialFileListDirectory: aDirectoryEntry - "Add an initial directory entry to the collection of initial directories." - - | currentValue | - (currentValue _ self initialFileListDirectories) isSymbol - ifTrue: [ - self initialFileListDirectories: (Set with: aDirectoryEntry) ] - ifFalse: [ - currentValue add: aDirectoryEntry ] - ! ! -!Preferences class methodsFor: 'file list' stamp: 'KLG 8/23/2021 20:01:01'! - initialFileListDirectories - "Answer the initial collection of file list directory entries. - - Special values: - - #root: Use the usual roots - #image: Use the image directory - #vm: Use the vm directory - #current: Use the current directory " - - ^ self - valueOfFlag: #initialFileListDirectories - ifAbsent: [ #roots ].! ! -!Preferences class methodsFor: 'file list' stamp: 'KLG 8/23/2021 19:53:28'! - initialFileListDirectories: aValue - "Set the initial fileList directories. - - See #initialFileListDirectories " - ^ self setPreference: #initialFileListDirectories toValue: aValue! ! -!Preferences class methodsFor: 'file list' stamp: 'KLG 8/23/2021 20:40:48'! - isInitialFileListDirectory: aDirectoryEntry - "Answer true if aDirectoryEntry is an initial directory entry." - - | currentValue | - (currentValue _ self initialFileListDirectories) isSymbol ifTrue: [ ^ false ]. - ^ currentValue includes: aDirectoryEntry! ! -!Preferences class methodsFor: 'file list' stamp: 'KLG 8/23/2021 20:35:42'! - removeInitialFileListDirectory: aDirectoryEntry - "Add an initial directory entry to the collection of initial directories." - - | currentValue | - (currentValue _ self initialFileListDirectories) isSymbol ifTrue: [ ^ self ]. - currentValue remove: aDirectoryEntry ifAbsent: [] . - currentValue ifEmpty: [ self initialFileListDirectories: #roots ]! ! -!Preferences class methodsFor: 'system startup' stamp: 'KLG 8/23/2021 21:33:24' overrides: 16784996! -initClassCachedState - "Check the initial file list directories for existence." - - | initialDirectories | - (initialDirectories _ self initialFileListDirectories) isSymbol ifTrue: [ ^ self ]. - initialDirectories copy do: [ :directoryEntry | - directoryEntry exists ifFalse: - [ self removeInitialFileListDirectory: directoryEntry ] ]! ! -!FileList methodsFor: 'initialization' stamp: 'KLG 8/23/2021 20:24:48' prior: 16842599! - initialDirectoryList - - | initialDirectoryListFromPreferences wrapperCreator | - wrapperCreator _ [ :directoryEntry | - FileDirectoryWrapper - with: directoryEntry - name: (directoryEntry name ifNil: [ '/' ]) - model: self ]. - (initialDirectoryListFromPreferences _ Preferences initialFileListDirectories) - caseOf: { - [ #roots ] -> [ | dirList | - dirList _ DirectoryEntry roots collect: wrapperCreator. - dirList isEmpty ifTrue: [ - dirList _ Array with: (FileDirectoryWrapper - with: directory - name: directory localName - model: self) ]. - ^ dirList ]. - [ #image ] -> [ - ^ { wrapperCreator value: DirectoryEntry smalltalkImageDirectory } ]. - [ #vm ] -> [ - ^ { wrapperCreator value: DirectoryEntry vmDirectory } ]. - [ #current ] -> [ - ^ { wrapperCreator value: DirectoryEntry currentDirectory } ] } - otherwise: [ ^ initialDirectoryListFromPreferences collect: wrapperCreator ]! ! -!FileListWindow methodsFor: 'menu building' stamp: 'KLG 8/23/2021 21:39:39' prior: 50400042! -volumeMenu - | aMenu initialDirectoriesMenu | - aMenu _ MenuMorph new defaultTarget: model. - aMenu - add: 'delete directory...' - action: #deleteDirectory - icon: #warningIcon :: setBalloonText: 'Delete the selected directory'. - model currentDirectorySelected - ifNil: [ aMenu add: 'initial directory' action: #yourself :: isEnabled: false ] - ifNotNil: [ :selectedWrapper | - aMenu - add: (Preferences isInitialFileListDirectory: selectedWrapper item :: - ifTrue: [ '' ] - ifFalse: [ '' ]), 'initial directory' - action: #toggleInitialDirectory :: - setBalloonText: 'The selected directory is an initial director for new file list windows' ]. - initialDirectoriesMenu _ MenuMorph new. - #( - (roots 'default roots' 'Use the usual root directories. Drives on Windows; "/" on Unix') - (image 'image directory' 'Use the directory with Smalltalk image') - (vm 'VM directory' 'Use the virtual machine directory') - (current 'current directory' 'Use the current directory; usually the directory the VM was started in') - ) - do: [ :entry | - initialDirectoriesMenu - add: entry second - target: Preferences - action: #initialFileListDirectories: - argument: entry first :: - setBalloonText: entry third ]. - aMenu add: 'default initial directories' subMenu: initialDirectoriesMenu. - ^ aMenu! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4804-ConfigurableInitialDirectoriesInFileList-GeraldKlix-2021Aug23-19h22m-KLG.001.cs.st----! -!Rectangle methodsFor: 'rectangle functions' stamp: 'jmv 8/24/2021 16:36:44'! - updateMerging: aRectangle - "Modify receiver" - - origin _ origin min: aRectangle origin. - corner _ corner max: aRectangle corner.! ! -!DamageRecorder methodsFor: 'recording' stamp: 'jmv 8/24/2021 16:37:48' prior: 50601950! - damageReportedOther - "Answer damage reported for no specific morph, for morphs that are not visible, and for morphs that are carried by the Hand." - | answer possiblyMoreRectsToMerge | - answer _ OrderedCollection new. - self pvtAccessProtect critical: [ - damageByRoot keysAndValuesDo: [ :m :r | - (m visible not or: [m owner isNil or: [m owner is: #HandMorph]]) ifTrue: [ - answer add: r]]. - otherDamage do: [ :r | answer add: r ]. - ]. - possiblyMoreRectsToMerge _ true. - [possiblyMoreRectsToMerge] whileTrue: [ - possiblyMoreRectsToMerge _ false. - answer withIndexDo: [ :r1 :i | - r1 ifNotNil: [ - i+1 to: answer size do: [ :j | | r2 | - r2 _ answer at: j. - r2 ifNotNil: [ - (r1 intersects: r2) ifTrue: [ - r1 updateMerging: r2. - answer at: j put: nil. - possiblyMoreRectsToMerge _ true ]]]]]]. - answer _ answer select: [ :r | r notNil ]. - ^answer! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4805-DamageRecorder-fix-JuanVuletich-2021Aug24-16h28m-jmv.001.cs.st----! - -----QUIT----(24 August 2021 17:32:23) Cuis5.0-4805-32.image priorSource: 8582306! - -----STARTUP---- (24 August 2021 20:35:47) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4805-32.image! - -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 8/24/2021 18:32:57'! - saveAndStayAs: newName clearAllClassState: clearAllStateFlag - "Save the image under a new name. Don't quit. - See senders." - - | newChangesName | - self currentChangesName ifNotNil: [ :oldChangesName | - self closeSourceFiles. "so copying the changes file will always work" - newChangesName _ self fullNameForChangesNamed: newName. - FileIOAccessor default copy: oldChangesName asFileEntry to: newChangesName asFileEntry. - ChangesInitialFileSize ifNotNil: [ - oldChangesName asFileEntry appendStreamDo: [ :strm | strm truncate: ChangesInitialFileSize ]]]. - - ChangeSet zapAllChangeSets. - self - changeImageNameTo: (self fullNameForImageNamed: newName); - closeSourceFiles; openSourceFiles; "so SNAPSHOT appears in new changes file" - snapshot: true andQuit: false embedded: false clearAllClassState: clearAllStateFlag.! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 8/24/2021 18:33:03'! - saveAsNewReleaseAndStay - "Save the image/changes using the next available version number. - This is usually only used to prepare updated Cuis images for distribution." - " - Smalltalk saveAsNewReleaseAndStay - " - | fileName newName changesName systemVersion | - systemVersion _ SystemVersion current. - fileName _ String streamContents: [ :strm | - strm - nextPutAll: 'Cuis'; - print: systemVersion versionMajor; - nextPut: $.; - print: systemVersion versionMinor; - nextPut: $-; - print: systemVersion highestUpdate. - Smalltalk isSpur - ifTrue: [ - Smalltalk wordSize = 4 ifTrue: [ - strm nextPutAll: '-32' ]] - ifFalse: [ - strm nextPutAll: '-v3' ]]. - newName _ fileName, '.image'. - (DirectoryEntry smalltalkImageDirectory // newName) exists ifTrue: [ - newName _ DirectoryEntry smalltalkImageDirectory - nextNameFor: fileName - extension: 'image' ]. - changesName _ self fullNameForChangesNamed: newName. - "Check to see if there is a .changes file that would cause a problem if we saved a new .image file with the new version number" - changesName asFileEntry exists ifTrue: [ - ^ self inform: -'There is already .changes file of the desired name, -', changesName, ' -curiously already present, even though there is no -corresponding .image file. -Please remedy manually and then repeat your request.' ]. - "Try to clear all user state, including all class vars, preferences, etc" - self saveAndStayAs: newName clearAllClassState: true! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4806-saveAsNewReleaseAndStay-JuanVuletich-2021Aug24-18h32m-jmv.001.cs.st----! -!ChangeSet class methodsFor: 'change set to use' stamp: 'jmv 12/17/2018 10:05:42' prior: 50602094! - installing: aCodePackageOrChangeSetName do: aBlock - - | currentCS currentCSNumber newHighestUpdate | - Installing _ 'Install-', aCodePackageOrChangeSetName. - aBlock ensure: [ Installing _ nil ]. - Smalltalk forceChangesToDisk. - - SystemVersion current registerUpdate: aCodePackageOrChangeSetName. - newHighestUpdate _ SystemVersion current highestUpdate. - - currentCSNumber _ self currentBaseCSNumber. - currentCS _ self changeSetForBaseSystem. - currentCS isEmpty ifTrue: [ - ChangeSet removeChangeSet: currentCS. - currentCSNumber > newHighestUpdate ifFalse: [ - CurrentBaseCSNumber _ newHighestUpdate + 1 ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4807-MomentarilyRollBack-4803-JuanVuletich-2021Aug24-19h32m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4806] on 24 August 2021 at 7:37:30 pm'! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 8/24/2021 19:36:56' prior: 50559984! - clippingByCurrentMorphDo: aBlock - "Do clipping only if currentMorph says so" - - | prevClipRect prevClippingMorphRect | - - currentMorph clipsSubmorphsReally ifFalse: [ ^aBlock value ]. - - prevClipRect _ self clipRect. - prevClippingMorphRect _ clippingMorphDisplayBounds. - "Might use the fact that currentMorph has just been drawn." - clippingMorphDisplayBounds _ self boundingRectOfCurrentMorphAfterDraw. - self setClipRect: (prevClipRect - ifNil: [clippingMorphDisplayBounds] - ifNotNil: [prevClipRect intersect: clippingMorphDisplayBounds]). - self clipCurrentMorph: true. - aBlock ensure: [ - self clipCurrentMorph: false. - self setClipRect: prevClipRect. - clippingMorphDisplayBounds _ prevClippingMorphRect ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4808-clippingByCurrentMorphDo-fix-JuanVuletich-2021Aug24-19h36m-jmv.001.cs.st----! - -SmalltalkCompleter initialize ! - -----QUIT----(24 August 2021 20:36:07) Cuis5.0-4808-32.image priorSource: 8661973! - -----STARTUP---- (26 August 2021 17:21:28) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4808-32.image! - - -'From Cuis 5.0 [latest update: #4808] on 25 August 2021 at 9:23:13 am'! -!CodeWindow methodsFor: 'updating' stamp: 'jmv 8/25/2021 09:13:01'! - updateListsAndCodeNow - "All code windows receive this message on any code change in the system" - self canDiscardEdits ifTrue: [ - self allMorphsDo: [ :m | (m is: #PluggableListMorph) ifTrue: [ m verifyContents ]]. - model updateIfNeeded ]! ! -!VersionsBrowserWindow methodsFor: 'updating' stamp: 'jmv 8/25/2021 09:13:05' overrides: 50602497! - updateListsAndCodeNow - "All code windows receive this message on any code change in the system" - model updateIfNeeded! ! -!CodeWindow methodsFor: 'updating' stamp: 'jmv 8/25/2021 09:21:47' prior: 50602067! - updateListsAndCode - "All code windows receive this message on any code change in the system. - Process it only once, for the benefit of installing large packages!!" - - (self hasProperty: #updateListsAndCode) ifFalse: [ - self setProperty: #updateListsAndCode toValue: true. - self whenUIinSafeState: [ - self removeProperty: #updateListsAndCode. - self updateListsAndCodeNow ]].! ! - -VersionsBrowserWindow removeSelector: #updateListsAndCode! - -!methodRemoval: VersionsBrowserWindow #updateListsAndCode stamp: 'Install-4809-FasterPackageLoading-SmarterApproach-JuanVuletich-2021Aug25-09h10m-jmv.002.cs.st 8/26/2021 17:21:33'! -updateListsAndCode - "All code windows receive this message on any code change in the system" - - model ifNotNil: [ - model updateIfNeeded ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4809-FasterPackageLoading-SmarterApproach-JuanVuletich-2021Aug25-09h10m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4809] on 26 August 2021 at 4:59:09 pm'! -!Preferences class methodsFor: 'bigger and smaller GUI element sizes' stamp: 'jmv 8/26/2021 12:05:02'! - roundedButtonRadius - "Only effective if #roundButtons answers true. - Provide a reasonable default for subclasses." - - ^Preferences standardListFont pointSize * 8 // 14! ! -!Preferences class methodsFor: 'bigger and smaller GUI element sizes' stamp: 'jmv 8/26/2021 12:05:21'! - roundedWindowRadius - "Only effective if #roundWindowCorners answers true. - Provide a reasonable default for subclasses." - - ^Preferences standardListFont pointSize! ! -!MorphicCanvas class methodsFor: 'services' stamp: 'jmv 8/26/2021 11:29:32'! - guiSizePreferenceChanged - "Some preference related to size of gui elements may have changed."! ! -!Theme methodsFor: 'other options' stamp: 'jmv 8/26/2021 16:32:33'! - titleBarButtonsExtent - "Answer the extent to use for close & other title bar buttons. - The label height is used to be proportional to the fonts preferences." - | e | - e _ Preferences windowTitleFont pointSize * 13 // 10. - ^e@e! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/26/2021 11:34:11' prior: 50473257! - defaultFont05 - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences defaultFont05 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 5) - (setMenuFontTo: 6) - (setWindowTitleFontTo: 7) - (setCodeFontTo: 5) - (setButtonFontTo: 5) - (setSystemFontTo: 6)). - Preferences disable: #biggerCursors.! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/26/2021 16:10:08' prior: 50473276! - defaultFont06 - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences defaultFont06 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 6) - (setMenuFontTo: 7) - (setWindowTitleFontTo: 8) - (setCodeFontTo: 6) - (setButtonFontTo: 6) - (setSystemFontTo: 7)). - Preferences disable: #biggerCursors.! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/26/2021 16:10:24' prior: 50473295! - defaultFont07 - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences defaultFont07 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 7) - (setMenuFontTo: 8) - (setWindowTitleFontTo: 9) - (setCodeFontTo: 7) - (setButtonFontTo: 7) - (setSystemFontTo: 8)). - Preferences disable: #biggerCursors.! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/26/2021 11:44:48' prior: 50473314! - defaultFont08 - "Sets not only fonts but other GUI elements - to fit low resolution or small screens - Preferences defaultFont08 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 8) - (setMenuFontTo: 9) - (setWindowTitleFontTo: 10) - (setCodeFontTo: 8) - (setButtonFontTo: 8) - (setSystemFontTo: 8)). - Preferences disable: #biggerCursors.! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/26/2021 16:11:11' prior: 50473332! - defaultFont09 - "Sets not only fonts but other GUI elements - to fit low resolution or small screens - Preferences defaultFont09 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 9) - (setMenuFontTo: 10) - (setWindowTitleFontTo: 11) - (setCodeFontTo: 9) - (setButtonFontTo: 9) - (setSystemFontTo: 9)). - Preferences disable: #biggerCursors.! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/26/2021 16:11:25' prior: 50472600! - defaultFont10 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont10 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 10) - (setMenuFontTo: 11) - (setWindowTitleFontTo: 12) - (setCodeFontTo: 10) - (setButtonFontTo: 10) - (setSystemFontTo: 10)). - Preferences disable: #biggerCursors.! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/26/2021 16:11:39' prior: 50472619! - defaultFont11 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont11 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 11) - (setMenuFontTo: 12) - (setWindowTitleFontTo: 14) - (setCodeFontTo: 11) - (setButtonFontTo: 11) - (setSystemFontTo: 11)). - Preferences disable: #biggerCursors.! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/26/2021 16:11:56' prior: 50472638! - defaultFont12 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont12 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 12) - (setMenuFontTo: 12) - (setWindowTitleFontTo: 14) - (setCodeFontTo: 12) - (setButtonFontTo: 12) - (setSystemFontTo: 12)). - Preferences disable: #biggerCursors.! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/26/2021 11:34:32' prior: 50472657! - defaultFont14 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont14 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 14) - (setMenuFontTo: 14) - (setWindowTitleFontTo: 17) - (setCodeFontTo: 14) - (setButtonFontTo: 14) - (setSystemFontTo: 14)). - Preferences disable: #biggerCursors.! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/26/2021 16:12:19' prior: 50472676! - defaultFont17 - "Sets not only fonts but other GUI elements - to fit high resolution or large screens - Preferences defaultFont17 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 17) - (setMenuFontTo: 17) - (setWindowTitleFontTo: 22) - (setCodeFontTo: 17) - (setButtonFontTo: 17) - (setSystemFontTo: 17)). - Preferences enable: #biggerCursors.! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/26/2021 16:12:27' prior: 50472694! - defaultFont22 - "Sets not only fonts but other GUI elements - to fit high resolution or large screens - Preferences defaultFont22 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 22) - (setMenuFontTo: 22) - (setWindowTitleFontTo: 28) - (setCodeFontTo: 22) - (setButtonFontTo: 22) - (setSystemFontTo: 22)). - Preferences enable: #biggerCursors.! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/26/2021 16:13:01' prior: 50472712! - defaultFont28 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont28 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 28) - (setMenuFontTo: 28) - (setWindowTitleFontTo: 36) - (setCodeFontTo: 28) - (setButtonFontTo: 28) - (setSystemFontTo: 28)). - Preferences enable: #biggerCursors.! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/26/2021 16:13:18' prior: 50472731! - defaultFont36 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont36 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 36) - (setMenuFontTo: 36) - (setWindowTitleFontTo: 46) - (setCodeFontTo: 36) - (setButtonFontTo: 36) - (setSystemFontTo: 36)). - Preferences enable: #biggerCursors.! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/26/2021 16:13:39' prior: 50472750! - defaultFont46 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont46 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 46) - (setMenuFontTo: 46) - (setWindowTitleFontTo: 60) - (setCodeFontTo: 46) - (setButtonFontTo: 46) - (setSystemFontTo: 46)). - Preferences enable: #biggerCursors.! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/26/2021 16:14:03' prior: 50472769! - defaultFont60 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont60 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 60) - (setMenuFontTo: 60) - (setWindowTitleFontTo: 80) - (setCodeFontTo: 60) - (setButtonFontTo: 60) - (setSystemFontTo: 60)). - Preferences enable: #biggerCursors.! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/26/2021 16:14:44' prior: 50472788! - defaultFont80 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont80 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 80) - (setMenuFontTo: 80) - (setWindowTitleFontTo: 80) - (setCodeFontTo: 80) - (setButtonFontTo: 80) - (setSystemFontTo: 80)). - Preferences enable: #biggerCursors.! ! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 8/26/2021 16:51:21' prior: 50523178! - setDefaultFont: fontFamilyName spec: defaultFontsSpec - - | font | - defaultFontsSpec do: [ :triplet | - font _ FontFamily familyName: fontFamilyName pointSize: triplet second. - font ifNil: [ font _ FontFamily defaultFamilyAndPointSize ]. - triplet size > 2 ifTrue: [ - font _ font emphasized: triplet third ]. - self - perform: triplet first - with: font ]. - UISupervisor ui ifNotNil: [ :w | w fontPreferenceChanged ]. - MorphicCanvas allSubclassesDo: [ :c| c guiSizePreferenceChanged ].! ! -!Preferences class methodsFor: 'bigger and smaller GUI element sizes' stamp: 'jmv 8/26/2021 11:56:07' prior: 16893484! - scrollbarThickness - "Includes border" - ^Preferences standardListFont pointSize * 9 // 7! ! -!SystemWindow methodsFor: 'geometry' stamp: 'jmv 8/26/2021 16:33:48' prior: 50500257 overrides: 50499535! - minimumExtent - - ^layoutMorph minimumExtent + (borderWidth * 2) + (0@self labelHeight) - max: Theme current titleBarButtonsExtent x * 6 @ 0! ! -!SystemWindow methodsFor: 'geometry' stamp: 'jmv 8/26/2021 16:33:53' prior: 50471954! - rescaleButtons - "boxExtent changed. Update my buttons." - | buttonPos buttonExtent buttonDelta| - buttonExtent := Theme current titleBarButtonsExtent. - buttonPos _ self labelHeight + borderWidth - buttonExtent // 2 * (1@1). - buttonDelta _ buttonExtent x *14//10. - self submorphsReverseDo: [ :aMorph | - (aMorph is: #PluggableButtonMorph) - ifTrue: [ - aMorph morphExtent: buttonExtent. - aMorph morphPosition: buttonPos. - buttonPos _ buttonPos + (buttonDelta@0). - ]. - ]! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 8/26/2021 16:33:15' prior: 50577884! - createCloseButton - ^ (PluggableButtonMorph model: self action: #closeBoxHit) - iconDrawSelector: #drawCloseIcon; - setBalloonText: 'close this window'; - morphExtent: Theme current titleBarButtonsExtent! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 8/26/2021 16:33:20' prior: 50577894! - createCollapseButton - ^(PluggableButtonMorph model: self action: #collapse) - iconDrawSelector: #drawCollapseIcon; - setBalloonText: 'collapse this window'; - morphExtent: Theme current titleBarButtonsExtent! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 8/26/2021 16:33:24' prior: 50577904! - createExpandButton - ^ (PluggableButtonMorph model: self action: #expandBoxHit) - iconDrawSelector: #drawExpandIcon; - setBalloonText: 'expand to full screen'; - morphExtent: Theme current titleBarButtonsExtent! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 8/26/2021 16:33:28' prior: 50577914! - createMenuButton - ^ (PluggableButtonMorph model: self action: #offerWindowMenu) - iconDrawSelector: #drawMenuIcon; - setBalloonText: 'window menu'; - morphExtent: Theme current titleBarButtonsExtent! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 8/26/2021 16:33:37' prior: 50541149! - initializeLabelArea - "Initialize the label area (titlebar) for the window." - - | topLeft spacing | - topLeft _ (self labelHeight + borderWidth - Theme current titleBarButtonsExtent / 2) ceiling asPoint. - spacing _ Theme current titleBarButtonsExtent x *14//10. - self addMorph: self createCloseButton position: topLeft. - self addMorph: self createCollapseButton position: spacing@0 + topLeft. - self addMorph: self createExpandButton position: spacing*2@0 + topLeft. - self addMorph: self createMenuButton position: spacing*3@0 + topLeft! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 8/26/2021 16:58:52' prior: 50577923! - addStayUpIcons - | closeButton pinButton w buttonHW | - Preferences optionalButtons ifFalse: [ ^self ]. - (self valueOfProperty: #hasStayUpIcons ifAbsent: [ false ]) - ifTrue: [ - self removeProperty: #needsStayUpIcons. - ^self ]. - titleMorph ifNil: [ - "Title not yet there. Flag ourself, so this method is called again when adding title." - self setProperty: #needsStayUpIcons toValue: true. - ^ self]. - buttonHW _ Theme current titleBarButtonsExtent x. - closeButton _ PluggableButtonMorph model: self action: #delete. - closeButton iconDrawSelector: #drawCloseIcon; color: `Color transparent`. - pinButton _ PluggableButtonMorph model: self action: #stayUp. - pinButton iconDrawSelector: #drawPushPinIcon; color: `Color transparent`. - w _ (titleMorph hasSubmorphs ifTrue: [ titleMorph firstSubmorph morphWidth ] ifFalse: [ 0 ]) + 60. - self addMorphFront: - (LayoutMorph newRow - "Make room for buttons" - morphExtent: w @ (titleMorph morphHeight max: buttonHW); - color: `Color transparent`; - addMorph: closeButton fixedWidth: buttonHW; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedWidth: buttonHW//7; - addMorph: titleMorph proportionalWidth: 1; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedWidth: buttonHW//7; - addMorph: pinButton fixedWidth: buttonHW; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedWidth: buttonHW//3). - - self setProperty: #hasStayUpIcons toValue: true. - self removeProperty: #needsStayUpIcons! ! -!MenuMorph methodsFor: 'menu' stamp: 'jmv 8/26/2021 16:46:43' prior: 16867119! - removeStayUpBox - | box | - submorphs isEmpty ifTrue: [^self]. - (submorphs first is: #LayoutMorph) ifFalse: [^self]. - box _ submorphs first submorphs second. - (box is: #PluggableButtonMorph) - ifTrue: [ box hide ]! ! -!Theme methodsFor: 'other options' stamp: 'jmv 8/26/2021 11:55:18' prior: 16935701! - roundedButtonRadius - "Only effective if #roundButtons answers true. - Provide a reasonable default for subclasses." - ^ Preferences roundedButtonRadius! ! -!Theme methodsFor: 'other options' stamp: 'jmv 8/26/2021 11:55:29' prior: 50578739! - roundedWindowRadius - "Only effective if #roundWindowCorners answers true. - Provide a reasonable default for subclasses." - ^Preferences roundedWindowRadius! ! - -SystemWindow removeSelector: #titleBarButtonsExtent! - -!methodRemoval: SystemWindow #titleBarButtonsExtent stamp: 'Install-4810-GUIPreferencesTweaks-JuanVuletich-2021Aug26-16h35m-jmv.004.cs.st 8/26/2021 17:21:33'! -titleBarButtonsExtent - "Answer the extent to use for close & other title bar buttons. - The label height is used to be proportional to the fonts preferences." - | e | - e _ Preferences windowTitleFont pointSize * 13 // 10. - ^e@e! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4810-GUIPreferencesTweaks-JuanVuletich-2021Aug26-16h35m-jmv.004.cs.st----! - -----QUIT----(26 August 2021 17:21:35) Cuis5.0-4810-32.image priorSource: 8666801! - -----STARTUP---- (28 August 2021 20:07:15) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4810-32.image! - - -'From Cuis 5.0 [latest update: #4810] on 27 August 2021 at 5:41:38 pm'! -!DisplayScreen methodsFor: 'accessing' stamp: 'jmv 8/27/2021 17:20:52'! - getMainCanvas - "Return a Canvas that can be used to draw onto the receiver" - ^MorphicCanvas withVectorEnginePluginOnForm: self! ! -!WorldMorph methodsFor: 'canvas' stamp: 'jmv 8/27/2021 17:26:47'! - setMainCanvas - self clearCanvas. "Deallocate before allocating could mean less memory stress." - self setCanvas: Display getMainCanvas. - damageRecorder _ DamageRecorder new. - self redrawNeeded! ! -!MorphicCanvas methodsFor: 'testing' stamp: 'jmv 8/27/2021 16:04:07'! - usesVectorEnginePlugin - ^false! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/27/2021 17:20:46'! - withVectorEnginePluginOnForm: aForm - "Note: Only one instance using VectorEnginePlugin should be acive at a time: - the plugin holds numeric parameters that are not passed again on every call." - - ^ self subclassToUse basicNew - setPluginAndForm: aForm; - initializeWithTranslation: `0@0`.! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 8/27/2021 17:17:56'! - setPluginAndForm: aForm - "nil means use default kind of anti aliasing" - - form _ aForm. - engine _ BitBltCanvasEngine toForm: form. - "Init BitBlt so that the first call to the 'primitiveDisplayString' primitive will not fail" - engine sourceX: 0; width: 0. - self newClipRect: nil.! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 8/27/2021 16:06:32' prior: 50579244! - okayToRotateEasily - "Answer whether it is appropriate for a rotation handle to be shown for the receiver." - - ^ self hasOwnLocation and: [self world canvas usesVectorEnginePlugin]! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 8/27/2021 16:06:44' prior: 50579253! - okayToScaleEasily - "Answer whether it is appropriate for a scale handle to be shown for the receiver." - - ^ self hasOwnLocation and: [self world canvas usesVectorEnginePlugin]! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 8/27/2021 17:27:32' prior: 50556371 overrides: 50556363! - extentChanged: oldExtent - "Our extent changed. Must layout submorphs again." - - super extentChanged: oldExtent. - self setMainCanvas! ! -!WorldMorph methodsFor: 'interaction loop' stamp: 'jmv 8/27/2021 17:23:17' prior: 50566932! - mainLoop - - - self clearWaitDelay. - canvas isNil ifTrue: [ - self setCanvas: Display getMainCanvas. - damageRecorder _ DamageRecorder new ]. - self redrawNeeded. - [ - self doOneCycle. - true ] - whileTrue: []! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 8/27/2021 17:27:28' prior: 50596552! - displayWorldSafely - "Update this world's display and keep track of errors during draw methods." - - [self displayWorld] ifErrorOrHalt: [ :err :rcvr | - "Handle a drawing error" - canvas currentMorphDrawingFails. - self setMainCanvas. - "Install the old error handler, so we can re-raise the error" - rcvr error: err. - ]! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 8/27/2021 17:25:41' prior: 50551817! - tryDeferredUpdatingAndSetCanvas - "If this platform supports deferred updates, then make my canvas be the Display (or a rectangular portion of it), set the Display to deferred update mode, and answer true. Otherwise, set a non-Disply canvas and answer false.." - | properDisplay | - - "As this is the only sender of #deferUpdates: , this could be done in Morphic or image startup, and never efterwards..." - (Display deferUpdates: true) ifNil: [ - "deferred updates not supported by the VM, do them in the image!!" - self ensureNonDisplayCanvas. - ^ false]. - - "if no canvas, or canvas was offscreen, from a platform that didnt support defers, then fix it" - properDisplay _ canvas notNil and: [canvas drawsOnDisplay]. - properDisplay ifFalse: [ - self morphPosition: `0@0` extent: Display extent. - self setCanvas: Display getMainCanvas. - ]. - ^ true! ! -!WorldMorph class methodsFor: 'instance creation' stamp: 'jmv 8/27/2021 17:23:29' prior: 50552197! - newWorld - " -[ - UISupervisor stopUIProcess. - UISupervisor spawnNewMorphicProcessFor: WorldMorph newWorld -] fork. - " - | w | - w _ self new. - w morphPosition: `0@0` extent: Display extent. - w setCanvas: Display getMainCanvas. - w handsDo: [ :h | - h privateOwner: w ]. - ^w! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/27/2021 17:38:53' prior: 50553020! - activeSubclass: aMorphicCanvasSubclass - ActiveSubclass _ aMorphicCanvasSubclass. - UISupervisor ui setMainCanvas.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/27/2021 17:07:00' prior: 50596894! - onForm: aForm over: aRectangle - "Warning: aForm extent must equal aRectangle extent" - - ^ self subclassToUse basicNew - setForm: aForm subPixelAntiAliasing: false; - initializeWithTranslation: aRectangle topLeft negated.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/27/2021 17:06:54' prior: 50596904! - onForm: aForm translation: aPoint - - ^ self subclassToUse basicNew - setForm: aForm subPixelAntiAliasing: false; - initializeWithTranslation: aPoint.! ! - -MorphicCanvas class removeSelector: #isVectorGraphicsUsedForAllRendering! - -!methodRemoval: MorphicCanvas class #isVectorGraphicsUsedForAllRendering stamp: 'Install-4811-supportForAPriviledgedMainCanvas-JuanVuletich-2021Aug27-17h31m-jmv.003.cs.st 8/28/2021 20:07:21'! -isVectorGraphicsUsedForAllRendering - " - MorphicCanvas isVectorGraphicsUsedForAllRendering - " - ^MorphicCanvas activeSubclass name == #VectorDrawingCanvas! - -MorphicCanvas class removeSelector: #onFormWithWholePixelAntiAliasing:! - -!methodRemoval: MorphicCanvas class #onFormWithWholePixelAntiAliasing: stamp: 'Install-4811-supportForAPriviledgedMainCanvas-JuanVuletich-2021Aug27-17h31m-jmv.003.cs.st 8/28/2021 20:07:21'! -onFormWithWholePixelAntiAliasing: aForm - - ^ self onFormWithWholePixelAntiAliasing: aForm translation: `0@0`.! - -MorphicCanvas class removeSelector: #isVectorGraphicsActive! - -!methodRemoval: MorphicCanvas class #isVectorGraphicsActive stamp: 'Install-4811-supportForAPriviledgedMainCanvas-JuanVuletich-2021Aug27-17h31m-jmv.003.cs.st 8/28/2021 20:07:21'! -isVectorGraphicsActive - " - MorphicCanvas isVectorGraphicsActive - " - ^MorphicCanvas activeSubclass ~~ BitBltCanvas ! - -MorphicCanvas class removeSelector: #isVectorGraphicsPluginActive! - -!methodRemoval: MorphicCanvas class #isVectorGraphicsPluginActive stamp: 'Install-4811-supportForAPriviledgedMainCanvas-JuanVuletich-2021Aug27-17h31m-jmv.003.cs.st 8/28/2021 20:07:21'! -isVectorGraphicsPluginActive - " - MorphicCanvas isVectorGraphicsPluginActive - " - ^self isVectorGraphicsActive and: [ - (Smalltalk at: #VectorEngineWithPlugin) isPluginAvailable ]! - -MorphicCanvas class removeSelector: #onFormWithWholePixelAntiAliasing:translation:! - -!methodRemoval: MorphicCanvas class #onFormWithWholePixelAntiAliasing:translation: stamp: 'Install-4811-supportForAPriviledgedMainCanvas-JuanVuletich-2021Aug27-17h31m-jmv.003.cs.st 8/28/2021 20:07:21'! -onFormWithWholePixelAntiAliasing: aForm translation: aPoint - - ^ self subclassToUse basicNew - setForm: aForm subPixelAntiAliasing: false; - initializeWithTranslation: aPoint.! - -WorldMorph removeSelector: #setCanvas! - -!methodRemoval: WorldMorph #setCanvas stamp: 'Install-4811-supportForAPriviledgedMainCanvas-JuanVuletich-2021Aug27-17h31m-jmv.003.cs.st 8/28/2021 20:07:21'! -setCanvas - self clearCanvas. "Deallocate before allocating could mean less memory stress." - self setCanvas: Display getCanvas. - damageRecorder _ DamageRecorder new. - self redrawNeeded! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4811-supportForAPriviledgedMainCanvas-JuanVuletich-2021Aug27-17h31m-jmv.003.cs.st----! - -'From Cuis 5.0 [latest update: #4811] on 27 August 2021 at 7:56:57 pm'! -!Morph methodsFor: 'geometry services' stamp: 'jmv 8/27/2021 14:06:57' prior: 50593303! - collides: aMorph - "Answer whether the pixels used by morphs touch at least at one place. - Morphs not in the WidgetMorph hierarchy should answer #true to wantsContour." - - privateDisplayBounds ifNil: [ - ^false ]. - - "Quick check with display bounds" - (aMorph displayBoundsIntersects: (privateDisplayBounds outsetBy: 1)) ifFalse: [ - ^false ]. - - "Precise check with contour, if available" - (self valueOfProperty: #contour) ifNotNil: [ :contour | | contourTop contourBottom | - contourTop _ self valueOfProperty: #contourY0. - contourBottom _ self valueOfProperty: #contourY1. - ^ aMorph contourIntersects: contour top: contourTop bottom: contourBottom ]. - - "If contour is not available, and both displayBounds overlap, answer true, as it is the best we can know." - ^ true! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 8/26/2021 17:38:12' prior: 50596679! - drawCurrentAsError - "The morph (or one of its submorphs) had an error in its drawing method." - | r w | - r _ currentMorph morphLocalBoundsForError. - w _ r extent > `50@50` - ifTrue: [ 6 ] - ifFalse: [ 2 ]. - self - frameAndFillRectangle: r - fillColor: `Color red` - borderWidth: w - borderColor: `Color yellow`. - self line: r topLeft+1 to: r bottomRight-7 width: w color: `Color yellow`. - self line: r topRight + (-7@1) to: r bottomLeft + (1@ -7) width: w color: `Color yellow`. - currentMorph displayBoundsSetFrom: self.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4812-tweaks-JuanVuletich-2021Aug27-19h49m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4812] on 28 August 2021 at 7:16:28 pm'! -!ObjectExplorerWrapper methodsFor: 'monitoring' stamp: 'jmv 8/28/2021 19:13:11' prior: 16883572! - refresh - "Refresh item given an object and a string that is either an index or an instance variable name." - | index | - (model class allInstVarNames includes: itemName) - ifTrue: [ - item _ model instVarNamed: itemName ] - ifFalse: [ - item _ nil. - index _ itemName findPositiveInteger. - (index notNil and: [index between: 1 and: model basicSize]) ifTrue: [ - item _ model basicAt: index]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4813-FixObjectExplorerRootMonitoring-JuanVuletich-2021Aug28-19h16m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4812] on 28 August 2021 at 7:17:31 pm'! -!ContextPart methodsFor: 'debugger access' stamp: 'jmv 8/28/2021 19:05:56' prior: 16824192! - tempsAndValuesLimitedTo: sizeLimit indent: indent - "Return a string of the temporary variabls and their current values" - - | aStream tempNames title | - aStream _ WriteStream on: (String new: 100). - tempNames _ self tempNames. - 1 to: self size do: [ :index | - title _ tempNames size = self size ifTrue: [tempNames at: index] ifFalse: [ 'argOrTemp', index printString ]. - indent timesRepeat: [aStream tab]. - aStream nextPutAll: title; nextPut: $:; space; tab. - aStream nextPutAll: - ((self tempAt: index) printStringLimitedTo: (sizeLimit -3 -title size max: 1)). - aStream newLine]. - ^aStream contents! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4814-ErrorLoggingFix-JuanVuletich-2021Aug28-19h16m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4814] on 28 August 2021 at 7:29:54 pm'! -!ImageMorph methodsFor: 'accessing' stamp: 'jmv 8/28/2021 19:27:55' prior: 50556503! - image: anImage - - image _ anImage depth = 1 - ifTrue: [ ColorForm mappingWhiteToTransparentFrom: anImage ] - ifFalse: [ anImage ]. - self morphExtent: self minimumExtent. - self redrawNeeded.! ! - -ImageMorph removeSelector: #morphExtent:! - -!methodRemoval: ImageMorph #morphExtent: stamp: 'Install-4815-ImageMorph-fix-JuanVuletich-2021Aug28-19h20m-jmv.001.cs.st 8/28/2021 20:07:21'! -morphExtent: aPoint - "Do nothing; my extent is determined by my image Form." - - "A clear case of a morph that shouldn't have an 'extent' ivar..." - self flag: #jmvVer2.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4815-ImageMorph-fix-JuanVuletich-2021Aug28-19h20m-jmv.001.cs.st----! - -----QUIT----(28 August 2021 20:07:24) Cuis5.0-4815-32.image priorSource: 8684731! - -----STARTUP---- (3 September 2021 15:02:21) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4815-32.image! - - -'From Cuis 5.0 [latest update: #4815] on 30 August 2021 at 11:41:50 am'! -!WidgetMorph methodsFor: 'halos and balloon help' stamp: 'jmv 8/30/2021 11:41:09' overrides: 50576963! - okayToResizeEasily - "Answer whether it is appropriate to have the receiver be easily resized by the user from the halo" - - ^ true.! ! -!WidgetMorph methodsFor: 'halos and balloon help' stamp: 'jmv 8/30/2021 11:40:56' overrides: 50603101! - okayToRotateEasily - "Answer whether it is appropriate for a rotation handle to be shown for the receiver." - - ^ self world canvas usesVectorEnginePlugin.! ! -!WidgetMorph methodsFor: 'halos and balloon help' stamp: 'jmv 8/30/2021 11:41:05' overrides: 50603110! - okayToScaleEasily - "Answer whether it is appropriate for a scale handle to be shown for the receiver." - - ^ self world canvas usesVectorEnginePlugin.! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 8/30/2021 11:41:24' prior: 50603101! - okayToRotateEasily - "Answer whether it is appropriate for a rotation handle to be shown for the receiver." - - ^ self hasOwnLocation! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 8/30/2021 11:41:30' prior: 50603110! - okayToScaleEasily - "Answer whether it is appropriate for a scale handle to be shown for the receiver." - - ^ self hasOwnLocation! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4816-AlwaysEnableZoomRotateForNonWidgets-JuanVuletich-2021Aug30-11h40m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4815] on 30 August 2021 at 11:52:44 am'! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/30/2021 11:48:44' prior: 50473249! - bigFonts - "Sets not only fonts but other GUI elements - to fit regular resolution and size screens - Preferences bigFonts - " - - self defaultFont22! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/30/2021 11:51:19' prior: 50473350! - hugeFonts - "Sets not only fonts but other GUI elements - to fit regular resolution and size screens - Preferences hugeFonts - " - - self defaultFont60! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/30/2021 11:47:04' prior: 50473358! - smallFonts - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences smallFonts - " - - self defaultFont12! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/30/2021 11:50:41' prior: 50473385! - veryBigFonts - "Sets not only fonts but other GUI elements - to fit regular resolution and size screens - Preferences veryBigFonts - " - - self defaultFont36! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/30/2021 11:47:10' prior: 50473394! - verySmallFonts - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences verySmallFonts - " - - self defaultFont10! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 8/30/2021 11:44:13' prior: 50552220! -preferencesMenu - "Build the preferences menu for the world." - - ^ (self menu: 'Preferences...') - addItemsFromDictionaries: { - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Size of GUI elements...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Set System Font...'. - #object -> FontFamily. - #selector -> #promptUserAndSetDefault. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'change the current system font family.' - } asDictionary. - { - #label -> 'Load all TrueType Fonts'. - #object -> FontFamily. - #selector -> #readAdditionalTrueTypeFonts. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'Load additional TrueType fonts included with Cuis.' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }! ! -!Theme class methodsFor: 'user interface' stamp: 'jmv 8/30/2021 11:43:38' prior: 50437275! - changeFontSizes - - (MenuMorph new defaultTarget: Preferences) - addTitle: 'Make GUI elements'; - addStayUpIcons; - add: 'Huge' action: #hugeFonts; - add: 'Very Big' action: #veryBigFonts; - add: 'Big' action: #bigFonts; - add: 'Standard Size' action: #standardFonts; - add: 'Small' action: #smallFonts; - add: 'Very Small'action: #verySmallFonts; - add: 'Tiny'action: #tinyFonts; - popUpInWorld: self runningWorld! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4817-GUISizingOptionsTweaks-JuanVuletich-2021Aug30-11h41m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4815] on 30 August 2021 at 12:04:28 pm'! -!StringRequestMorph methodsFor: 'initialization' stamp: 'jmv 8/30/2021 11:58:02' prior: 50548594 overrides: 50547033! - defaultBorderWidth - "Answer the default border width for the receiver." - ^ Theme current windowBorderWidth! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4818-StringRequestMorph-fix-JuanVuletich-2021Aug30-11h52m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4818] on 30 August 2021 at 12:44:30 pm'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 8/30/2021 12:43:22' prior: 50598652! -snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag - "This is the main method for image save and / or quit. - See senders." - "WARNING: Current process will be killed. UI Process will be restarted" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic - checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " - | activeProc | - activeProc _ Processor activeProcess. - [ | isARealStartup guiRootObject guiRootObjectClass | - save not & quit - ifTrue: [ - (SourceFiles at: 2) ifNotNil: [ :changes | - ChangesInitialFileSize ifNotNil: [ changes truncate: ChangesInitialFileSize ]]] - ifFalse: [ - self - logSnapshot: save - andQuit: quit ]. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | - each isInWorld ifTrue: [ - each delete.]]. - UISupervisor ui tearDownDesktop. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - "Cosas que levanto explicitamente abajo" - guiRootObjectClass _ UISupervisor ui class. - guiRootObject _ UISupervisor ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "guiRootObject _ clearAllStateFlag ifFalse: [ UISupervisor ui ]." - UISupervisor stopUIProcess. - activeProc isTerminated ifFalse: [ activeProc terminate ]. - guiRootObject ifNotNil: [ guiRootObject releaseCachedState ]. - "Clean Globals" - Smalltalk - at: #Sensor - put: nil. - Smalltalk - at: #Display - put: nil. - Smalltalk closeSourceFiles. - Smalltalk - at: #SourceFiles - put: nil. - Smalltalk allClassesDo: [ :cls | - cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | - cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ - Smalltalk printStuffToCleanOnImageSave. - "Remove this call to actually see the image clean report." - Transcript clear. - ]. - "Do image save & quit as apropriate" - (Cursor cursorAt: #writeCursor) activateCursor. - save - ifTrue: [ - "The snapshot primitive answers false if it was just called to do the snapshot. - But image startup is resumed by returning (again) from the primitive, but this time answering true." - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk - at: #Sensor - put: nil. - Smalltalk - at: #Display - put: DisplayScreen new. - Smalltalk - at: #SourceFiles - put: (Array new: 2). - Smalltalk openSourceFiles. - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | - cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - UISupervisor spawnNewMorphicProcessFor: (guiRootObject ifNil: [ guiRootObject _ guiRootObjectClass newWorld ]). - self restoreLostChangesIfNecessary. - clearAllStateFlag ifTrue: [ - UISupervisor whenUIinSafeState: [ - guiRootObject recreateDefaultDesktop; restoreDisplay. - Display triggerEvent: #screenSizeChanged ]] - ifFalse: [ - UISupervisor whenUIinSafeState: [ - guiRootObject restoreDisplay. - Display triggerEvent: #screenSizeChanged ]]. - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - UISupervisor whenUIinSafeState: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]] - forkAt: Processor timingPriority - 1 - named: 'Startup process'.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4819-ClearMorphicCanvasOnImageSave-JuanVuletich-2021Aug30-12h43m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4819] on 30 August 2021 at 4:25:57 pm'! -!TranscriptWindow methodsFor: 'geometry testing' stamp: 'jmv 8/30/2021 16:25:26' overrides: 50559952! - clipsSubmorphs - "Our contents are not inside a PluggableScrollPane like in other SystemWindows, - so we do the clipping ourselves." - - ^ true! ! - -TranscriptMorph removeSelector: #clipsSubmorphs! - -!methodRemoval: TranscriptMorph #clipsSubmorphs stamp: 'Install-4820-TranscriptWindow-fix-JuanVuletich-2021Aug30-16h24m-jmv.001.cs.st 9/3/2021 15:02:26'! -clipsSubmorphs - "Answer true if we clip the shape of our submorphs to our own. - Answer true only when clipping by the canvas is needed. - Morphs that can guarantee that submorphs don't protrude and answer false to - #submorphsMightProtrude should answer false for better performance" - - ^ true! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4820-TranscriptWindow-fix-JuanVuletich-2021Aug30-16h24m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4820] on 30 August 2021 at 5:45:18 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/30/2021 17:42:48' prior: 50596726! - displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Clipped appropiately if some owner clips us. - See also #displayBoundsUpdateFrom:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - (aCanvas isBoundsFinderCanvas or: [c canvasToUse == aCanvas canvasToUse]) ifTrue: [ - self knowsOwnLocalBounds - ifTrue: [ - "A good optimization in many cases. - But for morphs where #drawOn: might not be able to find bounds (InnerTextMorph and LayoutMorph, - for example) this is essential." - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphFromLocalBounds] - ifFalse: [ - "Use the bounds bound by #drawOn. This method must therefore be called after calling #drawOn:." - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphAfterDraw. - self wantsContour - ifTrue: [ - (aCanvas - contourOfCurrentMorphAfterDrawInto: (self valueOfProperty: #contour) - into: [ :contourArray :contourY0 :contourY1 | - self setProperty: #contour toValue: contourArray. - self setProperty: #contourY0 toValue: contourY0. - self setProperty: #contourY1 toValue: contourY1. - ])] - ifFalse: [ - self setProperty: #contour toValue: nil. - self setProperty: #contourY0 toValue: nil. - self setProperty: #contourY1 toValue: nil ]]]]].! ! -!WindowEdgeAdjustingMorph methodsFor: 'adjusting' stamp: 'jmv 8/30/2021 17:43:48' prior: 50594800 overrides: 50591384! - adjustOwnerAt: aGlobalPoint millisecondSinceLast: millisecondSinceLast - - self basicAdjustOwnerAt: aGlobalPoint. - - "If UI is becoming slow or is optimized for slow systems, resize without - showing window contents, but only edges. But don't do it for rotated Windows!!" - (owner isOrAnyOwnerIsRotated not and: [ - Preferences cheapWindowReframe or: [millisecondSinceLast > 200]]) ifTrue: [ - Preferences cheapWindowReframe ifFalse: [ Preferences enable: #cheapWindowReframe ]. - owner displayBounds newRectFrom: [ :f | - self basicAdjustOwnerAt: Sensor mousePoint. - owner morphPosition extent: owner morphExtentInWorld ]].! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 8/30/2021 17:44:18' prior: 50571160! - drawCurrentAsOutline - - self isCurrentMorphVisible ifTrue: [ - currentMorph displayBoundsSetFrom: self. - self frameReverseGlobalRect: currentMorph displayBounds borderWidth: 2 ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4821-CheapWindowRefeame-fixes-JuanVuletich-2021Aug30-17h42m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4821] on 31 August 2021 at 12:39:07 pm'! -!CodeWindow methodsFor: 'GUI building' stamp: 'KLG 8/31/2021 12:53:05' prior: 50597705! - optionalButtonTuples - "Answer a tuple buttons, in the format: - button label - selector to send - help message" - - | aList textConstructor | - textConstructor _ [ :string :backgroundColor | - string asText addAttribute: (TextBackgroundColor color: backgroundColor) ]. - - aList _ #( - (10 'browse' browseMethodFull 'view this method in a browser') - (11 'senders' browseSendersOfMessages 'browse senders of...') - (16 'implementors' browseMessages 'browse implementors of...') - (12 'versions' browseVersions 'browse versions')), - - (Preferences decorateBrowserButtons - ifTrue: - [{{13 . 'inheritance'. #methodInheritance. 'browse method inheritance - -', (textConstructor value:'green' value: `Color green muchLighter`),': sends to super -', (textConstructor value: 'tan' value: `Color tan`), ': has override(s) -', (textConstructor value: 'mauve' value: `Color blue muchLighter`), ': both of the above -', (textConstructor value: 'pink' value: `Color red muchLighter`), ': is an override but doesn''t call super -', (textConstructor value: 'pinkish tan' value: `Color r: 0.94 g: 0.823 b: 0.673`), ': has override(s), also is an override but doesn''t call super'}}] - ifFalse: - [{#(13 'inheritance' methodInheritance 'browse method inheritance')}]), - - #( - (12 'hierarchy' browseHierarchy 'browse class hierarchy') - (10 'inst vars' browseInstVarRefs 'inst var refs...') - (11 'class vars' browseClassVarRefs 'class var refs...') - (10 'show...' offerWhatToShowMenu 'menu of what to show in lower pane')). - - ^ aList! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4822-InheritanceButtonBalloon-GeraldKlix-2021Aug31-12h36m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4822] on 31 August 2021 at 5:33:26 pm'! -!WorldMorph methodsFor: 'canvas' stamp: 'jmv 8/31/2021 17:05:43'! - resetCanvas - "To be called in case of possible inconsistency due to an exception during drawing. - See #displayWorldSafely" - - canvas resetCanvas. - damageRecorder _ DamageRecorder new. - self redrawNeeded! ! -!MorphicCanvas methodsFor: 'initialization' stamp: 'jmv 8/31/2021 17:05:32'! - resetCanvas - "To be called in case of possible inconsistency due to an exception during drawing. - See #displayWorldSafely" - - cti _ 1. - currentTransformation _ transformations at: 1.! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 8/31/2021 17:06:38' prior: 50603137! - displayWorldSafely - "Update this world's display and keep track of errors during draw methods." - - [self displayWorld] on: Error, Halt do: [ :err :rcvr | - "Handle a drawing error" - canvas currentMorphDrawingFails. - "Creating a new canvas here could be dangerous, as code signaling the exception will be resumed." - self resetCanvas. - "Install the old error handler, so we can re-raise the error" - rcvr error: err. - ]! ! -!MorphicCanvas methodsFor: 'initialization' stamp: 'jmv 8/31/2021 17:04:10' prior: 50596873! - initializeWithTranslation: aPoint - "Set up these only on initialization." - - currentTransformation _ MorphicTranslation withTranslation: aPoint. - cti _ 1. - transformations - ifNil: [ transformations _ OrderedCollection with: currentTransformation ] - ifNotNil: [ transformations at: cti put: currentTransformation ]. - drawingMorphStack - ifNil: [ drawingMorphStack _ OrderedCollection with: nil ] - ifNotNil: [ drawingMorphStack at: cti put: nil ].! ! - -BlockClosure removeSelector: #ifErrorOrHalt:! - -!methodRemoval: BlockClosure #ifErrorOrHalt: stamp: 'Install-4823-resetCanvas-JuanVuletich-2021Aug31-17h31m-jmv.001.cs.st 9/3/2021 15:02:26'! -ifErrorOrHalt: errorHandlerBlock - "Evaluate the block represented by the receiver, and normally return it's value. If an error occurs, the errorHandlerBlock is evaluated, and it's value is instead returned. The errorHandlerBlock must accept zero, one, or two parameters (the error message and the receiver)." - "Examples: - [1 halt] ifErrorOrHalt: [:err :rcvr | 'huh?']. - [1 whatsUpDoc] ifErrorOrHalt: [:err :rcvr | 'huh?']. - [1 / 0] ifErrorOrHalt: [:err :rcvr | - 'ZeroDivide' = err - ifTrue: [Float infinity] - ifFalse: [self error: err]] -" - - ^ self on: Error, Halt do: [ :ex | - errorHandlerBlock valueWithPossibleArgument: ex description and: ex receiver ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4823-resetCanvas-JuanVuletich-2021Aug31-17h31m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4822] on 31 August 2021 at 5:36:52 pm'! -!MovableMorph methodsFor: 'initialization' stamp: 'jmv 8/31/2021 17:11:29' prior: 50554321 overrides: 50554573! - openInWorld: aWorld - "Add this morph to the requested World." - location isIdentity - ifTrue: [ - aWorld - addMorph: self - position: (Display width*8//10) atRandom@(Display height*8//10) atRandom + (Display extent //10) ] - ifFalse: [ aWorld addMorph: self ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4824-NewMorphsAtRandomPositions-JuanVuletich-2021Aug31-17h33m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4822] on 1 September 2021 at 11:34:10 am'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 9/1/2021 11:26:37'! - contourOfCurrentMorphAfterDrawInto: anArray into: aBlock - "We don't compute contours. See other implementors."! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 9/1/2021 11:33:22' prior: 50603858! -displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Clipped appropiately if some owner clips us. - See also #displayBoundsUpdateFrom:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - (aCanvas isBoundsFinderCanvas or: [c canvasToUse == aCanvas canvasToUse]) ifTrue: [ - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphAfterDraw. - self wantsContour - ifTrue: [ - (aCanvas - contourOfCurrentMorphAfterDrawInto: (self valueOfProperty: #contour) - into: [ :contourArray :contourY0 :contourY1 | - self setProperty: #contour toValue: contourArray. - self setProperty: #contourY0 toValue: contourY0. - self setProperty: #contourY1 toValue: contourY1 ])] - ifFalse: [ - self setProperty: #contour toValue: nil. - self setProperty: #contourY0 toValue: nil. - self setProperty: #contourY1 toValue: nil ]]]].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 9/1/2021 11:33:11' prior: 50595428! - displayBoundsUpdateFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us. - To be called after #postDrawOn:. See also #displayBoundsSetFrom: - This more complicated update is needed because the contour information from #drawOn: was possibly - when drawing submorphs. So, the controur from #drawOn: needs to be retrieved, and updated with the - new contour information from #postDrawOn:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - (aCanvas isBoundsFinderCanvas or: [c canvasToUse == aCanvas]) ifTrue: [ - privateDisplayBounds _ privateDisplayBounds - quickMerge: aCanvas boundingRectOfCurrentMorphAfterDraw. - self wantsContour ifTrue: [ - (aCanvas - contourOfCurrentMorphAfterDrawUpdate: (self valueOfProperty: #contour) - oldTop: (self valueOfProperty: #contourY0) - oldBottom: (self valueOfProperty: #contourY1) - into: [ :contourArray :contourY0 :contourY1 | - self setProperty: #contour toValue: contourArray. - self setProperty: #contourY0 toValue: contourY0. - self setProperty: #contourY1 toValue: contourY1 ])]]]].! ! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 9/1/2021 11:14:29' prior: 50536532! -boundingRectOfCurrentMorphAfterDraw - "In targetForm coordinates. - Clipped to owner if appropriate. - Only valid for morphs where #morphLocalBounds is known. - Subclasses may raise this restrinction. See inherintance, with VectorGraphics package loaded." - - | boundingRect | - boundingRect _ currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds. - ^ clippingMorphDisplayBounds - ifNotNil: [ :ownerClips | boundingRect intersect: ownerClips ] - ifNil: [ boundingRect ]! ! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 9/1/2021 11:27:45' prior: 50602457! - clippingByCurrentMorphDo: aBlock - "Do clipping only if currentMorph says so" - - | prevClipRect prevClippingMorphRect | - - currentMorph clipsSubmorphsReally ifFalse: [ ^aBlock value ]. - - prevClipRect _ self clipRect. - prevClippingMorphRect _ clippingMorphDisplayBounds. - clippingMorphDisplayBounds _ self boundingRectOfCurrentMorphAfterDraw. - self setClipRect: (prevClipRect - ifNil: [clippingMorphDisplayBounds] - ifNotNil: [prevClipRect intersect: clippingMorphDisplayBounds]). - self clipCurrentMorph: true. - aBlock ensure: [ - self clipCurrentMorph: false. - self setClipRect: prevClipRect. - clippingMorphDisplayBounds _ prevClippingMorphRect ]! ! - -BitBltCanvas removeSelector: #boundingRectOfCurrentMorphAfterDraw! - -!methodRemoval: BitBltCanvas #boundingRectOfCurrentMorphAfterDraw stamp: 'Install-4825-MorphicRefactor-JuanVuletich-2021Sep01-11h05m-jmv.001.cs.st 9/3/2021 15:02:26'! -boundingRectOfCurrentMorphAfterDraw - "In targetForm coordinates. - Clipped to owner if appropriate. - BitBltCanvas doesn't keep track of Morph bounds as it draws them. But it is limited to drawing morphs where - #morphLocalBounds is known. Use it, then." - - ^self boundingRectOfCurrentMorphFromLocalBounds! - -BitBltBoundsFinderCanvas removeSelector: #boundingRectOfCurrentMorphAfterDraw! - -!methodRemoval: BitBltBoundsFinderCanvas #boundingRectOfCurrentMorphAfterDraw stamp: 'Install-4825-MorphicRefactor-JuanVuletich-2021Sep01-11h05m-jmv.001.cs.st 9/3/2021 15:02:26'! -boundingRectOfCurrentMorphAfterDraw - "In targetForm coordinates. - Clipped to owner if appropriate. - BitBltCanvas doesn't keep track of Morph bounds as it draws them. But it is limited to drawing morphs where - #morphLocalBounds is known. Use it, then." - - ^self boundingRectOfCurrentMorphFromLocalBounds! - -MorphicCanvas removeSelector: #boundingRectOfCurrentMorphFromLocalBounds! - -!methodRemoval: MorphicCanvas #boundingRectOfCurrentMorphFromLocalBounds stamp: 'Install-4825-MorphicRefactor-JuanVuletich-2021Sep01-11h05m-jmv.001.cs.st 9/3/2021 15:02:26'! -boundingRectOfCurrentMorphFromLocalBounds - "In targetForm coordinates. - Clipped to owner if appropriate. - Only valid for morphs where #morphLocalBounds is known" - - | boundingRect | - boundingRect _ currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds. - ^ clippingMorphDisplayBounds - ifNotNil: [ :ownerClips | boundingRect intersect: ownerClips ] - ifNil: [ boundingRect ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4825-MorphicRefactor-JuanVuletich-2021Sep01-11h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4822] on 1 September 2021 at 11:41:53 am'! -!Morph methodsFor: 'updating' stamp: 'jmv 9/1/2021 11:41:29' prior: 50597009! - redrawNeeded - "Report that the area occupied by this morph should be redrawn. - Usually because we changed in some way. - Notes: - Area used before any change is reported here. - Area used after any changes is reported when displayBounds are updated. - See updateBoundsIn:addDamageTo: and senders. - " - - self needsRedraw: true. - self allOwnersDo: [ :m | m submorphNeedsRedraw: true ]. - self basicDisplayBounds ifNotNil: [ :b | - "outsetBy: 1 due to anti aliasing in VectorCanvas" - self invalidateDisplayRect: (b outsetBy: 1) for: self ]. - (self submorphsMightProtrude and: [self clipsSubmorphsReally not]) ifTrue: [ - self submorphsReverseDo: [ :m | m redrawNeeded ]]. - self removeProperty: #bitMask. - self removeProperty: #fullBoundsInOwner.! ! - -Morph removeSelector: #displayBoundsOrBogus! - -!methodRemoval: Morph #displayBoundsOrBogus stamp: 'Install-4826-Morphic-Refactor-JuanVuletich-2021Sep01-11h34m-jmv.001.cs.st 9/3/2021 15:02:26'! -displayBoundsOrBogus - "Never answer nil. A bogus value will trigger a draw operation, and bounds will later be corrected. - Integer pixel coordinates!!" - - ^self basicDisplayBounds ifNil: [ - Rectangle center: (self externalizeToWorld: `0@0`) extent: `2@2` ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4826-Morphic-Refactor-JuanVuletich-2021Sep01-11h34m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4825] on 1 September 2021 at 12:19:43 pm'! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'jmv 9/1/2021 12:19:27' prior: 50446704! - calculateItemsPerPage - - | itemsThatCanFit | - - itemsThatCanFit _ (Display height - originalPosition y - 2) // self itemHeight. - itemsPerPage _ (itemsThatCanFit min: self maxItemsPerPage) min: self entryCount. - -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4827-Tweak-JuanVuletich-2021Sep01-12h14m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4827] on 1 September 2021 at 12:41:09 pm'! -!DisplayScreen methodsFor: 'private' stamp: 'jmv 9/1/2021 12:40:52' prior: 16835386 overrides: 16848801! - setExtent: aPoint depth: bitsPerPixel - "DisplayScreen startUp" - "This method is critical. If the setExtent fails, there will be no - proper display on which to show the error condition..." - - | bitsPerPixelToUse | - (depth = bitsPerPixel and: [aPoint = self extent and: [ - self supportsDisplayDepth: bitsPerPixel]]) ifFalse: [ - bits _ nil. "Free up old bitmap in case space is low" - bitsPerPixelToUse _ (self supportsDisplayDepth: bitsPerPixel) - ifTrue: [ bitsPerPixel ] - ifFalse: [ - (self supportsDisplayDepth: bitsPerPixel negated) - ifTrue: [ bitsPerPixel negated ] - ifFalse: [ self findAnyDisplayDepth ]]. - super setExtent: aPoint depth: bitsPerPixelToUse. - ]. - - "Let the world know" - self triggerEvent: #screenSizeChanged.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4828-Display-tweak-JuanVuletich-2021Sep01-12h40m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4828] on 1 September 2021 at 4:09:49 pm'! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 9/1/2021 15:44:52'! - checkForNewScreenSize - "Check whether the screen size has changed and if so take appropriate actions" - - DisplayScreen isDisplayExtentOk ifFalse: [ - self clearCanvas. - DisplayScreen startUp. - self setMainCanvas. - self restoreDisplay. - self whenUIinSafeState: [ Cursor defaultCursor activateCursor ]].! ! -!WorldMorph methodsFor: 'interaction loop' stamp: 'jmv 9/1/2021 15:46:02' prior: 50603127! - mainLoop - - - self clearWaitDelay. - canvas isNil ifTrue: [ - self setMainCanvas ]. - self redrawNeeded. - [ - self doOneCycle. - true ] - whileTrue: []! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 9/1/2021 15:39:30' prior: 50565041! - doOneCycleNow - "Immediately do one cycle of the interaction loop. - Only used for a few tests." - "See #eventTickler" - | hadAny | - Cursor currentCursor = (Cursor cursorAt: #waitCursor) ifTrue: [ Cursor defaultCursor activateCursor ]. - "Repair visual damage." - self checkForNewScreenSize. - self displayWorldSafely. - "Run steps, alarms and deferred UI messages" - self runStepMethods. - "Process user input events. Run all event triggered code." - hadAny _ false. - self handsDo: [ :h | - activeHand _ h. - hadAny _ hadAny | h processEventQueue. - activeHand _ nil ]. - "The default is the primary hand" - activeHand _ self hands first. - ^ hadAny.! ! -!WorldMorph class methodsFor: 'instance creation' stamp: 'jmv 9/1/2021 15:46:58' prior: 50603180! - newWorld - " -[ - UISupervisor stopUIProcess. - UISupervisor spawnNewMorphicProcessFor: WorldMorph newWorld -] fork. - " - | w | - w _ self new. - w morphPosition: `0@0` extent: Display extent. - w handsDo: [ :h | - h privateOwner: w ]. - ^w! ! -!TheWorldMenu methodsFor: 'commands' stamp: 'jmv 9/1/2021 15:33:22' prior: 50379967! - fullScreenOff - - Display fullScreenMode: false.! ! -!TheWorldMenu methodsFor: 'commands' stamp: 'jmv 9/1/2021 15:33:17' prior: 50379974! - fullScreenOn - - Display fullScreenMode: true.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 9/1/2021 15:55:46' prior: 50603192! - activeSubclass: aMorphicCanvasSubclass - ActiveSubclass _ aMorphicCanvasSubclass. - UISupervisor ui ifNotNil: [ :world | - world whenUIinSafeState: [ - world setMainCanvas ]].! ! - -WorldMorph removeSelector: #extentChanged:! - -!methodRemoval: WorldMorph #extentChanged: stamp: 'Install-4829-Morphic-Refactor-JuanVuletich-2021Sep01-16h05m-jmv.001.cs.st 9/3/2021 15:02:26'! -extentChanged: oldExtent - "Our extent changed. Must layout submorphs again." - - super extentChanged: oldExtent. - self setMainCanvas! - -DisplayScreen class removeSelector: #checkForNewScreenSize! - -!methodRemoval: DisplayScreen class #checkForNewScreenSize stamp: 'Install-4829-Morphic-Refactor-JuanVuletich-2021Sep01-16h05m-jmv.001.cs.st 9/3/2021 15:02:26'! -checkForNewScreenSize - "Check whether the screen size has changed and if so take appropriate actions" - - self isDisplayExtentOk ifFalse: [ - UISupervisor restoreDisplay ]! - -UISupervisor class removeSelector: #restoreDisplay! - -!methodRemoval: UISupervisor class #restoreDisplay stamp: 'Install-4829-Morphic-Refactor-JuanVuletich-2021Sep01-16h05m-jmv.001.cs.st 9/3/2021 15:02:26'! -restoreDisplay - self ui ifNotNil: [ :guiRootObject | - DisplayScreen isDisplayExtentOk ifFalse: [ - "Deallocate before allocating could mean less memory stress." - guiRootObject clearCanvas ]]. - DisplayScreen startUp. - self ui ifNotNil: [ :guiRootObject | - guiRootObject restoreDisplay ]. - self whenUIinSafeState: [ Cursor defaultCursor activateCursor ].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4829-Morphic-Refactor-JuanVuletich-2021Sep01-16h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4829] on 1 September 2021 at 6:18:08 pm'! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 9/1/2021 18:14:16' prior: 50596713! - setForm: aForm subPixelAntiAliasing: aBooleanOrNil - "nil means use default kind of anti aliasing. Ignored in BitBltCanvas." - - form _ aForm. - engine _ BitBltCanvasEngine toForm: form. - "Init BitBlt so that the first call to the 'primitiveDisplayString' primitive will not fail" - engine sourceX: 0; width: 0. - self newClipRect: nil.! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 9/1/2021 18:15:37' prior: 50603089! - setPluginAndForm: aForm - "No VectorEnginePlugin in BitBltCanvas." - - self setForm: aForm subPixelAntiAliasing: nil.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4830-Tweaks-JuanVuletich-2021Sep01-18h13m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4830] on 2 September 2021 at 8:52:39 am'! -!DisplayScreen methodsFor: 'accessing' stamp: 'jmv 9/2/2021 08:52:10' prior: 50603057! - getMainCanvas - "Return a Canvas that can be used to draw onto the receiver. - Being the sole 'main' canvas means a priviledge: Can use VectorEnginePlugin if available." - - | answer | - answer _ [ MorphicCanvas withVectorEnginePluginOnForm: self ] - on: OutOfMemory - do: [ - 'Not enough memory to run VectorEngine. Using BitBltCanvas instead.' print. - MorphicCanvas activeSubclass: BitBltCanvas. - MorphicCanvas withVectorEnginePluginOnForm: self ]. - ^answer! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4831-CanvasCreation-HandleOutOfMemory-JuanVuletich-2021Sep02-08h45m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4831] on 2 September 2021 at 4:31:06 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 9/2/2021 16:25:56' prior: 50604118! - displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Clipped appropiately if some owner clips us. - See also #displayBoundsUpdateFrom:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - (aCanvas isBoundsFinderCanvas or: [c canvasToUse == aCanvas canvasToUse]) ifTrue: [ - privateDisplayBounds _ aCanvas canvasToUse boundingRectOfCurrentMorphAfterDraw. - self wantsContour - ifTrue: [ - (aCanvas canvasToUse - contourOfCurrentMorphAfterDrawInto: (self valueOfProperty: #contour) - into: [ :contourArray :contourY0 :contourY1 | - self setProperty: #contour toValue: contourArray. - self setProperty: #contourY0 toValue: contourY0. - self setProperty: #contourY1 toValue: contourY1 ])] - ifFalse: [ - self setProperty: #contour toValue: nil. - self setProperty: #contourY0 toValue: nil. - self setProperty: #contourY1 toValue: nil ]]]].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 9/2/2021 16:27:13' prior: 50604154! - displayBoundsUpdateFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us. - To be called after #postDrawOn:. See also #displayBoundsSetFrom: - This more complicated update is needed because the contour information from #drawOn: was possibly - when drawing submorphs. So, the controur from #drawOn: needs to be retrieved, and updated with the - new contour information from #postDrawOn:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - (aCanvas isBoundsFinderCanvas or: [c canvasToUse == aCanvas canvasToUse]) ifTrue: [ - privateDisplayBounds _ privateDisplayBounds - quickMerge: aCanvas canvasToUse boundingRectOfCurrentMorphAfterDraw. - self wantsContour ifTrue: [ - (aCanvas canvasToUse - contourOfCurrentMorphAfterDrawUpdate: (self valueOfProperty: #contour) - oldTop: (self valueOfProperty: #contourY0) - oldBottom: (self valueOfProperty: #contourY1) - into: [ :contourArray :contourY0 :contourY1 | - self setProperty: #contour toValue: contourArray. - self setProperty: #contourY0 toValue: contourY0. - self setProperty: #contourY1 toValue: contourY1 ])]]]].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 9/2/2021 16:15:12' prior: 50604197! - boundingRectOfCurrentMorphAfterDraw - "In targetForm coordinates. - Clipped to owner if appropriate. - Only valid for morphs where #morphLocalBounds is known. - Subclasses may raise this restriction. See inherintance, with VectorGraphics package loaded." - - | boundingRect | - boundingRect _ currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds. - ^ clippingMorphDisplayBounds - ifNotNil: [ :ownerClips | boundingRect intersect: ownerClips ] - ifNil: [ boundingRect ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4832-Morphic-boundsSetFix-JuanVuletich-2021Sep02-16h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4832] on 3 September 2021 at 11:27:46 am'! -!SpaceTally commentStamp: 'jmv 9/3/2021 10:57:56' prior: 16912391! - I'm responsible to help getting information about system space usage. The information I compute is represented by a spaceTallyItem - -try something like: - -((SpaceTally new spaceTally: (Array with: Morph with: Point)) - asSortedCollection: [:a :b | a spaceForInstances > b spaceForInstances]) - -SpaceTally new systemWideSpaceTally - -Also try: -'MemoryAnalysis.txt' asFileEntry forceWriteStreamDo: [ :stream | - SpaceTally new printSpaceAnalysis: 1 on: stream ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4833-SpaceTally-tweak-JuanVuletich-2021Sep03-10h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4832] on 3 September 2021 at 12:43:37 pm'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 9/3/2021 12:43:27'! - setDefaultGCParameters - "Adjust the VM's default GC parameters to avoid premature tenuring, and too frequent scavenging. - Parameters set here persist in saved images, so we set them image save for release. - See #setGCParameters" - - "Desired Eden size: " - Smalltalk vmParameterAt: 45 put: `16*1024*1024`.! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 9/3/2021 12:28:41' prior: 50599621! - saveAsNewReleaseAndQuit - "Save the image/changes using the next available version number. - This is usually only used to prepare updated Cuis images for distribution." - " - Smalltalk saveAsNewReleaseAndQuit - " - | fileName newName changesName systemVersion | - systemVersion _ SystemVersion current. - fileName _ String streamContents: [ :strm | - strm - nextPutAll: 'Cuis'; - print: systemVersion versionMajor; - nextPut: $.; - print: systemVersion versionMinor; - nextPut: $-; - print: systemVersion highestUpdate. - Smalltalk isSpur - ifTrue: [ - Smalltalk wordSize = 4 ifTrue: [ - strm nextPutAll: '-32' ]] - ifFalse: [ - strm nextPutAll: '-v3' ]]. - newName _ fileName, '.image'. - (DirectoryEntry smalltalkImageDirectory // newName) exists ifTrue: [ - newName _ DirectoryEntry smalltalkImageDirectory - nextNameFor: fileName - extension: 'image' ]. - changesName _ self fullNameForChangesNamed: newName. - "Check to see if there is a .changes file that would cause a problem if we saved a new .image file with the new version number" - changesName asFileEntry exists ifTrue: [ - ^ self inform: -'There is already .changes file of the desired name, -', changesName, ' -curiously already present, even though there is no -corresponding .image file. -Please remedy manually and then repeat your request.' ]. - self setDefaultGCParameters. - "Try to clear all user state, including all class vars, preferences, etc" - self saveAndQuitAs: newName clearAllClassState: true! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 9/3/2021 12:28:53' prior: 50602373! - saveAsNewReleaseAndStay - "Save the image/changes using the next available version number. - This is usually only used to prepare updated Cuis images for distribution." - " - Smalltalk saveAsNewReleaseAndStay - " - | fileName newName changesName systemVersion | - systemVersion _ SystemVersion current. - fileName _ String streamContents: [ :strm | - strm - nextPutAll: 'Cuis'; - print: systemVersion versionMajor; - nextPut: $.; - print: systemVersion versionMinor; - nextPut: $-; - print: systemVersion highestUpdate. - Smalltalk isSpur - ifTrue: [ - Smalltalk wordSize = 4 ifTrue: [ - strm nextPutAll: '-32' ]] - ifFalse: [ - strm nextPutAll: '-v3' ]]. - newName _ fileName, '.image'. - (DirectoryEntry smalltalkImageDirectory // newName) exists ifTrue: [ - newName _ DirectoryEntry smalltalkImageDirectory - nextNameFor: fileName - extension: 'image' ]. - changesName _ self fullNameForChangesNamed: newName. - "Check to see if there is a .changes file that would cause a problem if we saved a new .image file with the new version number" - changesName asFileEntry exists ifTrue: [ - ^ self inform: -'There is already .changes file of the desired name, -', changesName, ' -curiously already present, even though there is no -corresponding .image file. -Please remedy manually and then repeat your request.' ]. - self setDefaultGCParameters. - "Try to clear all user state, including all class vars, preferences, etc" - self saveAndStayAs: newName clearAllClassState: true! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 9/3/2021 12:43:22' prior: 16922843! - setGCParameters - "Adjust the VM's default GC parameters to avoid premature tenuring, and too frequent scavenging. - Parameters set here don't persist, so we set them on startup. - See #setDefaultGCParameters" - - "Grow old memory in chunks of: " - Smalltalk vmParameterAt: 25 put: `32*1024*1024`. - "Shrink heap when unused memory is at least: " - Smalltalk vmParameterAt: 24 put: `64*1024*1024`. - - Smalltalk isSpur - ifTrue: [ - "Note: (jmv, 9/2021) It seems modern Spur VMs ignore parameter 6. This all seems to be bogus." - | proportion edenSize survivorSize averageObjectSize numObjects | - proportion := 0.9. "tenure when 90% of pastSpace is full" - edenSize := self vmParameterAt: 44. - survivorSize := edenSize / 5.0. "David's paper uses 140Kb eden + 2 x 28kb survivor spaces; Spur uses the same ratios :-)" - averageObjectSize := 8 * self wordSize. "a good approximation" - numObjects := (proportion * survivorSize / averageObjectSize) rounded. - self vmParameterAt: 6 put: numObjects. "tenure when more than this many objects survive the GC" - "/Note: (jmv, 9/2021)" - - "Do a full GC when used memory grows by this factor. Fails on non-Spur VMs. - Default is 0.333. - 2.0 means gull GC when heap size triples." - Smalltalk vmParameterAt: 55 put: 2.0. - ] - ifFalse: [ - Smalltalk vmParameterAt: 5 put: 4000. "do an incremental GC after this many allocations" - Smalltalk vmParameterAt: 6 put: 2000. "tenure when more than this many objects survive the GC" - ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4834-Enlarge-GCParameters-JuanVuletich-2021Sep03-11h27m-jmv.001.cs.st----! - -----QUIT----(3 September 2021 15:02:29) Cuis5.0-4834-32.image priorSource: 8697056! - -----STARTUP---- (21 September 2021 12:54:02) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4834-32.image! - - -'From Haver 5.0 [latest update: #4821] on 1 September 2021 at 5:39:26 pm'! -!Boolean methodsFor: 'user interface support' stamp: 'KLG 9/1/2021 17:33:22'! - asMenuItemTextPrefix - "Answer '' or '' to prefix a menu item text with a check box. " - - ^ self subclassResponsibility! ! -!False methodsFor: 'user interface support' stamp: 'KLG 9/1/2021 17:33:51' overrides: 50604882! - asMenuItemTextPrefix - "Answer '' or '' to prefix a menu item text with a check box. " - - ^ ''! ! -!True methodsFor: 'user interface support' stamp: 'KLG 9/1/2021 17:34:02' overrides: 50604882! - asMenuItemTextPrefix - "Answer '' or '' to prefix a menu item text with a check box. " - - ^ ''! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4835-asMenuItemTextPrefix-GeraldKlix-2021Sep01-17h30m-KLG.001.cs.st----! - -'From Haver 5.0 [latest update: #4821] on 1 September 2021 at 7:00:13 pm'! -!TaskbarMorph class methodsFor: 'as yet unclassified' stamp: 'KLG 9/1/2021 18:58:39' overrides: 16877245! - includeInNewMorphMenu - "Return true for all classes that can be instantiated from the menu - - More than one taskbar confuses the running wolrd!!" - - ^ false! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4836-NoAdditionalTaskbarMorphs-GeraldKlix-2021Sep01-17h39m-KLG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4836] on 5 September 2021 at 1:59:07 pm'! -!CodeProvider methodsFor: 'diffs' stamp: 'jmv 9/5/2021 13:54:43' prior: 16812346! - showingLineDiffsString - "Answer a string representing whether I'm showing regular diffs" - - ^ self showingLineDiffs asMenuItemTextPrefix, - 'lineDiffs'! ! -!CodeProvider methodsFor: 'diffs' stamp: 'jmv 9/5/2021 13:55:59' prior: 16812361! - showingPrettyLineDiffsString - "Answer a string representing whether I'm showing pretty diffs" - - ^ self showingPrettyLineDiffs asMenuItemTextPrefix, - 'linePrettyDiffs'! ! -!CodeProvider methodsFor: 'diffs' stamp: 'jmv 9/5/2021 13:56:14' prior: 16812377! - showingPrettyWordDiffsString - "Answer a string representing whether I'm showing pretty diffs" - - ^ self showingPrettyWordDiffs asMenuItemTextPrefix, - 'wordPrettyDiffs'! ! -!CodeProvider methodsFor: 'diffs' stamp: 'jmv 9/5/2021 13:56:25' prior: 16812393! - showingWordDiffsString - "Answer a string representing whether I'm showing regular diffs" - - ^ self showingWordDiffs asMenuItemTextPrefix, - 'wordDiffs'! ! -!CodeProvider methodsFor: 'what to show' stamp: 'jmv 9/5/2021 13:55:22' prior: 16812559! - prettyPrintString - "Answer whether the receiver is showing pretty-print" - - ^ self showingPrettyPrint asMenuItemTextPrefix, - 'prettyPrint'! ! -!CodeProvider methodsFor: 'what to show' stamp: 'jmv 9/5/2021 13:53:44' prior: 16812605! - showingByteCodesString - "Answer whether the receiver is showing bytecodes" - - ^ self showingByteCodes asMenuItemTextPrefix, - 'byteCodes'! ! -!CodeProvider methodsFor: 'what to show' stamp: 'jmv 9/5/2021 13:54:04' prior: 16812620! - showingDecompileString - "Answer a string characerizing whether decompilation is showing" - - ^ self showingDecompile asMenuItemTextPrefix, - 'decompile'! ! -!CodeProvider methodsFor: 'what to show' stamp: 'jmv 9/5/2021 13:54:20' prior: 16812636! - showingDocumentationString - "Answer a string characerizing whether documentation is showing" - - ^ self showingDocumentation asMenuItemTextPrefix, - 'documentation'! ! -!CodeProvider methodsFor: 'what to show' stamp: 'jmv 9/5/2021 13:55:44' prior: 16812651! - showingPlainSourceString - "Answer a string telling whether the receiver is showing plain source" - - ^ self showingPlainSource asMenuItemTextPrefix, - 'source'! ! -!Morph methodsFor: 'menus' stamp: 'jmv 9/5/2021 13:57:02' prior: 16876328! - stickinessString - "Answer the string to be shown in a menu to represent the - stickiness status" - - ^ self isSticky asMenuItemTextPrefix, - 'resist being picked up'! ! -!InnerTextMorph methodsFor: 'menu' stamp: 'jmv 9/5/2021 13:57:19' prior: 16855935! - wrapString - "Answer the string to put in a menu that will invite the user to - switch word wrap mode" - ^ wrapFlag asMenuItemTextPrefix, - 'text wrap to bounds'! ! -!FileListWindow methodsFor: 'menu building' stamp: 'jmv 9/5/2021 13:58:00' prior: 50602245! - volumeMenu - | aMenu initialDirectoriesMenu | - aMenu _ MenuMorph new defaultTarget: model. - aMenu - add: 'delete directory...' - action: #deleteDirectory - icon: #warningIcon :: setBalloonText: 'Delete the selected directory'. - model currentDirectorySelected - ifNil: [ aMenu add: 'initial directory' action: #yourself :: isEnabled: false ] - ifNotNil: [ :selectedWrapper | - aMenu - add: (Preferences isInitialFileListDirectory: selectedWrapper item) - asMenuItemTextPrefix, 'initial directory' - action: #toggleInitialDirectory :: - setBalloonText: 'The selected directory is an initial director for new file list windows' ]. - initialDirectoriesMenu _ MenuMorph new. - #( - (roots 'default roots' 'Use the usual root directories. Drives on Windows; "/" on Unix') - (image 'image directory' 'Use the directory with Smalltalk image') - (vm 'VM directory' 'Use the virtual machine directory') - (current 'current directory' 'Use the current directory; usually the directory the VM was started in') - ) - do: [ :entry | - initialDirectoriesMenu - add: entry second - target: Preferences - action: #initialFileListDirectories: - argument: entry first :: - setBalloonText: entry third ]. - aMenu add: 'default initial directories' subMenu: initialDirectoriesMenu. - ^ aMenu! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4837-MakeGoodUseOf4835-JuanVuletich-2021Sep05-13h52m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4837] on 5 September 2021 at 7:51:29 pm'! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 9/5/2021 18:38:10' overrides: 50552865! - fontPreferenceChanged - - super fontPreferenceChanged. - scrollBar recreateSubmorphs. - hScrollBar recreateSubmorphs. - self setScrollDeltas.! ! - -ScrollBar removeSelector: #fontPreferenceChanged! - -!methodRemoval: ScrollBar #fontPreferenceChanged stamp: 'Install-4838-GUIelementsSizeChangeFix-JuanVuletich-2021Sep05-19h50m-jmv.001.cs.st 9/21/2021 12:54:08'! -fontPreferenceChanged - "Rescale" - - self recreateSubmorphs! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4838-GUIelementsSizeChangeFix-JuanVuletich-2021Sep05-19h50m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4837] on 5 September 2021 at 7:52:31 pm'! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 9/5/2021 19:52:05' prior: 50568016! - setDefaultFont: aFontName - "Change the font on the whole system without changing point sizes." - FontFamily defaultFamilyName: aFontName. - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: { - {#setListFontTo:. Preferences standardListFont pointSize.}. - {#setMenuFontTo:. Preferences standardMenuFont pointSize.}. - {#setWindowTitleFontTo:. Preferences windowTitleFont pointSize.}. - {#setCodeFontTo:. Preferences standardCodeFont pointSize.}. - {#setButtonFontTo:. Preferences standardButtonFont pointSize.}. - }. - MorphicCanvas allSubclassesDo: [ :c| c guiSizePreferenceChanged ]. - UISupervisor ui ifNotNil: [ :w | w fontPreferenceChanged ].! ! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 9/5/2021 19:51:58' prior: 50602840! - setDefaultFont: fontFamilyName spec: defaultFontsSpec - - | font | - defaultFontsSpec do: [ :triplet | - font _ FontFamily familyName: fontFamilyName pointSize: triplet second. - font ifNil: [ font _ FontFamily defaultFamilyAndPointSize ]. - triplet size > 2 ifTrue: [ - font _ font emphasized: triplet third ]. - self - perform: triplet first - with: font ]. - MorphicCanvas allSubclassesDo: [ :c| c guiSizePreferenceChanged ]. - UISupervisor ui ifNotNil: [ :w | w fontPreferenceChanged ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4839-GUISizePreferenceChanged-JuanVuletich-2021Sep05-19h51m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4839] on 6 September 2021 at 10:24:41 am'! -!HaloMorph methodsFor: 'drawing' stamp: 'jmv 9/6/2021 10:21:10' prior: 50596319! - drawCoordinateSystemOn: aCanvas - - | x0 x1 y0 y1 c stepX stepY haloTargetTx prevTx | - haloTargetTx _ MorphicTranslation identity. - target allOwnersReverseDo: [ :o | haloTargetTx _ haloTargetTx composedWith: o location ]. - haloTargetTx _ haloTargetTx composedWith: target location. - - target knowsOwnLocalBounds - ifTrue: [ | r | - r _ target morphLocalBounds. - x0 _ r left. - x1 _ r right. - y0 _ r top. - y1 _ r bottom ] - ifFalse: [ - x0 _ x1 _ y0 _ y1 _ 0. - target displayFullBounds corners collect: [ :pt | | p | - p _ haloTargetTx inverseTransform: pt. - x0 _ x0 min: p x. - x1 _ x1 max: p x. - y0 _ y0 min: p y. - y1 _ y1 max: p y.]]. - stepX _ FontFamily defaultPointSize * 4 //10 * 10. - stepY _ FontFamily defaultPointSize * 2 //10 * 10. - - prevTx _ aCanvas currentTransformation. - aCanvas geometryTransformation: haloTargetTx. - - c _ `Color black alpha: 0.4`. - aCanvas line: x0@0 to: x1@0 width: 2 color: c. - aCanvas line: 0@y0 to: 0@y1 width: 2 color: c. - - (x0 truncateTo: stepX) to: (x1 - stepX truncateTo: stepX) by: stepX do: [ :x | - aCanvas line: x @ -5 to: x @ 5 width: 2 color: c. - aCanvas drawString: x printString atCenterXBaselineY: x @ -10 font: nil color: c ]. - aCanvas drawString: 'x' atCenterX: x1 - 15 @ 0 font: nil color: c. - - (y0 truncateTo: stepY) to: (y1 - stepY truncateTo: stepY) by: stepY do: [ :y | - aCanvas line: -5 @ y to: 5 @ y width: 2 color: c. - aCanvas drawString: y printString, ' ' atWaistRight: -5 @ y font: nil color: c ]. - aCanvas drawString: 'y' atWaistRight: -5 @ (y1 - 20) font: nil color: c. - - aCanvas geometryTransformation: prevTx.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4840-drawCoordinateSystem-tweak-JuanVuletich-2021Sep05-20h14m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4839] on 6 September 2021 at 11:07:34 am'! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 9/6/2021 11:07:11' prior: 50604024! - displayWorldSafely - "Update this world's display and keep track of errors during draw methods." - - [self displayWorld] on: Error, Halt do: [ :ex | - "Handle a drawing error" - canvas currentMorphDrawingFails. - "Creating a new canvas here could be dangerous, as code signaling the exception will be resumed." - self resetCanvas. - "Install the old error handler, so we can re-raise the error" - ex receiver error: ex description. - ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4841-Morphic-ErrorHandling-fix-JuanVuletich-2021Sep06-11h07m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4841] on 6 September 2021 at 12:08:56 pm'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 9/6/2021 12:08:14' prior: 50559607! - fullDraw: aMorph - "Draw the full Morphic structure on us" - - "We are already set with a proper transformation from aMorph owner's coordinates to those of our target form." - - self flag: #jmvVer3. - aMorph visible ifFalse: [^ self]. - self into: aMorph. - - currentMorph layoutSubmorphsIfNeeded. - - currentMorph isKnownFailing ifTrue: [ - self canvasToUse drawCurrentAsError. - self outOfMorph. - ^ self]. - - (currentMorph isOwnedByHand and: [ - Preferences cheapWindowReframe and: [currentMorph is: #SystemWindow]]) ifTrue: [ - self drawCurrentAsOutline. - self outOfMorph. - ^ self]. - - "Draw current Morph and submorphs" - self canvasToUse drawCurrentAndSubmorphs. - - self outOfMorph! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4842-cheapWindowReframe-onlyForWindows-JuanVuletich-2021Sep06-12h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4841] on 6 September 2021 at 12:47:09 pm'! -!CodePackage methodsFor: 'naming' stamp: 'jmv 9/6/2021 12:17:27'! - packageDirectory - - ^self packageDirectoryName asDirectoryEntry! ! - -CodePackage removeSelector: #pagkageDirectory! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4843-packageDirectory-JuanVuletich-2021Sep06-12h08m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4843] on 6 September 2021 at 3:12:10 pm'! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 9/6/2021 15:06:24'! - isDrawnBySoftware - "Return true if this hand must be drawn explicitely instead of being drawn via the hardware cursor. This is the case if it (a) it is a remote hand, (b) it is showing a temporary cursor, or (c) it is not empty and there are any visible submorphs. If using the software cursor, ensure that the hardware cursor is hidden." - "Details: Return true if this hand has a saved patch to ensure that is is processed by the world. This saved patch will be deleted after one final display pass when it becomes possible to start using the hardware cursor again. This trick gives us one last display cycle to allow us to remove the software cursor from the display." - "Note. We draw the hand as a regular morph (using #drawOn:), disabling the hardware cursor, when we carry submorphs. The reason is to lock the mouse pointer and the carried morph together. Otherwhise the carried morph would lag behind the mouse pointer. - This method answers whether the regular #drawOn: drawing mechanism is used for us. - - Check senders. Hand drawing is handled explicitly by the world, because the Hand is not a submorph of the world!!" - | blankCursor | - (prevFullBounds notNil or: [ - submorphs anySatisfy: [ :ea | - ea visible ]]) ifTrue: [ - "using the software cursor; hide the hardware one" - blankCursor _ Cursor cursorAt: #blankCursor. - Cursor currentCursor == blankCursor ifFalse: [ blankCursor activateCursor ]. - ^ true ]. - ^ false.! ! -!WorldMorph methodsFor: 'hands' stamp: 'jmv 9/6/2021 15:06:31' prior: 50570236! - selectHandsToDrawForDamage: damageList - "Select the set of hands that must be redrawn because either (a) the hand itself has changed or (b) the hand intersects some damage rectangle." - - | result | - result _ OrderedCollection new. - hands do: [:hand | - hand isDrawnBySoftware ifTrue: [ - hand isRedrawNeeded - ifTrue: [result add: hand] - ifFalse: [ - hand displayFullBounds ifNotNil: [ :handBounds | - (damageList anySatisfy: [ :r | r intersects: handBounds]) ifTrue: [ - result add: hand]]]]]. - ^ result! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 9/6/2021 15:06:36' prior: 50570256! - checkIfUpdateNeeded - - self isSubmorphRedrawNeeded ifTrue: [ ^true ]. - damageRecorder updateIsNeeded ifTrue: [^true]. - hands do: [:h | (h isRedrawNeeded | h isSubmorphRedrawNeeded and: [h isDrawnBySoftware]) ifTrue: [^true]]. - ^false "display is already up-to-date" -! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 9/6/2021 15:10:14' prior: 50564980! - doOneCycle - "Do one cycle of the interaction loop. This method is called repeatedly when the world is running. - - Make for low cpu usage if the ui is inactive, but quick response when ui is in use. - However, after some inactivity, there will be a larger delay before the ui gets responsive again." - - | wait waitUntil | - waitDelay ifNil: [ waitDelay _ Delay forMilliseconds: 50 ]. - (lastCycleHadAnyEvent or: [ deferredUIMessages isEmpty not ]) - ifTrue: [ - pause _ 20. "This value will only be used later, when there are no more events to serve or deferred UI messages to process." - wait _ 0. "Don't wait this time"] - ifFalse: [ - "wait between 20 and 200 milliseconds" - (hands anySatisfy: [ :h | h waitingForMoreClicks ]) - ifTrue: [ pause _ 20 ] - ifFalse: [ pause < 200 ifTrue: [ pause _ pause * 21//20 ] ]. - waitUntil _ lastCycleTime + pause. - "Earlier if steps" - stepList isEmpty not ifTrue: [ - waitUntil _ waitUntil min: stepList first scheduledTime ]. - "Earlier if alarms" - alarms ifNotNil: [ - alarms isEmpty not ifTrue: [ - waitUntil _ waitUntil min: alarms first scheduledTime ]]. - wait _ waitUntil - Time localMillisecondClock max: 0 ]. - Preferences serverMode - ifTrue: [ wait _ wait max: 50 ]. "Always wait at least a bit on servers, even if this makes the UI slow." - wait = 0 - ifTrue: [ Processor yield ] - ifFalse: [ - waitDelay beingWaitedOn - ifFalse: [ waitDelay setDelay: wait; wait ] - ifTrue: [ - "If we are called from a different process than that of the main UI, we might be called in the main - interCyclePause. In such case, use a new Delay to avoid 'This Delay has already been scheduled' errors" - (Delay forMilliseconds: wait) wait ]]. - - "Record start time of this cycle, and do cycle" - lastCycleTime _ Time localMillisecondClock. - lastCycleHadAnyEvent _ self doOneCycleNow.! ! - -HandMorph removeSelector: #needsToBeDrawn! - -!methodRemoval: HandMorph #needsToBeDrawn stamp: 'Install-4844-DelayInMenuOpenBug-Fix-JuanVuletich-2021Sep06-15h09m-jmv.001.cs.st 9/21/2021 12:54:08'! -needsToBeDrawn - "Return true if this hand must be drawn explicitely instead of being drawn via the hardware cursor. This is the case if it (a) it is a remote hand, (b) it is showing a temporary cursor, or (c) it is not empty and there are any visible submorphs. If using the software cursor, ensure that the hardware cursor is hidden." - "Details: Return true if this hand has a saved patch to ensure that is is processed by the world. This saved patch will be deleted after one final display pass when it becomes possible to start using the hardware cursor again. This trick gives us one last display cycle to allow us to remove the software cursor from the display." - "Note. We draw the hand as a regular morph (using #drawOn:), disabling the hardware cursor, when we carry submorphs. The reason is to lock the mouse pointer and the carried morph together. Otherwhise the carried morph would lag behind the mouse pointer. - This method answers whether the regular #drawOn: drawing mechanism is used for us. - - Check senders. Hand drawing is handled explicitly by the world, because the Hand is not a submorph of the world!!" - | blankCursor | - (prevFullBounds notNil or: [ - submorphs anySatisfy: [ :ea | - ea visible ]]) ifTrue: [ - "using the software cursor; hide the hardware one" - blankCursor _ Cursor cursorAt: #blankCursor. - Cursor currentCursor == blankCursor ifFalse: [ blankCursor activateCursor ]. - ^ true ]. - ^ false.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4844-DelayInMenuOpenBug-Fix-JuanVuletich-2021Sep06-15h09m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4844] on 6 September 2021 at 3:36:59 pm'! -!Morph methodsFor: 'initialization' stamp: 'jmv 9/6/2021 15:21:29' prior: 16875917! - intoWorld: aWorld - "The receiver has just appeared in a new world. Note: - * aWorld can be nil (due to optimizations in other places) - * owner is already set - * owner's submorphs may not include receiver yet. - Important: Keep this method fast - it is run whenever morphs are added." - - aWorld ifNil: [ ^self ]. - self needsRedraw: true. - self wantsSteps ifTrue: [ self startStepping ]. - self submorphsDo: [ :m | m intoWorld: aWorld ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4845-AlwaysRefreshNewMorphs-JuanVuletich-2021Sep06-15h36m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4844] on 6 September 2021 at 3:37:39 pm'! -!WorldMorph methodsFor: 'events' stamp: 'jmv 9/6/2021 15:20:19' prior: 50552190 overrides: 16874466! - click: aMouseButtonEvent localPosition: localEventPosition - - ^self mouseButton2Activity.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4846-DontWaitToOpenWorldMenu-JuanVuletich-2021Sep06-15h36m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4844] on 6 September 2021 at 3:38:16 pm'! -!HandMorph methodsFor: 'double click support' stamp: 'jmv 9/6/2021 15:30:21'! - waitForClicksOrDragOrSimulatedMouseButton2: aMorph event: evt clkSel: clkSel - - "Wait until the difference between click, or drag gesture is known, then inform the given morph what transpired." - - mouseClickState _ - MouseClickState new - client: aMorph - drag: nil - click: clkSel - clickAndHalf: nil - dblClick: nil - dblClickAndHalf: nil - tripleClick: nil - event: evt - sendMouseButton2Activity: Preferences tapAndHoldEmulatesButton2. - - "It seems the Mac VM may occasionally lose button up events triggering bogus activations. - Hence Preferences tapAndHoldEmulatesButton2"! ! -!MouseClickState methodsFor: 'private' stamp: 'jmv 9/6/2021 15:33:13'! - notWaitingForMultipleClicks - - ^ clickAndHalfSelector isNil and: [ - dblClickSelector isNil and: [ - dblClickAndHalfSelector isNil and: [ - tripleClickSelector isNil ]]]! ! -!PasteUpMorph methodsFor: 'events' stamp: 'jmv 9/6/2021 15:30:26' prior: 50550883 overrides: 16874541! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - "Handle a mouse down event." - - super mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition. - - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: #click:localPosition:.! ! -!MouseClickState methodsFor: 'actions' stamp: 'jmv 9/6/2021 15:33:53' prior: 50574240! - handleEvent: aMouseEvent from: aHand - "Process the given mouse event to detect a click, double-click, or drag. - Return true if the event should be processed by the sender, false if it shouldn't. - NOTE: This method heavily relies on getting *all* mouse button events." - - | timedOut distance | - timedOut _ (aMouseEvent timeStamp - lastClickDown timeStamp) > self class doubleClickTimeout. - timedOut ifTrue: [ aHand dontWaitForMoreClicks ]. - distance _ (aMouseEvent eventPosition - lastClickDown eventPosition) r. - "Real action dispatch might be done after the triggering event, for example, because of waiting for timeout. - So, count the button downs and ups(clicks), to be processed, maybe later, maybe in a mouseMove..." - aMouseEvent isMouseDown ifTrue: [ - lastClickDown _ aMouseEvent. - buttonDownCount _ buttonDownCount + 1 ]. - aMouseEvent isMouseUp ifTrue: [ - buttonUpCount _ buttonUpCount + 1 ]. - - "Drag, or tap & hold" - (buttonDownCount = 1 and: [ buttonUpCount = 0]) ifTrue: [ - (self notWaitingForMultipleClicks or: [ distance > 0 ]) ifTrue: [ - "If we have already moved, then it won't be a double or triple click... why wait?" - aHand dontWaitForMoreClicks. - dragSelector - ifNotNil: [ self didDrag ] - ifNil: [ self didClick ]. - ^ false ]. - timedOut ifTrue: [ - aHand dontWaitForMoreClicks. - "Simulate button 2 via tap & hold. Useful for opening menus on pen computers." - sendMouseButton2Activity ifTrue: [ - clickClient mouseButton2Activity ]. - ^ false ]]. - - "If we're over triple click, or timed out, or mouse moved, don't allow more clicks." - (buttonDownCount = 4 or: [ timedOut or: [ distance > 0 ]]) ifTrue: [ - aHand dontWaitForMoreClicks. - ^ false ]. - - "Simple click." - (buttonDownCount = 1 and: [ buttonUpCount = 1 ]) ifTrue: [ - self didClick ]. - - "Click & hold" - (buttonDownCount = 2 and: [ buttonUpCount = 1]) ifTrue: [ - self didClickAndHalf ]. - - "Double click." - (buttonDownCount = 2 and: [ buttonUpCount = 2]) ifTrue: [ - self didDoubleClick ]. - - "Double click & hold." - (buttonDownCount = 3 and: [ buttonUpCount = 2]) ifTrue: [ - self didDoubleClickAndHalf ]. - - "Triple click" - (buttonDownCount = 3 and: [ buttonUpCount = 3]) ifTrue: [ - self didTripleClick ]. - - "This means: if a mouseDown, then don't further process this event (so we can turn it into a double or triple click on next buttonUp)" - ^ aMouseEvent isMouseDown! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4847-MouseClickState-tweaks-JuanVuletich-2021Sep06-15h37m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4847] on 6 September 2021 at 7:55:36 pm'! -!MouseClickState methodsFor: 'actions' stamp: 'jmv 6/17/2021 13:01:32' prior: 50605552! - handleEvent: aMouseEvent from: aHand - "Process the given mouse event to detect a click, double-click, or drag. - Return true if the event should be processed by the sender, false if it shouldn't. - NOTE: This method heavily relies on getting *all* mouse button events." - - | timedOut distance | - timedOut _ (aMouseEvent timeStamp - lastClickDown timeStamp) > self class doubleClickTimeout. - timedOut ifTrue: [ aHand dontWaitForMoreClicks ]. - distance _ (aMouseEvent eventPosition - lastClickDown eventPosition) r. - "Real action dispatch might be done after the triggering event, for example, because of waiting for timeout. - So, count the button downs and ups(clicks), to be processed, maybe later, maybe in a mouseMove..." - aMouseEvent isMouseDown ifTrue: [ - lastClickDown _ aMouseEvent. - buttonDownCount _ buttonDownCount + 1 ]. - aMouseEvent isMouseUp ifTrue: [ - buttonUpCount _ buttonUpCount + 1 ]. - - "Drag, or tap & hold" - (buttonDownCount = 1 and: [ buttonUpCount = 0]) ifTrue: [ - distance > 0 ifTrue: [ - aHand dontWaitForMoreClicks. - dragSelector - ifNotNil: [ self didDrag ] - "If we have already moved, then it won't be a double or triple click... why wait?" - ifNil: [ self didClick ]. - ^ false ]. - timedOut ifTrue: [ - aHand dontWaitForMoreClicks. - "Simulate button 2 via tap & hold. Useful for opening menus on pen computers." - sendMouseButton2Activity ifTrue: [ - clickClient mouseButton2Activity ]. - ^ false ]]. - - "If we're over triple click, or timed out, or mouse moved, don't allow more clicks." - (buttonDownCount = 4 or: [ timedOut or: [ distance > 0 ]]) ifTrue: [ - aHand dontWaitForMoreClicks. - ^ false ]. - - "Simple click." - (buttonDownCount = 1 and: [ buttonUpCount = 1 ]) ifTrue: [ - self didClick ]. - - "Click & hold" - (buttonDownCount = 2 and: [ buttonUpCount = 1]) ifTrue: [ - self didClickAndHalf ]. - - "Double click." - (buttonDownCount = 2 and: [ buttonUpCount = 2]) ifTrue: [ - self didDoubleClick ]. - - "Double click & hold." - (buttonDownCount = 3 and: [ buttonUpCount = 2]) ifTrue: [ - self didDoubleClickAndHalf ]. - - "Triple click" - (buttonDownCount = 3 and: [ buttonUpCount = 3]) ifTrue: [ - self didTripleClick ]. - - "This means: if a mouseDown, then don't further process this event (so we can turn it into a double or triple click on next buttonUp)" - ^ aMouseEvent isMouseDown! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4848-fixBugIn4847-JuanVuletich-2021Sep06-19h55m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4848] on 7 September 2021 at 11:05:59 am'! -!BitBltCanvas methodsFor: 'initialization' stamp: 'jmv 9/7/2021 09:41:09' overrides: 50604015! - resetCanvas - "To be called in case of possible inconsistency due to an exception during drawing. - See #displayWorldSafely" - - super resetCanvas. - boundsFinderCanvas resetCanvas.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4849-resetCanvas-fix-JuanVuletich-2021Sep07-11h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4849] on 7 September 2021 at 11:17:08 am'! -!Number methodsFor: 'truncation and round off' stamp: 'jmv 9/7/2021 10:54:01'! - round4perMagnitudeOrder - "Round receiver to 1 or two significant digits. - Answer is 1, 2, 2.5, 5, 10, 20, 25, 50, 100, 200, 250, 500, 1000, etc. - better name?" - - | excess firstDigitPosition | - firstDigitPosition _ self log floor. - excess _ self log - firstDigitPosition. - excess < 2 log ifTrue: [ ^10 raisedTo: firstDigitPosition ]. - excess < 2.5 log ifTrue: [ ^(10 raisedTo: firstDigitPosition) * 2 ]. - excess < 5 log ifTrue: [ ^(10 raisedTo: firstDigitPosition-1) * 25 ]. - ^(10 raisedTo: firstDigitPosition) * 5! ! -!HaloMorph methodsFor: 'drawing' stamp: 'jmv 9/7/2021 11:13:25' prior: 50605141! - drawCoordinateSystemOn: aCanvas - - | x0 x1 y0 y1 c stepX stepY haloTargetTx prevTx font strokeWidth tickLength stepXDecimals stepYDecimals | - haloTargetTx _ MorphicTranslation identity. - target allOwnersReverseDo: [ :o | haloTargetTx _ haloTargetTx composedWith: o location ]. - haloTargetTx _ haloTargetTx composedWith: target location. - - target knowsOwnLocalBounds - ifTrue: [ | r | - r _ target morphLocalBounds. - x0 _ r left. - x1 _ r right. - y0 _ r top. - y1 _ r bottom ] - ifFalse: [ - x0 _ x1 _ y0 _ y1 _ 0. - target displayFullBounds corners collect: [ :pt | | p | - p _ haloTargetTx inverseTransform: pt. - x0 _ x0 min: p x. - x1 _ x1 max: p x. - y0 _ y0 min: p y. - y1 _ y1 max: p y.]]. - - font _ FontFamily defaultFamilyPointSize: FontFamily defaultPointSize * 1.5 / haloTargetTx scale. - stepX _ (font pointSize * 10) round4perMagnitudeOrder asFloat. - stepXDecimals _ stepX log rounded negated + 1. - stepY _ (font pointSize * 5) round4perMagnitudeOrder asFloat. - stepYDecimals _ stepY log rounded negated + 1. - strokeWidth _ 3/ haloTargetTx scale. - tickLength _ 5 / haloTargetTx scale. - - prevTx _ aCanvas currentTransformation. - aCanvas geometryTransformation: haloTargetTx. - - c _ `Color black alpha: 0.4`. - aCanvas line: x0@0 to: x1@0 width: strokeWidth color: c. - aCanvas line: 0@y0 to: 0@y1 width: strokeWidth color: c. - - (x0 truncateTo: stepX) to: x1-(stepX*0.2) by: stepX do: [ :x | - aCanvas line: x @ tickLength negated to: x @ tickLength width: strokeWidth color: c. - aCanvas drawString: (x printStringFractionDigits: stepXDecimals) atCenterXBaselineY: x @ (tickLength*2) negated font: font color: c ]. - aCanvas drawString: 'x' atCenterX: x1 - (tickLength*3) @ 0 font: font color: c. - - (y0 truncateTo: stepY) to: y1-(stepY*0.5) by: stepY do: [ :y | - aCanvas line: tickLength negated @ y to: tickLength @ y width: strokeWidth color: c. - aCanvas drawString: (y printStringFractionDigits: stepYDecimals), ' ' atWaistRight: tickLength negated @ y font: font color: c ]. - aCanvas drawString: 'y' atWaistRight: tickLength negated @ (y1 - (tickLength*4)) font: font color: c. - - aCanvas geometryTransformation: prevTx.! ! -!WidgetMorph methodsFor: 'halos and balloon help' stamp: 'jmv 9/7/2021 09:26:23' prior: 50601327 overrides: 50601321! - haloShowsCoordinateSystem - "We are usually not concerned with this level of detail for Widgets, as they prefer using automatic Layout." - - ^self requiresVectorCanvas! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4850-drawCoordinateSystem-enhancements-JuanVuletich-2021Sep07-11h16m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4849] on 7 September 2021 at 11:21:43 am'! -!WindowEdgeAdjustingMorph methodsFor: 'adjusting' stamp: 'jmv 9/7/2021 11:21:14' prior: 50603909 overrides: 50591384! - adjustOwnerAt: aGlobalPoint millisecondSinceLast: millisecondSinceLast - - self basicAdjustOwnerAt: aGlobalPoint. - - "If UI is becoming slow or is optimized for slow systems, resize without - showing window contents, but only edges. But don't do it for rotated Windows!!" - (owner isOrAnyOwnerIsRotated not and: [ - Preferences cheapWindowReframe or: [millisecondSinceLast > 200]]) ifTrue: [ - owner displayBounds newRectFrom: [ :f | - self basicAdjustOwnerAt: Sensor mousePoint. - owner morphPosition extent: owner morphExtentInWorld ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4851-cheapWindowReframe-lessAgressive-JuanVuletich-2021Sep07-11h17m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4851] on 7 September 2021 at 12:04:13 pm'! -!CodeWindow methodsFor: 'updating' stamp: 'jmv 9/7/2021 12:02:33' prior: 50602515! - updateListsAndCode - "All code windows receive this message on any code change in the system. - Process it only once, for the benefit of installing large packages!!" - - (self hasProperty: #updateListsAndCode) ifFalse: [ - self setProperty: #updateListsAndCode toValue: true. - self whenUIinSafeState: [ - self removeProperty: #updateListsAndCode. - owner ifNotNil: [ self updateListsAndCodeNow ]]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4852-CodeWindow-updateListsAndCode-afterClose-fix-JuanVuletich-2021Sep07-12h02m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4809] on 5 September 2021 at 10:49:47 pm'! - -Smalltalk removeClassNamed: #ExtractMethodApplier! - -!classRemoval: #ExtractMethodApplier stamp: 'Install-4853-ExtractMethodEnhancement-HernanWilkinson-2021Aug25-15h32m-HAW.001.cs.st 9/21/2021 12:54:09'! -RefactoringApplier subclass: #ExtractMethodApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newSelector newMessageArguments codeProvider' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Smalltalk removeClassNamed: #ExtractMethod! - -!classRemoval: #ExtractMethod stamp: 'Install-4853-ExtractMethodEnhancement-HernanWilkinson-2021Aug25-15h32m-HAW.001.cs.st 9/21/2021 12:54:09'! -Refactoring subclass: #ExtractMethod - instanceVariableNames: 'intervalToExtract categoryOfNewSelector newMessage extractedSourceCode existingMethod' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MessageSet subclass: #ExtractMethodMessageSet - instanceVariableNames: 'finder selectedIndex' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractMethodMessageSet category: #'Tools-Refactoring' stamp: 'Install-4853-ExtractMethodEnhancement-HernanWilkinson-2021Aug25-15h32m-HAW.001.cs.st 9/21/2021 12:54:09'! -MessageSet subclass: #ExtractMethodMessageSet - instanceVariableNames: 'finder selectedIndex' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MessageSetWindow subclass: #ExtractMethodReplacementsWindow - instanceVariableNames: 'applier finder' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractMethodReplacementsWindow category: #'Tools-Refactoring' stamp: 'Install-4853-ExtractMethodEnhancement-HernanWilkinson-2021Aug25-15h32m-HAW.001.cs.st 9/21/2021 12:54:09'! -MessageSetWindow subclass: #ExtractMethodReplacementsWindow - instanceVariableNames: 'applier finder' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Object subclass: #ExtractMethodReplacementsFinder - instanceVariableNames: 'intervalToExtract sourceMethod replacements newMessage sourceCodeToExtract sizeToExtract' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractMethodReplacementsFinder category: #'Tools-Refactoring' stamp: 'Install-4853-ExtractMethodEnhancement-HernanWilkinson-2021Aug25-15h32m-HAW.001.cs.st 9/21/2021 12:54:09'! -Object subclass: #ExtractMethodReplacementsFinder - instanceVariableNames: 'intervalToExtract sourceMethod replacements newMessage sourceCodeToExtract sizeToExtract' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Refactoring subclass: #ExtractMethod - instanceVariableNames: 'extractMethodNewMethod collectionOfReplacements' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractMethod category: #'Tools-Refactoring' stamp: 'Install-4853-ExtractMethodEnhancement-HernanWilkinson-2021Aug25-15h32m-HAW.001.cs.st 9/21/2021 12:54:09'! -Refactoring subclass: #ExtractMethod - instanceVariableNames: 'extractMethodNewMethod collectionOfReplacements' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!ExtractMethod commentStamp: '' prior: 0! - I am a refactoring that extracts a selected piece of code to a separate method. The input is the following: - -* interval of code to extract (from index - to index) -* the CompiledMethod where this change applies -* the new method selector + argument names (instance of Message) -* the category name for the new method - -Many conditions have to be satisfied for this refactoring to be made, I delegate into SourceCodeOfMethodToBeExtractedPrecondition and NewSelectorPrecondition most of these checks. Refer to those classes' comments for more information.! - -Refactoring subclass: #ExtractMethodNewMethod - instanceVariableNames: 'intervalToExtract categoryOfNewSelector newMessage extractedSourceCode existingMethod' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractMethodNewMethod category: #'Tools-Refactoring' stamp: 'Install-4853-ExtractMethodEnhancement-HernanWilkinson-2021Aug25-15h32m-HAW.001.cs.st 9/21/2021 12:54:09'! -Refactoring subclass: #ExtractMethodNewMethod - instanceVariableNames: 'intervalToExtract categoryOfNewSelector newMessage extractedSourceCode existingMethod' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!ExtractMethodNewMethod commentStamp: '' prior: 0! - I am a refactoring that extracts a selected piece of code to a separate method. The input is the following: - -* interval of code to extract (from index - to index) -* the CompiledMethod where this change applies -* the new method selector + argument names (instance of Message) -* the category name for the new method - -Many conditions have to be satisfied for this refactoring to be made, I delegate into SourceCodeOfMethodToBeExtractedPrecondition and NewSelectorPrecondition most of these checks. Refer to those classes' comments for more information.! - -Refactoring subclass: #ExtractMethodReplacement - instanceVariableNames: 'intervalToExtract newMessage methodToExtractFrom callingExpression' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractMethodReplacement category: #'Tools-Refactoring' stamp: 'Install-4853-ExtractMethodEnhancement-HernanWilkinson-2021Aug25-15h32m-HAW.001.cs.st 9/21/2021 12:54:09'! -Refactoring subclass: #ExtractMethodReplacement - instanceVariableNames: 'intervalToExtract newMessage methodToExtractFrom callingExpression' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!ExtractMethodReplacement commentStamp: '' prior: 0! - I am a refactoring that extracts a selected piece of code to a separate method. The input is the following: - -* interval of code to extract (from index - to index) -* the CompiledMethod where this change applies -* the new method selector + argument names (instance of Message) -* the category name for the new method - -Many conditions have to be satisfied for this refactoring to be made, I delegate into SourceCodeOfMethodToBeExtractedPrecondition and NewSelectorPrecondition most of these checks. Refer to those classes' comments for more information.! - -RefactoringApplier subclass: #ExtractMethodApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newSelector newMessageArguments codeProvider sourceCodeToExtract newMethodRefactoring finder' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractMethodApplier category: #'Tools-Refactoring' stamp: 'Install-4853-ExtractMethodEnhancement-HernanWilkinson-2021Aug25-15h32m-HAW.001.cs.st 9/21/2021 12:54:09'! -RefactoringApplier subclass: #ExtractMethodApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newSelector newMessageArguments codeProvider sourceCodeToExtract newMethodRefactoring finder' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!ExtractMethodMessageSet methodsFor: 'initialization' stamp: 'HAW 9/5/2021 07:15:36' overrides: 50407636! - initialize - - selectedIndex := 0. - super initialize ! ! -!ExtractMethodMessageSet methodsFor: 'initialization' stamp: 'HAW 9/5/2021 00:12:23'! - initializeFinder: aFinder - - finder := aFinder.! ! -!ExtractMethodMessageSet methodsFor: 'message list' stamp: 'HAW 9/5/2021 07:15:16' overrides: 16792396! - messageListIndex - - ^selectedIndex ! ! -!ExtractMethodMessageSet methodsFor: 'message list' stamp: 'HAW 9/5/2021 07:14:51' overrides: 50390577! - messageListIndex: anIndex - - selectedIndex := anIndex. - ^super messageListIndex: anIndex ! ! -!ExtractMethodMessageSet methodsFor: 'message list' stamp: 'HAW 9/5/2021 21:52:26' overrides: 50442972! - removeMessageFromBrowserKeepingLabel - - | newIndex | - - selectedMessage ifNil: [ ^nil ]. - messageList removeIndex: selectedIndex. - finder removeReplacementAt: selectedIndex. - self changed: #messageList. - - newIndex := selectedIndex > messageList size - ifTrue: [ selectedIndex - 1 ] - ifFalse: [ selectedIndex ]. - self messageListIndex: newIndex.! ! -!ExtractMethodMessageSet methodsFor: 'source code ranges' stamp: 'HAW 9/5/2021 21:46:48' overrides: 50452610! - messageSendsRangesOf: aSelector - - | replacement | - - replacement := finder replacementsAt: self messageListIndex ifAbsent: [ ^#() ]. - - ^Array with: replacement intervalToExtract - ! ! -!ExtractMethodMessageSet class methodsFor: 'instance creation' stamp: 'HAW 9/5/2021 00:11:22'! - finder: aFinder - - ^(self messageList: aFinder methodsToReplace) initializeFinder: aFinder! ! -!MethodNode methodsFor: 'source ranges' stamp: 'HAW 8/26/2021 15:57:14'! - definitionStartPosition - - "It does not includes temp definition because the extract can include temps - Hernan" - ^self selectorLastPosition + 1! ! -!ExtractMethodReplacementsWindow methodsFor: 'actions' stamp: 'HAW 9/5/2021 20:41:28'! - closeAfter: aBlock - - aBlock value. - self whenUIinSafeState: [ self delete ]. - ! ! -!ExtractMethodReplacementsWindow methodsFor: 'actions' stamp: 'HAW 9/5/2021 20:41:16'! - extractAllInClass - - self closeAfter: [ applier valueWithMethodsInClass ]. - ! ! -!ExtractMethodReplacementsWindow methodsFor: 'actions' stamp: 'HAW 9/5/2021 20:41:43'! - extractInMethodOnly - - self closeAfter: [ applier valueWithSourceMethod ]. - ! ! -!ExtractMethodReplacementsWindow methodsFor: 'actions' stamp: 'HAW 9/5/2021 20:41:52'! - extractSelectionOnly - - self closeAfter: [ applier valueWithOriginalSelection ]. - ! ! -!ExtractMethodReplacementsWindow methodsFor: 'actions' stamp: 'HAW 9/5/2021 20:42:00'! - refactor - - self closeAfter: [ applier valueWithAllReplacements ]. - ! ! -!ExtractMethodReplacementsWindow methodsFor: 'actions' stamp: 'HAW 8/25/2021 22:07:31'! -remove - - model removeMessageFromBrowserKeepingLabel! ! -!ExtractMethodReplacementsWindow methodsFor: 'GUI building' stamp: 'HAW 8/25/2021 22:07:31'! - addButton: button to: row color: buttonColor - - button color: buttonColor. - row addMorph: button proportionalWidth: 10! ! -!ExtractMethodReplacementsWindow methodsFor: 'GUI building' stamp: 'HAW 9/5/2021 20:02:21'! - addButtonsTo: row color: buttonColor - - self - addButton: self createRemoveButton to: row color: buttonColor; - addButton: self createRefactorButton to: row color: buttonColor; - addButton: self createExtractSelectionOnlyButton to: row color: buttonColor; - addButton: self createExtractInMethodOnlyButton to: row color: buttonColor; - addButton: self createExtractAllInClassButton to: row color: buttonColor; - addButton: self createCancelButton to: row color: buttonColor. -! ! -!ExtractMethodReplacementsWindow methodsFor: 'GUI building' stamp: 'HAW 8/25/2021 22:07:31' overrides: 50518714! - buildLowerPanes - - | codeAndButtons | - - codeAndButtons _ LayoutMorph newColumn. - codeAndButtons - addMorph: self buttonsRow fixedHeight: self defaultButtonPaneHeight; - addAdjusterMorph; - addMorph: self buildMorphicCodePane proportionalHeight: 1.0. - - ^codeAndButtons ! ! -!ExtractMethodReplacementsWindow methodsFor: 'GUI building' stamp: 'HAW 8/25/2021 22:07:31'! - buttonsRow - - | buttonColor row | - - buttonColor := self buttonColor. - row := LayoutMorph newRow. - row doAdoptWidgetsColor. - row color: buttonColor. - - self addButtonsTo: row color: buttonColor. - - ^row - - ! ! -!ExtractMethodReplacementsWindow methodsFor: 'button creation' stamp: 'HAW 8/25/2021 22:07:31'! - createCancelButton - - ^PluggableButtonMorph - model: self - stateGetter: nil - action: #delete - label: 'Cancel'. -! ! -!ExtractMethodReplacementsWindow methodsFor: 'button creation' stamp: 'HAW 9/5/2021 19:55:47'! - createExtractAllInClassButton - - ^PluggableButtonMorph - model: self - stateGetter: nil - action: #extractAllInClass - label: 'In Class'! ! -!ExtractMethodReplacementsWindow methodsFor: 'button creation' stamp: 'HAW 9/5/2021 19:55:57'! - createExtractInMethodOnlyButton - - ^PluggableButtonMorph - model: self - stateGetter: nil - action: #extractInMethodOnly - label: 'In Method'! ! -!ExtractMethodReplacementsWindow methodsFor: 'button creation' stamp: 'HAW 9/5/2021 19:43:25'! - createExtractSelectionOnlyButton - - ^PluggableButtonMorph - model: self - stateGetter: nil - action: #extractSelectionOnly - label: 'Selection Only'! ! -!ExtractMethodReplacementsWindow methodsFor: 'button creation' stamp: 'HAW 9/5/2021 19:56:07'! - createRefactorButton - - ^PluggableButtonMorph - model: self - stateGetter: nil - action: #refactor - label: 'Refactor'! ! -!ExtractMethodReplacementsWindow methodsFor: 'button creation' stamp: 'HAW 9/5/2021 20:07:00'! - createRemoveButton - - ^PluggableButtonMorph - model: self - stateGetter: nil - action: #remove - label: 'Remove'. -! ! -!ExtractMethodReplacementsWindow methodsFor: 'initialization' stamp: 'HAW 9/4/2021 23:30:56'! - initializeFrom: anExtractMethodApplier with: aFinder - - applier := anExtractMethodApplier. - finder := aFinder ! ! -!ExtractMethodReplacementsWindow class methodsFor: 'instance creation' stamp: 'HAW 9/5/2021 20:31:15'! - openFrom: anExtractMethodApplier with: aFinder - - | window messageSet | - - messageSet := ExtractMethodMessageSet finder: aFinder. - "I have to set a autoSelectString even if I do not use it because if not the - autoSelect event is not triggered - Hernan" - messageSet autoSelectString: aFinder sourceCodeToExtract. - - window := self open: messageSet label: 'Select replacements'. - window initializeFrom: anExtractMethodApplier with: aFinder. - - ^window - -! ! -!ExtractMethodReplacementsFinder methodsFor: 'initialization' stamp: 'HAW 9/2/2021 17:31:19'! - initializeOfCodeIn: anIntervalToExtract at: aMethod to: aNewMessage - - intervalToExtract := anIntervalToExtract. - sourceMethod := aMethod. - newMessage := aNewMessage ! ! -!ExtractMethodReplacementsFinder methodsFor: 'private-replacement finding' stamp: 'HAW 9/5/2021 22:05:15'! - addReplacementAt: foundIntervalToExtract in: aMethod - - "If ther is an error creating the refactoring, then the found text is not extractable and - therefore should not be replaced - Hernan" - [ replacements add: (self createReplacementAt: foundIntervalToExtract in: aMethod) ] - on: RefactoringError - do: [ :anError | ].! ! -!ExtractMethodReplacementsFinder methodsFor: 'private-replacement finding' stamp: 'HAW 9/4/2021 21:03:06'! - createReplacementAt: foundIntervalToExtract in: aMethod - - ^ExtractMethodReplacement - fromInterval: foundIntervalToExtract asSourceCodeInterval - of: aMethod - to: newMessage! ! -!ExtractMethodReplacementsFinder methodsFor: 'private-replacement finding' stamp: 'HAW 9/4/2021 21:01:06'! - findReplacementsAt: aClass - - aClass methodsDo: [ :aMethod | self findReplacementsIn: aMethod asMethodReference ]! ! -!ExtractMethodReplacementsFinder methodsFor: 'private-replacement finding' stamp: 'HAW 9/4/2021 21:04:49'! - findReplacementsIn: aMethod - - | sourceCode foundIntervalToExtract sourceCodeToExtractStart | - - sourceCode := aMethod sourceCode. - sourceCodeToExtractStart := 1. - - [ sourceCodeToExtractStart := sourceCode indexOfSubCollection: sourceCodeToExtract startingAt: sourceCodeToExtractStart. - sourceCodeToExtractStart ~= 0 ] whileTrue: [ - foundIntervalToExtract := sourceCodeToExtractStart to: sourceCodeToExtractStart + sizeToExtract. - self addReplacementAt: foundIntervalToExtract in: aMethod. - sourceCodeToExtractStart := foundIntervalToExtract last + 1 ] - - ! ! -!ExtractMethodReplacementsFinder methodsFor: 'testing' stamp: 'HAW 9/4/2021 23:25:35'! - hasOneReplacement - - ^replacements size = 1! ! -!ExtractMethodReplacementsFinder methodsFor: 'replacements' stamp: 'HAW 9/5/2021 20:18:47'! - inClassReplacements - - ^replacements select: [ :aReplacement | aReplacement isAt: sourceMethod methodClass ]! ! -!ExtractMethodReplacementsFinder methodsFor: 'replacements' stamp: 'HAW 9/5/2021 00:12:03'! - methodsToReplace - - ^replacements collect: [ :aReplacement | aReplacement methodToExtractFrom ]! ! -!ExtractMethodReplacementsFinder methodsFor: 'replacements' stamp: 'HAW 9/5/2021 20:14:49'! - originalSelectionReplacement - - ^ExtractMethodReplacement fromInterval: intervalToExtract of: sourceMethod to: newMessage ! ! -!ExtractMethodReplacementsFinder methodsFor: 'replacements' stamp: 'HAW 9/5/2021 21:51:40'! - removeReplacementAt: anIndex - - ^replacements removeAt: anIndex ! ! -!ExtractMethodReplacementsFinder methodsFor: 'replacements' stamp: 'HAW 9/2/2021 17:41:27'! - replacements - - ^replacements ! ! -!ExtractMethodReplacementsFinder methodsFor: 'replacements' stamp: 'HAW 9/5/2021 07:24:58'! - replacementsAt: anIndex ifAbsent: ifAbsentBlock - - ^replacements at: anIndex ifAbsent: ifAbsentBlock ! ! -!ExtractMethodReplacementsFinder methodsFor: 'replacements' stamp: 'HAW 9/5/2021 20:17:31'! - sourceMethodReplacements - - ^replacements select: [:aReplacement | aReplacement isOf: sourceMethod ]! ! -!ExtractMethodReplacementsFinder methodsFor: 'evaluating' stamp: 'HAW 9/4/2021 21:00:59' overrides: 16881508! - value - - sourceCodeToExtract := sourceMethod sourceCode copyFrom: intervalToExtract first to: intervalToExtract last. - sizeToExtract := intervalToExtract size - 1. - replacements := OrderedCollection new. - - sourceMethod methodClass withAllSubclassesDo: [ :aClass | self findReplacementsAt: aClass] - ! ! -!ExtractMethodReplacementsFinder methodsFor: 'source code' stamp: 'HAW 9/5/2021 00:14:54'! - sourceCodeToExtract - - ^sourceCodeToExtract! ! -!ExtractMethodReplacementsFinder class methodsFor: 'instance creation' stamp: 'HAW 9/2/2021 17:31:33'! - ofCodeIn: anIntervalToExtract at: aMethod to: aNewMessage - - ^self new initializeOfCodeIn: anIntervalToExtract at: aMethod to: aNewMessage ! ! -!ExtractMethod methodsFor: 'initialization' stamp: 'HAW 9/5/2021 22:46:43'! - initializeNewDefinition: anExtractMethodNewMethod replacements: aCollectionOfReplacements - - extractMethodNewMethod := anExtractMethodNewMethod. - collectionOfReplacements := aCollectionOfReplacements.! ! -!ExtractMethod methodsFor: 'private - applying' stamp: 'HAW 9/5/2021 22:46:48'! - applyMethodReplacements: aMethodReplacements - - | adjustment sortedReplacements | - - adjustment := 0. - "This is not really necesary because the groupBy: keeps the order, but I do it just in case that is changed - Hernan" - sortedReplacements := aMethodReplacements sorted: [ :leftReplacement :rightReplacement | leftReplacement isBefore: rightReplacement ]. - sortedReplacements do: [ :aReplacement | - aReplacement applyAdjusting: adjustment. - adjustment := adjustment + aReplacement adjustmentForNextReplacement ]! ! -!ExtractMethod methodsFor: 'private - applying' stamp: 'HAW 9/5/2021 22:46:51'! - applyReplacements - - | replacementsByMethod | - - replacementsByMethod := collectionOfReplacements groupBy: [ :aReplacement | aReplacement methodToExtractFrom ]. - replacementsByMethod valuesDo: [ :aMethodReplacements | self applyMethodReplacements: aMethodReplacements ]. - ! ! -!ExtractMethod methodsFor: 'private - applying' stamp: 'HAW 9/5/2021 22:46:54'! - createNewMethod - - extractMethodNewMethod apply. -! ! -!ExtractMethod methodsFor: 'applying' stamp: 'HAW 9/5/2021 22:46:38' overrides: 50438490! - apply - - self - createNewMethod; - applyReplacements ! ! -!ExtractMethod class methodsFor: 'instance creation' stamp: 'HAW 9/5/2021 22:46:15'! - fromInterval: anIntervalToExtract of: aMethodToExtractCodeFrom to: newMessage categorizedAs: aCategory - - ^self - newDefinition: (ExtractMethodNewMethod - fromInterval: anIntervalToExtract - of: aMethodToExtractCodeFrom - to: newMessage - categorizedAs: aCategory ) - replacements: (Array with: (ExtractMethodReplacement - fromInterval: anIntervalToExtract - of: aMethodToExtractCodeFrom - to: newMessage)) - -! ! -!ExtractMethod class methodsFor: 'instance creation' stamp: 'HAW 9/5/2021 22:46:32'! - newDefinition: anExtractMethodNewMethod replacements: aCollectionOfReplacements - - ^self new initializeNewDefinition: anExtractMethodNewMethod replacements: aCollectionOfReplacements ! ! -!ExtractMethodNewMethod methodsFor: 'applying' stamp: 'HAW 9/4/2021 15:55:33' overrides: 50438490! - apply - - self sourceClass - compile: self newMethodSourceCode - classified: categoryOfNewSelector! ! -!ExtractMethodNewMethod methodsFor: 'initialization' stamp: 'HAW 9/2/2021 18:09:20'! - initializeExtractedSourceCode - - extractedSourceCode := existingMethod sourceCode - copyFrom: intervalToExtract first - to: intervalToExtract last! ! -!ExtractMethodNewMethod methodsFor: 'initialization' stamp: 'HAW 9/2/2021 18:09:20'! - initializeFrom: anIntervalToExtract of: aMethodToExtractCodeFrom to: aNewMessage in: aCategory - - intervalToExtract := anIntervalToExtract. - existingMethod := aMethodToExtractCodeFrom. - newMessage := aNewMessage. - categoryOfNewSelector := aCategory. - self initializeExtractedSourceCode.! ! -!ExtractMethodNewMethod methodsFor: 'private - source code' stamp: 'HAW 9/2/2021 18:09:20'! - newMessageString - - ^ newMessage fullName! ! -!ExtractMethodNewMethod methodsFor: 'private - source code' stamp: 'HAW 9/2/2021 18:09:20'! - newMethodSourceCode - - ^ String streamContents: [ :stream | - stream - nextPutAll: self newMessageString; - nextPutAll: self startingMethodIdentation; - nextPutAll: self returnCharacterIfNeeded; - nextPutAll: extractedSourceCode ]! ! -!ExtractMethodNewMethod methodsFor: 'private - source code' stamp: 'HAW 9/2/2021 18:09:20'! - returnCharacterIfNeeded - - | extractedMethodNode | - - extractedMethodNode := Parser parse: extractedSourceCode class: self sourceClass noPattern: true. - - ^ (extractedMethodNode numberOfStatements > 1 or: [ extractedMethodNode hasTemporaryVariables ]) - ifTrue: [ '' ] ifFalse: [ '^ ' ]! ! -!ExtractMethodNewMethod methodsFor: 'private - source code' stamp: 'HAW 9/2/2021 18:09:20'! - sourceClass - - ^ existingMethod methodClass! ! -!ExtractMethodNewMethod methodsFor: 'private - source code' stamp: 'HAW 9/2/2021 18:09:20'! - startingMethodIdentation - - ^ String lfString , String lfString , String tab! ! -!ExtractMethodNewMethod class methodsFor: 'error messages' stamp: 'HAW 9/2/2021 18:09:20'! - noSelectionErrorMessage - - ^ 'Please select some code for extraction'! ! -!ExtractMethodNewMethod class methodsFor: 'error messages' stamp: 'HAW 9/2/2021 18:09:20'! - outOfBoundsSelectionErrorMessage - - ^ 'The requested source code selection interval is out of bounds'! ! -!ExtractMethodNewMethod class methodsFor: 'error messages' stamp: 'HAW 9/2/2021 18:09:20'! - wrongNumberOfArgumentsGivenErrorMessage - - ^ 'The number of arguments in the given selector is not correct'! ! -!ExtractMethodNewMethod class methodsFor: 'exceptions' stamp: 'HAW 9/2/2021 18:09:20'! - signalExtractMethodWithWrongNumberOfArgumentsError - - self refactoringError: self wrongNumberOfArgumentsGivenErrorMessage! ! -!ExtractMethodNewMethod class methodsFor: 'exceptions' stamp: 'HAW 9/2/2021 18:09:20'! - signalNoSelectedCodeError - - self refactoringError: self noSelectionErrorMessage! ! -!ExtractMethodNewMethod class methodsFor: 'exceptions' stamp: 'HAW 9/2/2021 18:09:20'! - signalOutOfBoundsIntervalError - - self refactoringError: self outOfBoundsSelectionErrorMessage! ! -!ExtractMethodNewMethod class methodsFor: 'instance creation' stamp: 'HAW 9/2/2021 18:09:20'! - fromInterval: anIntervalToExtract of: aMethodToExtractCodeFrom to: newMessage categorizedAs: aCategory - - | trimmedIntervalToExtract | - - trimmedIntervalToExtract := anIntervalToExtract trimToMatchExpressionOn: aMethodToExtractCodeFrom sourceCode. - self - assert: newMessage selector canBeDefinedIn: aMethodToExtractCodeFrom methodClass; - assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: trimmedIntervalToExtract; - assert: newMessage hasValidParametersForExtracting: anIntervalToExtract from: aMethodToExtractCodeFrom methodNode. - - ^ self new - initializeFrom: trimmedIntervalToExtract - of: aMethodToExtractCodeFrom - to: newMessage - in: aCategory! ! -!ExtractMethodNewMethod class methodsFor: 'pre-conditions' stamp: 'HAW 9/2/2021 18:09:20'! - assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: anIntervalToExtract - - self - assertIntervalToExtractIsNotEmpty: anIntervalToExtract; - assert: anIntervalToExtract isWithinBoundsOf: aMethodToExtractCodeFrom sourceCode; - assert: aMethodToExtractCodeFrom containsValidCodeToBeExtractedAt: anIntervalToExtract! ! -!ExtractMethodNewMethod class methodsFor: 'private - pre-conditions' stamp: 'HAW 9/2/2021 18:09:20'! - assert: aSelector canBeDefinedIn: aClass - - NewSelectorPrecondition valueFor: aSelector on: aClass! ! -!ExtractMethodNewMethod class methodsFor: 'private - pre-conditions' stamp: 'HAW 9/2/2021 18:09:20'! - assert: aMethodToRefactor containsValidCodeToBeExtractedAt: anIntervalToExtract - - SourceCodeOfMethodToBeExtractedPrecondition valueFor: anIntervalToExtract of: aMethodToRefactor! ! -!ExtractMethodNewMethod class methodsFor: 'private - pre-conditions' stamp: 'HAW 9/2/2021 18:09:20'! - assert: newMessage hasValidParametersForExtracting: anIntervalToExtract from: aMethodNodeToRefactor - - | parseNodesToParameterize | - parseNodesToParameterize := ExtractMethodParametersDetector - valueFor: aMethodNodeToRefactor - at: anIntervalToExtract. - newMessage arguments size = parseNodesToParameterize size - ifFalse: [ self signalExtractMethodWithWrongNumberOfArgumentsError ]! ! -!ExtractMethodNewMethod class methodsFor: 'private - pre-conditions' stamp: 'HAW 9/2/2021 18:09:20'! - assert: anIntervalToExtract isWithinBoundsOf: sourceCode - - (self is: anIntervalToExtract withinBoundsOf: sourceCode) - ifFalse: [ self signalOutOfBoundsIntervalError ]! ! -!ExtractMethodNewMethod class methodsFor: 'private - pre-conditions' stamp: 'HAW 9/2/2021 18:09:20'! - assertIntervalToExtractIsNotEmpty: anIntervalToExtract - - (self isNotEmpty: anIntervalToExtract) - ifFalse: [ self signalNoSelectedCodeError ]! ! -!ExtractMethodNewMethod class methodsFor: 'private - pre-conditions' stamp: 'HAW 9/2/2021 18:09:20'! - is: anIntervalToExtract withinBoundsOf: aSourceCode - - ^ anIntervalToExtract first >= 1 and: [ anIntervalToExtract last <= aSourceCode size ]! ! -!ExtractMethodNewMethod class methodsFor: 'private - pre-conditions' stamp: 'HAW 9/2/2021 18:09:20'! - isNotEmpty: anInterval - - ^ anInterval first <= anInterval last! ! -!ExtractMethodReplacement methodsFor: 'applying' stamp: 'HAW 9/2/2021 17:38:51' overrides: 50438490! - apply - - self sourceClass - compile: self updatedSourceCodeOfExistingMethod - classified: methodToExtractFrom category! ! -!ExtractMethodReplacement methodsFor: 'applying' stamp: 'HAW 9/4/2021 20:59:16'! - applyAdjusting: anAdjustment - - intervalToExtract := (intervalToExtract + anAdjustment) asSourceCodeInterval. - self apply ! ! -!ExtractMethodReplacement methodsFor: 'initialization' stamp: 'HAW 9/4/2021 16:53:14'! - initializeFrom: anIntervalToExtract of: aMethodToExtractCodeFrom to: aNewMessage - - intervalToExtract := anIntervalToExtract. - methodToExtractFrom := aMethodToExtractCodeFrom. - newMessage := aNewMessage. - self initializeCallingExpression ! ! -!ExtractMethodReplacement methodsFor: 'private - source code' stamp: 'HAW 9/4/2021 16:31:47'! - initializeCallingExpression - - callingExpression := 'self ', self newMessageString. - self shouldBeEnclosedWithParens ifTrue: [ callingExpression := '(' , callingExpression , ')' ] - ! ! -!ExtractMethodReplacement methodsFor: 'private - source code' stamp: 'HAW 9/2/2021 17:06:21'! - newMessageString - - ^ newMessage fullName! ! -!ExtractMethodReplacement methodsFor: 'private - source code' stamp: 'HAW 9/2/2021 17:38:51'! - shouldBeEnclosedWithParens - - | initialNode finalNode parseNodesInCommon methodNode initialNodeAncestors finalNodeAncestors insideMessageNodeExpressions | - - methodNode _ methodToExtractFrom methodNode. - initialNodeAncestors _ methodNode parseNodesPathAt: intervalToExtract first ifAbsent: [ ^ false]. - finalNodeAncestors _ methodNode parseNodesPathAt: intervalToExtract last ifAbsent: [ ^ false ]. - parseNodesInCommon _ initialNodeAncestors intersection: finalNodeAncestors. - - initialNode _ (parseNodesInCommon at: 1 ifAbsent: [ ^ false ]) key. - finalNode _ (parseNodesInCommon at: 2 ifAbsent: [ ^ false ]) key. - insideMessageNodeExpressions _ initialNode isMessageNode and: [ finalNode isMessageNode ]. - - ^ insideMessageNodeExpressions - and: [ initialNode precedence < newMessage selector precedence ] - and: [ initialNode precedence <= finalNode precedence ]! ! -!ExtractMethodReplacement methodsFor: 'private - source code' stamp: 'HAW 9/2/2021 17:38:51'! -sourceClass - - ^ methodToExtractFrom methodClass! ! -!ExtractMethodReplacement methodsFor: 'private - source code' stamp: 'HAW 9/4/2021 16:37:55'! - updatedSourceCodeOfExistingMethod - - ^ methodToExtractFrom sourceCode - copyReplaceFrom: intervalToExtract first - to: intervalToExtract last - with: callingExpression! ! -!ExtractMethodReplacement methodsFor: 'accessing' stamp: 'HAW 9/2/2021 17:36:44'! - intervalToExtract - - ^intervalToExtract! ! -!ExtractMethodReplacement methodsFor: 'accessing' stamp: 'HAW 9/2/2021 17:38:51'! - methodToExtractFrom - - ^methodToExtractFrom ! ! -!ExtractMethodReplacement methodsFor: 'testing' stamp: 'HAW 9/4/2021 20:28:45'! -isAt: aClass - - ^methodToExtractFrom methodClass = aClass ! ! -!ExtractMethodReplacement methodsFor: 'testing' stamp: 'HAW 9/4/2021 17:02:06'! - isBefore: anExtractMethodReplacement - - ^anExtractMethodReplacement startsAfter: intervalToExtract first! ! -!ExtractMethodReplacement methodsFor: 'testing' stamp: 'HAW 9/2/2021 18:06:56'! - isOf: aMethod - - ^methodToExtractFrom = aMethod ! ! -!ExtractMethodReplacement methodsFor: 'testing' stamp: 'HAW 9/4/2021 17:02:34'! - startsAfter: aPosition - - ^intervalToExtract first > aPosition ! ! -!ExtractMethodReplacement methodsFor: 'adjustment' stamp: 'HAW 9/4/2021 16:50:17'! - adjustmentForNextReplacement - - ^callingExpression size - intervalToExtract size! ! -!ExtractMethodReplacement class methodsFor: 'instance creation' stamp: 'HAW 9/2/2021 17:26:03'! - fromInterval: anIntervalToExtract of: aMethodToExtractCodeFrom to: newMessage - - | trimmedIntervalToExtract | - - trimmedIntervalToExtract := anIntervalToExtract trimToMatchExpressionOn: aMethodToExtractCodeFrom sourceCode. - self assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: trimmedIntervalToExtract. - - ^ self new - initializeFrom: trimmedIntervalToExtract - of: aMethodToExtractCodeFrom - to: newMessage - ! ! -!ExtractMethodReplacement class methodsFor: 'pre-conditions' stamp: 'HAW 9/5/2021 22:07:25'! - assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: anIntervalToExtract - - ExtractMethodNewMethod assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: anIntervalToExtract -! ! -!RefactoringApplier methodsFor: 'refactoring - creation' stamp: 'HAW 8/26/2021 16:06:07'! - createAndSetRefactoringHandlingRefactoringExceptions: aCreatorBlock - - self valueHandlingRefactoringExceptions: [ refactoring := aCreatorBlock value] - ! ! -!ExtractMethodApplier methodsFor: 'initialization' stamp: 'HAW 9/5/2021 22:47:39'! - initializeOn: aCodeProvider for: anIntervalToExtract of: aMethodToExtractCodeFrom - - codeProvider := aCodeProvider. - intervalToExtract := anIntervalToExtract. - methodToExtractCodeFrom := MethodReference method: aMethodToExtractCodeFrom. - newMessageArguments := Dictionary new! ! -!ExtractMethodApplier methodsFor: 'refactoring - changes' stamp: 'HAW 9/5/2021 22:47:43' overrides: 50441450! - showChanges - - codeProvider currentMethodRefactored! ! -!ExtractMethodApplier methodsFor: 'refactoring - creation' stamp: 'HAW 9/5/2021 22:47:49' overrides: 50441327! - createRefactoring - - ^ self shouldNotImplement! ! -!ExtractMethodApplier methodsFor: 'refactoring - creation' stamp: 'HAW 9/5/2021 22:47:53'! - createRefactoringForMethodsInClass - - ^ self refactoringClass newDefinition: newMethodRefactoring replacements: finder inClassReplacements ! ! -!ExtractMethodApplier methodsFor: 'refactoring - creation' stamp: 'HAW 9/5/2021 22:47:57'! - createRefactoringForOriginalSelection - - ^ self refactoringClass newDefinition: newMethodRefactoring replacements: { finder originalSelectionReplacement }! ! -!ExtractMethodApplier methodsFor: 'refactoring - creation' stamp: 'HAW 9/5/2021 22:48:02'! - createRefactoringForSourceMethod - - ^ self refactoringClass newDefinition: newMethodRefactoring replacements: finder sourceMethodReplacements ! ! -!ExtractMethodApplier methodsFor: 'refactoring - creation' stamp: 'HAW 9/5/2021 22:48:06'! - createRefactoringWithAllReplacements - - ^ self refactoringClass newDefinition: newMethodRefactoring replacements: finder replacements ! ! -!ExtractMethodApplier methodsFor: 'refactoring - creation' stamp: 'HAW 9/5/2021 22:48:10'! - refactoringClass - - ^ ExtractMethod! ! -!ExtractMethodApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 9/5/2021 22:48:14'! - createExtractMethodNewMethodFor: newMessage - - ^ newMethodRefactoring := ExtractMethodNewMethod - fromInterval: intervalToExtract - of: methodToExtractCodeFrom - to: newMessage - categorizedAs: methodToExtractCodeFrom category! ! -!ExtractMethodApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 9/5/2021 22:48:17'! - findReplacementsWith: newMessage - - finder := ExtractMethodReplacementsFinder ofCodeIn: intervalToExtract at: methodToExtractCodeFrom to: newMessage. - finder value! ! -!ExtractMethodApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 9/5/2021 22:48:20'! - requestNewMessage - - | parseNodesToParameterize initialAnswer userAnswer | - - parseNodesToParameterize := self parseNodesToParameterize. - initialAnswer := self buildInitialSelectorAnswer: parseNodesToParameterize. - userAnswer := self request: 'New method name:' initialAnswer: initialAnswer. - - parseNodesToParameterize - ifEmpty: [ self saveUnarySelector: userAnswer ] - ifNotEmpty: [ self saveBinaryOrKeywordSelector: userAnswer withArguments: parseNodesToParameterize ]. - - ^self buildNewMessage. - ! ! -!ExtractMethodApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 9/5/2021 22:48:24' overrides: 50441345! - requestRefactoringParameters - - | newMessage | - - newMessage := self requestNewMessage. - self createExtractMethodNewMethodFor: newMessage. - self findReplacementsWith: newMessage. - - finder hasOneReplacement - ifTrue: [ self valueWithAllReplacements ] - ifFalse: [ ExtractMethodReplacementsWindow openFrom: self with: finder ] - ! ! -!ExtractMethodApplier methodsFor: 'private - new message' stamp: 'HAW 9/5/2021 22:48:29'! - buildNewMessage - - ^ Message - selector: newSelector - arguments: self newMessageArgumentNames! ! -!ExtractMethodApplier methodsFor: 'private - new message' stamp: 'HAW 9/5/2021 22:48:32'! - newMessageArgumentNames - - ^ newMessageArguments values collect: [ :parseNode | parseNode name ]! ! -!ExtractMethodApplier methodsFor: 'private - new message' stamp: 'HAW 9/5/2021 22:48:36'! - saveUnarySelector: userAnswer - - ^ newSelector := userAnswer asSymbol! ! -!ExtractMethodApplier methodsFor: 'value' stamp: 'HAW 9/5/2021 22:48:40' overrides: 50441454! - value - - requestExitBlock := [ ^self ]. - - self requestRefactoringParametersHandlingRefactoringExceptions -! ! -!ExtractMethodApplier methodsFor: 'value' stamp: 'HAW 9/5/2021 22:48:45'! - valueCreatingWith: aRefactoringCreationBlock - - self - createAndSetRefactoringHandlingRefactoringExceptions: aRefactoringCreationBlock; - applyRefactoring; - showChanges - - ! ! -!ExtractMethodApplier methodsFor: 'value' stamp: 'HAW 9/5/2021 22:48:48'! - valueWithAllReplacements - - self valueCreatingWith: [ self createRefactoringWithAllReplacements ] - ! ! -!ExtractMethodApplier methodsFor: 'value' stamp: 'HAW 9/5/2021 22:48:51'! - valueWithMethodsInClass - - self valueCreatingWith: [ self createRefactoringForMethodsInClass ]! ! -!ExtractMethodApplier methodsFor: 'value' stamp: 'HAW 9/5/2021 22:48:54'! - valueWithOriginalSelection - - self valueCreatingWith: [ self createRefactoringForOriginalSelection ]! ! -!ExtractMethodApplier methodsFor: 'value' stamp: 'HAW 9/5/2021 22:48:58'! - valueWithSourceMethod - - self valueCreatingWith: [ self createRefactoringForSourceMethod ]! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'HAW 9/5/2021 22:49:03'! - buildInitialSelectorAnswer: parseNodesToParameterize - "builds a selector with the shape of #m1 if unary, or #m1: something m2: else if it has args" - - ^ parseNodesToParameterize - ifEmpty: [ self formatAsKeyword: 'm1' ] - ifNotEmpty: [ parseNodesToParameterize - inject: '' - into: [ :partialSelector :parseNode | - | currentKeyword | - currentKeyword _ 'm' , (parseNodesToParameterize indexOf: parseNode) asString , ': '. - partialSelector - , (self formatAsKeyword: currentKeyword) - , (self formatAsMethodArgument: parseNode name) - , String newLineString ] ]! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'HAW 9/5/2021 22:49:06'! -formatAsKeyword: aKeyword - - ^ Text - string: aKeyword - attributes: (SHTextStylerST80 attributesFor: #patternKeyword)! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'HAW 9/5/2021 22:49:10'! - formatAsMethodArgument: aMethodArgumentName - - ^ Text - string: aMethodArgumentName - attributes: (SHTextStylerST80 attributesFor: #methodArg)! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'HAW 9/5/2021 22:49:13'! - parseNodesToParameterize - - ^ ExtractMethodParametersDetector - valueFor: methodToExtractCodeFrom methodNode - at: intervalToExtract! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'HAW 9/5/2021 22:49:16'! - saveBinaryOrKeywordSelector: userAnswer withArguments: parseNodesToParameterize - - self saveMessageArgumentsForEach: parseNodesToParameterize using: userAnswer. - newSelector := ('' join: (self selectorTokensOf: userAnswer)) asSymbol.! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'HAW 9/5/2021 22:49:20'! - saveMessageArgumentsForEach: parseNodesToParameterize using: userAnswer - - | newSelectorKeywords | - newSelectorKeywords _ self selectorTokensOf: userAnswer. - self validateRequiredParameters: parseNodesToParameterize haveACorrespondingKeywordIn: newSelectorKeywords. - parseNodesToParameterize withIndexDo: [ :parseNode :index | - newMessageArguments at: (newSelectorKeywords at: index) put: parseNode ]! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'HAW 9/5/2021 22:49:23'! - selectorTokensOf: userAnswer - "this selects the pieces of strings before each $:" - - ^ (userAnswer findTokens: ':') allButLast - collect: [ :tok | (tok findTokens: Character separators) last , ':' ]! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'HAW 9/5/2021 22:49:26'! - sourceCodeToExtract - - ^sourceCodeToExtract! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'HAW 9/5/2021 22:49:29'! - validateRequiredParameters: parseNodesToParameterize haveACorrespondingKeywordIn: newSelectorKeywords - - newSelectorKeywords size = parseNodesToParameterize size - ifFalse: [ ExtractMethodNewMethod signalExtractMethodWithWrongNumberOfArgumentsError ]! ! -!ExtractMethodApplier class methodsFor: 'instance creation' stamp: 'HAW 9/5/2021 22:47:32'! - on: aCodeProvider for: anIntervalToExtract of: aMethodToRefactor - - | trimmedIntervalToExtract sourceCode | - - sourceCode := aMethodToRefactor sourceCode. - trimmedIntervalToExtract := anIntervalToExtract trimToMatchExpressionOn: sourceCode.. - - self assertCanApplyRefactoringOn: aMethodToRefactor at: trimmedIntervalToExtract. - - ^ self new initializeOn: aCodeProvider for: trimmedIntervalToExtract of: aMethodToRefactor! ! -!ExtractMethodApplier class methodsFor: 'pre-conditions' stamp: 'HAW 9/5/2021 22:47:27'! - assertCanApplyRefactoringOn: aMethodToRefactor at: anIntervalToExtract - - ExtractMethodNewMethod - assertCanApplyRefactoringOn: aMethodToRefactor - at: anIntervalToExtract! ! -!SmalltalkEditor methodsFor: 'extract method' stamp: 'HAW 9/5/2021 20:36:00' prior: 50517563! - extractMethod - - self performCodeExtractionRefactoringWith: ExtractMethodApplier! ! -!ChangeSelectorWizardStepWindow methodsFor: 'button creation' stamp: 'HAW 9/5/2021 20:07:07' prior: 50438289! - createRemoveButton - - ^PluggableButtonMorph - model: self - stateGetter: nil - action: #remove - label: 'Remove'. -! ! -!AddInstanceVariable methodsFor: 'initialization' stamp: 'HAW 8/28/2021 17:44:36' prior: 50438540! - initializeNamed: aNewVariable to: aClassToRefactor - - newVariable := aNewVariable. - classToRefactor := aClassToRefactor ! ! -!RefactoringApplier methodsFor: 'refactoring - creation' stamp: 'HAW 8/26/2021 16:04:27' prior: 50441332! - createRefactoringHandlingRefactoringExceptions - - self createAndSetRefactoringHandlingRefactoringExceptions: [ self createRefactoring ] - ! ! -!SourceCodeIntervalPrecondition methodsFor: 'pre-conditions' stamp: 'HAW 8/26/2021 15:57:31' prior: 50529604! - assertSourceCodeIsNotPartOfMethodSignature - - self intervalToExtractIncludesPartOfMethodSignature - ifTrue: [ self signalExtractingPartOfMethodSignatureError ]! ! -!SourceCodeIntervalPrecondition methodsFor: 'private' stamp: 'HAW 8/26/2021 15:56:33' prior: 50529658! - methodDefinitionStartPosition - - ^methodNode definitionStartPosition! ! -!MethodReference methodsFor: 'decompiling' stamp: 'HAW 9/5/2021 23:06:10'! - methodNode - - ^self compiledMethod methodNode! ! -!CompiledMethod methodsFor: 'converting' stamp: 'HAW 9/5/2021 23:06:10'! - asMethodReference - - ^MethodReference method: self! ! - -SourceCodeIntervalPrecondition removeSelector: #firstParseNodeOfMethodDefinition! - -!methodRemoval: SourceCodeIntervalPrecondition #firstParseNodeOfMethodDefinition stamp: 'Install-4853-ExtractMethodEnhancement-HernanWilkinson-2021Aug25-15h32m-HAW.001.cs.st 9/21/2021 12:54:09'! -firstParseNodeOfMethodDefinition - - ^ methodNode hasTemporaryVariables - ifTrue: [ methodNode temporariesDeclaration ] - ifFalse: [ methodNode block statements first - ifNotNil: [ :statement | statement ] - ifNil: [ methodNode ] ]! - -ChangeSelectorWizardStepWindow removeSelector: #isMessageSelected! - -!methodRemoval: ChangeSelectorWizardStepWindow #isMessageSelected stamp: 'Install-4853-ExtractMethodEnhancement-HernanWilkinson-2021Aug25-15h32m-HAW.001.cs.st 9/21/2021 12:54:09'! -isMessageSelected - - ^model isNil ifTrue: [ false ] ifFalse: [ model selection notNil ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4853-ExtractMethodEnhancement-HernanWilkinson-2021Aug25-15h32m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4853] on 7 September 2021 at 12:53:40 pm'! -!HaloMorph methodsFor: 'drawing' stamp: 'jmv 9/7/2021 12:52:43' prior: 50605756! - drawCoordinateSystemOn: aCanvas - - | x0 x1 y0 y1 c stepX stepY haloTargetTx prevTx font strokeWidth tickLength stepXDecimals stepYDecimals | - haloTargetTx _ MorphicTranslation identity. - target allOwnersReverseDo: [ :o | haloTargetTx _ haloTargetTx composedWith: o location ]. - haloTargetTx _ haloTargetTx composedWith: target location. - - target knowsOwnLocalBounds - ifTrue: [ | r | - r _ target morphLocalBounds. - x0 _ r left. - x1 _ r right. - y0 _ r top. - y1 _ r bottom ] - ifFalse: [ - x0 _ x1 _ y0 _ y1 _ 0. - target displayFullBounds corners collect: [ :pt | | p | - p _ haloTargetTx inverseTransform: pt. - x0 _ x0 min: p x. - x1 _ x1 max: p x. - y0 _ y0 min: p y. - y1 _ y1 max: p y.]]. - - font _ FontFamily defaultFamilyPointSize: FontFamily defaultPointSize * 1.5 / haloTargetTx scale. - stepX _ (font pointSize * 9) round4perMagnitudeOrder asFloat. - stepXDecimals _ stepX log rounded negated + 1. - stepY _ (font pointSize * 5) round4perMagnitudeOrder asFloat. - stepYDecimals _ stepY log rounded negated + 1. - strokeWidth _ 3/ haloTargetTx scale. - tickLength _ 5 / haloTargetTx scale. - - prevTx _ aCanvas currentTransformation. - aCanvas geometryTransformation: haloTargetTx. - - c _ `Color black alpha: 0.4`. - aCanvas line: x0@0 to: x1@0 width: strokeWidth color: c. - aCanvas line: 0@y0 to: 0@y1 width: strokeWidth color: c. - - (x0 truncateTo: stepX) to: x1 by: stepX do: [ :x | - aCanvas line: x @ tickLength negated to: x @ tickLength width: strokeWidth color: c. - aCanvas drawString: (x printStringFractionDigits: stepXDecimals) atCenterXBaselineY: x @ (tickLength*2) negated font: font color: c ]. - aCanvas drawString: 'x' atCenterX: x1 - (tickLength*3) @ 0 font: font color: c. - - (y0 truncateTo: stepY) to: y1 by: stepY do: [ :y | - aCanvas line: tickLength negated @ y to: tickLength @ y width: strokeWidth color: c. - aCanvas drawString: (y printStringFractionDigits: stepYDecimals), ' ' atWaistRight: tickLength negated @ y font: font color: c ]. - aCanvas drawString: 'y' atWaist: tickLength @ (y1 - (tickLength*4)) font: font color: c. - - aCanvas geometryTransformation: prevTx.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4854-drawCoordinates-tweak-JuanVuletich-2021Sep07-12h50m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4854] on 9 September 2021 at 2:05:28 pm'! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 9/9/2021 14:05:20' prior: 50595329! - updateBoundsIn: aWorldMorph addDamageTo: aDamageRecorder - - aWorldMorph haloMorphsDo: [ :halo | - (halo target isRedrawNeeded or: [halo target isSubmorphRedrawNeeded]) ifTrue: [ - "Invalidation of halos requires this specific sequence:" - halo redrawNeeded. "invalidate old halo bounds" - self fullAddRedrawRect: halo target to: aDamageRecorder. "recompute & invalidate target bounds" - self fullAddRedrawRect: halo to: aDamageRecorder ]]. "recompute & invalidate halo bounds" - "bogus iteration on halos and targets below is harmless: - Both now marked as neither #isRedrawNeeded nor #isSubmorphRedrawNeeded." - - aWorldMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - self updateHandsDisplayBounds: aWorldMorph.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4855-BoundsFinder-fix-JuanVuletich-2021Sep09-14h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4855] on 10 September 2021 at 4:10:30 pm'! -!MouseEvent methodsFor: 'button state' stamp: 'jmv 9/10/2021 16:02:58'! - turnMouseButton2Into3 - "Answer true if modifier keys are such that button 2 should be considered as button 3. - ctrl - click right -> center click - " - - self controlKeyPressed ifTrue: [ ^ true ]. - ^ false! ! -!MouseEvent methodsFor: 'button state' stamp: 'jmv 9/10/2021 16:08:01' prior: 50467593! - mouseButton2Pressed - "Answer true if the mouseButton2 is being pressed. - Reported by the VM for right mouse button or option+click on the Mac, ctrl-click on Windows, or ctrl-click or alt-click on Linux. - It is also emulated here with ctrl-click on any platform." - - (self turnMouseButton1Into2 and: [ buttons anyMask: InputSensor mouseButton1 ]) - ifTrue: [ ^ true ]. - self turnMouseButton2Into3 ifTrue: [ ^ false ]. - ^ buttons anyMask: InputSensor mouseButton2! ! -!MouseEvent methodsFor: 'button state' stamp: 'jmv 9/10/2021 16:06:43' prior: 50467609! - mouseButton3Pressed - "Answer true if the mouseButton3 is being pressed. - Reported by the VM for center (wheel) mouse button or cmd+click on the Mac or win/meta+click on Windows and Linux. - It is also emulated here with on any platform with: - shift - ctrl - click - ctrl - rightClick" - - (self turnMouseButton1Into3 and: [ buttons anyMask: InputSensor mouseButton1 ]) - ifTrue: [ ^ true ]. - (self turnMouseButton2Into3 and: [ buttons anyMask: InputSensor mouseButton2 ]) - ifTrue: [ ^ true ]. - ^ buttons anyMask: InputSensor mouseButton3! ! -!MouseButtonEvent methodsFor: 'accessing' stamp: 'jmv 9/10/2021 16:09:10' prior: 50467646! - mouseButton2Changed - "Answer true if the mouseButton2 has changed. - Reported by the VM for right mouse button or option+click on the Mac. - It is also emulated here with ctrl-click on any platform. - The check for button change (instead of button press) is specially useful on buttonUp events." - - (self turnMouseButton1Into2 and: [ whichButton anyMask: InputSensor mouseButton1 ]) - ifTrue: [ ^ true ]. - self turnMouseButton2Into3 ifTrue: [ ^ false ]. - ^ whichButton anyMask: InputSensor mouseButton2! ! -!MouseButtonEvent methodsFor: 'accessing' stamp: 'jmv 9/10/2021 16:07:19' prior: 50467663! - mouseButton3Changed - "Answer true if the mouseButton3 has changed. - Reported by the VM for center (wheel) mouse button or cmd+click on the Mac or meta+click on Linux. - It is also emulated here with shift-ctrl-click or ctrl-rightClick on any platform. - The check for button change (instead of button press) is specially useful on buttonUp events." - - (self turnMouseButton1Into3 and: [ whichButton anyMask: InputSensor mouseButton1 ]) - ifTrue: [ ^ true ]. - (self turnMouseButton2Into3 and: [ whichButton anyMask: InputSensor mouseButton2 ]) - ifTrue: [ ^ true ]. - ^ whichButton anyMask: InputSensor mouseButton3! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4856-ctrl-rightClick-emulatesCenterClick-JuanVuletich-2021Sep10-16h02m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4856] on 13 September 2021 at 3:51:30 pm'! -!ScrollBar methodsFor: 'events' stamp: 'jmv 9/13/2021 15:51:20' prior: 16904535 overrides: 16874668! - mouseStillDown - - nextPageDirection notNil ifTrue: [ - self scrollByPage ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4857-AvoidWalkbackOnLost-mouseDown-JuanVuletich-2021Sep13-15h51m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4856] on 13 September 2021 at 4:08:19 pm'! -!WorldMorph methodsFor: 'canvas' stamp: 'jmv 9/13/2021 16:07:58' prior: 50603064! - setMainCanvas - "Deallocate before allocating could mean less memory stress." - - self clearCanvas. - self setCanvas: Display getMainCanvas. - self restoreDisplay.! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 9/13/2021 16:03:02' prior: 50604399! - checkForNewScreenSize - "Check whether the screen size has changed and if so take appropriate actions" - - DisplayScreen isDisplayExtentOk ifFalse: [ - self clearCanvas. - DisplayScreen startUp. - self setMainCanvas. - self whenUIinSafeState: [ Cursor defaultCursor activateCursor ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4858-MainWindowResizeCleanup-JuanVuletich-2021Sep13-15h51m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4858] on 14 September 2021 at 3:57:49 pm'! -!WidgetMorph methodsFor: 'drawing' stamp: 'jmv 9/13/2021 17:26:04' overrides: 50578084! - imageForm: extentOrNil depth: depth - - | answerExtent answer auxCanvas | - self requiresVectorCanvas ifFalse: [ - answerExtent _ extent. - extentOrNil ifNotNil: [ answerExtent _ answerExtent min: extentOrNil * 4 ]. - auxCanvas _ MorphicCanvas depth: depth over: (self morphPosition floor extent: answerExtent ceiling). - auxCanvas fullDraw: self. - answer _ auxCanvas form divideByAlpha. - extentOrNil ifNotNil: [ answer _ answer magnifyTo: extentOrNil ]. - ^answer ]. - ^super imageForm: extentOrNil depth: depth.! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 9/13/2021 17:26:23' prior: 50578084! - imageForm: extentOrNil depth: depth - - self subclassResponsibility! ! - -MovableMorph removeSelector: #privateLocation:! - -!methodRemoval: MovableMorph #privateLocation: stamp: 'Install-4859-imageFormdepth-refactor-JuanVuletich-2021Sep14-15h55m-jmv.001.cs.st 9/21/2021 12:54:09'! -privateLocation: aGeometryTransformation - location _ aGeometryTransformation.! - -Morph removeSelector: #privateLocation:! - -!methodRemoval: Morph #privateLocation: stamp: 'Install-4859-imageFormdepth-refactor-JuanVuletich-2021Sep14-15h55m-jmv.001.cs.st 9/21/2021 12:54:09'! -privateLocation: aGeometryTransformation! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4859-imageFormdepth-refactor-JuanVuletich-2021Sep14-15h55m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4859] on 14 September 2021 at 4:21:17 pm'! -!DisplayScreen methodsFor: 'other' stamp: 'jmv 9/14/2021 16:20:04' prior: 16835206! - forceToScreen: aRectangle - "Force the given rectangular section of the Display to be copied to the screen. The primitive call does nothing if the primitive is not implemented. Used when the deferUpdates flag in the virtual machine is on; see #deferUpdates:. - - If for whatever reason, actual OS or hardware Display is smaller than us, don't go outside its bounds. - This can sometimes happen, at least on MacOS, when frantically resizing the main OS Cuis window, - while Morphic is busy drawing many heavy morphs: it could be observed than apparently in #displayWorld, - after we were updated in #checkForNewScreenSize, MacOS window could be made smaller than aRectangle, - and a hard crash due to an invalid memory access happened in this primitive." - - | platformDisplayExtent | - platformDisplayExtent _ DisplayScreen actualScreenSize. - self primShowRectLeft: (aRectangle left max: 0) - right: (aRectangle right min: platformDisplayExtent x) - top: (aRectangle top max: 0) - bottom: (aRectangle bottom min: platformDisplayExtent y). -! ! -!WorldMorph methodsFor: 'drawing' stamp: 'jmv 9/14/2021 16:20:41' prior: 50551876! - displayWorld - "Update this world's display." - - | deferredUpdateVMMode worldDamageRects handsToDraw allDamage | - self checkIfUpdateNeeded ifFalse: [ ^ self ]. "display is already up-to-date" - "I (jmv) removed the call to 'deferUpdates: false' below. No more need to call this every time." - deferredUpdateVMMode _ self tryDeferredUpdatingAndSetCanvas. - - "repair world's damage on canvas" - worldDamageRects _ canvas drawWorld: self repair: damageRecorder. - - "Check which hands need to be drawn (they are not the hardware mouse pointer)" - handsToDraw _ self selectHandsToDrawForDamage: worldDamageRects. - allDamage _ Array streamContents: [ :strm | - strm nextPutAll: worldDamageRects. - handsToDraw do: [ :h | - h savePatchFrom: canvas appendDamageTo: strm ]]. - - "Draw hands (usually carying morphs) onto world canvas" - canvas newClipRect: nil. - handsToDraw reverseDo: [ :h | canvas fullDrawHand: h ]. - - "quickly copy altered rects of canvas to Display:" - deferredUpdateVMMode ifFalse: [ - "Drawing was done to off-Display canvas. Copy content to Display" - canvas showAt: self viewBox origin invalidRects: allDamage ]. - - "Display deferUpdates: false." - "Display forceDisplayUpdate" - DisplayScreen isDisplayExtentOk ifTrue: [ - Display forceDamageToScreen: allDamage ]. - - "Restore world canvas under hands and their carried morphs" - handsToDraw do: [ :h | h restoreSavedPatchOn: canvas ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4860-fixUnlikelyCrashOnMainWindowResize-JuanVuletich-2021Sep14-16h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4860] on 15 September 2021 at 9:48:57 am'! -!GeometryTransformation methodsFor: 'modifying' stamp: 'jmv 9/14/2021 18:16:54'! - invertingYAxis: mustInvertYAxis - "Answer an instance (either the receiver or a new one) with the prescribed behavior on the Y axis: - - If mustInvertYAxis, the Y axis in inner and outer space point in opposite directions. - - If mustInvertYAxis is false, the Y axis in inner and outer space point in the same direction (either up or down). - Senders should always use the returned object, but not assume it is a new one: - it could also be the receiver itself." - - self doesMirror = mustInvertYAxis ifFalse: [ - ^self withCurrentYAxisInverted ]. - ^self! ! -!GeometryTransformation methodsFor: 'modifying' stamp: 'jmv 9/14/2021 18:15:52'! - withCurrentYAxisInverted - "Answer an instance (either the receiver or a new one) that flips the current direction of the Y axis. - This means that whatever we answer when externalizing x@y, it will answer when externalizing x @ -y. - Senders should always use the returned object, but not assume it is a new one: - it could also be the receiver itself." - - self subclassResponsibility! ! -!AffineTransformation methodsFor: 'modifying' stamp: 'jmv 9/14/2021 18:15:58' overrides: 50607686! - withCurrentYAxisInverted - "Answer an instance (either the receiver or a new one) that flips the current direction of the Y axis. - This means that whatever we answer when externalizing x@y, it will answer when externalizing x @ -y. - Senders should always use the returned object, but not assume it is a new one (like for MorphicTranslation): - it could also be the receiver itself, like when the receiver is already a AffineTransformation." - - self a12: self a12 negated. - self a22: self a22 negated. - ^self! ! -!MorphicTranslation methodsFor: 'modifying' stamp: 'jmv 9/14/2021 18:16:01' overrides: 50607686! -withCurrentYAxisInverted - "Answer an instance (either the receiver or a new one) that flips the current direction of the Y axis. - This means that whatever we answer when externalizing x@y, it will answer when externalizing x @ -y. - Senders should always use the returned object, but not assume it is a new one (like here): - it could also be the receiver itself, like when the receiver is already a AffineTransformation." - - ^(AffineTransformation withTranslation: self translation) withCurrentYAxisInverted! ! -!MovableMorph methodsFor: 'geometry testing' stamp: 'jmv 9/14/2021 18:21:50'! - yAxisPointsUp - "By default, most morphs assume the usual convention in 2d computer graphics: - - x points to the right (i.e. increasing x values move from left to right) - - y points down (i.e. increasing y values move from top to bottom) - Subclasses wanting to follow the standard math convention, making increasing y values move upwards - should redefine this method to answer true." - - ^false! ! -!MovableMorph methodsFor: 'private' stamp: 'jmv 9/14/2021 18:24:55'! - fixYAxisDirection - "Ensure the direction of the Y axis used by our location for coordinate transformations matches our #yAxisPointsUp." - - | ownersYAxisPointsUp | - ownersYAxisPointsUp _ owner ifNil: [false] ifNotNil: [owner yAxisPointsUp]. - location _ location invertingYAxis: (self yAxisPointsUp = ownersYAxisPointsUp) not! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 9/14/2021 18:58:27'! - drawString: s atWaistCenter: pt font: fontOrNil color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - - | font dy | - font _ self fontToUse: fontOrNil. - dy _ currentTransformation doesMirror - ifFalse: [ font ascent * 0.4 ] - ifTrue: [ font ascent * -0.4 ]. - ^self - drawString: s - from: 1 to: s size - atBaseline: pt + ((font widthOfString: s) negated / 2 @ dy) - font: font color: aColor! ! -!GeometryTransformation methodsFor: 'testing' stamp: 'jmv 9/13/2021 17:01:20' prior: 50560741! - doesMirror - "Return true if the receiver mirrors points around some rect. - Usually this is interpreted as (and used for) inverting the direction of the Y axis between the inner and the outer coordinates systems." - - ^false! ! -!AffineTransformation methodsFor: 'testing' stamp: 'jmv 9/13/2021 17:01:13' prior: 50560747 overrides: 50607785! - doesMirror - "Return true if the receiver mirrors points around some rect. - Usually this is interpreted as (and used for) inverting the direction of the Y axis between the inner and the outer coordinates systems." - - | f | - f _ self a11 * self a22. - ^ f = 0.0 - ifTrue: [ self a12 * self a21 > 0.0] - ifFalse: [ f < 0.0 ]! ! -!MovableMorph methodsFor: 'accessing' stamp: 'jmv 9/14/2021 18:27:26' prior: 50576101 overrides: 50559666! - location: aGeometryTransformation - location _ aGeometryTransformation. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self fixYAxisDirection. - self redrawNeeded.! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 9/15/2021 09:45:04' prior: 50554261! - rotateBy: radians - "Change the rotation of this morph. Argument is an angle (possibly negative), to be added to current rotation." - - | r | - r _ self yAxisPointsUp ifTrue: [ radians negated ] ifFalse: [ radians ]. - location _ location rotatedBy: r. - self fixYAxisDirection. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 9/15/2021 09:44:18' prior: 50554280 overrides: 50554557! - rotation: radians scale: scale - "Change the rotation and scale of this morph. Arguments are an angle and a scale." - - | r | - r _ self yAxisPointsUp ifTrue: [ radians negated ] ifFalse: [ radians ]. - location _ location withRotation: r scale: scale. - self fixYAxisDirection. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!MovableMorph methodsFor: 'private' stamp: 'jmv 9/14/2021 18:26:53' prior: 50554394 overrides: 50590088! - privateOwner: aMorph - "Private!! Should only be used by methods that maintain the ower/submorph invariant." - - | oldGlobalPosition prevOwner | - - self flag: #jmvVer2. - "Is this the best behavior???" - prevOwner _ owner. - prevOwner - ifNotNil: [ - "Had an owner. Maintain my global position..." - oldGlobalPosition _ self morphPositionInWorld ]. - owner _ aMorph. - owner - ifNil: [ - "Won't have any owner. Keep local position, as it will be maintained in my new owner later" - ] - ifNotNil: [ - prevOwner - ifNil: [ - "Didn't have any owner. Assume my local position is to be maintained in my new owner" - ] - ifNotNil: [ - "Had an owner. Maintain my global position..." - location _ location withTranslation: (owner internalizeFromWorld: oldGlobalPosition). - self flag: #jmvVer2. - "extent _ owner internalizeDistanceFromWorld: oldGlobalExtent" "or something like this!!" - ]]. - self fixYAxisDirection.! ! -!HaloMorph methodsFor: 'drawing' stamp: 'jmv 9/14/2021 18:59:01' prior: 50607278! - drawCoordinateSystemOn: aCanvas - - | x0 x1 y0 y1 c stepX stepY haloTargetTx prevTx font strokeWidth tickLength stepXDecimals stepYDecimals | - haloTargetTx _ MorphicTranslation identity. - target allOwnersReverseDo: [ :o | haloTargetTx _ haloTargetTx composedWith: o location ]. - haloTargetTx _ haloTargetTx composedWith: target location. - - target knowsOwnLocalBounds - ifTrue: [ | r | - r _ target morphLocalBounds. - x0 _ r left. - x1 _ r right. - y0 _ r top. - y1 _ r bottom ] - ifFalse: [ - x0 _ x1 _ y0 _ y1 _ 0. - target displayFullBounds corners collect: [ :pt | | p | - p _ haloTargetTx inverseTransform: pt. - x0 _ x0 min: p x. - x1 _ x1 max: p x. - y0 _ y0 min: p y. - y1 _ y1 max: p y.]]. - - font _ FontFamily defaultFamilyPointSize: FontFamily defaultPointSize * 1.5 / haloTargetTx scale. - stepX _ (font pointSize * 9) round4perMagnitudeOrder asFloat. - stepXDecimals _ stepX log rounded negated + 1. - stepY _ (font pointSize * 5) round4perMagnitudeOrder asFloat. - stepYDecimals _ stepY log rounded negated + 1. - strokeWidth _ 3/ haloTargetTx scale. - tickLength _ 5 / haloTargetTx scale. - - prevTx _ aCanvas currentTransformation. - aCanvas geometryTransformation: haloTargetTx. - - c _ `Color black alpha: 0.4`. - aCanvas line: x0@0 to: x1@0 width: strokeWidth color: c. - aCanvas line: 0@y0 to: 0@y1 width: strokeWidth color: c. - - (x0 truncateTo: stepX) to: x1 by: stepX do: [ :x | - aCanvas line: x @ tickLength negated to: x @ tickLength width: strokeWidth color: c. - aCanvas drawString: (x printStringFractionDigits: stepXDecimals) atWaistCenter: x @ (tickLength*4) negated font: font color: c ]. - aCanvas drawString: 'x' atCenterX: x1 - (tickLength*3) @ 0 font: font color: c. - - (y0 truncateTo: stepY) to: y1 by: stepY do: [ :y | - aCanvas line: tickLength negated @ y to: tickLength @ y width: strokeWidth color: c. - aCanvas drawString: (y printStringFractionDigits: stepYDecimals), ' ' atWaistRight: tickLength negated @ y font: font color: c ]. - aCanvas drawString: 'y' atWaist: tickLength @ (y1 - (tickLength*4)) font: font color: c. - - aCanvas geometryTransformation: prevTx.! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 9/15/2021 09:46:28' prior: 50576109! - doRot: evt with: rotHandle - "Update the rotation of my target if it is rotatable." - - | radians prevLocation deltaRadians | - evt hand obtainHalo: self. - radians _ (evt eventPosition - target referencePosition) theta + angleOffset. - radians _ radians detentBy: 0.05 atMultiplesOf: Float pi / 4 snap: false. - rotHandle color: (radians = 0.0 - ifTrue: [`Color lightBlue`] - ifFalse: [`Color blue`]). - rotHandle submorphsDo: [ :m | - m color: rotHandle color makeForegroundColor]. - prevLocation _ target location. - deltaRadians _ radians-prevLocation radians. - target yAxisPointsUp ifTrue: [ deltaRadians _ deltaRadians negated ]. - target location: (prevLocation composedWith: ( - AffineTransformation withRadians: deltaRadians around: target rotationCenter)). - rotHandle morphPositionInWorld: evt eventPosition - (rotHandle morphExtent // 2). - self redrawNeeded.! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 9/14/2021 19:00:41' prior: 50565954! - drawString: aString from: firstIndex to: lastIndex atWaist: aPoint font: font color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - - | dy | - dy _ currentTransformation doesMirror - ifFalse: [ font ascent * 0.4 ] - ifTrue: [ font ascent * -0.4 ]. - ^self drawString: aString from: firstIndex to: lastIndex - atBaseline: aPoint + (0 @ dy) - font: font color: aColor! ! - -MorphicTranslation removeSelector: #withYAxisNegated! - -!methodRemoval: MorphicTranslation #withYAxisNegated stamp: 'Install-4861-YaxisUpwardsSupport-JuanVuletich-2021Sep15-09h37m-jmv.001.cs.st 9/21/2021 12:54:09'! -withYAxisNegated - "Swap inneer point Y sign. - Make y increment upwards. - This makes the any matrix transform from standard mathematical coordinates - to standard display coordinates (in addition to the transform it was already doing) - - Answer the modified object. In this implementation this requires the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself, - as if the receiver is already a AffineTransformation." - - ^(AffineTransformation withTranslation: self translation) withYAxisNegated! - -AffineTransformation removeSelector: #withYAxisNegated! - -!methodRemoval: AffineTransformation #withYAxisNegated stamp: 'Install-4861-YaxisUpwardsSupport-JuanVuletich-2021Sep15-09h37m-jmv.001.cs.st 9/21/2021 12:54:09'! -withYAxisNegated - "Swap inneer point Y sign. - Make y increment upwards. - This makes the any matrix transform from standard mathematical coordinates - to standard display coordinates (in addition to the transform it was already doing) - - Answer the modified object. In this implementation it is self, but some classes of transformations, - more restricted ones (like MorphicTranslation) could require the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself." - - self a12: self a12 negated. - self a22: self a22 negated. - ^self! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4861-YaxisUpwardsSupport-JuanVuletich-2021Sep15-09h37m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4861] on 15 September 2021 at 9:07:29 am'! -!WidgetMorph methodsFor: 'drawing' stamp: 'jmv 9/15/2021 08:48:04' prior: 50607529 overrides: 50607548! - imageForm: extentOrNil depth: depth - - | answerExtent answer auxCanvas | - self requiresVectorCanvas ifFalse: [ - answerExtent _ extent. - extentOrNil ifNotNil: [ answerExtent _ answerExtent min: extentOrNil * 4 ]. - "To avoid slower Smalltalk VG engine just because of window decorations" - auxCanvas _ BitBltCanvas depth: depth over: (self morphPosition floor extent: answerExtent ceiling). - auxCanvas fullDraw: self. - answer _ auxCanvas form divideByAlpha. - extentOrNil ifNotNil: [ answer _ answer magnifyTo: extentOrNil ]. - ^answer ]. - ^super imageForm: extentOrNil depth: depth.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4862-imageForm-use-BitBltCanvas-JuanVuletich-2021Sep15-09h07m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4862] on 16 September 2021 at 11:30:30 am'! -!DisplayScreen class methodsFor: 'snapshots' stamp: 'jmv 9/16/2021 11:22:16'! - setupDisplay: doGarbageCollection - " - DisplayScreen setupDisplay: true. - Display forceToScreen. - " - - self terminateScreenUpdater. - doGarbageCollection ifTrue: [ - Display setExtent: 0@0 depth: 0 bits: nil. - Smalltalk garbageCollect ]. - Display setExtent: self actualScreenSize depth: Display nativeDepth. - Display beDisplay. - self installScreenUpdater.! ! -!DisplayScreen methodsFor: 'other' stamp: 'jmv 9/16/2021 10:58:07' prior: 50607577! - forceToScreen: aRectangle - "Force the given rectangular section of the Display to be copied to the screen. The primitive call does nothing if the primitive is not implemented. Used when the deferUpdates flag in the virtual machine is on; see #deferUpdates:. - - If for whatever reason, actual OS or hardware Display is smaller than us, don't go outside its bounds. - This can sometimes happen, at least on MacOS, when frantically resizing the main OS Cuis window, - while Morphic is busy drawing many heavy morphs: it could be observed than apparently in #displayWorld, - after we were updated in #checkForNewScreenSize, MacOS window could be made smaller than aRectangle, - and a hard crash due to an invalid memory access happened in this primitive. - - Protecting against our bounds being smaller than aRectangle is done in the primitive. No need to do it here." - - | platformDisplayExtent | - platformDisplayExtent _ DisplayScreen actualScreenSize. - self primShowRectLeft: (aRectangle left max: 0) - right: (aRectangle right min: platformDisplayExtent x) - top: (aRectangle top max: 0) - bottom: (aRectangle bottom min: platformDisplayExtent y). -! ! -!DisplayScreen class methodsFor: 'snapshots' stamp: 'jmv 9/16/2021 11:22:01' prior: 50571531 overrides: 50335344! - startUp - " - DisplayScreen startUp. - Display forceToScreen. - " - self setupDisplay: false.! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 9/16/2021 11:25:32' prior: 50607509! - checkForNewScreenSize - "Check whether the screen size has changed and if so take appropriate actions" - - DisplayScreen isDisplayExtentOk ifFalse: [ - "Minimize the risk of going out of memory: - - First clear existing canvas, to free the memory it uses. - - Then, setup the display, with a GarbageCollection prior to allocating new display memory. - - Then set up new canvas." - self clearCanvas. - DisplayScreen setupDisplay: true. - self setMainCanvas. - self whenUIinSafeState: [ Cursor defaultCursor activateCursor ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4863-GarbabeCollectDuringDisplayResize-JuanVuletich-2021Sep16-11h28m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4863] on 16 September 2021 at 2:28:36 pm'! -!LargeNegativeInteger methodsFor: 'printing' stamp: 'jmv 9/16/2021 14:27:54' overrides: 16862727! - printOn: aStream base: b nDigits: n - "See comment at LargePositiveInteger." - - self shouldNotImplement.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4864-printOnbasenDigits-notAppropriateFor-LargeNegativeInteger-JuanVuletich-2021Sep16-14h27m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4863] on 16 September 2021 at 2:33:13 pm'! -!BlockClosure methodsFor: 'evaluating' stamp: 'jmv 9/16/2021 14:32:50'! - millisecondsToRun - "Answer the number of milliseconds taken to execute this block." - - ^ Time millisecondsToRun: self -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4865-millisecondsToRun-JuanVuletich-2021Sep16-14h28m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4863] on 16 September 2021 at 2:36:00 pm'! -!BlockClosure methodsFor: 'evaluating' stamp: 'jmv 9/16/2021 14:34:45'! - millisecondsToRunWithoutGC - "Answer the number of milliseconds taken to execute this block without GC time." - - ^(Smalltalk vmParameterAt: 8) + - (Smalltalk vmParameterAt: 10) + - self millisecondsToRun - - (Smalltalk vmParameterAt: 8) - - (Smalltalk vmParameterAt: 10) -! ! -!BlockClosure methodsFor: 'evaluating' stamp: 'jmv 9/16/2021 14:34:26' prior: 16787872! - durationToRun - "Answer the duration taken to execute this block." - - ^ Duration milliSeconds: self millisecondsToRun.! ! -!TestCase methodsFor: 'assertions' stamp: 'jmv 9/16/2021 14:35:21' prior: 50458978! - should: aClosure notTakeMoreThan: aLimit - - | millisecondsLimit | - - millisecondsLimit := aLimit totalMilliseconds. - self assert: aClosure millisecondsToRun <= millisecondsLimit - description: [ 'Took more than ', millisecondsLimit printString, ' milliseconds' ].! ! - -BlockClosure removeSelector: #timeToRunWithoutGC! - -!methodRemoval: BlockClosure #timeToRunWithoutGC stamp: 'Install-4866-prefer-millisecondsToRun-over-timeToRun-JuanVuletich-2021Sep16-14h33m-jmv.001.cs.st 9/21/2021 12:54:09'! -timeToRunWithoutGC - "Answer the number of milliseconds taken to execute this block without GC time." - - ^(Smalltalk vmParameterAt: 8) + - (Smalltalk vmParameterAt: 10) + - self timeToRun - - (Smalltalk vmParameterAt: 8) - - (Smalltalk vmParameterAt: 10) -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4866-prefer-millisecondsToRun-over-timeToRun-JuanVuletich-2021Sep16-14h33m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4866] on 17 September 2021 at 10:22:21 am'! -!DisplayScreen class methodsFor: 'snapshots' stamp: 'jmv 9/17/2021 10:21:57' prior: 50608085! - setupDisplay: doGarbageCollection - " - DisplayScreen setupDisplay: true. - Display forceToScreen. - " - - self terminateScreenUpdater. - doGarbageCollection ifTrue: [ - Display setExtent: 0@0 depth: 0 bits: nil. - Smalltalk primitiveGarbageCollect. ]. - Display setExtent: self actualScreenSize depth: Display nativeDepth. - Display beDisplay. - self installScreenUpdater.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4867-just-primitiveGarbageCollect-onDisplaySetup-JuanVuletich-2021Sep17-10h21m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4866] on 17 September 2021 at 10:58:32 am'! -!PasteUpMorph methodsFor: 'misc' stamp: 'jmv 9/17/2021 10:58:19' prior: 50572278! - buildMagnifiedBackgroundImage - | image | - backgroundImageData - ifNil: [ backgroundImage _ nil ] - ifNotNil: [ - [ - backgroundImage _ nil. - Smalltalk primitiveGarbageCollect. - image _ Form fromBinaryStream: backgroundImageData readStream. - backgroundImage _ image magnifyTo: extent. - backgroundImage _ backgroundImage orderedDither32To16 asColorFormOfDepth: 8. - image _ nil. - Smalltalk primitiveGarbageCollect. - backgroundImage bits pin. - ] on: Error do: [backgroundImage := nil]. "Can happen if JPEG plugin not built" - self redrawNeeded - ]! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -self runningWorld color: (Color fromHexString: '#214A8C') lighter.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4868-disableDesktopBackground-JuanVuletich-2021Sep17-10h39m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4868] on 20 September 2021 at 3:34:52 pm'! -!Morph methodsFor: 'change reporting' stamp: 'jmv 9/20/2021 12:32:14' prior: 50567572! - invalidateDisplayRect: damageRect for: aMorph - " - If we clip submorphs, then we clip damageRect. - - aMorph is the morph that changed and therefore should be redrawn. In some cases, damage reporting is done by no longer occupying some area, and requesting whatever appropriate morph to be drawn there. In such cases, aMorph should be nil. See senders." - - | clippedRect b | - self visible ifFalse: [ ^self]. - - clippedRect _ damageRect. - aMorph == self ifFalse: [ - self clipsSubmorphsReally ifTrue: [ - b _ self displayBounds. - b ifNil: [ ^self ]. - clippedRect _ damageRect intersect: b ]]. - owner ifNotNil: [ - owner invalidateDisplayRect: clippedRect for: aMorph ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4869-Transcript-artifactsInVG-fix-JuanVuletich-2021Sep20-15h34m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4869] on 21 September 2021 at 9:53:48 am'! -!Morph methodsFor: 'geometry services' stamp: 'jmv 9/21/2021 09:31:32'! -fullOwnsOrCoversPixel: worldPoint - "Answer true if worldPoint is in some submorph, even if not inside our shape. - See comment at #ownsOrCoversPixel: for important notes on behavior." - - (self ownsOrCoversPixel: worldPoint) ifTrue: [ ^true ]. - self submorphsDo: [ :m | - (m fullOwnsOrCoversPixel: worldPoint) ifTrue: [ ^true ]]. - ^ false.! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 9/21/2021 09:50:59'! - isCloserThan: maxDistance toPixel: worldPoint - "Answer true if our closest point to aPoint is less than aNumber pixels away. - In target surface (i.e. Display) coordinates. - Uses precise testing of the morph contour if available: - Morphs not in the WidgetMorph hierarchy should answer #true to wantsContour. - Note: Considers only the external border. Any inner pixel is considered 'inside' regardless of us being transparent there. - Note: Cheaper than #coversAnyPixelCloserThan:to: . Doesn't use #bitMask. Doesn't require maintenance." - - | center contourTop contourBottom | - privateDisplayBounds ifNil: [ - ^false ]. - center _ privateDisplayBounds center. - "Quick checks: If not even within aNumber distance to display bounds, fail" - (center y - worldPoint y) abs < (privateDisplayBounds height // 2 + maxDistance) ifFalse: [ - ^false ]. - (center x - worldPoint x) abs < (privateDisplayBounds width // 2 + maxDistance) ifFalse: [ - ^false ]. - "Precise check with contour, if available" - (self valueOfProperty: #contour) ifNotNil: [ :contour | | y0 y1 x0 x1 | - contourTop _ self valueOfProperty: #contourY0. - contourBottom _ self valueOfProperty: #contourY1. - "Contour rows to consider are those within requested distance." - y0 _ worldPoint y - maxDistance max: contourTop. - y1 _ worldPoint y + maxDistance min: contourBottom. - y0 to: y1 do: [ :y | - x0 _ (contour at: (y - contourTop) * 2 + 1) - maxDistance. - x1 _ (contour at: (y - contourTop) * 2 + 2) + maxDistance. - "If a vertical line of 2*aNumber height centered on aPoint is inside the contour, quick exit" - (worldPoint x between: x0 and: x1) ifTrue: [ ^true ]. - "Check if aPoint is close enough to contour" - (x0@y - worldPoint) r < maxDistance ifTrue: [ ^true ]. - (x1@y - worldPoint) r < maxDistance ifTrue: [ ^true ]]. - "Not inside, not close enough to contour" - ^ false ]. - "If contour is not available, and aPoint is close enough to displayBounds, answer true, as it is the best we can know." - ^ true! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 9/21/2021 09:33:07'! - ownsOrCoversPixel: worldPoint - "Answer true if we own the pixel, i.e. we are the last morph drawn at worldPoint. - Some implementations (KernelMorph and WidgetMorph) may also answer true if we cover but don't own the pixel, - meaning that some other morph was drawn later, covering us. - Therefore, senders need to be aware that the answer is meaningful only when it is known that no other morph covers us. - Note: This implementation is only used for VectorGraphics based morphs (i.e. morphs that answer true to #requiresVectorCanvas). - (See other implementors) - Note: Also see #ownsPixel: and #coversPixel:" - - ^ self ownsPixel: worldPoint.! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 9/21/2021 09:12:00'! - ownsPixel: worldPoint - "Answer true if we own the pixel, i.e. we are the last morph drawn at worldPoint. - Requires VectorGraphics. - Only valid for morphs that answer true to #requiresVectorCanvas" - - self topmostWorld ifNotNil: [ :w | - w canvas ifNotNil: [ :canvas | - ^ (canvas morphIdAt: worldPoint) = self morphId ]]. - ^ false.! ! -!KernelMorph methodsFor: 'geometry services' stamp: 'jmv 9/20/2021 11:25:55'! - coversLocalPoint: aLocalPoint - "Answer true as long as aLocalPoint is inside our shape even if: - - a submorph (above us) also covers it - - a sibling that is above us or one of their submorphs also covers it." - - "If not visible, won't cover any point at all." - self visible ifFalse: [ ^false ]. - - "We know our local bounds, and completely fill them." - ^ self morphLocalBounds containsPoint: aLocalPoint! ! -!KernelMorph methodsFor: 'geometry services' stamp: 'jmv 9/21/2021 09:36:45'! - coversPixel: worldPoint - "Answer true as long as worldPoint is inside our shape even if: - - a submorph (above us) also covers it - - a sibling that is above us or one of their submorphs also covers it. - This implementation is cheap, we are a rectangular shape." - - ^ self coversLocalPoint: - (self internalizeFromWorld: worldPoint)! ! -!KernelMorph methodsFor: 'geometry services' stamp: 'jmv 9/21/2021 09:31:36' overrides: 50608350! - fullOwnsOrCoversPixel: worldPoint - "Answer true if worldPoint is in some submorph, even if not inside our shape. - See comment at #ownsOrCoversPixel: for important notes on behavior." - - (self ownsOrCoversPixel: worldPoint) ifTrue: [ ^ true ]. - self submorphsMightProtrude ifTrue: [ - self submorphsDo: [ :m | - (m fullOwnsOrCoversPixel: worldPoint) ifTrue: [ ^ true ]]]. - ^ false.! ! -!KernelMorph methodsFor: 'geometry services' stamp: 'jmv 9/21/2021 09:35:38' overrides: 50608428! - ownsOrCoversPixel: worldPoint - "Answer true if we own the pixel, i.e. we are the last morph drawn at worldPoint. - This implementation also answer true if we cover but don't own the pixel, - meaning that some other morph was drawn later, covering us. - Therefore, senders need to be aware that the answer is meaningful only when it is known that no other morph covers us. - Note: This implementation is only used for morphs with a cheap #coversPixel:. - (See other implementors) - Note: Also see #ownsPixel: and #coversPixel:" - - ^ self visible and: [self coversPixel: worldPoint].! ! -!WidgetMorph methodsFor: 'geometry services' stamp: 'jmv 9/20/2021 11:26:19'! - coversLocalPoint: aLocalPoint - "Answer true as long as aLocalPoint is inside our shape even if: - - a submorph (above us) also covers it - - a sibling that is above us or one of their submorphs also covers it." - - "If not visible, won't cover any point at all." - self visible ifFalse: [ ^false ]. - - "We know our local bounds, and completely fill them." - ^ self morphLocalBounds containsPoint: aLocalPoint! ! -!WidgetMorph methodsFor: 'geometry services' stamp: 'jmv 9/21/2021 09:36:52'! - coversPixel: worldPoint - "Answer true as long as worldPoint is inside our shape even if: - - a submorph (above us) also covers it - - a sibling that is above us or one of their submorphs also covers it. - This implementation is cheap, we are a rectangular shape." - - ^ self coversLocalPoint: - (self internalizeFromWorld: worldPoint)! ! -!WidgetMorph methodsFor: 'geometry services' stamp: 'jmv 9/21/2021 09:31:41' overrides: 50608350! - fullOwnsOrCoversPixel: worldPoint - "Answer true if worldPoint is in some submorph, even if not inside our shape. - See comment at #ownsOrCoversPixel: for important notes on behavior." - - (self ownsOrCoversPixel: worldPoint) ifTrue: [ ^ true ]. - self submorphsMightProtrude ifTrue: [ - self submorphsDo: [ :m | - (m fullOwnsOrCoversPixel: worldPoint) ifTrue: [ ^ true ]]]. - ^ false.! ! -!WidgetMorph methodsFor: 'geometry services' stamp: 'jmv 9/21/2021 09:35:48' overrides: 50608428! - ownsOrCoversPixel: worldPoint - "Answer true if we own the pixel, i.e. we are the last morph drawn at worldPoint. - This implementation also answer true if we cover but don't own the pixel, - meaning that some other morph was drawn later, covering us. - Therefore, senders need to be aware that the answer is meaningful only when it is known that no other morph covers us. - Note: This implementation is only used for morphs with a cheap #coversPixel:. - (See other implementors) - Note: Also see #ownsPixel: and #coversPixel:" - - ^ self visible and: [self coversPixel: worldPoint].! ! -!WindowEdgeAdjustingMorph methodsFor: 'geometry services' stamp: 'jmv 9/20/2021 11:30:16' overrides: 50608531! - coversLocalPoint: aLocalPoint - "We don't completely cover our bounds. Account for that." - - | sensitiveBorder | - ( self morphLocalBounds containsPoint: aLocalPoint) ifFalse: [ ^false ]. - sensitiveBorder _ owner borderWidth. - selector caseOf: { - [ #windowTopLeft: ] -> [ ^ aLocalPoint x < sensitiveBorder or: [ aLocalPoint y < sensitiveBorder ]]. - [ #windowTopRight: ] -> [ ^ extent x - aLocalPoint x <= sensitiveBorder or: [ aLocalPoint y < sensitiveBorder ]]. - [ #windowBottomLeft: ] -> [ ^ aLocalPoint x < sensitiveBorder or: [ extent y- aLocalPoint y <= sensitiveBorder ]]. - [ #windowBottomRight: ] -> [ ^ extent x - aLocalPoint x <= sensitiveBorder or: [ extent y - aLocalPoint y <= sensitiveBorder ]]. - } - otherwise: [ - "all the morph is sensitive for horizontal and vertical (i.e. non corner) instances." - ^true ]! ! -!Morph methodsFor: 'events-processing' stamp: 'jmv 9/20/2021 12:13:48' prior: 50562667! - processMouseOver: aMouseEvent localPosition: localEventPosition - "System level event handling." - self hasMouseFocus ifTrue: [ - "Got this directly through #handleFocusEvent: so check explicitly" - ((self rejectsEvent: aMouseEvent) not and: [self fullOwnsOrCoversPixel: aMouseEvent eventPosition]) ifFalse: [ - ^self ]]. - aMouseEvent hand noticeMouseOver: self event: aMouseEvent. - "Open question: should any unhandled mouse move events be filtered out? (i.e. should mouseHover:localPosition: be called when a mouse button is pressed but the morph doesn't have mouse button handlers? Essentially, what are the limits of what is considered 'hovering'?" - (self handlesMouseHover and: [aMouseEvent wasHandled not]) ifTrue: [ - self - mouseHover: aMouseEvent - localPosition: localEventPosition ].! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 9/21/2021 09:53:20' prior: 50593328! - contourIntersects: aContourArray top: aContourTop bottom: aContourBottom - "Check if contours intersect. - If contour is not available, use displayBounds. - Not to be called directly. Pefer a higher level service. See senders." - - | contour contourTop contourBottom x0Own x1Own x0Arg x1Arg | - contour _ self valueOfProperty: #contour. - contourTop _ (self valueOfProperty: #contourY0) ifNil: [aContourTop]. - contourBottom _ (self valueOfProperty: #contourY1) ifNil: [aContourBottom]. - - (contourTop max: aContourTop) to: (contourBottom min: aContourBottom) do: [ :y | - x0Own _ contour ifNil: [privateDisplayBounds left] ifNotNil: [ contour at: (y - contourTop) * 2 + 1 ]. - x1Own _ contour ifNil: [privateDisplayBounds right-1] ifNotNil: [ contour at: (y - contourTop) * 2 + 2 ]. - x0Arg _ aContourArray at: (y - aContourTop) * 2 + 1. - x1Arg _ aContourArray at: (y - aContourTop) * 2 + 2. - (x0Own <= x1Arg and: [ x0Arg <= x1Own ]) - ifTrue: [ ^true ]]. - - ^false! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 9/21/2021 09:51:06'! - coversAnyPixelCloserThan: maxDistance to: worldPoint - "Answer true if our closest point to worldPoint is less than aNumber pixels away. - In target surface (i.e. Display) coordinates. - See #bitMask. - Remember to do - self removeProperty: #bitMask. - when appropriate!! (i.e. when we change in such a way to make the bitMask invalid). - - Note: Requires VectorGraphics. Meant to be used only when needed. - Note: Prefer #isCloserThan:toPixel:, that doesn't use #bitMask, and doesn't require maintenance." - - | center maxDistanceSquared | - privateDisplayBounds ifNil: [ - ^false ]. - center _ privateDisplayBounds center. - "Quick checks: If not even within aNumber distance to display bounds, fail" - (center y - worldPoint y) abs < (privateDisplayBounds height // 2 + maxDistance) ifFalse: [ - ^false ]. - (center x - worldPoint x) abs < (privateDisplayBounds width // 2 + maxDistance) ifFalse: [ - ^false ]. - "Precise check with bitMask" - (self coversPixel: worldPoint) ifTrue: [ ^true ]. - maxDistanceSquared _ maxDistance squared. - maxDistance negated to: maxDistance do: [ :dy | - maxDistance negated to: maxDistance do: [ :dx | - dx squared + dy squared <= maxDistanceSquared ifTrue: [ - (self coversPixel: worldPoint + (dx@dy)) ifTrue: [ ^true ]]]]. - ^false.! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 9/21/2021 09:38:06'! - coversPixel: worldPoint - "Answer true if pixel worldPoint is covered by us, even if we are not visible a it because of some - other morph above us also covers it. - See #bitMask. - Remember to do - self removeProperty: #bitMask. - when appropriate!! (i.e. when we change in such a way to make the bitMask invalid). - - Note: Subclasses such as KernelMorph and WidgetMorph redefine this method with an optimized - implementation that doesn't require computing and invalidating the #bitMask. Senders in the base image - and framework actually only use this optimized implementation. That's why general morphs don't care about - invalidting #bitMask. - - Note: If your morph #requiresVectorCanvas, and depends on this general implementation, remember to - `removeProperty: #bitMask` whenever it becomes invalid due to changes in your morphs. You may consider - using #ownsPixel: if appropriate, that doesn't require any maintenance and is cheaper (in cpu and memory). - - Note: This implementation requires VectorGraphics." - - self visible ifTrue: [ - ^(self bitMask pixelValueAt: worldPoint - self displayFullBounds topLeft) = 1 ]. - ^ false! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 9/20/2021 12:13:54' prior: 50567110! - transferHalo: event from: formerHaloOwner - "Progressively transfer the halo to the next likely recipient" - - formerHaloOwner == self - ifFalse: [ - self addHalo: event. - ^self ]. - - event shiftPressed ifTrue: [ - "Pass it outwards" - owner ifNotNil: [ - owner transferHalo: event from: formerHaloOwner. - ^self ]. - "We're at the top level; just keep it on ourselves" - ^self ]. - - self submorphsDo: [ :m | - (m wantsHalo and: [ m fullOwnsOrCoversPixel: event eventPosition ]) - ifTrue: [ - m transferHalo: event from: formerHaloOwner. - ^self ]]. - "We're at the bottom most level; just keep halo on ourselves"! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 9/20/2021 11:32:25' prior: 50562477! - doRecolor: event with: aHandle - "The mouse went down in the 'recolor' halo handle. Allow the user to change the color of the innerTarget" - - event hand obtainHalo: self. - (aHandle coversPixel: event eventPosition) - ifFalse: [ "only do it if mouse still in handle on mouse up" - self delete. - target addHalo: event] - ifTrue: [ - target changeColor]! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 9/20/2021 11:32:30' prior: 50567233! - maybeCollapse: event with: aHandle - "Ask hand to collapse my target if mouse comes up in it." - - event hand obtainHalo: self. - (aHandle coversPixel: event eventPosition) - ifTrue: [ - target collapse ]. - self delete.! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 9/20/2021 11:32:34' prior: 50562502! - maybeDismiss: event with: aHandle - "Ask hand to dismiss my target if mouse comes up in it." - - event hand obtainHalo: self. - (aHandle coversPixel: event eventPosition) - ifFalse: [ - self delete. - target addHalo: event] - ifTrue: [ - target resistsRemoval ifTrue: [ - (PopUpMenu - confirm: 'Really throw this away' - trueChoice: 'Yes' - falseChoice: 'Um, no, let me reconsider') ifFalse: [^ self]]. - - self delete. - target dismissViaHalo]! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 9/20/2021 11:32:38' prior: 50562520! - setDismissColor: event with: aHandle - "Called on mouseStillDown in the dismiss handle; set the color appropriately." - - | colorToUse | - event hand obtainHalo: self. - colorToUse _ (aHandle coversPixel: event eventPosition) - ifFalse: [ `Color red muchLighter` ] - ifTrue: [ `Color lightGray` ]. - aHandle color: colorToUse! ! -!MenuItemMorph methodsFor: 'events' stamp: 'jmv 9/20/2021 11:32:44' prior: 50562564! - activateOwnerMenu: evt - "Activate our owner menu; e.g., pass control to it" - owner ifNil: [ ^false ]. "not applicable" - (owner coversPixel: evt eventPosition) - ifFalse: [ ^false ]. - owner activate: evt. - ^true! ! -!MenuItemMorph methodsFor: 'events' stamp: 'jmv 9/20/2021 11:32:47' prior: 50565627! - activateSubmenu: event - "Activate our submenu; e.g., pass control to it" - - subMenu ifNil: [ ^false ]. "not applicable" - subMenu isInWorld ifFalse: [ ^false ]. - (subMenu coversPixel: event eventPosition) ifFalse: [^false]. - subMenu activate: event. - ^true! ! -!PluggableButtonMorph methodsFor: 'events' stamp: 'jmv 9/20/2021 11:32:53' prior: 50562585 overrides: 16874556! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - - isPressed _ false. - mouseIsOver _ false. - (actWhen == #buttonUp and: [ - self coversPixel: aMouseButtonEvent eventPosition ]) - ifTrue: [ self performAction ]. - self redrawNeeded! ! -!MenuMorph methodsFor: 'events' stamp: 'jmv 9/20/2021 11:36:05' prior: 50574679 overrides: 16874541! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - "Handle a mouse down event." - (stayUp or: [ self coversPixel: aMouseButtonEvent eventPosition ]) - ifFalse: [ - self deleteIfPopUp: aMouseButtonEvent. - self activeHand - newKeyboardFocus: prevKbdFocus; - newMouseFocus: prevMouseFocus. - ^ self ]. "click outside" - - "Grab the menu and drag it to some other place - This is reimplemented here because we handle the event, and if the following lines are commented, a menu can't be grabbed with the hand. This is not nice and shouldn't be needed" - self isSticky ifTrue: [ ^self ]. - aMouseButtonEvent hand grabMorph: self.! ! -!MenuMorph methodsFor: 'events' stamp: 'jmv 9/20/2021 11:36:32' prior: 50574703 overrides: 16874556! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - "Handle a mouse up event. - Note: This might be sent from a modal shell." - (self coversPixel: aMouseButtonEvent eventPosition) ifFalse:[ - "Mouse up outside. Release eventual focus and delete if pop up." - aMouseButtonEvent hand ifNotNil: [ :h | h releaseMouseFocus: self ]. - self deleteIfPopUp: aMouseButtonEvent. - self activeHand - newKeyboardFocus: prevKbdFocus; - newMouseFocus: prevMouseFocus. - ^ self]. - stayUp ifFalse: [ - "Still in pop-up transition; keep focus" - aMouseButtonEvent hand newMouseFocus: self ].! ! -!AutoCompleterMorph methodsFor: 'events' stamp: 'jmv 9/20/2021 11:32:58' prior: 50562597 overrides: 16874556! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - - (self coversPixel: aMouseButtonEvent eventPosition) - ifTrue: [ - ((self upButtonPosition extent: ScrollBar scrollbarThickness) containsPoint: localEventPosition) - ifTrue: [ ^self stillActive; goUp ]. - ((self downButtonPosition extent: ScrollBar scrollbarThickness) containsPoint: localEventPosition) - ifTrue: [ ^self stillActive; goDown ]. - self selected: (localEventPosition y // self itemHeight) + self firstVisible. - completer insertSelected ] - ifFalse: [ self delete. completer menuClosed ]! ! -!MorphicEvent methodsFor: 'dispatching' stamp: 'jmv 9/20/2021 12:14:09' prior: 50563868! - dispatchWith: aMorph - "Dispatch me. The event will be passed to the front-most visible submorph that contains the position wrt. to the event." - | handledByInner | - - "Try to get out quickly" - (aMorph fullOwnsOrCoversPixel: self eventPosition) - ifFalse: [ ^#rejected ]. - - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - (eachChild dispatchEvent: self) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - - "Check for being inside the receiver" - (handledByInner or: [ (aMorph rejectsEvent: self) not and: [aMorph fullOwnsOrCoversPixel: self eventPosition] ]) - ifTrue: [ ^ self sendEventTo: aMorph ]. - - ^ #rejected! ! -!DropEvent methodsFor: 'dispatching' stamp: 'jmv 9/20/2021 12:14:16' prior: 50563896 overrides: 50608949! - dispatchWith: aMorph - "Drop is done on the innermost target that accepts it." - | dropped | - - "Try to get out quickly" - (aMorph fullOwnsOrCoversPixel: position) - ifFalse: [ ^#rejected ]. - - "Go looking if any of our submorphs wants it" - aMorph submorphsDo: [ :eachChild | - (eachChild dispatchEvent: self) == #rejected ifFalse: [ - ^self ]]. - - (aMorph allowsMorphDrop and: [ (aMorph rejectsEvent: self) not and: [aMorph fullOwnsOrCoversPixel: position] ]) - ifTrue: [ - "Do a symmetric check if both morphs like each other" - dropped _ self contents. - ((aMorph wantsDroppedMorph: dropped event: self) "I want her" - and: [dropped wantsToBeDroppedInto: aMorph]) "she wants me" - ifTrue: [ - ^ self sendEventTo: aMorph ]]. - ^#rejected! ! -!DropFilesEvent methodsFor: 'dispatching' stamp: 'jmv 9/20/2021 12:14:23' prior: 50563923 overrides: 50608949! - dispatchWith: aMorph - "Drop is done on the innermost target that accepts it." - - "Try to get out quickly" - (aMorph fullOwnsOrCoversPixel: position) ifFalse: [ ^#rejected ]. - - "Go looking if any of our submorphs wants it" - aMorph submorphsDo: [ :eachChild | - (eachChild dispatchEvent: self) == #rejected ifFalse: [ ^self ]]. - - (aMorph allowsFilesDrop and: [ (aMorph rejectsEvent: self) not and: [aMorph fullOwnsOrCoversPixel: position] ]) - ifTrue: [^ self sendEventTo: aMorph ]. - - ^#rejected! ! -!KeyboardEvent methodsFor: 'actions' stamp: 'jmv 9/20/2021 11:33:02' prior: 50562828! - closeCurrentWindowOf: aMorph - - aMorph owningWindow ifNotNil: [ :w | - (w coversPixel: position) - ifTrue: [ w delete ] ].! ! -!MouseButtonEvent methodsFor: 'dispatching' stamp: 'jmv 9/20/2021 12:14:44' prior: 50563942 overrides: 50608949! - dispatchWith: aMorph - "Find the appropriate receiver for the event and let it handle it. Default rules: - * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. - * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. - * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. - * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. - " - | aMorphHandlesIt grabAMorph handledByInner | - "Only for MouseDown" - self isMouseDown ifFalse: [ - ^super dispatchWith: aMorph ]. - - "Try to get out quickly" - (aMorph fullOwnsOrCoversPixel: position) - ifFalse: [ ^#rejected ]. - - "Install the prospective handler for the receiver" - aMorphHandlesIt _ false. - grabAMorph _ false. - self mouseButton3Pressed - ifTrue: [ - (eventHandler isNil or: [ eventHandler isWorldMorph or: [ - self shiftPressed or: [ aMorph is: #HaloMorph ]]]) - ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]] - ifFalse: [ - (aMorph handlesMouseDown: self) ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]. - "If button 1, and both aMorph and the owner allows grabbing with the hand (to initiate drag & drop), so be it." - self mouseButton1Pressed ifTrue: [ - aMorph owner ifNotNil: [ :o | - (o allowsSubmorphDrag and: [ aMorph isSticky not ]) ifTrue: [ - grabAMorph _ true ]]]]. - - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - (eachChild dispatchEvent: self) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - - (handledByInner or: [ (aMorph rejectsEvent: self) not and: [aMorph fullOwnsOrCoversPixel: position] ]) ifTrue: [ - "aMorph is in the top-most unlocked, visible morph in the chain." - aMorphHandlesIt - ifTrue: [ ^self sendEventTo: aMorph ] - ifFalse: [ - (grabAMorph and: [ handledByInner not ]) ifTrue: [ - self hand - waitForClicksOrDrag: aMorph event: self - dragSel: (Preferences clickGrabsMorphs ifFalse: [#dragEvent:localPosition:]) - clkSel: (Preferences clickGrabsMorphs ifTrue: [#dragEvent:localPosition:]). - "false ifTrue: [ self hand grabMorph: aMorph ]." - Preferences clickGrabsMorphs ifFalse: [aMorph activateWindow]. - self wasHandled: true. - ^self ]]]. - - handledByInner ifTrue: [ ^self ]. - "Mouse was not on aMorph nor any of its children" - ^ #rejected! ! -!MouseScrollEvent methodsFor: 'dispatching' stamp: 'jmv 9/20/2021 12:14:35' prior: 50598417 overrides: 50608949! - dispatchWith: aMorph - "Find the appropriate receiver for the event and let it handle it. Default rules: - * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. - * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. - * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. - * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. - " - "Try to get out quickly" - | aMorphHandlesIt handledByInner | - "FIXME - this works in all tested cases but one: when the window directly under the mouse doesn't have keyboard focus (i.e. a Transcript window)" - aMorph fullOwnsOrCoversPixel: position :: ifFalse: [ ^ #rejected ]. - "Install the prospective handler for the receiver" - aMorphHandlesIt _ false. - (aMorph handlesMouseScroll: self) ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]. - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - (eachChild dispatchEvent: self) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - (handledByInner or: [ - (aMorph rejectsEvent: self) not and: [aMorph fullOwnsOrCoversPixel: position]]) ifTrue: [ - "aMorph is in the top-most unlocked, visible morph in the chain." - aMorphHandlesIt ifTrue: [ ^ self sendEventTo: aMorph ]]. - handledByInner ifTrue: [ ^ self ]. - "Mouse was not on aMorph nor any of its children" - ^ #rejected.! ! - -BitBltCanvas removeSelector: #morph:isAtPoint:! - -!methodRemoval: BitBltCanvas #morph:isAtPoint: stamp: 'Install-4870-Morphic-Geometry-Tweaks-JuanVuletich-2021Sep21-08h34m-jmv.002.cs.st 9/21/2021 12:54:09'! -morph: aMorph isAtPoint: aPoint - - aMorph basicDisplayBounds ifNotNil: [ :r | - (r containsPoint: aPoint) ifFalse: [ - ^false ]]. - "Give morphs with a non-rectangular shape (corner WindowEdgeAdjustingMorphs) - a chance to have a say." - ^ aMorph morphContainsPoint: - (aMorph internalizeFromWorld: aPoint)! - -WindowEdgeAdjustingMorph removeSelector: #morphContainsPoint:! - -!methodRemoval: WindowEdgeAdjustingMorph #morphContainsPoint: stamp: 'Install-4870-Morphic-Geometry-Tweaks-JuanVuletich-2021Sep21-08h34m-jmv.002.cs.st 9/21/2021 12:54:09'! -morphContainsPoint: aLocalPoint - | sensitiveBorder | - ( self morphLocalBounds containsPoint: aLocalPoint) ifFalse: [ ^false ]. - sensitiveBorder _ owner borderWidth. - selector caseOf: { - [ #windowTopLeft: ] -> [ ^ aLocalPoint x < sensitiveBorder or: [ aLocalPoint y < sensitiveBorder ]]. - [ #windowTopRight: ] -> [ ^ extent x - aLocalPoint x <= sensitiveBorder or: [ aLocalPoint y < sensitiveBorder ]]. - [ #windowBottomLeft: ] -> [ ^ aLocalPoint x < sensitiveBorder or: [ extent y- aLocalPoint y <= sensitiveBorder ]]. - [ #windowBottomRight: ] -> [ ^ extent x - aLocalPoint x <= sensitiveBorder or: [ extent y - aLocalPoint y <= sensitiveBorder ]]. - } - otherwise: [ - "all the morph is sensitive for horizontal and vertical (i.e. non corner) instances." - ^true ]! - -WidgetMorph removeSelector: #morphContainsPoint:! - -!methodRemoval: WidgetMorph #morphContainsPoint: stamp: 'Install-4870-Morphic-Geometry-Tweaks-JuanVuletich-2021Sep21-08h34m-jmv.002.cs.st 9/21/2021 12:54:09'! -morphContainsPoint: aLocalPoint - "Answer true even if aLocalPoint is in a submorph in front of us, as long as it is inside our shape." - - "If not visible, won't contain any point at all." - self visible ifFalse: [ ^false ]. - - "We know our local bounds, and completely fill them." - ^ self morphLocalBounds containsPoint: aLocalPoint! - -HaloMorph removeSelector: #containsGlobalPoint:! - -!methodRemoval: HaloMorph #containsGlobalPoint: stamp: 'Install-4870-Morphic-Geometry-Tweaks-JuanVuletich-2021Sep21-08h34m-jmv.002.cs.st 9/21/2021 12:54:09'! -containsGlobalPoint: worldPoint - - self visible ifTrue: [ - self topmostWorld ifNotNil: [ :w | - ^self morphLocalBounds containsPoint: - (self internalizeFromWorld: worldPoint) ]]. - ^ false! - -KernelMorph removeSelector: #morphContainsPoint:! - -!methodRemoval: KernelMorph #morphContainsPoint: stamp: 'Install-4870-Morphic-Geometry-Tweaks-JuanVuletich-2021Sep21-08h34m-jmv.002.cs.st 9/21/2021 12:54:09'! -morphContainsPoint: aLocalPoint - "Answer true even if aLocalPoint is in a submorph in front of us, as long as it is inside our shape." - - "If not visible, won't contain any point at all." - self visible ifFalse: [ ^false ]. - - "We know our local bounds, and completely fill them." - ^ self morphLocalBounds containsPoint: aLocalPoint! - -Morph removeSelector: #containsGlobalPoint:! - -!methodRemoval: Morph #containsGlobalPoint: stamp: 'Install-4870-Morphic-Geometry-Tweaks-JuanVuletich-2021Sep21-08h34m-jmv.002.cs.st 9/21/2021 12:54:09'! -containsGlobalPoint: worldPoint - "Answer true if pixel worldPoint is covered by us, and we are visible a it. - No other morph above us also covers it." - - self visible ifTrue: [ - self topmostWorld ifNotNil: [ :w | - w canvas ifNotNil: [ :canvas | - ^ canvas morph: self isAtPoint: worldPoint ]]]. - ^ false! - -Morph removeSelector: #isCloserThan:to:! - -Morph removeSelector: #fullContainsGlobalPoint:! - -!methodRemoval: Morph #fullContainsGlobalPoint: stamp: 'Install-4870-Morphic-Geometry-Tweaks-JuanVuletich-2021Sep21-08h34m-jmv.002.cs.st 9/21/2021 12:54:09'! -fullContainsGlobalPoint: worldPoint - "Answer true if worldPoint is in some submorph, even if not inside our shape." - - self visible ifTrue: [ - self topmostWorld ifNotNil: [ :w | - (self containsGlobalPoint: worldPoint) ifTrue: [ ^ true ]. - self submorphsDo: [ :m | - (m fullContainsGlobalPoint: worldPoint) ifTrue: [ ^ true ]]]]. - ^ false! - -Morph removeSelector: #isCloserThan:toPoint:! - -!methodRemoval: Morph #isCloserThan:toPoint: stamp: 'Install-4870-Morphic-Geometry-Tweaks-JuanVuletich-2021Sep21-08h34m-jmv.002.cs.st 9/21/2021 12:54:09'! -isCloserThan: aNumber toPoint: aPoint - "Answer true if our closest point to aPoint is less than aNumber pixels away. - In target surface (i.e. Display) coordinates. - Uses precise testing of the morph contour if available. See #knowsContour." - - | center contourTop contourBottom | - privateDisplayBounds ifNil: [ - ^false ]. - center _ privateDisplayBounds center. - "Quick checks: If not even within aNumber distance to display bounds, fail" - (center y - aPoint y) abs < (privateDisplayBounds height // 2 + aNumber) ifFalse: [ - ^false ]. - (center x - aPoint x) abs < (privateDisplayBounds width // 2 + aNumber) ifFalse: [ - ^false ]. - "Precise check with contour, if available" - (self valueOfProperty: #contour) ifNotNil: [ :contour | | y0 y1 x0 x1 | - contourTop _ self valueOfProperty: #contourY0. - contourBottom _ self valueOfProperty: #contourY1. - "Contour rows to consider are those within requested distance." - y0 _ aPoint y - aNumber max: contourTop. - y1 _ aPoint y + aNumber min: contourBottom. - y0 to: y1 do: [ :y | - x0 _ (contour at: (y - contourTop) * 2 + 1) - aNumber. - x1 _ (contour at: (y - contourTop) * 2 + 2) + aNumber. - "If a vertical line of 2*aNumber height centered on aPoint is inside the contour, quick exit" - (aPoint x between: x0 and: x1) ifTrue: [ ^true ]. - "Check if aPoint is close enough to contour" - (x0@y - aPoint) r < aNumber ifTrue: [ ^true ]. - (x1@y - aPoint) r < aNumber ifTrue: [ ^true ]]. - "Not inside, not close enough to contour" - ^ false ]. - "If contour is not available, and aPoint is close enough to displayBounds, answer true, as it is the best we can know." - ^ true! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4870-Morphic-Geometry-Tweaks-JuanVuletich-2021Sep21-08h34m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4870] on 21 September 2021 at 10:47:45 am'! -!KernelMorph methodsFor: 'drawing' stamp: 'jmv 9/21/2021 10:47:14' overrides: 50607548! - imageForm: extentOrNil depth: depth - - | answerExtent answer auxCanvas | - self requiresVectorCanvas ifFalse: [ - answerExtent _ extent. - extentOrNil ifNotNil: [ answerExtent _ answerExtent min: extentOrNil * 4 ]. - auxCanvas _ BitBltCanvas depth: depth over: (self morphPosition floor extent: answerExtent ceiling). - auxCanvas fullDraw: self. - answer _ auxCanvas form divideByAlpha. - extentOrNil ifNotNil: [ answer _ answer magnifyTo: extentOrNil ]. - ^answer ]. - ^super imageForm: extentOrNil depth: depth.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4871-imageFormdepth-KernelMorph-JuanVuletich-2021Sep21-10h46m-jmv.001.cs.st----! - -----QUIT----(21 September 2021 12:54:16) Cuis5.0-4871-32.image priorSource: 8743091! - -----STARTUP---- (24 September 2021 10:39:50) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4871-32.image! - - -'From Cuis 5.0 [latest update: #4862] on 21 September 2021 at 5:57:37 pm'! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 9/21/2021 17:50:48' overrides: 50556363! - extentChanged: oldExtent - "Our extent changed. Must layout submorphs again." - - super extentChanged: oldExtent. - taskbar ifNotNil: [ taskbar screenSizeChanged ].! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 9/21/2021 17:53:08' prior: 50603678! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag - "This is the main method for image save and / or quit. - See senders." - "WARNING: Current process will be killed. UI Process will be restarted" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic - checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " - | activeProc | - activeProc _ Processor activeProcess. - [ | isARealStartup guiRootObject guiRootObjectClass | - save not & quit - ifTrue: [ - (SourceFiles at: 2) ifNotNil: [ :changes | - ChangesInitialFileSize ifNotNil: [ changes truncate: ChangesInitialFileSize ]]] - ifFalse: [ - self - logSnapshot: save - andQuit: quit ]. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | - each isInWorld ifTrue: [ - each delete.]]. - UISupervisor ui tearDownDesktop. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - "Cosas que levanto explicitamente abajo" - guiRootObjectClass _ UISupervisor ui class. - guiRootObject _ UISupervisor ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "guiRootObject _ clearAllStateFlag ifFalse: [ UISupervisor ui ]." - UISupervisor stopUIProcess. - activeProc isTerminated ifFalse: [ activeProc terminate ]. - guiRootObject ifNotNil: [ guiRootObject releaseCachedState ]. - "Clean Globals" - Smalltalk - at: #Sensor - put: nil. - Smalltalk - at: #Display - put: nil. - Smalltalk closeSourceFiles. - Smalltalk - at: #SourceFiles - put: nil. - Smalltalk allClassesDo: [ :cls | - cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | - cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ - Smalltalk printStuffToCleanOnImageSave. - "Remove this call to actually see the image clean report." - Transcript clear. - ]. - "Do image save & quit as apropriate" - (Cursor cursorAt: #writeCursor) activateCursor. - save - ifTrue: [ - "The snapshot primitive answers false if it was just called to do the snapshot. - But image startup is resumed by returning (again) from the primitive, but this time answering true." - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk - at: #Sensor - put: nil. - Smalltalk - at: #Display - put: DisplayScreen new. - Smalltalk - at: #SourceFiles - put: (Array new: 2). - Smalltalk openSourceFiles. - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | - cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - UISupervisor spawnNewMorphicProcessFor: (guiRootObject ifNil: [ guiRootObject _ guiRootObjectClass newWorld ]). - self restoreLostChangesIfNecessary. - clearAllStateFlag ifTrue: [ - UISupervisor whenUIinSafeState: [ - guiRootObject recreateDefaultDesktop; restoreDisplay ]] - ifFalse: [ - UISupervisor whenUIinSafeState: [ - guiRootObject restoreDisplay ]]. - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - UISupervisor whenUIinSafeState: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]] - forkAt: Processor timingPriority - 1 - named: 'Startup process'.! ! -!DisplayScreen methodsFor: 'private' stamp: 'jmv 9/21/2021 17:53:28' prior: 50604366 overrides: 16848801! - setExtent: aPoint depth: bitsPerPixel - "DisplayScreen startUp" - "This method is critical. If the setExtent fails, there will be no - proper display on which to show the error condition." - - | bitsPerPixelToUse | - (depth = bitsPerPixel and: [aPoint = self extent and: [ - self supportsDisplayDepth: bitsPerPixel]]) ifFalse: [ - bits _ nil. "Free up old bitmap in case space is low" - bitsPerPixelToUse _ (self supportsDisplayDepth: bitsPerPixel) - ifTrue: [ bitsPerPixel ] - ifFalse: [ - (self supportsDisplayDepth: bitsPerPixel negated) - ifTrue: [ bitsPerPixel negated ] - ifFalse: [ self findAnyDisplayDepth ]]. - super setExtent: aPoint depth: bitsPerPixelToUse. - ].! ! -!TaskbarMorph methodsFor: 'events' stamp: 'jmv 9/21/2021 17:50:39' prior: 50379892! - screenSizeChanged - "Respond to change in screen size by repositioning self to bottom of screen" - -" Transcript newLine; print: 'Taskbar screenSizeChanged'. -" - | y e | - self world ifNotNil: [ :w | - y _ w morphExtent y - self defaultHeight. - e _ (self internalizeDistance: w morphExtent x @ self defaultHeight) asIntegerPoint. - self morphPosition: 0@y extent: e ].! ! -!TaskbarMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 9/21/2021 17:55:51' prior: 50337304 overrides: 50574156! - delete - - | w | - self restoreAll. - super delete. - w _ self world ifNil: [ self runningWorld ]. - w ifNotNil: [ w taskbarDeleted ]! ! -!TaskbarMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 9/21/2021 17:52:27' prior: 50594381 overrides: 16876712! - noteNewOwner: aMorph - "I have just been added as a submorph of aMorph" - - super noteNewOwner: aMorph. - aMorph submorphsDo: [ :subMorph | - self refreshTaskbarFor: aMorph ].! ! - -TaskbarMorph class removeSelector: #releaseClassCachedState! - -TaskbarMorph class removeSelector: #initClassCachedState! - -!methodRemoval: TaskbarMorph class #initClassCachedState stamp: 'Install-4872-Taskbar-fixesAndCleanup-JuanVuletich-2021Sep21-17h40m-jmv.001.cs.st 9/24/2021 10:39:54'! -initClassCachedState - - "Should use some other way to find relevant instances" - self flag: #jmvVer2. - self allInstancesDo: [ :each | - each notifyDisplayResize ]! - -TaskbarMorph removeSelector: #notifyDisplayResize! - -!methodRemoval: TaskbarMorph #notifyDisplayResize stamp: 'Install-4872-Taskbar-fixesAndCleanup-JuanVuletich-2021Sep21-17h40m-jmv.001.cs.st 9/24/2021 10:39:54'! -notifyDisplayResize - Display - when: #screenSizeChanged - send: #screenSizeChanged - to: self. - self screenSizeChanged! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -TaskbarMorph allInstancesDo: [ :each | - Display removeActionsWithReceiver: each ].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4872-Taskbar-fixesAndCleanup-JuanVuletich-2021Sep21-17h40m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4871] on 22 September 2021 at 9:35:25 am'! -!DisplayScreen methodsFor: 'other' stamp: 'jmv 4/1/2013 20:12' prior: 50608099! - forceToScreen: aRectangle - "Force the given rectangular section of the Display to be copied to the screen. The primitive call does nothing if the primitive is not implemented. Used when the deferUpdates flag in the virtual machine is on; see #deferUpdates:." - - self primShowRectLeft: aRectangle left - right: aRectangle right - top: aRectangle top - bottom: aRectangle bottom. -! ! -!DisplayScreen class methodsFor: 'screen update' stamp: 'jmv 9/22/2021 09:31:18' prior: 50571555! - screenUpdater - | delay | - delay _ Delay forMilliseconds: 50. - ScreenUpdaterSemaphore _ Semaphore new. - Damage _ nil. - [ - delay wait. - ScreenUpdaterSemaphore wait. - DisplayScreen isDisplayExtentOk ifTrue: [ - Display forceToScreen: Damage. - ScreenUpdaterSemaphore initSignals. - Damage _ nil ]. - ] repeat! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - DisplayScreen installScreenUpdater! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4873-screenUpdater-fix-JuanVuletich-2021Sep22-09h31m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4871] on 22 September 2021 at 9:39:51 am'! -!DisplayScreen class methodsFor: 'snapshots' stamp: 'jmv 9/22/2021 09:37:38'! - setupDisplay - " - DisplayScreen setupDisplay. - Display forceToScreen. - " - - self terminateScreenUpdater. - Display setExtent: self actualScreenSize depth: Display nativeDepth. - Display beDisplay. - self installScreenUpdater.! ! -!DisplayScreen class methodsFor: 'snapshots' stamp: 'jmv 9/22/2021 09:37:45' prior: 50608139 overrides: 50335344! - startUp - " - DisplayScreen startUp. - Display forceToScreen. - " - self setupDisplay.! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 9/22/2021 09:38:22' prior: 50608145! - checkForNewScreenSize - "Check whether the screen size has changed and if so take appropriate actions" - - DisplayScreen isDisplayExtentOk ifFalse: [ - "Minimize the risk of going out of memory: - - First clear existing canvas, to free the memory it uses. - - Then, setup the display. - - Then set up new canvas." - self clearCanvas. - DisplayScreen setupDisplay. - self setMainCanvas. - self whenUIinSafeState: [ Cursor defaultCursor activateCursor ]].! ! - -DisplayScreen class removeSelector: #setupDisplay:! - -!methodRemoval: DisplayScreen class #setupDisplay: stamp: 'Install-4874-setupDisplay-removeSuperfluousPedantry-JuanVuletich-2021Sep22-09h35m-jmv.001.cs.st 9/24/2021 10:39:54'! -setupDisplay: doGarbageCollection - " - DisplayScreen setupDisplay: true. - Display forceToScreen. - " - - self terminateScreenUpdater. - doGarbageCollection ifTrue: [ - Display setExtent: 0@0 depth: 0 bits: nil. - Smalltalk primitiveGarbageCollect. ]. - Display setExtent: self actualScreenSize depth: Display nativeDepth. - Display beDisplay. - self installScreenUpdater.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4874-setupDisplay-removeSuperfluousPedantry-JuanVuletich-2021Sep22-09h35m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4874] on 22 September 2021 at 3:03:14 pm'! -!TaskbarMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 9/22/2021 15:02:43' prior: 50609612 overrides: 16876712! - noteNewOwner: aMorph - "I have just been added as a submorph of aMorph" - - super noteNewOwner: aMorph. - aMorph submorphsDo: [ :subMorph | - self refreshTaskbarFor: subMorph ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4875-Taskbar-fix-JuanVuletich-2021Sep22-15h02m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4875] on 22 September 2021 at 3:09:47 pm'! -!TaskbarMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 9/22/2021 15:09:15' prior: 50609771 overrides: 16876712! - noteNewOwner: aMorph - "I have just been added as a submorph of aMorph" - - super noteNewOwner: aMorph. - aMorph submorphsDo: [ :subMorph | - self refreshTaskbarFor: subMorph ]. - self screenSizeChanged.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4876-Taskbar-fix-JuanVuletich-2021Sep22-15h09m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4876] on 22 September 2021 at 4:08:55 pm'! -!Theme methodsFor: 'colors' stamp: 'jmv 9/22/2021 16:08:06' prior: 50388779! - background - - "^ `Color r: 0.7 g: 0.72 b: 0.83`." - ^ `Color r: 0.167 g: 0.344 b: 0.629`! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -self runningWorld color: Theme current background.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4877-defaultBackgroundColor-JuanVuletich-2021Sep22-16h07m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4877] on 22 September 2021 at 4:22:12 pm'! -!MessageSetWindow class methodsFor: 'opening' stamp: 'jmv 9/22/2021 16:20:42'! - openMessageListUnsorted: methodReferences label: labelString - "Open a system view for a MessageSet on messageList. - Don't sort entries by default." - - | messageSet | - - messageSet _ MessageSet messageList: methodReferences asArray. - - ^self open: messageSet label: labelString ! ! -!ChangeListWindow methodsFor: 'menu commands' stamp: 'jmv 9/22/2021 16:20:50' prior: 16797146! - browseCurrentVersionsOfSelections - "Opens a message-list browser on the current in-memory versions of all methods that are currently seleted" - | aList | - - aList _ model currentVersionsOfSelections. - - aList size = 0 ifTrue: [^ self inform: 'no selected methods have in-memory counterparts']. - MessageSetWindow - openMessageListUnsorted: aList - label: 'Current versions of selected methods in ', model file localName! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4878-browseCurrentVersions-unsortedByDefault-JuanVuletich-2021Sep22-16h20m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4876] on 22 September 2021 at 9:15:23 pm'! - -ChangeSelector subclass: #AddParameter - instanceVariableNames: 'newParameter newParameterValue implementorTrailingString senderTrailingString index isAddingLast' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #AddParameter category: #'Tools-Refactoring' stamp: 'Install-4879-ExtractAsParameter-HernanWilkinson-2021Sep22-15h23m-HAW.001.cs.st 9/24/2021 10:39:55'! -ChangeSelector subclass: #AddParameter - instanceVariableNames: 'newParameter newParameterValue implementorTrailingString senderTrailingString index isAddingLast' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Refactoring subclass: #ExtractAsParameter - instanceVariableNames: 'intervalToExtract sourceMethod addParameter intervalToReplace' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractAsParameter category: #'Tools-Refactoring' stamp: 'Install-4879-ExtractAsParameter-HernanWilkinson-2021Sep22-15h23m-HAW.001.cs.st 9/24/2021 10:39:55'! -Refactoring subclass: #ExtractAsParameter - instanceVariableNames: 'intervalToExtract sourceMethod addParameter intervalToReplace' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -AddParameterApplier subclass: #ExtractAsParameterApplier - instanceVariableNames: 'interval' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractAsParameterApplier category: #'Tools-Refactoring' stamp: 'Install-4879-ExtractAsParameter-HernanWilkinson-2021Sep22-15h23m-HAW.001.cs.st 9/24/2021 10:39:55'! -AddParameterApplier subclass: #ExtractAsParameterApplier - instanceVariableNames: 'interval' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!SmalltalkEditor methodsFor: 'contextual add/remove parameter' stamp: 'HAW 9/22/2021 20:24:46'! - contextualExtractAsParameter - - self isEditingClassDefinition - ifTrue: [ morph flash ] - ifFalse: [ self ifSourceCodeRefactoringCanBeAppliedDo: [ self extractAsParameter ]]! ! -!SmalltalkEditor methodsFor: 'contextual add/remove parameter' stamp: 'HAW 9/22/2021 16:36:12'! - contextualExtractAsParameter: aKeyboardEvent - - self contextualExtractAsParameter. - ^true! ! -!SmalltalkEditor methodsFor: 'contextual add/remove parameter' stamp: 'HAW 9/22/2021 20:24:56'! - extractAsParameter - - ^ RefactoringApplier extractAsParameterApplier createAndValueHandlingExceptions: [ - RefactoringApplier extractAsParameterApplier - from: self selectionInterval - on: model textProvider - for: self codeProvider selectedMessageName - in: self selectedClassOrMetaClassOrUndefinedObject ]! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 9/22/2021 19:41:21'! - selectedClassOrMetaClassOrUndefinedObject - - "I have to do this because some codeProviders do not answer selectedClassOrMetaClass like the Workspace - Hernan" - - ^ [ self codeProvider selectedClassOrMetaClass ] - on: Error - do: [ :anError | anError return: UndefinedObject ]! ! -!ChangeSelector methodsFor: 'changes' stamp: 'HAW 9/22/2021 20:18:57'! - changes - - ^changes! ! -!AddParameter methodsFor: 'parameter' stamp: 'HAW 9/8/2021 22:37:02'! - newParameter - - ^newParameter! ! -!ExtractAsParameter methodsFor: 'applying' stamp: 'HAW 9/22/2021 20:19:25' overrides: 50438490! - apply - - self - applyAddParameter; - useNewParameter. - - ^addParameter changes - - ! ! -!ExtractAsParameter methodsFor: 'applying - private' stamp: 'HAW 9/22/2021 20:19:25'! - applyAddParameter - - ^ addParameter apply! ! -!ExtractAsParameter methodsFor: 'applying - private' stamp: 'HAW 9/22/2021 20:17:24'! - newSourceCode - - | intermediateSourceCode newInterval newSourceCode originalSourceCodeSize intermediateMethod | - - originalSourceCodeSize := sourceMethod sourceCode size. - intermediateMethod := sourceMethod methodClass >> self newSelector. - intermediateSourceCode := intermediateMethod sourceCode. - newInterval := intervalToReplace + (intermediateSourceCode size - originalSourceCodeSize). - newSourceCode := intermediateSourceCode copyReplaceFrom: newInterval first to: newInterval last with: addParameter newParameter. - - ^newSourceCode ! ! -!ExtractAsParameter methodsFor: 'applying - private' stamp: 'HAW 9/22/2021 20:17:33'! - useNewParameter - - sourceMethod methodClass compile: self newSourceCode. - - ! ! -!ExtractAsParameter methodsFor: 'initialization' stamp: 'HAW 9/21/2021 19:13:59'! - initializeExtractedFrom: anIntervalToExtract replacing: anIntervalToReplace at: aSourceMethod addingParameterWith: anAddParameter - - intervalToExtract := anIntervalToExtract. - intervalToReplace := anIntervalToReplace. - sourceMethod := aSourceMethod. - addParameter := anAddParameter.! ! -!ExtractAsParameter methodsFor: 'selectors' stamp: 'HAW 9/22/2021 19:56:45'! - newSelector - - ^addParameter newSelector ! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/22/2021 15:39:26'! - assert: aSourceMethod isInImplementors: implementorsCollection - - ^ (implementorsCollection includes: aSourceMethod) ifFalse: [ self signalOrigialMethodMustBeInImplementorsToChange ]! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/22/2021 20:07:25'! - assertAndCreateNamed: aNewParameter - extractedFrom: anInterval - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - creatingAddParameterWith: addParameterCreator - - | addParameter sourceCodeToExtract trimmedIntervalToReplace intervalToReplace intervals | - - self assert: aSourceMethod isInImplementors: implementorsCollection. - intervals := self assertCanExtractedFrom: anInterval for: aSourceMethod. - - intervalToReplace := intervals first. - trimmedIntervalToReplace := intervals second. - sourceCodeToExtract := aSourceMethod sourceCode copyFrom: trimmedIntervalToReplace first to: trimmedIntervalToReplace last. - - addParameter := addParameterCreator value: sourceCodeToExtract. - - ^self new - initializeExtractedFrom: trimmedIntervalToReplace - replacing: intervalToReplace - at: aSourceMethod - addingParameterWith: addParameter! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/22/2021 19:01:23'! - assertCanExtractedFrom: anInterval for: aSourceMethod - - | trimmedIntervalToReplace sourceCode node intervalToReplace | - - sourceCode := aSourceMethod sourceCode. - - ExtractMethodNewMethod assertIntervalToExtractIsNotEmpty: anInterval. - ExtractMethodNewMethod assert: anInterval isWithinBoundsOf: sourceCode. - - intervalToReplace := self removeDotsAt: anInterval in: sourceCode. - trimmedIntervalToReplace := intervalToReplace asSourceCodeInterval trimToMatchExpressionOn: sourceCode. - node := self nodeToExtractFrom: aSourceMethod at: trimmedIntervalToReplace or: intervalToReplace. - self assertIsValidToExtract: node. - - ^{ intervalToReplace. trimmedIntervalToReplace } - - ! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/22/2021 14:26:11'! - assertIsValidAssigmentToExtract: anAssignmentNode - - self assertIsValidToExtract: anAssignmentNode variable. - self assertIsValidToExtract: anAssignmentNode value ! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/22/2021 09:40:26'! - assertIsValidBlockNodeToExtract: aBlockNode - - aBlockNode block statementsDo: [ :aStatement | self assertIsValidToExtract: aStatement ]! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/22/2021 20:05:10'! - assertIsValidKeywordForNewParameter: aNewKeyword - - AddParameter assertIsValidKeywordForNewParameter: aNewKeyword! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/22/2021 15:09:49'! - assertIsValidLiteralNodeToExtract: aNode - - ^ (aNode isLiteralNode - or: [ aNode isTruePseudoVariable - or: [ aNode isFalsePseudoVariable - or: [ aNode isNilPseudoVariable ]]]) ifFalse: [ self signalInvalidExpressionToExtractAsParameter ]! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/22/2021 15:04:00'! - assertIsValidMessageNodeToExtract: aNode - - self assertIsValidToExtract: aNode receiver. - aNode arguments do: [ :anArgument | self assertIsValidToExtract: anArgument ]! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/22/2021 19:56:21'! - assertIsValidParameterName: aName - - AddParameter assertIsValidParameterName: aName ! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/22/2021 15:09:49'! - assertIsValidTempOrArgNodeToExtract: aTempVariableNode - - aTempVariableNode isDeclaredAtMethodLevel ifTrue: [ self signalInvalidExpressionToExtractAsParameter ]! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/22/2021 15:03:50'! - assertIsValidToExtract: aNode - - aNode isMessageNode ifTrue: [ ^self assertIsValidMessageNodeToExtract: aNode]. - aNode isBlockNode ifTrue: [ ^self assertIsValidBlockNodeToExtract: aNode ]. - aNode isTempOrArg ifTrue: [ ^self assertIsValidTempOrArgNodeToExtract: aNode ]. - aNode isAssignmentToTemporary ifTrue: [ ^self assertIsValidAssigmentToExtract: aNode ]. - self assertIsValidLiteralNodeToExtract: aNode! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/22/2021 09:28:16'! - is: aRange equalTo: sourceInterval or: intervalToReplace - - "When selecting literals like 1, the range first is one less than the initial character of the literal - Hernan" - - ^aRange = sourceInterval - or: [ aRange = intervalToReplace - or: [ aRange first + 1 = sourceInterval first and: [ aRange value last = sourceInterval last]]]! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/22/2021 15:45:11'! - nodeToExtractFrom: aSourceMethod at: trimmedIntervalToReplace or: intervalToReplace - - | nodeWithRangeToExtract nodesWithFirstPosition | - - nodesWithFirstPosition := aSourceMethod methodNode parseNodesPathAt: trimmedIntervalToReplace first ifAbsent: [ self signalInvalidSelection ]. - nodeWithRangeToExtract := nodesWithFirstPosition - detect: [ :nodeAndRange | self is: nodeAndRange value equalTo: trimmedIntervalToReplace or: intervalToReplace ] - ifNone: [ self signalInvalidSelection ]. - - ^nodeWithRangeToExtract key. - ! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/22/2021 15:42:21'! - removeDotsAt: anInterval in: sourceCode - - | lastToReplace | - - lastToReplace := anInterval last. - [(sourceCode at: lastToReplace) = $. ] whileTrue: [ lastToReplace := lastToReplace - 1]. - - ^anInterval first to: lastToReplace! ! -!ExtractAsParameter class methodsFor: 'instance creation' stamp: 'HAW 9/22/2021 15:55:37'! - named: aNewParameter - extractedFrom: anInterval - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - - ^self - assertAndCreateNamed: aNewParameter - extractedFrom: anInterval - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - creatingAddParameterWith: [ :sourceCodeToExtract | - AddParameter - named: aNewParameter - initializedWith: sourceCodeToExtract - toUnarySelector: aSourceMethod selector - implementors: implementorsCollection - senders: sendersCollection ]! ! -!ExtractAsParameter class methodsFor: 'instance creation' stamp: 'HAW 9/22/2021 15:56:38'! - named: aNewParameter - extractedFrom: anInterval - at: aNewKeywordIndex - newKeyword: newKeyword - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - - ^self - assertAndCreateNamed: aNewParameter - extractedFrom: anInterval - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - creatingAddParameterWith: [ :sourceCodeToExtract | - AddParameter - named: aNewParameter - at: aNewKeywordIndex - initializedWith: sourceCodeToExtract - using: newKeyword - toKeywordSelector: aSourceMethod selector - implementors: implementorsCollection - senders: sendersCollection ]! ! -!ExtractAsParameter class methodsFor: 'error messages' stamp: 'HAW 9/22/2021 15:10:01'! - errorMessageForInvalidExpressionToExtractAsParameter - - ^'Only literals, message sends to literals with literal parameters and -blocks with the previous conditions can be extracted as parameters'! ! -!ExtractAsParameter class methodsFor: 'error messages' stamp: 'HAW 9/21/2021 17:31:17'! - errorMessageForInvalidSelection - - ^'The selected source code is invalid for extraction as parameter'! ! -!ExtractAsParameter class methodsFor: 'error messages' stamp: 'HAW 9/22/2021 15:36:27'! - errorMessageForOrigialMethodMustBeInImplementorsToChange - - ^'Method with code to extract must be as implementor to change'! ! -!ExtractAsParameter class methodsFor: 'exceptions' stamp: 'HAW 9/22/2021 15:10:01'! - signalInvalidExpressionToExtractAsParameter - - self refactoringError: self errorMessageForInvalidExpressionToExtractAsParameter ! ! -!ExtractAsParameter class methodsFor: 'exceptions' stamp: 'HAW 9/21/2021 17:30:33'! - signalInvalidSelection - - self refactoringError: self errorMessageForInvalidSelection! ! -!ExtractAsParameter class methodsFor: 'exceptions' stamp: 'HAW 9/22/2021 15:37:55'! - signalOrigialMethodMustBeInImplementorsToChange - - self refactoringError: self errorMessageForOrigialMethodMustBeInImplementorsToChange! ! -!ExtractAsParameter class methodsFor: 'implementors and senders' stamp: 'HAW 9/22/2021 19:57:44'! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders forClassAndMetaOf: aPotentialClassToRefactor - - ^AddParameter addImplementorsOf: anOldSelector to: implementors andSendersTo: senders forClassAndMetaOf: aPotentialClassToRefactor! ! -!ExtractAsParameter class methodsFor: 'implementors and senders' stamp: 'HAW 9/22/2021 19:59:56'! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategoriesAndHierarchyOf: aClass organizedBy: anOrganization - - ^AddParameter addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategoriesAndHierarchyOf: aClass organizedBy: anOrganization! ! -!ExtractAsParameter class methodsFor: 'implementors and senders' stamp: 'HAW 9/22/2021 19:59:25'! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategory: aCategory organizedBy: anOrganization - - ^AddParameter addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategory: aCategory organizedBy: anOrganization! ! -!ExtractAsParameter class methodsFor: 'implementors and senders' stamp: 'HAW 9/22/2021 19:58:31'! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inHierarchyOf: aClass - - ^AddParameter addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inHierarchyOf: aClass -! ! -!ExtractAsParameter class methodsFor: 'implementors and senders' stamp: 'HAW 9/22/2021 20:00:22'! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inSystem: aSystem - - ^AddParameter addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inSystem: aSystem -! ! -!RefactoringApplier class methodsFor: 'appliers - registering' stamp: 'HAW 9/22/2021 18:38:54'! - registerExtractAsParameterApplier: anExtractAsParameterApplierClass - - self registerApplierAt: self extractAsParameterApplierId with: anExtractAsParameterApplierClass ! ! -!RefactoringApplier class methodsFor: 'appliers - getting' stamp: 'HAW 9/22/2021 16:35:35'! - extractAsParameterApplier - - ^self applierAt: self extractAsParameterApplierId ifAbsent: [ ExtractAsParameterApplier ]! ! -!RefactoringApplier class methodsFor: 'appliers - id' stamp: 'HAW 9/22/2021 16:35:22'! - extractAsParameterApplierId - - ^#extractAsParameterApplier! ! -!RefactoringApplier class methodsFor: 'appliers - resetting' stamp: 'HAW 9/22/2021 18:39:16'! - resetExtractAsParameterApplier - - self resetApplierAt: self extractAsParameterApplierId! ! -!ExtractAsParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 9/22/2021 16:30:27' overrides: 50441870! - askNewParameterValue! ! -!ExtractAsParameterApplier methodsFor: 'refactoring - creation' stamp: 'HAW 9/22/2021 20:06:39' overrides: 50441793! - createRefactoringForKeywordSelector - - ^self refactoringClass - named: newParameter - extractedFrom: interval - at: parameterIndex - newKeyword: newKeyword - at: selectedClass >> oldSelector - implementors: implementors - senders: senders ! ! -!ExtractAsParameterApplier methodsFor: 'refactoring - creation' stamp: 'HAW 9/22/2021 19:36:15' overrides: 50441804! - createRefactoringForUnarySelector - - ^self refactoringClass - named: newParameter - extractedFrom: interval - at: selectedClass >> oldSelector - implementors: implementors - senders: senders ! ! -!ExtractAsParameterApplier methodsFor: 'refactoring - creation' stamp: 'HAW 9/22/2021 16:30:58' overrides: 50441814! - refactoringClass - - ^ExtractAsParameter ! ! -!ExtractAsParameterApplier methodsFor: 'initialization' stamp: 'HAW 9/22/2021 19:05:46'! - initializeInterval: anInterval - - interval := anInterval.! ! -!ExtractAsParameterApplier class methodsFor: 'instance creation' stamp: 'HAW 9/22/2021 19:03:29'! -from: anInterval on: aModel for: anOldSelector in: aClassToRefactor - - ExtractAsParameter assertCanExtractedFrom: anInterval for: aClassToRefactor >> anOldSelector. - - ^(super on: aModel for: anOldSelector in: aClassToRefactor) initializeInterval: anInterval ! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 9/22/2021 19:41:05' prior: 50573278! - withMethodNodeAndClassDo: aBlock ifErrorsParsing: anErrorBlock - - | selectedClass methodNode | - - selectedClass := self selectedClassOrMetaClassOrUndefinedObject. - [ - [ methodNode := selectedClass methodNodeFor: model actualContents asString ] - on: UndeclaredVariableWarning do: [ :ex | ex resume ] - ] on: Error do: [ :anError | ^ anErrorBlock value: anError ]. - - ^aBlock value: methodNode value: selectedClass.! ! -!AddParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 9/22/2021 16:27:52' prior: 50441870! - askNewParameterValue - - | enteredString | - - enteredString := self request: 'Enter parameter value for senders'. - newParameterValue := enteredString withBlanksTrimmed. - self refactoringClass assertNewParameterValueIsValid: newParameterValue. -! ! -!RefactoringMenues class methodsFor: 'editor menus' stamp: 'HAW 9/22/2021 16:41:33' prior: 50491927! - smalltalkEditorRefactoringMenuOptions - - ^`{ - { - #itemGroup -> 35. - #itemOrder -> 30. - #label -> 'Add Parameter... (A)'. - #selector -> #contextualAddParameter. - #icon -> #listAddIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 35. - #label -> 'Extract as Parameter... (1)'. - #selector -> #contextualExtractAsParameter. - #icon -> #listAddIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 40. - #label -> 'Remove Parameter... (S)'. - #selector -> #contextualRemoveParameter. - #icon -> #listRemoveIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 50. - #label -> 'Temporary to Instance Variable (O)'. - #selector -> #temporaryToInstanceVariable. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 60. - #label -> 'Push Up Instance Variable'. - #selector -> #contextualPushUpInClassDefinition. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 70. - #label -> 'Push Down Instance Variable'. - #selector -> #contextualPushDownInClassDefinition. - #icon -> #goBottomIcon - } asDictionary. - }`! ! -!RefactoringMenues class methodsFor: 'shortcuts' stamp: 'HAW 9/22/2021 19:34:01' prior: 50507326! - smalltalkEditorCmdShortcutsSpec - - " - SmalltalkEditor initializeCmdShortcuts - " - ^#( - #($R #contextualRename: 'Renames what is under cursor') - #($A #contextualAddParameter: 'Adds parameter to message that is under cursor') - #($S #contextualRemoveParameter: 'Removes parameter to message that is under cursor') - #($O #temporaryToInstanceVariable: 'Extracts temporary variable to instance variable') - #($J #extractToTemporary: 'Extracts the selected code into a temporary variable') - #($K #extractMethod: 'Extracts the selected code into a separate method') - #($1 #contextualExtractAsParameter: 'Extracts the selected code as parameter') - )! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'pre-conditions' stamp: 'HAW 9/22/2021 14:33:51' prior: 50517377! - assertSourceCodeContainsAValidExpression - - (self intervalCoversCompleteAstNodes - and: [ self startAndEndNodesShareAParentNode - or: [ self intervalMatchesBeginningOfStatement - and: [ self intervalMatchesEndOfStatement ]]]) - ifFalse: [ self signalSourceCodeContainsAnInvalidExpressionError ]! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'private' stamp: 'HAW 9/22/2021 14:55:22' prior: 50508770! - intervalMatchesEndOfStatement - - | closerStatementLastPosition | - - closerStatementLastPosition := (self findSourceRangeOfCloserStatementIn: finalNodeAncestors) last. - ^ closerStatementLastPosition = intervalToExtract last or: [ closerStatementLastPosition - 1 = intervalToExtract last ].! ! - -ExtractAsParameterApplier class removeSelector: #on:for:in:! - -ExtractAsParameter class removeSelector: #assertNamed:extractedFrom:at:implementors:senders:creatingAddParameterWith:! - -ExtractAsParameter class removeSelector: #assertNamed:extractedFrom:at:implementors:senders:! - -ExtractAsParameter removeSelector: #addParameter! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4879-ExtractAsParameter-HernanWilkinson-2021Sep22-15h23m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4879] on 23 September 2021 at 10:21:47 am'! -!CodeProvider methodsFor: 'annotation' stamp: 'jmv 9/22/2021 18:29:08'! - annotationForSystemCategory: aCategory - "Provide a line of content for an annotation pane, given that the receiver is pointing at the class definition of the given class." - - | separator | - separator _ self annotationSeparator. - ^ String streamContents: [ :strm | - strm - nextPutAll: 'System Category'; - nextPutAll: aCategory; - nextPutAll: separator; - print: (SystemOrganization listAtCategoryNamed: aCategory) size; - nextPutAll: ' classes'; - nextPutAll: separator; - print: (SystemOrganization instanceMethodCountOf: aCategory); - nextPutAll: ' instance methods'; - nextPutAll: separator; - print: (SystemOrganization classMethodCountOf: aCategory); - nextPutAll: ' class methods'; - nextPutAll: separator; - print: (SystemOrganization linesOfCodeOf: aCategory); - nextPutAll: ' total lines of code' ]! ! -!SystemOrganizer methodsFor: 'source code management' stamp: 'jmv 9/23/2021 10:18:03'! - classMethodCountOf: category - - ^ (self superclassOrderIn: category) sum: [ :cl | cl class selectors size ] ifEmpty: 0.! ! -!SystemOrganizer methodsFor: 'source code management' stamp: 'jmv 9/23/2021 10:18:08'! - instanceMethodCountOf: category - - ^ (self superclassOrderIn: category) sum: [ :cl | cl selectors size ] ifEmpty: 0.! ! -!SystemOrganizer methodsFor: 'source code management' stamp: 'jmv 9/23/2021 10:16:49'! - linesOfCodeOf: category -" -SystemOrganization linesOfCodeOf: #'System-Files' -" - "An approximate measure of lines of. - Includes comments, but excludes blank lines." - - ^ (self superclassOrderIn: category) sum: [ :cl | cl linesOfCode ] ifEmpty: 0.! ! -!CodeProvider methodsFor: 'annotation' stamp: 'jmv 9/22/2021 18:45:23' prior: 50518430! - annotationForSelector: aSelector ofClass: aClass - "Provide a line of content for an annotation pane, representing - information about the given selector and class" - - | stamp sendersCount implementorsCount aCategory separator aString aList aComment stream requestList | - aSelector == #Comment - ifTrue: [^ self annotationForClassCommentFor: aClass]. - aSelector == #Definition - ifTrue: [^ self annotationForClassDefinitionFor: aClass]. - aSelector == #Hierarchy - ifTrue: [^ self annotationForHierarchyFor: aClass]. - stream _ WriteStream on: String new. - requestList _ self annotationRequests. - separator _ self annotationSeparator. - requestList - do: [:aRequest | - aRequest == #firstComment - ifTrue: [ - aComment _ aClass firstCommentAt: aSelector. - aComment isEmptyOrNil - ifFalse: [stream position = 0 ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: aComment]]. - aRequest == #masterComment - ifTrue: [ - aComment _ aClass supermostPrecodeCommentFor: aSelector. - aComment isEmptyOrNil - ifFalse: [stream position = 0 ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: aComment]]. - aRequest == #documentation - ifTrue: [ - aComment _ aClass precodeCommentOrInheritedCommentFor: aSelector. - aComment isEmptyOrNil - ifFalse: [stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: aComment]]. - aRequest == #timeStamp - ifTrue: [ - stamp _ self timeStamp. - stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: (stamp size > 0 ifTrue: [stamp] ifFalse: ['no timestamp'])]. - aRequest == #linesOfCode - ifTrue: [ - stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: ((aClass compiledMethodAt: aSelector ifAbsent: nil) - ifNotNil: [ :cm | cm linesOfCode]) printString, ' lines of code']. - aRequest == #messageCategory - ifTrue: [ - aCategory _ aClass organization categoryOfElement: aSelector. - aCategory - ifNotNil: ["woud be nil for a method no longer present, - e.g. in a recent-submissions browser" - stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: aCategory]]. - aRequest == #sendersCount - ifTrue: [ - sendersCount _ Smalltalk numberOfSendersOf: aSelector. - sendersCount _ sendersCount = 1 - ifTrue: ['1 sender'] - ifFalse: [sendersCount printString , ' senders']. - stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: sendersCount]. - aRequest == #implementorsCount - ifTrue: [ - implementorsCount _ Smalltalk numberOfImplementorsOf: aSelector. - implementorsCount _ implementorsCount = 1 - ifTrue: ['1 implementor'] - ifFalse: [implementorsCount printString , ' implementors']. - stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: implementorsCount]. - aRequest == #priorVersionsCount - ifTrue: [ - stream isEmpty ifFalse: [stream nextPutAll: separator]. - self - addPriorVersionsCountForSelector: aSelector - ofClass: aClass - to: stream]. - aRequest == #priorTimeStamp - ifTrue: [ - stamp _ VersionsBrowser - timeStampFor: aSelector - class: aClass - reverseOrdinal: 2. - stamp - ifNotNil: [stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: 'prior timestamp: ' , stamp]]. - aRequest == #packages - ifTrue: [ - (aClass compiledMethodAt: aSelector ifAbsent: nil) ifNotNil: [ :cm | - stream isEmpty ifFalse: [stream nextPutAll: separator]. - (CodePackage packageOfMethod: cm methodReference ifNone: nil) - ifNil: [ stream nextPutAll: 'in no package' ] - ifNotNil: [ :codePackage | - stream nextPutAll: 'in package '; nextPutAll: codePackage packageName ]]]. - aRequest == #changeSets - ifTrue: [ - stream isEmpty ifFalse: [stream nextPutAll: separator]. - aList _ ChangeSet allChangeSetsWithClass: aClass selector: aSelector. - aList size > 0 - ifTrue: [aList size = 1 - ifTrue: [stream nextPutAll: 'only in change set'] - ifFalse: [stream nextPutAll: 'in change sets:']. - aList - do: [:aChangeSet | stream nextPut: Character space; nextPutAll: aChangeSet name ] - separatedBy: [ stream nextPut: $, ]] - ifFalse: [stream nextPutAll: 'in no change set']]. - aRequest == #allChangeSets - ifTrue: [ - stream isEmpty ifFalse: [stream nextPutAll: separator]. - aList _ ChangeSet allChangeSetsWithClass: aClass selector: aSelector. - aList size > 0 - ifTrue: [aList size = 1 - ifTrue: [stream nextPutAll: 'only in change set'] - ifFalse: [stream nextPutAll: 'in change sets:']. - aList - do: [:aChangeSet | stream nextPut: Character space; nextPutAll: aChangeSet name ] - separatedBy: [ stream nextPut: $, ]] - ifFalse: [stream nextPutAll: 'in no change set']]. - aRequest == #allBaseSystemChangeSets - ifTrue: [ - stream isEmpty ifFalse: [stream nextPutAll: separator]. - aList _ (ChangeSet allChangeSetsWithClass: aClass selector: aSelector) select: [ :it | it isForBaseSystem ]. - aList size > 0 - ifTrue: [ - aList size = 1 - ifTrue: [stream nextPutAll: 'only in base system change set'] - ifFalse: [stream nextPutAll: 'in base system change sets:']. - aList - do: [:aChangeSet | stream nextPut: Character space; nextPutAll: aChangeSet name ] - separatedBy: [ stream nextPut: $, ]] - ifFalse: [stream nextPutAll: 'in no base system change set']]. - aRequest == #closuresInfo - ifTrue: [ - aString _ aClass closuresInfoAt: aSelector. - aString size > 0 - ifTrue: [stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: aString]]. - ]. - ^ stream contents! ! -!Browser methodsFor: 'annotation' stamp: 'jmv 9/23/2021 10:08:33' prior: 50485527 overrides: 50455416! - annotation - "Provide a line of content for an annotation pane, representing information about the method associated with the selected class and selector in the receiver." - - | aSelector aClass | - (aClass _ self selectedClassOrMetaClass) - ifNil: [ - self selectedSystemCategoryName ifNotNil: [ :sysCat | - ^self annotationForSystemCategory: sysCat ]. - ^ '']. - self editSelection == #editComment - ifTrue: [^ self annotationForSelector: #Comment ofClass: aClass]. - self isEditingExistingClass - ifTrue: [^ self annotationForSelector: #Definition ofClass: aClass]. - (aSelector _ self selectedMessageName) - ifNil: [^ '']. - ^ self annotationForSelector: aSelector ofClass: aClass! ! -!ClassDescription methodsFor: 'source code management' stamp: 'jmv 9/23/2021 10:05:44' prior: 16807069! - linesOfCode -" -Object linesOfCode -" - "An approximate measure of lines of. - Includes comments, but excludes blank lines. - If asked to a class, also include its metaclass (i.e. the class side). - If asked to a metaclass (the class side), don't include the class (the instance side)." - - | lines | - lines _ 0. - self selectorsDo: [ :sel | - lines _ lines + (self compiledMethodAt: sel) linesOfCode ]. - ^self isMeta - ifTrue: [ lines] - ifFalse: [ lines + self class linesOfCode]. -" -(SystemOrganization categories select: [:c | 'Kernel*' match: c]) sum: [:c | - (SystemOrganization superclassOrderIn: c) sum: [:cl | cl linesOfCode]] -" -" -Smalltalk allClasses sum: [:cl | cl linesOfCode] -"! ! -!CompiledMethod methodsFor: 'source code management' stamp: 'jmv 9/23/2021 10:03:40' prior: 16820495! - linesOfCode - "An approximate measure of lines of code. - Use decompiled source code. In this way, the measure: - - Doesn't include comments - - Doesn't include blank lines - - Is not sensitive to code formatting - The motivation is to consider LOC as an expense, not an asset. Minimizing LOC is good. - But it is not like that for comments!!" - - | lines | - lines _ 0. - self decompileString lineIndicesDo: [ :start :endWithoutDelimiters :end | - endWithoutDelimiters - start > 0 ifTrue: [ - lines _ lines+1 ]]. - ^lines! ! -!Preferences class methodsFor: 'parameters' stamp: 'jmv 9/22/2021 18:41:13' prior: 16893315! -annotationInfo - "Answer a list of pairs characterizing all the available kinds of annotations; in each pair, the first element is a symbol representing the info type, and the second element is a string providing the corresponding balloon help" - - ^ #( - (timeStamp 'The time stamp of the last submission of the method.') - (firstComment 'The first comment in the method, if any.') - (masterComment 'The comment at the beginning of the supermost implementor of the method if any.') - (documentation 'Comment at beginning of the method or, if it has none, comment at the beginning of a superclass''s implementation of the method.') - (messageCategory 'Which method category the method lies in.') - (sendersCount 'A report of how many senders there of the message.') - (implementorsCount 'A report of how many implementors there are of the message.') - (allChangeSets 'A list of all change sets bearing the method.') - (priorVersionsCount 'A report of how many previous versions there are of the method.') - (priorTimeStamp 'The time stamp of the penultimate submission of the method, if any.') - (closuresInfo 'Details about BlockClosures in the method.') - (packages 'Details about CodePackages including the method.') - (linesOfCode 'Number of lines of code, including comments but not blank lines.') - )! ! -!CodePackage methodsFor: 'source code management' stamp: 'jmv 9/23/2021 10:27:42' prior: 16810500! - linesOfCode - "An approximate measure of lines of code. - Does not includes comments, or excludes blank lines. - See comment at CompiledMethod >> #linesOfCode" - - ^self methods inject: 0 into: [ :sum :each | - sum + each compiledMethod linesOfCode ].! ! -!Preferences class methodsFor: 'parameters' stamp: 'jmv 9/22/2021 18:42:21' prior: 50419252! - setDefaultAnnotationInfo - " - Preferences setDefaultAnnotationInfo - " - ^ self parameters at: #MethodAnnotations put: #(timeStamp linesOfCode messageCategory implementorsCount sendersCount packages changeSets)! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - Preferences setDefaultAnnotationInfo! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4880-LinesOfCode-Enhancements-JuanVuletich-2021Sep23-09h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4880] on 23 September 2021 at 11:31:18 am'! -!Preferences class methodsFor: 'parameters' stamp: 'jmv 9/23/2021 11:30:01'! - setCheapAnnotationInfo - " - Preferences setCheapAnnotationInfo - " - ^ self parameters at: #MethodAnnotations put: #(timeStamp messageCategory packages changeSets)! ! -!Preferences class methodsFor: 'themes' stamp: 'jmv 9/23/2021 11:30:57' prior: 50601490! - slowMachine - " - Preferences slowMachine - " - self setPreferencesFrom: #( - #(#drawKeyboardFocusIndicator false ) - (balloonHelpEnabled false) - (browseWithPrettyPrint false) - (caseSensitiveFinds true) - (checkForSlips false) - (cmdDotEnabled true) - (diffsInChangeList true) - (diffsWithPrettyPrint false) - (menuKeyboardControl false) - (optionalButtons false) - (subPixelRenderFonts true) - (thoroughSenders true) - (cheapWindowReframe true) - (syntaxHighlightingAsYouType false) - (tapAndHoldEmulatesButton2 false) - (clickGrabsMorphs true) - ). - self useNoMenuIcons. - self runningWorld backgroundImageData: nil. - Preferences setCheapAnnotationInfo. - " - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - Taskbar hideTaskbar - "! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4881-Preferences-slowMachine-tweaks-JuanVuletich-2021Sep23-11h29m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4881] on 23 September 2021 at 4:06:09 pm'! -!PluggableButtonMorph methodsFor: 'accessing' stamp: 'KenD 9/17/2021 16:05:19' prior: 50578326! - iconName - - ^ self valueOfProperty: #iconName! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4882-iconName-fix-KenDickey-2021Sep23-16h05m-KenD.001.cs.st----! - -'From Cuis 5.0 [latest update: #4882] on 24 September 2021 at 10:19:33 am'! -!FontFamily class methodsFor: 'accessing fonts' stamp: 'jmv 9/24/2021 10:03:42'! - enableTrueTypeFontsOnly - - AvailableFamilies _ AvailableFamilies select: [ :f | f isTrueTypeFontFamily ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4883-EnableOnlyTrueTypeFonts-JuanVuletich-2021Sep24-10h19m-jmv.001.cs.st----! - -----QUIT----(24 September 2021 10:39:59) Cuis5.0-4883-32.image priorSource: 8888107! - -----STARTUP---- (24 September 2021 11:24:33) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4883-32.image! - - -'From Cuis 5.0 [latest update: #4883] on 24 September 2021 at 11:18:01 am'! -!MovableMorph methodsFor: 'initialization' stamp: 'jmv 9/24/2021 11:16:19' prior: 50554314 overrides: 50554567! - initialize - "initialize the state of the receiver" - - super initialize. - location _ MorphicTranslation new. - self fixYAxisDirection.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4884-fixYDirection-atCreation-JuanVuletich-2021Sep24-11h16m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4884] on 24 September 2021 at 11:22:34 am'! -!Base64MimeConverter class methodsFor: 'services' stamp: 'NM 9/24/2021 15:05:45' prior: 16782442! - mimeEncode: aCollectionOrStream to: outStream - self new - dataStream: ((aCollectionOrStream is: #Stream) - ifTrue: [aCollectionOrStream] - ifFalse: [ReadStream on: aCollectionOrStream]); - mimeStream: outStream; - multiLine: true; - mimeEncode! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4885-Base64MimeConverter-NicolaMingotti-2021Sep24-11h21m-NM.001.cs.st----! - -----QUIT----(24 September 2021 11:24:41) Cuis5.0-4885-32.image priorSource: 8939985! - -----STARTUP---- (14 October 2021 14:31:48) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4885-32.image! - - -'From Cuis 5.0 [latest update: #4879] on 24 September 2021 at 8:40:55 pm'! - -Refactoring subclass: #ExtractAsParameter - instanceVariableNames: 'intervalToExtract sourceMethod addParameter intervalToReplace intervals ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractAsParameter category: #'Tools-Refactoring' stamp: 'Install-4886-ExtractAsParameterMultiOcurrences-HernanWilkinson-2021Sep24-17h18m-HAW.001.cs.st 10/14/2021 14:31:53'! -Refactoring subclass: #ExtractAsParameter - instanceVariableNames: 'intervalToExtract sourceMethod addParameter intervalToReplace intervals' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -AddParameterApplier subclass: #ExtractAsParameterApplier - instanceVariableNames: 'interval intervals ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractAsParameterApplier category: #'Tools-Refactoring' stamp: 'Install-4886-ExtractAsParameterMultiOcurrences-HernanWilkinson-2021Sep24-17h18m-HAW.001.cs.st 10/14/2021 14:31:53'! -AddParameterApplier subclass: #ExtractAsParameterApplier - instanceVariableNames: 'interval intervals' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!ExtractAsParameter methodsFor: 'applying - private' stamp: 'HAW 9/24/2021 17:52:51'! - newSourceCode: anIntervalToReplace from: sourceCode originalSize: originalSourceCodeSize - - | newInterval newSourceCode | - - newInterval := anIntervalToReplace + (sourceCode size - originalSourceCodeSize). - newSourceCode := sourceCode copyReplaceFrom: newInterval first to: newInterval last with: addParameter newParameter. - - ^newSourceCode ! ! -!ExtractAsParameter methodsFor: 'initialization' stamp: 'HAW 9/24/2021 17:31:51'! - initializeReplacingAll: allIntervals at: aSourceMethod addingParameterWith: anAddParameter - - intervals := allIntervals. - sourceMethod := aSourceMethod. - addParameter := anAddParameter.! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/24/2021 20:18:37'! - assertAndCreateNamed: aNewParameter - extractedFromAll: allIntervals - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - creatingAddParameterWith: addParameterCreator - - | addParameter sourceCodeToExtract trimmedIntervalToReplace intervals | - - self assert: aSourceMethod isInImplementors: implementorsCollection. - intervals := self assertCanExtractedFromAll: allIntervals for: aSourceMethod. - - trimmedIntervalToReplace := intervals first second. - sourceCodeToExtract := aSourceMethod sourceCode copyFrom: trimmedIntervalToReplace first to: trimmedIntervalToReplace last. - - addParameter := addParameterCreator value: sourceCodeToExtract. - - ^self new - initializeReplacingAll: (intervals collect: [ :both | both first ]) - at: aSourceMethod - addingParameterWith: addParameter! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/24/2021 18:07:32'! - assertCanExtractFrom: anInterval for: sourceCode methodNode: methodNode last: lastIntervalsAndNode - - | trimmedIntervalToReplace node intervalToReplace | - - ExtractMethodNewMethod assertIntervalToExtractIsNotEmpty: anInterval. - ExtractMethodNewMethod assert: anInterval isWithinBoundsOf: sourceCode. - - intervalToReplace := self removeDotsAt: anInterval in: sourceCode. - trimmedIntervalToReplace := intervalToReplace asSourceCodeInterval trimToMatchExpressionOn: sourceCode. - node := self nodeToExtractFrom: methodNode at: trimmedIntervalToReplace or: intervalToReplace. - self assertIsValidToExtract: node. - lastIntervalsAndNode ifNotNil: [ self assertIsSameExpressionToExtractFrom: node to: lastIntervalsAndNode third ]. - - ^{ intervalToReplace. trimmedIntervalToReplace. node }! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/24/2021 18:17:03'! - assertCanExtractedFromAll: allIntervals for: aSourceMethod - - | sourceCode methodNode lastIntervalsAndNode | - - allIntervals isEmpty ifTrue: [ self signalNoExpressionToExtract ]. - - sourceCode := aSourceMethod sourceCode. - methodNode := aSourceMethod methodNode. - lastIntervalsAndNode := nil. - - ^allIntervals collect: [ :anInterval | - lastIntervalsAndNode := self - assertCanExtractFrom: anInterval - for: sourceCode - methodNode: methodNode - last: lastIntervalsAndNode ] ! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/24/2021 20:19:16'! - assertIsSameExpressionToExtractFrom: node to: lastNode - - (node = lastNode or: [ node equivalentTo: lastNode ]) ifFalse: [ - self signalNotAllExpressionsToExtractAreEqual ]! ! -!ExtractAsParameter class methodsFor: 'instance creation' stamp: 'HAW 9/24/2021 17:23:26'! - named: aNewParameter - extractedFromAll: intervals - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - - ^self - assertAndCreateNamed: aNewParameter - extractedFromAll: intervals - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - creatingAddParameterWith: [ :sourceCodeToExtract | - AddParameter - named: aNewParameter - initializedWith: sourceCodeToExtract - toUnarySelector: aSourceMethod selector - implementors: implementorsCollection - senders: sendersCollection ]! ! -!ExtractAsParameter class methodsFor: 'instance creation' stamp: 'HAW 9/24/2021 17:23:26'! - named: aNewParameter - extractedFromAll: intervals - at: aNewKeywordIndex - newKeyword: newKeyword - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - - ^self - assertAndCreateNamed: aNewParameter - extractedFromAll: intervals - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - creatingAddParameterWith: [ :sourceCodeToExtract | - AddParameter - named: aNewParameter - at: aNewKeywordIndex - initializedWith: sourceCodeToExtract - using: newKeyword - toKeywordSelector: aSourceMethod selector - implementors: implementorsCollection - senders: sendersCollection ]! ! -!ExtractAsParameter class methodsFor: 'error messages' stamp: 'HAW 9/24/2021 18:15:58'! - errorMessageForNoExpressionToExtract - - ^'No expression to extract'! ! -!ExtractAsParameter class methodsFor: 'error messages' stamp: 'HAW 9/24/2021 17:58:54'! - errorMessageNotAllExpressionsToExtractAreEqual - - ^'Expressions to extract are not equal'! ! -!ExtractAsParameter class methodsFor: 'exceptions' stamp: 'HAW 9/24/2021 18:17:30'! - signalNoExpressionToExtract - - self refactoringError: self errorMessageForNoExpressionToExtract ! ! -!ExtractAsParameter class methodsFor: 'exceptions' stamp: 'HAW 9/24/2021 18:07:12'! - signalNotAllExpressionsToExtractAreEqual - - self refactoringError: self errorMessageNotAllExpressionsToExtractAreEqual! ! -!ExtractAsParameter class methodsFor: 'intervals' stamp: 'HAW 9/24/2021 20:23:08'! - intervalsForEquivalentExpressionIn: method at: interval - - | methodNode node sourceCode trimmedIntervalToReplace rangeOrRanges | - - sourceCode := method sourceCode. - methodNode := method methodNode. - trimmedIntervalToReplace := interval asSourceCodeInterval trimToMatchExpressionOn: sourceCode. - node := self nodeToExtractFrom: methodNode at: trimmedIntervalToReplace or: interval. - - rangeOrRanges := methodNode rangeForNode: node ifAbsent: [ self shouldNotHappenBecause: 'node already exist' ]. - ^(methodNode isMultipleRanges: rangeOrRanges) - ifTrue: [ rangeOrRanges ] - ifFalse: [ self intervalsForEquivalentNodesTo: node in: methodNode ] - ! ! -!ExtractAsParameter class methodsFor: 'intervals' stamp: 'HAW 9/24/2021 20:24:05'! -intervalsForEquivalentNodesTo: node in: methodNode - - | completeSourceRanges intervalsForEquivalentNodes | - - intervalsForEquivalentNodes := OrderedCollection new. - completeSourceRanges := methodNode completeSourceRanges. - - methodNode nodesDo: [ :aNode | - (aNode equivalentTo: node) ifTrue: [ - "There can not be more than one range because of the is not a multi range node. See senders - Hernan" - intervalsForEquivalentNodes add: (completeSourceRanges at: aNode) first ]]. - - ^intervalsForEquivalentNodes! ! -!ExtractAsParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 9/24/2021 18:51:07'! - askToReplaceAll - - | extractAll | - - extractAll := PopUpMenu - confirm: 'Do you want to extract all ocurrences?' - trueChoice: 'Yes, extract all ocurrences' - falseChoice: 'No, extract only the selected one'. - - extractAll ifFalse: [ intervals := { interval } ].! ! -!ExtractAsParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 9/24/2021 18:47:00' overrides: 50441884! - requestRefactoringParameters - - intervals size > 1 ifTrue: [ self askToReplaceAll ]. - - super requestRefactoringParameters.! ! -!ExtractAsParameterApplier methodsFor: 'initialization' stamp: 'HAW 9/24/2021 20:22:13'! - initializeIntervals - - intervals := self refactoringClass intervalsForEquivalentExpressionIn: selectedClass >> oldSelector at: interval.! ! -!CodeNode methodsFor: 'private' stamp: 'HAW 9/24/2021 20:01:42' prior: 50506487! - hasEquivalentTemporariesDeclarationWith: aCodeNode - - (self temporariesDeclaration isNil and: [ aCodeNode temporariesDeclaration isNil ]) ifTrue: [ ^true ]. - (self temporariesDeclaration isNil and: [ aCodeNode temporariesDeclaration notNil ]) ifTrue: [ ^false ]. - (self temporariesDeclaration notNil and: [ aCodeNode temporariesDeclaration isNil ]) ifTrue: [ ^false ]. - - ^self temporariesDeclaration equivalentTo: aCodeNode temporariesDeclaration ! ! -!ExtractAsParameter methodsFor: 'applying - private' stamp: 'HAW 9/24/2021 17:54:19' prior: 50609998! - useNewParameter - - | newSourceCodeWithAllReplacements originalSourceCodeSize | - - originalSourceCodeSize := sourceMethod sourceCode size. - newSourceCodeWithAllReplacements := intervals - inject: (sourceMethod methodClass >> self newSelector) sourceCode - into: [ :newSourceCode :intervalToReplace | self newSourceCode: intervalToReplace from: newSourceCode originalSize: originalSourceCodeSize ]. - - sourceMethod methodClass compile: newSourceCodeWithAllReplacements! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/24/2021 17:42:58' prior: 50610172! -nodeToExtractFrom: methodNode at: trimmedIntervalToReplace or: intervalToReplace - - | nodeWithRangeToExtract nodesWithFirstPosition | - - nodesWithFirstPosition := methodNode parseNodesPathAt: trimmedIntervalToReplace first ifAbsent: [ self signalInvalidSelection ]. - nodeWithRangeToExtract := nodesWithFirstPosition - detect: [ :nodeAndRange | self is: nodeAndRange value equalTo: trimmedIntervalToReplace or: intervalToReplace ] - ifNone: [ self signalInvalidSelection ]. - - ^nodeWithRangeToExtract key. - ! ! -!ExtractAsParameter class methodsFor: 'instance creation' stamp: 'HAW 9/24/2021 17:22:20' prior: 50610203! - named: aNewParameter - extractedFrom: anInterval - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - - ^self - named: aNewParameter - extractedFromAll: { anInterval } - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection ! ! -!ExtractAsParameter class methodsFor: 'instance creation' stamp: 'HAW 9/24/2021 17:24:05' prior: 50610224! - named: aNewParameter - extractedFrom: anInterval - at: aNewKeywordIndex - newKeyword: newKeyword - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - - ^self - named: aNewParameter - extractedFromAll: { anInterval } - at: aNewKeywordIndex - newKeyword: newKeyword - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection ! ! -!ExtractAsParameterApplier methodsFor: 'refactoring - creation' stamp: 'HAW 9/24/2021 18:51:16' prior: 50610381 overrides: 50441793! - createRefactoringForKeywordSelector - - ^self refactoringClass - named: newParameter - extractedFromAll: intervals - at: parameterIndex - newKeyword: newKeyword - at: selectedClass >> oldSelector - implementors: implementors - senders: senders ! ! -!ExtractAsParameterApplier methodsFor: 'refactoring - creation' stamp: 'HAW 9/24/2021 18:51:25' prior: 50610393 overrides: 50441804! - createRefactoringForUnarySelector - - ^self refactoringClass - named: newParameter - extractedFromAll: intervals - at: selectedClass >> oldSelector - implementors: implementors - senders: senders ! ! -!ExtractAsParameterApplier methodsFor: 'initialization' stamp: 'HAW 9/24/2021 18:27:27' prior: 50610408! - initializeInterval: anInterval - - interval := anInterval. - - self initializeIntervals.! ! -!ExtractAsParameterApplier class methodsFor: 'instance creation' stamp: 'HAW 9/24/2021 17:40:01' prior: 50610413! - from: anInterval on: aModel for: anOldSelector in: aClassToRefactor - - ExtractAsParameter assertCanExtractedFromAll: { anInterval } for: aClassToRefactor >> anOldSelector. - - ^(super on: aModel for: anOldSelector in: aClassToRefactor) initializeInterval: anInterval ! ! - -ExtractAsParameterApplier removeSelector: #intervalsForEquivalentNodesTo:in:! - -ExtractAsParameterApplier removeSelector: #initializeIntervalsLookingForSameExpressionAt:to:! - -ExtractAsParameter class removeSelector: #assertCanExtractedFrom:for:! - -!methodRemoval: ExtractAsParameter class #assertCanExtractedFrom:for: stamp: 'Install-4886-ExtractAsParameterMultiOcurrences-HernanWilkinson-2021Sep24-17h18m-HAW.001.cs.st 10/14/2021 14:31:53'! -assertCanExtractedFrom: anInterval for: aSourceMethod - - | trimmedIntervalToReplace sourceCode node intervalToReplace | - - sourceCode := aSourceMethod sourceCode. - - ExtractMethodNewMethod assertIntervalToExtractIsNotEmpty: anInterval. - ExtractMethodNewMethod assert: anInterval isWithinBoundsOf: sourceCode. - - intervalToReplace := self removeDotsAt: anInterval in: sourceCode. - trimmedIntervalToReplace := intervalToReplace asSourceCodeInterval trimToMatchExpressionOn: sourceCode. - node := self nodeToExtractFrom: aSourceMethod at: trimmedIntervalToReplace or: intervalToReplace. - self assertIsValidToExtract: node. - - ^{ intervalToReplace. trimmedIntervalToReplace } - - ! - -ExtractAsParameter class removeSelector: #assertAndCreateNamed:extractedFrom:at:implementors:senders:creatingAddParameterWith:! - -!methodRemoval: ExtractAsParameter class #assertAndCreateNamed:extractedFrom:at:implementors:senders:creatingAddParameterWith: stamp: 'Install-4886-ExtractAsParameterMultiOcurrences-HernanWilkinson-2021Sep24-17h18m-HAW.001.cs.st 10/14/2021 14:31:53'! -assertAndCreateNamed: aNewParameter - extractedFrom: anInterval - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - creatingAddParameterWith: addParameterCreator - - | addParameter sourceCodeToExtract trimmedIntervalToReplace intervalToReplace intervals | - - self assert: aSourceMethod isInImplementors: implementorsCollection. - intervals := self assertCanExtractedFrom: anInterval for: aSourceMethod. - - intervalToReplace := intervals first. - trimmedIntervalToReplace := intervals second. - sourceCodeToExtract := aSourceMethod sourceCode copyFrom: trimmedIntervalToReplace first to: trimmedIntervalToReplace last. - - addParameter := addParameterCreator value: sourceCodeToExtract. - - ^self new - initializeExtractedFrom: trimmedIntervalToReplace - replacing: intervalToReplace - at: aSourceMethod - addingParameterWith: addParameter! - -ExtractAsParameter class removeSelector: #assertCanExtractFrom:for:methodNode:! - -ExtractAsParameter removeSelector: #newSourceCode:! - -ExtractAsParameter removeSelector: #initializeExtractedFrom:replacingAll:at:addingParameterWith:! - -ExtractAsParameter removeSelector: #newSourceCode! - -!methodRemoval: ExtractAsParameter #newSourceCode stamp: 'Install-4886-ExtractAsParameterMultiOcurrences-HernanWilkinson-2021Sep24-17h18m-HAW.001.cs.st 10/14/2021 14:31:53'! -newSourceCode - - | intermediateSourceCode newInterval newSourceCode originalSourceCodeSize intermediateMethod | - - originalSourceCodeSize := sourceMethod sourceCode size. - intermediateMethod := sourceMethod methodClass >> self newSelector. - intermediateSourceCode := intermediateMethod sourceCode. - newInterval := intervalToReplace + (intermediateSourceCode size - originalSourceCodeSize). - newSourceCode := intermediateSourceCode copyReplaceFrom: newInterval first to: newInterval last with: addParameter newParameter. - - ^newSourceCode ! - -ExtractAsParameter removeSelector: #initializeExtractedFrom:replacing:at:addingParameterWith:! - -!methodRemoval: ExtractAsParameter #initializeExtractedFrom:replacing:at:addingParameterWith: stamp: 'Install-4886-ExtractAsParameterMultiOcurrences-HernanWilkinson-2021Sep24-17h18m-HAW.001.cs.st 10/14/2021 14:31:53'! -initializeExtractedFrom: anIntervalToExtract replacing: anIntervalToReplace at: aSourceMethod addingParameterWith: anAddParameter - - intervalToExtract := anIntervalToExtract. - intervalToReplace := anIntervalToReplace. - sourceMethod := aSourceMethod. - addParameter := anAddParameter.! - -Refactoring subclass: #ExtractAsParameter - instanceVariableNames: 'sourceMethod addParameter intervals' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractAsParameter category: #'Tools-Refactoring' stamp: 'Install-4886-ExtractAsParameterMultiOcurrences-HernanWilkinson-2021Sep24-17h18m-HAW.001.cs.st 10/14/2021 14:31:53'! -Refactoring subclass: #ExtractAsParameter - instanceVariableNames: 'sourceMethod addParameter intervals' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -AddParameterApplier subclass: #ExtractAsParameterApplier - instanceVariableNames: 'interval intervals' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractAsParameterApplier category: #'Tools-Refactoring' stamp: 'Install-4886-ExtractAsParameterMultiOcurrences-HernanWilkinson-2021Sep24-17h18m-HAW.001.cs.st 10/14/2021 14:31:53'! -AddParameterApplier subclass: #ExtractAsParameterApplier - instanceVariableNames: 'interval intervals' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4886-ExtractAsParameterMultiOcurrences-HernanWilkinson-2021Sep24-17h18m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4879] on 25 September 2021 at 3:39:39 pm'! -!ExtractAsParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 9/25/2021 15:39:23' prior: 50611333! - askToReplaceAll - - | extractAll | - - extractAll := PopUpMenu - confirm: 'Do you want to extract all occurrences?' - trueChoice: 'Yes, extract all occurrences' - falseChoice: 'No, extract only the selected one'. - - extractAll ifFalse: [ intervals := { interval } ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4887-ExtractAsParameterTypo-HernanWilkinson-2021Sep24-20h40m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4887] on 27 September 2021 at 9:55:42 am'! -!GeometryTransformation methodsFor: 'testing' stamp: 'jmv 9/27/2021 09:52:51'! - isPureMirroring - "Return true if the receiver specifies no translation, rotation or scaling, and just mirrors the Y axis." - - ^ false! ! -!AffineTransformation methodsFor: 'testing' stamp: 'jmv 9/27/2021 09:52:19' overrides: 50611675! - isPureMirroring - "Return true if the receiver specifies no translation, rotation or scaling, and just mirrors the Y axis." - - ^self a11 = 1.0 and: [ self a12 = 0.0 and: [ - self a21 = 0.0 and: [ self a22 = -1.0 and: [ - self a13 = 0.0 and: [ self a23 = 0.0 ]]]]]! ! -!AffineTransformation methodsFor: 'testing' stamp: 'jmv 9/27/2021 09:51:11' prior: 16778544 overrides: 50408218! - isPureTranslation - "Return true if the receiver specifies no rotation or scaling." - - - ^self a11 = 1.0 and: [ self a12 = 0.0 and: [ - self a21 = 0.0 and: [ self a22 = 1.0 ]]]! ! -!MovableMorph methodsFor: 'initialization' stamp: 'jmv 9/27/2021 09:53:27' prior: 50604093 overrides: 50554573! - openInWorld: aWorld - "Add this morph to the requested World." - - location isIdentity - ifTrue: [ "Identity means default location on creation. Not an actual position to honor." - aWorld - addMorph: self - position: (Display width*7//10) atRandom@(Display height*8//10) atRandom ] - ifFalse: [ - location isPureMirroring - ifTrue: [ "But not the identity. Default location on creation if #yAxisPointsUp" - aWorld - addMorph: self - position: (Display width*7//10) atRandom@(Display height*6//10) atRandom + ((Display width //4)@ Display height //3) ] - ifFalse: [ - aWorld addMorph: self ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4888-BetterDefaultPositionsForNewMorphs-JuanVuletich-2021Sep27-09h55m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4888] on 27 September 2021 at 11:37:25 am'! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 9/27/2021 11:30:21' prior: 50593617 overrides: 50575546! - morphPosition: aPoint - "Change the position of this morph. Argument is in owner's coordinates." - - | prevTranslation | - prevTranslation _ location translation. - location _ location withTranslation: aPoint. - "Ask if translation effectively changed, after possible conversion to 32 bit Float in AffineTransformation. " - location translation = prevTranslation ifFalse: [ - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ].! ! -!WorldMorph methodsFor: 'drawing' stamp: 'jmv 9/27/2021 11:37:17' prior: 50607612! - displayWorld - "Update this world's display." - - | deferredUpdateVMMode worldDamageRects handsToDraw allDamage | - self checkIfUpdateNeeded ifFalse: [ ^ self ]. "display is already up-to-date" - "I (jmv) removed the call to 'deferUpdates: false' below. No more need to call this every time." - deferredUpdateVMMode _ self tryDeferredUpdatingAndSetCanvas. - - "repair world's damage on canvas" - worldDamageRects _ canvas drawWorld: self repair: damageRecorder. - " - worldDamageRects do: [ :r | Display border: r width: 3 fillColor: Color random ]. 'Debugging Aid'. - " - - "Check which hands need to be drawn (they are not the hardware mouse pointer)" - handsToDraw _ self selectHandsToDrawForDamage: worldDamageRects. - allDamage _ Array streamContents: [ :strm | - strm nextPutAll: worldDamageRects. - handsToDraw do: [ :h | - h savePatchFrom: canvas appendDamageTo: strm ]]. - - "Draw hands (usually carying morphs) onto world canvas" - canvas newClipRect: nil. - handsToDraw reverseDo: [ :h | canvas fullDrawHand: h ]. - - "quickly copy altered rects of canvas to Display:" - deferredUpdateVMMode ifFalse: [ - "Drawing was done to off-Display canvas. Copy content to Display" - canvas showAt: self viewBox origin invalidRects: allDamage ]. - - "Display deferUpdates: false." - "Display forceDisplayUpdate" - DisplayScreen isDisplayExtentOk ifTrue: [ - Display forceDamageToScreen: allDamage ]. - - "Restore world canvas under hands and their carried morphs" - handsToDraw do: [ :h | h restoreSavedPatchOn: canvas ].! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 9/27/2021 11:37:03' prior: 50605351! - doOneCycle - "Do one cycle of the interaction loop. This method is called repeatedly when the world is running. - - Make for low cpu usage if the ui is inactive, but quick response when ui is in use. - However, after some inactivity, there will be a larger delay before the ui gets responsive again." - - | wait waitUntil | - " - 'Debugging Aid'. - Display fill: (15@1515 extent: 200@30) fillColor: Color white. - (Time localMillisecondClock - lastCycleTime) printString displayAt: 20@1520. - Display forceToScreen. - " - waitDelay ifNil: [ waitDelay _ Delay forMilliseconds: 50 ]. - (lastCycleHadAnyEvent or: [ deferredUIMessages isEmpty not ]) - ifTrue: [ - pause _ 20. "This value will only be used later, when there are no more events to serve or deferred UI messages to process." - wait _ 0. "Don't wait this time"] - ifFalse: [ - "wait between 20 and 200 milliseconds" - (hands anySatisfy: [ :h | h waitingForMoreClicks ]) - ifTrue: [ pause _ 20 ] - ifFalse: [ pause < 200 ifTrue: [ pause _ pause * 21//20 ] ]. - waitUntil _ lastCycleTime + pause. - "Earlier if steps" - stepList isEmpty not ifTrue: [ - waitUntil _ waitUntil min: stepList first scheduledTime ]. - "Earlier if alarms" - alarms ifNotNil: [ - alarms isEmpty not ifTrue: [ - waitUntil _ waitUntil min: alarms first scheduledTime ]]. - wait _ waitUntil - Time localMillisecondClock max: 0 ]. - Preferences serverMode - ifTrue: [ wait _ wait max: 50 ]. "Always wait at least a bit on servers, even if this makes the UI slow." - wait = 0 - ifTrue: [ Processor yield ] - ifFalse: [ - waitDelay beingWaitedOn - ifFalse: [ waitDelay setDelay: wait; wait ] - ifTrue: [ - "If we are called from a different process than that of the main UI, we might be called in the main - interCyclePause. In such case, use a new Delay to avoid 'This Delay has already been scheduled' errors" - (Delay forMilliseconds: wait) wait ]]. - - "Record start time of this cycle, and do cycle" - lastCycleTime _ Time localMillisecondClock. - lastCycleHadAnyEvent _ self doOneCycleNow.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4889-AvoidSuperfluousInvalidation-JuanVuletich-2021Sep27-11h32m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4889] on 27 September 2021 at 5:22:48 pm'! -!KernelMorph methodsFor: 'drawing' stamp: 'jmv 9/27/2021 17:20:50' prior: 50609380 overrides: 50607548! -imageForm: extentOrNil depth: depth - - | answerExtent answer auxCanvas | - self requiresVectorCanvas ifFalse: [ - answerExtent _ extent. - extentOrNil ifNotNil: [ answerExtent _ answerExtent min: extentOrNil * 4 ]. - auxCanvas _ MorphicCanvas depth: depth over: (self morphPosition floor extent: answerExtent ceiling). - auxCanvas fullDraw: self. - answer _ auxCanvas form divideByAlpha. - extentOrNil ifNotNil: [ answer _ answer magnifyTo: extentOrNil ]. - ^answer ]. - ^super imageForm: extentOrNil depth: depth.! ! -!WidgetMorph methodsFor: 'drawing' stamp: 'jmv 9/27/2021 17:20:55' prior: 50608056 overrides: 50607548! - imageForm: extentOrNil depth: depth - - | answerExtent answer auxCanvas | - self requiresVectorCanvas ifFalse: [ - answerExtent _ extent. - extentOrNil ifNotNil: [ answerExtent _ answerExtent min: extentOrNil * 4 ]. - auxCanvas _ MorphicCanvas depth: depth over: (self morphPosition floor extent: answerExtent ceiling). - auxCanvas fullDraw: self. - answer _ auxCanvas form divideByAlpha. - extentOrNil ifNotNil: [ answer _ answer magnifyTo: extentOrNil ]. - ^answer ]. - ^super imageForm: extentOrNil depth: depth.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4890-defaultCanvas-for-imageForm-JuanVuletich-2021Sep27-16h48m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4890] on 28 September 2021 at 2:40:47 pm'! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 9/28/2021 12:35:45'! - offAxisHeightFor: aMorph within: availableHeight - "Answer height for a single morph -- offAxis calculation for a Row" - - | availableForPropHeight actualPropHeight | - availableForPropHeight := availableHeight - (2 * self ySeparation). - actualPropHeight := (availableForPropHeight * aMorph layoutSpec proportionalLayoutHeight) - max: aMorph minimumLayoutHeight. - ^ actualPropHeight! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 9/28/2021 12:35:50'! - offAxisWidthFor: aMorph within: availableWidth - "Answer width for a single morph -- offAxis calculation for a Column" - - | availableForPropWidth actualPropWidth | - availableForPropWidth := availableWidth - (2 * self xSeparation). - actualPropWidth := (availableForPropWidth * aMorph layoutSpec proportionalLayoutWidth) - max: aMorph minimumLayoutWidth. - ^ actualPropWidth! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 9/28/2021 12:37:54'! - offAxisXOffsetFor: aMorph within: availableWidth - "Answer x offset for a single morph -- offAxis calculation for a Column" - - | leftOver | - leftOver := availableWidth - (2 * self xSeparation). - ^ self xSeparation - + (leftOver * aMorph layoutSpec offAxisEdgeWeight). "first X, edge shifted"! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 9/28/2021 12:37:57'! - offAxisYOffsetFor: aMorph within: availableHeight - "Answer y offset for a single morph -- offAxis calculation for a Row" - - | leftOver | - leftOver := availableHeight - (2 * self ySeparation). - ^ self ySeparation - + (leftOver * aMorph layoutSpec offAxisEdgeWeight). "first Y, edge shifted"! ! -!LayoutMorph methodsFor: 'accessing' stamp: 'jmv 9/28/2021 12:30:37' prior: 50521409! - axisEdgeWeight - - ^ axisEdgeWeight ifNil: [ - direction == #horizontal - ifTrue: [0.0] - ifFalse: [0.5]]! ! -!LayoutMorph methodsFor: 'initialization' stamp: 'jmv 9/28/2021 12:29:22' prior: 50520086! - beColumn - "Establish the major layout axis, with default edge weight" - - direction _ #vertical. - axisEdgeWeight ifNil: [self axisEdgeWeight: #center]. - self layoutSubmorphs.! ! -!LayoutMorph methodsFor: 'initialization' stamp: 'jmv 9/28/2021 12:29:27' prior: 50520095! - beRow - "Establish the major layout axis, with default edge weight" - - direction _ #horizontal. - axisEdgeWeight ifNil: [self axisEdgeWeight: #rowLeft]. - self layoutSubmorphs.! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 9/28/2021 12:34:38' prior: 50540567! - layoutSubmorphsHorizontallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - - | visibleSubmorphs gap widths - widthToAllocate leftOver x height y | - "Preconditions: self isRow & morphExtent >= minimumLayoutExtent" - (visibleSubmorphs := self submorphsToLayout reversed "Display Order") - ifEmpty: [ ^ self. "Nothing to layout, besides `sum` below, would fail" ]. - - gap := self xSeparation. - widthToAllocate := (boundsForLayout width - ((visibleSubmorphs size + 1) * gap)). - widths := self widthsFor: visibleSubmorphs within: widthToAllocate. - leftOver := widthToAllocate - widths sum. - x := boundsForLayout left - + gap - + (leftOver * self axisEdgeWeight). "first X, edge shifted" - - visibleSubmorphs with: widths do: [ :sm :smWidth | - height := self offAxisHeightFor: sm within: boundsForLayout height. - y _ self offAxisYOffsetFor: sm within: boundsForLayout height - height. - sm morphPosition: x @ (boundsForLayout top + y). - sm morphExtent: smWidth @ height. - x := x + smWidth + gap. - ]! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 9/28/2021 12:34:53' prior: 50540613! - layoutSubmorphsVerticallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - - | visibleSubmorphs gap heights - heightToAllocate leftOver y width x | - "Preconditions: self isRow & morphExtent >= minimumLayoutExtent" - (visibleSubmorphs := self submorphsToLayout reversed "Display Order") - ifEmpty: [ ^ self. "Nothing to layout, besides `sum` below, would fail" ]. - - gap := self ySeparation. - heightToAllocate := (boundsForLayout height - ((visibleSubmorphs size + 1) * gap)). - heights := self heightsFor: visibleSubmorphs within: heightToAllocate. - leftOver := heightToAllocate - heights sum. - y := boundsForLayout top - + gap - + (leftOver * self axisEdgeWeight). "first Y, edge shifted" - - visibleSubmorphs with: heights do: [ :sm :smHeight | - width := self offAxisWidthFor: sm within: boundsForLayout width. - x _ self offAxisXOffsetFor: sm within: boundsForLayout width - width. - sm morphPosition: boundsForLayout left + x @ y. - sm morphExtent: width @ smHeight. - y := y + smHeight + gap. - ]! ! -!LayoutSpec methodsFor: 'accessing' stamp: 'jmv 9/28/2021 12:37:14' prior: 50521667! - offAxisEdgeWeight - ^offAxisEdgeWeight ifNil: [ 0.5 ]! ! - -LayoutMorph removeSelector: #offVerticalMetricFor:withinExtent:! - -!methodRemoval: LayoutMorph #offVerticalMetricFor:withinExtent: stamp: 'Install-4891-Layouts-refactor-JuanVuletich-2021Sep28-14h38m-jmv.002.cs.st 10/14/2021 14:31:53'! -offVerticalMetricFor: aMorph withinExtent: boundsForLayout - "Answer a point: x@width for a single morph -- offAxis calculation for a Column" - - | spec minMorphWidth theSeparation proportionalWidth - availableForPropWidth actualPropWidth - leftOver xPos | - spec := aMorph layoutSpec. - theSeparation := self xSeparation. - minMorphWidth := aMorph minimumLayoutWidth. - availableForPropWidth := (boundsForLayout width) - (2 * theSeparation). - proportionalWidth := spec proportionalLayoutWidth min: 1.0. - actualPropWidth := (availableForPropWidth * proportionalWidth) - max: minMorphWidth. - leftOver := availableForPropWidth - actualPropWidth. - - xPos := boundsForLayout origin x - + theSeparation - + (leftOver * (spec offAxisEdgeWeight ifNil: [0.5])). "first X, edge shifted" - - ^ xPos @ actualPropWidth - ! - -LayoutMorph removeSelector: #offHorizontalMetricFor:withinExtent:! - -!methodRemoval: LayoutMorph #offHorizontalMetricFor:withinExtent: stamp: 'Install-4891-Layouts-refactor-JuanVuletich-2021Sep28-14h38m-jmv.002.cs.st 10/14/2021 14:31:53'! -offHorizontalMetricFor: aMorph withinExtent: boundsForLayout - "Answer a point: height@y for a single morph -- offAxis calculation for a Row" - - | spec minMorphHeight theSeparation proportionalHeight - availableForPropHeight actualPropHeight - leftOver yPos | - spec := aMorph layoutSpec. - theSeparation := self ySeparation. - minMorphHeight := aMorph minimumLayoutHeight. - availableForPropHeight := (boundsForLayout height) - (2 * theSeparation).. - proportionalHeight := spec proportionalLayoutHeight min: 1.0. - actualPropHeight := (availableForPropHeight * proportionalHeight) - max: minMorphHeight. - leftOver := availableForPropHeight - actualPropHeight. - - yPos := boundsForLayout origin y - + theSeparation - + (leftOver * (spec offAxisEdgeWeight ifNil: [0.5])). "first Y, edge shifted" - - ^ actualPropHeight @ yPos - - ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4891-Layouts-refactor-JuanVuletich-2021Sep28-14h38m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4891] on 28 September 2021 at 3:55:27 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 9/28/2021 15:52:47'! - morphExtentInOwner - - ^self fullBoundsInOwner extent! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 9/28/2021 15:31:59'! - fitInto: aRectangle - "Change the position and extent of this morph. Arguments are owner's coordinates. - See inheritance: For general, non resizeable morphs, adjust position and scale." - - self morphPosition: aRectangle origin. - self morphExtentInOwner: aRectangle extent.! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 9/28/2021 15:17:52' overrides: 50612152! - morphExtentInOwner - - ^self externalizeDistance: extent! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 9/28/2021 15:17:17'! - morphExtentInOwner: newExtent - - self morphExtent: (self internalizeDistance: newExtent).! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 9/28/2021 15:21:10'! - morphHeightInOwner: newHeight - - self morphExtentInOwner: self morphExtentInOwner x @ newHeight! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 9/28/2021 15:21:31'! - morphWidthInOwner: newWidth - - self morphExtentInOwner: newWidth @ self morphExtentInOwner y! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 9/28/2021 15:32:02'! - fitInto: aRectangle - "Change the position and extent of this morph. Arguments are owner's coordinates. - See inheritance: For general, non resizeable morphs, adjust position and scale." - - self morphPosition: aRectangle origin. - self morphExtentInOwner: aRectangle extent.! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 9/28/2021 15:25:52' overrides: 50612152! - morphExtentInOwner - - ^self externalizeDistance: extent! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 9/28/2021 15:25:58'! - morphExtentInOwner: newExtent - - self morphExtent: (self internalizeDistance: newExtent).! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 9/28/2021 15:26:21'! - morphHeightInOwner: newHeight - - self morphExtentInOwner: self morphExtentInOwner x @ newHeight! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 9/28/2021 15:26:31'! - morphWidthInOwner: newWidth - - self morphExtentInOwner: newWidth @ self morphExtentInOwner y! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 9/28/2021 15:27:35' prior: 50593629! - morphPosition: newPos extent: newExtent - "Change the position and extent of this morph. Arguments are owner's coordinates." - - self morphPosition: newPos. - self morphExtentInOwner: newExtent.! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 9/28/2021 15:27:28' prior: 50593653! - morphPosition: newPos extent: newExtent - "Change the position and extent of this morph. Arguments are owner's coordinates." - - self morphPosition: newPos. - self morphExtentInOwner: newExtent.! ! -!LayoutMorph methodsFor: 'adjust' stamp: 'jmv 9/28/2021 15:23:25' prior: 50579864! - adjustHorizontallyBy: aLayoutAdjustMorph at: localPoint - | delta l ls r rs lNewWidth rNewWidth i lCurrentWidth rCurrentWidth | - i _ submorphs indexOf: aLayoutAdjustMorph. - ((i = 1) or: [i = self submorphs size]) ifTrue: [ - self inform: 'LayoutAdjustingMorphs require morphs before and after'. - ^self - ]. - l _ self submorphs at: i +1. - ls _ l layoutSpec. - lCurrentWidth _ l morphExtentInOwner x max: 1. "avoid division by zero" - r _ self submorphs at: i - 1. - rs _ r layoutSpec. - rCurrentWidth _ r morphExtentInOwner x max: 1. "avoid division by zero" - delta _ localPoint x - aLayoutAdjustMorph referencePositionInOwner x. - delta _ delta max: l minimumShrinkWidth - lCurrentWidth. - delta _ delta min: rCurrentWidth - r minimumShrinkWidth. - delta = 0 ifTrue: [ ^self ]. - rNewWidth _ rCurrentWidth - delta. - lNewWidth _ lCurrentWidth + delta. - (ls isProportionalWidth and: [ rs isProportionalWidth ]) - ifTrue: [ | leftNewProportion rightNewProportion toDistribute | "If both proportional, update them" - leftNewProportion _ lNewWidth / (lNewWidth + rNewWidth). - rightNewProportion _ 1.0 - leftNewProportion. - toDistribute _ ls proportionalLayoutWidth + rs proportionalLayoutWidth. - ls setProportionalWidth: leftNewProportion * toDistribute. - rs setProportionalWidth: rightNewProportion * toDistribute ] - ifFalse: ["If at least one is fixed, update only the fixed" - ls isProportionalWidth ifFalse: [ - ls fixedOrMorphWidth: lNewWidth ]. - rs isProportionalWidth ifFalse: [ - rs fixedOrMorphWidth: rNewWidth ]]. - self layoutSubmorphs.! ! -!LayoutMorph methodsFor: 'adjust' stamp: 'jmv 9/28/2021 15:23:58' prior: 50579915! - adjustVerticallyBy: aLayoutAdjustMorph at: localPoint - | delta t ts b bs tNewHeight bNewHeight i tCurrentHeight bCurrentHeight | - i _ submorphs indexOf: aLayoutAdjustMorph. - ((i = 1) or: [i = self submorphs size]) ifTrue: [ - self inform: 'LayoutAdjustingMorphs require morphs above and below'. - ^self - ]. t _ self submorphs at: i +1. - ts _ t layoutSpec. - tCurrentHeight _ t morphExtentInOwner y max: 1. "avoid division by zero" - b _ self submorphs at: i - 1. - bs _ b layoutSpec. - bCurrentHeight _ b morphExtentInOwner y max: 1. "avoid division by zero" - delta _ localPoint y - aLayoutAdjustMorph referencePositionInOwner y. - delta _ delta max: t minimumShrinkHeight - tCurrentHeight. - delta _ delta min: bCurrentHeight - b minimumShrinkHeight. - delta = 0 ifTrue: [ ^self ]. - tNewHeight _ tCurrentHeight + delta. - bNewHeight _ bCurrentHeight - delta. - (ts isProportionalHeight and: [ bs isProportionalHeight ]) - ifTrue: [ | bottomNewProportion toDistribute topNewProportion | "If both proportional, update them" - topNewProportion _ tNewHeight / (tNewHeight + bNewHeight). - bottomNewProportion _ 1.0 - topNewProportion. - toDistribute _ ts proportionalLayoutHeight + bs proportionalLayoutHeight. - ts setProportionalHeight: topNewProportion * toDistribute. - bs setProportionalHeight: bottomNewProportion * toDistribute ] - ifFalse: ["If at least one is fixed, update only the fixed" - ts isProportionalHeight ifFalse: [ - ts fixedOrMorphHeight: tNewHeight ]. - bs isProportionalHeight ifFalse: [ - bs fixedOrMorphHeight: bNewHeight ]]. - self layoutSubmorphs! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 9/28/2021 15:43:44' prior: 50612004! - layoutSubmorphsHorizontallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - - | visibleSubmorphs gap widths - widthToAllocate leftOver x height y | - "Preconditions: self isRow & morphExtent >= minimumLayoutExtent" - (visibleSubmorphs := self submorphsToLayout reversed "Display Order") - ifEmpty: [ ^ self. "Nothing to layout, besides `sum` below, would fail" ]. - - gap := self xSeparation. - widthToAllocate := (boundsForLayout width - ((visibleSubmorphs size + 1) * gap)). - widths := self widthsFor: visibleSubmorphs within: widthToAllocate. - leftOver := widthToAllocate - widths sum. - x := boundsForLayout left - + gap - + (leftOver * self axisEdgeWeight). "first X, edge shifted" - - visibleSubmorphs with: widths do: [ :sm :smWidth | - height := self offAxisHeightFor: sm within: boundsForLayout height. - y _ self offAxisYOffsetFor: sm within: boundsForLayout height - height. - sm fitInto: (x @ (boundsForLayout top + y) extent: smWidth @ height). - x := x + smWidth + gap. - ]! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 9/28/2021 15:41:41' prior: 50612039! - layoutSubmorphsVerticallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - - | visibleSubmorphs gap heights - heightToAllocate leftOver y width x | - "Preconditions: self isRow & morphExtent >= minimumLayoutExtent" - (visibleSubmorphs := self submorphsToLayout reversed "Display Order") - ifEmpty: [ ^ self. "Nothing to layout, besides `sum` below, would fail" ]. - - gap := self ySeparation. - heightToAllocate := (boundsForLayout height - ((visibleSubmorphs size + 1) * gap)). - heights := self heightsFor: visibleSubmorphs within: heightToAllocate. - leftOver := heightToAllocate - heights sum. - y := boundsForLayout top - + gap - + (leftOver * self axisEdgeWeight). "first Y, edge shifted" - - visibleSubmorphs with: heights do: [ :sm :smHeight | - width := self offAxisWidthFor: sm within: boundsForLayout width. - x _ self offAxisXOffsetFor: sm within: boundsForLayout width - width. - sm fitInto: (boundsForLayout left + x @ y extent: width @ smHeight). - y := y + smHeight + gap. - ]! ! -!LayoutSpec methodsFor: 'accessing' stamp: 'jmv 9/28/2021 15:19:43' prior: 50513174! - fixedHeight - ^proportionalHeight isNil ifTrue: [fixedHeight ifNil: [morph morphExtentInOwner y]] ifFalse: [ 0 ]! ! -!LayoutSpec methodsFor: 'accessing' stamp: 'jmv 9/28/2021 15:22:19' prior: 50520455! - fixedOrMorphHeight: aNumber - "aNumber is taken as the fixed height to use. - No proportional part." - fixedHeight - ifNotNil: [ fixedHeight _ aNumber ] - ifNil: [ fixedHeight _ aNumber. - morph morphHeightInOwner: aNumber - ]. - proportionalHeight _ nil! ! -!LayoutSpec methodsFor: 'accessing' stamp: 'jmv 9/28/2021 15:22:31' prior: 50520466! - fixedOrMorphWidth: aNumber - "aNumber is taken as the fixed width to use. - No proportional part." - fixedWidth - ifNotNil: [ fixedWidth _ aNumber ] - ifNil: [ fixedWidth _ aNumber. - morph morphWidthInOwner: aNumber ]. - proportionalWidth _ nil! ! -!LayoutSpec methodsFor: 'accessing' stamp: 'jmv 9/28/2021 15:20:04' prior: 50513518! - fixedWidth - ^proportionalWidth isNil ifTrue: [fixedWidth ifNil: [morph morphExtentInOwner x]] ifFalse: [ 0 ]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 9/28/2021 15:19:48' prior: 50500205! - fixedOrMinimumLayoutHeight - ^fixedHeight ifNil: [ morph morphExtentInOwner y ]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 9/28/2021 15:20:00' prior: 50500210! - fixedOrMinimumLayoutWidth - ^fixedWidth ifNil: [ morph morphExtentInOwner x ]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 9/28/2021 15:19:55' prior: 50519741! - minimumSpecHeight - "If fixedHeight is not nil, use it. - If fixdHeight and propostionlHeight are nil, use morphHeight" - - ^ fixedHeight ifNil: [ proportionalHeight ifNotNil: [ 0 ] ifNil: [ morph morphExtentInOwner y ] ]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 9/28/2021 15:20:08' prior: 50519750! - minimumSpecWidth - "If fixedWidth is not nil, use it. - If fixdWidth and propostionlWidth are nil, use morphWidth" - - ^ fixedWidth ifNil: [ proportionalWidth ifNotNil: [ 0 ] ifNil: [ morph morphExtentInOwner x ] ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4892-Layouts-refactor-JuanVuletich-2021Sep28-15h39m-jmv.003.cs.st----! - -'From Cuis 5.0 [latest update: #4892] on 28 September 2021 at 4:26:44 pm'! -!MovableMorph methodsFor: 'layout-properties' stamp: 'jmv 9/28/2021 16:08:01' prior: 50554447! - layoutSpec: aLayoutSpec - "Layout specific. Set the layout spec describing where the receiver should appear in a proportional layout" - self layoutSpec == aLayoutSpec ifTrue: [ ^self ]. - aLayoutSpec morph: self. - layoutSpec := aLayoutSpec. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]! ! - -WidgetMorph removeSelector: #layoutSpec:! - -!methodRemoval: WidgetMorph #layoutSpec: stamp: 'Install-4893-LayoutSpec-fix-JuanVuletich-2021Sep28-16h08m-jmv.001.cs.st 10/14/2021 14:31:53'! -layoutSpec: aLayoutSpec - "Layout specific. Set the layout spec describing where the receiver should appear in a proportional layout" - self layoutSpec == aLayoutSpec ifTrue: [ ^self ]. - aLayoutSpec morph: self. - layoutSpec := aLayoutSpec. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4893-LayoutSpec-fix-JuanVuletich-2021Sep28-16h08m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4893] on 28 September 2021 at 4:49:34 pm'! -!KernelMorph methodsFor: 'layout-properties' stamp: 'jmv 9/28/2021 16:47:56' overrides: 50554436! - layoutSpec - "Layout specific. Return the layout spec describing where the - receiver should appear in a proportional layout" - - layoutSpec ifNotNil: [ :ls | ^ ls ]. - layoutSpec := LayoutSpec keepMorphExtent. - layoutSpec morph: self. - - ^ layoutSpec! ! -!WidgetMorph methodsFor: 'layout-properties' stamp: 'jmv 9/28/2021 16:48:09' overrides: 50554436! - layoutSpec - "Layout specific. Return the layout spec describing where the - receiver should appear in a proportional layout" - - layoutSpec ifNotNil: [ :ls | ^ ls ]. - layoutSpec := LayoutSpec keepMorphExtent. - layoutSpec morph: self. - - ^ layoutSpec! ! -!MovableMorph methodsFor: 'layout-properties' stamp: 'jmv 9/28/2021 16:48:18' prior: 50554436! - layoutSpec - "Layout specific. Return the layout spec describing where the - receiver should appear in a proportional layout" - - layoutSpec ifNotNil: [ :ls | ^ ls ]. - layoutSpec _ LayoutSpec useAll. - layoutSpec morph: self. - - ^ layoutSpec ! ! - -LayoutMorph removeSelector: #layoutSpec! - -!methodRemoval: LayoutMorph #layoutSpec stamp: 'Install-4894-defaultLayoutSpec-enhancement-JuanVuletich-2021Sep28-16h47m-jmv.001.cs.st 10/14/2021 14:31:53'! -layoutSpec - "Layout specific. Return the layout spec describing where the - receiver should appear in a proportional layout" - - layoutSpec ifNotNil: [ :ls | ^ ls ]. - layoutSpec _ LayoutSpec useAll. - layoutSpec morph: self. - - ^ layoutSpec ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4894-defaultLayoutSpec-enhancement-JuanVuletich-2021Sep28-16h47m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4894] on 29 September 2021 at 5:05:07 pm'! -!LayoutMorph methodsFor: 'layout in owner' stamp: 'jmv 3/3/2016 09:43' overrides: 50612539! - layoutSpec - "Layout specific. Return the layout spec describing where the - receiver should appear in a proportional layout" - - layoutSpec ifNotNil: [ :ls | ^ ls ]. - layoutSpec _ LayoutSpec useAll. - layoutSpec morph: self. - - ^ layoutSpec ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4895-FixBreakageIn4894-JuanVuletich-2021Sep29-17h03m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4895] on 3 October 2021 at 9:16:42 pm'! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 10/3/2021 19:51:20'! - hideHardwareCursor - - | blankCursor | - blankCursor _ Cursor cursorAt: #blankCursor. - Cursor currentCursor == blankCursor ifFalse: [ - blankCursor activateCursor ].! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 10/3/2021 20:58:03'! - savePatchFrom: aCanvas - "Save the part of the given canvas under this hand as a Form and return its bounding rectangle." - - | fullBounds answer | - fullBounds _ self displayFullBoundsForPatch intersect: (`0@0` extent: aCanvas extent). - savedPatch _ aCanvas savePatch: savedPatch bounds: fullBounds. - answer _ fullBounds. - prevFullBounds ifNotNil: [ answer _ answer quickMerge: prevFullBounds ]. - prevFullBounds _ fullBounds. - ^answer! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 10/3/2021 20:22:25'! - showHardwareCursor - - "Make the transition to using hardware cursor. - Report one final damage rectangle to erase the image of the software cursor." - Cursor currentCursor == (Cursor cursorAt: #blankCursor) ifTrue: [ - "show hardware cursor" - Cursor defaultCursor activateCursor. - self invalidateDisplayRect: self basicDisplayBounds for: nil ].! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 10/3/2021 20:42:10' overrides: 50611738! - morphPosition: aPoint - "Change the position of this morph. Argument is in owner's coordinates." - - | prevTranslation | - prevTranslation _ location translation. - location _ location withTranslation: aPoint. - "Ask if translation effectively changed, after possible conversion to 32 bit Float in AffineTransformation. " - location translation = prevTranslation ifFalse: [ - self isDrawnBySoftware ifTrue: [ - self needsRedraw: true ]].! ! -!WorldMorph methodsFor: 'hands' stamp: 'jmv 10/3/2021 21:09:56'! - handsToDrawForDamage: damageList do: aBlock - "Select the set of hands that must be redrawn because either (a) the hand itself has changed or (b) the hand intersects some damage rectangle." - - hands do: [: hand | - hand isDrawnBySoftware ifTrue: [ - hand isRedrawNeeded - ifTrue: [aBlock value: hand] - ifFalse: [ - hand displayFullBounds ifNotNil: [ :handBounds | - (damageList anySatisfy: [ :r | r intersects: handBounds]) ifTrue: [ - aBlock value: hand]]]]].! ! -!MorphicCanvas methodsFor: 'other' stamp: 'jmv 10/3/2021 21:03:48'! - showAt: pt invalidRect: updateRect - | blt | - blt _ (BitBlt toForm: Display) - sourceForm: form; - combinationRule: Form over. - blt sourceRect: updateRect; - destOrigin: updateRect topLeft + pt; - copyBits! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 10/3/2021 20:21:06' prior: 50605271! - isDrawnBySoftware - "Return true if this hand must be drawn explicitely instead of being drawn via the hardware cursor. - Note. We draw the hand as a regular morph (using #drawOn:), disabling the hardware cursor, when we carry submorphs. The reason is to lock the mouse pointer and the carried morph together. Otherwhise the carried morph would lag behind the mouse pointer. - This method answers whether the regular #drawOn: drawing mechanism is used for us. - - Check senders. Hand drawing is handled explicitly by the world, because the Hand is not a submorph of the world!!" - - ^ submorphs anySatisfy: [ :ea | ea visible ]! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 10/3/2021 20:28:53' prior: 50591884! - restoreSavedPatchOn: aCanvas - "Clear the changed flag and restore the part of the given canvas under this hand from the previously saved patch." - - prevFullBounds ifNotNil: [ - aCanvas restorePatch: savedPatch bounds: prevFullBounds. - submorphs isEmpty ifTrue: [ - prevFullBounds _ nil ]].! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 10/3/2021 20:22:19' prior: 16852041! - dropMorphs: anEvent - "Drop the morphs at the hands position" - - self submorphsReverseDo: [ :m | - "Drop back to front to maintain z-order" - self dropMorph: m event: anEvent ]. - self showHardwareCursor.! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 10/3/2021 19:50:49' prior: 50593700! - grabMorph: aMorph moveUnderHand: moveUnderHand - "Grab the given morph (i.e., add it to this hand and remove it from its current owner). - If moveUnderHand is requested or it seems neccesary anyway, move the grabbed morph under the hand." - - | grabbed positionInHandCoordinates tx bounds | - self hideHardwareCursor. - self releaseMouseFocus. "Break focus" - grabbed _ aMorph. - aMorph owner ifNotNil: [ :o | grabbed _ o aboutToGrab: aMorph ]. - grabbed ifNil: [ ^ self ]. - grabbed _ grabbed aboutToBeGrabbedBy: self. - grabbed ifNil: [ ^ self ]. - - moveUnderHand ifTrue: [ - bounds _ nil. - grabbed isInWorld ifTrue: [ - grabbed displayBounds ifNotNil: [ :r | - bounds _ r translatedBy: grabbed morphPositionInWorld negated ]]. - bounds ifNil: [ bounds _ grabbed findFullBoundsInOwner ]. - positionInHandCoordinates _ (bounds center + bounds bottomRight //2) negated. - self grabMorph: grabbed delta: positionInHandCoordinates. - ^self ]. - - positionInHandCoordinates _ (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) - morphPositionInWorld - self morphPositionInWorld. - - tx _ GeometryTransformation identity. - (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) withAllOwnersDo: [ :o | - tx _ o location composedWith: tx ]. - self withAllOwnersReverseDo: [ :o | - tx _ o location inverseTransformation composedWith: tx ]. - self grabMorph: grabbed delta: positionInHandCoordinates. - - grabbed location: tx.! ! -!WorldMorph methodsFor: 'drawing' stamp: 'jmv 10/3/2021 21:12:11' prior: 50611755! - displayWorld - "Update this world's display." - - | deferredUpdateVMMode worldDamageRects allDamage | - self checkIfUpdateNeeded ifFalse: [ ^ self ]. "display is already up-to-date" - - "I (jmv) removed the call to 'deferUpdates: false' below. No more need to call this every time. ?? revisar." - deferredUpdateVMMode _ self tryDeferredUpdatingAndSetCanvas. - - "Restore world canvas under hands and their carried morphs" - hands do: [ :h | h restoreSavedPatchOn: canvas ]. - - "repair world's damage on canvas" - worldDamageRects _ canvas drawWorld: self repair: damageRecorder. - "worldDamageRects do: [ :r | Display border: r width: 3 fillColor: Color random ]. 'Debugging Aid'." - allDamage _ Rectangle merging: worldDamageRects. - canvas newClipRect: nil. - - "Check which hands need to be drawn. - (they are not the hardware mouse pointer and carry morphs)" - self handsToDrawForDamage: worldDamageRects do: [ :h | - allDamage _ (h savePatchFrom: canvas) quickMerge: allDamage. - canvas fullDrawHand: h . - h needsRedraw: false ]. - - "quickly copy altered rects of canvas to Display:" - deferredUpdateVMMode ifFalse: [ - "Drawing was done to off-Display canvas. Copy content to Display" - canvas showAt: self viewBox origin invalidRect: allDamage ]. - - "Display deferUpdates: false." - "Display forceDisplayUpdate" - allDamage ifNotNil: [ - DisplayScreen isDisplayExtentOk ifTrue: [ - Display forceToScreen: allDamage ]].! ! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 10/3/2021 19:28:36' prior: 50595259! - displayBoundsForHand: aHand - - ^ aHand morphPosition asIntegerPoint - 8 extent: aHand morphExtent.! ! - -MorphicCanvas removeSelector: #showAt:invalidRects:! - -!methodRemoval: MorphicCanvas #showAt:invalidRects: stamp: 'Install-4896-HandWithMorph-invalidation-Fixes-JuanVuletich-2021Oct03-21h14m-jmv.001.cs.st 10/14/2021 14:31:53'! -showAt: pt invalidRects: updateRects - | blt | - blt _ (BitBlt toForm: Display) - sourceForm: form; - combinationRule: Form over. - updateRects do: - [:rect | - blt sourceRect: rect; - destOrigin: rect topLeft + pt; - copyBits]! - -WorldMorph removeSelector: #selectHandsToDrawForDamage:! - -!methodRemoval: WorldMorph #selectHandsToDrawForDamage: stamp: 'Install-4896-HandWithMorph-invalidation-Fixes-JuanVuletich-2021Oct03-21h14m-jmv.001.cs.st 10/14/2021 14:31:53'! -selectHandsToDrawForDamage: damageList - "Select the set of hands that must be redrawn because either (a) the hand itself has changed or (b) the hand intersects some damage rectangle." - - | result | - result _ OrderedCollection new. - hands do: [:hand | - hand isDrawnBySoftware ifTrue: [ - hand isRedrawNeeded - ifTrue: [result add: hand] - ifFalse: [ - hand displayFullBounds ifNotNil: [ :handBounds | - (damageList anySatisfy: [ :r | r intersects: handBounds]) ifTrue: [ - result add: hand]]]]]. - ^ result! - -HandMorph removeSelector: #savePatchFrom:appendDamageTo:! - -!methodRemoval: HandMorph #savePatchFrom:appendDamageTo: stamp: 'Install-4896-HandWithMorph-invalidation-Fixes-JuanVuletich-2021Oct03-21h14m-jmv.001.cs.st 10/14/2021 14:31:53'! -savePatchFrom: aCanvas appendDamageTo: aStream - "Save the part of the given canvas under this hand as a Form and return its bounding rectangle." - - | fullBounds | - fullBounds _ self displayFullBoundsForPatch intersect: (`0@0` extent: aCanvas extent). - savedPatch _ aCanvas savePatch: savedPatch bounds: fullBounds. - prevFullBounds _ fullBounds. - aStream nextPut: fullBounds.! - -DisplayScreen removeSelector: #forceDamageToScreen:! - -!methodRemoval: DisplayScreen #forceDamageToScreen: stamp: 'Install-4896-HandWithMorph-invalidation-Fixes-JuanVuletich-2021Oct03-21h14m-jmv.001.cs.st 10/14/2021 14:31:53'! -forceDamageToScreen: allDamage - "Force all the damage rects to the screen." - - "allDamage do: [ :r | - self forceToScreen: r ]." - "Do it at once. Otherwise, some flicking with 'broken' morphs was visible." - (Rectangle merging: allDamage) ifNotNil: [ :r | - self forceToScreen: r ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4896-HandWithMorph-invalidation-Fixes-JuanVuletich-2021Oct03-21h14m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4896] on 4 October 2021 at 9:41:13 am'! -!Preferences class methodsFor: 'misc' stamp: 'jmv 10/4/2021 09:35:45'! - cacheDisplayContentWhenMovingMorphs - "Set to false to save buffer memory, at the cost of redrawing morphs belo hand each time." - - ^ self - valueOfFlag: #cacheDisplayContentWhenMovingMorphs - ifAbsent: [ true ].! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 10/4/2021 09:27:57' prior: 50612637 overrides: 50611738! - morphPosition: aPoint - "Change the position of this morph. Argument is in owner's coordinates." - - | prevTranslation | - prevTranslation _ location translation. - location _ location withTranslation: aPoint. - "Ask if translation effectively changed, after possible conversion to 32 bit Float in AffineTransformation. " - location translation = prevTranslation ifFalse: [ - self isDrawnBySoftware ifTrue: [ - Preferences cacheDisplayContentWhenMovingMorphs - ifTrue: [ self needsRedraw: true ] - ifFalse: [self redrawNeeded ]]].! ! -!WorldMorph methodsFor: 'drawing' stamp: 'jmv 10/4/2021 09:40:33' prior: 50612774! - displayWorld - "Update this world's display." - - | deferredUpdateVMMode worldDamageRects allDamage | - self checkIfUpdateNeeded ifFalse: [ ^ self ]. "display is already up-to-date" - - "I (jmv) removed the call to 'deferUpdates: false' below. No more need to call this every time. ?? revisar." - deferredUpdateVMMode _ self tryDeferredUpdatingAndSetCanvas. - - "Restore world canvas under hands and their carried morphs" - Preferences cacheDisplayContentWhenMovingMorphs ifTrue: [ - hands do: [ :h | h restoreSavedPatchOn: canvas ]]. - - "repair world's damage on canvas" - worldDamageRects _ canvas drawWorld: self repair: damageRecorder. - "worldDamageRects do: [ :r | Display border: r width: 3 fillColor: Color random ]. 'Debugging Aid'." - allDamage _ Rectangle merging: worldDamageRects. - canvas newClipRect: nil. - - "Check which hands need to be drawn. - (they are not the hardware mouse pointer and carry morphs)" - self handsToDrawForDamage: worldDamageRects do: [ :h | - Preferences cacheDisplayContentWhenMovingMorphs - ifTrue: [ allDamage _ (h savePatchFrom: canvas) quickMerge: allDamage ] - ifFalse: [ allDamage _ h displayFullBoundsForPatch quickMerge: allDamage ]. - canvas fullDrawHand: h . - h needsRedraw: false ]. - - "quickly copy altered rects of canvas to Display:" - deferredUpdateVMMode ifFalse: [ - "Drawing was done to off-Display canvas. Copy content to Display" - canvas showAt: self viewBox origin invalidRect: allDamage ]. - - "Display deferUpdates: false." - "Display forceDisplayUpdate" - allDamage ifNotNil: [ - DisplayScreen isDisplayExtentOk ifTrue: [ - Display forceToScreen: allDamage ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4897-Preference-cacheDisplayContentWhenMovingMorphs-JuanVuletich-2021Oct04-09h39m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4897] on 6 October 2021 at 4:54:10 pm'! -!Morph methodsFor: 'drawing' stamp: 'jmv 10/4/2021 16:05:27'! - fullyCovers: aRectangle - "Answer whether our drawing completely covers aRectangle. Answer true only if we are certain" - - | answer | - answer _ true. - self on: aRectangle - ifCovered: [] - uncoveredPartsDo: [ :r | answer _ false ] - else: [ answer _ false ]. - ^answer! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 10/4/2021 11:17:41'! - on: aRectangle ifCovered: partiallyOrTotallyCoveredBlock uncoveredPartsDo: uncoveredPartBlock else: notCoveredAtAllBlock - "Find rectangles encompassing those areas in aRectangle not completely - covered by self. These are the areas that might require further drawing (of morphs below us) - All areas that might possibly be uncovered must be included. - - If aRectangle is not covered at all, or for whatever reason we don't know, evaluate notCoveredAtAllBlock. - Othewise evaluate partiallyOrTotallyCoveredBlock once, and also evaluate uncoveredPartBlock for each part in aRectangle we don't cover." - - ^ notCoveredAtAllBlock value! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 10/4/2021 14:34:32' overrides: 50613011! - on: aRectangle ifCovered: partiallyOrTotallyCoveredBlock uncoveredPartsDo: uncoveredPartBlock else: notCoveredAtAllBlock - "Find rectangles encompassing those areas in aRectangle not completely - covered by self. These are the areas that might require further drawing (of morphs below us) - All areas that might possibly be uncovered must be included. - - If aRectangle is not covered at all, or for whatever reason we don't know, evaluate notCoveredAtAllBlock. - Othewise evaluate partiallyOrTotallyCoveredBlock once, and also evaluate uncoveredPartBlock for each part in aRectangle we don't cover." - -" -ver si hacer como -addPossiblyUncoveredAreasIn: aRectangle to: aCollection -que ademas vuela." - - | bounds r e r2 | - self isOrAnyOwnerIsRotated ifTrue: [ - ^ notCoveredAtAllBlock value ]. - - color mightBeTranslucent ifTrue: [ - ^ notCoveredAtAllBlock value ]. - - bounds _ self displayBounds. - bounds ifNil: [ - ^ notCoveredAtAllBlock value ]. - - (aRectangle intersects: bounds) ifFalse: [ - ^ notCoveredAtAllBlock value ]. - - "Solid rectangle. - This will be the fastest in many cases. So, please disable rounded corners if on slow hardware!!" - partiallyOrTotallyCoveredBlock value. - aRectangle areasOutside: bounds do: [ :rect | uncoveredPartBlock value: rect ]. - - Theme current roundWindowCorners ifTrue: [ - r _ Theme current roundedWindowRadius. - e _ r@r. - r2 _ aRectangle intersect: (bounds topLeft extent: e). - r2 hasPositiveExtent ifTrue: [ uncoveredPartBlock value: r2 ]. - r2 _ aRectangle intersect: (bounds topRight - (r@0) extent: e). - r2 hasPositiveExtent ifTrue: [ uncoveredPartBlock value: r2 ]. - r2 _ aRectangle intersect: (bounds bottomLeft - (0@r)extent: e). - r2 hasPositiveExtent ifTrue: [ uncoveredPartBlock value: r2 ]. - r2 _ aRectangle intersect: (bounds bottomRight - (r@r) extent: e). - r2 hasPositiveExtent ifTrue: [ uncoveredPartBlock value: r2 ]. - ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/6/2021 16:50:48'! - drawWorld: aWorldMorph rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage backgroundDamage: newDamageFromMorphsBelow - "Redraw the damaged areas. - Draw each morph just once, merging rectanges to be repaired as needed." - - | morph morphDamage allDamage | - "Iterate from back to front." - allDamage _ Rectangle merging: newDamageFromMorphsBelow. - rootMorphs size to: 1 by: -1 do: [ :i | - morph _ rootMorphs at: i. - morphDamage _ rootMorphsDamage at: i. - morph displayFullBounds ifNotNil: [ :morphFullBounds | - newDamageFromMorphsBelow do: [ :r | | intersection | - intersection _ r intersect: morphFullBounds. - intersection hasPositiveExtent ifTrue: [ - morphDamage - ifNil: [ morphDamage _ intersection ] - ifNotNil: [ morphDamage updateMerging: intersection ]]]]. - morphDamage ifNotNil: [ - self newClipRect: morphDamage. - self fullDraw: morph. - newDamageFromMorphsBelow add: morphDamage. - allDamage _ allDamage - ifNil: [ morphDamage ] - ifNotNil: [ morphDamage updateMerging: allDamage ]]]. - ^allDamage! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 10/4/2021 19:56:07' prior: 50591925! - displayFullBoundsForPatch - "Current full bounds of hand and carried submorphs. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around). - Integer pixel coordinates!!" - - | handBounds fullBounds | - handBounds _ self displayBounds. - fullBounds _ handBounds copy. - self submorphsDo: [ :m | - fullBounds updateMerging: m displayFullBounds]. - lastPosition - ifNotNil: [ :lastPos | "When already carrying morphs around. Update rectangle to current hand position." - fullBounds _ (fullBounds translatedBy: self morphPosition-lastPos) updateMerging: handBounds ]. - ^fullBounds encompassingIntegerRectangle outsetBy: 1! ! -!WorldMorph methodsFor: 'drawing' stamp: 'jmv 10/4/2021 16:25:37' prior: 50612939! - displayWorld - "Update this world's display." - - | deferredUpdateVMMode allDamage | - self checkIfUpdateNeeded ifFalse: [ ^ self ]. "display is already up-to-date" - - "I (jmv) removed the call to 'deferUpdates: false' below. No more need to call this every time. ?? revisar." - deferredUpdateVMMode _ self tryDeferredUpdatingAndSetCanvas. - - "Restore world canvas under hands and their carried morphs" - Preferences cacheDisplayContentWhenMovingMorphs ifTrue: [ - hands do: [ :h | h restoreSavedPatchOn: canvas ]]. - - "repair world's damage on canvas" - allDamage _ canvas drawWorld: self repair: damageRecorder. - "allDamage ifNotNil: [Display border: allDamage width: 3 fillColor: Color random]. 'Debugging Aid'." - canvas newClipRect: nil. - - "Check which hands need to be drawn. - (they are not the hardware mouse pointer and carry morphs)" - self handsToDrawForDamage: allDamage do: [ :h | - Preferences cacheDisplayContentWhenMovingMorphs - ifTrue: [ allDamage _ (h savePatchFrom: canvas) quickMerge: allDamage ] - ifFalse: [ allDamage _ h displayFullBoundsForPatch quickMerge: allDamage ]. - canvas fullDrawHand: h . - h needsRedraw: false ]. - - "quickly copy altered rects of canvas to Display:" - deferredUpdateVMMode ifFalse: [ - allDamage ifNotNil: [ - "Drawing was done to off-Display canvas. Copy content to Display" - canvas showAt: self viewBox origin invalidRect: allDamage ]]. - - "Display deferUpdates: false." - "Display forceDisplayUpdate" - allDamage ifNotNil: [ - DisplayScreen isDisplayExtentOk ifTrue: [ - Display forceToScreen: allDamage ]].! ! -!WorldMorph methodsFor: 'hands' stamp: 'jmv 10/4/2021 15:29:27' prior: 50612653! - handsToDrawForDamage: aRectangle do: aBlock - "Select the set of hands that must be redrawn because either (a) the hand itself has changed or (b) the hand intersects some damage rectangle." - - hands do: [: hand | - hand isDrawnBySoftware ifTrue: [ - hand isRedrawNeeded - ifTrue: [aBlock value: hand] - ifFalse: [ - aRectangle ifNotNil: [ - hand displayFullBounds ifNotNil: [ :handBounds | - (aRectangle intersects: handBounds) ifTrue: [ - aBlock value: hand ]]]]]].! ! -!DamageRecorder methodsFor: 'recording' stamp: 'jmv 10/4/2021 10:15:45' prior: 50602302! - damageReportedOther - "Answer damage reported for no specific morph, for morphs that are not visible, and for morphs that are carried by the Hand. - Answer might include nils. Skip them." - | answer possiblyMoreRectsToMerge | - answer _ OrderedCollection new. - self pvtAccessProtect critical: [ - damageByRoot keysAndValuesDo: [ :m :r | - (m visible not or: [m owner isNil or: [m owner is: #HandMorph]]) ifTrue: [ - answer add: r]]. - otherDamage do: [ :r | answer add: r ]. - ]. - possiblyMoreRectsToMerge _ true. - [possiblyMoreRectsToMerge] whileTrue: [ - possiblyMoreRectsToMerge _ false. - answer withIndexDo: [ :r1 :i | - r1 ifNotNil: [ - i+1 to: answer size do: [ :j | | r2 | - r2 _ answer at: j. - r2 ifNotNil: [ - (r1 intersects: r2) ifTrue: [ - r1 updateMerging: r2. - answer at: j put: nil. - possiblyMoreRectsToMerge _ true ]]]]]]. - ^answer! ! -!DamageRecorder methodsFor: 'private' stamp: 'jmv 10/6/2021 16:36:18' prior: 50601801! - pvtInnerRecordInvalidRect: requestedRect for: aRootMorph - "Record the given rectangle in my damage list, a list of rectangular areas of the display that should be redraw on the next display cycle." - | newRect | - newRect _ requestedRect encompassingIntegerRectangle. - newRect == requestedRect ifTrue: [ newRect _ newRect copy ]. - aRootMorph ifNotNil: [ - (damageByRoot at: aRootMorph - ifPresent: [ :r | r updateMerging: newRect] - ifAbsent: [ damageByRoot at: aRootMorph put: newRect ]) ] - ifNil: [otherDamage add: newRect].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/6/2021 16:52:49' prior: 50559484! - computeDamage: aWorldMorph repair: aDamageRecorder rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage - "Iterate front to back while computing damage to actually repair for each morph, and for world background. - Answer uncoveredDamage, the areas where World background needs to be redrawn." - - | uncoveredDamage additionalUncoveredDamage morph morphDamage morphFullBounds | - uncoveredDamage _ aDamageRecorder damageReportedOther. - additionalUncoveredDamage _ OrderedCollection new. - - "Iterate from front to back" - 1 to: rootMorphs size do: [ :i | - morph _ rootMorphs at: i. - morphFullBounds _ morph displayFullBounds. - morphDamage _ nil. - "Reported damage can be ignored if the area fully covered by another morph above us." - (aDamageRecorder damageReportedFor: morph) ifNotNil: [ :r | | wasFullyCovered | - wasFullyCovered _ false. - 1 to: i-1 do: [ :j | - wasFullyCovered _ wasFullyCovered or: [ (rootMorphs at: j) fullyCovers: r ]]. - wasFullyCovered ifFalse: [ - uncoveredDamage add: r ]]. - "Any uncovered damage this morph may overlap must be redrawn by it." - uncoveredDamage do: [ :r | | intersection | - r ifNotNil: [ - intersection _ r intersect: morphFullBounds. - intersection hasPositiveExtent ifTrue: [ - morphDamage - ifNil: [ morphDamage _ intersection ] - ifNotNil: [ morphDamage updateMerging: intersection ]]]]. - rootMorphsDamage at: i put: morphDamage. - "Whatever we cover completely is no longer uncoveredDamage" - uncoveredDamage withIndexDo: [ :r :ri | - r ifNotNil: [ - morph - on: r - ifCovered: [uncoveredDamage at: ri put: nil] - uncoveredPartsDo: [ :r2 | additionalUncoveredDamage add: r2 ] - else: []]]. - uncoveredDamage addAll: additionalUncoveredDamage. - additionalUncoveredDamage removeAll. - ]. - - "Remove redundant rectangles" - 1 to: uncoveredDamage size do: [ :i1 | - (uncoveredDamage at: i1) ifNotNil: [ :r1 | - 1 to: uncoveredDamage size do: [ :i2 | - i1 = i2 ifFalse: [ - (uncoveredDamage at: i2) ifNotNil: [ :r2 | - (r1 containsRect: r2) - ifTrue: [ uncoveredDamage at: i2 put: nil ]]]]]]. - - "Answer any yet uncovered areas. World background should be drawn on them." - ^ uncoveredDamage select: [ :r | r notNil ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/4/2021 16:29:10' prior: 50601897! - drawWorld: aWorldMorph repair: aDamageRecorder - "Redraw the damaged areas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | visibleRootMorphs visibleRootsDamage worldBackgroundRects | - "Update #displayBounds for all dirty morphs (marked as such with #redrawNeeded). - Also add the updated bounds to aDamageRecorder, and update bounds of morphs carried by hand." - self boundsFinderCanvas updateBoundsIn: aWorldMorph addDamageTo: aDamageRecorder. - - visibleRootMorphs _ aWorldMorph privateSubmorphs select: [ :m | m visible ]. - visibleRootsDamage _ Array new: visibleRootMorphs size. - - worldBackgroundRects _ self computeDamage: aWorldMorph repair: aDamageRecorder - rootMorphs: visibleRootMorphs rootMorphsDamage: visibleRootsDamage. - aDamageRecorder reset. - - self drawWorldBackground: aWorldMorph rects: worldBackgroundRects. - "Debugging aids." - " - worldBackgroundRects do: [ :r | Display fill: r fillColor: Color random . Display forceToScreen. (Delay forSeconds: 0.005) wait]. - "" - visibleRootsDamage do: [ :r | r ifNotNil: [ Display fill: r fillColor: Color random . Display forceToScreen. (Delay forSeconds: 0.05) wait]]. - " - - ^ self drawWorld: aWorldMorph - rootMorphs: visibleRootMorphs rootMorphsDamage: visibleRootsDamage - backgroundDamage: worldBackgroundRects.! ! - -MorphicCanvas removeSelector: #drawWorld:rootMorphs:rootMorphsDamage:allDamage:! - -!methodRemoval: MorphicCanvas #drawWorld:rootMorphs:rootMorphsDamage:allDamage: stamp: 'Install-4898-Morphic-DamageByMorph-Optimization-JuanVuletich-2021Oct06-16h46m-jmv.001.cs.st 10/14/2021 14:31:53'! -drawWorld: aWorldMorph rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage allDamage: worldDamage - "Redraw the damaged areas. - Draw each morph just once, merging rectanges to be repaired as needed." - - | morph morphDamage | - - "Iterate from back to front." - rootMorphs size to: 1 by: -1 do: [ :i | - morph _ rootMorphs at: i. - morphDamage _ rootMorphsDamage at: i. - morph displayFullBounds ifNotNil: [ :morphFullBounds | - worldDamage do: [ :r | | intersection | - intersection _ r intersect: morphFullBounds. - intersection hasPositiveExtent ifTrue: [ - morphDamage _ intersection quickMerge: morphDamage ]]]. - morphDamage ifNotNil: [ - self newClipRect: morphDamage. - self fullDraw: morph. - worldDamage add: morphDamage ]].! - -SystemWindow removeSelector: #addPossiblyUncoveredAreasIn:to:! - -!methodRemoval: SystemWindow #addPossiblyUncoveredAreasIn:to: stamp: 'Install-4898-Morphic-DamageByMorph-Optimization-JuanVuletich-2021Oct06-16h46m-jmv.001.cs.st 10/14/2021 14:31:53'! -addPossiblyUncoveredAreasIn: aRectangle to: aCollection - "Answer an array of rectangles encompassing those areas in aRectangle not completely - covered by self. These are the areas that might require further drawing (of morphs below us) - All areas that might possibly be uncovered must be included." - - | bounds | - self isOrAnyOwnerIsRotated ifTrue: [ - aCollection add: aRectangle. - ^self ]. - - color mightBeTranslucent ifTrue: [ - aCollection add: aRectangle. - ^self ]. - - bounds _ self displayBounds. - bounds ifNil: [ - aCollection add: aRectangle. - ^self ]. - - "Solid rectangle. - This will be the fastest in many cases. So, please disable rounded corners if on slow hardware!!" - Theme current roundWindowCorners ifFalse: [ - aRectangle areasOutside: bounds do: [ :rect | aCollection add: rect ]. - ^self ]. - - "The solid rectangle does not include the corners. - Report a couple of rows (top and bottom) or columns (left and right) as uncovered areas. - We could also try to be more careful and answer each rounded corner... - Right now, report top and bottom rows as uncovered areas: - - Rows are contiguous in Display memory - - Redrawing title area wont trigger redrawing all windows contents." - " - radius _ Theme current roundedWindowRadius. - aRectangle areasOutside: (bounds insetBy: 0@radius) do: [ :rect | aCollection add: rect ]. - " - "Alternative: just include window borders. Almost correct, and cheaper." - aRectangle areasOutside: (bounds insetBy: Theme current windowBorderWidth) do: [ :rect | aCollection add: rect ]. - -"Note: Doing this after the non-rounded-corner case gave bad results. Not letting the size of aCollection grow without bounds is more important than not answering extra areas. - Theme current roundWindowCorners ifTrue: [ - r _ Theme current roundedWindowRadius. - e _ r@r. - aCollection add: (aRectangle intersect: (bounds topLeft extent: e)). - aCollection add: (aRectangle intersect: (bounds topRight - (r@0) extent: e)). - aCollection add: (aRectangle intersect: (bounds bottomLeft - (0@r)extent: e)). - aCollection add: (aRectangle intersect: (bounds bottomRight - (r@r) extent: e)). - ]."! - -Morph removeSelector: #addPossiblyUncoveredAreasIn:to:! - -!methodRemoval: Morph #addPossiblyUncoveredAreasIn:to: stamp: 'Install-4898-Morphic-DamageByMorph-Optimization-JuanVuletich-2021Oct06-16h46m-jmv.001.cs.st 10/14/2021 14:31:53'! -addPossiblyUncoveredAreasIn: aRectangle to: aCollection - "Answer an array of rectangles encompassing those areas in aRectangle not completely - covered by self. - All areas that might possibly be uncovered must be included." - - aCollection add: aRectangle.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4898-Morphic-DamageByMorph-Optimization-JuanVuletich-2021Oct06-16h46m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4898] on 4 October 2021 at 5:26:12 pm'! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 10/4/2021 17:22:34' prior: 50607355! - updateBoundsIn: aWorldMorph addDamageTo: aDamageRecorder - - aWorldMorph haloMorphsDo: [ :halo | - (halo target isRedrawNeeded or: [halo target isSubmorphRedrawNeeded]) ifTrue: [ - "Invalidation of halos requires this specific sequence:" - halo redrawNeeded. "invalidate old halo bounds" - "self fullAddRedrawRect: halo target to: aDamageRecorder." "recompute & invalidate target bounds" - self fullAddRedrawRect: halo to: aDamageRecorder ]]. "recompute & invalidate halo bounds" - "bogus iteration on halos and targets below is harmless: - Both now marked as neither #isRedrawNeeded nor #isSubmorphRedrawNeeded." - - aWorldMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - self updateHandsDisplayBounds: aWorldMorph.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4899-HaloTargetBoundsUpdateFix-JuanVuletich-2021Oct04-17h25m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4895] on 6 October 2021 at 4:02:52 pm'! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 10/6/2021 16:02:03' prior: 50611805! - doOneCycle - "Do one cycle of the interaction loop. This method is called repeatedly when the world is running. - - Make for low cpu usage if the ui is inactive, but quick response when ui is in use. - However, after some inactivity, there will be a larger delay before the ui gets responsive again." - - | wait waitUntil | - " - 'Debugging Aid. Declare Delta either as a class variable or as a global variable. Declare delta and r as locals'. - delta _ Time localMillisecondClock - lastCycleTime. - r _ 15@1515 extent: 60@30. - Delta _ Delta ifNil: [ delta ] ifNotNil: [ Delta * 0.9 + (delta * 0.1) ]. - Random next > 0.9 ifTrue: [ - Display fill: r fillColor: Color white. - (Delta printStringFractionDigits: 1) displayAt: 20@1520. - Display forceToScreen: r ]. - " - waitDelay ifNil: [ waitDelay _ Delay forMilliseconds: 50 ]. - (lastCycleHadAnyEvent or: [ deferredUIMessages isEmpty not ]) - ifTrue: [ - pause _ 20. "This value will only be used later, when there are no more events to serve or deferred UI messages to process." - wait _ 0. "Don't wait this time"] - ifFalse: [ - "wait between 20 and 200 milliseconds" - (hands anySatisfy: [ :h | h waitingForMoreClicks ]) - ifTrue: [ pause _ 20 ] - ifFalse: [ pause < 200 ifTrue: [ pause _ pause * 21//20 ] ]. - waitUntil _ lastCycleTime + pause. - "Earlier if steps" - stepList isEmpty not ifTrue: [ - waitUntil _ waitUntil min: stepList first scheduledTime ]. - "Earlier if alarms" - alarms ifNotNil: [ - alarms isEmpty not ifTrue: [ - waitUntil _ waitUntil min: alarms first scheduledTime ]]. - wait _ waitUntil - Time localMillisecondClock max: 0 ]. - Preferences serverMode - ifTrue: [ wait _ wait max: 50 ]. "Always wait at least a bit on servers, even if this makes the UI slow." - wait = 0 - ifTrue: [ Processor yield ] - ifFalse: [ - waitDelay beingWaitedOn - ifFalse: [ waitDelay setDelay: wait; wait ] - ifTrue: [ - "If we are called from a different process than that of the main UI, we might be called in the main - interCyclePause. In such case, use a new Delay to avoid 'This Delay has already been scheduled' errors" - (Delay forMilliseconds: wait) wait ]]. - - "Record start time of this cycle, and do cycle" - lastCycleTime _ Time localMillisecondClock. - lastCycleHadAnyEvent _ self doOneCycleNow.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 9/29/2021 10:39:57' prior: 50604464! - activeSubclass: aMorphicCanvasSubclass - " - self runningWorld canvas class - MorphicCanvas activeSubclass: BitBltCanvas - MorphicCanvas activeSubclass: HybridCanvas - MorphicCanvas activeSubclass: VectorDrawingCanvas - " - (#(BitBltCanvas HybridCanvas VectorDrawingCanvas) - includes: aMorphicCanvasSubclass name) ifFalse: [ - ^self error: 'Invalid Canvas class' ]. - ActiveSubclass _ aMorphicCanvasSubclass. - UISupervisor ui ifNotNil: [ :world | - world whenUIinSafeState: [ - world setMainCanvas ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4900-DebuggingAids-JuanVuletich-2021Oct06-15h58m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4900] on 8 October 2021 at 9:18:15 am'! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 10/7/2021 12:24:39' prior: 50613034 overrides: 50613011! - on: aRectangle ifCovered: partiallyOrTotallyCoveredBlock uncoveredPartsDo: uncoveredPartBlock else: notCoveredAtAllBlock - "Find rectangles encompassing those areas in aRectangle not completely - covered by self. These are the areas that might require further drawing (of morphs below us) - All areas that might possibly be uncovered must be included. - - If aRectangle is not covered at all, or for whatever reason we don't know, evaluate notCoveredAtAllBlock. - Othewise evaluate partiallyOrTotallyCoveredBlock once, and also evaluate uncoveredPartBlock for each part in aRectangle we don't cover." - - | bounds r e r2 | - self isOrAnyOwnerIsRotated ifTrue: [ - ^ notCoveredAtAllBlock value ]. - - color mightBeTranslucent ifTrue: [ - ^ notCoveredAtAllBlock value ]. - - bounds _ self displayBounds. - bounds ifNil: [ - ^ notCoveredAtAllBlock value ]. - - (aRectangle intersects: bounds) ifFalse: [ - ^ notCoveredAtAllBlock value ]. - - "Solid rectangle. - This will be the fastest in many cases. So, please disable rounded corners if on slow hardware!!" - partiallyOrTotallyCoveredBlock value. - aRectangle areasOutside: bounds do: [ :rect | uncoveredPartBlock value: rect ]. - - Theme current roundWindowCorners ifTrue: [ - r _ Theme current roundedWindowRadius. - e _ r@r. - r2 _ aRectangle intersect: (bounds topLeft extent: e). - r2 hasPositiveExtent ifTrue: [ uncoveredPartBlock value: r2 ]. - r2 _ aRectangle intersect: (bounds topRight - (r@0) extent: e). - r2 hasPositiveExtent ifTrue: [ uncoveredPartBlock value: r2 ]. - r2 _ aRectangle intersect: (bounds bottomLeft - (0@r)extent: e). - r2 hasPositiveExtent ifTrue: [ uncoveredPartBlock value: r2 ]. - r2 _ aRectangle intersect: (bounds bottomRight - (r@r) extent: e). - r2 hasPositiveExtent ifTrue: [ uncoveredPartBlock value: r2 ]. - ].! ! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 10/7/2021 12:23:35' prior: 50613527! - updateBoundsIn: aWorldMorph addDamageTo: aDamageRecorder - - aWorldMorph haloMorphsDo: [ :halo | - (halo target isRedrawNeeded or: [halo target isSubmorphRedrawNeeded]) ifTrue: [ - "Invalidation of halos requires this specific sequence:" - halo redrawNeeded. "invalidate old halo bounds" - self fullAddRedrawRect: halo to: aDamageRecorder ]]. "recompute & invalidate halo bounds" - "bogus iteration on halos below is harmless: - It is now marked as neither #isRedrawNeeded nor #isSubmorphRedrawNeeded." - - aWorldMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - self updateHandsDisplayBounds: aWorldMorph.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4901-tweaks-JuanVuletich-2021Oct08-09h17m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4901] on 7 October 2021 at 4:39:35 pm'! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 10/7/2021 15:41:39' overrides: 50566154! - restorePatch: savedPatch bounds: savedBounds - "Argument must previously be obtained by calling #savePatch:bounds:" - - self - image: savedPatch - at: savedBounds origin - sourceRect: (0@0 extent: savedBounds extent)! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 10/7/2021 15:42:14' overrides: 50566317! - savePatch: prevSavedPatch bounds: aRectangle - "Senders don't need to know any details of what is answered, but just store it for further calls, and calls to restorePatch:bounds:" - "Details: The previously used patch Form is recycled when possible to reduce the burden on storage management." - | savedPatch prevExtent extent | - savedPatch _ prevSavedPatch. - prevExtent _ 0@0. - ((savedPatch is: #Form) and: [ - prevExtent _ savedPatch extent. - prevExtent >= aRectangle extent]) - ifTrue: [ - savedPatch offset: 0@0 ] - ifFalse: [ - "allocate new patch form if needed" - extent _ aRectangle extent max: prevExtent. - extent _ (extent x // 64 + 2 * 64) @ (extent y + 64). "Make it slightly larger, and even width." - savedPatch _ Form extent: extent depth: form depth ]. - [ - engine sourceForm: form; combinationRule: Form over; - sourceX: aRectangle left; sourceY: aRectangle top; - width: aRectangle width; height: aRectangle height; - copyBits. - ] ensure: [ - engine setDestForm: form; sourceForm: nil ]. - ^savedPatch! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 10/7/2021 16:37:05' prior: 50603932! - drawCurrentAsOutline - - currentMorph visible ifTrue: [ - currentMorph displayBoundsSetFrom: self. - self frameReverseGlobalRect: currentMorph displayBounds borderWidth: 2 ].! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 10/7/2021 16:37:09' prior: 50575403 overrides: 50564923! - drawCurrentAndSubmorphs - - currentMorph visible ifTrue: [ - - currentMorph drawOn: self. - currentMorph displayBoundsSetFrom: self. - - "Display submorphs back to front" - "coordinate system stack already set up for aMorph - ('ivars transformations' and 'currentTransformation')" - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | self fullDraw: m ]]. - - (currentMorph postDrawOn: self) ifTrue: [ - currentMorph displayBoundsUpdateFrom: self ]. - - currentMorph isHighlighted ifTrue: [ - self drawHighlight: currentMorph ]. - ].! ! - -MorphicCanvas removeSelector: #savePatch:bounds:! - -!methodRemoval: MorphicCanvas #savePatch:bounds: stamp: 'Install-4902-cleanup-JuanVuletich-2021Oct07-16h35m-jmv.001.cs.st 10/14/2021 14:31:54'! -savePatch: prevSavedPatch bounds: aRectangle - "Senders don't need to know any details of what is answered, but just store it for further calls, and calls to restorePatch:" - "Details: The previously used patch Form is recycled when possible to reduce the burden on storage management." - | savedPatch bb prevExtent extent | - savedPatch _ prevSavedPatch. - prevExtent _ 0@0. - ((savedPatch is: #Form) and: [ - prevExtent _ savedPatch extent. - prevExtent >= aRectangle extent]) - ifTrue: [ - savedPatch offset: 0@0 ] - ifFalse: [ - "allocate new patch form if needed" - extent _ aRectangle extent max: prevExtent. - extent _ (extent x // 64 + 2 * 64) @ (extent y + 64). "Make it slightly larger, and even width." - savedPatch _ Form extent: extent depth: form depth ]. - bb _ BitBlt toForm: savedPatch. - bb sourceForm: form; combinationRule: Form over; - sourceX: aRectangle left; sourceY: aRectangle top; - width: aRectangle width; height: aRectangle height; - copyBits. - ^savedPatch! - -MorphicCanvas removeSelector: #restorePatch:bounds:! - -!methodRemoval: MorphicCanvas #restorePatch:bounds: stamp: 'Install-4902-cleanup-JuanVuletich-2021Oct07-16h35m-jmv.001.cs.st 10/14/2021 14:31:54'! -restorePatch: savedPatch bounds: savedBounds - "Argument must previously be obtained by calling #savePatch:bounds: - Senders should not assume anything about the returned object, except that it will not be nil." - -self flag: #jmvHacks. -"Podriamos usar un BitBlt guardado. Este metodo termina haciendo demasiadas cosas... (innecesarias)" - self - image: savedPatch - at: savedBounds origin - sourceRect: (0@0 extent: savedBounds extent)! - -MorphicCanvas removeSelector: #image:at:sourceRect:! - -!methodRemoval: MorphicCanvas #image:at:sourceRect: stamp: 'Install-4902-cleanup-JuanVuletich-2021Oct07-16h35m-jmv.001.cs.st 10/14/2021 14:31:54'! -image: aForm at: aPoint sourceRect: sourceRect - self subclassResponsibility.! - -MorphicCanvas removeSelector: #fillRectangle:tilingWith:multipliedBy:! - -!methodRemoval: MorphicCanvas #fillRectangle:tilingWith:multipliedBy: stamp: 'Install-4902-cleanup-JuanVuletich-2021Oct07-16h35m-jmv.001.cs.st 10/14/2021 14:31:54'! -fillRectangle: aRectangle tilingWith: aForm multipliedBy: aColor - self subclassResponsibility.! - -MorphicCanvas removeSelector: #isCurrentMorphVisible! - -!methodRemoval: MorphicCanvas #isCurrentMorphVisible stamp: 'Install-4902-cleanup-JuanVuletich-2021Oct07-16h35m-jmv.001.cs.st 10/14/2021 14:31:54'! -isCurrentMorphVisible - "Note: answer true if we are not sure." - | aRectangle myClipRect | - currentMorph visible ifFalse: [ ^false ]. - aRectangle := currentMorph displayBounds. - aRectangle ifNil: [ ^true ]. - (currentMorph firstOwnerSuchThat: [ :m | m is: #HandMorph ]) notNil ifTrue: [ ^true ]. - -self flag: #jmvHacks. - true ifTrue: [ ^true ]. - myClipRect := self clipRect. - aRectangle right < myClipRect left ifTrue: [^ false]. - aRectangle left > myClipRect right ifTrue: [^ false]. - aRectangle bottom < myClipRect top ifTrue: [^ false]. - aRectangle top > myClipRect bottom ifTrue: [^ false]. - ^ true -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4902-cleanup-JuanVuletich-2021Oct07-16h35m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4902] on 7 October 2021 at 5:32:15 pm'! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 10/7/2021 17:30:56'! - cacheTrueTypeGlyphs - "Provides significant performance improvements for text if not rotated or scaled. - Placement of each character is rounded to integer coordinates: text layout is not perfect." - - ^ self - valueOfFlag: #cacheTrueTypeGlyphs - ifAbsent: [ true ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4903-cacheTrueTypeGlyphs-JuanVuletich-2021Oct07-17h25m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4903] on 8 October 2021 at 9:38:53 am'! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 10/8/2021 09:36:16' prior: 50613764! - savePatch: prevSavedPatch bounds: aRectangle - "Senders don't need to know any details of what is answered, but just store it for further calls, and calls to restorePatch:" - "Details: The previously used patch Form is recycled when possible to reduce the burden on storage management." - | savedPatch bb prevExtent extent | - savedPatch _ prevSavedPatch. - prevExtent _ 0@0. - ((savedPatch is: #Form) and: [ - prevExtent _ savedPatch extent. - prevExtent >= aRectangle extent]) - ifTrue: [ - savedPatch offset: 0@0 ] - ifFalse: [ - "allocate new patch form if needed" - extent _ aRectangle extent max: prevExtent. - extent _ (extent x // 64 + 2 * 64) @ (extent y + 64). "Make it slightly larger, and even width." - savedPatch _ Form extent: extent depth: form depth ]. - bb _ BitBlt toForm: savedPatch. - bb sourceForm: form; combinationRule: Form over; - sourceX: aRectangle left; sourceY: aRectangle top; - width: aRectangle width; height: aRectangle height; - copyBits. - ^savedPatch! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4904-fixBugIn4902-JuanVuletich-2021Oct08-09h38m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4904] on 8 October 2021 at 9:54:33 am'! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 10/8/2021 09:46:17' prior: 50613637! - activeSubclass: aMorphicCanvasSubclass - " - self runningWorld canvas class - MorphicCanvas activeSubclass: BitBltCanvas - MorphicCanvas activeSubclass: HybridCanvas - MorphicCanvas activeSubclass: VectorCanvas - " - (#(BitBltCanvas HybridCanvas VectorCanvas) - includes: aMorphicCanvasSubclass name) ifFalse: [ - ^self error: 'Invalid Canvas class' ]. - ActiveSubclass _ aMorphicCanvasSubclass. - UISupervisor ui ifNotNil: [ :world | - world whenUIinSafeState: [ - world setMainCanvas ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4905-renamedVectorCanvasClasses-JuanVuletich-2021Oct08-09h54m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4905] on 8 October 2021 at 10:05:48 am'! -!Morph methodsFor: 'private' stamp: 'jmv 10/8/2021 10:05:28' prior: 50539711! - privateAddAllMorphs: aCollection atIndex: index - "Private. Add aCollection of morphs to the receiver" - | myWorld itsWorld otherSubmorphs | - (aCollection allSatisfy: [ :m | self canAdd: m]) ifFalse: [ - (self confirm: 'Some requested morph requires VectorGraphics support. Do you want to install and activate it?') - ifTrue: [ - Feature require: 'VectorGraphics'. - MorphicCanvas activeSubclass: (Smalltalk at: #VectorCanvas) ] - ifFalse: [ - ^self error: 'We can''t add requested morphs.' ]]. - myWorld _ self world. - otherSubmorphs _ submorphs copyWithoutAll: aCollection. - (index between: 0 and: otherSubmorphs size) - ifFalse: [^ self error: 'index out of range']. - index = 0 - ifTrue:[ submorphs _ aCollection asArray, otherSubmorphs] - ifFalse:[ index = otherSubmorphs size - ifTrue:[ submorphs _ otherSubmorphs, aCollection] - ifFalse:[ submorphs _ otherSubmorphs copyReplaceFrom: index + 1 to: index with: aCollection ]]. - aCollection do: [:m | | itsOwner | - itsOwner _ m owner. - itsOwner ifNotNil: [ - itsWorld _ m world. - (itsWorld == myWorld) ifFalse: [ - itsWorld ifNotNil: [m redrawNeeded]]. - (itsOwner ~~ self) ifTrue: [ - m owner privateRemove: m. - m owner removedMorph: m ]]. - m privateOwner: self. - myWorld ifNotNil: [m redrawNeeded]. - (myWorld == itsWorld) ifFalse: [m intoWorld: myWorld]. - itsOwner == self ifFalse: [ - self addedMorph: m. - m noteNewOwner: self ]. - ]. - self someSubmorphPositionOrExtentChanged! ! -!Morph methodsFor: 'private' stamp: 'jmv 10/8/2021 10:05:31' prior: 50555988! - privateAddMorph: aMorph atIndex: index position: aPointOrNil - - | oldIndex myWorld itsWorld oldOwner | - (self canAdd: aMorph) ifFalse: [ - (self confirm: 'The requested morph requires VectorGraphics support. Do you want to install and activate it?') - ifTrue: [ - Feature require: 'VectorGraphics'. - MorphicCanvas activeSubclass: (Smalltalk at: #VectorCanvas) ] - ifFalse: [ - ^self error: 'We can''t add requested morph.' ]]. - ((index >= 1) and: [index <= (submorphs size + 1)]) - ifFalse: [^ self error: 'index out of range']. - myWorld _ self world. - oldOwner _ aMorph owner. - (oldOwner == self and: [(oldIndex _ submorphs indexOf: aMorph) > 0]) ifTrue: [ - "aMorph's position changes within in the submorph chain" - oldIndex < index ifTrue:[ - "moving aMorph to back" - submorphs replaceFrom: oldIndex to: index-2 with: submorphs startingAt: oldIndex+1. - submorphs at: index-1 put: aMorph. - ] ifFalse:[ - "moving aMorph to front" - oldIndex-1 to: index by: -1 do:[:i| - submorphs at: i+1 put: (submorphs at: i)]. - submorphs at: index put: aMorph. - ]. - aPointOrNil ifNotNil: [aMorph privatePosition: aPointOrNil]. - ] ifFalse: [ - "adding a new morph" - oldOwner ifNotNil: [ - itsWorld _ aMorph world. - itsWorld ifNotNil: [aMorph invalidateBounds]. - oldOwner privateRemove: aMorph. - oldOwner removedMorph: aMorph. - ]. - aMorph privateOwner: self. - submorphs _ submorphs copyReplaceFrom: index to: index-1 with: (Array with: aMorph). - aPointOrNil ifNotNil: [aMorph privatePosition: aPointOrNil]. - (itsWorld == myWorld) ifFalse: [aMorph intoWorld: myWorld]. - ]. - myWorld ifNotNil: [ - index = 1 - ifTrue: [aMorph redrawNeeded ] - ifFalse: [aMorph invalidateBounds]]. - self someSubmorphPositionOrExtentChanged. - oldOwner == self ifFalse: [ - self addedMorph: aMorph. - aMorph noteNewOwner: self ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4906-StartDeprecatingHybridCanvas-JuanVuletich-2021Oct08-10h04m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4906] on 8 October 2021 at 8:12:40 pm'! - -Transcript class - instanceVariableNames: 'entries firstIndex lastIndex accessSemaphore unfinishedEntry logToFile showOnDisplay lastDisplayPosition bounds logToStdout displayCanvas displayEngine '! - -!classDefinition: 'Transcript class' category: #'System-Support' stamp: 'Install-4907-MakeTranscriptIndependentOfBitBltCanvas-JuanVuletich-2021Oct08-20h02m-jmv.001.cs.st 10/14/2021 14:31:54'! -Transcript class - instanceVariableNames: 'entries firstIndex lastIndex accessSemaphore unfinishedEntry logToFile showOnDisplay lastDisplayPosition bounds logToStdout displayCanvas displayEngine'! -!Transcript class methodsFor: 'private' stamp: 'jmv 10/8/2021 19:49:14'! - displayEngine - - (displayEngine isNil or: [ - displayEngine class ~= BitBltCanvasEngine]) ifTrue: [ - displayEngine _ BitBltCanvasEngine toForm: Display ]. - ^ displayEngine! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 10/8/2021 20:10:59'! - displayOnDisplay - "To be called directly, not from Morphic. - See #displayOnCanvas:in:" - " - 1 to: 2000 do: [ :i | i print ]. - 1 to: 750 do: [ :i | i print ]. - Transcript displayOnDisplay. - Display forceToScreen - " - | innerR | - self displayEngine. - innerR _ bounds insetBy: self padding. - displayEngine clipRect: innerR. - displayEngine - copy: innerR - from: `0@0` in: nil - fillColor: `Color white` rule: Form over. - self displayTextOn: self in: innerR.! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 10/8/2021 20:07:43'! - displayTextOn: aCanvasOrSelf in: aRectangle - "See senders" - | font count string x y fh innerR index | - font _ FontFamily defaultFamilyAndPointSize. - innerR _ aRectangle insetBy: self padding. - x _ innerR left. - y _ innerR top. - fh _ font lineSpacing. - count _ lastIndex - firstIndex \\ self maxEntries + 1 min: innerR height // fh - 1. - index _ lastIndex - count \\ self maxEntries + 1. - count timesRepeat: [ - string _ entries at: index. - aCanvasOrSelf drawString: string at: x@y font: font color: `Color veryDarkGray`. - y _ y + fh. - index _ index \\ self maxEntries + 1 ]. - string _ unfinishedEntry contents. - aCanvasOrSelf drawString: string at: x@y font: font color: `Color veryDarkGray`! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 10/8/2021 20:00:14'! - displayUnfinishedEntryOnDisplay - - | font count string x y fh r innerR | - self displayEngine. - innerR _ bounds insetBy: self padding. - lastDisplayPosition < innerR right ifTrue: [ - font _ FontFamily defaultFamilyAndPointSize. - fh _ font lineSpacing. - count _ innerR height // fh-1. - x _ innerR left. - string _ unfinishedEntry contents. - y _ ((lastIndex - firstIndex \\ self maxEntries) min: count-1) + 1 * font lineSpacing + innerR top. - r _ innerR left: lastDisplayPosition. - displayEngine clipRect: r. - (self drawString: string at: x@y font: font color: `Color veryDarkGray`) ifNotNil: [ :lastPoint | - lastDisplayPosition _ lastPoint x. - ^r ]]. - ^nil! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 10/8/2021 19:59:46'! - drawString: s at: pt font: font color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - - | p1 | - p1 _ pt rounded. - p1 _ p1 + (0@(0 - (font ascent + font lineGap-1))). - p1 _ p1 rounded. - displayEngine colorMap: nil. - ^font - onBitBltCanvasEngine: displayEngine - displayString: s - from: 1 - to: s size - at: p1 - color: aColor! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 10/8/2021 19:53:38' prior: 50541645! - display - showOnDisplay ifTrue: [ - self displayOnDisplay. - DisplayScreen screenUpdateRequired: bounds ]. - "So any morph in front of us is repaired when Morphic cycles. - This includes, for instance, the TranscriptWindow that shows our contents if showOnDisplay is false" - self triggerEvent: #redraw! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 10/8/2021 19:57:35' prior: 50541661! - displayUnfinishedEntry - showOnDisplay ifTrue: [ - self displayUnfinishedEntryOnDisplay ifNotNil: [ :damage | - DisplayScreen screenUpdateRequired: damage ]]! ! -!Transcript class methodsFor: 'system startup' stamp: 'jmv 10/8/2021 19:48:11' prior: 50541640 overrides: 50510040! - releaseClassCachedState - displayEngine _ nil! ! -!TranscriptMorph methodsFor: 'drawing' stamp: 'jmv 10/8/2021 20:10:01' prior: 50591997 overrides: 50596573! - drawOn: aCanvas - "If we don't call super, clipping fails if zoomed / rotated, and nothing is shown." - super drawOn: aCanvas. - aCanvas clippingByCurrentMorphDo: [ - aCanvas - fillRectangle: self morphLocalBounds - color: `Color white`. - Transcript displayTextOn: aCanvas in: self morphLocalBounds ]. - self displayBounds ifNotNil: [ :r | - Transcript bounds:r ]. - self updateWorkspace! ! - -Transcript class removeSelector: #canvas! - -!methodRemoval: Transcript class #canvas stamp: 'Install-4907-MakeTranscriptIndependentOfBitBltCanvas-JuanVuletich-2021Oct08-20h02m-jmv.001.cs.st 10/14/2021 14:31:54'! -canvas - "VectorCanvas is not safe WRT changes in Display extent. - Besides, it is expensive in memory. - The alternative of using (UISupervisor ui canvas) is not safe. We don't know in which state it is (currentMorph, geometry, etc), or it is in midst of state change, and inconsistent. Waiting for a safe stat is not an option: we want immeiate updates. - The only way to no longer need BitBltCanvas is to use BitBlt directly, possibly with a special StrikeFont. - That, of course, would mean that the Morphic version has no hope of ever matching it. - More thought is needed to find a simple and general solution. - " - (displayCanvas isNil or: [ - displayCanvas class ~= BitBltCanvas]) ifTrue: [ - displayCanvas _ BitBltCanvas onForm: Display ]. - ^ displayCanvas! - -Transcript class removeSelector: #displayUnfinishedEntryOnCanvas:! - -!methodRemoval: Transcript class #displayUnfinishedEntryOnCanvas: stamp: 'Install-4907-MakeTranscriptIndependentOfBitBltCanvas-JuanVuletich-2021Oct08-20h02m-jmv.001.cs.st 10/14/2021 14:31:54'! -displayUnfinishedEntryOnCanvas: aCanvas - - | font count string x y fh r innerR | - innerR _ bounds insetBy: self padding. - lastDisplayPosition < innerR right ifTrue: [ - font _ FontFamily defaultFamilyAndPointSize. - fh _ font lineSpacing. - count _ innerR height // fh-1. - x _ innerR left. - string _ unfinishedEntry contents. - y _ ((lastIndex - firstIndex \\ self maxEntries) min: count-1) + 1 * font lineSpacing + innerR top. - r _ innerR left: lastDisplayPosition. - aCanvas newClipRect: r. - (aCanvas drawString: string at: x@y font: font color: `Color veryDarkGray`) ifNotNil: [ :lastPoint | - lastDisplayPosition _ lastPoint x. - ^r ]]. - ^nil! - -Transcript class removeSelector: #displayOnCanvas:in:! - -!methodRemoval: Transcript class #displayOnCanvas:in: stamp: 'Install-4907-MakeTranscriptIndependentOfBitBltCanvas-JuanVuletich-2021Oct08-20h02m-jmv.001.cs.st 10/14/2021 14:31:54'! -displayOnCanvas: aCanvas in: aRectangle - " - 1 to: 2000 do: [ :i | i print ]. - 1 to: 750 do: [ :i | i print ]. - Transcript displayOn: Display in: bounds - " - | font count string x y fh innerR index | - aCanvas - fillRectangle: aRectangle - color: `Color white`. - font _ FontFamily defaultFamilyAndPointSize. - innerR _ aRectangle insetBy: self padding. - x _ innerR left. - y _ innerR top. - fh _ font lineSpacing. - count _ lastIndex - firstIndex \\ self maxEntries + 1 min: innerR height // fh - 1. - index _ lastIndex - count \\ self maxEntries + 1. - count timesRepeat: [ - string _ entries at: index. - aCanvas drawString: string at: x@y font: font color: `Color veryDarkGray`. - y _ y + fh. - index _ index \\ self maxEntries + 1 ]. - string _ unfinishedEntry contents. - aCanvas drawString: string at: x@y font: font color: `Color veryDarkGray`! - -Transcript class - instanceVariableNames: 'entries firstIndex lastIndex accessSemaphore unfinishedEntry logToFile showOnDisplay lastDisplayPosition bounds logToStdout displayEngine'! - -!classDefinition: 'Transcript class' category: #'System-Support' stamp: 'Install-4907-MakeTranscriptIndependentOfBitBltCanvas-JuanVuletich-2021Oct08-20h02m-jmv.001.cs.st 10/14/2021 14:31:54'! -Transcript class - instanceVariableNames: 'entries firstIndex lastIndex accessSemaphore unfinishedEntry logToFile showOnDisplay lastDisplayPosition bounds logToStdout displayEngine'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4907-MakeTranscriptIndependentOfBitBltCanvas-JuanVuletich-2021Oct08-20h02m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4907] on 8 October 2021 at 8:24:38 pm'! - -WidgetMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity originalPosition showUp itemsPerPage downButtonForm upButtonForm ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #AutoCompleterMorph category: #'Tools-Autocompletion' stamp: 'Install-4908-MakeAutoCompleterMorphIndependentOfBitBltCanvas-JuanVuletich-2021Oct08-20h20m-jmv.001.cs.st 10/14/2021 14:31:54'! -WidgetMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity originalPosition showUp itemsPerPage downButtonForm upButtonForm' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'jmv 10/8/2021 20:22:46' prior: 50433560! - drawDownArrowOn: aCanvas thickness: scrollbarThickness - - downButtonForm ifNil: [ - downButtonForm _ ScrollBar new instVarNamed: 'downButton' :: imageForm: 32 ]. - aCanvas - image: downButtonForm - at: self downButtonPosition. -! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'jmv 10/8/2021 20:21:15' prior: 50446728! -drawScrollBarMovementBarOn: aCanvas thickness: scrollbarThickness - - | height top bottom | - - height _ extent y - (2 * scrollbarThickness). - top _ (1.0 * self firstVisible-1 / self entryCount * height) ceiling + 1 + scrollbarThickness-1. - bottom _ (1.0 * self lastVisible / self entryCount * height) floor + 1 + scrollbarThickness -1. - aCanvas - fillRectangle: (extent x - scrollbarThickness+2@top corner: extent x-2 @ bottom) - color: `Color veryLightGray lighter`! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'jmv 10/8/2021 20:23:23' prior: 50433640! - drawUpArrowOn: aCanvas thickness: scrollbarThickness - - upButtonForm ifNil: [ - upButtonForm _ ScrollBar new instVarNamed: 'upButton' :: imageForm: 32 ]. - aCanvas - image: upButtonForm - at: self upButtonPosition. -! ! - -WidgetMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity originalPosition showUp itemsPerPage downButtonForm upButtonForm' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #AutoCompleterMorph category: #'Tools-Autocompletion' stamp: 'Install-4908-MakeAutoCompleterMorphIndependentOfBitBltCanvas-JuanVuletich-2021Oct08-20h20m-jmv.001.cs.st 10/14/2021 14:31:54'! -WidgetMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity originalPosition showUp itemsPerPage downButtonForm upButtonForm' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4908-MakeAutoCompleterMorphIndependentOfBitBltCanvas-JuanVuletich-2021Oct08-20h20m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4908] on 13 October 2021 at 9:32:22 am'! -!Categorizer methodsFor: 'tdd' stamp: 'HAW 10/13/2021 09:29:54' prior: 50338077! - classesAt: aCategoryName - - ^(self listAtCategoryNamed: aCategoryName) - collect: [:aClassName | Smalltalk classNamed: aClassName ] - thenSelect: [ :aClass | aClass notNil ] - ! ! -!SystemOrganizer methodsFor: 'source code management' stamp: 'HAW 10/13/2021 09:31:11' prior: 50610595! - classMethodCountOf: category - - ^ (self classesAt: category) sum: [ :cl | cl class selectors size ] ifEmpty: 0.! ! -!SystemOrganizer methodsFor: 'source code management' stamp: 'HAW 10/13/2021 09:31:23' prior: 50610602! - instanceMethodCountOf: category - - ^ (self classesAt: category) sum: [ :cl | cl selectors size ] ifEmpty: 0.! ! -!SystemOrganizer methodsFor: 'source code management' stamp: 'HAW 10/13/2021 09:31:30' prior: 50610609! - linesOfCodeOf: category -" -SystemOrganization linesOfCodeOf: #'System-Files' -" - "An approximate measure of lines of. - Includes comments, but excludes blank lines." - - ^ (self classesAt: category) sum: [ :cl | cl linesOfCode ] ifEmpty: 0.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4909-ClassCategoryAnnotationSpeedUp-HernanWilkinson-2021Oct13-09h06m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4909] on 13 October 2021 at 10:16:22 am'! -!Categorizer methodsFor: 'tdd' stamp: 'HAW 2/7/2017 09:06:13' prior: 50614502! - classesAt: aCategoryName - - ^(self listAtCategoryNamed: aCategoryName) collect: [:aClassName | Smalltalk classNamed: aClassName ] - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4910-Simplify-HernanWilkinson-2021Oct13-10h15m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4910] on 13 October 2021 at 11:00:17 am'! -!Array methodsFor: 'enumerating' stamp: 'jmv 10/13/2021 10:54:48' overrides: 50586723! - collect: collectBlock thenSelect: selectBlock - "Evaluate collectBlock with each my elements as the argument. Collect the - resulting values into a collection that is like me, but only those elements for which - selectBlock evaluates to true. Answer the new collection. - Overriden for performance." - - | newElement | - ^ self species streamContents: [ :strm | - 1 to: self size do: [ :index | - newElement _ collectBlock value: (self at: index). - (selectBlock value: newElement) - ifTrue: [ strm nextPut: newElement ]]]! ! -!Array methodsFor: 'enumerating' stamp: 'jmv 10/13/2021 10:58:21' overrides: 50586730! - select: selectBlock thenCollect: collectBlock - "Evaluate selectBlock with each my elements as the argument. For those who evaluate to true, - collect the result of evaluating collectBlock on them into a collection that is like me. - Answer the new collection. - Overriden for performance." - - | each | - ^ self species streamContents: [ :strm | - 1 to: self size do: [ :index | - each _ self at: index. - (selectBlock value: each) ifTrue: [ - strm nextPut: (collectBlock value: each) ]]]! ! -!OrderedCollection methodsFor: 'enumerating' stamp: 'jmv 10/13/2021 10:40:07' overrides: 50586723! - collect: collectBlock thenSelect: selectBlock - "Evaluate collectBlock with each my elements as the argument. Collect the - resulting values into a collection that is like me, but only those elements for which - selectBlock evaluates to true. Answer the new collection. - Overriden for performance." - - | newCollection newElement | - newCollection _ self species new. - newCollection resetTo: 1. - firstIndex to: lastIndex do: [ :index | - newElement _ collectBlock value: (array at: index). - (selectBlock value: newElement) - ifTrue: [ newCollection addLast: newElement ]]. - ^ newCollection! ! -!OrderedCollection methodsFor: 'enumerating' stamp: 'jmv 10/13/2021 10:42:23' overrides: 50586730! - select: selectBlock thenCollect: collectBlock - "Evaluate selectBlock with each my elements as the argument. For those who evaluate to true, - collect the result of evaluating collectBlock on them into a collection that is like me. - Answer the new collection. - Overriden for performance." - - | newCollection each | - newCollection _ self species new. - newCollection resetTo: 1. - firstIndex to: lastIndex do: [ :index | - each _ array at: index. - (selectBlock value: each) ifTrue: [ - newCollection addLast: (collectBlock value: each) ]]. - ^ newCollection! ! -!OrderedCollection methodsFor: 'enumerating' stamp: 'jmv 10/13/2021 10:36:49' prior: 16884016 overrides: 16906753! - 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 species new. - newCollection resetTo: 1. - firstIndex to: lastIndex do: [ :index | - (aBlock value: (element _ array at: index)) - ifTrue: [ newCollection addLast: element ]]. - ^ newCollection! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4911-Faster-selectThenCollect-collectThenSelect-JuanVuletich-2021Oct13-10h27m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4910] on 13 October 2021 at 11:30:24 am'! -!CodeProvider methodsFor: 'annotation' stamp: 'jmv 10/13/2021 11:28:09' prior: 50610620! - annotationForSelector: aSelector ofClass: aClass - "Provide a line of content for an annotation pane, representing - information about the given selector and class" - - | stamp sendersCount implementorsCount aCategory separator aString aList aComment stream requestList | - aSelector == #Comment - ifTrue: [^ self annotationForClassCommentFor: aClass]. - aSelector == #Definition - ifTrue: [^ self annotationForClassDefinitionFor: aClass]. - stream _ WriteStream on: String new. - requestList _ self annotationRequests. - separator _ self annotationSeparator. - requestList - do: [:aRequest | - aRequest == #firstComment - ifTrue: [ - aComment _ aClass firstCommentAt: aSelector. - aComment isEmptyOrNil - ifFalse: [stream position = 0 ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: aComment]]. - aRequest == #masterComment - ifTrue: [ - aComment _ aClass supermostPrecodeCommentFor: aSelector. - aComment isEmptyOrNil - ifFalse: [stream position = 0 ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: aComment]]. - aRequest == #documentation - ifTrue: [ - aComment _ aClass precodeCommentOrInheritedCommentFor: aSelector. - aComment isEmptyOrNil - ifFalse: [stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: aComment]]. - aRequest == #timeStamp - ifTrue: [ - stamp _ self timeStamp. - stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: (stamp size > 0 ifTrue: [stamp] ifFalse: ['no timestamp'])]. - aRequest == #linesOfCode - ifTrue: [ - stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: ((aClass compiledMethodAt: aSelector ifAbsent: nil) - ifNotNil: [ :cm | cm linesOfCode]) printString, ' lines of code']. - aRequest == #messageCategory - ifTrue: [ - aCategory _ aClass organization categoryOfElement: aSelector. - aCategory - ifNotNil: ["woud be nil for a method no longer present, - e.g. in a recent-submissions browser" - stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: aCategory]]. - aRequest == #sendersCount - ifTrue: [ - sendersCount _ Smalltalk numberOfSendersOf: aSelector. - sendersCount _ sendersCount = 1 - ifTrue: ['1 sender'] - ifFalse: [sendersCount printString , ' senders']. - stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: sendersCount]. - aRequest == #implementorsCount - ifTrue: [ - implementorsCount _ Smalltalk numberOfImplementorsOf: aSelector. - implementorsCount _ implementorsCount = 1 - ifTrue: ['1 implementor'] - ifFalse: [implementorsCount printString , ' implementors']. - stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: implementorsCount]. - aRequest == #priorVersionsCount - ifTrue: [ - stream isEmpty ifFalse: [stream nextPutAll: separator]. - self - addPriorVersionsCountForSelector: aSelector - ofClass: aClass - to: stream]. - aRequest == #priorTimeStamp - ifTrue: [ - stamp _ VersionsBrowser - timeStampFor: aSelector - class: aClass - reverseOrdinal: 2. - stamp - ifNotNil: [stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: 'prior timestamp: ' , stamp]]. - aRequest == #packages - ifTrue: [ - (aClass compiledMethodAt: aSelector ifAbsent: nil) ifNotNil: [ :cm | - stream isEmpty ifFalse: [stream nextPutAll: separator]. - (CodePackage packageOfMethod: cm methodReference ifNone: nil) - ifNil: [ stream nextPutAll: 'in no package' ] - ifNotNil: [ :codePackage | - stream nextPutAll: 'in package '; nextPutAll: codePackage packageName ]]]. - aRequest == #changeSets - ifTrue: [ - stream isEmpty ifFalse: [stream nextPutAll: separator]. - aList _ ChangeSet allChangeSetsWithClass: aClass selector: aSelector. - aList size > 0 - ifTrue: [aList size = 1 - ifTrue: [stream nextPutAll: 'only in change set'] - ifFalse: [stream nextPutAll: 'in change sets:']. - aList - do: [:aChangeSet | stream nextPut: Character space; nextPutAll: aChangeSet name ] - separatedBy: [ stream nextPut: $, ]] - ifFalse: [stream nextPutAll: 'in no change set']]. - aRequest == #allChangeSets - ifTrue: [ - stream isEmpty ifFalse: [stream nextPutAll: separator]. - aList _ ChangeSet allChangeSetsWithClass: aClass selector: aSelector. - aList size > 0 - ifTrue: [aList size = 1 - ifTrue: [stream nextPutAll: 'only in change set'] - ifFalse: [stream nextPutAll: 'in change sets:']. - aList - do: [:aChangeSet | stream nextPut: Character space; nextPutAll: aChangeSet name ] - separatedBy: [ stream nextPut: $, ]] - ifFalse: [stream nextPutAll: 'in no change set']]. - aRequest == #allBaseSystemChangeSets - ifTrue: [ - stream isEmpty ifFalse: [stream nextPutAll: separator]. - aList _ (ChangeSet allChangeSetsWithClass: aClass selector: aSelector) select: [ :it | it isForBaseSystem ]. - aList size > 0 - ifTrue: [ - aList size = 1 - ifTrue: [stream nextPutAll: 'only in base system change set'] - ifFalse: [stream nextPutAll: 'in base system change sets:']. - aList - do: [:aChangeSet | stream nextPut: Character space; nextPutAll: aChangeSet name ] - separatedBy: [ stream nextPut: $, ]] - ifFalse: [stream nextPutAll: 'in no base system change set']]. - aRequest == #closuresInfo - ifTrue: [ - aString _ aClass closuresInfoAt: aSelector. - aString size > 0 - ifTrue: [stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: aString]]. - ]. - ^ stream contents! ! -!Browser methodsFor: 'accessing' stamp: 'jmv 10/13/2021 11:19:23' prior: 50485420 overrides: 16812025! - acceptedStringOrText - "Depending on the current selection, different information is retrieved. - Answer a string description of that information. This information is the - method of the currently selected class and message." - - | comment theClass latestCompiledMethod | - latestCompiledMethod _ currentCompiledMethod. - currentCompiledMethod _ nil. - - editSelection == #none ifTrue: [^ '']. - editSelection == #editSystemCategories - ifTrue: [^ systemOrganizer printString]. - self isEditingNewClass - ifTrue: [^ (theClass _ self selectedClass) - ifNil: [ - Class template: selectedSystemCategory] - ifNotNil: [ - Class templateForSubclassOf: theClass category: selectedSystemCategory]]. - self isEditingExistingClass - ifTrue: [^ self classDefinitionText ]. - editSelection == #editComment - ifTrue: [ - (theClass _ self selectedClass) ifNil: [^ '']. - comment _ theClass comment. - currentCompiledMethod _ theClass organization commentRemoteStr. - ^ comment size = 0 - ifTrue: ['This class has not yet been commented.'] - ifFalse: [comment]]. - editSelection == #editMessageCategories - ifTrue: [^ self classOrMetaClassOrganizer printString]. - editSelection == #newMessage - ifTrue: [ - ^ (theClass _ self selectedClassOrMetaClass) - ifNil: [''] - ifNotNil: [theClass sourceCodeTemplate]]. - editSelection == #editMessage - ifTrue: [ - self showingByteCodes ifTrue: [^ self selectedBytecodes]. - currentCompiledMethod _ latestCompiledMethod. - ^ self selectedMessage]. - - self error: 'Browser internal error: unknown edit selection.'! ! -!Browser methodsFor: 'accessing' stamp: 'jmv 10/13/2021 11:23:02' prior: 50485474! - contents: input notifying: aRequestor - "The retrieved information has changed and its source must now be - updated. The information can be a variety of things, depending on - the list selections (such as templates for class or message definition, - methods) or the user menu commands (such as definition, comment). - Answer the result of updating the source." - - | aString aText theClass | - aString _ input asString. - aText _ input asText. - editSelection == #editSystemCategories ifTrue: [ ^ self changeSystemCategories: aString ]. - self isEditingClass ifTrue: [ - [ - self defineClass: aString notifying: aRequestor - ] on: RecompilationFailure do: [ :ex | - self inform: ex messageText. - ^ false]. - ^ true]. - editSelection == #editComment - ifTrue: [ - theClass _ self selectedClass. - theClass - ifNil: [ - self inform: 'You must select a class -before giving it a comment.'. - ^ false]. - theClass comment: aText stamp: Utilities changeStamp. - self changed: #classCommentText. - ^ true]. - editSelection == #editMessageCategories ifTrue: [ ^ self changeMessageCategories: aString ]. - editSelection == #editMessage | (editSelection == #newMessage) - ifTrue: [ - ^ self okayToAccept - ifFalse:[ false ] - ifTrue: [ - (self compileMessage: aText notifying: aRequestor) - ifTrue: [ self triggerEvent: #annotationChanged ]; - yourself ]]. - editSelection == #none - ifTrue: [ - self inform: 'This text cannot be accepted -in this part of the browser.'. - ^ false]. - self error: 'unacceptable accept'! ! -!Browser methodsFor: 'class functions' stamp: 'jmv 10/13/2021 11:23:55' prior: 50485548! - explainSpecial: string - "Answer a string explaining the code pane selection if it is displaying - one of the special edit functions." - - | classes whole lits reply | - self isEditingClass - ifTrue: - ["Selector parts in class definition" - string last == $: ifFalse: [^nil]. - lits _ Array with: - #subclass:instanceVariableNames:classVariableNames:poolDictionaries:category:. - (whole _ lits detect: [:each | (each keywords - detect: [:frag | frag = string] ifNone: nil) notNil] - ifNone: nil) notNil - ifTrue: [reply _ '"' , string , ' is one part of the message selector ' , whole , '.'] - ifFalse: [^nil]. - classes _ Smalltalk allClassesImplementing: whole. - classes _ 'these classes ' , classes printString. - ^reply , ' It is defined in ' , classes , '." -Smalltalk browseAllImplementorsOf: #' , whole]. - - editSelection == #editSystemCategories ifTrue: [^nil]. - editSelection == #editMessageCategories ifTrue: [^nil]. - ^nil! ! -!Browser methodsFor: 'class functions' stamp: 'jmv 10/13/2021 11:25:19' prior: 16791754! - plusButtonHit - "Cycle among definition and comment." - - editSelection == #editComment - ifTrue: [ - self editSelection: #editClass. - selectedClassName ifNil: [ ^self ]. - self changed: #editComment. - self acceptedContentsChanged. - ^ self]. - self editComment. - self changed: #instanceMessagesIndicated. - self changed: #classCommentIndicated. - self changed: #classMessagesIndicated.! ! -!MessageSet methodsFor: 'message list' stamp: 'jmv 10/13/2021 11:19:12' prior: 50504336 overrides: 16792430! - selectedMessage - "Answer the source method for the currently selected message." - - | class selector | - selectedMessage ifNil: [^ 'Class vanished']. - - class _ selectedMessage actualClass. - selector _ selectedMessage methodSymbol. - selector ifNil: [ ^'prims']. - - selector first isUppercase ifTrue: [ - selector == #Comment ifTrue: [ - currentCompiledMethod _ class organization commentRemoteStr. - ^ class comment ]. - selector == #Definition ifTrue: [ - ^ class definition ].]. - - (class notNil and: [ class includesSelector: selector]) ifFalse: [ - currentCompiledMethod _ nil. - ^ 'Missing']. - - self showingDecompile ifTrue: [ - ^ self decompiledSource ]. - - currentCompiledMethod _ class compiledMethodAt: selector ifAbsent: nil. - self showingDocumentation ifTrue: [ - ^ self commentContents ]. - - ^self sourceStringPrettifiedAndDiffed! ! -!MessageSet methodsFor: 'accessing' stamp: 'jmv 10/13/2021 11:28:31' prior: 16870042 overrides: 50614900! - contents: aString notifying: aRequestor - "Compile the code in aString. Notify aRequestor of any syntax errors. - Answer false if the compilation fails. Otherwise, if the compilation - created a new method, deselect the current selection. Then answer true." - - | category selector class oldSelector | - self okayToAccept ifFalse: [^ false]. - selectedMessage ifNil: [^ false]. - class _ selectedMessage actualClass. - oldSelector _ selectedMessage methodSymbol. - (oldSelector notNil and: [oldSelector first isUppercase]) ifTrue: - [oldSelector == #Comment ifTrue: - [class comment: aString stamp: Utilities changeStamp. - self triggerEvent: #annotationChanged. - self changed: #clearUserEdits. - ^ false]. - oldSelector == #Definition ifTrue: [ - Compiler - evaluate: aString - notifying: aRequestor - logged: true. - self changed: #clearUserEdits. - ^ false]]. - "Normal method accept" - category _ class organization categoryOfElement: oldSelector. - selector _ class compile: aString - classified: category - notifying: aRequestor. - selector - ifNil: [^ false]. - selector == oldSelector ifFalse: [ - self reformulateListNoting: selector]. - self triggerEvent: #annotationChanged. - ^ true! ! -!MessageSet class methodsFor: 'utilities' stamp: 'jmv 10/13/2021 11:29:12' prior: 16870395! - isPseudoSelector: aSelector - "Answer whether the given selector is a special marker" - - ^ #(Comment Definition) statePointsTo: aSelector! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'jmv 10/13/2021 11:27:31' prior: 50445761! - classListMenuOptions - - ^ `{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutClass. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 5. - #label -> 'show classes hierarchically'. - #object -> #model. - #selector -> #enableListClassesHierarchically. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 6. - #label -> 'show classes alphabetically'. - #object -> #model. - #selector -> #enableListClassesAlphabetically. - #icon -> #sendReceiveIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'show definition'. - #object -> #model. - #selector -> #editClass. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'show comment'. - #object -> #model. - #selector -> #editComment. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'inst var refs...'. - #selector -> #browseInstVarRefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'inst var defs...'. - #selector -> #browseInstVarDefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'class var refs...'. - #selector -> #browseClassVarRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 20. - #label -> 'class vars'. - #selector -> #browseClassVariables. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'class refs (N)'. - #selector -> #browseClassRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'rename class... (R)'. - #object -> #model. - #selector -> #renameClass. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 20. - #label -> 'copy class...'. - #object -> #model. - #selector -> #copyClass. - #icon -> #copyIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 30. - #label -> 'remove class (x)'. - #object -> #model. - #selector -> #removeClass. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 10. - #label -> 'run tests (t)'. - #object -> #model. - #selector -> #runClassTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 20. - #label -> 'more...'. - #selector -> #offerClassListMenu2. - #icon -> #listAddIcon - } asDictionary. - }`. - ! ! - -PseudoClass removeSelector: #printHierarchy! - -!methodRemoval: PseudoClass #printHierarchy stamp: 'Install-4912-Remove-showHierarchy-menuOption-JuanVuletich-2021Oct13-11h00m-jmv.001.cs.st 10/14/2021 14:31:54'! -printHierarchy - - ^'Hierarchy view not supported'! - -Behavior removeSelector: #printHierarchy! - -!methodRemoval: Behavior #printHierarchy stamp: 'Install-4912-Remove-showHierarchy-menuOption-JuanVuletich-2021Oct13-11h00m-jmv.001.cs.st 10/14/2021 14:31:54'! -printHierarchy - "Answer a description containing the names and instance variable names - of all of the subclasses and superclasses of the receiver." - - | aStream index | - index _ 0. - aStream _ WriteStream on: (String new: 16). - self allSuperclasses reverseDo: [ :aClass | - aStream newLineTab: index. - index _ index + 1. - aStream nextPutAll: aClass name. - aStream space. - aStream print: aClass instVarNames]. - aStream newLine. - self printSubclassesOn: aStream level: index. - ^aStream contents! - -Browser removeSelector: #hierarchy! - -!methodRemoval: Browser #hierarchy stamp: 'Install-4912-Remove-showHierarchy-menuOption-JuanVuletich-2021Oct13-11h00m-jmv.001.cs.st 10/14/2021 14:31:54'! -hierarchy - "Display the inheritance hierarchy of the receiver's selected class." - - selectedClassName ifNil: [^ self]. - self messageCategoryListIndex: 0. - self editSelection: #hierarchy. - self changed: #editComment. - self acceptedContentsChanged. - ^ self! - -CodeProvider removeSelector: #annotationForHierarchyFor:! - -!methodRemoval: CodeProvider #annotationForHierarchyFor: stamp: 'Install-4912-Remove-showHierarchy-menuOption-JuanVuletich-2021Oct13-11h00m-jmv.001.cs.st 10/14/2021 14:31:54'! -annotationForHierarchyFor: aClass - "Provide a line of content for an annotation pane, given that the receiver is pointing at the hierarchy of the given class." - - ^ 'Hierarchy for ', aClass name! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4912-Remove-showHierarchy-menuOption-JuanVuletich-2021Oct13-11h00m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4910] on 13 October 2021 at 12:31:56 pm'! -!Preferences class methodsFor: 'parameters' stamp: 'jmv 10/13/2021 11:41:15'! - classAnnotations - " - Preferences classAnnotations - " - (self parameters includesKey: #ClassAnnotations) ifFalse: [ - self setDefaultAnnotationsInBrowsers ]. - ^ self parameters at: #ClassAnnotations! ! -!Preferences class methodsFor: 'parameters' stamp: 'jmv 10/13/2021 11:39:36'! - methodAnnotations - " - Preferences methodAnnotations - " - (self parameters includesKey: #MethodAnnotations) ifFalse: [ - self setDefaultAnnotationsInBrowsers ]. - ^ self parameters at: #MethodAnnotations! ! -!Preferences class methodsFor: 'parameters' stamp: 'jmv 10/13/2021 11:45:41'! - setDefaultAnnotationsInBrowsers - " - Preferences setDefaultAnnotationsInBrowsers - " - self parameters - at: #MethodAnnotations - put: #(timeStamp linesOfCode messageCategory implementorsCount sendersCount packages changeSets); - at: #ClassAnnotations - put: #(instanceMethodsCount classMethodsCount linesOfCode); - at: #SystemCategoryAnnotations - put: #(classCount instanceMethodsCount classMethodsCount linesOfCode)! ! -!Preferences class methodsFor: 'parameters' stamp: 'jmv 10/13/2021 11:46:19'! - setQuickAnnotationsInBrowsers - " - Preferences setQuickAnnotationsInBrowsers - " - self parameters - at: #MethodAnnotations - put: #(timeStamp messageCategory packages changeSets); - at: #ClassAnnotations - put: #(instanceMethodsCount classMethodsCount); - at: #SystemCategoryAnnotations - put: #(classCount instanceMethodsCount classMethodsCount)! ! -!Preferences class methodsFor: 'parameters' stamp: 'jmv 10/13/2021 11:41:44'! - systemCategoryAnnotations - " - Preferences systemCategoryAnnotations - " - (self parameters includesKey: #SystemCategoryAnnotations) ifFalse: [ - self setDefaultAnnotationsInBrowsers ]. - ^ self parameters at: #SystemCategoryAnnotations! ! -!CodeProvider methodsFor: 'annotation' stamp: 'jmv 10/13/2021 11:59:42' prior: 50518406! - annotationForClassDefinitionFor: aClass - "Provide a line of content for an annotation pane, given that the receiver is pointing at the class definition of the given class." - - ^ String streamContents: [ :strm | - strm - nextPutAll: 'Class definition for '; - nextPutAll: aClass name. - Preferences classAnnotations do: [ :each | - strm nextPutAll: self annotationSeparator. - each caseOf: { - [#instanceMethodsCount] -> [ - strm - print: (aClass theNonMetaClass selectors size); - nextPutAll: ' instance methods' ]. - [#classMethodsCount] -> [ - strm - print: (aClass theMetaClass selectors size); - nextPutAll: ' class methods' ]. - [#linesOfCode] -> [ - strm - print: (aClass theNonMetaClass linesOfCode); - nextPutAll: ' total lines of code' ] - }]].! ! -!CodeProvider methodsFor: 'annotation' stamp: 'jmv 10/13/2021 12:30:45' prior: 50614665! - annotationForSelector: aSelector ofClass: aClass - "Provide a line of content for an annotation pane, representing - information about the given selector and class" - - aSelector == #Comment - ifTrue: [^ self annotationForClassCommentFor: aClass]. - aSelector == #Definition - ifTrue: [^ self annotationForClassDefinitionFor: aClass]. - - ^ String streamContents: [ :strm | - Preferences methodAnnotations - do: [ :each | - each caseOf: { - [#firstComment] -> [ - strm nextPutAll: (aClass firstCommentAt: aSelector) ]. - [#masterComment] -> [ - strm nextPutAll: ((aClass supermostPrecodeCommentFor: aSelector) ifNil: ['']) ]. - [#documentation] -> [ - strm nextPutAll: ((aClass precodeCommentOrInheritedCommentFor: aSelector) ifNil: ['']) ]. - [#timeStamp] -> [ | stamp | - stamp _ self timeStamp. - strm nextPutAll: (stamp size > 0 ifTrue: [stamp] ifFalse: ['no timestamp'])]. - [#linesOfCode] -> [ - strm - print: ((aClass compiledMethodAt: aSelector ifAbsent: nil) ifNotNil: [ :cm | cm linesOfCode]); - nextPutAll: ' lines of code' ]. - [#messageCategory] -> [ - strm nextPutAll: (( aClass organization categoryOfElement: aSelector) ifNil: ['']) ]. - [#sendersCount] -> [ | sendersCount | - sendersCount _ Smalltalk numberOfSendersOf: aSelector. - sendersCount _ sendersCount = 1 - ifTrue: ['1 sender'] - ifFalse: [sendersCount printString , ' senders']. - strm nextPutAll: sendersCount ]. - [#implementorsCount] -> [ | implementorsCount | - implementorsCount _ Smalltalk numberOfImplementorsOf: aSelector. - implementorsCount _ implementorsCount = 1 - ifTrue: ['1 implementor'] - ifFalse: [implementorsCount printString , ' implementors']. - strm nextPutAll: implementorsCount ]. - [#priorVersionsCount] -> [ - self addPriorVersionsCountForSelector: aSelector ofClass: aClass to: strm]. - [#priorTimeStamp] -> [ | stamp | - stamp _ VersionsBrowser - timeStampFor: aSelector - class: aClass - reverseOrdinal: 2. - strm nextPutAll: 'prior timestamp: '; nextPutAll: (stamp ifNil: ['None']) ]. - [#packages] -> [ - (aClass compiledMethodAt: aSelector ifAbsent: nil) ifNotNil: [ :cm | - (CodePackage packageOfMethod: cm methodReference ifNone: nil) - ifNil: [ strm nextPutAll: 'in no package' ] - ifNotNil: [ :codePackage | - strm nextPutAll: 'in package '; nextPutAll: codePackage packageName ]]]. - [#changeSets] -> [ | aList | - aList _ ChangeSet allChangeSetsWithClass: aClass selector: aSelector. - aList size > 0 - ifTrue: [ aList size = 1 - ifTrue: [strm nextPutAll: 'only in change set'] - ifFalse: [strm nextPutAll: 'in change sets:']. - aList - do: [:aChangeSet | strm nextPut: Character space; nextPutAll: aChangeSet name ] - separatedBy: [ strm nextPut: $, ]] - ifFalse: [strm nextPutAll: 'in no change set']]. - [#allChangeSets] -> [ | aList | - aList _ ChangeSet allChangeSetsWithClass: aClass selector: aSelector. - aList size > 0 - ifTrue: [ aList size = 1 - ifTrue: [strm nextPutAll: 'only in change set'] - ifFalse: [strm nextPutAll: 'in change sets:']. - aList - do: [:aChangeSet | strm nextPut: Character space; nextPutAll: aChangeSet name ] - separatedBy: [ strm nextPut: $, ]] - ifFalse: [strm nextPutAll: 'in no change set']]. - [#allBaseSystemChangeSets] -> [ | aList | - aList _ (ChangeSet allChangeSetsWithClass: aClass selector: aSelector) select: [ :it | it isForBaseSystem ]. - aList size > 0 - ifTrue: [ aList size = 1 - ifTrue: [strm nextPutAll: 'only in base system change set'] - ifFalse: [strm nextPutAll: 'in base system change sets:']. - aList - do: [:aChangeSet | strm nextPut: Character space; nextPutAll: aChangeSet name ] - separatedBy: [ strm nextPut: $, ]] - ifFalse: [strm nextPutAll: 'in no base system change set']]. - [#closuresInfo] -> [ - strm nextPutAll: (aClass closuresInfoAt: aSelector)]. - - }] - separatedBy: [ strm nextPutAll: self annotationSeparator ] ].! ! -!CodeProvider methodsFor: 'annotation' stamp: 'jmv 10/13/2021 12:03:08' prior: 50610566! - annotationForSystemCategory: aCategory - "Provide a line of content for an annotation pane, given that the receiver is pointing at a System Category (i.e. a group of classes)." - - ^ String streamContents: [ :strm | - strm - nextPutAll: 'System Category: '; - nextPutAll: aCategory. - Preferences systemCategoryAnnotations do: [ :each | - strm nextPutAll: self annotationSeparator. - each caseOf: { - [#classCount] -> [ - strm - print: (SystemOrganization listAtCategoryNamed: aCategory) size; - nextPutAll: ' classes' ]. - [#instanceMethodsCount] -> [ - strm - print: (SystemOrganization instanceMethodCountOf: aCategory); - nextPutAll: ' instance methods' ]. - [#classMethodsCount] -> [ - strm - print: (SystemOrganization classMethodCountOf: aCategory); - nextPutAll: ' class methods' ]. - [#linesOfCode] -> [ - strm - print: (SystemOrganization linesOfCodeOf: aCategory); - nextPutAll: ' total lines of code' ] - }]].! ! -!Preferences class methodsFor: 'themes' stamp: 'jmv 10/13/2021 11:40:06' prior: 50610967! - slowMachine - " - Preferences slowMachine - " - self setPreferencesFrom: #( - #(#drawKeyboardFocusIndicator false ) - (balloonHelpEnabled false) - (browseWithPrettyPrint false) - (caseSensitiveFinds true) - (checkForSlips false) - (cmdDotEnabled true) - (diffsInChangeList true) - (diffsWithPrettyPrint false) - (menuKeyboardControl false) - (optionalButtons false) - (subPixelRenderFonts true) - (thoroughSenders true) - (cheapWindowReframe true) - (syntaxHighlightingAsYouType false) - (tapAndHoldEmulatesButton2 false) - (clickGrabsMorphs true) - ). - self useNoMenuIcons. - self runningWorld backgroundImageData: nil. - Preferences setQuickAnnotationsInBrowsers. - " - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - Taskbar hideTaskbar - "! ! - -Preferences class removeSelector: #setDefaultMethodAnnotations! - -Preferences class removeSelector: #setCheapAnnotationInfo! - -!methodRemoval: Preferences class #setCheapAnnotationInfo stamp: 'Install-4913-EnhancementsToBrowserAnnotations-JuanVuletich-2021Oct13-11h30m-jmv.001.cs.st 10/14/2021 14:31:54'! -setCheapAnnotationInfo - " - Preferences setCheapAnnotationInfo - " - ^ self parameters at: #MethodAnnotations put: #(timeStamp messageCategory packages changeSets)! - -Preferences class removeSelector: #setQuickMethodAnnotations! - -Preferences class removeSelector: #defaultAnnotationRequests! - -!methodRemoval: Preferences class #defaultAnnotationRequests stamp: 'Install-4913-EnhancementsToBrowserAnnotations-JuanVuletich-2021Oct13-11h30m-jmv.001.cs.st 10/14/2021 14:31:54'! -defaultAnnotationRequests - ^ self parameters at: #MethodAnnotations ifAbsent: - [self setDefaultAnnotationInfo] - "Preferences annotationInfo"! - -Preferences class removeSelector: #setDefaultAnnotationInfo! - -!methodRemoval: Preferences class #setDefaultAnnotationInfo stamp: 'Install-4913-EnhancementsToBrowserAnnotations-JuanVuletich-2021Oct13-11h30m-jmv.001.cs.st 10/14/2021 14:31:54'! -setDefaultAnnotationInfo - " - Preferences setDefaultAnnotationInfo - " - ^ self parameters at: #MethodAnnotations put: #(timeStamp linesOfCode messageCategory implementorsCount sendersCount packages changeSets)! - -CodeProvider removeSelector: #xannotationForSelector:ofClass:! - -CodeProvider removeSelector: #annotationRequests! - -!methodRemoval: CodeProvider #annotationRequests stamp: 'Install-4913-EnhancementsToBrowserAnnotations-JuanVuletich-2021Oct13-11h30m-jmv.001.cs.st 10/14/2021 14:31:54'! -annotationRequests - ^ Preferences defaultAnnotationRequests! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4913-EnhancementsToBrowserAnnotations-JuanVuletich-2021Oct13-11h30m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4908] on 10 October 2021 at 10:02:15 am'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 10/10/2021 09:40:22' prior: 50609423! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag - "This is the main method for image save and / or quit. - See senders." - "WARNING: Current process will be killed. UI Process will be restarted" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic - checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " - | activeProc | - activeProc _ Processor activeProcess. - [ | isARealStartup guiRootObject guiRootObjectClass | - save not & quit - ifTrue: [ - (SourceFiles at: 2) ifNotNil: [ :changes | - ChangesInitialFileSize ifNotNil: [ changes truncate: ChangesInitialFileSize ]]] - ifFalse: [ - self - logSnapshot: save - andQuit: quit ]. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | - each isInWorld ifTrue: [ - each delete.]]. - UISupervisor ui tearDownDesktop. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - "These could be moved to some #shutDown" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - "Stuff needed to relaunch UI on startup" - guiRootObjectClass _ UISupervisor ui class. - guiRootObject _ UISupervisor ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "guiRootObject _ clearAllStateFlag ifFalse: [ UISupervisor ui ]." - UISupervisor stopUIProcess. - activeProc isTerminated ifFalse: [ activeProc terminate ]. - guiRootObject ifNotNil: [ guiRootObject releaseCachedState ]. - "Clean Globals" - Smalltalk - at: #Sensor - put: nil. - Smalltalk - at: #Display - put: nil. - Smalltalk closeSourceFiles. - Smalltalk - at: #SourceFiles - put: nil. - Smalltalk allClassesDo: [ :cls | - cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | - cls releaseClassState ]]. - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ - Smalltalk printStuffToCleanOnImageSave. - "Remove this call to actually see the image clean report." - Transcript clear. - ]. - "Do image save & quit as apropriate" - (Cursor cursorAt: #writeCursor) activateCursor. - save - ifTrue: [ - "The snapshot primitive answers false if it was just called to do the snapshot. - But image startup is resumed by returning (again) from the primitive, but this time answering true." - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk - at: #Sensor - put: nil. - Smalltalk - at: #Display - put: DisplayScreen new. - Smalltalk - at: #SourceFiles - put: (Array new: 2). - Smalltalk openSourceFiles. - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | - cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - UISupervisor spawnNewMorphicProcessFor: (guiRootObject ifNil: [ guiRootObject _ guiRootObjectClass newWorld ]). - self restoreLostChangesIfNecessary. - clearAllStateFlag ifTrue: [ - UISupervisor whenUIinSafeState: [ - guiRootObject recreateDefaultDesktop; restoreDisplay ]] - ifFalse: [ - UISupervisor whenUIinSafeState: [ - guiRootObject restoreDisplay ]]. - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - UISupervisor whenUIinSafeState: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]] - forkAt: Processor timingPriority - 1 - named: 'Startup process'.! ! -!HandMorph methodsFor: 'caching' stamp: 'jmv 10/9/2021 20:21:34' prior: 16851468 overrides: 50590255! - releaseCachedState - | oo | - super releaseCachedState. - oo _ owner. - self removeAllMorphs. - self initialize. "nuke everything" - self privateOwner: oo. - self releaseAllFoci. - savedPatch _ nil.! ! -!WorldMorph methodsFor: 'caching' stamp: 'jmv 10/10/2021 09:41:57' prior: 50552041 overrides: 50550799! - releaseCachedState - super releaseCachedState. - self cleanseStepList. - self clearCanvas. - hands do: [ :h | h releaseCachedState ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4914-ReleaseHandSavedPatch-onImageSave-JuanVuletich-2021Oct10-10h01m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4908] on 11 October 2021 at 7:04:32 pm'! -!WindowEdgeAdjustingMorph methodsFor: 'geometry' stamp: 'jmv 10/11/2021 18:36:56' overrides: 50499535! - minimumExtent - "This returns the minimum extent that the morph may be shrunk to. - It is expressed in the morph own coordinates, like morphExtent." - - ^ `0@0`! ! -!BitBltCanvas methodsFor: 'drawing-windows' stamp: 'jmv 10/11/2021 18:11:33'! - roundEdge: aRectangle border: borderWidth color: borderColor - "NOP here"! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 10/11/2021 18:18:53' prior: 50603302! - collides: aMorph - "Answer whether the pixels used by morphs touch at least at one place. - Morphs not in the WidgetMorph hierarchy should answer #true to wantsContour." - - privateDisplayBounds ifNil: [ - ^false ]. - - "Quick check with display bounds" - (aMorph displayBoundsIntersects: privateDisplayBounds) ifFalse: [ - ^false ]. - - "Precise check with contour, if available" - (self valueOfProperty: #contour) ifNotNil: [ :contour | | contourTop contourBottom | - contourTop _ self valueOfProperty: #contourY0. - contourBottom _ self valueOfProperty: #contourY1. - ^ aMorph contourIntersects: contour top: contourTop bottom: contourBottom ]. - - "If contour is not available, and both displayBounds overlap, answer true, as it is the best we can know." - ^ true! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 10/11/2021 18:16:43' prior: 50613011! - on: aRectangle ifCovered: partiallyOrTotallyCoveredBlock uncoveredPartsDo: uncoveredPartBlock else: notCoveredAtAllBlock - "Find rectangles encompassing those areas in aRectangle not completely - covered by self. These are the areas that might require further drawing (of morphs below us) - All areas that might possibly be uncovered must be included. - - If aRectangle is not covered at all, or for whatever reason we don't know, evaluate notCoveredAtAllBlock. - Othewise evaluate partiallyOrTotallyCoveredBlock once, and also evaluate uncoveredPartBlock for each part in aRectangle we don't cover." - - ^ notCoveredAtAllBlock value! ! -!Morph methodsFor: 'updating' stamp: 'jmv 10/11/2021 18:19:02' prior: 50596647! - invalidateBounds - "Report that the area occupied by this morph and submorphs should be redrawn, - but most likely we are not going to be redrawn on it, or maybe we'll not be fully visible. See senders." - - self displayFullBounds ifNotNil: [ :r | - "outsetBy: 1 due to anti aliasing in VectorCanvas" - self invalidateDisplayRect: r for: nil ]. -! ! -!Morph methodsFor: 'updating' stamp: 'jmv 10/11/2021 18:19:08' prior: 50604301! - redrawNeeded - "Report that the area occupied by this morph should be redrawn. - Usually because we changed in some way. - Notes: - Area used before any change is reported here. - Area used after any changes is reported when displayBounds are updated. - See updateBoundsIn:addDamageTo: and senders. - " - - self needsRedraw: true. - self allOwnersDo: [ :m | m submorphNeedsRedraw: true ]. - self basicDisplayBounds ifNotNil: [ :b | - "outsetBy: 1 due to anti aliasing in VectorCanvas" - self invalidateDisplayRect: b for: self ]. - (self submorphsMightProtrude and: [self clipsSubmorphsReally not]) ifTrue: [ - self submorphsReverseDo: [ :m | m redrawNeeded ]]. - self removeProperty: #bitMask. - self removeProperty: #fullBoundsInOwner.! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 10/11/2021 18:19:14' prior: 50613132! - displayFullBoundsForPatch - "Current full bounds of hand and carried submorphs. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around). - Integer pixel coordinates!!" - - | handBounds fullBounds | - handBounds _ self displayBounds. - fullBounds _ handBounds copy. - self submorphsDo: [ :m | - fullBounds updateMerging: m displayFullBounds]. - lastPosition - ifNotNil: [ :lastPos | "When already carrying morphs around. Update rectangle to current hand position." - fullBounds _ (fullBounds translatedBy: self morphPosition-lastPos) updateMerging: handBounds ]. - ^fullBounds encompassingIntegerRectangle! ! -!WindowEdgeAdjustingMorph methodsFor: 'drawing' stamp: 'jmv 10/11/2021 19:02:52' prior: 50593055 overrides: 50503568! - drawOn: aCanvas - - | c | - (owner is: #SystemWindow) ifFalse: [ - ^super drawOn: aCanvas ]. - - "Use almost transparent, so effect on antialiasing for drawing exactly on top of Window is kept to a minimum." - c _ owner windowFrameColor alpha: 0.1. - selector caseOf: { - [ #windowTopLeft: ] -> [ - aCanvas roundTopLeftCornerX: 0 y: 0 length: extent x border: owner borderWidth color: c ]. - [ #windowTopRight: ] -> [ - aCanvas roundTopRightCornerX: 0 y: 0 length: extent x border: owner borderWidth color: c ]. - [ #windowBottomLeft: ] -> [ - aCanvas roundBottomLeftCornerX: 0 y: 0 length: extent x border: owner borderWidth color: c ]. - [ #windowBottomRight: ] -> [ - aCanvas roundBottomRightCornerX: 0 y: 0 length: extent x border: owner borderWidth color: c ]. - } - otherwise: [ - "all the morph is sensitive for horizontal and vertical (i.e. non corner) instances." - aCanvas roundEdge: self morphLocalBounds border: owner borderWidth color: c ].! ! -!WindowEdgeAdjustingMorph methodsFor: 'geometry services' stamp: 'jmv 10/11/2021 18:46:51' prior: 50608599 overrides: 50608531! - coversLocalPoint: aLocalPoint - "We don't completely cover our bounds. Account for that." - - | sensitiveBorder | - sensitiveBorder _ owner borderWidth. - ((self morphLocalBounds outsetBy: sensitiveBorder) containsPoint: aLocalPoint) ifFalse: [ ^false ]. - selector caseOf: { - [ #windowTopLeft: ] -> [ ^ aLocalPoint x < sensitiveBorder or: [ aLocalPoint y < sensitiveBorder ]]. - [ #windowTopRight: ] -> [ ^ extent x - aLocalPoint x <= sensitiveBorder or: [ aLocalPoint y < sensitiveBorder ]]. - [ #windowBottomLeft: ] -> [ ^ aLocalPoint x < sensitiveBorder or: [ extent y- aLocalPoint y <= sensitiveBorder ]]. - [ #windowBottomRight: ] -> [ ^ extent x - aLocalPoint x <= sensitiveBorder or: [ extent y - aLocalPoint y <= sensitiveBorder ]]. - } - otherwise: [ - "all the morph is sensitive for horizontal and vertical (i.e. non corner) instances." - ^true ]! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 10/11/2021 18:35:41' prior: 50578618! - drawClassicFrameOn: aCanvas color: windowFrameColor - "Window border encompasses title area. No round corners. No title gradient." - - aCanvas fillRectangle: (self morphLocalBounds insetBy: 1.5) color: color borderWidth: borderWidth borderStyleSymbol: #simple baseColorForBorder: self widgetsColor. - - "A border was drawn at the left, top and right of the title area. - The look is that the title area is inside the window" - aCanvas fillRectangle: (borderWidth@borderWidth extent: extent x - (2*borderWidth)@ self labelHeight) color: windowFrameColor! ! -!SystemWindow methodsFor: 'geometry services' stamp: 'jmv 10/11/2021 18:20:52' prior: 50613664 overrides: 50615811! - on: aRectangle ifCovered: partiallyOrTotallyCoveredBlock uncoveredPartsDo: uncoveredPartBlock else: notCoveredAtAllBlock - "Find rectangles encompassing those areas in aRectangle not completely - covered by self. These are the areas that might require further drawing (of morphs below us) - All areas that might possibly be uncovered must be included. - - If aRectangle is not covered at all, or for whatever reason we don't know, evaluate notCoveredAtAllBlock. - Othewise evaluate partiallyOrTotallyCoveredBlock once, and also evaluate uncoveredPartBlock for each part in aRectangle we don't cover." - - | bounds r e r2 | - self isOrAnyOwnerIsRotated ifTrue: [ - ^ notCoveredAtAllBlock value ]. - - color mightBeTranslucent ifTrue: [ - ^ notCoveredAtAllBlock value ]. - - "Due to possible anti aliasing, and possible conversion to integer, we can't be really sure - about the 2 outer pixels at each edge." - bounds _ self displayBounds insetBy: 2. - bounds ifNil: [ - ^ notCoveredAtAllBlock value ]. - - (aRectangle intersects: bounds) ifFalse: [ - ^ notCoveredAtAllBlock value ]. - - "Solid rectangle. - This will be the fastest in many cases. So, please disable rounded corners if on slow hardware!!" - partiallyOrTotallyCoveredBlock value. - aRectangle areasOutside: bounds do: [ :rect | uncoveredPartBlock value: rect ]. - - Theme current roundWindowCorners ifTrue: [ - r _ Theme current roundedWindowRadius * 1.1. "A bit more than actual radius because we use Bezier, not arc." - e _ self externalizeDistanceToWorld: r@r. - r2 _ aRectangle intersect: (bounds topLeft extent: e). - r2 hasPositiveExtent ifTrue: [ uncoveredPartBlock value: r2 ]. - r2 _ aRectangle intersect: (bounds topRight - (e x@0) extent: e). - r2 hasPositiveExtent ifTrue: [ uncoveredPartBlock value: r2 ]. - r2 _ aRectangle intersect: (bounds bottomLeft - (0@ e y)extent: e). - r2 hasPositiveExtent ifTrue: [ uncoveredPartBlock value: r2 ]. - r2 _ aRectangle intersect: (bounds bottomRight - e extent: e). - r2 hasPositiveExtent ifTrue: [ uncoveredPartBlock value: r2 ]. - ].! ! -!SystemWindow methodsFor: 'layout' stamp: 'jmv 10/11/2021 19:02:41' prior: 50541189 overrides: 50537642! - layoutSubmorphs - "Compute a new layout of submorphs based on the given layout bounds." - - | h thickness w cornerExtent wh ww pos halfThickness | - thickness _ self borderWidth. - halfThickness _ thickness * 0.5. - cornerExtent _ thickness * 5. - ww _ extent x. - wh _ extent y. - w _ ww - cornerExtent - cornerExtent. - h _ wh - cornerExtent - cornerExtent. - (adjusters at: #topAdjuster) morphPosition: cornerExtent@halfThickness extent: w@0. - (adjusters at: #bottomAdjuster) morphPosition: cornerExtent@(wh-halfThickness) extent: w@0. - (adjusters at: #leftAdjuster) morphPosition: halfThickness@cornerExtent extent: 0@h. - (adjusters at: #rightAdjuster) morphPosition: ww-halfThickness@cornerExtent extent: 0@h. - (adjusters at: #topLeftAdjuster) morphPosition: `0@0` extent: cornerExtent@cornerExtent. - (adjusters at: #topRightAdjuster) morphPosition: ww-cornerExtent@0 extent: cornerExtent@cornerExtent. - (adjusters at: #bottomLeftAdjuster) morphPosition: 0@(wh-cornerExtent) extent: cornerExtent@cornerExtent. - (adjusters at: #bottomRightAdjuster) morphPosition: ww@wh-cornerExtent extent: cornerExtent@cornerExtent. - - layoutMorph ifNotNil: [ - pos _ borderWidth @ (borderWidth + self labelHeight). - layoutMorph - morphPosition: pos - extent: extent - pos - borderWidth ]. - - self layoutNeeded: false.! ! -!MorphicCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 11/9/2020 15:28:39' prior: 50555797! - fillRectangle: aRectangle color: aColor borderWidth: borderWidth borderStyleSymbol: aSymbol baseColorForBorder: baseColorForBorder - " - (BitBltCanvas onForm: Display) - fillRectangle: (10@10 extent: 300@200) - color: Color green - borderWidth: 10 - borderStyleSymbol: #raised - baseColorForBorder: Color red. - Display forceToScreen. - " - - self fillRectangle: (aRectangle insetBy: borderWidth) color: aColor. - self frameRectangle: aRectangle color: baseColorForBorder borderWidth: borderWidth borderStyleSymbol: aSymbol! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/11/2021 18:18:35' prior: 50604655! - boundingRectOfCurrentMorphAfterDraw - "In targetForm coordinates. - Clipped to owner if appropriate. - Only valid for morphs where #morphLocalBounds is known. - Subclasses may raise this restriction. See inherintance, with VectorGraphics package loaded." - - | boundingRect | - boundingRect _ currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds. - "Include an extra pixel to cover possible anti aliasing." - boundingRect _ boundingRect outsetBy: 1. - ^ clippingMorphDisplayBounds - ifNotNil: [ :ownerClips | boundingRect intersect: ownerClips ] - ifNil: [ boundingRect ]! ! -!Theme methodsFor: 'other options' stamp: 'jmv 12/7/2010 14:32' prior: 16935698! - roundWindowCorners - ^true! ! - -BitBltCanvas removeSelector: #roundEdge:color:! - -!methodRemoval: BitBltCanvas #roundEdge:color: stamp: 'Install-4915-WindowEdgeAdjustersTweaks-JuanVuletich-2021Oct11-18h11m-jmv.001.cs.st 10/14/2021 14:31:54'! -roundEdge: aRectangle color: aColor - "NOP here"! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4915-WindowEdgeAdjustersTweaks-JuanVuletich-2021Oct11-18h11m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4910] on 12 October 2021 at 10:22:15 am'! -!MethodNode methodsFor: 'printing' stamp: 'jmv 10/12/2021 09:48:02' prior: 16872784! - printPrimitiveOn: aStream - "Print the primitive on aStream" - | primDecl | - primitive = 0 ifTrue: - [^self]. - primitive = 120 ifTrue: "External call spec" - [^aStream print: encoder literals first]. - aStream nextPutAll: '. - ((Smalltalk classNamed: #StackInterpreter) ifNil: [Smalltalk classNamed: #Interpreter]) ifNotNil: - [:interpreterClass| - aStream nextPutAll: ' "', ((interpreterClass primitiveTable) at: primitive + 1), '" ']! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4916-MethodNode-fix-JuanVuletich-2021Oct12-09h48m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4911] on 12 October 2021 at 11:15:05 am'! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 10/12/2021 11:06:35' prior: 50604216! - clippingByCurrentMorphDo: aBlock - "Do clipping only if currentMorph says so" - - | prevClipRect prevClippingMorphRect | - - currentMorph clipsSubmorphsReally ifFalse: [ ^aBlock value ]. - - prevClipRect _ self clipRect. - prevClippingMorphRect _ clippingMorphDisplayBounds. - clippingMorphDisplayBounds _ self boundingRectOfCurrentMorphAfterDraw insetBy: 1. - self setClipRect: (prevClipRect - ifNil: [clippingMorphDisplayBounds] - ifNotNil: [prevClipRect intersect: clippingMorphDisplayBounds]). - self clipCurrentMorph: true. - aBlock ensure: [ - self clipCurrentMorph: false. - self setClipRect: prevClipRect. - clippingMorphDisplayBounds _ prevClippingMorphRect ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4917-Morphic-smallFix-JuanVuletich-2021Oct12-11h14m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4912] on 12 October 2021 at 6:34:24 pm'! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 10/12/2021 18:29:15' prior: 50537417! - fullDrawHandOn: aCanvas - "A HandMorph has an unusual drawing requirement: - The hand itself (i.e., the cursor) appears in front of its submorphs - The illusion is that the hand plucks up morphs and carries them above the world." - - submorphs reverseDo: [ :m | aCanvas fullDraw: m ]. - self drawOn: aCanvas. "draw the hand itself in front of morphs" - lastPosition _ self morphPosition. "We already know we are carrying morphs."! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 10/12/2021 18:34:03' prior: 50615874! -displayFullBoundsForPatch - "Current full bounds of hand and carried submorphs. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around). - Integer pixel coordinates!!" - - | handBounds fullBounds submorphBounds | - handBounds _ self displayBounds. - submorphBounds _ nil. - self submorphsDo: [ :m | - submorphBounds _ m displayFullBounds quickMerge: submorphBounds ]. - fullBounds _ handBounds quickMerge: submorphBounds. - lastPosition - ifNotNil: [ :lastPos | "When already carrying morphs around. Update rectangle to current hand position." - fullBounds _ fullBounds quickMerge: (submorphBounds translatedBy: self morphPosition-lastPos) ]. - ^fullBounds encompassingIntegerRectangle! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 10/12/2021 18:30:46' prior: 50612919 overrides: 50611738! - morphPosition: aPoint - "Change the position of this morph. Argument is in owner's coordinates." - - | prevTranslation | - prevTranslation _ location translation. - location _ location withTranslation: aPoint. - "Ask if translation effectively changed, after possible conversion to 32 bit Float in AffineTransformation. " - location translation = prevTranslation ifFalse: [ - self isDrawnBySoftware - ifTrue: [ - Preferences cacheDisplayContentWhenMovingMorphs - ifTrue: [ - "We are caching whatever is in the Display below us. Thefore, there's no need - to do an invalidation that would trigger the redraw of everything below us." - self needsRedraw: true ] - ifFalse: [ - "No caching of stuff below us. Just invalidate and redraw." - self redrawNeeded ]] - ifFalse: [ - lastPosition _ nil. "Not nil if carrying morphs at that moment" - prevFullBounds _ nil "Any saved patch is no longer relevant"]].! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 10/12/2021 18:28:52' prior: 50579669! - grabMorph: aMorph delta: delta - "Grab the given morph (i.e., add it to this hand and remove it from its current owner)." - - | formerOwner formerPositionInWorld | - self releaseMouseFocus. "Break focus" - - "Grab the halo if present" - self halo ifNotNil: [ :h | - (h target == aMorph or: [h target hasOwner: aMorph]) ifTrue: [ - self addMorphBack: h position: h morphPositionInWorld - self morphPositionInWorld ]]. - - "Remember previous owner and position, in case the drop is later rejected" - formerOwner _ aMorph owner. - formerOwner ifNotNil: [ - formerPositionInWorld _ aMorph morphPositionInWorld. - grabMorphData - at: aMorph - put: { formerOwner. formerPositionInWorld. } ]. - self addMorphBack: aMorph position: delta. - - aMorph displayBounds ifNotNil: [ :r | | d | - formerPositionInWorld ifNotNil: [ - d _ aMorph morphPositionInWorld - formerPositionInWorld. - d isZero ifFalse: [ - aMorph adjustDisplayBoundsBy: d ]]]. - - aMorph justGrabbedFrom: formerOwner. - formerOwner ifNotNil: [ - "Morph was in the world" - lastPosition _ self morphPosition ].! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 10/12/2021 18:10:26' prior: 50612727! - grabMorph: aMorph moveUnderHand: moveUnderHand - "Grab the given morph (i.e., add it to this hand and remove it from its current owner). - If moveUnderHand is requested or it seems neccesary anyway, move the grabbed morph under the hand." - - | grabbed positionInHandCoordinates tx bounds | - self releaseMouseFocus. "Break focus" - grabbed _ aMorph. - aMorph owner ifNotNil: [ :o | grabbed _ o aboutToGrab: aMorph ]. - grabbed ifNil: [ ^ self ]. - grabbed _ grabbed aboutToBeGrabbedBy: self. - grabbed ifNil: [ ^ self ]. - self hideHardwareCursor. - self redrawNeeded. - - moveUnderHand ifTrue: [ - bounds _ nil. - grabbed isInWorld ifTrue: [ - grabbed displayBounds ifNotNil: [ :r | - bounds _ r translatedBy: grabbed morphPositionInWorld negated ]]. - bounds ifNil: [ bounds _ grabbed findFullBoundsInOwner ]. - positionInHandCoordinates _ (bounds center + bounds bottomRight //2) negated. - self grabMorph: grabbed delta: positionInHandCoordinates. - ^self ]. - - positionInHandCoordinates _ (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) - morphPositionInWorld - self morphPositionInWorld. - - tx _ GeometryTransformation identity. - (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) withAllOwnersDo: [ :o | - tx _ o location composedWith: tx ]. - self withAllOwnersReverseDo: [ :o | - tx _ o location inverseTransformation composedWith: tx ]. - self grabMorph: grabbed delta: positionInHandCoordinates. - - grabbed location: tx.! ! -!WorldMorph methodsFor: 'drawing' stamp: 'jmv 10/12/2021 16:41:47' prior: 50613156! - displayWorld - "Update this world's display." - - | deferredUpdateVMMode allDamage | - self checkIfUpdateNeeded ifFalse: [ ^ self ]. "display is already up-to-date" - - "I (jmv) removed the call to 'deferUpdates: false' below. No more need to call this every time. ?? revisar." - deferredUpdateVMMode _ self tryDeferredUpdatingAndSetCanvas. - - "Restore world canvas under hands and their carried morphs" - Preferences cacheDisplayContentWhenMovingMorphs ifTrue: [ - hands do: [ :h | h restoreSavedPatchOn: canvas ]]. - - "Update #displayBounds for all dirty morphs (marked as such with #redrawNeeded). - Also add the updated bounds to aDamageRecorder, and update bounds of morphs carried by hand." - canvas boundsFinderCanvas updateBoundsIn: self addDamageTo: damageRecorder. - - "repair world's damage on canvas" - allDamage _ canvas drawWorld: self repair: damageRecorder. - "allDamage ifNotNil: [Display border: allDamage width: 3 fillColor: Color random]. 'Debugging Aid'." - canvas newClipRect: nil. - - "Check which hands need to be drawn. - (they are not the hardware mouse pointer and carry morphs)" - self handsToDrawForDamage: allDamage do: [ :h | - Preferences cacheDisplayContentWhenMovingMorphs - ifTrue: [ allDamage _ (h savePatchFrom: canvas) quickMerge: allDamage ] - ifFalse: [ allDamage _ h displayFullBoundsForPatch quickMerge: allDamage ]. - canvas fullDrawHand: h . - h needsRedraw: false ]. - - "quickly copy altered rects of canvas to Display:" - deferredUpdateVMMode ifFalse: [ - allDamage ifNotNil: [ - "Drawing was done to off-Display canvas. Copy content to Display" - canvas showAt: self viewBox origin invalidRect: allDamage ]]. - - "Display deferUpdates: false." - "Display forceDisplayUpdate" - allDamage ifNotNil: [ - DisplayScreen isDisplayExtentOk ifTrue: [ - Display forceToScreen: allDamage ]].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/12/2021 16:41:53' prior: 50613351! - drawWorld: aWorldMorph repair: aDamageRecorder - "Redraw the damaged areas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | visibleRootMorphs visibleRootsDamage worldBackgroundRects | - visibleRootMorphs _ aWorldMorph privateSubmorphs select: [ :m | m visible ]. - visibleRootsDamage _ Array new: visibleRootMorphs size. - - worldBackgroundRects _ self computeDamage: aWorldMorph repair: aDamageRecorder - rootMorphs: visibleRootMorphs rootMorphsDamage: visibleRootsDamage. - aDamageRecorder reset. - - self drawWorldBackground: aWorldMorph rects: worldBackgroundRects. - "Debugging aids." - " - worldBackgroundRects do: [ :r | Display fill: r fillColor: Color random . Display forceToScreen. (Delay forSeconds: 0.005) wait]. - "" - visibleRootsDamage do: [ :r | r ifNotNil: [ Display fill: r fillColor: Color random . Display forceToScreen. (Delay forSeconds: 0.05) wait]]. - " - - ^ self drawWorld: aWorldMorph - rootMorphs: visibleRootMorphs rootMorphsDamage: visibleRootsDamage - backgroundDamage: worldBackgroundRects.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4918-HandInvalidationFixes-JuanVuletich-2021Oct12-18h18m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4913] on 12 October 2021 at 7:11:31 pm'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 10/12/2021 19:10:33' prior: 50603329! - drawCurrentAsError - "The morph (or one of its submorphs) had an error in its drawing method." - | r w | - r _ currentMorph morphLocalBoundsForError. - w _ r extent > `50@50` - ifTrue: [ 6 ] - ifFalse: [ 2 ]. - self - frameAndFillRectangle: r - fillColor: `Color red` - borderWidth: w - borderColor: `Color yellow`. - self line: r topLeft+1 to: r bottomRight-w width: w color: `Color yellow`. - self line: r topRight + (w negated@1) to: r bottomLeft + (1@ w negated) width: w color: `Color yellow`. - currentMorph displayBoundsSetFrom: self.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4919-DrawCurrentAsError-tweak-JuanVuletich-2021Oct12-19h02m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4919] on 13 October 2021 at 2:18:53 pm'! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 10/13/2021 14:18:16' prior: 50535982! - strictlyStaggeredInitialFrameFor: aStandardSystemView initialExtent: initialExtent world: aWorld - "This method implements a staggered window placement policy that I (di) like. - Basically it provides for up to 4 windows, staggered from each of the 4 corners. - The windows are staggered so that there will always be a corner visible." - - | allowedArea grid initialFrame otherFrames cornerSel corner delta putativeCorner free maxLevel | - allowedArea := (self maximumUsableAreaInWorld: aWorld) - insetBy: (self scrollBarSetback @ self screenTopSetback extent: `0 @ 0`). - "Number to be staggered at each corner (less on small screens)" - maxLevel := allowedArea area > 300000 ifTrue: [3] ifFalse: [2]. - "Amount by which to stagger (less on small screens)" - grid := allowedArea area > 500000 ifTrue: [40] ifFalse: [20]. - initialFrame := `0 @ 0` extent: initialExtent. - "min: (allowedArea extent - (grid*(maxLevel+1*2) + (grid//2)))) - min: 600@400" - otherFrames := (SystemWindow windowsIn: aWorld satisfying: [ :w | w visible and: [w isCollapsed not]]) - collect: [:w | w displayBounds]. - otherFrames _ otherFrames reject: [ :f | f isNil ]. - 0 to: maxLevel do: [ :level | - 1 to: 4 do: [ :ci | - cornerSel := #(#topLeft #topRight #bottomRight #bottomLeft) at: ci. - corner := allowedArea perform: cornerSel. - "The extra grid//2 in delta helps to keep title tabs distinct" - delta := ((maxLevel - level) * grid + (grid // 2)) @ (level * grid). - 1 to: ci - 1 do: [ :i | delta _ delta y negated @ delta x ]. "slow way" - putativeCorner := corner + delta. - free := true. - otherFrames do: [ :w | - free := free & (((w perform: cornerSel) - putativeCorner)r > 5)]. - free - ifTrue: [ - ^(initialFrame aligned: (initialFrame perform: cornerSel) - with: putativeCorner) translatedAndSquishedToBeWithin: allowedArea]]]. - "If all else fails..." - ^(self scrollBarSetback @ self screenTopSetback - extent: initialFrame extent) translatedAndSquishedToBeWithin: allowedArea! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4920-NewWindowPositionFix-JuanVuletich-2021Oct13-14h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4920] on 13 October 2021 at 2:55:43 pm'! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 10/13/2021 14:55:36' prior: 50579400! - drawRoundLookOn: aCanvas - | r colorForButton rect | - colorForButton _ self isPressed - ifFalse: [ - self mouseIsOver - ifTrue: [ Color h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ color ]] - ifTrue: [ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - rect _ self morphLocalBounds insetBy: `3@3`. - aCanvas roundRect: rect color: colorForButton radius: r ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawEmbossedLabelOn: aCanvas ] - ifFalse: [ self drawRegularLabelOn: aCanvas ].! ! - -DraggeableButtonMorph removeSelector: #isRoundButton! - -!methodRemoval: DraggeableButtonMorph #isRoundButton stamp: 'Install-4921-ModernizeScrollbars-JuanVuletich-2021Oct13-14h47m-jmv.001.cs.st 10/14/2021 14:31:54'! -isRoundButton - ^false! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4921-ModernizeScrollbars-JuanVuletich-2021Oct13-14h47m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4895] on 10 October 2021 at 12:58:06 pm'! -!HoverHelpMorph methodsFor: 'accessing' stamp: 'hlsf 10/10/2021 12:55:12' prior: 16853855! - contents: aString - | width | - contents _ aString. - width _ (contents includes: Character lf) - ifTrue: [9999999] ifFalse: [300]. - textComposition _ TextComposition new. - textComposition - setModel: (TextModel withText: contents asText); - extentForComposing: width@9999999. - textComposition composeAll. - self morphExtent: textComposition usedExtent + 8! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4922-HoverHelpMorph-CuisCore-HilaireFernandes-2021Oct10-12h47m-hlsf.001.cs.st----! - -'From Cuis 5.0 [latest update: #4922] on 13 October 2021 at 8:21:22 pm'! -!Integer methodsFor: 'mathematical functions' stamp: 'sqr 10/11/2021 21:24:29' prior: 16859572! - ifMultipleOf2And5Do: aBlock otherwise: anotherBlock - "If our prime factorization consists only of 2's and 5's, evaluate aBlock with the exponents. - Otherwise evaluate anotherBlock. - Be fast!!" - - | exponent2 exponent5 without2Factors | - exponent2 _ self lowBit-1. - without2Factors _ self bitShift: exponent2 negated. - exponent5 _ ( 0.430676558073393 "2 ln / 5 ln" * without2Factors highBit) truncated. - (5 raisedToInteger: exponent5) = without2Factors - ifTrue: [ - aBlock value: exponent2 value: exponent5 ] - ifFalse: [ - anotherBlock value ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4923-TypoFix-AndresValloud-2021Oct13-20h19m-sqr.001.cs.st----! - -'From Cuis 5.0 [latest update: #4923] on 14 October 2021 at 12:15:40 pm'! -!Morph methodsFor: 'structure' stamp: 'jmv 10/14/2021 10:27:31'! - wantsToBeOnTop: aBoolean - "If true, will be above all siblings who don't." - - self privateFlagAt: 6 put: aBoolean.! ! -!Morph methodsFor: 'testing' stamp: 'jmv 10/14/2021 10:27:38'! - wantsToBeOnTop - "If true, will be above all siblings who don't." - - ^ self privateFlagAt: 6.! ! -!Morph methodsFor: 'private' stamp: 'jmv 10/14/2021 10:36:00'! - privateArrangeWantsToBeOnTop - "Ensure that all morphs who #wantsToBeOnTop (i.e. toppers) are above all morphs who not #wantsToBeOnTop. - Do it without reordering these two subsets. - Do it in a single pass, and exit as soon as possible." - - | firstMisplacedTopperIndex firstNonTopperIndex topper nonTopper | - submorphs size < 2 ifTrue: [ ^self ]. - firstMisplacedTopperIndex _ 0. - firstNonTopperIndex _ 1. - [ - "Look for next." - [ (submorphs at: firstNonTopperIndex) wantsToBeOnTop ] whileTrue: [ - firstNonTopperIndex _ firstNonTopperIndex + 1. - firstNonTopperIndex = submorphs size ifTrue: [ - "All toppers until the end (at most, one non topper as last). Nothing else to do." - ^self ]]. - firstMisplacedTopperIndex _ firstMisplacedTopperIndex max: firstNonTopperIndex+1. - [ (submorphs at: firstMisplacedTopperIndex) wantsToBeOnTop not ] whileTrue: [ - firstMisplacedTopperIndex _ firstMisplacedTopperIndex + 1. - firstMisplacedTopperIndex > submorphs size ifTrue: [ - "No more toppers until the end. Nothing else to do." - ^self ]]. - - "We have actually found a misplaced topper. Fix it!!" - nonTopper _ submorphs at: firstNonTopperIndex. - topper _ submorphs at: firstMisplacedTopperIndex. - submorphs at: firstNonTopperIndex put: topper invalidateBounds. - submorphs at: firstMisplacedTopperIndex put: nonTopper invalidateBounds. - ] repeat.! ! -!StringRequestMorph methodsFor: 'testing' stamp: 'jmv 10/14/2021 10:31:13' overrides: 50616688! - wantsToBeOnTop - "If true, will be above all siblings who don't." - - ^ true! ! -!FillInTheBlankMorph methodsFor: 'testing' stamp: 'jmv 10/14/2021 10:28:52' overrides: 50616688! - wantsToBeOnTop - "If true, will be above all siblings who don't." - - ^ true! ! -!HoverHelpMorph methodsFor: 'testing' stamp: 'jmv 10/14/2021 10:27:49' overrides: 50616688! - wantsToBeOnTop - "If true, will be above all siblings who don't." - - ^ true! ! -!MenuMorph methodsFor: 'testing' stamp: 'jmv 10/14/2021 12:15:06' overrides: 50616688! - wantsToBeOnTop - "If true, will be above all siblings who don't." - - ^ true! ! -!AutoCompleterMorph methodsFor: 'testing' stamp: 'jmv 10/14/2021 10:29:00' overrides: 50616688! - wantsToBeOnTop - "If true, will be above all siblings who don't." - - ^ true! ! -!Morph methodsFor: 'private' stamp: 'jmv 10/14/2021 10:25:16' prior: 50614025! - privateAddAllMorphs: aCollection atIndex: index - "Private. Add aCollection of morphs to the receiver" - | myWorld itsWorld otherSubmorphs | - (aCollection allSatisfy: [ :m | self canAdd: m]) ifFalse: [ - (self confirm: 'Some requested morph requires VectorGraphics support. Do you want to install and activate it?') - ifTrue: [ - Feature require: 'VectorGraphics'. - MorphicCanvas activeSubclass: (Smalltalk at: #VectorCanvas) ] - ifFalse: [ - ^self error: 'We can''t add requested morphs.' ]]. - myWorld _ self world. - otherSubmorphs _ submorphs copyWithoutAll: aCollection. - (index between: 0 and: otherSubmorphs size) - ifFalse: [^ self error: 'index out of range']. - index = 0 - ifTrue:[ submorphs _ aCollection asArray, otherSubmorphs] - ifFalse:[ index = otherSubmorphs size - ifTrue:[ submorphs _ otherSubmorphs, aCollection] - ifFalse:[ submorphs _ otherSubmorphs copyReplaceFrom: index + 1 to: index with: aCollection ]]. - aCollection do: [:m | | itsOwner | - itsOwner _ m owner. - itsOwner ifNotNil: [ - itsWorld _ m world. - (itsWorld == myWorld) ifFalse: [ - itsWorld ifNotNil: [m redrawNeeded]]. - (itsOwner ~~ self) ifTrue: [ - m owner privateRemove: m. - m owner removedMorph: m ]]. - m privateOwner: self. - myWorld ifNotNil: [m redrawNeeded]. - (myWorld == itsWorld) ifFalse: [m intoWorld: myWorld]. - itsOwner == self ifFalse: [ - self addedMorph: m. - m noteNewOwner: self ]. - ]. - self privateArrangeWantsToBeOnTop. - self someSubmorphPositionOrExtentChanged! ! -!Morph methodsFor: 'private' stamp: 'jmv 10/14/2021 10:25:22' prior: 50614074! - privateAddMorph: aMorph atIndex: index position: aPointOrNil - - | oldIndex myWorld itsWorld oldOwner | - (self canAdd: aMorph) ifFalse: [ - (self confirm: 'The requested morph requires VectorGraphics support. Do you want to install and activate it?') - ifTrue: [ - Feature require: 'VectorGraphics'. - MorphicCanvas activeSubclass: (Smalltalk at: #VectorCanvas) ] - ifFalse: [ - ^self error: 'We can''t add requested morph.' ]]. - ((index >= 1) and: [index <= (submorphs size + 1)]) - ifFalse: [^ self error: 'index out of range']. - myWorld _ self world. - oldOwner _ aMorph owner. - (oldOwner == self and: [(oldIndex _ submorphs indexOf: aMorph) > 0]) ifTrue: [ - "aMorph's position changes within in the submorph chain" - oldIndex < index ifTrue:[ - "moving aMorph to back" - submorphs replaceFrom: oldIndex to: index-2 with: submorphs startingAt: oldIndex+1. - submorphs at: index-1 put: aMorph. - ] ifFalse:[ - "moving aMorph to front" - oldIndex-1 to: index by: -1 do:[:i| - submorphs at: i+1 put: (submorphs at: i)]. - submorphs at: index put: aMorph. - ]. - aPointOrNil ifNotNil: [aMorph privatePosition: aPointOrNil]. - ] ifFalse: [ - "adding a new morph" - oldOwner ifNotNil: [ - itsWorld _ aMorph world. - itsWorld ifNotNil: [aMorph invalidateBounds]. - oldOwner privateRemove: aMorph. - oldOwner removedMorph: aMorph. - ]. - aMorph privateOwner: self. - submorphs _ submorphs copyReplaceFrom: index to: index-1 with: (Array with: aMorph). - aPointOrNil ifNotNil: [aMorph privatePosition: aPointOrNil]. - (itsWorld == myWorld) ifFalse: [aMorph intoWorld: myWorld]. - ]. - myWorld ifNotNil: [ - index = 1 - ifTrue: [aMorph redrawNeeded ] - ifFalse: [aMorph invalidateBounds]]. - self privateArrangeWantsToBeOnTop. - self someSubmorphPositionOrExtentChanged. - oldOwner == self ifFalse: [ - self addedMorph: aMorph. - aMorph noteNewOwner: self ]! ! -!Morph methodsFor: 'private' stamp: 'jmv 10/14/2021 10:25:26' prior: 50530832! - privateMoveBackMorph: aMorph - - | oldIndex myWorld index | - myWorld _ self world. - "aMorph's position changes within in the submorph chain" - "moving aMorph to front" - oldIndex _ submorphs indexOf: aMorph. - "moving aMorph to back" - index _ submorphs size. - submorphs replaceFrom: oldIndex to: index-1 with: submorphs startingAt: oldIndex+1. - submorphs at: index put: aMorph. - myWorld ifNotNil: [aMorph redrawNeeded]. - self privateArrangeWantsToBeOnTop. - self someSubmorphPositionOrExtentChanged.! ! -!Morph methodsFor: 'private' stamp: 'jmv 10/14/2021 10:25:30' prior: 50530849! -privateMoveFrontMorph: aMorph - - | oldIndex myWorld | - myWorld _ self world. - "aMorph's position changes within in the submorph chain" - "moving aMorph to front" - oldIndex _ submorphs indexOf: aMorph. - oldIndex-1 to: 1 by: -1 do: [ :i | - submorphs at: i+1 put: (submorphs at: i)]. - submorphs at: 1 put: aMorph. - myWorld ifNotNil: [aMorph redrawNeeded]. - self privateArrangeWantsToBeOnTop. - self someSubmorphPositionOrExtentChanged.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4924-wantsToBeOnTop-JuanVuletich-2021Oct14-12h13m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4923] on 14 October 2021 at 10:59:24 am'! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 10/14/2021 10:56:28' prior: 50612623! - showHardwareCursor - - "Make the transition to using hardware cursor. - Report one final damage rectangle to erase the image of the software cursor." - self invalidateDisplayRect: self displayFullBoundsForPatch for: nil. - Cursor currentCursor == (Cursor cursorAt: #blankCursor) ifTrue: [ - "show hardware cursor" - Cursor defaultCursor activateCursor ].! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 10/14/2021 10:51:49' prior: 50612717! - dropMorphs: anEvent - "Drop the morphs at the hands position" - - self showHardwareCursor. - self submorphsReverseDo: [ :m | - "Drop back to front to maintain z-order" - self dropMorph: m event: anEvent ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4925-HandMorph-invalidationFix-JuanVuletich-2021Oct14-10h42m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4923] on 14 October 2021 at 11:12:23 am'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/14/2021 11:12:04' prior: 50613278! - computeDamage: aWorldMorph repair: aDamageRecorder rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage - "Iterate front to back while computing damage to actually repair for each morph, and for world background. - Answer uncoveredDamage, the areas where World background needs to be redrawn." - - | uncoveredDamage additionalUncoveredDamage morph morphDamage morphFullBounds | - uncoveredDamage _ aDamageRecorder damageReportedOther. - additionalUncoveredDamage _ OrderedCollection new. - - "Iterate from front to back" - 1 to: rootMorphs size do: [ :i | - morph _ rootMorphs at: i. - morphFullBounds _ morph displayFullBounds. - morphDamage _ nil. - "Reported damage can be ignored if the area fully covered by another morph above us." - (aDamageRecorder damageReportedFor: morph) ifNotNil: [ :r | | wasFullyCovered | - wasFullyCovered _ false. - 1 to: i-1 do: [ :j | - wasFullyCovered _ wasFullyCovered or: [ (rootMorphs at: j) fullyCovers: r ]]. - wasFullyCovered ifFalse: [ - uncoveredDamage add: r ]]. - "Any uncovered damage this morph may overlap must be redrawn by it." - uncoveredDamage withIndexDo: [ :r :j | | intersection | - r ifNotNil: [ - intersection _ r intersect: morphFullBounds. - intersection hasPositiveExtent ifTrue: [ - r = intersection ifTrue: [ uncoveredDamage at: j put: nil ]. - morphDamage - ifNil: [ morphDamage _ intersection ] - ifNotNil: [ morphDamage updateMerging: intersection ]]]]. - rootMorphsDamage at: i put: morphDamage. - uncoveredDamage add: morphDamage. - "Whatever we cover completely is no longer uncoveredDamage" - uncoveredDamage withIndexDo: [ :r :ri | - r ifNotNil: [ - morph - on: r - ifCovered: [uncoveredDamage at: ri put: nil] - uncoveredPartsDo: [ :r2 | additionalUncoveredDamage add: r2 ] - else: []]]. - uncoveredDamage addAll: additionalUncoveredDamage. - additionalUncoveredDamage removeAll. - ]. - - "Remove redundant rectangles" - 1 to: uncoveredDamage size do: [ :i1 | - (uncoveredDamage at: i1) ifNotNil: [ :r1 | - 1 to: uncoveredDamage size do: [ :i2 | - i1 = i2 ifFalse: [ - (uncoveredDamage at: i2) ifNotNil: [ :r2 | - (r1 containsRect: r2) - ifTrue: [ uncoveredDamage at: i2 put: nil ]]]]]]. - - "Answer any yet uncovered areas. World background should be drawn on them." - ^ uncoveredDamage select: [ :r | r notNil ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4926-InvalidationFix-JuanVuletich-2021Oct14-11h11m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4926] on 14 October 2021 at 12:11:46 pm'! -!FileList methodsFor: 'volume list and pattern' stamp: 'jmv 10/14/2021 12:11:31' prior: 50406386! - fileNameFormattedFrom: entry namePad: namePad sizePad: sizePad sizeWithCommasPad: sizeWithCommasPad - "entry is a 5-element array of the form: - (name creationTime modificationTime dirFlag fileSize)" - | sizeStr nameStr paddedNameStr dateStr someSpaces sizeDigits sizeDigitsAndCommas spacesToAdd font spaceWidth | - font _ Preferences standardListFont. - spaceWidth _ font widthOf: $ . - nameStr _ entry isDirectory - ifTrue: [ entry name , self folderString ] - ifFalse: [ entry name ]. - spacesToAdd _ namePad - (font widthOfString: nameStr) // spaceWidth. - paddedNameStr _ nameStr , - (String - new: spacesToAdd - withAll: $ ). - dateStr _ (entry modificationTime date printFormat: #(3 2 1 $/ 1 1 2 )) , ' ' , - (String streamContents: [ :s | - entry modificationTime time - print24: true - showSeconds: true - on: s ]). - sizeDigits _ entry fileSize printString size. - sizeStr _ entry fileSize printStringWithCommas. - sizeDigitsAndCommas _ sizeStr size. - spacesToAdd _ sizeWithCommasPad - sizeDigitsAndCommas. - "Usually a space takes the same space as a comma, and half the space of a digit. - Pad with 2 spaces for each missing digit and 1 space for each missing comma" - (font widthOf: Character space) ~= (font widthOf: $, ) - ifTrue: [spacesToAdd _ spacesToAdd + sizePad - sizeDigits max: 0]. - sizeStr _ (String new: spacesToAdd withAll: $ ) , sizeStr. - someSpaces _ String new: 6 withAll: $ . - " - sortMode = #name ifTrue: [ ^ paddedNameStr , someSpaces , '( ' , dateStr , someSpaces , sizeStr , ' )' ]. - sortMode = #date ifTrue: [ ^ '( ' , dateStr , someSpaces , sizeStr , ' )' , someSpaces , nameStr ]. - sortMode = #size ifTrue: [ ^ '( ' , sizeStr , someSpaces , dateStr , ' )' , someSpaces , nameStr ]. - " - ^ paddedNameStr , someSpaces , '( ' , dateStr , someSpaces , sizeStr , ' )' .! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4927-FileListFormatting-JuanVuletich-2021Oct14-12h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4923] on 14 October 2021 at 12:28:03 pm'! -!FileListWindow methodsFor: 'GUI building' stamp: 'hlsf 10/14/2021 12:27:46' prior: 16843354! - morphicPatternPane - - ^ (TextModelMorph - textProvider: model - textGetter: #pattern - textSetter: #pattern:) - acceptOnCR: true; - yourself.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4928-FileListPattern-acceptOnCR-HilaireFernandes-2021Oct14-12h26m-hlsf.001.cs.st----! - -----QUIT----(14 October 2021 14:31:57) Cuis5.0-4928-32.image priorSource: 8941307! - -----STARTUP---- (2 November 2021 10:27:33) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4928-32.image! - - -'From Cuis 5.0 [latest update: #4928] on 15 October 2021 at 1:09:52 pm'! -!MenuMorph methodsFor: 'testing' stamp: 'KLG 10/14/2021 23:47:37' prior: 50616757 overrides: 50616688! - wantsToBeOnTop - "If true, will be above all siblings who don't." - - ^ stayUp not! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4929-Menu-wantsToBeOnTop-Enhancement-GeraldKlix-2021Oct15-12h42m-KLG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4933] on 18 October 2021 at 2:46:00 pm'! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 10/18/2021 11:58:24' prior: 50616596! - drawRoundLookOn: aCanvas - | r colorForButton rect | - colorForButton _ self isPressed - ifFalse: [ - self mouseIsOver - ifTrue: [ Color h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ color ]] - ifTrue: [ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - rect _ self morphLocalBounds insetBy: `3@3`. - r _ r min: (rect width min: rect height) * 0.5. - aCanvas roundRect: rect color: colorForButton radius: r ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawEmbossedLabelOn: aCanvas ] - ifFalse: [ self drawRegularLabelOn: aCanvas ].! ! -!BitBltCanvas methodsFor: 'drawing-roundedRectangles' stamp: 'jmv 10/18/2021 14:45:01' prior: 50595745 overrides: 50463497! - roundRect: aRectangle color: aColor radius: aNumber - " - (BitBltCanvas onForm: Display) roundRect: (10@10 extent: 200@100) color: Color red radius: 10.5. Display forceToScreen. - " - | r | - r _ (currentTransformation externalizeScalar: aNumber) rounded. - - "top stripe" - self - image: (self class topLeftCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle topLeft. - self - image: (self class topRightCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle topRight - (r@0). - self fillRectangle: ((aRectangle withHeight: r) insetBy: r@0) color: aColor. - - "center stripe" - self fillRectangle: (aRectangle insetBy: (0 @ r corner: 0 @ r)) color: aColor. - - "bottom stripe" - self - image: (self class bottomLeftCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle bottomLeft - (0@r). - self - image: (self class bottomRightCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle bottomRight - (r@r) . - self fillRectangle: ((aRectangle bottomLeft + (r@r negated)) extent: (aRectangle width - r - r@r)) color: aColor! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4930-RoundedButtons-fix-JuanVuletich-2021Oct18-14h37m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4930] on 18 October 2021 at 4:59:38 pm'! -!Preferences class methodsFor: 'bigger and smaller GUI element sizes' stamp: 'jmv 10/18/2021 11:46:02' prior: 50602860! - scrollbarThickness - "Includes border. - No less than PluggableButtonMorph >> #minimumExtent." - ^Preferences windowTitleFont pointSize + 2! ! -!MorphicCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 10/18/2021 11:54:41' prior: 50595487! - frameRectangle: aRectangle color: aColor borderWidth: borderWidth borderStyleSymbol: aSymbol - " - (BitBltCanvas onForm: Display) - frameRectangle: (10@10 extent: 300@200) - color: Color green - borderWidth: 10 - borderStyleSymbol: #raised. - Display forceToScreen. - " - - | tlColor brColor | - tlColor _ aColor. - brColor _ aColor. - aSymbol == #raised ifTrue: [ - tlColor _ aColor lighter. - brColor _ aColor darker ]. - - aSymbol == #inset ifTrue: [ - tlColor _ aColor darker. - brColor _ aColor lighter ]. - - self frameRectangle: aRectangle topLeftColor: tlColor bottomRightColor: brColor borderWidth: borderWidth! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4931-ScrollbarButtons-tweaks-JuanVuletich-2021Oct18-16h59m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4934] on 18 October 2021 at 5:42:54 pm'! -!PluggableListMorph methodsFor: 'initialization' stamp: 'jmv 10/18/2021 17:18:08' prior: 50562027 overrides: 50601576! - initialize - scrollSiblings := false. "user must override" - super initialize. - scroller morphWidth: extent x.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4932-PluggableListMorph-fix-JuanVuletich-2021Oct18-17h42m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4932] on 18 October 2021 at 7:09:32 pm'! -!PluggableScrollPane commentStamp: '' prior: 16889491! - Allows viewing just part of a larger Morph. The scroll values vary from 0.0 to 1.0.! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/18/2021 11:24:30'! - adjustExtent - "Morphs intended to be included in PluggableScrollPanes as scrolled content might need to adjust their extent. - NOP by default."! ! -!PluggableScrollPane methodsFor: 'initialization' stamp: 'jmv 10/18/2021 11:23:18'! - scroller: contents - - scroller ifNotNil: [ scroller delete ]. - scroller _ contents. - self addMorphBack: scroller. - self scrollerOffset: `0@ 0`.! ! -!PluggableScrollPane methodsFor: 'events' stamp: 'jmv 10/18/2021 14:10:08' prior: 50449252 overrides: 50449239! - keyStroke: aKeyboardEvent - - ( self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - super keyStroke: aKeyboardEvent. - scroller ifNotNil: [ - scroller keyStroke: aKeyboardEvent ].! ! -!PluggableScrollPane methodsFor: 'events' stamp: 'jmv 10/18/2021 14:10:42' prior: 50458668 overrides: 16874541! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - - | eventPositionLocalToScroller | - scroller ifNotNil: [ - eventPositionLocalToScroller _ localEventPosition - scroller morphPosition. - scroller mouseButton1Down: aMouseButtonEvent localPosition: eventPositionLocalToScroller ]. - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: nil - clkNHalf: nil - dblClkSel: #doubleClick:localPosition: - dblClkNHalfSel: #doubleClickAndHalf:localPosition: - tripleClkSel: nil! ! -!PluggableScrollPane methodsFor: 'events' stamp: 'jmv 10/18/2021 14:10:57' prior: 50458688 overrides: 16874556! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - - | eventPositionLocalToScroller | - super mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition. - scroller ifNotNil: [ - eventPositionLocalToScroller _ localEventPosition - scroller morphPosition. - scroller mouseButton1Up: aMouseButtonEvent localPosition: eventPositionLocalToScroller ].! ! -!PluggableScrollPane methodsFor: 'events' stamp: 'jmv 10/18/2021 14:11:19' prior: 50458702 overrides: 16874651! - mouseMove: aMouseMoveEvent localPosition: localEventPosition - - | eventPositionLocalToScroller | - scroller ifNotNil: [ - eventPositionLocalToScroller _ localEventPosition - scroller morphPosition. - scroller mouseMove: aMouseMoveEvent localPosition: eventPositionLocalToScroller ].! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 10/18/2021 14:08:49' prior: 50556398 overrides: 50556356! - extentChanged: oldExtent - "Our extent changed. Must layout submorphs again." - - super extentChanged: oldExtent. - "Now reset widget sizes" - scroller ifNotNil: [ - scroller adjustExtent ]. - self updateScrollBarsBounds. - self setScrollDeltas. - self scrollSelectionIntoView ! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 10/18/2021 13:02:17' prior: 16889683! - hTotalScrollRange - "Return the width extent of the receiver's scrollable area" - scroller ifNil: [ ^0 ]. - ^scroller morphExtentInOwner x! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 10/18/2021 13:02:44' prior: 50578360 overrides: 50499535! - minimumExtent - | minW minH scrollerExtent | - scrollerExtent _ scroller ifNil: [ 0@0 ] ifNotNil: [ scroller morphExtentInOwner ]. - "Figure out the minimum extent for this pane so that either content, or at least required scrollbars, will fit" - minW _ self xtraBorder * 2 + scrollerExtent x min: ScrollBar scrollbarThickness * 2. - self vIsScrollbarShowing - ifTrue: [ - minW _ minW + ScrollBar scrollbarThickness]. - minH _ self xtraBorder * 2 + scrollerExtent y. - self hIsScrollbarShowing - ifTrue: [ - minH _ minH + ScrollBar scrollbarThickness]. - minH _ minH min: ScrollBar scrollbarThickness * 2. - ^ (minW + (borderWidth * 2)) @ (minH + (borderWidth * 2))! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 10/18/2021 13:02:01' prior: 16889824! - vTotalScrollRange - "Return the height extent of the receiver's scrollable area" - scroller ifNil: [ ^0 ]. - ^scroller morphExtentInOwner y! ! -!PluggableScrollPane methodsFor: 'initialization' stamp: 'jmv 10/18/2021 19:06:12' prior: 50601576 overrides: 50384377! - initialize - - "initialize the state of the receiver" - super initialize. - hideScrollBars _ #showIfNeeded. - - "initialize the receiver's scrollBars" - scrollBar _ ScrollBar new model: self setValueSelector: #vScrollBarValue:. - hScrollBar _ ScrollBar new model: self setValueSelector: #hScrollBarValue:. - drawKeyboardFocusIndicator _ Preferences drawKeyboardFocusIndicator. - - self innerMorphClass ifNotNil: [ :contentsClass | - self scroller: contentsClass new ]. - self addMorph: scrollBar. - self addMorph: hScrollBar.! ! -!PluggableScrollPane methodsFor: 'initialization' stamp: 'jmv 10/18/2021 11:18:31' prior: 16889884! - innerMorphClass - ^nil! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'jmv 10/18/2021 19:07:42' prior: 16889899! - hHideScrollBar - hScrollBar hide. - scroller ifNotNil: [ - scroller adjustExtent ].! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'jmv 10/18/2021 19:08:19' prior: 16889914! - hScrollBarValue: scrollValue - - | x | - scroller ifNotNil: [ - self hIsScrollbarShowing ifFalse: [ - ^self scrollerOffset: 0@self scrollerOffset y ]. - (x _ self hLeftoverScrollRange * scrollValue) <= 0 - ifTrue: [ x _ 0 ]. - self scrollerOffset: x@self scrollerOffset y ].! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'jmv 10/18/2021 19:09:01' prior: 16889925! - hShowScrollBar - - hScrollBar show. - scroller ifNotNil: [ - scroller adjustExtent ].! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'jmv 10/18/2021 14:12:38' prior: 50406131! - scrollBy: delta - "Move the contents in the direction delta." - - | newYoffset yRange xRange newXoffset | - - "Set the offset on the scroller" - yRange _ self vLeftoverScrollRange. - xRange _ self hLeftoverScrollRange. - - scroller ifNotNil: [ - newYoffset _ self scrollerOffset y - delta y min: yRange max: 0. - newXoffset _ self scrollerOffset x - delta x min: xRange max: 0. - self scrollerOffset: newXoffset@newYoffset ]. - - "Update the scrollBars" - scrollBar scrollValue: (yRange ifNotZero: [newYoffset asFloat / yRange]). - hScrollBar scrollValue: (xRange ifNotZero: [newXoffset asFloat / xRange]).! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'jmv 10/18/2021 19:07:48' prior: 16890011! - vHideScrollBar - scrollBar hide. - scroller ifNotNil: [ - scroller adjustExtent ].! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'jmv 10/18/2021 19:08:44' prior: 16890025! - vScrollBarValue: scrollValue - - scroller ifNotNil: [ - self scrollerOffset: - (self scrollerOffset x @ - (self vLeftoverScrollRange * scrollValue) rounded) ].! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'jmv 10/18/2021 19:09:04' prior: 16890032! - vShowScrollBar - - scrollBar show. - scroller ifNotNil: [ - scroller adjustExtent ].! ! - -InnerPluggableMorph removeSelector: #adjustExtent! - -!methodRemoval: InnerPluggableMorph #adjustExtent stamp: 'Install-4933-AllowArbitraryScroller-JuanVuletich-2021Oct18-19h03m-jmv.001.cs.st 11/2/2021 10:27:38'! -adjustExtent - "Morphs intended to be included in PluggableScrollPanes as scrolled content might need to adjust their extent." - - self subclassResponsibility! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4933-AllowArbitraryScroller-JuanVuletich-2021Oct18-19h03m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4933] on 18 October 2021 at 8:07:24 pm'! - -PluggableMorph subclass: #PluggableScrollPane - instanceVariableNames: 'scrollBar scroller hScrollBar hideScrollBars drawKeyboardFocusIndicator scrollerRadians scrollerScale theScrollerExtent ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #PluggableScrollPane category: 'Morphic-Widgets' stamp: 'Install-4934-AllowNonWidgetsInScrollPanes-JuanVuletich-2021Oct18-19h55m-jmv.002.cs.st 11/2/2021 10:27:38'! -PluggableMorph subclass: #PluggableScrollPane - instanceVariableNames: 'scrollBar scroller hScrollBar hideScrollBars drawKeyboardFocusIndicator scrollerRadians scrollerScale theScrollerExtent' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! -!PluggableScrollPane commentStamp: 'jmv 10/18/2021 19:56:27' prior: 50617266! - Allows viewing just part of a larger Morph. The scroll values vary from 0.0 to 1.0. - -| p | -p := PluggableScrollPane new. -p scroller: WidgetMorph new. -p openInWorld. - -| p | -p := PluggableScrollPane new. -p scroller: Sample01Star new. -p openInWorld.! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/18/2021 14:52:24'! - topLeftInOwner - - ^self fullBoundsInOwner origin! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 10/18/2021 14:53:02' overrides: 50617543! - topLeftInOwner - - ^self morphPosition! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 10/18/2021 14:53:07' overrides: 50617543! - topLeftInOwner - - ^self morphPosition! ! -!InnerTextMorph methodsFor: 'geometry' stamp: 'jmv 10/18/2021 19:50:20' prior: 50556378 overrides: 50556356! - extentChanged: oldExtent - "Our extent changed. Reflow text." - super extentChanged: oldExtent. - model ifNotNil: [ - wrapFlag ifTrue: [ - extent x = oldExtent x ifFalse: [ - self resetTextComposition. - self editor recomputeSelection. - owner - updateScrollBarsBounds; - setScrollDeltas ]]]! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 10/18/2021 20:02:53' prior: 50617368 overrides: 50499535! - minimumExtent - | minW minH h w | - w _ theScrollerExtent ifNotNil: [ theScrollerExtent x ] ifNil: [ 0 ]. - h _ theScrollerExtent ifNotNil: [ theScrollerExtent y ] ifNil: [ 0 ]. - "Figure out the minimum extent for this pane so that either content, or at least required scrollbars, will fit" - minW _ self xtraBorder * 2 + w min: ScrollBar scrollbarThickness * 2. - self vIsScrollbarShowing - ifTrue: [ - minW _ minW + ScrollBar scrollbarThickness]. - minH _ self xtraBorder * 2 + h. - self hIsScrollbarShowing - ifTrue: [ - minH _ minH + ScrollBar scrollbarThickness]. - minH _ minH min: ScrollBar scrollbarThickness * 2. - ^ (minW + (borderWidth * 2)) @ (minH + (borderWidth * 2))! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 10/18/2021 14:53:34' prior: 50461121! - scrollerOffset - - ^ scroller topLeftInOwner negated + self viewableAreaTopLeft! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 10/18/2021 15:07:28' prior: 50461127! - scrollerOffset: newOffset - - | delta | - delta _ scroller topLeftInOwner - scroller morphPosition. - scroller morphPosition: self viewableAreaTopLeft - newOffset - delta! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 10/18/2021 20:07:16' prior: 16889767 overrides: 50537666! - someSubmorphPositionOrExtentChanged - "Our extent, or some submorph changed. Must layout submorphs again." - - super someSubmorphPositionOrExtentChanged. - scroller ifNotNil: [ | scrollerLocation doIt | - doIt _ false. - scroller hasVariableExtent ifTrue: [ - theScrollerExtent = scroller morphExtentInOwner ifFalse: [ - theScrollerExtent _ scroller morphExtentInOwner. - doIt _ true ]]. - scrollerLocation _ scroller location. - scrollerScale = scrollerLocation scale ifFalse: [ - scrollerScale _ scrollerLocation scale. - doIt _ true ]. - scrollerRadians = scrollerLocation radians ifFalse: [ - scrollerRadians _ scrollerLocation radians. - doIt _ true ]. - doIt ifTrue: [ self setScrollDeltas ]].! ! -!PluggableScrollPane methodsFor: 'initialization' stamp: 'jmv 10/18/2021 19:47:13' prior: 50617401 overrides: 50384377! - initialize - - "initialize the state of the receiver" - super initialize. - hideScrollBars _ #showIfNeeded. - - "initialize the receiver's scrollBars" - scrollBar _ ScrollBar new model: self setValueSelector: #vScrollBarValue:. - hScrollBar _ ScrollBar new model: self setValueSelector: #hScrollBarValue:. - drawKeyboardFocusIndicator _ Preferences drawKeyboardFocusIndicator. - self addMorph: scrollBar. - self addMorph: hScrollBar. - self updateScrollBarsBounds. - self innerMorphClass ifNotNil: [ :contentsClass | - self scroller: contentsClass new ].! ! - -PluggableMorph subclass: #PluggableScrollPane - instanceVariableNames: 'scrollBar scroller hScrollBar hideScrollBars drawKeyboardFocusIndicator scrollerScale scrollerRadians theScrollerExtent' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #PluggableScrollPane category: 'Morphic-Widgets' stamp: 'Install-4934-AllowNonWidgetsInScrollPanes-JuanVuletich-2021Oct18-19h55m-jmv.002.cs.st 11/2/2021 10:27:39'! -PluggableMorph subclass: #PluggableScrollPane - instanceVariableNames: 'scrollBar scroller hScrollBar hideScrollBars drawKeyboardFocusIndicator scrollerScale scrollerRadians theScrollerExtent' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4934-AllowNonWidgetsInScrollPanes-JuanVuletich-2021Oct18-19h55m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4913] on 18 October 2021 at 6:47:02 pm'! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'private' stamp: 'HAW 10/18/2021 18:33:35'! - findSourceRangeOfCloserStatementIn: listOfAncestors ifNone: noneBlock - - ^ (listOfAncestors - detect: [ :assoc | assoc key isBlockNode ] - ifFound: [ :assoc | listOfAncestors before: assoc ifNone: noneBlock ] - ifNone: noneBlock) value! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'private' stamp: 'HAW 10/18/2021 18:33:59' prior: 50508761! - intervalMatchesBeginningOfStatement - - ^ (self findSourceRangeOfCloserStatementIn: initialNodeAncestors ifNone: [ initialNodeAncestors last ]) first = intervalToExtract first! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'private' stamp: 'HAW 10/18/2021 18:34:28' prior: 50610536! - intervalMatchesEndOfStatement - - | closerStatementLastPosition | - - closerStatementLastPosition := (self findSourceRangeOfCloserStatementIn: finalNodeAncestors ifNone: [ finalNodeAncestors first ]) last. - ^ closerStatementLastPosition = intervalToExtract last or: [ closerStatementLastPosition - 1 = intervalToExtract last ].! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'private' stamp: 'HAW 10/18/2021 17:49:29' prior: 50517670! - isLeftSideOfAssignment - - ^ initialNodeAncestors size > 1 - and: [ self startAndEndParseNodesAreTheSame ] - and: [ initialNodeAncestors second key isAssignmentNode ] - and: [ initialNodeAncestors second key variable = initialNode key ] - and: [ initialNodeAncestors second key variable isInstanceVariableNode not ]! ! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #findSourceRangeOfCloserStatementIn:! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition #findSourceRangeOfCloserStatementIn: stamp: 'Install-4935-ExtractMethodFixWhenManyBlocksInsideABlock-HernanWilkinson-2021Oct18-12h39m-HAW.001.cs.st 11/2/2021 10:27:39'! -findSourceRangeOfCloserStatementIn: listOfAncestors - - ^ (listOfAncestors - detect: [ :assoc | assoc key isBlockNode ] - ifFound: [ :assoc | listOfAncestors before: assoc ifNone: [ listOfAncestors last ] ] - ifNone: [ listOfAncestors last ]) value! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4935-ExtractMethodFixWhenManyBlocksInsideABlock-HernanWilkinson-2021Oct18-12h39m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4935] on 22 October 2021 at 12:23:16 pm'! -!PluggableListMorph methodsFor: 'accessing' stamp: 'jmv 10/22/2021 11:57:37' prior: 16888560! - rowAtLocation: aPoint - "Return the row at the given point or 0 if outside" - - ^scroller rowAtLocation: (scroller internalize: aPoint)! ! -!PluggableListMorph methodsFor: 'accessing' stamp: 'jmv 10/22/2021 11:57:48' prior: 50425969! - rowAtLocation: aPoint ifNone: aNoneBlock - - ^scroller rowAtLocation: (scroller internalize: aPoint) ifNone: aNoneBlock! ! -!PluggableListMorph methodsFor: 'event handling' stamp: 'jmv 10/22/2021 11:57:11' prior: 16888701 overrides: 16889892! - mouseButton2Activity - scroller highlightedRow: nil. - super mouseButton2Activity! ! -!PluggableListMorph methodsFor: 'events' stamp: 'jmv 10/22/2021 11:56:47' prior: 50546635 overrides: 50579662! - dragEvent: aMouseEvent localPosition: localEventPosition - - | row dragged listItem sm | - scroller highlightedRow: nil. - row _ self rowAtLocation: localEventPosition ifNone: [ ^self ]. - listItem _ self getListItem: row. - - sm _ LabelMorph contents: listItem. - dragged _ DraggingGuideMorph new. - dragged addMorph: sm. - dragged morphExtent: sm morphExtent. - dragged setProperty: #dragSource toValue: self. - dragged setProperty: #dropSelectorArgument toValue: listItem. - - aMouseEvent hand attachMorphBeside: dragged.! ! -!PluggableListMorph methodsFor: 'events' stamp: 'jmv 10/22/2021 11:56:57' prior: 50426137 overrides: 50617298! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - - | row | - - self hasKeyboardFocus ifFalse: [ - aMouseButtonEvent hand newKeyboardFocus: self. - "If we are focusing, deselect, so that later selection doesn't result in deselect." - scroller noSelection]. - row _ self - rowAtLocation: localEventPosition - ifNone: [^super mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition ]. - - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view. - Model update will be done on mouse button up, so this feedback will be visible before that." - scroller highlightedRow: row. - - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: #click:localPosition: - clkNHalf: nil - dblClkSel: (doubleClickSelector ifNotNil: [ #doubleClick:localPosition: ]) - dblClkNHalfSel: nil - tripleClkSel: nil - dragSel: (self itemsAreDraggable ifTrue: [ #dragEvent:localPosition: ] ifFalse: [ nil ])! ! -!PluggableListMorph methodsFor: 'events' stamp: 'jmv 10/22/2021 11:57:13' prior: 50461008 overrides: 50593187! - mouseLeave: event - super mouseLeave: event. - scroller highlightedRow: nil! ! -!PluggableListMorph methodsFor: 'events-processing' stamp: 'jmv 10/22/2021 11:57:19' prior: 50461154 overrides: 16875055! - processMouseMove: aMouseMoveEvent localPosition: localEventPosition - "Reimplemented because we really want #mouseMove when a morph is dragged around" - - aMouseMoveEvent wasHandled ifTrue: [ ^self ]. "not interested" - scroller highlightedRow: ( - (self viewableArea containsPoint: localEventPosition) ifTrue: [ - self rowAtLocation: localEventPosition ifNone: []]). - (aMouseMoveEvent anyButtonPressed and: [ self hasMouseFocus ]) ifFalse: [ ^self ]. - aMouseMoveEvent wasHandled: true. - self mouseMove: aMouseMoveEvent localPosition: localEventPosition. - (self handlesMouseStillDown: aMouseMoveEvent) ifTrue:[ - "Step at the new location" - self startStepping: #processMouseStillDown stepTime: 1 ]! ! -!PluggableListMorph methodsFor: 'initialization' stamp: 'jmv 10/22/2021 11:56:49' prior: 16888752! - font - - ^ scroller font -! ! -!PluggableListMorph methodsFor: 'initialization' stamp: 'jmv 10/22/2021 11:56:52' prior: 16888756! - font: aFontOrNil - scroller font: aFontOrNil. -! ! -!PluggableListMorph methodsFor: 'selection' stamp: 'jmv 10/22/2021 11:57:16' prior: 50380190! - privateVisualSelectionIndex: index - "Called internally to select the index-th item. - Does not update model" - | row | - row _ index ifNil: [ 0 ]. - row _ row min: self getListSize. "make sure we don't select past the end" - scroller selectedRow: row. - self scrollSelectionIntoView! ! -!PluggableListMorph methodsFor: 'selection' stamp: 'jmv 10/22/2021 12:10:55' prior: 50380210! - visualSelectionIndex - "return the index we have currently selected, or 0 if none" - ^scroller selectedRow ifNil: [ 0 ]! ! -!PluggableListMorph methodsFor: 'updating' stamp: 'jmv 10/22/2021 12:10:51' prior: 50380543! - updateList - | index | - "the list has changed -- update from the model" - self getList. - scroller listChanged. - self setScrollDeltas. - index _ self getCurrentSelectionIndex. - self privateVisualSelectionIndex: index! ! -!PluggableListMorph methodsFor: 'private' stamp: 'jmv 10/22/2021 11:56:44' prior: 50455218! - changeSelectionTo: nextSelection - - nextSelection = self getCurrentSelectionIndex ifFalse: [ - | window | - window _ self owningWindow. - (window isNil or: [ window okToChangeDueTo: self ]) ifTrue: [ - "No change if model is locked" - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - scroller highlightedRow: nextSelection. - "Update the model in next world cycle, so user gets the immediate feedback." - UISupervisor whenUIinSafeState: [ self setSelectionIndex: nextSelection ]. - ] - ]! ! -!PluggableListMorph methodsFor: 'scrolling' stamp: 'jmv 10/22/2021 12:22:50' prior: 50561940 overrides: 16889986! - scrollSelectionIntoView - "make sure that the current selection is visible" - | row r | - row _ self getCurrentSelectionIndex. - row = 0 - ifTrue: [ - "Value is 0, but we need to propagate it to model" - scrollBar internalScrollValue: scrollBar scrollValue ] - ifFalse: [ - self flag: #jmvVer2. - r _ scroller drawBoundsForRow: row. - r _ ((scroller externalize: r origin) extent: r extent). - self scrollToShow: r ]. - self scrollMySiblings -! ! -!PluggableListMorphOfMany methodsFor: 'events' stamp: 'jmv 10/22/2021 12:11:06' prior: 50573351 overrides: 50617808! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - - | oldIndex oldVal row w | - self hasKeyboardFocus ifFalse: [ - aMouseButtonEvent hand newKeyboardFocus: self ]. - - row _ self rowAtLocation: localEventPosition. - - row = 0 ifTrue: [ - ^super mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition ]. - - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - scroller highlightedRow: row. - - w _ self owningWindow. - (w isNil or: [ w okToChange ]) ifTrue: [ "No change if model is locked" - - "Set meaning for subsequent dragging of selection" - dragOnOrOff _ (self listSelectionAt: row) not. - dragStartRow _ row. - oldIndex _ self getCurrentSelectionIndex. - oldIndex ~= 0 ifTrue: [oldVal _ self listSelectionAt: oldIndex]. - - "Different from PluggableListMorph. There, we highlight on mouse down, and act on mouse up. - Here, we act on mouse down, because we support dragging of selection, so mouse up will - only happen after user is finished dragging. In order to get the highlight visible for the user, - update the model on next world cycle." - UISupervisor whenUIinSafeState: [ - "Set or clear new primary selection (listIndex)" - dragOnOrOff == true - ifTrue: [self setSelectionIndex: row] - ifFalse: [self setSelectionIndex: 0]. - "Need to restore the old one, due to how model works, and set new one." - oldIndex ~= 0 ifTrue: [self listSelectionAt: oldIndex put: oldVal]. - self listSelectionAt: row put: dragOnOrOff ]. - ]. - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: nil - clkNHalf: nil - dblClkSel: #doubleClick:localPosition: - dblClkNHalfSel: nil - tripleClkSel: nil! ! - -PluggableListMorph removeSelector: #listMorph! - -!methodRemoval: PluggableListMorph #listMorph stamp: 'Install-4936-Cleanup-JuanVuletich-2021Oct22-12h22m-jmv.001.cs.st 11/2/2021 10:27:39'! -listMorph -self flag: #jmvVer. -"Podemos reemplazar los senders locales por accesos directos (el doble encapsulamiento es tonto) una vez que quede definido el shape de la clase!!" - ^scroller! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4936-Cleanup-JuanVuletich-2021Oct22-12h22m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4935] on 22 October 2021 at 12:27:13 pm'! -!TextModelMorph methodsFor: 'accessing' stamp: 'jmv 10/22/2021 12:14:38'! - innerTextMorph - ^ scroller! ! -!TextModelMorph methodsFor: 'accessing' stamp: 'jmv 10/22/2021 11:53:17' prior: 50369322! - disableEditing - scroller disableEditing! ! -!TextModelMorph methodsFor: 'accessing' stamp: 'jmv 10/22/2021 11:53:38' prior: 16933959! - editor - ^scroller editor! ! -!TextModelMorph methodsFor: 'accessing' stamp: 'jmv 10/22/2021 11:53:41' prior: 50369326! - enableEditing - - scroller enableEditing! ! -!TextModelMorph methodsFor: 'accessing' stamp: 'jmv 10/22/2021 11:54:30' prior: 16933975! - wrapFlag: aBoolean - scroller wrapFlag: aBoolean! ! -!TextModelMorph methodsFor: 'dependents access' stamp: 'jmv 10/22/2021 11:53:12' prior: 16933980 overrides: 16874095! - canDiscardEdits - "Return true if this view either has no text changes or does not care." - - ^ scroller canDiscardEdits! ! -!TextModelMorph methodsFor: 'drawing' stamp: 'jmv 10/22/2021 11:53:33' prior: 50530732 overrides: 50596573! - drawOn: aCanvas - "Include a thin red inset border for unaccepted edits, or, if the unaccepted edits are known to conflict with a change made somewhere else to the same method (typically), put a thick red frame" - | bw bc | - self flag: #todo. - "Integrate this method with the Theme system. --cbr" - super drawOn: aCanvas. - bw _ Preferences focusIndicatorWidth. - bc _ nil. - self wantsFrameAdornments ifTrue: [ - model refusesToAccept - ifTrue: [ "Put up feedback showing that code cannot be submitted in this state" - bc _ Color tan ] - ifFalse: [ - scroller hasEditingConflicts - ifTrue: [ - bw _ 3. - bc _ Color red ] - ifFalse: [ - scroller hasUnacceptedEdits ifTrue: [ bc _ Color red ]]]]. - (drawKeyboardFocusIndicator and: [ scroller hasKeyboardFocus ]) - ifTrue: [ bc ifNil: [ bc _ Theme current focusIndicator ]] - ifFalse: [ - bc ifNotNil: [ - bc _ bc - alphaMixed: 0.4 - with: Color white ]]. - bc ifNotNil: [ - aCanvas - frameRectangle: self focusIndicatorRectangle - borderWidth: bw - color: bc ].! ! -!TextModelMorph methodsFor: 'editor access' stamp: 'jmv 10/22/2021 11:54:07' prior: 50458713 overrides: 16889986! - scrollSelectionIntoView - "Scroll my text into view if necessary and return true, else return false" - - | delta | - delta _ scroller morphPosition. - self editor pointIndex > 1 - ifTrue: [ - self scrollToShow: (self editor pointBlock translatedBy: delta) ] - ifFalse: [ - self scrollToShow: (self editor selectionRectangle translatedBy: delta) ]! ! -!TextModelMorph methodsFor: 'editor access' stamp: 'jmv 10/22/2021 11:54:10' prior: 16934037! - selectAll - "Tell my textMorph's editor to select all" - - scroller selectAll! ! -!TextModelMorph methodsFor: 'events' stamp: 'jmv 10/22/2021 11:53:15' prior: 50381734! - clickAndHalf: aMouseButtonEvent localPosition: localEventPosition - - scroller clickAndHalf: aMouseButtonEvent localPosition: localEventPosition! ! -!TextModelMorph methodsFor: 'events' stamp: 'jmv 10/22/2021 11:53:20' prior: 16934049 overrides: 16889535! - doubleClickAndHalf: aMouseButtonEvent localPosition: localEventPosition - - scroller doubleClickAndHalf: aMouseButtonEvent localPosition: localEventPosition! ! -!TextModelMorph methodsFor: 'events' stamp: 'jmv 10/22/2021 11:53:52' prior: 50449300 overrides: 50617288! - keyStroke: aKeyboardEvent - "A keystroke was hit while the receiver had keyboard focus. Pass the keywtroke on to my textMorph, and and also, if I have an event handler, pass it on to that handler" - - (self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - scroller keyStroke: aKeyboardEvent! ! -!TextModelMorph methodsFor: 'events' stamp: 'jmv 10/22/2021 11:54:04' prior: 16934072 overrides: 50593173! - mouseEnter: event - super mouseEnter: event. - Preferences focusFollowsMouse - ifTrue: [ event hand newKeyboardFocus: scroller ]! ! -!TextModelMorph methodsFor: 'event handling' stamp: 'jmv 10/22/2021 11:54:02' prior: 16934079 overrides: 16889892! - mouseButton2Activity - scroller mouseButton2Activity! ! -!TextModelMorph methodsFor: 'focus handling' stamp: 'jmv 10/22/2021 11:53:47' prior: 16934084! - focusText - - self world activeHand newKeyboardFocus: scroller! ! -!TextModelMorph methodsFor: 'initialization' stamp: 'jmv 10/22/2021 11:53:05' prior: 16934104! - acceptOnCR: aBoolean - scroller acceptOnCR: aBoolean! ! -!TextModelMorph methodsFor: 'initialization' stamp: 'jmv 10/22/2021 11:53:43' prior: 50432738! - escAction: aBlock - - scroller escAction: aBlock! ! -!TextModelMorph methodsFor: 'initialization' stamp: 'jmv 10/22/2021 11:53:59' prior: 16934119 overrides: 16889461! - model: aTextModel - - super model: aTextModel. - scroller model: model wrappedTo: self viewableWidth. - model refetch. - self setScrollDeltas! ! -!TextModelMorph methodsFor: 'model access' stamp: 'jmv 10/22/2021 11:54:13' prior: 16934171! - setTextColor: aColor - "Set the color of my text to the given color" - - scroller color: aColor! ! -!TextModelMorph methodsFor: 'scrolling' stamp: 'jmv 10/22/2021 11:53:55' prior: 16934189 overrides: 16889689! - mightNeedHorizontalScrollBar - - scroller isWrapped ifTrue: [ ^false ]. - - ^super mightNeedHorizontalScrollBar -! ! -!TextModelMorph methodsFor: 'unaccepted edits' stamp: 'jmv 10/22/2021 11:53:09' prior: 16934196! - askBeforeDiscardingEdits: aBoolean - "Set the flag that determines whether the user should be asked before discarding unaccepted edits." - - scroller askBeforeDiscardingEdits: aBoolean! ! -!TextModelMorph methodsFor: 'unaccepted edits' stamp: 'jmv 10/22/2021 11:53:50' prior: 16934205! - hasUnacceptedEdits: aBoolean - "Set the hasUnacceptedEdits flag in my morph." - scroller hasUnacceptedEdits: aBoolean! ! -!TextModelMorph methodsFor: 'updating' stamp: 'jmv 10/22/2021 11:54:19' prior: 50452644! - updateAcceptedContents - - scroller hasUnacceptedEdits ifTrue: [ - scroller hasEditingConflicts: true. - ^self redrawNeeded ]. - model refetch. - "#actualContents also signalled in #refetch. No need to repeat what's done there." - ^self ! ! -!TextModelMorph methodsFor: 'updating' stamp: 'jmv 10/22/2021 11:54:22' prior: 50452654! - updateActualContents - - "Some day, it would be nice to keep objects and update them - instead of throwing them away all the time for no good reason..." - scroller - releaseEditorAndTextComposition; - installEditorAndTextComposition; - formatAndStyleIfNeeded. - self setScrollDeltas. - self redrawNeeded. - ^self ! ! -!TextModelMorph methodsFor: 'updating' stamp: 'jmv 10/22/2021 11:54:24' prior: 50474008! - updateAutoSelect - - TextEditor abandonChangeText. "no replacement!!" - self selectMessage - ifFalse: [ self selectString ]. - - scroller updateFromTextComposition. - ^self scrollSelectionIntoView! ! -!TextModelMorph methodsFor: 'updating' stamp: 'jmv 10/22/2021 11:54:26' prior: 50452697! - updateShoutStyled - - scroller stylerStyled. - ^self redrawNeeded ! ! -!MessageNamesWindow methodsFor: 'GUI building' stamp: 'jmv 10/22/2021 12:14:51' prior: 50495726 overrides: 50518739! - buildMorphicWindow - "Answer a morphic window with the given initial search string, nil if none" - "MessageNames openMessageNames" - | selectorListView firstRow searchButton secondRow | - textMorph _ (TextModelMorph - textProvider: model - textGetter: #searchString - textSetter: #searchString: - selectionGetter: #contentsSelection) - setBalloonText: 'See MessageNames class comment for search string options'; - emptyTextDisplayMessage: 'Type here, then hit Search'. - textMorph askBeforeDiscardingEdits: false. - textMorph acceptOnCR: true. - textMorph hideScrollBarsIndefinitely. - searchButton _ PluggableButtonMorph new - model: textMorph innerTextMorph; - label: 'Search'; - action: #acceptContents. - searchButton setBalloonText: 'Type some letters into the pane at right, and then press this Search button (or hit RETURN) and all method selectors that match what you typed will appear in the list pane below. Click on any one of them, and all the implementors of that selector will be shown in the right-hand pane, and you can view and edit their code without leaving this tool.'. - firstRow _ LayoutMorph newRow. - firstRow color: self windowColor. - firstRow - doAdoptWidgetsColor; - - addMorph: searchButton - proportionalWidth: 0.25; - - addMorph: textMorph - proportionalWidth: 0.75. - selectorListView _ PluggableListMorph - model: model - listGetter: #selectorList - indexGetter: #selectorListIndex - indexSetter: #selectorListIndex: - mainView: self - menuGetter: #selectorListMenu - keystrokeAction: #selectorListKey:from:. - secondRow _ LayoutMorph newRow. - secondRow - - addMorph: selectorListView - proportionalWidth: 0.5; - - addAdjusterAndMorph: self buildMorphicMessageList - proportionalWidth: 0.5. - self layoutMorph - - addMorph: firstRow - fixedHeight: self defaultButtonPaneHeight + 4; - - addAdjusterAndMorph: secondRow - proportionalHeight: 0.5; - - addAdjusterAndMorph: self buildLowerPanes - proportionalHeight: 0.5. - model changed: #editSelection.! ! -!MessageNamesWindow methodsFor: 'GUI building' stamp: 'jmv 10/22/2021 12:14:54' prior: 16867816 overrides: 16926852! - submorphToFocusKeyboard - ^textMorph innerTextMorph! ! -!FillInTheBlankMorph methodsFor: 'menu' stamp: 'jmv 10/22/2021 12:15:00' prior: 16844215! - acceptClicked - "Sent by the accept button." - - textPane innerTextMorph acceptContents! ! - -TextModelMorph removeSelector: #textMorph! - -!methodRemoval: TextModelMorph #textMorph stamp: 'Install-4937-Cleanup-JuanVuletich-2021Oct22-12h23m-jmv.001.cs.st 11/2/2021 10:27:39'! -textMorph -self flag: #jmvVer. -"Podemos reemplazar los senders locales por accesos directos (el doble encapsulamiento es tonto) una vez que quede definido el shape de la clase!! -Y la variable deberia ser innerMorph o algo asi... -Y el getter para callers externos tambien deberia ser #innerMorph" - ^ scroller! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4937-Cleanup-JuanVuletich-2021Oct22-12h23m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4937] on 22 October 2021 at 12:50:57 pm'! -!AffineTransformation methodsFor: 'transforming rects' stamp: 'jmv 10/22/2021 12:34:52'! - externalBoundingRectOf: aRectangle - "Externalize aRectangle, and find a bounding rectangle with horizontal and vertical bounds" - - ^Rectangle encompassing: - (aRectangle corners - collect: [ :pt | self transform: pt ])! ! -!MorphicTranslation methodsFor: 'transforming rects' stamp: 'jmv 10/22/2021 12:34:55'! - externalBoundingRectOf: aRectangle - "Externalize aRectangle, and find a bounding rectangle with horizontal and vertical bounds" - - ^ aRectangle translatedBy: self translation.! ! -!Morph methodsFor: 'change reporting' stamp: 'jmv 10/22/2021 12:47:37' prior: 50593441! - invalidateLocalRect: localRectangle - - self - invalidateDisplayRect: - (self externalizeBoundsToWorld: localRectangle) - encompassingIntegerRectangle - for: self.! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/22/2021 12:42:02' prior: 50554483! - externalize: aPoint - "aPoint is in own coordinates. Answer is in owner's coordinates." - - ^ aPoint.! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/22/2021 12:48:55' prior: 50593420! - externalizeBoundsToWorld: aRectangle - - ^owner - ifNotNil: [ owner externalizeBoundsToWorld: aRectangle ] - ifNil: [ aRectangle ]! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/22/2021 12:42:11' prior: 50554092 overrides: 50618381! - externalize: aPoint - "aPoint is in own coordinates. Answer is in owner's coordinates." - - ^ location externalizePosition: aPoint.! ! -!MovableMorph methodsFor: 'dropping/grabbing' stamp: 'jmv 10/22/2021 12:48:44' prior: 50593428 overrides: 50618387! - externalizeBoundsToWorld: aRectangle - - | inOwners | - inOwners _ location externalBoundingRectOf: aRectangle. - ^owner - ifNotNil: [ owner externalizeBoundsToWorld: inOwners ] - ifNil: [ inOwners ]! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/22/2021 12:48:24' prior: 50593437 overrides: 50618403! - externalizeBoundsToWorld: aRectangle - - ^ aRectangle! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/22/2021 12:37:52' prior: 50616116! - boundingRectOfCurrentMorphAfterDraw - "In targetForm coordinates. - Clipped to owner if appropriate. - Only valid for morphs where #morphLocalBounds is known. - Subclasses may raise this restriction. See inherintance, with VectorGraphics package loaded." - - | boundingRect | - boundingRect _ (currentTransformation externalBoundingRectOf: currentMorph morphLocalBounds) - encompassingIntegerRectangle. - "Include an extra pixel to cover possible anti aliasing." - boundingRect _ boundingRect outsetBy: 1. - ^ clippingMorphDisplayBounds - ifNotNil: [ :ownerClips | boundingRect intersect: ownerClips ] - ifNil: [ boundingRect ]! ! -!BitBltCanvas methodsFor: 'drawing-ovals' stamp: 'jmv 10/22/2021 12:39:38' prior: 50595618 overrides: 50569695! - ellipseCenter: center radius: radiusPointOrNumber borderWidth: mbw borderColor: mbc fillColor: morphFillColor - - | displayRectangle doBorder doFill | - doBorder _ mbw > 0 and: [ mbc isTransparent not]. - doFill _ morphFillColor isTransparent not. - doBorder | doFill ifTrue: [ - displayRectangle _ (currentTransformation externalBoundingRectOf: (Rectangle center: center extent: radiusPointOrNumber asPoint * 2)) rounded. - "draw the border of the oval" - doBorder ifTrue: [ - self setPaintColor: mbc. - engine frameOval: displayRectangle borderWidth: mbw rounded]. - "fill the inside" - doFill ifTrue: [ - self setPaintColor: morphFillColor. - engine fillOval: (displayRectangle insetBy: mbw rounded) ]]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 10/22/2021 12:40:06' prior: 50595682 overrides: 50463471! - frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor - - | rect bw | - r area = 0 ifTrue: [ ^self ]. - rect _ (currentTransformation externalBoundingRectOf: r) rounded. - bw _ (currentTransformation externalizeScalar: borderWidth) rounded. - - "draw the border of the rectangle" - borderColor isTransparent ifFalse: [ - self setPaintColor: borderColor. - engine frameRect: rect borderWidth: bw ]. - - "fill the inside" - fillColor isTransparent ifFalse: [ - self setPaintColor: fillColor. - engine fillRect: (rect insetBy: bw) ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 10/22/2021 12:40:47' prior: 50595704 overrides: 50463478! - frameRectangle: r borderWidth: borderWidth color: borderColor - " - (BitBltCanvas onForm: Display) - frameRectangle: (10@10 extent: 300@200) - borderWidth: 20 - color: Color red. - Display forceToScreen - " - | rect bw | - (borderWidth > 0 and: [ borderColor isTransparent not ]) ifTrue: [ - rect _ (currentTransformation externalBoundingRectOf: r) rounded. - bw _ (currentTransformation externalizeScalar: borderWidth) rounded. - self setPaintColor: borderColor. - engine - frameRect: rect - borderWidth: bw ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 10/22/2021 12:40:52' prior: 50595723! - frameRectangle: aRectangle topLeftColor: tlColor bottomRightColor: brColor borderWidth: borderWidth - " - (BitBltCanvas onForm: Display) - frameRectangle: (10@10 extent: 300@200) - color: Color green - borderWidth: 10 - borderStyleSymbol: #raised. - Display forceToScreen. - " - - | displayRectangle bw | - bw _ (currentTransformation externalizeScalar: borderWidth) rounded. - displayRectangle _ (currentTransformation externalBoundingRectOf: aRectangle) rounded. - self - frameRectangle: displayRectangle - borderWidth: bw - topLeftColor: tlColor - bottomRightColor: brColor.! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 10/22/2021 12:39:50' prior: 50595950! - fillRectangle: aRectangle tilingWith: aForm sourceRect: patternBox rule: aCombinationRule - - | displayRectangle additionalOffset clippedEngine targetTopLeft clipOffset ex - targetBox savedMap top left | - - ex _ patternBox extent. - ex x = 0 ifTrue: [ ^self ]. - ex y = 0 ifTrue: [ ^self ]. - displayRectangle _ (currentTransformation externalBoundingRectOf: aRectangle) rounded. - - "this is a bit of a kludge to get the form to be aligned where I *think* it should be. - something better is needed, but not now" - - additionalOffset _ `0@0`. - clippedEngine _ engine clippedBy: displayRectangle. - targetTopLeft _ clippedEngine clipRect topLeft truncateTo: ex. - clipOffset _ displayRectangle topLeft - targetTopLeft. - additionalOffset _ (clipOffset \\ ex) - ex. - - "do it iteratively" - targetBox _ clippedEngine clipRect. - savedMap _ clippedEngine colorMap. - clippedEngine sourceForm: aForm; - fillColor: nil; - combinationRule: aCombinationRule; - sourceRect: patternBox; - colorMap: (aForm colormapIfNeededFor: clippedEngine destForm). - top _ (targetBox top truncateTo: patternBox height) + additionalOffset y. - left _ (targetBox left truncateTo: patternBox width) + additionalOffset x. - - left to: (targetBox right - 1) by: patternBox width do: [:x | - top to: (targetBox bottom - 1) by: patternBox height do: [:y | - clippedEngine destOrigin: x@y; copyBits]]. - clippedEngine colorMap: savedMap! ! - -MorphicTranslation removeSelector: #displayBoundsOfTransformOf:! - -!methodRemoval: MorphicTranslation #displayBoundsOfTransformOf: stamp: 'Install-4938-Cleanup-JuanVuletich-2021Oct22-12h46m-jmv.001.cs.st 11/2/2021 10:27:39'! -displayBoundsOfTransformOf: aRectangle - "Externalize aRectangle, and find a bounding rectangle with horizontal - and vertical bounds and integer coordinates (i.e. adisplayBounds)." - - ^(aRectangle translatedBy: self translation) encompassingIntegerRectangle! - -AffineTransformation removeSelector: #displayBoundsOfTransformOf:! - -!methodRemoval: AffineTransformation #displayBoundsOfTransformOf: stamp: 'Install-4938-Cleanup-JuanVuletich-2021Oct22-12h46m-jmv.001.cs.st 11/2/2021 10:27:39'! -displayBoundsOfTransformOf: aRectangle - "Externalize aRectangle, and find a bounding rectangle with horizontal - and vertical bounds and integer coordinates (i.e. adisplayBounds)." - - ^Rectangle encompassingInteger: (aRectangle corners collect: [ :pt | - self transform: pt ])! - -GeometryTransformation removeSelector: #externalizeRectangle:! - -!methodRemoval: GeometryTransformation #externalizeRectangle: stamp: 'Install-4938-Cleanup-JuanVuletich-2021Oct22-12h46m-jmv.001.cs.st 11/2/2021 10:27:39'! -externalizeRectangle: aRectangle - ^ (self transform: aRectangle origin) corner: (self transform: aRectangle corner)! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4938-Cleanup-JuanVuletich-2021Oct22-12h46m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4938] on 22 October 2021 at 3:05:28 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/22/2021 14:49:20'! -externalizeBoundingRectOf: aRectangle - - ^aRectangle! ! -!MovableMorph methodsFor: 'dropping/grabbing' stamp: 'jmv 10/22/2021 14:49:26' overrides: 50618623! - externalizeBoundingRectOf: aRectangle - - ^location externalBoundingRectOf: aRectangle.! ! -!InnerListMorph methodsFor: 'list management' stamp: 'jmv 10/22/2021 14:42:22' prior: 50453859! - drawBoundsForRow: row - "calculate the bounds that row should be drawn at. This might be outside our bounds!!" - - ^ 0 @ (self drawYForRow: row) extent: extent x @ font lineSpacing! ! -!HierarchicalListMorph methodsFor: 'selection' stamp: 'jmv 10/22/2021 15:05:07' prior: 16853356 overrides: 16889986! - scrollSelectionIntoView - - | r | - selectedMorph ifNotNil: [ - r _ scroller externalizeBoundingRectOf: - (selectedMorph morphPosition extent: selectedMorph morphExtentInOwner). - self scrollToShow: r ]! ! -!PluggableListMorph methodsFor: 'scrolling' stamp: 'jmv 10/22/2021 14:59:44' prior: 50617936 overrides: 16889986! - scrollSelectionIntoView - "make sure that the current selection is visible" - | row r | - row _ self getCurrentSelectionIndex. - row = 0 - ifTrue: [ - "Value is 0, but we need to propagate it to model" - scrollBar internalScrollValue: scrollBar scrollValue ] - ifFalse: [ - r _ scroller externalizeBoundingRectOf: (scroller drawBoundsForRow: row). - self scrollToShow: r ]. - self scrollMySiblings -! ! - -MovableMorph removeSelector: #externalBoundingRectOf:! - -Morph removeSelector: #externalBoundingRectOf:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4939-SmallRefactor-JuanVuletich-2021Oct22-14h42m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4939] on 22 October 2021 at 4:06:15 pm'! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 10/22/2021 16:05:10'! - scrollDeltaHeight: anInteger - "Set the increment in pixels which this pane should be scrolled." - self setProperty: #scrollDeltaHeight toValue: anInteger. - self vSetScrollDelta.! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 10/22/2021 16:05:00'! - scrollDeltaWidth: anInteger - "Set the increment in pixels which this pane should be scrolled." - self setProperty: #scrollDeltaWidth toValue: anInteger. - self hSetScrollDelta.! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 10/22/2021 16:02:19' prior: 16889728! - scrollDeltaHeight - "Return the increment in pixels which this pane should be scrolled." - ^ self valueOfProperty: #scrollDeltaHeight ifAbsent: [10]! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 10/22/2021 16:02:36' prior: 16889735! - scrollDeltaWidth - "Return the increment in pixels which this pane should be scrolled." - ^ self valueOfProperty: #scrollDeltaWidth ifAbsent: [10]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4940-TweakeableScrollDeltas-JuanVuletich-2021Oct22-16h02m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4940] on 25 October 2021 at 1:54:20 pm'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/25/2021 13:53:34' prior: 50613096! -drawWorld: aWorldMorph rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage backgroundDamage: newDamageFromMorphsBelow - "Redraw the damaged areas. - Draw each morph just once, merging rectanges to be repaired as needed." - - | morph morphDamage allDamage | - "Iterate from back to front." - allDamage _ Rectangle merging: newDamageFromMorphsBelow. - rootMorphs size to: 1 by: -1 do: [ :i | - morph _ rootMorphs at: i. - morphDamage _ rootMorphsDamage at: i. - morph displayFullBounds ifNotNil: [ :morphFullBounds | - newDamageFromMorphsBelow do: [ :r | | intersection | - intersection _ r intersect: morphFullBounds. - intersection hasPositiveExtent ifTrue: [ - morphDamage - ifNil: [ morphDamage _ intersection ] - ifNotNil: [ morphDamage updateMerging: intersection ]]]]. - morphDamage ifNotNil: [ - self newClipRect: morphDamage. - self fullDraw: morph. - newDamageFromMorphsBelow add: morphDamage. - allDamage - ifNil: [ allDamage _ morphDamage copy ] - ifNotNil: [ allDamage updateMerging: morphDamage ]]]. - ^allDamage! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4941-InvalidationTweak-JuanVuletich-2021Oct25-13h53m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4940] on 25 October 2021 at 1:52:30 pm'! -!LayoutMorph class methodsFor: 'instance creation' stamp: 'jmv 10/25/2021 13:51:56' prior: 16863610 overrides: 16783533! - new - "Answer a row by default so the 'new morph' menu doesn't fail..." - ^self newRow color: `(Color red alpha: 0.2)`! ! - -LayoutMorph class removeSelector: #initializedInstance! - -!methodRemoval: LayoutMorph class #initializedInstance stamp: 'Install-4942-LayoutMorph-new-JuanVuletich-2021Oct25-13h50m-jmv.001.cs.st 11/2/2021 10:27:39'! -initializedInstance - "Answer a row by default so the 'new morph' menu doesn't fail..." - ^self newRow color: `(Color red alpha: 0.2)`! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4942-LayoutMorph-new-JuanVuletich-2021Oct25-13h50m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4942] on 25 October 2021 at 4:18:19 pm'! -!Morph methodsFor: 'accessing' stamp: 'jmv 10/25/2021 14:44:19' prior: 50554479! - location - ^ GeometryTransformation identity! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 10/25/2021 14:42:45' prior: 50607548! - imageForm: extentOrNil depth: depth - "Scale as needed. Draw unrotated." - - | prevNotVisibleFlag bounds extent location answer auxCanvas | - "Position and scale us in order to fill required extent, but disregard any rotation. - Do it without triggering any invalidation at all." - prevNotVisibleFlag _ self privateFlagAt: 3. - [ - bounds _ self findFullBoundsInOwner. - extentOrNil - ifNotNil: [ | scale | - extent _ extentOrNil. - scale _ extent x asFloat / bounds width min: extent y asFloat / bounds height. - location _ AffineTransformation withScale: scale position: bounds origin negated +1 * scale ] - ifNil: [ - extent _ bounds extent. - location _ MorphicTranslation withTranslation: bounds origin negated ]. - answer _ Form extent: extent depth: 32. - "Ask for a Canvas with subpixels so it can also handle translucent target" - auxCanvas _ VectorCanvas onFormWithSubPixelAntiAliasing: answer. - auxCanvas geometryTransformation: location. - "But disable subpixel anti aliasing, as we are answering a Form, and therefore can't assume a Display geometry." - auxCanvas engine disableSubPixelSampling. - depth = 32 ifFalse: [ - "Only 32 bpp can hold translucent anti aliasing over transparent background" - answer fillColor: Color veryLightGray ]. - self privateFlagAt: 3 put: false. - auxCanvas fullDraw: self. - ] ensure: [ - self privateFlagAt: 3 put: prevNotVisibleFlag ]. - ^answer asFormOfDepth: depth.! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/25/2021 14:38:26' prior: 50616952! - computeDamage: aWorldMorph repair: aDamageRecorder rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage - "Iterate front to back while computing damage to actually repair for each morph, and for world background. - Answer uncoveredDamage, the areas where World background needs to be redrawn." - - | uncoveredDamage additionalUncoveredDamage morph morphDamage morphFullBounds | - uncoveredDamage _ aDamageRecorder damageReportedOther. - additionalUncoveredDamage _ OrderedCollection new. - - "Iterate from front to back" - 1 to: rootMorphs size do: [ :i | - morph _ rootMorphs at: i. - morphFullBounds _ morph displayFullBounds. - morphDamage _ nil. - "Reported damage can be ignored if the area fully covered by another morph above us." - (aDamageRecorder damageReportedFor: morph) ifNotNil: [ :r | | wasFullyCovered | - wasFullyCovered _ false. - 1 to: i-1 do: [ :j | - wasFullyCovered _ wasFullyCovered or: [ (rootMorphs at: j) fullyCovers: r ]]. - wasFullyCovered ifFalse: [ - uncoveredDamage add: r ]]. - "Any uncovered damage this morph may overlap must be redrawn by it." - morphFullBounds ifNotNil: [ - uncoveredDamage withIndexDo: [ :r :j | | intersection | - r ifNotNil: [ - intersection _ r intersect: morphFullBounds. - intersection hasPositiveExtent ifTrue: [ - r = intersection ifTrue: [ uncoveredDamage at: j put: nil ]. - morphDamage - ifNil: [ morphDamage _ intersection ] - ifNotNil: [ morphDamage updateMerging: intersection ]]]]]. - rootMorphsDamage at: i put: morphDamage. - uncoveredDamage add: morphDamage. - "Whatever we cover completely is no longer uncoveredDamage" - uncoveredDamage withIndexDo: [ :r :ri | - r ifNotNil: [ - morph - on: r - ifCovered: [uncoveredDamage at: ri put: nil] - uncoveredPartsDo: [ :r2 | additionalUncoveredDamage add: r2 ] - else: []]]. - uncoveredDamage addAll: additionalUncoveredDamage. - additionalUncoveredDamage removeAll. - ]. - - "Remove redundant rectangles" - 1 to: uncoveredDamage size do: [ :i1 | - (uncoveredDamage at: i1) ifNotNil: [ :r1 | - 1 to: uncoveredDamage size do: [ :i2 | - i1 = i2 ifFalse: [ - (uncoveredDamage at: i2) ifNotNil: [ :r2 | - (r1 containsRect: r2) - ifTrue: [ uncoveredDamage at: i2 put: nil ]]]]]]. - - "Answer any yet uncovered areas. World background should be drawn on them." - ^ uncoveredDamage select: [ :r | r notNil ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4943-Morph-imageFormdepth-JuanVuletich-2021Oct25-16h17m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4943] on 25 October 2021 at 4:39:04 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/25/2021 16:24:56' prior: 50571243! - adjustDisplayBoundsBy: delta - "Private for framework use. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us." - - privateDisplayBounds ifNotNil: [ - privateDisplayBounds _ delta ifNil: [ nil ] ifNotNil: [privateDisplayBounds translatedBy: delta]]. - self allSubmorphsDo: [ :m | m adjustDisplayBoundsBy: delta ].! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 10/25/2021 16:35:33' prior: 50616304! - grabMorph: aMorph delta: delta - "Grab the given morph (i.e., add it to this hand and remove it from its current owner)." - - | formerOwner formerPositionInWorld | - self releaseMouseFocus. "Break focus" - - "Grab the halo if present" - self halo ifNotNil: [ :h | - (h target == aMorph or: [h target hasOwner: aMorph]) ifTrue: [ - self addMorphBack: h position: h morphPositionInWorld - self morphPositionInWorld ]]. - - "Remember previous owner and position, in case the drop is later rejected" - formerOwner _ aMorph owner. - formerOwner ifNotNil: [ - formerPositionInWorld _ aMorph morphPositionInWorld. - grabMorphData - at: aMorph - put: { formerOwner. formerPositionInWorld. } ]. - self addMorphBack: aMorph position: delta. - - aMorph displayBounds ifNotNil: [ :r | | d | - d _ formerPositionInWorld ifNotNil: [aMorph morphPositionInWorld - formerPositionInWorld]. - (d isNil or: [d isZero not]) ifTrue: [ - aMorph adjustDisplayBoundsBy: d ]]. - - aMorph justGrabbedFrom: formerOwner. - formerOwner ifNotNil: [ - "Morph was in the world" - lastPosition _ self morphPosition ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4944-openInHand-invalidation-fix-JuanVuletich-2021Oct25-16h38m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4944] on 25 October 2021 at 4:49:05 pm'! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 10/25/2021 16:43:07' prior: 50616244! - displayFullBoundsForPatch - "Current full bounds of hand and carried submorphs. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around). - Integer pixel coordinates!!" - - | handBounds fullBounds submorphBounds | - handBounds _ self basicDisplayBounds. - submorphBounds _ nil. - self submorphsDo: [ :m | - submorphBounds _ m displayFullBounds quickMerge: submorphBounds ]. - fullBounds _ handBounds quickMerge: submorphBounds. - lastPosition - ifNotNil: [ :lastPos | "When already carrying morphs around. Update rectangle to current hand position." - fullBounds _ fullBounds quickMerge: (submorphBounds translatedBy: self morphPosition-lastPos) ]. - ^fullBounds encompassingIntegerRectangle! ! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 10/25/2021 16:40:28' prior: 50595339! - updateHandsDisplayBounds: aWorldMorph - "Update displayBounds for carried morphs if never set. - Useful for new morph, that are created and attached to the hand." - - aWorldMorph handsDo: [ :hand | - hand hasSubmorphs ifTrue: [ - self into: hand. - hand submorphsDo: [ :morph | - morph basicDisplayBounds ifNil: [ - self fullUpdateProtrudingBounds: morph ]]. - self outOfMorph ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4945-tweak-JuanVuletich-2021Oct25-16h47m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4945] on 25 October 2021 at 6:51:23 pm'! -!Morph methodsFor: 'drawing' stamp: 'jmv 9/13/2021 17:26:23' prior: 50618794! - imageForm: extentOrNil depth: depth - - self subclassResponsibility! ! -!Morph methodsFor: 'updating' stamp: 'jmv 10/25/2021 18:50:03' prior: 50615834! - invalidateBounds - "Report that the area occupied by this morph and submorphs should be redrawn, - but most likely we are not going to be redrawn on it, or maybe we'll not be fully visible. See senders." - - self displayFullBounds ifNotNil: [ :r | - self invalidateDisplayRect: r for: nil ]. -! ! -!Morph methodsFor: 'updating' stamp: 'jmv 10/25/2021 18:50:09' prior: 50615848! - redrawNeeded - "Report that the area occupied by this morph should be redrawn. - Usually because we changed in some way. - Notes: - Area used before any change is reported here. - Area used after any changes is reported when displayBounds are updated. - See updateBoundsIn:addDamageTo: and senders. - " - - self needsRedraw: true. - self allOwnersDo: [ :m | m submorphNeedsRedraw: true ]. - self basicDisplayBounds ifNotNil: [ :b | - self invalidateDisplayRect: b for: self ]. - (self submorphsMightProtrude and: [self clipsSubmorphsReally not]) ifTrue: [ - self submorphsReverseDo: [ :m | m redrawNeeded ]]. - self removeProperty: #bitMask. - self removeProperty: #fullBoundsInOwner.! ! -!Morph methodsFor: 'private' stamp: 'jmv 10/25/2021 18:49:29' prior: 50616768! - privateAddAllMorphs: aCollection atIndex: index - "Private. Add aCollection of morphs to the receiver" - | myWorld itsWorld otherSubmorphs | - (aCollection allSatisfy: [ :m | self canAdd: m]) ifFalse: [ - (self confirm: 'Some requested morph requires VectorGraphics support. Do you want to install and activate it?') - ifTrue: [ - Feature require: 'VectorGraphics'. - MorphicCanvas activeSubclass: (Smalltalk at: #HybridCanvas) ] - ifFalse: [ - ^self error: 'We can''t add requested morphs.' ]]. - myWorld _ self world. - otherSubmorphs _ submorphs copyWithoutAll: aCollection. - (index between: 0 and: otherSubmorphs size) - ifFalse: [^ self error: 'index out of range']. - index = 0 - ifTrue:[ submorphs _ aCollection asArray, otherSubmorphs] - ifFalse:[ index = otherSubmorphs size - ifTrue:[ submorphs _ otherSubmorphs, aCollection] - ifFalse:[ submorphs _ otherSubmorphs copyReplaceFrom: index + 1 to: index with: aCollection ]]. - aCollection do: [:m | | itsOwner | - itsOwner _ m owner. - itsOwner ifNotNil: [ - itsWorld _ m world. - (itsWorld == myWorld) ifFalse: [ - itsWorld ifNotNil: [m redrawNeeded]]. - (itsOwner ~~ self) ifTrue: [ - m owner privateRemove: m. - m owner removedMorph: m ]]. - m privateOwner: self. - myWorld ifNotNil: [m redrawNeeded]. - (myWorld == itsWorld) ifFalse: [m intoWorld: myWorld]. - itsOwner == self ifFalse: [ - self addedMorph: m. - m noteNewOwner: self ]. - ]. - self privateArrangeWantsToBeOnTop. - self someSubmorphPositionOrExtentChanged! ! -!Morph methodsFor: 'private' stamp: 'jmv 10/25/2021 18:49:39' prior: 50616818! - privateAddMorph: aMorph atIndex: index position: aPointOrNil - - | oldIndex myWorld itsWorld oldOwner | - (self canAdd: aMorph) ifFalse: [ - (self confirm: 'The requested morph requires VectorGraphics support. Do you want to install and activate it?') - ifTrue: [ - Feature require: 'VectorGraphics'. - MorphicCanvas activeSubclass: (Smalltalk at: #HybridCanvas) ] - ifFalse: [ - ^self error: 'We can''t add requested morph.' ]]. - ((index >= 1) and: [index <= (submorphs size + 1)]) - ifFalse: [^ self error: 'index out of range']. - myWorld _ self world. - oldOwner _ aMorph owner. - (oldOwner == self and: [(oldIndex _ submorphs indexOf: aMorph) > 0]) ifTrue: [ - "aMorph's position changes within in the submorph chain" - oldIndex < index ifTrue:[ - "moving aMorph to back" - submorphs replaceFrom: oldIndex to: index-2 with: submorphs startingAt: oldIndex+1. - submorphs at: index-1 put: aMorph. - ] ifFalse:[ - "moving aMorph to front" - oldIndex-1 to: index by: -1 do:[:i| - submorphs at: i+1 put: (submorphs at: i)]. - submorphs at: index put: aMorph. - ]. - aPointOrNil ifNotNil: [aMorph privatePosition: aPointOrNil]. - ] ifFalse: [ - "adding a new morph" - oldOwner ifNotNil: [ - itsWorld _ aMorph world. - itsWorld ifNotNil: [aMorph invalidateBounds]. - oldOwner privateRemove: aMorph. - oldOwner removedMorph: aMorph. - ]. - aMorph privateOwner: self. - submorphs _ submorphs copyReplaceFrom: index to: index-1 with: (Array with: aMorph). - aPointOrNil ifNotNil: [aMorph privatePosition: aPointOrNil]. - (itsWorld == myWorld) ifFalse: [aMorph intoWorld: myWorld]. - ]. - myWorld ifNotNil: [ - index = 1 - ifTrue: [aMorph redrawNeeded ] - ifFalse: [aMorph invalidateBounds]]. - self privateArrangeWantsToBeOnTop. - self someSubmorphPositionOrExtentChanged. - oldOwner == self ifFalse: [ - self addedMorph: aMorph. - aMorph noteNewOwner: self ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4946-Tweaks-JuanVuletich-2021Oct25-18h48m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4947] on 26 October 2021 at 3:26:57 pm'! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 10/26/2021 15:26:47' prior: 50618988! - displayFullBoundsForPatch - "Current full bounds of hand and carried submorphs. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around). - Integer pixel coordinates!!" - - | handBounds fullBounds submorphBounds | - handBounds _ self basicDisplayBounds. - submorphBounds _ nil. - self submorphsDo: [ :m | - m displayFullBounds ifNotNil: [ :b | - submorphBounds _ b quickMerge: submorphBounds ]]. - fullBounds _ handBounds quickMerge: submorphBounds. - lastPosition - ifNotNil: [ :lastPos | "When already carrying morphs around. Update rectangle to current hand position." - fullBounds _ fullBounds quickMerge: (submorphBounds translatedBy: self morphPosition-lastPos) ]. - ^fullBounds encompassingIntegerRectangle! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4947-Tweak-JuanVuletich-2021Oct26-15h26m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4940] on 25 October 2021 at 11:19:49 am'! -!PositionableStream methodsFor: 'accessing' stamp: 'jmv 10/25/2021 11:18:50'! - upTo: delimiter delimiterIsTerminator: delimiterIsTerminator - "Answer a subcollection from the current access position to the - occurrence of delimiter in the receiver. - - If delimiterIsTerminator is false, delimiter is considered a separator: - - Skip delimiter, but don't include it in the answer. - - If delimiter is not found, answer the entire rest of the receiver. - - If delimiterIsTerminator is true, answer will end with delimeter: - - Read delimiter, include it in the answer. - - If delimiter is not found, answer nil and don't advance receiver at all. - This is especially useful if we are appended new stuff while simultaneusly being read." - - | prevPosition element answer | - prevPosition _ self position. - answer _ self collectionSpecies streamContents: [ :newStream | - [self atEnd or: [(element _ self next) = delimiter]] - whileFalse: [newStream nextPut: element]. - delimiterIsTerminator ifTrue: [ - element = delimiter - ifTrue: [newStream nextPut: element] - ifFalse: [ - self position: prevPosition. - ^ nil ]]]. - ^answer.! ! -!ReadStream methodsFor: 'accessing' stamp: 'jmv 10/25/2021 09:58:29' overrides: 50619230! - upTo: delimiter delimiterIsTerminator: delimiterIsTerminator - "See comment at PositionableStream. - Fast version using indexOf:" - - | start end | - - start _ position+1. - end _ collection indexOf: delimiter startingAt: start ifAbsent: [0]. - - "not present" - end = 0 ifTrue: [ - ^ delimiterIsTerminator - ifTrue: [ - self position: start-1. - nil ] - ifFalse: [self upToEnd]]. - - "skip to the end and return the data passed over" - position _ end. - ^collection copyFrom: start to: (delimiterIsTerminator ifTrue: [end] ifFalse: [end-1])! ! -!StandardFileStream methodsFor: 'read, write, position' stamp: 'jmv 10/25/2021 10:00:18' overrides: 50619230! - upTo: delimiter delimiterIsTerminator: delimiterIsTerminator - "See comment at PositionableStream. - Fast version to speed up nextChunk" - - | pos buffer count skipSeparator tryAgain | - skipSeparator _ delimiterIsTerminator ifTrue: [0] ifFalse: [1]. - collection ifNotNil: [ - (position < readLimit and: [ - (pos _ collection indexOf: delimiter startingAt: position + 1) <= readLimit and: [ - pos > 0 ] ]) ifTrue: [ - ^ collection copyFrom: position + 1 to: (position _ pos) - skipSeparator ] ]. - - pos _ self position. - buffer _ self next: 2000. - (count _ buffer indexOf: delimiter) > 0 ifTrue: [ - "Found the delimiter part way into buffer" - self position: pos + count. - ^ buffer copyFrom: 1 to: count - skipSeparator]. - - self atEnd ifTrue: [ - "Never found it, and hit end of file" - ^ delimiterIsTerminator ifTrue: [self position: pos. nil] ifFalse: [buffer]]. - - "Never found it, but there's more..." - tryAgain _ self upTo: delimiter delimiterIsTerminator: delimiterIsTerminator. - tryAgain ifNil: [ - self position: pos. - ^ nil ]. - ^ buffer, tryAgain.! ! -!PositionableStream methodsFor: 'accessing' stamp: 'jmv 10/24/2021 20:57:46' prior: 16891470! - upTo: delimiter - "Answer a subcollection from the current access position to the - occurrence (if any, but not inclusive) of delimiter in the receiver. If - delimiter is not in the collection, answer the entire rest of the receiver." - - ^self upTo: delimiter delimiterIsTerminator: false.! ! - -StandardFileStream removeSelector: #upTo:! - -!methodRemoval: StandardFileStream #upTo: stamp: 'Install-4948-upTodelimiterIsTerminator-NicolaMingotti-JuanVuletich-2021Oct25-09h28m-jmv.001.cs.st 11/2/2021 10:27:39'! -upTo: delim - "Fast version to speed up nextChunk" - | pos buffer count | - collection ifNotNil: [ - (position < readLimit and: [ - (pos := collection indexOf: delim startingAt: position + 1) <= readLimit and: [ - pos > 0 ] ]) ifTrue: [ - ^collection copyFrom: position + 1 to: (position := pos) - 1 ] ]. - pos := self position. - buffer := self next: 2000. - (count := buffer indexOf: delim) > 0 ifTrue: - ["Found the delimiter part way into buffer" - self position: pos + count. - ^ buffer copyFrom: 1 to: count - 1]. - self atEnd ifTrue: - ["Never found it, and hit end of file" - ^ buffer]. - "Never found it, but there's more..." - ^ buffer , (self upTo: delim)! - -ReadStream removeSelector: #upTo:! - -!methodRemoval: ReadStream #upTo: stamp: 'Install-4948-upTodelimiterIsTerminator-NicolaMingotti-JuanVuletich-2021Oct25-09h28m-jmv.001.cs.st 11/2/2021 10:27:39'! -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)! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4948-upTodelimiterIsTerminator-NicolaMingotti-JuanVuletich-2021Oct25-09h28m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4948] on 26 October 2021 at 6:38:33 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/26/2021 18:36:22' prior: 50592960! - displayFullBounds - "Answer a rectangle that completely bounds receiver and submorphs when last drawn - (if the world was to be fully drawn, i.e. only to be used on a Canvas on the full world). - Integer pixel coordinates!!" - - | answer | - answer _ self basicDisplayBounds. - answer ifNil: [ ^nil ]. - (self submorphsMightProtrude and: [self clipsSubmorphsReally not]) ifTrue: [ - self submorphsReverseDo: [ :m | - answer _ answer quickMerge: m displayFullBounds ]]. - ^answer! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 10/26/2021 18:34:48' prior: 50619196! - displayFullBoundsForPatch - "Current full bounds of hand and carried submorphs. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around). - Integer pixel coordinates!!" - - | handBounds fullBounds submorphBounds | - handBounds _ self basicDisplayBounds. - submorphBounds _ nil. - self submorphsDo: [ :m | - m displayFullBounds ifNotNil: [ :b | - submorphBounds _ b quickMerge: submorphBounds ]]. - fullBounds _ handBounds quickMerge: submorphBounds. - lastPosition - ifNotNil: [ :lastPos | "When already carrying morphs around. Update rectangle to current hand position." - fullBounds _ fullBounds quickMerge: (submorphBounds translatedBy: self morphPosition-lastPos) ]. - ^fullBounds encompassingIntegerRectangle! ! -!DamageRecorder methodsFor: 'private' stamp: 'jmv 10/26/2021 18:37:56' prior: 50613258! - pvtInnerRecordInvalidRect: requestedRect for: aRootMorph - "Record the given rectangle in my damage list, a list of rectangular areas of the display that should be redraw on the next display cycle." - - aRootMorph ifNotNil: [ - (damageByRoot at: aRootMorph - ifPresent: [ :r | r updateMerging: requestedRect] - ifAbsent: [ damageByRoot at: aRootMorph put: requestedRect copy ]) ] - ifNil: [otherDamage add: requestedRect copy].! ! - -Rectangle removeSelector: #encompassingIntegerRectangleX! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4949-DamageRectsAreAlwaysInteger-JuanVuletich-2021Oct26-18h28m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4948] on 26 October 2021 at 6:44:05 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/26/2021 18:41:50' prior: 50597113! - fullBoundsInOwner - "Answer fullBoundsInOwner. Cache the found bounds. - Note: Answers an integer rectangle" - - (self valueOfProperty: #fullBoundsInOwner) ifNotNil: [ :fullBoundsInOwner | - ^fullBoundsInOwner ]. - - ^self setProperty: #fullBoundsInOwner toValue: self findFullBoundsInOwner.! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/26/2021 18:42:22' prior: 50612152! - morphExtentInOwner - "Note: Answers an integer point" - - ^self fullBoundsInOwner extent! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/26/2021 18:43:05' prior: 50617543! - topLeftInOwner - "Note: Answers an integer rectangle" - - ^self fullBoundsInOwner origin! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 10/26/2021 18:41:42' prior: 50601365 overrides: 50601395! - findFullBoundsInOwner - "Find and answer full bounds in whatever owner. - These might not equal #displayFullBounds at all!! - Note: Answers an integer rectangle" - - self requiresVectorCanvas ifTrue: [ - ^super findFullBoundsInOwner ]. - - "#morphExtent exists, and it is also valid in owner, because #requiresVectorCanvas is false." - ^(self morphPosition extent: self morphExtent) encompassingIntegerRectangle.! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 10/26/2021 18:41:46' prior: 50601380 overrides: 50601395! - findFullBoundsInOwner - "Find and answer full bounds in whatever owner. - These might not equal #displayFullBounds at all!! - Note: Answers an integer rectangle" - - self requiresVectorCanvas ifTrue: [ - ^super findFullBoundsInOwner ]. - - "#morphExtent exists, and it is also valid in owner, because #requiresVectorCanvas is false." - ^(self morphPosition extent: self morphExtent) encompassingIntegerRectangle.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4950-StateThatInComments-JuanVuletich-2021Oct26-18h38m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4950] on 28 October 2021 at 11:22:39 am'! -!Morph methodsFor: 'accessing' stamp: 'jmv 10/28/2021 11:18:04'! - boundsFinderCanvas - "Might answer nil if not in a world!!" - - ^ self canvas ifNotNil: [ :c | c boundsFinderCanvas ]! ! -!Morph methodsFor: 'accessing' stamp: 'jmv 10/27/2021 16:06:26'! - canvas - "Might answer nil if not in a world!!" - - ^ self topmostWorld ifNotNil: [ :w | w canvas ].! ! -!MorphicCanvas methodsFor: 'testing' stamp: 'jmv 10/27/2021 16:10:26'! - canDoVectorGraphics - ^false! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/27/2021 16:07:00' prior: 50604574! - displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Clipped appropiately if some owner clips us. - See also #displayBoundsUpdateFrom:" - - self canvas ifNotNil: [ :c | - (aCanvas isBoundsFinderCanvas or: [c canvasToUse == aCanvas canvasToUse]) ifTrue: [ - privateDisplayBounds _ aCanvas canvasToUse boundingRectOfCurrentMorphAfterDraw. - self wantsContour - ifTrue: [ - (aCanvas canvasToUse - contourOfCurrentMorphAfterDrawInto: (self valueOfProperty: #contour) - into: [ :contourArray :contourY0 :contourY1 | - self setProperty: #contour toValue: contourArray. - self setProperty: #contourY0 toValue: contourY0. - self setProperty: #contourY1 toValue: contourY1 ])] - ifFalse: [ - self setProperty: #contour toValue: nil. - self setProperty: #contourY0 toValue: nil. - self setProperty: #contourY1 toValue: nil ]]].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/27/2021 16:07:14' prior: 50604610! - displayBoundsUpdateFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us. - To be called after #postDrawOn:. See also #displayBoundsSetFrom: - This more complicated update is needed because the contour information from #drawOn: was possibly - when drawing submorphs. So, the controur from #drawOn: needs to be retrieved, and updated with the - new contour information from #postDrawOn:" - - self canvas ifNotNil: [ :c | - (aCanvas isBoundsFinderCanvas or: [c canvasToUse == aCanvas canvasToUse]) ifTrue: [ - privateDisplayBounds _ privateDisplayBounds - quickMerge: aCanvas canvasToUse boundingRectOfCurrentMorphAfterDraw. - self wantsContour ifTrue: [ - (aCanvas canvasToUse - contourOfCurrentMorphAfterDrawUpdate: (self valueOfProperty: #contour) - oldTop: (self valueOfProperty: #contourY0) - oldBottom: (self valueOfProperty: #contourY1) - into: [ :contourArray :contourY0 :contourY1 | - self setProperty: #contour toValue: contourArray. - self setProperty: #contourY0 toValue: contourY0. - self setProperty: #contourY1 toValue: contourY1 ])]]].! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 10/27/2021 16:21:16' prior: 50608731! -coversPixel: worldPoint - "Answer true if pixel worldPoint is covered by us, even if we are not visible a it because of some - other morph above us also covers it. - See #bitMask. - Remember to do - self removeProperty: #bitMask. - when appropriate!! (i.e. when we change in such a way to make the bitMask invalid). - - Note: Subclasses such as KernelMorph and WidgetMorph redefine this method with an optimized - implementation that doesn't require computing and invalidating the #bitMask. Senders in the base image - and framework actually only use this optimized implementation. That's why general morphs don't care about - invalidting #bitMask. - - Note: If your morph #requiresVectorCanvas, and depends on this general implementation, remember to - `removeProperty: #bitMask` whenever it becomes invalid due to changes in your morphs. You may consider - using #ownsPixel: if appropriate, that doesn't require any maintenance and is cheaper (in cpu and memory). - - Note: This implementation requires VectorGraphics. - - See #ownsOrCoversPixel:" - - self visible ifTrue: [ - ^(self bitMask pixelValueAt: worldPoint - self displayFullBounds topLeft) = 1 ]. - ^ false! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 10/27/2021 16:04:46' prior: 50608428! - ownsOrCoversPixel: worldPoint - "Answer true if we own the pixel, i.e. we are the last morph drawn at worldPoint. - Some implementations (KernelMorph and WidgetMorph) may also answer true if we cover but don't own the pixel, - meaning that some other morph was drawn later, covering us. - - Therefore, senders need to be aware that the answer is meaningful only when it is known that no other morph - covers us. A common case is to find the topmost morph at some position. In that case, iterating front to back ensures - that if any other morph covers us, it is found first. - - Note: This implementation is only used for morphs drawn by VectorCanvas, either because the main canvas is a - VectorCanvas, or because it is a HybridCanvas and we answer true to #requiresVectorCanvas. - (See other implementors) - Note: Also see #ownsPixel: and #coversPixel:" - - ^ self ownsPixel: worldPoint.! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 10/27/2021 16:07:29' prior: 50608451! - ownsPixel: worldPoint - "Answer true if we own the pixel, i.e. we are the last morph drawn at worldPoint. - Requires VectorGraphics. - In case of running on HybridCanvas, this method is only valid for morphs that - are drawon by VectorCanvas (i.e. they answer true to #requiresVectorCanvas)." - - self canvas ifNotNil: [ :canvas | - ^ (canvas morphIdAt: worldPoint) = self morphId ]. - ^ false.! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 10/28/2021 11:18:30' prior: 50595476 overrides: 50592801! - basicDisplayBounds - - ^ self boundsFinderCanvas displayBoundsForHand: self! ! -!WidgetMorph methodsFor: 'halos and balloon help' stamp: 'jmv 10/27/2021 16:07:44' prior: 50603452 overrides: 50603469! - okayToRotateEasily - "Answer whether it is appropriate for a rotation handle to be shown for the receiver." - - ^ self canvas usesVectorEnginePlugin.! ! -!WidgetMorph methodsFor: 'halos and balloon help' stamp: 'jmv 10/27/2021 16:07:55' prior: 50603461 overrides: 50603477! - okayToScaleEasily - "Answer whether it is appropriate for a scale handle to be shown for the receiver." - - ^ self canvas usesVectorEnginePlugin.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4951-Refactor-JuanVuletich-2021Oct28-11h14m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4928] on 27 October 2021 at 3:11:25 pm'! -!Morph methodsFor: 'geometry services' stamp: 'jmv 10/27/2021 15:10:52' prior: 50608350! - fullOwnsOrCoversPixel: worldPoint - "Answer true if worldPoint is in some submorph, even if not inside our shape. - See comment at #ownsOrCoversPixel: for important notes on behavior." - - (self ownsOrCoversPixel: worldPoint) ifTrue: [ ^ true ]. - self submorphsMightProtrude ifTrue: [ - self submorphsDo: [ :m | - (m fullOwnsOrCoversPixel: worldPoint) ifTrue: [ ^ true ]]]. - ^ false.! ! - -WidgetMorph removeSelector: #fullOwnsOrCoversPixel:! - -!methodRemoval: WidgetMorph #fullOwnsOrCoversPixel: stamp: 'Install-4952-fullOwnsOrCoversPixel-JuanVuletich-2021Oct27-15h10m-jmv.001.cs.st 11/2/2021 10:27:39'! -fullOwnsOrCoversPixel: worldPoint - "Answer true if worldPoint is in some submorph, even if not inside our shape. - See comment at #ownsOrCoversPixel: for important notes on behavior." - - (self ownsOrCoversPixel: worldPoint) ifTrue: [ ^ true ]. - self submorphsMightProtrude ifTrue: [ - self submorphsDo: [ :m | - (m fullOwnsOrCoversPixel: worldPoint) ifTrue: [ ^ true ]]]. - ^ false.! - -KernelMorph removeSelector: #fullOwnsOrCoversPixel:! - -!methodRemoval: KernelMorph #fullOwnsOrCoversPixel: stamp: 'Install-4952-fullOwnsOrCoversPixel-JuanVuletich-2021Oct27-15h10m-jmv.001.cs.st 11/2/2021 10:27:39'! -fullOwnsOrCoversPixel: worldPoint - "Answer true if worldPoint is in some submorph, even if not inside our shape. - See comment at #ownsOrCoversPixel: for important notes on behavior." - - (self ownsOrCoversPixel: worldPoint) ifTrue: [ ^ true ]. - self submorphsMightProtrude ifTrue: [ - self submorphsDo: [ :m | - (m fullOwnsOrCoversPixel: worldPoint) ifTrue: [ ^ true ]]]. - ^ false.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4952-fullOwnsOrCoversPixel-JuanVuletich-2021Oct27-15h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4952] on 28 October 2021 at 11:51:57 am'! -!Morph methodsFor: 'geometry services' stamp: 'jmv 10/28/2021 11:46:45' prior: 50619619! - coversPixel: worldPoint - "Answer true if pixel worldPoint is covered by us, even if we are not visible a it because of some - other morph above us also covers it. - - See #bitMask. - Remember to do - self removeProperty: #bitMask. - when appropriate!! (i.e. when we change in such a way to make the bitMask invalid). - - Note: Subclasses such as KernelMorph and WidgetMorph redefine this method with an optimized - implementation that doesn't require computing and invalidating the #bitMask. Senders in the base image - and framework actually only use this optimized implementation. That's why general morphs don't care about - invalidting #bitMask. - - Note: If your morph #requiresVectorCanvas, and depends on this general implementation, remember to - `removeProperty: #bitMask` whenever it becomes invalid due to changes in your morphs. You may consider - using #ownsPixel: if appropriate, that doesn't require any maintenance and is cheaper (in cpu and memory). - - Note: This implementation requires VectorGraphics. - - See #ownsPixel: - See #ownsOrCoversPixel:" - - self visible ifTrue: [ - "Expensive way for morphs with arbitrary shape in VectorGraphics. - The base Cuis System doesn't use this. - Use this in applications if the expense of maintaining #bitMask is worth it." - self canvas ifNotNil: [ :canvas | - canvas canDoVectorGraphics ifTrue: [ - ^(self bitMask pixelValueAt: worldPoint - self displayFullBounds topLeft) = 1 ]]. - - "This is cheap and OK for unrotated Morphs with a rectangular shape. - In general, the answer is not strictly correct. - WidgetMorph redefines this method with an equally cheap implementation that can also handle - rotated morphs (but assuming they are of rectangular shape)." - self basicDisplayBounds ifNotNil: [ :r | - ^ r containsPoint: worldPoint ]]. - - ^ false.! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 10/28/2021 11:50:48' prior: 50619658! - ownsOrCoversPixel: worldPoint - "Answer true if we own the pixel, i.e. we are the last morph drawn at worldPoint. - - Some implementations (KernelMorph and WidgetMorph) may also answer true if we cover but don't own the pixel, - meaning that some other morph was drawn later, covering us. - - For other morphs, not KernelMorph or WidgetMorph, (i.e. they run this implementation), if VectorGraphics is not active, - answer true for any point that lies within our bounds. If this is the case, consider using VectorGraphics: In addition to - many other advantages, this method will always answer a strictly correct answer. - - Therefore, senders need to be aware that the answer is meaningful only when it is known that no other morph - covers us. A common case is to find the topmost morph at some position. In that case, iterating front to back ensures - that if any other morph covers us, it is found first. - - Note: This implementation is only used for morphs drawn by VectorCanvas, either because the main canvas is a - VectorCanvas, or because it is a HybridCanvas and we answer true to #requiresVectorCanvas. - (See other implementors) - - Note: Also see #ownsPixel: and #coversPixel:" - - "Check if #ownsPixel:, if possible." - self canvas ifNotNil: [ :canvas | - canvas canDoVectorGraphics ifTrue: [ - ^ (canvas morphIdAt: worldPoint) = self morphId ]]. - - "This is cheap and OK for unrotated Morphs with a rectangular shape. - In general, the answer is not strictly correct. - WidgetMorph redefines this method with an equally cheap implementation that can also handle - rotated morphs (but assuming they are of rectangular shape)." - self visible ifTrue: [ - self basicDisplayBounds ifNotNil: [ :r | - ^r containsPoint: worldPoint ]]. - - ^ false.! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 10/28/2021 11:41:15' prior: 50619689! - ownsPixel: worldPoint - "Answer true if we own the pixel, i.e. we are the last morph drawn at worldPoint. - Requires VectorGraphics, as we need VectorCanvas' morphIdAt: service. - - Valid if running on VectorCanvas. - - In case of running on HybridCanvas, this method is only valid for morphs that - are drawn by VectorCanvas (i.e. they answer true to #requiresVectorCanvas). - - See #coversPixel: - See #ownsOrCoversPixel:" - - self canvas ifNotNil: [ :canvas | - canvas canDoVectorGraphics ifTrue: [ - ^ (canvas morphIdAt: worldPoint) = self morphId ]]. - ^ false.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4953-owns-covers-pixel-JuanVuletich-2021Oct28-11h32m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4953] on 28 October 2021 at 12:20:10 pm'! -!Morph methodsFor: 'geometry services' stamp: 'jmv 10/28/2021 12:00:05'! - fullIncludesPixel: worldPoint - "Answer true if worldPoint is in some submorph, even if not inside our shape. - See comment at #includesPixel: for important notes on behavior." - - (self includesPixel: worldPoint) ifTrue: [ ^ true ]. - self submorphsMightProtrude ifTrue: [ - self submorphsDo: [ :m | - (m fullIncludesPixel: worldPoint) ifTrue: [ ^ true ]]]. - ^ false.! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 10/28/2021 12:18:50'! - includesPixel: worldPoint - "Answer true if we own the pixel, i.e. we are the last morph drawn at worldPoint. - - Some implementations (KernelMorph and WidgetMorph) may also answer true if we cover but don't own the pixel, - meaning that some other morph was drawn later, covering us. - - For other morphs, not KernelMorph or WidgetMorph, (i.e. they run this implementation), if VectorGraphics is not active, - answer true for any point that lies within our bounds. If this is the case, consider using VectorGraphics: In addition to - many other advantages, this method will always answer a strictly correct answer. - - Therefore, senders need to be aware that the answer is meaningful only when it is known that no other morph - covers us. A common case is to find the topmost morph at some position. In that case, iterating front to back ensures - that if any other morph covers us, it is found first. - - Note: This method is redefined by some subclasses. This implementation is only used for morphs drawn by VectorCanvas, - either because the main canvas is a VectorCanvas, or because it is a HybridCanvas and we answer true to #requiresVectorCanvas. - (See other implementors) - - Note: Also see #ownsPixel: and #coversPixel:" - - "Check if #ownsPixel:, if possible." - self canvas ifNotNil: [ :canvas | - canvas canDoVectorGraphics ifTrue: [ - ^ (canvas morphIdAt: worldPoint) = self morphId ]]. - - "This is cheap and OK for unrotated Morphs with a rectangular shape. - In general, the answer is not strictly correct. (There are false positives). - WidgetMorph redefines this method with an equally cheap implementation that can also handle - rotated morphs (but assuming they are of rectangular shape)." - self visible ifTrue: [ - self basicDisplayBounds ifNotNil: [ :r | - ^r containsPoint: worldPoint ]]. - - ^ false.! ! -!KernelMorph methodsFor: 'geometry services' stamp: 'jmv 10/28/2021 11:57:23' overrides: 50619955! - includesPixel: worldPoint - "Answer true if we own the pixel, i.e. we are the last morph drawn at worldPoint. (See implementation at Morph). - This implementation also answer true if we cover but don't own the pixel, - meaning that some other morph was drawn later, covering us. - Therefore, senders need to be aware that the answer is meaningful only when it is known that no other morph covers us. - Note: This implementation is only used for morphs with a cheap #coversPixel:. - (See other implementors) - Note: Also see #ownsPixel: and #coversPixel:" - - ^ self visible and: [self coversPixel: worldPoint].! ! -!WidgetMorph methodsFor: 'geometry services' stamp: 'jmv 10/28/2021 11:57:27' overrides: 50619955! -includesPixel: worldPoint - "Answer true if we own the pixel, i.e. we are the last morph drawn at worldPoint. (See implementation at Morph). - This implementation also answer true if we cover but don't own the pixel, - meaning that some other morph was drawn later, covering us. - Therefore, senders need to be aware that the answer is meaningful only when it is known that no other morph covers us. - Note: This implementation is only used for morphs with a cheap #coversPixel:. - (See other implementors) - Note: Also see #ownsPixel: and #coversPixel:" - - ^ self visible and: [self coversPixel: worldPoint].! ! -!Morph methodsFor: 'events-processing' stamp: 'jmv 10/28/2021 11:58:38' prior: 50608628! - processMouseOver: aMouseEvent localPosition: localEventPosition - "System level event handling." - self hasMouseFocus ifTrue: [ - "Got this directly through #handleFocusEvent: so check explicitly" - ((self rejectsEvent: aMouseEvent) not and: [self fullIncludesPixel: aMouseEvent eventPosition]) ifFalse: [ - ^self ]]. - aMouseEvent hand noticeMouseOver: self event: aMouseEvent. - "Open question: should any unhandled mouse move events be filtered out? (i.e. should mouseHover:localPosition: be called when a mouse button is pressed but the morph doesn't have mouse button handlers? Essentially, what are the limits of what is considered 'hovering'?" - (self handlesMouseHover and: [aMouseEvent wasHandled not]) ifTrue: [ - self - mouseHover: aMouseEvent - localPosition: localEventPosition ].! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 10/28/2021 12:17:08' prior: 50608689! - coversAnyPixelCloserThan: maxDistance to: worldPoint - "Answer true if our closest point to worldPoint is less than aNumber pixels away. - In target surface (i.e. Display) coordinates. - See #bitMask. - Remember to do - self removeProperty: #bitMask. - when appropriate!! (i.e. when we change in such a way to make the bitMask invalid). - - Note: Requires VectorGraphics. Meant to be used only when needed. - Note: Prefer #isCloserThan:toPixel:, that doesn't use #bitMask, and doesn't require maintenance." - - | center maxDistanceSquared | - self visible ifFalse: [ - ^false ]. - privateDisplayBounds ifNil: [ - ^false ]. - center _ privateDisplayBounds center. - "Quick checks: If not even within aNumber distance to display bounds, fail" - (center y - worldPoint y) abs < (privateDisplayBounds height // 2 + maxDistance) ifFalse: [ - ^false ]. - (center x - worldPoint x) abs < (privateDisplayBounds width // 2 + maxDistance) ifFalse: [ - ^false ]. - "Precise check with bitMask. If unavailable, just answer false. See #coversPixel:" - (self coversPixel: worldPoint) - ifNil: [ ^false ] - ifNotNil: [ :coversIt | - coversIt ifTrue: [ ^true ]]. - maxDistanceSquared _ maxDistance squared. - maxDistance negated to: maxDistance do: [ :dy | - maxDistance negated to: maxDistance do: [ :dx | - dx squared + dy squared <= maxDistanceSquared ifTrue: [ - (self coversPixel: worldPoint + (dx@dy)) ifTrue: [ ^true ]]]]. - ^false.! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 10/28/2021 12:15:19' prior: 50619796! - coversPixel: worldPoint - "Answer true if pixel worldPoint is covered by us, even if we are not visible a it because of some - other morph above us also covers it. - - WARNING: Might answer nil when we simply don't know. It is generally advisable to call this method only for - morphs where the answer is not nil: - - WidgetMorphs. No sepecial care needed. (Senders in the base Cuis image are of this kind). - - KernelMorphs. No special care needed. (Senders in the base Cuis image are of this kind). - - Morphs drawn by VectorCanvas (i.e. they #requiresVectorCanvas). See notes below. - - Note: If your morph #requiresVectorCanvas, and depends on this general implementation, remember to - `removeProperty: #bitMask` whenever it becomes invalid due to changes in your morphs. You may consider - using #ownsPixel: if appropriate, that doesn't require any maintenance and is cheaper (in cpu and memory). - See #bitMask. - - See #ownsPixel: - See #includesPixel:" - - self visible ifTrue: [ - "Expensive way for morphs with arbitrary shape in VectorGraphics. - The base Cuis System doesn't use this. - Use this in applications if the expense of maintaining #bitMask is worth it." - self canvas ifNotNil: [ :canvas | - canvas canDoVectorGraphics ifTrue: [ - ^(self bitMask pixelValueAt: worldPoint - self displayFullBounds topLeft) = 1 ]]. - - "This is cheap and OK for unrotated Morphs with a rectangular shape. - In general, the answer is not strictly correct. - WidgetMorph redefines this method with an equally cheap implementation that can also handle - rotated morphs (but assuming they are of rectangular shape)." - self basicDisplayBounds ifNotNil: [ :r | - (r containsPoint: worldPoint) ifFalse: [ ^false ] ]]. - - "If we don't know." - ^ nil.! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 10/28/2021 12:00:12' prior: 50619913! - ownsPixel: worldPoint - "Answer true if we own the pixel, i.e. we are the last morph drawn at worldPoint. - Requires VectorGraphics, as we need VectorCanvas' morphIdAt: service. - - Valid if running on VectorCanvas. - - In case of running on HybridCanvas, this method is only valid for morphs that - are drawn by VectorCanvas (i.e. they answer true to #requiresVectorCanvas). - - See #coversPixel: - See #includesPixel:" - - self canvas ifNotNil: [ :canvas | - canvas canDoVectorGraphics ifTrue: [ - ^ (canvas morphIdAt: worldPoint) = self morphId ]]. - ^ false.! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 10/28/2021 11:58:42' prior: 50608770! - transferHalo: event from: formerHaloOwner - "Progressively transfer the halo to the next likely recipient" - - formerHaloOwner == self - ifFalse: [ - self addHalo: event. - ^self ]. - - event shiftPressed ifTrue: [ - "Pass it outwards" - owner ifNotNil: [ - owner transferHalo: event from: formerHaloOwner. - ^self ]. - "We're at the top level; just keep it on ourselves" - ^self ]. - - self submorphsDo: [ :m | - (m wantsHalo and: [ m fullIncludesPixel: event eventPosition ]) - ifTrue: [ - m transferHalo: event from: formerHaloOwner. - ^self ]]. - "We're at the bottom most level; just keep halo on ourselves"! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 10/28/2021 12:03:20' prior: 50608792! - doRecolor: event with: aHandle - "The mouse went down in the 'recolor' halo handle. Allow the user to change the color of the innerTarget" - - event hand obtainHalo: self. - (aHandle includesPixel: event eventPosition) - ifFalse: [ "only do it if mouse still in handle on mouse up" - self delete. - target addHalo: event] - ifTrue: [ - target changeColor]! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 10/28/2021 12:03:24' prior: 50608806! - maybeCollapse: event with: aHandle - "Ask hand to collapse my target if mouse comes up in it." - - event hand obtainHalo: self. - (aHandle includesPixel: event eventPosition) - ifTrue: [ - target collapse ]. - self delete.! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 10/28/2021 12:03:27' prior: 50608816! - maybeDismiss: event with: aHandle - "Ask hand to dismiss my target if mouse comes up in it." - - event hand obtainHalo: self. - (aHandle includesPixel: event eventPosition) - ifFalse: [ - self delete. - target addHalo: event] - ifTrue: [ - target resistsRemoval ifTrue: [ - (PopUpMenu - confirm: 'Really throw this away' - trueChoice: 'Yes' - falseChoice: 'Um, no, let me reconsider') ifFalse: [^ self]]. - - self delete. - target dismissViaHalo]! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 10/28/2021 12:03:31' prior: 50608833! -setDismissColor: event with: aHandle - "Called on mouseStillDown in the dismiss handle; set the color appropriately." - - | colorToUse | - event hand obtainHalo: self. - colorToUse _ (aHandle includesPixel: event eventPosition) - ifFalse: [ `Color red muchLighter` ] - ifTrue: [ `Color lightGray` ]. - aHandle color: colorToUse! ! -!MenuItemMorph methodsFor: 'events' stamp: 'jmv 10/28/2021 12:03:36' prior: 50608846! - activateOwnerMenu: evt - "Activate our owner menu; e.g., pass control to it" - owner ifNil: [ ^false ]. "not applicable" - (owner includesPixel: evt eventPosition) - ifFalse: [ ^false ]. - owner activate: evt. - ^true! ! -!MenuItemMorph methodsFor: 'events' stamp: 'jmv 10/28/2021 12:03:40' prior: 50608856! - activateSubmenu: event - "Activate our submenu; e.g., pass control to it" - - subMenu ifNil: [ ^false ]. "not applicable" - subMenu isInWorld ifFalse: [ ^false ]. - (subMenu includesPixel: event eventPosition) ifFalse: [^false]. - subMenu activate: event. - ^true! ! -!PluggableButtonMorph methodsFor: 'events' stamp: 'jmv 10/28/2021 12:02:45' prior: 50608868 overrides: 16874556! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - - isPressed _ false. - mouseIsOver _ false. - (actWhen == #buttonUp and: [ - self includesPixel: aMouseButtonEvent eventPosition ]) - ifTrue: [ self performAction ]. - self redrawNeeded! ! -!MenuMorph methodsFor: 'events' stamp: 'jmv 10/28/2021 12:02:50' prior: 50608880 overrides: 16874541! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - "Handle a mouse down event." - (stayUp or: [ self includesPixel: aMouseButtonEvent eventPosition ]) - ifFalse: [ - self deleteIfPopUp: aMouseButtonEvent. - self activeHand - newKeyboardFocus: prevKbdFocus; - newMouseFocus: prevMouseFocus. - ^ self ]. "click outside" - - "Grab the menu and drag it to some other place - This is reimplemented here because we handle the event, and if the following lines are commented, a menu can't be grabbed with the hand. This is not nice and shouldn't be needed" - self isSticky ifTrue: [ ^self ]. - aMouseButtonEvent hand grabMorph: self.! ! -!MenuMorph methodsFor: 'events' stamp: 'jmv 10/28/2021 12:02:53' prior: 50608904 overrides: 16874556! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - "Handle a mouse up event. - Note: This might be sent from a modal shell." - (self includesPixel: aMouseButtonEvent eventPosition) ifFalse:[ - "Mouse up outside. Release eventual focus and delete if pop up." - aMouseButtonEvent hand ifNotNil: [ :h | h releaseMouseFocus: self ]. - self deleteIfPopUp: aMouseButtonEvent. - self activeHand - newKeyboardFocus: prevKbdFocus; - newMouseFocus: prevMouseFocus. - ^ self]. - stayUp ifFalse: [ - "Still in pop-up transition; keep focus" - aMouseButtonEvent hand newMouseFocus: self ].! ! -!AutoCompleterMorph methodsFor: 'events' stamp: 'jmv 10/28/2021 12:02:56' prior: 50608927 overrides: 16874556! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - - (self includesPixel: aMouseButtonEvent eventPosition) - ifTrue: [ - ((self upButtonPosition extent: ScrollBar scrollbarThickness) containsPoint: localEventPosition) - ifTrue: [ ^self stillActive; goUp ]. - ((self downButtonPosition extent: ScrollBar scrollbarThickness) containsPoint: localEventPosition) - ifTrue: [ ^self stillActive; goDown ]. - self selected: (localEventPosition y // self itemHeight) + self firstVisible. - completer insertSelected ] - ifFalse: [ self delete. completer menuClosed ]! ! -!MorphicEvent methodsFor: 'dispatching' stamp: 'jmv 10/28/2021 11:58:51' prior: 50608949! - dispatchWith: aMorph - "Dispatch me. The event will be passed to the front-most visible submorph that contains the position wrt. to the event." - | handledByInner | - - "Try to get out quickly" - (aMorph fullIncludesPixel: self eventPosition) - ifFalse: [ ^#rejected ]. - - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - (eachChild dispatchEvent: self) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - - "Check for being inside the receiver" - (handledByInner or: [ (aMorph rejectsEvent: self) not and: [aMorph fullIncludesPixel: self eventPosition] ]) - ifTrue: [ ^ self sendEventTo: aMorph ]. - - ^ #rejected! ! -!DropEvent methodsFor: 'dispatching' stamp: 'jmv 10/28/2021 11:58:57' prior: 50608978 overrides: 50620392! - dispatchWith: aMorph - "Drop is done on the innermost target that accepts it." - | dropped | - - "Try to get out quickly" - (aMorph fullIncludesPixel: position) - ifFalse: [ ^#rejected ]. - - "Go looking if any of our submorphs wants it" - aMorph submorphsDo: [ :eachChild | - (eachChild dispatchEvent: self) == #rejected ifFalse: [ - ^self ]]. - - (aMorph allowsMorphDrop and: [ (aMorph rejectsEvent: self) not and: [aMorph fullIncludesPixel: position] ]) - ifTrue: [ - "Do a symmetric check if both morphs like each other" - dropped _ self contents. - ((aMorph wantsDroppedMorph: dropped event: self) "I want her" - and: [dropped wantsToBeDroppedInto: aMorph]) "she wants me" - ifTrue: [ - ^ self sendEventTo: aMorph ]]. - ^#rejected! ! -!DropFilesEvent methodsFor: 'dispatching' stamp: 'jmv 10/28/2021 11:59:02' prior: 50609005 overrides: 50620392! - dispatchWith: aMorph - "Drop is done on the innermost target that accepts it." - - "Try to get out quickly" - (aMorph fullIncludesPixel: position) ifFalse: [ ^#rejected ]. - - "Go looking if any of our submorphs wants it" - aMorph submorphsDo: [ :eachChild | - (eachChild dispatchEvent: self) == #rejected ifFalse: [ ^self ]]. - - (aMorph allowsFilesDrop and: [ (aMorph rejectsEvent: self) not and: [aMorph fullIncludesPixel: position] ]) - ifTrue: [^ self sendEventTo: aMorph ]. - - ^#rejected! ! -!KeyboardEvent methodsFor: 'actions' stamp: 'jmv 10/28/2021 12:03:50' prior: 50609024! - closeCurrentWindowOf: aMorph - - aMorph owningWindow ifNotNil: [ :w | - (w includesPixel: position) - ifTrue: [ w delete ] ].! ! -!MouseButtonEvent methodsFor: 'dispatching' stamp: 'jmv 10/28/2021 11:59:20' prior: 50609032 overrides: 50620392! - dispatchWith: aMorph - "Find the appropriate receiver for the event and let it handle it. Default rules: - * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. - * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. - * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. - * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. - " - | aMorphHandlesIt grabAMorph handledByInner | - "Only for MouseDown" - self isMouseDown ifFalse: [ - ^super dispatchWith: aMorph ]. - - "Try to get out quickly" - (aMorph fullIncludesPixel: position) - ifFalse: [ ^#rejected ]. - - "Install the prospective handler for the receiver" - aMorphHandlesIt _ false. - grabAMorph _ false. - self mouseButton3Pressed - ifTrue: [ - (eventHandler isNil or: [ eventHandler isWorldMorph or: [ - self shiftPressed or: [ aMorph is: #HaloMorph ]]]) - ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]] - ifFalse: [ - (aMorph handlesMouseDown: self) ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]. - "If button 1, and both aMorph and the owner allows grabbing with the hand (to initiate drag & drop), so be it." - self mouseButton1Pressed ifTrue: [ - aMorph owner ifNotNil: [ :o | - (o allowsSubmorphDrag and: [ aMorph isSticky not ]) ifTrue: [ - grabAMorph _ true ]]]]. - - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - (eachChild dispatchEvent: self) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - - (handledByInner or: [ (aMorph rejectsEvent: self) not and: [aMorph fullIncludesPixel: position] ]) ifTrue: [ - "aMorph is in the top-most unlocked, visible morph in the chain." - aMorphHandlesIt - ifTrue: [ ^self sendEventTo: aMorph ] - ifFalse: [ - (grabAMorph and: [ handledByInner not ]) ifTrue: [ - self hand - waitForClicksOrDrag: aMorph event: self - dragSel: (Preferences clickGrabsMorphs ifFalse: [#dragEvent:localPosition:]) - clkSel: (Preferences clickGrabsMorphs ifTrue: [#dragEvent:localPosition:]). - "false ifTrue: [ self hand grabMorph: aMorph ]." - Preferences clickGrabsMorphs ifFalse: [aMorph activateWindow]. - self wasHandled: true. - ^self ]]]. - - handledByInner ifTrue: [ ^self ]. - "Mouse was not on aMorph nor any of its children" - ^ #rejected! ! -!MouseScrollEvent methodsFor: 'dispatching' stamp: 'jmv 10/28/2021 11:59:12' prior: 50609125 overrides: 50620392! - dispatchWith: aMorph - "Find the appropriate receiver for the event and let it handle it. Default rules: - * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. - * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. - * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. - * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. - " - "Try to get out quickly" - | aMorphHandlesIt handledByInner | - "FIXME - this works in all tested cases but one: when the window directly under the mouse doesn't have keyboard focus (i.e. a Transcript window)" - aMorph fullIncludesPixel: position :: ifFalse: [ ^ #rejected ]. - "Install the prospective handler for the receiver" - aMorphHandlesIt _ false. - (aMorph handlesMouseScroll: self) ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]. - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - (eachChild dispatchEvent: self) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - (handledByInner or: [ - (aMorph rejectsEvent: self) not and: [aMorph fullIncludesPixel: position]]) ifTrue: [ - "aMorph is in the top-most unlocked, visible morph in the chain." - aMorphHandlesIt ifTrue: [ ^ self sendEventTo: aMorph ]]. - handledByInner ifTrue: [ ^ self ]. - "Mouse was not on aMorph nor any of its children" - ^ #rejected.! ! - -WidgetMorph removeSelector: #ownsOrCoversPixel:! - -!methodRemoval: WidgetMorph #ownsOrCoversPixel: stamp: 'Install-4954-includesPixel-not-ownsOrCoversPixel-JuanVuletich-2021Oct28-11h55m-jmv.001.cs.st 11/2/2021 10:27:39'! -ownsOrCoversPixel: worldPoint - "Answer true if we own the pixel, i.e. we are the last morph drawn at worldPoint. - This implementation also answer true if we cover but don't own the pixel, - meaning that some other morph was drawn later, covering us. - Therefore, senders need to be aware that the answer is meaningful only when it is known that no other morph covers us. - Note: This implementation is only used for morphs with a cheap #coversPixel:. - (See other implementors) - Note: Also see #ownsPixel: and #coversPixel:" - - ^ self visible and: [self coversPixel: worldPoint].! - -KernelMorph removeSelector: #ownsOrCoversPixel:! - -!methodRemoval: KernelMorph #ownsOrCoversPixel: stamp: 'Install-4954-includesPixel-not-ownsOrCoversPixel-JuanVuletich-2021Oct28-11h55m-jmv.001.cs.st 11/2/2021 10:27:39'! -ownsOrCoversPixel: worldPoint - "Answer true if we own the pixel, i.e. we are the last morph drawn at worldPoint. - This implementation also answer true if we cover but don't own the pixel, - meaning that some other morph was drawn later, covering us. - Therefore, senders need to be aware that the answer is meaningful only when it is known that no other morph covers us. - Note: This implementation is only used for morphs with a cheap #coversPixel:. - (See other implementors) - Note: Also see #ownsPixel: and #coversPixel:" - - ^ self visible and: [self coversPixel: worldPoint].! - -Morph removeSelector: #ownsOrCoversPixel:! - -!methodRemoval: Morph #ownsOrCoversPixel: stamp: 'Install-4954-includesPixel-not-ownsOrCoversPixel-JuanVuletich-2021Oct28-11h55m-jmv.001.cs.st 11/2/2021 10:27:39'! -ownsOrCoversPixel: worldPoint - "Answer true if we own the pixel, i.e. we are the last morph drawn at worldPoint. - - Some implementations (KernelMorph and WidgetMorph) may also answer true if we cover but don't own the pixel, - meaning that some other morph was drawn later, covering us. - - For other morphs, not KernelMorph or WidgetMorph, (i.e. they run this implementation), if VectorGraphics is not active, - answer true for any point that lies within our bounds. If this is the case, consider using VectorGraphics: In addition to - many other advantages, this method will always answer a strictly correct answer. - - Therefore, senders need to be aware that the answer is meaningful only when it is known that no other morph - covers us. A common case is to find the topmost morph at some position. In that case, iterating front to back ensures - that if any other morph covers us, it is found first. - - Note: This implementation is only used for morphs drawn by VectorCanvas, either because the main canvas is a - VectorCanvas, or because it is a HybridCanvas and we answer true to #requiresVectorCanvas. - (See other implementors) - - Note: Also see #ownsPixel: and #coversPixel:" - - "Check if #ownsPixel:, if possible." - self canvas ifNotNil: [ :canvas | - canvas canDoVectorGraphics ifTrue: [ - ^ (canvas morphIdAt: worldPoint) = self morphId ]]. - - "This is cheap and OK for unrotated Morphs with a rectangular shape. - In general, the answer is not strictly correct. - WidgetMorph redefines this method with an equally cheap implementation that can also handle - rotated morphs (but assuming they are of rectangular shape)." - self visible ifTrue: [ - self basicDisplayBounds ifNotNil: [ :r | - ^r containsPoint: worldPoint ]]. - - ^ false.! - -Morph removeSelector: #fullOwnsOrCoversPixel:! - -!methodRemoval: Morph #fullOwnsOrCoversPixel: stamp: 'Install-4954-includesPixel-not-ownsOrCoversPixel-JuanVuletich-2021Oct28-11h55m-jmv.001.cs.st 11/2/2021 10:27:39'! -fullOwnsOrCoversPixel: worldPoint - "Answer true if worldPoint is in some submorph, even if not inside our shape. - See comment at #ownsOrCoversPixel: for important notes on behavior." - - (self ownsOrCoversPixel: worldPoint) ifTrue: [ ^ true ]. - self submorphsMightProtrude ifTrue: [ - self submorphsDo: [ :m | - (m fullOwnsOrCoversPixel: worldPoint) ifTrue: [ ^ true ]]]. - ^ false.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4954-includesPixel-not-ownsOrCoversPixel-JuanVuletich-2021Oct28-11h55m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4954] on 29 October 2021 at 11:13:41 am'! -!Number methodsFor: 'truncation and round off' stamp: 'jmv 10/29/2021 10:57:03'! - roundedHAFZ - "Answer the integer nearest the receiver. - Use the rounding rule commonly taught in school." - "See https://en.wikipedia.org/wiki/Rounding#Round_half_away_from_zero - See #rounded" - - ^(self + (self sign / 2)) truncated.! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 10/29/2021 11:03:21' overrides: 50620765! - roundedHAFZ - "Answer the integer nearest the receiver." - "See https://en.wikipedia.org/wiki/Rounding#Round_half_away_from_zero - See #rounded" - - self fractionPart abs < 0.5 - ifTrue: [^self truncated] - ifFalse: [^self truncated + self sign].! ! -!Integer methodsFor: 'truncation and round off' stamp: 'jmv 10/29/2021 10:55:37' overrides: 50620765! - roundedHAFZ - "Refer to the comment in Number >> roundedHAFZ." - - ^self! ! -!Point methodsFor: 'truncation and round off' stamp: 'jmv 10/29/2021 10:52:04'! - roundedHAFZ - "Answer a Point that is the receiver's x and y rounded. Answer the receiver if its coordinates are already integral." - - (x isInteger and: [y isInteger]) ifTrue: [^ self]. - ^ x roundedHAFZ @ y roundedHAFZ! ! -!Rectangle methodsFor: 'truncation and round off' stamp: 'jmv 10/29/2021 10:52:11'! - roundedHAFZ - "Answer a Rectangle whose origin and corner are rounded." - - ^Rectangle origin: origin roundedHAFZ corner: self corner roundedHAFZ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4955-rounded-halfAwayFromZero-JuanVuletich-2021Oct29-11h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4955] on 29 October 2021 at 11:36:43 am'! -!Number methodsFor: 'truncation and round off' stamp: 'jmv 10/29/2021 09:53:30' prior: 50418015! - rounded - "Answer the integer nearest the receiver." - "See https://en.wikipedia.org/wiki/Rounding#Round_half_to_even" - - | truncated fractionPartAbs | - truncated _ self truncated. - fractionPartAbs _ (self-truncated) abs. - fractionPartAbs = `1/2` - ifTrue: [ truncated even ifTrue: [^truncated] ifFalse: [^truncated + self sign]]. - fractionPartAbs < `1/2` - ifTrue: [^ truncated] - ifFalse: [^ truncated + self sign]! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 10/29/2021 10:52:28' prior: 50614234! - drawString: s at: pt font: font color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - - | p1 | - p1 _ pt roundedHAFZ. - p1 _ p1 + (0@(0 - (font ascent + font lineGap-1))). - p1 _ p1 roundedHAFZ. - displayEngine colorMap: nil. - ^font - onBitBltCanvasEngine: displayEngine - displayString: s - from: 1 - to: s size - at: p1 - color: aColor! ! -!BitBlt methodsFor: 'line drawing' stamp: 'jmv 10/29/2021 10:52:36' prior: 16785828! - drawFrom: startPoint to: stopPoint withFirstPoint: drawFirstPoint - "Draw a line whose end points are startPoint and stopPoint. - The line is formed by repeatedly calling copyBits at every - point along the line. If drawFirstPoint is false, then omit - the first point so as not to overstrike at line junctions." - | offset point1 point2 forwards | - "Always draw down, or at least left-to-right" - forwards _ (startPoint y = stopPoint y and: [startPoint x < stopPoint x]) - or: [startPoint y < stopPoint y]. - forwards - ifTrue: [point1 _ startPoint. point2 _ stopPoint] - ifFalse: [point1 _ stopPoint. point2 _ startPoint]. - sourceForm - ifNil: [ - destX := point1 x. - destY := point1 y] - ifNotNil: [ - width := sourceForm width. - height := sourceForm height. - offset := sourceForm offset. - destX := (point1 x + offset x) roundedHAFZ. - destY := (point1 y + offset y) roundedHAFZ]. - - "Note that if not forwards, then the first point is the last and vice versa. - We agree to always paint stopPoint, and to optionally paint startPoint." - (drawFirstPoint or: [forwards == false "ie this is stopPoint"]) - ifTrue: [self copyBits]. - self drawLoopX: (point2 x - point1 x) roundedHAFZ - Y: (point2 y - point1 y) roundedHAFZ. - (drawFirstPoint or: [forwards "ie this is stopPoint"]) - ifTrue: [self copyBits]. -! ! -!WarpBlt class methodsFor: 'form rotation' stamp: 'jmv 10/29/2021 10:52:41' prior: 16943446! - rotate: srcForm degrees: angleInDegrees center: aPoint scaleBy: scalePoint smoothing: cellSize - "Rotate the given Form the given number of degrees about the given center and scale its width and height by x and y of the given scale point. Smooth using the given cell size, an integer between 1 and 3, where 1 means no smoothing. Return a pair where the first element is the rotated Form and the second is the position offset required to align the center of the rotated Form with that of the original. Note that the dimensions of the resulting Form generally differ from those of the original." - - | srcRect center radians dstOrigin dstCorner p dstRect inverseScale quad dstForm newCenter warpSrc | - srcRect _ srcForm boundingBox. - center _ srcRect center. - radians _ angleInDegrees degreesToRadians. - dstOrigin _ dstCorner _ center. - srcRect corners do: [:corner | - "find the limits of a rectangle that just encloses the rotated - original; in general, this rectangle will be larger than the - original (e.g., consider a square rotated by 45 degrees)" - p _ ((corner - center) scaledBy: scalePoint) + center. - p _ (p inverseRotatedBy: radians about: center) roundedHAFZ. - dstOrigin _ dstOrigin min: p. - dstCorner _ dstCorner max: p]. - - "rotate the enclosing rectangle back to get the source quadrilateral" - dstRect _ dstOrigin corner: dstCorner. - inverseScale _ (1.0 / scalePoint x)@(1.0 / scalePoint y). - quad _ dstRect innerCorners collect: [:corner | - p _ corner inverseRotatedBy: radians negated about: center. - ((p - center) scaledBy: inverseScale) + center]. - - "make a Form to hold the result and do the rotation" - warpSrc _ srcForm. - (srcForm is: #ColorForm) - ifTrue: [ - cellSize > 1 | true "ar 12/27/2001: Always enable - else sketches won't work" - ifTrue: [ - warpSrc _ Form extent: srcForm extent depth: 16. - srcForm displayOn: warpSrc. - dstForm _ Form extent: dstRect extent depth: 16] "use 16-bit depth to allow smoothing" - ifFalse: [ - dstForm _ srcForm class extent: dstRect extent depth: srcForm depth]] - ifFalse: [ - dstForm _ srcForm class extent: dstRect extent depth: srcForm depth]. - - (WarpBlt toForm: dstForm) - sourceForm: warpSrc; - colorMap: (warpSrc colormapIfNeededFor: dstForm); - cellSize: cellSize; "installs a new colormap if cellSize > 1" - combinationRule: Form paint; - copyQuad: quad toRect: dstForm boundingBox. - - (dstForm is: #ColorForm) ifTrue: [ dstForm colors: srcForm colors copy ]. - newCenter _ (center inverseRotatedBy: radians about: aPoint) truncated. - ^ Array with: dstForm with: dstRect origin + (newCenter - center) -! ! -!MorphicScanner methodsFor: 'scanning' stamp: 'jmv 10/29/2021 10:53:23' prior: 50596988 overrides: 50596938! - placeEmbeddedObject: anchoredFormOrMorph - - (super placeEmbeddedObject: anchoredFormOrMorph) ifFalse: [^ false]. - (anchoredFormOrMorph is: #Morph) - ifTrue: [ - anchoredFormOrMorph morphPosition: - (destX@ (lineY+line baseline)) + (anchoredFormOrMorph morphPosition-anchoredFormOrMorph fullBoundsInOwner corner) roundedHAFZ. - anchoredFormOrMorph show. - canvas fullDraw: anchoredFormOrMorph ] - ifFalse: [ - destY _ lineY. - canvas - image: anchoredFormOrMorph - at: destX - anchoredFormOrMorph width @ (destY + line baseline - anchoredFormOrMorph height) ]. - ^ true! ! -!IndentingListItemMorph methodsFor: 'drawing' stamp: 'jmv 10/29/2021 10:53:27' prior: 50592621 overrides: 50593952! - drawOn: aCanvas - - | x colorToUse centeringOffset | - isHighlighted ifTrue: [ - aCanvas - fillRectangle: self morphLocalBounds - color: ((Theme current - listHighlightFocused: owner owner hasKeyboardFocus) alpha: 0.3) ]. - - isSelected ifTrue: [ - aCanvas - fillRectangle: self morphLocalBounds - color: (Theme current - listHighlightFocused: owner owner hasKeyboardFocus) ]. - - x _ 12 * indentLevel. - - complexContents hasContents ifTrue: [ - isExpanded - ifTrue: [ aCanvas drawExpandedAt: x@(extent y//2)] - ifFalse: [ aCanvas drawNotExpandedAt: x@(extent y//2) ]]. - x _ x + 18. - - icon isNil ifFalse: [ - centeringOffset _ ((extent y - icon height) / 2.0) roundedHAFZ. - aCanvas - image: icon - at: (x @ centeringOffset). - x _ x + 20 ]. - - colorToUse _ complexContents preferredColor ifNil: [ color ]. - aCanvas - drawString: contents asString - at: x@0 - font: self fontToUse - color: colorToUse! ! -!BitBltCanvas methodsFor: 'drawing' stamp: 'jmv 10/29/2021 10:54:26' prior: 50595547 overrides: 50463409! - line: pt1 to: pt2 width: wp color: c - - | p1 p2 w | - (wp > 0 and: [ c isTransparent not ]) ifTrue: [ - p1 _ (currentTransformation transform: pt1) roundedHAFZ. - p2 _ (currentTransformation transform: pt2) roundedHAFZ. - w _ (currentTransformation externalizeScalar: wp) roundedHAFZ. - self setPaintColor: c. - engine - width: w; - height: w; - drawFrom: p1 to: p2 ]! ! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 10/29/2021 10:54:12' prior: 50595572! - image: aForm at: aPoint sourceRect: sourceRect - "Draw a translucent image using the best available way of representing translucency. - Note: This will be fixed in the future." - - | r p | - p _ (currentTransformation transform: aPoint) roundedHAFZ. - r _ (form depth < 32 or: [ aForm mightBeTranslucent not ]) - ifTrue: [ - "Rule Form paint treats pixels with a value of zero as transparent" - Form paint ] - ifFalse: [ Form blend ]. - engine colorMap: (aForm colormapIfNeededFor: form); fillColor: nil. - engine image: aForm at: p sourceRect: sourceRect rule: r. - (form depth = 32 and: [ aForm depth < 32 ]) ifTrue: [ - "If we blit to 32bpp from one of smaller depth, - it will have zero in the alpha channel (until BitBlt is fixed!!) - This is the same workaround as in #asFormOfDepth:" - engine sourceForm: nil. - engine combinationRule: 40. "fixAlpha:with:" - engine copyBits ]! ! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 10/29/2021 10:54:30' prior: 50595603! - stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor - "Flood this canvas with aColor wherever stencilForm has non-zero pixels" - | p | - p _ (currentTransformation transform: aPoint) roundedHAFZ. - self setPaintColor: aColor. - engine colorMap: stencilForm maskingMap. - engine stencil: stencilForm - at: p - sourceRect: sourceRect! ! -!BitBltCanvas methodsFor: 'drawing-ovals' stamp: 'jmv 10/29/2021 10:53:55' prior: 50618441 overrides: 50569695! - ellipseCenter: center radius: radiusPointOrNumber borderWidth: mbw borderColor: mbc fillColor: morphFillColor - - | displayRectangle doBorder doFill | - doBorder _ mbw > 0 and: [ mbc isTransparent not]. - doFill _ morphFillColor isTransparent not. - doBorder | doFill ifTrue: [ - displayRectangle _ (currentTransformation externalBoundingRectOf: (Rectangle center: center extent: radiusPointOrNumber asPoint * 2)) roundedHAFZ. - "draw the border of the oval" - doBorder ifTrue: [ - self setPaintColor: mbc. - engine frameOval: displayRectangle borderWidth: mbw roundedHAFZ]. - "fill the inside" - doFill ifTrue: [ - self setPaintColor: morphFillColor. - engine fillOval: (displayRectangle insetBy: mbw roundedHAFZ) ]]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 10/29/2021 10:54:03' prior: 50618467 overrides: 50463471! - frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor - - | rect bw | - r area = 0 ifTrue: [ ^self ]. - rect _ (currentTransformation externalBoundingRectOf: r) roundedHAFZ. - bw _ (currentTransformation externalizeScalar: borderWidth) roundedHAFZ. - - "draw the border of the rectangle" - borderColor isTransparent ifFalse: [ - self setPaintColor: borderColor. - engine frameRect: rect borderWidth: bw ]. - - "fill the inside" - fillColor isTransparent ifFalse: [ - self setPaintColor: fillColor. - engine fillRect: (rect insetBy: bw) ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 10/29/2021 10:54:06' prior: 50618489 overrides: 50463478! - frameRectangle: r borderWidth: borderWidth color: borderColor - " - (BitBltCanvas onForm: Display) - frameRectangle: (10@10 extent: 300@200) - borderWidth: 20 - color: Color red. - Display forceToScreen - " - | rect bw | - (borderWidth > 0 and: [ borderColor isTransparent not ]) ifTrue: [ - rect _ (currentTransformation externalBoundingRectOf: r) roundedHAFZ. - bw _ (currentTransformation externalizeScalar: borderWidth) roundedHAFZ. - self setPaintColor: borderColor. - engine - frameRect: rect - borderWidth: bw ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 10/29/2021 10:54:09' prior: 50618508! - frameRectangle: aRectangle topLeftColor: tlColor bottomRightColor: brColor borderWidth: borderWidth - " - (BitBltCanvas onForm: Display) - frameRectangle: (10@10 extent: 300@200) - color: Color green - borderWidth: 10 - borderStyleSymbol: #raised. - Display forceToScreen. - " - - | displayRectangle bw | - bw _ (currentTransformation externalizeScalar: borderWidth) roundedHAFZ. - displayRectangle _ (currentTransformation externalBoundingRectOf: aRectangle) roundedHAFZ. - self - frameRectangle: displayRectangle - borderWidth: bw - topLeftColor: tlColor - bottomRightColor: brColor.! ! -!BitBltCanvas methodsFor: 'drawing-roundedRectangles' stamp: 'jmv 10/29/2021 10:54:28' prior: 50617165 overrides: 50463497! - roundRect: aRectangle color: aColor radius: aNumber - " - (BitBltCanvas onForm: Display) roundRect: (10@10 extent: 200@100) color: Color red radius: 10.5. Display forceToScreen. - " - | r | - r _ (currentTransformation externalizeScalar: aNumber) roundedHAFZ. - - "top stripe" - self - image: (self class topLeftCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle topLeft. - self - image: (self class topRightCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle topRight - (r@0). - self fillRectangle: ((aRectangle withHeight: r) insetBy: r@0) color: aColor. - - "center stripe" - self fillRectangle: (aRectangle insetBy: (0 @ r corner: 0 @ r)) color: aColor. - - "bottom stripe" - self - image: (self class bottomLeftCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle bottomLeft - (0@r). - self - image: (self class bottomRightCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle bottomRight - (r@r) . - self fillRectangle: ((aRectangle bottomLeft + (r@r negated)) extent: (aRectangle width - r - r@r)) color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 10/29/2021 10:53:34' prior: 50595784 overrides: 50565947! - drawString: aString from: firstIndex to: lastIndex atBaseline: aPoint font: font color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - - | p1 | - "Don't waste any time if NOP" - lastIndex = 0 ifTrue: [ - ^nil ]. - - p1 _ currentTransformation transform: aPoint roundedHAFZ. - p1 _ p1 + (0@(0 - (font ascent + font lineGap-1))). - p1 _ p1 roundedHAFZ. - engine colorMap: nil. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 10/29/2021 10:53:40' prior: 50595804 overrides: 50566634! - drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint font: font color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - | p1 | - p1 _ (currentTransformation transform: aPoint roundedHAFZ) roundedHAFZ. - engine colorMap: nil. - - aColor = `Color black` ifFalse: [ | topColor | - topColor _ aColor alphaMixed: 0.25 with: `Color black`. - font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: topColor ]. - aColor = `Color white` ifFalse: [ | bottomColor | - bottomColor _ aColor alphaMixed: 0.22 with: `Color white`. - font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + `0@2` - color: bottomColor ]. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + `0@1` - color: aColor.! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 10/29/2021 10:53:58' prior: 50618529! - fillRectangle: aRectangle tilingWith: aForm sourceRect: patternBox rule: aCombinationRule - - | displayRectangle additionalOffset clippedEngine targetTopLeft clipOffset ex - targetBox savedMap top left | - - ex _ patternBox extent. - ex x = 0 ifTrue: [ ^self ]. - ex y = 0 ifTrue: [ ^self ]. - displayRectangle _ (currentTransformation externalBoundingRectOf: aRectangle) roundedHAFZ. - - "this is a bit of a kludge to get the form to be aligned where I *think* it should be. - something better is needed, but not now" - - additionalOffset _ `0@0`. - clippedEngine _ engine clippedBy: displayRectangle. - targetTopLeft _ clippedEngine clipRect topLeft truncateTo: ex. - clipOffset _ displayRectangle topLeft - targetTopLeft. - additionalOffset _ (clipOffset \\ ex) - ex. - - "do it iteratively" - targetBox _ clippedEngine clipRect. - savedMap _ clippedEngine colorMap. - clippedEngine sourceForm: aForm; - fillColor: nil; - combinationRule: aCombinationRule; - sourceRect: patternBox; - colorMap: (aForm colormapIfNeededFor: clippedEngine destForm). - top _ (targetBox top truncateTo: patternBox height) + additionalOffset y. - left _ (targetBox left truncateTo: patternBox width) + additionalOffset x. - - left to: (targetBox right - 1) by: patternBox width do: [:x | - top to: (targetBox bottom - 1) by: patternBox height do: [:y | - clippedEngine destOrigin: x@y; copyBits]]. - clippedEngine colorMap: savedMap! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4956-Use-roundedHalfAwayFromZero-forPixelCoordinates-JuanVuletich-2021Oct29-11h34m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4956] on 29 October 2021 at 12:23:47 pm'! -!Morph methodsFor: 'drawing' stamp: 'jmv 10/29/2021 12:22:53' prior: 50619037! - imageForm: extentOrNil depth: depth - - | answerExtent answer auxCanvas | - self requiresVectorCanvas ifTrue: [ - ^ self imageFormVG: extentOrNil depth: depth ]. - - answerExtent _ self findFullBoundsInOwner extent. - extentOrNil ifNotNil: [ answerExtent _ answerExtent min: extentOrNil * 4 ]. - auxCanvas _ MorphicCanvas depth: depth over: (self morphPosition floor extent: answerExtent ceiling). - auxCanvas fullDraw: self. - answer _ auxCanvas form divideByAlpha. - extentOrNil ifNotNil: [ answer _ answer magnifyTo: extentOrNil ]. - ^answer! ! - -WidgetMorph removeSelector: #imageForm:depth:! - -!methodRemoval: WidgetMorph #imageForm:depth: stamp: 'Install-4957-imageFormdepth-simplify-JuanVuletich-2021Oct29-12h22m-jmv.001.cs.st 11/2/2021 10:27:39'! -imageForm: extentOrNil depth: depth - - | answerExtent answer auxCanvas | - self requiresVectorCanvas ifFalse: [ - answerExtent _ extent. - extentOrNil ifNotNil: [ answerExtent _ answerExtent min: extentOrNil * 4 ]. - auxCanvas _ MorphicCanvas depth: depth over: (self morphPosition floor extent: answerExtent ceiling). - auxCanvas fullDraw: self. - answer _ auxCanvas form divideByAlpha. - extentOrNil ifNotNil: [ answer _ answer magnifyTo: extentOrNil ]. - ^answer ]. - ^super imageForm: extentOrNil depth: depth.! - -KernelMorph removeSelector: #imageForm:depth:! - -!methodRemoval: KernelMorph #imageForm:depth: stamp: 'Install-4957-imageFormdepth-simplify-JuanVuletich-2021Oct29-12h22m-jmv.001.cs.st 11/2/2021 10:27:39'! -imageForm: extentOrNil depth: depth - - | answerExtent answer auxCanvas | - self requiresVectorCanvas ifFalse: [ - answerExtent _ extent. - extentOrNil ifNotNil: [ answerExtent _ answerExtent min: extentOrNil * 4 ]. - auxCanvas _ MorphicCanvas depth: depth over: (self morphPosition floor extent: answerExtent ceiling). - auxCanvas fullDraw: self. - answer _ auxCanvas form divideByAlpha. - extentOrNil ifNotNil: [ answer _ answer magnifyTo: extentOrNil ]. - ^answer ]. - ^super imageForm: extentOrNil depth: depth.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4957-imageFormdepth-simplify-JuanVuletich-2021Oct29-12h22m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4957] on 29 October 2021 at 5:45:19 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/29/2021 15:05:41'! - morphExtent - "In our own coordinates!! - nil if unknown." - - ^ nil! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 10/29/2021 16:54:11' overrides: 50619460! - fullBoundsInOwner - "Find and answer full bounds in whatever owner. - Note: Answers an integer rectangle" - - "Rethoric question. If it is ever true, call super." - "(self submorphsMightProtrude and: [self clipsSubmorphsReally not]) ifFalse: [" - ^ (self externalizeBoundingRectOf: self morphLocalBounds) encompassingIntegerRectangle! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 10/29/2021 16:54:07' overrides: 50619460! - fullBoundsInOwner - "Find and answer full bounds in whatever owner. - Note: Answers an integer rectangle" - - "Rethoric question. If it is ever true, call super." - "(self submorphsMightProtrude and: [self clipsSubmorphsReally not]) ifFalse: [" - ^ (self externalizeBoundingRectOf: self morphLocalBounds) encompassingIntegerRectangle! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 10/29/2021 15:59:23' prior: 50621333! - imageForm: extentOrNil depth: depth - - | answerExtent answer auxCanvas bounds | - self requiresVectorCanvas ifTrue: [ - ^ self imageFormVG: extentOrNil depth: depth ]. - - bounds _ self fullBoundsInOwner. - answerExtent _ bounds extent. - extentOrNil ifNotNil: [ answerExtent _ answerExtent min: extentOrNil * 4 ]. - auxCanvas _ MorphicCanvas depth: depth over: (bounds origin extent: answerExtent ceiling). - auxCanvas fullDraw: self. - answer _ auxCanvas form divideByAlpha. - extentOrNil ifNotNil: [ answer _ answer magnifyTo: extentOrNil ]. - ^answer! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/29/2021 15:49:22' prior: 50601395! - findFullBoundsInOwner - "Find and answer full bounds in whatever owner. - These might not equal #displayFullBounds at all!! - Subclasses that (re)define #requiresVectorCanvas and #morphExtent should redefine this methods. - See inheritance. - Note: Answers an integer rectangle" - - | prevNotVisibleFlag w c answer prevOwner | - (owner notNil and: [owner isWorldMorph]) ifTrue: [ - w _ owner ] - ifFalse: [ - w _ UISupervisor ui ]. - c _ w boundsFinderCanvas. - "Hack owner so #displayBoundsSetFrom: will update privateDisplayBounds" - prevOwner _ owner. - owner _ w. - prevNotVisibleFlag _ self privateFlagAt: 3. - self privateFlagAt: 3 put: false. - c fullUpdateProtrudingBounds: self. - answer _ self displayFullBounds. - "Reset owner and privateDisplayBounds (if needed) so no one finds out what we've just done!!" - prevOwner == owner ifFalse: [ - owner _ prevOwner. - self world = w ifTrue: [ - self privateFlagAt: 3 put: false. - self allOwnersReverseDo: [ :m | c into: m ]. - c fullUpdateProtrudingBounds: self. - self allOwnersDo: [ :m | c outOfMorph ]]]. - self privateFlagAt: 3 put: prevNotVisibleFlag. - ^answer! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/29/2021 15:34:45' prior: 50619460! - fullBoundsInOwner - "Answer fullBoundsInOwner. Cache the found bounds. - No special care needed for property #fullBoundsInOwner. Cache is invalidated when appropriate. - Note: Answers an integer rectangle" - - (self valueOfProperty: #fullBoundsInOwner) ifNotNil: [ :fullBoundsInOwner | - ^fullBoundsInOwner ]. - - ^self setProperty: #fullBoundsInOwner toValue: self findFullBoundsInOwner.! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/29/2021 17:39:50' prior: 50619472! - morphExtentInOwner - - self morphExtent ifNotNil: [ :e | - ^ self externalizeDistance: e ]. - ^self fullBoundsInOwner extent! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/29/2021 17:40:09' prior: 50619478! - topLeftInOwner - - ^self fullBoundsInOwner origin! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 10/29/2021 15:23:44' prior: 50594670! - requiresVectorCanvas - "True if we use VectorCanvas protocol, or we are rotated or zoomed. - If False, we can be drawn by BitBltCanvas, and needs to implement: - #morphExtent and #topLeftInOwner" - - ^ true! ! -!MovableMorph methodsFor: 'geometry testing' stamp: 'jmv 10/29/2021 16:34:26' prior: 50594569 overrides: 50594555! - isOrAnyOwnerIsRotated - "True if we or any owner is rotated. - A zoomed widget will answer false, but a rotated one will answer true (even if only - some owner is rotated)." - - ^ location doesNotRotate not or: [ owner notNil and: [ owner isOrAnyOwnerIsRotated ]].! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 10/29/2021 15:05:53' prior: 50541822 overrides: 50621405! - morphExtent - "In our own coordinates!! - nil if unknown." - - ^ extent! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 10/29/2021 15:59:42' prior: 50616341! - grabMorph: aMorph moveUnderHand: moveUnderHand - "Grab the given morph (i.e., add it to this hand and remove it from its current owner). - If moveUnderHand is requested or it seems neccesary anyway, move the grabbed morph under the hand." - - | grabbed positionInHandCoordinates tx bounds | - self releaseMouseFocus. "Break focus" - grabbed _ aMorph. - aMorph owner ifNotNil: [ :o | grabbed _ o aboutToGrab: aMorph ]. - grabbed ifNil: [ ^ self ]. - grabbed _ grabbed aboutToBeGrabbedBy: self. - grabbed ifNil: [ ^ self ]. - self hideHardwareCursor. - self redrawNeeded. - - moveUnderHand ifTrue: [ - bounds _ nil. - grabbed isInWorld ifTrue: [ - grabbed displayBounds ifNotNil: [ :r | - bounds _ r translatedBy: grabbed morphPositionInWorld negated ]]. - bounds ifNil: [ bounds _ grabbed fullBoundsInOwner ]. - positionInHandCoordinates _ (bounds center + bounds bottomRight //2) negated. - self grabMorph: grabbed delta: positionInHandCoordinates. - ^self ]. - - positionInHandCoordinates _ (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) - morphPositionInWorld - self morphPositionInWorld. - - tx _ GeometryTransformation identity. - (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) withAllOwnersDo: [ :o | - tx _ o location composedWith: tx ]. - self withAllOwnersReverseDo: [ :o | - tx _ o location inverseTransformation composedWith: tx ]. - self grabMorph: grabbed delta: positionInHandCoordinates. - - grabbed location: tx.! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 10/29/2021 15:05:28' prior: 50545932 overrides: 50621405! - morphExtent - "In our own coordinates!! - nil if unknown." - - ^ extent! ! -!HierarchicalListMorph methodsFor: 'selection' stamp: 'jmv 10/29/2021 17:38:15' prior: 50618644 overrides: 16889986! - scrollSelectionIntoView - - | r | - selectedMorph ifNotNil: [ - r _ scroller externalizeBoundingRectOf: selectedMorph fullBoundsInOwner. - self scrollToShow: r ]! ! - -WidgetMorph removeSelector: #morphExtentInOwner! - -!methodRemoval: WidgetMorph #morphExtentInOwner stamp: 'Install-4958-BoundsFindingRefactor-JuanVuletich-2021Oct29-17h44m-jmv.001.cs.st 11/2/2021 10:27:39'! -morphExtentInOwner - - ^self externalizeDistance: extent! - -WidgetMorph removeSelector: #findFullBoundsInOwner! - -!methodRemoval: WidgetMorph #findFullBoundsInOwner stamp: 'Install-4958-BoundsFindingRefactor-JuanVuletich-2021Oct29-17h44m-jmv.001.cs.st 11/2/2021 10:27:39'! -findFullBoundsInOwner - "Find and answer full bounds in whatever owner. - These might not equal #displayFullBounds at all!! - Note: Answers an integer rectangle" - - self requiresVectorCanvas ifTrue: [ - ^super findFullBoundsInOwner ]. - - "#morphExtent exists, and it is also valid in owner, because #requiresVectorCanvas is false." - ^(self morphPosition extent: self morphExtent) encompassingIntegerRectangle.! - -KernelMorph removeSelector: #morphExtentInOwner! - -!methodRemoval: KernelMorph #morphExtentInOwner stamp: 'Install-4958-BoundsFindingRefactor-JuanVuletich-2021Oct29-17h44m-jmv.001.cs.st 11/2/2021 10:27:39'! -morphExtentInOwner - - ^self externalizeDistance: extent! - -KernelMorph removeSelector: #findFullBoundsInOwner! - -!methodRemoval: KernelMorph #findFullBoundsInOwner stamp: 'Install-4958-BoundsFindingRefactor-JuanVuletich-2021Oct29-17h44m-jmv.001.cs.st 11/2/2021 10:27:39'! -findFullBoundsInOwner - "Find and answer full bounds in whatever owner. - These might not equal #displayFullBounds at all!! - Note: Answers an integer rectangle" - - self requiresVectorCanvas ifTrue: [ - ^super findFullBoundsInOwner ]. - - "#morphExtent exists, and it is also valid in owner, because #requiresVectorCanvas is false." - ^(self morphPosition extent: self morphExtent) encompassingIntegerRectangle.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4958-BoundsFindingRefactor-JuanVuletich-2021Oct29-17h44m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4958] on 31 October 2021 at 7:13:13 pm'! -!InnerTextMorph commentStamp: '' prior: 16855377! - InnerTextMorphs support display of text with emphasis. They also support reasonable text-editing capabilities, as well as embedded hot links, and the ability to embed submorphs in the text. They are 'bare' in the sense that they can not clip contents to some window, or scroll it by themselves. - -Text display is clipped to the innerBounds of the rectangle, and text composition is normally performed within a rectangle which is innerBounds inset by the margins parameter. - -Comment about Shout specifics: ------------------------------------------ - -In order to colour the text, I use an instance of SHTextStylerST80, which I store in my 'styler' instance variable. - -When my setText: method is called, I use my styler to ... - a) optionally set all assignments to ansi or leftArrow. - b) Colour my text (immediately, if the text is less than 4096 chars in length, or in a backgroundProcess otherwise) - - When my text is changed, my hasUnacceptedEdits: method is called with true, and I ask my styler to re-colour my text. This is performed in a background process so that typing remains responsive regardless of the length of the text. - - Just before my styler is about to format/style the text, I send #stylerAboutToStyle: to my model. This gives my model a chance to veto the styling (by answering false), or to initialize the styler with information it needs in order to parse the text correctly (e.g. the class to which a method belongs, or the workspace in which I am contained). - - My styler informs me that it has finished styling by triggering the #shoutStyled event which I handle. I then update the textAttributes of my text and refresh the display. - - My 'unstyledAcceptText' instance variable is used in conjunction with my #acceptTextInModel and #correctFrom:to:with: methods to ensure that when my text is modified during a method compilation (removing unused vars etc), I do not lose those changes.! -!Morph methodsFor: 'testing' stamp: 'jmv 10/31/2021 19:06:51'! - drawsKeyboardFocusIndicator - - ^false! ! -!PluggableScrollPane methodsFor: 'testing' stamp: 'jmv 10/31/2021 19:05:16' overrides: 50621737! - drawsKeyboardFocusIndicator - - ^drawKeyboardFocusIndicator! ! -!InnerTextMorph methodsFor: 'editing' stamp: 'jmv 10/31/2021 19:07:57' prior: 50454564! - acceptContents - "The message is sent when the user hits return or Cmd-S. - Accept the current contents and end editing." - "Inform the model of text to be accepted, and return true if OK." - - | accepted prevSelection prevScrollValue | - - prevSelection _ self editor selectionInterval copy. - prevScrollValue _ owner verticalScrollBar scrollValue. - - hasUnacceptedEdits ifFalse: [ self flash. ^true ]. - hasEditingConflicts ifTrue: [ - self confirmAcceptAnyway ifFalse: [self flash. ^false]]. - - accepted _ model acceptContentsFrom: owner. - "During the step for the browser, updatePaneIfNeeded is called, and - invariably resets the contents of the code-holding PluggableTextMorph - at that time, resetting the cursor position and scroller in the process. - The following line forces that update without waiting for the step, - then restores the cursor and scrollbar" - - "some implementors of acceptContentsFrom: answer self :(" - ^accepted == true - ifTrue: [ - model refetch. - self editor selectFrom: prevSelection first to: prevSelection last. - UISupervisor whenUIinSafeState: [ - self world ifNotNil: [ :w | w activeHand newKeyboardFocus: self ]. - (owner is: #ScrollPane) ifTrue: [ - owner verticalScrollBar internalScrollValue: prevScrollValue]]. - true] - ifFalse: [ false ]! ! -!InnerTextMorph methodsFor: 'events' stamp: 'jmv 10/31/2021 18:16:36' prior: 16855688! - clickAndHalf: aMouseButtonEvent localPosition: localEventPosition - - self handleInteraction: [ - editor clickAndHalf ]. - (owner is: #ScrollPane) ifTrue: [ - owner scrollSelectionIntoView ].! ! -!InnerTextMorph methodsFor: 'events' stamp: 'jmv 10/31/2021 18:16:42' prior: 16855695! - doubleClickAndHalf: aMouseButtonEvent localPosition: localEventPosition - - self handleInteraction: [ - editor doubleClickAndHalf ]. - (owner is: #ScrollPane) ifTrue: [ - owner scrollSelectionIntoView ].! ! -!InnerTextMorph methodsFor: 'events' stamp: 'jmv 10/31/2021 18:17:07' prior: 16855756 overrides: 16874556! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - - super mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition. - self pauseBlinking. - self handleInteraction: [ editor mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition ]. - (owner is: #ScrollPane) ifTrue: [ - owner scrollSelectionIntoView ]! ! -!InnerTextMorph methodsFor: 'events' stamp: 'jmv 10/31/2021 18:17:20' prior: 16855768 overrides: 16874651! - mouseMove: aMouseMoveEvent localPosition: localEventPosition - - aMouseMoveEvent mouseButton1Pressed ifFalse: [ - ^ self enterClickableRegion: aMouseMoveEvent localPosition: localEventPosition ]. - self handleInteraction: [ - editor mouseMove: aMouseMoveEvent localPosition: localEventPosition]. - (owner is: #ScrollPane) ifTrue: [ - owner scrollSelectionIntoView ].! ! -!InnerTextMorph methodsFor: 'event handling' stamp: 'jmv 10/31/2021 19:04:30' prior: 50601547 overrides: 50590269! - keyboardFocusChange: aBoolean - - "The message is sent to a morph when its keyboard focus changes. - The given argument indicates that the receiver is gaining (versus losing) the keyboard focus. - In this case, all we need to do is to redraw border feedback" - aBoolean - ifTrue: [ - "A hand is wanting to send us characters..." - editor ifNil: [ self editor storeSelectionInComposition ]. "Forces install" - self showsBlinkingCursor ifTrue: [ - editor hasSelection ifFalse: [ - self startBlinking ]]] - ifFalse: [ self stopBlinking ]. - - (owner notNil and: [ owner drawsKeyboardFocusIndicator ]) - ifTrue: [ owner redrawNeeded ] - ifFalse: [ - "Selection might be shown differently when focused" - self textComposition selectionRects do: [ :r | self invalidateLocalRect: r ]] .! ! -!InnerTextMorph methodsFor: 'event handling' stamp: 'jmv 10/31/2021 18:18:44' prior: 50564587! - processKeystrokeEvent: evt - | action | - - (acceptOnCR and: [evt isReturnKey]) ifTrue: [^ self acceptContents]. - - self pauseBlinking. - - "Return - check for special action" - evt isReturnKey ifTrue: [ - action _ self crAction. - action ifNotNil: [ ^action value]]. - - "Esc - check for special action" - evt isEsc ifTrue: [ - action _ self escAction. - action ifNotNil: [ ^action value]]. - - self handleInteraction: [ editor processKeystrokeEvent: evt ]. - (owner is: #ScrollPane) ifTrue: [ - owner scrollSelectionIntoView ].! ! -!InnerTextMorph methodsFor: 'geometry' stamp: 'jmv 10/31/2021 18:15:57' prior: 50617558 overrides: 50556356! - extentChanged: oldExtent - "Our extent changed. Reflow text." - super extentChanged: oldExtent. - model ifNotNil: [ - wrapFlag ifTrue: [ - extent x = oldExtent x ifFalse: [ - self resetTextComposition. - self editor recomputeSelection. - (owner is: #ScrollPane) ifTrue: [ - owner - updateScrollBarsBounds; - setScrollDeltas ]]]].! ! -!InnerTextMorph methodsFor: 'private' stamp: 'jmv 10/31/2021 19:09:04' prior: 50556548! - fit - "Adjust my bounds to fit the text. - Required after the text changes, - or if wrapFlag is true and the user attempts to change the extent." - - | newExtent newHeight newWidth oldExtent | - newWidth _ extent x. - "Adjust width only if we don't wrap text to own width!!" - wrapFlag ifFalse: [ - newWidth _ self textComposition usedWidth max: 9 ]. - newHeight _ self textComposition usedHeight max: FontFamily defaultLineSpacing + 2. - newExtent _ newWidth @ newHeight. - extent = newExtent - ifTrue: [ - self redrawNeeded. - "Too conservative: only text composition (because of changes in text or styles, etc) - should cause invalidation. - Try to avoid calling #fit unless needed." - ] - ifFalse: [ - extent = newExtent ifFalse: [ - oldExtent _ extent. - extent _ newExtent. - self extentChanged: oldExtent. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]]. - - (owner is: #ScrollPane) ifTrue: [ - owner innerHeight: newExtent y ].! ! -!InnerTextMorph methodsFor: 'private' stamp: 'jmv 10/31/2021 17:52:28' prior: 50420049! - selectionChanged - - self textComposition selectionRects do: [ :r | self invalidateLocalRect: r ]. - (self showsBlinkingCursor and: [ editor hasSelection not ]) - ifTrue: [ self hasKeyboardFocus ifTrue: [self startBlinking ]] - ifFalse: [ self stopBlinking ]! ! -!InnerTextMorph methodsFor: 'private' stamp: 'jmv 10/31/2021 18:16:05' prior: 50601689! - updateFromTextComposition - "A change has taken place in my textComposition, as a result of editing and I must be updated. " - - textComposition ifNotNil: [ - editor storeSelectionInComposition. - needsFit ifTrue: [ - self fit. - needsFit _ false ]]. - - (owner is: #ScrollPane) ifTrue: [ - owner - updateScrollBarsBounds; - setScrollDeltas ].! ! -!InnerTextMorph methodsFor: 'notifications' stamp: 'jmv 10/31/2021 19:07:36' prior: 50449809! - possiblyChanged - | embeddedMorphs | - embeddedMorphs _ model actualContents embeddedMorphs. - self submorphsDo: [:each| - (embeddedMorphs includes: each) ifFalse: [ - self privateRemove: each. - each privateOwner: nil ]]. - embeddedMorphs do: [ :each| - each owner == self ifFalse: [ - self addMorphFront: each. - each hide "Show it only when properly located"]]. - (owner is: #ScrollPane) ifTrue: [ - owner possiblyChanged ]! ! -!InnerTextMorph methodsFor: 'shout' stamp: 'jmv 10/31/2021 18:18:53' prior: 50556764! - stylerStyled - - model allowStylingWithEmphasis ifTrue: [ - self textComposition composeAll ]. - self editor recomputeSelection. - self updateFromTextComposition. - self editor blinkParen. - (owner is: #ScrollPane) ifTrue: [ - owner scrollSelectionIntoView ].! ! - -TextModelMorph removeSelector: #drawKeyboardFocusIndicator! - -!methodRemoval: TextModelMorph #drawKeyboardFocusIndicator stamp: 'Install-4959-InnerTextMorph-tweaks-JuanVuletich-2021Oct31-19h12m-jmv.001.cs.st 11/2/2021 10:27:39'! -drawKeyboardFocusIndicator - "For InnerTextMorph" - - ^drawKeyboardFocusIndicator! - -InnerTextMorph removeSelector: #scrollSelectionIntoView! - -!methodRemoval: InnerTextMorph #scrollSelectionIntoView stamp: 'Install-4959-InnerTextMorph-tweaks-JuanVuletich-2021Oct31-19h12m-jmv.001.cs.st 11/2/2021 10:27:39'! -scrollSelectionIntoView - - (owner is: #ScrollPane) ifTrue: [ - owner scrollSelectionIntoView ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4959-InnerTextMorph-tweaks-JuanVuletich-2021Oct31-19h12m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4958] on 31 October 2021 at 7:16:14 pm'! - -WidgetMorph subclass: #ReadOnlyTextMorph - instanceVariableNames: 'contents wrapFlag textComposition editor mutex needsFit' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #ReadOnlyTextMorph category: 'Morphic-Widgets' stamp: 'Install-4960-ReadOnlyTextMorph-JuanVuletich-2021Oct31-19h13m-jmv.001.cs.st 11/2/2021 10:27:39'! -WidgetMorph subclass: #ReadOnlyTextMorph - instanceVariableNames: 'contents wrapFlag textComposition editor mutex needsFit' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! -!ReadOnlyTextMorph commentStamp: 'jmv 10/31/2021 18:56:35' prior: 0! - ReadOnlyTextMorph support display of text with emphasis. Very much like InnerTextMorph, but doesn't allow editing. Doesn't have a model. Contents can be set directly. It can be used on its own, no need to include them in some kind of TextModelMorph / ScrollPane. - -Clipping to extent is done, and word wrap is optional. Support all features of Text, including fonts, sizes, emphasis and embedded morphs. - -Text display is clipped to the innerBounds of the rectangle, and text composition is normally performed within a rectangle which is innerBounds inset by the margins parameter. - - -(ReadOnlyTextMorph contents: 'Hello -World!!') openInWorld. - - -(ReadOnlyTextMorph contents: Utilities defaultTextEditorContents) openInWorld. - - -t := ReadOnlyTextMorph contents: Utilities defaultTextEditorContents. -s := PluggableScrollPane new. -s scroller: t. -s openInWorld.! -!Text methodsFor: 'TextModel compatibility' stamp: 'jmv 10/31/2021 18:33:45'! - actualContents - ^self! ! -!Text methodsFor: 'TextModel compatibility' stamp: 'jmv 10/31/2021 18:33:52'! - textSize - ^self size! ! -!ReadOnlyTextMorph methodsFor: 'accessing' stamp: 'jmv 10/31/2021 18:45:21'! - contents: aTextOrString - contents _ aTextOrString asText. - self releaseEditorAndTextComposition. "So the model is properly set on the editor and the text composition"! ! -!ReadOnlyTextMorph methodsFor: 'accessing' stamp: 'jmv 10/31/2021 18:45:36'! - contents: aTextOrString wrappedTo: width - "Accept new text contents. Lay it out, wrapping to width. - Then fit my height to the result." - | newExtent oldExtent | - wrapFlag _ true. - contents _ aTextOrString asText. - newExtent _ width truncated@extent y. - extent = newExtent ifFalse: [ - oldExtent _ extent. - extent _ newExtent. - self extentChanged: oldExtent. - self someSubmorphPositionOrExtentChanged. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]. - self contents: aTextOrString! ! -!ReadOnlyTextMorph methodsFor: 'accessing' stamp: 'jmv 10/31/2021 18:45:10'! - contentsAsIs: aTextOrString - "Accept new text contents with line breaks only as in the text. - Fit my width and height to the result." - wrapFlag _ false. - contents _ aTextOrString asText.! ! -!ReadOnlyTextMorph methodsFor: 'accessing' stamp: 'jmv 10/31/2021 17:33:03'! - editor - "Return my current editor, or install a new one." - editor ifNil: [ self installEditorAndTextComposition ]. - ^editor! ! -!ReadOnlyTextMorph methodsFor: 'accessing' stamp: 'jmv 10/31/2021 17:33:03'! - isWrapped - - ^wrapFlag! ! -!ReadOnlyTextMorph methodsFor: 'accessing' stamp: 'jmv 10/31/2021 17:33:03'! - textColor - - ^ color! ! -!ReadOnlyTextMorph methodsFor: 'accessing' stamp: 'jmv 10/31/2021 17:33:03'! - textColor: aColor - - color = aColor ifTrue: [^ self]. - color _ aColor. - self redrawNeeded! ! -!ReadOnlyTextMorph methodsFor: 'accessing' stamp: 'jmv 10/31/2021 17:33:03'! - wrapFlag: aBoolean - "Change whether contents are wrapped to the container." - - aBoolean == wrapFlag ifTrue: [^ self]. - wrapFlag _ aBoolean. - - "Compose my text to fit my bounds." - self resetTextComposition. - self editor recomputeSelection. - self updateFromTextComposition ! ! -!ReadOnlyTextMorph methodsFor: 'caching' stamp: 'jmv 10/31/2021 17:33:03' overrides: 50590255! - releaseCachedState - - super releaseCachedState. - self releaseEditorAndTextComposition. -! ! -!ReadOnlyTextMorph methodsFor: 'drawing' stamp: 'jmv 10/31/2021 17:33:03'! - debugDrawLineRectsOn: aCanvas - "Shows where text line rectangles are" - - self textComposition lines do: [ :line | - aCanvas - frameRectangle: line rectangle - borderWidth: 1 - color: `Color brown` ] -! ! -!ReadOnlyTextMorph methodsFor: 'drawing' stamp: 'jmv 10/31/2021 18:11:09' overrides: 50596573! - drawOn: aCanvas - "Draw the receiver on a canvas" - - false ifTrue: [ self debugDrawLineRectsOn: aCanvas ]. "show line rects for debugging" - - aCanvas - textComposition: self textComposition - bounds: self morphLocalBounds - color: color - selectionColor: (Theme current textHighlightFocused: self hasKeyboardFocus).! ! -!ReadOnlyTextMorph methodsFor: 'editing' stamp: 'jmv 10/31/2021 18:00:39'! - acceptOnCR - "Answer whether the receiver wants to accept when the Return key is hit" - - ^ false! ! -!ReadOnlyTextMorph methodsFor: 'editing' stamp: 'jmv 10/31/2021 17:33:03'! - enterClickableRegion: aMorphicEvent localPosition: localEventPosition -! ! -!ReadOnlyTextMorph methodsFor: 'editing' stamp: 'jmv 10/31/2021 17:33:03'! - handleInteraction: interactionBlock - "Perform the changes in interactionBlock, noting any change in selection - and possibly a change in the composition" - - self selectionChanged. "Note old selection" - - interactionBlock value. - - self selectionChanged. "Note new selection" - self updateFromTextComposition! ! -!ReadOnlyTextMorph methodsFor: 'events' stamp: 'jmv 10/31/2021 18:11:31'! - clickAndHalf: aMouseButtonEvent localPosition: localEventPosition - - self handleInteraction: [ - editor clickAndHalf ]. - (owner is: #ScrollPane) ifTrue: [ - owner scrollSelectionIntoView ].! ! -!ReadOnlyTextMorph methodsFor: 'events' stamp: 'jmv 10/31/2021 18:11:22'! - doubleClickAndHalf: aMouseButtonEvent localPosition: localEventPosition - - self handleInteraction: [ - editor doubleClickAndHalf ]. - (owner is: #ScrollPane) ifTrue: [ - owner scrollSelectionIntoView ].! ! -!ReadOnlyTextMorph methodsFor: 'events' stamp: 'jmv 10/31/2021 17:38:05' overrides: 50449239! - keyStroke: aKeyboardEvent - - (self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - - self processKeystrokeEvent: aKeyboardEvent. - - super keyStroke: aKeyboardEvent! ! -!ReadOnlyTextMorph methodsFor: 'events' stamp: 'jmv 10/31/2021 17:33:03' overrides: 16874541! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - "Make this TextMorph be the keyboard input focus, if it isn't already, - and repond to the text selection gesture." - - "If we don't focus, Get focus, and do nothing else (the user will need to click again to do further interaction)" - self hasKeyboardFocus ifFalse: [ - ^aMouseButtonEvent hand newKeyboardFocus: self]. - - super mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition. - - self handleInteraction: [ editor mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition ]. - - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: nil - clkNHalf: #clickAndHalf:localPosition: - dblClkSel: nil - dblClkNHalfSel: #doubleClickAndHalf:localPosition: - tripleClkSel: nil! ! -!ReadOnlyTextMorph methodsFor: 'events' stamp: 'jmv 10/31/2021 18:09:10' overrides: 16874556! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - - super mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition. - self handleInteraction: [ editor mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition ]. - (owner is: #ScrollPane) ifTrue: [ - owner scrollSelectionIntoView ]! ! -!ReadOnlyTextMorph methodsFor: 'events' stamp: 'jmv 10/31/2021 18:17:17' overrides: 16874651! - mouseMove: aMouseMoveEvent localPosition: localEventPosition - - aMouseMoveEvent mouseButton1Pressed ifFalse: [ - ^ self enterClickableRegion: aMouseMoveEvent localPosition: localEventPosition ]. - self handleInteraction: [ - editor mouseMove: aMouseMoveEvent localPosition: localEventPosition]. - (owner is: #ScrollPane) ifTrue: [ - owner scrollSelectionIntoView ].! ! -!ReadOnlyTextMorph methodsFor: 'event handling testing' stamp: 'jmv 10/31/2021 18:58:59'! - disablesEditing - ^ true! ! -!ReadOnlyTextMorph methodsFor: 'event handling testing' stamp: 'jmv 10/31/2021 17:33:03' overrides: 16874712! - handlesKeyboard - - ^self visible! ! -!ReadOnlyTextMorph methodsFor: 'event handling testing' stamp: 'jmv 10/31/2021 17:33:03' overrides: 16874721! - handlesMouseDown: aMouseButtonEvent - ^ true! ! -!ReadOnlyTextMorph methodsFor: 'event handling' stamp: 'jmv 10/31/2021 18:09:56' overrides: 50590269! - keyboardFocusChange: aBoolean - - "The message is sent to a morph when its keyboard focus changes. - The given argument indicates that the receiver is gaining (versus losing) the keyboard focus. - In this case, all we need to do is to redraw border feedback" - aBoolean - ifTrue: [ - "A hand is wanting to send us characters..." - editor ifNil: [ self editor storeSelectionInComposition ]. "Forces install" - ]. - - "Selection might be shown differently when focused" - self textComposition selectionRects do: [ :r | self invalidateLocalRect: r ].! ! -!ReadOnlyTextMorph methodsFor: 'event handling' stamp: 'jmv 10/31/2021 18:18:48'! - processKeystrokeEvent: evt - - self handleInteraction: [ editor processKeystrokeEvent: evt ]. - (owner is: #ScrollPane) ifTrue: [ - owner scrollSelectionIntoView ].! ! -!ReadOnlyTextMorph methodsFor: 'events-processing' stamp: 'jmv 10/31/2021 17:33:03' overrides: 50563070! - processKeystroke: aKeyboardEvent - "System level event handling." - - aKeyboardEvent wasHandled ifTrue:[^self]. - self handlesKeyboard ifFalse: [^ self]. - aKeyboardEvent wasHandled: true. - self keyStroke: aKeyboardEvent! ! -!ReadOnlyTextMorph methodsFor: 'events-processing' stamp: 'jmv 10/31/2021 17:33:03' overrides: 16875055! - processMouseMove: aMouseMoveEvent localPosition: localEventPosition - "Re-implemented to allow for mouse-up move events" - - aMouseMoveEvent wasHandled ifTrue: [ ^self ]. "not interested" - aMouseMoveEvent hand hasSubmorphs ifTrue: [ ^self ]. - aMouseMoveEvent wasHandled: true. - self mouseMove: aMouseMoveEvent localPosition: localEventPosition. - (aMouseMoveEvent anyButtonPressed and: [ self hasMouseFocus ]) ifFalse: [ ^self ]. - (self handlesMouseStillDown: aMouseMoveEvent) ifTrue:[ - "Step at the new location" - self startStepping: #processMouseStillDown stepTime: 1]! ! -!ReadOnlyTextMorph methodsFor: 'geometry' stamp: 'jmv 10/31/2021 18:55:58' overrides: 50617271! - adjustExtent -"So far, copied verbatim from InnerTextMorph." - "This is just a suggestion. If we do wordwrap, the width will be honored. - But the height is whatever is appropriate for the contents!! See #fit" - self morphExtent: owner viewableExtent! ! -!ReadOnlyTextMorph methodsFor: 'geometry' stamp: 'jmv 10/31/2021 18:38:13' overrides: 50556356! - extentChanged: oldExtent - "Our extent changed. Reflow text." - super extentChanged: oldExtent. - contents ifNotNil: [ - wrapFlag ifTrue: [ - extent x = oldExtent x ifFalse: [ - self resetTextComposition. - self editor recomputeSelection. - (owner is: #ScrollPane) ifTrue: [ - owner - updateScrollBarsBounds; - setScrollDeltas ]]]].! ! -!ReadOnlyTextMorph methodsFor: 'geometry' stamp: 'jmv 10/31/2021 17:33:03' overrides: 50499535! -minimumExtent - - ^(9@(FontFamily defaultLineSpacing+2))! ! -!ReadOnlyTextMorph methodsFor: 'geometry' stamp: 'jmv 10/31/2021 18:55:43' overrides: 50546004! - privateExtent: aPoint - | newExtent | -"So far, copied verbatim from InnerTextMorph." - "Resist changing the extent if no wordwrap. this should be checked." - wrapFlag ifFalse: [ ^ false ]. - - "Just update width. Height is set by ourselves. See #fit" - newExtent _ aPoint x truncated @ extent y. - - ^ super privateExtent: newExtent! ! -!ReadOnlyTextMorph methodsFor: 'initialization' stamp: 'jmv 10/31/2021 17:33:03' overrides: 50545898! - defaultColor - "Return the default fill style for the receiver" - ^ Theme current text! ! -!ReadOnlyTextMorph methodsFor: 'initialization' stamp: 'jmv 10/31/2021 18:22:11' overrides: 50545903! - initialize - super initialize. - wrapFlag _ true. - needsFit _ false.! ! -!ReadOnlyTextMorph methodsFor: 'menu' stamp: 'jmv 10/31/2021 17:33:03' overrides: 16876144! - addCustomMenuItems: aCustomMenu hand: aHandMorph - "Add text-related menu items to the menu" - - super addCustomMenuItems: aCustomMenu hand: aHandMorph. - aCustomMenu - addUpdating: #wrapString - target: self - action: #wrapOnOff! ! -!ReadOnlyTextMorph methodsFor: 'menu' stamp: 'jmv 10/31/2021 17:33:03'! - wrapOnOff - self wrapFlag: wrapFlag not! ! -!ReadOnlyTextMorph methodsFor: 'menu' stamp: 'jmv 10/31/2021 17:33:03'! - wrapString - "Answer the string to put in a menu that will invite the user to - switch word wrap mode" - ^ wrapFlag asMenuItemTextPrefix, - 'text wrap to bounds'! ! -!ReadOnlyTextMorph methodsFor: 'private' stamp: 'jmv 10/31/2021 17:33:03'! - extentForComposing - self flag: #jmvVer2. "like #extent ..." - ^wrapFlag - ifTrue: [ extent x @ 9999999 ] - ifFalse: [ 9999999@9999999 ]! ! -!ReadOnlyTextMorph methodsFor: 'private' stamp: 'jmv 10/31/2021 18:10:34'! - fit - "Adjust my bounds to fit the text. - Required after the text changes, - or if wrapFlag is true and the user attempts to change the extent." - - | newExtent newHeight newWidth oldExtent | - newWidth _ extent x. - "Adjust width only if we don't wrap text to own width!!" - wrapFlag ifFalse: [ - newWidth _ self textComposition usedWidth max: 9 ]. - newHeight _ self textComposition usedHeight max: FontFamily defaultLineSpacing + 2. - newExtent _ newWidth @ newHeight. - extent = newExtent - ifTrue: [ - self redrawNeeded. - "Too conservative: only text composition (because of changes in text or styles, etc) - should cause invalidation. - Try to avoid calling #fit unless needed." - ] - ifFalse: [ - extent = newExtent ifFalse: [ - oldExtent _ extent. - extent _ newExtent. - self extentChanged: oldExtent. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]].! ! -!ReadOnlyTextMorph methodsFor: 'private' stamp: 'jmv 10/31/2021 18:43:02'! - installEditorAndTextComposition - "Install an editor for my textComposition. Install also the textComposition." - | e tc | - - "Editor and TextComposition are assigned here atomically." - e _ TextEditor new morph: self. - e model: contents. - tc _ TextComposition new. - tc showTextCursor: false. - "Keep critical section short" - self mutex critical: [ - editor _ e. - textComposition _ tc. - tc - setModel: contents; - extentForComposing: self extentForComposing. - e textComposition: tc. - tc editor: e ]. - e setEmphasisHereFromText. - tc composeAll. - e resetState. - self fit. - self selectionChanged.! ! -!ReadOnlyTextMorph methodsFor: 'private' stamp: 'jmv 10/31/2021 17:33:03'! - mutex - mutex - ifNil: [ mutex := Mutex new ]. - ^mutex! ! -!ReadOnlyTextMorph methodsFor: 'private' stamp: 'jmv 10/31/2021 17:33:03'! - releaseEditorAndTextComposition - "Editor and TextComposition instantiation is lazy -- they will be created only when needed" - - editor _ nil. - textComposition _ nil! ! -!ReadOnlyTextMorph methodsFor: 'private' stamp: 'jmv 10/31/2021 17:33:03'! - resetTextComposition - textComposition ifNotNil: [ - textComposition - initialize; - extentForComposing: self extentForComposing; - composeAll. - editor storeSelectionInComposition ]. - self fit. - self selectionChanged.! ! -!ReadOnlyTextMorph methodsFor: 'private' stamp: 'jmv 10/31/2021 17:58:57'! - selectionChanged - - self textComposition selectionRects do: [ :r | self invalidateLocalRect: r ].! ! -!ReadOnlyTextMorph methodsFor: 'private' stamp: 'jmv 10/31/2021 17:33:03'! - textComposition - "textComposition instantiation is lazy -- create it only when needed" - textComposition ifNil: [ self installEditorAndTextComposition ]. - ^textComposition! ! -!ReadOnlyTextMorph methodsFor: 'private' stamp: 'jmv 10/31/2021 18:07:27'! - updateFromTextComposition - "A change has taken place in my textComposition, as a result of editing and I must be updated. " - - textComposition ifNotNil: [ - editor storeSelectionInComposition. - needsFit ifTrue: [ - self fit. - needsFit _ false ]]. - - (owner is: #ScrollPane) ifTrue: [ - owner - updateScrollBarsBounds; - setScrollDeltas ].! ! -!ReadOnlyTextMorph methodsFor: 'notifications' stamp: 'jmv 10/31/2021 18:36:09' overrides: 50552865! - fontPreferenceChanged - - super fontPreferenceChanged. - self updateFromTextComposition.! ! -!ReadOnlyTextMorph methodsFor: 'notifications' stamp: 'jmv 10/31/2021 18:49:53'! - possiblyChanged! ! -!ReadOnlyTextMorph methodsFor: 'notifications' stamp: 'jmv 10/31/2021 17:33:03' overrides: 50537666! - someSubmorphPositionOrExtentChanged - "Our extent, or some submorph changed. Must layout submorphs again." - - super someSubmorphPositionOrExtentChanged. - textComposition ifNotNil: [ - textComposition composeAll. - self fit. - self selectionChanged ]! ! -!ReadOnlyTextMorph methodsFor: 'testing' stamp: 'jmv 10/31/2021 18:04:06'! - hasUnacceptedEdits - "No editing supported." - ^false! ! -!ReadOnlyTextMorph methodsFor: 'miscellaneous' stamp: 'jmv 10/31/2021 17:33:03'! - selectAll - "Tell my editor to select all the text" - - self editor selectAll. - self redrawNeeded! ! -!ReadOnlyTextMorph class methodsFor: 'instance creation' stamp: 'jmv 10/31/2021 19:16:08'! - contents: aTextOrString - "See a few more examples in class comment" -" -(ReadOnlyTextMorph contents: 'Hello -World!!') openInWorld -" - - ^ self new contents: aTextOrString.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4960-ReadOnlyTextMorph-JuanVuletich-2021Oct31-19h13m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4960] on 31 October 2021 at 7:42:03 pm'! -!InnerTextMorph methodsFor: 'geometry' stamp: 'jmv 10/31/2021 19:37:38' prior: 50556536 overrides: 50546004! - privateExtent: aPoint - | newExtent | - - newExtent _ aPoint. - (owner is: #ScrollPane) ifTrue: [ - "Resist changing the extent if no wordwrap. this should be checked." - wrapFlag ifFalse: [ ^ false ]. - - "Just update width. Height is set by ourselves. See #fit" - newExtent _ aPoint x truncated @ extent y ]. - - ^ super privateExtent: newExtent! ! -!InnerTextMorph methodsFor: 'private' stamp: 'jmv 10/31/2021 19:41:54' prior: 50621903! - fit - "Adjust my bounds to fit the text. - Required after the text changes, - or if wrapFlag is true and the user attempts to change the extent." - - | newExtent newHeight newWidth oldExtent | - (owner is: #ScrollPane) ifFalse: [ - ^self ]. - - newWidth _ extent x. - "Adjust width only if we don't wrap text to own width!!" - wrapFlag ifFalse: [ - newWidth _ self textComposition usedWidth max: 9 ]. - newHeight _ self textComposition usedHeight max: FontFamily defaultLineSpacing + 2. - newExtent _ newWidth @ newHeight. - extent = newExtent - ifTrue: [ - self redrawNeeded. - "Too conservative: only text composition (because of changes in text or styles, etc) - should cause invalidation. - Try to avoid calling #fit unless needed." - ] - ifFalse: [ - extent = newExtent ifFalse: [ - oldExtent _ extent. - extent _ newExtent. - self extentChanged: oldExtent. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]]. - - (owner is: #ScrollPane) ifTrue: [ - owner innerHeight: newExtent y ].! ! -!ReadOnlyTextMorph methodsFor: 'geometry' stamp: 'jmv 10/31/2021 18:55:58' prior: 50622356 overrides: 50617271! - adjustExtent -"So far, copied verbatim from InnerTextMorph." - "This is just a suggestion. If we do wordwrap, the width will be honored. - But the height is whatever is appropriate for the contents!! See #fit" - self morphExtent: owner viewableExtent! ! -!ReadOnlyTextMorph methodsFor: 'geometry' stamp: 'jmv 10/31/2021 19:37:21' prior: 50622386 overrides: 50546004! - privateExtent: aPoint - | newExtent | -"So far, copied verbatim from InnerTextMorph." - - newExtent _ aPoint. - (owner is: #ScrollPane) ifTrue: [ - "Resist changing the extent if no wordwrap. this should be checked." - wrapFlag ifFalse: [ ^ false ]. - - "Just update width. Height is set by ourselves. See #fit" - newExtent _ aPoint x truncated @ extent y ]. - - ^ super privateExtent: newExtent! ! -!ReadOnlyTextMorph methodsFor: 'private' stamp: 'jmv 10/31/2021 19:41:51' prior: 50622441! - fit - "Adjust my bounds to fit the text. - Required after the text changes, - or if wrapFlag is true and the user attempts to change the extent." - - | newExtent newHeight newWidth oldExtent | - (owner is: #ScrollPane) ifFalse: [ - ^self ]. - - newWidth _ extent x. - "Adjust width only if we don't wrap text to own width!!" - wrapFlag ifFalse: [ - newWidth _ self textComposition usedWidth max: 9 ]. - newHeight _ self textComposition usedHeight max: FontFamily defaultLineSpacing + 2. - newExtent _ newWidth @ newHeight. - extent = newExtent - ifTrue: [ - self redrawNeeded. - "Too conservative: only text composition (because of changes in text or styles, etc) - should cause invalidation. - Try to avoid calling #fit unless needed." - ] - ifFalse: [ - extent = newExtent ifFalse: [ - oldExtent _ extent. - extent _ newExtent. - self extentChanged: oldExtent. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]].! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 10/31/2021 19:34:05' prior: 50570165! - textComposition: aTextComposition bounds: boundsRect color: c selectionColor: sc - | displayScanner leftInRun line possibleVisibleLocalRect textTopLeft | - - textTopLeft _ boundsRect topLeft. - possibleVisibleLocalRect _ currentTransformation boundsOfInverseTransformOf: self clipRect. - - displayScanner _ MorphicScanner new - defaultFont: aTextComposition defaultFont; - text: aTextComposition textComposed - foreground: c. - displayScanner canvas: self. - - leftInRun _ 0. - "Take clipRect into account. Extrememly fast scrolls and redraws of huge files (like .sources)" - (aTextComposition lineIndexForPoint: (possibleVisibleLocalRect topLeft - textTopLeft max: `0@0`) ) - to: (aTextComposition lineIndexForPoint: (possibleVisibleLocalRect bottomRight - textTopLeft min: boundsRect bottomRight)) - do: [ :i | - line _ aTextComposition lines at: i. - aTextComposition - displaySelectionInLine: line - on: self - textTopLeft: textTopLeft - selectionColor: sc. - leftInRun _ displayScanner displayLine: line textTopLeft: textTopLeft leftInRun: leftInRun ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4961-ReadOnlyTextMorph-tweaks-JuanVuletich-2021Oct31-19h34m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4961] on 1 November 2021 at 9:52:29 am'! -!InnerTextMorph methodsFor: 'selection' stamp: 'jmv 7/29/2012 15:12'! - scrollSelectionIntoView - - (owner is: #ScrollPane) ifTrue: [ - owner scrollSelectionIntoView ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4962-FixASlip-JuanVuletich-2021Nov01-09h52m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4962] on 1 November 2021 at 11:42:37 am'! - -WidgetMorph subclass: #TextParagraphMorph - instanceVariableNames: 'textComposition' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #TextParagraphMorph category: 'Morphic-Widgets' stamp: 'Install-4963-TextParagraphMorph-HilaireFernandes-JuanVuletich-2021Nov01-11h39m-jmv.001.cs.st 11/2/2021 10:27:39'! -WidgetMorph subclass: #TextParagraphMorph - instanceVariableNames: 'textComposition' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! -!TextParagraphMorph commentStamp: 'jmv 11/1/2021 09:58:10' prior: 0! - TextParagraphMorph support display of text with emphasis. It can be used on its own, no need to include them in some kind of TextModelMorph / ScrollPane. - -Clipping to extent is done, and word wrap is optional. Support all features of Text, including fonts, sizes, emphasis and embedded morphs. - -Text display is clipped to the innerBounds of the rectangle, and text composition is normally performed within a rectangle which is innerBounds inset by the margins parameter. - - -(TextParagraphMorph contents: 'Hello -World!!') openInWorld. - - -(TextParagraphMorph contents: Utilities defaultTextEditorContents) openInWorld. - - -| t s | -t := TextParagraphMorph contents: Utilities defaultTextEditorContents. -s := PluggableScrollPane new. -s scroller: t. -s openInWorld.! -!TextParagraphMorph methodsFor: 'accessing' stamp: 'hlsf 10/31/2021 19:52:05'! - contents: aStringOrText - textComposition textComposed ~= aStringOrText ifTrue: [ - textComposition - setModel: (TextModel withText: aStringOrText); - composeAll. - extent _ textComposition usedExtent + 8]! ! -!TextParagraphMorph methodsFor: 'initialization' stamp: 'jmv 11/1/2021 10:08:39' overrides: 50545903! - initialize - super initialize. - textComposition _ TextComposition new. - textComposition - setModel: (TextModel withText: ''); - extentForComposing: extent x @ 9999999; - composeAll.! ! -!TextParagraphMorph methodsFor: 'drawing' stamp: 'hlsf 10/31/2021 20:06:11' overrides: 50596573! - drawOn: aCanvas - aCanvas - textComposition: textComposition - bounds: self morphLocalBounds - color: Theme current text - selectionColor: `Color red`.! ! -!TextParagraphMorph methodsFor: 'geometry' stamp: 'hlsf 11/1/2021 11:25:27' overrides: 50617271! - adjustExtent - "This is just a suggestion. If we do wordwrap, the width will be honored. - But the height is whatever is appropriate for the contents!! See #fit" - self morphExtent: owner viewableExtent! ! -!TextParagraphMorph methodsFor: 'geometry' stamp: 'hlsf 11/1/2021 11:29:52' overrides: 50556356! - extentChanged: oldExtent - "Our extent changed. Reflow text." - super extentChanged: oldExtent. - extent x = oldExtent x ifFalse: [ - textComposition - initialize; - extentForComposing: extent x @ 9999999; - composeAll. - self fit. - (owner is: #ScrollPane) ifTrue: [ - owner - updateScrollBarsBounds; - setScrollDeltas ]].! ! -!TextParagraphMorph methodsFor: 'geometry' stamp: 'hlsf 11/1/2021 11:33:19' overrides: 50546004! - privateExtent: aPoint - | newExtent | - - newExtent _ aPoint. - (owner is: #ScrollPane) ifTrue: [ - "We decide our own height" - newExtent _ aPoint x truncated @ extent y ]. - ^ super privateExtent: newExtent! ! -!TextParagraphMorph methodsFor: 'private' stamp: 'hlsf 11/1/2021 11:29:40'! - fit - "Adjust my bounds to fit the text." - - | newExtent oldExtent | - (owner is: #ScrollPane) ifFalse: [ - ^self ]. - - newExtent _ extent x @ (textComposition usedHeight max: FontFamily defaultLineSpacing + 2). - extent = newExtent ifFalse: [ - oldExtent _ extent. - extent _ newExtent. - self extentChanged: oldExtent. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ].! ! -!TextParagraphMorph class methodsFor: 'instance creation' stamp: 'hlsf 10/31/2021 19:58:58'! - contents: aStringOrText - ^ self new - contents: aStringOrText ; - yourself ! ! -!InnerTextMorph methodsFor: 'private' stamp: 'jmv 11/1/2021 11:39:40' prior: 50622608! - fit - "Adjust my bounds to fit the text. - Required after the text changes, - or if wrapFlag is true and the user attempts to change the extent." - - | newExtent newHeight newWidth oldExtent | - (owner is: #ScrollPane) ifFalse: [ - ^self ]. - - newWidth _ extent x. - "Adjust width only if we don't wrap text to own width!!" - wrapFlag ifFalse: [ - newWidth _ self textComposition usedWidth max: 9 ]. - newHeight _ self textComposition usedHeight max: FontFamily defaultLineSpacing + 2. - newExtent _ newWidth @ newHeight. - extent = newExtent - ifTrue: [ - "Too conservative: only text composition (because of changes in text or styles, etc) - should cause invalidation. - Try to avoid calling #fit unless needed." - self redrawNeeded ] - ifFalse: [ - oldExtent _ extent. - extent _ newExtent. - self extentChanged: oldExtent. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]. - - (owner is: #ScrollPane) ifTrue: [ - owner innerHeight: newExtent y ].! ! - -Text removeSelector: #textSize! - -!methodRemoval: Text #textSize stamp: 'Install-4963-TextParagraphMorph-HilaireFernandes-JuanVuletich-2021Nov01-11h39m-jmv.001.cs.st 11/2/2021 10:27:39'! -textSize - ^self size! - -Text removeSelector: #actualContents! - -!methodRemoval: Text #actualContents stamp: 'Install-4963-TextParagraphMorph-HilaireFernandes-JuanVuletich-2021Nov01-11h39m-jmv.001.cs.st 11/2/2021 10:27:39'! -actualContents - ^self! - -Smalltalk removeClassNamed: #ReadOnlyTextMorph! - -!classRemoval: #ReadOnlyTextMorph stamp: 'Install-4963-TextParagraphMorph-HilaireFernandes-JuanVuletich-2021Nov01-11h39m-jmv.001.cs.st 11/2/2021 10:27:39'! -WidgetMorph subclass: #ReadOnlyTextMorph - instanceVariableNames: 'contents wrapFlag textComposition editor mutex needsFit' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4963-TextParagraphMorph-HilaireFernandes-JuanVuletich-2021Nov01-11h39m-jmv.001.cs.st----! - -----QUIT----(2 November 2021 10:27:44) Cuis5.0-4963-32.image priorSource: 9134877! - -----STARTUP---- (23 November 2021 10:53:58) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4963-32.image! - - -'From Cuis 5.0 [latest update: #4913] on 3 November 2021 at 7:32:45 pm'! -!ExtractAsParameter class methodsFor: 'instance creation' stamp: 'HAW 11/3/2021 19:11:04'! - addParameterClass - - "This method is important for LiveTyping parameterization. Do not remove - Hernan" - ^ AddParameter! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 11/3/2021 19:09:24' prior: 50610101! - assertIsValidKeywordForNewParameter: aNewKeyword - - self addParameterClass assertIsValidKeywordForNewParameter: aNewKeyword! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 11/3/2021 19:09:24' prior: 50610128! - assertIsValidParameterName: aName - - self addParameterClass assertIsValidParameterName: aName ! ! -!ExtractAsParameter class methodsFor: 'instance creation' stamp: 'HAW 11/3/2021 19:09:24' prior: 50611221! - named: aNewParameter - extractedFromAll: intervals - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - - ^self - assertAndCreateNamed: aNewParameter - extractedFromAll: intervals - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - creatingAddParameterWith: [ :sourceCodeToExtract | - self addParameterClass - named: aNewParameter - initializedWith: sourceCodeToExtract - toUnarySelector: aSourceMethod selector - implementors: implementorsCollection - senders: sendersCollection ]! ! -!ExtractAsParameter class methodsFor: 'instance creation' stamp: 'HAW 11/3/2021 19:09:24' prior: 50611242! - named: aNewParameter - extractedFromAll: intervals - at: aNewKeywordIndex - newKeyword: newKeyword - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - - ^self - assertAndCreateNamed: aNewParameter - extractedFromAll: intervals - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - creatingAddParameterWith: [ :sourceCodeToExtract | - self addParameterClass - named: aNewParameter - at: aNewKeywordIndex - initializedWith: sourceCodeToExtract - using: newKeyword - toKeywordSelector: aSourceMethod selector - implementors: implementorsCollection - senders: sendersCollection ]! ! -!ExtractAsParameter class methodsFor: 'implementors and senders' stamp: 'HAW 11/3/2021 19:09:24' prior: 50610292! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders forClassAndMetaOf: aPotentialClassToRefactor - - ^self addParameterClass addImplementorsOf: anOldSelector to: implementors andSendersTo: senders forClassAndMetaOf: aPotentialClassToRefactor! ! -!ExtractAsParameter class methodsFor: 'implementors and senders' stamp: 'HAW 11/3/2021 19:09:24' prior: 50610303! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategoriesAndHierarchyOf: aClass organizedBy: anOrganization - - ^self addParameterClass addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategoriesAndHierarchyOf: aClass organizedBy: anOrganization! ! -!ExtractAsParameter class methodsFor: 'implementors and senders' stamp: 'HAW 11/3/2021 19:09:24' prior: 50610316! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategory: aCategory organizedBy: anOrganization - - ^self addParameterClass addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategory: aCategory organizedBy: anOrganization! ! -!ExtractAsParameter class methodsFor: 'implementors and senders' stamp: 'HAW 11/3/2021 19:09:24' prior: 50610328! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inHierarchyOf: aClass - - ^self addParameterClass addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inHierarchyOf: aClass -! ! -!ExtractAsParameter class methodsFor: 'implementors and senders' stamp: 'HAW 11/3/2021 19:09:24' prior: 50610338! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inSystem: aSystem - - ^self addParameterClass addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inSystem: aSystem -! ! -!ChangeSelectorApplier class methodsFor: 'instance creation' stamp: 'HAW 1/1/2020 21:54:30' prior: 50491651! - on: aBrowser for: aSelector in: aSelectedClass - - self assertCanApplyRefactoringFor: aSelector in: aSelectedClass. - - ^self new initializeOn: aBrowser for: aSelector in: aSelectedClass - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4964-ExtractAsParameterLiveTypingSupport-HernanWilkinson-2021Nov03-18h17m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4964] on 4 November 2021 at 10:18:21 am'! -!SmalltalkCompleterMorph methodsFor: 'selector documentation' stamp: 'HAW 11/4/2021 10:17:50' prior: 50528736! - initializeSelectorDocumentation - - selectorDocumentation := TextModelMorph withText: ''. - selectorDocumentation innerTextMorph - acceptOnCR: false; - crAction: [ self crPressedOnSelectorDocumentation ]. - - selectorDocumentation - wrapFlag: true; - borderColor: Color black; - borderWidth: 1; - disableEditing; - openInWorld - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4965-SmalltalkCompleterMorphDocumentationFix-HernanWilkinson-2021Nov04-10h17m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4965] on 4 November 2021 at 4:49:32 pm'! -!HierarchicalListMorph methodsFor: 'geometry' stamp: 'jmv 11/4/2021 15:52:51' overrides: 50617612! - someSubmorphPositionOrExtentChanged - "Our extent, or some submorph changed. Must layout submorphs again." - - self layoutNeeded: true. - self updateScrollBarsBounds! ! -!PluggableListMorph methodsFor: 'geometry' stamp: 'jmv 11/4/2021 15:52:17' overrides: 50617612! - someSubmorphPositionOrExtentChanged - "Our extent, or some submorph changed. Must layout submorphs again." - - self layoutNeeded: true. - self updateScrollBarsBounds! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4966-FixRecentSlowdownInListMorphs-JuanVuletich-2021Nov04-16h48m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4965] on 4 November 2021 at 5:14:49 pm'! -!HoverHelpMorph methodsFor: 'accessing' stamp: 'jmv 11/4/2021 17:11:01'! - contents: aString wrappedTo: wordWrapWidthOrNil - "If wordWrapWidthOrNil is nil, don't do wordwrap, and make the morph as wide as needed" - - | width | - contents _ aString. - width _ wordWrapWidthOrNil ifNil: [9999999]. -wordWrapWidthOrNil print. - textComposition _ TextComposition new. - textComposition - setModel: (TextModel withText: contents asText); - extentForComposing: width@9999999. - textComposition composeAll. - self morphExtent: textComposition usedExtent + 8.! ! -!HoverHelpMorph methodsFor: 'accessing' stamp: 'jmv 11/4/2021 17:07:51'! -contentsWrapped: aString - - self contents: aString wrappedTo: FontFamily defaultLineSpacing * 13! ! -!HoverHelpMorph class methodsFor: 'instance creation' stamp: 'jmv 11/4/2021 17:12:39'! - contents: aString wrappedTo: wordWrapWidthOrNil - "Make up and return a HoverHelp for morph. - (HoverHelpMorph contents: 'This is a HoverHelpMorph with a rather long contents to see how it gets wrapped. Is this long enough? Maybe a few more words are in order.' - wrappedTo: 150) openInHand - " - - ^self new contents: aString wrappedTo: wordWrapWidthOrNil! ! -!HoverHelpMorph class methodsFor: 'instance creation' stamp: 'jmv 11/4/2021 17:11:35'! - contentsWrapped: aString - "Make up and return a HoverHelp for morph. - (HoverHelpMorph contentsWrapped: 'This is a HoverHelpMorph with a rather long contents to see how it gets wrapped. Is this long enough? Maybe a few more words are in order.') openInHand - " - - ^self new contentsWrapped: aString! ! -!HoverHelpMorph methodsFor: 'accessing' stamp: 'jmv 11/4/2021 17:13:39' prior: 50616633! - contents: aString - - self contents: aString wrappedTo: nil! ! -!HoverHelpMorph class methodsFor: 'instance creation' stamp: 'jmv 11/4/2021 17:08:47' prior: 16853883! - contents: aString - "Make up and return a HoverHelp for morph. - (HoverHelpMorph contents: 'This is a HoverHelpMorph') openInHand - " - - ^self new contents: aString! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4967-HoverHelpMorph-contents-contentsWrapped-JuanVuletich-2021Nov04-16h49m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4967] on 9 November 2021 at 4:02:16 pm'! -!DateAndTime methodsFor: 'public protocol' stamp: 'jmv 11/9/2021 15:06:18'! - truncateToSeconds - nanos _ 0! ! -!Time class methodsFor: 'primitives' stamp: 'jmv 11/9/2021 14:26:36'! - primUtcWithOffset: arrayOrObjectWithTwoSlots - "The parameter may be a two element array, or an object whose first two instance - variables are expected to be UTC microseconds and seconds offset from GMT. - - First element is set to the number of microseconds since the UTC Posix (Unix) epoch, - i.e. 00:00 on the morning of January 1, 1970, in UTC time. - It might be a LargePositiveInteger (very likely on 32-bit images, very unlikely on 64-bit images). - - Second element is set to current seconds offset from GMT in the local time zone. - - Recent VMs implement this. Older Interpreters might not. - Time primUtcWithOffset: {0. 0} - " - - - ^nil! ! -!DateAndTime class methodsFor: 'ansi protocol' stamp: 'jmv 11/9/2021 15:28:56' prior: 16829159! - now - "Use highest resolution possible. - If called several times, always answer different, increasing values. This means that they can used as TimeStamps - DateAndTime now - " - - | days nanoseconds remainingNanoseconds remainingSeconds utcMicroSsecondsAndOffset | - utcMicroSsecondsAndOffset _ Time primUtcWithOffset: `{ 0. 0}`. - nanoseconds _ (utcMicroSsecondsAndOffset first + (utcMicroSsecondsAndOffset second * 1000000)) * 1000. - (LastTick = nanoseconds) - ifFalse: [ - LastTick _ nanoseconds] - ifTrue: [ - LastTickSemaphore critical: [ - LastTick _ LastTick + 1. - nanoseconds _ LastTick ]]. - - days _ nanoseconds // Time nanosecondsInDay. - remainingNanoseconds _ nanoseconds \\ Time nanosecondsInDay. - remainingSeconds _ remainingNanoseconds // 1000000000. - remainingNanoseconds _ remainingNanoseconds \\ 1000000000. - - ^ self basicNew - setJdn: `DateAndTime unixEpoch julianDayNumber` + days - seconds: remainingSeconds - nano: remainingNanoseconds - offset: (Duration seconds: utcMicroSsecondsAndOffset second)! ! -!DateAndTime class methodsFor: 'instance creation' stamp: 'jmv 11/9/2021 15:06:44' prior: 16829444! - nowUpToSeconds - "Resolution is up to one second. Don't use as a TimeStamp!! - DateAndTime nowUpToSeconds - " - - ^self now truncateToSeconds! ! -!Time class methodsFor: 'ansi protocol' stamp: 'jmv 11/9/2021 15:28:41' prior: 16937541! - now - "Answer a Time representing the time right now - this is a 24 hour clock. - Precision is microsecond." - - | microseconds utcMicroSsecondsAndOffset | - utcMicroSsecondsAndOffset _ Time primUtcWithOffset: `{ 0. 0}`. - microseconds _ (utcMicroSsecondsAndOffset first + (utcMicroSsecondsAndOffset second * 1000000)). - ^ self seconds: (microseconds // 1000000) nanoSeconds: (microseconds \\ 1000000) * 1000.! ! -!Time class methodsFor: 'private' stamp: 'jmv 11/9/2021 15:32:45' prior: 16937705! - currentUtcOffset - " - Time currentUtcOffset - " - ^ DateAndTime now offset! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4968-UseUTCtimePrimitives-JuanVuletich-2021Nov09-15h59m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4967] on 9 November 2021 at 4:30:30 pm'! -!Time class methodsFor: 'primitives' stamp: 'jmv 11/9/2021 15:35:03' prior: 50445613! - primUtcWithOffset - "Answer a two element array. - Prefer #primUtcWithOffset: - - First element is the number of microseconds since the UTC Posix (Unix) epoch, - i.e. 00:00 on the morning of January 1, 1970, in UTC time. - It might be a LargePositiveInteger (very likely on 32-bit images, very unlikely on 64-bit images). - - Second element is the current seconds offset from GMT in the local time zone. - - Recent VMs implement this. Older Interpreters might not. - " - " - Time primUtcWithOffset - Time primUtcWithOffset first / 1000 / 1000 / 60 / 60 / 24 / 365.25 - Time primUtcWithOffset second / 60 / 60.0 - - (Time primUtcWithOffset first / 1000 / 1000 + Time primUtcWithOffset second) / 60 / 60 / 24 / 365.25 - (DateAndTime now - (DateAndTime year: 1970 month: 1 day: 1)) totalSeconds / 60 / 60 / 24 / 365.25 - " - - ^nil! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4969-Tweak-JuanVuletich-2021Nov09-16h29m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4969] on 9 November 2021 at 4:44:26 pm'! -!Time class methodsFor: 'general inquiries' stamp: 'jmv 11/9/2021 16:20:51' prior: 50445434! - localMillisecondClock - "Answer the number of milliseconds since the Smalltalk epoch, - i.e. 00:00 on the morning of January 1, 1901, in the local host time zone. - In other words, the number of microseconds since it was that time in this time zone." - - ^self primLocalMicrosecondClock // 1000! ! -!InputSensor methodsFor: 'keyboard' stamp: 'jmv 11/9/2021 15:37:01' prior: 50555187! - kbdTest - " - Sensor kbdTest - " - "This test routine will print the unmodified character, its keycode, - and the OR of all its modifier bits, until the character x is typed - -Also useful: - Sensor test - " - | char | - char _ nil. - [ char = $x ] whileFalse: [ - [ self keyboardPressed ] whileFalse. - char _ self keyboard. - Display fill: `5@5 extent: 400@50` fillColor: `Color white`. - (String streamContents: [ :s | - s - nextPut: $-; - nextPut: char; - nextPut: $-; - space; - print: char numericValue; - space. - self isMouseButton3Pressed ifTrue: [ s nextPutAll: ' mouseButton3/blue/tertiary/halo ' ]. - self isMouseButton2Pressed ifTrue: [ s nextPutAll: ' mouseButton2/yellow/secondary/menu ' ]. - self isMouseButton1Pressed ifTrue: [ s nextPutAll: ' mouseButton1/red/primary ' ]. - self shiftPressed ifTrue: [ s nextPutAll: ' shift ' ]. - self controlKeyPressed ifTrue: [ s nextPutAll: ' control/ctrl ' ]. - (self primMouseButtons anyMask: 32) ifTrue: [ s nextPutAll: ' macOption ' ]. - self commandAltKeyPressed ifTrue: [ s nextPutAll: ' macCommand/winAlt ' ]. - Time now printOn: s - ]) - displayAt: 10 @ 10 ].! ! - -Time class removeSelector: #primLocalSecondsClock! - -!methodRemoval: Time class #primLocalSecondsClock stamp: 'Install-4970-Cleanup-JuanVuletich-2021Nov09-16h43m-jmv.001.cs.st 11/23/2021 10:54:03'! -primLocalSecondsClock - "Answer the number of seconds since the Smalltalk epoch, - i.e. 00:00 on the morning of January 1, 1901, in the local host time zone. - In other words, the number of seconds since it was that time in this time zone. - Answer is a 32-bit unsigned number. - Answer might be a LargePositiveInteger on 32-bit images. - Note: This is in local time, i.e. the time the system shows to the user. - Essential. See Object documentation whatIsAPrimitive. - - Time primLocalSecondsClock - Time primLocalSecondsClock / 60 / 60 / 24 / 365.25 - - Warning: Will overflow in year 2037 - " - - - self primitiveFailed! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4970-Cleanup-JuanVuletich-2021Nov09-16h43m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4969] on 9 November 2021 at 4:47:58 pm'! -!Time class methodsFor: 'general inquiries' stamp: 'jmv 11/9/2021 16:21:57' prior: 50445396! - localMicrosecondClock - "Answer the number of microseconds since the Smalltalk epoch, - i.e. 00:00 on the morning of January 1, 1901, in the local host time zone. - In other words, the number of microseconds since it was that time in this time zone. - Answer might be a LargePositiveInteger (very likely on 32-bit images, very unlikely on 64-bit images)." - - ^self primLocalMicrosecondClock! ! -!Time class methodsFor: 'general inquiries' stamp: 'jmv 11/9/2021 16:21:30' prior: 50445500! - localSecondClock - "Answer the number of seconds since the Smalltalk epoch, - i.e. 00:00 on the morning of January 1, 1901, in the local host time zone. - In other words, the number of microseconds since it was that time in this time zone." - - ^self primLocalMicrosecondClock // 1000000! ! -!Time class methodsFor: 'primitives' stamp: 'jmv 11/9/2021 16:12:41' prior: 50340831! - primMillisecondClock - "Primitive. Answer the number of milliseconds since the millisecond clock - was last reset or rolled over. No sync to any system clock. - Implemented by all major platforms. - Essential. See Object documentation whatIsAPrimitive. - - Time primMillisecondClock - Time primMillisecondClock / 1000 / 60.0 - - Range is from zero to 16r1FFFFFFF. - The VM defines MillisecondClockMask as 16r1FFFFFFF - - Overflows usually every six days. - " -"Not really a clock, but a timer or ticker" - - - self primitiveFailed! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4971-Cleanup-JuanVuletich-2021Nov09-16h44m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4969] on 9 November 2021 at 4:58:59 pm'! - -Magnitude subclass: #DateAndTime - instanceVariableNames: 'seconds offset jdn nanos ' - classVariableNames: 'LastTick LastTickSemaphore LocalTimeZone ' - poolDictionaries: '' - category: 'Kernel-Chronology'! - -!classDefinition: #DateAndTime category: #'Kernel-Chronology' stamp: 'Install-4972-Remove-TimeZone-JuanVuletich-2021Nov09-16h47m-jmv.001.cs.st 11/23/2021 10:54:03'! -Magnitude subclass: #DateAndTime - instanceVariableNames: 'seconds offset jdn nanos' - classVariableNames: 'LastTick LastTickSemaphore LocalTimeZone' - poolDictionaries: '' - category: 'Kernel-Chronology'! -!DateAndTime class methodsFor: 'squeak protocol' stamp: 'jmv 11/9/2021 16:56:54' prior: 16829255! - localOffset - "Answer the duration we are offset from UTC" - - ^ self now offset! ! -!DateAndTime class methodsFor: 'system startup & shutdown' stamp: 'jmv 11/9/2021 16:57:39' prior: 16829486 overrides: 50510040! - releaseClassCachedState - - LastTickSemaphore _ nil. - LastTick _ nil.! ! -!DateAndTime class methodsFor: 'constants' stamp: 'jmv 11/9/2021 16:54:14' prior: 16829492! - unixEpoch - " - DateAndTime unixEpoch - 1970-01-01T00:00:00+00:00 - - (DateAndTime now - DateAndTime unixEpoch) days / 365.25 - " - ^ self - julianDayNumber: 2440588 - seconds: 0 - nanoseconds: 0 - offset: `Duration zero`.! ! -!Timespan class methodsFor: 'instance creation' stamp: 'jmv 11/9/2021 16:54:23' prior: 50342525! - includingDateAndTime: aDateAndTime - - ^ self starting: aDateAndTime duration: `Duration zero`.! ! -!BlockClosure methodsFor: 'evaluating' stamp: 'jmv 11/9/2021 16:54:33' prior: 16788150! - valueWithin: aDuration onTimeout: timeoutBlock - "Evaluate the receiver. - If the evaluation does not complete in less than aDuration evaluate the timeoutBlock instead" - - | theProcess delay watchdog tag | - - aDuration <= `Duration zero` ifTrue: [^ timeoutBlock value ]. - - "the block will be executed in the current process" - theProcess := Processor activeProcess. - delay := aDuration asDelay. - tag := self. - - "make a watchdog process" - watchdog := [ - delay wait. "wait for timeout or completion" - theProcess ifNotNil:[ theProcess signalException: (TimedOut new tag: tag)] - ] newProcess. - - "Watchdog needs to run at high priority to do its job (but not at timing priority)" - watchdog priority: Processor timingPriority-1. - - "catch the timeout signal" - ^ [ watchdog resume. "start up the watchdog" - self ensure:[ "evaluate the receiver" - theProcess := nil. "it has completed, so ..." - delay delaySemaphore signal. "arrange for the watchdog to exit" - ]] on: TimedOut do: [ :e | - e tag == tag - ifTrue:[ timeoutBlock value ] - ifFalse:[ e pass]].! ! - -DateAndTime class removeSelector: #localTimeZone:! - -!methodRemoval: DateAndTime class #localTimeZone: stamp: 'Install-4972-Remove-TimeZone-JuanVuletich-2021Nov09-16h47m-jmv.001.cs.st 11/23/2021 10:54:03'! -localTimeZone: aTimeZone - "Set the local time zone" - - " - DateAndTime localTimeZone: (TimeZone offset: 0 hours name: 'Universal Time' abbreviation: 'UTC'). - DateAndTime localTimeZone: (TimeZone offset: -8 hours name: 'Pacific Standard Time' abbreviation: 'PST'). - " - - LocalTimeZone := aTimeZone - - -! - -DateAndTime class removeSelector: #localTimeZone! - -!methodRemoval: DateAndTime class #localTimeZone stamp: 'Install-4972-Remove-TimeZone-JuanVuletich-2021Nov09-16h47m-jmv.001.cs.st 11/23/2021 10:54:03'! -localTimeZone - "Answer the local time zone" - - ^ LocalTimeZone ifNil: [ LocalTimeZone _ TimeZone default ] - -! - -DateAndTime removeSelector: #asLocal! - -!methodRemoval: DateAndTime #asLocal stamp: 'Install-4972-Remove-TimeZone-JuanVuletich-2021Nov09-16h47m-jmv.001.cs.st 11/23/2021 10:54:03'! -asLocal - - - ^ (self offset = self class localOffset) - - ifTrue: [self] - ifFalse: [self utcOffset: self class localOffset] -! - -DateAndTime removeSelector: #timeZoneAbbreviation! - -!methodRemoval: DateAndTime #timeZoneAbbreviation stamp: 'Install-4972-Remove-TimeZone-JuanVuletich-2021Nov09-16h47m-jmv.001.cs.st 11/23/2021 10:54:03'! -timeZoneAbbreviation - - ^ self class localTimeZone abbreviation -! - -DateAndTime removeSelector: #timeZoneName! - -!methodRemoval: DateAndTime #timeZoneName stamp: 'Install-4972-Remove-TimeZone-JuanVuletich-2021Nov09-16h47m-jmv.001.cs.st 11/23/2021 10:54:03'! -timeZoneName - - ^ self class localTimeZone name -! - -Magnitude subclass: #DateAndTime - instanceVariableNames: 'seconds offset jdn nanos' - classVariableNames: 'LastTick LastTickSemaphore' - poolDictionaries: '' - category: 'Kernel-Chronology'! - -!classDefinition: #DateAndTime category: #'Kernel-Chronology' stamp: 'Install-4972-Remove-TimeZone-JuanVuletich-2021Nov09-16h47m-jmv.001.cs.st 11/23/2021 10:54:03'! -Magnitude subclass: #DateAndTime - instanceVariableNames: 'seconds offset jdn nanos' - classVariableNames: 'LastTick LastTickSemaphore' - poolDictionaries: '' - category: 'Kernel-Chronology'! - -Smalltalk removeClassNamed: #TimeZone! - -!classRemoval: #TimeZone stamp: 'Install-4972-Remove-TimeZone-JuanVuletich-2021Nov09-16h47m-jmv.001.cs.st 11/23/2021 10:54:03'! -Object subclass: #TimeZone - instanceVariableNames: 'offset abbreviation name' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Chronology'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4972-Remove-TimeZone-JuanVuletich-2021Nov09-16h47m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4972] on 16 November 2021 at 10:56:28 am'! -!StepMessage methodsFor: 'testing' stamp: 'jmv 11/16/2021 10:54:58' prior: 16913955! - stepTime - "Return the step time for this message. If nil, the receiver of the message will be asked for its #stepTime." - ^stepTime ifNil: [ receiver stepTime asInteger ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4973-DontCrashOnNonIntegerStepTimes-JuanVuletich-2021Nov16-10h54m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4973] on 23 November 2021 at 9:37:30 am'! -!EventSensor methodsFor: 'private-I/O' stamp: 'jmv 11/22/2021 22:12:30' prior: 50598187! - processSensorEvent: evt discardingMouseEvents: discardMouseEvents - "Process a single event. This method is run at high priority." - | type | - type _ evt at: 1. - - "Check if the event is a user interrupt" - (type = EventSensor eventTypeKeyboard and: [ (evt at: 4) = 0 and: [ - ((evt at: 3) bitOr: (((evt at: 5) bitAnd: 9) bitShift: 8)) = interruptKey]]) - ifTrue: [ - "interrupt key is meta - not reported as event" - ^interruptSemaphore signal]. - - "Store the event in the queue if there's any" - type = EventSensor eventTypeMouse ifTrue: [ - "Only swap secondary and tertiary buttons if there is no command or option modifier keys. - This swap is done so a 3-button mouse is - left -> mouseButton1 (select) - center -> mouseButton3 (halo) - right -> mouseButton2 (menu). - This is only needed on the Mac, Window VM does this mapping by default. - We avoid ding the swap if there are modifier keys, because in that case the buttons were generated by the VM as follows: - left -> mouseButton1 - macOption + left -> mouseButton3 - command + left -> mouseButton2, - but Mac users are already used to - macOption + left -> menu - command + left -> halo. - See #installMouseDecodeTable" - ((evt at: 6) anyMask: 12) ifFalse: [ - evt at: 5 put: (ButtonDecodeTable at: (evt at: 5) + 1)]]. - - (discardMouseEvents and: [ type = EventSensor eventTypeMouse ]) ifFalse: [ - self queueEvent: evt ]. - - "Update state for InputSensor." - "KLG: Why not `self class` instead of `EventSensor`?" - type = EventSensor eventTypeMouse ifTrue: [ - self processMouseSensorEvent: evt ]. - type = EventSensor eventTypeKeyboard ifTrue: [ - self processKeyboardSensorEvent: evt ]. - type = EventSensor eventTypeMouseScroll ifTrue: [ - self processMouseSensorWheelEvent: evt ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4974-InterruptKeyIsUnshifted-JuanVuletich-2021Nov23-09h35m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4973] on 23 November 2021 at 10:01:51 am'! -!HandMorph methodsFor: 'private events' stamp: 'jmv 11/23/2021 10:00:50' prior: 50561239! - generateKeyboardEvent: evtBuf - "Generate the appropriate mouse event for the given raw event buffer" - | buttons modifiers type keyValue pressType stamp mouseScrollDirection | - stamp _ evtBuf second. - stamp = 0 ifTrue: [ stamp _ Time millisecondClockValue ]. "VMs report events using #millisecondClockValue" - (evtBuf sixth <= 0 or: [ (keyValue _ Character iso8859s15CodeForUnicodeCodePoint: evtBuf sixth) isNil ]) ifTrue: [ keyValue _ Character macRomanToLatin1: evtBuf third ]. - Sensor peekEvent ifNotNil: [ :nxt | - "start: Combining diacritical marks (i.e. accents in the Linux VM)" - (nxt fourth = EventSensor eventKeyDown and: [ nxt third > 255 ]) ifTrue: [ - keyValue _ ((Character numericValue: keyValue) withDiacriticalMark: nxt third) iso8859s15Code. - Sensor - nextEvent; - nextEvent; - nextEvent ]. - "end: Combining diacritical marks (i.e. accents in the Linux VM)" - "start: Spurious LF after CR on Ctrl-Enter on Windows VM" - ((evtBuf fourth = EventSensor eventKeyChar and: [ evtBuf third = 13 ]) and: [ - nxt fourth = EventSensor eventKeyChar and: [ nxt third = 10 ]]) ifTrue: [ Sensor nextEvent - "print " ]]. - modifiers _ evtBuf fifth. - pressType _ evtBuf fourth. - pressType = EventSensor eventKeyDown ifTrue: [ - type _ #keyDown. - lastKeyDownValue _ keyValue ]. - pressType = EventSensor eventKeyUp ifTrue: [ - (keyValue = 9 and: [(modifiers anyMask: 1) and: [Smalltalk platformName = 'unix']]) - ifTrue: [ - "Linux VMs don't generate shift-tab keystroke. Turn #keyUp into #keystroke" - pressType _ EventSensor eventKeyChar ] - ifFalse: [type _ #keyUp ]]. - pressType = EventSensor eventKeyChar ifTrue: [ - type _ #keystroke. - "If Control key pressed, and the VM answers a code below 27, - it means it did the translation, convert it back to regular character: - We want to handle the meaning of ctrl ourselves." - (modifiers anyMask: 2) ifTrue: [ "Control key pressed" - keyValue < 27 ifTrue: [ "But we don't want to do it for Home/End/PgUp/PgDn, just for alphabetic keys" - lastKeyDownValue = keyValue ifFalse: [ "If equal, real Home/End/PgUp/PgDn in Windows => don't translate" - (keyValue + 64 = lastKeyDownValue or: [ "If Equal, Ctrl-alphabetic in Windows => do translate" - lastKeyDownValue < 47 ]) ifTrue: [ "Not on windows. If less (not sure about the bound, but do not translate 48: tab on Mac), alphabetic on Mac => do translate" - keyValue _ (modifiers anyMask: 1) - ifTrue: [ keyValue + 64 ] - ifFalse: [ keyValue + 96 "shift not pressed: conver to lowercase letter" ]]]]. - "On Windows, ctrl-backSpace is reported as ctrl-forwardDelete. But keyDown is ok, so we can know and fix." - (keyValue = 127 and: [ lastKeyDownValue = 8 ]) - ifTrue: [ keyValue _ 8 ]. - "Act as if command/alt was pressed for some usual Windows ctrl-key combinations" - (self shouldControlEmulateAltFor: keyValue) ifTrue: [ modifiers _ modifiers bitOr: 8 ]]. - (modifiers anyMask: 8) ifTrue: [ "CmdAlt key pressed (or Control key pressed, and #shouldControlEmulateAltFor: just answered true)" - (modifiers anyMask: 1) ifTrue: [ "Shift pressed" - | i | - "It seems that for ctrl-shifted keys and cmd-shifted keys, the VM incorrectly reports the UNSHIFTED character. - Correct this, at least for common cmd-shortcuts, and for the US keyboard... Sigh... - (This has only been observed on Mac VMs, but seems harmless if proper shifted character is reported (as in Linux), as this wil be NOP) - (On Windows, the situation is even worse: ctrl-{ is not even reported as a keystroke event. Only keyDown and keyUp.)" - "#($' $, $. $9 $0 $[ $]) -> #($'' $< $> $( $) ${) $}" - i _ #[39 44 46 57 48 91 93 ] indexOf: keyValue. - i > 0 ifTrue: [ - keyValue _ #[34 60 62 40 41 123 125] at: i ]]]]. - buttons _ modifiers bitShift: 3. - "Linux and Windows VM send keyboard ctrl-upArrow and ctrl-downArrow when the user tries to scroll using the mouse wheel - Mac VM sends cmd-option-ctrl-shift-upArrow and cmd-option-ctrl-shift-downArrow for trackpad vertical scroll gestures, - and cmd-option-ctrl-shift-leftArrow and cmd-option-ctrl-shift-rightArrow for horizontal scroll gestures. - This way of reporting scroll events by the VM also enables scrolling using the keyboard (actually, we can't tell if user gesture was on Mouse, Trackpad or Keyboard). - But ctrl-shift and cmdAlt-shift are needed used for selecting while moving by word, line, etc. - Additionally, #ctrlArrowsScrollHorizontally allows chosing between keyboard horizontal scroll and moving word by word in text editors." - mouseScrollDirection _ nil. - "Ctrl for Keyboard or Mouse wheel gestures. All modifiers for Trackpad gestures." - (buttons = InputSensor controlKey or: [buttons = InputSensor cmdAltOptionCtrlShiftModifierKeys]) ifTrue: [ - keyValue = 30 - ifTrue: [mouseScrollDirection _ #up] - ifFalse: [keyValue = 31 - ifTrue: [mouseScrollDirection _ #down]]]. - "Ctrl for Keyboard or Mouse wheel gestures, only if preference is set. All modifiers for Trackpad gestures." - ((buttons = InputSensor controlKey and: [Preferences ctrlArrowsScrollHorizontally]) or: [buttons = InputSensor cmdAltOptionCtrlShiftModifierKeys]) ifTrue: [ - keyValue = 28 - ifTrue: [mouseScrollDirection _ #left] - ifFalse: [keyValue = 29 - ifTrue: [mouseScrollDirection _ #right]]]. - mouseScrollDirection ifNotNil: [ - ^ MouseScrollEvent new - setType: #mouseScroll - position: self morphPosition - direction: mouseScrollDirection - buttons: buttons - hand: self - stamp: stamp ]. - ^ KeyboardEvent new - setType: type - buttons: buttons - position: self morphPosition - keyValue: keyValue - hand: self - stamp: stamp! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4975-KeyboardEventsFromVMBufferEnhancements-JuanVuletich-2021Nov23-09h37m-jmv.001.cs.st----! - -----QUIT----(23 November 2021 10:54:06) Cuis5.0-4975-32.image priorSource: 9321617! \ No newline at end of file diff --git a/Cuis5.0-4975-v3.changes b/Cuis5.0-4975-v3.changes deleted file mode 100644 index ead2035b..00000000 --- a/Cuis5.0-4975-v3.changes +++ /dev/null @@ -1,220476 +0,0 @@ -'From Cuis 5.0 of 7 November 2016 [latest update: #2974] on 7 November 2016 at 2:55:32 pm'! - - -----SNAPSHOT----#(7 November 2016 2:55:51.944389 pm) Cuis5.0-2974.image priorSource: 0! - -----QUIT----#(7 November 2016 2:55:56.449389 pm) Cuis5.0-2974.image priorSource: 92! - -----STARTUP----#(17 November 2016 12:32:16.520522 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-2974.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #2974] on 16 November 2016 at 3:55:25 pm'! -!Integer class methodsFor: 'instance creation' stamp: 'jmv 11/16/2016 15:37:15' prior: 16860879! - readFrom: aStream base: base - "Answer an instance of one of my concrete subclasses. Initial minus sign - accepted, and bases > 10 use letters A-Z. Embedded radix specifiers not - allowed--use Number readFrom: for that. Answer zero (not an error) if - there are no digits." - - | digit value neg cc atLeastOneDigitRead | - neg _ aStream peekFor: $-. - neg ifFalse: [aStream peekFor: $+]. - value _ 0. - atLeastOneDigitRead _ false. - [ aStream atEnd ] - whileFalse: [ - cc _ aStream next. - digit _ cc digitValue. - (digit < 0 or: [digit >= base]) - ifTrue: [ - aStream skip: -1. - atLeastOneDigitRead ifFalse: [self error: 'At least one digit expected here']. - ^neg - ifTrue: [value negated] - ifFalse: [value]]. - value _ value * base + digit. - atLeastOneDigitRead _ true ]. - neg ifTrue: [^ value negated]. - ^ value! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2975-Integer-readFrom-cleanup-JuanVuletich-2016Nov16-15h20m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2975] on 17 November 2016 at 9:08:34 am'! -!PositionableStream methodsFor: 'accessing' stamp: 'jmv 11/17/2016 09:06:59' prior: 16891425! - 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 | - position < readLimit ifTrue: [ - ^collection at: position+1 ]. - self atEnd ifTrue: [^nil]. - nextObject _ self next. - position _ position - 1. - ^nextObject! ! -!StandardFileStream methodsFor: 'read, write, position' stamp: 'jmv 11/17/2016 09:07:20' prior: 16913380! - peek - "Answer what would be returned if the message next were sent to the receiver. If the receiver is at the end, answer nil. " - | next | - position < readLimit ifTrue: [ - ^collection at: position+1 ]. - self atEnd ifTrue: [^ nil]. - next _ self basicNext. - self position: self position - 1. - ^ next! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2976-peek-Optimization-JuanVuletich-2016Nov17-09h06m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2975] on 17 November 2016 at 9:18:37 am'! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:42'! - nextDouble64BigEndian: bigEndian - "Store the given number as a 32 bit Float on this (binary) stream. - - Float pi hex '400921FB54442D18' - Float pi negated hex 'C00921FB54442D18' - - (ByteArray streamContents: [ :strm | - strm nextDouble64Put: Float pi bigEndian: false ]) - readStream nextDouble64BigEndian: false - - (ByteArray streamContents: [ :strm | - strm nextDouble64Put: Float pi bigEndian: true ]) - readStream nextDouble64BigEndian: true - " - | bytes | - bytes _ self next: 8. - ^ bytes doubleAt: 1 bigEndian: bigEndian! ! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:40'! - nextDouble64Put: aFloat bigEndian: bigEndian - "Store the given number as a 32 bit Float on this (binary) stream. - - Float pi hex '400921FB54442D18' - Float pi negated hex 'C00921FB54442D18' - - (ByteArray streamContents: [ :strm | - strm nextDouble64Put: Float pi bigEndian: false ]) hex - - (ByteArray streamContents: [ :strm | - strm nextDouble64Put: Float pi bigEndian: true ]) hex - " - | bytes | - bytes _ ByteArray new: 8. - bytes doubleAt: 1 put: aFloat bigEndian: bigEndian. - self nextPutAll: bytes! ! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:38'! - nextFloat32BigEndian: bigEndian - "Store the given number as a 32 bit Float on this (binary) stream. - - Float pi hex '400921FB54442D18' - Float pi negated hex 'C00921FB54442D18' - Float pi asIEEE32BitWord hex '16r40490FDB' - Float pi negated asIEEE32BitWord hex '16rC0490FDB' - - (ByteArray streamContents: [ :strm | - strm nextFloat32Put: Float pi bigEndian: false ]) - readStream nextFloat32BigEndian: false - - (ByteArray streamContents: [ :strm | - strm nextFloat32Put: Float pi bigEndian: true ]) - readStream nextFloat32BigEndian: true - " - | bytes | - bytes _ self next: 4. - ^ bytes floatAt: 1 bigEndian: bigEndian! ! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:34'! - nextFloat32Put: aFloat bigEndian: bigEndian - "Store the given number as a 32 bit Float on this (binary) stream. - - Float pi hex '400921FB54442D18' - Float pi negated hex 'C00921FB54442D18' - Float pi asIEEE32BitWord hex '16r40490FDB' - Float pi negated asIEEE32BitWord hex '16rC0490FDB' - - (ByteArray streamContents: [ :strm | - strm nextFloat32Put: Float pi bigEndian: false ]) hex 'DB0F4940' - - (ByteArray streamContents: [ :strm | - strm nextFloat32Put: Float pi bigEndian: true ]) hex '40490FDB' - " - | bytes | - bytes _ ByteArray new: 4. - bytes floatAt: 1 put: aFloat bigEndian: bigEndian. - self nextPutAll: bytes! ! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:26'! - nextSignedInt16BigEndian: bigEndian - "Answer the next signed, 16-bit integer from this (binary) stream. - - (ByteArray streamContents: [ :strm | - strm nextSignedInt16Put: -12345 bigEndian: false ]) - readStream nextSignedInt16BigEndian: false - - (ByteArray streamContents: [ :strm | - strm nextSignedInt16Put: -12345 bigEndian: true ]) - readStream nextSignedInt16BigEndian: true - " - | bytes | - bytes _ self next: 2. - ^ bytes shortAt: 1 bigEndian: bigEndian! ! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:26'! - nextSignedInt16Put: aNumber bigEndian: bigEndian - "Store the given number as a signed, 16-bit integer on this (binary) stream. - - (16r10000-12345) hex '16rCFC7' - - (ByteArray streamContents: [ :strm | - strm nextSignedInt16Put: -12345 bigEndian: false ]) hex - - (ByteArray streamContents: [ :strm | - strm nextSignedInt16Put: -12345 bigEndian: true ]) hex - " - | bytes | - bytes _ ByteArray new: 2. - bytes shortAt: 1 put: aNumber bigEndian: bigEndian. - self nextPutAll: bytes! ! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:26'! -nextSignedInt32BigEndian: bigEndian - "Answer the next signed, 32-bit integer from this (binary) stream. - - (ByteArray streamContents: [ :strm | - strm nextSignedInt32Put: -123456 bigEndian: false ]) - readStream nextSignedInt32BigEndian: false - - (ByteArray streamContents: [ :strm | - strm nextSignedInt32Put: -123456 bigEndian: true ]) - readStream nextSignedInt32BigEndian: true - " - | bytes | - bytes _ self next: 4. - ^ bytes longAt: 1 bigEndian: bigEndian! ! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:27'! - nextSignedInt32Put: aNumber bigEndian: bigEndian - "Store the given number as a signed, 32-bit integer on this (binary) stream. - - (16r100000000-123456) hex '16rFFFE1DC0' - - (ByteArray streamContents: [ :strm | - strm nextSignedInt32Put: -123456 bigEndian: false ]) hex - - (ByteArray streamContents: [ :strm | - strm nextSignedInt32Put: -123456 bigEndian: true ]) hex - " - | bytes | - bytes _ ByteArray new: 4. - bytes longAt: 1 put: aNumber bigEndian: bigEndian. - self nextPutAll: bytes! ! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:18'! - nextUnsignedInt16BigEndian: bigEndian - "Answer the next unsigned, 16-bit integer from this (binary) stream. - - (ByteArray streamContents: [ :strm | - strm nextUnsignedInt16Put: 12345 bigEndian: false ]) - readStream nextUnsignedInt16BigEndian: false - - (ByteArray streamContents: [ :strm | - strm nextUnsignedInt16Put: 12345 bigEndian: true ]) - readStream nextUnsignedInt16BigEndian: true - " - | bytes | - bytes _ self next: 2. - ^ bytes unsignedShortAt: 1 bigEndian: bigEndian! ! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:27'! - nextUnsignedInt16Put: aNumber bigEndian: bigEndian - "Store the given number as a unsigned, 16-bit integer on this (binary) stream. - - 12345 hex '16r3039' - - (ByteArray streamContents: [ :strm | - strm nextUnsignedInt16Put: 12345 bigEndian: false ]) hex - - (ByteArray streamContents: [ :strm | - strm nextUnsignedInt16Put: 12345 bigEndian: true ]) hex - " - | bytes | - bytes _ ByteArray new: 2. - bytes unsignedShortAt: 1 put: aNumber bigEndian: bigEndian. - self nextPutAll: bytes! ! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:19'! - nextUnsignedInt32BigEndian: bigEndian - "Answer the next unsigned, 32-bit integer from this (binary) stream. - - (ByteArray streamContents: [ :strm | - strm nextUnsignedInt32Put: 123456 bigEndian: false ]) - readStream nextUnsignedInt32BigEndian: false - - (ByteArray streamContents: [ :strm | - strm nextUnsignedInt32Put: 123456 bigEndian: true ]) - readStream nextUnsignedInt32BigEndian: true - " - | bytes | - bytes _ self next: 4. - ^ bytes unsignedLongAt: 1 bigEndian: bigEndian! ! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:27'! - nextUnsignedInt32Put: aNumber bigEndian: bigEndian - "Store the given number as a unsigned, 32-bit integer on this (binary) stream. - - 123456 hex '16r1E240' - - (ByteArray streamContents: [ :strm | - strm nextUnsignedInt32Put: 123456 bigEndian: false ]) hex - - (ByteArray streamContents: [ :strm | - strm nextUnsignedInt32Put: 123456 bigEndian: true ]) hex - " - | bytes | - bytes _ ByteArray new: 4. - bytes unsignedLongAt: 1 put: aNumber bigEndian: bigEndian. - self nextPutAll: bytes! ! -!Stream methodsFor: 'nonhomogeneous accessing' stamp: 'jmv 6/14/2013 20:02'! - nextNumber - "Answer a number from the stream." - - |element| - [(element := self next) isNil or: [element isDigit or: [element = $- or: [element = $)]]]] whileFalse. - element ifNil: [^nil]. - self skip: -1. - element = $) ifTrue: [^nil]. - ^Number readFrom: self! ! -!Stream methodsFor: 'nonhomogeneous accessing' stamp: 'jmv 2/29/2016 11:04'! - nextNumber: n - "Answer the next n bytes as a positive Integer or LargePositiveInteger. - Currently only for bigEndian. Consider following the convention in category 'normalized access'" - | s | - s _ 0. - 1 to: n do: - [:i | s _ (s bitShift: 8) bitOr: self next asInteger]. - ^ s normalize! ! -!Stream methodsFor: 'nonhomogeneous accessing' stamp: 'jmv 2/29/2016 11:04'! - 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. - Currently only for bigEndian. Consider following the convention in category 'normalized access'" - - 1 to: n do: [:i | self nextPut: (v digitAt: n+1-i)]. - ^ v -! ! -!Stream methodsFor: 'nonhomogeneous accessing' stamp: 'ls 9/14/1998 22:46'! - 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)." - - | aString length | - - "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]]. - aString _ String new: length. - - "read the characters in ASCII mode" - self ascii. - self nextInto: aString. - ^aString! ! -!Stream methodsFor: 'nonhomogeneous accessing' stamp: 'yo 4/16/2001 17:56'! - 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! ! - -DummyStream removeSelector: #nextDouble64BigEndian:! - -DummyStream removeSelector: #nextDouble64BigEndian:! - -DummyStream removeSelector: #nextDouble64Put:bigEndian:! - -DummyStream removeSelector: #nextDouble64Put:bigEndian:! - -DummyStream removeSelector: #nextNumber:put:! - -DummyStream removeSelector: #nextNumber:put:! - -DummyStream removeSelector: #nextSignedInt16BigEndian:! - -DummyStream removeSelector: #nextSignedInt16BigEndian:! - -DummyStream removeSelector: #nextSignedInt16Put:bigEndian:! - -DummyStream removeSelector: #nextSignedInt16Put:bigEndian:! - -DummyStream removeSelector: #nextSignedInt32BigEndian:! - -DummyStream removeSelector: #nextSignedInt32BigEndian:! - -DummyStream removeSelector: #nextSignedInt32Put:bigEndian:! - -DummyStream removeSelector: #nextSignedInt32Put:bigEndian:! - -DummyStream removeSelector: #nextStringPut:! - -DummyStream removeSelector: #nextStringPut:! - -DummyStream removeSelector: #nextUnsignedInt16BigEndian:! - -DummyStream removeSelector: #nextUnsignedInt16BigEndian:! - -DummyStream removeSelector: #nextUnsignedInt16Put:bigEndian:! - -DummyStream removeSelector: #nextUnsignedInt16Put:bigEndian:! - -DummyStream removeSelector: #nextUnsignedInt32BigEndian:! - -DummyStream removeSelector: #nextUnsignedInt32BigEndian:! - -DummyStream removeSelector: #nextUnsignedInt32Put:bigEndian:! - -DummyStream removeSelector: #nextUnsignedInt32Put:bigEndian:! - -DataStream removeSelector: #readStringOld! - -DataStream removeSelector: #readStringOld! - -PositionableStream removeSelector: #nextDouble64BigEndian:! - -PositionableStream removeSelector: #nextDouble64BigEndian:! - -PositionableStream removeSelector: #nextDouble64Put:bigEndian:! - -PositionableStream removeSelector: #nextDouble64Put:bigEndian:! - -PositionableStream removeSelector: #nextFloat32BigEndian:! - -PositionableStream removeSelector: #nextFloat32BigEndian:! - -PositionableStream removeSelector: #nextFloat32Put:bigEndian:! - -PositionableStream removeSelector: #nextFloat32Put:bigEndian:! - -PositionableStream removeSelector: #nextNumber! - -PositionableStream removeSelector: #nextNumber! - -PositionableStream removeSelector: #nextNumber:! - -PositionableStream removeSelector: #nextNumber:! - -PositionableStream removeSelector: #nextNumber:put:! - -PositionableStream removeSelector: #nextNumber:put:! - -PositionableStream removeSelector: #nextSignedInt16BigEndian:! - -PositionableStream removeSelector: #nextSignedInt16BigEndian:! - -PositionableStream removeSelector: #nextSignedInt16Put:bigEndian:! - -PositionableStream removeSelector: #nextSignedInt16Put:bigEndian:! - -PositionableStream removeSelector: #nextSignedInt32BigEndian:! - -PositionableStream removeSelector: #nextSignedInt32BigEndian:! - -PositionableStream removeSelector: #nextSignedInt32Put:bigEndian:! - -PositionableStream removeSelector: #nextSignedInt32Put:bigEndian:! - -PositionableStream removeSelector: #nextString! - -PositionableStream removeSelector: #nextString! - -PositionableStream removeSelector: #nextStringOld! - -PositionableStream removeSelector: #nextStringOld! - -PositionableStream removeSelector: #nextStringPut:! - -PositionableStream removeSelector: #nextStringPut:! - -PositionableStream removeSelector: #nextUnsignedInt16BigEndian:! - -PositionableStream removeSelector: #nextUnsignedInt16BigEndian:! - -PositionableStream removeSelector: #nextUnsignedInt16Put:bigEndian:! - -PositionableStream removeSelector: #nextUnsignedInt16Put:bigEndian:! - -PositionableStream removeSelector: #nextUnsignedInt32BigEndian:! - -PositionableStream removeSelector: #nextUnsignedInt32BigEndian:! - -PositionableStream removeSelector: #nextUnsignedInt32Put:bigEndian:! - -PositionableStream removeSelector: #nextUnsignedInt32Put:bigEndian:! - -Stream removeSelector: #nextStringOld! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2977-Stream-refactor-JuanVuletich-2016Nov17-09h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2977] on 17 November 2016 at 10:29:07 am'! -!PositionableStream methodsFor: 'testing' stamp: 'jmv 11/17/2016 10:28:06' prior: 16891536! - atEnd - "Answer whether the receiver can access any more objects." - - ^position >= readLimit! ! -!ReadStream methodsFor: 'accessing' stamp: 'jmv 11/17/2016 09:59:57' prior: 16897965! - next - "Answer the next object in the Stream represented by the receiver." - - ^position >= readLimit - ifFalse: [collection at: (position _ position + 1)]! ! -!WriteStream methodsFor: 'accessing' stamp: 'jmv 11/17/2016 10:28:35' prior: 16946385! - nextPut: anObject - "Insert the argument at the next position in the Stream represented by the receiver." - - position >= writeLimit - ifTrue: [^ self pastEndPut: anObject] - ifFalse: [ - position _ position + 1. - ^collection at: position put: anObject]! ! -!ReadWriteStream methodsFor: 'accessing' stamp: 'jmv 11/17/2016 10:28:45' prior: 16898094! - next - "Return the next object in the Stream represented by the receiver." - - "treat me as a FIFO" - ^ position >= readLimit - ifFalse: [collection at: (position _ position + 1)]! ! -!StandardFileStream methodsFor: 'read, write, position' stamp: 'jmv 11/17/2016 10:00:56' prior: 16913098! - basicNext - "Answer the next byte from this file, or nil if at the end of the file." - - | count | - collection ifNotNil: [ - position < readLimit - ifFalse: [ - readLimit := self primRead: fileID into: collection startingAt: 1 count: collection size. - position := 0. - readLimit = 0 ifTrue: [ ^nil ] ]. - ^collection at: (position := position + 1) ]. - count _ self primRead: fileID into: buffer1 startingAt: 1 count: 1. - ^count = 1 - ifTrue: [ buffer1 at: 1 ]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2978-RemoveObsoletePrimCalls-JuanVuletich-2016Nov17-10h26m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2977] on 17 November 2016 at 10:31:18 am'! - -Stream subclass: #StdIOReadStream - instanceVariableNames: 'fileID name buffer1' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #StdIOReadStream category: #'System-Support'! -Stream subclass: #StdIOReadStream - instanceVariableNames: 'fileID name buffer1' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! -!StdIOReadStream commentStamp: '' prior: 0! - Standard Input Stream. - -A basic problem/restriction with this code is that currently the VM runs multiple VM threads within a single OS thread. - -This means that waiting on StdIn blocks the VM, suspending all Smalltalk code.! - -Stream subclass: #StdIOWriteStream - instanceVariableNames: 'fileID name buffer1 collection readLimit position' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #StdIOWriteStream category: #'System-Support'! -Stream subclass: #StdIOWriteStream - instanceVariableNames: 'fileID name buffer1 collection readLimit position' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! -!StdIOWriteStream commentStamp: '' prior: 0! - Standard Output/Error Streams.! -!StdIOReadStream methodsFor: 'open / close' stamp: 'jmv 11/17/2016 10:12:24'! - openOnHandle: aFileID name: streamName - "Initialize the instance with the given file handle. - N.B. Do _not_ register the stream. We do not want it to be - closed implicitly (e.g. on GC). There may be multiple instances - accessing the same stream. The stream is not a file." - - fileID _ aFileID. - name _ streamName. - buffer1 _ String new: 1! ! -!StdIOReadStream methodsFor: 'streaming' stamp: 'jmv 11/17/2016 10:01:57'! - next - "Answer the next byte from this stream, or wait until one becomes available. - Warning: all Smalltalk processes are essentially suspended until that happens!!" - - | count | - count _ self primRead: fileID into: buffer1 startingAt: 1 count: 1. - ^count = 1 - ifTrue: [ buffer1 at: 1 ]! ! -!StdIOReadStream methodsFor: 'printing' stamp: 'jmv 11/17/2016 09:47:10'! - printOn: aStream - "Put a printed version of the receiver onto aStream." - - aStream nextPutAll: self class name; nextPutAll: ': '; print: name! ! -!StdIOReadStream methodsFor: 'primitives' stamp: 'jmv 11/17/2016 09:45:28'! - primRead: id into: byteArray startingAt: startIndex count: count - "Read up to count bytes of data from this file into the given string or byte array starting at the given index. Answer the number of bytes actually read." - - - self error: 'File read failed'! ! -!StdIOReadStream class methodsFor: 'instance creation' stamp: 'jmv 11/17/2016 09:46:36'! - stdin - | newSelf | - newSelf _ self basicNew. - newSelf - openOnHandle: self stdinHandle - name: 'stdin'. - ^newSelf! ! -!StdIOReadStream class methodsFor: 'accessing' stamp: 'jmv 11/17/2016 09:26:47'! - stdinHandle - - ^ StdIOWriteStream stdioHandles at: 1! ! -!StdIOWriteStream methodsFor: 'open / close' stamp: 'jmv 11/17/2016 10:14:32'! - openOnHandle: aFileID name: streamName - "Initialize the instance with the given file handle. - N.B. Do _not_ register the stream. We do not want it to be - closed implicitly (e.g. on GC). There may be multiple instances - accessing the same stream. The stream is not a file." - - fileID _ aFileID. - name _ streamName. - buffer1 _ String new: 1! ! -!StdIOWriteStream methodsFor: 'streaming' stamp: 'jmv 11/17/2016 10:19:51'! - flush - "Flush pending changes" - ^self primFlush: fileID! ! -!StdIOWriteStream methodsFor: 'streaming' stamp: 'jmv 11/17/2016 10:18:42'! - nextPut: char - "Write the given character to this file." - - buffer1 at: 1 put: char. - self primWrite: fileID from: buffer1 startingAt: 1 count: 1. - ^ char -! ! -!StdIOWriteStream methodsFor: 'printing' stamp: 'jmv 11/17/2016 09:35:56'! - printOn: aStream - "Put a printed version of the receiver onto aStream. 1/31/96 sw" - - aStream nextPutAll: self class name; nextPutAll: ': '; print: name! ! -!StdIOWriteStream methodsFor: 'primitives' stamp: 'jmv 11/17/2016 10:20:17'! - primFlush: id - "Flush pending changes to the disk" - - ! ! -!StdIOWriteStream methodsFor: 'primitives' stamp: 'jmv 11/17/2016 10:19:14'! - primWrite: id from: stringOrByteArray startingAt: startIndex count: count - "Write count bytes onto this file from the given string or byte array starting at the given index. Answer the number of bytes written." - - - (FileWriteError fileName: name) - signal: (self closed - ifTrue: [ 'File [', name, '] is closed' ] - ifFalse: [ 'File [', name, '] write failed' ])! ! -!StdIOWriteStream class methodsFor: 'instance creation' stamp: 'jmv 11/17/2016 10:15:08'! -stderr - | newSelf | - newSelf _ self basicNew. - newSelf - openOnHandle: self stderrHandle - name: 'stderr'. - ^newSelf! ! -!StdIOWriteStream class methodsFor: 'instance creation' stamp: 'jmv 11/17/2016 10:15:11'! - stdout - | newSelf | - newSelf _ self basicNew. - newSelf - openOnHandle: self stdoutHandle - name: 'stdout'. - ^newSelf! ! -!StdIOWriteStream class methodsFor: 'accessing' stamp: 'jmv 11/17/2016 09:26:20'! - stderrHandle - - ^ self stdioHandles at: 3! ! -!StdIOWriteStream class methodsFor: 'accessing' stamp: 'jmv 11/17/2016 09:26:09'! - stdioHandles -" answer handles: #(stdin stdout stderr) " - - self primitiveFailed! ! -!StdIOWriteStream class methodsFor: 'accessing' stamp: 'jmv 11/17/2016 09:26:12'! - stdoutHandle - - ^ self stdioHandles at: 2! ! - -Smalltalk removeClassNamed: #StdIOFileStream! - -Smalltalk removeClassNamed: #StdIOFileStream! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2979-NewStdIO-JuanVuletich-2016Nov17-10h29m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2979] on 17 November 2016 at 10:51:20 am'! -!StdIOWriteStream methodsFor: 'character writing' stamp: 'jmv 11/17/2016 10:48:18'! - newLine - "Append a newLine character to the receiver. - The Cuis convention is to use lf on output." - - self nextPut: Character newLineCharacter! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2980-stdout-newLine-JuanVuletich-2016Nov17-10h48m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2980] on 17 November 2016 at 11:51:03 am'! - -Stream subclass: #StdIOReadStream - instanceVariableNames: 'fileID name buffer1 peeked ' - classVariableNames: 'StdIn ' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #StdIOReadStream category: #'System-Support'! -Stream subclass: #StdIOReadStream - instanceVariableNames: 'fileID name buffer1 peeked' - classVariableNames: 'StdIn' - poolDictionaries: '' - category: 'System-Support'! - -Stream subclass: #StdIOWriteStream - instanceVariableNames: 'fileID name buffer1 collection readLimit position ' - classVariableNames: 'StdOut StdErr ' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #StdIOWriteStream category: #'System-Support'! -Stream subclass: #StdIOWriteStream - instanceVariableNames: 'fileID name buffer1 collection readLimit position' - classVariableNames: 'StdErr StdOut' - poolDictionaries: '' - category: 'System-Support'! -!StdIOReadStream methodsFor: 'streaming' stamp: 'jmv 11/17/2016 11:28:43'! - peek - "Answer the next byte from this stream, or wait until one becomes available. - Warning: all Smalltalk processes are essentially suspended until that happens!! - - Do not advance the stream!!" - - "Multiple calls to #peek don't make new reads" - peeked ifFalse: [ - self privateRead. - peeked _ true ]. - - "peeked is always true on exit" - ^buffer1 at: 1! ! -!StdIOReadStream methodsFor: 'streaming' stamp: 'jmv 11/17/2016 11:33:22'! - peekFor: aCharacter - "Answer false and do not move over the next element if it is not equal to the argument, aCharacter - Answer true and increment the position for accessing elements, if the next element is equal to anObject." - - | nextChar | - nextChar _ self peek. - aCharacter = nextChar ifTrue: [ - self next. - ^ true]. - ^ false! ! -!StdIOReadStream methodsFor: 'streaming' stamp: 'jmv 11/17/2016 11:24:52'! - privateRead - "Read one Character. - Private." - | count | - count _ self primRead: fileID into: buffer1 startingAt: 1 count: 1. - count = 1 ifFalse: [ buffer1 at: 1 put: nil ]! ! -!StdIOReadStream class methodsFor: 'cached state access' stamp: 'jmv 11/17/2016 11:45:00'! - releaseClassCachedState - - StdIn _ nil! ! -!StdIOWriteStream methodsFor: 'character writing' stamp: 'jmv 11/17/2016 11:08:02'! - space - "Append a space character to the receiver." - - self nextPut: Character space! ! -!StdIOWriteStream class methodsFor: 'cached state access' stamp: 'jmv 11/17/2016 11:44:50'! - releaseClassCachedState - - StdOut _ nil. - StdErr _ nil! ! -!StdIOReadStream methodsFor: 'open / close' stamp: 'jmv 11/17/2016 11:13:30' prior: 50332252! - openOnHandle: aFileID name: streamName - "Initialize the instance with the given file handle. - N.B. Do _not_ register the stream. We do not want it to be - closed implicitly (e.g. on GC). There may be multiple instances - accessing the same stream. The stream is not a file." - - fileID _ aFileID. - name _ streamName. - buffer1 _ String new: 1. - peeked _ false! ! -!StdIOReadStream methodsFor: 'streaming' stamp: 'jmv 11/17/2016 11:28:44' prior: 50332266! - next - "Answer the next byte from this stream, or wait until one becomes available. - Warning: all Smalltalk processes are essentially suspended until that happens!!" - - "If last call was #peek, not #next, then just answer cached value." - peeked - ifFalse: [ self privateRead ] - ifTrue: [ peeked _ false ]. - - "peeked is always false on exit" - ^buffer1 at: 1! ! -!StdIOReadStream class methodsFor: 'instance creation' stamp: 'jmv 11/17/2016 11:45:39' prior: 50332298! - stdin - StdIn ifNil: [ - StdIn _ self basicNew. - StdIn - openOnHandle: self stdinHandle - name: 'stdin' ]. - ^StdIn! ! -!StdIOWriteStream class methodsFor: 'instance creation' stamp: 'jmv 11/17/2016 11:46:13' prior: 50332367! - stderr - StdErr ifNil: [ - StdErr _ self basicNew. - StdErr - openOnHandle: self stderrHandle - name: 'stderr' ]. - ^StdErr! ! -!StdIOWriteStream class methodsFor: 'instance creation' stamp: 'jmv 11/17/2016 11:46:37' prior: 50332374! - stdout - StdOut ifNil: [ - StdOut _ self basicNew. - StdOut - openOnHandle: self stdoutHandle - name: 'stdout' ]. - ^StdOut! ! - -Stream subclass: #StdIOReadStream - instanceVariableNames: 'fileID name buffer1 peeked' - classVariableNames: 'StdIn' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #StdIOReadStream category: #'System-Support'! -Stream subclass: #StdIOReadStream - instanceVariableNames: 'fileID name buffer1 peeked' - classVariableNames: 'StdIn' - poolDictionaries: '' - category: 'System-Support'! - -Stream subclass: #StdIOWriteStream - instanceVariableNames: 'fileID name buffer1' - classVariableNames: 'StdErr StdOut' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #StdIOWriteStream category: #'System-Support'! -Stream subclass: #StdIOWriteStream - instanceVariableNames: 'fileID name buffer1' - classVariableNames: 'StdErr StdOut' - poolDictionaries: '' - category: 'System-Support'! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2981-StdIn-peek-peekFor-JuanVuletich-2016Nov17-11h08m-jmv.1.cs.st----! - -----SNAPSHOT----#(17 November 2016 12:32:45.272939 pm) Cuis5.0-2981.image priorSource: 181! - -----QUIT----#(17 November 2016 12:33:33.533688 pm) Cuis5.0-2981.image priorSource: 29844! - -----STARTUP----#(14 December 2016 2:33:04.156577 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-2981.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #2981] on 17 November 2016 at 5:11:35 pm'! -!SequenceableCollection methodsFor: 'copying' stamp: 'jmv 11/17/2016 17:08:04' prior: 16906186! - copyReplaceFrom: start to: stop with: replacementCollection - "Answer a copy of the receiver satisfying the following conditions: - + 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! ! -!SHTextStylerST80 methodsFor: 'private' stamp: 'jmv 11/17/2016 16:54:39' prior: 16903350! - setAttributesFromRanges: ranges - - formattedText removeAttributesThat: [ :attribute | attribute isForShout ]. - - "Optimize for mutation speed unless method is really large but with very few distict elements: - Source code that includes just big literals is better served by conventional Text+RunArray" - "Do it only if we are not breaking textModel!! (for instance, StyledTextEditor asks for formatting just sections, not whole #actualContents)." - formattedText == textModel actualContents ifTrue: [ - (formattedText size > 2000 and: [ ranges size < 50 ]) ifFalse: [ - formattedText _ formattedText optimizedForMutationSpeed. - textModel basicActualContents: formattedText ]]. - - ranges do: [ :range | - - "Smalltalk text styling" - (self attributesFor: range rangeType) ifNotNil: [ :attributes | - attributes do: [ :each | - formattedText addAttribute: each from: range start to: range end ]]. - - "Show as subscripts if appropriate." - (classOrMetaClass isNil or: [ - classOrMetaClass theNonMetaClass lastUnderscoreMeansSubscript]) ifTrue: [ - (#( instVar classVar globalVar workspaceVar poolConstant - patternArg methodArg patternTempVar tempVar - blockPatternArg blockArg blockPatternTempVar blockTempVar - incompleteIdentifier undefinedIdentifier) pointsTo: range rangeType ) - ifTrue: [ - formattedText lastIndexOf: $_ startingAt: range end endingAt: range start do: [ :i | - formattedText addAttribute: ShoutTextEmphasis subscript from: i to: range end ] ]]]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2982-CodeColorizerFix-JuanVuletich-2016Nov17-17h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2981] on 17 November 2016 at 5:18:27 pm'! -!DummyStream methodsFor: 'as yet unclassified' stamp: 'KenD 11/5/2016 16:17:09'! - space! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2983-DummyStream-space-KenDickey-2016Nov17-17h18m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2981] on 18 November 2016 at 10:49:39 am'! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/3/2015 10:19' prior: 16935004! - newMorph - "The user requested 'new morph' from the world menu. Put up a menu that allows many ways of obtaining new morphs. If the preference #classicNewMorphMenu is true, the full form of yore is used; otherwise, a much shortened form is used." - | menu subMenu catDict shortCat class | - menu _ self menu: 'Add a new morph'. - menu - - add: 'From Clipboard' - target: myHand - action: #pasteMorph; - - add: 'From Alphabetical List' - subMenu: self alphabeticalMorphMenu. - menu addLine. - - "Add 'Classic' New Morph menu" - catDict _ Dictionary new. - SystemOrganization categories do: [ :cat | - ((cat beginsWith: 'Morphic-') and: [ (#('Morphic-Menus' 'Morphic-Support' ) includes: cat) not ]) ifTrue: [ - shortCat _ (cat - copyFrom: 'Morphic-' size + 1 - to: cat size). - (SystemOrganization listAtCategoryNamed: cat) do: [ :cName | - class _ Smalltalk at: cName. - ((class inheritsFrom: Morph) and: [ class includeInNewMorphMenu ]) ifTrue: [ - (catDict includesKey: shortCat) - ifTrue: [ (catDict at: shortCat) addLast: class ] - ifFalse: [ - catDict - at: shortCat - put: (OrderedCollection with: class) ]]]]]. - catDict keys sort do: [ :categ | - subMenu _ MenuMorph new. - ((catDict at: categ) asArray sort: [ :c1 :c2 | - c1 name < c2 name ]) do: [ :cl | - subMenu - add: cl name - target: self - selector: #newMorphOfClass:event: - argument: cl ]. - menu - add: categ - subMenu: subMenu ]. - - self doPopUp: menu.! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2984-NewMorphMenuFix-JuanVuletich-2016Nov18-10h34m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2984] on 30 November 2016 at 2:56:21 pm'! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'jmv 11/30/2016 14:52:08'! - with: otherCollection with: thirdCollection collect: threeArgBlock - "Collect and return the result of evaluating twoArgBlock with corresponding elements from this collection and otherCollection." - | n result | - n _ self size. - otherCollection size = n ifFalse: [ self error: 'otherCollection must be the same size' ]. - thirdCollection size = n ifFalse: [ self error: 'thirdCollection must be the same size' ]. - result _ self species new: n. - 1 to: n do: [ :index | - result at: index put: - (threeArgBlock - value: (self at: index) - value: (otherCollection at: index) - value: (thirdCollection at: index) )]. - ^ result! ! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'jmv 11/25/2016 12:15:27'! - with: otherCollection with: thirdCollection do: threeArgBlock - "Evaluate twoArgBlock with corresponding elements from this collection and otherCollection." - | n | - n _ self size. - otherCollection size = n ifFalse: [self error: 'otherCollection must be the same size']. - thirdCollection size = n ifFalse: [self error: 'thirdCollection must be the same size']. - 1 to: n do: [ :index | - threeArgBlock - value: (self at: index) - value: (otherCollection at: index) - value: (thirdCollection at: index)]! ! -!OrderedCollection methodsFor: 'enumerating' stamp: 'jmv 11/30/2016 14:51:19'! - with: otherCollection with: thirdCollection collect: threeArgBlock - "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: - (threeArgBlock - value: (self at: index) - value: (otherCollection at: index) - value: (thirdCollection at: index) )]. - ^ result! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2985-withwithdo-withwithdcollect-JuanVuletich-2016Nov30-14h47m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2984] on 30 November 2016 at 3:22:11 pm'! -!SequenceableCollection methodsFor: 'math functions' stamp: 'jmv 11/30/2016 15:04:11'! - += anObject - ^anObject isNumber - ifTrue: [ self replace: [ :v | v + anObject ]] - ifFalse: [ - self withIndexDo: [ :v :i | - self at: i put: ((self at: i) + (anObject at: i)) ]]! ! -!SequenceableCollection methodsFor: 'math functions' stamp: 'jmv 11/25/2016 11:41:25'! - -= anObject - ^anObject isNumber - ifTrue: [ self replace: [ :v | v - anObject ]] - ifFalse: [ - self withIndexDo: [ :v :i | - self at: i put: ((self at: i) - (anObject at: i)) ]]! ! -!SequenceableCollection methodsFor: 'math functions' stamp: 'jmv 11/30/2016 15:21:00'! - derivative - | displaced answer | - displaced _ self class new: self size. - displaced replaceFrom: 2 to: self size with: self startingAt: 1. - displaced at: 1 put: self first - self first. "Some reasonable zero" - answer _ self copy. - answer -= displaced. - ^answer! ! -!SequenceableCollection methodsFor: 'math functions' stamp: 'jmv 11/29/2016 14:23:32'! - integral - | answer | - answer _ self copy. - 2 to: answer size do: [ :i | - answer at: i put: (answer at: i) + (answer at: i-1) ]. - ^answer! ! - -FloatArray removeSelector: #derivative! - -FloatArray removeSelector: #derivative! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2986-Collection-derivative-integral-JuanVuletich-2016Nov30-14h56m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2974] on 26 November 2016 at 8:42:22 am'! -!HaloMorph methodsFor: 'stepping' stamp: 'len 7/25/2016 21:39'! - step - (target isNil or: [target isInWorld not]) ifTrue: [self delete]! ! -!HaloMorph methodsFor: 'stepping' stamp: 'len 7/25/2016 21:41'! - stepTime - ^ 100! ! -!HaloMorph methodsFor: 'stepping' stamp: 'len 7/25/2016 21:38'! - wantsSteps - ^ true! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2987-DeleteHaloWhenMorphIsDeleted-LucianoEstebanNotarfrancesco-2016Nov26-08h41m-len.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2974] on 26 November 2016 at 8:46:53 am'! -!MenuMorph methodsFor: 'keyboard control' stamp: 'len 6/11/2016 20:40' prior: 16867064! - keyboardFocusChange: aBoolean - "Notify change due to green border for keyboard focus" - - aBoolean ifFalse: [self deleteIfPopUp: nil]. - self redrawNeeded! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2988-AvoidManuesHangingAround-LucianoEstebanNotarfrancesco-2016Nov26-08h42m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2974] on 26 November 2016 at 8:52:37 am'! -!SequenceableCollection methodsFor: 'copying' stamp: 'len 4/18/2016 22:08'! - shuffledBy: aGenerator - "To answer a mutable collection when receiver is, for example, an Interval." - ^ (self collect: [ :each | each ]) shuffleBy: aGenerator! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2989-ShuffledBy-LucianoEstebanNotarfrancesco-2016Nov26-08h46m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2974] on 26 November 2016 at 9:02:48 am'! -!SystemDictionary methodsFor: 'browsing' stamp: 'len 6/9/2016 23:23'! - browseAllPrimitives - self browseAllSelect: [:each| each primitive ~= 0 and: [(each primitive between: 256 and: 291) not]] -! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2990-SmalltalkBrowseAllPrimitives-LucianoEstebanNotarfrancesco-2016Nov26-08h52m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2974] on 26 November 2016 at 9:03:51 am'! -!SystemDictionary methodsFor: 'retrieving' stamp: 'len 11/26/2016 09:03:25' prior: 16921461! - allCallsOn: aLiteral "Smalltalk browseAllCallsOn: #open:label:." - "Answer a Collection of all the methods that call on aLiteral." - | aCollection special aList byte | - - #(23 48 'fred' (new open:label:)) size. -"Example above should find #open:label:, though it is deeply embedded here." - - aCollection _ OrderedCollection new. - special _ self hasSpecialSelector: aLiteral ifTrueSetByte: [:b | byte _ b ]. - self allBehaviorsDo: [:class | - aList _ class whichSelectorsReferTo: aLiteral special: special byte: byte. - aList do: [ :sel | - "For special selectors, look for the literal in the source code. - Otherwise, for example, searching for senders of #== will include senders of #ifNil. - Except for #at:put:, because it has two arguments and won't find it in the source code like that." - (byte isNil or: [aLiteral = #at:put: or: [ - ((class sourceCodeAt: sel) - findString: aLiteral) > 0]]) ifTrue: [ - - aCollection add: ( - MethodReference new - setStandardClass: class - methodSymbol: sel - ) - ] - ] - ]. - ^ aCollection! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2991-SendersOfatput-LucianoEstebanNotarfrancesco-2016Nov26-09h02m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2974] on 26 November 2016 at 9:06:05 am'! -!String methodsFor: 'testing' stamp: 'len 11/26/2016 09:05:35'! - isAlphaNumeric - "Answer true if the receiver contains only letters or digits." - ^ self allSatisfy: [:each| each isAlphaNumeric]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2992-StringisAlphaNumeric-LucianoEstebanNotarfrancesco-2016Nov26-09h03m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2974] on 26 November 2016 at 9:08:39 am'! -!Form methodsFor: 'fileIn/Out' stamp: 'len 8/1/2016 08:13' prior: 16847779! - printOn: aStream - aStream isText - ifTrue: - [aStream withAttribute: (TextAnchor new anchoredFormOrMorph: self) do: [aStream nextPut: $*]. - ^ self]. - aStream - nextPutAll: self class name; - nextPut: $(; print: width; - nextPut: $x; print: height; - nextPut: $x; print: depth; - nextPut: $)! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2993-FormPrintOnTextForWorkspaces-LucianoEstebanNotarfrancesco-2016Nov26-09h06m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2993] on 5 December 2016 at 8:17:22 am'! -!Morph methodsFor: 'printing' stamp: 'jmv 12/5/2016 08:16:19' prior: 16876467! - printOn: aStream - "Add the identity of the receiver to a stream" - aStream isText - ifTrue: [ - aStream - withAttribute: (TextAnchor new anchoredFormOrMorph: (owner ifNil: [self] ifNotNil: [self imageForm:32])) - do: [ aStream nextPut: $* ]. - ^ self]. - super printOn: aStream. "a(n) className" - aStream - nextPut: $(; - print: self identityHash; - nextPut: $). - self valueOfProperty: #morphName ifPresentDo: [ :x | aStream nextPutAll: x asString]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2994-MorphPrintOnTextEnh-JuanVuletich-2016Dec05-08h16m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2994] on 5 December 2016 at 9:46:02 am'! -!Integer methodsFor: 'comparing' stamp: 'len 12/5/2016 09:46:00' prior: 16859447! - hash - "Hash is reimplemented because = is implemented. - | s | - s _ (1 to: 10000) asSet. - [s includes: 123456] bench - " - - ^self hashMultiply! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - -Set rehashAllSets! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2995-Integer-hash-LucianoEstebanNotarfrancesco-2016Dec05-09h39m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2986] on 2 December 2016 at 4:40:51 pm'! -!Form methodsFor: 'scaling, rotation' stamp: 'jmv 12/2/2016 15:47:08' prior: 16848280! - flippedBy: direction - "Return a copy of the receiver flipped either #vertical, #horizontal or #both. (#both is a 180 degrees rotation) - Form lena display. - (Form lena flippedBy: #vertical) display. - (Form lena flippedBy: #horizontal) display. - (Form lena flippedBy: #both) display. - " - | newForm quad | - newForm _ self class extent: self extent depth: depth. - quad _ self boundingBox innerCorners. - quad _ ( - direction caseOf: { - [ #vertical ] -> [#(2 1 4 3)]. - [ #horizontal ] -> [#(4 3 2 1)]. - [ #both ] -> [#(3 4 1 2)]}) - collect: [:i | quad at: i]. - (WarpBlt toForm: newForm) - sourceForm: self; - colorMap: (self colormapIfNeededFor: newForm); - combinationRule: 3; - copyQuad: quad toRect: newForm boundingBox. -" newForm offset: (self offset flippedBy: direction centerAt: aPoint)." - ^ newForm -" -[Sensor isAnyButtonPressed] whileFalse: - [((Form fromDisplay: (Sensor mousePoint extent: 130@66)) - flippedBy: #vertical centerAt: 0@0) display] -" -"Consistency test... - | f f2 p | -[ Sensor isAnyButtonPressed ] whileFalse: [ - f _ Form fromDisplay: ((p _ Sensor mousePoint) extent: 31@41). - Display fillBlack: (p extent: 31@41). - f2 _ f flippedBy: #vertical centerAt: 0@0. - (f2 flippedBy: #vertical centerAt: 0@0) displayAt: p ] -"! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2996-Form-FlippedBy-both-JuanVuletich-2016Dec02-15h42m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2996] on 9 December 2016 at 9:12:18 am'! -!StringMorph methodsFor: 'initialization' stamp: 'jmv 12/9/2016 09:09:45' prior: 16918230! - initialize - super initialize. - font _ nil. - emphasis _ 0. - self contents: 'String Morph' -! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2997-StringMorph-fix-JuanVuletich-2016Dec09-09h07m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2974] on 29 November 2016 at 9:10:32 pm'! -!OrderedCollection methodsFor: 'converting' stamp: 'len 11/29/2016 08:54:14'! - asNewArray - ^ array copyFrom: firstIndex to: lastIndex! ! -!OrderedCollection class methodsFor: 'instance creation' stamp: 'len 11/28/2016 19:18:39'! - newFrom: aCollection - "Create a new collection containing all the elements from aCollection" - - ^(self new: aCollection size) - resetTo: 1; - addAll: aCollection; - yourself! ! -!OrderedCollection methodsFor: 'enumerating' stamp: 'len 11/28/2016 10:50:21' prior: 16883972! - 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. - newCollection resetTo: 1. - firstIndex to: lastIndex do: [ :index | - newCollection addLast: (aBlock value: (array at: index))]. - ^ newCollection! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2998-OrderedCollectionTweaks-LucianoEstebanNotarfrancesco-2016Nov26-09h08m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2995] on 6 December 2016 at 8:16:54 pm'! - -RectangleLikeMorph subclass: #ResizeMorph - instanceVariableNames: 'gridLineWidth gridColor selectionColor outlineMorph grid from to action' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #ResizeMorph category: #'Morphic-Views'! -RectangleLikeMorph subclass: #ResizeMorph - instanceVariableNames: 'gridLineWidth gridColor selectionColor outlineMorph grid from to action' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! -!SystemWindow methodsFor: 'resize/collapse' stamp: 'bp 10/18/2015 12:18'! - resize - | resizeMorph | - resizeMorph _ ResizeMorph new morphExtent: 200@150. - resizeMorph action: [self resize: (resizeMorph selectionRectangle: Display extent)]. - resizeMorph morphPosition: self world activeHand morphPosition. - resizeMorph openInWorld - ! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 22:22'! - action: aBlock - action _ aBlock! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/18/2015 18:00'! - drawGridOn: aCanvas - 0 to: grid x do: [:i | - | x | - x _ i * (extent x - gridLineWidth) / grid x. - aCanvas line: x @ 0 to: x @ (extent y - 2) width: gridLineWidth color: gridColor]. - 0 to: grid y do: [:i | - | y | - y _ i * (extent y - gridLineWidth) / grid y. - aCanvas line: 0 @ y to: (extent x - 2) @ y width: gridLineWidth color: gridColor]! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 23:02'! - drawOn: aCanvas - super drawOn: aCanvas. - from ifNotNil: [aCanvas fillRectangle: (self selectionRectangle: extent) color: selectionColor]. - self drawGridOn: aCanvas! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 19:00'! - grid: aPoint - grid _ aPoint! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 19:00'! - handlesMouseDown: aMouseButtonEvent - ^true! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/17/2015 15:51'! - initialize - super initialize. - extent _ 400@300. - color _ Color white. - grid _ 8@6. - gridLineWidth _ 2. - gridColor _ Color black. - selectionColor _ Color red! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 23:18'! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - from _ self toGridPoint: localEventPosition. - outlineMorph _ BorderedRectMorph new - borderColor: Color black; - color: Color transparent; - openInWorld; - hide. - self selectTo: localEventPosition! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 23:17'! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - self selectTo: localEventPosition. - outlineMorph delete. - action ifNotNil: [ - action value. - self delete]! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 21:32'! - mouseMove: aMouseButtonEvent localPosition: localEventPosition - self selectTo: localEventPosition! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 21:25'! - printOn: aStream - super printOn: aStream. - aStream space; print: from; space; print: to! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 23:14'! - selectTo: localEventPosition - | newTo | - newTo _ self toGridPoint: localEventPosition. - newTo ~= to ifTrue: [ - to _ newTo. - self redrawNeeded. - self updateOutlineMorph]! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/17/2015 15:35'! - selectionRectangle: aRectangle - ^(from corner: to + 1) scaledBy: aRectangle // grid! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/17/2015 15:34'! - toGridPoint: aPoint - ^(aPoint min: extent - 1) // (extent // grid)! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 23:15'! - updateOutlineMorph - | rectangle | - rectangle _ self selectionRectangle: Display extent. - outlineMorph - morphPosition: rectangle origin extent: rectangle extent; - show! ! -!SystemWindow methodsFor: 'menu' stamp: 'bp 10/11/2015 21:42' prior: 16926424! - buildWindowMenu - - | aMenu | - - aMenu _ MenuMorph new defaultTarget: self. - - aMenu - add: 'change title...' action: #relabel; - add: 'window color...' action: #setWindowColor; - addLine; - add: 'send to back' action: #sendToBack; - add: 'make next-to-topmost' action: #makeSecondTopmost; - addLine; - add: (self isSticky ifTrue: [ 'make draggable' ] ifFalse: [ 'make undraggable' ]) action: #toggleStickiness; - addLine; - add: 'close' action: #delete; - add: 'collapse' action: #collapse; - add: 'expand / contract' action: #expandBoxHit; - addLine; - add: 'resize...' action: #resize; - add: 'resize full' action: #resizeFull; - add: 'resize top' action: #resizeTop; - add: 'resize left' action: #resizeLeft; - add: 'resize bottom' action: #resizeBottom; - add: 'resize right' action: #resizeRight; - add: 'resize top left' action: #resizeTopLeft; - add: 'resize top right' action: #resizeTopRight; - add: 'resize bottom left' action: #resizeBottomLeft; - add: 'resize bottom right' action: #resizeBottomRight. - - ^ aMenu! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2999-ResizeMorph-BernhardPieber-2016Dec06-20h13m-bp.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2981] on 9 December 2016 at 10:27:21 am'! -!PasteUpMorph methodsFor: 'printing' stamp: 'jmv 12/9/2016 10:25:13' prior: 16887389! - printOn: aStream - "Reimplemented to add a tag showing that the receiver is currently functioning as a 'world', if it is" - - self isWorldMorph - ifTrue: [aStream nextPutAll: ' [world]'] - ifFalse: [super printOn: aStream]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3000-PasteUpMorph-print-fix-JuanVuletich-2016Dec09-10h25m-jmv.1.cs.st----! - -----SNAPSHOT----#(14 December 2016 2:33:22.856051 pm) Cuis5.0-3000.image priorSource: 29937! - -----QUIT----#(14 December 2016 2:33:35.179869 pm) Cuis5.0-3000.image priorSource: 54545! - -----STARTUP----#(19 December 2016 1:35:42.981648 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3000.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3000] on 15 December 2016 at 12:11:15 pm'! -!Point methodsFor: 'printing' stamp: 'jmv 12/15/2016 10:20:58'! -printStringFractionDigits: placesDesired - ^(x printStringFractionDigits: placesDesired), '@', (y printStringFractionDigits: placesDesired)! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3001-Point-printStringFractionDigits-JuanVuletich-2016Dec15-10h20m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3000] on 16 December 2016 at 3:13:12 pm'! -!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 12/16/2016 15:05:52' prior: 16924259! - browseMyChanges - "Browse only the changes (in the changes file) by the current author. - Smalltalk browseMyChanges - " - self browseAllSelect: [ :method | - method fileIndex > 1 "only look at changes file" - and: [ method timeStamp beginsWith: Utilities authorInitials, ' ' ]]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3002-BrowseMyChanges-fix-JuanVuletich-2016Dec16-15h03m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3002] on 19 December 2016 at 12:44:03 pm'! -!CompiledMethod methodsFor: 'accessing' stamp: 'jmv 12/17/2016 22:38:52' prior: 16819446! - initialPC - "Answer the program counter for the receiver's first bytecode." - ^ (self numLiterals + 1) * Smalltalk wordSize + 1! ! -!SystemDictionary methodsFor: 'memory space' stamp: 'jmv 12/17/2016 22:37:27' prior: 16920388! -lowSpaceThreshold - "Answer the low space threshold. When the amount of free memory (after garbage collection) - falls below this limit, the system is in serious danger of completely exhausting memory and - crashing. This limit should be made high enough to allow the user open a debugger to diagnose - a problem or to save the image. In a stack-based VM such as Cog contexts for activations in - the stack zone will have to be created as the debugger opens, requiring additional headroom." - - | slotsForDebugger slotsForContextsOnStackPages | - slotsForDebugger := 65536. "Arbitrary guess" - slotsForContextsOnStackPages := - (self vmParameterAt: 42) - ifNil: [0] - ifNotNil: - [:numStackPages| | headerSize numActivationsPerPage maxContextSize | - numActivationsPerPage := 40. "Design goal of the Cog VM" - headerSize := 2. "64-bytes for Spur" - maxContextSize := MethodContext instSize + CompiledMethod fullFrameSize + headerSize. - numStackPages * numActivationsPerPage * maxContextSize]. - ^slotsForDebugger + slotsForContextsOnStackPages * self wordSize! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3003-FixFor64BitSpur-JuanVuletich-2016Dec19-12h41m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3002] on 19 December 2016 at 12:54:39 pm'! -!Parser methodsFor: 'primitives' stamp: 'nice 9/6/2013 00:48' prior: 16885817! - externalFunctionDeclaration - "Parse the function declaration for a call to an external library." - | descriptorClass callType modifier retType externalName args argType module fn | - descriptorClass := Smalltalk at: #ExternalFunction ifAbsent: [ ^ false ]. - callType := descriptorClass callingConventionFor: here. - callType == nil ifTrue:[^false]. - [modifier := descriptorClass callingConventionModifierFor: token. - modifier notNil] whileTrue: - [self advance. - callType := callType bitOr: modifier]. - "Parse return type" - self advance. - retType := self externalType: descriptorClass. - retType == nil ifTrue:[^self expected:'return type']. - "Parse function name or index" - externalName := here. - (self match: #string) - ifTrue:[externalName := externalName asSymbol] - ifFalse:[(self match:#number) ifFalse:[^self expected:'function name or index']]. - (self match: #leftParenthesis) ifFalse:[^self expected:'argument list']. - args := WriteStream on: Array new. - [self match: #rightParenthesis] whileFalse:[ - argType := self externalType: descriptorClass. - argType == nil ifTrue:[^self expected:'argument']. - argType isVoid & argType isPointerType not ifFalse:[args nextPut: argType]]. - (self matchToken: 'module:') ifTrue:[ - module := here. - (self match: #string) ifFalse:[^self expected: 'String']. - module := module asSymbol]. - Smalltalk at: #ExternalLibraryFunction ifPresent:[:xfn| - fn := xfn name: externalName - module: module - callType: callType - returnType: retType - argumentTypes: args contents. - self allocateLiteral: fn]. - (self matchToken: 'error:') - ifTrue: - [| errorCodeVariable | - errorCodeVariable := here. - (hereType == #string - or: [hereType == #word]) ifFalse:[^self expected: 'error code (a variable or string)']. - self advance. - self addPragma: (Pragma keyword: #primitive:error: arguments: (Array with: 120 with: errorCodeVariable)). - fn ifNotNil: [fn setErrorCodeName: errorCodeVariable]] - ifFalse: - [self addPragma: (Pragma keyword: #primitive: arguments: #(120))]. - ^true! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3004-externalFunctionDeclaration-JuanVuletich-2016Dec19-12h44m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3002] on 19 December 2016 at 1:08:36 pm'! - -SmallInteger class - instanceVariableNames: 'minVal maxVal '! - -!classDefinition: 'SmallInteger class' category: #'Kernel-Numbers'! -SmallInteger class - instanceVariableNames: 'minVal maxVal'! -!SmallInteger class methodsFor: 'class initialization' stamp: 'jmv 12/19/2016 13:03:09'! - initMinValAndMaxVal - | next val | - val := -32768. "Assume at least 16 bits" - [next := val + val. - next class == self] whileTrue: - [val := next]. - minVal := val. - maxVal := -1 - val! ! -!SystemDictionary methodsFor: 'image' stamp: 'jmv 12/19/2016 13:04:12' prior: 16925538! - wordSize - "Answer the size in bytes of an object pointer or word in the object memory. - The value does not change for a given image, but may be modified by a SystemTracer - when converting the image to another format. The value is cached in WordSize to - avoid the performance overhead of repeatedly consulting the VM." - - "Smalltalk wordSize" - - ^ WordSize ifNil: [ - SmallInteger initMinValAndMaxVal. - WordSize := [self vmParameterAt: 40] on: Error do: [4]]! ! - -SmallInteger class - instanceVariableNames: 'minVal maxVal'! - -!classDefinition: 'SmallInteger class' category: #'Kernel-Numbers'! -SmallInteger class - instanceVariableNames: 'minVal maxVal'! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -SmallInteger initMinValAndMaxVal! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3005-SmallInteger-minVal-maxVal-part1-JuanVuletich-2016Dec19-12h54m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3005] on 19 December 2016 at 1:12:20 pm'! -!SmallInteger class methodsFor: 'constants' stamp: 'jmv 12/19/2016 13:06:38' prior: 16909182! - maxVal - "Answer the maximum value for a SmallInteger." - - "Ensure word size is properly set. If so, maxVal is also set." - Smalltalk wordSize. - ^maxVal! ! -!SmallInteger class methodsFor: 'constants' stamp: 'jmv 12/19/2016 13:07:24' prior: 16909186! - minVal - "Answer the minimum value for a SmallInteger." - - "Ensure word size is properly set. If so, minVal is also set." - Smalltalk wordSize. - ^minVal! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3006-SmallInteger-minVal-maxVal-part2-JuanVuletich-2016Dec19-13h11m-jmv.1.cs.st----! - -----SNAPSHOT----#(19 December 2016 1:35:50.759973 pm) Cuis5.0-3006.image priorSource: 54639! - -----QUIT----#(19 December 2016 1:36:04.087323 pm) Cuis5.0-3006.image priorSource: 62549! - -----STARTUP----#(19 December 2016 1:44:23.302825 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3006.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3006] on 19 December 2016 at 1:42:27 pm'! -!SmallFloat64 commentStamp: '' prior: 16908181! - My instances represent 64-bit Floats whose exponent fits in 8 bits as immediate objects. This representation is only available on 64-bit systems, not 32-bit systems.! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -SmallFloat64 tryPrimitive: 161 withArgs: #(999). -! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3007-SmallFloat64-fixHash-forSpur64Conversion-JuanVuletich-2016Dec19-13h41m-jmv.1.cs.st----! - -----SNAPSHOT----#(19 December 2016 1:44:31.161473 pm) Cuis5.0-3007.image priorSource: 62643! - -----QUIT----#(19 December 2016 1:44:42.243314 pm) Cuis5.0-3007.image priorSource: 63669! - -----STARTUP----#(2 January 1901 12:00:00.287686024 am) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3007.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3007] on 22 December 2016 at 4:05:04 pm'! -!LargePositiveInteger methodsFor: 'testing' stamp: 'nice 8/31/2008 00:07'! - isLarge - ^true! ! -!SmallInteger methodsFor: 'testing' stamp: 'nice 8/31/2008 00:07'! - isLarge - ^false! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/27/2015 23:01'! - long64At: index bigEndian: bigEndian - "Return a 64-bit signed integer quantity starting from the given byte index." - - | value | - value := self unsignedLong64At: index bigEndian: bigEndian. - value digitLength < 8 ifTrue: [ ^value ]. - (value digitAt: 8) < 16r80 ifTrue: [ ^value ]. - ^value - 16r10000000000000000! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/27/2015 22:57'! - long64At: index put: value bigEndian: bigEndian - "Store a 64-bit signed integer quantity starting from the given byte index." - - ^self - unsignedLong64At: index - put: (value negative - ifFalse: [ value ] - ifTrue: [ value + 16r10000000000000000 ]) - bigEndian: bigEndian! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'eem 2/22/2016 09:36'! - unsignedLong64At: index bigEndian: bigEndian - "Return a 64-bit unsigned integer quantity starting from the given byte index. Use #normalize where necessary to ensure compatibility with non-30-bit SmallIntegers." - - | byte | - SmallInteger maxVal > 1073741823 ifTrue: - [bigEndian - ifTrue: "64-bit SmallIntegers have a 3 bit tag and a sign bit, so the most positive value has 16rF as its top byte." - [(byte := self at: index) <= 16rF ifTrue: - [^((((((((byte bitShift: 8) + (self at: index + 1) bitShift: 8) + (self at: index + 2) bitShift: 8) + (self at: index + 3)) bitShift: 8) - + (self at: index + 4) bitShift: 8) + (self at: index + 5) bitShift: 8) + (self at: index + 6) bitShift: 8) + (self at: index + 7)]] - ifFalse: - [(byte := self at: index + 7) <= 16rF ifTrue: - [^((((((((byte bitShift: 8) + (self at: index + 6) bitShift: 8) + (self at: index + 5) bitShift: 8) + (self at: index + 4)) bitShift: 8) - + (self at: index + 3) bitShift: 8) + (self at: index + 2) bitShift: 8) + (self at: index + 1) bitShift: 8) + (self at: index)]]]. - bigEndian ifFalse: [ - (byte := self at: index + 7) = 0 ifFalse: [ - ^(LargePositiveInteger new: 8) - replaceFrom: 1 to: 8 with: self startingAt: index; - normalize ]. - (byte := self at: index + 6) = 0 ifFalse: [ - ^(LargePositiveInteger new: 7) - replaceFrom: 1 to: 7 with: self startingAt: index; - normalize ]. - (byte := self at: index + 5) = 0 ifFalse: [ - ^(LargePositiveInteger new: 6) - replaceFrom: 1 to: 6 with: self startingAt: index; - normalize ]. - (byte := self at: index + 4) = 0 ifFalse: [ - ^(LargePositiveInteger new: 5) - replaceFrom: 1 to: 5 with: self startingAt: index; - normalize ]. - (byte := self at: index + 3) <= 16r3F ifFalse: [ - ^(LargePositiveInteger new: 4) - replaceFrom: 1 to: 4 with: self startingAt: index; - normalize ]. - ^(((byte bitShift: 8) + (self at: index + 2) bitShift: 8) + (self at: index + 1) bitShift: 8) + (self at: index) ]. - (byte := self at: index) = 0 ifFalse: [ - ^(LargePositiveInteger new: 8) - digitAt: 1 put: (self at: index + 7); - digitAt: 2 put: (self at: index + 6); - digitAt: 3 put: (self at: index + 5); - digitAt: 4 put: (self at: index + 4); - digitAt: 5 put: (self at: index + 3); - digitAt: 6 put: (self at: index + 2); - digitAt: 7 put: (self at: index + 1); - digitAt: 8 put: byte; - normalize ]. - (byte := self at: index + 1) = 0 ifFalse: [ - ^(LargePositiveInteger new: 7) - digitAt: 1 put: (self at: index + 7); - digitAt: 2 put: (self at: index + 6); - digitAt: 3 put: (self at: index + 5); - digitAt: 4 put: (self at: index + 4); - digitAt: 5 put: (self at: index + 3); - digitAt: 6 put: (self at: index + 2); - digitAt: 7 put: byte; - normalize ]. - (byte := self at: index + 2) = 0 ifFalse: [ - ^(LargePositiveInteger new: 6) - digitAt: 1 put: (self at: index + 7); - digitAt: 2 put: (self at: index + 6); - digitAt: 3 put: (self at: index + 5); - digitAt: 4 put: (self at: index + 4); - digitAt: 5 put: (self at: index + 3); - digitAt: 6 put: byte; - normalize ]. - (byte := self at: index + 3) = 0 ifFalse: [ - ^(LargePositiveInteger new: 5) - digitAt: 1 put: (self at: index + 7); - digitAt: 2 put: (self at: index + 6); - digitAt: 3 put: (self at: index + 5); - digitAt: 4 put: (self at: index + 4); - digitAt: 5 put: byte; - normalize ]. - (byte := self at: index + 4) <= 16r3F ifFalse: [ - ^(LargePositiveInteger new: 4) - digitAt: 1 put: (self at: index + 7); - digitAt: 2 put: (self at: index + 6); - digitAt: 3 put: (self at: index + 5); - digitAt: 4 put: byte; - normalize ]. - ^(((byte bitShift: 8) + (self at: index + 5) bitShift: 8) + (self at: index + 6) bitShift: 8) + (self at: index + 7)! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/9/2015 20:18'! - unsignedLong64At: index put: value bigEndian: bigEndian - "Store a 64-bit unsigned integer quantity starting from the given byte index" - - | i j | - value isLarge ifTrue: [ - i := value digitLength. - bigEndian ifFalse: [ - self - replaceFrom: index - to: index + i - 1 - with: value - startingAt: 1; - replaceFrom: index + i - to: index + 7 - with: #[0 0 0 0 0 0 0 0] - startingAt: 1. - ^value ]. - j := index + 8. - i <= 7 ifTrue: [ - self - replaceFrom: index - to: j - i - 1 - with: #[0 0 0 0 0 0 0 0] - startingAt: 1 ]. - [ 1 <= i ] whileTrue: [ - self at: j - i put: (value digitAt: i). - i := i - 1 ]. - ^value ]. - bigEndian ifFalse: [ - j := index - 1. - i := value. - [ 1 <= i ] whileTrue: [ - self at: (j := j + 1) put: (i bitAnd: 16rFF). - i := i bitShift: -8 ]. - self replaceFrom: j + 1 - to: index + 7 - with: #[0 0 0 0 0 0 0 0] - startingAt: 1. - ^value ]. - j := index + 8. - i := value. - [ 1 <= i ] whileTrue: [ - self at: (j := j - 1) put: (i bitAnd: 16rFF). - i := i bitShift: -8 ]. - self replaceFrom: index - to: j - 1 - with: #[0 0 0 0 0 0 0 0] - startingAt: 1. - ^value! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/9/2015 20:28' prior: 16793638! - longAt: index bigEndian: bigEndian - "Return a 32-bit integer quantity starting from the given byte index. Use #normalize where necessary to ensure compatibility with non-30-bit SmallIntegers." - - | byte result | - bigEndian ifFalse: [ - (byte := self at: index + 3) <= 16r7F ifTrue: [ "Is the result non-negative?" - byte <= 16r3F ifTrue: [ - ^(((byte bitShift: 8) + (self at: index + 2) bitShift: 8) + (self at: index + 1) bitShift: 8) + (self at: index) ]. - ^(LargePositiveInteger new: 4) - replaceFrom: 1 - to: 4 - with: self - startingAt: index; - normalize ]. - "Negative" - byte >= 16rC0 ifTrue: [ - ^-1 - (((((byte bitShift: 8) + (self at: index + 2) bitShift: 8) + (self at: index + 1) bitXor: 16rFFFFFF) bitShift: 8) + ((self at: index) bitXor: 16rFF)) ]. - (result := LargeNegativeInteger new: 4) - digitAt: 4 put: ((self at: index + 3) bitXor: 16rFF); - digitAt: 3 put: ((self at: index + 2) bitXor: 16rFF); - digitAt: 2 put: ((self at: index + 1) bitXor: 16rFF). - (byte := ((self at: index) bitXor: 16rFF) + 1) <= 16rFF ifTrue: [ - ^result - digitAt: 1 put: byte; - normalize ]. - ^result - digitAt: 1 put: 16rFF; - - 1 "It's tempting to do the subtraction in a loop to avoid the LargeInteger creation, but it's actually slower than this." ]. - (byte := self at: index) <= 16r7F ifTrue: [ "Is the result non-negative?" - byte <= 16r3F ifTrue: [ - ^(((byte bitShift: 8) + (self at: index + 1) bitShift: 8) + (self at: index + 2) bitShift: 8) + (self at: index + 3) ]. - ^(LargePositiveInteger new: 4) - digitAt: 1 put: (self at: index + 3); - digitAt: 2 put: (self at: index + 2); - digitAt: 3 put: (self at: index + 1); - digitAt: 4 put: byte; - normalize ]. - "Negative" - 16rC0 <= byte ifTrue: [ - ^-1 - (((((byte bitShift: 8) + (self at: index + 1) bitShift: 8) + (self at: index + 2) bitXor: 16rFFFFFF) bitShift: 8) + ((self at: index + 3) bitXor: 16rFF)) ]. - (result := LargeNegativeInteger new: 4) - digitAt: 4 put: (byte bitXor: 16rFF); - digitAt: 3 put: ((self at: index + 1) bitXor: 16rFF); - digitAt: 2 put: ((self at: index + 2) bitXor: 16rFF). - (byte := ((self at: index + 3) bitXor: 16rFF) + 1) <= 16rFF ifTrue: [ - ^result - digitAt: 1 put: byte; - normalize ]. - ^result - digitAt: 1 put: 16rFF; - - 1 "It's tempting to do the subtraction in a loop to avoid the LargeInteger creation, but it's actually slower than this."! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/6/2015 17:13' prior: 16793658! - longAt: index put: value bigEndian: bigEndian - "Store a 32-bit signed integer quantity starting from the given byte index" - - | v v2 | - value isLarge ifTrue: [ - bigEndian ifFalse: [ - value positive ifTrue: [ - self - replaceFrom: index - to: index + 3 - with: value - startingAt: 1. - ^value ]. - v := 0. - [ v <= 3 and: [ (v2 := ((value digitAt: v + 1) bitXor: 16rFF) + 1) = 16r100 ] ] whileTrue: [ - self at: index + v put: 0. - v := v + 1 ]. - self at: index + v put: v2. - v := v + 1. - [ v <= 3 ] whileTrue: [ - self at: index + v put: ((value digitAt: (v := v + 1)) bitXor: 16rFF) ]. - ^value ]. - value positive ifTrue: [ - self - at: index put: (value digitAt: 4); - at: index + 1 put: (value digitAt: 3); - at: index + 2 put: (value digitAt: 2); - at: index + 3 put: (value digitAt: 1). - ^value ]. - v := 3. - [ 0 <= v and: [ (v2 := ((value digitAt: 4 - v) bitXor: 16rFF) + 1) = 16r100 ] ] whileTrue: [ - self at: index + v put: 0. - v := v - 1 ]. - self at: index + v put: v2. - [ 0 <= (v := v - 1) ] whileTrue: [ - self at: index + v put: ((value digitAt: 4 - v) bitXor: 16rFF) ]. - ^value ]. - v := value bitShift: -24. - 0 <= (v := (v bitAnd: 16r7F) - (v bitAnd: 16r80)) ifFalse: [ - v := v + 16r100 ]. - bigEndian ifFalse: [ - self - at: index put: (value bitAnd: 16rFF); - at: index + 1 put: ((value bitShift: -8) bitAnd: 16rFF); - at: index + 2 put: ((value bitShift: -16) bitAnd: 16rFF); - at: index + 3 put: v. - ^value ]. - self - at: index put: v; - at: index + 1 put: ((value bitShift: -16) bitAnd: 16rFF); - at: index + 2 put: ((value bitShift: -8) bitAnd: 16rFF); - at: index + 3 put: (value bitAnd: 16rFF). - ^value! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/6/2015 23:16' prior: 16793680! - shortAt: index bigEndian: bigEndian - "Return a 16-bit signed integer quantity starting from the given byte index" - - | result | - result := bigEndian - ifFalse: [ ((self at: index + 1) bitShift: 8) + (self at: index) ] - ifTrue: [ ((self at: index) bitShift: 8) + (self at: index + 1) ]. - result < 16r8000 ifTrue: [ ^result ]. - ^result - 16r10000! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/6/2015 23:16' prior: 16793690! - shortAt: index put: value bigEndian: bigEndian - "Store a 16-bit signed integer quantity starting from the given byte index" - - | unsignedValue | - (unsignedValue := value) < 0 ifTrue: [ - unsignedValue := unsignedValue + 16r10000 ]. - bigEndian ifFalse: [ - self - at: index + 1 put: (unsignedValue bitShift: -8); - at: index put: (unsignedValue bitAnd: 16rFF). - ^value ]. - self - at: index put: (unsignedValue bitShift: -8); - at: index + 1 put: (unsignedValue bitAnd: 16rFF). - ^value! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'eem 2/22/2016 09:20' prior: 16793700! - unsignedLongAt: index bigEndian: bigEndian - "Return a 32-bit unsigned integer quantity starting from the given byte index. Use #normalize where necessary to ensure compatibility with non-30-bit SmallIntegers." - | byte | - bigEndian ifTrue: - [((byte := self at: index) <= 16r3F - or: [SmallInteger maxVal > 1073741823]) ifTrue: - [^(((byte bitShift: 8) + (self at: index + 1) bitShift: 8) + (self at: index + 2) bitShift: 8) + (self at: index + 3)]. - ^(LargePositiveInteger new: 4) - digitAt: 1 put: (self at: index + 3); - digitAt: 2 put: (self at: index + 2); - digitAt: 3 put: (self at: index + 1); - digitAt: 4 put: byte; - normalize]. - ((byte := self at: index + 3) <= 16r3F - or: [SmallInteger maxVal > 1073741823]) ifTrue: - [^(((byte bitShift: 8) + (self at: index + 2) bitShift: 8) + (self at: index + 1) bitShift: 8) + (self at: index)]. - ^(LargePositiveInteger new: 4) - replaceFrom: 1 to: 4 with: self startingAt: index; - normalize! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/3/2015 01:33' prior: 16793720! - unsignedLongAt: index put: value bigEndian: bigEndian - "Store a 32-bit unsigned integer quantity starting from the given byte index" - - value isLarge - ifTrue: [ - bigEndian ifFalse: [ - self - replaceFrom: index - to: index + 3 - with: value - startingAt: 1. - ^value ]. - self - at: index put: (value digitAt: 4); - at: index + 1 put: (value digitAt: 3); - at: index + 2 put: (value digitAt: 2); - at: index +3 put: (value digitAt: 1) ] - ifFalse: [ - bigEndian ifFalse: [ - self - at: index put: (value bitAnd: 16rFF); - at: index + 1 put: ((value bitShift: -8) bitAnd: 16rFF); - at: index + 2 put: ((value bitShift: -16) bitAnd: 16rFF); - at: index + 3 put: (value bitShift: -24). - ^value ]. - self - at: index put: (value bitShift: -24); - at: index + 1 put: ((value bitShift: -16) bitAnd: 16rFF); - at: index + 2 put: ((value bitShift: -8) bitAnd: 16rFF); - at: index + 3 put: (value bitAnd: 16rFF) ]. - ^value! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/3/2015 01:33' prior: 16793740! - unsignedShortAt: index bigEndian: bigEndian - "Return a 16-bit unsigned integer quantity starting from the given byte index" - - bigEndian ifFalse: [ ^((self at: index + 1) bitShift: 8) + (self at: index) ]. - ^((self at: index) bitShift: 8) + (self at: index + 1) - ! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/3/2015 15:29' prior: 16793751! - unsignedShortAt: index put: value bigEndian: bigEndian - "Store a 16-bit unsigned integer quantity starting from the given byte index" - - bigEndian ifFalse: [ - self - at: index + 1 put: (value bitShift: -8); - at: index put: (value bitAnd: 16rFF). - ^value ]. - self - at: index put: (value bitShift: -8); - at: index+1 put: (value bitAnd: 16rFF). - ^value! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3008-ByteArray-UpdateToSqueak-JuanVuletich-2016Dec22-15h54m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3008] on 26 December 2016 at 2:54:38 pm'! -!Float64Array methodsFor: 'accessing' stamp: 'jmv 12/26/2016 14:53:06' prior: 16846088! - floatAt: index put: aFloat - "Store the argument (e.g., 64 bit Float) at the given index - Use the same internal representation as BoxedFloat64. I.e. a BoxedFloat64 and a Float64Array of size 1 hold the same bits. - Allow subclasses to redefine #at:put:" - - "This breaks with SmallFloat64" - "self replaceWordsFrom: index * 2 - 1 to: index * 2 with: aFloat asFloat startingAt: 1." - - "Float >>basicAt: acts as if Floats were stored in big endian format. Our instances are in platform endianess." - Smalltalk isLittleEndian - ifTrue: [ - self basicAt: index * 2 - 1 put: (aFloat basicAt: 2). - self basicAt: index * 2 put: (aFloat basicAt: 1) ] - ifFalse: [ - self basicAt: index * 2 - 1 put: (aFloat basicAt: 1). - self basicAt: index * 2 put: (aFloat basicAt: 2) ]. - ^aFloat! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3009-Float64Array-fixForSmallFloats-JuanVuletich-2016Dec26-14h53m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3009] on 27 December 2016 at 12:14:57 pm'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 12/27/2016 12:14:33' prior: 16922764! - saveAsNewVersion - "Save the image/changes using the next available version number." - " - Smalltalk saveAsNewVersion - " - | fileName newName changesName systemVersion | - self okayToSave ifFalse: [ ^ self ]. - systemVersion _ SystemVersion current. - fileName _ String streamContents: [ :strm | - strm - nextPutAll: 'Cuis'; - print: systemVersion versionMajor; - nextPut: $.; - print: systemVersion versionMinor; - nextPut: $-; - print: systemVersion highestUpdate. - Smalltalk isSpur ifTrue: [ - strm nextPutAll: '-spur'. - Smalltalk wordSize = 8 ifTrue: [ - strm nextPutAll: '-64' ]]]. - newName _ fileName, '.image'. - (DirectoryEntry smalltalkImageDirectory // newName) exists ifTrue: [ - newName _ DirectoryEntry smalltalkImageDirectory - nextNameFor: fileName - extension: 'image' ]. - changesName _ self fullNameForChangesNamed: newName. - "Check to see if there is a .changes file that would cause a problem if we saved a new .image file with the new version number" - changesName asFileEntry exists ifTrue: [ - ^ self inform: -'There is already .changes file of the desired name, -', newName, ' -curiously already present, even though there is -no corresponding .image file. Please remedy -manually and then repeat your request.' ]. - "Try to clear all user state, including all class vars, preferences, etc" - self saveAs: newName andQuit: false clearAllClassState: true! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3010-saveAsNewVersion-spur64-JuanVuletich-2016Dec27-12h14m-jmv.1.cs.st----! - -----SNAPSHOT----#(2 January 1901 12:00:00.287686028 am) Cuis5.0-3010.image priorSource: 63763! - -----QUIT----#(2 January 1901 12:00:01.300992248 am) Cuis5.0-3010.image priorSource: 81495! - -----STARTUP----#(1 January 1901 12:00:01.008123888 am) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3010.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3009] on 27 December 2016 at 9:51:30 am'! -!Float64Array methodsFor: 'accessing' stamp: 'jmv 12/27/2016 09:51:21' prior: 50334111! - floatAt: index put: aNumber - "Store the argument (e.g., 64 bit Float) at the given index - Use the same internal representation as BoxedFloat64. I.e. a BoxedFloat64 and a Float64Array of size 1 hold the same bits. - Allow subclasses to redefine #at:put:" - - "This breaks with SmallFloat64" - "self replaceWordsFrom: index * 2 - 1 to: index * 2 with: aFloat asFloat startingAt: 1." - - "Float >>basicAt: acts as if Floats were stored in big endian format. Our instances are in platform endianess." - | aFloat | - aFloat _ aNumber asFloat. - Smalltalk isLittleEndian - ifTrue: [ - self basicAt: index * 2 - 1 put: (aFloat basicAt: 2). - self basicAt: index * 2 put: (aFloat basicAt: 1) ] - ifFalse: [ - self basicAt: index * 2 - 1 put: (aFloat basicAt: 1). - self basicAt: index * 2 put: (aFloat basicAt: 2) ]. - ^aFloat! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3011-Float64Array-fixForSmallIntegers-JuanVuletich-2016Dec27-09h51m-jmv.1.cs.st----! - -----SNAPSHOT----#(2 January 1901 12:00:01.758557225 am) Cuis5.0-3011.image priorSource: 81591! - -----QUIT----#(2 January 1901 12:00:00.91421204 am) Cuis5.0-3011.image priorSource: 82989! - -----STARTUP----#(18 January 2017 10:33:47.310842 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3011.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3011] on 29 December 2016 at 11:02:24 am'! - -PluggableScrollPane subclass: #HierarchicalListMorph - instanceVariableNames: 'selectedMorph getListSelector keystrokeActionSelector autoDeselect autoExpand sortingSelector getSelectionSelector setSelectionSelector menuGetter mainView highlightedMorph doubleClickSelector ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #HierarchicalListMorph category: #'Morphic-Views'! -PluggableScrollPane subclass: #HierarchicalListMorph - instanceVariableNames: 'selectedMorph getListSelector keystrokeActionSelector autoDeselect autoExpand sortingSelector getSelectionSelector setSelectionSelector menuGetter mainView highlightedMorph doubleClickSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! -!Inspector methodsFor: 'user commands' stamp: 'jmv 12/29/2016 10:58:58'! - inspectSelection - self selection inspect! ! -!ObjectExplorer methodsFor: 'user commands' stamp: 'jmv 12/29/2016 11:01:35'! - inspectSelection - self object inspect! ! -!HierarchicalListMorph methodsFor: 'events' stamp: 'jmv 12/29/2016 10:55:06'! - doubleClick: aMouseButtonEvent localPosition: localEventPosition - - doubleClickSelector ifNil: [ ^super doubleClick: aMouseButtonEvent localPosition: localEventPosition ]. - ^ self model perform: doubleClickSelector! ! -!HierarchicalListMorph methodsFor: 'initialization' stamp: 'jmv 12/29/2016 10:55:42'! - doubleClickSelector: aSymbol - doubleClickSelector _ aSymbol! ! -!PluggableListMorph methodsFor: 'initialization' stamp: 'jmv 12/29/2016 10:41:28'! - doubleClickSelector: aSymbol - doubleClickSelector _ aSymbol! ! -!HierarchicalListMorph methodsFor: 'events' stamp: 'jmv 12/29/2016 10:53:49' prior: 16853080! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - - | itemMorph | - aMouseButtonEvent hand newKeyboardFocus: self. - itemMorph _ self itemFromPoint: localEventPosition. - itemMorph ifNil: [ ^super mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition ]. - self highlightedMorph: itemMorph. - (itemMorph inToggleArea: (itemMorph internalize: (scroller internalize: localEventPosition))) - ifTrue: [ ^self toggleExpandedState: itemMorph event: aMouseButtonEvent ]. - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: #click:localPosition: - clkNHalf: nil - dblClkSel: (doubleClickSelector ifNotNil: [ #doubleClick:localPosition: ]) - dblClkNHalfSel: nil - tripleClkSel: nil! ! -!DebuggerWindow methodsFor: 'GUI building' stamp: 'jmv 12/29/2016 10:59:15' prior: 16831023! - buildMorphicWindow - "Open a full morphic debugger with the given label" - - | upperMorph receiverInspector receiverInspectorText contextVariableInspector contextVariableInspectorText bottomMorph | - - upperMorph _ PluggableListMorph - model: model - listGetter: #contextStackList - indexGetter: #contextStackIndex - indexSetter: #toggleContextStackIndex: - mainView: self - menuGetter: #contextStackMenu - keystrokeAction: #contextStackKey:from:. - - receiverInspector _ PluggableListMorph - model: model receiverInspector - listGetter: #fieldList - indexGetter: #selectionIndex - indexSetter: #toggleIndex: - mainView: self - menuGetter: #receiverFieldListMenu - keystrokeAction: #inspectorKey:from:. - receiverInspector doubleClickSelector: #inspectSelection. - receiverInspectorText _ TextModelMorph - textProvider: model receiverInspector - textGetter: #acceptedContents - textSetter: #accept: - selectionGetter: #contentsSelection. - contextVariableInspector _ PluggableListMorph - model: model contextVariablesInspector - listGetter: #fieldList - indexGetter: #selectionIndex - indexSetter: #toggleIndex: - mainView: self - menuGetter: #contextFieldListMenu - keystrokeAction: #inspectorKey:from:. - contextVariableInspector doubleClickSelector: #inspectSelection. - contextVariableInspectorText _ TextModelMorph - textProvider: model contextVariablesInspector - textGetter: #acceptedContents - textSetter: #accept: - selectionGetter: #contentsSelection. - - bottomMorph _ LayoutMorph newRow. - bottomMorph - addMorph: receiverInspector proportionalWidth: 0.2; - addAdjusterAndMorph: receiverInspectorText proportionalWidth: 0.3; - addAdjusterAndMorph: contextVariableInspector proportionalWidth: 0.2; - addAdjusterAndMorph: contextVariableInspectorText proportionalWidth: 0.3. - - self layoutMorph - addMorph: upperMorph proportionalHeight: 0.25; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.55; - addAdjusterAndMorph: bottomMorph proportionalHeight: 0.2! ! -!InspectorWindow methodsFor: 'GUI building' stamp: 'jmv 12/29/2016 11:00:06' prior: 16857200! - buildMorphicWindow - " Inspector openOn: SystemOrganization " - | contentsText list upperRow evaluatorText label | - "Build widgets. We'll assemble them below." - list _ PluggableListMorph - model: model - listGetter: #fieldList - indexGetter: #selectionIndex - indexSetter: #toggleIndex: - mainView: self - menuGetter: #fieldListMenu - keystrokeAction: #inspectorKey:from:. - list doubleClickSelector: #inspectSelection. - contentsText _ TextModelMorph - textProvider: model - textGetter: #acceptedContents - textSetter: #accept: - selectionGetter: #contentsSelection. - evaluatorText _ (TextModelMorph textProvider: model) - askBeforeDiscardingEdits: false. - "Upper row has two widgets, side by side: the list of variables at the left side, and the variable contents pane at the right side." - upperRow _ LayoutMorph newRow. - upperRow - addMorph: list proportionalWidth: 0.3; - addAdjusterAndMorph: contentsText proportionalWidth: 0.7. - "Inspector Window has two rows: At the top, the one we just bult. Below it, the evaluation pane." - self layoutMorph - addMorph: upperRow proportionalHeight: 0.7; - addAdjusterAndMorph: evaluatorText proportionalHeight: 0.3. - "Set label" - label _ [model object printStringLimitedTo: 64] - on: UnhandledError - do: [:ex | ex return: model object class printString, ' (printing failed)']. - (label includesSubString: model object class name) - ifFalse: [label _ model object class name, ': ', label]. - self setLabel: label! ! -!ObjectExplorerWindow methodsFor: 'GUI building' stamp: 'jmv 12/29/2016 11:00:46' prior: 16883288! -buildMorphicWindow - - | textMorph | - listMorph _ HierarchicalListMorph - model: model - listGetter: #getList - indexGetter: #getCurrentSelection - indexSetter: #noteNewSelection: - mainView: self - menuGetter: #genericMenu - keystrokeAction: #explorerKey:from:. - listMorph autoDeselect: false. - listMorph doubleClickSelector: #inspectSelection. - textMorph _ (TextModelMorph textProvider: model) - askBeforeDiscardingEdits: false. - self layoutMorph - addMorph: listMorph proportionalHeight: 0.8; - addAdjusterAndMorph: textMorph proportionalHeight: 0.2. - self setLabel: (model rootObject printStringLimitedTo: 64)! ! -!ObjectExplorerWindow methodsFor: 'menu commands' stamp: 'jmv 12/29/2016 10:50:28' prior: 16883479! - openWeightExplorer - "Create and schedule a Weight Explorer on the receiver's model's currently selected object." - - ^WeightTracer openExplorerOn: model object! ! - -PluggableScrollPane subclass: #HierarchicalListMorph - instanceVariableNames: 'selectedMorph getListSelector keystrokeActionSelector autoDeselect autoExpand sortingSelector getSelectionSelector setSelectionSelector menuGetter mainView highlightedMorph doubleClickSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #HierarchicalListMorph category: #'Morphic-Views'! -PluggableScrollPane subclass: #HierarchicalListMorph - instanceVariableNames: 'selectedMorph getListSelector keystrokeActionSelector autoDeselect autoExpand sortingSelector getSelectionSelector setSelectionSelector menuGetter mainView highlightedMorph doubleClickSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3012-DoubleClickOpensInspector-JuanVuletich-2016Dec29-10h36m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3012] on 29 December 2016 at 11:30:18 am'! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 12/29/2016 11:29:52' prior: 16902537! - parseExternalCall - self scanNext. - self failWhen: currentToken isNil. - self scanPast: #externalCallType. - currentToken = '*' - ifTrue: [self scanPast: #externalCallTypePointerIndicator]. - currentTokenFirst isDigit - ifTrue: [self scanPast: #integer] - ifFalse: [ - self failUnless: currentTokenFirst == $'. - self parseString]. - self failUnless: currentTokenFirst == $(. - self scanPast: #leftParenthesis. - [currentTokenFirst ~~ $)] - whileTrue: [ - self failWhen: currentToken isNil. - self scanPast: #externalCallType. - currentToken = '*' - ifTrue: [self scanPast: #externalCallTypePointerIndicator]]. - self scanPast: #rightParenthesis. - currentToken = 'module:' - ifTrue: [ - self scanPast: #module. - self failUnless: currentTokenFirst == $'. - self parseString]. - self failUnless: currentToken = '>'. - self scanPast: #primitiveOrExternalCallEnd! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3013-Shout-ExternalCallFix-JuanVuletich-2016Dec29-11h29m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3013] on 29 December 2016 at 3:36:31 pm'! -!CompiledMethod methodsFor: 'file in/out' stamp: 'jmv 12/29/2016 15:25:13' prior: 16820644! - storeDataOn: aDataStream - "Store myself on a DataStream. I am a mixture of objects and raw data bytes. Only use this for blocks. Normal methodDictionaries should not be put out using ReferenceStreams. Their fileOut should be attached to the beginning of the file." - - | byteLength lits | - "No inst vars of the normal type" - byteLength _ self basicSize. - aDataStream - beginInstance: self class - size: byteLength. - lits _ self numLiterals + 1. "counting header" - 1 to: lits do: - [:ii | aDataStream nextPut: (self objectAt: ii)]. - lits*Smalltalk wordSize+1 to: byteLength do: - [:ii | aDataStream byteStream nextPut: (self basicAt: ii)]. - "write bytes straight through to the file"! ! -!DataStream methodsFor: 'write and read' stamp: 'jmv 12/29/2016 15:27:40' prior: 16827456! - readMethod - "PRIVATE -- Read the contents of an arbitrary instance. - ASSUMES: readDataFrom:size: sends me beginReference: after it - instantiates the new object but before reading nested objects. - NOTE: We must restore the current reference position after - recursive calls to next. - Let the instance, not the class read the data. " - | instSize refPosn newClass className xxHeader nLits byteCodeSizePlusTrailer newMethod lits | - - instSize _ (byteStream nextUnsignedInt32BigEndian: true) - 1. - refPosn _ self getCurrentReference. - className _ self next. - newClass _ Smalltalk at: className asSymbol. - - xxHeader _ self next. - "nArgs _ (xxHeader >> 24) bitAnd: 16rF." - "nTemps _ (xxHeader >> 18) bitAnd: 16r3F." - "largeBit _ (xxHeader >> 17) bitAnd: 1." - nLits _ (xxHeader >> 9) bitAnd: 16rFF. - "primBits _ ((xxHeader >> 19) bitAnd: 16r600) + (xxHeader bitAnd: 16r1FF)." - byteCodeSizePlusTrailer _ instSize - (newClass instSize "0") - (nLits + 1 * Smalltalk wordSize). - - newMethod _ newClass - newMethod: byteCodeSizePlusTrailer - header: xxHeader. - - self setCurrentReference: refPosn. "before readDataFrom:size:" - self beginReference: newMethod. - lits _ newMethod numLiterals + 1. "counting header" - 2 to: lits do: - [:ii | newMethod objectAt: ii put: self next]. - lits*Smalltalk wordSize+1 to: newMethod basicSize do: - [:ii | newMethod basicAt: ii put: byteStream next]. - "Get raw bytes directly from the file" - self setCurrentReference: refPosn. "before returning to next" - ^ newMethod! ! -!DataStream methodsFor: 'other' stamp: 'jmv 12/29/2016 15:36:22' prior: 16827907! - vacantRef - "Answer the magic 32-bit constant we use ***ON DISK*** as a stream 'reference - position' to identify a reference that's not yet filled in. This must be a - value that won't be used as an ordinary reference. Cf. outputReference: and - readReference. -- - NOTE: We could use a different type ID for vacant-refs rather than writing - object-references with a magic value. (The type ID and value are - overwritten by ordinary object-references when weak refs are fullfilled.)" - - "In 32 bit Cuis it was:" - "^ SmallInteger maxVal" - - "Use that very same value even if in 64 bit Cuis. - This means that DataStreams are limited to 1GibiBytes in size." - ^16r3FFFFFFF! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3014-DataStream-FixFor64Bits-JuanVuletich-2016Dec29-15h19m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3000] on 10 December 2016 at 10:41:46 am'! -!Scanner methodsFor: 'multi-character scans' stamp: 'jmv 12/10/2016 01:38:21'! - xBacktick - "Smalltalk code evaluated at compile time as a literal." - - self step. - buffer reset. - [hereChar == $` - and: [aheadChar == $` - ifTrue: [self step. false] - ifFalse: [true]]] - whileFalse: [ - buffer nextPut: self step. - (hereChar = Scanner doItCharacterValue asCharacter and: [source atEnd]) - ifTrue: [^self offEnd: 'Unmatched back quote']]. - self step. - token _ Compiler evaluate: buffer contents. - tokenType _ #literal! ! -!Character methodsFor: 'testing' stamp: 'jmv 12/10/2016 01:26:44' prior: 16800539! - isValidInIdentifiers - "Can c be part of an identifier? (unary or keyword selector, or variable name)" - - ^self isAlphaNumeric or: [ #( $_ ) statePointsTo: self ]! ! -!CompiledMethod methodsFor: 'comparing' stamp: 'jmv 12/10/2016 01:27:06' prior: 16819629! - = method - | numLits lit1 lit2 | - - "Any object is equal to itself" - self == method ifTrue: [ ^ true ]. - - "Answer whether the receiver implements the same code as the - argument, method." - (method is: #CompiledMethod) ifFalse: [ ^false ]. - self size = method size ifFalse: [ ^false ]. - self header = method header ifFalse: [ ^false ]. - self initialPC to: self endPC do: [ :i | - (self at: i) = (method at: i) ifFalse: [ ^false ]]. - (numLits _ self numLiterals) ~= method numLiterals ifTrue: [ ^false ]. - - "Dont bother checking FFI and named primitives'' - jmv: Does this make any sense? - (#(117 120) includes: self primitive) ifTrue: [^ true]." - - "properties" - (self properties analogousCodeTo: method properties) ifFalse: [ - ^false ]. - - "#penultimateLiteral is selector (or properties, just compared, above) - Last literal is #methodClass. - Don't compare them. Two methods might be equal even if they have different selector (or none at all) - or are installed in different classes (or none at all)" - 1 to: numLits-2 do: [ :i | - lit1 _ self literalAt: i. - lit2 _ method literalAt: i. - lit1 = lit2 ifFalse: [ - (i = 1 and: [ #(117 120) includes: self primitive ]) - ifTrue: [ - lit1 isArray - ifTrue: [ - (lit2 isArray and: [ lit1 allButLast = lit2 allButLast ]) ifFalse: [ - ^false ]] - ifFalse: [ "ExternalLibraryFunction" - (lit1 analogousCodeTo: lit2) ifFalse: [ - ^false ]]] - ifFalse: [ - lit1 isFloat - ifTrue: [ - "Floats match if values are close, due to roundoff error." - (lit1 closeTo: lit2) ifFalse: [ ^false ]. - self flag: 'just checking'. self halt ] - ifFalse: [ - "any other discrepancy is a failure" - ^ false ]]]]. - ^true! ! -!Scanner class methodsFor: 'cached class state' stamp: 'jmv 12/10/2016 01:26:17' prior: 16904329! - initTypeTable - | newTable | - newTable := Array new: 256 withAll: #xIllegal. "default" - newTable atAll: #(9 10 12 13 32 ) put: #xDelimiter. "tab lf ff cr space" - - 1 to: 255 - do: [:index | - (Character numericValue: index) isValidInIdentifiers - ifTrue: [ - "Digits and $_ are overwritten later" - newTable at: index put: #xLetter ]]. - - newTable atAll: ($0 numericValue to: $9 numericValue) put: #xDigit. - newTable atAll: '!!%&+-*/\±×÷¬­¯,<=>”•–—˜™š›œ«»?@~€‚ƒŽ‘’“žŸ°·' asByteArray put: #xBinary. - - newTable at: Scanner doItCharacterValue put: #doIt. - newTable at: $" numericValue put: #xDoubleQuote. - newTable at: $# numericValue put: #xLitQuote. - newTable at: $$ numericValue put: #xDollar. - newTable at: $' numericValue put: #xSingleQuote. - newTable at: $` numericValue put: #xBacktick. - newTable at: $: numericValue put: #xColon. - newTable at: $( numericValue put: #leftParenthesis. - newTable at: $) numericValue put: #rightParenthesis. - newTable at: $. numericValue put: #period. - newTable at: $; numericValue put: #semicolon. - newTable at: $[ numericValue put: #leftBracket. - newTable at: $] numericValue put: #rightBracket. - newTable at: ${ numericValue put: #leftBrace. - newTable at: $} numericValue put: #rightBrace. - newTable at: $^ numericValue put: #upArrow. - newTable at: $_ numericValue put: #xUnderscore. - newTable at: $| numericValue put: #verticalBar. - TypeTable := newTable "bon voyage!!" - - " - Scanner initTypeTable - "! ! -!SHParserST80 methodsFor: 'scan' stamp: 'jmv 12/10/2016 01:42:02' prior: 16901958! - scanWhitespace - | c | - - [c := self currentChar. - c notNil and: [c isSeparator or: [c == $`]]] - whileTrue: [sourcePosition := sourcePosition + 1]. - c == $" ifTrue: [self scanComment]! ! -!SHParserST80 methodsFor: 'character testing' stamp: 'jmv 12/10/2016 10:24:38' prior: 16902078! - isBinarySelectorCharacter: aCharacter - - aCharacter isValidInIdentifiers ifTrue: [^false]. - aCharacter isSeparator ifTrue: [^false]. - - ('"#$'':().;[]{}_`' includes: aCharacter) - ifTrue:[^false]. - aCharacter numericValue = Scanner doItCharacterValue ifTrue: [^false "the doIt char"]. - aCharacter numericValue = 0 ifTrue: [^false]. - "Any other char is ok as a binary selector char." - ^true! ! - -Scanner removeSelector: #scanStringStruct! - -Scanner removeSelector: #scanStringStruct! - -Scanner removeSelector: #scanStringStruct:! - -Scanner removeSelector: #scanStringStruct:! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Scanner initTypeTable! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3015-Backticks-JuanVuletich-2016Dec10-10h41m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3015] on 29 December 2016 at 4:06:32 pm'! -!LiteralNode methodsFor: 'printing' stamp: 'jmv 12/29/2016 16:06:13' prior: 16865098! - printOn: aStream indent: level - - key isVariableBinding - ifTrue: [ - key key isNil - ifTrue: [ - aStream nextPutAll: '###'; nextPutAll: key value soleInstance name ] - ifFalse: [ - aStream nextPutAll: '##'; nextPutAll: key key ]] - ifFalse: [ - key isLiteral - ifTrue: [ key storeOn: aStream ] - ifFalse: [ - "Need to generate code for stuff that is in a CompiledMethod literal - but is not understood as a literal by the Compiler. - Well, then it is because it was generated using backticks!!" - aStream nextPut: $`. - key storeOn: aStream. - aStream nextPut: $`. - ] - ]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3016-Backticks-SupportInDecompiler-JuanVuletich-2016Dec29-15h57m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3016] on 30 December 2016 at 10:57:00 am'! -!Scanner methodsFor: 'multi-character scans' stamp: 'jmv 12/30/2016 10:29:16' prior: 50334659! - xBacktick - "Smalltalk code evaluated at compile time as a literal." - - self step. - buffer reset. - [hereChar == $` - and: [aheadChar == $` - ifTrue: [self step. false] - ifFalse: [true]]] - whileFalse: [ - buffer nextPut: self step. - (hereChar = Scanner doItCharacterValue asCharacter and: [source atEnd]) - ifTrue: [^self offEnd: 'Unmatched back quote']]. - self step. - token _ [ Compiler evaluate: buffer contents ] - on: SyntaxErrorNotification, UndeclaredVariableReference, Error - do: [ :ex | - ex class caseOf: { - [ SyntaxErrorNotification ] -> [ - self notify: 'Can not compile: ', ex errorMessage at: mark]. - [ UndeclaredVariableReference ] -> [ - self notify: 'Can not compile: Variable ''', ex varName, ''' is not declared' at: mark ] - } otherwise: [ - self notify: 'Can not evaluate code: ', ex description at: mark ]]. - tokenType _ #literal! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3017-Backticks-betterErrorMessages-JuanVuletich-2016Dec30-10h56m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3016] on 30 December 2016 at 11:00:38 am'! -!Editor class methodsFor: 'class initialization' stamp: 'jmv 12/30/2016 11:00:14' prior: 16836909! - initialize - " - Editor initialize - " - self withAllSubclassesDo: [ :c | - c basicInitialize ]! ! -!TextEditor methodsFor: 'editing keys' stamp: 'jmv 12/30/2016 10:34:01' prior: 16931735! - enclose: aKeyboardEvent - "Insert or remove bracket characters around the current selection." - "This is a user command, and generates undo" - - | left right startIndex stopIndex oldSelection which | - startIndex _ self startIndex. - stopIndex _ self stopIndex. - oldSelection _ self selection. - which _ '([<{"''`' indexOf: aKeyboardEvent keyCharacter ifAbsent: [ ^true ]. - left _ '([<{"''`' at: which. - right _ ')]>}"''`' at: which. - ((startIndex > 1 and: [stopIndex <= model textSize]) - and: [ (model actualContents at: startIndex-1) = left and: [(model actualContents at: stopIndex) = right]]) - ifTrue: [ - "already enclosed; strip off brackets" - self selectFrom: startIndex-1 to: stopIndex. - self replaceSelectionWith: oldSelection] - ifFalse: [ - "not enclosed; enclose by matching brackets" - self replaceSelectionWith: - (Text string: (String with: left) attributes: emphasisHere), - oldSelection, - (Text string: (String with: right) attributes: emphasisHere). - self selectFrom: startIndex+1 to: stopIndex]. - ^true! ! -!TextEditor class methodsFor: 'keyboard shortcut tables' stamp: 'jmv 12/30/2016 10:33:45' prior: 16933087! - basicCmdShortcutsSpec - " - Editor initialize - " - - "arranged in QWERTY keyboard order" - ^#( - #( $( #enclose: 'Enclose within ( and ), or remove enclosing ( and )') - #( $[ #enclose: 'Enclose within [ and ], or remove enclosing [ and ]') - #( ${ #enclose: 'Enclose within { and }, or remove enclosing { and }') - #( $' #enclose: 'Enclose within single quotes, or remove enclosing single quotes') - #( $" #enclose: 'Enclose within double quotes, or remove enclosing double quotes') - #( $` #enclose: 'Enclose within backticks, or remove enclosing backticks') - #( $< #enclose: 'Enclose within < and >, or remove enclosing < and >') - - #( $a #selectAll: 'Select all') - #( $f #find: 'Find') - #( $g #findAgain: 'Find again') - #( $h #help: 'Open this help') - #( $j #setSearchString: 'Set selection as search string for find again') - - #( $z #undo: 'Undo (multiple levels)') - #( $x #cut: 'Cut selection and store it in the Clipboard') - #( $c #copySelection: 'Copy selection to the Clipboard') - #( $v #paste: 'Paste Clipboard contents') - - #( $R #indent: 'Indent (move selection one tab-stap right)') - #( $Y #makeUppercase: 'Force selection to uppercase') - #( $U #changeLineEndsToLf: 'Convert line endings to LF characters (Cuis convention) in selection') - - #( $H #cursorTopHome: 'Move cursor to start of text') - #( $L #outdent: 'Outdent (move selection one tab-stop left)') - - #( $Z #redo: 'Redo (multiple levels)') - #( $X #makeLowercase: 'Force selection to lowercase') - #( $C #compareToClipboard: 'Compare argument to clipboard') - - #( $ #selectWord: 'Select the current word as with double clicking') - )! ! -!SmalltalkEditor methodsFor: 'new selection' stamp: 'jmv 12/30/2016 10:36:10' prior: 16910578! - selectWord - "Select delimited text or word--the result of double-clicking." - - | leftDelimiters rightDelimiters | - "Warning. Once me (jmv) added Character crCharacter to the delimiters, to make double-click at and of line select whole line. - This had the bad effect that if a class name is the last word of a line, double-click would correctly select it, but after that, - doing ctrl-b to browse it would select the whole line..." - leftDelimiters _ '([{<|''"`'. - rightDelimiters _ ')]}>|''"`'. - ^self selectWordLeftDelimiters: leftDelimiters rightDelimiters: rightDelimiters! ! - -Editor initialize! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3018-Backticks-editorSupport-JuanVuletich-2016Dec30-10h57m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3016] on 30 December 2016 at 11:01:51 am'! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 12/30/2016 10:51:03'! - parseBacktick - self enterBlock. - self scanPast: #backtick. - currentTokenFirst == $| ifTrue: [self parseBlockTemporaries]. - self parseStatementList. - self failUnless: currentTokenFirst == $`. - self scanPast: #backtick. - self leaveBlock! ! -!SHParserST80 methodsFor: 'scan' stamp: 'tween 2/17/2007 14:51' prior: 50334790! - scanWhitespace - | c | - - [c := self currentChar. - c notNil and: [c isSeparator]] - whileTrue: [sourcePosition := sourcePosition + 1]. - c == $" ifTrue: [self scanComment]! ! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 12/30/2016 10:51:08' prior: 16902861! - parseTerm - self failWhen: currentToken isNil. - currentTokenFirst == $( - ifTrue: [ - bracketDepth := bracketDepth + 1. - self scanPast: #leftParenthesis level: bracketDepth. - self parseExpression. - self failUnless: currentTokenFirst == $). - self scanPast: #rightParenthesis level: bracketDepth. - bracketDepth := bracketDepth - 1. - ^self ]. - currentTokenFirst == $[ ifTrue: [^self parseBlock]. - currentTokenFirst == $` ifTrue: [^self parseBacktick]. - currentTokenFirst == ${ - ifTrue: [ - self scanPast: #leftBrace. - self parseBraceArray. - ^self ]. - self isName ifTrue: [^self scanPast: (self resolve: currentToken)]. - self parseLiteral: false! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3019-Backticks-BetterShoutSupport-JuanVuletich-2016Dec30-11h00m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3019] on 30 December 2016 at 11:46:58 am'! -!SHTextStylerST80 methodsFor: 'private' stamp: 'jmv 12/30/2016 11:44:19' prior: 50332635! - setAttributesFromRanges: ranges - - formattedText removeAttributesThat: [ :attribute | attribute isForShout ]. - - "Optimize for mutation speed unless method is really large but with very few distict elements: - Source code that includes just big literals is better served by conventional Text+RunArray" - "Do it only if we are not breaking textModel!! (for instance, StyledTextEditor asks for formatting just sections, not whole #actualContents)." - formattedText == textModel actualContents ifTrue: [ - (formattedText size > 2000 and: [ ranges size < 50 ]) ifFalse: [ - formattedText _ formattedText optimizedForMutationSpeed. - textModel basicActualContents: formattedText ]]. - - ranges do: [ :range | - - "Smalltalk text styling" - (self attributesFor: range rangeType) ifNotNil: [ :attributes | - attributes do: [ :each | - formattedText addAttribute: each from: range start to: range end ]]. - - "Show as subscripts if appropriate." - classOrMetaClass ifNotNil: [ - classOrMetaClass theNonMetaClass lastUnderscoreMeansSubscript ifTrue: [ - (#( instVar classVar globalVar workspaceVar poolConstant - patternArg methodArg patternTempVar tempVar - blockPatternArg blockArg blockPatternTempVar blockTempVar - incompleteIdentifier undefinedIdentifier) pointsTo: range rangeType ) - ifTrue: [ - formattedText lastIndexOf: $_ startingAt: range end endingAt: range start do: [ :i | - formattedText addAttribute: ShoutTextEmphasis subscript from: i to: range end ] ]]]]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3020-AvoidUnwantedSubscriptInClassDefinitions-JuanVuletich-2016Dec30-11h45m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3020] on 2 January 2017 at 2:27:29 pm'! -!Preferences class methodsFor: 'personalization' stamp: 'jmv 1/2/2017 14:18:06'! - usePreDebugWindow - ^ self - valueOfFlag: #usePreDebugWindow - ifAbsent: [ false ].! ! -!SystemWindow methodsFor: 'open/close' stamp: 'jmv 1/2/2017 14:11:03'! - initialFrameIn: aWorld - ^RealEstateAgent initialFrameFor: self world: aWorld! ! -!DebuggerWindow methodsFor: 'GUI building' stamp: 'jmv 1/2/2017 14:13:23'! - initialFrameIn: aWorld - | e | - e _ self runningWorld morphExtent. - ^(0@0 corner: e) insetBy: e // 10! ! -!SystemWindow methodsFor: 'open/close' stamp: 'jmv 1/2/2017 14:11:12' prior: 16926575! - openInWorld: aWorld - "This msg and its callees result in the window being activeOnlyOnTop" - | frameRect | - frameRect _ self initialFrameIn: aWorld. - self morphExtent: frameRect extent. - aWorld addMorph: self position: frameRect topLeft. - "Do it deferred. Was needed for text cursor to start blinking if (Preferences disable: #focusFollowsMouse) " - WorldState addDeferredUIMessage: [ self activate ]! ! -!PreDebugWindow class methodsFor: 'instance creation' stamp: 'jmv 1/2/2017 14:19:05' prior: 16892694! - open: model label: aString message: messageString - | window | - Preferences usePreDebugWindow - ifTrue: [ - window _ self new. - window - model: model; - buildMorphicWindowMessage: messageString print. - aString ifNotNil: [ window setLabel: aString ]. - window openInWorld ] - ifFalse: [ - model openFullMorphicLabel: aString ]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3021-DebuggerUsabilityEnh-JuanVuletich-2017Jan02-14h27m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3021] on 3 January 2017 at 9:34:24 pm'! -!WriteStream methodsFor: 'accessing' stamp: 'jmv 1/3/2017 21:22:43'! - nextPutAllString: aString withAttributes: attributesArray - - | newEnd | - (self isCompatibleWithContents: aString) - ifFalse: [ ^ super nextPutAllString: aString withAttributes: attributesArray ]. - - newEnd _ position + aString size. - newEnd > writeLimit ifTrue: [ - self growTo: newEnd + 10]. - - collection - replaceFrom: position+1 - to: newEnd - withString: aString - attributes: attributesArray - startingAt: 1. - position _ newEnd! ! -!WriteStream methodsFor: 'private' stamp: 'jmv 1/3/2017 21:21:34'! - isCompatibleWithContents: aCollection - - collection class == aCollection class - ifTrue: [ ^ true ]. - - (aCollection isString and: [ collection is: #Text]) - ifTrue: [ ^ true ]. - - ^ false! ! -!PositionableStream methodsFor: 'testing' stamp: 'jmv 1/3/2017 10:57:48' prior: 16891569! - isText - "Return true if the receiver is a Text stream" - ^collection is: #Text! ! -!WriteStream methodsFor: 'accessing' stamp: 'jmv 1/3/2017 21:22:51' prior: 16946406! - nextPutAll: aCollection - - | newEnd | - (self isCompatibleWithContents: aCollection) - 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.! ! -!WriteStream methodsFor: 'private' stamp: 'jmv 1/3/2017 10:57:15' prior: 16946621! - withAttribute: aTextAttribute do: streamBlock - | pos1 val | - - (collection is: #Text) ifFalse: [ - ^streamBlock value ]. - - pos1 _ self position. - val _ streamBlock value. - collection addAttribute: aTextAttribute from: pos1+1 to: self position. - ^ val! ! -!WriteStream methodsFor: 'private' stamp: 'jmv 1/3/2017 10:57:19' prior: 16946627! - withAttributes: attributes do: streamBlock - | pos1 val | - - (collection is: #Text) ifFalse: [ - ^streamBlock value ]. - - pos1 _ self position. - val _ streamBlock value. - attributes do: [:attribute | - collection - addAttribute: attribute - from: pos1 + 1 - to: self position]. - ^ val! ! - -Text class removeSelector: #streamContents:! - -Text class removeSelector: #streamContents:! - -Smalltalk removeClassNamed: #TextStream! - -Smalltalk removeClassNamed: #TextStream! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3022-TextStream-removal-JuanVuletich-2017Jan03-21h10m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3022] on 4 January 2017 at 10:42:00 am'! -!SmallInteger methodsFor: 'system primitives' stamp: 'jmv 1/4/2017 10:35:09' prior: 16909090! - digitAt: n - "Answer the value of an indexable field in the receiver. LargePositiveInteger uses bytes of base two number, and each is a 'digit' base 256. Fail if the argument (the index) is not an Integer or is out of bounds." - n > Smalltalk wordSize ifTrue: [^ 0]. - self < 0 - ifTrue: - [self = SmallInteger minVal ifTrue: [ - "Can't negate minVal -- treat specially" - ^ Smalltalk wordSize = 4 - ifTrue: [ #(0 0 0 64) at: n ] - ifFalse: [ #(0 0 0 0 0 0 0 16) at: n ]]. - ^ ((0-self) bitShift: (1-n)*8) bitAnd: 16rFF] - ifFalse: [^ (self bitShift: (1-n)*8) bitAnd: 16rFF]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3023-SmallInteger-digitAt-fixFor64Bits-JuanVuletich-2017Jan04-10h41m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3022] on 4 January 2017 at 10:46:32 am'! - -Integer class removeSelector: #byte1:byte2:byte3:byte4:! - -Integer class removeSelector: #byte1:byte2:byte3:byte4:! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3024-Integer-from4Bytes-removal-JuanVuletich-2017Jan04-10h44m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3024] on 6 January 2017 at 10:05:27 am'! -!WeakArray class methodsFor: 'system startup' stamp: 'jmv 1/6/2017 09:56:14'! -startUp - "Do it even if just continuing after image snapshot" - self restartFinalizationProcess! ! -!SystemDictionary methodsFor: 'startup' stamp: 'jmv 1/6/2017 09:59:32'! - doStartUp: isARealStartup - " - isARealStartup - true: system is coming up (VM and image just started) - false: we have just saved an image snapshot, but didn't quit. - " - - "Here, startup begins!!" - Cursor normal activateCursor. - self setGCParameters. - isARealStartup ifTrue: [ - self clearExternalObjects ]. - self readCommandLineArguments. - self processStartUpList: isARealStartup. - isARealStartup ifTrue: [ - self setPlatformPreferences. - self setStartupStamp ]! ! -!Behavior methodsFor: 'system startup' stamp: 'jmv 1/6/2017 09:52:14' prior: 16785037! - startUp - "This message is sent to registered classes when the system is coming up, or after an image save."! ! -!Behavior methodsFor: 'system startup' stamp: 'jmv 1/6/2017 09:53:18' prior: 16785042! - startUp: isARealStartup - "This message is sent to registered classes, with isARealStartup = true when the system is coming up, - and with isARealStartup = false after a snapshot (image save, no quit). - Classes caring about the difference should reimplement this method." - - ^ self startUp! ! -!WeakArray class methodsFor: 'class initialization' stamp: 'jmv 1/6/2017 09:49:16' prior: 16943683! - initialize - " - WeakArray initialize. - SystemDictionary initialize. - " - - self restartFinalizationProcess! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 1/6/2017 09:53:30' prior: 16922685! - processStartUpList: isARealStartup - "Send #startUp to each class that needs to run initialization after a snapshot." - - EndianCache _ self calcEndianness. - self send: #startUp: toClassesNamedIn: StartUpList with: isARealStartup! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 1/6/2017 09:55:41' prior: 16922813! - send: startUpOrShutDown toClassesNamedIn: startUpOrShutDownList with: argument - "Send the message #startUp: or #shutDown: to each class named in the list. - The argument indicates if the system is about to quit (for #shutDown:) or if - the image is ia real startup (or just continue after image save) (for #startUp:). - If any name cannot be found, then remove it from the list." - - | removals class | - removals _ OrderedCollection new. - startUpOrShutDownList do: - [:name | - class _ self at: name ifAbsent: nil. - class - ifNil: [removals add: name] - ifNotNil: [ - class isInMemory ifTrue: [ - class perform: startUpOrShutDown with: argument]]]. - - "Remove any obsolete entries, but after the iteration" - "Well, not. Better just ignore them. Maybe it is stuff, like SoundPlayer, that was moved to optional packages, and can be loaded again anytime." - "startUpOrShutDownList removeAll: removals"! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 1/6/2017 09:59:34' prior: 16922908! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag -"WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " -| activeProc | -activeProc _ Processor activeProcess. -[ - | isARealStartup world reopenTranscript | - self logSapshot: save andQuit: quit. - - reopenTranscript _ false. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | each isInWorld ifTrue: [ each delete. reopenTranscript _ true ]]. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - - - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - - "Cosas que levanto explicitamente abajo" - world _ ProjectX ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "world _ clearAllStateFlag ifFalse: [ ProjectX ui ]." - ProjectX stopUIProcess. - activeProc isTerminated ifFalse: [ - activeProc terminate ]. - - "Clean Globals" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: nil. - Smalltalk closeSourceFiles. Smalltalk at: #SourceFiles put: nil. - Smalltalk allClassesDo: [ :cls | cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ Smalltalk printStuffToCleanOnImageSave ]. - - - "Do image save & quit as apropriate" - Cursor write activateCursor. - save - ifTrue: [ - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - - - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: (DisplayScreen extent: 1024@768 depth: 32). - Smalltalk at: #SourceFiles put: (Array new: 2). - Smalltalk openSourceFiles. - - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - - - ProjectX spawnNewMorphicProcessFor: (world ifNil: [ PasteUpMorph newWorld ]). - - reopenTranscript ifTrue: [ - WorldState addDeferredUIMessage: [ - TranscriptWindow openTranscript ]]. - " - WorldState addDeferredUIMessage: [ - world fullRepaintNeeded ]. - " - - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - WorldState addDeferredUIMessage: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]. - -] forkAt: Processor timingPriority-1 named: 'Startup process'.! ! - -SystemDictionary removeSelector: #startup:! - -SystemDictionary removeSelector: #startup:! - -WeakArray class removeSelector: #startUp:! - -WeakArray class removeSelector: #startUp:! - -WeakArray initialize! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3025-RestartFinalizationAfterImageSave-JuanVuletich-2017Jan06-09h49m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3025] on 13 January 2017 at 9:55:29 am'! -!LargePositiveInteger methodsFor: 'bit manipulation' stamp: 'jmv 1/13/2017 09:39:07'! - bitXor: arg - "Primitive 36 deals with only 64-bit values (up to 8 byte LargeIntegers). - The inherited deals with - arbitrary sized large integers, but is much slower. - This method gives a performance improvement for integers using 32 to 64 bits on 32 bit VMs, - but only for 62 to 64 bits on 64 bits VMs. - See http://forum.world.st/Integer-arithmetic-and-bit-operations-in-Squeak-and-Pharo-32bit-amp-64bit-tc4928994.html#none - " - - - ^super bitXor: arg! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3026-LargeInteger-bitXor-performanceImprov-JuanVuletich-2017Jan13-09h54m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3025] on 13 January 2017 at 9:55:58 am'! -!SHParserST80 methodsFor: 'parse' stamp: 'ul 10/12/2010 02:43'! - parseStringOrSymbol - - currentTokenFirst == $' ifTrue: [ ^self parseString ]. - currentTokenFirst == $# ifTrue: [ ^self parseSymbol ]. - self error! ! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 1/13/2017 09:53:38' prior: 16902728! - parsePrimitive - self scanNext. - currentTokenFirst isDigit - ifTrue: [self scanPast: #integer] - ifFalse: [ - self failUnless: currentTokenFirst == $'. - self parseString. - currentToken = 'module:' - ifTrue: [ - self scanPast: #module. - self failUnless: currentTokenFirst == $'. - self parseString]]. - currentToken = 'error:' ifTrue: [ - self scanPast: #primitive. "there's no rangeType for error" - self isName - ifTrue: [ self scanPast: #patternTempVar ] - ifFalse: [ self parseStringOrSymbol ] ]. - self failUnless: currentToken = '>'. - self scanPast: #primitiveOrExternalCallEnd! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3027-ShoutFix-JuanVuletich-2017Jan13-09h55m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3025] on 13 January 2017 at 9:59:33 am'! -!Float methodsFor: 'private' stamp: 'jmv 1/13/2017 09:57:46' prior: 16845694! - replaceWordsFrom: 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." - - - self primitiveFailed! ! -!LargePositiveInteger methodsFor: 'system primitives' stamp: 'jmv 1/13/2017 09:58:53' prior: 16862796! - replaceFrom: start to: stop with: replacement startingAt: repStart - "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." - - - super replaceFrom: start to: stop with: replacement startingAt: repStart! ! -!String methodsFor: 'private' stamp: 'jmv 1/13/2017 09:58:04' prior: 16917188! - replaceFrom: start to: stop with: replacement startingAt: repStart - "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." - - - super replaceFrom: start to: stop with: replacement startingAt: repStart! ! -!Array methodsFor: 'private' stamp: 'jmv 1/13/2017 09:57:31' prior: 16779882! - replaceFrom: start to: stop with: replacement startingAt: repStart - "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." - - - super replaceFrom: start to: stop with: replacement startingAt: repStart! ! -!ByteArray methodsFor: 'private' stamp: 'jmv 1/13/2017 09:57:38' prior: 16793800! - replaceFrom: start to: stop with: replacement startingAt: repStart - "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." - - - super replaceFrom: start to: stop with: replacement startingAt: repStart! ! -!Float64Array methodsFor: 'private' stamp: 'jmv 1/13/2017 09:57:50' prior: 16846133! - replaceWordsFrom: 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." - - - self primitiveFailed! ! -!FloatArray methodsFor: 'private' stamp: 'jmv 1/13/2017 09:58:24' prior: 16846632! -replaceFrom: start to: stop with: replacement startingAt: repStart - "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." - - - super replaceFrom: start to: stop with: replacement startingAt: repStart! ! -!RunNotArray methodsFor: 'private' stamp: 'jmv 1/13/2017 09:58:00' prior: 16901681! - replaceFrom: start to: stop with: replacement startingAt: repStart - "Copied from Array" - "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." - - - super replaceFrom: start to: stop with: replacement startingAt: repStart! ! -!WordArray methodsFor: 'private' stamp: 'jmv 1/13/2017 09:58:38' prior: 16945290! - replaceFrom: start to: stop with: replacement startingAt: repStart - - - super replaceFrom: start to: stop with: replacement startingAt: repStart ! ! -!Bitmap methodsFor: 'accessing' stamp: 'jmv 1/13/2017 09:57:27' prior: 16787571! -replaceFrom: start to: stop with: replacement startingAt: repStart - "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." - - - super replaceFrom: start to: stop with: replacement startingAt: repStart! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3028-GrabErrorCodeForPrim105-JuanVuletich-2017Jan13-09h55m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3028] on 14 January 2017 at 8:18:04 am'! -!Point commentStamp: 'jmv 12/30/2016 17:39:06' prior: 16890200! - I represent an x-y pair of numbers usually designating a location on the screen. - -When dealing with display coordinates, the y axis is usually considered to increase downwards. However, the standard math convention is to consider it increasing upwards. -Points don't need to know about this. In the first case, theta increases clockwise. In the second case, it increases counter-clockwise, also the standard math convention. - -Any method that doesn't follow this (because it assumes one specific convention) include this fact in the selector and in a comment. - -My instances are immutable. See #privateSetX:setY:! -!Point methodsFor: 'private' stamp: 'jmv 12/11/2016 10:28:44'! - privateSetX: xValue setY: yValue - "Points are immutable. Right now this is by convention, but we'll make this enfoced by VM. - Do not all this method, except from instance creation." - x _ xValue. - y _ yValue! ! -!Point methodsFor: 'copying' stamp: 'pb 10/29/2016 18:18:07'! - shallowCopy - "Immutable" - ^ self.! ! -!Object class methodsFor: 'instance creation' stamp: 'jmv 12/30/2016 17:33:31' prior: 16882941! - unStream: aByteArray - ^ ReferenceStream unStream: aByteArray! ! -!DataStream class methodsFor: 'as yet unclassified' stamp: 'jmv 12/30/2016 17:33:27' prior: 16828091! - unStream: aByteArray - - ^(self on: ((RWBinaryOrTextStream with: aByteArray) reset; binary)) next! ! -!Point class methodsFor: 'instance creation' stamp: 'pb 10/29/2016 17:14:00' prior: 16890866! - r: rho degrees: degrees - "Answer an instance of me with polar coordinates rho and theta." - ^ self - rho: rho - theta: degrees asFloat degreesToRadians.! ! -!Point class methodsFor: 'instance creation' stamp: 'pb 10/29/2016 17:12:53' prior: 16890873! - rho: rho theta: radians - "Answer an instance of me with polar coordinates rho and theta." - ^ self - x: rho asFloat * radians cos - y: rho asFloat * radians sin.! ! -!Point class methodsFor: 'instance creation' stamp: 'jmv 12/11/2016 10:28:50' prior: 16890880! - x: anX y: anY - "Answer an instance of me with supplied coordinates." - - ^self new privateSetX: anX setY: anY! ! - -Point removeSelector: #setR:degrees:! - -Point removeSelector: #setR:degrees:! - -Point removeSelector: #setRho:theta:! - -Point removeSelector: #setRho:theta:! - -Point removeSelector: #setX:setY:! - -Point removeSelector: #setX:setY:! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3029-Point-immutable-PhilBellalouna-2017Jan14-08h15m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3029] on 14 January 2017 at 8:53:02 am'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 1/14/2017 08:52:09' prior: 16920588! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3030-AddHernanAndGeraToKnownAuthors-JuanVuletich-2017Jan14-08h52m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3025] on 10 January 2017 at 8:09:15 pm'! - -Object subclass: #TestResultForDebuggingAndInspection - instanceVariableNames: 'testResult' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Testing'! - -!classDefinition: #TestResultForDebuggingAndInspection category: #'Tools-Testing'! -Object subclass: #TestResultForDebuggingAndInspection - instanceVariableNames: 'testResult' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Testing'! -!CompiledMethod methodsFor: 'testing' stamp: 'HernanWilkinson 1/10/2017 18:22:10'! - isTestMethod - - ^ (self methodClass is: #TestCaseClass) - and: [ ((self selector beginsWith: 'test') or: [ (self selector beginsWith: 'should')]) - and: [ self numArgs isZero ] ]! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HernanWilkinson 1/10/2017 19:35:14'! - acceptAndTest - - ^self acceptThenTestMethodAndSuite: [ :aMethod | self testSuiteOf: aMethod methodClass ]! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HernanWilkinson 1/10/2017 19:35:34'! - acceptAndTestAll - - ^self acceptThenTestMethodAndSuite: [ :aMethod | self testSuiteForCategoryOf: aMethod methodClass ] - - ! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HernanWilkinson 1/10/2017 19:04:06'! - acceptThenTestMethodAndSuite: aSuiteBuilder - - | potencialTestMethod | - - self acceptContents ifFalse: [ ^false ]. - - potencialTestMethod _ model textProvider currentCompiledMethod. - self runAndDebuggIfNecessary: potencialTestMethod. - ^(self runTestSuite: (aSuiteBuilder value: potencialTestMethod)) hasPassed - ! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HernanWilkinson 1/10/2017 18:50:03'! - flashWith: aColor - - ^morph flashWith: aColor! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HernanWilkinson 1/10/2017 18:50:21'! -flashWithGreen - - ^self flashWith: Color green - - - - ! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HernanWilkinson 1/10/2017 19:03:07'! - runAndDebuggIfNecessary: aPotentialTestMethod - - aPotentialTestMethod isTestMethod ifTrue: [ - aPotentialTestMethod methodClass debug: aPotentialTestMethod selector ]! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HernanWilkinson 1/10/2017 19:04:42'! - runTestSuite: aTestSuite - - | suiteRunResult | - - suiteRunResult _ aTestSuite run. - suiteRunResult hasPassed - ifTrue: [self flashWithGreen ] - ifFalse: [ suiteRunResult forDebuggingAndInspection inspect ]. - - ^suiteRunResult - - - - ! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HernanWilkinson 1/10/2017 19:35:52'! - testSuiteForCategoryOf: aClass - - | testCaseClasses | - - testCaseClasses _ (SystemOrganization listAtCategoryNamed: aClass category) - collect: [ :aClassName | Smalltalk classNamed: aClassName ] - thenSelect: [ :aClassInCategory | aClassInCategory is: #TestCaseClass ]. - - - ^testCaseClasses - inject: (TestSuite named: 'Test of Category ', aClass category) - into: [ :suite :testCaseClass | testCaseClass addToSuiteFromSelectors: suite ]! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HernanWilkinson 1/10/2017 19:34:58'! - testSuiteOf: aPotentialTestCaseClass - - ^(aPotentialTestCaseClass is: #TestCaseClass) - ifTrue: [ aPotentialTestCaseClass buildSuite ] - ifFalse: [ TestSuite named: 'Tests of ', aPotentialTestCaseClass name ]! ! -!DisplayScreen methodsFor: 'displaying' stamp: 'HernanWilkinson 1/10/2017 18:45:48'! - flash: aRectangle with: aColor - - self fill: aRectangle fillColor: aColor. - self forceToScreen: aRectangle. - (Delay forMilliseconds: 100) wait. - self fill: aRectangle fillColor: aColor. - self forceToScreen: aRectangle! ! -!Morph methodsFor: 'macpal' stamp: 'HernanWilkinson 1/10/2017 18:49:44'! - flashWith: aColor - - self morphBoundsInWorld ifNotNil: [ :r | Display flash: r with: aColor ]! ! -!InnerTextMorph methodsFor: 'editing' stamp: 'HernanWilkinson 1/10/2017 15:56:51'! - confirmAcceptAnyway - - ^ self confirm: -'Caution!! Contents were saved -elsewhere since you started -editing them here. Accept anyway?'! ! -!TestCase class methodsFor: 'Testing' stamp: 'HernanWilkinson 1/10/2017 16:29:48'! - is: aSymbol - - ^aSymbol == #TestCaseClass or: [ super is: aSymbol ]! ! -!TestResult methodsFor: 'Inspecting' stamp: 'HernanWilkinson 1/10/2017 16:33:03'! - forDebuggingAndInspection - - ^TestResultForDebuggingAndInspection on: self! ! -!TestResultForDebuggingAndInspection methodsFor: 'initialization' stamp: 'HernanWilkinson 1/10/2017 16:34:56'! - initializeOn: aTestResult - - testResult _ aTestResult! ! -!TestResultForDebuggingAndInspection methodsFor: 'printing' stamp: 'HernanWilkinson 1/10/2017 17:49:59'! - print: aCollectionOfTestCases startingWith: header on: aStream - - aCollectionOfTestCases - do: [ :aTestCase | - aStream - nextPutAll: header; - space; - nextPutAll: aTestCase class name; - nextPutAll: ' debug: #'; - nextPutAll: aTestCase selector ] - separatedBy: [ aStream newLine ]. - - ! ! -!TestResultForDebuggingAndInspection methodsFor: 'printing' stamp: 'HernanWilkinson 1/10/2017 17:49:05'! - printOn: aStream - - aStream print: testResult. - aStream newLine. - - self print: testResult errors startingWith: '"E"' on: aStream. - self print: testResult failures startingWith: '"F"' on: aStream. - ! ! -!TestResultForDebuggingAndInspection methodsFor: 'running' stamp: 'HernanWilkinson 1/10/2017 18:14:09'! - reRun - - | suite | - - suite _ TestSuite new. - suite addTests: testResult tests. - - testResult _ suite run.! ! -!TestResultForDebuggingAndInspection class methodsFor: 'instance creation' stamp: 'HernanWilkinson 1/10/2017 16:34:28'! - on: aTestResult - - ^self new initializeOn: aTestResult! ! -!TextEditor methodsFor: 'menu messages' stamp: 'HernanWilkinson 1/10/2017 16:00:24' prior: 16932076! - acceptContents - "Save the current text of the text being edited as the current acceptable version for purposes of canceling. Allow my morph to take appropriate action" - ^morph acceptContents! ! -!SmalltalkEditor class methodsFor: 'keyboard shortcut tables' stamp: 'HernanWilkinson 1/10/2017 19:58:01' prior: 16910705! - initializeMenu - "Initialize the mouseButton2 (right button) pop-up menu and corresponding messages." - " - Editor initialize - " - - menu _ SelectionMenu fromArray: { - {'Help...'. #openHelp}. - #-. - {'Do it (d)'. #doIt}. - {'Print it (p)'. #printIt}. - {'Inspect it (i)'. #inspectIt}. - {'Explore it (I)'. #exploreIt}. - {'Debug it (D)'. #debugIt}. - {'Profile it'. #profileIt}. - #-. - {'Explain'. #explain}. - {'Browse it (b)'. #browseIt}. - {'Senders of it (n)'. #sendersOfIt}. - {'Implementors of it (m)'. #implementorsOfIt}. - {'References to it (N)'. #referencesToIt}. - #-. - {'Method Strings with it (E)'. #methodStringsContainingit}. - {'Method Source with it'. #methodSourceContainingIt}. - {'Class Comments with it'. #classCommentsContainingIt}. - #-. - {'Accept (s)'. #acceptContents}. - {'Cancel (l)'. #cancelEdits}. - {'Accept & Run Test in Class (t)'. #acceptAndTest}. - {'Accept & Run Test in Category (y)'. #acceptAndTestAll}. - #-. - {'More...'. #getMenu2}. - }. - menu2 _ SelectionMenu fromArray: { - {'Find...(f)'. #find}. - {'Find Again (g)'. #findAgain}. - {'Use Selection for Find (j)'. #setSearchString}. - #-. - {'Undo - multiple (z)'. #undo}. - {'Redo - multiple (Z)'. #redo}. - {'Undo / Redo history'. #offerUndoHistory}. - #-. - {'Copy (c)'. #copySelection}. - {'Cut (x)'. #cut}. - {'Paste (v)'. #paste}. - {'Paste without Format'. #pasteString}. - {'Paste...'. #pasteRecent}. - #-. - {'Toggle WordWrap'. #wrapOnOff}. - {'Set Font... (k)'. #offerFontMenu}. - {'Clear Font'. #clearFont}. - {'Set Default Font...'. #offerDefaultFontMenu}. - #-. - {'More...'. #getMenu}. - }! ! -!InspectorWindow methodsFor: 'GUI building' stamp: 'HernanWilkinson 1/10/2017 17:47:44' prior: 16857247! - initialExtent - - ^600@325! ! -!InnerTextMorph methodsFor: 'editing' stamp: 'HernanWilkinson 1/10/2017 19:46:39' prior: 16855583! - acceptContents - "The message is sent when the user hits return or Cmd-S. - Accept the current contents and end editing." - "Inform the model of text to be accepted, and return true if OK." - - | accepted prevSelection prevScrollValue | - - prevSelection _ self editor selectionInterval copy. - prevScrollValue _ owner verticalScrollBar value. - - (self canDiscardEdits and: [(self hasProperty: #alwaysAccept) not]) ifTrue: [self flash. ^true]. - (self hasEditingConflicts and: [ self confirmAcceptAnyway not ]) ifTrue: [self flash. ^false]. - - accepted _ model acceptContentsFrom: owner. - "During the step for the browser, updatePaneIfNeeded is called, and - invariably resets the contents of the code-holding PluggableTextMorph - at that time, resetting the cursor position and scroller in the process. - The following line forces that update without waiting for the step, - then restores the cursor and scrollbar" - - "some implementors of acceptContentsFrom: answer self :(" - ^accepted == true - ifTrue: [ - model refetch. - self editor selectFrom: prevSelection first to: prevSelection last. - WorldState addDeferredUIMessage: [ - self world ifNotNil: [ :w | w activeHand newKeyboardFocus: self ]. - owner verticalScrollBar setValue: prevScrollValue]. - true] - ifFalse: [ false ]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3031-TDDSupport-0-HernanWilkinson.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3025] on 10 January 2017 at 8:09:22 pm'! -!SmalltalkEditor methodsFor: 'editing keys' stamp: 'HernanWilkinson 1/10/2017 20:04:06'! - acceptAndTest: aKeyboardEvent - - ^self acceptAndTest! ! -!SmalltalkEditor methodsFor: 'editing keys' stamp: 'HernanWilkinson 1/10/2017 20:04:34'! - acceptAndTestAll: aKeyboardEvent - - ^self acceptAndTestAll! ! -!SmalltalkEditor methodsFor: 'editing keys' stamp: 'HernanWilkinson 1/10/2017 20:02:27'! - debugIt: aKeyboardEvent - - self debugIt. - ^true! ! -!SmalltalkEditor class methodsFor: 'keyboard shortcut tables' stamp: 'HernanWilkinson 1/10/2017 20:03:23' prior: 16910661! - cmdShortcutsSpec - " - Editor initialize - " - "arranged in QWERTY keyboard order" - ^#( - #( $t #acceptAndTest: 'Saves method, runs it as test and then all tests in class. Opens debugger if error') - #( $y #acceptAndTestAll: 'Saves method, runs it as test and then all tests in class category. Opens debugger if error') - #( $i #inspectIt: 'Inspect it (selection is a valid expression, or selection is over an inspect-ilst)') - #( $p #printIt: 'Print it (selection is a valid expression)') - - #( $s #save: 'Save (i.e. accept)') - #( $d #doIt: 'Do it (selection is a valid expression)') - #( $l #cancelEdits: 'Cancel') - - #( $b #browseIt: 'Browse it (selection is a class name or cursor is over a class-list or message-list)') - #( $n #sendersOfIt: 'Senders of it (selection is a message selector or cursor is over a class-list or message-list)') - #( $m #implementorsOfIt: 'Implementors of it (selection is a message selector or cursor is over a class-list or message-list)') - - #( $E #methodStringsContainingit:'Method strings containing it') - #( $T #displayIfTrue: 'Insert #ifTrue:') - #( $I #exploreIt: 'Inspect via Object Explorer') - - #( $A #argAdvance: 'Advance argument') - #( $D #debugIt: 'Debut it') - #( $F #displayIfFalse: 'Insert #ifFalse:') - #( $G #fileItIn: 'File in selection') - - #( $V #pasteInitials: 'Paste author initials') - #( $N #referencesToIt: 'References to it (selection is a class name, or cursor is over a class-list or message-list)') - )! ! -!SmalltalkEditor class methodsFor: 'keyboard shortcut tables' stamp: 'HernanWilkinson 1/10/2017 19:58:01' prior: 50336244! - initializeMenu - "Initialize the mouseButton2 (right button) pop-up menu and corresponding messages." - " - Editor initialize - " - - menu _ SelectionMenu fromArray: { - {'Help...'. #openHelp}. - #-. - {'Do it (d)'. #doIt}. - {'Print it (p)'. #printIt}. - {'Inspect it (i)'. #inspectIt}. - {'Explore it (I)'. #exploreIt}. - {'Debug it (D)'. #debugIt}. - {'Profile it'. #profileIt}. - #-. - {'Explain'. #explain}. - {'Browse it (b)'. #browseIt}. - {'Senders of it (n)'. #sendersOfIt}. - {'Implementors of it (m)'. #implementorsOfIt}. - {'References to it (N)'. #referencesToIt}. - #-. - {'Method Strings with it (E)'. #methodStringsContainingit}. - {'Method Source with it'. #methodSourceContainingIt}. - {'Class Comments with it'. #classCommentsContainingIt}. - #-. - {'Accept (s)'. #acceptContents}. - {'Cancel (l)'. #cancelEdits}. - {'Accept & Run Test in Class (t)'. #acceptAndTest}. - {'Accept & Run Test in Category (y)'. #acceptAndTestAll}. - #-. - {'More...'. #getMenu2}. - }. - menu2 _ SelectionMenu fromArray: { - {'Find...(f)'. #find}. - {'Find Again (g)'. #findAgain}. - {'Use Selection for Find (j)'. #setSearchString}. - #-. - {'Undo - multiple (z)'. #undo}. - {'Redo - multiple (Z)'. #redo}. - {'Undo / Redo history'. #offerUndoHistory}. - #-. - {'Copy (c)'. #copySelection}. - {'Cut (x)'. #cut}. - {'Paste (v)'. #paste}. - {'Paste without Format'. #pasteString}. - {'Paste...'. #pasteRecent}. - #-. - {'Toggle WordWrap'. #wrapOnOff}. - {'Set Font... (k)'. #offerFontMenu}. - {'Clear Font'. #clearFont}. - {'Set Default Font...'. #offerDefaultFontMenu}. - #-. - {'More...'. #getMenu}. - }! ! -!InnerTextMorph methodsFor: 'editing' stamp: 'HernanWilkinson 1/10/2017 19:46:39' prior: 50336309! - acceptContents - "The message is sent when the user hits return or Cmd-S. - Accept the current contents and end editing." - "Inform the model of text to be accepted, and return true if OK." - - | accepted prevSelection prevScrollValue | - - prevSelection _ self editor selectionInterval copy. - prevScrollValue _ owner verticalScrollBar value. - - (self canDiscardEdits and: [(self hasProperty: #alwaysAccept) not]) ifTrue: [self flash. ^true]. - (self hasEditingConflicts and: [ self confirmAcceptAnyway not ]) ifTrue: [self flash. ^false]. - - accepted _ model acceptContentsFrom: owner. - "During the step for the browser, updatePaneIfNeeded is called, and - invariably resets the contents of the code-holding PluggableTextMorph - at that time, resetting the cursor position and scroller in the process. - The following line forces that update without waiting for the step, - then restores the cursor and scrollbar" - - "some implementors of acceptContentsFrom: answer self :(" - ^accepted == true - ifTrue: [ - model refetch. - self editor selectFrom: prevSelection first to: prevSelection last. - WorldState addDeferredUIMessage: [ - self world ifNotNil: [ :w | w activeHand newKeyboardFocus: self ]. - owner verticalScrollBar setValue: prevScrollValue]. - true] - ifFalse: [ false ]! ! - -Editor initialize! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3032-TDDSupport-1-HernanWilkinson.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3025] on 12 January 2017 at 5:14:29 pm'! -!Debugger methodsFor: 'as yet unclassified' stamp: 'HAW 1/12/2017 17:05:16'! - askForSuperclassOf: aClass toImplement: aSelector ifCancel: cancelBlock - - | classes chosenClassIndex | - - classes _ aClass withAllSuperclasses. - chosenClassIndex _ PopUpMenu - withCaption: 'Define #', aSelector, ' in which class?' - chooseFrom: (classes collect: [:c | c name]). - chosenClassIndex = 0 ifTrue: [^ cancelBlock value]. - - ^ classes at: chosenClassIndex! ! -!Debugger methodsFor: 'as yet unclassified' stamp: 'HAW 1/12/2017 17:09:46'! - create - - self shouldBeAbleToCreateMethod - ifTrue: [ self createMethod ] - ifFalse: [ self inform: 'Only available for doesNotUndertand:' ]! ! -!Debugger methodsFor: 'as yet unclassified' stamp: 'HAW 1/12/2017 17:04:29'! - createMethod - - | message chosenClass interruptedContext | - - interruptedContext _ self interruptedContext. - message _ interruptedContext tempAt: 1. - chosenClass _ self - askForSuperclassOf: interruptedContext receiver class - toImplement: message selector - ifCancel: [^self]. - self implement: message inClass: chosenClass. -! ! -!Debugger methodsFor: 'as yet unclassified' stamp: 'HAW 1/12/2017 17:01:22'! - shouldBeAbleToCreateMethod - - ^self interruptedContext selector == #doesNotUnderstand:! ! -!DebuggerWindow methodsFor: 'GUI building' stamp: 'HAW 1/12/2017 17:04:50' prior: 16831115! - customButtonSpecs - "Answer an array of elements of the form wording, selector, help-message, that characterize the custom button row of a debugger." - - ^#( - ('Restart' restart 'reset this context to its start.') - ('Into' send 'step Into message sends') - ('Over' doStep 'step Over message sends') - ('Through' stepIntoBlock 'step into a block') - ('Full Stack' fullStack 'show full stack') - ('Where' where 'select current pc range') - ('Create' create 'create method'))! ! -!PreDebugWindow methodsFor: 'GUI building' stamp: 'HAW 1/12/2017 17:06:02' prior: 16892577! - buttonRowForPreDebugWindow: aDebugger - | row aButton triads buttons | - buttons _ OrderedCollection new. - triads _ OrderedCollection withAll: self preDebugButtonSpec. - (aDebugger shouldBeAbleToCreateMethod) ifTrue: [ - triads add: { 'Create'. #createMethod. 'create the missing method' } - ]. - triads do: [ :triad | - aButton _ PluggableButtonMorph new model: self. - aButton label: triad first. - aButton action: triad second. - aButton setBalloonText: triad third. - buttons add: aButton]. - - row _ LayoutMorph newRow. - row doAdoptWidgetsColor. - row color: Color transparent. - row separation: 1. - row addMorphs: buttons. - ^row! ! -!PreDebugWindow methodsFor: 'button actions' stamp: 'HAW 1/12/2017 17:06:43' prior: 16892636! - createMethod - "Should only be called when this Debugger was created in response to a - MessageNotUnderstood exception. Create a stub for the method that was - missing and proceed into it." - - model createMethod. - self debug -! ! - -PreDebugWindow removeSelector: #askForSuperclassOf:toImplement:ifCancel:! - -PreDebugWindow removeSelector: #askForSuperclassOf:toImplement:ifCancel:! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3033-CreateMethodSupport-HernanWilkinson-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3025] on 12 January 2017 at 6:54:23 pm'! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'HAW 1/12/2017 18:29:00'! - allSuperclassesUpTo: aSuperclass - - | superclasses | - - ^ superclass = aSuperclass - ifTrue: [ OrderedCollection with: aSuperclass] - ifFalse: [superclasses _ superclass allSuperclassesUpTo: aSuperclass. - superclasses addFirst: superclass. - superclasses]! ! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'HAW 1/12/2017 18:30:53'! - withAllSuperclassesUpTo: aSuperclass - - | classes | - - classes _ self allSuperclassesUpTo: aSuperclass. - classes addFirst: self. - - ^ classes! ! -!ContextPart methodsFor: 'debugger access' stamp: 'HAW 1/12/2017 17:48:35'! - arguments - - | arguments | - - arguments _ Array new: self selector numArgs. - 1 to: arguments size do: [ :index | arguments at: index put: (self tempAt: index)]. - - ^arguments. - - ! ! -!ContextPart methodsFor: 'debugger access' stamp: 'HAW 1/12/2017 17:47:30'! -messageForYourself - - ^Message selector: self selector arguments: self arguments. - ! ! -!Debugger methodsFor: 'method creation' stamp: 'HAW 1/12/2017 18:31:14'! - askForSuperclassOf: aClass upTo: aSuperclass toImplement: aSelector ifCancel: cancelBlock - - | classes chosenClassIndex | - - classes _ aClass withAllSuperclassesUpTo: aSuperclass. - chosenClassIndex _ PopUpMenu - withCaption: 'Define #', aSelector, ' in which class?' - chooseFrom: (classes collect: [:c | c name]). - chosenClassIndex = 0 ifTrue: [^ cancelBlock value]. - - ^ classes at: chosenClassIndex! ! -!Debugger methodsFor: 'method creation' stamp: 'HAW 1/12/2017 18:45:03'! - createMethodOnSubclassResponsibility - - | message chosenClass subclassResponsibilityContext | - - subclassResponsibilityContext _ self interruptedContext sender sender. - message _ subclassResponsibilityContext messageForYourself. - - chosenClass _ self - askForSuperclassOf: subclassResponsibilityContext receiver class - upTo: subclassResponsibilityContext method methodClass - toImplement: message selector - ifCancel: [^self]. - - self implement: message inClass: chosenClass context: subclassResponsibilityContext - -! ! -!Debugger methodsFor: 'method creation' stamp: 'HAW 1/12/2017 18:43:11'! - createMethodWhenDoesNotUndertand - - | message chosenClass interruptedContext | - - interruptedContext _ self interruptedContext. - message _ interruptedContext tempAt: 1. - - chosenClass _ self - askForSuperclassOf: interruptedContext receiver class - toImplement: message selector - ifCancel: [^self]. - - self implement: message inClass: chosenClass context: self selectedContext - -! ! -!Debugger methodsFor: 'method creation' stamp: 'HAW 1/12/2017 18:43:25'! - implement: aMessage inClass: aClass context: aContext - - aClass - compile: aMessage createStubMethod - classified: (self askForCategoryIn: aClass default: 'as yet unclassified'). - - aContext privRefreshWith: (aClass lookupSelector: aMessage selector). - aMessage arguments withIndexDo: [ :arg :index | aContext tempAt: index put: arg ]. - self resetContext: aContext! ! -!Debugger methodsFor: 'method creation' stamp: 'HAW 1/12/2017 17:22:28'! - wasInterrupedOnDoesNotUnderstand - - ^self interruptedContext selector == #doesNotUnderstand:! ! -!Debugger methodsFor: 'method creation' stamp: 'HAW 1/12/2017 17:25:23'! - wasInterruptedOnSubclassResponsibility - - ^self interruptedContext sender ifNil: [ false ] ifNotNil: [ :senderContext | senderContext selector == #subclassResponsibility ]! ! -!Debugger methodsFor: 'method creation' stamp: 'HAW 1/12/2017 18:31:48' prior: 50336540! - askForSuperclassOf: aClass toImplement: aSelector ifCancel: cancelBlock - - ^self askForSuperclassOf: aClass upTo: ProtoObject toImplement: aSelector ifCancel: cancelBlock -! ! -!Debugger methodsFor: 'method creation' stamp: 'HAW 1/12/2017 18:46:00' prior: 50336561! - createMethod - - self wasInterrupedOnDoesNotUnderstand ifTrue: [ ^self createMethodWhenDoesNotUndertand ]. - self wasInterruptedOnSubclassResponsibility ifTrue: [ ^self createMethodOnSubclassResponsibility ]. - - self inform: 'Only available for #doesNotUndertand: and #subclassResponsibility' ! ! -!Debugger methodsFor: 'method creation' stamp: 'HAW 1/12/2017 17:22:47' prior: 50336574! - shouldBeAbleToCreateMethod - - ^self wasInterrupedOnDoesNotUnderstand or: [ self wasInterruptedOnSubclassResponsibility]! ! -!DebuggerWindow methodsFor: 'GUI building' stamp: 'HAW 1/12/2017 18:46:32' prior: 50336580! - customButtonSpecs - "Answer an array of elements of the form wording, selector, help-message, that characterize the custom button row of a debugger." - - ^#( - ('Restart' restart 'reset this context to its start.') - ('Into' send 'step Into message sends') - ('Over' doStep 'step Over message sends') - ('Through' stepIntoBlock 'step into a block') - ('Full Stack' fullStack 'show full stack') - ('Where' where 'select current pc range') - ('Create' createMethod 'create method'))! ! -!PreDebugWindow methodsFor: 'GUI building' stamp: 'HAW 1/12/2017 18:47:35' prior: 50336599! - buttonRowForPreDebugWindow: aDebugger - | row aButton triads buttons | - buttons _ OrderedCollection new. - triads _ OrderedCollection withAll: self preDebugButtonSpec. - aDebugger shouldBeAbleToCreateMethod ifTrue: [ triads add: { 'Create'. #createMethod. 'create the missing method' }]. - - triads do: [ :triad | - aButton _ PluggableButtonMorph new model: self. - aButton label: triad first. - aButton action: triad second. - aButton setBalloonText: triad third. - buttons add: aButton]. - - row _ LayoutMorph newRow. - row doAdoptWidgetsColor. - row color: Color transparent. - row separation: 1. - row addMorphs: buttons. - ^row! ! - -Debugger removeSelector: #create! - -Debugger removeSelector: #create! - -Debugger removeSelector: #implement:inClass:! - -Debugger removeSelector: #implement:inClass:! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3034-CreateMethodSupport-HernanWilkinson-1-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3032] on 14 January 2017 at 9:09:47 am'! -!Theme methodsFor: 'menus' stamp: 'jmv 1/14/2017 09:09:05' prior: 16936064! - miscellaneousIcons - - "Everything else." - - ^ { - #('restore display (r)' 'set display depth...' 'move windows onscreen' 'Utilities saveDisplay.') -> #displayIcon. - #('changes...' 'dual change sorter' 'change sets with this method' 'find a change sorter' 'recent changes in file' 'Undo / Redo history' 'code file contents' 'package file contents') -> #changesIcon. - #('Install New Updates' 'update' 'turn on auto-update (a)' 'update list (u)' 'install code' 'fileIn entire file' 'install package') -> #updateIcon. - #('find again (g)' 'full stack (k)') -> #systemIcon. - #('print it (p)' 'check change set for slips') -> #printIcon. - #('accept (s)' 'make changes go to me (m)') -> #acceptIcon. - #('cancel (l)' 'turn off auto-update (a)') -> #cancelIcon. - #('debug...' 'Debug it (D)' 'toggle break on entry') -> #debugIcon. - #('close' 'close all debuggers' 'close top window') -> #closeIcon. - #('collapse' 'hide taskbar' 'collapse all windows') -> #collapseIcon. - #('expand / contract' 'show taskbar' 'restore all windows') -> #expandIcon. - #('menu') -> #windowMenuIcon. - #('browse all' 'browser' 'browse it (b)' 'MessageTally UI and browse' 'browse recent submissions' 'browse full (b)' 'find changed browsers...' 'browse (b)' 'browse my changes') -> #editFindReplaceIcon. - #('workspace' 'workspace with contents') -> #terminalIcon. - #('styled text editor' 'text editor' 'basic text editor' 'unicode editor' 'edit this list' 'edit postscript...' 'add postscript...') -> #textEditorIcon. - #('file list' 'find a fileList' 'compress file') -> #systemFileManagerIcon. - #('transcript' 'find a transcript' 'Transcript clear.' 'log to transcript') -> #printerIcon. - #('process browser' 'vm statistics' 'MessageTally all Processes') -> #systemMonitorIcon. - #('emergency evaluator' 'conflicts with other change sets' 'check for slips' 'conflicts with change set opposite' 'conflicts with category opposite') -> #emblemImportantIcon. - #('change sorter') -> #halfRefreshIcon. - #('SUnit Test Runner' 'Accept & Run Test in Class (t)' 'Accept & Run Test in Category (y)') -> #weatherFewCloudsIcon. - #('Font Sizes...' 'system fonts...' 'set font... (k)') -> #preferencesDesktopFontIcon. - #('full screen on') -> #viewFullscreenIcon. - #('full screen off') -> #exitFullscreenIcon. - #('set desktop color...') -> #wallpaperIcon. - #('preferences...' 'All preferences...' 'what to show...' 'view as hex') -> #preferencesIcon. - #('Editor keyboard shortcuts') -> #keyboardShortcutsIcon. - #('world menu help') -> #globeIcon. "currently unused, but a neat icon" - #('useful expressions' 'class comments with it' 'check for uncommented methods' 'check for uncommented classes') -> #chatIcon. - #('set code author...' 'check for other authors' 'check for any other authors') -> #usersIcon. - #('space left') -> #removableMediaIcon. - #('start drawing all again' 'window color...') -> #graphicsIcon. - #('start stepping again') -> #mediaPlaybackStartIcon. - #('file out current change set' 'fileOut' 'File out and remove (o)' 'File out and keep (k)') -> #fileOutIcon. - #('recently logged changes...' 'versions (v)' 'recent classes... (r)' 'trim history' 'Profile it') -> #clockIcon. - #('senders of it (n)' 'senders of... (n)' 'local senders of...' 'senders (n)') -> #mailForwardIcon. - #('implementors of it (m)' 'implementors of... (m)' 'implementors of sent messages') -> #developmentIcon. - #('references to it (N)') -> #addressBookIcon. - #('class var refs...' 'class refs (N)' 'class variables' 'class vars' 'local implementors of...' 'subclass template') -> #classIcon. - #('inst var refs...' 'inst var defs...' 'sample instance') -> #instanceIcon. - #('Use Selection for Find (j)' 'rename class ...' 'rename...' 'change title...') -> #saveAsIcon. - #('smalltalk options' 'method source with it' 'browse method (O)' 'check for uncategorized methods') -> #scriptIcon. - #('method strings with it (E)' 'Toggle WordWrap') -> #genericTextIcon. - #('browse hierarchy (h)' 'move to top' 'promote to top of list') -> #goTopIcon. - #('move up' 'make next-to-topmost') -> #goUpIcon. - #('move to bottom' 'send to back' 'send top window to back') -> #goBottomIcon. - #('inheritance (i)' 'move down') -> #goDownIcon. - #('browse protocol (p)' 'spawn sub-protocol') -> #spreadsheetIcon. - #('spawn full protocol') -> #speadsheetTemplateIcon. - #('alphabetize') -> #fontXGenericIcon. - #('Installed Packages' 'browse' 'show category (C)' 'categorize all uncategorized' 'select change set...' 'view affected class categories') -> #packageIcon. - #('remove from current change set' 'remove empty categories' 'subtract other side (-)' 'remove from this browser') -> #listRemoveIcon. - #('add to current change set' 'add all meths to current chgs' 'add preamble (p)' 'More...') -> #listAddIcon. - #('toggle diffing (D)' 'toggle selections') -> #switchIcon. - #('reorganize' 'create inst var accessors' 'ChangeSorter reorderChangeSets.' 'reorder all change sets' 'by name' 'by size' 'by date') -> #sendReceiveIcon. - #('unsent methods' 'unreferenced class vars' 'unreferenced inst vars' 'Undeclared inspect.' 'Undeclared removeUnreferencedKeys; inspect.' 'ChangeSorter removeEmptyUnnamedChangeSets.' 'check for unsent messages') -> #junkIcon. - #('find changed windows...') -> #newWindowIcon. - #('make undraggable') -> #pushPinIcon. - #('Utilities saveScreenshot.') -> #stillCameraIcon. - #('add new directory') -> #newFolderIcon. - #('select all' 'deselect all') -> #selectAllIcon. - #('sort by date') -> #dateIcon. - #('justified') -> #formatJustifyFillIcon. - #('centered') -> #formatJustifyCenterIcon. - #('set alignment...' 'leftFlush') -> #formatJustifyLeftIcon. - #('rightFlush') -> #formatJustifyRightIcon. - #('signal Semaphore (S)') -> #haloHelpIcon. - #('Change Paragraph Style...' 'Change Character Style...' 'Remove Character Style' 'Replace all uses of Paragraph Style...' 'Replace all uses of Character Style...' 'Set Default Font...') -> #fontXGenericIcon. - #('Clear Font') -> #newIcon. - #('code file browser' 'package file browser') -> #findIcon. - }! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Theme current class beCurrent! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3035-AddIconsForTDDSupport-JuanVuletich-2017Jan14-09h07m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3035] on 16 January 2017 at 11:04:32 am'! - -(Smalltalk classNamed: 'Taskbar') ifNotNil: [ :tbClass | - PasteUpMorph allInstancesDo: [ :w | w hideTaskbar ]. - tbClass allInstancesDo: [ :each | each delete ]]! - -StringMorph subclass: #UpdatingStringMorph - instanceVariableNames: 'target getSelector stepTime' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #UpdatingStringMorph category: #'Morphic-Widgets'! -StringMorph subclass: #UpdatingStringMorph - instanceVariableNames: 'target getSelector stepTime' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! -!UpdatingStringMorph commentStamp: 'jmv 1/5/2013 23:49' prior: 0! - UpdatingStringMorph new - target: [self runningWorld activeHand morphPosition asString]; - getSelector: #value; - stepTime: 10; - openInWorld! - -LayoutMorph subclass: #TaskbarMorph - instanceVariableNames: 'viewBox scale' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Taskbar'! - -!classDefinition: #TaskbarMorph category: #'Tools-Taskbar'! -LayoutMorph subclass: #TaskbarMorph - instanceVariableNames: 'viewBox scale' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Taskbar'! -!TaskbarMorph commentStamp: '' prior: 0! - A simple task bar written for Cuis. - -dashBoard contains views/controls -viewBox contains graphic buttons of "iconized" windows/morphs. -scale allows 1x 2x 4x tarkbar height. [scale= 1,2,4]! -!Preferences class methodsFor: 'personalization' stamp: 'jmv 1/15/2017 18:51:02'! - taskbarIncludesAllWindows - " - true: All windows are included in Taskbar - false: Only collapsed windows are included in Taskbar - " - ^ self - valueOfFlag: #taskbarIncludesAllWindows - ifAbsent: [ true ].! ! -!Morph methodsFor: 'accessing' stamp: 'jmv 1/15/2017 18:06:45'! - taskbar - ^self world ifNotNil: [ :w | w taskbar ]! ! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'jmv 1/15/2017 14:52:58'! -showAndComeToFront - - self show; comeToFront! ! -!PasteUpMorph methodsFor: 'change reporting' stamp: 'jmv 1/16/2017 09:56:14'! - addedMorph: aMorph - "Notify the receiver that the given morph was just added." - super addedMorph: aMorph. - self taskbar ifNotNil: [ :tb | - tb wasOpened: aMorph ]! ! -!PasteUpMorph methodsFor: 'change reporting' stamp: 'jmv 1/16/2017 09:56:07'! - removedMorph: aMorph - "Notify the receiver that aMorph was just removed from its children" - super removedMorph: aMorph. - self taskbar ifNotNil: [ :tb | - tb wasDeleted: aMorph ]! ! -!PasteUpMorph methodsFor: 'taskbar' stamp: 'jmv 1/15/2017 18:57:53'! - taskbarDeleted - taskbar _ nil! ! -!UpdatingStringMorph methodsFor: 'accessing' stamp: 'jmv 1/4/2013 13:15'! - getSelector: aSymbol - getSelector _ aSymbol! ! -!UpdatingStringMorph methodsFor: 'accessing' stamp: 'jmv 1/4/2013 13:18'! - stepTime - - ^stepTime! ! -!UpdatingStringMorph methodsFor: 'accessing' stamp: 'jmv 1/4/2013 13:15'! - stepTime: aNumber - stepTime _ aNumber! ! -!UpdatingStringMorph methodsFor: 'accessing' stamp: 'jmv 1/4/2013 13:15'! - target: anObject - target _ anObject! ! -!UpdatingStringMorph methodsFor: 'initialization' stamp: 'jmv 9/13/2013 09:23'! - initialize - super initialize. - target _ self. - getSelector _ #contents. - stepTime _ 50! ! -!UpdatingStringMorph methodsFor: 'stepping' stamp: 'jmv 2/27/2016 20:07'! - stepAt: millisecondSinceLast - - self contents: (target perform: getSelector)! ! -!UpdatingStringMorph methodsFor: 'stepping' stamp: 'jmv 1/4/2013 13:18'! - wantsSteps - "Return true if the receiver wants to its #step or #stepAt: methods be run" - - ^true! ! -!UpdatingStringMorph methodsFor: 'geometry' stamp: 'jmv 1/15/2017 14:25:27'! - fitContents - "Don't shrink each time contents change. - Might shrink during layout" - self morphExtent: (extent max: self measureContents)! ! -!UpdatingStringMorph class methodsFor: 'new-morph participation' stamp: 'jmv 4/15/2014 09:26'! - initializedInstance - "Answer a digital clock" - - | newInst | - newInst := self - contents: '' - font: (AbstractFont familyName: 'DejaVu' pointSize: 22) - emphasis: AbstractFont boldCode. - newInst - stepTime: 500; "half a second" - target: [String streamContents: [ :strm | DateAndTime now printHMSOn: strm]] ; - getSelector: #value. - - ^ newInst! ! -!TaskbarMorph methodsFor: 'accessing' stamp: 'jmv 1/15/2017 14:49:41'! - buttonFor: aMorph - - viewBox ifNotNil: [ - viewBox submorphs do: [ :button | - button model == aMorph - ifTrue: [ ^button ]] - ]. - ^nil! ! -!TaskbarMorph methodsFor: 'accessing' stamp: 'jmv 1/15/2017 14:49:30'! - scale - - ^ scale ifNil: [ self defaultScale ] ifNotNil: [ scale ]! ! -!TaskbarMorph methodsFor: 'events' stamp: 'jmv 1/8/2017 16:48:00'! - notifyDisplayResize - Display - when: #screenSizeChanged - send: #screenSizeChanged - to: self. - self screenSizeChanged! ! -!TaskbarMorph methodsFor: 'events' stamp: 'jmv 1/8/2017 16:48:14'! - screenSizeChanged - "Respond to change in screen size by repositioning self to bottom of screen" - -" Transcript newLine; print: 'Taskbar screenSizeChanged'. -" - | y e | - WorldState addDeferredUIMessage: [ - self world ifNotNil: [ :w | - y _ w morphExtent y - self defaultHeight. - e _ self internalizeDistance: w morphExtent x @ self defaultHeight. - self morphPosition: 0@y extent: e ]]! ! -!TaskbarMorph methodsFor: 'initialization' stamp: 'jmv 1/15/2017 14:49:51'! - defaultHeight - - ^ Preferences windowTitleFont height * 2 * self scale! ! -!TaskbarMorph methodsFor: 'initialization' stamp: 'jmv 1/15/2017 14:49:19'! - defaultScale - - ^ 1! ! -!TaskbarMorph methodsFor: 'initialization' stamp: 'jmv 1/8/2017 16:57:33'! - initialize - super initialize. - viewBox _ LayoutMorph newRow color: self defaultColor. - self - addMorph: UpdatingStringMorph initializedInstance - layoutSpec: (LayoutSpec morphWidthProportionalHeight: 1.0). - self - addMorph: viewBox - layoutSpec: (LayoutSpec - proportionalWidth: 1.0 - proportionalHeight: 1.0 - minorDirectionPadding: #right). - viewBox separation: 5 -! ! -!TaskbarMorph methodsFor: 'testing' stamp: 'jmv 1/8/2017 16:44:53'! - is: aSymbol - ^ aSymbol == #TaskbarMorph or: [ super is: aSymbol ]! ! -!TaskbarMorph methodsFor: 'testing' stamp: 'jmv 1/8/2017 16:47:41'! - isSticky - "answer whether the receiver is Sticky" - ^true! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 1/15/2017 18:42:23'! - addButtonFor: aMorph - - | button | - button _ PluggableButtonMorph - model: aMorph - stateGetter: nil - action: #showAndComeToFront. - button - color: self color; - icon: (aMorph imageForm: 32); - setBalloonText: aMorph label. - viewBox - addMorph: button - fixedWidth: self defaultHeight! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 1/15/2017 18:20:11'! - removeButtonFor: aMorph - - (self buttonFor: aMorph) ifNotNil: [ :b | - b delete ]! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 1/15/2017 18:49:21'! - restoreAll - viewBox ifNotNil: [ - viewBox submorphs do: [ :button | - button model showAndComeToFront ] ]! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 1/15/2017 18:23:09'! - wasCollapsed: aMorph - "Add a button for aMorph if not already there (see #taskbarIncludesAllWindows)" - - (self buttonFor: aMorph) ifNil: [ - self addButtonFor: aMorph ]! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 1/15/2017 18:25:27'! - wasDeleted: aMorph - "aMorph was deleted. Remove button for aMorph" - - self removeButtonFor: aMorph! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 1/15/2017 18:19:22'! - wasMadeVisible: aMorph - "aMorph is now visible. Remove button for aMorph if appropriate (see #taskbarIncludesAllWindows)" - - Preferences taskbarIncludesAllWindows ifFalse: [ - self removeButtonFor: aMorph ]! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 1/15/2017 18:21:15'! - wasOpened: aMorph - "aMorph was added to the world. Add button for aMorph if appropriate (see #taskbarIncludesAllWindows)" - - Preferences taskbarIncludesAllWindows ifTrue: [ - self addButtonFor: aMorph ]! ! -!TaskbarMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 1/15/2017 18:57:58'! -delete - - | w | - self restoreAll. - super delete. - w _ self world ifNil: [ self runningWorld ]. - Display removeActionsWithReceiver: self. - w ifNotNil: [ w taskbarDeleted ]! ! -!TaskbarMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 1/16/2017 09:52:23'! - noteNewOwner: aMorph - "I have just been added as a submorph of aMorph" - super noteNewOwner: aMorph. - Preferences taskbarIncludesAllWindows ifTrue: [ - aMorph submorphsDo: [ :m | - m == self ifFalse: [ - self addButtonFor: m ]]]. - self notifyDisplayResize! ! -!TaskbarMorph methodsFor: 'menus' stamp: 'jmv 1/15/2017 19:14:11'! - handlesMouseDown: aMouseButtonEvent - - ^ true! ! -!TaskbarMorph methodsFor: 'menus' stamp: 'jmv 1/15/2017 19:10:57'! - mouseButton2Activity - - | menu | - menu _ MenuMorph new defaultTarget: self. - menu - addLine; - add: 'Normal Height' action: #scaleNormal; - add: 'Scale x 2' action: #scaleX2; - add: 'Scale x 4' action: #scaleX4. - menu popUpInWorld! ! -!TaskbarMorph methodsFor: 'resize' stamp: 'jmv 1/15/2017 19:01:25'! - scale: anInteger - - (anInteger between: 1 and: 4) ifFalse: [ self error: 'scale should be 1 2 or 4' ]. - scale := anInteger. - self screenSizeChanged. "rescale self" - viewBox ifNotNil: [ "rescale buttons" - viewBox submorphs do: [ :button | - button layoutSpec fixedWidth: self defaultHeight - ] - ]! ! -!TaskbarMorph methodsFor: 'resize' stamp: 'jmv 1/15/2017 19:00:49'! - scaleNormal - - self scale: 1! ! -!TaskbarMorph methodsFor: 'resize' stamp: 'jmv 1/15/2017 19:00:52'! - scaleX2 - - self scale: 2! ! -!TaskbarMorph methodsFor: 'resize' stamp: 'jmv 1/15/2017 19:00:55'! - scaleX4 - - self scale: 4! ! -!TaskbarMorph class methodsFor: 'system startup' stamp: 'jmv 1/8/2017 16:47:17'! - initClassCachedState - - "Should use some other way to find relevant instances" - self flag: #jmvVer2. - self allInstancesDo: [ :each | - each notifyDisplayResize ]! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 1/15/2017 18:24:25' prior: 16874345! - visible: aBoolean - "set the 'visible' attribute of the receiver to aBoolean" - - self visible == aBoolean - ifTrue: [ ^ self ]. - aBoolean ifFalse: [ - self redrawNeeded ]. - self setProperty: #visible toValue: aBoolean. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - aBoolean ifTrue: [ - self redrawNeeded. - self taskbar ifNotNil: [ :tb | - tb wasMadeVisible: self ]]! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 1/15/2017 14:58:58' prior: 16875692! - comeToFrontAndAddHalo - self show. - self comeToFront. - self addHalo! ! -!Morph methodsFor: 'menus' stamp: 'jmv 1/15/2017 18:24:40' prior: 16876276! - collapse - "If taskbar not visible, just hide." - - self hide. - self taskbar - ifNotNil: [ :tb | tb wasCollapsed: self ]! ! -!Morph methodsFor: 'menus' stamp: 'jmv 1/15/2017 14:59:12' prior: 16876281! - expand - - self show. - self comeToFront! ! -!Morph methodsFor: 'testing' stamp: 'jmv 1/15/2017 15:04:18' prior: 16876985! - isCollapsed - - ^ self visible not! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 1/8/2017 16:44:57' prior: 16887743! - allNonWindowRelatedSubmorphs - "Answer all non-window submorphs that are not flap-related" - - ^submorphs - reject: [ :m | (m is: #SystemWindow) or: [ m is: #TaskbarMorph ] ]! ! -!PasteUpMorph methodsFor: 'taskbar' stamp: 'jmv 1/15/2017 14:43:48' prior: 16887920! - showTaskbar - - taskbar ifNil: [ - taskbar _ TaskbarMorph newRow. - taskbar openInWorld: self ]! ! -!StringMorph methodsFor: 'geometry' stamp: 'jmv 1/15/2017 14:22:53' prior: 16918181! - measureContents - | f | - f _ self fontToUse. - ^((f widthOfString: contents) max: 3) @ f height! ! - -TaskbarMorph removeSelector: #intoWorld:! - -PasteUpMorph removeSelector: #isCollapsed:! - -PasteUpMorph removeSelector: #isCollapsed:! - -PasteUpMorph removeSelector: #minimize:! - -PasteUpMorph removeSelector: #minimize:! - -PasteUpMorph removeSelector: #restore:! - -PasteUpMorph removeSelector: #restore:! - -PasteUpMorph removeSelector: #taskbar:! - -PasteUpMorph removeSelector: #taskbar:! - -PasteUpMorph allInstancesDo: [ :w | w showTaskbar ]! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3036-NewTaskbar-JuanVuletich-2017Jan16-10h55m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3036] on 17 January 2017 at 11:13:18 am'! -!DebuggerWindow methodsFor: 'GUI building' stamp: 'jmv 1/17/2017 10:51:52'! - initialExtent - ^ RealEstateAgent standardWindowExtent * 3 // 2! ! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 1/17/2017 11:12:27' prior: 16898269! - maximumUsableAreaInWorld: aWorldOrNil - - | allowedArea | - allowedArea _ Display boundingBox. - aWorldOrNil ifNotNil: [ - allowedArea _ allowedArea intersect: aWorldOrNil viewBox. - aWorldOrNil taskbar ifNotNil: [ :tb | - allowedArea _ (allowedArea areasOutside: tb morphBoundsInWorld) first ]]. - ^allowedArea -! ! -!PasteUpMorph methodsFor: 'geometry' stamp: 'jmv 1/17/2017 11:00:35' prior: 16887247! - privateExtent: newExtent - - ^ (super privateExtent: newExtent) - ifTrue: [ - self buildMagnifiedBackgroundImage. - worldState clearCanvas ]; yourself! ! -!PasteUpMorph methodsFor: 'project state' stamp: 'jmv 1/17/2017 10:56:23' prior: 16887422! - viewBox - - ^ worldState - ifNotNil: [ - 0@0 extent: extent ] - ifNil: [ - self world viewBox ]! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 1/17/2017 11:05:24' prior: 16887834! - restoreMorphicDisplay - DisplayScreen startUp. - self - morphExtent: Display extent; - handsDo: [ :h | h visible: true ]; - fullRepaintNeeded. - WorldState addDeferredUIMessage: [ Cursor normal activateCursor ]! ! -!PasteUpMorph class methodsFor: 'instance creation' stamp: 'jmv 1/17/2017 11:04:44' prior: 16887959! - newWorld - " -[ - ProjectX stopUIProcess. - ProjectX spawnNewMorphicProcessFor: PasteUpMorph newWorld -] fork. - " - | w ws | - w _ self new. - ws _ WorldState new. - w worldState: ws. - w morphPosition: 0@0 extent: Display extent. - ws setCanvas: Display getCanvas. - w borderWidth: 0. - ws handsDo: [ :h | - h privateOwner: w ]. - ^w! ! -!WorldState methodsFor: 'canvas' stamp: 'jmv 1/17/2017 10:57:47' prior: 16945711! - ensureNonDisplayCanvas - (canvas isNil or: [ - canvas drawsOnDisplay or: [ - (canvas extent ~= world morphExtent) or: [ - canvas form depth ~= Display depth]]]) ifTrue: [ - "allocate a new offscreen canvas the size of the window" - self setCanvas: (BitBltCanvas withExtent: world morphExtent depth: Display depth)]! ! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 1/17/2017 11:05:18' prior: 16946039! - tryDeferredUpdatingAndSetCanvasFor: aWorld - "If this platform supports deferred updates, then make my canvas be the Display (or a rectangular portion of it), set the Display to deferred update mode, and answer true. Otherwise, set a non-Disply canvas and answer false.." - | properDisplay | - - "As this is the only sender of #deferUpdates: , this could be done in Morphic or image startup, and never efterwards..." - (Display deferUpdates: true) ifNil: [ - "deferred updates not supported by the VM, do them in the image!!" - self ensureNonDisplayCanvas. - ^ false]. - - "if no canvas, or canvas was offscreen, from a platform that didnt support defers, then fix it" - properDisplay _ canvas notNil and: [canvas drawsOnDisplay]. - properDisplay ifFalse: [ - aWorld morphPosition: 0@0 extent: Display extent. - self setCanvas: Display getCanvas. - ]. - ^ true! ! -!WorldState methodsFor: 'drawing' stamp: 'jmv 7/28/2015 08:35' prior: 16946090! - displayWorld: aWorld submorphs: submorphs - "Update this world's display." - - | deferredUpdateVMMode worldDamageRects handsToDraw allDamage | - self checkIfUpdateNeeded ifFalse: [ ^ self ]. "display is already up-to-date" - "I (jmv) removed the call to 'deferUpdates: false' below. No more need to call this every time." - deferredUpdateVMMode _ self tryDeferredUpdatingAndSetCanvasFor: aWorld. - - "repair world's damage on canvas" - worldDamageRects _ self drawInvalidAreasWorld: aWorld submorphs: submorphs. - - "Check which hands need to be drawn (they are not the hardware mouse pointer)" - handsToDraw _ self selectHandsToDrawForDamage: worldDamageRects. - allDamage _ Array streamContents: [ :strm | - strm nextPutAll: worldDamageRects. - handsToDraw do: [ :h | - h savePatchFrom: canvas appendDamageTo: strm ]]. - - "Draw hands (usually carying morphs) onto world canvas" - canvas newClipRect: nil. - handsToDraw reverseDo: [ :h | canvas fullDrawHand: h ]. - - "quickly copy altered rects of canvas to Display:" - deferredUpdateVMMode ifFalse: [ - "Drawing was done to off-Display canvas. Copy content to Display" - canvas showAt: aWorld viewBox origin invalidRects: allDamage ]. - - "Display deferUpdates: false." - "Display forceDisplayUpdate" - Display forceDamageToScreen: allDamage. - - "Restore world canvas under hands and their carried morphs" - handsToDraw do: [ :h | h restoreSavedPatchOn: canvas ].! ! - -WorldState removeSelector: #viewBox! - -WorldState removeSelector: #viewBox! - -WorldState removeSelector: #viewBox:! - -WorldState removeSelector: #viewBox:! - -DebuggerWindow removeSelector: #initialFrameIn:! - -DebuggerWindow removeSelector: #initialFrameIn:! - -PasteUpMorph removeSelector: #viewBox:! - -PasteUpMorph removeSelector: #viewBox:! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3037-WindowsAvoidTaskbarArea-JuanVuletich-2017Jan17-10h47m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3037] on 18 January 2017 at 10:36:09 am'! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 1/18/2017 10:34:55' prior: 50337247! - addButtonFor: aMorph - - | button | - aMorph == self ifFalse: [ - button _ PluggableButtonMorph - model: aMorph - stateGetter: nil - action: #showAndComeToFront. - button - color: self color; - icon: (aMorph imageForm: 32); - setBalloonText: aMorph label. - viewBox - addMorph: button - fixedWidth: self defaultHeight ]! ! -!TaskbarMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 1/18/2017 10:35:05' prior: 50337310! - noteNewOwner: aMorph - "I have just been added as a submorph of aMorph" - super noteNewOwner: aMorph. - Preferences taskbarIncludesAllWindows ifTrue: [ - aMorph submorphsDo: [ :m | - self addButtonFor: m ]]. - self notifyDisplayResize! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3038-TaskbarTweaks-JuanVuletich-2017Jan18-10h34m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3038] on 18 January 2017 at 7:35:13 pm'! -!DirectoryEntry methodsFor: 'enumeration' stamp: 'jmv 1/18/2017 11:20:57'! - fileMatching: pattern -" - DirectoryEntry smalltalkImageDirectory fileMatching: '*.image'. - DirectoryEntry smalltalkImageDirectory fileMatching: 'x*.image'. -" - self filesDo: [ :file | - (pattern match: file name) - ifTrue: [ ^ file ]]. - ^ nil! ! -!DirectoryEntry methodsFor: 'enumeration' stamp: 'jmv 1/18/2017 11:13:59' prior: 16834484! - directoriesDo: aBlock - self childrenDo: [ :each | - each isFile ifFalse: [ - aBlock value: each ]]! ! -!DirectoryEntry methodsFor: 'enumeration' stamp: 'jmv 1/18/2017 11:19:42' prior: 16834701! - directoryMatching: pattern -" - DirectoryEntry smalltalkImageDirectory directoryMatching: 'C*Pack*'. - DirectoryEntry smalltalkImageDirectory directoryMatching: 'xC*Pack*'. -" - self directoriesDo: [ :directory | - (pattern match: directory name) - ifTrue: [ ^ directory ]]. - ^ nil! ! -!DirectoryEntry methodsFor: 'enumeration' stamp: 'jmv 1/18/2017 11:14:17' prior: 16834493! - filesDo: aBlock - self childrenDo: [ :each | - each isFile ifTrue: [ - aBlock value: each ]]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3039-DirectoryEntryTweaks-JuanVuletich-2017Jan18-19h34m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3039] on 18 January 2017 at 10:26:44 pm'! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 1/18/2017 22:25:29' prior: 50337608! - addButtonFor: aMorph - - | button | - aMorph == self ifFalse: [ - button _ PluggableButtonMorph - model: aMorph - stateGetter: nil - action: #showAndComeToFront. - button - color: self color; - icon: (aMorph imageForm: 32); - setBalloonText: aMorph label. - button icon: button magnifiedIcon. - viewBox - addMorph: button - fixedWidth: self defaultHeight ]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3040-DontWasteMemoryOnTaskbarButtons-JuanVuletich-2017Jan18-22h26m-jmv.1.cs.st----! - -----SNAPSHOT----#(18 January 2017 10:34:09.714849 pm) Cuis5.0-3040.image priorSource: 83085! - -----QUIT----#(18 January 2017 10:34:25.559349 pm) Cuis5.0-3040.image priorSource: 193640! - -----STARTUP----#(2 January 1901 12:00:01.075640272 am) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3040.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3040] on 22 January 2017 at 9:33:48 pm'! -!PasteUpMorph methodsFor: 'geometry' stamp: 'jmv 1/22/2017 21:17:32' prior: 50337463! - privateExtent: newExtent - - ^ (super privateExtent: newExtent) - ifTrue: [ - self buildMagnifiedBackgroundImage. - worldState ifNotNil: [ - worldState clearCanvas ]]; - yourself! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 1/22/2017 21:25:10' prior: 16926091! - drawOn: aCanvas - - | titleColor roundCorners | - - titleColor _ self widgetsColor. - self isTopWindow - ifTrue: [ titleColor _ titleColor lighter ]. - - roundCorners _ Theme current roundWindowCorners. - roundCorners - ifTrue: [ - "Round corners. Optional title gradient." - self drawRoundedFrameOn: aCanvas color: titleColor ] - ifFalse: [ - "No round corners. No title gradient." - self drawClassicFrameOn: aCanvas color: titleColor ]. - Theme current minimalWindows - ifFalse: [ - labelString ifNotNil: [self drawLabelOn: aCanvas]]! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 1/22/2017 21:31:40' prior: 16866779! - popUpInWorld: aWorld - "Present this menu under control of the given hand." - "Needed if not the real world but an inner PasteUpMorph" - | positionInWorld | - positionInWorld _ aWorld internalizeFromWorld: aWorld activeHand morphPosition. - ^self - popUpAt: positionInWorld - forHand: aWorld activeHand - in: aWorld -! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3041-Fix-clearCanvas-DNU-JuanVuletich-2017Jan22-21h17m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2974] on 3 December 2016 at 9:04:32 am'! -!Integer methodsFor: 'private' stamp: 'nice 1/19/2013 03:13'! - montgomeryDigitBase - "Answer the base used by Montgomery algorithm." - ^1 << self montgomeryDigitLength! ! -!Integer methodsFor: 'private' stamp: 'nice 1/19/2013 03:27'! - montgomeryDigitLength - "Answer the number of bits composing a digit in Montgomery algorithm. - Primitive use either 8 or 32 bits digits" - - ^8 "Legacy plugin which did not have this primitive did use 8 bits digits"! ! -!Integer methodsFor: 'private' stamp: 'nice 1/19/2013 03:14'! - montgomeryDigitMax - "Answer the maximum value of a digit used in Montgomery algorithm." - - ^1 << self montgomeryDigitLength - 1! ! -!Integer methodsFor: 'private' stamp: 'nice 1/19/2013 03:16'! - montgomeryNumberOfDigits - "Answer the number of montgomery digits required to represent the receiver." - ^self digitLength * 8 + (self montgomeryDigitLength - 1) // self montgomeryDigitLength! ! -!Integer methodsFor: 'mathematical functions' stamp: 'nice 1/16/2013 18:38' prior: 16859768! - raisedTo: n modulo: m - "Answer the modular exponential. - Note: this implementation is optimized for case of large integers raised to large powers." - | a s mInv | - n = 0 ifTrue: [^1]. - (self >= m or: [self < 0]) ifTrue: [^self \\ m raisedTo: n modulo: m]. - n < 0 ifTrue: [^(self reciprocalModulo: m) raisedTo: n negated modulo: m]. - (n < 4096 or: [m even]) - ifTrue: - ["Overhead of Montgomery method might cost more than naive divisions, use naive" - ^self slidingLeftRightRaisedTo: n modulo: m]. - - mInv := self montgomeryDigitBase - ((m bitAnd: self montgomeryDigitMax) reciprocalModulo: self montgomeryDigitBase). - - "Initialize the result to R=self montgomeryDigitModulo raisedTo: m montgomeryNumberOfDigits" - a := (1 bitShift: m montgomeryNumberOfDigits * m montgomeryDigitLength) \\ m. - - "Montgomerize self (multiply by R)" - (s := self montgomeryTimes: (a*a \\ m) modulo: m mInvModB: mInv) - ifNil: - ["No Montgomery primitive available ? fallback to naive divisions" - ^self slidingLeftRightRaisedTo: n modulo: m]. - - "Exponentiate self*R" - a := s montgomeryRaisedTo: n times: a modulo: m mInvModB: mInv. - - "Demontgomerize the result (divide by R)" - ^a montgomeryTimes: 1 modulo: m mInvModB: mInv! ! -!Integer methodsFor: 'testing' stamp: 'nice 11/14/2011 21:59' prior: 16860231! - isProbablyPrime - "See isProbablyPrimeWithK:andQ: for the algoritm description." - - | k q | - self <= 1 ifTrue: [ ^false ]. - self even ifTrue: [ ^self = 2 ]. - "Factor self into (2 raisedTo: k) * q + 1, where q odd" - q := self bitShift: -1. - k := q lowBit. - q := q bitShift: 1 - k. - "Repeat the probabilistic until false (the probability of false negative is null) or until probability is very low." - 25 timesRepeat: [ (self isProbablyPrimeWithK: k andQ: q) ifFalse: [ ^false ] ]. - "The probability of false positive after 25 iterations is less than (1/4 raisedTo: 25) < 1.0e-15" - ^true! ! -!Integer methodsFor: 'private' stamp: 'nice 11/15/2011 23:13' prior: 16860590! - isProbablyPrimeWithK: k andQ: q - "Algorithm P, probabilistic primality test, from - Knuth, Donald E. 'The Art of Computer Programming', Vol 2, - Third Edition, section 4.5.4, page 395, P1-P5 refer to Knuth description.. - Note that this is a Miller Rabin test which may answer false positives (known as pseudoprimes) for at most 1/4 of the possible bases x." - - | x j y minusOne | - "P1" - x := (self - 2) atRandom + 1. - "P2" - j := 0. - y := x raisedTo: q modulo: self. - minusOne := self - 1. - - ["P3" - y = 1 ifTrue: [^j = 0]. - y = minusOne ifTrue: [^true]. - "P4" - (j := j + 1) < k] - whileTrue: - [y := y squared \\ self]. - "P5" - ^false! ! -!Integer methodsFor: 'private' stamp: 'nice 1/16/2013 18:40' prior: 16860675! - montgomeryTimes: a modulo: m mInvModB: mInv - "Answer the result of a Montgomery multiplication - self * a * (b raisedTo: m montgomeryNumberOfDigits) inv \\ m - NOTE: it is assumed that: - self montgomeryNumberOfDigits <= m montgomeryNumberOfDigits - a montgomeryNumberOfDigits <= m montgomeryNumberOfDigits - mInv * m \\ b = (-1 \\ b) = (b-1) (this implies m odd) - where b = self montgomeryDigitBase - - Answer nil in case of absent plugin or other failure." - - - ^nil! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3042-MontgomeryExponentiationFix-LucianoEstebanNotarfrancesco-2016Nov29-21h10m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3042] on 22 January 2017 at 9:49:56 pm'! -!Integer methodsFor: 'arithmetic' stamp: 'len 12/4/2016 13:11:44'! - reciprocalModulo2: n - "Answer an integer x such that self * x \\ n = 1, with 0 < x < n, or nil if it doesn't exist." - | xgcd | - self == 0 ifTrue: [^ nil]. - self == 1 ifTrue: [^ 1]. - xgcd _ self xgcd: n. - ^ (xgcd at: 1) == 1 ifTrue: [^ (xgcd at: 2) \\ n]! ! -!Integer methodsFor: 'arithmetic' stamp: 'len 12/4/2016 13:07:08'! - xgcd: anInteger - "Extended Euclidean algorithm. - Answer an array {x. u. v} where self * u + (anInteger * v) = x, and x = (self gcd: anInteger)." - | a b s t sp tp r rp | - a _ self. b _ anInteger. - s _ 0. sp _ 1. - t _ 1. tp _ 0. - r _ a abs. rp _ b abs. - [r == 0] - whileFalse: - [ | q temp | - q _ rp // r. - temp _ r. r _ rp - (q * r). rp _ temp. - temp _ s. s _ sp - (q * s). sp _ temp. - temp _ t. t _ tp - (q * t). tp _ temp]. - sp _ sp * b sign. tp _ tp * a sign. - ^ {rp. tp. sp}! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3043-Alternative-gcd-reciprocalModulo-LucianoEstebanNotarfrancesco-2017Jan22-21h46m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3043] on 16 February 2017 at 2:31:35 pm'! -!FileSystemEntry methodsFor: 'accessing-file name' stamp: 'jmv 2/16/2017 11:21:10' prior: 16843823! - baseName - ^self fileAccessor baseNameFor: name! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3044-basename-fix-JuanVuletich-2017Feb16-11h21m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3044] on 17 February 2017 at 3:11:08 pm'! -!PluggableButtonMorph methodsFor: 'private' stamp: 'jmv 2/17/2017 15:10:48' prior: 16888368! - magnifiedIcon - | factor magnifiedExtent w h | - - icon ifNil: [ ^nil ]. - magnifiedIcon ifNil: [ - magnifiedIcon _ icon. - w _ icon width. - h _ icon height. - w*h = 0 ifFalse: [ - factor _ 1.0 * extent x / w min: 1.0 * extent y / h. - (factor < 1 or: [ factor > 1.7 and: [self isRoundButton]]) ifTrue: [ - magnifiedExtent _ (icon extent * factor) rounded. - magnifiedIcon _ icon magnifyTo: magnifiedExtent ]]]. - ^magnifiedIcon! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3045-magnifiedIcon-fix-JuanVuletich-2017Feb17-15h10m-jmv.1.cs.st----! - -----SNAPSHOT----#(2 January 1901 12:00:01.075640278 am) Cuis5.0-3045.image priorSource: 193734! - -----QUIT----#(1 January 1901 12:00:01.56749216 am) Cuis5.0-3045.image priorSource: 202527! - -----STARTUP----#(6 March 2017 10:36:08.27543 am) as C:\Users\Juan-Tuerca\PayloadSoftware\Cuis-Smalltalk-Dev\Cuis5.0-3045.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3042] on 10 February 2017 at 5:39:28 pm'! - -Object subclass: #ProgessiveTestRunner - instanceVariableNames: 'testSuite testsStream progressBar testResult testRunIncrement' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Testing'! - -!classDefinition: #ProgessiveTestRunner category: #'Tools-Testing'! -Object subclass: #ProgessiveTestRunner - instanceVariableNames: 'testSuite testsStream progressBar testResult testRunIncrement' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Testing'! -!Browser methodsFor: 'tdd' stamp: 'HAW 2/10/2017 17:32:22'! - debugMethodTest - - currentCompiledMethod isTestMethod ifTrue: [ - currentCompiledMethod methodClass debugAsFailure: currentCompiledMethod selector ] -! ! -!Browser methodsFor: 'tdd' stamp: 'HAW 2/4/2017 20:33:00'! - runClassTests - - self selectedClassName ifNotNil: [ :aClassName | | selectedClass | - selectedClass _ Smalltalk classNamed: aClassName. - (ProgessiveTestRunner for: (TestSuite forClass: selectedClass)) value ]! ! -!Browser methodsFor: 'tdd' stamp: 'HAW 2/7/2017 10:47:50'! - runMessageCategoryTests - - selectedMessageCategory ifNotNil: [ | selectedClass suite | - selectedClass _ Smalltalk classNamed: selectedClassName. - suite _ TestSuite forMessageCategoryNamed: selectedMessageCategory of: selectedClass categorizedWith: classOrganizer. - (ProgessiveTestRunner for: suite) value ] - - ! ! -!Browser methodsFor: 'tdd' stamp: 'HAW 2/4/2017 21:51:50'! - runMethodTest - - | suite | - - suite _ TestSuite forCompiledMethod: currentCompiledMethod. - (ProgessiveTestRunner for: suite) value - ! ! -!Browser methodsFor: 'tdd' stamp: 'HAW 2/1/2017 19:23:54'! - runSystemCategoryTests - - selectedSystemCategory ifNotNil: [ | suite | - suite _ TestSuite forSystemCategoryNamed: selectedSystemCategory using: systemOrganizer. - (ProgessiveTestRunner for: suite) value ] - - ! ! -!Behavior methodsFor: 'tdd' stamp: 'HAW 2/7/2017 11:55:50'! - testCaseClass - - self subclassResponsibility ! ! -!Behavior methodsFor: 'tdd' stamp: 'HAW 2/7/2017 11:55:40'! - withTestCaseClassDo: aFoundTestCaseClassBlock ifNone: aNoneBlock - - | potentialTestCaseClass | - - potentialTestCaseClass _ self testCaseClass. - - ^potentialTestCaseClass ifNil: aNoneBlock ifNotNil: aFoundTestCaseClassBlock - ! ! -!Class methodsFor: 'tdd' stamp: 'HAW 2/7/2017 10:42:40'! -testCaseClass - - | potentialTestCaseClass | - - potentialTestCaseClass _ Smalltalk classNamed: self name, 'Test'. - - ^potentialTestCaseClass - - ! ! -!Metaclass methodsFor: 'tdd' stamp: 'HAW 2/7/2017 11:56:51'! - testCaseClass - - ^self soleInstance testCaseClass ! ! -!Categorizer methodsFor: 'tdd' stamp: 'HAW 2/7/2017 09:06:13'! - classesAt: aCategoryName - - ^(self listAtCategoryNamed: aCategoryName) collect: [:aClassName | Smalltalk classNamed: aClassName ] - ! ! -!Categorizer methodsFor: 'tdd' stamp: 'HAW 2/7/2017 09:06:34'! - testCaseClassesAt: aCategoryName - - ^(self classesAt: aCategoryName) select: [ :aClass | aClass is: #TestCaseClass ]! ! -!SmalltalkEditor methodsFor: 'editing keys' stamp: 'HAW 2/10/2017 16:03:46'! - acceptAndDebugTest: aKeyboardEvent - - ^self acceptAndDebugTest ! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HAW 2/10/2017 17:34:45'! - acceptAndDebugTest - - ^self acceptAndWithMethodDo: [ :aPotencialTestMethod | - aPotencialTestMethod isTestMethod ifTrue: [ aPotencialTestMethod methodClass debugAsFailure: aPotencialTestMethod selector ]]! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HAW 2/10/2017 17:34:38'! - acceptAndWithMethodDo: aBlock - - | potencialTestMethod | - - self acceptContents ifFalse: [ ^false ]. - - potencialTestMethod _ self codeProvider currentCompiledMethod. - ^potencialTestMethod - ifNil: [ false ] - ifNotNil: [ - aBlock value: potencialTestMethod. - true]! ! -!ProgessiveTestRunner methodsFor: 'initialization' stamp: 'HAW 2/1/2017 19:20:06'! - initializeFor: aTestSuite - - testSuite _ aTestSuite. - ! ! -!ProgessiveTestRunner methodsFor: 'evaluating' stamp: 'HAW 1/31/2017 11:50:37'! - value - - testsStream _ ReadStream on: testSuite tests. - testsStream atEnd - ifTrue: [ self informNoTestToRun ] - ifFalse:[ self createProgressBarAndRun ]! ! -!ProgessiveTestRunner methodsFor: 'progress bar - private' stamp: 'HAW 1/31/2017 10:25:22'! - calculateTestRunIncrement - - testRunIncrement _ 1/testsStream size! ! -!ProgessiveTestRunner methodsFor: 'progress bar - private' stamp: 'HAW 1/31/2017 10:25:31'! - createProgressBar - - progressBar _ ProgressMorph label: testSuite name. - self calculateTestRunIncrement. - self updateProgressBarSubLabel. - ! ! -!ProgessiveTestRunner methodsFor: 'progress bar - private' stamp: 'HAW 1/31/2017 10:25:43'! - updateDoneIncrement - - progressBar incrDone: testRunIncrement - ! ! -!ProgessiveTestRunner methodsFor: 'progress bar - private' stamp: 'HAW 1/31/2017 11:10:25'! - updateProgressBarSubLabel - - testsStream atEnd ifFalse: [ - progressBar subLabel: testsStream next printString, ' (', testsStream position printString, '/', testsStream size printString, ')' ].! ! -!ProgessiveTestRunner methodsFor: 'show result - private' stamp: 'HAW 1/31/2017 20:05:25'! - informAllTestPassed - - PopUpMenu inform: testResult printString. - ! ! -!ProgessiveTestRunner methodsFor: 'show result - private' stamp: 'HAW 1/31/2017 10:05:21'! - informNoTestToRun - - PopUpMenu inform: 'No test to run'! ! -!ProgessiveTestRunner methodsFor: 'show result - private' stamp: 'HAW 2/1/2017 19:26:08'! - openTestResultForDebuggingAndInspection - - testResult forDebuggingAndInspection inspect ! ! -!ProgessiveTestRunner methodsFor: 'show result - private' stamp: 'HAW 1/31/2017 10:10:53'! - showDeffects - - | defects | - - defects _ testResult defects. - defects size = 1 - ifTrue: [ defects anyOne debug ] - ifFalse: [ self openTestResultForDebuggingAndInspection]! ! -!ProgessiveTestRunner methodsFor: 'evaluating - private' stamp: 'HAW 2/1/2017 19:14:08'! - createProgressBarAndRun - - self createProgressBar. - [ self runSuiteShowingProgress ] fork! ! -!ProgessiveTestRunner methodsFor: 'evaluating - private' stamp: 'HAW 2/1/2017 19:26:59'! - registerTestSuiteAction - - testSuite when: #changed: send: #testRun: to: self! ! -!ProgessiveTestRunner methodsFor: 'evaluating - private' stamp: 'HAW 1/31/2017 10:09:41'! - runSuite - - testResult _ testSuite run. - testResult hasPassed - ifTrue: [ self informAllTestPassed ] - ifFalse: [self showDeffects ] - ! ! -!ProgessiveTestRunner methodsFor: 'evaluating - private' stamp: 'HAW 1/31/2017 11:47:58'! - runSuiteShowingProgress - - [ self registerTestSuiteAction. - progressBar openInWorld. - self runSuite ] ensure: [ - self unregisterTestSuiteAction. - WorldState addDeferredUIMessage: [progressBar dismissMorph] ]. - ! ! -!ProgessiveTestRunner methodsFor: 'evaluating - private' stamp: 'HAW 2/1/2017 19:19:28'! - testRun: aTest - - self updateProgressBarSubLabel. - self updateDoneIncrement - - ! ! -!ProgessiveTestRunner methodsFor: 'evaluating - private' stamp: 'HAW 1/31/2017 10:04:32'! - unregisterTestSuiteAction - - testSuite releaseActionMap ! ! -!ProgessiveTestRunner class methodsFor: 'instance creation' stamp: 'HAW 1/31/2017 09:37:34'! - for: aTestSuite - - ^self new initializeFor: aTestSuite! ! -!TestCase class methodsFor: 'Instance Creation' stamp: 'HAW 2/10/2017 16:01:40'! - debugAsFailure: aSymbol - - ^(self selector: aSymbol) debugAsFailure - ! ! -!TestSuite class methodsFor: 'Creation' stamp: 'HAW 2/4/2017 20:31:47'! - forClass: aClass - - ^(aClass is: #TestCaseClass) - ifTrue: [ self forTestCaseClass: aClass ] - ifFalse: [ self forNoTestCaseClass: aClass ] -! ! -!TestSuite class methodsFor: 'Creation' stamp: 'HAW 2/4/2017 21:53:12'! - forCompiledMethod: aCompiledMethod - - ^aCompiledMethod isTestMethod - ifTrue: [ self forTestMethod: aCompiledMethod ] - ifFalse: [ self forNoTestMethod: aCompiledMethod ] - ! ! -!TestSuite class methodsFor: 'Creation' stamp: 'HAW 2/1/2017 18:43:22'! - forMessageCategoryNamed: aMessageCategoryName of: aClass categorizedWith: aClassOrganizer - - | suite | - - suite _ self named: aClass name, ' tests categorized under ',aMessageCategoryName. - (aClassOrganizer listAtCategoryNamed: aMessageCategoryName) do: [ :selector | - (aClass compiledMethodAt: selector) isTestMethod ifTrue: [ suite addTest: (aClass selector: selector) ]]. - - ^suite - ! ! -!TestSuite class methodsFor: 'Creation' stamp: 'HAW 2/7/2017 10:24:12'! - forSystemCategoryNamed: aCategoryName using: aSystemOrganizer - - | testCaseClasses | - - testCaseClasses _ aSystemOrganizer testCaseClassesAt: aCategoryName. - - ^testCaseClasses isEmpty - ifTrue: [ self forClasses: (aSystemOrganizer classesAt: aCategoryName) named: aCategoryName, ' infered tests' ] - ifFalse: [ self forTestCaseClasses: testCaseClasses named: aCategoryName, ' tests' ] - -! ! -!TestSuite class methodsFor: 'Creation - Private' stamp: 'HAW 2/7/2017 10:25:51'! - allTestCaseClassesReferencing: aClass - - ^(aClass allCallsOn - collect: [ :aMethodReference | aMethodReference actualClass ] - thenSelect: [ :aPotentialTestCaseClass | aPotentialTestCaseClass is: #TestCaseClass ]) asSet.! ! -!TestSuite class methodsFor: 'Creation - Private' stamp: 'HAW 2/7/2017 10:27:27'! - allTestsSending: aSelector - - ^(Smalltalk allCallsOn: aSelector) select: [:aMethodReference | - (aMethodReference actualClass is: #TestCaseClass) and: [aMethodReference compiledMethod isTestMethod ]].! ! -!TestSuite class methodsFor: 'Creation - Private' stamp: 'HAW 2/7/2017 09:08:23'! - forClasses: classes named: name - - | suite | - - suite _ classes - inject: (self named: name) - into: [ :partialSuite :aClass | partialSuite addTests: (self forClass: aClass) tests ]. - - ^suite - -! ! -!TestSuite class methodsFor: 'Creation - Private' stamp: 'HAW 2/7/2017 10:32:17'! - forNoTestCaseClass: aClass - - ^aClass - withTestCaseClassDo: [ :aTestCaseClass | self forTestCaseClass: aTestCaseClass ] - ifNone: [ self forReferencesToClass: aClass ] - -! ! -!TestSuite class methodsFor: 'Creation - Private' stamp: 'HAW 2/7/2017 11:28:55'! - forNoTestMethod: aCompiledMethod - - | allTestSenders testCaseClassesReferencingClass reducedTestSenders suite | - - allTestSenders _ self allTestsSending: aCompiledMethod selector. - testCaseClassesReferencingClass _ aCompiledMethod methodClass - withTestCaseClassDo: [:aTestCaseClass | Array with: aTestCaseClass ] - ifNone: [ self allTestCaseClassesReferencing: aCompiledMethod methodClass ]. - - reducedTestSenders _ allTestSenders select: [ :aMethodReference | testCaseClassesReferencingClass includes: aMethodReference actualClass ]. - reducedTestSenders isEmpty - ifTrue: [ suite _ self forClass: aCompiledMethod methodClass ] - ifFalse: [ - suite _ self named: 'Tests senders of ', aCompiledMethod selector. - reducedTestSenders do: [ :aMethodReference | suite addTest: (aMethodReference actualClass selector: aMethodReference selector)]]. - - ^suite! ! -!TestSuite class methodsFor: 'Creation - Private' stamp: 'HAW 2/7/2017 10:33:27'! - forReferencesToClass: aClass - - | testCaseClasses | - - testCaseClasses _ self allTestCaseClassesReferencing: aClass. - - ^testCaseClasses - inject: (self named: aClass name, ' all test references') - into: [ :suite :aTestCaseClass | aTestCaseClass addToSuiteFromSelectors: suite ] - - -! ! -!TestSuite class methodsFor: 'Creation - Private' stamp: 'HAW 2/7/2017 10:34:27'! - forTestCaseClass: aTestCaseClass - - | suite | - - suite _ aTestCaseClass buildSuite. - suite name: aTestCaseClass name, ' tests'. - - ^suite! ! -!TestSuite class methodsFor: 'Creation - Private' stamp: 'HAW 2/7/2017 09:04:48'! - forTestCaseClasses: testCaseClasses named: aName - - | suite | - - suite _ testCaseClasses - inject: (self named: aName) - into: [:partialSuite :aTestCaseClass | aTestCaseClass addToSuiteFromSelectors: partialSuite ]. - - ^suite! ! -!TestSuite class methodsFor: 'Creation - Private' stamp: 'HAW 2/4/2017 21:53:22'! - forTestMethod: aCompiledMethod - - | suite | - - suite _ self named: 'Test'. - suite addTest: (aCompiledMethod methodClass selector: aCompiledMethod selector). - - ^suite - ! ! -!UndefinedObject methodsFor: 'class hierarchy' stamp: 'HAW 2/10/2017 17:37:23'! - allSuperclassesUpTo: aSuperclass - - self error: (self superclassNotValidErrorDescriptionFor: aSuperclass)! ! -!UndefinedObject methodsFor: 'class hierarchy' stamp: 'HAW 2/10/2017 17:37:30'! - superclassNotValidErrorDescriptionFor: aClass - - ^aClass name, ' not in superclasses chain'! ! -!Behavior methodsFor: 'system-support' stamp: 'HAW 2/4/2017 20:51:10' prior: 16785122! - allCallsOn - "Answer a SortedCollection of all the methods that refer to me by name or - as part of an association in a global dict." - " - ^ (Smalltalk - allCallsOn: (Smalltalk associationAt: self theNonMetaClass name)) - , (Smalltalk allCallsOn: self theNonMetaClass name) - " - - ^ Smalltalk allCallsOn: self theNonMetaClass name! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'HAW 2/4/2017 20:49:09' prior: 16923905! - browseAllCallsOnClass: aClass - "Create and schedule a message browser on each method that refers to - aClass. For example, Smalltalk browseAllCallsOnClass: Object." - self - browseMessageList: aClass allCallsOn asArray sort - name: 'Users of class ' , aClass theNonMetaClass name - autoSelect: aClass theNonMetaClass name.! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HAW 2/1/2017 18:51:22' prior: 50336078! - acceptAndTest - - self acceptThenTestMethodAndSuite: [ :aMethod | self testSuiteOf: aMethod methodClass ]. - ^true! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HAW 2/1/2017 18:50:41' prior: 50336084! - acceptAndTestAll - - self acceptThenTestMethodAndSuite: [ :aMethod | self testSuiteForCategoryOf: aMethod methodClass ]. - ^true - - ! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HAW 2/10/2017 17:34:52' prior: 50336091! - acceptThenTestMethodAndSuite: aSuiteBuilder - - self acceptAndWithMethodDo: [ :aPotencialTestMethod | - self runAndDebuggIfNecessary: aPotencialTestMethod. - self runTestSuite: (aSuiteBuilder value: aPotencialTestMethod) ]! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HAW 2/10/2017 16:08:47' prior: 50336113! - runAndDebuggIfNecessary: aPotencialTestMethod - - aPotencialTestMethod isTestMethod ifTrue: [ - aPotencialTestMethod methodClass debug: aPotencialTestMethod selector ]! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HAW 2/1/2017 19:19:02' prior: 50336121! - runTestSuite: aTestSuite - - (ProgessiveTestRunner for: aTestSuite) value - - ! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HAW 2/5/2017 10:49:25' prior: 50336131! - testSuiteForCategoryOf: aClass - - ^TestSuite forSystemCategoryNamed: aClass category using: SystemOrganization -! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HAW 2/5/2017 10:48:27' prior: 50336148! - testSuiteOf: aClass - - ^TestSuite forClass: aClass -! ! -!SmalltalkEditor class methodsFor: 'keyboard shortcut tables' stamp: 'HAW 2/10/2017 15:58:27' prior: 50336375! - cmdShortcutsSpec - " - Editor initialize - " - "arranged in QWERTY keyboard order" - ^#( - #( $r #acceptAndDebugTest: 'Saves method and debugs it') - #( $t #acceptAndTest: 'Saves method, runs it as test and then all tests in class. Opens debugger if error') - #( $y #acceptAndTestAll: 'Saves method, runs it as test and then all tests in class category. Opens debugger if error') - #( $i #inspectIt: 'Inspect it (selection is a valid expression, or selection is over an inspect-ilst)') - #( $p #printIt: 'Print it (selection is a valid expression)') - - #( $s #save: 'Save (i.e. accept)') - #( $d #doIt: 'Do it (selection is a valid expression)') - #( $l #cancelEdits: 'Cancel') - - #( $b #browseIt: 'Browse it (selection is a class name or cursor is over a class-list or message-list)') - #( $n #sendersOfIt: 'Senders of it (selection is a message selector or cursor is over a class-list or message-list)') - #( $m #implementorsOfIt: 'Implementors of it (selection is a message selector or cursor is over a class-list or message-list)') - - #( $E #methodStringsContainingit:'Method strings containing it') - #( $T #displayIfTrue: 'Insert #ifTrue:') - #( $I #exploreIt: 'Inspect via Object Explorer') - - #( $A #argAdvance: 'Advance argument') - #( $D #debugIt: 'Debut it') - #( $F #displayIfFalse: 'Insert #ifFalse:') - #( $G #fileItIn: 'File in selection') - - #( $V #pasteInitials: 'Paste author initials') - #( $N #referencesToIt: 'References to it (selection is a class name, or cursor is over a class-list or message-list)') - )! ! -!SmalltalkEditor class methodsFor: 'keyboard shortcut tables' stamp: 'HAW 2/10/2017 15:57:40' prior: 50336429! - initializeMenu - "Initialize the mouseButton2 (right button) pop-up menu and corresponding messages." - " - Editor initialize - " - - menu _ SelectionMenu fromArray: { - {'Help...'. #openHelp}. - #-. - {'Do it (d)'. #doIt}. - {'Print it (p)'. #printIt}. - {'Inspect it (i)'. #inspectIt}. - {'Explore it (I)'. #exploreIt}. - {'Debug it (D)'. #debugIt}. - {'Profile it'. #profileIt}. - #-. - {'Explain'. #explain}. - {'Browse it (b)'. #browseIt}. - {'Senders of it (n)'. #sendersOfIt}. - {'Implementors of it (m)'. #implementorsOfIt}. - {'References to it (N)'. #referencesToIt}. - #-. - {'Method Strings with it (E)'. #methodStringsContainingit}. - {'Method Source with it'. #methodSourceContainingIt}. - {'Class Comments with it'. #classCommentsContainingIt}. - #-. - {'Accept (s)'. #acceptContents}. - {'Cancel (l)'. #cancelEdits}. - {'Accept & Run Test in Class (t)'. #acceptAndTest}. - {'Accept & Run Test in Category (y)'. #acceptAndTestAll}. - {'Accept & Debug Test (r)'. #acceptAndDebugTest}. - #-. - {'More...'. #getMenu2}. - }. - menu2 _ SelectionMenu fromArray: { - {'Find...(f)'. #find}. - {'Find Again (g)'. #findAgain}. - {'Use Selection for Find (j)'. #setSearchString}. - #-. - {'Undo - multiple (z)'. #undo}. - {'Redo - multiple (Z)'. #redo}. - {'Undo / Redo history'. #offerUndoHistory}. - #-. - {'Copy (c)'. #copySelection}. - {'Cut (x)'. #cut}. - {'Paste (v)'. #paste}. - {'Paste without Format'. #pasteString}. - {'Paste...'. #pasteRecent}. - #-. - {'Toggle WordWrap'. #wrapOnOff}. - {'Set Font... (k)'. #offerFontMenu}. - {'Clear Font'. #clearFont}. - {'Set Default Font...'. #offerDefaultFontMenu}. - #-. - {'More...'. #getMenu}. - }! ! -!CodeWindow methodsFor: 'keyboard shortcuts' stamp: 'HAW 1/31/2017 11:56:31' prior: 16813767! - classListKey: aChar from: view - "Respond to a Command key. I am a model with a list of classes and a - code pane, and I also have a listView that has a list of methods. The - view knows how to get the list and selection." - - aChar == $r ifTrue: [^ model recent]. - aChar == $h ifTrue: [^ self browseHierarchy]. - aChar == $x ifTrue: [^ model removeClass]. - aChar == $t ifTrue: [^ model runClassTests ]. - - ^ self messageListKey: aChar from: view! ! -!CodeWindow methodsFor: 'keyboard shortcuts' stamp: 'HAW 2/10/2017 17:33:25' prior: 16813782! - messageListKey: aChar from: view - "Respond to a Command key. I am a model with a code pane, and I also - have a listView that has a list of methods. The view knows how to get - the list and selection." - - | sel class | - aChar == $D ifTrue: [^ model toggleDiffing]. - - sel _ model selectedMessageName. - aChar == $m ifTrue: [ "These next two put up a type in if no message selected" - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllImplementorsOf: to: Smalltalk]. - aChar == $n ifTrue: [ - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllCallsOn: to: Smalltalk]. - - "The following require a class selection" - (class _ model selectedClassOrMetaClass) ifNil: [^ self ]. - aChar == $b ifTrue: [^ BrowserWindow fullOnClass: class selector: sel]. - aChar == $N ifTrue: [^ self browseClassRefs]. - aChar == $i ifTrue: [^ self methodHierarchy]. - aChar == $h ifTrue: [^ self browseHierarchy]. - aChar == $p ifTrue: [^ self browseFullProtocol]. - - "The following require a method selection" - sel ifNotNil: [ - aChar == $o ifTrue: [^ model fileOutMessage]. - aChar == $c ifTrue: [^ model copySelector]. - aChar == $v ifTrue: [^ self browseVersions]. - aChar == $O ifTrue: [^ self openSingleMessageBrowser]. - aChar == $x ifTrue: [^ model removeMessage]. - aChar == $t ifTrue: [^ model runMethodTest]. - aChar == $r ifTrue: [^ model debugMethodTest]]! ! -!CodeWindow methodsFor: 'keyboard shortcuts' stamp: 'HAW 2/7/2017 10:49:07' prior: 16813824! - systemCatListKey: aChar from: view - "Respond to a Command key. I am a model with a code pane, and I also have a listView that has a list of methods. The view knows how to get the list and selection." - - aChar == $f ifTrue: [^ self findClass]. - aChar == $x ifTrue: [^ model removeSystemCategory]. - aChar == $t ifTrue: [ ^model runSystemCategoryTests ]. - - ^ self classListKey: aChar from: view! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'HAW 1/31/2017 11:32:21' prior: 16793212! - classListMenu - "Set up the menu to apply to the receiver's class list, honoring the #shifted boolean" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addList: #( - ('browse full (b)' browseMethodFull) - ('browse hierarchy (h)' browseHierarchy) - ('browse protocol (p)' browseFullProtocol) - - - ('fileOut' fileOutClass '' model) - - - ('show hierarchy' hierarchy '' model) - ('show definition' editClass '' model) - ('show comment' editComment '' model) - - - ('inst var refs...' browseInstVarRefs) - ('inst var defs...' browseInstVarDefs) - - - ('class var refs...' browseClassVarRefs) - ('class vars' browseClassVariables) - ('class refs (N)' browseClassRefs) - - - ('rename class ...' renameClass '' model) - ('copy class...' copyClass '' model) - ('remove class (x)' removeClass '' model) - - - ('Run tests (t)' runClassTests '' model) - ('more...' offerShiftedClassListMenu)). - ^ aMenu! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'HAW 1/31/2017 19:57:02' prior: 16793244! - messageCategoryMenu - - | aMenu | - aMenu _ MenuMorph new defaultTarget: model. "All the options are for the model." - aMenu addList: #( - ('fileOut' fileOutMessageCategories) - - - ('reorganize' editMessageCategories) - ('alphabetize' alphabetizeMessageCategories) - ('remove empty categories' removeEmptyCategories) - ('categorize all uncategorized' categorizeAllUncategorizedMethods) - ('new category...' addCategory) - - - ('rename...' renameCategory) - ('remove' removeMessageCategory) - - - ('Run tests' runMessageCategoryTests)). - ^aMenu! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'HAW 2/10/2017 17:29:43' prior: 16793264! -messageListMenu - "Answer the message-list menu" - "Changed by emm to include menu-item for breakpoints" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addList:#( - ('what to show...' offerWhatToShowMenu) - ('toggle break on entry' toggleBreakOnEntry '' model) - - - ('browse full (b)' browseMethodFull) - ('browse hierarchy (h)' browseHierarchy) - ('browse method (O)' openSingleMessageBrowser) - ('browse protocol (p)' browseFullProtocol) - - - ('fileOut' fileOutMessage '' model) - - - ('senders of... (n)' browseSendersOfMessages) - ('implementors of... (m)' browseMessages) - ('inheritance (i)' methodHierarchy) - ('versions (v)' browseVersions) - - - ('inst var refs...' browseInstVarRefs) - ('inst var defs...' browseInstVarDefs) - ('class var refs...' browseClassVarRefs) - ('class variables' browseClassVariables) - ('class refs (N)' browseClassRefs) - - - ('remove method (x)' removeMessage '' model) - ('Run test (t)' runMethodTest '' model) - ('Debug test (r)' debugMethodTest '' model) - - - ('more...' openShiftedMessageListMenu)). - ^ aMenu -! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'HAW 1/31/2017 11:52:17' prior: 16793404! - systemCategoryMenu - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - self flag: #renameSystemCategory. "temporarily disabled" - aMenu addList: #( - ('find class... (f)' findClass) - ('recent classes... (r)' recent '' model) - - - ('browse all' browseAllClasses) - ('browse' openSystemCategoryBrowser) - - - ('fileOut' fileOutSystemCategory '' model) - - - ('reorganize' editSystemCategories '' model) - ('alphabetize' alphabetizeSystemCategories '' model) - - - ('update' updateSystemCategories '' model) - ('add item...' addSystemCategory '' model) -" ('rename...' renameSystemCategory '' model)" - ('remove' removeSystemCategory '' model) - - - ('move to top' moveSystemCategoryTop '' model) - ('move up' moveSystemCategoryUp '' model) - ('move down' moveSystemCategoryDown '' model) - ('move to bottom' moveSystemCategoryBottom '' model) - - - ('Run tests (t)' runSystemCategoryTests '' model)). - ^aMenu! ! -!Theme methodsFor: 'menus' stamp: 'HAW 2/10/2017 17:30:49' prior: 50336835! - miscellaneousIcons - - "Everything else." - - ^ { - #('restore display (r)' 'set display depth...' 'move windows onscreen' 'Utilities saveDisplay.') -> #displayIcon. - #('changes...' 'dual change sorter' 'change sets with this method' 'find a change sorter' 'recent changes in file' 'Undo / Redo history' 'code file contents' 'package file contents') -> #changesIcon. - #('Install New Updates' 'update' 'turn on auto-update (a)' 'update list (u)' 'install code' 'fileIn entire file' 'install package') -> #updateIcon. - #('find again (g)' 'full stack (k)') -> #systemIcon. - #('print it (p)' 'check change set for slips') -> #printIcon. - #('accept (s)' 'make changes go to me (m)') -> #acceptIcon. - #('cancel (l)' 'turn off auto-update (a)') -> #cancelIcon. - #('debug...' 'Debug it (D)' 'toggle break on entry') -> #debugIcon. - #('close' 'close all debuggers' 'close top window') -> #closeIcon. - #('collapse' 'hide taskbar' 'collapse all windows') -> #collapseIcon. - #('expand / contract' 'show taskbar' 'restore all windows') -> #expandIcon. - #('menu') -> #windowMenuIcon. - #('browse all' 'browser' 'browse it (b)' 'MessageTally UI and browse' 'browse recent submissions' 'browse full (b)' 'find changed browsers...' 'browse (b)' 'browse my changes') -> #editFindReplaceIcon. - #('workspace' 'workspace with contents') -> #terminalIcon. - #('styled text editor' 'text editor' 'basic text editor' 'unicode editor' 'edit this list' 'edit postscript...' 'add postscript...') -> #textEditorIcon. - #('file list' 'find a fileList' 'compress file') -> #systemFileManagerIcon. - #('transcript' 'find a transcript' 'Transcript clear.' 'log to transcript') -> #printerIcon. - #('process browser' 'vm statistics' 'MessageTally all Processes') -> #systemMonitorIcon. - #('emergency evaluator' 'conflicts with other change sets' 'check for slips' 'conflicts with change set opposite' 'conflicts with category opposite') -> #emblemImportantIcon. - #('change sorter') -> #halfRefreshIcon. - #('SUnit Test Runner' 'Accept & Run Test in Class (t)' 'Accept & Run Test in Category (y)' 'Run tests (t)' 'Run tests' 'Run test (t)' 'Accept & Debug Test (r)' 'Debug test (r)') -> #weatherFewCloudsIcon. - #('Font Sizes...' 'system fonts...' 'set font... (k)') -> #preferencesDesktopFontIcon. - #('full screen on') -> #viewFullscreenIcon. - #('full screen off') -> #exitFullscreenIcon. - #('set desktop color...') -> #wallpaperIcon. - #('preferences...' 'All preferences...' 'what to show...' 'view as hex') -> #preferencesIcon. - #('Editor keyboard shortcuts') -> #keyboardShortcutsIcon. - #('world menu help') -> #globeIcon. "currently unused, but a neat icon" - #('useful expressions' 'class comments with it' 'check for uncommented methods' 'check for uncommented classes') -> #chatIcon. - #('set code author...' 'check for other authors' 'check for any other authors') -> #usersIcon. - #('space left') -> #removableMediaIcon. - #('start drawing all again' 'window color...') -> #graphicsIcon. - #('start stepping again') -> #mediaPlaybackStartIcon. - #('file out current change set' 'fileOut' 'File out and remove (o)' 'File out and keep (k)') -> #fileOutIcon. - #('recently logged changes...' 'versions (v)' 'recent classes... (r)' 'trim history' 'Profile it') -> #clockIcon. - #('senders of it (n)' 'senders of... (n)' 'local senders of...' 'senders (n)') -> #mailForwardIcon. - #('implementors of it (m)' 'implementors of... (m)' 'implementors of sent messages') -> #developmentIcon. - #('references to it (N)') -> #addressBookIcon. - #('class var refs...' 'class refs (N)' 'class variables' 'class vars' 'local implementors of...' 'subclass template') -> #classIcon. - #('inst var refs...' 'inst var defs...' 'sample instance') -> #instanceIcon. - #('Use Selection for Find (j)' 'rename class ...' 'rename...' 'change title...') -> #saveAsIcon. - #('smalltalk options' 'method source with it' 'browse method (O)' 'check for uncategorized methods') -> #scriptIcon. - #('method strings with it (E)' 'Toggle WordWrap') -> #genericTextIcon. - #('browse hierarchy (h)' 'move to top' 'promote to top of list') -> #goTopIcon. - #('move up' 'make next-to-topmost') -> #goUpIcon. - #('move to bottom' 'send to back' 'send top window to back') -> #goBottomIcon. - #('inheritance (i)' 'move down') -> #goDownIcon. - #('browse protocol (p)' 'spawn sub-protocol') -> #spreadsheetIcon. - #('spawn full protocol') -> #speadsheetTemplateIcon. - #('alphabetize') -> #fontXGenericIcon. - #('Installed Packages' 'browse' 'show category (C)' 'categorize all uncategorized' 'select change set...' 'view affected class categories') -> #packageIcon. - #('remove from current change set' 'remove empty categories' 'subtract other side (-)' 'remove from this browser') -> #listRemoveIcon. - #('add to current change set' 'add all meths to current chgs' 'add preamble (p)' 'More...') -> #listAddIcon. - #('toggle diffing (D)' 'toggle selections') -> #switchIcon. - #('reorganize' 'create inst var accessors' 'ChangeSorter reorderChangeSets.' 'reorder all change sets' 'by name' 'by size' 'by date') -> #sendReceiveIcon. - #('unsent methods' 'unreferenced class vars' 'unreferenced inst vars' 'Undeclared inspect.' 'Undeclared removeUnreferencedKeys; inspect.' 'ChangeSorter removeEmptyUnnamedChangeSets.' 'check for unsent messages') -> #junkIcon. - #('find changed windows...') -> #newWindowIcon. - #('make undraggable') -> #pushPinIcon. - #('Utilities saveScreenshot.') -> #stillCameraIcon. - #('add new directory') -> #newFolderIcon. - #('select all' 'deselect all') -> #selectAllIcon. - #('sort by date') -> #dateIcon. - #('justified') -> #formatJustifyFillIcon. - #('centered') -> #formatJustifyCenterIcon. - #('set alignment...' 'leftFlush') -> #formatJustifyLeftIcon. - #('rightFlush') -> #formatJustifyRightIcon. - #('signal Semaphore (S)') -> #haloHelpIcon. - #('Change Paragraph Style...' 'Change Character Style...' 'Remove Character Style' 'Replace all uses of Paragraph Style...' 'Replace all uses of Character Style...' 'Set Default Font...') -> #fontXGenericIcon. - #('Clear Font') -> #newIcon. - #('code file browser' 'package file browser') -> #findIcon. - }! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 2/10/2017 17:37:41'! - should: aBlock raise: anExceptionalType withExceptionDo: assertionsBlock - - ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalType withExceptionDo: assertionsBlock) - ! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 2/10/2017 17:38:10'! - executeShould: aBlock inScopeOf: anExceptionType withExceptionDo: assertionsBlock - - ^[aBlock value. - false] - on: anExceptionType - do: [:exception | - assertionsBlock value: exception. - exception sunitExitWith: true]! ! -!TestCase class methodsFor: 'Testing' stamp: 'HAW 2/10/2017 16:32:10' prior: 50336181! - is: aSymbol - - ^self ~= TestCase - and: [ aSymbol == #TestCaseClass or: [ super is: aSymbol ]]! ! -!TestCase class methodsFor: 'Testing' stamp: 'HAW 2/1/2017 19:35:57' prior: 16927731! - shouldInheritSelectors - "I should inherit from an Abstract superclass but not from a concrete one by default, unless I have no testSelectors in which case I must be expecting to inherit them from my superclass. If a test case with selectors wants to inherit selectors from a concrete superclass, override this to true in that subclass." - - ^self ~= TestCase - and: [ self superclass isAbstract or: [self testSelectors isEmpty]] - -"$QA Ignore:Sends system method(superclass)$" - ! ! -!TestResultForDebuggingAndInspection methodsFor: 'printing' stamp: 'HAW 2/7/2017 10:51:56' prior: 50336198! - print: aCollectionOfTestCases startingWith: header on: aStream - - aCollectionOfTestCases do: [ :aTestCase | - aStream - nextPutAll: header; - space; - nextPutAll: aTestCase class name; - nextPutAll: ' debug: #'; - nextPutAll: aTestCase selector; - newLine ] - - - ! ! - -TestSuite class removeSelector: #allTestCasesReferencing:! - -TestSuite class removeSelector: #allTestReferencesTo:! - -TestSuite class removeSelector: #allTestsReferencing:! - -TestSuite class removeSelector: #from:using:! - -TestSuite class removeSelector: #fromClass:! - -TestSuite class removeSelector: #fromSystemCategoryNamed:using:! - -ProgessiveTestRunner removeSelector: #initializeFor:informingResultUsing:! - -ProgessiveTestRunner removeSelector: #initializeFor:showingTestPassedWith:! - -ProgessiveTestRunner removeSelector: #showProgressBarAndRunSuite! - -SmalltalkEditor removeSelector: #acceptAndWithTestMethodDo:! - -SmalltalkEditor removeSelector: #flashWith:! - -SmalltalkEditor removeSelector: #flashWith:! - -SmalltalkEditor removeSelector: #flashWithGreen! - -SmalltalkEditor removeSelector: #flashWithGreen! - -Categorizer removeSelector: #testCasesAt:! - -Class removeSelector: #withTestCaseClassDo:ifNone:! - -Behavior removeSelector: #withTestClassDo:ifNone:! - -----End fileIn of C:\Users\Juan-Tuerca\PayloadSoftware\Cuis-Smalltalk-Dev\CoreUpdates\3046-TestRunningHelpers-HernanWilkinson-2017Jan31-09h21m-HAW.5.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3046] on 1 March 2017 at 12:34:07 pm'! -!CodeFile methodsFor: 'change record types' stamp: 'jmv 3/1/2017 12:31:23' prior: 16808869! - doIt: chgRec - "See senders of #doIt " - | string | - string := chgRec string. - - "Method classification spec" - (string beginsWith: '(''') ifTrue: [ - ^ doIts add: chgRec ]. - - "Just for compatibility with Squeak, as Cuis always adds the #classDefinition change type marker in the files." - ('*ubclass:*instanceVariableNames:*classVariableNames:*poolDictionaries:*category:*' - match: string) ifTrue:[^self classDefinition: string with: chgRec]. - - "Just for compatibility with Squeak, as Cuis always adds the #classDefinition change type marker in the files." - ('* class*instanceVariableNames:*' - match: string) ifTrue:[^self metaClassDefinition: string with: chgRec]. - - "Just for compatibility with Squeak, as Cuis always adds the #methodRemoval: (or similar) change type marker in the files." - ('* removeSelector: *' - match: string) ifTrue:[^self removedMethod: string with: chgRec]. - - "Just for compatibility with Squeak, as Cuis always adds the #classComment change type marker in the files." - ('* comment:*' - match: string) ifTrue:[^self msgClassComment: string with: chgRec]. - - "Don't add these to a CodeFile. They will be added on save if needed." - ('* initialize' - match: string) ifTrue:[^self]. "Initialization is done based on class>>initialize" - - ('''From *' - match: string) ifTrue:[^self possibleSystemSource: chgRec]. - doIts add: chgRec.! ! - -----End fileIn of C:\Users\Juan-Tuerca\PayloadSoftware\Cuis-Smalltalk-Dev\CoreUpdates\3047-FileCodeBrowserFix-JuanVuletich-2017Mar01-12h33m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3047] on 2 March 2017 at 10:50:58 am'! - -BorderedRectMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp popUpOwner activeSubMenu titleMorph oldKeyboardFocus ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #MenuMorph category: #'Morphic-Menus'! -BorderedRectMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp popUpOwner activeSubMenu titleMorph oldKeyboardFocus' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! -!MenuMorph commentStamp: '' prior: 16866262! - Instance variables: - defaultTarget The default target for creating menu items - selectedItem The currently selected item in the receiver - stayUp True if the receiver should stay up after clicks! -!MenuMorph methodsFor: 'control' stamp: 'jmv 3/2/2017 10:47:30' prior: 16866663! - deleteIfPopUp: evt - "Remove this menu from the screen if stayUp is not true." - - stayUp ifFalse: [ self delete ]. - evt ifNotNil: [ evt hand ifNotNil: [ :h | h releaseMouseFocus: self ]]! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 3/2/2017 10:48:01' prior: 16866680! - popUpAdjacentTo: rightOrLeftPointInWorld from: sourceItem - "Present this menu at the given point under control of the given hand. - Used mostly for submenus." - - | delta tryToPlace selectedOffset | - selectedOffset _ (selectedItem ifNil: [ self items first ]) morphPosition. - sourceItem world addMorphFront: self. - - tryToPlace _ [ :where :mustFit | - self morphPosition: where - selectedOffset. - delta _ self morphFullBoundsInWorld - amountToTranslateWithin: sourceItem world morphBoundsInWorld. - (delta x = 0 | mustFit) ifTrue: [ - delta = (0@0) ifFalse: [ self morphPosition: self morphPosition + delta ]. - ^ self]]. - tryToPlace - value: rightOrLeftPointInWorld first value: false; - value: rightOrLeftPointInWorld last - (extent x @ 0) value: false; - value: rightOrLeftPointInWorld first value: true! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 3/2/2017 10:48:31' prior: 16866709! - popUpAt: aPoint forHand: hand allowKeyboard: aBoolean - "Present this menu at the given point under control of the given hand." - - | evt | - self items isEmpty ifTrue: [^self]. - Theme current decorateMenu: self. - (self submorphs select: [ :m | m is: #UpdatingMenuItemMorph ]) - do: [ :m | m updateContents]. - self runningWorld addMorphFront: self position: aPoint - (2 @ 8). - self fitInWorld. - "Acquire focus for valid pop up behavior" - hand newMouseFocus: self. - aBoolean ifTrue: [ hand newKeyboardFocus: self ]. - evt _ hand lastMouseEvent. - (evt isKeyboard or: [ evt isMouse and: [ evt anyButtonPressed not ]]) - ifTrue: [ - "Select first item if button not down" - self moveSelectionDown: 1 event: evt ]! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 3/2/2017 10:48:26' prior: 16866745! - popUpAt: aPoint forHand: hand in: aWorld allowKeyboard: aBoolean - "Present this menu at the given point under control of the given hand." - - self items isEmpty ifTrue: [ ^self ]. - Theme current decorateMenu: self. - (self submorphs select: [ :m | m is: #UpdatingMenuItemMorph]) - do: [ :m | m updateContents]. - aWorld addMorphFront: self position: aPoint - (2 @ 8). - self fitInWorld. - "Acquire focus for valid pop up behavior" - hand newMouseFocus: self. - aBoolean ifTrue: [ hand newKeyboardFocus: self ]! ! -!MenuMorph methodsFor: 'events' stamp: 'jmv 3/2/2017 10:47:45' prior: 16866819! - keyStroke: aKeyboardEvent - | matchString char asc selectable | - char := aKeyboardEvent keyCharacter. - asc := char numericValue. - aKeyboardEvent isReturnKey - ifTrue: [ - selectedItem ifNotNil: [ - selectedItem hasSubMenu - ifTrue: [ - aKeyboardEvent hand newMouseFocus: selectedItem subMenu. - ^aKeyboardEvent hand newKeyboardFocus: selectedItem subMenu] - ifFalse: [ - "self delete." - ^selectedItem invokeWithEvent: aKeyboardEvent]]. - (selectable := self items) size = 1 - ifTrue: [^selectable first invokeWithEvent: aKeyboardEvent]. - ^self]. - asc = 27 - ifTrue: [ - "escape key" - self - valueOfProperty: #matchString - ifPresentDo: [ :str | - str isEmpty - ifFalse: [ - "If filtered, first ESC removes filter" - self setProperty: #matchString toValue: String new. - self selectItem: nil. - ^self displayFiltered: aKeyboardEvent]]. - "If a stand-alone menu, just delete it" - ^self delete]. - (asc = 28 or: [asc = 29]) - ifTrue: [ - "left or right arrow key" - (selectedItem notNil and: [selectedItem hasSubMenu]) - ifTrue: [ - aKeyboardEvent hand newMouseFocus: selectedItem subMenu. - selectedItem subMenu moveSelectionDown: 1 event: aKeyboardEvent. - ^aKeyboardEvent hand newKeyboardFocus: selectedItem subMenu]]. - asc = 30 ifTrue: [^self moveSelectionDown: -1 event: aKeyboardEvent]. "up arrow key" - asc = 31 ifTrue: [^self moveSelectionDown: 1 event: aKeyboardEvent]. "down arrow key" - asc = 11 ifTrue: [^self moveSelectionDown: -5 event: aKeyboardEvent]. "page up key" - asc = 12 ifTrue: [^self moveSelectionDown: 5 event: aKeyboardEvent]. "page down key" - matchString := self valueOfProperty: #matchString ifAbsent: [String new]. - matchString := char = Character backspace - ifTrue: [ - matchString isEmpty ifTrue: [matchString] ifFalse: [matchString allButLast]] - ifFalse: [matchString copyWith: aKeyboardEvent keyCharacter]. - self setProperty: #matchString toValue: matchString. - self displayFiltered: aKeyboardEvent! ! -!MenuMorph methodsFor: 'events-processing' stamp: 'jmv 3/2/2017 10:47:57' prior: 16866952! - handleFocusEvent: aMorphicEvent - "Handle focus events. Valid menu transitions are determined based on the menu currently holding the focus after the mouse went down on one of its children." - | eventPositionInOurCoordinates | - eventPositionInOurCoordinates _ self internalizeFromWorld: aMorphicEvent eventPosition. - - self dispatchEvent: aMorphicEvent localPosition: eventPositionInOurCoordinates. - - "Need to handle keyboard input if we have the focus." - aMorphicEvent isKeyboard ifTrue: [ ^ aMorphicEvent sentTo: self localPosition: eventPositionInOurCoordinates]. - - "We need to handle button clicks outside and transitions to local popUps so throw away everything else" - (aMorphicEvent isMouseOver or: [aMorphicEvent isMouse not]) ifTrue: [ ^self ]. - "What remains are mouse buttons and moves" - aMorphicEvent isMove ifFalse: [ ^ aMorphicEvent sentTo: self localPosition: eventPositionInOurCoordinates ]. "handle clicks outside by regular means" - "Now it's getting tricky. On #mouseMove we might transfer control to *either* the currently active submenu or the pop up owner, if any. Since the active sub menu is always displayed upfront check it first." - selectedItem ifNotNil:[(selectedItem activateSubmenu: aMorphicEvent) ifTrue: [^self]]! ! -!MenuMorph methodsFor: 'initialization' stamp: 'jmv 3/2/2017 10:47:34' prior: 16867015! - initialize - super initialize. - extent _ 40@10. - defaultTarget _ nil. - selectedItem _ nil. - stayUp _ false! ! -!MenuItemMorph methodsFor: 'events' stamp: 'jmv 3/2/2017 10:45:33' prior: 16866023! - mouseEnter: evt - "The mouse entered the receiver" - owner ifNil: [ ^self ]. - owner selectItem: self! ! -!MenuItemMorph methodsFor: 'selecting' stamp: 'jmv 3/2/2017 10:36:12' prior: 16866139! - deselect - - self isSelected: false. - subMenu ifNotNil: [ - self removeAlarm: #deselectTimeOut ]! ! -!MenuItemMorph methodsFor: 'selecting' stamp: 'jmv 3/2/2017 10:36:17' prior: 16866151! - select - self isSelected: true. - subMenu ifNotNil: [ - subMenu delete. - subMenu - popUpAdjacentTo: (Array with: self morphBoundsInWorld topRight + (10@0) - with: self morphBoundsInWorld topLeft) - from: self. - subMenu selectItem: nil ]! ! - -MenuItemMorph removeSelector: #activateOwnerMenu:! - -MenuItemMorph removeSelector: #activateOwnerMenu:! - -MenuMorph removeSelector: #activeSubmenu:! - -MenuMorph removeSelector: #activeSubmenu:! - -MenuMorph removeSelector: #delete! - -MenuMorph removeSelector: #delete! - -MenuMorph removeSelector: #popUpOwner! - -MenuMorph removeSelector: #popUpOwner! - -BorderedRectMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp titleMorph' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #MenuMorph category: #'Morphic-Menus'! -BorderedRectMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp titleMorph' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -----End fileIn of C:\Users\Juan-Tuerca\PayloadSoftware\Cuis-Smalltalk-Dev\CoreUpdates\3048-MenuSimplification-JuanVuletich-2017Mar02-10h45m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3048] on 2 March 2017 at 4:11:32 pm'! -!Transcripter class methodsFor: 'instance creation' stamp: 'dhn 2/6/2017 13:38:40' prior: 16938922! - newInFrame: frame -" -(Transcripter newInFrame: (0@0 extent: 100@200)) - nextPutAll: 'Hello there'; endEntry; - newLine; print: 355.0/113; endEntry; - readEvalPrint. -" - | transcript | - transcript _ self on: (String new: 100). - transcript initInFrame: frame. - ^ transcript clear! ! - -----End fileIn of C:\Users\Juan-Tuerca\PayloadSoftware\Cuis-Smalltalk-Dev\CoreUpdates\3049-TranscripterCommentFix-DanNorton-2017Mar02-16h10m-dhn.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3049] on 3 March 2017 at 9:17:59 am'! -!WorldState methodsFor: 'stepping' stamp: 'jmv 3/2/2017 19:35:58'! - cleanseStepList - "Remove morphs from the step list that are not in this World. Often were in a flap that has moved on to another world." - - | deletions morphToStep | - deletions _ nil. - stepList do: [:entry | - morphToStep _ entry receiver. - morphToStep world == world ifFalse:[ - deletions ifNil: [deletions _ OrderedCollection new]. - deletions addLast: entry]]. - - deletions ifNotNil:[ - deletions do: [:entry| - self stopSteppingMorph: entry receiver]]. - - self alarms copy do:[:entry| - morphToStep _ entry receiver. - ((morphToStep is: #Morph) and: [ morphToStep world == world ]) - ifFalse: [ self removeAlarm: entry selector for: entry receiver ]].! ! -!WorldState methodsFor: 'stepping' stamp: 'jmv 3/2/2017 19:42:28'! - runStepMethods - "Perform periodic activity inbetween event cycles" - | queue msg | - - queue _ self class deferredUIMessages. - [ (msg _ queue nextOrNil) isNil ] whileFalse: [ - msg value - ]. - self runLocalStepMethods. - - "we are using a normal #step for these now" - "aWorld allLowerWorldsDo: [ :each | each runLocalStepMethods ]." -! ! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 3/2/2017 19:34:41'! - displayWorldSafely - "Update this world's display and keep track of errors during draw methods." - - [world displayWorld] ifError: [:err :rcvr | - "Handle a drawing error" - | errCtx errMorph | - errCtx _ thisContext. - [ - errCtx _ errCtx sender. - "Search the sender chain to find the morph causing the problem" - [errCtx notNil and: [ (errCtx receiver is: #Morph) not ]] - whileTrue:[errCtx _ errCtx sender]. - "If we're at the root of the context chain then we have a fatal drawing problem" - errCtx ifNil:[^self handleFatalDrawingError: err]. - errMorph _ errCtx receiver. - "If the morph causing the problem has already the #drawError flag set, - then search for the next morph above in the caller chain." - errMorph isKnownFailing - ] whileTrue. - errMorph drawingFails. - self clearCanvas. - "Install the old error handler, so we can re-raise the error" - rcvr error: err. - ]! ! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 3/2/2017 19:34:09'! - doOneCycle - "Do one cycle of the interaction loop. This method is called repeatedly when the world is running. - - Make for low cpu usage if the ui is inactive, but quick response when ui is in use. - However, after some inactivity, there will be a larger delay before the ui gets responsive again." - - | wait waitUntil | - waitDelay ifNil: [ waitDelay _ Delay forMilliseconds: 50 ]. - lastCycleHadAnyEvent - ifTrue: [ - pause _ 20. "This value will only be used when there are no more events to serve." - wait _ 0 ] "Don't wait" - ifFalse: [ - pause < 200 "No events processed? Start saving CPU!! But never make the user wait more than 200ms for being responsive again." - ifTrue: [ pause _ pause * 21//20 ]. - waitUntil _ lastCycleTime + pause. - "Earlier if steps" - stepList isEmpty not ifTrue: [ - waitUntil _ waitUntil min: stepList first scheduledTime ]. - "Earlier if alarms" - alarms ifNotNil: [ - alarms isEmpty not ifTrue: [ - waitUntil _ waitUntil min: alarms first scheduledTime ]]. - - wait _ waitUntil - Time localMillisecondClock ]. - Preferences serverMode - ifTrue: [ wait _ wait max: 50 ]. "Always wait at least a bit on servers, even if this makes the UI slow." - wait > 0 ifTrue: [ - waitDelay beingWaitedOn - ifFalse: [ waitDelay setDelay: wait; wait ] - ifTrue: [ - "If we are called from a different process than that of the main UI, we might be called in the main - interCyclePause. In such case, use a new Delay to avoid 'This Delay has already been scheduled' errors" - (Delay forMilliseconds: wait) wait ]]. - - "Record start time of this cycle, and do cycle" - lastCycleTime _ Time localMillisecondClock. - lastCycleHadAnyEvent _ self doOneCycleNow! ! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 3/2/2017 19:34:47'! - doOneCycleNow - "Immediately do one cycle of the interaction loop. - This should not be called directly, but only via doOneCycleFor:" - - | hadAnyEvent | - "See #eventTickler" - Cursor currentCursor = Cursor wait ifTrue: [ - Cursor normal activateCursor ]. - - "Repair visual damage." - DisplayScreen checkForNewScreenSize. - self displayWorldSafely. - - "Run steps, alarms and deferred UI messages" - world runStepMethods. - - "Process user input events. Run all event triggered code." - hadAnyEvent _ false. - self handsDo: [ :h | - activeHand _ h. - hadAnyEvent _ hadAnyEvent | h processEventQueue. - activeHand _ nil ]. - - "The default is the primary hand" - activeHand _ self hands first. - - - ^hadAnyEvent! ! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 3/2/2017 19:43:12'! - tryDeferredUpdatingAndSetCanvas - "If this platform supports deferred updates, then make my canvas be the Display (or a rectangular portion of it), set the Display to deferred update mode, and answer true. Otherwise, set a non-Disply canvas and answer false.." - | properDisplay | - - "As this is the only sender of #deferUpdates: , this could be done in Morphic or image startup, and never efterwards..." - (Display deferUpdates: true) ifNil: [ - "deferred updates not supported by the VM, do them in the image!!" - self ensureNonDisplayCanvas. - ^ false]. - - "if no canvas, or canvas was offscreen, from a platform that didnt support defers, then fix it" - properDisplay _ canvas notNil and: [canvas drawsOnDisplay]. - properDisplay ifFalse: [ - world morphPosition: 0@0 extent: Display extent. - self setCanvas: Display getCanvas. - ]. - ^ true! ! -!WorldState methodsFor: 'drawing' stamp: 'jmv 3/2/2017 19:43:18'! - displayWorldAndSubmorphs: submorphs - "Update this world's display." - - | deferredUpdateVMMode worldDamageRects handsToDraw allDamage | - self checkIfUpdateNeeded ifFalse: [ ^ self ]. "display is already up-to-date" - "I (jmv) removed the call to 'deferUpdates: false' below. No more need to call this every time." - deferredUpdateVMMode _ self tryDeferredUpdatingAndSetCanvas. - - "repair world's damage on canvas" - worldDamageRects _ self drawInvalidAreasSubmorphs: submorphs. - - "Check which hands need to be drawn (they are not the hardware mouse pointer)" - handsToDraw _ self selectHandsToDrawForDamage: worldDamageRects. - allDamage _ Array streamContents: [ :strm | - strm nextPutAll: worldDamageRects. - handsToDraw do: [ :h | - h savePatchFrom: canvas appendDamageTo: strm ]]. - - "Draw hands (usually carying morphs) onto world canvas" - canvas newClipRect: nil. - handsToDraw reverseDo: [ :h | canvas fullDrawHand: h ]. - - "quickly copy altered rects of canvas to Display:" - deferredUpdateVMMode ifFalse: [ - "Drawing was done to off-Display canvas. Copy content to Display" - canvas showAt: world viewBox origin invalidRects: allDamage ]. - - "Display deferUpdates: false." - "Display forceDisplayUpdate" - Display forceDamageToScreen: allDamage. - - "Restore world canvas under hands and their carried morphs" - handsToDraw do: [ :h | h restoreSavedPatchOn: canvas ].! ! -!WorldState methodsFor: 'drawing' stamp: 'jmv 3/2/2017 19:40:12'! - drawInvalidAreasSubmorphs: submorphs - "Redraw the damaged areas of the given canvas and clear the damage list. Return a collection of the areas that were redrawn." - - | initialRectsToRepair currentRectsToRepair newRectsToRepair morphsToDraw rectsForEachMorph thisMorphRects reuse i n morph morphBounds morphClipRect | - - "The simple implementation is slowers as it draws morph areas that will later be covered by other morphs. - But it works, and it is easier to understand. - See en.wikipedia.org/wiki/Painter's_algorithm" - true not ifTrue: [ ^self simpleDrawInvalidAreasSubmorphs: submorphs ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - initialRectsToRepair _ damageRecorder invalidRectsFullBounds: world viewBox. - damageRecorder reset. - currentRectsToRepair _ OrderedCollection new. - newRectsToRepair _ OrderedCollection withAll: initialRectsToRepair. - morphsToDraw _ OrderedCollection new. - rectsForEachMorph _ OrderedCollection new. - thisMorphRects _ OrderedCollection new. - n _ submorphs size. - i _ 1. - - "The idea here is to iterate morphs front to back, i.e. first the ones on top. - For each morph, record the rectangles it affects. And if a morph is opaque, remove the area behind it from the list of rectangles to be repaired. - This means, for example, that morphs completely covered might even not be redrawn. - this is a huge performance gain when there are many morphs on screen, especially if there are more than ten open windows, and Theme uses opaque colors. - See 'A reverse painter's algorithm' at en.wikipedia.org/wiki/Painter's_algorithm" - [ i <= n and: [ newRectsToRepair notEmpty ]] whileTrue: [ - morph _ submorphs at: i. - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - reuse _ currentRectsToRepair. - currentRectsToRepair _ newRectsToRepair. - newRectsToRepair _ reuse removeAll. - currentRectsToRepair do: [ :r | - (morphBounds intersects: r) - ifTrue: [ - morphClipRect _ morphBounds intersect: r. - thisMorphRects add: morphClipRect. "We could perhaps try and join adjacent rectangles in this collection..." - morph addPossiblyUncoveredAreasIn: r to: newRectsToRepair ] - ifFalse: [ - newRectsToRepair add: r ]]. - thisMorphRects ifNotEmpty: [ - morphsToDraw add: morph. - rectsForEachMorph add: thisMorphRects. - thisMorphRects _ OrderedCollection new. - ]]. - i _ i + 1 ]. - - "*make this true to flash damaged areas for testing*" - Preferences debugShowDamage ifTrue: [ world fillRects: initialRectsToRepair color: Color gray ]. - - "Draw world background on those areas that were not completely covered by opaque morphs" - i > n ifTrue: [ - newRectsToRepair do: [ :r | - world drawOn: (canvas newClipRect: r) ]]. - - "Now, draw the recorded areas of selected morphs, back to front." - morphsToDraw with: rectsForEachMorph reverseDo: [ :m :xrects | - "Here we could think about merging all xrects into just one call... - This would mean drawing each morph just once. - But that would mean drawing pixels we were not told to. There could be other morphs in that area that are not even being drawn!! - See WorldState class >> #experiment1" -" rr _ nil." - xrects do: [ :r | -" rr _ rr ifNil: [ r ] ifNotNil: [ r quickMerge: rr ]." - (canvas newClipRect: r) fullDraw: m. - ]. -" (canvas newClipRect: rr) fullDraw: m" - "*make this true to flash damaged areas for testing*" - Preferences debugShowDamage2 ifTrue: [ - world flashRects: xrects color: Color random ]. - ]. - - "Answer a list of rectangles to be updated on the Display. - This usually is not performance critical, drawing morphs is slower than just exposing the Display." - "What should we force on Display? Whatever was asked? Each small rect that was updated? A single bigger rect? - Right now, answer whatever was asked... Maybe this could be changed if that enhances performance... - (think of vnc over slow networks)" - ^ initialRectsToRepair! ! -!WorldState methodsFor: 'drawing' stamp: 'jmv 3/2/2017 19:39:56'! - simpleDrawInvalidAreasSubmorphs: submorphs - - "mover todo esto al canvas, no? - Y ver que hacer con los argumentos, etc.... Toda esta bananarama!!" - - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - This simple implementation just does as requested: No optimizations are done." - - | rectsToRepair morphBounds | - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ damageRecorder invalidRectsFullBounds: world viewBox. - damageRecorder reset. - - "Draw World" - rectsToRepair do: [ :r | - world drawOn: (canvas newClipRect: r) ]. - - "Draw morphs" - submorphs reverseDo: [ :morph | - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - rectsToRepair do: [ :r | - (morphBounds intersects: r) ifTrue: [ - (canvas newClipRect: r) fullDraw: morph ]]]]. - - ^ rectsToRepair! ! -!WorldState methodsFor: 'accessing' stamp: 'jmv 3/2/2017 21:47:15'! - runLocalStepMethods - "Run morph 'step' methods (LOCAL TO THIS WORLD) whose time has come. Purge any morphs that are no longer in this world." - - | now morphToStep scheduledTime | - now _ lastCycleTime. - self triggerAlarmsBefore: now. - stepList isEmpty - ifTrue: [ ^self]. - [ stepList isEmpty not and: [ stepList first scheduledTime <= now ]] - whileTrue: [ - lastStepMessage _ stepList removeFirst. - morphToStep _ lastStepMessage receiver. - (morphToStep shouldGetStepsFrom: world) - ifTrue: [ - scheduledTime _ lastStepMessage scheduledTime. - lastStepMessage valueAtTime: now - scheduledTime + lastStepMessage stepTime. - lastStepMessage ifNotNil: [ - lastStepMessage scheduledTime: (scheduledTime + lastStepMessage stepTime max: now + 1). - stepList add: lastStepMessage ]]. - lastStepMessage _ nil ]! ! -!PasteUpMorph methodsFor: 'interaction loop' stamp: 'jmv 3/2/2017 19:34:01' prior: 16887286! - doOneCycleNow - "see the comment in doOneCycleNowFor: - Only used for a few tests." - worldState doOneCycleNow! ! -!PasteUpMorph methodsFor: 'stepping' stamp: 'jmv 3/2/2017 19:36:23' prior: 16887443! - cleanseStepList - "Remove morphs from the step list that are not in this World. Often were in a flap that has moved on to another world." - - worldState cleanseStepList! ! -!PasteUpMorph methodsFor: 'stepping' stamp: 'jmv 3/2/2017 19:42:32' prior: 16887451! - runStepMethods - - worldState runStepMethods! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 3/2/2017 19:34:54' prior: 16887760! - displayWorldSafely - - worldState displayWorldSafely -! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 3/2/2017 19:33:20' prior: 16887765! - doOneCycle - "see the comment in WorldState >> doOneCycle" - - worldState doOneCycle! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 3/2/2017 19:37:11' prior: 16887829! - privateOuterDisplayWorld - - worldState displayWorldAndSubmorphs: submorphs -! ! -!WorldState class methodsFor: 'sample code' stamp: 'jmv 3/2/2017 19:39:21' prior: 16946320! - experiment1 - "To play with and learn about morphic Display update logic. - Remove the morphs when done!!" - " - WorldState experiment1 - " - | dr morph1 morph2 s w | - morph1 _ RectangleLikeMorph new openInWorld. - morph2 _ RectangleLikeMorph new openInWorld. - morph2 color: Color green. - morph2 morphPosition: 200@800 extent: 50@40. - morph1 morphPosition: 120@720 extent: 220@100. - - w _ self runningWorld. - s _ w instVarNamed: 'worldState'. - dr _ s instVarNamed: 'damageRecorder'. - - dr doFullRepaint. - dr reset; - " recordInvalidRect: (100@700 corner: 400@900);" - recordInvalidRect: (100@700 corner: 150@900); - recordInvalidRect: (300@700 corner: 400@900). - Display fillColor: Color gray. - "Do not draw the area used by the small rectangle, unless it is also drawn!!" - s drawInvalidAreasSubmorphs: {morph1. morph2 }! ! - -WorldState removeSelector: #cleanseStepListForWorld:! - -WorldState removeSelector: #cleanseStepListForWorld:! - -WorldState removeSelector: #displayWorld:submorphs:! - -WorldState removeSelector: #displayWorld:submorphs:! - -WorldState removeSelector: #displayWorldSafely:! - -WorldState removeSelector: #displayWorldSafely:! - -WorldState removeSelector: #doOneCycleFor:! - -WorldState removeSelector: #doOneCycleFor:! - -WorldState removeSelector: #doOneCycleNowFor:! - -WorldState removeSelector: #doOneCycleNowFor:! - -WorldState removeSelector: #drawInvalidAreasWorld:submorphs:! - -WorldState removeSelector: #drawInvalidAreasWorld:submorphs:! - -WorldState removeSelector: #runLocalStepMethodsIn:! - -WorldState removeSelector: #runLocalStepMethodsIn:! - -WorldState removeSelector: #runStepMethodsIn:! - -WorldState removeSelector: #runStepMethodsIn:! - -WorldState removeSelector: #simpleDrawInvalidAreasWorld:submorphs:! - -WorldState removeSelector: #simpleDrawInvalidAreasWorld:submorphs:! - -WorldState removeSelector: #tryDeferredUpdatingAndSetCanvasFor:! - -WorldState removeSelector: #tryDeferredUpdatingAndSetCanvasFor:! - -----End fileIn of C:\Users\Juan-Tuerca\PayloadSoftware\Cuis-Smalltalk-Dev\CoreUpdates\3050-WorldState-refactor-JuanVuletich-2017Mar03-09h17m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3049] on 3 March 2017 at 9:22:19 am'! -!PasteUpMorph methodsFor: 'interaction loop' stamp: 'jmv 3/2/2017 19:58:01' prior: 50339844! - doOneCycleNow - "see the comment in WorldState >> doOneCycleNow - Only used for a few tests." - worldState doOneCycleNow! ! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 3/3/2017 09:21:41' prior: 50339561! - doOneCycleNow - "Immediately do one cycle of the interaction loop." - - | hadAnyEvent | - "See #eventTickler" - Cursor currentCursor = Cursor wait ifTrue: [ - Cursor normal activateCursor ]. - - "Repair visual damage." - DisplayScreen checkForNewScreenSize. - self displayWorldSafely. - - "Run steps, alarms and deferred UI messages" - self runStepMethods. - - "Process user input events. Run all event triggered code." - hadAnyEvent _ false. - self handsDo: [ :h | - activeHand _ h. - hadAnyEvent _ hadAnyEvent | h processEventQueue. - activeHand _ nil ]. - - "The default is the primary hand" - activeHand _ self hands first. - - - ^hadAnyEvent! ! - -PasteUpMorph removeSelector: #runStepMethods! - -PasteUpMorph removeSelector: #runStepMethods! - -----End fileIn of C:\Users\Juan-Tuerca\PayloadSoftware\Cuis-Smalltalk-Dev\CoreUpdates\3051-WorldState-refactor-JuanVuletich-2017Mar03-09h17m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3049] on 3 March 2017 at 9:27:56 am'! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 3/2/2017 20:08:11'! - doOneMinimalCycleNow - "see the comment in WorldState >> doOneMinimalCycleNow" - - worldState doOneMinimalCycleNow! ! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 3/2/2017 20:06:48'! - doOneMinimalCycleNow - "Immediately do one cycle of the interaction loop. - Only repair display and process events. For modal menus and such." - - "Repair visual damage." - self displayWorldSafely. - - "Process user input events. Run all event triggered code." - ^activeHand processEventQueue! ! -!MenuMorph methodsFor: 'modal control' stamp: 'jmv 3/2/2017 20:08:34' prior: 16867177! - invokeModal: allowKeyboardControl - "Invoke this menu and don't return until the user has chosen a value. If the allowKeyboarControl boolean is true, permit keyboard control of the menu - See senders of this method for finding out how to use modal menu morphs." - | w oldFocus actHand | - w _ self runningWorld. - actHand _ w activeHand. - oldFocus _ actHand keyboardFocus. - w doOneMinimalCycleNow. - self - popUpAt: actHand morphPosition - forHand: actHand - allowKeyboard: allowKeyboardControl. - self isModalInvokationDone: false. - [ self isInWorld & self isModalInvokationDone not ] whileTrue: [ w doOneMinimalCycleNow ]. - self delete. - oldFocus ifNotNil: [ actHand newKeyboardFocus: oldFocus ]. - ^ self modalSelection! ! -!MVCMenuMorph methodsFor: 'invoking' stamp: 'jmv 3/2/2017 20:08:29' prior: 16865463! - invokeAt: aPoint allowKeyboard: aBoolean - "Add this menu to the given world centered at the given point. Wait for the user to make a selection and answer it. The selection value returned is an integer in keeping with PopUpMenu, if the menu is converted from an MVC-style menu." - "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop." - |actHand w oldFocus | - self flag: #bob. "is global or local?" - self flag: #arNote. " is local to aWorld" - w _ self runningWorld. - actHand _ w activeHand. - oldFocus _ actHand keyboardFocus. - w doOneMinimalCycleNow. - self - popUpAt: aPoint - forHand: actHand - allowKeyboard: aBoolean. - done _ false. - [ self isInWorld & done not ] whileTrue: [ w doOneMinimalCycleNow ]. - self delete. - oldFocus ifNotNil: [ actHand newKeyboardFocus: oldFocus ]. - ^ mvcSelection ! ! -!FillInTheBlankMorph methodsFor: 'invoking' stamp: 'jmv 3/2/2017 20:08:24' prior: 16844196! - getUserResponse - "Wait for the user to accept or cancel, and answer the result string. Answers the empty string if the user cancels." - "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop." - - | w | - w _ self world. - w ifNil: [^ response]. - done _ false. - textPane focusText. - [done] whileFalse: [w doOneMinimalCycleNow]. - self delete. - w doOneMinimalCycleNow. - ^ response -! ! -!FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'jmv 3/3/2017 09:26:42' prior: 16844289! - request: queryString initialAnswer: defaultAnswer centerAt: aPoint onCancelReturn: returnOnCancel acceptOnCR: acceptBoolean - "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. If the user cancels, answer returnOnCancel." - " - FillInTheBlankMorph - request: 'Type something, then type [Return].' - initialAnswer: 'yo ho ho!!' - " - - | aFillInTheBlankMorph | - aFillInTheBlankMorph _ self new - setQuery: queryString - initialAnswer: defaultAnswer - acceptOnCR: acceptBoolean. - aFillInTheBlankMorph responseUponCancel: returnOnCancel. - self runningWorld addMorph: aFillInTheBlankMorph centeredNear: aPoint. - ^ aFillInTheBlankMorph getUserResponse! ! - -----End fileIn of C:\Users\Juan-Tuerca\PayloadSoftware\Cuis-Smalltalk-Dev\CoreUpdates\3052-MenusDoReducedWorldCycle-JuanVuletich-2017Mar03-09h22m-jmv.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3049] on 3 March 2017 at 9:49:08 am'! -!WorldState methodsFor: 'accessing' stamp: 'jmv 3/3/2017 09:47:13'! - runLocalStepMethods: nowTime - "Run morph 'step' methods (LOCAL TO THIS WORLD) whose time has come. Purge any morphs that are no longer in this world." - - | morphToStep scheduledTime | - [ stepList notEmpty and: [ stepList first scheduledTime <= nowTime ]] - whileTrue: [ - lastStepMessage _ stepList removeFirst. - morphToStep _ lastStepMessage receiver. - (morphToStep shouldGetStepsFrom: world) - ifTrue: [ - scheduledTime _ lastStepMessage scheduledTime. - lastStepMessage valueAtTime: nowTime - scheduledTime + lastStepMessage stepTime. - lastStepMessage ifNotNil: [ - lastStepMessage scheduledTime: (scheduledTime + lastStepMessage stepTime max: nowTime + 1). - stepList add: lastStepMessage ]]. - lastStepMessage _ nil ]! ! -!WorldState methodsFor: 'alarms' stamp: 'jmv 3/3/2017 09:33:59' prior: 16945643! - addAlarm: aSelector withArguments: argArray for: aTarget at: scheduledTime - "Add a new alarm with the given set of parameters" - - alarms add: - (MorphicAlarm - receiver: aTarget - selector: aSelector - arguments: argArray - at: scheduledTime)! ! -!WorldState methodsFor: 'alarms' stamp: 'jmv 3/3/2017 09:34:03' prior: 16945653! - adjustAlarmTimes: nowTime - "Adjust the alarm times after some clock weirdness (such as image-startup etc)" - | deltaTime | - deltaTime _ nowTime - lastAlarmTime. - alarms do: [ :alarm | - alarm scheduledTime: alarm scheduledTime + deltaTime ]! ! -!WorldState methodsFor: 'alarms' stamp: 'jmv 3/3/2017 09:34:21' prior: 16945673! - removeAlarm: aSelector for: aTarget - "Remove the alarm with the given selector" - - | alarm | - alarm := alarms - detect: [ :any | any receiver == aTarget and: [any selector == aSelector]] - ifNone: nil. - alarm ifNotNil: [ alarms remove: alarm ]! ! -!WorldState methodsFor: 'alarms' stamp: 'jmv 3/3/2017 09:35:03' prior: 16945684! - triggerAlarmsBefore: nowTime - "Trigger all pending alarms that are to be executed before nowTime." - - nowTime - lastAlarmTime > 10000 - ifTrue: [ self adjustAlarmTimes: nowTime ]. - [ alarms notEmpty and: [ alarms first scheduledTime < nowTime ]] - whileTrue: [ alarms removeFirst valueAtTime: nowTime ]. - lastAlarmTime _ nowTime! ! -!WorldState methodsFor: 'initialization' stamp: 'jmv 3/3/2017 09:33:53' prior: 16945782! - initialize - - activeHand _ HandMorph new. - hands _ { activeHand }. - damageRecorder _ DamageRecorder new. - stepList _ Heap sortBlock: self stepListSortBlock. - alarms _ Heap sortBlock: self alarmSortBlock. - lastAlarmTime _ 0. - drawingFailingMorphs _ WeakIdentitySet new. - pause _ 20. - lastCycleTime _ Time localMillisecondClock. - lastCycleHadAnyEvent _ false! ! -!WorldState methodsFor: 'stepping' stamp: 'jmv 3/3/2017 09:39:18' prior: 50339438! - cleanseStepList - "Remove morphs from the step list that are not in this World." - - | deletions morphToStep | - deletions _ nil. - stepList do: [:entry | - morphToStep _ entry receiver. - morphToStep world == world ifFalse:[ - deletions ifNil: [deletions _ OrderedCollection new]. - deletions addLast: entry]]. - - deletions ifNotNil:[ - deletions do: [:entry| - self stopSteppingMorph: entry receiver]]. - - alarms copy do: [ :entry | - morphToStep _ entry receiver. - ((morphToStep is: #Morph) and: [ morphToStep world == world ]) - ifFalse: [ self removeAlarm: entry selector for: entry receiver ]]! ! -!WorldState methodsFor: 'stepping' stamp: 'jmv 3/3/2017 09:46:37' prior: 50339461! - runStepMethods - "Perform periodic activity inbetween event cycles" - | queue msg | - - queue _ self class deferredUIMessages. - [ (msg _ queue nextOrNil) isNil ] whileFalse: [ - msg value - ]. - self triggerAlarmsBefore: lastCycleTime. - self runLocalStepMethods: lastCycleTime. - - "we are using a normal #step for these now" - "aWorld allLowerWorldsDo: [ :each | each runLocalStepMethods ]." -! ! - -WorldState removeSelector: #alarms! - -WorldState removeSelector: #alarms! - -WorldState removeSelector: #runLocalStepMethods! - -WorldState removeSelector: #runLocalStepMethods! - -----End fileIn of C:\Users\Juan-Tuerca\PayloadSoftware\Cuis-Smalltalk-Dev\CoreUpdates\3053-WorldState-refactor-JuanVuletich-2017Mar03-09h27m-jmv.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3053] on 3 March 2017 at 11:17:47 am'! - -MorphicAlarm subclass: #StepMessage - instanceVariableNames: 'stepTime lastEvaluationTime ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Events'! - -!classDefinition: #StepMessage category: #'Morphic-Events'! -MorphicAlarm subclass: #StepMessage - instanceVariableNames: 'stepTime lastEvaluationTime' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Events'! -!StepMessage methodsFor: 'evaluating' stamp: 'jmv 3/3/2017 11:14:28'! - valueAtTime: millisecondClock - - | nArgs millisecondsSinceLast | - numArgs ifNil: [numArgs _ selector numArgs]. - nArgs _ arguments ifNil: [0] ifNotNil: [arguments size]. -"OJO!!" -lastEvaluationTime ifNil: [ lastEvaluationTime _ millisecondClock ]. - millisecondsSinceLast _ millisecondClock - lastEvaluationTime. - lastEvaluationTime _ millisecondClock. - nArgs = numArgs ifTrue: [ - "Ignore extra argument" - ^self value ]. - ^arguments - ifNil: [ receiver perform: selector with: millisecondsSinceLast] - ifNotNil: [ receiver perform: selector withArguments: (arguments copyWith: millisecondsSinceLast) ]! ! -!WorldState methodsFor: 'accessing' stamp: 'jmv 3/3/2017 11:16:08' prior: 50340125! - runLocalStepMethods: nowTime - "Run morph 'step' methods (LOCAL TO THIS WORLD) whose time has come. Purge any morphs that are no longer in this world." - - | morphToStep scheduledTime | - [ stepList notEmpty and: [ stepList first scheduledTime <= nowTime ]] - whileTrue: [ - lastStepMessage _ stepList removeFirst. - morphToStep _ lastStepMessage receiver. - (morphToStep shouldGetStepsFrom: world) - ifTrue: [ - scheduledTime _ lastStepMessage scheduledTime. - lastStepMessage valueAtTime: nowTime. - lastStepMessage ifNotNil: [ - lastStepMessage scheduledTime: (scheduledTime + lastStepMessage stepTime max: nowTime + 1). - stepList add: lastStepMessage ]]. - lastStepMessage _ nil ]! ! - -MorphicAlarm subclass: #StepMessage - instanceVariableNames: 'stepTime lastEvaluationTime' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Events'! - -!classDefinition: #StepMessage category: #'Morphic-Events'! -MorphicAlarm subclass: #StepMessage - instanceVariableNames: 'stepTime lastEvaluationTime' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Events'! - -----End fileIn of C:\Users\Juan-Tuerca\PayloadSoftware\Cuis-Smalltalk-Dev\CoreUpdates\3054-StepMessageCleanup-JuanVuletich-2017Mar03-11h11m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3053] on 3 March 2017 at 11:41:31 am'! -!StepMessage methodsFor: 'evaluating' stamp: 'jmv 3/3/2017 11:28:02'! - rescheduleAfter: millisecondTimer - "Schedule next run" - scheduledTime _ scheduledTime + self stepTime max: millisecondTimer + 1! ! -!WorldState methodsFor: 'stepping' stamp: 'jmv 3/3/2017 11:39:34' prior: 16945882! - stopStepping: aMorph selector: aSelector - "Remove the given morph from the step list." - stepList removeAll: (stepList select:[:stepMsg| stepMsg receiver == aMorph and: [ stepMsg selector == aSelector ]])! ! -!WorldState methodsFor: 'stepping' stamp: 'jmv 3/3/2017 11:39:22' prior: 16945896! - stopSteppingMorph: aMorph - "Remove the given morph from the step list." - stepList removeAll: (stepList select: [ :stepMsg | stepMsg receiver == aMorph])! ! -!WorldState methodsFor: 'accessing' stamp: 'jmv 3/3/2017 11:39:10' prior: 50340297! - runLocalStepMethods: nowTime - "Run morph 'step' methods (LOCAL TO THIS WORLD) whose time has come. Purge any morphs that are no longer in this world." - - | stepMessage | - [ stepList notEmpty and: [ stepList first scheduledTime <= nowTime ]] - whileTrue: [ - - stepMessage _ stepList first. - (stepMessage receiver shouldGetStepsFrom: world) - ifTrue: [ - stepMessage valueAtTime: nowTime. - "If it was not removed from the list during its own evaluation" - stepMessage == stepList first ifTrue: [ - stepList removeFirst. - stepMessage rescheduleAfter: nowTime. - stepList add: stepMessage ]] - - ifFalse: [ stepList removeFirst ]. - ]! ! - -----End fileIn of C:\Users\Juan-Tuerca\PayloadSoftware\Cuis-Smalltalk-Dev\CoreUpdates\3055-SteppingCleanup-JuanVuletich-2017Mar03-11h17m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3053] on 3 March 2017 at 11:55:19 am'! -!StepMessage methodsFor: 'evaluating' stamp: 'jmv 3/3/2017 11:55:15' prior: 50340275! - valueAtTime: millisecondClock - - | nArgs millisecondsSinceLast | - numArgs ifNil: [numArgs _ selector numArgs]. - nArgs _ arguments ifNil: [0] ifNotNil: [arguments size]. - lastEvaluationTime ifNil: [ lastEvaluationTime _ millisecondClock ]. - millisecondsSinceLast _ millisecondClock - lastEvaluationTime. - lastEvaluationTime _ millisecondClock. - nArgs = numArgs ifTrue: [ - "Ignore extra argument" - ^self value ]. - ^arguments - ifNil: [ receiver perform: selector with: millisecondsSinceLast] - ifNotNil: [ receiver perform: selector withArguments: (arguments copyWith: millisecondsSinceLast) ]! ! -!PasteUpMorph methodsFor: 'caching' stamp: 'jmv 3/3/2017 11:42:44' prior: 16887042! - releaseCachedState - super releaseCachedState. - backgroundImage _ nil. - self isWorldMorph ifTrue: [ - worldState cleanseStepList. - worldState clearCanvas ]! ! -!WorldState methodsFor: 'alarms' stamp: 'jmv 3/3/2017 11:54:00' prior: 50340174! - removeAlarm: aSelector for: aTarget - "Remove the alarm with the given selector" - - | alarm | - alarm _ alarms - detect: [ :any | any receiver == aTarget and: [any selector == aSelector]] - ifNone: nil. - alarm ifNotNil: [ alarms remove: alarm ]! ! -!WorldState methodsFor: 'stepping' stamp: 'jmv 3/3/2017 11:51:16' prior: 50340213! - cleanseStepList - "Remove morphs from the step list that are not in this World." - - | deletions | - deletions _ OrderedCollection new. - stepList do: [ :entry | - entry receiver world == world ifFalse: [ - deletions add: entry]]. - deletions do: [ :entry| - stepList remove: entry ]. - - deletions _ OrderedCollection new. - alarms do: [ :entry | - ((entry receiver is: #Morph) and: [ entry receiver world == world ]) ifFalse: [ - deletions add: entry]]. - deletions do: [ :entry| - alarms remove: entry ]! ! - -PasteUpMorph removeSelector: #cleanseStepList! - -PasteUpMorph removeSelector: #cleanseStepList! - -----End fileIn of C:\Users\Juan-Tuerca\PayloadSoftware\Cuis-Smalltalk-Dev\CoreUpdates\3056-SteppingCleanup-JuanVuletich-2017Mar03-11h41m-jmv.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3056] on 3 March 2017 at 3:11:05 pm'! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 3/3/2017 15:04:20' prior: 50339505! - doOneCycle - "Do one cycle of the interaction loop. This method is called repeatedly when the world is running. - - Make for low cpu usage if the ui is inactive, but quick response when ui is in use. - However, after some inactivity, there will be a larger delay before the ui gets responsive again." - - | wait waitUntil | - waitDelay ifNil: [ waitDelay _ Delay forMilliseconds: 50 ]. - lastCycleHadAnyEvent - ifTrue: [ - pause _ 20. "This value will only be used when there are no more events to serve." - wait _ 0 ] "Don't wait" - ifFalse: [ - pause < 200 "No events processed? Start saving CPU!! But never make the user wait more than 200ms for being responsive again." - ifTrue: [ pause _ pause * 21//20 ]. - waitUntil _ lastCycleTime + pause. - "Earlier if steps" - stepList isEmpty not ifTrue: [ - waitUntil _ waitUntil min: stepList first scheduledTime ]. - "Earlier if alarms" - alarms ifNotNil: [ - alarms isEmpty not ifTrue: [ - waitUntil _ waitUntil min: alarms first scheduledTime ]]. - - wait _ waitUntil - Time localMillisecondClock ]. - Preferences serverMode - ifTrue: [ wait _ wait max: 50 ]. "Always wait at least a bit on servers, even if this makes the UI slow." - wait > 5 - ifFalse: [ Processor yield ] - ifTrue: [ - waitDelay beingWaitedOn - ifFalse: [ waitDelay setDelay: wait; wait ] - ifTrue: [ - "If we are called from a different process than that of the main UI, we might be called in the main - interCyclePause. In such case, use a new Delay to avoid 'This Delay has already been scheduled' errors" - (Delay forMilliseconds: wait) wait ]]. - - "Record start time of this cycle, and do cycle" - lastCycleTime _ Time localMillisecondClock. - lastCycleHadAnyEvent _ self doOneCycleNow! ! - -----End fileIn of C:\Users\Juan-Tuerca\PayloadSoftware\Cuis-Smalltalk-Dev\CoreUpdates\3057-SteppingHangWorkaround-JuanVuletich-2017Mar03-15h10m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3049] on 3 March 2017 at 7:15:45 pm'! -!TestCase methodsFor: 'Running' stamp: 'HAW 3/3/2017 19:13:13'! - debugAsFailureIfCanNot: handler - - | semaphore | - - self ifCanNotDebugDo: [ ^handler value]. - - semaphore := Semaphore new. - self resources do: [:res | - res isAvailable ifFalse: [^res signalInitializationError]]. - [semaphore wait. - self tearDown. - self resources do: [:each | each reset]] fork. - (self class selector: testSelector) runCaseAsFailure: semaphore.! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 3/3/2017 14:13:09'! - canNotDebugMethodErrorDescription - - ^self class canNotDebugMethodErrorDescription! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 3/3/2017 18:50:08'! - ifCanNotDebugDo: handler - - ^self testMethod isQuick ifTrue: handler! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 3/3/2017 14:13:37'! - signalCanNotDebugMethod - - self error: self canNotDebugMethodErrorDescription! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 3/3/2017 14:10:20'! - testMethod - - ^self class lookupSelector: self selector! ! -!TestCase class methodsFor: 'Instance Creation' stamp: 'HAW 3/3/2017 18:51:38'! - debugAsFailure: aSymbol ifCanNot: handler - - ^(self selector: aSymbol) debugAsFailureIfCanNot: handler - ! ! -!TestCase class methodsFor: 'Error Descriptions' stamp: 'HAW 3/3/2017 16:33:00'! - canNotDebugMethodErrorDescription - - ^'Quick methods can not be debugged'! ! -!Browser methodsFor: 'tdd' stamp: 'HAW 3/3/2017 19:12:25' prior: 50338007! - debugMethodTest - - currentCompiledMethod isTestMethod ifTrue: [ - currentCompiledMethod methodClass debugAsFailure: currentCompiledMethod selector ifCanNot: [ PopUpMenu inform: TestCase canNotDebugMethodErrorDescription ]] -! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HAW 3/3/2017 19:12:39' prior: 50338094! - acceptAndDebugTest - - ^self acceptAndWithMethodDo: [ :aPotencialTestMethod | - aPotencialTestMethod isTestMethod ifTrue: [ - aPotencialTestMethod methodClass debugAsFailure: aPotencialTestMethod selector ifCanNot: [ PopUpMenu inform: TestCase canNotDebugMethodErrorDescription ]]]! ! -!TestCase methodsFor: 'Running' stamp: 'HAW 3/3/2017 18:49:24' prior: 16927491! - debugAsFailure - - ^self debugAsFailureIfCanNot: [ self signalCanNotDebugMethod ]! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 3/3/2017 19:13:40' prior: 16927518! - openDebuggerOnFailingTestMethod - - | guineaPig context compiledMethod debugger | - - compiledMethod _ self testMethod. - guineaPig _ [ self performTest ] newProcess. - context _ guineaPig suspendedContext. - debugger _ Debugger new - process: guineaPig - context: context. - debugger openFullNoSuspendLabel: 'Debug failed test ', self printString. - - [debugger interruptedContext method == compiledMethod] - whileFalse: [debugger send]. -! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 3/3/2017 19:14:27' prior: 16927535! - openDebuggerOnFailingTestMethod: semaphore - - | guineaPig context compiledMethod debugger | - - compiledMethod _ self testMethod. - guineaPig _ [ self performTest ] newProcess. - context _ guineaPig suspendedContext. - debugger _ TestCaseDebugger new - process: guineaPig - context: context. - debugger doneSemaphore: semaphore. - debugger openFullNoSuspendLabel: 'Debug failed test ', self printString. - - [debugger interruptedContext method == compiledMethod] - whileFalse: [debugger send]. -! ! - -TestCase class removeSelector: #debugAsFailure:! - -TestCase class removeSelector: #debugAsFailure:! - -TestCase removeSelector: #assertCanDebugMethod! - -TestCase removeSelector: #canNotDebugQuickMethodErrorDescription! - -TestCase removeSelector: #signalCanNotDebugQuickMethod! - -----End fileIn of C:\Users\Juan-Tuerca\PayloadSoftware\Cuis-Smalltalk-Dev\CoreUpdates\3058-CuisCore-HernanWilkinson-2017Mar02-18h30m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3058] on 6 March 2017 at 10:14:29 am'! -!Delay class methodsFor: 'timer process' stamp: 'jmv 3/6/2017 10:13:34' prior: 16833016! - handleTimerEvent - "Handle a timer event; which can be either: - - a schedule request (ScheduledDelay notNil) - - an unschedule request (FinishedDelay notNil) - - a timer signal (not explicitly specified) - We check for timer expiry every time we get a signal." - | nowTick nextTick afterwardsTick | - "Wait until there is work to do." - TimingSemaphore wait. - - "Process any schedule requests" - ScheduledDelay ifNotNil: [ - "Schedule the given delay" - self scheduleDelay: ScheduledDelay. - ScheduledDelay := nil. - ScheduledDelayNilledSemaphore initSignals. - ScheduledDelayNilledSemaphore signal ]. - - "Process any unschedule requests" - FinishedDelay ifNotNil: [ - self unscheduleDelay: FinishedDelay. - FinishedDelay := nil. - FinishedDelayNilledSemaphore initSignals. - FinishedDelayNilledSemaphore signal ]. - - "Check for clock wrap-around." - nowTick := Time millisecondClockValue. - nowTick < ActiveDelayStartTime ifTrue: [ - "clock wrapped" - self saveResumptionTimes. - self restoreResumptionTimes ]. - ActiveDelayStartTime := nowTick. - - "Signal any expired delays" - [ ActiveDelay notNil and:[ nowTick >= ActiveDelay resumptionTime ]] whileTrue: [ - ActiveDelay signalWaitingProcess. - SuspendedDelays isEmpty - ifTrue: [ ActiveDelay := nil ] - ifFalse:[ ActiveDelay := SuspendedDelays removeFirst ]]. - - "And signal when the next request is due. We sleep at most 1sec here - as a soft busy-loop so that we don't accidentally miss signals." - nextTick := nowTick + 1000. - ActiveDelay ifNotNil: [ - nextTick := nextTick min: ActiveDelay resumptionTime ]. - nextTick := nextTick min: SmallInteger maxVal. - - "Since we have processed all outstanding requests, reset the timing semaphore so - that only new work will wake us up again. Do this RIGHT BEFORE setting the next - wakeup call from the VM because it is only signaled once so we mustn't miss it." - TimingSemaphore initSignals. - Delay primSignal: TimingSemaphore atMilliseconds: nextTick. - - "This test is necessary for the obscure case that the msecs clock rolls over - after nowTick has been computed (unlikely but not impossible). In this case we'd - wait for MillisecondClockMask msecs (roughly six days) or until another delay gets - scheduled (which may not be any time soon). In any case, since handling the - condition is easy, let's just deal with it." - afterwardsTick _ Time millisecondClockValue. - afterwardsTick < nowTick "Means clock rollover." - ifTrue: [ TimingSemaphore signal ]. "retry" - - "It seems that #primSignal:atMilliseconds: might not signal the semaphore if the requested moment is in the past. - This behavior was observed in Linux Spur64 VMs. - If this happens, next delay never finishes. Usual symptom is frozen Morphic. - If there is any risk of this happening, just do another iteration right now." - nextTick < afterwardsTick "We're already late for next signal." - ifTrue: [ TimingSemaphore signal ]. "retry"! ! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 3/5/2017 00:38:27' prior: 50340470! - doOneCycle - "Do one cycle of the interaction loop. This method is called repeatedly when the world is running. - - Make for low cpu usage if the ui is inactive, but quick response when ui is in use. - However, after some inactivity, there will be a larger delay before the ui gets responsive again." - - | wait waitUntil | - waitDelay ifNil: [ waitDelay _ Delay forMilliseconds: 50 ]. - lastCycleHadAnyEvent - ifTrue: [ - pause _ 20. "This value will only be used when there are no more events to serve." - wait _ 0 ] "Don't wait" - ifFalse: [ - pause < 200 "No events processed? Start saving CPU!! But never make the user wait more than 200ms for being responsive again." - ifTrue: [ pause _ pause * 21//20 ]. - waitUntil _ lastCycleTime + pause. - "Earlier if steps" - stepList isEmpty not ifTrue: [ - waitUntil _ waitUntil min: stepList first scheduledTime ]. - "Earlier if alarms" - alarms ifNotNil: [ - alarms isEmpty not ifTrue: [ - waitUntil _ waitUntil min: alarms first scheduledTime ]]. - - wait _ waitUntil - Time localMillisecondClock ]. - Preferences serverMode - ifTrue: [ wait _ wait max: 50 ]. "Always wait at least a bit on servers, even if this makes the UI slow." - wait > 0 - ifFalse: [ Processor yield ] - ifTrue: [ - waitDelay beingWaitedOn - ifFalse: [ waitDelay setDelay: wait; wait ] - ifTrue: [ - "If we are called from a different process than that of the main UI, we might be called in the main - interCyclePause. In such case, use a new Delay to avoid 'This Delay has already been scheduled' errors" - (Delay forMilliseconds: wait) wait ]]. - - "Record start time of this cycle, and do cycle" - lastCycleTime _ Time localMillisecondClock. - lastCycleHadAnyEvent _ self doOneCycleNow! ! - -----End fileIn of C:\Users\Juan-Tuerca\PayloadSoftware\Cuis-Smalltalk-Dev\CoreUpdates\3059-RealFixForSteppingFreeze-JuanVuletich-2017Mar06-10h02m-jmv.1.cs.st----! - -----SNAPSHOT----#(6 March 2017 10:36:25.90543 am) Cuis5.0-3059.image priorSource: 202624! - -----QUIT----#(6 March 2017 10:36:43.98243 am) Cuis5.0-3059.image priorSource: 293299! - -----STARTUP----#(8 March 2017 9:34:14.372206 am) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3059.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3059] on 7 March 2017 at 9:52:45 am'! -!Time class methodsFor: 'primitives' stamp: 'jmv 3/7/2017 09:52:37' prior: 16937622! - primMillisecondClock - "Primitive. Answer the number of milliseconds since the millisecond clock - was last reset or rolled over. No sync to any system clock. - Implemented by all major platforms. - Essential. See Object documentation whatIsAPrimitive. - - Time primMillisecondClock - Time primMillisecondClock / 1000 / 60.0 - - Range is from zero to 16r1FFFFFFF. - The VM defines MillisecondClockMask as 16r1FFFFFFF - - Overflows usually every six days. - Still used in #localMillisecondClock if the VM doesn't implement - Time primLocalMicrosecondClock - " -"Not really a clock, but a timer or ticker" - - - self primitiveFailed! ! -!Delay class methodsFor: 'timer process' stamp: 'jmv 3/7/2017 09:51:10' prior: 50340660! - handleTimerEvent - "Handle a timer event; which can be either: - - a schedule request (ScheduledDelay notNil) - - an unschedule request (FinishedDelay notNil) - - a timer signal (not explicitly specified) - We check for timer expiry every time we get a signal." - | nowTick nextTick afterwardsTick | - "Wait until there is work to do." - TimingSemaphore wait. - - "Process any schedule requests" - ScheduledDelay ifNotNil: [ - "Schedule the given delay" - self scheduleDelay: ScheduledDelay. - ScheduledDelay := nil. - ScheduledDelayNilledSemaphore initSignals. - ScheduledDelayNilledSemaphore signal ]. - - "Process any unschedule requests" - FinishedDelay ifNotNil: [ - self unscheduleDelay: FinishedDelay. - FinishedDelay := nil. - FinishedDelayNilledSemaphore initSignals. - FinishedDelayNilledSemaphore signal ]. - - "Check for clock wrap-around." - nowTick := Time millisecondClockValue. - nowTick < ActiveDelayStartTime ifTrue: [ - "clock wrapped" - self saveResumptionTimes. - self restoreResumptionTimes ]. - ActiveDelayStartTime := nowTick. - - "Signal any expired delays" - [ ActiveDelay notNil and:[ nowTick >= ActiveDelay resumptionTime ]] whileTrue: [ - ActiveDelay signalWaitingProcess. - SuspendedDelays isEmpty - ifTrue: [ ActiveDelay := nil ] - ifFalse:[ ActiveDelay := SuspendedDelays removeFirst ]]. - - "And signal when the next request is due. We sleep at most 1sec here - as a soft busy-loop so that we don't accidentally miss signals." - nextTick := nowTick + 1000. - ActiveDelay ifNotNil: [ - nextTick := nextTick min: ActiveDelay resumptionTime ]. - nextTick := nextTick min: 16r1FFFFFFF. "MillisecondClockMask" - - "Since we have processed all outstanding requests, reset the timing semaphore so - that only new work will wake us up again. Do this RIGHT BEFORE setting the next - wakeup call from the VM because it is only signaled once so we mustn't miss it." - TimingSemaphore initSignals. - Delay primSignal: TimingSemaphore atMilliseconds: nextTick. - - "This test is necessary for the obscure case that the msecs clock rolls over - after nowTick has been computed (unlikely but not impossible). In this case we'd - wait for MillisecondClockMask msecs (roughly six days) or until another delay gets - scheduled (which may not be any time soon). In any case, since handling the - condition is easy, let's just deal with it." - afterwardsTick _ Time millisecondClockValue. - afterwardsTick < nowTick "Means clock rollover." - ifTrue: [ TimingSemaphore signal ]. "retry" - - "It seems that #primSignal:atMilliseconds: might not signal the semaphore if the requested moment is in the past. - This behavior was observed in Linux Spur64 VMs. - If this happens, next delay never finishes. Usual symptom is frozen Morphic. - If there is any risk of this happening, just do another iteration right now." - nextTick < afterwardsTick "We're already late for next signal." - ifTrue: [ TimingSemaphore signal ]. "retry"! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3060-Proper-MillisecondClockMask-JuanVuletich-2017Mar07-09h05m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3061] on 7 March 2017 at 12:20:30 pm'! -!Time class methodsFor: 'primitives' stamp: 'jmv 3/7/2017 12:16:43' prior: 16937642! - primUtcMicrosecondClock - "Answer the number of microseconds since the UTC Smalltalk epoch, - i.e. 00:00 on the morning of January 1, 1901, the start of the 20th century, in UTC time. - The value is derived from the Posix epoch with a constant offset corresponding to elapsed microseconds - between the two epochs according to RFC 868. - Answer is (at least usually) a LargePositiveInteger - Cog VMs implement this. Interpreters might not." - " - Time primUtcMicrosecondClock - Time primUtcMicrosecondClock/ 1000 / 1000 / 60 / 60 / 24 / 365.25 - - (Time primUtcMicrosecondClock / 1000 / 1000 + Time primUtcWithOffset second) / 60 / 60 / 24 / 365.25 - (DateAndTime now - (DateAndTime year: 1901 month: 1 day: 1)) totalSeconds / 60 / 60 / 24 / 365.25 - " - - ^nil! ! -!Delay class methodsFor: 'primitives' stamp: 'jmv 3/7/2017 12:19:39'! - primSignal: aSemaphore atUTCMicroseconds: anInteger - "Signal the semaphore when the UTC microsecond clock reaches the value of the second argument. - Fail if the first argument is neither a Semaphore nor nil. - Fail if the second argument is not an integer (either SmallInteger or LargePositiveInteger). - See #primUtcMicrosecondClock - Essential. See Object documentation whatIsAPrimitive." - - ^self primitiveFailed! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3061-UTCDelayedSignalPrimitive-JuanVuletich-2017Mar07-12h16m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3061] on 7 March 2017 at 2:55:27 pm'! - -BorderedRectMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp titleMorph activeSubMenu popUpOwner ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #MenuMorph category: #'Morphic-Menus'! -BorderedRectMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp titleMorph activeSubMenu popUpOwner' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! -!MenuMorph methodsFor: 'control' stamp: 'ar 9/17/2000 20:38'! - activeSubmenu: aSubmenu - activeSubMenu ifNotNil:[activeSubMenu delete]. - activeSubMenu _ aSubmenu.! ! -!MenuMorph methodsFor: 'initialization' stamp: 'ar 10/10/2000 01:57'! - delete - activeSubMenu ifNotNil:[activeSubMenu delete]. - ^super delete! ! -!MenuItemMorph methodsFor: 'events' stamp: 'jmv 9/20/2012 00:14'! - activateOwnerMenu: evt - "Activate our owner menu; e.g., pass control to it" - owner ifNil: [ ^false ]. "not applicable" - (owner morphContainsPoint: (owner internalizeFromWorld: evt eventPosition)) - ifFalse: [ ^false ]. - owner activate: evt. - ^true! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 3/7/2017 14:37:43' prior: 50339167! - deleteIfPopUp: evt - "Remove this menu from the screen if stayUp is not true. If it is a submenu, also remove its owning menu." - - stayUp ifFalse: [ self delete ]. - popUpOwner ifNotNil: [ - popUpOwner isSelected: false. - popUpOwner deleteIfPopUp: evt ]. - evt ifNotNil: [ evt hand ifNotNil: [ :h | h releaseMouseFocus: self ]]! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 5/9/2016 20:40' prior: 50339176! - popUpAdjacentTo: rightOrLeftPointInWorld from: sourceItem - "Present this menu at the given point under control of the given hand. - Used mostly for submenus." - - | delta tryToPlace selectedOffset | - popUpOwner _ sourceItem. - selectedOffset _ (selectedItem ifNil: [ self items first ]) morphPosition. - sourceItem world addMorphFront: self. - - tryToPlace _ [ :where :mustFit | - self morphPosition: where - selectedOffset. - delta _ self morphFullBoundsInWorld - amountToTranslateWithin: sourceItem world morphBoundsInWorld. - (delta x = 0 | mustFit) ifTrue: [ - delta = (0@0) ifFalse: [ self morphPosition: self morphPosition + delta ]. - ^ self]]. - tryToPlace - value: rightOrLeftPointInWorld first value: false; - value: rightOrLeftPointInWorld last - (extent x @ 0) value: false; - value: rightOrLeftPointInWorld first value: true! ! -!MenuMorph methodsFor: 'events-processing' stamp: 'jmv 8/20/2012 17:50' prior: 50339315! - handleFocusEvent: aMorphicEvent - "Handle focus events. Valid menu transitions are determined based on the menu currently holding the focus after the mouse went down on one of its children." - | eventPositionInOurCoordinates | - eventPositionInOurCoordinates _ self internalizeFromWorld: aMorphicEvent eventPosition. - - self dispatchEvent: aMorphicEvent localPosition: eventPositionInOurCoordinates. - - "Need to handle keyboard input if we have the focus." - aMorphicEvent isKeyboard ifTrue: [ ^ aMorphicEvent sentTo: self localPosition: eventPositionInOurCoordinates]. - - "We need to handle button clicks outside and transitions to local popUps so throw away everything else" - (aMorphicEvent isMouseOver or: [aMorphicEvent isMouse not]) ifTrue: [ ^self ]. - "What remains are mouse buttons and moves" - aMorphicEvent isMove ifFalse: [ ^ aMorphicEvent sentTo: self localPosition: eventPositionInOurCoordinates ]. "handle clicks outside by regular means" - "Now it's getting tricky. On #mouseMove we might transfer control to *either* the currently active submenu or the pop up owner, if any. Since the active sub menu is always displayed upfront check it first." - selectedItem ifNotNil:[(selectedItem activateSubmenu: aMorphicEvent) ifTrue: [^self]]. - "Note: The following does not traverse upwards but it's the best I can do for now" - popUpOwner ifNotNil:[(popUpOwner activateOwnerMenu: aMorphicEvent) ifTrue: [^self]].! ! -!MenuMorph methodsFor: 'initialization' stamp: 'jmv 9/8/2012 20:15' prior: 50339357! - initialize - super initialize. - extent _ 40@10. - defaultTarget _ nil. - selectedItem _ nil. - stayUp _ false. - popUpOwner _ nil! ! -!MenuItemMorph methodsFor: 'selecting' stamp: 'jmv 1/29/2014 23:46' prior: 50339370! - deselect - - self isSelected: false. - subMenu ifNotNil: [ - owner ifNotNil:[ owner activeSubmenu: nil ]. - self removeAlarm: #deselectTimeOut ]! ! -!MenuItemMorph methodsFor: 'selecting' stamp: 'jmv 1/29/2014 23:44' prior: 50339376! - select - self isSelected: true. - owner activeSubmenu: subMenu. - subMenu ifNotNil: [ - subMenu delete. - subMenu - popUpAdjacentTo: (Array with: self morphBoundsInWorld topRight + (10@0) - with: self morphBoundsInWorld topLeft) - from: self. - subMenu selectItem: nil ]! ! - -BorderedRectMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp titleMorph activeSubMenu popUpOwner' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #MenuMorph category: #'Morphic-Menus'! -BorderedRectMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp titleMorph activeSubMenu popUpOwner' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3062-FixRecentMenuBreackage-JuanVuletich-2017Mar07-14h20m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3049] on 7 March 2017 at 3:18:07 pm'! -!TestCase methodsFor: 'Private' stamp: 'HAW 3/6/2017 14:55:23'! - methodForTest - - "Can not call it testMethod because it will be detected as test - Hernan" - - ^self class lookupSelector: self selector! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 3/6/2017 14:55:38' prior: 50340554! - ifCanNotDebugDo: handler - - ^self methodForTest isQuick ifTrue: handler! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 3/6/2017 14:55:45' prior: 50340608! - openDebuggerOnFailingTestMethod - - | guineaPig context compiledMethod debugger | - - compiledMethod _ self methodForTest. - guineaPig _ [ self performTest ] newProcess. - context _ guineaPig suspendedContext. - debugger _ Debugger new - process: guineaPig - context: context. - debugger openFullNoSuspendLabel: 'Debug failed test ', self printString. - - [debugger interruptedContext method == compiledMethod] - whileFalse: [debugger send]. -! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 3/6/2017 14:55:50' prior: 50340625! - openDebuggerOnFailingTestMethod: semaphore - - | guineaPig context compiledMethod debugger | - - compiledMethod _ self methodForTest. - guineaPig _ [ self performTest ] newProcess. - context _ guineaPig suspendedContext. - debugger _ TestCaseDebugger new - process: guineaPig - context: context. - debugger doneSemaphore: semaphore. - debugger openFullNoSuspendLabel: 'Debug failed test ', self printString. - - [debugger interruptedContext method == compiledMethod] - whileFalse: [debugger send]. -! ! - -TestCase removeSelector: #testMethod! - -TestCase removeSelector: #testMethod! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3063-FixForExtraTest-HernanWilkinson-2017Mar03-19h15m-HAW.1.cs.st----! - -----SNAPSHOT----#(8 March 2017 9:34:44.802068 am) Cuis5.0-3063.image priorSource: 293390! - -----QUIT----#(8 March 2017 9:34:58.446732 am) Cuis5.0-3063.image priorSource: 306631! - -----STARTUP----#(13 March 2017 5:41:16.036263 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3063.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3063] on 13 March 2017 at 4:16:45 pm'! -!WriteStream methodsFor: 'accessing' stamp: 'jmv 3/12/2017 18:55:36' prior: 50335197! - nextPutAllString: aString withAttributes: attributesArray - - | newEnd | - (self isCompatibleWithContents: aString) - ifFalse: [ ^ self nextPutAll: aString ]. - - newEnd _ position + aString size. - newEnd > writeLimit ifTrue: [ - self growTo: newEnd + 10]. - - collection - replaceFrom: position+1 - to: newEnd - withString: aString - attributes: attributesArray - startingAt: 1. - position _ newEnd! ! -!WriteStream methodsFor: 'private' stamp: 'jmv 3/12/2017 19:08:07' prior: 16946568! -growTo: anInteger - "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. - - anInteger is the required minimal new size of the collection " - - | oldSize grownCollection newSize | - oldSize _ collection size. - newSize _ anInteger + (oldSize max: 20). - grownCollection _ collection class new: newSize. - collection _ grownCollection replaceFrom: 1 to: oldSize with: collection startingAt: 1. - writeLimit _ collection size! ! -!WriteStream methodsFor: 'private' stamp: 'jmv 3/12/2017 19:07:28' prior: 16946596! - pastEndPut: anObject - "Grow the collection. - Then we put at the current write position." - - self growTo: collection size + 1. - collection at: (position _ position + 1) put: anObject! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3064-WriteStreamTweaks-JuanVuletich-2017Mar13-16h06m-jmv.1.cs.st----! - -----SNAPSHOT----#(13 March 2017 5:41:23.462443 pm) Cuis5.0-3064.image priorSource: 306722! - -----QUIT----#(13 March 2017 5:41:40.450702 pm) Cuis5.0-3064.image priorSource: 308528! - -----STARTUP----#(19 March 2017 8:09:32.765418 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3064.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3064] on 15 March 2017 at 2:07:10 pm'! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 3/15/2017 14:06:54' prior: 50337450! - maximumUsableAreaInWorld: aWorldOrNil - - | allowedArea | - allowedArea _ Display boundingBox. - aWorldOrNil ifNotNil: [ - allowedArea _ allowedArea intersect: aWorldOrNil viewBox. - aWorldOrNil taskbar ifNotNil: [ :tb | - tb morphBoundsInWorld ifNotNil: [ :r | - allowedArea _ (allowedArea areasOutside: r) first ]]]. - ^allowedArea -! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3065-TaskbarFix-JuanVuletich-2017Mar15-14h03m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3064] on 17 March 2017 at 10:25:22 am'! -!Debugger methodsFor: 'method creation' stamp: 'HAW 3/17/2017 10:24:51' prior: 50336709! - createMethodWhenDoesNotUndertand - - | message chosenClass interruptedContext | - - "The doesNotUndertand context must be selected - Hernan" - contextStackIndex = 1 ifFalse: [ self contextStackIndex: 1 oldContextWas: self selectedContext ]. - - interruptedContext _ self interruptedContext. - message _ interruptedContext tempAt: 1. - - chosenClass _ self - askForSuperclassOf: interruptedContext receiver class - toImplement: message selector - ifCancel: [^self]. - - self implement: message inClass: chosenClass context: self selectedContext - -! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3066-CreateMissingMethodInDebuggerFix-HernanWilkinson-2017Mar16-20h05m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3064] on 18 March 2017 at 10:47:28 am'! -!SmalltalkEditor class methodsFor: 'keyboard shortcut tables' stamp: 'HAW 3/18/2017 10:44:48' prior: 50338473! - cmdShortcutsSpec - " - Editor initialize - " - "arranged in QWERTY keyboard order" - ^#( - #( $r #acceptAndDebugTest: 'Saves method and debugs it') - #( $t #acceptAndTest: 'Saves method, runs it as test and then all tests in class. Opens debugger if error') - #( $y #acceptAndTestAll: 'Saves method, runs it as test and then all tests in class category. Opens debugger if error') - #( $i #inspectIt: 'Inspect it (selection is a valid expression, or selection is over an inspect-ilst)') - #( $p #printIt: 'Print it (selection is a valid expression)') - - #( $s #save: 'Save (i.e. accept)') - #( $d #doIt: 'Do it (selection is a valid expression)') - #( $l #cancelEdits: 'Cancel') - - #( $b #browseIt: 'Browse it (selection is a class name or cursor is over a class-list or message-list)') - #( $n #sendersOfIt: 'Senders of it (selection is a message selector or cursor is over a class-list or message-list)') - #( $m #implementorsOfIt: 'Implementors of it (selection is a message selector or cursor is over a class-list or message-list)') - - #( $E #methodStringsContainingit:'Method strings containing it') - #( $T #displayIfTrue: 'Insert #ifTrue:') - #( $I #exploreIt: 'Inspect via Object Explorer') - - #( $A #argAdvance: 'Advance argument') - #( $D #debugIt: 'Debug it') - #( $F #displayIfFalse: 'Insert #ifFalse:') - #( $G #fileItIn: 'File in selection') - - #( $V #pasteInitials: 'Paste author initials') - #( $N #referencesToIt: 'References to it (selection is a class name, or cursor is over a class-list or message-list)') - )! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3067-FixATypo-HernanWilkinson-2017Mar18-10h44m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3064] on 18 March 2017 at 8:30:03 pm'! -!TheWorldMenu methodsFor: 'construction' stamp: 'HAW 3/18/2017 20:26:59' prior: 16934784! - buildWorldMenu - "Build the menu that is put up when the screen-desktop is clicked on" - - | menu | - menu _ MenuMorph new defaultTarget: self. - self colorForDebugging: menu. - menu addStayUpIcons. - self fillIn: menu - from: { - { 'Open...'. { self. #openWindow}}. - { 'New morph...'. { self. #newMorph}. - 'Offers a variety of ways to create new objects'}. - { 'Preferences...'. { self. #preferencesDo}. - 'put up a menu offering many controls over appearance and system preferences.'}. - { 'Windows...'. { self. #windowsDo}}. - { 'Help...'. { self. #helpDo}. - 'puts up a menu of useful items for updating the system, determining what version you are running, and much else'}. - nil. - { 'Changes...'. { self. #changesDo}}. - { 'Debug...'. { self. #debugDo}. - 'a menu of debugging items'}. - { 'Restore Display (r)'. { myWorld. #restoreMorphicDisplay}. - 'repaint the screen -- useful for removing unwanted display artifacts, lingering cursors, etc.'}. - nil. - { 'Save'. { Smalltalk . #saveSession}. - 'save the current version of the image on disk'}. - { 'Save as...'. { Smalltalk . #saveAs}. - 'save the current version of the image on disk under a new name.'}. - { 'Save as New Version'. { Smalltalk . #saveAsNewVersion}. - 'give the current image a new version-stamped name\and save it under that name on disk.\Clear all user preferences and user state (class vars).' withNewLines}. - { 'Save and Quit'. { self. #saveAndQuit}. - 'save the image and quit out of Cuis.'}. - { 'Quit'. { self. #quitSession}. - 'quit out of Cuis.'}}. - ^menu! ! - -TheWorldMenu removeSelector: #saveAndQuitSession! - -TheWorldMenu removeSelector: #saveMenu! - -TheWorldMenu removeSelector: #saveMenu! - -TheWorldMenu removeSelector: #saveOptionsDo! - -TheWorldMenu removeSelector: #saveOptionsDo! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3068-SaveMenuIntegrationInWorldMenu-HernanWilkinson-2017Mar18-10h53m-HAW.1.cs.st----! - -----SNAPSHOT----#(19 March 2017 8:09:41.870491 pm) Cuis5.0-3068.image priorSource: 308620! - -----QUIT----#(19 March 2017 8:10:01.388395 pm) Cuis5.0-3068.image priorSource: 314597! - -----STARTUP----#(16 April 2017 9:00:23.300511 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3068.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3068] on 26 March 2017 at 11:30:12 pm'! -!Theme class methodsFor: 'class initialization' stamp: 'jmv 3/26/2017 23:25:17' prior: 16936878! - currentTheme: aTheme - - CurrentTheme := aTheme new. - SHTextStylerST80 initialize. - self runningWorld ifNotNil: [ :w | - w backgroundImage ifNil: [ - w color: CurrentTheme background ]]. - SystemWindow initialize. - BitBltCanvas releaseClassCachedState. - self runningWorld ifNotNil: [ :w | - CurrentTheme useTaskbar - ifTrue: [w showTaskbar] - ifFalse: [w hideTaskbar]. - w restoreMorphicDisplay ]. - - ^ CurrentTheme! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3069-Theme-fix-JuanVuletich-2017Mar26-23h30m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3064] on 25 March 2017 at 10:48:23 am'! -!BasicClassOrganizer methodsFor: 'accessing' stamp: 'HAW 3/25/2017 10:48:00' prior: 16782575! - classComment: aString - "Store the comment, aString, associated with the object that refers to the - receiver." - - aString ifNil: [ ^classComment _ nil ]. - - aString isRemote - ifTrue: [classComment _ aString] - ifFalse: [aString size = 0 - ifTrue: [classComment _ nil] - ifFalse: [ - self error: 'use aClass classComment:'. - classComment _ RemoteString newString: aString onFileNumber: 2]] - "Later add priorSource and date and initials?"! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3070-ClassCommentSetterFix-HernanWilkinson-2017Mar25-10h47m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3064] on 27 March 2017 at 9:11:54 am'! -!Delay class methodsFor: 'instance creation' stamp: 'HAW 3/27/2017 09:08:00' prior: 16832891! - forDuration: aDuration - - ^ self forMilliseconds: aDuration totalMilliseconds! ! - -Duration removeSelector: #totalMilliSeconds! - -Duration removeSelector: #totalMilliSeconds! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3071-Remove-totalMilliSeconds-HernanWilkinson-2017Mar27-09h08m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3068] on 30 March 2017 at 8:42:47 am'! -!Morph methodsFor: 'user interface' stamp: 'jmv 3/30/2017 08:41:08'! - toggleCollapseOrShow - "If collapsed, show me. - If visible, collapse me." - - self visible - ifTrue: [ self collapse ] - ifFalse: [ self showAndComeToFront ]! ! -!Morph methodsFor: 'user interface' stamp: 'jmv 3/30/2017 08:38:46' prior: 50337387! - collapse - "If taskbar not visible, just hide." - - self hide. - self taskbar - ifNotNil: [ :tb | tb wasCollapsed: self ]! ! -!Morph methodsFor: 'user interface' stamp: 'jmv 3/30/2017 08:38:12' prior: 50337102! - showAndComeToFront - "Make me visible if not, set me on top of all other sibling morphs." - self show; comeToFront! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 3/30/2017 08:41:28' prior: 50337683! - addButtonFor: aMorph - - | button | - aMorph == self ifFalse: [ - button _ PluggableButtonMorph - model: aMorph - stateGetter: nil - action: #toggleCollapseOrShow. - button - color: self color; - icon: (aMorph imageForm: 32); - setBalloonText: aMorph label. - button icon: button magnifiedIcon. - viewBox - addMorph: button - fixedWidth: self defaultHeight ]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3072-taskbarButtonTogglesCollapsing-JuanVuletich-2017Mar30-08h36m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3072] on 30 March 2017 at 8:57:52 am'! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 3/30/2017 08:54:49'! - aboutToCollapse: aMorph - "Add a button for aMorph if not already there (see #taskbarIncludesAllWindows)" - - (self buttonFor: aMorph) ifNil: [ - self addButtonFor: aMorph ]! ! -!Morph methodsFor: 'user interface' stamp: 'jmv 3/30/2017 08:55:31' prior: 50341568! - collapse - "If taskbar not visible, just hide." - - self taskbar - ifNotNil: [ :tb | tb aboutToCollapse: self ]. - self hide! ! - -TaskbarMorph removeSelector: #wasCollapsed:! - -TaskbarMorph removeSelector: #wasCollapsed:! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3073-TaskbarFix-JuanVuletich-2017Mar30-08h57m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3064] on 29 March 2017 at 5:18:04 pm'! - -Object subclass: #ExceptionHandlingCondition - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #ExceptionHandlingCondition category: #'Exceptions Kernel'! -Object subclass: #ExceptionHandlingCondition - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! -!ExceptionHandlingCondition commentStamp: '' prior: 0! - I represent the protocol expected to be as condition on the exception handling message on:do: -I also define the protocol to create and combine exceptions handling conditions. -See methods #, and #- for a complemented documentation! -!ExceptionHandlingCondition commentStamp: '' prior: 50341641! - I represent the protocol expected to be as condition on the exception handling message on:do: -I also define the protocol to create and combine exceptions handling conditions. -See methods #, and #- for a complemented documentation! - -Smalltalk renameClassNamed: #ExceptionFilter as: #FilterExceptionHandlingCondition! - -ExceptionHandlingCondition subclass: #FilterExceptionHandlingCondition - instanceVariableNames: 'handleCondition filterCondition' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #FilterExceptionHandlingCondition category: #'Exceptions Kernel'! -ExceptionHandlingCondition subclass: #FilterExceptionHandlingCondition - instanceVariableNames: 'handleCondition filterCondition' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -Smalltalk renameClassNamed: #ExceptionAdd as: #OrExceptionHandlingCondition! - -ExceptionHandlingCondition subclass: #OrExceptionHandlingCondition - instanceVariableNames: 'leftCondition rightCondition' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #OrExceptionHandlingCondition category: #'Exceptions Kernel'! -ExceptionHandlingCondition subclass: #OrExceptionHandlingCondition - instanceVariableNames: 'leftCondition rightCondition' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! -!BlockClosure methodsFor: 'error handing' stamp: 'HAW 3/29/2017 15:16:01'! - handles: anException - - "This allows a block to be the handling condition of an exception handling. - See Exception class>>handles:" - - ^self value: anException ! ! -!Exception class methodsFor: 'handling condition creation' stamp: 'HAW 3/28/2017 15:48:57' prior: 16840211! - , anExceptionHandlingCondition - - "See ExceptionHandlingCondition>>," - - ^anExceptionHandlingCondition createOrConditionWithExceptionType: self! ! -!Exception class methodsFor: 'handling condition creation' stamp: 'HAW 3/28/2017 15:49:08'! - - anExceptionHandlingCondition - - "See ExceptionHandlingCondition>>-" - - ^anExceptionHandlingCondition createFilterConditionWithExceptionType: self! ! -!Exception class methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 11:23:04'! - createFilterConditionWithExceptionType: anExceptionType - - ^FilterExceptionHandlingCondition handling: anExceptionType filtering: self! ! -!Exception class methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 11:26:42'! - createFilterConditionWithFilterCondition: aFilterExceptionHandlingCondition - - ^FilterExceptionHandlingCondition handling: aFilterExceptionHandlingCondition filtering: self! ! -!Exception class methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 15:40:33'! - createFilterConditionWithOrCondition: anOrExceptionHandlingCondition - - ^FilterExceptionHandlingCondition handling: anOrExceptionHandlingCondition filtering: self! ! -!Exception class methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 15:37:59'! - createOrConditionWithExceptionType: anExceptionType - - ^OrExceptionHandlingCondition handling: anExceptionType or: self -! ! -!Exception class methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 15:48:29'! - createOrConditionWithFilterCondition: aFilterExceptionHandlingCondition - - ^aFilterExceptionHandlingCondition handleCondition, self - aFilterExceptionHandlingCondition filterCondition - - ! ! -!Exception class methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 11:09:54'! - createOrConditionWithOrCondition: anOrExceptionHandlingCondition - - ^OrExceptionHandlingCondition handling: anOrExceptionHandlingCondition or: self! ! -!ExceptionHandlingCondition methodsFor: 'error handling' stamp: 'HAW 3/28/2017 17:29:18'! - handles: anException - - "Must return true if anException must be handle - See also Exception class>>handles: anException" - - self subclassResponsibility ! ! -!ExceptionHandlingCondition methodsFor: 'handling condition creation' stamp: 'HAW 3/28/2017 17:17:36'! - , anExceptionHandlingCondition - - "Creates a handling condition that will return true if either part of the condition handles the exception. - It behaves like an or - The following example will handle the exception - [ Error signal ] - on: Error, Halt - do: [ :anError | ... ] - - The following example will also handle the exception: - [ Halt signal ] - on: Error, Halt - do: [ :anError | ... ]" - - self subclassResponsibility - ! ! -!ExceptionHandlingCondition methodsFor: 'handling condition creation' stamp: 'HAW 3/29/2017 13:59:37'! - - anExceptionHandlingCondition - - "Creates a handling condition that will not handle exceptions that meet the right side of the condition - The following example will not handle the exception - [ 1/0 ] - on: Error - ZeroDivide - do: [ :anError | ... ] - - The following example will handle the exception: - [ Error signal ] - on: Error - ZeroDivide - do: [ :anError | ... ] - - Due to inconsisties that can arrise with combining #, with #- the implementation orders the in such a way that 'or conditions' go first - and 'filter conditions' go last. Doing so (Error - Notification) , (UnhandledError - ZeroDivide) is converted to Error, UnhandledError - Notification - ZeroDivide - Inconsisties can arrise because ZeroDivide is a subclass of Error and therefore if the condition is not ordered correctly a ZeroDivide could be handled. - This inconsisty can be found in Pharo where the condition (Error - Notification) , (UnhandledError - ZeroDivide) does not filter ZeroDivide but - the condition Error, UnhandledError - Notification - ZeroDivide does filter it. - That is the reason the implementation uses double dispatch - " - - self subclassResponsibility - ! ! -!ExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/29/2017 13:31:13'! -createFilterConditionWithExceptionType: anExceptionType - - self subclassResponsibility ! ! -!ExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/29/2017 13:33:31'! - createFilterConditionWithFilterCondition: aFilterExceptionHandlingCondition - - self subclassResponsibility ! ! -!ExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/29/2017 13:33:39'! -createFilterConditionWithOrCondition: anOrExceptionHandlingCondition - - self subclassResponsibility ! ! -!ExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/29/2017 13:33:51'! - createOrConditionWithExceptionType: anExceptionType - - self subclassResponsibility ! ! -!ExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/29/2017 13:34:31'! - createOrConditionWithFilterCondition: aFilterExceptionHandlingCondition - - self subclassResponsibility ! ! -!ExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/29/2017 13:34:42'! - createOrConditionWithOrCondition: anOrExceptionHandlingCondition - - self subclassResponsibility ! ! -!FilterExceptionHandlingCondition methodsFor: 'accessing' stamp: 'HAW 3/28/2017 17:20:21'! - filterCondition - - ^filterCondition ! ! -!FilterExceptionHandlingCondition methodsFor: 'accessing' stamp: 'HAW 3/28/2017 17:20:26'! - handleCondition - - ^handleCondition ! ! -!FilterExceptionHandlingCondition methodsFor: 'error handling' stamp: 'HAW 3/28/2017 17:20:41'! - handles: anException - - ^ (filterCondition handles: anException) not and: [ handleCondition handles: anException ]! ! -!FilterExceptionHandlingCondition methodsFor: 'initialization' stamp: 'HAW 3/29/2017 13:45:21'! - initializeHandling: aHandleCondition filtering: aFilterCondition - - handleCondition _ aHandleCondition. - filterCondition _ aFilterCondition ! ! -!FilterExceptionHandlingCondition methodsFor: 'handling condition creation' stamp: 'HAW 3/29/2017 13:59:08'! - , anExceptionHandlingCondition - - "See ExceptionHandlingCondition>>#- for an explanation of why double dispatch is used as implementation" - - ^anExceptionHandlingCondition createOrConditionWithFilterCondition: self! ! -!FilterExceptionHandlingCondition methodsFor: 'handling condition creation' stamp: 'HAW 3/29/2017 13:59:00'! - - anExceptionHandlingCondition - - "See ExceptionHandlingCondition>>#- for an explanation of why double dispatch is used as implementation" - - ^anExceptionHandlingCondition createFilterConditionWithFilterCondition: self! ! -!FilterExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 17:56:46'! - createFilterConditionWithExceptionType: anExceptionType - - ^self class - handling: anExceptionType, filterCondition - filtering: handleCondition ! ! -!FilterExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 17:19:24'! - createFilterConditionWithFilterCondition: aFilterExceptionHandlingCondition - - ^aFilterExceptionHandlingCondition - handleCondition, filterCondition ! ! -!FilterExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 17:19:48'! - createFilterConditionWithOrCondition: anOrExceptionHandlingCondition - - ^anOrExceptionHandlingCondition, filterCondition - handleCondition ! ! -!FilterExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 17:19:56'! - createOrConditionWithExceptionType: anExceptionType - - ^anExceptionType - handleCondition - filterCondition ! ! -!FilterExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 17:20:04'! - createOrConditionWithFilterCondition: aFilterExceptionHandlingCondition - - ^aFilterExceptionHandlingCondition handleCondition,handleCondition - aFilterExceptionHandlingCondition filterCondition - filterCondition ! ! -!FilterExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/29/2017 15:32:33'! - createOrConditionWithOrCondition: anOrExceptionHandlingCondition - - ^anOrExceptionHandlingCondition, handleCondition - filterCondition ! ! -!FilterExceptionHandlingCondition methodsFor: 'printing' stamp: 'HAW 3/28/2017 17:20:55'! - printOn: aStream - - aStream - print: handleCondition ; - nextPutAll: ' - '; - print: filterCondition ! ! -!FilterExceptionHandlingCondition class methodsFor: 'instance creation' stamp: 'HAW 3/28/2017 17:18:11'! - handling: aHandleCondition filtering: aFilterCondition - - ^self new initializeHandling: aHandleCondition filtering: aFilterCondition -! ! -!OrExceptionHandlingCondition methodsFor: 'accessing' stamp: 'HAW 3/28/2017 17:55:27'! - leftCondition - - ^leftCondition ! ! -!OrExceptionHandlingCondition methodsFor: 'accessing' stamp: 'HAW 3/28/2017 17:56:11'! - rightCondition - - ^rightCondition ! ! -!OrExceptionHandlingCondition methodsFor: 'error handling' stamp: 'HAW 3/28/2017 17:31:39'! - handles: anException - - ^ (leftCondition handles: anException) or: [ rightCondition handles: anException ]! ! -!OrExceptionHandlingCondition methodsFor: 'initialization' stamp: 'HAW 3/28/2017 17:32:20'! - initializeHandling: aLeftCondition or: aRightCondition - - leftCondition _ aLeftCondition. - rightCondition _ aRightCondition ! ! -!OrExceptionHandlingCondition methodsFor: 'handling condition creation' stamp: 'HAW 3/29/2017 13:59:16'! - , anExceptionHandlingCondition - - "See ExceptionHandlingCondition>>#- for an explanation of why double dispatch is used as implementation" - - ^anExceptionHandlingCondition createOrConditionWithOrCondition: self - ! ! -!OrExceptionHandlingCondition methodsFor: 'handling condition creation' stamp: 'HAW 3/29/2017 13:59:22'! -- anExceptionHandlingCondition - - "See ExceptionHandlingCondition>>#- for an explanation of why double dispatch is used as implementation" - - ^anExceptionHandlingCondition createFilterConditionWithOrCondition: self - ! ! -!OrExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 17:32:37'! - createFilterConditionWithExceptionType: anExceptionType - - ^FilterExceptionHandlingCondition - handling: anExceptionType - leftCondition - filtering: rightCondition ! ! -!OrExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 17:33:37'! - createFilterConditionWithFilterCondition: aFilterExceptionHandlingCondition - - ^aFilterExceptionHandlingCondition - leftCondition - rightCondition ! ! -!OrExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 17:34:05'! - createFilterConditionWithOrCondition: anOrExceptionHandlingCondition - - ^ anOrExceptionHandlingCondition - leftCondition - rightCondition ! ! -!OrExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 11:16:37'! - createOrConditionWithExceptionType: anExceptionType - - ^self class handling: anExceptionType or: self! ! -!OrExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 14:56:09'! - createOrConditionWithFilterCondition: aFilterExceptionHandlingCondition - - ^self, aFilterExceptionHandlingCondition ! ! -!OrExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 11:20:32'! - createOrConditionWithOrCondition: anOrExceptionHandlingCondition - - ^self class handling: anOrExceptionHandlingCondition or: self! ! -!OrExceptionHandlingCondition methodsFor: 'printing' stamp: 'HAW 3/28/2017 17:54:46'! - printOn: aStream - - aStream - print: leftCondition; - nextPutAll: ', '; - print: rightCondition ! ! -!OrExceptionHandlingCondition class methodsFor: 'instance creation' stamp: 'HAW 3/27/2017 15:47:32'! - handling: anExceptionClass or: anotherExceptionClass - - ^self new initializeHandling: anExceptionClass or: anotherExceptionClass -! ! - -OrExceptionHandlingCondition removeSelector: #createOrHandlingConditionWithOrHandlingCondition:! - -Exception class removeSelector: #createFilterConditionWithExceptionClass:! - -Exception class removeSelector: #createHandlingConditionWithExceptionClass:! - -Exception class removeSelector: #handling:! - -Exception class removeSelector: #orHandlingExceptionClass:! - -Smalltalk removeClassNamed: #ExceptionSet! - -Smalltalk removeClassNamed: #ExceptionSet! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3074-ExceptionHandlingConditionEnh-HernanWilkinson-2017Mar26-18h04m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3064] on 29 March 2017 at 6:09:56 pm'! -!FilterExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/29/2017 17:59:55' prior: 50341955! - createOrConditionWithExceptionType: anExceptionType - - ^anExceptionType, handleCondition - filterCondition ! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3075-ExceptionHandlingConditionFix-HernanWilkinson-2017Mar29-17h18m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3068] on 16 April 2017 at 7:53:58 pm'! -!TextEditor methodsFor: 'menu messages' stamp: 'jmv 4/16/2017 19:53:14' prior: 16932110! - compareToClipboard - "Check to see if whether the receiver's text is the same as the text currently on the clipboard, and inform the user." - | s1 s2 | - s1 _ self clipboardStringOrText string. - s2 _ self selection ifEmpty: [self privateCurrentString]. - s1 = s2 ifTrue: [^ self inform: 'Exact match']. - - (TextModel new contents: - (DifferenceFinder displayPatchFrom: s1 to: s2 tryWords: true)) - openLabel: 'Comparison to Clipboard Text'! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3076-CompareToClipboardComparesSelection-JuanVuletich-2017Apr16-19h53m-jmv.1.cs.st----! - -----SNAPSHOT----#(16 April 2017 9:00:39.728125 pm) Cuis5.0-3076.image priorSource: 314689! - -----QUIT----#(16 April 2017 9:00:52.816126 pm) Cuis5.0-3076.image priorSource: 336438! - -----STARTUP----#(14 May 2017 7:53:51.943165 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3076.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3076] on 13 May 2017 at 12:54:11 pm'! -!Integer methodsFor: 'printing' stamp: 'jmv 5/9/2017 19:45:38'! - printOn: aStream length: minimum zeroPadded: zeroFlag - " - 7 printOn: Transcript length: 4 padded: true. Transcript newLine. - " - self printOn: aStream base: 10 length: minimum padded: zeroFlag! ! -!Character methodsFor: 'accessing' stamp: 'jmv 5/9/2017 19:49:32' prior: 16800371! - 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. - $0 numericValue = 48 - $9 numericValue = 57 - $A numericValue = 65 - $Z numericValue = 90 - $7 digitValue = 7 - " - - | nv | - nv _ self numericValue. - (nv between: 48 and: 57) - ifTrue: [ ^ nv - 48 ]. - (nv between: 65 and: 90) - ifTrue: [ ^ nv - 55 ]. - ^ -1! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3077-Integer-printPadded-JuanVuletich-2017May13-12h51m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3076] on 13 May 2017 at 1:02:33 pm'! -!Timespan class methodsFor: 'squeak protocol' stamp: 'jmv 5/9/2017 19:54:38'! - fromString: aString - "Please call with specific subclass." - - ^ self readFrom: aString readStream! ! -!Week class methodsFor: 'squeak protocol' stamp: 'jmv 5/12/2017 17:48:37'! - readFrom: aStream - "Read a Week from the stream in any of the forms: - -W (2009-W01) (ISO8601)" - | weekNumber yearNumber firstAsNumber firstAsNumberSign | - firstAsNumberSign := aStream peek = $- ifTrue: [-1] ifFalse: [1]. - [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. - aStream peek isDigit ifTrue: [ - firstAsNumber := (Integer readFrom: aStream) * firstAsNumberSign. - (firstAsNumber < 0 or: [firstAsNumber > 12]) - ifTrue: [yearNumber := firstAsNumber]]. - - [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. - aStream next = $W ifFalse: [ - self error: 'Invalid Format' ]. - - weekNumber _ Integer readFrom: aStream. - weekNumber < 1 ifTrue: [ self error: 'Invalid Format' ]. - (yearNumber < 100 and: [yearNumber >= 0]) ifTrue: [ - yearNumber _ yearNumber < 69 - ifTrue: [2000 + yearNumber] - ifFalse: [1900 + yearNumber]]. - - ^ self yearNumber: yearNumber weekNumber: weekNumber! ! -!Week class methodsFor: 'squeak protocol' stamp: 'jmv 5/13/2017 10:54:55'! - yearNumber: yearNumber weekNumber: weekNumber - - | firstOfJanuary firstThursday thisThursday | - firstOfJanuary _ DateAndTime year: yearNumber month: 1 day: 1. - firstThursday _ firstOfJanuary + (4 - firstOfJanuary dayOfWeek \\ 7) days. - thisThursday _ firstThursday + ((weekNumber-1) * 7) days. - - thisThursday yearNumber = yearNumber - ifFalse: [ self error: 'Week does not exist' ]. - - ^ self including: thisThursday! ! -!Year class methodsFor: 'squeak protocol' stamp: 'jmv 5/12/2017 16:41:15'! - readFrom: aStream - - | year sign | - sign := aStream peek = $- ifTrue: [-1] ifFalse: [1]. - [aStream peek isDigit] whileFalse: [aStream skip: 1]. - year := (Integer readFrom: aStream) * sign. - ^ self yearNumber: year! ! -!String methodsFor: 'converting' stamp: 'jmv 5/12/2017 11:24:09'! - asMonth - "Many allowed forms, see Month>>#readFrom: - 'July 1998' asMonth. - '1998/7'asMonth. - " - - ^ Month fromString: self! ! -!String methodsFor: 'converting' stamp: 'jmv 5/12/2017 16:39:13'! - asWeek - " - '2008-W52' asWeek. - '2008-W53' asWeek. 'Invalid format!!'. - '2009-W01' asWeek - '2009-W02' asWeek - '2009-W53' asWeek - '2010-W01' asWeek - '2010-W02' asWeek - '2008-W52' asWeek start. - '2009-W01' asWeek start - '2009-W02' asWeek start - '2009-W53' asWeek start - '2010-W01' asWeek start - '2010-W02' asWeek start - " - - ^ Week fromString: self! ! -!String methodsFor: 'converting' stamp: 'jmv 5/12/2017 16:37:23'! - asYear - " - '2008' asYear. - '2008' asYear start. - " - - ^ Year fromString: self! ! -!DateAndTime methodsFor: 'ansi protocol' stamp: 'jmv 5/12/2017 10:55:06' prior: 16828675! - dayOfWeek - - " - Sunday=1, ... , Saturday=7 - Monday=1, ... , Sunday=7 - '12 May 2017 ' asDate dayOfWeek = 5 - " - - ^ (jdn rem: 7) + 1! ! -!DateAndTime methodsFor: 'ansi protocol' stamp: 'jmv 5/12/2017 10:53:00' prior: 16828685! - dayOfWeekName - " - '12 May 2017 ' asDate dayOfWeek = 5 - '12 May 2017 ' asDate dayOfWeekName = #Friday - " - - ^ Week nameOfDay: self dayOfWeek -! ! -!Duration methodsFor: 'squeak protocol' stamp: 'jmv 5/12/2017 10:59:51' prior: 16836040! - printOn: aStream - "Format as per ANSI 5.8.2.16: [-]D:HH:MM:SS[.S] - (Duration days: 2 hours: 3 minutes: 16 seconds: 43) printString = '2:03:16:43' - " - | d h m s n | - d _ self days abs. - h _ self hours abs. - m _ self minutes abs. - s _ self seconds abs truncated. - n _ self nanoSeconds abs. self negative ifTrue: [ aStream nextPut: $- ]. - d printOn: aStream. aStream nextPut: $:. - h printOn: aStream length: 2 zeroPadded: true.aStream nextPut: $:. - m printOn: aStream length: 2 zeroPadded: true.aStream nextPut: $:. - s printOn: aStream length: 2 zeroPadded: true. - n = 0 ifFalse: [ - | z ps | - aStream nextPut: $.. - ps _ n printString padded: #left to: 9 with: $0. - z _ ps findLast: [ :c | c digitValue > 0 ]. - ps from: 1 to: z do: [ :c | aStream nextPut: c ] ]! ! -!Date methodsFor: 'smalltalk-80' stamp: 'jmv 5/12/2017 10:54:58' prior: 16828235! - weekdayIndex - "Sunday=1, ... , Saturday=7 - Monday=1, ... , Sunday=7 - '12 May 2017 ' asDate weekdayIndex = 5 - " - - ^ self dayOfWeek! ! -!Date class methodsFor: 'squeak protocol' stamp: 'jmv 5/10/2017 21:56:27' prior: 16828417! -readFrom: aStream - "Read a Date from the stream in any of the forms: - (15 April 1982; 15-APR-82; 15.4.82; 15APR82) - (April 15, 1982; 4/15/82) - -- (1982-04-15) (ISO8601)" - | day month year firstAsNumber firstAsNumberSign | - firstAsNumberSign := aStream peek = $- ifTrue: [-1] ifFalse: [1]. - [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. - aStream peek isDigit ifTrue: [ - firstAsNumber := (Integer readFrom: aStream) * firstAsNumberSign. - (firstAsNumber < 0 or: [firstAsNumber > 31]) - ifTrue: [year := firstAsNumber]]. - - [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. - aStream peek isLetter - ifTrue: ["MonthName-DD-YY or DD-MonthName-YY or YY-MonthName-DD" - month _ String streamContents: [ :strm | - [ aStream peek isLetter ] whileTrue: [ strm nextPut: aStream next ]]. - [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. - firstAsNumber - ifNil: ["MonthName DD YY" - day := Integer readFrom: aStream] - ifNotNil: [ - year ifNil: ["DD MonthName YY" - day := firstAsNumber]]] - ifFalse: ["MM-DD-YY or DD-MM-YY or YY-MM-DD" - year - ifNil: ["MM-DD-YY or DD-MM-YY" - firstAsNumber > 12 - ifTrue: ["DD-MM-YY" - day := firstAsNumber. - month := Month nameOfMonth: (Integer readFrom: aStream)] - ifFalse: ["MM-DD-YY" - month := Month nameOfMonth: firstAsNumber. - day := Integer readFrom: aStream]] - ifNotNil: ["YY-MM-DD" - month := Month nameOfMonth: (Integer readFrom: aStream)]]. - - [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. - year - ifNil: [year := Integer readFrom: aStream] - ifNotNil: [day := Integer readFrom: aStream]. - (year < 100 and: [year >= 0]) ifTrue: [ - year _ year < 69 - ifTrue: [2000 + year] - ifFalse: [1900 + year]]. - - ^ self year: year month: month day: day! ! -!Month class methodsFor: 'squeak protocol' stamp: 'jmv 5/12/2017 11:28:03' prior: 16873841! - readFrom: aStream - "Read a Month from the stream in any of the forms: - (April 1982; APR-82; 4.82; APR82) - (April, 1982; 4/82) - - (1982-04) (ISO8601)" - " - Month readFrom: 'July 1998' readStream - " - | month year firstAsNumber firstAsNumberSign | - firstAsNumberSign := aStream peek = $- ifTrue: [-1] ifFalse: [1]. - [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. - aStream peek isDigit ifTrue: [ - firstAsNumber := (Integer readFrom: aStream) * firstAsNumberSign. - (firstAsNumber < 0 or: [firstAsNumber > 12]) - ifTrue: [year := firstAsNumber]]. - - [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. - aStream peek isLetter - ifTrue: ["MonthName-YY or YY-MonthName" - month _ String streamContents: [ :strm | - [ aStream peek isLetter ] whileTrue: [ strm nextPut: aStream next ]]. - [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]] - ifFalse: ["MM-YY or YY-MM" - month _ year - ifNil: ["MM-YY" - Month nameOfMonth: firstAsNumber ] - ifNotNil: ["YY-MM" - Month nameOfMonth: (Integer readFrom: aStream)]]. - - year ifNil: [ - [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. - year := Integer readFrom: aStream]. - (year < 100 and: [year >= 0]) ifTrue: [ - year _ year < 69 - ifTrue: [2000 + year] - ifFalse: [1900 + year]]. - - ^ self month: month year: year! ! -!Week methodsFor: 'squeak protocol' stamp: 'jmv 5/12/2017 11:53:32' prior: 16944751! - printOn: aStream - " - '2008-W52' asWeek. - '2009-W01' asWeek - '2009-W02' asWeek - '2009-W53' asWeek - '2010-W01' asWeek - '2010-W02' asWeek - " - | thursday | - thursday _ self start + 3 days. - thursday yearNumber printOn: aStream. - aStream nextPutAll: '-W'. - (thursday dayOfYear-1 // 7 + 1) printOn: aStream length: 2 zeroPadded: true! ! -!Week class methodsFor: 'squeak protocol' stamp: 'jmv 5/12/2017 10:54:04' prior: 16944773! - indexOfDay: aSymbol - " - Week indexOfDay: #Sunday = 7 - Week nameOfDay: 7 = #Sunday - " - - ^ self dayNames indexOf: aSymbol! ! -!Week class methodsFor: 'smalltalk-80' stamp: 'jmv 5/12/2017 10:53:55' prior: 16944778! - nameOfDay: anIndex - " - Week indexOfDay: #Sunday = 7 - Week nameOfDay: 7 = #Sunday - " - - ^ self dayNames at: anIndex! ! -!Week class methodsFor: 'inquiries' stamp: 'jmv 5/10/2017 22:25:02' prior: 16944786! - dayNames - - ^ #(Monday Tuesday Wednesday Thursday Friday Saturday Sunday)! ! -!String methodsFor: 'converting' stamp: 'jmv 5/12/2017 11:22:17' prior: 16916294! - asDate - "Many allowed forms, see Date>>#readFrom: - '2014/6/30' asDate. - '70/12/30' asDate. - '12/30/70' asDate. - '30/12/70' asDate. - '4/5/6' asDate. - '15 April 1982' asDate. - " - - ^ Date fromString: self! ! - -Date class removeSelector: #fromString:! - -Date class removeSelector: #fromString:! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3078-WeekStartsOnMonday-NewWeekMonthYearCreationMethods-JuanVuletich-2017May13-12h54m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3076] on 13 May 2017 at 1:02:55 pm'! -!DateAndTime methodsFor: 'double dispatching' stamp: 'jmv 5/12/2017 17:17:21'! - includingTimespanOf: aTimespanClass - - ^ aTimespanClass includingDateAndTime: self! ! -!Timespan methodsFor: 'double displatching' stamp: 'jmv 5/12/2017 17:17:18'! - includingTimespanOf: aTimespanClass - - ^ aTimespanClass includingTimespan: self! ! -!Timespan class methodsFor: 'instance creation' stamp: 'jmv 5/12/2017 16:48:47'! - includingDateAndTime: aDateAndTime - - ^ self starting: aDateAndTime duration: Duration zero! ! -!Timespan class methodsFor: 'instance creation' stamp: 'jmv 5/12/2017 17:22:59'! - includingTimespan: aDateAndTime - - | ending starting | - starting _ self includingDateAndTime: aDateAndTime start. - ending _ self includingDateAndTime: aDateAndTime end. - starting = ending ifTrue: [ ^ starting ]. - self error: aDateAndTime printString, ' can not be included in a ', self name! ! -!Date class methodsFor: 'instance creation' stamp: 'jmv 5/12/2017 16:48:52'! - includingDateAndTime: aDateAndTime - - ^self basicNew - start: aDateAndTime midnight; - duration: (Duration days: 1); - yourself! ! -!Month class methodsFor: 'squeak protocol' stamp: 'jmv 5/12/2017 16:48:55'! - includingDateAndTime: aDateAndTime - "Months start at day 1" - | monthStart days | - monthStart _ DateAndTime - year: aDateAndTime yearNumber - month: aDateAndTime monthIndex - day: 1. - days _ self daysInMonth: monthStart monthIndex forYear: monthStart yearNumber. - ^ self basicNew - start: monthStart; - duration: (Duration days: days); - yourself! ! -!Week class methodsFor: 'squeak protocol' stamp: 'jmv 5/12/2017 18:05:57'! - includingDateAndTime: aDateAndTime - " - Week including: '12 May 2017 ' asDate start - (Week including: '12 May 2017 ' asDate start) start dayOfWeekName = #Monday - " - - | midnight weekStart | - midnight _ aDateAndTime midnight. - weekStart _ midnight - (midnight dayOfWeek - 1) days. - - ^ self basicNew - start: weekStart; - duration: (Duration weeks: 1); - yourself! ! -!Year class methodsFor: 'squeak protocol' stamp: 'jmv 5/12/2017 18:00:49'! - includingDateAndTime: aDateAndTime - "Answer a calendar year" - - ^ self yearNumber: aDateAndTime yearNumber! ! -!Timespan class methodsFor: 'instance creation' stamp: 'jmv 5/12/2017 17:18:23' prior: 16938217! - including: aDateAndTime - - ^ aDateAndTime includingTimespanOf: self! ! -!Year class methodsFor: 'squeak protocol' stamp: 'jmv 5/12/2017 17:43:17' prior: 16946731! - yearNumber: aYear - - | yearStart | - yearStart _ DateAndTime year: aYear month: 1 day: 1. - ^ self basicNew - start: yearStart; - duration: (Duration days: (self daysInYear: yearStart yearNumber)); - yourself! ! - -Year class removeSelector: #including:! - -Year class removeSelector: #including:! - -Week class removeSelector: #including:! - -Week class removeSelector: #including:! - -Month class removeSelector: #including:! - -Month class removeSelector: #including:! - -Date class removeSelector: #including:! - -Date class removeSelector: #including:! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3079-TimespanCreation-includingTimespan-JuanVuletich-2017May13-13h02m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3079] on 13 May 2017 at 2:18:26 pm'! -!DateAndTime methodsFor: 'private' stamp: 'jmv 5/13/2017 10:58:22'! - substractDateAndtime: operand - "operand is a DateAndTime or a Duration" - - | lvalue rvalue | - offset = operand offset - ifTrue: [ - lvalue _ self. - rvalue _ operand ] - ifFalse: [ - lvalue _ self asUTC. - rvalue _ operand asUTC ]. - ^ Duration - seconds: (Time secondsInDay *(lvalue julianDayNumber - rvalue julianDayNumber)) + - (lvalue secondsSinceMidnight - rvalue secondsSinceMidnight) - nanoSeconds: lvalue nanoSecond - rvalue nanoSecond! ! -!DateAndTime methodsFor: 'private' stamp: 'jmv 5/13/2017 10:58:31'! - substractDuration: operand - "operand is a DateAndTime or a Duration" - - ^self + operand negated! ! -!DateAndTime methodsFor: 'double dispatching' stamp: 'jmv 5/13/2017 10:59:45'! - substractFrom: aDateAndTime - - ^ aDateAndTime substractDateAndtime: self! ! -!Duration methodsFor: 'double dispatching' stamp: 'jmv 5/13/2017 11:03:50'! - substractFrom: aDateAndTimeOrDate - - ^aDateAndTimeOrDate substractDuration: self! ! -!Timespan methodsFor: 'private' stamp: 'jmv 5/13/2017 11:09:07'! - substractDuration: aDuration - - ^self class classDefinesDuration - ifTrue: [ self class including: start - aDuration ] - ifFalse: [ self class starting: start - aDuration duration: duration ]! ! -!Timespan methodsFor: 'private' stamp: 'jmv 5/13/2017 11:18:25'! - substractTimespan: aTimespan - - aTimespan duration = self duration ifFalse: [ - self error: 'Can not substract Timespans of different duration' ]. - - ^self start substractDateAndtime: aTimespan start! ! -!Timespan methodsFor: 'double displatching' stamp: 'jmv 5/13/2017 11:08:17'! - substractFrom: aTimespan - - ^ aTimespan substractTimespan: self! ! -!DateAndTime methodsFor: 'ansi protocol' stamp: 'jmv 5/13/2017 11:00:53' prior: 16828596! - - operand - "operand is a DateAndTime or a Duration. - Double dispatch" - - ^ operand substractFrom: self! ! -!Timespan methodsFor: 'ansi protocol' stamp: 'jmv 5/13/2017 14:16:21' prior: 16937995! -- aDurationOrTimespan - - ^ aDurationOrTimespan substractFrom: self! ! -!Timespan methodsFor: 'squeak protocol' stamp: 'jmv 5/13/2017 11:13:39' prior: 16938027! - includes: operand - "Operand might be a Timespan or a DateAndtime" - - ^ (operand is: #Timespan) - ifTrue: [ (self includes: operand start) - and: [ self includes: operand end ] ] - ifFalse: [ operand between: start and: self end ]! ! -!Timespan class methodsFor: 'instance creation' stamp: 'jmv 5/13/2017 11:12:44' prior: 50342526! - includingTimespan: aTimespan - - | ending starting | - starting _ self includingDateAndTime: aTimespan start. - ending _ self includingDateAndTime: aTimespan end. - starting = ending ifTrue: [ ^ starting ]. - self error: aTimespan printString, ' can not be included in a ', self name! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3080-TimespanLessTimespan-JuanVuletich-2017May13-14h12m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3080] on 13 May 2017 at 7:48:17 pm'! -!Week methodsFor: 'public protocol' stamp: 'jmv 5/13/2017 14:37:37'! - weekNumber - - | thursday | - thursday _ self start + 3 days. - ^thursday dayOfYear-1 // 7 + 1! ! -!Week methodsFor: 'public protocol' stamp: 'jmv 5/13/2017 14:37:18'! - yearNumber - - | thursday | - thursday _ self start + 3 days. - ^thursday yearNumber! ! -!Year methodsFor: 'public protocol' stamp: 'jmv 5/13/2017 14:51:58'! - yearNumber - - ^ start yearNumber! ! -!Week methodsFor: 'squeak protocol' stamp: 'jmv 5/13/2017 14:38:20' prior: 50342455! - printOn: aStream - " - '2008-W52' asWeek. - '2009-W01' asWeek - '2009-W02' asWeek - '2009-W53' asWeek - '2010-W01' asWeek - '2010-W02' asWeek - " - self yearNumber printOn: aStream. - aStream nextPutAll: '-W'. - self weekNumber printOn: aStream length: 2 zeroPadded: true! ! -!Week class methodsFor: 'squeak protocol' stamp: 'jmv 5/13/2017 14:59:27' prior: 50342469! - indexOfDay: aSymbol - " - (Week indexOfDay: #Sunday) = 7 - (Week nameOfDay: 7) = #Sunday - " - - ^ self dayNames indexOf: aSymbol! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3081-WeekYearTweaks-JuanVuletich-2017May13-19h46m-jmv.1.cs.st----! - -Cursor webLink maskForm bits: (Form extent: 16@16 - fromArray: (#(3072 7680 7680 7680 7680 8118 8191 32767 65535 65535 65535 65535 65535 32766 32766 16380 ) collect: [:bits | bits bitShift: 16]) - offset: 0@0) bits. -Smalltalk garbageCollect.! - -Form allInstances! - -----SNAPSHOT----#(14 May 2017 7:54:25.719029 pm) Cuis5.0-3081.image priorSource: 336530! - -----QUIT----#(14 May 2017 7:54:45.62971 pm) Cuis5.0-3081.image priorSource: 355382! - -----STARTUP----#(25 May 2017 10:01:26.404971 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3081.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3081] on 16 May 2017 at 10:43:45 am'! -!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'jmv 5/16/2017 10:43:40' prior: 16896077! - defaultAction - - | delta textFrame barFrame outerFrame result range width filledWidth f h textWidth textForm innerBarFrame oldFilledWidth oldFilledWidth2 prevContents | - f _ AbstractFont default. - h _ f height * 3//2. - textWidth _ (f widthOfString: progressTitle) + h. - width _ 150 max: textWidth. - - textForm _ Form extent: width@h depth: 32. - textForm fillBlack. - textForm fillWhite: (textForm boundingBox insetBy: 2). - progressTitle displayOn: textForm at: (width-textWidth+h//2@4). - barFrame _ Rectangle center: aPoint extent: width@h. - textFrame _ 0@0 extent: width@h. - textFrame _ textFrame - aligned: textFrame bottomCenter - with: barFrame topCenter + (0@2). - outerFrame _ barFrame merge: textFrame. - delta _ outerFrame amountToTranslateWithin: Display boundingBox. - barFrame _ barFrame translatedBy: delta. - textFrame _ textFrame translatedBy: delta. - outerFrame _ outerFrame translatedBy: delta. - prevContents _ Form fromDisplay: outerFrame. - range _ maxVal = minVal ifTrue: [1] ifFalse: [maxVal - minVal]. "Avoid div by 0" - innerBarFrame _ barFrame insetBy: 2. - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - oldFilledWidth _ 0. - oldFilledWidth2 _ 0. - result _ workBlock value: "Supply the bar-update block for evaluation in the work block" - [ :barVal | - barVal - ifNotNil: [ currentVal _ barVal ] - ifNil: [ - currentVal _ currentVal + 1. - currentVal >= maxVal - ifTrue: [ currentVal _ minVal ]]. - filledWidth _ ((barFrame width-4) asFloat * ((currentVal-minVal) asFloat / range min: 1.0)) asInteger. - filledWidth > oldFilledWidth ifTrue: [ - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - Display fillGray: (barFrame topLeft + (2@2) extent: filledWidth@17). - filledWidth -200 > oldFilledWidth2 - ifFalse: [ - "Usually just request an update, to be done asynchronously." - DisplayScreen screenUpdateRequired: outerFrame ] - ifTrue: [ - "Once in a while, force a real screen update (warning: really slow on MacOS if done too often)" - Display forceToScreen: outerFrame. oldFilledWidth2 _ filledWidth ]. - oldFilledWidth _ filledWidth ]]. - prevContents displayAt: outerFrame topLeft. - self resume: result! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3082-displayProgressAt-slownessOnMacFix-JuanVuletich-2017May16-10h38m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3082] on 24 May 2017 at 12:34:49 am'! -!Collection methodsFor: 'sorting' stamp: 'jmv 5/24/2017 00:28:06'! - sorted - "Return a new sequenceable collection which contains the same elements as self but its elements are sorted " - - ^self sorted: nil! ! -!ClassDescription methodsFor: 'instance variables' stamp: 'jmv 5/24/2017 00:29:04' prior: 16805949! - chooseInstVarAlphabeticallyThenDo: aBlock - | allVars index | - "Put up a menu of all the instance variables in the receiver, presented in alphabetical order, and when the user chooses one, evaluate aBlock with the chosen variable as its parameter." - - allVars _ self allInstVarNames sorted. - allVars isEmpty ifTrue: [^ self inform: 'There are no -instance variables']. - - index _ (PopUpMenu labelArray: allVars lines: #()) startUpWithCaption: 'Instance variables in -', self name. - index = 0 ifTrue: [^ self]. - aBlock value: (allVars at: index)! ! -!ClassDescription methodsFor: 'method dictionary' stamp: 'jmv 5/24/2017 00:28:55' prior: 16807219! - allMethodsInCategory: aSymbol - "Answer a list of all the method categories of the receiver and all its superclasses" - - | aColl | - aColl _ OrderedCollection new. - self withAllSuperclasses do: - [:aClass | aColl addAll: - (aSymbol == ClassOrganizer allCategory - ifTrue: - [aClass organization allMethodSelectors] - ifFalse: - [aClass organization listAtCategoryNamed: aSymbol])]. - ^ aColl asSet sorted - -"TileMorph allMethodsInCategory: #initialization"! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 5/24/2017 00:29:09' prior: 16924088! - browseClassesWithNamesContaining: aString caseSensitive: caseSensitive - "Smalltalk browseClassesWithNamesContaining: 'eMorph' caseSensitive: true " - "Launch a class-list list browser on all classes whose names containg aString as a substring." - - | suffix aList | - suffix _ caseSensitive - ifTrue: [' (case-sensitive)'] - ifFalse: [' (use shift for case-sensitive)']. - aList _ OrderedCollection new. - Smalltalk allClassesDo: [ :class | - (class name includesSubstring: aString caseSensitive: caseSensitive) - ifTrue: [aList add: class name]]. - aList size > 0 - ifTrue: [HierarchyBrowserWindow forClassesNamed: aList asSet sorted title: 'Classes whose names contain ' , aString , suffix]! ! -!ChangeSet methodsFor: 'method changes' stamp: 'jmv 5/24/2017 00:28:50' prior: 16797810! - changedMessageList - "Used by a message set browser to access the list view information." - - | messageList | - messageList _ OrderedCollection new. - changeRecords associationsDo: [ :clAssoc | | classNameInFull classNameInParts | - classNameInFull _ clAssoc key asString. - classNameInParts _ classNameInFull findTokens: ' '. - - (clAssoc value allChangeTypes includes: #comment) ifTrue: [ - messageList add: - (MethodReference new - setClassSymbol: classNameInParts first asSymbol - classIsMeta: false - methodSymbol: #Comment - stringVersion: classNameInFull, ' Comment')]. - - clAssoc value methodChangeTypes associationsDo: [ :mAssoc | - (#(remove addedThenRemoved movedToOtherPackage) includes: mAssoc value) ifFalse: [ - messageList add: - (MethodReference new - setClassSymbol: classNameInParts first asSymbol - classIsMeta: classNameInParts size > 1 - methodSymbol: mAssoc key - stringVersion: classNameInFull, ' ' , mAssoc key)]]]. - ^ messageList sorted! ! - -ArrayedCollection removeSelector: #asSortedArray! - -ArrayedCollection removeSelector: #asSortedArray! - -Collection removeSelector: #asSortedArray! - -Collection removeSelector: #asSortedArray! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3083-remove-asSortedArray-JuanVuletich-2017May24-00h34m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3083] on 25 May 2017 at 8:17:34 pm'! -!Integer methodsFor: 'benchmarks' stamp: 'jmv 5/25/2017 20:10:06' prior: 16859018! - tinyBenchmarks - "Report the results of running the two tiny Squeak benchmarks. - ar 9/10/1999: Adjusted to run at least 1 sec to get more stable results - 0 tinyBenchmarks - 292 MHz G3 Mac: 22,727,272 bytecodes/sec; 984,169 sends/sec - 400 MHz PII/Win98: 18,028,169 bytecodes/sec; 1,081,272 sends/sec - - RasPi2 - StackVM: 37,758,112 bytecodes/sec; 2,412,667 sends/sec - Raspi2- CogSSpur: 157,441,574 bytecodes/sec; 10,946,039 sends/sec - - C.H.I.P. (*1) - StackVM: 55,315,471 bytecodes/sec; 3,348,667 sends/sec - C.H.I.P. (*1) - CogSpur: 253,716,551 bytecodes/sec; 16,853,816 sends/sec - - 1.66GHz Atom N450 - Cog: 244,274,809 bytecodes/sec; 28,795,277 sends/sec - 1.66GHz Atom N450 - CogSpur: 469,724,770 bytecodes/sec; 30,754,699 sends/sec - - 1.33GHz Atom 3735G - Cog: 326,114,649 bytecodes/sec; 34,985,976 sends/sec - 1.33GHz Atom 3735G - CogSpur: 632,098,765 bytecodes/sec; 33,692,910 sends/sec - - 1.5GHz AMD A4-5000 APU - Cog: 390,243,902 bytecodes/sec; 47,507,997 sends/sec - 1.5GHz AMD A4-5000 APU - CogSpur: 675,907,590 bytecodes/sec; 40,669,724 sends/sec - 1.5GHz AMD A4-5000 APU - CogSpur64: 659,368,963 bytecodes/sec; 50,338,916 sends/sec - - 2.3GHz Tegra (*2) - StackVM: 258,847,320 bytecodes/sec; 13,014,759 sends/sec - 2.3GHz Tegra (*2) - CogSpur: 1,083,024,854 bytecodes/sec; 64,289,750 sends/sec - - 3.1GHz Core i3-2100 - Cog: 1,203,290,246 bytecodes/sec; 165,723,327 sends/sec - 3.1GHz Core i3-2100 - CogSpur: 2,042,892,768 bytecodes/sec; 127,837,794 sends/sec - - (*1) C.H.I.P. $9 Computer [Next Thing Co], Allwinner R8 Single-Core ARM Cortex-A8 - 1 GHz - (*2) ACER Chromebook CB5-311 - NVIDIA Tegra K1 Quad-Core ARM Cortex-A15 'r3' - 2.3 GHz - - It is interesting to note that Spur for the first time brings ARM hardware (RasPi and C.H.I.P.) into a 'Morphic is confortable and nice to use' level of performance. - " - | t1 t2 r n1 n2 | - n1 _ 1. - [ - t1 _ Time millisecondsToRun: [n1 benchmark]. - t1 < 1000] - whileTrue:[n1 _ n1 * 2]. "Note: #benchmark's runtime is about O(n)" - - n2 _ 28. - [ - t2 _ Time millisecondsToRun: [r _ n2 benchFib]. - t2 < 1000] - whileTrue:[n2 _ n2 + 1]. - "Note: #benchFib's runtime is about O(k^n), - where k is the golden number = (1 + 5 sqrt) / 2 = 1.618...." - - ^ ((n1 * 500000 * 1000) // t1) printStringWithCommas, ' bytecodes/sec; ', - ((r * 1000) // t2) printStringWithCommas, ' sends/sec'! ! -!SystemDictionary methodsFor: 'system attributes' stamp: 'jmv 5/14/2017 23:20:19' prior: 16925038! - isRunningCogit - "Returns true if we're running on the Cog JIT - (vmParameterAt: 46 is the size of the machine code zone) - Smalltalk isRunningCogit - " - - ^(self vmParameterAt: 46) - ifNotNil: [ :machineCodeZoneSize | machineCodeZoneSize > 0 ] - ifNil: [ false ]! ! -!SystemDictionary methodsFor: 'system attributes' stamp: 'jmv 5/14/2017 23:20:40' prior: 16925049! - isSpur - "Answer true if we are a Spur ObjectMemory. - Spur introduces a new format of header for objects, new format for classes, etc. - Smalltalk isSpur - " - - ^ self compactClassesArray isNil! ! -!SystemDictionary class methodsFor: 'copyright' stamp: 'jmv 5/14/2017 23:13:07' prior: 16925610! - copyright - "The Cuis Smalltalk copyright. - Parts are copyright of many contributors to Squeak and Cuis projects." - - ^ -'Portions of Cuis are: -Copyright (c) Xerox Corp. 1981, 1982. -Copyright (c) Apple Computer, Inc. 1985-1996. -Copyright (c) Contributors to Squeak and Cuis projects. 1997-2017.'! ! - -Utilities class removeSelector: #compileUsingClosures! - -Utilities class removeSelector: #compileUsingClosures! - -Utilities class removeSelector: #decommissionTheAllCategory! - -Utilities class removeSelector: #decommissionTheAllCategory! - -Utilities class removeSelector: #initializeClosures! - -Utilities class removeSelector: #initializeClosures! - -SystemVersion class removeSelector: #currentPluginVersion! - -SystemVersion class removeSelector: #currentPluginVersion! - -SystemVersion class removeSelector: #parseVersionString:! - -SystemVersion class removeSelector: #parseVersionString:! - -SystemVersion class removeSelector: #pluginVersion:newerThan:! - -SystemVersion class removeSelector: #pluginVersion:newerThan:! - -SystemDictionary removeSelector: #fixSourceCodeLineEndings! - -SystemDictionary removeSelector: #fixSourceCodeLineEndings! - -SystemDictionary removeSelector: #makeInternalRelease! - -SystemDictionary removeSelector: #makeInternalRelease! - -SystemDictionary removeSelector: #removeTextCode! - -SystemDictionary removeSelector: #removeTextCode! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3084-Cleanup-JuanVuletich-2017May25-20h08m-jmv.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3083] on 25 May 2017 at 8:23:29 pm'! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3085-Cleanup-JuanVuletich-2017May25-20h17m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3085] on 25 May 2017 at 9:56:27 pm'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 5/25/2017 21:56:04' prior: 50334147! - saveAsNewVersion - "Save the image/changes using the next available version number." - " - Smalltalk saveAsNewVersion - " - | fileName newName changesName systemVersion | - self okayToSave ifFalse: [ ^ self ]. - systemVersion _ SystemVersion current. - fileName _ String streamContents: [ :strm | - strm - nextPutAll: 'Cuis'; - print: systemVersion versionMajor; - nextPut: $.; - print: systemVersion versionMinor; - nextPut: $-; - print: systemVersion highestUpdate. - Smalltalk isSpur - ifTrue: [ - Smalltalk wordSize = 4 ifTrue: [ - strm nextPutAll: '-32' ]] - ifFalse: [ - strm nextPutAll: '-v3' ]]. - newName _ fileName, '.image'. - (DirectoryEntry smalltalkImageDirectory // newName) exists ifTrue: [ - newName _ DirectoryEntry smalltalkImageDirectory - nextNameFor: fileName - extension: 'image' ]. - changesName _ self fullNameForChangesNamed: newName. - "Check to see if there is a .changes file that would cause a problem if we saved a new .image file with the new version number" - changesName asFileEntry exists ifTrue: [ - ^ self inform: -'There is already .changes file of the desired name, -', newName, ' -curiously already present, even though there is -no corresponding .image file. Please remedy -manually and then repeat your request.' ]. - "Try to clear all user state, including all class vars, preferences, etc" - self saveAs: newName andQuit: false clearAllClassState: true! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3086-NewImageFlavorNaming-JuanVuletich-2017May25-21h56m-jmv.1.cs.st----! - -----SNAPSHOT----#(25 May 2017 10:01:33.374113 pm) Cuis5.0-3086-v3.image priorSource: 355472! - -----QUIT----#(25 May 2017 10:01:45.270842 pm) Cuis5.0-3086-v3.image priorSource: 369192! - -----STARTUP----#(14 June 2017 3:48:04.157986 pm) as C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\Cuis5.0-3086-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3086] on 29 May 2017 at 10:56:45 pm'! -!Integer methodsFor: 'benchmarks' stamp: 'jmv 5/29/2017 22:55:50' prior: 50342972! - tinyBenchmarks - "Report the results of running the two tiny Squeak benchmarks. - ar 9/10/1999: Adjusted to run at least 1 sec to get more stable results - 0 tinyBenchmarks - 292 MHz G3 Mac: 22,727,272 bytecodes/sec; 984,169 sends/sec - 400 MHz PII/Win98: 18,028,169 bytecodes/sec; 1,081,272 sends/sec - - RasPi2 - StackVM: 37,758,112 bytecodes/sec; 2,412,667 sends/sec - RasPi2- CogSSpur: 157,441,574 bytecodes/sec; 10,946,039 sends/sec - - C.H.I.P. (*1) - StackVM: 55,315,471 bytecodes/sec; 3,348,667 sends/sec - C.H.I.P. (*1) - CogSpur: 253,716,551 bytecodes/sec; 16,853,816 sends/sec - - RasPi3B - StackSpur 44,107,512 bytecodes/sec; 2,767,863 sends/sec - RasPi3B - CogSpur 281,783,159 bytecodes/sec; 16,404,381 sends/sec - - 1.66GHz Atom N450 - Cog: 244,274,809 bytecodes/sec; 28,795,277 sends/sec - 1.66GHz Atom N450 - CogSpur: 469,724,770 bytecodes/sec; 30,754,699 sends/sec - - 1.33GHz Atom 3735G - Cog: 326,114,649 bytecodes/sec; 34,985,976 sends/sec - 1.33GHz Atom 3735G - CogSpur: 632,098,765 bytecodes/sec; 33,692,910 sends/sec - - 1.5GHz AMD A4-5000 APU - Cog: 390,243,902 bytecodes/sec; 47,507,997 sends/sec - 1.5GHz AMD A4-5000 APU - CogSpur: 675,907,590 bytecodes/sec; 40,669,724 sends/sec - 1.5GHz AMD A4-5000 APU - CogSpur64: 659,368,963 bytecodes/sec; 50,338,916 sends/sec - - 2.3GHz Tegra (*2) - StackVM: 258,847,320 bytecodes/sec; 13,014,759 sends/sec - 2.3GHz Tegra (*2) - CogSpur: 1,083,024,854 bytecodes/sec; 64,289,750 sends/sec - - 3.1GHz Core i3-2100 - Cog: 1,203,290,246 bytecodes/sec; 165,723,327 sends/sec - 3.1GHz Core i3-2100 - CogSpur: 2,042,892,768 bytecodes/sec; 127,837,794 sends/sec - - (*1) C.H.I.P. $9 Computer [Next Thing Co], Allwinner R8 Single-Core ARM Cortex-A8 - 1 GHz - (*2) ACER Chromebook CB5-311 - NVIDIA Tegra K1 Quad-Core ARM Cortex-A15 'r3' - 2.3 GHz - - It is interesting to note that Spur for the first time brings ARM hardware (RasPi and C.H.I.P.) into a 'Morphic is confortable and nice to use' level of performance. - " - | t1 t2 r n1 n2 | - n1 _ 1. - [ - t1 _ Time millisecondsToRun: [n1 benchmark]. - t1 < 1000] - whileTrue:[n1 _ n1 * 2]. "Note: #benchmark's runtime is about O(n)" - - n2 _ 28. - [ - t2 _ Time millisecondsToRun: [r _ n2 benchFib]. - t2 < 1000] - whileTrue:[n2 _ n2 + 1]. - "Note: #benchFib's runtime is about O(k^n), - where k is the golden number = (1 + 5 sqrt) / 2 = 1.618...." - - ^ ((n1 * 500000 * 1000) // t1) printStringWithCommas, ' bytecodes/sec; ', - ((r * 1000) // t2) printStringWithCommas, ' sends/sec'! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3087-RasPi3-tinyBenchmarks-JuanVuletich-2017May29-22h54m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3087] on 30 May 2017 at 2:27:08 pm'! -!Integer methodsFor: 'benchmarks' stamp: 'jmv 5/30/2017 14:24:33' prior: 50343201! - tinyBenchmarks - "Report the results of running the two tiny Squeak benchmarks. - ar 9/10/1999: Adjusted to run at least 1 sec to get more stable results - 0 tinyBenchmarks - 292 MHz G3 Mac: 22,727,272 bytecodes/sec; 984,169 sends/sec - 400 MHz PII/Win98: 18,028,169 bytecodes/sec; 1,081,272 sends/sec - - RasPi2 - StackVM: 37,758,112 bytecodes/sec; 2,412,667 sends/sec - RasPi2- CogSSpur: 157,441,574 bytecodes/sec; 10,946,039 sends/sec - - C.H.I.P. (*1) - StackVM: 55,315,471 bytecodes/sec; 3,348,667 sends/sec - C.H.I.P. (*1) - CogSpur: 253,716,551 bytecodes/sec; 16,853,816 sends/sec - - RasPi3B - StackSpur 44,107,512 bytecodes/sec; 2,767,863 sends/sec - RasPi3B - CogSpur 281,783,159 bytecodes/sec; 16,404,381 sends/sec - - 1.66GHz Atom N450 - Cog: 244,274,809 bytecodes/sec; 28,795,277 sends/sec - 1.66GHz Atom N450 - CogSpur: 469,724,770 bytecodes/sec; 30,754,699 sends/sec - - 1.33GHz Atom 3735G - Cog: 326,114,649 bytecodes/sec; 34,985,976 sends/sec - 1.33GHz Atom 3735G - CogSpur: 632,098,765 bytecodes/sec; 33,692,910 sends/sec - - 1.5GHz AMD A4-5000 APU - Cog: 390,243,902 bytecodes/sec; 47,507,997 sends/sec - 1.5GHz AMD A4-5000 APU - CogSpur: 675,907,590 bytecodes/sec; 40,669,724 sends/sec - 1.5GHz AMD A4-5000 APU - CogSpur64: 659,368,963 bytecodes/sec; 50,338,916 sends/sec - - 2.3GHz Tegra (*2) - StackVM: 258,847,320 bytecodes/sec; 13,014,759 sends/sec - 2.3GHz Tegra (*2) - CogSpur: 1,083,024,854 bytecodes/sec; 64,289,750 sends/sec - - 3.1GHz Core i3-2100 - Cog: 1,203,290,246 bytecodes/sec; 165,723,327 sends/sec - 3.1GHz Core i3-2100 - CogSpur: 2,042,892,768 bytecodes/sec; 127,837,794 sends/sec - - 2.70GHz Core i5-6400 -CogSpur64 3,162,934,362 bytecodes/sec; 243,321,293 sends/sec - - (*1) C.H.I.P. $9 Computer [Next Thing Co], Allwinner R8 Single-Core ARM Cortex-A8 - 1 GHz - (*2) ACER Chromebook CB5-311 - NVIDIA Tegra K1 Quad-Core ARM Cortex-A15 'r3' - 2.3 GHz - - It is interesting to note that Spur for the first time brings ARM hardware (RasPi and C.H.I.P.) into a 'Morphic is confortable and nice to use' level of performance. - " - | t1 t2 r n1 n2 | - n1 _ 1. - [ - t1 _ Time millisecondsToRun: [n1 benchmark]. - t1 < 1000] - whileTrue:[n1 _ n1 * 2]. "Note: #benchmark's runtime is about O(n)" - - n2 _ 28. - [ - t2 _ Time millisecondsToRun: [r _ n2 benchFib]. - t2 < 1000] - whileTrue:[n2 _ n2 + 1]. - "Note: #benchFib's runtime is about O(k^n), - where k is the golden number = (1 + 5 sqrt) / 2 = 1.618...." - - ^ ((n1 * 500000 * 1000) // t1) printStringWithCommas, ' bytecodes/sec; ', - ((r * 1000) // t2) printStringWithCommas, ' sends/sec'! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3088-CoreI5-tinyBenchmarks-JuanVuletich-2017May30-14h24m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3088] on 31 May 2017 at 10:25:43 am'! -!WordArray methodsFor: 'accessing' stamp: 'jmv 5/31/2017 09:48:37'! - bytesAt: index - "Answer a ByteArray of 4 elements. - The 32-bit word is split in 4 bytes, in little endian format - WordArray with: 16rFF32791B :: bytesAt: 1 :: hex - " - - | bytes word | - bytes _ ByteArray new: 4. - word _ self at: index. "Usually a SmallInteger, but may be a Large Integer in 32-bit images" - 1 to: 4 do: [ :i | bytes at: i put: (word digitAt: i) ]. - ^ bytes! ! -!WordArray methodsFor: 'accessing' stamp: 'jmv 5/31/2017 09:53:07'! - bytesAt: index put: aByteArray - "Takes a ByteArray of 4 elements. - Store the 32-bit word made with those byes, in little endian format - WordArray new: 1 :: bytesAt: 1 put: #[16r1B 16r79 16r32 16rFF] :: first hex - " - - | word | - word _ 0. - 4 to: 1 by: -1 do: [ :i | word _ word * 256 + (aByteArray at: i) ]. - self at: index put: word! ! -!Bitmap methodsFor: 'accessing' stamp: 'jmv 5/31/2017 10:16:34'! - bytesAt: index - "Answer a ByteArray of 4 elements. - The 32-bit word is split in 4 bytes, in little endian format - WordArray with: 16rFF32791B :: bytesAt: 1 :: hex - " - - | bytes word | - bytes _ ByteArray new: 4. - word _ self at: index. "Usually a SmallInteger, but may be a Large Integer in 32-bit images" - 1 to: 4 do: [ :i | bytes at: i put: (word digitAt: i) ]. - ^ bytes! ! -!Bitmap methodsFor: 'accessing' stamp: 'jmv 5/31/2017 10:16:38'! - bytesAt: index put: aByteArray - "Takes a ByteArray of 4 elements. - Store the 32-bit word made with those byes, in little endian format - WordArray new: 1 :: bytesAt: 1 put: #[16r1B 16r79 16r32 16rFF] :: first hex - " - - | word | - word _ 0. - 4 to: 1 by: -1 do: [ :i | word _ word * 256 + (aByteArray at: i) ]. - self at: index put: word! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3089-BytesAccessForBitmapAndWordArray-JuanVuletich-2017May31-10h25m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3083] on 28 May 2017 at 8:07:38 pm'! -!TestCase methodsFor: 'Running' stamp: 'HAW 5/28/2017 20:01:43'! - setUpResources - - self resources do: [:res | res isAvailable ifFalse: [^res signalInitializationError]]. -! ! -!TestCase methodsFor: 'Running' stamp: 'HAW 5/28/2017 20:02:07'! - tearDownResources - - self resources do: [:each | each reset]! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 5/28/2017 20:03:22'! - runCaseAsFailure - - self setUpResources. - self setUp. - - self openDebuggerOnFailingTestMethod! ! -!TestSuite methodsFor: 'Running - Private' stamp: 'HAW 5/28/2017 20:04:46'! - setUpResources - - self resources do: [ :res | res isAvailable ifFalse: [^res signalInitializationError]]. - ! ! -!TestSuite methodsFor: 'Running - Private' stamp: 'HAW 5/28/2017 20:05:08'! - tearDownResources - - self resources do: [:each | each reset]! ! -!TestCase methodsFor: 'Running' stamp: 'HAW 5/28/2017 20:01:57' prior: 16927482! - debug - - self setUpResources. - - [(self class selector: testSelector) runCase] ensure: [self tearDownResources] - ! ! -!TestCase methodsFor: 'Running' stamp: 'HAW 5/28/2017 20:06:48' prior: 50340535! - debugAsFailureIfCanNot: handler - - self ifCanNotDebugDo: [ ^handler value]. - - (self class selector: testSelector) runCaseAsFailure! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 5/28/2017 16:11:59' prior: 16927577! - executeShould: aBlock inScopeOf: anExceptonHandlingCondition - - ^self executeShould: aBlock inScopeOf: anExceptonHandlingCondition withExceptionDo: [:anException | ] -! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 5/28/2017 16:12:11' prior: 50339003! - executeShould: aBlock inScopeOf: anExceptonHandlingCondition withExceptionDo: assertionsBlock - - ^[aBlock value. - false] - on: anExceptonHandlingCondition - do: [:exception | - assertionsBlock value: exception. - exception sunitExitWith: true]! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 5/28/2017 20:03:03' prior: 50341191! - openDebuggerOnFailingTestMethod - - | processToDebug context compiledMethod debugger | - - compiledMethod _ self methodForTest. - - processToDebug _ [ [ self performTest ] ensure: [ - self tearDown. - self tearDownResources]] newProcess. - context _ processToDebug suspendedContext. - - debugger _ Debugger new - process: processToDebug - context: context. - debugger openFullNoSuspendLabel: 'Debug failed test ', self printString. - - [debugger interruptedContext method == compiledMethod] whileFalse: [debugger send]. -! ! -!TestSuite methodsFor: 'Running' stamp: 'HAW 5/28/2017 20:04:59' prior: 16928869! - run - - | result | - - result := TestResult new. - self setUpResources. - [self run: result] ensure: [self tearDownResources]. - - ^result - ! ! - -TestCase removeSelector: #openDebuggerOnFailingTestMethod2! - -TestCase removeSelector: #openDebuggerOnFailingTestMethod:! - -TestCase removeSelector: #openDebuggerOnFailingTestMethod:! - -TestCase removeSelector: #runCaseAsFailure:! - -TestCase removeSelector: #runCaseAsFailure:! - -Smalltalk removeClassNamed: #TestCaseDebugger! - -Smalltalk removeClassNamed: #TestCaseDebugger! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3090-SUnitDebugFix-HernanWilkinson-2017May23-19h28m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3083] on 28 May 2017 at 8:55:15 pm'! - -MessageNode removeSelector: #test! - -MessageNode removeSelector: #test! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3091-MessageNode-test-removal-HernanWilkinson-2017May28-20h54m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3083] on 28 May 2017 at 8:56:52 pm'! -!SetInspector methodsFor: 'accessing' stamp: 'HAW 5/28/2017 20:56:40' prior: 16907433! -fieldList - - (object isNil or: [ object array isNil]) ifTrue: [^ Set new]. - - ^ self baseFieldList, (object array withIndexCollect: [:each :i | each ifNotNil: [i printString]]) select: [:each | each notNil]! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3092-SetInspectorFix-HernanWilkinson-2017May28-20h55m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3092] on 2 June 2017 at 11:21:59 am'! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 11:01:27'! - defaultFailDescription - - ^'Test failed'! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 11:02:09'! - fail - - ^self failWith: self defaultFailDescription ! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 11:02:55'! - failWith: aDescription - - self signalFailure: aDescription ! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 10:57:13'! -should: aBlock raise: anExceptonHandlingCondition withExceptionDo: assertionsBlock description: aFailDescription - - ^[aBlock value. - self failWith: aFailDescription ] - on: anExceptonHandlingCondition - do: assertionsBlock ! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 10:58:09' prior: 16927436! - should: aBlock - - self assert: aBlock value - ! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 10:58:16' prior: 16927439! - should: aBlock description: aString - - self assert: aBlock value description: aString - ! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 10:54:56' prior: 16927443! - should: aBlock raise: anExceptonHandlingCondition - - ^self should: aBlock raise: anExceptonHandlingCondition withExceptionDo: [ :anException | ] - ! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 11:00:17' prior: 16927448! - should: aBlock raise: anExceptonHandlingCondition description: aFailDescription - - ^self should: aBlock raise: anExceptonHandlingCondition withExceptionDo: [:anException | ] description: aFailDescription! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 10:57:59' prior: 50338995! -should: aBlock raise: anExceptonHandlingCondition withExceptionDo: assertionsBlock - - ^self should: aBlock raise: anExceptonHandlingCondition withExceptionDo: assertionsBlock description: self defaultFailDescription! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 11:09:25' prior: 16927455! - shouldnt: aBlock - - self deny: aBlock value - ! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 11:09:20' prior: 16927458! - shouldnt: aBlock description: aString - - self deny: aBlock value description: aString - ! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 11:10:31' prior: 16927462! - shouldnt: aBlock raise: anExceptonHandlingCondition - - ^self shouldnt: aBlock raise: anExceptonHandlingCondition description: anExceptonHandlingCondition printString, ' was not expected to be raised'! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 11:06:04' prior: 16927468! - shouldnt: aBlock raise: anExceptonHandlingCondition description: aFailDescription - - ^aBlock - on: anExceptonHandlingCondition - do: [ :anException | self failWith: aFailDescription ] -! ! - -TestCase removeSelector: #executeShould:inScopeOf:! - -TestCase removeSelector: #executeShould:inScopeOf:! - -TestCase removeSelector: #executeShould:inScopeOf:withExceptionDo:! - -TestCase removeSelector: #executeShould:inScopeOf:withExceptionDo:! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3093-TestsDebuggingImprovements-HernanWilkinson-2017Jun02-10h25m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3092] on 2 June 2017 at 4:06:08 pm'! -!Behavior methodsFor: 'user interface' stamp: 'HAW 6/2/2017 16:05:24'! -addTo: aSet referencesTo: aSymbol special: special byte: byte. - - self withAllSuperAndSubclassesDoGently: [ :class | - (class whichSelectorsReferTo: aSymbol special: special byte: byte) - do: [ :sel | aSet add: (MethodReference class: class selector: sel) ]]. - ! ! -!Behavior methodsFor: 'user interface' stamp: 'HAW 6/2/2017 16:05:35' prior: 16784612! - allLocalCallsOn: aSymbol - "Answer a SortedCollection of all the methods that call on aSymbol, anywhere in my class hierarchy." - - | aSet special byte cls | - - aSet _ Set new. - cls _ self theNonMetaClass. - special _ Smalltalk - hasSpecialSelector: aSymbol - ifTrueSetByte: [ :b | byte _ b ]. - - cls addTo: aSet referencesTo: aSymbol special: special byte: byte. - cls class addTo: aSet referencesTo: aSymbol special: special byte: byte. - - ^aSet! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3094-LocalCallsFix-HernanWilkinson-2017Jun02-11h21m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3095] on 7 June 2017 at 10:50:30 am'! -!MessageSetWindow class methodsFor: 'instance creation' stamp: 'jmv 6/7/2017 10:49:13' prior: 16870573! - openMessageList: anArray label: aString - "Create a standard system view for the message set on the list, anArray. - The label of the view is aString." - - ^self open: (MessageSet messageList: anArray) label: aString! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3095-openMessageListlabel-fix-JuanVuletich-2017Jun07-10h47m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3094] on 3 June 2017 at 8:52:25 pm'! - -MessageSetWindow subclass: #TestResultWindow - instanceVariableNames: 'testResult' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Testing'! - -!classDefinition: #TestResultWindow category: #'Tools-Testing'! -MessageSetWindow subclass: #TestResultWindow - instanceVariableNames: 'testResult' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Testing'! -!ProgessiveTestRunner methodsFor: 'show result - private' stamp: 'HAW 6/3/2017 20:40:29'! - openTestResultWindow - - TestResultWindow openFor: testResult - ! ! -!TestCase methodsFor: 'Testing' stamp: 'HAW 6/3/2017 20:26:43'! - isSameAs: aTestCase - - ^self class = aTestCase class and: [ testSelector = aTestCase selector ]! ! -!TestResult methodsFor: 'Accessing' stamp: 'HAW 6/3/2017 20:27:28'! - removeFromDefectsAndAddToPassed: aPassed - - errors - detect: [ :anError | anError isSameAs: aPassed ] - ifFound: [ :anError | errors remove: anError ] - ifNone: [ - failures - detect: [ :aFail | aFail isSameAs: aPassed ] - ifFound: [ :aFail | failures remove: aFail ] - ifNone: [ self error: aPassed printString, ' is not an error nor a failure' ]]. - passed add: aPassed -! ! -!TestResultWindow methodsFor: 'actions' stamp: 'HAW 6/3/2017 20:51:08'! - debug - - model selection ifNotNil: [ :selection | | test | - test := selection actualClass selector: selection selector. - test debug. - testResult removeFromDefectsAndAddToPassed: test. - model removeMessageFromBrowserKeepingLabel. - self setLabel: testResult printString ]! ! -!TestResultWindow methodsFor: 'actions' stamp: 'HAW 6/3/2017 20:51:12'! - runSuite - - | suite | - - suite := TestSuite new. - suite addTests: testResult tests. - self delete. - (ProgessiveTestRunner for: suite) value. - ! ! -!TestResultWindow methodsFor: 'button creation' stamp: 'HAW 6/3/2017 20:51:16'! - createDebugButton - - ^PluggableButtonMorph - model: self - stateGetter: #isMessageSelected - action: #debug - label: 'Debug'. -! ! -!TestResultWindow methodsFor: 'button creation' stamp: 'HAW 6/3/2017 20:51:20'! - createReRunButton - - ^PluggableButtonMorph - model: self - stateGetter: nil - action: #runSuite - label: 'Run Suite'. -! ! -!TestResultWindow methodsFor: 'GUI building' stamp: 'HAW 6/3/2017 20:51:24'! - addButton: button to: row color: buttonColor - - button color: buttonColor. - row addMorph: button proportionalWidth: 10! ! -!TestResultWindow methodsFor: 'GUI building' stamp: 'HAW 6/3/2017 20:51:28'! - addButtonsTo: row color: buttonColor - - self addButton: self createDebugButton to: row color: buttonColor. - self addButton: self createReRunButton to: row color: buttonColor. - ! ! -!TestResultWindow methodsFor: 'GUI building' stamp: 'HAW 6/3/2017 20:51:32'! -buildLowerPanes - - | codeAndButtons | - - codeAndButtons _ LayoutMorph newColumn. - codeAndButtons - addMorph: self buttonsRow fixedHeight: self defaultButtonPaneHeight; - addAdjusterMorph; - addMorph: self buildMorphicCodePane proportionalHeight: 1.0. - - ^codeAndButtons ! ! -!TestResultWindow methodsFor: 'GUI building' stamp: 'HAW 6/3/2017 20:51:36'! - buttonsRow - - | buttonColor row | - - buttonColor := self buttonColor. - row := LayoutMorph newRow. - row doAdoptWidgetsColor. - row color: buttonColor. - - self addButtonsTo: row color: buttonColor. - - ^row - - ! ! -!TestResultWindow methodsFor: 'initialization' stamp: 'HAW 6/3/2017 20:51:40'! - initializeFor: aTestResult - - testResult := aTestResult ! ! -!TestResultWindow methodsFor: 'testing' stamp: 'HAW 6/3/2017 20:51:46'! - isMessageSelected - - ^model selection notNil ! ! -!TestResultWindow class methodsFor: 'instance creation' stamp: 'HAW 6/3/2017 20:50:29'! - methodReferencesOf: tests - - ^tests collect: [:aTest | MethodReference class: aTest class selector: aTest selector]. -! ! -!TestResultWindow class methodsFor: 'instance creation' stamp: 'HAW 6/3/2017 20:50:25'! - openFor: aTestResult - - | window | - - window := self openMessageList: (self methodReferencesOf: aTestResult defects) label: aTestResult printString. - window initializeFor: aTestResult. - - ^window - -! ! -!ProgessiveTestRunner methodsFor: 'show result - private' stamp: 'HAW 6/3/2017 20:40:17' prior: 50338174! - showDeffects - - | defects | - - defects _ testResult defects. - defects size = 1 - ifTrue: [ defects anyOne debug ] - ifFalse: [ self openTestResultWindow]! ! - -TestResult removeSelector: #forDebuggingAndInspection! - -TestResult removeSelector: #forDebuggingAndInspection! - -TestCase removeSelectorIfInBaseSystem: #should:raise:withMessageText:! - -ProgessiveTestRunner removeSelector: #openTestResultForDebuggingAndInspection! - -ProgessiveTestRunner removeSelector: #openTestResultForDebuggingAndInspection! - -Smalltalk removeClassNamed: #TestResultForDebuggingAndInspection! - -Smalltalk removeClassNamed: #TestResultForDebuggingAndInspection! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3096-TestResultWindow-HernanWilkinson-2017May28-21h03m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3094] on 3 June 2017 at 8:55:22 pm'! -!StringMorph methodsFor: 'drawing' stamp: 'HAW 6/3/2017 20:55:08' prior: 16918187! - drawOn: aCanvas - aCanvas - drawString: (contents ifNil: [ '' ]) - at: 0@0 - font: self fontToUse - color: color - ! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3097-StringMorph-fix-HernanWilkinson-2017Jun03-20h52m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3092] on 5 June 2017 at 12:39:46 am'! -!TheWorldMenu methodsFor: 'commands' stamp: 'pb 6/5/2017 00:35:30' prior: 16934691! - splitNewMorphList: list depth: d - | middle c prev next out | - d <= 0 ifTrue: [ ^ Array with: list ]. - middle := list size // 2 + 1. - c := (list at: middle) name first: 3. - prev := middle - 1. - [ - prev > 0 and: [ ((list at: prev) name first: 3) = c ]] whileTrue: [ prev := prev - 1 ]. - next := middle + 1. - [ - next <= list size and: [ ((list at: next) name first: 3) = c ]] whileTrue: [ next := next + 1 ]. - "Choose the better cluster" - middle := middle - prev < (next - middle) - ifTrue: [ prev + 1 ] - ifFalse: [ next ]. - middle = 1 ifTrue: [ middle := next ]. - middle >= list size ifTrue: [ middle := prev + 1 ]. - (middle = 1 or: [ middle >= list size ]) ifTrue: [ ^ Array with: list ]. - out := WriteStream on: Array new. - out nextPutAll: - (self - splitNewMorphList: - (list - copyFrom: 1 - to: middle - 1) - depth: d - 1). - out nextPutAll: - (self - splitNewMorphList: - (list - copyFrom: middle - to: list size) - depth: d - 1). - ^ out contents.! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'pb 6/5/2017 00:38:53' prior: 16934754! - alphabeticalMorphMenu - | list splitLists menu firstChar lastChar subMenu | - list := Morph withAllSubclasses select: [ :m | - m includeInNewMorphMenu ]. - list := list asArray sort: [ :c1 :c2 | - c1 name < c2 name ]. - splitLists := self - splitNewMorphList: list - depth: 4. - menu := MenuMorph new defaultTarget: self. - 1 - to: splitLists size - do: [ :i | - firstChar := i = 1 - ifTrue: [ $A ] - ifFalse: [ - (splitLists at: i) first name first: 3 ]. - lastChar := i = splitLists size - ifTrue: [ $Z ] - ifFalse: [ - (splitLists at: i) last name first: 3 ]. - subMenu := MenuMorph new. - (splitLists at: i) do: [ :cl | - subMenu - add: cl name - target: self - selector: #newMorphOfClass:event: - argument: cl ]. - menu - add: firstChar asString , ' - ' , lastChar asString - subMenu: subMenu ]. - ^ menu.! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3098-MoreGranularAlphaMorphMenu-PhilBellalouna-2017Jun05-00h35m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3086] on 5 June 2017 at 11:53:55 am'! -!CodeProvider methodsFor: 'message list menu' stamp: 'jmv 6/5/2017 11:51:33'! - exploreCompiledMethod - "Open an Explorer on the CompiledMethod itself" - - self selectedMessageName ifNotNil: [ - (self selectedClassOrMetaClass compiledMethodAt: self selectedMessageName) - explore ]! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'jmv 6/5/2017 11:46:27' prior: 50338724! - messageListMenu - "Answer the message-list menu" - "Changed by emm to include menu-item for breakpoints" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addList:#( - ('what to show...' offerWhatToShowMenu) - ('toggle break on entry' toggleBreakOnEntry '' model) - - - ('browse full (b)' browseMethodFull) - ('browse hierarchy (h)' browseHierarchy) - ('browse method (O)' openSingleMessageBrowser) - ('browse protocol (p)' browseFullProtocol) - - - ('fileOut' fileOutMessage '' model) - ('explore CompiledMethod' exploreCompiledMethod '' model) - - - ('senders of... (n)' browseSendersOfMessages) - ('implementors of... (m)' browseMessages) - ('inheritance (i)' methodHierarchy) - ('versions (v)' browseVersions) - - - ('inst var refs...' browseInstVarRefs) - ('inst var defs...' browseInstVarDefs) - ('class var refs...' browseClassVarRefs) - ('class variables' browseClassVariables) - ('class refs (N)' browseClassRefs) - - - ('remove method (x)' removeMessage '' model) - ('Run test (t)' runMethodTest '' model) - ('Debug test (r)' debugMethodTest '' model) - - - ('more...' openShiftedMessageListMenu)). - ^ aMenu -! ! -!Theme methodsFor: 'menus' stamp: 'jmv 6/5/2017 11:46:34' prior: 16935967! - basicIcons - - "Minimal menu scheme. - Theme current class beCurrent - " - - ^ { - #('open...') -> #openIcon. - #('windows...' 'find window' 'Focus follows mouse' 'Click to focus') -> #windowIcon. - #('help...' 'explain' 'about this system...' 'Terse Guide to Cuis' 'Class Comment Browser' 'Code management in Cuis' 'Using GitHub to host Cuis packages' ) -> #helpIcon. - #('themes...') -> #appearanceIcon. - #('do it (d)') -> #doItIcon. - #('new morph...' 'objects (o)' 'save world as morph file') -> #morphsIcon. - #('save' ) -> #saveIcon. - #('Save options...' 'save as...' 'change category...' 'rename change set (r)' 'rename') -> #saveAsIcon. - #('save as new version') -> #saveAsNewVersionIcon. - #('quit') -> #quitIcon. - #('save and quit' ) -> #saveAndQuitIcon. - #('inspect it (i)' 'inspect world' 'inspect model' 'inspect morph' - 'inspect owner chain' 'inspect' 'inspect (i)' 'basic inspect' 'message names' 'find message names' 'inspect instances' 'inspect subinstances' 'inspect change set' 'inspect context (c)' 'inspect receiver (i)' 'start CPUWatcher' 'stop CPUWatcher') - -> #inspectIcon. - #('explore' 'explore it (I)' 'explore world' 'explore morph' 'explore (I)' 'explore context (C)' 'explore receiver (I)' 'references finder' 'weight explorer' 'explore CompiledMethod') -> #exploreIcon. - #('find...(f)' 'find class... (f)' 'find method...' 'find recent submissions' 'show hierarchy' 'show definition' 'show comment' 'filter' 'filter message list...' 'find context... (f)') -> #findIcon. - #('add item...' 'new category...' 'create new change set...' 'new change set... (n)' 'add new file') -> #newIcon. - #('remove method (x)' 'remove' 'remove class (x)' 'remove method from system (x)' 'remove class from system (x)' 'remove postscript') -> #deleteIcon. - #('delete method from changeset (d)' 'delete class from change set (d)' 'destroy change set (X)' 'revert & remove from changes' 'delete unchanged windows' 'delete non windows' 'delete both of the above' 'reset variables' 'remove contained in class categories...' 'clear this change set' 'uninstall this change set' 'delete directory...' 'delete') -> #warningIcon. - #('do again (j)' 'Redo - multiple (Z)') -> #redoIcon. - #('undo (z)' 'revert to previous version' 'Undo - multiple (z)') -> #undoIcon. - #('copy (c)' 'copy class...' 'copy class chgs to other side' 'copy method to other side' 'copy all to other side (c)' 'copy name to clipboard' 'copy selector to clipboard') -> #copyIcon. - #('paste (v)' 'Paste without Format') -> #pasteIcon. - #('cut (x)' 'move class chgs to other side' 'move method to other side' 'submerge into other side') -> #cutIcon. - #('paste...' 'icons...') -> #worldIcon. -}! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - - Theme current class beCurrent! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3099-exploreCompiledMethod-menuOption-JuanVuletich-2017Jun05-11h19m-jmv.1.cs.st----! - -----SNAPSHOT----#(14 June 2017 3:48:14.039986 pm) Cuis5.0-3099-v3.image priorSource: 369286! - -----QUIT----#(14 June 2017 3:48:31.144986 pm) Cuis5.0-3099-v3.image priorSource: 400261! - -----STARTUP----#(20 June 2017 5:57:20.091895 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3099-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3099] on 9 June 2017 at 12:14:01 am'! -!RectangleLikeMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:47:05'! - categoryInNewMorphMenu - ^ 'Kernel'! ! -!PasteUpMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:51:39'! - categoryInNewMorphMenu - ^ 'Worlds'! ! -!EllipseMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:50:14'! - categoryInNewMorphMenu - ^ 'Basic'! ! -!ProgressBarMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/9/2017 00:05:22'! - categoryInNewMorphMenu - ^ 'Widgets'! ! -!ImageMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:54:09'! - categoryInNewMorphMenu - ^ 'Basic'! ! -!StringMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:55:41'! - categoryInNewMorphMenu - ^ 'Basic'! ! -!UpdatingStringMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/9/2017 00:04:50'! - categoryInNewMorphMenu - ^ 'Widgets'! ! -!LayoutMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:48:35'! - categoryInNewMorphMenu - ^ 'Layouts'! ! -!ProgressMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/9/2017 00:10:17'! - categoryInNewMorphMenu - ^ 'Widgets'! ! -!HaloHandleMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:53:34'! - categoryInNewMorphMenu - ^ 'Halos'! ! -!HaloMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:53:26'! - categoryInNewMorphMenu - ^ 'Halos'! ! -!ResizeMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:56:28'! - categoryInNewMorphMenu - ^ 'Views'! ! -!FillInTheBlankMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:52:51'! - categoryInNewMorphMenu - ^ 'Widgets'! ! -!HoverHelpMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:54:39'! - categoryInNewMorphMenu - ^ 'Widgets'! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'pb 6/9/2017 00:11:33' prior: 50332703! - newMorph - "The user requested 'new morph' from the world menu. Put up a menu that allows many ways of obtaining new morphs. If the preference #classicNewMorphMenu is true, the full form of yore is used; otherwise, a much shortened form is used." - | menu subMenu catDict | - menu _ self menu: 'Add a new morph'. - menu - - add: 'From Clipboard' - target: myHand - action: #pasteMorph; - - add: 'From Alphabetical List' - subMenu: self alphabeticalMorphMenu. - menu addLine. - "Add 'Classic' New Morph menu" - catDict _ Dictionary new. - - Morph allSubclassesDo: [ :eaSubclass | - eaSubclass includeInNewMorphMenu ifTrue: [ | category | - (eaSubclass respondsTo: #categoryInNewMorphMenu) - ifTrue: [ category _ eaSubclass categoryInNewMorphMenu ] - ifFalse: [ category _ 'Unknown' ]. - (catDict includesKey: category) - ifTrue: [ (catDict at: category) add: eaSubclass ] - ifFalse: [ - catDict - at: category - put: (OrderedCollection with: eaSubclass) ]]]. - catDict keys sort do: [ :categ | - subMenu _ MenuMorph new. - ((catDict at: categ) asArray sort: [ :c1 :c2 | - c1 name < c2 name ]) do: [ :cl | - subMenu - add: cl name - target: self - selector: #newMorphOfClass:event: - argument: cl ]. - menu - add: categ - subMenu: subMenu ]. - self doPopUp: menu.! ! - -TheWorldMenu removeSelector: #newMorphOld! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3100-DynamicMorphMenuCategories-PhilBellalouna-2017Jun08-23h33m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3099] on 11 June 2017 at 8:11:06 pm'! -!TestCase class methodsFor: 'Testing' stamp: 'pb 6/11/2017 20:10:43' prior: 16927725! - isAbstract - "Override to true if a TestCase subclass is Abstract and should not have - TestCase instances built from it" - ^ thisContext methodClass == self class.! ! -!TestResource class methodsFor: 'Testing' stamp: 'pb 6/11/2017 20:10:52' prior: 16927869! - isAbstract - "Override to true if a TestResource subclass is Abstract and should not have - TestCase instances built from it" - ^ thisContext methodClass == self class.! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3101-isAbstract-PhilBellalouna-2017Jun11-20h10m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3099] on 9 June 2017 at 1:04:48 am'! -!Preferences class methodsFor: 'halos' stamp: 'pb 6/9/2017 00:46:36' prior: 16893159! -iconicHaloSpecifications - "Answer an array that characterizes the locations, colors, icons, and selectors of the halo handles that may be used in the iconic halo scheme" - - " - Preferences resetHaloSpecifications - " - -^ #( - "selector horiz vert color info icon key balloon help - --------- ------ ----------- ------------------------------- ---------------" - (addCollapseHandle: left topCenter (tan) haloCollapseIcon 'Collapse') - (addDebugHandle: right topCenter (orange) haloDebugIcon 'Debug') - (addDismissHandle: left top (red) haloDismissIcon 'Remove') - "FIXME - Currently non-functional... - (addRotateHandle: left bottom (blue) haloRotateIcon 'Rotate') - " - (addMenuHandle: leftCenter top (blue lighter) haloMenuIcon 'Menu') - (addGrabHandle: center top (black) haloGrabIcon 'Pick up') - (addDragHandle: rightCenter top (brown) haloDragIcon 'Move') - (addDupHandle: right top (green) haloDuplicateIcon 'Duplicate') - (addHelpHandle: center bottom (lightBlue) haloHelpIcon 'Help') - (addGrowHandle: right bottom (yellow) haloScaleIcon 'Change size') - (addFontSizeHandle: leftCenter bottom (lightGreen) haloFontSizeIcon 'Change font') - (addFontEmphHandle: rightCenter bottom (lightBrown darker) haloFontEmphasisIcon 'Emphasis & alignment') - "FIXME - Currently non-functional... - (addRecolorHandle: right bottomCenter (magenta darker) haloColorIcon 'Change color') - " -)! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'pb 6/9/2017 00:52:09' prior: 16875868! - wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph - "Answer whether the receiver would like to offer the halo handle with the given selector (e.g. #addCollapseHandle:)" - - (#(addRotateHandle: addRecolorHandle:) statePointsTo: aSelector) - ifTrue: ["FIXME - hack to disable for non-functional halo items" - ^ false]. - - Preferences selectiveHalos ifFalse: [ - ^true ]. - - (#(#addDismissHandle: ) includes: aSelector) - ifTrue: [ ^ self resistsRemoval not ]. - (#(#addDragHandle: ) includes: aSelector) - ifTrue: [ ^ self okayToBrownDragEasily ]. - (#(#addGrowHandle: ) includes: aSelector) - ifTrue: [ ^ self okayToResizeEasily ]. - (#(#addRotateHandle: ) includes: aSelector) - ifTrue: [ ^ self okayToRotateEasily ]. - (#(#addRecolorHandle: ) includes: aSelector) - ifTrue: [ ^ self wantsRecolorHandle ]. - ^ true! ! -!PasteUpMorph methodsFor: 'halos and balloon help' stamp: 'pb 6/9/2017 00:51:44' prior: 16887852! - wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph - "Answer whether the receiver would like to offer the halo handle with the given selector (e.g. #addCollapseHandle:)" - (#(addHelpHandle: addRotateHandle: addRecolorHandle:) statePointsTo: aSelector) - ifTrue: ["FIXME - hack to disable for non-functional halo items" - ^ false]. - - self isWorldMorph ifFalse: [ - ^super wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph ]. - - ^#(addDebugHandle: addMenuHandle: addHelpHandle:) - statePointsTo: aSelector! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3102-Disable-Nonfunctional-Halos-PhilBellalouna-2017Jun09-00h45m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3099] on 10 June 2017 at 1:39:18 am'! -!Array methodsFor: 'printing' stamp: 'pb 6/10/2017 01:39:04' prior: 16779829! - isLiteral - "Definition from Squeak" - ^ self class == Array and: [ - self allSatisfy: [ :each | - each isLiteral ]].! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3103-Array-isLiteral-compatibility-with-Squeak-PhilBellalouna-2017Jun10-01h39m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3103] on 19 June 2017 at 11:46:49 am'! -!ChangeList methodsFor: 'menu actions' stamp: 'jmv 6/19/2017 11:45:52'! - fileOutCurrentVersionsOfSelections - - (FillInTheBlankMorph - request: 'Enter file name' - initialAnswer: 'Filename.st' - onCancel: [^nil]) - - asFileEntry writeStreamDo: [ :stream | - stream timeStamp. - self currentVersionsOfSelections do: [ :methodRef | - methodRef actualClass - printMethodChunk: methodRef methodSymbol - withPreamble: true - on: stream - moveSource: false - toFile: 0 ]]! ! -!ChangeListWindow methodsFor: 'menu building' stamp: 'jmv 6/19/2017 11:39:03' prior: 16797171! - listMenu - "Fill aMenu up so that it comprises the primary changelist-browser menu" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'change list'. - aMenu addStayUpIcons. - aMenu addList: #( - ('fileIn selections' fileInSelections - 'import the selected items into the image' model) - ('fileOut selections... ' fileOutSelections - 'create a new file containing the selected items' model) - ('fileOut current version of selections...' fileOutCurrentVersionsOfSelections - 'create a new file containing the current (in-image) counterparts of the selected methods' model) - - - ('compare to current' compareToCurrentVersion - 'open a separate window which shows the text differences between the on-file version and the in-image version.' model) - ('toggle diffing (D)' toggleDiffing - 'start or stop showing diffs in the code pane.' model) - - - ('select new methods' selectNewMethods - 'select methods in the file that do not currently exist in the image' model) - ('select changes for absent classes' selectAllForAbsentClasses - 'select methods in the file for classes that are not defined in the image' model) - ('select all changes for this class' selectAllForThisClass - 'select all methods in the file that belong to the currently-selected class' model) - ('select unchanged methods' selectUnchangedMethods - 'select methods in the file whose in-image versions are the same as their in-file counterparts' model) - ('select methods equivalent to current' selectEquivalentMethods - 'select methods in the file whose in-image versions have the same behavior as their in-file counterparts' model) - ('select methods older than current' selectMethodsOlderThanCurrent - 'select methods in the file that are older than the one currently in the image' model) - ('select removals of sent methods' selectRemovalsOfSent - 'select all method removals of methods that have some sender in the image' model) - - - ('select all (a)' selectAll - 'select all the items in the list' model) - ('deselect all' deselectAll - 'deselect all the items in the list' model) - ('invert selections' invertSelections - 'select every item that is not currently selected, and deselect every item that *is* currently selected' model) - - - ('browse class and method' browseMethodFull - 'open a full browser showing the selected method') - ('browse all versions of single selection' browseVersions - 'open a version browser showing the versions of the currently selected method') - ('browse current versions of selections' browseCurrentVersionsOfSelections - 'open a message-list browser showing the current (in-image) counterparts of the selected methods') - ('destroy current methods of selections' destroyCurrentCodeOfSelections - 'remove (*destroy*) the in-image counterparts of all selected methods' model) - - - ('remove doIts' removeDoIts - 'remove all items that are doIts rather than definitions' model) - ('remove older versions' removeOlderMethodVersions - 'remove all but the most recent versions of methods in the list' model) - ('remove up-to-date versions' removeUpToDate - 'remove all items whose code is the same as the counterpart in-image code' model) - ('remove empty class comments' removeEmptyClassComments - 'remove all empty class comments' model) - ('remove selected items' removeSelections - 'remove the selected items from the change-list' model) - ('remove unselected items' removeNonSelections - 'remove all the items not currently selected from the change-list' model)). - ^ aMenu! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3104-fileOutCurrentVersions-JuanVuletich-2017Jun19-11h26m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3103] on 19 June 2017 at 11:07:11 am'! - -FloatArray variableWordSubclass: #Colour - instanceVariableNames: '' - classVariableNames: 'CachedColormaps ColorNamesDict FromGrayColormaps GrayToIndexMap IndexedColors MaskingMap ToGrayColormaps' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -!classDefinition: #Colour category: #'Graphics-Primitives'! -FloatArray variableWordSubclass: #Colour - instanceVariableNames: '' - classVariableNames: 'CachedColormaps ColorNamesDict FromGrayColormaps GrayToIndexMap IndexedColors MaskingMap ToGrayColormaps' - poolDictionaries: '' - category: 'Graphics-Primitives'! -!Colour commentStamp: 'jmv 6/18/2017 20:14:31' prior: 0! - This class represents abstract color, regardless of the depth of bitmap it will be shown in. At the very last moment a Color is converted to a pixelValue that depends on the depth of the actual Bitmap inside the Form it will be used with. The supported depths (in bits) are 1, 2, 4, 8, 16, and 32. The number of actual colors at these depths are: 2, 4, 16, 256, 32768, and 16 million. (See comment in BitBlt.) To change the depth of the Display and set how many colors you can see, execute: (Display newDepth: 8). (See comment in DisplayMedium) - Color is represented as the amount of light in red, green, and blue. White is (1.0, 1.0, 1.0) and black is (0, 0, 0). Pure red is (1.0, 0, 0). These colors are "additive". Think of Color's instance variables as: - r amount of red, a Float between 0.0 and 1.0. - g amount of green, a Float between 0.0 and 1.0. - b amount of blue, a Float between 0.0 and 1.0. - Many colors are named. You find a color by name by sending a message to class Color, for example (Color lightBlue). Also, (Color red: 0.2 green: 0.6 blue: 1.0) or (Color r: 0.2 g: 0.6 b: 1.0) creates a color. (see below) - A color is essentially immutable. Once you set red, green, and blue, you cannot change them. Instead, create a new Color and use it. - Applications such as contour maps and bar graphs will want to display one of a set of shades based on a number. Convert the range of this number to an integer from 1 to N. Then call (Color green lightShades: N) to get an Array of colors from white to green. Use the Array messages at:, atPin:, or atWrap: to pull out the correct color from the array. atPin: gives the first (or last) color if the index is out of range. atWrap: wraps around to the other end if the index is out of range. - Here are some fun things to run in when your screen has color: - Pen new mandala: 30 diameter: Display height-100. - Pen new web "Draw with the mouse, opt-click to end" - Display fillWhite. Pen new hilberts: 5. - Form toothpaste: 30 "Draw with mouse, opt-click to end" - -Messages: - mixed: proportion with: aColor Answer this color mixed with the given color additively. The proportion, a number between 0.0 and 1.0, determines what what fraction of the receiver to use in the mix. - - + add two colors - - subtract two colors - * multiply the values of r, g, b by a number or an Array of factors. ((Color named: #white) * 0.3) gives a darkish gray. (aColor * #(0 0 0.9)) gives a color with slightly less blue. - / divide a color by a factor or an array of three factors. - - hue Returns the hue of the color. On a wheel from 0 to 360 with pure red at 0 and again at 360. - saturation Returns the saturation of the color. 0.0 to 1.0 - brightness Returns the brightness of the color. 0.0 to 1.0 - - name Look to see if this Color has a name. - display Show a swatch of this color tracking the cursor. - - lightShades: thisMany An array of thisMany colors from white to the receiver. - darkShades: thisMany An array of thisMany colors from black to the receiver. Array is of length num. - mix: color2 shades: thisMany An array of thisMany colors from the receiver to color2. - wheel: thisMany An array of thisMany colors around the color wheel starting and ending at the receiver. - - pixelValueForDepth: d Returns the bits that appear be in a Bitmap of this depth for this color. Represents the nearest available color at this depth. Normal users do not need to know which pixelValue is used for which color. - -Messages to Class Color. - red: r green: g blue: b Return a color with the given r, g, and b components. - r: g: b: Same as above, for fast typing. - - hue: h saturation: s brightness: b Create a color with the given hue, saturation, and brightness. - - pink - blue - red ... Many colors have messages that return an instance of Color. - canUnderstand: #brown Returns true if #brown is a defined color. - names An OrderedCollection of the names of the colors. - named: #notAllThatGray put: aColor Add a new color to the list and create an access message and a class variable for it. - fromUser Shows the palette of colors available at this display depth. Click anywhere to return the color you clicked on. - - hotColdShades: thisMany An array of thisMany colors showing temperature from blue to red to white hot. - - stdColorsForDepth: d An Array of colors available at this depth. For 16 bit and 32 bits, returns a ColorGenerator. It responds to at: with a Color for that index, simulating a very big Array. - - colorFromPixelValue: value depth: d Returns a Color whose bit pattern (inside a Bitmap) at this depth is the number specified. Normal users do not need to use this. - -(See also comments in these classes: Form, Bitmap, BitBlt) - -Default colorSpace is #sRGB. Subclasses might use other color spaces! - -Colour variableWordSubclass: #TranslucentColour - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -!classDefinition: #TranslucentColour category: #'Graphics-Primitives'! -Colour variableWordSubclass: #TranslucentColour - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Primitives'! -!TranslucentColour commentStamp: '' prior: 0! - A TranslucentColor behaves just like a normal color, except that it will pack its alpha value into the fourth position. This allows creating forms with translucency for use with the alpha blend function of BitBlt. An alpha of zero is transparent, and 1.0 is opaque.! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:10:00'! - alpha - "Return the opacity ('alpha') value of opaque so that normal colors can be compared to TranslucentColors." - - ^ 1.0 -! ! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:35:34'! - blue - "Return the blue component of this color, a float in the range [0.0..1.0]." - - ^ self at: 3! ! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:33:10'! - brightness - "Return the brightness of this color, a float in the range [0.0..1.0]. - Color red brightness - " - - "Do not include alpha if TranslucentColour" - ^ (self red max: self green) max: self blue! ! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:34:30'! - chroma - "Return the chroma of this color, a value between 0.0 and 1.0, somewhat related to saturation. - See http://en.wikipedia.org/wiki/HSL_and_HSV - Color red chroma - Color gray chroma - " - - | r g b max min | - r _ self red. - g _ self green. - b _ self blue. - max _ (r max: g) max: b. - min _ (r min: g) min: b. - ^max - min! ! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:35:28'! - green - "Return the green component of this color, a float in the range [0.0..1.0]." - - ^ self at: 2! ! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:31:54'! - hue - "Return the hue of this color, an angle in the range [0.0..360.0]. - Color orange hue - " - - | r g b max min span h | - r _ self red. - g _ self green. - b _ self blue. - max _ (r max: g) max: b. - min _ (r min: g) min: b. - span _ (max - min) asFloat. - span = 0.0 ifTrue: [ ^ 0.0 ]. - - r = max ifTrue: [ - h _ ((g - b) asFloat / span) * 60.0. - ] ifFalse: [ - g = max - ifTrue: [ h _ 120.0 + (((b - r) asFloat / span) * 60.0). ] - ifFalse: [ h _ 240.0 + (((r - g) asFloat / span) * 60.0). ]. - ]. - - ^h mod: 360.0! ! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:10:00'! - icon - "Answer a swatch to display in a menu or browser" - ^self swatch! ! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:10:00'! - iconOrThumbnailOfSize: aNumberOrPoint - "Answer an appropiate form to represent the receiver" - | form | - form := Form extent: aNumberOrPoint asPoint asPoint depth: 32. - form fillColor: self. - ^ form! ! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:10:00'! - luminance - "Return the luminance of this color, a brightness value weighted by the human eye's color sensitivity." - - ^ ((299 * self red) + - (587 * self green) + - (114 * self blue)) / 1000! ! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:35:25'! - red - "Return the red component of this color, a float in the range [0.0..1.0]." - - ^ self at: 1! ! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:34:08'! -saturation - "Return the saturation of this color, a value between 0.0 and 1.0. - Color red saturation - Color gray saturation - " - - | r g b max min | - r _ self red. - g _ self green. - b _ self blue. - max _ (r max: g) max: b. - min _ (r min: g) min: b. - max = 0.0 ifTrue: [ ^0.0 ]. - ^max - min / max! ! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:10:00'! - swatch - "Answer a swatch to display in a menu or browser" - ^self iconOrThumbnailOfSize: 16! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:00'! - asNontranslucentColor - ^ self! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:20:07'! - bitPatternForDepth: depth - "Return a Bitmap, that best represents this color at the given depth. BitBlt calls this method to convert colors into Bitmaps." - "See also: pixelValueForDepth: -- value for single pixel - pixelWordForDepth: -- a 32-bit word filled with the pixel value" - - ^ Bitmap with: (self pixelWordForDepth: depth)! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:00'! - bitPatternForGrayForm - "Return a Bitmap, that best represents this color at the given depth. BitBlt calls this method to convert colors into Bitmaps." - "See also: pixelValueForDepth: -- value for single pixel - pixelWordForDepth: -- a 32-bit word filled with the pixel value" - "Details: The pattern for the most recently requested depth is cached." - - ^Bitmap with: (self pixelWordFor: 8 filledWith: (self luminance * 255) rounded)! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:00'! - closestPixelValue1 - "Return the nearest approximation to this color for a monochrome Form." - - "fast special cases" - self isBlack ifTrue: [^ 1]. "black" - self isWhite ifTrue: [^ 0]. "white" - - self luminance > 0.5 - ifTrue: [^ 0] "white" - ifFalse: [^ 1]. "black"! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:00'! - closestPixelValue2 - "Return the nearest approximation to this color for a 2-bit deep Form." - - | lum | - "fast special cases" - self isBlack ifTrue: [^ 1]. "black" - self isWhite ifTrue: [^ 2]. "opaque white" - - lum _ self luminance. - lum < 0.2 ifTrue: [^ 1]. "black" - lum > 0.6 ifTrue: [^ 2]. "opaque white" - ^ 3 "50% gray" -! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:00'! - closestPixelValue4 - "Return the nearest approximation to this color for a 4-bit deep Form." - - | bIndex | - "fast special cases" - self isBlack ifTrue: [^ 1]. "black" - self isWhite ifTrue: [^ 2]. "opaque white" - - self isRed ifTrue: [^ 4]. - self isGreen ifTrue: [^ 5]. - self isBlue ifTrue: [^ 6]. - self isCyan ifTrue: [^ 7]. - self isYellow ifTrue: [^ 8]. - self isMagenta ifTrue: [^ 9]. - - bIndex _ (self luminance * 8.0) rounded. "bIndex in [0..8]" - ^ #( - 1 "black" - 10 "1/8 gray" - 11 "2/8 gray" - 12 "3/8 gray" - 3 "4/8 gray" - 13 "5/8 gray" - 14 "6/8 gray" - 15 "7/8 gray" - 2 "opaque white" - ) at: bIndex + 1. -! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:00'! - closestPixelValue8 - "Return the nearest approximation to this color for an 8-bit deep Form." - - "fast special cases" - self isBlack ifTrue: [^ 1]. "black" - self isWhite ifTrue: [^ 255]. "white" - - ^self saturation < 0.2 - ifTrue: [ - ^ self class grayToIndexMap at:(self green * 255) rounded + 1. "nearest gray" - ] - ifFalse: [ - "compute nearest entry in the color cube" - 40 + - ((self red * 5) rounded * 36) + - ((self blue * 5) rounded * 6) + - (self green * 5) rounded ]! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:00'! - dominantColor - ^ self! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:00'! - indexInMap: aColorMap - "Return the index corresponding to this color in the given color map. RGB colors are truncated to 3-, 4-, or 5-bits per color component when indexing into such a colorMap. " - - aColorMap size = 2 ifTrue: [^ (self pixelValueForDepth: 1) + 1]. - aColorMap size = 4 ifTrue: [^ (self pixelValueForDepth: 2) + 1]. - aColorMap size = 16 ifTrue: [^ (self pixelValueForDepth: 4) + 1]. - aColorMap size = 256 ifTrue: [^ (self pixelValueForDepth: 8) + 1]. - aColorMap size = 512 ifTrue: [^ (self pixelValueForDepth: 9) + 1]. - aColorMap size = 4096 ifTrue: [^ (self pixelValueForDepth: 12) + 1]. - aColorMap size = 32768 ifTrue: [^ (self pixelValueForDepth: 15) + 1]. - self error: 'unknown pixel depth'. -! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:51:40'! - makeForegroundColor - "Make a foreground color contrasting with me" - ^self luminance >= 0.5 - ifTrue: [Colour black] - ifFalse: [Colour white]! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:00'! - pixelValueForDepth: d - "Returns an integer representing the bits that appear in a single pixel of this color in a Form of the given depth. The depth must be one of 1, 2, 4, 8, 16, or 32. Contrast with pixelWordForDepth: and bitPatternForDepth:, which return either a 32-bit word packed with the given pixel value or a multiple-word Bitmap containing a pattern. The inverse is the class message colorFromPixelValue:depth:" - "Details: For depths of 8 or less, the result is a colorMap index. For depths of 16 and 32, it is a direct color value with 5 or 8 bits per color component." - "Transparency: The pixel value zero is reserved for transparent. For depths greater than 8 and less than 32 (no Indexed colors, no real alpha), black maps to the darkest possible blue. - Note that - Color transparent class = TranslucentColor - this special case is handled in TranslucentColor >> #pixelValueForDepth: - " - - | bitBltFakeBlack val | - d = 8 ifTrue: [^ self closestPixelValue8]. "common case" - d < 8 ifTrue: [ - d = 4 ifTrue: [^ self closestPixelValue4]. - d = 2 ifTrue: [^ self closestPixelValue2]. - d = 1 ifTrue: [^ self closestPixelValue1]]. - - d = 32 ifTrue: [ - "eight bits per component; top 8 bits set to all ones (opaque alpha)" - val _ LargePositiveInteger new: 4. - val at: 3 put: (self red * 255) rounded. - val at: 2 put: (self green * 255) rounded. - val at: 1 put: (self blue * 255) rounded. - val at: 4 put: 16rFF. "opaque alpha" - ^ val normalize]. - - "For the depth 16, pixelValue = 0 means transparent, black is represented as 16r8000 (rgb=0, pixelvalue !!= 0)." - (d = 16) | (d = 15) ifTrue: [ - "five bits per component; top bits ignored" - val _ ((self red * 31) rounded bitShift: 10) bitOr: - (((self green * 31) rounded bitShift: 5) bitOr: - ((self blue * 31) rounded)). - ^ val = 0 - ifTrue: [d = 16 ifTrue: [16r8000] ifFalse: [1]] - ifFalse: [val]]. - - "For the rest of the depths, pixelValue = 0 means transparent, and darkest blue is considered to be black." - bitBltFakeBlack := 1. "closest black that is not transparent in RGB - Not for depths <=8 (Indexed) or = 32 (RGBA)" - d = 12 ifTrue: [ "for indexing a color map with 4 bits per color component" - val _ ((self red * 15) rounded bitShift: 8) bitOr: - (((self green * 15) rounded bitShift: 4) bitOr: - ((self blue * 15) rounded)). - ^ val = 0 ifTrue: [bitBltFakeBlack] ifFalse: [val]]. - - d = 9 ifTrue: [ "for indexing a color map with 3 bits per color component" - val _ ((self red * 7) rounded bitShift: 6) bitOr: - (((self green * 7) rounded bitShift: 3) bitOr: - ((self blue * 7) rounded)). - ^ val = 0 ifTrue: [bitBltFakeBlack] ifFalse: [val]]. - - self error: 'unknown pixel depth: ', d printString! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:00'! - pixelWordFor: depth filledWith: pixelValue - "Return to a 32-bit word that concatenates enough copies of the given pixel value to fill the word (i.e., 32/depth copies). Depth should be one of 1, 2, 4, 8, 16, or 32. The pixel value should be an integer in 0..2^depth-1." - | halfword | - depth = 32 ifTrue: [^ pixelValue]. - depth = 16 - ifTrue: [halfword _ pixelValue] - ifFalse: [halfword _ pixelValue * - (#(16rFFFF "replicates at every bit" - 16r5555 - "replicates every 2 bits" - 16r1111 - - - "replicates every 4 bits" - 16r0101) at: depth) "replicates every 8 bits"]. - ^ halfword bitOr: (halfword bitShift: 16)! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:00'! - pixelWordForDepth: depth - "Return to a 32-bit word that concatenates enough copies of the receiver's pixel value to fill the word (i.e., 32/depth copies). Depth should be one of 1, 2, 4, 8, 16, or 32. The pixel value should be an integer in 0..2^depth-1." - - | pixelValue | - pixelValue _ self pixelValueForDepth: depth. - ^ self pixelWordFor: depth filledWith: pixelValue -! ! -!Colour methodsFor: 'equality' stamp: 'jmv 6/18/2017 20:38:11'! - diff: theOther - "Returns a number between 0.0 and 1.0. - Color gray diff: Color red - " - ^(self - theOther ) abs sum / self size! ! -!Colour methodsFor: 'equality' stamp: 'jmv 6/18/2017 20:10:00'! - rgbDistance: otherColor - "Compare two colors in distance" -" - ^ (self hue - otherColor hue) abs + - (self saturation - otherColor saturation) abs *10 + - (self brightness - otherColor brightness) abs -" - "See http://www.compuphase.com/cmetric.htm" - | meanRed deltaRed deltaGreen deltaBlue | - meanRed := (self red + otherColor red) abs / 2. - deltaRed := (self red - otherColor red) abs. - deltaGreen := (self green - otherColor green) abs. - deltaBlue := (self blue - otherColor blue) abs. - - ^ ( ((2 + (meanRed / 256)) * (deltaRed * deltaRed)) + - (4 * deltaGreen) + - ((2 + ((255 - meanRed) / 256)) * deltaBlue) - ) sqrt! ! -!Colour methodsFor: 'groups of shades' stamp: 'jmv 6/18/2017 20:10:00'! - darkShades: thisMany - "An array of thisMany colors from black to the receiver. Array is of length num. Very useful for displaying color based on a variable in your program. " - "Color showColors: (Color red darkShades: 12)" - - ^ self class black mix: self shades: thisMany -! ! -!Colour methodsFor: 'groups of shades' stamp: 'jmv 6/18/2017 20:10:00'! - lightShades: thisMany - "An array of thisMany colors from white to self. Very useful for displaying color based on a variable in your program. " - "Color showColors: (Color red lightShades: 12)" - - ^ self class white mix: self shades: thisMany -! ! -!Colour methodsFor: 'groups of shades' stamp: 'jmv 6/18/2017 20:51:45'! - mix: color2 shades: thisMany - "Return an array of thisMany colors from self to color2. Very useful for displaying color based on a variable in your program. " - "Color showColors: (Color red mix: Color green shades: 12)" - - | redInc greenInc blueInc rr gg bb c out | - thisMany = 1 ifTrue: [^ Array with: color2]. - redInc _ color2 red - self red / (thisMany-1). - greenInc _ color2 green - self green / (thisMany-1). - blueInc _ color2 blue - self blue / (thisMany-1). - rr _ self red. gg _ self green. bb _ self blue. - out _ (1 to: thisMany) collect: [:num | - c _ Colour r: rr g: gg b: bb. - rr _ rr + redInc. - gg _ gg + greenInc. - bb _ bb + blueInc. - c]. - out at: out size put: color2. "hide roundoff errors" - ^ out -! ! -!Colour methodsFor: 'groups of shades' stamp: 'jmv 6/18/2017 20:52:45'! - wheel: thisMany - "An array of thisMany colors around the color wheel starting at self and ending all the way around the hue space just before self. Array is of length thisMany. Very useful for displaying color based on a variable in your program. " - - | sat bri hue step c | - sat _ self saturation. - bri _ self brightness. - hue _ self hue. - step _ 360.0 / (thisMany max: 1). - ^ (1 to: thisMany) collect: [:num | - c _ Colour h: hue s: sat v: bri. "hue is taken mod 360" - hue _ hue + step. - c]. -" -(Colour wheel: 8) withIndexDo: [:c :i | Display fill: (i*10@20 extent: 10@20) fillColor: c] -"! ! -!Colour methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:00'! - closestAssocFrom: aColorDict - "Answer closest associated color in aColorDict" -" - ((Color r: 0.3 g: 0.2 b: 0.8) closestAssocFrom: (Color colorNamesDict)) explore. -" - "Filter values for those close in hue (cheap test) then use rgbDistance" - | closeInHue isClose close distance myHue | - closeInHue := OrderedCollection new. - myHue := self hue. - isClose := [ :assoc | | delta | - delta := ((assoc value hue) - myHue) abs. - (delta < 20) or: [ delta > 340 ] "hues within 20 degrees" - ]. - aColorDict associationsDo: [ :assoc | - (isClose value: assoc) ifTrue: [ closeInHue add: assoc ] - ]. - - close := nil. - distance := 1000. "big" - (closeInHue size > 0) - ifFalse: [ "fallback -- no color really close" - aColorDict associationsDo: [ :assoc | | dist | - dist := self rgbDistance: (assoc value). - (dist < distance) ifTrue: [distance := dist. close := assoc] - ] - ] - ifTrue: [ closeInHue do: [ :assoc | | dist | - dist := self rgbDistance: (assoc value). - (dist < distance) ifTrue: [distance := dist. close := assoc] - ] - ]. - - ^ close! ! -!Colour methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:51:07'! - closestColor - "Answer the closest matching color in the colorNames dictionary" - -" - (Color red lighter lighter) closestColor explore. -" - ^ self closestColorFrom: (Colour colorNamesDict)! ! -!Colour methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:51:11'! -closestColorAssociation - "Answer this color's closest name->color match." - -" - (Color blue lighter lighter) closestColorAssociation explore. -" - ^ self closestAssocFrom: (Colour colorNamesDict)! ! -!Colour methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:00'! - closestColorFrom: aColorDict - "Answer closest associated color" -" - ((Color lightBlue) closestColorFrom: (Color css2NamedColors)) explore.. -" - ^(self closestAssocFrom: aColorDict) value! ! -!Colour methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:51:15'! -closestColorName - "Answer the name symbol of the closest matching color in the colorNames dictionary" -" - (Color red lighter lighter) closestColor name. -" - - ^ self closestNameFrom: (Colour colorNamesDict)! ! -!Colour methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:00'! - closestNameFrom: aColorDict - "Answer closest associated color name" -" - ((Color lightBlue) closestNameFrom: (Color namedColors)) print. -" - ^(self closestAssocFrom: aColorDict) key! ! -!Colour methodsFor: 'other' stamp: 'jmv 6/18/2017 20:51:20'! - colorName - "Return this color's name, or nil if it has no name. Only returns a name if it exactly matches the named color." - - ^(Colour colorNamesDict keyAtValue: self ifAbsent: [nil]) -! ! -!Colour methodsFor: 'other' stamp: 'jmv 6/18/2017 20:10:00'! - name - "Return this color's name, or description if unnamed." - - ^ self printString -! ! -!Colour methodsFor: 'printing' stamp: 'jmv 6/18/2017 20:10:00'! - hexStringRGB - " - Color fromUser hexStringRGB - " - ^String streamContents: [ :strm | - (self red * 255) rounded printOn: strm base: 16 length: 2 padded: true. - (self green * 255) rounded printOn: strm base: 16 length: 2 padded: true. - (self blue * 255) rounded printOn: strm base: 16 length: 2 padded: true ]! ! -!Colour methodsFor: 'printing' stamp: 'jmv 6/18/2017 20:53:07'! - printOn: aStream - self colorName ifNotNil: [ :name | - ^ aStream - nextPutAll: 'Colour '; - nextPutAll: name]. - self storeOn: aStream. -! ! -!Colour methodsFor: 'printing' stamp: 'jmv 6/18/2017 20:10:00'! - printString - "Answer a String whose characters are a description of the receiver." - - ^ String streamContents: [ :stream | self printOn: stream ]! ! -!Colour methodsFor: 'printing' stamp: 'jmv 6/18/2017 20:10:00'! - storeArrayOn: aStream - - aStream nextPutAll: '#('. - self storeArrayValuesOn: aStream. - aStream nextPutAll: ') ' -! ! -!Colour methodsFor: 'printing' stamp: 'jmv 6/18/2017 20:10:00'! - storeArrayValuesOn: aStream - - - self red printOn: aStream fractionDigits: 3. - aStream space. - self green printOn: aStream fractionDigits: 3. - aStream space. - self blue printOn: aStream fractionDigits: 3 - -! ! -!Colour methodsFor: 'printing' stamp: 'jmv 6/18/2017 20:10:00'! - storeOn: aStream - - aStream - nextPut: $(; - nextPutAll: self class name; - nextPutAll: ' r: '. - self red printOn: aStream fractionDigits: 3. - aStream nextPutAll: ' g: '. - self green printOn: aStream fractionDigits: 3. - aStream nextPutAll: ' b: '. - self blue printOn: aStream fractionDigits: 3. - aStream nextPut: $)! ! -!Colour methodsFor: 'queries' stamp: 'jmv 6/18/2017 20:40:55'! - isBlack - "Return true if the receiver represents black" - (self at: 1) = 0.0 ifFalse: [ ^ false ]. - (self at: 2) = 0.0 ifFalse: [ ^ false ]. - (self at: 3) = 0.0 ifFalse: [ ^ false ]. - ^ true! ! -!Colour methodsFor: 'queries' stamp: 'jmv 6/18/2017 20:10:00'! -isOpaque - ^true! ! -!Colour methodsFor: 'queries' stamp: 'jmv 6/18/2017 20:10:00'! - isTransparent - - ^ false -! ! -!Colour methodsFor: 'queries' stamp: 'jmv 6/18/2017 20:40:46'! - isWhite - "Return true if the receiver represents white" - (self at: 1) = 1.0 ifFalse: [ ^ false ]. - (self at: 2) = 1.0 ifFalse: [ ^ false ]. - (self at: 3) = 1.0 ifFalse: [ ^ false ]. - ^ true! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isBlue - "Am I considered Blue?" - - ^self blue > (self green + 0.3) - and: [self blue > (self red + 0.3)] - and: [(self green - self red) abs < 0.4]! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isBlueGreen - "Am I considered BlueGreen ?" - - ^self green > self red - and: [self red < 0.3] - and: [(self green - self blue) abs < 0.1]! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isBright - "Am I considered a Bright color ?" - - ^self brightness > 0.6! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isBrown - "Am I considered Brown ?" - - ^self red >= self green - and: [self green > self blue] - and: [(self red - self green) < 0.5] - and: [(self green - self blue) < 0.3]! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isCyan - "Am I considered Cyan ?" - - ^self red < 0.05 - and: [(self green min: self blue) > 0.5] - and: [(self green - self blue) abs < 0.2]! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isDark - "Am I considered a Dark color ?" - - ^self brightness < 0.5! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isGray - "Am I considered Gray ?" - - ^(self red closeTo: self green) - and: [self blue closeTo: self green ]! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isGreen - "Am I considered Green ?" - - ^self green > (self blue + 0.3) - and: [self blue > (self red + 0.3)]! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isGrey - "Am I considered Grey ?" - - ^self isGray! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isLight - "Am I considered a Light color ?" - - ^self brightness > 0.6! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isMagenta - "Am I considered Magenta ?" - - ^self green < 0.05 - and: [(self red min: self blue) > 0.5] - and: [(self red - self blue) abs < 0.2]! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isOrange - "Am I considered Orange ?" - - ^self red > ((self green max: self blue) + 0.2) - and: [self green > (self blue + 0.2)]! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isPastel - "Am I considered Pastel ?" - - ^self saturation < 0.4! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isPink - "Am I considered Pink ?" - - ^self red > ((self green max: self blue) + 0.3) - and: [self blue > (self green + 0.2)]! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isRed - "Am I considered Red ?" - - ^self red > (self green + 0.4) - and: [self red > (self blue + 0.6)] - and: [(self green - self blue) abs < 0.4]! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isSaturated - "Am I considered to be a Saturated color ?" - - ^self saturation > 0.6! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isYellow - "Am I considered Yellow ?" - - ^self blue < 0.05 - and: [(self red min: self green) > 0.5] - and: [(self red - self green) abs < 0.2]! ! -!Colour methodsFor: 'testing' stamp: 'jmv 6/18/2017 20:10:00'! - is: aSymbol - ^ aSymbol == #Color or: [ super is: aSymbol ]! ! -!Colour methodsFor: 'testing' stamp: 'jmv 6/18/2017 20:10:00'! - mightBeTranslucent - "For Colors, answer if actually translucent or not." - ^self isOpaque not! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:56:14'! - * aNumber - "Answer this color with its RGB multiplied by the given number. " - " - (Colour brown *2) display - " - ^ Colour new - setRed: (self red * aNumber min: 1.0 max: 0.0) - green: (self green * aNumber min: 1.0 max: 0.0) - blue: (self blue * aNumber min: 1.0 max: 0.0)! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:56:18'! - + aColor - "Answer this color mixed with the given color in an additive color space. " - " - (Colour blue + Colour green) display - " - ^ Colour new - setRed: (self red + aColor red min: 1.0 max: 0.0) - green: (self green + aColor green min: 1.0 max: 0.0) - blue: (self blue + aColor blue min: 1.0 max: 0.0)! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:56:22'! - - aColor - "Answer aColor is subtracted from the given color in an additive color space. " - " - (Color white - Color red) display - " - ^ Colour new - setRed: (self red - aColor red min: 1.0 max: 0.0) - green: (self green - aColor green min: 1.0 max: 0.0) - blue: (self blue - aColor blue min: 1.0 max: 0.0)! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:56:26'! - / aNumber - "Answer this color with its RGB divided by the given number. " - " - (Color red / 2) display - " - ^ Colour new - setRed: (self red / aNumber min: 1.0 max: 0.0) - green: (self green / aNumber min: 1.0 max: 0.0) - blue: (self blue / aNumber min: 1.0 max: 0.0)! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:50:50'! - adjustBrightness: brightness - "Adjust the relative brightness of this color. (lowest value is 0.005 so that hue information is not lost)" - - ^ Colour - h: self hue - s: self saturation - v: (self brightness + brightness min: 1.0 max: 0.005) - alpha: self alpha! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:50:53'! - adjustSaturation: saturation brightness: brightness - "Adjust the relative saturation and brightness of this color. (lowest value is 0.005 so that hue information is not lost)" - - ^ Colour - h: self hue - s: (self saturation + saturation min: 1.0 max: 0.005) - v: (self brightness + brightness min: 1.0 max: 0.005) - alpha: self alpha! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:10:41'! - alpha: alphaValue - "Return a new TranslucentColor with the given amount of opacity ('alpha')." - alphaValue = 1.0 ifFalse: [ - ^ TranslucentColour new - setRed: self red - green: self green - blue: self blue - alpha: alphaValue ]! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:50:57'! - alphaMixed: proportion with: aColor - "Answer this color mixed with the given color. The proportion, a number - between 0.0 and 1.0, determines what what fraction of the receiver to - use in the mix. For example, 0.9 would yield a color close to the - receiver. This method uses RGB interpolation; HSV interpolation can lead - to surprises. Mixes the alphas (for transparency) also." - - | frac1 frac2 | - frac1 _ proportion asFloat min: 1.0 max: 0.0. - frac2 _ 1.0 - frac1. - ^ Colour - r: self red * frac1 + (aColor red * frac2) - g: self green * frac1 + (aColor green * frac2) - b: self blue * frac1 + (aColor blue * frac2) - alpha: self alpha * frac1 + (aColor alpha * frac2)! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:10:00'! - atLeastAsLuminentAs: aFloat - - | revisedColor | - revisedColor _ self. - [revisedColor luminance < aFloat] whileTrue: [revisedColor _ revisedColor slightlyLighter]. - ^revisedColor -! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:10:00'! - atMostAsLuminentAs: aFloat - - | revisedColor | - revisedColor _ self. - [revisedColor luminance > aFloat] whileTrue: [revisedColor _ revisedColor slightlyDarker]. - ^revisedColor -! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:51:02'! - blacker - - ^ self alphaMixed: 0.8333 with: Colour black -! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:51:27'! - dansDarker - "Return a darker shade of the same color. - An attempt to do better than the current darker method. - (now obsolete, since darker has been changed to do this. -dew)" - ^ Colour h: self hue s: self saturation - v: (self brightness - 0.16 max: 0.0)! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:10:00'! - darker - "Answer a darker shade of this color." - - ^ self adjustBrightness: -0.08! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:10:00'! - duller - - ^ self adjustSaturation: -0.03 brightness: -0.2! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:10:00'! - lighter - "Answer a lighter shade of this color." - - ^ self adjustSaturation: -0.03 brightness: 0.08! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:51:59'! - mixed: proportion with: aColor - "Mix with another color and do not preserve transpareny. Only use this for extracting the RGB value and mixing it. All other callers should use instead: - aColor alphaMixed: proportion with: anotherColor - " - - | frac1 frac2 | - frac1 _ proportion asFloat min: 1.0 max: 0.0. - frac2 _ 1.0 - frac1. - ^ Colour - r: self red * frac1 + (aColor red * frac2) - g: self green * frac1 + (aColor green * frac2) - b: self blue * frac1 + (aColor blue * frac2)! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:52:03'! - muchDarker - - ^ self alphaMixed: 0.5 with: Colour black -! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:52:07'! - muchLighter - - ^ self alphaMixed: 0.233 with: Colour white -! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:52:12'! - negated - "Return an RGB inverted color" - ^Colour - r: 1.0 - self red - g: 1.0 - self green - b: 1.0 - self blue! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:37:53'! - orColorUnlike: theOther - "If this color is a lot like theOther, then return its complement, otherwide, return self" - - ^ (self diff: theOther) < 0.3 - ifTrue: [theOther negated] - ifFalse: [self]! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:10:00'! - paler - "Answer a paler shade of this color." - - ^ self adjustSaturation: -0.09 brightness: 0.09 -! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:52:16'! - quiteBlacker - - ^ self alphaMixed: 0.8 with: Colour black -! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:52:19'! - quiteWhiter - - ^ self alphaMixed: 0.6 with: Colour white! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:10:00'! - slightlyDarker - - ^ self adjustBrightness: -0.03 -! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:10:00'! - slightlyLighter - - ^ self adjustSaturation: -0.01 brightness: 0.03! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:52:24'! - slightlyWhiter - - ^ self alphaMixed: 0.85 with: Colour white -! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:10:00'! - twiceDarker - "Answer a significantly darker shade of this color." - - ^ self adjustSaturation: 0.076 brightness: -0.15! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:10:01'! - twiceLighter - "Answer a significantly lighter shade of this color." - - ^ self adjustSaturation: -0.06 brightness: 0.15! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:52:27'! -veryMuchDarker - - ^ self alphaMixed: 0.25 with: Colour black -! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:52:32'! - veryMuchLighter - - ^ self alphaMixed: 0.07 with: Colour white! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:02:05'! - whiter - - ^ self alphaMixed: 0.8333 with: Colour white -! ! -!Colour methodsFor: 'private' stamp: 'jmv 6/18/2017 20:10:01'! - attemptToMutateError - "A color is immutable. Once a color's red, green, and blue have been initialized, you cannot change them. Instead, create a new Color and use it." - - self error: 'Color objects are immutable once created' -! ! -!Colour methodsFor: 'private' stamp: 'jmv 6/18/2017 20:29:32'! - basicSetRed: r green: g blue: b - "Initialize this color's r, g, and b components to the given values in the range [0.0..1.0]." - - self - at: 1 put: r; - at: 2 put: g; - at: 3 put: b! ! -!Colour methodsFor: 'private' stamp: 'jmv 6/18/2017 20:15:44'! - setHue: hue chroma: chroma brightness: brightness - "Initialize this color to the given hue, chroma, and luma. See the comment in the instance creation method for details. - http://en.wikipedia.org/wiki/HSL_and_HSV - hue belongs in [0.0, 360.0) - chroma and luma belongs in [0.0, 1.0] - " - - | x hf i r1 g1 b1 m | - hf _ hue \\ 360. - i _ hf // 60. "integer part of hue" - x _ (hf \\ 60) / 60.0 . "fractional part of hue" - x _ x \\ 2 . - i \\ 2 = 1 ifTrue: [ x _ 1.0 - x ]. - x _ chroma * x. - - 0 = i ifTrue: [ r1 _ chroma. g1 _ x. b1 _ 0.0 ]. - 1 = i ifTrue: [ r1 _ x. g1 _ chroma. b1 _ 0.0 ]. - 2 = i ifTrue: [ r1 _ 0.0. g1 _ chroma. b1 _ x ]. - 3 = i ifTrue: [ r1 _ 0.0. g1 _ x. b1 _ chroma ]. - 4 = i ifTrue: [ r1 _ x. g1 _ 0.0. b1 _ chroma ]. - 5 = i ifTrue: [ r1 _ chroma. g1 _ 0.0. b1 _ x ]. - - m _ brightness - ((r1 max: g1) max: b1). - m < 0.0 - ifTrue: [ ^nil ]. "No color exists with required parameters" - r1 _ r1 + m. - r1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - g1 _ g1 + m. - g1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - b1 _ b1 + m. - b1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - self setRed: r1 green: g1 blue: b1! ! -!Colour methodsFor: 'private' stamp: 'jmv 6/18/2017 20:15:49'! - setHue: hue chroma: chroma luminance: luma - "Initialize this color to the given hue, chroma, and luma. See the comment in the instance creation method for details. - http://en.wikipedia.org/wiki/HSL_and_HSV - hue belongs in [0.0, 360.0) - chroma and luma belongs in [0.0, 1.0] - " - - | x hf i r1 g1 b1 m | - - hf _ hue \\ 360. - i _ hf // 60. "integer part of hue" - x _ (hf \\ 60) / 60.0 . "fractional part of hue" - x _ x \\ 2 . - i \\ 2 = 1 ifTrue: [ x _ 1.0 - x ]. - x _ chroma * x. - - 0 = i ifTrue: [ r1 _ chroma. g1 _ x. b1 _ 0.0 ]. - 1 = i ifTrue: [ r1 _ x. g1 _ chroma. b1 _ 0.0 ]. - 2 = i ifTrue: [ r1 _ 0.0. g1 _ chroma. b1 _ x ]. - 3 = i ifTrue: [ r1 _ 0.0. g1 _ x. b1 _ chroma ]. - 4 = i ifTrue: [ r1 _ x. g1 _ 0.0. b1 _ chroma ]. - 5 = i ifTrue: [ r1 _ chroma. g1 _ 0.0. b1 _ x ]. - - m _ luma - (0.299*r1) - (0.587*g1) - (0.114*b1). - m < 0.0 - ifTrue: [ ^nil ]. "No color exists with required parameters" - r1 _ r1 + m. - r1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - g1 _ g1 + m. - g1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - b1 _ b1 + m. - b1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - self setRed: r1 green: g1 blue: b1! ! -!Colour methodsFor: 'private' stamp: 'jmv 6/18/2017 20:16:07'! - setHue: hue saturation: saturation brightness: brightness - "Initialize this color to the given hue, saturation, and brightness. See the comment in the instance creation method for details." - - | s v hf i f p q t | - s _ saturation asFloat min: 1.0 max: 0.0. - v _ brightness asFloat min: 1.0 max: 0.0. - hf _ hue \\ 360. - i _ hf // 60. "integer part of hue" - f _ (hf \\ 60) / 60.0. "fractional part of hue" - - p _ (1.0 - s) * v. - q _ (1.0 - (s * f)) * v. - t _ (1.0 - (s * (1.0 - f))) * v. - - 0 = i ifTrue: [ ^ self setRed: v green: t blue: p ]. - 1 = i ifTrue: [ ^ self setRed: q green: v blue: p ]. - 2 = i ifTrue: [ ^ self setRed: p green: v blue: t ]. - 3 = i ifTrue: [ ^ self setRed: p green: q blue: v ]. - 4 = i ifTrue: [ ^ self setRed: t green: p blue: v ]. - 5 = i ifTrue: [ ^ self setRed: v green: p blue: q ]. - - self error: 'implementation error'! ! -!Colour methodsFor: 'private' stamp: 'jmv 6/18/2017 20:13:04'! - setRed: r green: g blue: b - - self basicSetRed: r green: g blue: b! ! -!Colour methodsFor: 'private' stamp: 'jmv 6/18/2017 20:29:48'! - setRed: r green: g blue: b range: range - "Initialize this color's r, g, and b components to the given values in the range [0..r]." - - self basicSetRed: r green: g blue: b. - self /= range! ! -!Colour methodsFor: 'as yet unclassified' stamp: 'jmv 6/18/2017 20:10:01'! - color - ^ self! ! -!Colour methodsFor: 'please remove' stamp: 'jmv 6/18/2017 21:26:21'! - floatRGB -"to be removed" - ^ self! ! -!Colour methodsFor: 'please remove' stamp: 'jmv 6/18/2017 21:26:07'! - setRed: r green: g blue: b colorSpace: aSymbol - ^ self setRed: r green: g blue: b! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:10:01'! - clipR: r g: g b: b - "Return a color with the given r, g, and b components in the range [0.0..1.0]. - Clip if necessary" - - ^ self - r: (r min: 1.0 max: 0.0) - g: (g min: 1.0 max: 0.0) - b: (b min: 1.0 max: 0.0)! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:10:01'! - colorFrom: parm - "Return an instantiated color from parm. If parm is already a color, return it, else return the result of my performing it if it's a symbol or, if it is a list, it can either be an array of three numbers, which will be interpreted as RGB values, or a list of symbols, the first of which is sent to me and then the others of which are in turn sent to the prior result, thus allowing entries of the form #(blue darker). Else just return the thing" - - | aColor firstParm | - (parm is: #Color) ifTrue: [ ^ parm ]. - parm isSymbol ifTrue: [ ^ self perform: parm ]. - (parm isSequenceableCollection and: [ parm size > 0 ]) - ifTrue: [ - firstParm _ parm first. - firstParm isNumber ifTrue: [ - ^ self fromRgbTriplet: parm]. - aColor _ self colorFrom: firstParm. - parm withIndexDo: [ :sym :ind | - ind > 1 ifTrue: [ - aColor _ aColor perform: sym ]]. - ^ aColor]. - ^ parm - -" -Color colorFrom: #(blue darker) -Color colorFrom: Color blue darker -Color colorFrom: #blue -Color colorFrom: #(0.0 0.0 1.0) -"! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 21:02:20'! - colorFromPixelValue: p depth: d - "Convert a pixel value for the given display depth into a color." - "Details: For depths of 8 or less, the pixel value is simply looked up in a table. For greater depths, the color components are extracted and converted into a color." - "Warning: In BitBlt, a pixel with pixelValue = 0 is transparent. - Squeak usually assumes that r=g=b=0 => transparent. But this is false if we have alpha (opacity). - A color with r=g=b=0 and opacity = 255 is BLACK, not TRANSPARENT. - Squeak also answers darkest possible blue when asked for black. Again, this is not needed in 32 bits (with alpha). It is also not really needed for 16 bits as we have an extra, unused bit: 16r8000 is not zero, but rgb=0, and hence, black. - The real rule is that pixelValue=0 means transparent. - And that darkest blue must be used instead of black, but only for depths >8 and < 16 (no indexed colors, no alpha) - This method is updated to reflect that." - - | r g b alpha | - - d = 1 ifTrue: [^ self indexedColors at: (p bitAnd: 16r01) + 1]. - - "For the rest of the depths, pixelValue = 0 means transparent, and darkest blue is considered to be black." - p = 0 ifTrue: [ ^Colour transparent ]. - - d = 8 ifTrue: [^ self indexedColors at: (p bitAnd: 16rFF) + 1]. - d = 4 ifTrue: [^ self indexedColors at: (p bitAnd: 16r0F) + 1]. - d = 2 ifTrue: [^ self indexedColors at: (p bitAnd: 16r03) + 1]. - - d = 32 ifTrue: [ - "eight bits per component; 8 bits of alpha" - alpha _ p bitShift: -24. - alpha = 0 ifTrue: [ ^Colour transparent ]. - r _ (p bitShift: -16) bitAnd: 16rFF. - g _ (p bitShift: -8) bitAnd: 16rFF. - b _ p bitAnd: 16rFF. - ^alpha < 255 - ifTrue: [ (Colour r: r g: g b: b range: 255) alpha: alpha asFloat / 255.0 ] - ifFalse: [ Colour r: r g: g b: b range: 255 ]]. - - d = 16 ifTrue: [ - "five bits per component. The most significant bit, unused, allows having real black, without p being zero" - r _ (p bitShift: -10) bitAnd: 16r1F. - g _ (p bitShift: -5) bitAnd: 16r1F. - b _ p bitAnd: 16r1F. - ^ Colour r: r g: g b: b range: 31]. - - d = 15 ifTrue: [ - "five bits per component" - r _ (p bitShift: -10) bitAnd: 16r1F. - g _ (p bitShift: -5) bitAnd: 16r1F. - b _ p bitAnd: 16r1F. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Colour black ]. - ^ Colour r: r g: g b: b range: 31]. - - d = 12 ifTrue: [ - "four bits per component" - r _ (p bitShift: -8) bitAnd: 16rF. - g _ (p bitShift: -4) bitAnd: 16rF. - b _ p bitAnd: 16rF. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Colour black ]. - ^ Colour r: r g: g b: b range: 15]. - - d = 9 ifTrue: [ - "three bits per component" - r _ (p bitShift: -6) bitAnd: 16r7. - g _ (p bitShift: -3) bitAnd: 16r7. - b _ p bitAnd: 16r7. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Colour black ]. - ^ Colour r: r g: g b: b range: 7]. - - self error: 'unknown pixel depth: ', d printString! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:10:01'! - fromArray: colorDef - - | answer | - colorDef size = 0 ifTrue: [^self transparent]. - colorDef size between: 3 and: 4 :: ifFalse: [self error: 'Undefined color definition']. - answer _ self r: (colorDef at: 1) g: (colorDef at: 2) b: (colorDef at: 3). - ^colorDef size = 3 - ifTrue: [answer] - ifFalse: [answer alpha: (colorDef at: 4)]! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:10:01'! - fromRgbTriplet: list - ^ self r: list first g: list second b: list last! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:10:01'! - fromString: aString - "For HTML color spec: #FFCCAA. Also support named colors. - See http://www.w3schools.com/cssref/css_colors_legal.asp" - " - Color fromString: '#FFCCAA'. - Color fromString: 'white'. - Color fromString: 'orange' - Color fromString: 'rgb(255,0,98)' - " - (aString size = 7 and: [ aString first = $# ]) ifTrue: [ - | aColorHexU red green blue | - aColorHexU _ aString asUppercase. - red _ ('16r', (aColorHexU copyFrom: 2 to: 3)) asNumber/255. - green _ ('16r', (aColorHexU copyFrom: 4 to: 5)) asNumber/255. - blue _ ('16r', (aColorHexU copyFrom: 6 to: 7)) asNumber/255. - ^ self r: red g: green b: blue]. - - (aString beginsWith: 'rgb') - ifTrue: [|values r g b| - values := (aString allButFirst: 4) allButLast findTokens: ','. - r := (values first includes: $%) - ifTrue: [(values first asNumber min: 100 max: 0) / 100.0] - ifFalse: [(values first asInteger min: 255 max: 0) / 255.0]. - g := (values second includes: $%) - ifTrue: [(values second asNumber min: 100 max: 0) / 100.0] - ifFalse: [(values second asInteger min: 255 max: 0) / 255.0]. - b := (values third includes: $%) - ifTrue: [(values third asNumber min: 100 max: 0) / 100.0] - ifFalse: [(values third asInteger min: 255 max: 0) / 255.0]. - ^self r: r g: g b: b]. - - ^self exactColorNamed: aString! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:29'! - gray: brightness - "Return a gray shade with the given brightness in the range [0.0..1.0]." - - ^ self new - setRed: brightness - green: brightness - blue: brightness! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:31'! - h: hue s: saturation v: brightness - "Create a color with the given hue, saturation, and brightness. Hue is given as the angle in degrees of the color on the color circle where red is zero degrees. Saturation and brightness are numbers in [0.0..1.0] where larger values are more saturated or brighter colors. For example, (Color h: 0 s: 1 v: 1) is pure red." - "Note: By convention, brightness is abbreviated 'v' to to avoid confusion with blue." - - ^ self new setHue: hue saturation: saturation brightness: brightness! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:10:01'! - h: h s: s v: v alpha: alpha - - ^ (self h: h s: s v: v) alpha: alpha! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:34'! - hue: hue chroma: chroma brightness: brightness - ^self new setHue: hue chroma: chroma brightness: brightness! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:37'! - hue: hue chroma: chroma luminance: luma - ^self new setHue: hue chroma: chroma luminance: luma! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:39'! - hue: hue saturation: saturation brightness: brightness - "Create a color with the given hue, saturation, and brightness. Hue is given as the angle in degrees of the color on the color circle where red is zero degrees. Saturation and brightness are numbers in [0.0..1.0] where larger values are more saturated or brighter colors. For example, (Color h: 0 s: 1 v: 1) is pure red." - "Note: By convention, brightness is abbreviated 'v' to to avoid confusion with blue." - - ^ self new setHue: hue saturation: saturation brightness: brightness! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:54:20'! - new - ^ self new: 3! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:41'! - r: r g: g b: b - "Return a color with the given r, g, and b components in the range [0.0..1.0]." - - ^ self new - setRed: r - green: g - blue: b! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:10:01'! -r: r g: g b: b alpha: alpha - - ^ (self r: r g: g b: b) alpha: alpha! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:43'! - r: r g: g b: b range: range - "Return a color with the given r, g, and b components specified as integers in the range [0..r]. This avoids the floating point arithmetic in the red:green:blue: message and is thus a bit faster for certain applications (such as computing a sequence of colors for a palette)." - - ^ self new setRed: r green: g blue: b range: range! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:10:01'! - random - "Return a random color that isn't too dark or under-saturated. - Display fill: (10@10 extent: 200@200) fillColor: Color random - " - - ^ Random withDefaultDo: [ :random | - self random: random ]! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:10:01'! - random2 - "Return a random color with a distribution that spans over all possible colors. - Display fill: (10@10 extent: 200@200) fillColor: Color random2 - " - - ^ Random withDefaultDo: [ :random | - self random2: random ]! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:46'! - random2: aRandom - "Return a random color with a distribution that spans over all possible colors." - - ^ self new - setRed: aRandom next - green: aRandom next - blue: aRandom next! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:48'! - random: aRandom - "Return a random color that isn't too dark or under-saturated." - - ^ self new - setHue: (360.0 * aRandom next) - saturation: (0.3 + (aRandom next * 0.7)) - brightness: (0.4 + (aRandom next * 0.6))! ! -!Colour class methodsFor: 'class initialization' stamp: 'jmv 6/18/2017 20:10:01'! - initializeGrayToIndexMap - "Build an array of gray values available in the 8-bit colormap. This array is indexed by a gray level between black (1) and white (256) and returns the pixel value for the corresponding gray level." - "Note: This method must be called after initializeIndexedColors, since it uses IndexedColors." - " - Color initializeGrayToIndexMap - " - - | grayLevels grayIndices c distToClosest dist indexOfClosest indexedColors | - "record the level and index of each gray in the 8-bit color table" - grayLevels _ OrderedCollection new. - grayIndices _ OrderedCollection new. - indexedColors _ self indexedColors. - "Note: skip the first entry, which is reserved for transparent" - 2 to: indexedColors size do: [:i | - c _ indexedColors at: i. - c saturation = 0.0 ifTrue: [ "c is a gray" - grayLevels add: (c green * 255) rounded. "0 to 255; R, G, and B are the same" - grayIndices add: i - 1]]. "pixel values are zero-based" - grayLevels _ grayLevels asArray. - grayIndices _ grayIndices asArray. - - "for each gray level in [0..255], select the closest match" - GrayToIndexMap _ ByteArray new: 256. - 0 to: 255 do: [ :level | - distToClosest _ 10000. "greater than distance to any real gray" - 1 to: grayLevels size do: [:i | - dist _ (level - (grayLevels at: i)) abs. - dist < distToClosest ifTrue: [ - distToClosest _ dist. - indexOfClosest _ grayIndices at: i]]. - GrayToIndexMap at: (level + 1) put: indexOfClosest]! ! -!Colour class methodsFor: 'class initialization' stamp: 'jmv 6/18/2017 20:59:48'! - initializeIndexedColors - "Build an array of colors corresponding to the fixed colormap used - for display depths of 1, 2, 4, or 8 bits." - "Color initializeIndexedColors" - - | a index grayVal | - a _ Array new: 256. - - "1-bit colors (monochrome)" - a at: 1 put: (Colour r: 1.0 g: 1.0 b: 1.0). "white or transparent" - a at: 2 put: (Colour r: 0.0 g: 0.0 b: 0.0). "black" - - "additional colors for 2-bit color" - a at: 3 put: (Colour r: 1.0 g: 1.0 b: 1.0). "opaque white" - a at: 4 put: (Colour r: 0.5 g: 0.5 b: 0.5). "1/2 gray" - - "additional colors for 4-bit color" - a at: 5 put: (Colour r: 1.0 g: 0.0 b: 0.0). "red" - a at: 6 put: (Colour r: 0.0 g: 1.0 b: 0.0). "green" - a at: 7 put: (Colour r: 0.0 g: 0.0 b: 1.0). "blue" - a at: 8 put: (Colour r: 0.0 g: 1.0 b: 1.0). "cyan" - a at: 9 put: (Colour r: 1.0 g: 1.0 b: 0.0). "yellow" - a at: 10 put: (Colour r: 1.0 g: 0.0 b: 1.0). "magenta" - - a at: 11 put: (Colour r: 0.125 g: 0.125 b: 0.125). "1/8 gray" - a at: 12 put: (Colour r: 0.25 g: 0.25 b: 0.25). "2/8 gray" - a at: 13 put: (Colour r: 0.375 g: 0.375 b: 0.375). "3/8 gray" - a at: 14 put: (Colour r: 0.625 g: 0.625 b: 0.625). "5/8 gray" - a at: 15 put: (Colour r: 0.75 g: 0.75 b: 0.75). "6/8 gray" - a at: 16 put: (Colour r: 0.875 g: 0.875 b: 0.875). "7/8 gray" - - "additional colors for 8-bit color" - "24 more shades of gray (1/32 increments but not repeating 1/8 increments)" - index _ 17. - 1 to: 31 do: [:v | - (v \\ 4) = 0 ifFalse: [ - grayVal _ v / 32.0. - a at: index put: (Colour r: grayVal g: grayVal b: grayVal). - index _ index + 1]]. - - "The remainder of color table defines a color cube with six steps - for each primary color. Note that the corners of this cube repeat - previous colors, but this simplifies the mapping between RGB colors - and color map indices. This color cube spans indices 40 through 255 - (indices 41-256 in this 1-based array)." - 0 to: 5 do: [:r | - 0 to: 5 do: [:g | - 0 to: 5 do: [:b | - index _ 41 + ((36 * r) + (6 * b) + g). - index > 256 ifTrue: [ - self error: 'index out of range in color table compuation']. - a at: index put: (Colour r: r g: g b: b range: 5)]]]. - - IndexedColors _ a. -! ! -!Colour class methodsFor: 'examples' stamp: 'jmv 6/18/2017 20:58:14'! - colorRampForDepth: depth extent: aPoint - "Returns a form of the given size showing R, G, B, and gray ramps for the given depth. Useful for testing color conversions between different depths." - "(Color colorRampForDepth: Display depth extent: 256@80) display" - "(Color colorRampForDepth: 32 extent: 256@80) displayOn: Display at: 0@0 rule: Form paint" - - | f dx dy r | - f _ Form extent: aPoint depth: depth. - dx _ aPoint x // 256. - dy _ aPoint y // 4. - 0 to: 255 do: [:i | - r _ (dx * i)@0 extent: dx@dy. - f fill: r fillColor: (Colour r: i g: 0 b: 0 range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Colour r: 0 g: i b: 0 range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Colour r: 0 g: 0 b: i range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Colour r: i g: i b: i range: 255)]. - ^ f -! ! -!Colour class methodsFor: 'examples' stamp: 'jmv 6/18/2017 21:29:30'! - experimentsTowarsANewColorPalette -" -self experimentsTowarsANewColorPalette -" -| selectedHue selectedSaturation selectedV selectedColor h s v color width height selectedChroma selectedLuminance | -width _ 300. -height _ 120. -selectedColor _ Colour random. -selectedHue _ selectedColor hue. -selectedSaturation _ selectedColor saturation. -selectedChroma _ selectedColor chroma. -selectedV _ selectedColor brightness. -selectedLuminance _ selectedColor luminance. -Display getCanvas fillRectangle: (0@0 extent: height@height) color: selectedColor. -0 to: height do: [ :y | - v _ 1.0 - (y / height). - 0 to: height do: [ :x | - s _ x / height. - color _ Colour new setHue: selectedHue saturation: s brightness: v. - Display colorAt: x@(y+height) put: color - ]. - DisplayScreen screenUpdateRequired: nil -]. -0 to: height do: [ :y | | c | - v _ 1.0 - (y / height). - s _ 1.0 - (y / height). - c _ s. - 0 to: width do: [ :x | - h _ x / width * 360. - - color _ Colour new setHue: h chroma: c luminance: selectedLuminance. -" color _ Colour new setHue: h chroma: c brightness: selectedV." - color ifNil: [ color _ Colour black ]. -" color _ Colour new setHue: h saturation: s brightness: selectedV." - Display colorAt: x+height@y put: color. - - color _ Colour new setHue: h chroma: selectedChroma luminance: v. -" color _ Colour new setHue: h chroma: selectedChroma brightness: v." - color ifNil: [ color _ Colour black ]. -" color _ Colour new setHue: h saturation: selectedSaturation brightness: v." - Display colorAt: x+height@(y+height) put: color. - - ]. - DisplayScreen screenUpdateRequired: nil -].! ! -!Colour class methodsFor: 'examples' stamp: 'jmv 6/18/2017 20:10:01'! - hotColdShades: thisMany - "An array of thisMany colors showing temperature from blue to red to white hot. (Later improve this by swinging in hue.) " - "Color showColors: (Color hotColdShades: 25)" - - | n s1 s2 s3 s4 s5 | - thisMany < 5 ifTrue: [^ self error: 'must be at least 5 shades']. - n _ thisMany // 5. - s1 _ self white mix: self yellow shades: (thisMany - (n*4)). - s2 _ self yellow mix: self red shades: n+1. - s2 _ s2 copyFrom: 2 to: n+1. - s3 _ self red mix: self green darker shades: n+1. - s3 _ s3 copyFrom: 2 to: n+1. - s4 _ self green darker mix: self blue shades: n+1. - s4 _ s4 copyFrom: 2 to: n+1. - s5 _ self blue mix: self black shades: n+1. - s5 _ s5 copyFrom: 2 to: n+1. - ^ s1, s2, s3, s4, s5 -! ! -!Colour class methodsFor: 'examples' stamp: 'jmv 6/18/2017 20:59:58'! - showColorCube - "Show a 12x12x12 color cube." - "Color showColorCube" - - 0 to: 11 do: [:r | - 0 to: 11 do: [:g | - 0 to: 11 do: [:b | - Display fill: (((r*60) + (b*5)) @ (g*5) extent: 5@5) - fillColor: (Colour r: r g: g b: b range: 11)]]]. -! ! -!Colour class methodsFor: 'examples' stamp: 'jmv 6/18/2017 20:10:01'! - showColors: colorList - "Display the given collection of colors across the top of the Display." - - | w r | - w _ Display width // colorList size. - r _ 0@0 extent: w@((w min: 30) max: 10). - colorList do: [:c | - Display fill: r fillColor: c. - r _ r translatedBy: w@0]. -! ! -!Colour class methodsFor: 'examples' stamp: 'jmv 6/18/2017 21:00:03'! - showHSVPalettes - "Shows a palette of hues, varying the saturation and brightness for each one. Best results are with depths 16 and 32." - "Color showHSVPalettes" - - | left top c | - left _ top _ 0. - 0 to: 179 by: 15 do: [:h | - 0 to: 10 do: [:s | - left _ (h * 4) + (s * 4). - 0 to: 10 do: [:v | - c _ Colour h: h s: s asFloat / 10.0 v: v asFloat / 10.0. - top _ (v * 4). - Display fill: (left@top extent: 4@4) fillColor: c. - - c _ Colour h: h + 180 s: s asFloat / 10.0 v: v asFloat / 10.0. - top _ (v * 4) + 50. - Display fill: (left@top extent: 4@4) fillColor: c]]]. -! ! -!Colour class methodsFor: 'examples' stamp: 'jmv 6/18/2017 20:10:01'! - showHuesInteractively - "Shows a palette of hues at a (saturation, brightness) point determined by the mouse position. Click the mouse button to exit and return the selected (saturation, brightness) point." - "Color showHuesInteractively" - - | p s v | - [Sensor isAnyButtonPressed] whileFalse: [ - p _ Sensor mousePoint. - s _ p x asFloat / 300.0. - v _ p y asFloat / 300.0. - self showColors: (self wheel: 12 saturation: s brightness: v)]. - ^ (s min: 1.0) @ (v min: 1.0)! ! -!Colour class methodsFor: 'examples' stamp: 'jmv 6/18/2017 21:01:15'! - wheel: thisMany - "Return a collection of thisMany colors evenly spaced around the color wheel." - "Color showColors: (Color wheel: 12)" - - ^ Colour wheel: thisMany saturation: 0.9 brightness: 0.7 -! ! -!Colour class methodsFor: 'examples' stamp: 'jmv 6/18/2017 21:01:20'! - wheel: thisMany saturation: s brightness: v - "Return a collection of thisMany colors evenly spaced around the color wheel, all of the given saturation and brightness." - "Color showColors: (Color wheel: 12 saturation: 0.4 brightness: 1.0)" - "Color showColors: (Color wheel: 12 saturation: 0.8 brightness: 0.5)" - - ^ (Colour h: 0.0 s: s v: v) wheel: thisMany -! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - aqua - - ^ self colorNamesDict at: #aqua! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - beige - - ^ self colorNamesDict at: #beige! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - black - - ^ self colorNamesDict at: #black! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - blue - - ^ self colorNamesDict at: #blue! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - brightGreen - - ^ self colorNamesDict at: #brightGreen! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - brown - - ^ self colorNamesDict at: #brown! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - cyan - - ^ self colorNamesDict at: #cyan! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - darkBlue - - ^ self colorNamesDict at: #darkBlue! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - darkGray - - ^ self colorNamesDict at: #darkGray! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - darkGreen - - ^ self colorNamesDict at: #darkGreen! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - darkPink - - ^ self colorNamesDict at: #darkPink! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - darkPurple - - ^ self colorNamesDict at: #darkPurple! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! -forestGreen - - ^ self colorNamesDict at: #forestGreen! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - gray - - ^ self colorNamesDict at: #gray! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - green - - ^ self colorNamesDict at: #green! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - grey - - ^ self colorNamesDict at: #grey! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - hotPink - - ^ self colorNamesDict at: #hotPink! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - indigo - - ^ self colorNamesDict at: #indigo! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lavender - - ^ self colorNamesDict at: #lavender! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lightBlue - - ^ self colorNamesDict at: #lightBlue! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lightBrown - - ^ self colorNamesDict at: #lightBrown! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! -lightCyan - - ^ self colorNamesDict at: #lightCyan! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lightGray - - ^ self colorNamesDict at: #lightGray! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lightGreen - - ^ self colorNamesDict at: #lightGreen! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! -lightMagenta - - ^ self colorNamesDict at: #lightMagenta! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lightOrange - - ^ self colorNamesDict at: #lightOrange! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lightPink - - ^ self colorNamesDict at: #lightPink! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lightPurple - - ^ self colorNamesDict at: #lightPurple! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lightRed - - ^ self colorNamesDict at: #lightRed! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lightYellow - - ^ self colorNamesDict at: #lightYellow! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lilac - - ^ self colorNamesDict at: #lilac! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lime - - ^ self colorNamesDict at: #lime! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - limeGreen - - ^ self colorNamesDict at: #limeGreen! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - magenta - - ^ self colorNamesDict at: #magenta! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - maroon - - ^ self colorNamesDict at: #maroon! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - mauve - - ^ self colorNamesDict at: #mauve! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - mustard - - ^ self colorNamesDict at: #mustard! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - navyBlue - - ^ self colorNamesDict at: #navyBlue! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - olive - - ^ self colorNamesDict at: #olive! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - oliveGreen - - ^ self colorNamesDict at: #oliveGreen! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! -orange - - ^ self colorNamesDict at: #orange! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - paleGreen - - ^ self colorNamesDict at: #paleGreen! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - peach - - ^ self colorNamesDict at: #peach! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - periwinkle - - ^ self colorNamesDict at: #periwinkle! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! -pink - - ^ self colorNamesDict at: #pink! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - purple - - ^ self colorNamesDict at: #purple! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - red - - ^ self colorNamesDict at: #red! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - royalBlue - - ^ self colorNamesDict at: #royalBlue! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - salmon - - ^ self colorNamesDict at: #salmon! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - seaGreen - - ^ self colorNamesDict at: #seaGreen! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - skyBlue - - ^ self colorNamesDict at: #skyBlue! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - tan - - ^ self colorNamesDict at: #tan! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - teal - - ^ self colorNamesDict at: #teal! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - transparent - - ^ self colorNamesDict at: #transparent! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - turquoise - - ^ self colorNamesDict at: #turquoise! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - veryDarkGray - - ^ self colorNamesDict at: #veryDarkGray! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - veryLightGray - - ^ self colorNamesDict at: #veryLightGray! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - veryVeryDarkGray - - ^ self colorNamesDict at: #veryVeryDarkGray! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - veryVeryLightGray - - ^ self colorNamesDict at: #veryVeryLightGray! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - violet - - ^ self colorNamesDict at: #violet! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - white - - ^ self colorNamesDict at: #white! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - yellow - - ^ self colorNamesDict at: #yellow! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:10:01'! - cachedColormapForGrayFrom: sourceDepth - "Return a cached colormap for mapping from the given depth to the 8bpp grays. Always return a real colormap, not nil; this allows the client to get an identity colormap that can then be copied and modified to do color transformations." - "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" - "Note: The colormap cache may be cleared by evaluating 'Color shutDown'." - "Note: The color maps for sourceDepth=16 and for sourceDepth=32 are the same" - - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | srcIndex map | - ToGrayColormaps ifNil: [ - ToGrayColormaps _ Array new: 5]. - - srcIndex _ sourceDepth highBit min: 5. - - (ToGrayColormaps at: srcIndex) ifNotNil: [ :m | ^ m ]. - - map _ self computeColormapForGray8bppFrom: sourceDepth. - ToGrayColormaps at: srcIndex put: map. - ^ map! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:10:01'! - cachedColormapFrom: sourceDepth to: destDepth - "Return a cached colormap for mapping between the given depths. Always return a real colormap, not nil; this allows the client to get an identity colormap that can then be copied and modified to do color transformations." - "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" - "Note: The colormap cache may be cleared by evaluating 'Color shutDown'." - "Note: The color maps for sourceDepth=16 and for sourceDepth=32 are the same" - - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | srcIndex dstIndex map | - CachedColormaps - ifNil: [CachedColormaps _ (1 to: 5) collect: [:i | Array new: 6]]. - - srcIndex _ sourceDepth highBit min: 5. - dstIndex _ destDepth highBit. - - ((CachedColormaps at: srcIndex) at: dstIndex) ifNotNil: [ :m | ^ m ]. - - map _ self computeColormapFrom: sourceDepth to: destDepth. - (CachedColormaps at: srcIndex) at: dstIndex put: map. - ^ map! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:10:01'! - cachedColormapFromGrayTo: destDepth - "Return a cached colormap for mapping from 8bpp grays to the given depth. Always return a real colormap, not nil; this allows the client to get an identity colormap that can then be copied and modified to do color transformations." - "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" - "Note: The colormap cache may be cleared by evaluating 'Color shutDown'." - "Note: The color maps for sourceDepth=16 and for sourceDepth=32 are the same" - - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | dstIndex map | - FromGrayColormaps - ifNil: [FromGrayColormaps _ Array new: 6 ]. - - dstIndex _ destDepth highBit. - - (FromGrayColormaps at: dstIndex) ifNotNil: [ :m | ^ m ]. - - map _ self computeColormapFromGray8bppForDepth: destDepth. - FromGrayColormaps at: dstIndex put: map. - ^ map! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:57:57'! - colorMapIfNeededFrom: sourceDepth to: destDepth - "Return a colormap for mapping between the given depths, or nil if no colormap is needed." - "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" - - sourceDepth = destDepth ifTrue: [^ nil]. "not needed if depths are the same" - - (sourceDepth >= 16) & (destDepth >= 16) ifTrue: [ - "mapping is done in BitBlt by zero-filling or truncating each color component" - ^ nil]. - - ^ Colour cachedColormapFrom: sourceDepth to: destDepth -! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:10:01'! - computeColorConvertingMap: targetColor from: sourceDepth to: destDepth keepSubPixelAA: keepSubPix - "Note: The color converting map for sourceDepth=16 and for sourceDepth=32 are the same" - sourceDepth < 16 ifTrue: [ - "source is 1-, 2-, 4-, or 8-bit indexed color. - Assumed not to include subpixelAA" - ^ self computeIndexedColorConvertingMap: targetColor from: sourceDepth to: destDepth - ] ifFalse: [ - "source is 16-bit or 32-bit RGB. - Might include subpixelAA" - ^ self computeRGBColorConvertingMap: targetColor to: destDepth keepSubPixelAA: keepSubPix - ]! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:10:01'! - computeColormapForGray8bppFrom: sourceDepth - "Compute a colorMap for translatingfrom the given depth to the 8bpp grays" - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | map | - sourceDepth < 16 ifTrue: [ - "source is 1-, 2-, 4-, or 8-bit indexed color" - map _ (self indexedColors copyFrom: 1 to: (1 bitShift: sourceDepth)) - collect: [ :c | (c luminance * 255) rounded]. - map _ map as: Bitmap. - ^ map - ] - ifFalse: [ - ^ self computeRGBColormapForGray8 ]! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:10:01'! - computeColormapFrom: sourceDepth to: destDepth - "Compute a colorMap for translating between the given depths. A colormap is a Bitmap whose entries contain the pixel values for the destination depth. Typical clients use cachedColormapFrom:to: instead." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | map bitsPerColor | - sourceDepth < 16 ifTrue: [ - "source is 1-, 2-, 4-, or 8-bit indexed color" - map _ (self indexedColors copyFrom: 1 to: (1 bitShift: sourceDepth)) - collect: [:c | c pixelValueForDepth: destDepth]. - map _ map as: Bitmap. - ] ifFalse: [ - "source is 16-bit or 32-bit RGB" - destDepth > 8 - ifTrue: [bitsPerColor _ 5] "retain maximum color resolution" - ifFalse: [bitsPerColor _ 4]. - map _ self computeRGBColormapFor: destDepth bitsPerColor: bitsPerColor]. - - "Note: zero is transparent except when source depth is one-bit deep" - sourceDepth > 1 ifTrue: [map at: 1 put: 0]. - ^ map -! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:58:29'! - computeColormapFromGray8bppForDepth: destDepth - "Return a colormap for displaying a GrayForm at the given depth" - - | newMap | - newMap _ Bitmap new: 256. - 1 to: 256 do: [ :i | - newMap - at: i - put: ((Colour gray: (i-1) asFloat / 255.0) pixelValueForDepth: destDepth)]. - ^ newMap! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:58:33'! - computeIndexedColorConvertingMap: targetColor from: sourceDepth to: destDepth - | map | - - map _ (self indexedColors copyFrom: 1 to: (1 bitShift: sourceDepth)) collect: [ :cc | | f c | - f _ 1.0 - (cc red + cc green + cc blue / 3.0 ). - c _ targetColor - ifNotNil: [ - destDepth = 32 - ifTrue: [ targetColor * f alpha: f] - ifFalse: [ targetColor alphaMixed: f*1.5 with: Colour white ]] - ifNil: [ cc ]. - destDepth = 32 - ifTrue: [ c pixelValueForDepth: destDepth] - ifFalse: [ - f = 0.0 - ifTrue: [ 0 ] - ifFalse: [ c pixelValueForDepth: destDepth ]]]. - map _ map as: Bitmap. - ^map! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:58:41'! - computeRGBColorConvertingMap: targetColor to: destDepth keepSubPixelAA: keepSubPix - "Builds a colormap intended to convert from subpixelAA black values to targetColor values. - keepSubPix - ifTrue: [ Answer colors that also include subpixelAA ] - ifFalse: [ - Take fullpixel luminance level. Apply it to targetColor. - I.e. answer colors with NO subpixelAA ]" - - | mask map c bitsPerColor r g b f v | - - destDepth > 8 - ifTrue: [bitsPerColor _ 5] "retain maximum color resolution" - ifFalse: [bitsPerColor _ 4]. - "Usually a bit less is enough, but make it configurable" - bitsPerColor _ bitsPerColor min: Preferences aaFontsColormapDepth. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - r _ (i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask. - g _ (i bitShift: 0 - bitsPerColor) bitAnd: mask. - b _ (i bitShift: 0) bitAnd: mask. - f _ 1.0 - (r + g + b / 3.0 / mask). - c _ targetColor - ifNotNil: [ - (keepSubPix and: [destDepth > 8]) ifTrue: [ - Colour - r: 1.0 - (r asFloat/mask) * targetColor red - g: 1.0 - (g asFloat/mask) * targetColor green - b: 1.0 - (b asFloat/mask) * targetColor blue - alpha: f * targetColor alpha "alpha will be ignored below, in #pixelValueForDepth: if destDepth ~= 32" ] - ifFalse: [ - destDepth = 32 - ifTrue: [ targetColor * f alpha: f * targetColor alpha ] - ifFalse: [ targetColor alphaMixed: f*1.5 with: Colour white ]]] - ifNil: [ Colour r: r g: g b: b range: mask]. "This is currently used only to keep some SubPixelAA on destDepth = 8, using a single pass of rule 25" - v _ destDepth = 32 - ifTrue: [ c pixelValueForDepth: destDepth] - ifFalse: [ - f < 0.1 - ifTrue: [ 0 ] - ifFalse: [ c pixelValueForDepth: destDepth ]]. - map at: i + 1 put: v ]. - ^ map! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:58:48'! - computeRGBColormapFor: destDepth bitsPerColor: bitsPerColor - "Compute a colorMap for translating from 16-bit or 32-bit RGB color to the given depth, using the given number of of bits per color component." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | mask map c | - (#(3 4 5) includes: bitsPerColor) - ifFalse: [self error: 'BitBlt only supports 3, 4, or 5 bits per color component']. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - c _ Colour - r: ((i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask) - g: ((i bitShift: 0 - bitsPerColor) bitAnd: mask) - b: ((i bitShift: 0) bitAnd: mask) - range: mask. - map at: i + 1 put: (c pixelValueForDepth: destDepth)]. - - map at: 1 put: (Colour transparent pixelWordForDepth: destDepth). "zero always transparent" - ^ map -! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:58:56'! - computeRGBColormapForGray8 - "Compute a colorMap for translating from 16-bit or 32-bit RGB color to 8bpp grays, using the default number of of bits per color component." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | bitsPerColor mask map c | - bitsPerColor _ 5. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - c _ Colour - r: ((i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask) - g: ((i bitShift: 0 - bitsPerColor) bitAnd: mask) - b: ((i bitShift: 0) bitAnd: mask) - range: mask. - map at: i + 1 put: (c luminance * 255) rounded]. - - ^ map! ! -!Colour class methodsFor: 'other' stamp: 'jmv 6/18/2017 20:10:01'! - maskingMap: depth - "Return a color map that maps all colors except transparent to words of all ones. Used to create a mask for a Form whose transparent pixel value is zero. Cache the most recently used map." - "Warning: The behavior is incorrect if depth = 32. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | sizeNeeded | - depth <= 8 - ifTrue: [sizeNeeded _ 1 bitShift: depth] - ifFalse: [sizeNeeded _ 4096]. - - (MaskingMap == nil or: [MaskingMap size ~= sizeNeeded]) ifTrue: - [MaskingMap _ Bitmap new: sizeNeeded withAll: 16rFFFFFFFF. - MaskingMap at: 1 put: 0. "transparent"]. - - ^ MaskingMap -! ! -!Colour class methodsFor: 'color from user' stamp: 'jmv 6/18/2017 20:58:07'! - colorPaletteForDepth: depth extent: chartExtent - "Display a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." - "Note: It is slow to build this palette, so it should be cached for quick access." - "(Color colorPaletteForDepth: 16 extent: 190@60) display" - - | basicHue x y startHue palette transHt vSteps transCaption grayWidth hSteps | - palette _ Form extent: chartExtent depth: depth. - transCaption _ - (Form extent: 34@9 depth: 1 - fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0) - offset: 0@0). - transHt _ transCaption height. - palette fillWhite: (0@0 extent: palette width@transHt). - palette fillBlack: (0@transHt extent: palette width@1). - transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0). - grayWidth _ 10. - startHue _ 338.0. - vSteps _ palette height - transHt // 2. - hSteps _ palette width - grayWidth. - x _ 0. - startHue to: startHue + 360.0 by: 360.0/hSteps do: [ :h | - basicHue _ Colour h: h asFloat s: 1.0 v: 1.0. - y _ transHt+1. - 0 to: vSteps do: [ :n | | c | - c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Colour white. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - 1 to: vSteps do: [ :n | | c | - c _ Colour black mixed: (n asFloat / vSteps asFloat) with: basicHue. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - x _ x + 1]. - y _ transHt + 1. - 1 to: vSteps * 2 do: [ :n | | c | - c _ Colour black mixed: (n asFloat / (vSteps*2) asFloat) with: Colour white. - palette fill: (x@y extent: 10@1) fillColor: c. - y _ y + 1]. - ^ palette -! ! -!Colour class methodsFor: 'color from user' stamp: 'jmv 6/18/2017 20:58:24'! - colorTest: depth extent: chartExtent colorMapper: colorMapper - "Create a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." - "Note: It is slow to build this palette, so it should be cached for quick access." - "(Color colorTest: 32 extent: 570@180 colorMapper: [:c | c]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 7) asInteger / 7 - g: (c green * 7) asInteger / 7 - b: (c blue * 3) asInteger / 3]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 5) asInteger / 5 - g: (c green * 5) asInteger / 5 - b: (c blue * 5) asInteger / 5]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 15) asInteger / 15 - g: (c green * 15) asInteger / 15 - b: (c blue * 15) asInteger / 15]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 31) asInteger / 31 - g: (c green * 31) asInteger / 31 - b: (c blue * 31) asInteger / 31]) display" - - | basicHue x y c startHue palette transHt vSteps transCaption grayWidth hSteps | - palette _ Form extent: chartExtent depth: depth. - transCaption _ - (Form extent: 34@9 depth: 1 - fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0) - offset: 0@0). - transHt _ transCaption height. - palette fillWhite: (0@0 extent: palette width@transHt). - palette fillBlack: (0@transHt extent: palette width@1). - transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0). - grayWidth _ 10. - startHue _ 338.0. - vSteps _ palette height - transHt // 2. - hSteps _ palette width - grayWidth. - x _ 0. - startHue to: startHue + 360.0 by: 360.0/hSteps do: [:h | - basicHue _ Colour h: h asFloat s: 1.0 v: 1.0. - y _ transHt+1. - 0 to: vSteps do: [:n | - c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Colour white. - c _ colorMapper value: c. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - 1 to: vSteps do: [:n | - c _ Colour black mixed: (n asFloat / vSteps asFloat) with: basicHue. - c _ colorMapper value: c. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - x _ x + 1]. - y _ transHt + 1. - 1 to: vSteps * 2 do: [:n | - c _ Colour black mixed: (n asFloat / (vSteps*2) asFloat) with: Colour white. - c _ colorMapper value: c. - palette fill: (x@y extent: 10@1) fillColor: c. - y _ y + 1]. - ^ palette -! ! -!Colour class methodsFor: 'color name lookup' stamp: 'jmv 6/18/2017 20:10:01'! - colorNames - "Answer the current dictionary of name->color associations." - - ^self colorNamesDict keys! ! -!Colour class methodsFor: 'color name lookup' stamp: 'jmv 6/18/2017 20:59:02'! - defaultColorNamesDictionary - "Answer a amall but useful name->color dictionary" - - | defaultDict | - "Meld most used xkcd colors into traditional colors." - defaultDict := (self traditionalColorNamesDictionary addAll: - self xkcdFirst48ColorNamesDictionary; - yourself). - - "Override traditional names existing in extended XKCD naming" - defaultDict at: #lightYellow put: (Colour r: 1.0 g: 0.996 b: 0.478). - defaultDict at: #lightOrange put: (Colour r: 0.992 g: 0.667 b: 0.283). - defaultDict at: #lightCyan put: (Colour r: 0.674 g: 1.0 b: 0.988). - defaultDict at: #lightRed put: (Colour r: 1.0 g: 0.279 b: 0.298). - defaultDict at: #lightMagenta put: (Colour r: 0.98 g: 0.372 b: 0.969). - - ^defaultDict! ! -!Colour class methodsFor: 'color name lookup' stamp: 'jmv 6/18/2017 20:59:12'! - doesNotUnderstand: aMessage - "Some code takes - Color colorNames - and does - Color perform: aColorname. - - Make this work." - - ^(Colour colorNamesDict) - at: (aMessage selector) - ifAbsent: [super doesNotUnderstand: aMessage]! ! -!Colour class methodsFor: 'color name lookup' stamp: 'jmv 6/18/2017 20:10:01'! - exactColorNamed: aColorName - - "Answer color matching name or nil - from my ColorName->Color Dictionary" - - ^ self colorNamesDict at: (aColorName asSymbol) ifAbsent: [nil]! ! -!Colour class methodsFor: 'color name lookup' stamp: 'jmv 6/18/2017 20:59:55'! - setColorNamesDict: aNameColorDictionary - "Answer the current dictionary of name->color associations." - - "Note: This is a non-standard name because this is a non-standard action!! - Do this if you really, really know what you are doing." - - "Some Colors are required for proper system operation" - Colour defaultColorNamesDictionary keysAndValuesDo: [ :colorName :colorValue | - aNameColorDictionary at: colorName ifAbsentPut: colorValue - ]. - - ColorNamesDict := aNameColorDictionary! ! -!Colour class methodsFor: 'color name lookup' stamp: 'jmv 6/18/2017 21:01:08'! - traditionalColorNamesDictionary - "Answer a dictionary of Squeak traditional name->color associations.." - - | nameDict | - nameDict _ Dictionary new. - nameDict at: #black put: (Colour r: 0 g: 0 b: 0). - nameDict at: #veryVeryDarkGray put: (Colour r: 0.125 g: 0.125 b: 0.125). - nameDict at: #veryDarkGray put: (Colour r: 0.25 g: 0.25 b: 0.25). - nameDict at: #darkGray put: (Colour r: 0.375 g: 0.375 b: 0.375). - nameDict at: #gray put: (Colour r: 0.5 g: 0.5 b: 0.5). - nameDict at: #lightGray put: (Colour r: 0.625 g: 0.625 b: 0.625). - nameDict at: #veryLightGray put: (Colour r: 0.75 g: 0.75 b: 0.75). - nameDict at: #veryVeryLightGray put: (Colour r: 0.875 g: 0.875 b: 0.875). - nameDict at: #white put: (Colour r: 1.0 g: 1.0 b: 1.0). - nameDict at: #red put: (Colour r: 1.0 g: 0 b: 0). - nameDict at: #yellow put: (Colour r: 1.0 g: 1.0 b: 0). - nameDict at: #green put: (Colour r: 0 g: 1.0 b: 0). - nameDict at: #cyan put: (Colour r: 0 g: 1.0 b: 1.0). - nameDict at: #blue put: (Colour r: 0 g: 0 b: 1.0). - nameDict at: #magenta put: (Colour r: 1.0 g: 0 b: 1.0). - nameDict at: #brown put: (Colour r: 0.6 g: 0.2 b: 0). - nameDict at: #orange put: (Colour r: 1.0 g: 0.6 b: 0). - nameDict at: #lightRed put: (Colour r: 1.0 g: 0.8 b: 0.8). - nameDict at: #lightYellow put: (Colour r: 1.0 g: 1.0 b: 0.8). - nameDict at: #lightGreen put: (Colour r: 0.8 g: 1.0 b: 0.6). - nameDict at: #lightCyan put: (Colour r: 0.4 g: 1.0 b: 1.0). - nameDict at: #lightBlue put: (Colour r: 0.8 g: 1.0 b: 1.0). - nameDict at: #lightMagenta put: (Colour r: 1.0 g: 0.8 b: 1.0). - nameDict at: #lightBrown put: (Colour r: 1.0 g: 0.6 b: 0.2). - nameDict at: #lightOrange put: (Colour r: 1.0 g: 0.8 b: 0.4). - nameDict at: #transparent put: (TranslucentColour r: 0.0 g: 0.0 b: 0.0 alpha: 0.0). - - ^nameDict -! ! -!Colour class methodsFor: 'color name lookup' stamp: 'jmv 6/18/2017 21:01:38'! - xkcdFirst48ColorNamesDictionary - "XKCD color names are based on a survey oc colors people call by the same name. - http://blog.xkcd.com/2010/05/03/color-survey-results/" - - "Answer a dictionary of the most agreed upon first 48 xkcd colors" -" - Color xkcdFirst48ColorNamesDictionary explore. -" - | xkcdDict | - xkcdDict := Dictionary new - at: #lightPink put: (Colour fromString: '#ffd1df') ; - at: #mustard put: (Colour fromString: '#ceb301') ; - at: #indigo put: (Colour fromString: '#380282') ; - at: #lime put: (Colour fromString: '#aaff32') ; - at: #seaGreen put: (Colour fromString: '#53fca1') ; - at: #periwinkle put: (Colour fromString: '#8e82fe') ; - at: #darkPink put: (Colour fromString: '#cb416b') ; - at: #oliveGreen put: (Colour fromString: '#677a04') ; - at: #peach put: (Colour fromString: '#ffb07c') ; - at: #paleGreen put: (Colour fromString: '#c7fdb5') ; - at: #lightBrown put: (Colour fromString: '#ad8150') ; - at: #hotPink put: (Colour fromString: '#ff028d') ; - at: #black put: (Colour fromString: '#000000') ; - at: #lilac put: (Colour fromString: '#cea2fd') ; - at: #navyBlue put: (Colour fromString: '#001146') ; - at: #royalBlue put: (Colour fromString: '#0504aa') ; - at: #beige put: (Colour fromString: '#e6daa6') ; - at: #salmon put: (Colour fromString: '#ff796c') ; - at: #olive put: (Colour fromString: '#6e750e') ; - at: #maroon put: (Colour fromString: '#650021') ; - at: #brightGreen put: (Colour fromString: '#01ff07') ; - at: #darkPurple put: (Colour fromString: '#35063e') ; - at: #mauve put: (Colour fromString: '#ae7181') ; - at: #forestGreen put: (Colour fromString: '#06470c') ; - at: #aqua put: (Colour fromString: '#13eac9') ; - at: #cyan put: (Colour fromString: '#00ffff') ; - at: #tan put: (Colour fromString: '#d1b26f') ; - at: #darkBlue put: (Colour fromString: '#00035b') ; - at: #lavender put: (Colour fromString: '#c79fef') ; - at: #turquoise put: (Colour fromString: '#06c2ac') ; - at: #darkGreen put: (Colour fromString: '#033500') ; - at: #violet put: (Colour fromString: '#9a0eea') ; - at: #lightPurple put: (Colour fromString: '#bf77f6') ; - at: #limeGreen put: (Colour fromString: '#89fe05') ; - at: #grey put: (Colour fromString: '#929591') ; - at: #skyBlue put: (Colour fromString: '#75bbfd') ; - at: #yellow put: (Colour fromString: '#ffff14') ; - at: #magenta put: (Colour fromString: '#c20078') ; - at: #lightGreen put: (Colour fromString: '#96f97b') ; - at: #orange put: (Colour fromString: '#f97306') ; - at: #teal put: (Colour fromString: '#029386') ; - at: #lightBlue put: (Colour fromString: '#95d0fc') ; - at: #red put: (Colour fromString: '#e50000') ; - at: #brown put: (Colour fromString: '#653700') ; - at: #pink put: (Colour fromString: '#ff81c0') ; - at: #blue put: (Colour fromString: '#0343df') ; - at: #green put: (Colour fromString: '#15b01a') ; - at: #purple put: (Colour fromString: '#7e1e9c') ; - yourself. - - ^xkcdDict - -! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - blueColorDict - "Answer a dictionary of named colors considered Blue" -" - Color blueColorDict explore. -" - ^self blueColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - blueColorDict: aColorDict - "Answer a dictionary of named colors considered Blue" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isBlue) - or: [assoc key asString asLowercase includesSubString: 'blue']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - blueGreenColorDict - "Answer a dictionary of named colors considered Blue" -" - Color blueGreenColorDict explore. -" - ^self blueGreenColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - blueGreenColorDict: aColorDict - "Answer a dictionary of named colors considered Blue" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isBlueGreen) - or: [assoc key asString asLowercase includesSubString: 'bluegreen']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - brightColorDict - "Answer a dictionary of named colors considered Bright" -" - Color brightColorDict explore. -" - ^self brightColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - brightColorDict: aColorDict - "Answer a dictionary of named colors considered Bright" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - (assoc value isBright) ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - brownColorDict - "Answer a dictionary of named colors considered Brown" -" - Color brownColorDict explore. -" - ^self brownColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - brownColorDict: aColorDict - "Answer a dictionary of named colors considered Brown" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isBrown) - or: [assoc key asString asLowercase includesSubString: 'brown']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - darkColorDict - "Answer a dictionary of named colors considered Dark" -" - Color darkColorDict explore. -" - ^self darkColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - darkColorDict: aColorDict - "Answer a dictionary of named colors considered Dark" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - (assoc value isDark) ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - grayColorDict: aColorDict - "Answer a dictionary of named colors considered Grey" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isGrey) - or: [assoc key asString asLowercase includesSubString: 'grey']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - greenColorDict - "Answer a dictionary of named colors considered Green" -" - Color greenColorDict explore. -" - ^self greenColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - greenColorDict: aColorDict - "Answer a dictionary of named colors considered Green" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isGreen) - or: [assoc key asString asLowercase includesSubString: 'green']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - greyColorDict - "Answer a dictionary of named colors considered Grey" -" - Color greyColorDict explore. -" - ^self greyColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - greyColorDict: aColorDict - "Answer a dictionary of named colors considered Grey" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isGrey) - or: [assoc key asString asLowercase includesSubString: 'grey']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - lightColorDict - "Answer a dictionary of named colors considered light" -" - Color lightColorDict explore. -" - ^self lightColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - lightColorDict: aColorDict - "Answer a dictionary of named colors considered Liight" - - ^self brightColorDict: aColorDict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - orangeColorDict - "Answer a dictionary of named colors considered Orange" -" - Color orangeColorDict explore. -" - ^self orangeColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - orangeColorDict: aColorDict - "Answer a dictionary of named colors considered Orange" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isOrange) - or: [assoc key asString asLowercase includesSubString: 'orange']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - pastelColorDict - "Answer a dictionary of named colors considered Pastel" -" - Color pastelColorDict explore. -" - ^self pastelColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - pastelColorDict: aColorDict - "Answer a dictionary of named colors considered Bright" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - (assoc value isPastel) ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - pinkColorDict - "Answer a dictionary of named colors considered Pink" -" - Color pinkColorDict explore. -" - ^self pinkColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - pinkColorDict: aColorDict - "Answer a dictionary of named colors considered Pink" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isPink) - or: [assoc key asString asLowercase includesSubString: 'pink']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - purpleColorDict - "Answer a dictionary of named colors considered Purple" -" - Color purpleColorDict explore. -" - ^self purpleColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - purpleColorDict: aColorDict - "Answer a dictionary of named colors considered Pink" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc key asString asLowercase includesSubString: 'purple') - or: [assoc key asString asLowercase includesSubString: 'violet']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - redColorDict - "Answer a dictionary of named colors considered Red" -" - Color redColorDict explore. -" - ^self redColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - redColorDict: aColorDict - "Answer a dictionary of named colors considered Red" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isRed) - or: [assoc key asString asLowercase includesSubString: 'red']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - saturatedColorDict - "Answer a dictionary of named colors considered Saturated" -" - Color saturatedColorDict explore. -" - ^self saturatedColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - saturatedColorDict: aColorDict - "Answer a dictionary of named colors considered Saturated" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - (assoc value isSaturated) ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - yellowColorDict - "Answer a dictionary of named colors considered Yellow" -" - Color yellowColorDict explore. -" - ^self yellowColorDict: (self colorNamesDict)! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - yellowColorDict: aColorDict - "Answer a dictionary of named colors considered Yellow" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isYellow) - or: [assoc key asString asLowercase includesSubString: 'yellow']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'color space conversions' stamp: 'jmv 6/18/2017 20:10:01'! - applySimpleGamma: gamma to: value - "Encode / decode Gamma. Typical gamma are 0.4545 ( = 1.0 / 2.2, for encoding) and 2.2 (for decoding) - In a non gamma encoded image, the pixel values are proportional to luminance, i.e. the actual light intensity, the photon count. - In an gamma encoded image, the pixel value is close to the average perceived brightness, or 'lightness'. This optimizes the use of available bits in digital images, and dynamic range in analog images and film. This is like the 'luma' signal in video. - - Usually: - - Images stored in file formats such as jpg, png, tiff and bmp are gamma encoded - (unless they are actually raw images). - - Images sent to a framebuffer (video memory) should be gamma encoded. - - Raw images from sensors are not gamma encoded. - - - Image processing algorithms that simulate the real world, or are applied to real world data should work on unencoded (linear) images. - This includes filtering, resizing, blending, and most operations done on images. - This means that if the images come from jpg photos from a camera, they should be gamma decoded. - - Image processing algorithms that works on human perception should work on gamma encoded images. - This includes histograms, histogram equalization, bit allocation (i.e. quantization), compression, etc. - This also includes detecting objects like a human would do - - - See - http://en.wikipedia.org/wiki/Gamma_correction - http://www.poynton.com/notes/colour_and_gamma/GammaFAQ.html - - Mostly for documentation. - value must be in [0.0 .. 1.0]. - Note that the sRGB standard specifies a function that is close to this, but slightly different. - See #linearTosRGBGamma: and #sRGBGammaToLinear:" - - ^ value raisedTo: gamma! ! -!Colour class methodsFor: 'color space conversions' stamp: 'jmv 6/18/2017 20:10:01'! - linearTosRGBGamma: value - "The sRGB standard specifies a gamma curve that is close to gamma = 2.2, but is actually - built from one stright line segment, and a curve with exponent = 2.4. - This method converts value from linearSpace to gammaSpace, i.e. it 'encodes' with gamma. - This is the operation done when producing an 8bit Form for displaying, or for saving on a JPG, PNG, etc; if source data is in linear space (for example, from raw data a sensor image, or data that was converted previously to linear space for proper image processing). - value must be in [0.0 .. 1.0]. - - See - http://en.wikipedia.org/wiki/Gamma_correction - http://www.poynton.com/notes/colour_and_gamma/GammaFAQ.html - http://entropymine.com/imageworsener/srgbformula - - | r v | - r _ Random new. - 1000 timesRepeat: [ - v _ r next. - self assert: ((Color sRGBGammaToLinear: (Color linearTosRGBGamma: v)) closeTo: v) ] - - | r | - r _ 10@10 extent: 600@400. - Display fill: r fillColor: Color white. - FFT new plot: ((0.0 to: 1.0 count: 100) collect: [ :v | Color linearTosRGBGamma: v ]) in: r color: Color black min: 0.0 max: 1.0. - FFT new plot: ((0.0 to: 1.0 count: 100) collect: [ :v | Color applySimpleGamma: 1/2.2 to: v ]) in: r color: Color blue min: 0.0 max: 1.0. - FFT new plot: ((0.0 to: 1.0 count: 100) collect: [ :v | Color sRGBGammaToLinear: v ]) in: r color: Color black min: 0.0 max: 1.0. - FFT new plot: ((0.0 to: 1.0 count: 100) collect: [ :v | Color applySimpleGamma: 2.2 to: v ]) in: r color: Color blue min: 0.0 max: 1.0. - " - - ^ value <= 0.00313066844250063 - ifTrue: [ value * 12.92 ] - ifFalse: [ (value raisedTo: 1.0/2.4) * 1.055 - 0.055 ]! ! -!Colour class methodsFor: 'color space conversions' stamp: 'jmv 6/18/2017 20:10:01'! - sRGBGammaToLinear: value - "The sRGB standard specifies a gamma curve that is close to gamma = 2.2, but is actually - built from one stright line segment, and a curve with exponent = 2.4. - This method converts value from gammaSpace to linearSpace, i.e. it 'decodes'. - This is the operation done by display screens. It is also needed to convert 8bit Forms (from a frameBuffer, or from PNG, JPG, etc.) to linear space for proper image processing. - value must be in [0.0 .. 1.0]. - - See - http://en.wikipedia.org/wiki/Gamma_correction - http://www.poynton.com/notes/colour_and_gamma/GammaFAQ.html - http://entropymine.com/imageworsener/srgbformula - " - - ^ value <= 0.0404482362771082 - ifTrue: [ value / 12.92 ] - ifFalse: [ value + 0.055 / 1.055 raisedTo: 2.4 ]! ! -!Colour class methodsFor: 'cached state access' stamp: 'jmv 6/18/2017 20:10:01'! - colorNamesDict - "Answer the current dictionary of name->color associations." -" - Color colorNamesDict explore. -" - ColorNamesDict ifNil: [ - self setColorNamesDict: self defaultColorNamesDictionary ]. - ^ColorNamesDict! ! -!Colour class methodsFor: 'cached state access' stamp: 'jmv 6/18/2017 20:10:01'! - grayToIndexMap - " - Color grayToIndexMap explore. - " - GrayToIndexMap ifNil: [ - self initializeGrayToIndexMap ]. - ^GrayToIndexMap! ! -!Colour class methodsFor: 'cached state access' stamp: 'jmv 6/18/2017 20:10:01'! - indexedColors - " - Color indexedColors explore. - " - IndexedColors ifNil: [ - self initializeIndexedColors ]. - ^IndexedColors! ! -!Colour class methodsFor: 'cached state access' stamp: 'jmv 6/18/2017 20:10:01'! - releaseClassCachedState - " - Color releaseClassCachedState - " - CachedColormaps _ nil. "Maps to translate between color depths" - ToGrayColormaps _ nil. "Maps colors to 8bpp grays for various color depths" - FromGrayColormaps _ nil. "Maps from 8bpp grays to colors of various depths" - MaskingMap _ nil. "Maps all colors except transparent to black for creating a mask" - ColorNamesDict _ nil. - IndexedColors _ nil. - GrayToIndexMap _ nil! ! -!TranslucentColour methodsFor: 'accessing' stamp: 'jmv 6/18/2017 20:41:17'! - alpha - "Return my alpha value, a number between 0.0 and 1.0 where 0.0 is completely transparent and 1.0 is completely opaque." - - ^ self at: 4! ! -!TranslucentColour methodsFor: 'printing' stamp: 'jmv 6/18/2017 20:10:08'! - storeArrayValuesOn: aStream - - self isTransparent ifTrue: [ - ^ aStream space]. - super storeArrayValuesOn: aStream. - aStream space. - self alpha printOn: aStream fractionDigits: 3! ! -!TranslucentColour methodsFor: 'printing' stamp: 'jmv 6/18/2017 20:10:08'! -storeOn: aStream - - self isTransparent ifTrue: [^ aStream nextPutAll: '(Color transparent)']. - aStream - nextPut: $(; - nextPutAll: self class name; - nextPutAll: ' r: '. - self red printOn: aStream fractionDigits: 3. - aStream nextPutAll: ' g: '. - self green printOn: aStream fractionDigits: 3. - aStream nextPutAll: ' b: '. - self blue printOn: aStream fractionDigits: 3. - aStream nextPutAll: ' alpha: '. - self alpha printOn: aStream fractionDigits: 3. - aStream nextPutAll: ')'! ! -!TranslucentColour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:55:03'! - alpha: alphaValue - "Return a new TranslucentColor with the given amount of opacity ('alpha')." - alphaValue = 1.0 ifTrue: [ - ^ Colour new - setRed: self red - green: self green - blue: self blue]. - ^ super alpha: alphaValue! ! -!TranslucentColour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:08'! - asNontranslucentColor - ^ self alpha: 1.0! ! -!TranslucentColour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:08'! - bitPatternForDepth: depth - "Return an appropriate bit pattern. This will almost never be meaningful for tranlucentColors, except for the degenerate case of tranparency." - - self isTransparent ifTrue: [ - ^ Bitmap with: 0]. - ^ super bitPatternForDepth: depth! ! -!TranslucentColour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:41:47'! - pixelValueForDepth: d - "Return the pixel value for this color at the given depth. Translucency only works in RGB; this color will appear either opaque or transparent at all other depths." - | basicPixelWord | - "In 32bpp, if alpha = 0, ignore any color components, and answer R=0, G=0, B=0, Alpha=0. - In depths > 8 and < 32, pixelValue zero is the special value used by BitBlt to denote transparent." - self isTransparent ifTrue: [ - ^ 0]. - basicPixelWord _ super pixelValueForDepth: d. - ^d < 32 - ifTrue: [ basicPixelWord ] - ifFalse: [ (basicPixelWord bitAnd: 16rFFFFFF) bitOr: - ((self alpha*255.0) rounded - bitShift: 24) ]! ! -!TranslucentColour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:41:50'! - pixelWordForDepth: depth - "Return the pixel value for this color at the given depth. Translucency only works in RGB; this color will appear either opaque or transparent at all other depths." - - | basicPixelWord | - self isTransparent ifTrue: [^ 0]. - basicPixelWord _ super pixelWordForDepth: depth. - ^depth < 32 - ifTrue: [ basicPixelWord ] - ifFalse: [ (basicPixelWord bitAnd: 16rFFFFFF) bitOr: - ((self alpha*255.0) rounded - bitShift: 24) ]! ! -!TranslucentColour methodsFor: 'private' stamp: 'jmv 6/18/2017 20:42:05'! - setRed: r green: g blue: b alpha: alphaValue - - self basicSetRed: r green: g blue: b. - self at: 4 put: alphaValue! ! -!TranslucentColour methodsFor: 'queries' stamp: 'jmv 6/18/2017 20:41:26'! - isOpaque - - ^self alpha = 1.0! ! -!TranslucentColour methodsFor: 'queries' stamp: 'jmv 6/18/2017 20:41:54'! - isTransparent - ^ self alpha = 0.0! ! -!TranslucentColour methodsFor: 'please remove' stamp: 'jmv 6/18/2017 21:27:51'! - setRed: r green: g blue: b alpha: alphaValue colorSpace: aSymbol - ^ self setRed: r green: g blue: b alpha: alphaValue! ! -!TranslucentColour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:54:35'! - new - ^ self new: 4! ! -!TranslucentColour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:57:08'! - r: r g: g b: b alpha: alphaValue - "Return a color with the given r, g, and b components in the range [0.0..1.0]." - - ^ self new - setRed: r - green: g - blue: b - alpha: alphaValue! ! -!FloatArray methodsFor: 'comparing' stamp: 'jmv 6/18/2017 20:25:14' prior: 16846542! - = another - self == another ifTrue: [ ^ true ]. - self class == another class ifFalse: [ ^ false ]. - ^self primitiveEqual: another! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3105-FloatArrayColour-JuanVuletich-2017Jun19-09h57m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3103] on 19 June 2017 at 11:11:02 am'! -!Integer methodsFor: 'converting' stamp: 'ar 10/31/1998 23:04' prior: 16859466! - asColorOfDepth: d - "Return a color value representing the receiver as color of the given depth" - ^Colour colorFromPixelValue: self depth: d! ! -!InputSensor methodsFor: 'keyboard' stamp: 'jmv 9/2/2016 11:08:09' prior: 16856307! - kbdTest - " - Sensor kbdTest - " - "This test routine will print the unmodified character, its keycode, - and the OR of all its modifier bits, until the character x is typed - -Also useful: - Sensor test - " - | char | - char _ nil. - [ char = $x ] whileFalse: [ - [ self keyboardPressed ] whileFalse. - char _ self keyboard. - Display fill: (5@5 extent: 400@20) fillColor: Colour white. - (String streamContents: [ :s | - s - nextPut: $-; - nextPut: char; - nextPut: $-; - space; - print: char numericValue; - space. - self isMouseButton3Pressed ifTrue: [ s nextPutAll: ' mouseButton3/blue/tertiary/halo ' ]. - self isMouseButton2Pressed ifTrue: [ s nextPutAll: ' mouseButton2/yellow/secondary/menu ' ]. - self isMouseButton1Pressed ifTrue: [ s nextPutAll: ' mouseButton1/red/primary ' ]. - self shiftPressed ifTrue: [ s nextPutAll: ' shift ' ]. - self controlKeyPressed ifTrue: [ s nextPutAll: ' control/ctrl ' ]. - (self primMouseButtons anyMask: 32) ifTrue: [ s nextPutAll: ' macOption ' ]. - self commandAltKeyPressed ifTrue: [ s nextPutAll: ' macCommand/winAlt ' ]]) - displayAt: 10 @ 10 ].! ! -!String methodsFor: 'displaying' stamp: 'jmv 5/12/2015 15:52' prior: 16917036! - 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: Colour black - " - 'Display' displayOn: Display at: 10@10 - "! ! -!SystemDictionary methodsFor: 'shrinking' stamp: 'jmv 4/25/2016 15:31' prior: 16922270! - reduceCuis - " - Smalltalk reduceCuis - " - | keep n unused newDicts oldDicts | - - self nominallyUnsent: #reduceCuis. - - "Remove icons" - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - PasteUpMorph allInstancesDo: [ :w | - w backgroundImageData: nil. - w submorphsDo: [ :a | a delete ]]. - Preferences useNoIcons. - Theme current initialize. - Theme content: nil. - Colour shutDown. - BitBltCanvas releaseClassCachedState. - - Transcript clear. - Clipboard default initialize. - - - "Remove some methods, even if they have senders." -" ColorPickerMorph class removeSelector: #buildEyedropperIcon." - Theme removeSelector: #miscellaneousIcons. - Utilities removeSelector: #vmStatisticsReportString. - SystemDictionary removeSelector: #recreateSpecialObjectsArray. - - StrikeFont removeMostFonts. - StrikeFont saveSpace. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - - keep := OrderedCollection new. - keep addAll: #(SpaceTally). - AppLauncher appGlobalName ifNotNil: [ :any | - keep add: any ]. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - [ - #hereWeGo print. - unused do: [:c | - c print. - (Smalltalk at: c) removeFromSystem]. - n := Smalltalk removeAllUnSentMessages. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - n > 0 or: [ - unused notEmpty ]] whileTrue. - ChangeSet zapAllChangeSets. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - Symbol rehash. - - "Shrink method dictionaries." - Smalltalk garbageCollect. - oldDicts _ MethodDictionary allInstances. - newDicts _ Array new: oldDicts size. - oldDicts withIndexDo: [:d :index | - newDicts at: index put: d rehashWithoutBecome ]. - oldDicts elementsExchangeIdentityWith: newDicts. - oldDicts _ newDicts _ nil. - - SmalltalkCompleter initialize . - - "Sanity checks" -" Undeclared - Smalltalk cleanOutUndeclared - Smalltalk browseUndeclaredReferences - Smalltalk obsoleteClasses - Smalltalk obsoleteBehaviors - Smalltalk browseObsoleteMethodReferences - SmalltalkImage current fixObsoleteReferences - Smalltalk browseAllUnimplementedCalls"! ! -!Transcripter methodsFor: 'accessing' stamp: 'jmv 7/28/2015 08:26' prior: 16938828! - 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]. - textComposition - setModel: (TextModel withText: c asText); - extentForComposing: frame width-8 @9999. - textComposition composeAll. - d _ textComposition usedHeight - frame height. - d > 0 ifTrue: [ - "Scroll up to keep all contents visible" - cb _ textComposition characterBlockAtPoint: - 0@0 + (0@(d+AbstractFont default height)). - self on: (c copyFrom: cb stringIndex to: c size). - readLimit _ position _ collection size. - ^ self endEntry]. - Display fill: (frame insetBy: -2) fillColor: self black; - fill: frame fillColor: self white. - Display getCanvas - textComposition: textComposition - bounds: (4@4 + frame topLeft extent: Display extent) - color: Colour black - selectionColor: Colour blue. - DisplayScreen screenUpdateRequired: nil! ! -!Transcripter methodsFor: 'private' stamp: 'di 8/14/97 12:12' prior: 16938904! - black - Display depth = 1 ifTrue: [^ Bitmap with: 16rFFFFFFFF "Works without color support"]. - ^ Colour black! ! -!Transcripter methodsFor: 'private' stamp: 'di 8/14/97 12:12' prior: 16938910! - white - Display depth = 1 ifTrue: [^ Bitmap with: 0 "Works without color support"]. - ^ Colour white! ! -!DataStream class methodsFor: 'as yet unclassified' stamp: '' prior: 16827931! - example - "An example and test of DataStream/ReferenceStream. - 11/19/92 jhm: Use self testWith:." - "DataStream example" - "ReferenceStream example" - | input sharedPoint | - - "Construct the test data." - input _ Array new: 9. - input at: 1 put: nil. - input at: 2 put: true. - input at: 3 put: (Form extent: 63 @ 50 depth: 8). - (input at: 3) fillWithColor: Colour lightBlue. - input at: 4 put: #(3 3.0 'three'). - input at: 5 put: false. - input at: 6 put: 1024 @ -2048. - input at: 7 put: #x. - input at: 8 put: (Array with: (sharedPoint _ 0 @ -30000)). - input at: 9 put: sharedPoint. - - "Write it out, read it back, and return it for inspection." - ^ self testWith: input! ! -!ReferenceStream class methodsFor: 'as yet unclassified' stamp: '' prior: 16900040! - example2 -"Here is the way to use DataStream and ReferenceStream: - rr _ ReferenceStream fileNamed: ''test.obj''. - rr nextPut: . - rr close. - -To get it back: - rr _ ReferenceStream fileNamed: ''test.obj''. - _ rr next. - rr close. -" -"An example and test of DataStream/ReferenceStream. - 11/19/92 jhm: Use self testWith:." - "ReferenceStream example2" - | input sharedPoint | - - "Construct the test data." - input _ Array new: 9. - input at: 1 put: nil. - input at: 2 put: true. - input at: 3 put: false. - input at: 4 put: #(-4 -4.0 'four' four). - input at: 5 put: (Form extent: 63 @ 50 depth: 8). - (input at: 5) fillWithColor: Colour lightOrange. - input at: 6 put: 1024 @ -2048. - input at: 7 put: input. "a cycle" - input at: 8 put: (Array with: (sharedPoint _ 0 @ -30000)). - input at: 9 put: sharedPoint. - - "Write it out, read it back, and return it for inspection." - ^ self testWith: input -! ! -!TextEditor methodsFor: 'attributes' stamp: 'jmv 6/18/2017 21:32:55' prior: 16931569! - offerColorMenu - "Present a menu of available colors, and if one is chosen, apply it to the current selection." - "This is a user command, and generates undo" - - | attribute colors index thisSel | - thisSel _ self selection. - colors _ #(#black #magenta #red #yellow #green #blue #cyan #white ). - index _ (PopUpMenu - labelArray: colors , #('choose color...' ) - lines: (Array with: colors size + 1)) startUpMenu. - index = 0 ifTrue: [ ^ true ]. - index <= colors size - ifTrue: [ attribute _ TextColor color: (Colour perform: (colors at: index)) ] - ifFalse: [ - index _ index - colors size - 1. - "Re-number!!!!!!" - index = 0 ifTrue: [ attribute _ self chooseColor ]. - thisSel ifNil: [ ^ true ]]. - attribute ifNotNil: [ self applyAttribute: attribute ]. - ^ true.! ! -!TextAction class methodsFor: 'as yet unclassified' stamp: 'jmv 4/19/2015 09:38' prior: 16930008! - textActionColor - ^Colour r: 0.4 g: 0 b: 1.0! ! -!TextColor methodsFor: 'testing' stamp: 'jmv 1/21/2011 11:33' prior: 16930362! - isSet - "Do not include Colour black, as it is the default color." - ^color ~= Colour black! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 16930372! - black - ^ self new color: Colour black! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 16930375! - blue - ^ self new color: Colour blue! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 16930378! - cyan - ^ self new color: Colour cyan! ! -!TextColor class methodsFor: 'constants' stamp: 'ajh 9/10/2002 02:26' prior: 16930382! - gray - ^ self new color: Colour gray! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 16930385! - green - ^ self new color: Colour green! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 16930388! - magenta - ^ self new color: Colour magenta! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 16930391! - red - ^ self new color: Colour red! ! -!TextColor class methodsFor: 'constants' stamp: 'sma 3/24/2000 10:50' prior: 16930395! - white - ^ self new color: Colour white! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 16930398! - yellow - ^ self new color: Colour yellow! ! -!Preferences class methodsFor: 'halos' stamp: 'jmv 6/18/2017 21:33:44' prior: 16893209! - installHaloSpecsFromArray: anArray - - | aColour | - ^ self parameters at: #HaloSpecs put: (anArray collect: [ :each | - aColour _ Colour. - each fourth do: [ :sel | aColour _ aColour perform: sel]. - HaloSpec new - horizontalPlacement: each second - verticalPlacement: each third - color: aColour - iconSymbol: each fifth - addHandleSelector: each first - hoverHelp: each sixth])! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 9/19/2016 20:45:55' prior: 16938476! - displayOn: aForm in: aRectangle - " - Transcript displayOn: Display - " - | font count i string x y fh f canvas innerR | - aForm fill: aRectangle fillColor: Colour white. - font _ AbstractFont default. - - innerR _ aRectangle insetBy: self padding. - fh _ font height. - count _ innerR height // fh-1. - x _ innerR left. - y _ innerR top. - f _ firstIndex-1. - firstIndex > lastIndex ifTrue: [ f _ f - self maxEntries ]. - i _ (lastIndex - count max: f) \\ self maxEntries + 1. - canvas _ aForm getCanvas. - canvas newClipRect: innerR. - [ - string _ entries at: i. - canvas drawString: string at: x@y font: font color: Colour veryDarkGray. - y _ y + fh. - i = lastIndex - ] whileFalse: [ i _ i \\ self maxEntries + 1 ]. - - string _ unfinishedEntry contents. - canvas drawString: string at: x@y font: font color: Colour veryDarkGray! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 9/19/2016 20:53:35' prior: 16938512! - displayUnfinishedEntryOn: aForm - - | font count string x y fh canvas r innerR | - innerR _ bounds insetBy: self padding. - lastDisplayPosition < innerR right ifTrue: [ - font _ AbstractFont default. - fh _ font height. - count _ innerR height // fh-1. - x _ innerR left. - string _ unfinishedEntry contents. - y _ ((lastIndex - firstIndex \\ self maxEntries) min: count-1) + 1 * font height + innerR top. - canvas _ aForm getCanvas. - r _ innerR left: lastDisplayPosition. - canvas newClipRect: r. - (canvas drawString: string at: x@y font: font color: Colour veryDarkGray) ifNotNil: [ :lastPoint | - lastDisplayPosition _ lastPoint x. - ^r ]]. - ^nil! ! -!Form methodsFor: 'analyzing' stamp: 'ar 5/17/2001 15:40' prior: 16846838! - dominantColor - | tally max maxi | - self depth > 16 ifTrue: - [^(self asFormOfDepth: 16) dominantColor]. - tally _ self tallyPixelValues. - max _ maxi _ 0. - tally withIndexDo: [:n :i | n > max ifTrue: [max _ n. maxi _ i]]. - ^ Colour colorFromPixelValue: maxi - 1 depth: self depth! ! -!Form methodsFor: 'bordering' stamp: 'jmv 1/22/2015 10:22' prior: 16847019! - border: aRectangle width: borderWidth - "Paint a border whose rectangular area is defined by aRectangle. The - width of the border of each side is borderWidth. Uses black for - drawing the border." - - self border: aRectangle width: borderWidth fillColor: Colour black! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:20' prior: 16847087! - fillBlack - "Set all bits in the receiver to black (ones)." - - self fill: self boundingBox fillColor: Colour black! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:20' prior: 16847093! - fillBlack: aRectangle - "Set all bits in the receiver's area defined by aRectangle to black (ones)." - - self fill: aRectangle rule: Form over fillColor: Colour black! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:20' prior: 16847109! - fillGray - "Set all bits in the receiver to gray." - - self fill: self boundingBox fillColor: Colour gray! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:20' prior: 16847115! - fillGray: aRectangle - "Set all bits in the receiver's area defined by aRectangle to the gray mask." - - self fill: aRectangle rule: Form over fillColor: Colour gray! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:21' prior: 16847146! - fillWhite - "Set all bits in the form to white." - - self fill: self boundingBox fillColor: Colour white! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:21' prior: 16847152! - fillWhite: aRectangle - "Set all bits in the receiver's area defined by aRectangle to white." - - self fill: aRectangle rule: Form over fillColor: Colour white! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:21' prior: 16847165! - reverse - "Change all the bits in the receiver that are white to black, and the ones - that are black to white. - Display reverse - " - - self fill: self boundingBox rule: Form reverse fillColor: Colour white! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:21' prior: 16847174! - reverse: aRectangle - "Change all the bits in the receiver's area that intersects with aRectangle - that are white to black, and the ones that are black to white." - - self fill: aRectangle rule: Form reverse fillColor: Colour white! ! -!Form methodsFor: 'color mapping' stamp: 'ar 5/17/2001 15:42' prior: 16847212! - colormapIfNeededForDepth: destDepth - "Return a colormap for displaying the receiver at the given depth, or nil if no colormap is needed." - - self depth = destDepth ifTrue: [^ nil]. "not needed if depths are the same" - ^ Colour colorMapIfNeededFrom: self depth to: destDepth -! ! -!Form methodsFor: 'color mapping' stamp: 'jmv 5/12/2016 13:53' prior: 16847223! - colormapIfNeededForGray8bpp - "Return a colormap for displaying the receiver at the given depth. - Note: Uses 5 bits per color component. 32bit Forms will lose information!!" - - ^ Colour cachedColormapForGrayFrom: self depth! ! -!Form methodsFor: 'color mapping' stamp: 'jmv 6/18/2017 21:31:52' prior: 16847240! - mapColor: oldColour to: newColor - "Make all pixels of the given color in this Form to the given new color." - "Warnings: This method modifies the receiver. It may lose some color accuracy on 32-bit Forms, since the transformation uses a color map with only 15-bit resolution." - - | map | - map _ (Colour cachedColormapFrom: self depth to: self depth) copy. - map at: (oldColour indexInMap: map) put: (newColor pixelWordForDepth: self depth). - (BitBlt toForm: self) - sourceForm: self; - sourceOrigin: 0@0; - combinationRule: Form over; - destX: 0 destY: 0 width: width height: height; - colorMap: map; - copyBits. -! ! -!Form methodsFor: 'color mapping' stamp: 'jmv 1/31/2011 09:21' prior: 16847262! - maskingMap - "Return a color map that maps all colors except transparent to words of all ones. Used to create a mask for a Form whose transparent pixel value is zero." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Colour maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - ^Colour maskingMap: self depth! ! -!Form methodsFor: 'converting' stamp: 'jm 11/12/97 19:28' prior: 16847299! - as8BitColorForm - "Simple conversion of zero pixels to transparent. Force it to 8 bits." - - | f map | - f _ ColorForm extent: self extent depth: 8. - self displayOn: f at: self offset negated. - map _ Colour indexedColors copy. - map at: 1 put: Colour transparent. - f colors: map. - f offset: self offset. - ^ f -! ! -!Form methodsFor: 'pixel access' stamp: 'ar 5/17/2001 15:42' prior: 16848158! - colorAt: aPoint - "Return the color in the pixel at the given point. " - - ^ Colour - colorFromPixelValue: (self pixelValueAt: aPoint) - depth: self depth -! ! -!Form methodsFor: 'pixel access' stamp: 'jmv 11/4/2015 12:40' prior: 16848175! - colorInterpolatedAt: aPoint - "Evaluate a bilinear (i.e. cheap) interpolation - Like OpenCV's CV_INTER_LINEAR - Answer Colour transparent if outside image bounds. - Copied almost verbatim from FloatImage. - Answer Colors with float components. Will be rounded to be stored in, for example, a 32-bit Form." - - | x y w interpolated xWeight1 xWeight0 yWeight1 yWeight0 xIndex0 xIndex1 yIndex0 yIndex1 | - x _ aPoint x. - y _ aPoint y. - x < 0.0 ifTrue: [ ^Colour transparent ]. - xIndex0 _ x truncated. "Could be #floor. But as we only care for values >=0, it is the same. But faster." - xIndex0 > (width-1) ifTrue: [ ^Colour transparent ]. - (xIndex0 = (width-1) and: [ x > (width-1) ]) ifTrue: [ ^Colour transparent ]. - xIndex1 _ xIndex0 = (width-1) "Avoid the invalid access if this was true, but don't make it slower the most common, general case." - ifFalse: [ xIndex0 + 1 ] - ifTrue: [ xIndex0 ]. - - y < 0.0 ifTrue: [ ^Colour transparent ]. - yIndex0 _ y truncated. "Could be #floor. But as we only care for values >=0, it is the same. But faster." - yIndex0 > (height-1) ifTrue: [ ^Colour transparent ]. - (yIndex0 = (height-1) and: [ y > (height-1) ]) ifTrue: [ ^Colour transparent ]. - yIndex1 _ yIndex0 = (height-1) "Avoid the invalid access if this was true, but don't make it slower the most common, general case." - ifFalse: [ yIndex0 + 1 ] - ifTrue: [ yIndex0 ]. - - xWeight1 _ x - xIndex0. - xWeight0 _ 1.0 - xWeight1. - - yWeight1 _ y - yIndex0. - yWeight0 _ 1.0 - yWeight1. - - "/* perform interpolation */" - w _ ((self colorAt: xIndex0 @ yIndex0) * xWeight0) + - ((self colorAt: xIndex1 @ yIndex0) * xWeight1). - interpolated _ w * yWeight0. - - w _ ((self colorAt: xIndex0 @ yIndex1) * xWeight0) + - ((self colorAt: xIndex1 @ yIndex1) * xWeight1). - interpolated _ w * yWeight1 + interpolated. - - ^interpolated! ! -!Form methodsFor: 'transitions' stamp: 'jmv 7/28/2015 08:32' prior: 16848519! - pageWarp: otherImage at: topLeft forward: forward - "Produce a page-turning illusion that gradually reveals otherImage - located at topLeft in this form. - forward == true means turn pages toward you, else away. [ignored for now]" - | pageRect oldPage nSteps buffer p leafRect sourceQuad warp oldBottom d | - pageRect _ otherImage boundingBox. - oldPage _ self copy: (pageRect translatedBy: topLeft). - (forward ifTrue: [oldPage] ifFalse: [otherImage]) - border: pageRect - widthRectangle: (Rectangle - left: 0 - right: 2 - top: 1 - bottom: 1) - rule: Form over - fillColor: Colour black. - oldBottom _ self copy: ((pageRect bottomLeft + topLeft) extent: (pageRect width@(pageRect height//4))). - nSteps _ 8. - buffer _ Form extent: otherImage extent + (0@(pageRect height//4)) depth: self depth. - d _ pageRect topLeft + (0@(pageRect height//4)) - pageRect topRight. - 1 to: nSteps-1 do: - [:i | forward - ifTrue: [buffer copy: pageRect from: otherImage to: 0@0 rule: Form over. - p _ pageRect topRight + (d * i // nSteps)] - ifFalse: [buffer copy: pageRect from: oldPage to: 0@0 rule: Form over. - p _ pageRect topRight + (d * (nSteps-i) // nSteps)]. - buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over. - leafRect _ pageRect topLeft corner: p x @ (pageRect bottom + p y). - sourceQuad _ Array with: pageRect topLeft - with: pageRect bottomLeft + (0@p y) - with: pageRect bottomRight - with: pageRect topRight - (0@p y). - warp _ (WarpBlt toForm: buffer) - clipRect: leafRect; - sourceForm: (forward ifTrue: [oldPage] ifFalse: [otherImage]); - combinationRule: Form paint. - warp copyQuad: sourceQuad toRect: leafRect. - self copy: buffer boundingBox from: buffer to: topLeft rule: Form over. - Display forceToScreen. - ]. - - buffer copy: pageRect from: otherImage to: 0@0 rule: Form over. - buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over. - self copy: buffer boundingBox from: buffer to: topLeft rule: Form over. - Display forceToScreen. -" -1 to: 4 do: [:corner | Display pageWarp: - (Form fromDisplay: (10@10 extent: 200@300)) reverse - at: 10@10 forward: false] -" -! ! -!Form class methodsFor: 'instance creation' stamp: 'jmv 9/23/2012 21:44' prior: 16848886! - dotOfSize: diameter - "Create a form which contains a round black dot." - | radius form bb rect centerX centerY centerYBias centerXBias radiusSquared xOverY maxy dx | - radius _ diameter//2. - form _ self extent: diameter@diameter offset: (0@0) - (radius@radius). - bb _ (BitBlt toForm: form) - sourceX: 0; sourceY: 0; - combinationRule: Form over; - fillColor: Colour black. - rect _ form boundingBox. - centerX _ rect center x. - centerY _ rect center y. - centerYBias _ rect height odd ifTrue: [0] ifFalse: [1]. - centerXBias _ rect width odd ifTrue: [0] ifFalse: [1]. - radiusSquared _ (rect height asFloat / 2.0) squared - 0.01. - xOverY _ rect width asFloat / rect height asFloat. - maxy _ rect height - 1 // 2. - - "First do the inner fill, and collect x values" - 0 to: maxy do: - [:dy | - dx _ ((radiusSquared - (dy * dy) asFloat) sqrt * xOverY) truncated. - bb destX: centerX - centerXBias - dx - destY: centerY - centerYBias - dy - width: dx + dx + centerXBias + 1 - height: 1; - copyBits. - bb destY: centerY + dy; - copyBits]. - ^ form -" -Time millisecondsToRun: - [1 to: 20 do: [:i | (Form dotOfSize: i) displayAt: (i*20)@(i*20)]] -"! ! -!Form class methodsFor: 'instance creation' stamp: 'pb 5/4/2016 17:43' prior: 16849005! - fakeSphereAt: aPoint diameter: diameter color: aColor - "Create a form which contains a round black dot." - | bb rect d p | - bb _ GrafPort toForm: Display. - bb fillColor: aColor. - bb combinationRule: Form blend. - rect _ aPoint extent: diameter. - bb fillOval: rect. - p _ (diameter * 2 // 5) asPoint + aPoint. - #(2 3 4 5 6 ) do: [ :i | - "simulate facade by circles of gray" - bb fillColor: (Colour white alpha: 0.3). - d _ i * diameter // 10. - rect _ Rectangle - center: p - extent: d. - bb fillOval: rect ]. - DisplayScreen screenUpdateRequired: nil. -" - Form fakeSphereAt: 50@50 diameter: 30 color: (Colour red alpha: 0.5) -"! ! -!Form class methodsFor: 'examples' stamp: 'jmv 3/20/2013 22:36' prior: 16849178! - toothpaste: diam - " - Display restoreAfter: [Form toothpaste: 30] - " - "Not completely unlike the ST-80 implementation :) - Original comment: - Draws wormlike lines by laying down images of spheres. - See Ken Knowlton, Computer Graphics, vol. 15 no. 4 p352. - Draw with mouse button down; terminate by option-click." - | point queue color q colors colr colr2 | - colors _ Colour red wheel: 12. - color _ 8. - [ true ] whileTrue: [ - queue _ OrderedCollection new: 32. - 16 timesRepeat: [queue addLast: -40@-40]. - Sensor waitButton. - Sensor isMouseButton2Pressed ifTrue: [^ self]. - point _ Sensor mousePoint. - colr _ colors atWrap: (color _ color + 5). "choose increment relatively prime to colors size" - colr2 _ colr alpha: 0.3. - [Sensor isMouseButton1Pressed or: [queue size > 0]] whileTrue: [ - point _ point * 4 + Sensor mousePoint // 5. - point _ point. - Form fakeSphereAt: point diameter: diam color: colr. - (q _ queue removeFirst) ifNil: [^ self]. "exit" - Form fakeSphereAt: q diameter: diam color: colr2. - Sensor isMouseButton1Pressed ifTrue: [queue addLast: point]]]! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 5/15/2015 09:37' prior: 16849256! - bottomLeftCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - "Create and answer a Form for the bottomLeft corner of a rounded rectangle" - | f aaw topColor bottomColor l d c width dy | - topColor _ Colour white * gradientTopFactor. - bottomColor _ Colour white * gradientBottomFactor. - width _ r. - aaw _ 1.3. - f _ Form - extent: width @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: width - 1 - do: [ :x | - dy _ height - r - y. - dy > 0 - ifTrue: [ l _ 1.0 ] - ifFalse: [ - d _ (width - 1 - x @ dy) r. - l _ ((r - d max: 0.0) min: aaw) / aaw ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 5/15/2015 09:47' prior: 16849283! - bottomLeftCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor borderWidth: bw - "Create and answer a Form for the bottomLeft corner of a rounded rectangle" - | f aaw topColor bottomColor l d c width dy l1 l2 | - topColor _ Colour white * gradientTopFactor. - bottomColor _ Colour white * gradientBottomFactor. - width _ r. - aaw _ 1.3. - f _ Form - extent: width @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: width - 1 - do: [ :x | - dy _ height - r - y. - dy > 0 - ifTrue: [ l _ 1.0 ] - ifFalse: [ - d _ (width - 1 - x @ dy) r. - l1 _ ((r - d-1+aaw max: 0.0) min: aaw) / aaw. - l2 _ ((d - r+bw+aaw max: 0.0) min: aaw) / aaw. - l _ l1 min: l2. - ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 5/15/2015 09:38' prior: 16849314! - bottomRightCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - "Create and answer a Form for the bottomRight corner of a rounded rectangle" - | f aaw topColor bottomColor l d c width dy | - topColor _ Colour white * gradientTopFactor. - bottomColor _ Colour white * gradientBottomFactor. - width _ r. - aaw _ 1.3. - f _ Form - extent: width @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: width - 1 - do: [ :x | - dy _ height - r - y. - dy > 0 - ifTrue: [ l _ 1.0 ] - ifFalse: [ - d _ (x @ dy) r. - l _ ((r - d max: 0.0) min: aaw) / aaw ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 5/15/2015 09:41' prior: 16849341! - bottomRightCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor borderWidth: bw - "Create and answer a Form for the bottomLeft corner of a rounded rectangle" - | f aaw topColor bottomColor l d c width dy l1 l2 | - topColor _ Colour white * gradientTopFactor. - bottomColor _ Colour white * gradientBottomFactor. - width _ r. - aaw _ 1.3. - f _ Form - extent: width @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: width - 1 - do: [ :x | - dy _ height - r - y. - dy > 0 - ifTrue: [ l _ 1.0 ] - ifFalse: [ - d _ (x @ dy) r. - l1 _ ((r - d-1+aaw max: 0.0) min: aaw) / aaw. - l2 _ ((d - r+bw+aaw max: 0.0) min: aaw) / aaw. - l _ l1 min: l2. - ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 11/30/2010 10:34' prior: 16849371! - topLeftCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - "Create and answer a Form with a vertical gray gradient as specified for the topLeft corner of a rounded rectangle" - | f bw topColor bottomColor l d c w | - topColor _ Colour white * gradientTopFactor. - bottomColor _ Colour white * gradientBottomFactor. - w _ r. - bw _ 1.3. - f _ Form - extent: w @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: w - 1 - do: [ :x | - l _ 1.0. - y < r ifTrue: [ - d _ (w - 1 - x @ (w - 1 - y)) r. - l _ ((r - d max: 0.0) min: bw) / bw ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 11/30/2010 10:36' prior: 16849397! - topRightCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - "Create and answer a Form with a vertical gray gradient as specified for the topRight corner of a rounded rectangle" - | f bw topColor bottomColor l d c w | - topColor _ Colour white * gradientTopFactor. - bottomColor _ Colour white * gradientBottomFactor. - w _ r. - bw _ 1.3. - f _ Form - extent: w @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: w - 1 - do: [ :x | - l _ 1.0. - y < r ifTrue: [ - d _ (x @ (w - y - 1)) r. - l _ ((r - d max: 0.0) min: bw) / bw ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!ColorForm methodsFor: 'accessing' stamp: 'ar 5/17/2001 15:45' prior: 16818750! - colors: colorList - "Set my color palette to the given collection." - - | colorArray colorCount newColors | - colorList ifNil: [ - colors _ cachedDepth _ cachedColormap _ nil. - ^ self]. - - colorArray _ colorList asArray. - colorCount _ colorArray size. - newColors _ Array new: (1 bitShift: self depth). - 1 to: newColors size do: [:i | - i <= colorCount - ifTrue: [newColors at: i put: (colorArray at: i)] - ifFalse: [newColors at: i put: Colour transparent]]. - - colors _ newColors. - cachedDepth _ nil. - cachedColormap _ nil. -! ! -!ColorForm methodsFor: 'color manipulation' stamp: 'di 11/11/1998 13:20' prior: 16818824! - asGrayScale - "Return a grayscale ColorForm computed by mapping each color into its grayscale equivalent" - ^ self copy colors: - (colors collect: - [:c | c isTransparent ifTrue: [c] - ifFalse: [Colour gray: c luminance]])! ! -!ColorForm methodsFor: 'color manipulation' stamp: 'jmv 3/1/2010 09:41' prior: 16818834! - colormapIfNeededForDepth: destDepth - "Return a colormap for displaying the receiver at the given depth, or nil if no colormap is needed." - - | newMap | - colors ifNil: [ - "use the standard colormap" - ^ Colour colorMapIfNeededFrom: self depth to: destDepth]. - - (destDepth = cachedDepth and:[cachedColormap isColormap not]) - ifTrue: [^ cachedColormap]. - newMap _ Bitmap new: colors size. - 1 to: colors size do: [:i | - newMap - at: i - put: ((colors at: i) pixelValueForDepth: destDepth)]. - - cachedDepth _ destDepth. - ^ cachedColormap _ newMap. -! ! -!ColorForm methodsFor: 'private' stamp: 'ar 5/17/2001 15:44' prior: 16818940! - ensureColorArrayExists - "Return my color palette." - - colors ifNil: [ - self depth > 8 ifTrue: [^ self error: 'ColorForms only support depths up to 8 bits']. - self colors: (Colour indexedColors copyFrom: 1 to: (1 bitShift: self depth))]. -! ! -!ColorForm class methodsFor: 'as yet unclassified' stamp: 'jmv 4/10/2015 23:20' prior: 16819047! - mappingWhiteToTransparentFrom: aFormOrCursor - "Return a ColorForm copied from the given Form or Cursor with white mapped to transparent." - - | f map | - aFormOrCursor depth <= 8 ifFalse: [ - ^ self error: 'argument depth must be 8-bits per pixel or less']. - (aFormOrCursor is: #ColorForm) ifTrue: [ - f _ aFormOrCursor copy. - map _ aFormOrCursor colors. - ] ifFalse: [ - f _ ColorForm extent: aFormOrCursor extent depth: aFormOrCursor depth. - f copyBits: aFormOrCursor boundingBox - from: aFormOrCursor - at: 0@0 - clippingBox: aFormOrCursor boundingBox - rule: Form over. - map _ Colour indexedColors copyFrom: 1 to: (1 bitShift: aFormOrCursor depth)]. - map _ map collect: [:c | - c = Colour white ifTrue: [Colour transparent] ifFalse: [c]]. - f colors: map. - ^ f -! ! -!ColorForm class methodsFor: 'instance creation' stamp: 'jmv 5/4/2016 16:31' prior: 16819074! - grayScaleAndTransparentExtent: aPoint -"Native depth" - "Answer a ColorForm for storing 8bpp gray scale. (do not include any slot for transparent)" - - | grays result | - result _ self extent: aPoint depth: (Smalltalk isLittleEndian ifTrue: [ -8 ] ifFalse: [ 8 ]). - grays _ (0 to: 255) collect: [ :brightness | Colour gray: brightness asFloat / 255.0]. - grays at: 1 put: Colour transparent. - result colors: grays. - ^result! ! -!Cursor methodsFor: 'converting' stamp: 'jmv 2/25/2011 19:47' prior: 16825855! - asCursorForm - | form | - form _ Form extent: self extent depth: 8. - form fillShape: self fillColor: Colour black at: offset negated. - ^ form offset: offset! ! -!CursorWithMask methodsFor: 'converting' stamp: 'jmv 2/25/2011 19:47' prior: 16826695! - asCursorForm - | form | - form _ Form extent: self extent depth: 8. - form fillShape: maskForm fillColor: Colour white. - form fillShape: self fillColor: Colour black at: offset negated. - ^ form offset: offset! ! -!GrayForm methodsFor: 'pixel accessing' stamp: 'jmv 5/11/2016 19:57' prior: 16850335! - grayAt: aPoint - "Return the color of the pixel at aPoint." - - ^Colour gray: (self pixelValueAt: aPoint) asFloat / 255.0! ! -!GrayForm methodsFor: 'color manipulation' stamp: 'jmv 5/12/2016 15:04' prior: 16850359! - colormapIfNeededForDepth: destDepth - "Return a colormap for displaying the receiver at the given depth, or nil if no colormap is needed." - - ^ Colour cachedColormapFromGrayTo: destDepth! ! -!BMPReadWriter methodsFor: 'reading' stamp: 'ar 10/24/2005 20:57' prior: 16781762! - readColorMap - "Read colorCount BMP color map entries from the given binary stream. Answer an array of Colors." - | colorCount colors maxLevel b g r ccStream | - colorCount := (bfOffBits - 54) // 4. - "Note: some programs (e.g. Photoshop 4.0) apparently do not set colorCount; assume that any data between the end of the header and the start of the pixel data is the color map" - biBitCount >= 16 ifTrue:[^nil]. - colorCount = 0 ifTrue: [ "this BMP file does not have a color map" - "default monochrome color map" - biBitCount = 1 ifTrue: [^ Array with: Colour white with: Colour black]. - "default gray-scale color map" - maxLevel := (2 raisedTo: biBitCount) - 1. - ^ (0 to: maxLevel) collect: [:level | Colour gray: (level asFloat / maxLevel)]]. - ccStream := ReadStream on: (stream next: colorCount*4). - colors := Array new: colorCount. - 1 to: colorCount do: [:i | - b := ccStream next. - g := ccStream next. - r := ccStream next. - ccStream next. "skip reserved" - colors at: i put: (Colour r: r g: g b: b range: 255)]. - ^ colors -! ! -!BitBlt methodsFor: 'accessing' stamp: 'jmv 3/20/2013 00:50' prior: 16785567! - fillColor - "Return the current fill color as a Color. - Gives the wrong answer if the halftoneForm is a complex pattern of more than one word." - - halftoneForm ifNil: [^ Colour black]. - ^ Colour colorFromPixelValue: halftoneForm first depth: destForm depth! ! -!BitBlt class methodsFor: 'examples' stamp: 'jmv 7/27/2015 17:07' prior: 16786237! - alphaBlendDemo - "To run this demo, use... - Display restoreAfter: [BitBlt alphaBlendDemo] - Displays 10 alphas, then lets you paint. Option-Click to stop painting." - - "This code exhibits alpha blending in any display depth by performing - the blend in an off-screen buffer with 32-bit pixels, and then copying - the result back onto the screen with an appropriate color map. - tk 3/10/97" - - "This version uses a sliding buffer for painting that keeps pixels in 32 bits - as long as they are in the buffer, so as not to lose info by converting down - to display resolution and back up to 32 bits at each operation. - di 3/15/97" - - | brush buff dispToBuff buffToDisplay mapDto32 map32toD prevP p brushToBuff theta buffRect buffSize buffToBuff brushRect delta newBuffRect updateRect | - - "compute color maps if needed" - Display depth <= 8 ifTrue: [ - mapDto32 _ Colour cachedColormapFrom: Display depth to: 32. - map32toD _ Colour cachedColormapFrom: 32 to: Display depth]. - - "display 10 different alphas, across top of screen" - buff _ Form extent: 500@50 depth: 32. - dispToBuff _ BitBlt toForm: buff. - dispToBuff colorMap: mapDto32. - dispToBuff copyFrom: (50@10 extent: 500@50) in: Display to: 0@0. - 1 to: 10 do: [:i | dispToBuff fill: (50*(i-1)@0 extent: 50@50) - fillColor: (Colour red alpha: i/10) - rule: Form blend]. - buffToDisplay _ BitBlt toForm: Display. - buffToDisplay colorMap: map32toD. - buffToDisplay copyFrom: buff boundingBox in: buff to: 50@10. - DisplayScreen screenUpdateRequired: nil. - - "Create a brush with radially varying alpha" - brush _ Form extent: 30@30 depth: 32. - 1 to: 5 do: - [:i | brush fillShape: (Form dotOfSize: brush width*(6-i)//5) - fillColor: (Colour red alpha: 0.02 * i - 0.01) - at: brush extent // 2]. - - "Now paint with the brush using alpha blending." - buffSize _ 100. - buff _ Form extent: brush extent + buffSize depth: 32. "Travelling 32-bit buffer" - dispToBuff _ BitBlt toForm: buff. "This is from Display to buff" - dispToBuff colorMap: mapDto32. - brushToBuff _ BitBlt toForm: buff. "This is from brush to buff" - brushToBuff sourceForm: brush; sourceOrigin: 0@0. - brushToBuff combinationRule: Form blend. - buffToBuff _ BitBlt toForm: buff. "This is for slewing the buffer" - - [Sensor isMouseButton2Pressed] whileFalse: - [prevP _ nil. - buffRect _ Sensor mousePoint - (buffSize // 2) extent: buff extent. - dispToBuff copyFrom: buffRect in: Display to: 0@0. - [Sensor isMouseButton1Pressed] whileTrue: - ["Here is the painting loop" - p _ Sensor mousePoint - (brush extent // 2). - (prevP == nil or: [prevP ~= p]) ifTrue: - [prevP == nil ifTrue: [prevP _ p]. - (p dist: prevP) > buffSize ifTrue: - ["Stroke too long to fit in buffer -- clip to buffer, - and next time through will do more of it" - theta _ (p-prevP) theta. - p _ ((theta cos@theta sin) * buffSize asFloat + prevP) truncated]. - brushRect _ p extent: brush extent. - (buffRect containsRect: brushRect) ifFalse: - ["Brush is out of buffer region. Scroll the buffer, - and fill vacated regions from the display" - delta _ brushRect amountToTranslateWithin: buffRect. - buffToBuff copyFrom: buff boundingBox in: buff to: delta. - newBuffRect _ buffRect translatedBy: delta negated. - newBuffRect - areasOutside: buffRect - do: [ :r | dispToBuff copyFrom: r in: Display to: r origin - newBuffRect origin ]. - buffRect _ newBuffRect]. - - "Interpolate from prevP to p..." - brushToBuff drawFrom: prevP - buffRect origin - to: p - buffRect origin - withFirstPoint: false. - - "Update (only) the altered pixels of the destination" - updateRect _ (p min: prevP) corner: (p max: prevP) + brush extent. - buffToDisplay copy: updateRect from: updateRect origin - buffRect origin in: buff. - DisplayScreen screenUpdateRequired: updateRect. - prevP _ p]]]! ! -!WarpBlt methodsFor: 'setup' stamp: 'mtf 8/14/2009 18:21' prior: 16942977! - cellSize: s - "Set the number of samples used for averaging" - cellSize := s. - cellSize = 1 ifTrue: [^ self]. - "Install the colorMap to used for mapping the averaged RGBA 32bit pixels to the - destination depth. Note that we need to install the 32->32 color map explicitly because - the VM will substitute a colorMap derived from sourceForm->destForm mapping which - is just plain wrong for <32 source and 32bit dest depth" - (destForm depth = 32 and: [sourceForm notNil] and: [sourceForm depth < 32]) - ifTrue:[colorMap := ColorMap shifts: #(0 0 0 0) masks:#(16rFF0000 16rFF00 16rFF 16rFF000000) colors: nil] - ifFalse:[colorMap := Colour colorMapIfNeededFrom: 32 to: destForm depth]. -! ! -!GrafPort methodsFor: 'text' stamp: 'jmv 6/1/2015 13:28' prior: 16850127! - displayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font color: foregroundColor - "If required, do a second pass with new rule and colorMap. - Answer last affected pixel position - Answer nil if nothing was done - " - - | answer prevRule secondPassMap sourceDepth destDepth | - - "Slight optimization when there's nothing to do." - clipHeight = 0 ifTrue: [^nil]. - clipWidth = 0 ifTrue: [^nil]. - - self installStrikeFont: font foregroundColor: (foregroundColor alpha: 1). - - "If combinationRule is rgbMul, we might need the special two-pass technique for component alpha blending. - If not, do it simply" - combinationRule = 37 "rgbMul" ifFalse: [ - ^self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font ]. - - "We need to do a second pass. The colormap set is for use in the second pass." - secondPassMap _ colorMap. - sourceDepth _ sourceForm depth. - destDepth _ destForm depth. - colorMap _ sourceDepth ~= destDepth - ifTrue: [ Colour cachedColormapFrom: sourceDepth to: destDepth ]. - answer := self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font. - colorMap := secondPassMap. - secondPassMap ifNotNil: [ - prevRule := combinationRule. - combinationRule := 20. "rgbAdd" - self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font. - combinationRule := prevRule ]. - ^answer! ! -!GrafPort methodsFor: 'private' stamp: 'jmv 5/12/2016 14:52' prior: 16850173! - cachedFontColormapFrom1BitTo: destDepth - - | map dstIndex | - CachedFontColorMaps - ifNil: [CachedFontColorMaps _ Array new: 6]. - - dstIndex _ destDepth highBit. - (CachedFontColorMaps at: dstIndex) ifNotNil: [ :m | ^ m ]. - - map _ (Colour cachedColormapFrom: 1 to: destDepth) copy. - CachedFontColorMaps at: dstIndex put: map. - ^ map! ! -!GrafPort methodsFor: 'private' stamp: 'jmv 5/12/2016 14:55' prior: 16850186! - colorConvertingMap: targetColour from: sourceDepth to: destDepth keepSubPixelAA: keepSubPix - "Note: The color converting map for sourceDepth=16 and for sourceDepth=32 are the same" - - | srcIndex dstIndex map mapsForSource mapsForSourceAndDest | - ColorConvertingMaps - ifNil: [ColorConvertingMaps _ (1 to: 6) collect: [:i | Array new: 6]]. - - srcIndex _ sourceDepth highBit. - sourceDepth > 8 ifTrue: [ srcIndex _ keepSubPix ifTrue: [5] ifFalse: [6] ]. - dstIndex _ destDepth highBit. - - mapsForSource _ ColorConvertingMaps at: srcIndex. - (mapsForSourceAndDest _ mapsForSource at: dstIndex) ifNil: [ - mapsForSourceAndDest _ mapsForSource at: dstIndex put: Dictionary new ]. - - map _ mapsForSourceAndDest at: targetColour ifAbsentPut: [ - Colour - computeColorConvertingMap: targetColour - from: sourceDepth - to: destDepth - keepSubPixelAA: keepSubPix ]. - - ^ map! ! -!GrafPort methodsFor: 'private' stamp: 'jmv 4/17/2014 16:57' prior: 16850225! - setRuleAndMapFor: sourceDepth foregroundColor: foregroundColor - - | targetColor destDepth | - destDepth _ destForm depth. - halftoneForm _ nil. "Don't use fillColor. Use a more powerful ColorMap" - - sourceDepth = 1 ifTrue: [ - self combinationRule: Form paint. - "Set up color map for a different source depth (color font)" - "Uses caching for reasonable efficiency" - colorMap _ self cachedFontColormapFrom1BitTo: destDepth. - colorMap at: 1 put: (destForm pixelValueFor: Colour transparent). - colorMap at: 2 put: (destForm pixelValueFor: foregroundColor) ] - - ifFalse: [ - "Enable subpixel rendering if requested, but never for translucent text: - This technique always draws opaque text. This could be added, by using an extra colormap for the rgbMul phase... - So far, no need arised for doing so." - (sourceDepth > 8 and: [ - Preferences subPixelRenderFonts and: [ foregroundColor = Colour black or: [ - Preferences subPixelRenderColorFonts and: [ foregroundColor isOpaque ]]]]) ifTrue: [ - destDepth > 8 ifTrue: [ - "rgbMul is equivalent to component alpha blend if text is black (only faster, hehe)" - self combinationRule: 37. "rgbMul" - colorMap _ (foregroundColor ~= Colour black or: [ - destDepth = 32 and: [ destForm ~~ Display or: [Preferences properDisplayAlphaForFonts] ]]) ifTrue: [ - "rgbMul / rgbAdd IS component alpha blend for any color of text (neat trick, eh!!)" - "This colorMap is to be used on the second pass with rule 20 (rgbAdd) - See #displayString:from:to:at:strikeFont:color:" - "Note: In 32bpp, if we want the correct alpha in the result, we need the second pass, as the destination could have transparent pixels, - and we need to add to the alpha channel" - self colorConvertingMap: foregroundColor from: sourceDepth to: destDepth keepSubPixelAA: true]] - ifFalse: [ - self combinationRule: 25. "Paint" - targetColor _ foregroundColor = Colour black ifFalse: [ foregroundColor ]. - colorMap _ self colorConvertingMap: targetColor from: sourceDepth to: destDepth keepSubPixelAA: true]] - ifFalse: [ - "Do not use rule 34 for 16bpp display. TTCFont uses it, but it builds a glyphs cache for each color used!!" - self combinationRule: (destDepth = 32 ifTrue: [34 "alphaBlendScaled"] ifFalse: [25 "Paint"]). - colorMap _ self colorConvertingMap: foregroundColor from: sourceDepth to: destDepth keepSubPixelAA: false]]! ! -!Color methodsFor: 'conversions' stamp: 'bf 4/18/2001 16:25' prior: 16815566! - makeForegroundColor - "Make a foreground color contrasting with me" - ^self luminance >= 0.5 - ifTrue: [Colour black] - ifFalse: [Colour white]! ! -!Color methodsFor: 'groups of shades' stamp: 'tk 6/18/96' prior: 16815760! - mix: color2 shades: thisMany - "Return an array of thisMany colors from self to color2. Very useful for displaying color based on a variable in your program. " - "Color showColors: (Color red mix: Colour green shades: 12)" - - | redInc greenInc blueInc rr gg bb c out | - thisMany = 1 ifTrue: [^ Array with: color2]. - redInc _ color2 red - self red / (thisMany-1). - greenInc _ color2 green - self green / (thisMany-1). - blueInc _ color2 blue - self blue / (thisMany-1). - rr _ self red. gg _ self green. bb _ self blue. - out _ (1 to: thisMany) collect: [:num | - c _ Colour r: rr g: gg b: bb. - rr _ rr + redInc. - gg _ gg + greenInc. - bb _ bb + blueInc. - c]. - out at: out size put: color2. "hide roundoff errors" - ^ out -! ! -!Color methodsFor: 'groups of shades' stamp: 'di 10/23/2000 09:45' prior: 16815785! - wheel: thisMany - "An array of thisMany colors around the color wheel starting at self and ending all the way around the hue space just before self. Array is of length thisMany. Very useful for displaying color based on a variable in your program. " - - | sat bri hue step c | - sat _ self saturation. - bri _ self brightness. - hue _ self hue. - step _ 360.0 / (thisMany max: 1). - ^ (1 to: thisMany) collect: [:num | - c _ Colour h: hue s: sat v: bri. "hue is taken mod 360" - hue _ hue + step. - c]. -" -(Color wheel: 8) withIndexDo: [:c :i | Display fill: (i*10@20 extent: 10@20) fillColor: c] -"! ! -!Color methodsFor: 'named colors' stamp: 'KenD 1/26/2013 16:33' prior: 16815842! - closestColor - "Answer the closest matching color in the colorNames dictionary" - -" - (Colour red lighter lighter) closestColour explore. -" - ^ self closestColorFrom: (Colour colorNamesDict)! ! -!Color methodsFor: 'named colors' stamp: 'KenD 1/26/2013 16:36' prior: 16815850! - closestColorAssociation - "Answer this color's closest name->color match." - -" - (Colour blue lighter lighter) closestColorAssociation explore. -" - ^ self closestAssocFrom: (Colour colorNamesDict)! ! -!Color methodsFor: 'named colors' stamp: 'KenD 1/26/2013 16:36' prior: 16815867! - closestColorName - "Answer the name symbol of the closest matching color in the colorNames dictionary" -" - (Colour red lighter lighter) closestColour name. -" - - ^ self closestNameFrom: (Colour colorNamesDict)! ! -!Color methodsFor: 'other' stamp: 'KenD 7/18/2015 20:41' prior: 16815891! - colorName - "Return this color's name, or nil if it has no name. Only returns a name if it exactly matches the named color." - - ^(Colour colorNamesDict keyAtValue: self ifAbsent: [nil]) -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:27:03' prior: 16816085! - * aNumber - "Answer this color with its RGB multiplied by the given number. " - " - (Color brown *2) display - " - ^ Colour new - setRed: (self red * aNumber min: 1.0 max: 0.0) - green: (self green * aNumber min: 1.0 max: 0.0) - blue: (self blue * aNumber min: 1.0 max: 0.0) - colorSpace: colorSpace! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:27:06' prior: 16816097! -+ aColor - "Answer this color mixed with the given color in an additive color space. " - " - (Color blue + Color green) display - " - ^ Colour new - setRed: (self red + aColor red min: 1.0 max: 0.0) - green: (self green + aColor green min: 1.0 max: 0.0) - blue: (self blue + aColor blue min: 1.0 max: 0.0) - colorSpace: colorSpace! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:27:09' prior: 16816110! -- aColor - "Answer aColor is subtracted from the given color in an additive color space. " - " - (Color white - Color red) display - " - ^ Colour new - setRed: (self red - aColor red min: 1.0 max: 0.0) - green: (self green - aColor green min: 1.0 max: 0.0) - blue: (self blue - aColor blue min: 1.0 max: 0.0) - colorSpace: colorSpace! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:27:10' prior: 16816123! - / aNumber - "Answer this color with its RGB divided by the given number. " - " - (Color red / 2) display - " - ^ Colour new - setRed: (self red / aNumber min: 1.0 max: 0.0) - green: (self green / aNumber min: 1.0 max: 0.0) - blue: (self blue / aNumber min: 1.0 max: 0.0) - colorSpace: colorSpace! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:34:18' prior: 16816135! - adjustBrightness: brightness - "Adjust the relative brightness of this color. (lowest value is 0.005 so that hue information is not lost)" - - ^ Colour - h: self hue - s: self saturation - v: (self brightness + brightness min: 1.0 max: 0.005) - alpha: self alpha! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:34:22' prior: 16816146! - adjustSaturation: saturation brightness: brightness - "Adjust the relative saturation and brightness of this color. (lowest value is 0.005 so that hue information is not lost)" - - ^ Colour - h: self hue - s: (self saturation + saturation min: 1.0 max: 0.005) - v: (self brightness + brightness min: 1.0 max: 0.005) - alpha: self alpha! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:28:01' prior: 16816159! - alpha: alphaValue - "Return a new TranslucentColor with the given amount of opacity ('alpha')." - alphaValue = 1.0 ifFalse: [ - ^ TranslucentColour new - setRed: self red - green: self green - blue: self blue - alpha: alphaValue - colorSpace: colorSpace ]! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:34:26' prior: 16816170! - alphaMixed: proportion with: aColour - "Answer this color mixed with the given color. The proportion, a number - between 0.0 and 1.0, determines what what fraction of the receiver to - use in the mix. For example, 0.9 would yield a color close to the - receiver. This method uses RGB interpolation; HSV interpolation can lead - to surprises. Mixes the alphas (for transparency) also." - - | frac1 frac2 | - frac1 _ proportion asFloat min: 1.0 max: 0.0. - frac2 _ 1.0 - frac1. - ^ Colour - r: self red * frac1 + (aColour red * frac2) - g: self green * frac1 + (aColour green * frac2) - b: self blue * frac1 + (aColour blue * frac2) - alpha: self alpha * frac1 + (aColour alpha * frac2)! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/23/2002 01:38' prior: 16816210! - blacker - - ^ self alphaMixed: 0.8333 with: Colour black -! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:54' prior: 16816214! - dansDarker - "Return a darker shade of the same color. - An attempt to do better than the current darker method. - (now obsolete, since darker has been changed to do this. -dew)" - ^ Colour h: self hue s: self saturation - v: (self brightness - 0.16 max: 0.0)! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:34:30' prior: 16816240! - mixed: proportion with: aColour - "Mix with another color and do not preserve transpareny. Only use this for extracting the RGB value and mixing it. All other callers should use instead: - aColour alphaMixed: proportion with: anotherColor - " - - | frac1 frac2 | - frac1 _ proportion asFloat min: 1.0 max: 0.0. - frac2 _ 1.0 - frac1. - ^ Colour - r: self red * frac1 + (aColour red * frac2) - g: self green * frac1 + (aColour green * frac2) - b: self blue * frac1 + (aColour blue * frac2)! ! -!Color methodsFor: 'transformations' stamp: 'dew 1/19/2002 01:29' prior: 16816258! - muchDarker - - ^ self alphaMixed: 0.5 with: Colour black -! ! -!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 12:07' prior: 16816262! - muchLighter - - ^ self alphaMixed: 0.233 with: Colour white -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:34:33' prior: 16816266! - negated - "Return an RGB inverted color" - ^Colour - r: 1.0 - self red - g: 1.0 - self green - b: 1.0 - self blue! ! -!Color methodsFor: 'transformations' stamp: 'jmv 9/10/2009 18:41' prior: 16816287! - quiteBlacker - - ^ self alphaMixed: 0.8 with: Colour black -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 9/10/2009 18:44' prior: 16816291! - quiteWhiter - - ^ self alphaMixed: 0.6 with: Colour white! ! -!Color methodsFor: 'transformations' stamp: 'dew 1/19/2002 01:25' prior: 16816304! - slightlyWhiter - - ^ self alphaMixed: 0.85 with: Colour white -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 8/23/2009 23:24' prior: 16816321! - veryMuchDarker - - ^ self alphaMixed: 0.25 with: Colour black -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 7/28/2016 15:43:04' prior: 16816326! - veryMuchLighter - - ^ self alphaMixed: 0.07 with: Colour white! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/23/2002 01:38' prior: 16816331! - whiter - - ^ self alphaMixed: 0.8333 with: Colour white -! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/2/2016 15:04' prior: 16816547! - colorFromPixelValue: p depth: d - "Convert a pixel value for the given display depth into a color." - "Details: For depths of 8 or less, the pixel value is simply looked up in a table. For greater depths, the color components are extracted and converted into a color." - "Warning: In BitBlt, a pixel with pixelValue = 0 is transparent. - Squeak usually assumes that r=g=b=0 => transparent. But this is false if we have alpha (opacity). - A color with r=g=b=0 and opacity = 255 is BLACK, not TRANSPARENT. - Squeak also answers darkest possible blue when asked for black. Again, this is not needed in 32 bits (with alpha). It is also not really needed for 16 bits as we have an extra, unused bit: 16r8000 is not zero, but rgb=0, and hence, black. - The real rule is that pixelValue=0 means transparent. - And that darkest blue must be used instead of black, but only for depths >8 and < 16 (no indexed colors, no alpha) - This method is updated to reflect that." - - | r g b alpha | - - d = 1 ifTrue: [^ self indexedColors at: (p bitAnd: 16r01) + 1]. - - "For the rest of the depths, pixelValue = 0 means transparent, and darkest blue is considered to be black." - p = 0 ifTrue: [ ^Colour transparent ]. - - d = 8 ifTrue: [^ self indexedColors at: (p bitAnd: 16rFF) + 1]. - d = 4 ifTrue: [^ self indexedColors at: (p bitAnd: 16r0F) + 1]. - d = 2 ifTrue: [^ self indexedColors at: (p bitAnd: 16r03) + 1]. - - d = 32 ifTrue: [ - "eight bits per component; 8 bits of alpha" - alpha _ p bitShift: -24. - alpha = 0 ifTrue: [ ^Colour transparent ]. - r _ (p bitShift: -16) bitAnd: 16rFF. - g _ (p bitShift: -8) bitAnd: 16rFF. - b _ p bitAnd: 16rFF. - ^alpha < 255 - ifTrue: [ (Colour r: r g: g b: b range: 255) alpha: alpha asFloat / 255.0 ] - ifFalse: [ Colour r: r g: g b: b range: 255 ]]. - - d = 16 ifTrue: [ - "five bits per component. The most significant bit, unused, allows having real black, without p being zero" - r _ (p bitShift: -10) bitAnd: 16r1F. - g _ (p bitShift: -5) bitAnd: 16r1F. - b _ p bitAnd: 16r1F. - ^ Colour r: r g: g b: b range: 31]. - - d = 15 ifTrue: [ - "five bits per component" - r _ (p bitShift: -10) bitAnd: 16r1F. - g _ (p bitShift: -5) bitAnd: 16r1F. - b _ p bitAnd: 16r1F. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Colour black ]. - ^ Colour r: r g: g b: b range: 31]. - - d = 12 ifTrue: [ - "four bits per component" - r _ (p bitShift: -8) bitAnd: 16rF. - g _ (p bitShift: -4) bitAnd: 16rF. - b _ p bitAnd: 16rF. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Colour black ]. - ^ Colour r: r g: g b: b range: 15]. - - d = 9 ifTrue: [ - "three bits per component" - r _ (p bitShift: -6) bitAnd: 16r7. - g _ (p bitShift: -3) bitAnd: 16r7. - b _ p bitAnd: 16r7. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Colour black ]. - ^ Colour r: r g: g b: b range: 7]. - - self error: 'unknown pixel depth: ', d printString! ! -!Color class methodsFor: 'class initialization' stamp: '' prior: 16816881! -initializeIndexedColors - "Build an array of colors corresponding to the fixed colormap used - for display depths of 1, 2, 4, or 8 bits." - "Colour initializeIndexedColors" - - | a index grayVal | - a _ Array new: 256. - - "1-bit colors (monochrome)" - a at: 1 put: (Colour r: 1.0 g: 1.0 b: 1.0). "white or transparent" - a at: 2 put: (Colour r: 0.0 g: 0.0 b: 0.0). "black" - - "additional colors for 2-bit color" - a at: 3 put: (Colour r: 1.0 g: 1.0 b: 1.0). "opaque white" - a at: 4 put: (Colour r: 0.5 g: 0.5 b: 0.5). "1/2 gray" - - "additional colors for 4-bit color" - a at: 5 put: (Colour r: 1.0 g: 0.0 b: 0.0). "red" - a at: 6 put: (Colour r: 0.0 g: 1.0 b: 0.0). "green" - a at: 7 put: (Colour r: 0.0 g: 0.0 b: 1.0). "blue" - a at: 8 put: (Colour r: 0.0 g: 1.0 b: 1.0). "cyan" - a at: 9 put: (Colour r: 1.0 g: 1.0 b: 0.0). "yellow" - a at: 10 put: (Colour r: 1.0 g: 0.0 b: 1.0). "magenta" - - a at: 11 put: (Colour r: 0.125 g: 0.125 b: 0.125). "1/8 gray" - a at: 12 put: (Colour r: 0.25 g: 0.25 b: 0.25). "2/8 gray" - a at: 13 put: (Colour r: 0.375 g: 0.375 b: 0.375). "3/8 gray" - a at: 14 put: (Colour r: 0.625 g: 0.625 b: 0.625). "5/8 gray" - a at: 15 put: (Colour r: 0.75 g: 0.75 b: 0.75). "6/8 gray" - a at: 16 put: (Colour r: 0.875 g: 0.875 b: 0.875). "7/8 gray" - - "additional colors for 8-bit color" - "24 more shades of gray (1/32 increments but not repeating 1/8 increments)" - index _ 17. - 1 to: 31 do: [:v | - (v \\ 4) = 0 ifFalse: [ - grayVal _ v / 32.0. - a at: index put: (Colour r: grayVal g: grayVal b: grayVal). - index _ index + 1]]. - - "The remainder of color table defines a color cube with six steps - for each primary color. Note that the corners of this cube repeat - previous colors, but this simplifies the mapping between RGB colors - and color map indices. This color cube spans indices 40 through 255 - (indices 41-256 in this 1-based array)." - 0 to: 5 do: [:r | - 0 to: 5 do: [:g | - 0 to: 5 do: [:b | - index _ 41 + ((36 * r) + (6 * b) + g). - index > 256 ifTrue: [ - self error: 'index out of range in color table compuation']. - a at: index put: (Colour r: r g: g b: b range: 5)]]]. - - IndexedColors _ a. -! ! -!Color class methodsFor: 'examples' stamp: 'jmv 8/17/2012 18:48' prior: 16816950! - colorRampForDepth: depth extent: aPoint - "Returns a form of the given size showing R, G, B, and gray ramps for the given depth. Useful for testing color conversions between different depths." - "(Colour colorRampForDepth: Display depth extent: 256@80) display" - "(Colour colorRampForDepth: 32 extent: 256@80) displayOn: Display at: 0@0 rule: Form paint" - - | f dx dy r | - f _ Form extent: aPoint depth: depth. - dx _ aPoint x // 256. - dy _ aPoint y // 4. - 0 to: 255 do: [:i | - r _ (dx * i)@0 extent: dx@dy. - f fill: r fillColor: (Colour r: i g: 0 b: 0 range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Colour r: 0 g: i b: 0 range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Colour r: 0 g: 0 b: i range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Colour r: i g: i b: i range: 255)]. - ^ f -! ! -!Color class methodsFor: 'examples' stamp: 'jmv 6/18/2017 21:30:09' prior: 16816978! - experimentsTowarsANewColorPalette -" -self experimentsTowarsANewColorPalette -" -| selectedHue selectedSaturation selectedV selectedColor h s v color width height selectedChroma selectedLuminance | -width _ 300. -height _ 120. -selectedColor _ Colour random. -selectedHue _ selectedColor hue. -selectedSaturation _ selectedColor saturation. -selectedChroma _ selectedColor chroma. -selectedV _ selectedColor brightness. -selectedLuminance _ selectedColor luminance. -Display getCanvas fillRectangle: (0@0 extent: height@height) color: selectedColor. -0 to: height do: [ :y | - v _ 1.0 - (y / height). - 0 to: height do: [ :x | - s _ x / height. - color _ Colour new setHue: selectedHue saturation: s brightness: v. - Display colorAt: x@(y+height) put: color - ]. - DisplayScreen screenUpdateRequired: nil -]. -0 to: height do: [ :y | | c | - v _ 1.0 - (y / height). - s _ 1.0 - (y / height). - c _ s. - 0 to: width do: [ :x | - h _ x / width * 360. - - color _ Colour new setHue: h chroma: c luminance: selectedLuminance. -" color _ Colour new setHue: h chroma: c brightness: selectedV." - color ifNil: [ color _ Colour black ]. -" color _ Colour new setHue: h saturation: s brightness: selectedV." - Display colorAt: x+height@y put: color. - - color _ Colour new setHue: h chroma: selectedChroma luminance: v. -" color _ Colour new setHue: h chroma: selectedChroma brightness: v." - color ifNil: [ color _ Colour black ]. -" color _ Colour new setHue: h saturation: selectedSaturation brightness: v." - Display colorAt: x+height@(y+height) put: color. - - ]. - DisplayScreen screenUpdateRequired: nil -].! ! -!Color class methodsFor: 'examples' stamp: '' prior: 16817055! - showColorCube - "Show a 12x12x12 color cube." - "Colour showColorCube" - - 0 to: 11 do: [:r | - 0 to: 11 do: [:g | - 0 to: 11 do: [:b | - Display fill: (((r*60) + (b*5)) @ (g*5) extent: 5@5) - fillColor: (Colour r: r g: g b: b range: 11)]]]. -! ! -!Color class methodsFor: 'examples' stamp: '' prior: 16817075! - showHSVPalettes - "Shows a palette of hues, varying the saturation and brightness for each one. Best results are with depths 16 and 32." - "Color showHSVPalettes" - - | left top c | - left _ top _ 0. - 0 to: 179 by: 15 do: [:h | - 0 to: 10 do: [:s | - left _ (h * 4) + (s * 4). - 0 to: 10 do: [:v | - c _ Colour h: h s: s asFloat / 10.0 v: v asFloat / 10.0. - top _ (v * 4). - Display fill: (left@top extent: 4@4) fillColor: c. - - c _ Colour h: h + 180 s: s asFloat / 10.0 v: v asFloat / 10.0. - top _ (v * 4) + 50. - Display fill: (left@top extent: 4@4) fillColor: c]]]. -! ! -!Color class methodsFor: 'examples' stamp: '' prior: 16817112! - wheel: thisMany - "Return a collection of thisMany colors evenly spaced around the color wheel." - "Color showColors: (Color wheel: 12)" - - ^ Colour wheel: thisMany saturation: 0.9 brightness: 0.7 -! ! -!Color class methodsFor: 'examples' stamp: '' prior: 16817120! - wheel: thisMany saturation: s brightness: v - "Return a collection of thisMany colors evenly spaced around the color wheel, all of the given saturation and brightness." - "Colour showColors: (Colour wheel: 12 saturation: 0.4 brightness: 1.0)" - "Colour showColors: (Colour wheel: 12 saturation: 0.8 brightness: 0.5)" - - ^ (Colour h: 0.0 s: s v: v) wheel: thisMany -! ! -!Color class methodsFor: 'colormaps' stamp: '' prior: 16817522! - colorMapIfNeededFrom: sourceDepth to: destDepth - "Return a colormap for mapping between the given depths, or nil if no colormap is needed." - "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" - - sourceDepth = destDepth ifTrue: [^ nil]. "not needed if depths are the same" - - (sourceDepth >= 16) & (destDepth >= 16) ifTrue: [ - "mapping is done in BitBlt by zero-filling or truncating each color component" - ^ nil]. - - ^ Colour cachedColormapFrom: sourceDepth to: destDepth -! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 5/12/2016 15:56' prior: 16817637! - computeColormapFromGray8bppForDepth: destDepth - "Return a colormap for displaying a GrayForm at the given depth" - - | newMap | - newMap _ Bitmap new: 256. - 1 to: 256 do: [ :i | - newMap - at: i - put: ((Colour gray: (i-1) asFloat / 255.0) pixelValueForDepth: destDepth)]. - ^ newMap! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 4/17/2015 15:05' prior: 16817648! - computeIndexedColorConvertingMap: targetColor from: sourceDepth to: destDepth - | map | - - map _ (self indexedColors copyFrom: 1 to: (1 bitShift: sourceDepth)) collect: [ :cc | | f c | - f _ 1.0 - (cc red + cc green + cc blue / 3.0 ). - c _ targetColor - ifNotNil: [ - destDepth = 32 - ifTrue: [ targetColor * f alpha: f] - ifFalse: [ targetColor alphaMixed: f*1.5 with: Colour white ]] - ifNil: [ cc ]. - destDepth = 32 - ifTrue: [ c pixelValueForDepth: destDepth] - ifFalse: [ - f = 0.0 - ifTrue: [ 0 ] - ifFalse: [ c pixelValueForDepth: destDepth ]]]. - map _ map as: Bitmap. - ^map! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 21:34:38' prior: 16817670! - computeRGBColorConvertingMap: targetColour to: destDepth keepSubPixelAA: keepSubPix - "Builds a colormap intended to convert from subpixelAA black values to targetColour values. - keepSubPix - ifTrue: [ Answer colors that also include subpixelAA ] - ifFalse: [ - Take fullpixel luminance level. Apply it to targetColor. - I.e. answer colors with NO subpixelAA ]" - - | mask map c bitsPerColour r g b f v | - - destDepth > 8 - ifTrue: [bitsPerColour _ 5] "retain maximum color resolution" - ifFalse: [bitsPerColour _ 4]. - "Usually a bit less is enough, but make it configurable" - bitsPerColour _ bitsPerColour min: Preferences aaFontsColormapDepth. - mask _ (1 bitShift: bitsPerColour) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColour)). - 0 to: map size - 1 do: [:i | - r _ (i bitShift: 0 - (2 * bitsPerColour)) bitAnd: mask. - g _ (i bitShift: 0 - bitsPerColour) bitAnd: mask. - b _ (i bitShift: 0) bitAnd: mask. - f _ 1.0 - (r + g + b / 3.0 / mask). - c _ targetColour - ifNotNil: [ - (keepSubPix and: [destDepth > 8]) ifTrue: [ - Colour - r: 1.0 - (r asFloat/mask) * targetColour red - g: 1.0 - (g asFloat/mask) * targetColour green - b: 1.0 - (b asFloat/mask) * targetColour blue - alpha: f * targetColour alpha "alpha will be ignored below, in #pixelValueForDepth: if destDepth ~= 32" ] - ifFalse: [ - destDepth = 32 - ifTrue: [ targetColour * f alpha: f * targetColour alpha ] - ifFalse: [ targetColour alphaMixed: f*1.5 with: Colour white ]]] - ifNil: [ Colour r: r g: g b: b range: mask]. "This is currently used only to keep some SubPixelAA on destDepth = 8, using a single pass of rule 25" - v _ destDepth = 32 - ifTrue: [ c pixelValueForDepth: destDepth] - ifFalse: [ - f < 0.1 - ifTrue: [ 0 ] - ifFalse: [ c pixelValueForDepth: destDepth ]]. - map at: i + 1 put: v ]. - ^ map! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 21:34:42' prior: 16817730! - computeRGBColormapFor: destDepth bitsPerColor: bitsPerColor - "Compute a colorMap for translating from 16-bit or 32-bit RGB color to the given depth, using the given number of of bits per color component." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Colour maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | mask map c | - (#(3 4 5) includes: bitsPerColor) - ifFalse: [self error: 'BitBlt only supports 3, 4, or 5 bits per color component']. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - c _ Colour - r: ((i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask) - g: ((i bitShift: 0 - bitsPerColor) bitAnd: mask) - b: ((i bitShift: 0) bitAnd: mask) - range: mask. - map at: i + 1 put: (c pixelValueForDepth: destDepth)]. - - map at: 1 put: (Colour transparent pixelWordForDepth: destDepth). "zero always transparent" - ^ map -! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 21:34:46' prior: 16817772! - computeRGBColormapForGray8 - "Compute a colorMap for translating from 16-bit or 32-bit RGB color to 8bpp grays, using the default number of of bits per color component." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Colour maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | bitsPerColor mask map c | - bitsPerColor _ 5. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - c _ Colour - r: ((i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask) - g: ((i bitShift: 0 - bitsPerColor) bitAnd: mask) - b: ((i bitShift: 0) bitAnd: mask) - range: mask. - map at: i + 1 put: (c luminance * 255) rounded]. - - ^ map! ! -!Color class methodsFor: 'color from user' stamp: 'jmv 3/1/2010 15:13' prior: 16817838! - colorPaletteForDepth: depth extent: chartExtent - "Display a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." - "Note: It is slow to build this palette, so it should be cached for quick access." - "(Color colorPaletteForDepth: 16 extent: 190@60) display" - - | basicHue x y startHue palette transHt vSteps transCaption grayWidth hSteps | - palette _ Form extent: chartExtent depth: depth. - transCaption _ - (Form extent: 34@9 depth: 1 - fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0) - offset: 0@0). - transHt _ transCaption height. - palette fillWhite: (0@0 extent: palette width@transHt). - palette fillBlack: (0@transHt extent: palette width@1). - transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0). - grayWidth _ 10. - startHue _ 338.0. - vSteps _ palette height - transHt // 2. - hSteps _ palette width - grayWidth. - x _ 0. - startHue to: startHue + 360.0 by: 360.0/hSteps do: [ :h | - basicHue _ Colour h: h asFloat s: 1.0 v: 1.0. - y _ transHt+1. - 0 to: vSteps do: [ :n | | c | - c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Colour white. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - 1 to: vSteps do: [ :n | | c | - c _ Colour black mixed: (n asFloat / vSteps asFloat) with: basicHue. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - x _ x + 1]. - y _ transHt + 1. - 1 to: vSteps * 2 do: [ :n | | c | - c _ Colour black mixed: (n asFloat / (vSteps*2) asFloat) with: Colour white. - palette fill: (x@y extent: 10@1) fillColor: c. - y _ y + 1]. - ^ palette -! ! -!Color class methodsFor: 'color from user' stamp: 'jmv 7/27/2009 11:32' prior: 16817895! - colorTest: depth extent: chartExtent colorMapper: colorMapper - "Create a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." - "Note: It is slow to build this palette, so it should be cached for quick access." - "(Color colorTest: 32 extent: 570@180 colorMapper: [:c | c]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 7) asInteger / 7 - g: (c green * 7) asInteger / 7 - b: (c blue * 3) asInteger / 3]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 5) asInteger / 5 - g: (c green * 5) asInteger / 5 - b: (c blue * 5) asInteger / 5]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 15) asInteger / 15 - g: (c green * 15) asInteger / 15 - b: (c blue * 15) asInteger / 15]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 31) asInteger / 31 - g: (c green * 31) asInteger / 31 - b: (c blue * 31) asInteger / 31]) display" - - | basicHue x y c startHue palette transHt vSteps transCaption grayWidth hSteps | - palette _ Form extent: chartExtent depth: depth. - transCaption _ - (Form extent: 34@9 depth: 1 - fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0) - offset: 0@0). - transHt _ transCaption height. - palette fillWhite: (0@0 extent: palette width@transHt). - palette fillBlack: (0@transHt extent: palette width@1). - transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0). - grayWidth _ 10. - startHue _ 338.0. - vSteps _ palette height - transHt // 2. - hSteps _ palette width - grayWidth. - x _ 0. - startHue to: startHue + 360.0 by: 360.0/hSteps do: [:h | - basicHue _ Colour h: h asFloat s: 1.0 v: 1.0. - y _ transHt+1. - 0 to: vSteps do: [:n | - c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Colour white. - c _ colorMapper value: c. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - 1 to: vSteps do: [:n | - c _ Colour black mixed: (n asFloat / vSteps asFloat) with: basicHue. - c _ colorMapper value: c. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - x _ x + 1]. - y _ transHt + 1. - 1 to: vSteps * 2 do: [:n | - c _ Colour black mixed: (n asFloat / (vSteps*2) asFloat) with: Colour white. - c _ colorMapper value: c. - palette fill: (x@y extent: 10@1) fillColor: c. - y _ y + 1]. - ^ palette -! ! -!Color class methodsFor: 'color name lookup' stamp: 'KenD 1/28/2013 20:34' prior: 16817983! - defaultColorNamesDictionary - "Answer a amall but useful name->color dictionary" - - | defaultDict | - "Meld most used xkcd colors into traditional colors." - defaultDict := (self traditionalColorNamesDictionary addAll: - self xkcdFirst48ColorNamesDictionary; - yourself). - - "Override traditional names existing in extended XKCD naming" - defaultDict at: #lightYellow put: (Colour r: 1.0 g: 0.996 b: 0.478). - defaultDict at: #lightOrange put: (Colour r: 0.992 g: 0.667 b: 0.283). - defaultDict at: #lightCyan put: (Colour r: 0.674 g: 1.0 b: 0.988). - defaultDict at: #lightRed put: (Colour r: 1.0 g: 0.279 b: 0.298). - defaultDict at: #lightMagenta put: (Colour r: 0.98 g: 0.372 b: 0.969). - - ^defaultDict! ! -!Color class methodsFor: 'color name lookup' stamp: 'KenD 2/1/2013 14:39' prior: 16818009! - doesNotUnderstand: aMessage - "Some code takes - Colour colorNames - and does - Colour perform: aColorname. - - Make this work." - - ^(Colour colorNamesDict) - at: (aMessage selector) - ifAbsent: [super doesNotUnderstand: aMessage]! ! -!Color class methodsFor: 'color name lookup' stamp: 'KenD 7/25/2014 21:22' prior: 16818027! - setColorNamesDict: aNameColorDictionary - "Answer the current dictionary of name->color associations." - - "Note: This is a non-standard name because this is a non-standard action!! - Do this if you really, really know what you are doing." - - "Some Colors are required for proper system operation" - Colour defaultColorNamesDictionary keysAndValuesDo: [ :colorName :colorValue | - aNameColorDictionary at: colorName ifAbsentPut: colorValue - ]. - - ColorNamesDict := aNameColorDictionary! ! -!Color class methodsFor: 'color name lookup' stamp: 'sqr 10/21/2016 12:44:48' prior: 16818045! - traditionalColorNamesDictionary - "Answer a dictionary of Squeak traditional name->color associations.." - - | nameDict | - nameDict _ Dictionary new. - nameDict at: #black put: (Colour r: 0 g: 0 b: 0). - nameDict at: #veryVeryDarkGray put: (Colour r: 0.125 g: 0.125 b: 0.125). - nameDict at: #veryDarkGray put: (Colour r: 0.25 g: 0.25 b: 0.25). - nameDict at: #darkGray put: (Colour r: 0.375 g: 0.375 b: 0.375). - nameDict at: #gray put: (Colour r: 0.5 g: 0.5 b: 0.5). - nameDict at: #lightGray put: (Colour r: 0.625 g: 0.625 b: 0.625). - nameDict at: #veryLightGray put: (Colour r: 0.75 g: 0.75 b: 0.75). - nameDict at: #veryVeryLightGray put: (Colour r: 0.875 g: 0.875 b: 0.875). - nameDict at: #white put: (Colour r: 1.0 g: 1.0 b: 1.0). - nameDict at: #red put: (Colour r: 1.0 g: 0 b: 0). - nameDict at: #yellow put: (Colour r: 1.0 g: 1.0 b: 0). - nameDict at: #green put: (Colour r: 0 g: 1.0 b: 0). - nameDict at: #cyan put: (Colour r: 0 g: 1.0 b: 1.0). - nameDict at: #blue put: (Colour r: 0 g: 0 b: 1.0). - nameDict at: #magenta put: (Colour r: 1.0 g: 0 b: 1.0). - nameDict at: #brown put: (Colour r: 0.6 g: 0.2 b: 0). - nameDict at: #orange put: (Colour r: 1.0 g: 0.6 b: 0). - nameDict at: #lightRed put: (Colour r: 1.0 g: 0.8 b: 0.8). - nameDict at: #lightYellow put: (Colour r: 1.0 g: 1.0 b: 0.8). - nameDict at: #lightGreen put: (Colour r: 0.8 g: 1.0 b: 0.6). - nameDict at: #lightCyan put: (Colour r: 0.4 g: 1.0 b: 1.0). - nameDict at: #lightBlue put: (Colour r: 0.8 g: 1.0 b: 1.0). - nameDict at: #lightMagenta put: (Colour r: 1.0 g: 0.8 b: 1.0). - nameDict at: #lightBrown put: (Colour r: 1.0 g: 0.6 b: 0.2). - nameDict at: #lightOrange put: (Colour r: 1.0 g: 0.8 b: 0.4). - nameDict at: #transparent put: (TranslucentColour r: 0.0 g: 0.0 b: 0.0 alpha: 0.0). - - ^nameDict -! ! -!Color class methodsFor: 'color name lookup' stamp: 'jmv 6/30/2014 15:22' prior: 16818102! - xkcdFirst48ColorNamesDictionary - "XKCD color names are based on a survey oc colors people call by the same name. - http://blog.xkcd.com/2010/05/03/color-survey-results/" - - "Answer a dictionary of the most agreed upon first 48 xkcd colors" -" - Colour xkcdFirst48ColorNamesDictionary explore. -" - | xkcdDict | - xkcdDict := Dictionary new - at: #lightPink put: (Colour fromString: '#ffd1df') ; - at: #mustard put: (Colour fromString: '#ceb301') ; - at: #indigo put: (Colour fromString: '#380282') ; - at: #lime put: (Colour fromString: '#aaff32') ; - at: #seaGreen put: (Colour fromString: '#53fca1') ; - at: #periwinkle put: (Colour fromString: '#8e82fe') ; - at: #darkPink put: (Colour fromString: '#cb416b') ; - at: #oliveGreen put: (Colour fromString: '#677a04') ; - at: #peach put: (Colour fromString: '#ffb07c') ; - at: #paleGreen put: (Colour fromString: '#c7fdb5') ; - at: #lightBrown put: (Colour fromString: '#ad8150') ; - at: #hotPink put: (Colour fromString: '#ff028d') ; - at: #black put: (Colour fromString: '#000000') ; - at: #lilac put: (Colour fromString: '#cea2fd') ; - at: #navyBlue put: (Colour fromString: '#001146') ; - at: #royalBlue put: (Colour fromString: '#0504aa') ; - at: #beige put: (Colour fromString: '#e6daa6') ; - at: #salmon put: (Colour fromString: '#ff796c') ; - at: #olive put: (Colour fromString: '#6e750e') ; - at: #maroon put: (Colour fromString: '#650021') ; - at: #brightGreen put: (Colour fromString: '#01ff07') ; - at: #darkPurple put: (Colour fromString: '#35063e') ; - at: #mauve put: (Colour fromString: '#ae7181') ; - at: #forestGreen put: (Colour fromString: '#06470c') ; - at: #aqua put: (Colour fromString: '#13eac9') ; - at: #cyan put: (Colour fromString: '#00ffff') ; - at: #tan put: (Colour fromString: '#d1b26f') ; - at: #darkBlue put: (Colour fromString: '#00035b') ; - at: #lavender put: (Colour fromString: '#c79fef') ; - at: #turquoise put: (Colour fromString: '#06c2ac') ; - at: #darkGreen put: (Colour fromString: '#033500') ; - at: #violet put: (Colour fromString: '#9a0eea') ; - at: #lightPurple put: (Colour fromString: '#bf77f6') ; - at: #limeGreen put: (Colour fromString: '#89fe05') ; - at: #grey put: (Colour fromString: '#929591') ; - at: #skyBlue put: (Colour fromString: '#75bbfd') ; - at: #yellow put: (Colour fromString: '#ffff14') ; - at: #magenta put: (Colour fromString: '#c20078') ; - at: #lightGreen put: (Colour fromString: '#96f97b') ; - at: #orange put: (Colour fromString: '#f97306') ; - at: #teal put: (Colour fromString: '#029386') ; - at: #lightBlue put: (Colour fromString: '#95d0fc') ; - at: #red put: (Colour fromString: '#e50000') ; - at: #brown put: (Colour fromString: '#653700') ; - at: #pink put: (Colour fromString: '#ff81c0') ; - at: #blue put: (Colour fromString: '#0343df') ; - at: #green put: (Colour fromString: '#15b01a') ; - at: #purple put: (Colour fromString: '#7e1e9c') ; - yourself. - - ^xkcdDict - -! ! -!TranslucentColor methodsFor: 'conversions' stamp: 'jmv 6/18/2017 21:28:31' prior: 16939024! - alpha: alphaValue - "Return a new TranslucentColor with the given amount of opacity ('alpha')." - alphaValue = 1.0 ifTrue: [ - ^ Colour new - setRed: self red - green: self green - blue: self blue - colorSpace: colorSpace]. - ^ super alpha: alphaValue! ! -!Rectangle methodsFor: 'transforming' stamp: 'jmv 9/24/2013 22:36' prior: 16898974! - newRectFrom: newRectBlock - "Track the outline of a new rectangle until mouse button changes. - newFrameBlock produces each new rectangle from the previous" - | rect newRect buttonStart buttonNow aHand delay | - delay _ Delay forMilliseconds: 10. - buttonStart _ buttonNow _ Sensor isAnyButtonPressed. - rect _ self. - Display border: rect width: 2 rule: Form reverse fillColor: Colour gray. - [buttonNow == buttonStart] whileTrue: - [delay wait. - buttonNow _ Sensor isAnyButtonPressed. - newRect _ newRectBlock value: rect. - newRect = rect ifFalse: - [Display border: rect width: 2 rule: Form reverse fillColor: Colour gray. - Display border: newRect width: 2 rule: Form reverse fillColor: Colour gray. - rect _ newRect]]. - Display border: rect width: 2 rule: Form reverse fillColor: Colour gray. - " pay the price for reading the sensor directly ; get this party started " - aHand _ self runningWorld activeHand. - aHand - newMouseFocus: nil; - flushEvents. - Sensor processSensorEvent: Sensor createMouseEvent discardingMouseEvents: false. - ^ rect! ! -!StrikeFont methodsFor: 'emphasis' stamp: 'jmv 4/10/2015 23:21' prior: 16914485! - makeBoldGlyphs - "Make a bold set of glyphs with same widths by ORing 1 bit to the right - (requires at least 1 pixel of intercharacter space)" - | g bonkForm | - g _ glyphs copy. - bonkForm _ (Form extent: 1@16) fillBlack offset: -1@0. - self bonk: g with: bonkForm. - glyphs depth = 1 ifTrue: [ - g copyBits: g boundingBox from: g at: (1@0) - clippingBox: g boundingBox rule: Form under ] - ifFalse: [ - 0 to: g width - 2 do: [ :x | 0 to: g height-1 do: [ :y | - (glyphs colorAt: x@y) = Colour white ifFalse: [ - g colorAt: x+1@y put: - ((glyphs colorAt: x+1@y) = Colour white - ifTrue: [glyphs colorAt: x@y] - ifFalse: [Colour black])]]]]. - glyphs _ g. - self isSynthetic: true! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 9/2/2016 11:03:22' prior: 16914725! - makeControlCharsVisible - | glyph | - self characterToGlyphMap. - glyph _ self glyphAt: (Character space). - glyph border: glyph boundingBox width: 1 fillColor: Colour blue. - self glyphAt: (Character numericValue: 134) put: glyph. - - "Keep tab(9), lf(10), cr(13) and space(32) transparent or whatever the user chose" - #(0 1 2 3 4 5 6 7 8 11 12 14 15 16 17 18 19 20 21 22 23 24 25 26 27) - do: [ :ascii | - characterToGlyphMap at: ascii + 1 put: 134 ]! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 9/2/2016 11:03:27' prior: 16914749! - makeCrVisible - | glyph | - self characterToGlyphMap. - glyph _ self glyphAt: (Character numericValue: 182). - glyph border: glyph boundingBox width: 1 fillColor: Colour blue. -" glyph _ glyph reverse." - self glyphAt: (Character numericValue: 133) put: glyph. - characterToGlyphMap at: 14 put: 133! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 9/2/2016 11:03:31' prior: 16914768! - makeLfVisible - | glyph | - self characterToGlyphMap. - glyph _ self glyphAt: (Character numericValue: 163). - glyph border: glyph boundingBox width: 1 fillColor: Colour blue. -" glyph _ glyph reverse." - self glyphAt: (Character numericValue: 132) put: glyph. - characterToGlyphMap at: 11 put: 132! ! -!Morph methodsFor: 'accessing' stamp: 'jmv 8/21/2012 20:40' prior: 16873946! - color - - ^ Colour blue! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 4/14/2015 08:53' prior: 16874298! - drawOn: aCanvas - "A canvas is already set with a proper transformation from our coordinates to those of the Canvas target." - aCanvas - fillRectangle: self morphLocalBounds - color: Colour blue! ! -!RectangleLikeMorph methodsFor: 'initialization' stamp: 'jmv 8/21/2012 18:46' prior: 16899196! - defaultColor - ^ Colour orange! ! -!BorderedRectMorph methodsFor: 'initialization' stamp: 'jmv 8/17/2014 21:28' prior: 16790410! - defaultBorderColor - "answer the default border color/fill style for the receiver" - ^ Colour gray! ! -!PasteUpMorph methodsFor: 'initialization' stamp: 'jmv 6/18/2017 21:33:36' prior: 16887268! -defaultBorderColor - "answer the default border color/fill style for the receiver" - ^ Colour - r: 0.861 - g: 1.0 - b: 0.722! ! -!PasteUpMorph methodsFor: 'initialization' stamp: 'jmv 6/18/2017 21:33:40' prior: 16887280! - defaultColor - "answer the default color/fill style for the receiver" - ^ Colour - r: 0.8 - g: 1.0 - b: 0.6! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 11/10/2013 19:32' prior: 16887655! - findWindow: evt - "Present a menu names of windows and naked morphs, and activate the one that gets chosen. Collapsed windows appear below line, expand if chosen; naked morphs appear below second line; if any of them has been given an explicit name, that is what's shown, else the class-name of the morph shows; if a naked morph is chosen, bring it to front and have it don a halo." - | menu expanded collapsed nakedMorphs | - menu _ MenuMorph new. - expanded _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed not ]. - collapsed _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed ]. - nakedMorphs _ self submorphsSatisfying: [ :m | - (m is: #SystemWindow) not ]. - expanded isEmpty & (collapsed isEmpty & nakedMorphs isEmpty) ifTrue: [ ^ Smalltalk beep ]. - (expanded asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #activateAndForceLabelToShow. - w canDiscardEdits ifFalse: [ menu lastItem color: Colour red ]]. - expanded isEmpty | (collapsed isEmpty & nakedMorphs isEmpty) ifFalse: [ menu addLine ]. - (collapsed asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #expand. - w canDiscardEdits ifFalse: [ menu lastItem color: Colour red ]]. - nakedMorphs isEmpty ifFalse: [ menu addLine ]. - (nakedMorphs asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #comeToFrontAndAddHalo ]. - menu addTitle: 'find window'. - menu popUpInWorld: self! ! -!EllipseMorph methodsFor: 'visual properties' stamp: 'ar 6/25/1999 11:14' prior: 16837113! - defaultColor - "Return the default fill style for the receiver" - ^Colour yellow! ! -!PluggableMorph methodsFor: 'initialization' stamp: 'jmv 8/6/2014 09:15' prior: 16889451! - defaultColor - "answer the default color/fill style for the receiver" - ^ Colour lightGray! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 9/9/2012 23:50' prior: 16888164! - drawRoundGradientLookOn: aCanvas - | r colorForButton rect bottomFactor topFactor | - - self isPressed - ifFalse: [ - topFactor _ Theme current buttonGradientTopFactor. - bottomFactor _ Theme current buttonGradientBottomFactor. - self mouseIsOver - ifTrue: [ - colorForButton _ Colour h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ - colorForButton _ color ]] - ifTrue: [ - topFactor _ Theme current buttonGradientBottomFactor. - bottomFactor _ Theme current buttonGradientTopFactor. - colorForButton _ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - Theme current useButtonGradient - ifTrue: [ - rect _ (0@0 extent: extent) insetBy: 1@3. - aCanvas - roundRect: rect - color: colorForButton - radius: r - gradientTop: topFactor - gradientBottom: bottomFactor - gradientHeight: Theme current buttonGradientHeight ] - ifFalse: [ - rect _ (0@0 extent: extent) insetBy: 1@3. - aCanvas roundRect: rect color: colorForButton radius: r ] - ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawEmbossedLabelOn: aCanvas ] - ifFalse: [ self drawRegularLabelOn: aCanvas ]! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 4/12/2012 22:37' prior: 16888215! - iconColor - - ^ self isPressed - ifTrue: [ Colour gray: 0.75 ] - ifFalse: [ - self mouseIsOver - ifTrue: [ Colour gray: 0.75 ] - ifFalse: [ Colour white ]].! ! -!PluggableButtonMorph class methodsFor: 'example' stamp: 'jmv 1/4/2013 13:31' prior: 16888484! - example - " - PluggableButtonMorph example openInWorld - " - - | s1 s2 s3 b1 b2 b3 row | - s1 _ Switch new. - s2 _ Switch new turnOn. - s3 _ Switch new. - s2 onAction: [s3 turnOff]. - s3 onAction: [s2 turnOff]. - b1 _ (PluggableButtonMorph model: s1 stateGetter: #isOn action: #switch) label: 'S1'. - b2 _ (PluggableButtonMorph model: s2 stateGetter: #isOn action: #turnOn) label: 'S2'. - b3 _ (PluggableButtonMorph model: s3 stateGetter: #isOn action: #turnOn) label: 'S3'. - b1 color: Colour lightRed. - b2 color: Colour lightRed. - b3 color: Colour lightRed. - row _ LayoutMorph newRow - addMorphs: (Array with: b1 with: b2 with: b3); - morphExtent: 120@35. - ^ row -! ! -!TextModelMorph methodsFor: 'drawing' stamp: 'cbr 10/10/2012 23:04' prior: 16933987! - drawOn: aCanvas - "Include a thin red inset border for unaccepted edits, or, if the unaccepted edits are known to conflict with a change made somewhere else to the same method (typically), put a thick red frame" - - - | bw bc | - - self flag: #todo. "Integrate this method with the Theme system. --cbr" - - - super drawOn: aCanvas. - bw _ Preferences focusIndicatorWidth. - bc _ nil. - self wantsFrameAdornments ifTrue: [ - model refusesToAccept - ifTrue: [ "Put up feedback showing that code cannot be submitted in this state" - bc _ Colour tan] - ifFalse: [ - self textMorph hasEditingConflicts - ifTrue: [ - bw _ 3. - bc _ Colour red ] - ifFalse: [ - self textMorph hasUnacceptedEdits - ifTrue: [ - bc _ Colour red]]]]. - - (drawKeyboardFocusIndicator and: [ self textMorph hasKeyboardFocus ]) ifTrue: [ - bc ifNil: [ - bc _ Theme current focusIndicator ]] - ifFalse: [ - bc ifNotNil: [ - bc _ bc alphaMixed: 0.4 with: Colour white ]]. - bc ifNotNil: [ - aCanvas frameRectangle: self focusIndicatorRectangle borderWidth: bw color: bc ]! ! -!SystemWindow methodsFor: 'initialization' stamp: 'cbr 11/7/2010 18:58' prior: 16926270! - defaultColor - "answer the default color/fill style for the receiver" - ^ Colour white! ! -!SystemWindow methodsFor: 'menu' stamp: 'jmv 6/7/2013 23:23' prior: 16926535! - setWindowColor: incomingColor - | existingColor aColor | - incomingColor ifNil: [^ self]. "it happens" - aColor _ incomingColor asNontranslucentColor. - aColor = Colour black ifTrue: [^ self]. - existingColor _ self widgetsColor. - existingColor ifNil: [^ Smalltalk beep]. - self widgetsColor: aColor. - self redrawNeeded! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'KenD 8/27/2015 14:39' prior: 16811424! - buildMorphicWindow - " - CodePackageListWindow open: CodePackageList new - " - | dirtyFlags names fileNames upperRow description summary backColor labelBackground textHeigth | - backColor := self textBackgroundColor. - labelBackground := Theme current background. - textHeigth := AbstractFont default height. - - dirtyFlags := PluggableListMorph - model: model - listGetter: #packageDirtyFlags - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - dirtyFlags color: backColor. - dirtyFlags := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Colour transparent) fixedHeight: 4; - addMorph: (StringMorph new contents: ' Unsaved?') fixedHeight: textHeigth; - addMorphUseAll: dirtyFlags. - - names := PluggableListMorph - model: model - listGetter: #packageNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - names color: backColor. - names := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Colour transparent) fixedHeight: 4; - addMorph: (StringMorph new contents: ' Package Name') fixedHeight: textHeigth; - addMorphUseAll: names. - - fileNames := PluggableListMorph - model: model - listGetter: #packageFullNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - fileNames color: backColor. - fileNames := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Colour transparent) fixedHeight: 4; - addMorph: (StringMorph new contents: ' File Name') fixedHeight: textHeigth; - addMorphUseAll: fileNames. - - upperRow := LayoutMorph newRow. - upperRow - addMorph: dirtyFlags proportionalWidth: 0.13; - addAdjusterAndMorph: names proportionalWidth: 0.27; - addAdjusterAndMorph: fileNames proportionalWidth: 0.6. - - description := TextModelMorph - textProvider: model - textGetter: #description - textSetter: #description:. - - summary := TextModelMorph - textProvider: model - textGetter: #summary. - - self layoutMorph - addMorph: upperRow proportionalHeight: 0.5; - addAdjusterAndMorph: self buildButtonPane proportionalHeight: 0.1; - addAdjusterAndMorph: summary proportionalHeight: 0.18; - addAdjusterAndMorph: description proportionalHeight: 0.22; - addAdjusterAndMorph: self buildRequirementsPane proportionalHeight: 0.2. - self setLabel: 'Installed Packages'! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'len 5/27/2016 21:51' prior: 16811499! - buildRequirementsPane - - | requirements deleteReqButton "editReqButton" reqLayout buttonLayout | - requirements := PluggableListMorph - model: (PackageRequirementsList fromCodePackageList: model) - listGetter: #requirementsStrings - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - requirements color: Theme current textPane. - - deleteReqButton := PluggableButtonMorph - model: requirements model - action: #deleteSelectedRequirement - label: 'delete'. - deleteReqButton color: self widgetsColor. - - buttonLayout := LayoutMorph newColumn. - buttonLayout addMorph: deleteReqButton - layoutSpec: (LayoutSpec - proportionalWidth: 1.0 - proportionalHeight: 1.0 - minorDirectionPadding: #top); - color: self widgetsColor quiteWhiter. - - model when: #changed: send: #updateRequirementsFromPackageList to: requirements model. - self when: #changed: send: #updateRequirementsFromPackageList to: requirements model. - requirements model when: #changed: send: #verifyContents to: requirements. - self when: #changed: send: #verifyContents to: requirements. - - reqLayout := LayoutMorph newRow. - ^ reqLayout - doAdoptWidgetsColor; - addMorph: requirements - layoutSpec: (LayoutSpec - proportionalWidth: 0.9 - proportionalHeight: 1.0 - minorDirectionPadding: #left); - addMorph: buttonLayout - layoutSpec: (LayoutSpec - proportionalWidth: 0.1 - proportionalHeight: 1.0 - minorDirectionPadding: #right); - color: Colour transparent; - yourself - ! ! -!CodeWindow methodsFor: 'updating' stamp: 'jmv 6/18/2017 21:32:16' prior: 16813173! - decorateForInheritance - "Check to see if the currently-viewed method has a super send or an override, and if so, change screen feedback, unless the #decorateBrowserButtons says not to." - - | cm aColour aButton flags buttonColour | - (aButton _ self inheritanceButton) ifNil: [^ self]. - buttonColour _ self buttonColor. - - Preferences decorateBrowserButtons - ifFalse: [ ^aButton color: buttonColour ]. - cm _ model currentCompiledMethod. - (cm is: #CompiledMethod) - ifFalse: [ ^aButton color: buttonColour ]. - - flags _ 0. - model isThisAnOverride ifTrue: [ flags _ flags bitOr: 4 ]. - cm sendsToSuper ifTrue: [ flags _ flags bitOr: 2 ]. - model isThereAnOverride ifTrue: [ flags _ flags bitOr: 1 ]. - aColour _ { - - "This is NOTan override. There is no super implementation." - buttonColour. "no sends to super. there is not override in any subclass" - Colour tan. "no sends to super. there is an override in some subclass" - Colour red. "sends to super. there is no override in any subclass. Error: no super to call (or calls super with a different message)" - Colour red. "sends to super. there is an override in some subclass. Error: no super to call (or calls super with a different message)" - - "This is an override. There is some super implementation" - Colour red muchLighter. "doesn't have sub; has super but doesn't call it" - Colour r: 0.94 g: 0.823 b: 0.673. "has sub; has super but doesn't call it" - Colour green muchLighter. "doesn't have sub; has super and callsl it" - Colour blue muchLighter. "has sub; has super and callsl it" - - } at: flags + 1. - aButton color: buttonColour! ! -!ChangeSorterWindow methodsFor: 'GUI building' stamp: 'DM 8/22/2015 12:34' prior: 16799978! - buildMorphicWindow - "Add a set of change sorter views to the given top view offset by the given amount. To create a single change sorter, call this once with an offset of 0@0. To create a dual change sorter, call it twice with offsets of 0@0 and 0.5@0." - - | dirtyFlags changeSetList classList messageList upperPanes backColor labelBackground | - backColor _ self textBackgroundColor. - labelBackground _ Theme current background. - model myChangeSet ifNil: [ - self flag: #ojo. "Or whatever was last changed, or is top of list, or whatever" - model myChangeSet: ChangeSet changeSetForBaseSystem ]. - - dirtyFlags _ PluggableListMorph - model: model - listGetter: #changeSetDirtyFlags - indexGetter: nil - indexSetter: nil. - dirtyFlags color: backColor. - dirtyFlags _ LayoutMorph newColumn - color: Theme current background; - addMorph: (RectangleLikeMorph new color: Colour transparent) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: ' Unsaved?'); - addMorphUseAll: dirtyFlags. - - changeSetList _ (PluggableListMorphByItem - model: model - listGetter: #changeSetList - indexGetter: #currentCngSet - indexSetter: #showChangeSetNamed: - mainView: self - menuGetter: #changeSetMenu - keystrokeAction: #changeSetListKey:from:) - autoDeselect: false. - changeSetList color: backColor. - changeSetList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Colour transparent) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: 'Change Set name'); - addMorphUseAll: changeSetList. - - classList _ PluggableListMorphByItem - model: model - listGetter: #classList - indexGetter: #currentClassName - indexSetter: #currentClassName: - mainView: self - menuGetter: #classListMenu - keystrokeAction: #classListKey:from:. - classList color: backColor. - classList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Colour transparent) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: 'Classes'); - addMorphUseAll: classList. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: dirtyFlags proportionalWidth: 0.13; - addAdjusterAndMorph: changeSetList proportionalWidth: 0.47; - addAdjusterAndMorph: classList proportionalWidth: 0.4. - - messageList _ PluggableListMorphByItem - model: model - listGetter: #messageList - indexGetter: #currentSelector - indexSetter: #currentSelector: - mainView: self - menuGetter: #messageMenu - keystrokeAction: #messageListKey:from:. - messageList color: backColor. - messageList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Colour transparent) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: 'Methods'); - addMorphUseAll: messageList. - - self layoutMorph - addMorph: upperPanes proportionalHeight: 0.25; - addAdjusterAndMorph: messageList proportionalHeight: 0.2; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.55. - - self setLabel: model labelString! ! -!PreDebugWindow methodsFor: 'GUI building' stamp: 'HAW 1/12/2017 18:47:35' prior: 50336800! - buttonRowForPreDebugWindow: aDebugger - | row aButton triads buttons | - buttons _ OrderedCollection new. - triads _ OrderedCollection withAll: self preDebugButtonSpec. - aDebugger shouldBeAbleToCreateMethod ifTrue: [ triads add: { 'Create'. #createMethod. 'create the missing method' }]. - - triads do: [ :triad | - aButton _ PluggableButtonMorph new model: self. - aButton label: triad first. - aButton action: triad second. - aButton setBalloonText: triad third. - buttons add: aButton]. - - row _ LayoutMorph newRow. - row doAdoptWidgetsColor. - row color: Colour transparent. - row separation: 1. - row addMorphs: buttons. - ^row! ! -!TestRunnerWindow methodsFor: 'constants' stamp: 'jmv 4/16/2011 13:57' prior: 16928704! - runButtonColor - ^ Colour green lighter duller! ! -!ProgressBarMorph methodsFor: 'initialization' stamp: 'jmv 12/2/2011 10:52' prior: 16896023! - defaultColor - ^Colour white! ! -!ProgressBarMorph methodsFor: 'initialization' stamp: 'jmv 12/2/2011 10:53' prior: 16896027! - initialize - super initialize. - progressColor _ Colour gray. - value _ 0.0! ! -!MenuMorph methodsFor: 'construction' stamp: 'len 11/16/2015 02:52' prior: 16866472! - addStayUpIcons - | closeBox pinBox w | - Preferences optionalButtons ifFalse: [ ^self ]. - (self valueOfProperty: #hasStayUpIcons ifAbsent: [ false ]) - ifTrue: [ - self removeProperty: #needsStayUpIcons. - ^self ]. - titleMorph ifNil: [ - "Title not yet there. Flag ourself, so this method is called again when adding title." - self setProperty: #needsStayUpIcons toValue: true. - ^ self]. - closeBox _ PluggableButtonMorph model: self action: #delete. - closeBox icon: Theme current closeIcon; color: Colour transparent. - pinBox _ PluggableButtonMorph model: self action: #stayUp. - pinBox icon: Theme current pushPinIcon; color: Colour transparent. - w _ (titleMorph hasSubmorphs ifTrue: [ titleMorph firstSubmorph morphWidth ] ifFalse: [ 0 ]) + 60. - self addMorphFront: - (LayoutMorph newRow - "Make room for buttons" - morphExtent: w @ (titleMorph morphHeight max: 19); - color: Colour transparent; - addMorph: closeBox fixedWidth: 20; - addMorph: (RectangleLikeMorph new color: Colour transparent) fixedWidth: 4; - addMorph: titleMorph proportionalWidth: 1; - addMorph: (RectangleLikeMorph new color: Colour transparent) fixedWidth: 4; - addMorph: pinBox fixedWidth: 20). - - self setProperty: #hasStayUpIcons toValue: true. - self removeProperty: #needsStayUpIcons! ! -!MenuMorph methodsFor: 'keyboard control' stamp: 'jmv 6/8/2014 20:32' prior: 16867035! - displayFiltered: evt - | matchStr allItems isMatch matches feedbackMorph | - matchStr _ self valueOfProperty: #matchString. - allItems _ self submorphs select: [ :m | - m is: #MenuItemMorph ]. - matches _ allItems select: [ :m | - isMatch _ matchStr isEmpty or: [ - m contents - includesSubstring: matchStr - caseSensitive: false ]. - m isEnabled: isMatch. - isMatch ]. - feedbackMorph _ self valueOfProperty: #feedbackMorph. - feedbackMorph ifNil: [ - feedbackMorph _ StringMorph new color: Colour veryDarkGray. - self addMorphBack: feedbackMorph lock position: (0@ -20). - self - setProperty: #feedbackMorph - toValue: feedbackMorph ]. - feedbackMorph contents: '<' , matchStr , '>'. - matchStr isEmpty ifTrue: [ - feedbackMorph delete. - self removeProperty: #feedbackMorph ]. - matches notEmpty ifTrue: [ - self selectItem: matches first ]! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'jmv 4/14/2016 15:10' prior: 16781489! - drawOn: aCanvas - | rectangle w y0 h y1 y2 scrollbarThickness | - aCanvas frameAndFillRectangle: (0@0 extent: extent) fillColor: self color borderWidth: borderWidth borderColor: borderColor. - y0 _ 1. - w _ extent x-2. - scrollbarThickness _ ScrollBar scrollbarThickness. - completer entryCount > self class itemsPerPage ifTrue: [ - w _ w - scrollbarThickness. - aCanvas - frameRectangle: (extent x - scrollbarThickness@0 - extent: scrollbarThickness @ extent y) - borderWidth: 1 - color: borderColor. - aCanvas - image: (BitBltCanvas arrowOfDirection: #up size: scrollbarThickness) - at: self upButtonPosition. - aCanvas - image: (BitBltCanvas arrowOfDirection: #down size: scrollbarThickness) - at: self downButtonPosition. - h _ extent y - (2 * scrollbarThickness). - y1 _ (1.0 * self firstVisible-1 / completer entryCount * h) ceiling + y0 + scrollbarThickness-1. - y2 _ (1.0 * self lastVisible / completer entryCount * h) floor + y0 + scrollbarThickness -1. - aCanvas - fillRectangle: (extent x - scrollbarThickness+2@y1 corner: extent x-2 @ y2) - color: Colour veryLightGray ]. - self firstVisible - to: self lastVisible - do: [ :index | - rectangle _ 1@y0 extent: w@self class itemHeight. - index = self selected - ifTrue: [ - aCanvas fillRectangle: rectangle color: (Theme current listHighlightFocused: true) ]. - aCanvas - drawString: (completer entries at: index) asString - at: rectangle topLeft - font: self class listFont - color: Theme current text. - y0 _ y0 + self itemHeight ]! ! -!AutoCompleterMorph methodsFor: 'initialization' stamp: 'jmv 12/2/2011 10:09' prior: 16781571! - defaultBorderColor - ^ Colour gray! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 9/9/2012 23:59' prior: 16851609! - drawOn: aCanvas - "Draw the hand itself (i.e., the cursor)." - "This method is only called when we are carrying morphs around..." - aCanvas - stencil: Cursor move - at: 0@0 - color: Colour black! ! -!ImageMorph methodsFor: 'accessing' stamp: 'jmv 6/18/2017 21:32:59' prior: 16854101! - color: aColor - super color: aColor. - (image depth = 1 and: [aColor is: #Color]) ifTrue: [ - image colors: {Colour transparent. aColor}. - self redrawNeeded]! ! -!MenuItemMorph methodsFor: 'accessing' stamp: 'jmv 3/13/2009 10:04' prior: 16865863! - isEnabled: aBoolean - - isEnabled = aBoolean ifTrue: [^ self]. - isEnabled _ aBoolean. - self color: (aBoolean ifTrue: [Colour black] ifFalse: [Colour gray]). -! ! -!MenuItemMorph methodsFor: 'private' stamp: 'jmv 9/9/2012 23:55' prior: 16866162! - offImage - "Return the form to be used for indicating an '' marker" - | form | - form _ Form extent: (self fontToUse ascent-2) asPoint depth: 16. - form getCanvas - frameAndFillRectangle: form boundingBox fillColor: (Colour gray: 0.9) - borderWidth: 1 borderColor: Colour black. - ^form! ! -!MenuItemMorph methodsFor: 'private' stamp: 'jmv 9/9/2012 23:55' prior: 16866174! - onImage - "Return the form to be used for indicating an '' marker" - | form | - form _ Form extent: (self fontToUse ascent-2) asPoint depth: 16. - form getCanvas - frameAndFillRectangle: form boundingBox fillColor: (Colour gray: 0.8) - borderWidth: 1 borderColor: Colour black; - fillRectangle: (form boundingBox insetBy: 2) color: Colour black. - ^form! ! -!LayoutMorph methodsFor: 'accessing' stamp: 'jmv 12/1/2015 09:53' prior: 16863001! - adoptWidgetsColor: paneColor - super adoptWidgetsColor: paneColor. - doAdoptWidgetsColor - ifTrue: [ self color: (Theme current buttonColorFrom: paneColor) ] - ifFalse: [ self color: Colour transparent ]! ! -!LayoutMorph methodsFor: 'initialization' stamp: 'jmv 8/17/2014 21:38' prior: 16863302! - defaultColor - ^Colour gray! ! -!LayoutMorph class methodsFor: 'instance creation' stamp: 'jmv 4/3/2011 22:59' prior: 16863603! - initializedInstance - "Answer a row by default so the 'new morph' menu doesn't fail..." - ^self newRow color: (Colour red alpha: 0.2)! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/5/2015 10:57' prior: 16863624! - example1 -" - self example1 -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example1. -pane color: Colour red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addMorph: (BorderedRectMorph new color: (Colour blue); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addMorph: (BorderedRectMorph new color: (Colour h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 20). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #G) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8); - addMorph: (BorderedRectMorph new color: (Colour h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (BorderedRectMorph new color: (Colour h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -pane morphPosition: 150@130 extent: 400@300. -pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/12/2015 16:42' prior: 16863690! - example10 -" - self example10 openInWorld -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example10. -pane color: Colour red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Colour blue); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Colour h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 20). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #G) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8); - addMorph: (BorderedRectMorph new color: (Colour h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (BorderedRectMorph new color: (Colour h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -^ pane! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/5/2015 10:55' prior: 16863758! -example11 -" - self example11 -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example11. -pane color: Colour red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Colour blue); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Colour h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 20). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #G) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8); - addMorph: (BorderedRectMorph new color: (Colour h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (BorderedRectMorph new color: (Colour h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -pane morphPosition: 150@130 extent: 400@300. -pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/5/2015 11:08' prior: 16863827! - example13 - " - self example13 - " - | pane row innerRow | -pane _ (LayoutMorph newColumn separation: 5) name: #example13. - pane color: Colour red. - row _ (LayoutMorph newRow separation: 5) name: #Row. - innerRow _ (LayoutMorph newRow separation: 5) name: #InnerRow; - color: Colour red. - innerRow - addMorph: (BorderedRectMorph new name: #Box1) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (BorderedRectMorph new name: #Box2) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (BorderedRectMorph new name: #Bar) - layoutSpec: (LayoutSpec proportionalWidth: 1.0 fixedHeight: 10). - row - color: (Colour h: 270 s: 0.2 v: 0.6); - addMorph: innerRow - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 30 minorDirectionPadding: #center); - addMorph: LayoutAdjustingMorph new layoutSpec: (LayoutSpec fixedWidth: 5); - addMorph: (BorderedRectMorph new color: (Colour h: 90 s: 0.6 v: 0.6); name: #Rect1) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40 minorDirectionPadding: #top); - addMorph: LayoutAdjustingMorph new layoutSpec: (LayoutSpec fixedWidth: 5); - addMorph: (BorderedRectMorph new color: (Colour h: 150 s: 0.6 v: 0.6); name: #Rect2) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). - pane addMorph: row layoutSpec: (LayoutSpec proportionalHeight: 0.9). - pane morphPosition: 250@130 extent: 400@300. - pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 2/16/2016 13:27' prior: 16863874! - example1b -" -Based on #example1, but using some Morph instead of RectangleLikeMorph -> extent is not adjustable - self example1b -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example1. -pane color: Colour red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addMorph: (Morph new name: #B); - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addMorph: (BorderedRectMorph new color: (Colour h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 20). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (Morph new name: #G); - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Colour red; - addMorph: (Morph new name: #J); - addMorph: (BorderedRectMorph new color: (Colour h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (BorderedRectMorph new color: (Colour h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -pane morphPosition: 150@130 extent: 400@300. -pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/5/2015 11:25' prior: 16863934! - example2 - " - self example2 - " - | pane row | - pane _ (LayoutMorph newColumn separation: 5) name: #example2. - pane color: Colour red. - row _ (LayoutMorph newRow separation: 5) name: #Row. - row - color: (Colour h: 270 s: 0.2 v: 0.6); - addMorph: (BorderedRectMorph new color: (Colour h: 120 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8 minorDirectionPadding: #bottom); - addMorph: (BorderedRectMorph new color: (Colour h: 90 s: 0.6 v: 0.6); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8 fixedHeight: 40 minorDirectionPadding: #top); - addMorph: (BorderedRectMorph new color: (Colour h: 150 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 0.7 minorDirectionPadding: #center). - pane addMorph: row layoutSpec: (LayoutSpec proportionalHeight: 0.9). - pane morphPosition: 200@180 extent: 400@300. - pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 11/18/2015 09:45' prior: 16863965! - example20 -" - self example20 -" -| column | - -column _ (LayoutMorph newColumn separation: 5) name: #Column. -column - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec proportionalWidth: 0.8 fixedHeight: 20); - addMorph: (BorderedRectMorph new color: (Colour h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec fixedWidth: 40 proportionalHeight: 0.5); - addMorph: (BorderedRectMorph new color: (Colour h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec proportionalWidth: 1.0 fixedHeight: 30). -column morphPosition: 150@130 extent: 400@300. -column openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/5/2015 11:13' prior: 16863988! - example3 - " - self example3 - " - | pane row innerRow | -pane _ (LayoutMorph newColumn separation: 5) name: #example3. - pane color: Colour red. - row _ (LayoutMorph newRow separation: 5) name: #Row. - innerRow _ (LayoutMorph newRow separation: 5) name: #InnerRow; - color: Colour red. - innerRow - addMorph: (BorderedRectMorph new name: #Box1) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (BorderedRectMorph new name: #Box2) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (BorderedRectMorph new name: #Bar) - layoutSpec: (LayoutSpec proportionalWidth: 1.0 fixedHeight: 10). - row - color: (Colour h: 270 s: 0.2 v: 0.6); - addMorph: innerRow - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 30 minorDirectionPadding: #center); - addMorph: (BorderedRectMorph new color: (Colour h: 90 s: 0.6 v: 0.6); name: #Rect1) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40 minorDirectionPadding: #top); - addMorph: (BorderedRectMorph new color: (Colour h: 150 s: 0.6 v: 0.6); name: #Rect2) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). - pane addMorph: row layoutSpec: (LayoutSpec proportionalHeight: 0.9). - pane morphPosition: 250@130 extent: 400@300. - pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 6/8/2014 20:03' prior: 16864030! - example6 - " - Useful example contributed by Ken Dickey - All these should look the same, right? (mmmh this should be a test...) - self example6 - " -| pane rect1 rect2 | -pane _ LayoutMorph newRow separation: 5. "1" -pane addMorph: (StringMorph contents: '1'). - -rect1 := BorderedRectMorph new color: (Colour lightOrange); - morphExtent: 20 @ 30. -pane addMorphFront: rect1. -rect2 := BorderedRectMorph new color: (Colour cyan); - morphExtent: 20 @ 30. -pane addMorphFront: rect2. -pane - color: Colour lightGreen; - morphPosition: 120 @ 50 extent: 180 @ 100; - openInWorld. - -pane _ LayoutMorph newRow separation: 5. "2" -pane addMorph: (StringMorph contents: '2'). - -rect1 := BorderedRectMorph new color: (Colour lightOrange); - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 minorDirectionPadding: #center). -pane addMorph: rect1. -rect2 := BorderedRectMorph new color: (Colour cyan). -pane addMorph: rect2 - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 minorDirectionPadding: #center). -pane - color: Colour lightGreen; - morphPosition: 320 @ 50 extent: 180 @ 100; - openInWorld. - - -pane _ LayoutMorph newRow separation: 5. "3" -pane addMorph: (StringMorph contents: '3'). - -rect1 := BorderedRectMorph new color: (Colour lightOrange). -pane addMorph: rect1 - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 minorDirectionPadding: #center). -rect2 := BorderedRectMorph new color: (Colour cyan); - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 minorDirectionPadding: #center). -pane addMorph: rect2. -pane - color: Colour lightGreen; - morphPosition: 520 @ 50 extent: 180 @ 100; - openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 1/4/2013 13:42' prior: 16864106! - launcherExample - " - self launcherExample - " - | b1 b2 b3 row b4 random buttons | - random _ Random new. - b1 _ PluggableButtonMorph model: [ Date today print ] action: #value label: 'Date'. - b2 _ PluggableButtonMorph model: [ Time now print ] action: #value label: 'Time'. - b3 _ PluggableButtonMorph model: [ SystemVersion current print ] action: #value label: 'Version'. - b4 _ PluggableButtonMorph model: [ random next print ] action: #value label: 'Random'. - buttons _ {b1. b2. b3. b4}. - buttons do: [ :button | - button color: Colour lightRed ]. - row _ LayoutMorph newRow - color: Colour red; - addMorphs: buttons; - morphExtent: 300 @ 40. - ^ row openInWorld! ! -!ProgressMorph methodsFor: 'initialization' stamp: 'jmv 12/2/2011 10:55' prior: 16896260! - defaultColor - ^Colour veryLightGray! ! -!HaloHandleMorph class methodsFor: 'accessing' stamp: 'jmv 11/18/2010 09:44' prior: 16850573! - circleForm: extent - " - CircleForm _ nil - " - | r d l bw center | - (CircleForm isNil or: [ CircleForm extent ~= extent ]) ifTrue: [ - center _ extent -1 * 0.5. - r _ center r * 0.75. - bw _ 1.3. - CircleForm _ Form extent: extent depth: 32. - 0 to: extent y - 1 do: [ :y | - 0 to: extent x - 1 do: [ :x | - d _ (x@y - center) r. - l _ (r - d max: 0.0) min: bw. - CircleForm - colorAt: x @ y - put: (Colour white alpha: (l / bw)) - ]]. - ]. - ^CircleForm! ! -!HaloMorph methodsFor: 'initialization' stamp: 'jmv 6/18/2017 21:33:32' prior: 16850854! - defaultColor - "answer the default color/fill style for the receiver" - ^ Colour - r: 0.6 - g: 0.8 - b: 1.0! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 5/27/2015 13:42' prior: 16850874! - addHandle: handleSpec - "Add a handle within the halo box as per the haloSpec, and set it up to respond to the given event by sending the given selector to the given recipient. Return the handle." - - | handle aPoint colorToUse form icon | - aPoint _ self - positionIn: haloBox - horizontalPlacement: handleSpec horizontalPlacement - verticalPlacement: handleSpec verticalPlacement. - colorToUse _ Colour colorFrom: handleSpec color. - handle _ HaloHandleMorph new color: colorToUse. - self addMorph: handle. - handle morphBoundsInWorld: (Rectangle center: aPoint extent: self class handleSize asPoint). - handleSpec iconSymbol ifNotNil: [ :iconName | - form _ self class icons at: iconName ifAbsent: [self class perform: iconName]. - form ifNotNil: [ - icon _ ImageMorph new - image: form; - color: colorToUse makeForegroundColor; - lock. - handle addMorphFront: icon position: 0@0 ]]. - handle mouseUpSelector: #endInteraction. - handle setBalloonText: handleSpec hoverHelp. - ^handle! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/4/2016 22:14' prior: 16850920! - addNameString: aString - "Add a name display centered beneath the bottom of the outer rectangle. Return the handle." - - | nameMorph namePosition nameBackground | - nameBackground _ RectangleLikeMorph new - color: ((target is: #SystemWindow) ifTrue: [target windowColor] ifFalse: [Colour lightBlue alpha: 0.9]). - nameMorph _ StringMorph contents: aString. - nameMorph color: Colour black. - nameBackground morphExtent: nameMorph morphExtent + 4. - namePosition _ haloBox width - nameMorph morphWidth // 2 @ (haloBox height). - self addMorph: nameBackground position: namePosition - 2. - self addMorph: nameMorph position: namePosition. - ^nameMorph! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 9/22/2012 15:18' prior: 16851047! - doRot: evt with: rotHandle - "Update the rotation of my target if it is rotatable. Keep the relevant command object up to date." - - | degrees | -self revisar. - self flag: #jmvVer2. - evt hand obtainHalo: self. - degrees _ (evt eventPosition - target referencePosition) degrees. - degrees _ degrees - angleOffset degrees. - degrees _ degrees detentBy: 10.0 atMultiplesOf: 90.0 snap: false. - degrees = 0.0 - ifTrue: [rotHandle color: Colour lightBlue] - ifFalse: [rotHandle color: Colour blue]. - rotHandle submorphsDo: - [:m | m color: rotHandle color makeForegroundColor]. - self removeAllHandlesBut: rotHandle. - - target rotationDegrees: degrees. - - rotHandle morphPositionInWorld: evt eventPosition - (rotHandle morphExtent // 2)! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 9/20/2012 00:01' prior: 16851135! - setDismissColor: evt with: dismissHandle - "Called on mouseStillDown in the dismiss handle; set the color appropriately." - - | colorToUse | - evt hand obtainHalo: self. - colorToUse _ (dismissHandle morphContainsPoint: (dismissHandle internalizeFromWorld: evt eventPosition)) - ifFalse: [ Colour red muchLighter ] - ifTrue: [ Colour lightGray ]. - dismissHandle color: colorToUse! ! -!InnerListMorph methodsFor: 'initialization' stamp: 'jmv 5/27/2013 09:39' prior: 16855063! - initialize - super initialize. - self color: Colour black. - font _ Preferences standardListFont. - listItems _ #(). - selectedRow _ nil. - selectedRows _ Set new. - highlightedRow _ nil! ! -!InnerTextMorph methodsFor: 'drawing' stamp: 'jmv 10/16/2013 19:55' prior: 16855561! - debugDrawLineRectsOn: aCanvas - "Shows where text line rectangles are" - - self textComposition lines do: [ :line | - aCanvas - frameRectangle: line rectangle - borderWidth: 1 - color: Colour brown ] -! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/17/2015 15:51' prior: 50333232! - initialize - super initialize. - extent _ 400@300. - color _ Colour white. - grid _ 8@6. - gridLineWidth _ 2. - gridColor _ Colour black. - selectionColor _ Colour red! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 23:18' prior: 50333240! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - from _ self toGridPoint: localEventPosition. - outlineMorph _ BorderedRectMorph new - borderColor: Colour black; - color: Colour transparent; - openInWorld; - hide. - self selectTo: localEventPosition! ! -!HoverHelpMorph methodsFor: 'initialization' stamp: 'jmv 9/25/2011 23:12' prior: 16853831! - defaultColor - - ^Colour r: 1.0 g: 1.0 b: 0.7! ! -!HoverHelpMorph methodsFor: 'drawing' stamp: 'jmv 12/20/2014 15:09' prior: 16853866! - drawOn: aCanvas - - | r | - r _ self morphLocalBounds. - aCanvas roundRect: r color: self color radius: 4. - aCanvas - textComposition: textComposition - bounds: (r insetBy: 4) - color: Colour black - selectionColor: (Theme current textHighlightFocused: false)! ! -!WorldState methodsFor: 'drawing' stamp: 'jmv 3/2/2017 19:40:12' prior: 50339659! - drawInvalidAreasSubmorphs: submorphs - "Redraw the damaged areas of the given canvas and clear the damage list. Return a collection of the areas that were redrawn." - - | initialRectsToRepair currentRectsToRepair newRectsToRepair morphsToDraw rectsForEachMorph thisMorphRects reuse i n morph morphBounds morphClipRect | - - "The simple implementation is slowers as it draws morph areas that will later be covered by other morphs. - But it works, and it is easier to understand. - See en.wikipedia.org/wiki/Painter's_algorithm" - true not ifTrue: [ ^self simpleDrawInvalidAreasSubmorphs: submorphs ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - initialRectsToRepair _ damageRecorder invalidRectsFullBounds: world viewBox. - damageRecorder reset. - currentRectsToRepair _ OrderedCollection new. - newRectsToRepair _ OrderedCollection withAll: initialRectsToRepair. - morphsToDraw _ OrderedCollection new. - rectsForEachMorph _ OrderedCollection new. - thisMorphRects _ OrderedCollection new. - n _ submorphs size. - i _ 1. - - "The idea here is to iterate morphs front to back, i.e. first the ones on top. - For each morph, record the rectangles it affects. And if a morph is opaque, remove the area behind it from the list of rectangles to be repaired. - This means, for example, that morphs completely covered might even not be redrawn. - this is a huge performance gain when there are many morphs on screen, especially if there are more than ten open windows, and Theme uses opaque colors. - See 'A reverse painter's algorithm' at en.wikipedia.org/wiki/Painter's_algorithm" - [ i <= n and: [ newRectsToRepair notEmpty ]] whileTrue: [ - morph _ submorphs at: i. - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - reuse _ currentRectsToRepair. - currentRectsToRepair _ newRectsToRepair. - newRectsToRepair _ reuse removeAll. - currentRectsToRepair do: [ :r | - (morphBounds intersects: r) - ifTrue: [ - morphClipRect _ morphBounds intersect: r. - thisMorphRects add: morphClipRect. "We could perhaps try and join adjacent rectangles in this collection..." - morph addPossiblyUncoveredAreasIn: r to: newRectsToRepair ] - ifFalse: [ - newRectsToRepair add: r ]]. - thisMorphRects ifNotEmpty: [ - morphsToDraw add: morph. - rectsForEachMorph add: thisMorphRects. - thisMorphRects _ OrderedCollection new. - ]]. - i _ i + 1 ]. - - "*make this true to flash damaged areas for testing*" - Preferences debugShowDamage ifTrue: [ world fillRects: initialRectsToRepair color: Colour gray ]. - - "Draw world background on those areas that were not completely covered by opaque morphs" - i > n ifTrue: [ - newRectsToRepair do: [ :r | - world drawOn: (canvas newClipRect: r) ]]. - - "Now, draw the recorded areas of selected morphs, back to front." - morphsToDraw with: rectsForEachMorph reverseDo: [ :m :xrects | - "Here we could think about merging all xrects into just one call... - This would mean drawing each morph just once. - But that would mean drawing pixels we were not told to. There could be other morphs in that area that are not even being drawn!! - See WorldState class >> #experiment1" -" rr _ nil." - xrects do: [ :r | -" rr _ rr ifNil: [ r ] ifNotNil: [ r quickMerge: rr ]." - (canvas newClipRect: r) fullDraw: m. - ]. -" (canvas newClipRect: rr) fullDraw: m" - "*make this true to flash damaged areas for testing*" - Preferences debugShowDamage2 ifTrue: [ - world flashRects: xrects color: Colour random ]. - ]. - - "Answer a list of rectangles to be updated on the Display. - This usually is not performance critical, drawing morphs is slower than just exposing the Display." - "What should we force on Display? Whatever was asked? Each small rect that was updated? A single bigger rect? - Right now, answer whatever was asked... Maybe this could be changed if that enhances performance... - (think of vnc over slow networks)" - ^ initialRectsToRepair! ! -!WorldState class methodsFor: 'sample code' stamp: 'jmv 3/2/2017 19:39:21' prior: 50339881! - experiment1 - "To play with and learn about morphic Display update logic. - Remove the morphs when done!!" - " - WorldState experiment1 - " - | dr morph1 morph2 s w | - morph1 _ RectangleLikeMorph new openInWorld. - morph2 _ RectangleLikeMorph new openInWorld. - morph2 color: Colour green. - morph2 morphPosition: 200@800 extent: 50@40. - morph1 morphPosition: 120@720 extent: 220@100. - - w _ self runningWorld. - s _ w instVarNamed: 'worldState'. - dr _ s instVarNamed: 'damageRecorder'. - - dr doFullRepaint. - dr reset; - " recordInvalidRect: (100@700 corner: 400@900);" - recordInvalidRect: (100@700 corner: 150@900); - recordInvalidRect: (300@700 corner: 400@900). - Display fillColor: Colour gray. - "Do not draw the area used by the small rectangle, unless it is also drawn!!" - s drawInvalidAreasSubmorphs: {morph1. morph2 }! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 12/20/2014 15:35' prior: 16877458! - drawCurrentAsError - "The morph (or one of its submorphs) had an error in its drawing method." - | r w | - r _ currentMorph morphLocalBounds. - w _ r extent > (50@50) - ifTrue: [ 6 ] - ifFalse: [ 2 ]. - self - frameAndFillRectangle: r - fillColor: Colour red - borderWidth: w - borderColor: Colour yellow. - self line: r topLeft to: r bottomRight-w width: w color: Colour yellow. - self line: r topRight -(w@0) to: r bottomLeft -(0@w)width: w color: Colour yellow! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 6/1/2015 13:30' prior: 16877630! - drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - aColor = Colour black ifFalse: [ | topColor | - topColor _ aColor alphaMixed: 0.25 with: Colour black. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint - font: fontOrNil - color: topColor ]. - aColor = Colour white ifFalse: [ | bottomColor | - bottomColor _ aColor alphaMixed: 0.22 with: Colour white. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + (0@2) - font: fontOrNil - color: bottomColor ]. - ^self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + (0@1) - font: fontOrNil - color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 11/29/2015 18:01' prior: 16786666! - fillRectangle: aRectangle color: aColor - "Fill the given rectangle." - - aColor isTransparent ifFalse: [ - self - frameAndFillRectangle: aRectangle - fillColor: aColor - borderWidth: 0 - borderColor: Colour transparent ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 11/29/2015 18:14' prior: 16786789! - reverseRectangleBorder: r borderWidth: borderWidth - " - Display getCanvas - reverseRectangleBorder: (10@10 extent: 300@200) - borderWidth: 20. - Display forceToScreen - " - | rect | - rect _ currentTransformation displayBoundsOfTransformOf: r. - port - sourceForm: nil; - fillColor: Colour gray; - combinationRule: Form reverse; - frameRect: rect borderWidth: borderWidth! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 4/9/2015 09:46' prior: 16787146! - setPaintColor: aColor - "Install a new color used for filling." - | paintColor | - paintColor _ aColor ifNil: [ Colour transparent ]. - (paintColor is: #Color) ifFalse: [ - ^self error: 'Cannot install color' ]. - - "Okay, so paintColor really *is* a color" - port sourceForm: nil. - (paintColor isOpaque or: [ self depth < 32]) ifTrue: [ - port fillColor: paintColor. - port combinationRule: Form paint. - ^self ]. - - "BitBlt setup for alpha mapped transfer" - port fillColor: paintColor. - port combinationRule: Form blend! ! -!BitBltCanvas class methodsFor: 'cached forms' stamp: 'jmv 4/17/2015 12:16' prior: 16787260! - steButtonForm: extent - ^self cachedForms - at: { #steButton . extent } - ifAbsentPut: [ - | form canvas | - form _ Form extent: extent depth: 32. - canvas _ form getCanvas. - canvas - roundRect: (0@0 extent: extent) - color: (Colour gray: 0.4) - radius: 4. - canvas - roundRect: (1@1 extent: extent-2) - color: Colour white - radius: 4 - gradientTop: 1.0 - gradientCenter: 0.73 - gradientBottom: 0.94 - gradient1Height: (extent y-8+1 max: extent y//2). - form]! ! -!BitBltCanvas class methodsFor: 'cached forms' stamp: 'jmv 4/17/2015 12:16' prior: 16787305! - verticalGrayGradient: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - ^self cachedForms - at: { #vertical. height. gradientTopFactor . gradientBottomFactor } - ifAbsentPut: [ - Form - verticalGradient: height - topColor: (Colour gray: gradientTopFactor) - bottomColor: (Colour gray: gradientBottomFactor) ]! ! -!BitBltCanvas class methodsFor: 'cached arrow forms' stamp: 'jmv 1/7/2015 08:12' prior: 16787328! - buildArrowOfDirection: aSymbolDirection size: finalSizeInteger - "PRIVATE - create an arrow with aSymbolDirectionDirection, - finalSizeInteger and aColor - - aSymbolDirectionDirection = #up, #down. #left or #right - (self buildArrowOfDirection: #down size: 120) display - (self buildArrowOfDirection: #up size: 120) display - " - - | resizeFactor resizedForm f e c bottomMargin topMargin | - resizeFactor _ 4. - e _ finalSizeInteger@finalSizeInteger*resizeFactor. - f _ Form extent: e depth: 32. - c _ Colour gray: 0.5. - topMargin _ finalSizeInteger * 3//4. - bottomMargin _ finalSizeInteger * 4//4. - 0 to: e y-1-bottomMargin do: [ :y | - 0 to: e x -1 do: [ :x | - (e x / 2 - 1 - x) abs * 2 + topMargin < y ifTrue: [ - f colorAt: x@y put: c - ] - ] - ]. - resizedForm _ f - magnify: f boundingBox - by: 1 / resizeFactor - smoothing: 4. - - aSymbolDirection == #right ifTrue: [ - resizedForm _ resizedForm rotatedByDegrees: 90 ]. - aSymbolDirection == #down ifTrue: [ - resizedForm _ resizedForm rotatedByDegrees: 180 ]. - aSymbolDirection == #left ifTrue: [ - resizedForm _ resizedForm rotatedByDegrees: 270 ]. - - aSymbolDirection == #up ifFalse: [ - resizedForm _ resizedForm - copy: (resizedForm boundingBox insetBy: (resizedForm width - finalSizeInteger/ 2.0) rounded) ]. - - ^resizedForm! ! -!BitBltCanvas class methodsFor: 'cached arrow forms' stamp: 'jmv 10/9/2014 23:02' prior: 16787371! - buildArrowWith: insideForm borderForm: borderForm - | extent translucentForm color insideSpec borderSpec border background alpha| - " - Display getCanvas - image: (BitBltCanvas buildArrowWith: BitBltCanvas downInsideForm borderForm: BitBltCanvas downBorderForm) - at: 20@20 - Display getCanvas - image: (BitBltCanvas buildArrowWith:BitBltCanvas upInsideForm borderForm: BitBltCanvas upBorderForm) - at: 40@20 - " - extent _ insideForm extent - (1@2). - translucentForm _ Form extent: insideForm extent depth: 32. - 0 to: extent x-1 do: [ :x | - 0 to: extent y-1 do: [ :y | - insideSpec _ insideForm colorAt: x@(y+1). - borderSpec _ borderForm colorAt: x@(y+1). - insideSpec = (Colour r: 0.0 g: 0.0 b: 1.0) - ifTrue: [ color _ Colour transparent ] - ifFalse: [ - borderSpec = (Colour r: 1.0 g: 0.0 b: 0.0) - ifTrue: [ color _ insideSpec ] - ifFalse: [ - border _ x < (extent x//2) - ifTrue: [Colour white] - ifFalse: [Colour black]. - background _ borderForm colorAt: extent x@(y+1). - alpha _ borderSpec red asFloat - background red / (border red - background red). - color _ border alpha: (alpha min: 1 max: 0) ]]. - translucentForm colorAt: x@y put: color ]]. - ^translucentForm! ! -!Theme methodsFor: 'colors' stamp: 'jmv 11/19/2010 14:06' prior: 16935417! - background - ^ Colour r: 0.7 g: 0.72 b: 0.83! ! -!Theme methodsFor: 'colors' stamp: 'jmv 11/23/2010 09:42' prior: 16935421! - buttonColorFrom: aColor - ^ Display depth <= 8 - ifTrue: [ Colour transparent ] - ifFalse: [ aColor paler ]! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/14/2011 08:50' prior: 16935427! - buttonLabel - ^Colour gray: 0.18! ! -!Theme methodsFor: 'colors' stamp: 'len 6/9/2016 17:38' prior: 16935430! - errorColor - ^ Colour red lighter! ! -!Theme methodsFor: 'colors' stamp: 'len 6/9/2016 17:40' prior: 16935433! - failureColor - ^ Colour yellow lighter! ! -!Theme methodsFor: 'colors' stamp: 'len 11/14/2015 02:34' prior: 16935453! - scrollbarButtonColor - ^Colour gray: 0.95! ! -!Theme methodsFor: 'colors' stamp: 'len 11/17/2015 23:55' prior: 16935457! - scrollbarColor - ^Colour white! ! -!Theme methodsFor: 'colors' stamp: 'len 11/14/2015 02:34' prior: 16935460! - scrollbarSliderShadowColor - ^Colour white! ! -!Theme methodsFor: 'colors' stamp: 'len 6/9/2016 17:38' prior: 16935464! - successColor - ^ Colour green lighter! ! -!Theme methodsFor: 'colors' stamp: 'cbr 11/7/2010 18:00' prior: 16935468! - text - ^ Colour black! ! -!Theme methodsFor: 'colors' stamp: 'jmv 10/16/2013 22:08' prior: 16935471! - textCursor - ^ Display depth <= 2 - ifTrue: [ Colour black ] - ifFalse: [ self text ]! ! -!Theme methodsFor: 'colors' stamp: 'jmv 5/30/2011 14:31' prior: 16935476! - textHighlight - "A nice light blue." - " - ^ Colour r: 0.71 g: 0.835 b: 1.0 - ^ Colour hue: 214 chroma: 0.29 luminance: 0.816 - " - ^Colour hue: 204 chroma: 0.29 luminance: 0.77! ! -!Theme methodsFor: 'colors' stamp: 'jmv 11/23/2010 09:58' prior: 16935484! - textHighlightFocused: focused - "A nice light blue." - | textHighlight | - Display depth = 1 ifTrue: [^ Colour veryLightGray]. - Display depth = 2 ifTrue: [^ Colour gray: 0.87]. - textHighlight _ self textHighlight. - ^focused - ifTrue: [ textHighlight ] - ifFalse: [ self unfocusedTextHighlightFrom: textHighlight ]! ! -!Theme methodsFor: 'colors' stamp: 'cbr 12/6/2010 20:08' prior: 16935501! - windowLabel - ^Colour gray: 0.3! ! -!Theme methodsFor: 'menu colors' stamp: 'jmv 5/26/2011 09:07' prior: 16935505! - menu - Display depth <= 2 ifTrue: [^ Colour white]. - ^Colour r: 0.75 g: 0.75 b: 0.75 alpha: 0.93! ! -!Theme methodsFor: 'menu colors' stamp: 'jmv 11/23/2010 09:45' prior: 16935511! - menuHighlight - ^ Display depth < 8 - ifTrue: [ Colour veryLightGray ] - ifFalse: [ self textHighlight ]! ! -!Theme methodsFor: 'menu colors' stamp: 'cbr 11/7/2010 18:28' prior: 16935517! - menuText - ^ Colour black! ! -!Theme methodsFor: 'menu colors' stamp: 'jmv 11/28/2010 08:04' prior: 16935520! - menuTitleBar - Display depth = 1 ifTrue: [^ Colour white]. - Display depth = 2 ifTrue: [^ Colour gray]. - ^ self menu darker! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 4/15/2011 14:59' prior: 16935526! - browser - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Colour r: 0.5 g: 0.7 b: 0.4]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 2/14/2013 11:05' prior: 16935539! - debugger - ^Colour h: 0.0 s: 0.6 v: 0.7! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 11/23/2010 09:16' prior: 16935543! - defaultWindowColor - ^ Colour lightGray! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 11/18/2010 12:44' prior: 16935551! - fileContentsBrowser - ^Colour tan duller! ! -!Theme methodsFor: 'tool colors' stamp: 'cbr 12/4/2010 18:44' prior: 16935555! - fileList - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Colour r: 0.7 g: 0.55 b: 0.7 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 5/23/2012 19:23' prior: 16935561! - messageNames - - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Colour r: 0.53 g: 0.77 b: 0.382 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'cbr 12/4/2010 18:45' prior: 16935567! - messageSet - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Colour r: 0.45 g: 0.6 b: 0.85 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 11/18/2010 12:44' prior: 16935573! - object - ^Colour white duller! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/28/2012 09:41' prior: 16935576! - packageList - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Colour r: 0.63 g: 0.47 b: 0.08 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 11/23/2010 09:17' prior: 16935582! - testRunner - ^ self useUniformColors - ifTrue: [ self defaultWindowColour ] - ifFalse: [ (Colour r: 0.650 g: 0.753 b: 0.976) duller ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/16/2011 08:15' prior: 16935589! - textEditor - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Colour gray: 0.6 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'cbr 12/4/2010 18:45' prior: 16935595! - transcript - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Colour r: 0.8 g: 0.6 b: 0.3 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'cbr 12/18/2010 17:56' prior: 16935601! - versionsBrowser - ^ self useUniformColors - ifTrue: [ self defaultWindowColour ] - ifFalse: [ (Colour r: 0.869 g: 0.753 b: 1.0) duller ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/16/2011 08:13' prior: 16935608! - workspace - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Colour h: 60.0 s: 0.73 v: 0.72 ]! ! -!Theme methodsFor: 'widget colors' stamp: 'jmv 5/23/2012 18:49' prior: 16935614! - acceptButton - - ^ self buttonColorFrom: - (self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Colour r: 0.2 g: 0.6 b: 0.1 ])! ! -!Theme methodsFor: 'widget colors' stamp: 'jmv 5/23/2012 18:51' prior: 16935621! - cancelButton - - ^ self buttonColorFrom: - (self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Colour r: 0.8 g: 0.2 b: 0.2 ])! ! -!Theme methodsFor: 'widget colors' stamp: 'cbr 10/10/2012 23:36' prior: 16935647! - textPane - ^Colour white! ! -!SHTextStylerST80 class methodsFor: 'style table' stamp: 'pb 5/4/2016 17:44' prior: 16903544! - initialTextAttributes - | d element color emphasis attrArray | - d _ IdentityDictionary new. - self styleTable do: [ :each | - element _ each first. - color _ each at: 2 ifAbsent: nil. - color _ color ifNotNil: [ Colour colorFrom: color ]. - emphasis _ each at: 3 ifAbsent: nil. - attrArray _ self attributeArrayForColor: color emphasis: emphasis. - attrArray notEmpty ifTrue: [ - d at: element put: attrArray ]]. - ^ d! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3106-ChangeReferencesToColour-JuanVuletich-2017Jun19-11h07m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3106] on 19 June 2017 at 12:18:58 pm'! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/19/2017 12:18:51' prior: 50345512! - * aNumber - "Answer this color with its RGB multiplied by the given number. " - " - (Colour brown *2) display - " - ^ (Colour new - setRed: (self red * aNumber min: 1.0 max: 0.0) - green: (self green * aNumber min: 1.0 max: 0.0) - blue: (self blue * aNumber min: 1.0 max: 0.0)) - alpha: self alpha! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/19/2017 12:18:50' prior: 50349789! - * aNumber - "Answer this color with its RGB multiplied by the given number. " - " - (Color brown *2) display - " - ^ (Colour new - setRed: (self red * aNumber min: 1.0 max: 0.0) - green: (self green * aNumber min: 1.0 max: 0.0) - blue: (self blue * aNumber min: 1.0 max: 0.0) - colorSpace: colorSpace) - alpha: self alpha! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3107-KeepAlphaOnColorMultiply-JuanVuletich-2017Jun19-12h18m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3106] on 19 June 2017 at 11:52:30 am'! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - -| all | -all := Color allInstances. -all elementsForwardIdentityTo: (all collect: [ :c | c * 1 ]). -all := TranslucentColor allInstances. -all elementsForwardIdentityTo: (all collect: [ :c | c * 1 ]).! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3108-MigrateInstancesToColour-JuanVuletich-2017Jun19-11h51m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3103] on 19 June 2017 at 11:15:55 am'! - -TranslucentColour removeSelector: #setRed:green:blue:alpha:colorSpace:! - -TranslucentColour removeSelector: #setRed:green:blue:alpha:colorSpace:! - -Colour removeSelector: #floatRGB! - -Colour removeSelector: #floatRGB! - -Colour removeSelector: #setRed:green:blue:colorSpace:! - -Colour removeSelector: #setRed:green:blue:colorSpace:! - -Smalltalk removeClassNamed: #Color! - -Smalltalk removeClassNamed: #Color! - -Smalltalk removeClassNamed: #TranslucentColor! - -Smalltalk removeClassNamed: #TranslucentColor! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3109-removeColor-JuanVuletich-2017Jun19-11h11m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3108] on 19 June 2017 at 11:58:54 am'! - -FloatArray variableWordSubclass: #Color - instanceVariableNames: '' - classVariableNames: 'CachedColormaps ColorNamesDict FromGrayColormaps GrayToIndexMap IndexedColors MaskingMap ToGrayColormaps' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -!classDefinition: #Color category: #'Graphics-Primitives'! -FloatArray variableWordSubclass: #Color - instanceVariableNames: '' - classVariableNames: 'CachedColormaps ColorNamesDict FromGrayColormaps GrayToIndexMap IndexedColors MaskingMap ToGrayColormaps' - poolDictionaries: '' - category: 'Graphics-Primitives'! -!Color commentStamp: 'jmv 6/18/2017 20:14:31' prior: 0! - This class represents abstract color, regardless of the depth of bitmap it will be shown in. At the very last moment a Color is converted to a pixelValue that depends on the depth of the actual Bitmap inside the Form it will be used with. The supported depths (in bits) are 1, 2, 4, 8, 16, and 32. The number of actual colors at these depths are: 2, 4, 16, 256, 32768, and 16 million. (See comment in BitBlt.) To change the depth of the Display and set how many colors you can see, execute: (Display newDepth: 8). (See comment in DisplayMedium) - Color is represented as the amount of light in red, green, and blue. White is (1.0, 1.0, 1.0) and black is (0, 0, 0). Pure red is (1.0, 0, 0). These colors are "additive". Think of Color's instance variables as: - r amount of red, a Float between 0.0 and 1.0. - g amount of green, a Float between 0.0 and 1.0. - b amount of blue, a Float between 0.0 and 1.0. - Many colors are named. You find a color by name by sending a message to class Color, for example (Color lightBlue). Also, (Color red: 0.2 green: 0.6 blue: 1.0) or (Color r: 0.2 g: 0.6 b: 1.0) creates a color. (see below) - A color is essentially immutable. Once you set red, green, and blue, you cannot change them. Instead, create a new Color and use it. - Applications such as contour maps and bar graphs will want to display one of a set of shades based on a number. Convert the range of this number to an integer from 1 to N. Then call (Color green lightShades: N) to get an Array of colors from white to green. Use the Array messages at:, atPin:, or atWrap: to pull out the correct color from the array. atPin: gives the first (or last) color if the index is out of range. atWrap: wraps around to the other end if the index is out of range. - Here are some fun things to run in when your screen has color: - Pen new mandala: 30 diameter: Display height-100. - Pen new web "Draw with the mouse, opt-click to end" - Display fillWhite. Pen new hilberts: 5. - Form toothpaste: 30 "Draw with mouse, opt-click to end" - -Messages: - mixed: proportion with: aColor Answer this color mixed with the given color additively. The proportion, a number between 0.0 and 1.0, determines what what fraction of the receiver to use in the mix. - - + add two colors - - subtract two colors - * multiply the values of r, g, b by a number or an Array of factors. ((Color named: #white) * 0.3) gives a darkish gray. (aColor * #(0 0 0.9)) gives a color with slightly less blue. - / divide a color by a factor or an array of three factors. - - hue Returns the hue of the color. On a wheel from 0 to 360 with pure red at 0 and again at 360. - saturation Returns the saturation of the color. 0.0 to 1.0 - brightness Returns the brightness of the color. 0.0 to 1.0 - - name Look to see if this Color has a name. - display Show a swatch of this color tracking the cursor. - - lightShades: thisMany An array of thisMany colors from white to the receiver. - darkShades: thisMany An array of thisMany colors from black to the receiver. Array is of length num. - mix: color2 shades: thisMany An array of thisMany colors from the receiver to color2. - wheel: thisMany An array of thisMany colors around the color wheel starting and ending at the receiver. - - pixelValueForDepth: d Returns the bits that appear be in a Bitmap of this depth for this color. Represents the nearest available color at this depth. Normal users do not need to know which pixelValue is used for which color. - -Messages to Class Color. - red: r green: g blue: b Return a color with the given r, g, and b components. - r: g: b: Same as above, for fast typing. - - hue: h saturation: s brightness: b Create a color with the given hue, saturation, and brightness. - - pink - blue - red ... Many colors have messages that return an instance of Color. - canUnderstand: #brown Returns true if #brown is a defined color. - names An OrderedCollection of the names of the colors. - named: #notAllThatGray put: aColor Add a new color to the list and create an access message and a class variable for it. - fromUser Shows the palette of colors available at this display depth. Click anywhere to return the color you clicked on. - - hotColdShades: thisMany An array of thisMany colors showing temperature from blue to red to white hot. - - stdColorsForDepth: d An Array of colors available at this depth. For 16 bit and 32 bits, returns a ColorGenerator. It responds to at: with a Color for that index, simulating a very big Array. - - colorFromPixelValue: value depth: d Returns a Color whose bit pattern (inside a Bitmap) at this depth is the number specified. Normal users do not need to use this. - -(See also comments in these classes: Form, Bitmap, BitBlt) - -Default colorSpace is #sRGB. Subclasses might use other color spaces! - -Color variableWordSubclass: #TranslucentColor - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -!classDefinition: #TranslucentColor category: #'Graphics-Primitives'! -Color variableWordSubclass: #TranslucentColor - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Primitives'! -!TranslucentColor commentStamp: '' prior: 0! - A TranslucentColor behaves just like a normal color, except that it will pack its alpha value into the fourth position. This allows creating forms with translucency for use with the alpha blend function of BitBlt. An alpha of zero is transparent, and 1.0 is opaque.! -!Color methodsFor: 'access' stamp: 'jmv 1/31/2011 09:25'! - alpha - "Return the opacity ('alpha') value of opaque so that normal colors can be compared to TranslucentColors." - - ^ 1.0 -! ! -!Color methodsFor: 'access' stamp: 'jmv 6/18/2017 20:35:34'! - blue - "Return the blue component of this color, a float in the range [0.0..1.0]." - - ^ self at: 3! ! -!Color methodsFor: 'access' stamp: 'jmv 6/18/2017 20:33:10'! - brightness - "Return the brightness of this color, a float in the range [0.0..1.0]. - Color red brightness - " - - "Do not include alpha if TranslucentColor" - ^ (self red max: self green) max: self blue! ! -!Color methodsFor: 'access' stamp: 'jmv 6/18/2017 20:34:30'! - chroma - "Return the chroma of this color, a value between 0.0 and 1.0, somewhat related to saturation. - See http://en.wikipedia.org/wiki/HSL_and_HSV - Color red chroma - Color gray chroma - " - - | r g b max min | - r _ self red. - g _ self green. - b _ self blue. - max _ (r max: g) max: b. - min _ (r min: g) min: b. - ^max - min! ! -!Color methodsFor: 'access' stamp: 'jmv 6/18/2017 20:35:28'! - green - "Return the green component of this color, a float in the range [0.0..1.0]." - - ^ self at: 2! ! -!Color methodsFor: 'access' stamp: 'jmv 6/18/2017 20:31:54'! - hue - "Return the hue of this color, an angle in the range [0.0..360.0]. - Color orange hue - " - - | r g b max min span h | - r _ self red. - g _ self green. - b _ self blue. - max _ (r max: g) max: b. - min _ (r min: g) min: b. - span _ (max - min) asFloat. - span = 0.0 ifTrue: [ ^ 0.0 ]. - - r = max ifTrue: [ - h _ ((g - b) asFloat / span) * 60.0. - ] ifFalse: [ - g = max - ifTrue: [ h _ 120.0 + (((b - r) asFloat / span) * 60.0). ] - ifFalse: [ h _ 240.0 + (((r - g) asFloat / span) * 60.0). ]. - ]. - - ^h mod: 360.0! ! -!Color methodsFor: 'access' stamp: 'KenD 1/23/2013 18:19'! - icon - "Answer a swatch to display in a menu or browser" - ^self swatch! ! -!Color methodsFor: 'access' stamp: 'KenD 1/23/2013 18:17'! - iconOrThumbnailOfSize: aNumberOrPoint - "Answer an appropiate form to represent the receiver" - | form | - form := Form extent: aNumberOrPoint asPoint asPoint depth: 32. - form fillColor: self. - ^ form! ! -!Color methodsFor: 'access' stamp: 'jmv 4/19/2013 16:46'! - luminance - "Return the luminance of this color, a brightness value weighted by the human eye's color sensitivity." - - ^ ((299 * self red) + - (587 * self green) + - (114 * self blue)) / 1000! ! -!Color methodsFor: 'access' stamp: 'jmv 6/18/2017 20:35:25'! - red - "Return the red component of this color, a float in the range [0.0..1.0]." - - ^ self at: 1! ! -!Color methodsFor: 'access' stamp: 'jmv 6/18/2017 20:34:08'! - saturation - "Return the saturation of this color, a value between 0.0 and 1.0. - Color red saturation - Color gray saturation - " - - | r g b max min | - r _ self red. - g _ self green. - b _ self blue. - max _ (r max: g) max: b. - min _ (r min: g) min: b. - max = 0.0 ifTrue: [ ^0.0 ]. - ^max - min / max! ! -!Color methodsFor: 'access' stamp: 'KenD 1/23/2013 18:18'! - swatch - "Answer a swatch to display in a menu or browser" - ^self iconOrThumbnailOfSize: 16! ! -!Color methodsFor: 'conversions' stamp: 'sw 10/27/1999 10:51'! - asNontranslucentColor - ^ self! ! -!Color methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:20:07'! - bitPatternForDepth: depth - "Return a Bitmap, that best represents this color at the given depth. BitBlt calls this method to convert colors into Bitmaps." - "See also: pixelValueForDepth: -- value for single pixel - pixelWordForDepth: -- a 32-bit word filled with the pixel value" - - ^ Bitmap with: (self pixelWordForDepth: depth)! ! -!Color methodsFor: 'conversions' stamp: 'jmv 6/3/2016 17:28'! - bitPatternForGrayForm - "Return a Bitmap, that best represents this color at the given depth. BitBlt calls this method to convert colors into Bitmaps." - "See also: pixelValueForDepth: -- value for single pixel - pixelWordForDepth: -- a 32-bit word filled with the pixel value" - "Details: The pattern for the most recently requested depth is cached." - - ^Bitmap with: (self pixelWordFor: 8 filledWith: (self luminance * 255) rounded)! ! -!Color methodsFor: 'conversions' stamp: 'jmv 4/19/2013 16:17'! - closestPixelValue1 - "Return the nearest approximation to this color for a monochrome Form." - - "fast special cases" - self isBlack ifTrue: [^ 1]. "black" - self isWhite ifTrue: [^ 0]. "white" - - self luminance > 0.5 - ifTrue: [^ 0] "white" - ifFalse: [^ 1]. "black"! ! -!Color methodsFor: 'conversions' stamp: 'jmv 12/13/2014 16:18'! - closestPixelValue2 - "Return the nearest approximation to this color for a 2-bit deep Form." - - | lum | - "fast special cases" - self isBlack ifTrue: [^ 1]. "black" - self isWhite ifTrue: [^ 2]. "opaque white" - - lum _ self luminance. - lum < 0.2 ifTrue: [^ 1]. "black" - lum > 0.6 ifTrue: [^ 2]. "opaque white" - ^ 3 "50% gray" -! ! -!Color methodsFor: 'conversions' stamp: 'jmv 12/13/2014 16:17'! - closestPixelValue4 - "Return the nearest approximation to this color for a 4-bit deep Form." - - | bIndex | - "fast special cases" - self isBlack ifTrue: [^ 1]. "black" - self isWhite ifTrue: [^ 2]. "opaque white" - - self isRed ifTrue: [^ 4]. - self isGreen ifTrue: [^ 5]. - self isBlue ifTrue: [^ 6]. - self isCyan ifTrue: [^ 7]. - self isYellow ifTrue: [^ 8]. - self isMagenta ifTrue: [^ 9]. - - bIndex _ (self luminance * 8.0) rounded. "bIndex in [0..8]" - ^ #( - 1 "black" - 10 "1/8 gray" - 11 "2/8 gray" - 12 "3/8 gray" - 3 "4/8 gray" - 13 "5/8 gray" - 14 "6/8 gray" - 15 "7/8 gray" - 2 "opaque white" - ) at: bIndex + 1. -! ! -!Color methodsFor: 'conversions' stamp: 'jmv 4/21/2015 09:57'! - closestPixelValue8 - "Return the nearest approximation to this color for an 8-bit deep Form." - - "fast special cases" - self isBlack ifTrue: [^ 1]. "black" - self isWhite ifTrue: [^ 255]. "white" - - ^self saturation < 0.2 - ifTrue: [ - ^ self class grayToIndexMap at:(self green * 255) rounded + 1. "nearest gray" - ] - ifFalse: [ - "compute nearest entry in the color cube" - 40 + - ((self red * 5) rounded * 36) + - ((self blue * 5) rounded * 6) + - (self green * 5) rounded ]! ! -!Color methodsFor: 'conversions' stamp: 'di 9/2/97 20:21'! - dominantColor - ^ self! ! -!Color methodsFor: 'conversions' stamp: 'jmv 6/2/2016 14:48'! - indexInMap: aColorMap - "Return the index corresponding to this color in the given color map. RGB colors are truncated to 3-, 4-, or 5-bits per color component when indexing into such a colorMap. " - - aColorMap size = 2 ifTrue: [^ (self pixelValueForDepth: 1) + 1]. - aColorMap size = 4 ifTrue: [^ (self pixelValueForDepth: 2) + 1]. - aColorMap size = 16 ifTrue: [^ (self pixelValueForDepth: 4) + 1]. - aColorMap size = 256 ifTrue: [^ (self pixelValueForDepth: 8) + 1]. - aColorMap size = 512 ifTrue: [^ (self pixelValueForDepth: 9) + 1]. - aColorMap size = 4096 ifTrue: [^ (self pixelValueForDepth: 12) + 1]. - aColorMap size = 32768 ifTrue: [^ (self pixelValueForDepth: 15) + 1]. - self error: 'unknown pixel depth'. -! ! -!Color methodsFor: 'conversions' stamp: 'bf 4/18/2001 16:25'! - makeForegroundColor - "Make a foreground color contrasting with me" - ^self luminance >= 0.5 - ifTrue: [Color black] - ifFalse: [Color white]! ! -!Color methodsFor: 'conversions' stamp: 'jmv 6/2/2016 14:50'! - pixelValueForDepth: d - "Returns an integer representing the bits that appear in a single pixel of this color in a Form of the given depth. The depth must be one of 1, 2, 4, 8, 16, or 32. Contrast with pixelWordForDepth: and bitPatternForDepth:, which return either a 32-bit word packed with the given pixel value or a multiple-word Bitmap containing a pattern. The inverse is the class message colorFromPixelValue:depth:" - "Details: For depths of 8 or less, the result is a colorMap index. For depths of 16 and 32, it is a direct color value with 5 or 8 bits per color component." - "Transparency: The pixel value zero is reserved for transparent. For depths greater than 8 and less than 32 (no Indexed colors, no real alpha), black maps to the darkest possible blue. - Note that - Color transparent class = TranslucentColor - this special case is handled in TranslucentColor >> #pixelValueForDepth: - " - - | bitBltFakeBlack val | - d = 8 ifTrue: [^ self closestPixelValue8]. "common case" - d < 8 ifTrue: [ - d = 4 ifTrue: [^ self closestPixelValue4]. - d = 2 ifTrue: [^ self closestPixelValue2]. - d = 1 ifTrue: [^ self closestPixelValue1]]. - - d = 32 ifTrue: [ - "eight bits per component; top 8 bits set to all ones (opaque alpha)" - val _ LargePositiveInteger new: 4. - val at: 3 put: (self red * 255) rounded. - val at: 2 put: (self green * 255) rounded. - val at: 1 put: (self blue * 255) rounded. - val at: 4 put: 16rFF. "opaque alpha" - ^ val normalize]. - - "For the depth 16, pixelValue = 0 means transparent, black is represented as 16r8000 (rgb=0, pixelvalue !!= 0)." - (d = 16) | (d = 15) ifTrue: [ - "five bits per component; top bits ignored" - val _ ((self red * 31) rounded bitShift: 10) bitOr: - (((self green * 31) rounded bitShift: 5) bitOr: - ((self blue * 31) rounded)). - ^ val = 0 - ifTrue: [d = 16 ifTrue: [16r8000] ifFalse: [1]] - ifFalse: [val]]. - - "For the rest of the depths, pixelValue = 0 means transparent, and darkest blue is considered to be black." - bitBltFakeBlack := 1. "closest black that is not transparent in RGB - Not for depths <=8 (Indexed) or = 32 (RGBA)" - d = 12 ifTrue: [ "for indexing a color map with 4 bits per color component" - val _ ((self red * 15) rounded bitShift: 8) bitOr: - (((self green * 15) rounded bitShift: 4) bitOr: - ((self blue * 15) rounded)). - ^ val = 0 ifTrue: [bitBltFakeBlack] ifFalse: [val]]. - - d = 9 ifTrue: [ "for indexing a color map with 3 bits per color component" - val _ ((self red * 7) rounded bitShift: 6) bitOr: - (((self green * 7) rounded bitShift: 3) bitOr: - ((self blue * 7) rounded)). - ^ val = 0 ifTrue: [bitBltFakeBlack] ifFalse: [val]]. - - self error: 'unknown pixel depth: ', d printString! ! -!Color methodsFor: 'conversions' stamp: 'di 11/30/1998 09:03'! - pixelWordFor: depth filledWith: pixelValue - "Return to a 32-bit word that concatenates enough copies of the given pixel value to fill the word (i.e., 32/depth copies). Depth should be one of 1, 2, 4, 8, 16, or 32. The pixel value should be an integer in 0..2^depth-1." - | halfword | - depth = 32 ifTrue: [^ pixelValue]. - depth = 16 - ifTrue: [halfword _ pixelValue] - ifFalse: [halfword _ pixelValue * - (#(16rFFFF "replicates at every bit" - 16r5555 - "replicates every 2 bits" - 16r1111 - - - "replicates every 4 bits" - 16r0101) at: depth) "replicates every 8 bits"]. - ^ halfword bitOr: (halfword bitShift: 16)! ! -!Color methodsFor: 'conversions'! - pixelWordForDepth: depth - "Return to a 32-bit word that concatenates enough copies of the receiver's pixel value to fill the word (i.e., 32/depth copies). Depth should be one of 1, 2, 4, 8, 16, or 32. The pixel value should be an integer in 0..2^depth-1." - - | pixelValue | - pixelValue _ self pixelValueForDepth: depth. - ^ self pixelWordFor: depth filledWith: pixelValue -! ! -!Color methodsFor: 'equality' stamp: 'jmv 6/18/2017 20:38:11'! - diff: theOther - "Returns a number between 0.0 and 1.0. - Color gray diff: Color red - " - ^(self - theOther ) abs sum / self size! ! -!Color methodsFor: 'equality' stamp: 'KenD 12/8/2013 08:35'! - rgbDistance: otherColor - "Compare two colors in distance" -" - ^ (self hue - otherColor hue) abs + - (self saturation - otherColor saturation) abs *10 + - (self brightness - otherColor brightness) abs -" - "See http://www.compuphase.com/cmetric.htm" - | meanRed deltaRed deltaGreen deltaBlue | - meanRed := (self red + otherColor red) abs / 2. - deltaRed := (self red - otherColor red) abs. - deltaGreen := (self green - otherColor green) abs. - deltaBlue := (self blue - otherColor blue) abs. - - ^ ( ((2 + (meanRed / 256)) * (deltaRed * deltaRed)) + - (4 * deltaGreen) + - ((2 + ((255 - meanRed) / 256)) * deltaBlue) - ) sqrt! ! -!Color methodsFor: 'groups of shades' stamp: 'tk 6/18/96'! - darkShades: thisMany - "An array of thisMany colors from black to the receiver. Array is of length num. Very useful for displaying color based on a variable in your program. " - "Color showColors: (Color red darkShades: 12)" - - ^ self class black mix: self shades: thisMany -! ! -!Color methodsFor: 'groups of shades' stamp: 'tk 6/18/96'! - lightShades: thisMany - "An array of thisMany colors from white to self. Very useful for displaying color based on a variable in your program. " - "Color showColors: (Color red lightShades: 12)" - - ^ self class white mix: self shades: thisMany -! ! -!Color methodsFor: 'groups of shades' stamp: 'tk 6/18/96'! - mix: color2 shades: thisMany - "Return an array of thisMany colors from self to color2. Very useful for displaying color based on a variable in your program. " - "Color showColors: (Color red mix: Color green shades: 12)" - - | redInc greenInc blueInc rr gg bb c out | - thisMany = 1 ifTrue: [^ Array with: color2]. - redInc _ color2 red - self red / (thisMany-1). - greenInc _ color2 green - self green / (thisMany-1). - blueInc _ color2 blue - self blue / (thisMany-1). - rr _ self red. gg _ self green. bb _ self blue. - out _ (1 to: thisMany) collect: [:num | - c _ Color r: rr g: gg b: bb. - rr _ rr + redInc. - gg _ gg + greenInc. - bb _ bb + blueInc. - c]. - out at: out size put: color2. "hide roundoff errors" - ^ out -! ! -!Color methodsFor: 'groups of shades' stamp: 'di 10/23/2000 09:45'! - wheel: thisMany - "An array of thisMany colors around the color wheel starting at self and ending all the way around the hue space just before self. Array is of length thisMany. Very useful for displaying color based on a variable in your program. " - - | sat bri hue step c | - sat _ self saturation. - bri _ self brightness. - hue _ self hue. - step _ 360.0 / (thisMany max: 1). - ^ (1 to: thisMany) collect: [:num | - c _ Color h: hue s: sat v: bri. "hue is taken mod 360" - hue _ hue + step. - c]. -" -(Color wheel: 8) withIndexDo: [:c :i | Display fill: (i*10@20 extent: 10@20) fillColor: c] -"! ! -!Color methodsFor: 'named colors' stamp: 'KenD 12/8/2013 14:59'! - closestAssocFrom: aColorDict - "Answer closest associated color in aColorDict" -" - ((Color r: 0.3 g: 0.2 b: 0.8) closestAssocFrom: (Color colorNamesDict)) explore. -" - "Filter values for those close in hue (cheap test) then use rgbDistance" - | closeInHue isClose close distance myHue | - closeInHue := OrderedCollection new. - myHue := self hue. - isClose := [ :assoc | | delta | - delta := ((assoc value hue) - myHue) abs. - (delta < 20) or: [ delta > 340 ] "hues within 20 degrees" - ]. - aColorDict associationsDo: [ :assoc | - (isClose value: assoc) ifTrue: [ closeInHue add: assoc ] - ]. - - close := nil. - distance := 1000. "big" - (closeInHue size > 0) - ifFalse: [ "fallback -- no color really close" - aColorDict associationsDo: [ :assoc | | dist | - dist := self rgbDistance: (assoc value). - (dist < distance) ifTrue: [distance := dist. close := assoc] - ] - ] - ifTrue: [ closeInHue do: [ :assoc | | dist | - dist := self rgbDistance: (assoc value). - (dist < distance) ifTrue: [distance := dist. close := assoc] - ] - ]. - - ^ close! ! -!Color methodsFor: 'named colors' stamp: 'KenD 1/26/2013 16:33'! - closestColor - "Answer the closest matching color in the colorNames dictionary" - -" - (Color red lighter lighter) closestColor explore. -" - ^ self closestColorFrom: (Color colorNamesDict)! ! -!Color methodsFor: 'named colors' stamp: 'KenD 1/26/2013 16:36'! - closestColorAssociation - "Answer this color's closest name->color match." - -" - (Color blue lighter lighter) closestColorAssociation explore. -" - ^ self closestAssocFrom: (Color colorNamesDict)! ! -!Color methodsFor: 'named colors' stamp: 'KenD 1/25/2013 14:31'! - closestColorFrom: aColorDict - "Answer closest associated color" -" - ((Color lightBlue) closestColorFrom: (Color css2NamedColors)) explore.. -" - ^(self closestAssocFrom: aColorDict) value! ! -!Color methodsFor: 'named colors' stamp: 'KenD 1/26/2013 16:36'! - closestColorName - "Answer the name symbol of the closest matching color in the colorNames dictionary" -" - (Color red lighter lighter) closestColor name. -" - - ^ self closestNameFrom: (Color colorNamesDict)! ! -!Color methodsFor: 'named colors' stamp: 'KenD 1/26/2013 16:36'! - closestNameFrom: aColorDict - "Answer closest associated color name" -" - ((Color lightBlue) closestNameFrom: (Color namedColors)) print. -" - ^(self closestAssocFrom: aColorDict) key! ! -!Color methodsFor: 'other' stamp: 'KenD 7/18/2015 20:41'! - colorName - "Return this color's name, or nil if it has no name. Only returns a name if it exactly matches the named color." - - ^(Color colorNamesDict keyAtValue: self ifAbsent: [nil]) -! ! -!Color methodsFor: 'other' stamp: 'KenD 7/18/2015 20:46'! - name - "Return this color's name, or description if unnamed." - - ^ self printString -! ! -!Color methodsFor: 'printing' stamp: 'jmv 2/13/2014 13:41'! - hexStringRGB - " - Color fromUser hexStringRGB - " - ^String streamContents: [ :strm | - (self red * 255) rounded printOn: strm base: 16 length: 2 padded: true. - (self green * 255) rounded printOn: strm base: 16 length: 2 padded: true. - (self blue * 255) rounded printOn: strm base: 16 length: 2 padded: true ]! ! -!Color methodsFor: 'printing' stamp: 'KenD 7/18/2015 20:42'! - printOn: aStream - self colorName ifNotNil: [ :name | - ^ aStream - nextPutAll: 'Color '; - nextPutAll: name]. - self storeOn: aStream. -! ! -!Color methodsFor: 'printing' stamp: 'KenD 7/18/2015 20:44'! - printString - "Answer a String whose characters are a description of the receiver." - - ^ String streamContents: [ :stream | self printOn: stream ]! ! -!Color methodsFor: 'printing' stamp: 'mir 7/21/1999 11:41'! - storeArrayOn: aStream - - aStream nextPutAll: '#('. - self storeArrayValuesOn: aStream. - aStream nextPutAll: ') ' -! ! -!Color methodsFor: 'printing' stamp: 'jmv 1/5/2014 21:04'! - storeArrayValuesOn: aStream - - - self red printOn: aStream fractionDigits: 3. - aStream space. - self green printOn: aStream fractionDigits: 3. - aStream space. - self blue printOn: aStream fractionDigits: 3 - -! ! -!Color methodsFor: 'printing' stamp: 'jmv 1/5/2014 21:01'! - storeOn: aStream - - aStream - nextPut: $(; - nextPutAll: self class name; - nextPutAll: ' r: '. - self red printOn: aStream fractionDigits: 3. - aStream nextPutAll: ' g: '. - self green printOn: aStream fractionDigits: 3. - aStream nextPutAll: ' b: '. - self blue printOn: aStream fractionDigits: 3. - aStream nextPut: $)! ! -!Color methodsFor: 'queries' stamp: 'jmv 6/18/2017 20:40:55'! - isBlack - "Return true if the receiver represents black" - (self at: 1) = 0.0 ifFalse: [ ^ false ]. - (self at: 2) = 0.0 ifFalse: [ ^ false ]. - (self at: 3) = 0.0 ifFalse: [ ^ false ]. - ^ true! ! -!Color methodsFor: 'queries' stamp: 'ar 4/20/2001 04:33'! - isOpaque - ^true! ! -!Color methodsFor: 'queries'! - isTransparent - - ^ false -! ! -!Color methodsFor: 'queries' stamp: 'jmv 6/18/2017 20:40:46'! - isWhite - "Return true if the receiver represents white" - (self at: 1) = 1.0 ifFalse: [ ^ false ]. - (self at: 2) = 1.0 ifFalse: [ ^ false ]. - (self at: 3) = 1.0 ifFalse: [ ^ false ]. - ^ true! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:35'! - isBlue - "Am I considered Blue?" - - ^self blue > (self green + 0.3) - and: [self blue > (self red + 0.3)] - and: [(self green - self red) abs < 0.4]! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:37'! - isBlueGreen - "Am I considered BlueGreen ?" - - ^self green > self red - and: [self red < 0.3] - and: [(self green - self blue) abs < 0.1]! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:50'! - isBright - "Am I considered a Bright color ?" - - ^self brightness > 0.6! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:40'! - isBrown - "Am I considered Brown ?" - - ^self red >= self green - and: [self green > self blue] - and: [(self red - self green) < 0.5] - and: [(self green - self blue) < 0.3]! ! -!Color methodsFor: 'selection' stamp: 'jmv 4/19/2013 17:14'! - isCyan - "Am I considered Cyan ?" - - ^self red < 0.05 - and: [(self green min: self blue) > 0.5] - and: [(self green - self blue) abs < 0.2]! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:50'! - isDark - "Am I considered a Dark color ?" - - ^self brightness < 0.5! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:42'! - isGray - "Am I considered Gray ?" - - ^(self red closeTo: self green) - and: [self blue closeTo: self green ]! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:38'! - isGreen - "Am I considered Green ?" - - ^self green > (self blue + 0.3) - and: [self blue > (self red + 0.3)]! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:40'! - isGrey - "Am I considered Grey ?" - - ^self isGray! ! -!Color methodsFor: 'selection' stamp: 'jmv 4/19/2013 17:06'! - isLight - "Am I considered a Light color ?" - - ^self brightness > 0.6! ! -!Color methodsFor: 'selection' stamp: 'jmv 4/19/2013 17:13'! - isMagenta - "Am I considered Magenta ?" - - ^self green < 0.05 - and: [(self red min: self blue) > 0.5] - and: [(self red - self blue) abs < 0.2]! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:44'! - isOrange - "Am I considered Orange ?" - - ^self red > ((self green max: self blue) + 0.2) - and: [self green > (self blue + 0.2)]! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:45'! - isPastel - "Am I considered Pastel ?" - - ^self saturation < 0.4! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:46'! - isPink - "Am I considered Pink ?" - - ^self red > ((self green max: self blue) + 0.3) - and: [self blue > (self green + 0.2)]! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:47'! - isRed - "Am I considered Red ?" - - ^self red > (self green + 0.4) - and: [self red > (self blue + 0.6)] - and: [(self green - self blue) abs < 0.4]! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:55'! - isSaturated - "Am I considered to be a Saturated color ?" - - ^self saturation > 0.6! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:49'! - isYellow - "Am I considered Yellow ?" - - ^self blue < 0.05 - and: [(self red min: self green) > 0.5] - and: [(self red - self green) abs < 0.2]! ! -!Color methodsFor: 'testing' stamp: 'jmv 12/2/2010 08:38'! - is: aSymbol - ^ aSymbol == #Color or: [ super is: aSymbol ]! ! -!Color methodsFor: 'testing' stamp: 'jmv 2/10/2011 21:46'! - mightBeTranslucent - "For Colors, answer if actually translucent or not." - ^self isOpaque not! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:56:14'! - * aNumber - "Answer this color with its RGB multiplied by the given number. " - " - (Color brown *2) display - " - ^ (Color new - setRed: (self red * aNumber min: 1.0 max: 0.0) - green: (self green * aNumber min: 1.0 max: 0.0) - blue: (self blue * aNumber min: 1.0 max: 0.0)) - alpha: self alpha! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:56:18'! - + aColor - "Answer this color mixed with the given color in an additive color space. " - " - (Color blue + Color green) display - " - ^ Color new - setRed: (self red + aColor red min: 1.0 max: 0.0) - green: (self green + aColor green min: 1.0 max: 0.0) - blue: (self blue + aColor blue min: 1.0 max: 0.0)! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:56:22'! - - aColor - "Answer aColor is subtracted from the given color in an additive color space. " - " - (Color white - Color red) display - " - ^ Color new - setRed: (self red - aColor red min: 1.0 max: 0.0) - green: (self green - aColor green min: 1.0 max: 0.0) - blue: (self blue - aColor blue min: 1.0 max: 0.0)! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:56:26'! - / aNumber - "Answer this color with its RGB divided by the given number. " - " - (Color red / 2) display - " - ^ Color new - setRed: (self red / aNumber min: 1.0 max: 0.0) - green: (self green / aNumber min: 1.0 max: 0.0) - blue: (self blue / aNumber min: 1.0 max: 0.0)! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:50'! - adjustBrightness: brightness - "Adjust the relative brightness of this color. (lowest value is 0.005 so that hue information is not lost)" - - ^ Color - h: self hue - s: self saturation - v: (self brightness + brightness min: 1.0 max: 0.005) - alpha: self alpha! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:51'! - adjustSaturation: saturation brightness: brightness - "Adjust the relative saturation and brightness of this color. (lowest value is 0.005 so that hue information is not lost)" - - ^ Color - h: self hue - s: (self saturation + saturation min: 1.0 max: 0.005) - v: (self brightness + brightness min: 1.0 max: 0.005) - alpha: self alpha! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:10:41'! - alpha: alphaValue - "Return a new TranslucentColor with the given amount of opacity ('alpha')." - alphaValue = 1.0 ifFalse: [ - ^ TranslucentColor new - setRed: self red - green: self green - blue: self blue - alpha: alphaValue ]! ! -!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 11:55'! - alphaMixed: proportion with: aColor - "Answer this color mixed with the given color. The proportion, a number - between 0.0 and 1.0, determines what what fraction of the receiver to - use in the mix. For example, 0.9 would yield a color close to the - receiver. This method uses RGB interpolation; HSV interpolation can lead - to surprises. Mixes the alphas (for transparency) also." - - | frac1 frac2 | - frac1 _ proportion asFloat min: 1.0 max: 0.0. - frac2 _ 1.0 - frac1. - ^ Color - r: self red * frac1 + (aColor red * frac2) - g: self green * frac1 + (aColor green * frac2) - b: self blue * frac1 + (aColor blue * frac2) - alpha: self alpha * frac1 + (aColor alpha * frac2)! ! -!Color methodsFor: 'transformations' stamp: 'RAA 6/2/2000 08:47'! - atLeastAsLuminentAs: aFloat - - | revisedColor | - revisedColor _ self. - [revisedColor luminance < aFloat] whileTrue: [revisedColor _ revisedColor slightlyLighter]. - ^revisedColor -! ! -!Color methodsFor: 'transformations' stamp: 'nk 3/8/2004 09:43'! - atMostAsLuminentAs: aFloat - - | revisedColor | - revisedColor _ self. - [revisedColor luminance > aFloat] whileTrue: [revisedColor _ revisedColor slightlyDarker]. - ^revisedColor -! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/23/2002 01:38'! - blacker - - ^ self alphaMixed: 0.8333 with: Color black -! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:54'! - dansDarker - "Return a darker shade of the same color. - An attempt to do better than the current darker method. - (now obsolete, since darker has been changed to do this. -dew)" - ^ Color h: self hue s: self saturation - v: (self brightness - 0.16 max: 0.0)! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:40'! - darker - "Answer a darker shade of this color." - - ^ self adjustBrightness: -0.08! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/8/2002 00:13'! - duller - - ^ self adjustSaturation: -0.03 brightness: -0.2! ! -!Color methodsFor: 'transformations' stamp: 'dew 1/23/2002 20:19'! - lighter - "Answer a lighter shade of this color." - - ^ self adjustSaturation: -0.03 brightness: 0.08! ! -!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 12:00'! - mixed: proportion with: aColor - "Mix with another color and do not preserve transpareny. Only use this for extracting the RGB value and mixing it. All other callers should use instead: - aColor alphaMixed: proportion with: anotherColor - " - - | frac1 frac2 | - frac1 _ proportion asFloat min: 1.0 max: 0.0. - frac2 _ 1.0 - frac1. - ^ Color - r: self red * frac1 + (aColor red * frac2) - g: self green * frac1 + (aColor green * frac2) - b: self blue * frac1 + (aColor blue * frac2)! ! -!Color methodsFor: 'transformations' stamp: 'dew 1/19/2002 01:29'! - muchDarker - - ^ self alphaMixed: 0.5 with: Color black -! ! -!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 12:07'! - muchLighter - - ^ self alphaMixed: 0.233 with: Color white -! ! -!Color methodsFor: 'transformations' stamp: 'ar 6/19/1999 00:36'! - negated - "Return an RGB inverted color" - ^Color - r: 1.0 - self red - g: 1.0 - self green - b: 1.0 - self blue! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:37:53'! - orColorUnlike: theOther - "If this color is a lot like theOther, then return its complement, otherwide, return self" - - ^ (self diff: theOther) < 0.3 - ifTrue: [theOther negated] - ifFalse: [self]! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:42'! - paler - "Answer a paler shade of this color." - - ^ self adjustSaturation: -0.09 brightness: 0.09 -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 9/10/2009 18:41'! - quiteBlacker - - ^ self alphaMixed: 0.8 with: Color black -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 9/10/2009 18:44'! - quiteWhiter - - ^ self alphaMixed: 0.6 with: Color white! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:43'! - slightlyDarker - - ^ self adjustBrightness: -0.03 -! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:43'! - slightlyLighter - - ^ self adjustSaturation: -0.01 brightness: 0.03! ! -!Color methodsFor: 'transformations' stamp: 'dew 1/19/2002 01:25'! - slightlyWhiter - - ^ self alphaMixed: 0.85 with: Color white -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 5/7/2012 15:05'! - twiceDarker - "Answer a significantly darker shade of this color." - - ^ self adjustSaturation: 0.076 brightness: -0.15! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:45'! - twiceLighter - "Answer a significantly lighter shade of this color." - - ^ self adjustSaturation: -0.06 brightness: 0.15! ! -!Color methodsFor: 'transformations' stamp: 'jmv 8/23/2009 23:24'! - veryMuchDarker - - ^ self alphaMixed: 0.25 with: Color black -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 7/28/2016 15:43:04'! - veryMuchLighter - - ^ self alphaMixed: 0.07 with: Color white! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/23/2002 01:38'! - whiter - - ^ self alphaMixed: 0.8333 with: Color white -! ! -!Color methodsFor: 'private'! - attemptToMutateError - "A color is immutable. Once a color's red, green, and blue have been initialized, you cannot change them. Instead, create a new Color and use it." - - self error: 'Color objects are immutable once created' -! ! -!Color methodsFor: 'private' stamp: 'jmv 6/18/2017 20:29:32'! - basicSetRed: r green: g blue: b - "Initialize this color's r, g, and b components to the given values in the range [0.0..1.0]." - - self - at: 1 put: r; - at: 2 put: g; - at: 3 put: b! ! -!Color methodsFor: 'private' stamp: 'jmv 6/18/2017 20:15:44'! - setHue: hue chroma: chroma brightness: brightness - "Initialize this color to the given hue, chroma, and luma. See the comment in the instance creation method for details. - http://en.wikipedia.org/wiki/HSL_and_HSV - hue belongs in [0.0, 360.0) - chroma and luma belongs in [0.0, 1.0] - " - - | x hf i r1 g1 b1 m | - hf _ hue \\ 360. - i _ hf // 60. "integer part of hue" - x _ (hf \\ 60) / 60.0 . "fractional part of hue" - x _ x \\ 2 . - i \\ 2 = 1 ifTrue: [ x _ 1.0 - x ]. - x _ chroma * x. - - 0 = i ifTrue: [ r1 _ chroma. g1 _ x. b1 _ 0.0 ]. - 1 = i ifTrue: [ r1 _ x. g1 _ chroma. b1 _ 0.0 ]. - 2 = i ifTrue: [ r1 _ 0.0. g1 _ chroma. b1 _ x ]. - 3 = i ifTrue: [ r1 _ 0.0. g1 _ x. b1 _ chroma ]. - 4 = i ifTrue: [ r1 _ x. g1 _ 0.0. b1 _ chroma ]. - 5 = i ifTrue: [ r1 _ chroma. g1 _ 0.0. b1 _ x ]. - - m _ brightness - ((r1 max: g1) max: b1). - m < 0.0 - ifTrue: [ ^nil ]. "No color exists with required parameters" - r1 _ r1 + m. - r1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - g1 _ g1 + m. - g1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - b1 _ b1 + m. - b1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - self setRed: r1 green: g1 blue: b1! ! -!Color methodsFor: 'private' stamp: 'jmv 6/18/2017 20:15:49'! - setHue: hue chroma: chroma luminance: luma - "Initialize this color to the given hue, chroma, and luma. See the comment in the instance creation method for details. - http://en.wikipedia.org/wiki/HSL_and_HSV - hue belongs in [0.0, 360.0) - chroma and luma belongs in [0.0, 1.0] - " - - | x hf i r1 g1 b1 m | - - hf _ hue \\ 360. - i _ hf // 60. "integer part of hue" - x _ (hf \\ 60) / 60.0 . "fractional part of hue" - x _ x \\ 2 . - i \\ 2 = 1 ifTrue: [ x _ 1.0 - x ]. - x _ chroma * x. - - 0 = i ifTrue: [ r1 _ chroma. g1 _ x. b1 _ 0.0 ]. - 1 = i ifTrue: [ r1 _ x. g1 _ chroma. b1 _ 0.0 ]. - 2 = i ifTrue: [ r1 _ 0.0. g1 _ chroma. b1 _ x ]. - 3 = i ifTrue: [ r1 _ 0.0. g1 _ x. b1 _ chroma ]. - 4 = i ifTrue: [ r1 _ x. g1 _ 0.0. b1 _ chroma ]. - 5 = i ifTrue: [ r1 _ chroma. g1 _ 0.0. b1 _ x ]. - - m _ luma - (0.299*r1) - (0.587*g1) - (0.114*b1). - m < 0.0 - ifTrue: [ ^nil ]. "No color exists with required parameters" - r1 _ r1 + m. - r1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - g1 _ g1 + m. - g1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - b1 _ b1 + m. - b1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - self setRed: r1 green: g1 blue: b1! ! -!Color methodsFor: 'private' stamp: 'jmv 6/18/2017 20:16:07'! - setHue: hue saturation: saturation brightness: brightness - "Initialize this color to the given hue, saturation, and brightness. See the comment in the instance creation method for details." - - | s v hf i f p q t | - s _ saturation asFloat min: 1.0 max: 0.0. - v _ brightness asFloat min: 1.0 max: 0.0. - hf _ hue \\ 360. - i _ hf // 60. "integer part of hue" - f _ (hf \\ 60) / 60.0. "fractional part of hue" - - p _ (1.0 - s) * v. - q _ (1.0 - (s * f)) * v. - t _ (1.0 - (s * (1.0 - f))) * v. - - 0 = i ifTrue: [ ^ self setRed: v green: t blue: p ]. - 1 = i ifTrue: [ ^ self setRed: q green: v blue: p ]. - 2 = i ifTrue: [ ^ self setRed: p green: v blue: t ]. - 3 = i ifTrue: [ ^ self setRed: p green: q blue: v ]. - 4 = i ifTrue: [ ^ self setRed: t green: p blue: v ]. - 5 = i ifTrue: [ ^ self setRed: v green: p blue: q ]. - - self error: 'implementation error'! ! -!Color methodsFor: 'private' stamp: 'jmv 6/18/2017 20:13:04'! - setRed: r green: g blue: b - - self basicSetRed: r green: g blue: b! ! -!Color methodsFor: 'private' stamp: 'jmv 6/18/2017 20:29:48'! - setRed: r green: g blue: b range: range - "Initialize this color's r, g, and b components to the given values in the range [0..r]." - - self basicSetRed: r green: g blue: b. - self /= range! ! -!Color methodsFor: 'as yet unclassified' stamp: 'jmv 8/15/2015 18:23'! - color - ^ self! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 9/17/2015 15:22'! - clipR: r g: g b: b - "Return a color with the given r, g, and b components in the range [0.0..1.0]. - Clip if necessary" - - ^ self - r: (r min: 1.0 max: 0.0) - g: (g min: 1.0 max: 0.0) - b: (b min: 1.0 max: 0.0)! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 4/2/2016 23:05'! - colorFrom: parm - "Return an instantiated color from parm. If parm is already a color, return it, else return the result of my performing it if it's a symbol or, if it is a list, it can either be an array of three numbers, which will be interpreted as RGB values, or a list of symbols, the first of which is sent to me and then the others of which are in turn sent to the prior result, thus allowing entries of the form #(blue darker). Else just return the thing" - - | aColor firstParm | - (parm is: #Color) ifTrue: [ ^ parm ]. - parm isSymbol ifTrue: [ ^ self perform: parm ]. - (parm isSequenceableCollection and: [ parm size > 0 ]) - ifTrue: [ - firstParm _ parm first. - firstParm isNumber ifTrue: [ - ^ self fromRgbTriplet: parm]. - aColor _ self colorFrom: firstParm. - parm withIndexDo: [ :sym :ind | - ind > 1 ifTrue: [ - aColor _ aColor perform: sym ]]. - ^ aColor]. - ^ parm - -" -Color colorFrom: #(blue darker) -Color colorFrom: Color blue darker -Color colorFrom: #blue -Color colorFrom: #(0.0 0.0 1.0) -"! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/2/2016 15:04'! - colorFromPixelValue: p depth: d - "Convert a pixel value for the given display depth into a color." - "Details: For depths of 8 or less, the pixel value is simply looked up in a table. For greater depths, the color components are extracted and converted into a color." - "Warning: In BitBlt, a pixel with pixelValue = 0 is transparent. - Squeak usually assumes that r=g=b=0 => transparent. But this is false if we have alpha (opacity). - A color with r=g=b=0 and opacity = 255 is BLACK, not TRANSPARENT. - Squeak also answers darkest possible blue when asked for black. Again, this is not needed in 32 bits (with alpha). It is also not really needed for 16 bits as we have an extra, unused bit: 16r8000 is not zero, but rgb=0, and hence, black. - The real rule is that pixelValue=0 means transparent. - And that darkest blue must be used instead of black, but only for depths >8 and < 16 (no indexed colors, no alpha) - This method is updated to reflect that." - - | r g b alpha | - - d = 1 ifTrue: [^ self indexedColors at: (p bitAnd: 16r01) + 1]. - - "For the rest of the depths, pixelValue = 0 means transparent, and darkest blue is considered to be black." - p = 0 ifTrue: [ ^Color transparent ]. - - d = 8 ifTrue: [^ self indexedColors at: (p bitAnd: 16rFF) + 1]. - d = 4 ifTrue: [^ self indexedColors at: (p bitAnd: 16r0F) + 1]. - d = 2 ifTrue: [^ self indexedColors at: (p bitAnd: 16r03) + 1]. - - d = 32 ifTrue: [ - "eight bits per component; 8 bits of alpha" - alpha _ p bitShift: -24. - alpha = 0 ifTrue: [ ^Color transparent ]. - r _ (p bitShift: -16) bitAnd: 16rFF. - g _ (p bitShift: -8) bitAnd: 16rFF. - b _ p bitAnd: 16rFF. - ^alpha < 255 - ifTrue: [ (Color r: r g: g b: b range: 255) alpha: alpha asFloat / 255.0 ] - ifFalse: [ Color r: r g: g b: b range: 255 ]]. - - d = 16 ifTrue: [ - "five bits per component. The most significant bit, unused, allows having real black, without p being zero" - r _ (p bitShift: -10) bitAnd: 16r1F. - g _ (p bitShift: -5) bitAnd: 16r1F. - b _ p bitAnd: 16r1F. - ^ Color r: r g: g b: b range: 31]. - - d = 15 ifTrue: [ - "five bits per component" - r _ (p bitShift: -10) bitAnd: 16r1F. - g _ (p bitShift: -5) bitAnd: 16r1F. - b _ p bitAnd: 16r1F. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Color black ]. - ^ Color r: r g: g b: b range: 31]. - - d = 12 ifTrue: [ - "four bits per component" - r _ (p bitShift: -8) bitAnd: 16rF. - g _ (p bitShift: -4) bitAnd: 16rF. - b _ p bitAnd: 16rF. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Color black ]. - ^ Color r: r g: g b: b range: 15]. - - d = 9 ifTrue: [ - "three bits per component" - r _ (p bitShift: -6) bitAnd: 16r7. - g _ (p bitShift: -3) bitAnd: 16r7. - b _ p bitAnd: 16r7. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Color black ]. - ^ Color r: r g: g b: b range: 7]. - - self error: 'unknown pixel depth: ', d printString! ! -!Color class methodsFor: 'instance creation' stamp: 'sqr 10/15/2016 20:41:04'! - fromArray: colorDef - - | answer | - colorDef size = 0 ifTrue: [^self transparent]. - colorDef size between: 3 and: 4 :: ifFalse: [self error: 'Undefined color definition']. - answer _ self r: (colorDef at: 1) g: (colorDef at: 2) b: (colorDef at: 3). - ^colorDef size = 3 - ifTrue: [answer] - ifFalse: [answer alpha: (colorDef at: 4)]! ! -!Color class methodsFor: 'instance creation' stamp: 'sw 8/8/97 22:03'! - fromRgbTriplet: list - ^ self r: list first g: list second b: list last! ! -!Color class methodsFor: 'instance creation' stamp: 'pb 10/16/2016 18:42:44'! - fromString: aString - "For HTML color spec: #FFCCAA. Also support named colors. - See http://www.w3schools.com/cssref/css_colors_legal.asp" - " - Color fromString: '#FFCCAA'. - Color fromString: 'white'. - Color fromString: 'orange' - Color fromString: 'rgb(255,0,98)' - " - (aString size = 7 and: [ aString first = $# ]) ifTrue: [ - | aColorHexU red green blue | - aColorHexU _ aString asUppercase. - red _ ('16r', (aColorHexU copyFrom: 2 to: 3)) asNumber/255. - green _ ('16r', (aColorHexU copyFrom: 4 to: 5)) asNumber/255. - blue _ ('16r', (aColorHexU copyFrom: 6 to: 7)) asNumber/255. - ^ self r: red g: green b: blue]. - - (aString beginsWith: 'rgb') - ifTrue: [|values r g b| - values := (aString allButFirst: 4) allButLast findTokens: ','. - r := (values first includes: $%) - ifTrue: [(values first asNumber min: 100 max: 0) / 100.0] - ifFalse: [(values first asInteger min: 255 max: 0) / 255.0]. - g := (values second includes: $%) - ifTrue: [(values second asNumber min: 100 max: 0) / 100.0] - ifFalse: [(values second asInteger min: 255 max: 0) / 255.0]. - b := (values third includes: $%) - ifTrue: [(values third asNumber min: 100 max: 0) / 100.0] - ifFalse: [(values third asInteger min: 255 max: 0) / 255.0]. - ^self r: r g: g b: b]. - - ^self exactColorNamed: aString! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:29'! - gray: brightness - "Return a gray shade with the given brightness in the range [0.0..1.0]." - - ^ self new - setRed: brightness - green: brightness - blue: brightness! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:31'! - h: hue s: saturation v: brightness - "Create a color with the given hue, saturation, and brightness. Hue is given as the angle in degrees of the color on the color circle where red is zero degrees. Saturation and brightness are numbers in [0.0..1.0] where larger values are more saturated or brighter colors. For example, (Color h: 0 s: 1 v: 1) is pure red." - "Note: By convention, brightness is abbreviated 'v' to to avoid confusion with blue." - - ^ self new setHue: hue saturation: saturation brightness: brightness! ! -!Color class methodsFor: 'instance creation' stamp: 'dew 3/19/2002 23:49'! - h: h s: s v: v alpha: alpha - - ^ (self h: h s: s v: v) alpha: alpha! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:34'! - hue: hue chroma: chroma brightness: brightness - ^self new setHue: hue chroma: chroma brightness: brightness! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:37'! - hue: hue chroma: chroma luminance: luma - ^self new setHue: hue chroma: chroma luminance: luma! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:39'! - hue: hue saturation: saturation brightness: brightness - "Create a color with the given hue, saturation, and brightness. Hue is given as the angle in degrees of the color on the color circle where red is zero degrees. Saturation and brightness are numbers in [0.0..1.0] where larger values are more saturated or brighter colors. For example, (Color h: 0 s: 1 v: 1) is pure red." - "Note: By convention, brightness is abbreviated 'v' to to avoid confusion with blue." - - ^ self new setHue: hue saturation: saturation brightness: brightness! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:54:20'! - new - ^ self new: 3! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:41'! - r: r g: g b: b - "Return a color with the given r, g, and b components in the range [0.0..1.0]." - - ^ self new - setRed: r - green: g - blue: b! ! -!Color class methodsFor: 'instance creation'! - r: r g: g b: b alpha: alpha - - ^ (self r: r g: g b: b) alpha: alpha! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:43'! - r: r g: g b: b range: range - "Return a color with the given r, g, and b components specified as integers in the range [0..r]. This avoids the floating point arithmetic in the red:green:blue: message and is thus a bit faster for certain applications (such as computing a sequence of colors for a palette)." - - ^ self new setRed: r green: g blue: b range: range! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 4/4/2015 20:30'! - random - "Return a random color that isn't too dark or under-saturated. - Display fill: (10@10 extent: 200@200) fillColor: Color random - " - - ^ Random withDefaultDo: [ :random | - self random: random ]! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 4/4/2015 20:30'! - random2 - "Return a random color with a distribution that spans over all possible colors. - Display fill: (10@10 extent: 200@200) fillColor: Color random2 - " - - ^ Random withDefaultDo: [ :random | - self random2: random ]! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:46'! - random2: aRandom - "Return a random color with a distribution that spans over all possible colors." - - ^ self new - setRed: aRandom next - green: aRandom next - blue: aRandom next! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:48'! - random: aRandom - "Return a random color that isn't too dark or under-saturated." - - ^ self new - setHue: (360.0 * aRandom next) - saturation: (0.3 + (aRandom next * 0.7)) - brightness: (0.4 + (aRandom next * 0.6))! ! -!Color class methodsFor: 'class initialization' stamp: 'jmv 4/17/2015 15:06'! - initializeGrayToIndexMap - "Build an array of gray values available in the 8-bit colormap. This array is indexed by a gray level between black (1) and white (256) and returns the pixel value for the corresponding gray level." - "Note: This method must be called after initializeIndexedColors, since it uses IndexedColors." - " - Color initializeGrayToIndexMap - " - - | grayLevels grayIndices c distToClosest dist indexOfClosest indexedColors | - "record the level and index of each gray in the 8-bit color table" - grayLevels _ OrderedCollection new. - grayIndices _ OrderedCollection new. - indexedColors _ self indexedColors. - "Note: skip the first entry, which is reserved for transparent" - 2 to: indexedColors size do: [:i | - c _ indexedColors at: i. - c saturation = 0.0 ifTrue: [ "c is a gray" - grayLevels add: (c green * 255) rounded. "0 to 255; R, G, and B are the same" - grayIndices add: i - 1]]. "pixel values are zero-based" - grayLevels _ grayLevels asArray. - grayIndices _ grayIndices asArray. - - "for each gray level in [0..255], select the closest match" - GrayToIndexMap _ ByteArray new: 256. - 0 to: 255 do: [ :level | - distToClosest _ 10000. "greater than distance to any real gray" - 1 to: grayLevels size do: [:i | - dist _ (level - (grayLevels at: i)) abs. - dist < distToClosest ifTrue: [ - distToClosest _ dist. - indexOfClosest _ grayIndices at: i]]. - GrayToIndexMap at: (level + 1) put: indexOfClosest]! ! -!Color class methodsFor: 'class initialization'! - initializeIndexedColors - "Build an array of colors corresponding to the fixed colormap used - for display depths of 1, 2, 4, or 8 bits." - "Color initializeIndexedColors" - - | a index grayVal | - a _ Array new: 256. - - "1-bit colors (monochrome)" - a at: 1 put: (Color r: 1.0 g: 1.0 b: 1.0). "white or transparent" - a at: 2 put: (Color r: 0.0 g: 0.0 b: 0.0). "black" - - "additional colors for 2-bit color" - a at: 3 put: (Color r: 1.0 g: 1.0 b: 1.0). "opaque white" - a at: 4 put: (Color r: 0.5 g: 0.5 b: 0.5). "1/2 gray" - - "additional colors for 4-bit color" - a at: 5 put: (Color r: 1.0 g: 0.0 b: 0.0). "red" - a at: 6 put: (Color r: 0.0 g: 1.0 b: 0.0). "green" - a at: 7 put: (Color r: 0.0 g: 0.0 b: 1.0). "blue" - a at: 8 put: (Color r: 0.0 g: 1.0 b: 1.0). "cyan" - a at: 9 put: (Color r: 1.0 g: 1.0 b: 0.0). "yellow" - a at: 10 put: (Color r: 1.0 g: 0.0 b: 1.0). "magenta" - - a at: 11 put: (Color r: 0.125 g: 0.125 b: 0.125). "1/8 gray" - a at: 12 put: (Color r: 0.25 g: 0.25 b: 0.25). "2/8 gray" - a at: 13 put: (Color r: 0.375 g: 0.375 b: 0.375). "3/8 gray" - a at: 14 put: (Color r: 0.625 g: 0.625 b: 0.625). "5/8 gray" - a at: 15 put: (Color r: 0.75 g: 0.75 b: 0.75). "6/8 gray" - a at: 16 put: (Color r: 0.875 g: 0.875 b: 0.875). "7/8 gray" - - "additional colors for 8-bit color" - "24 more shades of gray (1/32 increments but not repeating 1/8 increments)" - index _ 17. - 1 to: 31 do: [:v | - (v \\ 4) = 0 ifFalse: [ - grayVal _ v / 32.0. - a at: index put: (Color r: grayVal g: grayVal b: grayVal). - index _ index + 1]]. - - "The remainder of color table defines a color cube with six steps - for each primary color. Note that the corners of this cube repeat - previous colors, but this simplifies the mapping between RGB colors - and color map indices. This color cube spans indices 40 through 255 - (indices 41-256 in this 1-based array)." - 0 to: 5 do: [:r | - 0 to: 5 do: [:g | - 0 to: 5 do: [:b | - index _ 41 + ((36 * r) + (6 * b) + g). - index > 256 ifTrue: [ - self error: 'index out of range in color table compuation']. - a at: index put: (Color r: r g: g b: b range: 5)]]]. - - IndexedColors _ a. -! ! -!Color class methodsFor: 'examples' stamp: 'jmv 8/17/2012 18:48'! - colorRampForDepth: depth extent: aPoint - "Returns a form of the given size showing R, G, B, and gray ramps for the given depth. Useful for testing color conversions between different depths." - "(Color colorRampForDepth: Display depth extent: 256@80) display" - "(Color colorRampForDepth: 32 extent: 256@80) displayOn: Display at: 0@0 rule: Form paint" - - | f dx dy r | - f _ Form extent: aPoint depth: depth. - dx _ aPoint x // 256. - dy _ aPoint y // 4. - 0 to: 255 do: [:i | - r _ (dx * i)@0 extent: dx@dy. - f fill: r fillColor: (Color r: i g: 0 b: 0 range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Color r: 0 g: i b: 0 range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Color r: 0 g: 0 b: i range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Color r: i g: i b: i range: 255)]. - ^ f -! ! -!Color class methodsFor: 'examples' stamp: 'jmv 6/18/2017 21:29:30'! - experimentsTowarsANewColorPalette -" -self experimentsTowarsANewColorPalette -" -| selectedHue selectedSaturation selectedV selectedColor h s v color width height selectedChroma selectedLuminance | -width _ 300. -height _ 120. -selectedColor _ Color random. -selectedHue _ selectedColor hue. -selectedSaturation _ selectedColor saturation. -selectedChroma _ selectedColor chroma. -selectedV _ selectedColor brightness. -selectedLuminance _ selectedColor luminance. -Display getCanvas fillRectangle: (0@0 extent: height@height) color: selectedColor. -0 to: height do: [ :y | - v _ 1.0 - (y / height). - 0 to: height do: [ :x | - s _ x / height. - color _ Color new setHue: selectedHue saturation: s brightness: v. - Display colorAt: x@(y+height) put: color - ]. - DisplayScreen screenUpdateRequired: nil -]. -0 to: height do: [ :y | | c | - v _ 1.0 - (y / height). - s _ 1.0 - (y / height). - c _ s. - 0 to: width do: [ :x | - h _ x / width * 360. - - color _ Color new setHue: h chroma: c luminance: selectedLuminance. -" color _ Color new setHue: h chroma: c brightness: selectedV." - color ifNil: [ color _ Color black ]. -" color _ Color new setHue: h saturation: s brightness: selectedV." - Display colorAt: x+height@y put: color. - - color _ Color new setHue: h chroma: selectedChroma luminance: v. -" color _ Color new setHue: h chroma: selectedChroma brightness: v." - color ifNil: [ color _ Color black ]. -" color _ Color new setHue: h saturation: selectedSaturation brightness: v." - Display colorAt: x+height@(y+height) put: color. - - ]. - DisplayScreen screenUpdateRequired: nil -].! ! -!Color class methodsFor: 'examples' stamp: 'tk 6/19/96'! -hotColdShades: thisMany - "An array of thisMany colors showing temperature from blue to red to white hot. (Later improve this by swinging in hue.) " - "Color showColors: (Color hotColdShades: 25)" - - | n s1 s2 s3 s4 s5 | - thisMany < 5 ifTrue: [^ self error: 'must be at least 5 shades']. - n _ thisMany // 5. - s1 _ self white mix: self yellow shades: (thisMany - (n*4)). - s2 _ self yellow mix: self red shades: n+1. - s2 _ s2 copyFrom: 2 to: n+1. - s3 _ self red mix: self green darker shades: n+1. - s3 _ s3 copyFrom: 2 to: n+1. - s4 _ self green darker mix: self blue shades: n+1. - s4 _ s4 copyFrom: 2 to: n+1. - s5 _ self blue mix: self black shades: n+1. - s5 _ s5 copyFrom: 2 to: n+1. - ^ s1, s2, s3, s4, s5 -! ! -!Color class methodsFor: 'examples'! - showColorCube - "Show a 12x12x12 color cube." - "Color showColorCube" - - 0 to: 11 do: [:r | - 0 to: 11 do: [:g | - 0 to: 11 do: [:b | - Display fill: (((r*60) + (b*5)) @ (g*5) extent: 5@5) - fillColor: (Color r: r g: g b: b range: 11)]]]. -! ! -!Color class methodsFor: 'examples' stamp: 'jmv 8/17/2012 18:48'! - showColors: colorList - "Display the given collection of colors across the top of the Display." - - | w r | - w _ Display width // colorList size. - r _ 0@0 extent: w@((w min: 30) max: 10). - colorList do: [:c | - Display fill: r fillColor: c. - r _ r translatedBy: w@0]. -! ! -!Color class methodsFor: 'examples'! - showHSVPalettes - "Shows a palette of hues, varying the saturation and brightness for each one. Best results are with depths 16 and 32." - "Color showHSVPalettes" - - | left top c | - left _ top _ 0. - 0 to: 179 by: 15 do: [:h | - 0 to: 10 do: [:s | - left _ (h * 4) + (s * 4). - 0 to: 10 do: [:v | - c _ Color h: h s: s asFloat / 10.0 v: v asFloat / 10.0. - top _ (v * 4). - Display fill: (left@top extent: 4@4) fillColor: c. - - c _ Color h: h + 180 s: s asFloat / 10.0 v: v asFloat / 10.0. - top _ (v * 4) + 50. - Display fill: (left@top extent: 4@4) fillColor: c]]]. -! ! -!Color class methodsFor: 'examples' stamp: 'jmv 1/14/2013 21:12'! - showHuesInteractively - "Shows a palette of hues at a (saturation, brightness) point determined by the mouse position. Click the mouse button to exit and return the selected (saturation, brightness) point." - "Color showHuesInteractively" - - | p s v | - [Sensor isAnyButtonPressed] whileFalse: [ - p _ Sensor mousePoint. - s _ p x asFloat / 300.0. - v _ p y asFloat / 300.0. - self showColors: (self wheel: 12 saturation: s brightness: v)]. - ^ (s min: 1.0) @ (v min: 1.0)! ! -!Color class methodsFor: 'examples'! - wheel: thisMany - "Return a collection of thisMany colors evenly spaced around the color wheel." - "Color showColors: (Color wheel: 12)" - - ^ Color wheel: thisMany saturation: 0.9 brightness: 0.7 -! ! -!Color class methodsFor: 'examples'! - wheel: thisMany saturation: s brightness: v - "Return a collection of thisMany colors evenly spaced around the color wheel, all of the given saturation and brightness." - "Color showColors: (Color wheel: 12 saturation: 0.4 brightness: 1.0)" - "Color showColors: (Color wheel: 12 saturation: 0.8 brightness: 0.5)" - - ^ (Color h: 0.0 s: s v: v) wheel: thisMany -! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:58'! - aqua - - ^ self colorNamesDict at: #aqua! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:58'! - beige - - ^ self colorNamesDict at: #beige! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:58'! - black - - ^ self colorNamesDict at: #black! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:58'! - blue - - ^ self colorNamesDict at: #blue! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:58'! - brightGreen - - ^ self colorNamesDict at: #brightGreen! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:58'! - brown - - ^ self colorNamesDict at: #brown! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - cyan - - ^ self colorNamesDict at: #cyan! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - darkBlue - - ^ self colorNamesDict at: #darkBlue! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - darkGray - - ^ self colorNamesDict at: #darkGray! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - darkGreen - - ^ self colorNamesDict at: #darkGreen! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - darkPink - - ^ self colorNamesDict at: #darkPink! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - darkPurple - - ^ self colorNamesDict at: #darkPurple! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - forestGreen - - ^ self colorNamesDict at: #forestGreen! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - gray - - ^ self colorNamesDict at: #gray! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - green - - ^ self colorNamesDict at: #green! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - grey - - ^ self colorNamesDict at: #grey! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - hotPink - - ^ self colorNamesDict at: #hotPink! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - indigo - - ^ self colorNamesDict at: #indigo! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - lavender - - ^ self colorNamesDict at: #lavender! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - lightBlue - - ^ self colorNamesDict at: #lightBlue! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - lightBrown - - ^ self colorNamesDict at: #lightBrown! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - lightCyan - - ^ self colorNamesDict at: #lightCyan! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - lightGray - - ^ self colorNamesDict at: #lightGray! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - lightGreen - - ^ self colorNamesDict at: #lightGreen! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - lightMagenta - - ^ self colorNamesDict at: #lightMagenta! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! -lightOrange - - ^ self colorNamesDict at: #lightOrange! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - lightPink - - ^ self colorNamesDict at: #lightPink! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - lightPurple - - ^ self colorNamesDict at: #lightPurple! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - lightRed - - ^ self colorNamesDict at: #lightRed! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - lightYellow - - ^ self colorNamesDict at: #lightYellow! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - lilac - - ^ self colorNamesDict at: #lilac! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - lime - - ^ self colorNamesDict at: #lime! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - limeGreen - - ^ self colorNamesDict at: #limeGreen! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - magenta - - ^ self colorNamesDict at: #magenta! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - maroon - - ^ self colorNamesDict at: #maroon! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - mauve - - ^ self colorNamesDict at: #mauve! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - mustard - - ^ self colorNamesDict at: #mustard! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - navyBlue - - ^ self colorNamesDict at: #navyBlue! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - olive - - ^ self colorNamesDict at: #olive! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - oliveGreen - - ^ self colorNamesDict at: #oliveGreen! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - orange - - ^ self colorNamesDict at: #orange! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - paleGreen - - ^ self colorNamesDict at: #paleGreen! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - peach - - ^ self colorNamesDict at: #peach! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - periwinkle - - ^ self colorNamesDict at: #periwinkle! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - pink - - ^ self colorNamesDict at: #pink! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - purple - - ^ self colorNamesDict at: #purple! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - red - - ^ self colorNamesDict at: #red! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - royalBlue - - ^ self colorNamesDict at: #royalBlue! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - salmon - - ^ self colorNamesDict at: #salmon! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - seaGreen - - ^ self colorNamesDict at: #seaGreen! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - skyBlue - - ^ self colorNamesDict at: #skyBlue! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - tan - - ^ self colorNamesDict at: #tan! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - teal - - ^ self colorNamesDict at: #teal! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - transparent - - ^ self colorNamesDict at: #transparent! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - turquoise - - ^ self colorNamesDict at: #turquoise! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - veryDarkGray - - ^ self colorNamesDict at: #veryDarkGray! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! -veryLightGray - - ^ self colorNamesDict at: #veryLightGray! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - veryVeryDarkGray - - ^ self colorNamesDict at: #veryVeryDarkGray! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - veryVeryLightGray - - ^ self colorNamesDict at: #veryVeryLightGray! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - violet - - ^ self colorNamesDict at: #violet! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - white - - ^ self colorNamesDict at: #white! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - yellow - - ^ self colorNamesDict at: #yellow! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 5/12/2016 15:49'! - cachedColormapForGrayFrom: sourceDepth - "Return a cached colormap for mapping from the given depth to the 8bpp grays. Always return a real colormap, not nil; this allows the client to get an identity colormap that can then be copied and modified to do color transformations." - "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" - "Note: The colormap cache may be cleared by evaluating 'Color shutDown'." - "Note: The color maps for sourceDepth=16 and for sourceDepth=32 are the same" - - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | srcIndex map | - ToGrayColormaps ifNil: [ - ToGrayColormaps _ Array new: 5]. - - srcIndex _ sourceDepth highBit min: 5. - - (ToGrayColormaps at: srcIndex) ifNotNil: [ :m | ^ m ]. - - map _ self computeColormapForGray8bppFrom: sourceDepth. - ToGrayColormaps at: srcIndex put: map. - ^ map! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 5/12/2016 14:50'! - cachedColormapFrom: sourceDepth to: destDepth - "Return a cached colormap for mapping between the given depths. Always return a real colormap, not nil; this allows the client to get an identity colormap that can then be copied and modified to do color transformations." - "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" - "Note: The colormap cache may be cleared by evaluating 'Color shutDown'." - "Note: The color maps for sourceDepth=16 and for sourceDepth=32 are the same" - - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | srcIndex dstIndex map | - CachedColormaps - ifNil: [CachedColormaps _ (1 to: 5) collect: [:i | Array new: 6]]. - - srcIndex _ sourceDepth highBit min: 5. - dstIndex _ destDepth highBit. - - ((CachedColormaps at: srcIndex) at: dstIndex) ifNotNil: [ :m | ^ m ]. - - map _ self computeColormapFrom: sourceDepth to: destDepth. - (CachedColormaps at: srcIndex) at: dstIndex put: map. - ^ map! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 5/12/2016 15:49'! - cachedColormapFromGrayTo: destDepth - "Return a cached colormap for mapping from 8bpp grays to the given depth. Always return a real colormap, not nil; this allows the client to get an identity colormap that can then be copied and modified to do color transformations." - "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" - "Note: The colormap cache may be cleared by evaluating 'Color shutDown'." - "Note: The color maps for sourceDepth=16 and for sourceDepth=32 are the same" - - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | dstIndex map | - FromGrayColormaps - ifNil: [FromGrayColormaps _ Array new: 6 ]. - - dstIndex _ destDepth highBit. - - (FromGrayColormaps at: dstIndex) ifNotNil: [ :m | ^ m ]. - - map _ self computeColormapFromGray8bppForDepth: destDepth. - FromGrayColormaps at: dstIndex put: map. - ^ map! ! -!Color class methodsFor: 'colormaps'! - colorMapIfNeededFrom: sourceDepth to: destDepth - "Return a colormap for mapping between the given depths, or nil if no colormap is needed." - "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" - - sourceDepth = destDepth ifTrue: [^ nil]. "not needed if depths are the same" - - (sourceDepth >= 16) & (destDepth >= 16) ifTrue: [ - "mapping is done in BitBlt by zero-filling or truncating each color component" - ^ nil]. - - ^ Color cachedColormapFrom: sourceDepth to: destDepth -! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 8/27/2009 08:47'! - computeColorConvertingMap: targetColor from: sourceDepth to: destDepth keepSubPixelAA: keepSubPix - "Note: The color converting map for sourceDepth=16 and for sourceDepth=32 are the same" - sourceDepth < 16 ifTrue: [ - "source is 1-, 2-, 4-, or 8-bit indexed color. - Assumed not to include subpixelAA" - ^ self computeIndexedColorConvertingMap: targetColor from: sourceDepth to: destDepth - ] ifFalse: [ - "source is 16-bit or 32-bit RGB. - Might include subpixelAA" - ^ self computeRGBColorConvertingMap: targetColor to: destDepth keepSubPixelAA: keepSubPix - ]! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 5/12/2016 15:55'! - computeColormapForGray8bppFrom: sourceDepth - "Compute a colorMap for translatingfrom the given depth to the 8bpp grays" - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | map | - sourceDepth < 16 ifTrue: [ - "source is 1-, 2-, 4-, or 8-bit indexed color" - map _ (self indexedColors copyFrom: 1 to: (1 bitShift: sourceDepth)) - collect: [ :c | (c luminance * 255) rounded]. - map _ map as: Bitmap. - ^ map - ] - ifFalse: [ - ^ self computeRGBColormapForGray8 ]! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 4/17/2015 15:05'! - computeColormapFrom: sourceDepth to: destDepth - "Compute a colorMap for translating between the given depths. A colormap is a Bitmap whose entries contain the pixel values for the destination depth. Typical clients use cachedColormapFrom:to: instead." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | map bitsPerColor | - sourceDepth < 16 ifTrue: [ - "source is 1-, 2-, 4-, or 8-bit indexed color" - map _ (self indexedColors copyFrom: 1 to: (1 bitShift: sourceDepth)) - collect: [:c | c pixelValueForDepth: destDepth]. - map _ map as: Bitmap. - ] ifFalse: [ - "source is 16-bit or 32-bit RGB" - destDepth > 8 - ifTrue: [bitsPerColor _ 5] "retain maximum color resolution" - ifFalse: [bitsPerColor _ 4]. - map _ self computeRGBColormapFor: destDepth bitsPerColor: bitsPerColor]. - - "Note: zero is transparent except when source depth is one-bit deep" - sourceDepth > 1 ifTrue: [map at: 1 put: 0]. - ^ map -! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 5/12/2016 15:56'! - computeColormapFromGray8bppForDepth: destDepth - "Return a colormap for displaying a GrayForm at the given depth" - - | newMap | - newMap _ Bitmap new: 256. - 1 to: 256 do: [ :i | - newMap - at: i - put: ((Color gray: (i-1) asFloat / 255.0) pixelValueForDepth: destDepth)]. - ^ newMap! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 4/17/2015 15:05'! - computeIndexedColorConvertingMap: targetColor from: sourceDepth to: destDepth - | map | - - map _ (self indexedColors copyFrom: 1 to: (1 bitShift: sourceDepth)) collect: [ :cc | | f c | - f _ 1.0 - (cc red + cc green + cc blue / 3.0 ). - c _ targetColor - ifNotNil: [ - destDepth = 32 - ifTrue: [ targetColor * f alpha: f] - ifFalse: [ targetColor alphaMixed: f*1.5 with: Color white ]] - ifNil: [ cc ]. - destDepth = 32 - ifTrue: [ c pixelValueForDepth: destDepth] - ifFalse: [ - f = 0.0 - ifTrue: [ 0 ] - ifFalse: [ c pixelValueForDepth: destDepth ]]]. - map _ map as: Bitmap. - ^map! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 12/26/2011 13:49'! - computeRGBColorConvertingMap: targetColor to: destDepth keepSubPixelAA: keepSubPix - "Builds a colormap intended to convert from subpixelAA black values to targetColor values. - keepSubPix - ifTrue: [ Answer colors that also include subpixelAA ] - ifFalse: [ - Take fullpixel luminance level. Apply it to targetColor. - I.e. answer colors with NO subpixelAA ]" - - | mask map c bitsPerColor r g b f v | - - destDepth > 8 - ifTrue: [bitsPerColor _ 5] "retain maximum color resolution" - ifFalse: [bitsPerColor _ 4]. - "Usually a bit less is enough, but make it configurable" - bitsPerColor _ bitsPerColor min: Preferences aaFontsColormapDepth. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - r _ (i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask. - g _ (i bitShift: 0 - bitsPerColor) bitAnd: mask. - b _ (i bitShift: 0) bitAnd: mask. - f _ 1.0 - (r + g + b / 3.0 / mask). - c _ targetColor - ifNotNil: [ - (keepSubPix and: [destDepth > 8]) ifTrue: [ - Color - r: 1.0 - (r asFloat/mask) * targetColor red - g: 1.0 - (g asFloat/mask) * targetColor green - b: 1.0 - (b asFloat/mask) * targetColor blue - alpha: f * targetColor alpha "alpha will be ignored below, in #pixelValueForDepth: if destDepth ~= 32" ] - ifFalse: [ - destDepth = 32 - ifTrue: [ targetColor * f alpha: f * targetColor alpha ] - ifFalse: [ targetColor alphaMixed: f*1.5 with: Color white ]]] - ifNil: [ Color r: r g: g b: b range: mask]. "This is currently used only to keep some SubPixelAA on destDepth = 8, using a single pass of rule 25" - v _ destDepth = 32 - ifTrue: [ c pixelValueForDepth: destDepth] - ifFalse: [ - f < 0.1 - ifTrue: [ 0 ] - ifFalse: [ c pixelValueForDepth: destDepth ]]. - map at: i + 1 put: v ]. - ^ map! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 1/30/2011 23:10'! - computeRGBColormapFor: destDepth bitsPerColor: bitsPerColor - "Compute a colorMap for translating from 16-bit or 32-bit RGB color to the given depth, using the given number of of bits per color component." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | mask map c | - (#(3 4 5) includes: bitsPerColor) - ifFalse: [self error: 'BitBlt only supports 3, 4, or 5 bits per color component']. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - c _ Color - r: ((i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask) - g: ((i bitShift: 0 - bitsPerColor) bitAnd: mask) - b: ((i bitShift: 0) bitAnd: mask) - range: mask. - map at: i + 1 put: (c pixelValueForDepth: destDepth)]. - - map at: 1 put: (Color transparent pixelWordForDepth: destDepth). "zero always transparent" - ^ map -! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 5/12/2016 15:57'! - computeRGBColormapForGray8 - "Compute a colorMap for translating from 16-bit or 32-bit RGB color to 8bpp grays, using the default number of of bits per color component." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | bitsPerColor mask map c | - bitsPerColor _ 5. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - c _ Color - r: ((i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask) - g: ((i bitShift: 0 - bitsPerColor) bitAnd: mask) - b: ((i bitShift: 0) bitAnd: mask) - range: mask. - map at: i + 1 put: (c luminance * 255) rounded]. - - ^ map! ! -!Color class methodsFor: 'other' stamp: 'jmv 1/31/2011 09:30'! - maskingMap: depth - "Return a color map that maps all colors except transparent to words of all ones. Used to create a mask for a Form whose transparent pixel value is zero. Cache the most recently used map." - "Warning: The behavior is incorrect if depth = 32. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | sizeNeeded | - depth <= 8 - ifTrue: [sizeNeeded _ 1 bitShift: depth] - ifFalse: [sizeNeeded _ 4096]. - - (MaskingMap == nil or: [MaskingMap size ~= sizeNeeded]) ifTrue: - [MaskingMap _ Bitmap new: sizeNeeded withAll: 16rFFFFFFFF. - MaskingMap at: 1 put: 0. "transparent"]. - - ^ MaskingMap -! ! -!Color class methodsFor: 'color from user' stamp: 'jmv 3/1/2010 15:13'! - colorPaletteForDepth: depth extent: chartExtent - "Display a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." - "Note: It is slow to build this palette, so it should be cached for quick access." - "(Color colorPaletteForDepth: 16 extent: 190@60) display" - - | basicHue x y startHue palette transHt vSteps transCaption grayWidth hSteps | - palette _ Form extent: chartExtent depth: depth. - transCaption _ - (Form extent: 34@9 depth: 1 - fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0) - offset: 0@0). - transHt _ transCaption height. - palette fillWhite: (0@0 extent: palette width@transHt). - palette fillBlack: (0@transHt extent: palette width@1). - transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0). - grayWidth _ 10. - startHue _ 338.0. - vSteps _ palette height - transHt // 2. - hSteps _ palette width - grayWidth. - x _ 0. - startHue to: startHue + 360.0 by: 360.0/hSteps do: [ :h | - basicHue _ Color h: h asFloat s: 1.0 v: 1.0. - y _ transHt+1. - 0 to: vSteps do: [ :n | | c | - c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Color white. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - 1 to: vSteps do: [ :n | | c | - c _ Color black mixed: (n asFloat / vSteps asFloat) with: basicHue. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - x _ x + 1]. - y _ transHt + 1. - 1 to: vSteps * 2 do: [ :n | | c | - c _ Color black mixed: (n asFloat / (vSteps*2) asFloat) with: Color white. - palette fill: (x@y extent: 10@1) fillColor: c. - y _ y + 1]. - ^ palette -! ! -!Color class methodsFor: 'color from user' stamp: 'jmv 7/27/2009 11:32'! - colorTest: depth extent: chartExtent colorMapper: colorMapper - "Create a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." - "Note: It is slow to build this palette, so it should be cached for quick access." - "(Color colorTest: 32 extent: 570@180 colorMapper: [:c | c]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 7) asInteger / 7 - g: (c green * 7) asInteger / 7 - b: (c blue * 3) asInteger / 3]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 5) asInteger / 5 - g: (c green * 5) asInteger / 5 - b: (c blue * 5) asInteger / 5]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 15) asInteger / 15 - g: (c green * 15) asInteger / 15 - b: (c blue * 15) asInteger / 15]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 31) asInteger / 31 - g: (c green * 31) asInteger / 31 - b: (c blue * 31) asInteger / 31]) display" - - | basicHue x y c startHue palette transHt vSteps transCaption grayWidth hSteps | - palette _ Form extent: chartExtent depth: depth. - transCaption _ - (Form extent: 34@9 depth: 1 - fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0) - offset: 0@0). - transHt _ transCaption height. - palette fillWhite: (0@0 extent: palette width@transHt). - palette fillBlack: (0@transHt extent: palette width@1). - transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0). - grayWidth _ 10. - startHue _ 338.0. - vSteps _ palette height - transHt // 2. - hSteps _ palette width - grayWidth. - x _ 0. - startHue to: startHue + 360.0 by: 360.0/hSteps do: [:h | - basicHue _ Color h: h asFloat s: 1.0 v: 1.0. - y _ transHt+1. - 0 to: vSteps do: [:n | - c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Color white. - c _ colorMapper value: c. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - 1 to: vSteps do: [:n | - c _ Color black mixed: (n asFloat / vSteps asFloat) with: basicHue. - c _ colorMapper value: c. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - x _ x + 1]. - y _ transHt + 1. - 1 to: vSteps * 2 do: [:n | - c _ Color black mixed: (n asFloat / (vSteps*2) asFloat) with: Color white. - c _ colorMapper value: c. - palette fill: (x@y extent: 10@1) fillColor: c. - y _ y + 1]. - ^ palette -! ! -!Color class methodsFor: 'color name lookup' stamp: 'KenD 1/26/2013 20:13'! - colorNames - "Answer the current dictionary of name->color associations." - - ^self colorNamesDict keys! ! -!Color class methodsFor: 'color name lookup' stamp: 'KenD 1/28/2013 20:34'! - defaultColorNamesDictionary - "Answer a amall but useful name->color dictionary" - - | defaultDict | - "Meld most used xkcd colors into traditional colors." - defaultDict := (self traditionalColorNamesDictionary addAll: - self xkcdFirst48ColorNamesDictionary; - yourself). - - "Override traditional names existing in extended XKCD naming" - defaultDict at: #lightYellow put: (Color r: 1.0 g: 0.996 b: 0.478). - defaultDict at: #lightOrange put: (Color r: 0.992 g: 0.667 b: 0.283). - defaultDict at: #lightCyan put: (Color r: 0.674 g: 1.0 b: 0.988). - defaultDict at: #lightRed put: (Color r: 1.0 g: 0.279 b: 0.298). - defaultDict at: #lightMagenta put: (Color r: 0.98 g: 0.372 b: 0.969). - - ^defaultDict! ! -!Color class methodsFor: 'color name lookup' stamp: 'KenD 2/1/2013 14:39'! - doesNotUnderstand: aMessage - "Some code takes - Color colorNames - and does - Color perform: aColorname. - - Make this work." - - ^(Color colorNamesDict) - at: (aMessage selector) - ifAbsent: [super doesNotUnderstand: aMessage]! ! -!Color class methodsFor: 'color name lookup' stamp: 'KenD 1/26/2013 20:51'! - exactColorNamed: aColorName - - "Answer color matching name or nil - from my ColorName->Color Dictionary" - - ^ self colorNamesDict at: (aColorName asSymbol) ifAbsent: [nil]! ! -!Color class methodsFor: 'color name lookup' stamp: 'KenD 7/25/2014 21:22'! - setColorNamesDict: aNameColorDictionary - "Answer the current dictionary of name->color associations." - - "Note: This is a non-standard name because this is a non-standard action!! - Do this if you really, really know what you are doing." - - "Some Colors are required for proper system operation" - Color defaultColorNamesDictionary keysAndValuesDo: [ :colorName :colorValue | - aNameColorDictionary at: colorName ifAbsentPut: colorValue - ]. - - ColorNamesDict := aNameColorDictionary! ! -!Color class methodsFor: 'color name lookup' stamp: 'sqr 10/21/2016 12:44:48'! - traditionalColorNamesDictionary - "Answer a dictionary of Squeak traditional name->color associations.." - - | nameDict | - nameDict _ Dictionary new. - nameDict at: #black put: (Color r: 0 g: 0 b: 0). - nameDict at: #veryVeryDarkGray put: (Color r: 0.125 g: 0.125 b: 0.125). - nameDict at: #veryDarkGray put: (Color r: 0.25 g: 0.25 b: 0.25). - nameDict at: #darkGray put: (Color r: 0.375 g: 0.375 b: 0.375). - nameDict at: #gray put: (Color r: 0.5 g: 0.5 b: 0.5). - nameDict at: #lightGray put: (Color r: 0.625 g: 0.625 b: 0.625). - nameDict at: #veryLightGray put: (Color r: 0.75 g: 0.75 b: 0.75). - nameDict at: #veryVeryLightGray put: (Color r: 0.875 g: 0.875 b: 0.875). - nameDict at: #white put: (Color r: 1.0 g: 1.0 b: 1.0). - nameDict at: #red put: (Color r: 1.0 g: 0 b: 0). - nameDict at: #yellow put: (Color r: 1.0 g: 1.0 b: 0). - nameDict at: #green put: (Color r: 0 g: 1.0 b: 0). - nameDict at: #cyan put: (Color r: 0 g: 1.0 b: 1.0). - nameDict at: #blue put: (Color r: 0 g: 0 b: 1.0). - nameDict at: #magenta put: (Color r: 1.0 g: 0 b: 1.0). - nameDict at: #brown put: (Color r: 0.6 g: 0.2 b: 0). - nameDict at: #orange put: (Color r: 1.0 g: 0.6 b: 0). - nameDict at: #lightRed put: (Color r: 1.0 g: 0.8 b: 0.8). - nameDict at: #lightYellow put: (Color r: 1.0 g: 1.0 b: 0.8). - nameDict at: #lightGreen put: (Color r: 0.8 g: 1.0 b: 0.6). - nameDict at: #lightCyan put: (Color r: 0.4 g: 1.0 b: 1.0). - nameDict at: #lightBlue put: (Color r: 0.8 g: 1.0 b: 1.0). - nameDict at: #lightMagenta put: (Color r: 1.0 g: 0.8 b: 1.0). - nameDict at: #lightBrown put: (Color r: 1.0 g: 0.6 b: 0.2). - nameDict at: #lightOrange put: (Color r: 1.0 g: 0.8 b: 0.4). - nameDict at: #transparent put: (TranslucentColor r: 0.0 g: 0.0 b: 0.0 alpha: 0.0). - - ^nameDict -! ! -!Color class methodsFor: 'color name lookup' stamp: 'jmv 6/30/2014 15:22'! - xkcdFirst48ColorNamesDictionary - "XKCD color names are based on a survey oc colors people call by the same name. - http://blog.xkcd.com/2010/05/03/color-survey-results/" - - "Answer a dictionary of the most agreed upon first 48 xkcd colors" -" - Color xkcdFirst48ColorNamesDictionary explore. -" - | xkcdDict | - xkcdDict := Dictionary new - at: #lightPink put: (Color fromString: '#ffd1df') ; - at: #mustard put: (Color fromString: '#ceb301') ; - at: #indigo put: (Color fromString: '#380282') ; - at: #lime put: (Color fromString: '#aaff32') ; - at: #seaGreen put: (Color fromString: '#53fca1') ; - at: #periwinkle put: (Color fromString: '#8e82fe') ; - at: #darkPink put: (Color fromString: '#cb416b') ; - at: #oliveGreen put: (Color fromString: '#677a04') ; - at: #peach put: (Color fromString: '#ffb07c') ; - at: #paleGreen put: (Color fromString: '#c7fdb5') ; - at: #lightBrown put: (Color fromString: '#ad8150') ; - at: #hotPink put: (Color fromString: '#ff028d') ; - at: #black put: (Color fromString: '#000000') ; - at: #lilac put: (Color fromString: '#cea2fd') ; - at: #navyBlue put: (Color fromString: '#001146') ; - at: #royalBlue put: (Color fromString: '#0504aa') ; - at: #beige put: (Color fromString: '#e6daa6') ; - at: #salmon put: (Color fromString: '#ff796c') ; - at: #olive put: (Color fromString: '#6e750e') ; - at: #maroon put: (Color fromString: '#650021') ; - at: #brightGreen put: (Color fromString: '#01ff07') ; - at: #darkPurple put: (Color fromString: '#35063e') ; - at: #mauve put: (Color fromString: '#ae7181') ; - at: #forestGreen put: (Color fromString: '#06470c') ; - at: #aqua put: (Color fromString: '#13eac9') ; - at: #cyan put: (Color fromString: '#00ffff') ; - at: #tan put: (Color fromString: '#d1b26f') ; - at: #darkBlue put: (Color fromString: '#00035b') ; - at: #lavender put: (Color fromString: '#c79fef') ; - at: #turquoise put: (Color fromString: '#06c2ac') ; - at: #darkGreen put: (Color fromString: '#033500') ; - at: #violet put: (Color fromString: '#9a0eea') ; - at: #lightPurple put: (Color fromString: '#bf77f6') ; - at: #limeGreen put: (Color fromString: '#89fe05') ; - at: #grey put: (Color fromString: '#929591') ; - at: #skyBlue put: (Color fromString: '#75bbfd') ; - at: #yellow put: (Color fromString: '#ffff14') ; - at: #magenta put: (Color fromString: '#c20078') ; - at: #lightGreen put: (Color fromString: '#96f97b') ; - at: #orange put: (Color fromString: '#f97306') ; - at: #teal put: (Color fromString: '#029386') ; - at: #lightBlue put: (Color fromString: '#95d0fc') ; - at: #red put: (Color fromString: '#e50000') ; - at: #brown put: (Color fromString: '#653700') ; - at: #pink put: (Color fromString: '#ff81c0') ; - at: #blue put: (Color fromString: '#0343df') ; - at: #green put: (Color fromString: '#15b01a') ; - at: #purple put: (Color fromString: '#7e1e9c') ; - yourself. - - ^xkcdDict - -! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:26'! - blueColorDict - "Answer a dictionary of named colors considered Blue" -" - Color blueColorDict explore. -" - ^self blueColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:24'! - blueColorDict: aColorDict - "Answer a dictionary of named colors considered Blue" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isBlue) - or: [assoc key asString asLowercase includesSubString: 'blue']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:28'! - blueGreenColorDict - "Answer a dictionary of named colors considered Blue" -" - Color blueGreenColorDict explore. -" - ^self blueGreenColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:29'! - blueGreenColorDict: aColorDict - "Answer a dictionary of named colors considered Blue" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isBlueGreen) - or: [assoc key asString asLowercase includesSubString: 'bluegreen']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:31'! - brightColorDict - "Answer a dictionary of named colors considered Bright" -" - Color brightColorDict explore. -" - ^self brightColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:31'! - brightColorDict: aColorDict - "Answer a dictionary of named colors considered Bright" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - (assoc value isBright) ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:34'! - brownColorDict - "Answer a dictionary of named colors considered Brown" -" - Color brownColorDict explore. -" - ^self brownColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:33'! - brownColorDict: aColorDict - "Answer a dictionary of named colors considered Brown" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isBrown) - or: [assoc key asString asLowercase includesSubString: 'brown']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:36'! - darkColorDict - "Answer a dictionary of named colors considered Dark" -" - Color darkColorDict explore. -" - ^self darkColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:37'! - darkColorDict: aColorDict - "Answer a dictionary of named colors considered Dark" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - (assoc value isDark) ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:41'! - grayColorDict: aColorDict - "Answer a dictionary of named colors considered Grey" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isGrey) - or: [assoc key asString asLowercase includesSubString: 'grey']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:38'! - greenColorDict - "Answer a dictionary of named colors considered Green" -" - Color greenColorDict explore. -" - ^self greenColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:38'! - greenColorDict: aColorDict - "Answer a dictionary of named colors considered Green" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isGreen) - or: [assoc key asString asLowercase includesSubString: 'green']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:41'! - greyColorDict - "Answer a dictionary of named colors considered Grey" -" - Color greyColorDict explore. -" - ^self greyColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:40'! - greyColorDict: aColorDict - "Answer a dictionary of named colors considered Grey" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isGrey) - or: [assoc key asString asLowercase includesSubString: 'grey']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:44'! - lightColorDict - "Answer a dictionary of named colors considered light" -" - Color lightColorDict explore. -" - ^self lightColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:43'! - lightColorDict: aColorDict - "Answer a dictionary of named colors considered Liight" - - ^self brightColorDict: aColorDict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:46'! - orangeColorDict - "Answer a dictionary of named colors considered Orange" -" - Color orangeColorDict explore. -" - ^self orangeColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:46'! - orangeColorDict: aColorDict - "Answer a dictionary of named colors considered Orange" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isOrange) - or: [assoc key asString asLowercase includesSubString: 'orange']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:48'! - pastelColorDict - "Answer a dictionary of named colors considered Pastel" -" - Color pastelColorDict explore. -" - ^self pastelColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:48'! - pastelColorDict: aColorDict - "Answer a dictionary of named colors considered Bright" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - (assoc value isPastel) ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:50'! - pinkColorDict - "Answer a dictionary of named colors considered Pink" -" - Color pinkColorDict explore. -" - ^self pinkColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:50'! - pinkColorDict: aColorDict - "Answer a dictionary of named colors considered Pink" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isPink) - or: [assoc key asString asLowercase includesSubString: 'pink']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:52'! - purpleColorDict - "Answer a dictionary of named colors considered Purple" -" - Color purpleColorDict explore. -" - ^self purpleColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:52'! - purpleColorDict: aColorDict - "Answer a dictionary of named colors considered Pink" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc key asString asLowercase includesSubString: 'purple') - or: [assoc key asString asLowercase includesSubString: 'violet']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:54'! - redColorDict - "Answer a dictionary of named colors considered Red" -" - Color redColorDict explore. -" - ^self redColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:53'! - redColorDict: aColorDict - "Answer a dictionary of named colors considered Red" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isRed) - or: [assoc key asString asLowercase includesSubString: 'red']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:56'! - saturatedColorDict - "Answer a dictionary of named colors considered Saturated" -" - Color saturatedColorDict explore. -" - ^self saturatedColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:55'! - saturatedColorDict: aColorDict - "Answer a dictionary of named colors considered Saturated" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - (assoc value isSaturated) ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:26'! - yellowColorDict - "Answer a dictionary of named colors considered Yellow" -" - Color yellowColorDict explore. -" - ^self yellowColorDict: (self colorNamesDict)! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:19'! - yellowColorDict: aColorDict - "Answer a dictionary of named colors considered Yellow" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isYellow) - or: [assoc key asString asLowercase includesSubString: 'yellow']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'color space conversions' stamp: 'jmv 4/24/2013 10:55'! - applySimpleGamma: gamma to: value - "Encode / decode Gamma. Typical gamma are 0.4545 ( = 1.0 / 2.2, for encoding) and 2.2 (for decoding) - In a non gamma encoded image, the pixel values are proportional to luminance, i.e. the actual light intensity, the photon count. - In an gamma encoded image, the pixel value is close to the average perceived brightness, or 'lightness'. This optimizes the use of available bits in digital images, and dynamic range in analog images and film. This is like the 'luma' signal in video. - - Usually: - - Images stored in file formats such as jpg, png, tiff and bmp are gamma encoded - (unless they are actually raw images). - - Images sent to a framebuffer (video memory) should be gamma encoded. - - Raw images from sensors are not gamma encoded. - - - Image processing algorithms that simulate the real world, or are applied to real world data should work on unencoded (linear) images. - This includes filtering, resizing, blending, and most operations done on images. - This means that if the images come from jpg photos from a camera, they should be gamma decoded. - - Image processing algorithms that works on human perception should work on gamma encoded images. - This includes histograms, histogram equalization, bit allocation (i.e. quantization), compression, etc. - This also includes detecting objects like a human would do - - - See - http://en.wikipedia.org/wiki/Gamma_correction - http://www.poynton.com/notes/colour_and_gamma/GammaFAQ.html - - Mostly for documentation. - value must be in [0.0 .. 1.0]. - Note that the sRGB standard specifies a function that is close to this, but slightly different. - See #linearTosRGBGamma: and #sRGBGammaToLinear:" - - ^ value raisedTo: gamma! ! -!Color class methodsFor: 'color space conversions' stamp: 'jmv 4/24/2013 10:49'! - linearTosRGBGamma: value - "The sRGB standard specifies a gamma curve that is close to gamma = 2.2, but is actually - built from one stright line segment, and a curve with exponent = 2.4. - This method converts value from linearSpace to gammaSpace, i.e. it 'encodes' with gamma. - This is the operation done when producing an 8bit Form for displaying, or for saving on a JPG, PNG, etc; if source data is in linear space (for example, from raw data a sensor image, or data that was converted previously to linear space for proper image processing). - value must be in [0.0 .. 1.0]. - - See - http://en.wikipedia.org/wiki/Gamma_correction - http://www.poynton.com/notes/colour_and_gamma/GammaFAQ.html - http://entropymine.com/imageworsener/srgbformula - - | r v | - r _ Random new. - 1000 timesRepeat: [ - v _ r next. - self assert: ((Color sRGBGammaToLinear: (Color linearTosRGBGamma: v)) closeTo: v) ] - - | r | - r _ 10@10 extent: 600@400. - Display fill: r fillColor: Color white. - FFT new plot: ((0.0 to: 1.0 count: 100) collect: [ :v | Color linearTosRGBGamma: v ]) in: r color: Color black min: 0.0 max: 1.0. - FFT new plot: ((0.0 to: 1.0 count: 100) collect: [ :v | Color applySimpleGamma: 1/2.2 to: v ]) in: r color: Color blue min: 0.0 max: 1.0. - FFT new plot: ((0.0 to: 1.0 count: 100) collect: [ :v | Color sRGBGammaToLinear: v ]) in: r color: Color black min: 0.0 max: 1.0. - FFT new plot: ((0.0 to: 1.0 count: 100) collect: [ :v | Color applySimpleGamma: 2.2 to: v ]) in: r color: Color blue min: 0.0 max: 1.0. - " - - ^ value <= 0.00313066844250063 - ifTrue: [ value * 12.92 ] - ifFalse: [ (value raisedTo: 1.0/2.4) * 1.055 - 0.055 ]! ! -!Color class methodsFor: 'color space conversions' stamp: 'jmv 4/24/2013 10:50'! - sRGBGammaToLinear: value - "The sRGB standard specifies a gamma curve that is close to gamma = 2.2, but is actually - built from one stright line segment, and a curve with exponent = 2.4. - This method converts value from gammaSpace to linearSpace, i.e. it 'decodes'. - This is the operation done by display screens. It is also needed to convert 8bit Forms (from a frameBuffer, or from PNG, JPG, etc.) to linear space for proper image processing. - value must be in [0.0 .. 1.0]. - - See - http://en.wikipedia.org/wiki/Gamma_correction - http://www.poynton.com/notes/colour_and_gamma/GammaFAQ.html - http://entropymine.com/imageworsener/srgbformula - " - - ^ value <= 0.0404482362771082 - ifTrue: [ value / 12.92 ] - ifFalse: [ value + 0.055 / 1.055 raisedTo: 2.4 ]! ! -!Color class methodsFor: 'cached state access' stamp: 'jmv 4/17/2015 14:58'! - colorNamesDict - "Answer the current dictionary of name->color associations." -" - Color colorNamesDict explore. -" - ColorNamesDict ifNil: [ - self setColorNamesDict: self defaultColorNamesDictionary ]. - ^ColorNamesDict! ! -!Color class methodsFor: 'cached state access' stamp: 'jmv 4/17/2015 15:08'! - grayToIndexMap - " - Color grayToIndexMap explore. - " - GrayToIndexMap ifNil: [ - self initializeGrayToIndexMap ]. - ^GrayToIndexMap! ! -!Color class methodsFor: 'cached state access' stamp: 'jmv 4/17/2015 15:04'! - indexedColors - " - Color indexedColors explore. - " - IndexedColors ifNil: [ - self initializeIndexedColors ]. - ^IndexedColors! ! -!Color class methodsFor: 'cached state access' stamp: 'jmv 5/12/2016 14:58'! - releaseClassCachedState - " - Color releaseClassCachedState - " - CachedColormaps _ nil. "Maps to translate between color depths" - ToGrayColormaps _ nil. "Maps colors to 8bpp grays for various color depths" - FromGrayColormaps _ nil. "Maps from 8bpp grays to colors of various depths" - MaskingMap _ nil. "Maps all colors except transparent to black for creating a mask" - ColorNamesDict _ nil. - IndexedColors _ nil. - GrayToIndexMap _ nil! ! -!TranslucentColor methodsFor: 'accessing' stamp: 'jmv 6/18/2017 20:41:17'! - alpha - "Return my alpha value, a number between 0.0 and 1.0 where 0.0 is completely transparent and 1.0 is completely opaque." - - ^ self at: 4! ! -!TranslucentColor methodsFor: 'printing' stamp: 'jmv 1/5/2014 21:06'! - storeArrayValuesOn: aStream - - self isTransparent ifTrue: [ - ^ aStream space]. - super storeArrayValuesOn: aStream. - aStream space. - self alpha printOn: aStream fractionDigits: 3! ! -!TranslucentColor methodsFor: 'printing' stamp: 'jmv 1/5/2014 21:20'! - storeOn: aStream - - self isTransparent ifTrue: [^ aStream nextPutAll: '(Color transparent)']. - aStream - nextPut: $(; - nextPutAll: self class name; - nextPutAll: ' r: '. - self red printOn: aStream fractionDigits: 3. - aStream nextPutAll: ' g: '. - self green printOn: aStream fractionDigits: 3. - aStream nextPutAll: ' b: '. - self blue printOn: aStream fractionDigits: 3. - aStream nextPutAll: ' alpha: '. - self alpha printOn: aStream fractionDigits: 3. - aStream nextPutAll: ')'! ! -!TranslucentColor methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:55:03'! - alpha: alphaValue - "Return a new TranslucentColor with the given amount of opacity ('alpha')." - alphaValue = 1.0 ifTrue: [ - ^ Color new - setRed: self red - green: self green - blue: self blue]. - ^ super alpha: alphaValue! ! -!TranslucentColor methodsFor: 'conversions' stamp: 'sw 10/27/1999 10:51'! - asNontranslucentColor - ^ self alpha: 1.0! ! -!TranslucentColor methodsFor: 'conversions' stamp: 'jmv 4/19/2013 16:10'! - bitPatternForDepth: depth - "Return an appropriate bit pattern. This will almost never be meaningful for tranlucentColors, except for the degenerate case of tranparency." - - self isTransparent ifTrue: [ - ^ Bitmap with: 0]. - ^ super bitPatternForDepth: depth! ! -!TranslucentColor methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:41:47'! - pixelValueForDepth: d - "Return the pixel value for this color at the given depth. Translucency only works in RGB; this color will appear either opaque or transparent at all other depths." - | basicPixelWord | - "In 32bpp, if alpha = 0, ignore any color components, and answer R=0, G=0, B=0, Alpha=0. - In depths > 8 and < 32, pixelValue zero is the special value used by BitBlt to denote transparent." - self isTransparent ifTrue: [ - ^ 0]. - basicPixelWord _ super pixelValueForDepth: d. - ^d < 32 - ifTrue: [ basicPixelWord ] - ifFalse: [ (basicPixelWord bitAnd: 16rFFFFFF) bitOr: - ((self alpha*255.0) rounded - bitShift: 24) ]! ! -!TranslucentColor methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:41:50'! - pixelWordForDepth: depth - "Return the pixel value for this color at the given depth. Translucency only works in RGB; this color will appear either opaque or transparent at all other depths." - - | basicPixelWord | - self isTransparent ifTrue: [^ 0]. - basicPixelWord _ super pixelWordForDepth: depth. - ^depth < 32 - ifTrue: [ basicPixelWord ] - ifFalse: [ (basicPixelWord bitAnd: 16rFFFFFF) bitOr: - ((self alpha*255.0) rounded - bitShift: 24) ]! ! -!TranslucentColor methodsFor: 'private' stamp: 'jmv 6/18/2017 20:42:05'! - setRed: r green: g blue: b alpha: alphaValue - - self basicSetRed: r green: g blue: b. - self at: 4 put: alphaValue! ! -!TranslucentColor methodsFor: 'queries' stamp: 'jmv 6/18/2017 20:41:26'! - isOpaque - - ^self alpha = 1.0! ! -!TranslucentColor methodsFor: 'queries' stamp: 'jmv 6/18/2017 20:41:54'! - isTransparent - ^ self alpha = 0.0! ! -!TranslucentColor class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:54:35'! - new - ^ self new: 4! ! -!TranslucentColor class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:57:08'! - r: r g: g b: b alpha: alphaValue - "Return a color with the given r, g, and b components in the range [0.0..1.0]." - - ^ self new - setRed: r - green: g - blue: b - alpha: alphaValue! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3110-CallItColorAgain-JuanVuletich-2017Jun19-11h54m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3109] on 19 June 2017 at 12:07:06 pm'! -!Integer methodsFor: 'converting' stamp: 'ar 10/31/1998 23:04' prior: 50348249! - asColorOfDepth: d - "Return a color value representing the receiver as color of the given depth" - ^Color colorFromPixelValue: self depth: d! ! -!InputSensor methodsFor: 'keyboard' stamp: 'jmv 9/2/2016 11:08:09' prior: 50348257! - kbdTest - " - Sensor kbdTest - " - "This test routine will print the unmodified character, its keycode, - and the OR of all its modifier bits, until the character x is typed - -Also useful: - Sensor test - " - | char | - char _ nil. - [ char = $x ] whileFalse: [ - [ self keyboardPressed ] whileFalse. - char _ self keyboard. - Display fill: (5@5 extent: 400@20) fillColor: Color white. - (String streamContents: [ :s | - s - nextPut: $-; - nextPut: char; - nextPut: $-; - space; - print: char numericValue; - space. - self isMouseButton3Pressed ifTrue: [ s nextPutAll: ' mouseButton3/blue/tertiary/halo ' ]. - self isMouseButton2Pressed ifTrue: [ s nextPutAll: ' mouseButton2/yellow/secondary/menu ' ]. - self isMouseButton1Pressed ifTrue: [ s nextPutAll: ' mouseButton1/red/primary ' ]. - self shiftPressed ifTrue: [ s nextPutAll: ' shift ' ]. - self controlKeyPressed ifTrue: [ s nextPutAll: ' control/ctrl ' ]. - (self primMouseButtons anyMask: 32) ifTrue: [ s nextPutAll: ' macOption ' ]. - self commandAltKeyPressed ifTrue: [ s nextPutAll: ' macCommand/winAlt ' ]]) - displayAt: 10 @ 10 ].! ! -!String methodsFor: 'displaying' stamp: 'jmv 5/12/2015 15:52' prior: 50348295! - 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 - " - 'Display' displayOn: Display at: 10@10 - "! ! -!Color methodsFor: 'conversions' stamp: 'bf 4/18/2001 16:25' prior: 50353443! - makeForegroundColor - "Make a foreground color contrasting with me" - ^self luminance >= 0.5 - ifTrue: [Color black] - ifFalse: [Color white]! ! -!Color methodsFor: 'groups of shades' stamp: 'tk 6/18/96' prior: 50353623! - mix: color2 shades: thisMany - "Return an array of thisMany colors from self to color2. Very useful for displaying color based on a variable in your program. " - "Color showColors: (Color red mix: Color green shades: 12)" - - | redInc greenInc blueInc rr gg bb c out | - thisMany = 1 ifTrue: [^ Array with: color2]. - redInc _ color2 red - self red / (thisMany-1). - greenInc _ color2 green - self green / (thisMany-1). - blueInc _ color2 blue - self blue / (thisMany-1). - rr _ self red. gg _ self green. bb _ self blue. - out _ (1 to: thisMany) collect: [:num | - c _ Color r: rr g: gg b: bb. - rr _ rr + redInc. - gg _ gg + greenInc. - bb _ bb + blueInc. - c]. - out at: out size put: color2. "hide roundoff errors" - ^ out -! ! -!Color methodsFor: 'groups of shades' stamp: 'di 10/23/2000 09:45' prior: 50353648! - wheel: thisMany - "An array of thisMany colors around the color wheel starting at self and ending all the way around the hue space just before self. Array is of length thisMany. Very useful for displaying color based on a variable in your program. " - - | sat bri hue step c | - sat _ self saturation. - bri _ self brightness. - hue _ self hue. - step _ 360.0 / (thisMany max: 1). - ^ (1 to: thisMany) collect: [:num | - c _ Color h: hue s: sat v: bri. "hue is taken mod 360" - hue _ hue + step. - c]. -" -(Color wheel: 8) withIndexDo: [:c :i | Display fill: (i*10@20 extent: 10@20) fillColor: c] -"! ! -!Color methodsFor: 'named colors' stamp: 'KenD 1/26/2013 16:33' prior: 50353705! - closestColor - "Answer the closest matching color in the colorNames dictionary" - -" - (Color red lighter lighter) closestColor explore. -" - ^ self closestColorFrom: (Color colorNamesDict)! ! -!Color methodsFor: 'named colors' stamp: 'KenD 1/26/2013 16:36' prior: 50353713! - closestColorAssociation - "Answer this color's closest name->color match." - -" - (Color blue lighter lighter) closestColorAssociation explore. -" - ^ self closestAssocFrom: (Color colorNamesDict)! ! -!Color methodsFor: 'named colors' stamp: 'KenD 1/26/2013 16:36' prior: 50353730! - closestColorName - "Answer the name symbol of the closest matching color in the colorNames dictionary" -" - (Color red lighter lighter) closestColor name. -" - - ^ self closestNameFrom: (Color colorNamesDict)! ! -!Color methodsFor: 'other' stamp: 'KenD 7/18/2015 20:41' prior: 50353747! - colorName - "Return this color's name, or nil if it has no name. Only returns a name if it exactly matches the named color." - - ^(Color colorNamesDict keyAtValue: self ifAbsent: [nil]) -! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:50' prior: 50353994! - adjustBrightness: brightness - "Adjust the relative brightness of this color. (lowest value is 0.005 so that hue information is not lost)" - - ^ Color - h: self hue - s: self saturation - v: (self brightness + brightness min: 1.0 max: 0.005) - alpha: self alpha! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:51' prior: 50354005! - adjustSaturation: saturation brightness: brightness - "Adjust the relative saturation and brightness of this color. (lowest value is 0.005 so that hue information is not lost)" - - ^ Color - h: self hue - s: (self saturation + saturation min: 1.0 max: 0.005) - v: (self brightness + brightness min: 1.0 max: 0.005) - alpha: self alpha! ! -!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 11:55' prior: 50354028! -alphaMixed: proportion with: aColor - "Answer this color mixed with the given color. The proportion, a number - between 0.0 and 1.0, determines what what fraction of the receiver to - use in the mix. For example, 0.9 would yield a color close to the - receiver. This method uses RGB interpolation; HSV interpolation can lead - to surprises. Mixes the alphas (for transparency) also." - - | frac1 frac2 | - frac1 _ proportion asFloat min: 1.0 max: 0.0. - frac2 _ 1.0 - frac1. - ^ Color - r: self red * frac1 + (aColor red * frac2) - g: self green * frac1 + (aColor green * frac2) - b: self blue * frac1 + (aColor blue * frac2) - alpha: self alpha * frac1 + (aColor alpha * frac2)! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/23/2002 01:38' prior: 50354068! - blacker - - ^ self alphaMixed: 0.8333 with: Color black -! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:54' prior: 50354072! - dansDarker - "Return a darker shade of the same color. - An attempt to do better than the current darker method. - (now obsolete, since darker has been changed to do this. -dew)" - ^ Color h: self hue s: self saturation - v: (self brightness - 0.16 max: 0.0)! ! -!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 12:00' prior: 50354098! - mixed: proportion with: aColor - "Mix with another color and do not preserve transpareny. Only use this for extracting the RGB value and mixing it. All other callers should use instead: - aColor alphaMixed: proportion with: anotherColor - " - - | frac1 frac2 | - frac1 _ proportion asFloat min: 1.0 max: 0.0. - frac2 _ 1.0 - frac1. - ^ Color - r: self red * frac1 + (aColor red * frac2) - g: self green * frac1 + (aColor green * frac2) - b: self blue * frac1 + (aColor blue * frac2)! ! -!Color methodsFor: 'transformations' stamp: 'dew 1/19/2002 01:29' prior: 50354116! - muchDarker - - ^ self alphaMixed: 0.5 with: Color black -! ! -!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 12:07' prior: 50354120! - muchLighter - - ^ self alphaMixed: 0.233 with: Color white -! ! -!Color methodsFor: 'transformations' stamp: 'ar 6/19/1999 00:36' prior: 50354124! - negated - "Return an RGB inverted color" - ^Color - r: 1.0 - self red - g: 1.0 - self green - b: 1.0 - self blue! ! -!Color methodsFor: 'transformations' stamp: 'jmv 9/10/2009 18:41' prior: 50354145! - quiteBlacker - - ^ self alphaMixed: 0.8 with: Color black -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 9/10/2009 18:44' prior: 50354149! - quiteWhiter - - ^ self alphaMixed: 0.6 with: Color white! ! -!Color methodsFor: 'transformations' stamp: 'dew 1/19/2002 01:25' prior: 50354162! - slightlyWhiter - - ^ self alphaMixed: 0.85 with: Color white -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 8/23/2009 23:24' prior: 50354179! - veryMuchDarker - - ^ self alphaMixed: 0.25 with: Color black -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 7/28/2016 15:43:04' prior: 50354184! - veryMuchLighter - - ^ self alphaMixed: 0.07 with: Color white! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/23/2002 01:38' prior: 50354189! - whiter - - ^ self alphaMixed: 0.8333 with: Color white -! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/2/2016 15:04' prior: 50354382! - colorFromPixelValue: p depth: d - "Convert a pixel value for the given display depth into a color." - "Details: For depths of 8 or less, the pixel value is simply looked up in a table. For greater depths, the color components are extracted and converted into a color." - "Warning: In BitBlt, a pixel with pixelValue = 0 is transparent. - Squeak usually assumes that r=g=b=0 => transparent. But this is false if we have alpha (opacity). - A color with r=g=b=0 and opacity = 255 is BLACK, not TRANSPARENT. - Squeak also answers darkest possible blue when asked for black. Again, this is not needed in 32 bits (with alpha). It is also not really needed for 16 bits as we have an extra, unused bit: 16r8000 is not zero, but rgb=0, and hence, black. - The real rule is that pixelValue=0 means transparent. - And that darkest blue must be used instead of black, but only for depths >8 and < 16 (no indexed colors, no alpha) - This method is updated to reflect that." - - | r g b alpha | - - d = 1 ifTrue: [^ self indexedColors at: (p bitAnd: 16r01) + 1]. - - "For the rest of the depths, pixelValue = 0 means transparent, and darkest blue is considered to be black." - p = 0 ifTrue: [ ^Color transparent ]. - - d = 8 ifTrue: [^ self indexedColors at: (p bitAnd: 16rFF) + 1]. - d = 4 ifTrue: [^ self indexedColors at: (p bitAnd: 16r0F) + 1]. - d = 2 ifTrue: [^ self indexedColors at: (p bitAnd: 16r03) + 1]. - - d = 32 ifTrue: [ - "eight bits per component; 8 bits of alpha" - alpha _ p bitShift: -24. - alpha = 0 ifTrue: [ ^Color transparent ]. - r _ (p bitShift: -16) bitAnd: 16rFF. - g _ (p bitShift: -8) bitAnd: 16rFF. - b _ p bitAnd: 16rFF. - ^alpha < 255 - ifTrue: [ (Color r: r g: g b: b range: 255) alpha: alpha asFloat / 255.0 ] - ifFalse: [ Color r: r g: g b: b range: 255 ]]. - - d = 16 ifTrue: [ - "five bits per component. The most significant bit, unused, allows having real black, without p being zero" - r _ (p bitShift: -10) bitAnd: 16r1F. - g _ (p bitShift: -5) bitAnd: 16r1F. - b _ p bitAnd: 16r1F. - ^ Color r: r g: g b: b range: 31]. - - d = 15 ifTrue: [ - "five bits per component" - r _ (p bitShift: -10) bitAnd: 16r1F. - g _ (p bitShift: -5) bitAnd: 16r1F. - b _ p bitAnd: 16r1F. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Color black ]. - ^ Color r: r g: g b: b range: 31]. - - d = 12 ifTrue: [ - "four bits per component" - r _ (p bitShift: -8) bitAnd: 16rF. - g _ (p bitShift: -4) bitAnd: 16rF. - b _ p bitAnd: 16rF. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Color black ]. - ^ Color r: r g: g b: b range: 15]. - - d = 9 ifTrue: [ - "three bits per component" - r _ (p bitShift: -6) bitAnd: 16r7. - g _ (p bitShift: -3) bitAnd: 16r7. - b _ p bitAnd: 16r7. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Color black ]. - ^ Color r: r g: g b: b range: 7]. - - self error: 'unknown pixel depth: ', d printString! ! -!Color class methodsFor: 'class initialization' stamp: '' prior: 50354713! - initializeIndexedColors - "Build an array of colors corresponding to the fixed colormap used - for display depths of 1, 2, 4, or 8 bits." - "Color initializeIndexedColors" - - | a index grayVal | - a _ Array new: 256. - - "1-bit colors (monochrome)" - a at: 1 put: (Color r: 1.0 g: 1.0 b: 1.0). "white or transparent" - a at: 2 put: (Color r: 0.0 g: 0.0 b: 0.0). "black" - - "additional colors for 2-bit color" - a at: 3 put: (Color r: 1.0 g: 1.0 b: 1.0). "opaque white" - a at: 4 put: (Color r: 0.5 g: 0.5 b: 0.5). "1/2 gray" - - "additional colors for 4-bit color" - a at: 5 put: (Color r: 1.0 g: 0.0 b: 0.0). "red" - a at: 6 put: (Color r: 0.0 g: 1.0 b: 0.0). "green" - a at: 7 put: (Color r: 0.0 g: 0.0 b: 1.0). "blue" - a at: 8 put: (Color r: 0.0 g: 1.0 b: 1.0). "cyan" - a at: 9 put: (Color r: 1.0 g: 1.0 b: 0.0). "yellow" - a at: 10 put: (Color r: 1.0 g: 0.0 b: 1.0). "magenta" - - a at: 11 put: (Color r: 0.125 g: 0.125 b: 0.125). "1/8 gray" - a at: 12 put: (Color r: 0.25 g: 0.25 b: 0.25). "2/8 gray" - a at: 13 put: (Color r: 0.375 g: 0.375 b: 0.375). "3/8 gray" - a at: 14 put: (Color r: 0.625 g: 0.625 b: 0.625). "5/8 gray" - a at: 15 put: (Color r: 0.75 g: 0.75 b: 0.75). "6/8 gray" - a at: 16 put: (Color r: 0.875 g: 0.875 b: 0.875). "7/8 gray" - - "additional colors for 8-bit color" - "24 more shades of gray (1/32 increments but not repeating 1/8 increments)" - index _ 17. - 1 to: 31 do: [:v | - (v \\ 4) = 0 ifFalse: [ - grayVal _ v / 32.0. - a at: index put: (Color r: grayVal g: grayVal b: grayVal). - index _ index + 1]]. - - "The remainder of color table defines a color cube with six steps - for each primary color. Note that the corners of this cube repeat - previous colors, but this simplifies the mapping between RGB colors - and color map indices. This color cube spans indices 40 through 255 - (indices 41-256 in this 1-based array)." - 0 to: 5 do: [:r | - 0 to: 5 do: [:g | - 0 to: 5 do: [:b | - index _ 41 + ((36 * r) + (6 * b) + g). - index > 256 ifTrue: [ - self error: 'index out of range in color table compuation']. - a at: index put: (Color r: r g: g b: b range: 5)]]]. - - IndexedColors _ a. -! ! -!Color class methodsFor: 'examples' stamp: 'jmv 8/17/2012 18:48' prior: 50354782! - colorRampForDepth: depth extent: aPoint - "Returns a form of the given size showing R, G, B, and gray ramps for the given depth. Useful for testing color conversions between different depths." - "(Color colorRampForDepth: Display depth extent: 256@80) display" - "(Color colorRampForDepth: 32 extent: 256@80) displayOn: Display at: 0@0 rule: Form paint" - - | f dx dy r | - f _ Form extent: aPoint depth: depth. - dx _ aPoint x // 256. - dy _ aPoint y // 4. - 0 to: 255 do: [:i | - r _ (dx * i)@0 extent: dx@dy. - f fill: r fillColor: (Color r: i g: 0 b: 0 range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Color r: 0 g: i b: 0 range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Color r: 0 g: 0 b: i range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Color r: i g: i b: i range: 255)]. - ^ f -! ! -!Color class methodsFor: 'examples' stamp: '' prior: 50354886! - showColorCube - "Show a 12x12x12 color cube." - "Color showColorCube" - - 0 to: 11 do: [:r | - 0 to: 11 do: [:g | - 0 to: 11 do: [:b | - Display fill: (((r*60) + (b*5)) @ (g*5) extent: 5@5) - fillColor: (Color r: r g: g b: b range: 11)]]]. -! ! -!Color class methodsFor: 'examples' stamp: '' prior: 50354906! - showHSVPalettes - "Shows a palette of hues, varying the saturation and brightness for each one. Best results are with depths 16 and 32." - "Color showHSVPalettes" - - | left top c | - left _ top _ 0. - 0 to: 179 by: 15 do: [:h | - 0 to: 10 do: [:s | - left _ (h * 4) + (s * 4). - 0 to: 10 do: [:v | - c _ Color h: h s: s asFloat / 10.0 v: v asFloat / 10.0. - top _ (v * 4). - Display fill: (left@top extent: 4@4) fillColor: c. - - c _ Color h: h + 180 s: s asFloat / 10.0 v: v asFloat / 10.0. - top _ (v * 4) + 50. - Display fill: (left@top extent: 4@4) fillColor: c]]]. -! ! -!Color class methodsFor: 'examples' stamp: '' prior: 50354943! - wheel: thisMany - "Return a collection of thisMany colors evenly spaced around the color wheel." - "Color showColors: (Color wheel: 12)" - - ^ Color wheel: thisMany saturation: 0.9 brightness: 0.7 -! ! -!Color class methodsFor: 'examples' stamp: '' prior: 50354951! - wheel: thisMany saturation: s brightness: v - "Return a collection of thisMany colors evenly spaced around the color wheel, all of the given saturation and brightness." - "Color showColors: (Color wheel: 12 saturation: 0.4 brightness: 1.0)" - "Color showColors: (Color wheel: 12 saturation: 0.8 brightness: 0.5)" - - ^ (Color h: 0.0 s: s v: v) wheel: thisMany -! ! -!Color class methodsFor: 'colormaps' stamp: '' prior: 50355351! - colorMapIfNeededFrom: sourceDepth to: destDepth - "Return a colormap for mapping between the given depths, or nil if no colormap is needed." - "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" - - sourceDepth = destDepth ifTrue: [^ nil]. "not needed if depths are the same" - - (sourceDepth >= 16) & (destDepth >= 16) ifTrue: [ - "mapping is done in BitBlt by zero-filling or truncating each color component" - ^ nil]. - - ^ Color cachedColormapFrom: sourceDepth to: destDepth -! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 5/12/2016 15:56' prior: 50355466! - computeColormapFromGray8bppForDepth: destDepth - "Return a colormap for displaying a GrayForm at the given depth" - - | newMap | - newMap _ Bitmap new: 256. - 1 to: 256 do: [ :i | - newMap - at: i - put: ((Color gray: (i-1) asFloat / 255.0) pixelValueForDepth: destDepth)]. - ^ newMap! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 4/17/2015 15:05' prior: 50355477! - computeIndexedColorConvertingMap: targetColor from: sourceDepth to: destDepth - | map | - - map _ (self indexedColors copyFrom: 1 to: (1 bitShift: sourceDepth)) collect: [ :cc | | f c | - f _ 1.0 - (cc red + cc green + cc blue / 3.0 ). - c _ targetColor - ifNotNil: [ - destDepth = 32 - ifTrue: [ targetColor * f alpha: f] - ifFalse: [ targetColor alphaMixed: f*1.5 with: Color white ]] - ifNil: [ cc ]. - destDepth = 32 - ifTrue: [ c pixelValueForDepth: destDepth] - ifFalse: [ - f = 0.0 - ifTrue: [ 0 ] - ifFalse: [ c pixelValueForDepth: destDepth ]]]. - map _ map as: Bitmap. - ^map! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 12/26/2011 13:49' prior: 50355499! - computeRGBColorConvertingMap: targetColor to: destDepth keepSubPixelAA: keepSubPix - "Builds a colormap intended to convert from subpixelAA black values to targetColor values. - keepSubPix - ifTrue: [ Answer colors that also include subpixelAA ] - ifFalse: [ - Take fullpixel luminance level. Apply it to targetColor. - I.e. answer colors with NO subpixelAA ]" - - | mask map c bitsPerColor r g b f v | - - destDepth > 8 - ifTrue: [bitsPerColor _ 5] "retain maximum color resolution" - ifFalse: [bitsPerColor _ 4]. - "Usually a bit less is enough, but make it configurable" - bitsPerColor _ bitsPerColor min: Preferences aaFontsColormapDepth. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - r _ (i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask. - g _ (i bitShift: 0 - bitsPerColor) bitAnd: mask. - b _ (i bitShift: 0) bitAnd: mask. - f _ 1.0 - (r + g + b / 3.0 / mask). - c _ targetColor - ifNotNil: [ - (keepSubPix and: [destDepth > 8]) ifTrue: [ - Color - r: 1.0 - (r asFloat/mask) * targetColor red - g: 1.0 - (g asFloat/mask) * targetColor green - b: 1.0 - (b asFloat/mask) * targetColor blue - alpha: f * targetColor alpha "alpha will be ignored below, in #pixelValueForDepth: if destDepth ~= 32" ] - ifFalse: [ - destDepth = 32 - ifTrue: [ targetColor * f alpha: f * targetColor alpha ] - ifFalse: [ targetColor alphaMixed: f*1.5 with: Color white ]]] - ifNil: [ Color r: r g: g b: b range: mask]. "This is currently used only to keep some SubPixelAA on destDepth = 8, using a single pass of rule 25" - v _ destDepth = 32 - ifTrue: [ c pixelValueForDepth: destDepth] - ifFalse: [ - f < 0.1 - ifTrue: [ 0 ] - ifFalse: [ c pixelValueForDepth: destDepth ]]. - map at: i + 1 put: v ]. - ^ map! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 1/30/2011 23:10' prior: 50355559! - computeRGBColormapFor: destDepth bitsPerColor: bitsPerColor - "Compute a colorMap for translating from 16-bit or 32-bit RGB color to the given depth, using the given number of of bits per color component." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | mask map c | - (#(3 4 5) includes: bitsPerColor) - ifFalse: [self error: 'BitBlt only supports 3, 4, or 5 bits per color component']. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - c _ Color - r: ((i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask) - g: ((i bitShift: 0 - bitsPerColor) bitAnd: mask) - b: ((i bitShift: 0) bitAnd: mask) - range: mask. - map at: i + 1 put: (c pixelValueForDepth: destDepth)]. - - map at: 1 put: (Color transparent pixelWordForDepth: destDepth). "zero always transparent" - ^ map -! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 5/12/2016 15:57' prior: 50355601! - computeRGBColormapForGray8 - "Compute a colorMap for translating from 16-bit or 32-bit RGB color to 8bpp grays, using the default number of of bits per color component." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | bitsPerColor mask map c | - bitsPerColor _ 5. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - c _ Color - r: ((i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask) - g: ((i bitShift: 0 - bitsPerColor) bitAnd: mask) - b: ((i bitShift: 0) bitAnd: mask) - range: mask. - map at: i + 1 put: (c luminance * 255) rounded]. - - ^ map! ! -!Color class methodsFor: 'color from user' stamp: 'jmv 3/1/2010 15:13' prior: 50355667! - colorPaletteForDepth: depth extent: chartExtent - "Display a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." - "Note: It is slow to build this palette, so it should be cached for quick access." - "(Color colorPaletteForDepth: 16 extent: 190@60) display" - - | basicHue x y startHue palette transHt vSteps transCaption grayWidth hSteps | - palette _ Form extent: chartExtent depth: depth. - transCaption _ - (Form extent: 34@9 depth: 1 - fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0) - offset: 0@0). - transHt _ transCaption height. - palette fillWhite: (0@0 extent: palette width@transHt). - palette fillBlack: (0@transHt extent: palette width@1). - transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0). - grayWidth _ 10. - startHue _ 338.0. - vSteps _ palette height - transHt // 2. - hSteps _ palette width - grayWidth. - x _ 0. - startHue to: startHue + 360.0 by: 360.0/hSteps do: [ :h | - basicHue _ Color h: h asFloat s: 1.0 v: 1.0. - y _ transHt+1. - 0 to: vSteps do: [ :n | | c | - c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Color white. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - 1 to: vSteps do: [ :n | | c | - c _ Color black mixed: (n asFloat / vSteps asFloat) with: basicHue. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - x _ x + 1]. - y _ transHt + 1. - 1 to: vSteps * 2 do: [ :n | | c | - c _ Color black mixed: (n asFloat / (vSteps*2) asFloat) with: Color white. - palette fill: (x@y extent: 10@1) fillColor: c. - y _ y + 1]. - ^ palette -! ! -!Color class methodsFor: 'color from user' stamp: 'jmv 7/27/2009 11:32' prior: 50355724! - colorTest: depth extent: chartExtent colorMapper: colorMapper - "Create a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." - "Note: It is slow to build this palette, so it should be cached for quick access." - "(Color colorTest: 32 extent: 570@180 colorMapper: [:c | c]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 7) asInteger / 7 - g: (c green * 7) asInteger / 7 - b: (c blue * 3) asInteger / 3]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 5) asInteger / 5 - g: (c green * 5) asInteger / 5 - b: (c blue * 5) asInteger / 5]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 15) asInteger / 15 - g: (c green * 15) asInteger / 15 - b: (c blue * 15) asInteger / 15]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 31) asInteger / 31 - g: (c green * 31) asInteger / 31 - b: (c blue * 31) asInteger / 31]) display" - - | basicHue x y c startHue palette transHt vSteps transCaption grayWidth hSteps | - palette _ Form extent: chartExtent depth: depth. - transCaption _ - (Form extent: 34@9 depth: 1 - fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0) - offset: 0@0). - transHt _ transCaption height. - palette fillWhite: (0@0 extent: palette width@transHt). - palette fillBlack: (0@transHt extent: palette width@1). - transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0). - grayWidth _ 10. - startHue _ 338.0. - vSteps _ palette height - transHt // 2. - hSteps _ palette width - grayWidth. - x _ 0. - startHue to: startHue + 360.0 by: 360.0/hSteps do: [:h | - basicHue _ Color h: h asFloat s: 1.0 v: 1.0. - y _ transHt+1. - 0 to: vSteps do: [:n | - c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Color white. - c _ colorMapper value: c. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - 1 to: vSteps do: [:n | - c _ Color black mixed: (n asFloat / vSteps asFloat) with: basicHue. - c _ colorMapper value: c. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - x _ x + 1]. - y _ transHt + 1. - 1 to: vSteps * 2 do: [:n | - c _ Color black mixed: (n asFloat / (vSteps*2) asFloat) with: Color white. - c _ colorMapper value: c. - palette fill: (x@y extent: 10@1) fillColor: c. - y _ y + 1]. - ^ palette -! ! -!Color class methodsFor: 'color name lookup' stamp: 'KenD 1/28/2013 20:34' prior: 50355812! - defaultColorNamesDictionary - "Answer a amall but useful name->color dictionary" - - | defaultDict | - "Meld most used xkcd colors into traditional colors." - defaultDict := (self traditionalColorNamesDictionary addAll: - self xkcdFirst48ColorNamesDictionary; - yourself). - - "Override traditional names existing in extended XKCD naming" - defaultDict at: #lightYellow put: (Color r: 1.0 g: 0.996 b: 0.478). - defaultDict at: #lightOrange put: (Color r: 0.992 g: 0.667 b: 0.283). - defaultDict at: #lightCyan put: (Color r: 0.674 g: 1.0 b: 0.988). - defaultDict at: #lightRed put: (Color r: 1.0 g: 0.279 b: 0.298). - defaultDict at: #lightMagenta put: (Color r: 0.98 g: 0.372 b: 0.969). - - ^defaultDict! ! -!Color class methodsFor: 'color name lookup' stamp: 'KenD 2/1/2013 14:39' prior: 50355838! - doesNotUnderstand: aMessage - "Some code takes - Color colorNames - and does - Color perform: aColorname. - - Make this work." - - ^(Color colorNamesDict) - at: (aMessage selector) - ifAbsent: [super doesNotUnderstand: aMessage]! ! -!Color class methodsFor: 'color name lookup' stamp: 'KenD 7/25/2014 21:22' prior: 50355856! - setColorNamesDict: aNameColorDictionary - "Answer the current dictionary of name->color associations." - - "Note: This is a non-standard name because this is a non-standard action!! - Do this if you really, really know what you are doing." - - "Some Colors are required for proper system operation" - Color defaultColorNamesDictionary keysAndValuesDo: [ :colorName :colorValue | - aNameColorDictionary at: colorName ifAbsentPut: colorValue - ]. - - ColorNamesDict := aNameColorDictionary! ! -!Color class methodsFor: 'color name lookup' stamp: 'sqr 10/21/2016 12:44:48' prior: 50355874! - traditionalColorNamesDictionary - "Answer a dictionary of Squeak traditional name->color associations.." - - | nameDict | - nameDict _ Dictionary new. - nameDict at: #black put: (Color r: 0 g: 0 b: 0). - nameDict at: #veryVeryDarkGray put: (Color r: 0.125 g: 0.125 b: 0.125). - nameDict at: #veryDarkGray put: (Color r: 0.25 g: 0.25 b: 0.25). - nameDict at: #darkGray put: (Color r: 0.375 g: 0.375 b: 0.375). - nameDict at: #gray put: (Color r: 0.5 g: 0.5 b: 0.5). - nameDict at: #lightGray put: (Color r: 0.625 g: 0.625 b: 0.625). - nameDict at: #veryLightGray put: (Color r: 0.75 g: 0.75 b: 0.75). - nameDict at: #veryVeryLightGray put: (Color r: 0.875 g: 0.875 b: 0.875). - nameDict at: #white put: (Color r: 1.0 g: 1.0 b: 1.0). - nameDict at: #red put: (Color r: 1.0 g: 0 b: 0). - nameDict at: #yellow put: (Color r: 1.0 g: 1.0 b: 0). - nameDict at: #green put: (Color r: 0 g: 1.0 b: 0). - nameDict at: #cyan put: (Color r: 0 g: 1.0 b: 1.0). - nameDict at: #blue put: (Color r: 0 g: 0 b: 1.0). - nameDict at: #magenta put: (Color r: 1.0 g: 0 b: 1.0). - nameDict at: #brown put: (Color r: 0.6 g: 0.2 b: 0). - nameDict at: #orange put: (Color r: 1.0 g: 0.6 b: 0). - nameDict at: #lightRed put: (Color r: 1.0 g: 0.8 b: 0.8). - nameDict at: #lightYellow put: (Color r: 1.0 g: 1.0 b: 0.8). - nameDict at: #lightGreen put: (Color r: 0.8 g: 1.0 b: 0.6). - nameDict at: #lightCyan put: (Color r: 0.4 g: 1.0 b: 1.0). - nameDict at: #lightBlue put: (Color r: 0.8 g: 1.0 b: 1.0). - nameDict at: #lightMagenta put: (Color r: 1.0 g: 0.8 b: 1.0). - nameDict at: #lightBrown put: (Color r: 1.0 g: 0.6 b: 0.2). - nameDict at: #lightOrange put: (Color r: 1.0 g: 0.8 b: 0.4). - nameDict at: #transparent put: (TranslucentColor r: 0.0 g: 0.0 b: 0.0 alpha: 0.0). - - ^nameDict -! ! -!Color class methodsFor: 'color name lookup' stamp: 'jmv 6/30/2014 15:22' prior: 50355931! - xkcdFirst48ColorNamesDictionary - "XKCD color names are based on a survey oc colors people call by the same name. - http://blog.xkcd.com/2010/05/03/color-survey-results/" - - "Answer a dictionary of the most agreed upon first 48 xkcd colors" -" - Color xkcdFirst48ColorNamesDictionary explore. -" - | xkcdDict | - xkcdDict := Dictionary new - at: #lightPink put: (Color fromString: '#ffd1df') ; - at: #mustard put: (Color fromString: '#ceb301') ; - at: #indigo put: (Color fromString: '#380282') ; - at: #lime put: (Color fromString: '#aaff32') ; - at: #seaGreen put: (Color fromString: '#53fca1') ; - at: #periwinkle put: (Color fromString: '#8e82fe') ; - at: #darkPink put: (Color fromString: '#cb416b') ; - at: #oliveGreen put: (Color fromString: '#677a04') ; - at: #peach put: (Color fromString: '#ffb07c') ; - at: #paleGreen put: (Color fromString: '#c7fdb5') ; - at: #lightBrown put: (Color fromString: '#ad8150') ; - at: #hotPink put: (Color fromString: '#ff028d') ; - at: #black put: (Color fromString: '#000000') ; - at: #lilac put: (Color fromString: '#cea2fd') ; - at: #navyBlue put: (Color fromString: '#001146') ; - at: #royalBlue put: (Color fromString: '#0504aa') ; - at: #beige put: (Color fromString: '#e6daa6') ; - at: #salmon put: (Color fromString: '#ff796c') ; - at: #olive put: (Color fromString: '#6e750e') ; - at: #maroon put: (Color fromString: '#650021') ; - at: #brightGreen put: (Color fromString: '#01ff07') ; - at: #darkPurple put: (Color fromString: '#35063e') ; - at: #mauve put: (Color fromString: '#ae7181') ; - at: #forestGreen put: (Color fromString: '#06470c') ; - at: #aqua put: (Color fromString: '#13eac9') ; - at: #cyan put: (Color fromString: '#00ffff') ; - at: #tan put: (Color fromString: '#d1b26f') ; - at: #darkBlue put: (Color fromString: '#00035b') ; - at: #lavender put: (Color fromString: '#c79fef') ; - at: #turquoise put: (Color fromString: '#06c2ac') ; - at: #darkGreen put: (Color fromString: '#033500') ; - at: #violet put: (Color fromString: '#9a0eea') ; - at: #lightPurple put: (Color fromString: '#bf77f6') ; - at: #limeGreen put: (Color fromString: '#89fe05') ; - at: #grey put: (Color fromString: '#929591') ; - at: #skyBlue put: (Color fromString: '#75bbfd') ; - at: #yellow put: (Color fromString: '#ffff14') ; - at: #magenta put: (Color fromString: '#c20078') ; - at: #lightGreen put: (Color fromString: '#96f97b') ; - at: #orange put: (Color fromString: '#f97306') ; - at: #teal put: (Color fromString: '#029386') ; - at: #lightBlue put: (Color fromString: '#95d0fc') ; - at: #red put: (Color fromString: '#e50000') ; - at: #brown put: (Color fromString: '#653700') ; - at: #pink put: (Color fromString: '#ff81c0') ; - at: #blue put: (Color fromString: '#0343df') ; - at: #green put: (Color fromString: '#15b01a') ; - at: #purple put: (Color fromString: '#7e1e9c') ; - yourself. - - ^xkcdDict - -! ! -!SystemDictionary methodsFor: 'shrinking' stamp: 'jmv 4/25/2016 15:31' prior: 50348307! - reduceCuis - " - Smalltalk reduceCuis - " - | keep n unused newDicts oldDicts | - - self nominallyUnsent: #reduceCuis. - - "Remove icons" - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - PasteUpMorph allInstancesDo: [ :w | - w backgroundImageData: nil. - w submorphsDo: [ :a | a delete ]]. - Preferences useNoIcons. - Theme current initialize. - Theme content: nil. - Color shutDown. - BitBltCanvas releaseClassCachedState. - - Transcript clear. - Clipboard default initialize. - - - "Remove some methods, even if they have senders." -" ColorPickerMorph class removeSelector: #buildEyedropperIcon." - Theme removeSelector: #miscellaneousIcons. - Utilities removeSelector: #vmStatisticsReportString. - SystemDictionary removeSelector: #recreateSpecialObjectsArray. - - StrikeFont removeMostFonts. - StrikeFont saveSpace. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - - keep := OrderedCollection new. - keep addAll: #(SpaceTally). - AppLauncher appGlobalName ifNotNil: [ :any | - keep add: any ]. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - [ - #hereWeGo print. - unused do: [:c | - c print. - (Smalltalk at: c) removeFromSystem]. - n := Smalltalk removeAllUnSentMessages. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - n > 0 or: [ - unused notEmpty ]] whileTrue. - ChangeSet zapAllChangeSets. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - Symbol rehash. - - "Shrink method dictionaries." - Smalltalk garbageCollect. - oldDicts _ MethodDictionary allInstances. - newDicts _ Array new: oldDicts size. - oldDicts withIndexDo: [:d :index | - newDicts at: index put: d rehashWithoutBecome ]. - oldDicts elementsExchangeIdentityWith: newDicts. - oldDicts _ newDicts _ nil. - - SmalltalkCompleter initialize . - - "Sanity checks" -" Undeclared - Smalltalk cleanOutUndeclared - Smalltalk browseUndeclaredReferences - Smalltalk obsoleteClasses - Smalltalk obsoleteBehaviors - Smalltalk browseObsoleteMethodReferences - SmalltalkImage current fixObsoleteReferences - Smalltalk browseAllUnimplementedCalls"! ! -!Transcripter methodsFor: 'accessing' stamp: 'jmv 7/28/2015 08:26' prior: 50348378! - 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]. - textComposition - setModel: (TextModel withText: c asText); - extentForComposing: frame width-8 @9999. - textComposition composeAll. - d _ textComposition usedHeight - frame height. - d > 0 ifTrue: [ - "Scroll up to keep all contents visible" - cb _ textComposition characterBlockAtPoint: - 0@0 + (0@(d+AbstractFont default height)). - self on: (c copyFrom: cb stringIndex to: c size). - readLimit _ position _ collection size. - ^ self endEntry]. - Display fill: (frame insetBy: -2) fillColor: self black; - fill: frame fillColor: self white. - Display getCanvas - textComposition: textComposition - bounds: (4@4 + frame topLeft extent: Display extent) - color: Color black - selectionColor: Color blue. - DisplayScreen screenUpdateRequired: nil! ! -!Transcripter methodsFor: 'private' stamp: 'di 8/14/97 12:12' prior: 50348412! - black - Display depth = 1 ifTrue: [^ Bitmap with: 16rFFFFFFFF "Works without color support"]. - ^ Color black! ! -!Transcripter methodsFor: 'private' stamp: 'di 8/14/97 12:12' prior: 50348418! - white - Display depth = 1 ifTrue: [^ Bitmap with: 0 "Works without color support"]. - ^ Color white! ! -!DataStream class methodsFor: 'as yet unclassified' stamp: '' prior: 50348424! - example - "An example and test of DataStream/ReferenceStream. - 11/19/92 jhm: Use self testWith:." - "DataStream example" - "ReferenceStream example" - | input sharedPoint | - - "Construct the test data." - input _ Array new: 9. - input at: 1 put: nil. - input at: 2 put: true. - input at: 3 put: (Form extent: 63 @ 50 depth: 8). - (input at: 3) fillWithColor: Color lightBlue. - input at: 4 put: #(3 3.0 'three'). - input at: 5 put: false. - input at: 6 put: 1024 @ -2048. - input at: 7 put: #x. - input at: 8 put: (Array with: (sharedPoint _ 0 @ -30000)). - input at: 9 put: sharedPoint. - - "Write it out, read it back, and return it for inspection." - ^ self testWith: input! ! -!ReferenceStream class methodsFor: 'as yet unclassified' stamp: '' prior: 50348450! - example2 -"Here is the way to use DataStream and ReferenceStream: - rr _ ReferenceStream fileNamed: ''test.obj''. - rr nextPut: . - rr close. - -To get it back: - rr _ ReferenceStream fileNamed: ''test.obj''. - _ rr next. - rr close. -" -"An example and test of DataStream/ReferenceStream. - 11/19/92 jhm: Use self testWith:." - "ReferenceStream example2" - | input sharedPoint | - - "Construct the test data." - input _ Array new: 9. - input at: 1 put: nil. - input at: 2 put: true. - input at: 3 put: false. - input at: 4 put: #(-4 -4.0 'four' four). - input at: 5 put: (Form extent: 63 @ 50 depth: 8). - (input at: 5) fillWithColor: Color lightOrange. - input at: 6 put: 1024 @ -2048. - input at: 7 put: input. "a cycle" - input at: 8 put: (Array with: (sharedPoint _ 0 @ -30000)). - input at: 9 put: sharedPoint. - - "Write it out, read it back, and return it for inspection." - ^ self testWith: input -! ! -!TextEditor methodsFor: 'attributes' stamp: 'jmv 12/12/2014 15:53' prior: 50348482! - offerColorMenu - "Present a menu of available colors, and if one is chosen, apply it to the current selection." - "This is a user command, and generates undo" - - | attribute colors index thisSel | - thisSel _ self selection. - colors _ #(#black #magenta #red #yellow #green #blue #cyan #white ). - index _ (PopUpMenu - labelArray: colors , #('choose color...' ) - lines: (Array with: colors size + 1)) startUpMenu. - index = 0 ifTrue: [ ^ true ]. - index <= colors size - ifTrue: [ attribute _ TextColor color: (Color perform: (colors at: index)) ] - ifFalse: [ - index _ index - colors size - 1. - "Re-number!!!!!!" - index = 0 ifTrue: [ attribute _ self chooseColor ]. - thisSel ifNil: [ ^ true ]]. - attribute ifNotNil: [ self applyAttribute: attribute ]. - ^ true.! ! -!TextAction class methodsFor: 'as yet unclassified' stamp: 'jmv 4/19/2015 09:38' prior: 50348510! -textActionColor - ^Color r: 0.4 g: 0 b: 1.0! ! -!TextColor methodsFor: 'testing' stamp: 'jmv 1/21/2011 11:33' prior: 50348514! - isSet - "Do not include Color black, as it is the default color." - ^color ~= Color black! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 50348520! - black - ^ self new color: Color black! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 50348524! - blue - ^ self new color: Color blue! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 50348528! - cyan - ^ self new color: Color cyan! ! -!TextColor class methodsFor: 'constants' stamp: 'ajh 9/10/2002 02:26' prior: 50348532! - gray - ^ self new color: Color gray! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 50348536! - green - ^ self new color: Color green! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 50348540! - magenta - ^ self new color: Color magenta! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 50348544! - red - ^ self new color: Color red! ! -!TextColor class methodsFor: 'constants' stamp: 'sma 3/24/2000 10:50' prior: 50348548! - white - ^ self new color: Color white! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 50348552! - yellow - ^ self new color: Color yellow! ! -!Preferences class methodsFor: 'halos' stamp: 'jmv 4/20/2015 16:17' prior: 50348557! - installHaloSpecsFromArray: anArray - - | aColor | - ^ self parameters at: #HaloSpecs put: (anArray collect: [ :each | - aColor _ Color. - each fourth do: [ :sel | aColor _ aColor perform: sel]. - HaloSpec new - horizontalPlacement: each second - verticalPlacement: each third - color: aColor - iconSymbol: each fifth - addHandleSelector: each first - hoverHelp: each sixth])! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 9/19/2016 20:45:55' prior: 50348573! - displayOn: aForm in: aRectangle - " - Transcript displayOn: Display - " - | font count i string x y fh f canvas innerR | - aForm fill: aRectangle fillColor: Color white. - font _ AbstractFont default. - - innerR _ aRectangle insetBy: self padding. - fh _ font height. - count _ innerR height // fh-1. - x _ innerR left. - y _ innerR top. - f _ firstIndex-1. - firstIndex > lastIndex ifTrue: [ f _ f - self maxEntries ]. - i _ (lastIndex - count max: f) \\ self maxEntries + 1. - canvas _ aForm getCanvas. - canvas newClipRect: innerR. - [ - string _ entries at: i. - canvas drawString: string at: x@y font: font color: Color veryDarkGray. - y _ y + fh. - i = lastIndex - ] whileFalse: [ i _ i \\ self maxEntries + 1 ]. - - string _ unfinishedEntry contents. - canvas drawString: string at: x@y font: font color: Color veryDarkGray! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 9/19/2016 20:53:35' prior: 50348602! - displayUnfinishedEntryOn: aForm - - | font count string x y fh canvas r innerR | - innerR _ bounds insetBy: self padding. - lastDisplayPosition < innerR right ifTrue: [ - font _ AbstractFont default. - fh _ font height. - count _ innerR height // fh-1. - x _ innerR left. - string _ unfinishedEntry contents. - y _ ((lastIndex - firstIndex \\ self maxEntries) min: count-1) + 1 * font height + innerR top. - canvas _ aForm getCanvas. - r _ innerR left: lastDisplayPosition. - canvas newClipRect: r. - (canvas drawString: string at: x@y font: font color: Color veryDarkGray) ifNotNil: [ :lastPoint | - lastDisplayPosition _ lastPoint x. - ^r ]]. - ^nil! ! -!Form methodsFor: 'analyzing' stamp: 'ar 5/17/2001 15:40' prior: 50348625! - dominantColor - | tally max maxi | - self depth > 16 ifTrue: - [^(self asFormOfDepth: 16) dominantColor]. - tally _ self tallyPixelValues. - max _ maxi _ 0. - tally withIndexDo: [:n :i | n > max ifTrue: [max _ n. maxi _ i]]. - ^ Color colorFromPixelValue: maxi - 1 depth: self depth! ! -!Form methodsFor: 'bordering' stamp: 'jmv 1/22/2015 10:22' prior: 50348637! - border: aRectangle width: borderWidth - "Paint a border whose rectangular area is defined by aRectangle. The - width of the border of each side is borderWidth. Uses black for - drawing the border." - - self border: aRectangle width: borderWidth fillColor: Color black! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:20' prior: 50348648! - fillBlack - "Set all bits in the receiver to black (ones)." - - self fill: self boundingBox fillColor: Color black! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:20' prior: 50348654! - fillBlack: aRectangle - "Set all bits in the receiver's area defined by aRectangle to black (ones)." - - self fill: aRectangle rule: Form over fillColor: Color black! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:20' prior: 50348662! - fillGray - "Set all bits in the receiver to gray." - - self fill: self boundingBox fillColor: Color gray! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:20' prior: 50348668! - fillGray: aRectangle - "Set all bits in the receiver's area defined by aRectangle to the gray mask." - - self fill: aRectangle rule: Form over fillColor: Color gray! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:21' prior: 50348676! - fillWhite - "Set all bits in the form to white." - - self fill: self boundingBox fillColor: Color white! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:21' prior: 50348682! - fillWhite: aRectangle - "Set all bits in the receiver's area defined by aRectangle to white." - - self fill: aRectangle rule: Form over fillColor: Color white! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:21' prior: 50348690! - reverse - "Change all the bits in the receiver that are white to black, and the ones - that are black to white. - Display reverse - " - - self fill: self boundingBox rule: Form reverse fillColor: Color white! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:21' prior: 50348699! - reverse: aRectangle - "Change all the bits in the receiver's area that intersects with aRectangle - that are white to black, and the ones that are black to white." - - self fill: aRectangle rule: Form reverse fillColor: Color white! ! -!Form methodsFor: 'color mapping' stamp: 'ar 5/17/2001 15:42' prior: 50348709! - colormapIfNeededForDepth: destDepth - "Return a colormap for displaying the receiver at the given depth, or nil if no colormap is needed." - - self depth = destDepth ifTrue: [^ nil]. "not needed if depths are the same" - ^ Color colorMapIfNeededFrom: self depth to: destDepth -! ! -!Form methodsFor: 'color mapping' stamp: 'jmv 5/12/2016 13:53' prior: 50348721! - colormapIfNeededForGray8bpp - "Return a colormap for displaying the receiver at the given depth. - Note: Uses 5 bits per color component. 32bit Forms will lose information!!" - - ^ Color cachedColormapForGrayFrom: self depth! ! -!Form methodsFor: 'color mapping' stamp: 'jmv 9/23/2012 21:42' prior: 50348731! - mapColor: oldColor to: newColor - "Make all pixels of the given color in this Form to the given new color." - "Warnings: This method modifies the receiver. It may lose some color accuracy on 32-bit Forms, since the transformation uses a color map with only 15-bit resolution." - - | map | - map _ (Color cachedColormapFrom: self depth to: self depth) copy. - map at: (oldColor indexInMap: map) put: (newColor pixelWordForDepth: self depth). - (BitBlt toForm: self) - sourceForm: self; - sourceOrigin: 0@0; - combinationRule: Form over; - destX: 0 destY: 0 width: width height: height; - colorMap: map; - copyBits. -! ! -!Form methodsFor: 'color mapping' stamp: 'jmv 1/31/2011 09:21' prior: 50348753! - maskingMap - "Return a color map that maps all colors except transparent to words of all ones. Used to create a mask for a Form whose transparent pixel value is zero." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - ^Color maskingMap: self depth! ! -!Form methodsFor: 'converting' stamp: 'jm 11/12/97 19:28' prior: 50348776! - as8BitColorForm - "Simple conversion of zero pixels to transparent. Force it to 8 bits." - - | f map | - f _ ColorForm extent: self extent depth: 8. - self displayOn: f at: self offset negated. - map _ Color indexedColors copy. - map at: 1 put: Color transparent. - f colors: map. - f offset: self offset. - ^ f -! ! -!Form methodsFor: 'pixel access' stamp: 'ar 5/17/2001 15:42' prior: 50348789! - colorAt: aPoint - "Return the color in the pixel at the given point. " - - ^ Color - colorFromPixelValue: (self pixelValueAt: aPoint) - depth: self depth -! ! -!Form methodsFor: 'pixel access' stamp: 'jmv 11/4/2015 12:40' prior: 50348797! - colorInterpolatedAt: aPoint - "Evaluate a bilinear (i.e. cheap) interpolation - Like OpenCV's CV_INTER_LINEAR - Answer Color transparent if outside image bounds. - Copied almost verbatim from FloatImage. - Answer Colors with float components. Will be rounded to be stored in, for example, a 32-bit Form." - - | x y w interpolated xWeight1 xWeight0 yWeight1 yWeight0 xIndex0 xIndex1 yIndex0 yIndex1 | - x _ aPoint x. - y _ aPoint y. - x < 0.0 ifTrue: [ ^Color transparent ]. - xIndex0 _ x truncated. "Could be #floor. But as we only care for values >=0, it is the same. But faster." - xIndex0 > (width-1) ifTrue: [ ^Color transparent ]. - (xIndex0 = (width-1) and: [ x > (width-1) ]) ifTrue: [ ^Color transparent ]. - xIndex1 _ xIndex0 = (width-1) "Avoid the invalid access if this was true, but don't make it slower the most common, general case." - ifFalse: [ xIndex0 + 1 ] - ifTrue: [ xIndex0 ]. - - y < 0.0 ifTrue: [ ^Color transparent ]. - yIndex0 _ y truncated. "Could be #floor. But as we only care for values >=0, it is the same. But faster." - yIndex0 > (height-1) ifTrue: [ ^Color transparent ]. - (yIndex0 = (height-1) and: [ y > (height-1) ]) ifTrue: [ ^Color transparent ]. - yIndex1 _ yIndex0 = (height-1) "Avoid the invalid access if this was true, but don't make it slower the most common, general case." - ifFalse: [ yIndex0 + 1 ] - ifTrue: [ yIndex0 ]. - - xWeight1 _ x - xIndex0. - xWeight0 _ 1.0 - xWeight1. - - yWeight1 _ y - yIndex0. - yWeight0 _ 1.0 - yWeight1. - - "/* perform interpolation */" - w _ ((self colorAt: xIndex0 @ yIndex0) * xWeight0) + - ((self colorAt: xIndex1 @ yIndex0) * xWeight1). - interpolated _ w * yWeight0. - - w _ ((self colorAt: xIndex0 @ yIndex1) * xWeight0) + - ((self colorAt: xIndex1 @ yIndex1) * xWeight1). - interpolated _ w * yWeight1 + interpolated. - - ^interpolated! ! -!Form methodsFor: 'transitions' stamp: 'jmv 7/28/2015 08:32' prior: 50348856! - pageWarp: otherImage at: topLeft forward: forward - "Produce a page-turning illusion that gradually reveals otherImage - located at topLeft in this form. - forward == true means turn pages toward you, else away. [ignored for now]" - | pageRect oldPage nSteps buffer p leafRect sourceQuad warp oldBottom d | - pageRect _ otherImage boundingBox. - oldPage _ self copy: (pageRect translatedBy: topLeft). - (forward ifTrue: [oldPage] ifFalse: [otherImage]) - border: pageRect - widthRectangle: (Rectangle - left: 0 - right: 2 - top: 1 - bottom: 1) - rule: Form over - fillColor: Color black. - oldBottom _ self copy: ((pageRect bottomLeft + topLeft) extent: (pageRect width@(pageRect height//4))). - nSteps _ 8. - buffer _ Form extent: otherImage extent + (0@(pageRect height//4)) depth: self depth. - d _ pageRect topLeft + (0@(pageRect height//4)) - pageRect topRight. - 1 to: nSteps-1 do: - [:i | forward - ifTrue: [buffer copy: pageRect from: otherImage to: 0@0 rule: Form over. - p _ pageRect topRight + (d * i // nSteps)] - ifFalse: [buffer copy: pageRect from: oldPage to: 0@0 rule: Form over. - p _ pageRect topRight + (d * (nSteps-i) // nSteps)]. - buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over. - leafRect _ pageRect topLeft corner: p x @ (pageRect bottom + p y). - sourceQuad _ Array with: pageRect topLeft - with: pageRect bottomLeft + (0@p y) - with: pageRect bottomRight - with: pageRect topRight - (0@p y). - warp _ (WarpBlt toForm: buffer) - clipRect: leafRect; - sourceForm: (forward ifTrue: [oldPage] ifFalse: [otherImage]); - combinationRule: Form paint. - warp copyQuad: sourceQuad toRect: leafRect. - self copy: buffer boundingBox from: buffer to: topLeft rule: Form over. - Display forceToScreen. - ]. - - buffer copy: pageRect from: otherImage to: 0@0 rule: Form over. - buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over. - self copy: buffer boundingBox from: buffer to: topLeft rule: Form over. - Display forceToScreen. -" -1 to: 4 do: [:corner | Display pageWarp: - (Form fromDisplay: (10@10 extent: 200@300)) reverse - at: 10@10 forward: false] -" -! ! -!Form class methodsFor: 'instance creation' stamp: 'jmv 9/23/2012 21:44' prior: 50348927! - dotOfSize: diameter - "Create a form which contains a round black dot." - | radius form bb rect centerX centerY centerYBias centerXBias radiusSquared xOverY maxy dx | - radius _ diameter//2. - form _ self extent: diameter@diameter offset: (0@0) - (radius@radius). - bb _ (BitBlt toForm: form) - sourceX: 0; sourceY: 0; - combinationRule: Form over; - fillColor: Color black. - rect _ form boundingBox. - centerX _ rect center x. - centerY _ rect center y. - centerYBias _ rect height odd ifTrue: [0] ifFalse: [1]. - centerXBias _ rect width odd ifTrue: [0] ifFalse: [1]. - radiusSquared _ (rect height asFloat / 2.0) squared - 0.01. - xOverY _ rect width asFloat / rect height asFloat. - maxy _ rect height - 1 // 2. - - "First do the inner fill, and collect x values" - 0 to: maxy do: - [:dy | - dx _ ((radiusSquared - (dy * dy) asFloat) sqrt * xOverY) truncated. - bb destX: centerX - centerXBias - dx - destY: centerY - centerYBias - dy - width: dx + dx + centerXBias + 1 - height: 1; - copyBits. - bb destY: centerY + dy; - copyBits]. - ^ form -" -Time millisecondsToRun: - [1 to: 20 do: [:i | (Form dotOfSize: i) displayAt: (i*20)@(i*20)]] -"! ! -!Form class methodsFor: 'instance creation' stamp: 'pb 5/4/2016 17:43' prior: 50348966! - fakeSphereAt: aPoint diameter: diameter color: aColor - "Create a form which contains a round black dot." - | bb rect d p | - bb _ GrafPort toForm: Display. - bb fillColor: aColor. - bb combinationRule: Form blend. - rect _ aPoint extent: diameter. - bb fillOval: rect. - p _ (diameter * 2 // 5) asPoint + aPoint. - #(2 3 4 5 6 ) do: [ :i | - "simulate facade by circles of gray" - bb fillColor: (Color white alpha: 0.3). - d _ i * diameter // 10. - rect _ Rectangle - center: p - extent: d. - bb fillOval: rect ]. - DisplayScreen screenUpdateRequired: nil. -" - Form fakeSphereAt: 50@50 diameter: 30 color: (Color red alpha: 0.5) -"! ! -!Form class methodsFor: 'examples' stamp: 'jmv 3/20/2013 22:36' prior: 50348989! - toothpaste: diam - " - Display restoreAfter: [Form toothpaste: 30] - " - "Not completely unlike the ST-80 implementation :) - Original comment: - Draws wormlike lines by laying down images of spheres. - See Ken Knowlton, Computer Graphics, vol. 15 no. 4 p352. - Draw with mouse button down; terminate by option-click." - | point queue color q colors colr colr2 | - colors _ Color red wheel: 12. - color _ 8. - [ true ] whileTrue: [ - queue _ OrderedCollection new: 32. - 16 timesRepeat: [queue addLast: -40@-40]. - Sensor waitButton. - Sensor isMouseButton2Pressed ifTrue: [^ self]. - point _ Sensor mousePoint. - colr _ colors atWrap: (color _ color + 5). "choose increment relatively prime to colors size" - colr2 _ colr alpha: 0.3. - [Sensor isMouseButton1Pressed or: [queue size > 0]] whileTrue: [ - point _ point * 4 + Sensor mousePoint // 5. - point _ point. - Form fakeSphereAt: point diameter: diam color: colr. - (q _ queue removeFirst) ifNil: [^ self]. "exit" - Form fakeSphereAt: q diameter: diam color: colr2. - Sensor isMouseButton1Pressed ifTrue: [queue addLast: point]]]! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 5/15/2015 09:37' prior: 50349026! - bottomLeftCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - "Create and answer a Form for the bottomLeft corner of a rounded rectangle" - | f aaw topColor bottomColor l d c width dy | - topColor _ Color white * gradientTopFactor. - bottomColor _ Color white * gradientBottomFactor. - width _ r. - aaw _ 1.3. - f _ Form - extent: width @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: width - 1 - do: [ :x | - dy _ height - r - y. - dy > 0 - ifTrue: [ l _ 1.0 ] - ifFalse: [ - d _ (width - 1 - x @ dy) r. - l _ ((r - d max: 0.0) min: aaw) / aaw ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 5/15/2015 09:47' prior: 50349054! - bottomLeftCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor borderWidth: bw - "Create and answer a Form for the bottomLeft corner of a rounded rectangle" - | f aaw topColor bottomColor l d c width dy l1 l2 | - topColor _ Color white * gradientTopFactor. - bottomColor _ Color white * gradientBottomFactor. - width _ r. - aaw _ 1.3. - f _ Form - extent: width @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: width - 1 - do: [ :x | - dy _ height - r - y. - dy > 0 - ifTrue: [ l _ 1.0 ] - ifFalse: [ - d _ (width - 1 - x @ dy) r. - l1 _ ((r - d-1+aaw max: 0.0) min: aaw) / aaw. - l2 _ ((d - r+bw+aaw max: 0.0) min: aaw) / aaw. - l _ l1 min: l2. - ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 5/15/2015 09:38' prior: 50349085! - bottomRightCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - "Create and answer a Form for the bottomRight corner of a rounded rectangle" - | f aaw topColor bottomColor l d c width dy | - topColor _ Color white * gradientTopFactor. - bottomColor _ Color white * gradientBottomFactor. - width _ r. - aaw _ 1.3. - f _ Form - extent: width @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: width - 1 - do: [ :x | - dy _ height - r - y. - dy > 0 - ifTrue: [ l _ 1.0 ] - ifFalse: [ - d _ (x @ dy) r. - l _ ((r - d max: 0.0) min: aaw) / aaw ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 5/15/2015 09:41' prior: 50349112! - bottomRightCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor borderWidth: bw - "Create and answer a Form for the bottomLeft corner of a rounded rectangle" - | f aaw topColor bottomColor l d c width dy l1 l2 | - topColor _ Color white * gradientTopFactor. - bottomColor _ Color white * gradientBottomFactor. - width _ r. - aaw _ 1.3. - f _ Form - extent: width @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: width - 1 - do: [ :x | - dy _ height - r - y. - dy > 0 - ifTrue: [ l _ 1.0 ] - ifFalse: [ - d _ (x @ dy) r. - l1 _ ((r - d-1+aaw max: 0.0) min: aaw) / aaw. - l2 _ ((d - r+bw+aaw max: 0.0) min: aaw) / aaw. - l _ l1 min: l2. - ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 11/30/2010 10:34' prior: 50349143! - topLeftCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - "Create and answer a Form with a vertical gray gradient as specified for the topLeft corner of a rounded rectangle" - | f bw topColor bottomColor l d c w | - topColor _ Color white * gradientTopFactor. - bottomColor _ Color white * gradientBottomFactor. - w _ r. - bw _ 1.3. - f _ Form - extent: w @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: w - 1 - do: [ :x | - l _ 1.0. - y < r ifTrue: [ - d _ (w - 1 - x @ (w - 1 - y)) r. - l _ ((r - d max: 0.0) min: bw) / bw ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 11/30/2010 10:36' prior: 50349170! - topRightCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - "Create and answer a Form with a vertical gray gradient as specified for the topRight corner of a rounded rectangle" - | f bw topColor bottomColor l d c w | - topColor _ Color white * gradientTopFactor. - bottomColor _ Color white * gradientBottomFactor. - w _ r. - bw _ 1.3. - f _ Form - extent: w @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: w - 1 - do: [ :x | - l _ 1.0. - y < r ifTrue: [ - d _ (x @ (w - y - 1)) r. - l _ ((r - d max: 0.0) min: bw) / bw ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!ColorForm methodsFor: 'accessing' stamp: 'ar 5/17/2001 15:45' prior: 50349196! - colors: colorList - "Set my color palette to the given collection." - - | colorArray colorCount newColors | - colorList ifNil: [ - colors _ cachedDepth _ cachedColormap _ nil. - ^ self]. - - colorArray _ colorList asArray. - colorCount _ colorArray size. - newColors _ Array new: (1 bitShift: self depth). - 1 to: newColors size do: [:i | - i <= colorCount - ifTrue: [newColors at: i put: (colorArray at: i)] - ifFalse: [newColors at: i put: Color transparent]]. - - colors _ newColors. - cachedDepth _ nil. - cachedColormap _ nil. -! ! -!ColorForm methodsFor: 'color manipulation' stamp: 'di 11/11/1998 13:20' prior: 50349216! - asGrayScale - "Return a grayscale ColorForm computed by mapping each color into its grayscale equivalent" - ^ self copy colors: - (colors collect: - [:c | c isTransparent ifTrue: [c] - ifFalse: [Color gray: c luminance]])! ! -!ColorForm methodsFor: 'color manipulation' stamp: 'jmv 3/1/2010 09:41' prior: 50349226! - colormapIfNeededForDepth: destDepth - "Return a colormap for displaying the receiver at the given depth, or nil if no colormap is needed." - - | newMap | - colors ifNil: [ - "use the standard colormap" - ^ Color colorMapIfNeededFrom: self depth to: destDepth]. - - (destDepth = cachedDepth and:[cachedColormap isColormap not]) - ifTrue: [^ cachedColormap]. - newMap _ Bitmap new: colors size. - 1 to: colors size do: [:i | - newMap - at: i - put: ((colors at: i) pixelValueForDepth: destDepth)]. - - cachedDepth _ destDepth. - ^ cachedColormap _ newMap. -! ! -!ColorForm methodsFor: 'private' stamp: 'ar 5/17/2001 15:44' prior: 50349246! - ensureColorArrayExists - "Return my color palette." - - colors ifNil: [ - self depth > 8 ifTrue: [^ self error: 'ColorForms only support depths up to 8 bits']. - self colors: (Color indexedColors copyFrom: 1 to: (1 bitShift: self depth))]. -! ! -!ColorForm class methodsFor: 'as yet unclassified' stamp: 'jmv 4/10/2015 23:20' prior: 50349257! - mappingWhiteToTransparentFrom: aFormOrCursor - "Return a ColorForm copied from the given Form or Cursor with white mapped to transparent." - - | f map | - aFormOrCursor depth <= 8 ifFalse: [ - ^ self error: 'argument depth must be 8-bits per pixel or less']. - (aFormOrCursor is: #ColorForm) ifTrue: [ - f _ aFormOrCursor copy. - map _ aFormOrCursor colors. - ] ifFalse: [ - f _ ColorForm extent: aFormOrCursor extent depth: aFormOrCursor depth. - f copyBits: aFormOrCursor boundingBox - from: aFormOrCursor - at: 0@0 - clippingBox: aFormOrCursor boundingBox - rule: Form over. - map _ Color indexedColors copyFrom: 1 to: (1 bitShift: aFormOrCursor depth)]. - map _ map collect: [:c | - c = Color white ifTrue: [Color transparent] ifFalse: [c]]. - f colors: map. - ^ f -! ! -!ColorForm class methodsFor: 'instance creation' stamp: 'jmv 5/4/2016 16:31' prior: 50349285! - grayScaleAndTransparentExtent: aPoint -"Native depth" - "Answer a ColorForm for storing 8bpp gray scale. (do not include any slot for transparent)" - - | grays result | - result _ self extent: aPoint depth: (Smalltalk isLittleEndian ifTrue: [ -8 ] ifFalse: [ 8 ]). - grays _ (0 to: 255) collect: [ :brightness | Color gray: brightness asFloat / 255.0]. - grays at: 1 put: Color transparent. - result colors: grays. - ^result! ! -!Cursor methodsFor: 'converting' stamp: 'jmv 2/25/2011 19:47' prior: 50349301! - asCursorForm - | form | - form _ Form extent: self extent depth: 8. - form fillShape: self fillColor: Color black at: offset negated. - ^ form offset: offset! ! -!CursorWithMask methodsFor: 'converting' stamp: 'jmv 2/25/2011 19:47' prior: 50349309! - asCursorForm - | form | - form _ Form extent: self extent depth: 8. - form fillShape: maskForm fillColor: Color white. - form fillShape: self fillColor: Color black at: offset negated. - ^ form offset: offset! ! -!GrayForm methodsFor: 'pixel accessing' stamp: 'jmv 5/11/2016 19:57' prior: 50349319! - grayAt: aPoint - "Return the color of the pixel at aPoint." - - ^Color gray: (self pixelValueAt: aPoint) asFloat / 255.0! ! -!GrayForm methodsFor: 'color manipulation' stamp: 'jmv 5/12/2016 15:04' prior: 50349326! - colormapIfNeededForDepth: destDepth - "Return a colormap for displaying the receiver at the given depth, or nil if no colormap is needed." - - ^ Color cachedColormapFromGrayTo: destDepth! ! -!BMPReadWriter methodsFor: 'reading' stamp: 'ar 10/24/2005 20:57' prior: 50349335! - readColorMap - "Read colorCount BMP color map entries from the given binary stream. Answer an array of Colors." - | colorCount colors maxLevel b g r ccStream | - colorCount := (bfOffBits - 54) // 4. - "Note: some programs (e.g. Photoshop 4.0) apparently do not set colorCount; assume that any data between the end of the header and the start of the pixel data is the color map" - biBitCount >= 16 ifTrue:[^nil]. - colorCount = 0 ifTrue: [ "this BMP file does not have a color map" - "default monochrome color map" - biBitCount = 1 ifTrue: [^ Array with: Color white with: Color black]. - "default gray-scale color map" - maxLevel := (2 raisedTo: biBitCount) - 1. - ^ (0 to: maxLevel) collect: [:level | Color gray: (level asFloat / maxLevel)]]. - ccStream := ReadStream on: (stream next: colorCount*4). - colors := Array new: colorCount. - 1 to: colorCount do: [:i | - b := ccStream next. - g := ccStream next. - r := ccStream next. - ccStream next. "skip reserved" - colors at: i put: (Color r: r g: g b: b range: 255)]. - ^ colors -! ! -!BitBlt methodsFor: 'accessing' stamp: 'jmv 3/20/2013 00:50' prior: 50349370! - fillColor - "Return the current fill color as a Color. - Gives the wrong answer if the halftoneForm is a complex pattern of more than one word." - - halftoneForm ifNil: [^ Color black]. - ^ Color colorFromPixelValue: halftoneForm first depth: destForm depth! ! -!BitBlt class methodsFor: 'examples' stamp: 'jmv 7/27/2015 17:07' prior: 50349381! - alphaBlendDemo - "To run this demo, use... - Display restoreAfter: [BitBlt alphaBlendDemo] - Displays 10 alphas, then lets you paint. Option-Click to stop painting." - - "This code exhibits alpha blending in any display depth by performing - the blend in an off-screen buffer with 32-bit pixels, and then copying - the result back onto the screen with an appropriate color map. - tk 3/10/97" - - "This version uses a sliding buffer for painting that keeps pixels in 32 bits - as long as they are in the buffer, so as not to lose info by converting down - to display resolution and back up to 32 bits at each operation. - di 3/15/97" - - | brush buff dispToBuff buffToDisplay mapDto32 map32toD prevP p brushToBuff theta buffRect buffSize buffToBuff brushRect delta newBuffRect updateRect | - - "compute color maps if needed" - Display depth <= 8 ifTrue: [ - mapDto32 _ Color cachedColormapFrom: Display depth to: 32. - map32toD _ Color cachedColormapFrom: 32 to: Display depth]. - - "display 10 different alphas, across top of screen" - buff _ Form extent: 500@50 depth: 32. - dispToBuff _ BitBlt toForm: buff. - dispToBuff colorMap: mapDto32. - dispToBuff copyFrom: (50@10 extent: 500@50) in: Display to: 0@0. - 1 to: 10 do: [:i | dispToBuff fill: (50*(i-1)@0 extent: 50@50) - fillColor: (Color red alpha: i/10) - rule: Form blend]. - buffToDisplay _ BitBlt toForm: Display. - buffToDisplay colorMap: map32toD. - buffToDisplay copyFrom: buff boundingBox in: buff to: 50@10. - DisplayScreen screenUpdateRequired: nil. - - "Create a brush with radially varying alpha" - brush _ Form extent: 30@30 depth: 32. - 1 to: 5 do: - [:i | brush fillShape: (Form dotOfSize: brush width*(6-i)//5) - fillColor: (Color red alpha: 0.02 * i - 0.01) - at: brush extent // 2]. - - "Now paint with the brush using alpha blending." - buffSize _ 100. - buff _ Form extent: brush extent + buffSize depth: 32. "Travelling 32-bit buffer" - dispToBuff _ BitBlt toForm: buff. "This is from Display to buff" - dispToBuff colorMap: mapDto32. - brushToBuff _ BitBlt toForm: buff. "This is from brush to buff" - brushToBuff sourceForm: brush; sourceOrigin: 0@0. - brushToBuff combinationRule: Form blend. - buffToBuff _ BitBlt toForm: buff. "This is for slewing the buffer" - - [Sensor isMouseButton2Pressed] whileFalse: - [prevP _ nil. - buffRect _ Sensor mousePoint - (buffSize // 2) extent: buff extent. - dispToBuff copyFrom: buffRect in: Display to: 0@0. - [Sensor isMouseButton1Pressed] whileTrue: - ["Here is the painting loop" - p _ Sensor mousePoint - (brush extent // 2). - (prevP == nil or: [prevP ~= p]) ifTrue: - [prevP == nil ifTrue: [prevP _ p]. - (p dist: prevP) > buffSize ifTrue: - ["Stroke too long to fit in buffer -- clip to buffer, - and next time through will do more of it" - theta _ (p-prevP) theta. - p _ ((theta cos@theta sin) * buffSize asFloat + prevP) truncated]. - brushRect _ p extent: brush extent. - (buffRect containsRect: brushRect) ifFalse: - ["Brush is out of buffer region. Scroll the buffer, - and fill vacated regions from the display" - delta _ brushRect amountToTranslateWithin: buffRect. - buffToBuff copyFrom: buff boundingBox in: buff to: delta. - newBuffRect _ buffRect translatedBy: delta negated. - newBuffRect - areasOutside: buffRect - do: [ :r | dispToBuff copyFrom: r in: Display to: r origin - newBuffRect origin ]. - buffRect _ newBuffRect]. - - "Interpolate from prevP to p..." - brushToBuff drawFrom: prevP - buffRect origin - to: p - buffRect origin - withFirstPoint: false. - - "Update (only) the altered pixels of the destination" - updateRect _ (p min: prevP) corner: (p max: prevP) + brush extent. - buffToDisplay copy: updateRect from: updateRect origin - buffRect origin in: buff. - DisplayScreen screenUpdateRequired: updateRect. - prevP _ p]]]! ! -!WarpBlt methodsFor: 'setup' stamp: 'mtf 8/14/2009 18:21' prior: 50349504! - cellSize: s - "Set the number of samples used for averaging" - cellSize := s. - cellSize = 1 ifTrue: [^ self]. - "Install the colorMap to used for mapping the averaged RGBA 32bit pixels to the - destination depth. Note that we need to install the 32->32 color map explicitly because - the VM will substitute a colorMap derived from sourceForm->destForm mapping which - is just plain wrong for <32 source and 32bit dest depth" - (destForm depth = 32 and: [sourceForm notNil] and: [sourceForm depth < 32]) - ifTrue:[colorMap := ColorMap shifts: #(0 0 0 0) masks:#(16rFF0000 16rFF00 16rFF 16rFF000000) colors: nil] - ifFalse:[colorMap := Color colorMapIfNeededFrom: 32 to: destForm depth]. -! ! -!GrafPort methodsFor: 'text' stamp: 'jmv 6/1/2015 13:28' prior: 50349528! - displayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font color: foregroundColor - "If required, do a second pass with new rule and colorMap. - Answer last affected pixel position - Answer nil if nothing was done - " - - | answer prevRule secondPassMap sourceDepth destDepth | - - "Slight optimization when there's nothing to do." - clipHeight = 0 ifTrue: [^nil]. - clipWidth = 0 ifTrue: [^nil]. - - self installStrikeFont: font foregroundColor: (foregroundColor alpha: 1). - - "If combinationRule is rgbMul, we might need the special two-pass technique for component alpha blending. - If not, do it simply" - combinationRule = 37 "rgbMul" ifFalse: [ - ^self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font ]. - - "We need to do a second pass. The colormap set is for use in the second pass." - secondPassMap _ colorMap. - sourceDepth _ sourceForm depth. - destDepth _ destForm depth. - colorMap _ sourceDepth ~= destDepth - ifTrue: [ Color cachedColormapFrom: sourceDepth to: destDepth ]. - answer := self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font. - colorMap := secondPassMap. - secondPassMap ifNotNil: [ - prevRule := combinationRule. - combinationRule := 20. "rgbAdd" - self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font. - combinationRule := prevRule ]. - ^answer! ! -!GrafPort methodsFor: 'private' stamp: 'jmv 5/12/2016 14:52' prior: 50349575! - cachedFontColormapFrom1BitTo: destDepth - - | map dstIndex | - CachedFontColorMaps - ifNil: [CachedFontColorMaps _ Array new: 6]. - - dstIndex _ destDepth highBit. - (CachedFontColorMaps at: dstIndex) ifNotNil: [ :m | ^ m ]. - - map _ (Color cachedColormapFrom: 1 to: destDepth) copy. - CachedFontColorMaps at: dstIndex put: map. - ^ map! ! -!GrafPort methodsFor: 'private' stamp: 'jmv 5/12/2016 14:55' prior: 50349588! - colorConvertingMap: targetColor from: sourceDepth to: destDepth keepSubPixelAA: keepSubPix - "Note: The color converting map for sourceDepth=16 and for sourceDepth=32 are the same" - - | srcIndex dstIndex map mapsForSource mapsForSourceAndDest | - ColorConvertingMaps - ifNil: [ColorConvertingMaps _ (1 to: 6) collect: [:i | Array new: 6]]. - - srcIndex _ sourceDepth highBit. - sourceDepth > 8 ifTrue: [ srcIndex _ keepSubPix ifTrue: [5] ifFalse: [6] ]. - dstIndex _ destDepth highBit. - - mapsForSource _ ColorConvertingMaps at: srcIndex. - (mapsForSourceAndDest _ mapsForSource at: dstIndex) ifNil: [ - mapsForSourceAndDest _ mapsForSource at: dstIndex put: Dictionary new ]. - - map _ mapsForSourceAndDest at: targetColor ifAbsentPut: [ - Color - computeColorConvertingMap: targetColor - from: sourceDepth - to: destDepth - keepSubPixelAA: keepSubPix ]. - - ^ map! ! -!GrafPort methodsFor: 'private' stamp: 'jmv 4/17/2014 16:57' prior: 50349618! - setRuleAndMapFor: sourceDepth foregroundColor: foregroundColor - - | targetColor destDepth | - destDepth _ destForm depth. - halftoneForm _ nil. "Don't use fillColor. Use a more powerful ColorMap" - - sourceDepth = 1 ifTrue: [ - self combinationRule: Form paint. - "Set up color map for a different source depth (color font)" - "Uses caching for reasonable efficiency" - colorMap _ self cachedFontColormapFrom1BitTo: destDepth. - colorMap at: 1 put: (destForm pixelValueFor: Color transparent). - colorMap at: 2 put: (destForm pixelValueFor: foregroundColor) ] - - ifFalse: [ - "Enable subpixel rendering if requested, but never for translucent text: - This technique always draws opaque text. This could be added, by using an extra colormap for the rgbMul phase... - So far, no need arised for doing so." - (sourceDepth > 8 and: [ - Preferences subPixelRenderFonts and: [ foregroundColor = Color black or: [ - Preferences subPixelRenderColorFonts and: [ foregroundColor isOpaque ]]]]) ifTrue: [ - destDepth > 8 ifTrue: [ - "rgbMul is equivalent to component alpha blend if text is black (only faster, hehe)" - self combinationRule: 37. "rgbMul" - colorMap _ (foregroundColor ~= Color black or: [ - destDepth = 32 and: [ destForm ~~ Display or: [Preferences properDisplayAlphaForFonts] ]]) ifTrue: [ - "rgbMul / rgbAdd IS component alpha blend for any color of text (neat trick, eh!!)" - "This colorMap is to be used on the second pass with rule 20 (rgbAdd) - See #displayString:from:to:at:strikeFont:color:" - "Note: In 32bpp, if we want the correct alpha in the result, we need the second pass, as the destination could have transparent pixels, - and we need to add to the alpha channel" - self colorConvertingMap: foregroundColor from: sourceDepth to: destDepth keepSubPixelAA: true]] - ifFalse: [ - self combinationRule: 25. "Paint" - targetColor _ foregroundColor = Color black ifFalse: [ foregroundColor ]. - colorMap _ self colorConvertingMap: targetColor from: sourceDepth to: destDepth keepSubPixelAA: true]] - ifFalse: [ - "Do not use rule 34 for 16bpp display. TTCFont uses it, but it builds a glyphs cache for each color used!!" - self combinationRule: (destDepth = 32 ifTrue: [34 "alphaBlendScaled"] ifFalse: [25 "Paint"]). - colorMap _ self colorConvertingMap: foregroundColor from: sourceDepth to: destDepth keepSubPixelAA: false]]! ! -!Rectangle methodsFor: 'transforming' stamp: 'jmv 9/24/2013 22:36' prior: 50350831! - newRectFrom: newRectBlock - "Track the outline of a new rectangle until mouse button changes. - newFrameBlock produces each new rectangle from the previous" - | rect newRect buttonStart buttonNow aHand delay | - delay _ Delay forMilliseconds: 10. - buttonStart _ buttonNow _ Sensor isAnyButtonPressed. - rect _ self. - Display border: rect width: 2 rule: Form reverse fillColor: Color gray. - [buttonNow == buttonStart] whileTrue: - [delay wait. - buttonNow _ Sensor isAnyButtonPressed. - newRect _ newRectBlock value: rect. - newRect = rect ifFalse: - [Display border: rect width: 2 rule: Form reverse fillColor: Color gray. - Display border: newRect width: 2 rule: Form reverse fillColor: Color gray. - rect _ newRect]]. - Display border: rect width: 2 rule: Form reverse fillColor: Color gray. - " pay the price for reading the sensor directly ; get this party started " - aHand _ self runningWorld activeHand. - aHand - newMouseFocus: nil; - flushEvents. - Sensor processSensorEvent: Sensor createMouseEvent discardingMouseEvents: false. - ^ rect! ! -!StrikeFont methodsFor: 'emphasis' stamp: 'jmv 4/10/2015 23:21' prior: 50350867! - makeBoldGlyphs - "Make a bold set of glyphs with same widths by ORing 1 bit to the right - (requires at least 1 pixel of intercharacter space)" - | g bonkForm | - g _ glyphs copy. - bonkForm _ (Form extent: 1@16) fillBlack offset: -1@0. - self bonk: g with: bonkForm. - glyphs depth = 1 ifTrue: [ - g copyBits: g boundingBox from: g at: (1@0) - clippingBox: g boundingBox rule: Form under ] - ifFalse: [ - 0 to: g width - 2 do: [ :x | 0 to: g height-1 do: [ :y | - (glyphs colorAt: x@y) = Color white ifFalse: [ - g colorAt: x+1@y put: - ((glyphs colorAt: x+1@y) = Color white - ifTrue: [glyphs colorAt: x@y] - ifFalse: [Color black])]]]]. - glyphs _ g. - self isSynthetic: true! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 9/2/2016 11:03:22' prior: 50350892! - makeControlCharsVisible - | glyph | - self characterToGlyphMap. - glyph _ self glyphAt: (Character space). - glyph border: glyph boundingBox width: 1 fillColor: Color blue. - self glyphAt: (Character numericValue: 134) put: glyph. - - "Keep tab(9), lf(10), cr(13) and space(32) transparent or whatever the user chose" - #(0 1 2 3 4 5 6 7 8 11 12 14 15 16 17 18 19 20 21 22 23 24 25 26 27) - do: [ :ascii | - characterToGlyphMap at: ascii + 1 put: 134 ]! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 9/2/2016 11:03:27' prior: 50350909! - makeCrVisible - | glyph | - self characterToGlyphMap. - glyph _ self glyphAt: (Character numericValue: 182). - glyph border: glyph boundingBox width: 1 fillColor: Color blue. -" glyph _ glyph reverse." - self glyphAt: (Character numericValue: 133) put: glyph. - characterToGlyphMap at: 14 put: 133! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 9/2/2016 11:03:31' prior: 50350921! - makeLfVisible - | glyph | - self characterToGlyphMap. - glyph _ self glyphAt: (Character numericValue: 163). - glyph border: glyph boundingBox width: 1 fillColor: Color blue. -" glyph _ glyph reverse." - self glyphAt: (Character numericValue: 132) put: glyph. - characterToGlyphMap at: 11 put: 132! ! -!Morph methodsFor: 'accessing' stamp: 'jmv 8/21/2012 20:40' prior: 50350933! - color - - ^ Color blue! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 4/14/2015 08:53' prior: 50350937! - drawOn: aCanvas - "A canvas is already set with a proper transformation from our coordinates to those of the Canvas target." - aCanvas - fillRectangle: self morphLocalBounds - color: Color blue! ! -!RectangleLikeMorph methodsFor: 'initialization' stamp: 'jmv 8/21/2012 18:46' prior: 50350947! - defaultColor - ^ Color orange! ! -!BorderedRectMorph methodsFor: 'initialization' stamp: 'jmv 8/17/2014 21:28' prior: 50350951! - defaultBorderColor - "answer the default border color/fill style for the receiver" - ^ Color gray! ! -!PasteUpMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:35' prior: 50350957! - defaultBorderColor - "answer the default border color/fill style for the receiver" - ^ Color - r: 0.861 - g: 1.0 - b: 0.722! ! -!PasteUpMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:29' prior: 50350964! - defaultColor - "answer the default color/fill style for the receiver" - ^ Color - r: 0.8 - g: 1.0 - b: 0.6! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 11/10/2013 19:32' prior: 50350971! - findWindow: evt - "Present a menu names of windows and naked morphs, and activate the one that gets chosen. Collapsed windows appear below line, expand if chosen; naked morphs appear below second line; if any of them has been given an explicit name, that is what's shown, else the class-name of the morph shows; if a naked morph is chosen, bring it to front and have it don a halo." - | menu expanded collapsed nakedMorphs | - menu _ MenuMorph new. - expanded _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed not ]. - collapsed _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed ]. - nakedMorphs _ self submorphsSatisfying: [ :m | - (m is: #SystemWindow) not ]. - expanded isEmpty & (collapsed isEmpty & nakedMorphs isEmpty) ifTrue: [ ^ Smalltalk beep ]. - (expanded asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #activateAndForceLabelToShow. - w canDiscardEdits ifFalse: [ menu lastItem color: Color red ]]. - expanded isEmpty | (collapsed isEmpty & nakedMorphs isEmpty) ifFalse: [ menu addLine ]. - (collapsed asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #expand. - w canDiscardEdits ifFalse: [ menu lastItem color: Color red ]]. - nakedMorphs isEmpty ifFalse: [ menu addLine ]. - (nakedMorphs asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #comeToFrontAndAddHalo ]. - menu addTitle: 'find window'. - menu popUpInWorld: self! ! -!EllipseMorph methodsFor: 'visual properties' stamp: 'ar 6/25/1999 11:14' prior: 50351025! - defaultColor - "Return the default fill style for the receiver" - ^Color yellow! ! -!PluggableMorph methodsFor: 'initialization' stamp: 'jmv 8/6/2014 09:15' prior: 50351031! - defaultColor - "answer the default color/fill style for the receiver" - ^ Color lightGray! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 9/9/2012 23:50' prior: 50351037! - drawRoundGradientLookOn: aCanvas - | r colorForButton rect bottomFactor topFactor | - - self isPressed - ifFalse: [ - topFactor _ Theme current buttonGradientTopFactor. - bottomFactor _ Theme current buttonGradientBottomFactor. - self mouseIsOver - ifTrue: [ - colorForButton _ Color h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ - colorForButton _ color ]] - ifTrue: [ - topFactor _ Theme current buttonGradientBottomFactor. - bottomFactor _ Theme current buttonGradientTopFactor. - colorForButton _ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - Theme current useButtonGradient - ifTrue: [ - rect _ (0@0 extent: extent) insetBy: 1@3. - aCanvas - roundRect: rect - color: colorForButton - radius: r - gradientTop: topFactor - gradientBottom: bottomFactor - gradientHeight: Theme current buttonGradientHeight ] - ifFalse: [ - rect _ (0@0 extent: extent) insetBy: 1@3. - aCanvas roundRect: rect color: colorForButton radius: r ] - ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawEmbossedLabelOn: aCanvas ] - ifFalse: [ self drawRegularLabelOn: aCanvas ]! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 4/12/2012 22:37' prior: 50351078! - iconColor - - ^ self isPressed - ifTrue: [ Color gray: 0.75 ] - ifFalse: [ - self mouseIsOver - ifTrue: [ Color gray: 0.75 ] - ifFalse: [ Color white ]].! ! -!PluggableButtonMorph class methodsFor: 'example' stamp: 'jmv 1/4/2013 13:31' prior: 50351087! - example - " - PluggableButtonMorph example openInWorld - " - - | s1 s2 s3 b1 b2 b3 row | - s1 _ Switch new. - s2 _ Switch new turnOn. - s3 _ Switch new. - s2 onAction: [s3 turnOff]. - s3 onAction: [s2 turnOff]. - b1 _ (PluggableButtonMorph model: s1 stateGetter: #isOn action: #switch) label: 'S1'. - b2 _ (PluggableButtonMorph model: s2 stateGetter: #isOn action: #turnOn) label: 'S2'. - b3 _ (PluggableButtonMorph model: s3 stateGetter: #isOn action: #turnOn) label: 'S3'. - b1 color: Color lightRed. - b2 color: Color lightRed. - b3 color: Color lightRed. - row _ LayoutMorph newRow - addMorphs: (Array with: b1 with: b2 with: b3); - morphExtent: 120@35. - ^ row -! ! -!TextModelMorph methodsFor: 'drawing' stamp: 'cbr 10/10/2012 23:04' prior: 50351111! - drawOn: aCanvas - "Include a thin red inset border for unaccepted edits, or, if the unaccepted edits are known to conflict with a change made somewhere else to the same method (typically), put a thick red frame" - - - | bw bc | - - self flag: #todo. "Integrate this method with the Theme system. --cbr" - - - super drawOn: aCanvas. - bw _ Preferences focusIndicatorWidth. - bc _ nil. - self wantsFrameAdornments ifTrue: [ - model refusesToAccept - ifTrue: [ "Put up feedback showing that code cannot be submitted in this state" - bc _ Color tan] - ifFalse: [ - self textMorph hasEditingConflicts - ifTrue: [ - bw _ 3. - bc _ Color red ] - ifFalse: [ - self textMorph hasUnacceptedEdits - ifTrue: [ - bc _ Color red]]]]. - - (drawKeyboardFocusIndicator and: [ self textMorph hasKeyboardFocus ]) ifTrue: [ - bc ifNil: [ - bc _ Theme current focusIndicator ]] - ifFalse: [ - bc ifNotNil: [ - bc _ bc alphaMixed: 0.4 with: Color white ]]. - bc ifNotNil: [ - aCanvas frameRectangle: self focusIndicatorRectangle borderWidth: bw color: bc ]! ! -!SystemWindow methodsFor: 'initialization' stamp: 'cbr 11/7/2010 18:58' prior: 50351148! - defaultColor - "answer the default color/fill style for the receiver" - ^ Color white! ! -!SystemWindow methodsFor: 'menu' stamp: 'jmv 6/7/2013 23:23' prior: 50351154! - setWindowColor: incomingColor - | existingColor aColor | - incomingColor ifNil: [^ self]. "it happens" - aColor _ incomingColor asNontranslucentColor. - aColor = Color black ifTrue: [^ self]. - existingColor _ self widgetsColor. - existingColor ifNil: [^ Smalltalk beep]. - self widgetsColor: aColor. - self redrawNeeded! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'KenD 8/27/2015 14:39' prior: 50351167! - buildMorphicWindow - " - CodePackageListWindow open: CodePackageList new - " - | dirtyFlags names fileNames upperRow description summary backColor labelBackground textHeigth | - backColor := self textBackgroundColor. - labelBackground := Theme current background. - textHeigth := AbstractFont default height. - - dirtyFlags := PluggableListMorph - model: model - listGetter: #packageDirtyFlags - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - dirtyFlags color: backColor. - dirtyFlags := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorph: (StringMorph new contents: ' Unsaved?') fixedHeight: textHeigth; - addMorphUseAll: dirtyFlags. - - names := PluggableListMorph - model: model - listGetter: #packageNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - names color: backColor. - names := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorph: (StringMorph new contents: ' Package Name') fixedHeight: textHeigth; - addMorphUseAll: names. - - fileNames := PluggableListMorph - model: model - listGetter: #packageFullNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - fileNames color: backColor. - fileNames := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorph: (StringMorph new contents: ' File Name') fixedHeight: textHeigth; - addMorphUseAll: fileNames. - - upperRow := LayoutMorph newRow. - upperRow - addMorph: dirtyFlags proportionalWidth: 0.13; - addAdjusterAndMorph: names proportionalWidth: 0.27; - addAdjusterAndMorph: fileNames proportionalWidth: 0.6. - - description := TextModelMorph - textProvider: model - textGetter: #description - textSetter: #description:. - - summary := TextModelMorph - textProvider: model - textGetter: #summary. - - self layoutMorph - addMorph: upperRow proportionalHeight: 0.5; - addAdjusterAndMorph: self buildButtonPane proportionalHeight: 0.1; - addAdjusterAndMorph: summary proportionalHeight: 0.18; - addAdjusterAndMorph: description proportionalHeight: 0.22; - addAdjusterAndMorph: self buildRequirementsPane proportionalHeight: 0.2. - self setLabel: 'Installed Packages'! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'len 5/27/2016 21:51' prior: 50351243! - buildRequirementsPane - - | requirements deleteReqButton "editReqButton" reqLayout buttonLayout | - requirements := PluggableListMorph - model: (PackageRequirementsList fromCodePackageList: model) - listGetter: #requirementsStrings - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - requirements color: Theme current textPane. - - deleteReqButton := PluggableButtonMorph - model: requirements model - action: #deleteSelectedRequirement - label: 'delete'. - deleteReqButton color: self widgetsColor. - - buttonLayout := LayoutMorph newColumn. - buttonLayout addMorph: deleteReqButton - layoutSpec: (LayoutSpec - proportionalWidth: 1.0 - proportionalHeight: 1.0 - minorDirectionPadding: #top); - color: self widgetsColor quiteWhiter. - - model when: #changed: send: #updateRequirementsFromPackageList to: requirements model. - self when: #changed: send: #updateRequirementsFromPackageList to: requirements model. - requirements model when: #changed: send: #verifyContents to: requirements. - self when: #changed: send: #verifyContents to: requirements. - - reqLayout := LayoutMorph newRow. - ^ reqLayout - doAdoptWidgetsColor; - addMorph: requirements - layoutSpec: (LayoutSpec - proportionalWidth: 0.9 - proportionalHeight: 1.0 - minorDirectionPadding: #left); - addMorph: buttonLayout - layoutSpec: (LayoutSpec - proportionalWidth: 0.1 - proportionalHeight: 1.0 - minorDirectionPadding: #right); - color: Color transparent; - yourself - ! ! -!CodeWindow methodsFor: 'updating' stamp: 'jmv 9/2/2013 10:25' prior: 50351294! - decorateForInheritance - "Check to see if the currently-viewed method has a super send or an override, and if so, change screen feedback, unless the #decorateBrowserButtons says not to." - - | cm aColor aButton flags buttonColor | - (aButton _ self inheritanceButton) ifNil: [^ self]. - buttonColor _ self buttonColor. - - Preferences decorateBrowserButtons - ifFalse: [ ^aButton color: buttonColor ]. - cm _ model currentCompiledMethod. - (cm is: #CompiledMethod) - ifFalse: [ ^aButton color: buttonColor ]. - - flags _ 0. - model isThisAnOverride ifTrue: [ flags _ flags bitOr: 4 ]. - cm sendsToSuper ifTrue: [ flags _ flags bitOr: 2 ]. - model isThereAnOverride ifTrue: [ flags _ flags bitOr: 1 ]. - aColor _ { - - "This is NOTan override. There is no super implementation." - buttonColor. "no sends to super. there is not override in any subclass" - Color tan. "no sends to super. there is an override in some subclass" - Color red. "sends to super. there is no override in any subclass. Error: no super to call (or calls super with a different message)" - Color red. "sends to super. there is an override in some subclass. Error: no super to call (or calls super with a different message)" - - "This is an override. There is some super implementation" - Color red muchLighter. "doesn't have sub; has super but doesn't call it" - Color r: 0.94 g: 0.823 b: 0.673. "has sub; has super but doesn't call it" - Color green muchLighter. "doesn't have sub; has super and callsl it" - Color blue muchLighter. "has sub; has super and callsl it" - - } at: flags + 1. - aButton color: aColor! ! -!ChangeSorterWindow methodsFor: 'GUI building' stamp: 'DM 8/22/2015 12:34' prior: 50351348! - buildMorphicWindow - "Add a set of change sorter views to the given top view offset by the given amount. To create a single change sorter, call this once with an offset of 0@0. To create a dual change sorter, call it twice with offsets of 0@0 and 0.5@0." - - | dirtyFlags changeSetList classList messageList upperPanes backColor labelBackground | - backColor _ self textBackgroundColor. - labelBackground _ Theme current background. - model myChangeSet ifNil: [ - self flag: #ojo. "Or whatever was last changed, or is top of list, or whatever" - model myChangeSet: ChangeSet changeSetForBaseSystem ]. - - dirtyFlags _ PluggableListMorph - model: model - listGetter: #changeSetDirtyFlags - indexGetter: nil - indexSetter: nil. - dirtyFlags color: backColor. - dirtyFlags _ LayoutMorph newColumn - color: Theme current background; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: ' Unsaved?'); - addMorphUseAll: dirtyFlags. - - changeSetList _ (PluggableListMorphByItem - model: model - listGetter: #changeSetList - indexGetter: #currentCngSet - indexSetter: #showChangeSetNamed: - mainView: self - menuGetter: #changeSetMenu - keystrokeAction: #changeSetListKey:from:) - autoDeselect: false. - changeSetList color: backColor. - changeSetList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: 'Change Set name'); - addMorphUseAll: changeSetList. - - classList _ PluggableListMorphByItem - model: model - listGetter: #classList - indexGetter: #currentClassName - indexSetter: #currentClassName: - mainView: self - menuGetter: #classListMenu - keystrokeAction: #classListKey:from:. - classList color: backColor. - classList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: 'Classes'); - addMorphUseAll: classList. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: dirtyFlags proportionalWidth: 0.13; - addAdjusterAndMorph: changeSetList proportionalWidth: 0.47; - addAdjusterAndMorph: classList proportionalWidth: 0.4. - - messageList _ PluggableListMorphByItem - model: model - listGetter: #messageList - indexGetter: #currentSelector - indexSetter: #currentSelector: - mainView: self - menuGetter: #messageMenu - keystrokeAction: #messageListKey:from:. - messageList color: backColor. - messageList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: 'Methods'); - addMorphUseAll: messageList. - - self layoutMorph - addMorph: upperPanes proportionalHeight: 0.25; - addAdjusterAndMorph: messageList proportionalHeight: 0.2; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.55. - - self setLabel: model labelString! ! -!PreDebugWindow methodsFor: 'GUI building' stamp: 'HAW 1/12/2017 18:47:35' prior: 50351446! - buttonRowForPreDebugWindow: aDebugger - | row aButton triads buttons | - buttons _ OrderedCollection new. - triads _ OrderedCollection withAll: self preDebugButtonSpec. - aDebugger shouldBeAbleToCreateMethod ifTrue: [ triads add: { 'Create'. #createMethod. 'create the missing method' }]. - - triads do: [ :triad | - aButton _ PluggableButtonMorph new model: self. - aButton label: triad first. - aButton action: triad second. - aButton setBalloonText: triad third. - buttons add: aButton]. - - row _ LayoutMorph newRow. - row doAdoptWidgetsColor. - row color: Color transparent. - row separation: 1. - row addMorphs: buttons. - ^row! ! -!TestRunnerWindow methodsFor: 'constants' stamp: 'jmv 4/16/2011 13:57' prior: 50351469! - runButtonColor - ^ Color green lighter duller! ! -!ProgressBarMorph methodsFor: 'initialization' stamp: 'jmv 12/2/2011 10:52' prior: 50351474! - defaultColor - ^Color white! ! -!ProgressBarMorph methodsFor: 'initialization' stamp: 'jmv 12/2/2011 10:53' prior: 50351478! - initialize - super initialize. - progressColor _ Color gray. - value _ 0.0! ! -!MenuMorph methodsFor: 'construction' stamp: 'len 11/16/2015 02:52' prior: 50351484! -addStayUpIcons - | closeBox pinBox w | - Preferences optionalButtons ifFalse: [ ^self ]. - (self valueOfProperty: #hasStayUpIcons ifAbsent: [ false ]) - ifTrue: [ - self removeProperty: #needsStayUpIcons. - ^self ]. - titleMorph ifNil: [ - "Title not yet there. Flag ourself, so this method is called again when adding title." - self setProperty: #needsStayUpIcons toValue: true. - ^ self]. - closeBox _ PluggableButtonMorph model: self action: #delete. - closeBox icon: Theme current closeIcon; color: Color transparent. - pinBox _ PluggableButtonMorph model: self action: #stayUp. - pinBox icon: Theme current pushPinIcon; color: Color transparent. - w _ (titleMorph hasSubmorphs ifTrue: [ titleMorph firstSubmorph morphWidth ] ifFalse: [ 0 ]) + 60. - self addMorphFront: - (LayoutMorph newRow - "Make room for buttons" - morphExtent: w @ (titleMorph morphHeight max: 19); - color: Color transparent; - addMorph: closeBox fixedWidth: 20; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedWidth: 4; - addMorph: titleMorph proportionalWidth: 1; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedWidth: 4; - addMorph: pinBox fixedWidth: 20). - - self setProperty: #hasStayUpIcons toValue: true. - self removeProperty: #needsStayUpIcons! ! -!MenuMorph methodsFor: 'keyboard control' stamp: 'jmv 6/8/2014 20:32' prior: 50351527! - displayFiltered: evt - | matchStr allItems isMatch matches feedbackMorph | - matchStr _ self valueOfProperty: #matchString. - allItems _ self submorphs select: [ :m | - m is: #MenuItemMorph ]. - matches _ allItems select: [ :m | - isMatch _ matchStr isEmpty or: [ - m contents - includesSubstring: matchStr - caseSensitive: false ]. - m isEnabled: isMatch. - isMatch ]. - feedbackMorph _ self valueOfProperty: #feedbackMorph. - feedbackMorph ifNil: [ - feedbackMorph _ StringMorph new color: Color veryDarkGray. - self addMorphBack: feedbackMorph lock position: (0@ -20). - self - setProperty: #feedbackMorph - toValue: feedbackMorph ]. - feedbackMorph contents: '<' , matchStr , '>'. - matchStr isEmpty ifTrue: [ - feedbackMorph delete. - self removeProperty: #feedbackMorph ]. - matches notEmpty ifTrue: [ - self selectItem: matches first ]! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'jmv 4/14/2016 15:10' prior: 50351557! - drawOn: aCanvas - | rectangle w y0 h y1 y2 scrollbarThickness | - aCanvas frameAndFillRectangle: (0@0 extent: extent) fillColor: self color borderWidth: borderWidth borderColor: borderColor. - y0 _ 1. - w _ extent x-2. - scrollbarThickness _ ScrollBar scrollbarThickness. - completer entryCount > self class itemsPerPage ifTrue: [ - w _ w - scrollbarThickness. - aCanvas - frameRectangle: (extent x - scrollbarThickness@0 - extent: scrollbarThickness @ extent y) - borderWidth: 1 - color: borderColor. - aCanvas - image: (BitBltCanvas arrowOfDirection: #up size: scrollbarThickness) - at: self upButtonPosition. - aCanvas - image: (BitBltCanvas arrowOfDirection: #down size: scrollbarThickness) - at: self downButtonPosition. - h _ extent y - (2 * scrollbarThickness). - y1 _ (1.0 * self firstVisible-1 / completer entryCount * h) ceiling + y0 + scrollbarThickness-1. - y2 _ (1.0 * self lastVisible / completer entryCount * h) floor + y0 + scrollbarThickness -1. - aCanvas - fillRectangle: (extent x - scrollbarThickness+2@y1 corner: extent x-2 @ y2) - color: Color veryLightGray ]. - self firstVisible - to: self lastVisible - do: [ :index | - rectangle _ 1@y0 extent: w@self class itemHeight. - index = self selected - ifTrue: [ - aCanvas fillRectangle: rectangle color: (Theme current listHighlightFocused: true) ]. - aCanvas - drawString: (completer entries at: index) asString - at: rectangle topLeft - font: self class listFont - color: Theme current text. - y0 _ y0 + self itemHeight ]! ! -!AutoCompleterMorph methodsFor: 'initialization' stamp: 'jmv 12/2/2011 10:09' prior: 50351608! - defaultBorderColor - ^ Color gray! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 9/9/2012 23:59' prior: 50351612! - drawOn: aCanvas - "Draw the hand itself (i.e., the cursor)." - "This method is only called when we are carrying morphs around..." - aCanvas - stencil: Cursor move - at: 0@0 - color: Color black! ! -!ImageMorph methodsFor: 'accessing' stamp: 'jmv 3/14/2011 09:15' prior: 50351621! - color: aColor - super color: aColor. - (image depth = 1 and: [aColor is: #Color]) ifTrue: [ - image colors: {Color transparent. aColor}. - self redrawNeeded]! ! -!MenuItemMorph methodsFor: 'accessing' stamp: 'jmv 3/13/2009 10:04' prior: 50351630! - isEnabled: aBoolean - - isEnabled = aBoolean ifTrue: [^ self]. - isEnabled _ aBoolean. - self color: (aBoolean ifTrue: [Color black] ifFalse: [Color gray]). -! ! -!MenuItemMorph methodsFor: 'private' stamp: 'jmv 9/9/2012 23:55' prior: 50351638! - offImage - "Return the form to be used for indicating an '' marker" - | form | - form _ Form extent: (self fontToUse ascent-2) asPoint depth: 16. - form getCanvas - frameAndFillRectangle: form boundingBox fillColor: (Color gray: 0.9) - borderWidth: 1 borderColor: Color black. - ^form! ! -!MenuItemMorph methodsFor: 'private' stamp: 'jmv 9/9/2012 23:55' prior: 50351650! - onImage - "Return the form to be used for indicating an '' marker" - | form | - form _ Form extent: (self fontToUse ascent-2) asPoint depth: 16. - form getCanvas - frameAndFillRectangle: form boundingBox fillColor: (Color gray: 0.8) - borderWidth: 1 borderColor: Color black; - fillRectangle: (form boundingBox insetBy: 2) color: Color black. - ^form! ! -!LayoutMorph methodsFor: 'accessing' stamp: 'jmv 12/1/2015 09:53' prior: 50351664! - adoptWidgetsColor: paneColor - super adoptWidgetsColor: paneColor. - doAdoptWidgetsColor - ifTrue: [ self color: (Theme current buttonColorFrom: paneColor) ] - ifFalse: [ self color: Color transparent ]! ! -!LayoutMorph methodsFor: 'initialization' stamp: 'jmv 8/17/2014 21:38' prior: 50351674! - defaultColor - ^Color gray! ! -!LayoutMorph class methodsFor: 'instance creation' stamp: 'jmv 4/3/2011 22:59' prior: 50351678! - initializedInstance - "Answer a row by default so the 'new morph' menu doesn't fail..." - ^self newRow color: (Color red alpha: 0.2)! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/5/2015 10:57' prior: 50351685! - example1 -" - self example1 -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example1. -pane color: Color red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addMorph: (BorderedRectMorph new color: (Color blue); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addMorph: (BorderedRectMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 20). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #G) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8); - addMorph: (BorderedRectMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (BorderedRectMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -pane morphPosition: 150@130 extent: 400@300. -pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/12/2015 16:42' prior: 50351752! - example10 -" - self example10 openInWorld -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example10. -pane color: Color red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Color blue); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 20). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #G) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8); - addMorph: (BorderedRectMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (BorderedRectMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -^ pane! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/5/2015 10:55' prior: 50351820! - example11 -" - self example11 -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example11. -pane color: Color red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Color blue); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 20). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #G) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8); - addMorph: (BorderedRectMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (BorderedRectMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -pane morphPosition: 150@130 extent: 400@300. -pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/5/2015 11:08' prior: 50351890! - example13 - " - self example13 - " - | pane row innerRow | -pane _ (LayoutMorph newColumn separation: 5) name: #example13. - pane color: Color red. - row _ (LayoutMorph newRow separation: 5) name: #Row. - innerRow _ (LayoutMorph newRow separation: 5) name: #InnerRow; - color: Color red. - innerRow - addMorph: (BorderedRectMorph new name: #Box1) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (BorderedRectMorph new name: #Box2) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (BorderedRectMorph new name: #Bar) - layoutSpec: (LayoutSpec proportionalWidth: 1.0 fixedHeight: 10). - row - color: (Color h: 270 s: 0.2 v: 0.6); - addMorph: innerRow - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 30 minorDirectionPadding: #center); - addMorph: LayoutAdjustingMorph new layoutSpec: (LayoutSpec fixedWidth: 5); - addMorph: (BorderedRectMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #Rect1) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40 minorDirectionPadding: #top); - addMorph: LayoutAdjustingMorph new layoutSpec: (LayoutSpec fixedWidth: 5); - addMorph: (BorderedRectMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #Rect2) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). - pane addMorph: row layoutSpec: (LayoutSpec proportionalHeight: 0.9). - pane morphPosition: 250@130 extent: 400@300. - pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 2/16/2016 13:27' prior: 50351938! - example1b -" -Based on #example1, but using some Morph instead of RectangleLikeMorph -> extent is not adjustable - self example1b -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example1. -pane color: Color red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addMorph: (Morph new name: #B); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addMorph: (BorderedRectMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 20). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (Morph new name: #G); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Color red; - addMorph: (Morph new name: #J); - addMorph: (BorderedRectMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (BorderedRectMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -pane morphPosition: 150@130 extent: 400@300. -pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/5/2015 11:25' prior: 50351999! - example2 - " - self example2 - " - | pane row | - pane _ (LayoutMorph newColumn separation: 5) name: #example2. - pane color: Color red. - row _ (LayoutMorph newRow separation: 5) name: #Row. - row - color: (Color h: 270 s: 0.2 v: 0.6); - addMorph: (BorderedRectMorph new color: (Color h: 120 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8 minorDirectionPadding: #bottom); - addMorph: (BorderedRectMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8 fixedHeight: 40 minorDirectionPadding: #top); - addMorph: (BorderedRectMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 0.7 minorDirectionPadding: #center). - pane addMorph: row layoutSpec: (LayoutSpec proportionalHeight: 0.9). - pane morphPosition: 200@180 extent: 400@300. - pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 11/18/2015 09:45' prior: 50352031! - example20 -" - self example20 -" -| column | - -column _ (LayoutMorph newColumn separation: 5) name: #Column. -column - color: Color red; - addMorph: (BorderedRectMorph new color: (Color h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec proportionalWidth: 0.8 fixedHeight: 20); - addMorph: (BorderedRectMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec fixedWidth: 40 proportionalHeight: 0.5); - addMorph: (BorderedRectMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec proportionalWidth: 1.0 fixedHeight: 30). -column morphPosition: 150@130 extent: 400@300. -column openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/5/2015 11:13' prior: 50352054! - example3 - " - self example3 - " - | pane row innerRow | -pane _ (LayoutMorph newColumn separation: 5) name: #example3. - pane color: Color red. - row _ (LayoutMorph newRow separation: 5) name: #Row. - innerRow _ (LayoutMorph newRow separation: 5) name: #InnerRow; - color: Color red. - innerRow - addMorph: (BorderedRectMorph new name: #Box1) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (BorderedRectMorph new name: #Box2) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (BorderedRectMorph new name: #Bar) - layoutSpec: (LayoutSpec proportionalWidth: 1.0 fixedHeight: 10). - row - color: (Color h: 270 s: 0.2 v: 0.6); - addMorph: innerRow - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 30 minorDirectionPadding: #center); - addMorph: (BorderedRectMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #Rect1) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40 minorDirectionPadding: #top); - addMorph: (BorderedRectMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #Rect2) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). - pane addMorph: row layoutSpec: (LayoutSpec proportionalHeight: 0.9). - pane morphPosition: 250@130 extent: 400@300. - pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 6/8/2014 20:03' prior: 50352097! - example6 - " - Useful example contributed by Ken Dickey - All these should look the same, right? (mmmh this should be a test...) - self example6 - " -| pane rect1 rect2 | -pane _ LayoutMorph newRow separation: 5. "1" -pane addMorph: (StringMorph contents: '1'). - -rect1 := BorderedRectMorph new color: (Color lightOrange); - morphExtent: 20 @ 30. -pane addMorphFront: rect1. -rect2 := BorderedRectMorph new color: (Color cyan); - morphExtent: 20 @ 30. -pane addMorphFront: rect2. -pane - color: Color lightGreen; - morphPosition: 120 @ 50 extent: 180 @ 100; - openInWorld. - -pane _ LayoutMorph newRow separation: 5. "2" -pane addMorph: (StringMorph contents: '2'). - -rect1 := BorderedRectMorph new color: (Color lightOrange); - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 minorDirectionPadding: #center). -pane addMorph: rect1. -rect2 := BorderedRectMorph new color: (Color cyan). -pane addMorph: rect2 - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 minorDirectionPadding: #center). -pane - color: Color lightGreen; - morphPosition: 320 @ 50 extent: 180 @ 100; - openInWorld. - - -pane _ LayoutMorph newRow separation: 5. "3" -pane addMorph: (StringMorph contents: '3'). - -rect1 := BorderedRectMorph new color: (Color lightOrange). -pane addMorph: rect1 - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 minorDirectionPadding: #center). -rect2 := BorderedRectMorph new color: (Color cyan); - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 minorDirectionPadding: #center). -pane addMorph: rect2. -pane - color: Color lightGreen; - morphPosition: 520 @ 50 extent: 180 @ 100; - openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 1/4/2013 13:42' prior: 50352150! - launcherExample - " - self launcherExample - " - | b1 b2 b3 row b4 random buttons | - random _ Random new. - b1 _ PluggableButtonMorph model: [ Date today print ] action: #value label: 'Date'. - b2 _ PluggableButtonMorph model: [ Time now print ] action: #value label: 'Time'. - b3 _ PluggableButtonMorph model: [ SystemVersion current print ] action: #value label: 'Version'. - b4 _ PluggableButtonMorph model: [ random next print ] action: #value label: 'Random'. - buttons _ {b1. b2. b3. b4}. - buttons do: [ :button | - button color: Color lightRed ]. - row _ LayoutMorph newRow - color: Color red; - addMorphs: buttons; - morphExtent: 300 @ 40. - ^ row openInWorld! ! -!ProgressMorph methodsFor: 'initialization' stamp: 'jmv 12/2/2011 10:55' prior: 50352174! - defaultColor - ^Color veryLightGray! ! -!HaloHandleMorph class methodsFor: 'accessing' stamp: 'jmv 11/18/2010 09:44' prior: 50352179! - circleForm: extent - " - CircleForm _ nil - " - | r d l bw center | - (CircleForm isNil or: [ CircleForm extent ~= extent ]) ifTrue: [ - center _ extent -1 * 0.5. - r _ center r * 0.75. - bw _ 1.3. - CircleForm _ Form extent: extent depth: 32. - 0 to: extent y - 1 do: [ :y | - 0 to: extent x - 1 do: [ :x | - d _ (x@y - center) r. - l _ (r - d max: 0.0) min: bw. - CircleForm - colorAt: x @ y - put: (Color white alpha: (l / bw)) - ]]. - ]. - ^CircleForm! ! -!HaloMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:28' prior: 50352197! - defaultColor - "answer the default color/fill style for the receiver" - ^ Color - r: 0.6 - g: 0.8 - b: 1.0! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 5/27/2015 13:42' prior: 50352203! - addHandle: handleSpec - "Add a handle within the halo box as per the haloSpec, and set it up to respond to the given event by sending the given selector to the given recipient. Return the handle." - - | handle aPoint colorToUse form icon | - aPoint _ self - positionIn: haloBox - horizontalPlacement: handleSpec horizontalPlacement - verticalPlacement: handleSpec verticalPlacement. - colorToUse _ Color colorFrom: handleSpec color. - handle _ HaloHandleMorph new color: colorToUse. - self addMorph: handle. - handle morphBoundsInWorld: (Rectangle center: aPoint extent: self class handleSize asPoint). - handleSpec iconSymbol ifNotNil: [ :iconName | - form _ self class icons at: iconName ifAbsent: [self class perform: iconName]. - form ifNotNil: [ - icon _ ImageMorph new - image: form; - color: colorToUse makeForegroundColor; - lock. - handle addMorphFront: icon position: 0@0 ]]. - handle mouseUpSelector: #endInteraction. - handle setBalloonText: handleSpec hoverHelp. - ^handle! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/4/2016 22:14' prior: 50352237! - addNameString: aString - "Add a name display centered beneath the bottom of the outer rectangle. Return the handle." - - | nameMorph namePosition nameBackground | - nameBackground _ RectangleLikeMorph new - color: ((target is: #SystemWindow) ifTrue: [target windowColor] ifFalse: [Color lightBlue alpha: 0.9]). - nameMorph _ StringMorph contents: aString. - nameMorph color: Color black. - nameBackground morphExtent: nameMorph morphExtent + 4. - namePosition _ haloBox width - nameMorph morphWidth // 2 @ (haloBox height). - self addMorph: nameBackground position: namePosition - 2. - self addMorph: nameMorph position: namePosition. - ^nameMorph! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 9/22/2012 15:18' prior: 50352260! - doRot: evt with: rotHandle - "Update the rotation of my target if it is rotatable. Keep the relevant command object up to date." - - | degrees | -self revisar. - self flag: #jmvVer2. - evt hand obtainHalo: self. - degrees _ (evt eventPosition - target referencePosition) degrees. - degrees _ degrees - angleOffset degrees. - degrees _ degrees detentBy: 10.0 atMultiplesOf: 90.0 snap: false. - degrees = 0.0 - ifTrue: [rotHandle color: Color lightBlue] - ifFalse: [rotHandle color: Color blue]. - rotHandle submorphsDo: - [:m | m color: rotHandle color makeForegroundColor]. - self removeAllHandlesBut: rotHandle. - - target rotationDegrees: degrees. - - rotHandle morphPositionInWorld: evt eventPosition - (rotHandle morphExtent // 2)! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 9/20/2012 00:01' prior: 50352286! - setDismissColor: evt with: dismissHandle - "Called on mouseStillDown in the dismiss handle; set the color appropriately." - - | colorToUse | - evt hand obtainHalo: self. - colorToUse _ (dismissHandle morphContainsPoint: (dismissHandle internalizeFromWorld: evt eventPosition)) - ifFalse: [ Color red muchLighter ] - ifTrue: [ Color lightGray ]. - dismissHandle color: colorToUse! ! -!InnerListMorph methodsFor: 'initialization' stamp: 'jmv 5/27/2013 09:39' prior: 50352301! - initialize - super initialize. - self color: Color black. - font _ Preferences standardListFont. - listItems _ #(). - selectedRow _ nil. - selectedRows _ Set new. - highlightedRow _ nil! ! -!InnerTextMorph methodsFor: 'drawing' stamp: 'jmv 10/16/2013 19:55' prior: 50352310! - debugDrawLineRectsOn: aCanvas - "Shows where text line rectangles are" - - self textComposition lines do: [ :line | - aCanvas - frameRectangle: line rectangle - borderWidth: 1 - color: Color brown ] -! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/17/2015 15:51' prior: 50352320! - initialize - super initialize. - extent _ 400@300. - color _ Color white. - grid _ 8@6. - gridLineWidth _ 2. - gridColor _ Color black. - selectionColor _ Color red! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 23:18' prior: 50352329! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - from _ self toGridPoint: localEventPosition. - outlineMorph _ BorderedRectMorph new - borderColor: Color black; - color: Color transparent; - openInWorld; - hide. - self selectTo: localEventPosition! ! -!HoverHelpMorph methodsFor: 'initialization' stamp: 'jmv 9/25/2011 23:12' prior: 50352341! - defaultColor - - ^Color r: 1.0 g: 1.0 b: 0.7! ! -!HoverHelpMorph methodsFor: 'drawing' stamp: 'jmv 12/20/2014 15:09' prior: 50352346! - drawOn: aCanvas - - | r | - r _ self morphLocalBounds. - aCanvas roundRect: r color: self color radius: 4. - aCanvas - textComposition: textComposition - bounds: (r insetBy: 4) - color: Color black - selectionColor: (Theme current textHighlightFocused: false)! ! -!WorldState methodsFor: 'drawing' stamp: 'jmv 3/2/2017 19:40:12' prior: 50352357! - drawInvalidAreasSubmorphs: submorphs - "Redraw the damaged areas of the given canvas and clear the damage list. Return a collection of the areas that were redrawn." - - | initialRectsToRepair currentRectsToRepair newRectsToRepair morphsToDraw rectsForEachMorph thisMorphRects reuse i n morph morphBounds morphClipRect | - - "The simple implementation is slowers as it draws morph areas that will later be covered by other morphs. - But it works, and it is easier to understand. - See en.wikipedia.org/wiki/Painter's_algorithm" - true not ifTrue: [ ^self simpleDrawInvalidAreasSubmorphs: submorphs ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - initialRectsToRepair _ damageRecorder invalidRectsFullBounds: world viewBox. - damageRecorder reset. - currentRectsToRepair _ OrderedCollection new. - newRectsToRepair _ OrderedCollection withAll: initialRectsToRepair. - morphsToDraw _ OrderedCollection new. - rectsForEachMorph _ OrderedCollection new. - thisMorphRects _ OrderedCollection new. - n _ submorphs size. - i _ 1. - - "The idea here is to iterate morphs front to back, i.e. first the ones on top. - For each morph, record the rectangles it affects. And if a morph is opaque, remove the area behind it from the list of rectangles to be repaired. - This means, for example, that morphs completely covered might even not be redrawn. - this is a huge performance gain when there are many morphs on screen, especially if there are more than ten open windows, and Theme uses opaque colors. - See 'A reverse painter's algorithm' at en.wikipedia.org/wiki/Painter's_algorithm" - [ i <= n and: [ newRectsToRepair notEmpty ]] whileTrue: [ - morph _ submorphs at: i. - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - reuse _ currentRectsToRepair. - currentRectsToRepair _ newRectsToRepair. - newRectsToRepair _ reuse removeAll. - currentRectsToRepair do: [ :r | - (morphBounds intersects: r) - ifTrue: [ - morphClipRect _ morphBounds intersect: r. - thisMorphRects add: morphClipRect. "We could perhaps try and join adjacent rectangles in this collection..." - morph addPossiblyUncoveredAreasIn: r to: newRectsToRepair ] - ifFalse: [ - newRectsToRepair add: r ]]. - thisMorphRects ifNotEmpty: [ - morphsToDraw add: morph. - rectsForEachMorph add: thisMorphRects. - thisMorphRects _ OrderedCollection new. - ]]. - i _ i + 1 ]. - - "*make this true to flash damaged areas for testing*" - Preferences debugShowDamage ifTrue: [ world fillRects: initialRectsToRepair color: Color gray ]. - - "Draw world background on those areas that were not completely covered by opaque morphs" - i > n ifTrue: [ - newRectsToRepair do: [ :r | - world drawOn: (canvas newClipRect: r) ]]. - - "Now, draw the recorded areas of selected morphs, back to front." - morphsToDraw with: rectsForEachMorph reverseDo: [ :m :xrects | - "Here we could think about merging all xrects into just one call... - This would mean drawing each morph just once. - But that would mean drawing pixels we were not told to. There could be other morphs in that area that are not even being drawn!! - See WorldState class >> #experiment1" -" rr _ nil." - xrects do: [ :r | -" rr _ rr ifNil: [ r ] ifNotNil: [ r quickMerge: rr ]." - (canvas newClipRect: r) fullDraw: m. - ]. -" (canvas newClipRect: rr) fullDraw: m" - "*make this true to flash damaged areas for testing*" - Preferences debugShowDamage2 ifTrue: [ - world flashRects: xrects color: Color random ]. - ]. - - "Answer a list of rectangles to be updated on the Display. - This usually is not performance critical, drawing morphs is slower than just exposing the Display." - "What should we force on Display? Whatever was asked? Each small rect that was updated? A single bigger rect? - Right now, answer whatever was asked... Maybe this could be changed if that enhances performance... - (think of vnc over slow networks)" - ^ initialRectsToRepair! ! -!WorldState class methodsFor: 'sample code' stamp: 'jmv 3/2/2017 19:39:21' prior: 50352483! - experiment1 - "To play with and learn about morphic Display update logic. - Remove the morphs when done!!" - " - WorldState experiment1 - " - | dr morph1 morph2 s w | - morph1 _ RectangleLikeMorph new openInWorld. - morph2 _ RectangleLikeMorph new openInWorld. - morph2 color: Color green. - morph2 morphPosition: 200@800 extent: 50@40. - morph1 morphPosition: 120@720 extent: 220@100. - - w _ self runningWorld. - s _ w instVarNamed: 'worldState'. - dr _ s instVarNamed: 'damageRecorder'. - - dr doFullRepaint. - dr reset; - " recordInvalidRect: (100@700 corner: 400@900);" - recordInvalidRect: (100@700 corner: 150@900); - recordInvalidRect: (300@700 corner: 400@900). - Display fillColor: Color gray. - "Do not draw the area used by the small rectangle, unless it is also drawn!!" - s drawInvalidAreasSubmorphs: {morph1. morph2 }! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 12/20/2014 15:35' prior: 50352512! - drawCurrentAsError - "The morph (or one of its submorphs) had an error in its drawing method." - | r w | - r _ currentMorph morphLocalBounds. - w _ r extent > (50@50) - ifTrue: [ 6 ] - ifFalse: [ 2 ]. - self - frameAndFillRectangle: r - fillColor: Color red - borderWidth: w - borderColor: Color yellow. - self line: r topLeft to: r bottomRight-w width: w color: Color yellow. - self line: r topRight -(w@0) to: r bottomLeft -(0@w)width: w color: Color yellow! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 6/1/2015 13:30' prior: 50352530! - drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - aColor = Color black ifFalse: [ | topColor | - topColor _ aColor alphaMixed: 0.25 with: Color black. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint - font: fontOrNil - color: topColor ]. - aColor = Color white ifFalse: [ | bottomColor | - bottomColor _ aColor alphaMixed: 0.22 with: Color white. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + (0@2) - font: fontOrNil - color: bottomColor ]. - ^self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + (0@1) - font: fontOrNil - color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 11/29/2015 18:01' prior: 50352557! - fillRectangle: aRectangle color: aColor - "Fill the given rectangle." - - aColor isTransparent ifFalse: [ - self - frameAndFillRectangle: aRectangle - fillColor: aColor - borderWidth: 0 - borderColor: Color transparent ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 11/29/2015 18:14' prior: 50352568! -reverseRectangleBorder: r borderWidth: borderWidth - " - Display getCanvas - reverseRectangleBorder: (10@10 extent: 300@200) - borderWidth: 20. - Display forceToScreen - " - | rect | - rect _ currentTransformation displayBoundsOfTransformOf: r. - port - sourceForm: nil; - fillColor: Color gray; - combinationRule: Form reverse; - frameRect: rect borderWidth: borderWidth! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 4/9/2015 09:46' prior: 50352583! - setPaintColor: aColor - "Install a new color used for filling." - | paintColor | - paintColor _ aColor ifNil: [ Color transparent ]. - (paintColor is: #Color) ifFalse: [ - ^self error: 'Cannot install color' ]. - - "Okay, so paintColor really *is* a color" - port sourceForm: nil. - (paintColor isOpaque or: [ self depth < 32]) ifTrue: [ - port fillColor: paintColor. - port combinationRule: Form paint. - ^self ]. - - "BitBlt setup for alpha mapped transfer" - port fillColor: paintColor. - port combinationRule: Form blend! ! -!BitBltCanvas class methodsFor: 'cached forms' stamp: 'jmv 4/17/2015 12:16' prior: 50352603! - steButtonForm: extent - ^self cachedForms - at: { #steButton . extent } - ifAbsentPut: [ - | form canvas | - form _ Form extent: extent depth: 32. - canvas _ form getCanvas. - canvas - roundRect: (0@0 extent: extent) - color: (Color gray: 0.4) - radius: 4. - canvas - roundRect: (1@1 extent: extent-2) - color: Color white - radius: 4 - gradientTop: 1.0 - gradientCenter: 0.73 - gradientBottom: 0.94 - gradient1Height: (extent y-8+1 max: extent y//2). - form]! ! -!BitBltCanvas class methodsFor: 'cached forms' stamp: 'jmv 4/17/2015 12:16' prior: 50352622! - verticalGrayGradient: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - ^self cachedForms - at: { #vertical. height. gradientTopFactor . gradientBottomFactor } - ifAbsentPut: [ - Form - verticalGradient: height - topColor: (Color gray: gradientTopFactor) - bottomColor: (Color gray: gradientBottomFactor) ]! ! -!BitBltCanvas class methodsFor: 'cached arrow forms' stamp: 'jmv 1/7/2015 08:12' prior: 50352636! - buildArrowOfDirection: aSymbolDirection size: finalSizeInteger - "PRIVATE - create an arrow with aSymbolDirectionDirection, - finalSizeInteger and aColor - - aSymbolDirectionDirection = #up, #down. #left or #right - (self buildArrowOfDirection: #down size: 120) display - (self buildArrowOfDirection: #up size: 120) display - " - - | resizeFactor resizedForm f e c bottomMargin topMargin | - resizeFactor _ 4. - e _ finalSizeInteger@finalSizeInteger*resizeFactor. - f _ Form extent: e depth: 32. - c _ Color gray: 0.5. - topMargin _ finalSizeInteger * 3//4. - bottomMargin _ finalSizeInteger * 4//4. - 0 to: e y-1-bottomMargin do: [ :y | - 0 to: e x -1 do: [ :x | - (e x / 2 - 1 - x) abs * 2 + topMargin < y ifTrue: [ - f colorAt: x@y put: c - ] - ] - ]. - resizedForm _ f - magnify: f boundingBox - by: 1 / resizeFactor - smoothing: 4. - - aSymbolDirection == #right ifTrue: [ - resizedForm _ resizedForm rotatedByDegrees: 90 ]. - aSymbolDirection == #down ifTrue: [ - resizedForm _ resizedForm rotatedByDegrees: 180 ]. - aSymbolDirection == #left ifTrue: [ - resizedForm _ resizedForm rotatedByDegrees: 270 ]. - - aSymbolDirection == #up ifFalse: [ - resizedForm _ resizedForm - copy: (resizedForm boundingBox insetBy: (resizedForm width - finalSizeInteger/ 2.0) rounded) ]. - - ^resizedForm! ! -!BitBltCanvas class methodsFor: 'cached arrow forms' stamp: 'jmv 10/9/2014 23:02' prior: 50352680! - buildArrowWith: insideForm borderForm: borderForm - | extent translucentForm color insideSpec borderSpec border background alpha| - " - Display getCanvas - image: (BitBltCanvas buildArrowWith: BitBltCanvas downInsideForm borderForm: BitBltCanvas downBorderForm) - at: 20@20 - Display getCanvas - image: (BitBltCanvas buildArrowWith:BitBltCanvas upInsideForm borderForm: BitBltCanvas upBorderForm) - at: 40@20 - " - extent _ insideForm extent - (1@2). - translucentForm _ Form extent: insideForm extent depth: 32. - 0 to: extent x-1 do: [ :x | - 0 to: extent y-1 do: [ :y | - insideSpec _ insideForm colorAt: x@(y+1). - borderSpec _ borderForm colorAt: x@(y+1). - insideSpec = (Color r: 0.0 g: 0.0 b: 1.0) - ifTrue: [ color _ Color transparent ] - ifFalse: [ - borderSpec = (Color r: 1.0 g: 0.0 b: 0.0) - ifTrue: [ color _ insideSpec ] - ifFalse: [ - border _ x < (extent x//2) - ifTrue: [Color white] - ifFalse: [Color black]. - background _ borderForm colorAt: extent x@(y+1). - alpha _ borderSpec red asFloat - background red / (border red - background red). - color _ border alpha: (alpha min: 1 max: 0) ]]. - translucentForm colorAt: x@y put: color ]]. - ^translucentForm! ! -!Theme methodsFor: 'colors' stamp: 'jmv 11/19/2010 14:06' prior: 50352721! - background - ^ Color r: 0.7 g: 0.72 b: 0.83! ! -!Theme methodsFor: 'colors' stamp: 'jmv 11/23/2010 09:42' prior: 50352725! - buttonColorFrom: aColor - ^ Display depth <= 8 - ifTrue: [ Color transparent ] - ifFalse: [ aColor paler ]! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/14/2011 08:50' prior: 50352731! - buttonLabel - ^Color gray: 0.18! ! -!Theme methodsFor: 'colors' stamp: 'len 6/9/2016 17:38' prior: 50352735! - errorColor - ^ Color red lighter! ! -!Theme methodsFor: 'colors' stamp: 'len 6/9/2016 17:40' prior: 50352739! - failureColor - ^ Color yellow lighter! ! -!Theme methodsFor: 'colors' stamp: 'len 11/14/2015 02:34' prior: 50352743! - scrollbarButtonColor - ^Color gray: 0.95! ! -!Theme methodsFor: 'colors' stamp: 'len 11/17/2015 23:55' prior: 50352747! - scrollbarColor - ^Color white! ! -!Theme methodsFor: 'colors' stamp: 'len 11/14/2015 02:34' prior: 50352751! - scrollbarSliderShadowColor - ^Color white! ! -!Theme methodsFor: 'colors' stamp: 'len 6/9/2016 17:38' prior: 50352755! - successColor - ^ Color green lighter! ! -!Theme methodsFor: 'colors' stamp: 'cbr 11/7/2010 18:00' prior: 50352759! - text - ^ Color black! ! -!Theme methodsFor: 'colors' stamp: 'jmv 10/16/2013 22:08' prior: 50352763! - textCursor - ^ Display depth <= 2 - ifTrue: [ Color black ] - ifFalse: [ self text ]! ! -!Theme methodsFor: 'colors' stamp: 'jmv 5/30/2011 14:31' prior: 50352769! - textHighlight - "A nice light blue." - " - ^ Color r: 0.71 g: 0.835 b: 1.0 - ^ Color hue: 214 chroma: 0.29 luminance: 0.816 - " - ^Color hue: 204 chroma: 0.29 luminance: 0.77! ! -!Theme methodsFor: 'colors' stamp: 'jmv 11/23/2010 09:58' prior: 50352777! - textHighlightFocused: focused - "A nice light blue." - | textHighlight | - Display depth = 1 ifTrue: [^ Color veryLightGray]. - Display depth = 2 ifTrue: [^ Color gray: 0.87]. - textHighlight _ self textHighlight. - ^focused - ifTrue: [ textHighlight ] - ifFalse: [ self unfocusedTextHighlightFrom: textHighlight ]! ! -!Theme methodsFor: 'colors' stamp: 'cbr 12/6/2010 20:08' prior: 50352790! - windowLabel - ^Color gray: 0.3! ! -!Theme methodsFor: 'menu colors' stamp: 'jmv 5/26/2011 09:07' prior: 50352794! - menu - Display depth <= 2 ifTrue: [^ Color white]. - ^Color r: 0.75 g: 0.75 b: 0.75 alpha: 0.93! ! -!Theme methodsFor: 'menu colors' stamp: 'jmv 11/23/2010 09:45' prior: 50352800! - menuHighlight - ^ Display depth < 8 - ifTrue: [ Color veryLightGray ] - ifFalse: [ self textHighlight ]! ! -!Theme methodsFor: 'menu colors' stamp: 'cbr 11/7/2010 18:28' prior: 50352806! - menuText - ^ Color black! ! -!Theme methodsFor: 'menu colors' stamp: 'jmv 11/28/2010 08:04' prior: 50352810! - menuTitleBar - Display depth = 1 ifTrue: [^ Color white]. - Display depth = 2 ifTrue: [^ Color gray]. - ^ self menu darker! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 4/15/2011 14:59' prior: 50352817! - browser - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Color r: 0.5 g: 0.7 b: 0.4]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 2/14/2013 11:05' prior: 50352824! - debugger - ^Color h: 0.0 s: 0.6 v: 0.7! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 11/23/2010 09:16' prior: 50352828! - defaultWindowColor - ^ Color lightGray! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 11/18/2010 12:44' prior: 50352832! - fileContentsBrowser - ^Color tan duller! ! -!Theme methodsFor: 'tool colors' stamp: 'cbr 12/4/2010 18:44' prior: 50352836! - fileList - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Color r: 0.7 g: 0.55 b: 0.7 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 5/23/2012 19:23' prior: 50352843! - messageNames - - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Color r: 0.53 g: 0.77 b: 0.382 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'cbr 12/4/2010 18:45' prior: 50352850! - messageSet - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Color r: 0.45 g: 0.6 b: 0.85 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 11/18/2010 12:44' prior: 50352857! - object - ^Color white duller! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/28/2012 09:41' prior: 50352861! - packageList - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Color r: 0.63 g: 0.47 b: 0.08 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 11/23/2010 09:17' prior: 50352868! - testRunner - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ (Color r: 0.650 g: 0.753 b: 0.976) duller ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/16/2011 08:15' prior: 50352875! - textEditor - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Color gray: 0.6 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'cbr 12/4/2010 18:45' prior: 50352881! - transcript - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Color r: 0.8 g: 0.6 b: 0.3 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'cbr 12/18/2010 17:56' prior: 50352888! - versionsBrowser - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ (Color r: 0.869 g: 0.753 b: 1.0) duller ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/16/2011 08:13' prior: 50352895! - workspace - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Color h: 60.0 s: 0.73 v: 0.72 ]! ! -!Theme methodsFor: 'widget colors' stamp: 'jmv 5/23/2012 18:49' prior: 50352902! - acceptButton - - ^ self buttonColorFrom: - (self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Color r: 0.2 g: 0.6 b: 0.1 ])! ! -!Theme methodsFor: 'widget colors' stamp: 'jmv 5/23/2012 18:51' prior: 50352910! - cancelButton - - ^ self buttonColorFrom: - (self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Color r: 0.8 g: 0.2 b: 0.2 ])! ! -!Theme methodsFor: 'widget colors' stamp: 'cbr 10/10/2012 23:36' prior: 50352918! - textPane - ^Color white! ! -!SHTextStylerST80 class methodsFor: 'style table' stamp: 'pb 5/4/2016 17:44' prior: 50352922! - initialTextAttributes - | d element color emphasis attrArray | - d _ IdentityDictionary new. - self styleTable do: [ :each | - element _ each first. - color _ each at: 2 ifAbsent: nil. - color _ color ifNotNil: [ Color colorFrom: color ]. - emphasis _ each at: 3 ifAbsent: nil. - attrArray _ self attributeArrayForColor: color emphasis: emphasis. - attrArray notEmpty ifTrue: [ - d at: element put: attrArray ]]. - ^ d! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3111-ChangeReferencesBackToColor-JuanVuletich-2017Jun19-12h05m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3106] on 19 June 2017 at 11:52:30 am'! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/19/2017 12:10:13' prior: 50352946! - * aNumber - "Answer this color with its RGB multiplied by the given number. " - " - (Colour brown *2) display - " - ^ (Color new - setRed: (self red * aNumber min: 1.0 max: 0.0) - green: (self green * aNumber min: 1.0 max: 0.0) - blue: (self blue * aNumber min: 1.0 max: 0.0)) - alpha: self alpha! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - -| all | -all := Colour allInstances. -all elementsForwardIdentityTo: (all collect: [ :c | c * 1 ]). -all := TranslucentColour allInstances. -all elementsForwardIdentityTo: (all collect: [ :c | c * 1 ]).! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3112-MigrateInstancesToColor-JuanVuletich-2017Jun19-11h51m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3111] on 19 June 2017 at 12:11:51 pm'! - -Smalltalk removeClassNamed: #Colour! - -Smalltalk removeClassNamed: #Colour! - -Smalltalk removeClassNamed: #TranslucentColour! - -Smalltalk removeClassNamed: #TranslucentColour! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3113-RemoveColour-JuanVuletich-2017Jun19-12h11m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3113] on 19 June 2017 at 3:22:14 pm'! - -InnerPluggableMorph subclass: #InnerListMorph - instanceVariableNames: 'listItems font selectedRow selectedRows highlightedRow ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #InnerListMorph category: #'Morphic-Views'! -InnerPluggableMorph subclass: #InnerListMorph - instanceVariableNames: 'listItems font selectedRow selectedRows highlightedRow' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! -!InnerListMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 15:21:44' prior: 50360534! - initialize - super initialize. - self color: Color black. - font _ Preferences standardListFont. - listItems _ #(). - selectedRow _ nil. - highlightedRow _ nil! ! -!InnerListMorph methodsFor: 'list management' stamp: 'jmv 6/19/2017 15:21:40' prior: 16855089! - listChanged - "set newList to be the list of strings to display" - listItems _ Array new: self getListSize withAll: nil. - selectedRow _ nil. - self adjustExtent! ! -!InnerListMorph methodsFor: 'private' stamp: 'jmv 6/19/2017 15:21:48' prior: 16855308! - noSelection - selectedRow _ nil. - highlightedRow _ nil! ! - -InnerPluggableMorph subclass: #InnerListMorph - instanceVariableNames: 'listItems font selectedRow highlightedRow' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #InnerListMorph category: #'Morphic-Views'! -InnerPluggableMorph subclass: #InnerListMorph - instanceVariableNames: 'listItems font selectedRow highlightedRow' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3114-removeAnUnusedIvar-JuanVuletich-2017Jun19-15h21m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3113] on 19 June 2017 at 4:40:20 pm'! -!Object methodsFor: 'private' stamp: 'jmv 6/19/2017 16:14:39' prior: 16882717! - primitiveError: aString - "This method is called when the error handling results in a recursion in - calling on error: or halt or halt:." - - | context emergencyEvaluator lines r | - r _ `10@10` extent: (Display extent -20 min: `700@1000`). - lines _ r height // AbstractFont default height. - emergencyEvaluator _ Transcripter newInFrame: r. - emergencyEvaluator - nextPutAll: '***System error handling failed***'; newLine; - nextPutAll: aString; newLine; - nextPutAll: '-------------------------------'; newLine. - context _ thisContext sender sender. - (30 min: lines - 10) timesRepeat: [context ifNotNil: [emergencyEvaluator print: (context _ context sender); newLine]]. - emergencyEvaluator - nextPutAll: '-------------------------------'; newLine; - nextPutAll: 'Type ''revert'' to revert your last method change.'; newLine; - nextPutAll: 'Type ''exit'' to exit the emergency evaluator.'; newLine. - emergencyEvaluator readEvalPrint! ! -!InputSensor methodsFor: 'private' stamp: 'jmv 6/19/2017 15:53:29' prior: 16856661! - primMousePt - "Primitive. Poll the mouse to find out its position. Return a Point. Fail if - event-driven tracking is used instead of polling. Optional. See Object - documentation whatIsAPrimitive." - - - ^ `0@0`! ! -!EventSensor methodsFor: 'initialization' stamp: 'jmv 6/19/2017 15:48:40' prior: 16839804! - initialize - "Run the I/O process" - mouseButtons _ 0. - mousePosition _ `0@0`. - self setInterruptKey: (interruptKey ifNil: [$. numericValue bitOr: 16r0800 ]). "cmd-." - interruptSemaphore _ (Smalltalk specialObjectsArray at: 31) ifNil: [Semaphore new]. - self flushAllButDandDEvents. - inputSemaphore _ Semaphore new. - hasInputSemaphore _ false. - - self primSetInputSemaphore: (Smalltalk registerExternalObject: inputSemaphore). - self installInterruptWatcher. - self installEventTickler. - self flushAllButDandDEvents. - - "Attempt to discover whether the input semaphore is actually being signaled." - hasInputSemaphore _ false. - inputSemaphore initSignals! ! -!String methodsFor: 'displaying' stamp: 'jmv 6/19/2017 16:12:23' prior: 16917029! - displayOn: aDisplayMedium - "Display the receiver on the given DisplayMedium. 5/16/96 sw" - - self displayOn: aDisplayMedium at: `0 @ 0`! ! -!Bitmap methodsFor: 'as yet unclassified' stamp: 'jmv 6/19/2017 15:45:57' prior: 16787594! - asByteArray - "Faster way to make a byte array from me. - copyFromByteArray:, if receiver is BigEndian makes equal Bitmap. - Assume receiver bytes-in-word mapping is BigEndian: - Most significant bye of first word in self goes to first position in result. - This means that for a BigEndian 8bpp Form, pixels are in the right order in the ByteArray - - Form lena asGrayForm bits asByteArray copyFrom: 1 to: 4. - (Form lena asGrayForm asFormOfDepth: 8) bits asByteArray copyFrom: 1 to: 4. - (0 to: 3) collect: [ :x | ((Form lena asGrayForm colorAt: x@0) luminance * 255) rounded ]. - " - | f bytes hack | - f _ Form extent: 4@self size depth: 8 bits: self. - bytes _ ByteArray new: self size * 4. - hack _ Form new hackBits: bytes. - Smalltalk isLittleEndian ifTrue: [hack swapEndianness]. - hack copyBits: f boundingBox - from: f - at: `0@0` - clippingBox: hack boundingBox - rule: Form over. - - "f displayOn: hack." - ^ bytes! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 6/19/2017 16:12:37' prior: 50335412! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag -"WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " -| activeProc | -activeProc _ Processor activeProcess. -[ - | isARealStartup world reopenTranscript | - self logSapshot: save andQuit: quit. - - reopenTranscript _ false. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | each isInWorld ifTrue: [ each delete. reopenTranscript _ true ]]. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - - - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - - "Cosas que levanto explicitamente abajo" - world _ ProjectX ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "world _ clearAllStateFlag ifFalse: [ ProjectX ui ]." - ProjectX stopUIProcess. - activeProc isTerminated ifFalse: [ - activeProc terminate ]. - - "Clean Globals" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: nil. - Smalltalk closeSourceFiles. Smalltalk at: #SourceFiles put: nil. - Smalltalk allClassesDo: [ :cls | cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ Smalltalk printStuffToCleanOnImageSave ]. - - - "Do image save & quit as apropriate" - Cursor write activateCursor. - save - ifTrue: [ - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - - - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: (DisplayScreen extent: `1024@768` depth: 32). - Smalltalk at: #SourceFiles put: (Array new: 2). - Smalltalk openSourceFiles. - - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - - - ProjectX spawnNewMorphicProcessFor: (world ifNil: [ PasteUpMorph newWorld ]). - - reopenTranscript ifTrue: [ - WorldState addDeferredUIMessage: [ - TranscriptWindow openTranscript ]]. - " - WorldState addDeferredUIMessage: [ - world fullRepaintNeeded ]. - " - - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - WorldState addDeferredUIMessage: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]. - -] forkAt: Processor timingPriority-1 named: 'Startup process'.! ! -!Transcripter methodsFor: 'accessing' stamp: 'jmv 6/19/2017 16:13:36' prior: 50357756! - 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]. - textComposition - setModel: (TextModel withText: c asText); - extentForComposing: frame width-8 @9999. - textComposition composeAll. - d _ textComposition usedHeight - frame height. - d > 0 ifTrue: [ - "Scroll up to keep all contents visible" - cb _ textComposition characterBlockAtPoint: - `0@0` + (0@(d+AbstractFont default height)). - self on: (c copyFrom: cb stringIndex to: c size). - readLimit _ position _ collection size. - ^ self endEntry]. - Display fill: (frame insetBy: -2) fillColor: self black; - fill: frame fillColor: self white. - Display getCanvas - textComposition: textComposition - bounds: (`4@4` + frame topLeft extent: Display extent) - color: Color black - selectionColor: Color blue. - DisplayScreen screenUpdateRequired: nil! ! -!Transcripter class methodsFor: 'utilities' stamp: 'jmv 6/19/2017 15:58:42' prior: 16938949! - emergencyEvaluator - (Transcripter newInFrame: `0@0 corner: 320@200`) - show: 'Type ''exit'' to exit the emergency evaluator.'; - readEvalPrint! ! -!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'jmv 6/19/2017 16:15:27' prior: 50342770! - defaultAction - - | delta textFrame barFrame outerFrame result range width filledWidth f h textWidth textForm innerBarFrame oldFilledWidth oldFilledWidth2 prevContents | - f _ AbstractFont default. - h _ f height * 3//2. - textWidth _ (f widthOfString: progressTitle) + h. - width _ 150 max: textWidth. - - textForm _ Form extent: width@h depth: 32. - textForm fillBlack. - textForm fillWhite: (textForm boundingBox insetBy: 2). - progressTitle displayOn: textForm at: (width-textWidth+h//2@4). - barFrame _ Rectangle center: aPoint extent: width@h. - textFrame _ `0@0` extent: width@h. - textFrame _ textFrame - aligned: textFrame bottomCenter - with: barFrame topCenter + `0@2`. - outerFrame _ barFrame merge: textFrame. - delta _ outerFrame amountToTranslateWithin: Display boundingBox. - barFrame _ barFrame translatedBy: delta. - textFrame _ textFrame translatedBy: delta. - outerFrame _ outerFrame translatedBy: delta. - prevContents _ Form fromDisplay: outerFrame. - range _ maxVal = minVal ifTrue: [1] ifFalse: [maxVal - minVal]. "Avoid div by 0" - innerBarFrame _ barFrame insetBy: 2. - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - oldFilledWidth _ 0. - oldFilledWidth2 _ 0. - result _ workBlock value: "Supply the bar-update block for evaluation in the work block" - [ :barVal | - barVal - ifNotNil: [ currentVal _ barVal ] - ifNil: [ - currentVal _ currentVal + 1. - currentVal >= maxVal - ifTrue: [ currentVal _ minVal ]]. - filledWidth _ ((barFrame width-4) asFloat * ((currentVal-minVal) asFloat / range min: 1.0)) asInteger. - filledWidth > oldFilledWidth ifTrue: [ - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - Display fillGray: (barFrame topLeft + `2@2` extent: filledWidth@17). - filledWidth -200 > oldFilledWidth2 - ifFalse: [ - "Usually just request an update, to be done asynchronously." - DisplayScreen screenUpdateRequired: outerFrame ] - ifTrue: [ - "Once in a while, force a real screen update (warning: really slow on MacOS if done too often)" - Display forceToScreen: outerFrame. oldFilledWidth2 _ filledWidth ]. - oldFilledWidth _ filledWidth ]]. - prevContents displayAt: outerFrame topLeft. - self resume: result! ! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 6/19/2017 16:10:37' prior: 16898287! - staggerOffset - ^`6 @ 20`! ! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 6/19/2017 16:10:46' prior: 16898320! - standardWindowExtent - "Answer the standard default extent for new windows. " - - | effectiveExtent width strips height grid allowedArea maxLevel | - effectiveExtent _ self maximumUsableArea extent - - (self scrollBarSetback @ self screenTopSetback). - Preferences reverseWindowStagger ifTrue: - ["NOTE: following copied from strictlyStaggeredInitialFrameFor:" - allowedArea _ self maximumUsableArea insetBy: ( - self scrollBarSetback @ self screenTopSetback extent: `0@0` - ). - "Number to be staggered at each corner (less on small screens)" - maxLevel _ allowedArea area > 700000 ifTrue: [3] ifFalse: [2]. - "Amount by which to stagger (less on small screens)" - grid _ allowedArea area > 700000 ifTrue: [40] ifFalse: [20]. - ^ (allowedArea extent - (grid*(maxLevel+1*2) + (grid//2))) min: `52@40` * Preferences standardCodeFont height ]. - width _ (strips _ self windowColumnsDesired) > 1 - ifTrue: - [effectiveExtent x // strips] - ifFalse: - [(3 * effectiveExtent x) // 4]. - height _ (strips _ self windowRowsDesired) > 1 - ifTrue: - [effectiveExtent y // strips] - ifFalse: - [(3 * effectiveExtent y) //4]. - ^ width @ height - -"RealEstateAgent standardWindowExtent"! ! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 6/19/2017 16:10:58' prior: 16898360! - strictlyStaggeredInitialFrameFor: aStandardSystemView initialExtent: initialExtent world: aWorld - "This method implements a staggered window placement policy that I (di) like. - Basically it provides for up to 4 windows, staggered from each of the 4 corners. - The windows are staggered so that there will always be a corner visible." - - | allowedArea grid initialFrame otherFrames cornerSel corner delta putativeCorner free maxLevel | - allowedArea := (self maximumUsableAreaInWorld: aWorld) - insetBy: (self scrollBarSetback @ self screenTopSetback extent: `0 @ 0`). - "Number to be staggered at each corner (less on small screens)" - maxLevel := allowedArea area > 300000 ifTrue: [3] ifFalse: [2]. - "Amount by which to stagger (less on small screens)" - grid := allowedArea area > 500000 ifTrue: [40] ifFalse: [20]. - initialFrame := `0 @ 0` extent: initialExtent. - "min: (allowedArea extent - (grid*(maxLevel+1*2) + (grid//2)))) - min: 600@400" - otherFrames := (SystemWindow windowsIn: aWorld satisfying: [ :w | w visible and: [w isCollapsed not]]) - collect: [:w | w morphBoundsInWorld]. - otherFrames _ otherFrames reject: [ :f | f isNil ]. - 0 to: maxLevel do: [ :level | - 1 to: 4 do: [:ci | - cornerSel := #(#topLeft #topRight #bottomRight #bottomLeft) at: ci. - corner := allowedArea perform: cornerSel. - "The extra grid//2 in delta helps to keep title tabs distinct" - delta := ((maxLevel - level) * grid + (grid // 2)) @ (level * grid). - 1 to: ci - 1 do: [ :i | delta _ delta y negated @ delta x ]. "slow way" - putativeCorner := corner + delta. - free := true. - otherFrames do: [ :w | - free := free & ((w perform: cornerSel) ~= putativeCorner)]. - free - ifTrue: [ - ^(initialFrame aligned: (initialFrame perform: cornerSel) - with: putativeCorner) translatedAndSquishedToBeWithin: allowedArea]]]. - "If all else fails..." - ^(self scrollBarSetback @ self screenTopSetback - extent: initialFrame extent) translatedAndSquishedToBeWithin: allowedArea! ! -!Form methodsFor: 'accessing' stamp: 'jmv 6/19/2017 15:50:37' prior: 16846782! - offset - ^offset ifNil:[`0@0`]! ! -!Form methodsFor: 'analyzing' stamp: 'jmv 6/19/2017 15:51:14' prior: 16846919! - primCountBits - "Count the non-zero pixels of this form." - self depth > 8 ifTrue: - [^(self asFormOfDepth: 8) primCountBits]. - ^ (BitBlt toForm: self) - fillColor: (Bitmap with: 0); - destRect: (`0@0` extent: width@height); - combinationRule: 32; - copyBits! ! -!Form methodsFor: 'analyzing' stamp: 'jmv 6/19/2017 15:51:36' prior: 16846929! - tallyPixelValuesInRect: destRect into: valueTable - "Tally the selected pixels of this Form into valueTable, a Bitmap of depth 2^depth similar to a color map. Answer valueTable." - - (BitBlt toForm: self) - sourceForm: self; "src must be given for color map ops" - sourceOrigin: `0@0`; - colorMap: valueTable; - combinationRule: 33; - destRect: destRect; - copyBits. - ^ valueTable - -" -Move a little rectangle around the screen and print its tallies... - | r tallies nonZero | -Cursor blank showWhile: [ -[Sensor isAnyButtonPressed] whileFalse: - [r _ Sensor mousePoint extent: 10@10. - Display border: (r expandBy: 2) width: 2 rule: Form reverse fillColor: nil. - tallies _ (Display copy: r) tallyPixelValues. - nonZero _ (1 to: tallies size) select: [:i | (tallies at: i) > 0] - thenCollect: [:i | (tallies at: i) -> (i-1)]. - Display fill: (0@0 extent: Display width@20) fillColor: Color white. - nonZero printString , ' ' displayAt: 0@0. - Display border: (r expandBy: 2) width: 2 rule: Form reverse fillColor: nil]] -"! ! -!Form methodsFor: 'analyzing' stamp: 'jmv 6/19/2017 15:51:54' prior: 16846963! - xTallyPixelValue: pv orNot: not - "Return an array of the number of pixels with value pv by x-value. - Note that if not is true, then this will tally those different from pv." - | cm slice countBlt copyBlt | - cm _ self newColorMap. "Map all colors but pv to zero" - not ifTrue: [cm atAllPut: 1]. "... or all but pv to one" - cm at: pv+1 put: 1 - (cm at: pv+1). - slice _ Form extent: 1@height. - copyBlt _ (BitBlt destForm: slice sourceForm: self - combinationRule: Form over - destOrigin: `0@0` sourceOrigin: `0@0` extent: 1 @ slice height - clipRect: slice boundingBox) - colorMap: cm. - countBlt _ (BitBlt toForm: slice) - fillColor: (Bitmap with: 0); - destRect: (`0@0` extent: slice extent); - combinationRule: 32. - ^ (0 to: width-1) collect: - [:x | - copyBlt sourceOrigin: x@0; copyBits. - countBlt copyBits]! ! -!Form methodsFor: 'analyzing' stamp: 'jmv 6/19/2017 15:52:04' prior: 16846991! - yTallyPixelValue: pv orNot: not - "Return an array of the number of pixels with value pv by y-value. - Note that if not is true, then this will tally those different from pv." - | cm slice copyBlt countBlt | - cm _ self newColorMap. "Map all colors but pv to zero" - not ifTrue: [cm atAllPut: 1]. "... or all but pv to one" - cm at: pv+1 put: 1 - (cm at: pv+1). - slice _ Form extent: width@1. - copyBlt _ (BitBlt destForm: slice sourceForm: self - combinationRule: Form over - destOrigin: `0@0` sourceOrigin: `0@0` extent: slice width @ 1 - clipRect: slice boundingBox) - colorMap: cm. - countBlt _ (BitBlt toForm: slice) - fillColor: (Bitmap with: 0); - destRect: (`0@0` extent: slice extent); - combinationRule: 32. - ^ (0 to: height-1) collect: - [:y | - copyBlt sourceOrigin: 0@y; copyBits. - countBlt copyBits]! ! -!Form methodsFor: 'coloring' stamp: 'jmv 6/19/2017 15:50:16' prior: 16847123! - fillShape: aShapeForm fillColor: aColor - "Fill a region corresponding to 1 bits in aShapeForm with aColor" - - ^ self fillShape: aShapeForm fillColor: aColor at: `0@0`! ! -!Form methodsFor: 'coloring' stamp: 'jmv 6/19/2017 15:50:23' prior: 16847131! - fillShape: aShapeForm fillColor: aColor at: location - "Fill a region corresponding to 1 bits in aShapeForm with aColor" - - ((BitBlt destForm: self sourceForm: aShapeForm fillColor: aColor - combinationRule: Form paint - destOrigin: location + aShapeForm offset sourceOrigin: `0@0` - extent: self extent clipRect: self boundingBox) - colorMap: (Bitmap with: 0 with: 16rFFFFFFFF)) - copyBits! ! -!Form methodsFor: 'color mapping' stamp: 'jmv 6/19/2017 15:50:33' prior: 50358106! - mapColor: oldColor to: newColor - "Make all pixels of the given color in this Form to the given new color." - "Warnings: This method modifies the receiver. It may lose some color accuracy on 32-bit Forms, since the transformation uses a color map with only 15-bit resolution." - - | map | - map _ (Color cachedColormapFrom: self depth to: self depth) copy. - map at: (oldColor indexInMap: map) put: (newColor pixelWordForDepth: self depth). - (BitBlt toForm: self) - sourceForm: self; - sourceOrigin: `0@0`; - combinationRule: Form over; - destX: 0 destY: 0 width: width height: height; - colorMap: map; - copyBits. -! ! -!Form methodsFor: 'converting' stamp: 'jmv 6/19/2017 15:49:08' prior: 16847321! - asFormOfDepth: d - | newForm source | - d = depth ifTrue: [ ^self ]. - source _ (self depth = 32 and: [ d abs < 32 ]) - ifTrue: [ self copy convertAlphaToZeroValueTransparency ] - ifFalse: [ self ]. - newForm _ Form extent: source extent depth: d. - (BitBlt toForm: newForm) - colorMap: (source colormapIfNeededFor: newForm); - copy: source boundingBox - from: `0@0` in: source - fillColor: nil rule: Form over. - "If we build a 32bpp from one of smaller depth, - it will have zero in the alpha channel (until BitBlt is fixed!!)" - (newForm depth = 32 and: [self depth < 32]) ifTrue: [ - newForm fixAlpha ]. - ^newForm! ! -!Form methodsFor: 'converting' stamp: 'jmv 6/19/2017 15:49:12' prior: 16847342! - asGrayForm - | answer map | - - "For lower bit depths, the 15 bit ColorMap loses no information, - and answers the real #luminance of each pixel." - self depth < 32 ifTrue: [ - answer _ GrayForm extent: width@height. - map _ self colormapIfNeededForGray8bpp. - (BitBlt toForm: answer) - colorMap: map; - copy: self boundingBox - from: `0@0` in: self - fillColor: nil rule: Form over. - answer offset: self offset. - ^ answer ]. - - "For 32bpp, the approach below would use just 5bits per component. - Generally it is best to extract a component in full 8bpp and keep full dynamic range. - Green usually is a good choice." - ^ self asGrayForm: 3! ! -!Form methodsFor: 'converting' stamp: 'jmv 6/19/2017 15:49:19' prior: 16847364! - asGrayForm: componentIndex -"Native depth" - "Assume the receiver is a grayscale image. Return a GrayForm computed by extracting the brightness levels of one color component. This technique allows a 32-bit Form to be converted to an 8-bit GrayForm to save space while retaining a full 255 levels of gray. (The usual colormapping technique quantizes to 8, 16, or 32 levels, which loses information.) - - If component = 1, take the alpha component - If component = 2, take the red component - If component = 3, take the green component - If component = 4, take the blue component - " - | f32 result map mask shift | - self depth = 32 ifFalse: [ - f32 _ Form extent: width@height depth: 32. - self displayOn: f32. - ^ f32 asGrayForm: componentIndex ]. - - result _ GrayForm extent: width@height. - shift _ #(-24 -16 -8 0) at: componentIndex. - mask _ #(16rFF000000 16rFF0000 16rFF00 16rFF) at: componentIndex. - map _ ColorMap masks: { mask. 0. 0. 0 } shifts: { shift. 0. 0. 0 }. - (BitBlt toForm: result) - sourceForm: self; - combinationRule: Form over; - colorMap: map; - sourceRect: (`0@0` extent: width@height); - destOrigin: `0@0`; - copyBits. - ^ result! ! -!Form methodsFor: 'converting' stamp: 'jmv 6/19/2017 15:49:38' prior: 16847425! - asGrayScaleAndTransparent: componentIndex -"Native depth" - "Assume the receiver is a grayscale image. Return a grayscale ColorForm computed by extracting the brightness levels of one color component. This technique allows a 32-bit Form to be converted to an 8-bit ColorForm to save space while retaining a full 255 levels of gray. (The usual colormapping technique quantizes to 8, 16, or 32 levels, which loses information.) - - If component = 1, take the alpha component - If component = 2, take the red component - If component = 3, take the green component - If component = 4, take the blue component - " - | f32 result map mask shift | - self depth = 32 ifFalse: [ - f32 _ Form extent: width@height depth: 32. - self displayOn: f32. - ^ f32 asGrayScaleAndTransparent: componentIndex ]. - - result _ ColorForm grayScaleAndTransparentExtent: width@height. - shift _ #(-24 -16 -8 0) at: componentIndex. - mask _ #(16rFF000000 16rFF0000 16rFF00 16rFF) at: componentIndex. - map _ ColorMap masks: { mask. 0. 0. 0 } shifts: { shift. 0. 0. 0 }. - (BitBlt toForm: result) - sourceForm: self; - combinationRule: Form over; - colorMap: map; - sourceRect: (`0@0` extent: width@height); - destOrigin: `0@0`; - copyBits. - - "final BitBlt to zero-out pixels that were truely transparent in the original" - map _ Bitmap new: 512. - map at: 1 put: 16rFF. - (BitBlt toForm: result) - sourceForm: self; - sourceRect: self boundingBox; - destOrigin: `0@0`; - combinationRule: Form erase; - colorMap: map; - copyBits. - ^ result! ! -!Form methodsFor: 'converting' stamp: 'jmv 6/19/2017 16:04:17' prior: 16847525! - icon - "Answer a 16 x 16 icon of myself" - - ^self magnifyTo: `16 @ 16`! ! -!Form methodsFor: 'copying' stamp: 'jmv 6/19/2017 15:49:47' prior: 16847584! - contentsOfArea: aRect into: newForm - "Return a new form which derives from the portion of the original form delineated by aRect." - ^ newForm copyBits: aRect from: self at: `0@0` - clippingBox: newForm boundingBox rule: Form over! ! -!Form methodsFor: 'copying' stamp: 'jmv 6/19/2017 15:49:55' prior: 16847594! - copy: aRect - "Return a new form which derives from the portion of the original form delineated by aRect." - | newForm | - newForm _ self class extent: aRect extent depth: depth. - ^ newForm copyBits: aRect from: self at: `0@0` - clippingBox: newForm boundingBox rule: Form over! ! -!Form methodsFor: 'copying' stamp: 'jmv 6/19/2017 15:50:02' prior: 16847621! - copyBits: sourceForm at: destOrigin translucent: factor - "Make up a BitBlt table and copy the bits with the given colorMap." - (BitBlt - destForm: self - sourceForm: sourceForm - combinationRule: 30 - destOrigin: destOrigin - sourceOrigin: `0@0` - extent: sourceForm extent - clipRect: self boundingBox) - copyBitsTranslucent: ((0 max: (factor*255.0) asInteger) min: 255) -" - | f f2 f3 | f _ Form fromUser. f2 _ Form fromDisplay: (0@0 extent: f extent). f3 _ f2 copy. -0.0 to: 1.0 by: 1.0/32 do: - [:t | f3 _ f2 copy. f3 copyBits: f at: 0@0 translucent: t. - f3 displayAt: 0@0. (Delay forMilliseconds: 100) wait]. -"! ! -!Form methodsFor: 'display box access' stamp: 'jmv 6/19/2017 16:04:01' prior: 16847674! -boundingBox - ^ Rectangle - origin: `0 @ 0` - corner: width @ height! ! -!Form methodsFor: 'displaying' stamp: 'jmv 6/19/2017 15:51:05' prior: 16847690! - paintBits: sourceForm at: destOrigin translucent: factor - "Make up a BitBlt table and copy the bits with the given colorMap." - (BitBlt destForm: self - sourceForm: sourceForm - combinationRule: 31 - destOrigin: destOrigin - sourceOrigin: `0@0` - extent: sourceForm extent - clipRect: self boundingBox) - copyBitsTranslucent: ((0 max: (factor*255.0) asInteger) min: 255) -" - | f f2 f3 | f _ Form fromUser. f replaceColor: f dominantColor withColor: Color transparent. -f2 _ Form fromDisplay: (0@0 extent: f extent). f3 _ f2 copy. -0.0 to: 1.0 by: 1.0/32 do: - [:t | f3 _ f2 copy. f3 paintBits: f at: 0@0 translucent: t. - f3 displayAt: 0@0. (Delay forMilliseconds: 100) wait]. -"! ! -!Form methodsFor: 'displaying-generic' stamp: 'jmv 6/19/2017 16:04:09' prior: 16847730! - displayOn: aDisplayMedium - "Simple default display in order to see the receiver in the upper left - corner of screen." - - self displayOn: aDisplayMedium at: `0 @ 0`! ! -!Form methodsFor: 'filling' stamp: 'jmv 6/19/2017 15:50:07' prior: 16847937! - eraseShape: bwForm - "use bwForm as a mask to clear all pixels where bwForm has 1's" - ((BitBlt destForm: self sourceForm: bwForm - combinationRule: Form erase1bitShape "Cut a hole in the picture with my mask" - destOrigin: bwForm offset - sourceOrigin: `0@0` - extent: self extent clipRect: self boundingBox) - colorMap: (Bitmap with: 0 with: 16rFFFFFFFF)) - copyBits. -! ! -!Form methodsFor: 'filling' stamp: 'jmv 6/19/2017 15:50:12' prior: 16847951! - fill: aRectangle rule: anInteger fillColor: aForm - "Replace a rectangular area of the receiver with the pattern described by aForm - according to the rule anInteger." - (BitBlt toForm: self) - copy: aRectangle - from: `0@0` in: nil - fillColor: aForm rule: anInteger! ! -!Form methodsFor: 'image manipulation' stamp: 'jmv 6/19/2017 15:51:26' prior: 16848014! - smear: dir distance: dist - "Smear any black pixels in this form in the direction dir in Log N steps" - | skew bb | - bb _ BitBlt destForm: self sourceForm: self - combinationRule: Form under destOrigin: `0@0` sourceOrigin: `0@0` - extent: self extent clipRect: self boundingBox. - skew _ 1. - [skew < dist] whileTrue: - [bb destOrigin: dir*skew; copyBits. - skew _ skew+skew]! ! -!Form methodsFor: 'transitions' stamp: 'jmv 6/19/2017 15:50:50' prior: 50358231! - pageWarp: otherImage at: topLeft forward: forward - "Produce a page-turning illusion that gradually reveals otherImage - located at topLeft in this form. - forward == true means turn pages toward you, else away. [ignored for now]" - | pageRect oldPage nSteps buffer p leafRect sourceQuad warp oldBottom d | - pageRect _ otherImage boundingBox. - oldPage _ self copy: (pageRect translatedBy: topLeft). - (forward ifTrue: [oldPage] ifFalse: [otherImage]) - border: pageRect - widthRectangle: (Rectangle - left: 0 - right: 2 - top: 1 - bottom: 1) - rule: Form over - fillColor: Color black. - oldBottom _ self copy: ((pageRect bottomLeft + topLeft) extent: (pageRect width@(pageRect height//4))). - nSteps _ 8. - buffer _ Form extent: otherImage extent + (0@(pageRect height//4)) depth: self depth. - d _ pageRect topLeft + (0@(pageRect height//4)) - pageRect topRight. - 1 to: nSteps-1 do: - [:i | forward - ifTrue: [buffer copy: pageRect from: otherImage to: `0@0` rule: Form over. - p _ pageRect topRight + (d * i // nSteps)] - ifFalse: [buffer copy: pageRect from: oldPage to: `0@0` rule: Form over. - p _ pageRect topRight + (d * (nSteps-i) // nSteps)]. - buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over. - leafRect _ pageRect topLeft corner: p x @ (pageRect bottom + p y). - sourceQuad _ Array with: pageRect topLeft - with: pageRect bottomLeft + (0@p y) - with: pageRect bottomRight - with: pageRect topRight - (0@p y). - warp _ (WarpBlt toForm: buffer) - clipRect: leafRect; - sourceForm: (forward ifTrue: [oldPage] ifFalse: [otherImage]); - combinationRule: Form paint. - warp copyQuad: sourceQuad toRect: leafRect. - self copy: buffer boundingBox from: buffer to: topLeft rule: Form over. - Display forceToScreen. - ]. - - buffer copy: pageRect from: otherImage to: `0@0` rule: Form over. - buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over. - self copy: buffer boundingBox from: buffer to: topLeft rule: Form over. - Display forceToScreen. -" -1 to: 4 do: [:corner | Display pageWarp: - (Form fromDisplay: (10@10 extent: 200@300)) reverse - at: 10@10 forward: false] -" -! ! -!Form methodsFor: 'private' stamp: 'jmv 6/19/2017 16:04:06' prior: 16848740! - copyFromByteArray: bigEndianByteArray - "This method should work with either byte orderings. - See comment at Bitmap>>#asByteArray - Also see #copyFromByteArray2:to:" - - | myHack byteHack | - myHack := Form new hackBits: bits. - byteHack := Form new hackBits: bigEndianByteArray. - "We are passing a ByteArray instead of a Words object. Will be accessed according to native endianness." - Smalltalk isLittleEndian = self isLittleEndian ifFalse: [byteHack swapEndianness]. - byteHack displayOn: myHack at: `0 @ 0` rule: Form over! ! -!Form methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:04:13' prior: 16848849! - fromDisplay: aRectangle - "Create a virtual bit map from a user specified rectangular area on the - display screen. Reallocates bitmap only if aRectangle ~= the receiver's - extent." - - (width = aRectangle width and: [height = aRectangle height]) - ifFalse: [self setExtent: aRectangle extent depth: depth]. - self - copyBits: (aRectangle origin extent: self extent) - from: Display - at: `0 @ 0` - clippingBox: self boundingBox - rule: Form over! ! -!Form methodsFor: 'encoding' stamp: 'jmv 6/19/2017 15:49:02' prior: 16848870! - addDeltasFrom: previousForm - - (BitBlt - destForm: self - sourceForm: previousForm - fillColor: nil - combinationRule: Form reverse - destOrigin: `0@0` - sourceOrigin: `0@0` - extent: self extent - clipRect: self boundingBox) copyBits. - ^self! ! -!Form class methodsFor: 'instance creation' stamp: 'jmv 6/19/2017 16:37:08' prior: 50358302! - dotOfSize: diameter - "Create a form which contains a round black dot." - | radius form bb rect centerX centerY centerYBias centerXBias radiusSquared xOverY maxy dx | - radius _ diameter//2. - form _ self extent: diameter@diameter offset: `0@0` - radius. - bb _ (BitBlt toForm: form) - sourceX: 0; sourceY: 0; - combinationRule: Form over; - fillColor: Color black. - rect _ form boundingBox. - centerX _ rect center x. - centerY _ rect center y. - centerYBias _ rect height odd ifTrue: [0] ifFalse: [1]. - centerXBias _ rect width odd ifTrue: [0] ifFalse: [1]. - radiusSquared _ (rect height asFloat / 2.0) squared - 0.01. - xOverY _ rect width asFloat / rect height asFloat. - maxy _ rect height - 1 // 2. - - "First do the inner fill, and collect x values" - 0 to: maxy do: - [:dy | - dx _ ((radiusSquared - (dy * dy) asFloat) sqrt * xOverY) truncated. - bb destX: centerX - centerXBias - dx - destY: centerY - centerYBias - dy - width: dx + dx + centerXBias + 1 - height: 1; - copyBits. - bb destY: centerY + dy; - copyBits]. - ^ form -" -Time millisecondsToRun: - [1 to: 20 do: [:i | (Form dotOfSize: i) displayAt: (i*20)@(i*20)]] -"! ! -!Form class methodsFor: 'examples' stamp: 'jmv 6/19/2017 16:04:23' prior: 50358364! - toothpaste: diam - " - Display restoreAfter: [Form toothpaste: 30] - " - "Not completely unlike the ST-80 implementation :) - Original comment: - Draws wormlike lines by laying down images of spheres. - See Ken Knowlton, Computer Graphics, vol. 15 no. 4 p352. - Draw with mouse button down; terminate by option-click." - | point queue color q colors colr colr2 | - colors _ Color red wheel: 12. - color _ 8. - [ true ] whileTrue: [ - queue _ OrderedCollection new: 32. - 16 timesRepeat: [queue addLast: `-40@-40`]. - Sensor waitButton. - Sensor isMouseButton2Pressed ifTrue: [^ self]. - point _ Sensor mousePoint. - colr _ colors atWrap: (color _ color + 5). "choose increment relatively prime to colors size" - colr2 _ colr alpha: 0.3. - [Sensor isMouseButton1Pressed or: [queue size > 0]] whileTrue: [ - point _ point * 4 + Sensor mousePoint // 5. - point _ point. - Form fakeSphereAt: point diameter: diam color: colr. - (q _ queue removeFirst) ifNil: [^ self]. "exit" - Form fakeSphereAt: q diameter: diam color: colr2. - Sensor isMouseButton1Pressed ifTrue: [queue addLast: point]]]! ! -!ColorForm methodsFor: 'color manipulation' stamp: 'jmv 6/19/2017 15:47:08' prior: 16818811! - asGrayForm - "Build an optimal GrayForm, - for any color palette in the receiver." - | answer map | - answer _ GrayForm extent: width@height. - map _ self colormapIfNeededForGray8bpp. - (BitBlt toForm: answer) - colorMap: map; - copy: self boundingBox - from: `0@0` in: self - fillColor: nil rule: Form over. - ^ answer! ! -!ColorForm methodsFor: 'copying' stamp: 'jmv 6/19/2017 15:47:12' prior: 16818912! - copy: aRect - "Return a new ColorForm containing the portion of the receiver delineated by aRect." - - | newForm | - newForm _ self class extent: aRect extent depth: depth. - ((BitBlt - destForm: newForm - sourceForm: self - combinationRule: Form over - destOrigin: `0@0` - sourceOrigin: aRect origin - extent: aRect extent - clipRect: newForm boundingBox) - colorMap: nil) copyBits. - colors ifNotNil: [newForm colors: colors copy]. - ^ newForm -! ! -!ColorForm class methodsFor: 'as yet unclassified' stamp: 'jmv 6/19/2017 15:47:16' prior: 50358631! -mappingWhiteToTransparentFrom: aFormOrCursor - "Return a ColorForm copied from the given Form or Cursor with white mapped to transparent." - - | f map | - aFormOrCursor depth <= 8 ifFalse: [ - ^ self error: 'argument depth must be 8-bits per pixel or less']. - (aFormOrCursor is: #ColorForm) ifTrue: [ - f _ aFormOrCursor copy. - map _ aFormOrCursor colors. - ] ifFalse: [ - f _ ColorForm extent: aFormOrCursor extent depth: aFormOrCursor depth. - f copyBits: aFormOrCursor boundingBox - from: aFormOrCursor - at: `0@0` - clippingBox: aFormOrCursor boundingBox - rule: Form over. - map _ Color indexedColors copyFrom: 1 to: (1 bitShift: aFormOrCursor depth)]. - map _ map collect: [:c | - c = Color white ifTrue: [Color transparent] ifFalse: [c]]. - f colors: map. - ^ f -! ! -!Cursor methodsFor: 'converting' stamp: 'jmv 6/19/2017 15:47:21' prior: 16825862! - enlargedBy: scale - "Big cursors are 32 bits deep (ARGB premultiplied)" - | big | - scale = 1 ifTrue: [^self]. - big := CursorWithAlpha extent: self extent * scale depth: 32. - (self asCursorForm magnifyBy: scale) displayOn: big. - big offset: (self offset - 0.5 * scale min: `0@0` max: big extent negated) asIntegerPoint. - big fallback: self. - ^big! ! -!DisplayScreen class methodsFor: 'snapshots' stamp: 'jmv 6/19/2017 16:02:49' prior: 16835519! - actualScreenSize - - ^ `640@480`! ! -!DisplayScreen class methodsFor: 'snapshots' stamp: 'jmv 6/19/2017 16:02:57' prior: 16835523! - shutDown - "Minimize Display memory saved in image" - Display setExtent: `240@120` depth: Display nativeDepth. - ScreenUpdaterProcess ifNotNil: [ - ScreenUpdaterProcess terminate. - ScreenUpdaterProcess _ nil ]! ! -!GrayForm methodsFor: 'copying' stamp: 'jmv 6/19/2017 15:52:16' prior: 16850389! - copy: aRect - "Return a new instance containing the portion of the receiver delineated by aRect." - - | newForm | - newForm _ self class extent: aRect extent depth: depth. - ((BitBlt - destForm: newForm - sourceForm: self - combinationRule: Form over - destOrigin: `0@0` - sourceOrigin: aRect origin - extent: aRect extent - clipRect: newForm boundingBox) - colorMap: nil) copyBits. - ^ newForm! ! -!BitBlt class methodsFor: 'instance creation' stamp: 'jmv 6/19/2017 15:45:22' prior: 16786163! - bitPeekerFromForm: sourceForm - "Answer an instance to be used extract individual pixels from the given Form. The destination for a 1x1 copyBits will be the low order bits of (bits at: 1)." - | pixPerWord answer | - pixPerWord _ sourceForm pixelsPerWord. - answer _ self destForm: (Form extent: pixPerWord@1 depth: sourceForm depth) - sourceForm: nil "To ensure no colormap set" - combinationRule: Form over - destOrigin: (pixPerWord - 1)@0 - sourceOrigin: `0@0` - extent: `1@1` - clipRect: (`0@0` extent: pixPerWord@1). - "To ensure no colormap set" - answer sourceForm: sourceForm. - ^ answer! ! -!BitBlt class methodsFor: 'instance creation' stamp: 'jmv 6/19/2017 15:45:33' prior: 16786184! - bitPokerToForm: destForm - "Answer an instance to be used for valueAt: aPoint put: pixValue. - The source for a 1x1 copyBits will be the low order of (bits at: 1)" - | pixPerWord answer | - pixPerWord _ 32//destForm depth. - answer _ self destForm: destForm - sourceForm: nil "To ensure no colormap set" - combinationRule: Form over - destOrigin: `0@0` - sourceOrigin: (pixPerWord-1)@0 - extent: `1@1` - clipRect: (`0@0` extent: destForm extent). - "To ensure no colormap set" - answer sourceForm: (Form extent: pixPerWord@1 depth: destForm depth). - ^ answer! ! -!AffineTransformation methodsFor: 'converting coordinates' stamp: 'jmv 6/19/2017 15:43:10' prior: 16778110! - internalizeDelta: aPoint - "Internalize a distance vector. A distance is not a position. It is a magnitude with a direction. - It is usually used as a delta to be added to a position to obtain some other position." - - | x y det a11 a12 a21 a22 detX detY | - x _ aPoint x. - y _ aPoint y. - a11 _ self a11. - a12 _ self a12. - a21 _ self a21. - a22 _ self a22. - det _ (a11 * a22) - (a12 * a21). - det = 0.0 ifTrue: [ ^`0@0` ]. "So we have at least a valid result" - det _ 1.0 / det. - detX _ (x * a22) - (a12 * y). - detY _ (a11 * y) - (x * a21). - ^(detX * det) @ (detY * det)! ! -!AffineTransformation methodsFor: 'converting coordinates' stamp: 'jmv 6/19/2017 15:43:16' prior: 16778149! - inverseTransform: aPoint - "Apply the inverse transformation to aPoint, i.e. multiply our inverse by aPoint. - Use Smalltalk code, and not Matrix2x3Plugin, because we want Float conversion." - | x y det a11 a12 a21 a22 detX detY | - - x _ aPoint x - self a13. - y _ aPoint y - self a23. - a11 _ self a11. - a12 _ self a12. - a21 _ self a21. - a22 _ self a22. - det _ (a11 * a22) - (a12 * a21). - det = 0.0 ifTrue: [ ^`0@0` ]. "So we have at least a valid result" - det _ 1.0 / det. - detX _ (x * a22) - (a12 * y). - detY _ (a11 * y) - (x * a21). - ^(detX * det) @ (detY * det)! ! -!AffineTransformation methodsFor: 'accessing' stamp: 'jmv 6/19/2017 15:43:25' prior: 16778231! - inverseTransformation - "Return the inverse transformation of the receiver. - The inverse transformation is computed by first calculating - the inverse offset and then computing transformations - for the two identity vectors (1@0) and (0@1)" - | r1 r2 r3 m | - r3 _ self inverseTransform: `0@0`. - r1 _ (self inverseTransform: `1@0`) - r3. - r2 _ (self inverseTransform: `0@1`) - r3. - m _ self species new. - m - a11: r1 x; a12: r2 x; a13: r3 x; - a21: r1 y; a22: r2 y; a23: r3 y. - ^m! ! -!AffineTransformation methodsFor: 'transforming rects' stamp: 'jmv 6/19/2017 15:43:02' prior: 16778783! - displayBoundsOfTransformOf: aRectangle - "Externalize aRectangle, and find a bounding rectangle with horizontal - and vertical bounds and integer coordinates (i.e. adisplayBounds). - Primitive rounds and answers integers. - Warning: if answer from primitive is not strictly positive, it is off by one. Fix it here." - - | dstRect | - dstRect _ Rectangle new. - (self primDisplayBoundsOfTransformOf: aRectangle into: dstRect) ifNotNil: [ - dstRect topLeft > `0@0` ifTrue: [ ^dstRect ]]. - ^Rectangle encompassing: (aRectangle corners collect: [ :pt | - (self transform: pt) rounded ])! ! -!Point methodsFor: 'point functions' stamp: 'jmv 6/19/2017 16:10:05' prior: 16890518! - eightNeighbors - ^ (Array with: self + `1@0` - with: self + `1@1` - with: self + `0@1` - with: self + `-1@1`) , - (Array with: self + `-1@0` - with: self + `-1@-1` - with: self + `0@-1` - with: self + `1@-1`) -! ! -!Point methodsFor: 'point functions' stamp: 'jmv 6/19/2017 16:10:18' prior: 16890538! - fourNeighbors - ^ Array with: self + `1@0` - with: self + `0@1` - with: self + `-1@0` - with: self + `0@-1` -! ! -!Rectangle methodsFor: 'accessing' stamp: 'jmv 6/19/2017 16:11:04' prior: 16898560! - innerCorners - "Return an array of inner corner points, - ie, the most extreme pixels included, - in the order of a quadrilateral spec for WarpBlt" - | r1 | - r1 _ self topLeft corner: self bottomRight - `1@1`. - ^ Array with: r1 topLeft with: r1 bottomLeft with: r1 bottomRight with: r1 topRight! ! -!Morph methodsFor: 'events-processing' stamp: 'jmv 6/19/2017 15:54:30' prior: 16875129! - processUnknownEvent: aMorphicEvent localPosition: localEventPosition - "An event of an unknown type was sent to the receiver. What shall we do?!!" - - Smalltalk beep. - aMorphicEvent printString displayAt: `0@0`. - aMorphicEvent wasHandled: true! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 6/19/2017 16:08:34' prior: 16875336! - minimumExtent - "This returns the minimum extent that the morph may be shrunk to. Not honored in too many places yet, but respected by the resizeToFit feature, at least" - - self flag: #jmvVer2. "in owner's coordinates?" - ^self valueOfProperty: #minimumExtent ifAbsent: [`1@1`]! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 6/19/2017 16:08:41' prior: 16875397! - morphExtent - "In our own coordinates!!" -"Quizas eventualmente borrar este tambien? (no se usa mucho...)" - self flag: #jmvVer2. - ^`50 @ 40`! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 6/19/2017 15:54:22' prior: 16875457! - morphPositionInWorld - - self flag: #jmvVer2. - "Most likely we don't want to use global coordinates... - In fact, we could be in many frames of reference at the same time... - This method makes no sense at all!!" - - ^self externalizeToWorld: `0@0`! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 6/19/2017 15:54:26' prior: 16875515! - morphTopLeft - "By default, morphs occupy a rectangle specified by #morphTopLef and #morphExtent" - ^`0@0`! ! -!Morph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:08:46' prior: 16875946! - openInWorld: aWorld - "Add this morph to the requested World." - (location = MorphicTranslation new) - ifTrue: [ aWorld addMorph: self position: `50@50` ] - ifFalse: [ aWorld addMorph: self ]! ! -!RectangleLikeMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:11:08' prior: 16899200! - initialize - super initialize. - extent _ `50@40`. - color _ self defaultColor! ! -!PasteUpMorph methodsFor: 'change reporting' stamp: 'jmv 6/19/2017 15:55:13' prior: 16887050! - invalidateDisplayRect: damageRect from: aMorph - "Clip damage reports to my bounds, since drawing is clipped to my bounds." - - self == self world - ifTrue: [ worldState recordDamagedRect: (damageRect intersect: ( `0@0` extent: extent) ) ] - ifFalse: [ super invalidateDisplayRect: damageRect from: aMorph ] -! ! -!PasteUpMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:55:00' prior: 16887077! - drawOn: aCanvas - - "draw background image." - backgroundImage - ifNotNil: [ - aCanvas image: backgroundImage at: `0@0` ] - ifNil: [ - "draw background fill" - (self isWorldMorph and: [ aCanvas drawsOnDisplay ] and: [ color mightBeTranslucent ]) - ifTrue: [ - "Special case so a translucent background on the Display allows you to see through the main Cuis Window. - Requires proper handling of translucent Display in the VM. - Seems to work only on Linux when using a composing window manager." - (BitBlt toForm: Display) clipRect: aCanvas clipRect; - copy: Display boundingBox - from: `0@0` in: nil - fillColor: color rule: Form over. - Display forceToScreen] - ifFalse: [ super drawOn: aCanvas ]]! ! -!PasteUpMorph methodsFor: 'geometry' stamp: 'jmv 6/19/2017 15:55:18' prior: 16887238! - morphPositionInWorld - - self flag: #jmvVer2. "Solo para evitar los warning por falta de owner... pensar despues este caso" - self isWorldMorph ifTrue: [ ^ `0@0` ]. - ^super morphPositionInWorld! ! -!PasteUpMorph methodsFor: 'project state' stamp: 'jmv 6/19/2017 15:55:22' prior: 50337471! - viewBox - - ^ worldState - ifNotNil: [ - `0@0` extent: extent ] - ifNil: [ - self world viewBox ]! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 6/19/2017 15:55:05' prior: 16887770! - fillRects: rectangleList color: aColor - "For testing. Flashes the given list of rectangles on the Display so you can watch incremental redisplay at work." - - - | blt screenRect | - blt _ (BitBlt toForm: Display) - sourceForm: nil; - sourceOrigin: `0@0`; - clipRect: self viewBox; - fillColor: aColor; - combinationRule: Form over. - - rectangleList do: [:r | - screenRect _ r translatedBy: self viewBox origin. - blt destRect: screenRect; copyBits. - Display forceToScreen: screenRect ]. - - (Delay forMilliseconds: 150) wait! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 6/19/2017 15:55:09' prior: 16887789! - flashRects: rectangleList color: aColor - "For testing. Flashes the given list of rectangles on the Display so you can watch incremental redisplay at work." - "Details: Uses two reverses so that the display is restored to its original state. This is necessary when in deferred update mode." - - | blt screenRect | - blt _ (BitBlt toForm: Display) - sourceForm: nil; - sourceOrigin: `0@0`; - clipRect: self viewBox; - fillColor: aColor; - combinationRule: Form reverse. - - rectangleList do: [:r | - screenRect _ r translatedBy: self viewBox origin. - blt destRect: screenRect; copyBits. - Display forceToScreen: screenRect ]. - - (Delay forMilliseconds: 250) wait. - - rectangleList do: [:r | - screenRect _ r translatedBy: self viewBox origin. - blt destRect: screenRect; copyBits. - Display forceToScreen: screenRect ]! ! -!PasteUpMorph class methodsFor: 'instance creation' stamp: 'jmv 6/19/2017 15:55:26' prior: 50337487! - newWorld - " -[ - ProjectX stopUIProcess. - ProjectX spawnNewMorphicProcessFor: PasteUpMorph newWorld -] fork. - " - | w ws | - w _ self new. - ws _ WorldState new. - w worldState: ws. - w morphPosition: `0@0` extent: Display extent. - ws setCanvas: Display getCanvas. - w borderWidth: 0. - ws handsDo: [ :h | - h privateOwner: w ]. - ^w! ! -!EllipseMorph methodsFor: 'geometry testing' stamp: 'jmv 6/19/2017 16:03:06' prior: 16837091! - morphContainsPoint: aLocalPoint - - | radius other delta xOverY | - ((`0@0` extent: extent) containsPoint: aLocalPoint) ifFalse: [^ false]. "quick elimination" - extent > `1@1` - ifFalse: [^ true]. "Degenerate case -- code below fails by a bit" - - radius _ extent y asFloat / 2. - other _ extent x asFloat / 2. - delta _ aLocalPoint - (other@radius). - xOverY _ extent x asFloat / extent y asFloat. - ^ (delta x asFloat / xOverY) squared + delta y squared <= radius squared! ! -!HandleMorph methodsFor: 'events' stamp: 'jmv 6/19/2017 16:05:03' prior: 16852419! - keyStroke: aKeyboardEvent - "Check for cursor keys" - | keyValue | - (owner is: #HandMorph) ifFalse: [ ^self ]. - keyValue _ aKeyboardEvent keyValue. - keyValue = 28 ifTrue: [ ^self morphPosition: self morphPosition - `1@0` ]. - keyValue = 29 ifTrue: [ ^self morphPosition: self morphPosition + `1@0` ]. - keyValue = 30 ifTrue: [ ^self morphPosition: self morphPosition - `0@1` ]. - keyValue = 31 ifTrue: [ ^self morphPosition: self morphPosition + `0@1` ]. - "Special case for return" - aKeyboardEvent isReturnKey ifTrue:[ - "Drop the receiver and be done" - self flag: #arNote. "Probably unnecessary" - owner releaseKeyboardFocus: self. - self delete ]! ! -!HandleMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:04:48' prior: 16852446! - initialize - "initialize the state of the receiver" - super initialize. - extent _ `12@12`! ! -!PluggableMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:09:25' prior: 16889457! - initialize - super initialize. - extent _ `200@100`! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:55:30' prior: 16888083! - draw3DLookOn: aCanvas - - | borderStyleSymbol c | - borderStyleSymbol _ self isPressed ifFalse: [ #raised ] ifTrue: [ #inset ]. - c _ color. - self mouseIsOver ifTrue: [ c _ c lighter ]. - aCanvas - fillRectangle: (`0@0` extent: extent) - color: c - borderWidth: borderWidth - borderStyleSymbol: borderStyleSymbol - baseColorForBorder: c. - - self drawRegularLabelOn: aCanvas! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:55:46' prior: 50359275! - drawRoundGradientLookOn: aCanvas - | r colorForButton rect bottomFactor topFactor | - - self isPressed - ifFalse: [ - topFactor _ Theme current buttonGradientTopFactor. - bottomFactor _ Theme current buttonGradientBottomFactor. - self mouseIsOver - ifTrue: [ - colorForButton _ Color h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ - colorForButton _ color ]] - ifTrue: [ - topFactor _ Theme current buttonGradientBottomFactor. - bottomFactor _ Theme current buttonGradientTopFactor. - colorForButton _ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - Theme current useButtonGradient - ifTrue: [ - rect _ (`0@0` extent: extent) insetBy: `1@3`. - aCanvas - roundRect: rect - color: colorForButton - radius: r - gradientTop: topFactor - gradientBottom: bottomFactor - gradientHeight: Theme current buttonGradientHeight ] - ifFalse: [ - rect _ (`0@0` extent: extent) insetBy: `1@3`. - aCanvas roundRect: rect color: colorForButton radius: r ] - ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawEmbossedLabelOn: aCanvas ] - ifFalse: [ self drawRegularLabelOn: aCanvas ]! ! -!PluggableButtonMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:09:15' prior: 16888316! - initialize - "initialize the state of the receiver" - super initialize. - - roundButtonStyle _ nil. "nil: honor Theme. true: draw as round button. false: draw as classic 3d border square button" - model _ nil. - getStateSelector _ nil. - actionSelector _ nil. - isPressed _ false. - mouseIsOver _ false. - actWhen _ #buttonUp. - extent _ `20 @ 15`! ! -!PluggableButtonMorph methodsFor: 'geometry testing' stamp: 'jmv 6/19/2017 15:55:52' prior: 16888418! - morphContainsPoint: aLocalPoint - - | iconOrigin | - ((`0@0` extent: extent) containsPoint: aLocalPoint) ifFalse: [ ^false ]. - ^ self isOrthoRectangularMorph or: [ - magnifiedIcon isNil or: [ - iconOrigin _ extent - magnifiedIcon extent // 2. - (magnifiedIcon isTransparentAt: (aLocalPoint - iconOrigin) rounded) not ]]! ! -!PluggableButtonMorph class methodsFor: 'example' stamp: 'jmv 6/19/2017 16:09:19' prior: 50359324! - example - " - PluggableButtonMorph example openInWorld - " - - | s1 s2 s3 b1 b2 b3 row | - s1 _ Switch new. - s2 _ Switch new turnOn. - s3 _ Switch new. - s2 onAction: [s3 turnOff]. - s3 onAction: [s2 turnOff]. - b1 _ (PluggableButtonMorph model: s1 stateGetter: #isOn action: #switch) label: 'S1'. - b2 _ (PluggableButtonMorph model: s2 stateGetter: #isOn action: #turnOn) label: 'S2'. - b3 _ (PluggableButtonMorph model: s3 stateGetter: #isOn action: #turnOn) label: 'S3'. - b1 color: Color lightRed. - b2 color: Color lightRed. - b3 color: Color lightRed. - row _ LayoutMorph newRow - addMorphs: (Array with: b1 with: b2 with: b3); - morphExtent: `120@35`. - ^ row -! ! -!PluggableScrollPane methodsFor: 'access' stamp: 'jmv 6/19/2017 15:56:26' prior: 16889497! - addToScroller: aMorph - - scroller - addMorph: aMorph position: `0@0`; - morphExtent: aMorph morphExtent! ! -!PluggableScrollPane methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:09:31' prior: 16889865! - initialize - - "initialize the state of the receiver" - super initialize. - hideScrollBars _ false. - - "initialize the receiver's scrollBars" - scrollBar _ self scrollBarClass new model: self setValueSelector: #vScrollBarValue:. - hScrollBar _ self scrollBarClass new model: self setValueSelector: #hScrollBarValue:. - drawKeyboardFocusIndicator _ true. - - scroller _ self innerMorphClass new. - self addMorph: scroller. - self scrollerOffset: `0@ 0`. - self addMorph: scrollBar. - self addMorph: hScrollBar.! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'jmv 6/19/2017 15:56:31' prior: 16889992! - scrollToShow: aRectangle - "scroll to include as much of aRectangle as possible, where aRectangle is in the scroller's local space. - This means that 0@0 is scrolling all the way top and all the way left" - | delta | - (aRectangle top >= 0 and: [ - aRectangle bottom <= self viewableHeight ]) - ifTrue: [ - "already visible" - ^self ]. - - "Scroll end of selection into view if necessary" - delta _ aRectangle amountToTranslateWithin: (`0@0` extent: self viewableExtent). - delta y ~= 0 ifTrue: [ - self scrollBy: 0@delta y ]! ! -!PluggableListMorphOfMany methodsFor: 'events' stamp: 'jmv 6/19/2017 15:55:58' prior: 16889279! - mouseMove: aMouseMoveEvent localPosition: localEventPosition - "The mouse has moved, as characterized by the event provided. Adjust the scrollbar, and alter the selection as appropriate" - - | oldIndex oldVal row | - row _ (localEventPosition y < 0 and: [ scrollBar value > 0.0 ]) - ifTrue: [ - scrollBar scrollUp: 1. - "Leave at least one visible item unaffected, for better visual feedback to the user." - (self rowAtLocation: `0@0`) + 2 ] - ifFalse: [ - (localEventPosition y > extent y and: [ scrollBar value < 1.0 ]) - ifTrue: [ - scrollBar scrollDown: 1. - "Leave at least one visible item unaffected, for better visual feedback to the user." - (self rowAtLocation: 0@extent y) - 3 ] - ifFalse: [ self rowAtLocation: localEventPosition ]]. - row = 0 ifTrue: [ ^ self ]. - - "No change if model is locked" - self owningWindow ifNotNil: [ :w | - w okToChange ifFalse: [^ self]]. - - dragOnOrOff ifNil: [ - "Was not set at mouse down, which means the mouse must have gone down in an area where there was no list item" - dragOnOrOff _ (self listSelectionAt: row) not. - dragStartRow _ row ]. - - "Set meaning for subsequent dragging of selection" - oldIndex _ self getCurrentSelectionIndex. - oldIndex ~= 0 ifTrue: [ oldVal _ self listSelectionAt: oldIndex ]. - - "Set or clear new primary selection (listIndex)" - dragOnOrOff - ifTrue: [ self changeModelSelection: row ] - ifFalse: [ self changeModelSelection: 0 ]. - - "Need to restore the old one, due to how model works, and set new one." - oldIndex ~= 0 ifTrue: [ self listSelectionAt: oldIndex put: oldVal ]. - - "Select all in between if drag was too fast" - "self listSelectionAt: row put: dragOnOrOff." - (row min: dragStartRow) to: (row max: dragStartRow) do: [ :r | - self listSelectionAt: r put: dragOnOrOff ]! ! -!SystemWindow methodsFor: 'change reporting' stamp: 'jmv 6/19/2017 15:58:02' prior: 16926004! - invalidateTitleArea - - "not really pretty... also invalidating the top border, regardless of it being above or below the title area - (Different themes use various looks, this covers them all)" - self invalidateLocalRect: (`0@0` extent: extent x @ (self labelHeight + borderWidth))! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:57:54' prior: 16926054! - drawClassicFrameOn: aCanvas color: titleColor - "Window border encompasses title area. No round corners. No title gradient." - - aCanvas fillRectangle: (`0@0` extent: extent) color: color borderWidth: borderWidth borderStyleSymbol: #simple baseColorForBorder: self widgetsColor. - - "A border was drawn at the left, top and right of the title area. - The look is that the title area is inside the window" - aCanvas fillRectangle: (borderWidth@borderWidth extent: extent x - (2*borderWidth)@ self labelHeight) color: titleColor! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:57:58' prior: 16926109! -drawRoundedFrameOn: aCanvas color: widgetsColor - "Title area is not inside window borders" - | bottomFactor topFactor | - Theme current useWindowTitleGradient - ifTrue: [ - topFactor _ Theme current titleGradientTopFactor. - bottomFactor _ Theme current titleGradientBottomFactor ] - ifFalse: [ - topFactor _ 1. - bottomFactor _ 1 ]. - aCanvas - windowFrame: (`0@0` extent: extent) - color: widgetsColor * Theme current titleGradientExtraLightness - radius: Theme current roundedWindowRadius - border: borderWidth - labelHeight: self labelHeight + borderWidth - gradientTop: topFactor - gradientBottom: bottomFactor - insideColor: color! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 6/19/2017 16:37:43' prior: 16926132! - makeMeFullyVisible - - self world morphExtent > `0@0` ifFalse: [^ self]. - - (self morphPosition >= `0@0` and: [ self morphPosition < (self world morphExtent-self morphExtent)]) ifTrue: [ - ^ self "OK -- visible"]. - - self morphPosition: (RealEstateAgent initialFrameFor: self initialExtent: self morphExtentInWorld world: self world) topLeft! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 6/19/2017 16:37:53' prior: 16926145! - makeMeVisible - - self world morphExtent > `0@0` ifFalse: [^ self]. - - (self morphPosition >= `0@0` and: [ self morphPosition < (self world morphExtent-self labelHeight)]) ifTrue: [ - ^ self "OK -- at least my top left is visible"]. - - "window not on screen (probably due to reframe) -- move it now" - self morphPosition: (RealEstateAgent initialFrameFor: self initialExtent: extent world: self world) topLeft! ! -!SystemWindow methodsFor: 'geometry' stamp: 'jmv 6/19/2017 16:12:56' prior: 16926196! - minimumExtent - - ^`160@80`! ! -!SystemWindow methodsFor: 'geometry' stamp: 'jmv 6/19/2017 16:13:07' prior: 16926199! - rescaleButtons - "boxExtent changed. Update my buttons." - | buttonExtent buttonPos buttonDelta | - buttonExtent := self boxExtent. - buttonPos := `2@2`. - buttonDelta := self boxExtent x + 2. - self submorphsReverseDo: [ :aMorph | - (aMorph is: #PluggableButtonMorph) - ifTrue: [ - aMorph morphExtent: buttonExtent. - aMorph morphPosition: buttonPos. - buttonPos := (buttonPos x + buttonDelta) @ 2. - ]. - ]. -! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 6/19/2017 15:57:49' prior: 16926215! -boxExtent - "answer the extent to use in all the buttons. - - the label height is used to be proportional to the fonts preferences" - | e | - Theme current minimalWindows ifTrue: [^`0@0`]. - e _ Preferences windowTitleFont height. - ^e@e! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:12:42' prior: 16926276! - initialize - "Initialize a system window. Add label, stripes, etc., if desired" - - super initialize. - labelString ifNil: [ labelString _ 'Untitled Window']. - - self initializeLabelArea. - extent _ `300 @ 200`. - - adjusters _ Dictionary new. - adjusters at: #topAdjuster put: WindowEdgeAdjustingMorph forTop. - adjusters at: #bottomAdjuster put: WindowEdgeAdjustingMorph forBottom. - adjusters at: #leftAdjuster put: WindowEdgeAdjustingMorph forLeft. - adjusters at: #rightAdjuster put: WindowEdgeAdjustingMorph forRight. - adjusters at: #topLeftAdjuster put: WindowEdgeAdjustingMorph forTopLeft. - adjusters at: #bottomLeftAdjuster put: WindowEdgeAdjustingMorph forBottomLeft. - adjusters at: #topRightAdjuster put: WindowEdgeAdjustingMorph forTopRight. - adjusters at: #bottomRightAdjuster put: WindowEdgeAdjustingMorph forBottomRight. - adjusters do: [ :m | - self addMorphFront: m ]. - - "by default" - self beColumn! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:12:52' prior: 16926307! - initializeLabelArea - "Initialize the label area (titlebar) for the window." - - | spacing | - spacing _ self boxExtent x + 2. - self addMorph: self createCloseBox position: `2@2`. - self addMorph: self createCollapseBox position: spacing+2@2. - self addMorph: self createExpandBox position: spacing*2+2@2. - self addMorph: self createMenuBox position: spacing*3+2@2! ! -!SystemWindow methodsFor: 'layout' stamp: 'jmv 6/19/2017 15:58:05' prior: 16926374! - layoutSubmorphs - "Compute a new layout of submorphs based on the given layout bounds." - - | h thickness w cornerExtent wh ww pos | - thickness _ 4. - cornerExtent _ 20. - ww _ extent x. - wh _ extent y. - w _ ww - cornerExtent - cornerExtent. - h _ wh - cornerExtent - cornerExtent. - (adjusters at: #topAdjuster) morphPosition: cornerExtent@0 extent: w@thickness. - (adjusters at: #bottomAdjuster) morphPosition: cornerExtent@(wh-thickness) extent: w@thickness. - (adjusters at: #leftAdjuster) morphPosition: 0@cornerExtent extent: thickness@h. - (adjusters at: #rightAdjuster) morphPosition: ww-thickness@cornerExtent extent: thickness@h. - (adjusters at: #topLeftAdjuster) morphPosition: `0@0` extent: cornerExtent@cornerExtent. - (adjusters at: #bottomLeftAdjuster) morphPosition: 0@(wh-cornerExtent) extent: cornerExtent@cornerExtent. - (adjusters at: #topRightAdjuster) morphPosition: ww-cornerExtent@0 extent: cornerExtent@cornerExtent. - (adjusters at: #bottomRightAdjuster) morphPosition: ww@wh-cornerExtent extent: cornerExtent@cornerExtent. - - layoutMorph ifNotNil: [ - pos _ borderWidth @ (borderWidth + self labelHeight). - layoutMorph - morphPosition: pos - extent: extent - pos - borderWidth ]. - - layoutNeeded _ false! ! -!SystemWindow methodsFor: 'resize/collapse' stamp: 'jmv 6/19/2017 16:13:13' prior: 50333187! - resize - | resizeMorph | - resizeMorph _ ResizeMorph new morphExtent: `200@150`. - resizeMorph action: [self resize: (resizeMorph selectionRectangle: Display extent)]. - resizeMorph morphPosition: self world activeHand morphPosition. - resizeMorph openInWorld - ! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'jmv 6/19/2017 16:01:26' prior: 16811550! - initialExtent - - ^`540@400`! ! -!ChangeSorterWindow methodsFor: 'GUI building' stamp: 'jmv 6/19/2017 16:01:18' prior: 16800076! - initialExtent - ^`540@300`! ! -!PreDebugWindow methodsFor: 'GUI building' stamp: 'jmv 6/19/2017 16:01:38' prior: 16892600! - initialExtent - ^ `640 @ 320`! ! -!InspectorWindow methodsFor: 'GUI building' stamp: 'jmv 6/19/2017 16:01:32' prior: 50336305! - initialExtent - - ^`600@325`! ! -!ObjectExplorerWindow methodsFor: 'GUI building' stamp: 'jmv 6/19/2017 16:01:35' prior: 16883318! -initialExtent - - ^`300@500`! ! -!TestRunnerWindow methodsFor: 'GUI building' stamp: 'jmv 6/19/2017 16:13:18' prior: 16928555! - buildMorphicWindow - - self layoutMorph - addMorph: self buildUpperControls proportionalHeight: 0.25; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.75. - self setLabel: 'SUnit Test Runner'. - self refreshWindow. - self morphExtent: `460 @ 400`! ! -!ScrollBar methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:57:09' prior: 16904515! - drawOn: aCanvas - - aCanvas - fillRectangle: (`0@0` extent: extent) - color: (color alphaMixed: 0.3 with: Theme current scrollbarColor) - borderWidth: borderWidth - borderStyleSymbol: #simple - baseColorForBorder: borderColor! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 6/19/2017 16:07:49' prior: 16866514! - addTitle: aString - "Add a title line at the top of this menu Make aString its initial - contents. - If aSelector is not nil, then periodically obtain fresh values for its - contents by sending aSelector to aTarget.." - - | s pp w | - - titleMorph _ RectangleLikeMorph new. - titleMorph color: Theme current menuTitleBar. - pp _ `8@2`. - aString asString linesDo: [ :line | - s _ StringMorph new - contents: line; - font: Preferences standardMenuFont bold. - titleMorph addMorphBack: s position: pp. - pp _ pp + (0@(s morphHeight+2)) ]. - w _ titleMorph submorphs inject: 0 into: [ :prev :each | - prev max: each morphWidth ]. - titleMorph morphExtent: (w + 16) @ (pp y). - self addMorphFront: titleMorph. - - (self hasProperty: #needsStayUpIcons) ifTrue: [ self addStayUpIcons ]! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 6/19/2017 16:37:20' prior: 50341054! - popUpAdjacentTo: rightOrLeftPointInWorld from: sourceItem - "Present this menu at the given point under control of the given hand. - Used mostly for submenus." - - | delta tryToPlace selectedOffset | - popUpOwner _ sourceItem. - selectedOffset _ (selectedItem ifNil: [ self items first ]) morphPosition. - sourceItem world addMorphFront: self. - - tryToPlace _ [ :where :mustFit | - self morphPosition: where - selectedOffset. - delta _ self morphFullBoundsInWorld - amountToTranslateWithin: sourceItem world morphBoundsInWorld. - (delta x = 0 | mustFit) ifTrue: [ - delta = `0@0` ifFalse: [ self morphPosition: self morphPosition + delta ]. - ^ self]]. - tryToPlace - value: rightOrLeftPointInWorld first value: false; - value: rightOrLeftPointInWorld last - (extent x @ 0) value: false; - value: rightOrLeftPointInWorld first value: true! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 6/19/2017 16:08:25' prior: 50339204! - popUpAt: aPoint forHand: hand allowKeyboard: aBoolean - "Present this menu at the given point under control of the given hand." - - | evt | - self items isEmpty ifTrue: [^self]. - Theme current decorateMenu: self. - (self submorphs select: [ :m | m is: #UpdatingMenuItemMorph ]) - do: [ :m | m updateContents]. - self runningWorld addMorphFront: self position: aPoint - `2 @ 8`. - self fitInWorld. - "Acquire focus for valid pop up behavior" - hand newMouseFocus: self. - aBoolean ifTrue: [ hand newKeyboardFocus: self ]. - evt _ hand lastMouseEvent. - (evt isKeyboard or: [ evt isMouse and: [ evt anyButtonPressed not ]]) - ifTrue: [ - "Select first item if button not down" - self moveSelectionDown: 1 event: evt ]! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 6/19/2017 16:08:29' prior: 50339229! - popUpAt: aPoint forHand: hand in: aWorld allowKeyboard: aBoolean - "Present this menu at the given point under control of the given hand." - - self items isEmpty ifTrue: [ ^self ]. - Theme current decorateMenu: self. - (self submorphs select: [ :m | m is: #UpdatingMenuItemMorph]) - do: [ :m | m updateContents]. - aWorld addMorphFront: self position: aPoint - `2 @ 8`. - self fitInWorld. - "Acquire focus for valid pop up behavior" - hand newMouseFocus: self. - aBoolean ifTrue: [ hand newKeyboardFocus: self ]! ! -!MenuMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:08:18' prior: 50341130! - initialize - super initialize. - extent _ `40@10`. - defaultTarget _ nil. - selectedItem _ nil. - stayUp _ false. - popUpOwner _ nil! ! -!MenuMorph methodsFor: 'keyboard control' stamp: 'jmv 6/19/2017 16:08:04' prior: 50359761! - displayFiltered: evt - | matchStr allItems isMatch matches feedbackMorph | - matchStr _ self valueOfProperty: #matchString. - allItems _ self submorphs select: [ :m | - m is: #MenuItemMorph ]. - matches _ allItems select: [ :m | - isMatch _ matchStr isEmpty or: [ - m contents - includesSubstring: matchStr - caseSensitive: false ]. - m isEnabled: isMatch. - isMatch ]. - feedbackMorph _ self valueOfProperty: #feedbackMorph. - feedbackMorph ifNil: [ - feedbackMorph _ StringMorph new color: Color veryDarkGray. - self addMorphBack: feedbackMorph lock position: `0@ -20`. - self - setProperty: #feedbackMorph - toValue: feedbackMorph ]. - feedbackMorph contents: '<' , matchStr , '>'. - matchStr isEmpty ifTrue: [ - feedbackMorph delete. - self removeProperty: #feedbackMorph ]. - matches notEmpty ifTrue: [ - self selectItem: matches first ]! ! -!MenuMorph methodsFor: 'private' stamp: 'jmv 6/19/2017 16:07:56' prior: 16867223! - adjustSubmorphsLayout - "Enlarge the width of submorphs as needed - so all of them are have the same width, and no less than #minWidth. - Also adjust their vertical position. - Finally, set our own extent." - - | w p h | - - submorphs isEmpty ifTrue: [ ^self ]. - w _ submorphs inject: 0 into: [ :prev :each | - prev max: each minItemWidth]. - - w _ w + 1. - p _ `5 @ 5`. - submorphs do: [ :m | - h _ m morphHeight. - m morphPosition: p extent: w@h. - p _ p + (0@(h + 1)) ]. - - self morphExtent: w+4 @ p y + 5! ! -!MenuMorph methodsFor: 'private' stamp: 'jmv 6/19/2017 16:08:14' prior: 16867241! - fitInWorld - "Note: items may not be laid out yet (I found them all to be at 0@0), - so we have to add up heights of items above the selected item." - - | delta | - "If it doesn't fit, show it to the left, not to the right of the hand." - self morphBoundsInWorld right > owner world morphBoundsInWorld right - ifTrue: [ - self morphPosition: ((self morphPosition x + 10 - extent x) @ self morphPosition y) ]. - - "Make sure that the menu fits in the world." - delta _ self morphBoundsInWorld amountToTranslateWithin: - (owner world morphBoundsInWorld withHeight: - ((owner world morphExtentInWorld y) max: (self morphPosition y) + 1)). - delta = `0 @ 0` ifFalse: [ self morphPosition: self morphPosition + delta ]! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:43:48' prior: 16781484! - downButtonPosition - ^`0@0` + (extent - ScrollBar scrollbarThickness)! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:43:54' prior: 50359791! - drawOn: aCanvas - | rectangle w y0 h y1 y2 scrollbarThickness | - aCanvas frameAndFillRectangle: (`0@0` extent: extent) fillColor: self color borderWidth: borderWidth borderColor: borderColor. - y0 _ 1. - w _ extent x-2. - scrollbarThickness _ ScrollBar scrollbarThickness. - completer entryCount > self class itemsPerPage ifTrue: [ - w _ w - scrollbarThickness. - aCanvas - frameRectangle: (extent x - scrollbarThickness@0 - extent: scrollbarThickness @ extent y) - borderWidth: 1 - color: borderColor. - aCanvas - image: (BitBltCanvas arrowOfDirection: #up size: scrollbarThickness) - at: self upButtonPosition. - aCanvas - image: (BitBltCanvas arrowOfDirection: #down size: scrollbarThickness) - at: self downButtonPosition. - h _ extent y - (2 * scrollbarThickness). - y1 _ (1.0 * self firstVisible-1 / completer entryCount * h) ceiling + y0 + scrollbarThickness-1. - y2 _ (1.0 * self lastVisible / completer entryCount * h) floor + y0 + scrollbarThickness -1. - aCanvas - fillRectangle: (extent x - scrollbarThickness+2@y1 corner: extent x-2 @ y2) - color: Color veryLightGray ]. - self firstVisible - to: self lastVisible - do: [ :index | - rectangle _ 1@y0 extent: w@self class itemHeight. - index = self selected - ifTrue: [ - aCanvas fillRectangle: rectangle color: (Theme current listHighlightFocused: true) ]. - aCanvas - drawString: (completer entries at: index) asString - at: rectangle topLeft - font: self class listFont - color: Theme current text. - y0 _ y0 + self itemHeight ]! ! -!AutoCompleterMorph class methodsFor: 'instance creation' stamp: 'jmv 6/19/2017 16:00:57' prior: 16781686! - initializedInstance - | completer m | - completer _ SmalltalkCompleter withModel: (TextModel withText: 'Small'). - completer - instVarNamed: 'position' - put: 5. - completer computeEntries. - m _ AutoCompleterMorph - completer: completer - position: `200 @ 200`. - completer instVarNamed: 'menuMorph' put: m. - ^m! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:52:36' prior: 50359846! - drawOn: aCanvas - "Draw the hand itself (i.e., the cursor)." - "This method is only called when we are carrying morphs around..." - aCanvas - stencil: Cursor move - at: `0@0` - color: Color black! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:52:45' prior: 16851711! - savePatchFrom: aCanvas appendDamageTo: aStream - "Save the part of the given canvas under this hand as a Form and return its bounding rectangle." - - "Details: The previously used patch Form is recycled when possible to reduce the burden on storage management." - - | fullBounds | - fullBounds _ self morphFullBoundsInWorld. - fullBounds ifNil: [ ^self ]. - - fullBounds _ fullBounds intersect: (`0@0` extent: aCanvas extent). - (savedPatch isNil or: [savedPatch extent ~= fullBounds extent]) - ifTrue: [ - "allocate new patch form if needed" - savedPatch _ Form extent: fullBounds extent depth: aCanvas depth ]. - aCanvas - contentsOfArea: fullBounds - into: savedPatch. - savedPatch offset: fullBounds topLeft. - prevFullBounds - ifNil: [ aStream nextPut: fullBounds ] - ifNotNil: [ aStream nextPut: (fullBounds merge: prevFullBounds)]. - prevFullBounds _ fullBounds! ! -!HandMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 15:52:41' prior: 16852160! - initForEvents - mouseOverHandler _ nil. - lastMouseEvent _ MouseEvent new setType: #mouseMove position: `0@0` buttons: 0 hand: self. - lastMouseEventTime _ Time localMillisecondClock. - lastEventBuffer _ {1. 0. 0. 0. 0. 0. nil. nil}. - self dontWaitForMoreClicks! ! -!ImageMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:52:49' prior: 16854128! - drawOn: aCanvas - - aCanvas image: image at: `0@0`! ! -!StringMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:57:40' prior: 50343917! - drawOn: aCanvas - aCanvas - drawString: (contents ifNil: [ '' ]) - at: `0@0` - font: self fontToUse - color: color - ! ! -!StringMorph methodsFor: 'geometry' stamp: 'jmv 6/19/2017 15:57:44' prior: 16918155! - fitContents - "Measures contents later at #minimumExtent" - self morphExtent: `0@0`! ! -!IndentingListItemMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:53:00' prior: 16854676! - drawOn: aCanvas - - | tRect colorToUse sLeft aForm centeringOffset | - isHighlighted ifTrue: [ - aCanvas - fillRectangle: (`0@0` extent: extent) - color: (Theme current - listHighlightFocused: owner owner hasKeyboardFocus) duller ]. - isSelected ifTrue: [ - aCanvas - fillRectangle: (`0@0` extent: extent) - color: (Theme current - listHighlightFocused: owner owner hasKeyboardFocus) ]. - - tRect _ self toggleRectangle. - aForm _ isExpanded - ifTrue: [ container expandedForm ] - ifFalse: [ container notExpandedForm ]. - centeringOffset _ ((tRect height - aForm extent y) / 2.0) rounded. - - complexContents hasContents ifTrue: [ - aCanvas - image: aForm - at: (tRect topLeft translatedBy: 0 @ centeringOffset) ]. - - icon isNil - ifFalse: [ - aCanvas - image: icon - at: (tRect topLeft translatedBy: icon width @ centeringOffset). - sLeft _ indentLevel * 12 + 16 + (icon width + 2). - ] - ifTrue: [ - sLeft _ indentLevel * 12 + 16. - ]. - colorToUse _ complexContents preferredColor ifNil: [ color ]. - - aCanvas - drawString: contents asString - at: sLeft@0 - font: self fontToUse - color: colorToUse! ! -!MenuItemMorph methodsFor: 'accessing' stamp: 'jmv 6/19/2017 16:06:04' prior: 16865800! - contents: aString withMarkers: aBool inverse: inverse - "Set the menu item entry. If aBool is true, parse aString for embedded markers." - - | markerIndex marker | - self contentString: nil. "get rid of old" - aBool ifFalse: [^super contents: aString]. - self removeAllMorphs. "get rid of old markers if updating" - self hasIcon ifTrue: [ self icon: nil ]. - (aString notEmpty and: [aString first = $<]) - ifFalse: [^super contents: aString]. - markerIndex := aString indexOf: $>. - markerIndex = 0 ifTrue: [^super contents: aString]. - marker := (aString copyFrom: 1 to: markerIndex) asLowercase. - (#('' '' '' '') includes: marker) - ifFalse: [^super contents: aString]. - self contentString: aString. "remember actual string" - marker := (marker = '' or: [marker = '']) ~= inverse - ifTrue: [self onImage] - ifFalse: [self offImage]. - super contents: (aString copyFrom: markerIndex + 1 to: aString size). - "And set the marker" - marker := ImageMorph new image: marker. - self addMorphFront: marker position: `0@2`! ! -!MenuItemMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:53:42' prior: 16865892! - drawOn: aCanvas - | stringColor leftEdge | - - stringColor _ color. - isSelected & isEnabled - ifTrue: [ - aCanvas fillRectangle: (`0@0` extent: extent) color: Theme current menuHighlight]. - leftEdge _ 0. - - self hasMarker ifTrue: [ - leftEdge _ leftEdge + submorphs first morphWidth + 8 ]. - - self hasIcon - ifTrue: [| iconForm | - iconForm _ isEnabled ifTrue: [ self icon ] ifFalse: [ self icon asGrayScaleAndTransparent ]. - aCanvas image: iconForm at: leftEdge+1 @ (extent y - iconForm height // 2). - leftEdge _ leftEdge + iconForm width + self iconSeparation]. - - aCanvas - drawString: contents - at: leftEdge @ 1 - font: self fontToUse - color: stringColor. - subMenu ifNotNil: [ - aCanvas - image: self class subMenuMarker - at: extent x - 8 @ (extent y - self class subMenuMarker height // 2) ]! ! -!MenuItemMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:06:09' prior: 16866103! - initialize - "initialize the state of the receiver" - super initialize. - "" - extent _ `10@10`. - contents _ ''. - isEnabled _ true. - subMenu _ nil. - isSelected _ false. - target _ nil. - selector _ nil. - arguments _ nil. - font _ Preferences standardMenuFont! ! -!MenuItemMorph methodsFor: 'layout' stamp: 'jmv 6/19/2017 16:06:26' prior: 16866117! - measureContents - | e | - e _ super measureContents. - ^e y > 12 - ifTrue: [e+`2@2`] - ifFalse: [e+`2@1`]! ! -!MenuItemMorph methodsFor: 'selecting' stamp: 'jmv 6/19/2017 15:53:59' prior: 50341145! - select - self isSelected: true. - owner activeSubmenu: subMenu. - subMenu ifNotNil: [ - subMenu delete. - subMenu - popUpAdjacentTo: (Array with: self morphBoundsInWorld topRight + `10@0` - with: self morphBoundsInWorld topLeft) - from: self. - subMenu selectItem: nil ]! ! -!MenuItemMorph class methodsFor: 'cached state access' stamp: 'jmv 6/19/2017 16:06:33' prior: 16866204! - subMenuMarker - - | f | - SubMenuMarker ifNotNil: [ ^SubMenuMarker ]. - f _ Form - extent: `5@9` - fromArray: #(2147483648 3221225472 3758096384 4026531840 4160749568 4026531840 3758096384 3221225472 2147483648) - offset: `0@0`. - SubMenuMarker _ ColorForm mappingWhiteToTransparentFrom: f. - ^SubMenuMarker! ! -!LayoutAdjustingMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:53:34' prior: 16862884! - drawOn: aCanvas - - aCanvas - fillRectangle: (`0@0` extent: extent) - color: color! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 6/19/2017 15:53:38' prior: 16863315! - layoutBounds - "Return the bounds for laying out children of the receiver" - - ^`0@0` extent: extent! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 6/19/2017 16:05:36' prior: 16863335! - layoutSubmorphsHorizontallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - | xSep ySep usableWidth sumOfFixed normalizationFactor availableForPropWidth - fractionalWidths integerWidths theLeft usableHeight boundsTop boundsRight theTop minWidth submorphsToLayout - nextMorph ht wd ls theRight boundsBottom theBottom alternativeWidths count diff i | - - boundsForLayout extent > `2@2` "self minimumExtent" - ifFalse: [ ^self ]. "Too small. Don't bother!!" - - submorphsToLayout := self submorphsToLayout. - xSep := self xSeparation. - ySep := self ySeparation. - usableWidth := boundsForLayout width - ((submorphsToLayout size + 1) * xSep). - sumOfFixed := submorphsToLayout sum: [ :m | m layoutSpec fixedWidth ]. - availableForPropWidth := usableWidth - sumOfFixed max: 0. - normalizationFactor := self proportionalWidthNormalizationFactor. - availableForPropWidth := availableForPropWidth * normalizationFactor. - - fractionalWidths := submorphsToLayout collect: [ :m | m layoutSpec widthFor: availableForPropWidth ]. - "Compute integer widths, mostly rounding but with occasional #floor or #ceiling as needed to keep sum" - integerWidths _ fractionalWidths collect: [ :w | w rounded ]. - diff _ integerWidths sum - fractionalWidths sum rounded. - alternativeWidths _ diff > 0 ifTrue: [ fractionalWidths collect: [ :w | w floor ]] ifFalse: [ fractionalWidths collect: [ :w | w ceiling ]]. - count _ diff abs. - i _ 1. - [ count > 0] whileTrue: [ - (integerWidths at: i) = (alternativeWidths at: i) ifFalse: [ - integerWidths at: i put: (alternativeWidths at: i). - count _ count -1 ]. - i _ i + 1 ]. - minWidth := integerWidths sum. - theLeft := ((usableWidth - minWidth) * (padding ifNil: [0]) max: 0) + boundsForLayout left + xSep. - usableHeight := boundsForLayout height - (ySep * 2) max: 0. - boundsTop := boundsForLayout top + ySep. - boundsRight := boundsForLayout right - xSep. - boundsBottom := boundsForLayout bottom - ySep. - - submorphsToLayout size to: 1 by: -1 do: [ :index | - nextMorph := submorphsToLayout at: index. - "major direction" - wd := integerWidths at: index. - "minor direction" - ls := nextMorph layoutSpec. - ht := (ls heightFor: usableHeight) min: usableHeight. - theTop := ((usableHeight - ht) * ls minorDirectionPadding) floor + boundsTop. - theBottom := (theTop + ht) ceiling min: boundsBottom. - theRight := (theLeft + (wd min: minWidth)) "ceiling "min: boundsRight. - "Set bounds and adjust major direction for next step" - self flag: #jmvVer2. "should extent be set in m's coordinate system? what if its scale is not 1?" - ls usesMorphExtent - ifTrue: [ - nextMorph morphPosition: theLeft floor @ theTop floor ] - ifFalse: [ - nextMorph morphPosition: theLeft floor @ theTop floor extent: theRight - theLeft @ (theBottom - theTop) ]. - theLeft := theRight + xSep - ]! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 6/19/2017 16:05:46' prior: 16863426! - layoutSubmorphsVerticallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - | xSep ySep usableHeight sumOfFixed normalizationFactor availableForPropHeight - fractionalHeights integerHeights theTop usableWidth boundsLeft boundsBottom theLeft minHeight submorphsToLayout - nextMorph ht wd ls theBottom boundsRight theRight alternativeHeights count diff i | - - boundsForLayout extent > `2@2` "self minimumExtent" - ifFalse: [ ^self ]. "Too small. Don't bother!!" - - submorphsToLayout := self submorphsToLayout. - xSep := self xSeparation. - ySep := self ySeparation. - usableHeight := boundsForLayout height - ((submorphsToLayout size + 1) * ySep). - sumOfFixed := submorphsToLayout sum: [ :m | m layoutSpec fixedHeight ]. - availableForPropHeight := usableHeight - sumOfFixed max: 0. - normalizationFactor := self proportionalHeightNormalizationFactor. - availableForPropHeight := availableForPropHeight * normalizationFactor. - - fractionalHeights := submorphsToLayout collect: [ :m | m layoutSpec heightFor: availableForPropHeight ]. - "Compute integer widths, mostly rounding but with occasional #floor or #ceiling as needed to keep sum" - integerHeights _ fractionalHeights collect: [ :w | w rounded ]. - diff _ integerHeights sum - fractionalHeights sum rounded. - alternativeHeights _ diff > 0 ifTrue: [ fractionalHeights collect: [ :w | w floor ]] ifFalse: [ fractionalHeights collect: [ :w | w ceiling ]]. - count _ diff abs. - i _ 1. - [ count > 0] whileTrue: [ - (integerHeights at: i) = (alternativeHeights at: i) ifFalse: [ - integerHeights at: i put: (alternativeHeights at: i). - count _ count -1 ]. - i _ i + 1 ]. - minHeight := integerHeights sum. - theTop := ((usableHeight - minHeight) * (padding ifNil: [0]) max: 0) + boundsForLayout top + ySep. - usableWidth := boundsForLayout width - (xSep * 2) max: 0. - boundsLeft := boundsForLayout left + xSep. - boundsBottom := boundsForLayout bottom - ySep. - boundsRight := boundsForLayout right - xSep. - - submorphsToLayout size to: 1 by: -1 do: [ :index | - nextMorph := submorphsToLayout at: index. - "major direction" - ht := integerHeights at: index. - "minor direction" - ls := nextMorph layoutSpec. - wd := (ls widthFor: usableWidth) min: usableWidth. - theLeft := ((usableWidth - wd) * ls minorDirectionPadding) floor + boundsLeft. - theRight := (theLeft + wd) ceiling min: boundsRight. - theBottom := (theTop + (ht min: minHeight)) "ceiling" min: boundsBottom. - "Set bounds and adjust major direction for next step" - self flag: #jmvVer2. "should extent be set in m's coordinate system? what if its scale is not 1?" - ls usesMorphExtent - ifTrue: [ - nextMorph morphPosition: theLeft floor @ theTop floor ] - ifFalse: [ - nextMorph morphPosition: theLeft floor @ theTop floor extent: theRight - theLeft @ (theBottom - theTop) ]. - theTop := theBottom + ySep - ]! ! -!ProgressMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:10:33' prior: 16896264! - initialize - super initialize. - self separation: 0. - labelMorph _ StringMorph contents: '' font: AbstractFont default. - subLabelMorph _ StringMorph contents: '' font: AbstractFont default. - progress _ ProgressBarMorph new. - progress morphExtent: `200 @ 15`. - self addMorphFront: labelMorph. - self addMorphFront: subLabelMorph. - self addMorph: progress fixedHeight: 15.! ! -!HaloHandleMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:52:21' prior: 16850527! - drawOn: aCanvas - - aCanvas - image: (self class circleForm: extent) - multipliedBy: color - at: `0@0`! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 6/19/2017 15:52:25' prior: 50360436! - addHandle: handleSpec - "Add a handle within the halo box as per the haloSpec, and set it up to respond to the given event by sending the given selector to the given recipient. Return the handle." - - | handle aPoint colorToUse form icon | - aPoint _ self - positionIn: haloBox - horizontalPlacement: handleSpec horizontalPlacement - verticalPlacement: handleSpec verticalPlacement. - colorToUse _ Color colorFrom: handleSpec color. - handle _ HaloHandleMorph new color: colorToUse. - self addMorph: handle. - handle morphBoundsInWorld: (Rectangle center: aPoint extent: self class handleSize asPoint). - handleSpec iconSymbol ifNotNil: [ :iconName | - form _ self class icons at: iconName ifAbsent: [self class perform: iconName]. - form ifNotNil: [ - icon _ ImageMorph new - image: form; - color: colorToUse makeForegroundColor; - lock. - handle addMorphFront: icon position: `0@0` ]]. - handle mouseUpSelector: #endInteraction. - handle setBalloonText: handleSpec hoverHelp. - ^handle! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 6/19/2017 16:04:44' prior: 16850943! - basicBox - | aBox minSide anExtent w | - minSide _ 4 * self class handleSize. - anExtent _ ((extent x + self class handleSize + 8) max: minSide) @ - ((extent y + self class handleSize + 8) max: minSide). - aBox _ Rectangle center: self morphBoundsInWorld center extent: anExtent. - w _ self world ifNil: [ target world ]. - ^ w - ifNil: - [ aBox ] - ifNotNil: - [ aBox intersect: (w viewBox insetBy: `8@8`) ]! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 6/19/2017 15:52:32' prior: 16851149! - startGrow: evt with: growHandle - "Initialize resizing of my target. Launch a command representing it, to support Undo" - - | botRt | - evt hand obtainHalo: self. "Make sure the event's hand correlates with the receiver" - self removeAllHandlesBut: growHandle. "remove all other handles" - botRt _ target morphPositionInWorld + target morphExtentInWorld. - positionOffset _ (self world viewBox containsPoint: botRt) - ifTrue: [evt eventPosition - botRt] - ifFalse: [`0@0`]! ! -!InnerHierarchicalListMorph methodsFor: 'geometry' stamp: 'jmv 6/19/2017 16:36:31' prior: 16854885! - itemFromPoint: aPoint - "Return the list element (morph) at the given point or nil if outside" - | ptY last | - self hasSubmorphs ifFalse: [ ^nil ]. - (aPoint > `0@0` and: [ aPoint < extent ]) ifFalse: [ ^nil ]. - ptY _ aPoint y. - "note: following assumes that submorphs are vertical, non-overlapping, and ordered" - self firstSubmorph morphPosition y > ptY ifTrue: [ ^nil ]. - last _ self lastSubmorph. - last morphPosition y + last morphHeight < ptY ifTrue: [ ^nil ]. - "now use binary search" - ^self - findSubmorphBinary: [ :m | - (m morphPosition y <= ptY and: [ m morphPosition y + m morphHeight >= ptY ]) - ifTrue: [ 0 ] "found" - ifFalse: [ m morphPosition y + (m morphHeight // 2) > ptY ifTrue: [-1] ifFalse: [1]]]! ! -!InnerListMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:53:10' prior: 16855151! - drawBackgroundForMulti: row on: aCanvas - | selectionDrawBounds c | - "shade the background darker, if this row is selected" - selectionDrawBounds _ self drawBoundsForRow: row. - selectionDrawBounds _ selectionDrawBounds intersect: (`0@0` extent: extent). - c _ (selectedRow notNil and: [ row = selectedRow]) - ifTrue: [ Theme current listHighlightFocused: owner hasKeyboardFocus ] - ifFalse: [ Theme current listMultiHighlightFocused: owner hasKeyboardFocus ]. - aCanvas fillRectangle: selectionDrawBounds color: c! ! -!InnerListMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:53:15' prior: 16855170! - drawHighlightOn: aCanvas -"Ademas, poner el mouse pointer de relojito si tarda... Detectarlo automaticamente, etc. Aunque no estoy seguro de como hacerlo... quizas colgar un cachito de codigo en un proceso de mayor prioridad, onda 'si pasa 1 segundo, y todavia no te resetee este flag, entonces pone el relojito'" - | selectionDrawBounds | - highlightedRow ifNil: [ ^self ]. - highlightedRow = 0 ifTrue: [ ^self ]. - selectionDrawBounds _ self drawBoundsForRow: highlightedRow. - selectionDrawBounds _ selectionDrawBounds intersect: (`0@0` extent: extent). - aCanvas - fillRectangle: selectionDrawBounds - color: (Theme current listHighlightFocused: owner hasKeyboardFocus) duller! ! -!InnerListMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:53:20' prior: 16855209! - drawSelectionOn: aCanvas - | selectionDrawBounds | - selectedRow ifNil: [ ^self ]. - selectedRow = 0 ifTrue: [ ^self ]. - selectionDrawBounds _ self drawBoundsForRow: selectedRow. - selectionDrawBounds _ selectionDrawBounds intersect: (`0@0` extent: extent). - aCanvas - fillRectangle: selectionDrawBounds - color: (Theme current listHighlightFocused: owner hasKeyboardFocus)! ! -!InnerTextMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:53:24' prior: 16855570! - drawOn: aCanvas - "Draw the receiver on a canvas" - - false ifTrue: [ self debugDrawLineRectsOn: aCanvas ]. "show line rects for debugging" - - aCanvas - textComposition: self textComposition - bounds: (`0@0` extent: extent) - color: color - selectionColor: (Theme current textHighlightFocused: self hasKeyboardFocus)! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'jmv 6/19/2017 16:15:44' prior: 50360553! - initialize - super initialize. - extent _ `400@300`. - color _ Color white. - grid _ `8@6`. - gridLineWidth _ 2. - gridColor _ Color black. - selectionColor _ Color red! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:03:19' prior: 16844103! - createAcceptButton - "create the [accept] button" - | result | - result _ PluggableButtonMorph new - model: self; - color: Theme current acceptButton; - label: 'Accept'; - action: #acceptClicked. - result morphExtent: `6@2` * self sizeUnit. - self addMorph: result position: `2@7.5` * self sizeUnit // 1. - ^ result! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:03:31' prior: 16844116! -createCancelButton - "create the [cancel] button" - | result | - result _ PluggableButtonMorph new - model: self; - color: Theme current cancelButton; - label: 'Cancel'; - action: #cancelClicked. - result morphExtent: `6@2` * self sizeUnit. - self addMorph: result position: `12@7.5` * self sizeUnit // 1. - ^ result! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:03:37' prior: 16844129! - createQueryTextMorph: queryString - "create the queryTextMorph" - | result | - result _ StringMorph new contents: queryString. - result lock. - result morphExtent: `24@2` * self sizeUnit. - self addMorph: result position: `2@0.5` * self sizeUnit // 1. - ^ result! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:03:44' prior: 16844140! - createTextPaneAcceptOnCR: acceptBoolean - "create the textPane" - | result | - - self flag: #todo. "Integrate this method with the Theme system. --cbr" - - result _ TextModelMorph - textProvider: self - textGetter: #response - textSetter: #response: - selectionGetter: #selectionInterval. - result hasUnacceptedEdits: true. - result acceptOnCR: acceptBoolean. - result morphExtent: `18@5` * self sizeUnit. - self addMorph: result position: `1@2` * self sizeUnit. - ^ result! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:03:48' prior: 16844169! - initialize - - super initialize. - extent _ `20@10` * self sizeUnit. - responseUponCancel _ ''! ! -!FillInTheBlankMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:48:53' prior: 16844226! - drawOn: aCanvas - - Theme current roundWindowCorners - ifTrue: [ - aCanvas - roundRect: (`0@0` extent: extent) - color: color - radius: Theme current roundedWindowRadius ] - ifFalse: [ super drawOn: aCanvas ]! ! -!TranscriptMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:58:30' prior: 16938600! - drawOn: aCanvas - Transcript - showOnDisplay: true; - displayOn: form in: (`0@0` extent: extent). - aCanvas image: form at: `0@0`. - Transcript - bounds: self morphBoundsInWorld; - showOnDisplay: doImmediateUpdates. - self updateWorkspace! ! -!MenuLineMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:54:11' prior: 16866232! - drawOn: aCanvas - | baseColor | - baseColor _ owner color. - aCanvas - fillRectangle: (`0@0` corner: extent x @ (extent y / 2)) - color: baseColor twiceDarker. - - aCanvas - fillRectangle: (0 @ (extent y / 2) corner: extent) - color: baseColor twiceLighter! ! -!MenuLineMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:06:38' prior: 16866243! -initialize - super initialize. - extent _ `50 @ 2`! ! -!MenuLineMorph methodsFor: 'geometry' stamp: 'jmv 6/19/2017 16:07:43' prior: 16866250! - minimumExtent - - ^`10@2`! ! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 6/19/2017 15:59:45' prior: 50339585! - tryDeferredUpdatingAndSetCanvas - "If this platform supports deferred updates, then make my canvas be the Display (or a rectangular portion of it), set the Display to deferred update mode, and answer true. Otherwise, set a non-Disply canvas and answer false.." - | properDisplay | - - "As this is the only sender of #deferUpdates: , this could be done in Morphic or image startup, and never efterwards..." - (Display deferUpdates: true) ifNil: [ - "deferred updates not supported by the VM, do them in the image!!" - self ensureNonDisplayCanvas. - ^ false]. - - "if no canvas, or canvas was offscreen, from a platform that didnt support defers, then fix it" - properDisplay _ canvas notNil and: [canvas drawsOnDisplay]. - properDisplay ifFalse: [ - world morphPosition: `0@0` extent: Display extent. - self setCanvas: Display getCanvas. - ]. - ^ true! ! -!MorphicEvent methodsFor: 'dispatching' stamp: 'jmv 6/19/2017 15:54:47' prior: 16877833! - startDispatchFrom: aHand - "double dispatch the event dispatch" - "An event of an unknown type was sent. What shall we do?!!" - - Smalltalk beep. - self printString displayAt: `0@0`. - self wasHandled: true! ! -!MorphicCanvas methodsFor: 'accessing' stamp: 'jmv 6/19/2017 15:54:34' prior: 16877393! - newClipRect: aRectangleOrNil - "aRectangle is in world coordinates. - But ivar clipRect is relative to the form, - For example, if we had previously been built like - aCanvas on: someForm over: (100@100 extent 200@100) - then our origin would be -100 @ -100. - Then, a clipRect argument like (120@120 extent: 40@30) would mean affecting - only (20@20 extent: 40@30) in our form" - - self setClipRect: (aRectangleOrNil - ifNil: [ `0@0` corner: form extent ] - ifNotNil: [ aRectangleOrNil translatedBy: self canvasOrigin ])! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 6/19/2017 16:08:51' prior: 50360744! - drawCurrentAsError - "The morph (or one of its submorphs) had an error in its drawing method." - | r w | - r _ currentMorph morphLocalBounds. - w _ r extent > `50@50` - ifTrue: [ 6 ] - ifFalse: [ 2 ]. - self - frameAndFillRectangle: r - fillColor: Color red - borderWidth: w - borderColor: Color yellow. - self line: r topLeft to: r bottomRight-w width: w color: Color yellow. - self line: r topRight -(w@0) to: r bottomLeft -(0@w)width: w color: Color yellow! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 6/19/2017 16:09:00' prior: 50360761! - drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - aColor = Color black ifFalse: [ | topColor | - topColor _ aColor alphaMixed: 0.25 with: Color black. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint - font: fontOrNil - color: topColor ]. - aColor = Color white ifFalse: [ | bottomColor | - bottomColor _ aColor alphaMixed: 0.22 with: Color white. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + `0@2` - font: fontOrNil - color: bottomColor ]. - ^self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + `0@1` - font: fontOrNil - color: aColor! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 6/19/2017 15:54:38' prior: 16877657! - textComposition: aTextComposition bounds: boundsRect color: c selectionColor: sc - | displayScanner leftInRun line boundsInWorld tl | - - tl _ boundsRect topLeft. - boundsInWorld _ currentTransformation displayBoundsOfTransformOf: boundsRect. - - displayScanner _ MorphicScanner new - defaultFont: aTextComposition defaultFont; - text: aTextComposition textComposed - foreground: c. - displayScanner canvas: self. - - leftInRun _ 0. - "Take clipRect into account. Extrememly fast scrolls and redraws of huge files (like .sources)" - (aTextComposition lineIndexForPoint: (`0@0` max: (clipLeft@clipTop)- boundsInWorld origin)) - to: (aTextComposition lineIndexForPoint: (boundsInWorld extent min: (clipRight@clipBottom+1) - boundsInWorld origin)) - do: [ :i | - line _ aTextComposition lines at: i. - aTextComposition - displaySelectionInLine: line - on: self - textTopLeft: tl - selectionColor: sc. - leftInRun _ displayScanner displayLine: line textTopLeft: tl leftInRun: leftInRun ]! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 6/19/2017 15:54:43' prior: 16877740! - onForm: aForm - - ^ self basicNew - initializeWith: aForm origin: `0@0`! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 6/19/2017 15:45:38' prior: 16787053! - fillRectangle: aRectangle tilingWith: aForm sourceRect: patternBox rule: aCombinationRule - "aRectangle is in form coordinates, no transformation is done." - | displayRectangle additionalOffset clippedPort targetTopLeft clipOffset ex - targetBox savedMap top left | - - ex _ patternBox extent. - ex x = 0 ifTrue: [ ^self ]. - ex y = 0 ifTrue: [ ^self ]. - displayRectangle _ currentTransformation displayBoundsOfTransformOf: aRectangle. - - "this is a bit of a kludge to get the form to be aligned where I *think* it should be. - something better is needed, but not now" - - additionalOffset _ `0@0`. - clippedPort _ port clippedBy: displayRectangle. - targetTopLeft _ clippedPort clipRect topLeft truncateTo: ex. - clipOffset _ displayRectangle topLeft - targetTopLeft. - additionalOffset _ (clipOffset \\ ex) - ex. - - "do it iteratively" - targetBox _ clippedPort clipRect. - savedMap _ clippedPort colorMap. - clippedPort sourceForm: aForm; - fillColor: nil; - combinationRule: aCombinationRule; - sourceRect: patternBox; - colorMap: (aForm colormapIfNeededFor: clippedPort destForm). - top _ (targetBox top truncateTo: patternBox height) + additionalOffset y. - left _ (targetBox left truncateTo: patternBox width) + additionalOffset x. - - left to: (targetBox right - 1) by: patternBox width do: [:x | - top to: (targetBox bottom - 1) by: patternBox height do: [:y | - clippedPort destOrigin: x@y; copyBits]]. - clippedPort colorMap: savedMap! ! -!BitBltCanvas class methodsFor: 'cached forms' stamp: 'jmv 6/19/2017 15:45:51' prior: 50360833! - steButtonForm: extent - ^self cachedForms - at: { #steButton . extent } - ifAbsentPut: [ - | form canvas | - form _ Form extent: extent depth: 32. - canvas _ form getCanvas. - canvas - roundRect: (`0@0` extent: extent) - color: (Color gray: 0.4) - radius: 4. - canvas - roundRect: (`1@1` extent: extent-2) - color: Color white - radius: 4 - gradientTop: 1.0 - gradientCenter: 0.73 - gradientBottom: 0.94 - gradient1Height: (extent y-8+1 max: extent y//2). - form]! ! -!BitBltCanvas class methodsFor: 'cached arrow forms' stamp: 'jmv 6/19/2017 16:01:13' prior: 50360910! - buildArrowWith: insideForm borderForm: borderForm - | extent translucentForm color insideSpec borderSpec border background alpha| - " - Display getCanvas - image: (BitBltCanvas buildArrowWith: BitBltCanvas downInsideForm borderForm: BitBltCanvas downBorderForm) - at: 20@20 - Display getCanvas - image: (BitBltCanvas buildArrowWith:BitBltCanvas upInsideForm borderForm: BitBltCanvas upBorderForm) - at: 40@20 - " - extent _ insideForm extent - `1@2`. - translucentForm _ Form extent: insideForm extent depth: 32. - 0 to: extent x-1 do: [ :x | - 0 to: extent y-1 do: [ :y | - insideSpec _ insideForm colorAt: x@(y+1). - borderSpec _ borderForm colorAt: x@(y+1). - insideSpec = (Color r: 0.0 g: 0.0 b: 1.0) - ifTrue: [ color _ Color transparent ] - ifFalse: [ - borderSpec = (Color r: 1.0 g: 0.0 b: 0.0) - ifTrue: [ color _ insideSpec ] - ifFalse: [ - border _ x < (extent x//2) - ifTrue: [Color white] - ifFalse: [Color black]. - background _ borderForm colorAt: extent x@(y+1). - alpha _ borderSpec red asFloat - background red / (border red - background red). - color _ border alpha: (alpha min: 1 max: 0) ]]. - translucentForm colorAt: x@y put: color ]]. - ^translucentForm! ! -!TextComposition methodsFor: 'selection' stamp: 'jmv 6/19/2017 16:13:22' prior: 16931067! - defaultCharacterBlock - ^ CharacterBlock - stringIndex: 1 - text: model actualContents - topLeft: lines first topLeft - extent: `0 @ 0` - textLine: lines first! ! -!DifferenceFinder methodsFor: 'private' stamp: 'jmv 6/19/2017 16:02:44' prior: 16834082! - maxLengthPoints - | max points | - max := self maxLength. - max = 0 ifTrue: [^Array with: `0 @ 0`]. - points := OrderedCollection new. - tally withIndexesDo: [:i :j :t | t = max ifTrue: [points add: i @ j]]. - ^points! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3115-UseLiteralPoints-JuanVuletich-2017Jun19-16h29m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3115] on 20 June 2017 at 5:50:34 pm'! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 6/20/2017 13:47:09' prior: 16919543! - browseObsoleteMethodReferences - "Open a browser on all referenced behaviors that are obsolete - Smalltalk browseObsoleteMethodReferences - Remember that if no methods reference obsoletes, but - Smalltalk obsoleteBehaviors inspect - still finds them, maybe they are referenced by ChangeSets!! - " - | list | - list _ self obsoleteMethodReferences. - self browseMessageList: list name:'Method referencing obsoletes' autoSelect: nil! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 6/20/2017 13:46:17' prior: 16919851! - obsoleteBehaviors - " - Smalltalk obsoleteBehaviors inspect - Find all obsolete behaviors including meta classes - " - | obs | - obs _ OrderedCollection new. - Smalltalk garbageCollect. - self allObjectsDo: [ :cl | - (cl isBehavior and: [cl isObsolete]) ifTrue: [obs add: cl]]. - ^ obs asArray! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 6/20/2017 13:46:10' prior: 16919891! - obsoleteMethodReferences - " - Smalltalk obsoleteMethodReferences - Smalltalk browseObsoleteMethodReferences - Open a browser on all referenced behaviors that are obsolete" - | obsClasses obsRefs references | - references _ WriteStream on: Array new. - obsClasses _ self obsoleteBehaviors. - 'Scanning for methods referencing obsolete classes' displayProgressAt: Sensor mousePoint - from: 1 to: obsClasses size during: [ :bar | - obsClasses keysAndValuesDo: [ :index :each | - bar value: index. - obsRefs _ self pointersTo: each except: obsClasses. - obsRefs do: [ :ref | - "Figure out if it may be a global" - (ref isVariableBinding and: [ ref key isString "or Symbol" ]) ifTrue: [ - (self pointersTo: ref) do: [ :meth | - (meth is: #CompiledMethod) ifTrue: [ - meth methodReference ifNotNil: [ :mref | - (mref isValid and: [ mref compiledMethod == meth]) ifTrue: [ - references nextPut: mref ]]]]]]]. - ]. - ^references contents! ! -!MethodReference methodsFor: 'queries' stamp: 'jmv 6/20/2017 13:30:02' prior: 16873082! - printOn: aStream - "Print the receiver on a stream" - - super printOn: aStream. - aStream - space; - nextPutAll: classSymbol. - classIsMeta ifTrue: [ aStream nextPutAll: ' class' ]. - aStream - nextPutAll: ' >> '; - nextPutAll: methodSymbol! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3116-obsoleteMethodRefs-fix-JuanVuletich-2017Jun20-17h49m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3115] on 20 June 2017 at 5:51:43 pm'! -!Color methodsFor: 'conversions' stamp: 'jmv 6/20/2017 17:46:14' prior: 50353451! - pixelValueForDepth: d - "Returns an integer representing the bits that appear in a single pixel of this color in a Form of the given depth. The depth must be one of 1, 2, 4, 8, 16, or 32. Contrast with pixelWordForDepth: and bitPatternForDepth:, which return either a 32-bit word packed with the given pixel value or a multiple-word Bitmap containing a pattern. The inverse is the class message colorFromPixelValue:depth:" - "Details: For depths of 8 or less, the result is a colorMap index. For depths of 16 and 32, it is a direct color value with 5 or 8 bits per color component." - "Transparency: The pixel value zero is reserved for transparent. For depths greater than 8 and less than 32 (no Indexed colors, no real alpha), black maps to the darkest possible blue. - Note that - Color transparent class = TranslucentColor - this special case is handled in TranslucentColor >> #pixelValueForDepth: - " - - | bitBltFakeBlack val | - "Most common case" - "eight bits per component; top 8 bits set to all ones (opaque alpha)" - d = 32 ifTrue: [ - ^ 16rFF000000 bitOr: - ((((self at: 1) * 255.999) truncated bitShift: 16) bitOr: - ((((self at: 2) * 255.999) truncated bitShift: 8) bitOr: - (((self at: 3) * 255.999) truncated))) ]. - -"Faster in 32 bit systems, but slower in 64 bits" -" d = 32 ifTrue: [ - val _ LargePositiveInteger new: 4. - val at: 3 put: ((self at: 1) * 255.999) truncated. - val at: 2 put: ((self at: 2) * 255.999) truncated. - val at: 1 put: ((self at: 3) * 255.999) truncated. - val at: 4 put: 16rFF. - ^ val normalize]." - - d = 8 ifTrue: [^ self closestPixelValue8]. "common case" - d < 8 ifTrue: [ - d = 4 ifTrue: [^ self closestPixelValue4]. - d = 2 ifTrue: [^ self closestPixelValue2]. - d = 1 ifTrue: [^ self closestPixelValue1]]. - - "For the depth 16, pixelValue = 0 means transparent, black is represented as 16r8000 (rgb=0, pixelvalue !!= 0)." - (d = 16) | (d = 15) ifTrue: [ - "five bits per component; top bits ignored" - val _ ((self red * 31) rounded bitShift: 10) bitOr: - (((self green * 31) rounded bitShift: 5) bitOr: - ((self blue * 31) rounded)). - ^ val = 0 - ifTrue: [d = 16 ifTrue: [16r8000] ifFalse: [1]] - ifFalse: [val]]. - - "For the rest of the depths, pixelValue = 0 means transparent, and darkest blue is considered to be black." - bitBltFakeBlack := 1. "closest black that is not transparent in RGB - Not for depths <=8 (Indexed) or = 32 (RGBA)" - d = 12 ifTrue: [ "for indexing a color map with 4 bits per color component" - val _ ((self red * 15) rounded bitShift: 8) bitOr: - (((self green * 15) rounded bitShift: 4) bitOr: - ((self blue * 15) rounded)). - ^ val = 0 ifTrue: [bitBltFakeBlack] ifFalse: [val]]. - - d = 9 ifTrue: [ "for indexing a color map with 3 bits per color component" - val _ ((self red * 7) rounded bitShift: 6) bitOr: - (((self green * 7) rounded bitShift: 3) bitOr: - ((self blue * 7) rounded)). - ^ val = 0 ifTrue: [bitBltFakeBlack] ifFalse: [val]]. - - self error: 'unknown pixel depth: ', d printString! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3117-pixelValueForDepth-speedup-JuanVuletich-2017Jun20-17h50m-jmv.1.cs.st----! - -----SNAPSHOT----#(20 June 2017 5:57:31.430286 pm) Cuis5.0-3117-v3.image priorSource: 400355! - -----QUIT----#(20 June 2017 5:57:49.378972 pm) Cuis5.0-3117-v3.image priorSource: 1058207! - -----STARTUP----#(27 June 2017 7:12:15.894997 am) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3117-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3117] on 20 June 2017 at 11:19:24 pm'! -!WorldState methodsFor: 'initialization' stamp: 'jmv 6/20/2014 20:24:55' prior: 16945777! - clearWaitDelay - waitDelay ifNotNil: [ - waitDelay unschedule. - waitDelay _ nil ]. - "Needed if for some reason Cuis is started with an earlier DateTime than the image was saved. - Might happen, especially on RasPi or other systems without an RTC" - lastCycleTime _ Time localMillisecondClock. - lastAlarmTime _ 0.! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3118-FixHangWhenStartupInThePast-JuanVuletich-2017Jun20-23h18m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3103] on 18 June 2017 at 5:34:41 am'! -!Browser methodsFor: 'class comment pane' stamp: 'pb 6/18/2017 05:34:23' prior: 16791499! - newClassComment: aText - "The user has just entered aText. - It may be all red (a side-effect of replacing the default comment), so remove the color if it is." - | theClass | - theClass _ self selectedClassOrMetaClass theNonMetaClass. - theClass ifNotNil: [ - theClass classComment: aText asString ]. - self changed: #classCommentText. - ^ true! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3119-Class-comment-editor-fix-PhilBellalouna-2017Jun18-05h34m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3119] on 22 June 2017 at 12:54:43 pm'! -!Color methodsFor: 'as yet unclassified' stamp: 'jmv 6/22/2017 12:54:10'! - convertToCurrentVersion: varDict refStream: smartRefStrm - - "subclasses should implement if they wish to convert old instances to modern ones" - self size = 0 ifTrue: [ - ^ Color new copyFrom: (varDict at: 'floatRGB') ]. - ^ self! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3120-MigrateColorInstancesInSmartRefStream-JuanVuletich-2017Jun22-12h43m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3120] on 26 June 2017 at 8:03:37 pm'! -!ReadStream methodsFor: 'accessing' stamp: 'jmv 6/26/2017 19:34:17'! - readInto: byteArray startingAt: startIndex count: count - "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: count. - byteArray - replaceFrom: startIndex - to: startIndex+max-1 - with: collection - startingAt: position+1. - position _ position + max. - ^max! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3121-ReadStream-readInto-JuanVuletich-2017Jun26-19h32m-jmv.1.cs.st----! - -----SNAPSHOT----#(27 June 2017 7:12:23.031476 am) Cuis5.0-3121-v3.image priorSource: 1058301! - -----QUIT----#(27 June 2017 7:12:36.833399 am) Cuis5.0-3121-v3.image priorSource: 1061159! - -----STARTUP----#(2 August 2017 3:58:12.972093 pm) as C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\Cuis5.0-3121-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3121] on 6 July 2017 at 3:13:37 am'! -!ScrollBar methodsFor: 'access' stamp: 'pb 7/6/2017 02:44:45'! - scrollValue - ^ value! ! -!ScrollBar methodsFor: 'model access' stamp: 'pb 7/6/2017 02:53:19'! - internalScrollValue: newValue - "Called internally for propagation to model" - self scrollValue: newValue. - setValueSelector ifNotNil: [ - model perform: setValueSelector with: value ]! ! -!ScrollBar methodsFor: 'model access' stamp: 'pb 7/6/2017 02:45:15'! - scrollValue: newValue - "Drive the slider position externally..." - value _ newValue min: 1.0 max: 0.0. - self computeSlider! ! -!ProgressBarMorph methodsFor: 'accessing' stamp: 'pb 7/6/2017 02:42:04'! - progressValue - ^value! ! -!ProgressBarMorph methodsFor: 'accessing' stamp: 'pb 7/6/2017 02:42:12'! - progressValue: aValue - value _ aValue. - self redrawNeeded! ! -!PositionableStream methodsFor: 'fileIn/Out' stamp: 'jmv 10/10/2015 23:26' prior: 16891768! - 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 | - announcement - displayProgressAt: Sensor mousePoint - from: 0 - to: self size - during: [ :bar | - [ self atEnd ] whileFalse: [ - bar value: self position. - self skipSeparators. - - [ - val := (self peekFor: $!!) - ifTrue: [ - chunk := self nextChunk. - "These are the ones that should do nothing, - because next line is a doit that does the stuff - (or because it is handled elsewhere)" - (chunk beginsWith: 'description: ') - | (chunk beginsWith: 'provides: ') - | (chunk beginsWith: 'requires: ') - | (chunk beginsWith: 'classDefinition: ') - | (chunk beginsWith: 'classRemoval: ') - | (chunk beginsWith: 'methodRemoval: ') - | (chunk beginsWith: 'classMoveToSomePackage: ') - | (chunk beginsWith: 'methodMoveToSomePackage: ') - ifFalse: [(Compiler evaluate: chunk logged: false) scanFrom: self]] - ifFalse: [ - chunk := self nextChunk. - self checkForPreamble: chunk. - [ Compiler evaluate: chunk logged: true ] - on: Error - do: [ :ex | - ex print. - ('while evaluating: ', chunk) print. - ex pass ] - ]] - on: InMidstOfFileinNotification - do: [ :ex | ex resume: true ] ]. - ]. - "Note: The main purpose of this banner is to flush the changes file." - Smalltalk logChange: '----End fileIn of ' , self name , '----'. - ^val! ! -!PositionableStream methodsFor: 'gui' stamp: 'pb 7/6/2017 02:51:46' prior: 16892012! - untilEnd: aBlock displayingProgress: aString - aString - displayProgressAt: Sensor mousePoint - from: 0 to: self size - during: [ :bar | - [ self atEnd ] whileFalse: [ - bar scrollValue: self position. - aBlock value ]]! ! -!ProgressInitiationException class methodsFor: 'examples and tests' stamp: 'pb 7/6/2017 02:52:33' prior: 16896176! - testInnermost - - "test the progress code WITHOUT special handling" - - ^'Now here''s some Real Progress' - displayProgressAt: Sensor mousePoint - from: 0 - to: 10 - during: [ :bar | - 1 to: 10 do: [ :x | - bar scrollValue: x. - (Delay forMilliseconds: 500) wait. - x = 5 ifTrue: [1/0]. "just to make life interesting" - ]. - 'done' - ]. - -! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'pb 7/6/2017 02:46:41' prior: 16889660! - hSetScrollDelta - "Set the ScrollBar deltas, value and interval, based on the current scroll pane size, offset and range." - | range delta w | - - delta _ self scrollDeltaWidth * 1.0. "avoid Fraction arithmetic" - range _ self hLeftoverScrollRange. - range = 0 ifTrue: [ - ^hScrollBar scrollDelta: 0.02 pageDelta: 0.2; interval: 1.0; internalScrollValue: 0 ]. - - "Set up for one line (for arrow scrolling), or a full pane less one line (for paging)." - w _ self viewableWidth * 1.0. "avoid Fraction arithmetic" - hScrollBar scrollDelta: delta / range pageDelta: w - delta / range. - hScrollBar interval: w / self hTotalScrollRange. - hScrollBar internalScrollValue: hScrollBar scrollValue! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'pb 7/6/2017 02:48:25' prior: 16889801! - vSetScrollDelta - "Set the ScrollBar deltas, value and interval, based on the current scroll pane size, offset and range." - | range delta h | - - delta _ self scrollDeltaHeight * 1.0. "avoid Fraction arithmetic" - range _ self vLeftoverScrollRange. - range = 0 ifTrue: [ - ^ scrollBar scrollDelta: 0.02 pageDelta: 0.2; interval: 1.0; internalScrollValue: 0 ]. - - "Set up for one line (for arrow scrolling), or a full pane less one line (for paging)." - h _ self viewableHeight * 1.0. "avoid Fraction arithmetic" - scrollBar scrollDelta: delta / range pageDelta: h - delta / range. - scrollBar interval: h / self vTotalScrollRange. - scrollBar internalScrollValue: scrollBar scrollValue! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'pb 7/6/2017 02:48:00' prior: 16889930! - hideOrShowScrollBars - - "Assume for a moment we don't need an horizontal scrollbar" - self hHideScrollBar. - - "Add or remove vertical scrollbar, asuming for a monent there's no horizontal scrollbar, - to determine need of horizontal scrollbar..." - self vIsScrollbarNeeded - ifTrue: [ self vShowScrollBar ] - ifFalse: [ self vHideScrollBar ]. - - "If we need an horizontal scrollbar, add it." - self hIsScrollbarNeeded ifTrue: [ - self hShowScrollBar. - - "If horizontal scrollbar is needed, maybe vertical scrollbar will be needed too (even if we previously thoutht it wouldn't be needed)." - "Note that there is no chance of modifying the need of horizontal scrollbar: it was already needed. Therefore, there is no circularity here." - self vIsScrollbarNeeded ifTrue: [ - self vShowScrollBar ]]. - - "Ensure that if no scrollbars are needed, whole contents are visible" - self vIsScrollbarShowing ifFalse: [ - scrollBar internalScrollValue: 0 ]. - self hIsScrollbarShowing ifFalse: [ - hScrollBar internalScrollValue: 0 ]. - - self updateScrollBarsBounds! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'pb 7/6/2017 02:51:24' prior: 16889965! - scrollBy: delta - "Move the contents in the direction delta." - - | newYoffset r newXoffset | - - "Set the offset on the scroller" - newYoffset _ self scrollerOffset y - delta y max: 0. - newXoffset _ self scrollerOffset x - delta x max: 0. - - self scrollerOffset: newXoffset@ newYoffset. - - "Update the scrollBars" - (r _ self vLeftoverScrollRange) = 0 - ifTrue: [ scrollBar scrollValue: 0.0 ] - ifFalse: [ scrollBar scrollValue: newYoffset asFloat / r ]. - (r _ self hLeftoverScrollRange) = 0 - ifTrue: [ hScrollBar scrollValue: 0.0 ] - ifFalse: [ hScrollBar scrollValue: newXoffset asFloat / r ]! ! -!PluggableListMorph methodsFor: 'selection' stamp: 'pb 7/6/2017 02:47:04' prior: 16889020! - scrollSelectionIntoView - "make sure that the current selection is visible" - | row r | - row _ self getCurrentSelectionIndex. - row = 0 - ifTrue: [ - "Value is 0, but we need to propagate it to model" - scrollBar internalScrollValue: scrollBar scrollValue ] - ifFalse: [ - self flag: #jmvVer2. - r _ self listMorph drawBoundsForRow: row. - r _ ((self listMorph externalize: r origin) extent: r extent). - self scrollToShow: r ]! ! -!PluggableListMorphOfMany methodsFor: 'events' stamp: 'pb 7/6/2017 02:56:44' prior: 50362986! - mouseMove: aMouseMoveEvent localPosition: localEventPosition - "The mouse has moved, as characterized by the event provided. Adjust the scrollbar, and alter the selection as appropriate" - - | oldIndex oldVal row | - row _ (localEventPosition y < 0 and: [ scrollBar scrollValue > 0.0 ]) - ifTrue: [ - scrollBar scrollUp: 1. - "Leave at least one visible item unaffected, for better visual feedback to the user." - (self rowAtLocation: `0@0`) + 2 ] - ifFalse: [ - (localEventPosition y > extent y and: [ scrollBar scrollValue < 1.0 ]) - ifTrue: [ - scrollBar scrollDown: 1. - "Leave at least one visible item unaffected, for better visual feedback to the user." - (self rowAtLocation: 0@extent y) - 3 ] - ifFalse: [ self rowAtLocation: localEventPosition ]]. - row = 0 ifTrue: [ ^ self ]. - - "No change if model is locked" - self owningWindow ifNotNil: [ :w | - w okToChange ifFalse: [^ self]]. - - dragOnOrOff ifNil: [ - "Was not set at mouse down, which means the mouse must have gone down in an area where there was no list item" - dragOnOrOff _ (self listSelectionAt: row) not. - dragStartRow _ row ]. - - "Set meaning for subsequent dragging of selection" - oldIndex _ self getCurrentSelectionIndex. - oldIndex ~= 0 ifTrue: [ oldVal _ self listSelectionAt: oldIndex ]. - - "Set or clear new primary selection (listIndex)" - dragOnOrOff - ifTrue: [ self changeModelSelection: row ] - ifFalse: [ self changeModelSelection: 0 ]. - - "Need to restore the old one, due to how model works, and set new one." - oldIndex ~= 0 ifTrue: [ self listSelectionAt: oldIndex put: oldVal ]. - - "Select all in between if drag was too fast" - "self listSelectionAt: row put: dragOnOrOff." - (row min: dragStartRow) to: (row max: dragStartRow) do: [ :r | - self listSelectionAt: r put: dragOnOrOff ]! ! -!ScrollBar methodsFor: 'scrolling' stamp: 'pb 7/6/2017 02:48:48' prior: 16904721! - scrollByPage - "Scroll automatically while mouse is down" - nextPageDirection - ifTrue: [self internalScrollValue: (value + pageDelta min: 1.0)] - ifFalse: [self internalScrollValue: (value - pageDelta max: 0.0)] -! ! -!ScrollBar methodsFor: 'scrolling' stamp: 'pb 7/6/2017 02:48:59' prior: 16904734! - scrollDown: count - self internalScrollValue: (value + (scrollDelta * count) + 0.000001 min: 1.0)! ! -!ScrollBar methodsFor: 'scrolling' stamp: 'pb 7/6/2017 02:49:09' prior: 16904739! - scrollTo: handPositionRelativeToSlider - | v handPositionRelativeToUs | - grabPosition ifNotNil: [ - handPositionRelativeToUs _ slider externalize: handPositionRelativeToSlider. - v _ (self isHorizontal - ifTrue: [ handPositionRelativeToUs x - grabPosition x ] - ifFalse: [ handPositionRelativeToUs y - grabPosition y ]) - - borderWidth - self buttonExtent * 1.0 - / self freeSliderRoom. - self internalScrollValue: v ]! ! -!ScrollBar methodsFor: 'scrolling' stamp: 'pb 7/6/2017 02:49:21' prior: 16904758! - scrollUp: count - self internalScrollValue: (value - (scrollDelta * count) - 0.000001 max: 0.0)! ! -!ProgressBarMorph methodsFor: 'menu' stamp: 'pb 7/6/2017 02:57:29' prior: 16896049! - changeProgressValue: evt - | answer | - answer _ FillInTheBlankMorph - request: 'Enter new value (0 - 1.0)' - initialAnswer: self progressValue contents asString. - answer isEmptyOrNil ifTrue: [^ self]. - self progressValue: answer asNumber! ! -!ProgressMorph methodsFor: 'accessing' stamp: 'pb 7/6/2017 02:57:41' prior: 16896233! - done - ^progress progressValue! ! -!ProgressMorph methodsFor: 'accessing' stamp: 'pb 7/6/2017 02:52:47' prior: 16896236! - done: amountDone - progress progressValue: ((amountDone min: 1.0) max: 0.0)! ! -!InnerTextMorph methodsFor: 'editing' stamp: 'pb 7/6/2017 02:47:26' prior: 50336490! - acceptContents - "The message is sent when the user hits return or Cmd-S. - Accept the current contents and end editing." - "Inform the model of text to be accepted, and return true if OK." - - | accepted prevSelection prevScrollValue | - - prevSelection _ self editor selectionInterval copy. - prevScrollValue _ owner verticalScrollBar scrollValue. - - (self canDiscardEdits and: [(self hasProperty: #alwaysAccept) not]) ifTrue: [self flash. ^true]. - (self hasEditingConflicts and: [ self confirmAcceptAnyway not ]) ifTrue: [self flash. ^false]. - - accepted _ model acceptContentsFrom: owner. - "During the step for the browser, updatePaneIfNeeded is called, and - invariably resets the contents of the code-holding PluggableTextMorph - at that time, resetting the cursor position and scroller in the process. - The following line forces that update without waiting for the step, - then restores the cursor and scrollbar" - - "some implementors of acceptContentsFrom: answer self :(" - ^accepted == true - ifTrue: [ - model refetch. - self editor selectFrom: prevSelection first to: prevSelection last. - WorldState addDeferredUIMessage: [ - self world ifNotNil: [ :w | w activeHand newKeyboardFocus: self ]. - owner verticalScrollBar internalScrollValue: prevScrollValue]. - true] - ifFalse: [ false ]! ! - -ProgressBarMorph removeSelector: #value! - -ProgressBarMorph removeSelector: #value! - -ProgressBarMorph removeSelector: #value:! - -ProgressBarMorph removeSelector: #value:! - -ScrollBar removeSelector: #setValue:! - -ScrollBar removeSelector: #setValue:! - -ScrollBar removeSelector: #value! - -ScrollBar removeSelector: #value! - -ScrollBar removeSelector: #value:! - -ScrollBar removeSelector: #value:! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3122-Morphs-Distinct-value-Methods-PhilBellalouna-2017Jul06-02h42m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3121] on 15 July 2017 at 10:07:51 pm'! -!UpdatingStringMorph methodsFor: 'stepping' stamp: 'pb 7/15/2017 22:07:40' prior: 50337148! - stepAt: millisecondSinceLast - - self contents: (target perform: getSelector) asString! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3123-UpdatingStringMorph-Squeak-compatibility-PhilBellalouna-2017Jul15-22h07m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3121] on 15 July 2017 at 11:19:17 pm'! -!PluggableButtonMorph methodsFor: 'as yet unclassified' stamp: 'pb 7/15/2017 23:15:35'! - morphExtent - "Use extent if it has already been manually set, otherwise try to set it by computing from the label text and font, otherwise try using the icon extent, or finally fall back to the default value." - ^ extent ifNil: [ - extent := (self fontToUse notNil and: [ label notNil ]) - ifTrue: [ "Add a bit of padding" - (self fontToUse widthOfString: label) + 10 @ (self fontToUse height + 10) ] - ifFalse: [ - icon - ifNil: [ `20@15` ] - ifNotNil: [ icon extent ]]].! ! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'pb 7/15/2017 22:34:12' prior: 16899252! - morphHeight - -"Ensure everybody wants our coordinates!!" - self flag: #jmvVer2. - ^ self morphExtent y! ! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'pb 7/15/2017 22:34:52' prior: 16899265! - morphPosition: newPos extent: newExtent - "Change the position of this morph. Argument is in owner's coordinates." - - | oldBoundsInWorld someChange | - - "Ask for the old bounds before updating them, but ask for repair only if extent or position has really changed." - oldBoundsInWorld _ self morphBoundsInWorld. - someChange _ false. - (location isTranslation: newPos) ifFalse: [ - location _ location withTranslation: newPos. - someChange _ true ]. - - self morphExtent = newExtent ifFalse: [ - (self privateExtent: newExtent) ifTrue: [ - someChange _ true ]]. - - someChange ifTrue: [ - "Ask for the old bounds before updating them, but ask for repair only if extent or position has really changed." - oldBoundsInWorld ifNotNil: [ - self invalidateDisplayRect: oldBoundsInWorld from: nil ]. - self someSubmorphPositionOrExtentChanged. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]! ! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'pb 7/15/2017 22:34:20' prior: 16899296! - morphWidth - -"Ensure everybody wants our coordinates!!" - self flag: #jmvVer2. - ^ self morphExtent x! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'pb 7/15/2017 22:40:30' prior: 50362831! - draw3DLookOn: aCanvas - - | borderStyleSymbol c | - borderStyleSymbol _ self isPressed ifFalse: [ #raised ] ifTrue: [ #inset ]. - c _ color. - self mouseIsOver ifTrue: [ c _ c lighter ]. - aCanvas - fillRectangle: (`0@0` extent: self morphExtent) - color: c - borderWidth: borderWidth - borderStyleSymbol: borderStyleSymbol - baseColorForBorder: c. - - self drawRegularLabelOn: aCanvas! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'pb 7/15/2017 22:40:17' prior: 16888097! - drawEmbossedLabelOn: aCanvas - - | availableW center colorForLabel f l labelMargin targetSize w x y | - label ifNotNil: [ - colorForLabel _ Theme current buttonLabel. - self isPressed - ifFalse: [ - self mouseIsOver - ifFalse: [ colorForLabel _ colorForLabel adjustSaturation: -0.10 brightness: 0.10 ]] - ifTrue: [ colorForLabel _ colorForLabel adjustSaturation: 0.0 brightness: -0.07 ]. - f _ self fontToUse. - center _ self morphExtent // 2. - labelMargin _ 3. - w _ f widthOfString: label. - availableW _ self morphExtent x - labelMargin - labelMargin. - availableW >= w - ifTrue: [ - l _ label ] - ifFalse: [ - x _ labelMargin. - targetSize _ label size * availableW // w. - l _ label squeezedTo: targetSize. - (f widthOfString: l) > availableW ifTrue: [ - targetSize _ targetSize - 1. - l _ label squeezedTo: targetSize ]]. - - w _ f widthOfString: l. - x _ center x - (w // 2). - y _ center y - (f height // 2). - aCanvas - drawString: l - at: x@y - font: f - color: colorForLabel - embossed: true ]! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'pb 7/15/2017 22:39:57' prior: 16888142! - drawRegularLabelOn: aCanvas - - | w f center x y availableW l labelMargin | - - f _ self fontToUse. - center _ self morphExtent // 2. - - label ifNotNil: [ - labelMargin _ 4. - w _ f widthOfString: label. - availableW _ self morphExtent x - labelMargin - labelMargin - 1. - availableW >= w - ifTrue: [ - x _ center x - (w // 2). - l _ label ] - ifFalse: [ - x _ labelMargin. - l _ label squeezedTo: (label size * availableW / w) rounded ]. - y _ center y - (f height // 2). - self isPressed ifTrue: [ - x _ x + 1. - y _ y + 1 ]. - aCanvas - drawString: l - at: x@y - font: f - color: Theme current buttonLabel ]! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'pb 7/15/2017 22:39:34' prior: 50362846! - drawRoundGradientLookOn: aCanvas - | r colorForButton rect bottomFactor topFactor | - - self isPressed - ifFalse: [ - topFactor _ Theme current buttonGradientTopFactor. - bottomFactor _ Theme current buttonGradientBottomFactor. - self mouseIsOver - ifTrue: [ - colorForButton _ Color h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ - colorForButton _ color ]] - ifTrue: [ - topFactor _ Theme current buttonGradientBottomFactor. - bottomFactor _ Theme current buttonGradientTopFactor. - colorForButton _ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - Theme current useButtonGradient - ifTrue: [ - rect _ (`0@0` extent: self morphExtent) insetBy: `1@3`. - aCanvas - roundRect: rect - color: colorForButton - radius: r - gradientTop: topFactor - gradientBottom: bottomFactor - gradientHeight: Theme current buttonGradientHeight ] - ifFalse: [ - rect _ (`0@0` extent: self morphExtent) insetBy: `1@3`. - aCanvas roundRect: rect color: colorForButton radius: r ] - ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawEmbossedLabelOn: aCanvas ] - ifFalse: [ self drawRegularLabelOn: aCanvas ]! ! -!PluggableButtonMorph methodsFor: 'initialization' stamp: 'pb 7/15/2017 22:36:46' prior: 50362888! - initialize - "initialize the state of the receiver" - super initialize. - - roundButtonStyle := nil. "nil: honor Theme. true: draw as round button. false: draw as classic 3d border square button" - model := nil. - getStateSelector := nil. - actionSelector := nil. - isPressed := false. - mouseIsOver := false. - actWhen := #buttonUp. - "We are overriding any value populated in extent by our superclass with nil so we know to perform the inital morph extent calculation" - extent := nil! ! -!PluggableButtonMorph methodsFor: 'private' stamp: 'pb 7/15/2017 22:36:28' prior: 50337959! - magnifiedIcon - | factor magnifiedExtent w h | - - icon ifNil: [ ^nil ]. - magnifiedIcon ifNil: [ - magnifiedIcon := icon. - w := icon width. - h := icon height. - w*h = 0 ifFalse: [ - factor _ 1.0 * self morphExtent x / w min: 1.0 * self morphExtent y / h. - (factor < 1 or: [ factor > 1.7 and: [self isRoundButton]]) ifTrue: [ - magnifiedExtent := (icon extent * factor) rounded. - magnifiedIcon := icon magnifyTo: magnifiedExtent ]]]. - ^magnifiedIcon! ! -!PluggableButtonMorph methodsFor: 'geometry testing' stamp: 'pb 7/15/2017 22:38:44' prior: 50362902! - morphContainsPoint: aLocalPoint - - | iconOrigin | - ((`0@0` extent: self morphExtent) containsPoint: aLocalPoint) ifFalse: [ ^false ]. - ^ self isOrthoRectangularMorph or: [ - magnifiedIcon isNil or: [ - iconOrigin := self morphExtent - magnifiedIcon extent // 2. - (magnifiedIcon isTransparentAt: (aLocalPoint - iconOrigin) rounded) not ]]! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3124-PluggableButtonMorph-initial-extent-PhilBellalouna-2017Jul15-22h29m-pb.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3121] on 16 July 2017 at 3:33:18 pm'! -!Morph methodsFor: 'events' stamp: 'pb 7/16/2017 15:06:53'! - mouseHover: aMouseMoveEvent localPosition: localEventPosition - "Handle a mouse move event. - This message will only be sent to Morphs that answer true to #handlesMouseHover for events that have not been previously handled. - We can query aMouseMoveEvent to know about pressed mouse buttons." - "Allow instances to dynamically use properties for handling common events." - self - valueOfProperty: #mouseHover:localPosition: - ifPresentDo: [ :handler | - handler - value: aMouseMoveEvent - value: localEventPosition ].! ! -!Morph methodsFor: 'event handling testing' stamp: 'pb 7/16/2017 15:00:51'! - handlesMouseHover - "Do I want to receive unhandled mouseMove events when the button is up and the hand is empty? The default response is false." - "Use a property test to allow individual instances to specify this." - ^ self hasProperty: #handlesMouseHover.! ! -!Morph methodsFor: 'events-processing' stamp: 'pb 7/16/2017 15:31:38' prior: 16875080! - processMouseOver: aMouseEvent localPosition: localEventPosition - "System level event handling." - self hasMouseFocus ifTrue: [ - "Got this directly through #handleFocusEvent: so check explicitly" - (self containsPoint: localEventPosition event: aMouseEvent) ifFalse: [ - ^self ]]. - aMouseEvent hand noticeMouseOver: self event: aMouseEvent. - "Open question: should any unhandled mouse move events be filtered out? (i.e. should mouseHover:localPosition: be called when a mouse button is pressed but the morph doesn't have mouse button handlers? Essentially, what are the limits of what is considered 'hovering'?" - (self handlesMouseHover and: [aMouseEvent wasHandled not]) ifTrue: [ - self - mouseHover: aMouseEvent - localPosition: localEventPosition ].! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3125-Morph-hovering-PhilBellalouna-2017Jul16-15h00m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3122] on 17 July 2017 at 3:52:45 pm'! -!ChangeList methodsFor: 'scanning' stamp: 'jmv 7/17/2017 15:44:04' prior: 16795940! - scanFile: aFile from: startPosition to: stopPosition - - file _ aFile. - changeList _ OrderedCollection new. - list _ OrderedCollection new. - listIndex _ 0. - file position: startPosition. - 'Scanning ', aFile localName, '...' - displayProgressAt: Sensor mousePoint - from: startPosition to: stopPosition - during: [ :barBlock | - [file position < stopPosition] whileTrue: [ | prevChar | - barBlock value: file position. - [file atEnd not and: [file peek isSeparator]] - whileTrue: [prevChar _ file next]. - (file peekFor: $!!) - ifTrue: [ - "A line starting with $!! means a specific ChangeRecord type" - (prevChar notNil and: [ prevChar isLineSeparator ]) - ifTrue: [self scanSpecificChangeRecordType]] - ifFalse: [ - "Otherwise, interpret it with #doIt:" - | itemPosition item | - itemPosition _ file position. - item _ file nextChunk. - item size > 0 ifTrue: [ - self - addItem: (ChangeRecord new file: file position: itemPosition type: #doIt) - text: 'do it: ' , (item contractTo: 160)]]]]. - self clearSelections! ! -!ClassBuilder methodsFor: 'private' stamp: 'jmv 7/17/2017 15:48:14' prior: 16803943! - informUserDuring: aBlock - self class isSilent ifTrue:[^aBlock value]. - Utilities informUserDuring:[:barBlock| - progress _ barBlock. - aBlock value]. - progress _ nil.! ! -!Integer class methodsFor: 'prime numbers' stamp: 'jmv 7/17/2017 15:44:55' prior: 16861068! - verbosePrimesUpTo: max do: aBlock - "Integer verbosePrimesUpTo: SmallInteger maxVal" "<- heh, heh" - "Compute primes up to max, but be verbose about it" - | lastTime | - lastTime := Time localMillisecondClock. - Utilities informUserDuring: [ :barBlock| - barBlock value:'Computing primes...'. - self primesUpTo: max do: [ :prime| | nowTime | - aBlock value: prime. - nowTime := Time localMillisecondClock. - (nowTime - lastTime > 1000) ifTrue:[ - lastTime := nowTime. - barBlock value: 'Last prime found: ', prime printString]]].! ! -!LookupKey methodsFor: 'bindings' stamp: 'jmv 7/17/2017 15:45:04' prior: 16865388! - recompileBindingsAnnouncing: aBool - "Make the receiver (a global read-write binding) be a read-only binding" - aBool ifTrue:[ - Utilities informUserDuring: [ :barBlock | - (Smalltalk allCallsOn: self) do: [ :mref | - barBlock value: 'Recompiling ', mref stringVersion. - mref actualClass recompile: mref methodSymbol ]. - ]. - ] ifFalse:[ - (Smalltalk allCallsOn: self) do: [ :mref | - mref actualClass recompile: mref methodSymbol ] - ]! ! -!SequenceableCollection methodsFor: 'gui' stamp: 'jmv 7/17/2017 15:45:17' prior: 16906997! - do: aBlock displayingProgress: aString - aString - displayProgressAt: Sensor mousePoint - from: 0 to: self size - during: [ :barBlock | - self withIndexDo: [ :each :i | - barBlock value: i. - aBlock value: each]]! ! -!String methodsFor: 'displaying' stamp: 'jmv 7/17/2017 15:41:46' prior: 16917058! - 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 mousePoint - from: 0 to: 100 - during: [:barBlock | - 1 to: 100 do: [:x | - (Delay forMilliseconds: 10) wait. - barBlock value: x.]]. - -['Now here''s some Real Progress' - displayProgressAt: Sensor mousePoint - from: 0 to: 100 - during: [:barBlock | - 1 to: 100 do: [:x | barBlock value: x. - (Delay forMilliseconds: 100) wait]].] fork - -['Now here''s some Real Progress' - displayProgressAt: Sensor mousePoint - from: 0 to: 10 - during: [:barBlock | - 1 to: 30 do: [:x | barBlock value: x \\ 11. - (Delay forMilliseconds: 100) wait]]] fork - -'Now here''s some Real Progress' - displayProgressAt: Sensor mousePoint - from: 0 to: 10 - during: [:barBlock | - 1 to: 30 do: [:x | barBlock value: nil. - (Delay forMilliseconds: 200) 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. - -The use of ProgressInitiationException allows for avoiding actual -progress display, by catching the exception. -" - ^ProgressInitiationException - display: self - at: aPoint - from: minVal - to: maxVal - during: workBlock! ! -!Set class methodsFor: 'initialization' stamp: 'jmv 7/17/2017 15:40:16' prior: 16907390! - quickRehashAllSets "Set rehashAllSets" - | insts | - self withAllSubclassesDo: - [:c | - insts _ c allInstances. - (insts isEmpty or: [c = MethodDictionary]) ifFalse: - ['Rehashing instances of ' , c name - displayProgressAt: Sensor mousePoint - from: 1 to: insts size - during: [ :barBlock | 1 to: insts size do: [:x | barBlock value: x. (insts at: x) rehash]] - ] - ]! ! -!Set class methodsFor: 'initialization' stamp: 'jmv 7/17/2017 15:40:27' prior: 16907404! - rehashAllSets "Set rehashAllSets" - | insts | - self withAllSubclassesDo: - [:c | insts _ c allInstances. - insts isEmpty ifFalse: - ['Rehashing instances of ' , c name - displayProgressAt: Sensor mousePoint - from: 1 to: insts size - during: [ :barBlock | - 1 to: insts size do: - [ :x | barBlock value: x. - (insts at: x) rehash]]]]! ! -!Dictionary methodsFor: 'removing' stamp: 'jmv 7/17/2017 15:44:29' prior: 16833635! - unreferencedKeys - "| uk | (Time millisecondsToRun: [uk := TextConstants unreferencedKeys]) -> uk" - - ^'Scanning for references . . .' - displayProgressAt: Sensor mousePoint - from: 0 - to: Smalltalk classNames size * 2 - during: - [:barBlock | | currentClass n associations referencedAssociations | - currentClass := nil. - n := 0. - associations := self associations asIdentitySet. - referencedAssociations := IdentitySet new: associations size. - Smalltalk allSelect: - [:m| - m methodClass ~~ currentClass ifTrue: - [currentClass := m methodClass. - barBlock value: (n := n + 1)]. - m literalsDo: - [:l| - (l isVariableBinding and: [associations includes: l]) ifTrue: - [referencedAssociations add: l]]. - false]. - ((associations reject: [:assoc | referencedAssociations includes: assoc]) collect: [:assoc| assoc key]) asSet]! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 7/17/2017 15:46:10' prior: 16919601! -condenseChanges - "Move all the changes onto a compacted sources file." - " - Smalltalk condenseChanges - " - - | oldChanges classCount oldChangesLocalName oldChangesPathName | - DirectoryEntry smalltalkImageDirectory // 'ST80.temp' forceWriteStreamDo: [ :f | - f timeStamp. - 'Condensing Changes File...' - displayProgressAt: Sensor mousePoint - from: 0 to: Smalltalk classNames size - during: [ :barBlock | - classCount _ 0. - Smalltalk allClassesDo: [ :class | - barBlock value: (classCount _ classCount + 1). - class moveChangesTo: f. - class putClassCommentToCondensedChangesFile: f. - class class moveChangesTo: f ]]. - LastQuitLogPosition _ f position ]. - - CompiledMethod allInstancesDo: [ :e | - e isInstalled ifFalse: [ e destroySourcePointer ] ]. - - oldChanges _ SourceFiles at: 2. - oldChangesPathName _ oldChanges name. - oldChangesLocalName _ oldChanges localName. - oldChanges close. - (oldChangesPathName, '.old') asFileEntry delete. - oldChangesPathName asFileEntry rename: oldChangesLocalName, '.old'. - DirectoryEntry smalltalkImageDirectory // 'ST80.temp' rename: oldChangesLocalName. - - SourceFiles - at: 2 put: oldChangesPathName asFileEntry appendStream. - - self inform: 'Changes file has been rewritten!! - -Check that all is well, and then save/quit. - -Otherwise, remove new changes, -replace it with the former one, and -exit without saving the image. - '! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 7/17/2017 15:46:14' prior: 16919647! - condenseSources - "Move all the changes onto a compacted sources file." - "Smalltalk condenseSources" - - | classCount newVersionString oldChanges oldChangesLocalName oldChangesPathName newChangesPathName newSourcesName | - newVersionString _ FillInTheBlankMorph request: 'Please name the new sources file' initialAnswer: SourceFileVersionString. - newVersionString ifNil: [^ self]. - newVersionString = SourceFileVersionString ifTrue: [ - ^ self error: 'The new source file must not be the same as the old.']. - SourceFileVersionString _ newVersionString. - - "Write all sources with fileIndex 1" - newSourcesName _ self defaultSourcesName. - newSourcesName asFileEntry writeStreamDo: [ :f | - f timeStamp. - 'Condensing Sources File...' - displayProgressAt: Sensor mousePoint - from: 0 to: Smalltalk classNames size - during: [ :barBlock | - classCount _ 0. - Smalltalk allClassesDo: [ :class | - barBlock value: (classCount _ classCount + 1). - class fileOutOn: f moveSource: true toFile: 1]]]. - - CompiledMethod allInstancesDo: [ :e | - e isInstalled ifFalse: [ e destroySourcePointer ] ]. - - "Make a new empty changes file" - oldChanges _ SourceFiles at: 2. - oldChangesPathName _ oldChanges name. - oldChangesLocalName _ oldChanges localName. - self closeSourceFiles. - oldChangesPathName ifNotNil: [ - (oldChangesPathName, '.old') asFileEntry delete. - oldChangesPathName asFileEntry rename: oldChangesLocalName, '.old' ]. - newChangesPathName _ self defaultChangesName. - newChangesPathName asFileEntry writeStreamDo: [ :stream | - stream timeStamp ]. - LastQuitLogPosition _ 0. - - self openSourceFiles. - self inform: 'Source files have been rewritten!! - -Check that all is well, and then save/quit. - -Otherwise, remove new sources/changes, -replace them with the former ones, and -exit without saving the image. - '! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 7/17/2017 15:41:56' prior: 16919755! - macroBenchmark1 "Smalltalk macroBenchmark1" - "Decompiles and prettyPrints the source for every method in the system (or less depending on the *FILTER*, and then compiles that source and verifies that it generates (and decompiles to) identical code. This currently fails in a number of places because some different patterns (esp involving conditionals where the first branch returns) decompile the same. Because it never installs the new method, it should not cause any flusing of the method cache." - | methodNode oldMethod newMethod badOnes oldCodeString n classes | - classes _ Smalltalk allClasses select: [:c | c name < 'B3']. - badOnes _ OrderedCollection new. -'Decompiling and recompiling...' -displayProgressAt: Sensor mousePoint -from: 0 to: (classes detectSum: [:c | c selectors size]) -during: [:barBlock | n _ 0. - classes do: - [:cls | - "Transcript cr; show: cls name." - cls selectors do: - [:selector | barBlock value: (n _ n+1). - oldMethod _ cls compiledMethodAt: selector. - oldCodeString _ (cls decompilerClass new - decompile: selector in: cls method: oldMethod) - decompileString. - methodNode _ cls compilerClass new - compile: oldCodeString - in: cls notifying: nil ifFail: nil. - newMethod _ methodNode generate: #(0 0 0 0). - oldCodeString = (cls decompilerClass new - decompile: selector in: cls method: newMethod) - decompileString ifFalse: [badOnes add: cls name , ' ' , selector]]]. -]. - ^ badOnes size! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 7/17/2017 15:46:19' prior: 16919804! - macroBenchmark3 "Smalltalk macroBenchmark3" - | testBlock tallies prev receiver | - "Runs the stepping simulator with the messageTally tree (like tallySends)." - testBlock _ - ['Running the context step simulator' - displayProgressAt: Sensor mousePoint - from: 0 to: 200 - during: - [:barBlock | - 1 to: 200 do: - [:x | barBlock value: x. - Float pi printString. - 15 factorial printString]]]. - tallies _ MessageTally new class: testBlock receiver class - method: testBlock method. - receiver _ nil. - prev _ testBlock. - thisContext sender - runSimulated: testBlock - contextAtEachStep: - [:current | - current == prev ifFalse: [ - "call or return" - prev sender ifNotNil: [ - "call only" - (receiver == nil or: [current receiver == receiver]) - ifTrue: [tallies tally: current by: 1]]. - prev _ current]]. -! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 7/17/2017 15:46:24' prior: 50364568! - obsoleteMethodReferences - " - Smalltalk obsoleteMethodReferences - Smalltalk browseObsoleteMethodReferences - Open a browser on all referenced behaviors that are obsolete" - | obsClasses obsRefs references | - references _ WriteStream on: Array new. - obsClasses _ self obsoleteBehaviors. - 'Scanning for methods referencing obsolete classes' displayProgressAt: Sensor mousePoint - from: 1 to: obsClasses size during: [ :barBlock | - obsClasses keysAndValuesDo: [ :index :each | - barBlock value: index. - obsRefs _ self pointersTo: each except: obsClasses. - obsRefs do: [ :ref | - "Figure out if it may be a global" - (ref isVariableBinding and: [ ref key isString "or Symbol" ]) ifTrue: [ - (self pointersTo: ref) do: [ :meth | - (meth is: #CompiledMethod) ifTrue: [ - meth methodReference ifNotNil: [ :mref | - (mref isValid and: [ mref compiledMethod == meth]) ifTrue: [ - references nextPut: mref ]]]]]]]. - ]. - ^references contents! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 7/17/2017 15:46:30' prior: 16919989! - testDecompiler - " - Smalltalk testDecompiler - " - "Decompiles the source for every method in the system, and then compiles that source and verifies that it generates (and decompiles to) identical code. This currently fails in a number of places because some different patterns (esp involving conditionals where the first branch returns) decompile the same." - | methodNode oldMethod newMethod badOnes oldCodeString n | - badOnes _ OrderedCollection new. - 'Decompiling all classes...' - displayProgressAt: Sensor mousePoint - from: 0 - to: CompiledMethod instanceCount - during: [ :barBlock | - n _ 0. - Smalltalk allBehaviorsDo: [ :cls | - "Transcript cr; show: cls name." - cls selectors do: [ :selector | - (n _ n + 1) \\ 100 = 0 ifTrue: [ barBlock value: n ]. - oldMethod _ cls compiledMethodAt: selector. - oldCodeString _ (cls decompilerClass new - decompile: selector - in: cls - method: oldMethod) decompileString. - methodNode _ cls compilerClass new - compile: oldCodeString - in: cls - notifying: nil - ifFail: nil. - newMethod _ methodNode generate: #(0 0 0 0 ). - oldCodeString = - (cls decompilerClass new - decompile: selector - in: cls - method: newMethod) decompileString ifFalse: [ - Transcript - newLine; - show: '***' , cls name , ' ' , selector. - badOnes add: (MethodReference class: cls selector: selector) ]]]]. - Smalltalk - browseMessageList: badOnes asArray sort - name: 'Decompiler Discrepancies'.! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 7/17/2017 15:46:37' prior: 16920039! - testFormatter - "Smalltalk testFormatter" - "Reformats the source for every method in the system, and then compiles that source and verifies that it generates identical code. - The formatting used will be classic monochrome." - | newCodeString methodNode oldMethod newMethod badOnes n | - badOnes _ OrderedCollection new. - 'Formatting all classes...' - displayProgressAt: Sensor mousePoint - from: 0 - to: CompiledMethod instanceCount - during: [ :barBlock | - n _ 0. - Smalltalk allBehaviorsDo: [ :cls | - "Transcript cr; show: cls name." - cls selectors do: [ :selector | - (n _ n + 1) \\ 100 = 0 ifTrue: [ barBlock value: n ]. - newCodeString _ cls compilerClass new - format: (cls sourceCodeAt: selector) - in: cls - notifying: nil. - methodNode _ cls compilerClass new - compile: newCodeString - in: cls - notifying: nil - ifFail: nil. - newMethod _ methodNode generate: #(0 0 0 0 ). - oldMethod _ cls compiledMethodAt: selector. - oldMethod = newMethod ifFalse: [ - Transcript - newLine; - show: '***' , cls name , ' ' , selector. - badOnes add: cls name , ' ' , selector ]]]]. - Smalltalk - browseMessageList: badOnes asArray sort - name: 'Formatter Discrepancies'.! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 7/17/2017 15:46:43' prior: 16920080! - testFormatter2 - "Smalltalk testFormatter2" - "Reformats the source for every method in the system, and then verifies that the order of source tokens is unchanged. - The formatting used will be classic monochrome" - | newCodeString badOnes n oldCodeString oldTokens newTokens | - badOnes _ OrderedCollection new. - 'Formatting all classes...' - displayProgressAt: Sensor mousePoint - from: 0 - to: CompiledMethod instanceCount - during: [ :barBlock | - n _ 0. - Smalltalk allBehaviorsDo: [ :cls | - "Transcript cr; show: cls name." - cls selectors do: [ :selector | - (n _ n + 1) \\ 100 = 0 ifTrue: [ barBlock value: n ]. - oldCodeString _ (cls sourceCodeAt: selector) asString. - newCodeString _ cls compilerClass new - format: oldCodeString - in: cls - notifying: nil. - oldTokens _ oldCodeString findTokens: Character separators. - newTokens _ newCodeString findTokens: Character separators. - oldTokens = newTokens ifFalse: [ - Transcript - newLine; - show: '***' , cls name , ' ' , selector. - badOnes add: cls name , ' ' , selector ]]]]. - Smalltalk - browseMessageList: badOnes asArray sort - name: 'Formatter Discrepancies'.! ! -!SystemDictionary methodsFor: 'retrieving' stamp: 'jmv 7/17/2017 15:45:58' prior: 16921677! - allMethodsSourceStringMatching: aString - "Answer a sorted Collection of all the methods that contain, in source code, aString as a substring. - Search the class comments also. - Argument might include $*, that matches any subsequence. - For example, try: - ensure:*[*close*] - " - | list classCount adder | - list _ Set new. - adder _ [ :mrClass :mrSel | - list add: - (MethodReference new - setStandardClass: mrClass - methodSymbol: mrSel) ]. - 'Searching all source code...' - displayProgressAt: Sensor mousePoint - from: 0 - to: Smalltalk classNames size - during: [ :barBlock | - classCount _ 0. - Smalltalk allClassesDo: [ :class | - barBlock value: (classCount _ classCount + 1). - (Array - with: class - with: class class) do: [ :cl | - cl selectorsDo: [ :sel | - (aString match: (cl sourceCodeAt: sel)) ifTrue: [ - adder - value: cl - value: sel ]]. - - (aString match: cl organization classComment asString) ifTrue: [ - adder - value: cl - value: #Comment ]]]]. - ^ list asArray sort.! ! -!SystemDictionary methodsFor: 'retrieving' stamp: 'jmv 7/17/2017 15:46:02' prior: 16921712! - allMethodsWithSourceString: aString matchCase: caseSensitive - "Answer a sorted Collection of all the methods that contain, in source code, aString as a substring. Search the class comments also" - | list classCount adder | - list _ Set new. - adder _ [ :mrClass :mrSel | - list add: - (MethodReference new - setStandardClass: mrClass - methodSymbol: mrSel) ]. - 'Searching all source code...' - displayProgressAt: Sensor mousePoint - from: 0 - to: Smalltalk classNames size - during: [ :barBlock | - classCount _ 0. - Smalltalk allClassesDo: [ :class | - barBlock value: (classCount _ classCount + 1). - (Array - with: class - with: class class) do: [ :cl | - cl selectorsDo: [ :sel | - ((cl sourceCodeAt: sel) - findString: aString - startingAt: 1 - caseSensitive: caseSensitive) > 0 ifTrue: [ - adder - value: cl - value: sel ]]. - (cl organization classComment asString - findString: aString - startingAt: 1 - caseSensitive: caseSensitive) > 0 ifTrue: [ - adder - value: cl - value: #Comment ]]]]. - ^ list asArray sort.! ! -!SystemDictionary methodsFor: 'shrinking' stamp: 'jmv 7/17/2017 15:45:48' prior: 16922180! - abandonSources - " - Smalltalk abandonSources - " - | m bTotal bCount | - (self confirm: -'This method will detach the image fom source code. -A fresh changes file will be created to record further changes. --- CAUTION -- -If you have backed up your system and -are prepared to face the consequences of -abandoning source code files, choose Yes. -If you have any doubts, you may choose No -to back out with no harm done.') - == true ifFalse: [^ self inform: 'Okay - no harm done']. - bTotal _ 0. bCount _ 0. - Smalltalk allBehaviorsDo: [: b | bTotal _ bTotal + 1]. -'Doing #destroySourcePointer ...' - displayProgressAt: Sensor mousePoint - from: 0 to: bTotal - during: [ :barBlock | - Smalltalk allBehaviorsDo: [ :cl | - "for testing" - "{ EllipseMorph } do: [ :cl |" - barBlock value: (bCount _ bCount + 1). - cl selectors do: [:selector | - m _ cl compiledMethodAt: selector. - m destroySourcePointer ]]]. - Smalltalk allBehaviorsDo: [:b | b zapOrganization]. - Smalltalk closeSourceFiles. - Preferences disable: #warnIfNoChangesFile. - Preferences disable: #warnIfNoSourcesFile! ! -!SystemDictionary methodsFor: 'shrinking' stamp: 'jmv 7/17/2017 15:42:02' prior: 16922340! - removeAllUnSentMessages - "Smalltalk removeAllUnSentMessages" - "[Smalltalk unusedClasses do: [:c | (Smalltalk at: c) removeFromSystem]. - Smalltalk removeAllUnSentMessages > 0] whileTrue." - "Remove all implementations of unsent messages." - | sels n | - sels _ self allUnSentMessages. - self presumedSentMessages - do: [:sel | sels - remove: sel - ifAbsent: nil]. - sels size = 0 - ifTrue: [^ 0]. - n _ 0. - Smalltalk - allBehaviorsDo: [:x | n _ n + 1]. - 'Removing ' , sels size printString , ' messages . . .' - displayProgressAt: Sensor mousePoint - from: 0 - to: n - during: [:barBlock | - n _ 0. - self - allBehaviorsDo: [:class | - barBlock value: (n _ n + 1). - sels - do: [:sel | class removeSelector: sel]]]. - ^ sels size! ! -!PositionableStream methodsFor: 'fileIn/Out' stamp: 'jmv 7/17/2017 15:45:10' prior: 50364852! - 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 | - announcement - displayProgressAt: Sensor mousePoint - from: 0 - to: self size - during: [ :barBlock | - [ self atEnd ] whileFalse: [ - barBlock value: self position. - self skipSeparators. - - [ - val := (self peekFor: $!!) - ifTrue: [ - chunk := self nextChunk. - "These are the ones that should do nothing, - because next line is a doit that does the stuff - (or because it is handled elsewhere)" - (chunk beginsWith: 'description: ') - | (chunk beginsWith: 'provides: ') - | (chunk beginsWith: 'requires: ') - | (chunk beginsWith: 'classDefinition: ') - | (chunk beginsWith: 'classRemoval: ') - | (chunk beginsWith: 'methodRemoval: ') - | (chunk beginsWith: 'classMoveToSomePackage: ') - | (chunk beginsWith: 'methodMoveToSomePackage: ') - ifFalse: [(Compiler evaluate: chunk logged: false) scanFrom: self]] - ifFalse: [ - chunk := self nextChunk. - self checkForPreamble: chunk. - [ Compiler evaluate: chunk logged: true ] - on: Error - do: [ :ex | - ex print. - ('while evaluating: ', chunk) print. - ex pass ] - ]] - on: InMidstOfFileinNotification - do: [ :ex | ex resume: true ] ]. - ]. - "Note: The main purpose of this banner is to flush the changes file." - Smalltalk logChange: '----End fileIn of ' , self name , '----'. - ^val! ! -!PositionableStream methodsFor: 'gui' stamp: 'jmv 7/17/2017 15:38:57' prior: 50364910! - untilEnd: aBlock displayingProgress: aString - aString - displayProgressAt: Sensor mousePoint - from: 0 to: self size - during: [ :barBlock | - [ self atEnd ] whileFalse: [ - barBlock value: self position. - aBlock value ]]! ! -!ReferenceStream methodsFor: 'statistics' stamp: 'jmv 7/17/2017 15:40:06' prior: 16899982! - statisticsOfRefs - "Analyze the information in references, the objects being written out" - - | parents n kids nm ownerBags tallies owners objParent normalReferences | - normalReferences _ self references. "Exclude unrealized weaks" - parents _ IdentityDictionary new: normalReferences size * 2. - n _ 0. - 'Finding Owners...' - displayProgressAt: Sensor mousePoint - from: 0 to: normalReferences size - during: [ :barBlock | - normalReferences keysDo: - [ :parent | barBlock value: (n _ n+1). - kids _ parent class isFixed - ifTrue: [(1 to: parent class instSize) collect: [:i | parent instVarAt: i]] - ifFalse: [parent class isBits ifTrue: [Array new] - ifFalse: [(1 to: parent basicSize) collect: [:i | parent basicAt: i]]]. - (kids select: [:x | normalReferences includesKey: x]) - do: [:child | parents at: child put: parent]]]. - ownerBags _ Dictionary new. - tallies _ Bag new. - n _ 0. - 'Tallying Owners...' - displayProgressAt: Sensor mousePoint - from: 0 to: normalReferences size - during: [ :barBlock | - normalReferences keysDo: "For each class of obj, tally a bag of owner classes" - [ :obj | barBlock value: (n _ n+1). - nm _ obj class name. - tallies add: nm. - owners _ ownerBags at: nm ifAbsent: [ownerBags at: nm put: Bag new]. - (objParent _ parents at: obj ifAbsent: nil) ifNotNil: [ - owners add: objParent class name]]]. - ^ String streamContents: [ :strm | - tallies sortedCounts do: [ :assn | - n _ assn key. nm _ assn value. - owners _ ownerBags at: nm. - strm newLine; nextPutAll: nm; space; print: n. - owners size > 0 ifTrue: [ - strm newLine; tab; print: owners sortedCounts]]]! ! -!SmartRefStream methodsFor: 'read write' stamp: 'jmv 7/17/2017 15:40:37' prior: 16911182! - nextPut: anObject - "Really write three objects: (version, class structure, object). But only when called from the outside. If any instance-specific classes are present, prepend their source code. byteStream will be in fileOut format. - You can see an analysis of which objects are written out by doing: - (SmartRefStream statsOfSubObjects: anObject) - (SmartRefStream tallyOfSubObjects: anObject) - (SmartRefStream subObjects: anObject ofClass: aClass)" - -| info | -topCall - ifNil: [ - topCall _ anObject. - 'Please wait while objects are counted' - displayProgressAt: Sensor mousePoint - from: 0 to: 10 - during: [ :barBlock | info _ self instVarInfo: anObject]. - byteStream binary. - 'Writing an object file' displayProgressAt: Sensor mousePoint - from: 0 to: objCount*4 "estimate" - during: [ :barBlock | - objCount _ 0. - progressBar _ barBlock. - self setStream: byteStream reading: false. - "set basePos, but keep any class renames" - super nextPut: ReferenceStream versionCode. - super nextPut: info. - super nextPut: anObject. "<- the real writing" - ]. - "Note: the terminator, $!!, is not doubled inside object data" - "references is an IDict of every object that got written" - byteStream ascii. - byteStream nextPutAll: '!!'; newLine; newLine. - byteStream padToEndWith: $ . "really want to truncate file, but can't" - topCall _ progressBar _ nil] "reset it" - ifNotNil: [ - super nextPut: anObject. - progressBar ifNotNil: [progressBar value: (objCount _ objCount + 1)]]. -! ! -!SmartRefStream methodsFor: 'read write' stamp: 'jmv 7/17/2017 15:40:57' prior: 16911232! - nextPutObjOnly: anObject - "Really write three objects: (version, class structure, object). But only when called from the outside. Not in fileOut format. No class definitions will be written for instance-specific classes. Error if find one. (Use nextPut: instead)" - - | info | - topCall - ifNil: [ - topCall _ anObject. - super nextPut: ReferenceStream versionCode. - 'Please wait while objects are counted' displayProgressAt: Sensor mousePoint - from: 0 to: 10 - during: [ :barBlock | - info _ self instVarInfo: anObject]. - 'Writing an object file' displayProgressAt: Sensor mousePoint - from: 0 to: objCount*4 "estimate" - during: [ :barBlock | - objCount _ 0. - progressBar _ barBlock. - super nextPut: info. - super nextPut: anObject. "<- the real writing" - "Class inst vars not written here!!"]. - "references is an IDict of every object that got written - (in case you want to take statistics)" - "Transcript cr; show: structures keys printString." "debug" - topCall _ progressBar _ nil] "reset it" - ifNotNil: [ - super nextPut: anObject. - progressBar ifNotNil: [progressBar value: (objCount _ objCount + 1)]].! ! -!ProgressInitiationException class methodsFor: 'examples and tests' stamp: 'jmv 7/17/2017 15:39:39' prior: 50364921! -testInnermost - - " - test the progress code WITHOUT special handling - - ProgressInitiationException testInnermost - " - - ^'Now here''s some Real Progress' - displayProgressAt: Sensor mousePoint - from: 0 - to: 10 - during: [ :barBlock | - 1 to: 10 do: [ :x | - barBlock value: x. - (Delay forMilliseconds: 500) wait. - x = 5 ifTrue: [1/0]. "just to make life interesting" - ]. - 'done' - ]. - -! ! -!Utilities class methodsFor: 'user interface' stamp: 'jmv 7/17/2017 15:48:35' prior: 16941514! - informUserDuring: barBlock - "Display a message above (or below if insufficient room) the cursor during execution of the given block." - - "Utilities informUserDuring:[:barBlock| - #(one two three) do:[:info| - barBlock value: info. - (Delay forSeconds: 1) wait]]" - - (MVCMenuMorph from: (SelectionMenu labels: '') title: ' ') - informUserAt: Sensor mousePoint - during: barBlock! ! -!CodeFile methodsFor: 'reading' stamp: 'jmv 7/17/2017 15:44:20' prior: 16808992! - buildFrom: aStream - | chgRec changes | - changes _ (ChangeList new scanFile: aStream from: 0 to: aStream size) changeList. - ('Processing ', self name) - displayProgressAt: Sensor mousePoint - from: 1 - to: changes size - during: [ :barBlock | - 1 to: changes size do:[:i| - barBlock value: i. - chgRec := changes at: i. - chgRec class == MethodDeletionChangeRecord - ifTrue: [ self removedMethod: chgRec command with: chgRec ] - ifFalse: [ self perform: (chgRec changeType copyWith: $:) asSymbol with: chgRec ]. - ]. - ]! ! -!SpaceTally methodsFor: 'fileOut' stamp: 'jmv 7/17/2017 15:45:36' prior: 16912516! - printSpaceAnalysis: threshold on: aStream - " - SpaceTally new printSpaceAnalysis: 1 on:(FileStream forceNewFileNamed: 'STspace.text') - " - "sd-This method should be rewrote to be more coherent within the rest of the class - ie using preAllocate and spaceForInstanceOf:" - - "If threshold > 0, then only those classes with more than that number - of instances will be shown, and they will be sorted by total instance space. - If threshold = 0, then all classes will appear, sorted by name." - - | codeSpace instCount instSpace totalCodeSpace totalInstCount totalInstSpace eltSize n totalPercent percent | - Smalltalk garbageCollect. - totalCodeSpace _ totalInstCount _ totalInstSpace _ n _ 0. - results _ OrderedCollection new: Smalltalk classNames size. - 'Taking statistics...' - displayProgressAt: Sensor mousePoint - from: 0 to: Smalltalk classNames size - during: [ :barBlock | - Smalltalk allClassesDo: [ :cl | - codeSpace _ cl spaceUsed. - barBlock value: (n _ n+1). - Smalltalk garbageCollectMost. - instCount _ cl instanceCount. - instSpace _ (cl indexIfCompact > 0 ifTrue: [4] ifFalse: [8]) * instCount. "Object headers""Warning: The 3rd header word for big objects is not considered!!" - cl isVariable - ifTrue: [ - eltSize _ cl isBytes ifTrue: [1] ifFalse: [4]. - cl allInstancesDo: [ :x | - instSpace _ instSpace + (x basicSize * eltSize)]] - ifFalse: [instSpace _ instSpace + (cl instSize * instCount * 4)]. - results add: (SpaceTallyItem analyzedClassName: cl name codeSize: codeSpace instanceCount: instCount spaceForInstances: instSpace). - totalCodeSpace _ totalCodeSpace + codeSpace. - totalInstCount _ totalInstCount + instCount. - totalInstSpace _ totalInstSpace + instSpace]]. - totalPercent _ 0.0. - - aStream timeStamp. - aStream - nextPutAll: ('Class' padded: #right to: 30 with: $ ); - nextPutAll: ('code space' padded: #left to: 12 with: $ ); - nextPutAll: ('# instances' padded: #left to: 12 with: $ ); - nextPutAll: ('inst space' padded: #left to: 12 with: $ ); - nextPutAll: ('percent' padded: #left to: 8 with: $ ); newLine. - - threshold > 0 ifTrue: [ - "If inst count threshold > 0, then sort by space" - results _ (results select: [:s | s instanceCount >= threshold or: [s spaceForInstances > (totalInstSpace // 500)]]) - asArray sort: [:s :s2 | s spaceForInstances > s2 spaceForInstances]]. - - results do: [:s | - aStream - nextPutAll: (s analyzedClassName padded: #right to: 30 with: $ ); - nextPutAll: (s codeSize printString padded: #left to: 12 with: $ ); - nextPutAll: (s instanceCount printString padded: #left to: 12 with: $ ); - nextPutAll: (s spaceForInstances printString padded: #left to: 14 with: $ ). - percent _ s spaceForInstances*100.0/totalInstSpace. - totalPercent _ totalPercent + percent. - percent >= 0.1 ifTrue: [ - percent printOn: aStream integerDigits: 6 padWith: $ fractionDigits: 1 positiveIndicator: nil ]. - aStream newLine]. - - aStream - newLine; nextPutAll: ('Total' padded: #right to: 30 with: $ ); - nextPutAll: (totalCodeSpace printString padded: #left to: 12 with: $ ); - nextPutAll: (totalInstCount printString padded: #left to: 12 with: $ ); - nextPutAll: (totalInstSpace printString padded: #left to: 14 with: $ ). - totalPercent printOn: aStream integerDigits: 6 padWith: $ fractionDigits: 1 positiveIndicator: nil! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3126-ProgressArgumentIsABlock-JuanVuletich-2017Jul17-15h32m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3121] on 12 July 2017 at 1:50:53 pm'! -!Float64Array methodsFor: 'testing' stamp: 'jmv 7/11/2017 14:04:20'! -isLiteral - "so that - #(1 #[1.0 2 3] 5) - prints itself" - ^self class == Float64Array! ! -!Float64Array methodsFor: 'printing' stamp: 'jmv 7/11/2017 14:10:44'! - printOn: aStream - - self storeOn: aStream! ! -!Float64Array methodsFor: 'printing' stamp: 'jmv 7/11/2017 14:10:41'! - storeOn: aStream - - aStream nextPutAll: '#['. - self - do: [ :each | each storeOn: aStream ] - separatedBy: [ aStream nextPut: $ ]. - aStream nextPut: $]! ! -!ByteArray methodsFor: 'printing' stamp: 'jmv 7/11/2017 14:09:10' prior: 16793833! - printOn: aStream - self storeOn: aStream! ! -!Scanner methodsFor: 'expression types' stamp: 'jmv 7/12/2017 13:50:30' prior: 16903764! - scanLitByteVec - "Also accept Floats besides bytes!! - #[1 2 3 255] - #[1.0 0.2 1.0] - #[1.0 -0.2e-23 1.0e4] - " - | stream | - stream _ nil. - [ tokenType == #rightBracket or: [ tokenType == #doIt ] ] whileFalse: [ - (token == #- and: [(self typeTableAt: hereChar) == #xDigit]) ifTrue: [ - self scanToken. - token _ token negated ]. - ((token isInteger and: [ token between: 0 and: 255 ]) or: [token isFloat]) - ifFalse: [ ^ self offEnd: '8-bit integer, floating point number, or right bracket expected' ]. - stream ifNil: [ - stream _ ((token isFloat ifTrue: [Float64Array] ifFalse: [ByteArray]) new: 16) writeStream ]. - stream nextPut: token. - self scanToken ]. - token _ stream contents! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3127-LiteralFloatArrays-JuanVuletich-2017Jul12-13h50m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3127] on 17 July 2017 at 5:00:00 pm'! -!Collection methodsFor: 'converting' stamp: 'jmv 7/17/2017 16:59:02'! - asFloat64Array - "Answer a Float64Array whose elements are the elements of the receiver" - - ^self as: Float64Array! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3128-asFloat64Array-JuanVuletich-2017Jul17-16h59m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3128] on 18 July 2017 at 10:23:11 am'! -!PluggableButtonMorph methodsFor: 'as yet unclassified' stamp: 'jmv 7/18/2017 10:22:53' prior: 50365258! - morphExtent - "Use extent if it has already been manually set, otherwise try to set it by computing from the label text and font, otherwise try using the icon extent, or finally fall back to the default value." - ^ extent ifNil: [ - extent := (self fontToUse notNil and: [ label notNil ]) - ifTrue: [ "Add a bit of padding" - (self fontToUse widthOfString: label) + 10 @ (self fontToUse height + 10) ] - ifFalse: [ - `20@15` - "Usually button extent should not depend on icon extent. Icons are many times very big. - For example, the icons in buttons in Taskbar are full size captures of the windows" - "icon - ifNil: [ `20@15` ] - ifNotNil: [ icon extent ]" - ]].! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3129-AvoidHugeButtons-JuanVuletich-2017Jul18-10h22m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3128] on 19 July 2017 at 2:45:06 am'! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'pb 7/19/2017 02:42:16'! - moveEnd - self gotoPage: self pageCount. - self selected: completer entryCount. - self redrawNeeded.! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'pb 7/19/2017 02:42:22'! - moveHome - self gotoPage: 1. - self redrawNeeded.! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'pb 7/19/2017 02:43:17' prior: 16781410! - moveDown - self selected = completer entryCount - ifTrue: [ self moveHome ] - ifFalse: [ - self selected: self selected + 1. - (self selected > self lastVisible and: [ self selected <= completer entryCount ]) ifTrue: [ firstVisible _ firstVisible + 1 ]]. - self redrawNeeded.! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'pb 7/19/2017 02:42:32' prior: 16781419! - moveUp - (self selected = 0 and: [ self firstVisible = 1 ]) ifTrue: [ ^ self ]. - self selected = 1 - ifTrue: [ - self moveEnd ] - ifFalse: [ - self selected: self selected - 1. - self selected < self firstVisible ifTrue: [ firstVisible _ firstVisible - 1 ]]. - self redrawNeeded.! ! -!AutoCompleter methodsFor: 'keyboard' stamp: 'pb 7/19/2017 02:42:44' prior: 16781174! - handleKeystrokeBefore: kbEvent - "I return a boolean. true when I have handled the event and no futher processing is needed by the caller." - | currentPos currentCharIsAlphaNumeric keyValue ctrl cmd tab colon alphanum backspace esc space return keyChar | - currentPos _ textMorph editor startIndex-1. - currentCharIsAlphaNumeric _ currentPos > 0 and: [ model textSize >= currentPos and: [ - (model actualContents at: currentPos) isAlphaNumeric ]]. - keyValue _ kbEvent keyValue. - keyChar _ kbEvent keyCharacter. - ctrl _ kbEvent controlKeyPressed. - cmd _ kbEvent commandAltKeyPressed. - tab _ keyChar = Character tab. - colon _ keyChar = $:. - alphanum _ kbEvent keyCharacter isAlphaNumeric. - backspace _ keyValue = 8. - esc _ keyValue = 27. - space _ #(0 32 160) includes: keyValue. - return _ kbEvent isReturnKey. - - "Stuff to do if the menu is not open" - menuMorph ifNil: [ - "Ctrl-Space or Tab for open" - "Mac specific note: Using option-space (actually option+160) effectively disables the non-breaking space character 160" - (space & (ctrl | kbEvent rawMacOptionKeyPressed) or: [ - (self opensWithTab and: [tab]) and: [ currentCharIsAlphaNumeric ]]) - ifTrue: [ self openCompletionMenu. ^ true]. - "Auto-open - currently deactivated" -" (ctrl not & cmd not & alphanum) - ifTrue: [ self openCompletionMenu ]." - ^ false]. - - "Starting here, stuff to do if the menu is open" - menuMorph stillActive. - "Escape" - esc ifTrue: [ self closeMenu. ^ true]. - "Backspace" - backspace ifTrue: [ - currentCharIsAlphaNumeric ifFalse: [ self closeMenu ]. - ^ false]. - "Home" - keyValue = 1 ifTrue: [ menuMorph moveHome. ^ true ]. - "End" - keyValue = 4 ifTrue: [ menuMorph moveEnd. ^ true]. - "?" - keyChar = $? ifTrue: [ menuMorph help. ^true]. - "Arrow up" - keyValue = 30 ifTrue: [ menuMorph moveUp. ^ true]. - "Arrow down" - keyValue = 31 ifTrue: [ menuMorph moveDown. ^ true]. - "Page up" - keyValue = 11 ifTrue: [ menuMorph pageUp. ^ true]. - "Page down" - keyValue = 12 ifTrue: [ menuMorph pageDown. ^ true]. - "Return, Tab or Ctrl-Space" - (return or: [ space & (ctrl | kbEvent rawMacOptionKeyPressed) or: [ tab]]) ifTrue: [ - self insertSelected - ifTrue: [^ true]]. - "All keys but the alphanumeric chars (without command and control ) - and the backspace key do close the menu" - (ctrl not & cmd not and: [ alphanum | colon]) - ifFalse: [ self closeMenu ]. - ^false! ! - -AutoCompleterMorph removeSelector: #end! - -AutoCompleterMorph removeSelector: #end! - -AutoCompleterMorph removeSelector: #ensureVisible! - -AutoCompleterMorph removeSelector: #home! - -AutoCompleterMorph removeSelector: #home! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3130-AutoCompleterMorph-wrapping-PhilBellalouna-2017Jul19-02h20m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3130] on 2 August 2017 at 12:48:23 pm'! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'jmv 8/2/2017 12:45:12'! - goDown - self selected: self selected + 1. - (self selected > self lastVisible - and: [self selected <= completer entryCount]) - ifTrue: [firstVisible := firstVisible + 1]. - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'jmv 8/2/2017 12:45:38'! - goHome - firstVisible := 1. - self selected: firstVisible. - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'jmv 8/2/2017 12:47:05'! - goPageDown - (self gotoPage: self currentPage + 1) - ifFalse: [ self goToEnd ]. - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'jmv 8/2/2017 12:45:54'! - goPageUp - self gotoPage: self currentPage - 1. - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'jmv 8/2/2017 12:45:32'! - goToEnd - self selected: completer entryCount. - firstVisible := selected - self class itemsPerPage + 1 max: 1. - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'jmv 8/2/2017 12:45:45'! - goUp - (self selected = 0 - and: [self firstVisible = 1]) - ifTrue: [^ self]. - self selected: self selected - 1. - self selected < self firstVisible - ifTrue: [firstVisible := firstVisible - 1]. - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'events' stamp: 'jmv 8/2/2017 12:46:45' prior: 16781544! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - (self morphContainsPoint: localEventPosition) - ifTrue: [ - ((self upButtonPosition extent: ScrollBar scrollbarThickness) containsPoint: localEventPosition) - ifTrue: [ ^self stillActive; goUp ]. - ((self downButtonPosition extent: ScrollBar scrollbarThickness) containsPoint: localEventPosition) - ifTrue: [ ^self stillActive; goDown ]. - self selected: (localEventPosition y // self class itemHeight) + self firstVisible. - completer insertSelected ] - ifFalse: [ self delete. completer menuClosed ]! ! -!AutoCompleterMorph methodsFor: 'paging' stamp: 'jmv 8/2/2017 12:38:44' prior: 16781597! -gotoPage: anInteger - | item | - item := ((anInteger - 1) * self class itemsPerPage) + 1. - item >= completer entryCount ifTrue: [^false]. - item < 1 ifTrue: [item := 1]. - firstVisible := item. - self selected: firstVisible. - ^ true! ! -!AutoCompleter methodsFor: 'keyboard' stamp: 'jmv 8/2/2017 12:47:30' prior: 50366775! - handleKeystrokeBefore: kbEvent - "I return a boolean. true when I have handled the event and no futher processing is needed by the caller." - | currentPos currentCharIsAlphaNumeric keyValue ctrl cmd tab colon alphanum backspace esc space return keyChar | - currentPos _ textMorph editor startIndex-1. - currentCharIsAlphaNumeric _ currentPos > 0 and: [ model textSize >= currentPos and: [ - (model actualContents at: currentPos) isAlphaNumeric ]]. - keyValue _ kbEvent keyValue. - keyChar _ kbEvent keyCharacter. - ctrl _ kbEvent controlKeyPressed. - cmd _ kbEvent commandAltKeyPressed. - tab _ keyChar = Character tab. - colon _ keyChar = $:. - alphanum _ kbEvent keyCharacter isAlphaNumeric. - backspace _ keyValue = 8. - esc _ keyValue = 27. - space _ #(0 32 160) includes: keyValue. - return _ kbEvent isReturnKey. - - "Stuff to do if the menu is not open" - menuMorph ifNil: [ - "Ctrl-Space or Tab for open" - "Mac specific note: Using option-space (actually option+160) effectively disables the non-breaking space character 160" - (space & (ctrl | kbEvent rawMacOptionKeyPressed) or: [ - (self opensWithTab and: [tab]) and: [ currentCharIsAlphaNumeric ]]) - ifTrue: [ self openCompletionMenu. ^ true]. - "Auto-open - currently deactivated" -" (ctrl not & cmd not & alphanum) - ifTrue: [ self openCompletionMenu ]." - ^ false]. - - "Starting here, stuff to do if the menu is open" - menuMorph stillActive. - "Escape" - esc ifTrue: [ self closeMenu. ^ true]. - "Backspace" - backspace ifTrue: [ - currentCharIsAlphaNumeric ifFalse: [ self closeMenu ]. - ^ false]. - "Home" - keyValue = 1 ifTrue: [ menuMorph goHome. ^ true ]. - "End" - keyValue = 4 ifTrue: [ menuMorph goToEnd. ^ true]. - "?" - keyChar = $? ifTrue: [ menuMorph help. ^true]. - "Arrow up" - keyValue = 30 ifTrue: [ menuMorph goUp. ^ true]. - "Arrow down" - keyValue = 31 ifTrue: [ menuMorph goDown. ^ true]. - "Page up" - keyValue = 11 ifTrue: [ menuMorph goPageUp. ^ true]. - "Page down" - keyValue = 12 ifTrue: [ menuMorph goPageDown. ^ true]. - "Return, Tab or Ctrl-Space" - (return or: [ space & (ctrl | kbEvent rawMacOptionKeyPressed) or: [ tab]]) ifTrue: [ - self insertSelected - ifTrue: [^ true]]. - "All keys but the alphanumeric chars (without command and control ) - and the backspace key do close the menu" - (ctrl not & cmd not and: [ alphanum | colon]) - ifFalse: [ self closeMenu ]. - ^false! ! - -AutoCompleterMorph removeSelector: #moveDown! - -AutoCompleterMorph removeSelector: #moveDown! - -AutoCompleterMorph removeSelector: #moveEnd! - -AutoCompleterMorph removeSelector: #moveEnd! - -AutoCompleterMorph removeSelector: #moveHome! - -AutoCompleterMorph removeSelector: #moveHome! - -AutoCompleterMorph removeSelector: #moveUp! - -AutoCompleterMorph removeSelector: #moveUp! - -AutoCompleterMorph removeSelector: #pageDown! - -AutoCompleterMorph removeSelector: #pageDown! - -AutoCompleterMorph removeSelector: #pageUp! - -AutoCompleterMorph removeSelector: #pageUp! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3131-AutoCompletterMorph-removeWrapping-JuanVuletich-2017Aug02-12h43m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3131] on 2 August 2017 at 12:59:24 pm'! -!Scanner methodsFor: 'expression types' stamp: 'jmv 8/2/2017 12:59:08' prior: 50366661! - scanLitByteVec - "Also accept Floats besides bytes!! - #[1 2 3 255] - #[1.0 0.2 1.0] - #[1.0 -0.2e-23 1.0e4] - " - | stream | - stream _ nil. - [ tokenType == #rightBracket or: [ tokenType == #doIt ] ] whileFalse: [ - (token == #- and: [(self typeTableAt: hereChar) == #xDigit]) ifTrue: [ - self scanToken. - token _ token negated ]. - ((token isInteger and: [ token between: 0 and: 255 ]) or: [token isFloat]) - ifFalse: [ ^ self offEnd: '8-bit integer, floating point number, or right bracket expected' ]. - stream ifNil: [ - stream _ ((token isFloat ifTrue: [Float64Array] ifFalse: [ByteArray]) new: 16) writeStream ]. - stream nextPut: token. - self scanToken ]. - token _ stream - ifNotNil: [ stream contents ] - ifNil: [ - "For back compatibility, if empty, assume ByteArray" - ByteArray new ]! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3132-EmptyLiteralByteArrayFix-JuanVuletich-2017Aug02-12h59m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3094] on 29 July 2017 at 9:36:44 pm'! -!Exception methodsFor: 'debug support' stamp: 'HAW 7/29/2017 15:47:08'! - canSearchForSignalerContext - "This method is /only/ to support the debugger's catching of exceptions in stepIntoBlock." - ^signalContext isContext! ! -!Debugger methodsFor: 'context stack menu' stamp: 'HAW 7/29/2017 20:49:55' prior: 16829808! - doStep - "Send the selected message in the accessed method, and regain control - after the invoked method returns." - - | currentContext newContext | - - currentContext := self selectedContext. - newContext := self handleLabelUpdatesIn: [interruptedProcess completeStep: currentContext] - whenExecuting: currentContext. - newContext == currentContext ifTrue: - [newContext := interruptedProcess stepToSendOrReturn]. - self contextStackIndex > 1 - ifTrue: [self resetContext: newContext] - ifFalse: - [newContext == currentContext - ifTrue: [self changed: #contentsSelection. - self updateInspectors] - ifFalse: [self resetContext: newContext]]. -! ! -!Debugger methodsFor: 'context stack menu' stamp: 'HAW 7/29/2017 20:50:01'! - handleLabelUpdatesIn: aBlock whenExecuting: aContext - "Send the selected message in the accessed method, and regain control - after the invoked method returns." - - ^aBlock - on: Notification - do: [:ex| - (ex tag isArray - and: [ex tag size = 2 - and: [(ex tag first == aContext or: [ex tag first hasSender: aContext])]]) - ifTrue: - [self labelString: ex tag second description. - ex resume] - ifFalse: - [ex pass]]! ! -!Debugger methodsFor: 'context stack menu' stamp: 'HAW 7/29/2017 20:50:15' prior: 16829946! - stepIntoBlock - "Send messages until you return to the present method context. - Used to step into a block in the method." - - self - handleLabelUpdatesIn: [interruptedProcess stepToHome: self selectedContext] - whenExecuting: self selectedContext. - self resetContext: interruptedProcess stepToSendOrReturn! ! -!Inspector methodsFor: 'initialization' stamp: 'HAW 7/29/2017 15:28:27' prior: 16857112! - inspect: anObject - "Initialize the receiver so that it is inspecting anObject. There is no current selection. - - Normally the receiver will be of the correct class (as defined by anObject inspectorClass), - because it will have just been created by sedning inspect to anObject. However, the - debugger uses two embedded inspectors, which are re-targetted on the current receiver - each time the stack frame changes. The left-hand inspector in the debugger has its - class changed by the code here. Care should be taken if this method is overridden to - ensure that the overriding code calls 'super inspect: anObject', or otherwise ensures that - the class of these embedded inspectors are changed back." - - | c | - c := anObject inspectorClass. - self class ~= c ifTrue: [ - self class format = c format - ifTrue: [self primitiveChangeClassTo: c basicNew] - ifFalse: [self becomeForward: (c basicNew copyFrom: self)]]. - - "Set 'object' before sending the initialize message, because some implementations - of initialize (e.g., in DictionaryInspector) require 'object' to be non-nil." - - object := anObject. - self initialize! ! -!OrderedCollectionInspector methodsFor: 'as yet unclassified' stamp: 'HAW 7/29/2017 15:13:36' prior: 16884334! - fieldList - - | fieldsHere | - object isNil ifTrue: [^OrderedCollection new]. - fieldsHere _ - [ - (object size <= (self i1 + self i2) - ifTrue: [(1 to: object size) collect: [:i | i printString]] - ifFalse: [(1 to: self i1) , (object size-(self i2-1) to: object size) collect: [:i | i printString]]) - ] on: Error do: [:ex | ex return: OrderedCollection new]. - ^self baseFieldList , fieldsHere -" -OrderedCollection new inspect -(OrderedCollection newFrom: #(3 5 7 123)) inspect -(OrderedCollection newFrom: (1 to: 1000)) inspect -"! ! -!Process methodsFor: 'changing suspended state' stamp: 'HAW 7/29/2017 16:00:49' prior: 16894360! - stepToHome: aContext - "Resume self until the home of top context is aContext. Top context may be a block context. - Catch any UnhandledErrors that are created while stepping, answering the relevant signalerContext - if so. Note that this will cause weird effects if using through to step through UnhandledError - code, but as the doctor ordered, don't do that; use over or into instead." - - | home anError | - - home := aContext home. - [suspendedContext := suspendedContext step. - home == suspendedContext home or: [home isDead]] whileFalse: - [(suspendedContext selector == #signalForException: - and: [(suspendedContext receiver isBehavior - and: [suspendedContext receiver includesBehavior: UnhandledError]) - and: [anError := suspendedContext tempAt: 1. - ((suspendedContext objectClass: anError) includesBehavior: Exception) - and: [anError canSearchForSignalerContext]]]) ifTrue: - [anError signalerContext ifNotNil: [:unhandledErrorSignalerContext| - [unhandledErrorSignalerContext == suspendedContext] whileFalse: - [self completeStep: suspendedContext]. - "Give a debugger a chance to update its title to reflect the new exception" - Notification new - tag: {unhandledErrorSignalerContext. anError}; - signal. - ^unhandledErrorSignalerContext]]]. - - ^suspendedContext! ! - -----End fileIn of C:\Users\Admin\Cuis-Smalltalk-Organization\Cuis-Smalltalk-Dev\CoreUpdates\3133-DebuggerFixes-HernanWilkinson-2017Jun03-20h55m-HAW.1.cs.st----! - -----SNAPSHOT----#(2 August 2017 3:58:25.351093 pm) Cuis5.0-3133-v3.image priorSource: 1061254! - -----QUIT----#(2 August 2017 3:58:48.807093 pm) Cuis5.0-3133-v3.image priorSource: 1139044! - -----STARTUP----#(17 August 2017 10:42:52.713116 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3133-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3133] on 3 August 2017 at 12:49:11 pm'! -!Number methodsFor: 'intervals' stamp: 'jmv 8/3/2017 11:57:08'! - to: stop do: elementBlock separatedBy: separatorBlock - " - String streamContents: [ :strm | - 1 to: 10 do: [ :i | i printOn: strm ] separatedBy: [ strm nextPutAll: ' -- ' ]] - " - | beforeFirst | - "Evaluate the elementBlock for all elements in the receiver, - and evaluate the separatorBlock between." - - beforeFirst _ true. - self to: stop do: [ :element | - beforeFirst - ifTrue: [beforeFirst _ false] - ifFalse: [separatorBlock value]. - elementBlock value: element]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3134-to_do_separatedBy-JuanVuletich-2017Aug03-11h50m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3129] on 24 July 2017 at 4:30:44 pm'! -!TextEditor methodsFor: 'typing/selecting keys' stamp: 'jmv 7/24/2017 09:10:47' prior: 16932568! - forwardDelete: aKeyboardEvent - "Delete forward over the next character." - "This is a user command, and generates undo" - - | startIndex stopIndex | - - "If there was a selection" - self hasSelection ifTrue: [ - self replaceSelectionWith: self nullText. - ^ false]. - - "Exit if at end" - startIndex _ self markIndex. - startIndex > model textSize ifTrue: [ - ^ false]. - - "Null selection - do the delete forward" - stopIndex _ startIndex. - (aKeyboardEvent keyValue = 127 and: [ aKeyboardEvent shiftPressed ]) - ifTrue: [stopIndex := (self nextWordStart: stopIndex) - 1]. - self selectFrom: startIndex to: stopIndex. - self replaceSelectionWith: self nullText. - self deselectAndPlaceCursorAt: startIndex. - ^false! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3135-DeleteSelectionAtEndOfText-fix-JuanVuletich-2017Jul24-16h25m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3134] on 9 August 2017 at 11:37:48 am'! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 8/9/2017 11:37:34' prior: 16786577! - image: aForm at: aPoint sourceRect: sourceRect - "Draw a translucent image using the best available way of representing translucency. - Note: This will be fixed in the future." - | r p | - p _ (currentTransformation transform: aPoint) rounded. - r _ (self depth < 32 or: [ aForm mightBeTranslucent not ]) - ifTrue: [ - "Rule Form paint treats pixels with a value of zero as transparent" - Form paint ] - ifFalse: [ Form blend ]. - port colorMap: (aForm colormapIfNeededFor: form); fillColor: nil. - port image: aForm at: p sourceRect: sourceRect rule: r. - (self depth = 32 and: [ aForm depth < 32 ]) ifTrue: [ - "If we blit to 32bpp from one of smaller depth, - it will have zero in the alpha channel (until BitBlt is fixed!!) - This is the same workaround as in #asFormOfDepth:" - port sourceForm: nil. - port combinationRule: 40. "fixAlpha:with:" - port copyBits ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3136-BitBltCanvas-fix-JuanVuletich-2017Aug08-16h59m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3134] on 17 August 2017 at 1:06:03 pm'! -!PluggableListMorph methodsFor: 'events' stamp: 'jmv 8/17/2017 13:05:27' prior: 16888588! - doubleClick: aMouseButtonEvent localPosition: localEventPosition - | index | - doubleClickSelector ifNil: [ ^super doubleClick: aMouseButtonEvent localPosition: localEventPosition ]. - index _ self rowAtLocation: localEventPosition. - index = 0 ifTrue: [ ^super doubleClick: aMouseButtonEvent localPosition: localEventPosition ]. - index == self selectionIndex - ifFalse: [ self changeModelSelection: index ]. - ^ self model perform: doubleClickSelector! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3137-DoubleClickOnSelection-Inspector-Fix-JuanVuletich-2017Aug17-12h45m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3137] on 17 August 2017 at 5:00:13 pm'! -!Inspector methodsFor: 'user interface support' stamp: 'jmv 8/17/2017 16:28:29'! - textStylerClassFor: textGetter - - ^SHTextStylerST80! ! -!Inspector methodsFor: 'shout styling' stamp: 'jmv 8/17/2017 16:51:54'! - bindingNamesDo: aBlock - object class allInstVarNames do: aBlock! ! -!Inspector methodsFor: 'shout styling' stamp: 'jmv 8/17/2017 16:52:08'! - hasBindingOf: aString - ^ object class allInstVarNames includes: aString! ! -!Inspector methodsFor: 'shout styling' stamp: 'jmv 8/17/2017 16:48:11'! - shoutAboutToStyle: aSHTextStyler - "This is a notification that aSHTextStyler is about to re-style its text. - Set the classOrMetaClass in aSHTextStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - - aSHTextStyler -"No. Impica que es un metodo!! - classOrMetaClass: self selectedClassOrMetaClass." - - workspace: self. - ^true! ! -!ContextVariablesInspector methodsFor: 'shout styling' stamp: 'jmv 8/17/2017 16:58:45'! - bindingNamesDo: aBlock - fieldList do: aBlock! ! -!ContextVariablesInspector methodsFor: 'shout styling' stamp: 'jmv 8/17/2017 16:58:56'! - hasBindingOf: aString - ^ fieldList includes: aString! ! -!ObjectExplorer methodsFor: 'user interface support' stamp: 'jmv 8/17/2017 16:28:32'! - textStylerClassFor: textGetter - - ^SHTextStylerST80! ! -!ObjectExplorer methodsFor: 'shout styling' stamp: 'jmv 8/17/2017 16:54:38'! - bindingNamesDo: aBlock - self doItReceiver class allInstVarNames do: aBlock! ! -!ObjectExplorer methodsFor: 'shout styling' stamp: 'jmv 8/17/2017 16:54:33'! - hasBindingOf: aString - ^ self doItReceiver class allInstVarNames includes: aString! ! -!ObjectExplorer methodsFor: 'shout styling' stamp: 'jmv 8/17/2017 16:48:02'! - shoutAboutToStyle: aSHTextStyler - "This is a notification that aSHTextStyler is about to re-style its text. - Set the classOrMetaClass in aSHTextStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - - aSHTextStyler -"No. Impica que es un metodo!! - classOrMetaClass: self selectedClassOrMetaClass." - - workspace: self. - ^true! ! -!Inspector methodsFor: 'accessing' stamp: 'jmv 8/17/2017 16:47:26' prior: 16856921! - selectedClassOrMetaClass -"NOOOOOO" - ^ self selectedClass "I don't know any better"! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3138-ShoutInInspectorsAndExplorers-JuanVuletich-2017Aug17-16h27m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3137] on 17 August 2017 at 5:07:41 pm'! -!SmalltalkCompleter methodsFor: 'entries' stamp: 'jmv 8/17/2017 17:06:33' prior: 16909227! - computeEntries - - | allSource contextClass id specificModel last3Ranges range prevRange receiverClass prevPrevRange | - allSource _ model actualContents string. - specificModel _ (model is: #hasTextProvider) - ifTrue: [ model textProvider ] - ifFalse: [ model ]. - contextClass _ (specificModel is: #CodeProvider) ifTrue: [ - specificModel selectedClassOrMetaClass ]. - - "Instead of creating a new string, maybe we could pass the last position to parse to Shout..." - parser _ SHParserST80 new. - parser - workspace: specificModel; - classOrMetaClass: contextClass; - source: (allSource copyFrom: 1 to: position). - parser parse. - last3Ranges _ parser last3Ranges. - range _ last3Ranges third. - range ifNil: [ ^entries _ #() ]. - - "If parsing breaks before position, then we don't know what to suggest, therefore don't open Completion" - range end = position ifFalse: [ ^entries _ #() ]. - - prefix _ allSource copyFrom: range start to: range end. - - (parser isMessage: range rangeType) ifTrue: [ - "If previous range is a constant or a well known identifier, we might filter messages" - prevRange _ last3Ranges second. - prevPrevRange _ last3Ranges first. - receiverClass _ nil. - "3 if -> ifNil: but not ifTrue: - 3=4 -> ifNil: or ifTrue:" - (prevRange notNil and: [ prevPrevRange isNil or: [ (#(binary keyword) includes: prevPrevRange rangeType) not]]) ifTrue: [ - id _ (allSource copyFrom: prevRange start to: prevRange end). - receiverClass _ prevRange rangeType caseOf: { - [ #globalVar ] -> [ (Smalltalk at: id asSymbol) class ]. - [ #self ] -> [ contextClass ]. - [ #super ] -> [ contextClass superclass ]. - [ #true ] -> [ True ]. - [ #false ] -> [ False ]. - [ #nil ] -> [ UndefinedObject ]. - [ #character ] -> [ id first class ]. - [ #number ] -> [ (Compiler evaluate: id) class ]. - [ #string ] -> [ (Compiler evaluate: id) class ]. - [ #symbol ] -> [ (Compiler evaluate: id) class ]. - [ #stringSymbol ] -> [ (Compiler evaluate: id) class ]. - "thisContext could mean ContextPart or BlockClosure..." - "[ #thisContext ] -> [ ContextPart ]" - } otherwise: [ nil ] - ]. - ^self computeMessageEntries: receiverClass ]. - - (parser isPartialOrFullIdentifier: range rangeType) ifTrue: [ - ^self computeIdentifierEntries ]. - - "If we don't know what to do, do nothing" - entries _ #()! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3139-AutocompleterInInspectorsAndExplorers-JuanVuletich-2017Aug17-17h00m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3139] on 17 August 2017 at 9:26:32 pm'! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'jmv 9/22/2012 14:56' prior: 50365277! - morphHeight - -"Ensure everybody wants our coordinates!!" - self flag: #jmvVer2. - ^ extent y! ! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'jmv 2/16/2016 12:58' prior: 50365284! - morphPosition: newPos extent: newExtent - "Change the position of this morph. Argument is in owner's coordinates." - - | oldBoundsInWorld someChange | - - "Ask for the old bounds before updating them, but ask for repair only if extent or position has really changed." - oldBoundsInWorld _ self morphBoundsInWorld. - someChange _ false. - (location isTranslation: newPos) ifFalse: [ - location _ location withTranslation: newPos. - someChange _ true ]. - - extent = newExtent ifFalse: [ - (self privateExtent: newExtent) ifTrue: [ - someChange _ true ]]. - - someChange ifTrue: [ - "Ask for the old bounds before updating them, but ask for repair only if extent or position has really changed." - oldBoundsInWorld ifNotNil: [ - self invalidateDisplayRect: oldBoundsInWorld from: nil ]. - self someSubmorphPositionOrExtentChanged. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]! ! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'jmv 9/22/2012 14:57' prior: 50365316! - morphWidth - -"Ensure everybody wants our coordinates!!" - self flag: #jmvVer2. - ^ extent x! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:55:30' prior: 50365323! - draw3DLookOn: aCanvas - - | borderStyleSymbol c | - borderStyleSymbol _ self isPressed ifFalse: [ #raised ] ifTrue: [ #inset ]. - c _ color. - self mouseIsOver ifTrue: [ c _ c lighter ]. - aCanvas - fillRectangle: (`0@0` extent: extent) - color: c - borderWidth: borderWidth - borderStyleSymbol: borderStyleSymbol - baseColorForBorder: c. - - self drawRegularLabelOn: aCanvas! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 5/1/2015 16:20' prior: 50365338! - drawEmbossedLabelOn: aCanvas - - | availableW center colorForLabel f l labelMargin targetSize w x y | - label ifNotNil: [ - colorForLabel _ Theme current buttonLabel. - self isPressed - ifFalse: [ - self mouseIsOver - ifFalse: [ colorForLabel _ colorForLabel adjustSaturation: -0.10 brightness: 0.10 ]] - ifTrue: [ colorForLabel _ colorForLabel adjustSaturation: 0.0 brightness: -0.07 ]. - f _ self fontToUse. - center _ extent // 2. - labelMargin _ 3. - w _ f widthOfString: label. - availableW _ extent x - labelMargin - labelMargin. - availableW >= w - ifTrue: [ - l _ label ] - ifFalse: [ - x _ labelMargin. - targetSize _ label size * availableW // w. - l _ label squeezedTo: targetSize. - (f widthOfString: l) > availableW ifTrue: [ - targetSize _ targetSize - 1. - l _ label squeezedTo: targetSize ]]. - - w _ f widthOfString: l. - x _ center x - (w // 2). - y _ center y - (f height // 2). - aCanvas - drawString: l - at: x@y - font: f - color: colorForLabel - embossed: true ]! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 7/10/2014 22:43' prior: 50365374! - drawRegularLabelOn: aCanvas - - | w f center x y availableW l labelMargin | - - f _ self fontToUse. - center _ extent // 2. - - label ifNotNil: [ - labelMargin _ 4. - w _ f widthOfString: label. - availableW _ extent x - labelMargin - labelMargin - 1. - availableW >= w - ifTrue: [ - x _ center x - (w // 2). - l _ label ] - ifFalse: [ - x _ labelMargin. - l _ label squeezedTo: (label size * availableW / w) rounded ]. - y _ center y - (f height // 2). - self isPressed ifTrue: [ - x _ x + 1. - y _ y + 1 ]. - aCanvas - drawString: l - at: x@y - font: f - color: Theme current buttonLabel ]! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:55:46' prior: 50365397! - drawRoundGradientLookOn: aCanvas - | r colorForButton rect bottomFactor topFactor | - - self isPressed - ifFalse: [ - topFactor _ Theme current buttonGradientTopFactor. - bottomFactor _ Theme current buttonGradientBottomFactor. - self mouseIsOver - ifTrue: [ - colorForButton _ Color h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ - colorForButton _ color ]] - ifTrue: [ - topFactor _ Theme current buttonGradientBottomFactor. - bottomFactor _ Theme current buttonGradientTopFactor. - colorForButton _ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - Theme current useButtonGradient - ifTrue: [ - rect _ (`0@0` extent: extent) insetBy: `1@3`. - aCanvas - roundRect: rect - color: colorForButton - radius: r - gradientTop: topFactor - gradientBottom: bottomFactor - gradientHeight: Theme current buttonGradientHeight ] - ifFalse: [ - rect _ (`0@0` extent: extent) insetBy: `1@3`. - aCanvas roundRect: rect color: colorForButton radius: r ] - ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawEmbossedLabelOn: aCanvas ] - ifFalse: [ self drawRegularLabelOn: aCanvas ]! ! -!PluggableButtonMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:09:15' prior: 50365440! - initialize - "initialize the state of the receiver" - super initialize. - - roundButtonStyle _ nil. "nil: honor Theme. true: draw as round button. false: draw as classic 3d border square button" - model _ nil. - getStateSelector _ nil. - actionSelector _ nil. - isPressed _ false. - mouseIsOver _ false. - actWhen _ #buttonUp. - extent _ `20 @ 15`! ! -!PluggableButtonMorph methodsFor: 'private' stamp: 'jmv 2/17/2017 15:10:48' prior: 50365458! - magnifiedIcon - | factor magnifiedExtent w h | - - icon ifNil: [ ^nil ]. - magnifiedIcon ifNil: [ - magnifiedIcon _ icon. - w _ icon width. - h _ icon height. - w*h = 0 ifFalse: [ - factor _ 1.0 * extent x / w min: 1.0 * extent y / h. - (factor < 1 or: [ factor > 1.7 and: [self isRoundButton]]) ifTrue: [ - magnifiedExtent _ (icon extent * factor) rounded. - magnifiedIcon _ icon magnifyTo: magnifiedExtent ]]]. - ^magnifiedIcon! ! -!PluggableButtonMorph methodsFor: 'geometry testing' stamp: 'jmv 6/19/2017 15:55:52' prior: 50365476! - morphContainsPoint: aLocalPoint - - | iconOrigin | - ((`0@0` extent: extent) containsPoint: aLocalPoint) ifFalse: [ ^false ]. - ^ self isOrthoRectangularMorph or: [ - magnifiedIcon isNil or: [ - iconOrigin _ extent - magnifiedIcon extent // 2. - (magnifiedIcon isTransparentAt: (aLocalPoint - iconOrigin) rounded) not ]]! ! - -PluggableButtonMorph removeSelector: #morphExtent! - -PluggableButtonMorph removeSelector: #morphExtent! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3140-Revert-3124-BreaksExistingPackages-JuanVuletich-2017Aug17-21h24m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3140] on 17 August 2017 at 9:45:47 pm'! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 8/17/2017 21:37:11'! - raisedToFraction: aFraction - self isZero ifTrue: [ - aFraction negative ifTrue: [ - ^ (ZeroDivide dividend: 1) signal ]. - ^ self ]. - self negative ifFalse: [ - ^ (self ln * aFraction) exp ]. - aFraction denominator even ifTrue: [ - ^ ArithmeticError signal: 'nth root only defined for positive Integer n.' ]. - ^ (self negated ln * aFraction) exp negated! ! -!Fraction methodsFor: 'mathematical functions' stamp: 'jmv 8/17/2017 21:37:35'! - raisedToFraction: aFraction - | root | - root _ (self numerator nthRootTruncated: aFraction denominator) / - (self denominator nthRootTruncated: aFraction denominator). - (root raisedToInteger: aFraction denominator) = self ifTrue: [ - ^ root raisedToInteger: aFraction numerator ]. - ^ super raisedToFraction: aFraction! ! -!Integer methodsFor: 'mathematical functions' stamp: 'jmv 8/17/2017 21:37:42'! - raisedToFraction: aFraction - | root | - root _ self nthRootTruncated: aFraction denominator. - (root raisedToInteger: aFraction denominator) = self ifTrue: [ - ^ root raisedToInteger: aFraction numerator ]. - ^ super raisedToFraction: aFraction! ! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 8/17/2017 21:44:25' prior: 16880173! - raisedTo: aNumber - "Answer the receiver raised to aNumber." - - aNumber isInteger ifTrue: [ - "Do the special case of integer power" - ^ self raisedToInteger: aNumber]. - aNumber isFraction ifTrue: [ - "Special case for fraction power by Nicolas Cellier: - If aNumber is a fraction, but result must be a Float, learn it as quickly as possible, and give quick Float answer - Allows evaluating: - (2009/2000) raisedTo: (3958333/100000) - " - ^ self raisedToFraction: aNumber]. - self < 0 ifTrue: [ - ^ ArithmeticError signal: 'Negative numbers can''t be raised to float powers.' ]. - 0 = aNumber ifTrue: [^ self class one]. "Special case of exponent=0" - 1 = aNumber ifTrue: [^ self]. "Special case of exponent=1" - 0 = self ifTrue: [ "Special case of self = 0" - aNumber < 0 - ifTrue: [^ (ZeroDivide dividend: self) signal] - ifFalse: [^ self]]. - ^ (aNumber * self ln) exp "Otherwise use logarithms"! ! -!Fraction methodsFor: 'mathematical functions' stamp: 'jmv 8/17/2017 21:38:55' prior: 16849696! - nthRoot: aPositiveInteger - "Answer the nth root of the receiver." - | guess | - guess _ (numerator nthRootTruncated: aPositiveInteger) / - (denominator nthRootTruncated: aPositiveInteger). - (guess raisedTo: aPositiveInteger) = self ifTrue: [ - ^ guess ]. - "There is no exact nth root, so answer a Float approximation" - ^ (self abs ln / aPositiveInteger) exp * self sign! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3141-raisedTo-fix-NicolasCellier-2017Aug17-21h28m-jmv.1.cs.st----! - -----SNAPSHOT----#(17 August 2017 10:43:00.134843 pm) Cuis5.0-3141-v3.image priorSource: 1139140! - -----QUIT----#(17 August 2017 10:43:11.415409 pm) Cuis5.0-3141-v3.image priorSource: 1158329! - -----STARTUP----#(18 August 2017 6:06:27.201531 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3141-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3138] on 18 August 2017 at 3:36:55 pm'! -!Debugger methodsFor: 'code pane' stamp: 'jmv 8/18/2017 15:36:20' prior: 16829971! - contentsSelection - - "If we are just creating the method in the debugger, help the user by selecting the method body." - currentCompiledMethod ifNotNil: [ - ((currentCompiledMethod hasLiteral: #shouldBeImplemented) and: [ - (self selectedContext debuggerMap method abstractPCForConcretePC: self selectedContext pc) = 1]) ifTrue: [ - ^currentCompiledMethod selector size + 3 to: currentCompiledMethod getSource size ]]. - - ^self pcRange! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3142-autoSelectBodyIfCreateInDebugger-JuanVuletich-2017Aug18-15h00m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3141] on 18 August 2017 at 5:43:59 pm'! -!Workspace methodsFor: 'testing' stamp: 'jmv 8/18/2017 17:42:35'! - is: aSymbol - ^ aSymbol == #providesBindings or: [ super is: aSymbol ]! ! -!Debugger methodsFor: 'testing' stamp: 'jmv 8/18/2017 17:41:49'! - is: aSymbol - ^ aSymbol == #providesBindings or: [ super is: aSymbol ]! ! -!Inspector methodsFor: 'testing' stamp: 'jmv 8/18/2017 17:42:07'! - is: aSymbol - ^ aSymbol == #providesBindings or: [ super is: aSymbol ]! ! -!ObjectExplorer methodsFor: 'testing' stamp: 'jmv 8/18/2017 17:42:19'! - is: aSymbol - ^ aSymbol == #providesBindings or: [ super is: aSymbol ]! ! -!Inspector methodsFor: 'accessing' stamp: 'jmv 9/21/2009 15:16' prior: 50367450! - selectedClassOrMetaClass - - ^ self selectedClass "I don't know any better"! ! -!SmalltalkCompleter methodsFor: 'entries' stamp: 'jmv 8/18/2017 17:43:14' prior: 50367464! - computeEntries - - | allSource contextClass id specificModel last3Ranges range prevRange receiverClass prevPrevRange | - allSource _ model actualContents string. - specificModel _ (model is: #hasTextProvider) - ifTrue: [ model textProvider ] - ifFalse: [ model ]. - contextClass _ (specificModel is: #CodeProvider) ifTrue: [ - specificModel selectedClassOrMetaClass ]. - - "Instead of creating a new string, maybe we could pass the last position to parse to Shout..." - parser _ SHParserST80 new. - parser - workspace: ((specificModel is: #providesBindings) ifTrue: [specificModel]); - classOrMetaClass: contextClass; - source: (allSource copyFrom: 1 to: position). - parser parse. - last3Ranges _ parser last3Ranges. - range _ last3Ranges third. - range ifNil: [ ^entries _ #() ]. - - "If parsing breaks before position, then we don't know what to suggest, therefore don't open Completion" - range end = position ifFalse: [ ^entries _ #() ]. - - prefix _ allSource copyFrom: range start to: range end. - - (parser isMessage: range rangeType) ifTrue: [ - "If previous range is a constant or a well known identifier, we might filter messages" - prevRange _ last3Ranges second. - prevPrevRange _ last3Ranges first. - receiverClass _ nil. - "3 if -> ifNil: but not ifTrue: - 3=4 -> ifNil: or ifTrue:" - (prevRange notNil and: [ prevPrevRange isNil or: [ (#(binary keyword) includes: prevPrevRange rangeType) not]]) ifTrue: [ - id _ (allSource copyFrom: prevRange start to: prevRange end). - receiverClass _ prevRange rangeType caseOf: { - [ #globalVar ] -> [ (Smalltalk at: id asSymbol) class ]. - [ #self ] -> [ contextClass ]. - [ #super ] -> [ contextClass superclass ]. - [ #true ] -> [ True ]. - [ #false ] -> [ False ]. - [ #nil ] -> [ UndefinedObject ]. - [ #character ] -> [ id first class ]. - [ #number ] -> [ (Compiler evaluate: id) class ]. - [ #string ] -> [ (Compiler evaluate: id) class ]. - [ #symbol ] -> [ (Compiler evaluate: id) class ]. - [ #stringSymbol ] -> [ (Compiler evaluate: id) class ]. - "thisContext could mean ContextPart or BlockClosure..." - "[ #thisContext ] -> [ ContextPart ]" - } otherwise: [ nil ] - ]. - ^self computeMessageEntries: receiverClass ]. - - (parser isPartialOrFullIdentifier: range rangeType) ifTrue: [ - ^self computeIdentifierEntries ]. - - "If we don't know what to do, do nothing" - entries _ #()! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3143-fixRecentAutocompleteBug-JuanVuletich-2017Aug18-17h34m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3129] on 18 August 2017 at 9:07:32 am'! -!Message methodsFor: 'stub creation' stamp: 'HAW 8/18/2017 09:04:10'! - addGetterCodeOn: stream - - stream - newLine; tab; - nextPut: $^; - nextPutAll: selector ! ! -!Message methodsFor: 'stub creation' stamp: 'HAW 8/18/2017 09:04:52'! - addSetterCodeOn: stream with: argumentName - - stream - newLine; tab; - nextPutAll: selector allButLast; - nextPutAll: ' := '; - nextPutAll: argumentName ! ! -!Message methodsFor: 'stub creation' stamp: 'HAW 8/18/2017 07:43:09'! - writeShouldBeImplementedOn: stream. - - stream - nextPutAll: 'self '; - nextPutAll: #shouldBeImplemented; - nextPut: $.! ! -!Message methodsFor: 'testing' stamp: 'HAW 8/18/2017 07:40:37'! - isGetter - - ^selector isUnary and: [ lookupClass instVarNames includes: selector ]! ! -!Message methodsFor: 'testing' stamp: 'HAW 8/18/2017 07:44:22'! - isSetter - - ^selector isKeyword and: [ self numArgs = 1 and: [ lookupClass instVarNames includes: selector allButLast ]]! ! -!Message methodsFor: 'stub creation' stamp: 'HAW 8/18/2017 09:03:49' prior: 16867424! - createStubMethod - | argNames aOrAn argName arg argClassName | - - argNames _ Set new. - ^ String streamContents: [ :s | - self selector keywords withIndexDo: [ :key :i | - s nextPutAll: key. - ((key last = $:) or: [self selector isInfix]) ifTrue: [ - arg _ self arguments at: i. - argClassName _ (arg class isMeta) ifTrue: ['Class'] ifFalse: [arg class name]. - aOrAn _ argClassName first isVowel ifTrue: ['an'] ifFalse: ['a']. - argName _ aOrAn, argClassName. - [argNames includes: argName] whileTrue: [argName _ argName, i asString]. - argNames add: argName. - s nextPutAll: ' '; nextPutAll: argName; space - ]. - ]. - s newLine; tab. - self writeShouldBeImplementedOn: s. - self isGetter ifTrue: [ self addGetterCodeOn: s ]. - self isSetter ifTrue: [ self addSetterCodeOn: s with: argName ]. - ]! ! - -Message removeSelector: #createGetterStub! - -Message removeSelector: #createSetterStub! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3144-CreateAccessorsInDebugger-HernanWilkinson-2017Aug17-20h05m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3144] on 18 August 2017 at 6:03:22 pm'! -!Debugger methodsFor: 'code pane' stamp: 'jmv 8/18/2017 18:02:55' prior: 50367861! - contentsSelection - - "If we are just creating the method in the debugger, help the user by selecting the method body." - | sendInterval | - currentCompiledMethod ifNotNil: [ - ((currentCompiledMethod hasLiteral: #shouldBeImplemented) and: [ - (currentCompiledMethod abstractPCForConcretePC: self selectedContext pc) = 1]) ifTrue: [ - sendInterval _ (self selectedContext debuggerMap abstractSourceMap at: 2 ifAbsent: [nil]). - sendInterval ifNotNil: [ ^ sendInterval first - 5 to: sendInterval last + 1 ]]]. - - ^self pcRange! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3145-autoSelectOnCreateInDebugger-update-JuanVuletich-2017Aug18-17h52m-jmv.1.cs.st----! - -----SNAPSHOT----#(18 August 2017 6:06:32.360998 pm) Cuis5.0-3145-v3.image priorSource: 1158427! - -----QUIT----#(18 August 2017 6:06:44.135902 pm) Cuis5.0-3145-v3.image priorSource: 1166058! - -----STARTUP----#(28 August 2017 9:44:54.537559 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3145-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3145] on 22 August 2017 at 11:23:45 am'! -!Object methodsFor: 'message handling' stamp: 'HAW 8/22/2017 10:17:59'! -argumentName - - ^self argumentNameSufix prefixedWithAOrAn ! ! -!Object methodsFor: 'message handling' stamp: 'HAW 8/22/2017 10:16:01'! - argumentNameSufix - - ^self class isMeta ifTrue: ['Class'] ifFalse: [self class name]! ! -!String methodsFor: 'converting' stamp: 'HAW 8/22/2017 10:14:02'! - aOrAnPrefix - - ^self isEmpty - ifTrue: [ self ] - ifFalse: [ self first isVowel ifTrue: ['an'] ifFalse: ['a'] ] -! ! -!String methodsFor: 'converting' stamp: 'HAW 8/22/2017 10:14:46'! - prefixedWithAOrAn - - ^self aOrAnPrefix, self! ! -!Debugger methodsFor: 'method creation' stamp: 'HAW 8/22/2017 11:22:30' prior: 50336724! - implement: aMessage inClass: aClass context: aContext - - aClass - compile: (aMessage createStubMethodFor: aClass) - classified: (self askForCategoryIn: aClass default: 'as yet unclassified'). - - aContext privRefreshWith: (aClass lookupSelector: aMessage selector). - aMessage arguments withIndexDo: [ :arg :index | aContext tempAt: index put: arg ]. - self resetContext: aContext! ! -!Message methodsFor: 'stub creation' stamp: 'HAW 8/22/2017 11:23:03' prior: 50367995! - addGetterCodeOn: stream - - stream - newLine; tab; - nextPut: $^; - nextPutAll: selector ! ! -!Message methodsFor: 'stub creation' stamp: 'HAW 8/22/2017 11:23:07' prior: 50368001! - addSetterCodeOn: stream with: argumentName - - stream - newLine; tab; - nextPutAll: selector allButLast; - nextPutAll: ' := '; - nextPutAll: argumentName ! ! -!Message methodsFor: 'stub creation' stamp: 'HAW 8/22/2017 11:22:53'! - createStubMethodFor: aClass - - | argNames argName arg | - - argNames _ Set new. - ^ String streamContents: [ :s | - self selector keywords withIndexDo: [ :key :i | - s nextPutAll: key. - ((key last = $:) or: [self selector isInfix]) ifTrue: [ - arg _ self arguments at: i. - argName _ arg argumentName. - [argNames includes: argName] whileTrue: [argName _ argName, i asString]. - argNames add: argName. - s nextPutAll: ' '; nextPutAll: argName; space - ]. - ]. - - s newLine; tab. - self writeShouldBeImplementedOn: s. - (self isGetterFor: aClass) ifTrue: [ self addGetterCodeOn: s ]. - (self isSetterFor: aClass) ifTrue: [ self addSetterCodeOn: s with: argName ]. - ]! ! -!Message methodsFor: 'stub creation' stamp: 'HAW 8/22/2017 11:23:11' prior: 50368009! - writeShouldBeImplementedOn: stream. - - stream - nextPutAll: 'self '; - nextPutAll: #shouldBeImplemented; - nextPut: $.! ! -!Message methodsFor: 'testing' stamp: 'HAW 8/22/2017 11:22:40'! - isGetterFor: aClass - - ^selector isUnary and: [ aClass instVarNames includes: selector ]! ! -!Message methodsFor: 'testing' stamp: 'HAW 8/22/2017 11:22:43'! - isSetterFor: aClass - - ^selector isKeyword and: [ self numArgs = 1 and: [ aClass instVarNames includes: selector allButLast ]]! ! - -Message removeSelector: #createStubMethod! - -Message removeSelector: #createStubMethod! - -Message removeSelector: #isGetter! - -Message removeSelector: #isGetter! - -Message removeSelector: #isSetter! - -Message removeSelector: #isSetter! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3146-CreateAccessorsInDebuggerFix-HernanWilkinson-2017Aug19-20h52m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3145] on 23 August 2017 at 2:35:44 pm'! -!TextModelMorph methodsFor: 'accessing' stamp: 'HAW 8/23/2017 14:22:17'! - enableEdition - - self textMorph enableEdition! ! -!InnerTextMorph methodsFor: 'accessing' stamp: 'HAW 8/23/2017 14:23:36'! - enableEdition - - self removeProperty: #disablesEdition! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3147-textMorph-enableEdition-HernanWilkinson-2017Aug23-12h52m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3147] on 25 August 2017 at 10:56:35 am'! -!Object methodsFor: 'printing' stamp: 'jmv 8/25/2017 10:55:31' prior: 16882206! - printOn: aStream - "Append to the argument, aStream, a sequence of characters that - identifies the receiver." - - | title | - title _ self class name. - aStream - nextPutAll: title aOrAnPrefix; - space; - nextPutAll: title! ! -!Object methodsFor: 'printing' stamp: 'jmv 8/25/2017 10:55:49' prior: 16882255! - printWithClosureAnalysisOn: aStream - "Append to the argument, aStream, a sequence of characters that - identifies the receiver." - - | title | - title _ self class name. - aStream - nextPutAll: title aOrAnPrefix; - space; - nextPutAll: title! ! -!ContextPart methodsFor: 'debugger access' stamp: 'jmv 8/25/2017 10:55:54' prior: 16824084! - print: anObject on: aStream - "Safely print anObject in the face of direct ProtoObject subclasses." - | objClass title | - objClass _ self objectClass: anObject. - (objClass canUnderstand: #printOn:) ifTrue: [ - ^anObject printOn: aStream]. - title _ objClass name. - aStream - nextPutAll: title aOrAnPrefix; - space; - nextPutAll: title! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3148-Use-aOrAnPrefix-JuanVuletich-2017Aug25-10h53m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3128] on 23 July 2017 at 1:07:52 am'! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'pb 7/23/2017 00:53:45' prior: 50359403! - buildMorphicWindow - " - CodePackageListWindow open: CodePackageList new - " - | dirtyFlags names fileNames upperRow description summary backColor labelBackground textHeigth | - backColor := self textBackgroundColor. - labelBackground := Theme current background. - textHeigth := AbstractFont default height. - - dirtyFlags := PluggableListMorph - model: model - listGetter: #packageDirtyFlags - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - dirtyFlags color: backColor. - dirtyFlags := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorph: (StringMorph new contents: ' Unsaved?') fixedHeight: textHeigth; - addMorphUseAll: dirtyFlags. - - names := PluggableListMorph - model: model - listGetter: #packageNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - names color: backColor. - names := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorph: (StringMorph new contents: ' Package Name') fixedHeight: textHeigth; - addMorphUseAll: names. - - fileNames := PluggableListMorph - model: model - listGetter: #packageFullNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - fileNames color: backColor. - fileNames := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorph: (StringMorph new contents: ' File Name') fixedHeight: textHeigth; - addMorphUseAll: fileNames. - - upperRow := LayoutMorph newRow. - upperRow - addMorph: dirtyFlags proportionalWidth: 0.13; - addAdjusterAndMorph: names proportionalWidth: 0.27; - addAdjusterAndMorph: fileNames proportionalWidth: 0.6. - - description := TextModelMorph - textProvider: model - textGetter: #description - textSetter: #description:. - - summary := TextModelMorph - textProvider: model - textGetter: #summary. - - self layoutMorph - addMorph: upperRow proportionalHeight: 0.6; - addAdjusterAndMorph: self buildButtonPane fixedHeight: Theme current buttonPaneHeight; - addAdjusterAndMorph: summary fixedHeight: 60; - addAdjusterAndMorph: description proportionalHeight: 0.25; - addAdjusterAndMorph: self buildRequirementsPane proportionalHeight: 0.15. - self setLabel: 'Installed Packages'! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3149-CodePackageWindow-layout-tweak-PhilBellalouna-2017Jul23-00h53m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3128] on 23 July 2017 at 1:47:54 pm'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3150-category-cleanup-PhilBellalouna-2017Jul23-13h39m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3131] on 27 July 2017 at 3:27:46 am'! -!Debugger class methodsFor: 'opening' stamp: 'pb 7/27/2017 03:27:10' prior: 16830456! -openOn: process context: context label: title fullView: bool - "Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger." - | w | - Preferences logDebuggerStackToFile ifTrue: [ - Smalltalk - logError: title - inContext: context - to: 'CuisDebug.log' ]. - w := ProjectX newProcessIfUIX: process. - "schedule debugger in deferred UI message to address redraw - problems after opening a debugger e.g. from the testrunner." - WorldState addDeferredUIMessage: [ - [ | debugger | - "In case an error in Morphic code got us here, ensure mouse focus has been released" - true runningWorld ifNotNil: [ :rWorld | - rWorld activeHand ifNotNil: [ :aHand | - aHand releaseMouseFocus ]]. - debugger := self new - process: process - context: context. - debugger interruptedProcessUI: w. - bool - ifTrue: [ debugger openFullMorphicLabel: title ] - ifFalse: [ - PreDebugWindow - open: debugger - label: title - message: nil ]] - on: UnhandledError - do: [ :exOuter | | errorDescription | - errorDescription := 'Error while trying to open Debugger' , String newLineString , 'Orginal error: ' , title asString , '.' , String newLineString , ' Debugger error: ' , - ([ exOuter description ] - on: UnhandledError - do: [ :exInner | - exInner return: 'a ' , exInner class printString ]) , ':'. - self primitiveError: errorDescription ]]. - process suspend.! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3151-Debugger-ensure-focus-released-fix-PhilBellalouna-2017Jul27-03h27m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3130] on 27 July 2017 at 2:24:40 pm'! -!HierarchicalListMorph methodsFor: 'commands' stamp: 'pb 7/27/2017 14:24:23' prior: 16852992! - toggleExpandedState: aMorph event: event - - "self setSelectedMorph: aMorph." - ((self autoExpand or: [event shiftPressed]) and: [aMorph isExpanded not]) - ifTrue: [aMorph beFullyExpanded] - ifFalse: [aMorph toggleExpandedState]. - scroller adjustExtent. - self setScrollDeltas! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3152-HierarchicalListMorph-shift-key-fully-expands-PhilBellalouna-2017Jul27-14h17m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3130] on 27 July 2017 at 6:26:56 am'! - -TextProvider subclass: #FileList - instanceVariableNames: 'acceptedContentsCache fileName directory list listIndex pattern sortMode brevityState sortAscending showDirsInFileList currentDirectorySelected ' - classVariableNames: 'FileReaderRegistry ' - poolDictionaries: '' - category: 'Tools-FileList'! - -!classDefinition: #FileList category: #'Tools-FileList'! -TextProvider subclass: #FileList - instanceVariableNames: 'acceptedContentsCache fileName directory list listIndex pattern sortMode brevityState sortAscending showDirsInFileList currentDirectorySelected' - classVariableNames: 'FileReaderRegistry' - poolDictionaries: '' - category: 'Tools-FileList'! -!FileList class methodsFor: 'file reader registration' stamp: 'pb 7/27/2017 06:05:51' prior: 16843241! - itemsForFile: filename - "Answer a list of services appropriate for a file of the given name" - | services suffix classList | - suffix _ (FileIOAccessor default extensionFor: filename) asLowercase. - services _ OrderedCollection new. - "Build the list dynamically for all implementers of the appropriate class method... registration no longer required" - classList _ (Smalltalk allClassesImplementing: #fileReaderServicesForFile:suffix:) - collect: [ :item | - item class == Metaclass ifTrue: [ item soleInstance ]] - thenSelect: [ :item | - item notNil ]. - classList do: [ :reader | - reader ifNotNil: [ - services addAll: - (reader - fileReaderServicesForFile: filename - suffix: suffix) ]]. - ^ services.! ! -!FileList class methodsFor: 'file reader registration' stamp: 'pb 7/27/2017 06:02:20' prior: 16843256! - registerFileReader: aProviderClass - "For compatibility... no longer necessary"! ! -!FileList class methodsFor: 'file reader registration' stamp: 'pb 7/27/2017 06:02:32' prior: 16843266! - unregisterFileReader: aProviderClass - "For compatibility... no longer necessary"! ! - -Morph class removeSelector: #unload! - -Morph class removeSelector: #unload! - -Form class removeSelector: #unload! - -Form class removeSelector: #unload! - -FileList class removeSelector: #initialize! - -FileList class removeSelector: #initialize! - -ChangeSorter class removeSelector: #unload! - -ChangeSorter class removeSelector: #unload! - -ChangeList class removeSelector: #unload! - -ChangeList class removeSelector: #unload! - -CodeFileBrowser class removeSelector: #unload! - -CodeFileBrowser class removeSelector: #unload! - -MessageNames class removeSelector: #unload! - -MessageNames class removeSelector: #unload! - -TextProvider subclass: #FileList - instanceVariableNames: 'acceptedContentsCache fileName directory list listIndex pattern sortMode brevityState sortAscending showDirsInFileList currentDirectorySelected' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-FileList'! - -!classDefinition: #FileList category: #'Tools-FileList'! -TextProvider subclass: #FileList - instanceVariableNames: 'acceptedContentsCache fileName directory list listIndex pattern sortMode brevityState sortAscending showDirsInFileList currentDirectorySelected' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-FileList'! - -FileList initialize! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3153-FileList-dynamic-registration-PhilBellalouna-2017Jul27-05h59m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3153] on 25 August 2017 at 1:01:32 pm'! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'jmv 8/25/2017 13:00:40' prior: 50366866! - goDown - self selected = completer entryCount ifTrue: [ - "Wrap around" - ^ self goHome ]. - self selected: self selected + 1. - (self selected > self lastVisible - and: [self selected <= completer entryCount]) - ifTrue: [firstVisible := firstVisible + 1]. - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'jmv 8/25/2017 13:00:48' prior: 50366898! - goUp - (self selected = 0 - and: [self firstVisible = 1]) - ifTrue: [^ self]. - self selected = 1 ifTrue: [ - "Wrap around" - ^self goToEnd ]. - self selected: self selected - 1. - self selected < self firstVisible - ifTrue: [firstVisible := firstVisible - 1]. - self redrawNeeded! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3154-WraparoundAutoComplete-JuanVuletich-2017Aug25-12h57m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3145] on 28 August 2017 at 1:59:42 pm'! -!CompiledMethod class methodsFor: 'method encoding' stamp: 'HAW 8/28/2017 13:59:31' prior: 16821632! - headerFlagForEncoder: anEncoder - - (anEncoder class includesBehavior: PrimaryBytecodeSetEncoderClass) ifTrue: [^0]. - (anEncoder class includesBehavior: SecondaryBytecodeSetEncoderClass) ifTrue: [^SmallInteger minVal]. - - self error: 'The encoder is not one of the two installed bytecode sets'! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3155-AllowOtherMethodEncoders-HernanWilkinson-2017Aug28-13h56m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3145] on 28 August 2017 at 1:50:13 pm'! - -CodeWindow subclass: #BrowserWindow - instanceVariableNames: 'codePane ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Tools'! - -!classDefinition: #BrowserWindow category: #'Morphic-Tools'! -CodeWindow subclass: #BrowserWindow - instanceVariableNames: 'codePane' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Tools'! -!BrowserWindow methodsFor: 'updating' stamp: 'HAW 8/28/2017 13:44:30'! - disableCodePaneEdition - - codePane ifNotNil: [ codePane disableEdition ]! ! -!BrowserWindow methodsFor: 'updating' stamp: 'HAW 8/28/2017 13:41:24'! - editSelectionChanged - - self isEditSelectionNone - ifTrue: [ self disableCodePaneEdition ] - ifFalse: [ self enableCodePaneEdition]! ! -!BrowserWindow methodsFor: 'updating' stamp: 'HAW 8/28/2017 13:43:20'! - enableCodePaneEdition - - codePane ifNotNil: [ codePane enableEdition ]! ! -!BrowserWindow methodsFor: 'updating' stamp: 'HAW 8/28/2017 13:43:44'! - isEditSelectionNone - - ^ model editSelection = #none! ! -!BrowserWindow methodsFor: 'updating' stamp: 'HAW 8/28/2017 13:41:51'! -update: anEvent - super update: anEvent. - anEvent = #editSelection ifTrue: [self editSelectionChanged ] ! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'HAW 8/28/2017 13:39:41'! - buildMorphicCodePane - "Construct the pane that shows the code. - Respect the Preference for standardCodeFont." - - codePane _ super buildMorphicCodePane. - ^codePane! ! - -CodeWindow subclass: #BrowserWindow - instanceVariableNames: 'codePane' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Tools'! - -!classDefinition: #BrowserWindow category: #'Morphic-Tools'! -CodeWindow subclass: #BrowserWindow - instanceVariableNames: 'codePane' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Tools'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3156-DisableEditionIfNoSysCatSelected-HernanWilkinson-2017Aug23-14h35m-HAW.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3156] on 28 August 2017 at 5:05:29 pm'! -!MessageSet methodsFor: 'private' stamp: 'jmv 8/28/2017 17:05:18' prior: 16870086! - initializeMessageList: anArray - - messageList _ anArray. - messageList isEmpty - ifTrue: [ selectedMessage _ nil ] - ifFalse: [ - selectedMessage _ messageList first. - self editSelection: #editMessage ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3157-MessageSetFix-JuanVuletich-2017Aug28-16h59m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3157] on 28 August 2017 at 5:16:24 pm'! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 8/28/2017 17:06:34'! - reservedNames - - ^Theme current pseudoVariables! ! -!ClassBuilder methodsFor: 'private' stamp: 'jmv 8/28/2017 16:58:40' prior: 16804009! - reservedNames - "Return a list of names that must not be used for variables" - ^#(#self #super #true #false #nil #thisContext)! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 8/28/2017 16:51:25' prior: 16902210! -isIncompleteReservedName: aString - "Answer true if aString is the start of a reserved name, false otherwise" - - self reservedNames do: [ :arg | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 8/28/2017 16:53:14' prior: 16902288! - resolve: aString - - self reservedNames do: [ :symbol | aString = symbol ifTrue: [^symbol]]. - (self isBlockTempName: aString) ifTrue: [^#blockTempVar]. - (self isBlockArgName: aString) ifTrue: [^#blockArg]. - (self isMethodTempName: aString) ifTrue: [^#tempVar]. - (self isMethodArgName: aString) ifTrue: [^#methodArg]. - (self isInstVarName: aString) ifTrue: [^#instVar]. - (self isWorkspaceVarName: aString) ifTrue: [^#workspaceVar]. - Symbol hasInterned: aString ifTrue: [ :symbol | - (self isClassVarName: symbol) ifTrue: [ ^#classVar ]. - (self isPoolConstantName: symbol) ifTrue: [ ^#poolConstant]. - (self isGlobal: symbol) ifTrue: [^#globalVar]]. - ^self resolvePartial: aString! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 8/28/2017 16:52:46' prior: 16902979! - nonGlobalNamesDo: aBlock - "Evaluate aBlock over all available names, except for globals" - - self - blockArgNamesDo: aBlock; - blockTempNamesDo: aBlock; - methodArgNamesDo: aBlock; - methodTempNamesDo: aBlock; - instVarNamesDo: aBlock; - classVarNamesDo: aBlock; - poolConstantNamesDo: aBlock; - workspaceNamesDo: aBlock. - self - reservedNames do: aBlock! ! -!SHParserST80 methodsFor: 'testing' stamp: 'jmv 8/28/2017 17:14:20' prior: 16903020! - isPartialOrFullIdentifier: aSymbol - - (#(#incompleteIdentifier - #blockTempVar #blockArg #tempVar #methodArg - #instVar #classVar - #workspaceVar #poolConstant #globalVar ) - statePointsTo:aSymbol) ifTrue: [ ^ true ]. - (self reservedNames statePointsTo: aSymbol) ifTrue: [ ^ true ]. - ^ false! ! - -SHParserST80 removeSelector: #isReservedName:! - -SHParserST80 removeSelector: #isReservedName:! - -SHParserST80 removeSelector: #reservedNamesDo:! - -SHParserST80 removeSelector: #reservedNamesDo:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3158-AllowNewReservedNamesInSHParserST80-JuanVuletich-2017Aug28-17h12m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3158] on 28 August 2017 at 5:26:35 pm'! -!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jmv 8/25/2017 15:05:56' prior: 16888064! -label: aStringOrNil font: aFontOrNil - "Label this button with the given string." - label _ aStringOrNil. - font _ aFontOrNil. - (self fontToUse notNil and: [ label notNil ]) - ifTrue: [ "Add a bit of padding" - extent := (self fontToUse widthOfString: label) + 10 @ (self fontToUse height + 10) ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3159-SetAppropriateButtonExtent-JuanVuletich-2017Aug28-17h25m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3154] on 26 August 2017 at 7:48:09 pm'! -!TextModel methodsFor: 'user interface support' stamp: 'jmv 8/26/2017 19:19:29'! - formatAndStyleIfNeededWith: anSHTextStyler - anSHTextStyler ifNotNil: [ - (self shouldStyle: self actualContents with: anSHTextStyler) ifTrue: [ - anSHTextStyler formatAndStyle: self actualContents allowBackgroundStyleProcess: true. - self basicActualContents: anSHTextStyler formattedText ]]! ! -!PluggableTextModel methodsFor: 'shout styling' stamp: 'jmv 8/26/2017 19:21:51'! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text. - Set the classOrMetaClass in anSHTextStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - ^textProvider shouldStyle: text with: anSHTextStyler! ! -!Workspace methodsFor: 'shout styling' stamp: 'jmv 8/26/2017 19:21:53'! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text." - - self shouldStyle ifFalse: [ ^false ]. - anSHTextStyler - classOrMetaClass: nil; - workspace: self. - ^true! ! -!CodeProvider methodsFor: 'shout styling' stamp: 'jmv 8/26/2017 19:21:32'! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text. - Answer false if showing difs, to veto the styling." - - ^self showingAnyKindOfDiffs not! ! -!Browser methodsFor: 'shout styling' stamp: 'jmv 8/26/2017 19:21:20'! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text. - Set the classOrMetaClass in anSHTextStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - | type | - - self isModeStyleable ifFalse: [^false]. - type _ self editSelection. - (#(newMessage editMessage editClass newClass) includes: type) ifFalse:[^false]. - anSHTextStyler classOrMetaClass: (type = #editClass ifFalse:[self selectedClassOrMetaClass]). - ^true! ! -!MessageSet methodsFor: 'shout styling' stamp: 'jmv 8/26/2017 19:21:44'! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text. - Set the classOrMetaClass in anSHTextStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - - self isModeStyleable ifFalse: [^false]. - anSHTextStyler classOrMetaClass: self selectedClassOrMetaClass. - ^true! ! -!CodeFileBrowser methodsFor: 'shout styling' stamp: 'jmv 8/26/2017 19:21:30'! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text. - Set the classOrMetaClass in anSHTextStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - - self isModeStyleable ifFalse: [^false]. - anSHTextStyler classOrMetaClass: self selectedClassOrMetaClass. - ^true! ! -!ChangeList methodsFor: 'shout styling' stamp: 'jmv 8/26/2017 19:21:23'! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text. - Set the classOrMetaClass in anSHTextStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - - self isModeStyleable ifFalse: [^false]. - listIndex = 0 ifFalse: [ - (changeList at: listIndex) changeType = #method ifTrue: [ - self selectedClassOrMetaClass ifNotNil: [ :cl | - anSHTextStyler classOrMetaClass: cl. - ^true ]]]. - ^false! ! -!ChangeSorter methodsFor: 'shout styling' stamp: 'jmv 8/26/2017 19:21:27'! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text. - Set the classOrMetaClass in anSHTextStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - - self isModeStyleable ifFalse: [^false]. - self currentSelector ifNil: [^false]. - anSHTextStyler classOrMetaClass: self selectedClassOrMetaClass. - ^true! ! -!Debugger methodsFor: 'shout styling' stamp: 'jmv 8/26/2017 19:21:36'! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text. - Set the classOrMetaClass in anSHTextStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - - self isModeStyleable ifFalse: [^false]. - anSHTextStyler - classOrMetaClass: self selectedClassOrMetaClass; - disableFormatAndConvert; - workspace: self. - ^true! ! -!Inspector methodsFor: 'shout styling' stamp: 'jmv 8/26/2017 19:42:36'! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text. - Answer true to allow styling to proceed, or false to veto the styling" - - anSHTextStyler workspace: self. - ^(text = self acceptedContents) not! ! -!ObjectExplorer methodsFor: 'shout styling' stamp: 'jmv 8/26/2017 19:27:12'! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text. - Answer true to allow styling to proceed, or false to veto the styling" - - anSHTextStyler workspace: self. - ^true! ! -!Inspector methodsFor: 'contents' stamp: 'jmv 8/26/2017 19:40:39' prior: 16857103! - acceptedStringOrText - "We need our cache not to be modified by user editions" - ^acceptedContentsCache copy! ! -!InnerTextMorph methodsFor: 'editing' stamp: 'jmv 8/26/2017 19:07:20' prior: 16855670! - hasUnacceptedEdits: aBoolean - "Set the hasUnacceptedEdits flag to the given value. " - aBoolean == hasUnacceptedEdits ifFalse: [ - hasUnacceptedEdits _ aBoolean. - owner redrawNeeded]. - aBoolean ifFalse: [ hasEditingConflicts _ false]. - - "shout: re-style the text iff aBoolean is true - Do not apply any formatting (i.e. changes to the characters in the text), - just styling (i.e. TextAttributes)" - aBoolean ifTrue: [ - self formatAndStyleIfNeeded ]! ! -!InnerTextMorph methodsFor: 'shout' stamp: 'jmv 8/26/2017 19:14:13' prior: 16856199! - formatAndStyleIfNeeded - "Apply both formatting (changes to the characters in the text, such as - preferred assignment operators), and styling (TextAttributes to make - Smalltalk code easier to understand)" - - model formatAndStyleIfNeededWith: styler! ! - -InnerTextMorph removeSelector: #okToStyle! - -InnerTextMorph removeSelector: #okToStyle! - -ObjectExplorer removeSelector: #shoutAboutToStyle:! - -ObjectExplorer removeSelector: #shoutAboutToStyle:! - -Inspector removeSelector: #shoutAboutToStyle:! - -Inspector removeSelector: #shoutAboutToStyle:! - -Debugger removeSelector: #shoutAboutToStyle:! - -Debugger removeSelector: #shoutAboutToStyle:! - -ChangeSorter removeSelector: #shoutAboutToStyle:! - -ChangeSorter removeSelector: #shoutAboutToStyle:! - -ChangeList removeSelector: #shoutAboutToStyle:! - -ChangeList removeSelector: #shoutAboutToStyle:! - -CodeFileBrowser removeSelector: #shoutAboutToStyle:! - -CodeFileBrowser removeSelector: #shoutAboutToStyle:! - -MessageSet removeSelector: #shoutAboutToStyle:! - -MessageSet removeSelector: #shoutAboutToStyle:! - -Browser removeSelector: #shoutAboutToStyle:! - -Browser removeSelector: #shoutAboutToStyle:! - -CodeProvider removeSelector: #shoutAboutToStyle:! - -CodeProvider removeSelector: #shoutAboutToStyle:! - -Workspace removeSelector: #shoutAboutToStyle:! - -Workspace removeSelector: #shoutAboutToStyle:! - -PluggableTextModel removeSelector: #shoutAboutToStyle:! - -PluggableTextModel removeSelector: #shoutAboutToStyle:! - -TextModel removeSelector: #formatAndStyleWith:! - -TextModel removeSelector: #formatAndStyleWith:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3160-AvoidStylingInIspectorUntilEdit-JuanVuletich-2017Aug26-19h42m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3160] on 28 August 2017 at 9:40:53 pm'! - -ActiveModel subclass: #SimpleServiceEntry - instanceVariableNames: 'provider label selector useLineAfter stateSelector description argumentGetter buttonLabel argumentProvider triggerFileListChanged sortOrder ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-FileList'! - -!classDefinition: #SimpleServiceEntry category: #'Tools-FileList'! -ActiveModel subclass: #SimpleServiceEntry - instanceVariableNames: 'provider label selector useLineAfter stateSelector description argumentGetter buttonLabel argumentProvider triggerFileListChanged sortOrder' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-FileList'! -!SimpleServiceEntry methodsFor: 'accessing' stamp: 'jmv 8/28/2017 21:35:11'! - sortOrder - ^sortOrder! ! -!SimpleServiceEntry methodsFor: 'accessing' stamp: 'jmv 8/28/2017 21:28:07'! - sortOrder: aNumber - sortOrder _ aNumber! ! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'jmv 8/28/2017 21:40:08' prior: 16809512! - serviceBrowseCode - "Answer the service of opening a file-contents browser" - - ^ (SimpleServiceEntry - provider: self - label: 'code file browser' - selector: #browseCode: - description: 'open a "file-contents browser" on this file, allowing you to view and selectively load its code' - buttonLabel: 'code') - sortOrder: 10; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'jmv 8/28/2017 21:40:05' prior: 16809527! - serviceBrowsePackage - "Answer the service of opening a file-contents browser" - - ^ (SimpleServiceEntry - provider: self - label: 'package file browser' - selector: #browsePackage: - description: 'open a "package file browser" on this file, allowing you to view and selectively load its code' - buttonLabel: 'package browser') - sortOrder: 10; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!ChangeList class methodsFor: 'fileIn/Out' stamp: 'jmv 8/28/2017 21:39:59' prior: 16796992! - serviceContents - "Answer a service for opening a changelist browser on a file" - - ^ (SimpleServiceEntry - provider: self - label: 'code file contents' - selector: #browseContents: - description: 'open a code file contents tool on this file' - buttonLabel: 'contents') - sortOrder: 20; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!ChangeList class methodsFor: 'fileIn/Out' stamp: 'jmv 8/28/2017 21:39:55' prior: 16797005! - servicePackageContents - "Answer a service for opening a changelist browser on a file" - - ^ (SimpleServiceEntry - provider: self - label: 'package file contents' - selector: #browsePackageContents: - description: 'open a code file contents tool on this package file' - buttonLabel: 'pck contents') - sortOrder: 20; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!FileList class methodsFor: 'file reader registration' stamp: 'jmv 8/28/2017 21:39:36' prior: 50368456! - itemsForFile: filename - "Answer a list of services appropriate for a file of the given name" - | services suffix classList | - suffix _ (FileIOAccessor default extensionFor: filename) asLowercase. - "Build the list dynamically for all implementers of the appropriate class method... registration no longer required" - classList _ (Smalltalk allClassesImplementing: #fileReaderServicesForFile:suffix:) - collect: [ :item | - item class == Metaclass ifTrue: [ item soleInstance ]] - thenSelect: [ :item | - item notNil ]. - services _ OrderedCollection new. - classList do: [ :reader | - services addAll: - (reader - fileReaderServicesForFile: filename - suffix: suffix) ]. - services sort: [ :a :b | a sortOrder < b sortOrder ]. - ^ services.! ! -!ChangeSet class methodsFor: 'file list services' stamp: 'jmv 8/28/2017 21:28:59' prior: 16799248! - serviceFileIn - "Answer a service for filing in an entire file" - - ^ (SimpleServiceEntry - provider: self - label: 'fileIn entire file' - selector: #fileIn: - description: 'file in the entire contents of the file, which is expected to contain Smalltalk code in fileout ("chunk") format' - buttonLabel: 'filein') - sortOrder: 100; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!ChangeSet class methodsFor: 'file list services' stamp: 'jmv 8/28/2017 21:29:05' prior: 16799263! - serviceInstall - "Answer a service for filing in an entire file" - - ^ (SimpleServiceEntry - provider: self - label: 'install code' - selector: #install: - description: 'install change set' - buttonLabel: 'install') - sortOrder: 100; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!CodePackageFile class methodsFor: 'file list services' stamp: 'jmv 8/28/2017 21:29:39' prior: 16811207! - serviceInstallPackage - "Answer the service of installing a CodePackageFile (a chunk format file for a CodePackage)" - - ^ (SimpleServiceEntry - provider: self - label: 'install package' - selector: #installPackageStream: - description: 'install the package, replacing all existing code in the package (if any); create a new change set just for the installation' - buttonLabel: 'install package') - sortOrder: 100; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! - -ActiveModel subclass: #SimpleServiceEntry - instanceVariableNames: 'provider label selector useLineAfter stateSelector description argumentGetter buttonLabel argumentProvider triggerFileListChanged sortOrder' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-FileList'! - -!classDefinition: #SimpleServiceEntry category: #'Tools-FileList'! -ActiveModel subclass: #SimpleServiceEntry - instanceVariableNames: 'provider label selector useLineAfter stateSelector description argumentGetter buttonLabel argumentProvider triggerFileListChanged sortOrder' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-FileList'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3161-RestoreFileListButtonsOrder-JuanVuletich-2017Aug28-21h38m-jmv.1.cs.st----! - -----SNAPSHOT----#(28 August 2017 9:45:04.328394 pm) Cuis5.0-3161-v3.image priorSource: 1166155! - -----QUIT----#(28 August 2017 9:45:16.349516 pm) Cuis5.0-3161-v3.image priorSource: 1202187! - -----STARTUP----#(10 September 2017 6:05:31.684746 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3161-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3161] on 29 August 2017 at 3:54:37 pm'! -!Theme methodsFor: 'keyboard shortcuts' stamp: 'jmv 8/29/2017 15:53:47' prior: 16936827! - keyStroke: aKeyboardEvent morph: aMorph - aKeyboardEvent controlKeyPressed ifTrue: [^false]. - aKeyboardEvent commandAltKeyPressed ifFalse: [^false]. - - aKeyboardEvent keyValue = $w numericValue ifTrue: [ - aMorph owningWindow ifNotNil: [ :w | - (w morphContainsPoint: (w internalizeFromWorld: aKeyboardEvent eventPosition)) ifTrue: [ - w delete. - ^true ] ]]. -" aKeyboardEvent keyValue = $f numericValue - ifTrue: [aMorph owningWindow ifNotNil: [ :w | w fullScreen. ^true ]]. -" - ^ false! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3162-OnlyCloseWindowIfContainsMousePointer-JuanVuletich-2017Aug29-15h49m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3121] on 9 July 2017 at 7:49:17 pm'! -!Interval class methodsFor: 'instance creation' stamp: 'jmv 7/9/2017 16:59:23' prior: 16861363! - 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). - (newInterval hasEqualElements: aCollection) - ifFalse: [ 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 -"! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3163-IntervalFix-JuanVuletich-2017Jul09-16h58m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3163] on 31 August 2017 at 10:20:55 am'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3164-CategorizePinningProtocol-JuanVuletich-2017Aug31-10h17m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3164] on 6 September 2017 at 9:59:44 am'! -!SimpleServiceEntry methodsFor: 'initialization' stamp: 'jmv 9/6/2017 09:56:01' prior: 16908010! -initialize - triggerFileListChanged _ false. - sortOrder _ 1! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3165-FileListFix-JuanVuletich-2017Sep06-09h43m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3165] on 6 September 2017 at 10:08:50 am'! -!ReparseAfterSourceEditing commentStamp: 'jmv 9/6/2017 10:05:54' prior: 16900979! - A ReparseAfterSourceEditing is a Notification used to restart the syntax parsing phase of a compilation after a change in source code.! -!TextModelMorph methodsFor: 'accessing' stamp: 'jmv 9/6/2017 10:01:18'! - disableEditing - self textMorph disableEditing! ! -!TextModelMorph methodsFor: 'accessing' stamp: 'jmv 9/6/2017 10:03:26'! - enableEditing - - self textMorph enableEditing! ! -!BrowserWindow methodsFor: 'updating' stamp: 'jmv 9/6/2017 10:04:36'! - disableCodePaneEditing - - codePane ifNotNil: [ codePane disableEditing ]! ! -!BrowserWindow methodsFor: 'updating' stamp: 'jmv 9/6/2017 10:04:48'! - enableCodePaneEditing - - codePane ifNotNil: [ codePane enableEditing ]! ! -!InnerTextMorph methodsFor: 'accessing' stamp: 'jmv 9/6/2017 10:01:59'! - disableEditing - self setProperty: #disablesEditing toValue: true. - self stopBlinking! ! -!InnerTextMorph methodsFor: 'accessing' stamp: 'jmv 9/6/2017 10:03:03'! -enableEditing - - self removeProperty: #disablesEditing! ! -!InnerTextMorph methodsFor: 'event handling testing' stamp: 'jmv 9/6/2017 10:02:01'! - disablesEditing - - ^self hasProperty: #disablesEditing! ! -!Inspector methodsFor: 'contents' stamp: 'jmv 9/6/2017 10:05:31' prior: 50368947! - acceptedStringOrText - "We need our cache not to be modified by user changes" - ^acceptedContentsCache copy! ! -!TextEditor methodsFor: 'accessing' stamp: 'jmv 9/6/2017 10:02:22' prior: 16931330! - replaceSelectionWith: aTextOrString - "Deselect, and replace the selection text by aText." - "This is a user command, and generates undo" - - | start stop replacement | - - morph disablesEditing ifTrue: [ - ^ self ]. - - start _ self startIndex. - stop _ self stopIndex. - (aTextOrString isEmpty and: [stop > start]) ifTrue: [ - "If deleting, then set emphasisHere from 1st character of the deletion" - emphasisHere _ (model actualContents attributesAt: start) select: [:att | - att mayBeExtended]]. - - (start = stop and: [ aTextOrString isEmpty ]) ifFalse: [ - replacement _ self addAttributesForPasting: aTextOrString. - model logUndoAndReplaceFrom: start to: stop - 1 with: replacement. - textComposition - recomposeFrom: start - to: start + replacement size - 1 - delta: replacement size - (stop-start). - self deselectAndPlaceCursorAt: start + replacement size. - selectionStartBlocks _ #(). - selectionStopBlocks _ #(). - self userHasEdited " -- note text now dirty" ]. - - morph possiblyChanged! ! -!TextEditor methodsFor: 'private' stamp: 'jmv 9/6/2017 10:02:19' prior: 16932614! - applyAttribute: aTextAttribute - "The user selected aTextAttribute via shortcut, menu or other means. - If there is a selection, apply the attribute to the selection. - In any case use the attribute for the user input (emphasisHere)" - "This generates undo" - | anythingDone | - - morph disablesEditing ifTrue: [ - ^ self ]. - - anythingDone _ false. - emphasisHere _ Text addAttribute: aTextAttribute toArray: emphasisHere. - self selectionIntervalsDo: [ :interval | - (interval notEmpty or: [ aTextAttribute isParagraphAttribute ]) - ifTrue: [ - anythingDone _ true. - model logUndoAndAddAttribute: aTextAttribute from: interval first to: interval last. - textComposition recomposeFrom: interval first to: interval last delta: 0 ]]. - anythingDone ifTrue: [ - self recomputeSelection. "Needed so visible selection is updated to reflect new visual extent of selection" - self userHasEdited ]. - - "Even if nothing done, emphasisHere might have changed" - morph possiblyChanged! ! -!TextEditor methodsFor: 'undo & redo' stamp: 'jmv 9/6/2017 10:02:20' prior: 16933011! - redo - - morph disablesEditing ifTrue: [ - ^ self ]. - - model redoAndEvaluate: [ :modelUpdated :newCursorPos | - newCursorPos - ifNil: [ self recomputeSelection ] - ifNotNil: [ self markIndex: newCursorPos pointIndex: newCursorPos ]. - modelUpdated ifTrue: [ - self userHasEdited. - textComposition composeAll. "this could be made more specific..." - morph possiblyChanged ]]! ! -!TextEditor methodsFor: 'undo & redo' stamp: 'jmv 9/6/2017 10:02:24' prior: 16933031! - undo - - morph disablesEditing ifTrue: [ - ^ self ]. - - model undoAndEvaluate: [ :modelUpdated :newCursorPos | - newCursorPos - ifNil: [ self recomputeSelection ] - ifNotNil: [ self markIndex: newCursorPos pointIndex: newCursorPos ]. - modelUpdated ifTrue: [ - self userHasEdited. - textComposition composeAll. "this could be made more specific..." - morph possiblyChanged ]]! ! -!BrowserWindow methodsFor: 'updating' stamp: 'jmv 9/6/2017 10:04:55' prior: 50368607! - editSelectionChanged - - self isEditSelectionNone - ifTrue: [ self disableCodePaneEditing ] - ifFalse: [ self enableCodePaneEditing]! ! -!InnerTextMorph methodsFor: 'blinking cursor' stamp: 'jmv 9/6/2017 10:02:07' prior: 16856157! - showsBlinkingCursor - - ^self handlesKeyboard and: [ self disablesEditing not ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3166-ItIsEditingNotEdition-JuanVuletich-2017Sep06-10h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3165] on 6 September 2017 at 10:09:36 am'! - -InnerTextMorph removeSelector: #disableEdition! - -InnerTextMorph removeSelector: #disableEdition! - -InnerTextMorph removeSelector: #disablesEdition! - -InnerTextMorph removeSelector: #disablesEdition! - -InnerTextMorph removeSelector: #enableEdition! - -InnerTextMorph removeSelector: #enableEdition! - -BrowserWindow removeSelector: #disableCodePaneEdition! - -BrowserWindow removeSelector: #disableCodePaneEdition! - -BrowserWindow removeSelector: #enableCodePaneEdition! - -BrowserWindow removeSelector: #enableCodePaneEdition! - -TextModelMorph removeSelector: #disableEdition! - -TextModelMorph removeSelector: #disableEdition! - -TextModelMorph removeSelector: #enableEdition! - -TextModelMorph removeSelector: #enableEdition! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3167-EditionMisnomerCleanup-JuanVuletich-2017Sep06-10h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3162] on 4 September 2017 at 5:01:33 pm'! - -ChangeList subclass: #ChangeListWithFileInErrors - instanceVariableNames: 'errors' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #ChangeListWithFileInErrors category: #'Tools-Changes'! -ChangeList subclass: #ChangeListWithFileInErrors - instanceVariableNames: 'errors' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! -!ChangeListWithFileInErrors commentStamp: 'HAW 9/4/2017 10:23:05' prior: 0! - This class is used to keep errors when filing in changes. -I could have use ChangeList directly, selecting changes with errors, then removing them, etc., but it had some problems and that solution is more a hack. -So, instances of this class will keep errors when filing in a change, and it allows the posibility to show the change with the error in a change list window. - -A doit change that signaled a MessageNotUnderstood is assume to not be an error becuase those kinds of things are evaluations in specific contexts that will obiously generate errors. -All doits with errors could be assume not to be errors, but I limited to MNU type of errors to avoid filtering errors that should be shown.! -!ChangeListWithFileInErrors methodsFor: 'filing in' stamp: 'HAW 9/4/2017 09:34:35'! - fileInAllKeepingErrors - - errors := Dictionary new. - changeList do: [ :change | self fileInKeepingError: change ]. -! ! -!ChangeListWithFileInErrors methodsFor: 'filing in' stamp: 'HAW 9/4/2017 16:36:13'! - fileInKeepingError: change - - [ change fileIn ] - on: Error - do: [ :anError | (self hasToKeep: anError for: change) ifTrue: [ errors at: change put: anError ]]! ! -!ChangeListWithFileInErrors methodsFor: 'initialization-release' stamp: 'HAW 9/4/2017 09:34:20'! - initialize - - super initialize. - errors := Dictionary new.! ! -!ChangeListWithFileInErrors methodsFor: 'testing' stamp: 'HAW 9/4/2017 09:37:00'! - hasFileInErrors - - ^errors notEmpty! ! -!ChangeListWithFileInErrors methodsFor: 'testing' stamp: 'HAW 9/4/2017 16:37:07'! - hasToKeep: anError for: change - - ^(change isDoIt and: [ anError isKindOf: MessageNotUnderstood ]) not! ! -!ChangeListWithFileInErrors methodsFor: 'showing filein errors' stamp: 'HAW 9/4/2017 10:01:06'! - failedFileInChangesLabel - - ^'Changes that failed to file in'! ! -!ChangeListWithFileInErrors methodsFor: 'showing filein errors' stamp: 'HAW 9/4/2017 10:45:43'! -ifFiledInWithErrorAdd: aChange at: anIndex to: newChangeList and: newList - - (self wasFiledInWithError: aChange) ifTrue: [ - newChangeList add: aChange. - newList add: ((list at: anIndex) contractTo: 40), ' | ', (errors at: aChange) printString ]! ! -!ChangeListWithFileInErrors methodsFor: 'showing filein errors' stamp: 'HAW 9/4/2017 10:04:47'! - removeSucessfullyFiledInChanges - - | newChangeList newList | - - newChangeList := OrderedCollection new. - newList := OrderedCollection new. - - changeList withIndexDo: [ :aChange :anIndex | self ifFiledInWithErrorAdd: aChange at: anIndex to: newChangeList and: newList ]. - - changeList _ newChangeList. - list _ newList. - listIndex _ 0. - self clearSelections. - self changed: #list.! ! -!ChangeListWithFileInErrors methodsFor: 'showing filein errors' stamp: 'HAW 9/4/2017 10:02:20'! - showChangesWithFileInErrors - - self removeSucessfullyFiledInChanges. - ChangeListWindow open: self label: self failedFileInChangesLabel - -! ! -!ChangeListWithFileInErrors methodsFor: 'showing filein errors' stamp: 'HAW 9/4/2017 10:46:01'! - wasFiledInWithError: aChange - - ^errors includesKey: aChange! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:48:40'! - logSnapshot: save andQuit: quit - "Log quitting to changes file" - | msg | - (SourceFiles at: 2) ifNotNil: [ - msg _ self snapshotMessageFor: save andQuit: quit. - self assureStartupStampLogged. - save ifTrue: [ - LastQuitLogPosition _ (SourceFiles at: 2) - setToEnd; - position ]. - self logChange: msg. - Transcript - newLine; - show: msg; - newLine ]! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:42:57'! - nopTag - - ^ 'NOP'! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:42:27'! - quitNoSaveTag - - ^ 'QUIT/NOSAVE' ! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:40:45'! - quitTag - - ^'QUIT'! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:51:51'! - snapshotMessageFor: save andQuit: quit - - ^String streamContents: [ :stream | - stream - nextPutAll: self tagHeader; - nextPutAll: (self snapshotTagFor: save andQuit: quit); - nextPutAll: self tagTail; - print: Date dateAndTimeNow; - space; - nextPutAll: self imageName asFileEntry name; - nextPutAll: ' priorSource: '; - print: LastQuitLogPosition ].! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:41:19'! - snapshotTag - - ^'SNAPSHOT'! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:51:20'! - snapshotTagFor: save andQuit: quit - - ^save - ifTrue: [ quit - ifTrue: [ self quitTag ] - ifFalse: [ self snapshotTag ]] - ifFalse: [ quit - ifTrue: [ self quitNoSaveTag ] - ifFalse: [ self nopTag ]]! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:45:54'! - tagHeader - - ^ '----'! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:46:02'! - tagTail - - ^ self tagHeader! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:11:51'! - hasToRestoreChanges - - ^self withChangesFileDo: [ :changesFile | - changesFile position: self lastQuitLogPosition. - self hasToRestoreChangesFrom: changesFile ]. - ! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 16:41:24'! - hasToRestoreChangesFrom: changesFile - - | chunk | - - [ changesFile atEnd ] whileFalse: [ chunk := changesFile nextChunk ]. - - ^(self isSnapshotQuitOrQuitNoSaveRecord: chunk) not -! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 08:56:02'! - isQuitNoSaveRecord: chunk - - ^chunk beginsWith: self tagHeader, self quitNoSaveTag - ! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 08:55:51'! - isQuitRecord: chunk - - ^chunk beginsWith: self tagHeader, self quitTag ! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 16:34:34'! - isSnapshotQuitOrQuitNoSaveRecord: chunk - - ^(self isSnapshotRecord: chunk) - or: [ (self isQuitRecord: chunk) - or: [ self isQuitNoSaveRecord: chunk ]]! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 08:57:09'! - isSnapshotRecord: chunk - - ^chunk beginsWith: self tagHeader, self snapshotTag - ! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 09:07:35'! - lostChangesDetectedCaption - - ^ -'Last changes may have been lost -(maybe the VM crashed or you had to kill it) -What do you want to do?'! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:25:45'! - restoreLostChanges - - | decision | - - decision := PopUpMenu withCaption: self lostChangesDetectedCaption chooseFrom: self restoreLostChangesOptions. - - decision = 1 ifTrue: [ ^self restoreLostChangesAutomatically ]. - decision = 2 ifTrue: [ ^self restoreLostChangesManually ]! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:13:01'! - restoreLostChangesAutomatically - - self withChangesFileDo: [ :aChangesFile | self restoreLostChangesAutomaticallyFrom: aChangesFile ]! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 10:15:16'! - restoreLostChangesAutomaticallyFrom: aChangesFile - - | changeList | - - changeList := ChangeListWithFileInErrors new. - changeList scanFile: aChangesFile from: LastQuitLogPosition to: aChangesFile size. - changeList fileInAllKeepingErrors. - (changeList hasFileInErrors and: [ self shouldShowFileInErrors ]) ifTrue: [ changeList showChangesWithFileInErrors ] -! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:09:39'! - restoreLostChangesIfNecessary - - " - Smalltalk restoreLostChangesIfNecessary - " - - self hasToRestoreChanges ifTrue: [ WorldState addDeferredUIMessage: [self restoreLostChanges ]]. -! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/1/2017 17:28:22'! - restoreLostChangesManually - - ChangeList browseRecentLog! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:25:55'! - restoreLostChangesOptions - - ^{'Restore lost changes automatically'. 'Restore lost changes manually'. 'Nothing'}.! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:29:46'! - restoringChangesHasErrorsCaption - - ^'There were errors filing in the lost changes. Do you want to see them?'! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 09:37:34'! - shouldShowFileInErrors - - ^self confirm: self restoringChangesHasErrorsCaption - ! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:11:39'! - withChangesFileDo: aBlock - - ^self currentChangesName asFileEntry readStreamDo: aBlock! ! -!ChangeRecord methodsFor: 'testing' stamp: 'HAW 9/4/2017 06:32:29'! - isDoIt - - ^type = #doIt! ! -!ChangeList methodsFor: 'menu actions' stamp: 'HAW 9/4/2017 10:26:32' prior: 16796254! - removeDoIts - "Remove doits from the receiver, other than initializes. 1/26/96 sw" - - | newChangeList newList | - newChangeList _ OrderedCollection new. - newList _ OrderedCollection new. - - changeList with: list do: [ :chRec :str | - (chRec isDoIt not or: [str endsWith: 'initialize']) - ifTrue: [ - newChangeList add: chRec. - newList add: str]]. - newChangeList size < changeList size - ifTrue: [ - changeList _ newChangeList. - list _ newList. - listIndex _ 0. - self clearSelections ]. - self changed: #list. - - ! ! -!ChangeList methodsFor: 'menu actions' stamp: 'HAW 9/4/2017 10:26:50' prior: 16796515! - selectRemovalsOfSent - "Selects all method removal for sent methods" - - 1 to: changeList size do: [ :i | | change | - change _ changeList at: i. - listSelections at: i put: - (change isDoIt and: [ - change string includesSubString: 'removeSelector: #' ] and: [ - Smalltalk isThereAReferenceTo: (change string copyAfterLast: $#) asSymbol ]) ]. - self changed: #allSelections. - self changed: #annotation! ! -!ChangeList class methodsFor: 'public access' stamp: 'HAW 9/4/2017 10:32:00' prior: 16796892! - browseRecentLogOn: origChangesFileName - "figure out where the last snapshot or quit was, then browse the recent entries." - - | end done block positions prevBlock | - origChangesFileName asFileEntry readStreamDo: [ :changesFile | - positions _ SortedCollection new. - end _ changesFile size. - prevBlock _ end. - block _ end - 1024 max: 0. - done _ false. - [ done or: [ positions size > 0 ]] - whileFalse: [ - changesFile position: block. - "ignore first fragment" - changesFile nextChunk. - [ changesFile position < prevBlock ] - whileTrue: [ - | pos chunk | - pos _ changesFile position. - chunk _ changesFile nextChunk. - ((Smalltalk isQuitRecord: chunk) or: [ Smalltalk isSnapshotRecord: chunk ]) - ifTrue: [ positions add: pos ]]. - block = 0 - ifTrue: [done _ true] - ifFalse: [ - prevBlock _ block. - block _ block - 1024 max: 0]]. - ]. - positions isEmpty - ifTrue: [self inform: 'File ' , origChangesFileName , ' does not appear to be a changes file'] - ifFalse: [self browseRecentLogOn: origChangesFileName startingFrom: positions last]! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:46:37' prior: 50361385! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag -"WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " -| activeProc | -activeProc _ Processor activeProcess. -[ - | isARealStartup world reopenTranscript | - self logSnapshot: save andQuit: quit. - - reopenTranscript _ false. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | each isInWorld ifTrue: [ each delete. reopenTranscript _ true ]]. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - - - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - - "Cosas que levanto explicitamente abajo" - world _ ProjectX ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "world _ clearAllStateFlag ifFalse: [ ProjectX ui ]." - ProjectX stopUIProcess. - activeProc isTerminated ifFalse: [ - activeProc terminate ]. - - "Clean Globals" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: nil. - Smalltalk closeSourceFiles. Smalltalk at: #SourceFiles put: nil. - Smalltalk allClassesDo: [ :cls | cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ Smalltalk printStuffToCleanOnImageSave ]. - - - "Do image save & quit as apropriate" - Cursor write activateCursor. - save - ifTrue: [ - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - - - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: (DisplayScreen extent: `1024@768` depth: 32). - Smalltalk at: #SourceFiles put: (Array new: 2). - Smalltalk openSourceFiles. - - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - - - ProjectX spawnNewMorphicProcessFor: (world ifNil: [ PasteUpMorph newWorld ]). - - reopenTranscript ifTrue: [ - WorldState addDeferredUIMessage: [ - TranscriptWindow openTranscript ]]. - " - WorldState addDeferredUIMessage: [ - world fullRepaintNeeded ]. - " - - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - WorldState addDeferredUIMessage: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]. - -] forkAt: Processor timingPriority-1 named: 'Startup process'.! ! -!SystemDictionary methodsFor: 'startup' stamp: 'HAW 9/4/2017 06:14:44' prior: 50335324! - doStartUp: isARealStartup - " - isARealStartup - true: system is coming up (VM and image just started) - false: we have just saved an image snapshot, but didn't quit. - " - - "Here, startup begins!!" - Cursor normal activateCursor. - self setGCParameters. - isARealStartup ifTrue: [ - self clearExternalObjects ]. - self readCommandLineArguments. - self processStartUpList: isARealStartup. - isARealStartup ifTrue: [ - self setPlatformPreferences. - self setStartupStamp. - self restoreLostChangesIfNecessary ]! ! -!ChangeRecord methodsFor: 'initialization' stamp: 'HAW 9/4/2017 10:27:15' prior: 16797438! - fileIn - "File the receiver in. If I represent a method or a class-comment, file the method in and make a note of it in the recent-submissions list; if I represent a do-it, then, well, do it." - | s | - type == #method ifTrue: [ - self changeClass ifNotNil: [ :methodClass | - methodClass - compile: self text - classified: category - withStamp: stamp - notifying: nil ]]. - self isDoIt ifTrue: [ - ((s _ self string) beginsWith: '----') ifFalse: [ Compiler evaluate: s ]]. - type == #classDefinition ifTrue: [ Compiler evaluate: self string ]. - type == #classComment ifTrue: [ - (Smalltalk at: class asSymbol) - comment: self text - stamp: stamp ]! ! - -SystemDictionary removeSelector: #logSapshot:andQuit:! - -SystemDictionary removeSelector: #logSapshot:andQuit:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3168-AidInRecoveringChanges-HernanWilkinson-2017Sep01-13h49m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3168] on 10 September 2017 at 4:47:52 pm'! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'jmv 9/10/2017 16:44:03'! - withNextDo: twoArgBlock - "Evaluate the block with each element and the one following it. - For the last element, next is nil - (1 to: 10) asArray withNextDo: [ :each :next | {each. next} print ] - #() withNextDo: [ :a :b | {a. b} print ] - " - | first previous | - first _ true. - self do: [ :each | - first ifTrue: [ - first _ false ] - ifFalse: [ - twoArgBlock value: previous value: each ]. - previous _ each ]. - first ifFalse: [ - twoArgBlock value: previous value: nil ]! ! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'jmv 9/10/2017 16:44:25'! - withPreviousDo: twoArgBlock - "Evaluate the block with each element and the one before it. - For the first element, previous is nil - (1 to: 10) asArray withPreviousDo: [ :each :previous | {previous. each} print ] - #() withPreviousDo: [ :a :b | {a. b} print ] - " - | previous | - previous _ nil. - self do: [ :each | - twoArgBlock value: each value: previous. - previous _ each ].! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3169-withNextDo-withPreviousDo-JuanVuletich-2017Sep10-16h47m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3168] on 10 September 2017 at 4:29:09 pm'! - -TextAttribute subclass: #TextBackgroundColor - instanceVariableNames: 'color' - classVariableNames: '' - poolDictionaries: '' - category: 'System-TextAttributes'! - -!classDefinition: #TextBackgroundColor category: #'System-TextAttributes'! -TextAttribute subclass: #TextBackgroundColor - instanceVariableNames: 'color' - classVariableNames: '' - poolDictionaries: '' - category: 'System-TextAttributes'! -!TextBackgroundColor commentStamp: '' prior: 0! - A TextBackgroundColor encodes a highlight (background) color change applicable over a given range of text.! - -TextBackgroundColor subclass: #ShoutTextBackgroundColor - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'System-TextAttributes'! - -!classDefinition: #ShoutTextBackgroundColor category: #'System-TextAttributes'! -TextBackgroundColor subclass: #ShoutTextBackgroundColor - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'System-TextAttributes'! -!ShoutTextBackgroundColor commentStamp: '' prior: 0! - Just for code styler (Shout)! - -CharacterScanner subclass: #MorphicScanner - instanceVariableNames: 'canvas lineY foregroundColor defaultColor topLeft ignoreColorChanges backgroundColor ' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Text'! - -!classDefinition: #MorphicScanner category: #'Graphics-Text'! -CharacterScanner subclass: #MorphicScanner - instanceVariableNames: 'canvas lineY foregroundColor defaultColor topLeft ignoreColorChanges backgroundColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Text'! -!TextAttribute methodsFor: 'iterating' stamp: 'jmv 9/7/2017 16:45:20'! - forTextBackgroundColorDo: aBlock - "No action is the default"! ! -!TextBackgroundColor methodsFor: 'accessing' stamp: 'jmv 9/7/2017 16:41:55'! - color - ^ color! ! -!TextBackgroundColor methodsFor: 'accessing' stamp: 'jmv 9/7/2017 16:41:55'! - color: aColor - color _ aColor! ! -!TextBackgroundColor methodsFor: 'comparing' stamp: 'jmv 9/7/2017 16:41:55'! - = other - self == other ifTrue: [ ^ true ]. - ^ (other class == self class) - and: [other color = color]! ! -!TextBackgroundColor methodsFor: 'comparing' stamp: 'jmv 9/7/2017 16:41:55'! - hash - ^ color hash! ! -!TextBackgroundColor methodsFor: 'printing' stamp: 'jmv 9/7/2017 16:41:55'! - printOn: strm - super printOn: strm. - strm nextPutAll: ' code: '; print: color! ! -!TextBackgroundColor methodsFor: 'scanning' stamp: 'jmv 9/7/2017 16:41:55'! - dominates: other - ^ other class == self class! ! -!TextBackgroundColor methodsFor: 'iterating' stamp: 'jmv 9/7/2017 16:45:12'! - forTextBackgroundColorDo: aBlock - aBlock value: color! ! -!TextBackgroundColor methodsFor: 'testing' stamp: 'jmv 9/7/2017 16:44:40'! - isSet - "Do not include Color black, as it is the default color." - ^color isTransparent not! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - black - ^ self new color: Color black! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - blue - ^ self new color: Color blue! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - cyan - ^ self new color: Color cyan! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - gray - ^ self new color: Color gray! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - green - ^ self new color: Color green! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - magenta - ^ self new color: Color magenta! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - red - ^ self new color: Color red! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - white - ^ self new color: Color white! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - yellow - ^ self new color: Color yellow! ! -!TextBackgroundColor class methodsFor: 'instance creation' stamp: 'jmv 9/7/2017 16:41:55'! - color: aColor - ^ self new color: aColor! ! -!ShoutTextBackgroundColor methodsFor: 'testing' stamp: 'jmv 9/7/2017 16:42:03'! - isForShout - "True if to be removed from code before styling" - ^true! ! -!CharacterScanner methodsFor: 'private' stamp: 'jmv 9/7/2017 17:00:23'! - backgroundColor: ignored - "Overridden in MorphicScanner"! ! -!MorphicScanner methodsFor: 'private' stamp: 'jmv 9/7/2017 16:56:38'! - backgroundColor: aColor - backgroundColor _ aColor! ! -!Text methodsFor: 'emphasis' stamp: 'jmv 9/10/2017 16:28:51' prior: 16929486! - withAttributeValues: attributes do: aBlock - "Evaluate aBlock with the values of various attributes that affect text formatting, applied in the correct order - The order is (each overwriting the previous one) - 1) basic defaults - 2) ParagraphStyleReferene - 3) CharacterStyleReference - 4) TextFontReference - 5) TextEmphasis" - - | paragraphStyle characterStyle familyName pointSize emphasis alignment color backgroundColor | - paragraphStyle _ nil. - characterStyle _ nil. - familyName _ nil. - pointSize _ nil. - emphasis _ 0. - alignment _ 0. - color _ nil. - backgroundColor _ nil. - - "ParagraphStyle is the first to set several values" - attributes do: [ :attribute | - attribute forParagraphStyleReferenceDo: [ :s | - paragraphStyle _ s. - familyName _ s familyName. - pointSize _ s pointSize. - emphasis _ s emphasis. - alignment _ s alignment. - s color ifNotNil: [ :c | color _ c ]]]. - - "CharacterStyle, if present, can override font and color" - attributes do: [ :attribute | - attribute forCharacterStyleReferenceDo: [ :s | - characterStyle _ s. - familyName _ s familyName. - pointSize _ s pointSize. - emphasis _ s emphasis. - s color ifNotNil: [ :c | color _ c ]]]. - - "These will not interfere with each other, and all of them take precedence over previous values" - attributes do: [ :attribute | - attribute forFontFamilyAndSizeDo: [ :fn :ps | familyName _ fn. pointSize _ ps ]. - attribute forTextEmphasisDo: [ :e | emphasis _ emphasis bitOr: e ]. - attribute forTextColorDo: [ :c | color _ c ]. - attribute forTextBackgroundColorDo: [ :c | backgroundColor _ c ]. - attribute forTextAlignmentDo: [ :a | alignment _ a ]. - ]. - - "Done. Now evaluate the block." -"change all senders!!!!!!!!!!!!" - aBlock numArgs = 8 ifTrue: [ - ^aBlock valueWithArguments: { familyName. pointSize. emphasis. color. alignment. characterStyle. paragraphStyle. backgroundColor } - ]. - ^aBlock valueWithArguments: { familyName. pointSize. emphasis. color. alignment. characterStyle. paragraphStyle }! ! -!BitBlt methodsFor: 'accessing' stamp: 'jmv 9/6/2017 20:40:02' prior: 16785548! - destX: x destY: y width: w height: h - destX _ x. - destY _ y. - width _ w. - height _ h.! ! -!CharacterScanner methodsFor: 'private' stamp: 'jmv 9/7/2017 17:19:12' prior: 16801954! - setFont - | attributes | - "Set the font and other emphasis. - In fact set actual ParagraphStyle (or nil), alignment, font and emphasis" - - self setActualFont: (text fontAt: lastIndex default: defaultFont). - attributes _ text attributesAt: lastIndex. - text - withAttributeValues: attributes - do: [ :familyNameInText :pointSizeInText :emphasisInText :colorInText :alignmentInText :characterStyleInText :paragraphStyleInText :backgroundColorInText | - colorInText ifNotNil: [ self textColor: colorInText ]. - self backgroundColor: backgroundColorInText. - alignment _ alignmentInText. - paragraphStyle _ paragraphStyleInText ]. - - "Hardcoded color for TextAction" - attributes do: [ :attribute | - attribute forTextActionInfoDo: [ :info | - self textColor: TextAction textActionColor ]]. - - "Install various parameters from the font." - spaceWidth _ font widthOf: Character space. - tabWidth _ (font widthOf: $a) * 3. - xTable _ font xTable. - map _ font characterToGlyphMap! ! -!CharacterScanner methodsFor: 'private' stamp: 'jmv 9/6/2017 20:40:09' prior: 16801989! - textColor: ignored - "Overridden in MorphicScanner"! ! -!MorphicScanner methodsFor: 'scanning' stamp: 'jmv 9/10/2017 16:28:26' prior: 16877966! - displayLine: textLine textTopLeft: textTopLeft leftInRun: leftInRun - "The call on the primitive (scanCharactersFrom:to:in:rightX:) will be interrupted according to an array of stop conditions passed to the scanner at which time the code to handle the stop condition is run and the call on the primitive continued until a stop condition returns true (which means the line has terminated). leftInRun is the # of characters left to scan in the current run; when 0, it is time to call setStopConditions." - - "textTopLeft is relative to the morph currently being drawn" - | stopCondition nowLeftInRun startIndex string lastPos | - - topLeft _ textTopLeft. - line _ textLine. - lineY _ line top + textTopLeft y. - rightMargin _ line rightMargin + textTopLeft x. - lastIndex _ line first. - leftInRun <= 0 ifTrue: [ - self setFont. - self setStopConditions ]. - leftMargin _ (line leftMarginForAlignment: alignment) + textTopLeft x. - destX _ leftMargin. - destY _ lineY + line baseline - font ascent. - - textLine isEmptyLine ifTrue: [ - textLine paragraphStyle ifNotNil: [ :ps | - ps = paragraphStyle ifFalse: [ - foregroundColor _ defaultColor. - self setActualFont: ps font. - ps color ifNotNil: [ :color | self textColor: color ]. - alignment _ ps alignment. - paragraphStyle _ ps. - spaceWidth _ font widthOf: Character space. - tabWidth _ (font widthOf: $a) * 3. - xTable _ font xTable. - map _ font characterToGlyphMap. - self setStopConditions. - text ifNotNil: [ destY _ lineY + line baseline - font ascent ]]]. - self displayBulletIfAppropriateFor: textLine textLeft: textTopLeft x. - ^leftInRun ]. - - self displayBulletIfAppropriateFor: textLine textLeft: textTopLeft x. - - lastIndex _ line first. - leftInRun <= 0 - ifTrue: [nowLeftInRun _ text runLengthFor: lastIndex] - ifFalse: [nowLeftInRun _ leftInRun]. - runStopIndex _ lastIndex + (nowLeftInRun - 1) min: line last. - spaceCount _ 0. - string _ text string. - - self placeEmbeddedObject. - [ - startIndex _ lastIndex. - lastPos _ destX@destY. - stopCondition _ self - scanCharactersFrom: lastIndex to: runStopIndex - in: string rightX: rightMargin stopConditions: stopConditions - kern: font baseKern. - backgroundColor ifNotNil: [ - canvas - fillRectangle: (lastPos corner: destX @ (line bottom + textTopLeft y)) - color: backgroundColor ]. - lastIndex >= startIndex ifTrue: [ - canvas - drawString: string - from: startIndex - to: lastIndex - at: lastPos - font: font - color: foregroundColor ]. - "see setStopConditions for stopping conditions for displaying." - (self perform: stopCondition) ifTrue: [ - "Number of characters remaining in the current run" - ^ runStopIndex - lastIndex ] - ] repeat! ! - -CharacterScanner subclass: #MorphicScanner - instanceVariableNames: 'canvas lineY foregroundColor defaultColor topLeft backgroundColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Text'! - -!classDefinition: #MorphicScanner category: #'Graphics-Text'! -CharacterScanner subclass: #MorphicScanner - instanceVariableNames: 'canvas lineY foregroundColor defaultColor topLeft backgroundColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Text'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3170-TextBackgroundColor-JuanVuletich-2017Sep10-16h23m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3168] on 10 September 2017 at 4:36:05 pm'! -!Text methodsFor: 'emphasis' stamp: 'jmv 9/10/2017 16:32:21' prior: 16929265! - alignmentAt: characterIndex - - self - withAttributeValues: (self attributesAt: characterIndex) - do: [ :familyName :pointSize :emphasis :color :alignment :characterStyle :paragraphStyle :backgroundColor | - ^ alignment ]! ! -!Text methodsFor: 'emphasis' stamp: 'jmv 9/10/2017 16:33:17' prior: 16929295! - characterStyleOrNilAt: characterIndex - - self - withAttributeValues: (self attributesAt: characterIndex) - do: [ :familyName :pointSize :emphasis :color :alignment :characterStyle :paragraphStyle :backgroundColor | - ^ characterStyle ]! ! -!Text methodsFor: 'emphasis' stamp: 'jmv 9/10/2017 16:33:23' prior: 16929304! - characterStyleOrNilIfApplying: textAttributes - "Answer the ParagraphStyle for characters as specified by the argument." - - self withAttributeValues: textAttributes do: [ :familyName :pointSize :emphasis :color :alignment :characterStyle :paragraphStyle :backgroundColor | - ^characterStyle ]! ! -!Text methodsFor: 'emphasis' stamp: 'jmv 9/10/2017 16:33:30' prior: 16929363! - emphasisAt: characterIndex - "Answer the emphasis for characters in the run beginning at characterIndex." - - self - withAttributeValues: (self attributesAt: characterIndex) - do: [ :familyName :pointSize :emphasis :color :alignment :characterStyle :paragraphStyle :backgroundColor | - ^ emphasis ]! ! -!Text methodsFor: 'emphasis' stamp: 'jmv 9/10/2017 16:33:36' prior: 16929398! - fontIfApplying: textAttributes default: defaultFont - "Answer the font for characters as specified by the argument." - - self withAttributeValues: textAttributes do: [ :familyName :pointSize :emphasis :color :alignment :characterStyle :paragraphStyle :backgroundColor | - ^((AbstractFont familyName: familyName pointSize: pointSize) ifNil: [ defaultFont baseFont ]) - emphasized: emphasis ]! ! -!Text methodsFor: 'emphasis' stamp: 'jmv 9/10/2017 16:33:42' prior: 16929443! - paragraphStyleOrNilAt: characterIndex - - self - withAttributeValues: (self attributesAt: characterIndex) - do: [ :familyName :pointSize :emphasis :color :alignment :characterStyle :paragraphStyle :backgroundColor | - ^ paragraphStyle ]! ! -!Text methodsFor: 'emphasis' stamp: 'jmv 9/10/2017 16:33:48' prior: 16929452! - paragraphStyleOrNilIfApplying: textAttributes - "Answer the ParagraphStyle for characters as specified by the argument." - - self - withAttributeValues: textAttributes - do: [ :familyName :pointSize :emphasis :color :alignment :characterStyle :paragraphStyle :backgroundColor | - ^paragraphStyle ]! ! -!Text methodsFor: 'emphasis' stamp: 'jmv 9/10/2017 16:34:25' prior: 50370242! - withAttributeValues: attributes do: aBlock - "Evaluate aBlock with the values of various attributes that affect text formatting, applied in the correct order - The order is (each overwriting the previous one) - 1) basic defaults - 2) ParagraphStyleReferene - 3) CharacterStyleReference - 4) TextFontReference - 5) TextEmphasis" - - | paragraphStyle characterStyle familyName pointSize emphasis alignment color backgroundColor | - paragraphStyle _ nil. - characterStyle _ nil. - familyName _ nil. - pointSize _ nil. - emphasis _ 0. - alignment _ 0. - color _ nil. - backgroundColor _ nil. - - "ParagraphStyle is the first to set several values" - attributes do: [ :attribute | - attribute forParagraphStyleReferenceDo: [ :s | - paragraphStyle _ s. - familyName _ s familyName. - pointSize _ s pointSize. - emphasis _ s emphasis. - alignment _ s alignment. - s color ifNotNil: [ :c | color _ c ]]]. - - "CharacterStyle, if present, can override font and color" - attributes do: [ :attribute | - attribute forCharacterStyleReferenceDo: [ :s | - characterStyle _ s. - familyName _ s familyName. - pointSize _ s pointSize. - emphasis _ s emphasis. - s color ifNotNil: [ :c | color _ c ]]]. - - "These will not interfere with each other, and all of them take precedence over previous values" - attributes do: [ :attribute | - attribute forFontFamilyAndSizeDo: [ :fn :ps | familyName _ fn. pointSize _ ps ]. - attribute forTextEmphasisDo: [ :e | emphasis _ emphasis bitOr: e ]. - attribute forTextColorDo: [ :c | color _ c ]. - attribute forTextBackgroundColorDo: [ :c | backgroundColor _ c ]. - attribute forTextAlignmentDo: [ :a | alignment _ a ]. - ]. - - "Done. Now evaluate the block." - ^aBlock valueWithArguments: { familyName. pointSize. emphasis. color. alignment. characterStyle. paragraphStyle. backgroundColor }! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3171-Cleanup-JuanVuletich-2017Sep10-16h32m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3168] on 10 September 2017 at 4:45:51 pm'! - -Object subclass: #SHRange - instanceVariableNames: 'start end type blockDepth ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -!classDefinition: #SHRange category: #'Tools-Syntax Highlighting'! -Object subclass: #SHRange - instanceVariableNames: 'start end type blockDepth' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! -!Preferences class methodsFor: 'shout' stamp: 'jmv 9/10/2017 16:40:28'! - highlightBlockNesting - ^ self - valueOfFlag: #highlightBlockNesting - ifAbsent: [true]! ! -!SHRange methodsFor: 'accessing' stamp: 'jmv 9/6/2017 20:25:10'! - blockDepth - ^blockDepth! ! -!SHRange methodsFor: 'accessing' stamp: 'jmv 9/6/2017 20:22:45'! - blockDepth: anInteger - blockDepth := anInteger! ! -!SHParserST80 methodsFor: 'recording ranges' stamp: 'jmv 9/9/2017 15:21:28' prior: 16902916! - rangeType: aSymbol start: s end: e - ^ranges add: ((SHRange start: s end: e type: aSymbol) blockDepth: blockDepth)! ! -!SHTextStylerST80 methodsFor: 'private' stamp: 'jmv 9/10/2017 16:41:27' prior: 50335086! - setAttributesFromRanges: ranges - - | alpha start end | - formattedText removeAttributesThat: [ :attribute | attribute isForShout ]. - - "Optimize for mutation speed unless method is really large but with very few distict elements: - Source code that includes just big literals is better served by conventional Text+RunArray" - "Do it only if we are not breaking textModel!! (for instance, StyledTextEditor asks for formatting just sections, not whole #actualContents)." - formattedText == textModel actualContents ifTrue: [ - (formattedText size > 2000 and: [ ranges size < 50 ]) ifFalse: [ - formattedText _ formattedText optimizedForMutationSpeed. - textModel basicActualContents: formattedText ]]. - - ranges withNextDo: [ :range :nextRangeOrNil | - - "Smalltalk text styling" - (self attributesFor: range rangeType) ifNotNil: [ :attributes | - attributes do: [ :each | - formattedText addAttribute: each from: range start to: range end ]]. - - Preferences highlightBlockNesting ifTrue: [ - alpha _ range blockDepth / 16.0 min: 0.5. - start _ range start. - end _ nextRangeOrNil ifNotNil: [ nextRangeOrNil start - 1 ] ifNil: [ range end ]. - formattedText - addAttribute: (ShoutTextBackgroundColor - color: (Theme current text alpha: alpha) ) from: start to: end ]. - - "Show as subscripts if appropriate." - classOrMetaClass ifNotNil: [ - classOrMetaClass theNonMetaClass lastUnderscoreMeansSubscript ifTrue: [ - (#( instVar classVar globalVar workspaceVar poolConstant - patternArg methodArg patternTempVar tempVar - blockPatternArg blockArg blockPatternTempVar blockTempVar - incompleteIdentifier undefinedIdentifier) pointsTo: range rangeType ) - ifTrue: [ - formattedText lastIndexOf: $_ startingAt: range end endingAt: range start do: [ :i | - formattedText addAttribute: ShoutTextEmphasis subscript from: i to: range end ] ]]]. - ]! ! - -Object subclass: #SHRange - instanceVariableNames: 'start end type blockDepth' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -!classDefinition: #SHRange category: #'Tools-Syntax Highlighting'! -Object subclass: #SHRange - instanceVariableNames: 'start end type blockDepth' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3172-ShoutShowBlockDepth-JuanVuletich-2017Sep10-16h36m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3168] on 9 September 2017 at 12:15:04 pm'! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/9/2017 12:09:32' prior: 50369680! - hasToRestoreChanges - - ^Preferences checkLostChangesOnStartUp and: [ - self withChangesFileDo: [ :changesFile | self hasToRestoreChangesFrom: changesFile ]]. - ! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/9/2017 12:09:46' prior: 50369689! - hasToRestoreChangesFrom: changesFile - - | chunk | - - changesFile position: self lastQuitLogPosition. - [ changesFile atEnd ] whileFalse: [ chunk := changesFile nextChunk ]. - - ^(self isSnapshotQuitOrQuitNoSaveRecord: chunk) not -! ! -!Preferences class methodsFor: 'start up' stamp: 'HAW 9/9/2017 12:07:37'! - checkLostChangesOnStartUp - ^ self - valueOfFlag: #checkLostChangesOnStartUp - ifAbsent: [ true ].! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3173-RestoreLostChangesPreference-HernanWilkinson-2017Sep09-12h03m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3161] on 6 September 2017 at 8:02:36 pm'! -!ChangeList class methodsFor: 'public access' stamp: 'HAW 9/6/2017 19:58:01'! - browseFrom: startPosition on: aChangesFileName labeled: aLabel - - " - ChangeList browseFrom: Smalltalk lastQuitLogPosition on: Smalltalk currentChangesName labeled: 'Lost changes' - " - - | changeList end | - - aChangesFileName asFileEntry readStreamDo: [ :changesFile | - end _ changesFile size. - changeList _ self new - scanFile: changesFile - from: startPosition - to: end. - ]. - - ChangeListWindow open: changeList label: aLabel! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/6/2017 19:59:40' prior: 50369776! - restoreLostChangesManually - - ChangeList browseFrom: LastQuitLogPosition on: self currentChangesName labeled: 'Lost changes' -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3174-RestoreChangesOnlySinceLastSnapshot-HernanWilkinson-2017Sep04-16h55m-HAW.1.cs.st----! - -----SNAPSHOT----#(10 September 2017 6:05:40.130169 pm) Cuis5.0-3174-v3.image priorSource: 1202284! - -----QUIT----#(10 September 2017 6:06:01.832791 pm) Cuis5.0-3174-v3.image priorSource: 1252284! - -----STARTUP----#(18 September 2017 11:06:38.653242 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3174-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3138] on 29 July 2017 at 10:49:50 pm'! -!Dictionary class methodsFor: 'instance creation' stamp: 'pb 7/29/2017 22:47:17' prior: 16833878! - 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 copy]]. - ^ 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 -"! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3175-Dictionary-newFrom-compatibility-with-Squeak-PhilBellalouna-2017Jul29-22h47m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3163] on 31 August 2017 at 5:46:33 am'! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'pb 8/31/2017 05:46:22' prior: 16853225! - arrowKey: aChar - "Handle a keyboard navigation character. Answer true if handled, false if not." - | keyEvent answer nextSelection oldSelection | - answer := false. - keyEvent := aChar numericValue. - oldSelection := self getSelectionIndex. - nextSelection := oldSelection. - keyEvent = 31 ifTrue: [ - "down" - nextSelection := oldSelection + 1. - nextSelection > self maximumSelection ifTrue: [ nextSelection := self minimumSelection ]]. - keyEvent = 30 ifTrue: [ - "up" - nextSelection := oldSelection - 1. - nextSelection < self minimumSelection ifTrue: [ nextSelection := self maximumSelection ]]. - keyEvent = 1 ifTrue: [ "home" - nextSelection := 1 ]. - keyEvent = 4 ifTrue: [ "end" - nextSelection := scroller submorphs size ]. - keyEvent = 11 ifTrue: [ "page up" - nextSelection := oldSelection - self numSelectionsInView max: 1 ]. - keyEvent = 12 ifTrue: [ "page down" - nextSelection := oldSelection + self numSelectionsInView ]. - keyEvent = 29 ifTrue: [ - "right" - selectedMorph ifNotNil: [ - (selectedMorph canExpand and: [ selectedMorph isExpanded not ]) - ifTrue: [ - self toggleExpandedState: selectedMorph. - answer := true ] - ifFalse: [ nextSelection := oldSelection + 1 ]]]. - keyEvent = 28 ifTrue: [ - "left" - selectedMorph ifNotNil: [ - selectedMorph isExpanded - ifTrue: [ - self toggleExpandedState: selectedMorph. - answer := true ] - ifFalse: [ nextSelection := oldSelection - 1 max: 1 ]]. - ^ true ]. - nextSelection = oldSelection ifFalse: [ - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self highlightedMorph: (self listMorphAt: nextSelection). - "Update the model in next world cycle, so user gets the immediate feedback." - WorldState addDeferredUIMessage: [ self setSelectionIndex: nextSelection ]. - answer := true ]. - ^ answer.! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3176-HierarchicalListMorph-keyboard-navigation-wrapping-PhilBellalouna-2017Aug31-05h46m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3168] on 9 September 2017 at 3:07:54 am'! -!BraceNode methodsFor: 'as yet unclassified' stamp: 'pb 9/9/2017 03:05:08'! - isComplex - ^ true.! ! -!BraceNode methodsFor: 'printing' stamp: 'pb 9/9/2017 03:05:21' prior: 16791076! - printOn: aStream indent: level - | isComplex useLevel | - useLevel := level. - isComplex := elements anySatisfy: [ :ea | - ea isComplex ]. - isComplex ifTrue: [ useLevel := useLevel + 1 ]. - aStream nextPut: ${. - 1 - to: elements size - do: [ :i | - isComplex ifTrue: [ aStream newLineTab: (1 max: useLevel) ]. - (elements at: i) - printOn: aStream - indent: useLevel. - i < elements size ifTrue: [ aStream nextPutAll: '. ' ]]. - isComplex ifTrue: [ aStream newLineTab: (1 max: level) ]. - aStream nextPut: $}.! ! -!LiteralNode methodsFor: 'printing' stamp: 'pb 9/9/2017 03:06:57' prior: 50334837! - printOn: aStream indent: level - key isVariableBinding - ifTrue: [ - key key isNil - ifTrue: [ - aStream - nextPutAll: '###'; - nextPutAll: key value soleInstance name ] - ifFalse: [ - aStream - nextPutAll: '##'; - nextPutAll: key key ]] - ifFalse: [ - key isLiteral - ifTrue: [ | isComplex | - isComplex := false. - key isArray ifTrue: [ - isComplex := key anySatisfy: [ :ea | - ea isArray ]]. - "Is it complex? (i.e. array of arrays)" - isComplex - ifTrue: [ - aStream - nextPut: $#; - nextPut: $(. - key do: [ :ea | - aStream newLineTab: (1 max: level + 1). - ea storeOn: aStream ]. - aStream newLineTab: (1 max: level). - aStream nextPut: $) ] - ifFalse: [ key storeOn: aStream ]] - ifFalse: [ - "Need to generate code for stuff that is in a CompiledMethod literal - but is not understood as a literal by the Compiler. - Well, then it is because it was generated using backticks!!" - aStream nextPut: $`. - key storeOn: aStream. - aStream nextPut: $` ]].! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3177-PrettyPrint-complex-arrays-PhilBellalouna-2017Sep09-03h05m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3168] on 9 September 2017 at 12:50:57 am'! -!FileList commentStamp: '' prior: 16842300! - I am model that can be used to navigate the host file system. By omitting the volume list, file list, and template panes from the view, I can also be used as the model for an editor on an individual file. - -The FileList provides a dynamic extension mechanism. To extend FileList functionality, tools should implement the following class-side method (look for implementors in the image): - -#fileReaderServicesForFile:suffix: (appropriate services for given file, takes a file name and a lowercased suffix) - -This method returns a collection of SimpleServiceEntry instances. These contain a class, a menu label and a method selector having one argument. They may also provide separate button labels and description. - -The argument to the specified method will be a string representing the full name of a file when one is selected or the file list itself when there is no selected file.! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3178-FileList-class-comment-PhilBellalouna-2017Sep09-00h27m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3174] on 13 September 2017 at 3:48:54 pm'! -!UndeclaredVariableWarning methodsFor: 'accessing' stamp: 'HAW 9/13/2017 15:16:19'! - classImplementingSelector - - ^class ! ! -!UndeclaredVariableWarning methodsFor: 'accessing' stamp: 'HAW 9/13/2017 15:15:44'! - selector - - ^selector ! ! -!UndeclaredVariableWarning methodsFor: 'accessing' stamp: 'HAW 9/13/2017 15:15:34'! - variableName - - ^name ! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3179-UndeclaredVariableWarning-accessors-HernanWilkinson-2017Sep11-18h54m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3179] on 15 September 2017 at 3:38:52 pm'! - -Object subclass: #SHRange - instanceVariableNames: 'start end type blockDepth ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -!classDefinition: #SHRange category: #'Tools-Syntax Highlighting'! -Object subclass: #SHRange - instanceVariableNames: 'start end type blockDepth' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! -!SHParserST80 methodsFor: 'recording ranges' stamp: 'tween 4/28/2004 10:20' prior: 50370633! -rangeType: aSymbol start: s end: e - ^ranges add: (SHRange start: s end: e type: aSymbol)! ! -!SHTextStylerST80 methodsFor: 'private' stamp: 'jmv 12/30/2016 11:44:19' prior: 50370640! - setAttributesFromRanges: ranges - - formattedText removeAttributesThat: [ :attribute | attribute isForShout ]. - - "Optimize for mutation speed unless method is really large but with very few distict elements: - Source code that includes just big literals is better served by conventional Text+RunArray" - "Do it only if we are not breaking textModel!! (for instance, StyledTextEditor asks for formatting just sections, not whole #actualContents)." - formattedText == textModel actualContents ifTrue: [ - (formattedText size > 2000 and: [ ranges size < 50 ]) ifFalse: [ - formattedText _ formattedText optimizedForMutationSpeed. - textModel basicActualContents: formattedText ]]. - - ranges do: [ :range | - - "Smalltalk text styling" - (self attributesFor: range rangeType) ifNotNil: [ :attributes | - attributes do: [ :each | - formattedText addAttribute: each from: range start to: range end ]]. - - "Show as subscripts if appropriate." - classOrMetaClass ifNotNil: [ - classOrMetaClass theNonMetaClass lastUnderscoreMeansSubscript ifTrue: [ - (#( instVar classVar globalVar workspaceVar poolConstant - patternArg methodArg patternTempVar tempVar - blockPatternArg blockArg blockPatternTempVar blockTempVar - incompleteIdentifier undefinedIdentifier) pointsTo: range rangeType ) - ifTrue: [ - formattedText lastIndexOf: $_ startingAt: range end endingAt: range start do: [ :i | - formattedText addAttribute: ShoutTextEmphasis subscript from: i to: range end ] ]]]]! ! - -SHRange removeSelector: #blockDepth! - -SHRange removeSelector: #blockDepth! - -SHRange removeSelector: #blockDepth:! - -SHRange removeSelector: #blockDepth:! - -Object subclass: #SHRange - instanceVariableNames: 'start end type' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -!classDefinition: #SHRange category: #'Tools-Syntax Highlighting'! -Object subclass: #SHRange - instanceVariableNames: 'start end type' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3180-goBackWith-3172-JuanVuletich-2017Sep15-15h36m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3180] on 17 September 2017 at 9:22:40 pm'! - -Object subclass: #SHParserST80 - instanceVariableNames: 'classOrMetaClass source workspace arguments sourcePosition currentToken currentTokenFirst temporaries instanceVariables errorBlock currentTokenSourcePosition blockDepth bracketDepth ranges blockDepthsStartIndexes blockDepths ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -!classDefinition: #SHParserST80 category: #'Tools-Syntax Highlighting'! -Object subclass: #SHParserST80 - instanceVariableNames: 'classOrMetaClass source workspace arguments sourcePosition currentToken currentTokenFirst temporaries instanceVariables errorBlock currentTokenSourcePosition blockDepth bracketDepth ranges blockDepthsStartIndexes blockDepths' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! -!SHParserST80 methodsFor: 'accessing' stamp: 'jmv 9/13/2017 22:00:57'! - blockDepths - ^blockDepths! ! -!SHParserST80 methodsFor: 'accessing' stamp: 'jmv 9/13/2017 22:01:05'! - blockDepthsStartIndexes - ^blockDepthsStartIndexes! ! -!SHParserST80 methodsFor: 'accessing' stamp: 'jmv 9/13/2017 20:51:24'! - ranges - ^ ranges! ! -!SHTextStylerST80 methodsFor: 'private' stamp: 'jmv 9/17/2017 18:29:22'! - parseSetWorkspace: aBoolean - "Answer a collection of SHRanges by parsing aText. - When formatting it is not necessary to set the workspace, and this can make the parse take less time, so aBoolean specifies whether the parser should be given the workspace" - - parser ifNil: [parser _ SHParserST80 new]. - parser - workspace: (aBoolean ifTrue: [workspace]); - classOrMetaClass: classOrMetaClass; - source: formattedText asString. - parser parse! ! -!SHParserST80 methodsFor: 'parse support' stamp: 'jmv 9/17/2017 19:04:26' prior: 16901977! - enterBlock - blockDepth _ blockDepth + 1. - bracketDepth _ bracketDepth + 1. - blockDepths add: blockDepth. - blockDepthsStartIndexes add: sourcePosition-1! ! -!SHParserST80 methodsFor: 'parse support' stamp: 'jmv 9/17/2017 19:02:56' prior: 16901989! - leaveBlock - arguments removeKey: blockDepth ifAbsent: nil. - temporaries removeKey: blockDepth ifAbsent: nil. - blockDepth _ blockDepth - 1. - bracketDepth _ bracketDepth - 1. - blockDepths add: blockDepth. - blockDepthsStartIndexes add: sourcePosition! ! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 9/17/2017 19:03:23' prior: 16902395! - parse: isAMethod - "Parse the receiver's text. If isAMethod is true - then treat text as a method, if false as an - expression with no message pattern" - - self initializeInstanceVariables. - sourcePosition _ 1. - arguments _ Dictionary new. - temporaries _ Dictionary new. - blockDepth _ bracketDepth := 0. - blockDepths _ OrderedCollection with: blockDepth. - blockDepthsStartIndexes _ OrderedCollection with: sourcePosition. - ranges ifNil: [ ranges := OrderedCollection new: 100] ifNotNil: [ ranges reset]. - errorBlock _ [^false]. - [ - self scanNext. - isAMethod - ifTrue: [ - self parseMessagePattern. - self parsePragmaSequence]. - self parseMethodTemporaries. - isAMethod ifTrue: [self parsePragmaSequence]. - self parseStatementList. - currentToken ifNotNil: [self error] - ] ensure: [errorBlock _ nil]. - ^true! ! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 9/17/2017 19:05:25' prior: 50335035! - parseBacktick - self enterBlock. - self scanPast: #backtick. - currentTokenFirst == $| ifTrue: [self parseBlockTemporaries]. - self parseStatementList. - self failUnless: currentTokenFirst == $`. - self leaveBlock. - self scanPast: #backtick! ! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 9/17/2017 18:40:55' prior: 16902449! - parseBlock - self enterBlock. - self scanPast: #blockStart level: bracketDepth. - currentTokenFirst == $: ifTrue: [self parseBlockArguments]. - currentTokenFirst == $| ifTrue: [self parseBlockTemporaries]. - self parseStatementList. - self failUnless: currentTokenFirst == $]. - self leaveBlock. - self scanPast: #blockEnd level: bracketDepth.! ! -!SHTextStylerST80 methodsFor: 'private' stamp: 'jmv 9/17/2017 21:20:07' prior: 16903299! - privateStyle - - | alpha end start count startIndexes | - self parseSetWorkspace: true. - parser ranges ifNotNil: [ :ranges | - self setAttributesFromRanges: ranges ]. - - Preferences highlightBlockNesting ifTrue: [ - startIndexes _ parser blockDepthsStartIndexes. - count _ startIndexes size. - parser blockDepths withIndexDo: [ :depth :idx | - start _ startIndexes at: idx. - end _ idx = count ifTrue: [formattedText size] ifFalse: [ (startIndexes at: idx+1)-1]. - alpha _ depth / 16.0 min: 0.5. - formattedText - addAttribute: (ShoutTextBackgroundColor - color: (Theme current text alpha: alpha) ) from: start to: end ]]! ! -!SHTextStylerST80 methodsFor: 'private' stamp: 'jmv 9/17/2017 18:30:50' prior: 16903322! - replaceStringForRangesWithType: aSymbol with: aString - "Answer aText if no replacements, or a copy of aText with - each range with a type of aSymbol replaced by aString" - | toReplace increaseInLength | - - "We don't handle format and conversion for debuggers" - disableFormatAndConvert ifTrue: [ ^self ]. - - self parseSetWorkspace: false. - toReplace _ parser ranges select: [ :each | - each rangeType = aSymbol ]. - toReplace isEmpty ifTrue: [ ^self ]. - increaseInLength := 0. - - (toReplace asArray sort: [ :a :b | a start <= b start ]) - do: [ :each | | end start thisIncrease | - start := each start + increaseInLength. - end := each end + increaseInLength. - formattedText replaceFrom: start to: end with: aString. - thisIncrease := aString size - each length. - increaseInLength := increaseInLength + thisIncrease ]! ! - -SHTextStylerST80 removeSelector: #rangesSetWorkspace:! - -SHTextStylerST80 removeSelector: #rangesSetWorkspace:! - -SHParserST80 removeSelector: #rangesIn:classOrMetaClass:workspace:! - -SHParserST80 removeSelector: #rangesIn:classOrMetaClass:workspace:! - -Object subclass: #SHParserST80 - instanceVariableNames: 'classOrMetaClass source workspace arguments sourcePosition currentToken currentTokenFirst temporaries instanceVariables errorBlock currentTokenSourcePosition blockDepth bracketDepth ranges blockDepths blockDepthsStartIndexes' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -!classDefinition: #SHParserST80 category: #'Tools-Syntax Highlighting'! -Object subclass: #SHParserST80 - instanceVariableNames: 'classOrMetaClass source workspace arguments sourcePosition currentToken currentTokenFirst temporaries instanceVariables errorBlock currentTokenSourcePosition blockDepth bracketDepth ranges blockDepths blockDepthsStartIndexes' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3181-ShoutShowsBlockDepth-Take2-JuanVuletich-2017Sep17-21h16m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3180] on 17 September 2017 at 9:29:15 pm'! -!Preferences class methodsFor: 'shout' stamp: 'jmv 9/17/2017 21:27:39'! - backgroundColorFillsAllBackground - "I.e. do fill all whitespace (tabs and space at right of end of text) with backgroundColor" - ^ self - valueOfFlag: #backgroundColorFillsAllBackground - ifAbsent: [true]! ! -!MorphicScanner methodsFor: 'scanning' stamp: 'jmv 9/17/2017 21:27:43' prior: 50370352! - displayLine: textLine textTopLeft: textTopLeft leftInRun: leftInRun - "The call on the primitive (scanCharactersFrom:to:in:rightX:) will be interrupted according to an array of stop conditions passed to the scanner at which time the code to handle the stop condition is run and the call on the primitive continued until a stop condition returns true (which means the line has terminated). leftInRun is the # of characters left to scan in the current run; when 0, it is time to call setStopConditions." - - "textTopLeft is relative to the morph currently being drawn" - | stopCondition nowLeftInRun startIndex string lastPos x1 | - - topLeft _ textTopLeft. - line _ textLine. - lineY _ line top + textTopLeft y. - rightMargin _ line rightMargin + textTopLeft x. - lastIndex _ line first. - leftInRun <= 0 ifTrue: [ - self setFont. - self setStopConditions ]. - leftMargin _ (line leftMarginForAlignment: alignment) + textTopLeft x. - destX _ leftMargin. - destY _ lineY + line baseline - font ascent. - - textLine isEmptyLine ifTrue: [ - textLine paragraphStyle ifNotNil: [ :ps | - ps = paragraphStyle ifFalse: [ - foregroundColor _ defaultColor. - self setActualFont: ps font. - ps color ifNotNil: [ :color | self textColor: color ]. - alignment _ ps alignment. - paragraphStyle _ ps. - spaceWidth _ font widthOf: Character space. - tabWidth _ (font widthOf: $a) * 3. - xTable _ font xTable. - map _ font characterToGlyphMap. - self setStopConditions. - text ifNotNil: [ destY _ lineY + line baseline - font ascent ]]]. - self displayBulletIfAppropriateFor: textLine textLeft: textTopLeft x. - ^leftInRun ]. - - self displayBulletIfAppropriateFor: textLine textLeft: textTopLeft x. - - lastIndex _ line first. - leftInRun <= 0 - ifTrue: [nowLeftInRun _ text runLengthFor: lastIndex] - ifFalse: [nowLeftInRun _ leftInRun]. - runStopIndex _ lastIndex + (nowLeftInRun - 1) min: line last. - spaceCount _ 0. - string _ text string. - - self placeEmbeddedObject. - [ - startIndex _ lastIndex. - lastPos _ destX@destY. - stopCondition _ self - scanCharactersFrom: lastIndex to: runStopIndex - in: string rightX: rightMargin stopConditions: stopConditions - kern: font baseKern. - backgroundColor ifNotNil: [ - x1 _ destX. - (Preferences backgroundColorFillsAllBackground and: [startIndex > line last]) ifTrue: [ - x1 _ rightMargin ]. - canvas - fillRectangle: (lastPos corner: x1 @ (line bottom + textTopLeft y)) - color: backgroundColor. - (Preferences backgroundColorFillsAllBackground and: [stopCondition = #tab]) ifTrue: [ - canvas - fillRectangle: (destX @ lastPos y corner: self tabDestX @ (line bottom + textTopLeft y)) - color: backgroundColor ]]. - lastIndex >= startIndex ifTrue: [ - canvas - drawString: string - from: startIndex - to: lastIndex - at: lastPos - font: font - color: foregroundColor ]. - "see setStopConditions for stopping conditions for displaying." - (self perform: stopCondition) ifTrue: [ - "Number of characters remaining in the current run" - ^ runStopIndex - lastIndex ] - ] repeat! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3182-BlockHighlightFillAllBackground-JuanVuletich-2017Sep17-21h22m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3174] on 13 September 2017 at 6:23:32 am'! -!DateAndTime methodsFor: 'private' stamp: 'pb 9/13/2017 06:17:35'! - subtractDateAndtime: operand - "operand is a DateAndTime or a Duration" - - | lvalue rvalue | - offset = operand offset - ifTrue: [ - lvalue _ self. - rvalue _ operand ] - ifFalse: [ - lvalue _ self asUTC. - rvalue _ operand asUTC ]. - ^ Duration - seconds: (Time secondsInDay *(lvalue julianDayNumber - rvalue julianDayNumber)) + - (lvalue secondsSinceMidnight - rvalue secondsSinceMidnight) - nanoSeconds: lvalue nanoSecond - rvalue nanoSecond! ! -!DateAndTime methodsFor: 'private' stamp: 'pb 9/13/2017 06:17:41'! - subtractDuration: operand - "operand is a DateAndTime or a Duration" - - ^self + operand negated! ! -!DateAndTime methodsFor: 'double dispatching' stamp: 'pb 9/13/2017 06:20:33'! - subtractFrom: aDateAndTime - - ^ aDateAndTime subtractDateAndtime: self! ! -!Duration methodsFor: 'double dispatching' stamp: 'pb 9/13/2017 06:21:11'! - subtractFrom: aDateAndTimeOrDate - - ^aDateAndTimeOrDate subtractDuration: self! ! -!Timespan methodsFor: 'private' stamp: 'pb 9/13/2017 06:18:08'! - subtractDuration: aDuration - - ^self class classDefinesDuration - ifTrue: [ self class including: start - aDuration ] - ifFalse: [ self class starting: start - aDuration duration: duration ]! ! -!Timespan methodsFor: 'private' stamp: 'pb 9/13/2017 06:19:33'! - subtractTimespan: aTimespan - ^self start subtractDateAndtime: aTimespan start! ! -!Timespan methodsFor: 'double dispatching' stamp: 'pb 9/13/2017 06:21:26'! - subtractFrom: aTimespan - - ^ aTimespan subtractTimespan: self! ! -!DateAndTime methodsFor: 'ansi protocol' stamp: 'pb 9/13/2017 06:20:43' prior: 50342669! - - operand - "operand is a DateAndTime or a Duration. - Double dispatch" - - ^ operand subtractFrom: self! ! -!Timespan methodsFor: 'ansi protocol' stamp: 'pb 9/13/2017 06:20:49' prior: 50342675! - - aDurationOrTimespan - - ^ aDurationOrTimespan subtractFrom: self! ! -!ScrollBar methodsFor: 'geometry' stamp: 'pb 9/13/2017 06:22:10' prior: 16904581! - freeSliderRoom - "Answer the length or height of the free slider area, i.e. subtract the slider itself. - If we are really too short of room, lie a little bit. Answering at least 4, even when the - free space might be actually negative, makes the scrollbar somewhat usable." - - | buttonsRoom | - buttonsRoom _ Theme current minimalWindows ifTrue: [0] ifFalse: [self buttonExtent * 2]. - ^ ((self isHorizontal - ifTrue: [ extent x - slider morphWidth] - ifFalse: [ extent y - slider morphHeight]) - - (borderWidth * 2) - buttonsRoom) max: 4! ! - -Timespan removeSelector: #substractDuration:! - -Timespan removeSelector: #substractDuration:! - -Timespan removeSelector: #substractFrom:! - -Timespan removeSelector: #substractFrom:! - -Timespan removeSelector: #substractTimespan:! - -Timespan removeSelector: #substractTimespan:! - -Duration removeSelector: #substractFrom:! - -Duration removeSelector: #substractFrom:! - -DateAndTime removeSelector: #substractDateAndtime:! - -DateAndTime removeSelector: #substractDateAndtime:! - -DateAndTime removeSelector: #substractDuration:! - -DateAndTime removeSelector: #substractDuration:! - -DateAndTime removeSelector: #substractFrom:! - -DateAndTime removeSelector: #substractFrom:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3183-fix-typos-and-remove-Timespan-error-message-PhilBellalouna-2017Sep13-06h16m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3183] on 18 September 2017 at 6:29:35 pm'! -!Timespan methodsFor: 'private' stamp: 'jmv 9/18/2017 18:27:11'! - subtractMonth: aYear - - ^ self subtractTimespan: aYear! ! -!Timespan methodsFor: 'private' stamp: 'jmv 9/18/2017 17:22:56'! - subtractYear: aYear - - ^ self subtractTimespan: aYear! ! -!Month methodsFor: 'double dispatching' stamp: 'jmv 9/18/2017 18:26:57'! - subtractFrom: aTimespan - - ^ aTimespan subtractMonth: self! ! -!Month methodsFor: 'double dispatching' stamp: 'jmv 9/18/2017 18:26:44'! - subtractMonth: aMonth - "Months can be subtracted even they have different length." - - ^self start subtractDateAndtime: aMonth start! ! -!Year methodsFor: 'double displatching' stamp: 'jmv 9/18/2017 17:23:04'! - subtractFrom: aTimespan - - ^ aTimespan subtractYear: self! ! -!Year methodsFor: 'double displatching' stamp: 'jmv 9/18/2017 17:24:41'! - subtractYear: aYear - "Years can be subtracted even if one of them is leap and the other isn't." - - ^self start subtractDateAndtime: aYear start! ! -!Timespan methodsFor: 'private' stamp: 'jmv 9/18/2017 18:29:20' prior: 50371487! - subtractTimespan: aTimespan - " - (Month month: 'March' year: 2017) - (Month month: 'January' year: 2017) - (Month month: 'February' year: 2017) - (Month month: 'January' year: 2017) - - (Year yearNumber: 2016) - (Year yearNumber: 2015). - (Year yearNumber: 2017) - (Year yearNumber: 2016). - (Year yearNumber: 2017) - (Year yearNumber: 2015). - - (Year yearNumber: 2018) - (Date today). 'Error'. - " - aTimespan duration = self duration ifFalse: [ - self error: 'Can not subtract Timespans of different duration' ]. - - ^self start subtractDateAndtime: aTimespan start! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3184-AddTimespanErrorMessageBack-JuanVuletich-2017Sep18-18h25m-jmv.1.cs.st----! - -----SNAPSHOT----#(18 September 2017 11:06:50.303544 pm) Cuis5.0-3184-v3.image priorSource: 1252384! - -----QUIT----#(18 September 2017 11:07:10.670677 pm) Cuis5.0-3184-v3.image priorSource: 1278855! - -----STARTUP----#(24 September 2017 10:19:14.559677 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3184-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3184] on 19 September 2017 at 10:18:24 pm'! -!Number methodsFor: 'printing' stamp: 'jmv 9/19/2017 21:48:57'! - withBinaryUnitPrefixAndValue: aBlock - " - As in https://en.wikipedia.org/wiki/Binary_prefix - { 0.123456. 1.23456. 12.3456. 123.456. 1234.56. 12345.6. 123456. 1234560. 12345600 } do: [ :n | n withBinaryUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | {value printString, ' ', unitPrefixSymbol. unitPrefixName} print]] - " - | prefixIndex factor nameAndSymbol | - prefixIndex _ self log floor // 3. - prefixIndex _ prefixIndex min: 8 max: 0. - factor _ 1024 raisedToInteger: prefixIndex. - nameAndSymbol _ { - {''. ''}. - {'kibi'. 'Ki'}. - {'mebi'. 'Mi'}. - {'gibi'. 'Gi'}. - {'tebi'. 'Ti'}. - {'pebi'. 'Pi'}. - {'exbi'. 'Ei'}. - {'zebi'. 'Zi'}. - {'yobi'. 'Yi'} - } at: prefixIndex+1. - aBlock value: (self / factor) asIntegerOrFloat value: nameAndSymbol second value: nameAndSymbol first! ! -!Number methodsFor: 'printing' stamp: 'jmv 9/19/2017 21:48:12'! - withDecimalUnitPrefixAndValue: aBlock - " - As in https://en.wikipedia.org/wiki/Metric_prefix - { 0.00000123456. 0.0000123456. 0.000123456. 0.00123456. 0.0123456. 0.123456. 1.23456. 12.3456. 123.456. 1234.56. 12345.6. 123456. 1234560. 12345600 } do: [ :n | n withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | {value printString, ' ', unitPrefixSymbol. unitPrefixName} print]] - " - | prefixIndex factor nameAndSymbol | - prefixIndex _ self log floor // 3. - prefixIndex _ prefixIndex min: 6 max: -6. - factor _ 1000 raisedToInteger: prefixIndex. - nameAndSymbol _ { - {'atto'. 'a'}. - {'femto'. 'f'}. - {'pico'. 'p'}. - {'nano'. 'n'}. - {'micro'. 'µ'}. - {'milli'. 'm'}. - {''. ''}. - {'kilo'. 'k'}. - {'mega'. 'M'}. - {'giga'. 'G'}. - {'tera'. 'T'}. - {'peta'. 'P'}. - {'exa'. 'E'} - } at: prefixIndex+7. - aBlock value: self asFloat / factor value: nameAndSymbol second value: nameAndSymbol first! ! -!Integer methodsFor: 'benchmarks' stamp: 'jmv 9/19/2017 21:59:09' prior: 50343298! - tinyBenchmarks - "Report the results of running the two tiny Squeak benchmarks. - ar 9/10/1999: Adjusted to run at least 1 sec to get more stable results - 0 tinyBenchmarks - 292 MHz G3 Mac: 22,727,272 bytecodes/sec; 984,169 sends/sec - 400 MHz PII/Win98: 18,028,169 bytecodes/sec; 1,081,272 sends/sec - - RasPi2 - StackVM: 37,758,112 bytecodes/sec; 2,412,667 sends/sec - RasPi2- CogSSpur: 157,441,574 bytecodes/sec; 10,946,039 sends/sec - - C.H.I.P. (*1) - StackVM: 55,315,471 bytecodes/sec; 3,348,667 sends/sec - C.H.I.P. (*1) - CogSpur: 253,716,551 bytecodes/sec; 16,853,816 sends/sec - - RasPi3B - StackSpur 44,107,512 bytecodes/sec; 2,767,863 sends/sec - RasPi3B - CogSpur 281,783,159 bytecodes/sec; 16,404,381 sends/sec - - 1.66GHz Atom N450 - Cog: 244,274,809 bytecodes/sec; 28,795,277 sends/sec - 1.66GHz Atom N450 - CogSpur: 469,724,770 bytecodes/sec; 30,754,699 sends/sec - - 1.33GHz Atom 3735G - Cog: 326,114,649 bytecodes/sec; 34,985,976 sends/sec - 1.33GHz Atom 3735G - CogSpur: 632,098,765 bytecodes/sec; 33,692,910 sends/sec - - 1.5GHz AMD A4-5000 APU - Cog: 390,243,902 bytecodes/sec; 47,507,997 sends/sec - 1.5GHz AMD A4-5000 APU - CogSpur: 675,907,590 bytecodes/sec; 40,669,724 sends/sec - 1.5GHz AMD A4-5000 APU - CogSpur64: 659,368,963 bytecodes/sec; 50,338,916 sends/sec - - 2.3GHz Tegra (*2) - StackVM: 258,847,320 bytecodes/sec; 13,014,759 sends/sec - 2.3GHz Tegra (*2) - CogSpur: 1,083,024,854 bytecodes/sec; 64,289,750 sends/sec - - 3.1GHz Core i3-2100 - Cog: 1,203,290,246 bytecodes/sec; 165,723,327 sends/sec - 3.1GHz Core i3-2100 - CogSpur: 2,042,892,768 bytecodes/sec; 127,837,794 sends/sec - - 2.70GHz Core i5-6400 -CogSpur64 3,162,934,362 bytecodes/sec; 243,321,293 sends/sec - - (*1) C.H.I.P. $9 Computer [Next Thing Co], Allwinner R8 Single-Core ARM Cortex-A8 - 1 GHz - (*2) ACER Chromebook CB5-311 - NVIDIA Tegra K1 Quad-Core ARM Cortex-A15 'r3' - 2.3 GHz - - It is interesting to note that Spur for the first time brings ARM hardware (RasPi and C.H.I.P.) into a 'Morphic is confortable and nice to use' level of performance. - " - | t1 t2 r n1 n2 | - n1 _ 1. - [ - t1 _ Time millisecondsToRun: [n1 benchmark]. - t1 < 1000] - whileTrue: [n1 _ n1 * 2]. "Note: #benchmark's runtime is about O(n)" - - n2 _ 28. - [ - t2 _ Time millisecondsToRun: [r _ n2 benchFib]. - t2 < 1000] - whileTrue: [n2 _ n2 + 1]. - "Note: #benchFib's runtime is about O(k^n), - where k is the golden number = (1 + 5 sqrt) / 2 = 1.618...." - - ^String streamContents: [ :strm | - (n1 * 500000 * 1000) // t1 withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixName; - nextPutAll: 'Bytecodes/second; ' ]. - (r * 1000) // t2 withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixName; - nextPutAll: 'Sends/second' ]]! ! -!Integer methodsFor: 'printing' stamp: 'jmv 9/19/2017 21:42:27' prior: 16860030! - printStringAsBytes - "Answer a terse, easily-readable representation of this Integer reprsenting a number of bytes. Useful for file-browsers. - 123 printStringAsBytes - 1024 printStringAsBytes - (12*1024) printStringAsBytes - (1024*1024) printStringAsBytes - (1024*1024*1024) printStringAsBytes - (1024*1024*1024*1024) printStringAsBytes - (30 factorial) printStringAsBytes - - See https://en.wikipedia.org/wiki/Kibibyte - See #printStringAsBytesDecimal - " - self withBinaryUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - ^String streamContents: [ :strm | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixSymbol; - nextPut: $B]]! ! -!Integer methodsFor: 'printing' stamp: 'jmv 9/19/2017 21:48:23' prior: 16860061! - printStringAsBytesDecimal - "Answer a terse, easily-readable representation of this Integer reprsenting a number of bytes. Useful for file-browsers. - 123 printStringAsBytesDecimal - (12*1000) printStringAsBytesDecimal - (1000*1000) printStringAsBytesDecimal - - 1024 printStringAsBytesDecimal - (12*1024) printStringAsBytesDecimal - (1024*1024) printStringAsBytesDecimal - (1024*1024*1024) printStringAsBytesDecimal - (1024*1024*1024*1024) printStringAsBytesDecimal - (30 factorial) printStringAsBytesDecimal - - See https://en.wikipedia.org/wiki/Kibibyte - See #printStringAsBytes - " - self withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - ^String streamContents: [ :strm | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixSymbol; - nextPut: $B]]! ! -!BlockClosure methodsFor: 'evaluating' stamp: 'jmv 9/19/2017 22:16:51' prior: 16787838! - bench - "See how many times I can value in 5 seconds. I'll answer a meaningful description. - [ Float pi printString ] bench print. - [ 80000 factorial printString ] bench print. - " - - | startTime endTime count run | - count _ 0. - run _ true. - [ (Delay forSeconds: 5) wait. run _ false ] forkAt: Processor timingPriority - 1. - startTime _ Time localMillisecondClock. - [ run ] whileTrue: [ self value. count _ count + 1 ]. - endTime _ Time localMillisecondClock. - count = 1 - ifTrue: [ - (endTime - startTime) / 1000 withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - ^String streamContents: [ :strm | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixSymbol; - nextPutAll: ' seconds per run']] - ] - ifFalse: [ - (count * 1000) / (endTime - startTime) withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - ^String streamContents: [ :strm | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixSymbol; - nextPutAll: ' runs per second' ]] - ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3185-benchImprovements-NumberUnitprefixPrint-JuanVuletich-2017Sep19-20h14m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3185] on 19 September 2017 at 10:42:44 pm'! -!SHTextStylerST80 methodsFor: 'private' stamp: 'jmv 9/19/2017 22:40:08' prior: 50371238! - privateStyle - - | alpha end start count startIndexes c hue | - self parseSetWorkspace: true. - parser ranges ifNotNil: [ :ranges | - self setAttributesFromRanges: ranges ]. - - Preferences highlightBlockNesting ifTrue: [ - startIndexes _ parser blockDepthsStartIndexes. - count _ startIndexes size. - parser blockDepths withIndexDo: [ :depth :idx | - start _ startIndexes at: idx. - end _ idx = count ifTrue: [formattedText size] ifFalse: [ (startIndexes at: idx+1)-1]. - alpha _ depth / 10.0 min: 1.0. - hue _ depth * 60. - c _ Color h: hue s: 0.2 v: 0.5 alpha: alpha. - formattedText - addAttribute: (ShoutTextBackgroundColor - color: c ) from: start to: end ]]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3186-BlockNestingHighlightWithColor-JuanVuletich-2017Sep19-22h41m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3186] on 24 September 2017 at 10:13:16 pm'! -!Character class methodsFor: 'accessing untypeable characters' stamp: 'jmv 9/24/2017 20:34:05'! - shortUnderscore - "Answer the Character representing very short (or invisible) underscore. - Used to optionally mark subscript in code." - - ^ Character numericValue: 127! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'jmv 9/24/2017 20:13:24' prior: 16801432! - infinity - " - Character infinity - " - ^ $…! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 9/24/2017 22:08:45' prior: 16914742! - makeCrInvisible - | glyph | - glyph _ self glyphAt: Character cr. - glyph fillWhite. - self glyphAt: Character cr put: glyph! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 9/24/2017 22:07:50' prior: 50359147! - makeCrVisible - | glyph | - glyph _ self glyphAt: (Character numericValue: 182). - glyph border: glyph boundingBox width: 1 fillColor: Color blue. -" glyph _ glyph reverse." - self glyphAt: Character cr put: glyph! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 9/24/2017 22:09:18' prior: 16914761! - makeLfInvisible - | glyph | - glyph _ self glyphAt: Character lf. - glyph fillWhite. - self glyphAt: Character lf put: glyph! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 9/24/2017 22:07:44' prior: 50359159! - makeLfVisible - | glyph | - glyph _ self glyphAt: (Character numericValue: 163). - glyph border: glyph boundingBox width: 1 fillColor: Color blue. -" glyph _ glyph reverse." - self glyphAt: Character lf put: glyph! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 9/24/2017 20:24:03' prior: 16914780! - makeTabInvisible - self characterToGlyphMap. - characterToGlyphMap at: 10 put: (10 < minAscii ifFalse: [10] ifTrue: [maxAscii+1])! ! -!StrikeFont methodsFor: 'building' stamp: 'jmv 9/24/2017 20:49:47' prior: 16914852! - buildFromForm: allGlyphs data: data name: aString - - | x shortUnderscore firstGlyphInFiles | - pointSize _ data first asNumber. - ascent _ data second asNumber. - descent _ data third asNumber. - - firstGlyphInFiles _ 257-(data size-3). - minAscii _ 1. - maxAscii _ 255. - name _ aString. - type _ 0. "ignored for now" - superscript _ ascent - descent // 3. - subscript _ descent - ascent // 3. - emphasis _ 0. - - xTable _ (Array new: 258) atAllPut: 0. - maxWidth _ 0. - glyphs _ allGlyphs depth > 16 ifTrue: [ allGlyphs asFormOfDepth: 16 ] ifFalse: [ allGlyphs ]. - x _ 0. - 4 to: data size do: [ :i | - x _ (data at: i) asNumber. - xTable at: i+firstGlyphInFiles+1-4 put: x]. - xTable at: 258 put: x. - self reset. - derivativeFonts _ nil. - - self makeCrVisible. - - "Replace glyph for 127 (a box) with a short version of the underscore (used to optionally mark subscript in code)" - shortUnderscore _ self glyphAt: $_. - shortUnderscore _ shortUnderscore copy: (0@0 extent: 1@shortUnderscore height). - self glyphAt: (Character numericValue: 127) put: shortUnderscore! ! -!StrikeFont class methodsFor: 'instance creation' stamp: 'jmv 9/24/2017 20:08:30' prior: 16915044! - create: fontName size: pointSize bold: includeBold italic: includeItalic boldItalic: includeBoldItalic - " - self create: 'DejaVu Sans Mono' size: 12 bold: true italic: true boldItalic: true - " - | folder basename base bold oblique boldOblique point | - folder _ DirectoryEntry smalltalkImageDirectory / 'AdditionalFontData'. - basename _ fontName = 'DejaVu' ifTrue: ['DejaVu Sans'] ifFalse: [fontName]. - point _ pointSize asString. - base _ [ (StrikeFont new - buildFromForm: ((Form fromFileEntry: folder // (basename, '-0-', point, '.bmp')) asFormOfDepth: 16) - data: (folder // (basename, '-0-', point, '.txt')) fileContents substrings - name: fontName, ' ', point) - pointSize: pointSize ] on: FileDoesNotExistException do: [ : ex | ex print. nil ]. - includeBold ifTrue: [ - bold _ [ (StrikeFont new - buildFromForm: ((Form fromFileEntry: folder // (basename, '-1-', point, '.bmp')) asFormOfDepth: 16) - data: (folder // (basename, '-1-', point, '.txt')) fileContents substrings - name: fontName, ' ', point, 'B') - emphasis: 1; - pointSize: pointSize ] on: FileDoesNotExistException do: [ : ex | ex print. nil ]]. - includeItalic ifTrue: [ - oblique _ [ (StrikeFont new - buildFromForm: ((Form fromFileEntry: folder // (basename, '-2-', point, '.bmp')) asFormOfDepth: 16) - data: (folder // (basename, '-2-', point, '.txt')) fileContents substrings - name: fontName, ' ', point, 'I') - emphasis: 2; - pointSize: pointSize ] on: FileDoesNotExistException do: [ : ex | ex print. nil ]]. - includeBoldItalic ifTrue: [ - boldOblique _ [ (StrikeFont new - buildFromForm: ((Form fromFileEntry: folder // (basename, '-3-', point, '.bmp')) asFormOfDepth: 16) - data: (folder // (basename, '-3-', point, '.txt')) fileContents substrings - name: fontName, ' ', point, 'BI') - emphasis: 3; - pointSize: pointSize ] on: FileDoesNotExistException do: [ : ex | ex print. nil ]]. - "We have a regular, base font. Make others derivatives of it" - base ifNotNil: [ - bold ifNotNil: [ - base derivativeFont: bold at: 1 ]. - oblique ifNotNil: [ - base derivativeFont: oblique at: 2]. - boldOblique ifNotNil: [ - base derivativeFont: boldOblique at: 3 ]. - ^base ]. - "We don't have a base, regular font." - oblique ifNotNil: [ - oblique emphasis: 0. "Hacky. Non regular fonts can not have derivatives. Should change this?" - bold ifNotNil: [ - oblique derivativeFont: bold at: 1 ]. - boldOblique ifNotNil: [ - oblique derivativeFont: boldOblique at: 3 ]. - ^oblique ]. - bold ifNotNil: [ - bold emphasis: 0. "Hacky. Non regular fonts can not have derivatives. Should change this?" - boldOblique ifNotNil: [ - bold derivativeFont: boldOblique at: 3 ]. - ^bold ]. - boldOblique ifNotNil: [ - ^boldOblique ]. - ^nil! ! -!StrikeFont class methodsFor: 'instance creation' stamp: 'jmv 9/24/2017 20:15:42' prior: 16915129! - install: aString -" -StrikeFont install: 'DejaVu'. -StrikeFont buildLargerPunctuation: 'DejaVu'. -Character initialize - -StrikeFont install: 'DejaVu Sans Mono'. -StrikeFont buildLargerPunctuation: 'DejaVu Sans Mono'. -Character initialize -" -" -StrikeFont install: 'Inconsolata' -StrikeFont install: '#PilGi' -StrikeFont install: 'Optima' -StrikeFont install: 'Herculanum' -StrikeFont install: 'Papyrus' -StrikeFont install: 'Handwriting - Dakota' -StrikeFont install: 'Times New Roman' -StrikeFont install: 'Apple Chancery' -StrikeFont install: 'Cochin' -StrikeFont install: 'Cracked' -StrikeFont install: 'Zapfino' -StrikeFont install: 'Brush Script MT' -StrikeFont install: 'Chalkboard' -" - | fontDict | - fontDict _ Dictionary new. - #(5 6 7 8 9 10 11 12 14 17 22) do: [ :s | - (self create: aString size: s bold: true italic: true boldItalic: false) ifNotNil: [ :font | - fontDict - at: s - put: font ]]. - fontDict notEmpty ifTrue: [ - AvailableFonts at: aString put: fontDict ]. - Preferences restoreDefaultFonts! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3187-FontsFixes-JuanVuletich-2017Sep24-22h12m-jmv.1.cs.st----! - -StrikeFont install: 'DejaVu'. -StrikeFont buildLargerPunctuation: 'DejaVu'. -Character initialize! - -----SNAPSHOT----#(24 September 2017 10:19:32.375884 pm) Cuis5.0-3187-v3.image priorSource: 1278956! - -----QUIT----#(24 September 2017 10:19:46.345396 pm) Cuis5.0-3187-v3.image priorSource: 1295660! - -----STARTUP----#(24 September 2017 10:28:07.581656 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3187-v3.image! - - -actualContents edit! - -----QUIT----#(24 September 2017 10:28:53.042172 pm) Cuis5.0-3187-v3.image priorSource: 1295761! - -----STARTUP----#(1 October 2017 4:33:15.04294 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3187-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3187] on 25 September 2017 at 10:56:05 pm'! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 9/25/2017 20:23:26'! - defaultFontFamily - "Answer the default font family name" - - ^self parameters at: #defaultFontFamily ifAbsentPut: [ AbstractFont familyNames first ]! ! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 9/25/2017 20:33:41'! - setDefaultFont: fontFamilyName spec: defaultFontsSpec - - | font | - defaultFontsSpec do: [ :triplet | - font _ AbstractFont familyName: fontFamilyName pointSize: triplet second. - font ifNil: [ font _ AbstractFont default ]. - triplet size > 2 ifTrue: [ - font _ font emphasized: triplet third ]. - self - perform: triplet first - with: font]! ! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 9/25/2017 20:22:40'! - setDefaultFontFamilyTo: aString - - self parameters at: #defaultFontFamily put: aString! ! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 9/25/2017 20:40:23' prior: 16892936! - restoreDefaultFonts - "Since this is called from menus, we can take the opportunity to prompt for missing font styles. - Preferences restoreDefaultFonts - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 9) - (setListFontTo: 9) - (setMenuFontTo: 10) - (setWindowTitleFontTo: 12) - (setCodeFontTo: 9) - (setButtonFontTo: 9))! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/25/2017 20:40:14' prior: 16893908! - bigFonts - "Sets not only fonts but other GUI elements - to fit high resolution or large screens - Preferences bigFonts - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 11) - (setListFontTo: 11) - (setMenuFontTo: 12) - (setWindowTitleFontTo: 14) - (setCodeFontTo: 11) - (setButtonFontTo: 11)). - Preferences enable: #biggerCursors! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/25/2017 20:40:20' prior: 16893923! - hugeFonts - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences hugeFonts - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 17) - (setListFontTo: 17) - (setMenuFontTo: 17) - (setWindowTitleFontTo: 22) - (setCodeFontTo: 17) - (setButtonFontTo: 17)). - Preferences enable: #biggerCursors! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/25/2017 20:40:26' prior: 16893939! - smallFonts - "Sets not only fonts but other GUI elements - to fit low resolution or small screens - Preferences smallFonts - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 8) - (setListFontTo: 8) - (setMenuFontTo: 8) - (setWindowTitleFontTo: 11) - (setCodeFontTo: 8) - (setButtonFontTo: 8)). - Preferences disable: #biggerCursors! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/25/2017 20:40:30' prior: 16893954! - standardFonts - "Sets not only fonts but other GUI elements - to fit regular resolution and size screens - Preferences standardFonts - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 9) - (setListFontTo: 9) - (setMenuFontTo: 10) - (setWindowTitleFontTo: 12) - (setCodeFontTo: 9) - (setButtonFontTo: 9)). - Preferences disable: #biggerCursors! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/25/2017 20:40:32' prior: 16893970! - tinyFonts - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences tinyFonts - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 7) - (setListFontTo: 5) - (setMenuFontTo: 5) - (setWindowTitleFontTo: 7) - (setCodeFontTo: 5) - (setButtonFontTo: 5)). - Preferences disable: #biggerCursors! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/25/2017 20:40:36' prior: 16893986! - veryBigFonts - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences veryBigFonts - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 14) - (setListFontTo: 14) - (setMenuFontTo: 14) - (setWindowTitleFontTo: 17) - (setCodeFontTo: 14) - (setButtonFontTo: 14)). - Preferences enable: #biggerCursors! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/25/2017 20:40:39' prior: 16894002! - verySmallFonts - "Sets not only fonts but other GUI elements - to fit low resolution or small screens - Preferences verySmallFonts - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 8) - (setListFontTo: 7) - (setMenuFontTo: 7) - (setWindowTitleFontTo: 9) - (setCodeFontTo: 7) - (setButtonFontTo: 7)). - Preferences disable: #biggerCursors! ! -!AbstractFont methodsFor: 'displaying' stamp: 'jmv 9/25/2017 20:24:32' prior: 16777361! - on: aGrafPort displayString: aString from: firstIndex to: lastIndex at: p color: color - "Answer last affected pixel position - Answer nil if nothing was done" - - | char fallbackFont x y answer | - fallbackFont _ (AbstractFont - familyName: Preferences defaultFontFamily - aroundPointSize: self pointSize*0.9) - emphasized: self emphasis. - x _ p x. - y _ p y. - firstIndex to: lastIndex do: [ :i | - char _ aString at: i. - answer _ aGrafPort displayString: char asString from: 1 to: 1 at: x@y strikeFont: fallbackFont color: color. - x _ x + (self widthOf: char) ]. - ^answer! ! -!AbstractFont class methodsFor: 'instance accessing' stamp: 'jmv 9/25/2017 20:25:27' prior: 16777395! - familyName: aString aroundPointSize: aNumber - " - AbstractFont familyName: Preferences defaultFontFamily aroundPointSize: 120 - " - | familyDictionary found | - familyDictionary _ AvailableFonts at: aString ifAbsent: [^nil]. - ^familyDictionary at: aNumber ifAbsent: [ - familyDictionary do: [ :font | - (found isNil or: [ (found pointSize - aNumber) abs > (font pointSize - aNumber) abs ]) - ifTrue: [ found _ font ]]. - found - ]! ! -!AbstractFont class methodsFor: 'instance accessing' stamp: 'jmv 9/25/2017 20:25:34' prior: 16777411! - familyName: aString pointSize: aNumber - " - AbstractFont familyName: Preferences defaultFontFamily pointSize: 12 - " - | familyDictionary | - familyDictionary _ AvailableFonts at: aString ifAbsent: [^nil]. - ^familyDictionary at: aNumber ifAbsent: nil! ! -!AbstractFont class methodsFor: 'instance accessing' stamp: 'jmv 9/25/2017 20:25:58' prior: 16777469! -pointSizesFor: aString - " - AbstractFont pointSizesFor: Preferences defaultFontFamily - " - | familyDictionary | - familyDictionary _ AvailableFonts at: aString ifAbsent: [^#()]. - ^familyDictionary keys sort! ! -!AbstractFont class methodsFor: 'class initialization' stamp: 'jmv 9/25/2017 20:25:47' prior: 16777478! - initialize - "AvailableFonts is a dictionary whose keys are family names, such as 'DejaVu Sans' and values are family dictionaries - family dictionaries have keys that are integers (point sizes such as 10 or 12) and values instances of the Font hierarcy - - Fonts with emphasis (such as bold or italic) are derivative fonts of the one found in the family dictionary" - - AvailableFonts _ Dictionary new! ! -!StrikeFont methodsFor: 'accessing' stamp: 'jmv 9/25/2017 20:45:55' prior: 16914200! - baseKern - "Return the base kern value to be used for all characters. - What follows is some 'random' text used to visually adjust this method. - HaHbHcHdHeHfHgHhHiHjHkHlHmHnHoHpHqHrHsHtHuHvHwHxHyHzH - HAHBHCHDHEHFHGHHHIHJHKHLHMHNHOHPHQHRHSHTHUHVHWHXHYHXZH - wok yuyo wuwu vuvu rucu tucu WUWU VUVU huevo HUEVO to - k y mate runico ridiculo ARABICO AAAAA TOMATE - TUTU - tatadalajafua - abacadafagahaqawaearatayauaiaoapasadafagahajakalazaxacavabanama - kUxUxa - q?d?h?l?t?f?j?" - - | italic baseKern | - italic _ self isItalic. - - "Assume synthetic will not affect kerning (i.e. synthetic italics are not used)" - "After all, DejaVu Sans are the only StrikeFonts used in Cuis..." -" self familyName = 'DejaVu Sans' - ifTrue: [" - baseKern _ (italic or: [ pointSize < 9 ]) - ifTrue: [ -1 ] - ifFalse: [ 0 ]. - pointSize >= 13 ifTrue: [ - baseKern _ baseKern +1 ]. - pointSize >= 20 ifTrue: [ - baseKern _ baseKern +1 ]"] - ifFalse: [ - baseKern _ pointSize < 12 - ifTrue: [ -1 ] - ifFalse: [ 0 ]. - italic ifTrue: [ - baseKern _ baseKern - 1]]". - - "If synthetic italic" - "See makeItalicGlyphs" - (self isSynthetic and: [ italic and: [ self isBold ]]) ifTrue: [ - baseKern _ baseKern - ((self height-1-self ascent+4)//4 max: 0) - - (((self ascent-5+4)//4 max: 0)) ]. - ^baseKern! ! -!StrikeFont methodsFor: 'synthetic derivatives' stamp: 'jmv 9/25/2017 20:44:21' prior: 16914975! - syntheticSubscript - "Build and answer a derivative that is Subscript." - - | derivative | - derivative _ ((AbstractFont familyName: Preferences defaultFontFamily aroundPointSize: pointSize * 0.58) - emphasized: emphasis) - copy. - derivative useShortUnderscore. - ^ derivative - -" -StrikeFont allInstances do: [ :a | a reset ]. -('Hi ', (Text string: 'there' attribute: TextEmphasis superscript), ' how ', (Text string: 'are' attribute: TextEmphasis subscript), ' you?') edit. - -que todos, menos estos, tengan superscript y subscript en cero. Y en estos, apropiado. y en 'aca' usarlo. y listo -"! ! -!StrikeFont methodsFor: 'synthetic derivatives' stamp: 'jmv 9/25/2017 20:44:26' prior: 16914996! - syntheticSuperscript - "Build and answer a derivative that is Superscript." - - | derivative | - derivative _ ((AbstractFont familyName: Preferences defaultFontFamily aroundPointSize: pointSize * 0.58) - emphasized: emphasis) - copy. - derivative name: self name , 'Sup'. - ^ derivative - -" -StrikeFont allInstances do: [ :a | a reset ]. -('Hi ', (Text string: 'there' attribute: TextEmphasis superscript), ' how ', (Text string: 'are' attribute: TextEmphasis subscript), ' you?') edit. -"! ! -!StrikeFont class methodsFor: 'instance creation' stamp: 'jmv 9/25/2017 20:17:15' prior: 50372011! - create: fontName size: pointSize bold: includeBold italic: includeItalic boldItalic: includeBoldItalic - " - self create: 'DejaVu Sans Mono' size: 12 bold: true italic: true boldItalic: true - " - | folder base bold oblique boldOblique point | - folder _ DirectoryEntry smalltalkImageDirectory / 'AdditionalFontData'. - point _ pointSize asString. - base _ [ (StrikeFont new - buildFromForm: ((Form fromFileEntry: folder // (fontName, '-0-', point, '.bmp')) asFormOfDepth: 16) - data: (folder // (fontName, '-0-', point, '.txt')) fileContents substrings - name: fontName, ' ', point) - pointSize: pointSize ] on: FileDoesNotExistException do: [ : ex | ex print. nil ]. - includeBold ifTrue: [ - bold _ [ (StrikeFont new - buildFromForm: ((Form fromFileEntry: folder // (fontName, '-1-', point, '.bmp')) asFormOfDepth: 16) - data: (folder // (fontName, '-1-', point, '.txt')) fileContents substrings - name: fontName, ' ', point, 'B') - emphasis: 1; - pointSize: pointSize ] on: FileDoesNotExistException do: [ : ex | ex print. nil ]]. - includeItalic ifTrue: [ - oblique _ [ (StrikeFont new - buildFromForm: ((Form fromFileEntry: folder // (fontName, '-2-', point, '.bmp')) asFormOfDepth: 16) - data: (folder // (fontName, '-2-', point, '.txt')) fileContents substrings - name: fontName, ' ', point, 'I') - emphasis: 2; - pointSize: pointSize ] on: FileDoesNotExistException do: [ : ex | ex print. nil ]]. - includeBoldItalic ifTrue: [ - boldOblique _ [ (StrikeFont new - buildFromForm: ((Form fromFileEntry: folder // (fontName, '-3-', point, '.bmp')) asFormOfDepth: 16) - data: (folder // (fontName, '-3-', point, '.txt')) fileContents substrings - name: fontName, ' ', point, 'BI') - emphasis: 3; - pointSize: pointSize ] on: FileDoesNotExistException do: [ : ex | ex print. nil ]]. - "We have a regular, base font. Make others derivatives of it" - base ifNotNil: [ - bold ifNotNil: [ - base derivativeFont: bold at: 1 ]. - oblique ifNotNil: [ - base derivativeFont: oblique at: 2]. - boldOblique ifNotNil: [ - base derivativeFont: boldOblique at: 3 ]. - ^base ]. - "We don't have a base, regular font." - oblique ifNotNil: [ - oblique emphasis: 0. "Hacky. Non regular fonts can not have derivatives. Should change this?" - bold ifNotNil: [ - oblique derivativeFont: bold at: 1 ]. - boldOblique ifNotNil: [ - oblique derivativeFont: boldOblique at: 3 ]. - ^oblique ]. - bold ifNotNil: [ - bold emphasis: 0. "Hacky. Non regular fonts can not have derivatives. Should change this?" - boldOblique ifNotNil: [ - bold derivativeFont: boldOblique at: 3 ]. - ^bold ]. - boldOblique ifNotNil: [ - ^boldOblique ]. - ^nil! ! -!StrikeFont class methodsFor: 'instance creation' stamp: 'jmv 9/25/2017 20:48:55' prior: 50372099! - install: aString -" -StrikeFont install: 'DejaVu Sans'. -StrikeFont buildLargerPunctuation: 'DejaVu Sans'. -Preferences setDefaultFontFamilyTo: 'DejaVu Sans'. -Preferences standardFonts. -Character initialize. -" -" -StrikeFont install: 'DejaVu Sans Mono'. -Preferences setDefaultFontFamilyTo: 'DejaVu Sans Mono'. -Preferences bigFonts. -Character initialize. -" -" -StrikeFont install: 'Inconsolata' -StrikeFont install: '#PilGi' -StrikeFont install: 'Optima' -StrikeFont install: 'Herculanum' -StrikeFont install: 'Papyrus' -StrikeFont install: 'Handwriting - Dakota' -StrikeFont install: 'Times New Roman' -StrikeFont install: 'Apple Chancery' -StrikeFont install: 'Cochin' -StrikeFont install: 'Cracked' -StrikeFont install: 'Zapfino' -StrikeFont install: 'Brush Script MT' -StrikeFont install: 'Chalkboard' -" - | fontDict | - fontDict _ Dictionary new. - #(5 6 7 8 9 10 11 12 14 17 22) do: [ :s | - (self create: aString size: s bold: true italic: true boldItalic: false) ifNotNil: [ :font | - fontDict - at: s - put: font ]]. - fontDict notEmpty ifTrue: [ - AvailableFonts at: aString put: fontDict ]. - Preferences restoreDefaultFonts! ! -!StrikeFont class methodsFor: 'removing' stamp: 'jmv 9/25/2017 20:41:27' prior: 16915172! - removeForPDA -" -StrikeFont removeForPDA -" - | familyDict | - familyDict _ AvailableFonts at: Preferences defaultFontFamily. - familyDict keys do: [ :k | - (#(5 6 7 8 9) includes: k) - ifTrue: [ - (familyDict at: k) derivativeFont: nil at: 0 ] - ifFalse: [ - familyDict removeKey: k ]]. - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 8) - (setListFontTo: 6) - (setMenuFontTo: 7) - (setWindowTitleFontTo: 9) - (setCodeFontTo: 7) - (setButtonFontTo: 7))! ! -!StrikeFont class methodsFor: 'removing' stamp: 'jmv 9/25/2017 20:42:25' prior: 16915190! - removeMostFonts -" -StrikeFont removeMostFonts -" - | familyDict | - Preferences disable: #italicsInShout. - SHTextStylerST80 initialize. - familyDict _ AvailableFonts at: Preferences defaultFontFamily. - familyDict keys do: [ :k | - (#(8 10 12) includes: k) - ifTrue: [ - (familyDict at: k) derivativeFont: nil at: 0 ] - ifFalse: [ - familyDict removeKey: k ]]. - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 10) - (setListFontTo: 10) - (setMenuFontTo: 10) - (setWindowTitleFontTo: 12) - (setCodeFontTo: 10) - (setButtonFontTo: 10))! ! -!StrikeFont class methodsFor: 'removing' stamp: 'jmv 9/25/2017 20:42:49' prior: 16915211! - removeSomeFonts -" -StrikeFont removeSomeFonts -" - | familyDict | - familyDict _ AvailableFonts at: Preferences defaultFontFamily. - familyDict keys do: [ :k | - "No boldItalic for the followint" - (#(5 6 7 8 9 10 11 12 14 17 22) includes: k) - ifTrue: [ (familyDict at: k) derivativeFont: nil at: 3 ]. - "No derivatives at all for the following" - (#() includes: k) - ifTrue: [ (familyDict at: k) derivativeFont: nil at: 0 ]. - "Sizes to keep" - (#(5 6 7 8 9 10 11 12 14 17 22) includes: k) - ifFalse: [ familyDict removeKey: k ]]. - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 9) - (setListFontTo: 9) - (setMenuFontTo: 10) - (setWindowTitleFontTo: 12) - (setCodeFontTo: 9) - (setButtonFontTo: 9))! ! -!StrikeFont class methodsFor: 'character shapes' stamp: 'jmv 9/25/2017 20:45:01' prior: 16915250! - buildLargerPunctuation: familyName - " - StrikeFont buildLargerPunctuation: 'DejaVu Sans' - " - | form form2 f10 f11 f12 f9 | - - f9 _ AbstractFont familyName: familyName pointSize: 9. - f10 _ AbstractFont familyName: familyName pointSize: 10. - f11 _ AbstractFont familyName: familyName pointSize: 11. - f12 _ AbstractFont familyName: familyName pointSize: 12. - - - f9 takeGlyphFor: $. from: $. in: f12. - f9 takeGlyphFor: $, from: $, in: f12. - - form _ f9 glyphAt: $.. - form copy: (0@9 extent: 3@14) from: form to: 0@4 rule: Form and. - f9 glyphAt: $: put: form. - - form _ f9 glyphAt: $,. - form2 _ f9 glyphAt: $.. - form copy: (0@9 extent: 3@14) from: form2 to: 1@4 rule: Form and. - f9 glyphAt: $; put: form. - - - - f10 takeGlyphFor: $. from: $. in: f12. - f10 takeGlyphFor: $, from: $, in: f12. - - form _ f10 glyphAt: $. . - form copy: (0@9 extent: 3@14) from: form to: 0@4 rule: Form and. - f10 glyphAt: $: put: form. - - form _ f10 glyphAt: $,. - form2 _ f10 glyphAt: $.. - form copy: (0@9 extent: 3@14) from: form2 to: 1@4 rule: Form and. - f10 glyphAt: $; put: form. - - - - f11 takeGlyphFor: $. from: $. in: f12. - f11 takeGlyphFor: $, from: $, in: f12. - f11 takeGlyphFor: $: from: $: in: f12. - f11 takeGlyphFor: $; from: $; in: f12! ! -!UpdatingStringMorph class methodsFor: 'new-morph participation' stamp: 'jmv 9/25/2017 20:44:33' prior: 50337167! - initializedInstance - "Answer a digital clock" - - | newInst | - newInst := self - contents: '' - font: (AbstractFont familyName: Preferences defaultFontFamily pointSize: 22) - emphasis: AbstractFont boldCode. - newInst - stepTime: 500; "half a second" - target: [String streamContents: [ :strm | DateAndTime now printHMSOn: strm]] ; - getSelector: #value. - - ^ newInst! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3188-FontInstallEnhancements-JuanVuletich-2017Sep25-20h30m-jmv.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3188] on 29 September 2017 at 5:43:16 pm'! -!Form methodsFor: 'bordering' stamp: 'jmv 9/29/2017 16:59:58'! - border: aRectangle width: borderWidth borderHeight: borderHeight fillColor: aColor - "Paint a border whose rectangular area is defined by aRectangle. The - width of the border of each side is borderWidth@borderHeight. Uses aHalfTone for - drawing the border." - - self border: aRectangle - widthRectangle: - (Rectangle - left: borderWidth - right: borderWidth - top: borderHeight - bottom: borderHeight) - rule: Form over - fillColor: aColor! ! -!Form methodsFor: 'bordering' stamp: 'jmv 9/29/2017 16:59:43'! - borderWidth: borderWidth borderHeight: borderHeight fillColor: aColor - self border: self boundingBox width: borderWidth borderHeight: borderHeight fillColor: aColor! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3189-Form-2borderMethods-JuanVuletich-2017Sep29-12h42m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3187] on 28 September 2017 at 1:44:54 pm'! -!Float64Array methodsFor: 'interpolating' stamp: 'jmv 9/28/2017 13:39:15'! - interpolateValues: valuesArray at: x - "Interpret self as a domain and valuesArray as a function samples." - - ^self - findBinaryIndex: [ :arg | x - arg ] - do: [ :i | valuesArray at: i ] - ifNone: [ :i :j | - ((valuesArray at: i) interpolateTo: (valuesArray at: j) at: (x - (self at: i)) / ((self at: j) - (self at: i)))]! ! -!Float64Array methodsFor: 'interpolating' stamp: 'jmv 9/28/2017 13:39:12'! - interpolatedValueAt: floatIndex - "Do a linear interpolation. - Gives usual error if argument outside bounds: - #[ 4 5 ] asFloatArray interpolatedValueAt: 0.999 - #[ 4 5 ] asFloatArray interpolatedValueAt: 1.0 - #[ 4 5 ] asFloatArray interpolatedValueAt: 1.5 - #[ 4 5 ] asFloatArray interpolatedValueAt: 2.0 - #[ 4 5 ] asFloatArray interpolatedValueAt: 2.000001 - #[ 4 5 ] asFloatArray interpolatedValueAt: 3 - " - | size index0 index1 weight0 weight1 | - - size _ self size. - index0 _ floatIndex truncated. "Could be #floor. But as we only care for values >=1, it is the same. But faster." - - weight1 _ floatIndex - index0. - weight0 _ 1.0 - weight1. - - index1 _ (index0 = size and: [ weight1 = 0.0 ]) "Avoid the invalid access if this was true, but don't make it slower the most common, general case." - ifFalse: [ index0 + 1 ] - ifTrue: [ index0 ]. - - "/* perform interpolation */" - ^ (weight0 * (self at: index0)) + (weight1 * (self at: index1))! ! -!FloatArray methodsFor: 'interpolating' stamp: 'jmv 9/28/2017 13:36:31'! - interpolateValues: valuesArray at: x - "Interpret self as a domain and valuesArray as a function samples." - - ^self - findBinaryIndex: [ :arg | x - arg ] - do: [ :i | valuesArray at: i ] - ifNone: [ :i :j | - ((valuesArray at: i) interpolateTo: (valuesArray at: j) at: (x - (self at: i)) / ((self at: j) - (self at: i)))]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3190-interpolation-enh-JuanVuletich-2017Sep28-13h36m-jmv.1.cs.st----! - -----SNAPSHOT----#(1 October 2017 4:33:22.632616 pm) Cuis5.0-3190-v3.image priorSource: 1295998! - -----QUIT----#(1 October 2017 4:33:41.266095 pm) Cuis5.0-3190-v3.image priorSource: 1317581! - -----STARTUP----#(1 October 2017 4:45:40.238381 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3190-v3.image! - - -----QUIT----#(1 October 2017 4:54:50.115556 pm) Cuis5.0-3190-v3.image priorSource: 1317678! - -----STARTUP----#(22 October 2017 9:25:43.58221 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3190-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3190] on 1 October 2017 at 5:11:37 pm'! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 10/1/2017 17:11:24' prior: 50372160! - defaultFontFamily - "Answer the default font family name" - - ^self parameters at: #defaultFontFamily ifAbsentPut: [ AbstractFont familyNames first ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3191-JustInCase-JuanVuletich-2017Oct01-17h11m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3186] on 30 September 2017 at 3:32:06 pm'! -!SHTextStylerST80 methodsFor: 'private' stamp: 'pb 9/30/2017 15:31:56' prior: 50371148! - parseSetWorkspace: aBoolean - "Answer a collection of SHRanges by parsing aText. - When formatting it is not necessary to set the workspace, and this can make the parse take less time, so aBoolean specifies whether the parser should be given the workspace" - parser ifNil: [ parser := SHParserST80 new ]. - parser - workspace: - (aBoolean ifTrue: [ workspace ]); - classOrMetaClass: classOrMetaClass; - source: formattedText asString. - parser parse. - ^ parser ranges.! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3192-SHTextStylerST80-parseSetWorkspace-PhilBellalouna-2017Sep30-15h31m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3192] on 7 October 2017 at 4:29:18 pm'! -!Float commentStamp: 'jmv 10/7/2017 16:27:55' prior: 16844366! - A note About Floating Point numbers and Floating Point Arithmetic. - -The following is not specific to Cuis or Smalltalk at all. This is about the properties of Float numbers in any computer implementation. - -If you haven't done so already, read https://en.wikipedia.org/wiki/Floating-point_arithmetic - -But if you find the Wikipedia article too detailed, or hard to read, then try http://fabiensanglard.net/floating_point_visually_explained/ (get past "How Floating Point are usually explained" and read "A different way to explain..."). - -Other great reads are: - "Why don't my numbers add up?": - http://floating-point-gui.de/ -and - "What Every Computer Scientist Should Know About Floating-Point Arithmetic": - http://docs.oracle.com/cd/E19957-01/806-3568/ncg_goldberg.html -and also maybe - "Comparing floating point numbers" - https://randomascii.wordpress.com/2012/02/25/comparing-floating-point-numbers-2012-edition/ - -Now that you read them, and we are on the same boat, some further comments (from jmv): - -Floats are (conceptually) approximate real numbers. That's why trig and other trascendental functions always answer Floats. That's why it is ok to round the result of operations. That's why Float is considered more general than Fraction in ST-80 and most Smalltalks. So, when we have a Float value, we must not think about it as a Rational but as a Real (actually as some unknown Real that could hopefully be close to the Rational we can actually represent). Keep this in mind when dealing with Floats, and especially avoid comparing them for equality. - -(If you want exact arithmetic, can live in the limited world of Rational numbers, and can afford a slight performance penalty, use Fraction instead.) - -There are some things that can be done to increase the confidence you can have on Float results. One is to do an error propagation analysis on the code you are running. This is not easy, but it is done for any widely used numerical method. Then, you can know real bounds and/or estimates of the errors made. - -Perhaps you have heard about "interval arithmetic". It is a bit better than simple Float, but doesn't really fix the problems. - -The ultimate solution is to do Monte Carlo analysis, with random contamination of inputs. After the Monte Carlo run, it is needed to do statistical analysis of possible correlations between the distributions of the random noise added to imputs and the result of the algorithm. - -Additional food for thought: http://www.cs.berkeley.edu/~wkahan/Mindless.pdf . According to this, doing Monte Carlo as described above attacks a slightly different problem. This might be yet another reason (besides performance) to try something like the next paragraph. I (jmv) came up with it, and I don't really know if it has been described and or tried before or not. Mhhh. Maybe a defensive publication is in order. - -A possibility that could be a practical solution, being much cheaper than Monte Carlo, but better than interval arithmetic, is to represent each value by 2 Floats: an estimation of the real value (i.e. an estimation of the mean value of the distribution of the corresponding Monte Carlo result), and an estimation of the error (i.e. an estimation of the standard deviation of the corresponding Monte Carlo result). Or perhaps even 3 of them. In addition to the estimation of the real value and an estimation of the error, we could add a hard bound on the error. In many cases it will be useless, because the error can not really be bound. But in those cases where it is possible to bound it, applications could really know about the quality of computed values. - -======================================================================= - -My instances represent IEEE-754 floating-point double-precision numbers. They have about 16 digits of accuracy and their range is between plus and minus 10^307. Some valid examples are: - - 8.0 13.3 0.3 2.5e6 1.27e-30 1.27e-31 -12.987654e12 - -Mainly: no embedded blanks, little e for tens power, and a digit on both sides of the decimal point. It is actually possible to specify a radix for Squeak Float constants. This is great for teaching about numbers, but may be confusing to the average reader: - - 3r20.2 --> 6.66666666666667 - 8r20.2 --> 16.25 - -If you don't have access to the definition of IEEE-754, you can figure out what is going on by printing various simple values in Float hex. It may help you to know that the basic format is... - sign 1 bit - exponent 11 bits with bias of 1023 (16r3FF) to produce an exponent - in the range -1023 .. +1024 - - 16r000: - significand = 0: Float zero - significand ~= 0: Denormalized number (exp = -1024, no hidden '1' bit) - - 16r7FF: - significand = 0: Infinity - significand ~= 0: Not A Number (NaN) representation - mantissa 53 bits, but only 52 are stored (20 in the first word, 32 in the second). This is because a normalized mantissa, by definition, has a 1 to the right of its floating point, and IEEE-754 omits this redundant bit to gain an extra bit of precision instead. People talk about the mantissa without its leading one as the FRACTION, and with its leading 1 as the SIGNFICAND. - -The single-precision format is... - sign 1 bit - exponent 8 bits, with bias of 127, to represent -126 to +127 - - 0x0 and 0xFF reserved for Float zero (mantissa is ignored) - - 16r7F reserved for Float underflow/overflow (mantissa is ignored) - mantissa 24 bits, but only 23 are stored -This format is used in FloatArray (qv), and much can be learned from the conversion routines, Float asIEEE32BitWord, and Float class fromIEEE32Bit:. - -You might also check https://en.wikipedia.org/wiki/IEEE_754_revision - -Other great reads (covering broader but interesting issues): -https://randomascii.wordpress.com/2013/07/16/floating-point-determinism/ -http://www.ima.umn.edu/2010-2011/W1.10-14.11/activities/Leeser-Miriam/Leeser-GPU-IMA-Jan2011.pdf! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3193-FloatClassCommentTweaks-JuanVuletich-2017Oct07-16h14m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3193] on 8 October 2017 at 6:43:01 pm'! -!WriteStream methodsFor: 'services' stamp: 'jmv 10/8/2017 17:58:45'! - padToEndIfCantTruncate - "Only makes sense for file streams with existing content. - See inheritance"! ! -!StandardFileStream methodsFor: 'read, write, position' stamp: 'jmv 10/8/2017 17:58:13'! -padToEndIfCantTruncate - "Only makes sense for file streams with existing content. - On file systems that don't support truncating this is needed. - If truncating is supported, try that first" - - "On the Mac, files do not truncate. One can delete the old file and write a new one, but sometime deletion fails (file still open? file stale?). This is a sad compromise. Just let the file be the same length but pad it with a harmless character." - - | pad | - self atEnd ifTrue: [^ self]. - self truncate. - self atEnd ifTrue: [^ self]. - pad := self isBinary - ifTrue: [Character space numericValue] - ifFalse: [Character space ]. - self nextPutAll: (self collectionSpecies new: ((self size - self position) min: 20000) - withAll: pad)! ! -!StandardFileStream methodsFor: 'read, write, position' stamp: 'jmv 10/8/2017 17:02:10' prior: 50332189! - basicNext - "Answer the next byte or character (depending on mode) from this file, or nil if at the end of the file." - - | count | - collection ifNotNil: [ - position < readLimit - ifFalse: [ - readLimit := self primRead: fileID into: collection startingAt: 1 count: collection size. - position := 0. - readLimit = 0 ifTrue: [ ^nil ] ]. - ^collection at: (position := position + 1) ]. - count _ self primRead: fileID into: buffer1 startingAt: 1 count: 1. - ^count = 1 - ifTrue: [ buffer1 at: 1 ]! ! -!StandardFileStream methodsFor: 'read, write, position' stamp: 'jmv 10/8/2017 17:02:58' prior: 16913325! - nextPut: char - "Write the given byte or character (depending on mode) to this file." - - rwmode ifFalse: [^ self error: 'Cannot write a read-only file']. - collection ifNotNil: [ - position < readLimit ifTrue: [ self flushReadBuffer ] ]. - buffer1 at: 1 put: char. - self primWrite: fileID from: buffer1 startingAt: 1 count: 1. - ^ char -! ! -!StandardFileStream methodsFor: 'private' stamp: 'jmv 10/8/2017 17:04:44' prior: 16913668! - collectionSpecies - "Answer the species of collection into which the receiver can stream. - This is ByteArray or String, depending on the mode." - - ^buffer1 species! ! -!SmartRefStream methodsFor: 'read write' stamp: 'jmv 10/8/2017 17:59:09' prior: 50366383! -nextPut: anObject - "Really write three objects: (version, class structure, object). But only when called from the outside. If any instance-specific classes are present, prepend their source code. byteStream will be in fileOut format. - You can see an analysis of which objects are written out by doing: - (SmartRefStream statsOfSubObjects: anObject) - (SmartRefStream tallyOfSubObjects: anObject) - (SmartRefStream subObjects: anObject ofClass: aClass)" - -| info | -topCall - ifNil: [ - topCall _ anObject. - 'Please wait while objects are counted' - displayProgressAt: Sensor mousePoint - from: 0 to: 10 - during: [ :barBlock | info _ self instVarInfo: anObject]. - byteStream binary. - 'Writing an object file' displayProgressAt: Sensor mousePoint - from: 0 to: objCount*4 "estimate" - during: [ :barBlock | - objCount _ 0. - progressBar _ barBlock. - self setStream: byteStream reading: false. - "set basePos, but keep any class renames" - super nextPut: ReferenceStream versionCode. - super nextPut: info. - super nextPut: anObject. "<- the real writing" - ]. - "Note: the terminator, $!!, is not doubled inside object data" - "references is an IDict of every object that got written" - byteStream ascii. - byteStream nextPutAll: '!!'; newLine; newLine. - byteStream padToEndIfCantTruncate. - topCall _ progressBar _ nil] "reset it" - ifNotNil: [ - super nextPut: anObject. - progressBar ifNotNil: [progressBar value: (objCount _ objCount + 1)]]. -! ! - -DummyStream removeSelector: #padToEndWith:! - -DummyStream removeSelector: #padToEndWith:! - -StandardFileStream removeSelector: #padToEndWith:! - -StandardFileStream removeSelector: #padToEndWith:! - -FileStream removeSelector: #text! - -FileStream removeSelector: #text! - -RWBinaryOrTextStream removeSelector: #padToEndWith:! - -RWBinaryOrTextStream removeSelector: #padToEndWith:! - -RWBinaryOrTextStream removeSelector: #text! - -RWBinaryOrTextStream removeSelector: #text! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3194-FileStream-cleanup-JuanVuletich-2017Oct08-18h39m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3194] on 11 October 2017 at 12:29:51 pm'! -!SHParserST80 methodsFor: 'parse support' stamp: 'tween 4/28/2004 09:48' prior: 50371165! - enterBlock - blockDepth := blockDepth + 1. - bracketDepth := bracketDepth + 1! ! -!SHParserST80 methodsFor: 'parse support' stamp: 'jmv 3/2/2010 10:06' prior: 50371173! - leaveBlock - arguments removeKey: blockDepth ifAbsent: nil. - temporaries removeKey: blockDepth ifAbsent: nil. - blockDepth := blockDepth - 1. - bracketDepth := bracketDepth - 1! ! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 12/30/2016 10:51:03' prior: 50371213! - parseBacktick - self enterBlock. - self scanPast: #backtick. - currentTokenFirst == $| ifTrue: [self parseBlockTemporaries]. - self parseStatementList. - self failUnless: currentTokenFirst == $`. - self scanPast: #backtick. - self leaveBlock! ! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 10/11/2017 12:27:51' prior: 50371224! - parseBlock - - "Just read $[" - blockDepths add: blockDepth+1. - blockDepthsStartIndexes add: sourcePosition-1. - - self enterBlock. - self scanPast: #blockStart level: bracketDepth. - currentTokenFirst == $: ifTrue: [self parseBlockArguments]. - currentTokenFirst == $| ifTrue: [self parseBlockTemporaries]. - self parseStatementList. - self failUnless: currentTokenFirst == $]. - - "Just read $]" - blockDepths add: blockDepth-1. - blockDepthsStartIndexes add: sourcePosition. - - self scanPast: #blockEnd level: bracketDepth. - self leaveBlock! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3195-FixShoutBracketColoring-JuanVuletich-2017Oct11-12h29m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3195] on 21 October 2017 at 10:12:27 pm'! -!ContextPart methodsFor: 'debugger access' stamp: 'jmv 10/21/2017 22:04:04'! - shortErrorReportOn: strm - "Write a short error report on the stack (above me) on a stream. For both the error file, and emailing a bug report. " - - | cnt aContext | - strm print: Date today; space; print: Time now; newLine. - aContext _ self. - cnt _ 0. - [aContext notNil and: [(cnt _ cnt + 1) < 20]] whileTrue: [ - strm print: aContext; newLine. "just class>>selector" - aContext _ aContext sender]! ! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jmv 10/19/2017 23:20:22'! - isHeadless - "Answer true if any of this VM options was specified in the commandline: - -nodisplay - -vm-display-null - - Smalltalk isHeadless - " - self vmOptionsDo: [ :vmOption :i | - vmOption = '-vm-display-null' ifTrue: [ ^ true ]. - vmOption = '-nodisplay' ifTrue: [ ^ true ] ]. - ^ false! ! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jmv 10/19/2017 23:14:08'! - vmOptionsDo: aBlock - "Repeatedly evaluate aBlock for each vm option specified by the commandline that started Cuis. - aBlock has two arguments: the vm option itself and the index (position) - - Smalltalk vmOptionsDo: [ :option :i | {i. option} print ] - " - | i vmOption | - i _ -1. - [vmOption _ Smalltalk getSystemAttribute: i. - vmOption notNil ] whileTrue: [ - aBlock value: vmOption value: i. - i _ i-1 ]! ! -!UnhandledError methodsFor: 'priv handling' stamp: 'jmv 10/21/2017 22:07:43'! - standaloneAppDefaultAction - "Dump the stack trace to a log file, then exit the program (image)." - - Smalltalk logError: self description inContext: self signalerContext to: 'CuisDebug'. - Smalltalk quitPrimitive: 1! ! -!Debugger class methodsFor: 'class initialization' stamp: 'jmv 10/21/2017 21:54:51' prior: 16830340! - openContext: aContext label: aString contents: contentsStringOrNil - "Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger." - "Simulation guard" - self errorRecursion not & Preferences logDebuggerStackToFile ifTrue: - [Smalltalk logError: aString inContext: aContext to: 'CuisDebug']. - ErrorRecursion ifTrue: [ - ErrorRecursion _ false. - contentsStringOrNil - ifNil: [ - self primitiveError: 'Can not open debugger due to recursion error.', - String newLineString, aString] - ifNotNil: [ - self primitiveError: 'Can not open debugger due to recursion error.', - String newLineString, aString, String newLineString, contentsStringOrNil ]]. - ErrorRecursion _ true. - self informExistingDebugger: aContext label: aString. - (Debugger context: aContext) - openNotifierContents: contentsStringOrNil - label: aString. - ErrorRecursion _ false. - Processor activeProcess suspend. -! ! -!Debugger class methodsFor: 'opening' stamp: 'jmv 10/21/2017 21:54:56' prior: 16830430! - openInterrupt: aString onProcess: interruptedProcess - "Open a notifier in response to an interrupt. An interrupt occurs when the user types the interrupt key (cmd-. on Macs, ctrl-c or alt-. on other systems) or when the low-space watcher detects that memory is low." - | debugger | - "Simulation guard" - debugger _ self new. - debugger - process: interruptedProcess - context: interruptedProcess suspendedContext. - debugger externalInterrupt: true. - -Preferences logDebuggerStackToFile ifTrue: - [(aString includesSubString: 'Space') & - (aString includesSubString: 'low') ifTrue: [ - Smalltalk logError: aString inContext: debugger interruptedContext to: 'LowSpaceDebug']]. - - ^ debugger - openNotifierContents: nil - label: aString -! ! -!Debugger class methodsFor: 'opening' stamp: 'jmv 10/21/2017 21:55:00' prior: 50368357! - openOn: process context: context label: title fullView: bool - "Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger." - | w | - Preferences logDebuggerStackToFile ifTrue: [ - Smalltalk - logError: title - inContext: context - to: 'CuisDebug' ]. - w := ProjectX newProcessIfUIX: process. - "schedule debugger in deferred UI message to address redraw - problems after opening a debugger e.g. from the testrunner." - WorldState addDeferredUIMessage: [ - [ | debugger | - "In case an error in Morphic code got us here, ensure mouse focus has been released" - true runningWorld ifNotNil: [ :rWorld | - rWorld activeHand ifNotNil: [ :aHand | - aHand releaseMouseFocus ]]. - debugger := self new - process: process - context: context. - debugger interruptedProcessUI: w. - bool - ifTrue: [ debugger openFullMorphicLabel: title ] - ifFalse: [ - PreDebugWindow - open: debugger - label: title - message: nil ]] - on: UnhandledError - do: [ :exOuter | | errorDescription | - errorDescription := 'Error while trying to open Debugger' , String newLineString , 'Orginal error: ' , title asString , '.' , String newLineString , ' Debugger error: ' , - ([ exOuter description ] - on: UnhandledError - do: [ :exInner | - exInner return: 'a ' , exInner class printString ]) , ':'. - self primitiveError: errorDescription ]]. - process suspend.! ! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jmv 10/21/2017 22:12:20' prior: 16921052! - logError: errMsg inContext: aContext to: baseFilename - "Log the error message and a stack trace to the given file. - Smalltalk logError: 'test error message' inContext: thisContext to: 'testErr.txt' - " - - | localFilename file | - localFilename _ Preferences debugLogTimestamp - ifTrue: [ baseFilename, '-', Utilities dateTimeSuffix, '.log' ] - ifFalse: [ baseFilename, '.log' ]. - file _ DirectoryEntry smalltalkImageDirectory // localFilename. - [ - file forceWriteStreamDo: [ :stream | - stream nextPutAll: errMsg; newLine. - aContext errorReportOn: stream ] - ] on: UnhandledError do: [ :ex | ex return]. "avoid recursive errors" - [ - StdIOWriteStream stdout newLine; nextPutAll: errMsg. - StdIOWriteStream stdout newLine; nextPutAll: 'See '; nextPutAll: file pathName. - StdIOWriteStream stdout newLine. - aContext shortErrorReportOn: StdIOWriteStream stdout. - StdIOWriteStream stdout flush - ] on: UnhandledError do: [ :ex | ex return]. "avoid recursive errors"! ! -!UnhandledError methodsFor: 'priv handling' stamp: 'jmv 10/21/2017 21:17:43' prior: 16940304! - defaultAction - "The current computation is terminated. The cause of the error should be logged or reported to the user. If the program is operating in an interactive debugging environment the computation should be suspended and the debugger activated." - - self isDevelopmentEnvironmentPresent - ifTrue: [ self devDefaultAction ] - ifFalse: [ self standaloneAppDefaultAction ]! ! -!UnhandledError methodsFor: 'priv handling' stamp: 'jmv 10/19/2017 23:20:13' prior: 16940324! - isDevelopmentEnvironmentPresent - - ^ Smalltalk isHeadless not and: [Smalltalk includesKey: #Debugger]! ! -!Preferences class methodsFor: 'standard queries' stamp: 'jmv 10/19/2017 23:30:02' prior: 16893585! - debugLogTimestamp - ^ self - valueOfFlag: #debugLogTimestamp - ifAbsent: [true]! ! -!Utilities class methodsFor: 'identification' stamp: 'jmv 10/21/2017 21:52:54' prior: 16940682! - dateTimeSuffix - "Answer a string which indicates the date and time, intended for use in building fileout filenames, etc. - - Utilities dateTimeSuffix - " - | n | - n _ DateAndTime now. - ^ String streamContents: [ :strm | - n printYMDOn: strm withLeadingSpace: false. - strm nextPut: $_. - n printHMSOn: strm separator: $. ]! ! -!DisplayScreen methodsFor: 'private' stamp: 'jmv 10/21/2017 21:55:10' prior: 16835312! - findAnyDisplayDepth - "Return any display depth that is supported on this system." - ^self findAnyDisplayDepthIfNone: [ - "Ugh .... now this is a biggie - a system that does not support - any of the Squeak display depths at all." - Smalltalk - logError: 'Fatal error: This system has no support for any display depth at all.' - inContext: thisContext - to: 'CuisDebug'. - Smalltalk quitPrimitive. "There is no way to continue from here" - ]! ! - -Utilities class removeSelector: #monthDayTime24StringFrom:! - -Utilities class removeSelector: #monthDayTime24StringFrom:! - -Utilities class removeSelector: #monthDayTimeStringFrom:! - -Utilities class removeSelector: #monthDayTimeStringFrom:! - -Preferences class removeSelector: #twentyFourHourFileStamps! - -Preferences class removeSelector: #twentyFourHourFileStamps! - -Debugger removeSelector: #storeLog! - -Debugger removeSelector: #storeLog! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3196-StandaloneApps-ExitOnError-JuanVuletich-2017Oct21-22h09m-jmv.1.cs.st----! - -----SNAPSHOT----#(22 October 2017 9:25:52.288228 pm) Cuis5.0-3196-v3.image priorSource: 1317885! - -----QUIT----#(22 October 2017 9:26:08.261184 pm) Cuis5.0-3196-v3.image priorSource: 1340930! - -----STARTUP----#(3 November 2017 11:15:47.773216 am) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3196-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3196] on 26 October 2017 at 12:41:44 pm'! - -UnhandledError removeSelector: #runtimeDefaultAction! - -UnhandledError removeSelector: #runtimeDefaultAction! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3197-remove-runtimeDefaultAction-JuanVuletich-2017Oct26-12h41m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3197] on 26 October 2017 at 4:59:57 pm'! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'dhn 10/25/2017 16:48:11' prior: 16909778! - browseIt - "Launch a browser for the current selection, if appropriate" - - | aSymbol anEntry browser | - Preferences alternativeBrowseIt ifTrue: [^ self browseClassFromIt]. - - self wordSelectAndEmptyCheck: [^ self]. - (aSymbol _ self selectedSymbol) ifNil: [^ morph flash]. - - aSymbol first isUppercase - ifTrue: [ - anEntry _ (Smalltalk - at: aSymbol - ifAbsent: [ - Smalltalk browseAllImplementorsOf: aSymbol. - ^ nil]). - anEntry ifNil: [^ morph flash]. - (anEntry isKindOf: Class) - ifFalse: [anEntry _ anEntry class]. - browser _ Browser new. - browser setClass: anEntry selector: nil. - BrowserWindow open: browser label:'System Browser: ', aSymbol] - ifFalse: - [Smalltalk browseAllImplementorsOf: aSymbol]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3198-BrowseIt-includeClassName-DanNorton-2017Oct26-16h59m-dhn.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3198] on 27 October 2017 at 9:25:00 am'! -!Preferences class methodsFor: 'standard queries' stamp: 'jmv 10/27/2017 09:24:28' prior: 0! - logDebuggerStackToFile - ^ self - valueOfFlag: #logDebuggerStackToFile - ifAbsent: [ false ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3199-DontLogWalkbacksToDiskByDefault-JuanVuletich-2017Oct27-09h24m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3195] on 22 October 2017 at 4:02:34 pm'! - -MouseEvent subclass: #MouseScrollEvent - instanceVariableNames: 'direction eventHandler' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Events'! - -!classDefinition: #MouseScrollEvent category: #'Morphic-Events'! -MouseEvent subclass: #MouseScrollEvent - instanceVariableNames: 'direction eventHandler' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Events'! -!MouseScrollEvent commentStamp: '' prior: 0! - A MouseScrollEvent can be any type of secondary pointer movement (typically via a scroll wheel on a traditional mouse or a gesture on a trackpad). Currently, events are extracted from KeyboardEvents (which is how the VM currently communicates things like scroll wheel events via ctl+arrow up/down)! -!Morph methodsFor: 'events' stamp: 'pb 10/22/2017 02:55:55'! - mouseScroll: aMouseScrollEvent localPosition: localEventPosition - "Handle a mouse scroll event. - This message will only be sent to Morphs that answer true to #handlesMouseScroll: - We can query aMouseScrollEvent to know about pressed mouse buttons." - - "Allow instances to dynamically use properties for handling common events." - self - valueOfProperty: #mouseScroll:localPosition: - ifPresentDo: [ :handler | handler value: aMouseScrollEvent value: localEventPosition ]! ! -!Morph methodsFor: 'event handling testing' stamp: 'pb 10/22/2017 02:53:48'! - handlesMouseScroll: aMouseScrollEvent - ^ self hasProperty: #'handlesMouseScroll:'! ! -!Morph methodsFor: 'events-processing' stamp: 'pb 10/22/2017 15:49:56'! - processMouseScroll: aMouseEvent localPosition: localEventPosition - ((self handlesMouseScroll: aMouseEvent) and: [ aMouseEvent wasHandled not ]) ifTrue: [ - self - mouseScroll: aMouseEvent - localPosition: localEventPosition. - aMouseEvent wasHandled: true ].! ! -!Morph methodsFor: 'private' stamp: 'pb 10/22/2017 05:19:27'! - privateAnyOwnerHandlesMouseScroll: aMouseScrollEvent - | foundHandler | - foundHandler _ false. - (self ownerChain allButFirst anySatisfy: [ :anOwner | - anOwner isWorldMorph not and: [ anOwner handlesMouseScroll: aMouseScrollEvent ]]) ifTrue: [ foundHandler _ true ]. - ^ foundHandler.! ! -!PluggableScrollPane methodsFor: 'events' stamp: 'pb 10/22/2017 15:52:25'! - mouseScroll: aMouseEvent localPosition: localEventPosition - aMouseEvent direction = #up - ifTrue: [ scrollBar scrollUp: 1 ] - ifFalse: [ scrollBar scrollDown: 1 ].! ! -!PluggableScrollPane methodsFor: 'event handling testing' stamp: 'pb 10/22/2017 16:00:50'! - handlesMouseScroll: aMouseScrollEvent - "Only accept if we can actually do something useful with the event (i.e. not scrolling up when already at the top or down when already at the bottom) or if my owner chain doesn't want it" - | canUse | - canUse _ (aMouseScrollEvent direction = #up and: [ scrollBar scrollValue > 0 ]) or: [ - aMouseScrollEvent direction = #down and: [ scrollBar scrollValue < 1 ]]. - "Even if I don't want it, one of my owners might. (i.e. nested scroll panes) If my owners don't want it, accept the event to make sure that morphs behind me doesn't get the event." - canUse ifFalse: [ - (self privateAnyOwnerHandlesMouseScroll: aMouseScrollEvent) ifFalse: [ canUse _ true ]]. - ^ canUse.! ! -!MouseEvent methodsFor: 'testing' stamp: 'pb 10/22/2017 02:19:31'! - isMouseScroll - ^ type == #mouseScroll! ! -!MouseScrollEvent methodsFor: 'private' stamp: 'pb 10/22/2017 02:17:18'! - setType: evtType position: evtPos direction: evtDir buttons: evtButtons hand: evtHand stamp: stamp - type _ evtType. - position _ evtPos. - buttons _ evtButtons. - source _ evtHand. - wasHandled _ false. - direction _ evtDir. - timeStamp _ stamp.! ! -!MouseScrollEvent methodsFor: 'comparing' stamp: 'pb 10/22/2017 02:18:29'! - hash - ^ position hash + buttons hash + direction hash! ! -!MouseScrollEvent methodsFor: 'dispatching' stamp: 'pb 10/22/2017 15:51:28'! - dispatchWith: aMorph localPosition: positionInAMorph - "Find the appropriate receiver for the event and let it handle it. Default rules: - * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. - * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. - * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. - * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. - " - "Try to get out quickly" - | aMorphHandlesIt handledByInner eventPositionInChild focus| - focus := self hand keyboardFocus. - "FIXME - this works in all tested cases but one: when the window directly under the mouse doesn't have keyboard focus (i.e. a Transcript window)" - ((aMorph fullContainsPoint: positionInAMorph) and: [(aMorph = focus) or: [focus notNil and: [aMorph notNil and: [focus hasOwner: aMorph]]]]) ifFalse: [ ^ #rejected ]. - "Install the prospective handler for the receiver" - aMorphHandlesIt _ false. - (aMorph handlesMouseScroll: self) ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]. - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild - dispatchEvent: self - localPosition: eventPositionInChild) == #rejected ifFalse: [ "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - (handledByInner or: [ - aMorph - containsPoint: positionInAMorph - event: self ]) ifTrue: [ - "aMorph is in the top-most unlocked, visible morph in the chain." - aMorphHandlesIt ifTrue: [ ^ self - sentTo: aMorph - localPosition: positionInAMorph ]]. - handledByInner ifTrue: [ ^ self ]. - "Mouse was not on aMorph nor any of its children" - ^ #rejected.! ! -!MouseScrollEvent methodsFor: 'dispatching' stamp: 'pb 10/22/2017 03:04:54'! - sentTo: aMorph localPosition: positionInAMorph - "Dispatch the receiver into anObject" - ^ aMorph - processMouseScroll: self - localPosition: positionInAMorph.! ! -!MouseScrollEvent methodsFor: 'accessing' stamp: 'pb 10/22/2017 03:15:50'! - direction - ^ direction ! ! -!HandMorph methodsFor: 'events-processing' stamp: 'pb 10/22/2017 14:44:34' prior: 16851817! - startMouseDispatch: aMouseEvent - - aMouseEvent isMouseOver ifTrue: [ - ^self mouseFocus - ifNotNil: [ mouseFocus handleFocusEvent: aMouseEvent ] - ifNil: [ owner dispatchEvent: aMouseEvent localPosition: aMouseEvent eventPosition ]]. - - "any mouse event but mouseOver" - lastMouseEvent _ aMouseEvent. - lastMouseEventTime _ Time localMillisecondClock. - - "Check for pending drag or double click operations." - mouseClickState ifNotNil: [ - (mouseClickState handleEvent: aMouseEvent from: self) ifTrue: [ - "Possibly dispatched #click: or something. Do not further process this event." - ^self mouseOverHandler processMouseOver: lastMouseEvent ]]. - - aMouseEvent isMove - ifTrue: [ - self morphPosition: aMouseEvent eventPosition. - self mouseFocus - ifNotNil: [ mouseFocus handleFocusEvent: aMouseEvent ] - ifNil: [ owner dispatchEvent: aMouseEvent localPosition: aMouseEvent eventPosition ] - ] ifFalse: [ - aMouseEvent isMouseScroll ifTrue: [ - owner dispatchEvent: aMouseEvent localPosition: aMouseEvent eventPosition] ifFalse: [ - "Issue a synthetic move event if we're not at the position of the event" - aMouseEvent eventPosition = self morphPosition ifFalse: [ - "Issue a mouse move event to make the receiver appear at the given position" - self startMouseDispatch: (MouseMoveEvent new - setType: #mouseMove - position: aMouseEvent eventPosition - buttons: aMouseEvent buttons - hand: self - stamp: aMouseEvent timeStamp) ]. - "Drop submorphs on button events" - self hasSubmorphs - ifTrue: [ - "Not if we are grabbing them" - mouseClickState ifNil: [self dropMorphs: aMouseEvent ]] - ifFalse: [ - self mouseFocus - ifNotNil: [ mouseFocus handleFocusEvent: aMouseEvent ] - ifNil: [ owner dispatchEvent: aMouseEvent localPosition: aMouseEvent eventPosition ]]]]. - self mouseOverHandler processMouseOver: self lastMouseEvent! ! -!HandMorph methodsFor: 'private events' stamp: 'pb 10/22/2017 14:48:02' prior: 16852220! - generateKeyboardEvent: evtBuf - "Generate the appropriate mouse event for the given raw event buffer" - | buttons modifiers type keyValue pressType stamp | - stamp _ evtBuf second. - stamp = 0 ifTrue: [ stamp _ Time localMillisecondClock ]. - (evtBuf sixth <= 0 or: [ (keyValue _ Character iso8859s15CodeForUnicodeCodePoint: evtBuf sixth) isNil ]) ifTrue: [ keyValue _ Character macRomanToLatin1: evtBuf third ]. - Sensor peekEvent ifNotNil: [ :nxt | - "start: Combining diacritical marks (i.e. accents in the Linux VM)" - (nxt fourth = EventSensor eventKeyDown and: [ nxt third > 255 ]) ifTrue: [ - keyValue _ ((Character numericValue: keyValue) withDiacriticalMark: nxt third) iso8859s15Code. - Sensor - nextEvent; - nextEvent; - nextEvent ]. - "end: Combining diacritical marks (i.e. accents in the Linux VM)" - "start: Spurious LF after CR on Ctrl-Enter on Windows VM" - ((evtBuf fourth = EventSensor eventKeyChar and: [ evtBuf third = 13 ]) and: [ - nxt fourth = EventSensor eventKeyChar and: [ nxt third = 10 ]]) ifTrue: [ Sensor nextEvent - "print " ]]. - modifiers _ evtBuf fifth. - pressType _ evtBuf fourth. - pressType = EventSensor eventKeyDown ifTrue: [ - type _ #keyDown. - lastKeyDownValue _ keyValue ]. - pressType = EventSensor eventKeyUp ifTrue: [ type _ #keyUp ]. - pressType = EventSensor eventKeyChar ifTrue: [ - type _ #keystroke. - "If Control key pressed, and the VM answers a code below 27, - it means it did the translation, convert it back to regular character: - We want to handle the meaning of ctrl ourselves." - (modifiers anyMask: 2) ifTrue: [ - "Control key pressed" - keyValue < 27 ifTrue: [ - "But we don't want to do it for Home/End/PgUp/PgDn, just for alphabetic keys" - lastKeyDownValue = keyValue ifFalse: [ - "If equal, real Home/End/PgUp/PgDn in Windows => don't translate" - (keyValue + 64 = lastKeyDownValue or: [ "If Equal, Ctrl-alphabetic in Windows => do translate" - lastKeyDownValue < 47 ]) ifTrue: [ - "Not on windows. If less (not sure about the bound, but do not translate 48: tab on Mac), alphabetic on Mac => do translate" - keyValue _ (modifiers anyMask: 1) - ifTrue: [ keyValue + 64 ] - ifFalse: [ keyValue + 96 - "shift not pressed: conver to lowercase letter" ]]]]. - "Act as if command/alt was pressed for some usual Windows ctrl-key combinations" - (self shouldControlEmulateAltFor: keyValue) ifTrue: [ modifiers _ modifiers bitOr: 8 ]]]. - buttons _ modifiers bitShift: 3. - (modifiers = 2 and: [ - keyValue = 30 or: [ keyValue = 31 ]]) - ifTrue: [ "We're hijacking ctl-up/down arrow since that is what the VM sends us for scroll events. We're going to convert these to MouseScrollEvent and throw away the keyboard event" - ^ MouseScrollEvent new - setType: #mouseScroll - position: self morphPosition - direction: - (keyValue caseOf: { - [ "Implementing as a caseof to allow for easy adding of left/right/other events should they become available" - 30 ] -> [ #up ]. - [ 31 ] -> [ #down ]}) - buttons: buttons - hand: self - stamp: stamp ] - ifFalse: [ ^ KeyboardEvent new - setType: type - buttons: buttons - position: self morphPosition - keyValue: keyValue - hand: self - stamp: stamp ].! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3200-Morph-Scroll-Events-PhilBellalouna-2017Oct22-02h07m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3200] on 27 October 2017 at 9:38:49 am'! -!PluggableScrollPane methodsFor: 'events' stamp: 'jmv 10/27/2017 09:38:25' prior: 16889541! - keyStroke: aKeyboardEvent - - (Theme current keyStroke: aKeyboardEvent morph: self) - ifTrue: [^ self]. - ( self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - super keyStroke: aKeyboardEvent. - scroller keyStroke: aKeyboardEvent! ! -!HierarchicalListMorph methodsFor: 'events' stamp: 'jmv 10/27/2017 09:38:10' prior: 16853054! - keyStroke: aKeyboardEvent - "Process potential command keys" - - | args aCharacter | - (Theme current keyStroke: aKeyboardEvent morph: self) - ifTrue: [^ self]. - (self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - aCharacter _ aKeyboardEvent keyCharacter. - (self arrowKey: aCharacter) - ifTrue: [ ^self ]. - keystrokeActionSelector ifNil: [^self]. - (args _ keystrokeActionSelector numArgs) = 1 - ifTrue: [^mainView perform: keystrokeActionSelector with: aCharacter]. - args = 2 - ifTrue: [ - ^mainView - perform: keystrokeActionSelector - with: aCharacter - with: self]. - ^self error: 'The keystrokeActionSelector must be a 1- or 2-keyword symbol'! ! -!PluggableListMorph methodsFor: 'events' stamp: 'jmv 10/27/2017 09:38:21' prior: 16888604! - keyStroke: aKeyboardEvent - "Process keys" - - | aCharacter | - (Theme current keyStroke: aKeyboardEvent morph: self) - ifTrue: [^ self]. - (self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - aCharacter _ aKeyboardEvent keyCharacter. - (self arrowKey: aCharacter) - ifTrue: [ ^self ]. - aCharacter numericValue = 27 ifTrue: [ " escape key" - ^ self mouseButton2Activity]. - aKeyboardEvent anyModifierKeyPressed - ifTrue: [ - (self keystrokeAction: aCharacter) - ifTrue: [ ^self ]]. - ^ self keyboardSearch: aCharacter! ! -!HandMorph methodsFor: 'private events' stamp: 'jmv 10/27/2017 09:36:10' prior: 50373894! - generateKeyboardEvent: evtBuf - "Generate the appropriate mouse event for the given raw event buffer" - | buttons modifiers type keyValue pressType stamp | - stamp _ evtBuf second. - stamp = 0 ifTrue: [ stamp _ Time localMillisecondClock ]. - (evtBuf sixth <= 0 or: [ (keyValue _ Character iso8859s15CodeForUnicodeCodePoint: evtBuf sixth) isNil ]) ifTrue: [ keyValue _ Character macRomanToLatin1: evtBuf third ]. - Sensor peekEvent ifNotNil: [ :nxt | - "start: Combining diacritical marks (i.e. accents in the Linux VM)" - (nxt fourth = EventSensor eventKeyDown and: [ nxt third > 255 ]) ifTrue: [ - keyValue _ ((Character numericValue: keyValue) withDiacriticalMark: nxt third) iso8859s15Code. - Sensor - nextEvent; - nextEvent; - nextEvent ]. - "end: Combining diacritical marks (i.e. accents in the Linux VM)" - "start: Spurious LF after CR on Ctrl-Enter on Windows VM" - ((evtBuf fourth = EventSensor eventKeyChar and: [ evtBuf third = 13 ]) and: [ - nxt fourth = EventSensor eventKeyChar and: [ nxt third = 10 ]]) ifTrue: [ Sensor nextEvent - "print " ]]. - modifiers _ evtBuf fifth. - pressType _ evtBuf fourth. - pressType = EventSensor eventKeyDown ifTrue: [ - type _ #keyDown. - lastKeyDownValue _ keyValue ]. - pressType = EventSensor eventKeyUp ifTrue: [ type _ #keyUp ]. - pressType = EventSensor eventKeyChar ifTrue: [ - type _ #keystroke. - "If Control key pressed, and the VM answers a code below 27, - it means it did the translation, convert it back to regular character: - We want to handle the meaning of ctrl ourselves." - (modifiers anyMask: 2) ifTrue: [ - "Control key pressed" - keyValue < 27 ifTrue: [ - "But we don't want to do it for Home/End/PgUp/PgDn, just for alphabetic keys" - lastKeyDownValue = keyValue ifFalse: [ - "If equal, real Home/End/PgUp/PgDn in Windows => don't translate" - (keyValue + 64 = lastKeyDownValue or: [ "If Equal, Ctrl-alphabetic in Windows => do translate" - lastKeyDownValue < 47 ]) ifTrue: [ - "Not on windows. If less (not sure about the bound, but do not translate 48: tab on Mac), alphabetic on Mac => do translate" - keyValue _ (modifiers anyMask: 1) - ifTrue: [ keyValue + 64 ] - ifFalse: [ keyValue + 96 - "shift not pressed: conver to lowercase letter" ]]]]. - "Act as if command/alt was pressed for some usual Windows ctrl-key combinations" - (self shouldControlEmulateAltFor: keyValue) ifTrue: [ modifiers _ modifiers bitOr: 8 ]]]. - buttons _ modifiers bitShift: 3. - (modifiers = 2 and: [ - keyValue = 30 or: [ keyValue = 31 ]]) - ifTrue: [ "We're hijacking ctl-up/down arrow since that is what the VM sends us for scroll events. We're going to convert these to MouseScrollEvent and throw away the keyboard event" - "ThisPrecludes the use of up and down arrows with control, that are standard keystrokes in Windows to control the cursor. - But as Linux, Mac and Windows VMs generate ctrl-up and ctrl-down for mouse wheel events, we must honor them. - Some day, it would be good for the VMs to report mouse wheel events differently fom ctrl-up & ctrl-down..." - ^ MouseScrollEvent new - setType: #mouseScroll - position: self morphPosition - direction: - (keyValue caseOf: { - [ "Implementing as a caseof to allow for easy adding of left/right/other events should they become available" - 30 ] -> [ #up ]. - [ 31 ] -> [ #down ]}) - buttons: buttons - hand: self - stamp: stamp ] - ifFalse: [ ^ KeyboardEvent new - setType: type - buttons: buttons - position: self morphPosition - keyValue: keyValue - hand: self - stamp: stamp ].! ! -!InnerTextMorph methodsFor: 'events' stamp: 'jmv 10/27/2017 09:38:16' prior: 16855703! - keyStroke: aKeyboardEvent - - (Theme current keyStroke: aKeyboardEvent morph: self) - ifTrue: [^ self]. - (self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - - autoCompleter - ifNil: [ self processKeyStroke: aKeyboardEvent ] - ifNotNil: [ - autoCompleter - autoCompletionAround: [ self processKeyStroke: aKeyboardEvent ] - keyStroke: aKeyboardEvent ]! ! - -PluggableScrollPane removeSelector: #scrollByKeyboard:! - -PluggableScrollPane removeSelector: #scrollByKeyboard:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3201-Cleanup-JuanVuletich-2017Oct27-09h31m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3201] on 27 October 2017 at 9:58:10 am'! -!MouseScrollEvent commentStamp: '' prior: 50373638! - A MouseScrollEvent can be any type of secondary pointer movement (typically via a scroll wheel on a traditional mouse or a gesture on a trackpad). Currently, events are extracted from KeyboardEvents (which is how the VM currently communicates things like scroll wheel events via ctl+arrow up/down). - -It is also possible to generate these events with a keyboard, pressing ctrl-down or ctrl-up. Given this, we also added ctrl-left and ctrl-right, that can only be generated with a keyboard, to control horizontal scroll.! -!PluggableScrollPane methodsFor: 'events' stamp: 'jmv 10/27/2017 09:56:48' prior: 50373696! - mouseScroll: aMouseEvent localPosition: localEventPosition - aMouseEvent direction - caseOf: { - [ #up ] -> [ scrollBar scrollUp: 1 ]. - [ #down ] -> [ scrollBar scrollDown: 1 ]. - [ #left ] -> [ hScrollBar scrollUp: 1 ]. - [ #right ] -> [ hScrollBar scrollDown: 1 ] }! ! -!PluggableScrollPane methodsFor: 'event handling testing' stamp: 'jmv 10/27/2017 09:47:51' prior: 50373705! - handlesMouseScroll: aMouseScrollEvent - "Only accept if we can actually do something useful with the event (i.e. not scrolling up when already at the top or down when already at the bottom) or if my owner chain doesn't want it" - - (aMouseScrollEvent direction = #up and: [ scrollBar scrollValue > 0 ]) - ifTrue: [ ^ true ]. - (aMouseScrollEvent direction = #down and: [ scrollBar scrollValue < 1 ]) - ifTrue: [ ^ true ]. - (aMouseScrollEvent direction = #left and: [ hScrollBar scrollValue > 0 ]) - ifTrue: [ ^ true ]. - (aMouseScrollEvent direction = #right and: [ hScrollBar scrollValue < 1 ]) - ifTrue: [ ^ true ]. - "Even if I don't want it, one of my owners might. (i.e. nested scroll panes) If my owners don't want it, accept the event to make sure that morphs behind me doesn't get the event." - (self privateAnyOwnerHandlesMouseScroll: aMouseScrollEvent) - ifFalse: [ ^ true ]. - ^ false! ! -!HandMorph methodsFor: 'private events' stamp: 'jmv 10/27/2017 09:57:46' prior: 50374061! - generateKeyboardEvent: evtBuf - "Generate the appropriate mouse event for the given raw event buffer" - | buttons modifiers type keyValue pressType stamp | - stamp _ evtBuf second. - stamp = 0 ifTrue: [ stamp _ Time localMillisecondClock ]. - (evtBuf sixth <= 0 or: [ (keyValue _ Character iso8859s15CodeForUnicodeCodePoint: evtBuf sixth) isNil ]) ifTrue: [ keyValue _ Character macRomanToLatin1: evtBuf third ]. - Sensor peekEvent ifNotNil: [ :nxt | - "start: Combining diacritical marks (i.e. accents in the Linux VM)" - (nxt fourth = EventSensor eventKeyDown and: [ nxt third > 255 ]) ifTrue: [ - keyValue _ ((Character numericValue: keyValue) withDiacriticalMark: nxt third) iso8859s15Code. - Sensor - nextEvent; - nextEvent; - nextEvent ]. - "end: Combining diacritical marks (i.e. accents in the Linux VM)" - "start: Spurious LF after CR on Ctrl-Enter on Windows VM" - ((evtBuf fourth = EventSensor eventKeyChar and: [ evtBuf third = 13 ]) and: [ - nxt fourth = EventSensor eventKeyChar and: [ nxt third = 10 ]]) ifTrue: [ Sensor nextEvent - "print " ]]. - modifiers _ evtBuf fifth. - pressType _ evtBuf fourth. - pressType = EventSensor eventKeyDown ifTrue: [ - type _ #keyDown. - lastKeyDownValue _ keyValue ]. - pressType = EventSensor eventKeyUp ifTrue: [ type _ #keyUp ]. - pressType = EventSensor eventKeyChar ifTrue: [ - type _ #keystroke. - "If Control key pressed, and the VM answers a code below 27, - it means it did the translation, convert it back to regular character: - We want to handle the meaning of ctrl ourselves." - (modifiers anyMask: 2) ifTrue: [ - "Control key pressed" - keyValue < 27 ifTrue: [ - "But we don't want to do it for Home/End/PgUp/PgDn, just for alphabetic keys" - lastKeyDownValue = keyValue ifFalse: [ - "If equal, real Home/End/PgUp/PgDn in Windows => don't translate" - (keyValue + 64 = lastKeyDownValue or: [ "If Equal, Ctrl-alphabetic in Windows => do translate" - lastKeyDownValue < 47 ]) ifTrue: [ - "Not on windows. If less (not sure about the bound, but do not translate 48: tab on Mac), alphabetic on Mac => do translate" - keyValue _ (modifiers anyMask: 1) - ifTrue: [ keyValue + 64 ] - ifFalse: [ keyValue + 96 - "shift not pressed: conver to lowercase letter" ]]]]. - "Act as if command/alt was pressed for some usual Windows ctrl-key combinations" - (self shouldControlEmulateAltFor: keyValue) ifTrue: [ modifiers _ modifiers bitOr: 8 ]]]. - buttons _ modifiers bitShift: 3. - (modifiers = 2 and: [ - keyValue between: 28 and: 31]) - ifTrue: [ "We're hijacking ctl-up/down arrow since that is what the VM sends us for scroll events. We're going to convert these to MouseScrollEvent and throw away the keyboard event" - "ThisPrecludes the use of up and down arrows with control, that are standard keystrokes in Windows to control the cursor. - But as Linux, Mac and Windows VMs generate ctrl-up and ctrl-down for mouse wheel events, we must honor them. - Some day, it would be good for the VMs to report mouse wheel events differently fom ctrl-up & ctrl-down..." - "Also do ctrl-left and ctrl-right for horizontal scroll." - ^ MouseScrollEvent new - setType: #mouseScroll - position: self morphPosition - direction: - (keyValue caseOf: { - "Implementing as a caseof to allow for easy adding of left/right/other events should they become available" - [ 30 ] -> [ #up ]. - [ 31 ] -> [ #down ]. - [ 28 ] -> [ #left ]. - [ 29 ] -> [ #right ]. - }) - buttons: buttons - hand: self - stamp: stamp ] - ifFalse: [ ^ KeyboardEvent new - setType: type - buttons: buttons - position: self morphPosition - keyValue: keyValue - hand: self - stamp: stamp ].! ! -!MouseEvent methodsFor: 'comparing' stamp: 'jmv 10/27/2017 09:42:20' prior: 16879126! - hash - ^ type hash bitXor: (position hash bitXor: buttons hash)! ! -!MouseMoveEvent methodsFor: 'comparing' stamp: 'jmv 10/27/2017 09:42:03' prior: 16879243! - hash - ^ position hash bitXor: buttons hash! ! -!MouseScrollEvent methodsFor: 'comparing' stamp: 'jmv 10/27/2017 09:41:31' prior: 50373744! - hash - ^ position hash bitXor: (buttons hash bitXor: direction hash)! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3202-HorizontalScrollEvents-JuanVuletich-2017Oct27-09h52m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3202] on 30 October 2017 at 10:28:09 am'! -!Timespan methodsFor: 'smalltalk-80' stamp: 'jmv 10/30/2017 10:26:58' prior: 16938162! - previous - " - (Month month: 10 year: 2017) previous - (Year yearNumber: 2016) previous - " - ^self class classDefinesDuration - ifTrue: [ self class including: self end - duration ] - ifFalse: [ self class starting: start - duration duration: duration ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3203-Month-Year-previous-fix-JuanVuletich-2017Oct30-10h24m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3202] on 30 October 2017 at 10:37:01 am'! -!Preferences class methodsFor: 'standard queries' stamp: 'jmv 10/30/2017 10:36:16'! - ctrlArrowsScrollHorizontally - ^ self - valueOfFlag: #ctrlArrowsScrollHorizontally - ifAbsent: [ false ]! ! -!HandMorph methodsFor: 'private events' stamp: 'jmv 10/30/2017 10:35:34' prior: 50374264! - generateKeyboardEvent: evtBuf - "Generate the appropriate mouse event for the given raw event buffer" - | buttons modifiers type keyValue pressType stamp | - stamp _ evtBuf second. - stamp = 0 ifTrue: [ stamp _ Time localMillisecondClock ]. - (evtBuf sixth <= 0 or: [ (keyValue _ Character iso8859s15CodeForUnicodeCodePoint: evtBuf sixth) isNil ]) ifTrue: [ keyValue _ Character macRomanToLatin1: evtBuf third ]. - Sensor peekEvent ifNotNil: [ :nxt | - "start: Combining diacritical marks (i.e. accents in the Linux VM)" - (nxt fourth = EventSensor eventKeyDown and: [ nxt third > 255 ]) ifTrue: [ - keyValue _ ((Character numericValue: keyValue) withDiacriticalMark: nxt third) iso8859s15Code. - Sensor - nextEvent; - nextEvent; - nextEvent ]. - "end: Combining diacritical marks (i.e. accents in the Linux VM)" - "start: Spurious LF after CR on Ctrl-Enter on Windows VM" - ((evtBuf fourth = EventSensor eventKeyChar and: [ evtBuf third = 13 ]) and: [ - nxt fourth = EventSensor eventKeyChar and: [ nxt third = 10 ]]) ifTrue: [ Sensor nextEvent - "print " ]]. - modifiers _ evtBuf fifth. - pressType _ evtBuf fourth. - pressType = EventSensor eventKeyDown ifTrue: [ - type _ #keyDown. - lastKeyDownValue _ keyValue ]. - pressType = EventSensor eventKeyUp ifTrue: [ type _ #keyUp ]. - pressType = EventSensor eventKeyChar ifTrue: [ - type _ #keystroke. - "If Control key pressed, and the VM answers a code below 27, - it means it did the translation, convert it back to regular character: - We want to handle the meaning of ctrl ourselves." - (modifiers anyMask: 2) ifTrue: [ - "Control key pressed" - keyValue < 27 ifTrue: [ - "But we don't want to do it for Home/End/PgUp/PgDn, just for alphabetic keys" - lastKeyDownValue = keyValue ifFalse: [ - "If equal, real Home/End/PgUp/PgDn in Windows => don't translate" - (keyValue + 64 = lastKeyDownValue or: [ "If Equal, Ctrl-alphabetic in Windows => do translate" - lastKeyDownValue < 47 ]) ifTrue: [ - "Not on windows. If less (not sure about the bound, but do not translate 48: tab on Mac), alphabetic on Mac => do translate" - keyValue _ (modifiers anyMask: 1) - ifTrue: [ keyValue + 64 ] - ifFalse: [ keyValue + 96 - "shift not pressed: conver to lowercase letter" ]]]]. - "Act as if command/alt was pressed for some usual Windows ctrl-key combinations" - (self shouldControlEmulateAltFor: keyValue) ifTrue: [ modifiers _ modifiers bitOr: 8 ]]]. - buttons _ modifiers bitShift: 3. - (modifiers = 2 and: [ - keyValue - between: (Preferences ctrlArrowsScrollHorizontally ifTrue: [28] ifFalse: [30]) - and: 31]) - ifTrue: [ "We're hijacking ctl-up/down arrow since that is what the VM sends us for scroll events. We're going to convert these to MouseScrollEvent and throw away the keyboard event" - "ThisPrecludes the use of up and down arrows with control, that are standard keystrokes in Windows to control the cursor. - But as Linux, Mac and Windows VMs generate ctrl-up and ctrl-down for mouse wheel events, we must honor them. - Some day, it would be good for the VMs to report mouse wheel events differently fom ctrl-up & ctrl-down..." - "Also do ctrl-left and ctrl-right for horizontal scroll." - ^ MouseScrollEvent new - setType: #mouseScroll - position: self morphPosition - direction: - (keyValue caseOf: { - "Implementing as a caseof to allow for easy adding of left/right/other events should they become available" - [ 30 ] -> [ #up ]. - [ 31 ] -> [ #down ]. - [ 28 ] -> [ #left ]. - [ 29 ] -> [ #right ]. - }) - buttons: buttons - hand: self - stamp: stamp ] - ifFalse: [ ^ KeyboardEvent new - setType: type - buttons: buttons - position: self morphPosition - keyValue: keyValue - hand: self - stamp: stamp ].! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3204-ByDefault-ctrlLeftRight-jumpsWords-JuanVuletich-2017Oct30-10h28m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3204] on 1 November 2017 at 3:31:08 pm'! -!Character methodsFor: 'accessing' stamp: 'jmv 8/11/2016 09:46:09' prior: 16800406! - nonImmediateNumericValue - "Answer the numeric value of the receiver, if instances happen to be regular (i.e. not in Spur)" - - ^self instVarAt: 1! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3205-Dummy-JuanVuletich-2017Nov01-15h29m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3205] on 1 November 2017 at 4:07:42 pm'! - -MessageSet subclass: #ProtocolBrowser - instanceVariableNames: 'selectiveClassListIndex selectiveClassList baseClass selectedName exclude ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Browser'! - -!classDefinition: #ProtocolBrowser category: #'Tools-Browser'! -MessageSet subclass: #ProtocolBrowser - instanceVariableNames: 'selectiveClassListIndex selectiveClassList baseClass selectedName exclude' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Browser'! - -MessageSetWindow subclass: #ProtocolBrowserWindow - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Tools'! - -!classDefinition: #ProtocolBrowserWindow category: #'Morphic-Tools'! -MessageSetWindow subclass: #ProtocolBrowserWindow - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Tools'! -!ProtocolBrowserWindow commentStamp: '' prior: 0! - A view of the messages available to a class from itself upward through the class hierarchy. The viewed protocol can be pruned by selecting a superclass in the class hierchy pane.! -!ProtocolBrowser methodsFor: 'accessing' stamp: 'dhn 10/31/2017 17:06:51'! - labelString - "Answer the string for the window title" - - ^ 'Protocol for: ', baseClass name, ' up to: ', selectedName! ! -!ProtocolBrowser methodsFor: 'private' stamp: 'dhn 10/31/2017 17:38:39'! - hierarchyForClass: aClass - "Set the class hierarchy for the list pane" - | tab | - - selectiveClassList _ OrderedCollection new. - tab _ ''. - aClass withAllSuperclasses reverse do: [:ea | - selectiveClassList add: tab , ea name. - tab _ tab , ' ']. - self classListIndex: 0! ! -!ProtocolBrowser methodsFor: 'private' stamp: 'dhn 10/31/2017 16:56:42'! - protocolFor: anIndex - "Change the listed protocol" - - exclude _ OrderedCollection new. - anIndex > 0 - ifTrue: [ - selectedName _ (selectiveClassList at: anIndex) withBlanksTrimmed. - (1 to: anIndex - 1) do: [:ix | - exclude addLast: (selectiveClassList at: ix) withBlanksTrimmed]] - ifFalse: [ - selectedName _ nil. - ]. - self on: baseClass. - self changed: #relabel! ! -!ProtocolBrowser methodsFor: 'private' stamp: 'dhn 10/30/2017 15:40:07'! - selectiveClassList - "Answer the value of selectiveClassList" - - ^ selectiveClassList! ! -!ProtocolBrowser methodsFor: 'private' stamp: 'dhn 10/30/2017 17:02:13'! -selectiveClassListIndex - "Answer the value of selectiveClassListIndex" - - selectiveClassListIndex ifNil: [selectiveClassListIndex _ 0]. - ^ selectiveClassListIndex! ! -!ProtocolBrowser methodsFor: 'private' stamp: 'dhn 10/30/2017 17:02:28'! - selectiveClassListIndex: anObject - "Set the value of selectiveClassListIndex" - - selectiveClassListIndex _ anObject. - self protocolFor: selectiveClassListIndex -! ! -!ProtocolBrowser methodsFor: 'initialization' stamp: 'dhn 10/31/2017 15:03:26'! - initialize - - exclude _ OrderedCollection new! ! -!ProtocolBrowserWindow methodsFor: 'GUI building' stamp: 'dhn 10/30/2017 17:28:22'! - buildMorphicWindow - "Answer a morphic window that can display the receiver with a class hierarchy" - | topRow | - - topRow _ LayoutMorph newRow. - topRow - addMorph: self buildSelectiveClassList proportionalWidth: 0.3; - addAdjusterMorph; - addMorph: self buildMorphicMessageList proportionalWidth: 0.7. - self layoutMorph - addMorph: topRow proportionalHeight: 0.2; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.8. - model changed: #editSelection! ! -!ProtocolBrowserWindow methodsFor: 'GUI building' stamp: 'dhn 10/30/2017 16:56:49'! - buildSelectiveClassList - "Define the class hierarchy list pane" - - ^PluggableListMorph - model: model - listGetter: #selectiveClassList - indexGetter: #selectiveClassListIndex - indexSetter: #selectiveClassListIndex:! ! -!ProtocolBrowserWindow methodsFor: 'updating' stamp: 'dhn 10/30/2017 19:23:00'! - update: aSymbol - "Respond to events of the Dependency Mechanism" - - super update: aSymbol. - aSymbol == #relabel - ifTrue: [self setLabel: model labelString]! ! -!ProtocolBrowser methodsFor: 'private' stamp: 'dhn 10/31/2017 16:33:52' prior: 16896671! - initListFrom: selectorCollection highlighting: aClass - "Make up the messageList with items from aClass in boldface." - | defClass item | - - messageList _ OrderedCollection new. - selectorCollection do: [ :selector | - defClass _ aClass whichClassIncludesSelector: selector. - item _ selector, ' (' , defClass name , ')'. - defClass == aClass ifTrue: [item _ item asText allBold]. - messageList add: ( - MethodReference new - setClass: defClass - methodSymbol: selector - stringVersion: item)]. - self hierarchyForClass: (baseClass _ aClass)! ! -!ProtocolBrowser methodsFor: 'private' stamp: 'dhn 10/31/2017 18:08:50' prior: 16896690! - on: aClass - "Initialize the protocol for the class, aClass." - "Optionally, the upper part of the protocol is excluded." - | selectors | - - selectors _ Set new. - aClass withAllSuperclasses do: [ :each | - (exclude includes: each name) ifFalse: [selectors addAll: each selectors]]. - self - initListFrom: selectors asArray sort - highlighting: aClass! ! -!CodeWindow methodsFor: 'menu commands' stamp: 'dhn 10/30/2017 16:28:04' prior: 16813280! - browseFullProtocol - "Create and schedule a new protocol browser on the currently selected class or meta." - - | aPBrowser label | - model selectedClassOrMetaClass ifNotNil: [ :classOrMetaclass | - aPBrowser _ ProtocolBrowser new on: classOrMetaclass. - label _ 'Entire protocol of: ', classOrMetaclass name. - ProtocolBrowserWindow open: aPBrowser label: label ]! ! - -MessageSet subclass: #ProtocolBrowser - instanceVariableNames: 'baseClass selectiveClassList selectiveClassListIndex selectedName exclude' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Browser'! - -!classDefinition: #ProtocolBrowser category: #'Tools-Browser'! -MessageSet subclass: #ProtocolBrowser - instanceVariableNames: 'baseClass selectiveClassList selectiveClassListIndex selectedName exclude' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Browser'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3206-EnhancedProtocolBrowser-DanNorton-2017Nov01-16h05m-dhn.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3206] on 3 November 2017 at 10:42:58 am'! -!Object methodsFor: 'system primitives' stamp: 'jmv 12/31/1969 21:14:14'! - instVarAtPrim73: index - "Primitive. Answer a fixed variable in an object. The numbering of the - variables corresponds to the named instance variables. Fail if the index - is not an Integer or is not the index of a fixed variable. Essential. See - Object documentation whatIsAPrimitive." - - - "Access beyond fixed variables." - ^self basicAt: index - self class instSize! ! -!Object methodsFor: 'system primitives' stamp: 'jmv 12/31/1969 21:15:46'! - instVarAtPrim74: anInteger put: anObject - "Primitive. Store a value into a fixed variable in the receiver. The - numbering of the variables corresponds to the named instance variables. - Fail if the index is not an Integer or is not the index of a fixed variable. - Answer the value stored as the result. Using this message violates the - principle that each object has sovereign control over the storing of - values into its instance variables. Essential. See Object documentation - whatIsAPrimitive." - - - "Access beyond fixed fields" - ^self basicAt: anInteger - self class instSize put: anObject! ! -!Object methodsFor: 'system primitives' stamp: 'jmv 12/31/1969 21:17:57' prior: 16882332! - instVarAt: index - "Primitive. Answer a fixed variable in an object. The numbering of the variables - corresponds to the named instance variables, followed by the indexed instance - variables. Fail if the index is not an Integer or is not the index of a fixed variable. - Essential. See Object documentation whatIsAPrimitive." - - - "The classic InterpreterVMs don't support primitives 173 and 174. - See http://forum.world.st/Some-test-where-Spur-more-slow-than-Cog-td4867810.html#a4867888 - Use primitives 73 and 74 in such case." - Smalltalk isRunningCog ifFalse: [ - ^ self instVarAtPrim73: index ]. - self primitiveFailed! ! -!Object methodsFor: 'system primitives' stamp: 'jmv 12/31/1969 21:17:51' prior: 16882347! - instVarAt: index put: anObject - "Primitive. Store a value into a fixed variable in an object. The numbering of the - variables corresponds to the named instance variables, followed by the indexed - instance variables. Fail if the index is not an Integer or is not the index of a fixed - variable. Essential. See Object documentation whatIsAPrimitive." - - - "The classic InterpreterVMs don't support primitives 173 and 174. - See http://forum.world.st/Some-test-where-Spur-more-slow-than-Cog-td4867810.html#a4867888 - Use primitives 73 and 74 in such case." - Smalltalk isRunningCog ifFalse: [ - ^ self instVarAtPrim74: index put: anObject ]. - self primitiveFailed! ! -!Character methodsFor: 'accessing' stamp: 'jmv 8/11/2016 09:46:09' prior: 50374560! - nonImmediateNumericValue - "Answer the numeric value of the receiver, if instances happen to be regular (i.e. not in Spur)" - - ^self instVarAt: 1! ! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jmv 12/31/1969 21:13:09' prior: 16920989! - interpreterClass - "Interpreter class (Cog VM only) - nil for classic Interpreter VM - " - ^self getSystemAttribute: 1007! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3207-MakeCuisWorkOnInterpreterVM-JuanVuletich-2017Nov03-10h42m-jmv.1.cs.st----! - -----SNAPSHOT----#(3 November 2017 11:15:54.791933 am) Cuis5.0-3207-v3.image priorSource: 1341028! - -----QUIT----#(3 November 2017 11:16:05.949731 am) Cuis5.0-3207-v3.image priorSource: 1383370! - -----STARTUP----#(28 November 2017 3:35:55.816335 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3207-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3207] on 10 November 2017 at 11:08:35 am'! -!HandMorph methodsFor: 'private events' stamp: 'jmv 11/10/2017 11:07:46' prior: 50374431! - generateKeyboardEvent: evtBuf - "Generate the appropriate mouse event for the given raw event buffer" - | buttons modifiers type keyValue pressType stamp | - stamp _ evtBuf second. - stamp = 0 ifTrue: [ stamp _ Time localMillisecondClock ]. - (evtBuf sixth <= 0 or: [ (keyValue _ Character iso8859s15CodeForUnicodeCodePoint: evtBuf sixth) isNil ]) ifTrue: [ keyValue _ Character macRomanToLatin1: evtBuf third ]. - Sensor peekEvent ifNotNil: [ :nxt | - "start: Combining diacritical marks (i.e. accents in the Linux VM)" - (nxt fourth = EventSensor eventKeyDown and: [ nxt third > 255 ]) ifTrue: [ - keyValue _ ((Character numericValue: keyValue) withDiacriticalMark: nxt third) iso8859s15Code. - Sensor - nextEvent; - nextEvent; - nextEvent ]. - "end: Combining diacritical marks (i.e. accents in the Linux VM)" - "start: Spurious LF after CR on Ctrl-Enter on Windows VM" - ((evtBuf fourth = EventSensor eventKeyChar and: [ evtBuf third = 13 ]) and: [ - nxt fourth = EventSensor eventKeyChar and: [ nxt third = 10 ]]) ifTrue: [ Sensor nextEvent - "print " ]]. - modifiers _ evtBuf fifth. - pressType _ evtBuf fourth. - pressType = EventSensor eventKeyDown ifTrue: [ - type _ #keyDown. - lastKeyDownValue _ keyValue ]. - pressType = EventSensor eventKeyUp ifTrue: [ type _ #keyUp ]. - pressType = EventSensor eventKeyChar ifTrue: [ - type _ #keystroke. - "If Control key pressed, and the VM answers a code below 27, - it means it did the translation, convert it back to regular character: - We want to handle the meaning of ctrl ourselves." - (modifiers anyMask: 2) ifTrue: [ - "Control key pressed" - keyValue < 27 ifTrue: [ - "But we don't want to do it for Home/End/PgUp/PgDn, just for alphabetic keys" - lastKeyDownValue = keyValue ifFalse: [ - "If equal, real Home/End/PgUp/PgDn in Windows => don't translate" - (keyValue + 64 = lastKeyDownValue or: [ "If Equal, Ctrl-alphabetic in Windows => do translate" - lastKeyDownValue < 47 ]) ifTrue: [ - "Not on windows. If less (not sure about the bound, but do not translate 48: tab on Mac), alphabetic on Mac => do translate" - keyValue _ (modifiers anyMask: 1) - ifTrue: [ keyValue + 64 ] - ifFalse: [ keyValue + 96 - "shift not pressed: conver to lowercase letter" ]]]]. - "Act as if command/alt was pressed for some usual Windows ctrl-key combinations" - (self shouldControlEmulateAltFor: keyValue) ifTrue: [ modifiers _ modifiers bitOr: 8 ]]]. - buttons _ modifiers bitShift: 3. - ((modifiers anyMask: 2) and: [ - keyValue - between: (Preferences ctrlArrowsScrollHorizontally ifTrue: [28] ifFalse: [30]) - and: 31]) - ifTrue: [ "We're hijacking ctl-up/down arrow since that is what the VM sends us for scroll events. We're going to convert these to MouseScrollEvent and throw away the keyboard event" - "ThisPrecludes the use of up and down arrows with control, that are standard keystrokes in Windows to control the cursor. - But as Linux, Mac and Windows VMs generate ctrl-up and ctrl-down for mouse wheel events, we must honor them. - Some day, it would be good for the VMs to report mouse wheel events differently fom ctrl-up & ctrl-down..." - "Also do ctrl-left and ctrl-right for horizontal scroll." - ^ MouseScrollEvent new - setType: #mouseScroll - position: self morphPosition - direction: - (keyValue caseOf: { - "Implementing as a caseof to allow for easy adding of left/right/other events should they become available" - [ 30 ] -> [ #up ]. - [ 31 ] -> [ #down ]. - [ 28 ] -> [ #left ]. - [ 29 ] -> [ #right ]. - }) - buttons: buttons - hand: self - stamp: stamp ] - ifFalse: [ ^ KeyboardEvent new - setType: type - buttons: buttons - position: self morphPosition - keyValue: keyValue - hand: self - stamp: stamp ].! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3208-MouseScrollOnMacFix-JuanVuletich-2017Nov10-11h07m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3207] on 10 November 2017 at 11:19:54 am'! - -SystemWindow subclass: #WorkspaceWindow - instanceVariableNames: 'acceptDroppedMorphs ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Tools'! - -!classDefinition: #WorkspaceWindow category: #'Morphic-Tools'! -SystemWindow subclass: #WorkspaceWindow - instanceVariableNames: 'acceptDroppedMorphs' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Tools'! -!Morph methodsFor: 'accessing - properties' stamp: 'jmv 11/10/2017 11:14:34'! -objectForWorkspace - ^self! ! -!InspectorWindow methodsFor: 'accessing' stamp: 'jmv 11/10/2017 11:15:23'! - objectForWorkspace - ^model object! ! -!ObjectExplorerWindow methodsFor: 'accessing' stamp: 'jmv 11/10/2017 11:19:10'! - objectForWorkspace - ^model rootObject! ! -!Morph methodsFor: 'accessing - properties' stamp: 'jmv 11/10/2017 11:16:44' prior: 16874017! - nameForWorkspace - "Answer a name suitable for a Workspace variable" - | displayName object | - object _ self objectForWorkspace. - displayName := object name. - ^ displayName - ifNotNil: [ | name | - name := displayName asIdentifier: false. - (name size < 1) - ifTrue: [ object class name asLowercase , object identityHash asString ] - ifFalse: [ name at: 1 put: (name at: 1) asLowercase. name ] - ] - ifNil: [ object class name asLowercase , object identityHash asString ]! ! -!WorkspaceWindow methodsFor: 'menu' stamp: 'jmv 11/10/2017 11:10:18' prior: 16945502! - addCustomMenuItems: aCustomMenu hand: aHandMorph - super addCustomMenuItems: aCustomMenu hand: aHandMorph. - aCustomMenu addLine. - aCustomMenu - add: 'reset variables' - target: model - action: #initializeBindings. - aCustomMenu - addUpdating: #mustDeclareVariableWording - target: model - action: #toggleVariableDeclarationMode. - aCustomMenu - addUpdating: #toggleStylingLabel - target: model - action: #toggleStyling! ! -!WorkspaceWindow methodsFor: 'menu' stamp: 'jmv 11/10/2017 11:10:38' prior: 16945530! - offerWindowMenu - | aMenu | - aMenu _ self buildWindowMenu. - aMenu addLine. - aMenu - add: 'reset variables' - target: model - action: #initializeBindings. - aMenu - addUpdating: #mustDeclareVariableWording - target: model - action: #toggleVariableDeclarationMode. - aMenu - addUpdating: #toggleStylingLabel - target: model - action: #toggleStyling. - aMenu popUpInWorld: self world! ! -!WorkspaceWindow methodsFor: 'drag n drop' stamp: 'jmv 11/10/2017 11:09:41' prior: 16945548! - allowsMorphDrop - "Answer whether we accept dropping morphs. By default answer false." - - ^ true! ! -!WorkspaceWindow methodsFor: 'drag n drop' stamp: 'jmv 11/10/2017 11:17:29' prior: 16945554! - wantsDroppedMorph: aMorph event: evt - "Dropping a morph on my window means: - display exteral name for aMorph in Workspace - add a binding from name to aMorph - and rejecting the drop." - - | objectName textModelMorph object | - objectName := aMorph nameForWorkspace. - object _ aMorph objectForWorkspace. - textModelMorph := self layoutMorph submorphs at: 1. - - (self model bindingOf: objectName) value: object. - textModelMorph editor afterSelectionInsertAndSelect: objectName , ' '. - "send aMorph back to original position" - evt isNil ifFalse: [ evt wasHandled: true ]. - "Short circuit" - aMorph rejectDropMorphEvent: evt. - - ^ false ! ! - -WorkspaceWindow removeSelector: #allowsMorphDropWording! - -WorkspaceWindow removeSelector: #allowsMorphDropWording! - -WorkspaceWindow removeSelector: #initialize! - -WorkspaceWindow removeSelector: #initialize! - -WorkspaceWindow removeSelector: #toggleAcceptDroppedMorphs! - -WorkspaceWindow removeSelector: #toggleAcceptDroppedMorphs! - -SystemWindow subclass: #WorkspaceWindow - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Tools'! - -!classDefinition: #WorkspaceWindow category: #'Morphic-Tools'! -SystemWindow subclass: #WorkspaceWindow - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Tools'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3209-InspectorExplorerDnDOnWorkspace-JuanVuletich-2017Nov10-11h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3209] on 12 November 2017 at 9:07:35 pm'! -!Morph methodsFor: 'accessing - properties' stamp: 'jmv 11/12/2017 20:56:19'! - objectsForWorkspace - ^{self}! ! -!InspectorWindow methodsFor: 'accessing' stamp: 'jmv 11/12/2017 21:00:55'! - objectsForWorkspace - ^{self. model object. model selection}! ! -!ObjectExplorerWindow methodsFor: 'accessing' stamp: 'jmv 11/12/2017 21:00:29'! - objectsForWorkspace - ^{self. model rootObject. model object}! ! -!WorkspaceWindow methodsFor: 'drag n drop' stamp: 'jmv 11/12/2017 20:57:38'! - nameForObject: object - "Answer a name suitable for a Workspace variable" - object name ifNotNil: [ :displayName | - ^displayName asIdentifier: false ]. - ^ object class name asLowercase , object identityHash asString! ! -!WorkspaceWindow methodsFor: 'drag n drop' stamp: 'jmv 11/12/2017 20:44:49' prior: 50375096! - allowsMorphDrop - "Answer whether we accept dropping morphs. Workspaces always accept drops. - Regular morphs are inserted in the text. - Inspectors and Explorers generate workspace variables referencing the inspected object(s.)" - - ^ true! ! -!WorkspaceWindow methodsFor: 'drag n drop' stamp: 'jmv 11/12/2017 21:05:37' prior: 50375102! - wantsDroppedMorph: aMorph event: evt - "Dropping a morph on my window means: - display exteral name for aMorph in Workspace - add a binding from name to aMorph - and rejecting the drop." - - | textModelMorph | - textModelMorph := self layoutMorph submorphs at: 1. - aMorph objectsForWorkspace do: [ :object | | objectName | - objectName _ self nameForObject: object. - (self model bindingOf: objectName) value: object. - textModelMorph editor afterSelectionInsertAndSelect: String newLineString, objectName , '. ' ]. - "send aMorph back to original position" - evt isNil ifFalse: [ evt wasHandled: true ]. - "Short circuit" - aMorph rejectDropMorphEvent: evt. - - ^ false ! ! - -ObjectExplorerWindow removeSelector: #objectForWorkspace! - -ObjectExplorerWindow removeSelector: #objectForWorkspace! - -InspectorWindow removeSelector: #objectForWorkspace! - -InspectorWindow removeSelector: #objectForWorkspace! - -Morph removeSelector: #nameForWorkspace! - -Morph removeSelector: #nameForWorkspace! - -Morph removeSelector: #objectForWorkspace! - -Morph removeSelector: #objectForWorkspace! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3210-DnDOnWorkspaceEnhancements-JuanVuletich-2017Nov12-20h44m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3210] on 12 November 2017 at 10:28:26 pm'! -!BlockClosure methodsFor: 'lambda calculus' stamp: 'jmv 11/12/2017 22:27:40'! - curried - " - https://en.wikipedia.org/wiki/Currying - [ :a :b | a + b ] value: 1 value: 2 - [ :a :b | a + b ] curried value: 1 :: value: 2 - " - ^self argumentCount caseOf: { - [ 1] -> [[ :arg1 | [ self value: arg1 ]]]. - [ 2] -> [[ :arg1 | [ :arg2 | self value: arg1 value: arg2 ]]]. - [ 3] -> [[ :arg1 | [ :arg2 :arg3 | self value: arg1 value: arg2 value: arg3 ]]]. - [ 4] -> [[ :arg1 | [ :arg2 :arg3 :arg4 | self value: arg1 value: arg2 value: arg3 value: arg4 ]]] } - otherwise: [ self halt ]! ! -!BlockClosure methodsFor: 'lambda calculus' stamp: 'jmv 11/12/2017 22:27:57'! - withFirstArg: arg1 - " - https://en.wikipedia.org/wiki/Partial_application - - [ :a :b | a + b ] value: 1 value: 2 - [ :a :b | a + b ] withFirstArg: 1 - ([ :a :b | a + b ] withFirstArg: 1) value: 2 - ([ :a :b | a + b ] withFirstArg: 1) withFirstArg: 2 - (([ :a :b | a + b ] withFirstArg: 1) withFirstArg: 2) value - - ([ :a :b | a - b ] withFirstArg: 1) value: 2 - " - ^self argumentCount caseOf: { - [ 1] -> [[ self value: arg1 ]]. - [ 2] -> [[ :arg2 | self value: arg1 value: arg2 ]]. - [ 3] -> [[ :arg2 :arg3 | self value: arg1 value: arg2 value: arg3 ]]. - [ 4] -> [[ :arg2 :arg3 :arg4 | self value: arg1 value: arg2 value: arg3 value: arg4 ]] } - otherwise: [ self halt ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3211-lambdaCalculusToys-JuanVuletich-2017Nov12-22h27m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3211] on 14 November 2017 at 2:06:38 pm'! -!DisplayScreen methodsFor: 'other' stamp: 'jmv 11/14/2017 14:04:10' prior: 16835265! - restoreAfter: aBlock - " - - Evaluate the block - - Update host OS Display - - Wait for a mouse click - - And then restore the Morphic World" - - aBlock value. - self forceToScreen. - Sensor waitButton. - self runningWorld ifNotNil: [ :w | w fullRepaintNeeded ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3212-restoreAfter-fix-JuanVuletich-2017Nov14-14h04m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3212] on 19 November 2017 at 11:38:44 am'! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'jmv 11/19/2017 11:33:31' prior: 50363260! - initialExtent - - ^`540@400` * Preferences standardCodeFont height // 14! ! -!ChangeSorterWindow methodsFor: 'GUI building' stamp: 'jmv 11/19/2017 11:34:12' prior: 50363264! - initialExtent - ^`540@300` * Preferences standardCodeFont height // 14! ! -!PreDebugWindow methodsFor: 'GUI building' stamp: 'jmv 11/19/2017 11:36:45' prior: 50363268! - initialExtent - ^ `640 @ 320` * Preferences standardCodeFont height // 14! ! -!InspectorWindow methodsFor: 'GUI building' stamp: 'jmv 11/19/2017 11:36:58' prior: 50363272! - initialExtent - - ^`600@325` * Preferences standardCodeFont height // 14! ! -!ObjectExplorerWindow methodsFor: 'GUI building' stamp: 'jmv 11/19/2017 11:37:06' prior: 50363276! - initialExtent - - ^`300@500` * Preferences standardCodeFont height // 14! ! -!LayoutMorph methodsFor: 'adjust' stamp: 'jmv 11/19/2017 11:25:32' prior: 16863061! - adjustHorizontallyBy: aLayoutAdjustMorph at: aPoint - | delta l ls r rs lNewWidth rNewWidth i lCurrentWidth rCurrentWidth | - i _ submorphs indexOf: aLayoutAdjustMorph. - l _ self submorphs at: i +1. - ls _ l layoutSpec. - lCurrentWidth _ l morphWidth max: 1. "avoid division by zero" - r _ self submorphs at: i - 1. - rs _ r layoutSpec. - rCurrentWidth _ r morphWidth max: 1. "avoid division by zero" - delta _ aPoint x - aLayoutAdjustMorph referencePosition x. - delta _ delta max: l minPaneWidthForReframe - lCurrentWidth. - delta _ delta min: rCurrentWidth - r minPaneWidthForReframe. - delta = 0 ifTrue: [ ^self ]. - rNewWidth _ rCurrentWidth - delta. - lNewWidth _ lCurrentWidth + delta. - (ls isProportionalWidth and: [ rs isProportionalWidth ]) - ifTrue: [ "If both proportional, update them" - ls setProportionalWidth: (1.0 * lNewWidth / lCurrentWidth * ls proportionalWidth). - rs setProportionalWidth: (1.0 * rNewWidth / rCurrentWidth * rs proportionalWidth) ] - ifFalse: ["If at least one is fixed, update only the fixed" - ls isProportionalWidth ifFalse: [ - ls fixedOrMorphWidth: lNewWidth ]. - rs isProportionalWidth ifFalse: [ - rs fixedOrMorphWidth: rNewWidth ]]. - self layoutSubmorphs.! ! -!LayoutMorph methodsFor: 'private' stamp: 'jmv 11/19/2017 11:27:34' prior: 16863565! - minPaneWidthForReframe - - ^(self submorphs collect: [ :m | m minimumExtent x ]) max! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3213-FixColumnarResize-JuanVuletich-2017Nov19-11h10m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3213] on 19 November 2017 at 11:43:25 am'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 11/19/2017 11:43:05' prior: 50335858! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3214-AddJavierAsKnownAuthor-JuanVuletich-2017Nov19-11h43m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3207] on 18 November 2017 at 2:30:36 pm'! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'JO 11/18/2017 14:28:55' prior: 50368267! - buildMorphicWindow - " - CodePackageListWindow open: CodePackageList new - " - | dirtyFlags names fileNames upperRow description summary backColor labelBackground | - backColor := self textBackgroundColor. - labelBackground := Theme current background. - - dirtyFlags := PluggableListMorph - model: model - listGetter: #packageDirtyFlags - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - dirtyFlags color: backColor. - dirtyFlags := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: ' Unsaved?'); - addMorphUseAll: dirtyFlags. - - names := PluggableListMorph - model: model - listGetter: #packageNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - names color: backColor. - names := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: ' Package Name'); - addMorphUseAll: names. - - fileNames := PluggableListMorph - model: model - listGetter: #packageFullNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - fileNames color: backColor. - fileNames := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: ' File Name'); - addMorphUseAll: fileNames. - - upperRow := LayoutMorph newRow. - upperRow - addMorph: dirtyFlags proportionalWidth: 0.13; - addAdjusterAndMorph: names proportionalWidth: 0.27; - addAdjusterAndMorph: fileNames proportionalWidth: 0.6. - - description := TextModelMorph - textProvider: model - textGetter: #description - textSetter: #description:. - - summary := TextModelMorph - textProvider: model - textGetter: #summary. - - self layoutMorph - addMorph: upperRow proportionalHeight: 0.6; - addAdjusterAndMorph: self buildButtonPane fixedHeight: Theme current buttonPaneHeight; - addAdjusterAndMorph: summary fixedHeight: 60; - addAdjusterAndMorph: description proportionalHeight: 0.25; - addAdjusterAndMorph: self buildRequirementsPane proportionalHeight: 0.15. - self setLabel: 'Installed Packages'! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3215-CodePackageListWindow-cleanup-JavierOlaechea-2017Nov18-14h22m-JO.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3208] on 19 November 2017 at 12:34:29 am'! -!ChangeSorterWindow class methodsFor: 'instance creation' stamp: 'JO 11/18/2017 23:13:44' prior: 16800331! - openChangeSorter - self - open: ChangeSorter new - label: nil.! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'JO 11/18/2017 22:23:10' prior: 16934823! - changesMenu - "Build the changes menu for the world." - - | menu | - menu _ self menu: 'Changes...'. - self fillIn: menu from: { - { 'Change Sorter' . {ChangeSorterWindow. #openChangeSorter}. 'Open a 3-paned changed-set viewing tool'}. - nil. - - { 'Install New Updates' . { ChangeSet. #installNewUpdates }. -'Install in the current image the new updates available -in directory named ./CoreUpdates -or in directory named ../Cuis-Smalltalk-Dev/CoreUpdates'}. - nil. - - { 'Browse my Changes' . { Smalltalk . #browseMyChanges }. - 'Browse all of my changes since the last time #condenseSources was run.'}. - { 'Recently logged Changes...' . { ChangeList . #browseRecentLog}.'Open a change-list browser on the latter part of the changes log. You can use this browser to recover logged changes which were not saved in your image, in the event of a crash or other interruption.'}. - - nil. - { 'Save World as morph file' . {self. #saveWorldInFile}. 'Save a file that, when reloaded, reconstitutes the current World.'}. - }. - ^ menu! ! - -TheWorldMenu removeSelector: #openChangeSorter1! - -TheWorldMenu removeSelector: #openChangeSorter1! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3216-WorldMenu-cleanup-JavierOlaechea-2017Nov18-22h23m-JO.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3212] on 21 November 2017 at 3:19:55 am'! - -Object immediateSubclass: #Character - instanceVariableNames: 'value ' - classVariableNames: 'CharacterTable ClassificationTable LetterBits LowercaseBit UnaccentedTable UnicodeCodePoints UppercaseBit LetterTruthTable UppercaseTruthTable LowercaseTruthTable LowercaseMappingTable UppercaseMappingTable ' - poolDictionaries: '' - category: 'Kernel-Text'! -!Character class methodsFor: 'class initialization' stamp: 'pb 11/21/2017 02:38:24'! - initializeLookupTables - LowercaseMappingTable _ Array new: 256. - LowercaseTruthTable _ Array new: 256. - UppercaseMappingTable _ Array new: 256. - UppercaseTruthTable _ Array new: 256. - LetterTruthTable _ Array new: 256. - UnaccentedTable _ ByteArray new: 256. - 0 - to: 255 - do: [ :idx | | char | - "Default to an identity mapping with a false truth mapping" - char _ self numericValue: idx. - LowercaseMappingTable - at: idx + 1 - put: char. - LowercaseTruthTable - at: idx + 1 - put: false. - UppercaseMappingTable - at: idx + 1 - put: char. - UppercaseTruthTable - at: idx + 1 - put: false. - LetterTruthTable - at: idx + 1 - put: false. - UnaccentedTable at: idx + 1 put: idx]. - "Now override as needed" - Character uppercaseLowercaseAndUnaccentedLetters do: [ :group | | uppercase lowercase | - group size > 1 - ifTrue: [ | lowercaseChar uppercaseChar | - uppercase _ group first numericValue. - lowercase _ group second numericValue. - lowercaseChar _ self numericValue: lowercase. - uppercaseChar _ self numericValue: uppercase. - LowercaseMappingTable - at: lowercase + 1 - put: lowercaseChar. - LowercaseMappingTable - at: uppercase + 1 - put: lowercaseChar. - LowercaseTruthTable - at: lowercase + 1 - put: true. - LetterTruthTable - at: lowercase + 1 - put: true. - UppercaseMappingTable - at: lowercase + 1 - put: uppercaseChar. - UppercaseMappingTable - at: uppercase + 1 - put: uppercaseChar. - UppercaseTruthTable - at: uppercase + 1 - put: true. - LetterTruthTable - at: uppercase + 1 - put: true. - group size > 2 - ifTrue: [|unaccentedUppercase unaccentedLowercase| - unaccentedUppercase _ group third numericValue. - unaccentedLowercase _ group fourth numericValue. - UnaccentedTable at: uppercase+1 put: unaccentedUppercase. - UnaccentedTable at: lowercase+1 put: unaccentedLowercase]] - ifFalse: [ | lowercaseChar | - lowercase _ group first numericValue. - lowercaseChar _ self numericValue: lowercase. - LowercaseMappingTable - at: lowercase + 1 - put: lowercaseChar. - UppercaseMappingTable - at: lowercase + 1 - put: lowercaseChar. - LowercaseTruthTable - at: lowercase + 1 - put: true. - UppercaseTruthTable - at: lowercase + 1 - put: false. - LetterTruthTable - at: lowercase + 1 - put: true ]].! ! -!Character class methodsFor: 'class initialization' stamp: 'pb 11/21/2017 02:24:51' prior: 16800735! - initClassCachedState - "Create the table of unique Characters. - Character initialize - " - self initializeClassificationTable. - self initializeLookupTables . - self initializeUnicodeCodePoints.! ! -!Character class methodsFor: 'fileIn/Out' stamp: 'pb 11/21/2017 02:26:23' prior: 16801502! - definition - "Special class definition for Character, SmallInteger and SmallFloat64 - Required to have the same definition both for preSpur and Spur, and to be compatible with both." - ^ -'Object immediateSubclass: #Character - instanceVariableNames: ''value'' - classVariableNames: ''CharacterTable ClassificationTable LetterBits LowercaseBit UnaccentedTable UnicodeCodePoints UppercaseBit LowercaseMappingTable LowercaseTruthTable UppercaseMappingTable UppercaseTruthTable LetterTruthTable'' - poolDictionaries: '''' - category: ''Kernel-Text'''! ! - -Object immediateSubclass: #Character - instanceVariableNames: 'value' - classVariableNames: 'CharacterTable ClassificationTable LetterBits LowercaseBit UnaccentedTable UnicodeCodePoints UppercaseBit LowercaseMappingTable LowercaseTruthTable UppercaseMappingTable UppercaseTruthTable LetterTruthTable' - poolDictionaries: '' - category: 'Kernel-Text'! - -Character initialize! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3217-Character-lookup-tables-stage1-PhilBellalouna-2017Nov21-00h32m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3212] on 21 November 2017 at 3:19:55 am'! -!Character methodsFor: 'testing' stamp: 'pb 11/21/2017 02:29:43' prior: 16800489! - isLetter - "Answer whether the receiver is a letter." - ^ LetterTruthTable at: self numericValue + 1! ! -!Character methodsFor: 'testing' stamp: 'pb 11/21/2017 02:24:10' prior: 16800504! - isLowercase - "Answer whether the receiver is a lowercase letter." - ^ LowercaseTruthTable at: self numericValue + 1.! ! -!Character methodsFor: 'testing' stamp: 'pb 11/21/2017 02:24:25' prior: 16800531! - isUppercase - "Answer whether the receiver is an uppercase letter." - ^ UppercaseTruthTable at: self numericValue + 1.! ! -!Character methodsFor: 'converting' stamp: 'pb 11/21/2017 02:22:41' prior: 16800596! - asLowercase - ^ LowercaseMappingTable at: self numericValue + 1.! ! -!Character methodsFor: 'converting' stamp: 'pb 11/21/2017 02:23:38' prior: 16800628! - asUppercase - "If the receiver is lowercase, answer its matching uppercase Character." - ^ UppercaseMappingTable at: self numericValue + 1.! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3218-Character-lookup-tables-stage2-PhilBellalouna-2017Nov21-00h32m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3214] on 21 November 2017 at 3:34:57 am'! -!Character class methodsFor: 'class initialization' stamp: 'pb 11/21/2017 03:33:45' prior: 50375805! - initClassCachedState - "Create the table of unique Characters. - Character initialize - " - self initializeLookupTables . - self initializeUnicodeCodePoints.! ! - -Character class removeSelector: #initializeClassificationTable! - -Character class removeSelector: #initializeClassificationTable! -!Character class methodsFor: 'fileIn/Out' stamp: 'pb 11/21/2017 03:34:29' prior: 50375814! - definition - "Special class definition for Character, SmallInteger and SmallFloat64 - Required to have the same definition both for preSpur and Spur, and to be compatible with both." - ^ -'Object immediateSubclass: #Character - instanceVariableNames: ''value'' - classVariableNames: ''CharacterTable UnaccentedTable UnicodeCodePoints LowercaseMappingTable LowercaseTruthTable UppercaseMappingTable UppercaseTruthTable LetterTruthTable'' - poolDictionaries: '''' - category: ''Kernel-Text'''! ! - -Object immediateSubclass: #Character - instanceVariableNames: 'value' - classVariableNames: 'CharacterTable UnaccentedTable UnicodeCodePoints LowercaseMappingTable LowercaseTruthTable UppercaseMappingTable UppercaseTruthTable LetterTruthTable' - poolDictionaries: '' - category: 'Kernel-Text'! - -Character initialize! - -Smalltalk recreateSpecialObjectsArray! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3219-Character-lookup-tables-stage3-PhilBellalouna-2017Nov21-03h32m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3207] on 19 November 2017 at 12:42:52 pm'! -!Float commentStamp: 'jmv 11/19/2017 12:42:42' prior: 50372885! - A note About Floating Point numbers and Floating Point Arithmetic. - -The following is not specific to Cuis or Smalltalk at all. This is about the properties of Float numbers in any computer implementation. - -If you haven't done so already, read https://en.wikipedia.org/wiki/Floating-point_arithmetic - -But if you find the Wikipedia article too detailed, or hard to read, then try http://fabiensanglard.net/floating_point_visually_explained/ (get past "How Floating Point are usually explained" and read "A different way to explain..."). - -Other great reads are: - "Why don't my numbers add up?": - http://floating-point-gui.de/ -and - "What Every Computer Scientist Should Know About Floating-Point Arithmetic": - http://docs.oracle.com/cd/E19957-01/806-3568/ncg_goldberg.html -and also maybe - "Comparing floating point numbers" - https://randomascii.wordpress.com/2012/02/25/comparing-floating-point-numbers-2012-edition/ - -Now that you read them, and we are on the same boat, some further comments (from jmv): - -Floats are (conceptually) approximate real numbers. That's why trig and other trascendental functions always answer Floats. That's why it is ok to round the result of operations. That's why Float is considered more general than Fraction in ST-80 and most Smalltalks. So, when we have a Float value, we must not think about it as a Rational but as a Real (actually as some unknown Real that could hopefully be close to the Rational we can actually represent). Keep this in mind when dealing with Floats, and especially avoid comparing them for equality. - -When doing mixed operations with Floats and Fractions, Cuis, as most other Smalltalks, converts all values to Floats. Some other systems, including Pharo Smalltalk, Scheme and Lisp have two rules: when the answer is a Number, they convert to Float. But when the answer is a boolean (#<, #=, #<=, etc.) they convert to Fraction. We think this is a mistake. There should never be implicit conversions from Float to Fraction. Fractions are to hold exact values, and people expect Fractions to be exact. On the other hand, Floats are to hold approximations (and people should be aware of that!!). But an implicit conversion from Float to Fraction would give a Fraction that should not be considered an exact value (the value comes from an inexact Float), but that knowledge is lost, as it is an instance of Fraction. - -If you want exact arithmetic, usual mathematical properties (like transitivity of equality), can live in the limited world of Rational numbers, and can afford a slight performance penalty, use Fraction instead. Avoid trascendental functions and never convert to Float. - -In any case, most numeric computation is done on Float numbers. There are good reasons for that. One is that in most cases we don't need an exact answer. And in many cases we can't really have it: the inputs to algorithms already have a limited precision, or they use trascendental functions. And even when exact arithmetic possible, if we are doing sound synthesis, 24 bits of resolution is enough. For image processing and graphics, the result is never more than 16 bits per channel. So, these fields don't really need 64 bit Doubles. 32 bit Floats are enough. Other fields do need 64 bit Doubles, like physics simulations and geometry. Games usually prefer special, faster 32 bit Float operations in GPUs that have greater errors but are faster. - -There are some things that can be done to increase the confidence you can have on Float results. One is to do an error propagation analysis on the code you are running. This is not easy, but it is done for any widely used numerical method. Then, you can know real bounds and/or estimates of the errors made. So, understanding your inputs and your algorithms (for example error propagation, condition number, numeric stability), and using Float number if appropriate, is the usual advice. - -Perhaps you have heard about "interval arithmetic". It is a bit better than simple Float, but doesn't really fix the problems. - -The ultimate solution is to do Monte Carlo analysis, with random perturbation of inputs. After the Monte Carlo run, it is needed to do statistical analysis of possible correlations between the distributions of the random noise added to imputs and the result of the algorithm. - -Additional food for thought: http://www.cs.berkeley.edu/~wkahan/Mindless.pdf . According to this, doing Monte Carlo as described above attacks a slightly different problem. This might be yet another reason (besides performance) to try something like the next paragraph. I (jmv) came up with it, and I don't really know if it has been described and or tried before or not. Mhhh. Maybe a defensive publication is in order. - -A possibility that could be a practical solution, being much cheaper than Monte Carlo, but better than interval arithmetic, is to represent each value by 2 Floats: an estimation of the real value (i.e. an estimation of the mean value of the distribution of the corresponding Monte Carlo result), and an estimation of the error (i.e. an estimation of the standard deviation of the corresponding Monte Carlo result). Or perhaps even 3 of them. In addition to the estimation of the real value and an estimation of the error, we could add a hard bound on the error. In many cases it will be useless, because the error can not really be bound. But in those cases where it is possible to bound it, applications could really know about the quality of computed values. - -======================================================================= - -My instances represent IEEE-754 floating-point double-precision numbers. They have about 16 decimal digits of accuracy and their range is between plus and minus 10^307. Some valid examples are: - - 8.0 13.3 0.3 2.5e6 1.27e-30 1.27e-31 -12.987654e12 - -Mainly: no embedded blanks, little e for tens power, and a digit on both sides of the decimal point. It is actually possible to specify a radix for Squeak Float constants. This is great for teaching about numbers, but may be confusing to the average reader: - - 3r20.2 --> 6.66666666666667 - 8r20.2 --> 16.25 - -If you don't have access to the definition of IEEE-754, you can figure out what is going on by printing various simple values in Float hex. It may help you to know that the basic format is... - sign 1 bit - exponent 11 bits with bias of 1023 (16r3FF) to produce an exponent - in the range -1023 .. +1024 - - 16r000: - significand = 0: Float zero - significand ~= 0: Denormalized number (exp = -1024, no hidden '1' bit) - - 16r7FF: - significand = 0: Infinity - significand ~= 0: Not A Number (NaN) representation - mantissa 53 bits, but only 52 are stored (20 in the first word, 32 in the second). This is because a normalized mantissa, by definition, has a 1 to the right of its floating point, and IEEE-754 omits this redundant bit to gain an extra bit of precision instead. People talk about the mantissa without its leading one as the FRACTION, and with its leading 1 as the SIGNFICAND. - -The single-precision format is... - sign 1 bit - exponent 8 bits, with bias of 127, to represent -126 to +127 - - 0x0 and 0xFF reserved for Float zero (mantissa is ignored) - - 16r7F reserved for Float underflow/overflow (mantissa is ignored) - mantissa 24 bits, but only 23 are stored -This format is used in FloatArray (qv), and much can be learned from the conversion routines, Float asIEEE32BitWord, and Float class fromIEEE32Bit:. - -You might also check https://en.wikipedia.org/wiki/IEEE_754_revision - -Other great reads (covering broader but interesting issues): -https://randomascii.wordpress.com/2013/07/16/floating-point-determinism/ -http://www.ima.umn.edu/2010-2011/W1.10-14.11/activities/Leeser-Miriam/Leeser-GPU-IMA-Jan2011.pdf! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3220-FloatCommentTweaks-JuanVuletich-2017Nov19-12h24m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3220] on 24 November 2017 at 12:18:25 pm'! -!SystemWindow methodsFor: 'accessing' stamp: 'jmv 11/24/2017 12:06:15'! - objectsForWorkspace - ^{}! ! -!InspectorWindow methodsFor: 'accessing' stamp: 'jmv 11/24/2017 12:16:02' prior: 50375158! - objectsForWorkspace - | root sel | - root _ model object. - sel _ model selection. - (root == sel or: [ model contentsIsString ]) ifTrue: [ - ^{root} ]. - ^{root. sel }! ! -!ObjectExplorerWindow methodsFor: 'accessing' stamp: 'jmv 11/24/2017 12:17:16' prior: 50375163! - objectsForWorkspace - | root sel | - root _ model rootObject. - sel _ model object. - (root == sel or: [ sel isNil ]) ifTrue: [ - ^{root} ]. - ^{root. sel }! ! -!WorkspaceWindow methodsFor: 'drag n drop' stamp: 'jmv 11/24/2017 12:08:35' prior: 50375189! - wantsDroppedMorph: aMorph event: evt - "Dropping a morph on my window means: - display exteral name for aMorph in Workspace - add a binding from name to aMorph - and rejecting the drop." - - | textModelMorph addedBindings | - textModelMorph := self layoutMorph submorphs at: 1. - addedBindings _ false. - aMorph objectsForWorkspace do: [ :object | | objectName | - addedBindings _ true. - objectName _ self nameForObject: object. - (self model bindingOf: objectName) value: object. - textModelMorph editor afterSelectionInsertAndSelect: String newLineString, objectName , '. ' ]. - addedBindings ifTrue: [ - "send aMorph back to original position" - evt isNil ifFalse: [ evt wasHandled: true ]. - "Short circuit" - aMorph rejectDropMorphEvent: evt ]. - - ^ false ! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3221-DropOnWorkspaceEnh-JuanVuletich-2017Nov24-12h06m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3221] on 26 November 2017 at 5:12:13 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 11/26/2017 17:11:34'! - minPaneWidthForReframe - ^ self minimumExtent x! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3222-FixDNUOnColumnResize-JuanVuletich-2017Nov26-17h10m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3222] on 28 November 2017 at 3:11:44 pm'! -!Object methodsFor: 'inspecting' stamp: 'jmv 11/28/2017 15:08:54'! - copyToClipboard - "Create and schedule an Inspector in which the user can examine the receiver's variables." - - Clipboard storeObject: self! ! -!TextModel methodsFor: 'testing' stamp: 'jmv 11/28/2017 14:52:16'! - canBindVariables - ^ false! ! -!Workspace methodsFor: 'variable declarations' stamp: 'jmv 11/28/2017 14:56:27'! - nameForObject: object - "Answer a name suitable for a Workspace variable" - object name ifNotNil: [ :displayName | - ^displayName asIdentifier: false ]. - ^ object class name asLowercase , object identityHash asString! ! -!Workspace methodsFor: 'testing' stamp: 'jmv 11/28/2017 14:52:28'! - canBindVariables - ^ true! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'jmv 11/28/2017 14:57:38'! - paste - | object objectName | - model canBindVariables ifTrue: [ - object _ Clipboard retrieveObject. - objectName _ model nameForObject: object. - (model bindingOf: objectName) value: object. - self replaceSelectionWith: objectName. - ^ self ]. - ^ super paste! ! -!InspectorWindow methodsFor: 'menu commands' stamp: 'jmv 11/28/2017 14:47:12'! - copySelectionToClipboard - "For example, for pasting a reference in a Workspace" - - Clipboard storeObject: model selection! ! -!ObjectExplorerWindow methodsFor: 'menu commands' stamp: 'jmv 11/28/2017 14:47:30'! - copySelectionToClipboard - "For example, for pasting a reference in a Workspace" - - Clipboard storeObject: model object! ! -!Editor methodsFor: 'menu messages' stamp: 'jmv 12/19/2011 12:24' prior: 16836376! - paste - "Paste the text from the shared buffer over the current selection and - redisplay if necessary." - - self replaceSelectionWith: self clipboardStringOrText! ! -!Morph methodsFor: 'debug and other' stamp: 'jmv 11/28/2017 15:07:24' prior: 16874207! - buildDebugMenu: aHand - "Answer a debugging menu for the receiver. The hand argument is seemingly historical and plays no role presently" - - | aMenu | - aMenu := MenuMorph new defaultTarget: self. - aMenu addStayUpIcons. - self isKnownFailing - ifTrue: [ - aMenu add: 'start drawing again' action: #resumeAfterDrawError. - aMenu addLine]. - (self hasProperty: #errorOnStep) - ifTrue: [ - aMenu add: 'start stepping again' action: #resumeAfterStepError. - aMenu addLine]. - aMenu add: 'inspect morph' action: #inspect. - aMenu add: 'inspect owner chain' action: #inspectOwnerChain. - self hasModel - ifTrue: [ - aMenu - add: 'inspect model' - target: self model - action: #inspect]. - aMenu - add: 'explore morph' - target: self - selector: #explore. - aMenu - add: 'copy to clipboard (c)' - target: self - selector: #copyToClipboard. - aMenu addLine. - aMenu - add: 'browse morph class' - target: self - selector: #browseClassHierarchy. - self hasModel - ifTrue: [ - aMenu - add: 'browse model class' - target: self model - selector: #browseClassHierarchy]. - aMenu addLine. - aMenu - add: 'edit balloon help' action: #editBalloonHelpText. - ^aMenu! ! -!InspectorWindow methodsFor: 'menu building' stamp: 'jmv 11/28/2017 14:44:33' prior: 16857251! - fieldListMenu - "Arm the supplied menu with items for the field-list of the receiver" - - | aMenu object | - aMenu _ MenuMorph new defaultTarget: self. - - aMenu addList: #( - ('inspect (i)' inspectSelection) - ('explore (I)' exploreSelection) - ('copy to clipboard (c)' copySelectionToClipboard) - ('basic inspect' inspectBasic) - ('references finder' openReferencesFinder) - ('weight explorer' openWeightExplorer)). - - object _ model object. - (object is: #Dictionary) ifTrue: [ aMenu addList: #( - - - ('senders of this key' sendersOfSelectedKey) - ('add key' addEntry) - ('rename key' renameEntry) - ('remove' removeSelection '' model)) ] - - ifFalse: [ (object is: #Set) ifTrue: [ aMenu addList: #( - - - ('remove' removeSelection '' model))]]. - - aMenu addList: #( - - - ('browse full (b)' browseMethodFull) - ('browse hierarchy (h)' browseHierarchy) - ('browse protocol (p)' browseFullProtocol)). - ^ aMenu! ! -!ObjectExplorerWindow methodsFor: 'building menus' stamp: 'jmv 11/28/2017 14:45:17' prior: 16883322! - genericMenu - "Borrow a menu from my inspector" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - model getCurrentSelection - ifNil: [ - aMenu - add: '*nothing selected*' - target: self - selector: #yourself] - ifNotNil: [ - aMenu addList: #( - ('inspect (i)' inspectSelection) - ('explore (I)' exploreSelection) - ('copy to clipboard (c)' copySelectionToClipboard) - ('basic inspect' inspectBasic) - ('references finder' openReferencesFinder) - ('weight explorer' openWeightExplorer) - - - ('browse full (b)' browseMethodFull) - ('browse hierarchy (h)' browseHierarchy) - ('browse protocol (p)' browseFullProtocol)). - aMenu addLine; - add: 'monitor changes' - target: self - selector: #monitor: - argument: model getCurrentSelection. - model class == ReferencesExplorer ifTrue: [ - aMenu addLine; - add: 'rescan' - target: self - selector: #rescan ]]. - model basicMonitorList isEmptyOrNil - ifFalse: [ - aMenu addLine; - add: 'stop monitoring all' - target: self - selector: #stopMonitoring ]. - ^ aMenu! ! -!Theme methodsFor: 'menus' stamp: 'jmv 11/28/2017 14:43:40' prior: 50344057! - basicIcons - - "Minimal menu scheme. - Theme current class beCurrent - " - - ^ { - #('open...') -> #openIcon. - #('windows...' 'find window' 'Focus follows mouse' 'Click to focus') -> #windowIcon. - #('help...' 'explain' 'about this system...' 'Terse Guide to Cuis' 'Class Comment Browser' 'Code management in Cuis' 'Using GitHub to host Cuis packages' ) -> #helpIcon. - #('themes...') -> #appearanceIcon. - #('do it (d)') -> #doItIcon. - #('new morph...' 'objects (o)' 'save world as morph file') -> #morphsIcon. - #('save' ) -> #saveIcon. - #('Save options...' 'save as...' 'change category...' 'rename change set (r)' 'rename') -> #saveAsIcon. - #('save as new version') -> #saveAsNewVersionIcon. - #('quit') -> #quitIcon. - #('save and quit' ) -> #saveAndQuitIcon. - #('inspect it (i)' 'inspect world' 'inspect model' 'inspect morph' - 'inspect owner chain' 'inspect' 'inspect (i)' 'basic inspect' 'message names' 'find message names' 'inspect instances' 'inspect subinstances' 'inspect change set' 'inspect context (c)' 'inspect receiver (i)' 'start CPUWatcher' 'stop CPUWatcher') - -> #inspectIcon. - #('explore' 'explore it (I)' 'explore world' 'explore morph' 'explore (I)' 'explore context (C)' 'explore receiver (I)' 'references finder' 'weight explorer' 'explore CompiledMethod') -> #exploreIcon. - #('find...(f)' 'find class... (f)' 'find method...' 'find recent submissions' 'show hierarchy' 'show definition' 'show comment' 'filter' 'filter message list...' 'find context... (f)') -> #findIcon. - #('add item...' 'new category...' 'create new change set...' 'new change set... (n)' 'add new file') -> #newIcon. - #('remove method (x)' 'remove' 'remove class (x)' 'remove method from system (x)' 'remove class from system (x)' 'remove postscript') -> #deleteIcon. - #('delete method from changeset (d)' 'delete class from change set (d)' 'destroy change set (X)' 'revert & remove from changes' 'delete unchanged windows' 'delete non windows' 'delete both of the above' 'reset variables' 'remove contained in class categories...' 'clear this change set' 'uninstall this change set' 'delete directory...' 'delete') -> #warningIcon. - #('do again (j)' 'Redo - multiple (Z)') -> #redoIcon. - #('undo (z)' 'revert to previous version' 'Undo - multiple (z)') -> #undoIcon. - #('copy to clipboard (c)' 'copy (c)' 'copy class...' 'copy class chgs to other side' 'copy method to other side' 'copy all to other side (c)' 'copy name to clipboard' 'copy selector to clipboard') -> #copyIcon. - #('paste (v)' 'Paste without Format') -> #pasteIcon. - #('cut (x)' 'move class chgs to other side' 'move method to other side' 'submerge into other side') -> #cutIcon. - #('paste...' 'icons...') -> #worldIcon. -}! ! - -WorkspaceWindow removeSelector: #allowsMorphDrop! - -WorkspaceWindow removeSelector: #allowsMorphDrop! - -WorkspaceWindow removeSelector: #nameForObject:! - -WorkspaceWindow removeSelector: #nameForObject:! - -WorkspaceWindow removeSelector: #wantsDroppedMorph:event:! - -WorkspaceWindow removeSelector: #wantsDroppedMorph:event:! - -ObjectExplorerWindow removeSelector: #objectsForWorkspace! - -ObjectExplorerWindow removeSelector: #objectsForWorkspace! - -InspectorWindow removeSelector: #objectsForWorkspace! - -InspectorWindow removeSelector: #objectsForWorkspace! - -SystemWindow removeSelector: #objectsForWorkspace! - -SystemWindow removeSelector: #objectsForWorkspace! - -Morph removeSelector: #objectsForWorkspace! - -Morph removeSelector: #objectsForWorkspace! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Theme current class beCurrent! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3223-UseClipboardToAddObjectsToWorkspaces-JuanVuletich-2017Nov28-14h43m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3223] on 28 November 2017 at 3:28:20 pm'! -!FeatureRequirement methodsFor: 'private' stamp: 'jmv 11/28/2017 15:27:34' prior: 16840895! - inPackagesSubtreeOf: aDirectoryEntry do: aBlock - - | pckDir morphicExamplesPckDir compatPckDir | - - "Look in the requested directory" - aBlock value: aDirectoryEntry. - - "Look in the usual Packages subfolders" - pckDir _ aDirectoryEntry / 'Packages'. - pckDir exists ifTrue: [ - aBlock value: pckDir ]. - morphicExamplesPckDir _ pckDir / 'MorphicExamples'. - morphicExamplesPckDir exists ifTrue: [ - aBlock value: morphicExamplesPckDir ]. - compatPckDir _ aDirectoryEntry / 'CompatibilityPackages'. - compatPckDir exists ifTrue: [ - aBlock value: compatPckDir ]. - - "Finally look in folders that follow the convention of naming package repositories - with the 'Cuis-Smalltalk' prefix, and their possible 'Packages' subdir." - aDirectoryEntry children do: [ :entry | - (entry isDirectory and: [ entry name beginsWith: 'Cuis-Smalltalk' ]) ifTrue: [ - aBlock value: entry. - pckDir _ entry / 'Packages'. - pckDir exists ifTrue: [ - aBlock value: pckDir ]. - morphicExamplesPckDir _ pckDir / 'MorphicExamples'. - morphicExamplesPckDir exists ifTrue: [ - aBlock value: morphicExamplesPckDir ]. - compatPckDir _ entry / 'CompatibilityPackages'. - compatPckDir exists ifTrue: [ - aBlock value: compatPckDir ]]]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3224-AutoFindMorphicExamples-JuanVuletich-2017Nov28-15h27m-jmv.1.cs.st----! - -----SNAPSHOT----#(28 November 2017 3:36:05.602441 pm) Cuis5.0-3224-v3.image priorSource: 1383469! - -----QUIT----#(28 November 2017 3:36:18.803729 pm) Cuis5.0-3224-v3.image priorSource: 1438500! - -----STARTUP----#(29 November 2017 12:06:29.460129 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3224-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3224] on 29 November 2017 at 11:59:54 am'! - -Object subclass: #Clipboard - instanceVariableNames: 'contents recent contentsOriginalObjectWeakly ' - classVariableNames: 'Default ' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #Clipboard category: #'System-Support'! -Object subclass: #Clipboard - instanceVariableNames: 'contents recent contentsOriginalObjectWeakly' - classVariableNames: 'Default' - poolDictionaries: '' - category: 'System-Support'! -!Clipboard methodsFor: 'accessing' stamp: 'jmv 11/29/2017 11:42:16'! - contentsOriginalObject - "If not nil, the original object (not a copy!!) of what was stored in the clipboard. See #storeObject: Use with care" - - ^ contentsOriginalObjectWeakly at: 1! ! -!Clipboard class methodsFor: 'default clipboard' stamp: 'jmv 11/29/2017 11:42:25'! - contentsOriginalObject - "If not nil, the original object (not a copy!!) of what was stored in the clipboard. See #storeObject: Use with care" - - ^ self default contentsOriginalObject! ! -!Object methodsFor: 'inspecting' stamp: 'jmv 11/29/2017 11:49:58' prior: 50376261! - copyToClipboard - - Clipboard storeObject: self! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'jmv 11/29/2017 11:55:10' prior: 50376285! - paste - | objectName | - - model canBindVariables ifTrue: [ - "Not a copy!!!!!!" - Clipboard contentsOriginalObject ifNotNil: [ :object | - objectName _ model nameForObject: object. - (model bindingOf: objectName) value: object. - self replaceSelectionWith: objectName. - ^ self ]]. - ^ super paste! ! -!Clipboard methodsFor: 'accessing' stamp: 'jmv 11/29/2017 11:36:45' prior: 16807752! - storeObject: anObject - "Set new contents on the clipboard. Also export to OS. - anObject can be a: - String - Text - Form - Morph - Object. - OS clipboard supports String. Other formats might be supported if ExtendedClipboardInterface is present and operative." - - | primitiveFormat id | - - "Store a copy of the object. This is appropriate in case the original object is modified after being copied to the clipboard. - Another copy must be made again when pasting, as the same object could be pasted many times. - Besides, store the original object, but weakly (so we don't prevent it GCed). The original object might be used in workspaces." - (anObject isString or: [ anObject is: #Text]) - ifTrue: [ - contents _ anObject withCuisLineEndings. - contentsOriginalObjectWeakly at: 1 put: nil ] - ifFalse: [ - contents _ anObject copyForClipboard. - contentsOriginalObjectWeakly at: 1 put: anObject ]. - - self noteRecentClipping: contents. - - "Store on OS clipboard using ExtendedClipboardInterface if present" - self extendedClipboardInterface ifNotNil: [ :interface | - interface canStore ifTrue: [ - id _ self idFor: contents. - contents isString - ifTrue: [ ^interface storeString: contents id: id ]. - (contents is: #Text) - ifTrue: [ ^interface storeText: contents id: id ]. - (contents is: #Form) - ifTrue: [ ^interface storeForm: contents id: id ]. - (contents is: #Morph) - ifTrue: [ ^interface storeForm: (contents imageForm: 32) id: id ]. - ^interface storeString: contents asString id: id ]]. - - "Otherwise use the clipboard primitives in the VM" - "The VM uses UTF-8 for clipboard" - primitiveFormat _ (self stringOrIdFor: contents) asUtf8: true. - self primitiveClipboardString: primitiveFormat! ! -!Clipboard methodsFor: 'initialization' stamp: 'jmv 11/29/2017 11:34:38' prior: 16807881! - initialize - contents _ nil. - contentsOriginalObjectWeakly _ WeakArray new: 1. - recent _ OrderedCollection new.! ! -!Morph methodsFor: 'copying' stamp: 'jmv 11/29/2017 11:51:04' prior: 16874187! - copyForClipboard - "Some subclasses might need specific behavior..." - - self okayToDuplicate ifFalse: [ ^ nil ]. - ^self copy! ! -!Morph methodsFor: 'menus' stamp: 'jmv 11/29/2017 11:52:10' prior: 16876121! - addCopyItemsTo: aMenu - "Add copy-like items to the halo menu" - - | subMenu | - subMenu := MenuMorph new defaultTarget: self. - subMenu add: 'copy to clipboard (c)' action: #copyToClipboard:. - aMenu add: 'copy & print...' subMenu: subMenu! ! -!Morph methodsFor: 'meta-actions' stamp: 'jmv 11/29/2017 11:46:23' prior: 16876400! - copyToClipboard: evt - self copyToClipboard! ! - -Object subclass: #Clipboard - instanceVariableNames: 'contents recent contentsOriginalObjectWeakly' - classVariableNames: 'Default' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #Clipboard category: #'System-Support'! -Object subclass: #Clipboard - instanceVariableNames: 'contents recent contentsOriginalObjectWeakly' - classVariableNames: 'Default' - poolDictionaries: '' - category: 'System-Support'! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Clipboard releaseClassCachedState! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3225-PasteOnWorkspaceFixes-JuanVuletich-2017Nov29-11h56m-jmv.1.cs.st----! - -----SNAPSHOT----#(29 November 2017 12:06:36.507159 pm) Cuis5.0-3225-v3.image priorSource: 1438599! - -----QUIT----#(29 November 2017 12:06:50.214237 pm) Cuis5.0-3225-v3.image priorSource: 1444121! - -----STARTUP----#(15 December 2017 12:46:46.501118 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3225-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3225] on 30 November 2017 at 11:45:29 am'! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jmv 11/30/2017 11:44:27'! - isDevelopmentEnvironmentPresent - "Or we can't open a Smalltalk debugger" - - ^ Smalltalk isHeadless not and: [Smalltalk includesKey: #Debugger]! ! -!UnhandledError methodsFor: 'priv handling' stamp: 'jmv 11/30/2017 11:44:53' prior: 50373479! - defaultAction - "The current computation is terminated. The cause of the error should be logged or reported to the user. If the program is operating in an interactive debugging environment the computation should be suspended and the debugger activated." - - Smalltalk isDevelopmentEnvironmentPresent - ifTrue: [ self devDefaultAction ] - ifFalse: [ self standaloneAppDefaultAction ]! ! - -UnhandledError removeSelector: #isDevelopmentEnvironmentPresent! - -UnhandledError removeSelector: #isDevelopmentEnvironmentPresent! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3226-isDevelopmentEnvironmentPresent-to-Smalltalk-JuanVuletich-2017Nov30-11h44m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3226] on 4 December 2017 at 10:51:49 am'! -!Form methodsFor: 'private' stamp: 'jmv 12/4/2017 10:09:15'! - hackBits64: bitThing - "This method provides an initialization so that BitBlt may be used, eg, to - copy ByteArrays and other non-pointer objects efficiently. - The resulting form looks 8 wide, 8 deep, and bitThing-size-in-words high." - width _ 8. - depth _ 8. - bitThing class isBits ifFalse: [self error: 'bitThing must be a non-pointer object']. - bitThing class isBytes - ifTrue: [height _ bitThing basicSize // 8] - ifFalse: [height _ bitThing basicSize // 2]. - bits _ bitThing! ! -!BitBlt class methodsFor: 'byte and word utilities' stamp: 'jmv 12/4/2017 10:14:38'! - swapBytesIn64BitWords: aNonPointerThing - "Perform a bigEndian/littleEndian byte reversal of my 64 bit words. - We only intend this for non-pointer arrays. Do nothing if I contain pointers. - - | ba | - ba := #[1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16] copy. - BitBlt swapBytesIn64BitWords: ba. - ba - " - - self swapBytesIn64BitWords: aNonPointerThing from: 1 to: aNonPointerThing basicSize! ! -!BitBlt class methodsFor: 'byte and word utilities' stamp: 'jmv 12/4/2017 10:13:45'! - swapBytesIn64BitWords: aNonPointerThing from: start to: stop - "Perform a bigEndian/littleEndian byte reversal of my 64 bit words. - We only intend this for non-pointer arrays. Do nothing if I contain pointers." - - | hack blt | - "The implementation is a hack, but fast for large ranges" - hack _ Form new hackBits64: aNonPointerThing. - blt _ (BitBlt toForm: hack) sourceForm: hack. - blt combinationRule: Form reverse. "XOR" - blt sourceY: start-1; destY: start-1; height: stop-start+1; width: 1. - - "Exchange bytes 0 and 7" - blt sourceX: 0; destX: 7; copyBits. - blt sourceX: 7; destX: 0; copyBits. - blt sourceX: 0; destX: 7; copyBits. - - "Exchange bytes 1 and 6" - blt sourceX: 1; destX: 6; copyBits. - blt sourceX: 6; destX: 1; copyBits. - blt sourceX: 1; destX: 6; copyBits. - - "Exchange bytes 2 and 5" - blt sourceX: 2; destX: 5; copyBits. - blt sourceX: 5; destX: 2; copyBits. - blt sourceX: 2; destX: 5; copyBits. - - "Exchange bytes 3 and 4" - blt sourceX: 3; destX: 4; copyBits. - blt sourceX: 4; destX: 3; copyBits. - blt sourceX: 3; destX: 4; copyBits.! ! -!BitBlt class methodsFor: 'byte and word utilities' stamp: 'jmv 12/4/2017 10:15:23'! - swapHalvesIn64BitWords: aNonPointerThing - "Swap 32 bit halves in each 64 bit word. - We only intend this for non-pointer arrays. Do nothing if I contain pointers. - - | ba | - ba := #[1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16] copy. - BitBlt swapHalvesIn64BitWords: ba. - ba - " - - self swapHalvesIn64BitWords: aNonPointerThing from: 1 to: aNonPointerThing basicSize! ! -!BitBlt class methodsFor: 'byte and word utilities' stamp: 'jmv 12/4/2017 10:16:27'! - swapHalvesIn64BitWords: aNonPointerThing from: start to: stop - "Swap 32 bit halves in each 64 bit word. - We only intend this for non-pointer arrays. Do nothing if I contain pointers." - - | hack blt | - "The implementation is a hack, but fast for large ranges" - hack _ Form new hackBits64: aNonPointerThing. - blt _ (BitBlt toForm: hack) sourceForm: hack. - blt combinationRule: Form reverse. "XOR" - blt sourceY: start-1; destY: start-1; height: stop-start+1; width: 8. - - "Exchange bytes 0123 with 4567" - blt sourceX: 0; destX: 4; copyBits. - blt sourceX: 4; destX: 0; copyBits. - blt sourceX: 0; destX: 4; copyBits! ! -!Float64Array methodsFor: 'private' stamp: 'jmv 12/4/2017 10:51:19' prior: 16846148! - swapWords - "This could call #swapHalvesIn64BitWords:" - | tmp | - 1 to: self size do: [ :i | - tmp _ self rawBasicAt: i*2. - self rawBasicAt: i*2 put: (self rawBasicAt: i*2-1). - self rawBasicAt: i*2-1 put: tmp ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3227-byte-word-utilities-JuanVuletich-2017Dec04-10h00m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3227] on 4 December 2017 at 3:17:12 pm'! -!Float64Array commentStamp: '' prior: 16846050! - FloatArrays store 64bit IEEE floating point numbers, i.e. instances of the Float class. -Some support is included for subclasses in the style of Balloon3D-Math. - -Uses the same internal representation as Float. I.e. a Float and a Float64Array of size 1 hold the same bits. See #floatAt: and #floatAt:put:! -!Workspace methodsFor: 'variable declarations' stamp: 'jmv 12/4/2017 15:15:31' prior: 50376272! - nameForObject: object - "Answer a name suitable for a Workspace variable" - ^ object class name asLowercase , object identityHash asString! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3228-nameForObject-tweak-JuanVuletich-2017Dec04-15h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3228] on 6 December 2017 at 3:56:49 pm'! -!BitBltCanvas methodsFor: 'drawing-roundedRectangles' stamp: 'jmv 12/6/2017 15:41:29' prior: 16786942! - windowFrame: aRectangle color: aColor radius: r border: bw labelHeight: lh gradientTop: topFactor gradientBottom: bottomFactor insideColor: insideColor - " - BitBltCanvas releaseClassCachedState. - Display getCanvas windowFrame: (10@10 extent: 200@100) color: Color red radius: 10 border: 5 labelHeight: 25 gradientTop: 1.0 gradientBottom: 0.5 insideColor: Color green. - Display forceToScreen - " - "top stripe" - | bottomColor he tl tr | - self - image: (self class topLeftCorner: r height: lh gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: aRectangle topLeft. - self - image: (self class topRightCorner: r height: lh gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: aRectangle topRight - (r@0). - self - fillRectangle: ((aRectangle withHeight: lh) insetBy: r@0) - tilingWith: (self class verticalGrayGradient: lh gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor. - - bottomColor _ aColor * bottomFactor. - - "left and right borders" - tl _ aRectangle topLeft + (0@lh). - tr _ aRectangle topRight + (bw negated@lh). - he _ bw@(aRectangle height - lh - r). - self fillRectangle: (tl extent: he) color: bottomColor. - self fillRectangle: (tr extent: he) color: bottomColor. - - "bottom stripe" - self - image: (self class bottomLeftCorner: r height: r gradientTop: 1 gradientBottom: 1 borderWidth: bw) - multipliedBy: bottomColor - at: aRectangle bottomLeft - (0@r). - self - image: (self class bottomRightCorner: r height: r gradientTop: 1 gradientBottom: 1 borderWidth: bw) - multipliedBy: bottomColor - at: aRectangle bottomRight - (r@r) . - self fillRectangle: ((aRectangle bottomLeft + (r@bw negated)) extent: (aRectangle width - r - r@bw)) color: bottomColor. - - "inside" - self fillRectangle: (aRectangle insetBy: (bw@lh corner: bw@bw)) color: insideColor! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3229-CommentTweak-JuanVuletich-2017Dec06-15h29m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3229] on 11 December 2017 at 11:54:23 am'! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 11/2/2017 15:56:23' prior: 50370827! - arrowKey: aChar - "Handle a keyboard navigation character. Answer true if handled, false if not." - | keyEvent answer nextSelection oldSelection | - answer := false. - keyEvent := aChar numericValue. - oldSelection := self getSelectionIndex. - nextSelection := oldSelection. - keyEvent = 31 ifTrue: [ - "down" - nextSelection := oldSelection + 1. - nextSelection > self maximumSelection ifTrue: [ nextSelection := self minimumSelection ]]. - keyEvent = 30 ifTrue: [ - "up" - nextSelection := oldSelection - 1. - nextSelection < self minimumSelection ifTrue: [ nextSelection := self maximumSelection ]]. - keyEvent = 1 ifTrue: [ "home" - nextSelection := 1 ]. - keyEvent = 4 ifTrue: [ "end" - nextSelection := scroller submorphs size ]. - keyEvent = 11 ifTrue: [ "page up" - nextSelection := oldSelection - self numSelectionsInView max: 1 ]. - keyEvent = 12 ifTrue: [ "page down" - nextSelection := oldSelection + self numSelectionsInView ]. - keyEvent = 29 ifTrue: [ - "right" - selectedMorph ifNotNil: [ - (selectedMorph canExpand and: [ selectedMorph isExpanded not ]) - ifTrue: [ - self toggleExpandedState: selectedMorph. - self scrollSelectionIntoView. - answer := true ] - ifFalse: [ nextSelection := oldSelection + 1 ]]]. - keyEvent = 28 ifTrue: [ - "left" - selectedMorph ifNotNil: [ - selectedMorph isExpanded - ifTrue: [ - self toggleExpandedState: selectedMorph. - self scrollSelectionIntoView. - answer := true ] - ifFalse: [ - oldSelection > self minimumSelection ifTrue: [ - nextSelection _ (oldSelection-1 to: 1 by: -1) detect: [ :i | ( scroller submorphs at: i) indentLevel < selectedMorph indentLevel ]]. - ]]]. - nextSelection = oldSelection ifFalse: [ - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self highlightedMorph: (self listMorphAt: nextSelection). - "Update the model in next world cycle, so user gets the immediate feedback." - WorldState addDeferredUIMessage: [ self setSelectionIndex: nextSelection ]. - answer := true ]. - ^ answer.! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3230-TreeView-keyboardNavigationEng-JuanVuletich-2017Dec11-11h51m-jmv.1.cs.st----! - -----SNAPSHOT----#(15 December 2017 12:46:55.680103 pm) Cuis5.0-3230-v3.image priorSource: 1444221! - -----QUIT----#(15 December 2017 12:47:13.212637 pm) Cuis5.0-3230-v3.image priorSource: 1454915! - -----STARTUP----#(4 January 2018 5:56:24.197624 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3230-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3230] on 16 December 2017 at 6:16:14 pm'! -!MorphicCanvas commentStamp: 'jmv 12/16/2017 18:15:31' prior: 16877314! -A MorphicCanvas offers 2D drawing services. It works on a 'form', usually the Display. These services are used, for example, in #drawOn: methods. - -Subclasses are specific implementations. BitBltCanvas is based on BitBlt, the raster operation invented by Dan Ingalls for Smalltalk, and included in Smalltalk-80 and Squeak. VectorCanvas is based on its VectorEngine, using a novel technique for the rasterization (sampling) of vector graphics, invented by Juan Vuletich.! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3231-MorphicCanvasComment-JuanVuletich-2017Dec16-18h14m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3231] on 26 December 2017 at 9:21:34 am'! -!CodePackage methodsFor: 'enumerating' stamp: 'jmv 12/26/2017 08:36:49'! - coreMethodsOf: aClass do: aBlock - "Evaluate aBlock with the actual method objects in this package." - - aClass organization categories do: [ :cat | - (self isForeignClassExtension: cat) ifFalse: [ - (aClass organization listAtCategoryNamed: cat) do: [ :s | - aBlock value: (self referenceForMethod: s ofClass: aClass) ]]]! ! -!CodePackage methodsFor: 'saving' stamp: 'jmv 12/26/2017 08:39:58'! - writeCoreMethodsOf: aClass on: aStream - - self coreMethodsOf: aClass do: [ :methodReference | - methodReference isValid - ifTrue: [ - self writeMethod: methodReference on: aStream ]]! ! -!CodePackage methodsFor: 'saving' stamp: 'jmv 12/26/2017 08:52:22' prior: 16810579! - write: classes methodsOn: aStream - - classes - do: [ :class | - self writeCoreMethodsOf: class on: aStream. - self writeCoreMethodsOf: class class on: aStream ] - displayingProgress: 'Saving methods...'! ! -!CodePackage methodsFor: 'saving' stamp: 'jmv 12/26/2017 09:07:44' prior: 16810632! - writeOnStream: aStream - - | sortedClasses | - aStream - nextChunkPut: ('Description ', description) printString; - newLine. - self writeFeatureSpecOn: aStream. - self writeSystemCategoriesOn: aStream. - sortedClasses _ Array streamContents: [ :strm | - self classesInSafeOrderDo: [ :cls | - strm nextPut: cls ]]. - self - write: sortedClasses classDefinitionsOn: aStream; - write: sortedClasses classCommentsOn: aStream; - write: sortedClasses methodsOn: aStream. - self - sortedExtensionMethodsDo: [ :methodReference | - methodReference isValid ifTrue: [ - self writeMethod: methodReference on: aStream ]] - displayingProgress: 'Saving extension methods...'. - self - write: sortedClasses initializersOn: aStream! ! - -CodePackage removeSelector: #actualMethodsDo:! - -CodePackage removeSelector: #actualMethodsDo:! - -CodePackage removeSelector: #addCoreMethod:! - -CodePackage removeSelector: #addCoreMethod:! - -CodePackage removeSelector: #addExtensionMethod:! - -CodePackage removeSelector: #addExtensionMethod:! - -CodePackage removeSelector: #addMethod:! - -CodePackage removeSelector: #addMethod:! - -CodePackage removeSelector: #allOverriddenMethods! - -CodePackage removeSelector: #allOverriddenMethods! - -CodePackage removeSelector: #allOverriddenMethodsDo:! - -CodePackage removeSelector: #allOverriddenMethodsDo:! - -CodePackage removeSelector: #baseCategoryOfMethod:! - -CodePackage removeSelector: #baseCategoryOfMethod:! - -CodePackage removeSelector: #changeRecordForOverriddenMethod:! - -CodePackage removeSelector: #changeRecordForOverriddenMethod:! - -CodePackage removeSelector: #coreCategoriesForClass:! - -CodePackage removeSelector: #coreCategoriesForClass:! - -CodePackage removeSelector: #extensionClasses! - -CodePackage removeSelector: #extensionClasses! - -CodePackage removeSelector: #externalCallers! - -CodePackage removeSelector: #externalCallers! - -CodePackage removeSelector: #externalRefsSelect:thenCollect:! - -CodePackage removeSelector: #externalRefsSelect:thenCollect:! - -CodePackage removeSelector: #externalSubclasses! - -CodePackage removeSelector: #externalSubclasses! - -CodePackage removeSelector: #externalUsers! - -CodePackage removeSelector: #externalUsers! - -CodePackage removeSelector: #foreignClasses! - -CodePackage removeSelector: #foreignClasses! - -CodePackage removeSelector: #foreignSystemCategories! - -CodePackage removeSelector: #foreignSystemCategories! - -CodePackage removeSelector: #includesChangeRecord:! - -CodePackage removeSelector: #includesChangeRecord:! - -CodePackage removeSelector: #includesClassNamed:! - -CodePackage removeSelector: #includesClassNamed:! - -CodePackage removeSelector: #includesMethodCategory:ofClassNamed:! - -CodePackage removeSelector: #includesMethodCategory:ofClassNamed:! - -CodePackage removeSelector: #isOverrideCategory:! - -CodePackage removeSelector: #isOverrideCategory:! - -CodePackage removeSelector: #isOverrideMethod:! - -CodePackage removeSelector: #isOverrideMethod:! - -CodePackage removeSelector: #isOverrideOfYourMethod:! - -CodePackage removeSelector: #isOverrideOfYourMethod:! - -CodePackage removeSelector: #overriddenMethods! - -CodePackage removeSelector: #overriddenMethods! - -CodePackage removeSelector: #overriddenMethodsDo:! - -CodePackage removeSelector: #overriddenMethodsDo:! - -CodePackage removeSelector: #overriddenMethodsInClass:! - -CodePackage removeSelector: #overriddenMethodsInClass:! - -CodePackage removeSelector: #overriddenMethodsInClass:do:! - -CodePackage removeSelector: #overriddenMethodsInClass:do:! - -CodePackage removeSelector: #overrideCategoriesForClass:! - -CodePackage removeSelector: #overrideCategoriesForClass:! - -CodePackage removeSelector: #overrideCategoriesForClass:do:! - -CodePackage removeSelector: #overrideCategoriesForClass:do:! - -CodePackage removeSelector: #overrideMethods! - -CodePackage removeSelector: #overrideMethods! - -CodePackage removeSelector: #writeMethodsOf:on:! - -CodePackage removeSelector: #writeMethodsOf:on:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3232-CodePackage-cleanupAndEnhancements-JuanVuletich-2017Dec26-09h12m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3232] on 27 December 2017 at 12:03:07 pm'! -!Theme class methodsFor: 'class initialization' stamp: 'jmv 12/27/2017 11:14:22' prior: 50341495! - currentTheme: aTheme - - CurrentTheme := aTheme new. - SHTextStylerST80 releaseClassCachedState. - self runningWorld ifNotNil: [ :w | - w backgroundImage ifNil: [ - w color: CurrentTheme background ]]. - SystemWindow initialize. - BitBltCanvas releaseClassCachedState. - self runningWorld ifNotNil: [ :w | - CurrentTheme useTaskbar - ifTrue: [w showTaskbar] - ifFalse: [w hideTaskbar]. - w restoreMorphicDisplay ]. - - ^ CurrentTheme! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3233-DoNotResetShoutPreferencesOnthemeChange-JuanVuletich-2017Dec27-12h02m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3226] on 11 December 2017 at 2:44:07 pm'! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'pb 12/11/2017 14:37:42'! - privateMorphicTopLevelRendererClass - "The class controlling the outermost rendering process for Morphic and other critical methods for handling interrupts. Dangerous to change as any bugs will effectively crash the UI for the entire image. - - Using 'private' prefix to reflect the danger even though it will likely be called externally." - ^ ProjectX! ! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'pb 12/11/2017 14:37:54'! - privateMorphicWorldClass - "The class to be used for Morphic Worlds. Dangerous to change as any bugs will effectively crash the UI for the entire image. - - Using 'private' prefix to reflect the danger even though it will likely be called externally." - ^ PasteUpMorph ! ! -!Debugger methodsFor: 'initialization' stamp: 'pb 12/11/2017 14:41:18' prior: 16830276! - openFullNoSuspendLabel: aString - "Create and schedule a full debugger with the given label. Do not terminate the current active process." - - self openFullMorphicLabel: aString. - interruptedProcessUI _ Smalltalk privateMorphicTopLevelRendererClass newProcessIfUIX: interruptedProcess! ! -!Debugger methodsFor: 'initialization' stamp: 'pb 12/11/2017 14:41:28' prior: 16830286! - openNotifierContents: msgString label: label - "Create and schedule a notifier view with the given label and message. A notifier view shows just the message or the first several lines of the stack, with a menu that allows the user to open a full debugger if so desired." - "NOTE: When this method returns, a new process has been scheduled to run the windows, and thus this notifier, but the previous active porcess has not been suspended. The sender will do this." - | msg | - Sensor flushKeyboard. - savedCursor _ Cursor currentCursor. - Cursor normal activateCursor. - msg _ (label beginsWith: 'Space is low') - ifTrue: [ self lowSpaceChoices, (msgString ifNil: ['']) ] - ifFalse: [ msgString ]. - - interruptedProcessUI _ Smalltalk privateMorphicTopLevelRendererClass newProcessIfUIX: interruptedProcess. - WorldState addDeferredUIMessage: [ - PreDebugWindow open: self label: label message: msg ]. - ^self! ! -!Debugger class methodsFor: 'opening' stamp: 'pb 12/11/2017 14:41:38' prior: 50373395! - openOn: process context: context label: title fullView: bool - "Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger." - | w | - Preferences logDebuggerStackToFile ifTrue: [ - Smalltalk - logError: title - inContext: context - to: 'CuisDebug' ]. - w := Smalltalk privateMorphicTopLevelRendererClass newProcessIfUIX: process. - "schedule debugger in deferred UI message to address redraw - problems after opening a debugger e.g. from the testrunner." - WorldState addDeferredUIMessage: [ - [ | debugger | - "In case an error in Morphic code got us here, ensure mouse focus has been released" - true runningWorld ifNotNil: [ :rWorld | - rWorld activeHand ifNotNil: [ :aHand | - aHand releaseMouseFocus ]]. - debugger := self new - process: process - context: context. - debugger interruptedProcessUI: w. - bool - ifTrue: [ debugger openFullMorphicLabel: title ] - ifFalse: [ - PreDebugWindow - open: debugger - label: title - message: nil ]] - on: UnhandledError - do: [ :exOuter | | errorDescription | - errorDescription := 'Error while trying to open Debugger' , String newLineString , 'Orginal error: ' , title asString , '.' , String newLineString , ' Debugger error: ' , - ([ exOuter description ] - on: UnhandledError - do: [ :exInner | - exInner return: 'a ' , exInner class printString ]) , ':'. - self primitiveError: errorDescription ]]. - process suspend.! ! -!SystemDictionary methodsFor: 'memory space' stamp: 'pb 12/11/2017 14:42:30' prior: 16920405! - lowSpaceWatcher - "Wait until the low space semaphore is signalled, then take appropriate actions." - - self garbageCollectMost <= self lowSpaceThreshold ifTrue: [ - self garbageCollect <= self lowSpaceThreshold ifTrue: [ - "free space must be above threshold before starting low space watcher" - ^ Smalltalk primitiveBeep ]]. - - LowSpaceSemaphore _ Semaphore new. - self primLowSpaceSemaphore: LowSpaceSemaphore. - self primSignalAtBytesLeft: self lowSpaceThreshold. "enable low space interrupts" - - LowSpaceSemaphore wait. "wait for a low space condition..." - - self primSignalAtBytesLeft: 0. "disable low space interrupts" - self primLowSpaceSemaphore: nil. - LowSpaceProcess _ nil. - "Note: user now unprotected until the low space watcher is re-installed" - - self privateMorphicTopLevelRendererClass currentInterruptNameX: 'Space is low'! ! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'pb 12/11/2017 14:42:18' prior: 16920982! - handleUserInterrupt - Preferences cmdDotEnabled ifTrue: [ - [self privateMorphicTopLevelRendererClass currentInterruptNameX: 'User Interrupt'] fork]! ! -!SystemDictionary methodsFor: 'shrinking' stamp: 'pb 12/11/2017 14:39:37' prior: 50357685! - reduceCuis - " - Smalltalk reduceCuis - " - | keep n unused newDicts oldDicts | - - self nominallyUnsent: #reduceCuis. - - "Remove icons" - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - self privateMorphicWorldClass allInstancesDo: [ :w | - w backgroundImageData: nil. - w submorphsDo: [ :a | a delete ]]. - Preferences useNoIcons. - Theme current initialize. - Theme content: nil. - Color shutDown. - BitBltCanvas releaseClassCachedState. - - Transcript clear. - Clipboard default initialize. - - - "Remove some methods, even if they have senders." -" ColorPickerMorph class removeSelector: #buildEyedropperIcon." - Theme removeSelector: #miscellaneousIcons. - Utilities removeSelector: #vmStatisticsReportString. - SystemDictionary removeSelector: #recreateSpecialObjectsArray. - - StrikeFont removeMostFonts. - StrikeFont saveSpace. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - - keep := OrderedCollection new. - keep addAll: #(SpaceTally). - AppLauncher appGlobalName ifNotNil: [ :any | - keep add: any ]. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - [ - #hereWeGo print. - unused do: [:c | - c print. - (Smalltalk at: c) removeFromSystem]. - n := Smalltalk removeAllUnSentMessages. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - n > 0 or: [ - unused notEmpty ]] whileTrue. - ChangeSet zapAllChangeSets. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - Symbol rehash. - - "Shrink method dictionaries." - Smalltalk garbageCollect. - oldDicts _ MethodDictionary allInstances. - newDicts _ Array new: oldDicts size. - oldDicts withIndexDo: [:d :index | - newDicts at: index put: d rehashWithoutBecome ]. - oldDicts elementsExchangeIdentityWith: newDicts. - oldDicts _ newDicts _ nil. - - SmalltalkCompleter initialize . - - "Sanity checks" -" Undeclared - Smalltalk cleanOutUndeclared - Smalltalk browseUndeclaredReferences - Smalltalk obsoleteClasses - Smalltalk obsoleteBehaviors - Smalltalk browseObsoleteMethodReferences - SmalltalkImage current fixObsoleteReferences - Smalltalk browseAllUnimplementedCalls"! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'pb 12/11/2017 14:43:32' prior: 50369884! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag -"WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " -| activeProc | -activeProc _ Processor activeProcess. -[ - | isARealStartup world reopenTranscript | - self logSnapshot: save andQuit: quit. - - reopenTranscript _ false. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | each isInWorld ifTrue: [ each delete. reopenTranscript _ true ]]. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - - - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - - "Cosas que levanto explicitamente abajo" - world _ self privateMorphicTopLevelRendererClass ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "world _ clearAllStateFlag ifFalse: [ self privateMorphicTopLevelRendererClass ui ]." - self privateMorphicTopLevelRendererClass stopUIProcess. - activeProc isTerminated ifFalse: [ - activeProc terminate ]. - - "Clean Globals" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: nil. - Smalltalk closeSourceFiles. Smalltalk at: #SourceFiles put: nil. - Smalltalk allClassesDo: [ :cls | cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ Smalltalk printStuffToCleanOnImageSave ]. - - - "Do image save & quit as apropriate" - Cursor write activateCursor. - save - ifTrue: [ - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - - - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: (DisplayScreen extent: `1024@768` depth: 32). - Smalltalk at: #SourceFiles put: (Array new: 2). - Smalltalk openSourceFiles. - - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - - - self privateMorphicTopLevelRendererClass spawnNewMorphicProcessFor: (world ifNil: [ self privateMorphicWorldClass newWorld ]). - - reopenTranscript ifTrue: [ - WorldState addDeferredUIMessage: [ - TranscriptWindow openTranscript ]]. - " - WorldState addDeferredUIMessage: [ - world fullRepaintNeeded ]. - " - - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - WorldState addDeferredUIMessage: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]. - -] forkAt: Processor timingPriority-1 named: 'Startup process'.! ! -!ProjectX class methodsFor: 'as yet unclassified' stamp: 'pb 12/11/2017 14:42:05' prior: 16896342! - interruptNameX: labelString - "Create a Notifier on the active scheduling process with the given label." - | preemptedProcess label | - preemptedProcess _ Processor preemptedProcess. - - "Only debug preempted process if its priority is >= UIProcess' priority" - preemptedProcess priority < UIProcess priority ifTrue: [ - preemptedProcess _ UIProcess ]. - - label _ labelString, - ' - Process: ', preemptedProcess name, - ' - Priority: ', preemptedProcess priority printString. - preemptedProcess isTerminated - ifTrue: [ - self newProcessIfUIX: preemptedProcess. - self notify: 'Can not debug a terminated process: ', label ] - ifFalse: [ - preemptedProcess suspend. - Debugger - openInterrupt: label - onProcess: preemptedProcess ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3234-Morphic-globals-PhilBellalouna-2017Dec11-14h37m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3227] on 11 December 2017 at 5:30:58 pm'! -!PasteUpMorph methodsFor: 'world state' stamp: 'pb 12/11/2017 15:25:45'! - addDeferredUIMessage: valuableObject - "This will be safe to call directly in a multi-world environment (as opposed to the WorldState class-side method)" - WorldState addDeferredUIMessage: valuableObject ! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'pb 12/11/2017 17:07:49' prior: 50377573! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag -"WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " -| activeProc | -activeProc _ Processor activeProcess. -[ - | isARealStartup world reopenTranscript | - self logSnapshot: save andQuit: quit. - - reopenTranscript _ false. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | each isInWorld ifTrue: [ each delete. reopenTranscript _ true ]]. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - - - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - - "Cosas que levanto explicitamente abajo" - world _ self privateMorphicTopLevelRendererClass ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "world _ clearAllStateFlag ifFalse: [ self privateMorphicTopLevelRendererClass ui ]." - self privateMorphicTopLevelRendererClass stopUIProcess. - activeProc isTerminated ifFalse: [ - activeProc terminate ]. - - "Clean Globals" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: nil. - Smalltalk closeSourceFiles. Smalltalk at: #SourceFiles put: nil. - Smalltalk allClassesDo: [ :cls | cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ Smalltalk printStuffToCleanOnImageSave ]. - - - "Do image save & quit as apropriate" - Cursor write activateCursor. - save - ifTrue: [ - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - - - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: (DisplayScreen extent: `1024@768` depth: 32). - Smalltalk at: #SourceFiles put: (Array new: 2). - Smalltalk openSourceFiles. - - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - - - self privateMorphicTopLevelRendererClass spawnNewMorphicProcessFor: (world ifNil: [ world:=self privateMorphicWorldClass newWorld ]). - - reopenTranscript ifTrue: [ - world addDeferredUIMessage: [ - TranscriptWindow openTranscript ]]. - " - world addDeferredUIMessage: [ - world fullRepaintNeeded ]. - " - - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - world addDeferredUIMessage: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]. - -] forkAt: Processor timingPriority-1 named: 'Startup process'.! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'pb 12/11/2017 15:29:32' prior: 16875813! -showBalloon: msgString hand: aHand - "Pop up a balloon containing the given string, - first removing any existing BalloonMorphs in the world." - - | w balloon h | - (w _ self world) ifNil: [^ self]. - h _ aHand. - h ifNil:[ - h _ w activeHand]. - balloon _ HoverHelpMorph contents: msgString. - - "Do it in a while. In some cases, processing the event that might have triggered us might also remove any Help Balloon" - self world addDeferredUIMessage: [ - balloon popUpForHand: h ]! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'pb 12/11/2017 15:30:12' prior: 50337477! - restoreMorphicDisplay - DisplayScreen startUp. - self - morphExtent: Display extent; - handsDo: [ :h | h visible: true ]; - fullRepaintNeeded. - self addDeferredUIMessage: [ Cursor normal activateCursor ]! ! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'pb 12/11/2017 15:26:29' prior: 50377045! - arrowKey: aChar - "Handle a keyboard navigation character. Answer true if handled, false if not." - | keyEvent answer nextSelection oldSelection | - answer := false. - keyEvent := aChar numericValue. - oldSelection := self getSelectionIndex. - nextSelection := oldSelection. - keyEvent = 31 ifTrue: [ - "down" - nextSelection := oldSelection + 1. - nextSelection > self maximumSelection ifTrue: [ nextSelection := self minimumSelection ]]. - keyEvent = 30 ifTrue: [ - "up" - nextSelection := oldSelection - 1. - nextSelection < self minimumSelection ifTrue: [ nextSelection := self maximumSelection ]]. - keyEvent = 1 ifTrue: [ "home" - nextSelection := 1 ]. - keyEvent = 4 ifTrue: [ "end" - nextSelection := scroller submorphs size ]. - keyEvent = 11 ifTrue: [ "page up" - nextSelection := oldSelection - self numSelectionsInView max: 1 ]. - keyEvent = 12 ifTrue: [ "page down" - nextSelection := oldSelection + self numSelectionsInView ]. - keyEvent = 29 ifTrue: [ - "right" - selectedMorph ifNotNil: [ - (selectedMorph canExpand and: [ selectedMorph isExpanded not ]) - ifTrue: [ - self toggleExpandedState: selectedMorph. - answer := true ] - ifFalse: [ nextSelection := oldSelection + 1 ]]]. - keyEvent = 28 ifTrue: [ - "left" - selectedMorph ifNotNil: [ - selectedMorph isExpanded - ifTrue: [ - self toggleExpandedState: selectedMorph. - answer := true ] - ifFalse: [ nextSelection := oldSelection - 1 max: 1 ]]. - ^ true ]. - nextSelection = oldSelection ifFalse: [ - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self highlightedMorph: (self listMorphAt: nextSelection). - "Update the model in next world cycle, so user gets the immediate feedback." - self world addDeferredUIMessage: [ self setSelectionIndex: nextSelection ]. - answer := true ]. - ^ answer.! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'pb 12/11/2017 15:30:36' prior: 16888803! -arrowKey: aChar - "Process the up and down arrows in a list pane. Note that the listView tells us what index variable, how to get the list, and how to move the index." - | keyEvent oldSelection nextSelection max min howMany answer w | - answer _ false. - keyEvent _ aChar numericValue. - oldSelection _ self getCurrentSelectionIndex. - nextSelection _ oldSelection. - max _ self maximumSelection. - min _ self minimumSelection. - howMany _ self numSelectionsInView. "get this exactly??" - - keyEvent = 31 ifTrue: [ - "down-arrow; move down one, wrapping to top if needed" - nextSelection _ oldSelection + 1. - nextSelection > max ifTrue: [ nextSelection _ 1 ]]. - - keyEvent = 30 ifTrue: [ - "up arrow; move up one, wrapping to bottom if needed" - nextSelection _ oldSelection - 1. - nextSelection < 1 ifTrue: [ nextSelection _ max ]]. - - keyEvent = 1 ifTrue: [ nextSelection _ 1 ]. "home" - keyEvent = 4 ifTrue: [ nextSelection _ max ]. "end" - keyEvent = 11 ifTrue: [ nextSelection _ min max: oldSelection - howMany ]. "page up" - keyEvent = 12 ifTrue: [ nextSelection _ oldSelection + howMany min: max ]. "page down" - nextSelection = oldSelection ifFalse: [ - w _ self owningWindow. - (w isNil or: [ w okToChange ]) ifTrue: [ "No change if model is locked" - - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self listMorph highlightedRow: nextSelection. - - "Update the model in next world cycle, so user gets the immediate feedback." - self world addDeferredUIMessage: [ - self changeModelSelection: nextSelection ]. - answer _ true ]]. - ^answer! ! -!PluggableListMorphOfMany methodsFor: 'events' stamp: 'pb 12/11/2017 15:30:48' prior: 16889213! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - - | oldIndex oldVal row w | - self hasKeyboardFocus ifFalse: [ - aMouseButtonEvent hand newKeyboardFocus: self ]. - - row _ self rowAtLocation: localEventPosition. - - row = 0 ifTrue: [ - ^super mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition ]. - - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self listMorph highlightedRow: row. - - w _ self owningWindow. - (w isNil or: [ w okToChange ]) ifTrue: [ "No change if model is locked" - - "Set meaning for subsequent dragging of selection" - dragOnOrOff _ (self listSelectionAt: row) not. - dragStartRow _ row. - oldIndex _ self getCurrentSelectionIndex. - oldIndex ~= 0 ifTrue: [oldVal _ self listSelectionAt: oldIndex]. - - "Different from PluggableListMorph. There, we highlight on mouse down, and act on mouse up. - Here, we act on mouse down, because we support dragging of selection, so mouse up will - only happen after user is finished dragging. In order to get the highlight visible for the user, - update the model on next world cycle." - self world addDeferredUIMessage: [ - "Set or clear new primary selection (listIndex)" - dragOnOrOff - ifTrue: [self changeModelSelection: row] - ifFalse: [self changeModelSelection: 0]. - "Need to restore the old one, due to how model works, and set new one." - oldIndex ~= 0 ifTrue: [self listSelectionAt: oldIndex put: oldVal]. - self listSelectionAt: row put: dragOnOrOff ]. - ]. - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: nil - clkNHalf: nil - dblClkSel: #doubleClick:localPosition: - dblClkNHalfSel: nil - tripleClkSel: nil! ! -!SystemWindow methodsFor: 'open/close' stamp: 'pb 12/11/2017 15:31:54' prior: 50335160! - openInWorld: aWorld - "This msg and its callees result in the window being activeOnlyOnTop" - | frameRect | - frameRect _ self initialFrameIn: aWorld. - self morphExtent: frameRect extent. - aWorld addMorph: self position: frameRect topLeft. - "Do it deferred. Was needed for text cursor to start blinking if (Preferences disable: #focusFollowsMouse) " - aWorld addDeferredUIMessage: [ self activate ]! ! -!TaskbarMorph methodsFor: 'events' stamp: 'pb 12/11/2017 15:32:05' prior: 50337199! - screenSizeChanged - "Respond to change in screen size by repositioning self to bottom of screen" - -" Transcript newLine; print: 'Taskbar screenSizeChanged'. -" - | y e | - self world addDeferredUIMessage: [ - self world ifNotNil: [ :w | - y _ w morphExtent y - self defaultHeight. - e _ self internalizeDistance: w morphExtent x @ self defaultHeight. - self morphPosition: 0@y extent: e ]]! ! -!InnerTextMorph methodsFor: 'editing' stamp: 'pb 12/11/2017 15:29:07' prior: 50365178! - acceptContents - "The message is sent when the user hits return or Cmd-S. - Accept the current contents and end editing." - "Inform the model of text to be accepted, and return true if OK." - - | accepted prevSelection prevScrollValue | - - prevSelection _ self editor selectionInterval copy. - prevScrollValue _ owner verticalScrollBar scrollValue. - - (self canDiscardEdits and: [(self hasProperty: #alwaysAccept) not]) ifTrue: [self flash. ^true]. - (self hasEditingConflicts and: [ self confirmAcceptAnyway not ]) ifTrue: [self flash. ^false]. - - accepted _ model acceptContentsFrom: owner. - "During the step for the browser, updatePaneIfNeeded is called, and - invariably resets the contents of the code-holding PluggableTextMorph - at that time, resetting the cursor position and scroller in the process. - The following line forces that update without waiting for the step, - then restores the cursor and scrollbar" - - "some implementors of acceptContentsFrom: answer self :(" - ^accepted == true - ifTrue: [ - model refetch. - self editor selectFrom: prevSelection first to: prevSelection last. - "FIXME - is there actually a case where world will be nil here?" - self world addDeferredUIMessage: [ - self world ifNotNil: [ :w | w activeHand newKeyboardFocus: self ]. - owner verticalScrollBar internalScrollValue: prevScrollValue]. - true] - ifFalse: [ false ]! ! -!WorldState class methodsFor: 'class initialization' stamp: 'pb 12/11/2017 15:33:57' prior: 16946300! - addDeferredUIMessage: valuableObject - "Objects should not be calling directly as this will disappear from this location!! From the sender, instead to schedule on the currently running world use: - self runningWorld addDeferredUIMessage: ... - And to schedule on the world a given Morph exists in use: - self world addDeferredUIMessage: ..." - self deferredUIMessages nextPut: valuableObject! ! -!AndreasSystemProfiler methodsFor: 'reporting' stamp: 'pb 12/11/2017 15:33:07' prior: 16779085! - doReport - "Report the results of this profiler run" - self runningWorld addDeferredUIMessage: [ - SystemWindow - editText: (Workspace withText: self report) - label: 'Spy Results' - wrap: false ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3235-Morphic-addDeferredUIMessage-PhilBellalouna-2017Dec11-14h52m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3232] on 15 December 2017 at 9:24:34 pm'! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'pb 12/15/2017 21:24:22' prior: 50377883! - arrowKey: aChar - "Handle a keyboard navigation character. Answer true if handled, false if not." - | keyEvent answer nextSelection oldSelection | - answer := false. - keyEvent := aChar numericValue. - oldSelection := self getSelectionIndex. - nextSelection := oldSelection. - keyEvent = 31 ifTrue: [ - "down" - nextSelection := oldSelection + 1. - nextSelection > self maximumSelection ifTrue: [ nextSelection := self minimumSelection ]]. - keyEvent = 30 ifTrue: [ - "up" - nextSelection := oldSelection - 1. - nextSelection < self minimumSelection ifTrue: [ nextSelection := self maximumSelection ]]. - keyEvent = 1 ifTrue: [ "home" - nextSelection := 1 ]. - keyEvent = 4 ifTrue: [ "end" - nextSelection := scroller submorphs size ]. - keyEvent = 11 ifTrue: [ "page up" - nextSelection := oldSelection - self numSelectionsInView max: 1 ]. - keyEvent = 12 ifTrue: [ "page down" - nextSelection := oldSelection + self numSelectionsInView ]. - keyEvent = 29 ifTrue: [ - "right" - selectedMorph ifNotNil: [ - (selectedMorph canExpand and: [ selectedMorph isExpanded not ]) - ifTrue: [ - self toggleExpandedState: selectedMorph. - self scrollSelectionIntoView. - answer := true ] - ifFalse: [ nextSelection := oldSelection + 1 ]]]. - keyEvent = 28 ifTrue: [ - "left" - selectedMorph ifNotNil: [ - selectedMorph isExpanded - ifTrue: [ - self toggleExpandedState: selectedMorph. - self scrollSelectionIntoView. - answer := true ] - ifFalse: [ - oldSelection > self minimumSelection ifTrue: [ - nextSelection _ (oldSelection-1 to: 1 by: -1) detect: [ :i | ( scroller submorphs at: i) indentLevel < selectedMorph indentLevel ]]. - ]]]. - nextSelection = oldSelection ifFalse: [ - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self highlightedMorph: (self listMorphAt: nextSelection). - "Update the model in next world cycle, so user gets the immediate feedback." - self world addDeferredUIMessage: [ self setSelectionIndex: nextSelection ]. - answer := true ]. - ^ answer.! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3236-reapply-HierarchicalListMorph-change-PhilBellalouna-2017Dec15-21h23m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3236] on 28 December 2017 at 10:50:51 am'! - -Object subclass: #AndreasSystemProfiler - instanceVariableNames: 'semaphore ticks profilerProcess tallyRoot vmStats totalTally totalTime startTime ticksPerMSec totalTicks observedProcess ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Profiling'! - -!classDefinition: #AndreasSystemProfiler category: #'Tools-Profiling'! -Object subclass: #AndreasSystemProfiler - instanceVariableNames: 'semaphore ticks profilerProcess tallyRoot vmStats totalTally totalTime startTime ticksPerMSec totalTicks observedProcess' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Profiling'! -!Time class methodsFor: 'general inquiries' stamp: 'jmv 12/28/2017 09:52:08'! - highResTimerTicksPerMillisecond - " - Time highResTimerTicksPerMillisecond - " - | t0 ticks0 ticks1 ticksPerMSec | - t0 _ Time millisecondClockValue + 2. - [Time millisecondClockValue >= t0] whileFalse. - ticks0 := Time primHighResClock. - [Time millisecondClockValue >= (t0 + 100)] whileFalse. - ticks1 := Time primHighResClock. - ticksPerMSec := (ticks1 - ticks0) - // (Time millisecondClockValue - t0). - "Retry if rollover!!" - ^ ticksPerMSec < 0 - ifTrue: [ self highResTimerTicksPerMillisecond ] - ifFalse: [ ticksPerMSec ]! ! -!AndreasSystemProfiler methodsFor: 'testing' stamp: 'jmv 12/28/2017 07:45:21'! - isProfiling - ^ profilerProcess notNil! ! -!Time class methodsFor: 'primitives' stamp: 'jmv 12/28/2017 09:53:17' prior: 16937554! -primHighResClock - "Primitive. Answer the value of the high resolution clock if this computer has one. - Usually, this should be the highest resolution value available, for example on Intel - it will be the value of the time stamp counter register. - Answer is (at least usually) a LargePositiveInteger. - Implemented on Cog, but not in standard interpreter VMs." - " - Time primHighResClock - On Cog on Linux, OS-X and Windows, this gives sub nano second ticks!! - - Time highResTimerTicksPerMillisecond - " - "Not really a clock, but a timer or ticker" - - - ^0! ! -!SystemDictionary methodsFor: 'AndreasProfiler-profiling' stamp: 'jmv 12/28/2017 09:45:25' prior: 16925386! - profileStart: counter - "Primitive. Begin profiling execution every by using the interrupt check-counter instead of a time-based process (which is limited to timing resolution and triggers off the same signal that many of the processes being profiled trigger off leading to consistently wrong results). - The argument is the number of interrupt checks (method activations) to let go by before taking a sample. The sample is being stored in the profileSample iVar which can be retrieved by executing primitiveProfileSample. When a sample is taken, it signals the semaphore specified in primitiveProfileSemaphore. - If the argument is less or equal to zero, it disables profiling." - "Not an interrupt check-counter, but #primHighResClock" - - ^self primitiveFailed! ! -!QSystemTally methodsFor: 'report' stamp: 'jmv 12/28/2017 10:04:11' prior: 16897464! - printOn: textStream linesOn: linesStream talliesOn: talliesStreams tabs: tabsAndTreeLines total: total totalTime: totalTime parent: parentTally - - | aSelector aClass percentage line | - line _ String streamContents: [ :lineStream | - tabsAndTreeLines do: [ :tabOrLineChar | lineStream nextPutAll: tabOrLineChar ]. - percentage _ tally asFloat / total * 100.0. - percentage printOn: lineStream fractionDigits: 2. - lineStream nextPutAll: '% ('. - percentage * totalTime printOn: lineStream fractionDigits: 1. - lineStream nextPutAll: ' ms) '. - aSelector _ class selectorAtMethod: method setClass: [ :c | aClass _ c]. - blockNesting > 0 ifTrue: [ - lineStream - next: blockNesting put: $[; - next: blockNesting put: $]; - space ]. - lineStream - nextPutAll: class name; - nextPutAll: (aClass == class - ifTrue: ['>>'] - ifFalse: ['(' , aClass name , ')>>']); - nextPutAll: aSelector. - wasInPrimitive ifTrue: [ - self flag: #profilerFriendlyCall:. - parentTally methodSymbol == #profilerFriendlyCall: - ifTrue: [ - lineStream nextPutAll: ' -- primitive (reported properly)' ] - ifFalse: [ - lineStream nextPutAll: ' -- primitive (real sender possibly omitted, see #profilerFriendlyCall:)' ] - ]. - ]. - textStream nextPutAll: line; newLine. - linesStream nextPut: line. - talliesStreams nextPut: self! ! -!AndreasSystemProfiler methodsFor: 'reporting' stamp: 'jmv 12/28/2017 07:52:24' prior: 50378150! - doReport - "Report the results of this profiler run" - | report | - report _ self report. - WorldState addDeferredUIMessage: [ - SystemWindow - editText: (Workspace withText: report) - label: 'Spy Results' - wrap: false ]! ! -!AndreasSystemProfiler methodsFor: 'profiling' stamp: 'jmv 12/28/2017 10:45:37' prior: 16779284! - runProfilerProcess - "Run the profiler process" - - | process tallyStart tallyTicks methodForPrimitiveWhileTakingSample parentNode contextToTally | - totalTally _ 0. - Smalltalk profileSemaphore: semaphore. - totalTicks _ 0. - [ true ] - whileTrue: [ - tallyStart _ Time primHighResClock. - Smalltalk profileStart: ticks. "run for n ticks" - semaphore wait. - tallyTicks _ Time primHighResClock - tallyStart. - "In the extremely unlikely event of high res clock rollover, just ignore this tally" - tallyTicks > 0 ifTrue: [ - totalTicks _ totalTicks + tallyTicks. - process _ Smalltalk profileSample. - methodForPrimitiveWhileTakingSample _ Smalltalk profilePrimitive. - totalTally _ totalTally + 1. - process - ifNotNil: [ - methodForPrimitiveWhileTakingSample - ifNil: [ - tallyRoot - tally: (process suspendedContext ifNil: [ thisContext ]) - inProcess: process - by: tallyTicks. - ] - ifNotNil: [ - "The intention of this code is record which primitive was running when the VM took the sample." - "In Eliot Miranda's words: - AndreasSystemProfiler is more accurate because it uses VM support to tell it which primitive was running when it took a sample. - MessageTally simply ascribes a primitive's cost to the method at the next suspension point, which, in some contexts, - can yield wildly misleading results." - "The problem is that knowing just the primitive and the process doesn't give us the complete call stack. - So, this is, in a sense, approximate." - " - AndreasSystemProfiler spyOn: [ - [ #((1 2 3)) do: [ :each | - each findLast: [ :ea | - ea squared = ea ] ] ] bench ]. - Without asking #sender to the context, for this example - AndreasSystemProfiler spyOn:[10000 timesRepeat: [3.14159 printString]] - gave: - | 2.9% (7 ms) (Number>>#raisedToInteger:) - | 2.2% (5 ms) (Float>>#timesTwoPower: ) - but #raisedToInteger: does NOT send #timesTwoPower: - Approach taken: Add to parent node, but print with a note that specifies this is primitives, and maybe parent node is missing. - Additionally, add a note, suggesting #profilerFriendlyCall: - - For example - AndreasSystemProfiler spyOn:[1000000 timesRepeat: [3.14159 timesTwoPower: 10000]]. - Here, the real parent node is missing. - - AndreasSystemProfiler spyOn:[1000000 timesRepeat: [3.14159 profilerFriendlyTimesTwoPower: 1000]]. - Here, the proper tree is shown. - - See profilerFriendlyCall: - " - contextToTally _ process suspendedContext ifNil: [ thisContext ]. - contextToTally method selector == #profilerFriendlyCall: ifFalse: [ - contextToTally _ contextToTally sender ]. - parentNode _ tallyRoot - tally: contextToTally - inProcess: process - by: tallyTicks. - parentNode - tallyPrimInMethod: methodForPrimitiveWhileTakingSample by: tallyTicks - ]]]]! ! -!AndreasSystemProfiler methodsFor: 'profiling' stamp: 'jmv 12/28/2017 10:23:54' prior: 16779396! - startProfiling - "Start the profiler process taking samplesPerMsec samples per *milli* second" - semaphore _ Semaphore new. - "Try to get 10 samples per msec... Not really sure how this parameter is used, nor the meaning and relevance of #interruptChecksPerMSec" - "ticks _ Time highResTimerTicksPerMillisecond // Smalltalk interruptChecksPerMSec." - ticks _ Time highResTimerTicksPerMillisecond // 10. - vmStats _ Smalltalk getVMParameters. - startTime _ Time localMillisecondClock. - profilerProcess := [self runProfilerProcess] newProcess. - tallyRoot process: nil. - profilerProcess priority: Processor timingPriority-1. - profilerProcess name: 'AndreasSystemProfiler'. - profilerProcess resume! ! -!AndreasSystemProfiler methodsFor: 'profiling' stamp: 'jmv 12/28/2017 07:47:24' prior: 16779425! - stopProfiling - "Stop the profiler process" - Smalltalk profileSemaphore: nil. - Smalltalk profileStart: 0. "<- profile stops now" - totalTime _ Time localMillisecondClock - startTime. - Smalltalk getVMParameters keysAndValuesDo: [ :idx :value | - value isNumber ifTrue: [ - vmStats at: idx put: (value - (vmStats at: idx)) ]]. - profilerProcess ifNotNil: [ - profilerProcess terminate. - profilerProcess _ nil ]! ! -!AndreasSystemProfiler class methodsFor: 'spying' stamp: 'jmv 12/28/2017 07:51:36' prior: 16779565! -spyOn: aBlock includeAllProcesses: aBoolean - " - Spy on aBlock, in the current process. Can include or not statistics on other processes in the report. - [1000 timesRepeat: [ - 100 timesRepeat: [120 factorial]. - (Delay forMilliseconds: 10) wait - ]] forkAt: 45 named: '45'. - AndreasSystemProfiler spyOn: [10000 timesRepeat: [1.23 printString]] includeAllProcesses: true - " - | profiler | - self allInstancesDo: [ :p | - p isProfiling ifTrue: [ - ^ self inform: 'Must first wait for running profiler, or kill it in Process Browser' ]]. - profiler _ self new. - profiler observedProcess: (aBoolean ifFalse: [Processor activeProcess]). - [ ^ profiler spyOn: aBlock] ensure: [ profiler doReport ]. -! ! - -Object subclass: #AndreasSystemProfiler - instanceVariableNames: 'semaphore ticks profilerProcess tallyRoot vmStats totalTally totalTime startTime totalTicks observedProcess' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Profiling'! - -!classDefinition: #AndreasSystemProfiler category: #'Tools-Profiling'! -Object subclass: #AndreasSystemProfiler - instanceVariableNames: 'semaphore ticks profilerProcess tallyRoot vmStats totalTally totalTime startTime totalTicks observedProcess' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Profiling'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3237-ProfilerFixes-JuanVuletich-2017Dec28-10h41m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3237] on 28 December 2017 at 12:21:11 pm'! -!AndreasSystemProfiler methodsFor: 'reporting' stamp: 'jmv 12/28/2017 12:20:41' prior: 50378380! - doReport - "Report the results of this profiler run" - | report | - report _ self report. - self runningWorld addDeferredUIMessage: [ - SystemWindow - editText: (Workspace withText: report) - label: 'Spy Results' - wrap: false ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3238-MergeWith3235-JuanVuletich-2017Dec28-12h20m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3237] on 28 December 2017 at 2:26:10 pm'! - -Smalltalk renameClassNamed: #ProjectX as: #UISupervisor! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jmv 12/28/2017 14:25:52' prior: 50377343! - privateMorphicTopLevelRendererClass - "The class controlling the outermost rendering process for Morphic and other critical methods for handling interrupts. Dangerous to change as any bugs will effectively crash the UI for the entire image. - - Using 'private' prefix to reflect the danger even though it will likely be called externally." - ^ UISupervisor! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3239-UISupervisor-JuanVuletich-2017Dec28-14h25m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3239] on 28 December 2017 at 3:15:30 pm'! -!UISupervisor commentStamp: '' prior: 0! - UISupervisor is an interface to User Interface services not tied to any specific GUI. There could even be no GUI. -All state and behavior is on the class side! -!Debugger class methodsFor: 'opening' stamp: 'jmv 12/28/2017 15:02:53'! - interruptProcess: aProcess label: labelString - "Create a Notifier on aProcess with the given label." - | label | - - label _ labelString, - ' - Process: ', aProcess name, - ' - Priority: ', aProcess priority printString. - aProcess isTerminated - ifTrue: [ - UISupervisor newProcessIfUI: aProcess. - self notify: 'Can not debug a terminated process: ', label ] - ifFalse: [ - aProcess suspend. - self - openInterrupt: label - onProcess: aProcess ]! ! -!UISupervisor class methodsFor: 'gui process' stamp: 'jmv 12/28/2017 14:50:40'! - newProcessIfUI: suspendedProcess - "Answer the UI we created a new process for" - - suspendedProcess animatedUI ifNotNil: [ :guiRootObject | - self spawnNewMorphicProcessFor: guiRootObject. - ^guiRootObject ]. - ^nil! ! -!UISupervisor class methodsFor: 'gui process' stamp: 'jmv 12/28/2017 15:04:16'! - userInterrupt - "Create a Notifier on the active scheduling process with the given label." - | preemptedProcess | - preemptedProcess _ Processor preemptedProcess. - - "Only debug preempted process if its priority is >= UIProcess' priority" - preemptedProcess priority < UIProcess priority ifTrue: [ - preemptedProcess _ UIProcess ]. - - Debugger interruptProcess: preemptedProcess label: 'User Interrupt'! ! -!PasteUpMorph methodsFor: 'interaction loop' stamp: 'jmv 12/28/2017 14:38:23'! -mainLoop - - - self clearWaitDelay. - self clearCanvas. - [ - self doOneCycle. - Processor yield. - true ] - whileTrue: []! ! -!PasteUpMorph methodsFor: 'interaction loop' stamp: 'jmv 12/28/2017 14:40:22'! - runProcess - | process | - process _ [ self mainLoop ] - newProcess. - process - priority: Processor userSchedulingPriority; - name: 'Morphic UI'; - animatedUI: self. - ^ process! ! -!Debugger methodsFor: 'initialization' stamp: 'jmv 12/28/2017 14:43:57' prior: 50377369! - openFullNoSuspendLabel: aString - "Create and schedule a full debugger with the given label. Do not terminate the current active process." - - self openFullMorphicLabel: aString. - interruptedProcessUI _ UISupervisor newProcessIfUI: interruptedProcess! ! -!Debugger methodsFor: 'initialization' stamp: 'jmv 12/28/2017 14:44:04' prior: 50377381! - openNotifierContents: msgString label: label - "Create and schedule a notifier view with the given label and message. A notifier view shows just the message or the first several lines of the stack, with a menu that allows the user to open a full debugger if so desired." - "NOTE: When this method returns, a new process has been scheduled to run the windows, and thus this notifier, but the previous active porcess has not been suspended. The sender will do this." - | msg | - Sensor flushKeyboard. - savedCursor _ Cursor currentCursor. - Cursor normal activateCursor. - msg _ (label beginsWith: 'Space is low') - ifTrue: [ self lowSpaceChoices, (msgString ifNil: ['']) ] - ifFalse: [ msgString ]. - - interruptedProcessUI _ UISupervisor newProcessIfUI: interruptedProcess. - WorldState addDeferredUIMessage: [ - PreDebugWindow open: self label: label message: msg ]. - ^self! ! -!Debugger class methodsFor: 'opening' stamp: 'jmv 12/28/2017 14:44:13' prior: 50377412! - openOn: process context: context label: title fullView: bool - "Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger." - | w | - Preferences logDebuggerStackToFile ifTrue: [ - Smalltalk - logError: title - inContext: context - to: 'CuisDebug' ]. - w := UISupervisor newProcessIfUI: process. - "schedule debugger in deferred UI message to address redraw - problems after opening a debugger e.g. from the testrunner." - WorldState addDeferredUIMessage: [ - [ | debugger | - "In case an error in Morphic code got us here, ensure mouse focus has been released" - true runningWorld ifNotNil: [ :rWorld | - rWorld activeHand ifNotNil: [ :aHand | - aHand releaseMouseFocus ]]. - debugger := self new - process: process - context: context. - debugger interruptedProcessUI: w. - bool - ifTrue: [ debugger openFullMorphicLabel: title ] - ifFalse: [ - PreDebugWindow - open: debugger - label: title - message: nil ]] - on: UnhandledError - do: [ :exOuter | | errorDescription | - errorDescription := 'Error while trying to open Debugger' , String newLineString , 'Orginal error: ' , title asString , '.' , String newLineString , ' Debugger error: ' , - ([ exOuter description ] - on: UnhandledError - do: [ :exInner | - exInner return: 'a ' , exInner class printString ]) , ':'. - self primitiveError: errorDescription ]]. - process suspend.! ! -!SystemDictionary methodsFor: 'memory space' stamp: 'jmv 12/28/2017 15:00:19' prior: 50377463! - lowSpaceWatcher - "Wait until the low space semaphore is signalled, then take appropriate actions." - - self garbageCollectMost <= self lowSpaceThreshold ifTrue: [ - self garbageCollect <= self lowSpaceThreshold ifTrue: [ - "free space must be above threshold before starting low space watcher" - ^ Smalltalk primitiveBeep ]]. - - LowSpaceSemaphore _ Semaphore new. - self primLowSpaceSemaphore: LowSpaceSemaphore. - self primSignalAtBytesLeft: self lowSpaceThreshold. "enable low space interrupts" - - LowSpaceSemaphore wait. "wait for a low space condition..." - - self primSignalAtBytesLeft: 0. "disable low space interrupts" - self primLowSpaceSemaphore: nil. - LowSpaceProcess _ nil. - "Note: user now unprotected until the low space watcher is re-installed" - - Debugger interruptProcess: Processor preemptedProcess label: 'Space is low'! ! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jmv 12/28/2017 15:04:08' prior: 50377493! - handleUserInterrupt - Preferences cmdDotEnabled ifTrue: [ - [ UISupervisor userInterrupt ] fork]! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 12/28/2017 14:48:02' prior: 50377736! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag -"WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " -| activeProc | -activeProc _ Processor activeProcess. -[ - | isARealStartup guiRootObject reopenTranscript | - self logSnapshot: save andQuit: quit. - - reopenTranscript _ false. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | each isInWorld ifTrue: [ each delete. reopenTranscript _ true ]]. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - - - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - - "Cosas que levanto explicitamente abajo" - guiRootObject _ UISupervisor ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "guiRootObject _ clearAllStateFlag ifFalse: [ UISupervisor ui ]." - UISupervisor stopUIProcess. - activeProc isTerminated ifFalse: [ - activeProc terminate ]. - - "Clean Globals" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: nil. - Smalltalk closeSourceFiles. Smalltalk at: #SourceFiles put: nil. - Smalltalk allClassesDo: [ :cls | cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ Smalltalk printStuffToCleanOnImageSave ]. - - - "Do image save & quit as apropriate" - Cursor write activateCursor. - save - ifTrue: [ - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - - - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: (DisplayScreen extent: `1024@768` depth: 32). - Smalltalk at: #SourceFiles put: (Array new: 2). - Smalltalk openSourceFiles. - - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - - UISupervisor spawnNewMorphicProcessFor: (guiRootObject ifNil: [ guiRootObject _ self privateMorphicWorldClass newWorld ]). - - reopenTranscript ifTrue: [ - guiRootObject addDeferredUIMessage: [ - TranscriptWindow openTranscript ]]. - " - world addDeferredUIMessage: [ - world fullRepaintNeeded ]. - " - - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - guiRootObject addDeferredUIMessage: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]. - -] forkAt: Processor timingPriority-1 named: 'Startup process'.! ! -!UISupervisor class methodsFor: 'gui process' stamp: 'jmv 12/28/2017 14:50:33' prior: 16896377! - spawnNewMorphicProcessFor: guiRootObject - - UIProcess ifNotNil: [ UIProcess animatedUI: nil ]. - UIProcess _ guiRootObject runProcess. - UIProcess resume! ! -!UISupervisor class methodsFor: 'gui process' stamp: 'jmv 12/28/2017 15:10:48' prior: 16896390! - stopUIProcess - UIProcess ifNotNil: [ - UIProcess animatedUI: nil. - UIProcess terminate ]. - UIProcess _ nil! ! -!UISupervisor class methodsFor: 'gui process' stamp: 'jmv 12/28/2017 15:09:33' prior: 16896397! - ui - ^UIProcess animatedUI! ! - -UISupervisor class removeSelector: #currentInterruptNameX:! - -UISupervisor class removeSelector: #currentInterruptNameX:! - -UISupervisor class removeSelector: #interruptNameX:! - -UISupervisor class removeSelector: #interruptNameX:! - -UISupervisor class removeSelector: #newProcessIfUIX:! - -UISupervisor class removeSelector: #newProcessIfUIX:! - -SystemDictionary removeSelector: #privateMorphicTopLevelRendererClass! - -SystemDictionary removeSelector: #privateMorphicTopLevelRendererClass! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3240-UISupervisor-cleanup-JuanVuletich-2017Dec28-15h06m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3239] on 28 December 2017 at 3:20:41 pm'! -!SystemDictionary methodsFor: 'shrinking' stamp: 'jmv 4/25/2016 15:31' prior: 50377501! - reduceCuis - " - Smalltalk reduceCuis - " - | keep n unused newDicts oldDicts | - - self nominallyUnsent: #reduceCuis. - - "Remove icons" - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - PasteUpMorph allInstancesDo: [ :w | - w backgroundImageData: nil. - w submorphsDo: [ :a | a delete ]]. - Preferences useNoIcons. - Theme current initialize. - Theme content: nil. - Color shutDown. - BitBltCanvas releaseClassCachedState. - - Transcript clear. - Clipboard default initialize. - - - "Remove some methods, even if they have senders." -" ColorPickerMorph class removeSelector: #buildEyedropperIcon." - Theme removeSelector: #miscellaneousIcons. - Utilities removeSelector: #vmStatisticsReportString. - SystemDictionary removeSelector: #recreateSpecialObjectsArray. - - StrikeFont removeMostFonts. - StrikeFont saveSpace. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - - keep := OrderedCollection new. - keep addAll: #(SpaceTally). - AppLauncher appGlobalName ifNotNil: [ :any | - keep add: any ]. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - [ - #hereWeGo print. - unused do: [:c | - c print. - (Smalltalk at: c) removeFromSystem]. - n := Smalltalk removeAllUnSentMessages. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - n > 0 or: [ - unused notEmpty ]] whileTrue. - ChangeSet zapAllChangeSets. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - Symbol rehash. - - "Shrink method dictionaries." - Smalltalk garbageCollect. - oldDicts _ MethodDictionary allInstances. - newDicts _ Array new: oldDicts size. - oldDicts withIndexDo: [:d :index | - newDicts at: index put: d rehashWithoutBecome ]. - oldDicts elementsExchangeIdentityWith: newDicts. - oldDicts _ newDicts _ nil. - - SmalltalkCompleter initialize . - - "Sanity checks" -" Undeclared - Smalltalk cleanOutUndeclared - Smalltalk browseUndeclaredReferences - Smalltalk obsoleteClasses - Smalltalk obsoleteBehaviors - Smalltalk browseObsoleteMethodReferences - SmalltalkImage current fixObsoleteReferences - Smalltalk browseAllUnimplementedCalls"! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 12/28/2017 15:19:25' prior: 50378816! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag -"WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " -| activeProc | -activeProc _ Processor activeProcess. -[ - | isARealStartup guiRootObject guiRootObjectClass reopenTranscript | - self logSnapshot: save andQuit: quit. - - reopenTranscript _ false. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | each isInWorld ifTrue: [ each delete. reopenTranscript _ true ]]. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - - - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - - "Cosas que levanto explicitamente abajo" - guiRootObjectClass _ UISupervisor ui class. - guiRootObject _ UISupervisor ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "guiRootObject _ clearAllStateFlag ifFalse: [ UISupervisor ui ]." - UISupervisor stopUIProcess. - activeProc isTerminated ifFalse: [ - activeProc terminate ]. - - "Clean Globals" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: nil. - Smalltalk closeSourceFiles. Smalltalk at: #SourceFiles put: nil. - Smalltalk allClassesDo: [ :cls | cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ Smalltalk printStuffToCleanOnImageSave ]. - - - "Do image save & quit as apropriate" - Cursor write activateCursor. - save - ifTrue: [ - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - - - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: (DisplayScreen extent: `1024@768` depth: 32). - Smalltalk at: #SourceFiles put: (Array new: 2). - Smalltalk openSourceFiles. - - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - - UISupervisor spawnNewMorphicProcessFor: (guiRootObject ifNil: [ guiRootObject _ guiRootObjectClass newWorld ]). - - reopenTranscript ifTrue: [ - guiRootObject addDeferredUIMessage: [ - TranscriptWindow openTranscript ]]. - " - world addDeferredUIMessage: [ - world fullRepaintNeeded ]. - " - - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - guiRootObject addDeferredUIMessage: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]. - -] forkAt: Processor timingPriority-1 named: 'Startup process'.! ! -!PasteUpMorph class methodsFor: 'instance creation' stamp: 'jmv 12/28/2017 15:19:42' prior: 50362764! - newWorld - " -[ - UISupervisor stopUIProcess. - UISupervisor spawnNewMorphicProcessFor: PasteUpMorph newWorld -] fork. - " - | w ws | - w _ self new. - ws _ WorldState new. - w worldState: ws. - w morphPosition: `0@0` extent: Display extent. - ws setCanvas: Display getCanvas. - w borderWidth: 0. - ws handsDo: [ :h | - h privateOwner: w ]. - ^w! ! - -SystemDictionary removeSelector: #privateMorphicWorldClass! - -SystemDictionary removeSelector: #privateMorphicWorldClass! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3241-dontAskForWorldClass-JuanVuletich-2017Dec28-15h15m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3239] on 28 December 2017 at 3:45:45 pm'! -!BlockClosure commentStamp: 'jmv 12/28/2017 15:42:10' prior: 16787685! - I am a block closure for Eliot's closure implementation. Not to be confused with the old BlockClosure (they were never part of Cuis anyway). - -This is a closure converted image. With full closure support, you can finally use recursive blocks like here: - -| fac | - fac := [:n| n > 1 ifTrue:[n * (fac value: n-1)] ifFalse:[1]]. - fac value: 5. "120" - -and close over temps correctly, such as here: - - (1 to: 10) do:[:i| UISupervisor whenUIinSafeState:[Transcript newLine; show: i]]. - -Another good example: - -| fib | -fib := [:n| n < 2 ifTrue:[1] ifFalse:[(fib value:n-1) + (fib value:n-2)]]. -fib value: 10. "89"! -!UISupervisor class methodsFor: 'services' stamp: 'jmv 12/28/2017 15:36:24'! - restoreDisplay - DisplayScreen startUp. - self ui ifNotNil: [ :guiRootObject | - guiRootObject restoreDisplay ]. - UISupervisor whenUIinSafeState: [ Cursor normal activateCursor ]! ! -!UISupervisor class methodsFor: 'services' stamp: 'jmv 12/28/2017 15:29:34'! - whenUIinSafeState: evaluableObject - "If there is an UI present, evaluate argument when such UI is in a safe state. - If not, just evaluate the argument right now." - self ui - ifNotNil: [ :guiRootObject | guiRootObject whenUIinSafeState: evaluableObject ] - ifNil: evaluableObject! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 12/28/2017 15:36:22'! - restoreDisplay - self - morphExtent: Display extent; - handsDo: [ :h | h visible: true ]; - fullRepaintNeeded! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 12/28/2017 15:30:26'! - whenUIinSafeState: evaluableObject - "Please call - UISupervisor whenUIinSafeState: evaluableObject - " - WorldState addDeferredUIMessage: evaluableObject ! ! -!Debugger methodsFor: 'initialization' stamp: 'jmv 12/28/2017 15:31:17' prior: 50378699! - openNotifierContents: msgString label: label - "Create and schedule a notifier view with the given label and message. A notifier view shows just the message or the first several lines of the stack, with a menu that allows the user to open a full debugger if so desired." - "NOTE: When this method returns, a new process has been scheduled to run the windows, and thus this notifier, but the previous active porcess has not been suspended. The sender will do this." - | msg | - Sensor flushKeyboard. - savedCursor _ Cursor currentCursor. - Cursor normal activateCursor. - msg _ (label beginsWith: 'Space is low') - ifTrue: [ self lowSpaceChoices, (msgString ifNil: ['']) ] - ifFalse: [ msgString ]. - - interruptedProcessUI _ UISupervisor newProcessIfUI: interruptedProcess. - UISupervisor whenUIinSafeState: [ - PreDebugWindow open: self label: label message: msg ]. - ^self! ! -!Debugger class methodsFor: 'opening' stamp: 'jmv 12/28/2017 15:31:22' prior: 50378729! - openOn: process context: context label: title fullView: bool - "Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger." - | w | - Preferences logDebuggerStackToFile ifTrue: [ - Smalltalk - logError: title - inContext: context - to: 'CuisDebug' ]. - w := UISupervisor newProcessIfUI: process. - "schedule debugger in deferred UI message to address redraw - problems after opening a debugger e.g. from the testrunner." - UISupervisor whenUIinSafeState: [ - [ | debugger | - "In case an error in Morphic code got us here, ensure mouse focus has been released" - true runningWorld ifNotNil: [ :rWorld | - rWorld activeHand ifNotNil: [ :aHand | - aHand releaseMouseFocus ]]. - debugger := self new - process: process - context: context. - debugger interruptedProcessUI: w. - bool - ifTrue: [ debugger openFullMorphicLabel: title ] - ifFalse: [ - PreDebugWindow - open: debugger - label: title - message: nil ]] - on: UnhandledError - do: [ :exOuter | | errorDescription | - errorDescription := 'Error while trying to open Debugger' , String newLineString , 'Orginal error: ' , title asString , '.' , String newLineString , ' Debugger error: ' , - ([ exOuter description ] - on: UnhandledError - do: [ :exInner | - exInner return: 'a ' , exInner class printString ]) , ':'. - self primitiveError: errorDescription ]]. - process suspend.! ! -!TestRunner methodsFor: 'processing' stamp: 'jmv 12/28/2017 15:41:46' prior: 16928246! - runSuite: suite - running ifNotNil: [ ^self inform: 'already running' ]. - suite addDependent: self. - totalTests _ suite tests size. - completedTests _ 0. - running _ [ - [ result _ suite run ] - ensure: [ - running _ nil. - suite removeDependent: self. - runSemaphore signal. - UISupervisor whenUIinSafeState: [ - self updateWindow: result. - self changed: #runTests. - self changed: #runOneTest. - ]. - ]. - ] newProcess. - self runWindow. - self changed: #runTests. - self changed: #runOneTest. - running - name: 'TestRunner'; -" priority: Processor userBackgroundPriority;" - resume. -! ! -!TestRunner methodsFor: 'processing' stamp: 'jmv 12/28/2017 15:41:57' prior: 16928270! - runSuiteProfiled: suite - running ifNotNil: [ ^self inform: 'already running' ]. - suite addDependent: self. - totalTests _ suite tests size. - completedTests _ 0. - running _ [ - [ result _ MessageTally spyOn: [suite run] ] - ensure: [ - running _ nil. - suite removeDependent: self. - runSemaphore signal. - UISupervisor whenUIinSafeState: [ - self updateWindow: result. - self changed: #runTests. - self changed: #runOneTest. - ]. - ]. - ] newProcess. - self runWindow. - self changed: #runTests. - self changed: #runOneTest. - running - name: 'TestRunner'; -" priority: Processor userBackgroundPriority;" - resume. -! ! -!TestRunner methodsFor: 'updating' stamp: 'jmv 12/28/2017 15:41:51' prior: 16928371! - update: aParameter - "updates come in from another thread" - (aParameter is: #TestCase) - ifTrue: [ - UISupervisor whenUIinSafeState: [ - completedTests _ completedTests + 1. - progressLabel _ aParameter printString. - self changed: #progress ]] - ifFalse: [ super update: aParameter ]! ! -!CPUWatcher methodsFor: 'porcine capture' stamp: 'jmv 12/28/2017 15:31:10' prior: 16795052! - openWindowForSuspendedProcess: aProcess - - UISupervisor whenUIinSafeState: [self openMorphicWindowForSuspendedProcess: aProcess]! ! -!ProcessBrowser class methodsFor: 'CPU utilization' stamp: 'jmv 12/28/2017 15:42:34' prior: 16895203! - dumpPigStackOn: aStream - "Must run forked on its own process, so the monitored behavior is not affected too much" - - | promise tally process depth stack suspendedContext | - promise := Processor tallyCPUUsageFor: 1 every: 10. - tally := promise value. - "UISupervisor whenUIinSafeState: [self dumpTallyOnTranscript: tally]." - aStream nextPutAll: '====Al processes===='; newLine. - self dumpTally: tally on: aStream. - aStream newLine; nextPutAll: '====Process using most CPU===='; newLine. - process _ tally sortedCounts first value. - (100.0 * (tally occurrencesOf: process) / tally size) rounded printOn: aStream. - aStream - nextPutAll: ' % '; - nextPutAll: (process browserPrintStringFull: false); - newLine. - depth _ 20. - stack _ process == Processor activeProcess - ifTrue: [thisContext stackOfSize: depth] - ifFalse: [suspendedContext _ process suspendedContext. - suspendedContext - ifNotNil: [suspendedContext stackOfSize: depth]]. - stack - ifNil: [ aStream nextPutAll: 'No context'; newLine] - ifNotNil: [ - stack do: [ :c | - c printOn: aStream. - aStream newLine ]]! ! -!MessageTally class methodsFor: 'spying' stamp: 'jmv 12/28/2017 15:31:52' prior: 16870883! - tallySendsTo: receiver inBlock: aBlock - " - MessageTally tallySends: [3.14159 printString] - " - "This method uses the simulator to count the number of calls on each method - invoked in evaluating aBlock. If receiver is not nil, then only sends - to that receiver are tallied. - Results are presented as leaves, sorted by frequency, - preceded, optionally, by the whole tree." - | prev tallies startTime totalTime | - startTime _ Time localMillisecondClock. - tallies _ self new class: aBlock receiver class method: aBlock method. - prev _ aBlock. - thisContext sender - runSimulated: aBlock - contextAtEachStep: [ :current | - current == prev ifFalse: [ "call or return" - prev sender ifNotNil: [ "call only" - (receiver == nil or: [ current receiver == receiver ]) - ifTrue: [ tallies tally: current by: 1 ]]. - prev _ current]]. - - totalTime _ Time localMillisecondClock - startTime / 1000.0. - UISupervisor whenUIinSafeState: [ - SystemWindow - editText: (Workspace withText: (String streamContents: [ :s | - s - nextPutAll: 'This simulation took '; - nextPutAll: totalTime printString; - nextPutAll: ' seconds.'; - newLine. - tallies fullPrintExactOn: s ])) - label: 'Spy Results' - wrap: false ]! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 12/28/2017 15:42:48' prior: 50379047! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag -"WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " -| activeProc | -activeProc _ Processor activeProcess. -[ - | isARealStartup guiRootObject guiRootObjectClass reopenTranscript | - self logSnapshot: save andQuit: quit. - - reopenTranscript _ false. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | each isInWorld ifTrue: [ each delete. reopenTranscript _ true ]]. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - - - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - - "Cosas que levanto explicitamente abajo" - guiRootObjectClass _ UISupervisor ui class. - guiRootObject _ UISupervisor ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "guiRootObject _ clearAllStateFlag ifFalse: [ UISupervisor ui ]." - UISupervisor stopUIProcess. - activeProc isTerminated ifFalse: [ - activeProc terminate ]. - - "Clean Globals" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: nil. - Smalltalk closeSourceFiles. Smalltalk at: #SourceFiles put: nil. - Smalltalk allClassesDo: [ :cls | cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ Smalltalk printStuffToCleanOnImageSave ]. - - - "Do image save & quit as apropriate" - Cursor write activateCursor. - save - ifTrue: [ - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - - - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: (DisplayScreen extent: `1024@768` depth: 32). - Smalltalk at: #SourceFiles put: (Array new: 2). - Smalltalk openSourceFiles. - - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - - UISupervisor spawnNewMorphicProcessFor: (guiRootObject ifNil: [ guiRootObject _ guiRootObjectClass newWorld ]). - - reopenTranscript ifTrue: [ - UISupervisor whenUIinSafeState: [ - TranscriptWindow openTranscript ]]. - " - UISupervisor whenUIinSafeState: [ - guiRootObject fullRepaintNeeded ]. - " - - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - UISupervisor whenUIinSafeState: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]. - -] forkAt: Processor timingPriority-1 named: 'Startup process'.! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'jmv 12/28/2017 15:40:12' prior: 50369767! - restoreLostChangesIfNecessary - - " - Smalltalk restoreLostChangesIfNecessary - " - - self hasToRestoreChanges ifTrue: [ UISupervisor whenUIinSafeState: [self restoreLostChanges ]]. -! ! -!UISupervisor class methodsFor: 'gui process' stamp: 'jmv 12/28/2017 15:26:47' prior: 50378949! - ui - ^UIProcess ifNotNil: [ UIProcess animatedUI ]! ! -!UISupervisor class methodsFor: 'gui process' stamp: 'jmv 12/28/2017 15:27:03' prior: 50378657! - userInterrupt - "Create a Notifier on the active scheduling process with the given label." - | preemptedProcess | - preemptedProcess _ Processor preemptedProcess. - - "Only debug preempted process if its priority is >= UIProcess' priority" - UIProcess ifNotNil: [ - preemptedProcess priority < UIProcess priority ifTrue: [ - preemptedProcess _ UIProcess ]]. - - Debugger interruptProcess: preemptedProcess label: 'User Interrupt'! ! -!DisplayScreen methodsFor: 'other' stamp: 'jmv 12/28/2017 15:22:40' prior: 16835232! -newDepth: pixelSize -" - Display newDepth: 8. - Display newDepth: 1. -" - (self supportsDisplayDepth: pixelSize) - ifFalse: [ ^self inform:'Display depth ', pixelSize printString, ' is not supported on this system' ]. - self newDepthNoRestore: pixelSize. - self runningWorld ifNotNil: [ :w | w buildMagnifiedBackgroundImage ]. - self restore.! ! -!DisplayScreen class methodsFor: 'display box access' stamp: 'jmv 12/28/2017 15:37:02' prior: 16835493! - checkForNewScreenSize - "Check whether the screen size has changed and if so take appropriate actions" - - Display extent = DisplayScreen actualScreenSize ifTrue: [^ self]. - UISupervisor restoreDisplay! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 12/28/2017 15:33:32' prior: 50377855! - showBalloon: msgString hand: aHand - "Pop up a balloon containing the given string, - first removing any existing BalloonMorphs in the world." - - | w balloon h | - (w _ self world) ifNil: [^ self]. - h _ aHand. - h ifNil:[ - h _ w activeHand]. - balloon _ HoverHelpMorph contents: msgString. - - "Do it in a while. In some cases, processing the event that might have triggered us might also remove any Help Balloon" - UISupervisor whenUIinSafeState: [ - balloon popUpForHand: h ]! ! -!Morph methodsFor: 'initialization' stamp: 'jmv 12/28/2017 15:32:34' prior: 16875939! - openInWorld - - self runningWorld - ifNil: [ UISupervisor whenUIinSafeState: [ self openInWorld ]] - ifNotNil: [ :w | self openInWorld: w ]! ! -!PasteUpMorph class methodsFor: 'system startup' stamp: 'jmv 12/28/2017 15:37:37' prior: 16887941! - initClassCachedState - - "Should use some other way to find relevant instances" - self flag: #jmvVer2. - self allInstancesDo: [ :each | - each buildMagnifiedBackgroundImage. - each isWorldMorph ifTrue: [ - each restoreDisplay ]]. - Cursor normal activateCursor! ! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 12/28/2017 15:31:28' prior: 50378168! - arrowKey: aChar - "Handle a keyboard navigation character. Answer true if handled, false if not." - | keyEvent answer nextSelection oldSelection | - answer := false. - keyEvent := aChar numericValue. - oldSelection := self getSelectionIndex. - nextSelection := oldSelection. - keyEvent = 31 ifTrue: [ - "down" - nextSelection := oldSelection + 1. - nextSelection > self maximumSelection ifTrue: [ nextSelection := self minimumSelection ]]. - keyEvent = 30 ifTrue: [ - "up" - nextSelection := oldSelection - 1. - nextSelection < self minimumSelection ifTrue: [ nextSelection := self maximumSelection ]]. - keyEvent = 1 ifTrue: [ "home" - nextSelection := 1 ]. - keyEvent = 4 ifTrue: [ "end" - nextSelection := scroller submorphs size ]. - keyEvent = 11 ifTrue: [ "page up" - nextSelection := oldSelection - self numSelectionsInView max: 1 ]. - keyEvent = 12 ifTrue: [ "page down" - nextSelection := oldSelection + self numSelectionsInView ]. - keyEvent = 29 ifTrue: [ - "right" - selectedMorph ifNotNil: [ - (selectedMorph canExpand and: [ selectedMorph isExpanded not ]) - ifTrue: [ - self toggleExpandedState: selectedMorph. - self scrollSelectionIntoView. - answer := true ] - ifFalse: [ nextSelection := oldSelection + 1 ]]]. - keyEvent = 28 ifTrue: [ - "left" - selectedMorph ifNotNil: [ - selectedMorph isExpanded - ifTrue: [ - self toggleExpandedState: selectedMorph. - self scrollSelectionIntoView. - answer := true ] - ifFalse: [ - oldSelection > self minimumSelection ifTrue: [ - nextSelection _ (oldSelection-1 to: 1 by: -1) detect: [ :i | ( scroller submorphs at: i) indentLevel < selectedMorph indentLevel ]]. - ]]]. - nextSelection = oldSelection ifFalse: [ - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self highlightedMorph: (self listMorphAt: nextSelection). - "Update the model in next world cycle, so user gets the immediate feedback." - UISupervisor whenUIinSafeState: [ self setSelectionIndex: nextSelection ]. - answer := true ]. - ^ answer.! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 12/28/2017 15:39:41' prior: 50377944! - arrowKey: aChar - "Process the up and down arrows in a list pane. Note that the listView tells us what index variable, how to get the list, and how to move the index." - | keyEvent oldSelection nextSelection max min howMany answer w | - answer _ false. - keyEvent _ aChar numericValue. - oldSelection _ self getCurrentSelectionIndex. - nextSelection _ oldSelection. - max _ self maximumSelection. - min _ self minimumSelection. - howMany _ self numSelectionsInView. "get this exactly??" - - keyEvent = 31 ifTrue: [ - "down-arrow; move down one, wrapping to top if needed" - nextSelection _ oldSelection + 1. - nextSelection > max ifTrue: [ nextSelection _ 1 ]]. - - keyEvent = 30 ifTrue: [ - "up arrow; move up one, wrapping to bottom if needed" - nextSelection _ oldSelection - 1. - nextSelection < 1 ifTrue: [ nextSelection _ max ]]. - - keyEvent = 1 ifTrue: [ nextSelection _ 1 ]. "home" - keyEvent = 4 ifTrue: [ nextSelection _ max ]. "end" - keyEvent = 11 ifTrue: [ nextSelection _ min max: oldSelection - howMany ]. "page up" - keyEvent = 12 ifTrue: [ nextSelection _ oldSelection + howMany min: max ]. "page down" - nextSelection = oldSelection ifFalse: [ - w _ self owningWindow. - (w isNil or: [ w okToChange ]) ifTrue: [ "No change if model is locked" - - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self listMorph highlightedRow: nextSelection. - - "Update the model in next world cycle, so user gets the immediate feedback." - UISupervisor whenUIinSafeState: [ - self changeModelSelection: nextSelection ]. - answer _ true ]]. - ^answer! ! -!PluggableListMorphOfMany methodsFor: 'events' stamp: 'jmv 12/28/2017 15:39:45' prior: 50377998! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - - | oldIndex oldVal row w | - self hasKeyboardFocus ifFalse: [ - aMouseButtonEvent hand newKeyboardFocus: self ]. - - row _ self rowAtLocation: localEventPosition. - - row = 0 ifTrue: [ - ^super mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition ]. - - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self listMorph highlightedRow: row. - - w _ self owningWindow. - (w isNil or: [ w okToChange ]) ifTrue: [ "No change if model is locked" - - "Set meaning for subsequent dragging of selection" - dragOnOrOff _ (self listSelectionAt: row) not. - dragStartRow _ row. - oldIndex _ self getCurrentSelectionIndex. - oldIndex ~= 0 ifTrue: [oldVal _ self listSelectionAt: oldIndex]. - - "Different from PluggableListMorph. There, we highlight on mouse down, and act on mouse up. - Here, we act on mouse down, because we support dragging of selection, so mouse up will - only happen after user is finished dragging. In order to get the highlight visible for the user, - update the model on next world cycle." - UISupervisor whenUIinSafeState: [ - "Set or clear new primary selection (listIndex)" - dragOnOrOff - ifTrue: [self changeModelSelection: row] - ifFalse: [self changeModelSelection: 0]. - "Need to restore the old one, due to how model works, and set new one." - oldIndex ~= 0 ifTrue: [self listSelectionAt: oldIndex put: oldVal]. - self listSelectionAt: row put: dragOnOrOff ]. - ]. - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: nil - clkNHalf: nil - dblClkSel: #doubleClick:localPosition: - dblClkNHalfSel: nil - tripleClkSel: nil! ! -!SystemWindow methodsFor: 'open/close' stamp: 'jmv 12/28/2017 15:41:35' prior: 50378056! - openInWorld: aWorld - "This msg and its callees result in the window being activeOnlyOnTop" - | frameRect | - frameRect _ self initialFrameIn: aWorld. - self morphExtent: frameRect extent. - aWorld addMorph: self position: frameRect topLeft. - "Do it deferred. Was needed for text cursor to start blinking if (Preferences disable: #focusFollowsMouse) " - UISupervisor whenUIinSafeState: [ self activate ]! ! -!TaskbarMorph methodsFor: 'events' stamp: 'jmv 12/28/2017 15:41:40' prior: 50378072! - screenSizeChanged - "Respond to change in screen size by repositioning self to bottom of screen" - -" Transcript newLine; print: 'Taskbar screenSizeChanged'. -" - | y e | - UISupervisor whenUIinSafeState: [ - self world ifNotNil: [ :w | - y _ w morphExtent y - self defaultHeight. - e _ self internalizeDistance: w morphExtent x @ self defaultHeight. - self morphPosition: 0@y extent: e ]]! ! -!InnerTextMorph methodsFor: 'editing' stamp: 'jmv 12/28/2017 15:31:44' prior: 50378087! - acceptContents - "The message is sent when the user hits return or Cmd-S. - Accept the current contents and end editing." - "Inform the model of text to be accepted, and return true if OK." - - | accepted prevSelection prevScrollValue | - - prevSelection _ self editor selectionInterval copy. - prevScrollValue _ owner verticalScrollBar scrollValue. - - (self canDiscardEdits and: [(self hasProperty: #alwaysAccept) not]) ifTrue: [self flash. ^true]. - (self hasEditingConflicts and: [ self confirmAcceptAnyway not ]) ifTrue: [self flash. ^false]. - - accepted _ model acceptContentsFrom: owner. - "During the step for the browser, updatePaneIfNeeded is called, and - invariably resets the contents of the code-holding PluggableTextMorph - at that time, resetting the cursor position and scroller in the process. - The following line forces that update without waiting for the step, - then restores the cursor and scrollbar" - - "some implementors of acceptContentsFrom: answer self :(" - ^accepted == true - ifTrue: [ - model refetch. - self editor selectFrom: prevSelection first to: prevSelection last. - UISupervisor whenUIinSafeState: [ - self world ifNotNil: [ :w | w activeHand newKeyboardFocus: self ]. - owner verticalScrollBar internalScrollValue: prevScrollValue]. - true] - ifFalse: [ false ]! ! -!WorldState class methodsFor: 'class initialization' stamp: 'jmv 12/28/2017 15:26:18' prior: 50378134! - addDeferredUIMessage: evaluableObject - "Objects should not be calling directly as this will disappear from this location!! From the sender, instead to schedule on the currently running world use: - self runningWorld addDeferredUIMessage: ... - And to schedule on the world a given Morph exists in use: - self world addDeferredUIMessage: ..." - self deferredUIMessages nextPut: evaluableObject! ! -!TheWorldMenu methodsFor: 'commands' stamp: 'jmv 12/28/2017 15:38:38' prior: 16934600! -fullScreenOff - - Display fullScreenMode: false. - DisplayScreen checkForNewScreenSize. - myWorld restoreDisplay! ! -!TheWorldMenu methodsFor: 'commands' stamp: 'jmv 12/28/2017 15:38:40' prior: 16934606! - fullScreenOn - - Display fullScreenMode: true. - DisplayScreen checkForNewScreenSize. - myWorld restoreDisplay! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 12/28/2017 15:37:53' prior: 50341417! - buildWorldMenu - "Build the menu that is put up when the screen-desktop is clicked on" - - | menu | - menu _ MenuMorph new defaultTarget: self. - self colorForDebugging: menu. - menu addStayUpIcons. - self fillIn: menu - from: { - { 'Open...'. { self. #openWindow}}. - { 'New morph...'. { self. #newMorph}. - 'Offers a variety of ways to create new objects'}. - { 'Preferences...'. { self. #preferencesDo}. - 'put up a menu offering many controls over appearance and system preferences.'}. - { 'Windows...'. { self. #windowsDo}}. - { 'Help...'. { self. #helpDo}. - 'puts up a menu of useful items for updating the system, determining what version you are running, and much else'}. - nil. - { 'Changes...'. { self. #changesDo}}. - { 'Debug...'. { self. #debugDo}. - 'a menu of debugging items'}. - { 'Restore Display (r)'. { myWorld. #restoreDisplay}. - 'repaint the screen -- useful for removing unwanted display artifacts, lingering cursors, etc.'}. - nil. - { 'Save'. { Smalltalk . #saveSession}. - 'save the current version of the image on disk'}. - { 'Save as...'. { Smalltalk . #saveAs}. - 'save the current version of the image on disk under a new name.'}. - { 'Save as New Version'. { Smalltalk . #saveAsNewVersion}. - 'give the current image a new version-stamped name\and save it under that name on disk.\Clear all user preferences and user state (class vars).' withNewLines}. - { 'Save and Quit'. { self. #saveAndQuit}. - 'save the image and quit out of Cuis.'}. - { 'Quit'. { self. #quitSession}. - 'quit out of Cuis.'}}. - ^menu! ! -!Theme class methodsFor: 'class initialization' stamp: 'jmv 12/28/2017 15:38:58' prior: 50377319! - currentTheme: aTheme - - CurrentTheme := aTheme new. - SHTextStylerST80 releaseClassCachedState. - self runningWorld ifNotNil: [ :w | - w backgroundImage ifNil: [ - w color: CurrentTheme background ]]. - SystemWindow initialize. - BitBltCanvas releaseClassCachedState. - self runningWorld ifNotNil: [ :w | - CurrentTheme useTaskbar - ifTrue: [w showTaskbar] - ifFalse: [w hideTaskbar]. - w restoreDisplay ]. - - ^ CurrentTheme! ! -!ProgessiveTestRunner methodsFor: 'evaluating - private' stamp: 'jmv 12/28/2017 15:40:01' prior: 50338203! - runSuiteShowingProgress - - [ self registerTestSuiteAction. - progressBar openInWorld. - self runSuite ] ensure: [ - self unregisterTestSuiteAction. - UISupervisor whenUIinSafeState: [progressBar dismissMorph] ]. - ! ! -!AndreasSystemProfiler methodsFor: 'reporting' stamp: 'jmv 12/28/2017 15:31:01' prior: 50378582! - doReport - "Report the results of this profiler run" - | report | - report _ self report. - UISupervisor whenUIinSafeState: [ - SystemWindow - editText: (Workspace withText: report) - label: 'Spy Results' - wrap: false ]! ! -!SHTextStyler methodsFor: 'styling' stamp: 'jmv 12/28/2017 15:40:06' prior: 16903157! - styleInBackgroundProcess - "Do the styling on a copy of the provided text (and in a separate process). - After finishing, send it to the model, by triggering #shoutStyled - The the model should grab the TextAttributes we added to the copy, as appropriate." - self terminateBackgroundStylingProcess. - - self mutex critical: [ - "This part runs at low priority, and signals sem when finished" - backgroundProcess _ [ - self privateStyle. - UISupervisor whenUIinSafeState: [ - textModel changed: #shoutStyled ]. - ] newProcess. - backgroundProcess - priority: Processor userBackgroundPriority; - name: 'Shout format'; - resume - ]! ! -!PopUpMenu class methodsFor: 'dialogs' stamp: 'jmv 12/28/2017 15:39:54' prior: 16891167! - inform: aString - "PopUpMenu inform: 'I like Cuis'" - - UISupervisor whenUIinSafeState: [ (PopUpMenu labels: ' OK ') startUpWithCaption: aString ]! ! - -PasteUpMorph removeSelector: #addDeferredUIMessage:! - -PasteUpMorph removeSelector: #addDeferredUIMessage:! - -PasteUpMorph removeSelector: #restoreMorphicDisplay! - -PasteUpMorph removeSelector: #restoreMorphicDisplay! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3242-UISupervisor-whenUIinSafeState-JuanVuletich-2017Dec28-15h20m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3242] on 28 December 2017 at 3:56:57 pm'! -!UISupervisor class methodsFor: 'gui process' stamp: 'jmv 12/28/2017 15:54:48' prior: 50379607! - ui - ^UIProcess ifNotNil: [ - UIProcess isSuspended ifFalse: [ - UIProcess animatedUI ]]! ! -!UISupervisor class methodsFor: 'services' stamp: 'jmv 12/28/2017 15:56:12' prior: 50379213! - restoreDisplay - DisplayScreen startUp. - self ui ifNotNil: [ :guiRootObject | - guiRootObject restoreDisplay ]. - self whenUIinSafeState: [ Cursor normal activateCursor ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3243-answerUIonlyIfActive-JuanVuletich-2017Dec28-15h54m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3243] on 29 December 2017 at 10:30:48 am'! -!HierarchicalListMorph methodsFor: 'selection' stamp: 'jmv 12/29/2017 10:29:16'! - privateVisualSelection: item - "Called internally to set a new selection. - Does not update model" - - self privateVisualSelectionIndex: (self indexForItem: item)! ! -!HierarchicalListMorph methodsFor: 'selection' stamp: 'jmv 12/29/2017 10:19:02'! - privateVisualSelectionIndex: idx - "Called internally to select the index-th item. - Does not update model" - self selectedMorph: (self listMorphAt: idx). - self scrollSelectionIntoView! ! -!HierarchicalListMorph methodsFor: 'selection' stamp: 'jmv 12/29/2017 09:42:44'! - visualSelectionIndex - ^scroller submorphs indexOf: selectedMorph! ! -!HierarchicalListMorph methodsFor: 'private' stamp: 'jmv 12/29/2017 10:28:53'! - indexForItem: item - | i | - item ifNil: [ - ^ 0 ]. - i _ scroller submorphs findFirst: [ :m | m complexContents == item ]. - i > 0 ifTrue: [ - ^ i ]. - i _ scroller submorphs findFirst: [ :m | m withoutListWrapper = item withoutListWrapper ]. - ^ i! ! -!PluggableListMorph methodsFor: 'model access' stamp: 'jmv 12/29/2017 09:32:10'! - setSelectionIndex: anInteger - "Change the model's selected item index to be anInteger." - - setIndexSelector ifNotNil: [ - model perform: setIndexSelector with: anInteger. - self update: getIndexSelector. - ^ true ]. - ^ false! ! -!PluggableListMorph methodsFor: 'selection' stamp: 'jmv 12/29/2017 09:05:26'! - privateVisualSelection: item - "Called internally to set a new selection. - Does not update model" - - self privateVisualSelectionIndex: (list indexOf: item)! ! -!PluggableListMorph methodsFor: 'selection' stamp: 'jmv 12/29/2017 08:57:30'! - privateVisualSelectionIndex: index - "Called internally to select the index-th item. - Does not update model" - | row | - row _ index ifNil: [ 0 ]. - row _ row min: self getListSize. "make sure we don't select past the end" - self listMorph selectedRow: row. - self scrollSelectionIntoView! ! -!PluggableListMorph methodsFor: 'selection' stamp: 'jmv 12/29/2017 08:59:40'! - visualSelection - self visualSelectionIndex = 0 ifTrue: [ ^nil ]. - list ifNotNil: [ ^list at: self visualSelectionIndex ]. - ^ self getListItem: self visualSelectionIndex! ! -!PluggableListMorph methodsFor: 'selection' stamp: 'jmv 12/29/2017 08:54:40'! - visualSelectionIndex - "return the index we have currently selected, or 0 if none" - ^self listMorph selectedRow ifNil: [ 0 ]! ! -!PluggableListMorphByItem methodsFor: 'model access' stamp: 'jmv 12/29/2017 09:32:13'! - setSelectionIndex: anInteger - "Change the model's selected item to be the one at the given index." - - | item | - setIndexSelector ifNotNil: [ - item _ (anInteger = 0 ifTrue: [nil] ifFalse: [itemList at: anInteger]). - model perform: setIndexSelector with: item. - self update: getIndexSelector. - ^ true ]. - ^false - ! ! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 12/29/2017 09:18:40' prior: 50379690! - arrowKey: aChar - "Handle a keyboard navigation character. Answer true if handled, false if not." - | keyEvent answer nextSelection oldSelection | - answer := false. - keyEvent := aChar numericValue. - oldSelection := self visualSelectionIndex. - nextSelection := oldSelection. - keyEvent = 31 ifTrue: [ - "down" - nextSelection := oldSelection + 1. - nextSelection > self maximumSelection ifTrue: [ nextSelection := self minimumSelection ]]. - keyEvent = 30 ifTrue: [ - "up" - nextSelection := oldSelection - 1. - nextSelection < self minimumSelection ifTrue: [ nextSelection := self maximumSelection ]]. - keyEvent = 1 ifTrue: [ "home" - nextSelection := 1 ]. - keyEvent = 4 ifTrue: [ "end" - nextSelection := scroller submorphs size ]. - keyEvent = 11 ifTrue: [ "page up" - nextSelection := oldSelection - self numSelectionsInView max: 1 ]. - keyEvent = 12 ifTrue: [ "page down" - nextSelection := oldSelection + self numSelectionsInView ]. - keyEvent = 29 ifTrue: [ - "right" - selectedMorph ifNotNil: [ - (selectedMorph canExpand and: [ selectedMorph isExpanded not ]) - ifTrue: [ - self toggleExpandedState: selectedMorph. - self scrollSelectionIntoView. - answer := true ] - ifFalse: [ nextSelection := oldSelection + 1 ]]]. - keyEvent = 28 ifTrue: [ - "left" - selectedMorph ifNotNil: [ - selectedMorph isExpanded - ifTrue: [ - self toggleExpandedState: selectedMorph. - self scrollSelectionIntoView. - answer := true ] - ifFalse: [ - oldSelection > self minimumSelection ifTrue: [ - nextSelection _ (oldSelection-1 to: 1 by: -1) detect: [ :i | ( scroller submorphs at: i) indentLevel < selectedMorph indentLevel ]]. - ]]]. - nextSelection = oldSelection ifFalse: [ - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self highlightedMorph: (self listMorphAt: nextSelection). - "Update the model in next world cycle, so user gets the immediate feedback." - UISupervisor whenUIinSafeState: [ self setSelectionIndex: nextSelection ]. - answer := true ]. - ^ answer.! ! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 12/29/2017 10:15:47' prior: 16853285! - setSelectionIndex: idx - "Change the model's selected item index to be anInteger." - - ^self setSelectedMorph: (self listMorphAt: idx)! ! -!HierarchicalListMorph methodsFor: 'selection' stamp: 'jmv 12/29/2017 10:30:10' prior: 16853374! - selection: item - "Called to set a new selection. - Updates both model and view." - "Assumes scroller submorphs is exactly our list. - Note: MAY NOT work right if list includes repeated items" - - self selectionIndex: (self indexForItem: item)! ! -!HierarchicalListMorph methodsFor: 'selection' stamp: 'jmv 12/29/2017 10:23:15' prior: 16853391! - selectionIndex: anInteger - "Public. Call to set selection. - Usually, view is updated from model updates. - If model updating fails (no model index setter defined) then just update visuals." - - (self setSelectionIndex: anInteger) ifFalse: [ - self privateVisualSelectionIndex: anInteger ]! ! -!HierarchicalListMorph methodsFor: 'selection' stamp: 'jmv 12/29/2017 10:16:19' prior: 16853399! - setSelectedMorph: aMorph - setSelectionSelector ifNil: [ ^ false ]. - model - perform: setSelectionSelector - with: aMorph complexContents ."leave last wrapper in place" - ^ true - - ! ! -!HierarchicalListMorph methodsFor: 'updating' stamp: 'jmv 12/29/2017 10:20:49' prior: 16853407! - update: aSymbol - super update: aSymbol. - aSymbol == getSelectionSelector - ifTrue: [ - self privateVisualSelection: self getCurrentSelectionItem. - ^self ]. - aSymbol == getListSelector - ifTrue: [ - self list: self getList. - ^self ]. - - "Indeed not pretty" - ( aSymbol notEmpty and: [aSymbol first == #openPath]) - ifTrue: [ - ^(scroller submorphs at: 1 ifAbsent: [^self]) - openPath: aSymbol allButFirst adaptor: #asString compare: #=]! ! -!HierarchicalListMorph methodsFor: 'private' stamp: 'jmv 12/29/2017 10:20:41' prior: 16853481! - insertNewMorphs: morphList - - scroller addAllMorphs: morphList. - scroller adjustExtent. - self setScrollDeltas. - self privateVisualSelection: self getCurrentSelectionItem! ! -!PluggableListMorph methodsFor: 'events' stamp: 'jmv 12/29/2017 09:43:57' prior: 50367353! - doubleClick: aMouseButtonEvent localPosition: localEventPosition - | index | - doubleClickSelector ifNil: [ ^super doubleClick: aMouseButtonEvent localPosition: localEventPosition ]. - index _ self rowAtLocation: localEventPosition. - index = 0 ifTrue: [ ^super doubleClick: aMouseButtonEvent localPosition: localEventPosition ]. - index == self visualSelectionIndex - ifFalse: [ self setSelectionIndex: index ]. - ^ self model perform: doubleClickSelector! ! -!PluggableListMorph methodsFor: 'events' stamp: 'jmv 12/29/2017 09:44:01' prior: 16888657! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - "The mouse came up within the list; take appropriate action" - - | row | - row _ self rowAtLocation: localEventPosition. - self owningWindow ifNotNil: [ :w | - w okToChange ifFalse: [ ^ self ]]. - (autoDeselect == false and: [row = 0 ]) ifTrue: [ ^ self ]. "work-around the no-mans-land bug" - "No change if model is locked" - (autoDeselect and: [ row == self visualSelectionIndex ]) - ifTrue: [ - aMouseButtonEvent mouseButton1Changed ifTrue: [ - self setSelectionIndex: 0 ]] - ifFalse: [ self setSelectionIndex: row ]! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 12/29/2017 09:38:13' prior: 50379758! - arrowKey: aChar - "Process the up and down arrows in a list pane. Note that the listView tells us what index variable, how to get the list, and how to move the index." - | keyEvent oldSelection nextSelection max min howMany answer w | - answer _ false. - keyEvent _ aChar numericValue. - oldSelection _ self getCurrentSelectionIndex. - nextSelection _ oldSelection. - max _ self maximumSelection. - min _ self minimumSelection. - howMany _ self numSelectionsInView. "get this exactly??" - - keyEvent = 31 ifTrue: [ - "down-arrow; move down one, wrapping to top if needed" - nextSelection _ oldSelection + 1. - nextSelection > max ifTrue: [ nextSelection _ 1 ]]. - - keyEvent = 30 ifTrue: [ - "up arrow; move up one, wrapping to bottom if needed" - nextSelection _ oldSelection - 1. - nextSelection < 1 ifTrue: [ nextSelection _ max ]]. - - keyEvent = 1 ifTrue: [ nextSelection _ 1 ]. "home" - keyEvent = 4 ifTrue: [ nextSelection _ max ]. "end" - keyEvent = 11 ifTrue: [ nextSelection _ min max: oldSelection - howMany ]. "page up" - keyEvent = 12 ifTrue: [ nextSelection _ oldSelection + howMany min: max ]. "page down" - nextSelection = oldSelection ifFalse: [ - w _ self owningWindow. - (w isNil or: [ w okToChange ]) ifTrue: [ "No change if model is locked" - - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self listMorph highlightedRow: nextSelection. - - "Update the model in next world cycle, so user gets the immediate feedback." - UISupervisor whenUIinSafeState: [ - self setSelectionIndex: nextSelection ]. - answer _ true ]]. - ^answer! ! -!PluggableListMorph methodsFor: 'menus' stamp: 'jmv 12/29/2017 09:50:46' prior: 16888894! - copySelectionToClipboard - "Copy my selected item to the clipboard as a string" - - self visualSelection - ifNotNil: [ :sel | - Clipboard storeObject: sel asString ] - ifNil: [ - self flash ]! ! -!PluggableListMorph methodsFor: 'model access' stamp: 'jmv 12/29/2017 09:38:18' prior: 16888950! - keyboardSearch: aChar - | oldSelection nextSelection max milliSeconds nextSelectionList nextSelectionText | - nextSelection _ oldSelection _ self getCurrentSelectionIndex. - max _ self maximumSelection. - milliSeconds _ Time localMillisecondClock. - milliSeconds - lastKeystrokeTime > 300 ifTrue: ["just use the one current character for selecting" - lastKeystrokes _ '']. - lastKeystrokes _ lastKeystrokes , aChar asLowercase asString. - lastKeystrokeTime _ milliSeconds. - nextSelectionList _ OrderedCollection newFrom: (list copyFrom: oldSelection + 1 to: max). - nextSelectionList addAll: (list copyFrom: 1 to: oldSelection). - "Get rid of blanks and style used in some lists" - nextSelectionText _ nextSelectionList detect: [:a | a asString withBlanksTrimmed asLowercase beginsWith: lastKeystrokes] - ifNone: [^ self flash"match not found"]. - self owningWindow ifNotNil: [ :w | - w okToChange ifFalse: [^ self]]. - nextSelection _ list findFirst: [:a | a == nextSelectionText]. - "No change if model is locked" - oldSelection == nextSelection ifTrue: [^ self flash]. - ^ self setSelectionIndex: nextSelection! ! -!PluggableListMorph methodsFor: 'selection' stamp: 'jmv 12/29/2017 10:05:11' prior: 16889043! - selection: item - "Public. Call to set selection. - Usually, view is updated from model updates. - If model updating fails (no model index setter defined) then just update visuals." - - self selectionIndex: (list indexOf: item)! ! -!PluggableListMorph methodsFor: 'selection' stamp: 'jmv 12/29/2017 09:32:29' prior: 16889057! -selectionIndex: anInteger - "Public. Call to set selection. - Usually, view is updated from model updates. - If model updating fails (no model index setter defined) then just update visuals." - - (self setSelectionIndex: anInteger) ifFalse: [ - self privateVisualSelectionIndex: anInteger ]! ! -!PluggableListMorph methodsFor: 'updating' stamp: 'jmv 12/29/2017 09:46:24' prior: 16889068! - update: aSymbol - "Refer to the comment in View|update:." - - super update: aSymbol. - aSymbol == getListSelector ifTrue: [ - self updateList. - ^ self]. - aSymbol == getIndexSelector ifTrue: [ - self privateVisualSelectionIndex: self getCurrentSelectionIndex ]! ! -!PluggableListMorph methodsFor: 'updating' stamp: 'jmv 12/29/2017 09:46:28' prior: 16889079! - updateList - | index | - "the list has changed -- update from the model" - self getList. - self listMorph listChanged. - self setScrollDeltas. - index _ self getCurrentSelectionIndex. - self privateVisualSelectionIndex: index! ! -!PluggableListMorphOfMany methodsFor: 'events' stamp: 'jmv 12/29/2017 09:38:30' prior: 50379812! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - - | oldIndex oldVal row w | - self hasKeyboardFocus ifFalse: [ - aMouseButtonEvent hand newKeyboardFocus: self ]. - - row _ self rowAtLocation: localEventPosition. - - row = 0 ifTrue: [ - ^super mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition ]. - - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self listMorph highlightedRow: row. - - w _ self owningWindow. - (w isNil or: [ w okToChange ]) ifTrue: [ "No change if model is locked" - - "Set meaning for subsequent dragging of selection" - dragOnOrOff _ (self listSelectionAt: row) not. - dragStartRow _ row. - oldIndex _ self getCurrentSelectionIndex. - oldIndex ~= 0 ifTrue: [oldVal _ self listSelectionAt: oldIndex]. - - "Different from PluggableListMorph. There, we highlight on mouse down, and act on mouse up. - Here, we act on mouse down, because we support dragging of selection, so mouse up will - only happen after user is finished dragging. In order to get the highlight visible for the user, - update the model on next world cycle." - UISupervisor whenUIinSafeState: [ - "Set or clear new primary selection (listIndex)" - dragOnOrOff - ifTrue: [self setSelectionIndex: row] - ifFalse: [self setSelectionIndex: 0]. - "Need to restore the old one, due to how model works, and set new one." - oldIndex ~= 0 ifTrue: [self listSelectionAt: oldIndex put: oldVal]. - self listSelectionAt: row put: dragOnOrOff ]. - ]. - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: nil - clkNHalf: nil - dblClkSel: #doubleClick:localPosition: - dblClkNHalfSel: nil - tripleClkSel: nil! ! -!PluggableListMorphOfMany methodsFor: 'events' stamp: 'jmv 12/29/2017 09:38:32' prior: 50365060! - mouseMove: aMouseMoveEvent localPosition: localEventPosition - "The mouse has moved, as characterized by the event provided. Adjust the scrollbar, and alter the selection as appropriate" - - | oldIndex oldVal row | - row _ (localEventPosition y < 0 and: [ scrollBar scrollValue > 0.0 ]) - ifTrue: [ - scrollBar scrollUp: 1. - "Leave at least one visible item unaffected, for better visual feedback to the user." - (self rowAtLocation: `0@0`) + 2 ] - ifFalse: [ - (localEventPosition y > extent y and: [ scrollBar scrollValue < 1.0 ]) - ifTrue: [ - scrollBar scrollDown: 1. - "Leave at least one visible item unaffected, for better visual feedback to the user." - (self rowAtLocation: 0@extent y) - 3 ] - ifFalse: [ self rowAtLocation: localEventPosition ]]. - row = 0 ifTrue: [ ^ self ]. - - "No change if model is locked" - self owningWindow ifNotNil: [ :w | - w okToChange ifFalse: [^ self]]. - - dragOnOrOff ifNil: [ - "Was not set at mouse down, which means the mouse must have gone down in an area where there was no list item" - dragOnOrOff _ (self listSelectionAt: row) not. - dragStartRow _ row ]. - - "Set meaning for subsequent dragging of selection" - oldIndex _ self getCurrentSelectionIndex. - oldIndex ~= 0 ifTrue: [ oldVal _ self listSelectionAt: oldIndex ]. - - "Set or clear new primary selection (listIndex)" - dragOnOrOff - ifTrue: [ self setSelectionIndex: row ] - ifFalse: [ self setSelectionIndex: 0 ]. - - "Need to restore the old one, due to how model works, and set new one." - oldIndex ~= 0 ifTrue: [ self listSelectionAt: oldIndex put: oldVal ]. - - "Select all in between if drag was too fast" - "self listSelectionAt: row put: dragOnOrOff." - (row min: dragStartRow) to: (row max: dragStartRow) do: [ :r | - self listSelectionAt: r put: dragOnOrOff ]! ! -!PluggableListMorphOfMany methodsFor: 'updating' stamp: 'jmv 12/29/2017 09:46:31' prior: 16889359! - update: aSymbol - super update: aSymbol. - aSymbol == #allSelections ifTrue: [ - self privateVisualSelectionIndex: self getCurrentSelectionIndex. - self redrawNeeded]! ! - -PluggableListMorphByItem removeSelector: #changeModelSelection:! - -PluggableListMorphByItem removeSelector: #changeModelSelection:! - -PluggableListMorph removeSelector: #changeModelSelection:! - -PluggableListMorph removeSelector: #changeModelSelection:! - -PluggableListMorph removeSelector: #getListSelector! - -PluggableListMorph removeSelector: #getListSelector! - -PluggableListMorph removeSelector: #selection! - -PluggableListMorph removeSelector: #selection! - -PluggableListMorph removeSelector: #selectionIndex! - -PluggableListMorph removeSelector: #selectionIndex! - -HierarchicalListMorph removeSelector: #getSelectionIndex! - -HierarchicalListMorph removeSelector: #getSelectionIndex! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3244-PluggableLists-protocolCleanup-JuanVuletich-2017Dec29-10h09m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3244] on 4 January 2018 at 3:38:22 pm'! -!SequenceableCollection methodsFor: 'math functions' stamp: 'jmv 1/4/2018 15:37:17'! - incrementFraction - " - #(10 12.5 15 20) incrementFraction - " - | displaced answer | - displaced _ self class new: self size. - displaced replaceFrom: 2 to: self size with: self startingAt: 1. - displaced at: 1 put: self first. - answer _ self copy. - answer -= displaced. - ^answer / displaced! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3245-IncrementFraction-JuanVuletich-2018Jan04-13h50m-jmv.1.cs.st----! - -----SNAPSHOT----#(4 January 2018 5:56:30.980531 pm) Cuis5.0-3245-v3.image priorSource: 1455015! - -----QUIT----#(4 January 2018 5:56:41.426633 pm) Cuis5.0-3245-v3.image priorSource: 1570120! - -----STARTUP----#(19 January 2018 10:34:48.803022 am) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3245-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3245] on 11 January 2018 at 11:01:17 am'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 1/11/2018 00:15:12' prior: 50379478! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag -"WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " -| activeProc | -activeProc _ Processor activeProcess. -[ - | isARealStartup guiRootObject guiRootObjectClass reopenTranscript | - self logSnapshot: save andQuit: quit. - - reopenTranscript _ false. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | each isInWorld ifTrue: [ each delete. reopenTranscript _ true ]]. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - - - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - - "Cosas que levanto explicitamente abajo" - guiRootObjectClass _ UISupervisor ui class. - guiRootObject _ UISupervisor ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "guiRootObject _ clearAllStateFlag ifFalse: [ UISupervisor ui ]." - UISupervisor stopUIProcess. - activeProc isTerminated ifFalse: [ - activeProc terminate ]. - - "Clean Globals" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: nil. - Smalltalk closeSourceFiles. Smalltalk at: #SourceFiles put: nil. - Smalltalk allClassesDo: [ :cls | cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ Smalltalk printStuffToCleanOnImageSave ]. - - - "Do image save & quit as apropriate" - Cursor write activateCursor. - save - ifTrue: [ - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - - - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: (DisplayScreen extent: `1024@768` depth: 32). - Smalltalk at: #SourceFiles put: (Array new: 2). - Smalltalk openSourceFiles. - - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - - UISupervisor spawnNewMorphicProcessFor: (guiRootObject ifNil: [ guiRootObject _ guiRootObjectClass newWorld ]). - Display triggerEvent: #screenSizeChanged. - - reopenTranscript ifTrue: [ - UISupervisor whenUIinSafeState: [ - TranscriptWindow openTranscript ]]. - " - UISupervisor whenUIinSafeState: [ - guiRootObject fullRepaintNeeded ]. - " - - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - UISupervisor whenUIinSafeState: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]. - -] forkAt: Processor timingPriority-1 named: 'Startup process'.! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3246-FixTaskbarBugOnImageSave-JuanVuletich-2018Jan11-11h00m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3246] on 12 January 2018 at 9:18:55 am'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 1/12/2018 09:16:22' prior: 50380730! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag -"WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " -| activeProc | -activeProc _ Processor activeProcess. -[ - | isARealStartup guiRootObject guiRootObjectClass reopenTranscript | - self logSnapshot: save andQuit: quit. - - reopenTranscript _ false. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | each isInWorld ifTrue: [ each delete. reopenTranscript _ true ]]. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - - - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - - "Cosas que levanto explicitamente abajo" - guiRootObjectClass _ UISupervisor ui class. - guiRootObject _ UISupervisor ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "guiRootObject _ clearAllStateFlag ifFalse: [ UISupervisor ui ]." - UISupervisor stopUIProcess. - activeProc isTerminated ifFalse: [ - activeProc terminate ]. - - "Clean Globals" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: nil. - Smalltalk closeSourceFiles. Smalltalk at: #SourceFiles put: nil. - Smalltalk allClassesDo: [ :cls | cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ Smalltalk printStuffToCleanOnImageSave ]. - - - "Do image save & quit as apropriate" - Cursor write activateCursor. - save - ifTrue: [ - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - - - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: (DisplayScreen extent: `1024@768` depth: 32). - Smalltalk at: #SourceFiles put: (Array new: 2). - Smalltalk openSourceFiles. - - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - - UISupervisor spawnNewMorphicProcessFor: (guiRootObject ifNil: [ guiRootObject _ guiRootObjectClass newWorld ]). - - Display triggerEvent: #screenSizeChanged. - - UISupervisor whenUIinSafeState: [ - "guiRootObject fullRepaintNeeded." - reopenTranscript ifTrue: [ - TranscriptWindow openTranscript ]]. - - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - UISupervisor whenUIinSafeState: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]. - -] forkAt: Processor timingPriority-1 named: 'Startup process'.! ! -!PasteUpMorph class methodsFor: 'system startup' stamp: 'jmv 1/12/2018 09:17:41' prior: 50379678! - initClassCachedState - - "Should use some other way to find relevant instances" - self flag: #jmvVer2. - self allInstancesDo: [ :each | - each buildMagnifiedBackgroundImage. - each isWorldMorph ifTrue: [ - each redrawNeeded ]]. - Cursor normal activateCursor! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3247-AvoidWindowRepositionOnImageSave-JuanVuletich-2018Jan12-09h13m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3247] on 12 January 2018 at 9:26:33 am'! -!CodeWindow methodsFor: 'menu commands' stamp: 'jmv 1/12/2018 09:24:56' prior: 16813375! - browseProtocol - "Create and schedule a new protocol browser on the currently selected class or meta." - | aPBrowser label | - model selectedClassOrMetaClass ifNotNil: [ :classOrMetaclass | - aPBrowser _ ProtocolBrowser new onSubProtocolOf: classOrMetaclass. - label _'Sub-protocol of: ', classOrMetaclass name. - ProtocolBrowserWindow open: aPBrowser label: label ]! ! -!DebuggerWindow methodsFor: 'keyboard shortcuts' stamp: 'jmv 1/12/2018 09:25:29' prior: 16831235! - browseFullProtocolIn: anInspector - "Spawn a window showing full protocol for the receiver's selection" - - ProtocolBrowserWindow - openFullProtocolForClass: anInspector selectedClassOrMetaClass! ! -!InspectorWindow methodsFor: 'menu commands' stamp: 'jmv 1/12/2018 09:23:23' prior: 16857301! - browseFullProtocol - "Spawn a window showing full protocol for the receiver's selection" - - ProtocolBrowserWindow openFullProtocolForClass: model selectedClassOrMetaClass! ! -!ObjectExplorerWindow methodsFor: 'menu commands' stamp: 'jmv 1/12/2018 09:23:27' prior: 16883379! - browseFullProtocol - "Spawn a window showing full protocol for the receiver's selection" - - ProtocolBrowserWindow openFullProtocolForClass: model selectedClass! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3248-UseProtocolBrowserWindow-JuanVuletich-2018Jan12-09h23m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3248] on 13 January 2018 at 3:55:27 pm'! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 1/13/2018 15:49:22'! - fillRects: rectangleList - "For testing. Flashes the given list of rectangles on the Display so you can watch incremental redisplay at work." - - - | blt screenRect | - blt _ (BitBlt toForm: Display) - sourceForm: nil; - sourceOrigin: `0@0`; - clipRect: self viewBox; - combinationRule: Form over. - - rectangleList do: [:r | - screenRect _ r translatedBy: self viewBox origin. - blt fillColor: Color random. - blt destRect: screenRect; copyBits. - Display forceToScreen: screenRect ]. - - (Delay forMilliseconds: 50) wait! ! -!WorldState methodsFor: 'drawing' stamp: 'jmv 1/13/2018 15:47:59' prior: 50360589! - drawInvalidAreasSubmorphs: submorphs - "Redraw the damaged areas of the given canvas and clear the damage list. Return a collection of the areas that were redrawn." - - | initialRectsToRepair currentRectsToRepair newRectsToRepair morphsToDraw rectsForEachMorph thisMorphRects reuse i n morph morphBounds morphClipRect | - - "The simple implementation is slowers as it draws morph areas that will later be covered by other morphs. - But it works, and it is easier to understand. - See en.wikipedia.org/wiki/Painter's_algorithm" - true not ifTrue: [ ^self simpleDrawInvalidAreasSubmorphs: submorphs ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - initialRectsToRepair _ damageRecorder invalidRectsFullBounds: world viewBox. - damageRecorder reset. - currentRectsToRepair _ OrderedCollection new. - newRectsToRepair _ OrderedCollection withAll: initialRectsToRepair. - morphsToDraw _ OrderedCollection new. - rectsForEachMorph _ OrderedCollection new. - thisMorphRects _ OrderedCollection new. - n _ submorphs size. - i _ 1. - - "The idea here is to iterate morphs front to back, i.e. first the ones on top. - For each morph, record the rectangles it affects. And if a morph is opaque, remove the area behind it from the list of rectangles to be repaired. - This means, for example, that morphs completely covered might even not be redrawn. - this is a huge performance gain when there are many morphs on screen, especially if there are more than ten open windows, and Theme uses opaque colors. - See 'A reverse painter's algorithm' at en.wikipedia.org/wiki/Painter's_algorithm" - [ i <= n and: [ newRectsToRepair notEmpty ]] whileTrue: [ - morph _ submorphs at: i. - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - reuse _ currentRectsToRepair. - currentRectsToRepair _ newRectsToRepair. - newRectsToRepair _ reuse removeAll. - currentRectsToRepair do: [ :r | - (morphBounds intersects: r) - ifTrue: [ - morphClipRect _ morphBounds intersect: r. - thisMorphRects add: morphClipRect. "We could perhaps try and join adjacent rectangles in this collection..." - morph addPossiblyUncoveredAreasIn: r to: newRectsToRepair ] - ifFalse: [ - newRectsToRepair add: r ]]. - thisMorphRects ifNotEmpty: [ - morphsToDraw add: morph. - rectsForEachMorph add: thisMorphRects. - thisMorphRects _ OrderedCollection new. - ]]. - i _ i + 1 ]. - - "*make this true to flash damaged areas for testing*" - Preferences debugShowDamage ifTrue: [ world fillRects: initialRectsToRepair ]. - - "Draw world background on those areas that were not completely covered by opaque morphs" - i > n ifTrue: [ - newRectsToRepair do: [ :r | - world drawOn: (canvas newClipRect: r) ]]. - - "Now, draw the recorded areas of selected morphs, back to front." - morphsToDraw with: rectsForEachMorph reverseDo: [ :m :xrects | - "Here we could think about merging all xrects into just one call... - This would mean drawing each morph just once. - But that would mean drawing pixels we were not told to. There could be other morphs in that area that are not even being drawn!! - See WorldState class >> #experiment1" - "*make this true to flash damaged areas for testing*" - Preferences debugShowDamage2 ifTrue: [ - world fillRects: xrects ]. -" rr _ nil." - xrects do: [ :r | -" rr _ rr ifNil: [ r ] ifNotNil: [ r quickMerge: rr ]." - (canvas newClipRect: r) fullDraw: m. - ]. -" (canvas newClipRect: rr) fullDraw: m" - ]. - - "Answer a list of rectangles to be updated on the Display. - This usually is not performance critical, drawing morphs is slower than just exposing the Display." - "What should we force on Display? Whatever was asked? Each small rect that was updated? A single bigger rect? - Right now, answer whatever was asked... Maybe this could be changed if that enhances performance... - (think of vnc over slow networks)" - ^ initialRectsToRepair! ! - -PasteUpMorph removeSelector: #fillRects:color:! - -PasteUpMorph removeSelector: #fillRects:color:! - -PasteUpMorph removeSelector: #flashRects:color:! - -PasteUpMorph removeSelector: #flashRects:color:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3249-MorphicInvalidationAidsEnh-JuanVuletich-2018Jan13-15h40m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3249] on 13 January 2018 at 5:18:44 pm'! -!PasteUpMorph methodsFor: 'project state' stamp: 'jmv 1/13/2018 17:03:34'! - setCanvas: aCanvas - - ^ worldState ifNotNil: [ worldState setCanvas: aCanvas ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3250-setCanvas-JuanVuletich-2018Jan13-17h18m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3250] on 14 January 2018 at 11:26:34 am'! -!WorldState methodsFor: 'stepping' stamp: 'jmv 1/14/2018 11:26:09' prior: 50340235! - runStepMethods - "Perform periodic activity inbetween event cycles" - | queue readyToProcess | - - queue _ self class deferredUIMessages. - "Processing the queue until empty is wrong if a block in it calls #addDeferredUIMessage: itself, because this loop will never end. - Instead, process no more than entries already in queue befor we start iterating!!" - readyToProcess _ queue size. - readyToProcess timesRepeat: [ - queue nextOrNil ifNotNil: [ :block | - block value - ] - ]. - self triggerAlarmsBefore: lastCycleTime. - self runLocalStepMethods: lastCycleTime. - - "we are using a normal #step for these now" - "aWorld allLowerWorldsDo: [ :each | each runLocalStepMethods ]." -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3251-DeferredMorphicProcessingFix-JuanVuletich-2018Jan14-11h18m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3251] on 14 January 2018 at 7:37:37 pm'! -!InnerTextMorph methodsFor: 'event handling' stamp: 'jmv 1/14/2018 19:19:58' prior: 16855794! - keyboardFocusChange: aBoolean - - "The message is sent to a morph when its keyboard focus changes. - The given argument indicates that the receiver is gaining (versus losing) the keyboard focus. - In this case, all we need to do is to redraw border feedback" - aBoolean - ifTrue: [ - "A hand is wanting to send us characters..." - editor ifNil: [ self editor storeSelectionInComposition ]. "Forces install" - self showsBlinkingCursor ifTrue: [ - editor hasSelection ifFalse: [ - self startBlinking ]]] - ifFalse: [ self stopBlinking ]. - "Selection might be shown differently when focused" - owner - ifNotNil: [ owner redrawNeeded ] - ifNil: [ self redrawNeeded ] "Or at least redraw us"! ! -!InnerTextMorph methodsFor: 'private' stamp: 'jmv 1/14/2018 19:14:30' prior: 16856065! - selectionChanged - - self textComposition selectionRects do: [ :r | self invalidateLocalRect: r ]. - editor hasSelection - ifTrue: [ self stopBlinking ] - ifFalse: [ self startBlinking ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3252-InnerTextMorph-avoidUnnededStepping-JuanVuletich-2018Jan14-19h37m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3251] on 14 January 2018 at 7:38:44 pm'! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 1/14/2018 19:31:36' prior: 50340754! - doOneCycle - "Do one cycle of the interaction loop. This method is called repeatedly when the world is running. - - Make for low cpu usage if the ui is inactive, but quick response when ui is in use. - However, after some inactivity, there will be a larger delay before the ui gets responsive again." - - | wait waitUntil | - waitDelay ifNil: [ waitDelay _ Delay forMilliseconds: 50 ]. - lastCycleHadAnyEvent | self class deferredUIMessages isEmpty not - ifTrue: [ - pause _ 20. "This value will only be used when there are no more events to serve." - wait _ 0 ] "Don't wait" - ifFalse: [ - pause < 200 "No events processed? Start saving CPU!! But never make the user wait more than 200ms for being responsive again." - ifTrue: [ pause _ pause * 21//20 ]. - waitUntil _ lastCycleTime + pause. - "Earlier if steps" - stepList isEmpty not ifTrue: [ - waitUntil _ waitUntil min: stepList first scheduledTime ]. - "Earlier if alarms" - alarms ifNotNil: [ - alarms isEmpty not ifTrue: [ - waitUntil _ waitUntil min: alarms first scheduledTime ]]. - - wait _ waitUntil - Time localMillisecondClock ]. - Preferences serverMode - ifTrue: [ wait _ wait max: 50 ]. "Always wait at least a bit on servers, even if this makes the UI slow." - wait > 0 - ifFalse: [ Processor yield ] - ifTrue: [ - waitDelay beingWaitedOn - ifFalse: [ waitDelay setDelay: wait; wait ] - ifTrue: [ - "If we are called from a different process than that of the main UI, we might be called in the main - interCyclePause. In such case, use a new Delay to avoid 'This Delay has already been scheduled' errors" - (Delay forMilliseconds: wait) wait ]]. - - "Record start time of this cycle, and do cycle" - lastCycleTime _ Time localMillisecondClock. - lastCycleHadAnyEvent _ self doOneCycleNow! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3253-MorphicMaxFPSifDeferredBlocks-JuanVuletich-2018Jan14-19h37m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3253] on 15 January 2018 at 4:47:07 pm'! -!DisplayScreen methodsFor: 'initialization' stamp: 'jmv 1/15/2018 15:51:20'! - initialize - self - setExtent: self class actualScreenSize - depth: (self class actualScreenDepth ifNil: [ 32 ])! ! -!CompiledMethod methodsFor: 'source code management' stamp: 'jmv 1/15/2018 16:08:16' prior: 16820423! - getPreambleFrom: aFileStream at: position - | writeStream c p | - writeStream _ String new writeStream. - p _ position. - c _ nil. - [ p >= 0 and: [ c ~~ $!! ]] whileTrue: [ - aFileStream position: p. - c _ aFileStream basicNext. - p _ p - 1 ]. - [ p >= 0] whileTrue: [ - aFileStream position: p. - c _ aFileStream basicNext. - c == $!! - ifTrue: [^ writeStream contents reverse ] - ifFalse: [ writeStream nextPut: c ]. - p _ p - 1 ]. - ^ nil! ! -!CompiledMethod methodsFor: 'time stamp' stamp: 'jmv 1/15/2018 16:08:53' prior: 16821137! - timeStamp - "Answer the authoring time-stamp for the given method, retrieved from the sources or changes file. Answer the empty string if no time stamp is available." - - "(CompiledMethod compiledMethodAt: #timeStamp) timeStamp" - - | file preamble stamp tokens tokenCount | - self fileIndex = 0 ifTrue: [^ String new]. "no source pointer for this method" - file _ SourceFiles at: self fileIndex. - file ifNil: [^ String new]. "sources file not available" - "file does not exist happens in secure mode" - file _ [file name asFileEntry readStream] on: FileDoesNotExistException do: [ :ex| nil ]. - file ifNil: [^ String new]. - preamble _ self getPreambleFrom: file at: (0 max: self filePosition). - preamble ifNil: [ ^ '' ]. - stamp _ String new. - tokens _ (preamble findString: 'methodsFor:' startingAt: 1) > 0 - ifTrue: [Scanner new scanTokens: preamble] - ifFalse: [Array new "ie cant be back ref"]. - (((tokenCount _ tokens size) between: 7 and: 8) and: [(tokens at: tokenCount - 5) = #methodsFor:]) - ifTrue: - [(tokens at: tokenCount - 3) = #stamp: - ifTrue: ["New format gives change stamp and unified prior pointer" - stamp _ tokens at: tokenCount - 2]]. - ((tokenCount between: 5 and: 6) and: [(tokens at: tokenCount - 3) = #methodsFor:]) - ifTrue: - [(tokens at: tokenCount - 1) = #stamp: - ifTrue: ["New format gives change stamp and unified prior pointer" - stamp _ tokens at: tokenCount]]. - file close. - ^ stamp! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 1/15/2018 16:45:44' prior: 50380858! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag -"WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " -| activeProc | -activeProc _ Processor activeProcess. -[ - | isARealStartup guiRootObject guiRootObjectClass reopenTranscript | - self logSnapshot: save andQuit: quit. - - reopenTranscript _ false. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | each isInWorld ifTrue: [ each delete. reopenTranscript _ true ]]. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - - - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - - "Cosas que levanto explicitamente abajo" - guiRootObjectClass _ UISupervisor ui class. - guiRootObject _ UISupervisor ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "guiRootObject _ clearAllStateFlag ifFalse: [ UISupervisor ui ]." - UISupervisor stopUIProcess. - activeProc isTerminated ifFalse: [ - activeProc terminate ]. - - "Clean Globals" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: nil. - Smalltalk closeSourceFiles. Smalltalk at: #SourceFiles put: nil. - Smalltalk allClassesDo: [ :cls | cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ Smalltalk printStuffToCleanOnImageSave ]. - - - "Do image save & quit as apropriate" - Cursor write activateCursor. - save - ifTrue: [ - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - - - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: DisplayScreen new. - Smalltalk at: #SourceFiles put: (Array new: 2). - Smalltalk openSourceFiles. - - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - - UISupervisor spawnNewMorphicProcessFor: (guiRootObject ifNil: [ guiRootObject _ guiRootObjectClass newWorld ]). - Display triggerEvent: #screenSizeChanged. - - self restoreLostChangesIfNecessary. - - UISupervisor whenUIinSafeState: [ - "guiRootObject fullRepaintNeeded." - reopenTranscript ifTrue: [ - TranscriptWindow openTranscript ]]. - - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - UISupervisor whenUIinSafeState: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]. - -] forkAt: Processor timingPriority-1 named: 'Startup process'.! ! -!SystemDictionary methodsFor: 'startup' stamp: 'jmv 1/6/2017 09:59:32' prior: 50369999! - doStartUp: isARealStartup - " - isARealStartup - true: system is coming up (VM and image just started) - false: we have just saved an image snapshot, but didn't quit. - " - - "Here, startup begins!!" - Cursor normal activateCursor. - self setGCParameters. - isARealStartup ifTrue: [ - self clearExternalObjects ]. - self readCommandLineArguments. - self processStartUpList: isARealStartup. - isARealStartup ifTrue: [ - self setPlatformPreferences. - self setStartupStamp ]! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'jmv 1/15/2018 16:17:47' prior: 50370731! - hasToRestoreChangesFrom: changesFile - - | chunk | - - changesFile position: self lastQuitLogPosition. - [ changesFile atEnd ] whileFalse: [ chunk := changesFile nextChunk ]. - - ^chunk notNil and: [(self isSnapshotQuitOrQuitNoSaveRecord: chunk) not] -! ! -!DisplayScreen class methodsFor: 'snapshots' stamp: 'jmv 1/15/2018 15:51:11' prior: 16835515! - actualScreenDepth - - ^ Display ifNotNil: [ Display depth ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3254-fixStartupFreezeWhenBrokenChanges-JuanVuletich-2018Jan15-16h43m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3254] on 19 January 2018 at 10:28:10 am'! -!Collection methodsFor: 'enumerating' stamp: 'jmv 1/19/2018 08:57:00'! - select: selectBlock thenDo: doBlock - "Equivalent to - (self select: selectBlock) do: doBlock - but avoid creating an extra collection." - - self do: [ :each | (selectBlock value: each) ifTrue: [ doBlock value ]]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3255-selectthenDo-JuanVuletich-2018Jan19-10h27m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3254] on 19 January 2018 at 10:28:40 am'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 1/19/2018 10:12:45'! - snapshot: save andQuit: quit - - self snapshot: save andQuit: quit embedded: false clearAllClassState: false! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 1/19/2018 08:53:57'! - snapshot: save andQuit: quit embedded: embeddedFlag - - self snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: false! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3256-quitProtocol-JuanVuletich-2018Jan19-10h28m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3254] on 19 January 2018 at 10:28:58 am'! -!SystemDictionary class methodsFor: 'copyright' stamp: 'jmv 1/19/2018 10:25:24' prior: 50343078! - copyright - "The Cuis Smalltalk copyright. - Parts are copyright of many contributors to Squeak and Cuis projects." - - ^ -'Portions of Cuis are: -Copyright (c) Xerox Corp. 1981, 1982. -Copyright (c) Apple Computer, Inc. 1985-1996. -Copyright (c) Contributors to Squeak and Cuis projects. 1997-2018.'! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3257-updateCopyrightNotice-JuanVuletich-2018Jan19-10h28m-jmv.1.cs.st----! - -----SNAPSHOT----#(19 January 2018 10:34:56.475259 am) Cuis5.0-3257-v3.image priorSource: 1570217! - -----QUIT----#(19 January 2018 10:35:24.515101 am) Cuis5.0-3257-v3.image priorSource: 1599859! - -----STARTUP----#(26 February 2018 3:44:01.300155 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3257-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3257] on 22 January 2018 at 5:54:08 pm'! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 1/22/2018 17:53:13' prior: 50357948! - displayOn: aForm in: aRectangle - " - Transcript displayOn: Display - " - | font count i string x y fh f canvas innerR | - aForm fill: aRectangle fillColor: Color white. - font _ AbstractFont default. - - innerR _ aRectangle insetBy: self padding. - fh _ font height. - count _ innerR height // fh. - x _ innerR left. - y _ innerR top. - f _ firstIndex-1. - firstIndex > lastIndex ifTrue: [ f _ f - self maxEntries ]. - i _ (lastIndex - count max: f) \\ self maxEntries + 1. - canvas _ aForm getCanvas. - canvas newClipRect: innerR. - [ i <= lastIndex ] whileTrue: [ - string _ entries at: i. - canvas drawString: string at: x@y font: font color: Color veryDarkGray. - y _ y + fh. - i _ i \\ self maxEntries + 1 ]. - - string _ unfinishedEntry contents. - canvas drawString: string at: x@y font: font color: Color veryDarkGray! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3258-FixTranscriptResizeOnHugeFonts-JuanVuletich-2018Jan22-17h42m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3257] on 6 February 2018 at 11:27:37 am'! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 2/6/2018 11:27:31' prior: 16902489! - parseByteArray - "Literal ByteArray or literal FloatArray" - [currentTokenFirst == $]] whileFalse: [ - currentTokenFirst isDigit | (currentTokenFirst = $-) - ifTrue: [ - "do not parse the number, can be time consuming" - self scanPast: #number] - ifFalse: [ - self failWhen: currentTokenFirst == $. . - self error]]. - self scanPast: #arrayEnd! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3259-ShoutLiteralFloatArrays-JuanVuletich-2018Feb06-11h27m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3259] on 11 February 2018 at 6:51:44 pm'! -!Color methodsFor: 'testing' stamp: 'jmv 2/11/2018 18:50:54'! - isCollection - ^ false! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3260-Color-is-not-collection-JuanVuletich-2018Feb11-18h51m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3260] on 23 February 2018 at 3:19:20 pm'! -!TextModelMorph methodsFor: 'events' stamp: 'jmv 2/23/2018 14:55:30'! - clickAndHalf: aMouseButtonEvent localPosition: localEventPosition - - self textMorph clickAndHalf: aMouseButtonEvent localPosition: localEventPosition! ! -!TextModelMorph methodsFor: 'events' stamp: 'jmv 2/23/2018 14:56:20'! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - - scroller mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition. - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: nil - clkNHalf: #clickAndHalf:localPosition: - dblClkSel: #doubleClick:localPosition: - dblClkNHalfSel: #doubleClickAndHalf:localPosition: - tripleClkSel: nil! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3261-ClickNHalf-SelectAll-OnEmptyTextArea-JuanVuletich-2018Feb23-15h18m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3260] on 23 February 2018 at 3:00:53 pm'! -!Editor methodsFor: 'typing/selecting keys' stamp: 'jmv 2/23/2018 15:00:36' prior: 16836736! - selectAll: aKeyboardEvent - "select everything, invoked by cmd-a. 1/17/96 sw" - - self selectAll. - ^ true! ! - -TextEditor removeSelector: #selectAll:! - -TextEditor removeSelector: #selectAll:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3262-SelectAll-cleanup-JuanVuletich-2018Feb23-14h56m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3262] on 23 February 2018 at 3:46:21 pm'! -!HandMorph methodsFor: 'private events' stamp: 'jmv 2/23/2018 15:43:19' prior: 16852387! - shouldControlEmulateAltFor: keyValue - "At least on Linux Windows, command key is usually ctrl, not alt." - - ^ true! ! -!Theme methodsFor: 'keyboard shortcuts' stamp: 'jmv 2/23/2018 15:42:17' prior: 50369232! - keyStroke: aKeyboardEvent morph: aMorph - - aKeyboardEvent commandAltKeyPressed | aKeyboardEvent controlKeyPressed - ifFalse: [ ^ false ]. - - aKeyboardEvent keyValue = $w numericValue ifTrue: [ - aMorph owningWindow ifNotNil: [ :w | - (w morphContainsPoint: (w internalizeFromWorld: aKeyboardEvent eventPosition)) ifTrue: [ - w delete. - ^true ] ]]. -" aKeyboardEvent keyValue = $f numericValue - ifTrue: [aMorph owningWindow ifNotNil: [ :w | w fullScreen. ^true ]]. -" - ^ false! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3263-Ctrl-means-Command-JuanVuletich-2018Feb23-15h41m-jmv.1.cs.st----! - -----SNAPSHOT----#(26 February 2018 3:44:31.144618 pm) Cuis5.0-3263-v3.image priorSource: 1599958! - -----QUIT----#(26 February 2018 3:44:41.305869 pm) Cuis5.0-3263-v3.image priorSource: 1604939! - -----STARTUP----#(9 March 2018 11:47:50.795017 am) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3263-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3263] on 1 March 2018 at 4:59:38 pm'! -!HandMorph methodsFor: 'private events' stamp: 'jmv 3/1/2018 16:59:14' prior: 50381776! - shouldControlEmulateAltFor: keyValue - "At least on Linux Windows, command key is usually ctrl, not alt. - But not for arrow keys!! ctrl-left ~~ alt-left" - ^ keyValue > 32! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3264-Fix-ctrl-ArrowKeys-JuanVuletich-2018Mar01-16h57m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3264] on 4 March 2018 at 12:09:15 pm'! -!Integer methodsFor: 'benchmarks' stamp: 'jmv 3/4/2018 12:06:08' prior: 50371688! - tinyBenchmarks - "Report the results of running the two tiny Squeak benchmarks. - ar 9/10/1999: Adjusted to run at least 1 sec to get more stable results - - - Performance of early 80's experimental Smalltalk systems. - Estimations from http://wiki.c2.com/?GreenBook and http://www.wirfs-brock.com/allen/things/smalltalk-things/tektronix-smalltalk-document-archive - - DEC PDP-11/23 5,000 bytecodes/sec (Green Book, p.128) - Apple 5MHz 68000 9,000 to 11,000 bytecodes/sec (Green Book, p.187, 1982-qtr4-magnolia-perf-graph.pdf) - VAX-11/780 C HP Smalltalk 5,000 to 25,000 bytecodes/sec (Green Book, p.235) - VAX-11/780 C Berkeley Smalltalk 12,000 to 23000 bytecodes/sec (Green Book, p.203, 1982-qtr4-magnolia-perf-graph.pdf) - DEC VAX-11/780 assembly 20,000 to 25,000 bytecodes/sec (Green Book, p.149, 1982-qtr4-magnolia-perf-graph.pdf) - Xerox Dolphin µcode 20,000 to 40,000 bytecodes/sec (Green Book, p.44, p.203, 1982-qtr4-magnolia-perf-graph.pdf) - TEK Magnolia 10MHz 68000 50,000 bytecodes/sec (1983-Magnolia-st-perf.pdf) - Xerox Dorado 14MHz µcode 400,000 to 500,000 bytecodes/sec (Green book, p.44, p.203, 1982-qtr4-magnolia-perf-graph.pdf) - - - 0 tinyBenchmarks - - 292 MHz G3 Mac: 22,727,272 bytecodes/sec; 984,169 sends/sec - 400 MHz PII/Win98: 18,028,169 bytecodes/sec; 1,081,272 sends/sec - - RasPi2 - StackVM: 37,758,112 bytecodes/sec; 2,412,667 sends/sec - RasPi2- CogSSpur: 157,441,574 bytecodes/sec; 10,946,039 sends/sec - - C.H.I.P. (*1) - StackVM: 55,315,471 bytecodes/sec; 3,348,667 sends/sec - C.H.I.P. (*1) - CogSpur: 253,716,551 bytecodes/sec; 16,853,816 sends/sec - - RasPi3B - StackSpur 44,107,512 bytecodes/sec; 2,767,863 sends/sec - RasPi3B - CogSpur 281,783,159 bytecodes/sec; 16,404,381 sends/sec - - 1.66GHz Atom N450 - Cog: 244,274,809 bytecodes/sec; 28,795,277 sends/sec - 1.66GHz Atom N450 - CogSpur: 469,724,770 bytecodes/sec; 30,754,699 sends/sec - - 1.33GHz Atom 3735G - Cog: 326,114,649 bytecodes/sec; 34,985,976 sends/sec - 1.33GHz Atom 3735G - CogSpur: 632,098,765 bytecodes/sec; 33,692,910 sends/sec - - 1.5GHz AMD A4-5000 APU - Cog: 390,243,902 bytecodes/sec; 47,507,997 sends/sec - 1.5GHz AMD A4-5000 APU - CogSpur: 675,907,590 bytecodes/sec; 40,669,724 sends/sec - 1.5GHz AMD A4-5000 APU - CogSpur64: 659,368,963 bytecodes/sec; 50,338,916 sends/sec - - 2.3GHz Tegra (*2) - StackVM: 258,847,320 bytecodes/sec; 13,014,759 sends/sec - 2.3GHz Tegra (*2) - CogSpur: 1,083,024,854 bytecodes/sec; 64,289,750 sends/sec - - 3.1GHz Core i3-2100 - Cog: 1,203,290,246 bytecodes/sec; 165,723,327 sends/sec - 3.1GHz Core i3-2100 - CogSpur: 2,042,892,768 bytecodes/sec; 127,837,794 sends/sec - - 2.70GHz Core i5-6400 -CogSpur64 3,162,934,362 bytecodes/sec; 243,321,293 sends/sec - - (*1) C.H.I.P. $9 Computer [Next Thing Co], Allwinner R8 Single-Core ARM Cortex-A8 - 1 GHz - (*2) ACER Chromebook CB5-311 - NVIDIA Tegra K1 Quad-Core ARM Cortex-A15 'r3' - 2.3 GHz - - It is interesting to note that Spur for the first time brings ARM hardware (RasPi and C.H.I.P.) into a 'Morphic is confortable and nice to use' level of performance. - " - | t1 t2 r n1 n2 | - n1 _ 1. - [ - t1 _ Time millisecondsToRun: [n1 benchmark]. - t1 < 1000] - whileTrue: [n1 _ n1 * 2]. "Note: #benchmark's runtime is about O(n)" - - n2 _ 28. - [ - t2 _ Time millisecondsToRun: [r _ n2 benchFib]. - t2 < 1000] - whileTrue: [n2 _ n2 + 1]. - "Note: #benchFib's runtime is about O(k^n), - where k is the golden number = (1 + 5 sqrt) / 2 = 1.618...." - - ^String streamContents: [ :strm | - (n1 * 500000 * 1000) // t1 withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixName; - nextPutAll: 'Bytecodes/second; ' ]. - (r * 1000) // t2 withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixName; - nextPutAll: 'Sends/second' ]]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3265-EarlySmalltalkPerformanceNumbers-JuanVuletich-2018Mar04-12h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3265] on 4 March 2018 at 12:46:18 pm'! -!Integer methodsFor: 'benchmarks' stamp: 'jmv 3/4/2018 12:44:36' prior: 50381834! - tinyBenchmarks - "Report the results of running the two tiny Squeak benchmarks. - ar 9/10/1999: Adjusted to run at least 1 sec to get more stable results - - - Performance of early 80's experimental Smalltalk systems. - Estimations from - http://wiki.c2.com/?GreenBook - http://www.wirfs-brock.com/allen/things/smalltalk-things/tektronix-smalltalk-document-archive/1982-qtr4-magnolia-perf-graph.pdf - http://www.wirfs-brock.com/allen/things/smalltalk-things/tektronix-smalltalk-document-archive/1983-Magnolia-st-perf.pdf - - DEC PDP-11/23 5,000 bytecodes/sec (Green Book, p.128) - Apple 5MHz 68000 9,000 to 11,000 bytecodes/sec (Green Book, p.187, awb) 5000 clocks/bytecode - VAX-11/780 5MHz C HP Smalltalk 5,000 to 25,000 bytecodes/sec (Green Book, p.235) 330 clocks/bytecode - VAX-11/780 5MHz C Berkeley Smalltalk 12,000 to 23000 bytecodes/sec (Green Book, p.203, awb) 300 clocks/bytecode - DEC VAX-11/780 5MHz assembly 20,000 to 25,000 bytecodes/sec (Green Book, p.149, awb) 200 clocks/bytecode - Xerox Dolphin µcode 20,000 to 40,000 bytecodes/sec (Green Book, p.44, p.203, awb) - TEK Magnolia 10MHz 68000 50,000 bytecodes/sec (awb) 200 clocks/bytecode - Xerox Dorado 14MHz µcode 400,000 to 500,000 bytecodes/sec (Green book, p.44, p.203, awb) 28 clocks/bytecode - - - 0 tinyBenchmarks - - 292 MHz G3 Mac: 22,727,272 bytecodes/sec; 984,169 sends/sec 12.8 clocks/bytecode - 400 MHz PII/Win98: 18,028,169 bytecodes/sec; 1,081,272 sends/sec 22.2 clocks/bytecode - - 900MHz RasPi2 - StackVM: 37,758,112 bytecodes/sec; 2,412,667 sends/sec 16.2 clocks/bytecode - 900MHz RasPi2- CogSSpur: 157,441,574 bytecodes/sec; 10,946,039 sends/sec 5.7 clocks/bytecode - - 1GHz C.H.I.P. (*1) - StackVM: 55,315,471 bytecodes/sec; 3,348,667 sends/sec 18.1 clocks/bytecode - 1GHz C.H.I.P. (*1) - CogSpur: 253,716,551 bytecodes/sec; 16,853,816 sends/sec 3.9 clocks/bytecode - - 1.2GHz RasPi3B - StackSpur 44,107,512 bytecodes/sec; 2,767,863 sends/sec 27.2 clocks/bytecode - 1.2GHz RasPi3B - CogSpur 281,783,159 bytecodes/sec; 16,404,381 sends/sec 6.6 clocks/bytecode - - 1.66GHz Atom N450 - Cog: 244,274,809 bytecodes/sec; 28,795,277 sends/sec 6.8 clocks/bytecode - 1.66GHz Atom N450 - CogSpur: 469,724,770 bytecodes/sec; 30,754,699 sends/sec 3.5 clocks/bytecode - - 1.33GHz Atom 3735G - Cog: 326,114,649 bytecodes/sec; 34,985,976 sends/sec 4.1 clocks/bytecode - 1.33GHz Atom 3735G - CogSpur: 632,098,765 bytecodes/sec; 33,692,910 sends/sec 2.1 clocks/bytecode - - 1.5GHz AMD A4-5000 APU - Cog: 390,243,902 bytecodes/sec; 47,507,997 sends/sec 3.8 clocks/bytecode - 1.5GHz AMD A4-5000 APU - CogSpur: 675,907,590 bytecodes/sec; 40,669,724 sends/sec 2.2 clocks/bytecode - 1.5GHz AMD A4-5000 APU - CogSpur64: 659,368,963 bytecodes/sec; 50,338,916 sends/sec 2.2 clocks/bytecode - - 2.3GHz Tegra (*2) - StackVM: 258,847,320 bytecodes/sec; 13,014,759 sends/sec 8.9 clocks/bytecode - 2.3GHz Tegra (*2) - CogSpur: 1,083,024,854 bytecodes/sec; 64,289,750 sends/sec 2.1 clocks/bytecode - - 3.1GHz Core i3-2100 - Cog: 1,203,290,246 bytecodes/sec; 165,723,327 sends/sec 2.6 clocks/bytecode - 3.1GHz Core i3-2100 - CogSpur: 2,042,892,768 bytecodes/sec; 127,837,794 sends/sec 1.5 clocks/bytecode - - 2.70GHz Core i5-6400 -CogSpur64 3,162,934,362 bytecodes/sec; 243,321,293 sends/sec 0.85 clocks/bytecode - - (*1) C.H.I.P. $9 Computer [Next Thing Co], Allwinner R8 Single-Core ARM Cortex-A8 - 1 GHz - (*2) ACER Chromebook CB5-311 - NVIDIA Tegra K1 Quad-Core ARM Cortex-A15 'r3' - 2.3 GHz - - It is interesting to note that Spur for the first time brings ARM hardware (RasPi and C.H.I.P.) into a 'Morphic is confortable and nice to use' level of performance. - " - | t1 t2 r n1 n2 | - n1 _ 1. - [ - t1 _ Time millisecondsToRun: [n1 benchmark]. - t1 < 1000] - whileTrue: [n1 _ n1 * 2]. "Note: #benchmark's runtime is about O(n)" - - n2 _ 28. - [ - t2 _ Time millisecondsToRun: [r _ n2 benchFib]. - t2 < 1000] - whileTrue: [n2 _ n2 + 1]. - "Note: #benchFib's runtime is about O(k^n), - where k is the golden number = (1 + 5 sqrt) / 2 = 1.618...." - - ^String streamContents: [ :strm | - (n1 * 500000 * 1000) // t1 withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixName; - nextPutAll: 'Bytecodes/second; ' ]. - (r * 1000) // t2 withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixName; - nextPutAll: 'Sends/second' ]]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3266-ClocksPerBytecodeEstimation-JuanVuletich-2018Mar04-12h45m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3266] on 6 March 2018 at 5:42:11 pm'! -!String methodsFor: 'converting' stamp: 'jmv 3/6/2018 17:40:38'! - asValidInstanceVariableName - | answer | - answer _ self asIdentifier: false. - (Scanner pseudoVariableNames includes: answer) - ifTrue: [ answer _ answer , 'x' ]. - ^ answer - -" -'234znak 43 ) 2' asValidInstanceVariableName -'234 xx\ Uml /ler42342380-4' asValidInstanceVariableName -"! ! -!String methodsFor: 'converting' stamp: 'jmv 3/6/2018 17:32:02'! - asValidSelector - ^ self asIdentifier: false - -" -'234znak 43 ) 2' asValidSelector -"! ! -!String methodsFor: 'converting' stamp: 'jmv 3/6/2018 17:15:13'! - uncapitalized - "Answer an object like the receiver but with first character downshifted if necesary" - "'MElViN' uncapitalized" - "#Will uncapitalized" - | answer | - self isEmpty ifTrue: [^ self]. - answer _ self isString - ifTrue: ["don't modify receiver" - self copy] - ifFalse: [self asString]. - answer at: 1 put: (answer at: 1) asLowercase. - ^ self isString - ifTrue: [answer] - ifFalse: [answer as: self class]! ! -!Scanner class methodsFor: 'testing' stamp: 'jmv 3/6/2018 17:38:01'! - isValidInstanceVariableName: aString - "Answer whether aString is a legal instance variable name." - - ^ ((self isLiteralSymbol: aString) and: [(aString includes: $:) not]) and: - [(self pseudoVariableNames includes: aString) not]! ! -!Scanner class methodsFor: 'testing' stamp: 'jmv 3/6/2018 17:36:55'! - pseudoVariableNames - "Answer a list of Smalltalk pseudo-varialbes" - ^ #('nil' 'true' 'false' 'self' 'super' 'thisContext')! ! -!Workspace methodsFor: 'variable declarations' stamp: 'jmv 3/6/2018 17:28:10' prior: 50376962! - nameForObject: object - "Answer a name suitable for a Workspace variable" - ^ (object class name, object identityHash asString) asIdentifier: false! ! -!String methodsFor: 'converting' stamp: 'jmv 3/6/2018 17:19:56' prior: 16916313! - 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 | - aString _ self select: [ :el | el isValidInIdentifiers ]. - (aString size = 0 or: [aString first isValidStartOfIdentifiers not]) - ifTrue: [aString _ 'a', aString]. - ^ shouldBeCapitalized ifTrue: [ aString capitalized ] ifFalse: [ aString uncapitalized ] - -" -'234Fred987' asIdentifier: false -'235Fred987' asIdentifier: true -'' asIdentifier: true -'()87234' asIdentifier: false -'())z>=PPve889 U >' asIdentifier: false -"! ! -!Symbol class methodsFor: 'access' stamp: 'jmv 3/6/2018 17:15:26' prior: 16918609! - 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 numericValue. - ascii < 128 ifTrue: [selectorList add: (OneCharacterSymbols at: ascii+1)] - ]. - - aString first isValidInIdentifiers 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 uncapitalized numArgs < 0]]. - -"Symbol selectorsContaining: 'scon'"! ! -!Symbol class methodsFor: 'access' stamp: 'jmv 3/6/2018 17:15:29' prior: 16918646! - selectorsMatching: aStringPattern - "Answer a list of selectors that match aStringPattern within them. Case-insensitive. - Does return symbols that begin with a capital letter." - - | selectorList | - - selectorList := OrderedCollection new. - - aStringPattern isEmpty ifTrue: [^selectorList]. - - self allSymbolTablesDo: - [:each | (aStringPattern match: each) ifTrue: [selectorList add: each]]. - - ^selectorList reject: "reject non-selectors, but keep ones that begin with an uppercase" - [:each | each numArgs < 0 and: [each asString uncapitalized numArgs < 0]] - - "Symbol selectorsMatching: 'parse:*'"! ! -!Morph methodsFor: 'menus' stamp: 'jmv 3/6/2018 16:58:49' prior: 50376737! - addCopyItemsTo: aMenu - "Add copy-like items to the halo menu" - - aMenu add: 'copy to clipboard (c)' action: #copyToClipboard:! ! - -Utilities class removeSelector: #inviolateInstanceVariableNames! - -Utilities class removeSelector: #inviolateInstanceVariableNames! - -Utilities class removeSelector: #isLegalInstVarName:! - -Utilities class removeSelector: #isLegalInstVarName:! - -Utilities class removeSelector: #wellFormedInstanceVariableNameFrom:! - -Utilities class removeSelector: #wellFormedInstanceVariableNameFrom:! - -Scanner class removeSelector: #inviolateInstanceVariableNames! - -Scanner class removeSelector: #inviolateInstanceVariableNames! - -Scanner class removeSelector: #isLegalInstVarName:! - -Scanner class removeSelector: #isLegalInstVarName:! - -Scanner class removeSelector: #wellFormedInstanceVariableNameFrom:! - -Scanner class removeSelector: #wellFormedInstanceVariableNameFrom:! - -String removeSelector: #asLegalSelector! - -String removeSelector: #asLegalSelector! - -String removeSelector: #withFirstCharacterDownshifted! - -String removeSelector: #withFirstCharacterDownshifted! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3267-Cleanup-JuanVuletich-2018Mar06-17h39m-jmv.1.cs.st----! - -----SNAPSHOT----#(9 March 2018 11:47:57.609542 am) Cuis5.0-3267-v3.image priorSource: 1605038! - -----QUIT----#(9 March 2018 11:48:17.309766 am) Cuis5.0-3267-v3.image priorSource: 1621558! - -----STARTUP----#(13 March 2018 3:20:50.719361 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3267-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3267] on 11 March 2018 at 9:05:37 am'! -!Feature methodsFor: 'testing' stamp: 'jmv 3/11/2018 09:03:09' prior: 16840526! - satisfies: featureRequirement - "Does this provided Feature satisfy the FeatureRequirement?" - - "Must match name." - ^ (name sameAs: featureRequirement name) and: [ - - "If no specific version req, we are done. Ok." - featureRequirement minVersion isNil or: [ - - "If our version is exactly the min req version, we must also satisfy minRevision" - version = featureRequirement minVersion and: [ - featureRequirement minRevision isNil or: [ revision >= featureRequirement minRevision ]]] or: [ - - "If we are past min req version, ignore minRevision, but check we are not beyond max req version" - version > featureRequirement minVersion and: [ - featureRequirement maxVersion isNil or: [ version <= featureRequirement maxVersion ]]]]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3268-CaseInsensitiveFeatureMatching-JuanVuletich-2018Mar11-09h03m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3268] on 12 March 2018 at 12:16:15 pm'! -!CodeProvider methodsFor: 'message list' stamp: 'jmv 3/11/2018 15:52:08' prior: 16812753! - sourceStringPrettifiedAndDiffed - "Answer a copy of the source code for the selected message, transformed by diffing and pretty-printing exigencies" - | class selector sourceString | - class _ self selectedClassOrMetaClass. - selector _ self selectedMessageName. - (class isNil or: [ selector isNil ]) ifTrue: [ ^ 'missing' ]. - sourceString _ class - ultimateSourceCodeAt: selector - ifAbsent: [ ^ 'error' ]. - (self showingPrettyPrint or: [ self showingAnyKindOfPrettyDiffs ]) ifTrue: [ - sourceString _ class compilerClass new - format: sourceString - in: class - notifying: nil ]. - self showingAnyKindOfDiffs ifTrue: [ - sourceString _ self diffFromPriorSourceFor: sourceString ]. - ^ sourceString! ! -!Browser methodsFor: 'message functions' stamp: 'jmv 3/12/2018 12:15:33' prior: 16792281! - defineMessageFrom: aString notifying: aRequestor - "Compile the expressions in aString. Notify aRequestor if a syntax error occurs. Install the compiled method in the selected class classified under the currently selected message category name. Answer the selector obtained if compilation succeeds, nil otherwise." - | selectedMessageName selector category oldMessageList | - selectedMessageName _ self selectedMessageName. - oldMessageList _ self messageList. - self metaClassIndicated ifTrue: [ - selector _ self selectedClassOrMetaClass parserClass selectorFrom: aString. - ((self selectedClassOrMetaClass includesSelector: selector) not - and: [Metaclass isScarySelector: selector]) - ifTrue: ["A frist-time definition overlaps the protocol of Metaclasses" - (self confirm: (selector bold, ' is used in the existing class system. -Overriding it could cause serious problems. -Is this really what you want to do?')) - ifFalse: [^nil]]]. - selector _ self selectedClassOrMetaClass - compile: aString - classified: (category _ self selectedMessageCategoryName) - notifying: aRequestor. - selector - ifNil: [^ nil]. - selector ~~ selectedMessageName - ifTrue: [ - category = ClassOrganizer nullCategory - ifTrue: [self changed: #classSelectionChanged. - self changed: #classList. - self messageCategoryListIndex: 1]. - self setClassOrganizer. "In case organization not cached" - (oldMessageList includes: selector) - ifFalse: [self changed: #messageList]. - self messageListIndex: (self messageList indexOf: selector)]. - ^ selector! ! -!Compiler methodsFor: 'public access' stamp: 'jmv 3/12/2018 09:04:09' prior: 16821855! - compile: textOrStream in: aClass classified: aCategory notifying: aRequestor ifFail: failBlock - "Answer a MethodNode for the argument, textOrStream. If the - MethodNode can not be created, notify the argument, aRequestor; if - aRequestor is nil, evaluate failBlock instead. The MethodNode is the root - of a parse tree. It can be told to generate a CompiledMethod to be - installed in the method dictionary of the argument, aClass." - - | methodNode | - self from: textOrStream - class: aClass - context: nil - notifying: aRequestor. - category _ aCategory. - methodNode _ self translate: sourceStream noPattern: false ifFail: failBlock. - methodNode encoder requestor: requestor. - ^methodNode! ! -!Compiler methodsFor: 'public access' stamp: 'jmv 3/12/2018 09:08:56' prior: 16821922! - evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock logged: doLog profiled: doProfile - "Compiles the sourceStream into a parse tree, then generates code into - a method. If aContext is not nil, the text can refer to temporaries in that - context (the Debugger uses this). If aRequestor is not nil, then it will receive - a notify:at: message before the attempt to evaluate is aborted. Finally, the - compiled method is invoked from here via withArgs:executeMethod:, hence - the system no longer creates Doit method litter on errors." - - | methodNode method value toLog itsSelection itsSelectionString | - class _ (aContext ifNil: [ receiver ] ifNotNil: [ aContext receiver ]) class. - methodNode _ self compileNoPattern: textOrStream in: class context: aContext notifying: aRequestor ifFail: [^failBlock value]. - method _ methodNode generate. - - "(jmv) Log before evaluating. This way, if the evaluation is halted by whatever reason, it is logged anyway" - doLog ifTrue: [ - toLog _ ((requestor respondsTo: #selection) - and: [ (itsSelection _ requestor selection) notNil - and: [ (itsSelectionString _ itsSelection asString) isEmptyOrNil not ]]) - ifTrue: [ itsSelectionString ] - ifFalse: [ sourceStream contents ]. - SystemChangeNotifier uniqueInstance evaluated: toLog context: aContext]. - - "Evaluate now." - doProfile - ifTrue: [ - AndreasSystemProfiler spyOn: [ - value _ receiver - withArgs: (context ifNil: [#()] ifNotNil: [{context}]) - executeMethod: method ]] - ifFalse: [ - value _ receiver - withArgs: (context ifNil: [#()] ifNotNil: [{context}]) - executeMethod: method ]. - - ^ value! ! - -Compiler removeSelector: #from:class:classified:context:notifying:! - -Compiler removeSelector: #from:class:classified:context:notifying:! - -CodeProvider removeSelector: #validateMessageSource:forSelector:inClass:! - -CodeProvider removeSelector: #validateMessageSource:forSelector:inClass:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3269-CompilationCleanup-JuanVuletich-2018Mar12-12h04m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3269] on 12 March 2018 at 3:44:27 pm'! - -Object subclass: #Scanner - instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable isForTokenization sentInLiterals ' - classVariableNames: 'TypeTable ' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #Scanner category: #'Compiler-Kernel'! -Object subclass: #Scanner - instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable isForTokenization sentInLiterals' - classVariableNames: 'TypeTable' - poolDictionaries: '' - category: 'Compiler-Kernel'! -!Scanner methodsFor: 'multi-character scans' stamp: 'jmv 3/12/2018 15:37:29' prior: 50334867! - xBacktick - "Smalltalk code evaluated at compile time as a literal." - - self step. - buffer reset. - [hereChar == $` - and: [aheadChar == $` - ifTrue: [self step. false] - ifFalse: [true]]] - whileFalse: [ - buffer nextPut: self step. - (hereChar = Scanner doItCharacterValue asCharacter and: [source atEnd]) - ifTrue: [^self offEnd: 'Unmatched back quote']]. - self step. - [ | compiler method methodNode | - compiler _ Compiler new. - methodNode _ compiler compileNoPattern: buffer contents in: UndefinedObject context: nil notifying: nil ifFail: []. - method _ methodNode generate. - "Grab all messages sent while evaluating literal, so the main method will be shown as senders of them" - sentInLiterals addAll: method messages. - "Evaluate now." - token _ nil withArgs: #() executeMethod: method. - ] - on: SyntaxErrorNotification, UndeclaredVariableReference, Error - do: [ :ex | - ex class caseOf: { - [ SyntaxErrorNotification ] -> [ - self notify: 'Can not compile: ', ex errorMessage at: mark]. - [ UndeclaredVariableReference ] -> [ - self notify: 'Can not compile: Variable ''', ex varName, ''' is not declared' at: mark ] - } otherwise: [ - self notify: 'Can not evaluate code: ', ex description at: mark ]]. - tokenType _ #literal! ! -!Scanner methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:05:15' prior: 16904195! - initScanner - - buffer := WriteStream on: (String new: 40). - typeTable := Scanner typeTable. - isForTokenization := false. - sentInLiterals := Set new! ! -!Parser methodsFor: 'public access' stamp: 'jmv 3/12/2018 15:39:43' prior: 16886804! - parse: sourceStream class: class category: aCategory noPattern: noPattern context: ctxt notifying: req ifFail: aBlock - "Answer a MethodNode for the argument, sourceStream, that is the root of - a parse tree. Parsing is done with respect to the argument, class, to find - instance, class, and pool variables; and with respect to the argument, - ctxt, to find temporary variables. Errors in parsing are reported to the - argument, req, if not nil; otherwise aBlock is evaluated. The argument - noPattern is a Boolean that is true if the the sourceStream does not - contain a method header (i.e., for DoIts)." - | methNode repeatNeeded myStream s p | - category _ aCategory. - myStream _ sourceStream. - [ - repeatNeeded _ false. - p _ myStream position. - s _ myStream upToEnd. - myStream position: p. - self encoder init: class context: ctxt notifying: self. - self init: myStream notifying: req failBlock: [ - ^ aBlock value ]. - doitFlag _ noPattern. - failBlock _ aBlock. - [ methNode _ self method: noPattern context: ctxt ] - on: ReparseAfterSourceEditing - do: [ :ex | - repeatNeeded _ true. - myStream _ sourceStreamGetter notNil "Cuis specific. Do not remove!!" - ifTrue: [ requestor perform: sourceStreamGetter ] - ifFalse: [ ReadStream on: requestor text string ]]. - repeatNeeded - ] whileTrue: [ - encoder _ self encoder class new ]. - methNode sourceText: s. - "See #xBacktick" - sentInLiterals do: [ :sym | encoder noteOptimizedSelector: sym ]. - ^ methNode! ! - -Parser removeSelector: #method:context:encoder:! - -Parser removeSelector: #method:context:encoder:! - -Object subclass: #Scanner - instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable isForTokenization sentInLiterals' - classVariableNames: 'TypeTable' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #Scanner category: #'Compiler-Kernel'! -Object subclass: #Scanner - instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable isForTokenization sentInLiterals' - classVariableNames: 'TypeTable' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3270-FixSendersInsideBackticks-JuanVuletich-2018Mar12-15h43m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3269] on 12 March 2018 at 3:58:27 pm'! -!Object methodsFor: 'private' stamp: 'jmv 3/12/2018 15:54:19' prior: 50361280! - primitiveError: aString - "This method is called when the error handling results in a recursion in - calling on error: or halt or halt:." - - | context emergencyEvaluator lines r | - r _ `10@10` extent: (Display extent -20 min: `700@1000`). - lines _ r height // AbstractFont default height. - emergencyEvaluator _ Transcripter newInFrame: r. - emergencyEvaluator - nextPutAll: '***System error handling failed***'; newLine; - nextPutAll: aString; newLine; - nextPutAll: '-------------------------------'; newLine. - context _ thisContext sender sender. - (30 min: lines - 10) timesRepeat: [context ifNotNil: [emergencyEvaluator print: (context _ context sender); newLine]]. - emergencyEvaluator - nextPutAll: '-------------------------------'; newLine; - nextPutAll: 'Type ''revert'' to revert your last method change.'; newLine; - nextPutAll: 'Type ''exit'' to exit the emergency evaluator.'; newLine. - emergencyEvaluator readEvalPrint! ! -!Character methodsFor: 'converting' stamp: 'jmv 3/12/2018 15:47:49' prior: 16800645! - withDiacriticalMark: anUnicodeCodePoint - "Answer the character resulting from adding a diacritical mark (accent) to a letter. - If the result is unsupported in ISO 8859-15, answer the receiver. - Supported diacritical marks are: - U+0300 COMBINING GRAVE ACCENT - U+0301 COMBINING ACUTE ACCENT - U+0302 COMBINING CIRCUMFLEX ACCENT - U+0303 COMBINING TILDE - U+0308 COMBINING DIAERESIS - U+030A COMBINING RING ABOVE - U+030C COMBINING CARON - $a withDiacriticalMark: 16r301 - $N withDiacriticalMark: $~ - $Z withDiacriticalMark: $v - - invalid: - $9 withDiacriticalMark:$v - $A withDiacriticalMark: $v - $Á withDiacriticalMark: $v - $A withDiacriticalMark: 1244 - " - | answer i | - i _ ((anUnicodeCodePoint isNumber - ifTrue: [#(16r300 16r301 16r302 16r303 16r308 16r30A 16r30C)] - ifFalse: [#($` $' $^ $~ $" $° $v)]) indexOf: anUnicodeCodePoint - ) + 1. - answer _ (Character accentedLetters detect: [ :group | group first = self ] ifNone: [ ^self ]) at: i. - ^answer = $- ifFalse: [answer] ifTrue: [self]! ! -!InputSensor methodsFor: 'private' stamp: 'jmv 3/12/2018 15:52:20' prior: 50361312! - primMousePt - "Primitive. Poll the mouse to find out its position. Return a Point. Fail if - event-driven tracking is used instead of polling. Optional. See Object - documentation whatIsAPrimitive." - - - ^ `0@0`! ! -!EventSensor methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:48:41' prior: 50361322! - initialize - "Run the I/O process" - mouseButtons _ 0. - mousePosition _ `0@0`. - self setInterruptKey: (interruptKey ifNil: [$. numericValue bitOr: 16r0800 ]). "cmd-." - interruptSemaphore _ (Smalltalk specialObjectsArray at: 31) ifNil: [Semaphore new]. - self flushAllButDandDEvents. - inputSemaphore _ Semaphore new. - hasInputSemaphore _ false. - - self primSetInputSemaphore: (Smalltalk registerExternalObject: inputSemaphore). - self installInterruptWatcher. - self installEventTickler. - self flushAllButDandDEvents. - - "Attempt to discover whether the input semaphore is actually being signaled." - hasInputSemaphore _ false. - inputSemaphore initSignals! ! -!String methodsFor: 'displaying' stamp: 'jmv 3/12/2018 15:56:28' prior: 50361345! - displayOn: aDisplayMedium - "Display the receiver on the given DisplayMedium. 5/16/96 sw" - - self displayOn: aDisplayMedium at: `0 @ 0`! ! -!Bitmap methodsFor: 'as yet unclassified' stamp: 'jmv 3/12/2018 15:47:42' prior: 50361353! - asByteArray - "Faster way to make a byte array from me. - copyFromByteArray:, if receiver is BigEndian makes equal Bitmap. - Assume receiver bytes-in-word mapping is BigEndian: - Most significant bye of first word in self goes to first position in result. - This means that for a BigEndian 8bpp Form, pixels are in the right order in the ByteArray - - Form lena asGrayForm bits asByteArray copyFrom: 1 to: 4. - (Form lena asGrayForm asFormOfDepth: 8) bits asByteArray copyFrom: 1 to: 4. - (0 to: 3) collect: [ :x | ((Form lena asGrayForm colorAt: x@0) luminance * 255) rounded ]. - " - | f bytes hack | - f _ Form extent: 4@self size depth: 8 bits: self. - bytes _ ByteArray new: self size * 4. - hack _ Form new hackBits: bytes. - Smalltalk isLittleEndian ifTrue: [hack swapEndianness]. - hack copyBits: f boundingBox - from: f - at: `0@0` - clippingBox: hack boundingBox - rule: Form over. - - "f displayOn: hack." - ^ bytes! ! -!Transcripter methodsFor: 'accessing' stamp: 'jmv 3/12/2018 15:57:40' prior: 50361500! - 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]. - textComposition - setModel: (TextModel withText: c asText); - extentForComposing: frame width-8 @9999. - textComposition composeAll. - d _ textComposition usedHeight - frame height. - d > 0 ifTrue: [ - "Scroll up to keep all contents visible" - cb _ textComposition characterBlockAtPoint: - `0@0` + (0@(d+AbstractFont default height)). - self on: (c copyFrom: cb stringIndex to: c size). - readLimit _ position _ collection size. - ^ self endEntry]. - Display fill: (frame insetBy: -2) fillColor: self black; - fill: frame fillColor: self white. - Display getCanvas - textComposition: textComposition - bounds: (`4@4` + frame topLeft extent: Display extent) - color: Color black - selectionColor: Color blue. - DisplayScreen screenUpdateRequired: nil! ! -!Transcripter class methodsFor: 'utilities' stamp: 'jmv 3/12/2018 15:57:42' prior: 50361535! - emergencyEvaluator - (Transcripter newInFrame: `0@0 corner: 320@200`) - show: 'Type ''exit'' to exit the emergency evaluator.'; - readEvalPrint! ! -!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'jmv 3/12/2018 15:55:35' prior: 50361544! - defaultAction - - | delta textFrame barFrame outerFrame result range width filledWidth f h textWidth textForm innerBarFrame oldFilledWidth oldFilledWidth2 prevContents | - f _ AbstractFont default. - h _ f height * 3//2. - textWidth _ (f widthOfString: progressTitle) + h. - width _ 150 max: textWidth. - - textForm _ Form extent: width@h depth: 32. - textForm fillBlack. - textForm fillWhite: (textForm boundingBox insetBy: 2). - progressTitle displayOn: textForm at: (width-textWidth+h//2@4). - barFrame _ Rectangle center: aPoint extent: width@h. - textFrame _ `0@0` extent: width@h. - textFrame _ textFrame - aligned: textFrame bottomCenter - with: barFrame topCenter + `0@2`. - outerFrame _ barFrame merge: textFrame. - delta _ outerFrame amountToTranslateWithin: Display boundingBox. - barFrame _ barFrame translatedBy: delta. - textFrame _ textFrame translatedBy: delta. - outerFrame _ outerFrame translatedBy: delta. - prevContents _ Form fromDisplay: outerFrame. - range _ maxVal = minVal ifTrue: [1] ifFalse: [maxVal - minVal]. "Avoid div by 0" - innerBarFrame _ barFrame insetBy: 2. - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - oldFilledWidth _ 0. - oldFilledWidth2 _ 0. - result _ workBlock value: "Supply the bar-update block for evaluation in the work block" - [ :barVal | - barVal - ifNotNil: [ currentVal _ barVal ] - ifNil: [ - currentVal _ currentVal + 1. - currentVal >= maxVal - ifTrue: [ currentVal _ minVal ]]. - filledWidth _ ((barFrame width-4) asFloat * ((currentVal-minVal) asFloat / range min: 1.0)) asInteger. - filledWidth > oldFilledWidth ifTrue: [ - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - Display fillGray: (barFrame topLeft + `2@2` extent: filledWidth@17). - filledWidth -200 > oldFilledWidth2 - ifFalse: [ - "Usually just request an update, to be done asynchronously." - DisplayScreen screenUpdateRequired: outerFrame ] - ifTrue: [ - "Once in a while, force a real screen update (warning: really slow on MacOS if done too often)" - Display forceToScreen: outerFrame. oldFilledWidth2 _ filledWidth ]. - oldFilledWidth _ filledWidth ]]. - prevContents displayAt: outerFrame topLeft. - self resume: result! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'jmv 3/12/2018 15:56:15' prior: 50382562! - xBacktick - "Smalltalk code evaluated at compile time as a literal." - - self step. - buffer reset. - [hereChar == $` - and: [aheadChar == $` - ifTrue: [self step. false] - ifFalse: [true]]] - whileFalse: [ - buffer nextPut: self step. - (hereChar = Scanner doItCharacterValue asCharacter and: [source atEnd]) - ifTrue: [^self offEnd: 'Unmatched back quote']]. - self step. - [ | compiler method methodNode | - compiler _ Compiler new. - methodNode _ compiler compileNoPattern: buffer contents in: UndefinedObject context: nil notifying: nil ifFail: []. - method _ methodNode generate. - "Grab all messages sent while evaluating literal, so the main method will be shown as senders of them" - sentInLiterals addAll: method messages. - "Evaluate now." - token _ nil withArgs: #() executeMethod: method. - ] - on: SyntaxErrorNotification, UndeclaredVariableReference, Error - do: [ :ex | - ex class caseOf: { - [ SyntaxErrorNotification ] -> [ - self notify: 'Can not compile: ', ex errorMessage at: mark]. - [ UndeclaredVariableReference ] -> [ - self notify: 'Can not compile: Variable ''', ex varName, ''' is not declared' at: mark ] - } otherwise: [ - self notify: 'Can not evaluate code: ', ex description at: mark ]]. - tokenType _ #literal! ! -!Scanner class methodsFor: 'cached class state' stamp: 'jmv 3/12/2018 15:56:19' prior: 50334741! - initTypeTable - | newTable | - newTable := Array new: 256 withAll: #xIllegal. "default" - newTable atAll: #(9 10 12 13 32 ) put: #xDelimiter. "tab lf ff cr space" - - 1 to: 255 - do: [:index | - (Character numericValue: index) isValidInIdentifiers - ifTrue: [ - "Digits and $_ are overwritten later" - newTable at: index put: #xLetter ]]. - - newTable atAll: ($0 numericValue to: $9 numericValue) put: #xDigit. - newTable atAll: '!!%&+-*/\±×÷¬­¯,<=>”•–—˜™š›œ«»?@~€‚ƒŽ‘’“žŸ°·' asByteArray put: #xBinary. - - newTable at: Scanner doItCharacterValue put: #doIt. - newTable at: $" numericValue put: #xDoubleQuote. - newTable at: $# numericValue put: #xLitQuote. - newTable at: $$ numericValue put: #xDollar. - newTable at: $' numericValue put: #xSingleQuote. - newTable at: $` numericValue put: #xBacktick. - newTable at: $: numericValue put: #xColon. - newTable at: $( numericValue put: #leftParenthesis. - newTable at: $) numericValue put: #rightParenthesis. - newTable at: $. numericValue put: #period. - newTable at: $; numericValue put: #semicolon. - newTable at: $[ numericValue put: #leftBracket. - newTable at: $] numericValue put: #rightBracket. - newTable at: ${ numericValue put: #leftBrace. - newTable at: $} numericValue put: #rightBrace. - newTable at: $^ numericValue put: #upArrow. - newTable at: $_ numericValue put: #xUnderscore. - newTable at: $| numericValue put: #verticalBar. - TypeTable := newTable "bon voyage!!" - - " - Scanner initTypeTable - "! ! -!LiteralNode methodsFor: 'printing' stamp: 'jmv 3/12/2018 15:52:43' prior: 50370919! - printOn: aStream indent: level - key isVariableBinding - ifTrue: [ - key key isNil - ifTrue: [ - aStream - nextPutAll: '###'; - nextPutAll: key value soleInstance name ] - ifFalse: [ - aStream - nextPutAll: '##'; - nextPutAll: key key ]] - ifFalse: [ - key isLiteral - ifTrue: [ | isComplex | - isComplex := false. - key isArray ifTrue: [ - isComplex := key anySatisfy: [ :ea | - ea isArray ]]. - "Is it complex? (i.e. array of arrays)" - isComplex - ifTrue: [ - aStream - nextPut: $#; - nextPut: $(. - key do: [ :ea | - aStream newLineTab: (1 max: level + 1). - ea storeOn: aStream ]. - aStream newLineTab: (1 max: level). - aStream nextPut: $) ] - ifFalse: [ key storeOn: aStream ]] - ifFalse: [ - "Need to generate code for stuff that is in a CompiledMethod literal - but is not understood as a literal by the Compiler. - Well, then it is because it was generated using backticks!!" - aStream nextPut: $`. - key storeOn: aStream. - aStream nextPut: $` ]]! ! -!TextEditor methodsFor: 'editing keys' stamp: 'jmv 3/12/2018 15:57:29' prior: 50334912! - enclose: aKeyboardEvent - "Insert or remove bracket characters around the current selection." - "This is a user command, and generates undo" - - | left right startIndex stopIndex oldSelection which | - startIndex _ self startIndex. - stopIndex _ self stopIndex. - oldSelection _ self selection. - which _ '([<{"''`' indexOf: aKeyboardEvent keyCharacter ifAbsent: [ ^true ]. - left _ '([<{"''`' at: which. - right _ ')]>}"''`' at: which. - ((startIndex > 1 and: [stopIndex <= model textSize]) - and: [ (model actualContents at: startIndex-1) = left and: [(model actualContents at: stopIndex) = right]]) - ifTrue: [ - "already enclosed; strip off brackets" - self selectFrom: startIndex-1 to: stopIndex. - self replaceSelectionWith: oldSelection] - ifFalse: [ - "not enclosed; enclose by matching brackets" - self replaceSelectionWith: - (Text string: (String with: left) attributes: emphasisHere), - oldSelection, - (Text string: (String with: right) attributes: emphasisHere). - self selectFrom: startIndex+1 to: stopIndex]. - ^ true! ! -!TextEditor class methodsFor: 'keyboard shortcut tables' stamp: 'jmv 3/12/2018 15:57:33' prior: 50334948! - basicCmdShortcutsSpec - " - Editor initialize - " - - "arranged in QWERTY keyboard order" - ^#( - #( $( #enclose: 'Enclose within ( and ), or remove enclosing ( and )') - #( $[ #enclose: 'Enclose within [ and ], or remove enclosing [ and ]') - #( ${ #enclose: 'Enclose within { and }, or remove enclosing { and }') - #( $' #enclose: 'Enclose within single quotes, or remove enclosing single quotes') - #( $" #enclose: 'Enclose within double quotes, or remove enclosing double quotes') - #( $` #enclose: 'Enclose within backticks, or remove enclosing backticks') - #( $< #enclose: 'Enclose within < and >, or remove enclosing < and >') - - #( $a #selectAll: 'Select all') - #( $f #find: 'Find') - #( $g #findAgain: 'Find again') - #( $h #help: 'Open this help') - #( $j #setSearchString: 'Set selection as search string for find again') - - #( $z #undo: 'Undo (multiple levels)') - #( $x #cut: 'Cut selection and store it in the Clipboard') - #( $c #copySelection: 'Copy selection to the Clipboard') - #( $v #paste: 'Paste Clipboard contents') - - #( $R #indent: 'Indent (move selection one tab-stap right)') - #( $Y #makeUppercase: 'Force selection to uppercase') - #( $U #changeLineEndsToLf: 'Convert line endings to LF characters (Cuis convention) in selection') - - #( $H #cursorTopHome: 'Move cursor to start of text') - #( $L #outdent: 'Outdent (move selection one tab-stop left)') - - #( $Z #redo: 'Redo (multiple levels)') - #( $X #makeLowercase: 'Force selection to lowercase') - #( $C #compareToClipboard: 'Compare argument to clipboard') - - #( $ #selectWord: 'Select the current word as with double clicking') - )! ! -!SmalltalkEditor methodsFor: 'new selection' stamp: 'jmv 3/12/2018 15:56:25' prior: 50335006! - selectWord - "Select delimited text or word--the result of double-clicking." - - | leftDelimiters rightDelimiters | - "Warning. Once me (jmv) added Character crCharacter to the delimiters, to make double-click at and of line select whole line. - This had the bad effect that if a class name is the last word of a line, double-click would correctly select it, but after that, - doing ctrl-b to browse it would select the whole line..." - leftDelimiters _ '([{<|''"`'. - rightDelimiters _ ')]}>|''"`'. - ^self selectWordLeftDelimiters: leftDelimiters rightDelimiters: rightDelimiters! ! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 3/12/2018 15:55:41' prior: 50361619! - staggerOffset - ^`6 @ 20`! ! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 3/12/2018 15:55:48' prior: 50361624! - standardWindowExtent - "Answer the standard default extent for new windows. " - - | effectiveExtent width strips height grid allowedArea maxLevel | - effectiveExtent _ self maximumUsableArea extent - - (self scrollBarSetback @ self screenTopSetback). - Preferences reverseWindowStagger ifTrue: - ["NOTE: following copied from strictlyStaggeredInitialFrameFor:" - allowedArea _ self maximumUsableArea insetBy: ( - self scrollBarSetback @ self screenTopSetback extent: `0@0` - ). - "Number to be staggered at each corner (less on small screens)" - maxLevel _ allowedArea area > 700000 ifTrue: [3] ifFalse: [2]. - "Amount by which to stagger (less on small screens)" - grid _ allowedArea area > 700000 ifTrue: [40] ifFalse: [20]. - ^ (allowedArea extent - (grid*(maxLevel+1*2) + (grid//2))) min: `52@40` * Preferences standardCodeFont height ]. - width _ (strips _ self windowColumnsDesired) > 1 - ifTrue: - [effectiveExtent x // strips] - ifFalse: - [(3 * effectiveExtent x) // 4]. - height _ (strips _ self windowRowsDesired) > 1 - ifTrue: - [effectiveExtent y // strips] - ifFalse: - [(3 * effectiveExtent y) //4]. - ^ width @ height - -" -RealEstateAgent standardWindowExtent -"! ! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 3/12/2018 15:55:52' prior: 50361665! - strictlyStaggeredInitialFrameFor: aStandardSystemView initialExtent: initialExtent world: aWorld - "This method implements a staggered window placement policy that I (di) like. - Basically it provides for up to 4 windows, staggered from each of the 4 corners. - The windows are staggered so that there will always be a corner visible." - - | allowedArea grid initialFrame otherFrames cornerSel corner delta putativeCorner free maxLevel | - allowedArea := (self maximumUsableAreaInWorld: aWorld) - insetBy: (self scrollBarSetback @ self screenTopSetback extent: `0 @ 0`). - "Number to be staggered at each corner (less on small screens)" - maxLevel := allowedArea area > 300000 ifTrue: [3] ifFalse: [2]. - "Amount by which to stagger (less on small screens)" - grid := allowedArea area > 500000 ifTrue: [40] ifFalse: [20]. - initialFrame := `0 @ 0` extent: initialExtent. - "min: (allowedArea extent - (grid*(maxLevel+1*2) + (grid//2)))) - min: 600@400" - otherFrames := (SystemWindow windowsIn: aWorld satisfying: [ :w | w visible and: [w isCollapsed not]]) - collect: [:w | w morphBoundsInWorld]. - otherFrames _ otherFrames reject: [ :f | f isNil ]. - 0 to: maxLevel do: [ :level | - 1 to: 4 do: [:ci | - cornerSel := #(#topLeft #topRight #bottomRight #bottomLeft) at: ci. - corner := allowedArea perform: cornerSel. - "The extra grid//2 in delta helps to keep title tabs distinct" - delta := ((maxLevel - level) * grid + (grid // 2)) @ (level * grid). - 1 to: ci - 1 do: [ :i | delta _ delta y negated @ delta x ]. "slow way" - putativeCorner := corner + delta. - free := true. - otherFrames do: [ :w | - free := free & ((w perform: cornerSel) ~= putativeCorner)]. - free - ifTrue: [ - ^(initialFrame aligned: (initialFrame perform: cornerSel) - with: putativeCorner) translatedAndSquishedToBeWithin: allowedArea]]]. - "If all else fails..." - ^(self scrollBarSetback @ self screenTopSetback - extent: initialFrame extent) translatedAndSquishedToBeWithin: allowedArea! ! -!Form methodsFor: 'accessing' stamp: 'jmv 3/12/2018 15:50:15' prior: 50361731! - offset - ^offset ifNil: [`0@0`]! ! -!Form methodsFor: 'analyzing' stamp: 'jmv 3/12/2018 15:50:32' prior: 50361735! - primCountBits - "Count the non-zero pixels of this form." - self depth > 8 ifTrue: [ - ^(self asFormOfDepth: 8) primCountBits]. - ^ (BitBlt toForm: self) - fillColor: (Bitmap with: 0); - destRect: (`0@0` extent: width@height); - combinationRule: 32; - copyBits! ! -!Form methodsFor: 'analyzing' stamp: 'jmv 3/12/2018 15:50:49' prior: 50361746! - tallyPixelValuesInRect: destRect into: valueTable - "Tally the selected pixels of this Form into valueTable, a Bitmap of depth 2^depth similar to a color map. Answer valueTable." - - (BitBlt toForm: self) - sourceForm: self; "src must be given for color map ops" - sourceOrigin: `0@0`; - colorMap: valueTable; - combinationRule: 33; - destRect: destRect; - copyBits. - ^ valueTable - -" -Move a little rectangle around the screen and print its tallies... - | r tallies nonZero | -Cursor blank showWhile: [ -[Sensor isAnyButtonPressed] whileFalse: - [r _ Sensor mousePoint extent: 10@10. - Display border: (r expandBy: 2) width: 2 rule: Form reverse fillColor: nil. - tallies _ (Display copy: r) tallyPixelValues. - nonZero _ (1 to: tallies size) select: [:i | (tallies at: i) > 0] - thenCollect: [:i | (tallies at: i) -> (i-1)]. - Display fill: (0@0 extent: Display width@20) fillColor: Color white. - nonZero printString , ' ' displayAt: 0@0. - Display border: (r expandBy: 2) width: 2 rule: Form reverse fillColor: nil]] -"! ! -!Form methodsFor: 'analyzing' stamp: 'jmv 3/12/2018 15:50:58' prior: 50361781! - xTallyPixelValue: pv orNot: not - "Return an array of the number of pixels with value pv by x-value. - Note that if not is true, then this will tally those different from pv." - | cm slice countBlt copyBlt | - cm _ self newColorMap. "Map all colors but pv to zero" - not ifTrue: [cm atAllPut: 1]. "... or all but pv to one" - cm at: pv+1 put: 1 - (cm at: pv+1). - slice _ Form extent: 1@height. - copyBlt _ (BitBlt destForm: slice sourceForm: self - combinationRule: Form over - destOrigin: `0@0` sourceOrigin: `0@0` extent: 1 @ slice height - clipRect: slice boundingBox) - colorMap: cm. - countBlt _ (BitBlt toForm: slice) - fillColor: (Bitmap with: 0); - destRect: (`0@0` extent: slice extent); - combinationRule: 32. - ^ (0 to: width-1) collect: [ :x | - copyBlt sourceOrigin: x@0; copyBits. - countBlt copyBits]! ! -!Form methodsFor: 'analyzing' stamp: 'jmv 3/12/2018 15:51:05' prior: 50361810! - yTallyPixelValue: pv orNot: not - "Return an array of the number of pixels with value pv by y-value. - Note that if not is true, then this will tally those different from pv." - | cm slice copyBlt countBlt | - cm _ self newColorMap. "Map all colors but pv to zero" - not ifTrue: [cm atAllPut: 1]. "... or all but pv to one" - cm at: pv+1 put: 1 - (cm at: pv+1). - slice _ Form extent: width@1. - copyBlt _ (BitBlt destForm: slice sourceForm: self - combinationRule: Form over - destOrigin: `0@0` sourceOrigin: `0@0` extent: slice width @ 1 - clipRect: slice boundingBox) - colorMap: cm. - countBlt _ (BitBlt toForm: slice) - fillColor: (Bitmap with: 0); - destRect: (`0@0` extent: slice extent); - combinationRule: 32. - ^ (0 to: height-1) collect: [ :y | - copyBlt sourceOrigin: 0@y; copyBits. - countBlt copyBits]! ! -!Form methodsFor: 'coloring' stamp: 'jmv 3/12/2018 15:49:54' prior: 50361839! - fillShape: aShapeForm fillColor: aColor - "Fill a region corresponding to 1 bits in aShapeForm with aColor" - - ^ self fillShape: aShapeForm fillColor: aColor at: `0@0`! ! -!Form methodsFor: 'coloring' stamp: 'jmv 3/12/2018 15:49:58' prior: 50361847! - fillShape: aShapeForm fillColor: aColor at: location - "Fill a region corresponding to 1 bits in aShapeForm with aColor" - - ((BitBlt destForm: self sourceForm: aShapeForm fillColor: aColor - combinationRule: Form paint - destOrigin: location + aShapeForm offset sourceOrigin: `0@0` - extent: self extent clipRect: self boundingBox) - colorMap: (Bitmap with: 0 with: 16rFFFFFFFF)) - copyBits! ! -!Form methodsFor: 'color mapping' stamp: 'jmv 3/12/2018 15:50:08' prior: 50361862! - mapColor: oldColor to: newColor - "Make all pixels of the given color in this Form to the given new color." - "Warnings: This method modifies the receiver. It may lose some color accuracy on 32-bit Forms, since the transformation uses a color map with only 15-bit resolution." - - | map | - map _ (Color cachedColormapFrom: self depth to: self depth) copy. - map at: (oldColor indexInMap: map) put: (newColor pixelWordForDepth: self depth). - (BitBlt toForm: self) - sourceForm: self; - sourceOrigin: `0@0`; - combinationRule: Form over; - destX: 0 destY: 0 width: width height: height; - colorMap: map; - copyBits! ! -!Form methodsFor: 'converting' stamp: 'jmv 3/12/2018 15:49:08' prior: 50361884! - asFormOfDepth: d - | newForm source | - d = depth ifTrue: [ ^self ]. - source _ (self depth = 32 and: [ d abs < 32 ]) - ifTrue: [ self copy convertAlphaToZeroValueTransparency ] - ifFalse: [ self ]. - newForm _ Form extent: source extent depth: d. - (BitBlt toForm: newForm) - colorMap: (source colormapIfNeededFor: newForm); - copy: source boundingBox - from: `0@0` in: source - fillColor: nil rule: Form over. - "If we build a 32bpp from one of smaller depth, - it will have zero in the alpha channel (until BitBlt is fixed!!)" - (newForm depth = 32 and: [self depth < 32]) ifTrue: [ - newForm fixAlpha ]. - ^ newForm! ! -!Form methodsFor: 'converting' stamp: 'jmv 3/12/2018 15:49:11' prior: 50361906! - asGrayForm - | answer map | - - "For lower bit depths, the 15 bit ColorMap loses no information, - and answers the real #luminance of each pixel." - self depth < 32 ifTrue: [ - answer _ GrayForm extent: width@height. - map _ self colormapIfNeededForGray8bpp. - (BitBlt toForm: answer) - colorMap: map; - copy: self boundingBox - from: `0@0` in: self - fillColor: nil rule: Form over. - answer offset: self offset. - ^ answer ]. - - "For 32bpp, the approach below would use just 5bits per component. - Generally it is best to extract a component in full 8bpp and keep full dynamic range. - Green usually is a good choice." - ^ self asGrayForm: 3! ! -!Form methodsFor: 'converting' stamp: 'jmv 3/12/2018 15:49:14' prior: 50361929! - asGrayForm: componentIndex -"Native depth" - "Assume the receiver is a grayscale image. Return a GrayForm computed by extracting the brightness levels of one color component. This technique allows a 32-bit Form to be converted to an 8-bit GrayForm to save space while retaining a full 255 levels of gray. (The usual colormapping technique quantizes to 8, 16, or 32 levels, which loses information.) - - If component = 1, take the alpha component - If component = 2, take the red component - If component = 3, take the green component - If component = 4, take the blue component - " - | f32 result map mask shift | - self depth = 32 ifFalse: [ - f32 _ Form extent: width@height depth: 32. - self displayOn: f32. - ^ f32 asGrayForm: componentIndex ]. - - result _ GrayForm extent: width@height. - shift _ #(-24 -16 -8 0) at: componentIndex. - mask _ #(16rFF000000 16rFF0000 16rFF00 16rFF) at: componentIndex. - map _ ColorMap masks: { mask. 0. 0. 0 } shifts: { shift. 0. 0. 0 }. - (BitBlt toForm: result) - sourceForm: self; - combinationRule: Form over; - colorMap: map; - sourceRect: (`0@0` extent: width@height); - destOrigin: `0@0`; - copyBits. - ^ result! ! -!Form methodsFor: 'converting' stamp: 'jmv 3/12/2018 15:49:21' prior: 50361968! - asGrayScaleAndTransparent: componentIndex -"Native depth" - "Assume the receiver is a grayscale image. Return a grayscale ColorForm computed by extracting the brightness levels of one color component. This technique allows a 32-bit Form to be converted to an 8-bit ColorForm to save space while retaining a full 255 levels of gray. (The usual colormapping technique quantizes to 8, 16, or 32 levels, which loses information.) - - If component = 1, take the alpha component - If component = 2, take the red component - If component = 3, take the green component - If component = 4, take the blue component - " - | f32 result map mask shift | - self depth = 32 ifFalse: [ - f32 _ Form extent: width@height depth: 32. - self displayOn: f32. - ^ f32 asGrayScaleAndTransparent: componentIndex ]. - - result _ ColorForm grayScaleAndTransparentExtent: width@height. - shift _ #(-24 -16 -8 0) at: componentIndex. - mask _ #(16rFF000000 16rFF0000 16rFF00 16rFF) at: componentIndex. - map _ ColorMap masks: { mask. 0. 0. 0 } shifts: { shift. 0. 0. 0 }. - (BitBlt toForm: result) - sourceForm: self; - combinationRule: Form over; - colorMap: map; - sourceRect: (`0@0` extent: width@height); - destOrigin: `0@0`; - copyBits. - - "final BitBlt to zero-out pixels that were truely transparent in the original" - map _ Bitmap new: 512. - map at: 1 put: 16rFF. - (BitBlt toForm: result) - sourceForm: self; - sourceRect: self boundingBox; - destOrigin: `0@0`; - combinationRule: Form erase; - colorMap: map; - copyBits. - ^ result! ! -!Form methodsFor: 'converting' stamp: 'jmv 3/12/2018 15:50:03' prior: 50362018! - icon - "Answer a 16 x 16 icon of myself" - - ^self magnifyTo: `16 @ 16`! ! -!Form methodsFor: 'copying' stamp: 'jmv 3/12/2018 15:49:28' prior: 50362023! - contentsOfArea: aRect into: newForm - "Return a new form which derives from the portion of the original form delineated by aRect." - ^ newForm copyBits: aRect from: self at: `0@0` - clippingBox: newForm boundingBox rule: Form over! ! -!Form methodsFor: 'copying' stamp: 'jmv 3/12/2018 15:49:31' prior: 50362033! - copy: aRect - "Return a new form which derives from the portion of the original form delineated by aRect." - | newForm | - newForm _ self class extent: aRect extent depth: depth. - ^ newForm copyBits: aRect from: self at: `0@0` - clippingBox: newForm boundingBox rule: Form over! ! -!Form methodsFor: 'copying' stamp: 'jmv 3/12/2018 15:49:34' prior: 50362045! - copyBits: sourceForm at: destOrigin translucent: factor - "Make up a BitBlt table and copy the bits with the given colorMap." - (BitBlt - destForm: self - sourceForm: sourceForm - combinationRule: 30 - destOrigin: destOrigin - sourceOrigin: `0@0` - extent: sourceForm extent - clipRect: self boundingBox) - copyBitsTranslucent: ((0 max: (factor*255.0) asInteger) min: 255) -" - | f f2 f3 | f _ Form fromUser. f2 _ Form fromDisplay: (0@0 extent: f extent). f3 _ f2 copy. -0.0 to: 1.0 by: 1.0/32 do: - [:t | f3 _ f2 copy. f3 copyBits: f at: 0@0 translucent: t. - f3 displayAt: 0@0. (Delay forMilliseconds: 100) wait]. -"! ! -!Form methodsFor: 'display box access' stamp: 'jmv 3/12/2018 15:49:24' prior: 50362067! -boundingBox - ^ Rectangle - origin: `0 @ 0` - corner: width @ height! ! -!Form methodsFor: 'displaying' stamp: 'jmv 3/12/2018 15:50:23' prior: 50362072! - paintBits: sourceForm at: destOrigin translucent: factor - "Make up a BitBlt table and copy the bits with the given colorMap." - (BitBlt destForm: self - sourceForm: sourceForm - combinationRule: 31 - destOrigin: destOrigin - sourceOrigin: `0@0` - extent: sourceForm extent - clipRect: self boundingBox) - copyBitsTranslucent: ((0 max: (factor*255.0) asInteger) min: 255) -" - | f f2 f3 | f _ Form fromUser. f replaceColor: f dominantColor withColor: Color transparent. -f2 _ Form fromDisplay: (0@0 extent: f extent). f3 _ f2 copy. -0.0 to: 1.0 by: 1.0/32 do: - [:t | f3 _ f2 copy. f3 paintBits: f at: 0@0 translucent: t. - f3 displayAt: 0@0. (Delay forMilliseconds: 100) wait]. -"! ! -!Form methodsFor: 'displaying-generic' stamp: 'jmv 3/12/2018 15:49:40' prior: 50362096! - displayOn: aDisplayMedium - "Simple default display in order to see the receiver in the upper left - corner of screen." - - self displayOn: aDisplayMedium at: `0 @ 0`! ! -!Form methodsFor: 'filling' stamp: 'jmv 3/12/2018 15:49:45' prior: 50362104! - eraseShape: bwForm - "use bwForm as a mask to clear all pixels where bwForm has 1's" - ((BitBlt destForm: self sourceForm: bwForm - combinationRule: Form erase1bitShape "Cut a hole in the picture with my mask" - destOrigin: bwForm offset - sourceOrigin: `0@0` - extent: self extent clipRect: self boundingBox) - colorMap: (Bitmap with: 0 with: 16rFFFFFFFF)) - copyBits! ! -!Form methodsFor: 'filling' stamp: 'jmv 3/12/2018 15:49:51' prior: 50362119! -fill: aRectangle rule: anInteger fillColor: aForm - "Replace a rectangular area of the receiver with the pattern described by aForm - according to the rule anInteger." - (BitBlt toForm: self) - copy: aRectangle - from: `0@0` in: nil - fillColor: aForm rule: anInteger! ! -!Form methodsFor: 'image manipulation' stamp: 'jmv 3/12/2018 15:50:44' prior: 50362131! - smear: dir distance: dist - "Smear any black pixels in this form in the direction dir in Log N steps" - | skew bb | - bb _ BitBlt destForm: self sourceForm: self - combinationRule: Form under destOrigin: `0@0` sourceOrigin: `0@0` - extent: self extent clipRect: self boundingBox. - skew _ 1. - [skew < dist] whileTrue: [ - bb destOrigin: dir*skew; copyBits. - skew _ skew+skew]! ! -!Form methodsFor: 'transitions' stamp: 'jmv 3/12/2018 15:50:19' prior: 50362146! - pageWarp: otherImage at: topLeft forward: forward - "Produce a page-turning illusion that gradually reveals otherImage - located at topLeft in this form. - forward == true means turn pages toward you, else away. [ignored for now]" - | pageRect oldPage nSteps buffer p leafRect sourceQuad warp oldBottom d | - pageRect _ otherImage boundingBox. - oldPage _ self copy: (pageRect translatedBy: topLeft). - (forward ifTrue: [oldPage] ifFalse: [otherImage]) - border: pageRect - widthRectangle: (Rectangle - left: 0 - right: 2 - top: 1 - bottom: 1) - rule: Form over - fillColor: Color black. - oldBottom _ self copy: ((pageRect bottomLeft + topLeft) extent: (pageRect width@(pageRect height//4))). - nSteps _ 8. - buffer _ Form extent: otherImage extent + (0@(pageRect height//4)) depth: self depth. - d _ pageRect topLeft + (0@(pageRect height//4)) - pageRect topRight. - 1 to: nSteps-1 do: - [:i | forward - ifTrue: [buffer copy: pageRect from: otherImage to: `0@0` rule: Form over. - p _ pageRect topRight + (d * i // nSteps)] - ifFalse: [buffer copy: pageRect from: oldPage to: `0@0` rule: Form over. - p _ pageRect topRight + (d * (nSteps-i) // nSteps)]. - buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over. - leafRect _ pageRect topLeft corner: p x @ (pageRect bottom + p y). - sourceQuad _ Array with: pageRect topLeft - with: pageRect bottomLeft + (0@p y) - with: pageRect bottomRight - with: pageRect topRight - (0@p y). - warp _ (WarpBlt toForm: buffer) - clipRect: leafRect; - sourceForm: (forward ifTrue: [oldPage] ifFalse: [otherImage]); - combinationRule: Form paint. - warp copyQuad: sourceQuad toRect: leafRect. - self copy: buffer boundingBox from: buffer to: topLeft rule: Form over. - Display forceToScreen. - ]. - - buffer copy: pageRect from: otherImage to: `0@0` rule: Form over. - buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over. - self copy: buffer boundingBox from: buffer to: topLeft rule: Form over. - Display forceToScreen. -" -1 to: 4 do: [:corner | Display pageWarp: - (Form fromDisplay: (10@10 extent: 200@300)) reverse - at: 10@10 forward: false] -"! ! -!Form methodsFor: 'private' stamp: 'jmv 3/12/2018 15:49:37' prior: 50362217! - copyFromByteArray: bigEndianByteArray - "This method should work with either byte orderings. - See comment at Bitmap>>#asByteArray - Also see #copyFromByteArray2:to:" - - | myHack byteHack | - myHack := Form new hackBits: bits. - byteHack := Form new hackBits: bigEndianByteArray. - "We are passing a ByteArray instead of a Words object. Will be accessed according to native endianness." - Smalltalk isLittleEndian = self isLittleEndian ifFalse: [byteHack swapEndianness]. - byteHack displayOn: myHack at: `0 @ 0` rule: Form over! ! -!Form methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:50:00' prior: 50362236! - fromDisplay: aRectangle - "Create a virtual bit map from a user specified rectangular area on the - display screen. Reallocates bitmap only if aRectangle ~= the receiver's - extent." - - (width = aRectangle width and: [height = aRectangle height]) - ifFalse: [self setExtent: aRectangle extent depth: depth]. - self - copyBits: (aRectangle origin extent: self extent) - from: Display - at: `0 @ 0` - clippingBox: self boundingBox - rule: Form over! ! -!Form methodsFor: 'encoding' stamp: 'jmv 3/12/2018 15:49:03' prior: 50362253! - addDeltasFrom: previousForm - - (BitBlt - destForm: self - sourceForm: previousForm - fillColor: nil - combinationRule: Form reverse - destOrigin: `0@0` - sourceOrigin: `0@0` - extent: self extent - clipRect: self boundingBox) copyBits. - ^self! ! -!Form class methodsFor: 'instance creation' stamp: 'jmv 3/12/2018 15:51:12' prior: 50362264! - dotOfSize: diameter - "Create a form which contains a round black dot." - | radius form bb rect centerX centerY centerYBias centerXBias radiusSquared xOverY maxy dx | - radius _ diameter//2. - form _ self extent: diameter@diameter offset: `0@0` - radius. - bb _ (BitBlt toForm: form) - sourceX: 0; sourceY: 0; - combinationRule: Form over; - fillColor: Color black. - rect _ form boundingBox. - centerX _ rect center x. - centerY _ rect center y. - centerYBias _ rect height odd ifTrue: [0] ifFalse: [1]. - centerXBias _ rect width odd ifTrue: [0] ifFalse: [1]. - radiusSquared _ (rect height asFloat / 2.0) squared - 0.01. - xOverY _ rect width asFloat / rect height asFloat. - maxy _ rect height - 1 // 2. - - "First do the inner fill, and collect x values" - 0 to: maxy do: [ :dy | - dx _ ((radiusSquared - (dy * dy) asFloat) sqrt * xOverY) truncated. - bb destX: centerX - centerXBias - dx - destY: centerY - centerYBias - dy - width: dx + dx + centerXBias + 1 - height: 1; - copyBits. - bb destY: centerY + dy; - copyBits]. - ^ form -" -Time millisecondsToRun: - [1 to: 20 do: [:i | (Form dotOfSize: i) displayAt: (i*20)@(i*20)]] -"! ! -!Form class methodsFor: 'examples' stamp: 'jmv 3/12/2018 15:51:17' prior: 50362302! - toothpaste: diam - " - Display restoreAfter: [Form toothpaste: 30] - " - "Not completely unlike the ST-80 implementation :) - Original comment: - Draws wormlike lines by laying down images of spheres. - See Ken Knowlton, Computer Graphics, vol. 15 no. 4 p352. - Draw with mouse button down; terminate by option-click." - | point queue color q colors colr colr2 | - colors _ Color red wheel: 12. - color _ 8. - [ true ] whileTrue: [ - queue _ OrderedCollection new: 32. - 16 timesRepeat: [queue addLast: `-40@-40`]. - Sensor waitButton. - Sensor isMouseButton2Pressed ifTrue: [^ self]. - point _ Sensor mousePoint. - colr _ colors atWrap: (color _ color + 5). "choose increment relatively prime to colors size" - colr2 _ colr alpha: 0.3. - [Sensor isMouseButton1Pressed or: [queue size > 0]] whileTrue: [ - point _ point * 4 + Sensor mousePoint // 5. - point _ point. - Form fakeSphereAt: point diameter: diam color: colr. - (q _ queue removeFirst) ifNil: [^ self]. "exit" - Form fakeSphereAt: q diameter: diam color: colr2. - Sensor isMouseButton1Pressed ifTrue: [queue addLast: point]]]! ! -!ColorForm methodsFor: 'color manipulation' stamp: 'jmv 3/12/2018 15:47:55' prior: 50362339! - asGrayForm - "Build an optimal GrayForm, - for any color palette in the receiver." - | answer map | - answer _ GrayForm extent: width@height. - map _ self colormapIfNeededForGray8bpp. - (BitBlt toForm: answer) - colorMap: map; - copy: self boundingBox - from: `0@0` in: self - fillColor: nil rule: Form over. - ^ answer! ! -!ColorForm methodsFor: 'copying' stamp: 'jmv 3/12/2018 15:47:59' prior: 50362352! - copy: aRect - "Return a new ColorForm containing the portion of the receiver delineated by aRect." - - | newForm | - newForm _ self class extent: aRect extent depth: depth. - ((BitBlt - destForm: newForm - sourceForm: self - combinationRule: Form over - destOrigin: `0@0` - sourceOrigin: aRect origin - extent: aRect extent - clipRect: newForm boundingBox) - colorMap: nil) copyBits. - colors ifNotNil: [newForm colors: colors copy]. - ^ newForm! ! -!ColorForm class methodsFor: 'as yet unclassified' stamp: 'jmv 3/12/2018 15:48:04' prior: 50362369! - mappingWhiteToTransparentFrom: aFormOrCursor - "Return a ColorForm copied from the given Form or Cursor with white mapped to transparent." - - | f map | - aFormOrCursor depth <= 8 ifFalse: [ - ^ self error: 'argument depth must be 8-bits per pixel or less']. - (aFormOrCursor is: #ColorForm) ifTrue: [ - f _ aFormOrCursor copy. - map _ aFormOrCursor colors. - ] ifFalse: [ - f _ ColorForm extent: aFormOrCursor extent depth: aFormOrCursor depth. - f copyBits: aFormOrCursor boundingBox - from: aFormOrCursor - at: `0@0` - clippingBox: aFormOrCursor boundingBox - rule: Form over. - map _ Color indexedColors copyFrom: 1 to: (1 bitShift: aFormOrCursor depth)]. - map _ map collect: [:c | - c = Color white ifTrue: [Color transparent] ifFalse: [c]]. - f colors: map. - ^ f! ! -!Cursor methodsFor: 'converting' stamp: 'jmv 3/12/2018 15:48:08' prior: 50362396! - enlargedBy: scale - "Big cursors are 32 bits deep (ARGB premultiplied)" - | big | - scale = 1 ifTrue: [^self]. - big := CursorWithAlpha extent: self extent * scale depth: 32. - (self asCursorForm magnifyBy: scale) displayOn: big. - big offset: (self offset - 0.5 * scale min: `0@0` max: big extent negated) asIntegerPoint. - big fallback: self. - ^ big! ! -!DisplayScreen class methodsFor: 'snapshots' stamp: 'jmv 3/12/2018 15:48:15' prior: 50362410! - actualScreenSize - - ^ `640@480`! ! -!DisplayScreen class methodsFor: 'snapshots' stamp: 'jmv 3/12/2018 15:48:18' prior: 50362415! - shutDown - "Minimize Display memory saved in image" - Display setExtent: `240@120` depth: Display nativeDepth. - ScreenUpdaterProcess ifNotNil: [ - ScreenUpdaterProcess terminate. - ScreenUpdaterProcess _ nil ]! ! -!GrayForm methodsFor: 'copying' stamp: 'jmv 3/12/2018 15:51:21' prior: 50362425! - copy: aRect - "Return a new instance containing the portion of the receiver delineated by aRect." - - | newForm | - newForm _ self class extent: aRect extent depth: depth. - ((BitBlt - destForm: newForm - sourceForm: self - combinationRule: Form over - destOrigin: `0@0` - sourceOrigin: aRect origin - extent: aRect extent - clipRect: newForm boundingBox) - colorMap: nil) copyBits. - ^ newForm! ! -!BitBlt class methodsFor: 'instance creation' stamp: 'jmv 3/12/2018 15:47:23' prior: 50362441! - bitPeekerFromForm: sourceForm - "Answer an instance to be used extract individual pixels from the given Form. The destination for a 1x1 copyBits will be the low order bits of (bits at: 1)." - | pixPerWord answer | - pixPerWord _ sourceForm pixelsPerWord. - answer _ self destForm: (Form extent: pixPerWord@1 depth: sourceForm depth) - sourceForm: nil "To ensure no colormap set" - combinationRule: Form over - destOrigin: (pixPerWord - 1)@0 - sourceOrigin: `0@0` - extent: `1@1` - clipRect: (`0@0` extent: pixPerWord@1). - "To ensure no colormap set" - answer sourceForm: sourceForm. - ^ answer! ! -!BitBlt class methodsFor: 'instance creation' stamp: 'jmv 3/12/2018 15:47:27' prior: 50362463! - bitPokerToForm: destForm - "Answer an instance to be used for valueAt: aPoint put: pixValue. - The source for a 1x1 copyBits will be the low order of (bits at: 1)" - | pixPerWord answer | - pixPerWord _ 32//destForm depth. - answer _ self destForm: destForm - sourceForm: nil "To ensure no colormap set" - combinationRule: Form over - destOrigin: `0@0` - sourceOrigin: (pixPerWord-1)@0 - extent: `1@1` - clipRect: (`0@0` extent: destForm extent). - "To ensure no colormap set" - answer sourceForm: (Form extent: pixPerWord@1 depth: destForm depth). - ^ answer! ! -!AffineTransformation methodsFor: 'converting coordinates' stamp: 'jmv 3/12/2018 15:46:56' prior: 50362484! - internalizeDelta: aPoint - "Internalize a distance vector. A distance is not a position. It is a magnitude with a direction. - It is usually used as a delta to be added to a position to obtain some other position." - - | x y det a11 a12 a21 a22 detX detY | - x _ aPoint x. - y _ aPoint y. - a11 _ self a11. - a12 _ self a12. - a21 _ self a21. - a22 _ self a22. - det _ (a11 * a22) - (a12 * a21). - det = 0.0 ifTrue: [ ^`0@0` ]. "So we have at least a valid result" - det _ 1.0 / det. - detX _ (x * a22) - (a12 * y). - detY _ (a11 * y) - (x * a21). - ^ (detX * det) @ (detY * det)! ! -!AffineTransformation methodsFor: 'converting coordinates' stamp: 'jmv 3/12/2018 15:47:00' prior: 50362506! - inverseTransform: aPoint - "Apply the inverse transformation to aPoint, i.e. multiply our inverse by aPoint. - Use Smalltalk code, and not Matrix2x3Plugin, because we want Float conversion." - | x y det a11 a12 a21 a22 detX detY | - - x _ aPoint x - self a13. - y _ aPoint y - self a23. - a11 _ self a11. - a12 _ self a12. - a21 _ self a21. - a22 _ self a22. - det _ (a11 * a22) - (a12 * a21). - det = 0.0 ifTrue: [ ^`0@0` ]. "So we have at least a valid result" - det _ 1.0 / det. - detX _ (x * a22) - (a12 * y). - detY _ (a11 * y) - (x * a21). - ^ (detX * det) @ (detY * det)! ! -!AffineTransformation methodsFor: 'accessing' stamp: 'jmv 3/12/2018 15:47:03' prior: 50362527! - inverseTransformation - "Return the inverse transformation of the receiver. - The inverse transformation is computed by first calculating - the inverse offset and then computing transformations - for the two identity vectors (1@0) and (0@1)" - | r1 r2 r3 m | - r3 _ self inverseTransform: `0@0`. - r1 _ (self inverseTransform: `1@0`) - r3. - r2 _ (self inverseTransform: `0@1`) - r3. - m _ self species new. - m - a11: r1 x; a12: r2 x; a13: r3 x; - a21: r1 y; a22: r2 y; a23: r3 y. - ^ m! ! -!AffineTransformation methodsFor: 'transforming rects' stamp: 'jmv 3/12/2018 15:46:50' prior: 50362546! - displayBoundsOfTransformOf: aRectangle - "Externalize aRectangle, and find a bounding rectangle with horizontal - and vertical bounds and integer coordinates (i.e. adisplayBounds). - Primitive rounds and answers integers. - Warning: if answer from primitive is not strictly positive, it is off by one. Fix it here." - - | dstRect | - dstRect _ Rectangle new. - (self primDisplayBoundsOfTransformOf: aRectangle into: dstRect) ifNotNil: [ - dstRect topLeft > `0@0` ifTrue: [ ^dstRect ]]. - ^Rectangle encompassing: (aRectangle corners collect: [ :pt | - (self transform: pt) rounded ])! ! -!Point methodsFor: 'point functions' stamp: 'jmv 3/12/2018 15:55:24' prior: 50362567! - eightNeighbors - ^ (Array with: self + `1@0` - with: self + `1@1` - with: self + `0@1` - with: self + `-1@1`) , - (Array with: self + `-1@0` - with: self + `-1@-1` - with: self + `0@-1` - with: self + `1@-1`)! ! -!Point methodsFor: 'point functions' stamp: 'jmv 3/12/2018 15:55:28' prior: 50362577! - fourNeighbors - ^ Array with: self + `1@0` - with: self + `0@1` - with: self + `-1@0` - with: self + `0@-1`! ! -!Rectangle methodsFor: 'accessing' stamp: 'jmv 3/12/2018 15:55:55' prior: 50362584! - innerCorners - "Return an array of inner corner points, - ie, the most extreme pixels included, - in the order of a quadrilateral spec for WarpBlt" - | r1 | - r1 _ self topLeft corner: self bottomRight - `1@1`. - ^ Array with: r1 topLeft with: r1 bottomLeft with: r1 bottomRight with: r1 topRight! ! -!Morph methodsFor: 'events-processing' stamp: 'jmv 3/12/2018 15:53:54' prior: 50362596! - processUnknownEvent: aMorphicEvent localPosition: localEventPosition - "An event of an unknown type was sent to the receiver. What shall we do?!!" - - Smalltalk beep. - aMorphicEvent printString displayAt: `0@0`. - aMorphicEvent wasHandled: true! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 3/12/2018 15:53:40' prior: 50362607! - minimumExtent - "This returns the minimum extent that the morph may be shrunk to. Not honored in too many places yet, but respected by the resizeToFit feature, at least" - - self flag: #jmvVer2. "in owner's coordinates?" - ^self valueOfProperty: #minimumExtent ifAbsent: [`1@1`]! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 3/12/2018 15:53:42' prior: 50362619! - morphExtent - "In our own coordinates!!" -"Quizas eventualmente borrar este tambien? (no se usa mucho...)" - self flag: #jmvVer2. - ^`50 @ 40`! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 3/12/2018 15:53:45' prior: 50362626! - morphPositionInWorld - - self flag: #jmvVer2. - "Most likely we don't want to use global coordinates... - In fact, we could be in many frames of reference at the same time... - This method makes no sense at all!!" - - ^self externalizeToWorld: `0@0`! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 3/12/2018 15:53:48' prior: 50362637! - morphTopLeft - "By default, morphs occupy a rectangle specified by #morphTopLef and #morphExtent" - ^`0@0`! ! -!Morph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:53:51' prior: 50362644! - openInWorld: aWorld - "Add this morph to the requested World." - (location = MorphicTranslation new) - ifTrue: [ aWorld addMorph: self position: `50@50` ] - ifFalse: [ aWorld addMorph: self ]! ! -!RectangleLikeMorph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:55:58' prior: 50362654! - initialize - super initialize. - extent _ `50@40`. - color _ self defaultColor! ! -!PasteUpMorph methodsFor: 'change reporting' stamp: 'jmv 3/12/2018 15:54:34' prior: 50362660! - invalidateDisplayRect: damageRect from: aMorph - "Clip damage reports to my bounds, since drawing is clipped to my bounds." - - self == self world - ifTrue: [ worldState recordDamagedRect: (damageRect intersect: ( `0@0` extent: extent) ) ] - ifFalse: [ super invalidateDisplayRect: damageRect from: aMorph ]! ! -!PasteUpMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:54:27' prior: 50362674! - drawOn: aCanvas - - "draw background image." - backgroundImage - ifNotNil: [ - aCanvas image: backgroundImage at: `0@0` ] - ifNil: [ - "draw background fill" - (self isWorldMorph and: [ aCanvas drawsOnDisplay ] and: [ color mightBeTranslucent ]) - ifTrue: [ - "Special case so a translucent background on the Display allows you to see through the main Cuis Window. - Requires proper handling of translucent Display in the VM. - Seems to work only on Linux when using a composing window manager." - (BitBlt toForm: Display) clipRect: aCanvas clipRect; - copy: Display boundingBox - from: `0@0` in: nil - fillColor: color rule: Form over. - Display forceToScreen] - ifFalse: [ super drawOn: aCanvas ]]! ! -!PasteUpMorph methodsFor: 'geometry' stamp: 'jmv 3/12/2018 15:54:38' prior: 50362700! - morphPositionInWorld - - self flag: #jmvVer2. "Solo para evitar los warning por falta de owner... pensar despues este caso" - self isWorldMorph ifTrue: [ ^ `0@0` ]. - ^ super morphPositionInWorld! ! -!PasteUpMorph methodsFor: 'project state' stamp: 'jmv 3/12/2018 15:54:43' prior: 50362709! - viewBox - - ^ worldState - ifNotNil: [ - `0@0` extent: extent ] - ifNil: [ - self world viewBox ]! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 3/12/2018 15:54:30' prior: 50381046! - fillRects: rectangleList - "For testing. Flashes the given list of rectangles on the Display so you can watch incremental redisplay at work." - - - | blt screenRect | - blt _ (BitBlt toForm: Display) - sourceForm: nil; - sourceOrigin: `0@0`; - clipRect: self viewBox; - combinationRule: Form over. - - rectangleList do: [:r | - screenRect _ r translatedBy: self viewBox origin. - blt fillColor: Color random. - blt destRect: screenRect; copyBits. - Display forceToScreen: screenRect ]. - - (Delay forMilliseconds: 50) wait! ! -!PasteUpMorph class methodsFor: 'instance creation' stamp: 'jmv 3/12/2018 15:54:48' prior: 50379167! - newWorld - " -[ - UISupervisor stopUIProcess. - UISupervisor spawnNewMorphicProcessFor: PasteUpMorph newWorld -] fork. - " - | w ws | - w _ self new. - ws _ WorldState new. - w worldState: ws. - w morphPosition: `0@0` extent: Display extent. - ws setCanvas: Display getCanvas. - w borderWidth: 0. - ws handsDo: [ :h | - h privateOwner: w ]. - ^w! ! -!EllipseMorph methodsFor: 'geometry testing' stamp: 'jmv 3/12/2018 15:48:22' prior: 50362778! - morphContainsPoint: aLocalPoint - - | radius other delta xOverY | - ((`0@0` extent: extent) containsPoint: aLocalPoint) ifFalse: [^ false]. "quick elimination" - extent > `1@1` - ifFalse: [^ true]. "Degenerate case -- code below fails by a bit" - - radius _ extent y asFloat / 2. - other _ extent x asFloat / 2. - delta _ aLocalPoint - (other@radius). - xOverY _ extent x asFloat / extent y asFloat. - ^ (delta x asFloat / xOverY) squared + delta y squared <= radius squared! ! -!HandleMorph methodsFor: 'events' stamp: 'jmv 3/12/2018 15:51:54' prior: 50362796! - keyStroke: aKeyboardEvent - "Check for cursor keys" - | keyValue | - (owner is: #HandMorph) ifFalse: [ ^self ]. - keyValue _ aKeyboardEvent keyValue. - keyValue = 28 ifTrue: [ ^self morphPosition: self morphPosition - `1@0` ]. - keyValue = 29 ifTrue: [ ^self morphPosition: self morphPosition + `1@0` ]. - keyValue = 30 ifTrue: [ ^self morphPosition: self morphPosition - `0@1` ]. - keyValue = 31 ifTrue: [ ^self morphPosition: self morphPosition + `0@1` ]. - "Special case for return" - aKeyboardEvent isReturnKey ifTrue:[ - "Drop the receiver and be done" - self flag: #arNote. "Probably unnecessary" - owner releaseKeyboardFocus: self. - self delete ]! ! -!HandleMorph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:51:51' prior: 50362820! - initialize - "initialize the state of the receiver" - super initialize. - extent _ `12@12`! ! -!PluggableMorph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:55:13' prior: 50362826! - initialize - super initialize. - extent _ `200@100`! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:54:51' prior: 50367591! - draw3DLookOn: aCanvas - - | borderStyleSymbol c | - borderStyleSymbol _ self isPressed ifFalse: [ #raised ] ifTrue: [ #inset ]. - c _ color. - self mouseIsOver ifTrue: [ c _ c lighter ]. - aCanvas - fillRectangle: (`0@0` extent: extent) - color: c - borderWidth: borderWidth - borderStyleSymbol: borderStyleSymbol - baseColorForBorder: c. - - self drawRegularLabelOn: aCanvas! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:54:54' prior: 50367663! - drawRoundGradientLookOn: aCanvas - | r colorForButton rect bottomFactor topFactor | - - self isPressed - ifFalse: [ - topFactor _ Theme current buttonGradientTopFactor. - bottomFactor _ Theme current buttonGradientBottomFactor. - self mouseIsOver - ifTrue: [ - colorForButton _ Color h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ - colorForButton _ color ]] - ifTrue: [ - topFactor _ Theme current buttonGradientBottomFactor. - bottomFactor _ Theme current buttonGradientTopFactor. - colorForButton _ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - Theme current useButtonGradient - ifTrue: [ - rect _ (`0@0` extent: extent) insetBy: `1@3`. - aCanvas - roundRect: rect - color: colorForButton - radius: r - gradientTop: topFactor - gradientBottom: bottomFactor - gradientHeight: Theme current buttonGradientHeight ] - ifFalse: [ - rect _ (`0@0` extent: extent) insetBy: `1@3`. - aCanvas roundRect: rect color: colorForButton radius: r ] - ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawEmbossedLabelOn: aCanvas ] - ifFalse: [ self drawRegularLabelOn: aCanvas ]! ! -!PluggableButtonMorph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:54:57' prior: 50367705! - initialize - "initialize the state of the receiver" - super initialize. - - roundButtonStyle _ nil. "nil: honor Theme. true: draw as round button. false: draw as classic 3d border square button" - model _ nil. - getStateSelector _ nil. - actionSelector _ nil. - isPressed _ false. - mouseIsOver _ false. - actWhen _ #buttonUp. - extent _ `20 @ 15`! ! -!PluggableButtonMorph methodsFor: 'geometry testing' stamp: 'jmv 3/12/2018 15:55:00' prior: 50367736! - morphContainsPoint: aLocalPoint - - | iconOrigin | - ((`0@0` extent: extent) containsPoint: aLocalPoint) ifFalse: [ ^false ]. - ^ self isOrthoRectangularMorph or: [ - magnifiedIcon isNil or: [ - iconOrigin _ extent - magnifiedIcon extent // 2. - (magnifiedIcon isTransparentAt: (aLocalPoint - iconOrigin) rounded) not ]]! ! -!PluggableButtonMorph class methodsFor: 'example' stamp: 'jmv 3/12/2018 15:55:05' prior: 50362916! - example - " - PluggableButtonMorph example openInWorld - " - - | s1 s2 s3 b1 b2 b3 row | - s1 _ Switch new. - s2 _ Switch new turnOn. - s3 _ Switch new. - s2 onAction: [s3 turnOff]. - s3 onAction: [s2 turnOff]. - b1 _ (PluggableButtonMorph model: s1 stateGetter: #isOn action: #switch) label: 'S1'. - b2 _ (PluggableButtonMorph model: s2 stateGetter: #isOn action: #turnOn) label: 'S2'. - b3 _ (PluggableButtonMorph model: s3 stateGetter: #isOn action: #turnOn) label: 'S3'. - b1 color: Color lightRed. - b2 color: Color lightRed. - b3 color: Color lightRed. - row _ LayoutMorph newRow - addMorphs: (Array with: b1 with: b2 with: b3); - morphExtent: `120@35`. - ^ row! ! -!PluggableScrollPane methodsFor: 'access' stamp: 'jmv 3/12/2018 15:55:16' prior: 50362940! - addToScroller: aMorph - - scroller - addMorph: aMorph position: `0@0`; - morphExtent: aMorph morphExtent! ! -!PluggableScrollPane methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:55:18' prior: 50362947! - initialize - - "initialize the state of the receiver" - super initialize. - hideScrollBars _ false. - - "initialize the receiver's scrollBars" - scrollBar _ self scrollBarClass new model: self setValueSelector: #vScrollBarValue:. - hScrollBar _ self scrollBarClass new model: self setValueSelector: #hScrollBarValue:. - drawKeyboardFocusIndicator _ true. - - scroller _ self innerMorphClass new. - self addMorph: scroller. - self scrollerOffset: `0@ 0`. - self addMorph: scrollBar. - self addMorph: hScrollBar! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'jmv 3/12/2018 15:55:21' prior: 50362966! - scrollToShow: aRectangle - "scroll to include as much of aRectangle as possible, where aRectangle is in the scroller's local space. - This means that 0@0 is scrolling all the way top and all the way left" - | delta | - (aRectangle top >= 0 and: [ - aRectangle bottom <= self viewableHeight ]) - ifTrue: [ - "already visible" - ^self ]. - - "Scroll end of selection into view if necessary" - delta _ aRectangle amountToTranslateWithin: (`0@0` extent: self viewableExtent). - delta y ~= 0 ifTrue: [ - self scrollBy: 0@delta y ]! ! -!PluggableListMorphOfMany methodsFor: 'events' stamp: 'jmv 3/12/2018 15:55:10' prior: 50380605! - mouseMove: aMouseMoveEvent localPosition: localEventPosition - "The mouse has moved, as characterized by the event provided. Adjust the scrollbar, and alter the selection as appropriate" - - | oldIndex oldVal row | - row _ (localEventPosition y < 0 and: [ scrollBar scrollValue > 0.0 ]) - ifTrue: [ - scrollBar scrollUp: 1. - "Leave at least one visible item unaffected, for better visual feedback to the user." - (self rowAtLocation: `0@0`) + 2 ] - ifFalse: [ - (localEventPosition y > extent y and: [ scrollBar scrollValue < 1.0 ]) - ifTrue: [ - scrollBar scrollDown: 1. - "Leave at least one visible item unaffected, for better visual feedback to the user." - (self rowAtLocation: 0@extent y) - 3 ] - ifFalse: [ self rowAtLocation: localEventPosition ]]. - row = 0 ifTrue: [ ^ self ]. - - "No change if model is locked" - self owningWindow ifNotNil: [ :w | - w okToChange ifFalse: [^ self]]. - - dragOnOrOff ifNil: [ - "Was not set at mouse down, which means the mouse must have gone down in an area where there was no list item" - dragOnOrOff _ (self listSelectionAt: row) not. - dragStartRow _ row ]. - - "Set meaning for subsequent dragging of selection" - oldIndex _ self getCurrentSelectionIndex. - oldIndex ~= 0 ifTrue: [ oldVal _ self listSelectionAt: oldIndex ]. - - "Set or clear new primary selection (listIndex)" - dragOnOrOff - ifTrue: [ self setSelectionIndex: row ] - ifFalse: [ self setSelectionIndex: 0 ]. - - "Need to restore the old one, due to how model works, and set new one." - oldIndex ~= 0 ifTrue: [ self listSelectionAt: oldIndex put: oldVal ]. - - "Select all in between if drag was too fast" - "self listSelectionAt: row put: dragOnOrOff." - (row min: dragStartRow) to: (row max: dragStartRow) do: [ :r | - self listSelectionAt: r put: dragOnOrOff ]! ! -!SystemWindow methodsFor: 'change reporting' stamp: 'jmv 3/12/2018 15:56:57' prior: 50363045! - invalidateTitleArea - - "not really pretty... also invalidating the top border, regardless of it being above or below the title area - (Different themes use various looks, this covers them all)" - self invalidateLocalRect: (`0@0` extent: extent x @ (self labelHeight + borderWidth))! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:56:43' prior: 50363057! - drawClassicFrameOn: aCanvas color: titleColor - "Window border encompasses title area. No round corners. No title gradient." - - aCanvas fillRectangle: (`0@0` extent: extent) color: color borderWidth: borderWidth borderStyleSymbol: #simple baseColorForBorder: self widgetsColor. - - "A border was drawn at the left, top and right of the title area. - The look is that the title area is inside the window" - aCanvas fillRectangle: (borderWidth@borderWidth extent: extent x - (2*borderWidth)@ self labelHeight) color: titleColor! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:56:47' prior: 50363076! -drawRoundedFrameOn: aCanvas color: widgetsColor - "Title area is not inside window borders" - | bottomFactor topFactor | - Theme current useWindowTitleGradient - ifTrue: [ - topFactor _ Theme current titleGradientTopFactor. - bottomFactor _ Theme current titleGradientBottomFactor ] - ifFalse: [ - topFactor _ 1. - bottomFactor _ 1 ]. - aCanvas - windowFrame: (`0@0` extent: extent) - color: widgetsColor * Theme current titleGradientExtraLightness - radius: Theme current roundedWindowRadius - border: borderWidth - labelHeight: self labelHeight + borderWidth - gradientTop: topFactor - gradientBottom: bottomFactor - insideColor: color! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:57:04' prior: 50363099! - makeMeFullyVisible - - self world morphExtent > `0@0` ifFalse: [^ self]. - - (self morphPosition >= `0@0` and: [ self morphPosition < (self world morphExtent-self morphExtent)]) ifTrue: [ - ^ self "OK -- visible"]. - - self morphPosition: (RealEstateAgent initialFrameFor: self initialExtent: self morphExtentInWorld world: self world) topLeft! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:57:07' prior: 50363113! - makeMeVisible - - self world morphExtent > `0@0` ifFalse: [^ self]. - - (self morphPosition >= `0@0` and: [ self morphPosition < (self world morphExtent-self labelHeight)]) ifTrue: [ - ^ self "OK -- at least my top left is visible"]. - - "window not on screen (probably due to reframe) -- move it now" - self morphPosition: (RealEstateAgent initialFrameFor: self initialExtent: extent world: self world) topLeft! ! -!SystemWindow methodsFor: 'geometry' stamp: 'jmv 3/12/2018 15:57:09' prior: 50363129! - minimumExtent - - ^`160@80`! ! -!SystemWindow methodsFor: 'geometry' stamp: 'jmv 3/12/2018 15:57:13' prior: 50363133! - rescaleButtons - "boxExtent changed. Update my buttons." - | buttonExtent buttonPos buttonDelta | - buttonExtent := self boxExtent. - buttonPos := `2@2`. - buttonDelta := self boxExtent x + 2. - self submorphsReverseDo: [ :aMorph | - (aMorph is: #PluggableButtonMorph) - ifTrue: [ - aMorph morphExtent: buttonExtent. - aMorph morphPosition: buttonPos. - buttonPos := (buttonPos x + buttonDelta) @ 2. - ]. - ]! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:56:39' prior: 50363149! - boxExtent - "answer the extent to use in all the buttons. - - the label height is used to be proportional to the fonts preferences" - | e | - Theme current minimalWindows ifTrue: [^`0@0`]. - e _ Preferences windowTitleFont height. - ^e@e! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:56:51' prior: 50363160! - initialize - "Initialize a system window. Add label, stripes, etc., if desired" - - super initialize. - labelString ifNil: [ labelString _ 'Untitled Window']. - - self initializeLabelArea. - extent _ `300 @ 200`. - - adjusters _ Dictionary new. - adjusters at: #topAdjuster put: WindowEdgeAdjustingMorph forTop. - adjusters at: #bottomAdjuster put: WindowEdgeAdjustingMorph forBottom. - adjusters at: #leftAdjuster put: WindowEdgeAdjustingMorph forLeft. - adjusters at: #rightAdjuster put: WindowEdgeAdjustingMorph forRight. - adjusters at: #topLeftAdjuster put: WindowEdgeAdjustingMorph forTopLeft. - adjusters at: #bottomLeftAdjuster put: WindowEdgeAdjustingMorph forBottomLeft. - adjusters at: #topRightAdjuster put: WindowEdgeAdjustingMorph forTopRight. - adjusters at: #bottomRightAdjuster put: WindowEdgeAdjustingMorph forBottomRight. - adjusters do: [ :m | - self addMorphFront: m ]. - - "by default" - self beColumn! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:56:54' prior: 50363192! - initializeLabelArea - "Initialize the label area (titlebar) for the window." - - | spacing | - spacing _ self boxExtent x + 2. - self addMorph: self createCloseBox position: `2@2`. - self addMorph: self createCollapseBox position: spacing+2@2. - self addMorph: self createExpandBox position: spacing*2+2@2. - self addMorph: self createMenuBox position: spacing*3+2@2! ! -!SystemWindow methodsFor: 'layout' stamp: 'jmv 3/12/2018 15:57:00' prior: 50363206! - layoutSubmorphs - "Compute a new layout of submorphs based on the given layout bounds." - - | h thickness w cornerExtent wh ww pos | - thickness _ 4. - cornerExtent _ 20. - ww _ extent x. - wh _ extent y. - w _ ww - cornerExtent - cornerExtent. - h _ wh - cornerExtent - cornerExtent. - (adjusters at: #topAdjuster) morphPosition: cornerExtent@0 extent: w@thickness. - (adjusters at: #bottomAdjuster) morphPosition: cornerExtent@(wh-thickness) extent: w@thickness. - (adjusters at: #leftAdjuster) morphPosition: 0@cornerExtent extent: thickness@h. - (adjusters at: #rightAdjuster) morphPosition: ww-thickness@cornerExtent extent: thickness@h. - (adjusters at: #topLeftAdjuster) morphPosition: `0@0` extent: cornerExtent@cornerExtent. - (adjusters at: #bottomLeftAdjuster) morphPosition: 0@(wh-cornerExtent) extent: cornerExtent@cornerExtent. - (adjusters at: #topRightAdjuster) morphPosition: ww-cornerExtent@0 extent: cornerExtent@cornerExtent. - (adjusters at: #bottomRightAdjuster) morphPosition: ww@wh-cornerExtent extent: cornerExtent@cornerExtent. - - layoutMorph ifNotNil: [ - pos _ borderWidth @ (borderWidth + self labelHeight). - layoutMorph - morphPosition: pos - extent: extent - pos - borderWidth ]. - - layoutNeeded _ false! ! -!SystemWindow methodsFor: 'resize/collapse' stamp: 'jmv 3/12/2018 15:57:17' prior: 50363248! - resize - | resizeMorph | - resizeMorph _ ResizeMorph new morphExtent: `200@150`. - resizeMorph action: [self resize: (resizeMorph selectionRectangle: Display extent)]. - resizeMorph morphPosition: self world activeHand morphPosition. - resizeMorph openInWorld! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'jmv 3/12/2018 15:47:52' prior: 50375301! - initialExtent - - ^`540@400` * Preferences standardCodeFont height // 14! ! -!ChangeSorterWindow methodsFor: 'GUI building' stamp: 'jmv 3/12/2018 15:47:45' prior: 50375307! - initialExtent - ^`540@300` * Preferences standardCodeFont height // 14! ! -!PreDebugWindow methodsFor: 'GUI building' stamp: 'jmv 3/12/2018 15:55:30' prior: 50375313! - initialExtent - ^ `640 @ 320` * Preferences standardCodeFont height // 14! ! -!InspectorWindow methodsFor: 'GUI building' stamp: 'jmv 3/12/2018 15:52:24' prior: 50375319! - initialExtent - - ^`600@325` * Preferences standardCodeFont height // 14! ! -!ObjectExplorerWindow methodsFor: 'GUI building' stamp: 'jmv 3/12/2018 15:54:22' prior: 50375325! - initialExtent - - ^`300@500` * Preferences standardCodeFont height // 14! ! -!TestRunnerWindow methodsFor: 'GUI building' stamp: 'jmv 3/12/2018 15:57:20' prior: 50363280! - buildMorphicWindow - - self layoutMorph - addMorph: self buildUpperControls proportionalHeight: 0.25; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.75. - self setLabel: 'SUnit Test Runner'. - self refreshWindow. - self morphExtent: `460 @ 400`! ! -!ScrollBar methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:56:22' prior: 50363291! - drawOn: aCanvas - - aCanvas - fillRectangle: (`0@0` extent: extent) - color: (color alphaMixed: 0.3 with: Theme current scrollbarColor) - borderWidth: borderWidth - borderStyleSymbol: #simple - baseColorForBorder: borderColor! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 3/12/2018 15:53:14' prior: 50363301! - addTitle: aString - "Add a title line at the top of this menu Make aString its initial - contents. - If aSelector is not nil, then periodically obtain fresh values for its - contents by sending aSelector to aTarget.." - - | s pp w | - - titleMorph _ RectangleLikeMorph new. - titleMorph color: Theme current menuTitleBar. - pp _ `8@2`. - aString asString linesDo: [ :line | - s _ StringMorph new - contents: line; - font: Preferences standardMenuFont bold. - titleMorph addMorphBack: s position: pp. - pp _ pp + (0@(s morphHeight+2)) ]. - w _ titleMorph submorphs inject: 0 into: [ :prev :each | - prev max: each morphWidth ]. - titleMorph morphExtent: (w + 16) @ (pp y). - self addMorphFront: titleMorph. - - (self hasProperty: #needsStayUpIcons) ifTrue: [ self addStayUpIcons ]! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 3/12/2018 15:53:30' prior: 50363328! - popUpAdjacentTo: rightOrLeftPointInWorld from: sourceItem - "Present this menu at the given point under control of the given hand. - Used mostly for submenus." - - | delta tryToPlace selectedOffset | - popUpOwner _ sourceItem. - selectedOffset _ (selectedItem ifNil: [ self items first ]) morphPosition. - sourceItem world addMorphFront: self. - - tryToPlace _ [ :where :mustFit | - self morphPosition: where - selectedOffset. - delta _ self morphFullBoundsInWorld - amountToTranslateWithin: sourceItem world morphBoundsInWorld. - (delta x = 0 | mustFit) ifTrue: [ - delta = `0@0` ifFalse: [ self morphPosition: self morphPosition + delta ]. - ^ self]]. - tryToPlace - value: rightOrLeftPointInWorld first value: false; - value: rightOrLeftPointInWorld last - (extent x @ 0) value: false; - value: rightOrLeftPointInWorld first value: true! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 3/12/2018 15:53:34' prior: 50363357! - popUpAt: aPoint forHand: hand allowKeyboard: aBoolean - "Present this menu at the given point under control of the given hand." - - | evt | - self items isEmpty ifTrue: [^self]. - Theme current decorateMenu: self. - (self submorphs select: [ :m | m is: #UpdatingMenuItemMorph ]) - do: [ :m | m updateContents]. - self runningWorld addMorphFront: self position: aPoint - `2 @ 8`. - self fitInWorld. - "Acquire focus for valid pop up behavior" - hand newMouseFocus: self. - aBoolean ifTrue: [ hand newKeyboardFocus: self ]. - evt _ hand lastMouseEvent. - (evt isKeyboard or: [ evt isMouse and: [ evt anyButtonPressed not ]]) - ifTrue: [ - "Select first item if button not down" - self moveSelectionDown: 1 event: evt ]! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 3/12/2018 15:53:37' prior: 50363382! - popUpAt: aPoint forHand: hand in: aWorld allowKeyboard: aBoolean - "Present this menu at the given point under control of the given hand." - - self items isEmpty ifTrue: [ ^self ]. - Theme current decorateMenu: self. - (self submorphs select: [ :m | m is: #UpdatingMenuItemMorph]) - do: [ :m | m updateContents]. - aWorld addMorphFront: self position: aPoint - `2 @ 8`. - self fitInWorld. - "Acquire focus for valid pop up behavior" - hand newMouseFocus: self. - aBoolean ifTrue: [ hand newKeyboardFocus: self ]! ! -!MenuMorph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:53:27' prior: 50363401! - initialize - super initialize. - extent _ `40@10`. - defaultTarget _ nil. - selectedItem _ nil. - stayUp _ false. - popUpOwner _ nil! ! -!MenuMorph methodsFor: 'keyboard control' stamp: 'jmv 3/12/2018 15:53:21' prior: 50363408! - displayFiltered: evt - | matchStr allItems isMatch matches feedbackMorph | - matchStr _ self valueOfProperty: #matchString. - allItems _ self submorphs select: [ :m | - m is: #MenuItemMorph ]. - matches _ allItems select: [ :m | - isMatch _ matchStr isEmpty or: [ - m contents - includesSubstring: matchStr - caseSensitive: false ]. - m isEnabled: isMatch. - isMatch ]. - feedbackMorph _ self valueOfProperty: #feedbackMorph. - feedbackMorph ifNil: [ - feedbackMorph _ StringMorph new color: Color veryDarkGray. - self addMorphBack: feedbackMorph lock position: `0@ -20`. - self - setProperty: #feedbackMorph - toValue: feedbackMorph ]. - feedbackMorph contents: '<' , matchStr , '>'. - matchStr isEmpty ifTrue: [ - feedbackMorph delete. - self removeProperty: #feedbackMorph ]. - matches notEmpty ifTrue: [ - self selectItem: matches first ]! ! -!MenuMorph methodsFor: 'private' stamp: 'jmv 3/12/2018 15:53:17' prior: 50363437! - adjustSubmorphsLayout - "Enlarge the width of submorphs as needed - so all of them are have the same width, and no less than #minWidth. - Also adjust their vertical position. - Finally, set our own extent." - - | w p h | - - submorphs isEmpty ifTrue: [ ^self ]. - w _ submorphs inject: 0 into: [ :prev :each | - prev max: each minItemWidth]. - - w _ w + 1. - p _ `5 @ 5`. - submorphs do: [ :m | - h _ m morphHeight. - m morphPosition: p extent: w@h. - p _ p + (0@(h + 1)) ]. - - self morphExtent: w+4 @ p y + 5! ! -!MenuMorph methodsFor: 'private' stamp: 'jmv 3/12/2018 15:53:24' prior: 50363456! - fitInWorld - "Note: items may not be laid out yet (I found them all to be at 0@0), - so we have to add up heights of items above the selected item." - - | delta | - "If it doesn't fit, show it to the left, not to the right of the hand." - self morphBoundsInWorld right > owner world morphBoundsInWorld right - ifTrue: [ - self morphPosition: ((self morphPosition x + 10 - extent x) @ self morphPosition y) ]. - - "Make sure that the menu fits in the world." - delta _ self morphBoundsInWorld amountToTranslateWithin: - (owner world morphBoundsInWorld withHeight: - ((owner world morphExtentInWorld y) max: (self morphPosition y) + 1)). - delta = `0 @ 0` ifFalse: [ self morphPosition: self morphPosition + delta ]! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:47:08' prior: 50363482! - downButtonPosition - ^ `0@0` + (extent - ScrollBar scrollbarThickness)! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:47:14' prior: 50363488! - drawOn: aCanvas - | rectangle w y0 h y1 y2 scrollbarThickness | - aCanvas frameAndFillRectangle: (`0@0` extent: extent) fillColor: self color borderWidth: borderWidth borderColor: borderColor. - y0 _ 1. - w _ extent x-2. - scrollbarThickness _ ScrollBar scrollbarThickness. - completer entryCount > self class itemsPerPage ifTrue: [ - w _ w - scrollbarThickness. - aCanvas - frameRectangle: (extent x - scrollbarThickness@0 - extent: scrollbarThickness @ extent y) - borderWidth: 1 - color: borderColor. - aCanvas - image: (BitBltCanvas arrowOfDirection: #up size: scrollbarThickness) - at: self upButtonPosition. - aCanvas - image: (BitBltCanvas arrowOfDirection: #down size: scrollbarThickness) - at: self downButtonPosition. - h _ extent y - (2 * scrollbarThickness). - y1 _ (1.0 * self firstVisible-1 / completer entryCount * h) ceiling + y0 + scrollbarThickness-1. - y2 _ (1.0 * self lastVisible / completer entryCount * h) floor + y0 + scrollbarThickness -1. - aCanvas - fillRectangle: (extent x - scrollbarThickness+2@y1 corner: extent x-2 @ y2) - color: Color veryLightGray ]. - self firstVisible - to: self lastVisible - do: [ :index | - rectangle _ 1@y0 extent: w@self class itemHeight. - index = self selected - ifTrue: [ - aCanvas fillRectangle: rectangle color: (Theme current listHighlightFocused: true) ]. - aCanvas - drawString: (completer entries at: index) asString - at: rectangle topLeft - font: self class listFont - color: Theme current text. - y0 _ y0 + self itemHeight ]! ! -!AutoCompleterMorph class methodsFor: 'instance creation' stamp: 'jmv 3/12/2018 15:47:19' prior: 50363539! - initializedInstance - | completer m | - completer _ SmalltalkCompleter withModel: (TextModel withText: 'Small'). - completer - instVarNamed: 'position' - put: 5. - completer computeEntries. - m _ AutoCompleterMorph - completer: completer - position: `200 @ 200`. - completer instVarNamed: 'menuMorph' put: m. - ^m! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:51:41' prior: 50363552! - drawOn: aCanvas - "Draw the hand itself (i.e., the cursor)." - "This method is only called when we are carrying morphs around..." - aCanvas - stencil: Cursor move - at: `0@0` - color: Color black! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:51:48' prior: 50363561! - savePatchFrom: aCanvas appendDamageTo: aStream - "Save the part of the given canvas under this hand as a Form and return its bounding rectangle." - - "Details: The previously used patch Form is recycled when possible to reduce the burden on storage management." - - | fullBounds | - fullBounds _ self morphFullBoundsInWorld. - fullBounds ifNil: [ ^self ]. - - fullBounds _ fullBounds intersect: (`0@0` extent: aCanvas extent). - (savedPatch isNil or: [savedPatch extent ~= fullBounds extent]) - ifTrue: [ - "allocate new patch form if needed" - savedPatch _ Form extent: fullBounds extent depth: aCanvas depth ]. - aCanvas - contentsOfArea: fullBounds - into: savedPatch. - savedPatch offset: fullBounds topLeft. - prevFullBounds - ifNil: [ aStream nextPut: fullBounds ] - ifNotNil: [ aStream nextPut: (fullBounds merge: prevFullBounds)]. - prevFullBounds _ fullBounds! ! -!HandMorph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:51:44' prior: 50363591! - initForEvents - mouseOverHandler _ nil. - lastMouseEvent _ MouseEvent new setType: #mouseMove position: `0@0` buttons: 0 hand: self. - lastMouseEventTime _ Time localMillisecondClock. - lastEventBuffer _ {1. 0. 0. 0. 0. 0. nil. nil}. - self dontWaitForMoreClicks! ! -!ImageMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:51:57' prior: 50363602! - drawOn: aCanvas - - aCanvas image: image at: `0@0`! ! -!StringMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:56:33' prior: 50363607! - drawOn: aCanvas - aCanvas - drawString: (contents ifNil: [ '' ]) - at: `0@0` - font: self fontToUse - color: color! ! -!StringMorph methodsFor: 'geometry' stamp: 'jmv 3/12/2018 15:56:36' prior: 50363614! - fitContents - "Measures contents later at #minimumExtent" - self morphExtent: `0@0`! ! -!IndentingListItemMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:52:00' prior: 50363620! - drawOn: aCanvas - - | tRect colorToUse sLeft aForm centeringOffset | - isHighlighted ifTrue: [ - aCanvas - fillRectangle: (`0@0` extent: extent) - color: (Theme current - listHighlightFocused: owner owner hasKeyboardFocus) duller ]. - isSelected ifTrue: [ - aCanvas - fillRectangle: (`0@0` extent: extent) - color: (Theme current - listHighlightFocused: owner owner hasKeyboardFocus) ]. - - tRect _ self toggleRectangle. - aForm _ isExpanded - ifTrue: [ container expandedForm ] - ifFalse: [ container notExpandedForm ]. - centeringOffset _ ((tRect height - aForm extent y) / 2.0) rounded. - - complexContents hasContents ifTrue: [ - aCanvas - image: aForm - at: (tRect topLeft translatedBy: 0 @ centeringOffset) ]. - - icon isNil - ifFalse: [ - aCanvas - image: icon - at: (tRect topLeft translatedBy: icon width @ centeringOffset). - sLeft _ indentLevel * 12 + 16 + (icon width + 2). - ] - ifTrue: [ - sLeft _ indentLevel * 12 + 16. - ]. - colorToUse _ complexContents preferredColor ifNil: [ color ]. - - aCanvas - drawString: contents asString - at: sLeft@0 - font: self fontToUse - color: colorToUse! ! -!MenuItemMorph methodsFor: 'accessing' stamp: 'jmv 3/12/2018 15:52:47' prior: 50363658! - contents: aString withMarkers: aBool inverse: inverse - "Set the menu item entry. If aBool is true, parse aString for embedded markers." - - | markerIndex marker | - self contentString: nil. "get rid of old" - aBool ifFalse: [^super contents: aString]. - self removeAllMorphs. "get rid of old markers if updating" - self hasIcon ifTrue: [ self icon: nil ]. - (aString notEmpty and: [aString first = $<]) - ifFalse: [^super contents: aString]. - markerIndex := aString indexOf: $>. - markerIndex = 0 ifTrue: [^super contents: aString]. - marker := (aString copyFrom: 1 to: markerIndex) asLowercase. - (#('' '' '' '') includes: marker) - ifFalse: [^super contents: aString]. - self contentString: aString. "remember actual string" - marker := (marker = '' or: [marker = '']) ~= inverse - ifTrue: [self onImage] - ifFalse: [self offImage]. - super contents: (aString copyFrom: markerIndex + 1 to: aString size). - "And set the marker" - marker := ImageMorph new image: marker. - self addMorphFront: marker position: `0@2`! ! -!MenuItemMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:52:51' prior: 50363694! - drawOn: aCanvas - | stringColor leftEdge | - - stringColor _ color. - isSelected & isEnabled - ifTrue: [ - aCanvas fillRectangle: (`0@0` extent: extent) color: Theme current menuHighlight]. - leftEdge _ 0. - - self hasMarker ifTrue: [ - leftEdge _ leftEdge + submorphs first morphWidth + 8 ]. - - self hasIcon - ifTrue: [| iconForm | - iconForm _ isEnabled ifTrue: [ self icon ] ifFalse: [ self icon asGrayScaleAndTransparent ]. - aCanvas image: iconForm at: leftEdge+1 @ (extent y - iconForm height // 2). - leftEdge _ leftEdge + iconForm width + self iconSeparation]. - - aCanvas - drawString: contents - at: leftEdge @ 1 - font: self fontToUse - color: stringColor. - subMenu ifNotNil: [ - aCanvas - image: self class subMenuMarker - at: extent x - 8 @ (extent y - self class subMenuMarker height // 2) ]! ! -!MenuItemMorph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:52:54' prior: 50363723! - initialize - "initialize the state of the receiver" - super initialize. - "" - extent _ `10@10`. - contents _ ''. - isEnabled _ true. - subMenu _ nil. - isSelected _ false. - target _ nil. - selector _ nil. - arguments _ nil. - font _ Preferences standardMenuFont! ! -!MenuItemMorph methodsFor: 'layout' stamp: 'jmv 3/12/2018 15:52:57' prior: 50363734! - measureContents - | e | - e _ super measureContents. - ^e y > 12 - ifTrue: [e+`2@2`] - ifFalse: [e+`2@1`]! ! -!MenuItemMorph methodsFor: 'selecting' stamp: 'jmv 3/12/2018 15:52:59' prior: 50363741! - select - self isSelected: true. - owner activeSubmenu: subMenu. - subMenu ifNotNil: [ - subMenu delete. - subMenu - popUpAdjacentTo: (Array with: self morphBoundsInWorld topRight + `10@0` - with: self morphBoundsInWorld topLeft) - from: self. - subMenu selectItem: nil ]! ! -!MenuItemMorph class methodsFor: 'cached state access' stamp: 'jmv 3/12/2018 15:53:02' prior: 50363754! - subMenuMarker - - | f | - SubMenuMarker ifNotNil: [ ^SubMenuMarker ]. - f _ Form - extent: `5@9` - fromArray: #(2147483648 3221225472 3758096384 4026531840 4160749568 4026531840 3758096384 3221225472 2147483648) - offset: `0@0`. - SubMenuMarker _ ColorForm mappingWhiteToTransparentFrom: f. - ^SubMenuMarker! ! -!LayoutAdjustingMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:52:28' prior: 50363767! - drawOn: aCanvas - - aCanvas - fillRectangle: (`0@0` extent: extent) - color: color! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 3/12/2018 15:52:31' prior: 50363773! - layoutBounds - "Return the bounds for laying out children of the receiver" - - ^`0@0` extent: extent! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 3/12/2018 15:52:35' prior: 50363779! - layoutSubmorphsHorizontallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - | xSep ySep usableWidth sumOfFixed normalizationFactor availableForPropWidth - fractionalWidths integerWidths theLeft usableHeight boundsTop boundsRight theTop minWidth submorphsToLayout - nextMorph ht wd ls theRight boundsBottom theBottom alternativeWidths count diff i | - - boundsForLayout extent > `2@2` "self minimumExtent" - ifFalse: [ ^self ]. "Too small. Don't bother!!" - - submorphsToLayout := self submorphsToLayout. - xSep := self xSeparation. - ySep := self ySeparation. - usableWidth := boundsForLayout width - ((submorphsToLayout size + 1) * xSep). - sumOfFixed := submorphsToLayout sum: [ :m | m layoutSpec fixedWidth ]. - availableForPropWidth := usableWidth - sumOfFixed max: 0. - normalizationFactor := self proportionalWidthNormalizationFactor. - availableForPropWidth := availableForPropWidth * normalizationFactor. - - fractionalWidths := submorphsToLayout collect: [ :m | m layoutSpec widthFor: availableForPropWidth ]. - "Compute integer widths, mostly rounding but with occasional #floor or #ceiling as needed to keep sum" - integerWidths _ fractionalWidths collect: [ :w | w rounded ]. - diff _ integerWidths sum - fractionalWidths sum rounded. - alternativeWidths _ diff > 0 ifTrue: [ fractionalWidths collect: [ :w | w floor ]] ifFalse: [ fractionalWidths collect: [ :w | w ceiling ]]. - count _ diff abs. - i _ 1. - [ count > 0] whileTrue: [ - (integerWidths at: i) = (alternativeWidths at: i) ifFalse: [ - integerWidths at: i put: (alternativeWidths at: i). - count _ count -1 ]. - i _ i + 1 ]. - minWidth := integerWidths sum. - theLeft := ((usableWidth - minWidth) * (padding ifNil: [0]) max: 0) + boundsForLayout left + xSep. - usableHeight := boundsForLayout height - (ySep * 2) max: 0. - boundsTop := boundsForLayout top + ySep. - boundsRight := boundsForLayout right - xSep. - boundsBottom := boundsForLayout bottom - ySep. - - submorphsToLayout size to: 1 by: -1 do: [ :index | - nextMorph := submorphsToLayout at: index. - "major direction" - wd := integerWidths at: index. - "minor direction" - ls := nextMorph layoutSpec. - ht := (ls heightFor: usableHeight) min: usableHeight. - theTop := ((usableHeight - ht) * ls minorDirectionPadding) floor + boundsTop. - theBottom := (theTop + ht) ceiling min: boundsBottom. - theRight := (theLeft + (wd min: minWidth)) "ceiling "min: boundsRight. - "Set bounds and adjust major direction for next step" - self flag: #jmvVer2. "should extent be set in m's coordinate system? what if its scale is not 1?" - ls usesMorphExtent - ifTrue: [ - nextMorph morphPosition: theLeft floor @ theTop floor ] - ifFalse: [ - nextMorph morphPosition: theLeft floor @ theTop floor extent: theRight - theLeft @ (theBottom - theTop) ]. - theLeft := theRight + xSep - ]! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 3/12/2018 15:52:39' prior: 50363870! - layoutSubmorphsVerticallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - | xSep ySep usableHeight sumOfFixed normalizationFactor availableForPropHeight - fractionalHeights integerHeights theTop usableWidth boundsLeft boundsBottom theLeft minHeight submorphsToLayout - nextMorph ht wd ls theBottom boundsRight theRight alternativeHeights count diff i | - - boundsForLayout extent > `2@2` "self minimumExtent" - ifFalse: [ ^self ]. "Too small. Don't bother!!" - - submorphsToLayout := self submorphsToLayout. - xSep := self xSeparation. - ySep := self ySeparation. - usableHeight := boundsForLayout height - ((submorphsToLayout size + 1) * ySep). - sumOfFixed := submorphsToLayout sum: [ :m | m layoutSpec fixedHeight ]. - availableForPropHeight := usableHeight - sumOfFixed max: 0. - normalizationFactor := self proportionalHeightNormalizationFactor. - availableForPropHeight := availableForPropHeight * normalizationFactor. - - fractionalHeights := submorphsToLayout collect: [ :m | m layoutSpec heightFor: availableForPropHeight ]. - "Compute integer widths, mostly rounding but with occasional #floor or #ceiling as needed to keep sum" - integerHeights _ fractionalHeights collect: [ :w | w rounded ]. - diff _ integerHeights sum - fractionalHeights sum rounded. - alternativeHeights _ diff > 0 ifTrue: [ fractionalHeights collect: [ :w | w floor ]] ifFalse: [ fractionalHeights collect: [ :w | w ceiling ]]. - count _ diff abs. - i _ 1. - [ count > 0] whileTrue: [ - (integerHeights at: i) = (alternativeHeights at: i) ifFalse: [ - integerHeights at: i put: (alternativeHeights at: i). - count _ count -1 ]. - i _ i + 1 ]. - minHeight := integerHeights sum. - theTop := ((usableHeight - minHeight) * (padding ifNil: [0]) max: 0) + boundsForLayout top + ySep. - usableWidth := boundsForLayout width - (xSep * 2) max: 0. - boundsLeft := boundsForLayout left + xSep. - boundsBottom := boundsForLayout bottom - ySep. - boundsRight := boundsForLayout right - xSep. - - submorphsToLayout size to: 1 by: -1 do: [ :index | - nextMorph := submorphsToLayout at: index. - "major direction" - ht := integerHeights at: index. - "minor direction" - ls := nextMorph layoutSpec. - wd := (ls widthFor: usableWidth) min: usableWidth. - theLeft := ((usableWidth - wd) * ls minorDirectionPadding) floor + boundsLeft. - theRight := (theLeft + wd) ceiling min: boundsRight. - theBottom := (theTop + (ht min: minHeight)) "ceiling" min: boundsBottom. - "Set bounds and adjust major direction for next step" - self flag: #jmvVer2. "should extent be set in m's coordinate system? what if its scale is not 1?" - ls usesMorphExtent - ifTrue: [ - nextMorph morphPosition: theLeft floor @ theTop floor ] - ifFalse: [ - nextMorph morphPosition: theLeft floor @ theTop floor extent: theRight - theLeft @ (theBottom - theTop) ]. - theTop := theBottom + ySep - ]! ! -!ProgressMorph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:55:38' prior: 50363963! - initialize - super initialize. - self separation: 0. - labelMorph _ StringMorph contents: '' font: AbstractFont default. - subLabelMorph _ StringMorph contents: '' font: AbstractFont default. - progress _ ProgressBarMorph new. - progress morphExtent: `200 @ 15`. - self addMorphFront: labelMorph. - self addMorphFront: subLabelMorph. - self addMorph: progress fixedHeight: 15! ! -!HaloHandleMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:51:24' prior: 50363978! - drawOn: aCanvas - - aCanvas - image: (self class circleForm: extent) - multipliedBy: color - at: `0@0`! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 3/12/2018 15:51:29' prior: 50363984! - addHandle: handleSpec - "Add a handle within the halo box as per the haloSpec, and set it up to respond to the given event by sending the given selector to the given recipient. Return the handle." - - | handle aPoint colorToUse form icon | - aPoint _ self - positionIn: haloBox - horizontalPlacement: handleSpec horizontalPlacement - verticalPlacement: handleSpec verticalPlacement. - colorToUse _ Color colorFrom: handleSpec color. - handle _ HaloHandleMorph new color: colorToUse. - self addMorph: handle. - handle morphBoundsInWorld: (Rectangle center: aPoint extent: self class handleSize asPoint). - handleSpec iconSymbol ifNotNil: [ :iconName | - form _ self class icons at: iconName ifAbsent: [self class perform: iconName]. - form ifNotNil: [ - icon _ ImageMorph new - image: form; - color: colorToUse makeForegroundColor; - lock. - handle addMorphFront: icon position: `0@0` ]]. - handle mouseUpSelector: #endInteraction. - handle setBalloonText: handleSpec hoverHelp. - ^ handle! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 3/12/2018 15:51:35' prior: 50364018! - basicBox - | aBox minSide anExtent w | - minSide _ 4 * self class handleSize. - anExtent _ ((extent x + self class handleSize + 8) max: minSide) @ - ((extent y + self class handleSize + 8) max: minSide). - aBox _ Rectangle center: self morphBoundsInWorld center extent: anExtent. - w _ self world ifNil: [ target world ]. - ^ w - ifNil: - [ aBox ] - ifNotNil: - [ aBox intersect: (w viewBox insetBy: `8@8`) ]! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 3/12/2018 15:51:38' prior: 50364034! - startGrow: evt with: growHandle - "Initialize resizing of my target. Launch a command representing it, to support Undo" - - | botRt | - evt hand obtainHalo: self. "Make sure the event's hand correlates with the receiver" - self removeAllHandlesBut: growHandle. "remove all other handles" - botRt _ target morphPositionInWorld + target morphExtentInWorld. - positionOffset _ (self world viewBox containsPoint: botRt) - ifTrue: [evt eventPosition - botRt] - ifFalse: [`0@0`]! ! -!InnerHierarchicalListMorph methodsFor: 'geometry' stamp: 'jmv 3/12/2018 15:52:04' prior: 50364052! - itemFromPoint: aPoint - "Return the list element (morph) at the given point or nil if outside" - | ptY last | - self hasSubmorphs ifFalse: [ ^nil ]. - (aPoint > `0@0` and: [ aPoint < extent ]) ifFalse: [ ^nil ]. - ptY _ aPoint y. - "note: following assumes that submorphs are vertical, non-overlapping, and ordered" - self firstSubmorph morphPosition y > ptY ifTrue: [ ^nil ]. - last _ self lastSubmorph. - last morphPosition y + last morphHeight < ptY ifTrue: [ ^nil ]. - "now use binary search" - ^self - findSubmorphBinary: [ :m | - (m morphPosition y <= ptY and: [ m morphPosition y + m morphHeight >= ptY ]) - ifTrue: [ 0 ] "found" - ifFalse: [ m morphPosition y + (m morphHeight // 2) > ptY ifTrue: [-1] ifFalse: [1]]]! ! -!InnerListMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:52:08' prior: 50364078! - drawBackgroundForMulti: row on: aCanvas - | selectionDrawBounds c | - "shade the background darker, if this row is selected" - selectionDrawBounds _ self drawBoundsForRow: row. - selectionDrawBounds _ selectionDrawBounds intersect: (`0@0` extent: extent). - c _ (selectedRow notNil and: [ row = selectedRow]) - ifTrue: [ Theme current listHighlightFocused: owner hasKeyboardFocus ] - ifFalse: [ Theme current listMultiHighlightFocused: owner hasKeyboardFocus ]. - aCanvas fillRectangle: selectionDrawBounds color: c! ! -!InnerListMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:52:11' prior: 50364097! - drawHighlightOn: aCanvas -"Ademas, poner el mouse pointer de relojito si tarda... Detectarlo automaticamente, etc. Aunque no estoy seguro de como hacerlo... quizas colgar un cachito de codigo en un proceso de mayor prioridad, onda 'si pasa 1 segundo, y todavia no te resetee este flag, entonces pone el relojito'" - | selectionDrawBounds | - highlightedRow ifNil: [ ^self ]. - highlightedRow = 0 ifTrue: [ ^self ]. - selectionDrawBounds _ self drawBoundsForRow: highlightedRow. - selectionDrawBounds _ selectionDrawBounds intersect: (`0@0` extent: extent). - aCanvas - fillRectangle: selectionDrawBounds - color: (Theme current listHighlightFocused: owner hasKeyboardFocus) duller! ! -!InnerListMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:52:14' prior: 50364121! - drawSelectionOn: aCanvas - | selectionDrawBounds | - selectedRow ifNil: [ ^self ]. - selectedRow = 0 ifTrue: [ ^self ]. - selectionDrawBounds _ self drawBoundsForRow: selectedRow. - selectionDrawBounds _ selectionDrawBounds intersect: (`0@0` extent: extent). - aCanvas - fillRectangle: selectionDrawBounds - color: (Theme current listHighlightFocused: owner hasKeyboardFocus)! ! -!InnerTextMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:52:17' prior: 50364136! - drawOn: aCanvas - "Draw the receiver on a canvas" - - false ifTrue: [ self debugDrawLineRectsOn: aCanvas ]. "show line rects for debugging" - - aCanvas - textComposition: self textComposition - bounds: (`0@0` extent: extent) - color: color - selectionColor: (Theme current textHighlightFocused: self hasKeyboardFocus)! ! -!ResizeMorph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:56:01' prior: 50364149! - initialize - super initialize. - extent _ `400@300`. - color _ Color white. - grid _ `8@6`. - gridLineWidth _ 2. - gridColor _ Color black. - selectionColor _ Color red! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:48:45' prior: 50364158! - createAcceptButton - "create the [accept] button" - | result | - result _ PluggableButtonMorph new - model: self; - color: Theme current acceptButton; - label: 'Accept'; - action: #acceptClicked. - result morphExtent: `6@2` * self sizeUnit. - self addMorph: result position: `2@7.5` * self sizeUnit // 1. - ^ result! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:48:48' prior: 50364171! -createCancelButton - "create the [cancel] button" - | result | - result _ PluggableButtonMorph new - model: self; - color: Theme current cancelButton; - label: 'Cancel'; - action: #cancelClicked. - result morphExtent: `6@2` * self sizeUnit. - self addMorph: result position: `12@7.5` * self sizeUnit // 1. - ^ result! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:48:51' prior: 50364185! - createQueryTextMorph: queryString - "create the queryTextMorph" - | result | - result _ StringMorph new contents: queryString. - result lock. - result morphExtent: `24@2` * self sizeUnit. - self addMorph: result position: `2@0.5` * self sizeUnit // 1. - ^ result! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:48:54' prior: 50364197! - createTextPaneAcceptOnCR: acceptBoolean - "create the textPane" - | result | - - self flag: #todo. "Integrate this method with the Theme system. --cbr" - - result _ TextModelMorph - textProvider: self - textGetter: #response - textSetter: #response: - selectionGetter: #selectionInterval. - result hasUnacceptedEdits: true. - result acceptOnCR: acceptBoolean. - result morphExtent: `18@5` * self sizeUnit. - self addMorph: result position: `1@2` * self sizeUnit. - ^ result! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:49:00' prior: 50364215! - initialize - - super initialize. - extent _ `20@10` * self sizeUnit. - responseUponCancel _ ''! ! -!FillInTheBlankMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:48:57' prior: 50364221! - drawOn: aCanvas - - Theme current roundWindowCorners - ifTrue: [ - aCanvas - roundRect: (`0@0` extent: extent) - color: color - radius: Theme current roundedWindowRadius ] - ifFalse: [ super drawOn: aCanvas ]! ! -!TranscriptMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:57:36' prior: 50364231! - drawOn: aCanvas - Transcript - showOnDisplay: true; - displayOn: form in: (`0@0` extent: extent). - aCanvas image: form at: `0@0`. - Transcript - bounds: self morphBoundsInWorld; - showOnDisplay: doImmediateUpdates. - self updateWorkspace! ! -!MenuLineMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 15:53:05' prior: 50364242! - drawOn: aCanvas - | baseColor | - baseColor _ owner color. - aCanvas - fillRectangle: (`0@0` corner: extent x @ (extent y / 2)) - color: baseColor twiceDarker. - - aCanvas - fillRectangle: (0 @ (extent y / 2) corner: extent) - color: baseColor twiceLighter! ! -!MenuLineMorph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 15:53:08' prior: 50364253! -initialize - super initialize. - extent _ `50 @ 2`! ! -!MenuLineMorph methodsFor: 'geometry' stamp: 'jmv 3/12/2018 15:53:10' prior: 50364258! - minimumExtent - - ^`10@2`! ! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 3/12/2018 15:57:46' prior: 50364262! - tryDeferredUpdatingAndSetCanvas - "If this platform supports deferred updates, then make my canvas be the Display (or a rectangular portion of it), set the Display to deferred update mode, and answer true. Otherwise, set a non-Disply canvas and answer false.." - | properDisplay | - - "As this is the only sender of #deferUpdates: , this could be done in Morphic or image startup, and never efterwards..." - (Display deferUpdates: true) ifNil: [ - "deferred updates not supported by the VM, do them in the image!!" - self ensureNonDisplayCanvas. - ^ false]. - - "if no canvas, or canvas was offscreen, from a platform that didnt support defers, then fix it" - properDisplay _ canvas notNil and: [canvas drawsOnDisplay]. - properDisplay ifFalse: [ - world morphPosition: `0@0` extent: Display extent. - self setCanvas: Display getCanvas. - ]. - ^ true! ! -!MorphicEvent methodsFor: 'dispatching' stamp: 'jmv 3/12/2018 15:54:16' prior: 50364292! - startDispatchFrom: aHand - "double dispatch the event dispatch" - "An event of an unknown type was sent. What shall we do?!!" - - Smalltalk beep. - self printString displayAt: `0@0`. - self wasHandled: true! ! -!MorphicCanvas methodsFor: 'accessing' stamp: 'jmv 3/12/2018 15:54:04' prior: 50364302! - newClipRect: aRectangleOrNil - "aRectangle is in world coordinates. - But ivar clipRect is relative to the form, - For example, if we had previously been built like - aCanvas on: someForm over: (100@100 extent 200@100) - then our origin would be -100 @ -100. - Then, a clipRect argument like (120@120 extent: 40@30) would mean affecting - only (20@20 extent: 40@30) in our form" - - self setClipRect: (aRectangleOrNil - ifNil: [ `0@0` corner: form extent ] - ifNotNil: [ aRectangleOrNil translatedBy: self canvasOrigin ])! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 3/12/2018 15:53:57' prior: 50364321! - drawCurrentAsError - "The morph (or one of its submorphs) had an error in its drawing method." - | r w | - r _ currentMorph morphLocalBounds. - w _ r extent > `50@50` - ifTrue: [ 6 ] - ifFalse: [ 2 ]. - self - frameAndFillRectangle: r - fillColor: Color red - borderWidth: w - borderColor: Color yellow. - self line: r topLeft to: r bottomRight-w width: w color: Color yellow. - self line: r topRight -(w@0) to: r bottomLeft -(0@w)width: w color: Color yellow! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/12/2018 15:54:00' prior: 50364339! - drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - aColor = Color black ifFalse: [ | topColor | - topColor _ aColor alphaMixed: 0.25 with: Color black. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint - font: fontOrNil - color: topColor ]. - aColor = Color white ifFalse: [ | bottomColor | - bottomColor _ aColor alphaMixed: 0.22 with: Color white. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + `0@2` - font: fontOrNil - color: bottomColor ]. - ^self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + `0@1` - font: fontOrNil - color: aColor! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/12/2018 15:54:10' prior: 50364366! - textComposition: aTextComposition bounds: boundsRect color: c selectionColor: sc - | displayScanner leftInRun line boundsInWorld tl | - - tl _ boundsRect topLeft. - boundsInWorld _ currentTransformation displayBoundsOfTransformOf: boundsRect. - - displayScanner _ MorphicScanner new - defaultFont: aTextComposition defaultFont; - text: aTextComposition textComposed - foreground: c. - displayScanner canvas: self. - - leftInRun _ 0. - "Take clipRect into account. Extrememly fast scrolls and redraws of huge files (like .sources)" - (aTextComposition lineIndexForPoint: (`0@0` max: (clipLeft@clipTop)- boundsInWorld origin)) - to: (aTextComposition lineIndexForPoint: (boundsInWorld extent min: (clipRight@clipBottom+1) - boundsInWorld origin)) - do: [ :i | - line _ aTextComposition lines at: i. - aTextComposition - displaySelectionInLine: line - on: self - textTopLeft: tl - selectionColor: sc. - leftInRun _ displayScanner displayLine: line textTopLeft: tl leftInRun: leftInRun ]! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 3/12/2018 15:54:13' prior: 50364401! - onForm: aForm - - ^ self basicNew - initializeWith: aForm origin: `0@0`! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 3/12/2018 15:47:31' prior: 50364406! - fillRectangle: aRectangle tilingWith: aForm sourceRect: patternBox rule: aCombinationRule - "aRectangle is in form coordinates, no transformation is done." - | displayRectangle additionalOffset clippedPort targetTopLeft clipOffset ex - targetBox savedMap top left | - - ex _ patternBox extent. - ex x = 0 ifTrue: [ ^self ]. - ex y = 0 ifTrue: [ ^self ]. - displayRectangle _ currentTransformation displayBoundsOfTransformOf: aRectangle. - - "this is a bit of a kludge to get the form to be aligned where I *think* it should be. - something better is needed, but not now" - - additionalOffset _ `0@0`. - clippedPort _ port clippedBy: displayRectangle. - targetTopLeft _ clippedPort clipRect topLeft truncateTo: ex. - clipOffset _ displayRectangle topLeft - targetTopLeft. - additionalOffset _ (clipOffset \\ ex) - ex. - - "do it iteratively" - targetBox _ clippedPort clipRect. - savedMap _ clippedPort colorMap. - clippedPort sourceForm: aForm; - fillColor: nil; - combinationRule: aCombinationRule; - sourceRect: patternBox; - colorMap: (aForm colormapIfNeededFor: clippedPort destForm). - top _ (targetBox top truncateTo: patternBox height) + additionalOffset y. - left _ (targetBox left truncateTo: patternBox width) + additionalOffset x. - - left to: (targetBox right - 1) by: patternBox width do: [:x | - top to: (targetBox bottom - 1) by: patternBox height do: [:y | - clippedPort destOrigin: x@y; copyBits]]. - clippedPort colorMap: savedMap! ! -!BitBltCanvas class methodsFor: 'cached forms' stamp: 'jmv 3/12/2018 15:47:38' prior: 50364454! - steButtonForm: extent - ^self cachedForms - at: { #steButton . extent } - ifAbsentPut: [ - | form canvas | - form _ Form extent: extent depth: 32. - canvas _ form getCanvas. - canvas - roundRect: (`0@0` extent: extent) - color: (Color gray: 0.4) - radius: 4. - canvas - roundRect: (`1@1` extent: extent-2) - color: Color white - radius: 4 - gradientTop: 1.0 - gradientCenter: 0.73 - gradientBottom: 0.94 - gradient1Height: (extent y-8+1 max: extent y//2). - form]! ! -!BitBltCanvas class methodsFor: 'cached arrow forms' stamp: 'jmv 3/12/2018 15:47:35' prior: 50364473! - buildArrowWith: insideForm borderForm: borderForm - | extent translucentForm color insideSpec borderSpec border background alpha| - " - Display getCanvas - image: (BitBltCanvas buildArrowWith: BitBltCanvas downInsideForm borderForm: BitBltCanvas downBorderForm) - at: 20@20 - Display getCanvas - image: (BitBltCanvas buildArrowWith:BitBltCanvas upInsideForm borderForm: BitBltCanvas upBorderForm) - at: 40@20 - " - extent _ insideForm extent - `1@2`. - translucentForm _ Form extent: insideForm extent depth: 32. - 0 to: extent x-1 do: [ :x | - 0 to: extent y-1 do: [ :y | - insideSpec _ insideForm colorAt: x@(y+1). - borderSpec _ borderForm colorAt: x@(y+1). - insideSpec = (Color r: 0.0 g: 0.0 b: 1.0) - ifTrue: [ color _ Color transparent ] - ifFalse: [ - borderSpec = (Color r: 1.0 g: 0.0 b: 0.0) - ifTrue: [ color _ insideSpec ] - ifFalse: [ - border _ x < (extent x//2) - ifTrue: [Color white] - ifFalse: [Color black]. - background _ borderForm colorAt: extent x@(y+1). - alpha _ borderSpec red asFloat - background red / (border red - background red). - color _ border alpha: (alpha min: 1 max: 0) ]]. - translucentForm colorAt: x@y put: color ]]. - ^translucentForm! ! -!TextComposition methodsFor: 'selection' stamp: 'jmv 3/12/2018 15:57:22' prior: 50364514! - defaultCharacterBlock - ^ CharacterBlock - stringIndex: 1 - text: model actualContents - topLeft: lines first topLeft - extent: `0 @ 0` - textLine: lines first! ! -!SHParserST80 methodsFor: 'character testing' stamp: 'jmv 3/12/2018 15:56:04' prior: 50334799! - isBinarySelectorCharacter: aCharacter - - aCharacter isValidInIdentifiers ifTrue: [^false]. - aCharacter isSeparator ifTrue: [^false]. - - ('"#$'':().;[]{}_`' includes: aCharacter) - ifTrue:[^false]. - aCharacter numericValue = Scanner doItCharacterValue ifTrue: [^false "the doIt char"]. - aCharacter numericValue = 0 ifTrue: [^false]. - "Any other char is ok as a binary selector char." - ^ true! ! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 3/12/2018 15:56:08' prior: 50373241! - parseBacktick - self enterBlock. - self scanPast: #backtick. - currentTokenFirst == $| ifTrue: [self parseBlockTemporaries]. - self parseStatementList. - self failUnless: currentTokenFirst == $`. - self scanPast: #backtick. - self leaveBlock! ! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 3/12/2018 15:56:12' prior: 50335054! - parseTerm - self failWhen: currentToken isNil. - currentTokenFirst == $( - ifTrue: [ - bracketDepth := bracketDepth + 1. - self scanPast: #leftParenthesis level: bracketDepth. - self parseExpression. - self failUnless: currentTokenFirst == $). - self scanPast: #rightParenthesis level: bracketDepth. - bracketDepth := bracketDepth - 1. - ^self ]. - currentTokenFirst == $[ ifTrue: [^self parseBlock]. - currentTokenFirst == $` ifTrue: [^self parseBacktick]. - currentTokenFirst == ${ - ifTrue: [ - self scanPast: #leftBrace. - self parseBraceArray. - ^self ]. - self isName ifTrue: [^self scanPast: (self resolve: currentToken)]. - self parseLiteral: false! ! -!DifferenceFinder methodsFor: 'private' stamp: 'jmv 3/12/2018 15:48:12' prior: 50364522! - maxLengthPoints - | max points | - max := self maxLength. - max = 0 ifTrue: [^Array with: `0 @ 0`]. - points := OrderedCollection new. - tally withIndexesDo: [:i :j :t | t = max ifTrue: [points add: i @ j]]. - ^ points! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3271-RefreshAllMethodsUsingBacktick-JuanVuletich-2018Mar12-15h44m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3271] on 12 March 2018 at 4:50:33 pm'! -!Color class methodsFor: 'instance creation' stamp: 'jmv 3/7/2018 10:37:22'! - jet: fraction - "Answer a suitable color for a HeatMap using the 'jet' color scheme. - See https://en.wikipedia.org/wiki/Heat_map - - Color showColors: ((0.0 to: 1.0 count: 100) collect: [ :f | Color jet: f ]) - " - - | hue | - hue _ Color blue hue interpolateTo: Color red hue at: fraction. - ^ Color h: hue s: 1 v: 1! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3272-jet-heatmap-colors-JuanVuletich-2018Mar12-16h48m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3272] on 12 March 2018 at 6:02:58 pm'! -!InputSensor methodsFor: 'keyboard' stamp: 'jmv 3/10/2018 22:22:45' prior: 50356632! - kbdTest - " - Sensor kbdTest - " - "This test routine will print the unmodified character, its keycode, - and the OR of all its modifier bits, until the character x is typed - -Also useful: - Sensor test - " - | char | - char _ nil. - [ char = $x ] whileFalse: [ - [ self keyboardPressed ] whileFalse. - char _ self keyboard. - Display fill: `5@5 extent: 400@20` fillColor: `Color white`. - (String streamContents: [ :s | - s - nextPut: $-; - nextPut: char; - nextPut: $-; - space; - print: char numericValue; - space. - self isMouseButton3Pressed ifTrue: [ s nextPutAll: ' mouseButton3/blue/tertiary/halo ' ]. - self isMouseButton2Pressed ifTrue: [ s nextPutAll: ' mouseButton2/yellow/secondary/menu ' ]. - self isMouseButton1Pressed ifTrue: [ s nextPutAll: ' mouseButton1/red/primary ' ]. - self shiftPressed ifTrue: [ s nextPutAll: ' shift ' ]. - self controlKeyPressed ifTrue: [ s nextPutAll: ' control/ctrl ' ]. - (self primMouseButtons anyMask: 32) ifTrue: [ s nextPutAll: ' macOption ' ]. - self commandAltKeyPressed ifTrue: [ s nextPutAll: ' macCommand/winAlt ' ]]) - displayAt: 10 @ 10 ].! ! -!String methodsFor: 'displaying' stamp: 'jmv 3/10/2018 21:32:34' prior: 50356670! - 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` - " - 'Display' displayOn: Display at: 10@10 - "! ! -!Color methodsFor: 'conversions' stamp: 'jmv 3/10/2018 21:25:40' prior: 50356682! - makeForegroundColor - "Make a foreground color contrasting with me" - ^self luminance >= 0.5 - ifTrue: [`Color black`] - ifFalse: [`Color white`]! ! -!Color methodsFor: 'transformations' stamp: 'jmv 3/10/2018 21:25:46' prior: 50356857! - muchDarker - - ^ self alphaMixed: 0.5 with: `Color black` -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 3/10/2018 22:17:55' prior: 50356862! - muchLighter - - ^ self alphaMixed: 0.233 with: `Color white`! ! -!Color methodsFor: 'transformations' stamp: 'jmv 3/10/2018 21:25:51' prior: 50356874! - quiteBlacker - - ^ self alphaMixed: 0.8 with: `Color black` -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 3/10/2018 22:18:15' prior: 50356879! - quiteWhiter - - ^ self alphaMixed: 0.6 with: `Color white`! ! -!Color methodsFor: 'transformations' stamp: 'jmv 3/10/2018 21:26:03' prior: 50356889! - veryMuchDarker - - ^ self alphaMixed: 0.25 with: `Color black`! ! -!Color methodsFor: 'transformations' stamp: 'jmv 3/10/2018 22:18:31' prior: 50356894! - veryMuchLighter - - ^ self alphaMixed: 0.07 with: `Color white`! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 3/10/2018 21:27:30' prior: 50356904! - colorFromPixelValue: p depth: d - "Convert a pixel value for the given display depth into a color." - "Details: For depths of 8 or less, the pixel value is simply looked up in a table. For greater depths, the color components are extracted and converted into a color." - "Warning: In BitBlt, a pixel with pixelValue = 0 is transparent. - Squeak usually assumes that r=g=b=0 => transparent. But this is false if we have alpha (opacity). - A color with r=g=b=0 and opacity = 255 is BLACK, not TRANSPARENT. - Squeak also answers darkest possible blue when asked for black. Again, this is not needed in 32 bits (with alpha). It is also not really needed for 16 bits as we have an extra, unused bit: 16r8000 is not zero, but rgb=0, and hence, black. - The real rule is that pixelValue=0 means transparent. - And that darkest blue must be used instead of black, but only for depths >8 and < 16 (no indexed colors, no alpha) - This method is updated to reflect that." - - | r g b alpha | - - d = 1 ifTrue: [^ self indexedColors at: (p bitAnd: 16r01) + 1]. - - "For the rest of the depths, pixelValue = 0 means transparent, and darkest blue is considered to be black." - p = 0 ifTrue: [ ^ `Color transparent` ]. - - d = 8 ifTrue: [^ self indexedColors at: (p bitAnd: 16rFF) + 1]. - d = 4 ifTrue: [^ self indexedColors at: (p bitAnd: 16r0F) + 1]. - d = 2 ifTrue: [^ self indexedColors at: (p bitAnd: 16r03) + 1]. - - d = 32 ifTrue: [ - "eight bits per component; 8 bits of alpha" - alpha _ p bitShift: -24. - alpha = 0 ifTrue: [ ^`Color transparent` ]. - r _ (p bitShift: -16) bitAnd: 16rFF. - g _ (p bitShift: -8) bitAnd: 16rFF. - b _ p bitAnd: 16rFF. - ^alpha < 255 - ifTrue: [ (Color r: r g: g b: b range: 255) alpha: alpha asFloat / 255.0 ] - ifFalse: [ Color r: r g: g b: b range: 255 ]]. - - d = 16 ifTrue: [ - "five bits per component. The most significant bit, unused, allows having real black, without p being zero" - r _ (p bitShift: -10) bitAnd: 16r1F. - g _ (p bitShift: -5) bitAnd: 16r1F. - b _ p bitAnd: 16r1F. - ^ Color r: r g: g b: b range: 31]. - - d = 15 ifTrue: [ - "five bits per component" - r _ (p bitShift: -10) bitAnd: 16r1F. - g _ (p bitShift: -5) bitAnd: 16r1F. - b _ p bitAnd: 16r1F. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^`Color black` ]. - ^ Color r: r g: g b: b range: 31]. - - d = 12 ifTrue: [ - "four bits per component" - r _ (p bitShift: -8) bitAnd: 16rF. - g _ (p bitShift: -4) bitAnd: 16rF. - b _ p bitAnd: 16rF. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^`Color black` ]. - ^ Color r: r g: g b: b range: 15]. - - d = 9 ifTrue: [ - "three bits per component" - r _ (p bitShift: -6) bitAnd: 16r7. - g _ (p bitShift: -3) bitAnd: 16r7. - b _ p bitAnd: 16r7. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^`Color black` ]. - ^ Color r: r g: g b: b range: 7]. - - self error: 'unknown pixel depth: ', d printString! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 3/10/2018 20:53:35' prior: 50354473! - fromArray: colorDef - - | answer | - colorDef size = 0 ifTrue: [^ `Color transparent` ]. - colorDef size between: 3 and: 4 :: ifFalse: [self error: 'Undefined color definition']. - answer _ self r: (colorDef at: 1) g: (colorDef at: 2) b: (colorDef at: 3). - ^colorDef size = 3 - ifTrue: [answer] - ifFalse: [answer alpha: (colorDef at: 4)]! ! -!Color class methodsFor: 'class initialization' stamp: 'jmv 3/10/2018 20:57:43' prior: 50356995! - initializeIndexedColors - "Build an array of colors corresponding to the fixed colormap used - for display depths of 1, 2, 4, or 8 bits." - "Color initializeIndexedColors" - - | a index grayVal | - a _ Array new: 256. - - "1-bit colors (monochrome)" - a at: 1 put: `Color r: 1.0 g: 1.0 b: 1.0`. "white or transparent" - a at: 2 put: `Color r: 0.0 g: 0.0 b: 0.0`. "black" - - "additional colors for 2-bit color" - a at: 3 put: `Color r: 1.0 g: 1.0 b: 1.0`. "opaque white" - a at: 4 put: `Color r: 0.5 g: 0.5 b: 0.5`. "1/2 gray" - - "additional colors for 4-bit color" - a at: 5 put: `Color r: 1.0 g: 0.0 b: 0.0`. "red" - a at: 6 put: `Color r: 0.0 g: 1.0 b: 0.0`. "green" - a at: 7 put: `Color r: 0.0 g: 0.0 b: 1.0`. "blue" - a at: 8 put: `Color r: 0.0 g: 1.0 b: 1.0`. "cyan" - a at: 9 put: `Color r: 1.0 g: 1.0 b: 0.0`. "yellow" - a at: 10 put: `Color r: 1.0 g: 0.0 b: 1.0`. "magenta" - - a at: 11 put: `Color r: 0.125 g: 0.125 b: 0.125`. "1/8 gray" - a at: 12 put: `Color r: 0.25 g: 0.25 b: 0.25`. "2/8 gray" - a at: 13 put: `Color r: 0.375 g: 0.375 b: 0.375`. "3/8 gray" - a at: 14 put: `Color r: 0.625 g: 0.625 b: 0.625`. "5/8 gray" - a at: 15 put: `Color r: 0.75 g: 0.75 b: 0.75`. "6/8 gray" - a at: 16 put: `Color r: 0.875 g: 0.875 b: 0.875`. "7/8 gray" - - "additional colors for 8-bit color" - "24 more shades of gray (1/32 increments but not repeating 1/8 increments)" - index _ 17. - 1 to: 31 do: [:v | - (v \\ 4) = 0 ifFalse: [ - grayVal _ v / 32.0. - a at: index put: (Color r: grayVal g: grayVal b: grayVal). - index _ index + 1]]. - - "The remainder of color table defines a color cube with six steps - for each primary color. Note that the corners of this cube repeat - previous colors, but this simplifies the mapping between RGB colors - and color map indices. This color cube spans indices 40 through 255 - (indices 41-256 in this 1-based array)." - 0 to: 5 do: [:r | - 0 to: 5 do: [:g | - 0 to: 5 do: [:b | - index _ 41 + ((36 * r) + (6 * b) + g). - index > 256 ifTrue: [ - self error: 'index out of range in color table compuation']. - a at: index put: (Color r: r g: g b: b range: 5)]]]. - - IndexedColors _ a. -! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 3/10/2018 22:18:42' prior: 50357180! - computeIndexedColorConvertingMap: targetColor from: sourceDepth to: destDepth - | map | - - map _ (self indexedColors copyFrom: 1 to: (1 bitShift: sourceDepth)) collect: [ :cc | | f c | - f _ 1.0 - (cc red + cc green + cc blue / 3.0 ). - c _ targetColor - ifNotNil: [ - destDepth = 32 - ifTrue: [ targetColor * f alpha: f] - ifFalse: [ targetColor alphaMixed: f*1.5 with: `Color white` ]] - ifNil: [ cc ]. - destDepth = 32 - ifTrue: [ c pixelValueForDepth: destDepth] - ifFalse: [ - f = 0.0 - ifTrue: [ 0 ] - ifFalse: [ c pixelValueForDepth: destDepth ]]]. - map _ map as: Bitmap. - ^map! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 3/10/2018 21:59:30' prior: 50357202! - computeRGBColorConvertingMap: targetColor to: destDepth keepSubPixelAA: keepSubPix - "Builds a colormap intended to convert from subpixelAA black values to targetColor values. - keepSubPix - ifTrue: [ Answer colors that also include subpixelAA ] - ifFalse: [ - Take fullpixel luminance level. Apply it to targetColor. - I.e. answer colors with NO subpixelAA ]" - - | mask map c bitsPerColor r g b f v | - - destDepth > 8 - ifTrue: [bitsPerColor _ 5] "retain maximum color resolution" - ifFalse: [bitsPerColor _ 4]. - "Usually a bit less is enough, but make it configurable" - bitsPerColor _ bitsPerColor min: Preferences aaFontsColormapDepth. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - r _ (i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask. - g _ (i bitShift: 0 - bitsPerColor) bitAnd: mask. - b _ (i bitShift: 0) bitAnd: mask. - f _ 1.0 - (r + g + b / 3.0 / mask). - c _ targetColor - ifNotNil: [ - (keepSubPix and: [destDepth > 8]) ifTrue: [ - Color - r: 1.0 - (r asFloat/mask) * targetColor red - g: 1.0 - (g asFloat/mask) * targetColor green - b: 1.0 - (b asFloat/mask) * targetColor blue - alpha: f * targetColor alpha "alpha will be ignored below, in #pixelValueForDepth: if destDepth ~= 32" ] - ifFalse: [ - destDepth = 32 - ifTrue: [ targetColor * f alpha: f * targetColor alpha ] - ifFalse: [ targetColor alphaMixed: f*1.5 with: `Color white` ]]] - ifNil: [ Color r: r g: g b: b range: mask]. "This is currently used only to keep some SubPixelAA on destDepth = 8, using a single pass of rule 25" - v _ destDepth = 32 - ifTrue: [ c pixelValueForDepth: destDepth] - ifFalse: [ - f < 0.1 - ifTrue: [ 0 ] - ifFalse: [ c pixelValueForDepth: destDepth ]]. - map at: i + 1 put: v ]. - ^ map! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 3/10/2018 22:09:19' prior: 50357262! - computeRGBColormapFor: destDepth bitsPerColor: bitsPerColor - "Compute a colorMap for translating from 16-bit or 32-bit RGB color to the given depth, using the given number of of bits per color component." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | mask map c | - (#(3 4 5) includes: bitsPerColor) - ifFalse: [self error: 'BitBlt only supports 3, 4, or 5 bits per color component']. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - c _ Color - r: ((i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask) - g: ((i bitShift: 0 - bitsPerColor) bitAnd: mask) - b: ((i bitShift: 0) bitAnd: mask) - range: mask. - map at: i + 1 put: (c pixelValueForDepth: destDepth)]. - - map at: 1 put: (`Color transparent` pixelWordForDepth: destDepth). "zero always transparent" - ^ map -! ! -!Color class methodsFor: 'color name lookup' stamp: 'jmv 3/10/2018 20:42:11' prior: 50357536! - traditionalColorNamesDictionary - "Answer a dictionary of Squeak traditional name->color associations.." - - | nameDict | - nameDict _ Dictionary new. - nameDict at: #black put: `Color r: 0 g: 0 b: 0`. - nameDict at: #veryVeryDarkGray put: `Color r: 0.125 g: 0.125 b: 0.125`. - nameDict at: #veryDarkGray put: `Color r: 0.25 g: 0.25 b: 0.25`. - nameDict at: #darkGray put: `Color r: 0.375 g: 0.375 b: 0.375`. - nameDict at: #gray put: `Color r: 0.5 g: 0.5 b: 0.5`. - nameDict at: #lightGray put: `Color r: 0.625 g: 0.625 b: 0.625`. - nameDict at: #veryLightGray put: `Color r: 0.75 g: 0.75 b: 0.75`. - nameDict at: #veryVeryLightGray put: `Color r: 0.875 g: 0.875 b: 0.875`. - nameDict at: #white put: `Color r: 1.0 g: 1.0 b: 1.0`. - nameDict at: #red put: `Color r: 1.0 g: 0 b: 0`. - nameDict at: #yellow put: `Color r: 1.0 g: 1.0 b: 0`. - nameDict at: #green put: `Color r: 0 g: 1.0 b: 0`. - nameDict at: #cyan put: `Color r: 0 g: 1.0 b: 1.0`. - nameDict at: #blue put: `Color r: 0 g: 0 b: 1.0`. - nameDict at: #magenta put: `Color r: 1.0 g: 0 b: 1.0`. - nameDict at: #brown put: `Color r: 0.6 g: 0.2 b: 0`. - nameDict at: #orange put: `Color r: 1.0 g: 0.6 b: 0`. - nameDict at: #lightRed put: `Color r: 1.0 g: 0.8 b: 0.8`. - nameDict at: #lightYellow put: `Color r: 1.0 g: 1.0 b: 0.8`. - nameDict at: #lightGreen put: `Color r: 0.8 g: 1.0 b: 0.6`. - nameDict at: #lightCyan put: `Color r: 0.4 g: 1.0 b: 1.0`. - nameDict at: #lightBlue put: `Color r: 0.8 g: 1.0 b: 1.0`. - nameDict at: #lightMagenta put: `Color r: 1.0 g: 0.8 b: 1.0`. - nameDict at: #lightBrown put: `Color r: 1.0 g: 0.6 b: 0.2`. - nameDict at: #lightOrange put: `Color r: 1.0 g: 0.8 b: 0.4`. - nameDict at: #transparent put: `TranslucentColor r: 0.0 g: 0.0 b: 0.0 alpha: 0.0`. - - ^nameDict -! ! -!Transcripter methodsFor: 'accessing' stamp: 'jmv 3/12/2018 17:57:31' prior: 50382830! - 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]. - textComposition - setModel: (TextModel withText: c asText); - extentForComposing: frame width-8 @9999. - textComposition composeAll. - d _ textComposition usedHeight - frame height. - d > 0 ifTrue: [ - "Scroll up to keep all contents visible" - cb _ textComposition characterBlockAtPoint: - `0@0` + (0@(d+AbstractFont default height)). - self on: (c copyFrom: cb stringIndex to: c size). - readLimit _ position _ collection size. - ^ self endEntry]. - Display fill: (frame insetBy: -2) fillColor: self black; - fill: frame fillColor: self white. - Display getCanvas - textComposition: textComposition - bounds: (`4@4` + frame topLeft extent: Display extent) - color: `Color black` - selectionColor: `Color blue`. - DisplayScreen screenUpdateRequired: nil! ! -!Transcripter methodsFor: 'private' stamp: 'jmv 3/10/2018 21:34:26' prior: 50357790! - black - Display depth = 1 ifTrue: [^ Bitmap with: 16rFFFFFFFF "Works without color support"]. - ^ `Color black`! ! -!Transcripter methodsFor: 'private' stamp: 'jmv 3/10/2018 22:23:58' prior: 50357796! - white - Display depth = 1 ifTrue: [^ Bitmap with: 0 "Works without color support"]. - ^ `Color white`! ! -!DataStream class methodsFor: 'as yet unclassified' stamp: 'jmv 3/10/2018 21:53:12' prior: 50357802! - example - "An example and test of DataStream/ReferenceStream. - 11/19/92 jhm: Use self testWith:." - "DataStream example" - "ReferenceStream example" - | input sharedPoint | - - "Construct the test data." - input _ Array new: 9. - input at: 1 put: nil. - input at: 2 put: true. - input at: 3 put: (Form extent: 63 @ 50 depth: 8). - (input at: 3) fillWithColor: `Color lightBlue`. - input at: 4 put: #(3 3.0 'three'). - input at: 5 put: false. - input at: 6 put: 1024 @ -2048. - input at: 7 put: #x. - input at: 8 put: (Array with: (sharedPoint _ 0 @ -30000)). - input at: 9 put: sharedPoint. - - "Write it out, read it back, and return it for inspection." - ^ self testWith: input! ! -!ReferenceStream class methodsFor: 'as yet unclassified' stamp: 'jmv 3/10/2018 21:54:43' prior: 50357828! - example2 -"Here is the way to use DataStream and ReferenceStream: - rr _ ReferenceStream fileNamed: ''test.obj''. - rr nextPut: . - rr close. - -To get it back: - rr _ ReferenceStream fileNamed: ''test.obj''. - _ rr next. - rr close. -" -"An example and test of DataStream/ReferenceStream. - 11/19/92 jhm: Use self testWith:." - "ReferenceStream example2" - | input sharedPoint | - - "Construct the test data." - input _ Array new: 9. - input at: 1 put: nil. - input at: 2 put: true. - input at: 3 put: false. - input at: 4 put: #(-4 -4.0 'four' four). - input at: 5 put: (Form extent: 63 @ 50 depth: 8). - (input at: 5) fillWithColor: `Color lightOrange`. - input at: 6 put: 1024 @ -2048. - input at: 7 put: input. "a cycle" - input at: 8 put: (Array with: (sharedPoint _ 0 @ -30000)). - input at: 9 put: sharedPoint. - - "Write it out, read it back, and return it for inspection." - ^ self testWith: input -! ! -!TextAction class methodsFor: 'as yet unclassified' stamp: 'jmv 3/10/2018 20:58:51' prior: 50357887! - textActionColor - ^ `Color r: 0.4 g: 0 b: 1.0`! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:33:13' prior: 50370186! - black - ^ self new color: `Color black`! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:41:12' prior: 50370190! - blue - ^ self new color: `Color blue`! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:41:25' prior: 50370194! - cyan - ^ self new color: `Color cyan`! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:41:30' prior: 50370198! - gray - ^ self new color: `Color gray`! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:41:34' prior: 50370202! - green - ^ self new color: `Color green`! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:41:39' prior: 50370206! - magenta - ^ self new color: `Color magenta`! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:42:40' prior: 50370210! - red - ^ self new color: `Color red`! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:42:46' prior: 50370214! - white - ^ self new color: `Color white`! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:42:50' prior: 50370218! - yellow - ^ self new color: `Color yellow`! ! -!TextColor methodsFor: 'testing' stamp: 'jmv 3/10/2018 21:33:19' prior: 50357891! - isSet - "Do not include Color black, as it is the default color." - ^color ~= `Color black`! ! -!TextColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:33:25' prior: 50357896! - black - ^ self new color: `Color black`! ! -!TextColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:38:56' prior: 50357900! - blue - ^ self new color: `Color blue`! ! -!TextColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:39:20' prior: 50357904! - cyan - ^ self new color: `Color cyan`! ! -!TextColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:39:25' prior: 50357908! - gray - ^ self new color: `Color gray`! ! -!TextColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:39:29' prior: 50357912! - green - ^ self new color: `Color green`! ! -!TextColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:39:33' prior: 50357916! - magenta - ^ self new color: `Color magenta`! ! -!TextColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:39:38' prior: 50357920! - red - ^ self new color: `Color red`! ! -!TextColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:39:45' prior: 50357924! -white - ^ self new color: `Color white`! ! -!TextColor class methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:39:51' prior: 50357928! - yellow - ^ self new color: `Color yellow`! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 3/10/2018 22:15:21' prior: 50381660! - displayOn: aForm in: aRectangle - " - Transcript displayOn: Display - " - | font count i string x y fh f canvas innerR | - aForm fill: aRectangle fillColor: `Color white`. - font _ AbstractFont default. - - innerR _ aRectangle insetBy: self padding. - fh _ font height. - count _ innerR height // fh. - x _ innerR left. - y _ innerR top. - f _ firstIndex-1. - firstIndex > lastIndex ifTrue: [ f _ f - self maxEntries ]. - i _ (lastIndex - count max: f) \\ self maxEntries + 1. - canvas _ aForm getCanvas. - canvas newClipRect: innerR. - [ i <= lastIndex ] whileTrue: [ - string _ entries at: i. - canvas drawString: string at: x@y font: font color: `Color veryDarkGray`. - y _ y + fh. - i _ i \\ self maxEntries + 1 ]. - - string _ unfinishedEntry contents. - canvas drawString: string at: x@y font: font color: `Color veryDarkGray`! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 3/10/2018 22:15:54' prior: 50357977! - displayUnfinishedEntryOn: aForm - - | font count string x y fh canvas r innerR | - innerR _ bounds insetBy: self padding. - lastDisplayPosition < innerR right ifTrue: [ - font _ AbstractFont default. - fh _ font height. - count _ innerR height // fh-1. - x _ innerR left. - string _ unfinishedEntry contents. - y _ ((lastIndex - firstIndex \\ self maxEntries) min: count-1) + 1 * font height + innerR top. - canvas _ aForm getCanvas. - r _ innerR left: lastDisplayPosition. - canvas newClipRect: r. - (canvas drawString: string at: x@y font: font color: `Color veryDarkGray`) ifNotNil: [ :lastPoint | - lastDisplayPosition _ lastPoint x. - ^r ]]. - ^nil! ! -!Form methodsFor: 'bordering' stamp: 'jmv 3/10/2018 21:28:34' prior: 50358012! - border: aRectangle width: borderWidth - "Paint a border whose rectangular area is defined by aRectangle. The - width of the border of each side is borderWidth. Uses black for - drawing the border." - - self border: aRectangle width: borderWidth fillColor: `Color black`! ! -!Form methodsFor: 'coloring' stamp: 'jmv 3/10/2018 21:28:39' prior: 50358023! - fillBlack - "Set all bits in the receiver to black (ones)." - - self fill: self boundingBox fillColor: `Color black`! ! -!Form methodsFor: 'coloring' stamp: 'jmv 3/10/2018 21:28:44' prior: 50358029! - fillBlack: aRectangle - "Set all bits in the receiver's area defined by aRectangle to black (ones)." - - self fill: aRectangle rule: Form over fillColor: `Color black`! ! -!Form methodsFor: 'coloring' stamp: 'jmv 3/10/2018 21:45:56' prior: 50358037! - fillGray - "Set all bits in the receiver to gray." - - self fill: self boundingBox fillColor: `Color gray`! ! -!Form methodsFor: 'coloring' stamp: 'jmv 3/10/2018 21:46:03' prior: 50358043! - fillGray: aRectangle - "Set all bits in the receiver's area defined by aRectangle to the gray mask." - - self fill: aRectangle rule: Form over fillColor: `Color gray`! ! -!Form methodsFor: 'coloring' stamp: 'jmv 3/10/2018 22:18:53' prior: 50358051! - fillWhite - "Set all bits in the form to white." - - self fill: self boundingBox fillColor: `Color white`! ! -!Form methodsFor: 'coloring' stamp: 'jmv 3/10/2018 22:19:16' prior: 50358057! - fillWhite: aRectangle - "Set all bits in the receiver's area defined by aRectangle to white." - - self fill: aRectangle rule: Form over fillColor: `Color white`! ! -!Form methodsFor: 'coloring' stamp: 'jmv 3/10/2018 22:19:25' prior: 50358065! - reverse - "Change all the bits in the receiver that are white to black, and the ones - that are black to white. - Display reverse - " - - self fill: self boundingBox rule: Form reverse fillColor: `Color white`! ! -!Form methodsFor: 'coloring' stamp: 'jmv 3/10/2018 22:19:31' prior: 50358074! - reverse: aRectangle - "Change all the bits in the receiver's area that intersects with aRectangle - that are white to black, and the ones that are black to white." - - self fill: aRectangle rule: Form reverse fillColor: `Color white`! ! -!Form methodsFor: 'converting' stamp: 'jmv 3/10/2018 22:10:25' prior: 50358151! - as8BitColorForm - "Simple conversion of zero pixels to transparent. Force it to 8 bits." - - | f map | - f _ ColorForm extent: self extent depth: 8. - self displayOn: f at: self offset negated. - map _ Color indexedColors copy. - map at: 1 put: `Color transparent`. - f colors: map. - f offset: self offset. - ^ f -! ! -!Form methodsFor: 'pixel access' stamp: 'jmv 3/10/2018 22:11:31' prior: 50358172! - colorInterpolatedAt: aPoint - "Evaluate a bilinear (i.e. cheap) interpolation - Like OpenCV's CV_INTER_LINEAR - Answer Color transparent if outside image bounds. - Copied almost verbatim from FloatImage. - Answer Colors with float components. Will be rounded to be stored in, for example, a 32-bit Form." - - | x y w interpolated xWeight1 xWeight0 yWeight1 yWeight0 xIndex0 xIndex1 yIndex0 yIndex1 | - x _ aPoint x. - y _ aPoint y. - x < 0.0 ifTrue: [ ^ `Color transparent` ]. - xIndex0 _ x truncated. "Could be #floor. But as we only care for values >=0, it is the same. But faster." - xIndex0 > (width-1) ifTrue: [ ^ `Color transparent` ]. - (xIndex0 = (width-1) and: [ x > (width-1) ]) ifTrue: [ ^ `Color transparent` ]. - xIndex1 _ xIndex0 = (width-1) "Avoid the invalid access if this was true, but don't make it slower the most common, general case." - ifFalse: [ xIndex0 + 1 ] - ifTrue: [ xIndex0 ]. - - y < 0.0 ifTrue: [ ^ `Color transparent` ]. - yIndex0 _ y truncated. "Could be #floor. But as we only care for values >=0, it is the same. But faster." - yIndex0 > (height-1) ifTrue: [ ^ `Color transparent` ]. - (yIndex0 = (height-1) and: [ y > (height-1) ]) ifTrue: [ ^ `Color transparent` ]. - yIndex1 _ yIndex0 = (height-1) "Avoid the invalid access if this was true, but don't make it slower the most common, general case." - ifFalse: [ yIndex0 + 1 ] - ifTrue: [ yIndex0 ]. - - xWeight1 _ x - xIndex0. - xWeight0 _ 1.0 - xWeight1. - - yWeight1 _ y - yIndex0. - yWeight0 _ 1.0 - yWeight1. - - "/* perform interpolation */" - w _ ((self colorAt: xIndex0 @ yIndex0) * xWeight0) + - ((self colorAt: xIndex1 @ yIndex0) * xWeight1). - interpolated _ w * yWeight0. - - w _ ((self colorAt: xIndex0 @ yIndex1) * xWeight0) + - ((self colorAt: xIndex1 @ yIndex1) * xWeight1). - interpolated _ w * yWeight1 + interpolated. - - ^interpolated! ! -!Form methodsFor: 'transitions' stamp: 'jmv 3/12/2018 17:58:14' prior: 50383720! - pageWarp: otherImage at: topLeft forward: forward - "Produce a page-turning illusion that gradually reveals otherImage - located at topLeft in this form. - forward == true means turn pages toward you, else away. [ignored for now]" - | pageRect oldPage nSteps buffer p leafRect sourceQuad warp oldBottom d | - pageRect _ otherImage boundingBox. - oldPage _ self copy: (pageRect translatedBy: topLeft). - (forward ifTrue: [oldPage] ifFalse: [otherImage]) - border: pageRect - widthRectangle: (Rectangle - left: 0 - right: 2 - top: 1 - bottom: 1) - rule: Form over - fillColor: `Color black`. - oldBottom _ self copy: ((pageRect bottomLeft + topLeft) extent: (pageRect width@(pageRect height//4))). - nSteps _ 8. - buffer _ Form extent: otherImage extent + (0@(pageRect height//4)) depth: self depth. - d _ pageRect topLeft + (0@(pageRect height//4)) - pageRect topRight. - 1 to: nSteps-1 do: - [:i | forward - ifTrue: [buffer copy: pageRect from: otherImage to: `0@0` rule: Form over. - p _ pageRect topRight + (d * i // nSteps)] - ifFalse: [buffer copy: pageRect from: oldPage to: `0@0` rule: Form over. - p _ pageRect topRight + (d * (nSteps-i) // nSteps)]. - buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over. - leafRect _ pageRect topLeft corner: p x @ (pageRect bottom + p y). - sourceQuad _ Array with: pageRect topLeft - with: pageRect bottomLeft + (0@p y) - with: pageRect bottomRight - with: pageRect topRight - (0@p y). - warp _ (WarpBlt toForm: buffer) - clipRect: leafRect; - sourceForm: (forward ifTrue: [oldPage] ifFalse: [otherImage]); - combinationRule: Form paint. - warp copyQuad: sourceQuad toRect: leafRect. - self copy: buffer boundingBox from: buffer to: topLeft rule: Form over. - Display forceToScreen. - ]. - - buffer copy: pageRect from: otherImage to: `0@0` rule: Form over. - buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over. - self copy: buffer boundingBox from: buffer to: topLeft rule: Form over. - Display forceToScreen. -" -1 to: 4 do: [:corner | Display pageWarp: - (Form fromDisplay: (10@10 extent: 200@300)) reverse - at: 10@10 forward: false] -"! ! -!Form class methodsFor: 'instance creation' stamp: 'jmv 3/12/2018 17:58:22' prior: 50383838! - dotOfSize: diameter - "Create a form which contains a round black dot." - | radius form bb rect centerX centerY centerYBias centerXBias radiusSquared xOverY maxy dx | - radius _ diameter//2. - form _ self extent: diameter@diameter offset: `0@0` - radius. - bb _ (BitBlt toForm: form) - sourceX: 0; sourceY: 0; - combinationRule: Form over; - fillColor: `Color black`. - rect _ form boundingBox. - centerX _ rect center x. - centerY _ rect center y. - centerYBias _ rect height odd ifTrue: [0] ifFalse: [1]. - centerXBias _ rect width odd ifTrue: [0] ifFalse: [1]. - radiusSquared _ (rect height asFloat / 2.0) squared - 0.01. - xOverY _ rect width asFloat / rect height asFloat. - maxy _ rect height - 1 // 2. - - "First do the inner fill, and collect x values" - 0 to: maxy do: [ :dy | - dx _ ((radiusSquared - (dy * dy) asFloat) sqrt * xOverY) truncated. - bb destX: centerX - centerXBias - dx - destY: centerY - centerYBias - dy - width: dx + dx + centerXBias + 1 - height: 1; - copyBits. - bb destY: centerY + dy; - copyBits]. - ^ form -" -Time millisecondsToRun: - [1 to: 20 do: [:i | (Form dotOfSize: i) displayAt: (i*20)@(i*20)]] -"! ! -!Form class methodsFor: 'instance creation' stamp: 'jmv 3/10/2018 22:20:49' prior: 50358341! - fakeSphereAt: aPoint diameter: diameter color: aColor - "Create a form which contains a round black dot." - | bb rect d p | - bb _ GrafPort toForm: Display. - bb fillColor: aColor. - bb combinationRule: Form blend. - rect _ aPoint extent: diameter. - bb fillOval: rect. - p _ (diameter * 2 // 5) asPoint + aPoint. - #(2 3 4 5 6 ) do: [ :i | - "simulate facade by circles of gray" - bb fillColor: `Color white alpha: 0.3`. - d _ i * diameter // 10. - rect _ Rectangle - center: p - extent: d. - bb fillOval: rect ]. - DisplayScreen screenUpdateRequired: nil. -" - Form fakeSphereAt: 50@50 diameter: 30 color: (Color red alpha: 0.5) -"! ! -!Form class methodsFor: 'examples' stamp: 'jmv 3/12/2018 17:58:38' prior: 50383876! - toothpaste: diam - " - Display restoreAfter: [Form toothpaste: 30] - " - "Not completely unlike the ST-80 implementation :) - Original comment: - Draws wormlike lines by laying down images of spheres. - See Ken Knowlton, Computer Graphics, vol. 15 no. 4 p352. - Draw with mouse button down; terminate by option-click." - | point queue color q colors colr colr2 | - colors _ `Color red wheel: 12`. - color _ 8. - [ true ] whileTrue: [ - queue _ OrderedCollection new: 32. - 16 timesRepeat: [queue addLast: `-40@-40`]. - Sensor waitButton. - Sensor isMouseButton2Pressed ifTrue: [^ self]. - point _ Sensor mousePoint. - colr _ colors atWrap: (color _ color + 5). "choose increment relatively prime to colors size" - colr2 _ colr alpha: 0.3. - [Sensor isMouseButton1Pressed or: [queue size > 0]] whileTrue: [ - point _ point * 4 + Sensor mousePoint // 5. - point _ point. - Form fakeSphereAt: point diameter: diam color: colr. - (q _ queue removeFirst) ifNil: [^ self]. "exit" - Form fakeSphereAt: q diameter: diam color: colr2. - Sensor isMouseButton1Pressed ifTrue: [queue addLast: point]]]! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 3/10/2018 22:19:44' prior: 50358401! - bottomLeftCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - "Create and answer a Form for the bottomLeft corner of a rounded rectangle" - | f aaw topColor bottomColor l d c width dy | - topColor _ `Color white` * gradientTopFactor. - bottomColor _ `Color white` * gradientBottomFactor. - width _ r. - aaw _ 1.3. - f _ Form - extent: width @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: width - 1 - do: [ :x | - dy _ height - r - y. - dy > 0 - ifTrue: [ l _ 1.0 ] - ifFalse: [ - d _ (width - 1 - x @ dy) r. - l _ ((r - d max: 0.0) min: aaw) / aaw ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 3/10/2018 22:19:58' prior: 50358428! - bottomLeftCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor borderWidth: bw - "Create and answer a Form for the bottomLeft corner of a rounded rectangle" - | f aaw topColor bottomColor l d c width dy l1 l2 | - topColor _ `Color white` * gradientTopFactor. - bottomColor _ `Color white` * gradientBottomFactor. - width _ r. - aaw _ 1.3. - f _ Form - extent: width @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: width - 1 - do: [ :x | - dy _ height - r - y. - dy > 0 - ifTrue: [ l _ 1.0 ] - ifFalse: [ - d _ (width - 1 - x @ dy) r. - l1 _ ((r - d-1+aaw max: 0.0) min: aaw) / aaw. - l2 _ ((d - r+bw+aaw max: 0.0) min: aaw) / aaw. - l _ l1 min: l2. - ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 3/10/2018 22:20:11' prior: 50358459! - bottomRightCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - "Create and answer a Form for the bottomRight corner of a rounded rectangle" - | f aaw topColor bottomColor l d c width dy | - topColor _ `Color white` * gradientTopFactor. - bottomColor _ `Color white` * gradientBottomFactor. - width _ r. - aaw _ 1.3. - f _ Form - extent: width @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: width - 1 - do: [ :x | - dy _ height - r - y. - dy > 0 - ifTrue: [ l _ 1.0 ] - ifFalse: [ - d _ (x @ dy) r. - l _ ((r - d max: 0.0) min: aaw) / aaw ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 3/10/2018 22:20:37' prior: 50358486! - bottomRightCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor borderWidth: bw - "Create and answer a Form for the bottomLeft corner of a rounded rectangle" - | f aaw topColor bottomColor l d c width dy l1 l2 | - topColor _ `Color white` * gradientTopFactor. - bottomColor _ `Color white` * gradientBottomFactor. - width _ r. - aaw _ 1.3. - f _ Form - extent: width @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: width - 1 - do: [ :x | - dy _ height - r - y. - dy > 0 - ifTrue: [ l _ 1.0 ] - ifFalse: [ - d _ (x @ dy) r. - l1 _ ((r - d-1+aaw max: 0.0) min: aaw) / aaw. - l2 _ ((d - r+bw+aaw max: 0.0) min: aaw) / aaw. - l _ l1 min: l2. - ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 3/10/2018 22:21:11' prior: 50358517! - topLeftCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - "Create and answer a Form with a vertical gray gradient as specified for the topLeft corner of a rounded rectangle" - | f bw topColor bottomColor l d c w | - topColor _ `Color white` * gradientTopFactor. - bottomColor _ `Color white` * gradientBottomFactor. - w _ r. - bw _ 1.3. - f _ Form - extent: w @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: w - 1 - do: [ :x | - l _ 1.0. - y < r ifTrue: [ - d _ (w - 1 - x @ (w - 1 - y)) r. - l _ ((r - d max: 0.0) min: bw) / bw ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 3/10/2018 22:21:32' prior: 50358544! - topRightCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - "Create and answer a Form with a vertical gray gradient as specified for the topRight corner of a rounded rectangle" - | f bw topColor bottomColor l d c w | - topColor _ `Color white` * gradientTopFactor. - bottomColor _ `Color white` * gradientBottomFactor. - w _ r. - bw _ 1.3. - f _ Form - extent: w @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: w - 1 - do: [ :x | - l _ 1.0. - y < r ifTrue: [ - d _ (x @ (w - y - 1)) r. - l _ ((r - d max: 0.0) min: bw) / bw ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!ColorForm methodsFor: 'accessing' stamp: 'jmv 3/10/2018 22:09:40' prior: 50358570! - colors: colorList - "Set my color palette to the given collection." - - | colorArray colorCount newColors | - colorList ifNil: [ - colors _ cachedDepth _ cachedColormap _ nil. - ^ self]. - - colorArray _ colorList asArray. - colorCount _ colorArray size. - newColors _ Array new: (1 bitShift: self depth). - 1 to: newColors size do: [:i | - i <= colorCount - ifTrue: [newColors at: i put: (colorArray at: i)] - ifFalse: [newColors at: i put: `Color transparent` ]]. - - colors _ newColors. - cachedDepth _ nil. - cachedColormap _ nil. -! ! -!ColorForm class methodsFor: 'as yet unclassified' stamp: 'jmv 3/12/2018 17:58:56' prior: 50383943! - mappingWhiteToTransparentFrom: aFormOrCursor - "Return a ColorForm copied from the given Form or Cursor with white mapped to transparent." - - | f map | - aFormOrCursor depth <= 8 ifFalse: [ - ^ self error: 'argument depth must be 8-bits per pixel or less']. - (aFormOrCursor is: #ColorForm) ifTrue: [ - f _ aFormOrCursor copy. - map _ aFormOrCursor colors. - ] ifFalse: [ - f _ ColorForm extent: aFormOrCursor extent depth: aFormOrCursor depth. - f copyBits: aFormOrCursor boundingBox - from: aFormOrCursor - at: `0@0` - clippingBox: aFormOrCursor boundingBox - rule: Form over. - map _ Color indexedColors copyFrom: 1 to: (1 bitShift: aFormOrCursor depth)]. - map _ map collect: [:c | - c = `Color white` ifTrue: [`Color transparent`] ifFalse: [c]]. - f colors: map. - ^ f! ! -!ColorForm class methodsFor: 'instance creation' stamp: 'jmv 3/10/2018 22:09:53' prior: 50358658! - grayScaleAndTransparentExtent: aPoint -"Native depth" - "Answer a ColorForm for storing 8bpp gray scale. (do not include any slot for transparent)" - - | grays result | - result _ self extent: aPoint depth: (Smalltalk isLittleEndian ifTrue: [ -8 ] ifFalse: [ 8 ]). - grays _ (0 to: 255) collect: [ :brightness | Color gray: brightness asFloat / 255.0]. - grays at: 1 put: `Color transparent`. - result colors: grays. - ^result! ! -!Cursor methodsFor: 'converting' stamp: 'jmv 3/10/2018 21:28:10' prior: 50358674! - asCursorForm - | form | - form _ Form extent: self extent depth: 8. - form fillShape: self fillColor: `Color black` at: offset negated. - ^ form offset: offset! ! -!CursorWithMask methodsFor: 'converting' stamp: 'jmv 3/10/2018 21:28:27' prior: 50358682! - asCursorForm - | form | - form _ Form extent: self extent depth: 8. - form fillShape: maskForm fillColor: `Color white`. - form fillShape: self fillColor: `Color black` at: offset negated. - ^ form offset: offset! ! -!BMPReadWriter methodsFor: 'reading' stamp: 'jmv 3/10/2018 22:17:39' prior: 50358708! - readColorMap - "Read colorCount BMP color map entries from the given binary stream. Answer an array of Colors." - | colorCount colors maxLevel b g r ccStream | - colorCount := (bfOffBits - 54) // 4. - "Note: some programs (e.g. Photoshop 4.0) apparently do not set colorCount; assume that any data between the end of the header and the start of the pixel data is the color map" - biBitCount >= 16 ifTrue:[^nil]. - colorCount = 0 ifTrue: [ "this BMP file does not have a color map" - "default monochrome color map" - biBitCount = 1 ifTrue: [^ `Array with: Color white with: Color black`]. - "default gray-scale color map" - maxLevel := (2 raisedTo: biBitCount) - 1. - ^ (0 to: maxLevel) collect: [:level | Color gray: (level asFloat / maxLevel)]]. - ccStream := ReadStream on: (stream next: colorCount*4). - colors := Array new: colorCount. - 1 to: colorCount do: [:i | - b := ccStream next. - g := ccStream next. - r := ccStream next. - ccStream next. "skip reserved" - colors at: i put: (Color r: r g: g b: b range: 255)]. - ^ colors -! ! -!BitBlt methodsFor: 'accessing' stamp: 'jmv 3/10/2018 21:25:25' prior: 50358743! - fillColor - "Return the current fill color as a Color. - Gives the wrong answer if the halftoneForm is a complex pattern of more than one word." - - halftoneForm ifNil: [^ `Color black` ]. - ^ Color colorFromPixelValue: halftoneForm first depth: destForm depth! ! -!GrafPort methodsFor: 'private' stamp: 'jmv 3/10/2018 22:12:11' prior: 50358991! - setRuleAndMapFor: sourceDepth foregroundColor: foregroundColor - - | targetColor destDepth | - destDepth _ destForm depth. - halftoneForm _ nil. "Don't use fillColor. Use a more powerful ColorMap" - - sourceDepth = 1 ifTrue: [ - self combinationRule: Form paint. - "Set up color map for a different source depth (color font)" - "Uses caching for reasonable efficiency" - colorMap _ self cachedFontColormapFrom1BitTo: destDepth. - colorMap at: 1 put: (destForm pixelValueFor: `Color transparent`). - colorMap at: 2 put: (destForm pixelValueFor: foregroundColor) ] - - ifFalse: [ - "Enable subpixel rendering if requested, but never for translucent text: - This technique always draws opaque text. This could be added, by using an extra colormap for the rgbMul phase... - So far, no need arised for doing so." - (sourceDepth > 8 and: [ - Preferences subPixelRenderFonts and: [ foregroundColor = `Color black` or: [ - Preferences subPixelRenderColorFonts and: [ foregroundColor isOpaque ]]]]) ifTrue: [ - destDepth > 8 ifTrue: [ - "rgbMul is equivalent to component alpha blend if text is black (only faster, hehe)" - self combinationRule: 37. "rgbMul" - colorMap _ (foregroundColor ~= `Color black` or: [ - destDepth = 32 and: [ destForm ~~ Display or: [Preferences properDisplayAlphaForFonts] ]]) ifTrue: [ - "rgbMul / rgbAdd IS component alpha blend for any color of text (neat trick, eh!!)" - "This colorMap is to be used on the second pass with rule 20 (rgbAdd) - See #displayString:from:to:at:strikeFont:color:" - "Note: In 32bpp, if we want the correct alpha in the result, we need the second pass, as the destination could have transparent pixels, - and we need to add to the alpha channel" - self colorConvertingMap: foregroundColor from: sourceDepth to: destDepth keepSubPixelAA: true]] - ifFalse: [ - self combinationRule: 25. "Paint" - targetColor _ foregroundColor = `Color black` ifFalse: [ foregroundColor ]. - colorMap _ self colorConvertingMap: targetColor from: sourceDepth to: destDepth keepSubPixelAA: true]] - ifFalse: [ - "Do not use rule 34 for 16bpp display. TTCFont uses it, but it builds a glyphs cache for each color used!!" - self combinationRule: (destDepth = 32 ifTrue: [34 "alphaBlendScaled"] ifFalse: [25 "Paint"]). - colorMap _ self colorConvertingMap: foregroundColor from: sourceDepth to: destDepth keepSubPixelAA: false]]! ! -!Rectangle methodsFor: 'transforming' stamp: 'jmv 3/10/2018 21:46:43' prior: 50359069! - newRectFrom: newRectBlock - "Track the outline of a new rectangle until mouse button changes. - newFrameBlock produces each new rectangle from the previous" - | rect newRect buttonStart buttonNow aHand delay | - delay _ Delay forMilliseconds: 10. - buttonStart _ buttonNow _ Sensor isAnyButtonPressed. - rect _ self. - Display border: rect width: 2 rule: Form reverse fillColor: `Color gray`. - [buttonNow == buttonStart] whileTrue: - [delay wait. - buttonNow _ Sensor isAnyButtonPressed. - newRect _ newRectBlock value: rect. - newRect = rect ifFalse: - [Display border: rect width: 2 rule: Form reverse fillColor: `Color gray`. - Display border: newRect width: 2 rule: Form reverse fillColor: `Color gray`. - rect _ newRect]]. - Display border: rect width: 2 rule: Form reverse fillColor: `Color gray`. - " pay the price for reading the sensor directly ; get this party started " - aHand _ self runningWorld activeHand. - aHand - newMouseFocus: nil; - flushEvents. - Sensor processSensorEvent: Sensor createMouseEvent discardingMouseEvents: false. - ^ rect! ! -!StrikeFont methodsFor: 'emphasis' stamp: 'jmv 3/10/2018 21:32:21' prior: 50359105! - makeBoldGlyphs - "Make a bold set of glyphs with same widths by ORing 1 bit to the right - (requires at least 1 pixel of intercharacter space)" - | g bonkForm | - g _ glyphs copy. - bonkForm _ (Form extent: 1@16) fillBlack offset: -1@0. - self bonk: g with: bonkForm. - glyphs depth = 1 ifTrue: [ - g copyBits: g boundingBox from: g at: (1@0) - clippingBox: g boundingBox rule: Form under ] - ifFalse: [ - 0 to: g width - 2 do: [ :x | 0 to: g height-1 do: [ :y | - (glyphs colorAt: x@y) = `Color white` ifFalse: [ - g colorAt: x+1@y put: - ((glyphs colorAt: x+1@y) = `Color white` - ifTrue: [glyphs colorAt: x@y] - ifFalse: [`Color black`])]]]]. - glyphs _ g. - self isSynthetic: true! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 3/10/2018 21:40:06' prior: 50359130! - makeControlCharsVisible - | glyph | - self characterToGlyphMap. - glyph _ self glyphAt: (Character space). - glyph border: glyph boundingBox width: 1 fillColor: `Color blue`. - self glyphAt: (Character numericValue: 134) put: glyph. - - "Keep tab(9), lf(10), cr(13) and space(32) transparent or whatever the user chose" - #(0 1 2 3 4 5 6 7 8 11 12 14 15 16 17 18 19 20 21 22 23 24 25 26 27) - do: [ :ascii | - characterToGlyphMap at: ascii + 1 put: 134 ]! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 3/10/2018 21:40:54' prior: 50371941! - makeCrVisible - | glyph | - glyph _ self glyphAt: (Character numericValue: 182). - glyph border: glyph boundingBox width: 1 fillColor: `Color blue`. -" glyph _ glyph reverse." - self glyphAt: Character cr put: glyph! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 3/10/2018 21:40:59' prior: 50371958! - makeLfVisible - | glyph | - glyph _ self glyphAt: (Character numericValue: 163). - glyph border: glyph boundingBox width: 1 fillColor: `Color blue`. -" glyph _ glyph reverse." - self glyphAt: Character lf put: glyph! ! -!Morph methodsFor: 'accessing' stamp: 'jmv 3/10/2018 21:38:27' prior: 50359171! - color - - ^ `Color blue`! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 3/10/2018 21:38:33' prior: 50359175! - drawOn: aCanvas - "A canvas is already set with a proper transformation from our coordinates to those of the Canvas target." - aCanvas - fillRectangle: self morphLocalBounds - color: `Color blue`! ! -!RectangleLikeMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 21:56:39' prior: 50359185! - defaultColor - ^ `Color orange`! ! -!BorderedRectMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 21:45:32' prior: 50359189! - defaultBorderColor - "answer the default border color/fill style for the receiver" - ^ `Color gray`! ! -!PasteUpMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 20:58:35' prior: 50359195! - defaultBorderColor - "answer the default border color/fill style for the receiver" - ^ `Color - r: 0.861 - g: 1.0 - b: 0.722`! ! -!PasteUpMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 20:58:44' prior: 50359202! - defaultColor - "answer the default color/fill style for the receiver" - ^ `Color - r: 0.8 - g: 1.0 - b: 0.6`! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 3/10/2018 22:02:53' prior: 50359209! - findWindow: evt - "Present a menu names of windows and naked morphs, and activate the one that gets chosen. Collapsed windows appear below line, expand if chosen; naked morphs appear below second line; if any of them has been given an explicit name, that is what's shown, else the class-name of the morph shows; if a naked morph is chosen, bring it to front and have it don a halo." - | menu expanded collapsed nakedMorphs | - menu _ MenuMorph new. - expanded _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed not ]. - collapsed _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed ]. - nakedMorphs _ self submorphsSatisfying: [ :m | - (m is: #SystemWindow) not ]. - expanded isEmpty & (collapsed isEmpty & nakedMorphs isEmpty) ifTrue: [ ^ Smalltalk beep ]. - (expanded asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #activateAndForceLabelToShow. - w canDiscardEdits ifFalse: [ menu lastItem color: `Color red` ]]. - expanded isEmpty | (collapsed isEmpty & nakedMorphs isEmpty) ifFalse: [ menu addLine ]. - (collapsed asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #expand. - w canDiscardEdits ifFalse: [ menu lastItem color: `Color red` ]]. - nakedMorphs isEmpty ifFalse: [ menu addLine ]. - (nakedMorphs asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #comeToFrontAndAddHalo ]. - menu addTitle: 'find window'. - menu popUpInWorld: self! ! -!EllipseMorph methodsFor: 'visual properties' stamp: 'jmv 3/10/2018 22:24:29' prior: 50359263! - defaultColor - "Return the default fill style for the receiver" - ^ `Color yellow`! ! -!PluggableMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 21:53:56' prior: 50359269! - defaultColor - "answer the default color/fill style for the receiver" - ^ `Color lightGray`! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 3/10/2018 21:23:14' prior: 50359316! - iconColor - - ^ self isPressed - ifTrue: [ `Color gray: 0.75` ] - ifFalse: [ - self mouseIsOver - ifTrue: [ `Color gray: 0.75` ] - ifFalse: [ `Color white` ]].! ! -!PluggableButtonMorph class methodsFor: 'example' stamp: 'jmv 3/12/2018 17:59:10' prior: 50384461! - example - " - PluggableButtonMorph example openInWorld - " - - | s1 s2 s3 b1 b2 b3 row | - s1 _ Switch new. - s2 _ Switch new turnOn. - s3 _ Switch new. - s2 onAction: [s3 turnOff]. - s3 onAction: [s2 turnOff]. - b1 _ (PluggableButtonMorph model: s1 stateGetter: #isOn action: #switch) label: 'S1'. - b2 _ (PluggableButtonMorph model: s2 stateGetter: #isOn action: #turnOn) label: 'S2'. - b3 _ (PluggableButtonMorph model: s3 stateGetter: #isOn action: #turnOn) label: 'S3'. - b1 color: `Color lightRed`. - b2 color: `Color lightRed`. - b3 color: `Color lightRed`. - row _ LayoutMorph newRow - addMorphs: (Array with: b1 with: b2 with: b3); - morphExtent: `120@35`. - ^ row! ! -!TextModelMorph methodsFor: 'drawing' stamp: 'jmv 3/10/2018 22:03:53' prior: 50359348! - drawOn: aCanvas - "Include a thin red inset border for unaccepted edits, or, if the unaccepted edits are known to conflict with a change made somewhere else to the same method (typically), put a thick red frame" - - - | bw bc | - - self flag: #todo. "Integrate this method with the Theme system. --cbr" - - - super drawOn: aCanvas. - bw _ Preferences focusIndicatorWidth. - bc _ nil. - self wantsFrameAdornments ifTrue: [ - model refusesToAccept - ifTrue: [ "Put up feedback showing that code cannot be submitted in this state" - bc _ `Color tan` ] - ifFalse: [ - self textMorph hasEditingConflicts - ifTrue: [ - bw _ 3. - bc _ `Color red` ] - ifFalse: [ - self textMorph hasUnacceptedEdits - ifTrue: [ - bc _ `Color red` ]]]]. - - (drawKeyboardFocusIndicator and: [ self textMorph hasKeyboardFocus ]) ifTrue: [ - bc ifNil: [ - bc _ Theme current focusIndicator ]] - ifFalse: [ - bc ifNotNil: [ - bc _ bc alphaMixed: 0.4 with: `Color white` ]]. - bc ifNotNil: [ - aCanvas frameRectangle: self focusIndicatorRectangle borderWidth: bw color: bc ]! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 3/10/2018 22:23:04' prior: 50359384! - defaultColor - "answer the default color/fill style for the receiver" - ^ `Color white`! ! -!SystemWindow methodsFor: 'menu' stamp: 'jmv 3/10/2018 21:32:46' prior: 50359390! - setWindowColor: incomingColor - | existingColor aColor | - incomingColor ifNil: [^ self]. "it happens" - aColor _ incomingColor asNontranslucentColor. - aColor = `Color black` ifTrue: [^ self]. - existingColor _ self widgetsColor. - existingColor ifNil: [^ Smalltalk beep]. - self widgetsColor: aColor. - self redrawNeeded! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'jmv 3/10/2018 22:08:36' prior: 50375583! - buildMorphicWindow - " - CodePackageListWindow open: CodePackageList new - " - | dirtyFlags names fileNames upperRow description summary backColor labelBackground | - backColor := self textBackgroundColor. - labelBackground := Theme current background. - - dirtyFlags := PluggableListMorph - model: model - listGetter: #packageDirtyFlags - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - dirtyFlags color: backColor. - dirtyFlags := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: ' Unsaved?'); - addMorphUseAll: dirtyFlags. - - names := PluggableListMorph - model: model - listGetter: #packageNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - names color: backColor. - names := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: ' Package Name'); - addMorphUseAll: names. - - fileNames := PluggableListMorph - model: model - listGetter: #packageFullNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - fileNames color: backColor. - fileNames := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: ' File Name'); - addMorphUseAll: fileNames. - - upperRow := LayoutMorph newRow. - upperRow - addMorph: dirtyFlags proportionalWidth: 0.13; - addAdjusterAndMorph: names proportionalWidth: 0.27; - addAdjusterAndMorph: fileNames proportionalWidth: 0.6. - - description := TextModelMorph - textProvider: model - textGetter: #description - textSetter: #description:. - - summary := TextModelMorph - textProvider: model - textGetter: #summary. - - self layoutMorph - addMorph: upperRow proportionalHeight: 0.6; - addAdjusterAndMorph: self buildButtonPane fixedHeight: Theme current buttonPaneHeight; - addAdjusterAndMorph: summary fixedHeight: 60; - addAdjusterAndMorph: description proportionalHeight: 0.25; - addAdjusterAndMorph: self buildRequirementsPane proportionalHeight: 0.15. - self setLabel: 'Installed Packages'! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'jmv 3/10/2018 22:09:02' prior: 50359479! - buildRequirementsPane - - | requirements deleteReqButton "editReqButton" reqLayout buttonLayout | - requirements := PluggableListMorph - model: (PackageRequirementsList fromCodePackageList: model) - listGetter: #requirementsStrings - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - requirements color: Theme current textPane. - - deleteReqButton := PluggableButtonMorph - model: requirements model - action: #deleteSelectedRequirement - label: 'delete'. - deleteReqButton color: self widgetsColor. - - buttonLayout := LayoutMorph newColumn. - buttonLayout addMorph: deleteReqButton - layoutSpec: (LayoutSpec - proportionalWidth: 1.0 - proportionalHeight: 1.0 - minorDirectionPadding: #top); - color: self widgetsColor quiteWhiter. - - model when: #changed: send: #updateRequirementsFromPackageList to: requirements model. - self when: #changed: send: #updateRequirementsFromPackageList to: requirements model. - requirements model when: #changed: send: #verifyContents to: requirements. - self when: #changed: send: #verifyContents to: requirements. - - reqLayout := LayoutMorph newRow. - ^ reqLayout - doAdoptWidgetsColor; - addMorph: requirements - layoutSpec: (LayoutSpec - proportionalWidth: 0.9 - proportionalHeight: 1.0 - minorDirectionPadding: #left); - addMorph: buttonLayout - layoutSpec: (LayoutSpec - proportionalWidth: 0.1 - proportionalHeight: 1.0 - minorDirectionPadding: #right); - color: `Color transparent`; - yourself - ! ! -!CodeWindow methodsFor: 'updating' stamp: 'jmv 3/10/2018 20:51:37' prior: 50359530! - decorateForInheritance - "Check to see if the currently-viewed method has a super send or an override, and if so, change screen feedback, unless the #decorateBrowserButtons says not to." - - | cm aColor aButton flags buttonColor | - (aButton _ self inheritanceButton) ifNil: [^ self]. - buttonColor _ self buttonColor. - - Preferences decorateBrowserButtons - ifFalse: [ ^aButton color: buttonColor ]. - cm _ model currentCompiledMethod. - (cm is: #CompiledMethod) - ifFalse: [ ^aButton color: buttonColor ]. - - flags _ 0. - model isThisAnOverride ifTrue: [ flags _ flags bitOr: 4 ]. - cm sendsToSuper ifTrue: [ flags _ flags bitOr: 2 ]. - model isThereAnOverride ifTrue: [ flags _ flags bitOr: 1 ]. - aColor _ { - - "This is NOTan override. There is no super implementation." - buttonColor. "no sends to super. there is not override in any subclass" - `Color tan`. "no sends to super. there is an override in some subclass" - `Color red`. "sends to super. there is no override in any subclass. Error: no super to call (or calls super with a different message)" - `Color red`. "sends to super. there is an override in some subclass. Error: no super to call (or calls super with a different message)" - - "This is an override. There is some super implementation" - `Color red muchLighter`. "doesn't have sub; has super but doesn't call it" - `Color r: 0.94 g: 0.823 b: 0.673`. "has sub; has super but doesn't call it" - `Color green muchLighter`. "doesn't have sub; has super and callsl it" - `Color blue muchLighter`. "has sub; has super and callsl it" - - } at: flags + 1. - aButton color: aColor! ! -!ChangeSorterWindow methodsFor: 'GUI building' stamp: 'jmv 3/10/2018 22:07:53' prior: 50359583! - buildMorphicWindow - "Add a set of change sorter views to the given top view offset by the given amount. To create a single change sorter, call this once with an offset of 0@0. To create a dual change sorter, call it twice with offsets of 0@0 and 0.5@0." - - | dirtyFlags changeSetList classList messageList upperPanes backColor labelBackground | - backColor _ self textBackgroundColor. - labelBackground _ Theme current background. - model myChangeSet ifNil: [ - self flag: #ojo. "Or whatever was last changed, or is top of list, or whatever" - model myChangeSet: ChangeSet changeSetForBaseSystem ]. - - dirtyFlags _ PluggableListMorph - model: model - listGetter: #changeSetDirtyFlags - indexGetter: nil - indexSetter: nil. - dirtyFlags color: backColor. - dirtyFlags _ LayoutMorph newColumn - color: Theme current background; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: ' Unsaved?'); - addMorphUseAll: dirtyFlags. - - changeSetList _ (PluggableListMorphByItem - model: model - listGetter: #changeSetList - indexGetter: #currentCngSet - indexSetter: #showChangeSetNamed: - mainView: self - menuGetter: #changeSetMenu - keystrokeAction: #changeSetListKey:from:) - autoDeselect: false. - changeSetList color: backColor. - changeSetList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: 'Change Set name'); - addMorphUseAll: changeSetList. - - classList _ PluggableListMorphByItem - model: model - listGetter: #classList - indexGetter: #currentClassName - indexSetter: #currentClassName: - mainView: self - menuGetter: #classListMenu - keystrokeAction: #classListKey:from:. - classList color: backColor. - classList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: 'Classes'); - addMorphUseAll: classList. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: dirtyFlags proportionalWidth: 0.13; - addAdjusterAndMorph: changeSetList proportionalWidth: 0.47; - addAdjusterAndMorph: classList proportionalWidth: 0.4. - - messageList _ PluggableListMorphByItem - model: model - listGetter: #messageList - indexGetter: #currentSelector - indexSetter: #currentSelector: - mainView: self - menuGetter: #messageMenu - keystrokeAction: #messageListKey:from:. - messageList color: backColor. - messageList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: 'Methods'); - addMorphUseAll: messageList. - - self layoutMorph - addMorph: upperPanes proportionalHeight: 0.25; - addAdjusterAndMorph: messageList proportionalHeight: 0.2; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.55. - - self setLabel: model labelString! ! -!PreDebugWindow methodsFor: 'GUI building' stamp: 'jmv 3/10/2018 22:13:32' prior: 50359681! -buttonRowForPreDebugWindow: aDebugger - | row aButton triads buttons | - buttons _ OrderedCollection new. - triads _ OrderedCollection withAll: self preDebugButtonSpec. - aDebugger shouldBeAbleToCreateMethod ifTrue: [ triads add: { 'Create'. #createMethod. 'create the missing method' }]. - - triads do: [ :triad | - aButton _ PluggableButtonMorph new model: self. - aButton label: triad first. - aButton action: triad second. - aButton setBalloonText: triad third. - buttons add: aButton]. - - row _ LayoutMorph newRow. - row doAdoptWidgetsColor. - row color: `Color transparent`. - row separation: 1. - row addMorphs: buttons. - ^row! ! -!TestRunnerWindow methodsFor: 'constants' stamp: 'jmv 3/10/2018 21:52:20' prior: 50359704! - runButtonColor - ^ `Color green lighter duller`! ! -!ProgressBarMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 22:22:59' prior: 50359709! - defaultColor - ^ `Color white`! ! -!ProgressBarMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 21:46:24' prior: 50359713! - initialize - super initialize. - progressColor _ `Color gray`. - value _ 0.0! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 3/10/2018 22:13:23' prior: 50359718! - addStayUpIcons - | closeBox pinBox w | - Preferences optionalButtons ifFalse: [ ^self ]. - (self valueOfProperty: #hasStayUpIcons ifAbsent: [ false ]) - ifTrue: [ - self removeProperty: #needsStayUpIcons. - ^self ]. - titleMorph ifNil: [ - "Title not yet there. Flag ourself, so this method is called again when adding title." - self setProperty: #needsStayUpIcons toValue: true. - ^ self]. - closeBox _ PluggableButtonMorph model: self action: #delete. - closeBox icon: Theme current closeIcon; color: `Color transparent`. - pinBox _ PluggableButtonMorph model: self action: #stayUp. - pinBox icon: Theme current pushPinIcon; color: `Color transparent`. - w _ (titleMorph hasSubmorphs ifTrue: [ titleMorph firstSubmorph morphWidth ] ifFalse: [ 0 ]) + 60. - self addMorphFront: - (LayoutMorph newRow - "Make room for buttons" - morphExtent: w @ (titleMorph morphHeight max: 19); - color: `Color transparent`; - addMorph: closeBox fixedWidth: 20; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedWidth: 4; - addMorph: titleMorph proportionalWidth: 1; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedWidth: 4; - addMorph: pinBox fixedWidth: 20). - - self setProperty: #hasStayUpIcons toValue: true. - self removeProperty: #needsStayUpIcons! ! -!MenuMorph methodsFor: 'keyboard control' stamp: 'jmv 3/12/2018 17:59:17' prior: 50384963! - displayFiltered: evt - | matchStr allItems isMatch matches feedbackMorph | - matchStr _ self valueOfProperty: #matchString. - allItems _ self submorphs select: [ :m | - m is: #MenuItemMorph ]. - matches _ allItems select: [ :m | - isMatch _ matchStr isEmpty or: [ - m contents - includesSubstring: matchStr - caseSensitive: false ]. - m isEnabled: isMatch. - isMatch ]. - feedbackMorph _ self valueOfProperty: #feedbackMorph. - feedbackMorph ifNil: [ - feedbackMorph _ StringMorph new color: `Color veryDarkGray`. - self addMorphBack: feedbackMorph lock position: `0@ -20`. - self - setProperty: #feedbackMorph - toValue: feedbackMorph ]. - feedbackMorph contents: '<' , matchStr , '>'. - matchStr isEmpty ifTrue: [ - feedbackMorph delete. - self removeProperty: #feedbackMorph ]. - matches notEmpty ifTrue: [ - self selectItem: matches first ]! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 17:59:29' prior: 50385043! - drawOn: aCanvas - | rectangle w y0 h y1 y2 scrollbarThickness | - aCanvas frameAndFillRectangle: (`0@0` extent: extent) fillColor: self color borderWidth: borderWidth borderColor: borderColor. - y0 _ 1. - w _ extent x-2. - scrollbarThickness _ ScrollBar scrollbarThickness. - completer entryCount > self class itemsPerPage ifTrue: [ - w _ w - scrollbarThickness. - aCanvas - frameRectangle: (extent x - scrollbarThickness@0 - extent: scrollbarThickness @ extent y) - borderWidth: 1 - color: borderColor. - aCanvas - image: (BitBltCanvas arrowOfDirection: #up size: scrollbarThickness) - at: self upButtonPosition. - aCanvas - image: (BitBltCanvas arrowOfDirection: #down size: scrollbarThickness) - at: self downButtonPosition. - h _ extent y - (2 * scrollbarThickness). - y1 _ (1.0 * self firstVisible-1 / completer entryCount * h) ceiling + y0 + scrollbarThickness-1. - y2 _ (1.0 * self lastVisible / completer entryCount * h) floor + y0 + scrollbarThickness -1. - aCanvas - fillRectangle: (extent x - scrollbarThickness+2@y1 corner: extent x-2 @ y2) - color: `Color veryLightGray` ]. - self firstVisible - to: self lastVisible - do: [ :index | - rectangle _ 1@y0 extent: w@self class itemHeight. - index = self selected - ifTrue: [ - aCanvas fillRectangle: rectangle color: (Theme current listHighlightFocused: true) ]. - aCanvas - drawString: (completer entries at: index) asString - at: rectangle topLeft - font: self class listFont - color: Theme current text. - y0 _ y0 + self itemHeight ]! ! -!AutoCompleterMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 21:45:20' prior: 50359842! - defaultBorderColor - ^ `Color gray`! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 3/12/2018 17:59:34' prior: 50385107! - drawOn: aCanvas - "Draw the hand itself (i.e., the cursor)." - "This method is only called when we are carrying morphs around..." - aCanvas - stencil: Cursor move - at: `0@0` - color: `Color black`! ! -!ImageMorph methodsFor: 'accessing' stamp: 'jmv 3/10/2018 22:12:19' prior: 50359855! - color: aColor - super color: aColor. - (image depth = 1 and: [aColor is: #Color]) ifTrue: [ - image colors: {`Color transparent`. aColor}. - self redrawNeeded]! ! -!MenuItemMorph methodsFor: 'accessing' stamp: 'jmv 3/10/2018 21:30:52' prior: 50359864! - isEnabled: aBoolean - - isEnabled = aBoolean ifTrue: [^ self]. - isEnabled _ aBoolean. - self color: (aBoolean ifTrue: [`Color black`] ifFalse: [`Color gray`]). -! ! -!MenuItemMorph methodsFor: 'private' stamp: 'jmv 3/10/2018 21:22:24' prior: 50359872! - offImage - "Return the form to be used for indicating an '' marker" - | form | - form _ Form extent: (self fontToUse ascent-2) asPoint depth: 16. - form getCanvas - frameAndFillRectangle: form boundingBox fillColor: `(Color gray: 0.9)` - borderWidth: 1 borderColor: `Color black`. - ^form! ! -!MenuItemMorph methodsFor: 'private' stamp: 'jmv 3/10/2018 21:22:55' prior: 50359884! - onImage - "Return the form to be used for indicating an '' marker" - | form | - form _ Form extent: (self fontToUse ascent-2) asPoint depth: 16. - form getCanvas - frameAndFillRectangle: form boundingBox fillColor: `Color gray: 0.8` - borderWidth: 1 borderColor: `Color black`; - fillRectangle: (form boundingBox insetBy: 2) color: `Color black`. - ^form! ! -!LayoutMorph methodsFor: 'accessing' stamp: 'jmv 3/10/2018 22:12:27' prior: 50359898! - adoptWidgetsColor: paneColor - super adoptWidgetsColor: paneColor. - doAdoptWidgetsColor - ifTrue: [ self color: (Theme current buttonColorFrom: paneColor) ] - ifFalse: [ self color: `Color transparent` ]! ! -!LayoutMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 21:46:16' prior: 50359908! - defaultColor - ^ `Color gray`! ! -!LayoutMorph class methodsFor: 'instance creation' stamp: 'jmv 3/10/2018 22:01:15' prior: 50359912! - initializedInstance - "Answer a row by default so the 'new morph' menu doesn't fail..." - ^self newRow color: `(Color red alpha: 0.2)`! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 3/10/2018 22:01:26' prior: 50360383! - launcherExample - " - self launcherExample - " - | b1 b2 b3 row b4 random buttons | - random _ Random new. - b1 _ PluggableButtonMorph model: [ Date today print ] action: #value label: 'Date'. - b2 _ PluggableButtonMorph model: [ Time now print ] action: #value label: 'Time'. - b3 _ PluggableButtonMorph model: [ SystemVersion current print ] action: #value label: 'Version'. - b4 _ PluggableButtonMorph model: [ random next print ] action: #value label: 'Random'. - buttons _ {b1. b2. b3. b4}. - buttons do: [ :button | - button color: `Color lightRed` ]. - row _ LayoutMorph newRow - color: `Color red`; - addMorphs: buttons; - morphExtent: 300 @ 40. - ^ row openInWorld! ! -!ProgressMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 22:16:44' prior: 50360407! - defaultColor - ^ `Color veryLightGray`! ! -!HaloHandleMorph class methodsFor: 'accessing' stamp: 'jmv 3/10/2018 22:21:42' prior: 50360412! - circleForm: extent - " - CircleForm _ nil - " - | r d l bw center | - (CircleForm isNil or: [ CircleForm extent ~= extent ]) ifTrue: [ - center _ extent -1 * 0.5. - r _ center r * 0.75. - bw _ 1.3. - CircleForm _ Form extent: extent depth: 32. - 0 to: extent y - 1 do: [ :y | - 0 to: extent x - 1 do: [ :x | - d _ (x@y - center) r. - l _ (r - d max: 0.0) min: bw. - CircleForm - colorAt: x @ y - put: (`Color white` alpha: (l / bw)) - ]]. - ]. - ^CircleForm! ! -!HaloMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 20:58:21' prior: 50360430! - defaultColor - "answer the default color/fill style for the receiver" - ^ `Color - r: 0.6 - g: 0.8 - b: 1.0`! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 3/10/2018 21:30:16' prior: 50360470! -addNameString: aString - "Add a name display centered beneath the bottom of the outer rectangle. Return the handle." - - | nameMorph namePosition nameBackground | - nameBackground _ RectangleLikeMorph new - color: ((target is: #SystemWindow) ifTrue: [target windowColor] ifFalse: [`Color lightBlue alpha: 0.9`]). - nameMorph _ StringMorph contents: aString. - nameMorph color: `Color black`. - nameBackground morphExtent: nameMorph morphExtent + 4. - namePosition _ haloBox width - nameMorph morphWidth // 2 @ (haloBox height). - self addMorph: nameBackground position: namePosition - 2. - self addMorph: nameMorph position: namePosition. - ^nameMorph! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 3/10/2018 21:38:00' prior: 50360493! - doRot: evt with: rotHandle - "Update the rotation of my target if it is rotatable. Keep the relevant command object up to date." - - | degrees | -self revisar. - self flag: #jmvVer2. - evt hand obtainHalo: self. - degrees _ (evt eventPosition - target referencePosition) degrees. - degrees _ degrees - angleOffset degrees. - degrees _ degrees detentBy: 10.0 atMultiplesOf: 90.0 snap: false. - degrees = 0.0 - ifTrue: [rotHandle color: `Color lightBlue`] - ifFalse: [rotHandle color: `Color blue`]. - rotHandle submorphsDo: - [:m | m color: rotHandle color makeForegroundColor]. - self removeAllHandlesBut: rotHandle. - - target rotationDegrees: degrees. - - rotHandle morphPositionInWorld: evt eventPosition - (rotHandle morphExtent // 2)! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 3/10/2018 21:53:51' prior: 50360519! - setDismissColor: evt with: dismissHandle - "Called on mouseStillDown in the dismiss handle; set the color appropriately." - - | colorToUse | - evt hand obtainHalo: self. - colorToUse _ (dismissHandle morphContainsPoint: (dismissHandle internalizeFromWorld: evt eventPosition)) - ifFalse: [ `Color red muchLighter` ] - ifTrue: [ `Color lightGray` ]. - dismissHandle color: colorToUse! ! -!InnerListMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 21:30:39' prior: 50361238! - initialize - super initialize. - self color: `Color black`. - font _ Preferences standardListFont. - listItems _ #(). - selectedRow _ nil. - highlightedRow _ nil! ! -!InnerTextMorph methodsFor: 'drawing' stamp: 'jmv 3/10/2018 21:44:18' prior: 50360543! - debugDrawLineRectsOn: aCanvas - "Shows where text line rectangles are" - - self textComposition lines do: [ :line | - aCanvas - frameRectangle: line rectangle - borderWidth: 1 - color: `Color brown` ] -! ! -!ResizeMorph methodsFor: 'initialization' stamp: 'jmv 3/12/2018 17:59:45' prior: 50385704! - initialize - super initialize. - extent _ `400@300`. - color _ `Color white`. - grid _ `8@6`. - gridLineWidth _ 2. - gridColor _ `Color black`. - selectionColor _ `Color red`! ! -!ResizeMorph methodsFor: 'events' stamp: 'jmv 3/10/2018 21:31:55' prior: 50360561! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - from _ self toGridPoint: localEventPosition. - outlineMorph _ BorderedRectMorph new - borderColor: `Color black`; - color: `Color transparent`; - openInWorld; - hide. - self selectTo: localEventPosition! ! -!HoverHelpMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 20:58:28' prior: 50360573! - defaultColor - - ^ `Color r: 1.0 g: 1.0 b: 0.7`! ! -!HoverHelpMorph methodsFor: 'drawing' stamp: 'jmv 3/10/2018 21:30:31' prior: 50360578! - drawOn: aCanvas - - | r | - r _ self morphLocalBounds. - aCanvas roundRect: r color: self color radius: 4. - aCanvas - textComposition: textComposition - bounds: (r insetBy: 4) - color: `Color black` - selectionColor: (Theme current textHighlightFocused: false)! ! -!WorldState class methodsFor: 'sample code' stamp: 'jmv 3/10/2018 21:48:37' prior: 50360715! - experiment1 - "To play with and learn about morphic Display update logic. - Remove the morphs when done!!" - " - WorldState experiment1 - " - | dr morph1 morph2 s w | - morph1 _ RectangleLikeMorph new openInWorld. - morph2 _ RectangleLikeMorph new openInWorld. - morph2 color: `Color green`. - morph2 morphPosition: 200@800 extent: 50@40. - morph1 morphPosition: 120@720 extent: 220@100. - - w _ self runningWorld. - s _ w instVarNamed: 'worldState'. - dr _ s instVarNamed: 'damageRecorder'. - - dr doFullRepaint. - dr reset; - " recordInvalidRect: (100@700 corner: 400@900);" - recordInvalidRect: (100@700 corner: 150@900); - recordInvalidRect: (300@700 corner: 400@900). - Display fillColor: `Color gray`. - "Do not draw the area used by the small rectangle, unless it is also drawn!!" - s drawInvalidAreasSubmorphs: {morph1. morph2 }! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 3/12/2018 17:59:57' prior: 50385876! - drawCurrentAsError - "The morph (or one of its submorphs) had an error in its drawing method." - | r w | - r _ currentMorph morphLocalBounds. - w _ r extent > `50@50` - ifTrue: [ 6 ] - ifFalse: [ 2 ]. - self - frameAndFillRectangle: r - fillColor: `Color red` - borderWidth: w - borderColor: `Color yellow`. - self line: r topLeft to: r bottomRight-w width: w color: `Color yellow`. - self line: r topRight -(w@0) to: r bottomLeft -(0@w)width: w color: `Color yellow`! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/12/2018 18:00:11' prior: 50385894! - drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - aColor = `Color black` ifFalse: [ | topColor | - topColor _ aColor alphaMixed: 0.25 with: `Color black`. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint - font: fontOrNil - color: topColor ]. - aColor = `Color white` ifFalse: [ | bottomColor | - bottomColor _ aColor alphaMixed: 0.22 with: `Color white`. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + `0@2` - font: fontOrNil - color: bottomColor ]. - ^self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + `0@1` - font: fontOrNil - color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 3/10/2018 22:06:13' prior: 50360788! - fillRectangle: aRectangle color: aColor - "Fill the given rectangle." - - aColor isTransparent ifFalse: [ - self - frameAndFillRectangle: aRectangle - fillColor: aColor - borderWidth: 0 - borderColor: `Color transparent` ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 3/10/2018 21:45:27' prior: 50360798! - reverseRectangleBorder: r borderWidth: borderWidth - " - Display getCanvas - reverseRectangleBorder: (10@10 extent: 300@200) - borderWidth: 20. - Display forceToScreen - " - | rect | - rect _ currentTransformation displayBoundsOfTransformOf: r. - port - sourceForm: nil; - fillColor: `Color gray`; - combinationRule: Form reverse; - frameRect: rect borderWidth: borderWidth! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 3/10/2018 22:06:54' prior: 50360813! - setPaintColor: aColor - "Install a new color used for filling." - | paintColor | - paintColor _ aColor ifNil: [ `Color transparent` ]. - (paintColor is: #Color) ifFalse: [ - ^ self error: 'Cannot install color' ]. - - "Okay, so paintColor really *is* a color" - port sourceForm: nil. - (paintColor isOpaque or: [ self depth < 32]) ifTrue: [ - port fillColor: paintColor. - port combinationRule: Form paint. - ^ self ]. - - "BitBlt setup for alpha mapped transfer" - port fillColor: paintColor. - port combinationRule: Form blend! ! -!BitBltCanvas class methodsFor: 'cached forms' stamp: 'jmv 3/12/2018 18:00:43' prior: 50386009! - steButtonForm: extent - ^self cachedForms - at: { #steButton . extent } - ifAbsentPut: [ - | form canvas | - form _ Form extent: extent depth: 32. - canvas _ form getCanvas. - canvas - roundRect: (`0@0` extent: extent) - color: `Color gray: 0.4` - radius: 4. - canvas - roundRect: (`1@1` extent: extent-2) - color: `Color white` - radius: 4 - gradientTop: 1.0 - gradientCenter: 0.73 - gradientBottom: 0.94 - gradient1Height: (extent y-8+1 max: extent y//2). - form]! ! -!BitBltCanvas class methodsFor: 'cached arrow forms' stamp: 'jmv 3/10/2018 21:21:27' prior: 50360866! - buildArrowOfDirection: aSymbolDirection size: finalSizeInteger - "PRIVATE - create an arrow with aSymbolDirectionDirection, - finalSizeInteger and aColor - - aSymbolDirectionDirection = #up, #down. #left or #right - (self buildArrowOfDirection: #down size: 120) display - (self buildArrowOfDirection: #up size: 120) display - " - - | resizeFactor resizedForm f e c bottomMargin topMargin | - resizeFactor _ 4. - e _ finalSizeInteger@finalSizeInteger*resizeFactor. - f _ Form extent: e depth: 32. - c _ `Color gray: 0.5`. - topMargin _ finalSizeInteger * 3//4. - bottomMargin _ finalSizeInteger * 4//4. - 0 to: e y-1-bottomMargin do: [ :y | - 0 to: e x -1 do: [ :x | - (e x / 2 - 1 - x) abs * 2 + topMargin < y ifTrue: [ - f colorAt: x@y put: c - ] - ] - ]. - resizedForm _ f - magnify: f boundingBox - by: 1 / resizeFactor - smoothing: 4. - - aSymbolDirection == #right ifTrue: [ - resizedForm _ resizedForm rotatedByDegrees: 90 ]. - aSymbolDirection == #down ifTrue: [ - resizedForm _ resizedForm rotatedByDegrees: 180 ]. - aSymbolDirection == #left ifTrue: [ - resizedForm _ resizedForm rotatedByDegrees: 270 ]. - - aSymbolDirection == #up ifFalse: [ - resizedForm _ resizedForm - copy: (resizedForm boundingBox insetBy: (resizedForm width - finalSizeInteger/ 2.0) rounded) ]. - - ^resizedForm! ! -!BitBltCanvas class methodsFor: 'cached arrow forms' stamp: 'jmv 3/12/2018 18:01:37' prior: 50386028! - buildArrowWith: insideForm borderForm: borderForm - | extent translucentForm color insideSpec borderSpec border background alpha| - " - Display getCanvas - image: (BitBltCanvas buildArrowWith: BitBltCanvas downInsideForm borderForm: BitBltCanvas downBorderForm) - at: 20@20 - Display getCanvas - image: (BitBltCanvas buildArrowWith:BitBltCanvas upInsideForm borderForm: BitBltCanvas upBorderForm) - at: 40@20 - " - extent _ insideForm extent - `1@2`. - translucentForm _ Form extent: insideForm extent depth: 32. - 0 to: extent x-1 do: [ :x | - 0 to: extent y-1 do: [ :y | - insideSpec _ insideForm colorAt: x@(y+1). - borderSpec _ borderForm colorAt: x@(y+1). - insideSpec = `Color r: 0.0 g: 0.0 b: 1.0` - ifTrue: [ color _ `Color transparent` ] - ifFalse: [ - borderSpec = `Color r: 1.0 g: 0.0 b: 0.0` - ifTrue: [ color _ insideSpec ] - ifFalse: [ - border _ x < (extent x//2) - ifTrue: [`Color white`] - ifFalse: [`Color black`]. - background _ borderForm colorAt: extent x@(y+1). - alpha _ borderSpec red asFloat - background red / (border red - background red). - color _ border alpha: (alpha min: 1 max: 0) ]]. - translucentForm colorAt: x@y put: color ]]. - ^translucentForm! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/10/2018 20:59:15' prior: 50360951! - background - ^ `Color r: 0.7 g: 0.72 b: 0.83`! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/10/2018 22:13:58' prior: 50360955! - buttonColorFrom: aColor - ^ Display depth <= 8 - ifTrue: [ `Color transparent` ] - ifFalse: [ aColor paler ]! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/10/2018 21:23:25' prior: 50360961! - buttonLabel - ^ `Color gray: 0.18`! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/10/2018 22:03:59' prior: 50360965! - errorColor - ^ `Color red lighter`! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/10/2018 22:24:39' prior: 50360969! - failureColor - ^ `Color yellow lighter`! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/10/2018 21:23:34' prior: 50360973! - scrollbarButtonColor - ^ `Color gray: 0.95`! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/10/2018 22:23:27' prior: 50360977! - scrollbarColor - ^ `Color white`! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/10/2018 22:23:32' prior: 50360981! - scrollbarSliderShadowColor - ^ `Color white`! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/10/2018 21:52:43' prior: 50360985! - successColor - ^ `Color green lighter`! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/10/2018 21:34:04' prior: 50360989! - text - ^ `Color black`! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/10/2018 21:34:14' prior: 50360993! - textCursor - ^ Display depth <= 2 - ifTrue: [ `Color black` ] - ifFalse: [ self text ]! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/10/2018 21:19:22' prior: 50360999! - textHighlight - "A nice light blue." - " - ^ Color r: 0.71 g: 0.835 b: 1.0 - ^ Color hue: 214 chroma: 0.29 luminance: 0.816 - " - ^ `Color hue: 204 chroma: 0.29 luminance: 0.77`! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/10/2018 21:24:07' prior: 50361007! - textHighlightFocused: focused - "A nice light blue." - | textHighlight | - Display depth = 1 ifTrue: [^ `Color veryLightGray` ]. - Display depth = 2 ifTrue: [^ `Color gray: 0.87` ]. - textHighlight _ self textHighlight. - ^focused - ifTrue: [ textHighlight ] - ifFalse: [ self unfocusedTextHighlightFrom: textHighlight ]! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/10/2018 21:24:18' prior: 50361020! - windowLabel - ^ `Color gray: 0.3`! ! -!Theme methodsFor: 'menu colors' stamp: 'jmv 3/10/2018 20:42:33' prior: 50361024! - menu - Display depth <= 2 ifTrue: [^ `Color white` ]. - ^ `Color r: 0.75 g: 0.75 b: 0.75 alpha: 0.93`! ! -!Theme methodsFor: 'menu colors' stamp: 'jmv 3/10/2018 22:16:53' prior: 50361030! - menuHighlight - ^ Display depth < 8 - ifTrue: [ `Color veryLightGray` ] - ifFalse: [ self textHighlight ]! ! -!Theme methodsFor: 'menu colors' stamp: 'jmv 3/10/2018 21:33:40' prior: 50361036! - menuText - ^ `Color black`! ! -!Theme methodsFor: 'menu colors' stamp: 'jmv 3/10/2018 21:47:13' prior: 50361040! - menuTitleBar - Display depth = 1 ifTrue: [^ `Color white`]. - Display depth = 2 ifTrue: [^ `Color gray`]. - ^ self menu darker! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/10/2018 20:59:31' prior: 50361047! - browser - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ `Color r: 0.5 g: 0.7 b: 0.4`]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/10/2018 21:20:34' prior: 50361054! - debugger - ^ `Color h: 0.0 s: 0.6 v: 0.7`! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/10/2018 20:59:08' prior: 50361058! - defaultWindowColor - ^ `Color lightGray`! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/10/2018 22:05:56' prior: 50361062! - fileContentsBrowser - ^ `Color tan duller`! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/10/2018 20:59:58' prior: 50361066! - fileList - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ `Color r: 0.7 g: 0.55 b: 0.7` ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/10/2018 21:00:04' prior: 50361073! - messageNames - - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ `Color r: 0.53 g: 0.77 b: 0.382` ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/10/2018 21:00:12' prior: 50361080! - messageSet - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ `Color r: 0.45 g: 0.6 b: 0.85` ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/10/2018 22:23:19' prior: 50361087! - object - ^ `Color white duller`! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/10/2018 21:00:19' prior: 50361091! - packageList - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ `Color r: 0.63 g: 0.47 b: 0.08` ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/10/2018 21:00:28' prior: 50361098! - testRunner - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ `(Color r: 0.650 g: 0.753 b: 0.976) duller` ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/10/2018 21:23:40' prior: 50361105! - textEditor - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ `Color gray: 0.6` ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/10/2018 21:01:02' prior: 50361111! -transcript - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ `Color r: 0.8 g: 0.6 b: 0.3` ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/10/2018 21:01:08' prior: 50361118! - versionsBrowser - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ `(Color r: 0.869 g: 0.753 b: 1.0) duller` ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/10/2018 21:20:41' prior: 50361125! - workspace - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ `Color h: 60.0 s: 0.73 v: 0.72` ]! ! -!Theme methodsFor: 'widget colors' stamp: 'jmv 3/10/2018 20:59:00' prior: 50361132! - acceptButton - - ^ self buttonColorFrom: - (self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ `Color r: 0.2 g: 0.6 b: 0.1` ])! ! -!Theme methodsFor: 'widget colors' stamp: 'jmv 3/10/2018 20:59:50' prior: 50361140! - cancelButton - - ^ self buttonColorFrom: - (self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ `Color r: 0.8 g: 0.2 b: 0.2` ])! ! -!Theme methodsFor: 'widget colors' stamp: 'jmv 3/10/2018 22:23:38' prior: 50361148! - textPane - ^ `Color white`! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3273-UseALotOfLiteralColors-JuanVuletich-2018Mar12-17h49m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3272] on 12 March 2018 at 6:05:59 pm'! -!ChangeListElement methodsFor: 'testing' stamp: 'jmv 3/12/2018 18:05:54'! - isDoIt - - ^false! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3274-ChangeListElement-isDoit-JuanVuletich-2018Mar12-18h02m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3274] on 12 March 2018 at 7:21:38 pm'! -!Color methodsFor: 'other' stamp: 'jmv 3/12/2018 19:20:35' prior: 50356766! - colorName - "Return this color's name, or nil if it has no name. Only returns a name if it exactly matches the named color. - Return nil if named color support is not present" - - ^ ColorNamesDict ifNotNil: [ :dict| - dict keyAtValue: self ifAbsent: [nil]]! ! -!Color methodsFor: 'selection' stamp: 'jmv 3/12/2018 19:15:42' prior: 50353879! - isGreen - "Am I considered Green ?" - - ^self green > (self blue + 0.3) - and: [self green > (self red + 0.3)]! ! -!Color methodsFor: 'selection' stamp: 'jmv 3/12/2018 19:16:29' prior: 50353894! - isMagenta - "Am I considered Magenta ?" - - ^self green < 0.05 - and: [(self red min: self blue) > 0.4] - and: [(self red - self blue) abs < 0.3]! ! -!Color methodsFor: 'selection' stamp: 'jmv 3/12/2018 19:17:05' prior: 50353930! - isYellow - "Am I considered Yellow ?" - - ^self blue < 0.1 - and: [(self red min: self green) > 0.5] - and: [(self red - self green) abs < 0.2]! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 18:48:04' prior: 50354973! - black - ^`Color r: 0 g: 0 b: 0`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:01:23' prior: 50354977! - blue - "Override traditional names existing in XKCD naming" - ^ `Color r: 0.012 g: 0.263 b: 0.875`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 18:59:10' prior: 50354985! - brown - "Override traditional names existing in XKCD naming" - ^ `Color r: 0.396 g: 0.216 b: 0.0`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 18:49:47' prior: 50354989! - cyan - ^ `Color r: 0 g: 1.0 b: 1.0`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:03:42' prior: 50354997! - darkGray - ^ `Color r: 0.375 g: 0.375 b: 0.375`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:03:57' prior: 50355017! - gray - ^ `Color r: 0.5 g: 0.5 b: 0.5`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:02:25' prior: 50355021! - green - "Override traditional names existing in XKCD naming" - ^ `Color r: 0.082 g: 0.690 b: 0.102`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 18:57:12' prior: 50355041! - lightBlue - "Override traditional names existing in XKCD naming" - ^ `Color r: 0.584 g: 0.816 b: 0.988`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 18:47:23' prior: 50355045! - lightBrown - "Override traditional names existing in XKCD naming" - ^ `Color r: 0.678 g: 0.506 b: 0.314`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 18:40:26' prior: 50355049! - lightCyan - "Override traditional names existing in extended XKCD naming" - ^ `Color r: 0.674 g: 1.0 b: 0.988`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:04:01' prior: 50355053! - lightGray - ^ `Color r: 0.625 g: 0.625 b: 0.625`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 18:54:54' prior: 50355057! - lightGreen - "Override traditional names existing in XKCD naming" - ^ `Color r: 0.588 g: 0.976 b: 0.482`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 18:40:33' prior: 50355061! - lightMagenta - "Override traditional names existing in extended XKCD naming" - ^ `Color r: 0.98 g: 0.372 b: 0.969`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 18:40:22' prior: 50355065! - lightOrange - "Override traditional names existing in extended XKCD naming" - ^ `Color r: 0.992 g: 0.667 b: 0.283`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 18:40:30' prior: 50355077! - lightRed - "Override traditional names existing in extended XKCD naming" - ^ `Color r: 1.0 g: 0.279 b: 0.298`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 18:40:18' prior: 50355081! - lightYellow - "Override traditional names existing in extended XKCD naming" - ^ `Color r: 1.0 g: 0.996 b: 0.478`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 18:53:42' prior: 50355097! - magenta - "Override traditional names existing in XKCD naming" - ^ `Color r: 0.760 g: 0.0 b: 0.471`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 18:55:57' prior: 50355125! - orange - "Override traditional names existing in XKCD naming" - ^ `Color r: 0.976 g: 0.451 b: 0.024`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:00:11' prior: 50355141! - pink - "Override traditional names existing in XKCD naming" - ^ `Color r: 1.0 g: 0.506 b: 0.753`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:03:18' prior: 50355145! - purple - "Override traditional names existing in XKCD naming" - ^ `Color r: 0.494 g: 0.118 b: 0.612`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 18:58:04' prior: 50355149! - red - "Override traditional names existing in XKCD naming" - ^ `Color r: 0.898 g: 0 b: 0`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:05:22' prior: 50355169! - tan - ^ `Color r: 0.820 g: 0.698 b: 0.435`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:04:45' prior: 50355177! - transparent - ^ `TranslucentColor r: 0.0 g: 0.0 b: 0.0 alpha: 0.0`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:04:05' prior: 50355185! - veryDarkGray - ^ `Color r: 0.25 g: 0.25 b: 0.25`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:04:10' prior: 50355189! - veryLightGray - ^ `Color r: 0.75 g: 0.75 b: 0.75`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:05:08' prior: 50355194! - veryVeryDarkGray - ^ `Color r: 0.125 g: 0.125 b: 0.125`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:04:18' prior: 50355199! - veryVeryLightGray - ^ `Color r: 0.875 g: 0.875 b: 0.875`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:04:24' prior: 50355208! - white - ^ `Color r: 1.0 g: 1.0 b: 1.0`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 18:52:36' prior: 50355212! - yellow - "Override traditional names existing in XKCD naming" - ^ `Color r: 1.0 g: 1.0 b: 0.078`! ! -!Color class methodsFor: 'cached state access' stamp: 'jmv 5/12/2016 14:58' prior: 50356475! - releaseClassCachedState - " - Color releaseClassCachedState - " - CachedColormaps _ nil. "Maps to translate between color depths" - ToGrayColormaps _ nil. "Maps colors to 8bpp grays for various color depths" - FromGrayColormaps _ nil. "Maps from 8bpp grays to colors of various depths" - MaskingMap _ nil. "Maps all colors except transparent to black for creating a mask" - ColorNamesDict _ nil. - IndexedColors _ nil. - GrayToIndexMap _ nil! ! - -Color class removeSelector: #aqua! - -Color class removeSelector: #aqua! - -Color class removeSelector: #beige! - -Color class removeSelector: #beige! - -Color class removeSelector: #blueColorDict! - -Color class removeSelector: #blueColorDict! - -Color class removeSelector: #blueColorDict:! - -Color class removeSelector: #blueColorDict:! - -Color class removeSelector: #blueGreenColorDict! - -Color class removeSelector: #blueGreenColorDict! - -Color class removeSelector: #blueGreenColorDict:! - -Color class removeSelector: #blueGreenColorDict:! - -Color class removeSelector: #brightColorDict! - -Color class removeSelector: #brightColorDict! - -Color class removeSelector: #brightColorDict:! - -Color class removeSelector: #brightColorDict:! - -Color class removeSelector: #brightGreen! - -Color class removeSelector: #brightGreen! - -Color class removeSelector: #brownColorDict! - -Color class removeSelector: #brownColorDict! - -Color class removeSelector: #brownColorDict:! - -Color class removeSelector: #brownColorDict:! - -Color class removeSelector: #colorNames! - -Color class removeSelector: #colorNames! - -Color class removeSelector: #colorNamesDict! - -Color class removeSelector: #colorNamesDict! - -Color class removeSelector: #darkBlue! - -Color class removeSelector: #darkBlue! - -Color class removeSelector: #darkColorDict! - -Color class removeSelector: #darkColorDict! - -Color class removeSelector: #darkColorDict:! - -Color class removeSelector: #darkColorDict:! - -Color class removeSelector: #darkGreen! - -Color class removeSelector: #darkGreen! - -Color class removeSelector: #darkPink! - -Color class removeSelector: #darkPink! - -Color class removeSelector: #darkPurple! - -Color class removeSelector: #darkPurple! - -Color class removeSelector: #defaultColorNamesDictionary! - -Color class removeSelector: #defaultColorNamesDictionary! - -Color class removeSelector: #doesNotUnderstand:! - -Color class removeSelector: #doesNotUnderstand:! - -Color class removeSelector: #exactColorNamed:! - -Color class removeSelector: #exactColorNamed:! - -Color class removeSelector: #forestGreen! - -Color class removeSelector: #forestGreen! - -Color class removeSelector: #fromString:! - -Color class removeSelector: #fromString:! - -Color class removeSelector: #grayColorDict:! - -Color class removeSelector: #grayColorDict:! - -Color class removeSelector: #greenColorDict! - -Color class removeSelector: #greenColorDict! - -Color class removeSelector: #greenColorDict:! - -Color class removeSelector: #greenColorDict:! - -Color class removeSelector: #grey! - -Color class removeSelector: #grey! - -Color class removeSelector: #greyColorDict! - -Color class removeSelector: #greyColorDict! - -Color class removeSelector: #greyColorDict:! - -Color class removeSelector: #greyColorDict:! - -Color class removeSelector: #hotPink! - -Color class removeSelector: #hotPink! - -Color class removeSelector: #indigo! - -Color class removeSelector: #indigo! - -Color class removeSelector: #lavender! - -Color class removeSelector: #lavender! - -Color class removeSelector: #lightColorDict! - -Color class removeSelector: #lightColorDict! - -Color class removeSelector: #lightColorDict:! - -Color class removeSelector: #lightColorDict:! - -Color class removeSelector: #lightPink! - -Color class removeSelector: #lightPink! - -Color class removeSelector: #lightPurple! - -Color class removeSelector: #lightPurple! - -Color class removeSelector: #lilac! - -Color class removeSelector: #lilac! - -Color class removeSelector: #lime! - -Color class removeSelector: #lime! - -Color class removeSelector: #limeGreen! - -Color class removeSelector: #limeGreen! - -Color class removeSelector: #maroon! - -Color class removeSelector: #maroon! - -Color class removeSelector: #mauve! - -Color class removeSelector: #mauve! - -Color class removeSelector: #mustard! - -Color class removeSelector: #mustard! - -Color class removeSelector: #navyBlue! - -Color class removeSelector: #navyBlue! - -Color class removeSelector: #olive! - -Color class removeSelector: #olive! - -Color class removeSelector: #oliveGreen! - -Color class removeSelector: #oliveGreen! - -Color class removeSelector: #orangeColorDict! - -Color class removeSelector: #orangeColorDict! - -Color class removeSelector: #orangeColorDict:! - -Color class removeSelector: #orangeColorDict:! - -Color class removeSelector: #paleGreen! - -Color class removeSelector: #paleGreen! - -Color class removeSelector: #pastelColorDict! - -Color class removeSelector: #pastelColorDict! - -Color class removeSelector: #pastelColorDict:! - -Color class removeSelector: #pastelColorDict:! - -Color class removeSelector: #peach! - -Color class removeSelector: #peach! - -Color class removeSelector: #periwinkle! - -Color class removeSelector: #periwinkle! - -Color class removeSelector: #pinkColorDict! - -Color class removeSelector: #pinkColorDict! - -Color class removeSelector: #pinkColorDict:! - -Color class removeSelector: #pinkColorDict:! - -Color class removeSelector: #purpleColorDict! - -Color class removeSelector: #purpleColorDict! - -Color class removeSelector: #purpleColorDict:! - -Color class removeSelector: #purpleColorDict:! - -Color class removeSelector: #redColorDict! - -Color class removeSelector: #redColorDict! - -Color class removeSelector: #redColorDict:! - -Color class removeSelector: #redColorDict:! - -Color class removeSelector: #royalBlue! - -Color class removeSelector: #royalBlue! - -Color class removeSelector: #salmon! - -Color class removeSelector: #salmon! - -Color class removeSelector: #saturatedColorDict! - -Color class removeSelector: #saturatedColorDict! - -Color class removeSelector: #saturatedColorDict:! - -Color class removeSelector: #saturatedColorDict:! - -Color class removeSelector: #seaGreen! - -Color class removeSelector: #seaGreen! - -Color class removeSelector: #setColorNamesDict:! - -Color class removeSelector: #setColorNamesDict:! - -Color class removeSelector: #skyBlue! - -Color class removeSelector: #skyBlue! - -Color class removeSelector: #teal! - -Color class removeSelector: #teal! - -Color class removeSelector: #traditionalColorNamesDictionary! - -Color class removeSelector: #traditionalColorNamesDictionary! - -Color class removeSelector: #turquoise! - -Color class removeSelector: #turquoise! - -Color class removeSelector: #violet! - -Color class removeSelector: #violet! - -Color class removeSelector: #xkcdFirst48ColorNamesDictionary! - -Color class removeSelector: #xkcdFirst48ColorNamesDictionary! - -Color class removeSelector: #yellowColorDict! - -Color class removeSelector: #yellowColorDict! - -Color class removeSelector: #yellowColorDict:! - -Color class removeSelector: #yellowColorDict:! - -Color removeSelector: #closestAssocFrom:! - -Color removeSelector: #closestAssocFrom:! - -Color removeSelector: #closestColor! - -Color removeSelector: #closestColor! - -Color removeSelector: #closestColorAssociation! - -Color removeSelector: #closestColorAssociation! - -Color removeSelector: #closestColorFrom:! - -Color removeSelector: #closestColorFrom:! - -Color removeSelector: #closestColorName! - -Color removeSelector: #closestColorName! - -Color removeSelector: #closestNameFrom:! - -Color removeSelector: #closestNameFrom:! - -Color removeSelector: #isBlueGreen! - -Color removeSelector: #isBlueGreen! - -Color removeSelector: #isBright! - -Color removeSelector: #isBright! - -Color removeSelector: #isBrown! - -Color removeSelector: #isBrown! - -Color removeSelector: #isDark! - -Color removeSelector: #isDark! - -Color removeSelector: #isGray! - -Color removeSelector: #isGray! - -Color removeSelector: #isGrey! - -Color removeSelector: #isGrey! - -Color removeSelector: #isLight! - -Color removeSelector: #isLight! - -Color removeSelector: #isOrange! - -Color removeSelector: #isOrange! - -Color removeSelector: #isPastel! - -Color removeSelector: #isPastel! - -Color removeSelector: #isPink! - -Color removeSelector: #isPink! - -Color removeSelector: #isSaturated! - -Color removeSelector: #isSaturated! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3275-MakeNamedColorsOptional-JuanVuletich-2018Mar12-18h18m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3275] on 12 March 2018 at 8:29:55 pm'! -!Color class methodsFor: 'instance creation' stamp: 'jmv 3/12/2018 19:29:16'! - fromHexString: aString - "For HTML color spec: #FFCCAA. - See http://www.w3schools.com/cssref/css_colors_legal.asp" - " - Color fromHexString: '#FFCCAA'. - " - (aString size = 7 and: [ aString first = $# ]) ifTrue: [ - | aColorHexU red green blue | - aColorHexU _ aString asUppercase. - red _ ('16r', (aColorHexU copyFrom: 2 to: 3)) asNumber/255. - green _ ('16r', (aColorHexU copyFrom: 4 to: 5)) asNumber/255. - blue _ ('16r', (aColorHexU copyFrom: 6 to: 7)) asNumber/255. - ^ self r: red g: green b: blue]. - ^ nil! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 20:28:53' prior: 50389025! - black - "Override traditional names existing in XKCD naming" - ^`Color fromHexString: '#000000'`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:30:14' prior: 50389029! - blue - "Override traditional names existing in XKCD naming" - ^ `Color fromHexString: '#0343df'`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:31:13' prior: 50389035! - brown - "Override traditional names existing in XKCD naming" - ^ `Color fromHexString: '#653700'`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 20:28:59' prior: 50389041! - cyan - "Override traditional names existing in XKCD naming" - ^ `Color fromHexString: '#00ffff'`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:33:50' prior: 50389055! - green - "Override traditional names existing in XKCD naming" - ^ `Color fromHexString: '#15b01a'`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 19:34:21' prior: 50389061! - lightBlue - "Override traditional names existing in XKCD naming" - ^ `Color fromHexString: '#95d0fc'`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 20:12:45' prior: 50389068! -lightBrown - "Override traditional names existing in XKCD naming" - ^ `Color fromHexString: '#ad8150'`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 20:13:44' prior: 50389087! - lightGreen - "Override traditional names existing in XKCD naming" - ^ `Color fromHexString: '#96f97b'`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 20:14:56' prior: 50389122! - magenta - "Override traditional names existing in XKCD naming" - ^ `Color fromHexString: '#c20078'`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 20:15:20' prior: 50389128! - orange - "Override traditional names existing in XKCD naming" - ^ `Color fromHexString: '#f97306'`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 20:16:35' prior: 50389134! - pink - "Override traditional names existing in XKCD naming" - ^ `Color fromHexString: '#ff81c0'`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 20:16:53' prior: 50389140! - purple - "Override traditional names existing in XKCD naming" - ^ `Color fromHexString: '#7e1e9c'`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 20:17:13' prior: 50389146! - red - "Override traditional names existing in XKCD naming" - ^ `Color fromHexString: '#e50000'`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 20:28:47' prior: 50389152! - tan - "Override traditional names existing in XKCD naming" - ^ `Color fromHexString: '#d1b26f'`! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 3/12/2018 20:18:33' prior: 50389187! - yellow - "Override traditional names existing in XKCD naming" - ^ `Color fromHexString: '#ffff14'`! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3276-TweaksToColor-JuanVuletich-2018Mar12-20h27m-jmv.1.cs.st----! - -----SNAPSHOT----#(13 March 2018 3:20:58.566479 pm) Cuis5.0-3276-v3.image priorSource: 1621654! - -----QUIT----#(13 March 2018 3:21:14.516639 pm) Cuis5.0-3276-v3.image priorSource: 1853479! - -----STARTUP----#(13 March 2018 4:40:23.986394 pm) as /home/juan/Rectifier/Cuis-Smalltalk-Dev/Cuis5.0-3276-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3276] on 13 March 2018 at 3:37:57 pm'! -!StdIOReadStream methodsFor: 'streaming' stamp: 'jmv 3/13/2018 15:37:34'! - atEnd - ^ false! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3277-StdIOReadStream-atEnd-JuanVuletich-2018Mar13-15h37m-jmv.1.cs.st----! - -----SNAPSHOT----#(13 March 2018 4:40:29.44499 pm) Cuis5.0-3277-v3.image priorSource: 1853575! - -----QUIT----#(13 March 2018 4:40:52.239446 pm) Cuis5.0-3277-v3.image priorSource: 1854114! - -----STARTUP----#(28 March 2018 9:15:50.713275 am) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3277-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3277] on 19 March 2018 at 3:33:10 pm'! -!Message methodsFor: 'stub creation' stamp: 'HAW 3/19/2018 15:29:03'! - addSetterCodeOn: stream - - stream - newLine; tab; - nextPutAll: selector allButLast; - nextPutAll: ' := '; - nextPutAll: self arguments first argumentName ! ! -!Message methodsFor: 'stub creation' stamp: 'HAW 3/19/2018 15:20:08'! - argumentNameAt: anIndex havingNamed: alreadyNamedArguments - - | argumentName | - - argumentName _ (self arguments at: anIndex) argumentName. - [alreadyNamedArguments includes: argumentName] whileTrue: [argumentName _ argumentName, anIndex asString]. - alreadyNamedArguments add: argumentName. - - ^argumentName! ! -!Message methodsFor: 'stub creation' stamp: 'HAW 3/19/2018 15:26:18'! - writeMessageNameOn: aStream - - | alreadyNamedArguments | - - alreadyNamedArguments _ Set new. - self selector keywords withIndexDo: [ :keyword :index | - aStream nextPutAll: keyword. - self hasArguments ifTrue: [ self writeOn: aStream argumentNameAt: index havingNamed: alreadyNamedArguments ]]. - - ! ! -!Message methodsFor: 'stub creation' stamp: 'HAW 3/19/2018 15:27:23'! - writeOn: aStream argumentNameAt: index havingNamed: alreadyNamedArguments - - | argumentName | - - argumentName _ self argumentNameAt: index havingNamed: alreadyNamedArguments. - - aStream - nextPutAll: ' '; - nextPutAll: argumentName; - space - - ! ! -!Message methodsFor: 'stub creation' stamp: 'HAW 3/19/2018 15:28:33' prior: 50368152! - createStubMethodFor: aClass - - ^ String streamContents: [ :stream | - self writeMessageNameOn: stream. - stream newLine; tab. - self writeShouldBeImplementedOn: stream. - (self isGetterFor: aClass) ifTrue: [ self addGetterCodeOn: stream ]. - (self isSetterFor: aClass) ifTrue: [ self addSetterCodeOn: stream ]. - ]! ! - -Message removeSelector: #addSetterCodeOn:with:! - -Message removeSelector: #addSetterCodeOn:with:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3278-autoGetterAndSetterTweaks-HernanWilkinson-2018Mar19-15h07m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3277] on 22 March 2018 at 12:42:03 pm'! -!Browser methodsFor: 'class list' stamp: 'HAW 3/22/2018 12:40:03' prior: 16791821! -classListIndex: anInteger - "Set anInteger to be the index of the current class selection." - - | className recent canSelectClass | - - canSelectClass _ anInteger between: 1 and: self classList size. - selectedClassName _ canSelectClass ifTrue: [ self classList at: anInteger ]. - self setClassOrganizer. - selectedMessageCategory _ nil. - selectedMessage _ nil. - - self classCommentIndicated ifFalse: [ - self editSelection: (canSelectClass - ifTrue: [#editClass] - ifFalse: [ metaClassIndicated | selectedSystemCategory isNil - ifTrue: [#none] - ifFalse: [#newClass]])]. - - self selectedClass ifNotNil: [ - recent _ self class recentClasses. - className _ self selectedClass name. - (recent includes: className) ifTrue: [recent remove: className]. - recent addFirst: className. - recent size > 16 ifTrue: [recent removeLast]]. - - "We have to refresh the class list if somebody wants to select a class that does not exist anymore - Hernan" - anInteger > self classList size ifTrue: [ self changed: #classList ]. - self changed: #classSelectionChanged. - self changed: #classCommentText. - self changed: #classListIndex. "update my selection" - self changed: #messageCategoryList. - self changed: #messageList. - self changed: #relabel. - self acceptedContentsChanged! ! -!SystemDictionary methodsFor: 'class names' stamp: 'HAW 3/22/2018 12:37:37' prior: 16919340! - forgetClass: aClass logged: aBool - "Delete the class, aClass, from the system. - Note that this doesn't do everything required to dispose of a class - to do that use Class>>removeFromSystem." - - SystemOrganization removeElement: aClass name. - aBool ifTrue: [SystemChangeNotifier uniqueInstance classRemoved: aClass fromCategory: aClass category]. - self removeFromStartUpList: aClass. - self removeFromShutDownList: aClass. - self removeKey: aClass name ifAbsent: nil. - self flushClassNameCache! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3279-ClassRemovalFix-HernanWilkinson-2018Mar22-12h07m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3277] on 22 March 2018 at 3:07:52 pm'! -!SystemDictionary methodsFor: 'class names' stamp: 'HAW 3/22/2018 15:07:34' prior: 50389713! - forgetClass: aClass logged: aBool - "Delete the class, aClass, from the system. - Note that this doesn't do everything required to dispose of a class - to do that use Class>>removeFromSystem." - - | classCategory | - - "I have to keep the cateogory becuase it is nil after removing the class -Hernan" - classCategory _ aClass category. - - SystemOrganization removeElement: aClass name. - aBool ifTrue: [SystemChangeNotifier uniqueInstance classRemoved: aClass fromCategory: classCategory]. - self removeFromStartUpList: aClass. - self removeFromShutDownList: aClass. - self removeKey: aClass name ifAbsent: nil. - self flushClassNameCache! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3280-ClassRemovalFix-HernanWilkinson-2018Mar22-12h42m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3277] on 27 March 2018 at 10:42:25 am'! -!CodePackage methodsFor: 'saving' stamp: 'jmv 3/27/2018 10:31:21'! - writeInitializerExtensionMethods: extensionInitializers on: aStream - "Write the call to package initialization methods in clases not defined in the - package (usually, classes in base system that requires specific init - of stuff that is package extensions)" - - extensionInitializers do: [ :methodReference | - aStream nextChunkPut: methodReference classSymbol asString, ' ' , methodReference selector asString; newLine ]! ! -!CodePackage methodsFor: 'saving' stamp: 'jmv 3/27/2018 10:20:51' prior: 16810570! - write: classes initializersOn: aStream - "Write the call to #initialize method of classes defined in us." - - Smalltalk hierarchySorted: classes do: [ :class | - (class class includesSelector: #initialize) ifTrue: [ - aStream nextChunkPut: class name, ' initialize'; newLine ]]! ! -!CodePackage methodsFor: 'saving' stamp: 'jmv 3/27/2018 10:40:34' prior: 50377186! - writeOnStream: aStream - - | sortedClasses initExtensions | - aStream - nextChunkPut: ('Description ', description) printString; - newLine. - self writeFeatureSpecOn: aStream. - self writeSystemCategoriesOn: aStream. - sortedClasses _ Array streamContents: [ :strm | - self classesInSafeOrderDo: [ :cls | - strm nextPut: cls ]]. - self - write: sortedClasses classDefinitionsOn: aStream; - write: sortedClasses classCommentsOn: aStream; - write: sortedClasses methodsOn: aStream. - initExtensions _ OrderedCollection new. - self - sortedExtensionMethodsDo: [ :methodReference | - methodReference isValid ifTrue: [ - self writeMethod: methodReference on: aStream. - (methodReference selector beginsWith: 'initialize') - ifTrue: [ initExtensions add: methodReference ]]] - displayingProgress: 'Saving extension methods...'. - self write: sortedClasses initializersOn: aStream. - self writeInitializerExtensionMethods: initExtensions on: aStream! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3281-PackageExtensionsInitializers-JuanVuletich-2018Mar27-10h19m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3281] on 28 March 2018 at 9:05:04 am'! - -Object subclass: #StackSizeWatcher - instanceVariableNames: 'watcher timeBetweenChecks stackSizeThreashold' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Profiling'! - -!classDefinition: #StackSizeWatcher category: #'Tools-Profiling'! -Object subclass: #StackSizeWatcher - instanceVariableNames: 'watcher timeBetweenChecks stackSizeThreashold' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Profiling'! - -StackSizeWatcher class - instanceVariableNames: 'current'! - -!classDefinition: 'StackSizeWatcher class' category: #'Tools-Profiling'! -StackSizeWatcher class - instanceVariableNames: 'current'! -!ProcessBrowser methodsFor: 'initialization' stamp: 'jmv 3/28/2018 08:57:18'! -startStackSizeWatcher - - StackSizeWatcher isWatching ifFalse: [ - StackSizeWatcher startWatchingWithDefaults ]! ! -!ProcessBrowser methodsFor: 'initialization' stamp: 'jmv 3/28/2018 08:56:50'! - stopStackSizeWatcher - - StackSizeWatcher stopWatching. - self updateProcessList! ! -!ContextPart methodsFor: 'accessing' stamp: 'HAW 3/27/2018 14:02:09'! - depthBelow - - ^self depthBelow: nil! ! -!ProcessBrowserWindow methodsFor: 'menu commands' stamp: 'jmv 3/28/2018 08:55:53'! - startStackSizeWatcher - - model startStackSizeWatcher! ! -!ProcessBrowserWindow methodsFor: 'menu commands' stamp: 'jmv 3/28/2018 08:56:08'! - stopStackSizeWatcher - model stopStackSizeWatcher! ! -!StackSizeWatcher methodsFor: 'assertions' stamp: 'HAW 3/27/2018 14:16:52'! -assertIsNotWatching - - self isNotWatching ifFalse: [ self error: 'Already watching' ].! ! -!StackSizeWatcher methodsFor: 'assertions' stamp: 'HAW 3/27/2018 14:16:43'! - assertIsWatching - - self isWatching ifFalse: [ self error: 'It is not watching' ]! ! -!StackSizeWatcher methodsFor: 'configuration changing' stamp: 'HAW 3/27/2018 14:21:02'! - changeStackSizeThresholdTo: aThreshold - - stackSizeThreashold _ aThreshold ! ! -!StackSizeWatcher methodsFor: 'configuration changing' stamp: 'HAW 3/27/2018 14:21:17'! - changeTimeBetweenChecksTo: aTimeBetweenChecks - - "time in milliseconds - Hernan" - - timeBetweenChecks _ aTimeBetweenChecks ! ! -!StackSizeWatcher methodsFor: 'testing' stamp: 'HAW 3/27/2018 14:49:41'! - canDebug: aProcess - - ^(ProcessBrowser rulesFor: aProcess) second - -! ! -!StackSizeWatcher methodsFor: 'testing' stamp: 'HAW 3/27/2018 13:51:35'! - isNotWatching - - ^self isWatching not! ! -!StackSizeWatcher methodsFor: 'testing' stamp: 'HAW 3/27/2018 14:55:20'! - isStackTooDeepAt: aProcess - - "aProcess suspendedContext should never be nil under this circunstances but checking that just in case - Hernan" - ^aProcess suspendedContext - ifNil: [ false ] - ifNotNil: [ :topContext | topContext depthBelow > stackSizeThreashold ] - ! ! -!StackSizeWatcher methodsFor: 'testing' stamp: 'HAW 3/27/2018 13:51:28'! - isWatching - - ^watcher notNil ! ! -!StackSizeWatcher methodsFor: 'testing' stamp: 'HAW 3/27/2018 14:49:21'! - shouldStopAndDebug: aProcess - - ^(self isStackTooDeepAt: aProcess) and: [self canDebug: aProcess] - -! ! -!StackSizeWatcher methodsFor: 'start/stop' stamp: 'jmv 3/28/2018 08:50:08'! - startWatching - - self assertIsNotWatching. - - watcher _ [ [self watch] repeat ] newProcess. - watcher priority: Processor lowIOPriority. - watcher name: 'StackSizeWatcher monitor'. - watcher resume. - Processor yield! ! -!StackSizeWatcher methodsFor: 'start/stop' stamp: 'HAW 3/27/2018 14:19:22'! - startWatchingAt: aTimeBetweenChecks informingWhenStackSizeBiggerThan: aThreshold - - self assertIsNotWatching. - - self changeTimeBetweenChecksTo: aTimeBetweenChecks. - self changeStackSizeThresholdTo: aThreshold. - self startWatching ! ! -!StackSizeWatcher methodsFor: 'start/stop' stamp: 'HAW 3/27/2018 13:50:21'! - stopWatching - - self assertIsWatching. - - watcher terminate. - watcher _ nil! ! -!StackSizeWatcher methodsFor: 'private' stamp: 'HAW 3/27/2018 14:53:56'! - debug: aProcess - - aProcess debugFullWithTitle: 'Interrupted - Stack too deep'. -! ! -!StackSizeWatcher methodsFor: 'private' stamp: 'HAW 3/27/2018 14:47:26'! - watch - - | processToWatch | - - (Delay forMilliseconds: timeBetweenChecks) wait. - processToWatch := Processor nextReadyProcess. - (self shouldStopAndDebug: processToWatch) ifTrue: [ self debug: processToWatch ] -! ! -!StackSizeWatcher class methodsFor: 'current' stamp: 'HAW 3/27/2018 14:12:49'! - current - - current isNil ifTrue: [ current _ self new ]. - ^current! ! -!StackSizeWatcher class methodsFor: 'current' stamp: 'HAW 3/27/2018 14:15:30'! - resetCurrent - - current _ nil! ! -!StackSizeWatcher class methodsFor: 'defaults' stamp: 'HAW 3/27/2018 14:20:12'! - defaultStackSizeThreshold - - ^2000! ! -!StackSizeWatcher class methodsFor: 'defaults' stamp: 'HAW 3/27/2018 14:07:34'! - defaultTimeBetweenChecks - - "Time in milliseconds - Hernan" - ^10! ! -!StackSizeWatcher class methodsFor: 'start/stop' stamp: 'jmv 3/28/2018 08:54:09'! - isWatching - ^ current notNil and: [ current isWatching ]! ! -!StackSizeWatcher class methodsFor: 'start/stop' stamp: 'HAW 3/27/2018 14:19:58'! - startWatchingAt: aTimeBetweenChecks informingWhenStackSizeBiggerThan: aThreshold - - ^self current startWatchingAt: aTimeBetweenChecks informingWhenStackSizeBiggerThan: aThreshold -! ! -!StackSizeWatcher class methodsFor: 'start/stop' stamp: 'HAW 3/27/2018 14:20:22'! - startWatchingWithDefaults - - ^self startWatchingAt: self defaultTimeBetweenChecks informingWhenStackSizeBiggerThan: self defaultStackSizeThreshold! ! -!StackSizeWatcher class methodsFor: 'start/stop' stamp: 'HAW 3/27/2018 14:15:17'! - stopWatching - - self current stopWatching. - self resetCurrent ! ! -!ProcessBrowserWindow methodsFor: 'menu building' stamp: 'jmv 3/28/2018 08:58:40' prior: 16895341! - processListMenu - | menu rules | - menu _ MenuMorph new defaultTarget: self. - - model selectedProcess - ifNotNil: [ :selectedProcess | - rules _ model class rulesFor: model selectedProcess. - menu addList: #( - ('inspect (i)' #inspectProcess) - ('explore (I)' #exploreProcess) - ('references finder' #openReferencesFinder)). - rules first - ifTrue: [ - menu add: 'terminate (t)' target: model action: #terminateProcess. - selectedProcess isSuspended - ifTrue: [menu add: 'resume (r)' target: model action: #resumeProcess] - ifFalse: [menu add: 'suspend (s)' target: model action: #suspendProcess]]. - rules second - ifTrue: [ - menu addList: #( - ('change priority (p)' #changePriority) - ('debug (d)' #debugProcess))]. - (selectedProcess suspendingList isKindOf: Semaphore) - ifTrue: [menu add: 'signal Semaphore (S)' target: model action: #signalSemaphore]. - menu add: 'full stack (k)' target: model action: #moreStack. - menu addLine]. - - menu addList: #( - ('find context... (f)' #findContext) - ('find again (g)' #nextContext '' model)). - menu addLine. - - menu - add: (isStepping - ifTrue: ['turn off auto-update (a)'] - ifFalse: ['turn on auto-update (a)']) - action: #toggleAutoUpdate. - menu add: 'update list (u)' target: model action: #updateProcessList. - - menu addLine. - CPUWatcher isMonitoring - ifTrue: [ menu add: 'stop CPUWatcher' action: #stopCPUWatcher ] - ifFalse: [ menu add: 'start CPUWatcher' action: #startCPUWatcher ]. - StackSizeWatcher isWatching - ifTrue: [ menu add: 'stop StackSizeWatcher' action: #stopStackSizeWatcher ] - ifFalse: [ menu add: 'start StackSizeWatcher' action: #startStackSizeWatcher ]. - - ^ menu! ! -!Theme methodsFor: 'menus' stamp: 'jmv 3/28/2018 09:03:29' prior: 50376430! - basicIcons - - "Minimal menu scheme. - Theme current class beCurrent - " - - ^ { - #('open...') -> #openIcon. - #('windows...' 'find window' 'Focus follows mouse' 'Click to focus') -> #windowIcon. - #('help...' 'explain' 'about this system...' 'Terse Guide to Cuis' 'Class Comment Browser' 'Code management in Cuis' 'Using GitHub to host Cuis packages' ) -> #helpIcon. - #('themes...') -> #appearanceIcon. - #('do it (d)') -> #doItIcon. - #('new morph...' 'objects (o)' 'save world as morph file') -> #morphsIcon. - #('save' ) -> #saveIcon. - #('Save options...' 'save as...' 'change category...' 'rename change set (r)' 'rename') -> #saveAsIcon. - #('save as new version') -> #saveAsNewVersionIcon. - #('quit') -> #quitIcon. - #('save and quit' ) -> #saveAndQuitIcon. - #('inspect it (i)' 'inspect world' 'inspect model' 'inspect morph' - 'inspect owner chain' 'inspect' 'inspect (i)' 'basic inspect' 'message names' 'find message names' 'inspect instances' 'inspect subinstances' 'inspect change set' 'inspect context (c)' 'inspect receiver (i)' 'start CPUWatcher' 'stop CPUWatcher') - -> #inspectIcon. - #('explore' 'explore it (I)' 'explore world' 'explore morph' 'explore (I)' 'explore context (C)' 'explore receiver (I)' 'references finder' 'weight explorer' 'explore CompiledMethod') -> #exploreIcon. - #('find...(f)' 'find class... (f)' 'find method...' 'find recent submissions' 'show hierarchy' 'show definition' 'show comment' 'filter' 'filter message list...' 'find context... (f)') -> #findIcon. - #('add item...' 'new category...' 'create new change set...' 'new change set... (n)' 'add new file') -> #newIcon. - #('remove method (x)' 'remove' 'remove class (x)' 'remove method from system (x)' 'remove class from system (x)' 'remove postscript''stop StackSizeWatcher' ) -> #deleteIcon. - #('delete method from changeset (d)' 'delete class from change set (d)' 'destroy change set (X)' 'revert & remove from changes' 'delete unchanged windows' 'delete non windows' 'delete both of the above' 'reset variables' 'remove contained in class categories...' 'clear this change set' 'uninstall this change set' 'delete directory...' 'delete' 'start StackSizeWatcher') -> #warningIcon. - #('do again (j)' 'Redo - multiple (Z)') -> #redoIcon. - #('undo (z)' 'revert to previous version' 'Undo - multiple (z)') -> #undoIcon. - #('copy to clipboard (c)' 'copy (c)' 'copy class...' 'copy class chgs to other side' 'copy method to other side' 'copy all to other side (c)' 'copy name to clipboard' 'copy selector to clipboard') -> #copyIcon. - #('paste (v)' 'Paste without Format') -> #pasteIcon. - #('cut (x)' 'move class chgs to other side' 'move method to other side' 'submerge into other side') -> #cutIcon. - #('paste...' 'icons...') -> #worldIcon. -}! ! -!Theme methodsFor: 'menus' stamp: 'jmv 3/28/2018 09:03:59' prior: 50338800! - miscellaneousIcons - - "Everything else." - - ^ { - #('restore display (r)' 'set display depth...' 'move windows onscreen' 'Utilities saveDisplay.') -> #displayIcon. - #('changes...' 'dual change sorter' 'change sets with this method' 'find a change sorter' 'recent changes in file' 'Undo / Redo history' 'code file contents' 'package file contents') -> #changesIcon. - #('Install New Updates' 'update' 'turn on auto-update (a)' 'update list (u)' 'install code' 'fileIn entire file' 'install package') -> #updateIcon. - #('find again (g)' 'full stack (k)') -> #systemIcon. - #('print it (p)' 'check change set for slips') -> #printIcon. - #('accept (s)' 'make changes go to me (m)') -> #acceptIcon. - #('cancel (l)' 'turn off auto-update (a)' 'stop StackSizeWatcher') -> #cancelIcon. - #('debug...' 'Debug it (D)' 'toggle break on entry') -> #debugIcon. - #('close' 'close all debuggers' 'close top window') -> #closeIcon. - #('collapse' 'hide taskbar' 'collapse all windows') -> #collapseIcon. - #('expand / contract' 'show taskbar' 'restore all windows') -> #expandIcon. - #('menu') -> #windowMenuIcon. - #('browse all' 'browser' 'browse it (b)' 'MessageTally UI and browse' 'browse recent submissions' 'browse full (b)' 'find changed browsers...' 'browse (b)' 'browse my changes') -> #editFindReplaceIcon. - #('workspace' 'workspace with contents') -> #terminalIcon. - #('styled text editor' 'text editor' 'basic text editor' 'unicode editor' 'edit this list' 'edit postscript...' 'add postscript...') -> #textEditorIcon. - #('file list' 'find a fileList' 'compress file') -> #systemFileManagerIcon. - #('transcript' 'find a transcript' 'Transcript clear.' 'log to transcript') -> #printerIcon. - #('process browser' 'vm statistics' 'MessageTally all Processes') -> #systemMonitorIcon. - #('emergency evaluator' 'conflicts with other change sets' 'check for slips' 'conflicts with change set opposite' 'conflicts with category opposite') -> #emblemImportantIcon. - #('change sorter') -> #halfRefreshIcon. - #('SUnit Test Runner' 'Accept & Run Test in Class (t)' 'Accept & Run Test in Category (y)' 'Run tests (t)' 'Run tests' 'Run test (t)' 'Accept & Debug Test (r)' 'Debug test (r)') -> #weatherFewCloudsIcon. - #('Font Sizes...' 'system fonts...' 'set font... (k)') -> #preferencesDesktopFontIcon. - #('full screen on') -> #viewFullscreenIcon. - #('full screen off') -> #exitFullscreenIcon. - #('set desktop color...') -> #wallpaperIcon. - #('preferences...' 'All preferences...' 'what to show...' 'view as hex') -> #preferencesIcon. - #('Editor keyboard shortcuts') -> #keyboardShortcutsIcon. - #('world menu help') -> #globeIcon. "currently unused, but a neat icon" - #('useful expressions' 'class comments with it' 'check for uncommented methods' 'check for uncommented classes') -> #chatIcon. - #('set code author...' 'check for other authors' 'check for any other authors') -> #usersIcon. - #('space left') -> #removableMediaIcon. - #('start drawing all again' 'window color...') -> #graphicsIcon. - #('start stepping again') -> #mediaPlaybackStartIcon. - #('file out current change set' 'fileOut' 'File out and remove (o)' 'File out and keep (k)') -> #fileOutIcon. - #('recently logged changes...' 'versions (v)' 'recent classes... (r)' 'trim history' 'Profile it') -> #clockIcon. - #('senders of it (n)' 'senders of... (n)' 'local senders of...' 'senders (n)') -> #mailForwardIcon. - #('implementors of it (m)' 'implementors of... (m)' 'implementors of sent messages') -> #developmentIcon. - #('references to it (N)') -> #addressBookIcon. - #('class var refs...' 'class refs (N)' 'class variables' 'class vars' 'local implementors of...' 'subclass template') -> #classIcon. - #('inst var refs...' 'inst var defs...' 'sample instance') -> #instanceIcon. - #('Use Selection for Find (j)' 'rename class ...' 'rename...' 'change title...') -> #saveAsIcon. - #('smalltalk options' 'method source with it' 'browse method (O)' 'check for uncategorized methods') -> #scriptIcon. - #('method strings with it (E)' 'Toggle WordWrap') -> #genericTextIcon. - #('browse hierarchy (h)' 'move to top' 'promote to top of list') -> #goTopIcon. - #('move up' 'make next-to-topmost') -> #goUpIcon. - #('move to bottom' 'send to back' 'send top window to back') -> #goBottomIcon. - #('inheritance (i)' 'move down') -> #goDownIcon. - #('browse protocol (p)' 'spawn sub-protocol') -> #spreadsheetIcon. - #('spawn full protocol') -> #speadsheetTemplateIcon. - #('alphabetize') -> #fontXGenericIcon. - #('Installed Packages' 'browse' 'show category (C)' 'categorize all uncategorized' 'select change set...' 'view affected class categories') -> #packageIcon. - #('remove from current change set' 'remove empty categories' 'subtract other side (-)' 'remove from this browser') -> #listRemoveIcon. - #('add to current change set' 'add all meths to current chgs' 'add preamble (p)' 'More...') -> #listAddIcon. - #('toggle diffing (D)' 'toggle selections') -> #switchIcon. - #('reorganize' 'create inst var accessors' 'ChangeSorter reorderChangeSets.' 'reorder all change sets' 'by name' 'by size' 'by date') -> #sendReceiveIcon. - #('unsent methods' 'unreferenced class vars' 'unreferenced inst vars' 'Undeclared inspect.' 'Undeclared removeUnreferencedKeys; inspect.' 'ChangeSorter removeEmptyUnnamedChangeSets.' 'check for unsent messages') -> #junkIcon. - #('find changed windows...') -> #newWindowIcon. - #('make undraggable') -> #pushPinIcon. - #('Utilities saveScreenshot.') -> #stillCameraIcon. - #('add new directory') -> #newFolderIcon. - #('select all' 'deselect all') -> #selectAllIcon. - #('sort by date') -> #dateIcon. - #('justified') -> #formatJustifyFillIcon. - #('centered') -> #formatJustifyCenterIcon. - #('set alignment...' 'leftFlush') -> #formatJustifyLeftIcon. - #('rightFlush') -> #formatJustifyRightIcon. - #('signal Semaphore (S)') -> #haloHelpIcon. - #('Change Paragraph Style...' 'Change Character Style...' 'Remove Character Style' 'Replace all uses of Paragraph Style...' 'Replace all uses of Character Style...' 'Set Default Font...') -> #fontXGenericIcon. - #('Clear Font') -> #newIcon. - #('code file browser' 'package file browser') -> #findIcon. - }! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3282-StackGrowthAlert-HernanWilkinson-2018Mar28-08h47m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3282] on 27 March 2018 at 5:11:12 pm'! -!InspectorWindow methodsFor: 'accessing' stamp: 'HAW 3/27/2018 17:07:55'! - classDefinitionChangedFrom: oldClass to: newClass - - model ifNotNil: [ model object class = newClass ifTrue: [ model changed: #fieldList ]]! ! -!InspectorWindow methodsFor: 'accessing' stamp: 'HAW 3/27/2018 17:07:24'! - model: aModel - - super model: aModel. - model ifNotNil: [ - SystemChangeNotifier uniqueInstance - when: #classDefinitionChanged send: #classDefinitionChangedFrom:to: to: self ] -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3283-UpdateInspectorOnClassShapeChange-HernanWilkinson-2018Mar19-15h33m-HAW.2.cs.st----! - -----SNAPSHOT----#(28 March 2018 9:15:59.75432 am) Cuis5.0-3283-v3.image priorSource: 1854209! - -----QUIT----#(28 March 2018 9:16:17.83412 am) Cuis5.0-3283-v3.image priorSource: 1879631! - -----STARTUP----#(15 April 2018 7:35:02.119502 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3283-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3283] on 31 March 2018 at 11:34:13 pm'! -!SequenceableCollection methodsFor: 'testing' stamp: 'HAW 3/31/2018 23:26:34'! - ifInBounds: anIndex ifNot: aValuable - - ^(self isInBounds: anIndex) ifTrue: [ anIndex ] ifFalse: aValuable ! ! -!SequenceableCollection methodsFor: 'testing' stamp: 'HAW 3/31/2018 23:26:24'! - isInBounds: anIndex - - ^anIndex between: 1 and: self size! ! -!SequenceableCollection methodsFor: 'accessing' stamp: 'HAW 3/31/2018 23:26:53' prior: 16905458! - 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." - - (self isInBounds: index) ifTrue: [^self at: index]. - ^exceptionBlock value! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3284-SequenceableCollection-boundsChecking-HernanWilkinson-2018Mar31-23h26m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3283] on 31 March 2018 at 11:37:37 pm'! -!Browser methodsFor: 'class list' stamp: 'HAW 3/31/2018 23:34:42' prior: 50389670! - classListIndex: anInteger - "Set anInteger to be the index of the current class selection." - - | className recent canSelectClass classList | - - classList _ self classList. - canSelectClass _ classList isInBounds: anInteger. - selectedClassName _ canSelectClass ifTrue: [ classList at: anInteger ]. - self setClassOrganizer. - selectedMessageCategory _ nil. - selectedMessage _ nil. - - self classCommentIndicated ifFalse: [ - self editSelection: (canSelectClass - ifTrue: [#editClass] - ifFalse: [ metaClassIndicated | selectedSystemCategory isNil - ifTrue: [#none] - ifFalse: [#newClass]])]. - - self selectedClass ifNotNil: [ - recent _ self class recentClasses. - className _ self selectedClass name. - (recent includes: className) ifTrue: [recent remove: className]. - recent addFirst: className. - recent size > 16 ifTrue: [recent removeLast]]. - - "We have to refresh the class list if somebody wants to select a class that does not exist anymore - Hernan" - anInteger > classList size ifTrue: [ self changed: #classList ]. - self changed: #classSelectionChanged. - self changed: #classCommentText. - self changed: #classListIndex. "update my selection" - self changed: #messageCategoryList. - self changed: #messageList. - self changed: #relabel. - self acceptedContentsChanged! ! -!Browser methodsFor: 'message category list' stamp: 'HAW 3/31/2018 23:35:18' prior: 16792196! - messageCategoryListIndex: anInteger - "Set the selected message category to be the one indexed by anInteger." - - | index messageCategoryList | - - messageCategoryList _ self messageCategoryList. - index _ messageCategoryList ifInBounds: anInteger ifNot: 0. - - selectedMessageCategory _ index = 0 ifFalse: [messageCategoryList at: index ]. - selectedMessage _ nil. - self changed: #messageCategorySelectionChanged. - self changed: #messageCategoryListIndex. "update my selection" - self changed: #messageList. - self editSelection: (index > 0 - ifTrue: [#newMessage] - ifFalse: [self classListIndex > 0 - ifTrue: [#editClass] - ifFalse: [#newClass]]). - self acceptedContentsChanged.! ! -!Browser methodsFor: 'message list' stamp: 'HAW 3/31/2018 23:35:30' prior: 16792405! - messageListIndex: anInteger - "Set the selected message selector to be the one indexed by anInteger." - - | index messageList | - - messageList _ self messageList. - index _ messageList ifInBounds: anInteger ifNot: 0. - - selectedMessage _ index = 0 ifFalse: [ messageList at: index ]. - self editSelection: (index > 0 - ifTrue: [#editMessage] - ifFalse: [self messageCategoryListIndex > 0 - ifTrue: [#newMessage] - ifFalse: [self classListIndex > 0 - ifTrue: [#editClass] - ifFalse: [#newClass]]]). - self changed: #messageListIndex. "update my selection" - self acceptedContentsChanged! ! -!Browser methodsFor: 'system category list' stamp: 'HAW 3/31/2018 23:35:42' prior: 16792786! - systemCategoryListIndex: anInteger - "Set the selected system category index to be anInteger. Update all other - selections to be deselected." - - | index systemCategoryList | - - systemCategoryList _ self systemCategoryList. - index _ systemCategoryList ifInBounds: anInteger ifNot: 0. - - selectedSystemCategory _ index = 0 ifFalse: [ systemCategoryList at: index ]. - selectedClassName _ nil. - selectedMessageCategory _ nil. - selectedMessage _ nil. - self editSelection: ( index = 0 ifTrue: [#none] ifFalse: [#newClass]). - metaClassIndicated _ false. - self setClassOrganizer. - self changed: #systemCategorySelectionChanged. - self changed: #systemCategoryListIndex. "update my selection" - self changed: #classList. - self changed: #messageCategoryList. - self changed: #messageList. - self changed: #relabel. - self changed: #instanceMessagesIndicated. - self changed: #classCommentIndicated. - self changed: #classMessagesIndicated. - self acceptedContentsChanged! ! -!HierarchyBrowser methodsFor: 'initialization' stamp: 'HAW 3/31/2018 23:36:09' prior: 16853533! - classListIndex: newIndex - - "Cause system organization to reflect appropriate category" - - | newClassName ind i | - - (classList isInBounds: newIndex) ifTrue: [ - newClassName _ (classList at: newIndex) copyWithout: $ . - i _ systemOrganizer numberOfCategoryOfElement: newClassName. - selectedSystemCategory _ i = 0 ifFalse: [ self systemCategoryList at: i]]. - ind _ super classListIndex: newIndex. - self changed: #systemCategorySingleton. - ^ ind! ! -!MessageSet methodsFor: 'message list' stamp: 'HAW 3/31/2018 23:36:45' prior: 16869855! - messageListIndex: anInteger - - "Set the index of the selected item to be anInteger." - - | list | - - list _ self messageList. - selectedMessage _ (list isInBounds: anInteger) ifTrue: [ list at: anInteger ]. - self changed: #messageListIndex. "update my selection" - self editSelection: #editMessage. - self acceptedContentsChanged! ! -!TimeProfileBrowser methodsFor: 'message list' stamp: 'HAW 3/31/2018 23:37:17' prior: 16937837! - messageListIndex: anInteger - - "Set the index of the selected item to be anInteger." - - selectedMessage _ (talliesList isInBounds: anInteger) ifTrue: [ talliesList at: anInteger ]. - self changed: #messageListIndex. "update my selection" - self editSelection: #editMessage. - self acceptedContentsChanged! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3285-Browser-SelectionIndexChecks-HernanWilkinson-2018Mar31-23h34m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3285] on 4 April 2018 at 3:16:11 pm'! -!AbstractFont methodsFor: 'measuring' stamp: 'jmv 4/4/2018 14:46:40'! - normalizedWidthOf: aCharacter - "Return the width of the given character, irrespective of point size." - ^ (self widthOf: aCharacter) / self pointSize! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3286-normalizedWidthOf-JuanVuletich-2018Apr04-14h46m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3286] on 4 April 2018 at 4:53:28 pm'! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipLeft clipTop clipRight clipBottom shadowColor transformations currentTransformation cti currentMorph ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipLeft clipTop clipRight clipBottom shadowColor transformations currentTransformation cti currentMorph' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3287-removeUnusedIvar-JuanVuletich-2018Apr04-16h43m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3285] on 5 April 2018 at 2:33:05 pm'! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 4/5/2018 13:35:59' prior: 50343605! - should: aBlock raise: anExceptionHandlingCondition withExceptionDo: assertionsBlock description: aFailDescription - - | result | - - [result := aBlock value ] - on: anExceptionHandlingCondition - do: [ :anException | - assertionsBlock value: anException. - ^result ]. - - self failWith: aFailDescription! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3288-shouldraise-fix-HernanWilkinson-2018Apr05-14h11m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3283] on 13 April 2018 at 4:53:18 pm'! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 4/13/2018 16:51:04' prior: 50386817! - displayOn: aForm in: aRectangle - " - 1 to: 2000 do: [ :i | i print ]. - 1 to: 750 do: [ :i | i print ]. - Transcript displayOn: Display in: bounds - " - | font count string x y fh canvas innerR index | - aForm fill: aRectangle fillColor: `Color white`. - font _ AbstractFont default. - - innerR _ aRectangle insetBy: self padding. - canvas _ aForm getCanvas. - canvas newClipRect: innerR. - x _ innerR left. - y _ innerR top. - fh _ font height. - count _ lastIndex - firstIndex \\ self maxEntries + 1 min: innerR height // fh - 1. - index _ lastIndex - count \\ self maxEntries + 1. - count timesRepeat: [ - string _ entries at: index. - canvas drawString: string at: x@y font: font color: `Color veryDarkGray`. - y _ y + fh. - index _ index \\ self maxEntries + 1 ]. - string _ unfinishedEntry contents. - canvas drawString: string at: x@y font: font color: `Color veryDarkGray`! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3289-Transcript-fix-JuanVuletich-2018Apr13-16h20m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3285] on 12 April 2018 at 1:37:31 pm'! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'HAW 4/12/2018 13:36:40' prior: 16806621! - definition - "Answer a String that defines the receiver." - - ^String streamContents: [ :strm | - strm - nextPutAll: (superclass ifNotNil: [ superclass name ] ifNil: [ 'ProtoObject' ]); - nextPutAll: self kindOfSubclass; - store: self name. - strm - newLine; - tab; - nextPutAll: 'instanceVariableNames: '; - store: self instanceVariablesString. - strm - newLine; - tab; - nextPutAll: 'classVariableNames: '; - store: self classVariablesString. - strm - newLine; - tab; - nextPutAll: 'poolDictionaries: '; - store: self sharedPoolsString. - strm - newLine; - tab; - nextPutAll: 'category: '; - store: self category asString. - - superclass ifNil: [ - strm nextPutAll: '.'; newLine. - strm nextPutAll: self name. - strm space; nextPutAll: 'superclass: nil' ]]! ! -!SmallFloat64 class methodsFor: 'fileIn/Out' stamp: 'HAW 4/12/2018 13:35:41' prior: 16908567! - definition - "Special class definition for Character, SmallInteger and SmallFloat64 - Required to have the same definition both for preSpur and Spur, and to be compatible with both." - ^ -'Float immediateSubclass: #SmallFloat64 - instanceVariableNames: '''' - classVariableNames: '''' - poolDictionaries: '''' - category: ''', self category, '''' -! ! -!SmallInteger class methodsFor: 'fileIn/Out' stamp: 'HAW 4/12/2018 13:35:04' prior: 16909202! - definition - "Special class definition for Character, SmallInteger and SmallFloat64 - Required to have the same definition both for preSpur and Spur, and to be compatible with both." - ^ -'Integer immediateSubclass: #SmallInteger - instanceVariableNames: '''' - classVariableNames: '''' - poolDictionaries: '''' - category: ''', self category, ''''! ! -!Character class methodsFor: 'fileIn/Out' stamp: 'HAW 4/12/2018 13:36:49' prior: 50375906! - definition - "Special class definition for Character, SmallInteger and SmallFloat64 - Required to have the same definition both for preSpur and Spur, and to be compatible with both." - ^ -'Object immediateSubclass: #Character - instanceVariableNames: ''value'' - classVariableNames: ''CharacterTable UnaccentedTable UnicodeCodePoints LowercaseMappingTable LowercaseTruthTable UppercaseMappingTable UppercaseTruthTable LetterTruthTable'' - poolDictionaries: '''' - category: ''', self category, '''' -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3290-ImmediateClasses-definition-HernanWilkinson-2018Apr12-13h34m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3285] on 14 April 2018 at 7:50:08 pm'! -!Theme methodsFor: 'menus - private' stamp: 'HAW 4/12/2018 15:53:55'! - basicIconsTypeSelector - - ^#addBasicIconsTo:! ! -!Theme methodsFor: 'menus - private' stamp: 'HAW 4/14/2018 19:47:32'! - iconDefinersFor: anIconTypeSelector - - ^(Smalltalk allClassesImplementing: anIconTypeSelector) - select: [ :aClass | aClass isMeta ] - thenCollect: [ :aClass | aClass soleInstance ]. - ! ! -!Theme methodsFor: 'menus - private' stamp: 'HAW 4/14/2018 19:47:39'! - iconsDefinitionFor: anIconTypeSelector - - ^(self iconDefinersFor: anIconTypeSelector) - inject: OrderedCollection new - into: [ :definition :iconDefiner | - iconDefiner perform: anIconTypeSelector with: definition. - definition ]! ! -!Theme methodsFor: 'menus - private' stamp: 'HAW 4/12/2018 16:00:19'! - miscellaneousIconsTypeSelector - - ^#addMiscellaneousIconsTo: -! ! -!Theme class methodsFor: 'icons by menu' stamp: 'HAW 4/14/2018 19:44:24'! - addBasicIconsTo: aCollectorCollection - - aCollectorCollection - add: #('open...') -> #openIcon; - add: #('windows...' 'find window' 'Focus follows mouse' 'Click to focus') -> #windowIcon; - add: #('help...' 'explain' 'about this system...' 'Terse Guide to Cuis' 'Class Comment Browser' 'Code management in Cuis' 'Using GitHub to host Cuis packages' ) -> #helpIcon; - add: #('themes...') -> #appearanceIcon; - add: #('do it (d)') -> #doItIcon; - add: #('new morph...' 'objects (o)' 'save world as morph file') -> #morphsIcon; - add: #('save' ) -> #saveIcon; - add: #('Save options...' 'save as...' 'change category...' 'rename change set (r)' 'rename') -> #saveAsIcon; - add: #('save as new version') -> #saveAsNewVersionIcon; - add: #('quit') -> #quitIcon; - add: #('save and quit' ) -> #saveAndQuitIcon; - add: #('inspect it (i)' 'inspect world' 'inspect model' 'inspect morph' - 'inspect owner chain' 'inspect' 'inspect (i)' 'basic inspect' 'message names' 'find message names' 'inspect instances' 'inspect subinstances' 'inspect change set' 'inspect context (c)' 'inspect receiver (i)' 'start CPUWatcher' 'stop CPUWatcher') - -> #inspectIcon; - add: #('explore' 'explore it (I)' 'explore world' 'explore morph' 'explore (I)' 'explore context (C)' 'explore receiver (I)' 'references finder' 'weight explorer' 'explore CompiledMethod') -> #exploreIcon; - add: #('find...(f)' 'find class... (f)' 'find method...' 'find recent submissions' 'show hierarchy' 'show definition' 'show comment' 'filter' 'filter message list...' 'find context... (f)') -> #findIcon; - add: #('add item...' 'new category...' 'create new change set...' 'new change set... (n)' 'add new file') -> #newIcon; - add: #('remove method (x)' 'remove' 'remove class (x)' 'remove method from system (x)' 'remove class from system (x)' 'remove postscript''stop StackSizeWatcher' ) -> #deleteIcon; - add: #('delete method from changeset (d)' 'delete class from change set (d)' 'destroy change set (X)' 'revert & remove from changes' 'delete unchanged windows' 'delete non windows' 'delete both of the above' 'reset variables' 'remove contained in class categories...' 'clear this change set' 'uninstall this change set' 'delete directory...' 'delete' 'start StackSizeWatcher') -> #warningIcon; - add: #('do again (j)' 'Redo - multiple (Z)') -> #redoIcon; - add: #('undo (z)' 'revert to previous version' 'Undo - multiple (z)') -> #undoIcon; - add: #('copy to clipboard (c)' 'copy (c)' 'copy class...' 'copy class chgs to other side' 'copy method to other side' 'copy all to other side (c)' 'copy name to clipboard' 'copy selector to clipboard') -> #copyIcon; - add: #('paste (v)' 'Paste without Format') -> #pasteIcon; - add: #('cut (x)' 'move class chgs to other side' 'move method to other side' 'submerge into other side') -> #cutIcon; - add: #('paste...' 'icons...') -> #worldIcon -! ! -!Theme class methodsFor: 'icons by menu' stamp: 'HAW 4/14/2018 19:42:09'! - addMiscellaneousIconsTo: aCollectorCollection - - aCollectorCollection - add: #('restore display (r)' 'set display depth...' 'move windows onscreen' 'Utilities saveDisplay.') -> #displayIcon; - add: #('changes...' 'dual change sorter' 'change sets with this method' 'find a change sorter' 'recent changes in file' 'Undo / Redo history' 'code file contents' 'package file contents') -> #changesIcon; - add: #('Install New Updates' 'update' 'turn on auto-update (a)' 'update list (u)' 'install code' 'fileIn entire file' 'install package') -> #updateIcon; - add: #('find again (g)' 'full stack (k)') -> #systemIcon; - add: #('print it (p)' 'check change set for slips') -> #printIcon; - add: #('accept (s)' 'make changes go to me (m)') -> #acceptIcon; - add: #('cancel (l)' 'turn off auto-update (a)' 'stop StackSizeWatcher') -> #cancelIcon; - add: #('debug...' 'Debug it (D)' 'toggle break on entry') -> #debugIcon; - add: #('close' 'close all debuggers' 'close top window') -> #closeIcon; - add: #('collapse' 'hide taskbar' 'collapse all windows') -> #collapseIcon; - add: #('expand / contract' 'show taskbar' 'restore all windows') -> #expandIcon; - add: #('menu') -> #windowMenuIcon; - add: #('browse all' 'browser' 'browse it (b)' 'MessageTally UI and browse' 'browse recent submissions' 'browse full (b)' 'find changed browsers...' 'browse (b)' 'browse my changes') -> #editFindReplaceIcon; - add: #('workspace' 'workspace with contents') -> #terminalIcon; - add: #('styled text editor' 'text editor' 'basic text editor' 'unicode editor' 'edit this list' 'edit postscript...' 'add postscript...') -> #textEditorIcon; - add: #('file list' 'find a fileList' 'compress file') -> #systemFileManagerIcon; - add: #('transcript' 'find a transcript' 'Transcript clear.' 'log to transcript') -> #printerIcon; - add: #('process browser' 'vm statistics' 'MessageTally all Processes') -> #systemMonitorIcon; - add: #('emergency evaluator' 'conflicts with other change sets' 'check for slips' 'conflicts with change set opposite' 'conflicts with category opposite') -> #emblemImportantIcon; - add: #('change sorter') -> #halfRefreshIcon; - add: #('SUnit Test Runner' 'Accept & Run Test in Class (t)' 'Accept & Run Test in Category (y)' 'Run tests (t)' 'Run tests' 'Run test (t)' 'Accept & Debug Test (r)' 'Debug test (r)') -> #weatherFewCloudsIcon; - add: #('Font Sizes...' 'system fonts...' 'set font... (k)') -> #preferencesDesktopFontIcon; - add: #('full screen on') -> #viewFullscreenIcon; - add: #('full screen off') -> #exitFullscreenIcon; - add: #('set desktop color...') -> #wallpaperIcon; - add: #('preferences...' 'All preferences...' 'what to show...' 'view as hex') -> #preferencesIcon; - add: #('Editor keyboard shortcuts') -> #keyboardShortcutsIcon; - add: #('world menu help') -> #globeIcon; "currently unused, but a neat icon" - add: #('useful expressions' 'class comments with it' 'check for uncommented methods' 'check for uncommented classes') -> #chatIcon; - add: #('set code author...' 'check for other authors' 'check for any other authors') -> #usersIcon; - add: #('space left') -> #removableMediaIcon; - add: #('start drawing all again' 'window color...') -> #graphicsIcon; - add: #('start stepping again') -> #mediaPlaybackStartIcon; - add: #('file out current change set' 'fileOut' 'File out and remove (o)' 'File out and keep (k)') -> #fileOutIcon; - add: #('recently logged changes...' 'versions (v)' 'recent classes... (r)' 'trim history' 'Profile it') -> #clockIcon; - add: #('senders of it (n)' 'senders of... (n)' 'local senders of...' 'senders (n)') -> #mailForwardIcon; - add: #('implementors of it (m)' 'implementors of... (m)' 'implementors of sent messages') -> #developmentIcon; - add: #('references to it (N)') -> #addressBookIcon; - add: #('class var refs...' 'class refs (N)' 'class variables' 'class vars' 'local implementors of...' 'subclass template') -> #classIcon; - add: #('inst var refs...' 'inst var defs...' 'sample instance') -> #instanceIcon; - add: #('Use Selection for Find (j)' 'rename class ...' 'rename...' 'change title...') -> #saveAsIcon; - add: #('smalltalk options' 'method source with it' 'browse method (O)' 'check for uncategorized methods') -> #scriptIcon; - add: #('method strings with it (E)' 'Toggle WordWrap') -> #genericTextIcon; - add: #('browse hierarchy (h)' 'move to top' 'promote to top of list') -> #goTopIcon; - add: #('move up' 'make next-to-topmost') -> #goUpIcon; - add: #('move to bottom' 'send to back' 'send top window to back') -> #goBottomIcon; - add: #('inheritance (i)' 'move down') -> #goDownIcon; - add: #('browse protocol (p)' 'spawn sub-protocol') -> #spreadsheetIcon; - add: #('spawn full protocol') -> #speadsheetTemplateIcon; - add: #('alphabetize') -> #fontXGenericIcon; - add: #('Installed Packages' 'browse' 'show category (C)' 'categorize all uncategorized' 'select change set...' 'view affected class categories') -> #packageIcon; - add: #('remove from current change set' 'remove empty categories' 'subtract other side (-)' 'remove from this browser') -> #listRemoveIcon; - add: #('add to current change set' 'add all meths to current chgs' 'add preamble (p)' 'More...') -> #listAddIcon; - add: #('toggle diffing (D)' 'toggle selections') -> #switchIcon; - add: #('reorganize' 'create inst var accessors' 'ChangeSorter reorderChangeSets.' 'reorder all change sets' 'by name' 'by size' 'by date') -> #sendReceiveIcon; - add: #('unsent methods' 'unreferenced class vars' 'unreferenced inst vars' 'Undeclared inspect.' 'Undeclared removeUnreferencedKeys; inspect.' 'ChangeSorter removeEmptyUnnamedChangeSets.' 'check for unsent messages') -> #junkIcon; - add: #('find changed windows...') -> #newWindowIcon; - add: #('make undraggable') -> #pushPinIcon; - add: #('Utilities saveScreenshot.') -> #stillCameraIcon; - add: #('add new directory') -> #newFolderIcon; - add: #('select all' 'deselect all') -> #selectAllIcon; - add: #('sort by date') -> #dateIcon; - add: #('justified') -> #formatJustifyFillIcon; - add: #('centered') -> #formatJustifyCenterIcon; - add: #('set alignment...' 'leftFlush') -> #formatJustifyLeftIcon; - add: #('rightFlush') -> #formatJustifyRightIcon; - add: #('signal Semaphore (S)') -> #haloHelpIcon; - add: #('Change Paragraph Style...' 'Change Character Style...' 'Remove Character Style' 'Replace all uses of Paragraph Style...' 'Replace all uses of Character Style...' 'Set Default Font...') -> #fontXGenericIcon; - add: #('Clear Font') -> #newIcon; - add: #('code file browser' 'package file browser') -> #findIcon. - ! ! -!Theme methodsFor: 'menus' stamp: 'HAW 4/12/2018 15:56:21' prior: 50390077! - basicIcons - - "Minimal menu scheme. - Theme current class beCurrent - " - - ^self iconsDefinitionFor: self basicIconsTypeSelector -! ! -!Theme methodsFor: 'menus' stamp: 'HAW 4/12/2018 16:00:06' prior: 50390166! - miscellaneousIcons - - ^self iconsDefinitionFor: self miscellaneousIconsTypeSelector -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3291-IconSpecEnhancements-HernanWilkinson-2018Apr12-13h37m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3285] on 14 April 2018 at 8:01:56 pm'! -!PluggableListMorphByItem methodsFor: 'model access' stamp: 'HAW 4/14/2018 19:27:47' prior: 50380211! - setSelectionIndex: anInteger - "Change the model's selected item to be the one at the given index." - - | item | - setIndexSelector ifNotNil: [ - item _ itemList at: anInteger ifAbsent: [ nil ]. - model perform: setIndexSelector with: item. - self update: getIndexSelector. - ^ true ]. - ^false - ! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3292-PluggableListMorphByItem-fix-HernanWilkinson-2018Apr14-19h50m-HAW.1.cs.st----! - -----SNAPSHOT----#(15 April 2018 7:35:09.00468 pm) Cuis5.0-3292-v3.image priorSource: 1879726! - -----QUIT----#(15 April 2018 7:35:38.974492 pm) Cuis5.0-3292-v3.image priorSource: 1904444! - -----STARTUP----#(18 April 2018 5:27:53.308788 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3292-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3292] on 18 April 2018 at 5:21:46 pm'! -!String class methodsFor: 'primitives' stamp: 'jmv 4/18/2018 17:21:32' prior: 16918032! - indexOfByte: anInteger inString: aString startingAt: start - - | stringSize | - - - self var: #aCharacter declareC: 'int anInteger'. - self var: #aString declareC: 'unsigned char *aString'. - - start > 0 ifFalse: [ ^ 0 ]. - stringSize _ aString size. - start to: stringSize do: [:pos | - (aString at: pos) asciiValue = anInteger ifTrue: [^ pos]]. - ^ 0 -! ! -!CompiledMethod class methodsFor: 'services' stamp: 'jmv 4/18/2018 17:19:33' prior: 16821574! - timeStamp: aStamp partsDo: aBlock - " - CompiledMethod>>#timeStampPartsDo: timeStampPartsDo: [ :authorInitials :dateAndTime | - ('*',authorInitials,'*') print. dateAndTime print ] - " - | stamp dateIndex aux dateAndTimePart | - stamp _ aStamp. - "Account for some unfortunately hacked stamps such as this: 'cwp 10/17/2007 23:29/eem 9/5/2009 11:10 - => :=' " - aux _ stamp lastIndexOf: $/. - aux _ stamp indexOf: $: startingAt: (aux max:1) ifAbsent: [ 0 ]. - aux > 0 ifTrue: [ - (aux > 0 and: [ aux + 2 ~= stamp size]) ifTrue: [ - stamp _ stamp copyFrom: 1 to: aux + 2 ]]. - - "Find start of date, if not possible, consider the whole stamp the author, and no date" - aux _ stamp - lastIndexOf: $/ - startingAt: stamp size - ifAbsent: [ ^ aBlock value: stamp value: nil ]. - aux _ stamp - lastIndexOf: $/ - startingAt: aux - ifAbsent: [ ^ aBlock value: stamp value: nil ]. - dateIndex _ stamp - lastIndexOf: $ - startingAt: aux - ifAbsent: [ ^ aBlock value: stamp value: nil ]. - "If only date, no time, add midnight time" - dateAndTimePart _ stamp copyFrom: dateIndex + 1 to: stamp size. - (dateAndTimePart indexOf: $:) = 0 ifTrue:[ - dateAndTimePart _ dateAndTimePart, ' 00:00' ]. - "Done" - ^aBlock - value: (stamp copyFrom: 1 to: dateIndex-1) - value: (DateAndTime fromString: dateAndTimePart)! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3293-PackageLoadHang-fix-JuanVuletich-2018Apr18-17h20m-jmv.1.cs.st----! - -----SNAPSHOT----#(18 April 2018 5:27:59.111944 pm) Cuis5.0-3293-v3.image priorSource: 1904539! - -----QUIT----#(18 April 2018 5:28:11.893591 pm) Cuis5.0-3293-v3.image priorSource: 1906891! - -----STARTUP----#(25 May 2018 2:10:28.044686 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3293-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3293] on 21 April 2018 at 4:54:48 pm'! - -CodeWindow subclass: #DebuggerWindow - instanceVariableNames: 'receiverInspector codePane receiverInspectorText stackList contextVariableInspector contextVariableInspectorText ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Tools'! - -!classDefinition: #DebuggerWindow category: #'Morphic-Tools'! -CodeWindow subclass: #DebuggerWindow - instanceVariableNames: 'receiverInspector codePane receiverInspectorText stackList contextVariableInspector contextVariableInspectorText' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Tools'! -!SystemWindow methodsFor: 'user interface' stamp: 'HAW 4/21/2018 16:46:39'! - canDiscardEditsOf: aMorphWithChanges - - | okToLooseChanges | - - aMorphWithChanges canDiscardEdits ifTrue: [ ^true ]. - - okToLooseChanges _ self isItOkToLooseChanges. - okToLooseChanges ifTrue: [ aMorphWithChanges disregardUnacceptedEdits ]. - - ^okToLooseChanges - - ! ! -!SystemWindow methodsFor: 'user interface' stamp: 'HAW 4/21/2018 16:03:28'! - isItOkToLooseChanges - - ^ self confirm: -'Changes have not been saved. -Is it OK to cancel those changes?'.! ! -!SystemWindow methodsFor: 'user interface' stamp: 'HAW 4/21/2018 12:09:13'! - okToChangeDueTo: aMorph - - ^self okToChange! ! -!DebuggerWindow methodsFor: 'GUI building' stamp: 'HAW 4/21/2018 12:11:38'! - buildMorphicCodePane - - codePane _ super buildMorphicCodePane. - ^codePane! ! -!DebuggerWindow methodsFor: 'user interface' stamp: 'HAW 4/21/2018 16:47:36'! - okToChangeCodePane - - | okToLooseChanges | - - okToLooseChanges _ self canDiscardEditsOf: codePane. - okToLooseChanges ifTrue: [ - receiverInspectorText disregardUnacceptedEdits. - contextVariableInspectorText disregardUnacceptedEdits ]. - - ^okToLooseChanges ! ! -!DebuggerWindow methodsFor: 'user interface' stamp: 'HAW 4/21/2018 16:47:50'! - okToChangeContextVariableInspectorText - - ^self canDiscardEditsOf: contextVariableInspectorText! ! -!DebuggerWindow methodsFor: 'user interface' stamp: 'HAW 4/21/2018 16:40:50'! - okToChangeDueTo: aMorph - - aMorph = stackList ifTrue: [ ^self okToChangeCodePane ]. - aMorph = receiverInspector ifTrue: [ ^self okToChangeReceiverInspectorText ]. - aMorph = contextVariableInspector ifTrue: [ ^self okToChangeContextVariableInspectorText ]. - - ^super okToChangeDueTo: aMorph - - - ! ! -!DebuggerWindow methodsFor: 'user interface' stamp: 'HAW 4/21/2018 16:47:56'! - okToChangeReceiverInspectorText - - ^self canDiscardEditsOf: receiverInspectorText! ! -!PluggableListMorph methodsFor: 'events' stamp: 'HAW 4/21/2018 12:09:58' prior: 50380379! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - "The mouse came up within the list; take appropriate action" - - | row | - row _ self rowAtLocation: localEventPosition. - self owningWindow ifNotNil: [ :w | - (w okToChangeDueTo: self) ifFalse: [ ^ self ]]. - (autoDeselect == false and: [row = 0 ]) ifTrue: [ ^ self ]. "work-around the no-mans-land bug" - "No change if model is locked" - (autoDeselect and: [ row == self visualSelectionIndex ]) - ifTrue: [ - aMouseButtonEvent mouseButton1Changed ifTrue: [ - self setSelectionIndex: 0 ]] - ifFalse: [ self setSelectionIndex: row ]! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'HAW 4/21/2018 12:09:32' prior: 50380401! - arrowKey: aChar - "Process the up and down arrows in a list pane. Note that the listView tells us what index variable, how to get the list, and how to move the index." - | keyEvent oldSelection nextSelection max min howMany answer w | - answer _ false. - keyEvent _ aChar numericValue. - oldSelection _ self getCurrentSelectionIndex. - nextSelection _ oldSelection. - max _ self maximumSelection. - min _ self minimumSelection. - howMany _ self numSelectionsInView. "get this exactly??" - - keyEvent = 31 ifTrue: [ - "down-arrow; move down one, wrapping to top if needed" - nextSelection _ oldSelection + 1. - nextSelection > max ifTrue: [ nextSelection _ 1 ]]. - - keyEvent = 30 ifTrue: [ - "up arrow; move up one, wrapping to bottom if needed" - nextSelection _ oldSelection - 1. - nextSelection < 1 ifTrue: [ nextSelection _ max ]]. - - keyEvent = 1 ifTrue: [ nextSelection _ 1 ]. "home" - keyEvent = 4 ifTrue: [ nextSelection _ max ]. "end" - keyEvent = 11 ifTrue: [ nextSelection _ min max: oldSelection - howMany ]. "page up" - keyEvent = 12 ifTrue: [ nextSelection _ oldSelection + howMany min: max ]. "page down" - nextSelection = oldSelection ifFalse: [ - w _ self owningWindow. - (w isNil or: [ w okToChangeDueTo: self ]) ifTrue: [ "No change if model is locked" - - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self listMorph highlightedRow: nextSelection. - - "Update the model in next world cycle, so user gets the immediate feedback." - UISupervisor whenUIinSafeState: [ - self setSelectionIndex: nextSelection ]. - answer _ true ]]. - ^answer! ! -!PluggableListMorph methodsFor: 'model access' stamp: 'HAW 4/21/2018 12:09:49' prior: 50380465! - keyboardSearch: aChar - | oldSelection nextSelection max milliSeconds nextSelectionList nextSelectionText | - nextSelection _ oldSelection _ self getCurrentSelectionIndex. - max _ self maximumSelection. - milliSeconds _ Time localMillisecondClock. - milliSeconds - lastKeystrokeTime > 300 ifTrue: ["just use the one current character for selecting" - lastKeystrokes _ '']. - lastKeystrokes _ lastKeystrokes , aChar asLowercase asString. - lastKeystrokeTime _ milliSeconds. - nextSelectionList _ OrderedCollection newFrom: (list copyFrom: oldSelection + 1 to: max). - nextSelectionList addAll: (list copyFrom: 1 to: oldSelection). - "Get rid of blanks and style used in some lists" - nextSelectionText _ nextSelectionList detect: [:a | a asString withBlanksTrimmed asLowercase beginsWith: lastKeystrokes] - ifNone: [^ self flash"match not found"]. - self owningWindow ifNotNil: [ :w | - (w okToChangeDueTo: self) ifFalse: [^ self]]. - nextSelection _ list findFirst: [:a | a == nextSelectionText]. - "No change if model is locked" - oldSelection == nextSelection ifTrue: [^ self flash]. - ^ self setSelectionIndex: nextSelection! ! -!SystemWindow methodsFor: 'user interface' stamp: 'HAW 4/21/2018 16:46:56' prior: 16926859! - okToChange - - ^self canDiscardEditsOf: self! ! -!DebuggerWindow methodsFor: 'GUI building' stamp: 'HAW 4/21/2018 12:08:29' prior: 50334336! - buildMorphicWindow - "Open a full morphic debugger with the given label" - - | bottomMorph | - - stackList _ PluggableListMorph - model: model - listGetter: #contextStackList - indexGetter: #contextStackIndex - indexSetter: #toggleContextStackIndex: - mainView: self - menuGetter: #contextStackMenu - keystrokeAction: #contextStackKey:from:. - - receiverInspector _ PluggableListMorph - model: model receiverInspector - listGetter: #fieldList - indexGetter: #selectionIndex - indexSetter: #toggleIndex: - mainView: self - menuGetter: #receiverFieldListMenu - keystrokeAction: #inspectorKey:from:. - receiverInspector doubleClickSelector: #inspectSelection. - receiverInspectorText _ TextModelMorph - textProvider: model receiverInspector - textGetter: #acceptedContents - textSetter: #accept: - selectionGetter: #contentsSelection. - contextVariableInspector _ PluggableListMorph - model: model contextVariablesInspector - listGetter: #fieldList - indexGetter: #selectionIndex - indexSetter: #toggleIndex: - mainView: self - menuGetter: #contextFieldListMenu - keystrokeAction: #inspectorKey:from:. - contextVariableInspector doubleClickSelector: #inspectSelection. - contextVariableInspectorText _ TextModelMorph - textProvider: model contextVariablesInspector - textGetter: #acceptedContents - textSetter: #accept: - selectionGetter: #contentsSelection. - - bottomMorph _ LayoutMorph newRow. - bottomMorph - addMorph: receiverInspector proportionalWidth: 0.2; - addAdjusterAndMorph: receiverInspectorText proportionalWidth: 0.3; - addAdjusterAndMorph: contextVariableInspector proportionalWidth: 0.2; - addAdjusterAndMorph: contextVariableInspectorText proportionalWidth: 0.3. - - self layoutMorph - addMorph: stackList proportionalHeight: 0.25; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.55; - addAdjusterAndMorph: bottomMorph proportionalHeight: 0.2! ! - -DebuggerWindow removeSelector: #canDiscardEditsFrom:! - -DebuggerWindow removeSelector: #canDiscardEditsFrom:disregarding:! - -DebuggerWindow removeSelector: #okToChangeStackList! - -SystemWindow removeSelector: #askShouldSaveChanges! - -CodeWindow subclass: #DebuggerWindow - instanceVariableNames: 'stackList receiverInspector receiverInspectorText contextVariableInspector contextVariableInspectorText codePane' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Tools'! - -!classDefinition: #DebuggerWindow category: #'Morphic-Tools'! -CodeWindow subclass: #DebuggerWindow - instanceVariableNames: 'stackList receiverInspector receiverInspectorText contextVariableInspector contextVariableInspectorText codePane' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Tools'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3294-DebuggerEnhancements-HernanWilkinson-2018Apr21-12h07m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3293] on 22 April 2018 at 5:32:30 pm'! -!DebuggerWindow methodsFor: 'user interface' stamp: 'HAW 4/21/2018 20:43:49'! - ifOkToChangeCodePaneDo: aBlock - - ^self okToChangeCodePane ifTrue: aBlock -! ! -!DebuggerWindow methodsFor: 'context stack menu' stamp: 'HAW 4/22/2018 17:30:34'! -createMethod - - ^ self ifOkToChangeCodePaneDo: [ model createMethod ]! ! -!DebuggerWindow methodsFor: 'context stack menu' stamp: 'HAW 4/21/2018 20:44:10'! - doStep - - ^ self ifOkToChangeCodePaneDo: [ model doStep ]! ! -!DebuggerWindow methodsFor: 'context stack menu' stamp: 'HAW 4/21/2018 20:45:19'! - fullStack - - ^ self ifOkToChangeCodePaneDo: [ model fullStack ]! ! -!DebuggerWindow methodsFor: 'context stack menu' stamp: 'HAW 4/21/2018 20:45:26'! - proceed - - ^ self ifOkToChangeCodePaneDo: [ model proceed ]! ! -!DebuggerWindow methodsFor: 'context stack menu' stamp: 'HAW 4/21/2018 20:45:36'! - restart - - ^ self ifOkToChangeCodePaneDo: [ model restart ]! ! -!DebuggerWindow methodsFor: 'context stack menu' stamp: 'HAW 4/22/2018 17:31:44'! - send - - ^ self ifOkToChangeCodePaneDo: [ model send ]! ! -!DebuggerWindow methodsFor: 'context stack menu' stamp: 'HAW 4/21/2018 20:45:56'! - stepIntoBlock - - ^ self ifOkToChangeCodePaneDo: [ model stepIntoBlock ]! ! -!DebuggerWindow methodsFor: 'context stack menu' stamp: 'HAW 4/21/2018 20:46:06'! - where - - ^ self ifOkToChangeCodePaneDo: [ model where ]! ! -!DebuggerWindow methodsFor: 'GUI building' stamp: 'HAW 4/21/2018 20:41:02' prior: 16831080! - customButtonRow - "Answer a button pane affording the user one-touch access to certain functions; the pane is given the formal name 'customButtonPane' by which it can be retrieved by code wishing to send messages to widgets residing on the pane" - - | button buttons row buttonColor | - - buttons _ OrderedCollection new. - buttonColor _ self buttonColor. - "button with target = self" - button _ PluggableButtonMorph - model: self - stateGetter: nil - action: #proceed. - button color: buttonColor. - button label: 'Proceed'. - button setBalloonText: 'close the debugger and proceed.'. - buttons add: button. - "buttons with model target" - self customButtonSpecs do: [ :tuple | - button _ PluggableButtonMorph - model: self - stateGetter: nil - action: tuple second. - button color: buttonColor. - button label: tuple first asString. - tuple size > 2 ifTrue: [button setBalloonText: tuple third]. - buttons add: button]. - - row _ LayoutMorph newRow. - row doAdoptWidgetsColor. - row color: buttonColor. - row addMorphs: buttons. - ^row! ! -!DebuggerWindow methodsFor: 'menu building' stamp: 'HAW 4/21/2018 20:39:59' prior: 16831155! - contextStackMenu - "Set up the menu appropriately for the context-stack-list, either shifted or unshifted as per the parameter provided" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addList: #( - ('fullStack (f)' fullStack ) - ('restart (r)' restarl) - ('proceed (p)' proceed) - ('step (t)' doStep) - ('step through (T)' stepIntoBlock) - ('send (e)' send) - ('where (w)' where) - ('peel to first like this' peelToFirst) - - - ('return entered value' returnValue) - ('toggle break on entry' toggleBreakOnEntry '' model) - ). - ^aMenu! ! -!DebuggerWindow methodsFor: 'keyboard shortcuts' stamp: 'HAW 4/21/2018 20:38:49' prior: 16831264! - contextStackKey: aChar from: view - "Respond to a keystroke in the context list" - - aChar == $e ifTrue: [^ self send]. - aChar == $t ifTrue: [^ self doStep]. - aChar == $T ifTrue: [^ self stepIntoBlock]. - aChar == $p ifTrue: [^ self proceed]. - aChar == $r ifTrue: [^ self restart]. - aChar == $f ifTrue: [^ self fullStack]. - aChar == $w ifTrue: [^ self where]. - - ^ self messageListKey: aChar from: view! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3295-DebuggerEnhancements-HernanWilkinson-2018Apr21-16h54m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3295] on 26 April 2018 at 1:38:13 pm'! -!Object methodsFor: 'evaluating' stamp: 'jmv 4/26/2018 13:11:27'! - valueWithPossibleArgument: anArg - - ^self! ! -!Collection methodsFor: 'enumerating' stamp: 'jmv 4/26/2018 13:33:07'! - collect: aBlock andFold: aTwoArgBlock ifEmpty: emptyBlockOrValue - "Evaluate the block with the first two elements of the receiver, - then with the result of the first evaluation and the next element, - and so on. Answer the result of the final evaluation. If the receiver - is empty, raise an error. If the receiver has a single element, answer - that element." - " - #('if' 'it' 'is' 'to' 'be' 'it' 'is' 'up' 'to' 'me') collect: [ :each | each ] andFold: [:a :b | a, ' ', b] ifEmpty:nil - #('if' 'it' 'is' 'to' 'be' 'it' 'is' 'up' 'to' 'me') collect: [ :each | each size] andFold: [:a :b | a + b] ifEmpty: nil - #() collect: [ :each | each ] andFold: [:a :b | a, ' ', b] ifEmpty:nil - " - - | first eachValue answer | - first _ true. - self do: [ :each | - eachValue _ aBlock value: each. - first - ifTrue: [ - first _ false. - answer _ eachValue ] - ifFalse: [ - answer _ aTwoArgBlock - value: answer - value: eachValue ]]. - first ifTrue: [ answer _ emptyBlockOrValue valueWithPossibleArgument: self ]. - ^ answer! ! -!Collection methodsFor: 'enumerating' stamp: 'jmv 4/26/2018 13:17:08'! - fold: aTwoArgBlock ifEmpty: emptyBlockOrValue - "Evaluate the block with the first two elements of the receiver, - then with the result of the first evaluation and the next element, - and so on. Answer the result of the final evaluation. If the receiver - is empty, raise an error. If the receiver has a single element, answer - that element." - " - #('if' 'it' 'is' 'to' 'be' 'it' 'is' 'up' 'to' 'me') fold: [:a :b | a, ' ', b] ifEmpty: [ :coll | coll errorEmptyCollection ] - #() fold: [:a :b | a, ' ', b] ifEmpty: [ :coll | coll errorEmptyCollection ] - #() fold: [:a :b | a, ' ', b] ifEmpty: 7 - " - - ^self - collect: [ :each | each ] - andFold: aTwoArgBlock - ifEmpty: emptyBlockOrValue! ! -!Collection methodsFor: 'statistics' stamp: 'jmv 4/26/2018 13:30:54'! - sum: aBlock ifEmpty: emptyBlockOrValue - "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." - ^self collect: aBlock andFold: [ :a :b | a + b ] ifEmpty: emptyBlockOrValue! ! -!Collection methodsFor: 'enumerating' stamp: 'jmv 4/26/2018 13:16:40' prior: 16814204! - collect: aBlock andFold: aTwoArgBlock - "Evaluate the block with the first two elements of the receiver, - then with the result of the first evaluation and the next element, - and so on. Answer the result of the final evaluation. If the receiver - is empty, raise an error. If the receiver has a single element, answer - that element." - " - #('if' 'it' 'is' 'to' 'be' 'it' 'is' 'up' 'to' 'me') collect: [ :each | each ] andFold: [:a :b | a, ' ', b] - #('if' 'it' 'is' 'to' 'be' 'it' 'is' 'up' 'to' 'me') collect: [ :each | each size] andFold: [:a :b | a + b] - " - - ^ self - collect: aBlock - andFold: aTwoArgBlock - ifEmpty: [ self errorEmptyCollection ]! ! -!Collection methodsFor: 'enumerating' stamp: 'jmv 4/26/2018 13:16:51' prior: 16814381! - fold: aTwoArgBlock - "Evaluate the block with the first two elements of the receiver, - then with the result of the first evaluation and the next element, - and so on. Answer the result of the final evaluation. If the receiver - is empty, raise an error. If the receiver has a single element, answer - that element." - " - #('if' 'it' 'is' 'to' 'be' 'it' 'is' 'up' 'to' 'me') fold: [:a :b | a, ' ', b] - " - - ^self - collect: [ :each | each ] - andFold: aTwoArgBlock - ifEmpty: [ self errorEmptyCollection ]! ! -!Collection methodsFor: 'enumerating' stamp: 'jmv 4/26/2018 13:22:28' prior: 16814447! - reduce: aTwoArgBlock - "Apply the argument, binaryBlock cumulatively to the elements of the receiver. - For sequenceable collections the elements will be used in order, for unordered - collections the order is unspecified." - - ^self fold: aTwoArgBlock! ! -!Collection methodsFor: 'statistics' stamp: 'jmv 4/26/2018 13:27:14' prior: 16815012! - product - "Compute the product of all the elements in the receiver" - - ^self fold: [ :a :b | a * b] ifEmpty: 1! ! -!Collection methodsFor: 'statistics' stamp: 'jmv 4/26/2018 13:30:08' prior: 16815065! - sum - "Compute the sum of all the elements in the receiver" - - ^self fold: [ :a :b | a + b]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3296-sum_ifEmpty-foldProtocolTweaks-JuanVuletich-2018Apr26-13h36m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3296] on 2 May 2018 at 6:33:04 pm'! -!Scanner methodsFor: 'multi-character scans' stamp: 'jmv 5/2/2018 18:28:52' prior: 50382949! - xBacktick - "Smalltalk code evaluated at compile time as a literal." - - self step. - buffer reset. - [hereChar == $` - and: [aheadChar == $` - ifTrue: [self step. false] - ifFalse: [true]]] - whileFalse: [ - buffer nextPut: self step. - (hereChar = Scanner doItCharacterValue asCharacter and: [source atEnd]) - ifTrue: [^self offEnd: 'Unmatched back quote']]. - self step. - [ | compiler method methodNode | - compiler _ Compiler new. - methodNode _ compiler compileNoPattern: buffer contents in: UndefinedObject context: nil notifying: nil ifFail: []. - method _ methodNode generate. - "Grab all messages sent while evaluating literal, so the main method will be shown as senders of them" - sentInLiterals addAll: method messages. - method literalsDo: [ :literal | literal isSymbol ifTrue: [ sentInLiterals add: literal ]]. - "Evaluate now." - token _ nil withArgs: #() executeMethod: method. - ] - on: SyntaxErrorNotification, UndeclaredVariableReference, Error - do: [ :ex | - ex class caseOf: { - [ SyntaxErrorNotification ] -> [ - self notify: 'Can not compile: ', ex errorMessage at: mark]. - [ UndeclaredVariableReference ] -> [ - self notify: 'Can not compile: Variable ''', ex varName, ''' is not declared' at: mark ] - } otherwise: [ - self notify: 'Can not evaluate code: ', ex description at: mark ]]. - tokenType _ #literal! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3297-FixSendersInComplexLiterals-JuanVuletich-2018May02-18h31m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3296] on 30 April 2018 at 8:28:45 pm'! -!Preferences class methodsFor: 'menu icons' stamp: 'jmv 4/30/2018 20:13:31'! - useMenuIcons - - self setPreference: #wantsMenuIcons toValue: true! ! -!Preferences class methodsFor: 'menu icons' stamp: 'jmv 4/30/2018 20:13:34'! - useNoMenuIcons - - self setPreference: #wantsMenuIcons toValue: false! ! -!Preferences class methodsFor: 'menu icons' stamp: 'jmv 4/30/2018 20:13:53'! - wantsMenuIcons - ^ self - valueOfFlag: #wantsMenuIcons - ifAbsent: [ true ]! ! -!SystemDictionary methodsFor: 'shrinking' stamp: 'jmv 4/30/2018 20:26:39' prior: 50378976! - reduceCuis - " - Smalltalk reduceCuis - " - | keep n unused newDicts oldDicts | - - self nominallyUnsent: #reduceCuis. - - "Remove icons" - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - PasteUpMorph allInstancesDo: [ :w | - w backgroundImageData: nil. - w submorphsDo: [ :a | a delete ]]. - Preferences useNoMenuIcons. - Theme current initialize. - Theme content: nil. - Color shutDown. - BitBltCanvas releaseClassCachedState. - - Transcript clear. - Clipboard default initialize. - - - "Remove some methods, even if they have senders." - Utilities removeSelector: #vmStatisticsReportString. - SystemDictionary removeSelector: #recreateSpecialObjectsArray. - - StrikeFont removeMostFonts. - StrikeFont saveSpace. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - - keep := OrderedCollection new. - keep addAll: #(SpaceTally). - AppLauncher appGlobalName ifNotNil: [ :any | - keep add: any ]. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - [ - #hereWeGo print. - unused do: [:c | - c print. - (Smalltalk at: c) removeFromSystem]. - n := Smalltalk removeAllUnSentMessages. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - n > 0 or: [ - unused notEmpty ]] whileTrue. - ChangeSet zapAllChangeSets. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - Symbol rehash. - - "Shrink method dictionaries." - Smalltalk garbageCollect. - oldDicts _ MethodDictionary allInstances. - newDicts _ Array new: oldDicts size. - oldDicts withIndexDo: [:d :index | - newDicts at: index put: d rehashWithoutBecome ]. - oldDicts elementsExchangeIdentityWith: newDicts. - oldDicts _ newDicts _ nil. - - SmalltalkCompleter initialize . - - "Sanity checks" -" Undeclared - Smalltalk cleanOutUndeclared - Smalltalk browseUndeclaredReferences - Smalltalk obsoleteClasses - Smalltalk obsoleteBehaviors - Smalltalk browseObsoleteMethodReferences - SmalltalkImage current fixObsoleteReferences - Smalltalk browseAllUnimplementedCalls"! ! -!Preferences class methodsFor: 'themes' stamp: 'jmv 4/30/2018 20:22:36' prior: 16893781! - cuisDefaults - " - Preferences cuisDefaults - " - self setPreferencesFrom: - - #( - (balloonHelpEnabled true) - (browseWithPrettyPrint false) - (caseSensitiveFinds false) - (checkForSlips true) - (cmdDotEnabled true) - (diffsInChangeList true) - (diffsWithPrettyPrint false) - (menuKeyboardControl true) - (optionalButtons true) - (extraDebuggerButtons true) - (subPixelRenderFonts true) - (thoroughSenders true) - (cheapWindowReframe false) - (syntaxHighlightingAsYouType true) - (tapAndHoldEmulatesButton2 true) - (clickGrabsMorphs false) - - (syntaxHighlightingAsYouTypeAnsiAssignment false) - (syntaxHighlightingAsYouTypeLeftArrowAssignment false) - ). - self useMenuIcons - ". - Theme beCurrent. - Taskbar showTaskbar - "! ! -!Preferences class methodsFor: 'themes' stamp: 'jmv 4/30/2018 20:24:54' prior: 16893825! - slowMachine - " - Preferences slowMachine - " - self setPreferencesFrom: #( - (balloonHelpEnabled false) - (browseWithPrettyPrint false) - (caseSensitiveFinds true) - (checkForSlips false) - (cmdDotEnabled true) - (diffsInChangeList true) - (diffsWithPrettyPrint false) - (menuKeyboardControl false) - (optionalButtons false) - (subPixelRenderFonts true) - (thoroughSenders true) - (cheapWindowReframe true) - (syntaxHighlightingAsYouType false) - (tapAndHoldEmulatesButton2 false) - (clickGrabsMorphs true) - ). - self useNoMenuIcons. - self runningWorld backgroundImageData: nil. - " - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - Taskbar hideTaskbar - "! ! -!Preferences class methodsFor: 'themes' stamp: 'jmv 4/30/2018 20:24:56' prior: 16893849! - smalltalk80 - "A traditional monochrome Smalltalk-80 look and feel, clean and austere, and lacking many features added to Squeak and Cuis in recent years. Caution: turns off the 'smartUpdating' feature that keeps multiple browsers in synch, and much more. - - Preferences smalltalk80 - " - - self setPreferencesFrom: - - #( - (balloonHelpEnabled false) - (browseWithPrettyPrint false) - (caseSensitiveFinds true) - (checkForSlips false) - (cmdDotEnabled true) - (diffsInChangeList false) - (diffsWithPrettyPrint false) - (menuKeyboardControl false) - (optionalButtons false) - (subPixelRenderFonts true) - (thoroughSenders false) - (cheapWindowReframe true) - (syntaxHighlightingAsYouType false) - (tapAndHoldEmulatesButton2 false) - (clickGrabsMorphs true) - ). - self useNoMenuIcons. - " - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - Taskbar hideTaskbar - "! ! -!Theme methodsFor: 'menus' stamp: 'jmv 4/30/2018 20:06:28' prior: 50391127! - basicIcons - - "Minimal menu scheme. - Theme current class beCurrent - " - - ^self iconsDefinitionFor: #addBasicIconsTo:! ! -!Theme methodsFor: 'menus' stamp: 'jmv 4/30/2018 20:17:26' prior: 16936052! - menuDecorations - - "build a dictionary wordings -> icon to decorate the menus all over the image" - - ^Preferences wantsMenuIcons - ifTrue: [ self allIcons ] - ifFalse: [#() ]! ! -!Theme methodsFor: 'menus' stamp: 'jmv 4/30/2018 20:06:14' prior: 50391134! - miscellaneousIcons - - ^self iconsDefinitionFor: #addMiscellaneousIconsTo:! ! -!Theme class methodsFor: 'user interface' stamp: 'jmv 4/30/2018 20:22:02' prior: 16936913! - changeIcons - - | menu selector | - - menu _ SelectionMenu - fromArray: #( - #( 'Use icons for menu entries' #useMenuIcons ) - #( 'Don''t use icons for menu entries' #useNoMenuIcons ) - ). - - selector _ menu startUpWithCaption: 'Menu Icons'. - - selector ifNotNil: [ - Preferences perform: selector. - Theme current class beCurrent ] -! ! - -Theme removeSelector: #basicIconsTypeSelector! - -Theme removeSelector: #basicIconsTypeSelector! - -Theme removeSelector: #miscellaneousIconsTypeSelector! - -Theme removeSelector: #miscellaneousIconsTypeSelector! - -Theme removeSelector: #noIcons! - -Theme removeSelector: #noIcons! - -Preferences class removeSelector: #menuIcons! - -Preferences class removeSelector: #menuIcons! - -Preferences class removeSelector: #useAllIcons! - -Preferences class removeSelector: #useAllIcons! - -Preferences class removeSelector: #useBasicIcons! - -Preferences class removeSelector: #useBasicIcons! - -Preferences class removeSelector: #useNoIcons! - -Preferences class removeSelector: #useNoIcons! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3298-BigMenuRefactor-p1-JuanVuletich-2018Apr30-19h58m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3296] on 1 May 2018 at 1:15:46 am'! - -StringMorph subclass: #MenuItemMorph - instanceVariableNames: 'isEnabled subMenu isSelected target selector arguments icon contentString ' - classVariableNames: 'SubMenuMarker ' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #MenuItemMorph category: #'Morphic-Menus'! -StringMorph subclass: #MenuItemMorph - instanceVariableNames: 'isEnabled subMenu isSelected target selector arguments icon contentString' - classVariableNames: 'SubMenuMarker' - poolDictionaries: '' - category: 'Morphic-Menus'! -!MenuItemMorph methodsFor: 'accessing' stamp: 'jmv 5/1/2018 01:15:02' prior: 50385213! - contents: aString withMarkers: aBool inverse: inverse - "Set the menu item entry. If aBool is true, parse aString for embedded markers." - - | markerIndex marker | - contentString _ nil. "get rid of old" - aBool ifFalse: [^super contents: aString]. - self removeAllMorphs. "get rid of old markers if updating" - self hasIcon ifTrue: [ self icon: nil ]. - (aString notEmpty and: [aString first = $<]) - ifFalse: [^super contents: aString]. - markerIndex := aString indexOf: $>. - markerIndex = 0 ifTrue: [^super contents: aString]. - marker := (aString copyFrom: 1 to: markerIndex) asLowercase. - (#('' '' '' '') includes: marker) - ifFalse: [^super contents: aString]. - contentString _ aString. "remember actual string" - marker := (marker = '' or: [marker = '']) ~= inverse - ifTrue: [self onImage] - ifFalse: [self offImage]. - super contents: (aString copyFrom: markerIndex + 1 to: aString size). - "And set the marker" - marker := ImageMorph new image: marker. - self addMorphFront: marker position: `0@2`! ! -!MenuItemMorph methodsFor: 'events' stamp: 'jmv 5/1/2018 01:14:28' prior: 16865998! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - "Handle a mouse up event. Menu items get activated when the mouse is over them. Do nothing if we're not in a 'valid menu transition', meaning that the current hand focus must be aimed at the owning menu." - owner hasMouseFocus ifFalse: [ ^self ]. - "This will happen if the menu has toggles in it. (for instance, the 'show...' button) - Update the look, refresh the world and wait a bit, - to give the user some visual feedback" - contentString ifNotNil: [ - self contents: contentString withMarkers: true inverse: true. - self refreshWorld. - (Delay forMilliseconds: 200) wait]. - self deselect. - self invokeWithEvent: aMouseButtonEvent! ! -!UpdatingMenuItemMorph methodsFor: 'world' stamp: 'jmv 5/1/2018 01:14:34' prior: 16940489! - updateContents - "Update the receiver's contents" - - | newString enablement nArgs | - ((wordingProvider isNil) or: [wordingSelector isNil]) ifFalse: [ - nArgs _ wordingSelector numArgs. - newString _ nArgs = 0 - ifTrue: [ - wordingProvider perform: wordingSelector] - ifFalse: [ - (nArgs = 1 and: [wordingArgument notNil]) - ifTrue: [ - wordingProvider perform: wordingSelector with: wordingArgument] - ifFalse: [ - nArgs = arguments size ifTrue: [ - wordingProvider perform: wordingSelector withArguments: arguments]]]. - newString = (contentString ifNil: [ contents ]) - ifFalse: [ - self contents: newString. - Theme current decorateMenu: owner ]]. - enablementSelector ifNotNil: [ - (enablement _ self enablement) == isEnabled - ifFalse: [self isEnabled: enablement]]! ! - -MenuItemMorph removeSelector: #contentString! - -MenuItemMorph removeSelector: #contentString! - -MenuItemMorph removeSelector: #contentString:! - -MenuItemMorph removeSelector: #contentString:! - -StringMorph subclass: #MenuItemMorph - instanceVariableNames: 'isEnabled subMenu isSelected target selector arguments icon contentString' - classVariableNames: 'SubMenuMarker' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #MenuItemMorph category: #'Morphic-Menus'! -StringMorph subclass: #MenuItemMorph - instanceVariableNames: 'isEnabled subMenu isSelected target selector arguments icon contentString' - classVariableNames: 'SubMenuMarker' - poolDictionaries: '' - category: 'Morphic-Menus'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3299-BigMenuRefactor-p2-JuanVuletich-2018May01-01h11m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3296] on 1 May 2018 at 1:26:50 am'! -!MenuMorph methodsFor: 'accessing' stamp: 'jmv 5/1/2018 01:22:28'! - addBlankIconsIfNecessary - "If any of my items have an icon, ensure that all do by using anIcon for those that don't" - - | withIcons withoutIcons blankIcon | - withIcons _ Set new. - withoutIcons _ Set new. - self items do: [ :item | - item hasIcon | item hasMarker - ifTrue: [ withIcons add: item ] - ifFalse: [ withoutIcons add: item ]. - item hasSubMenu ifTrue: [ item subMenu addBlankIconsIfNecessary ]]. - (withIcons isEmpty or: [ withoutIcons isEmpty ]) ifTrue: [ ^self ]. - blankIcon _ Theme current blankIcon. - withoutIcons do: [ :item | item set_icon: blankIcon ].! ! -!MenuItemMorph methodsFor: 'accessing' stamp: 'jmv 5/1/2018 01:20:01'! - contentsWithMarkers: aString inverse: inverse - "Set the menu item entry. If aBool is true, parse aString for embedded markers." - - | markerIndex marker | - contentString _ nil. "get rid of old" - self removeAllMorphs. "get rid of old markers if updating" - icon _ nil. - (aString notEmpty and: [aString first = $<]) - ifFalse: [^super contents: aString]. - markerIndex := aString indexOf: $>. - markerIndex = 0 ifTrue: [^super contents: aString]. - marker := (aString copyFrom: 1 to: markerIndex) asLowercase. - (#('' '' '' '') includes: marker) - ifFalse: [^super contents: aString]. - contentString _ aString. "remember actual string" - marker := (marker = '' or: [marker = '']) ~= inverse - ifTrue: [self onImage] - ifFalse: [self offImage]. - super contents: (aString copyFrom: markerIndex + 1 to: aString size). - "And set the marker" - marker := ImageMorph new image: marker. - self addMorphFront: marker position: `0@2`! ! -!MenuItemMorph methodsFor: 'accessing' stamp: 'jmv 4/30/2018 20:54:05'! - set_icon: aForm - "change the the receiver's icon" - icon := aForm! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 4/30/2018 21:04:03' prior: 16866372! - add: aString subMenu: aMenuMorph - "Append the given submenu with the given label." - - | item | - item _ MenuItemMorph new. - item - contents: aString; - subMenu: aMenuMorph. - self addMorphBack: item! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 4/30/2018 21:04:08' prior: 16866410! - add: aString target: target selector: aSymbol argumentList: argList - "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument. Answer the appended menu item." - - | item | - item _ MenuItemMorph new - contents: aString; - target: target; - selector: aSymbol; - arguments: argList asArray. - self addMorphBack: item. - ^ item! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 4/30/2018 20:51:33' prior: 50384912! - popUpAt: aPoint forHand: hand allowKeyboard: aBoolean - "Present this menu at the given point under control of the given hand." - - | evt | - self items isEmpty ifTrue: [^self]. - Theme current decorateMenu: self. - self addBlankIconsIfNecessary. - (self submorphs select: [ :m | m is: #UpdatingMenuItemMorph ]) - do: [ :m | m updateContents]. - self runningWorld addMorphFront: self position: aPoint - `2 @ 8`. - self fitInWorld. - "Acquire focus for valid pop up behavior" - hand newMouseFocus: self. - aBoolean ifTrue: [ hand newKeyboardFocus: self ]. - evt _ hand lastMouseEvent. - (evt isKeyboard or: [ evt isMouse and: [ evt anyButtonPressed not ]]) - ifTrue: [ - "Select first item if button not down" - self moveSelectionDown: 1 event: evt ]! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 4/30/2018 20:51:37' prior: 50384937! - popUpAt: aPoint forHand: hand in: aWorld allowKeyboard: aBoolean - "Present this menu at the given point under control of the given hand." - - self items isEmpty ifTrue: [ ^self ]. - Theme current decorateMenu: self. - self addBlankIconsIfNecessary. - (self submorphs select: [ :m | m is: #UpdatingMenuItemMorph]) - do: [ :m | m updateContents]. - aWorld addMorphFront: self position: aPoint - `2 @ 8`. - self fitInWorld. - "Acquire focus for valid pop up behavior" - hand newMouseFocus: self. - aBoolean ifTrue: [ hand newKeyboardFocus: self ]! ! -!MenuItemMorph methodsFor: 'accessing' stamp: 'jmv 5/1/2018 01:19:11' prior: 16865789! - contents: aString - ^self contentsWithMarkers: aString inverse: false! ! -!MenuItemMorph methodsFor: 'events' stamp: 'jmv 5/1/2018 01:19:31' prior: 50392158! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - "Handle a mouse up event. Menu items get activated when the mouse is over them. Do nothing if we're not in a 'valid menu transition', meaning that the current hand focus must be aimed at the owning menu." - owner hasMouseFocus ifFalse: [ ^self ]. - "This will happen if the menu has toggles in it. (for instance, the 'show...' button) - Update the look, refresh the world and wait a bit, - to give the user some visual feedback" - contentString ifNotNil: [ - self contentsWithMarkers: contentString inverse: true. - self refreshWorld. - (Delay forMilliseconds: 200) wait]. - self deselect. - self invokeWithEvent: aMouseButtonEvent! ! -!UpdatingMenuItemMorph methodsFor: 'world' stamp: 'jmv 5/1/2018 01:24:02' prior: 50392183! - updateContents - "Update the receiver's contents" - - | newString enablement nArgs | - ((wordingProvider isNil) or: [wordingSelector isNil]) ifFalse: [ - nArgs _ wordingSelector numArgs. - newString _ nArgs = 0 - ifTrue: [ - wordingProvider perform: wordingSelector] - ifFalse: [ - (nArgs = 1 and: [wordingArgument notNil]) - ifTrue: [ - wordingProvider perform: wordingSelector with: wordingArgument] - ifFalse: [ - nArgs = arguments size ifTrue: [ - wordingProvider perform: wordingSelector withArguments: arguments]]]. - newString = (contentString ifNil: [ contents ]) - ifFalse: [ - self contents: newString ]]. - enablementSelector ifNotNil: [ - (enablement _ self enablement) == isEnabled - ifFalse: [self isEnabled: enablement]]! ! -!Theme methodsFor: 'accessing' stamp: 'jmv 4/30/2018 20:56:48' prior: 16936767! - decorateMenu: aMenu - - "decorate aMenu with icons" - - self flag: #todo. "Do I really belong on Theme, and not some menu class somewhere?" - - menuItemIcons ifEmpty: [ - ^ self ]. - - aMenu items do: [ :item | - | decoration | - decoration _ menuItemIcons - at: item contents asString asLowercase - ifAbsent: nil. - - decoration ifNotNil: [ - item set_icon: decoration ]]! ! - -MenuItemMorph removeSelector: #contents:withMarkers:! - -MenuItemMorph removeSelector: #contents:withMarkers:! - -MenuItemMorph removeSelector: #contents:withMarkers:inverse:! - -MenuItemMorph removeSelector: #contents:withMarkers:inverse:! - -MenuItemMorph removeSelector: #icon:! - -MenuItemMorph removeSelector: #icon:! - -MenuMorph removeSelector: #addBlankIconsIfNecessary:! - -MenuMorph removeSelector: #addBlankIconsIfNecessary:! - -MenuMorph removeSelector: #addWithLabel:enablement:action:! - -MenuMorph removeSelector: #addWithLabel:enablement:action:! - -MenuMorph removeSelector: #addWithLabel:enablementSelector:target:selector:argumentList:! - -MenuMorph removeSelector: #addWithLabel:enablementSelector:target:selector:argumentList:! - -MenuMorph removeSelector: #defaultTarget! - -MenuMorph removeSelector: #defaultTarget! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3300-BigMenuRefactor-p3-JuanVuletich-2018May01-01h15m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3296] on 1 May 2018 at 1:29:48 am'! - -MenuItemMorph subclass: #UpdatingMenuItemMorph - instanceVariableNames: 'wordingProvider wordingSelector enablementSelector wordingArgument ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #UpdatingMenuItemMorph category: #'Morphic-Menus'! -MenuItemMorph subclass: #UpdatingMenuItemMorph - instanceVariableNames: 'wordingProvider wordingSelector enablementSelector wordingArgument' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! -!UpdatingMenuItemMorph methodsFor: 'world' stamp: 'jmv 4/30/2018 21:36:20' prior: 50392404! - updateContents - "Update the receiver's contents" - - | newString enablement nArgs | - ((wordingProvider isNil) or: [wordingSelector isNil]) ifFalse: [ - nArgs _ wordingSelector numArgs. - newString _ nArgs = 0 - ifTrue: [ - wordingProvider perform: wordingSelector] - ifFalse: [ - nArgs = arguments size ifTrue: [ - wordingProvider perform: wordingSelector withArguments: arguments]]. - newString = (contentString ifNil: [ contents ]) - ifFalse: [ - self contents: newString ]]. - enablementSelector ifNotNil: [ - (enablement _ self enablement) == isEnabled - ifFalse: [self isEnabled: enablement]]! ! - -UpdatingMenuItemMorph removeSelector: #wordingArgument:! - -UpdatingMenuItemMorph removeSelector: #wordingArgument:! - -MenuItemMorph subclass: #UpdatingMenuItemMorph - instanceVariableNames: 'wordingProvider wordingSelector enablementSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #UpdatingMenuItemMorph category: #'Morphic-Menus'! -MenuItemMorph subclass: #UpdatingMenuItemMorph - instanceVariableNames: 'wordingProvider wordingSelector enablementSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3301-BigMenuRefactor-p4-JuanVuletich-2018May01-01h26m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3300] on 1 May 2018 at 10:29:54 am'! -!MenuItemMorph methodsFor: 'accessing' stamp: 'jmv 4/30/2018 21:22:56'! - setBlankIcon - "change the the receiver's icon" - icon := Theme current blankIcon! ! -!MenuItemMorph methodsFor: 'accessing' stamp: 'jmv 4/30/2018 21:26:57'! - target: anObject selector: aSymbol arguments: aCollection - - target _ anObject. - selector _ aSymbol. - arguments _ aCollection! ! -!MenuMorph methodsFor: 'accessing' stamp: 'jmv 5/1/2018 10:27:02' prior: 50392240! - addBlankIconsIfNecessary - "If any of my items have an icon, ensure that all do by using anIcon for those that don't" - - | withIcons withoutIcons | - withIcons _ Set new. - withoutIcons _ Set new. - self items do: [ :item | - item hasIcon | item hasMarker - ifTrue: [ withIcons add: item ] - ifFalse: [ withoutIcons add: item ]. - item hasSubMenu ifTrue: [ item subMenu addBlankIconsIfNecessary ]]. - (withIcons isEmpty or: [ withoutIcons isEmpty ]) ifTrue: [ ^self ]. - withoutIcons do: [ :item | item setBlankIcon ]! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:15:20' prior: 50392307! - add: aString target: target selector: aSymbol argumentList: argList - "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument. Answer the appended menu item." - - | item | - item _ MenuItemMorph new - contents: aString; - target: target selector: aSymbol arguments: argList asArray. - self addMorphBack: item. - ^ item! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:15:48' prior: 16866555! - addUpdating: wordingSelector target: target selector: aSymbol argumentList: argList - "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument. In this variant, the wording of the menu item is obtained by sending the wordingSelector to the target, Answer the item added." - - | item | - item _ UpdatingMenuItemMorph new - target: target selector: aSymbol arguments: argList asArray; - wordingProvider: target wordingSelector: wordingSelector. - self addMorphBack: item. - ^ item! ! -!MenuItemMorph methodsFor: 'accessing' stamp: 'jmv 5/1/2018 10:23:05' prior: 50392261! - contentsWithMarkers: aString inverse: inverse - "Set the menu item entry. Parse aString for embedded markers." - - | markerIndex marker | - contentString _ nil. "get rid of old" - self removeAllMorphs. "get rid of old markers if updating" - icon _ nil. - (aString notEmpty and: [aString first = $<]) - ifFalse: [^super contents: aString]. - markerIndex := aString indexOf: $>. - markerIndex = 0 ifTrue: [^super contents: aString]. - marker := (aString copyFrom: 1 to: markerIndex) asLowercase. - (#('' '' '' '') includes: marker) - ifFalse: [^super contents: aString]. - contentString _ aString. "remember actual string" - marker := (marker = '' or: [marker = '']) ~= inverse - ifTrue: [self onImage] - ifFalse: [self offImage]. - super contents: (aString copyFrom: markerIndex + 1 to: aString size). - "And set the marker" - marker := ImageMorph new image: marker. - self addMorphFront: marker position: `0@2`! ! -!MenuItemMorph methodsFor: 'drawing' stamp: 'jmv 5/1/2018 10:25:29' prior: 50385249! - drawOn: aCanvas - | stringColor leftEdge | - - stringColor _ color. - isSelected & isEnabled - ifTrue: [ - aCanvas fillRectangle: (`0@0` extent: extent) color: Theme current menuHighlight]. - leftEdge _ 0. - - self hasMarker ifTrue: [ - leftEdge _ leftEdge + submorphs first morphWidth + 8 ]. - - icon ifNotNil: [ - | iconForm | - iconForm _ isEnabled ifTrue: [ icon ] ifFalse: [ icon asGrayScaleAndTransparent ]. - aCanvas image: iconForm at: leftEdge+1 @ (extent y - iconForm height // 2). - leftEdge _ leftEdge + iconForm width + self iconSeparation]. - - aCanvas - drawString: contents - at: leftEdge @ 1 - font: self fontToUse - color: stringColor. - subMenu ifNotNil: [ - aCanvas - image: self class subMenuMarker - at: extent x - 8 @ (extent y - self class subMenuMarker height // 2) ]! ! -!MenuItemMorph methodsFor: 'layout' stamp: 'jmv 5/1/2018 10:25:03' prior: 16866123! - minItemWidth - | fontToUse iconWidth subMenuWidth markerWidth | - fontToUse _ self fontToUse. - subMenuWidth _ self hasSubMenu - ifFalse: [0] - ifTrue: [10]. - iconWidth _ icon - ifNotNil: [icon width + self iconSeparation] - ifNil: [0]. - markerWidth _ self hasMarker - ifTrue: [ submorphs first morphWidth + 8 ] - ifFalse: [ 0 ]. - ^ (fontToUse widthOfString: contents) - + subMenuWidth + iconWidth + markerWidth.! ! - -MenuItemMorph removeSelector: #arguments! - -MenuItemMorph removeSelector: #arguments! - -MenuItemMorph removeSelector: #arguments:! - -MenuItemMorph removeSelector: #arguments:! - -MenuItemMorph removeSelector: #icon! - -MenuItemMorph removeSelector: #icon! - -MenuItemMorph removeSelector: #selector! - -MenuItemMorph removeSelector: #selector! - -MenuItemMorph removeSelector: #selector:! - -MenuItemMorph removeSelector: #selector:! - -MenuItemMorph removeSelector: #target! - -MenuItemMorph removeSelector: #target! - -MenuItemMorph removeSelector: #target:! - -MenuItemMorph removeSelector: #target:! - -MenuMorph removeSelector: #target:! - -MenuMorph removeSelector: #target:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3302-BigMenuRefactor-p5-JuanVuletich-2018May01-10h14m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3300] on 1 May 2018 at 10:51:01 am'! -!ChangeSorterWindow methodsFor: 'menu building' stamp: 'jmv 5/1/2018 10:35:14' prior: 16800084! - changeSetMenu - "Set up aMenu to hold commands for the change-set-list pane. This could be for a single or double changeSorter" - - | aMenu isForBaseSystem | - isForBaseSystem _ model changeSet isForBaseSystem. - aMenu _ MenuMorph new defaultTarget: model. - aMenu title: 'Change Set'. - aMenu addStayUpIcons. - - (aMenu add: 'File out and remove (o)' action: #fileOutAndRemove) isEnabled: isForBaseSystem. - aMenu add: 'File out and keep (k)' action: #fileOutAndKeep. - aMenu addLine. - - (aMenu add: 'Rename change set (r)' action: #rename) isEnabled: isForBaseSystem. - (aMenu add: 'Destroy change set (x)' action: #remove) isEnabled: isForBaseSystem. - aMenu addLine. - model currentCanHavePreambleAndPostscript ifTrue: [ - aMenu addLine. - model currentHasPreamble - ifTrue: [ - aMenu add: 'Edit preamble (p)' action: #addPreamble. - aMenu add: 'Remove preamble' action: #removePreamble] - ifFalse: [ - aMenu add: 'Add preamble (p)' action: #addPreamble]. - model currentHasPostscript - ifTrue: [ - aMenu add: 'Edit postscript...' action: #editPostscript. - aMenu add: 'Remove postscript' action: #removePostscript] - ifFalse: [ - aMenu add: 'Add postscript...' action: #editPostscript]. - ]. - aMenu addLine. - - "CONFLICTS SECTION" - aMenu add: 'conflicts with other change sets' target: self action: #browseMethodConflicts. - aMenu balloonTextForLastItem: 'Browse all methods that occur both in this change set and in at least one other change set.'. - aMenu addLine. - - "CHECKS SECTION" - (aMenu add: 'trim history' action: #trimHistory) isEnabled: isForBaseSystem. - aMenu balloonTextForLastItem: ' Drops any methods added and then removed, as well as renaming and reorganization of newly-added classes. ', - 'NOTE: can cause confusion if later filed in over an earlier version of these changes'. - - aMenu add: 'view affected class categories' action: #viewAffectedClassCategories. - aMenu balloonTextForLastItem: ' Show class categories affected by any contained change'. - - ^ aMenu! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:43:21' prior: 16866322! - add: aString action: aSymbol - "Append a menu item with the given label. If the item is selected, it will send the given selector to the default target object." - "Details: Note that the menu item added captures the default target object at the time the item is added; the default target can later be changed before added additional items without affecting the targets of previously added entries. The model is that each entry is like a button that knows everything it needs to perform its action." - - ^self add: aString - target: defaultTarget - selector: aSymbol - argumentList: #()! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:44:00' prior: 16866365! - add: aString selector: aSymbol argument: arg - - ^self add: aString - target: defaultTarget - selector: aSymbol - argumentList: (Array with: arg) -! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:44:36' prior: 50392298! - add: aString subMenu: aMenuMorph - "Append the given submenu with the given label." - - | item | - item _ MenuItemMorph new. - item - contents: aString; - subMenu: aMenuMorph. - self addMorphBack: item. - ^item! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:44:10' prior: 16866381! - add: aString target: aTarget action: aSymbol - ^self add: aString - target: aTarget - selector: aSymbol - argumentList: #()! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:44:15' prior: 16866388! - add: aString target: anObject selector: aSymbol - "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object." - - ^self add: aString - target: anObject - selector: aSymbol - argumentList: #()! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:48:29' prior: 16866398! - add: aString target: target selector: aSymbol argument: arg - "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given argument." - - ^self add: aString - target: target - selector: aSymbol - argumentList: { arg }! ! -!CustomMenu methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:47:21' prior: 16826787! - addList: listOfTuplesAndDashes - "Add a menu item to the receiver for each tuple in the given list of the form ( ). Add a line for each dash (-) in the list." - - listOfTuplesAndDashes do: [:aTuple | - aTuple == #- - ifTrue: [self addLine] - ifFalse: [self add: aTuple first action: aTuple second]] - - " - CustomMenu new addList: #( - ('apples' buyApples) - ('oranges' buyOranges) - - - ('milk' buyMilk)); startUpMenu - " - -! ! - -CustomMenu removeSelector: #add:target:selector:! - -CustomMenu removeSelector: #add:target:selector:! - -CustomMenu removeSelector: #add:target:selector:argument:! - -CustomMenu removeSelector: #add:target:selector:argument:! - -CustomMenu removeSelector: #add:target:selector:argumentList:! - -CustomMenu removeSelector: #add:target:selector:argumentList:! - -CustomMenu removeSelector: #addStayUpIcons! - -CustomMenu removeSelector: #addStayUpIcons! - -MenuMorph removeSelector: #add:action:enabled:! - -MenuMorph removeSelector: #add:action:enabled:! - -MenuMorph removeSelector: #add:target:selector:arguments:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3303-BigMenuRefactor-p6-JuanVuletich-2018May01-10h29m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3300] on 1 May 2018 at 11:01:26 am'! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:59:27'! - add: aString target: target action: aSymbol argument: arg - "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given argument." - - ^self add: aString - target: target - action: aSymbol - argumentList: { arg }! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:58:49'! - add: aString target: target action: aSymbol argumentList: argList - "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument. Answer the appended menu item." - - | item | - item _ MenuItemMorph new - contents: aString; - target: target selector: aSymbol arguments: argList asArray. - self addMorphBack: item. - ^ item! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:58:11'! - addUpdating: wordingSelector target: target action: aSymbol argumentList: argList - "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument. In this variant, the wording of the menu item is obtained by sending the wordingSelector to the target, Answer the item added." - - | item | - item _ UpdatingMenuItemMorph new - target: target selector: aSymbol arguments: argList asArray; - wordingProvider: target wordingSelector: wordingSelector. - self addMorphBack: item. - ^ item! ! -!SimpleServiceEntry methodsFor: 'services menu' stamp: 'jmv 5/1/2018 10:55:06' prior: 16907962! - addServiceFor: served toMenu: aMenu - argumentProvider _ served. - aMenu add: self label - target: self - action: #performService. - self useLineAfter ifTrue: [ aMenu addLine ].! ! -!CPUWatcher methodsFor: 'porcine capture' stamp: 'jmv 5/1/2018 11:00:03' prior: 16795021! - openMorphicWindowForSuspendedProcess: aProcess - | menu rule | - menu _ MenuMorph new. - "nickname allow-stop allow-debug" - rule _ (ProcessBrowser rulesFor: aProcess) second. - menu add: 'Dismiss this menu' target: menu action: #delete; addLine. - menu add: 'Open Process Browser' target: ProcessBrowserWindow action: #openProcessBrowser. - menu add: 'Resume' - target: self - action: #resumeProcess:fromMenu: - argumentList: { aProcess . menu }. - menu add: 'Terminate' - target: self - action: #terminateProcess:fromMenu: - argumentList: { aProcess . menu }. - rule ifTrue: [ - menu add: 'Debug at a lower priority' - target: self - action: #debugProcess:fromMenu: - argumentList: { aProcess . menu }. - ]. - menu addTitle: aProcess identityHash asString, - ' ', aProcess name, - ' is taking too much time and has been suspended. -What do you want to do with it?'. - menu stayUp. - menu popUpInWorld -! ! -!AbstractFont class methodsFor: 'instance accessing' stamp: 'jmv 5/1/2018 10:56:07' prior: 16777431! - fromUser: priorFont - " - AbstractFont fromUser - " - "Present a menu of available fonts, and if one is chosen, return it. - Otherwise return nil. - Show only baseFonts i.e. FamilyName, pointSize (but do not include emphasis, such as italic or bold)" - - | fontList fontMenu active ptMenu label spec | - fontList := AbstractFont familyNames. - fontMenu := MenuMorph new defaultTarget: self. - fontList do: [:fontName | - active := priorFont familyName sameAs: fontName. - ptMenu := MenuMorph new defaultTarget: self. - (AbstractFont pointSizesFor:fontName ) do: [ :pt | - (active and: [pt = priorFont pointSize]) - ifTrue: [label := ''] - ifFalse: [label := '']. - label := label , pt printString , ' pt'. - ptMenu - add: label - target: fontMenu - action: #modalSelection: - argument: { - fontName. - pt}]. - active ifTrue: [label := ''] ifFalse: [label := '']. - label := label , fontName. - fontMenu add: label subMenu: ptMenu]. - spec := fontMenu invokeModal. - spec ifNil: [^nil]. - ^AbstractFont familyName: spec first pointSize: spec last! ! -!Morph methodsFor: 'debug and other' stamp: 'jmv 5/1/2018 10:55:33' prior: 50376318! - buildDebugMenu: aHand - "Answer a debugging menu for the receiver. The hand argument is seemingly historical and plays no role presently" - - | aMenu | - aMenu := MenuMorph new defaultTarget: self. - aMenu addStayUpIcons. - self isKnownFailing - ifTrue: [ - aMenu add: 'start drawing again' action: #resumeAfterDrawError. - aMenu addLine]. - (self hasProperty: #errorOnStep) - ifTrue: [ - aMenu add: 'start stepping again' action: #resumeAfterStepError. - aMenu addLine]. - aMenu add: 'inspect morph' action: #inspect. - aMenu add: 'inspect owner chain' action: #inspectOwnerChain. - self hasModel - ifTrue: [ - aMenu - add: 'inspect model' - target: self model - action: #inspect]. - aMenu - add: 'explore morph' - target: self - action: #explore. - aMenu - add: 'copy to clipboard (c)' - target: self - action: #copyToClipboard. - aMenu addLine. - aMenu - add: 'browse morph class' - target: self - action: #browseClassHierarchy. - self hasModel - ifTrue: [ - aMenu - add: 'browse model class' - target: self model - action: #browseClassHierarchy]. - aMenu addLine. - aMenu - add: 'edit balloon help' action: #editBalloonHelpText. - ^aMenu! ! -!Morph methodsFor: 'meta-actions' stamp: 'jmv 5/1/2018 10:59:32' prior: 16876336! - addEmbeddingMenuItemsTo: aMenu hand: aHandMorph - | menu | - menu _ MenuMorph new defaultTarget: self. - self potentialEmbeddingTargets reverseDo: [:m | - menu - add: m class name asString - target: m - action: #addMorphFrontFromWorldPosition: - argumentList: {self}]. - aMenu ifNotNil:[ - menu submorphCount > 0 - ifTrue:[aMenu add:'embed into' subMenu: menu]. - ]. - ^menu! ! -!ObjectExplorerWindow methodsFor: 'building menus' stamp: 'jmv 5/1/2018 10:56:13' prior: 50376392! - genericMenu - "Borrow a menu from my inspector" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - model getCurrentSelection - ifNil: [ - aMenu - add: '*nothing selected*' - target: self - action: #yourself] - ifNotNil: [ - aMenu addList: #( - ('inspect (i)' inspectSelection) - ('explore (I)' exploreSelection) - ('copy to clipboard (c)' copySelectionToClipboard) - ('basic inspect' inspectBasic) - ('references finder' openReferencesFinder) - ('weight explorer' openWeightExplorer) - - - ('browse full (b)' browseMethodFull) - ('browse hierarchy (h)' browseHierarchy) - ('browse protocol (p)' browseFullProtocol)). - aMenu addLine; - add: 'monitor changes' - target: self - action: #monitor: - argument: model getCurrentSelection. - model class == ReferencesExplorer ifTrue: [ - aMenu addLine; - add: 'rescan' - target: self - action: #rescan ]]. - model basicMonitorList isEmptyOrNil - ifFalse: [ - aMenu addLine; - add: 'stop monitoring all' - target: self - action: #stopMonitoring ]. - ^ aMenu! ! -!TestRunnerWindow methodsFor: 'menu building' stamp: 'jmv 5/1/2018 10:56:21' prior: 16928753! - listMenu - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu title: 'Test Cases'. - aMenu add: 'select all' target: model action: #selectAll. - aMenu add: 'deselect all' target: model action: #deselectAll. - aMenu add: 'toggle selections' target: model action: #invertSelections. - aMenu add: 'filter' target: model action: #setFilter. - model runButtonState ifTrue: [ - aMenu add: 'stop' target: model action: #terminateRun - ]. - model selectedSuite > 0 ifTrue: [ | cls | - cls _ (model tests at: model selectedSuite ifAbsent: ['']) copyUpTo: Character space. - cls _ cls asSymbol. - cls _ (Smalltalk at: cls ifAbsent: nil). - cls ifNotNil: [ - aMenu addLine. - aMenu add: 'browse' target: self action: #browse: argument: cls. - ]. - ]. - aMenu addLine. - aMenu add: 'log to Transcript' target: model action: #showResult. - ^aMenu! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:59:08' prior: 50392790! - add: aString action: aSymbol - "Append a menu item with the given label. If the item is selected, it will send the given selector to the default target object." - "Details: Note that the menu item added captures the default target object at the time the item is added; the default target can later be changed before added additional items without affecting the targets of previously added entries. The model is that each entry is like a button that knows everything it needs to perform its action." - - ^self add: aString - target: defaultTarget - action: aSymbol - argumentList: #()! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:59:21' prior: 50392811! - add: aString selector: aSymbol argument: arg - - ^self add: aString - target: defaultTarget - action: aSymbol - argumentList: { arg }! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:59:24' prior: 50392829! - add: aString target: aTarget action: aSymbol - ^self add: aString - target: aTarget - action: aSymbol - argumentList: #()! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:58:24' prior: 16866541! - addUpdating: aWordingSelector action: aSymbol - - self addUpdating: aWordingSelector target: defaultTarget action: aSymbol argumentList: #()! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:58:30' prior: 16866548! - addUpdating: aWordingSelector target: aTarget action: aSymbol - - self addUpdating: aWordingSelector target: aTarget action: aSymbol argumentList: #()! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:56:28' prior: 50343966! - alphabeticalMorphMenu - | list splitLists menu firstChar lastChar subMenu | - list := Morph withAllSubclasses select: [ :m | - m includeInNewMorphMenu ]. - list := list asArray sort: [ :c1 :c2 | - c1 name < c2 name ]. - splitLists := self - splitNewMorphList: list - depth: 4. - menu := MenuMorph new defaultTarget: self. - 1 - to: splitLists size - do: [ :i | - firstChar := i = 1 - ifTrue: [ $A ] - ifFalse: [ - (splitLists at: i) first name first: 3 ]. - lastChar := i = splitLists size - ifTrue: [ $Z ] - ifFalse: [ - (splitLists at: i) last name first: 3 ]. - subMenu := MenuMorph new. - (splitLists at: i) do: [ :cl | - subMenu - add: cl name - target: self - action: #newMorphOfClass:event: - argument: cl ]. - menu - add: firstChar asString , ' - ' , lastChar asString - subMenu: subMenu ]. - ^ menu.! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:59:35' prior: 16934888! - fillIn: aMenu from: dataForMenu - "A menu constructor utility by RAA. dataForMenu is a list of items which mean: - nil Indicates to add a line - - first element is symbol Add updating item with the symbol as the wording selector - second element is a list second element has the receiver and selector - - first element is a string Add menu item with the string as its wording - second element is a list second element has the receiver and selector - - a third element exists Use it as the balloon text - a fourth element exists Use it as the enablement selector (updating case only)" - - | item | - - dataForMenu do: [ :itemData | - itemData ifNil: [aMenu addLine] ifNotNil: [ - item _ itemData first isSymbol - ifTrue: [ - aMenu - addUpdating: itemData first - target: self - action: #doMenuItem:with: - argumentList: {itemData second}] - ifFalse: [ - aMenu - add: itemData first - target: self - action: #doMenuItem:with: - argumentList: {itemData second}]. - itemData size >= 3 ifTrue: [ - aMenu balloonTextForLastItem: itemData third. - itemData size >= 4 ifTrue: [ - item enablementSelector: itemData fourth ]]]]. - - ^ aMenu! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:59:42' prior: 16934928! - fillIn: aMenu fromDictionaries: dataForMenuDicts - "A menu constructor utility that uses Dictionaries with elements: - #label - the name that displays in the menu - #object - the target object - #selector - the selector called on object when the menu item is selected - #arguments - optional collection of arguments passed to the selector - #balloonText - optional 'tool tip' style help text - - note, nil elements will add a line." - dataForMenuDicts do: [ :dict | - dict - ifNil: [ aMenu addLine ] - ifNotNil: [ - (dict at: #label) isSymbol - ifTrue: [ - aMenu - addUpdating: (dict at: #label) - target: (dict at: #object) - action: (dict at: #selector) - argumentList: - (dict - at: #arguments - ifAbsent: [ #() ]) ] - ifFalse: [ - aMenu - add: (dict at: #label) - target: (dict at: #object) - action: (dict at: #selector) - argumentList: - (dict - at: #arguments - ifAbsent: [ #() ]) ]. - dict - at: #balloonText - ifPresent: [ :balloonText | - aMenu balloonTextForLastItem: balloonText ]]]. - ^ aMenu.! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/1/2018 10:56:32' prior: 50344234! - newMorph - "The user requested 'new morph' from the world menu. Put up a menu that allows many ways of obtaining new morphs. If the preference #classicNewMorphMenu is true, the full form of yore is used; otherwise, a much shortened form is used." - | menu subMenu catDict | - menu _ self menu: 'Add a new morph'. - menu - - add: 'From Clipboard' - target: myHand - action: #pasteMorph; - - add: 'From Alphabetical List' - subMenu: self alphabeticalMorphMenu. - menu addLine. - "Add 'Classic' New Morph menu" - catDict _ Dictionary new. - - Morph allSubclassesDo: [ :eaSubclass | - eaSubclass includeInNewMorphMenu ifTrue: [ | category | - (eaSubclass respondsTo: #categoryInNewMorphMenu) - ifTrue: [ category _ eaSubclass categoryInNewMorphMenu ] - ifFalse: [ category _ 'Unknown' ]. - (catDict includesKey: category) - ifTrue: [ (catDict at: category) add: eaSubclass ] - ifFalse: [ - catDict - at: category - put: (OrderedCollection with: eaSubclass) ]]]. - catDict keys sort do: [ :categ | - subMenu _ MenuMorph new. - ((catDict at: categ) asArray sort: [ :c1 :c2 | - c1 name < c2 name ]) do: [ :cl | - subMenu - add: cl name - target: self - action: #newMorphOfClass:event: - argument: cl ]. - menu - add: categ - subMenu: subMenu ]. - self doPopUp: menu.! ! - -MenuMorph removeSelector: #add:target:selector:! - -MenuMorph removeSelector: #add:target:selector:! - -MenuMorph removeSelector: #add:target:selector:argument:! - -MenuMorph removeSelector: #add:target:selector:argument:! - -MenuMorph removeSelector: #add:target:selector:argumentList:! - -MenuMorph removeSelector: #add:target:selector:argumentList:! - -MenuMorph removeSelector: #addUpdating:target:selector:argumentList:! - -MenuMorph removeSelector: #addUpdating:target:selector:argumentList:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3304-BigMenuRefactor-p7-JuanVuletich-2018May01-10h51m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3303] on 1 May 2018 at 12:46:35 pm'! -!Morph methodsFor: 'menus' stamp: 'jmv 5/1/2018 11:26:39' prior: 16876165! - addHaloActionsTo: aMenu - "Add items to aMenu representing actions requestable via halo" - - | subMenu | - subMenu := MenuMorph new defaultTarget: self. - subMenu addTitle: (self printStringLimitedTo: 40). - subMenu addStayUpIcons. - subMenu addLine. - (subMenu add: 'delete' action: #dismissViaHalo) - setBalloonText: 'Delete this object -- warning -- can be destructive!!' . - self maybeAddCollapseItemTo: subMenu. - (subMenu add: 'grab' action: #openInHand) - setBalloonText: 'Pick this object up -- warning, since this removes it from its container, it can have adverse effects.' . - subMenu addLine. - (subMenu add: 'resize' action: #resizeFromMenu) - setBalloonText: 'Change the size of this object'. - (subMenu add: 'duplicate' action: #maybeDuplicateMorph) - setBalloonText: 'Hand me a copy of this object'. - (subMenu - add: 'set color' - target: self - action: #changeColor) - setBalloonText: 'Change the color of this object'. - (subMenu - add: 'inspect' - target: self - action: #inspect) - setBalloonText: 'Open an Inspector on this object'. - aMenu add: 'halo actions...' subMenu: subMenu! ! -!Morph methodsFor: 'menus' stamp: 'jmv 5/1/2018 11:26:53' prior: 16876246! - addToggleItemsToHaloMenu: aMenu - "Add standard true/false-checkbox items to the memu" - - #( - (stickinessString toggleStickiness 'whether I should be resistant to a drag done by mousing down on me') - (lockedString lockUnlockMorph 'when "locked", I am inert to all user interactions') - ) do: [ :trip | - (aMenu addUpdating: trip first action: trip second) - setBalloonText: trip third ]! ! -!CodeWindow methodsFor: 'menu building' stamp: 'jmv 5/1/2018 11:24:50' prior: 16813594! - addContentsTogglesTo: aMenu - "Add updating menu toggles governing contents to aMenu." - - model contentsSymbolQuints do: [ :aQuint | - aQuint == #- - ifTrue: [ - aMenu addLine] - ifFalse: [ - (aMenu addUpdating: aQuint third target: model action: aQuint second) - setBalloonText: aQuint fifth ]]! ! -!ChangeSorterWindow methodsFor: 'menu building' stamp: 'jmv 5/1/2018 11:24:14' prior: 50392723! - changeSetMenu - "Set up aMenu to hold commands for the change-set-list pane. This could be for a single or double changeSorter" - - | aMenu isForBaseSystem | - isForBaseSystem _ model changeSet isForBaseSystem. - aMenu _ MenuMorph new defaultTarget: model. - aMenu title: 'Change Set'. - aMenu addStayUpIcons. - - (aMenu add: 'File out and remove (o)' action: #fileOutAndRemove) isEnabled: isForBaseSystem. - aMenu add: 'File out and keep (k)' action: #fileOutAndKeep. - aMenu addLine. - - (aMenu add: 'Rename change set (r)' action: #rename) isEnabled: isForBaseSystem. - (aMenu add: 'Destroy change set (x)' action: #remove) isEnabled: isForBaseSystem. - aMenu addLine. - model currentCanHavePreambleAndPostscript ifTrue: [ - aMenu addLine. - model currentHasPreamble - ifTrue: [ - aMenu add: 'Edit preamble (p)' action: #addPreamble. - aMenu add: 'Remove preamble' action: #removePreamble] - ifFalse: [ - aMenu add: 'Add preamble (p)' action: #addPreamble]. - model currentHasPostscript - ifTrue: [ - aMenu add: 'Edit postscript...' action: #editPostscript. - aMenu add: 'Remove postscript' action: #removePostscript] - ifFalse: [ - aMenu add: 'Add postscript...' action: #editPostscript]. - ]. - aMenu addLine. - - "CONFLICTS SECTION" - (aMenu add: 'conflicts with other change sets' target: self action: #browseMethodConflicts) - setBalloonText: 'Browse all methods that occur both in this change set and in at least one other change set.'. - aMenu addLine. - - "CHECKS SECTION" - (aMenu add: 'trim history' action: #trimHistory) - isEnabled: isForBaseSystem; - setBalloonText: ' Drops any methods added and then removed, as well as renaming and reorganization of newly-added classes. ', - 'NOTE: can cause confusion if later filed in over an earlier version of these changes'. - - (aMenu add: 'view affected class categories' action: #viewAffectedClassCategories) - setBalloonText: ' Show class categories affected by any contained change'. - - ^ aMenu! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 11:25:14' prior: 16866439! - addList: aList - "Add the given items to this menu, where each item is a pair ( ).. If an element of the list is simply the symobl $-, add a line to the receiver. The optional third element of each entry, if present, provides balloon help." - - | target item | - aList do: [:tuple | - tuple == #- - ifTrue: [ self addLine ] - ifFalse: [ - target _ tuple size > 3 - ifTrue: [ defaultTarget perform: tuple fourth ] - ifFalse: [ defaultTarget ]. - item _ self add: tuple first target: target action: tuple second. - tuple size > 2 ifTrue: [ - item setBalloonText: tuple third]]]! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 11:24:38' prior: 50393195! -addUpdating: aWordingSelector action: aSymbol - - ^self addUpdating: aWordingSelector target: defaultTarget action: aSymbol argumentList: #()! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/1/2018 11:24:33' prior: 50393203! - addUpdating: aWordingSelector target: aTarget action: aSymbol - - ^self addUpdating: aWordingSelector target: aTarget action: aSymbol argumentList: #()! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/1/2018 12:45:58' prior: 50393241! - fillIn: aMenu from: dataForMenu - "A menu constructor utility by RAA. dataForMenu is a list of items which mean: - nil Indicates to add a line - - first element is symbol Add updating item with the symbol as the wording selector - second element is a list second element has the receiver and selector - - first element is a string Add menu item with the string as its wording - second element is a list second element has the receiver and selector - - a third element exists Use it as the balloon text - a fourth element exists Use it as the enablement selector (updating case only)" - - | item | - - dataForMenu do: [ :itemData | - itemData ifNil: [aMenu addLine] ifNotNil: [ - item _ aMenu - add: itemData first - target: self - action: #doMenuItem:with: - argumentList: {itemData second}. - itemData size >= 3 ifTrue: [ - item setBalloonText: itemData third. - itemData size >= 4 ifTrue: [ - item enablementSelector: itemData fourth ]]]]. - - ^ aMenu! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/1/2018 11:27:29' prior: 50393282! - fillIn: aMenu fromDictionaries: dataForMenuDicts - "A menu constructor utility that uses Dictionaries with elements: - #label - the name that displays in the menu - #object - the target object - #selector - the selector called on object when the menu item is selected - #arguments - optional collection of arguments passed to the selector - #balloonText - optional 'tool tip' style help text - - note, nil elements will add a line." - | item | - dataForMenuDicts do: [ :dict | - dict - ifNil: [ aMenu addLine ] - ifNotNil: [ - item _ (dict at: #label) isSymbol - ifTrue: [ - aMenu - addUpdating: (dict at: #label) - target: (dict at: #object) - action: (dict at: #selector) - argumentList: - (dict - at: #arguments - ifAbsent: [ #() ]) ] - ifFalse: [ - aMenu - add: (dict at: #label) - target: (dict at: #object) - action: (dict at: #selector) - argumentList: - (dict - at: #arguments - ifAbsent: [ #() ]) ]. - dict - at: #balloonText - ifPresent: [ :balloonText | - item setBalloonText: balloonText ]]]. - ^ aMenu! ! - -CustomMenu removeSelector: #balloonTextForLastItem:! - -CustomMenu removeSelector: #balloonTextForLastItem:! - -MenuMorph removeSelector: #balloonTextForLastItem:! - -MenuMorph removeSelector: #balloonTextForLastItem:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3305-BigMenuRefactor-p8-JuanVuletich-2018May01-12h43m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3304] on 1 May 2018 at 9:11:14 pm'! -!Collection methodsFor: 'converting' stamp: 'jmv 5/1/2018 14:28:51'! - asDictionary - "Answer a Dictionary. Assume our elements are Associations. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Browser'. - #object -> BrowserWindow. - #selector -> #openBrowser. - #icon -> #editFindReplaceIcon. - #balloonText -> 'A Smalltalk code browser, for studying and modifying the system'. - } asDictionary - " - - ^ self as: Dictionary! ! -!MenuItemMorph methodsFor: 'accessing' stamp: 'jmv 5/1/2018 14:17:12'! - setIcon: symbolOrFormOrNil - "Argument can be a Form, a Symbol (to be sent to Theme current) or nil." - - icon _ symbolOrFormOrNil isSymbol - ifTrue: [Theme current perform: symbolOrFormOrNil] - ifFalse: [ symbolOrFormOrNil ]! ! -!Workspace class methodsFor: 'menu-world' stamp: 'jmv 5/1/2018 21:07:43' prior: 16945473! - worldMenuForOpenGroup - ^ `{ - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'Workspace'. - #object -> Workspace. - #selector -> #openWorkspace. - #icon -> #terminalIcon. - #balloonText -> 'A window for evaluating Smalltalk expressions'. - } asDictionary`! ! -!Transcripter class methodsFor: 'menu-world' stamp: 'jmv 5/1/2018 21:06:41' prior: 16938956! - worldMenuForOpenGroup - ^ `{ - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Emergency Evaluator'. - #object -> Transcripter. - #selector -> #emergencyEvaluator. - #icon -> #emblemImportantIcon. - #balloonText -> 'When all else fails...'. - } asDictionary`! ! -!TextEditor class methodsFor: 'menu-world' stamp: 'jmv 5/1/2018 21:04:48' prior: 16933249! - worldMenuForOpenGroup - ^ `{ - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Text Editor'. - #object -> TextEditor. - #selector -> #openTextEditor. - #icon -> #textEditorIcon. - #balloonText -> 'A window for composing text'. - } asDictionary`! ! -!CodePackageListWindow class methodsFor: 'menu-world' stamp: 'jmv 5/1/2018 14:38:08' prior: 16811663! - worldMenuForOpenGroup - ^ `{ - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Installed Packages'. - #object -> CodePackageListWindow. - #selector -> #openPackageList. - #icon -> #packageIcon. - #balloonText -> 'A tool for managing Packages (optional units of code) installed in the system'. - } asDictionary`! ! -!BrowserWindow class methodsFor: 'menu-world' stamp: 'jmv 5/1/2018 14:36:38' prior: 16793528! - worldMenuForOpenGroup - ^ `{ - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Browser'. - #object -> BrowserWindow. - #selector -> #openBrowser. - #icon -> #editFindReplaceIcon. - #balloonText -> 'A Smalltalk code browser, for studying and modifying the system'. - } asDictionary`! ! -!MessageNamesWindow class methodsFor: 'menu-world' stamp: 'jmv 5/1/2018 21:01:20' prior: 16867850! - worldMenuForOpenGroup - ^ `{ - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'Message Names'. - #object -> MessageNamesWindow. - #selector -> #openMessageNames. - #icon -> #inspectIcon. - #balloonText -> 'A tool for finding and editing methods that contain any given keyword in their names.'. - } asDictionary`! ! -!ChangeSorterWindow class methodsFor: 'menu-world' stamp: 'jmv 5/1/2018 14:36:47' prior: 16800316! - worldMenuForOpenGroup - ^ `{ - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Change Sorter'. - #object -> ChangeSorterWindow. - #selector -> #openChangeSorter. - #icon -> #halfRefreshIcon. - #balloonText -> 'A tool allowing you to view the methods in a Change Set, especially changes to the Base System'. - } asDictionary`! ! -!FileListWindow class methodsFor: 'menu-world' stamp: 'jmv 5/1/2018 21:00:10' prior: 16843460! - worldMenuForOpenGroup - ^ `{ - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'File List'. - #object -> FileListWindow. - #selector -> #openFileList. - #icon -> #systemFileManagerIcon. - #balloonText -> 'An explorer of the File System'. - } asDictionary`! ! -!ProcessBrowserWindow class methodsFor: 'menu-world' stamp: 'jmv 5/1/2018 21:02:47' prior: 16895580! - worldMenuForOpenGroup - ^ `{ - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Process Browser'. - #object -> ProcessBrowserWindow. - #selector -> #openProcessBrowser. - #icon -> #systemMonitorIcon. - #balloonText -> 'A tool to monitor and manage Smalltalk processes'. - } asDictionary`! ! -!TestRunnerWindow class methodsFor: 'menu-world' stamp: 'jmv 5/1/2018 21:03:55' prior: 16928799! - worldMenuForOpenGroup - ^ `{ - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'SUnit Test Runner'. - #object -> TestRunnerWindow. - #selector -> #openTestRunner. - #icon -> #weatherFewCloudsIcon. - #balloonText -> 'Smalltalk''s testing framework'. - } asDictionary`! ! -!TranscriptWindow class methodsFor: 'menu-world' stamp: 'jmv 5/1/2018 21:05:41' prior: 16938780! - worldMenuForOpenGroup - ^ `{ - #itemGroup -> 10. - #itemOrder -> 50. - #label -> 'Transcript'. - #object -> TranscriptWindow. - #selector -> #openTranscript. - #icon -> #printerIcon. - #balloonText -> 'A window showing contents of the System Transcript'. - } asDictionary`! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/1/2018 14:18:59' prior: 50393589! - fillIn: aMenu fromDictionaries: dataForMenuDicts - "A menu constructor utility that uses Dictionaries with elements: - #label - the name that displays in the menu - #object - the target object - #selector - the selector called on object when the menu item is selected - #arguments - optional collection of arguments passed to the selector - #balloonText - optional 'tool tip' style help text - #icon- optional icon selector or Form - - note, nil elements will add a line." - | item | - dataForMenuDicts do: [ :dict | - dict - ifNil: [ aMenu addLine ] - ifNotNil: [ - item _ (dict at: #label) isSymbol - ifTrue: [ - aMenu - addUpdating: (dict at: #label) - target: (dict at: #object) - action: (dict at: #selector) - argumentList: - (dict - at: #arguments - ifAbsent: [ #() ]) ] - ifFalse: [ - aMenu - add: (dict at: #label) - target: (dict at: #object) - action: (dict at: #selector) - argumentList: - (dict - at: #arguments - ifAbsent: [ #() ]) ]. - dict - at: #icon - ifPresent: [ :symbolOrFormOrNil | - item setIcon: symbolOrFormOrNil ]. - dict - at: #balloonText - ifPresent: [ :balloonText | - item setBalloonText: balloonText ]. - ]]. - ^ aMenu! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3306-BigMenuRefactor-p9-JuanVuletich-2018May01-21h10m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3306] on 2 May 2018 at 2:33:08 pm'! -!TheWorldMenu methodsFor: 'popups' stamp: 'jmv 5/1/2018 21:47:43'! - openChangesMenu - "Build the changes menu for the world." - - self doPopUp: self changesMenu! ! -!TheWorldMenu methodsFor: 'popups' stamp: 'jmv 5/1/2018 21:48:18'! -openDebugMenu - - self doPopUp: self debugMenu! ! -!TheWorldMenu methodsFor: 'popups' stamp: 'jmv 5/1/2018 21:45:28'! - openHelpMenu - "Build and show the help menu for the world." - - self doPopUp: self helpMenu! ! -!TheWorldMenu methodsFor: 'popups' stamp: 'jmv 5/1/2018 21:30:15'! -openOpenMenu - - self doPopUp: self openMenu! ! -!TheWorldMenu methodsFor: 'popups' stamp: 'jmv 5/1/2018 21:43:44'! - openPreferencesMenu - "Build and show the preferences menu for the world." - - self doPopUp: self preferencesMenu! ! -!TheWorldMenu methodsFor: 'popups' stamp: 'jmv 5/1/2018 21:45:06'! - openWindowsMenu - "Build the windows menu for the world." - - self doPopUp: self windowsMenu! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/2/2018 14:32:47' prior: 50379975! - buildWorldMenu - "Build the menu that is put up when the screen-desktop is clicked on" - - | menu | - menu _ MenuMorph new defaultTarget: self. - menu addStayUpIcons. - self - fillIn: menu - fromDictionaries: `{ - { - #label -> 'Open...'. - #object -> #theWorldMenu. - #selector -> #openOpenMenu. - #icon -> #openIcon. - #balloonText -> 'Submenu to open various system tools'. - } asDictionary. - { - #label -> 'New morph...'. - #object -> #theWorldMenu. - #selector -> #newMorph. - #icon -> #morphsIcon. - #balloonText -> 'Offers a variety of ways to create new objects'. - } asDictionary. - { - #label -> 'Preferences...'. - #object -> #theWorldMenu. - #selector -> #openPreferencesMenu. - #icon -> #preferencesIcon. - #balloonText -> 'Opens a menu offering many controls over appearance and system preferences.'. - } asDictionary. - { - #label -> 'Windows...'. - #object -> #theWorldMenu. - #selector -> #openWindowsMenu. - #icon -> #windowIcon. - #balloonText -> 'Manage open windows'. - } asDictionary. - { - #label -> 'Help...'. - #object -> #theWorldMenu. - #selector -> #openHelpMenu. - #icon -> #helpIcon. - #balloonText -> 'Opens a menu of useful items for updating the system, determining what version you are running, and much else'. - } asDictionary. - nil. - { - #label -> 'Changes...'. - #object -> #theWorldMenu. - #selector -> #openChangesMenu. - #icon -> #changesIcon. - #balloonText -> 'Opens a menu of useful tools for dealing with changes'. - } asDictionary. - { - #label -> 'Debug...'. - #object -> #theWorldMenu. - #selector -> #openDebugMenu. - #icon -> #debugIcon. - #balloonText -> 'a menu of debugging items'. - } asDictionary. - { - #label -> 'Restore Display (r)'. - #object -> #myWorld. - #selector -> #restoreDisplay. - #icon -> #displayIcon. - #balloonText -> 'Repaint the screen -- useful for removing unwanted display artifacts, lingering cursors, etc.'. - } asDictionary. - nil. - { - #label -> 'Save'. - #object -> Smalltalk. - #selector -> #saveSession. - #icon -> #saveIcon. - #balloonText -> 'Save the current version of the image on disk'. - } asDictionary. - { - #label -> 'Save as...'. - #object -> Smalltalk. - #selector -> #saveAs. - #icon -> #saveAsIcon. - #balloonText -> 'Save the current version of the image on disk under a new name.'. - } asDictionary. - { - #label -> 'Save as New Version'. - #object -> Smalltalk. - #selector -> #saveAsNewVersion. - #icon -> #saveAsNewVersionIcon. - #balloonText -> 'Save the current image a new version-stamped name\and save it under that name on disk.\Clear all user preferences and user state (class vars).' withNewLines. - } asDictionary. - { - #label -> 'Save and Quit'. - #object -> #theWorldMenu. - #selector -> #saveAndQuit. - #icon -> #saveAndQuitIcon. - #balloonText -> 'Save the image and quit out of Cuis.'. - } asDictionary. - { - #label -> 'Quit'. - #object -> #theWorldMenu. - #selector -> #quitSession. - #icon -> #quitIcon. - #balloonText -> 'Quit out of Cuis.'. - } asDictionary. - }`. - ^menu! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/1/2018 21:38:18' prior: 50393815! - fillIn: aMenu fromDictionaries: dataForMenuDicts - "A menu constructor utility that uses Dictionaries with elements: - #label - the name that displays in the menu - #object - the target object - #selector - the selector called on object when the menu item is selected - #arguments - optional collection of arguments passed to the selector - #balloonText - optional 'tool tip' style help text - #icon- optional icon selector or Form - - note, nil elements will add a line." - | item | - dataForMenuDicts do: [ :dict | - dict - ifNil: [ aMenu addLine ] - ifNotNil: [ | realTarget | - realTarget _ dict at: #object. - realTarget == #myWorld ifTrue: [realTarget _ myWorld]. - realTarget == #theWorldMenu ifTrue: [realTarget _ self]. - item _ (dict at: #label) isSymbol - ifTrue: [ - aMenu - addUpdating: (dict at: #label) - target: realTarget - action: (dict at: #selector) - argumentList: - (dict - at: #arguments - ifAbsent: [ #() ]) ] - ifFalse: [ - aMenu - add: (dict at: #label) - target: realTarget - action: (dict at: #selector) - argumentList: - (dict - at: #arguments - ifAbsent: [ #() ]) ]. - dict - at: #icon - ifPresent: [ :symbolOrFormOrNil | - item setIcon: symbolOrFormOrNil ]. - dict - at: #balloonText - ifPresent: [ :balloonText | - item setBalloonText: balloonText ]. - ]]. - ^ aMenu! ! -!TheWorldMenu methodsFor: 'mechanics' stamp: 'jmv 5/1/2018 21:24:40' prior: 16935161! - menu: titleString - "Create a menu with the given title, ready for filling" - - | menu | - (menu _ MenuMorph entitled: titleString) - defaultTarget: self; - addStayUpIcons. - ^ menu -! ! - -TheWorldMenu removeSelector: #changesDo! - -TheWorldMenu removeSelector: #changesDo! - -TheWorldMenu removeSelector: #colorForDebugging:! - -TheWorldMenu removeSelector: #colorForDebugging:! - -TheWorldMenu removeSelector: #debugDo! - -TheWorldMenu removeSelector: #debugDo! - -TheWorldMenu removeSelector: #helpDo! - -TheWorldMenu removeSelector: #helpDo! - -TheWorldMenu removeSelector: #openWindow! - -TheWorldMenu removeSelector: #openWindow! - -TheWorldMenu removeSelector: #preferencesDo! - -TheWorldMenu removeSelector: #preferencesDo! - -TheWorldMenu removeSelector: #windowsDo! - -TheWorldMenu removeSelector: #windowsDo! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3307-BigMenuRefactor-p10-JuanVuletich-2018May02-14h21m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3307] on 2 May 2018 at 5:47:44 pm'! - -MenuItemMorph subclass: #UpdatingMenuItemMorph - instanceVariableNames: 'wordingProvider wordingSelector enablementSelector ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #UpdatingMenuItemMorph category: #'Morphic-Menus'! -MenuItemMorph subclass: #UpdatingMenuItemMorph - instanceVariableNames: 'wordingProvider wordingSelector enablementSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! -!UpdatingMenuItemMorph methodsFor: 'world' stamp: 'jmv 5/2/2018 17:46:11' prior: 50392494! - updateContents - "Update the receiver's contents" - - | newString nArgs | - ((wordingProvider isNil) or: [wordingSelector isNil]) ifFalse: [ - nArgs _ wordingSelector numArgs. - newString _ nArgs = 0 - ifTrue: [ - wordingProvider perform: wordingSelector] - ifFalse: [ - nArgs = arguments size ifTrue: [ - wordingProvider perform: wordingSelector withArguments: arguments]]. - newString = (contentString ifNil: [ contents ]) - ifFalse: [ - self contents: newString ]]! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/2/2018 16:57:32' prior: 50375670! - changesMenu - "Build the changes menu for the world." - - ^ self - fillIn: (self menu: 'Changes...') - fromDictionaries: `{ - { - #label -> 'Change Sorter'. - #object -> ChangeSorterWindow. - #selector -> #openChangeSorter. - #icon -> #halfRefreshIcon. - #balloonText -> 'Open a 3-paned changed-set viewing tool'. - } asDictionary. - nil. - { - #label -> 'Install New Updates'. - #object -> ChangeSet. - #selector -> #installNewUpdates. - #icon -> #updateIcon. - #balloonText -> 'Install in the current image the new updates available -in directory named ./CoreUpdates -or in directory named ../Cuis-Smalltalk-Dev/CoreUpdates'. - } asDictionary. - nil. - { - #label -> 'Browse my Changes'. - #object -> Smalltalk. - #selector -> #browseMyChanges. - #icon -> #editFindReplaceIcon. - #balloonText -> 'Browse all of my changes since the last time #condenseSources was run.'. - } asDictionary. - { - #label -> 'Recently logged Changes...'. - #object -> ChangeList. - #selector -> #browseRecentLog. - #icon -> #clockIcon. - #balloonText -> 'Open a change-list browser on the latter part of the changes log. You can use this browser to recover logged changes which were not saved in your image, in the event of a crash or other interruption.'. - } asDictionary. - nil. - { - #label -> 'Save World as morph file'. - #object -> #theWorldMenu. - #selector -> #saveWorldInFile. - #icon -> #morphsIcon. - #balloonText -> 'Save a file that, when reloaded, reconstitutes the current World.'. - } asDictionary. - }`! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/2/2018 16:58:03' prior: 16934864! - debugMenu - - ^ self - fillIn: (self menu: 'Debug...') - fromDictionaries: `{ - { - #label -> 'Inspect World'. - #object -> #myWorld. - #selector -> #inspect. - #icon -> #inspectIcon. - } asDictionary. - { - #label -> 'Explore World'. - #object -> #myWorld. - #selector -> #explore. - #icon -> #exploreIcon. - } asDictionary. - { - #label -> 'MessageTally all Processes'. - #object -> #theWorldMenu. - #selector -> #startMessageTally. - #icon -> #systemMonitorIcon. - } asDictionary. - { - #label -> 'MessageTally UI and Browse'. - #object -> #theWorldMenu. - #selector -> #startThenBrowseMessageTally. - #icon -> #editFindReplaceIcon. - } asDictionary. - nil. - { - #label -> 'Start drawing all again'. - #object -> #myWorld. - #selector -> #removeAllKnownFailing. - #icon -> #graphicsIcon. - } asDictionary. - { - #label -> 'Start stepping again'. - #object -> #myWorld. - #selector -> #resumeAfterStepError. - #icon -> #mediaPlaybackStartIcon. - } asDictionary. - { - #label -> 'Close all Debuggers'. - #object -> DebuggerWindow. - #selector -> #closeAllDebuggers. - #icon -> #closeIcon. - } asDictionary. - }`! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/2/2018 17:16:07' prior: 50394008! -fillIn: aMenu fromDictionaries: dataForMenuDicts - "A menu constructor utility that uses Dictionaries with elements: - #label - the name that displays in the menu - #object - the target object - #selector - the selector called on object when the menu item is selected - #arguments - optional collection of arguments passed to the selector - #balloonText - optional 'tool tip' style help text - #icon- optional icon selector or Form - - note, nil elements will add a line." - | item wantsIcons | - wantsIcons _ Preferences wantsMenuIcons. - dataForMenuDicts do: [ :dict | - dict - ifNil: [ aMenu addLine ] - ifNotNil: [ | realTarget | - realTarget _ dict at: #object. - realTarget == #myWorld ifTrue: [realTarget _ myWorld]. - realTarget == #theWorldMenu ifTrue: [realTarget _ self]. - item _ (dict at: #label) isSymbol - ifTrue: [ - aMenu - addUpdating: (dict at: #label) - target: realTarget - action: (dict at: #selector) - argumentList: - (dict - at: #arguments - ifAbsent: [ #() ]) ] - ifFalse: [ - aMenu - add: (dict at: #label) - target: realTarget - action: (dict at: #selector) - argumentList: - (dict - at: #arguments - ifAbsent: [ #() ]) ]. - wantsIcons ifTrue: [ - dict - at: #icon - ifPresent: [ :symbolOrFormOrNil | - item setIcon: symbolOrFormOrNil ]]. - dict - at: #balloonText - ifPresent: [ :balloonText | - item setBalloonText: balloonText ]. - ]]. - ^ aMenu! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/2/2018 16:56:08' prior: 16934966! - helpMenu - "Build the help menu for the world." - - ^ self - fillIn: (self menu: 'Help...') - fromDictionaries: `{ - { - #label -> 'About this System...'. - #object -> Smalltalk. - #selector -> #aboutThisSystem. - #icon -> #helpIcon. - #balloonText -> 'current version information.' - } asDictionary. - { - #label -> 'Terse Guide to Cuis'. - #object -> #theWorldMenu. - #selector -> #openTerseGuide. - #icon -> #helpIcon. - #balloonText -> 'explore Cuis Smalltalk' - } asDictionary. - { - #label -> 'Class Comment Browser'. - #object -> #theWorldMenu. - #selector -> #openCommentGuide. - #icon -> #helpIcon. - #balloonText -> 'search & explore Cuis Class Comments' - } asDictionary. - { - #label -> 'Code management in Cuis'. - #object -> Utilities. - #selector -> #openCodeManagementInCuis. - #icon -> #helpIcon. - #balloonText -> 'Features are kept in Packages.' - } asDictionary. - { - #label -> 'Using GitHub to host Cuis packages'. - #object -> Utilities. - #selector -> #openCuisAndGitHub. - #icon -> #helpIcon. - #balloonText -> 'GitHub usage pattern.' - } asDictionary. - nil. - { - #label -> 'Editor keyboard shortcuts'. - #object -> SmalltalkEditor. - #selector -> #openHelp. - #icon -> #keyboardShortcutsIcon. - #balloonText -> 'summary of keyboard shortcuts in editors for Smalltalk code.' - } asDictionary. - { - #label -> 'Useful Expressions'. - #object -> Utilities. - #selector -> #openUsefulExpressions. - #icon -> #chatIcon. - #balloonText -> 'a window full of useful expressions.' - } asDictionary. - nil. - { - #label -> 'VM Statistics'. - #object -> #theWorldMenu. - #selector -> #vmStatistics. - #icon -> #systemMonitorIcon. - #balloonText -> 'obtain some intriguing data about the vm.' - } asDictionary. - { - #label -> 'Space Left'. - #object -> #theWorldMenu. - #selector -> #garbageCollect. - #icon -> #removableMediaIcon. - #balloonText -> 'perform a full garbage-collection and report how many bytes of space remain in the image.' - } asDictionary. - }`! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/2/2018 17:12:47' prior: 16935088! - preferencesMenu - "Build the preferences menu for the world." - - ^ self - fillIn: (self menu: 'Preferences...') - fromDictionaries: `{ - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Font Sizes...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #object -> #theWorldMenu. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #object -> #theWorldMenu. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set display depth...'. - #object -> #theWorldMenu. - #selector -> #setDisplayDepth. - #icon -> #displayIcon. - #balloonText -> 'choose how many bits per pixel.' - } asDictionary. - { - #label -> 'Set desktop color...'. - #object -> #theWorldMenu. - #selector -> #changeBackgroundColor. - #icon -> #wallpaperIcon. - #balloonText -> 'choose a uniform color to use as desktop background.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }`! ! -!TheWorldMenu methodsFor: 'windows & flaps menu' stamp: 'jmv 5/2/2018 17:42:52' prior: 16935213! - windowsMenu - "Build the windows menu for the world." - - ^ self - fillIn: (self menu: 'Windows') - fromDictionaries: `{ - { - #label -> 'Find Window'. - #object -> #myWorld. - #selector -> #findWindow:. - #icon -> #windowIcon. - #balloonText -> 'Presents a list of all windows; if you choose one from the list, it becomes the active window.' - } asDictionary. - { - #label -> 'Find changed Browsers...'. - #object -> #myWorld. - #selector -> #findDirtyBrowsers:. - #icon -> #editFindReplaceIcon. - #balloonText -> 'Presents a list of browsers that have unsubmitted changes; if you choose one from the list, it becomes the active window.' - } asDictionary. - { - #label -> 'Find changed Windows...'. - #object -> #myWorld. - #selector -> #findDirtyWindows:. - #icon -> #newWindowIcon. - #balloonText -> 'Presents a list of all windows that have unsubmitted changes; if you choose one from the list, it becomes the active window.' - } asDictionary. - nil. - { - #label -> 'Find a Transcript'. - #object -> #myWorld. - #selector -> #findATranscript:. - #icon -> #printerIcon. - #balloonText -> 'Brings an open Transcript to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find a FileList'. - #object -> #myWorld. - #selector -> #findAFileList:. - #icon -> #systemFileManagerIcon. - #balloonText -> 'Brings an open fileList to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find a Change Sorter'. - #object -> #myWorld. - #selector -> #findAChangeSorter:. - #icon -> #changesIcon. - #balloonText -> 'Brings an open change sorter to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find Message Names'. - #object -> #myWorld. - #selector -> #findAMessageNamesWindow:. - #icon -> #inspectIcon. - #balloonText -> 'Brings an open MessageNames window to the front, creating one if necessary, and makes it the active window' - } asDictionary. - nil. - { - #label -> 'Collapse all Windows'. - #object -> #myWorld. - #selector -> #collapseAll. - #icon -> #collapseIcon. - #balloonText -> 'Reduce all open windows to collapsed forms that only show titles.' - } asDictionary. - { - #label -> 'Restore all Windows'. - #object -> #myWorld. - #selector -> #restoreAll. - #icon -> #expandIcon. - #balloonText -> 'Restore all collapsed windows back to their previous forms.' - } asDictionary. - { - #label -> 'Close top Window'. - #object -> SystemWindow. - #selector -> #closeTopWindow. - #icon -> #closeIcon. - #balloonText -> 'Close the topmost window if possible.' - } asDictionary. - { - #label -> 'Send top Window to back'. - #object -> SystemWindow. - #selector -> #sendTopWindowToBack. - #icon -> #goBottomIcon. - #balloonText -> 'Make the topmost window become the backmost one, and activate the window just beneath it.' - } asDictionary. - { - #label -> 'Move Windows onscreen'. - #object -> #myWorld. - #selector -> #bringWindowsFullOnscreen. - #icon -> #displayIcon. - #balloonText -> 'Make all windows fully visible on the screen' - } asDictionary. - nil. - { - #label -> 'Delete unchanged Windows'. - #object -> #myWorld. - #selector -> #closeUnchangedWindows. - #icon -> #warningIcon. - #balloonText -> 'Deletes all windows that do not have unsaved text edits.' - } asDictionary. - { - #label -> 'Delete non Windows'. - #object -> #myWorld. - #selector -> #deleteNonWindows. - #icon -> #warningIcon. - #balloonText -> 'Deletes all non-window morphs lying on the world.' - } asDictionary. - { - #label -> 'Delete Both of the Above'. - #object -> #theWorldMenu. - #selector -> #cleanUpWorld. - #icon -> #warningIcon. - #balloonText -> 'Deletes all unchanged windows and also all non-window morphs lying on the world, other than flaps.' - } asDictionary. - }`! ! - -TheWorldMenu removeSelector: #doMenuItem:with:! - -TheWorldMenu removeSelector: #doMenuItem:with:! - -TheWorldMenu removeSelector: #fillIn:from:! - -TheWorldMenu removeSelector: #fillIn:from:! - -UpdatingMenuItemMorph removeSelector: #enablement! - -UpdatingMenuItemMorph removeSelector: #enablement! - -UpdatingMenuItemMorph removeSelector: #enablementSelector:! - -UpdatingMenuItemMorph removeSelector: #enablementSelector:! - -MenuItemMorph subclass: #UpdatingMenuItemMorph - instanceVariableNames: 'wordingProvider wordingSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #UpdatingMenuItemMorph category: #'Morphic-Menus'! -MenuItemMorph subclass: #UpdatingMenuItemMorph - instanceVariableNames: 'wordingProvider wordingSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3308-BigMenuRefactor-p11-JuanVuletich-2018May02-16h53m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3307] on 2 May 2018 at 5:54:32 pm'! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 5/2/2018 17:48:28' prior: 16898194! - initialFrameFor: aView initialExtent: initialExtent world: aWorld - "Find a plausible initial screen area for the supplied view, which should be a StandardSystemView, taking into account the 'reverseWindowStagger' Preference, the size needed, and other windows currently on the screen." - - ^ self - strictlyStaggeredInitialFrameFor: aView - initialExtent: initialExtent - world: aWorld! ! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 5/2/2018 17:49:23' prior: 50383199! - standardWindowExtent - "Answer the standard default extent for new windows. " - - | grid allowedArea maxLevel | - "NOTE: following copied from strictlyStaggeredInitialFrameFor:" - allowedArea _ self maximumUsableArea insetBy: ( - self scrollBarSetback @ self screenTopSetback extent: `0@0` - ). - "Number to be staggered at each corner (less on small screens)" - maxLevel _ allowedArea area > 700000 ifTrue: [3] ifFalse: [2]. - "Amount by which to stagger (less on small screens)" - grid _ allowedArea area > 700000 ifTrue: [40] ifFalse: [20]. - ^ (allowedArea extent - (grid*(maxLevel+1*2) + (grid//2))) min: `52@40` * Preferences standardCodeFont height! ! - -TheWorldMenu removeSelector: #staggerPolicyString! - -TheWorldMenu removeSelector: #staggerPolicyString! - -TheWorldMenu removeSelector: #toggleWindowPolicy! - -TheWorldMenu removeSelector: #toggleWindowPolicy! - -RealEstateAgent class removeSelector: #staggerOffset! - -RealEstateAgent class removeSelector: #staggerOffset! - -RealEstateAgent class removeSelector: #standardPositionsInWorld:! - -RealEstateAgent class removeSelector: #standardPositionsInWorld:! - -RealEstateAgent class removeSelector: #windowColumnsDesired! - -RealEstateAgent class removeSelector: #windowColumnsDesired! - -RealEstateAgent class removeSelector: #windowRowsDesired! - -RealEstateAgent class removeSelector: #windowRowsDesired! - -Preferences class removeSelector: #reverseWindowStagger! - -Preferences class removeSelector: #reverseWindowStagger! - -Preferences class removeSelector: #staggerPolicyString! - -Preferences class removeSelector: #staggerPolicyString! - -Preferences class removeSelector: #toggleWindowPolicy! - -Preferences class removeSelector: #toggleWindowPolicy! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3309-RealEstateAgent-simplification-JuanVuletich-2018May02-17h47m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3309] on 5 May 2018 at 5:09:03 pm'! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/5/2018 16:57:30'! - buildFromDictionaries: dataForMenuDicts - "A menu constructor utility that uses Dictionaries with elements: - #label - the name that displays in the menu - #object - the target object. If nil, use defaultTarget. If a Symbol, send it as message to defaultTarget to get real target. - #selector - the selector called on object when the menu item is selected - #arguments - optional collection of arguments passed to the selector - #balloonText - optional 'tool tip' style help text - #icon- optional icon selector or Form - - note, nil elements will add a line." - | item wantsIcons | - wantsIcons _ Preferences wantsMenuIcons. - dataForMenuDicts do: [ :dict | - dict - ifNil: [ self addLine ] - ifNotNil: [ | realTarget | - realTarget _ dict at: #object ifAbsent: [defaultTarget]. - realTarget isSymbol ifTrue: [ realTarget _ defaultTarget perform: realTarget ]. - item _ (dict at: #label) isSymbol - ifTrue: [ - self - addUpdating: (dict at: #label) - target: realTarget - action: (dict at: #selector) - argumentList: - (dict - at: #arguments - ifAbsent: [ #() ]) ] - ifFalse: [ - self - add: (dict at: #label) - target: realTarget - action: (dict at: #selector) - argumentList: - (dict - at: #arguments - ifAbsent: [ #() ]) ]. - wantsIcons ifTrue: [ - dict - at: #icon - ifPresent: [ :symbolOrFormOrNil | - item setIcon: symbolOrFormOrNil ]]. - dict - at: #balloonText - ifPresent: [ :balloonText | - item setBalloonText: balloonText ]. - ]]! ! -!TheWorldMenu methodsFor: 'mechanics' stamp: 'jmv 5/5/2018 17:03:51'! - myWorld - ^ myWorld! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/5/2018 17:03:26' prior: 50393894! - buildWorldMenu - "Build the menu that is put up when the screen-desktop is clicked on" - - ^(MenuMorph new defaultTarget: self) - addStayUpIcons; - buildFromDictionaries: `{ - { - #label -> 'Open...'. - #selector -> #openOpenMenu. - #icon -> #openIcon. - #balloonText -> 'Submenu to open various system tools'. - } asDictionary. - { - #label -> 'New morph...'. - #selector -> #newMorph. - #icon -> #morphsIcon. - #balloonText -> 'Offers a variety of ways to create new objects'. - } asDictionary. - { - #label -> 'Preferences...'. - #selector -> #openPreferencesMenu. - #icon -> #preferencesIcon. - #balloonText -> 'Opens a menu offering many controls over appearance and system preferences.'. - } asDictionary. - { - #label -> 'Windows...'. - #selector -> #openWindowsMenu. - #icon -> #windowIcon. - #balloonText -> 'Manage open windows'. - } asDictionary. - { - #label -> 'Help...'. - #selector -> #openHelpMenu. - #icon -> #helpIcon. - #balloonText -> 'Opens a menu of useful items for updating the system, determining what version you are running, and much else'. - } asDictionary. - nil. - { - #label -> 'Changes...'. - #selector -> #openChangesMenu. - #icon -> #changesIcon. - #balloonText -> 'Opens a menu of useful tools for dealing with changes'. - } asDictionary. - { - #label -> 'Debug...'. - #selector -> #openDebugMenu. - #icon -> #debugIcon. - #balloonText -> 'a menu of debugging items'. - } asDictionary. - { - #label -> 'Restore Display (r)'. - #object -> #myWorld. - #selector -> #restoreDisplay. - #icon -> #displayIcon. - #balloonText -> 'Repaint the screen -- useful for removing unwanted display artifacts, lingering cursors, etc.'. - } asDictionary. - nil. - { - #label -> 'Save'. - #object -> Smalltalk. - #selector -> #saveSession. - #icon -> #saveIcon. - #balloonText -> 'Save the current version of the image on disk'. - } asDictionary. - { - #label -> 'Save as...'. - #object -> Smalltalk. - #selector -> #saveAs. - #icon -> #saveAsIcon. - #balloonText -> 'Save the current version of the image on disk under a new name.'. - } asDictionary. - { - #label -> 'Save as New Version'. - #object -> Smalltalk. - #selector -> #saveAsNewVersion. - #icon -> #saveAsNewVersionIcon. - #balloonText -> ('Save the current image a new version-stamped name\and save it under that name on disk.\', - 'Clear all user preferences and user state (class vars).') withNewLines. - } asDictionary. - { - #label -> 'Save and Quit'. - #selector -> #saveAndQuit. - #icon -> #saveAndQuitIcon. - #balloonText -> 'Save the image and quit out of Cuis.'. - } asDictionary. - { - #label -> 'Quit'. - #selector -> #quitSession. - #icon -> #quitIcon. - #balloonText -> 'Quit out of Cuis.'. - } asDictionary. - }`! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/5/2018 17:01:58' prior: 50394124! - changesMenu - "Build the changes menu for the world." - - ^ (self menu: 'Changes...') - buildFromDictionaries: `{ - { - #label -> 'Change Sorter'. - #object -> ChangeSorterWindow. - #selector -> #openChangeSorter. - #icon -> #halfRefreshIcon. - #balloonText -> 'Open a 3-paned changed-set viewing tool'. - } asDictionary. - nil. - { - #label -> 'Install New Updates'. - #object -> ChangeSet. - #selector -> #installNewUpdates. - #icon -> #updateIcon. - #balloonText -> 'Install in the current image the new updates available -in directory named ./CoreUpdates -or in directory named ../Cuis-Smalltalk-Dev/CoreUpdates'. - } asDictionary. - nil. - { - #label -> 'Browse my Changes'. - #object -> Smalltalk. - #selector -> #browseMyChanges. - #icon -> #editFindReplaceIcon. - #balloonText -> 'Browse all of my changes since the last time #condenseSources was run.'. - } asDictionary. - { - #label -> 'Recently logged Changes...'. - #object -> ChangeList. - #selector -> #browseRecentLog. - #icon -> #clockIcon. - #balloonText -> 'Open a change-list browser on the latter part of the changes log. You can use this browser to recover logged changes which were not saved in your image, in the event of a crash or other interruption.'. - } asDictionary. - nil. - { - #label -> 'Save World as morph file'. - #selector -> #saveWorldInFile. - #icon -> #morphsIcon. - #balloonText -> 'Save a file that, when reloaded, reconstitutes the current World.'. - } asDictionary. - }`! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/5/2018 17:04:31' prior: 50394180! - debugMenu - - ^ (self menu: 'Debug...') - buildFromDictionaries: `{ - { - #label -> 'Inspect World'. - #object -> #myWorld. - #selector -> #inspect. - #icon -> #inspectIcon. - } asDictionary. - { - #label -> 'Explore World'. - #object -> #myWorld. - #selector -> #explore. - #icon -> #exploreIcon. - } asDictionary. - { - #label -> 'MessageTally all Processes'. - #selector -> #startMessageTally. - #icon -> #systemMonitorIcon. - } asDictionary. - { - #label -> 'MessageTally UI and Browse'. - #selector -> #startThenBrowseMessageTally. - #icon -> #editFindReplaceIcon. - } asDictionary. - nil. - { - #label -> 'Start drawing all again'. - #object -> #myWorld. - #selector -> #removeAllKnownFailing. - #icon -> #graphicsIcon. - } asDictionary. - { - #label -> 'Start stepping again'. - #object -> #myWorld. - #selector -> #resumeAfterStepError. - #icon -> #mediaPlaybackStartIcon. - } asDictionary. - { - #label -> 'Close all Debuggers'. - #object -> DebuggerWindow. - #selector -> #closeAllDebuggers. - #icon -> #closeIcon. - } asDictionary. - }`! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/5/2018 17:05:32' prior: 50394274! - helpMenu - "Build the help menu for the world." - - ^ (self menu: 'Help...') - buildFromDictionaries: `{ - { - #label -> 'About this System...'. - #object -> Smalltalk. - #selector -> #aboutThisSystem. - #icon -> #helpIcon. - #balloonText -> 'current version information.' - } asDictionary. - { - #label -> 'Terse Guide to Cuis'. - #selector -> #openTerseGuide. - #icon -> #helpIcon. - #balloonText -> 'explore Cuis Smalltalk' - } asDictionary. - { - #label -> 'Class Comment Browser'. - #selector -> #openCommentGuide. - #icon -> #helpIcon. - #balloonText -> 'search & explore Cuis Class Comments' - } asDictionary. - { - #label -> 'Code management in Cuis'. - #object -> Utilities. - #selector -> #openCodeManagementInCuis. - #icon -> #helpIcon. - #balloonText -> 'Features are kept in Packages.' - } asDictionary. - { - #label -> 'Using GitHub to host Cuis packages'. - #object -> Utilities. - #selector -> #openCuisAndGitHub. - #icon -> #helpIcon. - #balloonText -> 'GitHub usage pattern.' - } asDictionary. - nil. - { - #label -> 'Editor keyboard shortcuts'. - #object -> SmalltalkEditor. - #selector -> #openHelp. - #icon -> #keyboardShortcutsIcon. - #balloonText -> 'summary of keyboard shortcuts in editors for Smalltalk code.' - } asDictionary. - { - #label -> 'Useful Expressions'. - #object -> Utilities. - #selector -> #openUsefulExpressions. - #icon -> #chatIcon. - #balloonText -> 'a window full of useful expressions.' - } asDictionary. - nil. - { - #label -> 'VM Statistics'. - #selector -> #vmStatistics. - #icon -> #systemMonitorIcon. - #balloonText -> 'obtain some intriguing data about the vm.' - } asDictionary. - { - #label -> 'Space Left'. - #selector -> #garbageCollect. - #icon -> #removableMediaIcon. - #balloonText -> 'perform a full garbage-collection and report how many bytes of space remain in the image.' - } asDictionary. - }`! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/5/2018 17:06:38' prior: 16935052! - openMenu - "Build the open window menu for the world." - | menu items groups firstGroup itemsSorted itemsBase | - menu _ self menu: 'Open...'. - itemsBase _ (Smalltalk allClassesImplementing: #worldMenuForOpenGroup) - collect: [ :item | - item class == Metaclass ifTrue: [ - item soleInstance - worldMenuForOpenGroup ] ] - thenSelect: [ :item | - item notNil ]. - items _ OrderedCollection new. - "A single class may add more than one item to a menu" - itemsBase do: [ :item | - item class == Dictionary - ifTrue: [ items add: item ] - ifFalse: [ items addAll: item ]]. - groups _ (items collect: [ :item | - item at: #itemGroup ]) asSet asSortedCollection. - itemsSorted _ OrderedCollection new. - firstGroup _ true. - groups do: [ :group | - firstGroup - ifTrue: [ firstGroup _ false ] - ifFalse: [ itemsSorted add: nil ]. - ((items select: [ :item | - (item at: #itemGroup) = group ]) sort: [ :item1 :item2 | - (item1 at: #itemOrder) < (item2 at: #itemOrder) ]) do: [ :item | - itemsSorted add: item ]]. - menu buildFromDictionaries: itemsSorted. - ^ menu.! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/5/2018 17:07:28' prior: 50394349! - preferencesMenu - "Build the preferences menu for the world." - - ^ (self menu: 'Preferences...') - buildFromDictionaries: `{ - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Font Sizes...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set display depth...'. - #selector -> #setDisplayDepth. - #icon -> #displayIcon. - #balloonText -> 'choose how many bits per pixel.' - } asDictionary. - { - #label -> 'Set desktop color...'. - #selector -> #changeBackgroundColor. - #icon -> #wallpaperIcon. - #balloonText -> 'choose a uniform color to use as desktop background.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }`! ! -!TheWorldMenu methodsFor: 'windows & flaps menu' stamp: 'jmv 5/5/2018 17:08:12' prior: 50394454! - windowsMenu - "Build the windows menu for the world." - - ^ (self menu: 'Windows') - buildFromDictionaries: `{ - { - #label -> 'Find Window'. - #object -> #myWorld. - #selector -> #findWindow:. - #icon -> #windowIcon. - #balloonText -> 'Presents a list of all windows; if you choose one from the list, it becomes the active window.' - } asDictionary. - { - #label -> 'Find changed Browsers...'. - #object -> #myWorld. - #selector -> #findDirtyBrowsers:. - #icon -> #editFindReplaceIcon. - #balloonText -> 'Presents a list of browsers that have unsubmitted changes; if you choose one from the list, it becomes the active window.' - } asDictionary. - { - #label -> 'Find changed Windows...'. - #object -> #myWorld. - #selector -> #findDirtyWindows:. - #icon -> #newWindowIcon. - #balloonText -> 'Presents a list of all windows that have unsubmitted changes; if you choose one from the list, it becomes the active window.' - } asDictionary. - nil. - { - #label -> 'Find a Transcript'. - #object -> #myWorld. - #selector -> #findATranscript:. - #icon -> #printerIcon. - #balloonText -> 'Brings an open Transcript to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find a FileList'. - #object -> #myWorld. - #selector -> #findAFileList:. - #icon -> #systemFileManagerIcon. - #balloonText -> 'Brings an open fileList to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find a Change Sorter'. - #object -> #myWorld. - #selector -> #findAChangeSorter:. - #icon -> #changesIcon. - #balloonText -> 'Brings an open change sorter to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find Message Names'. - #object -> #myWorld. - #selector -> #findAMessageNamesWindow:. - #icon -> #inspectIcon. - #balloonText -> 'Brings an open MessageNames window to the front, creating one if necessary, and makes it the active window' - } asDictionary. - nil. - { - #label -> 'Collapse all Windows'. - #object -> #myWorld. - #selector -> #collapseAll. - #icon -> #collapseIcon. - #balloonText -> 'Reduce all open windows to collapsed forms that only show titles.' - } asDictionary. - { - #label -> 'Restore all Windows'. - #object -> #myWorld. - #selector -> #restoreAll. - #icon -> #expandIcon. - #balloonText -> 'Restore all collapsed windows back to their previous forms.' - } asDictionary. - { - #label -> 'Close top Window'. - #object -> SystemWindow. - #selector -> #closeTopWindow. - #icon -> #closeIcon. - #balloonText -> 'Close the topmost window if possible.' - } asDictionary. - { - #label -> 'Send top Window to back'. - #object -> SystemWindow. - #selector -> #sendTopWindowToBack. - #icon -> #goBottomIcon. - #balloonText -> 'Make the topmost window become the backmost one, and activate the window just beneath it.' - } asDictionary. - { - #label -> 'Move Windows onscreen'. - #object -> #myWorld. - #selector -> #bringWindowsFullOnscreen. - #icon -> #displayIcon. - #balloonText -> 'Make all windows fully visible on the screen' - } asDictionary. - nil. - { - #label -> 'Delete unchanged Windows'. - #object -> #myWorld. - #selector -> #closeUnchangedWindows. - #icon -> #warningIcon. - #balloonText -> 'Deletes all windows that do not have unsaved text edits.' - } asDictionary. - { - #label -> 'Delete non Windows'. - #object -> #myWorld. - #selector -> #deleteNonWindows. - #icon -> #warningIcon. - #balloonText -> 'Deletes all non-window morphs lying on the world.' - } asDictionary. - { - #label -> 'Delete Both of the Above'. - #selector -> #cleanUpWorld. - #icon -> #warningIcon. - #balloonText -> 'Deletes all unchanged windows and also all non-window morphs lying on the world, other than flaps.' - } asDictionary. - }`! ! - -TheWorldMenu removeSelector: #fillIn:fromDictionaries:! - -TheWorldMenu removeSelector: #fillIn:fromDictionaries:! - -TheWorldMenu removeSelector: #world! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3310-BigMenuRefactor-p12-JuanVuletich-2018May05-16h48m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3309] on 5 May 2018 at 5:51:50 pm'! - -TextEditor class - instanceVariableNames: 'menu '! - -!classDefinition: 'TextEditor class' category: #'System-Text'! -TextEditor class - instanceVariableNames: 'menu'! - -SmalltalkEditor class - instanceVariableNames: 'menu2 '! - -!classDefinition: 'SmalltalkEditor class' category: #'System-Text'! -SmalltalkEditor class - instanceVariableNames: 'menu2'! -!SmalltalkEditor methodsFor: 'menu' stamp: 'jmv 5/5/2018 17:40:51'! - getMenu - - ^(MenuMorph new defaultTarget: self) - addTitle: self class name; - addStayUpIcons; - buildFromDictionaries: `{ - { - #label -> 'Help...'. - #selector -> #openHelp. - #icon -> #helpIcon - } asDictionary. - nil. - { - #label -> 'Do it (d)'. - #selector -> #doIt. - #icon -> #doItIcon - } asDictionary. - { - #label -> 'Print it (p)'. - #selector -> #printIt. - #icon -> #printIcon - } asDictionary. - { - #label -> 'Inspect it (i)'. - #selector -> #inspectIt. - #icon -> #inspectIcon - } asDictionary. - { - #label -> 'Explore it (I)'. - #selector -> #exploreIt. - #icon -> #exploreIcon - } asDictionary. - { - #label -> 'Debug it (D)'. - #selector -> #debugIt. - #icon -> #debugIcon - } asDictionary. - { - #label -> 'Profile it'. - #selector -> #profileIt. - #icon -> #clockIcon - } asDictionary. - nil. - { - #label -> 'Explain'. - #selector -> #explain. - #icon -> #helpIcon - } asDictionary. - { - #label -> 'Browse it (b)'. - #selector -> #browseIt. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'Senders of it (n)'. - #selector -> #sendersOfIt. - #icon -> #mailForwardIcon - } asDictionary. - { - #label -> 'Implementors of it (m)'. - #selector -> #implementorsOfIt. - #icon -> #developmentIcon - } asDictionary. - { - #label -> 'References to it (N)'. - #selector -> #referencesToIt. - #icon -> #addressBookIcon - } asDictionary. - nil. - { - #label -> 'Method Strings with it (E)'. - #selector -> #methodStringsContainingit. - #icon -> #genericTextIcon - } asDictionary. - { - #label -> 'Method Source with it'. - #selector -> #methodSourceContainingIt. - #icon -> #scriptIcon - } asDictionary. - { - #label -> 'Class Comments with it'. - #selector -> #classCommentsContainingIt. - #icon -> #chatIcon - } asDictionary. - nil. - { - #label -> 'Accept (s)'. - #selector -> #acceptContents. - #icon -> #acceptIcon - } asDictionary. - { - #label -> 'Cancel (l)'. - #selector -> #cancelEdits. - #icon -> #cancelIcon - } asDictionary. - { - #label -> 'Accept & Run Test in Class (t)'. - #selector -> #acceptAndTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #label -> 'Accept & Run Test in Category (y)'. - #selector -> #acceptAndTestAll. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #label -> 'Accept & Debug Test (r)'. - #selector -> #acceptAndDebugTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - nil. - { - #label -> 'More...'. - #selector -> #openMenu2. - #icon -> #listAddIcon - } asDictionary. - }`! ! -!SmalltalkEditor methodsFor: 'menu' stamp: 'jmv 5/5/2018 17:42:25'! - openMenu - - self getMenu popUpInWorld: morph world! ! -!SmalltalkEditor methodsFor: 'menu' stamp: 'jmv 5/5/2018 17:45:22'! - openMenu2 - - (MenuMorph new defaultTarget: self) - addTitle: self class name; - addStayUpIcons; - buildFromDictionaries: `{ - { - #label -> 'Find...(f)'. - #selector -> #find. - #icon -> #findIcon - } asDictionary. - { - #label -> 'Find Again (g)'. - #selector -> #findAgain. - #icon -> #systemIcon - } asDictionary. - { - #label -> 'Use Selection for Find (j)'. - #selector -> #setSearchString. - #icon -> #saveAsIcon - } asDictionary. - nil. - { - #label -> 'Undo - multiple (z)'. - #selector -> #undo. - #icon -> #undoIcon - } asDictionary. - { - #label -> 'Redo - multiple (Z)'. - #selector -> #redo. - #icon -> #redoIcon - } asDictionary. - { - #label -> 'Undo / Redo history'. - #selector -> #offerUndoHistory. - #icon -> #changesIcon - } asDictionary. - nil. - { - #label -> 'Copy (c)'. - #selector -> #copySelection. - #icon -> #copyIcon - } asDictionary. - { - #label -> 'Cut (x)'. - #selector -> #cut. - #icon -> #cutIcon - } asDictionary. - { - #label -> 'Paste (v)'. - #selector -> #paste. - #icon -> #pasteIcon - } asDictionary. - { - #label -> 'Paste without Format'. - #selector -> #pasteString. - #icon -> #pasteIcon - } asDictionary. - { - #label -> 'Paste...'. - #selector -> #pasteRecent. - #icon -> #worldIcon - } asDictionary. - nil. - { - #label -> 'Toggle WordWrap'. - #selector -> #wrapOnOff. - #icon -> #genericTextIcon - } asDictionary. - { - #label -> 'Set Font... (k)'. - #selector -> #offerFontMenu. - #icon -> #preferencesDesktopFontIcon - } asDictionary. - { - #label -> 'Clear Font'. - #selector -> #clearFont. - #icon -> #newIcon - } asDictionary. - { - #label -> 'Set Default Font...'. - #selector -> #offerDefaultFontMenu. - #icon -> #fontXGenericIcon - } asDictionary. - nil. - { - #label -> 'More...'. - #selector -> #openMenu. - #icon -> #listAddIcon - } asDictionary. - }`; - popUpInWorld: morph world.! ! -!TextEditor methodsFor: 'menu' stamp: 'jmv 5/5/2018 17:40:36' prior: 16933045! - getMenu - - ^(MenuMorph new defaultTarget: self) - addTitle: self class name; - addStayUpIcons; - buildFromDictionaries: `{ - { - #label -> 'Help...'. - #selector -> #openHelp. - #icon -> #helpIcon - } asDictionary. - nil. - { - #label -> 'Find...(f)'. - #selector -> #find. - #icon -> #findIcon - } asDictionary. - { - #label -> 'Find Again (g)'. - #selector -> #findAgain. - #icon -> #systemIcon - } asDictionary. - { - #label -> 'Use Selection for Find (j)'. - #selector -> #setSearchString. - #icon -> #saveAsIcon - } asDictionary. - nil. - { - #label -> 'Undo - multiple (z)'. - #selector -> #undo. - #icon -> #undoIcon - } asDictionary. - { - #label -> 'Redo - multiple (Z)'. - #selector -> #redo. - #icon -> #redoIcon - } asDictionary. - { - #label -> 'Undo / Redo history'. - #selector -> #offerUndoHistory. - #icon -> #changesIcon - } asDictionary. - nil. - { - #label -> 'Copy (c)'. - #selector -> #copySelection. - #icon -> #copyIcon - } asDictionary. - { - #label -> 'Cut (x)'. - #selector -> #cut. - #icon -> #cutIcon - } asDictionary. - { - #label -> 'Paste (v)'. - #selector -> #paste. - #icon -> #pasteIcon - } asDictionary. - { - #label -> 'Paste without Format'. - #selector -> #pasteString. - #icon -> #pasteIcon - } asDictionary. - { - #label -> 'Paste...'. - #selector -> #pasteRecent. - #icon -> #worldIcon - } asDictionary. - nil. - { - #label -> 'Toggle WordWrap'. - #selector -> #wrapOnOff. - #icon -> #genericTextIcon - } asDictionary. - { - #label -> 'Set Font... (k)'. - #selector -> #offerFontMenu. - #icon -> #preferencesDesktopFontIcon - } asDictionary. - { - #label -> 'Clear Font'. - #selector -> #clearFont. - #icon -> #newIcon - } asDictionary. - { - #label -> 'Set Default Font...'. - #selector -> #offerDefaultFontMenu. - #icon -> #fontXGenericIcon - } asDictionary. - { - #label -> 'Set Alignment...'. - #selector -> #chooseAlignment. - #icon -> #formatJustifyLeftIcon - } asDictionary. - }`! ! -!TextEditor class methodsFor: 'cached state access' stamp: 'jmv 5/5/2018 17:50:04' prior: 16933239! - releaseClassCachedState - - FindText _ nil. - ChangeText _ nil. - "We are not calling super to avoid cleansing class vars many times. - So, repeat inherited class instVars!!" - shortcuts _ nil. - cmdShortcuts _ nil! ! -!SmalltalkEditor class methodsFor: 'cached state access' stamp: 'jmv 5/5/2018 17:50:09' prior: 16910772! - releaseClassCachedState - - "We are not calling super to avoid cleansing class vars many times. - So, repeat inherited class instVars!!" - shortcuts _ nil. - cmdShortcuts _ nil! ! - -SmalltalkEditor class removeSelector: #initializeMenu! - -SmalltalkEditor class removeSelector: #initializeMenu! - -SmalltalkEditor class removeSelector: #menu2! - -SmalltalkEditor class removeSelector: #menu2! - -SmalltalkEditor class removeSelector: #paneMenu2:! - -SmalltalkEditor class removeSelector: #paneMenu2:! - -SmalltalkEditor removeSelector: #getMenu2! - -SmalltalkEditor removeSelector: #getMenu2! - -TextEditor class removeSelector: #basicInitialize! - -TextEditor class removeSelector: #basicInitialize! - -TextEditor class removeSelector: #initializeMenu! - -TextEditor class removeSelector: #initializeMenu! - -TextEditor class removeSelector: #menu! - -TextEditor class removeSelector: #menu! - -TextEditor class removeSelector: #paneMenu:! - -TextEditor class removeSelector: #paneMenu:! - -TextEditor class - instanceVariableNames: ''! - -!classDefinition: 'TextEditor class' category: #'System-Text'! -TextEditor class - instanceVariableNames: ''! - -SmalltalkEditor class - instanceVariableNames: ''! - -!classDefinition: 'SmalltalkEditor class' category: #'System-Text'! -SmalltalkEditor class - instanceVariableNames: ''! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3311-BigMenuRefactor-p13-JuanVuletich-2018May05-17h09m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3311] on 5 May 2018 at 7:22:00 pm'! - -SelectionMenu removeSelector: #selections! - -SelectionMenu removeSelector: #selections! - -MenuMorph removeSelector: #addCustomMenuItems:hand:! - -MenuMorph removeSelector: #addCustomMenuItems:hand:! - -MenuMorph removeSelector: #addItem! - -MenuMorph removeSelector: #addItem! - -MenuMorph removeSelector: #addTitle! - -MenuMorph removeSelector: #addTitle! - -MenuMorph removeSelector: #sightTarget:! - -MenuMorph removeSelector: #sightTarget:! - -Smalltalk removeClassNamed: #CustomMenu! - -Smalltalk removeClassNamed: #CustomMenu! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3312-BigMenuRefactor-p14-JuanVuletich-2018May05-19h11m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3311] on 5 May 2018 at 7:48:24 pm'! -!MenuMorph methodsFor: 'modal progress dialog' stamp: 'jmv 5/5/2018 19:37:23'! - displayAt: aPoint during: aBlock - "Add this menu to the Morphic world during the execution of the given block." - - self runningWorld ifNotNil: [ :w | - w addMorph: self centeredNear: aPoint. - self world ifNotNil: [ w displayWorld ]. "show myself" - ]. - aBlock value. - self delete! ! -!MenuMorph methodsFor: 'modal progress dialog' stamp: 'jmv 5/5/2018 19:37:19'! - informUserAt: aPoint during: aBlock - "Add this menu to the Morphic world during the execution of the given block." - - | w titleString | - - titleString _ titleMorph submorphs first. - self visible: false. - w _ self world ifNil: [ self runningWorld ]. - aBlock value: [ :string | - self visible ifFalse: [ - w addMorph: self centeredNear: aPoint. - self visible: true]. - titleString contents: string. - titleMorph morphWidth: titleString morphWidth + 8. - self morphPosition: w activeHand morphPosition. - self adjustSubmorphsLayout. - self redrawNeeded. - w ifNotNil: [ - w displayWorld ]. "show myself" - ]. - self delete. - w ifNotNil: [ - w displayWorld ]! ! -!Utilities class methodsFor: 'user interface' stamp: 'jmv 5/5/2018 19:31:18' prior: 16941500! - informUser: aString during: aBlock - "Display a message above (or below if insufficient room) the cursor during execution of the given block." - - " - Utilities informUser: 'Just a sec!!' during: [(Delay forSeconds: 1) wait] - " - - (MenuMorph entitled: aString) - displayAt: Sensor mousePoint + 60 - during: aBlock! ! -!Utilities class methodsFor: 'user interface' stamp: 'jmv 5/5/2018 19:31:32' prior: 50366490! - informUserDuring: barBlock - "Display a message above (or below if insufficient room) the cursor during execution of the given block." - - " - Utilities informUserDuring:[:barBlock| - #(one two three) do:[:info| - barBlock value: info. - (Delay forSeconds: 1) wait]] - " - - (MenuMorph entitled: ' ') - informUserAt: Sensor mousePoint - during: barBlock! ! -!MenuMorph methodsFor: 'modal control' stamp: 'jmv 5/5/2018 19:34:12' prior: 16867158! - invokeModal - "Invoke this menu and don't return until the user has chosen a value. - See example below on how to use modal menu morphs." - ^ self invokeModal: Preferences menuKeyboardControl - - " - | menu sub entry | - menu _ MenuMorph new. - 1 to: 3 do: [:i | - entry _ 'Line', i printString. - sub _ MenuMorph new. - menu add: entry subMenu: sub. - #('Item A' 'Item B' 'Item C') do:[:subEntry| - sub add: subEntry target: menu - action: #modalSelection: argument: {entry. subEntry}]]. - menu invokeModal. - "! ! -!MVCMenuMorph methodsFor: 'invoking' stamp: 'jmv 3/2/2017 20:08:29' prior: 50340036! - invokeAt: aPoint allowKeyboard: aBoolean - "Add this menu to the given world centered at the given point. Wait for the user to make a selection and answer it. The selection value returned is an integer in keeping with PopUpMenu, if the menu is converted from an MVC-style menu." - "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop." - |actHand w oldFocus | - self flag: #bob. "is global or local?" - self flag: #arNote. " is local to aWorld" - w _ self runningWorld. - actHand _ w activeHand. - oldFocus _ actHand keyboardFocus. - w doOneMinimalCycleNow. - self - popUpAt: aPoint - forHand: actHand - allowKeyboard: aBoolean. - done _ false. - [ self isInWorld & done not ] whileTrue: [ w doOneMinimalCycleNow ]. - self delete. - oldFocus ifNotNil: [ actHand newKeyboardFocus: oldFocus ]. - ^ mvcSelection ! ! -!PopUpMenu class methodsFor: 'dialogs' stamp: 'jmv 5/5/2018 19:38:51' prior: 16891113! - confirm: queryString - "Put up a yes/no menu with caption queryString. Answer true if the - response is yes, false if no. This is a modal question--the user must - respond yes or no." - - " - PopUpMenu confirm: 'Are you hungry?' - " - - ^ self confirm: queryString trueChoice: 'Yes' falseChoice: 'No'! ! - -MVCMenuMorph removeSelector: #displayAt:during:! - -MVCMenuMorph removeSelector: #displayAt:during:! - -MVCMenuMorph removeSelector: #informUserAt:during:! - -MVCMenuMorph removeSelector: #informUserAt:during:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3313-BigMenuRefactor-p15-JuanVuletich-2018May05-19h22m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3311] on 5 May 2018 at 8:47:10 pm'! -!VersionsBrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/5/2018 20:45:15' prior: 16942771! - classCommentVersionsMenu - | aMenu | - aMenu _ MenuMorph new defaultTarget: model. "all commands are implemented by the model, not the view" - aMenu addTitle: 'versions'. - aMenu addStayUpIcons. - aMenu buildFromDictionaries: `{ - { - #label -> 'compare to current'. - #selector -> #compareToCurrentVersion. - #balloonText -> 'compare selected version to the current version' - } asDictionary. - { - #label -> 'revert to selected version'. - #selector -> #fileInSelections. - #balloonText -> 'resubmit the selected version, so that it becomes the current version' - } asDictionary. - nil. - { - #label -> 'toggle diffing (D)'. - #selector -> #toggleDiffing. - #balloonText -> 'toggle whether or not diffs should be shown here' - } asDictionary. - { - #label -> 'update list'. - #selector -> #reformulateList. - #balloonText -> 'reformulate the list of versions, in case it somehow got out of synch with reality' - } asDictionary. - nil. - { - #label -> 'help...'. - #selector -> #offerVersionsHelp. - #balloonText -> 'provide an explanation of the use of this tool' - } asDictionary. - }`. - ^aMenu! ! -!VersionsBrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/5/2018 20:45:08' prior: 16942805! - methodVersionsMenu - "Fill aMenu with menu items appropriate to the receiver" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Versions'. - aMenu addStayUpIcons. - model listIndex > 0 ifTrue:[ - (model list size > 1 ) ifTrue: [ - aMenu buildFromDictionaries: `{ - { - #label -> 'compare to current'. - #object -> #model. - #selector -> #compareToCurrentVersion. - #balloonText -> 'compare selected version to the current version' - } asDictionary. - { - #label -> 'compare to version...'. - #object -> #model. - #selector -> #compareToOtherVersion. - #balloonText -> 'compare selected version to another selected version' - } asDictionary. - }` ]. - "Note: Revert to selected should be visible for lists of length one for having the ability to revert to an accidentally deleted method" - aMenu buildFromDictionaries: `{ - { - #label -> 'revert to selected version'. - #object -> #model. - #selector -> #fileInSelections. - #balloonText -> 'resubmit the selected version, so that it becomes the current version' - } asDictionary. - }` ]. - - aMenu buildFromDictionaries: `{ - { - #label -> 'edit current method (O)'. - #selector -> #openSingleMessageBrowser. - #balloonText -> 'open a single-message browser on the current version of this method' - } asDictionary. - nil. - { - #label -> 'toggle diffing (D)'. - #object -> #model. - #selector -> #toggleDiffing. - #balloonText -> 'toggle whether or not diffs should be shown here' - } asDictionary. - { - #label -> 'update list'. - #object -> #model. - #selector -> #reformulateList. - #balloonText -> 'reformulate the list of versions, in case it somehow got out of synch with reality' - } asDictionary. - nil. - { - #label -> 'senders (n)'. - #selector -> #browseSenders. - #balloonText -> 'browse all senders of this selector' - } asDictionary. - { - #label -> 'implementors (m)'. - #selector -> #browseImplementors. - #balloonText -> 'browse all implementors of this selector' - } asDictionary. - nil. - { - #label -> 'help...'. - #object -> #model. - #selector -> #offerVersionsHelp. - #balloonText -> 'provide an explanation of the use of this tool' - } asDictionary. - }`. - ^aMenu! ! -!ChangeSorterWindow methodsFor: 'menu building' stamp: 'jmv 5/5/2018 20:27:50' prior: 50393452! - changeSetMenu - "Set up aMenu to hold commands for the change-set-list pane. This could be for a single or double changeSorter" - - | aMenu isForBaseSystem | - isForBaseSystem _ model changeSet isForBaseSystem. - aMenu _ MenuMorph new defaultTarget: model. - aMenu addTitle: 'Change Set'. - aMenu addStayUpIcons. - - (aMenu add: 'File out and remove (o)' action: #fileOutAndRemove) isEnabled: isForBaseSystem. - aMenu add: 'File out and keep (k)' action: #fileOutAndKeep. - aMenu addLine. - - (aMenu add: 'Rename change set (r)' action: #rename) isEnabled: isForBaseSystem. - (aMenu add: 'Destroy change set (x)' action: #remove) isEnabled: isForBaseSystem. - aMenu addLine. - model currentCanHavePreambleAndPostscript ifTrue: [ - aMenu addLine. - model currentHasPreamble - ifTrue: [ - aMenu add: 'Edit preamble (p)' action: #addPreamble. - aMenu add: 'Remove preamble' action: #removePreamble] - ifFalse: [ - aMenu add: 'Add preamble (p)' action: #addPreamble]. - model currentHasPostscript - ifTrue: [ - aMenu add: 'Edit postscript...' action: #editPostscript. - aMenu add: 'Remove postscript' action: #removePostscript] - ifFalse: [ - aMenu add: 'Add postscript...' action: #editPostscript]. - ]. - aMenu addLine. - - "CONFLICTS SECTION" - (aMenu add: 'conflicts with other change sets' target: self action: #browseMethodConflicts) - setBalloonText: 'Browse all methods that occur both in this change set and in at least one other change set.'. - aMenu addLine. - - "CHECKS SECTION" - (aMenu add: 'trim history' action: #trimHistory) - isEnabled: isForBaseSystem; - setBalloonText: ' Drops any methods added and then removed, as well as renaming and reorganization of newly-added classes. ', - 'NOTE: can cause confusion if later filed in over an earlier version of these changes'. - - (aMenu add: 'view affected class categories' action: #viewAffectedClassCategories) - setBalloonText: ' Show class categories affected by any contained change'. - - ^ aMenu! ! -!ChangeSorterWindow methodsFor: 'menu building' stamp: 'jmv 5/5/2018 20:27:52' prior: 16800150! - classListMenu - "Fill aMenu with items appropriate for the class list" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'class list'. - aMenu addStayUpIcons. - aMenu addList: #( - - - ('delete class from change set (d)' forgetClass '' model) - ('remove class from system (x)' removeClass '' model) - - - ('browse full (b)' browseMethodFull) - ('browse hierarchy (h)' browseHierarchy) - ('browse protocol (p)' browseFullProtocol) - - - ('inst var refs...' browseInstVarRefs) - ('inst var defs...' browseInstVarDefs) - ('class var refs...' browseClassVarRefs) - ('class vars' browseClassVariables) - ('class refs (N)' browseClassRefs)). - ^ aMenu! ! -!ChangeSorterWindow methodsFor: 'menu building' stamp: 'jmv 5/5/2018 20:27:55' prior: 16800176! - messageMenu - "Fill aMenu with items appropriate for the message list; could be for a single or double changeSorter" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'message list'. - aMenu addStayUpIcons. - aMenu addList: #( - ('delete method from changeSet (d)' forget '' model) - - - ('remove method from system (x)' removeMessage '' model) - - - ('browse full (b)' browseMethodFull) - ('browse hierarchy (h)' browseHierarchy) - ('browse method (O)' openSingleMessageBrowser) - ('browse protocol (p)' browseFullProtocol) - - - ('fileOut' fileOutMessage '' model) - - - ('senders of... (n)' browseSendersOfMessages) - ('implementors of... (m)' browseMessages) - ('inheritance (i)' methodHierarchy) - ('versions (v)' browseVersions)). - ^ aMenu! ! -!TestRunnerWindow methodsFor: 'menu building' stamp: 'jmv 5/5/2018 20:27:58' prior: 50393131! - listMenu - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Test Cases'. - aMenu add: 'select all' target: model action: #selectAll. - aMenu add: 'deselect all' target: model action: #deselectAll. - aMenu add: 'toggle selections' target: model action: #invertSelections. - aMenu add: 'filter' target: model action: #setFilter. - model runButtonState ifTrue: [ - aMenu add: 'stop' target: model action: #terminateRun - ]. - model selectedSuite > 0 ifTrue: [ | cls | - cls _ (model tests at: model selectedSuite ifAbsent: ['']) copyUpTo: Character space. - cls _ cls asSymbol. - cls _ (Smalltalk at: cls ifAbsent: nil). - cls ifNotNil: [ - aMenu addLine. - aMenu add: 'browse' target: self action: #browse: argument: cls. - ]. - ]. - aMenu addLine. - aMenu add: 'log to Transcript' target: model action: #showResult. - ^aMenu! ! - -MenuMorph removeSelector: #title:! - -MenuMorph removeSelector: #title:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3314-BigMenuRefactor-p16-JuanVuletich-2018May05-20h24m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3311] on 5 May 2018 at 8:58:04 pm'! -!CodeWindow methodsFor: 'menu building' stamp: 'jmv 5/5/2018 20:54:23'! - offerClassListMenu - "Offer the shifted class-list menu." - - ^ self classListMenu popUpInWorld! ! -!CodeWindow methodsFor: 'menu building' stamp: 'jmv 5/5/2018 20:53:04'! - offerClassListMenu2 - "Offer the shifted class-list menu." - - ^ self classListMenu2 popUpInWorld! ! -!CodeWindow methodsFor: 'menu building' stamp: 'jmv 5/5/2018 20:50:27'! - openMessageListMenu2 - "Offer the additional selector-list menu" - - ^ self messageListMenu2 popUpInWorld! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/5/2018 20:56:29'! - addExtraMenu2ItemsTo: aMenu - "The shifted selector-list menu is being built; some menu items are appropriate only for certain kinds of browsers, and this gives a hook for them to be added as approrpiate. If any is added here, a line should be added first -- browse reimplementors of this message for examples."! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/5/2018 20:55:04'! - classListMenu2 - "Set up the menu to apply to the receiver's class list when the shift key is down" - - | aMenu | - aMenu := MenuMorph new defaultTarget: self. - aMenu addList: #( - - - ('unsent methods' browseUnusedMethods - 'browse all methods defined by this class that have no senders') - ('unreferenced inst vars' showUnreferencedInstVars - 'show a list of all instance variables that are not referenced in methods') - ('unreferenced class vars' showUnreferencedClassVars - 'show a list of all class variables that are not referenced in methods') - ('subclass template' makeNewSubclass - 'put a template into the code pane for defining of a subclass of this class' model) - - - ('sample instance' makeSampleInstance - 'give me a sample instance of this class, if possible') - ('inspect instances' inspectInstances - 'open an inspector on all the extant instances of this class') - ('inspect subinstances' inspectSubInstances - 'open an inspector on all the extant instances of this class and of all of its subclasses') - - - ('create inst var accessors' createInstVarAccessors - 'compile instance-variable access methods for any instance variables that do not yet have them' model) - - - ('more...' offerClassListMenu - 'return to the standard class-list menu')). - ^ aMenu! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/5/2018 20:56:50'! - messageListMenu2 - "Fill aMenu with the items appropriate when the shift key is held down" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addStayUpIcons. - aMenu addList: #( - ('toggle diffing (D)' toggleDiffing '' model) - ('implementors of sent messages' browseAllMessages) - - - ('local senders of...' browseLocalSendersOfMessages) - ('local implementors of...' browseLocalImplementors) - - - ('spawn sub-protocol' browseProtocol) - ('spawn full protocol' browseFullProtocol) - - - ('sample instance' makeSampleInstance) - ('inspect instances' inspectInstances) - ('inspect subinstances' inspectSubInstances)). - - self addExtraMenu2ItemsTo: aMenu. - aMenu addList: #( - - - ('change category...' changeCategory '' model)). - - model canShowMultipleMessageCategories ifTrue: [ aMenu addList: #( - ('show category (C)' showHomeCategory '' model))]. - aMenu addList: #( - - - ('change sets with this method' findMethodInChangeSets) - ('revert to previous version' revertToPreviousVersion '' model) - - - ('more...' openMessageListMenu)). - ^ aMenu! ! -!MessageSetWindow methodsFor: 'menu building' stamp: 'jmv 5/5/2018 20:56:34'! - addExtraMenu2ItemsTo: aMenu - "The shifted selector-list menu is being built. Add items specific to MessageSet" - - model growable ifTrue: [ - aMenu addList: #( - - - ('remove from this browser' removeMessageFromBrowser '' model) - ('filter message list...' filterMessageList))]. - aMenu add: 'sort by date' target: model action: #sortByDate! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/5/2018 20:53:09' prior: 50338669! - classListMenu - "Set up the menu to apply to the receiver's class list, honoring the #shifted boolean" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addList: #( - ('browse full (b)' browseMethodFull) - ('browse hierarchy (h)' browseHierarchy) - ('browse protocol (p)' browseFullProtocol) - - - ('fileOut' fileOutClass '' model) - - - ('show hierarchy' hierarchy '' model) - ('show definition' editClass '' model) - ('show comment' editComment '' model) - - - ('inst var refs...' browseInstVarRefs) - ('inst var defs...' browseInstVarDefs) - - - ('class var refs...' browseClassVarRefs) - ('class vars' browseClassVariables) - ('class refs (N)' browseClassRefs) - - - ('rename class ...' renameClass '' model) - ('copy class...' copyClass '' model) - ('remove class (x)' removeClass '' model) - - - ('Run tests (t)' runClassTests '' model) - ('more...' offerClassListMenu2)). - ^ aMenu! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/5/2018 20:50:00' prior: 50344014! - messageListMenu - "Answer the message-list menu" - "Changed by emm to include menu-item for breakpoints" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addList:#( - ('what to show...' offerWhatToShowMenu) - ('toggle break on entry' toggleBreakOnEntry '' model) - - - ('browse full (b)' browseMethodFull) - ('browse hierarchy (h)' browseHierarchy) - ('browse method (O)' openSingleMessageBrowser) - ('browse protocol (p)' browseFullProtocol) - - - ('fileOut' fileOutMessage '' model) - ('explore CompiledMethod' exploreCompiledMethod '' model) - - - ('senders of... (n)' browseSendersOfMessages) - ('implementors of... (m)' browseMessages) - ('inheritance (i)' methodHierarchy) - ('versions (v)' browseVersions) - - - ('inst var refs...' browseInstVarRefs) - ('inst var defs...' browseInstVarDefs) - ('class var refs...' browseClassVarRefs) - ('class variables' browseClassVariables) - ('class refs (N)' browseClassRefs) - - - ('remove method (x)' removeMessage '' model) - ('Run test (t)' runMethodTest '' model) - ('Debug test (r)' debugMethodTest '' model) - - - ('more...' openMessageListMenu2)). - ^ aMenu -! ! - -MessageSetWindow removeSelector: #addExtraShiftedItemsTo:! - -MessageSetWindow removeSelector: #addExtraShiftedItemsTo:! - -BrowserWindow removeSelector: #addExtraShiftedItemsTo:! - -BrowserWindow removeSelector: #addExtraShiftedItemsTo:! - -BrowserWindow removeSelector: #shiftedClassListMenu! - -BrowserWindow removeSelector: #shiftedClassListMenu! - -BrowserWindow removeSelector: #shiftedMessageListMenu! - -BrowserWindow removeSelector: #shiftedMessageListMenu! - -CodeWindow removeSelector: #offerShiftedClassListMenu! - -CodeWindow removeSelector: #offerShiftedClassListMenu! - -CodeWindow removeSelector: #offerUnshiftedClassListMenu! - -CodeWindow removeSelector: #offerUnshiftedClassListMenu! - -CodeWindow removeSelector: #openShiftedMessageListMenu! - -CodeWindow removeSelector: #openShiftedMessageListMenu! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3315-BigMenuRefactor-p17-JuanVuletich-2018May05-20h47m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3315] on 6 May 2018 at 10:33:27 am'! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/6/2018 10:32:34'! - addItemsFromDictionaries: dataForMenuDicts - "A menu constructor utility that uses Dictionaries with elements: - #label - the name that displays in the menu - #object - the target object. If nil, use defaultTarget. If a Symbol, send it as message to defaultTarget to get real target. - #selector - the selector called on object when the menu item is selected - #arguments - optional collection of arguments passed to the selector - #balloonText - optional 'tool tip' style help text - #icon- optional icon selector or Form - - note, nil elements will add a line." - | item wantsIcons | - wantsIcons _ Preferences wantsMenuIcons. - dataForMenuDicts do: [ :dict | - dict - ifNil: [ self addLine ] - ifNotNil: [ | realTarget | - realTarget _ dict at: #object ifAbsent: [defaultTarget]. - realTarget isSymbol ifTrue: [ realTarget _ defaultTarget perform: realTarget ]. - item _ (dict at: #label) isSymbol - ifTrue: [ - self - addUpdating: (dict at: #label) - target: realTarget - action: (dict at: #selector) - argumentList: - (dict - at: #arguments - ifAbsent: [ #() ]) ] - ifFalse: [ - self - add: (dict at: #label) - target: realTarget - action: (dict at: #selector) - argumentList: - (dict - at: #arguments - ifAbsent: [ #() ]) ]. - wantsIcons ifTrue: [ - dict - at: #icon - ifPresent: [ :symbolOrFormOrNil | - item setIcon: symbolOrFormOrNil ]]. - dict - at: #balloonText - ifPresent: [ :balloonText | - item setBalloonText: balloonText ]. - ]]! ! -!TextEditor methodsFor: 'menu' stamp: 'jmv 5/6/2018 10:32:42' prior: 50395500! - getMenu - - ^(MenuMorph new defaultTarget: self) - addTitle: self class name; - addStayUpIcons; - addItemsFromDictionaries: `{ - { - #label -> 'Help...'. - #selector -> #openHelp. - #icon -> #helpIcon - } asDictionary. - nil. - { - #label -> 'Find...(f)'. - #selector -> #find. - #icon -> #findIcon - } asDictionary. - { - #label -> 'Find Again (g)'. - #selector -> #findAgain. - #icon -> #systemIcon - } asDictionary. - { - #label -> 'Use Selection for Find (j)'. - #selector -> #setSearchString. - #icon -> #saveAsIcon - } asDictionary. - nil. - { - #label -> 'Undo - multiple (z)'. - #selector -> #undo. - #icon -> #undoIcon - } asDictionary. - { - #label -> 'Redo - multiple (Z)'. - #selector -> #redo. - #icon -> #redoIcon - } asDictionary. - { - #label -> 'Undo / Redo history'. - #selector -> #offerUndoHistory. - #icon -> #changesIcon - } asDictionary. - nil. - { - #label -> 'Copy (c)'. - #selector -> #copySelection. - #icon -> #copyIcon - } asDictionary. - { - #label -> 'Cut (x)'. - #selector -> #cut. - #icon -> #cutIcon - } asDictionary. - { - #label -> 'Paste (v)'. - #selector -> #paste. - #icon -> #pasteIcon - } asDictionary. - { - #label -> 'Paste without Format'. - #selector -> #pasteString. - #icon -> #pasteIcon - } asDictionary. - { - #label -> 'Paste...'. - #selector -> #pasteRecent. - #icon -> #worldIcon - } asDictionary. - nil. - { - #label -> 'Toggle WordWrap'. - #selector -> #wrapOnOff. - #icon -> #genericTextIcon - } asDictionary. - { - #label -> 'Set Font... (k)'. - #selector -> #offerFontMenu. - #icon -> #preferencesDesktopFontIcon - } asDictionary. - { - #label -> 'Clear Font'. - #selector -> #clearFont. - #icon -> #newIcon - } asDictionary. - { - #label -> 'Set Default Font...'. - #selector -> #offerDefaultFontMenu. - #icon -> #fontXGenericIcon - } asDictionary. - { - #label -> 'Set Alignment...'. - #selector -> #chooseAlignment. - #icon -> #formatJustifyLeftIcon - } asDictionary. - }`! ! -!SmalltalkEditor methodsFor: 'menu' stamp: 'jmv 5/6/2018 10:32:39' prior: 50395329! - getMenu - - ^(MenuMorph new defaultTarget: self) - addTitle: self class name; - addStayUpIcons; - addItemsFromDictionaries: `{ - { - #label -> 'Help...'. - #selector -> #openHelp. - #icon -> #helpIcon - } asDictionary. - nil. - { - #label -> 'Do it (d)'. - #selector -> #doIt. - #icon -> #doItIcon - } asDictionary. - { - #label -> 'Print it (p)'. - #selector -> #printIt. - #icon -> #printIcon - } asDictionary. - { - #label -> 'Inspect it (i)'. - #selector -> #inspectIt. - #icon -> #inspectIcon - } asDictionary. - { - #label -> 'Explore it (I)'. - #selector -> #exploreIt. - #icon -> #exploreIcon - } asDictionary. - { - #label -> 'Debug it (D)'. - #selector -> #debugIt. - #icon -> #debugIcon - } asDictionary. - { - #label -> 'Profile it'. - #selector -> #profileIt. - #icon -> #clockIcon - } asDictionary. - nil. - { - #label -> 'Explain'. - #selector -> #explain. - #icon -> #helpIcon - } asDictionary. - { - #label -> 'Browse it (b)'. - #selector -> #browseIt. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'Senders of it (n)'. - #selector -> #sendersOfIt. - #icon -> #mailForwardIcon - } asDictionary. - { - #label -> 'Implementors of it (m)'. - #selector -> #implementorsOfIt. - #icon -> #developmentIcon - } asDictionary. - { - #label -> 'References to it (N)'. - #selector -> #referencesToIt. - #icon -> #addressBookIcon - } asDictionary. - nil. - { - #label -> 'Method Strings with it (E)'. - #selector -> #methodStringsContainingit. - #icon -> #genericTextIcon - } asDictionary. - { - #label -> 'Method Source with it'. - #selector -> #methodSourceContainingIt. - #icon -> #scriptIcon - } asDictionary. - { - #label -> 'Class Comments with it'. - #selector -> #classCommentsContainingIt. - #icon -> #chatIcon - } asDictionary. - nil. - { - #label -> 'Accept (s)'. - #selector -> #acceptContents. - #icon -> #acceptIcon - } asDictionary. - { - #label -> 'Cancel (l)'. - #selector -> #cancelEdits. - #icon -> #cancelIcon - } asDictionary. - { - #label -> 'Accept & Run Test in Class (t)'. - #selector -> #acceptAndTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #label -> 'Accept & Run Test in Category (y)'. - #selector -> #acceptAndTestAll. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #label -> 'Accept & Debug Test (r)'. - #selector -> #acceptAndDebugTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - nil. - { - #label -> 'More...'. - #selector -> #openMenu2. - #icon -> #listAddIcon - } asDictionary. - }`! ! -!SmalltalkEditor methodsFor: 'menu' stamp: 'jmv 5/6/2018 10:32:41' prior: 50395428! - openMenu2 - - (MenuMorph new defaultTarget: self) - addTitle: self class name; - addStayUpIcons; - addItemsFromDictionaries: `{ - { - #label -> 'Find...(f)'. - #selector -> #find. - #icon -> #findIcon - } asDictionary. - { - #label -> 'Find Again (g)'. - #selector -> #findAgain. - #icon -> #systemIcon - } asDictionary. - { - #label -> 'Use Selection for Find (j)'. - #selector -> #setSearchString. - #icon -> #saveAsIcon - } asDictionary. - nil. - { - #label -> 'Undo - multiple (z)'. - #selector -> #undo. - #icon -> #undoIcon - } asDictionary. - { - #label -> 'Redo - multiple (Z)'. - #selector -> #redo. - #icon -> #redoIcon - } asDictionary. - { - #label -> 'Undo / Redo history'. - #selector -> #offerUndoHistory. - #icon -> #changesIcon - } asDictionary. - nil. - { - #label -> 'Copy (c)'. - #selector -> #copySelection. - #icon -> #copyIcon - } asDictionary. - { - #label -> 'Cut (x)'. - #selector -> #cut. - #icon -> #cutIcon - } asDictionary. - { - #label -> 'Paste (v)'. - #selector -> #paste. - #icon -> #pasteIcon - } asDictionary. - { - #label -> 'Paste without Format'. - #selector -> #pasteString. - #icon -> #pasteIcon - } asDictionary. - { - #label -> 'Paste...'. - #selector -> #pasteRecent. - #icon -> #worldIcon - } asDictionary. - nil. - { - #label -> 'Toggle WordWrap'. - #selector -> #wrapOnOff. - #icon -> #genericTextIcon - } asDictionary. - { - #label -> 'Set Font... (k)'. - #selector -> #offerFontMenu. - #icon -> #preferencesDesktopFontIcon - } asDictionary. - { - #label -> 'Clear Font'. - #selector -> #clearFont. - #icon -> #newIcon - } asDictionary. - { - #label -> 'Set Default Font...'. - #selector -> #offerDefaultFontMenu. - #icon -> #fontXGenericIcon - } asDictionary. - nil. - { - #label -> 'More...'. - #selector -> #openMenu. - #icon -> #listAddIcon - } asDictionary. - }`; - popUpInWorld: morph world.! ! -!VersionsBrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/6/2018 10:32:59' prior: 50395801! - classCommentVersionsMenu - | aMenu | - aMenu _ MenuMorph new defaultTarget: model. "all commands are implemented by the model, not the view" - aMenu addTitle: 'versions'. - aMenu addStayUpIcons. - aMenu addItemsFromDictionaries: `{ - { - #label -> 'compare to current'. - #selector -> #compareToCurrentVersion. - #balloonText -> 'compare selected version to the current version' - } asDictionary. - { - #label -> 'revert to selected version'. - #selector -> #fileInSelections. - #balloonText -> 'resubmit the selected version, so that it becomes the current version' - } asDictionary. - nil. - { - #label -> 'toggle diffing (D)'. - #selector -> #toggleDiffing. - #balloonText -> 'toggle whether or not diffs should be shown here' - } asDictionary. - { - #label -> 'update list'. - #selector -> #reformulateList. - #balloonText -> 'reformulate the list of versions, in case it somehow got out of synch with reality' - } asDictionary. - nil. - { - #label -> 'help...'. - #selector -> #offerVersionsHelp. - #balloonText -> 'provide an explanation of the use of this tool' - } asDictionary. - }`. - ^aMenu! ! -!VersionsBrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/6/2018 10:33:10' prior: 50395842! - methodVersionsMenu - "Fill aMenu with menu items appropriate to the receiver" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Versions'. - aMenu addStayUpIcons. - model listIndex > 0 ifTrue:[ - (model list size > 1 ) ifTrue: [ - aMenu addItemsFromDictionaries: `{ - { - #label -> 'compare to current'. - #object -> #model. - #selector -> #compareToCurrentVersion. - #balloonText -> 'compare selected version to the current version' - } asDictionary. - { - #label -> 'compare to version...'. - #object -> #model. - #selector -> #compareToOtherVersion. - #balloonText -> 'compare selected version to another selected version' - } asDictionary. - }` ]. - "Note: Revert to selected should be visible for lists of length one for having the ability to revert to an accidentally deleted method" - aMenu addItemsFromDictionaries: `{ - { - #label -> 'revert to selected version'. - #object -> #model. - #selector -> #fileInSelections. - #balloonText -> 'resubmit the selected version, so that it becomes the current version' - } asDictionary. - }` ]. - - aMenu addItemsFromDictionaries: `{ - { - #label -> 'edit current method (O)'. - #selector -> #openSingleMessageBrowser. - #balloonText -> 'open a single-message browser on the current version of this method' - } asDictionary. - nil. - { - #label -> 'toggle diffing (D)'. - #object -> #model. - #selector -> #toggleDiffing. - #balloonText -> 'toggle whether or not diffs should be shown here' - } asDictionary. - { - #label -> 'update list'. - #object -> #model. - #selector -> #reformulateList. - #balloonText -> 'reformulate the list of versions, in case it somehow got out of synch with reality' - } asDictionary. - nil. - { - #label -> 'senders (n)'. - #selector -> #browseSenders. - #balloonText -> 'browse all senders of this selector' - } asDictionary. - { - #label -> 'implementors (m)'. - #selector -> #browseImplementors. - #balloonText -> 'browse all implementors of this selector' - } asDictionary. - nil. - { - #label -> 'help...'. - #object -> #model. - #selector -> #offerVersionsHelp. - #balloonText -> 'provide an explanation of the use of this tool' - } asDictionary. - }`. - ^aMenu! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/6/2018 10:32:44' prior: 50394762! - buildWorldMenu - "Build the menu that is put up when the screen-desktop is clicked on" - - ^(MenuMorph new defaultTarget: self) - addStayUpIcons; - addItemsFromDictionaries: `{ - { - #label -> 'Open...'. - #selector -> #openOpenMenu. - #icon -> #openIcon. - #balloonText -> 'Submenu to open various system tools'. - } asDictionary. - { - #label -> 'New morph...'. - #selector -> #newMorph. - #icon -> #morphsIcon. - #balloonText -> 'Offers a variety of ways to create new objects'. - } asDictionary. - { - #label -> 'Preferences...'. - #selector -> #openPreferencesMenu. - #icon -> #preferencesIcon. - #balloonText -> 'Opens a menu offering many controls over appearance and system preferences.'. - } asDictionary. - { - #label -> 'Windows...'. - #selector -> #openWindowsMenu. - #icon -> #windowIcon. - #balloonText -> 'Manage open windows'. - } asDictionary. - { - #label -> 'Help...'. - #selector -> #openHelpMenu. - #icon -> #helpIcon. - #balloonText -> 'Opens a menu of useful items for updating the system, determining what version you are running, and much else'. - } asDictionary. - nil. - { - #label -> 'Changes...'. - #selector -> #openChangesMenu. - #icon -> #changesIcon. - #balloonText -> 'Opens a menu of useful tools for dealing with changes'. - } asDictionary. - { - #label -> 'Debug...'. - #selector -> #openDebugMenu. - #icon -> #debugIcon. - #balloonText -> 'a menu of debugging items'. - } asDictionary. - { - #label -> 'Restore Display (r)'. - #object -> #myWorld. - #selector -> #restoreDisplay. - #icon -> #displayIcon. - #balloonText -> 'Repaint the screen -- useful for removing unwanted display artifacts, lingering cursors, etc.'. - } asDictionary. - nil. - { - #label -> 'Save'. - #object -> Smalltalk. - #selector -> #saveSession. - #icon -> #saveIcon. - #balloonText -> 'Save the current version of the image on disk'. - } asDictionary. - { - #label -> 'Save as...'. - #object -> Smalltalk. - #selector -> #saveAs. - #icon -> #saveAsIcon. - #balloonText -> 'Save the current version of the image on disk under a new name.'. - } asDictionary. - { - #label -> 'Save as New Version'. - #object -> Smalltalk. - #selector -> #saveAsNewVersion. - #icon -> #saveAsNewVersionIcon. - #balloonText -> ('Save the current image a new version-stamped name\and save it under that name on disk.\', - 'Clear all user preferences and user state (class vars).') withNewLines. - } asDictionary. - { - #label -> 'Save and Quit'. - #selector -> #saveAndQuit. - #icon -> #saveAndQuitIcon. - #balloonText -> 'Save the image and quit out of Cuis.'. - } asDictionary. - { - #label -> 'Quit'. - #selector -> #quitSession. - #icon -> #quitIcon. - #balloonText -> 'Quit out of Cuis.'. - } asDictionary. - }`! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/6/2018 10:32:45' prior: 50394865! - changesMenu - "Build the changes menu for the world." - - ^ (self menu: 'Changes...') - addItemsFromDictionaries: `{ - { - #label -> 'Change Sorter'. - #object -> ChangeSorterWindow. - #selector -> #openChangeSorter. - #icon -> #halfRefreshIcon. - #balloonText -> 'Open a 3-paned changed-set viewing tool'. - } asDictionary. - nil. - { - #label -> 'Install New Updates'. - #object -> ChangeSet. - #selector -> #installNewUpdates. - #icon -> #updateIcon. - #balloonText -> 'Install in the current image the new updates available -in directory named ./CoreUpdates -or in directory named ../Cuis-Smalltalk-Dev/CoreUpdates'. - } asDictionary. - nil. - { - #label -> 'Browse my Changes'. - #object -> Smalltalk. - #selector -> #browseMyChanges. - #icon -> #editFindReplaceIcon. - #balloonText -> 'Browse all of my changes since the last time #condenseSources was run.'. - } asDictionary. - { - #label -> 'Recently logged Changes...'. - #object -> ChangeList. - #selector -> #browseRecentLog. - #icon -> #clockIcon. - #balloonText -> 'Open a change-list browser on the latter part of the changes log. You can use this browser to recover logged changes which were not saved in your image, in the event of a crash or other interruption.'. - } asDictionary. - nil. - { - #label -> 'Save World as morph file'. - #selector -> #saveWorldInFile. - #icon -> #morphsIcon. - #balloonText -> 'Save a file that, when reloaded, reconstitutes the current World.'. - } asDictionary. - }`! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/6/2018 10:32:47' prior: 50394919! -debugMenu - - ^ (self menu: 'Debug...') - addItemsFromDictionaries: `{ - { - #label -> 'Inspect World'. - #object -> #myWorld. - #selector -> #inspect. - #icon -> #inspectIcon. - } asDictionary. - { - #label -> 'Explore World'. - #object -> #myWorld. - #selector -> #explore. - #icon -> #exploreIcon. - } asDictionary. - { - #label -> 'MessageTally all Processes'. - #selector -> #startMessageTally. - #icon -> #systemMonitorIcon. - } asDictionary. - { - #label -> 'MessageTally UI and Browse'. - #selector -> #startThenBrowseMessageTally. - #icon -> #editFindReplaceIcon. - } asDictionary. - nil. - { - #label -> 'Start drawing all again'. - #object -> #myWorld. - #selector -> #removeAllKnownFailing. - #icon -> #graphicsIcon. - } asDictionary. - { - #label -> 'Start stepping again'. - #object -> #myWorld. - #selector -> #resumeAfterStepError. - #icon -> #mediaPlaybackStartIcon. - } asDictionary. - { - #label -> 'Close all Debuggers'. - #object -> DebuggerWindow. - #selector -> #closeAllDebuggers. - #icon -> #closeIcon. - } asDictionary. - }`! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/6/2018 10:32:49' prior: 50394961! - helpMenu - "Build the help menu for the world." - - ^ (self menu: 'Help...') - addItemsFromDictionaries: `{ - { - #label -> 'About this System...'. - #object -> Smalltalk. - #selector -> #aboutThisSystem. - #icon -> #helpIcon. - #balloonText -> 'current version information.' - } asDictionary. - { - #label -> 'Terse Guide to Cuis'. - #selector -> #openTerseGuide. - #icon -> #helpIcon. - #balloonText -> 'explore Cuis Smalltalk' - } asDictionary. - { - #label -> 'Class Comment Browser'. - #selector -> #openCommentGuide. - #icon -> #helpIcon. - #balloonText -> 'search & explore Cuis Class Comments' - } asDictionary. - { - #label -> 'Code management in Cuis'. - #object -> Utilities. - #selector -> #openCodeManagementInCuis. - #icon -> #helpIcon. - #balloonText -> 'Features are kept in Packages.' - } asDictionary. - { - #label -> 'Using GitHub to host Cuis packages'. - #object -> Utilities. - #selector -> #openCuisAndGitHub. - #icon -> #helpIcon. - #balloonText -> 'GitHub usage pattern.' - } asDictionary. - nil. - { - #label -> 'Editor keyboard shortcuts'. - #object -> SmalltalkEditor. - #selector -> #openHelp. - #icon -> #keyboardShortcutsIcon. - #balloonText -> 'summary of keyboard shortcuts in editors for Smalltalk code.' - } asDictionary. - { - #label -> 'Useful Expressions'. - #object -> Utilities. - #selector -> #openUsefulExpressions. - #icon -> #chatIcon. - #balloonText -> 'a window full of useful expressions.' - } asDictionary. - nil. - { - #label -> 'VM Statistics'. - #selector -> #vmStatistics. - #icon -> #systemMonitorIcon. - #balloonText -> 'obtain some intriguing data about the vm.' - } asDictionary. - { - #label -> 'Space Left'. - #selector -> #garbageCollect. - #icon -> #removableMediaIcon. - #balloonText -> 'perform a full garbage-collection and report how many bytes of space remain in the image.' - } asDictionary. - }`! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/6/2018 10:32:52' prior: 50395031! - openMenu - "Build the open window menu for the world." - | menu items groups firstGroup itemsSorted itemsBase | - menu _ self menu: 'Open...'. - itemsBase _ (Smalltalk allClassesImplementing: #worldMenuForOpenGroup) - collect: [ :item | - item class == Metaclass ifTrue: [ - item soleInstance - worldMenuForOpenGroup ] ] - thenSelect: [ :item | - item notNil ]. - items _ OrderedCollection new. - "A single class may add more than one item to a menu" - itemsBase do: [ :item | - item class == Dictionary - ifTrue: [ items add: item ] - ifFalse: [ items addAll: item ]]. - groups _ (items collect: [ :item | - item at: #itemGroup ]) asSet asSortedCollection. - itemsSorted _ OrderedCollection new. - firstGroup _ true. - groups do: [ :group | - firstGroup - ifTrue: [ firstGroup _ false ] - ifFalse: [ itemsSorted add: nil ]. - ((items select: [ :item | - (item at: #itemGroup) = group ]) sort: [ :item1 :item2 | - (item1 at: #itemOrder) < (item2 at: #itemOrder) ]) do: [ :item | - itemsSorted add: item ]]. - menu addItemsFromDictionaries: itemsSorted. - ^ menu.! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/6/2018 10:32:55' prior: 50395068! - preferencesMenu - "Build the preferences menu for the world." - - ^ (self menu: 'Preferences...') - addItemsFromDictionaries: `{ - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Font Sizes...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set display depth...'. - #selector -> #setDisplayDepth. - #icon -> #displayIcon. - #balloonText -> 'choose how many bits per pixel.' - } asDictionary. - { - #label -> 'Set desktop color...'. - #selector -> #changeBackgroundColor. - #icon -> #wallpaperIcon. - #balloonText -> 'choose a uniform color to use as desktop background.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }`! ! -!TheWorldMenu methodsFor: 'windows & flaps menu' stamp: 'jmv 5/6/2018 10:32:56' prior: 50395169! - windowsMenu - "Build the windows menu for the world." - - ^ (self menu: 'Windows') - addItemsFromDictionaries: `{ - { - #label -> 'Find Window'. - #object -> #myWorld. - #selector -> #findWindow:. - #icon -> #windowIcon. - #balloonText -> 'Presents a list of all windows; if you choose one from the list, it becomes the active window.' - } asDictionary. - { - #label -> 'Find changed Browsers...'. - #object -> #myWorld. - #selector -> #findDirtyBrowsers:. - #icon -> #editFindReplaceIcon. - #balloonText -> 'Presents a list of browsers that have unsubmitted changes; if you choose one from the list, it becomes the active window.' - } asDictionary. - { - #label -> 'Find changed Windows...'. - #object -> #myWorld. - #selector -> #findDirtyWindows:. - #icon -> #newWindowIcon. - #balloonText -> 'Presents a list of all windows that have unsubmitted changes; if you choose one from the list, it becomes the active window.' - } asDictionary. - nil. - { - #label -> 'Find a Transcript'. - #object -> #myWorld. - #selector -> #findATranscript:. - #icon -> #printerIcon. - #balloonText -> 'Brings an open Transcript to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find a FileList'. - #object -> #myWorld. - #selector -> #findAFileList:. - #icon -> #systemFileManagerIcon. - #balloonText -> 'Brings an open fileList to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find a Change Sorter'. - #object -> #myWorld. - #selector -> #findAChangeSorter:. - #icon -> #changesIcon. - #balloonText -> 'Brings an open change sorter to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find Message Names'. - #object -> #myWorld. - #selector -> #findAMessageNamesWindow:. - #icon -> #inspectIcon. - #balloonText -> 'Brings an open MessageNames window to the front, creating one if necessary, and makes it the active window' - } asDictionary. - nil. - { - #label -> 'Collapse all Windows'. - #object -> #myWorld. - #selector -> #collapseAll. - #icon -> #collapseIcon. - #balloonText -> 'Reduce all open windows to collapsed forms that only show titles.' - } asDictionary. - { - #label -> 'Restore all Windows'. - #object -> #myWorld. - #selector -> #restoreAll. - #icon -> #expandIcon. - #balloonText -> 'Restore all collapsed windows back to their previous forms.' - } asDictionary. - { - #label -> 'Close top Window'. - #object -> SystemWindow. - #selector -> #closeTopWindow. - #icon -> #closeIcon. - #balloonText -> 'Close the topmost window if possible.' - } asDictionary. - { - #label -> 'Send top Window to back'. - #object -> SystemWindow. - #selector -> #sendTopWindowToBack. - #icon -> #goBottomIcon. - #balloonText -> 'Make the topmost window become the backmost one, and activate the window just beneath it.' - } asDictionary. - { - #label -> 'Move Windows onscreen'. - #object -> #myWorld. - #selector -> #bringWindowsFullOnscreen. - #icon -> #displayIcon. - #balloonText -> 'Make all windows fully visible on the screen' - } asDictionary. - nil. - { - #label -> 'Delete unchanged Windows'. - #object -> #myWorld. - #selector -> #closeUnchangedWindows. - #icon -> #warningIcon. - #balloonText -> 'Deletes all windows that do not have unsaved text edits.' - } asDictionary. - { - #label -> 'Delete non Windows'. - #object -> #myWorld. - #selector -> #deleteNonWindows. - #icon -> #warningIcon. - #balloonText -> 'Deletes all non-window morphs lying on the world.' - } asDictionary. - { - #label -> 'Delete Both of the Above'. - #selector -> #cleanUpWorld. - #icon -> #warningIcon. - #balloonText -> 'Deletes all unchanged windows and also all non-window morphs lying on the world, other than flaps.' - } asDictionary. - }`! ! - -MenuMorph removeSelector: #buildFromDictionaries:! - -MenuMorph removeSelector: #buildFromDictionaries:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3316-BigMenuRefactor-p18-JuanVuletich-2018May06-10h32m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3315] on 6 May 2018 at 11:21:29 am'! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/6/2018 10:51:49'! - add: aString action: aSymbol icon: symbolOrFormOrNil - "Append a menu item with the given label. If the item is selected, it will send the given selector to the default target object." - "Details: Note that the menu item added captures the default target object at the time the item is added; the default target can later be changed before added additional items without affecting the targets of previously added entries. The model is that each entry is like a button that knows everything it needs to perform its action." - - ^(self add: aString - target: defaultTarget - action: aSymbol - argumentList: #()) - setIcon: symbolOrFormOrNil! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/6/2018 10:51:24'! - add: aString action: aSymbol icon: symbolOrFormOrNil enabled: aBoolean - "Append a menu item with the given label. If the item is selected, it will send the given selector to the default target object." - "Details: Note that the menu item added captures the default target object at the time the item is added; the default target can later be changed before added additional items without affecting the targets of previously added entries. The model is that each entry is like a button that knows everything it needs to perform its action." - - (self add: aString - target: defaultTarget - action: aSymbol - argumentList: #()) - setIcon: symbolOrFormOrNil; - isEnabled: aBoolean! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/6/2018 10:56:22'! - add: aString target: aTarget action: aSymbol icon: symbolOrFormOrNil - ^(self add: aString - target: aTarget - action: aSymbol - argumentList: #()) - setIcon: symbolOrFormOrNil! ! -!ChangeSorterWindow methodsFor: 'menu building' stamp: 'jmv 5/6/2018 10:56:43' prior: 50395920! - changeSetMenu - "Set up aMenu to hold commands for the change-set-list pane. This could be for a single or double changeSorter" - - | aMenu isForBaseSystem | - isForBaseSystem _ model changeSet isForBaseSystem. - aMenu _ MenuMorph new defaultTarget: model. - aMenu addTitle: 'Change Set'. - aMenu addStayUpIcons. - - aMenu add: 'File out and remove (o)' action: #fileOutAndRemove icon: #fileOutIcon enabled: isForBaseSystem. - aMenu add: 'File out and keep (k)' action: #fileOutAndKeep icon: #fileOutIcon. - aMenu addLine. - - aMenu add: 'Rename change set (r)' action: #rename icon: #saveAsIcon enabled: isForBaseSystem. - aMenu add: 'Destroy change set (x)' action: #remove icon: #warningIcon enabled: isForBaseSystem. - aMenu addLine. - model currentCanHavePreambleAndPostscript ifTrue: [ - aMenu addLine. - model currentHasPreamble - ifTrue: [ - aMenu add: 'Edit preamble (p)' action: #addPreamble icon: #textEditorIcon. - aMenu add: 'Remove preamble' action: #removePreamble icon: #listRemoveIcon ] - ifFalse: [ - aMenu add: 'Add preamble (p)' action: #addPreamble icon: #listAddIcon ]. - model currentHasPostscript - ifTrue: [ - aMenu add: 'Edit postscript...' action: #editPostscript icon: #textEditorIcon . - aMenu add: 'Remove postscript' action: #removePostscript icon: #listRemoveIcon ] - ifFalse: [ - aMenu add: 'Add postscript...' action: #editPostscript icon: #listAddIcon ]. - ]. - aMenu addLine. - - "CONFLICTS SECTION" - (aMenu add: 'conflicts with other change sets' target: self action: #browseMethodConflicts icon: #emblemImportantIcon) - setBalloonText: 'Browse all methods that occur both in this change set and in at least one other change set.'. - aMenu addLine. - - "CHECKS SECTION" - (aMenu add: 'trim history' action: #trimHistory icon: #clockIcon enabled: isForBaseSystem) - setBalloonText: ' Drops any methods added and then removed, as well as renaming and reorganization of newly-added classes. ', - 'NOTE: can cause confusion if later filed in over an earlier version of these changes'. - - (aMenu add: 'view affected class categories' action: #viewAffectedClassCategories icon: #clockIcon) - setBalloonText: ' Show class categories affected by any contained change'. - - ^ aMenu! ! -!ChangeSorterWindow methodsFor: 'menu building' stamp: 'jmv 5/6/2018 11:20:40' prior: 50395986! - classListMenu - "Fill aMenu with items appropriate for the class list" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'class list'. - aMenu addStayUpIcons. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'delete class from change set (d)'. - #object -> #model. - #selector -> #forgetClass. - #icon -> #warningIcon - } asDictionary. - { - #label -> 'remove class from system (x)'. - #object -> #model. - #selector -> #removeClass. - #icon -> #deleteIcon - } asDictionary. - nil. - { - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - nil. - { - #label -> 'inst var refs...'. - #selector -> #browseInstVarRefs. - #icon -> #instanceIcon - } asDictionary. - { - #label -> 'inst var defs...'. - #selector -> #browseInstVarDefs. - #icon -> #instanceIcon - } asDictionary. - { - #label -> 'class var refs...'. - #selector -> #browseClassVarRefs. - #icon -> #classIcon - } asDictionary. - { - #label -> 'class vars'. - #selector -> #browseClassVariables. - #icon -> #classIcon - } asDictionary. - { - #label -> 'class refs (N)'. - #selector -> #browseClassRefs. - #icon -> #classIcon - } asDictionary. - }`. - ^ aMenu! ! -!ChangeSorterWindow methodsFor: 'menu building' stamp: 'jmv 5/6/2018 11:12:18' prior: 50396012! - messageMenu - "Fill aMenu with items appropriate for the message list; could be for a single or double changeSorter" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'message list'. - aMenu addStayUpIcons. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'delete method from changeSet (d)'. - #object -> #model. - #selector -> #forget. - #icon -> #warningIcon - } asDictionary. - nil. - { - #label -> 'remove method from system (x)'. - #object -> #model. - #selector -> #removeMessage. - #icon -> #deleteIcon - } asDictionary. - nil. - { - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #label -> 'browse method (O)'. - #selector -> #openSingleMessageBrowser. - #icon -> #scriptIcon - } asDictionary. - { - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - nil. - { - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutMessage. - #icon -> #fileOutIcon - } asDictionary. - nil. - { - #label -> 'senders of... (n)'. - #selector -> #browseSendersOfMessages. - #icon -> #mailForwardIcon - } asDictionary. - { - #label -> 'implementors of... (m)'. - #selector -> #browseMessages. - #icon -> #developmentIcon - } asDictionary. - { - #label -> 'inheritance (i)'. - #selector -> #methodHierarchy. - #icon -> #goDownIcon - } asDictionary. - { - #label -> 'versions (v)'. - #selector -> #browseVersions. - #icon -> #clockIcon - } asDictionary. - }`. - ^ aMenu! ! -!MenuMorph methodsFor: 'accessing' stamp: 'jmv 5/6/2018 09:38:40' prior: 50392553! - addBlankIconsIfNecessary - "If any of my items have an icon, ensure that all do by using anIcon for those that don't" - - | withIcons withoutIcons | - withIcons _ Set new. - withoutIcons _ Set new. - self items do: [ :item | - item hasIcon | item hasMarker - ifTrue: [ withIcons add: item ] - ifFalse: [ withoutIcons add: item ]. - item hasSubMenu ifTrue: [ item subMenu addBlankIconsIfNecessary ]]. -" (withIcons isEmpty or: [ withoutIcons isEmpty ]) ifTrue: [ ^self ]." - withoutIcons do: [ :item | item setBlankIcon ]! ! - -MenuMorph removeSelector: #add:action:enabled:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3317-BigMenuRefactor-p19-JuanVuletich-2018May06-10h33m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3317] on 6 May 2018 at 11:55:36 am'! -!MVCMenuMorph class methodsFor: 'instance creation' stamp: 'jmv 5/6/2018 11:54:04' prior: 16865516! - from: aPopupMenu title: titleStringOrNil - "Answer a MenuMorph constructed from the given PopUpMenu. Used to simulate MVC-style menus in a Morphic-only world." - - | menu items lines selections labelString j emphasis | - menu _ self new. - titleStringOrNil ifNotNil: [ - titleStringOrNil isEmpty ifFalse: [menu addTitle: titleStringOrNil]]. - labelString _ aPopupMenu labelString. - items _ labelString asString lines. - (labelString is: #Text) ifTrue: [ - "Pass along text emphasis if present" - j _ 1. - items _ items collect: [ :item | - j _ labelString asString findString: item startingAt: j. - emphasis _ TextEmphasis new emphasisCode: (labelString emphasisAt: j). - item asText addAttribute: emphasis]]. - lines _ aPopupMenu lineArray. - lines ifNil: [lines _ #()]. - menu cancelValue: 0. - menu defaultTarget: menu. - selections _ (1 to: items size) asArray. - 1 to: items size do: [ :i | - menu add: (items at: i) target: menu action: #selectMVCItem: argument: (selections at: i). - (lines includes: i) ifTrue: [menu addLine]]. - ^ menu -! ! - -MenuMorph removeSelector: #add:selector:argument:! - -MenuMorph removeSelector: #add:selector:argument:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3318-BigMenuRefactor-p20-JuanVuletich-2018May06-11h53m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3318] on 6 May 2018 at 4:50:12 pm'! -!TextEditor methodsFor: 'attributes' stamp: 'jmv 5/6/2018 16:14:40' prior: 16931498! - changeEmphasisOrAlignment - "This is a user command, and generates undo" - - | menuStrings aList reply code align menuList startIndex attribute | - startIndex _ self startIndex. - aList _ #(normal bold italic underlined struckThrough leftFlush centered rightFlush justified). - align _ model actualContents alignmentAt: startIndex. - code _ model actualContents emphasisAt: startIndex. - menuList _ WriteStream on: Array new. - menuList nextPut: (code isZero ifTrue:[''] ifFalse:['']), 'normal'. - menuList nextPutAll: (#(bold italic underlined struckThrough superscript subscript withST80Glyphs) collect: [ :emph | - (code anyMask: (TextEmphasis perform: emph) emphasisCode) - ifTrue: [ '', emph asString ] - ifFalse: [ '', emph asString ]]). - menuList nextPutAll: (#(leftFlush centered rightFlush justified) withIndexCollect: [ :type :i | - align = (i-1) - ifTrue: [ '', type asString ] - ifFalse: [ '', type asString ]]). - menuStrings _ menuList contents. - aList _ #(normal bold italic underlined struckThrough superscript subscript withST80Glyphs leftFlush centered rightFlush justified). - reply _ (SelectionMenu labelList: menuStrings lines: #(1 8) selections: aList) startUpMenu. - reply ifNotNil: [ - (#(leftFlush centered rightFlush justified) includes: reply) - ifTrue: [ - attribute _ TextAlignment perform: reply] - ifFalse: [ - attribute _ TextEmphasis perform: reply]. - ((menuStrings at: (aList indexOf: reply)) beginsWith: '') - ifTrue: [ self unapplyAttributes: {attribute} ] - ifFalse: [ self applyAttribute: attribute ]]. - ^ true! ! -!Preferences class methodsFor: 'menu icons' stamp: 'jmv 5/6/2018 16:43:04' prior: 50391880! - useMenuIcons - - self setPreference: #wantsMenuIcons toValue: true. - Theme current class beCurrent! ! -!Preferences class methodsFor: 'menu icons' stamp: 'jmv 5/6/2018 16:43:10' prior: 50391885! -useNoMenuIcons - - self setPreference: #wantsMenuIcons toValue: false. - Theme current class beCurrent! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/6/2018 16:38:18' prior: 50372203! - bigFonts - "Sets not only fonts but other GUI elements - to fit high resolution or large screens - Preferences bigFonts - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 11) - (setListFontTo: 11) - (setMenuFontTo: 12) - (setWindowTitleFontTo: 14) - (setCodeFontTo: 11) - (setButtonFontTo: 11)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/6/2018 16:38:21' prior: 50372219! - hugeFonts - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences hugeFonts - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 17) - (setListFontTo: 17) - (setMenuFontTo: 17) - (setWindowTitleFontTo: 22) - (setCodeFontTo: 17) - (setButtonFontTo: 17)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/6/2018 16:38:23' prior: 50372235! - smallFonts - "Sets not only fonts but other GUI elements - to fit low resolution or small screens - Preferences smallFonts - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 8) - (setListFontTo: 8) - (setMenuFontTo: 8) - (setWindowTitleFontTo: 11) - (setCodeFontTo: 8) - (setButtonFontTo: 8)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/6/2018 16:38:26' prior: 50372251! - standardFonts - "Sets not only fonts but other GUI elements - to fit regular resolution and size screens - Preferences standardFonts - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 9) - (setListFontTo: 9) - (setMenuFontTo: 10) - (setWindowTitleFontTo: 12) - (setCodeFontTo: 9) - (setButtonFontTo: 9)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/6/2018 16:38:28' prior: 50372267! - tinyFonts - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences tinyFonts - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 7) - (setListFontTo: 5) - (setMenuFontTo: 5) - (setWindowTitleFontTo: 7) - (setCodeFontTo: 5) - (setButtonFontTo: 5)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/6/2018 16:38:30' prior: 50372283! - veryBigFonts - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences veryBigFonts - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 14) - (setListFontTo: 14) - (setMenuFontTo: 14) - (setWindowTitleFontTo: 17) - (setCodeFontTo: 14) - (setButtonFontTo: 14)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/6/2018 16:38:32' prior: 50372299! - verySmallFonts - "Sets not only fonts but other GUI elements - to fit low resolution or small screens - Preferences verySmallFonts - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 8) - (setListFontTo: 7) - (setMenuFontTo: 7) - (setWindowTitleFontTo: 9) - (setCodeFontTo: 7) - (setButtonFontTo: 7)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!TheWorldMenu methodsFor: 'commands' stamp: 'jmv 5/6/2018 16:04:24' prior: 16934722! - startMessageTally - "Tally on all the processes in the system, and not only the UI" - - | d | - (self confirm: 'MessageTally all the processes in -the system, until the mouse pointer -goes to the top of the screen') ifTrue: [ - [ - d _ Delay forMilliseconds: 100. - AndreasSystemProfiler spyAllOn: [ - [Sensor peekMousePt y > 10] whileTrue: [d wait]] - ] forkAt: Processor userInterruptPriority - ]! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/6/2018 16:07:49' prior: 50396888! - debugMenu - - ^ (self menu: 'Debug...') - addItemsFromDictionaries: `{ - { - #label -> 'Inspect World'. - #object -> #myWorld. - #selector -> #inspect. - #icon -> #inspectIcon. - } asDictionary. - { - #label -> 'Explore World'. - #object -> #myWorld. - #selector -> #explore. - #icon -> #exploreIcon. - } asDictionary. - { - #label -> 'MessageTally all Processes'. - #selector -> #startMessageTally. - #icon -> #systemMonitorIcon. - } asDictionary. - nil. - { - #label -> 'Start drawing all again'. - #object -> #myWorld. - #selector -> #removeAllKnownFailing. - #icon -> #graphicsIcon. - } asDictionary. - { - #label -> 'Start stepping again'. - #object -> #myWorld. - #selector -> #resumeAfterStepError. - #icon -> #mediaPlaybackStartIcon. - } asDictionary. - { - #label -> 'Close all Debuggers'. - #object -> DebuggerWindow. - #selector -> #closeAllDebuggers. - #icon -> #closeIcon. - } asDictionary. - }`! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/6/2018 16:21:32' prior: 50397037! - preferencesMenu - "Build the preferences menu for the world." - - ^ (self menu: 'Preferences...') - addItemsFromDictionaries: `{ - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Font Sizes...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }`! ! -!Theme class methodsFor: 'instance creation' stamp: 'jmv 5/6/2018 16:45:50' prior: 16936855! - beCurrent - self currentTheme: self. - self inform: 'Please close and reopen all windows'! ! -!Theme class methodsFor: 'user interface' stamp: 'jmv 5/6/2018 16:42:00' prior: 16936893! - changeFontSizes - - (MenuMorph new defaultTarget: Preferences) - addTitle: 'Choose a size'; - addStayUpIcons; - add: 'Huge Fonts' action: #hugeFonts; - add: 'Very big Fonts' action: #veryBigFonts; - add: 'Big Fonts' action: #bigFonts; - add: 'Standard Fonts' action: #standardFonts; - add: 'Small Fonts' action: #smallFonts; - add: 'Very small Fonts'action: #verySmallFonts; - add: 'Tiny Fonts'action: #tinyFonts; - popUpInWorld: self runningWorld! ! -!Theme class methodsFor: 'user interface' stamp: 'jmv 5/6/2018 16:43:14' prior: 50392065! - changeIcons - - (MenuMorph new defaultTarget: Preferences) - addTitle: 'Menu Icons'; - addStayUpIcons; - add: 'Use icons for menu entries' action: #useMenuIcons; - add: 'Don''t use icons for menu entries' action: #useNoMenuIcons; - popUpInWorld: self runningWorld! ! -!Theme class methodsFor: 'user interface' stamp: 'jmv 5/6/2018 16:49:26' prior: 16936926! - changeTheme - - | menu | - menu _ MenuMorph new. - menu - addTitle: 'Choose a theme'; - addStayUpIcons. - Theme withAllSubclassesDo: [ :themeClass | - menu add: themeClass name target: themeClass action: #beCurrent ]. - menu popUpInWorld: self runningWorld! ! -!Theme class methodsFor: 'icons by menu' stamp: 'jmv 5/6/2018 16:44:00' prior: 50390828! - addBasicIconsTo: aCollectorCollection - - aCollectorCollection - add: #('save' ) -> #saveIcon; - add: #('change category...' 'rename') -> #saveAsIcon; - add: #('quit') -> #quitIcon; - add: #('inspect it (i)' 'inspect world' 'inspect model' 'inspect morph' - 'inspect owner chain' 'inspect' 'inspect (i)' 'basic inspect' 'message names' 'find message names' 'inspect instances' 'inspect subinstances' 'inspect change set' 'inspect context (c)' 'inspect receiver (i)' 'start CPUWatcher' 'stop CPUWatcher') - -> #inspectIcon; - add: #('explore' 'explore it (I)' 'explore morph' 'explore (I)' 'explore context (C)' 'explore receiver (I)' 'references finder' 'weight explorer' 'explore CompiledMethod') -> #exploreIcon; - add: #('find...(f)' 'find class... (f)' 'find method...' 'show hierarchy' 'show definition' 'show comment' 'filter' 'filter message list...' 'find context... (f)') -> #findIcon; - add: #('add item...' 'new category...' 'create new change set...' 'new change set... (n)' 'add new file') -> #newIcon; - add: #('remove method (x)' 'remove' 'remove class (x)' 'remove method from system (x)' 'remove class from system (x)' 'remove postscript''stop StackSizeWatcher' ) -> #deleteIcon; - add: #('delete method from changeset (d)' 'delete class from change set (d)' 'revert & remove from changes' 'reset variables' 'remove contained in class categories...' 'clear this change set' 'uninstall this change set' 'delete directory...' 'delete' 'start StackSizeWatcher') -> #warningIcon; - add: #('revert to previous version') -> #undoIcon; - add: #('copy to clipboard (c)' 'copy class...' 'copy name to clipboard') -> #copyIcon -! ! -!PopUpMenu methodsFor: 'basic control sequence' stamp: 'jmv 5/6/2018 16:27:31' prior: 16890977! - startUpWithCaption: captionOrNil - "Display the menu, slightly offset from the cursor, - so that a slight tweak is required to confirm any action." - ^ self startUpWithCaption: captionOrNil at: Sensor mousePoint allowKeyboard: Preferences menuKeyboardControl! ! - -PopUpMenu removeSelector: #startUpWithCaption:at:! - -PopUpMenu removeSelector: #startUpWithCaption:at:! - -PopUpMenu removeSelector: #startUpWithoutKeyboard! - -PopUpMenu removeSelector: #startUpWithoutKeyboard! - -TheWorldMenu removeSelector: #changeBackgroundColor! - -TheWorldMenu removeSelector: #changeBackgroundColor! - -TheWorldMenu removeSelector: #setDisplayDepth! - -TheWorldMenu removeSelector: #setDisplayDepth! - -TheWorldMenu removeSelector: #startThenBrowseMessageTally! - -TheWorldMenu removeSelector: #startThenBrowseMessageTally! - -ProgressBarMorph removeSelector: #addCustomMenuItems:hand:! - -ProgressBarMorph removeSelector: #addCustomMenuItems:hand:! - -ProgressBarMorph removeSelector: #changeProgressColor:! - -ProgressBarMorph removeSelector: #changeProgressColor:! - -ProgressBarMorph removeSelector: #changeProgressValue:! - -ProgressBarMorph removeSelector: #changeProgressValue:! - -ProgressBarMorph removeSelector: #progressColor! - -ProgressBarMorph removeSelector: #progressColor! - -ProgressBarMorph removeSelector: #progressColor:! - -ProgressBarMorph removeSelector: #progressColor:! - -Morph removeSelector: #changeColorTarget:selector:originalColor:hand:! - -Morph removeSelector: #changeColorTarget:selector:originalColor:hand:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3319-BigMenuRefactor-p21-JuanVuletich-2018May06-15h53m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3293] on 10 May 2018 at 8:53:39 pm'! -!ColorForm class methodsFor: 'as yet unclassified' stamp: 'jmv 5/10/2018 20:52:39'! - extent: aPoint - "Native depth" - - ^self extent: aPoint depth: (Smalltalk isLittleEndian ifTrue: [ -8 ] ifFalse: [ 8 ])! ! -!Color class methodsFor: 'class initialization' stamp: 'jmv 5/10/2018 20:43:18' prior: 50386360! - initializeIndexedColors - "Build an array of colors corresponding to the fixed colormap used - for display depths of 1, 2, 4, or 8 bits." - " - Color initializeIndexedColors - " - " -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: (Color r: 1 g: 0 b: 0); display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: (Color r: 0 g: 1 b: 0); display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: (Color r: 0 g: 0 b: 1); display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: (Color r: 0.5 g: 0.5 b: 0.5); display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: Color blue; display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: Color green; display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: Color red; display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: Color cyan; display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: Color yellow; display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: Color magenta; display. - " - - | a index grayVal | - a _ Array new: 256. - - "1-bit colors (monochrome)" - a at: 1 put: `Color r: 1.0 g: 1.0 b: 1.0`. "white or transparent" - a at: 2 put: `Color r: 0.0 g: 0.0 b: 0.0`. "black" - - "additional colors for 2-bit color" - a at: 3 put: `Color r: 1.0 g: 1.0 b: 1.0`. "opaque white" - a at: 4 put: `Color r: 0.5 g: 0.5 b: 0.5`. "1/2 gray" - - "additional colors for 4-bit color" - a at: 5 put: Color red. - a at: 6 put: Color green. - a at: 7 put: Color blue. - a at: 8 put: Color cyan. - a at: 9 put: Color yellow. - a at: 10 put: Color magenta. - - a at: 11 put: `Color r: 0.125 g: 0.125 b: 0.125`. "1/8 gray" - a at: 12 put: `Color r: 0.25 g: 0.25 b: 0.25`. "2/8 gray" - a at: 13 put: `Color r: 0.375 g: 0.375 b: 0.375`. "3/8 gray" - a at: 14 put: `Color r: 0.625 g: 0.625 b: 0.625`. "5/8 gray" - a at: 15 put: `Color r: 0.75 g: 0.75 b: 0.75`. "6/8 gray" - a at: 16 put: `Color r: 0.875 g: 0.875 b: 0.875`. "7/8 gray" - - "additional colors for 8-bit color" - "24 more shades of gray (1/32 increments but not repeating 1/8 increments)" - index _ 17. - 1 to: 31 do: [:v | - (v \\ 4) = 0 ifFalse: [ - grayVal _ v / 32.0. - a at: index put: (Color r: grayVal g: grayVal b: grayVal). - index _ index + 1]]. - - "The remainder of color table defines a color cube with six steps - for each primary color. Note that the corners of this cube may repeat - previous colors, but this simplifies the mapping between RGB colors - and color map indices. This color cube spans indices 40 through 255 - (indices 41-256 in this 1-based array)." - 0 to: 5 do: [:r | - 0 to: 5 do: [:g | - 0 to: 5 do: [:b | - index _ 41 + ((36 * r) + (6 * b) + g). - index > 256 ifTrue: [ - self error: 'index out of range in color table compuation']. - a at: index put: (Color r: r g: g b: b range: 5)]]]. - - IndexedColors _ a. -! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - Color initializeIndexedColors! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3320-ColorForm-fix-JuanVuletich-2018May10-20h43m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3319] on 13 May 2018 at 3:03:58 pm'! -!BrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/7/2018 18:53:59' prior: 50396209! - classListMenu - "Set up the menu to apply to the receiver's class list, honoring the #shifted boolean" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Class List'. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - nil. - { - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutClass. - #icon -> #fileOutIcon - } asDictionary. - nil. - { - #label -> 'show hierarchy'. - #object -> #model. - #selector -> #hierarchy. - #icon -> #findIcon - } asDictionary. - { - #label -> 'show definition'. - #object -> #model. - #selector -> #editClass. - #icon -> #findIcon - } asDictionary. - { - #label -> 'show comment'. - #object -> #model. - #selector -> #editComment. - #icon -> #findIcon - } asDictionary. - nil. - { - #label -> 'inst var refs...'. - #selector -> #browseInstVarRefs. - #icon -> #instanceIcon - } asDictionary. - { - #label -> 'inst var defs...'. - #selector -> #browseInstVarDefs. - #icon -> #instanceIcon - } asDictionary. - nil. - { - #label -> 'class var refs...'. - #selector -> #browseClassVarRefs. - #icon -> #classIcon - } asDictionary. - { - #label -> 'class vars'. - #selector -> #browseClassVariables. - #icon -> #classIcon - } asDictionary. - { - #label -> 'class refs (N)'. - #selector -> #browseClassRefs. - #icon -> #classIcon - } asDictionary. - nil. - { - #label -> 'rename class ...'. - #object -> #model. - #selector -> #renameClass. - #icon -> #saveAsIcon - } asDictionary. - { - #label -> 'copy class...'. - #object -> #model. - #selector -> #copyClass. - #icon -> #copyIcon - } asDictionary. - { - #label -> 'remove class (x)'. - #object -> #model. - #selector -> #removeClass. - #icon -> #deleteIcon - } asDictionary. - nil. - { - #label -> 'Run tests (t)'. - #object -> #model. - #selector -> #runClassTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #label -> 'more...'. - #selector -> #offerClassListMenu2. - #icon -> #listAddIcon - } asDictionary. - }`. - ^ aMenu! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/7/2018 18:42:05' prior: 50396111! - classListMenu2 - "Set up the menu to apply to the receiver's class list when the shift key is down" - - | aMenu | - aMenu := MenuMorph new defaultTarget: self. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'unsent methods'. - #selector -> #browseUnusedMethods. - #icon -> #junkIcon. - #balloonText -> 'browse all methods defined by this class that have no senders' - } asDictionary. - { - #label -> 'unreferenced inst vars'. - #selector -> #showUnreferencedInstVars. - #icon -> #junkIcon. - #balloonText -> 'show a list of all instance variables that are not referenced in methods' - } asDictionary. - { - #label -> 'unreferenced class vars'. - #selector -> #showUnreferencedClassVars. - #icon -> #junkIcon. - #balloonText -> 'show a list of all class variables that are not referenced in methods' - } asDictionary. - { - #label -> 'subclass template'. - #object -> #model. - #selector -> #makeNewSubclass. - #icon -> #classIcon. - #balloonText -> 'put a template into the code pane for defining of a subclass of this class' - } asDictionary. - nil. - { - #label -> 'sample instance'. - #selector -> #makeSampleInstance. - #icon -> #instanceIcon. - #balloonText -> 'give me a sample instance of this class, if possible' - } asDictionary. - { - #label -> 'inspect instances'. - #selector -> #inspectInstances. - #icon -> #inspectIcon. - #balloonText -> 'open an inspector on all the extant instances of this class' - } asDictionary. - { - #label -> 'inspect subinstances'. - #selector -> #inspectSubInstances. - #icon -> #inspectIcon. - #balloonText -> 'open an inspector on all the extant instances of this class and of all of its subclasses' - } asDictionary. - nil. - { - #label -> 'create inst var accessors'. - #object -> #model. - #selector -> #createInstVarAccessors. - #icon -> #sendReceiveIcon. - #balloonText -> 'compile instance-variable access methods for any instance variables that do not yet have them' - } asDictionary. - nil. - { - #label -> 'more...'. - #selector -> #offerClassListMenu. - #icon -> #listAddIcon. - #balloonText -> 'return to the standard class-list menu' - } asDictionary. - }`. - ^ aMenu! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/7/2018 18:59:39' prior: 50338703! - messageCategoryMenu - - | aMenu | - aMenu _ MenuMorph new defaultTarget: model. "All the options are for the model." - aMenu addTitle: 'Message Category'. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'fileOut'. - #selector -> #fileOutMessageCategories. - #icon -> #fileOutIcon - } asDictionary. - nil. - { - #label -> 'reorganize'. - #selector -> #editMessageCategories. - #icon -> #sendReceiveIcon - } asDictionary. - { - #label -> 'alphabetize'. - #selector -> #alphabetizeMessageCategories. - #icon -> #fontXGenericIcon - } asDictionary. - { - #label -> 'remove empty categories'. - #selector -> #removeEmptyCategories. - #icon -> #listRemoveIcon - } asDictionary. - { - #label -> 'categorize all uncategorized'. - #selector -> #categorizeAllUncategorizedMethods. - #icon -> #packageIcon - } asDictionary. - { - #label -> 'new category...'. - #selector -> #addCategory. - #icon -> #newIcon - } asDictionary. - nil. - { - #label -> 'rename...'. - #selector -> #renameCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #label -> 'remove'. - #selector -> #removeMessageCategory. - #icon -> #deleteIcon - } asDictionary. - nil. - { - #label -> 'Run tests'. - #selector -> #runMessageCategoryTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - }`. - ^ aMenu! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/7/2018 20:10:56' prior: 50396243! - messageListMenu - "Answer the message-list menu" - "Changed by emm to include menu-item for breakpoints" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Message List'. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'what to show...'. - #selector -> #offerWhatToShowMenu. - #icon -> #preferencesIcon - } asDictionary. - { - #label -> 'toggle break on entry'. - #object -> #model. - #selector -> #toggleBreakOnEntry. - #icon -> #debugIcon - } asDictionary. - nil. - { - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #label -> 'browse method (O)'. - #selector -> #openSingleMessageBrowser. - #icon -> #scriptIcon - } asDictionary. - { - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - nil. - { - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutMessage. - #icon -> #fileOutIcon - } asDictionary. - { - #label -> 'explore CompiledMethod'. - #object -> #model. - #selector -> #exploreCompiledMethod. - #icon -> #exploreIcon - } asDictionary. - nil. - { - #label -> 'senders of... (n)'. - #selector -> #browseSendersOfMessages. - #icon -> #mailForwardIcon - } asDictionary. - { - #label -> 'implementors of... (m)'. - #selector -> #browseMessages. - #icon -> #developmentIcon - } asDictionary. - { - #label -> 'inheritance (i)'. - #selector -> #methodHierarchy. - #icon -> #goDownIcon - } asDictionary. - { - #label -> 'versions (v)'. - #selector -> #browseVersions. - #icon -> #clockIcon - } asDictionary. - nil. - { - #label -> 'inst var refs...'. - #selector -> #browseInstVarRefs. - #icon -> #instanceIcon - } asDictionary. - { - #label -> 'inst var defs...'. - #selector -> #browseInstVarDefs. - #icon -> #instanceIcon - } asDictionary. - { - #label -> 'class var refs...'. - #selector -> #browseClassVarRefs. - #icon -> #classIcon - } asDictionary. - { - #label -> 'class variables'. - #selector -> #browseClassVariables. - #icon -> #classIcon - } asDictionary. - { - #label -> 'class refs (N)'. - #selector -> #browseClassRefs. - #icon -> #classIcon - } asDictionary. - nil. - { - #label -> 'remove method (x)'. - #object -> #model. - #selector -> #removeMessage. - #icon -> #deleteIcon - } asDictionary. - { - #label -> 'Run test (t)'. - #object -> #model. - #selector -> #runMethodTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #label -> 'Debug test (r)'. - #object -> #model. - #selector -> #debugMethodTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - nil. - { - #label -> 'more...'. - #selector -> #openMessageListMenu2. - #icon -> #listAddIcon - } asDictionary. - }`. - ^ aMenu! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/7/2018 20:25:02' prior: 50396156! - messageListMenu2 - "Fill aMenu with the items appropriate when the shift key is held down" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Message List'. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'toggle diffing (D)'. - #object -> #model. - #selector -> #toggleDiffing. - #icon -> #switchIcon - } asDictionary. - { - #label -> 'implementors of sent messages'. - #selector -> #browseAllMessages. - #icon -> #developmentIcon - } asDictionary. - nil. - { - #label -> 'local senders of...'. - #selector -> #browseLocalSendersOfMessages. - #icon -> #mailForwardIcon - } asDictionary. - { - #label -> 'local implementors of...'. - #selector -> #browseLocalImplementors. - #icon -> #classIcon - } asDictionary. - nil. - { - #label -> 'spawn sub-protocol'. - #selector -> #browseProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - { - #label -> 'spawn full protocol'. - #selector -> #browseFullProtocol. - #icon -> #speadsheetTemplateIcon - } asDictionary. - nil. - { - #label -> 'sample instance'. - #selector -> #makeSampleInstance. - #icon -> #instanceIcon - } asDictionary. - { - #label -> 'inspect instances'. - #selector -> #inspectInstances. - #icon -> #inspectIcon - } asDictionary. - { - #label -> 'inspect subinstances'. - #selector -> #inspectSubInstances. - #icon -> #inspectIcon - } asDictionary. - }`. - - self addExtraMenu2ItemsTo: aMenu. - aMenu add: 'change category...' target: model action: #changeCategory icon: #saveAsIcon. - - model canShowMultipleMessageCategories ifTrue: [ - aMenu add: 'show category (C)' target: model action: #showHomeCategory icon: #packageIcon ]. - aMenu - add: 'change sets with this method' action: #findMethodInChangeSets icon: #changesIcon; - add: 'revert to previous version' target: model action: #revertToPreviousVersion icon: #undoIcon; - addLine; - add: 'more...' action: #openMessageListMenu icon: #listAddIcon. - ^ aMenu! ! -!CodeFileBrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/7/2018 18:53:57' prior: 16809604! - classListMenu - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Class List'. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'definition'. - #object -> #model. - #selector -> #editClass. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'comment'. - #object -> #model. - #selector -> #editComment. - #icon -> #editFindReplaceIcon - } asDictionary. - nil. - { - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'class refs (N)'. - #selector -> #browseClassRefs. - #icon -> #classIcon - } asDictionary. - nil. - { - #label -> 'fileIn'. - #object -> #model. - #selector -> #fileInClass. - #icon -> #updateIcon - } asDictionary. - { - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutClass. - #icon -> #fileOutIcon - } asDictionary. - nil. - { - #label -> 'rename...'. - #object -> #model. - #selector -> #renameClass. - #icon -> #saveAsIcon - } asDictionary. - { - #label -> 'remove'. - #object -> #model. - #selector -> #removeClass. - #icon -> #listRemoveIcon - } asDictionary. - nil. - { - #label -> 'remove existing'. - #object -> #model. - #selector -> #removeUnmodifiedCategories. - #icon -> #deleteIcon - } asDictionary. - }`. - ^aMenu! ! -!CodeFileBrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/7/2018 19:03:29' prior: 16809635! - messageCategoryMenu - - | aMenu | - aMenu _ MenuMorph new defaultTarget: model. "All the options are for the model." - aMenu addTitle: 'Message Category'. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'fileIn'. - #selector -> #fileInMessageCategories. - #icon -> #updateIcon - } asDictionary. - { - #label -> 'fileOut'. - #selector -> #fileOutMessageCategories. - #icon -> #fileOutIcon - } asDictionary. - nil. - { - #label -> 'reorganize'. - #selector -> #editMessageCategories. - #icon -> #sendReceiveIcon - } asDictionary. - nil. - { - #label -> 'add item...'. - #selector -> #addCategory. - #icon -> #newIcon - } asDictionary. - nil. - { - #label -> 'rename...'. - #selector -> #renameCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #label -> 'remove'. - #selector -> #removeMessageCategory. - #icon -> #listRemoveIcon - } asDictionary. - nil. - { - #label -> 'remove existing'. - #selector -> #removeUnmodifiedMethods. - #icon -> #deleteIcon - } asDictionary. - }`. - ^ aMenu! ! -!CodeFileBrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/7/2018 20:10:06' prior: 16809652! - messageListMenu - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Message List'. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'fileIn'. - #object -> #model. - #selector -> #fileInMessage. - #icon -> #updateIcon - } asDictionary. - { - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutMessage. - #icon -> #fileOutIcon - } asDictionary. - nil. - { - #label -> 'senders (n)'. - #selector -> #browseSenders. - #icon -> #mailForwardIcon - } asDictionary. - { - #label -> 'implementors (m)'. - #selector -> #browseImplementors. - #icon -> #developmentIcon - } asDictionary. - { - #label -> 'method inheritance (h)'. - #selector -> #methodHierarchy. - #icon -> #goDownIcon - } asDictionary. - { - #label -> 'versions (v)'. - #selector -> #browseVersions. - #icon -> #clockIcon - } asDictionary. - nil. - { - #label -> 'remove method (x)'. - #object -> #model. - #selector -> #removeMessage. - #icon -> #deleteIcon - } asDictionary. - }`. - ^ aMenu! ! -!MessageSetWindow methodsFor: 'menu building' stamp: 'jmv 5/7/2018 20:22:14' prior: 50396195! - addExtraMenu2ItemsTo: aMenu - "The shifted selector-list menu is being built. Add items specific to MessageSet" - - model growable ifTrue: [ - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'remove from this browser'. - #object -> #model. - #selector -> #removeMessageFromBrowser. - #icon -> #listRemoveIcon - } asDictionary. - { - #label -> 'filter message list...'. - #selector -> #filterMessageList. - #icon -> #findIcon - } asDictionary. - }`. - ]. - aMenu add: 'sort by date' target: model action: #sortByDate icon: #dateIcon! ! -!ChangeSorterWindow methodsFor: 'menu building' stamp: 'jmv 5/7/2018 18:53:45' prior: 50397417! - classListMenu - "Fill aMenu with items appropriate for the class list" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Class List'. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'delete class from change set (d)'. - #object -> #model. - #selector -> #forgetClass. - #icon -> #warningIcon - } asDictionary. - { - #label -> 'remove class from system (x)'. - #object -> #model. - #selector -> #removeClass. - #icon -> #deleteIcon - } asDictionary. - nil. - { - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - nil. - { - #label -> 'inst var refs...'. - #selector -> #browseInstVarRefs. - #icon -> #instanceIcon - } asDictionary. - { - #label -> 'inst var defs...'. - #selector -> #browseInstVarDefs. - #icon -> #instanceIcon - } asDictionary. - { - #label -> 'class var refs...'. - #selector -> #browseClassVarRefs. - #icon -> #classIcon - } asDictionary. - { - #label -> 'class vars'. - #selector -> #browseClassVariables. - #icon -> #classIcon - } asDictionary. - { - #label -> 'class refs (N)'. - #selector -> #browseClassRefs. - #icon -> #classIcon - } asDictionary. - }`. - ^ aMenu! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3321-BigMenuRefactor-p22-JuanVuletich-2018May13-14h50m-jmv.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3319] on 13 May 2018 at 3:33:06 pm'! -!BrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/13/2018 15:28:48' prior: 16793385! - systemCatSingletonMenu - - | aMenu | - self flag: #renameSystemCategory. "temporarily disabled" - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Class category'. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'find class... (f)'. - #selector -> #findClass. - #icon -> #findIcon - } asDictionary. - nil. - { - #label -> 'browse all'. - #selector -> #browseAllClasses. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'browse'. - #selector -> #openSystemCategoryBrowser. - #icon -> #packageIcon - } asDictionary. - nil. - { - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutSystemCategory. - #icon -> #fileOutIcon - } asDictionary. - nil. - { - #label -> 'update'. - #object -> #model. - #selector -> #updateSystemCategories. - #icon -> #updateIcon - } asDictionary. - { - #label -> 'rename...'. - #object -> #model. - #selector -> #renameSystemCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #label -> 'remove'. - #object -> #model. - #selector -> #removeSystemCategory. - #icon -> #deleteIcon - } asDictionary. - }`. - ^aMenu! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/13/2018 15:32:04' prior: 50338765! - systemCategoryMenu - - | aMenu | - self flag: #renameSystemCategory. "temporarily disabled" - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Class category'. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'find class... (f)'. - #selector -> #findClass. - #icon -> #findIcon - } asDictionary. - { - #label -> 'recent classes... (r)'. - #object -> #model. - #selector -> #recent. - #icon -> #clockIcon - } asDictionary. - nil. - { - #label -> 'browse all'. - #selector -> #browseAllClasses. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'browse'. - #selector -> #openSystemCategoryBrowser. - #icon -> #packageIcon - } asDictionary. - nil. - { - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutSystemCategory. - #icon -> #fileOutIcon - } asDictionary. - nil. - { - #label -> 'reorganize'. - #object -> #model. - #selector -> #editSystemCategories. - #icon -> #sendReceiveIcon - } asDictionary. - { - #label -> 'alphabetize'. - #object -> #model. - #selector -> #alphabetizeSystemCategories. - #icon -> #fontXGenericIcon - } asDictionary. - nil. - { - #label -> 'update'. - #object -> #model. - #selector -> #updateSystemCategories. - #icon -> #updateIcon - } asDictionary. - { - #label -> 'add item...'. - #object -> #model. - #selector -> #addSystemCategory. - #icon -> #newIcon - } asDictionary. - { - #label -> 'rename...'. - #object -> #model. - #selector -> #renameSystemCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #label -> 'remove'. - #object -> #model. - #selector -> #removeSystemCategory. - #icon -> #deleteIcon - } asDictionary. - nil. - { - #label -> 'move to top'. - #object -> #model. - #selector -> #moveSystemCategoryTop. - #icon -> #goTopIcon - } asDictionary. - { - #label -> 'move up'. - #object -> #model. - #selector -> #moveSystemCategoryUp. - #icon -> #goUpIcon - } asDictionary. - { - #label -> 'move down'. - #object -> #model. - #selector -> #moveSystemCategoryDown. - #icon -> #goDownIcon - } asDictionary. - { - #label -> 'move to bottom'. - #object -> #model. - #selector -> #moveSystemCategoryBottom. - #icon -> #goBottomIcon - } asDictionary. - nil. - { - #label -> 'Run tests (t)'. - #object -> #model. - #selector -> #runSystemCategoryTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - }`. - ^aMenu! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3322-BigMenuRefactor-p23-JuanVuletich-2018May13-15h03m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3319] on 13 May 2018 at 4:26:25 pm'! -!CodeFileBrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/13/2018 15:58:47' prior: 16809623! - codeFileListMenu - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Code File'. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'find class... (f)'. - #selector -> #findClass - } asDictionary. - nil. - { - #label -> 'fileIn'. - #object -> #model. - #selector -> #fileIn - } asDictionary. - { - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOut - } asDictionary. - { - #label -> 'remove existing'. - #object -> #model. - #selector -> #removeUnmodifiedClasses - } asDictionary. - }`. - ^ aMenu! ! -!ChangeListWindow methodsFor: 'menu building' stamp: 'jmv 5/13/2018 15:53:28' prior: 50344451! - listMenu - "Fill aMenu up so that it comprises the primary changelist-browser menu" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Change List'. - aMenu addStayUpIcons. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'fileIn selections'. - #object -> #model. - #selector -> #fileInSelections. - #balloonText -> 'import the selected items into the image'. - } asDictionary. - { - #label -> 'fileOut selections... '. - #object -> #model. - #selector -> #fileOutSelections. - #balloonText -> 'create a new file containing the selected items'. - } asDictionary. - { - #label -> 'fileOut current version of selections...'. - #object -> #model. - #selector -> #fileOutCurrentVersionsOfSelections. - #balloonText -> 'create a new file containing the current (in-image) counterparts of the selected methods'. - } asDictionary. - nil. - { - #label -> 'compare to current'. - #object -> #model. - #selector -> #compareToCurrentVersion. - #balloonText -> 'open a separate window which shows the text differences between the on-file version and the in-image version.'. - } asDictionary. - { - #label -> 'toggle diffing (D)'. - #object -> #model. - #selector -> #toggleDiffing. - #balloonText -> 'start or stop showing diffs in the code pane.'. - } asDictionary. - nil. - { - #label -> 'select new methods'. - #object -> #model. - #selector -> #selectNewMethods. - #balloonText -> 'select methods in the file that do not currently exist in the image'. - } asDictionary. - { - #label -> 'select changes for absent classes'. - #object -> #model. - #selector -> #selectAllForAbsentClasses. - #balloonText -> 'select methods in the file for classes that are not defined in the image'. - } asDictionary. - { - #label -> 'select all changes for this class'. - #object -> #model. - #selector -> #selectAllForThisClass. - #balloonText -> 'select all methods in the file that belong to the currently-selected class'. - } asDictionary. - { - #label -> 'select unchanged methods'. - #object -> #model. - #selector -> #selectUnchangedMethods. - #balloonText -> 'select methods in the file whose in-image versions are the same as their in-file counterparts'. - } asDictionary. - { - #label -> 'select methods equivalent to current'. - #object -> #model. - #selector -> #selectEquivalentMethods. - #balloonText -> 'select methods in the file whose in-image versions have the same behavior as their in-file counterparts'. - } asDictionary. - { - #label -> 'select methods older than current'. - #object -> #model. - #selector -> #selectMethodsOlderThanCurrent. - #balloonText -> 'select methods in the file that are older than the one currently in the image'. - } asDictionary. - { - #label -> 'select removals of sent methods'. - #object -> #model. - #selector -> #selectRemovalsOfSent. - #balloonText -> 'select all method removals of methods that have some sender in the image'. - } asDictionary. - nil. - { - #label -> 'select all (a)'. - #object -> #model. - #selector -> #selectAll. - #balloonText -> 'select all the items in the list'. - } asDictionary. - { - #label -> 'deselect all'. - #object -> #model. - #selector -> #deselectAll. - #balloonText -> 'deselect all the items in the list'. - } asDictionary. - { - #label -> 'invert selections'. - #object -> #model. - #selector -> #invertSelections. - #balloonText -> 'select every item that is not currently selected, and deselect every item that *is* currently selected'. - } asDictionary. - nil. - { - #label -> 'browse class and method'. - #selector -> #browseMethodFull. - #balloonText -> 'open a full browser showing the selected method'. - } asDictionary. - { - #label -> 'browse all versions of single selection'. - #selector -> #browseVersions. - #balloonText -> 'open a version browser showing the versions of the currently selected method'. - } asDictionary. - { - #label -> 'browse current versions of selections'. - #selector -> #browseCurrentVersionsOfSelections. - #balloonText -> 'open a message-list browser showing the current (in-image) counterparts of the selected methods'. - } asDictionary. - { - #label -> 'destroy current methods of selections'. - #object -> #model. - #selector -> #destroyCurrentCodeOfSelections. - #balloonText -> 'remove (*destroy*) the in-image counterparts of all selected methods'. - } asDictionary. - nil. - { - #label -> 'remove doIts'. - #object -> #model. - #selector -> #removeDoIts. - #balloonText -> 'remove all items that are doIts rather than definitions'. - } asDictionary. - { - #label -> 'remove older versions'. - #object -> #model. - #selector -> #removeOlderMethodVersions. - #balloonText -> 'remove all but the most recent versions of methods in the list'. - } asDictionary. - { - #label -> 'remove up-to-date versions'. - #object -> #model. - #selector -> #removeUpToDate. - #balloonText -> 'remove all items whose code is the same as the counterpart in-image code'. - } asDictionary. - { - #label -> 'remove empty class comments'. - #object -> #model. - #selector -> #removeEmptyClassComments. - #balloonText -> 'remove all empty class comments'. - } asDictionary. - { - #label -> 'remove selected items'. - #object -> #model. - #selector -> #removeSelections. - #balloonText -> 'remove the selected items from the change-list'. - } asDictionary. - { - #label -> 'remove unselected items'. - #object -> #model. - #selector -> #removeNonSelections. - #balloonText -> 'remove all the items not currently selected from the change-list'. - } asDictionary. - }`. - ^ aMenu! ! -!DebuggerWindow methodsFor: 'menu building' stamp: 'jmv 5/13/2018 16:02:25' prior: 16831143! - contextFieldListMenu - "Arm the supplied menu with items for the field-list of the receiver" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'explore (I)'. - #selector -> #exploreContextSelection - } asDictionary. - nil. - { - #label -> 'browse hierarchy (h)'. - #selector -> #contextClassHierarchy - } asDictionary. - }`. - ^ aMenu! ! -!DebuggerWindow methodsFor: 'menu building' stamp: 'jmv 5/13/2018 16:05:17' prior: 50391627! - contextStackMenu - "Set up the menu appropriately for the context-stack-list, either shifted or unshifted as per the parameter provided" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'fullStack (f)'. - #selector -> #fullStack - } asDictionary. - { - #label -> 'restart (r)'. - #selector -> #restarl - } asDictionary. - { - #label -> 'proceed (p)'. - #selector -> #proceed - } asDictionary. - { - #label -> 'step (t)'. - #selector -> #doStep - } asDictionary. - { - #label -> 'step through (T)'. - #selector -> #stepIntoBlock - } asDictionary. - { - #label -> 'send (e)'. - #selector -> #send - } asDictionary. - { - #label -> 'where (w)'. - #selector -> #where - } asDictionary. - { - #label -> 'peel to first like this'. - #selector -> #peelToFirst - } asDictionary. - nil. - { - #label -> 'return entered value'. - #selector -> #returnValue - } asDictionary. - { - #label -> 'toggle break on entry'. - #object -> #model. - #selector -> #toggleBreakOnEntry - } asDictionary. - }`. - ^aMenu! ! -!DebuggerWindow methodsFor: 'menu building' stamp: 'jmv 5/13/2018 16:01:41' prior: 16831180! - receiverFieldListMenu - "Arm the supplied menu with items for the field-list of the receiver" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'explore (I)'. - #selector -> #exploreReceiverSelection - } asDictionary. - nil. - { - #label -> 'browse hierarchy (h)'. - #selector -> #receiverClassHierarchy - } asDictionary. - }`. - ^ aMenu! ! -!FileListWindow methodsFor: 'menu building' stamp: 'jmv 5/13/2018 16:07:20' prior: 16843430! - volumeMenu - | aMenu | - aMenu _ MenuMorph new defaultTarget: model. - aMenu - add: 'delete directory...' - action: #deleteDirectory. - ^ aMenu! ! -!InspectorWindow methodsFor: 'menu building' stamp: 'jmv 5/13/2018 16:19:22' prior: 50376358! - fieldListMenu - "Arm the supplied menu with items for the field-list of the receiver" - - | aMenu object | - aMenu _ MenuMorph new defaultTarget: self. - - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'inspect (i)'. - #selector -> #inspectSelection. - #icon -> #inspectIcon - } asDictionary. - { - #label -> 'explore (I)'. - #selector -> #exploreSelection. - #icon -> #exploreIcon - } asDictionary. - { - #label -> 'copy to clipboard (c)'. - #selector -> #copySelectionToClipboard. - #icon -> #copyIcon - } asDictionary. - { - #label -> 'basic inspect'. - #selector -> #inspectBasic. - #icon -> #inspectIcon - } asDictionary. - { - #label -> 'references finder'. - #selector -> #openReferencesFinder. - #icon -> #exploreIcon - } asDictionary. - { - #label -> 'weight explorer'. - #selector -> #openWeightExplorer. - #icon -> #exploreIcon - } asDictionary. - }`. - - object _ model object. - (object is: #Dictionary) ifTrue: [ - aMenu addItemsFromDictionaries: `{ - nil. - { - #label -> 'senders of this key'. - #selector -> #sendersOfSelectedKey. - } asDictionary. - { - #label -> 'add key'. - #selector -> #addEntry. - } asDictionary. - { - #label -> 'rename key'. - #selector -> #renameEntry. - } asDictionary. - { - #label -> 'remove'. - #object -> #model. - #selector -> #removeSelection. - } asDictionary. - }` ] - - ifFalse: [ (object is: #Set) ifTrue: [ - aMenu addItemsFromDictionaries: `{ - nil. - { - #label -> 'remove'. - #object -> #model. - #selector -> #removeSelection. - #icon -> #listRemoveIcon - } asDictionary. - }` ]]. - - aMenu - addItemsFromDictionaries: `{ - nil. - { - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - }`. - ^ aMenu! ! -!ObjectExplorerWindow methodsFor: 'building menus' stamp: 'jmv 5/13/2018 16:25:51' prior: 50393093! - genericMenu - "Borrow a menu from my inspector" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - model getCurrentSelection - ifNil: [ - aMenu - add: '*nothing selected*' - target: self - action: #yourself] - ifNotNil: [ - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'inspect (i)'. - #selector -> #inspectSelection. - #icon -> #inspectIcon - } asDictionary. - { - #label -> 'explore (I)'. - #selector -> #exploreSelection. - #icon -> #exploreIcon - } asDictionary. - { - #label -> 'copy to clipboard (c)'. - #selector -> #copySelectionToClipboard. - #icon -> #copyIcon - } asDictionary. - { - #label -> 'basic inspect'. - #selector -> #inspectBasic. - #icon -> #inspectIcon - } asDictionary. - { - #label -> 'references finder'. - #selector -> #openReferencesFinder. - #icon -> #exploreIcon - } asDictionary. - { - #label -> 'weight explorer'. - #selector -> #openWeightExplorer. - #icon -> #exploreIcon - } asDictionary. - nil. - { - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - }`. - aMenu addLine; - add: 'monitor changes' - target: self - action: #monitor: - argument: model getCurrentSelection. - model class == ReferencesExplorer ifTrue: [ - aMenu addLine; - add: 'rescan' - target: self - action: #rescan ]]. - model basicMonitorList isEmptyOrNil - ifFalse: [ - aMenu addLine; - add: 'stop monitoring all' - target: self - action: #stopMonitoring ]. - ^ aMenu! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3323-BigMenuRefactor-p24-JuanVuletich-2018May13-15h33m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3323] on 13 May 2018 at 6:14:25 pm'! -!AbstractFont class methodsFor: 'instance accessing' stamp: 'jmv 5/13/2018 18:14:09'! - availableFonts - ^AvailableFonts! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3324-availableFonts-JuanVuletich-2018May13-18h14m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3323] on 13 May 2018 at 6:53:04 pm'! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 5/13/2018 18:48:20'! - add: aString action: aSymbol balloonText: stringOrText - "Append a menu item with the given label. If the item is selected, it will send the given selector to the default target object." - "Details: Note that the menu item added captures the default target object at the time the item is added; the default target can later be changed before added additional items without affecting the targets of previously added entries. The model is that each entry is like a button that knows everything it needs to perform its action." - - ^(self add: aString - target: defaultTarget - action: aSymbol - argumentList: #()) - setBalloonText: stringOrText! ! -!MessageSetWindow methodsFor: 'menu commands' stamp: 'jmv 5/13/2018 18:52:01' prior: 16870467! - filterMessageList - "Allow the user to refine the list of messages." - - | aMenu | - model messageList size <= 1 - ifTrue: [ ^self inform: 'this is not a propitious filtering situation' ]. - - aMenu _ MenuMorph new defaultTarget: model. - aMenu addTitle: 'Filter by only showing...'. - aMenu addStayUpIcons. - aMenu - add: 'unsent messages' action: #filterToUnsentMessages balloonText: 'filter to show only messages that have no senders'; - addLine; - add: 'messages that send...' action: #filterToSendersOf balloonText: 'filter to show only messages that send a selector I specify'; - add: 'messages that do not send...' action: #filterToNotSendersOf balloonText: 'filter to show only messages that do not send a selector I specify'; - addLine; - add: 'messages whose selector is...' action: #filterToImplementorsOf balloonText: 'filter to show only messages with a given selector I specify'; - add: 'messages whose selector is NOT...' action: #filterToNotImplementorsOf balloonText: 'filter to show only messages whose selector is NOT a seletor I specify'; - addLine; - add: 'messages in any change set' action: #filterToAnyChangeSet balloonText: 'filter to show only messages that occur in at least one change set'; - add: 'messages not in any change set' action: #filterToNotAnyChangeSet balloonText: 'filter to show only messages that do not occur in any change set in the system'; - addLine; - add: 'messages authored by me' action: #filterToCurrentAuthor balloonText: 'filter to show only messages whose authoring stamp has my initials'; - add: 'messages not authored by me' action: #filterToNotCurrentAuthor balloonText: 'filter to show only messages whose authoring stamp does not have my initials'; - addLine; - add: 'messages logged in .changes file' action: #filterToMessagesInChangesFile balloonText: 'filter to show only messages whose latest source code is logged in the .changes file'; - add: 'messages only in .sources file' action: #filterToMessagesInSourcesFile balloonText: 'filter to show only messages whose latest source code is logged in the .sources file'; - addLine; - add: 'messages with prior versions' action: #filterToMessagesWithPriorVersions balloonText: 'filter to show only messages that have at least one prior version'; - add: 'messages without prior versions' action: #filterToMessagesWithoutPriorVersions balloonText: 'filter to show only messages that have no prior versions'; - addLine; - add: 'uncommented messages' action: #filterToUncommentedMethods balloonText: 'filter to show only messages that do not have comments at the beginning'; - add: 'commented messages' action: #filterToCommentedMethods balloonText: 'filter to show only messages that have comments at the beginning'. - aMenu popUpInWorld: self world! ! -!MessageNamesWindow methodsFor: 'menu building' stamp: 'jmv 5/13/2018 18:17:58' prior: 16867824! - selectorListMenu - "Answer the menu associated with the selectorList" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - (aMenu add: 'senders (n)' action: #browseSenders icon: #mailForwardIcon) - setBalloonText: 'browse senders of the chosen selector'. - ^ aMenu! ! -!ProcessBrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/13/2018 18:44:18' prior: 50390021! - processListMenu - | menu rules | - menu _ MenuMorph new defaultTarget: self. - - model selectedProcess - ifNotNil: [ :selectedProcess | - rules _ model class rulesFor: model selectedProcess. - menu - add: 'inspect (i)' action: #inspectProcess icon: #inspectIcon; - add: 'explore (I)' action: #exploreProcess icon: #exploreIcon; - add: 'references finder' action: #openReferencesFinder icon: #exploreIcon. - rules first - ifTrue: [ - menu add: 'terminate (t)' target: model action: #terminateProcess icon: #cancelIcon. - selectedProcess isSuspended - ifTrue: [menu add: 'resume (r)' target: model action: #resumeProcess icon: #mediaPlaybackStartIcon] - ifFalse: [menu add: 'suspend (s)' target: model action: #suspendProcess icon: #chatIcon]]. - rules second - ifTrue: [ - menu - add: 'change priority (p)' action: #changePriority icon: #systemMonitorIcon; - add: 'debug (d)' action: #debugProcess icon: #debugIcon ]. - (selectedProcess suspendingList isKindOf: Semaphore) - ifTrue: [menu add: 'signal Semaphore (S)' target: model action: #signalSemaphore icon: #haloHelpIcon ]. - menu add: 'full stack (k)' target: model action: #moreStack icon: #systemIcon. - menu addLine]. - - menu - add: 'find context... (f)' action: #findContext icon: #findIcon; - add: 'find again (g)' target: model action: #nextContext icon: #systemIcon. - menu addLine. - - isStepping - ifTrue: [ menu add: 'turn off auto-update (a)' action: #toggleAutoUpdate icon: #cancelIcon ] - ifFalse: [ menu add: 'turn on auto-update (a)' action: #toggleAutoUpdate icon: #updateIcon ]. - - menu add: 'update list (u)' target: model action: #updateProcessList icon: #updateIcon. - - menu addLine. - CPUWatcher isMonitoring - ifTrue: [ menu add: 'stop CPUWatcher' action: #stopCPUWatcher icon: #inspectIcon ] - ifFalse: [ menu add: 'start CPUWatcher' action: #startCPUWatcher icon: #inspectIcon ]. - StackSizeWatcher isWatching - ifTrue: [ menu add: 'stop StackSizeWatcher' action: #stopStackSizeWatcher icon: #inspectIcon ] - ifFalse: [ menu add: 'start StackSizeWatcher' action: #startStackSizeWatcher icon: #inspectIcon ]. - - ^ menu! ! -!ProcessBrowserWindow methodsFor: 'menu building' stamp: 'jmv 5/13/2018 18:25:38' prior: 16895392! - stackListMenu - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - model selectedContext - ifNil: [^ aMenu]. - aMenu - add: 'inspect context (c)' action: #inspectContext icon: #inspectIcon; - add: 'explore context (C)' action: #exploreContext icon: #exploreIcon; - add: 'inspect receiver (i)' action: #inspectReceiver icon: #inspectIcon; - add: 'explore receiver (I)' action: #exploreReceiver icon: #exploreIcon; - add: 'browse (b)' action: #browseContext icon: #editFindReplaceIcon. - ^aMenu! ! -!TranscriptMorph methodsFor: 'menus' stamp: 'jmv 5/13/2018 18:22:44' prior: 16938623! - getMenu - "Set up the menu to apply to the receiver" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - doImmediateUpdates - ifTrue: [ aMenu add: 'Only update in the regular Morphic cycle' action: #doRegularUpdates ] - ifFalse: [ aMenu add: 'Immediately show each entry' action: #doImmediateUpdates ]. - aMenu - addLine; - add: 'Workspace with Contents' action: #editContents; - addLine; - add: 'Clear Transcript' action: #clearInternal; - add: 'Clear Transcript File' action: #clearFile; - add: 'Clear Both' action: #clearAll; - addLine. - Transcript logsToFile - ifTrue: [ aMenu add: 'Stop logging to File' action: #dontLogToFile ] - ifFalse: [ aMenu add: 'Start logging to File' action: #logToFile ]. - ^ aMenu! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3325-BigMenuRefactor-p25-JuanVuletich-2018May13-18h14m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3325] on 13 May 2018 at 7:42:11 pm'! -!SmallFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 5/13/2018 19:25:31'! - profilerFriendlyPrimTimesTwoPower: anInteger - " - This is an example on proper primitive reporting in AndreasSystemProfiler. - See senders. - " - - - ^nil! ! -!SmallFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 5/13/2018 19:25:53'! - profilerFriendlyTimesTwoPower: anInteger - - "This is an example on proper primitive reporting in AndreasSystemProfiler. - It is a reimplementation of #timesTwoPower: in a Profiler friendly way. - - Compare the results of - AndreasSystemProfiler spyOn:[1000000 timesRepeat: [3.14159 timesTwoPower: 10000]]. - and - AndreasSystemProfiler spyOn:[1000000 timesRepeat: [3.14159 profilerFriendlyTimesTwoPower: 10000]]. - - See #profilerFriendlyCall: - " - - | primResult | - primResult _ self profilerFriendlyCall: [ - self profilerFriendlyPrimTimesTwoPower: anInteger ]. - primResult ifNotNil: [ :result | ^result ]. - - "Make sure that (2.0 raisedTo: Integer) can be safely used without overflow - For example: - Float fminNormalized * (2.0 raisedTo: 2000) = Float infinity. - while: - (Float fminNormalized timesTwoPower: 2000) = (2.0 raisedTo: 2000+Float emin)." - anInteger > Float emax ifTrue: [^(self timesTwoPower: Float emax) timesTwoPower: anInteger - Float emax]. - - "In case of gradual underflow, timesTwoPower: is not exact, so greatest care must be taken - because two consecutive timesTwoPower: might differ from a single one" - anInteger < Float emin - ifTrue: - [| deltaToUnderflow | - deltaToUnderflow := Float emin - self exponent max: Float emin. - deltaToUnderflow >= 0 ifTrue: - ["self is already near or past underflow, so don't care, result will be zero" - deltaToUnderflow := Float emin]. - ^(self timesTwoPower: deltaToUnderflow) timesTwoPower: anInteger - deltaToUnderflow]. - - "If (2.0 raisedToInteger: anInteger) fit in a positive SmallInteger, then use faster SmallInteger conversion. - Note that SmallInteger maxVal highBit = 30 in a 32 bits image, so 1 can be shifted 29 times." - anInteger > -29 ifTrue: [ - anInteger < 0 ifTrue: [^ self / (1 bitShift: (0 - anInteger)) asFloat]. - anInteger < 30 ifTrue: [^ self * (1 bitShift: anInteger) asFloat]]. - - ^ self * (2.0 raisedToInteger: anInteger)! ! - -BoxedFloat64 removeSelector: #profilerFriendlyPrimTimesTwoPower:! - -BoxedFloat64 removeSelector: #profilerFriendlyPrimTimesTwoPower:! - -BoxedFloat64 removeSelector: #profilerFriendlyTimesTwoPower:! - -BoxedFloat64 removeSelector: #profilerFriendlyTimesTwoPower:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3326-ProfilerDemoCodeFix-JuanVuletich-2018May13-19h41m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3325] on 13 May 2018 at 7:42:58 pm'! - -Object subclass: #Theme - instanceVariableNames: 'menuItemIcons ' - classVariableNames: 'Content CurrentTheme ' - poolDictionaries: '' - category: 'Theme-Core'! - -!classDefinition: #Theme category: #'Theme-Core'! -Object subclass: #Theme - instanceVariableNames: 'menuItemIcons' - classVariableNames: 'Content CurrentTheme' - poolDictionaries: '' - category: 'Theme-Core'! -!MenuMorph methodsFor: 'control' stamp: 'jmv 5/13/2018 19:12:18' prior: 50392328! - popUpAt: aPoint forHand: hand allowKeyboard: aBoolean - "Present this menu at the given point under control of the given hand." - - | evt | - self items isEmpty ifTrue: [^self]. - self addBlankIconsIfNecessary. - (self submorphs select: [ :m | m is: #UpdatingMenuItemMorph ]) - do: [ :m | m updateContents]. - self runningWorld addMorphFront: self position: aPoint - `2 @ 8`. - self fitInWorld. - "Acquire focus for valid pop up behavior" - hand newMouseFocus: self. - aBoolean ifTrue: [ hand newKeyboardFocus: self ]. - evt _ hand lastMouseEvent. - (evt isKeyboard or: [ evt isMouse and: [ evt anyButtonPressed not ]]) - ifTrue: [ - "Select first item if button not down" - self moveSelectionDown: 1 event: evt ]! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 5/13/2018 19:12:24' prior: 50392354! - popUpAt: aPoint forHand: hand in: aWorld allowKeyboard: aBoolean - "Present this menu at the given point under control of the given hand." - - self items isEmpty ifTrue: [ ^self ]. - self addBlankIconsIfNecessary. - (self submorphs select: [ :m | m is: #UpdatingMenuItemMorph]) - do: [ :m | m updateContents]. - aWorld addMorphFront: self position: aPoint - `2 @ 8`. - self fitInWorld. - "Acquire focus for valid pop up behavior" - hand newMouseFocus: self. - aBoolean ifTrue: [ hand newKeyboardFocus: self ]! ! - -Theme class removeSelector: #addBasicIconsTo:! - -Theme class removeSelector: #addBasicIconsTo:! - -Theme class removeSelector: #addMiscellaneousIconsTo:! - -Theme class removeSelector: #addMiscellaneousIconsTo:! - -Theme removeSelector: #allIcons! - -Theme removeSelector: #allIcons! - -Theme removeSelector: #basicIcons! - -Theme removeSelector: #basicIcons! - -Theme removeSelector: #decorateMenu:! - -Theme removeSelector: #decorateMenu:! - -Theme removeSelector: #iconDefinersFor:! - -Theme removeSelector: #iconDefinersFor:! - -Theme removeSelector: #iconsDefinitionFor:! - -Theme removeSelector: #iconsDefinitionFor:! - -Theme removeSelector: #initialize! - -Theme removeSelector: #initialize! - -Theme removeSelector: #menuDecorations! - -Theme removeSelector: #menuDecorations! - -Theme removeSelector: #miscellaneousIcons! - -Theme removeSelector: #miscellaneousIcons! - -MenuItemMorph removeSelector: #set_icon:! - -MenuItemMorph removeSelector: #set_icon:! - -MenuMorph removeSelector: #addList:! - -MenuMorph removeSelector: #addList:! - -Object subclass: #Theme - instanceVariableNames: '' - classVariableNames: 'Content CurrentTheme' - poolDictionaries: '' - category: 'Theme-Core'! - -!classDefinition: #Theme category: #'Theme-Core'! -Object subclass: #Theme - instanceVariableNames: '' - classVariableNames: 'Content CurrentTheme' - poolDictionaries: '' - category: 'Theme-Core'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3327-removeOldStyleMenuDecorations-JuanVuletich-2018May13-19h42m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3327] on 13 May 2018 at 7:48:23 pm'! -!ContentPack methodsFor: 'accessing' stamp: 'jmv 5/13/2018 19:47:44'! - from: key get: anArray - -" - Theme content from: #Theme get: #('16x16' 'actions' 'view-refresh.png' ) - Answer nil when the object isn't found. - --cbr " - - | object | object _ self at: key ifAbsent: [ ^ nil ]. - - anArray do: [ :i | object _ object at: i ifAbsent: [ ^ nil ]]. - - ^ object! ! -!Theme methodsFor: 'icon lookup' stamp: 'jmv 5/13/2018 19:47:13' prior: 16936742! - fetch: aTuple " #( 'resolution' 'context' 'filename' ) " - - "Get an icon from Content. See icons protocol." - - | contentSpecifier icon themeGuess | - - icon _ nil. - themeGuess _ self class. - contentSpecifier _ self appendExtensionToContentSpec: aTuple. - - [ icon isNil ] - whileTrue: [ - icon _ self class content - from: themeGuess name - get: contentSpecifier. - - icon ifNotNil: [ ^ icon ]. - - themeGuess = Theme content - ifTrue: [ ^ nil "See comment in ContentPack>>get: --cbr" ]. - - themeGuess _ themeGuess superclass - ]! ! - -ContentPack removeSelector: #get:! - -ContentPack removeSelector: #get:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3328-IconRetrievalOptimization-JuanVuletich-2018May13-19h45m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3328] on 14 May 2018 at 1:02:23 pm'! -!SystemWindow methodsFor: 'menu' stamp: 'jmv 5/14/2018 11:54:07' prior: 50333299! - buildWindowMenu - - | aMenu | - - aMenu _ MenuMorph new defaultTarget: self. - - aMenu - add: 'change title...' action: #relabel icon: #saveAsIcon; - add: 'window color...' action: #setWindowColor icon: #graphicsIcon; - addLine; - add: 'send to back' action: #sendToBack icon: #goBottomIcon; - add: 'make next-to-topmost' action: #makeSecondTopmost icon: #goUpIcon; - addLine; - add: (self isSticky ifTrue: [ 'make draggable' ] ifFalse: [ 'make undraggable' ]) - action: #toggleStickiness icon: (self isSticky ifFalse: [#pushPinIcon]); - addLine; - add: 'close' action: #delete icon: #closeIcon; - add: 'collapse' action: #collapse icon: #collapseIcon; - add: 'expand / contract' action: #expandBoxHit icon: #expandIcon; - addLine; - add: 'resize...' action: #resize; - add: 'resize full' action: #resizeFull; - add: 'resize top' action: #resizeTop; - add: 'resize left' action: #resizeLeft; - add: 'resize bottom' action: #resizeBottom; - add: 'resize right' action: #resizeRight; - add: 'resize top left' action: #resizeTopLeft; - add: 'resize top right' action: #resizeTopRight; - add: 'resize bottom left' action: #resizeBottomLeft; - add: 'resize bottom right' action: #resizeBottomRight. - - ^ aMenu! ! -!ChangeSorterWindow methodsFor: 'menu building' stamp: 'jmv 5/14/2018 10:56:45' prior: 50397342! - changeSetMenu - "Set up aMenu to hold commands for the change-set-list pane. This could be for a single or double changeSorter" - - | aMenu isForBaseSystem | - isForBaseSystem _ model changeSet isForBaseSystem. - aMenu _ MenuMorph new defaultTarget: model. - aMenu addTitle: 'Change Set'. - aMenu addStayUpIcons. - - aMenu add: 'File out and remove (o)' action: #fileOutAndRemove icon: #fileOutIcon enabled: isForBaseSystem. - aMenu add: 'File out and keep (k)' action: #fileOutAndKeep icon: #fileOutIcon. - aMenu addLine. - - aMenu add: 'Rename change set (r)' action: #rename icon: #saveAsIcon enabled: isForBaseSystem. - aMenu add: 'Destroy change set (x)' action: #remove icon: #warningIcon enabled: isForBaseSystem. - aMenu addLine. - model currentCanHavePreambleAndPostscript ifTrue: [ - aMenu addLine. - model currentHasPreamble - ifTrue: [ - aMenu add: 'Edit preamble (p)' action: #addPreamble icon: #textEditorIcon. - aMenu add: 'Remove preamble' action: #removePreamble icon: #listRemoveIcon ] - ifFalse: [ - aMenu add: 'Add preamble (p)' action: #addPreamble icon: #listAddIcon ]. - model currentHasPostscript - ifTrue: [ - aMenu add: 'Edit postscript...' action: #editPostscript icon: #textEditorIcon . - aMenu add: 'Remove postscript' action: #removePostscript icon: #listRemoveIcon ] - ifFalse: [ - aMenu add: 'Add postscript...' action: #editPostscript icon: #listAddIcon ]. - ]. - aMenu addLine. - - "CONFLICTS SECTION" - (aMenu add: 'conflicts with other change sets' target: self action: #browseMethodConflicts icon: #emblemImportantIcon) - setBalloonText: 'Browse all methods that occur both in this change set and in at least one other change set.'. - aMenu addLine. - - "CHECKS SECTION" - (aMenu add: 'trim history' action: #trimHistory icon: #clockIcon enabled: isForBaseSystem) - setBalloonText: ' Drops any methods added and then removed, as well as renaming and reorganization of newly-added classes. ', - 'NOTE: can cause confusion if later filed in over an earlier version of these changes'. - - (aMenu add: 'view affected class categories' action: #viewAffectedClassCategories icon: #packageIcon) - setBalloonText: ' Show class categories affected by any contained change'. - - ^ aMenu! ! -!FileListWindow methodsFor: 'menu building' stamp: 'jmv 5/14/2018 10:28:53' prior: 50399269! - volumeMenu - | aMenu | - aMenu _ MenuMorph new defaultTarget: model. - aMenu - add: 'delete directory...' - action: #deleteDirectory - icon: #warningIcon. - ^ aMenu! ! -!TestRunnerWindow methodsFor: 'menu building' stamp: 'jmv 5/14/2018 11:10:46' prior: 50396042! - listMenu - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Test Cases'. - aMenu add: 'select all' target: model action: #selectAll icon: #selectAllIcon. - aMenu add: 'deselect all' target: model action: #deselectAll icon: #selectAllIcon. - aMenu add: 'toggle selections' target: model action: #invertSelections icon: #switchIcon. - aMenu add: 'filter' target: model action: #setFilter icon: #findIcon. - model runButtonState ifTrue: [ - aMenu add: 'stop' target: model action: #terminateRun icon: #cancelIcon ]. - model selectedSuite > 0 ifTrue: [ | cls | - cls _ (model tests at: model selectedSuite ifAbsent: ['']) copyUpTo: Character space. - cls _ cls asSymbol. - cls _ (Smalltalk at: cls ifAbsent: nil). - cls ifNotNil: [ - aMenu addLine. - (aMenu add: 'browse' target: self action: #browse: argument: cls) - setIcon: #editFindReplaceIcon. - ]. - ]. - aMenu addLine. - aMenu add: 'log to Transcript' target: model action: #showResult icon: #printerIcon. - ^aMenu! ! -!WorkspaceWindow methodsFor: 'menu' stamp: 'jmv 5/14/2018 11:55:00' prior: 50375081! - offerWindowMenu - | aMenu | - aMenu _ self buildWindowMenu. - aMenu addLine. - aMenu - add: 'reset variables' - target: model - action: #initializeBindings - icon: #warningIcon. - aMenu - addUpdating: #mustDeclareVariableWording - target: model - action: #toggleVariableDeclarationMode. - aMenu - addUpdating: #toggleStylingLabel - target: model - action: #toggleStyling. - aMenu popUpInWorld: self world! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3329-BigMenuRefactor-p26-JuanVuletich-2018May14-13h01m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3329] on 22 May 2018 at 4:38:46 pm'! -!DebuggerWindow methodsFor: 'menu building' stamp: 'jmv 5/22/2018 16:16:36' prior: 50399211! - contextStackMenu - "Set up the menu appropriately for the context-stack-list, either shifted or unshifted as per the parameter provided" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'fullStack (f)'. - #selector -> #fullStack - } asDictionary. - { - #label -> 'restart (r)'. - #selector -> #restart - } asDictionary. - { - #label -> 'proceed (p)'. - #selector -> #proceed - } asDictionary. - { - #label -> 'step (t)'. - #selector -> #doStep - } asDictionary. - { - #label -> 'step through (T)'. - #selector -> #stepIntoBlock - } asDictionary. - { - #label -> 'send (e)'. - #selector -> #send - } asDictionary. - { - #label -> 'where (w)'. - #selector -> #where - } asDictionary. - { - #label -> 'peel to first like this'. - #selector -> #peelToFirst - } asDictionary. - nil. - { - #label -> 'return entered value'. - #selector -> #returnValue - } asDictionary. - { - #label -> 'toggle break on entry'. - #object -> #model. - #selector -> #toggleBreakOnEntry - } asDictionary. - }`. - ^aMenu! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3330-DebugMenuFix-JuanVuletich-2018May22-16h16m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3331] on 23 May 2018 at 11:33:10 am'! -!Form methodsFor: 'analyzing' stamp: 'jmv 5/23/2018 11:28:54'! - isAnyPixel: pv - "Return an array of the number of pixels with value pv by y-value. - Note that if not is true, then this will tally those different from pv. - Based on #yTallyPixelValue:orNot: - Form lena isAnyPixel: 0 - Form lena isAnyPixel: 100 - " - | cm slice copyBlt countBlt | - cm _ self newColorMap. "Map all colors but pv to zero" - cm at: pv+1 put: 1 - (cm at: pv+1). - slice _ Form extent: width@1. - copyBlt _ (BitBlt destForm: slice sourceForm: self - combinationRule: Form over - destOrigin: `0@0` sourceOrigin: `0@0` extent: slice width @ 1 - clipRect: slice boundingBox) - colorMap: cm. - countBlt _ (BitBlt toForm: slice) - fillColor: (Bitmap with: 0); - destRect: (`0@0` extent: slice extent); - combinationRule: 32. - (0 to: height-1) do: [ :y | - copyBlt sourceOrigin: 0@y; copyBits. - countBlt copyBits > 0 ifTrue: [ ^ true ]]. - ^ false! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3331-isAnyPixel-JuanVuletich-2018May23-10h38m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3331] on 25 May 2018 at 10:41:35 am'! - -Dictionary subclass: #OrderedDictionary - instanceVariableNames: 'orderedKeys' - classVariableNames: '' - poolDictionaries: '' - category: 'Collections-Sequenceable'! - -!classDefinition: #OrderedDictionary category: #'Collections-Sequenceable'! -Dictionary subclass: #OrderedDictionary - instanceVariableNames: 'orderedKeys' - classVariableNames: '' - poolDictionaries: '' - category: 'Collections-Sequenceable'! -!OrderedDictionary commentStamp: '' prior: 0! - Like Python's OrderedDict! -!OrderedDictionary methodsFor: 'removing' stamp: 'jmv 3/9/2018 14:33:08'! - removeKey: key ifAbsent: aBlock - - super removeKey: key ifAbsent: [ - ^ aBlock value ]. - orderedKeys remove: key! ! -!OrderedDictionary methodsFor: 'enumerating' stamp: 'jmv 3/9/2018 14:45:35'! - associationsDo: aBlock - "Evaluate aBlock for each of the receiver's elements (key/value - associations)." - - orderedKeys do: [ :key | - aBlock value: (self associationAt: key ifAbsent: nil) ]! ! -!OrderedDictionary methodsFor: 'enumerating' stamp: 'jmv 3/9/2018 14:45:31'! - do: aBlock - "Evaluate aBlock for each of the receiver's values." - - orderedKeys do: [ :key | - aBlock value: (self at: key ifAbsent: nil) ]! ! -!OrderedDictionary methodsFor: 'enumerating' stamp: 'jmv 3/9/2018 14:45:24'! - keysDo: aBlock - "Evaluate aBlock for each of the receiver's keys." - - orderedKeys do: aBlock ! ! -!OrderedDictionary methodsFor: 'accessing' stamp: 'jmv 5/25/2018 10:36:46'! - keysSortedSafely - "Answer a sorted Collection containing the receiver's keys. - Redefined from Dictionary: for us, propery sorted keys are keys in the order they were added." - ^ orderedKeys! ! -!OrderedDictionary methodsFor: 'private' stamp: 'jmv 3/9/2018 14:33:17'! - atNewIndex: index put: anAssociation - - super atNewIndex: index put: anAssociation. - orderedKeys add: anAssociation key! ! -!OrderedDictionary methodsFor: 'private' stamp: 'jmv 3/9/2018 14:33:19'! - init: n - - super init: n. - orderedKeys _ OrderedCollection new: n! ! -!Dictionary methodsFor: 'accessing' stamp: 'jmv 5/25/2018 10:35:25' prior: 16833451! - keysSortedSafely - "Answer a sorted Collection containing the receiver's keys." - | sortedKeys | - sortedKeys _ OrderedCollection new: self size. - self keysDo: [:each | sortedKeys addLast: each]. - sortedKeys sort: - [ :x :y | "Should really be use 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]]]. - ^ sortedKeys! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3332-OrderedDictionary-JuanVuletich-2018May25-10h13m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3332] on 25 May 2018 at 2:06:45 pm'! -!Theme class methodsFor: 'instance creation' stamp: 'cbr 12/14/2010 01:55' prior: 50397945! - beCurrent - ^ self currentTheme: self! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3333-fixHangOnImageSave-JuanVuletich-2018May25-14h06m-jmv.1.cs.st----! - -----SNAPSHOT----#(25 May 2018 2:10:36.038874 pm) Cuis5.0-3333-v3.image priorSource: 1906987! - -----QUIT----#(25 May 2018 2:10:52.374396 pm) Cuis5.0-3333-v3.image priorSource: 2196336! - -----STARTUP----#(15 June 2018 11:06:21.767694 am) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3333-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3333] on 26 May 2018 at 5:40:37 pm'! -!Complex methodsFor: 'testing' stamp: 'jmv 5/20/2018 21:10:51'! - isInfinite - ^real isInfinite or: [ imaginary isInfinite ]! ! -!Complex methodsFor: 'private' stamp: 'jmv 5/20/2018 20:29:34'! - setReal: aNumber1 imaginary: aNumber2 - "Private - initialize the real and imaginary parts of a Complex" - real _ aNumber1. - imaginary _ aNumber2! ! -!Complex class methodsFor: 'instance creation' stamp: 'jmv 5/20/2018 20:32:34'! - basicReal: realPart imaginary: imaginaryPart - "Answer a Complex even if imaginary part is zero. Usually you don't want this and just call #real:imaginary:" - ^self basicNew setReal: realPart imaginary: imaginaryPart! ! -!Number methodsFor: 'converting' stamp: 'jmv 5/20/2018 20:33:20' prior: 16879859! - asComplex - "Answer a Complex number that represents value of the the receiver." - - ^ Complex basicReal: self imaginary: 0! ! -!Complex methodsFor: 'arithmetic' stamp: 'jmv 5/20/2018 20:30:21' prior: 16822388! - absSecure - "Answer the distance of the receiver from zero (0 + 0 i). - Try avoiding overflow and/or underflow" - - | scale | - scale := real abs max: imaginary abs. - ^scale isZero - ifTrue: [scale] - ifFalse: [(self class basicReal: real / scale imaginary: imaginary / scale) squaredNorm sqrt * scale]! ! -!Complex class methodsFor: 'instance creation' stamp: 'jmv 5/20/2018 20:27:23' prior: 16822850! - abs: rho arg: theta - | theta1 | - "So that if theta is any integer multiple of twoPi, answer is real" - theta1 _ theta \\ Float twoPi. - ^ self - real: rho * theta1 cos - imaginary: rho * theta1 sin! ! -!Complex class methodsFor: 'instance creation' stamp: 'jmv 5/20/2018 17:14:55' prior: 16822864! - real: realPart imaginary: imaginaryPart - ^ imaginaryPart isZero - ifTrue: [ realPart ] - ifFalse: [ self basicReal: realPart imaginary: imaginaryPart ]! ! - -Complex removeSelector: #real:imaginary:! - -Complex removeSelector: #real:imaginary:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3334-Complex-Creation-JuanVuletich-2018May26-17h32m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3334] on 26 May 2018 at 11:10:23 pm'! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 5/26/2018 17:51:33'! - sqrt - "Answer the square root of the receiver. - Optional. See Object documentation whatIsAPrimitive." - | exp guess eps delta prim | - prim _ self primSqrt. - prim isNaN ifFalse: [ ^prim ]. - - "Newton-Raphson" - self <= 0.0 - ifTrue: [ - ^self = 0.0 - ifTrue: [0.0] - ifFalse: [ - (0.0 - self) sqrt i ]]. - "first guess is half the exponent" - exp := self exponent // 2. - guess := self timesTwoPower: 0 - exp. - "get eps value" - eps := guess * Epsilon. - eps := eps * eps. - delta := self - (guess * guess) / (guess * 2.0). - [delta * delta > eps] - whileTrue: - [guess := guess + delta. - delta := self - (guess * guess) / (guess * 2.0)]. - ^ guess! ! -!BoxedFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 5/21/2018 18:02:08'! - primSqrt - "Answer the square root of the receiver. - Optional. See Object documentation whatIsAPrimitive." - - - ^Float nan! ! -!SmallFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 5/21/2018 18:02:14'! - primSqrt - "Answer the square root of the receiver. - Optional. See Object documentation whatIsAPrimitive." - - - ^Float nan! ! -!Complex methodsFor: 'testing' stamp: 'jmv 5/26/2018 23:00:13'! - isNaN - ^real isNaN or: [ imaginary isNaN ]! ! -!Fraction methodsFor: 'mathematical functions' stamp: 'jmv 5/26/2018 23:01:31' prior: 16849723! - sqrt - | d n answer | - n _ numerator sqrt. - d _ denominator sqrt. - "The #sqrt method in integer will only answer a Float if there's no exact square root. - So, we need a float anyway." - (n isInfinite or: [ d isInfinite ]) ifTrue: [ - ^self asFloat sqrt ]. - answer _ n / d. - answer isNaN ifTrue: [ - ^self asFloat sqrt ]. - ^ answer! ! -!LargeNegativeInteger methodsFor: 'mathematical functions' stamp: 'jmv 5/26/2018 17:52:29' prior: 16862205! - sqrt - "Answer the square root of the receiver." - ^ self negated sqrt i! ! -!SmallInteger methodsFor: 'mathematical functions' stamp: 'jmv 5/26/2018 17:52:59' prior: 16909161! - sqrt - self negative ifTrue: [ - ^ self negated sqrt i ]. - ^ super sqrt! ! - -SmallFloat64 removeSelector: #sqrt! - -SmallFloat64 removeSelector: #sqrt! - -BoxedFloat64 removeSelector: #sqrt! - -BoxedFloat64 removeSelector: #sqrt! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3335-Complex-sqrt-JuanVuletich-2018May26-23h09m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3335] on 26 May 2018 at 6:10:15 pm'! - -SmallInteger class removeSelector: #guideToDivision! - -SmallInteger class removeSelector: #guideToDivision! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3336-RemoveOldGuideToDivision-JuanVuletich-2018May26-18h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3336] on 26 May 2018 at 11:05:24 pm'! -!Complex methodsFor: 'mathematical functions' stamp: 'jmv 5/26/2018 22:57:33'! - nthRoot: aPositiveInteger - - aPositiveInteger = 2 ifTrue: [ - ^ self sqrt ]. - - (aPositiveInteger isInteger not or: [ aPositiveInteger negative ]) - ifTrue: [^ ArithmeticError signal: 'nth root only defined for positive Integer n.']. - - ^ Complex abs: (self abs nthRoot: aPositiveInteger) arg: self arg / aPositiveInteger! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 5/26/2018 21:52:19' prior: 16844676! - nthRoot: aPositiveInteger - "Answer the nth root of the receiver." - aPositiveInteger = 2 ifTrue: [ - ^self sqrt ]. - - (aPositiveInteger isInteger not or: [ aPositiveInteger negative ]) - ifTrue: [^ ArithmeticError signal: 'nth root only defined for positive Integer n.']. - - ^self negative - ifTrue: [ - aPositiveInteger even - ifTrue: [ (Complex basicReal: self imaginary: 0) nthRoot: aPositiveInteger ] - ifFalse: [ (self negated nthRoot: aPositiveInteger) negated ]] - ifFalse: [ self raisedTo: 1.0 / aPositiveInteger ]! ! -!Fraction methodsFor: 'mathematical functions' stamp: 'jmv 5/26/2018 22:57:41' prior: 50367830! - nthRoot: aPositiveInteger - "Answer the nth root of the receiver." - | guess | - aPositiveInteger = 2 ifTrue: [ - ^ self sqrt ]. - - (aPositiveInteger isInteger not or: [ aPositiveInteger negative ]) - ifTrue: [^ ArithmeticError signal: 'nth root only defined for positive Integer n.']. - - (self negative and: [ aPositiveInteger even ]) ifTrue: [ - ^(Complex basicReal: self imaginary: 0) nthRoot: aPositiveInteger ]. - - guess _ (numerator nthRootTruncated: aPositiveInteger) / - (denominator nthRootTruncated: aPositiveInteger). - (guess raisedTo: aPositiveInteger) = self ifTrue: [ - ^ guess ]. - "There is no exact nth root, so answer a Float approximation" - ^ (self abs ln / aPositiveInteger) exp * self sign! ! -!Integer methodsFor: 'mathematical functions' stamp: 'jmv 5/26/2018 22:57:47' prior: 16859661! - nthRoot: aPositiveInteger - "Answer the nth root of the receiver. - Answer an Integer if root is exactly this Integer, else answer the Float nearest the exact root." - - | guess excess scaled nBits | - self = 0 ifTrue: [ ^0 ]. - - aPositiveInteger = 2 ifTrue: [ - ^ self sqrt ]. - - (aPositiveInteger isInteger not or: [ aPositiveInteger negative ]) - ifTrue: [^ ArithmeticError signal: 'nth root only defined for positive Integer n.']. - - (self negative and: [ aPositiveInteger even ]) ifTrue: [ - ^ (Complex basicReal: self imaginary: 0) nthRoot: aPositiveInteger ]. - - guess _ self nthRootRounded: aPositiveInteger. - excess _ (guess raisedTo: aPositiveInteger) - self. - excess = 0 ifTrue: [ ^ guess ]. - - nBits _ Float precision - guess highBitOfMagnitude. - nBits <= 0 ifTrue: [ ^(Fraction numerator: guess * 4 - excess sign denominator: 4) asFloat]. - - scaled _ self << (nBits * aPositiveInteger). - guess _ scaled nthRootRounded: aPositiveInteger. - excess _ (guess raisedTo: aPositiveInteger) - scaled. - ^(Fraction numerator: guess * 4 - excess sign denominator: 1 << (nBits + 2)) asFloat! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3337-Complex-nthRoot-JuanVuletich-2018May26-23h04m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3336] on 26 May 2018 at 10:48:43 pm'! -!Complex methodsFor: 'mathematical functions' stamp: 'jmv 5/26/2018 22:20:24'! - raisedToFraction: aFraction - ^ (self nthRoot: aFraction denominator) raisedToInteger: aFraction numerator! ! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 5/26/2018 22:28:10' prior: 50367798! - raisedTo: aNumber - "Answer the receiver raised to aNumber." - - aNumber isInteger ifTrue: [ - "Do the special case of integer power" - ^ self raisedToInteger: aNumber]. - aNumber isFraction ifTrue: [ - "Special case for fraction power by Nicolas Cellier: - If aNumber is a fraction, but result must be a Float, learn it as quickly as possible, and give quick Float answer - Allows evaluating: - (2009/2000) raisedTo: (3958333/100000) - " - ^ self raisedToFraction: aNumber]. - self < 0 ifTrue: [ - ^(Complex basicReal: self imaginary: 0) raisedTo: aNumber ]. - 0 = aNumber ifTrue: [^ self class one]. "Special case of exponent=0" - 1 = aNumber ifTrue: [^ self]. "Special case of exponent=1" - 0 = self ifTrue: [ "Special case of self = 0" - aNumber < 0 - ifTrue: [^ (ZeroDivide dividend: self) signal] - ifFalse: [^ self]]. - ^ (aNumber * self ln) exp "Otherwise use logarithms"! ! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 5/26/2018 22:22:44' prior: 50367760! - raisedToFraction: aFraction - self isZero ifTrue: [ - aFraction negative ifTrue: [ - ^ (ZeroDivide dividend: 1) signal ]. - ^ self ]. - self negative ifFalse: [ - ^ (self ln * aFraction) exp ]. - aFraction denominator = 2 ifTrue: [ - ^ self sqrt raisedToInteger: aFraction numerator ]. - (self negative and: [ aFraction denominator even ]) ifTrue: [ - ^ (Complex basicReal: self imaginary: 0) raisedToFraction: aFraction]. - ^ (self negated ln * aFraction) exp negated! ! -!Fraction methodsFor: 'mathematical functions' stamp: 'jmv 5/26/2018 22:21:48' prior: 50367774! - raisedToFraction: aFraction - | root | - aFraction denominator = 2 ifTrue: [ - ^ self sqrt raisedToInteger: aFraction numerator ]. - (self negative and: [ aFraction denominator even ]) ifTrue: [ - ^ (Complex basicReal: self imaginary: 0) raisedToFraction: aFraction]. - root _ (self numerator nthRootTruncated: aFraction denominator) / - (self denominator nthRootTruncated: aFraction denominator). - (root raisedToInteger: aFraction denominator) = self ifTrue: [ - ^ root raisedToInteger: aFraction numerator ]. - ^ super raisedToFraction: aFraction! ! -!Integer methodsFor: 'mathematical functions' stamp: 'jmv 5/26/2018 22:19:10' prior: 50367787! - raisedToFraction: aFraction - | root | - self = 0 ifTrue: [ ^0 ]. - aFraction denominator = 2 ifTrue: [ - ^ self sqrt raisedToInteger: aFraction numerator ]. - (self negative and: [ aFraction denominator even ]) ifTrue: [ - ^ (Complex basicReal: self imaginary: 0) raisedToFraction: aFraction]. - root _ self nthRootTruncated: aFraction denominator. - (root raisedToInteger: aFraction denominator) = self ifTrue: [ - ^ root raisedToInteger: aFraction numerator ]. - ^ super raisedToFraction: aFraction! ! -!Complex methodsFor: 'mathematical functions' stamp: 'jmv 5/26/2018 22:24:56' prior: 16822720! - raisedTo: aNumber - "Answer the receiver raised to aNumber." - - aNumber isInteger ifTrue: [ - "Do the special case of integer power" - ^ self raisedToInteger: aNumber]. - aNumber isFraction ifTrue: [ - ^ self raisedToFraction: aNumber]. - - 0 = aNumber ifTrue: [^ self class one]. "Special case of exponent=0" - 1 = aNumber ifTrue: [^ self]. "Special case of exponent=1" - 0 = self ifTrue: [ "Special case of self = 0" - aNumber < 0 - ifTrue: [^ (ZeroDivide dividend: self) signal] - ifFalse: [^ self]]. - ^ (aNumber * self ln) exp "Otherwise use logarithms"! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3338-Complex-raisedTo-JuanVuletich-2018May26-22h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3338] on 27 May 2018 at 7:35:34 pm'! -!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 5/27/2018 19:35:13' prior: 16924221! - browseMethodsWithString: aString - "Launch a browser on all methods that contain string literals with aString as a substring. The search is case-insensitive, unless the shift key is pressed, in which case the search is case-sensitive." - - ^ self browseMethodsWithString: aString matchCase: false - - "Smalltalk browseMethodsWithString: 'Testing' matchCase: false" - "Smalltalk browseMethodsWithString: 'Testing' matchCase: true"! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3339-StringFind-CaseInsensituve-JuanVuletich-2018May27-19h31m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3339] on 1 June 2018 at 8:07:08 pm'! -!PseudoClass methodsFor: 'accessing' stamp: 'jmv 5/31/2018 21:51:33'! - superclassName - ^definition copyUpTo: Character space! ! -!Utilities class methodsFor: 'support windows' stamp: 'jmv 5/31/2018 19:23:46' prior: 16941075! - codeManagementInCuisContents - ^ self class firstCommentAt: #codeManagementInCuisContents - -" -(from http://jvuletich.org/Cuis/CodeManagementInCuis4.html ) - -Starting with version 4.0, Cuis includes tools and suggested procedures for managing Smalltalk code. Code that is not part of the Cuis Core image itself, like applications, frameworks and libraries, should be stored in Packages. New code that is meant as patches, fixes or additions; that could eventually become part of Cuis itself, is not part of any Package, and is therefore automatically stored in Change Sets. - - -Packages ------------- - -Let's start with Packages. The Package implementation in Cuis is based on PackageInfo, the standard way to specify packages in Squeak and its derivatives, and used, for example, by Monticello. It uses Package names, to specify prefixes for Class and Method categories. Classes and Methods whose categories match a Package's prefixes belong in that Package. More details about how PackageInfo decides what code belongs in a package are available at http://wiki.squeak.org/squeak/3329 . - -To install packages (.pck.st files) in Cuis, use the FileList, navigate to the appropriate directory (on disk, or in a GitHub repository, etc), select the package file and click on [Install Package]. - -Cuis includes a tool to manage installed Packages. It is at World / Open / Installed Packages. To create a new package (instead of installing an existing one from a file), click on [Create Package] This creates a new package, and associates with it all the existing code in the image that matches the package name. - -The operations available on installed or newly created packages are: - -[Save] Saves a package on the file system. Overwrites any existing version. It is good to save package from time to time, to reduce the risk of losing code. - -[Delete] Removes the Package instance from the image. Does not remove any code. This means, effectively, to merge back the code into Cuis. - -[Browse unsaved Changes] This opens a ChangeSorter on the ChangeSet that captures all the changes done to the Package since it was last saved. Therefore it shows the work done on the package that would be lost if the package is not saved. - -[Browse Package Code] This opens a Class Browser that only shows the code that belongs in the package. This is useful for working on a package, or studying it. - -The tool shows, for each Package, the name, whether it is dirty (has unsaved changes) and the file it was installed from / saved to. - -Handling Packages like this, Cuis behaves as a sort of document editor (like, for example a regular text editor) whose documents are Package files (.pck.st). Cuis doesn't handle Package versions, ancestries, etc. If versioning of Packages is desired, the best is to use a versioning file repository, such as Git or Mercurial. The recommendation is to use a GitHub repository with a name beginning with 'Cuis-Smalltalk', so it will be easy for anybody to find it. Cuis Package files (.pck.st) are uncompressed, use Lf (ASCII 10) as newLine, and are encoded in ISO 8859-15. This means that they are Git friendly, and Git/GitHub can diff and merge them, and browse them with syntax highlighting. - -This is not unlike using Git or GitHub with a more conventional development environment such as Eclipse or a text editor. Like Cuis 4, these tools don't do version handling themselves, they just load and save files; and let Git do its magic. - - -Changes to the Cuis base image --------------------------------------- - -The way ChangeSets are created and managed in Cuis 4 is very different from previous versions of Cuis (and Squeak & derivatives). This was done to make ChangeSets a good way to manage changes to the base Cuis Core image, while keeping code in Packages out of the way, so they don't get mixed together. - -What is not in a Package belongs (at least temporarily) in the Cuis Core image. Such code is automatically captured in a ChangeSet. The ChangeSet for Core changes is created automatically and named like '1243-CuisCore-JuanVuletich-2012Apr03-22h50m'. The number at the beginning is the next number for the Cuis update stream, and is provided only as a suggestion. The 'CuisCore' part is to reveal that the code belongs in the base image and not in some package. Then we have author name and date / time of creation. These ChangeSets are created automatically. There is no longer a way to manually create them, or make them 'current' or 'active'. It is best not to rename them. These ChangeSets will not capture any code that belongs in a Package. - -Opening a Change Sorter will show the CuisCore change set. This is useful, for example, to check that no code that was intended for a Package ends here by mistake (because of the wrong class or method category). But it is also useful when doing changes to the base system. Now, we can do changes both to the base system and to a number of packages, all in the same session, without having to be careful about selecting the proper change set before saving a method: The code is automatically added to the proper Package or ChangeSet, simply following the class or method category. Gone are the days of messed up change sets and lost code!! - -When the changes to the base system are complete, it is a good time to review the CuisCore change set and, maybe remove from it changes that we don't want to keep (for example, experiments, halts, etc). Then, just do right click / File out and remove. This saves the ChangeSet on disk. It also removes it from the ChangeSorter (but it doesn't remove any code). This is good, because the next changes done will end in a new CuisCore change set, and there's no risk of having undesired changes in the old one. As changes to the base image progress, and several CuisCore change sets are saved to disk, these numbered files are created in sequence. They will be ready to be loaded back in proper order in a fresh Cuis image, or to be sent to Cuis maintainers for integration in the update stream and in next releases of Cuis. - - -Loading ChangeSet files into Cuis ---------------------------------------- - -There are two ways to load ChangeSet files (.cs): [FileIn] and [Install]. - -[FileIn] loads the code without creating a new ChangeSet object. This means that changes that belong in the base image (and not in a package) will be added to the current ChangeSet for Cuis core changes, as if they were done by the user. This is appropriate when we are combining code from more than one source into a single ChangeSet. Any change that belongs in an installed package will be added to it, and the package will appear as dirty. - -[Install] loads the code into a separate ChangeSet object (viewable in the ChangeSorter tool). This is appropriate for loading Cuis updates, or other code that we are not authoring, as it doesn't add new items (class or method definitions) to the current ChangeSet for our changes to Cuis. Usually any ChangeSets should be installed before doing changes to the image. The reason is that an installed ChangeSet could overwrite changes done by you, or packages you have installed. If this is the case, the affected packages would appear as dirty, and your change set would include any installed changes (that don't belong in a package). Be careful when saving packages or change sets if this was the case!! -" - -" -Utilities codeManagementInCuisContents edit -"! ! -!PseudoClass methodsFor: 'fileIn/fileOut' stamp: 'jmv 5/31/2018 21:51:47' prior: 16896967! - fileInDefinition - (self makeSureSuperClassExists: self superclassName) ifFalse:[^self]. - self hasDefinition ifTrue:[ - Transcript newLine; show:'Defining ', self name. - self evaluate: self definition]. - self exists ifFalse:[^self]. - self hasComment ifTrue:[self realClass classComment: self comment].! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3340-tweaks-JuanVuletich-2018Jun01-20h06m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3341] on 1 June 2018 at 8:59:47 pm'! -!CodePackage class methodsFor: 'installing' stamp: 'jmv 6/1/2018 20:59:14'! - postPackageInstall - "This gets called after installing all the package code. - Redefine as appropriate"! ! -!CodePackage class methodsFor: 'installing' stamp: 'jmv 6/1/2018 20:59:33'! - prePackageInstall - "This gets called after creating the package class and installing its code, but before installing the rest of the package code - Redefine as appropriate"! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3341-pre-post-packageInstall-CuisCore-JuanVuletich-2018Jun01-20h58m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3341] on 2 June 2018 at 5:00:22 pm'! -!CodePackage methodsFor: 'accessing' stamp: 'jmv 6/2/2018 16:58:49'! - codePackageClass - "Answer the specific CodePackage subclass to use." - - self class == CodePackage ifFalse: [ - ^ self class ]. - self classesDo: [ :cls | - (cls inheritsFrom: CodePackage) - ifTrue: [ ^ cls ]]. - ^ nil! ! -!CodePackage methodsFor: 'saving' stamp: 'jmv 6/2/2018 16:59:03' prior: 50389797! - writeOnStream: aStream - - | sortedClasses | - aStream - nextChunkPut: ('Description ', description) printString; - newLine. - self writeFeatureSpecOn: aStream. - self writeSystemCategoriesOn: aStream. - - self codePackageClass ifNotNil: [ :codePackageClass | - self - write: {codePackageClass} classDefinitionsOn: aStream; - write: {codePackageClass} classCommentsOn: aStream; - write: {codePackageClass} methodsOn: aStream. - aStream nextChunkPut: codePackageClass name, ' prePackageInstall'; newLine ]. - - sortedClasses _ Array streamContents: [ :strm | - self classesInSafeOrderDo: [ :cls | - cls == self class ifFalse: [ - strm nextPut: cls ]]]. - self - write: sortedClasses classDefinitionsOn: aStream; - write: sortedClasses classCommentsOn: aStream; - write: sortedClasses methodsOn: aStream. - - self - sortedExtensionMethodsDo: [ :methodReference | - methodReference isValid ifTrue: [ - self writeMethod: methodReference on: aStream ]] - displayingProgress: 'Saving extension methods...'. - self write: sortedClasses initializersOn: aStream. - - self codePackageClass ifNotNil: [ :codePackageClass | - self write: { codePackageClass } initializersOn: aStream. - aStream nextChunkPut: codePackageClass name, ' postPackageInstall'; newLine ]! ! -!CodePackageFile methodsFor: 'services' stamp: 'jmv 6/2/2018 16:59:49' prior: 16810879! - install: aFileStream - "Installs the package. Replace all existing code in the CodePackage, removing any code that is not included in us." - | localName newCodePackage pckClass | - - "Give reasonable warnings if there is stuff that can't be properly cleaned. Give the user the chance to abort." - '=============' print. - classesToRemove notEmpty ifTrue: [ - ('classesToRemove: ', classesToRemove printString) print. - '=============' print ]. - methodsToRemove notEmpty ifTrue: [ - 'methodsToRemove: ' print. - methodsToRemove do: [ :methodReference | methodReference print ]. - '=============' print ]. - - "Tirar warning si hay que borrar cosas que no se puede, si hay referencias, etc. Quizas si vamos a borrar el ultimo implementor de un mensaje enviado?" - - localName _ fullName asFileEntry name. - ChangeSet installing: packageName do: [ - aFileStream fileInAnnouncing: 'Installing ', localName, '...'. - methodsToRemove do: [ :methodReference | methodReference actualClass removeSelector: methodReference selector ]. - classesToRemove do: [ :className | (Smalltalk at: className) removeFromSystem ]. - "Create, install and answer an instance of CodePackage" - pckClass _ CodePackage. - classes do: [ :ee | (ee hasDefinition and: [ee superclassName = 'CodePackage']) ifTrue: [ - pckClass _ Smalltalk at: ee name ]]. - newCodePackage _ pckClass - named: packageName - createIfAbsent: true - registerIfNew: true. - newCodePackage - fullFileName: fullName; - sourceSystem: sourceSystem; - description: description; - featureSpec: featureSpec. - ]. - newCodePackage hasUnsavedChanges: false; triggerEvent: #dirtyFlagChanged. - DataStream initialize. "Just in case" - "If we are installing an already installed package, zap the change set with possible changes done, - as they are irrelevant now: we have the package from disk" - ChangeSet removeChangeSet: (ChangeSet existingOrNewChangeSetForPackage: newCodePackage). - Transcript newLine; show: 'Package ', packageName, ' successfully installed'; newLine. - - "Tirar undeclared al transcript. warning si quedaron undeclared - Es feo que tire an transcript undeclareds que despues no lo son..." - Smalltalk cleanOutUndeclared. - Undeclared notEmpty ifTrue: [ - ('Undeclared: ', Undeclared printString) print ]. - - "Descartar la instancia de CodePackageFile" - ^newCodePackage! ! - -CodePackage removeSelector: #writeInitializerExtensionMethods:on:! - -CodePackage removeSelector: #writeInitializerExtensionMethods:on:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3342-supportFor-CodePackage-subclasses-JuanVuletich-2018Jun02-16h57m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3341] on 1 June 2018 at 8:56:07 pm'! - -FloatArray variableWordSubclass: #Color - instanceVariableNames: '' - classVariableNames: 'CachedColormaps ColorNamesDict FromGrayColormaps GrayToIndexMap IndexedColors MaskingMap ToGrayColormaps ' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -!classDefinition: #Color category: #'Graphics-Primitives'! -FloatArray variableWordSubclass: #Color - instanceVariableNames: '' - classVariableNames: 'CachedColormaps ColorNamesDict FromGrayColormaps GrayToIndexMap IndexedColors MaskingMap ToGrayColormaps' - poolDictionaries: '' - category: 'Graphics-Primitives'! -!Color methodsFor: 'other' stamp: 'jmv 6/1/2018 20:55:02' prior: 50388992! - colorName - "Return this color's name, or nil if it has no name. Only returns a name if it exactly matches the named color. - Return nil if named color support is not present" - - Color classPool - at: #ColorNamesDict - ifPresent: [ :dict | ^dict keyAtValue: self ifAbsent: [nil]]. - ^nil! ! -!Color class methodsFor: 'cached state access' stamp: 'jmv 6/1/2018 20:55:34' prior: 50389193! - releaseClassCachedState - " - Color releaseClassCachedState - " - CachedColormaps _ nil. "Maps to translate between color depths" - ToGrayColormaps _ nil. "Maps colors to 8bpp grays for various color depths" - FromGrayColormaps _ nil. "Maps from 8bpp grays to colors of various depths" - MaskingMap _ nil. "Maps all colors except transparent to black for creating a mask" - IndexedColors _ nil. - GrayToIndexMap _ nil! ! - -FloatArray variableWordSubclass: #Color - instanceVariableNames: '' - classVariableNames: 'CachedColormaps FromGrayColormaps GrayToIndexMap IndexedColors MaskingMap ToGrayColormaps' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -!classDefinition: #Color category: #'Graphics-Primitives'! -FloatArray variableWordSubclass: #Color - instanceVariableNames: '' - classVariableNames: 'CachedColormaps FromGrayColormaps GrayToIndexMap IndexedColors MaskingMap ToGrayColormaps' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3343-RemoveUnused-Color-classVar-JuanVuletich-2018Jun01-20h54m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3343] on 2 June 2018 at 5:24:58 pm'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 6/2/2018 17:24:20' prior: 50375384! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3344-Add-NahuelGarbezza-asAuthor-JuanVuletich-2018Jun02-17h23m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3333] on 27 May 2018 at 1:46:20 am'! -!CodeWindow methodsFor: 'keyboard shortcuts' stamp: 'RNG 5/27/2018 01:44:26'! - messageCatListKey: aChar from: view - - aChar == $o ifTrue: [^ model fileOutMessageCategories ]. - aChar == $t ifTrue: [^ model runMessageCategoryTests ]. - aChar == $x ifTrue: [^ model removeMessageCategory ].! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'RNG 5/27/2018 01:43:23' prior: 16793073! - buildMorphicMessageCatList - - ^PluggableListMorph - model: model - listGetter: #messageCategoryList - indexGetter: #messageCategoryListIndex - indexSetter: #messageCategoryListIndex: - mainView: self - menuGetter: #messageCategoryMenu - keystrokeAction: #messageCatListKey:from:! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'RNG 5/27/2018 01:43:51' prior: 50398391! - messageCategoryMenu - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Message Category'. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'fileOut (o)'. - #object -> #model. - #selector -> #fileOutMessageCategories. - #icon -> #fileOutIcon - } asDictionary. - nil. - { - #label -> 'reorganize'. - #object -> #model. - #selector -> #editMessageCategories. - #icon -> #sendReceiveIcon - } asDictionary. - { - #label -> 'alphabetize'. - #object -> #model. - #selector -> #alphabetizeMessageCategories. - #icon -> #fontXGenericIcon - } asDictionary. - { - #label -> 'remove empty categories'. - #object -> #model. - #selector -> #removeEmptyCategories. - #icon -> #listRemoveIcon - } asDictionary. - { - #label -> 'categorize all uncategorized'. - #object -> #model. - #selector -> #categorizeAllUncategorizedMethods. - #icon -> #packageIcon - } asDictionary. - { - #label -> 'new category...'. - #object -> #model. - #selector -> #addCategory. - #icon -> #newIcon - } asDictionary. - nil. - { - #label -> 'rename...'. - #object -> #model. - #selector -> #renameCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #label -> 'remove (x)'. - #object -> #model. - #selector -> #removeMessageCategory. - #icon -> #deleteIcon - } asDictionary. - nil. - { - #label -> 'Run tests (t)'. - #object -> #model. - #selector -> #runMessageCategoryTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - }`. - ^ aMenu! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3345-KeyboardShortcutForMessageCategories-NahuelGarbezza-2018May27-01h24m-RNG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3345] on 14 June 2018 at 2:11:19 pm'! -!CompiledMethod methodsFor: 'source code management' stamp: 'jmv 6/14/2018 14:06:32' prior: 50381363! - getPreambleFrom: aFileStream at: position - | writeStream c p | - writeStream _ String new writeStream. - p _ position. - c _ nil. - aFileStream position: p. - aFileStream atEnd ifTrue: [ ^ nil ]. - [ p >= 0 and: [ c ~~ $!! ]] whileTrue: [ - aFileStream position: p. - c _ aFileStream basicNext. - p _ p - 1 ]. - [ p >= 0] whileTrue: [ - aFileStream position: p. - c _ aFileStream basicNext. - c == $!! - ifTrue: [^ writeStream contents reverse ] - ifFalse: [ writeStream nextPut: c ]. - p _ p - 1 ]. - ^ nil! ! -!RemoteString methodsFor: 'accessing' stamp: 'jmv 6/14/2018 14:11:09' prior: 16900625! - string - "Answer the receiver's string if remote files are enabled." - | theFile answer | - (sourceFileNumber == nil or: [(SourceFiles at: sourceFileNumber) == nil]) ifTrue: [^nil]. - theFile _ SourceFiles at: sourceFileNumber. - theFile position: filePositionHi. - answer _ theFile nextChunk. - ^answer isEmpty ifTrue: [nil] ifFalse: [answer]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3346-FixSlowdownsWhenMissingChangesFile-JuanVuletich-2018Jun14-14h10m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3345] on 5 June 2018 at 11:03:34 am'! -!CodePackage methodsFor: 'naming' stamp: 'jmv 6/5/2018 11:02:21' prior: 16810412! - packageName: aString - packageName _ aString. - description _ 'Please enter a description for this package'. - featureSpec _ FeatureSpec new. - featureSpec provides: (Feature name: packageName version: 1 revision: 0). - hasUnsavedChanges _ self includesAnyCode. - "But reset revision if it was incremented because of marking it dirty!!" - featureSpec provides name: packageName version: 1 revision: 0! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3347-PackageInstallFix-JuanVuletich-2018Jun05-11h03m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3347] on 15 June 2018 at 10:10:07 am'! -!PseudoClass methodsFor: 'fileIn/fileOut' stamp: 'jmv 6/15/2018 10:06:19'! - fileInDefinitionAndMetaclass - self fileInDefinition. - metaClass ifNotNil: [ metaClass fileInDefinition ]! ! -!CodePackageFile methodsFor: 'services' stamp: 'jmv 6/15/2018 10:09:12' prior: 50401040! - install: aFileStream - "Installs the package. Replace all existing code in the CodePackage, removing any code that is not included in us." - | localName newCodePackage pckClass | - - "Give reasonable warnings if there is stuff that can't be properly cleaned. Give the user the chance to abort." - '=============' print. - classesToRemove notEmpty ifTrue: [ - ('classesToRemove: ', classesToRemove printString) print. - '=============' print ]. - methodsToRemove notEmpty ifTrue: [ - 'methodsToRemove: ' print. - methodsToRemove do: [ :methodReference | methodReference print ]. - '=============' print ]. - - "Tirar warning si hay que borrar cosas que no se puede, si hay referencias, etc. Quizas si vamos a borrar el ultimo implementor de un mensaje enviado?" - - "Create, install and answer a (sub)instance of CodePackage" - pckClass _ CodePackage. - classes do: [ :ee | - (ee hasDefinition and: [ee superclassName = 'CodePackage']) ifTrue: [ - ee fileInDefinitionAndMetaclass. - pckClass _ Smalltalk at: ee name ]]. - newCodePackage _ pckClass - named: packageName - createIfAbsent: true - registerIfNew: true. - - localName _ fullName asFileEntry name. - ChangeSet installing: packageName do: [ - newCodePackage - fullFileName: fullName; - sourceSystem: sourceSystem; - description: description; - featureSpec: featureSpec. - aFileStream fileInAnnouncing: 'Installing ', localName, '...'. - methodsToRemove do: [ :methodReference | methodReference actualClass removeSelector: methodReference selector ]. - classesToRemove do: [ :className | (Smalltalk at: className) removeFromSystem ]]. - newCodePackage hasUnsavedChanges: false; triggerEvent: #dirtyFlagChanged. - DataStream initialize. "Just in case" - "If we are installing an already installed package, zap the change set with possible changes done, - as they are irrelevant now: we have the package from disk" - ChangeSet removeChangeSet: (ChangeSet existingOrNewChangeSetForPackage: newCodePackage). - Transcript newLine; show: 'Package ', packageName, ' successfully installed'; newLine. - - "Tirar undeclared al transcript. warning si quedaron undeclared - Es feo que tire an transcript undeclareds que despues no lo son..." - Smalltalk cleanOutUndeclared. - Undeclared notEmpty ifTrue: [ - ('Undeclared: ', Undeclared printString) print ]. - - "Descartar la instancia de CodePackageFile" - ^newCodePackage! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3348-CreatePackageInstance-beforeInstall-JuanVuletich-2018Jun15-10h00m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3345] on 13 June 2018 at 4:12:00 pm'! -!BrowserWindow methodsFor: 'keyboard shortcuts' stamp: 'HAW 6/13/2018 16:07:19'! - systemCatListKey: aChar from: view - - aChar == $r ifTrue: [^ model recent ]. - - ^super systemCatListKey: aChar from: view! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3349-recentClasses-shortcutFix-HernanWilkinson-2018Jun13-15h21m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3345] on 14 June 2018 at 12:30:21 pm'! - -Object subclass: #PopUpMenu - instanceVariableNames: 'labelString lineArray icons ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Menus'! - -!classDefinition: #PopUpMenu category: #'Tools-Menus'! -Object subclass: #PopUpMenu - instanceVariableNames: 'labelString lineArray icons' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Menus'! -!MenuMorph methodsFor: 'construction' stamp: 'HAW 6/14/2018 12:12:12'! - add: aString target: target action: aSymbol argument: arg icon: symbolOrFormOrNil - - ^(self add: aString - target: target - action: aSymbol - argumentList: { arg }) - setIcon: symbolOrFormOrNil; - yourself -! ! -!PopUpMenu methodsFor: 'accessing' stamp: 'HAW 6/14/2018 12:13:38'! - iconAt: aPosition - - ^icons at: aPosition ifAbsent: [ nil ]! ! -!PopUpMenu methodsFor: 'private' stamp: 'HAW 6/14/2018 11:56:15'! -labels: aString lines: anArray icons: iconCollection - - labelString _ aString. - lineArray _ anArray. - icons _ iconCollection -! ! -!PopUpMenu class methodsFor: 'instance creation' stamp: 'HAW 6/14/2018 12:25:34'! - labelArray: labelArray lines: lineArray icons: icons - "Answer an instance of me whose items are in labelArray, with lines - drawn after each item indexed by anArray. 2/1/96 sw" - - labelArray isEmpty ifTrue: [self error: 'Menu must not be zero size']. - ^ self - labels: (String streamContents: - [:stream | - labelArray do: [:each | stream nextPutAll: each; newLine]. - stream skip: -1 "remove last newline"]) - lines: lineArray - icons: icons - -"Example: - (PopUpMenu labelArray: #('frog' 'and' 'toad') lines: #() icons: #()) startUpWithCaption: 'Please pick one.' -"! ! -!PopUpMenu class methodsFor: 'instance creation' stamp: 'HAW 6/14/2018 12:04:54'! - labels: aString lines: anArray icons: icons - "Answer an instance of me whose items are in aString, with lines drawn - after each item indexed by anArray and icons per item." - - ^ self new labels: aString lines: anArray icons: icons! ! -!PopUpMenu class methodsFor: 'dialogs' stamp: 'HAW 6/14/2018 12:21:38'! - confirm: queryString trueChoice: trueChoice falseChoice: falseChoice icons: icons - "Put up a yes/no menu with caption queryString. The actual wording - for the two choices will be as provided in the trueChoice and - falseChoice parameters. Answer true if the response is the true-choice, - false if it's the false-choice. - This is a modal question -- the user must respond one way or the other." - - "PopUpMenu confirm: 'Are you hungry?' trueChoice: 'yes, I''m famished' falseChoice: 'no, I just ate'" - - "PopUpMenu confirm: 'Are you hungry?' trueChoice: 'yes, I''m famished' falseChoice: 'no, I just ate' icons: #(acceptIcon cancelIcon)" - - | menu choice | - menu _ self labelArray: {trueChoice. falseChoice} lines: nil icons: icons. - [(choice _ menu startUpWithCaption: queryString) isNil] whileTrue. - ^ choice = 1! ! -!MVCMenuMorph class methodsFor: 'instance creation' stamp: 'HAW 6/14/2018 12:13:56' prior: 50397564! - from: aPopupMenu title: titleStringOrNil - "Answer a MenuMorph constructed from the given PopUpMenu. Used to simulate MVC-style menus in a Morphic-only world." - - | menu items lines selections labelString j emphasis | - menu _ self new. - titleStringOrNil ifNotNil: [ - titleStringOrNil isEmpty ifFalse: [menu addTitle: titleStringOrNil]]. - labelString _ aPopupMenu labelString. - items _ labelString asString lines. - (labelString is: #Text) ifTrue: [ - "Pass along text emphasis if present" - j _ 1. - items _ items collect: [ :item | - j _ labelString asString findString: item startingAt: j. - emphasis _ TextEmphasis new emphasisCode: (labelString emphasisAt: j). - item asText addAttribute: emphasis]]. - lines _ aPopupMenu lineArray. - lines ifNil: [lines _ #()]. - menu cancelValue: 0. - menu defaultTarget: menu. - selections _ (1 to: items size) asArray. - 1 to: items size do: [ :i | - menu add: (items at: i) target: menu action: #selectMVCItem: argument: (selections at: i) icon: (aPopupMenu iconAt: i). - (lines includes: i) ifTrue: [menu addLine]]. - ^ menu -! ! -!PopUpMenu methodsFor: 'private' stamp: 'HAW 6/14/2018 11:56:37' prior: 16891046! - labels: aString lines: anArray - - self labels: aString lines: anArray icons: #()! ! -!PopUpMenu class methodsFor: 'instance creation' stamp: 'HAW 6/14/2018 12:02:45' prior: 16891064! - labelArray: labelArray lines: lineArray - - ^self labelArray: labelArray lines: lineArray icons: #()! ! -!PopUpMenu class methodsFor: 'instance creation' stamp: 'HAW 6/14/2018 12:04:21' prior: 16891089! - labels: aString lines: anArray - "Answer an instance of me whose items are in aString, with lines drawn - after each item indexed by anArray." - - ^ self labels: aString lines: anArray icons: #()! ! -!PopUpMenu class methodsFor: 'dialogs' stamp: 'HAW 6/14/2018 12:18:59' prior: 50395775! - confirm: queryString - "Put up a yes/no menu with caption queryString. Answer true if the - response is yes, false if no. This is a modal question--the user must - respond yes or no." - - " - PopUpMenu confirm: 'Are you hungry?' - " - - ^ self confirm: queryString trueChoice: 'Yes' falseChoice: 'No' icons: #(acceptIcon cancelIcon)! ! -!PopUpMenu class methodsFor: 'dialogs' stamp: 'HAW 6/14/2018 12:17:00' prior: 16891125! - confirm: queryString orCancel: cancelBlock - "Put up a yes/no/cancel menu with caption aString. Answer true if - the response is yes, false if no. If cancel is chosen, evaluate - cancelBlock. This is a modal question--the user must respond yes or no." - - "PopUpMenu confirm: 'Reboot universe' orCancel: [^'Nevermind']" - - | menu choice | - menu _ self labelArray: {'Yes'. 'No'. 'Cancel'} lines: #() icons: #(acceptIcon cancelIcon collapseIcon). - choice _ menu startUpWithCaption: queryString. - choice = 1 ifTrue: [^ true]. - choice = 2 ifTrue: [^ false]. - ^ cancelBlock value! ! -!PopUpMenu class methodsFor: 'dialogs' stamp: 'HAW 6/14/2018 12:22:28' prior: 16891144! - confirm: queryString trueChoice: trueChoice falseChoice: falseChoice - - "See #confirm:trueChoice:falseChoice:icons:" - - ^self confirm: queryString trueChoice: trueChoice falseChoice: falseChoice icons: #()! ! - -PopUpMenu removeSelector: #icons! - -Object subclass: #PopUpMenu - instanceVariableNames: 'labelString lineArray icons' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Menus'! - -!classDefinition: #PopUpMenu category: #'Tools-Menus'! -Object subclass: #PopUpMenu - instanceVariableNames: 'labelString lineArray icons' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Menus'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3350-IconsInPopUpMenu-HernanWilkinson-2018Jun14-11h15m-HAW.1.cs.st----! - -----SNAPSHOT----#(15 June 2018 11:06:28.139396 am) Cuis5.0-3350-v3.image priorSource: 2196430! - -----QUIT----#(15 June 2018 11:06:54.952746 am) Cuis5.0-3350-v3.image priorSource: 2246729! - -----STARTUP----#(11 July 2018 3:43:35.235421 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3350-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3350] on 15 June 2018 at 8:06:45 pm'! -!Theme methodsFor: 'private - shout mappings' stamp: 'jmv 6/15/2018 19:47:32'! - blockLevelOne - - ^ #( - blockStart1 - blockEnd1 - leftParenthesis1 - rightParenthesis1 - )! ! -!Theme methodsFor: 'private - shout mappings' stamp: 'jmv 6/15/2018 19:44:15'! - blockLevelThree - - ^ #( - blockStart3 - blockEnd3 - leftParenthesis3 - rightParenthesis3 - ) -! ! -!Theme methodsFor: 'private - shout mappings' stamp: 'jmv 6/15/2018 19:45:51'! - blockLevelTwo - - ^ #( - blockStart2 - blockEnd2 - leftParenthesis2 - rightParenthesis2 - ) -! ! -!Theme methodsFor: 'private - shout mappings' stamp: 'jmv 6/15/2018 19:53:16'! - blockLevelZero - - ^ #( - blockStart - blockEnd - leftParenthesis - rightParenthesis - )! ! -!Theme methodsFor: 'private - shout mappings' stamp: 'jmv 6/15/2018 19:53:22' prior: 16935803! - defaults - - ^ #( - default - arrayStart - arrayEnd - arrayStart1 - arrayEnd1 - leftBrace - rightBrace - cascadeSeparator - chainSeparator - statementSeparator - externalCallType - externalCallTypePointerIndicator - blockArgColon - )! ! -!Theme methodsFor: 'private - shout mappings' stamp: 'jmv 6/15/2018 20:06:29' prior: 16935821! - generateShoutConfig - - | styles colors | - styles := OrderedCollection new. - colors := self shout as: Dictionary. - - { - {self undefined. colors at: #undefined}. - {self defaults . colors at: #defaults}. - {self pseudoVariables . colors at: #pseudoVariables}. - {self literals . colors at: #literals}. - {self instVar . colors at: #instVar}. - {self messages . colors at: #messages}. - {self blockLevelZero . colors at: #blockLevelZero}. - {self blockLevelOne . colors at: #blockLevelOne}. - {self blockLevelTwo . colors at: #blockLevelTwo}. - {self blockLevelThree . colors at: #blockLevelThree}. - {self blockLevelFour . colors at: #blockLevelFour}. - {self blockLevelFive . colors at: #blockLevelFive}. - {self blockLevelSix . colors at: #blockLevelSix}. - {self blockLevelSeven . colors at: #blockLevelSeven}. - {self tempBar . colors at: #tempBar}. - {self methodTags . colors at: #methodTags . #bold}. - {self globals . colors at: #defaults . #bold}. - {self incompleteMessages . colors at: #incompleteMessages . #underlined}. - {self argumentTypes . colors at: #arguments . self italic}. - {self symbols . colors at: #messages . #bold}. - {self pattern . nil . #bold}. - {self ansiAssignment . nil . #bold}. - {self assignment . nil . #(#bold #withST80Glyphs)}. - {self return . nil . #(#bold #withST80Glyphs)}. - {self tempVars . colors at: #tempVars . self italic}. - {self blockTemps . colors at: #tempBar . self italic} - } do: [ :style | - styles addAll: - (style first - collect: [ :category | | elements | - elements _ style asOrderedCollection. - elements at: 1 put: category. - Array withAll: elements ])]. - - "Miscellaneous remainder after factoring out commonality:" - styles addAll: { - {#unfinishedString . colors at: #undefined . #normal}. - {#undefinedIdentifier . colors at: #undefined .#bold}. - {#unfinishedComment . colors at: #pseudoVariables . self italic}. - {#comment . colors at: #comment . self italic}. - {#string . colors at: #instVar . #normal}. - {#literal . nil . self italic}. - {#incompleteIdentifier . colors at: #tempVars . {#italic. #underlined}}. - {#classVar . colors at: #tempVars . #bold}. - }. - - ^ styles! ! -!Theme methodsFor: 'private - shout mappings' stamp: 'jmv 6/15/2018 19:45:42' prior: 16935897! - instVar - ^ #( - instVar - )! ! -!Theme methodsFor: 'private - shout mappings' stamp: 'jmv 6/15/2018 19:44:23' prior: 16935909! - literals - - ^ #( - character - integer - number - - - )! ! -!Theme methodsFor: 'shout' stamp: 'jmv 6/15/2018 20:06:11' prior: 16936786! - shout - "Color symbols as an association list. - SHTextStylerST80 initialize - " - - ^ { - #defaults -> #black. - #undefined -> #red. - #comment -> #(green muchDarker). - #methodTags -> #(green muchDarker). - #pseudoVariables -> #(red muchDarker). - #literals -> #(green muchDarker). - #messages -> #(blue darker). - #arguments -> #(cyan muchDarker). - #instVar -> #(magenta muchDarker). - #incompleteMessages -> #(gray veryMuchDarker). - #blockLevelZero -> #black. - #blockLevelOne -> #brown. - #blockLevelTwo -> #magenta. - #blockLevelThree -> #red. - #blockLevelFour -> #(orange darker). - #blockLevelFive -> #(orange muchDarker). - #blockLevelSix -> #(green muchDarker). - #blockLevelSeven -> #blue. - #tempBar -> #gray. - #tempVars -> #(gray muchDarker). - }! ! - -Theme removeSelector: #firstBlockLevel! - -Theme removeSelector: #firstBlockLevel! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - SHTextStylerST80 initialize! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3351-SyntaxHighlightEnhancements-JuanVuletich-2018Jun15-19h59m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3351] on 21 June 2018 at 2:06:07 pm'! -!PluggableMorph methodsFor: 'access' stamp: 'jmv 6/20/2018 22:42:04'! - balloonText - "Answer balloon help text or nil, if no help is available. - NB: subclasses may override such that they programatically - construct the text, for economy's sake, such as model phrases in - a Viewer" - - | balloonText | - balloonText _ super balloonText. - balloonText isSymbol ifTrue: [ ^model perform: balloonText ]. - ^ balloonText! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 6/20/2018 22:38:58' prior: 16875792! - setBalloonText: stringTextOrSymbol - "Set receiver's balloon help text. Pass nil to remove the help." - - stringTextOrSymbol - ifNil: [ self removeProperty: #balloonText ] - ifNotNil: [ - self setProperty: #balloonText - toValue: ((stringTextOrSymbol is: Text) - ifTrue: [ stringTextOrSymbol asString ] - ifFalse: [ stringTextOrSymbol ])]! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 6/20/2018 22:33:30' prior: 50341582! - addButtonFor: aMorph - - | button | - aMorph == self ifFalse: [ - button _ PluggableButtonMorph - model: aMorph - stateGetter: nil - action: #toggleCollapseOrShow. - button - color: self color; - icon: (aMorph imageForm: 32); - setBalloonText: #label. - button icon: button magnifiedIcon. - viewBox - addMorph: button - fixedWidth: self defaultHeight ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3352-KeepTaskButtonBalloonUpdated-JuanVuletich-2018Jun21-14h05m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3351] on 21 June 2018 at 2:06:28 pm'! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 6/21/2018 13:41:37' prior: 50371184! - parse: isAMethod - "Parse the receiver's text. If isAMethod is true - then treat text as a method, if false as an - expression with no message pattern" - - self initializeInstanceVariables. - sourcePosition _ 1. - arguments _ Dictionary new. - temporaries _ Dictionary new. - blockDepth _ bracketDepth := 0. - blockDepths _ OrderedCollection with: blockDepth. - blockDepthsStartIndexes _ OrderedCollection with: sourcePosition. - ranges ifNil: [ ranges := OrderedCollection new: 100] ifNotNil: [ ranges reset]. - errorBlock _ [^false]. - [ - self scanNext. - isAMethod - ifTrue: [ - self parseMessagePattern. - self parsePragmaSequence]. - self parseMethodTemporaries. - isAMethod ifTrue: [self parsePragmaSequence]. - "Iterate once for methods, but pontentially several times for workspaces - (to recover after errors, for possible good next lines or chunks)" - [ sourcePosition <= source size ] whileTrue: [ - self parseStatementList. - currentToken ifNotNil: [ - "Only if we are parsing a method, consider everything after this point as error." - isAMethod ifTrue: [self error]] - ]. - ] ensure: [errorBlock _ nil]. - ^true! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3353-ShoutWorkspacesBychunks-JuanVuletich-2018Jun21-14h06m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3353] on 25 June 2018 at 12:07:56 pm'! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2018 12:03:06'! - argument - "Answer the argument of the receiver (see Complex | argument). - Answer is in (-Pi .. +Pi] - Note: Assume the convention of 0+0i having argument=0" - - ^self < 0 - ifFalse: [0] - ifTrue: [Float pi]! ! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2018 12:03:18'! - phase - "Answer the argument of the receiver. - Answer is in (-Pi .. +Pi] - Note: Assume the convention of 0+0i having argument=0" - - ^ self argument! ! -!Number methodsFor: 'arithmetic' stamp: 'jmv 6/25/2018 11:58:51' prior: 16879685! - arg - "Answer the argument of the receiver (see Complex | arg). - Note: #argument and #phase assume the convention of 0+0i having argument=0" - - self isZero ifTrue: [self error: 'Zero (0 + 0 i) does not have an argument.']. - ^self < 0 - ifFalse: [0] - ifTrue: [Float pi]! ! -!Complex methodsFor: 'accessing' stamp: 'jmv 6/25/2018 12:01:46' prior: 16822295! - argument - "Answer the argument of the receiver. - Answer is in (-Pi .. +Pi]" - - self isZero ifTrue: [ ^0.0 ]. - ^imaginary arcTan: real! ! -!Complex methodsFor: 'accessing' stamp: 'jmv 6/25/2018 11:52:36' prior: 16822305! - magnitude - "Answer the distance of the receiver from zero (0 + 0 i)." - - ^ self abs! ! -!Complex methodsFor: 'accessing' stamp: 'jmv 6/25/2018 12:03:15' prior: 16822311! - phase - "Answer the argument of the receiver. - Answer is in (-Pi .. +Pi] - Note: Assume the convention of 0+0i having argument=0" - - ^ self argument! ! -!Complex methodsFor: 'arithmetic' stamp: 'jmv 6/25/2018 12:02:03' prior: 16822400! - arg - "Answer the argument of the receiver. - Answer is in (-Pi .. +Pi] - Note: #argument and #phase assume the convention of 0+0i having argument=0" - - self isZero ifTrue: [self error: 'zero has no argument.']. - ^imaginary arcTan: real! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3354-Complex-enh-JuanVuletich-2018Jun25-10h42m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3348] on 30 June 2018 at 7:27:04 pm'! -!PopUpMenu class methodsFor: 'instance creation' stamp: 'HAW 6/30/2018 19:26:48'! - labels: aString icons: icons - "Answer an instance of me whose items are in aString." - - ^self labels: aString lines: nil icons: icons! ! -!PopUpMenu class methodsFor: 'dialogs' stamp: 'HAW 6/30/2018 19:26:35' prior: 50380089! -inform: aString - "PopUpMenu inform: 'I like Cuis'" - - UISupervisor whenUIinSafeState: [ (self labels: ' OK ' icons: #(emblemImportantIcon)) startUpWithCaption: aString ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3355-inform_withIcon-HernanWilkinson-2018Jun30-19h26m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3348] on 1 July 2018 at 1:15:10 pm'! -!UndeclaredVariable methodsFor: 'exception handling' stamp: 'HAW 7/1/2018 13:05:18'! - defaultAction - - | labels actions lines caption choice icons | - - labels _ OrderedCollection new. - actions _ OrderedCollection new. - lines _ OrderedCollection new. - icons _ OrderedCollection new. - - self createMenuOptionsAddingTo: labels actions: actions icons: icons lines: lines. - caption _ 'Unknown variable: ' , name , ' please correct, or cancel:'. - choice _ (PopUpMenu labelArray: labels lines: lines icons: icons) startUpWithCaption: caption. - - self resume: (actions at: choice ifAbsent:[ nil ]).! ! -!UndeclaredVariable methodsFor: 'exception handling - private' stamp: 'HAW 7/1/2018 12:59:52'! - addAlternativesTo: labels actions: actions icons: icons - - | alternatives | - - alternatives _ parser possibleVariablesFor: name. - alternatives do: [ :each | - labels add: each. - actions add: [ parser substituteVariable: each atInterval: interval ]. - icons add: nil ]. -! ! -!UndeclaredVariable methodsFor: 'exception handling - private' stamp: 'HAW 7/1/2018 12:55:34'! - addCancelTo: labels actions: actions icons: icons - - labels add: 'cancel'. - actions add: nil. - icons add: #cancelIcon. - -! ! -!UndeclaredVariable methodsFor: 'exception handling - private' stamp: 'HAW 7/1/2018 12:50:36'! - addGlobalVariableOptionsTo: labels actions: actions - - labels add: 'define new class'. - actions add: [ parser defineClass: name ]. - - labels add: 'declare global'. - actions add: [ parser declareGlobal: name ]. - - parser canDeclareClassVariable ifTrue: [ - labels add: 'declare class variable'. - actions add: [ parser declareClassVar: name ]] -! ! -!UndeclaredVariable methodsFor: 'exception handling - private' stamp: 'HAW 7/1/2018 12:49:43'! - addLocalVariableOptionsTo: labels actions: actions - - labels add: 'declare block-local temp'. - actions add: [ parser declareTemp: name at: #block ]. - - labels add: 'declare method temp'. - actions add: [ parser declareTemp: name at: #method ]. - - parser canDeclareInstanceVariable ifTrue: [ - labels add: 'declare instance'. - actions add: [ parser declareInstVar: name ]]! ! -!UndeclaredVariable methodsFor: 'exception handling - private' stamp: 'HAW 7/1/2018 12:52:33'! - addOptionsTo: labels actions: actions icons: icons - - name first isLowercase - ifTrue: [ self addLocalVariableOptionsTo: labels actions: actions ] - ifFalse: [ self addGlobalVariableOptionsTo: labels actions: actions ]. - labels size timesRepeat: [ icons add: #listAddIcon ]. - -! ! -!UndeclaredVariable methodsFor: 'exception handling - private' stamp: 'HAW 7/1/2018 12:59:24'! - createMenuOptionsAddingTo: labels actions: actions icons: icons lines: lines - - self addOptionsTo: labels actions: actions icons: icons. - lines add: labels size. - self addAlternativesTo: labels actions: actions icons: icons. - lines add: labels size. - self addCancelTo: labels actions: actions icons: icons.! ! -!UndefinedVariable methodsFor: 'exception handling' stamp: 'HAW 7/1/2018 12:17:22'! - defaultAction - - | shouldResume | - - shouldResume := PopUpMenu confirm: name, ' appears to be\undefined at this point.\Proceed anyway?' withNewLines. - ^ self resume: shouldResume ! ! -!UnknownSelector methodsFor: 'exception handling' stamp: 'HAW 7/1/2018 13:07:30'! - defaultAction - - | alternatives labels lines caption choice icons | - - alternatives := Symbol possibleSelectorsFor: name. - labels := Array streamContents: [:s | s nextPut: name; nextPutAll: alternatives; nextPut: 'cancel']. - lines := {1. alternatives size + 1}. - icons := Array new: labels size. - icons at: 1 put: #acceptIcon. - icons at: icons size put: #cancelIcon. - caption := 'Unknown selector, please\confirm, correct, or cancel' withNewLines. - - choice := (PopUpMenu labelArray: labels lines: lines icons: icons) startUpWithCaption: caption. - choice = 1 ifTrue: [self resume: name asSymbol]. - choice = labels size ifTrue: [self resume: nil]. - self resume: (alternatives at: choice - 1 ifAbsent: [ nil ]) - -! ! -!UnusedVariable methodsFor: 'exception handling' stamp: 'HAW 7/1/2018 12:14:01'! - defaultAction - - | shouldResume | - - shouldResume := PopUpMenu confirm: name, ' appears to be\unused in this method.\OK to remove it?' withNewLines. - self resume: shouldResume ! ! - -UnusedVariable removeSelector: #openMenuIn:! - -UnusedVariable removeSelector: #openMenuIn:! - -UnknownSelector removeSelector: #openMenuIn:! - -UnknownSelector removeSelector: #openMenuIn:! - -UndefinedVariable removeSelector: #openMenuIn:! - -UndefinedVariable removeSelector: #openMenuIn:! - -UndeclaredVariable removeSelector: #addAlternative:to:actions:icons:! - -UndeclaredVariable removeSelector: #openMenuIn:! - -UndeclaredVariable removeSelector: #openMenuIn:! - -ParserNotification removeSelector: #defaultAction! - -ParserNotification removeSelector: #defaultAction! - -ParserNotification removeSelector: #openMenuIn:! - -ParserNotification removeSelector: #openMenuIn:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3356-ParserNotification-Enhancements-HernanWilkinson-2018Jul01-12h05m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3356] on 4 July 2018 at 5:23:57 pm'! -!Complex class methodsFor: 'instance creation' stamp: 'jmv 7/4/2018 17:03:13'! - magnitude: rho phase: theta - ^ self abs: rho arg: theta! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3357-Complex-rho-phase-JuanVuletich-2018Jul04-16h36m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3348] on 2 July 2018 at 7:56:47 pm'! -!SystemDictionary methodsFor: 'browsing' stamp: 'HAW 7/2/2018 19:55:29' prior: 16924171! - browseMessageList: messageList name: labelString autoSelect: autoSelectString - | title aSize | - "Create and schedule a MessageSet browser on the message list." - - messageList size = 0 ifTrue: - [^ PopUpMenu inform: ('There are no\' , labelString) withNewLines ]. - - title _ (aSize _ messageList size) > 1 - ifFalse: [ labelString ] - ifTrue: [ '[', aSize printString, '] ', labelString]. - - MessageSetWindow - openMessageList: messageList - label: title - autoSelect: autoSelectString! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3358-inform-not-label-CuisCore-HernanWilkinson-2018Jul02-19h53m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3348] on 2 July 2018 at 8:04:58 pm'! -!SystemDictionary methodsFor: 'ui' stamp: 'HAW 7/2/2018 20:04:12' prior: 16923767! - confirmRemovalOf: aSelector on: aClass - "Determine if it is okay to remove the given selector. Answer 1 if it - should be removed, 2 if it should be removed followed by a senders - browse, and 3 if it should not be removed." - | count aMenu answer caption allCalls | - allCalls _ self allCallsOn: aSelector. - (count _ allCalls size) = 0 - ifTrue: [^ 1]. - "no senders -- let the removal happen without warning" - count = 1 - ifTrue: [(allCalls first actualClass == aClass - and: [allCalls first methodSymbol == aSelector]) - ifTrue: [^ 1]]. - "only sender is itself" - aMenu _ PopUpMenu labels: 'Remove it -Remove, then browse senders -Don''t remove, but show me those senders -Forget it -- do nothing -- sorry I asked' - icons: #(acceptIcon acceptIcon cancelIcon cancelIcon). - - caption _ 'This message has ' , count printString , ' sender'. - count > 1 - ifTrue: [caption _ caption copyWith: $s]. - answer _ aMenu startUpWithCaption: caption. - answer = 3 - ifTrue: [self - browseMessageList: allCalls - name: 'Senders of ' , aSelector - autoSelect: aSelector keywords first]. - answer = 0 - ifTrue: [answer _ 3]. - "If user didn't answer, treat it as cancel" - ^ answer min: 3! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3359-icon-on-method-removal-HernanWilkinson-2018Jul02-19h56m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3359] on 5 July 2018 at 4:03:31 pm'! -!Number methodsFor: 'accessing' stamp: 'jmv 7/5/2018 15:47:19'! - imaginary - "Compatibility with Complex numbers" - ^ 0! ! -!Number methodsFor: 'accessing' stamp: 'jmv 7/5/2018 15:47:55'! - real - "Compatibility with Complex numbers" - ^ self! ! -!Number methodsFor: 'accessing' stamp: 'jmv 7/5/2018 15:48:09' prior: 50402132! - argument - "Compatibility with Complex numbers. - Answer the argument of the receiver (see Complex | argument). - Answer is in (-Pi .. +Pi] - Note: Assume the convention of 0+0i having argument=0" - - ^self < 0 - ifFalse: [0] - ifTrue: [Float pi]! ! -!Number methodsFor: 'accessing' stamp: 'jmv 7/5/2018 15:48:20' prior: 16880163! - magnitude - "Compatibility with Complex numbers" - ^self abs! ! -!Number methodsFor: 'accessing' stamp: 'jmv 7/5/2018 15:48:29' prior: 50402141! - phase - "Compatibility with Complex numbers. - Answer the argument of the receiver. - Answer is in (-Pi .. +Pi] - Note: Assume the convention of 0+0i having argument=0" - - ^ self argument! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3360-Number-ComplexProtocol-JuanVuletich-2018Jul05-10h07m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3345] on 5 July 2018 at 2:59:23 pm'! -!CodePackage methodsFor: 'accessing' stamp: 'HAW 7/5/2018 14:59:10' prior: 16810690! - hasUnsavedChanges - - "Might be nil and breaks when a code package window is open and loading packages - Hernan - This is not a lazy initialization, the variable is set to non nil value only when certain." - ^hasUnsavedChanges = true! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3361-FixPossibleWalkbackInPackageLoading-HernanWilkinson-2018Jul05-14h59m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3348] on 5 July 2018 at 3:17:35 pm'! -!Collection methodsFor: 'enumerating' stamp: 'HAW 7/5/2018 14:49:22'! - groupBy: keyBlock - - ^ self - inject: Dictionary new - into: [ :groupedCollection :elementToGroup | | group | - group := groupedCollection at: (keyBlock value: elementToGroup) ifAbsentPut: [ OrderedCollection new ]. - group add: elementToGroup. - groupedCollection ] - ! ! -!Collection methodsFor: 'enumerating' stamp: 'HAW 7/5/2018 15:14:50' prior: 16814398! - groupBy: keyBlock having: selectBlock - "Like in SQL operation - Split the receivers contents into collections of - elements for which keyBlock returns the same results, and return those - collections allowed by selectBlock. " - - ^ (self groupBy: keyBlock) select: selectBlock! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3362-groupBy-HernanWilkinson-2018Jul02-20h04m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3348] on 5 July 2018 at 4:00:10 pm'! - -Object subclass: #DynamicMenuBuilder - instanceVariableNames: 'title defaultTarget menuOptionsSelector menu items groups ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #DynamicMenuBuilder category: #'Morphic-Menus'! -Object subclass: #DynamicMenuBuilder - instanceVariableNames: 'title defaultTarget menuOptionsSelector menu items groups' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! -!DynamicMenuBuilder methodsFor: 'initialization' stamp: 'HAW 7/5/2018 15:42:29'! - initializeTitled: aTitle targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector - - title := aTitle. - defaultTarget := aDefaultTarget. - menuOptionsSelector := aMenuOptionsSelector ! ! -!DynamicMenuBuilder methodsFor: 'building - private' stamp: 'HAW 7/5/2018 15:59:10'! - addGroupSeparation - - menu addLine - ! ! -!DynamicMenuBuilder methodsFor: 'building - private' stamp: 'HAW 7/5/2018 15:56:23'! - addGroupedMenuOptionsToMenu - - groups := items groupBy: [ :item | item at: #itemGroup ]. - groups keys asSortedCollection - do: [ :group | self addMenuOptionsOfGroup: group ] - separatedBy: [ self addGroupSeparation ]. -! ! -!DynamicMenuBuilder methodsFor: 'building - private' stamp: 'HAW 7/5/2018 15:55:59'! - addMenuOptionsOfGroup: group - - | groupMenuOptions | - - groupMenuOptions := (groups at: group) asSortedCollection: [ :leftItem :rightItem | (leftItem at: #itemOrder) < (rightItem at: #itemOrder) ]. - menu addItemsFromDictionaries: groupMenuOptions.! ! -!DynamicMenuBuilder methodsFor: 'building - private' stamp: 'HAW 7/5/2018 15:53:08'! - collectMenuOptions - - items := (Smalltalk allClassesImplementing: menuOptionsSelector) - collect: [ :item | item isMeta ifTrue: [ item soleInstance perform: menuOptionsSelector ] ] - thenSelect: [ :item | item notNil ].! ! -!DynamicMenuBuilder class methodsFor: 'instance creation' stamp: 'HAW 7/5/2018 15:41:58'! - titled: aTitle targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector - - ^self new initializeTitled: aTitle targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector - -! ! -!DynamicMenuBuilder methodsFor: 'building' stamp: 'HAW 7/5/2018 15:57:34'! - build - - self - createMenu; - collectMenuOptions; - addGroupedMenuOptionsToMenu. - - ^ menu.! ! -!DynamicMenuBuilder methodsFor: 'building - private' stamp: 'HAW 7/5/2018 15:52:31'! - createMenu - - menu := MenuMorph entitled: title. - menu - defaultTarget: defaultTarget; - addStayUpIcons! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'HAW 7/5/2018 15:47:16' prior: 50397000! - openMenu - "Build the open window menu for the world." - - ^(DynamicMenuBuilder titled: 'Open...' targeting: self collectingMenuOptionsWith: #worldMenuForOpenGroup) build - - ! ! - -Object subclass: #DynamicMenuBuilder - instanceVariableNames: 'title defaultTarget menuOptionsSelector menu items groups' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #DynamicMenuBuilder category: #'Morphic-Menus'! -Object subclass: #DynamicMenuBuilder - instanceVariableNames: 'title defaultTarget menuOptionsSelector menu items groups' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3363-DynamicMenuBuilder-HernanWilkinson-2018Jul05-15h17m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3348] on 5 July 2018 at 6:42:58 pm'! -!DynamicMenuBuilder methodsFor: 'testing' stamp: 'HAW 7/5/2018 18:26:14'! - hasTitle - - ^title ~= self class noTitle ! ! -!DynamicMenuBuilder methodsFor: 'building - private' stamp: 'HAW 7/5/2018 18:41:03'! - classesProvidingMenuOptions - - ^(Smalltalk allClassesImplementing: menuOptionsSelector) select: [ :aClass | aClass isMeta ]! ! -!DynamicMenuBuilder class methodsFor: 'instance creation' stamp: 'HAW 7/5/2018 18:25:03'! - targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector - - ^self titled: self noTitle targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector - -! ! -!DynamicMenuBuilder class methodsFor: 'defaults' stamp: 'HAW 7/5/2018 18:25:09'! - noTitle - - ^nil! ! -!DynamicMenuBuilder class methodsFor: 'building' stamp: 'HAW 7/5/2018 18:27:20'! - buildTargeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector - - ^(self targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector) build! ! -!DynamicMenuBuilder class methodsFor: 'building' stamp: 'HAW 7/5/2018 18:27:45'! - buildTitled: aTitle targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector - - ^(self titled: aTitle targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector) build! ! -!TheWorldMenu class methodsFor: 'menu building' stamp: 'HAW 7/5/2018 18:37:46'! - worldMenuOptions - - ^`{{ - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Open...'. - #selector -> #openOpenMenu. - #icon -> #openIcon. - #balloonText -> 'Submenu to open various system tools'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'New morph...'. - #selector -> #newMorph. - #icon -> #morphsIcon. - #balloonText -> 'Offers a variety of ways to create new objects'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Preferences...'. - #selector -> #openPreferencesMenu. - #icon -> #preferencesIcon. - #balloonText -> 'Opens a menu offering many controls over appearance and system preferences.'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'Windows...'. - #selector -> #openWindowsMenu. - #icon -> #windowIcon. - #balloonText -> 'Manage open windows'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 50. - #label -> 'Help...'. - #selector -> #openHelpMenu. - #icon -> #helpIcon. - #balloonText -> 'Opens a menu of useful items for updating the system, determining what version you are running, and much else'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Changes...'. - #selector -> #openChangesMenu. - #icon -> #changesIcon. - #balloonText -> 'Opens a menu of useful tools for dealing with changes'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Debug...'. - #selector -> #openDebugMenu. - #icon -> #debugIcon. - #balloonText -> 'a menu of debugging items'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'Restore Display (r)'. - #object -> #myWorld. - #selector -> #restoreDisplay. - #icon -> #displayIcon. - #balloonText -> 'Repaint the screen -- useful for removing unwanted display artifacts, lingering cursors, etc.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Save'. - #object -> Smalltalk. - #selector -> #saveSession. - #icon -> #saveIcon. - #balloonText -> 'Save the current version of the image on disk'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Save as...'. - #object -> Smalltalk. - #selector -> #saveAs. - #icon -> #saveAsIcon. - #balloonText -> 'Save the current version of the image on disk under a new name.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'Save as New Version'. - #object -> Smalltalk. - #selector -> #saveAsNewVersion. - #icon -> #saveAsNewVersionIcon. - #balloonText -> ('Save the current image a new version-stamped name\and save it under that name on disk.\', - 'Clear all user preferences and user state (class vars).') withNewLines. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 40. - #label -> 'Save and Quit'. - #selector -> #saveAndQuit. - #icon -> #saveAndQuitIcon. - #balloonText -> 'Save the image and quit out of Cuis.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 50. - #label -> 'Quit'. - #selector -> #quitSession. - #icon -> #quitIcon. - #balloonText -> 'Quit out of Cuis.'. - } asDictionary. -}`! ! -!Workspace class methodsFor: 'menu-world' stamp: 'HAW 7/5/2018 18:03:00' prior: 50393665! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'Workspace'. - #object -> Workspace. - #selector -> #openWorkspace. - #icon -> #terminalIcon. - #balloonText -> 'A window for evaluating Smalltalk expressions'. - } asDictionary}`! ! -!Transcripter class methodsFor: 'menu-world' stamp: 'HAW 7/5/2018 18:02:53' prior: 50393678! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Emergency Evaluator'. - #object -> Transcripter. - #selector -> #emergencyEvaluator. - #icon -> #emblemImportantIcon. - #balloonText -> 'When all else fails...'. - } asDictionary}`! ! -!TextEditor class methodsFor: 'menu-world' stamp: 'HAW 7/5/2018 18:02:41' prior: 50393691! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Text Editor'. - #object -> TextEditor. - #selector -> #openTextEditor. - #icon -> #textEditorIcon. - #balloonText -> 'A window for composing text'. - } asDictionary}`! ! -!CodePackageListWindow class methodsFor: 'menu-world' stamp: 'HAW 7/5/2018 18:01:57' prior: 50393704! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Installed Packages'. - #object -> CodePackageListWindow. - #selector -> #openPackageList. - #icon -> #packageIcon. - #balloonText -> 'A tool for managing Packages (optional units of code) installed in the system'. - } asDictionary}`! ! -!BrowserWindow class methodsFor: 'menu-world' stamp: 'HAW 7/5/2018 18:01:26' prior: 50393718! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Browser'. - #object -> BrowserWindow. - #selector -> #openBrowser. - #icon -> #editFindReplaceIcon. - #balloonText -> 'A Smalltalk code browser, for studying and modifying the system'. - } asDictionary}`! ! -!MessageNamesWindow class methodsFor: 'menu-world' stamp: 'HAW 7/5/2018 18:02:18' prior: 50393732! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'Message Names'. - #object -> MessageNamesWindow. - #selector -> #openMessageNames. - #icon -> #inspectIcon. - #balloonText -> 'A tool for finding and editing methods that contain any given keyword in their names.'. - } asDictionary}`! ! -!ChangeSorterWindow class methodsFor: 'menu-world' stamp: 'HAW 7/5/2018 18:01:49' prior: 50393747! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Change Sorter'. - #object -> ChangeSorterWindow. - #selector -> #openChangeSorter. - #icon -> #halfRefreshIcon. - #balloonText -> 'A tool allowing you to view the methods in a Change Set, especially changes to the Base System'. - } asDictionary}`! ! -!FileListWindow class methodsFor: 'menu-world' stamp: 'HAW 7/5/2018 18:02:10' prior: 50393762! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'File List'. - #object -> FileListWindow. - #selector -> #openFileList. - #icon -> #systemFileManagerIcon. - #balloonText -> 'An explorer of the File System'. - } asDictionary}`! ! -!ProcessBrowserWindow class methodsFor: 'menu-world' stamp: 'HAW 7/5/2018 18:02:24' prior: 50393775! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Process Browser'. - #object -> ProcessBrowserWindow. - #selector -> #openProcessBrowser. - #icon -> #systemMonitorIcon. - #balloonText -> 'A tool to monitor and manage Smalltalk processes'. - } asDictionary}`! ! -!TestRunnerWindow class methodsFor: 'menu-world' stamp: 'HAW 7/5/2018 18:02:30' prior: 50393789! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'SUnit Test Runner'. - #object -> TestRunnerWindow. - #selector -> #openTestRunner. - #icon -> #weatherFewCloudsIcon. - #balloonText -> 'Smalltalk''s testing framework'. - } asDictionary}`! ! -!TranscriptWindow class methodsFor: 'menu-world' stamp: 'HAW 7/5/2018 18:02:47' prior: 50393802! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 10. - #itemOrder -> 50. - #label -> 'Transcript'. - #object -> TranscriptWindow. - #selector -> #openTranscript. - #icon -> #printerIcon. - #balloonText -> 'A window showing contents of the System Transcript'. - } asDictionary}`! ! -!DynamicMenuBuilder methodsFor: 'building - private' stamp: 'HAW 7/5/2018 18:41:32' prior: 50402608! - collectMenuOptions - - items := OrderedCollection new. - self classesProvidingMenuOptions do: [ :aClass | items addAll: (aClass soleInstance perform: menuOptionsSelector) ]. - ! ! -!DynamicMenuBuilder methodsFor: 'building - private' stamp: 'HAW 7/5/2018 18:25:48' prior: 50402633! - createMenu - - menu := self hasTitle ifTrue: [ MenuMorph entitled: title] ifFalse: [ MenuMorph new ]. - menu - defaultTarget: defaultTarget; - addStayUpIcons! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'HAW 7/5/2018 18:28:15' prior: 50396731! - buildWorldMenu - "Build the menu that is put up when the screen-desktop is clicked on" - - ^DynamicMenuBuilder buildTargeting: self collectingMenuOptionsWith: #worldMenuOptions - ! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'HAW 7/5/2018 18:28:15' prior: 50402640! - openMenu - "Build the open window menu for the world." - - ^DynamicMenuBuilder buildTitled: 'Open...' targeting: self collectingMenuOptionsWith: #worldMenuForOpenGroup - ! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3364-WorldMenuCustomization-HernanWilkinson-2018Jul05-16h00m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3358] on 7 July 2018 at 7:15:34 pm'! - -Object subclass: #DynamicMenuBuilder - instanceVariableNames: 'title defaultTarget menuOptionsSelector menu items groups optionsChanger ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #DynamicMenuBuilder category: #'Morphic-Menus'! -Object subclass: #DynamicMenuBuilder - instanceVariableNames: 'title defaultTarget menuOptionsSelector menu items groups optionsChanger' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 7/6/2018 12:21:10'! - classListMenu2Options - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'unsent methods'. - #selector -> #browseUnusedMethods. - #icon -> #junkIcon. - #balloonText -> 'browse all methods defined by this class that have no senders' - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'unreferenced inst vars'. - #selector -> #showUnreferencedInstVars. - #icon -> #junkIcon. - #balloonText -> 'show a list of all instance variables that are not referenced in methods' - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'unreferenced class vars'. - #selector -> #showUnreferencedClassVars. - #icon -> #junkIcon. - #balloonText -> 'show a list of all class variables that are not referenced in methods' - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'subclass template'. - #object -> #model. - #selector -> #makeNewSubclass. - #icon -> #classIcon. - #balloonText -> 'put a template into the code pane for defining of a subclass of this class' - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'sample instance'. - #selector -> #makeSampleInstance. - #icon -> #instanceIcon. - #balloonText -> 'give me a sample instance of this class, if possible' - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'inspect instances'. - #selector -> #inspectInstances. - #icon -> #inspectIcon. - #balloonText -> 'open an inspector on all the extant instances of this class' - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'inspect subinstances'. - #selector -> #inspectSubInstances. - #icon -> #inspectIcon. - #balloonText -> 'open an inspector on all the extant instances of this class and of all of its subclasses' - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'create inst var accessors'. - #object -> #model. - #selector -> #createInstVarAccessors. - #icon -> #sendReceiveIcon. - #balloonText -> 'compile instance-variable access methods for any instance variables that do not yet have them' - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'more...'. - #selector -> #offerClassListMenu. - #icon -> #listAddIcon. - #balloonText -> 'return to the standard class-list menu' - } asDictionary. - }`! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 7/6/2018 11:58:54'! - classListMenuOptions - - ^ `{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutClass. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'show hierarchy'. - #object -> #model. - #selector -> #hierarchy. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'show definition'. - #object -> #model. - #selector -> #editClass. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'show comment'. - #object -> #model. - #selector -> #editComment. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'inst var refs...'. - #selector -> #browseInstVarRefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'inst var defs...'. - #selector -> #browseInstVarDefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'class var refs...'. - #selector -> #browseClassVarRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 20. - #label -> 'class vars'. - #selector -> #browseClassVariables. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'class refs (N)'. - #selector -> #browseClassRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'rename class ...'. - #object -> #model. - #selector -> #renameClass. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 20. - #label -> 'copy class...'. - #object -> #model. - #selector -> #copyClass. - #icon -> #copyIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 30. - #label -> 'remove class (x)'. - #object -> #model. - #selector -> #removeClass. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 10. - #label -> 'run tests (t)'. - #object -> #model. - #selector -> #runClassTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 20. - #label -> 'more...'. - #selector -> #offerClassListMenu2. - #icon -> #listAddIcon - } asDictionary. - }`. - ! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 7/6/2018 12:24:58'! - messageCategoryMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'fileOut (o)'. - #object -> #model. - #selector -> #fileOutMessageCategories. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'reorganize'. - #object -> #model. - #selector -> #editMessageCategories. - #icon -> #sendReceiveIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'alphabetize'. - #object -> #model. - #selector -> #alphabetizeMessageCategories. - #icon -> #fontXGenericIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'remove empty categories'. - #object -> #model. - #selector -> #removeEmptyCategories. - #icon -> #listRemoveIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 40. - #label -> 'categorize all uncategorized'. - #object -> #model. - #selector -> #categorizeAllUncategorizedMethods. - #icon -> #packageIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 50. - #label -> 'new category...'. - #object -> #model. - #selector -> #addCategory. - #icon -> #newIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'rename...'. - #object -> #model. - #selector -> #renameCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'remove (x)'. - #object -> #model. - #selector -> #removeMessageCategory. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'run tests (t)'. - #object -> #model. - #selector -> #runMessageCategoryTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - }`. - ! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 7/7/2018 18:22:02'! - messageListMenu2Options - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'toggle diffing (D)'. - #object -> #model. - #selector -> #toggleDiffing. - #icon -> #switchIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'implementors of sent messages'. - #selector -> #browseAllMessages. - #icon -> #developmentIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'local senders of...'. - #selector -> #browseLocalSendersOfMessages. - #icon -> #mailForwardIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'local implementors of...'. - #selector -> #browseLocalImplementors. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'spawn sub-protocol'. - #selector -> #browseProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'spawn full protocol'. - #selector -> #browseFullProtocol. - #icon -> #speadsheetTemplateIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'sample instance'. - #selector -> #makeSampleInstance. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'inspect instances'. - #selector -> #inspectInstances. - #icon -> #inspectIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'inspect subinstances'. - #selector -> #inspectSubInstances. - #icon -> #inspectIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 40. - #label -> 'change category...'. - #object -> #model. - #selector -> #changeCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 50. - #label -> 'change sets with this method'. - #selector -> #findMethodInChangeSets. - #icon -> #changesIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 60. - #label -> 'revert to previous version'. - #object -> #model. - #selector -> #revertToPreviousVersion. - #icon -> #undoIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'more...'. - #selector -> #openMessageListMenu. - #icon -> #listAddIcon - } asDictionary. - }`! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 7/7/2018 19:10:48'! - messageListMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'what to show...'. - #selector -> #offerWhatToShowMenu. - #icon -> #preferencesIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'toggle break on entry'. - #object -> #model. - #selector -> #toggleBreakOnEntry. - #icon -> #debugIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'browse method (O)'. - #selector -> #openSingleMessageBrowser. - #icon -> #scriptIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 40. - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutMessage. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'explore CompiledMethod'. - #object -> #model. - #selector -> #exploreCompiledMethod. - #icon -> #exploreIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'senders of... (n)'. - #selector -> #browseSendersOfMessages. - #icon -> #mailForwardIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'implementors of... (m)'. - #selector -> #browseMessages. - #icon -> #developmentIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'inheritance (i)'. - #selector -> #methodHierarchy. - #icon -> #goDownIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 40. - #label -> 'versions (v)'. - #selector -> #browseVersions. - #icon -> #clockIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'inst var refs...'. - #selector -> #browseInstVarRefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 20. - #label -> 'inst var defs...'. - #selector -> #browseInstVarDefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'class var refs...'. - #selector -> #browseClassVarRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 40. - #label -> 'class variables'. - #selector -> #browseClassVariables. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 50. - #label -> 'class refs (N)'. - #selector -> #browseClassRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'remove method (x)'. - #object -> #model. - #selector -> #removeMessage. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 20. - #label -> 'run test (t)'. - #object -> #model. - #selector -> #runMethodTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 30. - #label -> 'debug test (r)'. - #object -> #model. - #selector -> #debugMethodTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 10. - #label -> 'more...'. - #selector -> #openMessageListMenu2. - #icon -> #listAddIcon - } asDictionary. - }`. - ! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 7/7/2018 19:04:27'! - systemCatSingletonMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'find class... (f)'. - #selector -> #findClass. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'browse all'. - #selector -> #browseAllClasses. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'browse'. - #selector -> #openSystemCategoryBrowser. - #icon -> #packageIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutSystemCategory. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'update'. - #object -> #model. - #selector -> #updateSystemCategories. - #icon -> #updateIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'rename...'. - #object -> #model. - #selector -> #renameSystemCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'remove'. - #object -> #model. - #selector -> #removeSystemCategory. - #icon -> #deleteIcon - } asDictionary. - }`. - ! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 7/7/2018 19:02:29'! - systemCategoryMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'find class... (f)'. - #selector -> #findClass. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'recent classes... (r)'. - #object -> #model. - #selector -> #recent. - #icon -> #clockIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'browse all'. - #selector -> #browseAllClasses. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'browse'. - #selector -> #openSystemCategoryBrowser. - #icon -> #packageIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutSystemCategory. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'reorganize'. - #object -> #model. - #selector -> #editSystemCategories. - #icon -> #sendReceiveIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'alphabetize'. - #object -> #model. - #selector -> #alphabetizeSystemCategories. - #icon -> #fontXGenericIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'update'. - #object -> #model. - #selector -> #updateSystemCategories. - #icon -> #updateIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 20. - #label -> 'add item...'. - #object -> #model. - #selector -> #addSystemCategory. - #icon -> #newIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'rename...'. - #object -> #model. - #selector -> #renameSystemCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 40. - #label -> 'remove'. - #object -> #model. - #selector -> #removeSystemCategory. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'move to top'. - #object -> #model. - #selector -> #moveSystemCategoryTop. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 20. - #label -> 'move up'. - #object -> #model. - #selector -> #moveSystemCategoryUp. - #icon -> #goUpIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 30. - #label -> 'move down'. - #object -> #model. - #selector -> #moveSystemCategoryDown. - #icon -> #goDownIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 40. - #label -> 'move to bottom'. - #object -> #model. - #selector -> #moveSystemCategoryBottom. - #icon -> #goBottomIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 10. - #label -> 'run tests (t)'. - #object -> #model. - #selector -> #runSystemCategoryTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - }`. - ! ! -!DynamicMenuBuilder methodsFor: 'initialization' stamp: 'HAW 7/7/2018 18:43:12'! - initializeTitled: aTitle targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector changingThemWith: anOptionsChangerBlock - - title := aTitle. - defaultTarget := aDefaultTarget. - menuOptionsSelector := aMenuOptionsSelector. - optionsChanger := anOptionsChangerBlock ! ! -!DynamicMenuBuilder methodsFor: 'testing' stamp: 'HAW 7/5/2018 18:26:14' prior: 50402670! - hasTitle - - ^title ~= self class noTitle ! ! -!DynamicMenuBuilder methodsFor: 'building - private' stamp: 'HAW 7/7/2018 18:40:31'! - changeOptions - - optionsChanger value: items! ! -!DynamicMenuBuilder methodsFor: 'building - private' stamp: 'HAW 7/5/2018 18:41:03' prior: 50402675! - classesProvidingMenuOptions - - ^(Smalltalk allClassesImplementing: menuOptionsSelector) select: [ :aClass | aClass isMeta ]! ! -!DynamicMenuBuilder class methodsFor: 'instance creation' stamp: 'HAW 7/5/2018 18:25:03' prior: 50402682! - targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector - - ^self titled: self noTitle targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector - -! ! -!DynamicMenuBuilder class methodsFor: 'instance creation' stamp: 'HAW 7/7/2018 18:42:10'! - titled: aTitle targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector changingThemWith: anOptionsChangerBlock - - ^self new initializeTitled: aTitle targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector changingThemWith: anOptionsChangerBlock - -! ! -!DynamicMenuBuilder class methodsFor: 'defaults' stamp: 'HAW 7/5/2018 18:25:09' prior: 50402691! - noTitle - - ^nil! ! -!DynamicMenuBuilder class methodsFor: 'building' stamp: 'HAW 7/5/2018 18:27:20' prior: 50402695! - buildTargeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector - - ^(self targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector) build! ! -!DynamicMenuBuilder class methodsFor: 'building' stamp: 'HAW 7/5/2018 18:27:45' prior: 50402703! - buildTitled: aTitle targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector - - ^(self titled: aTitle targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector) build! ! -!DynamicMenuBuilder class methodsFor: 'building' stamp: 'HAW 7/7/2018 18:42:56'! - buildTitled: aTitle targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector changingThemWith: anOptionsChangerBlock - - ^(self titled: aTitle targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector changingThemWith: anOptionsChangerBlock) build! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'HAW 7/6/2018 12:14:46' prior: 50402988! - buildWorldMenu - "Build the menu that is put up when the screen-desktop is clicked on" - - ^(DynamicMenuBuilder buildTargeting: self collectingMenuOptionsWith: #worldMenuOptions) - addStayUpIcons; - yourself - - ! ! -!TheWorldMenu class methodsFor: 'menu building' stamp: 'HAW 7/5/2018 18:37:46' prior: 50402712! - worldMenuOptions - - ^`{{ - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Open...'. - #selector -> #openOpenMenu. - #icon -> #openIcon. - #balloonText -> 'Submenu to open various system tools'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'New morph...'. - #selector -> #newMorph. - #icon -> #morphsIcon. - #balloonText -> 'Offers a variety of ways to create new objects'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Preferences...'. - #selector -> #openPreferencesMenu. - #icon -> #preferencesIcon. - #balloonText -> 'Opens a menu offering many controls over appearance and system preferences.'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'Windows...'. - #selector -> #openWindowsMenu. - #icon -> #windowIcon. - #balloonText -> 'Manage open windows'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 50. - #label -> 'Help...'. - #selector -> #openHelpMenu. - #icon -> #helpIcon. - #balloonText -> 'Opens a menu of useful items for updating the system, determining what version you are running, and much else'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Changes...'. - #selector -> #openChangesMenu. - #icon -> #changesIcon. - #balloonText -> 'Opens a menu of useful tools for dealing with changes'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Debug...'. - #selector -> #openDebugMenu. - #icon -> #debugIcon. - #balloonText -> 'a menu of debugging items'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'Restore Display (r)'. - #object -> #myWorld. - #selector -> #restoreDisplay. - #icon -> #displayIcon. - #balloonText -> 'Repaint the screen -- useful for removing unwanted display artifacts, lingering cursors, etc.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Save'. - #object -> Smalltalk. - #selector -> #saveSession. - #icon -> #saveIcon. - #balloonText -> 'Save the current version of the image on disk'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Save as...'. - #object -> Smalltalk. - #selector -> #saveAs. - #icon -> #saveAsIcon. - #balloonText -> 'Save the current version of the image on disk under a new name.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'Save as New Version'. - #object -> Smalltalk. - #selector -> #saveAsNewVersion. - #icon -> #saveAsNewVersionIcon. - #balloonText -> ('Save the current image a new version-stamped name\and save it under that name on disk.\', - 'Clear all user preferences and user state (class vars).') withNewLines. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 40. - #label -> 'Save and Quit'. - #selector -> #saveAndQuit. - #icon -> #saveAndQuitIcon. - #balloonText -> 'Save the image and quit out of Cuis.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 50. - #label -> 'Quit'. - #selector -> #quitSession. - #icon -> #quitIcon. - #balloonText -> 'Quit out of Cuis.'. - } asDictionary. -}`! ! -!Workspace class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:15:27' prior: 50402821! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'Workspace'. - #object -> Workspace. - #selector -> #openWorkspace. - #icon -> #terminalIcon. - #balloonText -> 'A window for evaluating Smalltalk expressions'. - } asDictionary}`! ! -!Transcripter class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:15:19' prior: 50402834! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Emergency Evaluator'. - #object -> Transcripter. - #selector -> #emergencyEvaluator. - #icon -> #emblemImportantIcon. - #balloonText -> 'When all else fails...'. - } asDictionary}`! ! -!TextEditor class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:14:50' prior: 50402847! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Text Editor'. - #object -> TextEditor. - #selector -> #openTextEditor. - #icon -> #textEditorIcon. - #balloonText -> 'A window for composing text'. - } asDictionary}`! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'HAW 7/5/2018 18:24:37' prior: 16887708! - invokeWorldMenu - "Put up the world menu, triggered by the passed-in event. - Perhaps a good place to disable it if needed" - - | menu | - menu _ (TheWorldMenu new - world: self - hand: self activeHand) buildWorldMenu. - menu addTitle: Preferences desktopMenuTitle. - menu popUpInWorld: self! ! -!CodePackageListWindow class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:13:05' prior: 50402860! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Installed Packages'. - #object -> CodePackageListWindow. - #selector -> #openPackageList. - #icon -> #packageIcon. - #balloonText -> 'A tool for managing Packages (optional units of code) installed in the system'. - } asDictionary}`! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'HAW 7/7/2018 18:32:00' prior: 50396098! - addExtraMenu2ItemsTo: optoins - "The shifted selector-list menu is being built; some menu items are appropriate only for certain kinds of browsers, and this gives a hook for them to be added as approrpiate. If any is added here, a line should be added first -- browse reimplementors of this message for examples."! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'HAW 7/6/2018 11:59:53' prior: 50398224! - classListMenu - "Set up the menu to apply to the receiver's class list, honoring the #shifted boolean" - - ^DynamicMenuBuilder buildTitled: 'Class List' targeting: self collectingMenuOptionsWith: #classListMenuOptions.! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'HAW 7/6/2018 12:18:34' prior: 50398313! - classListMenu2 - "Set up the menu to apply to the receiver's class list when the shift key is down" - - ^DynamicMenuBuilder buildTargeting: self collectingMenuOptionsWith: #classListMenu2Options. - ! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'HAW 7/6/2018 12:22:51' prior: 50401419! - messageCategoryMenu - - ^DynamicMenuBuilder buildTitled: 'Message Category' targeting: self collectingMenuOptionsWith: #messageCategoryMenuOptions. -! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'HAW 7/7/2018 19:09:07' prior: 50398441! - messageListMenu - "Answer the message-list menu" - "Changed by emm to include menu-item for breakpoints" - - ^DynamicMenuBuilder buildTitled: 'Message List' targeting: self collectingMenuOptionsWith: #messageListMenuOptions. - ! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'HAW 7/7/2018 18:45:13' prior: 50398549! - messageListMenu2 - "Fill aMenu with the items appropriate when the shift key is held down" - - ^DynamicMenuBuilder - buildTitled: 'Message List' - targeting: self - collectingMenuOptionsWith: #messageListMenu2Options - changingThemWith: [ :options | - self addExtraMenu2ItemsTo: options. - model canShowMultipleMessageCategories ifTrue: [ - options add: `{ - #itemGroup -> 40. - #itemOrder -> 45. - #label -> 'show category (C)'. - #object -> #model. - #selector -> #showHomeCategory. - #icon -> #packageIcon - } asDictionary` ]]. - - ! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'HAW 7/7/2018 18:57:48' prior: 50398835! - systemCatSingletonMenu - - ^DynamicMenuBuilder buildTitled: 'Class category' targeting: self collectingMenuOptionsWith: #systemCatSingletonMenuOptions. -! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'HAW 7/7/2018 19:03:15' prior: 50398878! - systemCategoryMenu - - ^DynamicMenuBuilder buildTitled: 'Class category' targeting: self collectingMenuOptionsWith: #systemCategoryMenuOptions.! ! -!BrowserWindow class methodsFor: 'menu-world' stamp: 'HAW 7/6/2018 11:53:52' prior: 50402874! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Browser'. - #object -> BrowserWindow. - #selector -> #openBrowser. - #icon -> #editFindReplaceIcon. - #balloonText -> 'A Smalltalk code browser, for studying and modifying the system'. - } asDictionary}`! ! -!MessageSetWindow methodsFor: 'menu building' stamp: 'HAW 7/7/2018 18:31:51' prior: 50398751! - addExtraMenu2ItemsTo: options - "The shifted selector-list menu is being built. Add items specific to MessageSet" - - model growable ifTrue: [ - options add: `{ - #itemGroup -> 40. - #itemOrder -> 31. - #label -> 'remove from this browser'. - #object -> #model. - #selector -> #removeMessageFromBrowser. - #icon -> #listRemoveIcon - } asDictionary`. - options add:`{ - #itemGroup -> 40. - #itemOrder -> 32. - #label -> 'filter message list...'. - #selector -> #filterMessageList. - #icon -> #findIcon - } asDictionary` ]. - - options add: `{ - #itemGroup -> 40. - #itemOrder -> 33. - #label -> 'sort by date'. - #object -> #model. - #selector -> #sortByDate. - #icon -> #dateIcon - } asDictionary`. - -! ! -!MessageNamesWindow class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:13:59' prior: 50402888! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'Message Names'. - #object -> MessageNamesWindow. - #selector -> #openMessageNames. - #icon -> #inspectIcon. - #balloonText -> 'A tool for finding and editing methods that contain any given keyword in their names.'. - } asDictionary}`! ! -!ChangeSorterWindow class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:12:50' prior: 50402903! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Change Sorter'. - #object -> ChangeSorterWindow. - #selector -> #openChangeSorter. - #icon -> #halfRefreshIcon. - #balloonText -> 'A tool allowing you to view the methods in a Change Set, especially changes to the Base System'. - } asDictionary}`! ! -!FileListWindow class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:13:27' prior: 50402918! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'File List'. - #object -> FileListWindow. - #selector -> #openFileList. - #icon -> #systemFileManagerIcon. - #balloonText -> 'An explorer of the File System'. - } asDictionary}`! ! -!ProcessBrowserWindow class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:14:22' prior: 50402931! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Process Browser'. - #object -> ProcessBrowserWindow. - #selector -> #openProcessBrowser. - #icon -> #systemMonitorIcon. - #balloonText -> 'A tool to monitor and manage Smalltalk processes'. - } asDictionary}`! ! -!TestRunnerWindow class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:14:27' prior: 50402945! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'SUnit Test Runner'. - #object -> TestRunnerWindow. - #selector -> #openTestRunner. - #icon -> #weatherFewCloudsIcon. - #balloonText -> 'Smalltalk''s testing framework'. - } asDictionary}`! ! -!TranscriptWindow class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:15:13' prior: 50402958! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 10. - #itemOrder -> 50. - #label -> 'Transcript'. - #object -> TranscriptWindow. - #selector -> #openTranscript. - #icon -> #printerIcon. - #balloonText -> 'A window showing contents of the System Transcript'. - } asDictionary}`! ! -!DynamicMenuBuilder methodsFor: 'building' stamp: 'HAW 7/7/2018 18:40:16' prior: 50402627! - build - - self - createMenu; - collectMenuOptions; - changeOptions; - addGroupedMenuOptionsToMenu. - - ^ menu.! ! -!DynamicMenuBuilder methodsFor: 'building - private' stamp: 'HAW 7/5/2018 18:41:32' prior: 50402971! - collectMenuOptions - - items := OrderedCollection new. - self classesProvidingMenuOptions do: [ :aClass | items addAll: (aClass soleInstance perform: menuOptionsSelector) ]. - ! ! -!DynamicMenuBuilder methodsFor: 'building - private' stamp: 'HAW 7/6/2018 12:15:07' prior: 50402980! - createMenu - - menu := self hasTitle ifTrue: [ MenuMorph entitled: title] ifFalse: [ MenuMorph new ]. - menu defaultTarget: defaultTarget! ! -!DynamicMenuBuilder class methodsFor: 'instance creation' stamp: 'HAW 7/7/2018 18:41:32' prior: 50402618! - titled: aTitle targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector - - ^self titled: aTitle targeting: aDefaultTarget collectingMenuOptionsWith: aMenuOptionsSelector changingThemWith: [ :options | ]! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'HAW 7/6/2018 12:14:08' prior: 50402997! - openMenu - "Build the open window menu for the world." - - ^(DynamicMenuBuilder buildTitled: 'Open...' targeting: self collectingMenuOptionsWith: #worldMenuForOpenGroup) - addStayUpIcons; - yourself - ! ! - -DynamicMenuBuilder class removeSelector: #buildTitled:targeting:collectingMenuOptionsWith:adding:! - -DynamicMenuBuilder class removeSelector: #buildTitled:targeting:collectingMenuOptionsWith:changingOptionsWith:! - -DynamicMenuBuilder class removeSelector: #titled:targeting:collectingMenuOptionsWith:adding:! - -DynamicMenuBuilder class removeSelector: #titled:targeting:collectingMenuOptionsWith:changingOptionsWith:! - -DynamicMenuBuilder removeSelector: #addOptionalOptions! - -DynamicMenuBuilder removeSelector: #initializeTitled:targeting:collectingMenuOptionsWith:! - -DynamicMenuBuilder removeSelector: #initializeTitled:targeting:collectingMenuOptionsWith:! - -DynamicMenuBuilder removeSelector: #initializeTitled:targeting:collectingMenuOptionsWith:adding:! - -DynamicMenuBuilder removeSelector: #initializeTitled:targeting:collectingMenuOptionsWith:changingOptionsWith:! - -Object subclass: #DynamicMenuBuilder - instanceVariableNames: 'title defaultTarget menuOptionsSelector menu items groups optionsChanger' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #DynamicMenuBuilder category: #'Morphic-Menus'! -Object subclass: #DynamicMenuBuilder - instanceVariableNames: 'title defaultTarget menuOptionsSelector menu items groups optionsChanger' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3365-DynamicMenusInBrowser-HernanWilkinson-2018Jul05-16h00m-HAW.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3365] on 9 July 2018 at 4:41:43 pm'! -!False methodsFor: 'controlling' stamp: 'HAW 7/8/2018 20:12:50'! - and: aBlock1 and: aBlock2 - - ^self! ! -!False methodsFor: 'controlling' stamp: 'HAW 7/8/2018 20:13:01'! - and: aBlock1 and: aBlock2 and: aBlock3 - - ^self! ! -!False methodsFor: 'controlling' stamp: 'HAW 7/8/2018 20:13:06'! - and: aBlock1 and: aBlock2 and: aBlock3 and: aBlock4 - - ^self! ! -!False methodsFor: 'controlling' stamp: 'jmv 7/9/2018 16:37:10'! -or: aBlock1 or: aBlock2 - - ^aBlock1 value or: aBlock2! ! -!False methodsFor: 'controlling' stamp: 'jmv 7/9/2018 16:39:33'! - or: aBlock1 or: aBlock2 or: aBlock3 - - ^aBlock1 value or: aBlock2 or: aBlock3! ! -!False methodsFor: 'controlling' stamp: 'jmv 7/9/2018 16:39:40'! - or: aBlock1 or: aBlock2 or: aBlock3 or: aBlock4 - - ^aBlock1 value or: aBlock2 or: aBlock3 or: aBlock4! ! -!True methodsFor: 'controlling' stamp: 'jmv 7/9/2018 16:38:32'! - and: aBlock1 and: aBlock2 - - ^aBlock1 value and: aBlock2! ! -!True methodsFor: 'controlling' stamp: 'jmv 7/9/2018 16:39:09'! - and: aBlock1 and: aBlock2 and: aBlock3 - - ^aBlock1 value and: aBlock2 and: aBlock3! ! -!True methodsFor: 'controlling' stamp: 'jmv 7/9/2018 16:39:14'! - and: aBlock1 and: aBlock2 and: aBlock3 and: aBlock4 - - ^aBlock1 value and: aBlock2 and: aBlock3 and: aBlock4 ! ! -!True methodsFor: 'controlling' stamp: 'HAW 7/8/2018 20:13:31'! - or: aBlock1 or: aBlock2 - - ^self! ! -!True methodsFor: 'controlling' stamp: 'HAW 7/8/2018 20:13:43'! - or: aBlock1 or: aBlock2 or: aBlock3 - - ^self! ! -!True methodsFor: 'controlling' stamp: 'HAW 7/8/2018 20:13:48'! - or: aBlock1 or: aBlock2 or: aBlock3 or: aBlock4 - - ^self! ! -!Boolean methodsFor: 'controlling' stamp: 'HAW 7/8/2018 20:16:44' prior: 16790174! - and: block1 and: block2 - "Nonevaluating conjunction without deep nesting. - The receiver is evaluated, followed by the blocks in order. - If any of these evaluates as false, then return false immediately, - without evaluating any further blocks. - If all return true, then return true." - - self subclassResponsibility! ! -!Boolean methodsFor: 'controlling' stamp: 'HAW 7/8/2018 20:16:50' prior: 16790189! - and: block1 and: block2 and: block3 - "Nonevaluating conjunction without deep nesting. - The receiver is evaluated, followed by the blocks in order. - If any of these evaluates as false, then return false immediately, - without evaluating any further blocks. - If all return true, then return true." - - self subclassResponsibility! ! -!Boolean methodsFor: 'controlling' stamp: 'HAW 7/8/2018 20:16:57' prior: 16790205! - and: block1 and: block2 and: block3 and: block4 - "Nonevaluating conjunction without deep nesting. - The receiver is evaluated, followed by the blocks in order. - If any of these evaluates as false, then return false immediately, - without evaluating any further blocks. - If all return true, then return true." - - self subclassResponsibility! ! -!Boolean methodsFor: 'controlling' stamp: 'HAW 7/8/2018 20:17:04' prior: 16790280! - or: block1 or: block2 - "Nonevaluating alternation without deep nesting. - The receiver is evaluated, followed by the blocks in order. - If any of these evaluates as true, then return true immediately, - without evaluating any further blocks. - If all return false, then return false." - - self subclassResponsibility! ! -!Boolean methodsFor: 'controlling' stamp: 'HAW 7/8/2018 20:17:09' prior: 16790294! - or: block1 or: block2 or: block3 - "Nonevaluating alternation without deep nesting. - The receiver is evaluated, followed by the blocks in order. - If any of these evaluates as true, then return true immediately, - without evaluating any further blocks. - If all return false, then return false." - - self subclassResponsibility! ! -!Boolean methodsFor: 'controlling' stamp: 'HAW 7/8/2018 20:17:17' prior: 16790310! - or: block1 or: block2 or: block3 or: block4 - "Nonevaluating alternation without deep nesting. - The receiver is evaluated, followed by the blocks in order. - If any of these evaluates as true, then return true immediately, - without evaluating any further blocks. - If all return false, then return false." - - self subclassResponsibility! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3366-BooleanEnhancements-HernanWilkinson-JuanVuletich-2018Jul09-16h31m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3364] on 9 July 2018 at 10:16:59 am'! -!Float64Array methodsFor: 'arithmetic' stamp: 'jmv 7/8/2018 19:37:51'! - divideBy: aFloatArrayOrNumber ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue - ^aFloatArrayOrNumber isNumber - ifTrue:[self divideByScalar: aFloatArrayOrNumber asFloat ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue] - ifFalse:[self divideByArray: aFloatArrayOrNumber ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue]! ! -!Float64Array methodsFor: 'primitives-plugin' stamp: 'jmv 7/9/2018 09:45:37'! - divideByArray: floatArray ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue - - "It would be nice to have FloatArrayPlugin or equivalent for Float64Array..." - 1 to: self size do:[:i| | dividend divisor quotient | - dividend _ self at: i. - divisor _ floatArray at: i. - quotient _ - divisor isZero - ifTrue: [ - dividend isZero - ifTrue: indeterminateBlockOrValue - ifFalse: zeroDivisionBlockOrValue ] - ifFalse: [dividend / divisor]. - self at: i put: quotient]! ! -!Float64Array methodsFor: 'primitives-plugin' stamp: 'jmv 7/9/2018 09:45:23'! - divideByScalar: scalarValue ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue - - "It would be nice to have FloatArrayPlugin or equivalent for Float64Array..." - 1 to: self size do:[:i| | dividend quotient | - dividend _ self at: i. - quotient _ - scalarValue isZero - ifTrue: [ - dividend isZero - ifTrue: indeterminateBlockOrValue - ifFalse: zeroDivisionBlockOrValue ] - ifFalse: [dividend / scalarValue]. - self at: i put: quotient]! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'jmv 7/9/2018 09:41:43'! - divideBy: aFloatArrayOrNumber ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue - ^aFloatArrayOrNumber isNumber - ifTrue:[self divideByScalar: aFloatArrayOrNumber asFloat ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue] - ifFalse:[self divideByArray: aFloatArrayOrNumber ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue]! ! -!FloatArray methodsFor: 'primitives-plugin' stamp: 'jmv 7/9/2018 09:44:49'! - divideByArray: floatArray ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue - - (self primDivArray: floatArray) == #primitiveFailure ifTrue: [ - 1 to: self size do:[:i| | dividend divisor quotient | - dividend _ self at: i. - divisor _ floatArray at: i. - quotient _ - divisor isZero - ifTrue: [ - dividend isZero - ifTrue: indeterminateBlockOrValue - ifFalse: zeroDivisionBlockOrValue ] - ifFalse: [dividend / divisor]. - self at: i put: quotient]]! ! -!FloatArray methodsFor: 'primitives-plugin' stamp: 'jmv 7/8/2018 21:47:26'! - divideByScalar: scalarValue ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue - - "This primitive doesn't fail if argument is zeros, just fills with infinity or nan" - scalarValue isZero ifFalse: [ - ^self primDivScalar: scalarValue ]. - 1 to: self size do:[:i| | dividend quotient | - dividend _ self at: i. - quotient _ dividend isZero - ifTrue: indeterminateBlockOrValue - ifFalse: zeroDivisionBlockOrValue. - self at: i put: quotient]! ! -!Float64Array methodsFor: 'arithmetic' stamp: 'jmv 7/8/2018 18:52:23' prior: 16846212! - /= anObject - - ^self divideBy: anObject - ifDivisorZero: [^ZeroDivide signalWithDividend: self] - ifBothZero: [^ZeroDivide signalWithDividend: self]! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'jmv 7/8/2018 18:52:33' prior: 16846470! - /= anObject - - ^self divideBy: anObject - ifDivisorZero: [^ZeroDivide signalWithDividend: self] - ifBothZero: [^ZeroDivide signalWithDividend: self]! ! -!FloatArray methodsFor: 'primitives-plugin' stamp: 'jmv 7/8/2018 19:29:26' prior: 16846584! - primDivArray: floatArray - - - ^#primitiveFailure! ! -!FloatArray methodsFor: 'primitives-plugin' stamp: 'jmv 7/8/2018 19:53:08' prior: 16846592! - primDivScalar: scalarValue - "This primitive doesn't fail if argument is zero. It fills result with infinity or nan. - For consistency with division with arrays, and general practice, an exception block or value might be used in public protocol. If needed, call directly this method instead. - - #[1.0 2.0 3.141592 0.0] asFloatArray primDivScalar: 0.0. - #[1.0 2.0 3.141592 0.0] asFloatArray / 0.0. - #[1.0 2.0 3.141592 0.0] asFloatArray divideBy: 0.0 ifDivisorZero: -100 ifBothZero: -200 - " - - 1 to: self size do:[:i| self at: i put: (self at: i) / scalarValue].! ! - -Float64Array removeSelector: #primDivArray:! - -Float64Array removeSelector: #primDivArray:! - -Float64Array removeSelector: #primDivScalar:! - -Float64Array removeSelector: #primDivScalar:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3367-ArrayDivisionEnhancements-JuanVuletich-2018Jul09-10h14m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3358] on 9 July 2018 at 5:31:34 pm'! -!False methodsFor: 'controlling' stamp: 'HAW 7/9/2018 17:27:55' prior: 50404249! - or: aBlock1 or: aBlock2 - - "I sending value to aBlock2 to optimize the generated byte-code - Hernan" - ^aBlock1 value or: [ aBlock2 value ] -! ! -!False methodsFor: 'controlling' stamp: 'HAW 7/9/2018 17:28:10' prior: 50404253! - or: aBlock1 or: aBlock2 or: aBlock3 - - "I sending value to aBlock3 to optimize the generated byte-code - Hernan" - ^aBlock1 value or: [ aBlock2 value or: [ aBlock3 value ] ]! ! -!False methodsFor: 'controlling' stamp: 'HAW 7/9/2018 17:28:37' prior: 50404258! -or: aBlock1 or: aBlock2 or: aBlock3 or: aBlock4 - - "I sending value to aBlock4 to optimize the generated byte-code - Hernan" - ^aBlock1 value or: [ aBlock2 value or: [ aBlock3 value or: [ aBlock4 value ]]]. -! ! -!True methodsFor: 'controlling' stamp: 'HAW 7/9/2018 17:29:32' prior: 50404264! - and: aBlock1 and: aBlock2 - - "I sending value to aBlock2 to optimize the generated byte-code - Hernan" - ^aBlock1 value and: [ aBlock2 value ]! ! -!True methodsFor: 'controlling' stamp: 'HAW 7/9/2018 17:29:59' prior: 50404268! -and: aBlock1 and: aBlock2 and: aBlock3 - - "I sending value to aBlock3 to optimize the generated byte-code - Hernan" - ^aBlock1 value and: [ aBlock2 value and: [ aBlock3 value ]]! ! -!True methodsFor: 'controlling' stamp: 'HAW 7/9/2018 17:30:40' prior: 50404273! - and: aBlock1 and: aBlock2 and: aBlock3 and: aBlock4 - - "I sending value to aBlock4 to optimize the generated byte-code - Hernan" - ^aBlock1 value and: [ aBlock2 value and: [ aBlock3 value and: [ aBlock4 value ]]] ! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3368-BooleanEnhancements-take2-HernanWilkinson-2018Jul08-20h18m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3361] on 10 July 2018 at 7:12:14 pm'! -!SmalltalkEditor methodsFor: 'menu' stamp: 'HAW 7/10/2018 19:08:18'! - createMenuCollectingOptionsWith: aMenuOptionsSelector - - ^(DynamicMenuBuilder buildTitled: self class name targeting: self collectingMenuOptionsWith: aMenuOptionsSelector) - addStayUpIcons; - yourself - -! ! -!SmalltalkEditor methodsFor: 'menu' stamp: 'HAW 7/10/2018 19:08:50'! - getMenu2 - - ^self createMenuCollectingOptionsWith: #smalltalkEditorMenu2Options! ! -!SmalltalkEditor methodsFor: 'menu' stamp: 'HAW 7/10/2018 19:09:14'! - openMenu: aMenu - - aMenu popUpInWorld: morph world! ! -!SmalltalkEditor class methodsFor: 'menu' stamp: 'HAW 7/10/2018 19:03:02'! - smalltalkEditorMenu2Options - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Find...(f)'. - #selector -> #find. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'Find Again (g)'. - #selector -> #findAgain. - #icon -> #systemIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Use Selection for Find (j)'. - #selector -> #setSearchString. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Undo - multiple (z)'. - #selector -> #undo. - #icon -> #undoIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Redo - multiple (Z)'. - #selector -> #redo. - #icon -> #redoIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'Undo / Redo history'. - #selector -> #offerUndoHistory. - #icon -> #changesIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Copy (c)'. - #selector -> #copySelection. - #icon -> #copyIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Cut (x)'. - #selector -> #cut. - #icon -> #cutIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'Paste (v)'. - #selector -> #paste. - #icon -> #pasteIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 40. - #label -> 'Paste without Format'. - #selector -> #pasteString. - #icon -> #pasteIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 50. - #label -> 'Paste...'. - #selector -> #pasteRecent. - #icon -> #worldIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'Toggle WordWrap'. - #selector -> #wrapOnOff. - #icon -> #genericTextIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'Set Font... (k)'. - #selector -> #offerFontMenu. - #icon -> #preferencesDesktopFontIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'Clear Font'. - #selector -> #clearFont. - #icon -> #newIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 40. - #label -> 'Set Default Font...'. - #selector -> #offerDefaultFontMenu. - #icon -> #fontXGenericIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'More...'. - #selector -> #openMenu. - #icon -> #listAddIcon - } asDictionary. - }` -! ! -!SmalltalkEditor class methodsFor: 'menu' stamp: 'HAW 7/10/2018 18:57:42'! - smalltalkEditorMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Help...'. - #selector -> #openHelp. - #icon -> #helpIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Do it (d)'. - #selector -> #doIt. - #icon -> #doItIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Print it (p)'. - #selector -> #printIt. - #icon -> #printIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'Inspect it (i)'. - #selector -> #inspectIt. - #icon -> #inspectIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 40. - #label -> 'Explore it (I)'. - #selector -> #exploreIt. - #icon -> #exploreIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 50. - #label -> 'Debug it (D)'. - #selector -> #debugIt. - #icon -> #debugIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 60. - #label -> 'Profile it'. - #selector -> #profileIt. - #icon -> #clockIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Explain'. - #selector -> #explain. - #icon -> #helpIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Browse it (b)'. - #selector -> #browseIt. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'Senders of it (n)'. - #selector -> #sendersOfIt. - #icon -> #mailForwardIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 40. - #label -> 'Implementors of it (m)'. - #selector -> #implementorsOfIt. - #icon -> #developmentIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 50. - #label -> 'References to it (N)'. - #selector -> #referencesToIt. - #icon -> #addressBookIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'Method Strings with it (E)'. - #selector -> #methodStringsContainingit. - #icon -> #genericTextIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'Method Source with it'. - #selector -> #methodSourceContainingIt. - #icon -> #scriptIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'Class Comments with it'. - #selector -> #classCommentsContainingIt. - #icon -> #chatIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'Accept (s)'. - #selector -> #acceptContents. - #icon -> #acceptIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 20. - #label -> 'Cancel (l)'. - #selector -> #cancelEdits. - #icon -> #cancelIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'Accept & Run Test in Class (t)'. - #selector -> #acceptAndTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 40. - #label -> 'Accept & Run Test in Category (y)'. - #selector -> #acceptAndTestAll. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 50. - #label -> 'Accept & Debug Test (r)'. - #selector -> #acceptAndDebugTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'More...'. - #selector -> #openMenu2. - #icon -> #listAddIcon - } asDictionary. - }`! ! -!SmalltalkEditor methodsFor: 'menu' stamp: 'HAW 7/10/2018 19:08:33' prior: 50396445! - getMenu - - ^self createMenuCollectingOptionsWith: #smalltalkEditorMenuOptions! ! -!SmalltalkEditor methodsFor: 'menu' stamp: 'HAW 7/10/2018 19:09:25' prior: 50395424! - openMenu - - self openMenu: self getMenu - ! ! -!SmalltalkEditor methodsFor: 'menu' stamp: 'HAW 7/10/2018 19:09:34' prior: 50396540! - openMenu2 - - self openMenu: self getMenu2 - ! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3369-Make-SmalltalkEditorMenu-dynamic-HernanWilkinson-2018Jul10-18h51m-HAW.1.cs.st----! - -----SNAPSHOT----#(11 July 2018 3:43:41.828695 pm) Cuis5.0-3369-v3.image priorSource: 2246825! - -----QUIT----#(11 July 2018 3:43:52.96215 pm) Cuis5.0-3369-v3.image priorSource: 2342632! - -----STARTUP----#(27 July 2018 10:45:18.046887 am) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3369-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3369] on 11 July 2018 at 5:18:12 pm'! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'jmv 7/11/2018 17:16:50' prior: 50373579! - browseIt - "Launch a browser for the current selection, if appropriate" - - | aSymbol anEntry browser | - Preferences alternativeBrowseIt ifTrue: [^ self browseClassFromIt]. - - self wordSelectAndEmptyCheck: [^ self]. - aSymbol _ self selectedSymbol ifNil: [ - self - evaluateSelectionAndDo: [ :result | result class name ] - ifFail: [ morph flash ] - profiled: false]. - - aSymbol first isUppercase - ifTrue: [ - anEntry _ (Smalltalk - at: aSymbol - ifAbsent: [ - Smalltalk browseAllImplementorsOf: aSymbol. - ^ nil]). - anEntry ifNil: [^ morph flash]. - (anEntry isKindOf: Class) - ifFalse: [anEntry _ anEntry class]. - browser _ Browser new. - browser setClass: anEntry selector: nil. - BrowserWindow open: browser label:'System Browser: ', aSymbol] - ifFalse: - [Smalltalk browseAllImplementorsOf: aSymbol]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3370-browseIt-onObjects-JuanVuletich-2018Jul11-17h16m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3369] on 11 July 2018 at 6:10:38 pm'! -!Float methodsFor: 'printing' stamp: 'jmv 7/11/2018 18:06:31'! - absPrintOn: aStream base: base mantissaSignificantBits: significantBits - "Print my value on a stream in the given base. Assumes that my value is strictly - positive; negative numbers, zero, and NaNs have already been handled elsewhere. - Based upon the algorithm outlined in: - Robert G. Burger and R. Kent Dybvig - Printing Floating Point Numbers Quickly and Accurately - ACM SIGPLAN 1996 Conference on Programming Language Design and Implementation - June 1996. - This version performs all calculations with Floats instead of LargeIntegers, and loses - about 3 lsbs of accuracy compared to an exact conversion." - - | fBase exp baseExpEstimate r s mPlus mMinus scale d tc1 tc2 fixedFormat decPointCount | - self isInfinite ifTrue: [aStream nextPutAll: 'Infinity'. ^ self]. - fBase := base asFloat. - exp := self exponent. - baseExpEstimate := (exp * fBase reciprocalLogBase2 - 1.0e-10) ceiling. - exp >= 0 - ifTrue: - [r := self. - s := 1.0. - mPlus := 1.0 timesTwoPower: exp - significantBits. - mMinus := self significand ~= 1.0 ifTrue: [mPlus] ifFalse: [mPlus / 2.0]] - ifFalse: - [r := self timesTwoPower: significantBits. - s := 1.0 timesTwoPower: significantBits. - mMinus := 1.0 timesTwoPower: (exp max: -1024). - mPlus := - (exp = MinValLogBase2) | (self significand ~= 1.0) - ifTrue: [mMinus] - ifFalse: [mMinus * 2.0]]. - baseExpEstimate >= 0 - ifTrue: - [exp = 1023 - ifTrue: "scale down to prevent overflow to Infinity during conversion" - [r := r / fBase. - s := s * (fBase raisedToInteger: baseExpEstimate - 1). - mPlus := mPlus / fBase. - mMinus := mMinus / fBase] - ifFalse: - [s := s * (fBase raisedToInteger: baseExpEstimate)]] - ifFalse: - [exp < -1023 - ifTrue: "scale up to prevent denorm reciprocals overflowing to Infinity" - [d := (53 * fBase reciprocalLogBase2 - 1.0e-10) ceiling. - scale := fBase raisedToInteger: d. - r := r * scale. - mPlus := mPlus * scale. - mMinus := mMinus * scale. - scale := fBase raisedToInteger: (baseExpEstimate + d) negated] - ifFalse: - [scale := fBase raisedToInteger: baseExpEstimate negated]. - s := s / scale]. - (r + mPlus >= s) - ifTrue: [baseExpEstimate := baseExpEstimate + 1] - ifFalse: - [s := s / fBase]. - (fixedFormat := baseExpEstimate between: -3 and: 6) - ifTrue: - [decPointCount := baseExpEstimate. - baseExpEstimate <= 0 - ifTrue: [aStream nextPutAll: ('0.000000' truncateTo: 2 - baseExpEstimate)]] - ifFalse: - [decPointCount := 1]. - [d := (r / s) truncated. - r := r - (d * s). - (tc1 := r <= mMinus) | (tc2 := r + mPlus >= s)] whileFalse: - [aStream nextPut: (Character digitValue: d). - r := r * fBase. - mPlus := mPlus * fBase. - mMinus := mMinus * fBase. - decPointCount := decPointCount - 1. - decPointCount = 0 ifTrue: [aStream nextPut: $.]]. - tc2 ifTrue: - [tc1 not | (tc1 & (r*2.0 >= s)) ifTrue: [d := d + 1]]. - aStream nextPut: (Character digitValue: d). - decPointCount > 0 - ifTrue: - [decPointCount - 1 to: 1 by: -1 do: [:i | aStream nextPut: $0]. - aStream nextPutAll: '.0']. - fixedFormat ifFalse: - [aStream nextPut: $e. - aStream nextPutAll: (baseExpEstimate - 1) printString]! ! -!Float methodsFor: 'printing' stamp: 'jmv 7/11/2018 17:45:59'! - printAsIEEE32BitPrecisionFloatOn: aStream base: base - "Handle sign, zero, and NaNs; all other values passed to absPrintOn:base:mantissaSignificantBits: - Print as a 32 bit Float" - - self isNaN ifTrue: [aStream nextPutAll: 'NaN'. ^ self]. "check for NaN before sign" - self > 0.0 - ifTrue: [self absPrintOn: aStream base: base mantissaSignificantBits: 24] - ifFalse: - [self sign = -1 - ifTrue: [aStream nextPutAll: '-']. - self = 0.0 - ifTrue: [aStream nextPutAll: '0.0'. ^ self] - ifFalse: [self negated absPrintOn: aStream base: base mantissaSignificantBits: 24]]! ! -!FloatArray methodsFor: 'printing' stamp: 'jmv 7/11/2018 17:49:59'! - printElementsOn: aStream - "FloatArray elements are answered as 64 bit Float, but are really 32 bit Float. - When printing, print them as 32 bit Float." - aStream nextPut: $(. - self do: [ :element | - element printAsIEEE32BitPrecisionFloatOn: aStream base: 10. - aStream space]. - self isEmpty ifFalse: [aStream skip: -1]. - aStream nextPut: $)! ! -!Float methodsFor: 'printing' stamp: 'jmv 7/11/2018 17:43:34' prior: 16845413! - absPrintOn: aStream base: base - "Print my value on a stream in the given base. Assumes that my value is strictly - positive; negative numbers, zero, and NaNs have already been handled elsewhere. - Based upon the algorithm outlined in: - Robert G. Burger and R. Kent Dybvig - Printing Floating Point Numbers Quickly and Accurately - ACM SIGPLAN 1996 Conference on Programming Language Design and Implementation - June 1996. - This version performs all calculations with Floats instead of LargeIntegers, and loses - about 3 lsbs of accuracy compared to an exact conversion." - - self absPrintOn: aStream base: base mantissaSignificantBits: 50 "approximately 3 lsb's of accuracy loss during conversion"! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3371-FloatArray-printAs32bitFloat-JuanVuletich-2018Jul11-18h06m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3371] on 15 July 2018 at 10:28:26 pm'! -!MouseEvent methodsFor: 'button state' stamp: 'jmv 7/15/2018 22:24:54' prior: 16879055! - mouseButton1Pressed - "Answer true if the mouseButton1 is being pressed. - This is the first mouse button, usually the one at the left. - But if they are combined with ctrl or option(Mac) keys, it is considered button 2 or 3 (depending on shift). - See also #mouseButton1Changed" - - self controlKeyPressed ifTrue: [ ^ false ]. - ^ buttons anyMask: InputSensor mouseButton1! ! -!MouseEvent methodsFor: 'button state' stamp: 'jmv 7/15/2018 22:23:15' prior: 16879080! - mouseButton2Pressed - "Answer true if the mouseButton2 is being pressed. - This is usually the right mouse button or option+click on the Mac. - It is also emulated here with shift-ctrl-click on any platform." - - (self controlKeyPressed and: [self shiftPressed] and: [ buttons anyMask: InputSensor mouseButton1 ]) - ifTrue: [ ^ true ]. - ^ buttons anyMask: InputSensor mouseButton2! ! -!MouseEvent methodsFor: 'button state' stamp: 'jmv 7/15/2018 22:21:11' prior: 16879089! - mouseButton3Pressed - "Answer true if the mouseButton3 is being pressed. - This is usually the center (wheel) mouse button or cmd+click on the Mac or ctrl+click on Linux. - It is also emulated here with ctrl-click on any platform (i.e. Windows)." - - (self controlKeyPressed and: [self shiftPressed not] and: [ buttons anyMask: InputSensor mouseButton1 ]) - ifTrue: [ ^ true ]. - ^ buttons anyMask: InputSensor mouseButton3! ! -!MouseButtonEvent methodsFor: 'accessing' stamp: 'jmv 7/15/2018 22:25:04' prior: 16878630! -mouseButton1Changed - "Answer true if the mouseButton1 has changed. - This is usually the left mouse button. - But if they are combined with ctrl or option(Mac) keys, it is considered button 2 or 3 (depending on shift). - The check for button change (instead of button press) is specially useful on buttonUp events. - See also #mouseButton1Pressed" - - self controlKeyPressed ifTrue: [ ^ false ]. - ^ whichButton anyMask: InputSensor mouseButton1! ! -!MouseButtonEvent methodsFor: 'accessing' stamp: 'jmv 7/15/2018 22:22:40' prior: 16878657! - mouseButton2Changed - "Answer true if the mouseButton2 has changed. - This is the usually the right mouse button or option+click on the Mac. - It is also emulated here with shift-ctrl-click on any platform. - The check for button change (instead of button press) is specially useful on buttonUp events." - - (self controlKeyPressed and: [self shiftPressed] and: [ whichButton anyMask: InputSensor mouseButton1 ]) - ifTrue: [ ^ true ]. - ^ whichButton anyMask: InputSensor mouseButton2! ! -!MouseButtonEvent methodsFor: 'accessing' stamp: 'jmv 7/15/2018 22:22:16' prior: 16878669! - mouseButton3Changed - "Answer true if the mouseButton3 has changed. - This is usually the center (wheel) mouse button or cmd+click on the Mac or ctrl+click on Linux. - It is also emulated here with ctrl-click on any platform (i.e. Windows). - The check for button change (instead of button press) is specially useful on buttonUp events." - - (self controlKeyPressed and: [self shiftPressed not] and: [ whichButton anyMask: InputSensor mouseButton1 ]) - ifTrue: [ ^ true ]. - ^ whichButton anyMask: InputSensor mouseButton3! ! - -Preferences class removeSelector: #commandClickOpensHalo! - -Preferences class removeSelector: #commandClickOpensHalo! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3372-ctrlClick-shiftCtrlClick-MouseButtons-JuanVuletich-2018Jul15-22h27m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3372] on 16 July 2018 at 4:24:19 pm'! -!Array2D methodsFor: 'iterating' stamp: 'jmv 7/16/2018 15:12:46'! - do: aBlock - "Evaluate aBlock on each element" - - 1 to: height do: [ :i | - 1 to: width do: [ :j | - aBlock value: (self i: i j: j) ] ]! ! -!Array2D methodsFor: 'iterating' stamp: 'jmv 7/16/2018 16:14:30'! - with: otherImage do: aBlock - "Evaluate aBlock on each element" - - 1 to: height do: [ :i | - 1 to: width do: [ :j | - aBlock value: (self i: i j: j) value: (otherImage i: i j: j) ] ]! ! -!Array2D methodsFor: 'iterating' stamp: 'jmv 7/16/2018 15:11:48' prior: 16780157! - withIndexesDo: aBlock - "Evaluate aBlock on each element, including i, j indexes also as arguments" - - 1 to: height do: [ :i | - 1 to: width do: [ :j | - aBlock value: i value: j value: (self i: i j: j) ] ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3373-Array2D-iteration-JuanVuletich-2018Jul16-15h11m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3372] on 19 July 2018 at 9:35:19 am'! -!Number methodsFor: 'converting' stamp: 'jmv 7/18/2018 11:03:29'! - inMinusPiToPiRange - "Avoid conversion to Float if already ok" - (self > Float pi negated and: [self <= Float pi]) ifTrue: [ - ^ self ]. - ^ self asFloat inMinusPiToPiRange! ! -!Float methodsFor: 'converting' stamp: 'jmv 7/17/2018 15:52:15'! - inMinusPiToPiRange - "For angles in radians. Add or remove whole turns until we get to the (-Pi .. +Pi] range" - | answer | - answer _ self \\ Twopi. - answer > Pi ifTrue: [ - answer _ answer - Twopi ]. - ^ answer! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3374-inMinusPiToPiRange-JuanVuletich-2018Jul19-09h33m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3374] on 26 July 2018 at 11:48:37 am'! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 7/26/2018 09:42:55'! - smoothIsAbsBelow: threshold - "A Function that is 1 at zero, 0 outside a bounded interval of size 4*threshold, and is continuous and differentiable. - - It is a 'smooth' version of the #isAbsBelow: function. - Useful when we need to 'count' stuff, but still want continuous and differentiable stuff." - " - | g | - Feature require: 'Morphic-Widgets-Extras'. - g _ FunctionGraphMorph new. - g domain: (-4 to: 4). - g addFunction: [ :x | x abs < Float halfPi ifTrue: [1] ifFalse:[0] ] color: Color brown. - g addFunction: [ :x | x smoothIsAbsBelow: Float halfPi ] color: Color red. - (g embeddedInMorphicWindowLabeled: 'graph') openInWorld - " - | scaled | - scaled _ self / threshold. - ^ scaled abs < 2 ifTrue: [ (scaled * Float halfPi) cos + 1.0 * 0.5 ] ifFalse: [ 0 ]! ! -!Number methodsFor: 'arithmetic' stamp: 'jmv 7/26/2018 09:41:17' prior: 16879650! - \\ divisor - "Modulo operation. Remainder of the integer division #// (Floored division, truncated to minus infinity, a.k.a Knuth's division) - Answer a Number with the same sign as divisor. - 9\\4 = 1 - -9\\4 = 3 - 9\\-4 = -3 - 0.9\\0.4 = 0.1 - See http://en.wikipedia.org/wiki/Modulo_operation - See #\\, #rem: and #mod: - See detailed discussion at http://mathforum.org/library/drmath/view/52343.html - " - - ^self - (self // divisor * divisor) - - "Evaluate the following:" -" -| g d | -d _ 1. -Feature require: 'Morphic-Widgets-Extras'. -g _ FunctionGraphMorph new. -g domain: (-4 to: 4). -g addFunction: [ :x | x \\ d ] color: Color green. -g addFunction: [ :x | x // d ] color: Color red. -g openInWorld -" -" -| g d | -d _ -1. -Feature require: 'Morphic-Widgets-Extras'. -g _ FunctionGraphMorph new. -g domain: (-4 to: 4). -g addFunction: [ :x | x \\ d ] color: Color green. -g addFunction: [ :x | x // d ] color: Color red. -g openInWorld -"! ! -!Number methodsFor: 'arithmetic' stamp: 'jmv 7/26/2018 09:41:05' prior: 16879710! - mod: divisor - "Modulo operation. Remainder of the integer division #div: (Euclidean division) - Answer a Number that is never negative (it is positive or zero). - (9 mod: 4) = 1 - (-9 mod: 4) = 3 - (9 mod: -4) = 1 - (0.9 mod: 0.4) = 0.1 - See http://en.wikipedia.org/wiki/Modulo_operation - See #\\, #rem: and #mod: - See detailed discussion at http://mathforum.org/library/drmath/view/52343.html - And https://biblio.ugent.be/input/download?func=downloadFile&recordOId=314490&fileOId=452146 - " - "Answer r such that: - for some integer q, aNumber * q + r = self - with 0 <= r < | aNumber |" - - ^self \\ divisor abs - - "Evaluate the following:" -" -| g d | -d _ 1. -Feature require: 'Morphic-Widgets-Extras'. -g _ FunctionGraphMorph new. -g domain: (-4 to: 4). -g addFunction: [ :x | x mod: d ] color: Color green. -g addFunction: [ :x | x div: d ] color: Color red. -g openInWorld -" -" -| g d | -d _ -1. -Feature require: 'Morphic-Widgets-Extras'. -g _ FunctionGraphMorph new. -g domain: (-4 to: 4). -g addFunction: [ :x | x mod: d ] color: Color green. -g addFunction: [ :x | x div: d ] color: Color red. -g openInWorld -" -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3375-smothIsAbsBelow-JuanVuletich-2018Jul26-09h40m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3375] on 26 July 2018 at 3:11:29 pm'! -!Editor class methodsFor: 'help' stamp: 'jmv 7/26/2018 15:10:49' prior: 16836998! - help - " - Editor help - SimpleEditor help - CellStyleEditor help - TextEditor help - SmalltalkEditor help - " - | allSpecs | - allSpecs _ self cmdShortcutsSpec, self basicCmdShortcutsSpec. - ^String streamContents: [ :strm | - allSpecs do: [ :triplet | | c | - c _ triplet first = Character space - ifFalse: [ triplet first asString, ' ' ] - ifTrue: [ 'Space']. - strm nextPutAll: ('Cmd-', c, String tab, String tab, triplet third). - strm newLine ]]! ! -!SmalltalkEditor class methodsFor: 'keyboard shortcut tables' stamp: 'jmv 7/26/2018 15:05:27' prior: 50341355! - cmdShortcutsSpec - " - Editor initialize - " - "arranged in QWERTY keyboard order" - ^#( - #( $r #acceptAndDebugTest: 'Saves method and debugs it') - #( $t #acceptAndTest: 'Saves method, runs it as test and then all tests in class. Opens debugger if error') - #( $y #acceptAndTestAll: 'Saves method, runs it as test and then all tests in class category. Opens debugger if error') - #( $i #inspectIt: 'Inspect it (selection is a valid expression, or selection is over an inspect-ilst)') - #( $p #printIt: 'Print it (selection is a valid expression)') - - #( $s #save: 'Save (i.e. accept)') - #( $d #doIt: 'Do it (selection is a valid expression)') - - #( $b #browseIt: 'Browse it (selection is a class name or cursor is over a class-list or message-list)') - #( $n #sendersOfIt: 'Senders of it (selection is a message selector or cursor is over a class-list or message-list)') - #( $m #implementorsOfIt: 'Implementors of it (selection is a message selector or cursor is over a class-list or message-list)') - - #( $E #methodStringsContainingit:'Method strings containing it') - #( $T #displayIfTrue: 'Insert #ifTrue:') - #( $I #exploreIt: 'Inspect via Object Explorer') - - #( $A #argAdvance: 'Advance argument') - #( $D #debugIt: 'Debug it') - #( $F #displayIfFalse: 'Insert #ifFalse:') - #( $G #fileItIn: 'File in selection') - - #( $V #pasteInitials: 'Paste author initials') - #( $N #referencesToIt: 'References to it (selection is a class name, or cursor is over a class-list or message-list)') - )! ! -!SmalltalkEditor class methodsFor: 'menu' stamp: 'jmv 7/26/2018 15:04:57' prior: 50404713! - smalltalkEditorMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Help...'. - #selector -> #openHelp. - #icon -> #helpIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Do it (d)'. - #selector -> #doIt. - #icon -> #doItIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Print it (p)'. - #selector -> #printIt. - #icon -> #printIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'Inspect it (i)'. - #selector -> #inspectIt. - #icon -> #inspectIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 40. - #label -> 'Explore it (I)'. - #selector -> #exploreIt. - #icon -> #exploreIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 50. - #label -> 'Debug it (D)'. - #selector -> #debugIt. - #icon -> #debugIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 60. - #label -> 'Profile it'. - #selector -> #profileIt. - #icon -> #clockIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Explain'. - #selector -> #explain. - #icon -> #helpIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Browse it (b)'. - #selector -> #browseIt. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'Senders of it (n)'. - #selector -> #sendersOfIt. - #icon -> #mailForwardIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 40. - #label -> 'Implementors of it (m)'. - #selector -> #implementorsOfIt. - #icon -> #developmentIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 50. - #label -> 'References to it (N)'. - #selector -> #referencesToIt. - #icon -> #addressBookIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'Method Strings with it (E)'. - #selector -> #methodStringsContainingit. - #icon -> #genericTextIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'Method Source with it'. - #selector -> #methodSourceContainingIt. - #icon -> #scriptIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'Class Comments with it'. - #selector -> #classCommentsContainingIt. - #icon -> #chatIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'Accept (s)'. - #selector -> #acceptContents. - #icon -> #acceptIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'Accept & Run Test in Class (t)'. - #selector -> #acceptAndTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 40. - #label -> 'Accept & Run Test in Category (y)'. - #selector -> #acceptAndTestAll. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 50. - #label -> 'Accept & Debug Test (r)'. - #selector -> #acceptAndDebugTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'More...'. - #selector -> #openMenu2. - #icon -> #listAddIcon - } asDictionary. - }`! ! - -InnerTextMorph removeSelector: #cancelEdits! - -InnerTextMorph removeSelector: #cancelEdits! - -TextEditor removeSelector: #cancelEdits! - -TextEditor removeSelector: #cancelEdits! - -TextEditor removeSelector: #cancelEdits:! - -TextEditor removeSelector: #cancelEdits:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3376-remove-cancel-command-JuanVuletich-2018Jul26-15h04m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3375] on 26 July 2018 at 3:17:53 pm'! -!CuisSourceFileArray commentStamp: '' prior: 16825649! -Cuis source code access mechanism. -Uses the range for sourcePointer in CompiledMethods (16r1000000 to 16r4FFFFFF) quite differently than StandardSourceFileArray (the older way, inherited from Squeak). First half is for Sources, second half is for Changes. The actual offset in the file is the sourcePointer minus 16r1000000 (or minus 16r3000000) multiplied by a scaling factor. This scaling factor is (right now) 32, raising the limit to 1Gb. - -See the class comment at MigratingSourceFileArray to see how to activate this.! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3377-CuisSourceFileArray-comment-JuanVuletich-2018Jul26-15h11m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3377] on 26 July 2018 at 6:15:23 pm'! - -Object subclass: #Utilities - instanceVariableNames: '' - classVariableNames: 'AuthorInitials AuthorName LastStats LogsUserChanges ' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #Utilities category: #'System-Support'! -Object subclass: #Utilities - instanceVariableNames: '' - classVariableNames: 'AuthorInitials AuthorName LastStats LogsUserChanges' - poolDictionaries: '' - category: 'System-Support'! -!SystemDictionary methodsFor: 'image, changes name' stamp: 'jmv 7/26/2018 18:15:12'! - defaultUserChangesName - "Answer the default full path to the changes file corresponding to the image file name." - " - Smalltalk defaultUserChangesName - " - ^(FileIOAccessor default baseNameFor: self imageName), '.user.changes'! ! -!Utilities class methodsFor: 'identification' stamp: 'jmv 7/26/2018 18:15:16'! - logsUserChanges - LogsUserChanges ifNil: [ LogsUserChanges _ true ]. - ^ LogsUserChanges! ! -!Utilities class methodsFor: 'identification' stamp: 'jmv 7/26/2018 18:15:19'! - logsUserChanges: aBoolean - LogsUserChanges _ aBoolean! ! - -Object subclass: #Utilities - instanceVariableNames: '' - classVariableNames: 'AuthorInitials AuthorName LastStats LogsUserChanges' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #Utilities category: #'System-Support'! -Object subclass: #Utilities - instanceVariableNames: '' - classVariableNames: 'AuthorInitials AuthorName LastStats LogsUserChanges' - poolDictionaries: '' - category: 'System-Support'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3378-logsUserChanges-JuanVuletich-2018Jul26-18h12m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3377] on 26 July 2018 at 6:28:18 pm'! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'jmv 7/26/2018 18:22:27' prior: 16806554! - classComment: aString stamp: aStamp - "Store the comment, aString or Text or RemoteString, associated with the class we are organizing. Empty string gets stored only if had a non-empty one before." - - | ptr header oldCommentRemoteStr | - aString isRemote ifTrue: [ - SystemChangeNotifier uniqueInstance classCommented: self. - ^ self organization classComment: aString stamp: aStamp]. - - oldCommentRemoteStr _ self organization commentRemoteStr. - (aString size = 0) & (oldCommentRemoteStr == nil) ifTrue: [^ self organization classComment: nil]. - "never had a class comment, no need to write empty string out" - - ptr _ oldCommentRemoteStr ifNil: [0] ifNotNil: [oldCommentRemoteStr sourcePointer]. - SourceFiles ifNotNil: [ | file | - (file _ SourceFiles at: 2) ifNotNil: [ - file setToEnd; newLine; nextPut: $!!. "directly" - header _ String streamContents: [:strm | strm nextPutAll: self name; - nextPutAll: ' commentStamp: '. - aStamp storeOn: strm. - strm nextPutAll: ' prior: '; nextPutAll: ptr printString]. - file nextChunkPut: header]]. - self organization classComment: (RemoteString newString: aString onFileNumber: 2) stamp: aStamp. - Utilities logsUserChanges ifTrue: [ - Smalltalk defaultUserChangesName asFileEntry appendStreamDo: [ :stream | - stream newLine; nextPut: $!!. "directly" - header _ String streamContents: [:strm | strm nextPutAll: self name; - nextPutAll: ' commentStamp: '. - aStamp storeOn: strm. - strm nextPutAll: ' prior: '; nextPutAll: ptr printString]. - stream nextChunkPut: header. - stream newLine; nextChunkPut: aString. - ]. - ]. - SystemChangeNotifier uniqueInstance classCommented: self! ! -!BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'jmv 7/26/2018 18:22:23' prior: 16782654! - fileOutCommentOn: aFileStream moveSource: moveSource toFile: fileIndex - "Copy the class comment to aFileStream. If moveSource is true (as in compressChanges or compressSources, then update classComment to point to the new file." - | fileComment | - classComment ifNotNil: [ - aFileStream newLine. - fileComment _ RemoteString newString: classComment text - onFileNumber: fileIndex toFile: aFileStream. - moveSource ifTrue: [classComment _ fileComment]. - Smalltalk defaultUserChangesName asFileEntry appendStreamDo: [ :stream | - stream newLine; nextChunkPut: classComment text ]]! ! -!CompiledMethod methodsFor: 'source code management' stamp: 'jmv 7/26/2018 18:22:32' prior: 16820535! - putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble: preambleBlock - "Store the source code for the receiver on an external file. - If no sources are available, i.e., SourceFile is nil, do nothing. - If the fileIndex is 1, print on *.sources; if it is 2, print on *.changes, - in each case, storing a 4-byte source code pointer at the method end." - - | file remoteString | - (SourceFiles notNil and: [(file _ SourceFiles at: fileIndex) notNil]) ifTrue: [ - - Smalltalk assureStartupStampLogged. - file setToEnd. - - preambleBlock value: file. "Write the preamble" - remoteString _ RemoteString newString: sourceStr onFileNumber: fileIndex toFile: file. - - file nextChunkPut: ' '. - InMidstOfFileinNotification signal ifFalse: [file flush]. - self checkOKToAdd: sourceStr size at: remoteString position in: fileIndex. - self setSourcePosition: remoteString position inFile: fileIndex ]. - - Utilities logsUserChanges ifTrue: [ - Smalltalk defaultUserChangesName asFileEntry appendStreamDo: [ :stream | - preambleBlock value: stream. "Write the preamble" - stream nextChunkPut: sourceStr. - stream nextChunkPut: ' ' ] - ]! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 7/26/2018 17:58:26' prior: 50369617! - logSnapshot: save andQuit: quit - "Log quitting to changes file" - | msg | - self assureStartupStampLogged. - msg _ self snapshotMessageFor: save andQuit: quit. - (SourceFiles at: 2) ifNotNil: [ - save ifTrue: [ - LastQuitLogPosition _ (SourceFiles at: 2) - setToEnd; - position ]]. - self logChange: msg. - Transcript - newLine; - show: msg; - newLine! ! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'jmv 7/26/2018 18:23:44' prior: 16923062! - assureStartupStampLogged - "If there is a startup stamp not yet actually logged to disk, do it now." - | changesFile | - StartupStamp ifNil: [^ self]. - (SourceFiles notNil and: [(changesFile _ SourceFiles at: 2) notNil]) ifTrue: [ - changesFile isReadOnly ifFalse: [ - changesFile setToEnd; newLine; newLine. - changesFile nextChunkPut: StartupStamp asString; newLine. - self forceChangesToDisk ]]. - Smalltalk defaultUserChangesName asFileEntry appendStreamDo: [ :stream | - stream newLine; newLine. - stream nextChunkPut: StartupStamp asString; newLine ]. - StartupStamp _ nil! ! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'jmv 7/26/2018 17:58:32' prior: 16923264! - logChange: aStringOrText - "Write the argument, aString, onto the changes file." - ^ self logChange: aStringOrText preamble: nil! ! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'jmv 7/26/2018 18:27:21' prior: 16923287! - logChange: aStringOrText preamble: preambleOrNil - "Write the argument, aString, onto the changes file." - | aString changesFile | - self assureStartupStampLogged. - aString _ aStringOrText asString. - (aString findFirst: [:char | char isSeparator not]) = 0 - ifTrue: [^ self]. "null doits confuse replay" - (SourceFiles notNil and: [(changesFile _ SourceFiles at: 2) notNil]) ifTrue: [ - changesFile isReadOnly ifFalse: [ - changesFile setToEnd; newLine; newLine. - preambleOrNil ifNotNil: [ - changesFile nextPut: $!!; nextChunkPut: preambleOrNil; newLine ]. - changesFile nextChunkPut: aString. - "If want style changes in DoIt, use nextChunkPutWithStyle:, and allow Texts to get here" - self forceChangesToDisk ]]. - Utilities logsUserChanges ifTrue: [ - Smalltalk defaultUserChangesName asFileEntry appendStreamDo: [ :stream | - stream newLine; newLine. - preambleOrNil ifNotNil: [ - stream nextPut: $!!; nextChunkPut: preambleOrNil; newLine ]. - stream nextChunkPut: aString ]]! ! -!PositionableStream methodsFor: 'fileIn/Out' stamp: 'jmv 7/26/2018 18:15:37' prior: 50366259! - 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 | - Utilities logsUserChanges: false. - announcement - displayProgressAt: Sensor mousePoint - from: 0 - to: self size - during: [ :barBlock | - [ self atEnd ] whileFalse: [ - barBlock value: self position. - self skipSeparators. - - [ - val := (self peekFor: $!!) - ifTrue: [ - chunk := self nextChunk. - "These are the ones that should do nothing, - because next line is a doit that does the stuff - (or because it is handled elsewhere)" - (chunk beginsWith: 'description: ') - | (chunk beginsWith: 'provides: ') - | (chunk beginsWith: 'requires: ') - | (chunk beginsWith: 'classDefinition: ') - | (chunk beginsWith: 'classRemoval: ') - | (chunk beginsWith: 'methodRemoval: ') - | (chunk beginsWith: 'classMoveToSomePackage: ') - | (chunk beginsWith: 'methodMoveToSomePackage: ') - ifFalse: [(Compiler evaluate: chunk logged: false) scanFrom: self]] - ifFalse: [ - chunk := self nextChunk. - self checkForPreamble: chunk. - [ Compiler evaluate: chunk logged: true ] - on: Error - do: [ :ex | - ex print. - ('while evaluating: ', chunk) print. - ex pass ] - ]] - on: InMidstOfFileinNotification - do: [ :ex | ex resume: true ] ]. - ]. - "Note: The main purpose of this banner is to flush the changes file." - Utilities logsUserChanges: true. - Smalltalk logChange: '----End fileIn of ' , self name , '----'. - ^val! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3379-NewLogOfUserChanges-JuanVuletich-2018Jul26-18h15m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3379] on 27 July 2018 at 9:49:22 am'! -!ClassDescription methodsFor: 'accessing' stamp: 'jmv 7/27/2018 09:42:53' prior: 16805673! - comment: aStringOrText - "Set the receiver's comment to be the argument, aStringOrText." - - self theNonMetaClass classComment: aStringOrText asString.! ! -!ClassDescription methodsFor: 'accessing' stamp: 'jmv 7/27/2018 09:41:06' prior: 16805680! - comment: aStringOrText stamp: aStamp - "Set the receiver's comment to be the argument, aStringOrText." - - self theNonMetaClass classComment: aStringOrText asString stamp: aStamp.! ! -!PseudoClass methodsFor: 'class' stamp: 'jmv 7/27/2018 09:43:05' prior: 16896748! - comment: aString - self classComment: aString asString! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3380-tweaks-JuanVuletich-2018Jul27-09h49m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3380] on 27 July 2018 at 10:26:23 am'! -!FileSystemEntry methodsFor: 'convenience' stamp: 'jmv 7/27/2018 10:18:05'! - ifExists: aBlock - "Evaluate a block with receiver as argument if it exists on the file system. If not, do nothing." - self exists ifTrue: [ - aBlock value: self ]! ! -!FeatureRequirement methodsFor: 'private' stamp: 'jmv 7/27/2018 10:24:05'! - withPackageSubfoldersOf: aDirectoryEntry do: aBlock - - "Look in the requested directory" - aBlock value: aDirectoryEntry. - - "Look in the usual Packages subfolders" - aDirectoryEntry / 'Packages' ifExists: [ :packagesFolder | - aBlock value: packagesFolder. - packagesFolder / 'MorphicExamples' ifExists: [ :subFolder | aBlock value: subFolder ]. - packagesFolder / 'CompatibilityPackages' ifExists: [ :subFolder | aBlock value: subFolder ]]. - aDirectoryEntry / 'M3' ifExists: [ :subFolder | aBlock value: subFolder ]! ! -!FeatureRequirement methodsFor: 'private' stamp: 'jmv 7/27/2018 10:16:03' prior: 50376559! -inPackagesSubtreeOf: aDirectoryEntry do: aBlock - - "Direct subfolders" - self withPackageSubfoldersOf: aDirectoryEntry do: aBlock. - - "Finally look in folders that follow the convention of naming package repositories - with the 'Cuis-Smalltalk' prefix, and their possible 'Packages' subdir." - aDirectoryEntry children do: [ :entry | - (entry isDirectory and: [ entry name beginsWith: 'Cuis-Smalltalk' ]) ifTrue: [ - self withPackageSubfoldersOf: entry do: aBlock ]]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3381-PrerequisitesLoadingImprovements-JuanVuletich-2018Jul27-10h25m-jmv.1.cs.st----! - -----SNAPSHOT----#(27 July 2018 10:45:24.93112 am) Cuis5.0-3381-v3.image priorSource: 2342727! - -----QUIT----#(27 July 2018 10:45:47.931205 am) Cuis5.0-3381-v3.image priorSource: 2378184! - -----STARTUP----#(2 August 2018 9:10:51.994686 am) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3381-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3381] on 27 July 2018 at 2:21:57 pm'! -!ChangeList class methodsFor: 'public access' stamp: 'jmv 7/27/2018 14:20:49' prior: 16796932! - browseRecentLogOn: origChangesFileName startingFrom: initialPos - "Prompt with a menu of how far back to go when browsing a changes file." - - | end banners positions pos chunk i | - origChangesFileName asFileEntry readStreamDo: [ :changesFile | - banners _ OrderedCollection new. - positions _ OrderedCollection new. - end _ changesFile size. - pos _ initialPos. - [pos = 0 - or: [banners size > 20]] - whileFalse: [ - changesFile position: pos. - chunk _ changesFile nextChunk. - i _ chunk indexOfSubCollection: 'priorSource: ' startingAt: 1. - i > 0 - ifTrue: [ - positions addLast: pos. - banners addLast: (chunk copyFrom: 5 to: i - 2). - pos _ Number readFrom: (chunk copyFrom: i + 13 to: chunk size)] - ifFalse: [ - positions addLast: 0. - banners addLast: 'Whole file'. - pos _ 0]]. - ]. - banners size = 0 ifTrue: [^ self inform: -'this image has never been saved -since changes were compressed']. - pos _ (SelectionMenu labelList: banners selections: positions) - startUpWithCaption: 'Browse as far back as...'. - pos - ifNil: [^ self]. - self browseRecent: end - pos on: origChangesFileName! ! -!CompiledMethod methodsFor: 'source code management' stamp: 'jmv 7/27/2018 14:21:47' prior: 50405706! - putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble: preambleBlock - "Store the source code for the receiver on an external file. - If no sources are available, i.e., SourceFile is nil, do nothing. - If the fileIndex is 1, print on *.sources; if it is 2, print on *.changes, - in each case, storing a 4-byte source code pointer at the method end." - - | file remoteString | - Smalltalk assureStartupStampLogged. - (SourceFiles notNil and: [(file _ SourceFiles at: fileIndex) notNil]) ifTrue: [ - file setToEnd. - preambleBlock value: file. "Write the preamble" - remoteString _ RemoteString newString: sourceStr onFileNumber: fileIndex toFile: file. - file nextChunkPut: ' '. - InMidstOfFileinNotification signal ifFalse: [file flush]. - self checkOKToAdd: sourceStr size at: remoteString position in: fileIndex. - self setSourcePosition: remoteString position inFile: fileIndex ]. - - Utilities logsUserChanges ifTrue: [ - Smalltalk defaultUserChangesName asFileEntry appendStreamDo: [ :stream | - preambleBlock value: stream. "Write the preamble" - stream nextChunkPut: sourceStr. - stream nextChunkPut: ' ' ]]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3382-RecentChangesBrowseTweaks-JuanVuletich-2018Jul27-14h16m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3382] on 27 July 2018 at 6:17:35 pm'! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 7/27/2018 18:16:30' prior: 50402086! - parse: isAMethod - "Parse the receiver's text. If isAMethod is true - then treat text as a method, if false as an - expression with no message pattern" - - | continue | - self initializeInstanceVariables. - sourcePosition _ 1. - arguments _ Dictionary new. - temporaries _ Dictionary new. - blockDepth _ bracketDepth := 0. - blockDepths _ OrderedCollection with: blockDepth. - blockDepthsStartIndexes _ OrderedCollection with: sourcePosition. - ranges ifNil: [ ranges := OrderedCollection new: 100] ifNotNil: [ ranges reset]. - errorBlock _ [^false]. - [ - self scanNext. - isAMethod - ifTrue: [ - self parseMessagePattern. - self parsePragmaSequence]. - self parseMethodTemporaries. - isAMethod ifTrue: [self parsePragmaSequence]. - "Iterate once for methods, but pontentially several times for workspaces - (to recover after errors, for possible good next lines or chunks)" - continue _ true. - [ continue ] whileTrue: [ - self parseStatementList. - isAMethod - ifTrue: [ - "Only if we are parsing a method, consider everything after this point as error." - currentToken ifNotNil: [ self error ]. - continue _ false] - ifFalse: [ - sourcePosition > source size ifTrue: [continue _ false]]]. - ] ensure: [errorBlock _ nil]. - ^true! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3383-WorkspaceShoutFix-JuanVuletich-2018Jul27-18h07m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3384] on 30 July 2018 at 9:40:43 am'! -!Number methodsFor: 'testing' stamp: 'jmv 7/30/2018 08:51:35'! - ifNotZero: aBlock - " - Useful for workarounding division by zero - #(1.0 2.0 0.0) collect: [ :k | k ifNotZero: [100.0/k]] - " - ^ self isZero ifFalse: aBlock ifTrue: [self]! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'jmv 7/30/2018 08:53:30' prior: 50365021! - scrollBy: delta - "Move the contents in the direction delta." - - | newYoffset yRange xRange newXoffset | - - "Set the offset on the scroller" - yRange _ self vLeftoverScrollRange. - xRange _ self hLeftoverScrollRange. - newYoffset _ self scrollerOffset y - delta y min: yRange max: 0. - newXoffset _ self scrollerOffset x - delta x min: xRange max: 0. - - self scrollerOffset: newXoffset@newYoffset. - - "Update the scrollBars" - scrollBar scrollValue: (yRange ifNotZero: [newYoffset asFloat / yRange]). - hScrollBar scrollValue: (xRange ifNotZero: [newXoffset asFloat / xRange])! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'jmv 7/30/2018 08:58:19' prior: 50384511! - scrollToShow: aRectangle - "scroll to include as much of aRectangle as possible, where aRectangle is in the scroller's local space. - This means that 0@0 is scrolling all the way top and all the way left" - | deltaY | - (aRectangle top >= (0.1*self viewableHeight) and: [ - aRectangle bottom <= (0.9*self viewableHeight) ]) - ifTrue: [ - "already visible" - ^self ]. - - "Scroll center of selection into view if necessary" - deltaY _ self viewableExtent y * 0.1 - aRectangle top. - deltaY ~= 0 ifTrue: [ - self scrollBy: 0@deltaY ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3384-scrollToShow-JuanVuletich-2018Jul30-09h40m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3384] on 31 July 2018 at 5:43:12 pm'! -!ChangeList class methodsFor: 'public access' stamp: 'jmv 7/31/2018 17:40:24' prior: 50369846! - browseRecentLogOn: origChangesFileName - "figure out where the last snapshot or quit was, then browse the recent entries." - - | end done block positions prevBlock | - origChangesFileName asFileEntry readStreamDo: [ :changesFile | - positions _ SortedCollection new. - end _ changesFile size. - prevBlock _ end. - block _ end - 1024 max: 0. - done _ false. - [ done or: [ positions size > 0 ]] - whileFalse: [ - changesFile position: block. - "ignore first fragment" - changesFile nextChunk. - [ changesFile position < prevBlock ] - whileTrue: [ - | pos chunk | - pos _ changesFile position. - chunk _ changesFile nextChunk. - ((Smalltalk isQuitRecord: chunk) or: [ Smalltalk isSnapshotRecord: chunk ]) - ifTrue: [ positions add: pos ]]. - block = 0 - ifTrue: [done _ true] - ifFalse: [ - prevBlock _ block. - block _ block - 1024 max: 0]]. - ]. - self browseRecentLogOn: origChangesFileName startingFrom: (positions isEmpty ifTrue: [0] ifFalse: [positions last])! ! -!ChangeList class methodsFor: 'public access' stamp: 'jmv 7/31/2018 17:42:47' prior: 50405982! - browseRecentLogOn: origChangesFileName startingFrom: initialPos - "Prompt with a menu of how far back to go when browsing a changes file." - - | end banners positions pos chunk i | - origChangesFileName asFileEntry readStreamDo: [ :changesFile | - banners _ OrderedCollection new. - positions _ OrderedCollection new. - end _ changesFile size. - pos _ initialPos. - [pos = 0 - or: [banners size > 20]] "Go back at most 20 image exits" - whileFalse: [ - changesFile position: pos. - chunk _ changesFile nextChunk. - i _ chunk indexOfSubCollection: 'priorSource: ' startingAt: 1. - i > 0 - ifTrue: [ - positions addLast: pos. - banners addLast: (chunk copyFrom: 5 to: i - 2). - pos _ Number readFrom: (chunk copyFrom: i + 13 to: chunk size)] - ifFalse: [ - pos _ 0]]. - ]. - positions addLast: 0. - banners addLast: 'Whole file'. - pos _ (SelectionMenu labelList: banners selections: positions) - startUpWithCaption: 'Browse as far back as...'. - pos - ifNil: [^ self]. - self browseRecent: end - pos on: origChangesFileName! ! -!ChangeList class methodsFor: 'fileIn/Out' stamp: 'jmv 7/31/2018 17:21:48' prior: 16797019! - serviceRecentChanges - "Answer a service for opening a changelist browser on the tail end of a .changes file" - - ^ SimpleServiceEntry - provider: self - label: 'recent changes in file' - selector: #browseRecentLogOn: - description: 'open a changelist tool on recent changes in file' - buttonLabel: 'recent changes'! ! - -ChangeList class removeSelector: #browseRecentLogOnPath:! - -ChangeList class removeSelector: #browseRecentLogOnPath:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3385-recentLog-Enh-JuanVuletich-2018Jul31-17h21m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3385] on 1 August 2018 at 5:29:52 pm'! - -Object subclass: #FileSystemEntry - instanceVariableNames: 'drive pathComponents parent name creationTime modificationTime primEntryInParent exists lastSync ' - classVariableNames: '' - poolDictionaries: '' - category: 'System-FileMan-Core'! - -!classDefinition: #FileSystemEntry category: #'System-FileMan-Core'! -Object subclass: #FileSystemEntry - instanceVariableNames: 'drive pathComponents parent name creationTime modificationTime primEntryInParent exists lastSync' - classVariableNames: '' - poolDictionaries: '' - category: 'System-FileMan-Core'! -!FileSystemEntry methodsFor: 'accessing' stamp: 'jmv 8/1/2018 16:15:03'! - name: aString parent: parentEntryOrNil - name _ aString. - parentEntryOrNil - ifNil: [ - self pathString: aString ] - ifNotNil: [ - parent _ parentEntryOrNil. - drive _ parentEntryOrNil drive. "harmless if no drive supported, as in Unix" - pathComponents _ parentEntryOrNil pathComponents copyWith: name ]. - self refresh! ! -!FileSystemEntry methodsFor: 'private' stamp: 'jmv 8/1/2018 16:20:13'! - updateFrom: primitiveArray entryInParent: index - primEntryInParent _ index. - lastSync _ DateAndTime now. - exists _ true. - creationTime _ DateAndTime fromSeconds: (primitiveArray at: 2). - modificationTime _ DateAndTime fromSeconds: (primitiveArray at: 3)! ! -!FileSystemEntry methodsFor: 'initialize-release' stamp: 'jmv 8/1/2018 16:12:40'! - pathComponents: tokens drive: driveStringOrNil - | firstToken | - tokens isEmptyOrNil ifTrue: [ ^pathComponents _ nil ]. - (driveStringOrNil isNil and: [ (firstToken _ tokens first) isDriveName]) - ifTrue: [ - self drive: firstToken. - pathComponents _ tokens copyFrom: 2 to: tokens size ] - ifFalse: [ - self drive: driveStringOrNil. - pathComponents _ tokens ]. - - pathComponents ifNotEmpty: [ name _ pathComponents last ]. - self refresh! ! -!FileSystemEntry methodsFor: 'initialize-release' stamp: 'jmv 8/1/2018 16:15:35'! - pathString: aString - | tokens guessedDriveName | -"esto esta detectando el drive si corresponde y despues pasa nil para que se vuelva a detectar. repasar" - tokens _ FileIOAccessor default absolutePathComponentsFor: aString. - tokens ifEmpty: [^ nil]. - self fileAccessor isDriveSupported - ifTrue: [ - guessedDriveName _ tokens first asDriveName. - guessedDriveName ifNotNil: [ -"Yo creo que aca habria que llamar a #pathComponents:drive: y salir...." - self drive: guessedDriveName. - tokens := tokens copyFrom: 2 to: tokens size ]]. - self pathComponents: tokens drive: nil! ! -!FileSystemEntry class methodsFor: 'instance creation' stamp: 'jmv 8/1/2018 16:16:01'! - withPathComponents: comps drive: driveString - "May exist or not" - | instance | - instance _ self new. - instance pathComponents: comps drive: driveString. - ^instance! ! -!FileSystemEntry class methodsFor: 'instance creation' stamp: 'jmv 8/1/2018 16:17:07'! - withPathName: aString - "May exist or not" - | instance | - instance _ self new. - instance pathString: aString. - ^instance! ! -!DirectoryEntry methodsFor: 'private' stamp: 'jmv 8/1/2018 15:46:30'! - updateFrom: primitiveArray entryInParent: index - super updateFrom: primitiveArray entryInParent: index. - children _ nil. "lazy initialization"! ! -!FileEntry methodsFor: 'private' stamp: 'jmv 8/1/2018 10:38:53'! - primEntryInParent - ^ primEntryInParent! ! -!FileEntry methodsFor: 'private' stamp: 'jmv 8/1/2018 16:20:02'! - updateFrom: primitiveArray entryInParent: index - super updateFrom: primitiveArray entryInParent: index. - fileSize _ primitiveArray at: 5! ! -!FileList methodsFor: 'volume list and pattern' stamp: 'jmv 7/31/2018 10:36:52' prior: 16842806! - fileNameFormattedFrom: entry namePad: namePad sizePad: sizePad sizeWithCommasPad: sizeWithCommasPad - "entry is a 5-element array of the form: - (name creationTime modificationTime dirFlag fileSize)" - | sizeStr nameStr paddedNameStr dateStr someSpaces sizeDigits sizeDigitsAndCommas spacesToAdd font spaceWidth | - font _ Preferences standardListFont. - spaceWidth _ font widthOf: $ . - nameStr _ entry isDirectory - ifTrue: [ entry name , self folderString ] - ifFalse: [ entry name ]. - spacesToAdd _ namePad - (font widthOfString: nameStr) // spaceWidth. - paddedNameStr _ nameStr , - (String - new: spacesToAdd - withAll: $ ). - dateStr _ (entry modificationTime date printFormat: #(3 2 1 $/ 1 1 2 )) , ' ' , - (String streamContents: [ :s | - entry modificationTime time - print24: true - showSeconds: true - on: s ]). - sizeDigits _ entry fileSize printString size. - sizeStr _ entry fileSize printStringWithCommas. - sizeDigitsAndCommas _ sizeStr size. - spacesToAdd _ sizeWithCommasPad - sizeDigitsAndCommas. - "Usually a space takes the same space as a comma, and half the space of a digit. - Pad with 2 spaces for each missing digit and 1 space for each missing comma" - (font widthOf: Character space) ~= (font widthOf: $, ) - ifTrue: [spacesToAdd _ spacesToAdd + sizePad - sizeDigits max: 0]. - sizeStr _ (String new: spacesToAdd withAll: $ ) , sizeStr. - someSpaces _ String new: 6 withAll: $ . - sortMode = #name ifTrue: [ ^ paddedNameStr , someSpaces , '( ' , dateStr , someSpaces , sizeStr , ' )' ]. - sortMode = #date ifTrue: [ ^ '( ' , dateStr , someSpaces , sizeStr , ' )' , someSpaces , nameStr ]. - sortMode = #size ifTrue: [ ^ '( ' , sizeStr , someSpaces , dateStr , ' )' , someSpaces , nameStr ]! ! -!String methodsFor: 'fileman-converting' stamp: 'jmv 8/1/2018 16:17:21' prior: 16917503! - asDirectoryEntry - "See examples in #asFileEntry method comment" - ^DirectoryEntry withPathName: self! ! -!String methodsFor: 'fileman-converting' stamp: 'jmv 8/1/2018 16:17:23' prior: 16917538! -asFileEntry - " - -Windows - 'C:\Windows' asFileEntry exists false - 'C:\Windows' asDirectoryEntry exists true - '/' asFileEntry exists false - '/' asDirectoryEntry exists false - 'C:\' asFileEntry exists false - 'C:\' asDirectoryEntry exists true - ('C:' asDirectoryEntry // 'Windows') exists false - ('C:' asDirectoryEntry / 'Windows') exists true - -Linux - '/var' asFileEntry exists - '/var' asDirectoryEntry exists true - '/' asFileEntry exists false - '/' asDirectoryEntry exists true - '/media/cdrom' asFileEntry exists false - '/media/cdrom' asDirectoryEntry exists true - ('/bin' asDirectoryEntry / 'more') exists false - ('/bin' asDirectoryEntry // 'more') exists true - -MacOsX - '/var' asFileEntry exists false - '/var' asDirectoryEntry exists true - '/' asFileEntry exists false - '/' asDirectoryEntry exists true - '/Volumes/SanDisk32-NTFS' asFileEntry exists false - '/Volumes/SanDisk32-NTFS' asDirectoryEntry exists true - 'SanDisk32-NTFS' asFileEntry exists false - 'SanDisk32-NTFS' asDirectoryEntry exists false - - " - self isRelativeMark ifTrue: [ ^self error: 'Maybe you need to call #asDirectoryEntry!!' ]. - ^FileEntry withPathName: self! ! -!FileIOAccessor methodsFor: 'private' stamp: 'jmv 8/1/2018 15:50:23' prior: 16841783! - entriesIn: parentEntryOrNil - " - Warning: Private. Only to be called from within FileMan. - Accepts nil as argument, but behavior depends on platform. - -Windows (nil means root) -FileIOAccessor default entriesIn: nil #(C:\ D:\) -(FileIOAccessor default entriesIn: '' asDirectoryEntry) = (FileIOAccessor default entriesIn: '.' asDirectoryEntry) true -FileIOAccessor default entriesIn: '/' asDirectoryEntry #(\$Recycle.Bin \Config.Msi \Documents and Settings \gratMusic \hiberfil.sys \Intel \pagefile.sys \PerfLogs \Program Files \Program Files (x86) \ProgramData \Python27 \Recovery \SimuloHoy \System Volume Information \totalcmd \Users \Windows) - -Linux (nil means current dir, like '' and '.') -FileIOAccessor default entriesIn: nil #(Lots of stuff in current directory) -(FileIOAccessor default entriesIn: nil) = (FileIOAccessor default entriesIn: '.' asDirectoryEntry) true -(FileIOAccessor default entriesIn: '' asDirectoryEntry) = (FileIOAccessor default entriesIn: '.' asDirectoryEntry) true -FileIOAccessor default entriesIn: '/' asDirectoryEntry #(/vmlinuz /boot /sbin /srv /lib /lib32 /tmp /sys /home /etc /initrd.img /bin /dev /opt /proc /lost+found /var /root /lib64 /mnt /usr /run /media) - -MacOsX (nil means current dir, like '' and '.') -FileIOAccessor default entriesIn: nil #(/Volumes/SanDisk32-NTFS/CuisTest/2554-REVISAR-JuanVuletich-2015Oct21-16h40m-jmv.1.cs.st /Volumes/SanDisk32-NTFS/CuisTest/Cog.app /Volumes/SanDisk32-NTFS/CuisTest/Cog.app.tgz /Volumes/SanDisk32-NTFS/CuisTest/Cuis4.2-2553.changes /Volumes/SanDisk32-NTFS/CuisTest/Cuis4.2-2553.image /Volumes/SanDisk32-NTFS/CuisTest/CuisV4.sources) -(FileIOAccessor default entriesIn: '' asDirectoryEntry) = (FileIOAccessor default entriesIn: '.' asDirectoryEntry) true -FileIOAccessor default entriesIn: '/' asDirectoryEntry #(/.dbfseventsd /.DocumentRevisions-V100 /.DS_Store /.file /.fseventsd /.hotfiles.btree /.Spotlight-V100 /.Trashes /.vol /Applications /bin /cores /dev /etc /home /installer.failurerequests /Library /net /Network /opt /private /sbin /System /tmp /Users /usr /var /Volumes) - - " - | entries index done entryArray entry isDirectory lookIn | - entries _ OrderedCollection new: 200. - index _ 1. - done _ false. - lookIn _ parentEntryOrNil ifNil: [''] ifNotNil: [parentEntryOrNil pathName]. - [done] whileFalse: [ - entryArray _ self primLookupEntryIn: lookIn index: index. - #badDirectoryPath == entryArray ifTrue: [ - ^#()]. - entryArray == nil - ifTrue: [done _ true] - ifFalse: [ - isDirectory _ entryArray at: 4. - entry _ isDirectory ifTrue: [DirectoryEntry new] ifFalse: [FileEntry new]. - entry name: (entryArray at: 1) parent: parentEntryOrNil. - entry updateFrom: entryArray entryInParent: index. - entries addLast: entry ]. - index _ index + 1]. - - ^entries asArray! ! -!FileSystemEntry methodsFor: 'private' stamp: 'jmv 8/1/2018 16:16:21' prior: 16843927! - ensureParent - self pathComponents isEmpty - ifTrue: [^ nil]. - parent _ DirectoryEntry - withPathComponents: (self pathComponents copyFrom: 1 to: self pathComponents size - 1) - drive: self drive. - ^ parent! ! -!FileSystemEntry methodsFor: 'initialize-release' stamp: 'jmv 8/1/2018 09:19:11' prior: 16844018! - refresh - "Assume we know nothing about current state in the File System. - This might be because we're just created. - Or it might be because there is a chance the File System changed and we don't know current state." - lastSync _ nil. - exists _ nil. - creationTime _ nil. - modificationTime _ nil.! ! -!DirectoryEntry methodsFor: 'actions-path' stamp: 'jmv 8/1/2018 16:16:10' prior: 16834409! - concatPathComponentsAsDirectory: components - | entry entryComponents parentEntry | - components ifEmpty: [ ^self ]. - parentEntry := self isRoot ifFalse: [ self ]. - entryComponents := self pathComponents. - - components do: [ :eachComponent | - entryComponents := entryComponents copyWith: eachComponent. - entry := DirectoryEntry withPathComponents: entryComponents drive: self drive. - parentEntry ifNotNil: [ - entry setParent: parentEntry ]. - parentEntry := entry ]. - - ^entry! ! -!DirectoryEntry methodsFor: 'actions-path' stamp: 'jmv 8/1/2018 16:16:14' prior: 16834427! - concatPathComponentsAsFile: components - - | entry entryComponents parentEntry | - components ifEmpty: [ ^self ]. - parentEntry := self isRoot ifFalse: [ self ]. - entryComponents := self pathComponents. - - components allButLast do: [ :eachComponent | - entryComponents := entryComponents copyWith: eachComponent. - entry := DirectoryEntry withPathComponents: entryComponents drive: self drive. - parentEntry ifNotNil: [ - entry setParent: parentEntry ]. - parentEntry := entry ]. - - entryComponents := entryComponents copyWith: components last. - entry := FileEntry withPathComponents: entryComponents drive: self drive. - parentEntry ifNotNil: [ - entry setParent: parentEntry ]. - - ^entry! ! -!DirectoryEntry class methodsFor: 'instance creation' stamp: 'jmv 8/1/2018 16:17:15' prior: 16834792! - currentDirectory - "Answer the current directory. - - In Unix it is the current directory in the OS shell that started us. - In Windows the same happens if the image file is in a subree of the Windows current directory. - - But it defaults to the directory in wich this Smalltalk image was started (or last saved) if this fails - (this usually happens, for example, if the image is dropped on the VM in a Windows explorer). - See #getCurrentWorkingDirectory - - DirectoryEntry currentDirectory - " - - CurrentDirectory ifNil: [ - CurrentDirectory _ self withPathName: (Smalltalk getCurrentWorkingDirectory ifNil: [ Smalltalk imagePath ]) ]. - ^ CurrentDirectory! ! -!DirectoryEntry class methodsFor: 'instance creation' stamp: 'jmv 8/1/2018 16:17:17' prior: 16834830! - smalltalkImageDirectory - "Answer the directory on which this Smalltalk image was started (or last saved) - - DirectoryEntry smalltalkImageDirectory - " - - ImageDirectory ifNil: [ - ImageDirectory _ self withPathName: Smalltalk imagePath ]. - ^ ImageDirectory! ! -!DirectoryEntry class methodsFor: 'instance creation' stamp: 'jmv 8/1/2018 16:17:19' prior: 16834841! - vmDirectory - "Answer the directory containing the VM that runs us. - - DirectoryEntry vmDirectory - " - - VMDirectory ifNil: [ - VMDirectory _ self withPathName: Smalltalk vmPath ]. - ^ VMDirectory! ! -!FileEntry methodsFor: 'initialize-release' stamp: 'jmv 8/1/2018 16:19:41' prior: 16841472! - refresh - super refresh. - fileSize _ nil! ! - -FileSystemEntry class removeSelector: #pathComponents:! - -FileSystemEntry class removeSelector: #pathComponents:! - -FileSystemEntry class removeSelector: #pathComponents:drive:! - -FileSystemEntry class removeSelector: #pathComponents:drive:! - -FileSystemEntry class removeSelector: #pathName:! - -FileSystemEntry class removeSelector: #pathName:! - -FileSystemEntry removeSelector: #basicPathComponents:! - -FileSystemEntry removeSelector: #basicPathComponents:! - -FileSystemEntry removeSelector: #parent:! - -FileSystemEntry removeSelector: #parent:! - -FileSystemEntry removeSelector: #pathComponents:! - -FileSystemEntry removeSelector: #pathComponents:! - -FileSystemEntry removeSelector: #pathComponents:detectDrive:! - -FileSystemEntry removeSelector: #pathComponents:detectDrive:! - -FileSystemEntry removeSelector: #pathName:! - -FileSystemEntry removeSelector: #pathName:! - -Object subclass: #FileSystemEntry - instanceVariableNames: 'drive pathComponents parent name primEntryInParent lastSync exists creationTime modificationTime' - classVariableNames: '' - poolDictionaries: '' - category: 'System-FileMan-Core'! - -!classDefinition: #FileSystemEntry category: #'System-FileMan-Core'! -Object subclass: #FileSystemEntry - instanceVariableNames: 'drive pathComponents parent name primEntryInParent lastSync exists creationTime modificationTime' - classVariableNames: '' - poolDictionaries: '' - category: 'System-FileMan-Core'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3386-FileSystemEntry-refactor-JuanVuletich-2018Aug01-17h27m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3386] on 1 August 2018 at 5:32:47 pm'! -!FileIOAccessor methodsFor: 'private' stamp: 'jmv 8/1/2018 17:11:06'! - updateEntry: aFileSystemEntry - | entryArray index lookIn isDirectory | - - "If the index in aFileSystemEntry is valid, use it. No need to iterate over all entries." - aFileSystemEntry primEntryInParent ifNotNil: [ :tentativeIndex | - (self primLookupEntryIn: aFileSystemEntry parent pathName index: tentativeIndex) ifNotNil: [ :found | - found == #badDirectoryPath ifFalse: [ - aFileSystemEntry name = (found at: 1) ifTrue: [ - aFileSystemEntry updateFrom: found entryInParent: tentativeIndex. - ^ self ]]]]. - - "Otherwise, do a full iteration" - lookIn _ aFileSystemEntry parent pathName. - index _ 1. - [ - entryArray _ self primLookupEntryIn: lookIn index: index. - #badDirectoryPath == entryArray ifTrue: [ - ^ self]. - entryArray == nil ifTrue: [ - ^ self]. - isDirectory _ entryArray at: 4. - aFileSystemEntry name = (entryArray at: 1) ifTrue: [ - isDirectory == aFileSystemEntry isDirectory ifTrue: [ - aFileSystemEntry updateFrom: entryArray entryInParent: index ]. - "If found, exit even if invalid. No point to keep iterating." - ^ self ]. - index _ index + 1] repeat! ! -!FileSystemEntry methodsFor: 'accessing' stamp: 'jmv 8/1/2018 16:56:17'! - exists - self invalidateIfOld. - exists ifNil: [self updateExists]. - ^exists! ! -!FileSystemEntry methodsFor: 'private' stamp: 'jmv 8/1/2018 16:28:04'! - invalidateIfOld - - lastSync isNil ifTrue: [ - ^ self invalidate ]. - (DateAndTime now - lastSync) totalSeconds > 2 ifTrue: [ - self invalidate ]! ! -!FileSystemEntry methodsFor: 'initialize-release' stamp: 'jmv 8/1/2018 16:27:06'! - invalidate - "Assume we know nothing about current state in the File System. - This might be because we're just created. - Or it might be because there is a chance the File System changed and we don't know current state." - lastSync _ nil. - exists _ nil. - creationTime _ nil. - modificationTime _ nil.! ! -!DirectoryEntry methodsFor: 'testing' stamp: 'jmv 8/1/2018 16:55:24'! - updateExists - - | pathName | - (self fileAccessor isDriveSupported and: [self pathComponents isEmpty]) - ifTrue: [^ exists _ self fileAccessor drives includes: self ]. - - self isRoot ifTrue: [ ^ exists _ true ]. - - pathName _ self pathName. - pathName = self fileAccessor slash ifTrue: [ ^ exists _ true ]. - - exists _ self fileAccessor basicDirectoryExists: pathName! ! -!DirectoryEntry methodsFor: 'initialize-release' stamp: 'jmv 8/1/2018 16:31:30'! - invalidate - "Assume we know nothing about current state in the File System. - This might be because we're just created. - Or it might be because there is a chance the File System changed and we don't know current state." - super invalidate. - self invalidateChildren! ! -!DirectoryEntry methodsFor: 'initialize-release' stamp: 'jmv 8/1/2018 16:31:20'! - invalidateChildren - - children _ nil! ! -!FileEntry methodsFor: 'testing' stamp: 'jmv 8/1/2018 16:55:46'! - updateExists - - self fileSize "Updates both"! ! -!FileEntry methodsFor: 'initialize-release' stamp: 'jmv 8/1/2018 16:27:14'! - invalidate - "Assume we know nothing about current state in the File System. - This might be because we're just created. - Or it might be because there is a chance the File System changed and we don't know current state." - super invalidate. - fileSize _ nil! ! -!FileSystemEntry methodsFor: 'accessing' stamp: 'jmv 8/1/2018 17:13:59' prior: 16843857! - creationTime - self invalidateIfOld. - creationTime ifNil: [self fileAccessor updateEntry: self]. - ^creationTime! ! -!FileSystemEntry methodsFor: 'accessing' stamp: 'jmv 8/1/2018 17:01:34' prior: 16843875! - modificationTime - self invalidateIfOld. - modificationTime ifNil: [self fileAccessor updateEntry: self]. - ^modificationTime! ! -!FileSystemEntry methodsFor: 'accessing' stamp: 'jmv 8/1/2018 16:27:50' prior: 50406284! - name: aString parent: parentEntryOrNil - name _ aString. - parentEntryOrNil - ifNil: [ - self pathString: aString ] - ifNotNil: [ - parent _ parentEntryOrNil. - drive _ parentEntryOrNil drive. "harmless if no drive supported, as in Unix" - pathComponents _ parentEntryOrNil pathComponents copyWith: name ]. - self invalidate! ! -!FileSystemEntry methodsFor: 'initialize-release' stamp: 'jmv 8/1/2018 16:27:53' prior: 50406308! - pathComponents: tokens drive: driveStringOrNil - | firstToken | - tokens isEmptyOrNil ifTrue: [ ^pathComponents _ nil ]. - (driveStringOrNil isNil and: [ (firstToken _ tokens first) isDriveName]) - ifTrue: [ - self drive: firstToken. - pathComponents _ tokens copyFrom: 2 to: tokens size ] - ifFalse: [ - self drive: driveStringOrNil. - pathComponents _ tokens ]. - - pathComponents ifNotEmpty: [ name _ pathComponents last ]. - self invalidate! ! -!FileSystemEntry class methodsFor: 'class state access' stamp: 'jmv 8/1/2018 16:28:10' prior: 16844063! - releaseClassCachedState - - self allSubInstancesDo: [ :each | each invalidate]! ! -!DirectoryEntry methodsFor: 'actions-directory' stamp: 'jmv 8/1/2018 16:31:28' prior: 16834541! - delete - self fileAccessor deleteDirectory: self pathName. - self invalidateChildren! ! -!DirectoryEntry methodsFor: 'private' stamp: 'jmv 8/1/2018 16:31:26' prior: 16834573! - basicRecursiveDelete - self invalidateChildren. - self directoriesDo: [:dir | dir basicRecursiveDelete]. - self filesDo: [:file | file delete]. - self delete! ! -!DirectoryEntry methodsFor: 'dictionary-like' stamp: 'jmv 8/1/2018 16:31:24' prior: 16834599! - at: localFileName put: contents - - (self // localFileName) forceWriteStreamDo: [ :stream | - self setContentsOf: stream to: contents ]. - self invalidateChildren. - ^contents! ! -!DirectoryEntry methodsFor: 'dictionary-like' stamp: 'jmv 8/1/2018 16:31:32' prior: 16834639! - removeKey: localFileName ifAbsent: failBlock - self fileAccessor deleteFile: (self // localFileName) pathName ifAbsent: [^failBlock value]. - self invalidateChildren.! ! -!DirectoryEntry methodsFor: 'accessing' stamp: 'jmv 8/1/2018 16:45:23' prior: 16834647! -children - self invalidateIfOld. - children ifNil: [self initChildren]. - ^children! ! -!FileEntry methodsFor: 'actions-file' stamp: 'jmv 8/1/2018 16:27:36' prior: 16841288! - binaryContents: aByteArray - self forceWriteStreamDo: [ :stream | - self setContentsOf: stream binary to: aByteArray ]. - self invalidate! ! -!FileEntry methodsFor: 'actions-file' stamp: 'jmv 8/1/2018 16:27:44' prior: 16841337! - textContents: aString - self forceWriteStreamDo: [ :stream | - self setContentsOf: stream to: aString ]. - self invalidate! ! -!FileEntry methodsFor: 'accessing' stamp: 'jmv 8/1/2018 17:02:21' prior: 16841395! - fileSize - - self invalidateIfOld. - - "Slow version." - "fileSize ifNil: [self fileAccessor updateEntry: self]." - - "Fast version, that asks just for the size of this file. - Used if I was not created by reading a direcotry" - fileSize ifNil: [ - fileSize _ self fileAccessor fileSize: self. - exists _ fileSize notNil ]. - - ^fileSize! ! -!FileEntry methodsFor: 'accessing' stamp: 'jmv 8/1/2018 16:27:47' prior: 16841423! - writeStream - "If the file already exists raise FileExistsException. - Note: You need to eventually close the stream. - Usually prefer #writeStreamDo: that closes the file for you. - Creates the directory if it doesn't exist." - - self invalidate. - self parent exists ifFalse: [self parent assureExistence]. - ^self fileAccessor privateNewFile: self! ! -!FileEntry methodsFor: 'private' stamp: 'jmv 8/1/2018 16:27:41' prior: 16841436! - forceWriteStream - "If the file already exists, delete it first without asking. Do not raise FileExistsException. - Note: You need to eventually close the stream. - Usually prefer #forceWriteStreamDo: that closes the file for you. - Creates the directory if it doesn't exist." - - self invalidate. - self parent exists ifFalse: [self parent assureExistence]. - ^self fileAccessor privateForceNewFile: self! ! - -FileEntry removeSelector: #exists! - -FileEntry removeSelector: #exists! - -FileEntry removeSelector: #fileSize:! - -FileEntry removeSelector: #fileSize:! - -FileEntry removeSelector: #initValuesFrom:! - -FileEntry removeSelector: #initValuesFrom:! - -FileEntry removeSelector: #refresh! - -FileEntry removeSelector: #refresh! - -DirectoryEntry removeSelector: #exists! - -DirectoryEntry removeSelector: #exists! - -DirectoryEntry removeSelector: #refresh! - -DirectoryEntry removeSelector: #refresh! - -DirectoryEntry removeSelector: #refreshChildren! - -DirectoryEntry removeSelector: #refreshChildren! - -FileSystemEntry removeSelector: #creationTime:! - -FileSystemEntry removeSelector: #creationTime:! - -FileSystemEntry removeSelector: #initValuesFrom:! - -FileSystemEntry removeSelector: #initValuesFrom:! - -FileSystemEntry removeSelector: #initValuesFromParent! - -FileSystemEntry removeSelector: #initValuesFromParent! - -FileSystemEntry removeSelector: #modificationTime:! - -FileSystemEntry removeSelector: #modificationTime:! - -FileSystemEntry removeSelector: #refresh! - -FileSystemEntry removeSelector: #refresh! - -FileIOAccessor removeSelector: #fileExists:! - -FileIOAccessor removeSelector: #fileExists:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3387-FileSystemEntry-autosync-JuanVuletich-2018Aug01-17h32m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3387] on 1 August 2018 at 5:51:16 pm'! -!CodePackageFile class methodsFor: 'file list services' stamp: 'jmv 8/1/2018 08:49:06' prior: 50369177! - serviceInstallPackage - "Answer the service of installing a CodePackageFile (a chunk format file for a CodePackage)" - - ^ (SimpleServiceEntry - provider: self - label: 'install package' - selector: #installPackage: - description: 'install the package, replacing all existing code in the package (if any); create a new change set just for the installation' - buttonLabel: 'install package') - sortOrder: 100; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! - -CodePackageFile class removeSelector: #installPackageStream:! - -CodePackageFile class removeSelector: #installPackageStream:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3388-cleanup-JuanVuletich-2018Aug01-17h49m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3386] on 1 August 2018 at 6:36:13 pm'! -!FileSystemEntry methodsFor: 'initialize-release' stamp: 'jmv 8/1/2018 18:34:46' prior: 50406325! - pathString: aString - | tokens | - tokens _ FileIOAccessor default absolutePathComponentsFor: aString. - tokens ifEmpty: [^ nil]. - self fileAccessor isDriveSupported - ifTrue: [ - tokens first asDriveName ifNotNil: [ :guessedDriveName | - ^ self pathComponents: (tokens copyFrom: 2 to: tokens size) drive: guessedDriveName ]]. - self pathComponents: tokens drive: nil! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3389-keepWindowsDrive-JuanVuletich-2018Aug01-18h34m-jmv.1.cs.st----! - -----SNAPSHOT----#(2 August 2018 9:10:58.111269 am) Cuis5.0-3389-v3.image priorSource: 2378279! - -----QUIT----#(2 August 2018 9:11:10.946556 am) Cuis5.0-3389-v3.image priorSource: 2413881! - -----STARTUP----#(6 August 2018 6:24:48.905512 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3389-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3389] on 2 August 2018 at 4:49:36 pm'! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'HAW 8/2/2018 16:49:19'! - hasReferencesToInstanceVariableNamed: anInstanceVariableName - - "Returns true if only self has one or more methods referencing anInstanceVariableName - Hernan" - - ^(self whichSelectorsAccess: anInstanceVariableName) notEmpty! ! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'HAW 8/2/2018 16:48:53'! - isInstanceVariableNamedReferencedInHierarchy: anInstanceVariableName - - "Returns true if self or any subclass has one or more methods referencing anInstanceVariableName - Hernan" - - ^self withAllSubclasses anySatisfy: [ :aClass | aClass hasReferencesToInstanceVariableNamed: anInstanceVariableName ]! ! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'HAW 8/2/2018 16:03:04' prior: 16784635! - allUnreferencedInstanceVariables - - "Return a list of the instance variables known to the receiver which are not referenced in the receiver or any of its subclasses OR superclasses" - - ^ self allInstVarNames reject: [ :instanceVariableName | | definingClass | - definingClass _ self classThatDefinesInstanceVariable: instanceVariableName. - definingClass isInstanceVariableNamedReferencedInHierarchy: instanceVariableName ]! ! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'HAW 8/2/2018 15:59:42' prior: 16784677! - unreferencedInstanceVariables - "Return a list of the instance variables defined in the receiver which are not referenced in the receiver or any of its subclasses - - Object unreferencedInstanceVariables - " - - ^ self instVarNames reject: [ :instanceVariableName | self isInstanceVariableNamedReferencedInHierarchy: instanceVariableName ] - ! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3390-unreferencedIVars-enh-HernanWilkinson-2018Aug02-10h37m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3389] on 2 August 2018 at 8:36:25 pm'! -!Browser methodsFor: 'class list' stamp: 'HAW 8/2/2018 20:19:45'! -classListIndexOf: aClassNameToFind - - "Answer the index of the aClassName selection." - - aClassNameToFind ifNil: [ ^0 ]. - ^self listClassesHierarchically - ifTrue: [ self classListIndexWhenShowingHierarchicallyOf: aClassNameToFind ] - ifFalse: [ self classList indexOf: aClassNameToFind ] -! ! -!Browser methodsFor: 'class list' stamp: 'HAW 8/2/2018 20:20:58'! - classListIndexWhenShowingHierarchicallyOf: aClassNameToFind - - ^self classList findFirst: [ :showingClassName | showingClassName afterBlanksEndsWith: aClassNameToFind ] -! ! -!Browser methodsFor: 'class list' stamp: 'HAW 8/2/2018 19:37:45'! - createHierarchyTreeOf: col - - "Create a tree from a flat collection of classes" - - | transformed | - - transformed := col collect: [:ea | - | childs indexes | - childs := col select: [:class | class superclass = ea]. - indexes := childs collect: [:child | col indexOf: child]. - ea -> indexes]. - transformed copy do: [:ea | - ea value: (ea value collect: [:idx | - | val | - val := transformed at: idx. - transformed at: idx put: nil. - val])]. - ^ transformed select: [:ea | ea notNil]. -! ! -!Browser methodsFor: 'class list' stamp: 'HAW 8/2/2018 17:51:43'! - defaultClassList - "Answer an array of the class names of the selected category. Answer an - empty array if no selection exists." - - ^selectedSystemCategory - ifNil: [#()] - ifNotNil: [systemOrganizer listAtCategoryNamed: selectedSystemCategory]! ! -!Browser methodsFor: 'class list' stamp: 'HAW 8/2/2018 19:38:01'! - flattenHierarchyTree: classHierarchy on: col indent: indent - - ^ self - flattenHierarchyTree: classHierarchy - on: col - indent: indent - by: ' '.! ! -!Browser methodsFor: 'class list' stamp: 'HAW 8/2/2018 19:38:11'! - flattenHierarchyTree: classHierarchy on: col indent: indent by: indentChars - - "Recursively add to col the names in classHierarchy indenting to show the hierarchical relationship. Use indentChars to do the indenting: spaces, tabs, etc." - - | plusIndent | - - plusIndent := indentChars. - classHierarchy do: [:assoc | - | class childs | - class := assoc key. - col add: indent , class name. - childs := assoc value. - self - flattenHierarchyTree: childs - on: col - indent: indent , plusIndent - by: indentChars]. - ^ col! ! -!Browser methodsFor: 'class list' stamp: 'HAW 8/2/2018 19:38:37'! - hierarchicalClassList - - "classNames are an arbitrary collection of classNames of the system. - Reorder those class names so that they are sorted and indended by inheritance" - - | classes | - - "Creating the hierarchy is *really slow* for the full class list. Skip it for now." - selectedSystemCategory = SystemOrganizer allCategory ifTrue: [^ self defaultClassList]. - classes := self defaultClassList collect: [:sym | Smalltalk classNamed: sym]. - - ^ self - flattenHierarchyTree: (self createHierarchyTreeOf: classes) - on: OrderedCollection new - indent: ''.! ! -!Browser methodsFor: 'class list' stamp: 'HAW 8/2/2018 19:42:13'! - listClassesHierarchically - - ^self class listClassesHierarchically ! ! -!Browser class methodsFor: 'class list' stamp: 'HAW 8/2/2018 20:25:05'! - disableListClassesHierarchically - - ^Preferences disable: #listClassesHierarchically ! ! -!Browser class methodsFor: 'class list' stamp: 'HAW 8/2/2018 20:24:55'! - enableListClassesHierarchically - - ^Preferences enable: #listClassesHierarchically ! ! -!Browser class methodsFor: 'class list' stamp: 'HAW 8/2/2018 19:21:34'! - listClassesHierarchically - - ^Preferences listClassesHierarchically ! ! -!String methodsFor: 'converting' stamp: 'HAW 8/2/2018 20:19:09'! - afterBlanksEndsWith: aTail - - ^(self endsWith: aTail) and: [self size = aTail size or: [ (self at: self size - aTail size) isSeparator]] - - ! ! -!String methodsFor: 'converting' stamp: 'HAW 8/2/2018 19:11:17'! - withoutLeadingBlanks - - "Return a copy of the receiver from which leading blanks have been trimmed." - - | first | - - first := self findFirst: [:c | c isSeparator not ]. - first = 0 ifTrue: [^ '']. - first = 1 ifTrue: [^ self ]. - - "no non-separator character" - ^ self copyFrom: first to: self size - - " ' abc d ' withoutLeadingBlanks" -! ! -!Preferences class methodsFor: 'standard queries'! - listClassesHierarchically - ^ self - valueOfFlag: #listClassesHierarchically - ifAbsent: [ true ].! ! -!Browser methodsFor: 'class list' stamp: 'HAW 8/2/2018 19:42:28' prior: 16791804! - classList - - ^ self listClassesHierarchically - ifTrue: [self hierarchicalClassList] - ifFalse: [self defaultClassList].! ! -!Browser methodsFor: 'class list' stamp: 'HAW 8/2/2018 19:42:49' prior: 16791814! - classListIndex - "Answer the index of the current class selection." - - ^self classListIndexOf: selectedClassName ! ! -!Browser methodsFor: 'class list' stamp: 'HAW 8/2/2018 19:35:07' prior: 50390432! - classListIndex: anInteger - "Set anInteger to be the index of the current class selection." - - | className recent canSelectClass classList | - - classList _ self classList. - canSelectClass _ classList isInBounds: anInteger. - selectedClassName _ canSelectClass ifTrue: [ | newClassName | - newClassName := classList at: anInteger ifAbsent: [ nil ]. - newClassName := newClassName ifNotNil: [newClassName withoutLeadingBlanks asSymbol]. - newClassName ]. - self setClassOrganizer. - selectedMessageCategory _ nil. - selectedMessage _ nil. - - self classCommentIndicated ifFalse: [ - self editSelection: (canSelectClass - ifTrue: [#editClass] - ifFalse: [ metaClassIndicated | selectedSystemCategory isNil - ifTrue: [#none] - ifFalse: [#newClass]])]. - - self selectedClass ifNotNil: [ - recent _ self class recentClasses. - className _ self selectedClass name. - (recent includes: className) ifTrue: [recent remove: className]. - recent addFirst: className. - recent size > 16 ifTrue: [recent removeLast]]. - - "We have to refresh the class list if somebody wants to select a class that does not exist anymore - Hernan" - anInteger > classList size ifTrue: [ self changed: #classList ]. - self changed: #classSelectionChanged. - self changed: #classCommentText. - self changed: #classListIndex. "update my selection" - self changed: #messageCategoryList. - self changed: #messageList. - self changed: #relabel. - self acceptedContentsChanged! ! -!Browser methodsFor: 'class list' stamp: 'HAW 8/2/2018 19:44:06' prior: 16791874! - selectClass: classNotMeta - - self classListIndex: (self classListIndexOf: classNotMeta name)! ! -!Browser methodsFor: 'class list' stamp: 'HAW 8/2/2018 19:45:38' prior: 16791888! - selectedClassName - "Answer the name of the current class. Answer nil if no selection exists." - - ^selectedClassName - ! ! -!Browser methodsFor: 'metaclass' stamp: 'HAW 8/2/2018 19:45:57' prior: 16792546! - setClassOrganizer - - "Install whatever organization is appropriate" - - | theClass | - - classOrganizer _ nil. - metaClassOrganizer _ nil. - selectedClassName ifNil: [^ self]. - theClass := self selectedClass ifNil: [ ^self ]. - classOrganizer _ theClass organization. - metaClassOrganizer _ theClass class organization.! ! -!HierarchyBrowser methodsFor: 'initialization' stamp: 'HAW 8/2/2018 20:06:54' prior: 50390554! - classListIndex: newIndex - - "Cause system organization to reflect appropriate category" - - | newClassName ind i | - - (classList isInBounds: newIndex) ifTrue: [ - newClassName _ (classList at: newIndex) withoutLeadingBlanks. - i _ systemOrganizer numberOfCategoryOfElement: newClassName. - selectedSystemCategory _ i = 0 ifFalse: [ self systemCategoryList at: i]]. - ind _ super classListIndex: newIndex. - self changed: #systemCategorySingleton. - ^ ind! ! -!HierarchyBrowser methodsFor: 'initialization' stamp: 'HAW 8/2/2018 20:07:42' prior: 16853583! - potentialClassNames - - "Answer the names of all the classes that could be viewed in this browser" - - ^ self classList collect: [:aName | aName withoutLeadingBlanks ]! ! -!HierarchyBrowser methodsFor: 'initialization' stamp: 'HAW 8/2/2018 20:21:08' prior: 16853590! - selectClass: classNotMeta - - self classListIndex: (self classListIndexWhenShowingHierarchicallyOf: classNotMeta name)! ! -!HierarchyBrowser methodsFor: 'initialization' stamp: 'HAW 8/2/2018 20:10:24' prior: 16853600! - selectedClassName - "Answer the name of the class currently selected. di - bug fix for the case where name cannot be found -- return nil rather than halt" - - | aName | - - aName _ super selectedClassName. - ^ aName ifNotNil: [aName withoutLeadingBlanks asSymbol]! ! -!HierarchyBrowser methodsFor: 'class list' stamp: 'HAW 8/2/2018 20:06:27' prior: 16853658! - classList - - classList _ classList select: [:each | Smalltalk includesKey: each withoutLeadingBlanks asSymbol]. - ^ classList! ! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'HAW 8/2/2018 19:17:40' prior: 16906552! - findFirst: aBlock - "Return the index of my first element for which aBlock evaluates as true." - - | index currentSize | - - index _ 0. - currentSize _ self size. - - [(index _ index + 1) <= currentSize ] whileTrue: - [(aBlock value: (self at: index)) ifTrue: [^index]]. - - ^ 0! ! -!String methodsFor: 'converting' stamp: 'HAW 8/2/2018 19:17:01' prior: 16917010! - 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" - last = self size ifTrue: [ ^self ]. - - ^ self copyFrom: 1 to: last - - " ' abc d ' withoutTrailingBlanks" -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3391-BrowserListsHierarchically-HernanWilkinson-2018Aug02-16h49m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3389] on 3 August 2018 at 11:18:15 am'! -!String methodsFor: 'converting' stamp: 'HAW 8/3/2018 11:12:15'! - firstNoBlankIndex - - ^self findFirst: [:aChar | aChar isSeparator not ]! ! -!String methodsFor: 'converting' stamp: 'HAW 8/3/2018 11:12:25'! - lastNoBlankIndex - - ^ self findLast: [:aChar | aChar isSeparator not]. - ! ! -!String methodsFor: 'converting' stamp: 'HAW 8/3/2018 10:57:30' prior: 50407272! - afterBlanksEndsWith: aTail - - ^(self endsWith: aTail) and: [ self firstNoBlankIndex = (self size - aTail size + 1) ] -! ! -!String methodsFor: 'converting' stamp: 'HAW 8/3/2018 11:13:24' prior: 16916886! - withBlanksTrimmed - "Return a copy of the receiver from which leading and trailing blanks have been trimmed." - - | first | - - first _ self firstNoBlankIndex. - first = 0 ifTrue: [^ '']. "no non-separator character" - - ^ self copyFrom: first to: self lastNoBlankIndex - - " ' abc d ' withBlanksTrimmed" -! ! -!String methodsFor: 'converting' stamp: 'HAW 8/3/2018 11:02:05' prior: 50407279! - withoutLeadingBlanks - - "Return a copy of the receiver from which leading blanks have been trimmed." - - | first | - - first := self firstNoBlankIndex. - first = 0 ifTrue: [^ '']. - first = 1 ifTrue: [^ self ]. - - "no non-separator character" - ^ self copyFrom: first to: self size - - " ' abc d ' withoutLeadingBlanks" -! ! -!String methodsFor: 'converting' stamp: 'HAW 8/3/2018 11:08:59' prior: 50407452! - withoutTrailingBlanks - "Return a copy of the receiver from which trailing blanks have been trimmed." - - | last | - - last _ self lastNoBlankIndex. - last = 0 ifTrue: [^ '']. "no non-separator character" - last = self size ifTrue: [ ^self ]. - - ^ self copyFrom: 1 to: last - - " ' abc d ' withoutTrailingBlanks" -! ! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'HAW 8/3/2018 11:05:15' prior: 50405790! - logChange: aStringOrText preamble: preambleOrNil - "Write the argument, aString, onto the changes file." - | aString changesFile | - self assureStartupStampLogged. - aString _ aStringOrText asString. - aString firstNoBlankIndex = 0 ifTrue: [^ self]. "null doits confuse replay" - - (SourceFiles notNil and: [(changesFile _ SourceFiles at: 2) notNil]) ifTrue: [ - changesFile isReadOnly ifFalse: [ - changesFile setToEnd; newLine; newLine. - preambleOrNil ifNotNil: [ - changesFile nextPut: $!!; nextChunkPut: preambleOrNil; newLine ]. - changesFile nextChunkPut: aString. - "If want style changes in DoIt, use nextChunkPutWithStyle:, and allow Texts to get here" - self forceChangesToDisk ]]. - Utilities logsUserChanges ifTrue: [ - Smalltalk defaultUserChangesName asFileEntry appendStreamDo: [ :stream | - stream newLine; newLine. - preambleOrNil ifNotNil: [ - stream nextPut: $!!; nextChunkPut: preambleOrNil; newLine ]. - stream nextChunkPut: aString ]]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3392-String-cleanup-HernanWilkinson-2018Aug02-20h36m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3389] on 3 August 2018 at 11:45:47 am'! -!Browser methodsFor: 'class list' stamp: 'HAW 8/3/2018 11:45:20' prior: 50407366! - selectedClassName - "Answer the name of the current class. Answer nil if no selection exists." - - ^selectedClassName ifNotNil: [ - "I send #defaultClassList and no #classList because when showing classes hierarchically we should remove spaces to see - if class name is in the list and that consumes more time - Hernan" - (self defaultClassList includes: selectedClassName) ifTrue: [ selectedClassName ]]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3393-Browser-recent-bug-fix-HernanWilkinson-2018Aug03-11h18m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3389] on 3 August 2018 at 2:54:59 pm'! - -CodeProvider subclass: #Browser - instanceVariableNames: 'systemOrganizer classOrganizer metaClassOrganizer selectedSystemCategory selectedClassName selectedMessageCategory selectedMessage editSelection metaClassIndicated listClassesHierarchically ' - classVariableNames: 'RecentClasses ' - poolDictionaries: '' - category: 'Tools-Browser'! - -!classDefinition: #Browser category: #'Tools-Browser'! -CodeProvider subclass: #Browser - instanceVariableNames: 'systemOrganizer classOrganizer metaClassOrganizer selectedSystemCategory selectedClassName selectedMessageCategory selectedMessage editSelection metaClassIndicated listClassesHierarchically' - classVariableNames: 'RecentClasses' - poolDictionaries: '' - category: 'Tools-Browser'! -!Browser methodsFor: 'class list' stamp: 'HAW 8/3/2018 12:29:41'! - enableListClassesAlphabetically - - self listClassesHierarchically: false! ! -!Browser methodsFor: 'class list' stamp: 'HAW 8/3/2018 12:29:30'! - enableListClassesHierarchically - - self listClassesHierarchically: true! ! -!Browser methodsFor: 'class list' stamp: 'HAW 8/3/2018 14:49:36'! - listClassesHierarchically: aBoolean - - listClassesHierarchically := aBoolean. - - self changed: #classList. - self changed: #classListIndex. -! ! -!Browser methodsFor: 'initialization' stamp: 'HAW 8/3/2018 14:51:55'! - initialize - - super initialize. - self initializeListClassesHierachically! ! -!Browser methodsFor: 'initialization' stamp: 'HAW 8/3/2018 14:51:47'! - initializeListClassesHierachically - - listClassesHierarchically _ self class listClassesHierarchically ! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'HAW 8/3/2018 11:59:30'! - createClassButton - - | classSwitch | - - classSwitch := PluggableButtonMorph - model: model - stateGetter: #classMessagesIndicated - action: #indicateClassMessages. - - classSwitch - label: 'class'; - setBalloonText: 'show class methods'. - - ^classSwitch! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'HAW 8/3/2018 11:59:41'! - createCommentButton - - | commentSwitch | - - commentSwitch := PluggableButtonMorph - model: model - stateGetter: #classCommentIndicated - action: #plusButtonHit. - - commentSwitch - label: '?'; - setBalloonText: 'show class comment'. - - ^commentSwitch ! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'HAW 8/3/2018 11:59:22'! - createInstanceButton - - | instanceSwitch | - - instanceSwitch := PluggableButtonMorph - model: model - stateGetter: #instanceMessagesIndicated - action: #indicateInstanceMessages. - - instanceSwitch - label: 'instance'; - setBalloonText: 'show instance methods'. - - ^instanceSwitch ! ! -!Browser methodsFor: 'class list' stamp: 'HAW 8/3/2018 14:52:35' prior: 50407251! - listClassesHierarchically - - "I check for nil to support migration on already opened browser when the change is loaded in image - Hernan" - ^listClassesHierarchically ifNil: [ self initializeListClassesHierachically]! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'HAW 8/3/2018 14:54:25' prior: 16793097! - buildMorphicSwitches - - | instanceSwitch commentSwitch classSwitch row buttonColor | - - instanceSwitch _ self createInstanceButton. - commentSwitch _ self createCommentButton. - classSwitch _ self createClassButton. - - row _ LayoutMorph newRow. - row - doAdoptWidgetsColor; - addMorph: instanceSwitch proportionalWidth: 0.45; - addMorph: commentSwitch proportionalWidth: 0.22; - addMorph: classSwitch proportionalWidth: 0.33. - buttonColor _ self buttonColor. - row color: buttonColor. - - { - instanceSwitch. - commentSwitch. - classSwitch} do: [:m | m color: buttonColor ]. - - ^row! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 8/3/2018 14:47:08' prior: 50403114! - classListMenuOptions - - ^ `{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutClass. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 5. - #label -> 'show classes hierarchically'. - #object -> #model. - #selector -> #enableListClassesHierarchically. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 6. - #label -> 'show classes alphabetically'. - #object -> #model. - #selector -> #enableListClassesAlphabetically. - #icon -> #sendReceiveIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'show hierarchy'. - #object -> #model. - #selector -> #hierarchy. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'show definition'. - #object -> #model. - #selector -> #editClass. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'show comment'. - #object -> #model. - #selector -> #editComment. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'inst var refs...'. - #selector -> #browseInstVarRefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'inst var defs...'. - #selector -> #browseInstVarDefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'class var refs...'. - #selector -> #browseClassVarRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 20. - #label -> 'class vars'. - #selector -> #browseClassVariables. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'class refs (N)'. - #selector -> #browseClassRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'rename class ...'. - #object -> #model. - #selector -> #renameClass. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 20. - #label -> 'copy class...'. - #object -> #model. - #selector -> #copyClass. - #icon -> #copyIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 30. - #label -> 'remove class (x)'. - #object -> #model. - #selector -> #removeClass. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 10. - #label -> 'run tests (t)'. - #object -> #model. - #selector -> #runClassTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 20. - #label -> 'more...'. - #selector -> #offerClassListMenu2. - #icon -> #listAddIcon - } asDictionary. - }`. - ! ! - -HierarchyBrowserWindow removeSelector: #buildMorphicSwitches! - -BrowserWindow removeSelector: #createListClassesAlphabetically! - -BrowserWindow removeSelector: #createListClassesAlphabeticallyButton! - -BrowserWindow removeSelector: #createListClassesHierarchically! - -BrowserWindow removeSelector: #createListClassesHierarchicallyButton! - -Browser removeSelector: #listClassesAlphabetically! - -CodeProvider subclass: #Browser - instanceVariableNames: 'systemOrganizer classOrganizer metaClassOrganizer selectedSystemCategory selectedClassName selectedMessageCategory selectedMessage editSelection metaClassIndicated listClassesHierarchically' - classVariableNames: 'RecentClasses' - poolDictionaries: '' - category: 'Tools-Browser'! - -!classDefinition: #Browser category: #'Tools-Browser'! -CodeProvider subclass: #Browser - instanceVariableNames: 'systemOrganizer classOrganizer metaClassOrganizer selectedSystemCategory selectedClassName selectedMessageCategory selectedMessage editSelection metaClassIndicated listClassesHierarchically' - classVariableNames: 'RecentClasses' - poolDictionaries: '' - category: 'Tools-Browser'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3394-BrowserShowHierarchically-perBrowserOption-HernanWilkinson-2018Aug03-11h45m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3394] on 4 August 2018 at 2:48:52 pm'! -!Browser methodsFor: 'class list' stamp: 'jmv 8/4/2018 14:48:21' prior: 50407157! - classListIndexOf: aClassNameToFind - - "Answer the index of the aClassName selection." - - aClassNameToFind ifNil: [ ^0 ]. - ^self classList findFirst: [ :showingClassName | - "Works regardless of currently showing hierarchically or alphabetically." - showingClassName afterBlanksEndsWith: aClassNameToFind ]! ! -!HierarchyBrowser methodsFor: 'initialization' stamp: 'jmv 8/4/2018 14:48:30' prior: 50407413! - selectClass: classNotMeta - - self classListIndex: (self classListIndexOf: classNotMeta name)! ! - -Browser removeSelector: #classListIndexWhenShowingHierarchicallyOf:! - -Browser removeSelector: #classListIndexWhenShowingHierarchicallyOf:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3395-SlightSimplification-JuanVuletich-2018Aug04-14h48m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3395] on 4 August 2018 at 3:59:49 pm'! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph drawingMorphStack ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph drawingMorphStack' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 8/4/2018 15:46:00' prior: 16877545! - into: aMorph - | location previousLast | - location _ aMorph location. - drawingMorphStack ifNil: [ drawingMorphStack _ transformations collect: [ :t | nil ]]. - drawingMorphStack size = transformations size ifFalse: [ drawingMorphStack _ transformations collect: [ :t | nil ]]. - currentMorph _ aMorph. - cti _ cti + 1. - transformations size < cti - ifTrue: [ - drawingMorphStack add: aMorph. - currentTransformation _ currentTransformation composedWith: location. - transformations add: currentTransformation ] - ifFalse: [ - drawingMorphStack at: cti put: aMorph. - previousLast _ currentTransformation. - currentTransformation _ transformations at: cti. - "reuse the instance if possible" - (previousLast class == location class and: [ previousLast class == currentTransformation class ]) - ifTrue: [ - previousLast composedWith: location into: currentTransformation ] - ifFalse: [ - currentTransformation _ previousLast composedWith: location. - transformations at: cti put: currentTransformation ]]! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 8/4/2018 15:58:56' prior: 16877580! - outOfMorph - - drawingMorphStack at: cti put: nil. "Don't hold any morphs that could be collected" - cti _ cti - 1. - currentTransformation _ transformations at: cti. -" currentMorph _ drawingMorphStack at: cti" - currentMorph _ currentMorph owner! ! -!MorphicCanvas methodsFor: 'initialization' stamp: 'jmv 8/4/2018 15:37:46' prior: 16877585! - initializeWith: aForm origin: aPoint - self initialize. - self setForm: aForm. - - "We currently set up these only on initialization. - This is safe (wrt walkbacks during world redraw) because a new instance is created - each time the world is redrawn. See #drawInvalidAreasWorld:submorphs: - Maybe this cleanup should be in an aux method that can be called each time on an existing instance..." - currentTransformation _ MorphicTranslation withTranslation: aPoint. - cti _ 1. - transformations - ifNil: [ transformations _ OrderedCollection with: currentTransformation ] - ifNotNil: [ transformations at: cti put: currentTransformation ]. - drawingMorphStack - ifNil: [ drawingMorphStack _ OrderedCollection with: nil ] - ifNotNil: [ drawingMorphStack at: cti put: nil ].! ! - -MorphicCanvas removeSelector: #intoLocation:! - -MorphicCanvas removeSelector: #intoLocation:! - -MorphicCanvas removeSelector: #outOfLocation! - -MorphicCanvas removeSelector: #outOfLocation! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph drawingMorphStack' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph drawingMorphStack' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -MorphicCanvas allSubInstancesDo: [ :each | each instVarNamed: 'drawingMorphStack' put: ((each instVarNamed: 'transformations') collect: [ :t | nil])].! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3396-MoreRobustCanvas-JuanVuletich-2018Aug04-15h58m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3395] on 4 August 2018 at 4:01:01 pm'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 8/4/2018 16:00:30' prior: 50407920! - into: aMorph - | location previousLast | - location _ aMorph location. - currentMorph _ aMorph. - cti _ cti + 1. - transformations size < cti - ifTrue: [ - drawingMorphStack add: aMorph. - currentTransformation _ currentTransformation composedWith: location. - transformations add: currentTransformation ] - ifFalse: [ - drawingMorphStack at: cti put: aMorph. - previousLast _ currentTransformation. - currentTransformation _ transformations at: cti. - "reuse the instance if possible" - (previousLast class == location class and: [ previousLast class == currentTransformation class ]) - ifTrue: [ - previousLast composedWith: location into: currentTransformation ] - ifFalse: [ - currentTransformation _ previousLast composedWith: location. - transformations at: cti put: currentTransformation ]]! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 8/4/2018 16:00:39' prior: 50407955! - outOfMorph - - drawingMorphStack at: cti put: nil. "Don't hold any morphs that could be collected" - cti _ cti - 1. - currentTransformation _ transformations at: cti. - currentMorph _ drawingMorphStack at: cti! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3397-MoreRobustCanvas-JuanVuletich-2018Aug04-15h59m-jmv.1.cs.st----! - -----SNAPSHOT----#(6 August 2018 6:24:55.336826 pm) Cuis5.0-3397-v3.image priorSource: 2413977! - -----QUIT----#(6 August 2018 6:25:12.899278 pm) Cuis5.0-3397-v3.image priorSource: 2445720! - -----STARTUP----#(9 August 2018 6:35:06.413916 pm) as /home/juan/Rectifier/Cuis-Smalltalk-Dev/Cuis5.0-3397-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3397] on 9 August 2018 at 10:46:43 am'! -!DirectoryEntry methodsFor: 'enumeration' stamp: 'jmv 8/9/2018 10:41:27' prior: 16834451! - allChildrenDo: aBlock - self childrenDo: [ :child | - aBlock value: child ]. - self allDirectoriesDo: [ :child | - child allChildrenDo: aBlock]! ! -!FeatureRequirement methodsFor: 'private' stamp: 'jmv 8/9/2018 10:45:45' prior: 50405928! - withPackageSubfoldersOf: aDirectoryEntry do: aBlock - - "Look in the requested directory" - aBlock value: aDirectoryEntry. - - "Look in ./Packages/ and subfolders" - aDirectoryEntry / 'Packages' ifExists: [ :packagesFolder | - aBlock value: packagesFolder. - packagesFolder allDirectoriesDo: aBlock ]! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3398-PackageFolderReorganization-JuanVuletich-2018Aug09-09h22m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3398] on 9 August 2018 at 11:45:19 am'! - -GeometryTransformation variableWordSubclass: #AffineTransformation - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -!classDefinition: #AffineTransformation category: #'Graphics-Primitives'! -GeometryTransformation variableWordSubclass: #AffineTransformation - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -GeometryTransformation variableWordSubclass: #Homography - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -!classDefinition: #Homography category: #'Graphics-Primitives'! -GeometryTransformation variableWordSubclass: #Homography - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Primitives'! -!Homography commentStamp: '' prior: 0! - An homography (or perspective transformation) for resampling images (for example). Can apply or correct for the perspective resulting from taking a photograph to a 2D object that is not perpendicular to the camera axis (for example, taking an image of the ground ahead of the camera). - -http://docs.opencv.org/modules/imgproc/doc/geometric_transformations.html#warpperspective - -To be of use, needs #map:to: in NumCuis/ImageProcessing.pck.st! - -GeometryTransformation subclass: #MorphicTranslation - instanceVariableNames: 'deltaX deltaY ' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -!classDefinition: #MorphicTranslation category: #'Graphics-Primitives'! -GeometryTransformation subclass: #MorphicTranslation - instanceVariableNames: 'deltaX deltaY' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Primitives'! -!Morph commentStamp: '' prior: 16873905! - A Morph (from the Greek "shape" or "form") is an interactive graphical object. General information on the Morphic system can be found at http://wiki.squeak.org/squeak/morph. - -Morphs exist in a tree, rooted at a World (generally a PasteUpMorph). The morphs owned by a morph are its submorphs. Morphs are drawn recursively; if a Morph has no owner it never gets drawn. To hide a Morph and its submorphs, set its #visible property to false using the #visible: method. - -Structure: -instance var Type Description -owner Morph My parent Morph, or nil for the top-level Morph, which is a - or nil world, typically a PasteUpMorph. -submorphs Array My child Morphs. -location MorphicTranslation Specifies position (and possibly, angle of rotation and scale change) inside owner - or AffineTransformation -extension MorphExtension Allows extra properties to be stored without adding a - or nil storage burden to all morphs. -! -!GeometryTransformation methodsFor: 'testing' stamp: 'jmv 8/9/2018 11:25:47'! - is: aSymbol - ^aSymbol == #GeometryTransformation or: [ super is: aSymbol ]! ! -!GeometryTransformation methodsFor: 'testing' stamp: 'jmv 8/9/2018 11:27:48'! - isPureTranslation - "Return true if the receiver specifies no rotation or scaling." - ^false! ! -!Homography methodsFor: 'element access' stamp: 'jmv 8/9/2018 11:22:18'! - a0 - ^self at: 1! ! -!Homography methodsFor: 'element access' stamp: 'jmv 8/9/2018 11:22:18'! - a1 - ^self at: 2! ! -!Homography methodsFor: 'element access' stamp: 'jmv 8/9/2018 11:22:18'! - a2 - ^self at: 3! ! -!Homography methodsFor: 'element access' stamp: 'jmv 8/9/2018 11:22:18'! - b0 - ^self at: 4! ! -!Homography methodsFor: 'element access' stamp: 'jmv 8/9/2018 11:22:18'! - b1 - ^self at: 5! ! -!Homography methodsFor: 'element access' stamp: 'jmv 8/9/2018 11:22:18'! - b2 - ^self at: 6! ! -!Homography methodsFor: 'element access' stamp: 'jmv 8/9/2018 11:22:18'! - c0 - ^self at: 7! ! -!Homography methodsFor: 'element access' stamp: 'jmv 8/9/2018 11:22:18'! - c1 - ^self at: 8! ! -!Homography methodsFor: 'private access' stamp: 'jmv 8/9/2018 11:22:18'! - at: index - - ^Float fromIEEE32Bit: (self basicAt: index)! ! -!Homography methodsFor: 'private access' stamp: 'jmv 8/9/2018 11:22:18'! - at: index put: value - - value isFloat - ifTrue:[self basicAt: index put: value asIEEE32BitWord] - ifFalse:[self at: index put: value asFloat]. - ^value! ! -!Homography methodsFor: 'converting coordinates' stamp: 'jmv 8/9/2018 11:22:18'! - map: aPoint - | xx yy zz | - xx _ (self a0 * aPoint x) + (self a1 * aPoint y) + self a2. - yy _ (self b0 * aPoint x) + (self b1 * aPoint y) + self b2. - zz _ (self c0 * aPoint x) + (self c1 * aPoint y) + 1. - ^(xx / zz) @ (yy / zz)! ! -!Homography class methodsFor: 'instance creation' stamp: 'jmv 8/9/2018 11:22:18'! - new - ^(self basicNew: 8) initialize! ! -!Homography class methodsFor: 'instance creation' stamp: 'jmv 8/9/2018 11:23:34'! - new: s - self error: 'Please call Homography>>#new (without arguments).'. - ^self new! ! -!MorphicTranslation methodsFor: 'comparing' stamp: 'jmv 8/9/2018 11:26:07' prior: 16878311! - = aMorphicTranslation - self == aMorphicTranslation ifTrue: [ ^ true ]. - (aMorphicTranslation is: #GeometryTransformation) ifFalse: [ ^false ]. - aMorphicTranslation isPureTranslation ifFalse: [ ^false ]. - ^self translation = aMorphicTranslation translation! ! - -Homography class removeSelector: #map:to:! - -GeometryTransformation subclass: #MorphicTranslation - instanceVariableNames: 'deltaX deltaY' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -!classDefinition: #MorphicTranslation category: #'Graphics-Primitives'! -GeometryTransformation subclass: #MorphicTranslation - instanceVariableNames: 'deltaX deltaY' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -Smalltalk removeClassNamed: #MorphicLocation! - -Smalltalk removeClassNamed: #MorphicLocation! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3399-GeometryTransformation-refactor-JuanVuletich-2018Aug09-11h38m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3399] on 9 August 2018 at 1:17:11 pm'! -!Form methodsFor: 'pixel access' stamp: 'jmv 8/8/2018 14:17:49'! - i: i j: j - "Compatibility with Matrices" - ^ self colorAt: j@i -1! ! -!Form methodsFor: 'pixel access' stamp: 'jmv 8/8/2018 14:18:01'! - i: i j: j put: aColor - "Compatibility with Matrices" - ^ self colorAt: j@i -1 put: aColor! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3400-Form-MatrixCompatibleElementAccess-JuanVuletich-2018Aug09-12h40m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3400] on 9 August 2018 at 6:13:10 pm'! -!Form methodsFor: 'displaying' stamp: 'jmv 8/9/2018 16:23:10'! - displayAutoRangeAt: aPoint - "Display receiver, mapping used range to available gray levels" - - ^ self displayAutoRangeAt: aPoint zoom: 1! ! -!Form methodsFor: 'displaying' stamp: 'jmv 8/9/2018 16:22:37'! - displayAutoRangeAt: aPoint zoom: scale - "Display receiver, compatibility with Matrix and subclasses such as FloatImage" - - | form | - form _ self. - scale = 1 ifFalse: [ - form _ form magnifyBy: scale ]. - form displayAt: aPoint. - ^ form! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3401-Form-MatrixCompatibleDisplay-JuanVuletich-2018Aug09-16h22m-jmv.1.cs.st----! - -----SNAPSHOT----#(9 August 2018 6:35:14.108338 pm) Cuis5.0-3401-v3.image priorSource: 2445816! - -----QUIT----#(9 August 2018 6:35:26.927056 pm) Cuis5.0-3401-v3.image priorSource: 2454532! - -----STARTUP----#(15 August 2018 3:59:23.282491 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3401-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3401] on 10 August 2018 at 11:07:42 am'! -!SinglePackageBrowser methodsFor: 'lists' stamp: 'jmv 8/10/2018 11:05:40'! - defaultClassList - "Answer an array of the class names of the selected category. Answer an - empty array if no selection exists." - | answer | - answer _ selectedSystemCategory - ifNil: [#()] - ifNotNil: [ - (package includesSystemCategory: selectedSystemCategory) - ifTrue: [ systemOrganizer listAtCategoryNamed: selectedSystemCategory ] - ifFalse: [ - package extensionClassNamesIn: (selectedSystemCategory copyFrom: 2 to: selectedSystemCategory size) ]]. - selectedClassName ifNil: [ - answer size = 0 ifFalse: [ - selectedClassName _ answer first. - self setClassOrganizer. - self editSelection: #editClass ]]. - ^answer! ! - -SinglePackageBrowser removeSelector: #classList! - -SinglePackageBrowser removeSelector: #classList! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3402-PackageBrowser-fix-JuanVuletich-2018Aug10-11h05m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3402] on 10 August 2018 at 4:45:43 pm'! -!Form methodsFor: 'converting' stamp: 'jmv 8/10/2018 15:19:49'! - asFormAutoRange - "In optional packages (LinearAlgebra, ImageProcessing) we might have #asFormAutoRange - conversion methods for other kinds of objects." - ^self! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3403-asFormAutoRange-JuanVuletich-2018Aug10-15h19m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3403] on 12 August 2018 at 11:35:10 pm'! -!CompiledMethod methodsFor: 'comparing' stamp: 'jmv 8/12/2018 23:31:38' prior: 50334684! - = method - | numLits lit1 lit2 firstLitIndex | - - "Any object is equal to itself" - self == method ifTrue: [ ^ true ]. - - "Answer whether the receiver implements the same code as the - argument, method." - (method is: #CompiledMethod) ifFalse: [ ^false ]. - self size = method size ifFalse: [ ^false ]. - self header = method header ifFalse: [ ^false ]. - self initialPC to: self endPC do: [ :i | - (self at: i) = (method at: i) ifFalse: [ ^false ]]. - (numLits _ self numLiterals) ~= method numLiterals ifTrue: [ ^false ]. - - "Dont bother checking FFI and named primitives'' - jmv: Does this make any sense? - (#(117 120) includes: self primitive) ifTrue: [^ true]." - - "properties" - (self properties analogousCodeTo: method properties) ifFalse: [ - ^false ]. - - firstLitIndex _ 1. - (#(117 120) includes: self primitive) ifTrue: [ - lit1 _ self literalAt: firstLitIndex. - lit2 _ method literalAt: firstLitIndex. - lit1 isArray - ifTrue: [ - (lit2 isArray and: [ lit1 first = lit2 first and: [lit1 second = lit2 second]]) ifFalse: [ - ^false ]] - ifFalse: [ "ExternalLibraryFunction" - (lit1 analogousCodeTo: lit2) ifFalse: [ - ^false ]]. - firstLitIndex _ 2 ]. - - "#penultimateLiteral is selector (or properties, just compared, above) - Last literal is #methodClass. - Don't compare them. Two methods might be equal even if they have different selector (or none at all) - or are installed in different classes (or none at all)" - firstLitIndex to: numLits-2 do: [ :i | - lit1 _ self literalAt: i. - lit2 _ method literalAt: i. - lit1 = lit2 ifFalse: [ - "any other discrepancy is a failure" - ^ false ]]. - ^true! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'jmv 8/12/2018 21:36:15' prior: 50391827! - xBacktick - "Smalltalk code evaluated at compile time as a literal." - - self step. - buffer reset. - [hereChar == $` - and: [aheadChar == $` - ifTrue: [self step. false] - ifFalse: [true]]] - whileFalse: [ - buffer nextPut: self step. - (hereChar = Scanner doItCharacterValue asCharacter and: [source atEnd]) - ifTrue: [^self offEnd: 'Unmatched back quote']]. - self step. - [ | compiler method methodNode | - compiler _ Compiler new. - methodNode _ compiler compileNoPattern: buffer contents in: UndefinedObject context: nil notifying: nil ifFail: []. - method _ methodNode generate. - "Grab all messages sent while evaluating literal, so the main method will be shown as senders of them" - sentInLiterals addAll: method messages. - method literalsDo: [ :literal | literal isSymbol ifTrue: [ literal = #DoIt ifFalse: [sentInLiterals add: literal ]]]. - "Evaluate now." - token _ nil withArgs: #() executeMethod: method. - ] - on: SyntaxErrorNotification, UndeclaredVariableReference, Error - do: [ :ex | - ex class caseOf: { - [ SyntaxErrorNotification ] -> [ - self notify: 'Can not compile: ', ex errorMessage at: mark]. - [ UndeclaredVariableReference ] -> [ - self notify: 'Can not compile: Variable ''', ex varName, ''' is not declared' at: mark ] - } otherwise: [ - self notify: 'Can not evaluate code: ', ex description at: mark ]]. - tokenType _ #literal! ! -!Encoder methodsFor: 'results' stamp: 'jmv 8/12/2018 22:28:05' prior: 16837182! - allLiterals - addedSelectorAndMethodClassLiterals ifFalse: - [addedSelectorAndMethodClassLiterals := true. - "Put the optimized selectors in literals so as to browse senders more easily" - optimizedSelectors := optimizedSelectors reject: [:e| literalStream originalContents hasLiteral: e]. - optimizedSelectors isEmpty ifFalse: [ - "Use one entry per literal if enough room, else make anArray" - literalStream position + optimizedSelectors size + 2 >= self maxNumLiterals - ifTrue: [self litIndex: optimizedSelectors asArray sort] - ifFalse: [optimizedSelectors sorted do: [:e | self litIndex: e]]]. - "Add a slot for selector or MethodProperties" - self litIndex: nil. - self litIndex: self associationForClass]. - ^literalStream contents! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -ProtoObject withAllSubclasses do: [:c | c compileAll ].! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3404-ThreeCompiledMethodBugFixes-JuanVuletich-2018Aug12-23h34m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3404] on 15 August 2018 at 3:42:44 pm'! -!MenuItemMorph methodsFor: 'events' stamp: 'jmv 8/15/2018 15:42:06' prior: 16865939! - activateSubmenu: evt - "Activate our submenu; e.g., pass control to it" - subMenu ifNil: [ ^false ]. "not applicable" - (subMenu morphContainsPoint: (subMenu internalizeFromWorld: evt eventPosition)) ifFalse:[^false]. - subMenu activate: evt. - ^true! ! -!MenuItemMorph methodsFor: 'selecting' stamp: 'jmv 8/15/2018 15:41:44' prior: 50341137! - deselect - - self isSelected: false. - subMenu ifNotNil: [ - owner ifNotNil: [ owner activeSubmenu: nil ]]! ! - -MenuItemMorph removeSelector: #deselectTimeOut! - -MenuItemMorph removeSelector: #deselectTimeOut! - -MenuItemMorph removeSelector: #mouseLeave:! - -MenuItemMorph removeSelector: #mouseLeave:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3405-MenuFix-JuanVuletich-2018Aug15-15h41m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3403] on 11 August 2018 at 7:33:37 pm'! - -ParseNode subclass: #MessageNode - instanceVariableNames: 'receiver selector precedence special arguments sizes equalNode caseErrorNode originalReceiver originalSelector originalArguments keywordRanges ' - classVariableNames: 'MacroEmitters MacroPrinters MacroSelectors MacroSizers MacroTransformers ' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #MessageNode category: #'Compiler-ParseNodes'! -ParseNode subclass: #MessageNode - instanceVariableNames: 'receiver selector precedence special arguments sizes equalNode caseErrorNode originalReceiver originalSelector originalArguments keywordRanges' - classVariableNames: 'MacroEmitters MacroPrinters MacroSelectors MacroSizers MacroTransformers' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -ParseNode subclass: #MethodNode - instanceVariableNames: 'selectorOrFalse precedence arguments block primitive encoder temporaries properties sourceText locationCounter localsPool selectorKeywordsRanges ' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #MethodNode category: #'Compiler-ParseNodes'! -ParseNode subclass: #MethodNode - instanceVariableNames: 'selectorOrFalse precedence arguments block primitive encoder temporaries properties sourceText locationCounter localsPool selectorKeywordsRanges' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! -!CodeProvider methodsFor: 'message list menu' stamp: 'HAW 8/11/2018 18:52:25'! - inspectCompiledMethod - "Open an Inspector on the CompiledMethod itself" - - self selectedMessageName ifNotNil: [ - (self selectedClassOrMetaClass compiledMethodAt: self selectedMessageName) - inspect ]! ! -!Behavior methodsFor: 'methods' stamp: 'HAW 8/11/2018 18:49:25'! - methodNodeFor: aSourceCode - - | parser methodNode | - - parser := self parserClass new - encoderClass: EncoderForV3PlusClosures; - yourself. - - methodNode := parser parse: aSourceCode class: self. - methodNode sourceText: aSourceCode. - - ^methodNode - ! ! -!ParseNode methodsFor: 'testing' stamp: 'HAW 8/11/2018 19:00:35'! - isInstanceVariableNode - - ^false! ! -!ParseNode methodsFor: 'testing' stamp: 'HAW 8/11/2018 19:26:31'! - isMessageNamed: aSelector - - ^ false! ! -!Encoder methodsFor: 'temps' stamp: 'HAW 8/11/2018 19:09:30'! - bindArg: aName range: aRange - - ^ self addMultiRange: aRange for: (self bindArg: aName) -! ! -!Encoder methodsFor: 'temps' stamp: 'HAW 8/11/2018 19:13:38'! - bindTemp: aName range: aRange - - ^ self addMultiRange: aRange for: (self bindTemp: aName)! ! -!Encoder methodsFor: 'encoding' stamp: 'HAW 8/11/2018 19:14:52'! - encodeLiteral: object range: aRange - - ^ self addMultiRange: aRange for: (self encodeLiteral: object)! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 8/11/2018 19:11:31'! - addMultiRange: aRange for: aNode - - | ranges | - - "I'm using an OrderedCollection because ranges are added in order, while parsing the source code. - If this constrain is not hold, a SortedCollection should be used - Hernan" - ranges := sourceRanges at: aNode ifAbsentPut: [ OrderedCollection new ]. - ranges add: aRange. - - ^aNode ! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 8/11/2018 19:30:24'! - messageSendSelectorKeywordRangesOf: aSelector ifAbsent: aBlock - - | ranges sortedRanges | - - ranges := sourceRanges keys - select: [ :aParseNode | aParseNode isMessageNamed: aSelector ] - thenCollect: [ :aMessageSendNode | aMessageSendNode keywordRanges ]. - - ranges isEmpty ifTrue: [ ^aBlock value ]. - sortedRanges := ranges asSortedCollection: [ :left :right | left first first < right first first ]. - - ^sortedRanges ! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 8/11/2018 18:59:11'! - rangesForInstanceVariable: aName ifAbsent: aBlock - - ^ self - rangesForVariable: aName - checkingType: [ :variableNode | variableNode isInstanceVariableNode ] - ifAbsent: aBlock ! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 8/11/2018 18:59:25'! - rangesForTemporaryVariable: aName ifAbsent: aBlock - - ^ self - rangesForVariable: aName - checkingType: [ :variableNode | variableNode isTemp ] - ifAbsent: aBlock ! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 8/11/2018 18:58:07'! - rangesForVariable: aName checkingType: nodeTypeCheckBlock ifAbsent: anAbsentBlock - - | variableNode | - - variableNode := scopeTable at: aName ifAbsent: [ ^anAbsentBlock value ]. - (nodeTypeCheckBlock value: variableNode) ifFalse: [ ^anAbsentBlock value ]. - - ^sourceRanges at: variableNode ifAbsent: anAbsentBlock ! ! -!InstanceVariableNode methodsFor: 'testing' stamp: 'HAW 8/11/2018 19:00:19'! - isInstanceVariableNode - - ^true! ! -!MessageNode methodsFor: 'source ranges' stamp: 'HAW 8/11/2018 19:24:24'! - keywordRanges - - ^keywordRanges! ! -!MessageNode methodsFor: 'testing' stamp: 'HAW 8/11/2018 19:23:56'! - isMessageNamed: aSelector - - ^aSelector == selector key! ! -!MessageNode methodsFor: 'initialization' stamp: 'HAW 8/11/2018 19:21:33'! - receiver: aReceiver selector: aSelector arguments: args precedence: aPrecedence from: anEncoder sourceRange: aSourceRange keywordsRanges: wordsRanges - - keywordRanges := wordsRanges. - - ^self receiver: aReceiver selector: aSelector arguments: args precedence: aPrecedence from: anEncoder sourceRange: aSourceRange ! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 8/11/2018 19:01:49'! - rangesForInstanceVariable: aName ifAbsent: aBlock - - ^encoder rangesForInstanceVariable: aName ifAbsent: aBlock -! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 8/11/2018 19:01:59'! - rangesForTemporaryVariable: aName ifAbsent: aBlock - - ^encoder rangesForTemporaryVariable: aName ifAbsent: aBlock -! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 8/11/2018 19:06:30'! - selectorKeywordsRanges - - ^selectorKeywordsRanges! ! -!MethodNode methodsFor: 'initialization' stamp: 'HAW 8/11/2018 19:27:21'! - selector: selOrFalse arguments: args precedence: p temporaries: temps block: blk encoder: anEncoder primitive: prim properties: propDict selectorKeywordsRanges: range - - selectorKeywordsRanges := range. - - ^self selector: selOrFalse arguments: args precedence: p temporaries: temps block: blk encoder: anEncoder primitive: prim properties: propDict ! ! -!CompiledMethod methodsFor: 'decompiling' stamp: 'HAW 8/11/2018 18:50:26' prior: 16820711! - methodNode - "Return the parse tree that represents self" - - | aClass source | - - aClass := self methodClass. - source := self - getSourceFor: (self selector ifNil: [self defaultSelector]) - in: aClass. - - ^ aClass methodNodeFor: source - ! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 8/11/2018 18:51:50' prior: 50403373! - messageListMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'what to show...'. - #selector -> #offerWhatToShowMenu. - #icon -> #preferencesIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'toggle break on entry'. - #object -> #model. - #selector -> #toggleBreakOnEntry. - #icon -> #debugIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'browse method (O)'. - #selector -> #openSingleMessageBrowser. - #icon -> #scriptIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 40. - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutMessage. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'inspect CompiledMethod'. - #object -> #model. - #selector -> #inspectCompiledMethod. - #icon -> #exploreIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'senders of... (n)'. - #selector -> #browseSendersOfMessages. - #icon -> #mailForwardIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'implementors of... (m)'. - #selector -> #browseMessages. - #icon -> #developmentIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'inheritance (i)'. - #selector -> #methodHierarchy. - #icon -> #goDownIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 40. - #label -> 'versions (v)'. - #selector -> #browseVersions. - #icon -> #clockIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'inst var refs...'. - #selector -> #browseInstVarRefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 20. - #label -> 'inst var defs...'. - #selector -> #browseInstVarDefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'class var refs...'. - #selector -> #browseClassVarRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 40. - #label -> 'class variables'. - #selector -> #browseClassVariables. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 50. - #label -> 'class refs (N)'. - #selector -> #browseClassRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'remove method (x)'. - #object -> #model. - #selector -> #removeMessage. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 20. - #label -> 'run test (t)'. - #object -> #model. - #selector -> #runMethodTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 30. - #label -> 'debug test (r)'. - #object -> #model. - #selector -> #debugMethodTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 10. - #label -> 'more...'. - #selector -> #openMessageListMenu2. - #icon -> #listAddIcon - } asDictionary. - }`. - ! ! - -CodeProvider removeSelector: #exploreCompiledMethod! - -CodeProvider removeSelector: #exploreCompiledMethod! - -ParseNode subclass: #MessageNode - instanceVariableNames: 'receiver selector precedence special arguments sizes equalNode caseErrorNode originalReceiver originalSelector originalArguments keywordRanges' - classVariableNames: 'MacroEmitters MacroPrinters MacroSelectors MacroSizers MacroTransformers' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #MessageNode category: #'Compiler-ParseNodes'! -ParseNode subclass: #MessageNode - instanceVariableNames: 'receiver selector precedence special arguments sizes equalNode caseErrorNode originalReceiver originalSelector originalArguments keywordRanges' - classVariableNames: 'MacroEmitters MacroPrinters MacroSelectors MacroSizers MacroTransformers' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -ParseNode subclass: #MethodNode - instanceVariableNames: 'selectorOrFalse precedence arguments block primitive encoder temporaries properties sourceText locationCounter localsPool selectorKeywordsRanges' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #MethodNode category: #'Compiler-ParseNodes'! -ParseNode subclass: #MethodNode - instanceVariableNames: 'selectorOrFalse precedence arguments block primitive encoder temporaries properties sourceText locationCounter localsPool selectorKeywordsRanges' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3406-ParserEnhancements-HernanWilkinson-2018Aug11-18h49m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3403] on 11 August 2018 at 7:59:09 pm'! -!Parser methodsFor: 'scanning' stamp: 'HAW 8/11/2018 19:36:55'! - advanceWithRangeDo: aBlock - - | lexema start end | - - start := self startOfNextToken + requestorOffset. - lexema := self advance. - end _ self endOfLastToken + requestorOffset. - - ^ aBlock value: lexema value: (start to: end)! ! -!Parser methodsFor: 'temps' stamp: 'HAW 8/11/2018 19:45:20'! - bindArg: aName range: aRange - - ^ self bindArg: aName! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 19:48:40' prior: 16886084! - messagePart: level repeat: repeat - - | start receiver selector args precedence words keywordStart | - - [receiver := parseNode. - (hereType == #keyword and: [level >= 3]) - ifTrue: - [start := self startOfNextToken. - selector := WriteStream on: (String new: 32). - args := OrderedCollection new. - words := OrderedCollection new. - [hereType == #keyword] - whileTrue: - [keywordStart := self startOfNextToken + requestorOffset. - selector nextPutAll: self advance. - words addLast: (keywordStart to: self endOfLastToken + requestorOffset). - self primaryExpression ifFalse: [^self expected: 'Argument']. - self messagePart: 2 repeat: true. - args addLast: parseNode]. - (Symbol hasInterned: selector contents ifTrue: [ :sym | selector := sym]) - ifFalse: [ selector := self correctSelector: selector contents - wordIntervals: words - exprInterval: (start to: self endOfLastToken) - ifAbort: [ ^ self fail ] ]. - precedence := 3] - ifFalse: [ - - (level >= 2 and: [hereType == #verticalBar or: [hereType == #upArrow]]) ifTrue: [self transformVerticalBarAndUpArrowIntoABinarySelector]. - ((hereType == #binary ) - and: [level >= 2]) - ifTrue: - [start := self startOfNextToken. - selector := self advance asSymbol. - self primaryExpression ifFalse: [^self expected: 'Argument']. - self messagePart: 1 repeat: true. - args := Array with: parseNode. - precedence := 2] - ifFalse: [hereType == #word - ifTrue: - [start := self startOfNextToken. - selector := self advance. - args := #(). - words := OrderedCollection with: (start + requestorOffset to: self endOfLastToken + requestorOffset). - (Symbol hasInterned: selector ifTrue: [ :sym | selector := sym]) - ifFalse: [ selector := self correctSelector: selector - wordIntervals: words - exprInterval: (start to: self endOfLastToken) - ifAbort: [ ^ self fail ] ]. - precedence := 1] - ifFalse: [^args notNil]]]. - - parseNode := MessageNode new - receiver: receiver - selector: selector - arguments: args - precedence: precedence - from: encoder - sourceRange: (start to: self endOfLastToken) - keywordsRanges: words. - repeat] - whileTrue: []. - ^true! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 19:58:35' prior: 16886206! - pattern: fromDoit inContext: ctxt - " unarySelector | binarySelector arg | keyword arg {keyword arg} => - {selector, arguments, precedence}." - - | args selector end start argumentName | - - doitFlag := fromDoit. - fromDoit ifTrue: - [^ctxt == nil - ifTrue: [{#DoIt. {}. 1. nil }] - ifFalse: [{#DoItIn:. {encoder encodeVariable: encoder doItInContextName}. 3. nil}]]. - - hereType == #word ifTrue: [ - start _ self startOfNextToken + requestorOffset. - selector _ self advance asSymbol. - end _ self endOfLastToken + requestorOffset. - ^ {selector. {}. 1. {start to: end}}]. - - (hereType == #verticalBar - or: [hereType == #upArrow]) - ifTrue: [self transformVerticalBarAndUpArrowIntoABinarySelector]. - - hereType == #binary ifTrue: [ - start _ self startOfNextToken + requestorOffset. - selector _ self advance asSymbol. - end _ self endOfLastToken + requestorOffset. - - start _ self startOfNextToken + requestorOffset. - argumentName _ self argumentName. - end _ self endOfLastToken + requestorOffset. - - args _ Array with: (encoder bindArg: argumentName range: (start to: end)). - ^ {selector. args. 2. {start to: end}}]. - - hereType == #keyword ifTrue: [ | ranges | - selector := WriteStream on: (String new: 32). - args := OrderedCollection new. - ranges := OrderedCollection new. - [hereType == #keyword] whileTrue:[ | keywordAsString | - start _ self startOfNextToken + requestorOffset. - keywordAsString _ self advance. - end _ self endOfLastToken + requestorOffset. - ranges add: (start to: end). - selector nextPutAll: keywordAsString. - - start _ self startOfNextToken + requestorOffset. - argumentName _ self argumentName. - end _ self endOfLastToken + requestorOffset. - - args addLast: (encoder bindArg: argumentName range: (start to: end)). - ]. - ^ {selector contents asSymbol. args. 3. ranges}]. - ^self expected: 'Message pattern' -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3407-ParserEnhancements-HernanWilkinson-2018Aug11-19h33m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3403] on 11 August 2018 at 8:12:52 pm'! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 20:12:10'! - argumentNameWithRangeDo: aBlock - - hereType == #word ifFalse: [^self expected: 'Argument name']. - - ^self advanceWithRangeDo: aBlock! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 20:07:48' prior: 16886157! - method: doit context: ctxt - " pattern [ | temporaries ] block => MethodNode." - - | sap blk prim temps messageComment methodNode | - sap := self pattern: doit inContext: ctxt. - "sap={selector, arguments, precedence}" - self properties selector: (sap at: 1). - encoder selector: (sap at: 1). - (sap at: 2) do: [:argNode | argNode beMethodArg]. - doit ifFalse: [self pragmaSequence]. - temps := self temporaries. - messageComment := currentComment. - currentComment := nil. - doit ifFalse: [self pragmaSequence]. - prim := self pragmaPrimitives. - self statements: #() innerBlock: doit. - blk := parseNode. - doit ifTrue: [blk returnLast] - ifFalse: [blk returnSelfIfNoOther: encoder]. - hereType == #doIt ifFalse: [^self expected: 'Nothing more']. - methodNode := self newMethodNode comment: messageComment. - methodNode - selector: (sap at: 1) - arguments: (sap at: 2) - precedence: (sap at: 3) - temporaries: temps - block: blk - encoder: encoder - primitive: prim - properties: properties - selectorKeywordsRanges: (sap at: 4). - self interactive ifTrue: - [self declareUndeclaredTemps: methodNode. - self removeUnusedTemps]. - ^methodNode! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 20:10:22' prior: 50409076! - pattern: fromDoit inContext: ctxt - " unarySelector | binarySelector arg | keyword arg {keyword arg} => - {selector, arguments, precedence}." - - | args selector end start argumentName | - - doitFlag := fromDoit. - fromDoit ifTrue: - [^ctxt == nil - ifTrue: [{#DoIt. {}. 1. nil }] - ifFalse: [{#DoItIn:. {encoder encodeVariable: encoder doItInContextName}. 3. nil}]]. - - hereType == #word - ifTrue: [^ self advanceWithRangeDo: [ :sel :range | {sel asSymbol. {}. 1. {range}} ]]. - - (hereType == #verticalBar or: [hereType == #upArrow]) - ifTrue: [self transformVerticalBarAndUpArrowIntoABinarySelector]. - - hereType == #binary ifTrue: [ | selectorRange | - self advanceWithRangeDo: [ :sel :range | - selector _ sel asSymbol. - selectorRange _ range ]. - - start _ self startOfNextToken + requestorOffset. - argumentName _ self argumentName. - end _ self endOfLastToken + requestorOffset. - - args _ Array with: (encoder bindArg: argumentName range: (start to: end)). - ^ {selector. args. 2. {selectorRange}}]. - - hereType == #keyword ifTrue: [ | ranges | - selector := WriteStream on: (String new: 32). - args := OrderedCollection new. - ranges := OrderedCollection new. - [hereType == #keyword] whileTrue:[ - self advanceWithRangeDo: [ :keywordAsString :range | - selector nextPutAll: keywordAsString. - ranges add: range ]. - - start _ self startOfNextToken + requestorOffset. - argumentName _ self argumentName. - end _ self endOfLastToken + requestorOffset. - - args addLast: (encoder bindArg: argumentName range: (start to: end)). - ]. - ^ {selector contents asSymbol. args. 3. ranges}]. - ^self expected: 'Message pattern' -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3408-ParserEnhancements-HernanWilkinson-2018Aug11-19h59m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3403] on 11 August 2018 at 8:32:22 pm'! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 20:30:00'! - addKeywordPatternPartTo: selector keywordRanges: keywordRanges arguments: arguments - - self advanceWithRangeDo: [ :keywordAsString :range | - selector nextPutAll: keywordAsString. - keywordRanges add: range ]. - - self argumentNameWithRangeDo: [ :argName :range | - arguments addLast: (encoder bindArg: argName range: range)] -! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 20:25:57'! - binaryPattern - - ^ self advanceWithRangeDo: [ :selectorAsString :selectorRange | | arguments | - self argumentNameWithRangeDo: [ :argumentName :argumentRange | - arguments _ Array with: (encoder bindArg: argumentName range: argumentRange). - {selectorAsString asSymbol. arguments. 2. {selectorRange}}]]! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 20:31:37'! - doitPatternInContext: context - - ^context - ifNil: [{#DoIt. {}. 1. nil }] - ifNotNil: [{#DoItIn:. {encoder encodeVariable: encoder doItInContextName}. 3. nil}]! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 20:29:32'! - keywordPattern - - | keywordRanges selector arguments | - - selector := WriteStream on: (String new: 32). - arguments := OrderedCollection new. - keywordRanges := OrderedCollection new. - - [hereType == #keyword] whileTrue:[ - self addKeywordPatternPartTo: selector keywordRanges: keywordRanges arguments: arguments ]. - - ^ {selector contents asSymbol. arguments. 3. keywordRanges} - ! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 20:23:06'! - unaryPattern - - ^ self advanceWithRangeDo: [ :sel :range | {sel asSymbol. {}. 1. {range}} ]! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 20:21:50' prior: 50409189! - pattern: fromDoit inContext: ctxt - " unarySelector | binarySelector arg | keyword arg {keyword arg} => - {selector, arguments, precedence}." - - | args selector | - - doitFlag := fromDoit. - fromDoit ifTrue: - [^ctxt == nil - ifTrue: [{#DoIt. {}. 1. nil }] - ifFalse: [{#DoItIn:. {encoder encodeVariable: encoder doItInContextName}. 3. nil}]]. - - hereType == #word - ifTrue: [^ self advanceWithRangeDo: [ :sel :range | {sel asSymbol. {}. 1. {range}} ]]. - - (hereType == #verticalBar or: [hereType == #upArrow]) - ifTrue: [self transformVerticalBarAndUpArrowIntoABinarySelector]. - - hereType == #binary ifTrue: [ | selectorRange | - self advanceWithRangeDo: [ :sel :range | - selector _ sel asSymbol. - selectorRange _ range ]. - - ^ self argumentNameWithRangeDo: [ :argName :range | - args _ Array with: (encoder bindArg: argName range: range). - {selector. args. 2. {selectorRange}}]]. - - hereType == #keyword ifTrue: [ | keywordRanges | - selector := WriteStream on: (String new: 32). - args := OrderedCollection new. - keywordRanges := OrderedCollection new. - [hereType == #keyword] whileTrue:[ - self advanceWithRangeDo: [ :keywordAsString :range | - selector nextPutAll: keywordAsString. - keywordRanges add: range ]. - - self argumentNameWithRangeDo: [ :argName :range | - args addLast: (encoder bindArg: argName range: range)]. - ]. - ^ {selector contents asSymbol. args. 3. keywordRanges}]. - ^self expected: 'Message pattern' -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3409-ParserEnhancements-HernanWilkinson-2018Aug11-20h12m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3403] on 11 August 2018 at 8:36:31 pm'! -!Parser methodsFor: 'scanning' stamp: 'HAW 8/11/2018 20:36:10'! - transformVerticalBarAndUpArrowIntoABinarySelectorIfNecessary - - (hereType == #verticalBar or: [hereType == #upArrow]) - ifTrue: [self transformVerticalBarAndUpArrowIntoABinarySelector].! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 20:33:48' prior: 50409304! - pattern: fromDoit inContext: ctxt - " unarySelector | binarySelector arg | keyword arg {keyword arg} => - {selector, arguments, precedence}." - - doitFlag := fromDoit. - fromDoit ifTrue: [^self doitPatternInContext: ctxt ]. - - hereType == #word ifTrue: [^self unaryPattern ]. - - (hereType == #verticalBar or: [hereType == #upArrow]) - ifTrue: [self transformVerticalBarAndUpArrowIntoABinarySelector]. - - hereType == #binary ifTrue: [^self binaryPattern ]. - - hereType == #keyword ifTrue: [^self keywordPattern ]. - - ^self expected: 'Message pattern' -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3410-ParserEnhancements-HernanWilkinson-2018Aug11-20h32m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3403] on 11 August 2018 at 8:37:35 pm'! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 20:37:20' prior: 50409368! - pattern: fromDoit inContext: ctxt - " unarySelector | binarySelector arg | keyword arg {keyword arg} => - {selector, arguments, precedence}." - - doitFlag := fromDoit. - - fromDoit ifTrue: [^self doitPatternInContext: ctxt ]. - hereType == #word ifTrue: [^self unaryPattern ]. - self transformVerticalBarAndUpArrowIntoABinarySelectorIfNecessary. - hereType == #binary ifTrue: [^self binaryPattern ]. - hereType == #keyword ifTrue: [^self keywordPattern ]. - - ^self expected: 'Message pattern' -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3411-ParserEnhancements-HernanWilkinson-2018Aug11-20h36m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3403] on 11 August 2018 at 11:11:26 pm'! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 23:04:38' prior: 50409002! - messagePart: level repeat: repeat - - | start receiver selector args precedence words keywordStart | - - [receiver := parseNode. - (hereType == #keyword and: [level >= 3]) - ifTrue: - [start := self startOfNextToken. - selector := WriteStream on: (String new: 32). - args := OrderedCollection new. - words := OrderedCollection new. - [hereType == #keyword] - whileTrue: - [keywordStart := self startOfNextToken + requestorOffset. - selector nextPutAll: self advance. - words addLast: (keywordStart to: self endOfLastToken + requestorOffset). - self primaryExpression ifFalse: [^self expected: 'Argument']. - self messagePart: 2 repeat: true. - args addLast: parseNode]. - (Symbol hasInterned: selector contents ifTrue: [ :sym | selector := sym]) - ifFalse: [ selector := self correctSelector: selector contents - wordIntervals: words - exprInterval: (start to: self endOfLastToken) - ifAbort: [ ^ self fail ] ]. - precedence := 3] - ifFalse: [ - - (level >= 2 and: [hereType == #verticalBar or: [hereType == #upArrow]]) ifTrue: [self transformVerticalBarAndUpArrowIntoABinarySelector]. - ((hereType == #binary ) - and: [level >= 2]) - ifTrue: - [start := self startOfNextToken. - selector := self advance asSymbol. - words := OrderedCollection with: (start + requestorOffset to: self endOfLastToken + requestorOffset). - self primaryExpression ifFalse: [^self expected: 'Argument']. - self messagePart: 1 repeat: true. - args := Array with: parseNode. - precedence := 2] - ifFalse: [hereType == #word - ifTrue: - [start := self startOfNextToken. - selector := self advance. - args := #(). - words := OrderedCollection with: (start + requestorOffset to: self endOfLastToken + requestorOffset). - (Symbol hasInterned: selector ifTrue: [ :sym | selector := sym]) - ifFalse: [ selector := self correctSelector: selector - wordIntervals: words - exprInterval: (start to: self endOfLastToken) - ifAbort: [ ^ self fail ] ]. - precedence := 1] - ifFalse: [^args notNil]]]. - - parseNode := MessageNode new - receiver: receiver - selector: selector - arguments: args - precedence: precedence - from: encoder - sourceRange: (start to: self endOfLastToken) - keywordsRanges: words. - repeat] - whileTrue: []. - ^true! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3412-ParserEnhancements-HernanWilkinson-2018Aug11-20h58m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3403] on 11 August 2018 at 11:32:56 pm'! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 23:20:34' prior: 16886240! - primaryExpression - hereType == #word - ifTrue: [ - parseNode _ self variable. - - " - (parseNode isUndefTemp and: [self interactive] and: [ - ((requestor isKindOf: Editor) or: [ requestor is: #Morph ])]) - " - "If the requestor is of an exotic kind (like a telnet server) we might not be - allowed to open a PupUpMenu for querying the user" - - (parseNode isUndefTemp and: [ self interactive ]) - ifTrue: [self queryUndefined]. - parseNode nowHasRef. - ^ true]. - hereType == #leftBracket - ifTrue: [ - self advance. - self blockExpression. - ^true]. - hereType == #leftBrace - ifTrue: [ - self braceExpression. - ^true]. - hereType == #leftParenthesis - ifTrue: [ - self advance. - self expression ifFalse: [^self expected: 'expression']. - (self match: #rightParenthesis) - ifFalse: [^self expected: 'right parenthesis']. - ^true]. - (hereType == #string or: [hereType == #number or: [hereType == #literal]]) - ifTrue: [ - parseNode := self advanceWithRangeDo: [ :lexema :range | encoder encodeLiteral: lexema range: range ]. - ^true]. - (here == #- and: [tokenType == #number]) - ifTrue: [ - self advanceWithRangeDo: [ :minusChar :minusRange | - self advanceWithRangeDo: [ :number :numberRange | - parseNode := encoder encodeLiteral: number negated range: (minusRange first to: numberRange last)]]. - ^true]. - ^false! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 23:23:08' prior: 16886333! - temporaries - " [ '|' (variable)* '|' ]" - | vars theActualText | - (self match: #verticalBar) ifFalse: - ["no temps" - doitFlag ifTrue: - [tempsMark := self interactive - ifTrue: [requestor selectionInterval first] - ifFalse: [1]. - ^ #()]. - tempsMark := hereMark "formerly --> prevMark + prevToken". - tempsMark > 0 ifTrue: - [theActualText := source contents. - [tempsMark < theActualText size and: [(theActualText at: tempsMark) isSeparator]] - whileTrue: [tempsMark := tempsMark + 1]]. - ^ #()]. - vars := OrderedCollection new. - [hereType == #word] - whileTrue: [ - self advanceWithRangeDo: [ :variableName :range | - vars addLast: (encoder bindTemp: variableName range: range)]]. - (self match: #verticalBar) ifTrue: - [tempsMark := prevMark. - ^ vars]. - ^ self expected: 'Vertical bar' -! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/11/2018 23:30:36' prior: 16886405! - variable - - ^self advanceWithRangeDo: [ :variableName :range | | varName result | - varName := variableName. - [result _ encoder encodeVariable: varName sourceRange: range ifUnknown: [ nil ]. - result ifNil: [ - result _ (UndeclaredVariableReference new) - parser: self; - varName: varName; - varStart: range first; - varEnd: range last; - signal ]. - result isString ] whileTrue: [ varName _ result]. - encoder addMultiRange: range for: result ]. - ! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3413-ParserEnhancements-HernanWilkinson-2018Aug11-23h11m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3411] on 13 August 2018 at 11:36:37 am'! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 8/13/2018 11:35:34'! -rangesForLiteralNode: aName ifAbsent: aBlock - - | variableNode | - - variableNode := litSet at: aName ifAbsent: [ ^aBlock value ]. - - ^sourceRanges at: variableNode ifAbsent: aBlock! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 8/13/2018 11:35:41'! - rangesForLiteralVariableNode: aName ifAbsent: aBlock - - | variableNode | - - variableNode := litIndSet values detect: [ :aLiteralVariableNode | aLiteralVariableNode name = aName ] ifNone: [ ^aBlock value ]. - - ^sourceRanges at: variableNode ifAbsent: aBlock! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3414-ParserEnhancements-2-HernanWilkinson-2018Aug13-11h28m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3411] on 13 August 2018 at 7:15:52 pm'! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/13/2018 19:15:42'! - performInteractiveChecks: aMethodNode - - self - declareUndeclaredTemps: aMethodNode; - removeUnusedTemps! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3415-ParserEnhancements-2-HernanWilkinson-2018Aug13-19h15m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3411] on 13 August 2018 at 7:16:22 pm'! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/13/2018 19:16:08' prior: 50409151! - method: doit context: ctxt - " pattern [ | temporaries ] block => MethodNode." - - | sap blk prim temps messageComment methodNode | - - sap := self pattern: doit inContext: ctxt. - "sap={selector, arguments, precedence}" - self properties selector: (sap at: 1). - encoder selector: (sap at: 1). - (sap at: 2) do: [:argNode | argNode beMethodArg]. - doit ifFalse: [self pragmaSequence]. - temps := self temporaries. - messageComment := currentComment. - currentComment := nil. - doit ifFalse: [self pragmaSequence]. - prim := self pragmaPrimitives. - self statements: #() innerBlock: doit. - blk := parseNode. - doit ifTrue: [blk returnLast] - ifFalse: [blk returnSelfIfNoOther: encoder]. - hereType == #doIt ifFalse: [^self expected: 'Nothing more']. - methodNode := self newMethodNode comment: messageComment. - methodNode - selector: (sap at: 1) - arguments: (sap at: 2) - precedence: (sap at: 3) - temporaries: temps - block: blk - encoder: encoder - primitive: prim - properties: properties - selectorKeywordsRanges: (sap at: 4). - - self interactive ifTrue: [ self performInteractiveChecks: methodNode ]. - - ^methodNode! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3416-ParserEnhancements-2-HernanWilkinson-2018Aug13-19h15m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3411] on 13 August 2018 at 7:45:27 pm'! -!Encoder methodsFor: 'temps' stamp: 'HAW 8/13/2018 19:44:54'! - bindBlockArg: name within: aBlockNode range: range - - ^self addMultiRange: range for: (self bindBlockArg: name within: aBlockNode) - -! ! -!Encoder methodsFor: 'temps' stamp: 'HAW 8/13/2018 19:45:13'! - bindBlockTemp: name within: aBlockNode range: range - - ^self addMultiRange: range for: (self bindBlockTemp: name within: aBlockNode) - -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3417-ParserEnhancements-3-HernanWilkinson-2018Aug13-19h16m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3411] on 13 August 2018 at 7:48:17 pm'! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/13/2018 19:47:02' prior: 16885972! - blockExpression - "[ ({:var} |) (| {temps} |) (statements) ] => BlockNode." - - | blockNode variableNodes temporaryBlockVariables start | - blockNode := BlockNode new. - variableNodes := OrderedCollection new. - start := prevMark + requestorOffset. - "Gather parameters." - [self match: #colon] whileTrue: - [self argumentNameWithRangeDo: [ :argumentName :range | - variableNodes addLast: (encoder bindBlockArg: argumentName within: blockNode range: range)]]. - (variableNodes size > 0 & (hereType ~~ #rightBracket) and: [(self match: #verticalBar) not]) ifTrue: - [^self expected: 'Vertical bar']. - - temporaryBlockVariables := self temporaryBlockVariablesFor: blockNode. - self statements: variableNodes innerBlock: true blockNode: blockNode. - blockNode temporaries: temporaryBlockVariables. - - (self match: #rightBracket) ifFalse: [^self expected: 'Period or right bracket']. - - blockNode noteSourceRangeStart: start end: self endOfLastToken encoder: encoder. - - "The scope of the parameters and temporary block variables is no longer active." - temporaryBlockVariables do: [:variable | variable scope: -1]. - variableNodes do: [:variable | variable scope: -1]! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 8/13/2018 19:47:49' prior: 16886386! - temporaryBlockVariablesFor: aBlockNode - "Scan and answer temporary block variables." - - | variables | - (self match: #verticalBar) ifFalse: - "There are't any temporary variables." - [aBlockNode tempsMark: prevMark + requestorOffset. - ^#()]. - - variables := OrderedCollection new. - [hereType == #word] whileTrue: - [self advanceWithRangeDo: [ :lexema :range | - variables addLast: (encoder bindBlockTemp: lexema within: aBlockNode range: range)]]. - (self match: #verticalBar) ifFalse: - [^self expected: 'Vertical bar']. - aBlockNode tempsMark: prevMark + requestorOffset. - ^variables! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3418-ParserEnhancements-3-HernanWilkinson-2018Aug13-19h45m-HAW.1.cs.st----! - -----SNAPSHOT----#(15 August 2018 3:59:36.247523 pm) Cuis5.0-3418-v3.image priorSource: 2454628! - -----QUIT----#(15 August 2018 4:00:00.623775 pm) Cuis5.0-3418-v3.image priorSource: 2500024! - -----STARTUP----#(25 August 2018 11:26:45.959061 am) as /home/juan/Rectifier/Cuis-Smalltalk-Dev/Cuis5.0-3418-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3418] on 15 August 2018 at 7:54:00 pm'! - -Object subclass: #Scanner - instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable isForTokenization sentInLiterals ignoreBacktick ' - classVariableNames: 'TypeTable ' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #Scanner category: #'Compiler-Kernel'! -Object subclass: #Scanner - instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable isForTokenization sentInLiterals ignoreBacktick' - classVariableNames: 'TypeTable' - poolDictionaries: '' - category: 'Compiler-Kernel'! -!Scanner methodsFor: 'expression types - private' stamp: 'HAW 8/15/2018 19:53:14'! - isBacktickAndShouldIgnoreIt - - "I compare with true because there are many ways to initialize the scanner and ingoreBacktick could be nil - Hernan" - ^ ignoreBacktick == true and: [tokenType = #xBacktick]! ! -!Scanner methodsFor: 'expression types - private' stamp: 'HAW 8/15/2018 19:53:27'! - skipDelimiters - - [(tokenType := self typeTableAt: hereChar) == #xDelimiter] whileTrue: [self step]. -! ! -!Scanner methodsFor: 'expression types - private' stamp: 'HAW 8/15/2018 19:53:35'! - skipDelimitersAndBacktickIfNecessary - - [self skipDelimiters. - self isBacktickAndShouldIgnoreIt ] whileTrue: [self step]. ! ! -!Scanner methodsFor: 'initialization' stamp: 'HAW 8/15/2018 19:51:51' prior: 50382605! - initScanner - - buffer := WriteStream on: (String new: 40). - typeTable := Scanner typeTable. - isForTokenization := false. - sentInLiterals := Set new. - ignoreBacktick := true! ! -!Scanner methodsFor: 'initialization' stamp: 'HAW 8/15/2018 19:52:00' prior: 16904201! - initScannerForTokenization - "Don't raise xIllegal when enocuntering an _" - "Simpler implementation for Cuis" - isForTokenization _ true. - ignoreBacktick _ true.! ! - -Object subclass: #Scanner - instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable isForTokenization sentInLiterals ignoreBacktick' - classVariableNames: 'TypeTable' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #Scanner category: #'Compiler-Kernel'! -Object subclass: #Scanner - instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable isForTokenization sentInLiterals ignoreBacktick' - classVariableNames: 'TypeTable' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3419-BacktickEvaluationOnlyWhenCompiling-HernanWilkinson-2018Aug15-19h51m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3418] on 15 August 2018 at 7:55:52 pm'! -!Scanner methodsFor: 'initialization' stamp: 'HAW 8/15/2018 19:55:10'! - ignoreBacktick: aBoolean - - ignoreBacktick := aBoolean ! ! -!Scanner methodsFor: 'expression types' stamp: 'HAW 8/15/2018 19:55:41' prior: 16903829! - scanToken - - "Skip delimiters fast, there almost always is one." - self skipDelimitersAndBacktickIfNecessary. - - mark := source position - 1. - (tokenType at: 1) = $x "x as first letter" - ifTrue: [self perform: tokenType "means perform to compute token & type"] - ifFalse: [token := self step asSymbol "else just unique the first char"]. - ^token! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3420-BacktickEvaluationOnlyWhenCompiling-HernanWilkinson-2018Aug15-19h54m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3418] on 15 August 2018 at 7:57:57 pm'! -!Compiler methodsFor: 'private' stamp: 'HAW 8/15/2018 19:56:18' prior: 16822062! - translate: aStream noPattern: noPattern ifFail: failBlock - ^self parser - sourceStreamGetter: sourceStreamGetter; "Cuis specific. Do not remove!!" - ignoreBacktick: false; - parse: aStream - class: class - category: category - noPattern: noPattern - context: context - notifying: requestor - ifFail: [^failBlock value]! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3421-BacktickEvaluationOnlyWhenCompiling-HernanWilkinson-2018Aug15-19h55m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3418] on 16 August 2018 at 6:44:54 am'! -!Scanner methodsFor: 'xBacktick processing - private' stamp: 'HAW 8/16/2018 06:37:45'! - compileBacktickCode - - | compiler method methodNode | - - compiler _ Compiler new. - methodNode _ compiler compileNoPattern: buffer contents in: UndefinedObject context: nil notifying: nil ifFail: []. - method _ methodNode generate. - - "Grab all messages sent while evaluating literal, so the main method will be shown as senders of them" - sentInLiterals addAll: method messages. - method literalsDo: [ :literal | literal isSymbol ifTrue: [ literal = #DoIt ifFalse: [sentInLiterals add: literal ]]]. - - "Evaluate now." - token _ nil withArgs: #() executeMethod: method ! ! -!Scanner methodsFor: 'xBacktick processing - private' stamp: 'HAW 8/16/2018 06:37:02'! - compileBacktickCodeHandlingErrors - - [[[self compileBacktickCode ] - on: SyntaxErrorNotification - do: [ :ex | self notify: 'Can not compile: ', ex errorMessage at: mark]] - on: UndeclaredVariableReference - do: [ :ex | self notify: 'Can not compile: Variable ''', ex varName, ''' is not declared' at: mark ]] - on: Error - do: [ :ex | self notify: 'Can not evaluate code: ', ex description at: mark ]. - - tokenType _ #literal! ! -!Scanner methodsFor: 'xBacktick processing - private' stamp: 'HAW 8/16/2018 06:28:34'! - isAtBacktick - - ^ hereChar == $` and: [aheadChar == $` ifTrue: [self step. false] ifFalse: [true]]! ! -!Scanner methodsFor: 'xBacktick processing - private' stamp: 'HAW 8/16/2018 06:28:54'! - readUpToNextBacktick - - self step. - buffer reset. - - [self isAtBacktick] - whileFalse: [ - buffer nextPut: self step. - (hereChar = Scanner doItCharacterValue asCharacter and: [source atEnd]) ifTrue: [^false]]. - self step. - - ^true! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'HAW 8/16/2018 06:38:36' prior: 50408469! - xBacktick - - "Smalltalk code evaluated at compile time as a literal." - - self readUpToNextBacktick ifFalse: [^self offEnd: 'Unmatched back quote']. - self compileBacktickCodeHandlingErrors.! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3422-ScannerCleanup-HernanWilkinson-2018Aug15-19h57m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3418] on 16 August 2018 at 6:49:39 am'! -!Scanner methodsFor: 'multi-character scans' stamp: 'HAW 8/16/2018 06:49:14'! - doItCharacter - - ^self class doItCharacterValue asCharacter! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3423-ScannerCleanup-HernanWilkinson-2018Aug16-06h44m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3418] on 16 August 2018 at 6:56:22 am'! -!Scanner methodsFor: 'expression types' stamp: 'HAW 8/16/2018 06:52:54' prior: 16903686! -scanAllTokenPositionsInto: aBlock - "Evaluate aBlock with the start and end positions of all separate non-white-space tokens, including comments." - - | lastMark | - lastMark := 1. - [currentComment ifNotNil: - [currentComment do: - [:cmnt| | idx | - idx := source originalContents indexOfSubCollection: cmnt startingAt: lastMark. - (idx > 0 and: [idx < mark]) ifTrue: - [aBlock value: idx - 1 value: (lastMark := idx + cmnt size)]]. - currentComment := nil]. - mark ifNotNil: - [(token == #- - and: [(self typeTableAt: hereChar) == #xDigit]) ifTrue: - [| savedMark | - savedMark := mark. - self scanToken. - token := token negated. - mark := savedMark]. - "Compensate for the fact that the parser uses two character lookahead. Normally we must - remove the extra two characters. But this mustn't happen for the last token at the end of stream." - aBlock - value: mark - value: (source position - (aheadChar = self class doItCharacterValue ifTrue: [hereChar = self doItCharacter ifTrue: [0] ifFalse: [1]] ifFalse: [2]))]. - (tokenType == #rightParenthesis - or: [tokenType == #doIt]) ifTrue: - [^self]. - tokenType == #leftParenthesis - ifTrue: - [self scanToken; scanAllTokenPositionsInto: aBlock] - ifFalse: - [(tokenType == #word or: [tokenType == #keyword or: [tokenType == #colon]]) - ifTrue: - [self scanLitWord. - token == #true ifTrue: [token := true]. - token == #false ifTrue: [token := false]. - token == #nil ifTrue: [token := nil]] - ifFalse: - [(token == #- - and: [(self typeTableAt: hereChar) == #xDigit]) - ifTrue: - [self scanToken. - token := token negated]]]. - self scanToken ] repeat! ! -!Scanner methodsFor: 'expression types' stamp: 'HAW 8/16/2018 06:50:46' prior: 16903844! - step - - | c | - c := hereChar. - hereChar := aheadChar. - source atEnd - ifTrue: [aheadChar := self doItCharacter "doit"] - ifFalse: [aheadChar := source next]. - ^c! ! -!Scanner methodsFor: 'xBacktick processing - private' stamp: 'HAW 8/16/2018 06:50:12' prior: 50409966! - readUpToNextBacktick - - self step. - buffer reset. - - [self isAtBacktick] - whileFalse: [ - buffer nextPut: self step. - (hereChar = self doItCharacter and: [source atEnd]) ifTrue: [^false]]. - self step. - - ^true! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'HAW 8/16/2018 06:51:11' prior: 16904051! - xDigit - "Form a number." - - tokenType := #number. - (aheadChar = self doItCharacter and: [source atEnd - and: [source skip: -1. source next ~= self doItCharacter]]) - ifTrue: [source skip: -1 "Read off the end last time"] - ifFalse: [source skip: -2]. - token := [Number readFrom: source] ifError: [:err :rcvr | self offEnd: err]. - self step; step! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'HAW 8/16/2018 06:51:33' prior: 16904073! - xDoubleQuote - "Collect a comment." - "wod 1/10/98: Allow 'empty' comments by testing the first character -for $"" rather than blindly adding it to the comment being collected." - | aStream stopChar | - stopChar := self doItCharacter. - aStream := WriteStream on: (String new: 200). - self step. - [hereChar == $"] - whileFalse: - [(hereChar == stopChar and: [source atEnd]) - ifTrue: [^self offEnd: 'Unmatched comment quote']. - aStream nextPut: self step.]. - self step. - currentComment == nil - ifTrue: [currentComment := OrderedCollection with: aStream contents] - ifFalse: [currentComment add: aStream contents]. - self scanToken! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'HAW 8/16/2018 06:51:48' prior: 16904108! - xLetter - "Form a word or keyword." - - | type | - buffer reset. - [(type := self typeTableAt: hereChar) == #xLetter - or: [type == #xDigit - or: [type == #xUnderscore]]] whileTrue: - ["open code step for speed" - buffer nextPut: hereChar. - hereChar := aheadChar. - aheadChar := source atEnd - ifTrue: [self doItCharacter "doit"] - ifFalse: [source next]]. - tokenType := (type == #colon or: [type == #xColon and: [aheadChar ~~ $=]]) - ifTrue: - [buffer nextPut: self step. - "Allow any number of embedded colons in literal symbols" - [(self typeTableAt: hereChar) == #xColon] whileTrue: - [buffer nextPut: self step]. - #keyword] - ifFalse: - [#word]. - token := buffer contents! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'HAW 8/16/2018 06:52:09' prior: 16904168! - xSingleQuote - "String." - - self step. - buffer reset. - [hereChar == $' - and: [aheadChar == $' - ifTrue: [self step. false] - ifFalse: [true]]] - whileFalse: - [buffer nextPut: self step. - (hereChar = self doItCharacter and: [source atEnd]) - ifTrue: [^self offEnd: 'Unmatched string quote']]. - self step. - token := buffer contents. - tokenType := #string! ! -!Scanner class methodsFor: 'cached class state' stamp: 'HAW 8/16/2018 06:52:18' prior: 50382992! - initTypeTable - | newTable | - newTable := Array new: 256 withAll: #xIllegal. "default" - newTable atAll: #(9 10 12 13 32 ) put: #xDelimiter. "tab lf ff cr space" - - 1 to: 255 - do: [:index | - (Character numericValue: index) isValidInIdentifiers - ifTrue: [ - "Digits and $_ are overwritten later" - newTable at: index put: #xLetter ]]. - - newTable atAll: ($0 numericValue to: $9 numericValue) put: #xDigit. - newTable atAll: '!!%&+-*/\±×÷¬­¯,<=>”•–—˜™š›œ«»?@~€‚ƒŽ‘’“žŸ°·' asByteArray put: #xBinary. - - newTable at: self doItCharacterValue put: #doIt. - newTable at: $" numericValue put: #xDoubleQuote. - newTable at: $# numericValue put: #xLitQuote. - newTable at: $$ numericValue put: #xDollar. - newTable at: $' numericValue put: #xSingleQuote. - newTable at: $` numericValue put: #xBacktick. - newTable at: $: numericValue put: #xColon. - newTable at: $( numericValue put: #leftParenthesis. - newTable at: $) numericValue put: #rightParenthesis. - newTable at: $. numericValue put: #period. - newTable at: $; numericValue put: #semicolon. - newTable at: $[ numericValue put: #leftBracket. - newTable at: $] numericValue put: #rightBracket. - newTable at: ${ numericValue put: #leftBrace. - newTable at: $} numericValue put: #rightBrace. - newTable at: $^ numericValue put: #upArrow. - newTable at: $_ numericValue put: #xUnderscore. - newTable at: $| numericValue put: #verticalBar. - TypeTable := newTable "bon voyage!!" - - " - Scanner initTypeTable - "! ! -!Parser methodsFor: 'scanning' stamp: 'HAW 8/16/2018 06:49:54' prior: 16885743! - advance - | this | - prevMark := hereMark. - prevEnd := hereEnd. - this := here. - here := token. - hereType := tokenType. - hereMark := mark. - hereEnd := source position - (source atEnd ifTrue: [hereChar = self doItCharacter ifTrue: [0] ifFalse: [1]] ifFalse: [2]). - self scanToken. - "Transcript show: 'here: ', here printString, ' mark: ', hereMark printString, ' end: ', hereEnd printString; cr." - ^this! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3424-ScannerCleanup-HernanWilkinson-2018Aug16-06h49m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3418] on 16 August 2018 at 7:01:54 am'! -!Scanner methodsFor: 'multi-character scans' stamp: 'HAW 8/16/2018 07:00:43'! - isAt: aChar - - ^ hereChar == aChar and: [aheadChar == aChar ifTrue: [self step. false] ifFalse: [true]]! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'HAW 8/16/2018 07:01:00'! - readUpToNext: aChar ifNotFound: aNotFoundBlock - - self step. - buffer reset. - - [self isAt: aChar] - whileFalse: - [buffer nextPut: self step. - (hereChar = self doItCharacter and: [source atEnd]) ifTrue: [^aNotFoundBlock value ]]. - - self step. - token := buffer contents. - ! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3425-ScannerCleanup-HernanWilkinson-2018Aug16-06h56m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3418] on 16 August 2018 at 7:05:45 am'! -!Scanner methodsFor: 'multi-character scans' stamp: 'HAW 8/16/2018 07:04:23' prior: 50409977! - xBacktick - - "Smalltalk code evaluated at compile time as a literal." - - self readUpToNext: $` ifNotFound: [^self offEnd: 'Unmatched back quote']. - self compileBacktickCodeHandlingErrors.! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'HAW 8/16/2018 07:03:12' prior: 50410146! - xSingleQuote - - "String." - - self readUpToNext: $' ifNotFound: [^self offEnd: 'Unmatched string quote']. - tokenType := #string! ! - -Scanner removeSelector: #isAtBacktick! - -Scanner removeSelector: #isAtBacktick! - -Scanner removeSelector: #readUpToNextBacktick! - -Scanner removeSelector: #readUpToNextBacktick! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3426-ScannerCleanup-HernanWilkinson-2018Aug16-07h01m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3426] on 19 August 2018 at 6:11:23 pm'! -!WorldState methodsFor: 'accessing' stamp: 'jmv 8/19/2018 18:11:12' prior: 50340367! - runLocalStepMethods: nowTime - "Run morph 'step' methods (LOCAL TO THIS WORLD) whose time has come. Purge any morphs that are no longer in this world." - - | stepMessage | - [ stepList notEmpty and: [ stepList first scheduledTime <= nowTime ]] - whileTrue: [ - stepMessage _ stepList first. - (stepMessage receiver shouldGetStepsFrom: world) - ifFalse: [ stepList removeFirst ] - ifTrue: [ - stepMessage valueAtTime: nowTime. - stepMessage rescheduleAfter: nowTime. - "We've just updated the scheduled time for stepMessage. - It might have been that stepMessage was removed altogether from stepList. - It also may be the case that stepList got added or removed other elements while on #valueAtTime: - Just reSort. It will be ok in any case." - stepList reSort. - ] - ]! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3427-MorphicStepFix-JuanVuletich-2018Aug19-18h11m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3418] on 21 August 2018 at 4:01:58 pm'! -!ProtocolBrowser methodsFor: 'initialization' stamp: 'jmv 8/21/2018 16:01:20' prior: 50374662! - initialize - super initialize. - exclude _ OrderedCollection new! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3428-ProtocolBrowser-fix-JuanVuletich-2018Aug21-16h01m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3402] on 18 August 2018 at 2:44:44 pm'! -!Behavior methodsFor: 'private' stamp: 'pb 8/18/2018 14:12:12' prior: 16784915! - handleFailingFailingBasicNew: sizeRequested - "This basicNew: gets sent after handleFailingBasicNew: has done a full - garbage collection and possibly grown memory. If this basicNew: fails - then the system really is low on space, so raise the OutOfMemory signal. - - Primitive. Answer an instance of this class with the number of indexable - variables specified by the argument, sizeRequested. Fail if this class is not - indexable or if the argument is not a positive Integer, or if there is not - enough memory available. Essential. See Object documentation whatIsAPrimitive." - "space must be low." - - (sizeRequested isInteger and: [ sizeRequested > 0 ]) - ifTrue: [ OutOfMemory signal ] - ifFalse: [ self error: 'sizeRequested must be a positive integer' ]. - ^ self basicNew: sizeRequested"retry if user proceeds".! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3429-not-always-OOM-PhilBellalouna-2018Aug18-14h12m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3429] on 23 August 2018 at 4:37:09 pm'! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 8/23/2018 09:45:40'! - smoothStep - "A Function that is - x <= -1 -> 1 - -1 < x < 1 -> smooth differentiable transition from 1 to 0 - 1 <= x -> 0 - - It is a 'smooth' version of an #negative - Has countless applications. For example in image and signal processing, but also in other fields." - " - | g | - Feature require: 'Morphic-Widgets-Extras'. - g _ FunctionGraphMorph new. - g domain: (-4 to: 4). - g addFunction: [ :x | x abs < 1 ifTrue: [1] ifFalse:[0] ] color: Color brown. - g addFunction: [ :x | x smoothStep ] color: Color red. - (g embeddedInMorphicWindowLabeled: 'graph') openInWorld - " - self > -1 ifFalse: [ ^ 1 ]. - 1 > self ifFalse: [ ^ 0 ]. - ^ (self +2 * Float halfPi) sin * 0.5 + 0.5! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 8/23/2018 09:30:56' prior: 16845643! - reciprocal - ^ 1.0 / self! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 8/23/2018 09:32:01' prior: 50405241! - smoothIsAbsBelow: threshold - "A Function that is 1 at zero, 0 outside a bounded interval of size 4*threshold, and is continuous and differentiable. - - It is a 'smooth' version of an #isAbsBelow: function: x abs < threshold. - Useful when we need to 'count' stuff, but still want continuous and differentiable stuff." - " - | g | - Feature require: 'Morphic-Widgets-Extras'. - g _ FunctionGraphMorph new. - g domain: (-4 to: 4). - g addFunction: [ :x | x abs < Float halfPi ifTrue: [1] ifFalse:[0] ] color: Color brown. - g addFunction: [ :x | x smoothIsAbsBelow: Float halfPi ] color: Color red. - (g embeddedInMorphicWindowLabeled: 'graph') openInWorld - " - | scaled | - scaled _ self / threshold. - ^ scaled abs < 2 ifTrue: [ (scaled * Float halfPi) cos + 1.0 * 0.5 ] ifFalse: [ 0 ]! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3430-FloatTweaks-JuanVuletich-2018Aug23-16h36m-jmv.1.cs.st----! - -----SNAPSHOT----#(25 August 2018 11:26:53.680982 am) Cuis5.0-3430-v3.image priorSource: 2500121! - -----QUIT----#(25 August 2018 11:27:16.731318 am) Cuis5.0-3430-v3.image priorSource: 2520942! - -----STARTUP----#(8 October 2018 11:01:45.563759 am) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3430-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3430] on 2 September 2018 at 11:47:54 pm'! - -Object subclass: #CharacterScanner - instanceVariableNames: 'destX lastIndex xTable map destY stopConditions text alignment leftMargin rightMargin font line runStopIndex spaceCount spaceWidth kern paragraphStyle tabWidth defaultFont lastTabIndex lastTabX ' - classVariableNames: 'DefaultStopConditions StopConditionsWithPaddedSpace StopConditionsWithSpace ' - poolDictionaries: '' - category: 'Graphics-Text'! - -!classDefinition: #CharacterScanner category: #'Graphics-Text'! -Object subclass: #CharacterScanner - instanceVariableNames: 'destX lastIndex xTable map destY stopConditions text alignment leftMargin rightMargin font line runStopIndex spaceCount spaceWidth kern paragraphStyle tabWidth defaultFont lastTabIndex lastTabX' - classVariableNames: 'DefaultStopConditions StopConditionsWithPaddedSpace StopConditionsWithSpace' - poolDictionaries: '' - category: 'Graphics-Text'! -!CharacterScanner methodsFor: 'private' stamp: 'jmv 9/2/2018 23:46:54' prior: 50370313! - setFont - | attributes | - "Set the font and other emphasis. - In fact set actual ParagraphStyle (or nil), alignment, font and emphasis" - - self setActualFont: (text fontAt: lastIndex default: defaultFont). - attributes _ text attributesAt: lastIndex. - text - withAttributeValues: attributes - do: [ :familyNameInText :pointSizeInText :emphasisInText :colorInText :alignmentInText :characterStyleInText :paragraphStyleInText :backgroundColorInText | - colorInText ifNotNil: [ self textColor: colorInText ]. - self backgroundColor: backgroundColorInText. - alignment _ alignmentInText. - paragraphStyle _ paragraphStyleInText ]. - - "Hardcoded color for TextAction" - attributes do: [ :attribute | - attribute forTextActionInfoDo: [ :info | - self textColor: TextAction textActionColor ]]. - - "Install various parameters from the font." - spaceWidth _ font widthOf: Character space. - tabWidth _ font pointSize * 5 // 2. - xTable _ font xTable! ! -!CharacterScanner methodsFor: 'stop conditions' stamp: 'jmv 9/2/2018 23:46:57' prior: 16802073! - tabDestX - "This is the basic method of adjusting destX for a tab." - - ^paragraphStyle - ifNotNil: [ - paragraphStyle - nextTabXFrom: destX - leftMargin: leftMargin - rightMargin: rightMargin ] - ifNil: [ - "Add the width of a tab for every two chars since last tab, to last tab x position." - (lastIndex - lastTabIndex // 3 + 1) * tabWidth + lastTabX min: rightMargin ]! ! -!CharacterScanner methodsFor: 'initialization' stamp: 'jmv 9/1/2018 20:32:04' prior: 16802089! - initialize - lastTabIndex _ lastTabX _ destX _ destY _ leftMargin _ rightMargin _ 0.! ! -!CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'jmv 9/2/2018 23:40:08' prior: 16801835! - tab - | currentX | - currentX _ self tabDestX. - lastSpaceOrTabWidth _ currentX - destX max: 0. - currentX >= characterPoint x - ifTrue: [ - lastCharacterWidth _ lastSpaceOrTabWidth. - ^ self crossedX ]. - destX _ currentX. - lastIndex _ lastIndex + 1. - lastTabX _ destX. - lastTabIndex _ lastIndex. - ^false! ! -!CharacterBlockScanner methodsFor: 'scanning' stamp: 'jmv 9/2/2018 23:30:31' prior: 16801846! - characterBlockAtPoint: aPoint index: index in: textLine - "This method is the Morphic characterBlock finder." - | runLength lineStop stopCondition | - line _ textLine. - rightMargin _ line rightMargin. - lastTabIndex _ lastIndex _ line first. - self setFont. - self setStopConditions. - characterIndex _ index. "nil means scanning for point" - characterPoint _ aPoint. - (characterPoint isNil or: [ characterPoint y > line bottom ]) - ifTrue: [ characterPoint _ line bottomRight ]. - (text isEmpty or: [( characterPoint y < line top or: [ characterPoint x < line left ]) - or: [ characterIndex notNil and: [ characterIndex < line first ]]]) - ifTrue: [^ CharacterBlock - stringIndex: line first - text: text - topLeft: line leftMargin@line top - extent: 0 @ line lineHeight - textLine: line]. - lastTabX _ destX _ leftMargin _ line leftMarginForAlignment: alignment. - destY _ line top. - runLength _ text runLengthFor: line first. - lineStop _ characterIndex "scanning for index" - ifNil: [ line last ]. "scanning for point" - runStopIndex _ lastIndex + (runLength - 1) min: lineStop. - lastCharacterWidth _ 0. - spaceCount _ 0. - - self placeEmbeddedObject. - [ - stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex - in: text string rightX: characterPoint x - stopConditions: stopConditions kern: font baseKern. - "see setStopConditions for stopping conditions for character block operations." - lastCharacterWidth _ specialWidth ifNil: [ font widthOf: (text at: lastIndex) ]. - (self perform: stopCondition) ifTrue: [ - ^characterIndex - ifNil: [ "Result for characterBlockAtPoint: " - CharacterBlock - stringIndex: lastIndex - text: text - topLeft: characterPoint - extent: lastCharacterWidth @ line lineHeight - textLine: line ] - ifNotNil: [ "Result for characterBlockForIndex: " - CharacterBlock - stringIndex: characterIndex - text: text - topLeft: characterPoint - extent: lastCharacterWidth @ line lineHeight - textLine: line ]] - ] repeat! ! -!CompositionScanner methodsFor: 'scanning' stamp: 'jmv 9/2/2018 23:27:51' prior: 16822889! - composeFrom: startIndex inRectangle: lineRectangle firstLine: firstLine leftSide: leftSide rightSide: rightSide - - "Answer an instance of TextLineInterval that represents the next line in the paragraph." - | runLength stopCondition xtraSpaceBefore spaceAfterParagraph | - - lastTabIndex _ lastIndex _ startIndex. "scanning sets last index" - destY _ lineRectangle top. - lineHeight _ baseline _ 0. "Will be increased by setFont" - self setFont. - self setStopConditions. - - "Set up margins" - leftMargin _ lineRectangle left. - rightMargin _ lineRectangle right. - xtraSpaceBefore _ 0. - spaceAfterParagraph _ 0. - paragraphStyle ifNotNil: [ - leftSide ifTrue: [ - leftMargin _ leftMargin + - ((firstLine and: [ paragraphStyle isListStyle not ]) - ifTrue: [ paragraphStyle firstIndent ] - ifFalse: [ paragraphStyle restIndent ])]. - rightSide ifTrue: [ - rightMargin _ rightMargin - paragraphStyle rightIndent]. - firstLine ifTrue: [ xtraSpaceBefore _ paragraphStyle spaceBefore ]. - spaceAfterParagraph _ paragraphStyle spaceAfter ]. - lastTabX _ destX _ spaceX _ leftMargin. - - runLength _ text runLengthFor: startIndex. - runStopIndex _ lastIndex + runLength - 1. - line _ (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0) - rectangle: lineRectangle. - line isFirstLine: firstLine. - spaceCount _ 0. - lastLineBreakingSpace _ 0. - leftMargin _ destX. - line leftMargin: leftMargin. - - self placeEmbeddedObject. - [ - stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex - in: text string rightX: rightMargin stopConditions: stopConditions - kern: font baseKern. - "See setStopConditions for stopping conditions for composing." - (self perform: stopCondition) ifTrue: [ - ^ line - lineHeight: lineHeight + xtraSpaceBefore + - (stopCondition == #doNewLine ifTrue: [spaceAfterParagraph] ifFalse: [0]) - baseline: baseline + xtraSpaceBefore ] - ] repeat! ! -!CompositionScanner methodsFor: 'stop conditions' stamp: 'jmv 9/2/2018 23:40:01' prior: 16823086! - tab - "Advance destination x according to tab settings in the current - ParagraphStyle. Answer whether the character has crossed the right edge of - the composition rectangle of the TextComposition." - - destX _ self tabDestX. - destX > rightMargin ifTrue: [^self crossedX]. - lastIndex _ lastIndex + 1. - lastTabX _ destX. - lastTabIndex _ lastIndex. - ^false -! ! -!MorphicScanner methodsFor: 'scanning' stamp: 'jmv 9/2/2018 23:30:05' prior: 50371340! - displayLine: textLine textTopLeft: textTopLeft leftInRun: leftInRun - "The call on the primitive (scanCharactersFrom:to:in:rightX:) will be interrupted according to an array of stop conditions passed to the scanner at which time the code to handle the stop condition is run and the call on the primitive continued until a stop condition returns true (which means the line has terminated). leftInRun is the # of characters left to scan in the current run; when 0, it is time to call setStopConditions." - - "textTopLeft is relative to the morph currently being drawn" - | stopCondition nowLeftInRun startIndex string lastPos x1 | - - topLeft _ textTopLeft. - line _ textLine. - lineY _ line top + textTopLeft y. - rightMargin _ line rightMargin + textTopLeft x. - lastTabIndex _ lastIndex _ line first. - leftInRun <= 0 ifTrue: [ - self setFont. - self setStopConditions ]. - leftMargin _ (line leftMarginForAlignment: alignment) + textTopLeft x. - lastTabX _ destX _ leftMargin. - destY _ lineY + line baseline - font ascent. - - textLine isEmptyLine ifTrue: [ - textLine paragraphStyle ifNotNil: [ :ps | - ps = paragraphStyle ifFalse: [ - foregroundColor _ defaultColor. - self setActualFont: ps font. - ps color ifNotNil: [ :color | self textColor: color ]. - alignment _ ps alignment. - paragraphStyle _ ps. - spaceWidth _ font widthOf: Character space. - xTable _ font xTable. - self setStopConditions. - text ifNotNil: [ destY _ lineY + line baseline - font ascent ]]]. - self displayBulletIfAppropriateFor: textLine textLeft: textTopLeft x. - ^leftInRun ]. - - self displayBulletIfAppropriateFor: textLine textLeft: textTopLeft x. - - leftInRun <= 0 - ifTrue: [nowLeftInRun _ text runLengthFor: lastIndex] - ifFalse: [nowLeftInRun _ leftInRun]. - runStopIndex _ lastIndex + (nowLeftInRun - 1) min: line last. - spaceCount _ 0. - string _ text string. - - self placeEmbeddedObject. - [ - startIndex _ lastIndex. - lastPos _ destX@destY. - stopCondition _ self - scanCharactersFrom: lastIndex to: runStopIndex - in: string rightX: rightMargin stopConditions: stopConditions - kern: font baseKern. - backgroundColor ifNotNil: [ - x1 _ destX. - (Preferences backgroundColorFillsAllBackground and: [startIndex > line last]) ifTrue: [ - x1 _ rightMargin ]. - canvas - fillRectangle: (lastPos corner: x1 @ (line bottom + textTopLeft y)) - color: backgroundColor. - (Preferences backgroundColorFillsAllBackground and: [stopCondition = #tab]) ifTrue: [ - canvas - fillRectangle: (destX @ lastPos y corner: self tabDestX @ (line bottom + textTopLeft y)) - color: backgroundColor ]]. - lastIndex >= startIndex ifTrue: [ - canvas - drawString: string - from: startIndex - to: lastIndex - at: lastPos - font: font - color: foregroundColor ]. - "see setStopConditions for stopping conditions for displaying." - (self perform: stopCondition) ifTrue: [ - "Number of characters remaining in the current run" - ^ runStopIndex - lastIndex ] - ] repeat! ! -!MorphicScanner methodsFor: 'stop conditions' stamp: 'jmv 9/2/2018 23:39:42' prior: 16878154! - tab - destX _ self tabDestX. - lastIndex _ lastIndex + 1. - lastTabX _ destX. - lastTabIndex _ lastIndex. - ^ false! ! - -Object subclass: #CharacterScanner - instanceVariableNames: 'destX lastIndex xTable destY stopConditions text alignment leftMargin rightMargin font line runStopIndex spaceCount spaceWidth tabWidth kern paragraphStyle defaultFont lastTabX lastTabIndex' - classVariableNames: 'DefaultStopConditions StopConditionsWithPaddedSpace StopConditionsWithSpace' - poolDictionaries: '' - category: 'Graphics-Text'! - -!classDefinition: #CharacterScanner category: #'Graphics-Text'! -Object subclass: #CharacterScanner - instanceVariableNames: 'destX lastIndex xTable destY stopConditions text alignment leftMargin rightMargin font line runStopIndex spaceCount spaceWidth tabWidth kern paragraphStyle defaultFont lastTabX lastTabIndex' - classVariableNames: 'DefaultStopConditions StopConditionsWithPaddedSpace StopConditionsWithSpace' - poolDictionaries: '' - category: 'Graphics-Text'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3431-TabColumnsFix-JuanVuletich-2018Sep02-23h10m-jmv.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3430] on 2 September 2018 at 11:54:19 pm'! -!Workspace class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:15:27' prior: 50403865! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'Workspace'. - #object -> Workspace. - #selector -> #openWorkspace. - #icon -> #terminalIcon. - #balloonText -> 'A window for evaluating Smalltalk expressions'. - } asDictionary}`! ! -!Transcripter class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:15:19' prior: 50403878! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Emergency Evaluator'. - #object -> Transcripter. - #selector -> #emergencyEvaluator. - #icon -> #emblemImportantIcon. - #balloonText -> 'When all else fails...'. - } asDictionary}`! ! -!TextEditor class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:14:50' prior: 50403891! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Text Editor'. - #object -> TextEditor. - #selector -> #openTextEditor. - #icon -> #textEditorIcon. - #balloonText -> 'A window for composing text'. - } asDictionary}`! ! -!CodePackageListWindow class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:13:05' prior: 50403916! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Installed Packages'. - #object -> CodePackageListWindow. - #selector -> #openPackageList. - #icon -> #packageIcon. - #balloonText -> 'A tool for managing Packages (optional units of code) installed in the system'. - } asDictionary}`! ! -!BrowserWindow class methodsFor: 'menu-world' stamp: 'HAW 7/6/2018 11:53:52' prior: 50404019! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Browser'. - #object -> BrowserWindow. - #selector -> #openBrowser. - #icon -> #editFindReplaceIcon. - #balloonText -> 'A Smalltalk code browser, for studying and modifying the system'. - } asDictionary}`! ! -!MessageNamesWindow class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:13:59' prior: 50404062! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'Message Names'. - #object -> MessageNamesWindow. - #selector -> #openMessageNames. - #icon -> #inspectIcon. - #balloonText -> 'A tool for finding and editing methods that contain any given keyword in their names.'. - } asDictionary}`! ! -!ChangeSorterWindow class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:12:50' prior: 50404077! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Change Sorter'. - #object -> ChangeSorterWindow. - #selector -> #openChangeSorter. - #icon -> #halfRefreshIcon. - #balloonText -> 'A tool allowing you to view the methods in a Change Set, especially changes to the Base System'. - } asDictionary}`! ! -!FileListWindow class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:13:27' prior: 50404092! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'File List'. - #object -> FileListWindow. - #selector -> #openFileList. - #icon -> #systemFileManagerIcon. - #balloonText -> 'An explorer of the File System'. - } asDictionary}`! ! -!ProcessBrowserWindow class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:14:22' prior: 50404105! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Process Browser'. - #object -> ProcessBrowserWindow. - #selector -> #openProcessBrowser. - #icon -> #systemMonitorIcon. - #balloonText -> 'A tool to monitor and manage Smalltalk processes'. - } asDictionary}`! ! -!TestRunnerWindow class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:14:27' prior: 50404119! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'SUnit Test Runner'. - #object -> TestRunnerWindow. - #selector -> #openTestRunner. - #icon -> #weatherFewCloudsIcon. - #balloonText -> 'Smalltalk''s testing framework'. - } asDictionary}`! ! -!TranscriptWindow class methodsFor: 'menu-world' stamp: 'HAW 7/7/2018 19:15:13' prior: 50404132! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 10. - #itemOrder -> 50. - #label -> 'Transcript'. - #object -> TranscriptWindow. - #selector -> #openTranscript. - #icon -> #printerIcon. - #balloonText -> 'A window showing contents of the System Transcript'. - } asDictionary}`! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3432-FixSomeTabbing-JuanVuletich-2018Sep02-23h47m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3430] on 3 September 2018 at 12:02:50 am'! -!Collection methodsFor: 'converting' stamp: 'jmv 9/3/2018 00:00:57' prior: 50393640! - asDictionary - "Answer a Dictionary. Assume our elements are Associations. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Browser'. - #object -> BrowserWindow. - #selector -> #openBrowser. - #icon -> #editFindReplaceIcon. - #balloonText -> 'A Smalltalk code browser, for studying and modifying the system'. - } asDictionary - " - - ^ self as: Dictionary! ! -!SmalltalkEditor class methodsFor: 'menu' stamp: 'HAW 7/10/2018 19:03:02' prior: 50404621! - smalltalkEditorMenu2Options - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Find...(f)'. - #selector -> #find. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'Find Again (g)'. - #selector -> #findAgain. - #icon -> #systemIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Use Selection for Find (j)'. - #selector -> #setSearchString. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Undo - multiple (z)'. - #selector -> #undo. - #icon -> #undoIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Redo - multiple (Z)'. - #selector -> #redo. - #icon -> #redoIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'Undo / Redo history'. - #selector -> #offerUndoHistory. - #icon -> #changesIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Copy (c)'. - #selector -> #copySelection. - #icon -> #copyIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Cut (x)'. - #selector -> #cut. - #icon -> #cutIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'Paste (v)'. - #selector -> #paste. - #icon -> #pasteIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 40. - #label -> 'Paste without Format'. - #selector -> #pasteString. - #icon -> #pasteIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 50. - #label -> 'Paste...'. - #selector -> #pasteRecent. - #icon -> #worldIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'Toggle WordWrap'. - #selector -> #wrapOnOff. - #icon -> #genericTextIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'Set Font... (k)'. - #selector -> #offerFontMenu. - #icon -> #preferencesDesktopFontIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'Clear Font'. - #selector -> #clearFont. - #icon -> #newIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 40. - #label -> 'Set Default Font...'. - #selector -> #offerDefaultFontMenu. - #icon -> #fontXGenericIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'More...'. - #selector -> #openMenu. - #icon -> #listAddIcon - } asDictionary. - }` -! ! -!SmalltalkEditor class methodsFor: 'menu' stamp: 'jmv 9/2/2018 23:59:47' prior: 50405415! - smalltalkEditorMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Help...'. - #selector -> #openHelp. - #icon -> #helpIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Do it (d)'. - #selector -> #doIt. - #icon -> #doItIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Print it (p)'. - #selector -> #printIt. - #icon -> #printIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'Inspect it (i)'. - #selector -> #inspectIt. - #icon -> #inspectIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 40. - #label -> 'Explore it (I)'. - #selector -> #exploreIt. - #icon -> #exploreIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 50. - #label -> 'Debug it (D)'. - #selector -> #debugIt. - #icon -> #debugIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 60. - #label -> 'Profile it'. - #selector -> #profileIt. - #icon -> #clockIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Explain'. - #selector -> #explain. - #icon -> #helpIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Browse it (b)'. - #selector -> #browseIt. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'Senders of it (n)'. - #selector -> #sendersOfIt. - #icon -> #mailForwardIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 40. - #label -> 'Implementors of it (m)'. - #selector -> #implementorsOfIt. - #icon -> #developmentIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 50. - #label -> 'References to it (N)'. - #selector -> #referencesToIt. - #icon -> #addressBookIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'Method Strings with it (E)'. - #selector -> #methodStringsContainingit. - #icon -> #genericTextIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'Method Source with it'. - #selector -> #methodSourceContainingIt. - #icon -> #scriptIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'Class Comments with it'. - #selector -> #classCommentsContainingIt. - #icon -> #chatIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'Accept (s)'. - #selector -> #acceptContents. - #icon -> #acceptIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'Accept & Run Test in Class (t)'. - #selector -> #acceptAndTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 40. - #label -> 'Accept & Run Test in Category (y)'. - #selector -> #acceptAndTestAll. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 50. - #label -> 'Accept & Debug Test (r)'. - #selector -> #acceptAndDebugTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'More...'. - #selector -> #openMenu2. - #icon -> #listAddIcon - } asDictionary. - }`! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'HAW 7/7/2018 18:45:13' prior: 50403981! - messageListMenu2 - "Fill aMenu with the items appropriate when the shift key is held down" - - ^DynamicMenuBuilder - buildTitled: 'Message List' - targeting: self - collectingMenuOptionsWith: #messageListMenu2Options - changingThemWith: [ :options | - self addExtraMenu2ItemsTo: options. - model canShowMultipleMessageCategories ifTrue: [ - options add: `{ - #itemGroup -> 40. - #itemOrder -> 45. - #label -> 'show category (C)'. - #object -> #model. - #selector -> #showHomeCategory. - #icon -> #packageIcon - } asDictionary` ]]. - - ! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 7/6/2018 12:21:10' prior: 50403028! - classListMenu2Options - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'unsent methods'. - #selector -> #browseUnusedMethods. - #icon -> #junkIcon. - #balloonText -> 'browse all methods defined by this class that have no senders' - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'unreferenced inst vars'. - #selector -> #showUnreferencedInstVars. - #icon -> #junkIcon. - #balloonText -> 'show a list of all instance variables that are not referenced in methods' - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'unreferenced class vars'. - #selector -> #showUnreferencedClassVars. - #icon -> #junkIcon. - #balloonText -> 'show a list of all class variables that are not referenced in methods' - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'subclass template'. - #object -> #model. - #selector -> #makeNewSubclass. - #icon -> #classIcon. - #balloonText -> 'put a template into the code pane for defining of a subclass of this class' - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'sample instance'. - #selector -> #makeSampleInstance. - #icon -> #instanceIcon. - #balloonText -> 'give me a sample instance of this class, if possible' - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'inspect instances'. - #selector -> #inspectInstances. - #icon -> #inspectIcon. - #balloonText -> 'open an inspector on all the extant instances of this class' - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'inspect subinstances'. - #selector -> #inspectSubInstances. - #icon -> #inspectIcon. - #balloonText -> 'open an inspector on all the extant instances of this class and of all of its subclasses' - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'create inst var accessors'. - #object -> #model. - #selector -> #createInstVarAccessors. - #icon -> #sendReceiveIcon. - #balloonText -> 'compile instance-variable access methods for any instance variables that do not yet have them' - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'more...'. - #selector -> #offerClassListMenu. - #icon -> #listAddIcon. - #balloonText -> 'return to the standard class-list menu' - } asDictionary. - }`! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 8/3/2018 14:47:08' prior: 50407707! - classListMenuOptions - - ^ `{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutClass. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 5. - #label -> 'show classes hierarchically'. - #object -> #model. - #selector -> #enableListClassesHierarchically. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 6. - #label -> 'show classes alphabetically'. - #object -> #model. - #selector -> #enableListClassesAlphabetically. - #icon -> #sendReceiveIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'show hierarchy'. - #object -> #model. - #selector -> #hierarchy. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'show definition'. - #object -> #model. - #selector -> #editClass. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'show comment'. - #object -> #model. - #selector -> #editComment. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'inst var refs...'. - #selector -> #browseInstVarRefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'inst var defs...'. - #selector -> #browseInstVarDefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'class var refs...'. - #selector -> #browseClassVarRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 20. - #label -> 'class vars'. - #selector -> #browseClassVariables. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'class refs (N)'. - #selector -> #browseClassRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'rename class ...'. - #object -> #model. - #selector -> #renameClass. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 20. - #label -> 'copy class...'. - #object -> #model. - #selector -> #copyClass. - #icon -> #copyIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 30. - #label -> 'remove class (x)'. - #object -> #model. - #selector -> #removeClass. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 10. - #label -> 'run tests (t)'. - #object -> #model. - #selector -> #runClassTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 20. - #label -> 'more...'. - #selector -> #offerClassListMenu2. - #icon -> #listAddIcon - } asDictionary. - }`. - ! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 7/6/2018 12:24:58' prior: 50403222! - messageCategoryMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'fileOut (o)'. - #object -> #model. - #selector -> #fileOutMessageCategories. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'reorganize'. - #object -> #model. - #selector -> #editMessageCategories. - #icon -> #sendReceiveIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'alphabetize'. - #object -> #model. - #selector -> #alphabetizeMessageCategories. - #icon -> #fontXGenericIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'remove empty categories'. - #object -> #model. - #selector -> #removeEmptyCategories. - #icon -> #listRemoveIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 40. - #label -> 'categorize all uncategorized'. - #object -> #model. - #selector -> #categorizeAllUncategorizedMethods. - #icon -> #packageIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 50. - #label -> 'new category...'. - #object -> #model. - #selector -> #addCategory. - #icon -> #newIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'rename...'. - #object -> #model. - #selector -> #renameCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'remove (x)'. - #object -> #model. - #selector -> #removeMessageCategory. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'run tests (t)'. - #object -> #model. - #selector -> #runMessageCategoryTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - }`. - ! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 7/7/2018 18:22:02' prior: 50403288! - messageListMenu2Options - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'toggle diffing (D)'. - #object -> #model. - #selector -> #toggleDiffing. - #icon -> #switchIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'implementors of sent messages'. - #selector -> #browseAllMessages. - #icon -> #developmentIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'local senders of...'. - #selector -> #browseLocalSendersOfMessages. - #icon -> #mailForwardIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'local implementors of...'. - #selector -> #browseLocalImplementors. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'spawn sub-protocol'. - #selector -> #browseProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'spawn full protocol'. - #selector -> #browseFullProtocol. - #icon -> #speadsheetTemplateIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'sample instance'. - #selector -> #makeSampleInstance. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'inspect instances'. - #selector -> #inspectInstances. - #icon -> #inspectIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'inspect subinstances'. - #selector -> #inspectSubInstances. - #icon -> #inspectIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 40. - #label -> 'change category...'. - #object -> #model. - #selector -> #changeCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 50. - #label -> 'change sets with this method'. - #selector -> #findMethodInChangeSets. - #icon -> #changesIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 60. - #label -> 'revert to previous version'. - #object -> #model. - #selector -> #revertToPreviousVersion. - #icon -> #undoIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'more...'. - #selector -> #openMessageListMenu. - #icon -> #listAddIcon - } asDictionary. - }`! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 8/11/2018 18:51:50' prior: 50408802! - messageListMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'what to show...'. - #selector -> #offerWhatToShowMenu. - #icon -> #preferencesIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'toggle break on entry'. - #object -> #model. - #selector -> #toggleBreakOnEntry. - #icon -> #debugIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'browse method (O)'. - #selector -> #openSingleMessageBrowser. - #icon -> #scriptIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 40. - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutMessage. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'inspect CompiledMethod'. - #object -> #model. - #selector -> #inspectCompiledMethod. - #icon -> #exploreIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'senders of... (n)'. - #selector -> #browseSendersOfMessages. - #icon -> #mailForwardIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'implementors of... (m)'. - #selector -> #browseMessages. - #icon -> #developmentIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'inheritance (i)'. - #selector -> #methodHierarchy. - #icon -> #goDownIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 40. - #label -> 'versions (v)'. - #selector -> #browseVersions. - #icon -> #clockIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'inst var refs...'. - #selector -> #browseInstVarRefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 20. - #label -> 'inst var defs...'. - #selector -> #browseInstVarDefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'class var refs...'. - #selector -> #browseClassVarRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 40. - #label -> 'class variables'. - #selector -> #browseClassVariables. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 50. - #label -> 'class refs (N)'. - #selector -> #browseClassRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'remove method (x)'. - #object -> #model. - #selector -> #removeMessage. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 20. - #label -> 'run test (t)'. - #object -> #model. - #selector -> #runMethodTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 30. - #label -> 'debug test (r)'. - #object -> #model. - #selector -> #debugMethodTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 10. - #label -> 'more...'. - #selector -> #openMessageListMenu2. - #icon -> #listAddIcon - } asDictionary. - }`. - ! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 7/7/2018 19:04:27' prior: 50403505! - systemCatSingletonMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'find class... (f)'. - #selector -> #findClass. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'browse all'. - #selector -> #browseAllClasses. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'browse'. - #selector -> #openSystemCategoryBrowser. - #icon -> #packageIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutSystemCategory. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'update'. - #object -> #model. - #selector -> #updateSystemCategories. - #icon -> #updateIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'rename...'. - #object -> #model. - #selector -> #renameSystemCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'remove'. - #object -> #model. - #selector -> #removeSystemCategory. - #icon -> #deleteIcon - } asDictionary. - }`. - ! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 7/7/2018 19:02:29' prior: 50403553! - systemCategoryMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'find class... (f)'. - #selector -> #findClass. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'recent classes... (r)'. - #object -> #model. - #selector -> #recent. - #icon -> #clockIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'browse all'. - #selector -> #browseAllClasses. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'browse'. - #selector -> #openSystemCategoryBrowser. - #icon -> #packageIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutSystemCategory. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'reorganize'. - #object -> #model. - #selector -> #editSystemCategories. - #icon -> #sendReceiveIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'alphabetize'. - #object -> #model. - #selector -> #alphabetizeSystemCategories. - #icon -> #fontXGenericIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'update'. - #object -> #model. - #selector -> #updateSystemCategories. - #icon -> #updateIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 20. - #label -> 'add item...'. - #object -> #model. - #selector -> #addSystemCategory. - #icon -> #newIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'rename...'. - #object -> #model. - #selector -> #renameSystemCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 40. - #label -> 'remove'. - #object -> #model. - #selector -> #removeSystemCategory. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'move to top'. - #object -> #model. - #selector -> #moveSystemCategoryTop. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 20. - #label -> 'move up'. - #object -> #model. - #selector -> #moveSystemCategoryUp. - #icon -> #goUpIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 30. - #label -> 'move down'. - #object -> #model. - #selector -> #moveSystemCategoryDown. - #icon -> #goDownIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 40. - #label -> 'move to bottom'. - #object -> #model. - #selector -> #moveSystemCategoryBottom. - #icon -> #goBottomIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 10. - #label -> 'run tests (t)'. - #object -> #model. - #selector -> #runSystemCategoryTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - }`. - ! ! -!MessageSetWindow methodsFor: 'menu building' stamp: 'HAW 7/7/2018 18:31:51' prior: 50404033! - addExtraMenu2ItemsTo: options - "The shifted selector-list menu is being built. Add items specific to MessageSet" - - model growable ifTrue: [ - options add: `{ - #itemGroup -> 40. - #itemOrder -> 31. - #label -> 'remove from this browser'. - #object -> #model. - #selector -> #removeMessageFromBrowser. - #icon -> #listRemoveIcon - } asDictionary`. - options add:`{ - #itemGroup -> 40. - #itemOrder -> 32. - #label -> 'filter message list...'. - #selector -> #filterMessageList. - #icon -> #findIcon - } asDictionary` ]. - - options add: `{ - #itemGroup -> 40. - #itemOrder -> 33. - #label -> 'sort by date'. - #object -> #model. - #selector -> #sortByDate. - #icon -> #dateIcon - } asDictionary`. - -! ! -!TheWorldMenu class methodsFor: 'menu building' stamp: 'HAW 7/5/2018 18:37:46' prior: 50403756! - worldMenuOptions - - ^`{{ - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Open...'. - #selector -> #openOpenMenu. - #icon -> #openIcon. - #balloonText -> 'Submenu to open various system tools'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'New morph...'. - #selector -> #newMorph. - #icon -> #morphsIcon. - #balloonText -> 'Offers a variety of ways to create new objects'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Preferences...'. - #selector -> #openPreferencesMenu. - #icon -> #preferencesIcon. - #balloonText -> 'Opens a menu offering many controls over appearance and system preferences.'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'Windows...'. - #selector -> #openWindowsMenu. - #icon -> #windowIcon. - #balloonText -> 'Manage open windows'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 50. - #label -> 'Help...'. - #selector -> #openHelpMenu. - #icon -> #helpIcon. - #balloonText -> 'Opens a menu of useful items for updating the system, determining what version you are running, and much else'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Changes...'. - #selector -> #openChangesMenu. - #icon -> #changesIcon. - #balloonText -> 'Opens a menu of useful tools for dealing with changes'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Debug...'. - #selector -> #openDebugMenu. - #icon -> #debugIcon. - #balloonText -> 'a menu of debugging items'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'Restore Display (r)'. - #object -> #myWorld. - #selector -> #restoreDisplay. - #icon -> #displayIcon. - #balloonText -> 'Repaint the screen -- useful for removing unwanted display artifacts, lingering cursors, etc.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Save'. - #object -> Smalltalk. - #selector -> #saveSession. - #icon -> #saveIcon. - #balloonText -> 'Save the current version of the image on disk'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Save as...'. - #object -> Smalltalk. - #selector -> #saveAs. - #icon -> #saveAsIcon. - #balloonText -> 'Save the current version of the image on disk under a new name.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'Save as New Version'. - #object -> Smalltalk. - #selector -> #saveAsNewVersion. - #icon -> #saveAsNewVersionIcon. - #balloonText -> ('Save the current image a new version-stamped name\and save it under that name on disk.\', - 'Clear all user preferences and user state (class vars).') withNewLines. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 40. - #label -> 'Save and Quit'. - #selector -> #saveAndQuit. - #icon -> #saveAndQuitIcon. - #balloonText -> 'Save the image and quit out of Cuis.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 50. - #label -> 'Quit'. - #selector -> #quitSession. - #icon -> #quitIcon. - #balloonText -> 'Quit out of Cuis.'. - } asDictionary. -}`! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3433-FixSomeTabbing-JuanVuletich-2018Sep02-23h54m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3430] on 3 September 2018 at 12:04:11 am'! -!Number methodsFor: 'printing' stamp: 'jmv 9/3/2018 00:03:09' prior: 50371628! - withBinaryUnitPrefixAndValue: aBlock - " - As in https://en.wikipedia.org/wiki/Binary_prefix - { 0.123456. 1.23456. 12.3456. 123.456. 1234.56. 12345.6. 123456. 1234560. 12345600 } do: [ :n | n withBinaryUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | {value printString, ' ', unitPrefixSymbol. unitPrefixName} print]] - " - | prefixIndex factor nameAndSymbol | - prefixIndex _ self log floor // 3. - prefixIndex _ prefixIndex min: 8 max: 0. - factor _ 1024 raisedToInteger: prefixIndex. - nameAndSymbol _ { - {''. ''}. - {'kibi'. 'Ki'}. - {'mebi'. 'Mi'}. - {'gibi'. 'Gi'}. - {'tebi'. 'Ti'}. - {'pebi'. 'Pi'}. - {'exbi'. 'Ei'}. - {'zebi'. 'Zi'}. - {'yobi'. 'Yi'} - } at: prefixIndex+1. - aBlock value: (self / factor) asIntegerOrFloat value: nameAndSymbol second value: nameAndSymbol first! ! -!Number methodsFor: 'printing' stamp: 'jmv 9/3/2018 00:03:34' prior: 50371656! - withDecimalUnitPrefixAndValue: aBlock - " - As in https://en.wikipedia.org/wiki/Metric_prefix - { 0.00000123456. 0.0000123456. 0.000123456. 0.00123456. 0.0123456. 0.123456. 1.23456. 12.3456. 123.456. 1234.56. 12345.6. 123456. 1234560. 12345600 } do: [ :n | n withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | {value printString, ' ', unitPrefixSymbol. unitPrefixName} print]] - " - | prefixIndex factor nameAndSymbol | - prefixIndex _ self log floor // 3. - prefixIndex _ prefixIndex min: 6 max: -6. - factor _ 1000 raisedToInteger: prefixIndex. - nameAndSymbol _ { - {'atto'. 'a'}. - {'femto'. 'f'}. - {'pico'. 'p'}. - {'nano'. 'n'}. - {'micro'. 'µ'}. - {'milli'. 'm'}. - {''. ''}. - {'kilo'. 'k'}. - {'mega'. 'M'}. - {'giga'. 'G'}. - {'tera'. 'T'}. - {'peta'. 'P'}. - {'exa'. 'E'} - } at: prefixIndex+7. - aBlock value: self asFloat / factor value: nameAndSymbol second value: nameAndSymbol first! ! -!SmalltalkEditor class methodsFor: 'menu' stamp: 'jmv 9/3/2018 00:03:51' prior: 50411086! - smalltalkEditorMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Help...'. - #selector -> #openHelp. - #icon -> #helpIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Do it (d)'. - #selector -> #doIt. - #icon -> #doItIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Print it (p)'. - #selector -> #printIt. - #icon -> #printIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'Inspect it (i)'. - #selector -> #inspectIt. - #icon -> #inspectIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 40. - #label -> 'Explore it (I)'. - #selector -> #exploreIt. - #icon -> #exploreIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 50. - #label -> 'Debug it (D)'. - #selector -> #debugIt. - #icon -> #debugIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 60. - #label -> 'Profile it'. - #selector -> #profileIt. - #icon -> #clockIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Explain'. - #selector -> #explain. - #icon -> #helpIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Browse it (b)'. - #selector -> #browseIt. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'Senders of it (n)'. - #selector -> #sendersOfIt. - #icon -> #mailForwardIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 40. - #label -> 'Implementors of it (m)'. - #selector -> #implementorsOfIt. - #icon -> #developmentIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 50. - #label -> 'References to it (N)'. - #selector -> #referencesToIt. - #icon -> #addressBookIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'Method Strings with it (E)'. - #selector -> #methodStringsContainingit. - #icon -> #genericTextIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'Method Source with it'. - #selector -> #methodSourceContainingIt. - #icon -> #scriptIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'Class Comments with it'. - #selector -> #classCommentsContainingIt. - #icon -> #chatIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'Accept (s)'. - #selector -> #acceptContents. - #icon -> #acceptIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'Accept & Run Test in Class (t)'. - #selector -> #acceptAndTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 40. - #label -> 'Accept & Run Test in Category (y)'. - #selector -> #acceptAndTestAll. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 50. - #label -> 'Accept & Debug Test (r)'. - #selector -> #acceptAndDebugTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'More...'. - #selector -> #openMenu2. - #icon -> #listAddIcon - } asDictionary. - }`! ! -!Transcript class methodsFor: 'preferred protocol' stamp: 'jmv 9/3/2018 00:04:05' prior: 16938264! - clear - - accessSemaphore critical: [ - "Having at least one entry simplifies handling of the entries circular collection" - firstIndex _ 1. - lastIndex _ 1. - entries at: 1 put: 'Transcript'. - unfinishedEntry reset. - lastDisplayPosition _ 0. - - logToFile ifTrue: [ - self filename asFileEntry forceWriteStreamDo: [ :stream | - stream nextPutAll: 'Transcript log started: '. - DateAndTime now printOn: stream. - stream - newLine; - nextPutAll: '------------------------------------------------------------------------'; - newLine ]]]. - self display! ! -!Transcript class methodsFor: 'preferred protocol' stamp: 'jmv 9/3/2018 00:04:08' prior: 16938303! - clearInternal - - accessSemaphore critical: [ - "Having at least one entry simplifies handling of the entries circular collection" - firstIndex _ 1. - lastIndex _ 1. - entries at: 1 put: 'Transcript'. - unfinishedEntry reset. - lastDisplayPosition _ 0 ]. - self display! ! -!PreDebugWindow methodsFor: 'GUI building' stamp: 'jmv 9/3/2018 00:03:40' prior: 16892604! - preDebugButtonSpec - - ^{ - {'Proceed'. #proceed. 'continue execution' }. - {'Abandon'. #abandon. 'abandon this execution by closing this window' }. - {'Debug'. #debug. 'bring up a debugger' } - }! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3434-FixSomeTabbing-JuanVuletich-2018Sep03-00h02m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3430] on 3 September 2018 at 12:07:09 am'! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 9/3/2018 00:05:26' prior: 50410370! - smoothStep - "A Function that is - x <= -1 -> 1 - -1 < x < 1 -> smooth differentiable transition from 1 to 0 - 1 <= x -> 0 - - It is a 'smooth' version of an #negative - Has countless applications. For example in image and signal processing, but also in other fields." - " - | g | - Feature require: 'Morphic-Widgets-Extras'. - g _ FunctionGraphMorph new. - g domain: (-4 to: 4). - g addFunction: [ :x | x abs < 1 ifTrue: [1] ifFalse:[0] ] color: Color brown. - g addFunction: [ :x | x smoothStep ] color: Color red. - (g embeddedInMorphicWindowLabeled: 'graph') openInWorld - " - self > -1 ifFalse: [ ^ 1 ]. - 1 > self ifFalse: [ ^ 0 ]. - ^ (self +2 * Float halfPi) sin * 0.5 + 0.5! ! -!PluggableScrollPane methodsFor: 'events' stamp: 'jmv 9/3/2018 00:05:46' prior: 50374220! - mouseScroll: aMouseEvent localPosition: localEventPosition - aMouseEvent direction - caseOf: { - [ #up ] -> [ scrollBar scrollUp: 1 ]. - [ #down ] -> [ scrollBar scrollDown: 1 ]. - [ #left ] -> [ hScrollBar scrollUp: 1 ]. - [ #right ] -> [ hScrollBar scrollDown: 1 ] }! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 9/3/2018 00:06:36' prior: 50396930! - helpMenu - "Build the help menu for the world." - - ^ (self menu: 'Help...') - addItemsFromDictionaries: `{ - { - #label -> 'About this System...'. - #object -> Smalltalk. - #selector -> #aboutThisSystem. - #icon -> #helpIcon. - #balloonText -> 'current version information.' - } asDictionary. - { - #label -> 'Terse Guide to Cuis'. - #selector -> #openTerseGuide. - #icon -> #helpIcon. - #balloonText -> 'explore Cuis Smalltalk' - } asDictionary. - { - #label -> 'Class Comment Browser'. - #selector -> #openCommentGuide. - #icon -> #helpIcon. - #balloonText -> 'search & explore Cuis Class Comments' - } asDictionary. - { - #label -> 'Code management in Cuis'. - #object -> Utilities. - #selector -> #openCodeManagementInCuis. - #icon -> #helpIcon. - #balloonText -> 'Features are kept in Packages.' - } asDictionary. - { - #label -> 'Using GitHub to host Cuis packages'. - #object -> Utilities. - #selector -> #openCuisAndGitHub. - #icon -> #helpIcon. - #balloonText -> 'GitHub usage pattern.' - } asDictionary. - nil. - { - #label -> 'Editor keyboard shortcuts'. - #object -> SmalltalkEditor. - #selector -> #openHelp. - #icon -> #keyboardShortcutsIcon. - #balloonText -> 'summary of keyboard shortcuts in editors for Smalltalk code.' - } asDictionary. - { - #label -> 'Useful Expressions'. - #object -> Utilities. - #selector -> #openUsefulExpressions. - #icon -> #chatIcon. - #balloonText -> 'a window full of useful expressions.' - } asDictionary. - nil. - { - #label -> 'VM Statistics'. - #selector -> #vmStatistics. - #icon -> #systemMonitorIcon. - #balloonText -> 'obtain some intriguing data about the vm.' - } asDictionary. - { - #label -> 'Space Left'. - #selector -> #garbageCollect. - #icon -> #removableMediaIcon. - #balloonText -> 'perform a full garbage-collection and report how many bytes of space remain in the image.' - } asDictionary. - }`! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3435-FixSomeTabbing-JuanVuletich-2018Sep03-00h04m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3430] on 3 September 2018 at 12:08:37 am'! -!LayoutSpec commentStamp: 'jmv 9/3/2018 00:07:43' prior: 16864138! - LayoutSpecs are the basis for the layout mechanism. Any Morph can be given a LayoutSpec, but in order to honor it, its owner must be a LayoutMorph. - -A LayoutSpec specifies how a morph wants to be layed out. It can specify either a fixed width or a fraction of some available owner width. Same goes for height. If a fraction is specified, a minimum extent is also possible. - - -Alternatives: - - proportionalWidth notNil, fixedWidth notNil -> Use fraction of available space, take fixedWidth as minimum desired width - - proportionalWidth isNil, fixedWidth isNil -> Use current morph width - - proportionalWidth isNil, fixedWidth notNil -> Use fixedWidth - - proportionalWidth notNil, fixedWidth isNil -> NOT VALID - -Same goes for proportionalHeight and fixedHeight -! -!LayoutSpec methodsFor: 'accessing' stamp: 'jmv 9/3/2018 00:08:13' prior: 16864261! - proportionalWidth: aNumberOrNil minimum: otherNumberOrNil - "Alternatives: - - proportionalWidth notNil, fixedWidth notNil -> Use fraction of available space, take fixedWidth as minimum desired width - - proportionalWidth isNil, fixedWidth isNil -> Use current morph width - - proportionalWidth isNil, fixedWidth notNil -> Use fixedWidth - - proportionalWidth notNil, fixedWidth isNil -> NOT VALID" - proportionalWidth _ aNumberOrNil. - fixedWidth _ otherNumberOrNil! ! -!LayoutSpec methodsFor: 'accessing' stamp: 'jmv 9/3/2018 00:08:20' prior: 16864285! - setProportionalWidth: aNumberOrNil - "Alternatives: - - proportionalWidth notNil, fixedWidth notNil -> Use fraction of available space, take fixedWidth as minimum desired width - - proportionalWidth isNil, fixedWidth isNil -> Use current morph width - - proportionalWidth isNil, fixedWidth notNil -> Use fixedWidth - - proportionalWidth notNil, fixedWidth isNil -> NOT VALID" - proportionalWidth _ aNumberOrNil! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3436-FixSomeTabbing-JuanVuletich-2018Sep03-00h07m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3436] on 6 September 2018 at 6:13:28 pm'! -!SmalltalkEditor methodsFor: 'typing/selecting keys' stamp: 'jmv 9/6/2018 17:51:29'! - argNext: aKeyboardEvent - "Invoked by cmd-A. - Search forward from the end of the selection for a colon followed by - a space. Place the text cursor after the space. If none are found, place the - text cursor at the end of the text.." - - | start t | - t _ model actualContents. - start _ t findString: ': ' startingAt: self startIndex. - start = 0 ifTrue: [ start _ t size + 1]. - self deselectAndPlaceCursorAt: start + 2. - ^true! ! -!SmalltalkEditor methodsFor: 'typing/selecting keys' stamp: 'jmv 9/6/2018 18:09:53'! - argPrev: aKeyboardEvent - "Invoked by cmd-Q. - Search backwards from the start of the selection for a colon followed by - a space. Place the text cursor after the space. If none are found, place the - text cursor at the start of the text.." - - | t i | - t _ model actualContents. - i _ self stopIndex. - i > 1 ifTrue: [ - i _ i -2. - [i > 0 and: [ (t at: i) ~= $ or: [(t at: i-1) ~= $: ]]] whileTrue: [ - i _ i -1 ]. - self deselectAndPlaceCursorAt: i + 1. - ]. - ^true! ! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'jmv 9/6/2018 17:56:10' prior: 16906691! - quickFindLast: aBlock - "Return the index of my last element for which aBlock evaluates as true. - Assumes that receiver is sorted according with aBlock. Then, we are able to use faster binary search. - Result is (in these cases) the same as #findLast: - - 1 to: 1000 :: findLast: [:x | x squared < 123456] - 1 to: 1000 :: quickFindLast: [:x | x squared < 123456] - - 1 to: 1000 :: findLast: [:x | x squared < -10] - 1 to: 1000 :: quickFindLast: [:x | x squared < -10] - - 1 to: 1000 :: findLast: [:x | x squared < 1234560] - 1 to: 1000 :: quickFindLast: [:x | x squared < 1234560] - " - ^self - findBinaryIndex: [ :x | (aBlock value: x) ifTrue: [1] ifFalse: [-1]] - do: [ :i | ] - ifNone: [ :i1 :i2 | i1 ]! ! -!SmalltalkEditor methodsFor: 'typing/selecting keys' stamp: 'jmv 9/6/2018 17:47:15' prior: 16910004! - displayIfFalse: aKeyboardEvent - "Replace the current text selection with the text 'ifFalse:'--initiated by - cmd-F." - - self addString: 'ifFalse:'. - ^false! ! -!SmalltalkEditor methodsFor: 'typing/selecting keys' stamp: 'jmv 9/6/2018 17:47:27' prior: 16910012! - displayIfTrue: aKeyboardEvent - "Replace the current text selection with the text 'ifTrue:'--initiated by - cmd-T." - - self addString: 'ifTrue:'. - ^false! ! -!SmalltalkEditor class methodsFor: 'keyboard shortcut tables' stamp: 'jmv 9/6/2018 17:50:48' prior: 50405362! - cmdShortcutsSpec - " - Editor initialize - " - "arranged in QWERTY keyboard order" - ^#( - #( $r #acceptAndDebugTest: 'Saves method and debugs it') - #( $t #acceptAndTest: 'Saves method, runs it as test and then all tests in class. Opens debugger if error') - #( $y #acceptAndTestAll: 'Saves method, runs it as test and then all tests in class category. Opens debugger if error') - #( $i #inspectIt: 'Inspect it (selection is a valid expression, or selection is over an inspect-ilst)') - #( $p #printIt: 'Print it (selection is a valid expression)') - - #( $s #save: 'Save (i.e. accept)') - #( $d #doIt: 'Do it (selection is a valid expression)') - - #( $b #browseIt: 'Browse it (selection is a class name or cursor is over a class-list or message-list)') - #( $n #sendersOfIt: 'Senders of it (selection is a message selector or cursor is over a class-list or message-list)') - #( $m #implementorsOfIt: 'Implementors of it (selection is a message selector or cursor is over a class-list or message-list)') - - #( $E #methodStringsContainingit:'Method strings containing it') - #( $T #displayIfTrue: 'Insert #ifTrue:') - #( $I #exploreIt: 'Inspect via Object Explorer') - - #( $Q #argPrev: 'Previous argument') - #( $A #argNext: 'Next argument') - #( $D #debugIt: 'Debug it') - #( $F #displayIfFalse: 'Insert #ifFalse:') - #( $G #fileItIn: 'File in selection') - - #( $V #pasteInitials: 'Paste author initials') - #( $N #referencesToIt: 'References to it (selection is a class name, or cursor is over a class-list or message-list)') - )! ! -!AutoCompleter methodsFor: 'keyboard' stamp: 'jmv 9/6/2018 17:40:31' prior: 50366939! -handleKeystrokeBefore: kbEvent - "I return a boolean. true when I have handled the event and no futher processing is needed by the caller." - | currentPos currentChar currentCharIsAlphaNumericOrColon keyValue ctrl cmd tab colon alphanum backspace esc space return keyChar | - currentPos _ textMorph editor startIndex-1. - currentCharIsAlphaNumericOrColon _ currentPos > 0 and: [ model textSize >= currentPos and: [ - currentChar _ model actualContents at: currentPos. currentChar isAlphaNumeric | (currentChar == $:) ]]. - keyValue _ kbEvent keyValue. - keyChar _ kbEvent keyCharacter. - ctrl _ kbEvent controlKeyPressed. - cmd _ kbEvent commandAltKeyPressed. - tab _ keyChar = Character tab. - colon _ keyChar = $:. - alphanum _ kbEvent keyCharacter isAlphaNumeric. - backspace _ keyValue = 8. - esc _ keyValue = 27. - space _ #(0 32 160) includes: keyValue. - return _ kbEvent isReturnKey. - - "Stuff to do if the menu is not open" - menuMorph ifNil: [ - "Ctrl-Space or Tab for open" - "Mac specific note: Using option-space (actually option+160) effectively disables the non-breaking space character 160" - (space & (ctrl | kbEvent rawMacOptionKeyPressed) or: [ - (self opensWithTab and: [tab]) and: [ currentCharIsAlphaNumericOrColon ]]) - ifTrue: [ self openCompletionMenu. ^ true]. - "Auto-open - currently deactivated" -" (ctrl not & cmd not & alphanum) - ifTrue: [ self openCompletionMenu ]." - ^ false]. - - "Starting here, stuff to do if the menu is open" - menuMorph stillActive. - "Escape" - esc ifTrue: [ self closeMenu. ^ true]. - "Backspace" - backspace ifTrue: [ - currentCharIsAlphaNumericOrColon ifFalse: [ self closeMenu ]. - ^ false]. - "Home" - keyValue = 1 ifTrue: [ menuMorph goHome. ^ true ]. - "End" - keyValue = 4 ifTrue: [ menuMorph goToEnd. ^ true]. - "?" - keyChar = $? ifTrue: [ menuMorph help. ^true]. - "Arrow up" - keyValue = 30 ifTrue: [ menuMorph goUp. ^ true]. - "Arrow down" - keyValue = 31 ifTrue: [ menuMorph goDown. ^ true]. - "Page up" - keyValue = 11 ifTrue: [ menuMorph goPageUp. ^ true]. - "Page down" - keyValue = 12 ifTrue: [ menuMorph goPageDown. ^ true]. - "Return, Tab or Ctrl-Space" - (return or: [ space & (ctrl | kbEvent rawMacOptionKeyPressed) or: [ tab]]) ifTrue: [ - self insertSelected - ifTrue: [^ true]]. - "All keys but the alphanumeric chars (without command and control ) - and the backspace key do close the menu" - (ctrl not & cmd not and: [ alphanum | colon]) - ifFalse: [ self closeMenu ]. - ^false! ! - -SmalltalkEditor removeSelector: #argAdvance:! - -SmalltalkEditor removeSelector: #argAdvance:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3437-NextArgument-PreviousArgument-JuanVuletich-2018Sep06-18h13m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3437] on 10 September 2018 at 9:12:16 am'! -!Time class methodsFor: 'smalltalk-80' stamp: 'jmv 9/10/2018 09:11:34' prior: 16937449! - readFrom: aStream - "Read a Time from the stream in the form: - :: - - , or may be omitted. e.g. 1:59:30 pm; 8AM; 15:30" - - | hour minute second ampm nanos nanosBuffer | - hour := Integer readFrom: aStream. - minute := 0. - second := 0. - nanosBuffer := '000000000' copy. - nanos := WriteStream on: nanosBuffer. - (aStream peekFor: $:) - ifTrue: [ - minute := Integer readFrom: aStream. - (aStream peekFor: $:) - ifTrue: [ - second := Integer readFrom: aStream]. - (aStream peekFor: $.) - ifTrue: [ - [aStream atEnd not and: [aStream peek isDigit]] - whileTrue: [nanos nextPut: aStream next]]]. - aStream skipSeparators. - (aStream atEnd not and: [aStream peek isLetter]) ifTrue: - [ampm := aStream next asLowercase. - - (ampm = $p and: [hour < 12]) ifTrue: [hour := hour + 12]. - (ampm = $a and: [hour = 12]) ifTrue: [hour := 0]. - - (aStream peekFor: $m) ifFalse: [aStream peekFor: $M ]]. - ^ self - hour: hour - minute: minute - second: second - nanoSecond: nanosBuffer asNumber - - "Time readFrom: (ReadStream on: '2:23:09 pm')"! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3438-Avoid-String-asInteger-JuanVuletich-2018Sep10-09h10m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3437] on 10 September 2018 at 9:10:09 am'! - -ImageReadWriter removeSelector: #space! - -ImageReadWriter removeSelector: #space! - -ImageReadWriter removeSelector: #tab! - -ImageReadWriter removeSelector: #tab! - -Stream removeSelector: #nextNumber! - -Stream removeSelector: #nextNumber! - -Stream removeSelector: #nextNumber:! - -Stream removeSelector: #nextNumber:! - -Stream removeSelector: #nextNumber:put:! - -Stream removeSelector: #nextNumber:put:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3439-Cleanup-JuanVuletich-2018Sep10-09h04m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3439] on 10 September 2018 at 9:16:29 am'! -!Integer class methodsFor: 'instance creation' stamp: 'GC 9/10/2018 00:18:57' prior: 50331667! - readFrom: aStream base: base - "Answer an instance of one of my concrete subclasses. Initial minus sign - accepted, and bases > 10 use letters A-Z. Embedded radix specifiers not - allowed--use Number readFrom: for that. Raises an error if - there are no digits." - - | digit value neg cc atLeastOneDigitRead | - - (aStream atEnd) ifTrue: [ self error: 'At least one digit expected here' ]. - - neg _ aStream peekFor: $-. - neg ifFalse: [aStream peekFor: $+]. - value _ 0. - atLeastOneDigitRead _ false. - [ aStream atEnd ] - whileFalse: [ - cc _ aStream next. - digit _ cc digitValue. - (digit < 0 or: [digit >= base]) - ifTrue: [ - aStream skip: -1. - atLeastOneDigitRead ifFalse: [self error: 'At least one digit expected here']. - ^neg - ifTrue: [value negated] - ifFalse: [value]]. - value _ value * base + digit. - atLeastOneDigitRead _ true ]. - neg ifTrue: [^ value negated]. - ^ value! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3440-Integer-readFrom-ErrorIfEmpty-GastonCaruso-2018Sep10-09h16m-GC.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3437] on 10 September 2018 at 10:25:41 am'! -!TestSuite class methodsFor: 'Creation - Private' stamp: 'jmv 9/10/2018 10:24:54' prior: 50338365! -forTestCaseClasses: testCaseClasses named: aName - - | suite | - suite _ self named: aName. - testCaseClasses do: [ :aTestCaseClass | - aTestCaseClass isAbstract - ifFalse: [ aTestCaseClass addToSuiteFromSelectors: suite ]]. - - ^suite! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3441-TestSystemCategory-fix-JuanVuletich-2018Sep10-10h16m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3440] on 10 September 2018 at 12:01:49 pm'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 9/10/2018 12:01:33' prior: 50401198! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3442-AddGastonAsAuthor-JuanVuletich-2018Sep10-10h35m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3442] on 16 September 2018 at 10:20:05 am'! -!PseudoClass methodsFor: 'accessing' stamp: 'JO 9/16/2018 10:19:39'! - variablesAndOffsetsDo: aBinaryBlock - "NOp"! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3443-PackageFileBrowserFix-JavierOlaechea-2018Sep16-10h19m-JO.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3443] on 16 September 2018 at 10:48:40 am'! -!Theme methodsFor: 'icons' stamp: 'jmv 9/16/2018 10:45:54'! - resizeBottomIcon - ^nil! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/16/2018 10:46:11'! - resizeBottomLeftIcon - ^nil! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/16/2018 10:46:15'! - resizeBottomRightIcon - ^nil! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/16/2018 10:45:41'! - resizeFullIcon - ^nil! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/16/2018 10:45:50'! - resizeLeftIcon - ^nil! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/16/2018 10:45:59'! - resizeRightIcon - ^nil! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/16/2018 10:45:46'! - resizeTopIcon - ^nil! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/16/2018 10:46:03'! - resizeTopLeftIcon - ^nil! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/16/2018 10:46:07'! - resizeTopRightIcon - ^nil! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3444-PlaceholdersForResizeWindowIcons-JuanVuletich-2018Sep16-10h48m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3368] on 14 September 2018 at 9:47:11 pm'! - -BorderedRectMorph subclass: #TileResizeMorph - instanceVariableNames: 'selectedResize selectionColor action' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #TileResizeMorph category: #'Morphic-Views'! -BorderedRectMorph subclass: #TileResizeMorph - instanceVariableNames: 'selectedResize selectionColor action' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! -!Preferences class methodsFor: 'get/set' stamp: 'MM 9/14/2018 10:03:28'! - disableTileResizerInWindowMenu - - Preferences disable: #tileResizerInWindowMenu.! ! -!Preferences class methodsFor: 'get/set' stamp: 'MM 9/14/2018 10:03:16'! - enableTileResizerInWindowMenu - - Preferences enable: #tileResizerInWindowMenu.! ! -!TileResizeMorph methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 09:40:43'! - action: aBlock - action _ aBlock! ! -!TileResizeMorph methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 11:34:14'! - drawOn: aCanvas - - super drawOn: aCanvas. - - selectedResize ifNil: [^ self]. - - aCanvas fillRectangle: (self selectionRectangle: selectedResize) - color: selectionColor - borderWidth: borderWidth - borderStyleSymbol: #simple - baseColorForBorder: borderColor.! ! -!TileResizeMorph methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 09:41:56'! - handlesMouseDown: aMouseButtonEvent - - ^ true! ! -!TileResizeMorph methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 09:44:47'! - handlesMouseHover - ^ true! ! -!TileResizeMorph methodsFor: 'as yet unclassified' stamp: 'MM 9/14/2018 18:08:50'! - initialize - - super initialize. - extent _ 120@60. - color _ Color white. - selectionColor _ Color lightYellow . - self borderColor: Color black. - self borderWidth: 1.! ! -!TileResizeMorph methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 11:20:20'! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - self selectResize: localEventPosition! ! -!TileResizeMorph methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 11:20:57'! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - self selectResize: localEventPosition. - action ifNotNil: [ - action value: selectedResize. - self delete]! ! -!TileResizeMorph methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 11:10:21'! - mouseHover: aMouseButtonEvent localPosition: localEventPosition - self selectResize: localEventPosition! ! -!TileResizeMorph methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 11:37:24'! - resizeAtPoint: aPoint - - |region| - - region _ (aPoint min: extent - 1) // (extent // 3). - - ^ region caseOf: { - [0@0] -> [#topLeft]. - [1@0] -> [#top]. - [2@0] -> [#topRight]. - [0@1] -> [#left]. - [1@1] -> [#full]. - [2@1] -> [#right]. - [0@2] -> [#bottomLeft]. - [1@2] -> [#bottom]. - [2@2] -> [#bottomRight]. - } otherwise: [nil]! ! -!TileResizeMorph methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 11:03:57'! - selectResize: localEventPosition - - | newResize | - - newResize _ self resizeAtPoint: localEventPosition. - newResize ~= selectedResize ifTrue: [ - selectedResize _ newResize. - self redrawNeeded]! ! -!TileResizeMorph methodsFor: 'as yet unclassified' stamp: 'MM 9/14/2018 18:10:14'! - selectionColor: aColor - - selectionColor _ aColor! ! -!TileResizeMorph methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 11:33:29'! - selectionRectangle: region - - ^ region caseOf: { - [#topLeft] -> [0@0 corner: (extent // 2)]. - [#top] -> [0@0 corner: (extent x@(extent y // 2))]. - [#topRight] -> [(extent x // 2)@0 corner: (extent x@(extent y // 2))]. - [#left] -> [0@0 corner: (extent x // 2)@extent y]. - [#full] -> [0@0 corner: extent]. - [#right] -> [(extent x // 2)@0 corner: extent]. - [#bottomLeft] -> [0@(extent y // 2) corner: (extent x // 2)@extent y]. - [#bottomRight] -> [(extent x // 2)@(extent y // 2) corner: extent]. - [#bottom] -> [0@(extent y // 2) corner: extent]. - }! ! -!TileResizeMorph class methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 16:11:37'! - calculateTileRegions: aNumber - - ^ self calculateTileRegionsIn: Display boundingBox by: aNumber! ! -!TileResizeMorph class methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 18:25:19'! - calculateTileRegionsHorizontallyIn: aRectangle by: aNumber - - | rects rects1 rects2 | - aNumber <= 2 ifTrue: [^ self divideRectHorizontally: aRectangle by: aNumber]. - - rects _ self divideRectHorizontally: aRectangle by: 2. - - rects1 _ self calculateTileRegionsVerticallyIn: rects first by: aNumber // 2. - rects2 _ self calculateTileRegionsVerticallyIn: rects second by: (aNumber - (aNumber // 2)). - - ^ rects1, rects2! ! -!TileResizeMorph class methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 16:13:08'! - calculateTileRegionsIn: aRectangle by: aNumber - - ^ self calculateTileRegionsHorizontallyIn: aRectangle by: aNumber! ! -!TileResizeMorph class methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 16:20:53'! - calculateTileRegionsVerticallyIn: aRectangle by: aNumber - - | rects rects1 rects2 | - aNumber <= 3 ifTrue: [^ self divideRectVertically: aRectangle by: aNumber]. - - rects _ self divideRectVertically: aRectangle by: 2. - - rects1 _ self calculateTileRegionsHorizontallyIn: rects first by: aNumber // 2. - rects2 _ self calculateTileRegionsHorizontallyIn: rects second by: (aNumber - (aNumber // 2)). - - ^ rects1, rects2! ! -!TileResizeMorph class methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 16:08:58'! - divideRectHorizontally: aRectangle by: aNumber - - | w x rects | - - x _ aRectangle origin x. - w _ aRectangle width // aNumber. - rects _ OrderedCollection new. - - aNumber timesRepeat: [ |rect| - rect _ Rectangle origin: x@aRectangle origin y extent: w@aRectangle height. - x _ x + w. - rects add: rect]. - - ^ rects - - ! ! -!TileResizeMorph class methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 16:10:57'! - divideRectVertically: aRectangle by: aNumber - - | h y rects | - - y _ aRectangle origin y. - h _ aRectangle height // aNumber. - rects _ OrderedCollection new. - - aNumber timesRepeat: [ |rect| - rect _ Rectangle origin: aRectangle origin x@y extent: aRectangle width@h. - y _ y + h. - rects add: rect]. - - ^ rects - - ! ! -!TileResizeMorph class methodsFor: 'as yet unclassified' stamp: 'MM 9/14/2018 10:01:07'! - initialize - - Preferences - addPreference: #tileResizerInWindowMenu - category: #gui - default: true - balloonHelp: 'If enabled, a tile resizer morph is embedded in windows menus.' withNewLines! ! -!TileResizeMorph class methodsFor: 'as yet unclassified' stamp: 'MM 9/13/2018 15:59:18'! - tileOpenWindows - - |windows regions i | - - windows _ (SystemWindow - windowsIn: self runningWorld - satisfying: [ :w | w visible]). - - regions _ self calculateTileRegions: windows size. - - i _ 1. - windows do: [:w | |r| - r _ regions at: i. - w resize: r. - i _ i + 1]! ! -!SystemWindow methodsFor: 'menu' stamp: 'MM 9/14/2018 18:21:38' prior: 50399917! - buildWindowMenu - - | aMenu | - - aMenu _ MenuMorph new defaultTarget: self. - - aMenu - add: 'change title...' action: #relabel icon: #saveAsIcon; - add: 'window color...' action: #setWindowColor icon: #graphicsIcon; - addLine; - add: 'send to back' action: #sendToBack icon: #goBottomIcon; - add: 'make next-to-topmost' action: #makeSecondTopmost icon: #goUpIcon; - addLine; - add: (self isSticky ifTrue: [ 'make draggable' ] ifFalse: [ 'make undraggable' ]) - action: #toggleStickiness icon: (self isSticky ifFalse: [#pushPinIcon]); - addLine; - add: 'close' action: #delete icon: #closeIcon; - add: 'collapse' action: #collapse icon: #collapseIcon; - add: 'expand / contract' action: #expandBoxHit icon: #expandIcon; - addLine; - add: 'resize...' action: #resize. - "We can look at preferences here to decide what too do" - (Preferences tileResizerInWindowMenu) ifFalse: [ - aMenu add: 'resize full' action: #resizeFull icon: #resizeFullIcon; - add: 'resize top' action: #resizeTop icon: #resizeTopIcon; - add: 'resize left' action: #resizeLeft icon: #resizeLeftIcon; - add: 'resize bottom' action: #resizeBottom icon: #resizeBottomIcon; - add: 'resize right' action: #resizeRight icon: #resizeRightIcon; - add: 'resize top left' action: #resizeTopLeft icon: #resizeTopLeftIcon; - add: 'resize top right' action: #resizeTopRight icon: #resizeTopRightIcon; - add: 'resize bottom left' action: #resizeBottomLeft icon: #resizeBottomLeftIcon; - add: 'resize bottom right' action: #resizeBottomRight icon: #resizeBottomRightIcon] - ifTrue: [ |resizeMorph| - "Use embedded resize morph" - resizeMorph _ TileResizeMorph new - selectionColor: (self widgetsColor adjustSaturation: -0.2 brightness: 0.25) ; - action: [:resize | |resizeMsg| - resizeMsg _ ('resize', resize asString capitalized) asSymbol. - self perform: resizeMsg. - aMenu delete]; - yourself. - aMenu addMorphBack: resizeMorph]. - - ^ aMenu! ! -!TheWorldMenu methodsFor: 'windows & flaps menu' stamp: 'MM 9/14/2018 21:42:58' prior: 50397138! - windowsMenu - "Build the windows menu for the world." - - ^ (self menu: 'Windows') - addItemsFromDictionaries: `{ - { - #label -> 'Find Window'. - #object -> #myWorld. - #selector -> #findWindow:. - #icon -> #windowIcon. - #balloonText -> 'Presents a list of all windows; if you choose one from the list, it becomes the active window.' - } asDictionary. - { - #label -> 'Find changed Browsers...'. - #object -> #myWorld. - #selector -> #findDirtyBrowsers:. - #icon -> #editFindReplaceIcon. - #balloonText -> 'Presents a list of browsers that have unsubmitted changes; if you choose one from the list, it becomes the active window.' - } asDictionary. - { - #label -> 'Find changed Windows...'. - #object -> #myWorld. - #selector -> #findDirtyWindows:. - #icon -> #newWindowIcon. - #balloonText -> 'Presents a list of all windows that have unsubmitted changes; if you choose one from the list, it becomes the active window.' - } asDictionary. - nil. - { - #label -> 'Find a Transcript'. - #object -> #myWorld. - #selector -> #findATranscript:. - #icon -> #printerIcon. - #balloonText -> 'Brings an open Transcript to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find a FileList'. - #object -> #myWorld. - #selector -> #findAFileList:. - #icon -> #systemFileManagerIcon. - #balloonText -> 'Brings an open fileList to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find a Change Sorter'. - #object -> #myWorld. - #selector -> #findAChangeSorter:. - #icon -> #changesIcon. - #balloonText -> 'Brings an open change sorter to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find Message Names'. - #object -> #myWorld. - #selector -> #findAMessageNamesWindow:. - #icon -> #inspectIcon. - #balloonText -> 'Brings an open MessageNames window to the front, creating one if necessary, and makes it the active window' - } asDictionary. - nil. - { - #label -> 'Tile open windows'. - #object -> TileResizeMorph. - #selector -> #tileOpenWindows. - #icon -> #windowIcon. - #balloonText -> 'Tile open windows'. - } asDictionary. - { - #label -> 'Collapse all Windows'. - #object -> #myWorld. - #selector -> #collapseAll. - #icon -> #collapseIcon. - #balloonText -> 'Reduce all open windows to collapsed forms that only show titles.' - } asDictionary. - { - #label -> 'Restore all Windows'. - #object -> #myWorld. - #selector -> #restoreAll. - #icon -> #expandIcon. - #balloonText -> 'Restore all collapsed windows back to their previous forms.' - } asDictionary. - { - #label -> 'Close top Window'. - #object -> SystemWindow. - #selector -> #closeTopWindow. - #icon -> #closeIcon. - #balloonText -> 'Close the topmost window if possible.' - } asDictionary. - { - #label -> 'Send top Window to back'. - #object -> SystemWindow. - #selector -> #sendTopWindowToBack. - #icon -> #goBottomIcon. - #balloonText -> 'Make the topmost window become the backmost one, and activate the window just beneath it.' - } asDictionary. - { - #label -> 'Move Windows onscreen'. - #object -> #myWorld. - #selector -> #bringWindowsFullOnscreen. - #icon -> #displayIcon. - #balloonText -> 'Make all windows fully visible on the screen' - } asDictionary. - nil. - { - #label -> 'Delete unchanged Windows'. - #object -> #myWorld. - #selector -> #closeUnchangedWindows. - #icon -> #warningIcon. - #balloonText -> 'Deletes all windows that do not have unsaved text edits.' - } asDictionary. - { - #label -> 'Delete non Windows'. - #object -> #myWorld. - #selector -> #deleteNonWindows. - #icon -> #warningIcon. - #balloonText -> 'Deletes all non-window morphs lying on the world.' - } asDictionary. - { - #label -> 'Delete Both of the Above'. - #selector -> #cleanUpWorld. - #icon -> #warningIcon. - #balloonText -> 'Deletes all unchanged windows and also all non-window morphs lying on the world, other than flaps.' - } asDictionary. - }`! ! - -TileResizeMorph initialize! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3445-TileWindowResize-MarianoMontone-2018Sep13-01h34m-MM.4.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3430] on 18 September 2018 at 5:08:42 pm'! -!Stream methodsFor: 'nonhomogeneous accessing' stamp: 'jmv 9/18/2018 17:08:36'! - nextNumber - "Answer a number from the (text) stream." - - |element| - [(element := self next) isNil or: [element isDigit or: [element = $- or: [element = $)]]]] whileFalse. - element ifNil: [^nil]. - self skip: -1. - element = $) ifTrue: [^nil]. - ^Number readFrom: self! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3446-Reintroduce-Stream-nextNumber-JuanVuletich-2018Sep18-17h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3445] on 17 September 2018 at 5:37:57 pm'! -!TileResizeMorph class methodsFor: 'as yet unclassified' stamp: 'MM 9/17/2018 17:36:57' prior: 50413240! - tileOpenWindows - - |windows regions i | - - windows _ (SystemWindow - windowsIn: self runningWorld - satisfying: [ :w | w visible]). - - windows ifEmpty: [^ self]. - - regions _ self calculateTileRegions: windows size. - - i _ 1. - windows do: [:w | |r| - r _ regions at: i. - w resize: r. - i _ i + 1]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3447-tileWindowsFixWhenNoWindows-MarianoMontone-2018Sep17-17h36m-MM.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3430] on 19 September 2018 at 10:17:16 am'! -!ContentPack methodsFor: 'exporting' stamp: 'jmv 9/19/2018 10:08:59' prior: 16823316! - exportInto: aDirectory - - aDirectory assureExistence. - - self associations do: [ :assoc | - | klass thisDirectory fullPath | - klass _ assoc value class. - thisDirectory _ aDirectory / assoc key. - fullPath _ (aDirectory // assoc key) pathName. - - self flag: #note. "Add support for new file export type mappings here. --cbr" - klass = ContentPack - ifTrue: [ assoc value exportInto: thisDirectory ]. - - klass = ColorForm - ifTrue: [ assoc value writeBMPfileNamed: fullPath ]. - - klass = Form - ifTrue: [ assoc value writeBMPfileNamed: fullPath ] - ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3448-ContentPackFix-JuanVuletich-2018Sep19-10h16m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3430] on 19 September 2018 at 10:17:34 am'! -!FileIOAccessor methodsFor: 'private' stamp: 'jmv 9/19/2018 10:17:18' prior: 16841766! - basicDirectoryExists: fullPathName - - | result | - result := self primLookupEntryIn: fullPathName index: 1. - result ifNil: [ ^ false ]. - ^(result == #badDirectoryPath) not! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3449-basicDirectoryExists-fix-JuanVuletich-2018Sep19-10h17m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3449] on 21 September 2018 at 5:02:42 pm'! -!ContentPack methodsFor: 'importing' stamp: 'jmv 9/21/2018 16:13:27'! - loadContentFrom: aDirectoryEntry - - | contentPacks | - - (self supportedFilesIn: aDirectoryEntry) do: [ :filename | - self flag: #todo. "Add hook for other media types here. Also consider renaming this method. --cbr" - self at: filename name - put: (self import: [ Form fromFileEntry: filename ]) "This may yet be a cross-cutting concern, and need to be refactored when other media types become present. --cbr" - ]. - - contentPacks _ aDirectoryEntry directoryNames collect: [ :i | - i -> (ContentPack new loadContentFrom: aDirectoryEntry / i) - ]. - - ^ self union: (contentPacks as: Dictionary)! ! -!ContentPack class methodsFor: 'instance creation' stamp: 'jmv 9/21/2018 16:30:21'! - import - " - Feature require: 'Graphics-Files-Additional'. - Theme content export. - ContentPack import. - Theme bootstrap. - " - - ^ self new loadContentFrom: self exportDirectory! ! -!ContentPack class methodsFor: 'configuration' stamp: 'jmv 9/21/2018 16:07:27'! - exportDirectory - - ^ DirectoryEntry smalltalkImageDirectory / self defaultContentDirectory / 'Exported'! ! -!ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'jmv 9/21/2018 16:56:49'! - putForm: aForm onFile: fileEntry - "Store the given form on a file of the given name." - - fileEntry forceWriteStreamDo: [ :stream | - (self onBinaryStream: stream binary) nextPutImage: aForm ]! ! -!ContentPack methodsFor: 'exporting' stamp: 'jmv 9/21/2018 16:07:38' prior: 16823304! - export - - "Answer true on success." - - "self break." - - self class exportDirectory exists - ifTrue: [ Utilities inform: - 'Before you can export, you must move, rename or delete this directory: ' , - self exportDirectory pathName. - - ^ false. - ]. - - self exportInto: self class exportDirectory. - - ^ true! ! -!ContentPack methodsFor: 'exporting' stamp: 'jmv 9/21/2018 16:58:00' prior: 50413512! - exportInto: aDirectory - - | featureName | - featureName _ 'Graphics-Files-Additional'. - (FeatureRequirement name: featureName) isAlreadySatisfied - ifFalse: [ - self error: 'Please load "', featureName, '".']. - - aDirectory assureExistence. - - self associations do: [ :assoc | - | klass thisDirectory fullPath | - klass _ assoc value class. - thisDirectory _ aDirectory / assoc key. - fullPath _ aDirectory // assoc key. - - self flag: #note. "Add support for new file export type mappings here. --cbr" - klass = ContentPack - ifTrue: [ assoc value exportInto: thisDirectory ]. - - klass = ColorForm - ifTrue: [ assoc value writePNGfile: fullPath ]. - - klass = Form - ifTrue: [ assoc value writePNGfile: fullPath ] - ]! ! -!ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'jmv 9/21/2018 16:56:41' prior: 16854489! - putForm: aForm onFileNamed: filename - "Store the given form on a file of the given name." - - self putForm: aForm onFile: filename asFileEntry! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/21/2018 16:24:43' prior: 50412997! - resizeBottomIcon - " - Theme current resizeBottomIcon - " - ^ self fetch: #( '16x16' 'resize' 'resize-bottom' )! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/21/2018 16:25:13' prior: 50413000! - resizeBottomLeftIcon - " - Theme current resizeBottomLeftIcon - " - ^ self fetch: #( '16x16' 'resize' 'resize-bottom-left' )! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/21/2018 16:25:35' prior: 50413003! - resizeBottomRightIcon - " - Theme current resizeBottomRightIcon - " - ^ self fetch: #( '16x16' 'resize' 'resize-bottom-right' )! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/21/2018 16:28:59' prior: 50413006! - resizeFullIcon - " - Theme current resizeFullIcon - " - ^ self fetch: #( '16x16' 'resize' 'resize' )! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/21/2018 16:26:03' prior: 50413009! - resizeLeftIcon - " - Theme current resizeLeftIcon - " - ^ self fetch: #( '16x16' 'resize' 'resize-left' )! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/21/2018 16:26:25' prior: 50413012! - resizeRightIcon - " - Theme current resizeRightIcon - " - ^ self fetch: #( '16x16' 'resize' 'resize-right' )! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/21/2018 16:26:43' prior: 50413015! - resizeTopIcon - " - Theme current resizeTopIcon - " - ^ self fetch: #( '16x16' 'resize' 'resize-top' )! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/21/2018 16:27:13' prior: 50413018! - resizeTopLeftIcon - " - Theme current resizeTopLeftIcon - " - ^ self fetch: #( '16x16' 'resize' 'resize-top-left' )! ! -!Theme methodsFor: 'icons' stamp: 'jmv 9/21/2018 16:27:17' prior: 50413021! - resizeTopRightIcon - " - Theme current resizeTopRightIcon - " - ^ self fetch: #( '16x16' 'resize' 'resize-top-right' )! ! -!Theme methodsFor: 'icon lookup' stamp: 'jmv 9/21/2018 16:21:17' prior: 50399888! - fetch: aTuple " #( 'resolution' 'context' 'filename' ) " - - "Get an icon from Content. See icons protocol." - - | contentSpecifier icon themeGuess | - - icon _ nil. - themeGuess _ self class. - contentSpecifier _ self appendExtensionToContentSpec: aTuple. - - [ icon isNil ] - whileTrue: [ - icon _ self class content - from: themeGuess name - get: contentSpecifier. - - icon ifNotNil: [ ^ icon ]. - - themeGuess = Theme - ifTrue: [ ^ nil "See comment in ContentPack>>from:get: --cbr" ]. - - themeGuess _ themeGuess superclass - ]! ! -!Theme class methodsFor: 'importing/exporting' stamp: 'jmv 9/21/2018 16:08:35' prior: 16936871! - bootstrap - - "Destructive. Loads up initial content." - self flag: #todo. "Consider removal. --cbr" - - Content _ ContentPack import! ! - -ContentPack class removeSelector: #default! - -ContentPack class removeSelector: #default! - -ContentPack removeSelector: #exportDirectory! - -ContentPack removeSelector: #exportDirectory! - -ContentPack removeSelector: #path:! - -ContentPack removeSelector: #path:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3450-ContentPack-fixes-JuanVuletich-2018Sep21-17h01m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3450] on 22 September 2018 at 3:33:36 pm'! -!Number class methodsFor: 'instance creation' stamp: 'jmv 9/22/2018 09:01:25' prior: 16880670! - readRemainderOf: integerPart from: aStream base: base withSign: sign - "Read optional fractional part and exponent, and return the final result" - | value fraction fracpos peekChar | - - value := integerPart. - (aStream peekFor: $.) - ifTrue: [ "." - (aStream atEnd not and: [ aStream peek digitValue between: 0 and: base - 1 ]) - ifTrue: [ - fracpos := aStream position. - fraction := Integer readFrom: aStream base: base. - fraction := fraction / (base raisedTo: aStream position - fracpos). - value := value asFloat + fraction] - ifFalse: [ - "oops - just ." - aStream skip: -1. - "un-gobble the period" - ^ value * sign"Number readFrom: '3r-22.2'"]]. - peekChar := aStream peek. - peekChar = $e | (peekChar = $d) | (peekChar = $q) - ifTrue: [ "(e|d|q)>" - aStream next. - (aStream atEnd not and: [ (aStream peek digitValue between: 0 and: 9) or: [ aStream peek = $- ]]) - ifTrue: [ - value := value * (base raisedTo: (Integer readFrom: aStream)) ] - ifFalse: [ - "oops - just ." - aStream skip: -1.]]. - ^(value isFloat - and: [ value = 0.0 and: [ sign = -1 ]]) - ifTrue: [ Float negativeZero ] - ifFalse: [ value * sign ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3451-NumberFromString-fix-JuanVuletich-2018Sep22-15h33m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3451] on 24 September 2018 at 11:00:42 am'! -!Number class methodsFor: 'instance creation' stamp: 'jmv 9/24/2018 11:00:21' prior: 50413750! - readRemainderOf: integerPart from: aStream base: base withSign: sign - "Read optional fractional part and exponent, and return the final result" - | value fraction fracpos peekChar exp scale | - - value := integerPart. - (aStream peekFor: $.) - ifTrue: [ "." - (aStream atEnd not and: [ aStream peek digitValue between: 0 and: base - 1 ]) - ifTrue: [ - fracpos := aStream position. - fraction := Integer readFrom: aStream base: base. - fraction := fraction / (base raisedToInteger: aStream position - fracpos). - value := value asFloat + fraction] - ifFalse: [ - "oops - just ." - aStream skip: -1. - "un-gobble the period" - ^ value * sign"Number readFrom: '3r-22.2'"]]. - peekChar := aStream peek. - peekChar = $e | (peekChar = $d) | (peekChar = $q) - ifTrue: [ "(e|d|q)>" - aStream next. - (aStream atEnd not and: [ (aStream peek digitValue between: 0 and: 9) or: [ aStream peek = $- ]]) - ifTrue: [ - exp := Integer readFrom: aStream. - scale := base raisedToInteger: exp. - value := (value isFloat and: [ scale asFloat < Float fminNormalized ]) - ifTrue: [ - "Avoid Float arithmetic to allow stuff like - 12345678901234567890.0e-330 - (Float fminNormalized / 10) storeString asNumber = ((Float fminNormalized / 10)) - " - (value asTrueFraction * scale) asFloat ] - ifFalse: [ value * scale ] ] - ifFalse: [ - "oops - just ." - aStream skip: -1.]]. - ^(value isFloat - and: [ value = 0.0 and: [ sign = -1 ]]) - ifTrue: [ Float negativeZero ] - ifFalse: [ value * sign ]! ! -!Float methodsFor: 'printing' stamp: 'jmv 9/24/2018 10:31:30' prior: 16845315! -absPrintExactlyOn: aStream base: base - "Print my value on a stream in the given base. Assumes that my value is strictly - positive; negative numbers, zero, and NaNs have already been handled elsewhere. - Based upon the algorithm outlined in: - Robert G. Burger and R. Kent Dybvig - Printing Floating Point Numbers Quickly and Accurately - ACM SIGPLAN 1996 Conference on Programming Language Design and Implementation - June 1996. - This version guarantees that the printed representation exactly represents my value - by using exact integer arithmetic." - - | significand exp baseExpEstimate r s mPlus mMinus scale roundingIncludesLimits d tc1 tc2 fixedFormat decPointCount slowbit shead | - self isInfinite ifTrue: [aStream nextPutAll: 'Infinity'. ^ self]. - significand := self significandAsInteger. - roundingIncludesLimits := significand even. - exp := (self exponent - 52) max: MinValLogBase2. - baseExpEstimate := (self exponent * base asFloat reciprocalLogBase2 - 1.0e-10) ceiling. - exp >= 0 - ifTrue: - [significand ~= 16r10000000000000 - ifTrue: - [r := significand bitShift: 1 + exp. - s := 2. - mPlus := mMinus := 1 bitShift: exp] - ifFalse: - [r := significand bitShift: 2 + exp. - s := 4. - mPlus := 2 * (mMinus := 1 bitShift: exp)]] - ifFalse: - [(exp = MinValLogBase2 or: [significand ~= 16r10000000000000]) & false - ifTrue: - "jmv 2018-9-24. Deactivated. Makes the following false (See Tests package):" - " - | float | - float _ (Float fminNormalized / 2) successor. - float storeString asNumber = float - " - [r := significand bitShift: 1. - s := 1 bitShift: 1 - exp. - mPlus := mMinus := 1] - ifFalse: - [r := significand bitShift: 2. - s := 1 bitShift: 2 - exp. - mPlus := 2. - mMinus := 1]]. - baseExpEstimate >= 0 - ifTrue: [s := s * (base raisedToInteger: baseExpEstimate)] - ifFalse: - [scale := base raisedToInteger: baseExpEstimate negated. - r := r * scale. - mPlus := mPlus * scale. - mMinus := mMinus * scale]. - ((r + mPlus < s) not and: [roundingIncludesLimits or: [r + mPlus > s]]) - ifTrue: [baseExpEstimate := baseExpEstimate + 1] - ifFalse: - [r := r * base. - mPlus := mPlus * base. - mMinus := mMinus * base]. - (fixedFormat := baseExpEstimate between: -3 and: 6) - ifTrue: - [decPointCount := baseExpEstimate. - baseExpEstimate <= 0 - ifTrue: [aStream nextPutAll: ('0.000000' truncateTo: 2 - baseExpEstimate)]] - ifFalse: - [decPointCount := 1]. - slowbit := 1 - s lowBit . - shead := s bitShift: slowbit. - [d := (r bitShift: slowbit) // shead. - r := r - (d * s). - (tc1 := (r > mMinus) not and: [roundingIncludesLimits or: [r < mMinus]]) | - (tc2 := (r + mPlus < s) not and: [roundingIncludesLimits or: [r + mPlus > s]])] whileFalse: - [aStream nextPut: (Character digitValue: d). - r := r * base. - mPlus := mPlus * base. - mMinus := mMinus * base. - decPointCount := decPointCount - 1. - decPointCount = 0 ifTrue: [aStream nextPut: $.]]. - tc2 ifTrue: - [(tc1 not or: [r * 2 >= s]) ifTrue: [d := d + 1]]. - aStream nextPut: (Character digitValue: d). - decPointCount > 0 - ifTrue: - [decPointCount - 1 to: 1 by: -1 do: [:i | aStream nextPut: $0]. - aStream nextPutAll: '.0']. - fixedFormat ifFalse: - [aStream nextPut: $e. - aStream nextPutAll: (baseExpEstimate - 1) printString]! ! -!Float methodsFor: 'printing' stamp: 'jmv 9/24/2018 10:56:53' prior: 50405041! - absPrintOn: aStream base: base - "In Cuis, print Floats with enough digits to be able to recover later exactly the same Float." - - self absPrintExactlyOn: aStream base: base! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3452-FloatStringConversionFixes-JuanVuletich-2018Sep24-09h04m-jmv.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3452] on 24 September 2018 at 1:41:19 pm'! -!Float methodsFor: 'printing' stamp: 'jmv 9/24/2018 13:40:33' prior: 50413852! - absPrintExactlyOn: aStream base: base - "Print my value on a stream in the given base. Assumes that my value is strictly - positive; negative numbers, zero, and NaNs have already been handled elsewhere. - Based upon the algorithm outlined in: - Robert G. Burger and R. Kent Dybvig - Printing Floating Point Numbers Quickly and Accurately - ACM SIGPLAN 1996 Conference on Programming Language Design and Implementation - June 1996. - https://www.cs.indiana.edu/~dyb/pubs/FP-Printing-PLDI96.pdf - This version guarantees that the printed representation exactly represents my value - by using exact integer arithmetic." - - | significand exp baseExpEstimate r s mPlus mMinus scale roundingIncludesLimits d tc1 tc2 fixedFormat decPointCount slowbit shead | - self isInfinite ifTrue: [aStream nextPutAll: 'Infinity'. ^ self]. - significand := self significandAsInteger. - roundingIncludesLimits := significand even. - exp := (self exponent - 52) max: MinValLogBase2. - baseExpEstimate := (self exponent * base asFloat reciprocalLogBase2 - 1.0e-10) ceiling. - exp >= 0 - ifTrue: - [significand ~= 16r10000000000000 - ifTrue: - [r := significand bitShift: 1 + exp. - s := 2. - mPlus := mMinus := 1 bitShift: exp] - ifFalse: - [r := significand bitShift: 2 + exp. - s := 4. - mPlus := 2 * (mMinus := 1 bitShift: exp)]] - ifFalse: - [(exp = MinValLogBase2 or: [significand ~= 16r10000000000000]) - ifTrue: - [r := significand bitShift: 1. - s := 1 bitShift: 1 - exp. - mPlus := mMinus := 1] - ifFalse: - [r := significand bitShift: 2. - s := 1 bitShift: 2 - exp. - mPlus := 2. - mMinus := 1]]. - baseExpEstimate >= 0 - ifTrue: [s := s * (base raisedToInteger: baseExpEstimate)] - ifFalse: - [scale := base raisedToInteger: baseExpEstimate negated. - r := r * scale. - mPlus := mPlus * scale. - mMinus := mMinus * scale]. - ((r + mPlus < s) not and: [roundingIncludesLimits or: [r + mPlus > s]]) - ifTrue: [baseExpEstimate := baseExpEstimate + 1] - ifFalse: - [r := r * base. - mPlus := mPlus * base. - mMinus := mMinus * base]. - (fixedFormat := baseExpEstimate between: -3 and: 6) - ifTrue: - [decPointCount := baseExpEstimate. - baseExpEstimate <= 0 - ifTrue: [aStream nextPutAll: ('0.000000' truncateTo: 2 - baseExpEstimate)]] - ifFalse: - [decPointCount := 1]. - slowbit := 1 - s lowBit . - shead := s bitShift: slowbit. - [d := (r bitShift: slowbit) // shead. - r := r - (d * s). - (tc1 := (r > mMinus) not and: [roundingIncludesLimits or: [r < mMinus]]) | - (tc2 := (r + mPlus < s) not and: [roundingIncludesLimits or: [r + mPlus > s]])] whileFalse: - [aStream nextPut: (Character digitValue: d). - r := r * base. - mPlus := mPlus * base. - mMinus := mMinus * base. - decPointCount := decPointCount - 1. - decPointCount = 0 ifTrue: [aStream nextPut: $.]]. - tc2 ifTrue: - [(tc1 not or: [r * 2 >= s]) ifTrue: [d := d + 1]]. - aStream nextPut: (Character digitValue: d). - decPointCount > 0 - ifTrue: - [decPointCount - 1 to: 1 by: -1 do: [:i | aStream nextPut: $0]. - aStream nextPutAll: '.0']. - fixedFormat ifFalse: - [aStream nextPut: $e. - aStream nextPutAll: (baseExpEstimate - 1) printString]! ! -!Float methodsFor: 'printing' stamp: 'jmv 9/24/2018 13:40:36' prior: 50404906! - absPrintOn: aStream base: base mantissaSignificantBits: significantBits - "Print my value on a stream in the given base. Assumes that my value is strictly - positive; negative numbers, zero, and NaNs have already been handled elsewhere. - Based upon the algorithm outlined in: - Robert G. Burger and R. Kent Dybvig - Printing Floating Point Numbers Quickly and Accurately - ACM SIGPLAN 1996 Conference on Programming Language Design and Implementation - June 1996. - https://www.cs.indiana.edu/~dyb/pubs/FP-Printing-PLDI96.pdf - This version performs all calculations with Floats instead of LargeIntegers, and loses - about 3 lsbs of accuracy compared to an exact conversion." - - | fBase exp baseExpEstimate r s mPlus mMinus scale d tc1 tc2 fixedFormat decPointCount | - self isInfinite ifTrue: [aStream nextPutAll: 'Infinity'. ^ self]. - fBase := base asFloat. - exp := self exponent. - baseExpEstimate := (exp * fBase reciprocalLogBase2 - 1.0e-10) ceiling. - exp >= 0 - ifTrue: - [r := self. - s := 1.0. - mPlus := 1.0 timesTwoPower: exp - significantBits. - mMinus := self significand ~= 1.0 ifTrue: [mPlus] ifFalse: [mPlus / 2.0]] - ifFalse: - [r := self timesTwoPower: significantBits. - s := 1.0 timesTwoPower: significantBits. - mMinus := 1.0 timesTwoPower: (exp max: -1024). - mPlus := - (exp = MinValLogBase2) | (self significand ~= 1.0) - ifTrue: [mMinus] - ifFalse: [mMinus * 2.0]]. - baseExpEstimate >= 0 - ifTrue: - [exp = 1023 - ifTrue: "scale down to prevent overflow to Infinity during conversion" - [r := r / fBase. - s := s * (fBase raisedToInteger: baseExpEstimate - 1). - mPlus := mPlus / fBase. - mMinus := mMinus / fBase] - ifFalse: - [s := s * (fBase raisedToInteger: baseExpEstimate)]] - ifFalse: - [exp < -1023 - ifTrue: "scale up to prevent denorm reciprocals overflowing to Infinity" - [d := (53 * fBase reciprocalLogBase2 - 1.0e-10) ceiling. - scale := fBase raisedToInteger: d. - r := r * scale. - mPlus := mPlus * scale. - mMinus := mMinus * scale. - scale := fBase raisedToInteger: (baseExpEstimate + d) negated] - ifFalse: - [scale := fBase raisedToInteger: baseExpEstimate negated]. - s := s / scale]. - (r + mPlus >= s) - ifTrue: [baseExpEstimate := baseExpEstimate + 1] - ifFalse: - [s := s / fBase]. - (fixedFormat := baseExpEstimate between: -3 and: 6) - ifTrue: - [decPointCount := baseExpEstimate. - baseExpEstimate <= 0 - ifTrue: [aStream nextPutAll: ('0.000000' truncateTo: 2 - baseExpEstimate)]] - ifFalse: - [decPointCount := 1]. - [d := (r / s) truncated. - r := r - (d * s). - (tc1 := r <= mMinus) | (tc2 := r + mPlus >= s)] whileFalse: - [aStream nextPut: (Character digitValue: d). - r := r * fBase. - mPlus := mPlus * fBase. - mMinus := mMinus * fBase. - decPointCount := decPointCount - 1. - decPointCount = 0 ifTrue: [aStream nextPut: $.]]. - tc2 ifTrue: - [tc1 not | (tc1 & (r*2.0 >= s)) ifTrue: [d := d + 1]]. - aStream nextPut: (Character digitValue: d). - decPointCount > 0 - ifTrue: - [decPointCount - 1 to: 1 by: -1 do: [:i | aStream nextPut: $0]. - aStream nextPutAll: '.0']. - fixedFormat ifFalse: - [aStream nextPut: $e. - aStream nextPutAll: (baseExpEstimate - 1) printString]! ! - -Float removeSelector: #absByteEncode:base:! - -Float removeSelector: #absByteEncode:base:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3453-FloatStringConversionStuff-JuanVuletich-2018Sep24-13h39m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3453] on 26 September 2018 at 11:48:12 am'! -!Float commentStamp: 'jmv 9/24/2018 20:52:43' prior: 50375942! - A note About Floating Point numbers and Floating Point Arithmetic. - -The following is not specific to Cuis or Smalltalk at all. This is about the properties of Float numbers in any computer implementation. - -If you haven't done so already, read https://en.wikipedia.org/wiki/Floating-point_arithmetic - -But if you find the Wikipedia article too detailed, or hard to read, then try http://fabiensanglard.net/floating_point_visually_explained/ (get past "How Floating Point are usually explained" and read "A different way to explain..."). - -Other great reads are: - "Why don't my numbers add up?": - http://floating-point-gui.de/ -and - "What Every Computer Scientist Should Know About Floating-Point Arithmetic": - http://docs.oracle.com/cd/E19957-01/806-3568/ncg_goldberg.html -and also maybe - "Comparing floating point numbers" - https://randomascii.wordpress.com/2012/02/25/comparing-floating-point-numbers-2012-edition/ - -Now that you read them, and we are on the same boat, some further comments (from jmv): - -Floats are (conceptually) approximate real numbers. That's why trig and other trascendental functions always answer Floats. That's why it is ok to round the result of operations. That's why Float is considered more general than Fraction in ST-80 and most Smalltalks. So, when we have a Float value, we must not think about it as a Rational but as a Real (actually as some unknown Real that could hopefully be close to the Rational we can actually represent). Keep this in mind when dealing with Floats, and especially avoid comparing them for equality. - -When doing mixed operations with Floats and Fractions, Cuis, as most other Smalltalks, converts all values to Floats. Some other systems, including Pharo Smalltalk, Scheme and Lisp have two rules: when the answer is a Number, they convert to Float. But when the answer is a boolean (#<, #=, #<=, etc.) they convert to Fraction. We think this is a mistake. There should never be implicit conversions from Float to Fraction. Fractions are to hold exact values, and people expect Fractions to be exact. On the other hand, Floats are to hold approximations (and people should be aware of that!!). But an implicit conversion from Float to Fraction would give a Fraction that should not be considered an exact value (the value comes from an inexact Float), but that knowledge is lost, as it is an instance of Fraction. - -If you want exact arithmetic, usual mathematical properties (like transitivity of equality), can live in the limited world of Rational numbers, and can afford a slight performance penalty, use Fraction instead. Avoid trascendental functions and never convert to Float. - -In any case, most numeric computation is done on Float numbers. There are good reasons for that. One is that in most cases we don't need an exact answer. And in many cases we can't really have it: the inputs to algorithms already have a limited precision, or they use trascendental functions. And even when exact arithmetic possible, if we are doing sound synthesis, 24 bits of resolution is enough. For image processing and graphics, the result is never more than 16 bits per channel. So, these fields don't really need 64 bit Doubles. 32 bit Floats are enough. Other fields do need 64 bit Doubles, like physics simulations and geometry. Games usually prefer special, faster 32 bit Float operations in GPUs that have greater errors but are faster. - -There are some things that can be done to increase the confidence you can have on Float results. One is to do an error propagation analysis on the code you are running. This is not easy, but it is done for any widely used numerical method. Then, you can know real bounds and/or estimates of the errors made. So, understanding your inputs and your algorithms (for example error propagation, condition number, numeric stability), and using Float number if appropriate, is the usual advice. - -Perhaps you have heard about "interval arithmetic". It is a bit better than simple Float, but doesn't really fix the problems. - -The ultimate solution is to do Monte Carlo analysis, with random perturbation of inputs. After the Monte Carlo run, it is needed to do statistical analysis of possible correlations between the distributions of the random noise added to imputs and the result of the algorithm. - -Additional food for thought: http://www.cs.berkeley.edu/~wkahan/Mindless.pdf . According to this, doing Monte Carlo as described above attacks a slightly different problem. This might be yet another reason (besides performance) to try something like the next paragraph. I (jmv) came up with it, and I don't really know if it has been described and or tried before or not. Mhhh. Maybe a defensive publication is in order. - -A possibility that could be a practical solution, being much cheaper than Monte Carlo, but better than interval arithmetic, is to represent each value by 2 Floats: an estimation of the real value (i.e. an estimation of the mean value of the distribution of the corresponding Monte Carlo result), and an estimation of the error (i.e. an estimation of the standard deviation of the corresponding Monte Carlo result). Or perhaps even 3 of them. In addition to the estimation of the real value and an estimation of the error, we could add a hard bound on the error. In many cases it will be useless, because the error can not really be bound. But in those cases where it is possible to bound it, applications could really know about the quality of computed values. - -======================================================================= - -My instances represent IEEE-754 floating-point double-precision numbers. They have about 16 decimal digits of accuracy and their range is between plus and minus 10^307. Some valid examples are: - - 8.0 13.3 0.3 2.5e6 1.27e-30 1.27e-31 -12.987654e12 - -Mainly: no embedded blanks, little e for tens power, and a digit on both sides of the decimal point. It is actually possible to specify a radix for Squeak Float constants. This is great for teaching about numbers, but may be confusing to the average reader: - - 3r20.2 --> 6.66666666666667 - 8r20.2 --> 16.25 - -If you don't have access to the definition of IEEE-754, you can figure out what is going on by printing various simple values in Float hex. It may help you to know that the basic format is... - sign 1 bit - exponent 11 bits with bias of 1023 (16r3FF) to produce an exponent - in the range -1023 .. +1024 - - 16r000: - significand = 0: Float zero - significand ~= 0: Denormalized number (exp = -1023 + 1 = -1022, no hidden '1' bit in mantissa) - - 16r7FF: - significand = 0: Infinity - significand ~= 0: Not A Number (NaN) representation - mantissa 53 bits, but only 52 are stored (20 in the first word, 32 in the second). This is because a normalized mantissa, by definition, has a 1 to the right of its floating point, and IEEE-754 omits this redundant bit to gain an extra bit of precision instead. People talk about the mantissa without its leading one as the FRACTION, and with its leading 1 as the SIGNFICAND. - -The single-precision format is... - sign 1 bit - exponent 8 bits, with bias of 127, to represent -126 to +127 - - 0x0 and 0xFF reserved for Float zero (mantissa is ignored) - - 16r7F reserved for Float underflow/overflow (mantissa is ignored) - mantissa 24 bits, but only 23 are stored -This format is used in FloatArray (qv), and much can be learned from the conversion routines, Float asIEEE32BitWord, and Float class fromIEEE32Bit:. - -You might also check https://en.wikipedia.org/wiki/IEEE_754_revision - -Other great reads (covering broader but interesting issues): -https://randomascii.wordpress.com/2013/07/16/floating-point-determinism/ -http://www.ima.umn.edu/2010-2011/W1.10-14.11/activities/Leeser-Miriam/Leeser-GPU-IMA-Jan2011.pdf! -!Float methodsFor: 'converting' stamp: 'jmv 9/26/2018 09:32:40' prior: 16844861! - asTrueFraction - " Answer a fraction that EXACTLY represents self, - a double precision IEEE floating point number. - By David N. Smith with significant performance - improvements by Luciano Esteban Notarfrancesco. - (Version of 11April97). - Refactoring and simplification by jmv" - - ^self - partValues: [ :sign :exponent :mantissa | | zeroBitsCount | - " Prepare result. If exponent is greater than mantissa size, result is an integer" - (exponent >= 52 or: [ - zeroBitsCount _ mantissa lowBit - 1. - exponent + zeroBitsCount >= 52 ]) - ifTrue: [ - "result is an integer number" - sign * mantissa bitShift: exponent - 52 ] - ifFalse: [ - " This is the 'obvious' way. Better do Luciano's trick below:" - "result := Fraction - numerator: sign * mantissa - denominator: (1 bitShift: 52 - exponent)." - " Form the result. When exp>52, the exponent is adjusted by - the number of trailing zero bits in the mantissa to minimize - the (huge) time could be spent in #gcd:. " - Fraction - numerator: (sign * (mantissa bitShift: 0 - zeroBitsCount)) - denominator: (1 bitShift: 52 - exponent - zeroBitsCount) ] - ] - ifInfinite: [ self error: 'Cannot represent infinity as a fraction' ] - ifNaN: [ self error: 'Cannot represent Not-a-Number as a fraction' ].! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 9/26/2018 11:31:38' prior: 16844982! - exponentPart - " - Exponent part of the Floating Point representation. - For any Floating Point number (except zeros, infinities and NaNs) - Includes correction of stored exponent bits for denormals (where it acts as a label, not a real exponent) - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. (f signPart * f significandAsInteger * (2 raisedToInteger: f exponentPart-52)) asFloat = f } print ]. - " - ^self partValues: [ :sign :exponent :mantissa | exponent ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 9/26/2018 11:30:23' prior: 16844994! - mantissaPart - "Equivalent to #significandAsInteger." - "The actual bits in the mantissa of the receiver, as an integer number, including the implicit leading 1 if appropriate. - Does not include de sign. - See #exponentPart and #signPart - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. (f signPart * f mantissaPart * (2 raisedToInteger: f exponentPart-52)) asFloat = f } print ]. - " - ^self partValues: [ :sign :exponent :mantissa | mantissa ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 9/26/2018 11:29:42' prior: 16845031! - signPart - "The sign of the mantissa. - See #mantissaPart and #exponentPart" - " - | f | - f := -2.0. - (f signPart * f mantissaPart * (2 raisedToInteger: f exponentPart-52)) asFloat. - " - ^self partValues: [ :sign :exponent :mantissa | sign ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 9/26/2018 11:33:16' prior: 16845037! - significand - "Answers mantissa as a Float between one and two (or between -1 and -2). See #exponent. - See also #signPart, #significandAsInteger and #exponentPart - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. f significand * (2 raisedToInteger: f exponent) = f } print ]. - " - ^ self timesTwoPower: (self exponent negated)! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 9/26/2018 11:31:01' prior: 16845042! - significandAsInteger - "The actual bits in the mantissa of the receiver, as an integer number, including the implicit leading 1 if appropriate. - See #exponentPart - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. (f signPart * f significandAsInteger * (2 raisedToInteger: f exponentPart-52)) asFloat = f } print ]. - " - ^self partValues: [ :sign :exponent :mantissa | mantissa ]! ! -!BoxedFloat64 methodsFor: 'truncation and round off' stamp: 'jmv 9/26/2018 11:33:06' prior: 16790833! - exponent - "Primitive. Consider the receiver to be represented as a power of two - multiplied by a mantissa between one and two or between -1 and -2 (#significand). - Answer with the SmallInteger to whose power two is raised. - Optional. See Object documentation whatIsAPrimitive. - See also #signPart, #significandAsInteger and #exponentPart - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. f significand * (2 raisedToInteger: f exponent) = f } print ]. - " - - | positive | - - self >= 1.0 ifTrue: [^self floorLog: 2]. - self > 0.0 - ifTrue: - [positive _ (1.0 / self) exponent. - self = (1.0 / (1.0 timesTwoPower: positive)) - ifTrue: [^positive negated] - ifFalse: [^positive negated - 1]]. - self = 0.0 ifTrue: [^-1]. - ^self negated exponent! ! -!SmallFloat64 methodsFor: 'truncation and round off' stamp: 'jmv 9/26/2018 11:17:00' prior: 16908499! - exponent - "Primitive. Consider the receiver to be represented as a power of two - multiplied by a mantissa between one and two (#significand). - Answer with the SmallInteger to whose power two is raised. - Optional. See Object documentation whatIsAPrimitive. - See comment at BoxedFloat64" - - | positive | - - self >= 1.0 ifTrue: [^self floorLog: 2]. - self > 0.0 - ifTrue: - [positive _ (1.0 / self) exponent. - self = (1.0 / (1.0 timesTwoPower: positive)) - ifTrue: [^positive negated] - ifFalse: [^positive negated - 1]]. - self = 0.0 ifTrue: [^-1]. - ^self negated exponent! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3454-FloatCommentsEnhancements-JuanVuletich-2018Sep26-11h47m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3454] on 26 September 2018 at 1:32:50 pm'! -!Number class methodsFor: 'instance creation' stamp: 'jmv 9/26/2018 13:28:05' prior: 50413799! - readRemainderOf: integerPart from: aStream base: base withSign: sign - "Read optional fractional part and exponent, and return the final result" - | value fraction fracpos peekChar exp scale convertToFloat | - - convertToFloat := false. - value := integerPart. - (aStream peekFor: $.) - ifTrue: [ "." - (aStream atEnd not and: [ aStream peek digitValue between: 0 and: base - 1 ]) - ifTrue: [ - fracpos := aStream position. - fraction := Integer readFrom: aStream base: base. - fraction := fraction / (base raisedToInteger: aStream position - fracpos). - value := value + fraction. - convertToFloat := true ] - ifFalse: [ - "oops - just ." - aStream skip: -1. - "un-gobble the period" - ^ value * sign"Number readFrom: '3r-22.2'"]]. - peekChar := aStream peek. - peekChar = $e | (peekChar = $d) | (peekChar = $q) - ifTrue: [ "(e|d|q)>" - aStream next. - (aStream atEnd not and: [ (aStream peek digitValue between: 0 and: 9) or: [ aStream peek = $- ]]) - ifTrue: [ - exp := Integer readFrom: aStream. - scale := base raisedToInteger: exp. - value := value * scale ] - ifFalse: [ - "oops - just ." - aStream skip: -1.]]. - ^convertToFloat - ifTrue: [ - (value = 0.0 and: [ sign = -1 ]) - ifTrue: [ Float negativeZero ] - ifFalse: [ (value * sign) asFloat ]] - ifFalse: [ value * sign ]! ! -!Float methodsFor: 'printing' stamp: 'nice 4/20/2010 22:48' prior: 50413973! - absPrintExactlyOn: aStream base: base - "Print my value on a stream in the given base. Assumes that my value is strictly - positive; negative numbers, zero, and NaNs have already been handled elsewhere. - Based upon the algorithm outlined in: - Robert G. Burger and R. Kent Dybvig - Printing Floating Point Numbers Quickly and Accurately - ACM SIGPLAN 1996 Conference on Programming Language Design and Implementation - June 1996. - https://www.cs.indiana.edu/~dyb/pubs/FP-Printing-PLDI96.pdf - This version guarantees that the printed representation exactly represents my value - by using exact integer arithmetic." - - | significand exp baseExpEstimate r s mPlus mMinus scale roundingIncludesLimits d tc1 tc2 fixedFormat decPointCount slowbit shead | - self isInfinite ifTrue: [aStream nextPutAll: 'Infinity'. ^ self]. - significand := self significandAsInteger. - roundingIncludesLimits := significand even. - "What follows is equivalent, but faster than - exp := self exponentPart - 52." - exp := (self exponent - 52) max: MinValLogBase2. - baseExpEstimate := (self exponent * base asFloat reciprocalLogBase2 - 1.0e-10) ceiling. - exp >= 0 - ifTrue: - [significand ~= 16r10000000000000 - ifTrue: - [r := significand bitShift: 1 + exp. - s := 2. - mPlus := mMinus := 1 bitShift: exp] - ifFalse: - [r := significand bitShift: 2 + exp. - s := 4. - mPlus := 2 * (mMinus := 1 bitShift: exp)]] - ifFalse: - [(exp = MinValLogBase2 or: [significand ~= 16r10000000000000]) - ifTrue: - [r := significand bitShift: 1. - s := 1 bitShift: 1 - exp. - mPlus := mMinus := 1] - ifFalse: - [r := significand bitShift: 2. - s := 1 bitShift: 2 - exp. - mPlus := 2. - mMinus := 1]]. - baseExpEstimate >= 0 - ifTrue: [s := s * (base raisedToInteger: baseExpEstimate)] - ifFalse: - [scale := base raisedToInteger: baseExpEstimate negated. - r := r * scale. - mPlus := mPlus * scale. - mMinus := mMinus * scale]. - ((r + mPlus < s) not and: [roundingIncludesLimits or: [r + mPlus > s]]) - ifTrue: [baseExpEstimate := baseExpEstimate + 1] - ifFalse: - [r := r * base. - mPlus := mPlus * base. - mMinus := mMinus * base]. - (fixedFormat := baseExpEstimate between: -3 and: 6) - ifTrue: - [decPointCount := baseExpEstimate. - baseExpEstimate <= 0 - ifTrue: [aStream nextPutAll: ('0.000000' truncateTo: 2 - baseExpEstimate)]] - ifFalse: - [decPointCount := 1]. - slowbit := 1 - s lowBit . - shead := s bitShift: slowbit. - [d := (r bitShift: slowbit) // shead. - r := r - (d * s). - (tc1 := (r > mMinus) not and: [roundingIncludesLimits or: [r < mMinus]]) | - (tc2 := (r + mPlus < s) not and: [roundingIncludesLimits or: [r + mPlus > s]])] whileFalse: - [aStream nextPut: (Character digitValue: d). - r := r * base. - mPlus := mPlus * base. - mMinus := mMinus * base. - decPointCount := decPointCount - 1. - decPointCount = 0 ifTrue: [aStream nextPut: $.]]. - tc2 ifTrue: - [(tc1 not or: [r * 2 >= s]) ifTrue: [d := d + 1]]. - aStream nextPut: (Character digitValue: d). - decPointCount > 0 - ifTrue: - [decPointCount - 1 to: 1 by: -1 do: [:i | aStream nextPut: $0]. - aStream nextPutAll: '.0']. - fixedFormat ifFalse: - [aStream nextPut: $e. - aStream nextPutAll: (baseExpEstimate - 1) printString]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3455-FloatFromString-fix-JuanVuletich-2018Sep26-13h32m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3450] on 22 September 2018 at 10:28:10 am'! - -"Change Set: 3451-CuisCore-AuthorName-2018Sep22-10h25m -Date: 22 September 2018 -Author: Nahuel Garbezza - -Method #average: for Collection. Basically the composition of #collect: and #average"! -!Collection methodsFor: 'statistics' stamp: 'RNG 9/22/2018 10:26:52'! - average: aBlock - - ^ (self sum: aBlock) / self size! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3456-Collection_average_withArgument-NahuelGarbezza-2018Sep22-10h25m-RNG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3456] on 27 September 2018 at 11:14:05 am'! - -String removeSelector: #asCharacter! - -String removeSelector: #asCharacter! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3457-Remove-String-asCharacter-JuanVuletich-2018Sep27-10h55m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3451] on 23 September 2018 at 10:09:08 pm'! -!KeyboardEvent methodsFor: 'testing' stamp: 'HAW 9/23/2018 21:03:43'! - isAlphaNumeric - - ^ self keyCharacter isAlphaNumeric! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'HAW 9/23/2018 21:29:31'! - isArrowDown - - ^ keyValue = 31! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'HAW 9/23/2018 21:29:05'! - isArrowUp - - ^ keyValue = 30! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'HAW 9/23/2018 21:26:20'! - isBackspace - - ^ keyValue = 8! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'HAW 9/23/2018 21:04:09'! - isColon - - ^ self keyCharacter = $:.! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'HAW 9/23/2018 21:34:21'! - isCtrlSpace - - ^ (self controlKeyPressed or: [ self rawMacOptionKeyPressed ]) and: [ self isSpace ]! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'HAW 9/23/2018 21:27:43'! - isEnd - - ^ keyValue = 4! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'HAW 9/23/2018 21:25:30'! - isEsc - - ^ keyValue = 27! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'HAW 9/23/2018 21:27:07'! - isHome - - ^ keyValue = 1! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'HAW 9/23/2018 21:30:29'! - isPageDown - - ^ keyValue = 12! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'HAW 9/23/2018 21:30:07'! - isPageUp - - ^ keyValue = 11! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'HAW 9/23/2018 21:28:26'! - isQuesitonMark - - ^ self keyCharacter = $? ! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'HAW 9/23/2018 20:55:17'! - isSpace - - ^ #(0 32 160) includes: keyValue.! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'HAW 9/23/2018 20:55:13'! - isTab - - ^self keyCharacter = Character tab.! ! -!AutoCompleter methodsFor: 'keyboard - private' stamp: 'HAW 9/23/2018 21:16:16'! -isTab: kbEvent and: shouldOpenMoprh - - ^ self opensWithTab - and: [ kbEvent isTab - and: [ shouldOpenMoprh ]]! ! -!AutoCompleter methodsFor: 'keyboard - private' stamp: 'HAW 9/23/2018 21:35:54'! - openCompletionMenuFor: kbEvent if: shouldOpenMorph - - "Ctrl-Space or Tab for open" - "Mac specific note: Using option-space (actually option+160) effectively disables the non-breaking space character 160" - (kbEvent isCtrlSpace or: [self isTab: kbEvent and: shouldOpenMorph]) ifTrue: [ self openCompletionMenu. ^ true]. - - "Auto-open - currently deactivated" -" (ctrl not & cmd not & alphanum) ifTrue: [ self openCompletionMenu ]." - - ^ false! ! -!AutoCompleter methodsFor: 'keyboard - private' stamp: 'HAW 9/23/2018 21:06:20'! - shouldCloseMenu: kbEvent - - "All keys but the alphanumeric chars (without command and control ) - and the backspace key do close the menu" - - ^ ((kbEvent controlKeyPressed not and: [ kbEvent commandAltKeyPressed not ]) and: [ kbEvent isAlphaNumeric or: [ kbEvent isColon ]]) not -! ! -!AutoCompleter methodsFor: 'keyboard - private' stamp: 'HAW 9/23/2018 20:58:51'! - shouldInsertSelected: kbEvent - - ^ kbEvent isReturnKey - or: [ (kbEvent isSpace and: [ kbEvent controlKeyPressed or: [ kbEvent rawMacOptionKeyPressed ]]) - or: [ kbEvent isTab]]! ! -!AutoCompleter methodsFor: 'keyboard - private' stamp: 'HAW 9/23/2018 19:46:17'! - shouldOpenMorph - - | currentPos currentChar | - - currentPos _ textMorph editor startIndex-1. - currentPos <= 0 ifTrue: [ ^ false ]. - currentChar _ model actualContents at: currentPos. - - ^ currentChar = Character space - ifTrue: [ self shouldOpenMorphWhenNoPrefixAt: currentPos-1 ] - ifFalse: [ self shouldOpenMorphWhenPrefixAt: currentPos and: currentChar ]. - - - - ! ! -!AutoCompleter methodsFor: 'keyboard - private' stamp: 'HAW 9/23/2018 21:23:06'! - shouldOpenMorphWhenNoPrefixAt: currentPos - - ^ model textSize >= currentPos - and: [ currentPos > 0 - and: [ (model actualContents at: currentPos) isAlphaNumeric ]] ! ! -!AutoCompleter methodsFor: 'keyboard - private' stamp: 'HAW 9/23/2018 19:48:46'! - shouldOpenMorphWhenPrefixAt: currentPos and: currentChar - - ^ model textSize >= currentPos and: [ currentChar isAlphaNumeric or: [ currentChar == $: ]] - - - ! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 9/23/2018 19:30:07'! - canComputeMessageEntriesFor: prevRange and: prevPrevRange - - ^ prevRange notNil and: [ prevPrevRange isNil or: [ (#(binary keyword) includes: prevPrevRange rangeType) not]]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 9/23/2018 19:17:21'! - computeEntriesOfMessageOrIdentifiersFor: allSource using: last3Ranges at: range in: contextClass and: specificModel - - prefix _ allSource copyFrom: range start to: range end. - (parser isMessage: range rangeType) ifTrue: [ ^self computeMessageEntriesWhenSendinMessageFor: allSource using: last3Ranges in: contextClass and: specificModel ]. - (parser isPartialOrFullIdentifier: range rangeType) ifTrue: [ ^self computeIdentifierEntries ]. - - "If we don't know what to do, do nothing" - entries _ #() ! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 9/23/2018 19:26:07'! - computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel - - | id receiverClass | - - id _ allSource copyFrom: range start to: range end. - receiverClass _ range rangeType - caseOf: { - [ #globalVar ] -> [ (Smalltalk at: id asSymbol) class ]. - [ #self ] -> [ contextClass ]. - [ #super ] -> [ contextClass superclass ]. - [ #true ] -> [ True ]. - [ #false ] -> [ False ]. - [ #nil ] -> [ UndefinedObject ]. - [ #character ] -> [ id first class ]. - [ #number ] -> [ self classOfLiteral: id in: contextClass ]. - [ #string ] -> [ self classOfLiteral: id in: contextClass ]. - [ #symbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #stringSymbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #instVar ] -> [ self classOfInstVarNamed: id in: specificModel ]. - [ #tempVar ] -> [ self classOfTempVarNamed: id in: specificModel ]. - [ #workspaceVar ] -> [ self classOfWorkspaceVarNamed: id in: specificModel ]. - [ #classVar ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #poolConstant ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #thisContext ] -> [ self classOfThisContextIn: specificModel ]. } - otherwise: [ nil ]. - - self computeMessageEntries: receiverClass! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 9/23/2018 19:29:16'! - computeMessageEntriesWhenSendinMessageFor: allSource using: last3Ranges in: contextClass and: specificModel - - | prevPrevRange prevRange | - - "If previous range is a constant or a well known identifier, we might filter messages" - prevRange _ last3Ranges second. - prevPrevRange _ last3Ranges first. - - "3 if -> ifNil: but not ifTrue: - 3=4 -> ifNil: or ifTrue:" - ^ (self canComputeMessageEntriesFor: prevRange and: prevPrevRange) - ifTrue: [ self computeMessageEntriesFor: allSource at: prevRange in: contextClass and: specificModel ] - ifFalse: [ self computeMessageEntries: nil ] -! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 9/23/2018 19:18:09'! -computeMessageEntriesWithEmptyPrefixFor: allSource at: range in: contextClass and: specificModel - - prefix _ ''. - self computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel ! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 9/23/2018 19:03:49'! - parse: sourceToParse in: contextClass and: specificModel - - parser _ SHParserST80 new. - parser - workspace: ((specificModel is: #providesBindings) ifTrue: [specificModel]); - classOrMetaClass: contextClass; - source: sourceToParse. - parser parse. - - ^ parser last3Ranges. -! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 9/23/2018 19:01:52'! - selectedClassOrMetaClassIn: specificModel - - ^ (specificModel is: #CodeProvider) ifTrue: [ specificModel selectedClassOrMetaClass ]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 9/23/2018 19:30:43'! - textProviderOrModel - - ^ (model is: #hasTextProvider) ifTrue: [ model textProvider ] ifFalse: [ model ].! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/23/2018 22:03:28'! - classOfInstVarNamed: aName in: specificModel - - (specificModel isKindOf: Debugger) ifTrue: [ ^specificModel contextStackIndex ~= 0 ifTrue: [ (specificModel receiver instVarNamed: aName) class] ]. - - ^nil - ! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/23/2018 16:52:20'! - classOfLiteral: aLiteral in: aClass - - | compilerClass | - - compilerClass := aClass ifNil: [ Compiler ] ifNotNil: [ aClass compilerClass ]. - - ^ (compilerClass evaluate: aLiteral) class ! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/23/2018 16:52:36'! - classOfLocalBindingNamed: aName in: aClass - - ^ (aClass localBindingOf: aName) ifNotNil: [ :aBinding | aBinding value class ]! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/23/2018 22:04:08'! - classOfTempVarNamed: aName in: specificModel - - (specificModel isKindOf: Workspace) ifTrue: [ ^ self classOfTempVarNamed: aName inWorkspace: specificModel ]. - (specificModel isKindOf: Debugger) ifTrue: [ ^ self classOfTempVarNamed: aName inDebugger: specificModel ]. - (specificModel isKindOf: Inspector) ifTrue: [ ^ self classOfTempVarNamed: aName inInspector: specificModel ]. - - ^ nil! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/23/2018 19:31:39'! - classOfTempVarNamed: aName inDebugger: aDebugger - - | context tempIndex | - - context := aDebugger selectedContext. - tempIndex := context tempNames indexOf: aName. - - ^ tempIndex ~= 0 ifTrue: [(context tempAt: tempIndex) class]! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/23/2018 21:50:35'! -classOfTempVarNamed: aName inInspector: anInspector - - ^ (anInspector bindingOf: aName) value ifNotNil: [ :aValue | aValue class ] ! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/23/2018 16:38:27'! - classOfTempVarNamed: aName inWorkspace: aWorkspace - - ^ (aWorkspace bindingOf: aName) value ifNotNil: [ :aValue | aValue class ] ! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/23/2018 19:31:57'! - classOfThisContextIn: specificModel - - "thisContext could mean ContextPart or BlockClosure..." - ^ (specificModel isKindOf: Debugger) ifTrue: [ self classOfThisContextInDebugger: specificModel ] - ! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/23/2018 17:06:19'! - classOfThisContextInDebugger: aDebugger - - ^ aDebugger selectedContext class! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/23/2018 22:05:20'! - classOfWorkspaceVarNamed: id in: specificModel - - (specificModel isKindOf: Workspace) ifTrue: [ ^ self classOfWorkspaceVarNamed: id inWorkspace: specificModel ]. - (specificModel isKindOf: Inspector) ifTrue: [ ^self classOfWorkspaceVarNamed: id inInspector: specificModel ]. - - ^nil! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/23/2018 16:44:50'! - classOfWorkspaceVarNamed: aName inInspector: anInspector - - ^ (anInspector object instVarNamed: aName) class ! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/23/2018 16:43:48'! - classOfWorkspaceVarNamed: aName inWorkspace: aWorkspace - - ^ (aWorkspace bindingOf: aName) value ifNotNil: [ :aValue | aValue class ] ! ! -!AutoCompleter methodsFor: 'keyboard' stamp: 'HAW 9/23/2018 21:30:54' prior: 50412571! - handleKeystrokeBefore: kbEvent - - "I return a boolean. true when I have handled the event and no futher processing is needed by the caller." - - | shouldOpenMorph | - - shouldOpenMorph _ self shouldOpenMorph. - - "Stuff to do if the menu is not open" - menuMorph ifNil: [ ^ self openCompletionMenuFor: kbEvent if: shouldOpenMorph ]. - - "Starting here, stuff to do if the menu is open" - menuMorph stillActive. - - kbEvent isEsc ifTrue: [ self closeMenu. ^ true]. - kbEvent isBackspace ifTrue: [ shouldOpenMorph ifFalse: [ self closeMenu ]. ^ false]. - kbEvent isHome ifTrue: [ menuMorph goHome. ^ true ]. - kbEvent isEnd ifTrue: [ menuMorph goToEnd. ^ true]. - kbEvent isQuesitonMark ifTrue: [ menuMorph help. ^true]. - kbEvent isArrowUp ifTrue: [ menuMorph goUp. ^ true]. - kbEvent isArrowDown ifTrue: [ menuMorph goDown. ^ true]. - kbEvent isPageUp ifTrue: [ menuMorph goPageUp. ^ true]. - kbEvent isPageDown ifTrue: [ menuMorph goPageDown. ^ true]. - (self shouldInsertSelected: kbEvent) ifTrue: [ self insertSelected ifTrue: [^ true]]. - (self shouldCloseMenu: kbEvent) ifTrue: [ self closeMenu ]. - - ^false! ! -!SmalltalkCompleter methodsFor: 'entries' stamp: 'HAW 9/23/2018 19:18:00' prior: 50367911! - computeEntries - - | allSource contextClass specificModel last3Ranges range | - - allSource _ model actualContents string. - specificModel _ self textProviderOrModel. - contextClass _ self selectedClassOrMetaClassIn: specificModel. - last3Ranges _ self parse: (allSource copyFrom: 1 to: position) in: contextClass and: specificModel. - range _ last3Ranges third ifNil: [ ^entries _ #() ]. - - range end = position - ifTrue: [ self computeEntriesOfMessageOrIdentifiersFor: allSource using: last3Ranges at: range in: contextClass and: specificModel ] - ifFalse: [ self computeMessageEntriesWithEmptyPrefixFor: allSource at: range in: contextClass and: specificModel ]. - - ! ! -!SmalltalkCompleter methodsFor: 'entries' stamp: 'HAW 9/23/2018 19:23:35' prior: 16909351! - newCursorPosition: anEntry - - ^anEntry indexOf: $ ! ! -!SmalltalkCompleter methodsFor: 'entries' stamp: 'HAW 9/23/2018 19:23:40' prior: 16909355! - selectedEntry - - ^(self entries at: menuMorph selected) separateKeywords! ! - -SmalltalkCompleter removeSelector: #canDetectTypeOf:in:! - -SmalltalkCompleter removeSelector: #classForInstVarNamed:in:! - -SmalltalkCompleter removeSelector: #classOfLiteral:! - -SmalltalkCompleter removeSelector: #classOfLocalBindingNamed:of:! - -SmalltalkCompleter removeSelector: #classOfTempVarNamed:inBindingsProvider:! - -SmalltalkCompleter removeSelector: #computeEntriesOf:in:! - -AutoCompleter removeSelector: #isArrowDown:! - -AutoCompleter removeSelector: #isArrowUp:! - -AutoCompleter removeSelector: #isCtrlSpace:! - -AutoCompleter removeSelector: #isEnd:! - -AutoCompleter removeSelector: #isHome:! - -AutoCompleter removeSelector: #isPageDown:! - -AutoCompleter removeSelector: #isPageUp:! - -AutoCompleter removeSelector: #isQuesitonMark:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3458-SmalltalkCompleterEnhancements-p1-HernanWilkinson-2018Sep23-12h02m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3451] on 23 September 2018 at 10:28:44 pm'! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/23/2018 22:24:12'! - classOfBlockArgNamed: aName in: specificModel - - (specificModel isKindOf: Debugger) ifTrue: [ ^ self classOfBlockArgNamed: aName inDebugger: specificModel ]. - - ^ nil! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/23/2018 22:27:23'! - classOfBlockArgNamed: aName inDebugger: aDebugger - - ^ aDebugger contextStackIndex ~= 0 ifTrue: [ | selectedContext tempIndex | - selectedContext := aDebugger selectedContext. - tempIndex := selectedContext tempNames indexOf: aName ifAbsent: [ ^nil ]. - (selectedContext namedTempAt: tempIndex) class ]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 9/23/2018 22:23:41' prior: 50414973! - computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel - - | id receiverClass | - - id _ allSource copyFrom: range start to: range end. - receiverClass _ range rangeType - caseOf: { - [ #globalVar ] -> [ (Smalltalk at: id asSymbol) class ]. - [ #self ] -> [ contextClass ]. - [ #super ] -> [ contextClass superclass ]. - [ #true ] -> [ True ]. - [ #false ] -> [ False ]. - [ #nil ] -> [ UndefinedObject ]. - [ #character ] -> [ id first class ]. - [ #number ] -> [ self classOfLiteral: id in: contextClass ]. - [ #string ] -> [ self classOfLiteral: id in: contextClass ]. - [ #symbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #stringSymbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #instVar ] -> [ self classOfInstVarNamed: id in: specificModel ]. - [ #tempVar ] -> [ self classOfTempVarNamed: id in: specificModel ]. - [ #workspaceVar ] -> [ self classOfWorkspaceVarNamed: id in: specificModel ]. - [ #classVar ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #poolConstant ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #thisContext ] -> [ self classOfThisContextIn: specificModel ]. - [ #blockArg ] -> [ self classOfBlockArgNamed: id in: specificModel ].} - otherwise: [ nil ]. - - self computeMessageEntries: receiverClass! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3459-SmalltalkCompleterEnhancements-p2-HernanWilkinson-2018Sep23-22h09m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3451] on 24 September 2018 at 3:31:12 pm'! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/24/2018 15:03:26'! - classOfInstVarNamed: aName inDebugger: aDebugger - - ^aDebugger contextStackIndex ~= 0 ifTrue: [ (aDebugger receiver instVarNamed: aName) class]! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/24/2018 15:04:44'! - classOfInstVarNamed: aName inInspector: anInspector - - ^ (anInspector object instVarNamed: aName) class ! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/24/2018 15:17:20'! -classOfTempVarNamed: aName inContext: context - - | tempIndex | - - tempIndex := context tempNames indexOf: aName. - - ^ tempIndex ~= 0 ifTrue: [(context tempAt: tempIndex) class]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 9/24/2018 13:25:49' prior: 50415305! - computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel - - | id receiverClass | - - id _ allSource copyFrom: range start to: range end. - receiverClass _ range rangeType - caseOf: { - [ #globalVar ] -> [ (Smalltalk at: id asSymbol) class ]. - [ #self ] -> [ contextClass ]. - [ #super ] -> [ contextClass superclass ]. - [ #true ] -> [ True ]. - [ #false ] -> [ False ]. - [ #nil ] -> [ UndefinedObject ]. - [ #character ] -> [ id first class ]. - [ #number ] -> [ self classOfLiteral: id in: contextClass ]. - [ #string ] -> [ self classOfLiteral: id in: contextClass ]. - [ #symbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #stringSymbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #instVar ] -> [ self classOfInstVarNamed: id in: specificModel ]. - [ #tempVar ] -> [ self classOfTempVarNamed: id in: specificModel ]. - [ #workspaceVar ] -> [ self classOfWorkspaceVarNamed: id in: specificModel ]. - [ #classVar ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #poolConstant ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #thisContext ] -> [ self classOfThisContextIn: specificModel ]. - [ #blockArg ] -> [ self classOfBlockArgNamed: id in: specificModel ].} - otherwise: [ nil ]. - - self computeMessageEntries: receiverClass! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 9/24/2018 12:48:26' prior: 50415048! - parse: sourceToParse in: contextClass and: specificModel - - parser _ SHParserST80 new. - parser - workspace: ((specificModel is: #providesBindings) ifTrue: [specificModel]); - classOrMetaClass: contextClass; - source: sourceToParse. - parser parse: (specificModel is: #CodeProvider). - - ^ parser last3Ranges. -! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 9/24/2018 12:58:46' prior: 50415060! - selectedClassOrMetaClassIn: specificModel - - (specificModel is: #CodeProvider) ifTrue: [ ^ specificModel selectedClassOrMetaClass ]. - - "I can not use #selectedClassOrMetaClass becuase it changes with the selection but when compiling to evaluate it assumes object as receiver - Hernan" - ^ (specificModel isKindOf: Inspector) ifTrue: [ specificModel object class ] ! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/24/2018 15:02:09' prior: 50415284! - classOfBlockArgNamed: aName in: specificModel - - ^ (specificModel isKindOf: Debugger) ifTrue: [ self classOfBlockArgNamed: aName inDebugger: specificModel ]. - ! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/24/2018 15:03:54' prior: 50415073! - classOfInstVarNamed: aName in: specificModel - - (specificModel isKindOf: Debugger) ifTrue: [ ^ self classOfInstVarNamed: aName inDebugger: specificModel ]. - ^ (specificModel isKindOf: Inspector) ifTrue: [ self classOfInstVarNamed: aName inInspector: specificModel ]. - - ! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/24/2018 15:16:59' prior: 50415115! - classOfTempVarNamed: aName inDebugger: aDebugger - - | context | - - context := aDebugger selectedContext. - - ^self classOfTempVarNamed: aName inContext: context! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/24/2018 15:29:14' prior: 50415154! - classOfWorkspaceVarNamed: id in: specificModel - - (specificModel isKindOf: Workspace) ifTrue: [ ^ self classOfWorkspaceVarNamed: id inWorkspace: specificModel ]. - ^ (specificModel isKindOf: Inspector) ifTrue: [ self classOfWorkspaceVarNamed: id inInspector: specificModel ]. - ! ! -!SmalltalkCompleter methodsFor: 'class detection' stamp: 'HAW 9/24/2018 15:19:44' prior: 50415166! - classOfWorkspaceVarNamed: aName inInspector: anInspector - - ^ self classOfTempVarNamed: aName inContext: anInspector object - -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3460-SmalltalkCompleterEnhancements-p3-HernanWilkinson-2018Sep24-08h59m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3451] on 24 September 2018 at 3:44:30 pm'! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 9/24/2018 15:44:19' prior: 16909302! - computeIdentifierEntries - "Use an aux Set to avoid duplicates, but keep the order given." - | entriesSet | - - entriesSet _ Set new. - entries _ Array streamContents: [ :strm | - parser namesBeginningWith: prefix do: [ :identifier | - (entriesSet includes: identifier) ifFalse: [ - entriesSet add: identifier. - strm nextPut: identifier ]]]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3461-SmalltalkCompleterEnhancements-p4-HernanWilkinson-2018Sep24-15h31m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3463] on 28 September 2018 at 12:16:58 pm'! -!ContentPack commentStamp: 'jmv 9/28/2018 12:16:02' prior: 16823123! - ContentPack lets you read in and write out the (supported files in the) contents of a directory on your file system. It also allows you to trivially create "messenger" subclasses that capture the information containted in these directory trees, including any implicit communication that's there in the structure of the directory hierarchy itself, which are captured in your changes file. You can then file out a change set that contains a representation of the (supported file/object types and directory structurein) the stuff on your disk, or in your image. This subclass is a dummy which ContentPack compiles methods into containing base 64 encoded data. You can load this into another image, as long as that image has ContentPack loaded. The filed in class can then recreate the ContentPack on the other end with the media files and structure intact. - -The current implementation is based on #storeString, but the plan is to change that to SmartRefStream in the long run to support serializing things like morphs. - -ContentPack instances hang onto the actual tree of media objects. It has a nice simple EDSL that just interprets an array of strings from beginning to end as a "path" to a file (really a series of dictionary lookups to a Smalltalk object, wherin the dictionaries mirror the structure of what was on the disk, sans unsupported files.) This mechanism will likely change a little bit at some point, - -ContentPack came into the world a little faster than I expected, as I ended up using it to send some icons back in time to fix the Cuis update stream without having to sort my changes all over again. As such it had some unusual design pressures... it had to be able to carry information in and out of both the change set stream and the filesystem, as well as function in a slightly earlier (unreleased) version of Cuis than it was written in, and not break anything on it's way back up through the build to head. - -The code, in particular the way things are named, has not settled yet, and that's why this comment contains no code examples. Use with care and read the code first, for now. - -Currently, .bmp import and .png import are implemented, and both can be exported. Anything you can import, you can also shuffle into a change set. Plans are in the works to support audio, change sets, and text files. I'll support video if someone has a good importer, exporter, and player under the MIT license that'll work under Cuis. - -Currently, objects are serialized into single methods, which works for small icons, but likely doesn't work well (if at all) for larger files. My intent is to add some behavior that breaks up large objects into smaller chunks so that this becomes a non-issue. I'll likely get to that when I've removed most of the repetitive subtle variations of the same recursive tree walking visitor-trick from the code, and renamed everything. I think in essence this class is slightly smaller than it is as represented currently. - -Hopefully I will be able to explain all of this better once I've clarified the code a bit so that I can show off some examples. - - - cbr - ------------------------------------ -Alternative description (need to merge both!!) - -Forms (and potentially other media types) can exist in three forms: - -1) As external files, such as jpg, png, etc. This is the representation we need to use external tools (such as image processing apps, cameras, scanners, web, etc) to work on them. -2) As methods. Non human readable, base-64 encoded binary data. We need this to be able to include such stuff in the update stream, or in packages. After we update an image, we usually delete these methods, just keeping 3). -3) Live objects in the image, for example, stored in class variables. This is to make use of them in Cuis. - -Most of the time, we use 3). But we need 2) for the update stream. We also need 1) sometimes to work on them. ContentPack supports the conversion between these 3 formats. The implementation is quite simple. What is really great is that Casey realized we need some tool to move comfortably between these 3 representations. And he also implemented it. - - - jmv - -------------------------------------------- -Usage hints - -Feature require: 'Graphics-Files-Additional'. -Theme content export. - -"Build 'Import' directory copying the structure of 'Exported', with stuff to be loaded" - -"Just build an instance from files" -ContentPack import. - -"Build an instance and generate code" -ContentPack generateCode: ContentPack import. - -"Build an instance from code generated" -ContentPack decode. - -"Build and merge. Usually do this in the postscript of the change set that includes the generated code" -Theme content merge: ContentPack decode. -ContentPack removeCategory: ContentPack generatedMethodsCategory! -!ContentPack methodsFor: 'importing' stamp: 'jmv 9/28/2018 11:50:48'! - decodeContent - "Load content in us. - Start with an empty instance!!" - - self decodeContentFrom: self contentMap! ! -!ContentPack methodsFor: 'testing' stamp: 'jmv 9/28/2018 12:02:29'! - is: aSymbol - ^aSymbol == #ContentPack or: [ super is: aSymbol ]! ! -!ContentPack methodsFor: 'merge' stamp: 'jmv 9/28/2018 12:03:37'! - merge: aDictionaryOrContentPack - "Merge aDictionaryOrContentPack into us" - - aDictionaryOrContentPack keysAndValuesDo: [ :key :value | - (value is: #ContentPack) - ifFalse: [ - self at: key put: value ] - ifTrue: [ - (self at: key ifAbsentPut: [ContentPack new]) - merge: value ]]! ! -!ContentPack class methodsFor: 'instance creation' stamp: 'jmv 9/28/2018 11:51:51'! - decode - - ^ self new decodeContent! ! -!ContentPack class methodsFor: 'code pack' stamp: 'jmv 9/28/2018 10:47:25'! - generateCode: aDictionary - - | contentMap | - - self resetImporter. - - contentMap _ self encodeContentFrom: aDictionary. - - self compilePayloadWith: contentMap. - - self resetImporter.! ! -!ContentPack class methodsFor: 'configuration' stamp: 'jmv 9/28/2018 12:14:18'! - generatedMethodsCategory - ^ 'generated code'! ! -!ContentPack class methodsFor: 'configuration' stamp: 'jmv 9/28/2018 10:37:22'! -importDirectory - - ^ DirectoryEntry smalltalkImageDirectory / self defaultContentDirectory / 'Import'! ! -!ContentPack methodsFor: 'importing' stamp: 'jmv 9/28/2018 11:56:08' prior: 16823258! - decodeContentFrom: associationList - "Load content in us, frin geberated code. - Start with an empty instance!!" - - associationList do: [ :assoc | - (assoc at: 2) class == Array - ifTrue: [ - self at: (assoc at: 1) put: (ContentPack new decodeContentFrom: (assoc at: 2)) ] - ifFalse: [ - self at: (assoc at: 1) put: (Compiler - evaluate: (self - perform: - ('object' , (assoc at: 2) asString) asSymbol) base64Decoded) - ] - ]! ! -!ContentPack methodsFor: 'importing' stamp: 'jmv 9/28/2018 11:55:59' prior: 50413556! - loadContentFrom: aDirectoryEntry - "Load content in us, from files. - Start with an empty instance!!" - - (self supportedFilesIn: aDirectoryEntry) do: [ :filename | - self flag: #todo. "Add hook for other media types here. Also consider renaming this method. --cbr" - self at: filename name - put: (Form fromFileEntry: filename) - ]. - - aDirectoryEntry directoryNames do: [ :i | - self at: i put: (ContentPack new loadContentFrom: aDirectoryEntry / i) - ]! ! -!ContentPack class methodsFor: 'instance creation' stamp: 'jmv 9/28/2018 10:37:34' prior: 50413578! - import - " - Feature require: 'Graphics-Files-Additional'. - Theme content export. - ContentPack import. - Theme bootstrap. - " - - ^ self new loadContentFrom: self importDirectory! ! -!ContentPack class methodsFor: 'code pack' stamp: 'jmv 9/28/2018 12:14:28' prior: 16823429! - compilePayloadWith: contentMap - - | category | - category _ self generatedMethodsCategory. - self - compile: 'contentMap' , String newLineString , ' ^ ' , contentMap asString - classified: category. - - self - compile: 'objectCount' , String newLineString , ' ^ ' , payload size asString - classified: category. - - payload withIndexDo: [ :blob :index | | selector | - selector _ 'object', index asString. - self - compile: selector, String newLineString, ' ^ ', blob surroundedBySingleQuotes - classified: category ]! ! - -ContentPack class removeSelector: #withDictionary:! - -ContentPack class removeSelector: #withDictionary:! - -ContentPack removeSelector: #import:! - -ContentPack removeSelector: #import:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3462-ContentPack-enhancements-JuanVuletich-2018Sep28-11h24m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3462] on 28 September 2018 at 12:20:08 pm'! -!ContentPack methodsFor: 'generated code' stamp: 'jmv 9/28/2018 10:41:53'! - contentMap - ^ #(#('Theme' 1))! ! -!ContentPack methodsFor: 'generated code' stamp: 'jmv 9/28/2018 10:41:53'! - object1 - ^ 'KChDb250ZW50UGFjayBuZXcpIGFkZDogKCcxNngxNictPigoQ29udGVudFBhY2sgbmV3KSBh -ZGQ6ICgncmVzaXplJy0+KChDb250ZW50UGFjayBuZXcpIGFkZDogKCdyZXNpemUzLnBuZyct -PihGb3JtCglleHRlbnQ6IDE2QDE2CglkZXB0aDogMzIKCWZyb21BcnJheTogIyggNDI5NDk2 -NzI5NSA0MjQ0NjM1NjQ3IDQyNDQ2MzU2NDcgNDI0NDYzNTY0NyA0MjQ0NjM1NjQ3IDQyNDQ2 -MzU2NDcgNDI0NDYzNTY0NyA0MjQ0NjM1NjQ3IDQyNDQ2MzU2NDcgNDI0NDYzNTY0NyA0MjQ0 -NTY5ODU0IDQyNDQ1Njk4NTQgNDI0NDU2OTg1NCA0MjQ0NTY5ODU0IDQyNDQ1Njk4NTQgNDI5 -NDk2NzI5NSA0MjQ0NjM1NjQ3IDQyNzg5Nzk1OTYgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQy -NzgxOTAwODAgNDI3ODk3OTU5NiA0Mjk0MTExOTg2IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAg -NDI3ODE5MDA4MCA0MjQ0NTY5ODU0IDQyNDQ2MzU2NDcgNDI3ODg0ODAxMCA0Mjk0MzA5MzY1 -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0MTExOTg2IDQyOTQ5MDE1MDIgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjc4MTkwMDgwIDQyNDQ1Njk4NTQgNDI0NDYzNTY0NyA0Mjc4NTg0 -ODM4IDQyOTQ1NzI1MzcgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyNzgxOTAwODAgNDI0NDU2OTg1NCA0MjQ0 -NjM1NjQ3IDQyNzgzODc0NTkgNDI5NDc2OTkxNiA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQy -OTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI3ODE5MDA4MCA0 -MjQ0NTY5ODU0IDQyNDQ2MzU2NDcgNDI3ODI1NTg3MyA0Mjk0OTAxNTAyIDQyOTQ5NjcyOTUg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjc4MTkwMDgwIDQyNDQ1Njk4NTQgNDI0NDYzNTY0NyA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3 -Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI0NDYzNTY0NyA0MjQ0NjM1NjQ3IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0 -OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0MjQ0NjM1NjQ3IDQy -NDQ2MzU2NDcgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDQyNDQ2MzU2NDcgNDI0NDYzNTY0NyA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3 -Mjk1IDQyOTQ5NjcyOTUgNDI0NDYzNTY0NyA0MjQ0NjM1NjQ3IDQyNzgxOTAwODAgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0 -OTY3Mjk1IDQyOTQ3MDQxMjMgNDI3ODU4NDgzOCA0MjQ0NjM1NjQ3IDQyNDQ2MzU2NDcgNDI3 -ODE5MDA4MCA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQy -OTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDgzNTcwOSA0Mjc4NDUzMjUyIDQyNDQ2MzU2NDcg -NDI0NDYzNTY0NyA0Mjc4MTkwMDgwIDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTAxNTAyIDQyNzgzODc0 -NTkgNDI0NDYzNTY0NyA0MjQ0NjM1NjQ3IDQyNzgxOTAwODAgNDI5NDk2NzI5NSA0Mjk0OTY3 -Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI3ODMyMTY2NiA0MjQ0NjM1NjQ3IDQyNDQ2MzU2NDcgNDI3ODE5MDA4MCA0Mjc4 -MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5MDE1MDIgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQy -NzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MjU1ODczIDQyNDQ2MzU2NDcgNDI5NDk2NzI5NSA0 -MjQ0NjM1NjQ3IDQyNDQ2MzU2NDcgNDI0NDYzNTY0NyA0MjQ0NjM1NjQ3IDQyNDQ2MzU2NDcg -NDI0NDYzNTY0NyA0MjQ0NjM1NjQ3IDQyNDQ2MzU2NDcgNDI0NDYzNTY0NyA0MjQ0NjM1NjQ3 -IDQyNDQ2MzU2NDcgNDI0NDYzNTY0NyA0MjQ0NjM1NjQ3IDQyNDQ2MzU2NDcgNDI5NDk2NzI5 -NSkKCW9mZnNldDogMEAwKSk7IGFkZDogKCdyZXNpemUtcmlnaHQucG5nJy0+KEZvcm0KCWV4 -dGVudDogMTZAMTYKCWRlcHRoOiAzMgoJZnJvbUFycmF5OiAjKCA0Mjc4MTkwMDgwIDQyNzgx -OTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4 -MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3 -ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQy -NzgxOTAwODAgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSAzODkyMjQ4NTc2IDQyOTQ5MDE3NjAg -NDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjc4MTI0NTQ0 -IDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQwMDk2ODkw -ODggNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAx -NzYwIDQyNzgxMjQ1NDQgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDAyNjQ2NjMwNCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0 -OTAxNzYwIDQyOTQ5MDE3NjAgNDI3ODEyNDU0NCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQy -OTQ5NjcyOTUgNDI5NDk2NzI5NSA0MDI2NDY2MzA0IDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0 -Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0MjYxMzQ3MzI4IDQyNzgxOTAwODAg -NDI3ODE5MDA4MCA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQwMjY0NjYzMDQgNDI5NDkwMTc2 -MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyNjEzNDcz -MjggNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3 -Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDAyNjQ2 -NjMwNCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5 -MDE3NjAgNDI2MTM0NzMyOCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDk2NzI5NSA0Mjk0 -OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0MDI2NDY2MzA0IDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQy -OTQ5MDE3NjAgNDI5NDkwMTc2MCA0MjYxMzQ3MzI4IDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQwNDMyNDM1MjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYw -IDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyNjEzNDczMjggNDI3ODE5MDA4 -MCA0Mjc4MTkwMDgwIDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDA0MzI0MzUyMCA0Mjk0OTAx -NzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI0NDU3 -MDExMiA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0MDYw -MDIwNzM2IDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5 -NDkwMTc2MCA0MjQ0NTcwMTEyIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0OTY3Mjk1IDQy -OTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQwNjAwMjA3MzYgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAg -NDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyNDQ1NzAxMTIgNDI3ODE5MDA4MCA0Mjc4MTkwMDgw -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDA2MDAyMDczNiA0Mjk0OTAxNzYwIDQyOTQ5MDE3 -NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI0NDU3MDExMiA0Mjc4MTkw -MDgwIDQyNzgxOTAwODAgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0MDc2Nzk3OTUyIDQyOTQ5 -MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0MjI3 -NzkyODk2IDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDM5 -OTI5MTE4NzIgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0 -Mjk0OTAxNzYwIDQyMTEwMTU2ODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAg -NDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgw -IDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4 -MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwKQoJb2Zmc2V0 -OiAwQDApKTsgYWRkOiAoJ3Jlc2l6ZS1ib3R0b20tcmlnaHQucG5nJy0+KEZvcm0KCWV4dGVu -dDogMTZAMTYKCWRlcHRoOiAzMgoJZnJvbUFycmF5OiAjKCA0Mjc4MTkwMDgwIDQyNzgxOTAw -ODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkw -MDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5 -MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgx -OTAwODAgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0 -OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQy -NzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3 -Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0 -OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyNzgxOTAwODAgNDI3 -ODE5MDA4MCA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQy -OTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDk2NzI5NSA0Mjk0OTY3 -Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0MTEw -NDE3OTE5IDM4OTIzMTQxMTEgMzg5MjMxNDExMSAzODkyMzE0MTExIDM4OTIzMTQxMTEgMzg5 -MjMxNDExMSA0MTEwNDE3OTE5IDQxMTAzNTIzODQgMzg5MjI0ODU3NiAzODkyMjQ4NTc2IDM4 -OTIyNDg1NzYgMzg5MjI0ODU3NiAzODkyMjQ4NTc2IDQxMTAzNTIzODQgNDI3ODE5MDA4MCA0 -Mjc4MTkwMDgwIDM4OTIzMTQxMTEgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDM4OTIzMTQxMTEgMzg5MjI0ODU3NiA0Mjk0OTAxNzYw -IDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgMzg5MjI0ODU3 -NiA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgMzg5MjMxNDExMSA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgMzg5MjMxNDExMSAzODkyMjQ4 -NTc2IDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkw -MTc2MCAzODkyMjQ4NTc2IDQyNzgxOTAwODAgNDI3ODE5MDA4MCAzODkyMzE0MTExIDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSAzODky -MzE0MTExIDM4OTIyNDg1NzYgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5 -NDkwMTc2MCA0Mjk0OTAxNzYwIDM4OTIyNDg1NzYgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDM4 -OTIzMTQxMTEgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDM4OTIzMTQxMTEgMzg5MjI0ODU3NiA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAg -NDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgMzg5MjI0ODU3NiA0Mjc4MTkwMDgw -IDQyNzgxOTAwODAgMzg5MjMxNDExMSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgMzg5MjMxNDExMSAzODkyMjQ4NTc2IDQyOTQ5MDE3 -NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCAzODkyMjQ4 -NTc2IDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0MTEwNDE3OTE5IDM4OTIzMTQxMTEgMzg5MjMx -NDExMSAzODkyMzE0MTExIDM4OTIzMTQxMTEgMzg5MjMxNDExMSA0MTEwNDE3OTE5IDQxMTAz -NTIzODQgMzg5MjI0ODU3NiAzODkyMjQ4NTc2IDM4OTIyNDg1NzYgMzg5MjI0ODU3NiAzODky -MjQ4NTc2IDQxMTAzNTIzODQgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3 -ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQy -NzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0 -Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwKQoJb2Zmc2V0OiAw -QDApKTsgYWRkOiAoJ3Jlc2l6ZS10b3AucG5nJy0+KEZvcm0KCWV4dGVudDogMTZAMTYKCWRl -cHRoOiAzMgoJZnJvbUFycmF5OiAjKCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4 -MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAw -ODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkw -MDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDkw -MTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5 -MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0 -OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyNzgxOTAwODAgNDI3 -ODE5MDA4MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQy -OTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0 -Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAg -NDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYw -IDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2 -MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3 -NjAgNDI5NDkwMTc2MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDkwMTc2MCA0Mjk0OTAx -NzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkw -MTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5 -MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0 -OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5 -NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQy -OTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI3ODE5MDA4MCA0 -Mjc4MTkwMDgwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAg -NDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYw -IDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2 -MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3 -NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAx -NzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkw -MTc2MCA0Mjk0OTAxNzYwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0 -OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQy -OTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjc4MTkwMDgw -IDQyNzgxOTAwODAgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3 -Mjk1IDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0 -OTY3Mjk1IDQyOTQ5NjcyOTUgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQy -OTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjc4MTkwMDgwIDQyNzgxOTAwODAg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyNzgxOTAw -ODAgNDI3ODE5MDA4MCA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3 -Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4 -MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3 -ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQy -NzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwKQoJb2Zmc2V0OiAwQDApKTsgYWRkOiAo -J3Jlc2l6ZS1ib3R0b20tbGVmdC5wbmcnLT4oRm9ybQoJZXh0ZW50OiAxNkAxNgoJZGVwdGg6 -IDMyCglmcm9tQXJyYXk6ICMoIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQy -NzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0 -Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAg -NDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI3ODE5MDA4MCA0Mjc4MTkw -MDgwIDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjc4 -MTkwMDgwIDQyNzgxOTAwODAgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQy -OTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3 -Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjc4MTkwMDgwIDQyNzgx -OTAwODAgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0 -OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQy -NzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQxMTAzNTIzODQgMzg5MjI0ODU3 -NiAzODkyMjQ4NTc2IDM4OTIyNDg1NzYgMzg5MjI0ODU3NiAzODkyMjQ4NTc2IDQxMTAzNTIz -ODQgNDExMDQxNzkxOSAzODkyMzE0MTExIDM4OTIzMTQxMTEgMzg5MjMxNDExMSAzODkyMzE0 -MTExIDM4OTIzMTQxMTEgNDExMDQxNzkxOSA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgMzg5MjI0 -ODU3NiA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5 -MDE3NjAgMzg5MjI0ODU3NiAzODkyMzE0MTExIDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0 -OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSAzODkyMzE0MTExIDQyNzgxOTAwODAgNDI3 -ODE5MDA4MCAzODkyMjQ4NTc2IDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQy -OTQ5MDE3NjAgNDI5NDkwMTc2MCAzODkyMjQ4NTc2IDM4OTIzMTQxMTEgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDM4OTIzMTQxMTEg -NDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDM4OTIyNDg1NzYgNDI5NDkwMTc2MCA0Mjk0OTAxNzYw -IDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDM4OTIyNDg1NzYgMzg5MjMxNDEx -MSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgMzg5MjMxNDExMSA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgMzg5MjI0ODU3NiA0Mjk0OTAx -NzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgMzg5MjI0 -ODU3NiAzODkyMzE0MTExIDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSAzODkyMzE0MTExIDQyNzgxOTAwODAgNDI3ODE5MDA4MCAzODky -MjQ4NTc2IDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5 -NDkwMTc2MCAzODkyMjQ4NTc2IDM4OTIzMTQxMTEgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQy -OTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDM4OTIzMTQxMTEgNDI3ODE5MDA4MCA0 -Mjc4MTkwMDgwIDQxMTAzNTIzODQgMzg5MjI0ODU3NiAzODkyMjQ4NTc2IDM4OTIyNDg1NzYg -Mzg5MjI0ODU3NiAzODkyMjQ4NTc2IDQxMTAzNTIzODQgNDExMDQxNzkxOSAzODkyMzE0MTEx -IDM4OTIzMTQxMTEgMzg5MjMxNDExMSAzODkyMzE0MTExIDM4OTIzMTQxMTEgNDExMDQxNzkx -OSA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAw -ODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkw -MDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5 -MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODApCglvZmZzZXQ6IDBAMCkpOyBhZGQ6ICgncmVz -aXplLXRvcC1yaWdodC5wbmcnLT4oRm9ybQoJZXh0ZW50OiAxNkAxNgoJZGVwdGg6IDMyCglm -cm9tQXJyYXk6ICMoIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAw -ODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkw -MDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5 -MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0MTEwNDE3OTE5IDM4OTIz -MTQxMTEgMzg5MjMxNDExMSAzODkyMzE0MTExIDM4OTIzMTQxMTEgMzg5MjMxNDExMSA0MTEw -NDE3OTE5IDQxMTAzNTIzODQgMzg5MjI0ODU3NiAzODkyMjQ4NTc2IDM4OTIyNDg1NzYgMzg5 -MjI0ODU3NiAzODkyMjQ4NTc2IDQxMTAzNTIzODQgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDM4 -OTIzMTQxMTEgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDM4OTIzMTQxMTEgMzg5MjI0ODU3NiA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAg -NDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgMzg5MjI0ODU3NiA0Mjc4MTkwMDgw -IDQyNzgxOTAwODAgMzg5MjMxNDExMSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgMzg5MjMxNDExMSAzODkyMjQ4NTc2IDQyOTQ5MDE3 -NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCAzODkyMjQ4 -NTc2IDQyNzgxOTAwODAgNDI3ODE5MDA4MCAzODkyMzE0MTExIDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSAzODkyMzE0MTExIDM4OTIy -NDg1NzYgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0 -OTAxNzYwIDM4OTIyNDg1NzYgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDM4OTIzMTQxMTEgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDM4 -OTIzMTQxMTEgMzg5MjI0ODU3NiA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0 -Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgMzg5MjI0ODU3NiA0Mjc4MTkwMDgwIDQyNzgxOTAwODAg -Mzg5MjMxNDExMSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgMzg5MjMxNDExMSAzODkyMjQ4NTc2IDQyOTQ5MDE3NjAgNDI5NDkwMTc2 -MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCAzODkyMjQ4NTc2IDQyNzgxOTAw -ODAgNDI3ODE5MDA4MCA0MTEwNDE3OTE5IDM4OTIzMTQxMTEgMzg5MjMxNDExMSAzODkyMzE0 -MTExIDM4OTIzMTQxMTEgMzg5MjMxNDExMSA0MTEwNDE3OTE5IDQxMTAzNTIzODQgMzg5MjI0 -ODU3NiAzODkyMjQ4NTc2IDM4OTIyNDg1NzYgMzg5MjI0ODU3NiAzODkyMjQ4NTc2IDQxMTAz -NTIzODQgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0 -OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQy -OTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyNzgxOTAwODAgNDI3ODE5MDA4 -MCA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3 -Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI3ODE5 -MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0 -OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQy -OTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI3ODE5MDA4MCA0Mjc4MTkw -MDgwIDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjc4 -MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3 -ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQy -NzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0 -Mjc4MTkwMDgwIDQyNzgxOTAwODApCglvZmZzZXQ6IDBAMCkpOyBhZGQ6ICgncmVzaXplLWxl -ZnQucG5nJy0+KEZvcm0KCWV4dGVudDogMTZAMTYKCWRlcHRoOiAzMgoJZnJvbUFycmF5OiAj -KCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAw -ODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkw -MDgwIDQyNzgxOTAwODAgNDI3ODI1NTg3MyA0Mjc5MzA4NTYxIDQyNzkzMDg1NjEgNDI3OTE3 -Njk3NSA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5 -MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjc4 -MTkwMDc5IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0MTYwNzQ5NTY3IDQxNjA3NDk1NjcgNDE3 -NzUyNjc4MyAzOTA5MDkxMzI3IDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0OTAxNzYwIDQy -OTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0 -Mjk0OTAxNzYwIDQyNjE0MTI4NjMgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQwMjY1MzE4MzkgNDI3ODE5MDA4MCA0Mjc4MTkwMDgw -IDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2 -MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI0NDYzNTY0NyA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDA0MzMwOTA1NSA0Mjc4MTkw -MDgwIDQyNzgxOTAwODAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkw -MTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0MjI3ODU4NDMxIDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0MDc2 -ODYzNDg3IDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5 -NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQy -MTEwODEyMTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQwOTM2NDA3MDMgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5MDE3NjAg -NDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYw -IDQyOTQ5MDE3NjAgNDE5NDMwMzk5OSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDExMDQxNzkxOSA0Mjc4MTkwMDgwIDQyNzgxOTAw -ODAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAx -NzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0MTc3NTI2NzgzIDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0MTQzOTcyMzUxIDQyNzgx -OTAwODAgNDI3ODE5MDA4MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0 -OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQxNDM5NzIzNTEgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQx -NjA3NDk1NjcgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0 -Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAg -NDEyNzE5NTEzNSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDE5NDMwMzk5OSA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDkwMTc2 -MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3 -NjAgNDI5NDkwMTc2MCA0MTEwNDE3OTE5IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3 -Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0MjExMDgxMjE1IDQyNzgxOTAwODAgNDI3ODE5 -MDA4MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5 -MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQwNzY4NjM0ODcgNDI5NDk2NzI5NSA0Mjk0 -OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyMjc4NTg0MzEgNDI3 -ODE5MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQy -OTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDA2MDA4NjI3MSA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI0NDYzNTY0NyA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYw -IDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2 -MCA0MDI2NTMxODM5IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0MjYxNDEyODYzIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0OTAx -NzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkw -MTc2MCA0Mjk0OTAxNzYwIDM4OTIzMTQxMTEgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDE0Mzk3MjM1MSA0MTQzOTcyMzUxIDQwNjAwODYyNzEgNDI3ODE5MDA4MCA0Mjc4 -MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3 -ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQy -NzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0 -Mjc4MTkwMDgwKQoJb2Zmc2V0OiAwQDApKTsgYWRkOiAoJ3Jlc2l6ZS5wbmcnLT4oRm9ybQoJ -ZXh0ZW50OiAxNkAxNgoJZGVwdGg6IDMyCglmcm9tQXJyYXk6ICMoIDQyNzgxOTAwODAgNDI3 -ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzg4NDgwMTAgNDI0MDE2MTcyMyA0MjI3ODU4NDMxIDQy -Mjc4NTg0MzEgNDIyNzg1ODQzMSA0MjI3ODU4NDMxIDQyMjc4NTg0MzEgNDIyNzg1ODQzMSA0 -MjM5ODk4NTUxIDQyNzk1NzE3MzMgNDI3OTE3Njk3NSA0Mjc4NzE2NDI0IDQyNzk3MDMzMTkg -NDI3ODE5MDA4MCA0Mjc4OTEzODAzIDQyNzkyNDI3NjggNDI5MDU1OTE2NCA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI4OTQ0MDY4MyA0Mjc4OTc5NTk2IDQyNzgyNTU4 -NzMgNDI3ODcxNjQyNCA0Mjc4MTkwMDgwIDQyNzkxNzY5NzUgNDI3OTMwODU2MSA0MjkwNDkz -MzcxIDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0MjkwNDkzMzcxIDQyNzky -NDI3NjggNDI3ODkxMzgwMyA0Mjc4NzE2NDI0IDQyNzg5MTM4MDMgNDI5MDY5MDc1MCA0Mjkx -MjE3MDk0IDQyNzk1NzE3MzMgNDI5MDAzMjgyMCA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0MjkwNDI3NTc4IDQy -Nzk1MDU5NDAgNDI5MDgyMjMzNiA0Mjg5NTcyMjY5IDQyNzkyNDI3NjggNDI1NzEzNjMxOCA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5MTIxNzA5NCA0Mjc5NTcxNzMzIDQyODk5NjcwMjcg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0MjkwMzYxNzg1 -IDQyNzk1MDU5NDAgNDI5MDg4ODEyOSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI1NjYwOTk3 -NCA0MjQ0NjM1NjQ3IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTE2MTE4 -NTIgNDI3OTc2OTExMiA0Mjg5OTY3MDI3IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0MjkwMzYx -Nzg1IDQyNzk3MDMzMTkgNDI5MTI4Mjg4NyA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0MjQ0NjM1NjQ3IDQyNDQ2MzU2NDcgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0MjkxNjExODUyIDQyNzk3NjkxMTIgNDI4OTkwMTIzNCA0Mjkw -MzYxNzg1IDQyNzk3MDMzMTkgNDI5MTI4Mjg4NyA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyNDQ2MzU2NDcgNDI0NDYzNTY0NyA0Mjk0OTY3Mjk1IDQy -OTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5MTYxMTg1MiA0 -Mjc5MzA4NTYxIDQyNzkyNDI3NjggNDI5MTI4Mjg4NyA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI0NDYzNTY0NyA0MjQ0NjM1NjQ3 -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0MjkwMjMwMTk5IDQyNzkzNzQzNTQgNDI3OTQ0MDE0NyA0Mjg5ODM1NDQxIDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0MjQ0NjM1 -NjQ3IDQyNDQ2MzU2NDcgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0MjkwMjMwMTk5IDQyNzk3MDMzMTkgNDI5MTM0ODY4MCA0MjkxNjc3NjQ1IDQyNzk3 -NjkxMTIgNDI4OTgzNTQ0MSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0 -OTY3Mjk1IDQyNDQ2MzU2NDcgNDI0NDYzNTY0NyA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0MjkwMjMwMTk5IDQyNzk3MDMzMTkgNDI5MTQxNDQ3MyA0Mjk0OTY3Mjk1IDQy -OTQ5NjcyOTUgNDI5MTc0MzQzOCA0Mjc5NzY5MTEyIDQyODk4MzU0NDEgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI0NDYzNTY0NyA0MjU3NTMxMDc2IDQyOTQ5NjcyOTUg -NDI5NDk2NzI5NSA0MjkwMTY0NDA2IDQyNzk3MDMzMTkgNDI5MTQxNDQ3MyA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTE3NDM0MzggNDI3OTc2OTEx -MiA0Mjg5NzY5NjQ4IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0MjU2OTM4OTM5IDQyNzk1MDU5 -NDAgNDI5MDU1OTE2NCA0MjkwMTY0NDA2IDQyNzk3NjkxMTIgNDI5MTQxNDQ3MyA0Mjk0OTY3 -Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0MjkxNzQzNDM4IDQyNzk4MzQ5MDUgNDI4OTc2OTY0OCA0MjkwNTU5MTY0IDQyNzg4 -NDgwMTAgNDI3ODU4NDgzOCA0Mjc4OTEzODAzIDQyNzkzNzQzNTQgNDI5MTY3NzY0NSA0Mjk0 -OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5MTY3NzY0NSA0Mjc5Mzc0MzU0IDQy -NzkwNDUzODkgNDI3ODE5MDA4MCA0Mjc4NTg0ODM4IDQyNzg0NTMyNTIgNDI3OTA0NTM4OSA0 -MjkwMDMyODIwIDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0MjkwNDI3NTc4 -IDQyNzg5MTM4MDMgNDI3ODQ1MzI1MiA0Mjc4MTkwMDgwIDQyNjE5MzkyMDggNDI3ODE5MDA4 -MCA0Mjc4MTkwMDgwIDQyNjE5MzkyMDggNDEwNTYxNTAzMCA0MDQzMzA5MDU1IDQwNDMzMDkw -NTUgNDA0MzMwOTA1NSA0MDQzMzA5MDU1IDQwNDMzMDkwNTUgNDA0MzMwOTA1NSA0MDg5Njkz -MTIzIDQyNDYxNDg4ODcgNDI2MjA3MDc5NCA0MjYyMDcwNzk0IDQyNDU0MjUxNjQpCglvZmZz -ZXQ6IDBAMCkpOyBhZGQ6ICgncmVzaXplLXRvcC1sZWZ0LnBuZyctPihGb3JtCglleHRlbnQ6 -IDE2QDE2CglkZXB0aDogMzIKCWZyb21BcnJheTogIyggNDI3ODE5MDA4MCA0Mjc4MTkwMDgw -IDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4 -MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAw -ODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkw -MDgwIDQxMTAzNTIzODQgMzg5MjI0ODU3NiAzODkyMjQ4NTc2IDM4OTIyNDg1NzYgMzg5MjI0 -ODU3NiAzODkyMjQ4NTc2IDQxMTAzNTIzODQgNDExMDQxNzkxOSAzODkyMzE0MTExIDM4OTIz -MTQxMTEgMzg5MjMxNDExMSAzODkyMzE0MTExIDM4OTIzMTQxMTEgNDExMDQxNzkxOSA0Mjc4 -MTkwMDgwIDQyNzgxOTAwODAgMzg5MjI0ODU3NiA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5 -NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgMzg5MjI0ODU3NiAzODkyMzE0MTExIDQy -OTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSAz -ODkyMzE0MTExIDQyNzgxOTAwODAgNDI3ODE5MDA4MCAzODkyMjQ4NTc2IDQyOTQ5MDE3NjAg -NDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCAzODkyMjQ4NTc2 -IDM4OTIzMTQxMTEgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDM4OTIzMTQxMTEgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDM4OTIyNDg1 -NzYgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAx -NzYwIDM4OTIyNDg1NzYgMzg5MjMxNDExMSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgMzg5MjMxNDExMSA0Mjc4MTkwMDgwIDQyNzgx -OTAwODAgMzg5MjI0ODU3NiA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0 -OTAxNzYwIDQyOTQ5MDE3NjAgMzg5MjI0ODU3NiAzODkyMzE0MTExIDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSAzODkyMzE0MTExIDQy -NzgxOTAwODAgNDI3ODE5MDA4MCAzODkyMjQ4NTc2IDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0 -Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCAzODkyMjQ4NTc2IDM4OTIzMTQxMTEg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDM4OTIzMTQxMTEgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQxMTAzNTIzODQgMzg5MjI0ODU3 -NiAzODkyMjQ4NTc2IDM4OTIyNDg1NzYgMzg5MjI0ODU3NiAzODkyMjQ4NTc2IDQxMTAzNTIz -ODQgNDExMDQxNzkxOSAzODkyMzE0MTExIDM4OTIzMTQxMTEgMzg5MjMxNDExMSAzODkyMzE0 -MTExIDM4OTIzMTQxMTEgNDExMDQxNzkxOSA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0 -OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyNzgxOTAwODAgNDI3 -ODE5MDA4MCA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQy -OTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDk2NzI5NSA0Mjk0OTY3 -Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0 -OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQy -OTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI3ODE5MDA4MCA0 -Mjc4MTkwMDgwIDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3 -Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgx -OTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4 -MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3 -ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCkKCW9mZnNldDogMEAw -KSk7IGFkZDogKCdyZXNpemUtYm90dG9tLnBuZyctPihGb3JtCglleHRlbnQ6IDE2QDE2Cglk -ZXB0aDogMzIKCWZyb21BcnJheTogIyggNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAw -ODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkw -MDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5 -MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0 -OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjc4MTkwMDgwIDQy -NzgxOTAwODAgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUg -NDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3 -Mjk1IDQyOTQ5NjcyOTUgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0 -OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5 -NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQy -OTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0 -Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyNzgxOTAwODAg -NDI3ODE5MDA4MCA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1 -IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5 -NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5Njcy -OTUgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3 -Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2 -NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5NjcyOTUgNDI5NDk2NzI5NSA0Mjk0OTY3Mjk1IDQyOTQ5 -NjcyOTUgNDI5NDk2NzI5NSA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDkwMTc2MCA0Mjk0 -OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5 -NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQy -OTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0 -Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAg -NDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYw -IDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI3ODE5MDA4 -MCA0Mjc4MTkwMDgwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3 -NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAx -NzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkw -MTc2MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5 -MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0 -OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5 -NDkwMTc2MCA0Mjk0OTAxNzYwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjk0OTAxNzYwIDQy -OTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0 -Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAg -NDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgw -IDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2 -MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3 -NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjc4MTkw -MDgwIDQyNzgxOTAwODAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkw -MTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5 -MDE3NjAgNDI5NDkwMTc2MCA0Mjk0OTAxNzYwIDQyOTQ5MDE3NjAgNDI5NDkwMTc2MCA0Mjk0 -OTAxNzYwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3 -ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQy -NzgxOTAwODAgNDI3ODE5MDA4MCA0Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCA0 -Mjc4MTkwMDgwIDQyNzgxOTAwODAgNDI3ODE5MDA4MCkKCW9mZnNldDogMEAwKSk7IHlvdXJz -ZWxmKSk7IHlvdXJzZWxmKSk7IHlvdXJzZWxmKQ=='! ! -!ContentPack methodsFor: 'generated code' stamp: 'jmv 9/28/2018 10:41:53'! -objectCount ^ 1! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - -Theme content merge: ContentPack decode. -ContentPack removeCategory: ContentPack generatedMethodsCategory! - -ContentPack removeSelector: #contentMap! - -ContentPack removeSelector: #object1! - -ContentPack removeSelector: #objectCount! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3463-AddNewResizeIcons-JuanVuletich-2018Sep28-12h19m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3461] on 2 October 2018 at 4:57:52 pm'! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 15:32:43'! - classOfBlockArgNamed: aName - - ^ nil! ! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 16:55:03'! - classOfBlockTempVarNamed: aName - - ^ nil! ! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 15:32:49'! - classOfInstVarNamed: aName - - ^ nil! ! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 15:32:56'! - classOfTempVarNamed: aName - - ^ nil! ! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 15:33:03'! - classOfThisContext - - ^ nil! ! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 15:33:09'! - classOfWorkspaceVarNamed: aName - - ^ nil! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 15:34:05'! - classOfBlockArgNamed: aName - - ^ textProvider classOfBlockArgNamed: aName ! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 16:56:47'! - classOfBlockTempVarNamed: aName - - ^ textProvider classOfBlockTempVarNamed: aName ! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 15:34:21'! - classOfInstVarNamed: aName - - ^ textProvider classOfInstVarNamed: aName ! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 15:34:36'! - classOfTempVarNamed: aName - - ^ textProvider classOfTempVarNamed: aName ! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 15:34:50'! - classOfThisContext - - ^ textProvider classOfThisContext ! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 15:35:04'! - classOfWorkspaceVarNamed: aName - - ^ textProvider classOfWorkspaceVarNamed: aName ! ! -!Workspace methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 15:50:00'! - classOfBindingOf: aName - - ^ (self bindingOf: aName) value ifNotNil: [ :aValue | aValue class ] ! ! -!Workspace methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 15:50:14'! - classOfTempVarNamed: aName - - ^ self classOfBindingOf: aName ! ! -!Workspace methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 15:50:27'! - classOfWorkspaceVarNamed: aName - - ^ self classOfBindingOf: aName ! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 9/28/2018 13:50:02'! - classOfBlockArgNamed: aName - - ^ nil! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 16:54:36'! - classOfBlockTempVarNamed: aName - - ^ nil! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 9/28/2018 13:50:17'! - classOfInstVarNamed: aName - - ^ nil! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 9/28/2018 13:50:42'! - classOfTempVarNamed: aName - - ^ nil! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 9/28/2018 13:51:28'! - classOfThisContext - - ^ nil! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 9/28/2018 13:51:53'! - classOfWorkspaceVarNamed: aName - - ^ nil! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 16:52:39'! - classOfBlockArgNamed: aName - - ^self classOfTempVarNamed: aName ! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 16:52:47'! - classOfBlockTempVarNamed: aName - - ^self classOfTempVarNamed: aName ! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 15:37:49'! - classOfInstVarNamed: aName - - ^ contextStackIndex ~= 0 ifTrue: [ (self receiver instVarNamed: aName) class]! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 16:53:29'! - classOfTempVarNamed: aName - - | context tempIndex | - - context := self selectedContext. - tempIndex := context tempNames indexOf: aName ifAbsent: [ ^ nil ]. - - ^ (self debuggerMap namedTempAt: tempIndex in: context) class - - ! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 15:52:45'! - classOfThisContext - - ^ self selectedContext class! ! -!Inspector methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 15:38:26'! - classOfInstVarNamed: aName - - ^ (object instVarNamed: aName) class ! ! -!Character methodsFor: 'testing' stamp: 'HAW 10/2/2018 16:31:57'! - isRightBracket - - ^self = $]! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 16:19:24'! - classOfBlockArgNamed: aName - - ^ nil! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 16:55:33'! - classOfBlockTempVarNamed: aName - - ^ nil! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 16:19:34'! - classOfInstVarNamed: aName - - ^ nil! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 16:19:42'! - classOfTempVarNamed: aName - - ^ nil! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 16:19:51'! - classOfThisContext - - ^ nil! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 10/2/2018 16:19:58'! - classOfWorkspaceVarNamed: aName - - ^ nil! ! -!AutoCompleter methodsFor: 'keyboard - private' stamp: 'HAW 10/2/2018 16:36:34'! - shouldOpenMorphWhenNoPrefixFor: currentChar - - ^currentChar isAlphaNumeric or: [ currentChar isRightBracket ]! ! -!AutoCompleter methodsFor: 'keyboard - private' stamp: 'HAW 10/2/2018 16:34:55' prior: 50414929! - shouldOpenMorphWhenNoPrefixAt: currentPos - - ^ model textSize >= currentPos - and: [ currentPos > 0 - and: [ self shouldOpenMorphWhenNoPrefixFor: (model actualContents at: currentPos) ]]! ! -!SmalltalkCompleter methodsFor: 'entries' stamp: 'HAW 10/2/2018 16:29:25' prior: 50415219! - computeEntries - - | allSource contextClass specificModel last3Ranges range | - - allSource _ model actualContents string. - specificModel _ self textProviderOrModel. - contextClass _ self selectedClassOrMetaClassIn: specificModel. - last3Ranges _ self parse: (allSource copyFrom: 1 to: position) in: contextClass and: specificModel. - range _ last3Ranges third ifNil: [ ^entries _ #() ]. - - range end = position - ifTrue: [ self computeEntriesOfMessageOrIdentifiersFor: allSource using: last3Ranges at: range in: contextClass and: specificModel ] - ifFalse: [ self computeMessageEntriesWithEmptyPrefixFor: allSource at: range in: contextClass and: specificModel ]. - - ! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 10/2/2018 16:50:09' prior: 50415382! -computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel - - | id receiverClass | - - id _ allSource copyFrom: range start to: range end. - receiverClass _ range rangeType - caseOf: { - [ #globalVar ] -> [ (Smalltalk at: id asSymbol) class ]. - [ #self ] -> [ contextClass ]. - [ #super ] -> [ contextClass superclass ]. - [ #true ] -> [ True ]. - [ #false ] -> [ False ]. - [ #nil ] -> [ UndefinedObject ]. - [ #character ] -> [ id first class ]. - [ #number ] -> [ self classOfLiteral: id in: contextClass ]. - [ #string ] -> [ self classOfLiteral: id in: contextClass ]. - [ #symbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #stringSymbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #instVar ] -> [ specificModel classOfInstVarNamed: id ]. - [ #tempVar ] -> [ specificModel classOfTempVarNamed: id ]. - [ #workspaceVar ] -> [ specificModel classOfWorkspaceVarNamed: id ]. - [ #blockArg ] -> [ specificModel classOfBlockArgNamed: id ]. - [ #blockTempVar ] -> [ specificModel classOfBlockTempVarNamed: id ]. - [ #thisContext ] -> [ specificModel classOfThisContext ]. - [ #classVar ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #poolConstant ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #blockEnd ] -> [ BlockClosure ]. } - otherwise: [ nil ]. - - self computeMessageEntries: receiverClass! ! - -SmalltalkCompleter removeSelector: #classOfBlockArgNamed:in:! - -SmalltalkCompleter removeSelector: #classOfBlockArgNamed:in:! - -SmalltalkCompleter removeSelector: #classOfBlockArgNamed:inDebugger:! - -SmalltalkCompleter removeSelector: #classOfBlockArgNamed:inDebugger:! - -SmalltalkCompleter removeSelector: #classOfInstVarNamed:in:! - -SmalltalkCompleter removeSelector: #classOfInstVarNamed:in:! - -SmalltalkCompleter removeSelector: #classOfInstVarNamed:inDebugger:! - -SmalltalkCompleter removeSelector: #classOfInstVarNamed:inDebugger:! - -SmalltalkCompleter removeSelector: #classOfInstVarNamed:inInspector:! - -SmalltalkCompleter removeSelector: #classOfInstVarNamed:inInspector:! - -SmalltalkCompleter removeSelector: #classOfTempVarNamed:in:! - -SmalltalkCompleter removeSelector: #classOfTempVarNamed:in:! - -SmalltalkCompleter removeSelector: #classOfTempVarNamed:inContext:! - -SmalltalkCompleter removeSelector: #classOfTempVarNamed:inContext:! - -SmalltalkCompleter removeSelector: #classOfTempVarNamed:inDebugger:! - -SmalltalkCompleter removeSelector: #classOfTempVarNamed:inDebugger:! - -SmalltalkCompleter removeSelector: #classOfTempVarNamed:inInspector:! - -SmalltalkCompleter removeSelector: #classOfTempVarNamed:inInspector:! - -SmalltalkCompleter removeSelector: #classOfTempVarNamed:inWorkspace:! - -SmalltalkCompleter removeSelector: #classOfTempVarNamed:inWorkspace:! - -SmalltalkCompleter removeSelector: #classOfThisContextIn:! - -SmalltalkCompleter removeSelector: #classOfThisContextIn:! - -SmalltalkCompleter removeSelector: #classOfThisContextInDebugger:! - -SmalltalkCompleter removeSelector: #classOfThisContextInDebugger:! - -SmalltalkCompleter removeSelector: #classOfWorkspaceVarNamed:in:! - -SmalltalkCompleter removeSelector: #classOfWorkspaceVarNamed:in:! - -SmalltalkCompleter removeSelector: #classOfWorkspaceVarNamed:inInspector:! - -SmalltalkCompleter removeSelector: #classOfWorkspaceVarNamed:inInspector:! - -SmalltalkCompleter removeSelector: #classOfWorkspaceVarNamed:inWorkspace:! - -SmalltalkCompleter removeSelector: #classOfWorkspaceVarNamed:inWorkspace:! - -SmalltalkCompleter removeSelector: #shouldOpenMorphWhenNoPrefixFor:! - -Debugger removeSelector: #classOfThisContextIn:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3464-SmalltalkCompleterEnhancements-HernanWilkinson-2018Sep28-13h49m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3464] on 3 October 2018 at 3:23:41 pm'! -!Float methodsFor: 'truncation and round off' stamp: 'nice 3/1/2014 00:32' prior: 16845048! - successor - | ulp | - self isFinite ifFalse: [ - (self isNaN or: [self positive]) ifTrue: [^self]. - ^Float fmax negated]. - ulp := self ulp. - ^self + (0.5 * ulp) = self - ifTrue: [self * -1.0 - ulp * -1.0 "This trick is for obtaining a negativeZero"] - ifFalse: [self + (0.5 * ulp)]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3465-Float-successor-fix-NicolasCellier-2018Oct03-14h28m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3430] on 1 October 2018 at 4:22:14 pm'! -!PreDebugWindow class methodsFor: 'instance creation' stamp: 'jmv 10/1/2018 16:21:56' prior: 50335176! - open: model label: aString message: messageString - | window | - (Preferences usePreDebugWindow or: [messageString notNil]) - ifTrue: [ - window _ self new. - window - model: model; - buildMorphicWindowMessage: messageString print. - aString ifNotNil: [ window setLabel: aString ]. - window openInWorld ] - ifFalse: [ - model openFullMorphicLabel: aString ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3466-UsePreDebugWindowIfMessageToUser-JuanVuletich-2018Oct01-16h21m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3466] on 3 October 2018 at 4:37:19 pm'! -!Float methodsFor: 'comparing' stamp: 'nice 10/27/2014 21:57'! - literalEqual: aFloat - "Two float literals can be replaced by a single one only if their representation have the same bits. - For example, zero and negativeZero are equal, but not literally equal." - - ^self class == aFloat class and: [(self at: 1) = (aFloat at: 1) and: [(self at: 2) = (aFloat at: 2)]]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3467-Float-literalEqual-JuanVuletich-2018Oct03-16h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3467] on 3 October 2018 at 5:18:30 pm'! -!Float methodsFor: 'arithmetic' stamp: 'nice 12/20/2012 23:16' prior: 16845131! - negated - "Answer a Number that is the negation of the receiver. - Implementation note: this version cares of negativeZero." - - ^-1.0 * self! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3468-Float-negated-fix-NicolasCellier-2018Oct03-17h18m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3468] on 3 October 2018 at 5:52:09 pm'! -!Fraction methodsFor: 'mathematical functions' stamp: 'nice 4/25/2018 09:43'! - floorLog: radix - "Unlike super, this version is exact when radix is integer" - - | d n | - radix isInteger ifFalse: [^super floorLog: radix]. - n := numerator floorLog: radix. - d := denominator floorLog: radix. - ^(numerator * (radix raisedTo: d)) - < (denominator * (radix raisedTo: n)) - ifTrue: [n - d - 1] - ifFalse: [n - d]! ! -!Integer methodsFor: 'mathematical functions' stamp: 'nice 4/25/2018 09:43'! - floorLog: radix - "Unlike super, this version is exact when radix is integer" - - radix isInteger ifFalse: [^super floorLog: radix]. - self <= 0 ifTrue: [^DomainError signal: 'floorLog: is only defined for x > 0.0']. - ^(self numberOfDigitsInBase: radix) - 1! ! -!Number methodsFor: 'mathematical functions' stamp: 'nice 12/11/2012 19:18' prior: 16880105! - floorLog: radix - "Answer the floor of the log base radix of the receiver." - - ^(self log: radix) floor! ! -!Float methodsFor: 'mathematical functions' stamp: 'nice 6/3/2012 17:26' prior: 16844655! - floorLog: radix - "Answer the floor of the log base radix of the receiver. - The result may be off by one due to rounding errors, except in base 2." - - (radix = 2 and: [self > 0.0 and: [self isFinite]]) ifTrue: [^self exponent]. - ^ (self log: radix) floor -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3469-floorLog-exactWhenPossible-JuanVuletich-2018Oct03-17h24m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3430] on 2 October 2018 at 4:54:47 pm'! -!ClosureTraceNode methodsFor: 'printing' stamp: 'sqr 10/2/2018 16:14:51'! - dumpOn: aStream - - self dumpOn: aStream depth: 0! ! -!ClosureTraceNode methodsFor: 'printing' stamp: 'sqr 10/2/2018 16:54:39'! - dumpOn: aStream depth: anInteger - - anInteger timesRepeat: [aStream tab]. - self printOn: aStream. - aStream newLine. - self paths do: [:each | each dumpOn: aStream depth: anInteger + 1]! ! -!ClosureTraceNode methodsFor: 'printing' stamp: 'sqr 10/2/2018 16:16:41'! - dumpString - - | answer | - answer := String new writeStream. - self dumpOn: answer. - ^answer contents! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3470-ClosureTraceNode-dumpString-ud-2018Oct02-16h14m-sq.st----! - -----SNAPSHOT----#(8 October 2018 11:01:54.56262 am) Cuis5.0-3470-v3.image priorSource: 2521040! - -----QUIT----#(8 October 2018 11:02:13.140988 am) Cuis5.0-3470-v3.image priorSource: 2748647! - -----STARTUP----#(22 October 2018 2:45:55.321668 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3470-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3470] on 8 October 2018 at 6:54:40 pm'! -!Character class methodsFor: 'class initialization' stamp: 'jmv 10/8/2018 18:36:22'! - releaseClassState - UnaccentedTable _ nil. - UnicodeCodePoints _ nil! ! -!Character class methodsFor: 'constants' stamp: 'jmv 10/8/2018 18:39:44'! - unaccentedTable - UnaccentedTable ifNil: [ self initializeLookupTables ]. - ^UnaccentedTable! ! -!Character class methodsFor: 'constants' stamp: 'jmv 10/8/2018 18:37:36'! - unicodeCodePoints - UnicodeCodePoints ifNil: [ self initializeUnicodeCodePoints ]. - ^UnicodeCodePoints! ! -!Color class methodsFor: 'cached state access' stamp: 'jmv 10/8/2018 18:29:30'! - releaseClassState - "Do not remove them in every image save (#releaseClassCachedState) to save startup time." - " - Color releaseClassState - " - CachedColormaps _ nil. "Maps to translate between color depths" - ToGrayColormaps _ nil. "Maps colors to 8bpp grays for various color depths" - FromGrayColormaps _ nil. "Maps from 8bpp grays to colors of various depths" - MaskingMap _ nil. "Maps all colors except transparent to black for creating a mask" - IndexedColors _ nil. - GrayToIndexMap _ nil! ! -!BitBlt class methodsFor: 'cached state access' stamp: 'jmv 10/8/2018 18:31:40'! - releaseClassState - "Do not remove them in every image save (#releaseClassCachedState) to save startup time." - - CachedFontColorMaps _ ColorConvertingMaps _ nil! ! -!StrikeFont class methodsFor: 'class cached access' stamp: 'jmv 10/8/2018 18:53:44'! - releaseClassState - "Do not remove them in every image save (#releaseClassCachedState) to save startup time." - " - StrikeFont releaseClassState - " - "Deallocate synthetically derived copies of base fonts to save space" - self allSubInstancesDo: [ :sf | sf reset ]! ! -!BitBltCanvas class methodsFor: 'cached state access' stamp: 'jmv 10/8/2018 18:33:14'! - releaseClassState - "Do not remove them in every image save (#releaseClassCachedState) to save startup time." - " - BitBltCanvas releaseClassState - " - CachedForms _ nil.! ! -!Behavior methodsFor: 'system startup' stamp: 'jmv 10/8/2018 18:31:00' prior: 16785005! - releaseClassCachedState - "Will be called for each class on shutdown or snapshot. - All class vars or class instVar vars that can be cheaply recreated lazily on demand, should be nilled. - For more expensive stuff to recreate, consider #releaseClassState that is not called on every image save. - See implementors for examples"! ! -!Character methodsFor: 'accessing' stamp: 'jmv 10/8/2018 18:39:19' prior: 16800364! - codePoint - " - self assert: $A codePoint hex = '16r41'. - self assert: $¤ codePoint hex = '16r20AC'. - " - ^self class unicodeCodePoints at: self numericValue + 1! ! -!Character methodsFor: 'converting' stamp: 'jmv 10/8/2018 18:44:52' prior: 16800616! - asUnaccented - " - $A asUnaccented - $Á asUnaccented - (0 to: 255) collect: [ :i | (Character numericValue: i) asUnaccented ] - (0 to: 255) collect: [ :i | (Character numericValue: i) asUnaccented asLowercase] - " - ^ Character - numericValue: (self class unaccentedTable at: self numericValue + 1)! ! -!Character class methodsFor: 'class initialization' stamp: 'jmv 10/8/2018 18:46:39' prior: 16800743! - initialize - "Create the table of unique Characters. - Character initialize - " - self initializeLookupTables . - self initializeUnicodeCodePoints.! ! -!Character class methodsFor: 'converting' stamp: 'jmv 10/8/2018 18:37:44' prior: 16801210! - iso8859s15CodeForUnicodeCodePoint: codePoint - " - Answer nil if the Unicode codePoint is not a valid ISO 8859-15 character - - self assert: (Character iso8859s15CodeForUnicodeCodePoint: 16r41) = $A iso8859s15Code. - self assert: (Character iso8859s15CodeForUnicodeCodePoint: 16r20AC) = $¤ iso8859s15Code. - " - | code | - code _ (self unicodeCodePoints indexOf: codePoint) -1. - code = -1 ifTrue: [ ^nil ]. - ^code! ! -!BitBltCanvas class methodsFor: 'cached state access' stamp: 'jmv 10/8/2018 18:33:24' prior: 16787424! - releaseClassCachedState - " - BitBltCanvas releaseClassCachedState - " - AccessProtect _ nil. - AuxForm _ nil. - AuxBlitter _ nil! ! - -StrikeFont class removeSelector: #releaseClassCachedState! - -StrikeFont class removeSelector: #releaseClassCachedState! - -BitBlt class removeSelector: #releaseClassCachedState! - -BitBlt class removeSelector: #releaseClassCachedState! - -Color class removeSelector: #releaseClassCachedState! - -Color class removeSelector: #releaseClassCachedState! - -Character class removeSelector: #initClassCachedState! - -Character class removeSelector: #initClassCachedState! - -Character class removeSelector: #releaseClassCachedState! - -Character class removeSelector: #releaseClassCachedState! - -Character initialize! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3471-KeepExpensiveCachedStuff-JuanVuletich-2018Oct08-18h41m-jmv.3.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3470] on 8 October 2018 at 4:36:36 pm'! -!Float methodsFor: 'comparing' stamp: 'jmv 10/8/2018 16:29:40' prior: 16845719! - hash - "Hash is reimplemented because = is implemented. Both words of the float are used. (The bitShift:'s ensure that the intermediate results do not become a large integer.) Care is taken to answer same hash as an equal Integer." - - | asInteger | - self isFinite ifTrue: [ - asInteger _ self truncated. - asInteger = self ifTrue: [ - ^ asInteger hash ]]. - ^ ((self basicAt: 1) bitShift: -4) + - ((self basicAt: 2) bitShift: -4)! ! -!Fraction methodsFor: 'comparing' stamp: 'jmv 10/8/2018 16:30:04' prior: 16849531! - hash - "Hash is reimplemented because = is implemented. - Care is taken that a Fraction equal to a Float also have an equal hash" - - ^ self asFloat hash! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3472-Fraction-hash-consistentWithFloat-JuanVuletich-2018Oct08-16h29m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3472] on 9 October 2018 at 9:53:17 am'! -!Float methodsFor: 'converting' stamp: 'jmv 10/8/2018 18:05:43'! - partBits: aThreeArgumentBlock - " - Extract the bits for Sign, Mantissa and Exponent parts of the Floating Point representation. - Just extract the bits. Do not add implicit bit. Do not correct denormals. Do not substract exponent bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. (f signPart * f significandAsInteger * (2 raisedToInteger: f exponentPart-52)) asFloat = f } print ]. - " - | allBits signBit exponentBits mantissaBits | - - " Extract the bits of an IEEE double float " - allBits _ ((self basicAt: 1) bitShift: 32) + (self basicAt: 2). - - " Extract the sign and the biased exponent " - signBit _ allBits bitShift: -63. - exponentBits _ (allBits bitShift: -52) bitAnd: 16r7FF. - - " Extract fractional part " - mantissaBits _ allBits bitAnd: 16r000FFFFFFFFFFFFF. - - "Evaluate the block" - ^aThreeArgumentBlock value: signBit value: exponentBits value: mantissaBits! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 10/8/2018 18:10:16'! - exponentBits - " - Actual bits for the exponent part of the Floating Point representation. - Just extract the bits. Do not correct denormals. Do not substract bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - { f. f exponentBits. f exponentPart. f exponent } print ]. - " - - self partBits: [ :signBit :exponentBits :mantissaBits | - ^ exponentBits ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 10/8/2018 18:23:14'! - mantissaBits - " - Actual bits for the mantissa part of the Floating Point representation. - Just extract the bits. Do not correct denormals. Do not substract bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - { f. f mantissaBits. f mantissaPart. f significand. } print ]. - " - self partBits: [ :signBit :exponentBits :mantissaBits | - ^ mantissaBits ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 10/8/2018 18:15:24'! - signBit - " - Actual bits for the exponent part of the Floating Point representation. - Just extract the bits. Do not correct denormals. Do not substract bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0. 0.0. -0.0} do: [ :f | - { f. f signBit. f signPart. f sign } print ]. - " - - self partBits: [ :signBit :exponentBits :mantissaBits | - ^ signBit ]! ! -!Float methodsFor: 'converting' stamp: 'jmv 10/8/2018 18:17:37' prior: 16844918! - partValues: aThreeArgumentBlock ifInfinite: infiniryBlock ifNaN: nanBlock - " - Float pi hex print - Float pi partValues: [ :sign :exponent :mantissa | { sign hex. exponent hex. mantissa hex} print ] - 0.0 partValues: [ :sign :exponent :mantissa | { sign hex. exponent hex. mantissa hex} print ] - For 0.0, exponent will be the minimum possible, i.e. -1023, and mantissa will be 0. - " - | sign exponent mantissa | - - self partBits: [ :signBit :exponentBits :mantissaBits | - - " Extract the sign" - sign _ signBit = 0 ifTrue: [1] ifFalse: [-1]. - - " Special cases: infinites and NaN" - exponentBits = 16r7FF ifTrue: [ - ^mantissaBits = 0 - ifTrue: [ infiniryBlock valueWithPossibleArgument: self ] - ifFalse: [ nanBlock valueWithPossibleArgument: self and: mantissaBits ]]. - - "Unbias exponent: 16r3FF is bias" - exponent _ exponentBits - 16r3FF. - - " Replace omitted leading 1 in fraction if appropriate" - "If expPart = 0, I am +/-zero or a denormal value. In such cases, no implicit leading bit in mantissa" - exponentBits = 0 - ifTrue: [ - mantissa _ mantissaBits. - exponent _ exponent + 1 ] - ifFalse: [ - mantissa _ mantissaBits bitOr: 16r0010000000000000 ]. - - "Evaluate the block" - ^aThreeArgumentBlock value: sign value: exponent value: mantissa - ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 10/8/2018 18:13:53' prior: 50414541! - significandAsInteger - "The actual bits in the mantissa of the receiver, as an integer number, including the implicit leading 1 if appropriate. - See #exponentPart - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. (f signPart * f significandAsInteger * (2 raisedToInteger: f exponentPart-52)) asFloat = f } print ]. - " - ^self mantissaPart! ! -!BoxedFloat64 methodsFor: 'truncation and round off' stamp: 'jmv 10/8/2018 17:52:44' prior: 50414558! - exponent - "Primitive. Consider the receiver to be represented as a power of two - multiplied by a mantissa between one and two or between -1 and -2 (#significand). - Answer with the SmallInteger to whose power two is raised. - Optional. See Object documentation whatIsAPrimitive. - See also #signPart, #significandAsInteger and #exponentPart - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. f significand . f exponent. f significand * (2 raisedToInteger: f exponent) = f } print ]. - " - - | positive | - - self >= 1.0 ifTrue: [^self floorLog: 2]. - self > 0.0 - ifTrue: - [positive _ (1.0 / self) exponent. - self = (1.0 / (1.0 timesTwoPower: positive)) - ifTrue: [^positive negated] - ifFalse: [^positive negated - 1]]. - self = 0.0 ifTrue: [^-1]. - ^self negated exponent! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3473-Float-partBits-JuanVuletich-2018Oct09-09h43m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3471] on 9 October 2018 at 2:29:53 pm'! -!LargeNegativeInteger methodsFor: 'comparing' stamp: 'jmv 10/9/2018 14:20:27'! - hash - - self > Float maxExactInteger negated ifFalse: [ - ^ self asFloat hash ]. - ^ByteArray - hashBytes: self - startingWith: self species hash! ! -!Float methodsFor: 'comparing' stamp: 'jmv 10/9/2018 12:30:01' prior: 50417715! - hash - "Hash is reimplemented because = is implemented. Both words of the float are used. (The bitShift:'s ensure that the intermediate results do not become a large integer.) Care is taken to answer same hash as an equal Integer." - - | asInteger | - self isFinite ifTrue: [ - asInteger _ self truncated. - asInteger abs < Float maxExactInteger ifTrue: [ - ^ asInteger hash ]]. - ^ ((self basicAt: 1) bitShift: -4) + - ((self basicAt: 2) bitShift: -4)! ! -!Fraction methodsFor: 'comparing' stamp: 'jmv 10/8/2018 16:30:04' prior: 50417732! - hash - "Hash is reimplemented because = is implemented. - Care is taken that a Fraction equal to a Float also have an equal hash" - - ^ self asFloat hash! ! -!Integer methodsFor: 'comparing' stamp: 'jmv 10/9/2018 12:30:19' prior: 50333045! - hash - "Hash is reimplemented because = is implemented. - | s | - s _ (1 to: 10000) asSet. - [s includes: 123456] bench - " - - self abs < Float maxExactInteger ifFalse: [ - ^ self asFloat hash ]. - ^self hashMultiply! ! -!LargePositiveInteger methodsFor: 'comparing' stamp: 'jmv 10/9/2018 14:20:30' prior: 16862513! - hash - - self < Float maxExactInteger ifFalse: [ - ^ self asFloat hash ]. - ^ByteArray - hashBytes: self - startingWith: self species hash! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3474-Integer-hash-consistentWithFloat-JuanVuletich-2018Oct09-14h19m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3474] on 9 October 2018 at 2:51:00 pm'! -!LargePositiveInteger methodsFor: 'comparing' stamp: 'jmv 10/9/2018 14:49:10' prior: 50417966! - hash - self < `(2 raisedToInteger: Float emax+1)` ifFalse: [ - ^ `Float infinity hash` ]. - self < Float maxExactInteger ifFalse: [ - ^ self asFloat hash ]. - ^ByteArray - hashBytes: self - startingWith: self species hash! ! -!LargeNegativeInteger methodsFor: 'comparing' stamp: 'jmv 10/9/2018 14:50:07' prior: 50417923! - hash - - self > `(2 raisedToInteger: Float emax+1) negated` ifFalse: [ - ^ `Float negativeInfinity hash` ]. - self > Float maxExactInteger negated ifFalse: [ - ^ self asFloat hash ]. - ^ByteArray - hashBytes: self - startingWith: self species hash! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3475-Faster-LargeInteger-hash-JuanVuletich-2018Oct09-14h38m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3476] on 9 October 2018 at 4:31:26 pm'! -!Number methodsFor: 'truncation and round off' stamp: 'jmv 10/9/2018 16:30:05' prior: 16880603! - rounded - "Answer the integer nearest the receiver." - "See https://en.wikipedia.org/wiki/Rounding#Round_half_to_even" - - | truncated fractionPartAbs | - truncated _ self truncated. - fractionPartAbs _ (self-truncated) abs. - fractionPartAbs = (1/2) - ifTrue: [ truncated even ifTrue: [^truncated] ifFalse: [^truncated + self sign]]. - fractionPartAbs < (1/2) - ifTrue: [^ truncated] - ifFalse: [^ truncated + self sign]! ! - -Float removeSelector: #rounded! - -Float removeSelector: #rounded! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3476-RoundHalfToEven-JuanVuletich-2018Oct09-16h28m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3476] on 10 October 2018 at 3:49:14 pm'! -!Integer methodsFor: 'comparing' stamp: 'jmv 10/10/2018 15:44:51' prior: 50417956! - hash - "Hash is reimplemented because = is implemented. - | s | - s _ (1 to: 10000) asSet. - [s includes: 123456] bench - " - - "Can only happen in 64 bits images..." - self abs < Float maxExactInteger ifFalse: [ - ^ self asFloat hash ]. - - "In 32 bit image it will always go this way" - ^self hashMultiply! ! -!LargePositiveInteger methodsFor: 'comparing' stamp: 'jmv 10/10/2018 15:44:55' prior: 50417981! - hash - - self < `(2 raisedToInteger: Float emax+1)` ifFalse: [ - ^ `Float infinity hash` ]. - - self < Float maxExactInteger ifFalse: [ - "Will always enter here for 64 bits images." - ^ self asFloat hash ]. - - "May only reach here in 32 bit images" - ^ByteArray - hashBytes: self - startingWith: self species hash! ! -!LargeNegativeInteger methodsFor: 'comparing' stamp: 'jmv 10/10/2018 15:45:00' prior: 50417991! - hash - - self > `(2 raisedToInteger: Float emax+1) negated` ifFalse: [ - ^ `Float negativeInfinity hash` ]. - - self > Float maxExactInteger negated ifFalse: [ - "Will always enter here for 64 bits images." - ^ self asFloat hash ]. - - "May only reach here in 32 bit images" - ^ByteArray - hashBytes: self - startingWith: self species hash! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3477-hashComments-JuanVuletich-2018Oct10-15h48m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3476] on 10 October 2018 at 3:58:36 pm'! -!Float methodsFor: 'comparing' stamp: 'jmv 10/10/2018 15:53:22' prior: 50417931! - hash - "Hash is reimplemented because = is implemented. Both words of the float are used. (The bitShift:'s ensure that the intermediate results do not become a large integer.) Care is taken to answer same hash as an equal Integer." - - | asInteger | - self isFinite ifTrue: [ - asInteger _ self truncated. - (asInteger = self and: [ asInteger abs < Float maxExactInteger ]) ifTrue: [ - ^ asInteger hash ]]. - ^ ((self basicAt: 1) bitShift: -4) + - ((self basicAt: 2) bitShift: -4)! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3478-Float-hash-fix-JuanVuletich-2018Oct10-15h49m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3478] on 18 October 2018 at 9:52:42 am'! -!Float methodsFor: 'comparing' stamp: 'jmv 10/18/2018 09:52:13' prior: 50418082! - hash - "Hash is reimplemented because = is implemented. Both words of the float are used. (The bitShift:'s ensure that the intermediate results do not become a large integer.) Care is taken to answer same hash as an equal Integer." - - | asInteger | - self isFinite ifTrue: [ - asInteger _ self truncated. - "See Integer>>#hash, LargePositiveInteger>>#hash and LargeNegativeInteger>>#hash" - "Very big integers will answer true when asked #= with their own conversion to Float, - But that Float will #asInteger to a different integer. Use Float hash in those cases. - In addition, there is a performance improvement: the hash in LargeIntegers could - get very slow for very big numbers" - (asInteger = self and: [ asInteger abs < Float maxExactInteger ]) ifTrue: [ - ^ asInteger hash ]]. - ^ ((self basicAt: 1) bitShift: -4) + - ((self basicAt: 2) bitShift: -4)! ! -!Integer methodsFor: 'comparing' stamp: 'jmv 10/18/2018 09:48:12' prior: 50418035! - hash - "Hash is reimplemented because = is implemented. - | s | - s _ (1 to: 10000) asSet. - [s includes: 123456] bench - " - - "Can only happen in 64 bits images... - See Float>>#hash, LargePositiveInteger>>#hash and LargeNegativeInteger>>#hash" - self abs < Float maxExactInteger ifFalse: [ - ^ self asFloat hash ]. - - "In 32 bit image it will always go this way" - ^self hashMultiply! ! -!LargePositiveInteger methodsFor: 'comparing' stamp: 'jmv 10/18/2018 09:48:28' prior: 50418048! - hash - - self < `(2 raisedToInteger: Float emax+1)` ifFalse: [ - ^ `Float infinity hash` ]. - - self < Float maxExactInteger ifFalse: [ - "Will always enter here for 64 bits images. - See Float>>#hash, Integer>>#hash and LargeNegativeInteger>>#hash" - ^ self asFloat hash ]. - - "May only reach here in 32 bit images" - ^ByteArray - hashBytes: self - startingWith: self species hash! ! -!LargeNegativeInteger methodsFor: 'comparing' stamp: 'jmv 10/18/2018 09:48:53' prior: 50418061! - hash - - self > `(2 raisedToInteger: Float emax+1) negated` ifFalse: [ - ^ `Float negativeInfinity hash` ]. - - self > Float maxExactInteger negated ifFalse: [ - "Will always enter here for 64 bits images. - See Float>>#hash, Integer>>#hash and LargePositiveInteger>>#hash" - ^ self asFloat hash ]. - - "May only reach here in 32 bit images" - ^ByteArray - hashBytes: self - startingWith: self species hash! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3479-Float-Integer-hash-comments-JuanVuletich-2018Oct18-09h46m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3478] on 18 October 2018 at 9:59:15 am'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 10/18/2018 09:58:57' prior: 50412783! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('FJG' 'Facundo Javier Gelatti') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3480-AddFacundoAsKnownAuthor-JuanVuletich-2018Oct18-09h52m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3470] on 12 October 2018 at 12:23:20 pm'! -!Debugger methodsFor: 'method creation' stamp: 'FJG 10/8/2018 12:49:55'! - askForSuperclassOf: aClass upTo: aSuperclass toImplement: aSelector withCaption: aCaptionText ifCancel: cancelBlock - - | classes chosenClassIndex | - - classes _ aClass = aSuperclass ifTrue: [ { aClass } ] ifFalse: [ aClass withAllSuperclassesUpTo: aSuperclass ]. - chosenClassIndex _ PopUpMenu - withCaption: aCaptionText - chooseFrom: (classes collect: [:c | c name]). - chosenClassIndex = 0 ifTrue: [^ cancelBlock value]. - - ^ classes at: chosenClassIndex! ! -!Debugger methodsFor: 'method creation' stamp: 'FJG 10/8/2018 12:38:20'! - implement: aMessage inCategory: aCategory fromClass: aClass context: aContext - - aClass - compile: (aMessage createStubMethodFor: aClass) - classified: aCategory. - - aContext privRefreshWith: (aClass lookupSelector: aMessage selector). - aMessage arguments withIndexDo: [ :arg :index | aContext tempAt: index put: arg ]. - self resetContext: aContext! ! -!Debugger methodsFor: 'method creation' stamp: 'FJG 10/8/2018 12:50:42' prior: 50336675! - askForSuperclassOf: aClass upTo: aSuperclass toImplement: aSelector ifCancel: cancelBlock - - ^ self askForSuperclassOf: aClass upTo: aSuperclass toImplement: aSelector withCaption: 'Define #', aSelector, ' in which class?' ifCancel: cancelBlock! ! -!Debugger methodsFor: 'method creation' stamp: 'FJG 10/12/2018 12:22:13'! - createMethodWhenDoesNotUnderstand - - | message chosenClass interruptedContext | - - "The doesNotUndertand context must be selected - Hernan" - contextStackIndex = 1 ifFalse: [ self contextStackIndex: 1 oldContextWas: self selectedContext ]. - - interruptedContext _ self interruptedContext. - message _ interruptedContext tempAt: 1. - - chosenClass _ self - askForSuperclassOf: interruptedContext receiver class - toImplement: message selector - ifCancel: [^self]. - - self implement: message inClass: chosenClass context: self selectedContext - -! ! -!Debugger methodsFor: 'method creation' stamp: 'FJG 10/12/2018 12:22:26' prior: 50336762! - createMethod - - self wasInterrupedOnDoesNotUnderstand ifTrue: [ ^self createMethodWhenDoesNotUnderstand ]. - self wasInterruptedOnSubclassResponsibility ifTrue: [ ^self createMethodOnSubclassResponsibility ]. - self wasInterruptedOnOverridableMethod ifTrue: [ ^self overrideMethodOnSubclass ]. - - self inform: 'Only available to override methods or for #doesNotUnderstand: and #subclassResponsibility' ! ! -!Debugger methodsFor: 'method creation' stamp: 'FJG 10/8/2018 12:37:52' prior: 50368123! - implement: aMessage inClass: aClass context: aContext - - self implement: aMessage inCategory: (self askForCategoryIn: aClass default: 'as yet unclassified') fromClass: aClass context: aContext! ! -!Debugger methodsFor: 'method creation' stamp: 'FJG 10/8/2018 13:20:36'! - overrideMethodOnSubclass - - | chosenClass lastPossibleClass message methodCategory methodClass receiverClass | - - methodCategory _ self interruptedContext method category. - methodClass _ self interruptedContext method methodClass. - receiverClass _ self interruptedContext receiver class. - lastPossibleClass _ (receiverClass withAllSuperclassesPreviousTo: methodClass) last. - message _ self interruptedContext messageForYourself. - - chosenClass _ self - askForSuperclassOf: receiverClass - upTo: lastPossibleClass - toImplement: message selector - withCaption: 'Override #', message selector, ' in which class?' - ifCancel: [^self]. - - ^ self implement: message inCategory: methodCategory fromClass: chosenClass context: self interruptedContext! ! -!Debugger methodsFor: 'method creation' stamp: 'FJG 10/8/2018 13:20:43'! - wasInterruptedOnOverridableMethod - | methodClass receiverClass | - - methodClass _ self interruptedContext method methodClass. - receiverClass _ self interruptedContext receiver class. - - ^ methodClass ~= receiverClass! ! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'FJG 10/8/2018 13:21:29'! - allSuperclassesPreviousTo: aSuperclass - - | superclasses | - - superclasses _ self allSuperclassesUpTo: aSuperclass. - - ^ superclasses allButLast! ! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'FJG 10/8/2018 13:21:39'! - withAllSuperclassesPreviousTo: aSuperclass - - | classes | - - classes _ self withAllSuperclassesUpTo: aSuperclass. - - ^ classes allButLast! ! - -Debugger removeSelector: #createMethodWhenDoesNotUndertand! - -Debugger removeSelector: #createMethodWhenDoesNotUndertand! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3481-OverrideMethodsOnDebugger-FJG.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3481] on 18 October 2018 at 10:40:55 am'! -!Theme class methodsFor: 'consistency verification' stamp: 'HAW 10/10/2018 16:57:50'! - verifyShoutConfig - - " - self verifyShoutConfig - " - ^self allSubclasses - inject: OrderedCollection new into: [ :errors :themeClass | - [ themeClass new generateShoutConfig ] on: Error do: [:anError | | atIfAbsentContext key | - "I have to do this because error is not resumable - Hernan" - atIfAbsentContext := thisContext. - 10 timesRepeat: [ atIfAbsentContext := atIfAbsentContext sender ]. - key := atIfAbsentContext tempAt: 1. - errors add: themeClass -> key. - atIfAbsentContext receiver at: key put: Color black. - atIfAbsentContext restart ]. - errors ]! ! -!Theme methodsFor: 'shout' stamp: 'jmv 10/18/2018 10:39:38' prior: 50401988! - shout - "Color symbols as an association list. - SHTextStylerST80 initialize - " - - ^ { - #defaults -> #black. - #undefined -> #red. - #comment -> #(green muchDarker). - #methodTags -> #(green muchDarker). - #pseudoVariables -> #(red muchDarker). - #literals -> #(green muchDarker). - #messages -> #(blue darker). - #arguments -> #(cyan muchDarker). - #instVar -> #(magenta muchDarker). - #incompleteMessages -> #(gray veryMuchDarker). - #blockLevelZero -> #black. - #blockLevelOne -> #brown. - #blockLevelTwo -> #magenta. - #blockLevelThree -> #red. - #blockLevelFour -> #(orange darker). - #blockLevelFive -> #(orange muchDarker). - #blockLevelSix -> #(green muchDarker). - #blockLevelSeven -> #blue. - #tempBar -> #gray. - #tempVars -> #(gray muchDarker). - }! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3482-VerifyShoutConfig-HernanWilkinson-2018Oct18-10h28m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3482] on 18 October 2018 at 11:06:39 am'! -!Float methodsFor: 'mathematical functions' stamp: 'RNG 10/12/2018 05:43:21' prior: 16844725! - sign: aNumber - "Return a Number with the same sign as aNumber and same magnitude as self. - Implementation is different from super to handle the special case of Float negativeZero." - - (self isZero and: [aNumber sign negative]) ifTrue: [^Float negativeZero]. - ^aNumber copySignTo: self! ! -!Float methodsFor: 'converting' stamp: 'jmv 10/18/2018 10:56:50' prior: 16844793! - asIEEE32BitWord - "Convert the receiver into a 32 bit Integer value representing the same number in IEEE 32 bit format. - Used for conversion in FloatArrays only." - - | word1 word2 sign mantissa exponent destWord truncatedBits mask roundToUpper | - - "quickly skip positive and negative zero" - self isZero ifTrue: [^self basicAt: 1]. - - "retrieve 64 bits of IEEE 754 double" - word1 := self basicAt: 1. - word2 := self basicAt: 2. - - "prepare sign exponent and mantissa of 32 bits float" - sign := word1 bitAnd: 16r80000000. - exponent := ((word1 bitShift: -20) bitAnd: 16r7FF) - 1023 + 127. - mantissa := (word2 bitShift: -29) + ((word1 bitAnd: 16rFFFFF) bitShift: 3). - truncatedBits := (word2 bitAnd: 16r1FFFFFFF). - - "We must now honour default IEEE rounding mode (round to nearest even)" - - "we are below gradual underflow, even if rounded to upper mantissa" - exponent < -24 ifTrue: [^sign "this can be negative zero"]. - - "BEWARE: rounding occurs on less than 23bits when gradual underflow" - exponent <= 0 - ifTrue: - [mask := 1 bitShift: exponent negated. - mantissa := mantissa bitOr: 16r800000. - roundToUpper := (mantissa bitAnd: mask) isZero not - and: [truncatedBits isZero not - or: [(mantissa bitAnd: mask - 1) isZero not - or: [(mantissa bitAnd: mask*2) isZero not]]]. - mantissa := mantissa bitShift: exponent - 1. - "exponent := exponent + 1"] - ifFalse: - [roundToUpper := (truncatedBits bitAnd: 16r10000000) isZero not - and: [(mantissa bitAnd: 16r1) isZero not - or: [(truncatedBits bitAnd: 16r0FFFFFFF) isZero not]] - ]. - - "adjust mantissa and exponent due to IEEE rounding mode" - roundToUpper - ifTrue: - [mantissa := mantissa + 1. - mantissa > 16r7FFFFF - ifTrue: - [mantissa := 0. - exponent := exponent+1]]. - - exponent > 254 ifTrue: ["Overflow" - exponent := 255. - self isNaN - ifTrue: [mantissa isZero - ifTrue: ["BEWARE: do not convert a NaN to infinity due to truncatedBits" - mantissa := 1]] - ifFalse: [mantissa := 0]]. - - "Encode the word" - destWord := (sign bitOr: ((exponent max: 0) bitShift: 23)) bitOr: mantissa. - ^ destWord! ! -!Float methodsFor: 'converting' stamp: 'RNG 10/12/2018 05:44:04' prior: 16844974! - withNegativeSign - "Same as super, but handle the subtle case of Float negativeZero" - - self isZero ifTrue: [^self class negativeZero]. - ^super withNegativeSign! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 10/18/2018 10:59:41' prior: 16845001! - predecessor - | ulp | - self isFinite ifFalse: [ - (self isNaN or: [self negative]) ifTrue: [^self]. - ^Float fmax]. - ulp := self ulp. - ^self - (0.5 * ulp) = self - ifTrue: [self - ulp] - ifFalse: [self - (0.5 * ulp)]! ! -!Float methodsFor: 'truncation and round off' stamp: 'RNG 10/12/2018 05:43:53' prior: 16845059! - ulp - "Answer the unit of least precision of self (the power of two corresponding to last bit of mantissa)" - - | exponent | - self isFinite ifFalse: [^self abs]. - self isZero ifTrue: [^Float fmin]. - exponent := self exponent. - ^exponent < self class emin - ifTrue: [Float fminDenormalized] - ifFalse: [Float epsilon timesTwoPower: exponent]! ! -!Float methodsFor: 'testing' stamp: 'RNG 10/12/2018 05:46:10' prior: 16845075! - isFinite - "simple, byte-order independent test for rejecting Not-a-Number and (Negative)Infinity" - - ^(self - self) isZero! ! -!Float methodsFor: 'printing' stamp: 'RNG 10/12/2018 05:43:01' prior: 50405006! - printAsIEEE32BitPrecisionFloatOn: aStream base: base - "Handle sign, zero, and NaNs; all other values passed to absPrintOn:base:mantissaSignificantBits: - Print as a 32 bit Float" - - self isNaN ifTrue: [aStream nextPutAll: 'NaN'. ^ self]. "check for NaN before sign" - self > 0.0 - ifTrue: [self absPrintOn: aStream base: base mantissaSignificantBits: 24] - ifFalse: - [self sign = -1 - ifTrue: [aStream nextPutAll: '-']. - self isZero - ifTrue: [aStream nextPutAll: '0.0'. ^ self] - ifFalse: [self negated absPrintOn: aStream base: base mantissaSignificantBits: 24]]! ! -!Float methodsFor: 'printing' stamp: 'RNG 10/12/2018 05:43:12' prior: 16845527! - printOn: aStream base: base - "Handle sign, zero, and NaNs; all other values passed to absPrintOn:base:" - - self isNaN ifTrue: [aStream nextPutAll: 'NaN'. ^ self]. "check for NaN before sign" - self > 0.0 - ifTrue: [self absPrintOn: aStream base: base] - ifFalse: - [self sign = -1 - ifTrue: [aStream nextPutAll: '-']. - self isZero - ifTrue: [aStream nextPutAll: '0.0'. ^ self] - ifFalse: [self negated absPrintOn: aStream base: base]]! ! -!Float methodsFor: 'printing' stamp: 'RNG 10/12/2018 05:43:39' prior: 16845574! - storeOn: aStream base: base - "Print the Number exactly so it can be interpreted back unchanged" - self isFinite - ifTrue: [self sign = -1 ifTrue: [aStream nextPutAll: '-']. - base = 10 ifFalse: [aStream print: base; nextPut: $r]. - self isZero - ifTrue: [aStream nextPutAll: '0.0'] - ifFalse: [self abs absPrintExactlyOn: aStream base: base]] - ifFalse: [self isNaN - ifTrue: [aStream nextPutAll: 'Float nan'] - ifFalse: [self > 0.0 - ifTrue: [aStream nextPutAll: 'Float infinity'] - ifFalse: [aStream nextPutAll: 'Float infinity negated']]]! ! -!Color methodsFor: 'access' stamp: 'RNG 10/12/2018 05:45:04' prior: 50353255! - hue - "Return the hue of this color, an angle in the range [0.0..360.0]. - Color orange hue - " - - | r g b max min span h | - r _ self red. - g _ self green. - b _ self blue. - max _ (r max: g) max: b. - min _ (r min: g) min: b. - span _ (max - min) asFloat. - span isZero ifTrue: [ ^ 0.0 ]. - - r = max ifTrue: [ - h _ ((g - b) asFloat / span) * 60.0. - ] ifFalse: [ - g = max - ifTrue: [ h _ 120.0 + (((b - r) asFloat / span) * 60.0). ] - ifFalse: [ h _ 240.0 + (((r - g) asFloat / span) * 60.0). ]. - ]. - - ^h mod: 360.0! ! -!Color methodsFor: 'access' stamp: 'RNG 10/12/2018 05:45:46' prior: 50353301! - saturation - "Return the saturation of this color, a value between 0.0 and 1.0. - Color red saturation - Color gray saturation - " - - | r g b max min | - r _ self red. - g _ self green. - b _ self blue. - max _ (r max: g) max: b. - min _ (r min: g) min: b. - max isZero ifTrue: [ ^0.0 ]. - ^max - min / max! ! -!Color class methodsFor: 'class initialization' stamp: 'RNG 10/12/2018 05:45:57' prior: 50354666! - initializeGrayToIndexMap - "Build an array of gray values available in the 8-bit colormap. This array is indexed by a gray level between black (1) and white (256) and returns the pixel value for the corresponding gray level." - "Note: This method must be called after initializeIndexedColors, since it uses IndexedColors." - " - Color initializeGrayToIndexMap - " - - | grayLevels grayIndices c distToClosest dist indexOfClosest indexedColors | - "record the level and index of each gray in the 8-bit color table" - grayLevels _ OrderedCollection new. - grayIndices _ OrderedCollection new. - indexedColors _ self indexedColors. - "Note: skip the first entry, which is reserved for transparent" - 2 to: indexedColors size do: [:i | - c _ indexedColors at: i. - c saturation isZero ifTrue: [ "c is a gray" - grayLevels add: (c green * 255) rounded. "0 to 255; R, G, and B are the same" - grayIndices add: i - 1]]. "pixel values are zero-based" - grayLevels _ grayLevels asArray. - grayIndices _ grayIndices asArray. - - "for each gray level in [0..255], select the closest match" - GrayToIndexMap _ ByteArray new: 256. - 0 to: 255 do: [ :level | - distToClosest _ 10000. "greater than distance to any real gray" - 1 to: grayLevels size do: [:i | - dist _ (level - (grayLevels at: i)) abs. - dist < distToClosest ifTrue: [ - distToClosest _ dist. - indexOfClosest _ grayIndices at: i]]. - GrayToIndexMap at: (level + 1) put: indexOfClosest]! ! -!TranslucentColor methodsFor: 'queries' stamp: 'RNG 10/12/2018 05:46:53' prior: 50356600! - isTransparent - ^ self alpha isZero! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3483-Use-isZero-NahuelGarbezza-2018Oct18-10h56m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3461] on 15 October 2018 at 10:06:14 pm'! -!Behavior methodsFor: 'as yet unclassified' stamp: 'HAW 10/15/2018 20:57:14'! - addMethodsTo: methodsReferencingLiteral thatReferenceTo: aLiteral special: specialFlag byte: specialByte - - | selectors | - - selectors _ self whichSelectorsReferTo: aLiteral special: specialFlag byte: specialByte. - selectors do: [ :sel | methodsReferencingLiteral add: (MethodReference class: self selector: sel) ]! ! -!Behavior methodsFor: 'as yet unclassified' stamp: 'HAW 10/15/2018 20:57:14'! - addTo: aSet methodsThatReferenceInHierarchyTo: aSymbol special: special byte: byte. - - self withAllSuperAndSubclassesDoGently: [ :class | - class addMethodsTo: aSet thatReferenceTo: aSymbol special: special byte: byte ] - ! ! -!Behavior methodsFor: 'as yet unclassified' stamp: 'HAW 10/15/2018 20:59:04'! - rejectSelectorsFrom: selectors thatReferenceTo: aLiteral byte: specialByte - - "For special selectors, look for the literal in the source code. - Otherwise, for example, searching for senders of #== will include senders of #ifNil. - Except for #at:put:, because it has two arguments and won't find it in the source code like that." - - ^ (specialByte isNil or: [ aLiteral = #at:put: ]) - ifTrue: [ selectors ] - ifFalse: [ selectors select: [ :sel | ((self sourceCodeAt: sel) findString: aLiteral) > 0]]! ! -!Behavior methodsFor: 'testing method dictionary' stamp: 'HAW 10/15/2018 21:56:17' prior: 16784461! - whichSelectorsReferTo: literal special: specialFlag byte: specialByte - "Answer a set of selectors whose methods access the argument as a literal." - - | who | - - Preferences thoroughSenders - ifTrue: [ who _ self thoroughWhichSelectorsReferTo: literal special: specialFlag byte: specialByte ] - ifFalse: [ - who _ Set new. - self selectorsAndMethodsDo: [:sel :method | - ((method hasLiteral: literal) or: [specialFlag and: [method scanFor: specialByte]]) ifTrue: [ - ((literal isVariableBinding) not or: [method sendsToSuper not - "N.B. (method indexOfLiteral: literal) < method numLiterals copes with looking for - Float bindingOf: #NaN, since (Float bindingOf: #NaN) ~= (Float bindingOf: #NaN)." - or: [(method indexOfLiteral: literal) ~= 0]]) ifTrue: [who add: sel]]]]. - - ^self rejectSelectorsFrom: who thatReferenceTo: literal byte: specialByte ! ! -!Behavior methodsFor: 'user interface' stamp: 'HAW 10/15/2018 20:58:17' prior: 50343709! -allLocalCallsOn: aSymbol - "Answer a SortedCollection of all the methods that call on aSymbol, anywhere in my class hierarchy." - - | aSet special byte cls | - - aSet _ Set new. - cls _ self theNonMetaClass. - special _ Smalltalk hasSpecialSelector: aSymbol ifTrueSetByte: [ :b | byte _ b ]. - - cls addTo: aSet methodsThatReferenceInHierarchyTo: aSymbol special: special byte: byte. - cls class addTo: aSet methodsThatReferenceInHierarchyTo: aSymbol special: special byte: byte. - - ^aSet! ! -!SystemDictionary methodsFor: 'retrieving' stamp: 'HAW 10/15/2018 20:57:14' prior: 50332942! - allCallsOn: aLiteral "Smalltalk browseAllCallsOn: #open:label:." - "Answer a Collection of all the methods that call on aLiteral." - | aCollection special byte | - - #(23 48 'fred' (new open:label:)) size. - "Example above should find #open:label:, though it is deeply embedded here." - - aCollection _ OrderedCollection new. - special _ self hasSpecialSelector: aLiteral ifTrueSetByte: [:b | byte _ b ]. - self allBehaviorsDo: [:class | class addMethodsTo: aCollection thatReferenceTo: aLiteral special: special byte: byte ]. - - ^ aCollection! ! -!SystemDictionary methodsFor: 'retrieving' stamp: 'HAW 10/15/2018 21:07:56' prior: 16922089! - numberOfSendersOf: aSymbol - "Answer the count of all the methods that call on aLiteral. - [ (Smalltalk numberOfSendersOf: #open:label:) ] timeToRun - [ (Smalltalk numberOfSendersOf: #==) ] timeToRun - " - | count specialFlag specialByte | - - count _ 0. - specialFlag _ self hasSpecialSelector: aSymbol ifTrueSetByte: [ :b | specialByte _ b ]. - self allBehaviorsDo: [ :class | - class selectorsAndMethodsDo: [ :sel :method | - ((method hasLiteral: aSymbol) or: [specialFlag and: [(method scanFor: specialByte) and: [ ((class sourceCodeAt: sel) findString: aSymbol) > 0 ]]]) - ifTrue: [ count _ count + 1 ]]]. - ^ count! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'HAW 10/15/2018 20:57:14' prior: 16924287! - browseViewReferencesFromNonViews - " - Smalltalk browseViewReferencesFromNonViews - " - | aLiteral aCollection | - - aCollection _ OrderedCollection new. - - "Tweak to look just for pluggables or also for menus (or maybe for all morphs)" -" PopUpMenu withAllSubclasses , MenuMorph withAllSubclasses , PluggableMorph withAllSubclasses do: [ :view |" - PluggableMorph withAllSubclassesDo: [ :view | -" MenuMorph withAllSubclassesDo: [ :view |" - - aLiteral _ view name. - - "tweak to linclude refs to SysWindow subhierarchy or not" - (view includesBehavior: SystemWindow) & false ifFalse: [ - Smalltalk allBehaviorsDo: [ :class | - ((class includesBehavior: Morph) or: [ class includesBehavior: Morph class ]) ifFalse: [ - class addMethodsTo: aCollection thatReferenceTo: aLiteral special: false byte: nil ]]]]. - - Smalltalk - browseMessageList: aCollection asSet asArray sort - name: 'References to Views from non-Views' - autoSelect: ''.! ! - -Behavior removeSelector: #addMethodsTo:thatReferTo:special:byte:! - -Behavior removeSelector: #addTo:referencesInHierarchyTo:special:byte:! - -Behavior removeSelector: #addTo:referencesTo:special:byte:! - -Behavior removeSelector: #addTo:referencesTo:special:byte:! - -Behavior removeSelector: #rejectSelectorsFrom:thatReferTo:byte:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3484-Fix-whichSelectorsReferTo-HernanWilkinson-2018Oct02-16h57m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3484] on 22 October 2018 at 2:36:01 pm'! -!MorphicTranslation methodsFor: 'transforming rects' stamp: 'jmv 10/22/2018 14:32:45' prior: 16878595! - displayBoundsOfTransformOf: aRectangle - "Externalize aRectangle, and find a bounding rectangle with horizontal - and vertical bounds and integer coordinates (i.e. adisplayBounds)." - - ^(aRectangle translatedBy: self translation) rounded! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3485-displayBounds-fix-JuanVuletich-2018Oct22-14h35m-jmv.1.cs.st----! - -----SNAPSHOT----#(22 October 2018 2:46:03.124313 pm) Cuis5.0-3485-v3.image priorSource: 2748744! - -----QUIT----#(22 October 2018 2:46:33.049559 pm) Cuis5.0-3485-v3.image priorSource: 2797526! - -----STARTUP----#(30 November 2018 9:34:20.981965 am) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3485-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3485] on 5 November 2018 at 1:32:47 pm'! -!CodeProvider methodsFor: 'annotation' stamp: 'jmv 11/5/2018 13:32:18' prior: 16811768! -annotationForSelector: aSelector ofClass: aClass - "Provide a line of content for an annotation pane, representing - information about the given selector and class" - | stamp sendersCount implementorsCount aCategory separator aString aList aComment stream requestList | - aSelector == #Comment - ifTrue: [^ self annotationForClassCommentFor: aClass]. - aSelector == #Definition - ifTrue: [^ self annotationForClassDefinitionFor: aClass]. - aSelector == #Hierarchy - ifTrue: [^ self annotationForHierarchyFor: aClass]. - stream _ WriteStream on: String new. - requestList _ self annotationRequests. - separator _ requestList size > 1 - ifTrue: [self annotationSeparator] - ifFalse: ['']. - requestList - do: [:aRequest | - aRequest == #firstComment - ifTrue: [ - aComment _ aClass firstCommentAt: aSelector. - aComment isEmptyOrNil - ifFalse: [stream nextPutAll: aComment , separator]]. - aRequest == #masterComment - ifTrue: [ - aComment _ aClass supermostPrecodeCommentFor: aSelector. - aComment isEmptyOrNil - ifFalse: [stream nextPutAll: aComment , separator]]. - aRequest == #documentation - ifTrue: [ - aComment _ aClass precodeCommentOrInheritedCommentFor: aSelector. - aComment isEmptyOrNil - ifFalse: [stream nextPutAll: aComment , separator]]. - aRequest == #timeStamp - ifTrue: [ - stamp _ self timeStamp. - stream - nextPutAll: (stamp size > 0 - ifTrue: [stamp , separator] - ifFalse: ['no timeStamp' , separator])]. - aRequest == #messageCategory - ifTrue: [ - aCategory _ aClass organization categoryOfElement: aSelector. - aCategory - ifNotNil: ["woud be nil for a method no longer present, - e.g. in a recent-submissions browser" - stream nextPutAll: aCategory , separator]]. - aRequest == #sendersCount - ifTrue: [ - sendersCount _ Smalltalk numberOfSendersOf: aSelector. - sendersCount _ sendersCount = 1 - ifTrue: ['1 sender'] - ifFalse: [sendersCount printString , ' senders']. - stream nextPutAll: sendersCount , separator]. - aRequest == #implementorsCount - ifTrue: [ - implementorsCount _ Smalltalk numberOfImplementorsOf: aSelector. - implementorsCount _ implementorsCount = 1 - ifTrue: ['1 implementor'] - ifFalse: [implementorsCount printString , ' implementors']. - stream nextPutAll: implementorsCount , separator]. - aRequest == #priorVersionsCount - ifTrue: [ - self - addPriorVersionsCountForSelector: aSelector - ofClass: aClass - to: stream]. - aRequest == #priorTimeStamp - ifTrue: [ - stamp _ VersionsBrowser - timeStampFor: aSelector - class: aClass - reverseOrdinal: 2. - stamp - ifNotNil: [stream nextPutAll: 'prior time stamp: ' , stamp , separator]]. - aRequest == #packages - ifTrue: [ - (aClass compiledMethodAt: aSelector ifAbsent: nil) ifNotNil: [ :cm | - (CodePackage packageOfMethod: cm methodReference ifNone: nil) - ifNil: [ stream nextPutAll: 'part of base system (i.e. not in a package)' ] - ifNotNil: [ :codePackage | - stream nextPutAll: 'in package '; nextPutAll: codePackage packageName ]. - stream nextPutAll: separator]]. - aRequest == #changeSets - ifTrue: [ - aList _ ChangeSet allChangeSetsWithClass: aClass selector: aSelector. - aList size > 0 - ifTrue: [aList size = 1 - ifTrue: [stream nextPutAll: 'only in change set '] - ifFalse: [stream nextPutAll: 'in change sets:']. - aList - do: [:aChangeSet | stream nextPut: Character space; nextPutAll: aChangeSet name ] - separatedBy: [ stream nextPut: $, ]] - ifFalse: [stream nextPutAll: 'in no change set']. - stream nextPutAll: separator]. - aRequest == #allChangeSets - ifTrue: [ - aList _ ChangeSet allChangeSetsWithClass: aClass selector: aSelector. - aList size > 0 - ifTrue: [aList size = 1 - ifTrue: [stream nextPutAll: 'only in change set '] - ifFalse: [stream nextPutAll: 'in change sets:']. - aList - do: [:aChangeSet | stream nextPut: Character space; nextPutAll: aChangeSet name ] - separatedBy: [ stream nextPut: $, ]] - ifFalse: [stream nextPutAll: 'in no change set']. - stream nextPutAll: separator]. - aRequest == #allBaseSystemChangeSets - ifTrue: [ - aList _ (ChangeSet allChangeSetsWithClass: aClass selector: aSelector) select: [ :it | it isForBaseSystem ]. - aList size > 0 - ifTrue: [ - aList size = 1 - ifTrue: [stream nextPutAll: 'only in base system change set'] - ifFalse: [stream nextPutAll: 'in base system change sets:']. - aList - do: [:aChangeSet | stream nextPut: Character space; nextPutAll: aChangeSet name ] - separatedBy: [ stream nextPut: $, ]] - ifFalse: [stream nextPutAll: 'in no base system change set']. - stream nextPutAll: separator]. - aRequest == #closuresInfo - ifTrue: [ - aString _ aClass closuresInfoAt: aSelector. - aString size > 0 - ifTrue: [stream nextPutAll: aString , separator]]. - ]. - ^ stream contents! ! -!Preferences class methodsFor: 'parameters' stamp: 'jmv 11/5/2018 13:23:10' prior: 16893375! - setDefaultAnnotationInfo - " - Preferences setDefaultAnnotationInfo - " - ^ self parameters at: #MethodAnnotations put: #(timeStamp messageCategory implementorsCount sendersCount packages changeSets)! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - -Preferences setDefaultAnnotationInfo! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3486-MethodAnnotationsEnhancements-JuanVuletich-2018Nov05-13h21m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3487] on 17 November 2018 at 11:46:04 am'! -!Collection methodsFor: 'private' stamp: 'HAW 11/17/2018 11:40:56'! - emptyCollectionDescription - - ^self class emptyCollectionDescription ! ! -!Collection class methodsFor: 'error descriptions' stamp: 'HAW 11/17/2018 11:41:14'! - emptyCollectionDescription - - ^'this collection is empty'! ! -!Collection methodsFor: 'private' stamp: 'HAW 11/17/2018 11:39:51' prior: 16814643! - errorEmptyCollection - - self error: self emptyCollectionDescription! ! -!Collection methodsFor: 'statistics' stamp: 'HAW 11/17/2018 11:34:23' prior: 50414780! - average: aBlock - - ^ self average: aBlock ifEmpty: [ self errorEmptyCollection ]! ! -!Collection methodsFor: 'statistics' stamp: 'HAW 11/17/2018 11:38:13'! - average: aBlock ifEmpty: emptyBlock - - ^ (self sum: aBlock ifEmpty: [ ^emptyBlock value ]) / self size! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3487-Average-ifEmpty-HernanWilkinson-2018Nov17-11h28m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3490] on 17 November 2018 at 1:28:17 pm'! -!Collection methodsFor: 'private' stamp: 'GC 11/17/2018 13:12:25'! - errorCollectionTooSmall - - self error: self class collectionTooSmallDescription! ! -!Collection class methodsFor: 'error descriptions' stamp: 'GC 11/17/2018 13:12:24'! - collectionTooSmallDescription - - ^ 'this collection is too small'! ! -!Collection class methodsFor: 'error descriptions' stamp: 'GC 11/17/2018 13:23:46'! - notKeyedDescription - - ^ 'Instances of {1} do not respond to keyed accessing messages.' format: { self className }! ! -!Collection class methodsFor: 'error descriptions' stamp: 'GC 11/17/2018 13:18:00'! - objectNotFoundDescription - - ^ 'Object is not in the collection'! ! -!Collection class methodsFor: 'error descriptions' stamp: 'GC 11/17/2018 13:17:06'! - sizesDoNotMatchDescription - - ^ 'collection sizes do not match'! ! -!Collection methodsFor: 'private' stamp: 'GC 11/17/2018 13:15:10' prior: 50419283! - errorEmptyCollection - - self error: self class emptyCollectionDescription! ! -!Collection methodsFor: 'private' stamp: 'GC 11/17/2018 13:17:21' prior: 16814647! - errorNoMatch - - self error: self class sizesDoNotMatchDescription! ! -!Collection methodsFor: 'private' stamp: 'GC 11/17/2018 13:18:15' prior: 16814651! - errorNotFound: anObject - "Actually, this should raise a special Exception not just an error." - - self error: self class objectNotFoundDescription! ! -!Collection methodsFor: 'private' stamp: 'GC 11/17/2018 13:23:53' prior: 16814658! - errorNotKeyed - - self error: self class notKeyedDescription -! ! -!Collection methodsFor: 'statistics' stamp: 'HAW 11/17/2018 11:34:23' prior: 50419288! - average: aBlock - - ^ self average: aBlock ifEmpty: [ self errorEmptyCollection ]! ! -!Collection methodsFor: 'statistics' stamp: 'HAW 11/17/2018 11:38:13' prior: 50419293! - average: aBlock ifEmpty: emptyBlock - - ^ (self sum: aBlock ifEmpty: [ ^emptyBlock value ]) / self size! ! -!Collection class methodsFor: 'error descriptions' stamp: 'GC 11/17/2018 13:13:11' prior: 50419278! - emptyCollectionDescription - - ^ 'this collection is empty'! ! -!SequenceableCollection methodsFor: 'accessing' stamp: 'GC 11/17/2018 13:12:01' prior: 16905895! - penultimate - "Answer the penultimate element of the receiver. - Raise an error if the collection is empty or has just one element." - - | size | - (size _ self size) < 2 ifTrue: [self errorCollectionTooSmall]. - ^ self at: size-1! ! - -Collection class removeSelector: #collectionToSmallDescription! - -Collection class removeSelector: #notKeyedDescription:! - -Collection removeSelector: #emptyCollectionDescription! - -Collection removeSelector: #emptyCollectionDescription! - -Collection removeSelector: #errorCollectionToSmall! - -Collection removeSelector: #errorCollectionToSmall! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3488-CollectionErrorsCleanup-GastonCaruso-2018Nov17-13h07m-GC.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3488] on 20 November 2018 at 12:19:12 pm'! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'jmv 11/20/2018 12:18:39' prior: 16798356! - fileOut - "File out the receiver, to a file whose name is a function of the - change-set name and either of the date & time or chosen to have a - unique numeric tag, depending on the preference - 'changeSetVersionNumbers'" - | slips nameToUse | - nameToUse _ self name. - nameToUse _ nameToUse copyReplaceAll: 'AuthorName' with: Utilities authorName asUnaccented asCamelCase. - nameToUse _ Preferences changeSetVersionNumbers - ifTrue: [ - DirectoryEntry currentDirectory - nextNameFor: nameToUse coda: '-', Utilities authorInitials - extension: 'cs.st' ] - ifFalse: [ (nameToUse , '.' , Utilities dateTimeSuffix , '.cs.st') asFileName ]. - - nameToUse asFileEntry writeStreamDo: [ :stream | - stream timeStamp. - self fileOutPreambleOn: stream. - self fileOutOn: stream. - self fileOutPostscriptOn: stream ]. - - self hasUnsavedChanges: false. - Preferences checkForSlips - ifFalse: [^ self]. - slips _ self checkForSlips. - (slips size > 0 - and: [(PopUpMenu withCaption: 'Methods in this fileOut have halts -or references to the Transcript -or other ''slips'' in them. -Would you like to browse them?' chooseFrom: 'Ignore\Browse slips') - = 2]) - ifTrue: [ Smalltalk browseMessageList: slips name: 'Possible slips in ' , name ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3489-fixChangeSetFilenamewhenAuthorUsesTilde-JuanVuletich-2018Nov20-12h18m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3485] on 11 November 2018 at 7:26:03 pm'! -!Parser methodsFor: 'public access' stamp: 'HAW 11/11/2018 19:31:01'! - parse: sourceStreamOrString class: behavior noPattern: aBoolean - - ^ self - parse: sourceStreamOrString readStream - class: behavior - noPattern: aBoolean - context: nil - notifying: nil - ifFail: [^nil]! ! -!Workspace methodsFor: 'accessing' stamp: 'HAW 11/11/2018 19:24:17'! - methodNodeOf: aSourceCode ifErrorsParsing: aParsingErrorBlock - - ^[ UndefinedObject methodNodeFor: aSourceCode noPattern: true ] on: Error do: aParsingErrorBlock -! ! -!CodeProvider methodsFor: 'contents' stamp: 'HAW 11/11/2018 19:21:24'! - methodNodeOf: aSourceCode ifErrorsParsing: aParsingErrorBlock - - ^[ self selectedClassOrMetaClass methodNodeFor: aSourceCode ] on: Error do: aParsingErrorBlock - ! ! -!Inspector methodsFor: 'contents' stamp: 'HAW 11/11/2018 19:21:12'! - methodNodeOf: aSourceCode ifErrorsParsing: aParsingErrorBlock - - ^[ self selectedClassOrMetaClass methodNodeFor: aSourceCode noPattern: true ] on: Error do: aParsingErrorBlock ! ! -!Behavior methodsFor: 'methods' stamp: 'HAW 11/11/2018 15:07:12'! - methodNodeFor: aSourceCode noPattern: aBoolean - - | parser methodNode | - - parser := self parserClass new - encoderClass: EncoderForV3PlusClosures; - yourself. - - methodNode := parser parse: aSourceCode class: self noPattern: aBoolean. - methodNode sourceText: aSourceCode. - - ^methodNode - ! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 11/11/2018 14:27:34'! - parseNodeIncluding: aPosition ifAbsent: aBlockClosure - - | smallestRangeSize nodeWithRangeAtPosition | - - smallestRangeSize := SmallInteger maxVal. - nodeWithRangeAtPosition := nil. - - sourceRanges associationsDo: [ :nodeAtRange | - self withRangesOf: nodeAtRange including: aPosition do: [ :aRange | | currentNodeRangeSize | - currentNodeRangeSize := aRange size. - currentNodeRangeSize < smallestRangeSize ifTrue: [ - smallestRangeSize := currentNodeRangeSize. - nodeWithRangeAtPosition := nodeAtRange key -> aRange ]]]. - - ^ nodeWithRangeAtPosition ifNil: aBlockClosure ifNotNil: [ nodeWithRangeAtPosition ] - ! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 11/11/2018 14:26:13'! - withRangesOf: nodeAtRange including: aPosition do: aBlock - - | currentNodeRange ranges | - - currentNodeRange := nodeAtRange value. - ranges := currentNodeRange isInterval ifTrue: [ Array with: currentNodeRange ] ifFalse: [ currentNodeRange ]. - - ranges do: [ :aRange | (aRange includes: aPosition) ifTrue: [ aBlock value: aRange ]]. - - ! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 11/11/2018 14:16:41'! - parseNodeIncluding: aPosition ifAbsent: aBlockClosure - - ^encoder parseNodeIncluding: aPosition ifAbsent: aBlockClosure -! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'HAW 11/11/2018 14:29:56'! - implementorsOfItWhenErrorsParsing - - "Open an implementors browser on the selected selector" - - | aSelector | - - self lineSelectAndEmptyCheck: [^ self]. - (aSelector _ self selectedSelector) ifNil: [^ morph flash]. - Smalltalk browseAllImplementorsOf: aSelector! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'HAW 11/11/2018 14:15:34'! - sendersOfItWhenErrorsParsing - - "Open a senders browser on the selected selector" - - | aSelector | - - self lineSelectAndEmptyCheck: [^ self]. - (aSelector _ self selectedSelector) ifNil: [^ morph flash]. - Smalltalk browseAllCallsOn: aSelector! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'HAW 11/11/2018 14:36:04'! - withSelectorUnderCursorDo: aBlock ifErrorsParsing: aParsingErrorBlock - - self withSelectorUnderCursorDo: aBlock ifErrorsParsing: aParsingErrorBlock ifNoSelector: [ morph flash ]! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'HAW 11/11/2018 15:30:45'! - withSelectorUnderCursorDo: aBlock ifErrorsParsing: aParsingErrorBlock ifNoSelector: aNoSelectorBlock - - | methodNode nodeAtRange nodeUnderCursor | - - methodNode := self codeProvider methodNodeOf: model actualContents ifErrorsParsing: [ :anError | ^ aParsingErrorBlock value: anError ]. - - self startIndex < methodNode selectorLastPosition ifTrue: [ ^aBlock value: methodNode selector ]. - nodeAtRange := methodNode parseNodeIncluding: self startIndex ifAbsent: [ ^ aNoSelectorBlock value ]. - nodeUnderCursor := nodeAtRange key. - nodeUnderCursor isMessageNode ifTrue: [ ^aBlock value: nodeAtRange key selector key ]. - (nodeUnderCursor isLiteralNode and: [ nodeUnderCursor literalValue isSymbol ]) ifTrue: [ ^aBlock value: nodeUnderCursor literalValue ]. - - ^ aNoSelectorBlock value ! ! -!Behavior methodsFor: 'methods' stamp: 'HAW 11/11/2018 15:07:41' prior: 50408642! - methodNodeFor: aSourceCode - - ^self methodNodeFor: aSourceCode noPattern: false! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 11/11/2018 15:21:21'! - selectorLastPosition - - "If #DoIt selector, returns 0 - Hernan" - - ^self selector isUnary - ifTrue: [ selectorKeywordsRanges ifNil: [ 0 ] ifNotNil: [ selectorKeywordsRanges last last ]] - ifFalse: [ (encoder sourceRangeFor: arguments last) first last ]! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'HAW 11/11/2018 14:32:52' prior: 16909904! - implementorsOfIt - - "Open an implementors browser on the selector under cursor. If it can not parse the source code it uses - old implementation that looks for the selected selector if any - Hernan" - - self - withSelectorUnderCursorDo: [ :aSelector | Smalltalk browseAllImplementorsOf: aSelector ] - ifErrorsParsing: [ :anError | self implementorsOfItWhenErrorsParsing ] - -! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'HAW 11/11/2018 15:13:54' prior: 16909977! - sendersOfIt - - "Open a senders browser on the selector under cursor. If it can not parse the source code it uses - old implementation that looks for the selected selector if any - Hernan" - - self - withSelectorUnderCursorDo: [ :aSelector | Smalltalk browseAllCallsOn: aSelector ] - ifErrorsParsing: [ :anError | self sendersOfItWhenErrorsParsing ] -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3490-SendersImplementorsEnhancements-HernanWilkinson-2018Nov11-14h14m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3490] on 20 November 2018 at 12:51:56 pm'! -!Message methodsFor: 'comparing' stamp: 'jmv 11/20/2018 12:51:32'! - = aMessage - - "Any object is equal to itself" - self == aMessage ifTrue: [ ^ true ]. - - self class == aMessage class ifFalse: [ ^false ]. - selector = aMessage selector ifFalse: [ ^false ]. - lookupClass = aMessage lookupClass ifFalse: [ ^false ]. - ^args = aMessage arguments! ! -!Message methodsFor: 'comparing' stamp: 'jmv 11/20/2018 12:47:30'! - hash - "Hash is reimplemented because = is implemented." - ^selector hash bitXor: args hash! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3491-MessageEqualAndHash-JuanVuletich-2018Nov20-12h46m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3485] on 26 October 2018 at 6:11:52 am'! - -"Change Set: 3486-CuisCore-AuthorName-2018Oct26-06h03m -Date: 26 October 2018 -Author: Nahuel Garbezza - -This adds some shortcuts to browser category list section"! -!CodeWindow methodsFor: 'keyboard shortcuts' stamp: 'RNG 10/26/2018 06:10:22' prior: 50338653! - systemCatListKey: aChar from: view - "Respond to a Command key. I am a model with a code pane, and I also have a listView that has a list of methods. The view knows how to get the list and selection." - - aChar == $f ifTrue: [ ^ self findClass ]. - aChar == $x ifTrue: [ ^ model removeSystemCategory ]. - aChar == $t ifTrue: [ ^ model runSystemCategoryTests ]. - aChar == $a ifTrue: [ ^ model addSystemCategory ]. - aChar == $A ifTrue: [ ^ model alphabetizeSystemCategories ]. - aChar == $b ifTrue: [ ^ self openSystemCategoryBrowser ]. - aChar == $B ifTrue: [ ^ self browseAllClasses ]. - aChar == $o ifTrue: [ ^ model fileOutSystemCategory ]. - aChar == $u ifTrue: [ ^ model updateSystemCategories ]. - - ^ self classListKey: aChar from: view! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'RNG 10/26/2018 06:10:09' prior: 50411774! - systemCategoryMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'find class... (f)'. - #selector -> #findClass. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'recent classes... (r)'. - #object -> #model. - #selector -> #recent. - #icon -> #clockIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'browse all (B)'. - #selector -> #browseAllClasses. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'browse (b)'. - #selector -> #openSystemCategoryBrowser. - #icon -> #packageIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'fileOut (o)'. - #object -> #model. - #selector -> #fileOutSystemCategory. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'reorganize'. - #object -> #model. - #selector -> #editSystemCategories. - #icon -> #sendReceiveIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'alphabetize (A)'. - #object -> #model. - #selector -> #alphabetizeSystemCategories. - #icon -> #fontXGenericIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'update (u)'. - #object -> #model. - #selector -> #updateSystemCategories. - #icon -> #updateIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 20. - #label -> 'add item... (a)'. - #object -> #model. - #selector -> #addSystemCategory. - #icon -> #newIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'rename...'. - #object -> #model. - #selector -> #renameSystemCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 40. - #label -> 'remove (x)'. - #object -> #model. - #selector -> #removeSystemCategory. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'move to top'. - #object -> #model. - #selector -> #moveSystemCategoryTop. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 20. - #label -> 'move up'. - #object -> #model. - #selector -> #moveSystemCategoryUp. - #icon -> #goUpIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 30. - #label -> 'move down'. - #object -> #model. - #selector -> #moveSystemCategoryDown. - #icon -> #goDownIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 40. - #label -> 'move to bottom'. - #object -> #model. - #selector -> #moveSystemCategoryBottom. - #icon -> #goBottomIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 10. - #label -> 'run tests (t)'. - #object -> #model. - #selector -> #runSystemCategoryTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - }`. - ! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3492-SystemCategoryMenuOptionsEnh-NahuelGarbezza-2018Oct26-06h03m-RNG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3492] on 20 November 2018 at 7:10:56 pm'! -!Message methodsFor: 'comparing' stamp: 'jmv 11/20/2018 19:10:34' prior: 50419649! - = aMessage - - "Any object is equal to itself" - self == aMessage ifTrue: [ ^ true ]. - - self class == aMessage class ifFalse: [ ^false ]. - selector = aMessage selector ifFalse: [ ^false ]. - lookupClass = aMessage lookupClass ifFalse: [ ^false ]. - ^args literalEqual: aMessage arguments! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3493-MessageEqualFix-JuanVuletich-2018Nov20-19h10m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3485] on 8 November 2018 at 6:23:20 pm'! -!BlockClosure methodsFor: 'scheduling' stamp: 'jmv 11/8/2018 18:23:08' prior: 16788299! - fork - "Create and schedule a Process running the code in the receiver." - - "jmv - Do NOT answer the new process. - - See http://lists.squeakfoundation.org/pipermail/squeak-dev/2008-February/124960.html - - Most times, these methods return before resuming the new process (if priority of new process is less - or equal than current). But they might return afterwards. - - This means it is very dangerous to use the returned process in code that stores it in some variable - and checks for nil to start a new one. If these methods happen to return after the new process is forked, - chances are the code that starts all this runs again, that variable is nil, and a second process is forked, - perhaps breaking some shared state. This kind of bug is hard to spot and debug. - - Callers wanting the new process object, should call #newProcess, store the answer, and then #resume. - - A way to ensure this bug will not ever happen again is just to answer nil" - - self newProcess resume. - ^nil! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3494-fork-commentEnh-JuanVuletich-2018Nov08-18h22m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3494] on 21 November 2018 at 5:40:44 pm'! -!Float methodsFor: 'comparing' stamp: 'jmv 11/21/2018 17:04:24' prior: 50418107! - hash - "Hash is reimplemented because = is implemented." - - | asInteger | - self isFinite ifTrue: [ - asInteger _ self truncated. - "See Integer>>#hash, LargePositiveInteger>>#hash and LargeNegativeInteger>>#hash" - "Very big integers will answer true when asked #= with their own conversion to Float, - But that Float will #asInteger to a different integer. Use Float hash in those cases, to ensure equal hash value. - In addition, there is a performance improvement: the hash in LargeIntegers could - get very slow for very big numbers" - (asInteger = self and: [ asInteger abs < Float maxExactInteger ]) ifTrue: [ - ^ asInteger hash ]]. - "Both words of the float are used. (The bitShift:'s ensure that the intermediate results do not become a large integer.) - Care is taken to answer same hash as an equal Integer." - ^ ((self basicAt: 1) bitShift: -4) + - ((self basicAt: 2) bitShift: -4)! ! -!LargePositiveInteger methodsFor: 'comparing' stamp: 'jmv 11/21/2018 17:32:14' prior: 50418152! - hash - - self < `(2 raisedToInteger: Float emax+1)` ifFalse: [ - ^ `Float infinity hash` ]. - - self < Float maxExactInteger ifFalse: [ - "Will always enter here for 64 bits images. - See Float>>#hash, Integer>>#hash and LargeNegativeInteger>>#hash" - ^ self asFloat hash ]. - - "May normally only reach here in 32 bit images" - - "If could be a SmallInteger (regardless of the current word size, we want consistency between 32/64 bit systems)" - self digitLength <= 8 ifTrue: [ - ^ self hashMultiply ]. - - ^ByteArray - hashBytes: self - startingWith: self species hash! ! -!LargeNegativeInteger methodsFor: 'comparing' stamp: 'jmv 11/21/2018 17:32:25' prior: 50418167! - hash - - self > `(2 raisedToInteger: Float emax+1) negated` ifFalse: [ - ^ `Float negativeInfinity hash` ]. - - self > Float maxExactInteger negated ifFalse: [ - "Will always enter here for 64 bits images. - See Float>>#hash, Integer>>#hash and LargePositiveInteger>>#hash" - ^ self asFloat hash ]. - - "May normally only reach here in 32 bit images" - - "If could be a SmallInteger (regardless of the current word size, we want consistency between 32/64 bit systems)" - self digitLength <= 8 ifTrue: [ - ^ self hashMultiply ]. - - ^ByteArray - hashBytes: self - startingWith: self species hash! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3495-SmallInteger-LargeInteger-hash-consistency-JuanVuletich-2018Nov21-16h56m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3495] on 27 November 2018 at 9:04:27 am'! - -"Change Set: 3497-CuisCore-AuthorName-2018Nov27-09h04m -Date: 27 November 2018 -Author: Juan Vuletich -" -(FeatureRequirement name: 'Statistics') isAlreadySatisfied ifTrue: [ self inform: 'You have the Statistics package already loaded in this image. Please reinstall it after loading this change set (#3496).' ]! - -SortedCollection removeSelector: #median! - -SortedCollection removeSelector: #median! - -Collection removeSelector: #median! - -Collection removeSelector: #median! - -Collection removeSelector: #sampleStandardDeviation! - -Collection removeSelector: #sampleStandardDeviation! - -Collection removeSelector: #sampleVariance! - -Collection removeSelector: #sampleVariance! - -Collection removeSelector: #standardDeviation! - -Collection removeSelector: #standardDeviation! - -Collection removeSelector: #variance! - -Collection removeSelector: #variance! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3496-CleanBaseImageOfPackageStuff-JuanVuletich-2018Nov27-08h55m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3496] on 27 November 2018 at 9:20:13 am'! -!Color class methodsFor: 'instance creation' stamp: 'jmv 11/26/2018 17:17:17' prior: 50354347! - colorFrom: parm - "Return an instantiated color from parm. If parm is already a color, return it, else return the result of my performing it if it's a symbol or, if it is a list, it can either be an array of three numbers, which will be interpreted as RGB values, or a list of symbols, the first of which is sent to me and then the others of which are in turn sent to the prior result, thus allowing entries of the form #(blue darker). Else just return the thing" - - | aColor firstParm | - (parm is: #Color) ifTrue: [ ^ parm ]. - parm isSymbol ifTrue: [ ^ self perform: parm ]. - parm isString ifTrue: [ ^ self fromHexString: parm ]. - (parm isSequenceableCollection and: [ parm size > 0 ]) - ifTrue: [ - firstParm _ parm first. - firstParm isNumber ifTrue: [ - ^ self fromRgbTriplet: parm]. - aColor _ self colorFrom: firstParm. - parm withIndexDo: [ :sym :ind | - ind > 1 ifTrue: [ - aColor _ aColor perform: sym ]]. - ^ aColor]. - ^ parm - -" -Color colorFrom: #(blue darker) -Color colorFrom: Color blue darker -Color colorFrom: #blue -Color colorFrom: #(0.0 0.0 1.0) -Color colorFrom: '#D7B360' -"! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3497-Color-fromFrom-hexString-JuanVuletich-2018Nov27-09h19m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3496] on 27 November 2018 at 9:21:11 am'! -!InnerTextMorph methodsFor: 'private' stamp: 'jmv 11/26/2018 18:20:34' prior: 50381273! - selectionChanged - - self textComposition selectionRects do: [ :r | self invalidateLocalRect: r ]. - editor hasSelection - ifTrue: [ self stopBlinking ] - ifFalse: [ self hasKeyboardFocus ifTrue: [self startBlinking ]]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3498-FixTextCursorBlinking-JuanVuletich-2018Nov27-09h20m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3496] on 27 November 2018 at 9:28:07 am'! -!CodeWindow methodsFor: 'updating' stamp: 'jmv 11/26/2018 18:36:46' prior: 50387981! - decorateForInheritance - "Check to see if the currently-viewed method has a super send or an override, and if so, change screen feedback, unless the #decorateBrowserButtons says not to." - - | cm aColor aButton flags buttonColor | - (aButton _ self inheritanceButton) ifNil: [^ self]. - buttonColor _ self buttonColor. - - Preferences decorateBrowserButtons - ifFalse: [ ^aButton color: buttonColor ]. - cm _ model currentCompiledMethod. - (cm is: #CompiledMethod) - ifFalse: [ ^aButton color: buttonColor ]. - - flags _ 0. - model isThisAnOverride ifTrue: [ flags _ flags bitOr: 4 ]. - cm sendsToSuper ifTrue: [ flags _ flags bitOr: 2 ]. - model isThereAnOverride ifTrue: [ flags _ flags bitOr: 1 ]. - aColor _ { - - "This is NOTan override. There is no super implementation." - buttonColor. "no sends to super. there is not override in any subclass" - `Color tan`. "no sends to super. there is an override in some subclass" - `Color red`. "sends to super. there is no override in any subclass. Error: no super to call (or calls super with a different message)" - `Color red`. "sends to super. there is an override in some subclass. Error: no super to call (or calls super with a different message)" - - "This is an override. There is some super implementation" - `Color red muchLighter`. "doesn't have sub; has super but doesn't call it" - `Color r: 0.94 g: 0.823 b: 0.673`. "has sub; has super but doesn't call it" - `Color green muchLighter`. "doesn't have sub; has super and callsl it" - `Color blue muchLighter`. "has sub; has super and callsl it" - - } at: flags + 1. - Theme current useUniformColors - ifTrue: [ - aButton color: (self buttonColor mixed: 0.8 with: aColor) ] - ifFalse: [ - aButton color: aColor ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3499-softInheritanceButtonColoring-JuanVuletich-2018Nov27-09h21m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3485] on 27 November 2018 at 9:33:43 am'! -!SmalltalkCompleter class methodsFor: 'class initialization' stamp: 'jmv 3/19/2012 08:41' prior: 16909395! - initialize - " - It takes about 6 seconds, mostly because of the time to fetch method stamps from source files... - [ SmalltalkCompleter initialize ]timeToRun - Selectors inspect - " - | maxSortValue allImplemented | - SystemChangeNotifier uniqueInstance - removeActionsWithReceiver: self. "avoid double registration" - - SystemChangeNotifier uniqueInstance - when: #classRemoved send: #classRemoved:fromCategory: to: self; - when: #methodAdded send: #methodAdded:selector:inClass:requestor: to: self; - when: #methodAddedInProtocol send: #methodAdded:selector:inProtocol:class:requestor: to: self; - when: #methodRemoved send: #methodRemoved:selector:inProtocol:class: to: self. - - self protected: [ - allImplemented _ Smalltalk allImplementedMessages. - Selectors _ Trie new. - " - Smalltalk allBehaviorsDo: [:class | - class selectorsAndMethodsDo: [ :sel :method | - Selectors at: sel ifAbsentPut: [ 0 ]. - method messages do: [ :sentMsg | - Selectors at: sentMsg put: (Selectors at: sentMsg ifAbsent: [ 0 ]) + 1 ]]]. - " - Smalltalk allBehaviorsDo: [:class | - class selectorsAndMethodsDo: [ :sel :method | - self addSelector: sel method: method allImplemented: allImplemented]]. - "" - - "The following might not be found in #messages. Give them maximum priority." - maxSortValue _ SmallInteger maxVal. - "From MessageNode>>#initialize" - #( ifTrue: ifFalse: ifTrue:ifFalse: ifFalse:ifTrue: - and: or: - whileFalse: whileTrue: whileFalse whileTrue - to:do: to:by:do: - caseOf: caseOf:otherwise: - ifNil: ifNotNil: ifNil:ifNotNil: ifNotNil:ifNil:) do: [ :sel | - Selectors at: sel put: maxSortValue ]. - - maxSortValue _ SmallInteger maxVal-1. - "From SystemDictionary >>#recreateSpecialObjectsArray" - (1 to: Smalltalk specialSelectorSize) do: [ :i | - Selectors at: (Smalltalk specialSelectorAt: i) put: maxSortValue ]]! ! - -SmalltalkCompleter initialize! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -SmalltalkCompleter initialize! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3500-Initialize-Smalltalk-Completer-JuanVuletich-2018Nov27-09h32m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3500] on 27 November 2018 at 10:16:21 am'! - -Theme subclass: #BrightTheme - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Theme-Core'! - -!classDefinition: #BrightTheme category: #'Theme-Core'! -Theme subclass: #BrightTheme - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Theme-Core'! -!BrightTheme commentStamp: '' prior: 0! - Default bright colored theme for Cuis.! -!Theme methodsFor: 'private - shout mappings' stamp: 'jmv 11/26/2018 18:00:55' prior: 50401908! - generateShoutConfig - - | styles colors | - styles := OrderedCollection new. - colors := self shout as: Dictionary. - - { - {self undefined. colors at: #undefined}. - {self defaults . colors at: #defaults}. - {self pseudoVariables . colors at: #pseudoVariables}. - {self literals . colors at: #literals}. - {self instVar . colors at: #instVar}. - {self messages . colors at: #messages}. - {self blockLevelZero . colors at: #blockLevelZero}. - {self blockLevelOne . colors at: #blockLevelOne}. - {self blockLevelTwo . colors at: #blockLevelTwo}. - {self blockLevelThree . colors at: #blockLevelThree}. - {self blockLevelFour . colors at: #blockLevelFour}. - {self blockLevelFive . colors at: #blockLevelFive}. - {self blockLevelSix . colors at: #blockLevelSix}. - {self blockLevelSeven . colors at: #blockLevelSeven}. - {self tempBar . colors at: #tempBar}. - {self methodTags . colors at: #methodTags . #bold}. - {self globals . colors at: #defaults . #bold}. - {self incompleteMessages . colors at: #incompleteMessages . #underlined}. - {self argumentTypes . colors at: #arguments . self italic}. - {self symbols . colors at: #messages . #bold}. - {self pattern . colors at: #selector . #bold}. - {self ansiAssignment . nil . #bold}. - {self assignment . nil . #(#bold #withST80Glyphs)}. - {self return . nil . #(#bold #withST80Glyphs)}. - {self tempVars . colors at: #tempVars . self italic}. - {self blockTemps . colors at: #tempBar . self italic} - } do: [ :style | - styles addAll: - (style first - collect: [ :category | | elements | - elements _ style asOrderedCollection. - elements at: 1 put: category. - Array withAll: elements ])]. - - "Miscellaneous remainder after factoring out commonality:" - styles addAll: { - {#unfinishedString . colors at: #undefined . #normal}. - {#undefinedIdentifier . colors at: #undefined .#bold}. - {#unfinishedComment . colors at: #pseudoVariables . self italic}. - {#comment . colors at: #comment . self italic}. - {#string . colors at: #instVar . #normal}. - {#literal . nil . self italic}. - {#incompleteIdentifier . colors at: #tempVars . {#italic. #underlined}}. - {#classVar . colors at: #tempVars . #bold}. - }. - - ^ styles! ! -!Theme methodsFor: 'shout' stamp: 'jmv 11/27/2018 09:59:21' prior: 50418566! - shout - "Color symbols as an association list. - SHTextStylerST80 initialize - " - ^ { - #selector -> nil. - #arguments -> #(cyan muchDarker). - #comment -> #(green muchDarker). - #tempBar -> #gray. - #tempVars -> #(gray muchDarker). - #instVar -> #(magenta muchDarker). - #pseudoVariables -> #(red muchDarker). - #literals -> #(green muchDarker). - #messages -> #(blue darker). - #incompleteMessages -> #(gray veryMuchDarker). - #blockLevelZero -> #black. - #blockLevelOne -> #brown. - #blockLevelTwo -> #magenta. - #blockLevelThree -> #red. - #blockLevelFour -> #(orange darker). - #blockLevelFive -> #(orange muchDarker). - #blockLevelSix -> #(green muchDarker). - #blockLevelSeven -> #blue. - #defaults -> #black. - #undefined -> #red. - #methodTags -> #(green muchDarker). - }! ! -!Theme class methodsFor: 'user interface' stamp: 'jmv 11/27/2018 10:14:54' prior: 50397980! - changeTheme - - | menu | - menu _ MenuMorph new. - menu - addTitle: 'Choose a theme'; - addStayUpIcons. - (Theme allSubclasses sorted: [ :a :b | a name < b name ]) do: [ :themeClass | - menu add: themeClass name target: themeClass action: #beCurrent ]. - menu popUpInWorld: self runningWorld! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -BrightTheme beCurrent.! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3501-BrightTheme-JuanVuletich-2018Nov27-09h49m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3501] on 27 November 2018 at 10:20:03 am'! -!Workspace methodsFor: 'accessing' stamp: 'jmv 11/27/2018 10:19:24' prior: 50419461! - methodNodeOf: aSourceCode ifErrorsParsing: aParsingErrorBlock - - ^[ UndefinedObject methodNodeFor: aSourceCode noPattern: true ] on: Error, UndeclaredVariableReference do: aParsingErrorBlock -! ! -!CodeProvider methodsFor: 'contents' stamp: 'jmv 11/27/2018 10:19:13' prior: 50419469! - methodNodeOf: aSourceCode ifErrorsParsing: aParsingErrorBlock - - ^[ self selectedClassOrMetaClass methodNodeFor: aSourceCode ] on: Error, UndeclaredVariableReference do: aParsingErrorBlock - ! ! -!Inspector methodsFor: 'contents' stamp: 'jmv 11/27/2018 10:19:17' prior: 50419477! - methodNodeOf: aSourceCode ifErrorsParsing: aParsingErrorBlock - - ^[ self selectedClassOrMetaClass methodNodeFor: aSourceCode noPattern: true ] on: Error, UndeclaredVariableReference do: aParsingErrorBlock ! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3502-FixSendersImplementorsEnhancements-JuanVuletich-2018Nov27-10h19m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3501] on 27 November 2018 at 10:24:18 am'! - -CodePackage subclass: #ColorExtrasPackage - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Color-Extras'! - -!classDefinition: #ColorExtrasPackage category: #'Color-Extras'! -CodePackage subclass: #ColorExtrasPackage - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Color-Extras'! -!SmallInteger methodsFor: 'bit manipulation' stamp: 'SqR 8/3/2000 13:29' prior: 16908824! - hashMultiply - "Multiply by 1664525, take lower 28 bits, do not use LargeIntegers (not even in 32 bit images)" - | low | - - low _ self bitAnd: 16383. - ^(16r260D * low + ((16r260D * (self bitShift: -14) + (16r0065 * low) bitAnd: 16383) * 16384)) - bitAnd: 16r0FFFFFFF! ! - -Smalltalk removeClassNamedIfInBaseSystem: #ColorExtrasPackage! - -Smalltalk removeClassNamed: #ColorExtrasPackage! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3503-hashMultiplyComment-JuanVuletich-2018Nov27-10h22m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3501] on 27 November 2018 at 1:42:06 pm'! - -Number subclass: #Float - instanceVariableNames: '' - classVariableNames: 'E Epsilon Halfpi Infinity Ln10 Ln2 MaxVal MaxValLn MinValLogBase2 NaN NegativeInfinity NegativeZero Pi RadiansPerDegree Sqrt2 Twopi ' - poolDictionaries: '' - category: 'Kernel-Numbers'! - -!classDefinition: #Float category: #'Kernel-Numbers'! -Number subclass: #Float - instanceVariableNames: '' - classVariableNames: 'E Epsilon Halfpi Infinity Ln10 Ln2 MaxVal MaxValLn MinValLogBase2 NaN NegativeInfinity NegativeZero Pi RadiansPerDegree Sqrt2 Twopi' - poolDictionaries: '' - category: 'Kernel-Numbers'! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 11/27/2018 13:10:52'! - arcTanNonPrimitive - "Answer the angle in radians." - - | theta delta sinTheta cosTheta | - - "Newton-Raphson" - self < 0.0 ifTrue: [ ^ 0.0 - (0.0 - self) arcTan ]. - - "first guess" - theta _ (self * Halfpi) / (self + 1.0). - - "iterate" - [ - sinTheta _ theta sin. - cosTheta _ theta cos. - delta _ (sinTheta * cosTheta) - (self * cosTheta * cosTheta). - delta abs >= theta ulp ] - whileTrue: [ - theta _ theta - delta ]. - ^ theta! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 11/27/2018 13:24:16'! - expNonPrimitive - "Answer E raised to the receiver power." - - | base fract correction delta div | - - "Taylor series" - "check the special cases" - self < 0.0 ifTrue: [^ (self negated exp) reciprocal]. - self = 0.0 ifTrue: [^ 1]. - self abs > MaxValLn ifTrue: [self error: 'exp overflow']. - - "get first approximation by raising e to integer power" - base _ E raisedToInteger: (self truncated). - - "now compute the correction with a short Taylor series" - "fract will be 0..1, so correction will be 1..E" - "in the worst case, convergance time is logarithmic with 1/Epsilon" - fract _ self fractionPart. - fract = 0.0 ifTrue: [ ^ base ]. "no correction required" - - correction _ 1.0 + fract. - delta _ fract * fract / 2.0. - div _ 2.0. - [delta >= base ulp] whileTrue: [ - correction _ correction + delta. - div _ div + 1.0. - delta _ delta * fract / div]. - correction _ correction + delta. - ^ base * correction! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 11/27/2018 13:32:39'! - lnNonPrimitive - "Answer the natural logarithm of the receiver. - Optional. See Object documentation whatIsAPrimitive." - - | expt n mant x div pow delta sum | - - "Taylor series" - self <= 0.0 ifTrue: [DomainError signal: 'ln is only defined for x > 0.0']. - - "get a rough estimate from binary exponent" - expt := self exponent. - n := Ln2 * expt. - mant := self timesTwoPower: 0 - expt. - - "compute fine correction from mantinssa in Taylor series" - "mant is in the range [0..2]" - "we unroll the loop to avoid use of abs" - x := mant - 1.0. - div := 1.0. - pow := delta := sum := x. - x := x negated. "x <= 0" - [delta > (n + sum) ulp] whileTrue: [ - "pass one: delta is positive" - div := div + 1.0. - pow := pow * x. - delta := pow / div. - sum := sum + delta. - "pass two: delta is negative" - div := div + 1.0. - pow := pow * x. - delta := pow / div. - sum := sum + delta]. - - ^ n + sum - - "Float e ln 1.0"! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 11/27/2018 13:40:01'! - sinNonPrimitive - "Answer the sine of the receiver taken as an angle in radians." - - | sum delta self2 i | - - "Taylor series" - "normalize to the range [0..Pi/2]" - self < 0.0 ifTrue: [^ (0.0 - ((0.0 - self) sin))]. - self > Twopi ifTrue: [^ (self \\ Twopi) sin]. - self > Pi ifTrue: [^ (0.0 - (self - Pi) sin)]. - self > Halfpi ifTrue: [^ (Pi - self) sin]. - - "unroll loop to avoid use of abs" - sum _ delta _ self. - self2 _ 0.0 - (self * self). - i _ 2.0. - [delta >= sum ulp] whileTrue: [ - "once" - delta _ (delta * self2) / (i * (i + 1.0)). - i _ i + 2.0. - sum _ sum + delta. - "twice" - delta _ (delta * self2) / (i * (i + 1.0)). - i _ i + 2.0. - sum _ sum + delta]. - ^ sum! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 11/27/2018 13:10:59'! - sqrtNonPrimitive - "Answer the square root of the receiver. " - | exp guess delta | - - "Complex answer" - self <= 0.0 - ifTrue: [ - ^ self = 0.0 - ifFalse: [ (0.0 - self) sqrt i ] - ifTrue: [ self ] "Answer 0.0 for 0.0, but -0.0 for -0.0. See IEEE 754 standard" - ]. - - "NaN and Infinity" - self isFinite ifFalse: [ - ^ self ]. - - "Newton-Raphson" - "first guess is half the exponent" - exp _ self exponent // 2. - guess _ self timesTwoPower: 0 - exp. - [ - delta _ self - (guess * guess) / (guess * 2.0). - delta abs >= guess ulp ] - whileTrue: [ - guess _ guess + delta ]. - ^ guess! ! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 11/27/2018 11:09:00' prior: 16880047! - arcTan - "The receiver is the tangent of an angle. Answer the angle measured in radians. - Note: If the purpose is to recover the angle of some vector, prefer #arcTan: - See, for example, Complex>>#argument" - - ^self asFloat arcTan! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 11/27/2018 10:57:09' prior: 50400367! - sqrt - "Answer the square root of the receiver. - Use primitive if available, or Smalltalk code if primitive is unavailable or fails." - - | prim | - prim _ self primSqrt. - prim isNaN ifFalse: [ ^prim ]. - - ^ self sqrtNonPrimitive! ! -!Float class methodsFor: 'class initialization' stamp: 'jmv 11/27/2018 13:40:39' prior: 16845982! - initClassCachedState - "Float initialize" - "Constants from Computer Approximations, pp. 182-183: - Pi = 3.14159265358979323846264338327950288 - Pi/2 = 1.57079632679489661923132169163975144 - Pi*2 = 6.28318530717958647692528676655900576 - Pi/180 = 0.01745329251994329576923690768488612 - 2.0 ln = 0.69314718055994530941723212145817657 - 2.0 sqrt = 1.41421356237309504880168872420969808" - - Pi _ 3.14159265358979323846264338327950288. - Halfpi _ Pi / 2.0. - Twopi _ Pi * 2.0. - RadiansPerDegree _ Pi / 180.0. - - Ln2 _ 0.69314718055994530941723212145817657. - Ln10 _ 10.0 ln. - Sqrt2 _ 1.41421356237309504880168872420969808. - E _ 2.718281828459045235360287471353. - - MaxVal _ 1.7976931348623157e308. - MaxValLn _ 709.782712893384. - MinValLogBase2 _ -1074. - - Infinity _ MaxVal * MaxVal. - NegativeInfinity _ 0.0 - Infinity. - NaN _ Infinity - Infinity. - NegativeZero _ 1.0 / Infinity negated. -! ! -!Float class methodsFor: 'class initialization' stamp: 'jmv 11/27/2018 13:40:43' prior: 16846031! - releaseClassCachedState - - Pi _ nil. - Halfpi _ nil. - Twopi _ nil. - RadiansPerDegree _ nil. - - Ln2 _ nil. - Ln10 _ nil. - Sqrt2 _ nil. - E _ nil. - - MaxVal _ nil. - MaxValLn _ nil. - MinValLogBase2 _ nil. - - Infinity _ nil. - NegativeInfinity _ nil. - NaN _ nil. - NegativeZero _ nil! ! -!BoxedFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 11/27/2018 11:12:00' prior: 16790579! - arcTan - "Answer the angle in radians. - Optional. See Object documentation whatIsAPrimitive. - Note: If the purpose is to recover the angle of some vector, prefer #arcTan: - See, for example, Complex>>#argument" - - - ^ self arcTanNonPrimitive! ! -!BoxedFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 11/27/2018 11:14:01' prior: 16790598! - exp - "Answer E raised to the receiver power. - Optional. See Object documentation whatIsAPrimitive." - - - ^ self expNonPrimitive! ! -!BoxedFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 11/27/2018 11:14:45' prior: 16790631! - ln - "Answer the natural logarithm of the receiver. - Optional. See Object documentation whatIsAPrimitive." - - - ^ self lnNonPrimitive! ! -!BoxedFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 11/27/2018 11:15:17' prior: 16790733! - sin - "Answer the sine of the receiver taken as an angle in radians. - Optional. See Object documentation whatIsAPrimitive." - - - ^ self sinNonPrimitive! ! -!SmallFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 11/27/2018 11:11:58' prior: 16908312! - arcTan - "Answer the angle in radians. - Optional. See Object documentation whatIsAPrimitive. - Note: If the purpose is to recover the angle of some vector, prefer #arcTan: - See, for example, Complex>>#argument" - - - ^self arcTanNonPrimitive! ! -!SmallFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 11/27/2018 11:13:51' prior: 16908332! - exp - "Answer E raised to the receiver power. - Optional. See Object documentation whatIsAPrimitive." - - - ^ self expNonPrimitive! ! -!SmallFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 11/27/2018 11:14:36' prior: 16908365! - ln - "Answer the natural logarithm of the receiver. - Optional. See Object documentation whatIsAPrimitive." - - - ^ self lnNonPrimitive! ! -!SmallFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 11/27/2018 11:15:23' prior: 16908397! - sin - "Answer the sine of the receiver taken as an angle in radians. - Optional. See Object documentation whatIsAPrimitive." - - - ^ self sinNonPrimitive! ! -!Integer methodsFor: 'mathematical functions' stamp: 'jmv 11/27/2018 10:30:26' prior: 16859841! - sqrt - "Answer the square root of the receiver." - - | selfAsFloat floatResult guess | - selfAsFloat _ self asFloat. - floatResult _ selfAsFloat sqrt. - - floatResult isInfinite ifFalse: [ - guess _ floatResult truncated. - - "If got an exact answer, answer it. Otherwise answer float approximate answer." - guess squared = self - ifTrue: [ ^ guess ]]. - - "In this case, maybe it failed because we are such a big integer that the Float method becomes - inexact, even if we are a whole square number. So, try the slower but more general method." - selfAsFloat >= Float maxExactInteger asFloat squared - ifTrue: [ - guess _ self sqrtFloor. - guess squared = self - ifTrue: [ ^guess ]. - - "Nothing else can be done. No exact answer means answer must be a Float. - Answer the best we can which is the rounded sqrt." - ^ self sqrtRounded asFloat ]. - - "We need an approximate result" - ^floatResult! ! - -Number subclass: #Float - instanceVariableNames: '' - classVariableNames: 'E Halfpi Infinity Ln10 Ln2 MaxVal MaxValLn MinValLogBase2 NaN NegativeInfinity NegativeZero Pi RadiansPerDegree Sqrt2 Twopi' - poolDictionaries: '' - category: 'Kernel-Numbers'! - -!classDefinition: #Float category: #'Kernel-Numbers'! -Number subclass: #Float - instanceVariableNames: '' - classVariableNames: 'E Halfpi Infinity Ln10 Ln2 MaxVal MaxValLn MinValLogBase2 NaN NegativeInfinity NegativeZero Pi RadiansPerDegree Sqrt2 Twopi' - poolDictionaries: '' - category: 'Kernel-Numbers'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3504-Float-Refactor-RemoveEpsilonClassVar-JuanVuletich-2018Nov27-10h24m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3504] on 27 November 2018 at 2:34:48 pm'! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'jmv 11/27/2018 14:28:37'! - withSelectorUnderCursorDo: aBlock otherwise: failBlock - - self withSelectorUnderCursorDo: aBlock ifErrorsParsing: failBlock ifNoSelector: failBlock! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'jmv 11/27/2018 14:29:28' prior: 50419613! - implementorsOfIt - - "Open an implementors browser on the selector under cursor. If it can not parse the source code it uses - old implementation that looks for the selected selector if any - Hernan" - - self - withSelectorUnderCursorDo: [ :aSelector | Smalltalk browseAllImplementorsOf: aSelector ] - otherwise: [ self implementorsOfItWhenErrorsParsing ]! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'jmv 11/27/2018 14:29:23' prior: 50419628! - sendersOfIt - - "Open a senders browser on the selector under cursor. If it can not parse the source code it uses - old implementation that looks for the selected selector if any - Hernan" - - self - withSelectorUnderCursorDo: [ :aSelector | Smalltalk browseAllCallsOn: aSelector ] - otherwise: [ self sendersOfItWhenErrorsParsing ]! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'jmv 11/27/2018 14:33:01' prior: 50419570! - withSelectorUnderCursorDo: aBlock ifErrorsParsing: aParsingErrorBlock ifNoSelector: aNoSelectorBlock - - | methodNode nodeAtRange nodeUnderCursor | - - methodNode := self codeProvider methodNodeOf: model actualContents ifErrorsParsing: [ :anError | ^ aParsingErrorBlock valueWithPossibleArgument: anError ]. - - self startIndex < methodNode selectorLastPosition ifTrue: [ ^aBlock value: methodNode selector ]. - nodeAtRange := methodNode parseNodeIncluding: self startIndex ifAbsent: [ ^ aNoSelectorBlock value ]. - nodeUnderCursor := nodeAtRange key. - nodeUnderCursor isMessageNode ifTrue: [ ^aBlock value: nodeAtRange key selector key ]. - (nodeUnderCursor isLiteralNode and: [ nodeUnderCursor literalValue isSymbol ]) ifTrue: [ ^aBlock value: nodeUnderCursor literalValue ]. - - ^ aNoSelectorBlock value ! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3505-FixSendersImplementorsEnhancements-JuanVuletich-2018Nov27-14h32m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3505] on 27 November 2018 at 2:46:58 pm'! -!Theme class methodsFor: 'instance creation' stamp: 'jmv 11/27/2018 14:45:06' prior: 50400278! - beCurrent - self currentTheme: self. - self inform: 'Please close and reopen all windows'! ! -!Theme class methodsFor: 'user interface' stamp: 'jmv 11/27/2018 14:42:55' prior: 50420321! - changeTheme - - | menu | - "In Theme-Themes.pck.st" - (FeatureRequirement name: 'Theme-Themes') isAlreadySatisfied ifFalse: [ - (PopUpMenu - confirm: 'The Additional Themes package is not loaded', String newLineString, 'Would you like me to load it for you now?') - ifTrue: [Feature require: #'Theme-Themes'] - ]. - menu _ MenuMorph new. - menu - addTitle: 'Choose a theme'; - addStayUpIcons. - (Theme allSubclasses sorted: [ :a :b | a name < b name ]) do: [ :themeClass | - menu add: themeClass name target: themeClass action: #beCurrent ]. - menu popUpInWorld: self runningWorld! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3506-Themes-enh-JuanVuletich-2018Nov27-14h41m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3505] on 27 November 2018 at 4:39:19 pm'! -!PluggableTextModel commentStamp: '' prior: 16890049! - A TextModel whose contents are stored elsewhere (ivar textProvider)! -!TextProvider methodsFor: 'accessing' stamp: 'jmv 11/27/2018 16:38:04'! - methodNodeOf: aSourceCode ifErrorsParsing: aParsingErrorBlock - - ^[ UndefinedObject methodNodeFor: aSourceCode noPattern: true ] on: Error, UndeclaredVariableReference do: aParsingErrorBlock -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3507-yetAnother-JuanVuletich-2018Nov27-16h34m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3507] on 28 November 2018 at 6:06:10 pm'! -!Theme class methodsFor: 'instance creation' stamp: 'cbr 12/14/2010 01:55' prior: 50420829! - beCurrent - ^ self currentTheme: self! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3508-AvoidHangOnImageSave-JuanVuletich-2018Nov28-18h05m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3508] on 29 November 2018 at 1:05:06 pm'! - -Theme subclass: #BrightColorTheme - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Theme-Core'! - -!classDefinition: #BrightColorTheme category: #'Theme-Core'! -Theme subclass: #BrightColorTheme - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Theme-Core'! -!BrightColorTheme commentStamp: '' prior: 0! - Default bright colored theme for Cuis.! - -Theme subclass: #DarkTheme - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Theme-Core'! - -!classDefinition: #DarkTheme category: #'Theme-Core'! -Theme subclass: #DarkTheme - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Theme-Core'! -!DarkTheme commentStamp: '' prior: 0! - A low contrast, darker gray theme.! -!DarkTheme methodsFor: 'colors' stamp: 'jmv 11/27/2018 10:07:19'! - background - ^ `Color black`! ! -!DarkTheme methodsFor: 'colors' stamp: 'jmv 11/26/2018 18:24:15'! - buttonLabel - ^ `Color gray: 0.48`! ! -!DarkTheme methodsFor: 'colors' stamp: 'jmv 11/27/2018 10:07:25'! - defaultWindowColor - ^ `Color hue: 212 chroma: 0.015 luminance: 0.25`! ! -!DarkTheme methodsFor: 'colors' stamp: 'cbr 10/10/2012 20:18'! - missingCommentTextColor - - ^ TextColor cyan! ! -!DarkTheme methodsFor: 'colors' stamp: 'jmv 11/26/2018 16:59:09'! - paneBackgroundFrom: aColor - ^ aColor alphaMixed: 0.7 with: Color black! ! -!DarkTheme methodsFor: 'colors' stamp: 'jmv 11/27/2018 09:59:07'! - shout - "Color symbols as an association list." - - ^ { - #selector -> '#B59F60'. - #arguments -> '#289078'. - #comment -> #(green duller). - #tempBar -> #gray. - #tempVars -> '#767836'. - #instVar -> '#B3695A'. - #pseudoVariables -> '#2070E0'. - #literals -> #green. - #messages -> '#6FB3BD'. - #incompleteMessages -> '#F08060'. - #blockLevelZero -> '#6FB3BD'. - #blockLevelOne -> '#FFB0B0'. - #blockLevelTwo -> '#B0FFB0'. - #blockLevelThree -> '#B0B0FF'. - #blockLevelFour -> '#00B0B0'. - #blockLevelFive -> '#E03030'. - #blockLevelSix -> '#30E030'. - #blockLevelSeven -> '#3030E0'. - #defaults -> '#A1AFBF'. - #undefined -> '#E04020'. - #methodTags -> #green. - }! ! -!DarkTheme methodsFor: 'colors' stamp: 'jmv 11/27/2018 10:07:33'! - text - ^ `Color veryLightGray`! ! -!DarkTheme methodsFor: 'colors' stamp: 'jmv 11/26/2018 18:08:53'! - textHighlight - "A nice light blue." - " - ^ Color r: 0.71 g: 0.835 b: 1.0 - ^ Color hue: 214 chroma: 0.29 luminance: 0.816 - " - ^ `Color hue: 204 chroma: 0.29 luminance: 0.22`! ! -!DarkTheme methodsFor: 'colors' stamp: 'jmv 11/27/2018 10:07:40'! - textPane - ^ `Color gray`! ! -!DarkTheme methodsFor: 'colors' stamp: 'jmv 11/27/2018 10:07:46'! - unfocusedTextHighlightFrom: aColor - ^ aColor adjustSaturation: -0.15 brightness: -0.07! ! -!DarkTheme methodsFor: 'colors' stamp: 'cbr 10/10/2012 18:32'! - useUniformColors - ^ true! ! -!DarkTheme methodsFor: 'other options' stamp: 'jmv 11/27/2018 10:07:56'! - windowLabel - ^ `Color gray: 0.55`! ! -!DarkTheme methodsFor: 'menu colors' stamp: 'jmv 11/26/2018 18:29:15'! - menu - ^ `Color darkGray`! ! -!DarkTheme methodsFor: 'menu colors' stamp: 'jmv 11/26/2018 18:31:04'! - menuText - ^ self text! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -BrightColorTheme beCurrent! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3509-AddDarkTheme-JuanVuletich-2018Nov29-13h02m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3508] on 29 November 2018 at 1:05:30 pm'! - -Smalltalk removeClassNamed: #BrightTheme! - -Smalltalk removeClassNamed: #BrightTheme! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3510-cleanup-JuanVuletich-2018Nov29-13h05m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3510] on 30 November 2018 at 9:29:13 am'! -!Editor methodsFor: 'new selection' stamp: 'jmv 11/30/2018 09:26:44' prior: 16836464! - selectWordLeftDelimiters: leftDelimiters rightDelimiters: rightDelimiters - "Select delimited text or word--the result of double-clicking." - - | initialDelimiter finalDelimiter direction match level string here hereChar start stop | - string _ self privateCurrentString. - string size < 2 ifTrue: [^self selectFrom: 1 to: 1]. - here _ self pointIndex min: string size max: 2. - initialDelimiter _ string at: here - 1. - match _ leftDelimiters indexOf: initialDelimiter. - match > 0 - ifTrue: [ - "delimiter is on left -- match to the right" - start _ here. - direction _ 1. - here _ here - 1. - finalDelimiter _ rightDelimiters at: match] - ifFalse: [ - initialDelimiter _ string at: here. - match _ rightDelimiters indexOf: initialDelimiter. - match > 0 - ifTrue: [ - "delimiter is on right -- match to the left" - stop _ here - 1. - direction _ -1. - finalDelimiter _ leftDelimiters at: match] - ifFalse: [ - "no delimiters -- select a token" - direction _ -1]]. - level _ 1. - [level > 0 and: [direction > 0 - ifTrue: [here < string size] - ifFalse: [here > 1]]] - whileTrue: [ - hereChar _ string at: (here _ here + direction). - match = 0 - ifTrue: [ - "token scan goes left, then right" - hereChar isValidInIdentifiers "Consider $: as a word separator" - ifTrue: [ - here = 1 - ifTrue: [ - start _ 1. - "go right if hit string start" - direction _ 1]] - ifFalse: [ - direction < 0 - ifTrue: [ - start _ here + 1. - "go right if hit non-token" - direction _ 1] - ifFalse: [level _ 0]]] - ifFalse: [ - "delimiter match just counts nesting level" - hereChar = finalDelimiter - ifTrue: [level _ level - 1"leaving nest"] - ifFalse: [ - hereChar = initialDelimiter - ifTrue: [level _ level + 1"entering deeper nest"]]]]. - level > 0 ifTrue: [ - "If we failed to find final delimiter, then just select word." - ^self selectWordLeftDelimiters: '' rightDelimiters: '' ]. - direction > 0 - ifTrue: [ - "If a word ends with $: (a keyword), consider it part of the word" - hereChar = $: ifTrue: [here _ here + 1]. - self selectFrom: start to: here - 1] - ifFalse: [ - "But if a word starts with $: (this is the argument to a keyword), then it is not part of the word." - self selectFrom: here + 1 to: stop]! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'HAW 11/29/2018 19:11:47' prior: 50404871! - browseIt - "Launch a browser for the current selection, if appropriate" - - | aSymbol anEntry browser | - Preferences alternativeBrowseIt ifTrue: [^ self browseClassFromIt]. - - self wordSelectAndEmptyCheck: [^ self]. - aSymbol _ self selectedSymbol ifNil: [ - self - evaluateSelectionAndDo: [ :result | result class name ] - ifFail: [ ^morph flash ] - profiled: false]. - - aSymbol first isUppercase - ifTrue: [ - anEntry _ (Smalltalk - at: aSymbol - ifAbsent: [ - Smalltalk browseAllImplementorsOf: aSymbol. - ^ nil]). - anEntry ifNil: [^ morph flash]. - (anEntry isKindOf: Class) - ifFalse: [anEntry _ anEntry class]. - browser _ Browser new. - browser setClass: anEntry selector: nil. - BrowserWindow open: browser label:'System Browser: ', aSymbol] - ifFalse: - [Smalltalk browseAllImplementorsOf: aSymbol]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3511-AutoSelectToBrowse-fix-HernanWilkinson-2018Nov30-09h28m-HAW.1.cs.st----! - -----SNAPSHOT----#(30 November 2018 9:34:32.067126 am) Cuis5.0-3511-v3.image priorSource: 2797624! - -----QUIT----#(30 November 2018 9:34:55.232912 am) Cuis5.0-3511-v3.image priorSource: 2863724! - -----STARTUP----#(21 December 2018 5:45:57.13997 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3511-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3511] on 1 December 2018 at 11:24:55 am'! -!Editor methodsFor: 'new selection' stamp: 'jmv 12/1/2018 11:23:07' prior: 50421032! - selectWordLeftDelimiters: leftDelimiters rightDelimiters: rightDelimiters - "Select delimited text or word--the result of double-clicking." - - | initialDelimiter finalDelimiter direction match level string here hereChar start stop | - string _ self privateCurrentString. - string size < 2 ifTrue: [^self selectFrom: 1 to: 1]. - here _ self pointIndex min: string size max: 2. - initialDelimiter _ string at: here - 1. - match _ leftDelimiters indexOf: initialDelimiter. - match > 0 - ifTrue: [ - "delimiter is on left -- match to the right" - start _ here. - direction _ 1. - here _ here - 1. - finalDelimiter _ rightDelimiters at: match] - ifFalse: [ - initialDelimiter _ string at: here. - match _ rightDelimiters indexOf: initialDelimiter. - match > 0 - ifTrue: [ - "delimiter is on right -- match to the left" - stop _ here - 1. - direction _ -1. - finalDelimiter _ leftDelimiters at: match] - ifFalse: [ - "no delimiters -- select a token" - direction _ -1]]. - level _ 1. - [level > 0 and: [direction > 0 - ifTrue: [here < string size] - ifFalse: [here > 1]]] - whileTrue: [ - hereChar _ string at: (here _ here + direction). - match = 0 - ifTrue: [ - "token scan goes left, then right" - hereChar isValidInIdentifiers "Consider $: as a word separator" - ifTrue: [ - here = 1 - ifTrue: [ - start _ 1. - "go right if hit string start" - direction _ 1]] - ifFalse: [ - direction < 0 - ifTrue: [ - start _ here + 1. - "go right if hit non-token" - direction _ 1] - ifFalse: [level _ 0]]] - ifFalse: [ - "delimiter match just counts nesting level" - hereChar = finalDelimiter - ifTrue: [level _ level - 1"leaving nest"] - ifFalse: [ - hereChar = initialDelimiter - ifTrue: [level _ level + 1"entering deeper nest"]]]]. - level > 0 ifTrue: [ - leftDelimiters size + rightDelimiters size = 0 ifFalse: [ - "If we failed to find final delimiter, then just select word." - ^self selectWordLeftDelimiters: '' rightDelimiters: '' ]. - here _ here + direction ]. - direction > 0 - ifTrue: [ - "If a word ends with $: (a keyword), consider it part of the word" - hereChar = $: ifTrue: [here _ here + 1]. - self selectFrom: start to: here - 1] - ifFalse: [ - "But if a word starts with $: (this is the argument to a keyword), then it is not part of the word." - self selectFrom: here + 1 to: stop]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3512-TripleClickOnTextEditorFix-JuanVuletich-2018Dec01-11h16m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3512] on 4 December 2018 at 12:19:11 pm'! -!Float methodsFor: 'converting' stamp: 'jmv 12/4/2018 12:11:37' prior: 50417747! - partBits: aThreeArgumentBlock - " - Extract the bits for Sign, Mantissa and Exponent parts of the Floating Point representation. - Just extract the bits. Do not add implicit bit. Do not correct denormals. Do not substract exponent bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. (f signPart * f significandAsInteger * (2 raisedToInteger: f exponentPart-52)) asFloat = f } print ]. - " - | allBits signBit exponentBits mantissaBits | - - "Extract the bits of an IEEE double float " - allBits _ ((self basicAt: 1) bitShift: 32) + (self basicAt: 2). - - "Extract the sign and the biased exponent " - signBit _ allBits bitShift: -63. - exponentBits _ (allBits bitShift: -52) bitAnd: 16r7FF. - - "Extract fractional part " - mantissaBits _ allBits bitAnd: 16r000FFFFFFFFFFFFF. - - "Evaluate the block" - ^aThreeArgumentBlock value: signBit value: exponentBits value: mantissaBits! ! -!Float methodsFor: 'converting' stamp: 'jmv 12/4/2018 12:12:49' prior: 50417828! - partValues: aThreeArgumentBlock ifInfinite: infiniryBlock ifNaN: nanBlock - " - Float pi hex print - Float pi partValues: [ :sign :exponent :mantissa | { sign hex. exponent hex. mantissa hex} print ] - 0.0 partValues: [ :sign :exponent :mantissa | { sign hex. exponent hex. mantissa hex} print ] - For 0.0, exponent will be the minimum possible, i.e. -1023, and mantissa will be 0. - " - | sign exponent mantissa | - - self partBits: [ :signBit :exponentBits :mantissaBits | - - "Extract the sign" - sign _ signBit = 0 ifTrue: [1] ifFalse: [-1]. - - "Special cases: infinites and NaN" - exponentBits = 16r7FF ifTrue: [ - ^mantissaBits = 0 - ifTrue: [ infiniryBlock valueWithPossibleArgument: self ] - ifFalse: [ nanBlock valueWithPossibleArgument: self and: mantissaBits ]]. - - "Unbias exponent: 16r3FF is bias" - exponent _ exponentBits - 16r3FF. - - "Add back implicit leading 1 in fraction if appropriate" - "If expPart = 0, I am +/-zero or a denormal value. In such cases, no implicit leading bit in mantissa" - exponentBits = 0 - ifTrue: [ - mantissa _ mantissaBits. - exponent _ exponent + 1 ] - ifFalse: [ - mantissa _ 16r0010000000000000 bitOr: mantissaBits ]. - - "Evaluate the block" - ^aThreeArgumentBlock value: sign value: exponent value: mantissa - ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/4/2018 12:13:25' prior: 50414496! - mantissaPart - "Equivalent to #significandAsInteger." - "The actual bits in the mantissa of the receiver, as an integer, including the implicit leading 1 if appropriate. - Does not include de sign. - See #exponentPart and #signPart - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. (f signPart * f mantissaPart * (2 raisedToInteger: f exponentPart-52)) asFloat = f } print ]. - " - ^self partValues: [ :sign :exponent :mantissa | mantissa ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/4/2018 12:15:28' prior: 50418693! - predecessor - "Answer the largest Float smaller than self" - | ulp | - self isFinite ifFalse: [ - (self isNaN or: [self negative]) ifTrue: [^self]. - ^Float fmax]. - ulp := self ulp. - ^self - (0.5 * ulp) = self - ifTrue: [self - ulp] - ifFalse: [self - (0.5 * ulp)]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/4/2018 12:13:37' prior: 50417871! - significandAsInteger - "The actual bits in the mantissa of the receiver, as an integer number, including the implicit leading 1 if appropriate. - See #mantissaPart - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. (f signPart * f significandAsInteger * (2 raisedToInteger: f exponentPart-52)) asFloat = f } print ]. - " - ^self mantissaPart! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/4/2018 12:15:19' prior: 50417397! - successor - "Answer the smallest Float greater than self" - | ulp | - self isFinite ifFalse: [ - (self isNaN or: [self positive]) ifTrue: [^self]. - ^Float fmax negated]. - ulp := self ulp. - ^self + (0.5 * ulp) = self - ifTrue: [self * -1.0 - ulp * -1.0 "This trick is for obtaining a negativeZero"] - ifFalse: [self + (0.5 * ulp)]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/4/2018 12:15:44' prior: 50418703! - ulp - "Answer the unit of least precision of the receiver" - - | exponent | - self isFinite ifFalse: [^self abs]. - self isZero ifTrue: [^Float fmin]. - exponent := self exponent. - ^exponent < self class emin - ifTrue: [Float fminDenormalized] - ifFalse: [Float epsilon timesTwoPower: exponent]! ! -!Float methodsFor: 'printing' stamp: 'jmv 12/4/2018 12:17:36' prior: 50418745! - printOn: aStream base: base - "Handle sign, zero, and NaNs; all other values passed to absPrintOn:base:" - - self isNaN ifTrue: [aStream nextPutAll: 'NaN'. ^ self]. "check for NaN before sign" - self > 0.0 - ifTrue: [self absPrintOn: aStream base: base] - ifFalse: - [self sign = -1 - ifTrue: [aStream nextPutAll: '-']. - self isZero - ifTrue: [aStream nextPutAll: '0.0'] - ifFalse: [self negated absPrintOn: aStream base: base]]! ! -!Float class methodsFor: 'constants' stamp: 'jmv 12/4/2018 11:57:45' prior: 16845874! - emin - "Answer the exponent of the non-denormal value with smallest magnitude" - - ^-1022! ! -!Float class methodsFor: 'constants' stamp: 'jmv 12/4/2018 11:58:23' prior: 16845952! - precision - "Answer the apparent precision of the floating point representation. - That is the maximum number of radix-based digits (bits if radix=2) representable in floating point without rounding error. - Technically, 52 bits are stored in the representation, and normalized numbers have an implied leading 1 that does not need to be stored. - Note that denormalized floating point numbers don't have the implied leading 1, and thus gradually lose precision. - This format implements the IEEE-754 binary64 format." - - ^53! ! -!Fraction methodsFor: 'converting' stamp: 'jmv 12/4/2018 11:57:12' prior: 16849556! - asFloat - "Answer a Float that closely approximates the value of the receiver. - This implementation will answer the closest floating point number to the receiver. - In case of a tie, it will use the IEEE 754 round to nearest even mode. - In case of overflow, it will answer +/- Float infinity." - - | a b mantissa exponent floatMantissa hasTruncatedBits lostBit n ha hb hm | - a := numerator abs. - b := denominator. "denominator is always positive" - ha := a highBit. - hb := b highBit. - - "Number of bits to keep in mantissa plus one to handle rounding." - n := 1 + Float precision. - - "If both numerator and denominator are represented exactly as floating point number, - float division is fastest." - (ha < n and: [hb < n]) ifTrue: [^numerator asFloat / denominator asFloat]. - - "Shift the fraction by a power of two exponent so as to obtain a mantissa with n bits. - The first guess is approximate, the mantissa might have n+1 bits." - exponent := ha - hb - n. - exponent >= 0 - ifTrue: [b := b bitShift: exponent] - ifFalse: [a := a bitShift: exponent negated]. - mantissa := a quo: b. - hasTruncatedBits := a > (mantissa * b). - hm := mantissa highBit. - - "Check for gradual underflow, in which case the mantissa will lose bits. - Keep at least one bit to let underflow preserve the sign of zero." - lostBit := Float emin - (exponent + hm - 1). - lostBit > 0 ifTrue: [n := n - lostBit max: 1]. - - "Remove excess bits in the mantissa." - hm > n - ifTrue: - [exponent := exponent + hm - n. - hasTruncatedBits := hasTruncatedBits or: [mantissa anyBitOfMagnitudeFrom: 1 to: hm - n]. - mantissa := mantissa bitShift: n - hm]. - - "Check if mantissa must be rounded upward. - The case of tie will be handled by Integer>>asFloat." - (hasTruncatedBits and: [mantissa odd]) - ifTrue: [mantissa := mantissa + 1]. - - floatMantissa := mantissa asFloat. - self positive ifFalse: [floatMantissa := floatMantissa negated]. - ^floatMantissa timesTwoPower: exponent! ! -!Integer methodsFor: 'bit manipulation' stamp: 'jmv 12/4/2018 11:59:58' prior: 16859338! - highBitOfMagnitude - "Answer the position of the leading bit or zero if the - receiver is zero. Receiver has to be positive!!" - - | shifted bitNo | - shifted := self < 0 ifTrue: [0 - self] ifFalse: [self]. - bitNo := 0. - [shifted < 65536] - whileFalse: - [shifted := shifted bitShift: -16. - bitNo := bitNo + 16]. - shifted < 256 - ifFalse: - [shifted := shifted bitShift: -8. - bitNo := bitNo + 8]. - - "The high bits table can be obtained with: - (1 to: 8) inject: #[0] into: [:highBits :rank | highBits , (highBits collect: [:e | rank])]." - ^bitNo + ( #[0 1 2 2 3 3 3 3 4 4 4 4 4 4 4 4 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8 8] at: shifted + 1)! ! -!LargePositiveInteger methodsFor: 'bit manipulation' stamp: 'jmv 12/4/2018 11:59:42' prior: 16862428! - highBit - "Answer the position of the leading bit or zero if the - receiver is zero. Raise an error if the receiver is negative, since - negative integers are defined to have an infinite number of leading 1's - in 2's-complement arithmetic. Use >>highBitOfMagnitude if you want to - get the highest bit of the magnitude." - ^ self highBitOfMagnitude! ! -!LargePositiveInteger methodsFor: 'bit manipulation' stamp: 'jmv 12/4/2018 12:04:04' prior: 16862443! - highBitOfMagnitude - "Answer the position of the leading bit or zero if the - receiver is zero. - This method is used for LargeNegativeIntegers as well, - since Squeak's LargeIntegers are sign/magnitude." - | byteIndex msByte | - byteIndex := self digitLength. - [byteIndex > 0] whileTrue: - [ - msByte := self at: byteIndex. - msByte > 0 ifTrue: [^byteIndex - 1 * 8 + msByte highBit]. - byteIndex := byteIndex - 1 - ]. - ^0! ! -!LargeNegativeInteger methodsFor: 'bit manipulation' stamp: 'jmv 12/4/2018 11:59:30' prior: 16862144! - highBit - "Answer the position of the leading bit or zero if the - receiver is zero. Raise an error if the receiver is negative, since - negative integers are defined to have an infinite number of leading 1's - in 2's-complement arithmetic. Use >>highBitOfMagnitude if you want to - get the highest bit of the magnitude." - - ^self error: 'highBit is not defined for negative integers'! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3513-NumericsCleanup-JuanVuletich-2018Dec04-10h24m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3512] on 4 December 2018 at 12:21:28 pm'! -!Float methodsFor: 'converting' stamp: 'jmv 12/4/2018 12:20:55' prior: 50421275! - partValues: aThreeArgumentBlock ifInfinite: infinityBlock ifNaN: nanBlock - " - Float pi hex print - Float pi partValues: [ :sign :exponent :mantissa | { sign hex. exponent hex. mantissa hex} print ] - 0.0 partValues: [ :sign :exponent :mantissa | { sign hex. exponent hex. mantissa hex} print ] - For 0.0, exponent will be the minimum possible, i.e. -1023, and mantissa will be 0. - " - | sign exponent mantissa | - - self partBits: [ :signBit :exponentBits :mantissaBits | - - "Extract the sign" - sign _ signBit = 0 ifTrue: [1] ifFalse: [-1]. - - "Special cases: infinites and NaN" - exponentBits = 16r7FF ifTrue: [ - ^mantissaBits = 0 - ifTrue: [ infinityBlock valueWithPossibleArgument: self ] - ifFalse: [ nanBlock valueWithPossibleArgument: self and: mantissaBits ]]. - - "Unbias exponent: 16r3FF is bias" - exponent _ exponentBits - 16r3FF. - - "Add back implicit leading 1 in fraction if appropriate" - "If expPart = 0, I am +/-zero or a denormal value. In such cases, no implicit leading bit in mantissa" - exponentBits = 0 - ifTrue: [ - mantissa _ mantissaBits. - exponent _ exponent + 1 ] - ifFalse: [ - mantissa _ 16r0010000000000000 bitOr: mantissaBits ]. - - "Evaluate the block" - ^aThreeArgumentBlock value: sign value: exponent value: mantissa - ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3514-NumericsCleanup-JuanVuletich-2018Dec04-12h19m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3512] on 4 December 2018 at 12:26:03 pm'! -!Float methodsFor: 'printing' stamp: 'jmv 12/3/2018 18:27:17' prior: 16845515! - hex - ^ String streamContents: [ :strm | | word nibble | - 1 to: 2 do: [ :i | - word := self at: i. - 1 to: 8 do: [ :s | - nibble := (word bitShift: -8+s*4) bitAnd: 16rF. - strm nextPut: ('0123456789ABCDEF' at: nibble+1)]]] -" -(-2.0 to: 2.0) collect: [:f | f hex] -"! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3515-NumericsCleanup-JuanVuletich-2018Dec04-12h21m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3515] on 4 December 2018 at 3:51:34 pm'! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/4/2018 15:21:29'! - nextAwayFromZero - "Answer the Float with smallest magnitude but larger than ours, with the same sign - Only for finite numbers." - - | exponent mantissa | - self partValues: [ :sign :myExponent :myMantissa | - myMantissa = 16r1FFFFFFFFFFFFF - ifTrue: [ - mantissa _ 16r10000000000000. - exponent _ myExponent +1 ] - ifFalse: [ - mantissa _ myMantissa+1. - exponent _ myExponent ]. - ^ Float signPart: sign mantissaPart: mantissa exponentPart: exponent ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/4/2018 15:21:25'! - nextTowardsZero - "Answer the Float with largest magnitude but smaller than ours, with the same sign. - Only for finite, non zero numbers." - - | exponent mantissa | - self partValues: [ :sign :myExponent :myMantissa | - myMantissa isZero ifTrue: [ self error: 'Not for zero values' ]. - (myMantissa = 16r10000000000000 and: [myExponent > Float emin]) - ifTrue: [ - mantissa _ 16r1FFFFFFFFFFFFF. - exponent _ myExponent -1 ] - ifFalse: [ - mantissa _ myMantissa-1. - exponent _ myExponent ]. - ^ Float signPart: sign mantissaPart: mantissa exponentPart: exponent ]! ! -!Float class methodsFor: 'instance creation' stamp: 'jmv 12/4/2018 14:10:38'! - signBit: signBit mantissaBits: mantissaBits exponentBits: exponentBits - " - Float signBit: Float pi signBit mantissaBits: Float pi mantissaBits exponentBits: Float pi exponentBits - " - | answer leastSignificativeWord mostSignificativeWord | - answer _ BoxedFloat64 new. - mostSignificativeWord _ (signBit bitShift: 31) + (exponentBits bitShift: 20) + (mantissaBits bitShift: -32). - leastSignificativeWord _ mantissaBits bitAnd: 16rFFFFFFFF. - answer basicAt: 1 put: mostSignificativeWord. - answer basicAt: 2 put: leastSignificativeWord. - ^ answer! ! -!Float class methodsFor: 'instance creation' stamp: 'jmv 12/4/2018 14:09:38'! - signPart: signPart mantissaPart: mantissaPart exponentPart: exponentPart - " - Float signPart: Float pi signPart mantissaPart: Float pi mantissaPart exponentPart: Float pi exponentPart - " - ^ signPart * mantissaPart asFloat timesTwoPower: exponentPart-52! ! -!Float methodsFor: 'converting' stamp: 'jmv 12/4/2018 13:37:51' prior: 50421242! - partBits: aThreeArgumentBlock - " - Extract the bits for Sign, Mantissa and Exponent parts of the Floating Point representation. - Just extract the bits. Do not add implicit bit. Do not correct denormals. Do not substract exponent bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. (f signPart * f significandAsInteger * (2 raisedToInteger: f exponentPart-52)) asFloat = f } print ]. - " - | signBit exponentBits mantissaBits leastSignificativeWord mostSignificativeWord | - - mostSignificativeWord _ self basicAt: 1. - leastSignificativeWord _ self basicAt: 2. - signBit _ mostSignificativeWord bitShift: -31 . - exponentBits _ (mostSignificativeWord bitShift: -20 ) bitAnd: 16r7FF. - mantissaBits _ ((mostSignificativeWord bitAnd: 16r000FFFFF) bitShift: 32) + leastSignificativeWord. - - "Evaluate the block" - ^aThreeArgumentBlock value: signBit value: exponentBits value: mantissaBits! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/4/2018 14:54:42' prior: 50421336! - predecessor - "Answer the largest Float smaller than self" - - self isFinite ifFalse: [ - (self isNaN or: [self negative]) ifTrue: [^self]. - ^Float fmax]. - self isZero ifTrue: [ - "Both for positive and negative zero" - ^ -0.0 nextAwayFromZero ]. - ^self > 0.0 - ifTrue: [ self nextTowardsZero ] - ifFalse: [ self nextAwayFromZero ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/4/2018 14:54:36' prior: 50421363! - successor - "Answer the smallest Float greater than self" - - self isFinite ifFalse: [ - (self isNaN or: [self positive]) ifTrue: [^self]. - ^Float fmax negated]. - self isZero ifTrue: [ - "Both for positive and negative zero" - ^ 0.0 nextAwayFromZero ]. - ^self < 0.0 - ifTrue: [ self nextTowardsZero ] - ifFalse: [ self nextAwayFromZero ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/4/2018 14:51:27' prior: 50421377! - ulp - "Answer the unit of least precision of the receiver" - - self isFinite ifFalse: [^self abs]. - ^ (self nextAwayFromZero - self) abs! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3516-muchBetterUlpPredecessorSuccessor-JuanVuletich-2018Dec04-15h44m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3508] on 6 December 2018 at 12:58:58 pm'! - -VariableScopeFinder removeSelector: #visitFieldNode:! - -VariableScopeFinder removeSelector: #visitFieldNode:! - -ParseNodeEnumerator removeSelector: #visitFieldNode:! - -ParseNodeEnumerator removeSelector: #visitFieldNode:! - -ParseNodeVisitor removeSelector: #visitFieldNode:! - -ParseNodeVisitor removeSelector: #visitFieldNode:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3517-Cleanup-HernanWilkinson-2018Dec06-12h58m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3517] on 10 December 2018 at 6:59:08 pm'! -!Float methodsFor: 'converting' stamp: 'jmv 12/10/2018 18:49:42' prior: 50421587! - partValues: aThreeArgumentBlock ifInfinite: infinityBlock ifNaN: nanBlock - " - Float pi hex print - Float pi partValues: [ :sign :exponent :mantissa | { sign hex. exponent hex. mantissa hex} print ] - 0.0 partValues: [ :sign :exponent :mantissa | { sign hex. exponent hex. mantissa hex} print ] - For 0.0, exponent will be the minimum possible, i.e. -1023, and mantissa will be 0. - " - | sign exponent mantissa | - - ^ self partBits: [ :signBit :exponentBits :mantissaBits | - - "Extract the sign" - sign _ signBit = 0 ifTrue: [1] ifFalse: [-1]. - - "Special cases: infinites and NaN" - exponentBits = 16r7FF ifTrue: [ - ^mantissaBits = 0 - ifTrue: [ infinityBlock valueWithPossibleArgument: self ] - ifFalse: [ nanBlock valueWithPossibleArgument: self and: mantissaBits ]]. - - "Unbias exponent: 16r3FF is bias" - exponent _ exponentBits - 16r3FF. - - "Add back implicit leading 1 in fraction if appropriate" - "If expPart = 0, I am +/-zero or a denormal value. In such cases, no implicit leading bit in mantissa" - exponentBits = 0 - ifTrue: [ - mantissa _ mantissaBits. - exponent _ exponent + 1 ] - ifFalse: [ - mantissa _ 16r0010000000000000 bitOr: mantissaBits ]. - - "Evaluate the block" - aThreeArgumentBlock value: sign value: exponent value: mantissa - ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/10/2018 18:49:08' prior: 50417780! - exponentBits - " - Actual bits for the exponent part of the Floating Point representation. - Just extract the bits. Do not correct denormals. Do not substract bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - { f. f exponentBits. f exponentPart. f exponent } print ]. - " - - ^ self partBits: [ :signBit :exponentBits :mantissaBits | exponentBits ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/10/2018 18:49:15' prior: 50417796! - mantissaBits - " - Actual bits for the mantissa part of the Floating Point representation. - Just extract the bits. Do not correct denormals. Do not substract bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - { f. f mantissaBits. f mantissaPart. f significand. } print ]. - " - ^ self partBits: [ :signBit :exponentBits :mantissaBits | mantissaBits ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/10/2018 18:54:58' prior: 50421656! - nextAwayFromZero - "Answer the Float with smallest magnitude but larger than ours, with the same sign - Only for finite numbers." - - | exponent mantissa | - ^ self partValues: [ :sign :myExponent :myMantissa | - myMantissa = 16r1FFFFFFFFFFFFF - ifTrue: [ - mantissa _ 16r10000000000000. - exponent _ myExponent +1 ] - ifFalse: [ - mantissa _ myMantissa+1. - exponent _ myExponent ]. - Float signPart: sign mantissaPart: mantissa exponentPart: exponent ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/10/2018 18:55:04' prior: 50421673! - nextTowardsZero - "Answer the Float with largest magnitude but smaller than ours, with the same sign. - Only for finite, non zero numbers." - - | exponent mantissa | - ^ self partValues: [ :sign :myExponent :myMantissa | - myMantissa isZero ifTrue: [ self error: 'Not for zero values' ]. - (myMantissa = 16r10000000000000 and: [myExponent > Float emin]) - ifTrue: [ - mantissa _ 16r1FFFFFFFFFFFFF. - exponent _ myExponent -1 ] - ifFalse: [ - mantissa _ myMantissa-1. - exponent _ myExponent ]. - Float signPart: sign mantissaPart: mantissa exponentPart: exponent ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/10/2018 18:49:24' prior: 50417812! - signBit - " - Actual bits for the exponent part of the Floating Point representation. - Just extract the bits. Do not correct denormals. Do not substract bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0. 0.0. -0.0} do: [ :f | - { f. f signBit. f signPart. f sign } print ]. - " - - ^ self partBits: [ :signBit :exponentBits :mantissaBits | signBit ]! ! -!Integer methodsFor: 'bit manipulation' stamp: 'jmv 12/10/2018 18:36:21' prior: 16859375! - lowBit - "Answer the index of the low order bit of this number" - - | byte byteIndex byteSize | - byteIndex _ 1. - byteSize _ self digitLength. - [ byteIndex <= byteSize ] whileTrue: [ - byte _ self at: byteIndex. - byte > 0 ifTrue: [ ^ byteIndex - 1 * 8 + byte lowBit ]. - byteIndex _ byteIndex + 1 ]. - ^ 0.! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3518-AvoidNonLocalReturns-JuanVuletich-2018Dec10-14h13m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3517] on 11 December 2018 at 1:42:08 pm'! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/11/2018 13:10:34' prior: 50421786! - ulp - "Answer the unit of least precision of the receiver. - Follow John Harrison's definition as described at - https://en.wikipedia.org/wiki/Unit_in_the_last_place" - - self isFinite ifFalse: [^self abs]. - self isZero ifTrue: [^0.0 nextAwayFromZero]. - ^ (self - self nextTowardsZero) abs! ! -!Float class methodsFor: 'constants' stamp: 'jmv 12/11/2018 13:21:21' prior: 16845879! - epsilon - "Answer difference between 1.0 and next representable value. - Note: does not equal 1.0 ulp." - - ^1.0 successor - 1.0! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3519-UseJohnHarrisonsUlp-JuanVuletich-2018Dec11-10h00m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3511] on 12 December 2018 at 12:40:54 pm'! -!ChangeSet class methodsFor: 'change set to use' stamp: 'jmv 12/12/2018 12:22:30' prior: 16799212! - notInstallOrTestRun - - ^Installing isNil or: [ - (Installing beginsWith: 'RunningTest-') and: [ Processor activeProcess name ~= 'TestRunner' ]] - - " - (Installing beginsWith: 'RunningTest-') and: [ Processor activeProcess name = 'TestRunner' ] -> Test - (Installing beginsWith: Install-') -> Install - Installing isNil -> Normal - (Installing beginsWith: 'RunningTest-') and: [ Processor activeProcess name ~= 'TestRunner' ] -> Normal - "! ! -!CodePackageFile methodsFor: 'services' stamp: 'jmv 12/12/2018 12:40:08' prior: 50401553! - install: aFileStream - "Installs the package. Replace all existing code in the CodePackage, removing any code that is not included in us." - | localName newCodePackage pckClass currentCS | - - "Give reasonable warnings if there is stuff that can't be properly cleaned. Give the user the chance to abort." - '=============' print. - classesToRemove notEmpty ifTrue: [ - ('classesToRemove: ', classesToRemove printString) print. - '=============' print ]. - methodsToRemove notEmpty ifTrue: [ - 'methodsToRemove: ' print. - methodsToRemove do: [ :methodReference | methodReference print ]. - '=============' print ]. - - "Tirar warning si hay que borrar cosas que no se puede, si hay referencias, etc. Quizas si vamos a borrar el ultimo implementor de un mensaje enviado?" - - "Create, install and answer a (sub)instance of CodePackage" - localName _ fullName asFileEntry name. - ChangeSet installing: packageName do: [ - "This change set will capture a possible class definition for a subclass of CodePackage. - If it only has that, then remove it after package install. - One example needing this is 'Color-Extras.pck.st'" - currentCS _ ChangeSet changeSetForBaseSystem. - currentCS isEmpty ifFalse: [ currentCS _ nil ]. - pckClass _ CodePackage. - classes do: [ :ee | - (ee hasDefinition and: [ee superclassName = 'CodePackage']) ifTrue: [ - ee fileInDefinitionAndMetaclass. - pckClass _ Smalltalk at: ee name ]]. - newCodePackage _ pckClass - named: packageName - createIfAbsent: true - registerIfNew: true. - newCodePackage - fullFileName: fullName; - sourceSystem: sourceSystem; - description: description; - featureSpec: featureSpec. - aFileStream fileInAnnouncing: 'Installing ', localName, '...'. - methodsToRemove do: [ :methodReference | methodReference actualClass removeSelector: methodReference selector ]. - classesToRemove do: [ :className | (Smalltalk at: className) removeFromSystem ]. - currentCS ifNotNil: [ ChangeSet removeChangeSet: currentCS ]]. - newCodePackage hasUnsavedChanges: false; triggerEvent: #dirtyFlagChanged. - DataStream initialize. "Just in case" - "If we are installing an already installed package, zap the change set with possible changes done, - as they are irrelevant now: we have the package from disk" - ChangeSet removeChangeSet: (ChangeSet existingOrNewChangeSetForPackage: newCodePackage). - Transcript newLine; show: 'Package ', packageName, ' successfully installed'; newLine. - - "Tirar undeclared al transcript. warning si quedaron undeclared - Es feo que tire an transcript undeclareds que despues no lo son..." - Smalltalk cleanOutUndeclared. - Undeclared notEmpty ifTrue: [ - ('Undeclared: ', Undeclared printString) print ]. - - "Descartar la instancia de CodePackageFile" - ^newCodePackage! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3520-AvoidSuperfluousCSOnPackageInstall-JuanVuletich-2018Dec12-12h40m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3520] on 13 December 2018 at 5:20:43 pm'! -!Scanner methodsFor: 'multi-character scans' stamp: 'jmv 12/12/2018 16:22:24' prior: 16904023! - xBinary - - tokenType _ #binary. - token _ String streamContents: [ :stream | - stream nextPut: self step. - [ | type | - type _ self typeTableAt: hereChar. - type == #xBinary and: [hereChar ~= $- or: [aheadChar isDigit not]] - ] whileTrue: [ - stream nextPut: self step]]. - token _ token asSymbol! ! -!Scanner class methodsFor: 'cached class state' stamp: 'jmv 12/12/2018 15:33:25' prior: 50410161! - initTypeTable - | newTable | - newTable := Array new: 256 withAll: #xIllegal. "default" - newTable atAll: #(9 10 12 13 32 ) put: #xDelimiter. "tab lf ff cr space" - - 1 to: 255 - do: [:index | - (Character numericValue: index) isValidInIdentifiers - ifTrue: [ - "Digits and $_ are overwritten later" - newTable at: index put: #xLetter ]]. - - newTable atAll: ($0 numericValue to: $9 numericValue) put: #xDigit. - newTable atAll: '¡!!%&+-*/\±×÷¬­¯,<=>”•–—˜™š›œ«»¿?@~€‚ƒŽ‘’“žŸ°·¢£¤¥µ¶„…§©®¹²³ªº' asByteArray put: #xBinary. - - newTable at: self doItCharacterValue put: #doIt. - newTable at: $" numericValue put: #xDoubleQuote. - newTable at: $# numericValue put: #xLitQuote. - newTable at: $$ numericValue put: #xDollar. - newTable at: $' numericValue put: #xSingleQuote. - newTable at: $` numericValue put: #xBacktick. - newTable at: $: numericValue put: #xColon. - newTable at: $( numericValue put: #leftParenthesis. - newTable at: $) numericValue put: #rightParenthesis. - newTable at: $. numericValue put: #period. - newTable at: $; numericValue put: #semicolon. - newTable at: $[ numericValue put: #leftBracket. - newTable at: $] numericValue put: #rightBracket. - newTable at: ${ numericValue put: #leftBrace. - newTable at: $} numericValue put: #rightBrace. - newTable at: $^ numericValue put: #upArrow. - newTable at: $_ numericValue put: #xUnderscore. - newTable at: $| numericValue put: #verticalBar. - TypeTable := newTable "bon voyage!!" - - " - Scanner initTypeTable - "! ! -!Parser methodsFor: 'private' stamp: 'jmv 12/12/2018 16:17:46' prior: 16885517! - privateReadSelector - | args selector | - doitFlag := false. - - hereType == #word ifTrue: [ - ^ here asSymbol ]. - - self transformVerticalBarAndUpArrowIntoABinarySelector. - - hereType == #binary ifTrue: [ - ^ here asSymbol ]. - - hereType == #keyword ifTrue: [ - selector := WriteStream on: (String new: 32). - args := OrderedCollection new. - [hereType == #keyword] whileTrue: [ - selector nextPutAll: self advance. - args addLast: (encoder bindArg: self argumentName). - ]. - ^ selector contents asSymbol ]. - - ^self expected: 'Message pattern'! ! -!Parser methodsFor: 'scanning' stamp: 'jmv 12/13/2018 17:07:02' prior: 16885783! - transformVerticalBarAndUpArrowIntoABinarySelector - "Transform a vertical bar and or a up arrow into a binary selector. - Eventually aggregate a serie of immediately following vertical bars, up arrows and a binary selector. - Note that this aggregation cannot occur at scan time, because a pair of vertical bars can be encountered in two valid constructs: - - either as an empty temporaries specification, - - or as a local temporaries specification in a block of arity > 0. - Also do the same with some other special characters that are allowed as binary selectors, in addition to their traditional meaning" - | special | - special _ #(verticalBar upArrow). - (special identityIncludes: hereType) ifFalse: [ - ^ self ]. - here := here asString. - hereType := #binary. - [(special identityIncludes: tokenType) and: [hereMark + here size = mark]] - whileTrue: [ - here := here , token asString. - hereEnd := hereEnd + 1. - self scanToken]. - (tokenType == #binary and: [hereMark + here size = mark]) - ifTrue: [ - here := here asString , token. - hereType := #binary. - hereEnd := hereEnd + token size. - self scanToken].! ! -!Parser methodsFor: 'expression types' stamp: 'jmv 12/12/2018 16:17:30' prior: 50409422! - messagePart: level repeat: repeat - - | start receiver selector args precedence words keywordStart | - - [receiver := parseNode. - (hereType == #keyword and: [level >= 3]) - ifTrue: - [start := self startOfNextToken. - selector := WriteStream on: (String new: 32). - args := OrderedCollection new. - words := OrderedCollection new. - [hereType == #keyword] - whileTrue: - [keywordStart := self startOfNextToken + requestorOffset. - selector nextPutAll: self advance. - words addLast: (keywordStart to: self endOfLastToken + requestorOffset). - self primaryExpression ifFalse: [^self expected: 'Argument']. - self messagePart: 2 repeat: true. - args addLast: parseNode]. - (Symbol hasInterned: selector contents ifTrue: [ :sym | selector := sym]) - ifFalse: [ selector := self correctSelector: selector contents - wordIntervals: words - exprInterval: (start to: self endOfLastToken) - ifAbort: [ ^ self fail ] ]. - precedence := 3] - ifFalse: [ - - level >= 2 ifTrue: [self transformVerticalBarAndUpArrowIntoABinarySelector]. - ((hereType == #binary ) - and: [level >= 2]) - ifTrue: - [start := self startOfNextToken. - selector := self advance asSymbol. - words := OrderedCollection with: (start + requestorOffset to: self endOfLastToken + requestorOffset). - self primaryExpression ifFalse: [^self expected: 'Argument']. - self messagePart: 1 repeat: true. - args := Array with: parseNode. - precedence := 2] - ifFalse: [hereType == #word - ifTrue: - [start := self startOfNextToken. - selector := self advance. - args := #(). - words := OrderedCollection with: (start + requestorOffset to: self endOfLastToken + requestorOffset). - (Symbol hasInterned: selector ifTrue: [ :sym | selector := sym]) - ifFalse: [ selector := self correctSelector: selector - wordIntervals: words - exprInterval: (start to: self endOfLastToken) - ifAbort: [ ^ self fail ] ]. - precedence := 1] - ifFalse: [^args notNil]]]. - - parseNode := MessageNode new - receiver: receiver - selector: selector - arguments: args - precedence: precedence - from: encoder - sourceRange: (start to: self endOfLastToken) - keywordsRanges: words. - repeat] - whileTrue: []. - ^true! ! -!Parser methodsFor: 'expression types' stamp: 'jmv 12/12/2018 16:16:14' prior: 50409396! - pattern: fromDoit inContext: ctxt - " unarySelector | binarySelector arg | keyword arg {keyword arg} => - {selector, arguments, precedence}." - - doitFlag := fromDoit. - - fromDoit ifTrue: [^self doitPatternInContext: ctxt ]. - hereType == #word ifTrue: [^self unaryPattern ]. - self transformVerticalBarAndUpArrowIntoABinarySelector. - hereType == #binary ifTrue: [^self binaryPattern ]. - hereType == #keyword ifTrue: [^self keywordPattern ]. - - ^self expected: 'Message pattern' -! ! - -Parser removeSelector: #transformVerticalBarAndUpArrowIntoABinarySelectorIfNecessary! - -Parser removeSelector: #transformVerticalBarAndUpArrowIntoABinarySelectorIfNecessary! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3521-AdditionalPossibleBinarySelectors-JuanVuletich-2018Dec13-17h19m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3521] on 13 December 2018 at 7:37:45 pm'! -!Parser methodsFor: 'scanning' stamp: 'jmv 12/13/2018 19:37:11' prior: 50422194! - transformVerticalBarAndUpArrowIntoABinarySelector - "Transform a vertical bar and or a up arrow into a binary selector. - Eventually aggregate a serie of immediately following vertical bars, up arrows and a binary selector. - Note that this aggregation cannot occur at scan time, because a pair of vertical bars can be encountered in two valid constructs: - - either as an empty temporaries specification, - - or as a local temporaries specification in a block of arity > 0. - Colon $: can be used as binary, but '::' means Chain." - | toMakeBinary | - toMakeBinary _ #(verticalBar upArrow colon). - "Special case: '::' is not a binary selector but the Chain operator" - (hereType = #colon and: [tokenType = #colon]) ifTrue: [^ self ]. - (toMakeBinary identityIncludes: hereType) ifFalse: [ - ^ self ]. - here := here asString. - hereType := #binary. - [(toMakeBinary identityIncludes: tokenType) and: [hereMark + here size = mark]] - whileTrue: [ - here := here , token asString. - hereEnd := hereEnd + 1. - self scanToken]. - (tokenType == #binary and: [hereMark + here size = mark]) - ifTrue: [ - here := here asString , token. - hereType := #binary. - hereEnd := hereEnd + token size. - self scanToken].! ! -!SHParserST80 methodsFor: 'token testing' stamp: 'jmv 12/13/2018 19:37:20' prior: 16902034! - isBinary - | c | - (currentToken isNil or: [self isName or: [self isKeyword]]) - ifTrue: [^false]. - "Special case: '::' is not a binary selector but the Chain operator" - (sourcePosition - currentTokenSourcePosition = 1 and: [ - (source at: currentTokenSourcePosition ifAbsent: nil) = $: and: [ - (source at: sourcePosition ifAbsent: nil) = $: ]]) - ifTrue: [^ false ]. - 1 to: currentToken size do: [ :i | - c := currentToken at: i. - ((self isBinarySelectorCharacter: c) or: [c == $:]) - ifFalse: [^false]]. - ^true! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3522-AllowColonAsBinarySelector-JuanVuletich-2018Dec13-19h33m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3508] on 13 December 2018 at 4:50:45 pm'! - -Object subclass: #StackSizeWatcher - instanceVariableNames: 'watcher timeBetweenChecks stackSizeThreashold delay delayBetweenChecks ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Profiling' -! - -!classDefinition: #StackSizeWatcher category: #'Tools-Profiling'! -Object subclass: #StackSizeWatcher - instanceVariableNames: 'watcher timeBetweenChecks stackSizeThreashold delay delayBetweenChecks' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Profiling'! -!StackSizeWatcher methodsFor: 'configuration changing' stamp: 'HAW 12/13/2018 16:28:08' prior: 50389898! - changeTimeBetweenChecksTo: aTimeBetweenChecks - - "time in milliseconds - Hernan" - - delayBetweenChecks _ Delay forMilliseconds: aTimeBetweenChecks. -! ! -!StackSizeWatcher methodsFor: 'testing' stamp: 'HAW 12/13/2018 16:48:10' prior: 50389929! - shouldStopAndDebug: aProcess - - "Verify the process can be debugged before #isStackTooDeepAt: to avoid - loosing time in #isStackDeeperThan: that is more expensive - Hernan" - - ^(self canDebug: aProcess) and: [self isStackTooDeepAt: aProcess] - -! ! -!StackSizeWatcher methodsFor: 'private' stamp: 'HAW 12/13/2018 16:29:13' prior: 50389965! - watch - - | processToWatch | - - delayBetweenChecks wait. - processToWatch := Processor nextReadyProcess. - (self shouldStopAndDebug: processToWatch) ifTrue: [ self debug: processToWatch ] -! ! -!StackSizeWatcher class methodsFor: 'start/stop' stamp: 'HAW 12/13/2018 16:21:22' prior: 50389993! - isWatching - - ^ current notNil and: [ current isWatching ]! ! - -Object subclass: #StackSizeWatcher - instanceVariableNames: 'watcher stackSizeThreashold delayBetweenChecks' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Profiling' -! - -!classDefinition: #StackSizeWatcher category: #'Tools-Profiling'! -Object subclass: #StackSizeWatcher - instanceVariableNames: 'watcher stackSizeThreashold delayBetweenChecks' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Profiling'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3523-StackSizeWatcher-improvements-HernanWilkinson-2018Dec13-16h20m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3523] on 13 December 2018 at 8:18:41 pm'! -!Debugger methodsFor: 'private' stamp: 'jmv 12/13/2018 20:18:10' prior: 16830176! - resumeProcess - | mustTerminateActive mustRedisplay | - mustRedisplay _ self runningWorld. - savedCursor - ifNotNil: [savedCursor activateCursor]. - mustTerminateActive _ false. - interruptedProcess isTerminated ifFalse: [ - Processor activeProcess animatedUI = interruptedProcessUI ifTrue: [ - interruptedProcess animatedUI: interruptedProcessUI. - mustTerminateActive _ true ]. - interruptedProcess resume ]. - "if old process was terminated, just terminate current one" - interruptedProcess _ nil. - contextStackIndex _ 0. - contextStack _ nil. - contextStackTop _ nil. - receiverInspector _ nil. - contextVariablesInspector _ nil. - mustRedisplay ifNotNil: [ :w | UISupervisor whenUIinSafeState: [ w displayWorld ]]. - "restart low space handler" - Smalltalk installLowSpaceWatcher. - "If this process was the UI process, then it will terminate and never return to caller." - mustTerminateActive - ifTrue: [ Processor terminateActive ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3524-DebuggerResumeRedisplayFix-JuanVuletich-2018Dec13-20h18m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3524] on 14 December 2018 at 3:43:44 pm'! -!Character methodsFor: 'testing' stamp: 'jmv 12/14/2018 15:30:45'! - isValidInBinarySelectors - "Can be part of a binary selector? - $< isValidInBinarySelectors - $| isValidInBinarySelectors - $^ isValidInBinarySelectors - $: isValidInBinarySelectors - " - ^#(verticalBar upArrow xColon xBinary) statePointsTo: (Scanner typeTable at: self numericValue)! ! -!String methodsFor: 'converting' stamp: 'jmv 12/14/2018 15:40:54' prior: 16916666! - findSelector - "Revised to use scanner for better removal of extraneous stuff" - | sel colonIndex | - sel _ self withBlanksTrimmed. - colonIndex _ sel indexOf: $:. - "possible keyword selector" - (colonIndex > 1 and: [ (self at: colonIndex - 1) isLetter ]) ifTrue: [ - sel _ Scanner findSelectorIn: sel ]. - sel isEmpty ifTrue: [ ^ nil ]. - Symbol - hasInterned: sel - ifTrue: [ :aSymbol | - ^ aSymbol ]. - ^ nil.! ! -!String methodsFor: 'converting' stamp: 'jmv 12/14/2018 09:53:01' prior: 16916699! - keywords - "Answer an array of the keywords that compose the receiver." - | kwd char keywords isAllLeters | - keywords _ Array streamContents: [ :kwds | - kwd _ WriteStream on: (String new: 16). - isAllLeters _ true. - 1 - to: self size - do: [ :i | - char _ self at: i. - kwd nextPut: char. - char = $: & isAllLeters - ifTrue: [ - kwds nextPut: kwd contents. - kwd reset. - isAllLeters _ true ] - ifFalse: [ - char isLetter ifFalse: [ isAllLeters _ false ]]]. - kwd isEmpty ifFalse: [ kwds nextPut: kwd contents ]]. - - ^ keywords.! ! -!String methodsFor: 'system primitives' stamp: 'jmv 12/14/2018 15:27:30' prior: 16917278! - 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 start ix | - self size = 0 ifTrue: [ ^ -1 ]. - "Binary messages" - (self allSatisfy: [ :c | c isValidInBinarySelectors ]) - ifTrue: [ ^1 ]. - "Unary and keyword messages" - firstChar _ self at: 1. - firstChar isValidStartOfIdentifiers 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 ]. - ^ -1.! ! -!Symbol methodsFor: 'accessing' stamp: 'jmv 12/14/2018 15:41:59' prior: 16918441! - 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." - - | c | - self size = 0 ifTrue: [^ 0]. - "Consider selectors starting with an underscore $_ as unary, even if Preferences allowUnderscoreSelectors is not set." - c _ self first. - c isValidInBinarySelectors ifTrue: [^ 2]. - self last = $: ifTrue: [^ 3]. - ^ 1! ! -!SHParserST80 methodsFor: 'character testing' stamp: 'jmv 12/14/2018 15:39:18' prior: 50386078! - isBinarySelectorCharacter: aCharacter - aCharacter = $: ifTrue: [^ false]. - ^aCharacter isValidInBinarySelectors! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3525-MiscFixesForColonAsBinarySelector-JuanVuletich-2018Dec14-13h29m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3512] on 17 December 2018 at 10:09:21 am'! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'jmv 12/17/2018 10:09:17' prior: 16923172! - forceChangesToDisk - "Ensure that the changes file has been fully written to disk by closing and re-opening it. This makes the system more robust in the face of a power failure or hard-reboot." - - | changesFile | - "Expensive and not worth doing, esp. in Windows with antivirus active, when installing large packages" - ChangeSet notInstallOrTestRun ifTrue: [ - changesFile _ SourceFiles at: 2. - changesFile isFileStream ifTrue: [ - changesFile flush. - changesFile close. - changesFile open: changesFile name forWrite: true. - changesFile setToEnd. - ]. - ]! ! -!ChangeSet class methodsFor: 'change set to use' stamp: 'jmv 12/17/2018 10:05:42' prior: 16799185! - installing: aCodePackageOrChangeSetName do: aBlock - - | currentCS currentCSNumber newHighestUpdate | - Installing _ 'Install-', aCodePackageOrChangeSetName. - aBlock ensure: [ Installing _ nil ]. - Smalltalk forceChangesToDisk. - - SystemVersion current registerUpdate: aCodePackageOrChangeSetName. - newHighestUpdate _ SystemVersion current highestUpdate. - - currentCSNumber _ self currentBaseCSNumber. - currentCS _ self changeSetForBaseSystem. - currentCS isEmpty ifTrue: [ - ChangeSet removeChangeSet: currentCS. - currentCSNumber > newHighestUpdate ifFalse: [ - CurrentBaseCSNumber _ newHighestUpdate + 1 ]]! ! -!SmalltalkCompleter class methodsFor: 'class initialization' stamp: 'jmv 12/17/2018 10:08:59' prior: 16909373! - addSelector: aSymbol method: aCompiledMethod allImplemented: implemented - - | sentValue value | - self protected: [ - value _ ChangeSet notInstallOrTestRun - ifTrue: [ - "Expensive and not worth doing, esp. in Windows with antivirus active, when installing large packages" - aCompiledMethod dateSortingValue ] - ifFalse: [ 0 ]. - Selectors at: aSymbol put: (value max: (Selectors at: aSymbol ifAbsent: [0])). - aCompiledMethod messages do: [ :sentMsg | - ((Selectors includesKey: sentMsg) or: [ - implemented - ifNotNil: [ implemented includes: sentMsg ] - ifNil: [ Smalltalk isThereAnImplementorOf: sentMsg ]]) - ifTrue: [ - sentValue _ value max: (Selectors at: sentMsg ifAbsent: [0]). - Selectors at: sentMsg put: sentValue ]]]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3526-FasterPackageInstallInWindows-JuanVuletich-2018Dec17-10h04m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3526] on 18 December 2018 at 12:49:31 pm'! -!Color class methodsFor: 'examples' stamp: 'jmv 12/17/2018 16:29:53'! - experimentsTowardsANewColorPalette -" -self experimentsTowardsANewColorPalette -" -| selectedHue selectedSaturation selectedV selectedColor h s v color width height selectedChroma selectedLuminance | -width _ 300. -height _ 120. -selectedColor _ Color random. -selectedHue _ selectedColor hue. -selectedSaturation _ selectedColor saturation. -selectedChroma _ selectedColor chroma. -selectedV _ selectedColor brightness. -selectedLuminance _ selectedColor luminance. -Display getCanvas fillRectangle: (0@0 extent: height@height) color: selectedColor. -0 to: height do: [ :y | - v _ 1.0 - (y / height). - 0 to: height do: [ :x | - s _ x / height. - color _ Color new setHue: selectedHue saturation: s brightness: v. - Display colorAt: x@(y+height) put: color - ]. - DisplayScreen screenUpdateRequired: nil -]. -0 to: height do: [ :y | | c | - v _ 1.0 - (y / height). - s _ 1.0 - (y / height). - c _ s. - 0 to: width do: [ :x | - h _ x / width * 360. - - color _ Color new setHue: h chroma: c luminance: selectedLuminance. -" color _ Color new setHue: h chroma: c brightness: selectedV." - color ifNil: [ color _ Color black ]. -" color _ Color new setHue: h saturation: s brightness: selectedV." - Display colorAt: x+height@y put: color. - - color _ Color new setHue: h chroma: selectedChroma luminance: v. -" color _ Color new setHue: h chroma: selectedChroma brightness: v." - color ifNil: [ color _ Color black ]. -" color _ Color new setHue: h saturation: selectedSaturation brightness: v." - Display colorAt: x+height@(y+height) put: color. - - ]. - DisplayScreen screenUpdateRequired: nil -].! ! - -Color class removeSelector: #experimentsTowarsANewColorPalette! - -Color class removeSelector: #experimentsTowarsANewColorPalette! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3527-Color-tweak-JuanVuletich-2018Dec18-12h49m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3526] on 18 December 2018 at 12:50:08 pm'! -!Number methodsFor: 'comparing' stamp: 'jmv 12/18/2018 09:09:38'! - % another - "Answer the relative distance between two number" - ^ (self - another) abs / (self abs + another abs / 2)! ! -!Float methodsFor: 'truncation and round off' stamp: 'sqr 12/14/2018 23:01:59'! - floatsAwayFrom: aFloat - - | count2 count1 | - (self isNaN or: [ aFloat isNaN ]) ifTrue: [ ^ Float nan ]. - self partBits: [:s :e :m | count2 := (e bitShift: self class precision - 1) + m * (s * -2 + 1)]. - aFloat partBits: [:s :e :m | count1 := (e bitShift: self class precision - 1) + m * (s * -2 + 1)]. - ^count2 - count1! ! -!Float methodsFor: 'comparing' stamp: 'sqr 12/14/2018 23:04:40'! - isWithin: anInteger floatsFrom: aNumber - - ^self floatsAwayFrom: aNumber :: abs <= anInteger! ! -!Float methodsFor: 'mathematical functions' stamp: 'sqr 12/14/2018 23:35:21' prior: 16844641! - degreeCos - "If finite, allow for special values such as cos(60 degrees) = 1/2" - - self isFinite ifTrue: [^super degreeCos]. - ^self degreesToRadians cos! ! -!Float methodsFor: 'mathematical functions' stamp: 'sqr 12/14/2018 23:35:44' prior: 16844648! - degreeSin - "If finite, allow for special values such as cos(30 degrees) = 1/2" - - self isFinite ifTrue: [^super degreeSin]. - ^self degreesToRadians sin! ! -!Interval class methodsFor: 'instance creation' stamp: 'sqr 12/15/2018 00:19:19' prior: 16861321! - from: start to: stop by: step - "Answer an instance of me, starting at start, ending at - stop, and with an interval increment of step. - The actual interval creation uses start, stop and count, to avoid accumulation of rounding errors. - We need to tell apart things like - (0.0 to: 2.4 by: 0.1) the caller wants to honor end - from - (0.0 to: 10.0 by: 3.0) the caller actually wants to end at 9.0. - - Before this, - (0 to: 2.4 by: 0.1) last - used to answer 2.3" - | count end | - count _ stop - start / step + 1. - (count isFloat and: [count isWithin: 5 floatsFrom: count rounded asFloat]) - ifTrue: [ - count _ count rounded. - end _ stop ] - ifFalse: [ - count _ count truncated. - end _ count-1 * step + start ]. - ^self from: start to: end count: count! ! - -Float removeSelector: #closeTo:! - -Float removeSelector: #closeTo:! - -Float removeSelector: #isWithin:ulpsFrom:! - -Float removeSelector: #isWithin:ulpsFrom:! - -Float removeSelector: #reduce! - -Float removeSelector: #reduce! - -Number removeSelector: #closeTo:! - -Number removeSelector: #closeTo:! - -Number removeSelector: #isWithin:ulpsFrom:! - -Number removeSelector: #isWithin:ulpsFrom:! - -Number removeSelector: #reduce! - -Number removeSelector: #reduce! - -Object removeSelector: #closeTo:! - -Object removeSelector: #closeTo:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3528-Numerics-tweaks-JuanVuletich-2018Dec18-12h49m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3526] on 17 December 2018 at 6:04:42 pm'! -!String methodsFor: 'converting' stamp: 'HAW 12/17/2018 18:03:42' prior: 50422544! - keywords - "Answer an array of the keywords that compose the receiver." - | kwd char keywords isAllValidInIdentifiers | - keywords _ Array streamContents: [ :kwds | - kwd _ WriteStream on: (String new: 16). - isAllValidInIdentifiers _ true. - 1 - to: self size - do: [ :i | - char _ self at: i. - kwd nextPut: char. - char = $: & isAllValidInIdentifiers - ifTrue: [ - kwds nextPut: kwd contents. - kwd reset. - isAllValidInIdentifiers _ true ] - ifFalse: [ - char isValidInIdentifiers ifFalse: [ isAllValidInIdentifiers _ false ]]]. - kwd isEmpty ifFalse: [ kwds nextPut: kwd contents ]]. - - ^ keywords.! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3529-FixToColonAsBinarySelector-HernanWilkinson-2018Dec17-18h03m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3529] on 20 December 2018 at 10:58:38 am'! -!ObjectExplorer methodsFor: 'user interface support' stamp: 'jmv 12/20/2018 10:52:46'! - methodNodeOf: aSourceCode ifErrorsParsing: aParsingErrorBlock - - ^aParsingErrorBlock value: nil! ! -!TestResult methodsFor: 'Running' stamp: 'jmv 12/20/2018 10:58:20' prior: 16927991! - runCase: aTestCase - - | testCasePassed | - - testCasePassed _ - [ - [ - Transcript show: 'Will run: '; print: aTestCase; newLine. - aTestCase runCase. - Transcript show: 'finished.'; newLine. - true] - on: self class failure - do: [ :signal | - Transcript print: signal; newLine. - (self failures isEmpty or: [ (failures last == aTestCase) not ]) - ifTrue: [ failures add: aTestCase ]. - signal sunitExitWith: false ]] - on: self class error - do: [ :signal | - Transcript print: signal; newLine. - aTestCase errored: signal. - self errors add: aTestCase. - signal sunitExitWith: false ]. - - testCasePassed - ifTrue: [ self passed add: aTestCase ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3530-FixImplementorsInExplorer-LogTestInfoToTranscript-JuanVuletich-2018Dec20-10h50m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3529] on 20 December 2018 at 11:08:36 am'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 12/20/2018 11:07:32'! - storeOn: aStream - self == Smalltalk ifTrue: [ - ^ aStream nextPutAll: 'Smalltalk']. - ^ super storeOn: aStream! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3531-FixInfiniteRecursionOnDecompilingSmalltalkRefs-JuanVuletich-2018Dec20-10h58m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3529] on 20 December 2018 at 11:16:32 am'! -!FileIOAccessor methodsFor: 'private' stamp: 'pb 5/25/2016 00:32' prior: 50413540! - basicDirectoryExists: fullPathName - - | result | - result := self primLookupEntryIn: fullPathName index: 1. - ^(result == #badDirectoryPath) not! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3532-EmptyDirectoryDoesExist-JuanVuletich-2018Dec20-11h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3529] on 19 December 2018 at 6:02:57 pm'! - -SmallInteger removeSelector: #instVarAt:! - -SmallInteger removeSelector: #instVarAt:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3533-RemoveSmallIntegerInstVarAt-JuanVuletich-2018Dec19-18h02m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3533] on 21 December 2018 at 7:33:06 am'! -!Number methodsFor: 'arithmetic' stamp: 'jmv 12/20/2018 16:59:41'! - ^ another - "Covenient, usual idiom. - 2 ^ 8 - " - ^ self raisedTo: another! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3534-CaretAsRaisedTo-JuanVuletich-2018Dec21-07h32m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3533] on 21 December 2018 at 7:39:11 am'! -!Number methodsFor: 'printing' stamp: 'jmv 12/20/2018 17:54:18' prior: 16880287! -printOn: aStream fractionDigits: placesDesired - "Print a representation of the receiver on aStream in decimal notation with prescribed number of places after decimal separator." - - | rounder rounded roundedFractionPart | - placesDesired > 0 ifFalse: [ ^ self rounded printOn: aStream ]. - rounder _ 10 raisedToInteger: placesDesired. - rounded _ self roundTo: rounder reciprocal. - rounded negative ifTrue: [ aStream nextPut: $- ]. - rounded _ rounded abs. - rounded integerPart truncated printOn: aStream. - aStream nextPut: $.. - roundedFractionPart _ (rounded fractionPart * rounder) truncated. - roundedFractionPart - printOn: aStream - base: 10 - length: placesDesired - padded: true! ! -!Number methodsFor: 'printing' stamp: 'jmv 12/20/2018 16:30:54' prior: 16880311! - printOn: aStream integerDigits: placesLeftOfFractionPoint fractionDigits: placesRightOfFractionPoint - "placesLeftOfFractionPoint is the minimum to be used (use more if required) - placesRightOfFractionPoint is strict. Add extra zeros or round as appropriate." - " - String streamContents: [ :strm | 23 printOn: strm integerDigits: 3 fractionDigits: 5 ] - String streamContents: [ :strm | 1.23 printOn: strm integerDigits: 3 fractionDigits: 5 ] - String streamContents: [ :strm | 123456.23 printOn: strm integerDigits: 3 fractionDigits: 5 ] - String streamContents: [ :strm | Float pi printOn: strm integerDigits: 3 fractionDigits: 5 ] - String streamContents: [ :strm | Float nan printOn: strm integerDigits: 3 fractionDigits: 5 ] - String streamContents: [ :strm | Float infinity printOn: strm integerDigits: 3 fractionDigits: 5 ] - String streamContents: [ :strm | Float negativeInfinity printOn: strm integerDigits: 3 fractionDigits: 5 ] - String streamContents: [ :strm | Float zero printOn: strm integerDigits: 3 fractionDigits: 5 ] - " - - ^self printOn: aStream integerDigits: placesLeftOfFractionPoint padWith: nil fractionDigits: placesRightOfFractionPoint positiveIndicator: nil! ! -!Float methodsFor: 'printing' stamp: 'jmv 12/21/2018 07:38:12' prior: 16845543! - printOn: aStream fractionDigits: placesDesired - "This implementation avoids any rounding error caused by rounded or roundTo: - The approach is simple. Round to appropriate integer, take the digits, and just - add the decimal point in the appropriate place." - - | i s scaled | - self isFinite ifFalse: [ ^self printOn: aStream ]. - - placesDesired > 0 ifFalse: [ - ^self rounded printOn: aStream ]. - - scaled _ self * (10 raisedTo: placesDesired). - "If rounding could possible print a sequence that is read back as a different float, then go the more expensive Fraction way. - If the following line is commented, #testPrintShowingDecimalPlaces4 will fail!!" - scaled ulp > 1 ifTrue: [ - ^ self asTrueFraction printOn: aStream fractionDigits: placesDesired ]. - i _ scaled rounded. - i negative ifTrue: [ - aStream nextPut: $-. - i _ i negated ]. - s _ i printString. - placesDesired + 1 > s size - ifTrue: [ - aStream nextPutAll: '0.'. - placesDesired - s size timesRepeat: [ aStream nextPut: $0 ]. - aStream nextPutAll: s ] - ifFalse: [ - aStream - nextPutAll: (s copyFrom: 1 to: s size-placesDesired); - nextPut: $.; - nextPutAll: (s copyFrom: s size-placesDesired+1 to: s size) ]! ! -!Fraction methodsFor: 'printing' stamp: 'jmv 12/20/2018 17:54:02' prior: 16849803! - printOn: aStream fractionDigits: placesDesired - "Same as super, but provides a faster implementation by inlining some Fraction protocol thus avoiding intermediate Fraction creation." - - | roundedFractionPart integerPart scaling | - placesDesired > 0 - ifFalse: [self rounded printOn: aStream] - ifTrue: [ - scaling := 10 raisedToInteger: placesDesired. - integerPart := numerator abs quo: denominator. - roundedFractionPart := (numerator abs - (integerPart * denominator)) * scaling * 2 + denominator quo: denominator * 2. - roundedFractionPart = scaling - ifTrue: - [integerPart := integerPart + 1. - roundedFractionPart := 0]. - "Don't print minus sign if result is rouded to zero" - (numerator negative and: [integerPart > 0 or: [roundedFractionPart > 0]]) ifTrue: [aStream nextPut: $-]. - integerPart printOn: aStream. - aStream nextPut: $.. - roundedFractionPart printOn: aStream base: 10 length: placesDesired padded: true].! ! -!Integer methodsFor: 'printing' stamp: 'jmv 12/20/2018 17:54:47' prior: 16859997! - printOn: aStream fractionDigits: placesDesired - "Same as super, but provides a faster implementation because fraction part and rounding are trivial." - - self printOn: aStream base: 10. - - placesDesired > 0 - ifTrue: [ - aStream nextPut: $.. - placesDesired timesRepeat: [ - aStream nextPut: $0 ]]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3535-printOnFractionDigits-fix-JuanVuletich-2018Dec21-07h33m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3537] on 21 December 2018 at 2:50:39 pm'! -!Editor class methodsFor: 'help' stamp: 'jmv 12/21/2018 10:14:26' prior: 50405344! - help - " - TextEditor help edit - SmalltalkEditor help edit - " - | allSpecs | - allSpecs _ self cmdShortcutsSpec, self basicCmdShortcutsSpec. - ^String streamContents: [ :strm | - allSpecs do: [ :triplet | | c | - c _ triplet first = Character space - ifFalse: [ triplet first asString, ' ' ] - ifTrue: [ 'Space']. - strm nextPutAll: ('Cmd-', c, String tab, String tab, triplet third). - strm newLine ]]! ! -!TextEditor class methodsFor: 'keyboard shortcut tables' stamp: 'jmv 12/21/2018 14:43:04' prior: 50383114! - basicCmdShortcutsSpec - " - Editor initialize - " - - "arranged in QWERTY keyboard order" - ^#( - #( $( #enclose: 'Enclose within ( and ), or remove enclosing ( and )') - #( $[ #enclose: 'Enclose within [ and ], or remove enclosing [ and ]') - #( ${ #enclose: 'Enclose within { and }, or remove enclosing { and }') - #( $' #enclose: 'Enclose within single quotes, or remove enclosing single quotes') - #( $" #enclose: 'Enclose within double quotes, or remove enclosing double quotes') - #( $` #enclose: 'Enclose within backticks, or remove enclosing backticks') - #( $< #enclose: 'Enclose within < and >, or remove enclosing < and >') - - #( $a #selectAll: 'Select all') - #( $f #find: 'Find') - #( $g #findAgain: 'Find again') - #( $h #help: 'Open this help') - #( $j #setSearchString: 'Set selection as search string for find again') - - #( $z #undo: 'Undo (multiple levels)') - #( $x #cut: 'Cut selection and store it in the Clipboard') - #( $c #copySelection: 'Copy selection to the Clipboard') - #( $v #paste: 'Paste Clipboard contents') - - #( $R #indent: 'Indent (same as [Tab], move selection one tab-stap right)') - #( $Y #makeUppercase: 'Force selection to uppercase') - #( $U #changeLineEndsToLf: 'Convert line endings to LF characters (Cuis convention) in selection') - - #( $H #cursorTopHome: 'Move cursor to start of text') - #( $L #outdent: 'Outdent (same as [Shift][Tab], move selection one tab-stop left)') - - #( $Z #redo: 'Redo (multiple levels)') - #( $X #makeLowercase: 'Force selection to lowercase') - #( $C #compareToClipboard: 'Compare argument to clipboard') - - #( $ #selectWord: 'Select the current word as with double clicking') - )! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3536-EditorHelpTweaks-JuanVuletich-2018Dec21-14h50m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3538] on 21 December 2018 at 2:53:25 pm'! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 12/21/2018 11:06:01' prior: 50420453! - expNonPrimitive - "Answer e raised to the receiver power." - - | base fract correction delta div | - - "Taylor series" - "check the special cases" - self < 0.0 ifTrue: [^ (self negated exp) reciprocal]. - self = 0.0 ifTrue: [^ 1]. - self abs > MaxValLn ifTrue: [self error: 'exp overflow']. - - "get first approximation by raising e to integer power" - base _ E raisedToInteger: (self truncated). - - "now compute the correction with a short Taylor series" - "fract will be 0..1, so correction will be 1..E" - "in the worst case, convergance time is logarithmic with 1/Epsilon" - fract _ self fractionPart. - fract = 0.0 ifTrue: [ ^ base ]. "no correction required" - - correction _ 1.0 + fract. - delta _ fract * fract / 2.0. - div _ 2.0. - [delta >= base ulp] whileTrue: [ - correction _ correction + delta. - div _ div + 1.0. - delta _ delta * fract / div]. - correction _ correction + delta. - ^ base * correction! ! -!Float methodsFor: 'converting' stamp: 'jmv 12/21/2018 11:12:14' prior: 50421725! - partBits: aThreeArgumentBlock - " - Extract the bits for Sign, Mantissa and Exponent parts of the Floating Point representation. - Just extract the bits. Do not add implicit bit. Do not correct denormals. Do not subtract exponent bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. (f signPart * f significandAsInteger * (2 raisedToInteger: f exponentPart-52)) asFloat = f } print ]. - " - | signBit exponentBits mantissaBits leastSignificativeWord mostSignificativeWord | - - mostSignificativeWord _ self basicAt: 1. - leastSignificativeWord _ self basicAt: 2. - signBit _ mostSignificativeWord bitShift: -31 . - exponentBits _ (mostSignificativeWord bitShift: -20 ) bitAnd: 16r7FF. - mantissaBits _ ((mostSignificativeWord bitAnd: 16r000FFFFF) bitShift: 32) + leastSignificativeWord. - - "Evaluate the block" - ^aThreeArgumentBlock value: signBit value: exponentBits value: mantissaBits! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/21/2018 11:12:06' prior: 50421861! - exponentBits - " - Actual bits for the exponent part of the Floating Point representation. - Just extract the bits. Do not correct denormals. Do not subtract bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - { f. f exponentBits. f exponentPart. f exponent } print ]. - " - - ^ self partBits: [ :signBit :exponentBits :mantissaBits | exponentBits ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/21/2018 11:12:10' prior: 50421878! - mantissaBits - " - Actual bits for the mantissa part of the Floating Point representation. - Just extract the bits. Do not correct denormals. Do not subtract bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - { f. f mantissaBits. f mantissaPart. f significand. } print ]. - " - ^ self partBits: [ :signBit :exponentBits :mantissaBits | mantissaBits ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/21/2018 11:12:18' prior: 50421934! - signBit - " - Actual bits for the exponent part of the Floating Point representation. - Just extract the bits. Do not correct denormals. Do not subtract bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0. 0.0. -0.0} do: [ :f | - { f. f signBit. f signPart. f sign } print ]. - " - - ^ self partBits: [ :signBit :exponentBits :mantissaBits | signBit ]! ! -!Float class methodsFor: 'constants' stamp: 'jmv 12/21/2018 11:02:26' prior: 16845865! - e - "Answer the constant, e." - - ^E! ! -!Float class methodsFor: 'constants' stamp: 'jmv 12/21/2018 12:54:06' prior: 16845869! - emax - "Answer exponent of the maximal representable value" - - ^1023! ! -!Float class methodsFor: 'constants' stamp: 'jmv 12/21/2018 12:54:26' prior: 50421982! - epsilon - "Answer the difference between 1.0 and the next representable value. - Note: does not equal 1.0 ulp." - - ^1.0 successor - 1.0! ! -!BoxedFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 12/21/2018 11:04:53' prior: 50420638! - exp - "Answer e raised to the receiver power. - Optional. See Object documentation whatIsAPrimitive." - - - ^ self expNonPrimitive! ! -!SmallFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 12/21/2018 11:05:17' prior: 50420675! - exp - "Answer e raised to the receiver power. - Optional. See Object documentation whatIsAPrimitive." - - - ^ self expNonPrimitive! ! -!Fraction methodsFor: 'printing' stamp: 'jmv 12/21/2018 11:15:47' prior: 50423093! - printOn: aStream fractionDigits: placesDesired - "Same as super, but provides a faster implementation by inlining some Fraction protocol thus avoiding intermediate Fraction creation." - - | roundedFractionPart integerPart scaling | - placesDesired > 0 - ifFalse: [self rounded printOn: aStream] - ifTrue: [ - scaling := 10 raisedToInteger: placesDesired. - integerPart := numerator abs quo: denominator. - roundedFractionPart := (numerator abs - (integerPart * denominator)) * scaling * 2 + denominator quo: denominator * 2. - roundedFractionPart = scaling - ifTrue: - [integerPart := integerPart + 1. - roundedFractionPart := 0]. - "Don't print minus sign if result is rounded to zero" - (numerator negative and: [integerPart > 0 or: [roundedFractionPart > 0]]) ifTrue: [aStream nextPut: $-]. - integerPart printOn: aStream. - aStream nextPut: $.. - roundedFractionPart printOn: aStream base: 10 length: placesDesired padded: true].! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3537-FixTyposInNumerics-JuanVuletich-2018Dec21-14h52m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3535] on 21 December 2018 at 9:18:35 am'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 12/21/2018 09:18:25' prior: 50418191! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('AY' 'Angel Yan') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('FJG' 'Facundo Javier Gelatti') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3538-AddAngelAsKnownAuthor-JuanVuletich-2018Dec21-09h18m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3538] on 21 December 2018 at 3:11:09 pm'! -!TextEditor methodsFor: 'editing keys' stamp: 'AY 12/17/2018 17:05:42'! - tabKey: aKeyboardEvent - "Add/remove a tab at the front of every line occupied by the selection if there is one; treat as a normal character otherwise." - - aKeyboardEvent shiftPressed - ifTrue: [ ^ self outdent: aKeyboardEvent ]. - - ^ self hasSelection - ifTrue: [ self indent: aKeyboardEvent ] - ifFalse: [ self normalCharacter: aKeyboardEvent ]! ! -!TextEditor class methodsFor: 'class initialization' stamp: 'AY 12/21/2018 13:10:43'! - initializeShortcuts - - super initializeShortcuts. - shortcuts at: 9 + 1 put: #tabKey:.! ! -!TextEditor class methodsFor: 'keyboard shortcut tables' stamp: 'jmv 12/21/2018 08:09:38' prior: 50423163! - basicCmdShortcutsSpec - " - Editor initialize - " - - "arranged in QWERTY keyboard order" - ^#( - #( $( #enclose: 'Enclose within ( and ), or remove enclosing ( and )') - #( $[ #enclose: 'Enclose within [ and ], or remove enclosing [ and ]') - #( ${ #enclose: 'Enclose within { and }, or remove enclosing { and }') - #( $' #enclose: 'Enclose within single quotes, or remove enclosing single quotes') - #( $" #enclose: 'Enclose within double quotes, or remove enclosing double quotes') - #( $` #enclose: 'Enclose within backticks, or remove enclosing backticks') - #( $< #enclose: 'Enclose within < and >, or remove enclosing < and >') - - #( $a #selectAll: 'Select all') - #( $f #find: 'Find') - #( $g #findAgain: 'Find again') - #( $h #help: 'Open this help') - #( $j #setSearchString: 'Set selection as search string for find again') - - #( $z #undo: 'Undo (multiple levels)') - #( $x #cut: 'Cut selection and store it in the Clipboard') - #( $c #copySelection: 'Copy selection to the Clipboard') - #( $v #paste: 'Paste Clipboard contents') - - #( $R #indent: 'Indent (move selection one tab-stap right)') - #( $Y #makeUppercase: 'Force selection to uppercase') - #( $U #changeLineEndsToLf: 'Convert line endings to LF characters (Cuis convention) in selection') - - #( $H #cursorTopHome: 'Move cursor to start of text') - #( $L #outdent: 'Outdent (move selection one tab-stop left)') - - #( $Z #redo: 'Redo (multiple levels)') - #( $X #makeLowercase: 'Force selection to lowercase') - #( $C #compareToClipboard: 'Compare argument to clipboard') - - #( $ #selectWord: 'Select the current word as with double clicking') - )! ! -!Morph methodsFor: 'events-processing' stamp: 'jmv 12/21/2018 09:21:39' prior: 16874864! - focusKeyboardFor: aKeyboardEvent - - "If aKeyboardEvent ctrl-tab or shift-ctrl-tab use it to navigate keyboard focus. - Warning: This doesn't work on Windows... the event is not sent" - (aKeyboardEvent keyValue = 9 and: [ aKeyboardEvent controlKeyPressed and: [ aKeyboardEvent rawMacOptionKeyPressed not ]]) - ifTrue: [ - aKeyboardEvent shiftPressed - ifTrue: [ aKeyboardEvent hand keyboardFocusPrevious ] - ifFalse: [ aKeyboardEvent hand keyboardFocusNext ]. - ^ true ]. - "On Windows use at least some keystroke to navigate morphs... even shift-Tab that should navigate backwards" -" - (aKeyboardEvent keyValue = 9 and: [ aKeyboardEvent shiftPressed and: [ aKeyboardEvent rawMacOptionKeyPressed not ]]) - ifTrue: [ - aKeyboardEvent hand keyboardFocusNext. - ^ true ]. -" - - "Cycle through windows with cmdAlt + < and cmdAlt + >. - VM and platform peculiarities are hidden in #isCmdAltLessThan and #isCmdAltGreaterThan" - "This was done as an attempt to mimic the Mac OSX keystrokes for 'Move focus to next window in active application'. Unfortunately, it only works if OS X is set to use any other keys for this. If (as for example, with German defaults), OS-X uses these keystrokes, then they are not sent to the VM. This is a long standing issues in Chromium and PhotoShop, for example..." - self disableCode: [ - aKeyboardEvent isCmdAltLessThan ifTrue: [ - aKeyboardEvent hand activatePreviousWindow. - ^true ]. - aKeyboardEvent isCmdAltGreaterThan ifTrue: [ - aKeyboardEvent hand activateNextWindow. - ^true ]]. - "Alternative for Mac OS-X: option-Tab and option-shift-Tab" - (aKeyboardEvent keyValue = 9 and: [ aKeyboardEvent rawMacOptionKeyPressed ]) - ifTrue: [ - aKeyboardEvent shiftPressed - ifTrue: [ aKeyboardEvent hand activatePreviousWindow ] - ifFalse: [ aKeyboardEvent hand activateNextWindow ]. - ^ true ]. - "Alternative for non-Mac OS-X: alt-< and alt->" - (aKeyboardEvent commandAltKeyPressed and: [ aKeyboardEvent keyCharacter = $< ]) ifTrue: [ - aKeyboardEvent hand activatePreviousWindow. - ^true ]. - (aKeyboardEvent commandAltKeyPressed and: [ aKeyboardEvent keyCharacter = $> ]) ifTrue: [ - aKeyboardEvent hand activateNextWindow. - ^true ]. - ^false! ! -!HandMorph methodsFor: 'private events' stamp: 'jmv 12/21/2018 09:28:14' prior: 50374894! - generateKeyboardEvent: evtBuf - "Generate the appropriate mouse event for the given raw event buffer" - | buttons modifiers type keyValue pressType stamp | - stamp _ evtBuf second. - stamp = 0 ifTrue: [ stamp _ Time localMillisecondClock ]. - (evtBuf sixth <= 0 or: [ (keyValue _ Character iso8859s15CodeForUnicodeCodePoint: evtBuf sixth) isNil ]) ifTrue: [ keyValue _ Character macRomanToLatin1: evtBuf third ]. - Sensor peekEvent ifNotNil: [ :nxt | - "start: Combining diacritical marks (i.e. accents in the Linux VM)" - (nxt fourth = EventSensor eventKeyDown and: [ nxt third > 255 ]) ifTrue: [ - keyValue _ ((Character numericValue: keyValue) withDiacriticalMark: nxt third) iso8859s15Code. - Sensor - nextEvent; - nextEvent; - nextEvent ]. - "end: Combining diacritical marks (i.e. accents in the Linux VM)" - "start: Spurious LF after CR on Ctrl-Enter on Windows VM" - ((evtBuf fourth = EventSensor eventKeyChar and: [ evtBuf third = 13 ]) and: [ - nxt fourth = EventSensor eventKeyChar and: [ nxt third = 10 ]]) ifTrue: [ Sensor nextEvent - "print " ]]. - modifiers _ evtBuf fifth. - pressType _ evtBuf fourth. - pressType = EventSensor eventKeyDown ifTrue: [ - type _ #keyDown. - lastKeyDownValue _ keyValue ]. - pressType = EventSensor eventKeyUp ifTrue: [ - (keyValue = 9 and: [(modifiers anyMask: 1) and: [Smalltalk platformName = 'unix']]) - ifTrue: [ - "Linux VMs don't generate shift-tab keystroke. Turn #keyUp into #keystroke" - pressType _ EventSensor eventKeyChar ] - ifFalse: [type _ #keyUp ]]. - pressType = EventSensor eventKeyChar ifTrue: [ - type _ #keystroke. - "If Control key pressed, and the VM answers a code below 27, - it means it did the translation, convert it back to regular character: - We want to handle the meaning of ctrl ourselves." - (modifiers anyMask: 2) ifTrue: [ - "Control key pressed" - keyValue < 27 ifTrue: [ - "But we don't want to do it for Home/End/PgUp/PgDn, just for alphabetic keys" - lastKeyDownValue = keyValue ifFalse: [ - "If equal, real Home/End/PgUp/PgDn in Windows => don't translate" - (keyValue + 64 = lastKeyDownValue or: [ "If Equal, Ctrl-alphabetic in Windows => do translate" - lastKeyDownValue < 47 ]) ifTrue: [ - "Not on windows. If less (not sure about the bound, but do not translate 48: tab on Mac), alphabetic on Mac => do translate" - keyValue _ (modifiers anyMask: 1) - ifTrue: [ keyValue + 64 ] - ifFalse: [ keyValue + 96 - "shift not pressed: conver to lowercase letter" ]]]]. - "Act as if command/alt was pressed for some usual Windows ctrl-key combinations" - (self shouldControlEmulateAltFor: keyValue) ifTrue: [ modifiers _ modifiers bitOr: 8 ]]]. - buttons _ modifiers bitShift: 3. - ((modifiers anyMask: 2) and: [ - keyValue - between: (Preferences ctrlArrowsScrollHorizontally ifTrue: [28] ifFalse: [30]) - and: 31]) - ifTrue: [ "We're hijacking ctl-up/down arrow since that is what the VM sends us for scroll events. We're going to convert these to MouseScrollEvent and throw away the keyboard event" - "ThisPrecludes the use of up and down arrows with control, that are standard keystrokes in Windows to control the cursor. - But as Linux, Mac and Windows VMs generate ctrl-up and ctrl-down for mouse wheel events, we must honor them. - Some day, it would be good for the VMs to report mouse wheel events differently fom ctrl-up & ctrl-down..." - "Also do ctrl-left and ctrl-right for horizontal scroll." - ^ MouseScrollEvent new - setType: #mouseScroll - position: self morphPosition - direction: - (keyValue caseOf: { - "Implementing as a caseof to allow for easy adding of left/right/other events should they become available" - [ 30 ] -> [ #up ]. - [ 31 ] -> [ #down ]. - [ 28 ] -> [ #left ]. - [ 29 ] -> [ #right ]. - }) - buttons: buttons - hand: self - stamp: stamp ] - ifFalse: [ ^ KeyboardEvent new - setType: type - buttons: buttons - position: self morphPosition - keyValue: keyValue - hand: self - stamp: stamp ].! ! -!AutoCompleter methodsFor: 'keyboard - private' stamp: 'AY 12/17/2018 16:57:52' prior: 50414914! - shouldOpenMorph - - | currentPos currentChar | - - textMorph editor hasSelection ifTrue: [ ^ false ]. - - currentPos _ textMorph editor startIndex-1. - currentPos <= 0 ifTrue: [ ^ false ]. - currentChar _ model actualContents at: currentPos. - - ^ currentChar = Character space - ifTrue: [ self shouldOpenMorphWhenNoPrefixAt: currentPos-1 ] - ifFalse: [ self shouldOpenMorphWhenPrefixAt: currentPos and: currentChar ].! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Editor initialize! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3539-TabShiftTabToIndentOutdent-AngelYan-2018Dec21-15h06m-AY.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3526] on 19 December 2018 at 7:42:39 pm'! -!SystemDictionary methodsFor: 'testing' stamp: 'HAW 12/19/2018 16:09:00'! - isLiveTypeInformationInstalled - - ^(FeatureRequirement name: #LiveTypeInformation) isAlreadySatisfied! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 12/19/2018 19:41:54'! -returnTypeOfEnclosedExpressionAt: aRange - - Smalltalk isLiveTypeInformationInstalled ifFalse: [ ^nil ]. - - ^self - withParserSourceMethodNodeDo: [ :methodNode | self returnTypeOfEnclosedExpresionIn: methodNode at: aRange end ] - ifError: [ :anError | nil ]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 12/19/2018 16:43:55'! - returnTypeOfUnaryMessage: aSelector at: aRange - - Smalltalk isLiveTypeInformationInstalled ifFalse: [ ^nil ]. - - ^self - withParserSourceMethodNodeDo: [ :methodNode | self returnTypeOfNodeUnderCursorIn: methodNode at: aRange end] - ifError: [ :anError | nil ]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 12/19/2018 16:18:52'! -withParserSourceMethodNodeDo: doBlock ifError: anErrorBlock - - ^ [[ doBlock value: (parser classOrMetaClass methodNodeFor: parser source) ] - on: UndeclaredVariableReference - do: [ :anUndeclareVariableReference | anUndeclareVariableReference declareTempAndResume ]] - on: Error - do: anErrorBlock - - ! ! -!UndeclaredVariableReference methodsFor: 'handling' stamp: 'HAW 12/19/2018 19:34:38'! - declareTempAndResume - - parser declareTemp: varName at: #method. - self resume: varName! ! -!UndeclaredVariableReference methodsFor: 'handling' stamp: 'HAW 12/19/2018 19:34:42' prior: 16939960! - defaultAction - - ^parser correctVariable: varName interval: (varStart to: varEnd)! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 12/18/2018 19:03:40' prior: 50419497! - parseNodeIncluding: aPosition ifAbsent: aBlockClosure - - | smallestRangeSize nodeWithRangeAtPosition | - - smallestRangeSize := SmallInteger maxVal. - nodeWithRangeAtPosition := nil. - - sourceRanges associationsDo: [ :nodeAtRange | - self withRangesOf: nodeAtRange including: aPosition do: [ :aRange | | currentNodeRangeSize | - currentNodeRangeSize := aRange size. - currentNodeRangeSize < smallestRangeSize ifTrue: [ - smallestRangeSize := currentNodeRangeSize. - nodeWithRangeAtPosition := nodeAtRange key -> aRange ]]]. - - ^ nodeWithRangeAtPosition ifNil: aBlockClosure ifNotNil: [ nodeWithRangeAtPosition ] - ! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 12/18/2018 19:04:26' prior: 50419532! - parseNodeIncluding: aPosition ifAbsent: aBlockClosure - - ^encoder parseNodeIncluding: aPosition ifAbsent: aBlockClosure -! ! -!AutoCompleter methodsFor: 'keyboard - private' stamp: 'HAW 12/18/2018 18:41:14' prior: 50417233! -shouldOpenMorphWhenNoPrefixFor: currentChar - - ^currentChar isAlphaNumeric - or: [ currentChar isRightBracket - or: [ currentChar = $) ]]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 12/19/2018 19:41:54' prior: 50417273! - computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel - - | id receiverClassOrEntries | - - id _ allSource copyFrom: range start to: range end. - receiverClassOrEntries _ range rangeType - caseOf: { - [ #globalVar ] -> [ (Smalltalk at: id asSymbol) class ]. - [ #self ] -> [ contextClass ]. - [ #super ] -> [ contextClass superclass ]. - [ #true ] -> [ True ]. - [ #false ] -> [ False ]. - [ #nil ] -> [ UndefinedObject ]. - [ #character ] -> [ id first class ]. - [ #number ] -> [ self classOfLiteral: id in: contextClass ]. - [ #string ] -> [ self classOfLiteral: id in: contextClass ]. - [ #symbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #stringSymbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #instVar ] -> [ specificModel classOfInstVarNamed: id ]. - [ #methodArg ] -> [ specificModel classOfTempVarNamed: id ]. - [ #tempVar ] -> [ specificModel classOfTempVarNamed: id ]. - [ #workspaceVar ] -> [ specificModel classOfWorkspaceVarNamed: id ]. - [ #blockArg ] -> [ specificModel classOfBlockArgNamed: id ]. - [ #blockTempVar ] -> [ specificModel classOfBlockTempVarNamed: id ]. - [ #thisContext ] -> [ specificModel classOfThisContext ]. - [ #classVar ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #poolConstant ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #blockEnd ] -> [ BlockClosure ]. - [ #unary ] -> [ self returnTypeOfUnaryMessage: id at: range ]. - [ #rightParenthesis ] -> [ self returnTypeOfEnclosedExpressionAt: range ]. } - otherwise: [ nil ]. - - receiverClassOrEntries isCollection - ifTrue: [ - receiverClassOrEntries isEmpty - ifTrue: [ self computeMessageEntries: nil ] - ifFalse: [ entries _ receiverClassOrEntries asArray sort ]] - ifFalse: [ self computeMessageEntries: receiverClassOrEntries ]! ! -!SHParserST80 methodsFor: 'accessing' stamp: 'HAW 12/19/2018 16:10:09'! - classOrMetaClass - - ^classOrMetaClass! ! - -MethodNode removeSelector: #topParseNodeIncluding:ifAbsent:! - -Encoder removeSelector: #topParseNodeIncluding:ifAbsent:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3540-AutoCompleteImprovements-HernanWilkinson-2018Dec18-18h31m-HAW.4.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3526] on 20 December 2018 at 9:43:37 am'! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 12/20/2018 09:41:03'! - computeMessageEntriesForSelectors: selectors - - selectors isEmpty - ifTrue: [ self computeMessageEntries: nil ] - ifFalse: [ | prefixedSelectors | - prefixedSelectors := selectors select: [ :aSelector | aSelector beginsWith: prefix ]. - entries _ prefixedSelectors asArray sort ]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 12/20/2018 09:38:26' prior: 50424025! - computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel - - | id receiverClassOrEntries | - - id _ allSource copyFrom: range start to: range end. - receiverClassOrEntries _ range rangeType - caseOf: { - [ #globalVar ] -> [ (Smalltalk at: id asSymbol) class ]. - [ #self ] -> [ contextClass ]. - [ #super ] -> [ contextClass superclass ]. - [ #true ] -> [ True ]. - [ #false ] -> [ False ]. - [ #nil ] -> [ UndefinedObject ]. - [ #character ] -> [ id first class ]. - [ #number ] -> [ self classOfLiteral: id in: contextClass ]. - [ #string ] -> [ self classOfLiteral: id in: contextClass ]. - [ #symbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #stringSymbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #instVar ] -> [ specificModel classOfInstVarNamed: id ]. - [ #methodArg ] -> [ specificModel classOfTempVarNamed: id ]. - [ #tempVar ] -> [ specificModel classOfTempVarNamed: id ]. - [ #workspaceVar ] -> [ specificModel classOfWorkspaceVarNamed: id ]. - [ #blockArg ] -> [ specificModel classOfBlockArgNamed: id ]. - [ #blockTempVar ] -> [ specificModel classOfBlockTempVarNamed: id ]. - [ #thisContext ] -> [ specificModel classOfThisContext ]. - [ #classVar ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #poolConstant ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #blockEnd ] -> [ BlockClosure ]. - [ #unary ] -> [ self returnTypeOfUnaryMessage: id at: range ]. - [ #rightParenthesis ] -> [ self returnTypeOfEnclosedExpressionAt: range ]. } - otherwise: [ nil ]. - - receiverClassOrEntries isCollection - ifTrue: [ self computeMessageEntriesForSelectors: receiverClassOrEntries ] - ifFalse: [ self computeMessageEntries: receiverClassOrEntries ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3541-AutoCompleterSmallEnh-HernanWilkinson-2018Dec19-19h45m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3526] on 20 December 2018 at 3:12:35 pm'! - -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser ' - classVariableNames: 'AccessLock Selectors EntriesLimit ' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #SmalltalkCompleter category: #'Tools-Autocompletion'! -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! -!Object methodsFor: 'private' stamp: 'HAW 12/20/2018 14:18:53'! - errorDescriptionForSubcriptBounds: index - - ^'subscript is out of bounds: ' , index printString! ! -!SequenceableCollection methodsFor: 'assertions' stamp: 'HAW 12/20/2018 14:40:40'! - assertIsInBounds: anIndex - - (self isInBounds: anIndex) ifFalse: [ self errorSubscriptBounds: anIndex ] - ! ! -!ArrayedCollection methodsFor: 'inserting' stamp: 'HAW 12/20/2018 14:54:55'! - insert: anObject shiftingRightAt: anInsertionIndex - - "Inserts anObject at anInsertionIndex, moving right object between anInsertionIndex and self size, - loosing last object. Example: - #(0 1 3 4 5) insert: 2 shiftingRightAt: 3 - returns: #(0 1 2 3 4) - " - | currentIndex | - - self assertIsInBounds: anInsertionIndex. - currentIndex _ self size . - - [currentIndex > anInsertionIndex] whileTrue: [ - self at: currentIndex put: (self at: currentIndex-1). - currentIndex _ currentIndex - 1]. - - self at: anInsertionIndex put: anObject -! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 12/20/2018 14:43:28'! - add: selector and: lastUsedTime to: selectorsToShow - - ^ selectorsToShow size < EntriesLimit - ifTrue: [ self add: selector and: lastUsedTime whenNotFullTo: selectorsToShow ] - ifFalse: [ self add: selector and: lastUsedTime whenFullTo: selectorsToShow ] ! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 12/20/2018 14:44:54'! - add: selector and: lastUsedTime whenFullTo: selectorsToShow - - selectorsToShow - findBinaryIndex: [ :selectorAndTime | selectorAndTime second < lastUsedTime ifTrue: [ -1 ] ifFalse: [ 1 ]] - do: [ :found | ] - ifNone: [ :leftBound :rightBound | self insert: selector and: lastUsedTime at: rightBound to: selectorsToShow ]. - - ^selectorsToShow -! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 12/20/2018 14:49:34'! - add: selector and: lastUsedTime whenNotFullTo: selectorsToShow - - selectorsToShow add: { selector . lastUsedTime }. - - ^selectorsToShow size = EntriesLimit - ifTrue: [ self sortByLastUsedTime: selectorsToShow ] - ifFalse: [ selectorsToShow ] - ! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 12/20/2018 14:45:44'! - insert: selector and: lastUsedTime at: insertionIndex to: selectorsToShow - - insertionIndex <= EntriesLimit ifTrue: [ selectorsToShow insert: { selector . lastUsedTime } shiftingRightAt: insertionIndex ]. - - ^selectorsToShow ! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 12/20/2018 14:44:13'! - sortByLastUsedTime: selectorsToShow - - ^selectorsToShow asArray sort: [ :leftSelectorAndTime :rightSelectorAndTime | leftSelectorAndTime second > rightSelectorAndTime second ]! ! -!Object methodsFor: 'private' stamp: 'HAW 12/20/2018 14:17:22' prior: 16882709! - errorSubscriptBounds: index - "Create an error notification that an improper integer was used as an index." - - self error: (self errorDescriptionForSubcriptBounds: index)! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 12/20/2018 14:19:58'! - should: aBlockToFail raise: anExceptionHandlingCondition withMessageText: anExpectedErrorMessageCreator - - self - should: aBlockToFail - raise: anExceptionHandlingCondition - withExceptionDo: [ :anException | self assert: anExpectedErrorMessageCreator value equals: anException messageText ]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 12/20/2018 14:47:00' prior: 16909310! - computeMessageEntries: receiverClass - - | selectorsToShow notUnderstoodSelectors | - - selectorsToShow _ OrderedCollection new. - notUnderstoodSelectors _ OrderedCollection new. - - self class protected: [ - Selectors forPrefix: prefix keysAndValuesDo: [ :selector :lastUsedTime | - (receiverClass isNil or: [ receiverClass canUnderstand: selector ]) - ifTrue: [ selectorsToShow := self add: selector and: lastUsedTime to: selectorsToShow ] - ifFalse: [ notUnderstoodSelectors := self add: selector and: lastUsedTime to: notUnderstoodSelectors ]]]. - - selectorsToShow isEmpty ifTrue: [ selectorsToShow _ notUnderstoodSelectors ]. - selectorsToShow size < EntriesLimit ifTrue: [ selectorsToShow _ self sortByLastUsedTime: selectorsToShow ]. - - " To see the timestamps in the menu (need to tweak #insertCompletion: to activate. Right now, just for debugging) - entries _ selectorsToShow collect: [ :ary | ary first, '(', ((DateAndTime fromString: '01/01/1996 00:00') + ary second minutes) printString,')' ] - " - entries _ selectorsToShow collect: [ :selectorAndTime | selectorAndTime first ] - -! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 12/20/2018 11:32:31' prior: 50424116! - computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel - - | id receiverClassOrEntries | - - id _ allSource copyFrom: range start to: range end. - receiverClassOrEntries _ range rangeType - caseOf: { - [ #globalVar ] -> [ (Smalltalk at: id asSymbol) class ]. - [ #self ] -> [ contextClass ]. - [ #super ] -> [ contextClass superclass ]. - [ #true ] -> [ True ]. - [ #false ] -> [ False ]. - [ #nil ] -> [ UndefinedObject ]. - [ #character ] -> [ id first class ]. - [ #number ] -> [ self classOfLiteral: id in: contextClass ]. - [ #string ] -> [ self classOfLiteral: id in: contextClass ]. - [ #symbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #stringSymbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #instVar ] -> [ specificModel classOfInstVarNamed: id ]. - [ #methodArg ] -> [ specificModel classOfTempVarNamed: id ]. - [ #tempVar ] -> [ specificModel classOfTempVarNamed: id ]. - [ #workspaceVar ] -> [ specificModel classOfWorkspaceVarNamed: id ]. - [ #blockArg ] -> [ specificModel classOfBlockArgNamed: id ]. - [ #blockTempVar ] -> [ specificModel classOfBlockTempVarNamed: id ]. - [ #thisContext ] -> [ specificModel classOfThisContext ]. - [ #classVar ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #poolConstant ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #blockEnd ] -> [ BlockClosure ]. - [ #arrayEnd ] -> [ Array ]. - [ #rightBrace ] -> [ Array ]. - [ #unary ] -> [ self returnTypeOfUnaryMessage: id at: range ]. - [ #rightParenthesis ] -> [ self returnTypeOfEnclosedExpressionAt: range ]. } - otherwise: [ nil ]. - - receiverClassOrEntries isCollection - ifTrue: [ self computeMessageEntriesForSelectors: receiverClassOrEntries ] - ifFalse: [ self computeMessageEntries: receiverClassOrEntries ]! ! -!SmalltalkCompleter class methodsFor: 'class initialization' stamp: 'HAW 12/20/2018 11:51:22' prior: 50420127! - initialize - " - It takes about 6 seconds, mostly because of the time to fetch method stamps from source files... - [ SmalltalkCompleter initialize ]timeToRun - Selectors inspect - " - | maxSortValue allImplemented | - - EntriesLimit _ 400. - - SystemChangeNotifier uniqueInstance - removeActionsWithReceiver: self. "avoid double registration" - - SystemChangeNotifier uniqueInstance - when: #classRemoved send: #classRemoved:fromCategory: to: self; - when: #methodAdded send: #methodAdded:selector:inClass:requestor: to: self; - when: #methodAddedInProtocol send: #methodAdded:selector:inProtocol:class:requestor: to: self; - when: #methodRemoved send: #methodRemoved:selector:inProtocol:class: to: self. - - self protected: [ - allImplemented _ Smalltalk allImplementedMessages. - Selectors _ Trie new. - " - Smalltalk allBehaviorsDo: [:class | - class selectorsAndMethodsDo: [ :sel :method | - Selectors at: sel ifAbsentPut: [ 0 ]. - method messages do: [ :sentMsg | - Selectors at: sentMsg put: (Selectors at: sentMsg ifAbsent: [ 0 ]) + 1 ]]]. - " - Smalltalk allBehaviorsDo: [:class | - class selectorsAndMethodsDo: [ :sel :method | - self addSelector: sel method: method allImplemented: allImplemented]]. - "" - - "The following might not be found in #messages. Give them maximum priority." - maxSortValue _ SmallInteger maxVal. - "From MessageNode>>#initialize" - #( ifTrue: ifFalse: ifTrue:ifFalse: ifFalse:ifTrue: - and: or: - whileFalse: whileTrue: whileFalse whileTrue - to:do: to:by:do: - caseOf: caseOf:otherwise: - ifNil: ifNotNil: ifNil:ifNotNil: ifNotNil:ifNil:) do: [ :sel | - Selectors at: sel put: maxSortValue ]. - - maxSortValue _ SmallInteger maxVal-1. - "From SystemDictionary >>#recreateSpecialObjectsArray" - (1 to: Smalltalk specialSelectorSize) do: [ :i | - Selectors at: (Smalltalk specialSelectorAt: i) put: maxSortValue ]]! ! - -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #SmalltalkCompleter category: #'Tools-Autocompletion'! -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -SmalltalkCompleter initialize! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3542-AutoCompleterEnhancements-HernanWilkinson-2018Dec20-09h43m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3542] on 21 December 2018 at 5:34:41 pm'! -!SmalltalkCompleter class methodsFor: 'class initialization' stamp: 'jmv 12/21/2018 17:33:20' prior: 50422677! - addSelector: aSymbol method: aCompiledMethod allImplemented: implemented - - | sentValue value | - self protected: [ - value _ (ChangeSet notInstallOrTestRun or: [Smalltalk platformName ~= 'Win32']) - ifTrue: [ - "Expensive and not worth doing in Windows with antivirus active, when installing large packages" - aCompiledMethod dateSortingValue ] - ifFalse: [ 0 ]. - Selectors at: aSymbol put: (value max: (Selectors at: aSymbol ifAbsent: [0])). - aCompiledMethod messages do: [ :sentMsg | - ((Selectors includesKey: sentMsg) or: [ - implemented - ifNotNil: [ implemented includes: sentMsg ] - ifNil: [ Smalltalk isThereAnImplementorOf: sentMsg ]]) - ifTrue: [ - sentValue _ value max: (Selectors at: sentMsg ifAbsent: [0]). - Selectors at: sentMsg put: sentValue ]]]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3543-IgnorePackageMethodDateForAutocompleteOnlyOnWindows-JuanVuletich-2018Dec21-17h30m-jmv.1.cs.st----! - -----SNAPSHOT----#(21 December 2018 5:46:03.733937 pm) Cuis5.0-3543-v3.image priorSource: 2863823! - -----QUIT----#(21 December 2018 5:46:13.041218 pm) Cuis5.0-3543-v3.image priorSource: 2971944! - -----STARTUP----#(1 January 2019 8:25:31.451567 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3543-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3543] on 23 December 2018 at 11:25:59 am'! -!Behavior methodsFor: 'methods' stamp: 'KLG 12/23/2018 11:18:27' prior: 50419485! - methodNodeFor: aSourceCode noPattern: aBoolean - - | parser methodNode | - - parser := self parserClass new. - - methodNode := parser parse: aSourceCode class: self noPattern: aBoolean. - methodNode sourceText: aSourceCode. - - ^methodNode - ! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3544-DontHardCodeEncoderClass-KLG-2018Dec23-11h18m-KLG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3544] on 24 December 2018 at 12:15:36 pm'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 12/24/2018 12:15:14' prior: 50423417! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('AY' 'Angel Yan') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('FJG' 'Facundo Javier Gelatti') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('KLG' 'Gerald Klix') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3545-AddGeraldKlixAsKnownAuthor-JuanVuletich-2018Dec24-12h14m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3531] on 24 December 2018 at 10:41:52 am'! - -Object subclass: #DropFilesAction - instanceVariableNames: 'shouldAskForCancel dropFilesEvent cancelBlock' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Worlds'! - -!classDefinition: #DropFilesAction category: #'Morphic-Worlds'! -Object subclass: #DropFilesAction - instanceVariableNames: 'shouldAskForCancel dropFilesEvent cancelBlock' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Worlds'! - -MorphicEvent subclass: #DropFilesEvent - instanceVariableNames: 'position wasHandled numberOfFiles' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Events'! - -!classDefinition: #DropFilesEvent category: #'Morphic-Events'! -MorphicEvent subclass: #DropFilesEvent - instanceVariableNames: 'position wasHandled numberOfFiles' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Events'! -!Morph methodsFor: 'dropping/grabbing' stamp: 'HAW 12/24/2018 07:21:44'! - dropFiles: aDropFilesEvent - - "I do nothing, subclasses should redefine if they handle this event - Hernan"! ! -!Morph methodsFor: 'event handling testing' stamp: 'HAW 12/24/2018 07:13:50'! - allowsFilesDrop - "Answer whether we accept dropping files. By default answer false." - - "Use a property test to allow individual instances to specify this." - ^ self hasProperty: #'allowsFilesDrop'! ! -!Morph methodsFor: 'events-processing' stamp: 'HAW 12/24/2018 09:28:32'! - processDropFiles: aDropFilesEvent localPosition: localEventPosition - "Handle a dropping file." - - aDropFilesEvent wasHandled ifTrue: [ ^self ]. - - aDropFilesEvent wasHandled: true. - self dropFiles: aDropFilesEvent! ! -!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'HAW 12/24/2018 07:13:56'! - allowsFilesDrop - - ^ true! ! -!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'HAW 12/24/2018 10:27:39'! - dropFiles: aDropFilesEvent - - (DropFilesAction for: aDropFilesEvent) value! ! -!HandMorph methodsFor: 'events-processing' stamp: 'HAW 12/24/2018 09:25:29'! - startDropFilesEventDispatch: aDropFilesEvent - - owner dispatchEvent: aDropFilesEvent localPosition: aDropFilesEvent eventPosition. - self mouseOverHandler processMouseOver: lastMouseEvent! ! -!HandMorph methodsFor: 'private events' stamp: 'HAW 12/24/2018 09:29:07'! - generateDropFilesEvent: evtBuf - "Generate the appropriate mouse event for the given raw event buffer" - - | position stamp numberOfFiles dragType | - - stamp := evtBuf second. - stamp = 0 ifTrue: [stamp := Time localMillisecondClock]. - dragType := evtBuf third. - position := evtBuf fourth @ evtBuf fifth. - numberOfFiles := evtBuf seventh. - - ^ dragType = 4 ifTrue: [ DropFilesEvent at: position with: numberOfFiles from: self]. -! ! -!DropFilesAction methodsFor: 'initialization' stamp: 'HAW 12/24/2018 10:29:45'! - initializeFor: aDropFilesEvent - - dropFilesEvent := aDropFilesEvent. - shouldAskForCancel := aDropFilesEvent numberOfFiles > 1! ! -!DropFilesAction methodsFor: 'evaluating' stamp: 'HAW 12/24/2018 10:34:38'! - value - - cancelBlock := [ ^self ]. - dropFilesEvent fileNamesDo: [ :fileName | self fileNamedDropped: fileName ] - -! ! -!DropFilesAction methodsFor: 'evaluating - private' stamp: 'HAW 12/24/2018 10:33:29'! - ask: aQueation onYes: aYesBlock - - | yesSelected | - - yesSelected := shouldAskForCancel - ifTrue: [ self confirm: aQueation orCancel: cancelBlock ] - ifFalse: [ self confirm: aQueation ]. - - ^yesSelected ifTrue: aYesBlock ! ! -!DropFilesAction methodsFor: 'evaluating - private' stamp: 'HAW 12/24/2018 10:33:54'! - canBeFiledIn: aFileName - - ^aFileName endsWith: '.st'! ! -!DropFilesAction methodsFor: 'evaluating - private' stamp: 'HAW 12/24/2018 10:33:43'! - canBeInstalled: aFileName - - ^(aFileName endsWith: '.cs.st') or: [ aFileName endsWith: '.pck.st' ]! ! -!DropFilesAction methodsFor: 'evaluating - private' stamp: 'HAW 12/24/2018 10:36:41'! - fileNamedDropped: aFileName - - (self canBeInstalled: aFileName) - ifTrue: [ self ifUserWantsInstall: aFileName ] - ifFalse: [ (self canBeFiledIn: aFileName) - ifTrue: [ self ifUserWantsFileIn: aFileName ] - ifFalse: [ self inform: 'Dropped file ', aFileName, ' not supported' ]]! ! -!DropFilesAction methodsFor: 'evaluating - private' stamp: 'HAW 12/24/2018 10:32:40'! - ifUserWantsFileIn: aFileName - - self ask: 'Do you want to file in ', aFileName, ' ?' onYes: [ ChangeSet fileIn: aFileName asFileEntry ] ! ! -!DropFilesAction methodsFor: 'evaluating - private' stamp: 'HAW 12/24/2018 10:32:12'! - ifUserWantsInstall: aFileName - - self ask: 'Do you want to install ', aFileName, ' ?' onYes: [ ChangeSet install: aFileName asFileEntry ] - ! ! -!DropFilesAction class methodsFor: 'instance creation' stamp: 'HAW 12/24/2018 10:29:14'! - for: aDropFilesEvent - - ^self new initializeFor: aDropFilesEvent - ! ! -!DropFilesEvent methodsFor: 'initialization' stamp: 'HAW 12/24/2018 09:32:07'! - initializeAt: aPosition with: aNumberOfFiles from: aHand - - position := aPosition. - numberOfFiles := aNumberOfFiles. - source := aHand. - wasHandled := false.! ! -!DropFilesEvent methodsFor: 'testing' stamp: 'HAW 12/24/2018 09:27:00'! - isDropEvent - - ^true! ! -!DropFilesEvent methodsFor: 'testing' stamp: 'HAW 12/24/2018 09:27:13'! - wasHandled - - ^wasHandled! ! -!DropFilesEvent methodsFor: 'testing' stamp: 'HAW 12/24/2018 09:27:26'! - wasHandled: aBool - - "This is ugly, and means that events are copied in many places..." - self flag: #jmvVer. - - wasHandled _ aBool! ! -!DropFilesEvent methodsFor: 'dispatching' stamp: 'HAW 12/24/2018 09:24:16'! - dispatchWith: aMorph localPosition: positionInAMorph - "Drop is done on the innermost target that accepts it." - - | eventPositionInChild | - - "Try to get out quickly" - (aMorph fullContainsPoint: positionInAMorph) ifFalse: [ ^#rejected ]. - - "Go looking if any of our submorphs wants it" - aMorph submorphsDo: [ :eachChild | - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ ^self ]]. - - (aMorph allowsFilesDrop and: [ aMorph containsPoint: positionInAMorph event: self ]) - ifTrue: [^ self sentTo: aMorph localPosition: positionInAMorph ]. - - ^#rejected! ! -!DropFilesEvent methodsFor: 'dispatching' stamp: 'HAW 12/24/2018 07:20:35'! - sentTo: aMorph localPosition: positionInAMorph - "Dispatch the receiver into aMorph" - - ^aMorph processDropFiles: self localPosition: positionInAMorph! ! -!DropFilesEvent methodsFor: 'dispatching' stamp: 'HAW 12/24/2018 07:53:42'! - startDispatchFrom: aHand - "double dispatch the event dispatch" - - aHand startDropFilesEventDispatch: self! ! -!DropFilesEvent methodsFor: 'position' stamp: 'HAW 12/24/2018 09:30:41'! - eventPosition - - ^position! ! -!DropFilesEvent methodsFor: 'primitives' stamp: 'HAW 12/24/2018 09:39:09'! - primDropRequestFileHandle: dropIndex - "Primitive. Return the (read-only) file handle for some file that was just dropped onto Squeak. - Fail if dropIndex is out of range or the primitive is not supported." - - ^nil! ! -!DropFilesEvent methodsFor: 'primitives' stamp: 'HAW 12/24/2018 09:38:59'! - primDropRequestFileName: dropIndex - "Primitive. Return the file name for some file that was just dropped onto Squeak. - Fail if dropIndex is out of range or the primitive is not supported." - - ^nil! ! -!DropFilesEvent methodsFor: 'files' stamp: 'HAW 12/24/2018 09:38:25'! - fileNamesDo: aBlock - - 1 to: numberOfFiles do: [ :fileNumber | | fileName | - fileName := self primDropRequestFileName: fileNumber. - fileName ifNotNil: aBlock ]! ! -!DropFilesEvent methodsFor: 'files' stamp: 'HAW 12/24/2018 10:34:28'! - numberOfFiles - - ^numberOfFiles! ! -!DropFilesEvent class methodsFor: 'instance creation' stamp: 'HAW 12/24/2018 09:32:07'! - at: aPosition with: aNumberOfFiles from: aHand - - ^self new initializeAt: aPosition with: aNumberOfFiles from: aHand - -! ! -!StandardFileStream class methodsFor: 'error handling' stamp: 'HAW 12/24/2018 09:50:28' prior: 16913802! - readOnlyFileDoesNotExistUserHandling: fullFileName - - | dir files choices selection newName fileName | - dir _ fullFileName asFileEntry parent. - files _ dir fileNames. - fileName _ fullFileName asFileEntry name. - choices _ fileName correctAgainst: files. - choices add: 'Choose another name'. - choices add: 'Cancel'. - selection _ (PopUpMenu labelArray: choices lines: (Array with: 5) ) - startUpWithCaption: fullFileName asFileEntry name, ' -does not exist.'. - selection = choices size ifTrue:["cancel" ^ nil "should we raise another exception here?"]. - selection < (choices size - 1) ifTrue: [ - newName _ (dir pathName , '/', (choices at: selection))]. - selection = (choices size - 1) ifTrue: [ - newName _ FillInTheBlankMorph - request: 'Enter a new file name' - initialAnswer: fileName. - "If Cancel was pressed, no file should be opened - Hernan" - newName isEmpty ifTrue: [ ^nil ]]. - newName = '' ifFalse: [^ FileIOAccessor default privateReadOnlyFile: newName asFileEntry ]. - ^ self error: 'Could not open a file'! ! -!HandMorph methodsFor: 'event handling' stamp: 'HAW 12/24/2018 09:29:37' prior: 16851755! - processEventQueue - "Process user input events from the local input devices." - - | evt evtBuf type hadAny mcs | - mcs _ mouseClickState. - hadAny := false. - [ (evtBuf := Sensor nextEvent) isNil ] whileFalse: [ - evt := nil. "for unknown event types" - type := evtBuf first. - type = EventSensor eventTypeMouse - ifTrue: [ evt _ self generateMouseEvent: evtBuf ] ifFalse: [ - type = EventSensor eventTypeKeyboard - ifTrue: [ evt _ self generateKeyboardEvent: evtBuf ] ifFalse: [ - type = EventSensor eventTypeWindow - ifTrue: [ evt _ self generateWindowEvent: evtBuf ] ifFalse: [ - type = EventSensor eventTypeDragDropFiles - ifTrue: [evt _ self generateDropFilesEvent: evtBuf]]]]. - "All other events are ignored" - evt - ifNil: [ - "I have to consume all eventTypeDragDropFiles of type 2 quicky, that is why - I check if it was an eventTypeDragDropFiles to continue in the loop - Hernan" - type ~= EventSensor eventTypeDragDropFiles ifTrue: [^hadAny]] - ifNotNil: [ - "Finally, handle it" - self startEventDispatch: evt. - hadAny := true. - "For better user feedback, return immediately after a mouse event has been processed." - evt isMouse ifTrue: [ ^hadAny ]]]. - "note: if we come here we didn't have any mouse events" - mcs - ifNotNil: [ - "No mouse events during this cycle. Make sure click states time out accordingly" - mcs - handleEvent: (self lastMouseEvent asMouseMove: (Time localMillisecondClock - self lastMouseEventTime max: 0)) - from: self ]. - ^hadAny! ! -!ChangeSet class methodsFor: 'services' stamp: 'HAW 12/24/2018 09:44:22' prior: 16799274! - fileIn: aFileEntry - "File in the entire contents of the file specified by the name provided" - - aFileEntry ifNil: [^ Smalltalk beep ]. - aFileEntry readStreamDo: [ :stream | - stream ifNotNil: [ stream fileIn ]]! ! - -DropFilesEvent removeSelector: #inittializeAt:with:from:! - -DropFilesEvent removeSelector: #sentTo:! - -DropFilesEvent removeSelector: #type! - -StandardFileStream removeSelector: #primDropRequestFileHandle:! - -StandardFileStream removeSelector: #primDropRequestFileHandle:! - -StandardFileStream removeSelector: #primDropRequestFileName:! - -StandardFileStream removeSelector: #primDropRequestFileName:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3546-DropFileSupport-HernanWilkinson-2018Dec20-15h12m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3546] on 27 December 2018 at 5:58:46 pm'! -!Float class methodsFor: 'constants' stamp: 'jmv 12/26/2018 12:50:56' prior: 50423348! - emax - "Answer exponent of the maximal representable finite value" - - ^1023! ! -!Float class methodsFor: 'class initialization' stamp: 'jmv 12/26/2018 13:08:28' prior: 50420583! - initClassCachedState - "Float initialize" - "Constants from Computer Approximations, pp. 182-183: - Pi = 3.14159265358979323846264338327950288 - Pi/2 = 1.57079632679489661923132169163975144 - Pi*2 = 6.28318530717958647692528676655900576 - Pi/180 = 0.01745329251994329576923690768488612 - 2.0 ln = 0.69314718055994530941723212145817657 - 2.0 sqrt = 1.41421356237309504880168872420969808" - - Pi _ 3.14159265358979323846264338327950288. - Halfpi _ Pi / 2.0. - Twopi _ Pi * 2.0. - RadiansPerDegree _ Pi / 180.0. - - Ln2 _ 0.69314718055994530941723212145817657. - Ln10 _ 10.0 ln. - Sqrt2 _ 1.41421356237309504880168872420969808. - E _ 2.718281828459045235360287471353. - - MaxVal _ 1.7976931348623157e308. - MaxValLn _ 709.782712893384. - MinValLogBase2 _ -1074. - - Infinity _ MaxVal * MaxVal. - NegativeInfinity _ 0.0 - Infinity. - NaN _ Infinity - Infinity. - NegativeZero _ Float fmin negated nextTowardsZero. -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3547-NicerNegativeZeroInit-JuanVuletich-2018Dec27-17h57m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3546] on 26 December 2018 at 1:54:58 pm'! -!Float commentStamp: 'jmv 12/26/2018 13:44:13' prior: 50414186! - A note About Floating Point numbers and Floating Point Arithmetic. - -The following is not specific to Cuis or Smalltalk at all. This is about the properties of Float numbers in any computer implementation. - -If you haven't done so already, read https://en.wikipedia.org/wiki/Floating-point_arithmetic - -But if you find the Wikipedia article too detailed, or hard to read, then try http://fabiensanglard.net/floating_point_visually_explained/ (get past "How Floating Point are usually explained" and read "A different way to explain..."). - -Other great reads are: - "Why don't my numbers add up?": - http://floating-point-gui.de/ -and - "What Every Computer Scientist Should Know About Floating-Point Arithmetic": - http://docs.oracle.com/cd/E19957-01/806-3568/ncg_goldberg.html -and also maybe - "Comparing floating point numbers" - https://randomascii.wordpress.com/2012/02/25/comparing-floating-point-numbers-2012-edition/ - -Now that you read them, and we are on the same boat, some further comments (from jmv): - -Floats are (conceptually) approximate real numbers. That's why trig and other trascendental functions always answer Floats. That's why it is ok to round the result of operations. That's why Float is considered more general than Fraction in ST-80 and most Smalltalks. So, when we have a Float value, we must not think about it as a Rational but as a Real (actually as some unknown Real that could hopefully be close to the Rational we can actually represent). Keep this in mind when dealing with Floats, and especially avoid comparing them for equality. - -When doing mixed operations with Floats and Fractions, Cuis, as most other Smalltalks, converts all values to Floats. Some other systems, including Pharo Smalltalk, Scheme and Lisp have two rules: when the answer is a Number, they convert to Float. But when the answer is a boolean (#<, #=, #<=, etc.) they convert to Fraction. We think this is a mistake. There should never be implicit conversions from Float to Fraction. Fractions are to hold exact values, and people expect Fractions to be exact. On the other hand, Floats are to hold approximations (and people should be aware of that!!). But an implicit conversion from Float to Fraction would give a Fraction that should not be considered an exact value (the value comes from an inexact Float), but that knowledge is lost, as it is an instance of Fraction. - -If you want exact arithmetic, usual mathematical properties (like transitivity of equality), can live in the limited world of Rational numbers, and can afford a slight performance penalty, use Fraction instead. Avoid trascendental functions and never convert to Float. - -In any case, most numeric computation is done on Float numbers. There are good reasons for that. One is that in most cases we don't need an exact answer. And in many cases we can't really have it: the inputs to algorithms already have a limited precision, or they use trascendental functions. And even when exact arithmetic possible, if we are doing sound synthesis, 24 bits of resolution is enough. For image processing and graphics, the result is never more than 16 bits per channel. So, these fields don't really need 64 bit Doubles. 32 bit Floats are enough. Other fields do need 64 bit Doubles, like physics simulations and geometry. Games usually prefer special, faster 32 bit Float operations in GPUs that have greater errors but are faster. - -There are some things that can be done to increase the confidence you can have on Float results. One is to do an error propagation analysis on the code you are running. This is not easy, but it is done for any widely used numerical method. Then, you can know real bounds and/or estimates of the errors made. So, understanding your inputs and your algorithms (for example error propagation, condition number, numeric stability), and using Float number if appropriate, is the usual advice. - -Perhaps you have heard about "interval arithmetic". It is a bit better than simple Float, but doesn't really fix the problems. - -The ultimate solution is to do Monte Carlo analysis, with random perturbation of inputs. After the Monte Carlo run, it is needed to do statistical analysis of possible correlations between the distributions of the random noise added to imputs and the result of the algorithm. - -Additional food for thought: http://www.cs.berkeley.edu/~wkahan/Mindless.pdf . According to this, doing Monte Carlo as described above attacks a slightly different problem. This might be yet another reason (besides performance) to try something like the next paragraph. I (jmv) came up with it, and I don't really know if it has been described and or tried before or not. Mhhh. Maybe a defensive publication is in order. - -A possibility that could be a practical solution, being much cheaper than Monte Carlo, but better than interval arithmetic, is to represent each value by 2 Floats: an estimation of the real value (i.e. an estimation of the mean value of the distribution of the corresponding Monte Carlo result), and an estimation of the error (i.e. an estimation of the standard deviation of the corresponding Monte Carlo result). Or perhaps even 3 of them. In addition to the estimation of the real value and an estimation of the error, we could add a hard bound on the error. In many cases it will be useless, because the error can not really be bound. But in those cases where it is possible to bound it, applications could really know about the quality of computed values. - -======================================================================= - -My instances represent IEEE 754 floating-point double-precision numbers. They have about 16 decimal digits of accuracy and their range is between plus and minus 10^307. Some valid examples are: - - 8.0 13.3 0.3 2.5e6 1.27e-30 1.27e-31 -12.987654e12 - -Mainly: no embedded blanks, little e for tens power, and a digit on both sides of the decimal point. It is actually possible to specify a radix for Squeak Float constants. This is great for teaching about numbers, but may be confusing to the average reader: - - 3r20.2 --> 6.66666666666667 - 8r20.2 --> 16.25 - -If you don't have access to the definition of IEEE754, you can figure out what is going on by printing various simple values in Float hex. It may help you to know that the basic format is... - sign 1 bit - exponent 11 bits with bias of 1023 (16r3FF) to produce an exponent - in the range -1023 .. +1024 - - 16r000: - significand = 0: Float zero - significand ~= 0: Denormalized number (exp = -1023 + 1 = -1022, no hidden '1' bit in mantissa) - - 16r7FF: - significand = 0: Infinity - significand ~= 0: Not A Number (NaN) representation - mantissa 53 bits, but only 52 are stored (20 in the first word, 32 in the second). This is because a normalized mantissa, by definition, has a 1 to the right of its floating point, and IEEE 754 omits this redundant bit to gain an extra bit of precision instead. People talk about the mantissa without its leading one as the FRACTION, and with its leading 1 as the SIGNFICAND. - -The single-precision format is... - sign 1 bit - exponent 8 bits, with bias of 127, to represent -126 to +127 - - 0x0 and 0xFF reserved for Float zero (mantissa is ignored) - - 16r7F reserved for Float underflow/overflow (mantissa is ignored) - mantissa 24 bits, but only 23 are stored -This format is used in FloatArray (qv), and much can be learned from the conversion routines, Float asIEEE32BitWord, and Float class fromIEEE32Bit:. - -You might also check https://en.wikipedia.org/wiki/IEEE_754_revision - -Other great reads (covering broader but interesting issues): -https://randomascii.wordpress.com/2013/07/16/floating-point-determinism/ -http://www.ima.umn.edu/2010-2011/W1.10-14.11/activities/Leeser-Miriam/Leeser-GPU-IMA-Jan2011.pdf! -!Float methodsFor: 'testing' stamp: 'jmv 12/26/2018 13:43:52' prior: 16845106! - sign - "Answer 1 if the receiver is greater than 0, -1 if less than 0, else 0. - Handle IEEE754 negative-zero by reporting a sign of -1 - Warning!! This makes Float negativeZero the only number in the system such that - x sign negated = x negated sign - evaluates to false!! - This precludes the simpler implementation in #signPart - 0.0 sign -> 0 - 0.0 signPart -> 1 - Float negativeZero sign -> -1 - Float negativeZero signPart -> -1 - " - - self > 0 ifTrue: [^ 1]. - (self < 0 or: [((self at: 1) bitShift: -31) = 1]) ifTrue: [^ -1]. - ^ 0! ! -!Float class methodsFor: 'instance creation' stamp: 'jmv 12/26/2018 13:54:36' prior: 50421714! - signPart: signPart mantissaPart: mantissaPart exponentPart: exponentPart - " - Float signPart: Float pi signPart mantissaPart: Float pi mantissaPart exponentPart: Float pi exponentPart - " - ^ mantissaPart asFloat * signPart timesTwoPower: exponentPart-52! ! -!Float class methodsFor: 'constants' stamp: 'jmv 12/26/2018 13:44:22' prior: 50421412! - precision - "Answer the apparent precision of the floating point representation. - That is the maximum number of radix-based digits (bits if radix=2) representable in floating point without rounding error. - Technically, 52 bits are stored in the representation, and normalized numbers have an implied leading 1 that is not stored. - Note that denormalized floating point numbers don't have the implied leading 1, and thus gradually lose precision. - This format implements the IEEE 754 binary64 format." - - ^53! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3548-FloatCosmetics-JuanVuletich-2018Dec26-13h28m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3546] on 26 December 2018 at 2:34:46 pm'! -!Float methodsFor: 'converting' stamp: 'jmv 12/26/2018 14:05:07' prior: 50414433! - asTrueFraction - " Answer a fraction that EXACTLY represents self, - a double precision IEEE floating point number. - By David N. Smith with significant performance - improvements by Luciano Esteban Notarfrancesco. - (Version of 11April97). - Refactoring and simplification by jmv" - - ^self - partValues: [ :sign :exponent :mantissa | | zeroBitsCount | - " Prepare result. If exponent is greater than mantissa size, result is an integer" - (exponent >= 52 or: [ - zeroBitsCount _ mantissa lowBit - 1. - exponent + zeroBitsCount >= 52 ]) - ifTrue: [ - "result is an integer number" - sign * mantissa bitShift: exponent - 52 ] - ifFalse: [ - " This is the 'obvious' way. Better do Luciano's trick below:" - "result := Fraction - numerator: sign * mantissa - denominator: (1 bitShift: 52 - exponent)." - " Form the result. When exp>52, the exponent is adjusted by - the number of trailing zero bits in the mantissa to minimize - the (huge) time that could be spent in #gcd:. " - Fraction - numerator: (sign * (mantissa bitShift: 0 - zeroBitsCount)) - denominator: (1 bitShift: 52 - exponent - zeroBitsCount) ] - ] - ifInfinite: [ self error: 'Cannot represent infinity as a fraction' ] - ifNaN: [ self error: 'Cannot represent Not-a-Number as a fraction' ].! ! -!Float methodsFor: 'converting' stamp: 'jmv 12/26/2018 14:33:41' prior: 50423261! - partBits: aThreeArgumentBlock - " - Extract the bits for Sign, Mantissa and Exponent parts of the floating point representation. - Just extract the bits. Do not add implicit bit. Do not correct denormals. Do not subtract exponent bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. (f signPart * f significandAsInteger * (2 raisedToInteger: f exponentPart-52)) asFloat = f } print ]. - " - | signBit exponentBits mantissaBits leastSignificativeWord mostSignificativeWord | - - mostSignificativeWord _ self basicAt: 1. - leastSignificativeWord _ self basicAt: 2. - signBit _ mostSignificativeWord bitShift: -31 . - exponentBits _ (mostSignificativeWord bitShift: -20 ) bitAnd: 16r7FF. - mantissaBits _ ((mostSignificativeWord bitAnd: 16r000FFFFF) bitShift: 32) + leastSignificativeWord. - - "Evaluate the block" - ^aThreeArgumentBlock value: signBit value: exponentBits value: mantissaBits! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/26/2018 14:32:49' prior: 50423294! - exponentBits - " - Actual bits for the exponent part of the floating point representation. - Just extract the bits. Do not correct denormals. Do not subtract bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - { f. f exponentBits. f exponentPart. f exponent } print ]. - " - - ^ self partBits: [ :signBit :exponentBits :mantissaBits | exponentBits ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/26/2018 14:33:27' prior: 50414477! - exponentPart - " - Exponent part of the floating point representation. - Valid for any floating point number (except zeros, infinities and NaNs). - Includes correction of stored exponent bits for denormals (where it acts as a label, not a real exponent). - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. (f signPart * f significandAsInteger * (2 raisedToInteger: f exponentPart-52)) asFloat = f } print ]. - " - ^self partValues: [ :sign :exponent :mantissa | exponent ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/26/2018 14:34:33' prior: 50423311! - mantissaBits - " - Actual bits for the mantissa part of the floating point representation. - Just extract the bits. Do not correct denormals. Do not subtract bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - { f. f mantissaBits. f mantissaPart. f significand. } print ]. - " - ^ self partBits: [ :signBit :exponentBits :mantissaBits | mantissaBits ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/26/2018 14:28:48' prior: 50421318! - mantissaPart - "Equivalent to #significandAsInteger." - "The actual bits in the mantissa of the receiver, as an integer, including the implicit leading 1 if appropriate. - Does not include the sign. - See #exponentPart and #signPart - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. (f signPart * f mantissaPart * (2 raisedToInteger: f exponentPart-52)) asFloat = f } print ]. - " - ^self partValues: [ :sign :exponent :mantissa | mantissa ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/26/2018 14:34:07' prior: 50423328! - signBit - " - Actual bits for the exponent part of the floating point representation. - Just extract the bits. Do not correct denormals. Do not subtract bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0. 0.0. -0.0} do: [ :f | - { f. f signBit. f signPart. f sign } print ]. - " - - ^ self partBits: [ :signBit :exponentBits :mantissaBits | signBit ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3549-FloatCosmetics-JuanVuletich-2018Dec26-13h54m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3546] on 26 December 2018 at 2:41:21 pm'! -!Float methodsFor: 'converting' stamp: 'jmv 12/26/2018 14:41:18' prior: 50421818! - partValues: aThreeArgumentBlock ifInfinite: infinityBlock ifNaN: nanBlock - " - Float pi hex print - Float pi partValues: [ :sign :exponent :mantissa | { sign hex. exponent hex. mantissa hex} print ] - 0.0 partValues: [ :sign :exponent :mantissa | { sign hex. exponent hex. mantissa hex} print ] - For 0.0, exponent will be the minimum possible, i.e. -1023, and mantissa will be 0. - " - | sign exponent mantissa | - - ^ self partBits: [ :signBit :exponentBits :mantissaBits | - - "Extract the sign" - sign _ signBit = 0 ifTrue: [1] ifFalse: [-1]. - - "Special cases: infinites and NaN" - exponentBits = 16r7FF ifTrue: [ - ^mantissaBits = 0 - ifTrue: [ infinityBlock valueWithPossibleArgument: self ] - ifFalse: [ nanBlock valueWithPossibleArgument: self and: mantissaBits ]]. - - "Unbias exponent: 16r3FF is bias" - exponent _ exponentBits - 16r3FF. - - exponentBits ~= 0 - ifTrue: [ - "Add back implicit leading 1 in fraction." - mantissa _ 16r0010000000000000 bitOr: mantissaBits ] - ifFalse: [ - "If expPart = 0, I am +/-zero or a denormal value. In such cases, no implicit leading bit in mantissa." - mantissa _ mantissaBits. - exponent _ exponent + 1 ]. - - "Evaluate the block" - aThreeArgumentBlock value: sign value: exponent value: mantissa - ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3550-FloatCosmetics-JuanVuletich-2018Dec26-14h34m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3550] on 27 December 2018 at 6:03:32 pm'! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/26/2018 14:59:25' prior: 50425634! - signBit - " - Actual sigh bit part of the floating point representation. - Just extract the bit. Do not correct denormals. Do not subtract bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0. 0.0. -0.0} do: [ :f | - { f. f signBit. f signPart. f sign } print ]. - " - - ^ self partBits: [ :signBit :exponentBits :mantissaBits | signBit ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 12/26/2018 15:00:07' prior: 50421348! - significandAsInteger - "The actual bits in the mantissa of the receiver, as an integer, including the implicit leading 1 if appropriate. - See #mantissaPart - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. (f signPart * f significandAsInteger * (2 raisedToInteger: f exponentPart-52)) asFloat = f } print ]. - " - ^self mantissaPart! ! -!Float methodsFor: 'printing' stamp: 'jmv 12/26/2018 14:57:20' prior: 50423053! - printOn: aStream fractionDigits: placesDesired - "This implementation avoids rounding errors doue to #rounded or #roundTo: - Round to a suitable integer and insert the decimal point in the appropriately between the digits." - - | i s scaled | - self isFinite ifFalse: [ ^self printOn: aStream ]. - - placesDesired > 0 ifFalse: [ - ^self rounded printOn: aStream ]. - - scaled _ self * (10 raisedTo: placesDesired). - "If rounding could possibly print a sequence that is read back as a different float, then go the more expensive Fraction way. - If the following line is commented, #testPrintShowingDecimalPlaces4 will fail!!" - scaled ulp > 1 ifTrue: [ - ^ self asTrueFraction printOn: aStream fractionDigits: placesDesired ]. - i _ scaled rounded. - i negative ifTrue: [ - aStream nextPut: $-. - i _ i negated ]. - s _ i printString. - placesDesired + 1 > s size - ifTrue: [ - aStream nextPutAll: '0.'. - placesDesired - s size timesRepeat: [ aStream nextPut: $0 ]. - aStream nextPutAll: s ] - ifFalse: [ - aStream - nextPutAll: (s copyFrom: 1 to: s size-placesDesired); - nextPut: $.; - nextPutAll: (s copyFrom: s size-placesDesired+1 to: s size) ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3551-FloatCosmetics-JuanVuletich-2018Dec27-18h03m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3550] on 27 December 2018 at 6:26:26 pm'! -!SequenceableCollection methodsFor: 'comparing' stamp: 'jmv 12/27/2018 18:20:09' prior: 16906017! - 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 isSequenceable ifFalse: [^ false]. - (size _ self size) = otherCollection size ifFalse: [^ false]. - 1 to: size do: - [:index | - (self at: index) = (otherCollection at: index) ifFalse: [^ false]]. - ^ true! ! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'jmv 12/26/2018 15:47:12' prior: 16906652! - polynomialEval: thisX - "Treat myself as the coefficients of a polynomial in X. Evaluate it with thisX. First element is the constant and last is the coefficient for the highest power. - https://en.wikipedia.org/wiki/Horner's_method" - " #(1 2 3) polynomialEval: 2 " "is 3*X^2 + 2*X + 1 with X = 2" - - | index sum | - sum := self at: (index := self size). - [ (index := index - 1) >= 1 ] whileTrue: [ - sum := sum * thisX + (self at: index) ]. - ^sum! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 12/27/2018 18:25:18' prior: 50419999! - colorFrom: parm - "Return an instantiated color from parm. If parm is already a color, return it, else return the result of my performing it if it's a symbol or, if it is a list, it can either be an array of three numbers, which will be interpreted as RGB values, or a list of symbols, the first of which is sent to me and then the others of which are in turn sent to the prior result, thus allowing entries of the form #(blue darker). Else just return the thing" - - | aColor firstParm | - (parm is: #Color) ifTrue: [ ^ parm ]. - parm isSymbol ifTrue: [ ^ self perform: parm ]. - parm isString ifTrue: [ ^ self fromHexString: parm ]. - (parm isCollection and: [ parm isSequenceable and: [ parm size > 0 ]]) - ifTrue: [ - firstParm _ parm first. - firstParm isNumber ifTrue: [ - ^ self fromRgbTriplet: parm]. - aColor _ self colorFrom: firstParm. - parm withIndexDo: [ :sym :ind | - ind > 1 ifTrue: [ - aColor _ aColor perform: sym ]]. - ^ aColor]. - ^ parm - -" -Color colorFrom: #(blue darker) -Color colorFrom: Color blue darker -Color colorFrom: #blue -Color colorFrom: #(0.0 0.0 1.0) -Color colorFrom: '#D7B360' -"! ! -!ParseNode methodsFor: 'printing' stamp: 'jmv 12/27/2018 18:25:45' prior: 16884894! - nodePrintOn: aStrm indent: nn - | var aaStrm myLine | - "Show just the sub nodes and the code." - - (aaStrm := aStrm) ifNil: [aaStrm := WriteStream on: (String new: 500)]. - nn timesRepeat: [aaStrm tab]. - aaStrm nextPutAll: self class name; space. - myLine := self printString withBlanksCondensed. - myLine := myLine copyFrom: 1 to: (myLine size min: 70). - aaStrm nextPutAll: myLine; newLine. - 1 to: self class instSize do: [:ii | - var := self instVarAt: ii. - (var respondsTo: #asReturnNode) ifTrue: [var nodePrintOn: aaStrm indent: nn+1]]. - 1 to: self class instSize do: [:ii | - var := self instVarAt: ii. - (var isCollection and: [var isSequenceable]) ifTrue: [ - var do: [ :aNode | - (aNode respondsTo: #asReturnNode) ifTrue: [ - aNode nodePrintOn: aaStrm indent: nn+1]]]]. - ^ aaStrm! ! - -SequenceableCollection removeSelector: #allButFirstDo:! - -SequenceableCollection removeSelector: #allButFirstDo:! - -SequenceableCollection removeSelector: #allButLastDo:! - -SequenceableCollection removeSelector: #allButLastDo:! - -SequenceableCollection removeSelector: #at:incrementBy:! - -SequenceableCollection removeSelector: #at:incrementBy:! - -SequenceableCollection removeSelector: #errorFirstObject:! - -SequenceableCollection removeSelector: #errorFirstObject:! - -SequenceableCollection removeSelector: #forceTo:paddingStartWith:! - -SequenceableCollection removeSelector: #forceTo:paddingStartWith:! - -SequenceableCollection removeSelector: #forceTo:paddingWith:! - -SequenceableCollection removeSelector: #forceTo:paddingWith:! - -SequenceableCollection removeSelector: #integerAt:! - -SequenceableCollection removeSelector: #integerAt:! - -SequenceableCollection removeSelector: #integerAt:put:! - -SequenceableCollection removeSelector: #integerAt:put:! - -SequenceableCollection removeSelector: #isSequenceableCollection! - -SequenceableCollection removeSelector: #isSequenceableCollection! - -Object removeSelector: #isSequenceableCollection! - -Object removeSelector: #isSequenceableCollection! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3552-SequenceableCollectionCleanup-JuanVuletich-2018Dec27-18h03m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3543] on 25 December 2018 at 5:16:22 pm'! - -RectangleLikeMorph subclass: #DraggingGuideMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -!classDefinition: #DraggingGuideMorph category: #'Morphic-Kernel'! -RectangleLikeMorph subclass: #DraggingGuideMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! -!Browser methodsFor: 'message category functions' stamp: 'AY 12/22/2018 11:56:46'! - categorizeUnderCategoryAt: aMessageCategoryListIndex messageAt: aMessageListIndex - - self selectedClassOrMetaClass ifNotNil: [ :class | | categorySelector messageSelector | - categorySelector _ self messageCategoryList at: aMessageCategoryListIndex ifAbsent: [^self]. - messageSelector _ self messageList at: aMessageListIndex ifAbsent: [^self]. - categorySelector ~= Categorizer allCategory - ifTrue: [ - class organization classify: messageSelector under: categorySelector suppressIfDefault: false. - self changed: #messageList]]! ! -!PluggableListMorph methodsFor: 'accessing' stamp: 'HAW 12/25/2018 12:21:46'! - rowAtLocation: aPoint ifNone: aNoneBlock - - | listMorph | - - listMorph _ self listMorph. - ^listMorph rowAtLocation: (listMorph internalize: aPoint) ifNone: aNoneBlock! ! -!PluggableListMorph methodsFor: 'drawing' stamp: 'AY 12/25/2018 16:51:46'! - flashRow: aRow - - ^self listMorph flashRow: aRow.! ! -!PluggableListMorph methodsFor: 'events' stamp: 'AY 12/25/2018 17:02:10'! - dragEvent: aMouseEvent localPosition: localEventPosition - - | row dragged | - - row _ self rowAtLocation: localEventPosition ifNone: [ ^self ]. - - dragged _ DraggingGuideMorph new. - dragged addMorph: (StringMorph contents: (self getListItem: row)). - dragged setProperty: #dragSource toValue: self. - dragged setProperty: #dropSelectorArgument toValue: row. - - aMouseEvent hand attachMorphBeside: dragged.! ! -!PluggableListMorph methodsFor: 'event handling testing' stamp: 'AY 12/22/2018 11:50:28'! - allowsMorphDrop - - ^self hasProperty: #allowsMorphDrop! ! -!PluggableListMorph methodsFor: 'private' stamp: 'AY 12/22/2018 01:26:29'! - itemsAreDraggable - - ^self hasProperty: #draggableItems! ! -!PluggableListMorph methodsFor: 'accessing - properties' stamp: 'AY 12/22/2018 12:26:06'! - acceptDropsFrom: aMorph performing: aDropActionSelector - - self setProperty: #allowsMorphDrop toValue: true. - self setProperty: #acceptedDragSource toValue: aMorph. - self setProperty: #dropActionSelector toValue: aDropActionSelector.! ! -!PluggableListMorph methodsFor: 'accessing - properties' stamp: 'AY 12/22/2018 12:25:54'! - makeItemsDraggable - - self setProperty: #draggableItems toValue: true! ! -!PluggableListMorph methodsFor: 'accessing - properties' stamp: 'AY 12/22/2018 01:26:39'! - makeItemsUndraggable - - self removeProperty: #draggableItems! ! -!PluggableListMorph methodsFor: 'accessing - properties' stamp: 'AY 12/22/2018 12:27:38'! - rejectDrops - - self removeProperty: #allowsMorphDrop. - self removeProperty: #acceptedDragSource. - self removeProperty: #dropActionSelector.! ! -!PluggableListMorph methodsFor: 'layout' stamp: 'AY 12/25/2018 16:52:06'! - acceptDroppingMorph: aMorph event: dropEvent - - | localPosition row dropActionSelector args | - - localPosition _ self internalizeFromWorld: dropEvent eventPosition. - row _ self rowAtLocation: localPosition ifNone: [ ^self ]. - - self flashRow: row. - - dropActionSelector _ self valueOfProperty: #dropActionSelector. - args _ dropActionSelector numArgs. - args = 1 ifTrue: [ - model perform: dropActionSelector with: row. - ^self]. - args = 2 ifTrue: [ | dropSelectorArgument | - dropSelectorArgument _ aMorph - valueOfProperty: #dropSelectorArgument - ifAbsent: [self error: 'aMorph is missing dropSelectorArgument property']. - model perform: dropActionSelector with: row with: dropSelectorArgument. - ^self]. - - self error: 'dropActionSelector must be a 1- or 2-keyword symbol'! ! -!PluggableListMorph methodsFor: 'dropping/grabbing' stamp: 'HAW 12/25/2018 12:22:07'! - wantsDroppedMorph: aMorph event: evt - - ^(aMorph is: #DraggingGuideMorph) - and: [ (aMorph valueOfProperty: #dragSource) = (self valueOfProperty: #acceptedDragSource) ]! ! -!DraggingGuideMorph methodsFor: 'initialization' stamp: 'AY 12/21/2018 16:05:14'! - defaultColor - - ^Color transparent! ! -!DraggingGuideMorph methodsFor: 'initialization' stamp: 'AY 12/21/2018 16:06:08'! - initialize - - super initialize. - extent _ 0@0.! ! -!DraggingGuideMorph methodsFor: 'testing' stamp: 'AY 12/21/2018 16:05:22'! - is: aSymbol - - ^aSymbol == #DraggingGuideMorph or: [ super is: aSymbol ]! ! -!DraggingGuideMorph methodsFor: 'dropping/grabbing' stamp: 'AY 12/25/2018 16:49:57'! -justDroppedInto: newOwnerMorph event: anEvent - - self delete. - anEvent hand redrawNeeded.! ! -!HandMorph methodsFor: 'double click support' stamp: 'AY 12/21/2018 16:07:39'! - waitForClicksOrDragOrSimulatedMouseButton2: aMorph event: evt clkSel: clkSel clkNHalf: clkNHalfSel dblClkSel: dblClkSel dblClkNHalfSel: dblClkNHalfSel tripleClkSel: tripleClkSel dragSel: dragSel - - mouseClickState _ - MouseClickState new - client: aMorph - drag: dragSel - click: clkSel - clickAndHalf: clkNHalfSel - dblClick: dblClkSel - dblClickAndHalf: dblClkNHalfSel - tripleClick: tripleClkSel - event: evt - sendMouseButton2Activity: Preferences tapAndHoldEmulatesButton2! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'AY 12/25/2018 17:06:43'! - attachMorphBeside: aMorph - - "Position the given morph beside this hand, then grab it." - - aMorph aboutToBeGrabbedBy: self. - ^self grabMorph: aMorph delta: (self morphWidth)@0! ! -!InnerListMorph methodsFor: 'list management' stamp: 'HAW 12/25/2018 12:21:42'! - rowAtLocation: aPoint ifNone: aNoneBlock - - | potentialRowNumber | - - potentialRowNumber := aPoint y // font height + 1. - - ^(listItems isInBounds: potentialRowNumber) - ifTrue: [ potentialRowNumber ] - ifFalse: aNoneBlock! ! -!InnerListMorph methodsFor: 'drawing' stamp: 'AY 12/25/2018 16:51:08'! - flashRow: aRow - - self world ifNotNil: [ :world | world canvas ifNotNil: [ :canvas | - Display flash: (canvas externalizeDisplayBounds: (self drawBoundsForRow: aRow) from: self) ]]. - -! ! -!PluggableListMorph methodsFor: 'events' stamp: 'HAW 12/25/2018 12:22:40' prior: 16888625! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - - | row | - - self hasKeyboardFocus ifFalse: [ - aMouseButtonEvent hand newKeyboardFocus: self. - "If we are focusing, deselect, so that later selection doesn't result in deselect." - self listMorph noSelection]. - row _ self - rowAtLocation: localEventPosition - ifNone: [^super mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition ]. - - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view. - Model update will be done on mouse button up, so this feedback will be visible before that." - self listMorph highlightedRow: row. - - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: #click:localPosition: - clkNHalf: nil - dblClkSel: (doubleClickSelector ifNotNil: [ #doubleClick:localPosition: ]) - dblClkNHalfSel: nil - tripleClkSel: nil - dragSel: (self itemsAreDraggable ifTrue: [ #dragEvent:localPosition: ] ifFalse: [ nil ])! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'AY 12/22/2018 12:18:24' prior: 16793141! - buildMorphicWindow - "Create a pluggable version of all the morphs for a Browser in Morphic" - - | upperPanes messageCatList messageList | - - messageCatList _ self buildMorphicMessageCatList. - messageList _ self buildMorphicMessageList. - messageList makeItemsDraggable. - messageCatList acceptDropsFrom: messageList performing: #categorizeUnderCategoryAt:messageAt:. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: self buildMorphicSystemCatList proportionalWidth: 0.2; - addAdjusterAndMorph: self buildMorphicClassColumn proportionalWidth: 0.2; - addAdjusterAndMorph: messageCatList proportionalWidth: 0.2; - addAdjusterAndMorph: messageList proportionalWidth: 0.4. - - self layoutMorph - addMorph: upperPanes proportionalHeight: 0.3; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.7. - - model changed: #editSelection! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3553-DragAndDropToCategorizeMethods-AngelYan-2018Dec25-17h15m-AY.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3544] on 27 December 2018 at 10:16:55 am'! -!Browser methodsFor: 'message category functions' stamp: 'HAW 12/27/2018 10:07:52'! - categorizeUnderNewCategoryMessageAt: aSelectorToCategorize - - self selectedClassOrMetaClass ifNotNil: [ :class | | newCategory | - newCategory _ self newCategoryNameIfNone: [ ^self ]. - class organization - addCategory: newCategory; - classify: aSelectorToCategorize under: newCategory suppressIfDefault: false. - - self changed: #messageCategoryList. - self changed: #messageList]! ! -!Browser methodsFor: 'message category functions' stamp: 'HAW 12/27/2018 10:04:30'! - newCategoryNameIfNone: aNoneBlock - - | labels lines menuIndex newName reject | - - labels _ OrderedCollection with: 'new...'. - reject _ Set new. - reject - addAll: self selectedClassOrMetaClass organization categories; - add: ClassOrganizer nullCategory; - add: ClassOrganizer default. - lines _ OrderedCollection new. - self selectedClassOrMetaClass allSuperclasses do: [:cls | | cats | - cls = Object ifFalse: [ - cats _ cls organization categories reject: - [:cat | reject includes: cat]. - cats isEmpty ifFalse: [ - lines add: labels size. - labels addAll: cats asArray sort. - reject addAll: cats]]]. - newName _ (labels size = 1 or: [ - menuIndex _ (PopUpMenu labelArray: labels lines: lines) - startUpWithCaption: 'Add Category'. - menuIndex = 0 ifTrue: [^ aNoneBlock value]. - menuIndex = 1]) - ifTrue: [ - self request: 'Please type new category name' - initialAnswer: 'category name'] - ifFalse: [ - labels at: menuIndex]. - - ^ newName isEmpty - ifTrue: aNoneBlock - ifFalse: [newName asSymbol]. -! ! -!PluggableListMorph methodsFor: 'accessing - properties' stamp: 'HAW 12/27/2018 09:32:34'! - acceptDropsFrom: aMorph performing: aDropActionSelector whenOutsideList: aDropOutsideListActionSelector - - (aDropActionSelector numArgs between: 1 and: 2) ifFalse: [ self error: 'dropActionSelector must be a 1- or 2-keyword symbol' ]. - aDropOutsideListActionSelector numArgs = 1 ifFalse: [ self error: 'dropOutsideListActionSelector must be a 1-keyword symbol' ]. - - self setProperty: #allowsMorphDrop toValue: true. - self setProperty: #acceptedDragSource toValue: aMorph. - self setProperty: #dropActionSelector toValue: aDropActionSelector. - self setProperty: #dropOutsideListActionSelector toValue: aDropOutsideListActionSelector ! ! -!PluggableListMorph methodsFor: 'dropping/grabbing' stamp: 'HAW 12/27/2018 10:14:02'! - acceptDroppingMorph: aMorph atRow: row withEvent: dropEvent - - | args dropActionSelector | - - self flashRow: row. - - dropActionSelector _ self valueOfProperty: #dropActionSelector. - args _ dropActionSelector numArgs. - args = 1 ifTrue: [ ^model perform: dropActionSelector with: row]. - args = 2 ifTrue: [ | dropSelectorArgument | - dropSelectorArgument _ aMorph - valueOfProperty: #dropSelectorArgument - ifAbsent: [self error: 'aMorph is missing dropSelectorArgument property']. - ^model perform: dropActionSelector with: row with: dropSelectorArgument ]. - - self error: 'dropActionSelector must be a 1- or 2-keyword symbol' - - ! ! -!PluggableListMorph methodsFor: 'dropping/grabbing' stamp: 'HAW 12/27/2018 09:28:18'! - acceptDroppingMorph: aMorph outsideListWithEvent: dropEvent - - | dropActionSelector dropSelectorArgument | - - dropActionSelector _ self valueOfProperty: #dropOutsideListActionSelector. - dropSelectorArgument _ aMorph - valueOfProperty: #dropSelectorArgument - ifAbsent: [self error: 'aMorph is missing dropSelectorArgument property']. - model perform: dropActionSelector with: dropSelectorArgument. - ! ! -!Browser methodsFor: 'message category functions' stamp: 'HAW 12/27/2018 10:02:04' prior: 16791958! - addCategory - "Present a choice of categories or prompt for a new category name and add it before the current selection, or at the end if no current selection" - - | oldIndex newName | - - selectedClassName ifNil: [ ^self ]. - - oldIndex _ self messageCategoryListIndex. - newName _ self newCategoryNameIfNone: [ ^self ]. - - self classOrMetaClassOrganizer - addCategory: newName - before: selectedMessageCategory. - self changed: #messageCategoryList. - self messageCategoryListIndex: - (oldIndex = 0 - ifTrue: [self classOrMetaClassOrganizer categories size + 1] - ifFalse: [oldIndex]). - self changed: #messageCategoryList. - -! ! -!Browser methodsFor: 'message category functions' stamp: 'HAW 12/27/2018 09:54:08' prior: 50425944! - categorizeUnderCategoryAt: aMessageCategoryListIndex messageAt: aSelectorToCategorize - - self selectedClassOrMetaClass ifNotNil: [ :class | | categorySelector | - categorySelector _ self messageCategoryList at: aMessageCategoryListIndex ifAbsent: [^self]. - categorySelector ~= Categorizer allCategory - ifTrue: [ - class organization classify: aSelectorToCategorize under: categorySelector suppressIfDefault: false. - self changed: #messageList]]! ! -!PluggableListMorph methodsFor: 'accessing - properties' stamp: 'HAW 12/27/2018 09:19:35' prior: 50426024! - rejectDrops - - self removeProperty: #allowsMorphDrop. - self removeProperty: #acceptedDragSource. - self removeProperty: #dropActionSelector. - self removeProperty: #dropOutsideListActionSelector! ! -!PluggableListMorph methodsFor: 'dropping/grabbing' stamp: 'HAW 12/27/2018 10:12:59' prior: 50426031! - acceptDroppingMorph: aMorph event: dropEvent - - | localPosition row | - - localPosition _ self internalizeFromWorld: dropEvent eventPosition. - row _ self rowAtLocation: localPosition ifNone: [ ^self acceptDroppingMorph: aMorph outsideListWithEvent: dropEvent ]. - - self acceptDroppingMorph: aMorph atRow: row withEvent: dropEvent. - - ! ! -!PluggableListMorph methodsFor: 'events' stamp: 'HAW 12/27/2018 10:10:27' prior: 50425976! - dragEvent: aMouseEvent localPosition: localEventPosition - - | row dragged listItem | - - row _ self rowAtLocation: localEventPosition ifNone: [ ^self ]. - listItem _ self getListItem: row. - - dragged _ DraggingGuideMorph new. - dragged addMorph: (StringMorph contents: listItem). - dragged setProperty: #dragSource toValue: self. - dragged setProperty: #dropSelectorArgument toValue: listItem. - - aMouseEvent hand attachMorphBeside: dragged.! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'HAW 12/27/2018 10:09:58' prior: 50426168! - buildMorphicWindow - "Create a pluggable version of all the morphs for a Browser in Morphic" - - | upperPanes messageCatList messageList | - - messageCatList _ self buildMorphicMessageCatList. - messageList _ self buildMorphicMessageList. - messageList makeItemsDraggable. - messageCatList - acceptDropsFrom: messageList - performing: #categorizeUnderCategoryAt:messageAt: - whenOutsideList: #categorizeUnderNewCategoryMessageAt:. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: self buildMorphicSystemCatList proportionalWidth: 0.2; - addAdjusterAndMorph: self buildMorphicClassColumn proportionalWidth: 0.2; - addAdjusterAndMorph: messageCatList proportionalWidth: 0.2; - addAdjusterAndMorph: messageList proportionalWidth: 0.4. - - self layoutMorph - addMorph: upperPanes proportionalHeight: 0.3; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.7. - - model changed: #editSelection! ! - -PluggableListMorph removeSelector: #acceptDropsFrom:performing:! - -PluggableListMorph removeSelector: #acceptDropsFrom:performing:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3554-AllowMethodDropAfterLastCategory-HernanWilkinson-2018Dec27-09h14m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3544] on 27 December 2018 at 10:21:22 am'! -!DropFilesAction methodsFor: 'evaluating - private' stamp: 'HAW 12/27/2018 10:21:17' prior: 50424882! - fileNamedDropped: aFileName - - (self canBeInstalled: aFileName) ifTrue: [ ^self ifUserWantsInstall: aFileName ]. - (self canBeFiledIn: aFileName) ifTrue: [ ^self ifUserWantsFileIn: aFileName ]. - - self inform: 'Dropped file ', aFileName, ' not supported'! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3555-tweak-HernanWilkinson-2018Dec27-10h16m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3544] on 27 December 2018 at 10:29:13 am'! -!HandMorph methodsFor: 'event handling' stamp: 'HAW 12/27/2018 10:28:27'! - createEventFrom: eventBuffer ofType: type - - type = EventSensor eventTypeMouse ifTrue: [ ^self generateMouseEvent: eventBuffer ]. - type = EventSensor eventTypeKeyboard ifTrue: [ ^self generateKeyboardEvent: eventBuffer ]. - type = EventSensor eventTypeWindow ifTrue: [ ^self generateWindowEvent: eventBuffer ]. - type = EventSensor eventTypeDragDropFiles ifTrue: [ ^self generateDropFilesEvent: eventBuffer ]. - - "All other events are ignored" - ^nil ! ! -!HandMorph methodsFor: 'event handling' stamp: 'HAW 12/27/2018 10:28:17' prior: 50425058! - processEventQueue - "Process user input events from the local input devices." - - | evt evtBuf type hadAny mcs | - mcs _ mouseClickState. - hadAny := false. - [ (evtBuf := Sensor nextEvent) isNil ] whileFalse: [ - type := evtBuf first. - evt := self createEventFrom: evtBuf ofType: type. - evt - ifNil: [ - "I have to consume all eventTypeDragDropFiles of type 2 quicky, that is why - I check if it was an eventTypeDragDropFiles to continue in the loop - Hernan" - type ~= EventSensor eventTypeDragDropFiles ifTrue: [^hadAny]] - ifNotNil: [ - "Finally, handle it" - self startEventDispatch: evt. - hadAny := true. - "For better user feedback, return immediately after a mouse event has been processed." - evt isMouse ifTrue: [ ^hadAny ]]]. - "note: if we come here we didn't have any mouse events" - mcs - ifNotNil: [ - "No mouse events during this cycle. Make sure click states time out accordingly" - mcs - handleEvent: (self lastMouseEvent asMouseMove: (Time localMillisecondClock - self lastMouseEventTime max: 0)) - from: self ]. - ^hadAny! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3556-ReadabilityTweak-HernanWilkinson-2018Dec27-10h21m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3544] on 27 December 2018 at 1:42:37 pm'! -!Browser methodsFor: 'message category functions' stamp: 'HAW 12/27/2018 13:11:10'! - categorizeUnderCategoryAt: aMessageCategoryListIndex selector: aSelectorToCategorize - - self selectedClassOrMetaClass ifNotNil: [ :class | | categorySelector | - categorySelector _ self messageCategoryList at: aMessageCategoryListIndex ifAbsent: [^self]. - categorySelector ~= Categorizer allCategory - ifTrue: [ - class organization classify: aSelectorToCategorize under: categorySelector suppressIfDefault: false. - self changed: #messageList]]! ! -!Browser methodsFor: 'message category functions' stamp: 'HAW 12/27/2018 13:10:15'! - categorizeUnderNewCategorySelector: aSelectorToCategorize - - self selectedClassOrMetaClass ifNotNil: [ :class | | newCategory | - newCategory _ self newCategoryNameIfNone: [ ^self ]. - class organization - addCategory: newCategory; - classify: aSelectorToCategorize under: newCategory suppressIfDefault: false. - - self changed: #messageCategoryList. - self changed: #messageList]! ! -!Browser methodsFor: 'system category functions' stamp: 'HAW 12/27/2018 13:30:46'! - categorizeUnderCategoryAt: aSystemCategoryIndex class: aClassName - - systemOrganizer classify: aClassName under: (self systemCategoryList at: aSystemCategoryIndex). - self changed: #classList! ! -!Browser methodsFor: 'system category functions' stamp: 'HAW 12/27/2018 13:39:38'! - categorizeUnderNewCategoryClass: aClassName - - | newCategory | - - newCategory _ self newCategoryNameIfNone: [ ^self ]. - - systemOrganizer - addCategory: newCategory; - classify: aClassName under: newCategory. - - self changed: #systemCategoryList. - self changed: #classList.! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'HAW 12/27/2018 13:14:38'! - buildMorphicClassColumnWith: classList - - | column | - - column _ LayoutMorph newColumn. - column - addMorphUseAll: classList; - addAdjusterAndMorph: self buildMorphicSwitches fixedHeight: (Theme current minimalWindows ifTrue: [AbstractFont default height + 4] ifFalse: [AbstractFont default height *2-4]). - - ^column! ! -!Browser methodsFor: 'system category functions' stamp: 'HAW 12/27/2018 13:37:37' prior: 16792558! - addSystemCategory - "Prompt for a new category name and add it before the - current selection, or at the end if no current selection" - - | oldIndex newName | - - oldIndex _ self systemCategoryListIndex. - newName _ self newCategoryNameIfNone: [ ^self ]. - - systemOrganizer - addCategory: newName - before: selectedSystemCategory. - self systemCategoryListIndex: - (oldIndex = 0 - ifTrue: [self systemCategoryList size] - ifFalse: [oldIndex]). - self changed: #systemCategoryList.! ! -!Browser methodsFor: 'system category functions' stamp: 'HAW 12/27/2018 13:38:14' prior: 50426220! - newCategoryNameIfNone: aNoneBlock - - | newName | - - newName _ self - request: 'Please type new category name' - initialAnswer: 'Category-Name'. - - ^newName isEmpty - ifTrue: aNoneBlock - ifFalse: [newName asSymbol].! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'HAW 12/27/2018 13:15:08' prior: 16793040! - buildMorphicClassColumn - - ^self buildMorphicClassColumnWith: self buildMorphicClassList! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'HAW 12/27/2018 13:16:43' prior: 50426399! - buildMorphicWindow - "Create a pluggable version of all the morphs for a Browser in Morphic" - - | upperPanes messageCatList messageList systemCatList classList | - - systemCatList _ self buildMorphicSystemCatList. - classList _ self buildMorphicClassList. - messageCatList _ self buildMorphicMessageCatList. - messageList _ self buildMorphicMessageList. - - classList makeItemsDraggable. - systemCatList - acceptDropsFrom: classList - performing: #categorizeUnderCategoryAt:class: - whenOutsideList: #categorizeUnderNewCategoryClass:. - - messageList makeItemsDraggable. - messageCatList - acceptDropsFrom: messageList - performing: #categorizeUnderCategoryAt:selector: - whenOutsideList: #categorizeUnderNewCategorySelector:. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: systemCatList proportionalWidth: 0.2; - addAdjusterAndMorph: (self buildMorphicClassColumnWith: classList) proportionalWidth: 0.2; - addAdjusterAndMorph: messageCatList proportionalWidth: 0.2; - addAdjusterAndMorph: messageList proportionalWidth: 0.4. - - self layoutMorph - addMorph: upperPanes proportionalHeight: 0.3; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.7. - - model changed: #editSelection! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3557-DragAndDropToCategorizeClasses-HernanWilkinson-2018Dec27-10h29m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3544] on 27 December 2018 at 1:50:32 pm'! -!Browser methodsFor: 'system category functions' stamp: 'HAW 12/27/2018 13:48:49' prior: 50426554! - categorizeUnderCategoryAt: aSystemCategoryIndex class: aClassName - - systemOrganizer classify: aClassName withBlanksTrimmed asSymbol under: (self systemCategoryList at: aSystemCategoryIndex). - self changed: #classList! ! -!Browser methodsFor: 'system category functions' stamp: 'HAW 12/27/2018 13:48:56' prior: 50426563! -categorizeUnderNewCategoryClass: aClassName - - | newCategory | - - newCategory _ self newCategoryNameIfNone: [ ^self ]. - - systemOrganizer - addCategory: newCategory; - classify: aClassName withBlanksTrimmed asSymbol under: newCategory. - - self changed: #systemCategoryList. - self changed: #classList.! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3558-ClassesDnDFix-HernanWilkinson-2018Dec27-13h42m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3558] on 28 December 2018 at 11:02:37 am'! -!ClassDescription class methodsFor: 'utilities' stamp: 'jmv 12/28/2018 10:34:16'! - printPackageExtensionCategories - "In a bare image, without any packages, should print nothing - ClassDescription printPackageExtensionCategories - ClassOrganizer allInstancesDo: [:co | co removeEmptyCategories]. - " - ClassDescription allSubInstances do: [ :cls | - cls organization categories do: [ :cat | - (cat beginsWith: '*') ifTrue: [ - {cls. cat} print ]]].! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3559-RemovePackageLeftovers-JuanVuletich-2018Dec28-10h58m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3559] on 28 December 2018 at 11:16:11 am'! -!SelectionMenu methodsFor: 'basic control sequence' stamp: 'KLG 12/28/2018 14:05:30' prior: 16904809! - startUpWithCaption: captionOrNil at: location allowKeyboard: aBoolean - "Overridden to return value returned by manageMarker. The boolean parameter indicates whether the menu should be given keyboard focus (if in morphic)" - - | index | - index _ super startUpWithCaption: captionOrNil at: location allowKeyboard: aBoolean. - selections ifNil: [ ^index ]. "If there are no selections defined, show the super class' behavior." - index between: 1 and: selections size :: ifFalse: [ ^nil ]. - ^ selections at: index! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3560-FixFor-SelectionMenu-confirm-GeraldKlix-2018Dec28-11h15m-KLG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3560] on 28 December 2018 at 11:29:52 am'! -!CodeProvider methodsFor: 'misc' stamp: 'HAW 12/28/2018 09:33:38' prior: 16812484! - okayToAccept - "Answer whether it is okay to accept the receiver's input" - - self showingByteCodes ifTrue: [ - self inform: -'Sorry, you can only submit changes here -when you are showing source.'. - ^ false]. - - self showingDocumentation ifTrue: [ - self inform: -'Sorry, you can only submit changes here -when you are showing source.'. - ^ false]. - - self showingAnyKindOfDiffs ifTrue: [ - ^ SelectionMenu confirm: -'Caution!! You are "showing diffs" here, so -there is a danger that some of the text in the -code pane is contaminated by the "diff" display' - trueChoice: 'accept anyway -- I''ll take my chances' falseChoice: 'um, let me reconsider' icons: #(acceptIcon cancelIcon) - ]. - - ^ true! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3561-AddIconsTo-okayToAccept-HernanWilkinson-2018Dec28-11h27m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3561] on 28 December 2018 at 12:44:11 pm'! -!Browser methodsFor: 'message category functions' stamp: 'HAW 12/28/2018 12:37:44'! - newMethodCategoryNameIfNone: aNoneBlock - - | labels lines menuIndex newName reject | - - labels _ OrderedCollection with: 'new...'. - reject _ Set new. - reject - addAll: self selectedClassOrMetaClass organization categories; - add: ClassOrganizer nullCategory; - add: ClassOrganizer default. - lines _ OrderedCollection new. - self selectedClassOrMetaClass allSuperclasses do: [:cls | | cats | - cls = Object ifFalse: [ - cats _ cls organization categories reject: - [:cat | reject includes: cat]. - cats isEmpty ifFalse: [ - lines add: labels size. - labels addAll: cats asArray sort. - reject addAll: cats]]]. - newName _ (labels size = 1 or: [ - menuIndex _ (PopUpMenu labelArray: labels lines: lines) - startUpWithCaption: 'Add Category'. - menuIndex = 0 ifTrue: [^ aNoneBlock value]. - menuIndex = 1]) - ifTrue: [ - self request: 'Please type new category name' - initialAnswer: 'category name'] - ifFalse: [ - labels at: menuIndex]. - - ^ newName isEmpty - ifTrue: aNoneBlock - ifFalse: [newName asSymbol]. -! ! -!Browser methodsFor: 'system category functions' stamp: 'HAW 12/28/2018 12:37:19'! - newSystemCategoryNameIfNone: aNoneBlock - - | newName | - - newName _ self - request: 'Please type new category name' - initialAnswer: 'Category-Name'. - - ^newName isEmpty - ifTrue: aNoneBlock - ifFalse: [newName asSymbol].! ! -!Browser methodsFor: 'message category functions' stamp: 'HAW 12/28/2018 12:37:56' prior: 50426317! - addCategory - "Present a choice of categories or prompt for a new category name and add it before the current selection, or at the end if no current selection" - - | oldIndex newName | - - selectedClassName ifNil: [ ^self ]. - - oldIndex _ self messageCategoryListIndex. - newName _ self newMethodCategoryNameIfNone: [ ^self ]. - - self classOrMetaClassOrganizer - addCategory: newName - before: selectedMessageCategory. - self changed: #messageCategoryList. - self messageCategoryListIndex: - (oldIndex = 0 - ifTrue: [self classOrMetaClassOrganizer categories size + 1] - ifFalse: [oldIndex]). - self changed: #messageCategoryList. - -! ! -!Browser methodsFor: 'message category functions' stamp: 'HAW 12/28/2018 12:38:40' prior: 50426539! - categorizeUnderNewCategorySelector: aSelectorToCategorize - - self selectedClassOrMetaClass ifNotNil: [ :class | | newCategory | - newCategory _ self newMethodCategoryNameIfNone: [ ^self ]. - class organization - addCategory: newCategory; - classify: aSelectorToCategorize under: newCategory suppressIfDefault: false. - - self changed: #messageCategoryList. - self changed: #messageList]! ! -!Browser methodsFor: 'system category functions' stamp: 'HAW 12/28/2018 12:38:00' prior: 50426589! - addSystemCategory - "Prompt for a new category name and add it before the - current selection, or at the end if no current selection" - - | oldIndex newName | - - oldIndex _ self systemCategoryListIndex. - newName _ self newSystemCategoryNameIfNone: [ ^self ]. - - systemOrganizer - addCategory: newName - before: selectedSystemCategory. - self systemCategoryListIndex: - (oldIndex = 0 - ifTrue: [self systemCategoryList size] - ifFalse: [oldIndex]). - self changed: #systemCategoryList.! ! -!Browser methodsFor: 'system category functions' stamp: 'HAW 12/28/2018 12:38:10' prior: 50426683! - categorizeUnderNewCategoryClass: aClassName - - | newCategory | - - newCategory _ self newSystemCategoryNameIfNone: [ ^self ]. - - systemOrganizer - addCategory: newCategory; - classify: aClassName withBlanksTrimmed asSymbol under: newCategory. - - self changed: #systemCategoryList. - self changed: #classList.! ! - -Browser removeSelector: #categorizeUnderCategoryAt:messageAt:! - -Browser removeSelector: #categorizeUnderCategoryAt:messageAt:! - -Browser removeSelector: #categorizeUnderNewCategoryMessageAt:! - -Browser removeSelector: #categorizeUnderNewCategoryMessageAt:! - -Browser removeSelector: #newCategoryNameIfNone:! - -Browser removeSelector: #newCategoryNameIfNone:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3562-ClassesDragAndDropFix-HernanWilkinson-2018Dec28-12h33m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3562] on 29 December 2018 at 11:17:58 am'! - -ActiveModel subclass: #SimpleServiceEntry - instanceVariableNames: 'provider label selector useLineAfter stateSelector description argumentGetter buttonLabel argumentProvider triggerFileListChanged sortOrder icon ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-FileList'! - -!classDefinition: #SimpleServiceEntry category: #'Tools-FileList'! -ActiveModel subclass: #SimpleServiceEntry - instanceVariableNames: 'provider label selector useLineAfter stateSelector description argumentGetter buttonLabel argumentProvider triggerFileListChanged sortOrder icon' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-FileList'! - -Object subclass: #DropFilesAction - instanceVariableNames: 'shouldAskForCancel dropFilesEvent cancelBlock stopHereBlock selectedFileEntry shouldAskToStop ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Worlds'! - -!classDefinition: #DropFilesAction category: #'Morphic-Worlds'! -Object subclass: #DropFilesAction - instanceVariableNames: 'shouldAskForCancel dropFilesEvent cancelBlock stopHereBlock selectedFileEntry shouldAskToStop' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Worlds'! -!SimpleServiceEntry methodsFor: 'accessing' stamp: 'HAW 12/29/2018 09:55:38'! - icon - - ^icon ! ! -!SimpleServiceEntry methodsFor: 'accessing' stamp: 'HAW 12/29/2018 09:55:29'! - icon: anIcon - - icon := anIcon ! ! -!SimpleServiceEntry class methodsFor: 'instance creation' stamp: 'HAW 12/29/2018 10:21:57'! - provider: anObject label: aString selector: aSymbol description: anotherString buttonLabel: aLabel icon: anIcon - - ^ (self provider: anObject label: aString selector: aSymbol description: anotherString buttonLabel: aLabel) - icon: anIcon; - yourself! ! -!SimpleServiceEntry class methodsFor: 'instance creation' stamp: 'HAW 12/29/2018 10:21:33'! - provider: anObject label: aString selector: aSymbol description: anotherString icon: anIcon - - ^(self provider: anObject label: aString selector: aSymbol description: anotherString) - icon: anIcon; - yourself! ! -!DropFilesAction methodsFor: 'evaluating - private' stamp: 'HAW 12/29/2018 11:14:32'! - createMenuFor: options - - | icons lines labels | - - "options is a small collection, no problem to collect twice - Hernan" - labels := options collect: [ :option | option label ]. - icons := options collect: [ :option | option icon ]. - - shouldAskToStop - ifTrue: [ - lines := Array with: labels size. - labels add: 'stop here'. - icons add: #cancelIcon ] - ifFalse: [ lines := #() ]. - - ^PopUpMenu labelArray: labels lines: lines icons: icons! ! -!DropFilesAction methodsFor: 'evaluating - private' stamp: 'HAW 12/29/2018 11:06:41'! - performService: aService - - aService - argumentProvider: self; - performService -! ! -!DropFilesAction methodsFor: 'FileList protocol' stamp: 'HAW 12/28/2018 20:31:41'! - fullName - - ^selectedFileEntry name ! ! -!DropFilesAction methodsFor: 'FileList protocol' stamp: 'HAW 12/28/2018 20:26:43'! - selectedFileEntry - - ^selectedFileEntry! ! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'HAW 12/29/2018 10:06:58' prior: 50369059! - serviceBrowseCode - "Answer the service of opening a file-contents browser" - - ^ (SimpleServiceEntry - provider: self - label: 'browse code' - selector: #browseCode: - description: 'open a "file-contents browser" on this file, allowing you to view and selectively load its code' - buttonLabel: 'code' - icon: #editFindReplaceIcon) - sortOrder: 10; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'HAW 12/29/2018 10:07:24' prior: 50369075! - serviceBrowsePackage - "Answer the service of opening a file-contents browser" - - ^ (SimpleServiceEntry - provider: self - label: 'browse package' - selector: #browsePackage: - description: 'open a "package file browser" on this file, allowing you to view and selectively load its code' - buttonLabel: 'package browser' - icon: #editFindReplaceIcon) - sortOrder: 10; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!ChangeList class methodsFor: 'fileIn/Out' stamp: 'HAW 12/29/2018 10:01:13' prior: 50369091! - serviceContents - "Answer a service for opening a changelist browser on a file" - - ^ (SimpleServiceEntry - provider: self - label: 'see code file contents' - selector: #browseContents: - description: 'open a code file contents tool on this file' - buttonLabel: 'contents' - icon: #changesIcon) - sortOrder: 20; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!ChangeList class methodsFor: 'fileIn/Out' stamp: 'HAW 12/29/2018 09:59:06' prior: 50369105! - servicePackageContents - "Answer a service for opening a changelist browser on a file" - - ^ (SimpleServiceEntry - provider: self - label: 'see package file contents' - selector: #browsePackageContents: - description: 'open a code file contents tool on this package file' - buttonLabel: 'pck contents' - icon: #changesIcon) - sortOrder: 20; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!ChangeList class methodsFor: 'fileIn/Out' stamp: 'HAW 12/29/2018 10:01:37' prior: 50406244! - serviceRecentChanges - "Answer a service for opening a changelist browser on the tail end of a .changes file" - - ^ SimpleServiceEntry - provider: self - label: 'see recent changes in file' - selector: #browseRecentLogOn: - description: 'open a changelist tool on recent changes in file' - buttonLabel: 'recent changes' - icon: #changesIcon! ! -!FileList methodsFor: 'own services' stamp: 'HAW 12/29/2018 10:23:22' prior: 16842644! - serviceAddNewDirectory - "Answer a service entry characterizing the 'add new directory' command" - - ^ SimpleServiceEntry - provider: self - label: 'add new directory' - selector: #addNewDirectory - description: 'adds a new, empty directory (folder)' - icon: #listAddIcon! ! -!FileList methodsFor: 'own services' stamp: 'HAW 12/29/2018 10:42:05' prior: 16842655! - serviceAddNewFile - "Answer a service entry characterizing the 'add new file' command" - - ^ SimpleServiceEntry - provider: self - label: 'add new file' - selector: #addNewFile - description: 'create a new,. empty file, and add it to the current directory.' - icon: #newIcon! ! -!FileList methodsFor: 'own services' stamp: 'HAW 12/29/2018 10:24:39' prior: 16842665! - serviceCopyName - - ^ SimpleServiceEntry - provider: self - label: 'copy name to clipboard' - selector: #copyName - description:'copy name to clipboard' - icon: #copyIcon! ! -!FileList methodsFor: 'own services' stamp: 'HAW 12/29/2018 10:26:03' prior: 16842672! - serviceDeleteFile - - ^ SimpleServiceEntry - provider: self - label: 'delete' - selector: #deleteFile - description: 'delete the seleted item' - icon: #deleteIcon! ! -!FileList methodsFor: 'own services' stamp: 'HAW 12/29/2018 10:41:24' prior: 16842679! - serviceGet - "Answer a service for getting the entire file" - - ^ SimpleServiceEntry - provider: self - label: 'get entire file' - selector: #get - description: 'if the file has only been partially read in, because it is very large, read the entire file in at this time.' - icon: #textEditorIcon! ! -!FileList methodsFor: 'own services' stamp: 'HAW 12/29/2018 10:40:08' prior: 16842690! - serviceGetHex - - ^ SimpleServiceEntry - provider: self - label: 'view as hex' - selector: #getHex - description: 'view as hex' - icon: #fontXGenericIcon! ! -!FileList methodsFor: 'own services' stamp: 'HAW 12/29/2018 10:27:40' prior: 16842697! - serviceRenameFile - - ^ SimpleServiceEntry - provider: self - label: 'rename' - selector: #renameFile - description: 'rename file' - icon: #saveAsIcon! ! -!FileList methodsFor: 'own services' stamp: 'HAW 12/29/2018 10:31:06' prior: 16842704! - serviceSortByDate - "Answer a service for sorting by date" - | buttonLabel | - buttonLabel _ sortMode = #date - ifTrue: [ - sortAscending - ifTrue: [ '[^] - date' ] - ifFalse: [ '[v] - date' ]] - ifFalse: [ 'date' ]. - ^ (SimpleServiceEntry - provider: self - label: 'by date' - selector: #sortByDate - description: 'sort entries by date' - icon: #sendReceiveIcon) - extraSelector: #sortingByDate; - buttonLabel: buttonLabel! ! -!FileList methodsFor: 'own services' stamp: 'HAW 12/29/2018 10:31:00' prior: 16842720! - serviceSortByName - "Answer a service for soring by name" - | buttonLabel | - buttonLabel _ sortMode = #name - ifTrue: [ - sortAscending - ifTrue: [ '[^] - name' ] - ifFalse: [ '[v] - name' ]] - ifFalse: [ 'name' ]. - ^ (SimpleServiceEntry - provider: self - label: 'by name' - selector: #sortByName - description: 'sort entries by name' - icon: #sendReceiveIcon) - extraSelector: #sortingByName; - buttonLabel: buttonLabel! ! -!FileList methodsFor: 'own services' stamp: 'HAW 12/29/2018 10:29:42' prior: 16842735! - serviceSortBySize - "Answer a service for sorting by size" - | buttonLabel | - buttonLabel _ sortMode = #size - ifTrue: [ - sortAscending - ifTrue: [ '[^] - size' ] - ifFalse: [ '[v] - size' ]] - ifFalse: [ 'size' ]. - ^ (SimpleServiceEntry - provider: self - label: 'by size' - selector: #sortBySize - description: 'sort entries by size' - icon: #sendReceiveIcon) - extraSelector: #sortingBySize; - buttonLabel: buttonLabel.! ! -!FileList methodsFor: 'own services' stamp: 'HAW 12/29/2018 10:33:04' prior: 16842750! - serviceViewContentsInWorkspace - "Answer a service for viewing the contents of a file in a workspace" - - ^ SimpleServiceEntry - provider: self - label: 'workspace with contents' - selector: #viewContentsInWorkspace - description: 'open a new Workspace whose contents are set to the contents of this file' - icon: #terminalIcon! ! -!SimpleServiceEntry methodsFor: 'services menu' stamp: 'HAW 12/29/2018 10:20:15' prior: 50392959! - addServiceFor: served toMenu: aMenu - argumentProvider _ served. - aMenu - add: self label - target: self - action: #performService - icon: icon. - self useLineAfter ifTrue: [ aMenu addLine ].! ! -!SimpleServiceEntry methodsFor: 'initialization' stamp: 'HAW 12/29/2018 10:20:39' prior: 50369297! - initialize - - triggerFileListChanged _ false. - sortOrder _ 1. - icon _ nil.! ! -!DropFilesAction methodsFor: 'initialization' stamp: 'HAW 12/29/2018 11:14:32' prior: 50424847! - initializeFor: aDropFilesEvent - - dropFilesEvent := aDropFilesEvent. - shouldAskToStop := aDropFilesEvent numberOfFiles > 1! ! -!DropFilesAction methodsFor: 'evaluating' stamp: 'HAW 12/29/2018 11:14:49' prior: 50424854! - value - - stopHereBlock := [ ^self ]. - dropFilesEvent fileNamesDo: [ :fileName | self fileNamedDropped: fileName ] - -! ! -!DropFilesAction methodsFor: 'evaluating - private' stamp: 'HAW 12/29/2018 11:15:10' prior: 50426443! - fileNamedDropped: aFileName - - | options selectionIndex menu | - - selectedFileEntry := aFileName asFileEntry. - options := FileList itemsForFile: aFileName. - options isEmpty ifTrue: [ ^self inform: 'No action found for ', selectedFileEntry name ]. - menu := self createMenuFor: options. - - selectionIndex := menu startUpWithCaption: 'Select action for ', selectedFileEntry name. - - selectionIndex = 0 ifTrue: [ ^self ]. - (options isInBounds: selectionIndex) ifTrue: [ ^self performService: (options at: selectionIndex) ]. - "The only available option is 'stop here'. This could change if #createMenuFor: changes - Hernan" - stopHereBlock value - -! ! -!ChangeSet class methodsFor: 'file list services' stamp: 'HAW 12/29/2018 10:04:54' prior: 50369148! - serviceFileIn - "Answer a service for filing in an entire file" - - ^ (SimpleServiceEntry - provider: self - label: 'file in' - selector: #fileIn: - description: 'file in the entire contents of the file, which is expected to contain Smalltalk code in fileout ("chunk") format' - buttonLabel: 'filein' - icon: #saveIcon) - sortOrder: 100; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!ChangeSet class methodsFor: 'file list services' stamp: 'HAW 12/29/2018 10:05:49' prior: 50369164! - serviceInstall - "Answer a service for filing in an entire file" - - ^ (SimpleServiceEntry - provider: self - label: 'install code' - selector: #install: - description: 'install change set' - buttonLabel: 'install' - icon: #saveIcon) - sortOrder: 100; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!CodePackageFile class methodsFor: 'file list services' stamp: 'HAW 12/29/2018 10:16:53' prior: 50407037! - serviceInstallPackage - "Answer the service of installing a CodePackageFile (a chunk format file for a CodePackage)" - - ^ (SimpleServiceEntry - provider: self - label: 'install package' - selector: #installPackage: - description: 'install the package, replacing all existing code in the package (if any); create a new change set just for the installation' - buttonLabel: 'install package' - icon: #saveIcon) - sortOrder: 100; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! - -DropFilesAction removeSelector: #ask:onYes:! - -DropFilesAction removeSelector: #ask:onYes:! - -DropFilesAction removeSelector: #canBeFiledIn:! - -DropFilesAction removeSelector: #canBeFiledIn:! - -DropFilesAction removeSelector: #canBeInstalled:! - -DropFilesAction removeSelector: #canBeInstalled:! - -DropFilesAction removeSelector: #ifUserWantsFileIn:! - -DropFilesAction removeSelector: #ifUserWantsFileIn:! - -DropFilesAction removeSelector: #ifUserWantsInstall:! - -DropFilesAction removeSelector: #ifUserWantsInstall:! - -DropFilesAction removeSelector: #isAChangeSet:! - -DropFilesAction removeSelector: #isChangeSet:! - -ActiveModel subclass: #SimpleServiceEntry - instanceVariableNames: 'provider label selector useLineAfter stateSelector description argumentGetter buttonLabel argumentProvider triggerFileListChanged sortOrder icon' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-FileList'! - -!classDefinition: #SimpleServiceEntry category: #'Tools-FileList'! -ActiveModel subclass: #SimpleServiceEntry - instanceVariableNames: 'provider label selector useLineAfter stateSelector description argumentGetter buttonLabel argumentProvider triggerFileListChanged sortOrder icon' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-FileList'! - -Object subclass: #DropFilesAction - instanceVariableNames: 'dropFilesEvent selectedFileEntry shouldAskToStop stopHereBlock' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Worlds'! - -!classDefinition: #DropFilesAction category: #'Morphic-Worlds'! -Object subclass: #DropFilesAction - instanceVariableNames: 'dropFilesEvent selectedFileEntry shouldAskToStop stopHereBlock' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Worlds'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3563-DropFileEnhancements-HernanWilkinson-2018Dec28-17h36m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3562] on 29 December 2018 at 11:34:36 am'! -!SystemDictionary methodsFor: 'testing' stamp: 'HAW 12/29/2018 11:34:08'! - isLiveTypingInstalled - - ^(FeatureRequirement name: #LiveTyping) isAlreadySatisfied! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 12/29/2018 11:34:08' prior: 50423940! - returnTypeOfEnclosedExpressionAt: aRange - - Smalltalk isLiveTypingInstalled ifFalse: [ ^nil ]. - - ^self - withParserSourceMethodNodeDo: [ :methodNode | self returnTypeOfEnclosedExpresionIn: methodNode at: aRange end ] - ifError: [ :anError | nil ]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 12/29/2018 11:34:08' prior: 50423951! - returnTypeOfUnaryMessage: aSelector at: aRange - - Smalltalk isLiveTypingInstalled ifFalse: [ ^nil ]. - - ^self - withParserSourceMethodNodeDo: [ :methodNode | self returnTypeOfNodeUnderCursorIn: methodNode at: aRange end] - ifError: [ :anError | nil ]! ! - -SystemDictionary removeSelector: #isLiveTypeInformationInstalled! - -SystemDictionary removeSelector: #isLiveTypeInformationInstalled! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3564-LiveTyping-Enhancements-HernanWilkinson-2018Dec29-11h17m-HAW.1.cs.st----! - -----SNAPSHOT----#(1 January 2019 8:25:44.949058 pm) Cuis5.0-3564-v3.image priorSource: 2972043! - -----QUIT----#(1 January 2019 8:26:18.1987 pm) Cuis5.0-3564-v3.image priorSource: 3064981! - -----STARTUP----#(28 January 2019 10:38:59.056154 am) as /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/Cuis5.0-3564-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3562] on 8 January 2019 at 4:25:22 pm'! -!Parser methodsFor: 'scanning' stamp: 'HAW 1/8/2019 16:24:45'! - compensateTwoCharacterLookahead - - ^source position - (aheadChar == self doItCharacter ifTrue: [hereChar == self doItCharacter ifTrue: [0] ifFalse: [1]] ifFalse: [2]) - ! ! -!Scanner methodsFor: 'expression types' stamp: 'HAW 1/8/2019 16:21:59' prior: 50410005! - scanAllTokenPositionsInto: aBlock - "Evaluate aBlock with the start and end positions of all separate non-white-space tokens, including comments." - - | lastMark | - lastMark := 1. - [currentComment ifNotNil: - [currentComment do: - [:cmnt| | idx | - idx := source originalContents indexOfSubCollection: cmnt startingAt: lastMark. - (idx > 0 and: [idx < mark]) ifTrue: - [aBlock value: idx - 1 value: (lastMark := idx + cmnt size)]]. - currentComment := nil]. - mark ifNotNil: - [(token == #- - and: [(self typeTableAt: hereChar) == #xDigit]) ifTrue: - [| savedMark | - savedMark := mark. - self scanToken. - token := token negated. - mark := savedMark]. - "Compensate for the fact that the parser uses two character lookahead. Normally we must - remove the extra two characters. But this mustn't happen for the last token at the end of stream." - aBlock - value: mark - value: (source position - (aheadChar == self doItCharacter ifTrue: [hereChar == self doItCharacter ifTrue: [0] ifFalse: [1]] ifFalse: [2]))]. - (tokenType == #rightParenthesis - or: [tokenType == #doIt]) ifTrue: - [^self]. - tokenType == #leftParenthesis - ifTrue: - [self scanToken; scanAllTokenPositionsInto: aBlock] - ifFalse: - [(tokenType == #word or: [tokenType == #keyword or: [tokenType == #colon]]) - ifTrue: - [self scanLitWord. - token == #true ifTrue: [token := true]. - token == #false ifTrue: [token := false]. - token == #nil ifTrue: [token := nil]] - ifFalse: - [(token == #- - and: [(self typeTableAt: hereChar) == #xDigit]) - ifTrue: - [self scanToken. - token := token negated]]]. - self scanToken ] repeat! ! -!Parser methodsFor: 'scanning' stamp: 'HAW 1/8/2019 16:21:24' prior: 50410209! - advance - | this | - prevMark := hereMark. - prevEnd := hereEnd. - this := here. - here := token. - hereType := tokenType. - hereMark := mark. - hereEnd := source position - (aheadChar == self doItCharacter ifTrue: [hereChar == self doItCharacter ifTrue: [0] ifFalse: [1]] ifFalse: [2]). - self scanToken. - "Transcript show: 'here: ', here printString, ' mark: ', hereMark printString, ' end: ', hereEnd printString; cr." - ^this! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3565-ParserFix-HernanWilkinson-2019Jan08-11h39m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3562] on 8 January 2019 at 4:27:21 pm'! -!Scanner methodsFor: 'expression types' stamp: 'HAW 1/8/2019 16:26:05' prior: 50427453! - scanAllTokenPositionsInto: aBlock - "Evaluate aBlock with the start and end positions of all separate non-white-space tokens, including comments." - - | lastMark | - lastMark := 1. - [currentComment ifNotNil: - [currentComment do: - [:cmnt| | idx | - idx := source originalContents indexOfSubCollection: cmnt startingAt: lastMark. - (idx > 0 and: [idx < mark]) ifTrue: - [aBlock value: idx - 1 value: (lastMark := idx + cmnt size)]]. - currentComment := nil]. - mark ifNotNil: - [(token == #- - and: [(self typeTableAt: hereChar) == #xDigit]) ifTrue: - [| savedMark | - savedMark := mark. - self scanToken. - token := token negated. - mark := savedMark]. - "Compensate for the fact that the parser uses two character lookahead. Normally we must - remove the extra two characters. But this mustn't happen for the last token at the end of stream." - aBlock - value: mark - value: self compensateTwoCharacterLookahead ]. - (tokenType == #rightParenthesis - or: [tokenType == #doIt]) ifTrue: - [^self]. - tokenType == #leftParenthesis - ifTrue: - [self scanToken; scanAllTokenPositionsInto: aBlock] - ifFalse: - [(tokenType == #word or: [tokenType == #keyword or: [tokenType == #colon]]) - ifTrue: - [self scanLitWord. - token == #true ifTrue: [token := true]. - token == #false ifTrue: [token := false]. - token == #nil ifTrue: [token := nil]] - ifFalse: - [(token == #- - and: [(self typeTableAt: hereChar) == #xDigit]) - ifTrue: - [self scanToken. - token := token negated]]]. - self scanToken ] repeat! ! -!Parser methodsFor: 'scanning' stamp: 'HAW 1/8/2019 16:25:50' prior: 50427508! - advance - | this | - prevMark := hereMark. - prevEnd := hereEnd. - this := here. - here := token. - hereType := tokenType. - hereMark := mark. - hereEnd := self compensateTwoCharacterLookahead. - self scanToken. - "Transcript show: 'here: ', here printString, ' mark: ', hereMark printString, ' end: ', hereEnd printString; cr." - ^this! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3566-ParserFix-HernanWilkinson-2019Jan08-16h25m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3562] on 2 January 2019 at 7:08:02 pm'! -!FileList methodsFor: 'own services' stamp: 'HAW 1/2/2019 19:06:52' prior: 50427150! - serviceGetHex - - ^ SimpleServiceEntry - provider: self - label: 'view as hex' - selector: #getHex - description: 'view as hex' - icon: #preferencesDesktopFontIcon! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3567-HexFileListIcon-HernanWilkinson-2018Dec29-11h34m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3562] on 7 January 2019 at 4:06:33 pm'! -!CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'HAW 1/3/2019 07:04:14'! - removeProperties - - self penultimateLiteral: self selector! ! -!CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'HAW 1/3/2019 07:06:51'! - withPropertiesDo: withBlock - - ^self withPropertiesDo: withBlock ifSelector: [ :selector | nil ]! ! -!CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'HAW 1/3/2019 07:03:13'! -withPropertiesDo: withBlock ifSelector: notBlock - - | penultimalLiteral | - - penultimalLiteral := self penultimateLiteral. - - ^penultimalLiteral isMethodProperties - ifTrue: [ withBlock value: penultimalLiteral ] - ifFalse: [ notBlock value: penultimalLiteral ]! ! -!CompiledMethod methodsFor: 'accessing' stamp: 'HAW 1/3/2019 07:03:14' prior: 16819533! - properties - - "Answer the method properties of the receiver." - - ^self - withPropertiesDo: [ :properties | properties ] - ifSelector: [ :selector | AdditionalMethodState forMethod: self selector: selector ]! ! -!CompiledMethod methodsFor: 'accessing' stamp: 'HAW 1/7/2019 15:49:22' prior: 16819588! - selector - "Answer a method's selector. This is either the penultimate literal, - or, if the method has any properties or pragmas, the selector of - the MethodProperties stored in the penultimate literal." - - ^self - withPropertiesDo: [ :properties | properties selector ] - ifSelector: [ :selector | selector ] -! ! -!CompiledMethod methodsFor: 'accessing' stamp: 'HAW 1/7/2019 15:56:36' prior: 16819602! - selector: aSelector - "Set a method's selector. This is either the penultimate literal, - or, if the method has any properties or pragmas, the selector of - the MethodProperties stored in the penultimate literal." - - | numberOfLiterals | - - self - withPropertiesDo: [ :properties | properties selector: aSelector ] - ifSelector: [ :selector | - (numberOfLiterals := self numLiterals) < 2 ifTrue: [self error: 'insufficient literals to hold selector']. - self literalAt: numberOfLiterals - 1 put: aSelector]! ! -!CompiledMethod methodsFor: 'literals' stamp: 'HAW 1/3/2019 07:06:51' prior: 16820025! - hasLiteralSuchThat: litBlock - "Answer true if litBlock returns true for any literal in this method, even if embedded in array structure." - - | lit | - - self withPropertiesDo: [ :properties | (properties hasLiteralSuchThat: litBlock) ifTrue: [ ^true ]]. - - 2 to: self numLiterals + 1 do: [ :index | - lit := self objectAt: index. - ((litBlock value: lit) - or: [lit isArray and: [lit hasLiteralSuchThat: litBlock]]) ifTrue: - [^true]]. - ^false! ! -!CompiledMethod methodsFor: 'literals' stamp: 'HAW 1/3/2019 07:06:51' prior: 16820042! - hasLiteralThorough: literal - "Answer true if any literal in this method is literal, - even if embedded in array structure." - - | lit | - - self withPropertiesDo: [ :properties | (properties hasLiteralThorough: literal) ifTrue:[^true]]. - - 2 to: self numLiterals - 1 "exclude superclass + selector/properties" - do: [ :index | - (((lit := self objectAt: index) literalEqual: literal) - or: [(lit isVariableBinding and: [lit key == literal]) - or: [lit isArray and: [lit hasLiteral: literal]]]) ifTrue: - [^ true]]. - ^ false ! ! -!CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'HAW 1/3/2019 07:03:14' prior: 16820939! - pragmaAt: aKey - - "Answer the pragma with selector aKey, or nil if none." - - ^self withPropertiesDo: [ :properties | properties at: aKey ifAbsent: nil ] ifSelector: [ :selector | nil ]. - ! ! -!CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'HAW 1/3/2019 07:03:14' prior: 16820950! - pragmas - - ^self withPropertiesDo: [ :properties | properties pragmas ] ifSelector: [ :selector | #() ]! ! -!CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'HAW 1/3/2019 07:18:59' prior: 16820959! - propertyKeysAndValuesDo: aBlock - - "Enumerate the receiver with all the keys and values." - - self withPropertiesDo: [ :properties | properties propertyKeysAndValuesDo: aBlock]! ! -!CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'HAW 1/3/2019 16:57:04' prior: 16820970! - propertyValueAt: propName - - ^self withPropertiesDo: [ :properties | properties propertyValueAt: propName ifAbsent: nil] ! ! -!CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'HAW 1/3/2019 17:01:07' prior: 16820980! - propertyValueAt: propName ifAbsent: aBlock - - ^self withPropertiesDo: [ :properties | properties propertyValueAt: propName ifAbsent: aBlock ] ifSelector: [ :selector | aBlock value ] - ! ! -!CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'HAW 1/7/2019 15:45:43' prior: 16820991! - propertyValueAt: propName put: propValue - "Set or add the property with key propName and value propValue. - If the receiver does not yet have a method properties create one and replace - the selector with it. Otherwise, either relace propValue in the method properties - or replace method properties with one containing the new property." - - self - withPropertiesDo: [:properties | - (properties includesProperty: propName) ifTrue: [^properties at: propName put: propValue]. - self penultimateLiteral: (properties - copyWith: (Association - key: propName asSymbol - value: propValue)). - ^propValue ] - ifSelector: [ :selector | - self penultimateLiteral: ((AdditionalMethodState - selector: selector - with: (Association - key: propName asSymbol - value: propValue)) - setMethod: self; - yourself). - ^propValue].! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3568-CompiledMethodPropertiesCleanup-HernanWilkinson-2019Jan02-19h08m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3562] on 7 January 2019 at 4:23:57 pm'! -!ClassBuilder methodsFor: 'validation' stamp: 'HAW 1/7/2019 16:20:34'! - doesClassNameStartWithUppercase: aClassName - - ^ aClassName first isUppercase! ! -!ClassBuilder methodsFor: 'validation' stamp: 'HAW 1/7/2019 16:20:34' prior: 16803747! - validateClassName: aString - "Validate the new class name" - - (self doesClassNameStartWithUppercase: aString) ifFalse:[ - self error: 'Class names must be capitalized'. - ^false]. - Smalltalk at: aString ifPresent:[:old| - (old isKindOf: Behavior) ifFalse:[ - self notify: aString asText allBold, - ' already exists!!\Proceed will store over it.' withNewLines]]. - ^true! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3569-Tweak-HernanWilkinson-2019Jan07-16h06m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3569] on 8 January 2019 at 5:28:27 pm'! -!ProcessBrowser class methodsFor: 'process control' stamp: 'jmv 1/8/2019 17:27:55' prior: 16895117! - rulesFor: aProcess - "Answer two flags: allow-stop, and allow-debug" - - "Don't mess with the process running the ProcessBrowser. - If we support several active UIs, we'd detect the UI process running us" - self flag: #jmvVer2. - aProcess == Processor activeProcess - ifTrue: [^{false. false}]. - - aProcess name = 'Sound Player' - ifTrue: [ ^{false. false}]. - - ^ [aProcess caseOf: { - [] -> [{false. false}]. - [Smalltalk lowSpaceWatcherProcess] -> [{false. false}]. - [WeakArray runningFinalizationProcess] -> [{false. false}]. - [Processor activeProcess] -> [{false. true}]. - [Processor backgroundProcess] -> [{false. false}]. - [Sensor interruptWatcherProcess] -> [{false. false}]. - [Sensor eventTicklerProcess] -> [{false. false}]. - [CPUWatcher currentWatcherProcess] -> [{false. false}]. - [Delay timerProcess] -> [{false. false}]} - otherwise: [ {true. true}]] - ifError: [ :err :rcvr | {true. true}]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3570-rulesForFix-JuanVuletich-2019Jan08-17h27m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3562] on 7 January 2019 at 10:46:01 pm'! -!ClassBuilder class methodsFor: 'accessing' stamp: 'HAW 1/7/2019 22:32:41'! - reservedNames - - "Return a list of names that must not be used for variables" - - ^#(#self #super #true #false #nil #thisContext)! ! -!ClassBuilder methodsFor: 'private' stamp: 'HAW 1/7/2019 22:32:29' prior: 50368678! - reservedNames - - "Return a list of names that must not be used for variables" - - ^self class reservedNames ! ! -!Theme methodsFor: 'private - shout mappings' stamp: 'HAW 1/7/2019 22:33:06' prior: 16935932! - pseudoVariables - - ^ ClassBuilder reservedNames ! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3571-ClassBuilderCleanup-HernanWilkinson-2019Jan07-17h05m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3562] on 8 January 2019 at 5:05:17 pm'! - -Object subclass: #Scanner - instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable isForTokenization sentInLiterals ignoreBacktick ' - classVariableNames: 'TypeTable DoItCharacter ' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #Scanner category: #'Compiler-Kernel'! -Object subclass: #Scanner - instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable isForTokenization sentInLiterals ignoreBacktick' - classVariableNames: 'DoItCharacter TypeTable' - poolDictionaries: '' - category: 'Compiler-Kernel'! -!Scanner class methodsFor: 'class initialization' stamp: 'HAW 1/8/2019 17:02:07'! - initializeDoitCharacter - - DoItCharacter := self doItCharacterValue asCharacter ! ! -!Scanner class methodsFor: 'class initialization' stamp: 'HAW 1/8/2019 17:01:11' prior: 16904320! - initialize - " - Scanner initialize - " - self initTypeTable. - self initializeDoitCharacter! ! - -Object subclass: #Scanner - instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable isForTokenization sentInLiterals ignoreBacktick' - classVariableNames: 'DoItCharacter TypeTable' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #Scanner category: #'Compiler-Kernel'! -Object subclass: #Scanner - instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable isForTokenization sentInLiterals ignoreBacktick' - classVariableNames: 'DoItCharacter TypeTable' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -Scanner initialize! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3572-SlightParserSpeedup-HernanWilkinson-2019Jan08-16h27m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3562] on 8 January 2019 at 5:13:05 pm'! -!Scanner methodsFor: 'expression types' stamp: 'HAW 1/8/2019 17:08:16' prior: 50410061! - step - - | c | - c := hereChar. - hereChar := aheadChar. - source atEnd - ifTrue: [aheadChar := DoItCharacter "doit"] - ifFalse: [aheadChar := source next]. - ^c! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'HAW 1/8/2019 17:08:09' prior: 50410238! - readUpToNext: aChar ifNotFound: aNotFoundBlock - - self step. - buffer reset. - - [self isAt: aChar] - whileFalse: - [buffer nextPut: self step. - (hereChar == DoItCharacter and: [source atEnd]) ifTrue: [^aNotFoundBlock value ]]. - - self step. - token := buffer contents. - ! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'HAW 1/8/2019 17:10:01' prior: 50410080! - xDigit - "Form a number." - - tokenType := #number. - (aheadChar == DoItCharacter and: [source atEnd - and: [source skip: -1. source next ~~ DoItCharacter]]) - ifTrue: [source skip: -1 "Read off the end last time"] - ifFalse: [source skip: -2]. - token := [Number readFrom: source] ifError: [:err :rcvr | self offEnd: err]. - self step; step! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'HAW 1/8/2019 17:10:14' prior: 50410094! - xDoubleQuote - "Collect a comment." - "wod 1/10/98: Allow 'empty' comments by testing the first character -for $"" rather than blindly adding it to the comment being collected." - | aStream stopChar | - stopChar := DoItCharacter. - aStream := WriteStream on: (String new: 200). - self step. - [hereChar == $"] - whileFalse: - [(hereChar == stopChar and: [source atEnd]) - ifTrue: [^self offEnd: 'Unmatched comment quote']. - aStream nextPut: self step.]. - self step. - currentComment == nil - ifTrue: [currentComment := OrderedCollection with: aStream contents] - ifFalse: [currentComment add: aStream contents]. - self scanToken! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'HAW 1/8/2019 17:10:25' prior: 50410120! - xLetter - "Form a word or keyword." - - | type | - buffer reset. - [(type := self typeTableAt: hereChar) == #xLetter - or: [type == #xDigit - or: [type == #xUnderscore]]] whileTrue: - ["open code step for speed" - buffer nextPut: hereChar. - hereChar := aheadChar. - aheadChar := source atEnd - ifTrue: [DoItCharacter "doit"] - ifFalse: [source next]]. - tokenType := (type == #colon or: [type == #xColon and: [aheadChar ~~ $=]]) - ifTrue: - [buffer nextPut: self step. - "Allow any number of embedded colons in literal symbols" - [(self typeTableAt: hereChar) == #xColon] whileTrue: - [buffer nextPut: self step]. - #keyword] - ifFalse: - [#word]. - token := buffer contents! ! -!Parser methodsFor: 'scanning' stamp: 'HAW 1/8/2019 17:07:55' prior: 50427444! - compensateTwoCharacterLookahead - - ^source position - (aheadChar == DoItCharacter ifTrue: [hereChar == DoItCharacter ifTrue: [0] ifFalse: [1]] ifFalse: [2]) - ! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3573-SlightParserSpeedup-HernanWilkinson-2019Jan08-17h05m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3562] on 8 January 2019 at 5:37:28 pm'! - -Scanner removeSelector: #doItCharacter! - -Scanner removeSelector: #doItCharacter! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3574-SlightParserSpeedup-HernanWilkinson-2019Jan08-17h13m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3574] on 9 January 2019 at 12:29:29 pm'! -!TextEditor methodsFor: 'private' stamp: 'AY 1/2/2019 22:24:14'! - firstOfBeginningOfLineOrEndOfIndentationLeftOf: position - - "Returns the first of beginning-of-line or end-of-indentation that appears to the left of the given position, wrapping around to the end of the line (i.e. the line is considered circular). - This way, if the given position is beginning-of-line then end-of-indentation is returned." - - | currentLine beginningOfLine endOfIndentation stops | - - currentLine _ textComposition lines at: (textComposition lineIndexFor: position). - beginningOfLine _ currentLine first. - endOfIndentation _ self privateCurrentString - skipDelimiters: (String with: Character tab) - startingAt: beginningOfLine. - - stops _ OrderedCollection with: endOfIndentation with: beginningOfLine. - ^ stops detect: [ :stop | stop < position ] ifNone: [endOfIndentation]! ! -!Editor methodsFor: 'private' stamp: 'AY 1/9/2019 12:18:54' prior: 16836757! - beginningOfParagraph: position - | s | - s _ self privateCurrentString. - ^ (s - lastIndexOf: Character newLineCharacter - startingAt: (position-1 min: s size) - ifAbsent: [ 0 ]) - + 1.! ! -!TextEditor methodsFor: 'nonediting/nontyping keys' stamp: 'AY 1/9/2019 12:29:03' prior: 16932328! - cursorEnd: aKeyboardEvent - - "Private - Move cursor end of current line." - - self - moveCursor: [ :position | - "Mac standard keystrole" - (aKeyboardEvent commandAltKeyPressed or: [ - "Windows / Linux standard keystroke" - aKeyboardEvent controlKeyPressed ]) - ifTrue: [ self endOfText ] - ifFalse: [ self endOfLine: position ]] - forward: true - event: aKeyboardEvent. - ^true! ! -!TextEditor methodsFor: 'nonediting/nontyping keys' stamp: 'AY 1/9/2019 12:28:01' prior: 16932347! - cursorHome: aKeyboardEvent - - "Private - Move cursor from position in current line to beginning of current line or end of indentation (see #firstOfBeginningOfLineOrEndOfIndentationLeftOf:). - If control key is pressed put cursor at beginning of text" - - self - moveCursor: [ :position | - "Mac standard keystrole" - (aKeyboardEvent commandAltKeyPressed or: [ - "Windows / Linux standard keystroke" - aKeyboardEvent controlKeyPressed ]) - ifTrue: [ self beginningOfText ] - ifFalse: [ self firstOfBeginningOfLineOrEndOfIndentationLeftOf: position ]] - forward: false - event: aKeyboardEvent. - ^true! ! -!TextEditor methodsFor: 'private' stamp: 'jmv 1/9/2019 12:27:48' prior: 16932811! - sameColumn: start newLine: lineBlock forward: isForward - "Private - Compute the index in my text - with the line number derived from lineBlock," - " a one argument block accepting the old line number. - The position inside the line will be preserved as good as possible" - "The boolean isForward is used in the border case to determine if - we should move to the beginning or the end of the line." - | column currentLine offsetAtTargetLine targetEOL lines numberOfLines currentLineNumber targetLineNumber | - lines _ textComposition lines. - numberOfLines _ textComposition numberOfLines. - currentLineNumber _ textComposition lineIndexFor: start. - currentLine _ lines at: currentLineNumber. - column _ start - currentLine first. - targetLineNumber _ ((lineBlock value: currentLineNumber) max: 1) min: numberOfLines. - offsetAtTargetLine _ (lines at: targetLineNumber) first. - targetEOL _ (lines at: targetLineNumber) last + (targetLineNumber = numberOfLines ifTrue:[1]ifFalse:[0]). - targetLineNumber = currentLineNumber - "No movement or movement failed. Move to beginning or end of line." - ifTrue:[ - ^isForward - ifTrue:[targetEOL] - ifFalse:[offsetAtTargetLine]]. - ^offsetAtTargetLine + column min: targetEOL.! ! - -Preferences class removeSelector: #wordStyleCursorMovement! - -Preferences class removeSelector: #wordStyleCursorMovement! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3575-CursorHomeEnh-AngelYan-JuanVuletich-2019Jan09-12h09m-AY.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3575] on 11 January 2019 at 4:57:40 pm'! - -Error subclass: #AttemptToMutateObjectInCallStack - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #AttemptToMutateObjectInCallStack category: #'Exceptions Kernel'! -Error subclass: #AttemptToMutateObjectInCallStack - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! -!AttemptToMutateObjectInCallStack commentStamp: '' prior: 0! - A become operation tries to mutate an object that is the receiver ('self') in a method currently in execution, and part of the stack of calls of some process.! -!ProcessorScheduler methodsFor: 'accessing' stamp: 'jmv 1/11/2019 11:08:09'! - anyReceiverInStackIn: anArray - "Iterate over all methods currently in execution. Answer true if in any of them 'self' an element of argument" - " - Processor anyReceiverInStackIn: { self runningWorld } - Processor anyReceiverInStackIn: { Object new } - " - self processesDo: [ :p | ] withStackFramestDo: [ :p :c | - (anArray statePointsTo: c receiver) - ifTrue: [ ^ true ]]. - ^ false! ! -!ProcessorScheduler methodsFor: 'accessing' stamp: 'jmv 1/11/2019 11:11:48'! - anyReceiverInStackIn: anArray orIn: anotherArray - "Iterate over all methods currently in execution. Answer true if in any of them 'self' an element of argument" - " - Processor anyReceiverInStackIn: {} orIn: { self runningWorld } - Processor anyReceiverInStackIn: {} orIn: { Object new } - " - self processesDo: [ :p | ] withStackFramestDo: [ :p :c | | r | - r _ c receiver. - (anArray statePointsTo: r) - ifTrue: [ ^ true ]. - (anotherArray statePointsTo: r) - ifTrue: [ ^ true ]]. - ^ false! ! -!ProcessorScheduler methodsFor: 'accessing' stamp: 'jmv 1/9/2019 16:02:19'! - anyReceiverInStackIsKindOf: aClass - "Iterate over all methods currently in execution. Answer true if in any of them 'self' is a (sub)instance of aClass" - " - Processor anyReceiverInStackIsKindOf: Morph - Processor anyReceiverInStackIsKindOf: DifferenceFinder - " - self processesDo: [ :p | ] withStackFramestDo: [ :p :c | - (c receiver isKindOf: aClass) - ifTrue: [ ^ true ]]. - ^ false! ! -!ProcessorScheduler methodsFor: 'accessing' stamp: 'jmv 1/9/2019 15:54:20'! - processesDo: aBlock - "Iterate over processes that can run" - " - Processor processesDo: [ :p | p print ]. - " - Process allSubInstancesDo: [ :p | - p isTerminated ifFalse: [ - aBlock value: p ]]! ! -!ProcessorScheduler methodsFor: 'accessing' stamp: 'jmv 1/9/2019 15:59:16'! - processesDo: aBlock withStackFramestDo: twoArgBlock - "Iterate over processes that can run. - For each process, iterate over stack frames (i.e. contexts)." - " - Processor - processesDo: [ :p | - '--------------' print. - p print. - '--------------' print ] - withStackFramestDo: [ :p :c | - (' ', c printString) print ]. - " - self processesWithTopContextDo: [ :process :topContext | | context | - aBlock value: process. - context _ topContext. - [ context notNil ] whileTrue: [ - twoArgBlock value: process value: context. - context _ context sender ]]! ! -!ProcessorScheduler methodsFor: 'accessing' stamp: 'jmv 1/9/2019 15:54:54'! - processesWithTopContextDo: aBlock - "Iterate over processes that can run. Include top context in block arguments." - " - Processor processesWithTopContextDo: [ :p :c | p print. ('------->', c printString) print ]. - " - self processesDo: [ :process | - aBlock - value: process - value: (process isRunning ifTrue: [ thisContext ] ifFalse: [ process suspendedContext ]) ]! ! -!ProtoObject methodsFor: 'system primitives' stamp: 'jmv 1/11/2019 16:52:15' prior: 16896514! - become: otherObject - "Primitive. Swap the object pointers of the receiver and the argument. - All variables in the entire system that used to point to the - receiver now point to the argument, and vice-versa. - Fails if either object is a SmallInteger" - - | oldObjects newObjects | - oldObjects _ { self }. - newObjects _ { otherObject }. - self class == otherObject class ifFalse: [ - (Processor anyReceiverInStackIn: oldObjects orIn: newObjects) ifTrue: [ - AttemptToMutateObjectInCallStack - signal: 'Can not do #become: Either receiver or argument has some method currently in execution.']]. - oldObjects elementsExchangeIdentityWith: newObjects! ! -!Object methodsFor: 'system primitives' stamp: 'jmv 1/11/2019 16:52:24' prior: 16882299! - becomeForward: otherObject - "Primitive. All variables in the entire system that used to point - to the receiver now point to the argument. - Fails if either argument is a SmallInteger." - - | oldObjects | - oldObjects _ { self }. - self class == otherObject class ifFalse: [ - (Processor anyReceiverInStackIn: oldObjects) ifTrue: [ - AttemptToMutateObjectInCallStack - signal: 'Can not do #become: Receiver has some method currently in execution.']]. - oldObjects elementsForwardIdentityTo: { otherObject }! ! -!Object methodsFor: 'system primitives' stamp: 'jmv 1/11/2019 16:52:33' prior: 16882310! - becomeForward: otherObject copyHash: copyHash - "Primitive. All variables in the entire system that used to point to the receiver now point to the argument. - If copyHash is true, the argument's identity hash bits will be set to those of the receiver. - Fails if either argument is a SmallInteger." - - | oldObjects | - oldObjects _ { self }. - self class == otherObject class ifFalse: [ - (Processor anyReceiverInStackIn: oldObjects) ifTrue: [ - AttemptToMutateObjectInCallStack - signal: 'Can not do #become: Receiver has some method currently in execution.']]. - oldObjects - elementsForwardIdentityTo: { otherObject } - copyHash: copyHash! ! -!Behavior methodsFor: 'private' stamp: 'jmv 1/11/2019 11:39:10' prior: 16784728! - becomeCompact - "Here are the restrictions on compact classes in order for export segments to work: A compact class index may not be reused. If a class was compact in a release of Squeak, no other class may use that index. The class might not be compact later, and there should be nil in its place in the array." - | cct index | - - Smalltalk isSpur ifTrue: [ ^ self halt: 'No Compact Classes support in Spur' ]. - self isWeak ifTrue:[ ^ self halt: 'You must not make a weak class compact' ]. - (Processor anyReceiverInStackIsKindOf: self) - ifTrue: [ ^self halt: self name, ' has some (sub)instance with some method currently in execution.' ]. - cct _ Smalltalk compactClassesArray. - (self indexIfCompact > 0 or: [cct includes: self]) - ifTrue: [^ self halt: self name, ' is already compact']. - index _ cct indexOf: nil - ifAbsent: [^ self halt: 'compact class table is full']. - "Install this class in the compact class table" - cct at: index put: self. - "Update instspec so future instances will be compact" - format _ format + (index bitShift: 11). - "Make up new instances and become old ones into them" - self updateInstancesFrom: self. - "Purge any old instances" - Smalltalk garbageCollect.! ! -!Behavior methodsFor: 'private' stamp: 'jmv 1/11/2019 11:39:04' prior: 16784797! - becomeUncompact - | cct index | - cct _ Smalltalk compactClassesArray. - (index _ self indexIfCompact) = 0 - ifTrue: [^ self]. - (Processor anyReceiverInStackIsKindOf: self) - ifTrue: [ ^self halt: self name, ' has some (sub)instance with some method currently in execution.' ]. - (cct includes: self) - ifFalse: [^ self halt "inconsistent state"]. - "Update instspec so future instances will not be compact" - format _ format - (index bitShift: 11). - "Make up new instances and become old ones into them" - self updateInstancesFrom: self. - "Make sure there are no compact ones left around" - Smalltalk garbageCollect. - "Remove this class from the compact class table" - cct at: index put: nil. -! ! -!ClassBuilder methodsFor: 'class definition' stamp: 'jmv 1/11/2019 16:55:48' prior: 16803207! - class: oldClass instanceVariableNames: instVarString unsafe: unsafe - "This is the basic initialization message to change the definition of - an existing Metaclass" - | instVars newClass needNew copyOfOldClass | - instVars _ Scanner new scanFieldNames: instVarString. - unsafe ifFalse:[ - "Run validation checks so we know that we have a good chance for recompilation" - (self validateInstvars: instVars from: oldClass forSuper: oldClass superclass) ifFalse:[^nil]. - (self validateSubclassFormat: oldClass typeOfClass from: oldClass forSuper: oldClass superclass extra: instVars size) ifFalse:[^nil]. - (Processor anyReceiverInStackIsKindOf: oldClass) ifTrue: [ - AttemptToMutateObjectInCallStack - signal: oldClass name, ' has some (sub)instance with some method currently in execution.'. ^nil ]]. - "See if we need a new subclass or not" - needNew _ self needsSubclassOf: oldClass superclass type: oldClass typeOfClass instanceVariables: instVars from: oldClass. - needNew ifNil:[^nil]. "some error" - needNew ifFalse:[^oldClass]. "no new class needed" - - "Create the new class" - copyOfOldClass _ oldClass copy. - newClass _ self - newSubclassOf: oldClass superclass - type: oldClass typeOfClass - instanceVariables: instVars - from: oldClass. - - newClass _ self recompile: false from: oldClass to: newClass mutate: false. - self doneCompiling: newClass. - SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass. - ^newClass! ! -!ClassBuilder methodsFor: 'class definition' stamp: 'jmv 1/11/2019 16:56:13' prior: 16803265! - name: className subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category unsafe: unsafe - "Define a new class. - If unsafe is true do not run any validation checks. - This facility is provided to implement important system changes." - | oldClass newClass organization instVars classVars force needNew oldCategory copyOfOldClass newCategory | - instVars _ Scanner new scanFieldNames: instVarString. - classVars _ (Scanner new scanFieldNames: classVarString) collect: [:x | x asSymbol]. - - "Validate the proposed name" - unsafe ifFalse:[(self validateClassName: className) ifFalse:[^nil]]. - oldClass _ Smalltalk at: className ifAbsent: nil. - oldClass isBehavior - ifFalse:[oldClass _ nil]. "Already checked in #validateClassName:" - copyOfOldClass _ oldClass copy. - - unsafe ifFalse:[ - "Run validation checks so we know that we have a good chance for recompilation" - (self validateSuperclass: newSuper forSubclass: oldClass) ifFalse:[^nil]. - (self validateInstvars: instVars from: oldClass forSuper: newSuper) ifFalse:[^nil]. - (self validateClassvars: classVars from: oldClass forSuper: newSuper) ifFalse:[^nil]. - (self validateSubclassFormat: type from: oldClass forSuper: newSuper extra: instVars size) ifFalse:[^nil]. - (Processor anyReceiverInStackIsKindOf: oldClass) ifTrue: [ - AttemptToMutateObjectInCallStack - signal: oldClass name, ' has some (sub)instance with some method currently in execution.'. ^nil ]]. - - "See if we need a new subclass" - needNew _ self needsSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass. - needNew ifNil: [^nil]. "some error" - - (needNew and:[unsafe not]) ifTrue:[ - "Make sure we don't redefine any dangerous classes" - (self tooDangerousClasses includes: oldClass name) ifTrue:[ - self error: oldClass name, ' cannot be changed'. - ]. - "Check if the receiver should not be redefined" - (oldClass notNil and:[oldClass shouldNotBeRedefined]) ifTrue:[ - self notify: oldClass name asText allBold, - ' should not be redefined!! \Proceed to store over it.' withNewLines]]. - - needNew ifTrue:[ - "Create the new class" - newClass _ self - newSubclassOf: newSuper - type: type - instanceVariables: instVars - from: oldClass. - newClass ifNil: [ ^nil]. "Some error" - newClass setName: className. - ] ifFalse:[ - "Reuse the old class" - newClass _ oldClass. - ]. - - "Install the class variables and pool dictionaries... " - force _ (newClass declare: classVarString) | (newClass sharing: poolString). - - "... classify ..." - newCategory _ category asSymbol. - organization _ Smalltalk organization. - oldClass ifNotNil: [oldCategory := (organization categoryOfElement: oldClass name) asSymbol]. - organization classify: newClass name under: newCategory. - - "... recompile ..." - newClass _ self recompile: force from: oldClass to: newClass mutate: false. - - "... export if not yet done ..." - (Smalltalk at: newClass name ifAbsent: nil) == newClass ifFalse:[ - [Smalltalk at: newClass name put: newClass] - on: AttemptToWriteReadOnlyGlobal do:[:ex| ex resume: true]. - Smalltalk flushClassNameCache. - ]. - - self doneCompiling: newClass. - - "... notify interested clients ..." - oldClass ifNil: [ - SystemChangeNotifier uniqueInstance classAdded: newClass inCategory: newCategory. - ^ newClass]. - SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass. - newCategory ~= oldCategory - ifTrue: [SystemChangeNotifier uniqueInstance classRecategorized: newClass from: oldCategory to: category]. - ^newClass! ! -!ClassBuilder methodsFor: 'class definition' stamp: 'jmv 1/11/2019 11:58:48' prior: 16803437! - recompile: force from: oldClass to: newClass mutate: forceMutation - "Do the necessary recompilation after changing oldClass to newClass. - If required (e.g., when oldClass ~~ newClass) mutate oldClass to newClass - and all its subclasses. If forceMutation is true force a mutation even - if oldClass and newClass are the same." - - oldClass - ifNil: [^ newClass]. - - (newClass == oldClass and:[force not and:[forceMutation not]]) ifTrue:[ - ^newClass]. - - currentClassIndex _ 0. - maxClassIndex _ oldClass withAllSubclasses size. - - (oldClass == newClass and:[forceMutation not]) ifTrue:[ - "Recompile from newClass without mutating" - self informUserDuring:[ - newClass withAllSubclassesDo:[:cl| - self showProgressFor: cl. - cl compileAll]]. - ^newClass]. - "Recompile and mutate oldClass to newClass" - self informUserDuring:[ - self mutate: oldClass to: newClass. - ]. - ^oldClass "now mutated to newClass"! ! -!ClassBuilder methodsFor: 'public' stamp: 'jmv 1/11/2019 16:56:52' prior: 16804069! - moveInstVarNamed: instVarName from: srcClass to: dstClass after: prevInstVarName - "Move the given instVar from srcClass to dstClass" - | instancesOk | - (srcClass instVarNames includes: instVarName) - ifFalse:[^self error: instVarName,' is not an instance variable of ', srcClass name]. - (prevInstVarName isNil or:[dstClass instVarNames includes: prevInstVarName]) - ifFalse:[^self error: prevInstVarName, 'is not an instance variable of', dstClass name]. - instancesOk _ false. - (srcClass inheritsFrom: dstClass) ifTrue:[ - "Move the instvar up the hierarchy." - (Processor anyReceiverInStackIsKindOf: dstClass) ifTrue: [ - AttemptToMutateObjectInCallStack - signal: dstClass name, ' has some (sub)instance with some method currently in execution.' ^false ]. - instancesOk _ true. - (self validateClass: srcClass forMoving: instVarName upTo: dstClass) - ifFalse:[^false]. - ]. - (dstClass inheritsFrom: srcClass) ifTrue:[ - "Move the instvar down the hierarchy" - (Processor anyReceiverInStackIsKindOf: srcClass) ifTrue: [ - AttemptToMutateObjectInCallStack - signal: srcClass name, ' has some (sub)instance with some method currently in execution.' ^false ]. - instancesOk _ true. - (self validateClass: srcClass forMoving: instVarName downTo: dstClass) - ifFalse:[^false]. - ]. - instancesOk ifFalse: [ "disjunt hierarchies" - (Processor anyReceiverInStackIsKindOf: dstClass) ifTrue: [ - AttemptToMutateObjectInCallStack - signal: dstClass name, ' has some (sub)instance with some method currently in execution.' ^false ]. - (Processor anyReceiverInStackIsKindOf: srcClass) ifTrue: [ - AttemptToMutateObjectInCallStack - signal: srcClass name, ' has some (sub)instance with some method currently in execution.' ^false ]]. - ^self silentlyMoveInstVarNamed: instVarName from: srcClass to: dstClass after: prevInstVarName! ! -!Array methodsFor: 'converting' stamp: 'jmv 1/11/2019 11:10:01' prior: 16779671! -elementsExchangeIdentityWith: otherArray - "This primitive performs a bulk mutation, causing all pointers to the elements of the - receiver 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. - - Warning. This is a dangerous operation and it could lead to a crash if some object in receiver or argument is receiver of a method currently in execution. See #anyReceiverInStackIn: See senders for examples." - - - ec == #'bad receiver' ifTrue: - [^self error: 'receiver must be of class Array']. - ec == #'bad argument' ifTrue: - [^self error: (otherArray class == Array - ifTrue: ['arg must be of class Array'] - ifFalse: ['receiver and argument must have the same size'])]. - ec == #'inappropriate operation' ifTrue: - [^self error: 'can''t become immediates such as SmallIntegers or Characters']. - ec == #'no modification' ifTrue: - [^self error: 'can''t become immutable objects']. - ec == #'object is pinned' ifTrue: - [^self error: 'can''t become pinned objects']. - ec == #'insufficient object memory' ifTrue: - [| maxRequired | - "In Spur, two-way become may involve making each pair of objects into a forwarder into a copy of the other. - So if become fails with #'insufficient object memory', garbage collect, and if necessary, grow memory." - maxRequired := (self detectSum: [:obj | obj class byteSizeOfInstanceOfSize: obj basicSize]) - + (otherArray detectSum: [:obj | obj class byteSizeOfInstanceOfSize: obj basicSize]). - (Smalltalk garbageCollectMost < maxRequired - and: [Smalltalk garbageCollect < maxRequired]) ifTrue: - [Smalltalk growMemoryByAtLeast: maxRequired]. - ^self elementsExchangeIdentityWith: otherArray]. - self primitiveFailed! ! -!Array methodsFor: 'converting' stamp: 'jmv 1/11/2019 11:09:50' prior: 16779730! - elementsForwardIdentityTo: otherArray - "This primitive performs a bulk mutation, causing all pointers to the elements of the - receiver 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. - - Warning. This is a dangerous operation and it could lead to a crash if some object in receiver or argument is receiver of a method currently in execution. See #anyReceiverInStackIn: See senders for examples." - - - ec == #'bad receiver' ifTrue: - [^self error: 'receiver must be of class Array']. - ec == #'bad argument' ifTrue: - [^self error: (otherArray class == Array - ifTrue: ['arg must be of class Array'] - ifFalse: ['receiver and argument must have the same size'])]. - ec == #'inappropriate operation' ifTrue: - [^self error: 'can''t become immediates such as SmallIntegers or Characters']. - ec == #'no modification' ifTrue: - [^self error: 'can''t become immutable objects']. - ec == #'object is pinned' ifTrue: - [^self error: 'can''t become pinned objects']. - ec == #'insufficient object memory' ifTrue: - [self error: 'The virtual machine is out-of-date. Please upgrade.']. - self primitiveFailed! ! -!Array methodsFor: 'converting' stamp: 'jmv 1/11/2019 11:09:40' prior: 16779768! - elementsForwardIdentityTo: otherArray copyHash: copyHash - "This primitive performs a bulk mutation, causing all pointers to the elements of the - receiver to be replaced by pointers to the corresponding elements of otherArray. - If copyHash is true, the identityHashes remain with the pointers rather than with the - objects so that the objects in the receiver should still be properly indexed in any - existing hashed structures after the mutation. If copyHash is false, then the hashes - of the objects in otherArray remain unchanged. If you know what you're doing this - may indeed be what you want. - - Warning. This is a dangerous operation and it could lead to a crash if some object in receiver or argument is receiver of a method currently in execution. See #anyReceiverInStackIn: See senders for examples." - - ec == #'bad receiver' ifTrue: - [^self error: 'receiver must be of class Array']. - ec == #'bad argument' ifTrue: - [^self error: (otherArray class == Array - ifTrue: ['arg must be of class Array'] - ifFalse: ['receiver and argument must have the same size'])]. - ec == #'inappropriate operation' ifTrue: - [^self error: 'can''t become immediates such as SmallIntegers or Characters']. - ec == #'no modification' ifTrue: - [^self error: 'can''t become immutable objects']. - ec == #'object is pinned' ifTrue: - [^self error: 'can''t become pinned objects']. - self primitiveFailed! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3576-dontBecomeObjectIfRunningSomeMethod-JuanVuletich-2019Jan11-16h49m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3576] on 14 January 2019 at 4:35:29 pm'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 1/14/2019 16:34:53' prior: 50424555! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('AY' 'Angel Yan') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('FGJ' 'Fernando Gasperi Jabalera') - #('FJG' 'Facundo Javier Gelatti') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('KLG' 'Gerald Klix') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! -!MessageNode methodsFor: 'equation translation' stamp: 'jmv 1/14/2019 16:15:00' prior: 16867989! - arguments: list - arguments := list asArray! ! -!MessageNode methodsFor: 'cascading' stamp: 'jmv 1/14/2019 16:14:02' prior: 16868573! - receiver: rcvr arguments: args precedence: p - - receiver := rcvr. - originalReceiver := rcvr copy. - arguments := args asArray. - originalArguments := arguments copy. - sizes := Array new: arguments size. - precedence := p! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3577-MessageNodeFix-JuanVuletich-2019Jan14-16h33m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3577] on 16 January 2019 at 8:40:56 am'! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'jmv 1/16/2019 08:38:06'! - allButFirstDo: block - - 2 to: self size do: - [:index | block value: (self at: index)]! ! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'jmv 1/16/2019 08:38:18'! - allButLastDo: block - - 1 to: self size - 1 do: - [:index | block value: (self at: index)]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3578-AddBack-allButFirstDo-allButLastDo-JuanVuletich-2019Jan16-08h38m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3564] on 16 January 2019 at 12:05:04 pm'! -!Preferences class methodsFor: 'code generation' stamp: 'KLG 1/16/2019 11:51:32'! - leftArrowAssignmentsInGeneratedCodeWithComputedDefault - ^ self - valueOfFlag: #leftArrowAssignmentsInGeneratedCode - ifAbsent: [ - self syntaxHighlightingAsYouTypeLeftArrowAssignment or: [ - self syntaxHighlightingAsYouTypeAnsiAssignment not ]].! ! -!Browser methodsFor: 'class functions' stamp: 'KLG 1/16/2019 11:52:48' prior: 16791579! - createInstVarAccessors - "Create getters and setters for all inst vars defined at the level of the current class selection, except do NOT clobber or override any selectors already understood by the instances of the selected class" - self selectedClassOrMetaClass ifNotNil: [ :aClass | - aClass instVarNames do: [ :aName | | newMessage setter | - (aClass canUnderstand: aName asSymbol) ifFalse: [ - newMessage _ aName , ' - "Answer the value of ' , aName , '" - - ^ ' , aName. - aClass - compile: newMessage - classified: 'accessing' - notifying: nil ]. - (aClass canUnderstand: (setter _ aName , ':') asSymbol) ifFalse: [ - newMessage _ setter , ' anObject - "Set the value of ' , aName , '" - - ' , aName , ' ' , - (Preferences leftArrowAssignmentsInGeneratedCodeWithComputedDefault - ifTrue: [ '_' ] - ifFalse: [ ':=' ]) , ' anObject'. - aClass - compile: newMessage - classified: 'accessing' - notifying: nil ]]]! ! -!Message methodsFor: 'stub creation' stamp: 'KLG 1/16/2019 11:51:59' prior: 50389604! - addSetterCodeOn: stream - - stream - newLine; tab; - nextPutAll: selector allButLast; - nextPutAll: (Preferences leftArrowAssignmentsInGeneratedCodeWithComputedDefault - ifTrue: [ ' _ ' ] - ifFalse: [ ' := ' ]); - nextPutAll: self arguments first argumentName ! ! -!Preferences class methodsFor: 'standard queries' stamp: 'KLG 1/16/2019 12:03:07'! - leftArrowAssignmentsInGeneratedCode - ^ self - valueOfFlag: #leftArrowAssignmentsInGeneratedCode - ifAbsent: [ false ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3579-CodeGenerationHonorsAssignmentPreferences-KLG-ConsistentAssignment-In-Generated-Code-KLG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3564] on 17 January 2019 at 7:00:11 pm'! -!CodePackage methodsFor: 'enumerating' stamp: 'KLG 1/17/2019 18:40:59'! - coreMethodsForFileinOf: aClass do: aBlock - "Evaluate aBlock with the actual method objects in this package. - Only enumerate those methods that might be needed for proper filein. - such as #compilerClass." - - aClass organization categories do: [ :cat | - (self isForeignClassExtension: cat) ifFalse: [ - (aClass organization listAtCategoryNamed: cat) do: [ :s | - (self selectorNeededForFilein: s) ifTrue: [ - aBlock value: (self referenceForMethod: s ofClass: aClass) ]]]]! ! -!CodePackage methodsFor: 'testing' stamp: 'KLG 1/17/2019 18:43:05'! - selectorNeededForFilein: aSelector - "Answer true if aSelector might be needed for proper filein of the remaing methods." - - ^ Metaclass isScarySelector: aSelector! ! -!CodePackage methodsFor: 'saving' stamp: 'KLG 1/17/2019 18:54:50'! - write: classes methodsForFileinOn: aStream - - classes - do: [ :class | - self - writeCoreMethodsForFileinOf: class class on: aStream; - writeCoreMethodsForFileinOf: class on: aStream ] - displayingProgress: 'Saving methods...'! ! -!CodePackage methodsFor: 'saving' stamp: 'KLG 1/17/2019 18:56:42'! - writeCoreMethodsForFileinOf: aClass on: aStream - - self coreMethodsForFileinOf: aClass do: [ :methodReference | - methodReference isValid - ifTrue: [ - self writeMethod: methodReference on: aStream ]]! ! -!CodePackage methodsFor: 'enumerating' stamp: 'KLG 1/17/2019 18:44:19' prior: 50377154! - coreMethodsOf: aClass do: aBlock - "Evaluate aBlock with the actual method objects in this package. - - Leave out all the methods needed for filein." - - aClass organization categories do: [ :cat | - (self isForeignClassExtension: cat) ifFalse: [ - (aClass organization listAtCategoryNamed: cat) do: [ :s | - (self selectorNeededForFilein: s) ifFalse: [ - aBlock value: (self referenceForMethod: s ofClass: aClass) ]]]]! ! -!CodePackage methodsFor: 'saving' stamp: 'KLG 1/17/2019 18:55:00' prior: 50377176! - write: classes methodsOn: aStream - - classes - do: [ :class | - self - writeCoreMethodsOf: class on: aStream; - writeCoreMethodsOf: class class on: aStream ] - displayingProgress: 'Saving methods...'! ! -!CodePackage methodsFor: 'saving' stamp: 'KLG 1/17/2019 18:56:15' prior: 50400998! - writeOnStream: aStream - - | sortedClasses | - aStream - nextChunkPut: ('Description ', description) printString; - newLine. - self writeFeatureSpecOn: aStream. - self writeSystemCategoriesOn: aStream. - - self codePackageClass ifNotNil: [ :codePackageClass | - self - write: {codePackageClass} classDefinitionsOn: aStream; - write: {codePackageClass} classCommentsOn: aStream; - write: {codePackageClass} methodsOn: aStream. - aStream nextChunkPut: codePackageClass name, ' prePackageInstall'; newLine ]. - - sortedClasses _ Array streamContents: [ :strm | - self classesInSafeOrderDo: [ :cls | - cls == self class ifFalse: [ - strm nextPut: cls ]]]. - self - write: sortedClasses classDefinitionsOn: aStream; - write: sortedClasses classCommentsOn: aStream; - write: sortedClasses methodsForFileinOn: aStream; - write: sortedClasses methodsOn: aStream. - - self - sortedExtensionMethodsDo: [ :methodReference | - methodReference isValid ifTrue: [ - self writeMethod: methodReference on: aStream ]] - displayingProgress: 'Saving extension methods...'. - self write: sortedClasses initializersOn: aStream. - - self codePackageClass ifNotNil: [ :codePackageClass | - self write: { codePackageClass } initializersOn: aStream. - aStream nextChunkPut: codePackageClass name, ' postPackageInstall'; newLine ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3580-ScarySelectorsFirstInPackages-KLG-fileout-methods-for-filein-first-2019Jan17-16h55m-KLG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3562] on 11 January 2019 at 12:22:25 pm'! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 1/9/2019 19:00:12' prior: 50424343! - computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel - - | id receiverClassOrEntries | - - id _ allSource copyFrom: range start to: range end. - receiverClassOrEntries _ range rangeType - caseOf: { - [ #globalVar ] -> [ (Smalltalk at: id asSymbol) class ]. - [ #self ] -> [ contextClass ]. - [ #super ] -> [ contextClass superclass ]. - [ #true ] -> [ True ]. - [ #false ] -> [ False ]. - [ #nil ] -> [ UndefinedObject ]. - [ #character ] -> [ id first class ]. - [ #number ] -> [ self classOfLiteral: id in: contextClass ]. - [ #string ] -> [ self classOfLiteral: id in: contextClass ]. - [ #symbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #stringSymbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #instVar ] -> [ specificModel classOfInstVarNamed: id ]. - [ #methodArg ] -> [ specificModel classOfTempVarNamed: id ]. - [ #tempVar ] -> [ specificModel classOfTempVarNamed: id ]. - [ #workspaceVar ] -> [ specificModel classOfWorkspaceVarNamed: id ]. - [ #blockArg ] -> [ specificModel classOfBlockArgNamed: id ]. - [ #blockTempVar ] -> [ specificModel classOfBlockTempVarNamed: id ]. - [ #thisContext ] -> [ specificModel classOfThisContext ]. - [ #classVar ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #poolConstant ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #blockEnd ] -> [ BlockClosure ]. - [ #arrayEnd ] -> [ Array ]. - [ #rightBrace ] -> [ Array ]. - [ #unary ] -> [ self returnTypeOfUnaryMessage: id at: range ]. - [ #rightParenthesis ] -> [ self returnTypeOfEnclosedExpressionAt: range ]. } - otherwise: [ nil ]. - - receiverClassOrEntries isCollection - ifTrue: [ self computeMessageEntriesForSelectors: receiverClassOrEntries ] - ifFalse: [ -" Descomentar para que suceda solo para cuando el receiver es una clase" - "(receiverClassOrEntries notNil and: [ receiverClassOrEntries isMeta ])" - (receiverClassOrEntries notNil) - ifTrue: [ self computeMessageForMetaclass: receiverClassOrEntries ] - ifFalse: [ self computeMessageEntries: receiverClassOrEntries ]]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 1/11/2019 12:17:09'! - computeMessageForMetaclass: aMetaclass - - | selectorsToShow addedSelectorsFastSet current | - - true ifTrue: [ ^self computeMessageForMetaclassWithCategories: aMetaclass ]. - false ifTrue: [ ^self computeMessageForMetaclassAddingCategory: aMetaclass ]. - - selectorsToShow := OrderedCollection new. - addedSelectorsFastSet := IdentitySet new. - current := aMetaclass. - [ current notNil ] whileTrue: [ | currentSelectors | - currentSelectors := current selectors select: [ :aSelector | (aSelector beginsWith: prefix) and: [ (addedSelectorsFastSet includes: aSelector) not ]]. - - selectorsToShow addAll: currentSelectors sorted. - addedSelectorsFastSet addAll: currentSelectors. - - current := current superclass. - "Comentar/Descomentar abajo para poner separador por clase" - "selectorsToShow add: '-- ', current name, ':'"]. - - "Comentar/Descomentar abajo para poner separador con Object class" - "selectorsToShow ifNotEmpty: [ selectorsToShow add: '-- ', current name ]." - - "self computeMessageEntries: Object class." - "Falta sacar repetidos de entries" - "entries := selectorsToShow asArray, entries." - entries := selectorsToShow asArray. - - "Comentar todo lo de arriba y descomentar esto para ver el comportamiento original" - " - self computeMessageEntries: aMetaclass . - " - ! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 1/9/2019 19:01:26'! - computeMessageForMetaclassAddingCategory: aMetaclass - - | selectorsToShow addedSelectorsFastSet current | - - selectorsToShow := OrderedCollection new. - addedSelectorsFastSet := IdentitySet new. - current := aMetaclass. - [ current notNil ] whileTrue: [ | currentSelectors organization | - organization := current organization. - currentSelectors := (current selectors select: [ :aSelector | (aSelector beginsWith: prefix) and: [ (addedSelectorsFastSet includes: aSelector) not ]]) sorted. - currentSelectors do: [ :aSelector | selectorsToShow add: aSelector, ' | ', (organization categoryOfElement: aSelector) ]. - - addedSelectorsFastSet addAll: currentSelectors. - - current := current superclass. - "Comentar/Descomentar abajo para poner separador por clase" - "selectorsToShow add: '-- ', current name, ':'"]. - - "Comentar/Descomentar abajo para poner separador con Object class" - selectorsToShow ifNotEmpty: [ selectorsToShow add: '-- ', current name ]. - - self computeMessageEntries: Object class. - "Falta sacar repetidos de entries" - entries := selectorsToShow asArray, entries. - - "Comentar todo lo de arriba y descomentar esto para ver el comportamiento original" - " - self computeMessageEntries: aMetaclass . - " - ! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 1/9/2019 19:01:35'! - computeMessageForMetaclassWithCategories: aMetaclass - - | selectorsToShow categoriesWithSelectors addedSelectorsFastSet current | - - categoriesWithSelectors := OrderedDictionary new. - addedSelectorsFastSet := IdentitySet new. - current := aMetaclass. - [ current notNil ] whileTrue: [ | currentSelectors organization | - organization := current organization. - organization categories do: [ :aCategory | - currentSelectors := (organization listAtCategoryNamed: aCategory) - select: [ :aSelector | (aSelector beginsWith: prefix) and: [ (addedSelectorsFastSet includes: aSelector) not ] ]. - (categoriesWithSelectors at: aCategory ifAbsentPut: [ OrderedCollection new ]) addAll: currentSelectors. - addedSelectorsFastSet addAll: currentSelectors ]. - - current := current superclass]. - - selectorsToShow := OrderedCollection new. - categoriesWithSelectors - at: 'instance creation' - ifPresent: [ :instanceCreationSelectors | - instanceCreationSelectors isEmpty ifFalse: [ - selectorsToShow add: '-- instance creation'; addAll: instanceCreationSelectors. - categoriesWithSelectors removeKey: 'instance creation' ]]. - - categoriesWithSelectors associationsDo: [ :categoryAndSelectors | - categoryAndSelectors value isEmpty ifFalse: [ - selectorsToShow - add: '-- ', categoryAndSelectors key; - addAll: categoryAndSelectors value ]]. - - "Comentar/Descomentar abajo para poner separador con Object class" - "selectorsToShow ifNotEmpty: [ selectorsToShow add: '-- ', current name ]." - - "Falta sacar repetidos de entries" -" self computeMessageEntries: Object class. - entries := selectorsToShow asArray, entries." - entries := selectorsToShow asArray. - - "Comentar todo lo de arriba y descomentar esto para ver el comportamiento original" - " - self computeMessageEntries: aMetaclass . - " - ! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3581-AutoCompleterEnhancements-HernanWilkinson-2019Jan08-17h37m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3562] on 17 January 2019 at 4:48:31 pm'! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 1/17/2019 16:33:43' prior: 50427400! - returnTypeOfEnclosedExpressionAt: aRange - - Smalltalk isLiveTypingInstalled ifFalse: [ ^nil ]. - - ^self - withParserSourceMethodNodeDo: [ :methodNode | self returnTypeOfEnclosedExpresionIn: methodNode at: aRange end - 1 ] - ifError: [ :anError | nil ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3582-AutoCompleterFix-HernanWilkinson-2019Jan11-12h22m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3562] on 18 January 2019 at 12:58:36 am'! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 1/18/2019 00:58:19'! - typeOfCascadeReceiverAt: aRange - - | positionBeforeSemiColon | - - Smalltalk isLiveTypingInstalled ifFalse: [ ^nil ]. - - positionBeforeSemiColon := aRange end - 1. - - "I have to parse excluding the last semi-colon because if not a syntax error will be signaled - because the cascade message is not finished - Hernan" - ^self - withMethodNodeOf: (parser source first: positionBeforeSemiColon) - do: [ :methodNode | self typeOfCascadeReceiverIn: methodNode at: positionBeforeSemiColon ] - ifError: [ :anError | nil ]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 1/18/2019 00:14:55'! - withMethodNodeOf: aSourceCode do: doBlock ifError: anErrorBlock - - ^ [[ doBlock value: (parser classOrMetaClass methodNodeFor: aSourceCode) ] - on: UndeclaredVariableReference - do: [ :anUndeclareVariableReference | anUndeclareVariableReference declareTempAndResume ]] - on: Error - do: anErrorBlock - - ! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 1/18/2019 00:21:47'! - withMethodNodeOfAllSourceCodeDo: doBlock ifError: anErrorBlock - - ^ self withMethodNodeOf: parser source do: doBlock ifError: anErrorBlock - ! ! -!AutoCompleter methodsFor: 'keyboard - private' stamp: 'HAW 1/17/2019 23:26:04' prior: 50424017! - shouldOpenMorphWhenNoPrefixFor: currentChar - - ^currentChar isAlphaNumeric - or: [ currentChar isRightBracket - or: [ currentChar = $) - or: [ currentChar = $; ]]]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 1/17/2019 16:49:38' prior: 50414945! - canComputeMessageEntriesFor: prevRange and: prevPrevRange - - ^ prevRange notNil and: [ prevPrevRange isNil or: [ prevPrevRange rangeType ~= #binary ]]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 1/17/2019 23:33:22' prior: 50429301! - computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel - - | id receiverClassOrEntries | - - id _ allSource copyFrom: range start to: range end. - receiverClassOrEntries _ range rangeType - caseOf: { - [ #globalVar ] -> [ (Smalltalk at: id asSymbol) class ]. - [ #self ] -> [ contextClass ]. - [ #super ] -> [ contextClass superclass ]. - [ #true ] -> [ True ]. - [ #false ] -> [ False ]. - [ #nil ] -> [ UndefinedObject ]. - [ #character ] -> [ id first class ]. - [ #number ] -> [ self classOfLiteral: id in: contextClass ]. - [ #string ] -> [ self classOfLiteral: id in: contextClass ]. - [ #symbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #stringSymbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #instVar ] -> [ specificModel classOfInstVarNamed: id ]. - [ #methodArg ] -> [ specificModel classOfTempVarNamed: id ]. - [ #tempVar ] -> [ specificModel classOfTempVarNamed: id ]. - [ #workspaceVar ] -> [ specificModel classOfWorkspaceVarNamed: id ]. - [ #blockArg ] -> [ specificModel classOfBlockArgNamed: id ]. - [ #blockTempVar ] -> [ specificModel classOfBlockTempVarNamed: id ]. - [ #thisContext ] -> [ specificModel classOfThisContext ]. - [ #classVar ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #poolConstant ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #blockEnd ] -> [ BlockClosure ]. - [ #arrayEnd ] -> [ Array ]. - [ #rightBrace ] -> [ Array ]. - [ #unary ] -> [ self returnTypeOfUnaryMessage: id at: range ]. - [ #rightParenthesis ] -> [ self returnTypeOfEnclosedExpressionAt: range ]. - [ #cascadeSeparator] -> [ self typeOfCascadeReceiverAt: range ]. } - otherwise: [ nil ]. - - receiverClassOrEntries isCollection - ifTrue: [ self computeMessageEntriesForSelectors: receiverClassOrEntries ] - ifFalse: [ -" Descomentar para que suceda solo para cuando el receiver es una clase" - "(receiverClassOrEntries notNil and: [ receiverClassOrEntries isMeta ])" - (receiverClassOrEntries notNil) - ifTrue: [ self computeMessageForMetaclass: receiverClassOrEntries ] - ifFalse: [ self computeMessageEntries: receiverClassOrEntries ] ]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 1/18/2019 00:21:47' prior: 50429525! - returnTypeOfEnclosedExpressionAt: aRange - - Smalltalk isLiveTypingInstalled ifFalse: [ ^nil ]. - - ^self - withMethodNodeOfAllSourceCodeDo: [ :methodNode | self returnTypeOfEnclosedExpresionIn: methodNode at: aRange end - 1 ] - ifError: [ :anError | nil ]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 1/18/2019 00:45:13' prior: 50427412! - returnTypeOfUnaryMessage: aSelector at: aRange - - Smalltalk isLiveTypingInstalled ifFalse: [ ^nil ]. - - ^self - withMethodNodeOfAllSourceCodeDo: [ :methodNode | self returnTypeOfNodeUnderCursorIn: methodNode at: aRange end] - ifError: [ :anError | nil ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3583-AutocompleterHandlesCascade-HernanWilkinson-2019Jan17-16h48m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3583] on 18 January 2019 at 12:32:51 pm'! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 1/18/2019 12:32:36' prior: 50429601! - computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel - - | id receiverClassOrEntries | - - id _ allSource copyFrom: range start to: range end. - receiverClassOrEntries _ range rangeType - caseOf: { - [ #globalVar ] -> [ (Smalltalk at: id asSymbol) class ]. - [ #self ] -> [ contextClass ]. - [ #super ] -> [ contextClass superclass ]. - [ #true ] -> [ True ]. - [ #false ] -> [ False ]. - [ #nil ] -> [ UndefinedObject ]. - [ #character ] -> [ id first class ]. - [ #number ] -> [ self classOfLiteral: id in: contextClass ]. - [ #string ] -> [ self classOfLiteral: id in: contextClass ]. - [ #symbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #stringSymbol ] -> [ self classOfLiteral: id in: contextClass ]. - [ #instVar ] -> [ specificModel classOfInstVarNamed: id ]. - [ #methodArg ] -> [ specificModel classOfTempVarNamed: id ]. - [ #tempVar ] -> [ specificModel classOfTempVarNamed: id ]. - [ #workspaceVar ] -> [ specificModel classOfWorkspaceVarNamed: id ]. - [ #blockArg ] -> [ specificModel classOfBlockArgNamed: id ]. - [ #blockTempVar ] -> [ specificModel classOfBlockTempVarNamed: id ]. - [ #thisContext ] -> [ specificModel classOfThisContext ]. - [ #classVar ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #poolConstant ] -> [ self classOfLocalBindingNamed: id in: contextClass ]. - [ #blockEnd ] -> [ BlockClosure ]. - [ #arrayEnd ] -> [ Array ]. - [ #rightBrace ] -> [ Array ]. - [ #unary ] -> [ self returnTypeOfUnaryMessage: id at: range ]. - [ #rightParenthesis ] -> [ self returnTypeOfEnclosedExpressionAt: range ]. - [ #cascadeSeparator] -> [ self typeOfCascadeReceiverAt: range ]. } - otherwise: [ nil ]. - - receiverClassOrEntries isCollection - ifTrue: [ self computeMessageEntriesForSelectors: receiverClassOrEntries ] - ifFalse: [ self computeMessageEntries: receiverClassOrEntries ]! ! - -SmalltalkCompleter removeSelector: #computeMessageForMetaclass:! - -SmalltalkCompleter removeSelector: #computeMessageForMetaclass:! - -SmalltalkCompleter removeSelector: #computeMessageForMetaclassAddingCategory:! - -SmalltalkCompleter removeSelector: #computeMessageForMetaclassAddingCategory:! - -SmalltalkCompleter removeSelector: #computeMessageForMetaclassWithCategories:! - -SmalltalkCompleter removeSelector: #computeMessageForMetaclassWithCategories:! - -SmalltalkCompleter removeSelector: #withParserSourceMethodNodeDo:ifError:! - -SmalltalkCompleter removeSelector: #withParserSourceMethodNodeDo:ifError:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3584-AutoCompleter-removeExperimentalCode-HernanWilkinson-2019Jan18-12h29m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3584] on 21 January 2019 at 12:44:58 pm'! -!ProcessorScheduler methodsFor: 'accessing' stamp: 'jmv 1/21/2019 12:43:41'! - anyReceiverInStackIn: anArray orIn: anotherArray runningProcessSearchStart: aContextOrNil - "Iterate over all methods currently in execution. Answer true if in any of them 'self' an element of argument" - " - Processor anyReceiverInStackIn: {} orIn: { self runningWorld } runningProcessSearchStart: nil - Processor anyReceiverInStackIn: {} orIn: { Object new } runningProcessSearchStart: nil - " - self - processesDo: [ :p | ] withStackFramestDo: [ :p :c | | r | - r _ c receiver. - (anArray statePointsTo: r) - ifTrue: [ ^ true ]. - (anotherArray statePointsTo: r) - ifTrue: [ ^ true ]] - runningProcessSearchStart: aContextOrNil. - ^ false! ! -!ProcessorScheduler methodsFor: 'accessing' stamp: 'jmv 1/21/2019 12:43:55'! - anyReceiverInStackIn: anArray runningProcessSearchStart: aContextOrNil - "Iterate over all methods currently in execution. Answer true if in any of them 'self' an element of argument" - " - Processor anyReceiverInStackIn: { self runningWorld } runningProcessSearchStart: nil - Processor anyReceiverInStackIn: { Object new } runningProcessSearchStart: nil - " - self - processesDo: [ :p | ] withStackFramestDo: [ :p :c | - (anArray statePointsTo: c receiver) - ifTrue: [ ^ true ]] - runningProcessSearchStart: aContextOrNil. - ^ false! ! -!ProcessorScheduler methodsFor: 'accessing' stamp: 'jmv 1/21/2019 12:25:46'! - processesDo: aBlock withStackFramestDo: twoArgBlock runningProcessSearchStart: aContextOrNil - "Iterate over processes that can run. - For each process, iterate over stack frames (i.e. contexts)." - " - Processor - processesDo: [ :p | - '--------------' print. - p print. - '--------------' print ] - withStackFramestDo: [ :p :c | - (' ', c printString) print ]. - " - self - processesWithTopContextDo: [ :process :topContext | | context | - aBlock value: process. - context _ topContext. - [ context notNil ] whileTrue: [ - twoArgBlock value: process value: context. - context _ context sender ]] - runningProcessSearchStart: aContextOrNil! ! -!ProcessorScheduler methodsFor: 'accessing' stamp: 'jmv 1/21/2019 12:25:07'! - processesWithTopContextDo: aBlock runningProcessSearchStart: aContextOrNil - "Iterate over processes that can run. Include top context in block arguments." - " - Processor processesWithTopContextDo: [ :p :c | p print. ('------->', c printString) print ]. - " - self processesDo: [ :process | - aBlock - value: process - value: (process isRunning ifTrue: [ aContextOrNil ifNil: [thisContext] ] ifFalse: [ process suspendedContext ]) ]! ! -!ProtoObject methodsFor: 'system primitives' stamp: 'jmv 1/21/2019 12:37:38' prior: 50428308! - become: otherObject - "Primitive. Swap the object pointers of the receiver and the argument. - All variables in the entire system that used to point to the - receiver now point to the argument, and vice-versa. - Fails if either object is a SmallInteger" - - | oldObjects newObjects | - oldObjects _ { self }. - newObjects _ { otherObject }. - self class == otherObject class ifFalse: [ - (Processor anyReceiverInStackIn: oldObjects orIn: newObjects runningProcessSearchStart: thisContext sender) ifTrue: [ - AttemptToMutateObjectInCallStack - signal: 'Can not do #become: Either receiver or argument has some method currently in execution.']]. - oldObjects elementsExchangeIdentityWith: newObjects! ! -!Object methodsFor: 'system primitives' stamp: 'jmv 1/21/2019 12:37:46' prior: 50428332! - becomeForward: otherObject - "Primitive. All variables in the entire system that used to point - to the receiver now point to the argument. - Fails if either argument is a SmallInteger." - - | oldObjects | - oldObjects _ { self }. - self class == otherObject class ifFalse: [ - (Processor anyReceiverInStackIn: oldObjects runningProcessSearchStart: thisContext sender) ifTrue: [ - AttemptToMutateObjectInCallStack - signal: 'Can not do #become: Receiver has some method currently in execution.']]. - oldObjects elementsForwardIdentityTo: { otherObject }! ! -!Object methodsFor: 'system primitives' stamp: 'jmv 1/21/2019 12:37:50' prior: 50428351! - becomeForward: otherObject copyHash: copyHash - "Primitive. All variables in the entire system that used to point to the receiver now point to the argument. - If copyHash is true, the argument's identity hash bits will be set to those of the receiver. - Fails if either argument is a SmallInteger." - - | oldObjects | - oldObjects _ { self }. - self class == otherObject class ifFalse: [ - (Processor anyReceiverInStackIn: oldObjects runningProcessSearchStart: thisContext sender) ifTrue: [ - AttemptToMutateObjectInCallStack - signal: 'Can not do #become: Receiver has some method currently in execution.']]. - oldObjects - elementsForwardIdentityTo: { otherObject } - copyHash: copyHash! ! -!ProcessorScheduler methodsFor: 'accessing' stamp: 'jmv 1/21/2019 12:34:33' prior: 50428215! - anyReceiverInStackIn: anArray - "Iterate over all methods currently in execution. Answer true if in any of them 'self' an element of argument" - " - Processor anyReceiverInStackIn: { self runningWorld } - Processor anyReceiverInStackIn: { Object new } - " - self - processesDo: [ :p | ] - withStackFramestDo: [ :p :c | - (anArray statePointsTo: c receiver) - ifTrue: [ ^ true ]] - runningProcessSearchStart: nil. - ^ false! ! -!ProcessorScheduler methodsFor: 'accessing' stamp: 'jmv 1/21/2019 12:34:49' prior: 50428248! - anyReceiverInStackIsKindOf: aClass - "Iterate over all methods currently in execution. Answer true if in any of them 'self' is a (sub)instance of aClass" - " - Processor anyReceiverInStackIsKindOf: Morph - Processor anyReceiverInStackIsKindOf: DifferenceFinder - " - self - processesDo: [ :p | ] - withStackFramestDo: [ :p :c | - (c receiver isKindOf: aClass) - ifTrue: [ ^ true ]] - runningProcessSearchStart: nil. - ^ false! ! - -ProcessorScheduler removeSelector: #anyReceiverInStackIn:orIn:! - -ProcessorScheduler removeSelector: #anyReceiverInStackIn:orIn:! - -ProcessorScheduler removeSelector: #processesDo:withStackFramestDo:! - -ProcessorScheduler removeSelector: #processesDo:withStackFramestDo:! - -ProcessorScheduler removeSelector: #processesWithTopContextDo:! - -ProcessorScheduler removeSelector: #processesWithTopContextDo:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3585-becomeStackCheckStartsAtSender-JuanVuletich-2019Jan21-12h39m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3584] on 21 January 2019 at 12:19:58 pm'! -!Debugger methodsFor: 'private' stamp: 'jmv 1/21/2019 12:17:19'! - fixReceiverInspector - "Make receiver inspector work on current context receiver. - Create a new inspector if needed" - - | currentReceiver requiredInspectorClass oldInspectorClass | - currentReceiver _ self receiver. - requiredInspectorClass _ currentReceiver inspectorClass. - oldInspectorClass _ receiverInspector class. - - oldInspectorClass ~= requiredInspectorClass ifTrue: [ - oldInspectorClass format = requiredInspectorClass format - ifTrue: [receiverInspector primitiveChangeClassTo: requiredInspectorClass basicNew] - ifFalse: [receiverInspector becomeForward: (requiredInspectorClass basicNew copyFrom: receiverInspector)]]. - - receiverInspector object: currentReceiver! ! -!Debugger methodsFor: 'private' stamp: 'jmv 1/21/2019 12:17:40' prior: 16830041! - contextStackIndex: arg1 oldContextWas: arg2 - | temp3 temp4 temp5 | - contextStackIndex _ arg1. - arg1 = 0 ifTrue: [ - currentCompiledMethod _ nil. - self changed: #contextStackIndex. - self acceptedContentsChanged. - contextVariablesInspector object: nil. - self fixReceiverInspector. - ^ self ]. - temp4 _ contextVariablesInspector selectedSlotName. - temp3 _ arg2 - ifNil: [ true ] - ifNotNil: [ arg2 method ~~ (currentCompiledMethod _ self selectedContext method) ]. - temp3 ifTrue: [ - self acceptedContentsChanged. - self pcRange ]. - self changed: #contextStackIndex. - self triggerEvent: #decorateButtons. - contextVariablesInspector object: self selectedContext. - ((temp5 _ contextVariablesInspector fieldList indexOf: temp4) ~= 0 and: [ - temp5 ~= contextVariablesInspector selectionIndex ]) ifTrue: [ - contextVariablesInspector toggleIndex: temp5 ]. - self fixReceiverInspector. - temp3 ifFalse: [ self changed: #contentsSelection ].! ! -!Inspector methodsFor: 'initialization' stamp: 'jmv 1/21/2019 12:12:06' prior: 50367138! - inspect: anObject - "Initialize the receiver so that it is inspecting anObject. There is no current selection." - - object := anObject. - self initialize! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3586-AvoidDangerousSelfBecomeInInspector-JuanVuletich-2019Jan21-12h19m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3586] on 22 January 2019 at 11:53:37 am'! -!FeatureRequirement methodsFor: 'private' stamp: 'jmv 1/22/2019 10:51:42' prior: 16840926! - placesToLookForPackagesDo: aBlock - - | base myDir | - - "Look inside my own folder" - pathName ifNotNil: [ - myDir _ pathName asFileEntry parent. - aBlock value: myDir ]. - - "Look in Cuis image folder and reasonable subfolders" - base _ DirectoryEntry smalltalkImageDirectory. - base allDirectoriesDo: aBlock. - - "Look in parent directory and reasonable subfolders. - Useful when image is stored in a subdirectory of the main app directory. - This could be the case when the package comes from a 'main' git repo, and image is copied from gitHub" - base parent allDirectoriesDo: aBlock. - - "Also look in host OS current directory" - (base ~= DirectoryEntry currentDirectory and: [base parent ~= DirectoryEntry currentDirectory]) - ifTrue: [ - base _ DirectoryEntry currentDirectory. - base allDirectoriesDo: aBlock ]! ! - -FeatureRequirement removeSelector: #inPackagesSubtreeOf:do:! - -FeatureRequirement removeSelector: #inPackagesSubtreeOf:do:! - -FeatureRequirement removeSelector: #withPackageSubfoldersOf:do:! - -FeatureRequirement removeSelector: #withPackageSubfoldersOf:do:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3587-SearchPackagesInAllFolderTree-JuanVuletich-2019Jan22-11h53m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3587] on 22 January 2019 at 12:56:51 pm'! -!PositionableStream methodsFor: 'fileIn/Out' stamp: 'jmv 1/22/2019 12:29:29' prior: 16891757! - 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." - - self fileInAnnouncing: 'Reading ' , self name. - Smalltalk cleanOutUndeclared. - Undeclared notEmpty ifTrue: [ - ('Undeclared: ', Undeclared printString) print ]! ! -!PositionableStream methodsFor: 'fileIn/Out' stamp: 'jmv 1/22/2019 12:25:39' prior: 50405824! - 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 | - Utilities logsUserChanges: false. - announcement - displayProgressAt: Sensor mousePoint - from: 0 - to: self size - during: [ :barBlock | - [ self atEnd ] whileFalse: [ - barBlock value: self position. - self skipSeparators. - - [ - val := (self peekFor: $!!) - ifTrue: [ - chunk := self nextChunk. - "These are the ones that should do nothing, - because next line is a doit that does the stuff - (or because it is handled elsewhere)" - (chunk beginsWith: 'description: ') - | (chunk beginsWith: 'provides: ') - | (chunk beginsWith: 'requires: ') - | (chunk beginsWith: 'classDefinition: ') - | (chunk beginsWith: 'classRemoval: ') - | (chunk beginsWith: 'methodRemoval: ') - | (chunk beginsWith: 'classMoveToSomePackage: ') - | (chunk beginsWith: 'methodMoveToSomePackage: ') - ifFalse: [(Compiler evaluate: chunk logged: false) scanFrom: self]] - ifFalse: [ - chunk := self nextChunk. - self checkForPreamble: chunk. - [ Compiler evaluate: chunk logged: true ] - on: Error - do: [ :ex | - ex print. - ('while evaluating: ', chunk) print. - ex pass ] - ]] - on: InMidstOfFileinNotification, UndeclaredVariableWarning - do: [ :ex | ex resume: true ] ]. - ]. - "Note: The main purpose of this banner is to flush the changes file." - Utilities logsUserChanges: true. - Smalltalk logChange: '----End fileIn of ' , self name , '----'. - ^val! ! -!FileStream methodsFor: 'fileIn/Out' stamp: 'jmv 1/22/2019 12:27:38' prior: 16843707! -fileIn - "Guarantee that the receiver is readOnly before fileIn for efficiency and - to eliminate remote sharing conflicts." - - self readOnly. - self fileInAnnouncing: 'Loading ', self localName. - Smalltalk cleanOutUndeclared. - Undeclared notEmpty ifTrue: [ - ('Undeclared: ', Undeclared printString) print ]. -! ! -!CodePackageFile methodsFor: 'services' stamp: 'jmv 1/22/2019 12:56:06' prior: 50422015! - install: aFileStream - "Installs the package. Replace all existing code in the CodePackage, removing any code that is not included in us." - | localName newCodePackage pckClass currentCS | - - "Give reasonable warnings if there is stuff that can't be properly cleaned. Give the user the chance to abort." - '=============' print. - classesToRemove notEmpty ifTrue: [ - ('classesToRemove: ', classesToRemove printString) print. - '=============' print ]. - methodsToRemove notEmpty ifTrue: [ - 'methodsToRemove: ' print. - methodsToRemove do: [ :methodReference | methodReference print ]. - '=============' print ]. - - "Create, install and answer a (sub)instance of CodePackage" - localName _ fullName asFileEntry name. - ChangeSet installing: packageName do: [ - "This change set will capture a possible class definition for a subclass of CodePackage. - If it only has that, then remove it after package install. - One example needing this is 'Color-Extras.pck.st'" - currentCS _ ChangeSet changeSetForBaseSystem. - currentCS isEmpty ifFalse: [ currentCS _ nil ]. - pckClass _ CodePackage. - classes do: [ :ee | - (ee hasDefinition and: [ee superclassName = 'CodePackage']) ifTrue: [ - ee fileInDefinitionAndMetaclass. - pckClass _ Smalltalk at: ee name ]]. - newCodePackage _ pckClass - named: packageName - createIfAbsent: true - registerIfNew: true. - newCodePackage - fullFileName: fullName; - sourceSystem: sourceSystem; - description: description; - featureSpec: featureSpec. - aFileStream fileInAnnouncing: 'Installing ', localName, '...'. - methodsToRemove do: [ :methodReference | methodReference actualClass removeSelector: methodReference selector ]. - classesToRemove do: [ :className | (Smalltalk at: className) removeFromSystem ]. - currentCS ifNotNil: [ ChangeSet removeChangeSet: currentCS ]]. - newCodePackage hasUnsavedChanges: false; triggerEvent: #dirtyFlagChanged. - DataStream initialize. "Just in case" - "If we are installing an already installed package, zap the change set with possible changes done, - as they are irrelevant now: we have the package from disk" - ChangeSet removeChangeSet: (ChangeSet existingOrNewChangeSetForPackage: newCodePackage). - Transcript newLine; show: 'Package ', packageName, ' successfully installed'; newLine. - - Smalltalk cleanOutUndeclared. - Undeclared notEmpty ifTrue: [ - ('Undeclared: ', Undeclared printString) print ]. - - ^newCodePackage! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3588-AvoidUndeclaredWarningsDuringPackageInstall-JuanVuletich-2019Jan22-12h54m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3588] on 23 January 2019 at 2:56:32 pm'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 1/23/2019 14:56:17' prior: 50428862! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('AY' 'Angel Yan') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('FGJ' 'Fernando Gasperi Jabalera') - #('FJG' 'Facundo Javier Gelatti') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('KLG' 'Gerald Klix') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('pmon' 'Paolo Montrasi') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3589-AddPaoloAsKnownAuthor-JuanVuletich-2019Jan23-14h56m-jmv.1.cs.st----! - -----SNAPSHOT----#(28 January 2019 10:39:22.58203 am) Cuis5.0-3589-v3.image priorSource: 3065078! - -----QUIT----#(28 January 2019 10:39:44.870652 am) Cuis5.0-3589-v3.image priorSource: 3163314! - -----STARTUP----#(16 February 2019 9:33:12.580539 pm) as /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/Cuis5.0-3589-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3589] on 29 January 2019 at 1:03:47 pm'! - -Error subclass: #MethodInCallStackToBecomeInvalid - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #MethodInCallStackToBecomeInvalid category: #'Exceptions Kernel'! -Error subclass: #MethodInCallStackToBecomeInvalid - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! -!MethodInCallStackToBecomeInvalid commentStamp: '' prior: 0! - A become operation tries to mutate an object that is the receiver ('self') in a method currently in execution, and part of the stack of calls of some process. This would render the method invalid and is potentially catastrophic.! -!ProtoObject methodsFor: 'system primitives' stamp: 'jmv 1/29/2019 12:03:51' prior: 50429881! - become: otherObject - "Primitive. Swap the object pointers of the receiver and the argument. - All variables in the entire system that used to point to the - receiver now point to the argument, and vice-versa. - Fails if either object is a SmallInteger" - - | selfMethod otherObjectMethod selector contextReceiver | - self class == otherObject class ifFalse: [ - Processor - processesDo: [ :p | ] withStackFramestDo: [ :process :context | - contextReceiver _ context receiver. - (self == contextReceiver or: [ otherObject == contextReceiver ]) ifTrue: [ - selector _ context method selector. - selfMethod _ self class lookupSelector: selector. - otherObjectMethod _ otherObject class lookupSelector: selector. - selfMethod = otherObjectMethod ifFalse: [ - MethodInCallStackToBecomeInvalid - signal: contextReceiver class name, ' has some instance running #', selector, ' that would become invalid.'. - ^ true ]]] - runningProcessSearchStart: thisContext sender. - ]. - { self } elementsExchangeIdentityWith: { otherObject }! ! -!Object methodsFor: 'system primitives' stamp: 'jmv 1/29/2019 12:03:48' prior: 50429906! - becomeForward: otherObject - "Primitive. All variables in the entire system that used to point - to the receiver now point to the argument. - Fails if either argument is a SmallInteger." - - | newMethod oldMethod selector | - self class == otherObject class ifFalse: [ - Processor - processesDo: [ :p | ] withStackFramestDo: [ :process :context | - self == context receiver ifTrue: [ - selector _ context method selector. - oldMethod _ self class lookupSelector: selector. - newMethod _ otherObject class lookupSelector: selector. - oldMethod = newMethod ifFalse: [ - MethodInCallStackToBecomeInvalid - signal: self class name, ' has some instance running #', selector, ' that would become invalid.'. - ^ true ]]] - runningProcessSearchStart: thisContext sender. - ]. - { self } elementsForwardIdentityTo: { otherObject }! ! -!Object methodsFor: 'system primitives' stamp: 'jmv 1/29/2019 12:03:50' prior: 50429927! - becomeForward: otherObject copyHash: copyHash - "Primitive. All variables in the entire system that used to point to the receiver now point to the argument. - If copyHash is true, the argument's identity hash bits will be set to those of the receiver. - Fails if either argument is a SmallInteger." - - | newMethod oldMethod selector | - self class == otherObject class ifFalse: [ - Processor - processesDo: [ :p | ] withStackFramestDo: [ :proces :context | - self == context receiver ifTrue: [ - selector _ context method selector. - oldMethod _ self class lookupSelector: selector. - newMethod _ otherObject class lookupSelector: selector. - oldMethod = newMethod ifFalse: [ - MethodInCallStackToBecomeInvalid - signal: self class name, ' has some instance running #', selector, ' that would become invalid.'. - ^ true ]]] - runningProcessSearchStart: thisContext sender. - ]. - { self } - elementsForwardIdentityTo: { otherObject } - copyHash: copyHash! ! -!Behavior methodsFor: 'private' stamp: 'jmv 8/16/2016 09:31:16' prior: 50428374! - becomeCompact - "Here are the restrictions on compact classes in order for export segments to work: A compact class index may not be reused. If a class was compact in a release of Squeak, no other class may use that index. The class might not be compact later, and there should be nil in its place in the array." - | cct index | - - Smalltalk isSpur ifTrue: [^ self halt: 'No Compact Classes support in Spur']. - self isWeak ifTrue:[^ self halt: 'You must not make a weak class compact']. - cct _ Smalltalk compactClassesArray. - (self indexIfCompact > 0 or: [cct includes: self]) - ifTrue: [^ self halt: self name , 'is already compact']. - index _ cct indexOf: nil - ifAbsent: [^ self halt: 'compact class table is full']. - "Install this class in the compact class table" - cct at: index put: self. - "Update instspec so future instances will be compact" - format _ format + (index bitShift: 11). - "Make up new instances and become old ones into them" - self updateInstancesFrom: self. - "Purge any old instances" - Smalltalk garbageCollect.! ! -!Behavior methodsFor: 'private' stamp: 'jmv 11/27/2008 16:05' prior: 50428414! - becomeUncompact - | cct index | - cct _ Smalltalk compactClassesArray. - (index _ self indexIfCompact) = 0 - ifTrue: [^ self]. - (cct includes: self) - ifFalse: [^ self halt "inconsistent state"]. - "Update instspec so future instances will not be compact" - format _ format - (index bitShift: 11). - "Make up new instances and become old ones into them" - self updateInstancesFrom: self. - "Make sure there are no compact ones left around" - Smalltalk garbageCollect. - "Remove this class from the compact class table" - cct at: index put: nil. -! ! -!ClassDescription methodsFor: 'initialization' stamp: 'jmv 1/29/2019 12:03:46' prior: 16807271! - updateInstancesFrom: oldClass - "Recreate any existing instances of the argument, oldClass, as instances of - the receiver, which is a newly changed class. Permute variables as necessary, - and forward old instances to new instances.. Answer nil to defeat any clients - that expected the old behaviour of answering the array of old instances." - "ar 7/15/1999: The updating below is possibly dangerous. If there are any - contexts having an old instance as receiver it might crash the system if - the new receiver in which the context is executed has a different layout. - See bottom below for a simple example:" - | newMethod oldMethod selector | - Processor - processesDo: [ :p | ] - withStackFramestDo: [ :process :context | - (context receiver isKindOf: oldClass) ifTrue: [ - selector _ context method selector. - oldMethod _ oldClass lookupSelector: selector. - newMethod _ self lookupSelector: selector. - oldMethod = newMethod ifFalse: [ - MethodInCallStackToBecomeInvalid - signal: self class name, ' has some instance running ', oldMethod printString, ' that would become invalid.'. - ^nil ]]] - runningProcessSearchStart: nil. - self updateInstances: oldClass allInstances asArray from: oldClass isMeta: self isMeta. - ^nil - -"This attempts to crash the VM by stepping off the end of an instance. - As the doctor says, do not do this." -" | crashingBlock class | - class := Object subclass: #CrashTestDummy - instanceVariableNames: 'instVar' - classVariableNames: '' - poolDictionaries: '' - category: 'Crash-Test'. - class compile:'instVar: value instVar := value'. - class compile:'crashingBlock ^[instVar]'. - crashingBlock := (class new) instVar: 42; crashingBlock. - Object subclass: #CrashTestDummy - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Crash-Test'. - crashingBlock value"! ! -!ClassBuilder methodsFor: 'class definition' stamp: 'jmv 5/20/2015 12:51' prior: 50428439! - class: oldClass instanceVariableNames: instVarString unsafe: unsafe - "This is the basic initialization message to change the definition of - an existing Metaclass" - | instVars newClass needNew copyOfOldClass | - instVars _ Scanner new scanFieldNames: instVarString. - unsafe ifFalse:[ - "Run validation checks so we know that we have a good chance for recompilation" - (self validateInstvars: instVars from: oldClass forSuper: oldClass superclass) ifFalse:[^nil]. - (self validateSubclassFormat: oldClass typeOfClass from: oldClass forSuper: oldClass superclass extra: instVars size) ifFalse:[^nil]]. - "See if we need a new subclass or not" - needNew _ self needsSubclassOf: oldClass superclass type: oldClass typeOfClass instanceVariables: instVars from: oldClass. - needNew ifNil:[^nil]. "some error" - needNew ifFalse:[^oldClass]. "no new class needed" - - "Create the new class" - copyOfOldClass _ oldClass copy. - newClass _ self - newSubclassOf: oldClass superclass - type: oldClass typeOfClass - instanceVariables: instVars - from: oldClass. - - newClass _ self recompile: false from: oldClass to: newClass mutate: false. - self doneCompiling: newClass. - SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass. - ^newClass! ! -!ClassBuilder methodsFor: 'class definition' stamp: 'jmv 5/20/2015 12:51' prior: 50428488! - name: className subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category unsafe: unsafe - "Define a new class. - If unsafe is true do not run any validation checks. - This facility is provided to implement important system changes." - | oldClass newClass organization instVars classVars force needNew oldCategory copyOfOldClass newCategory | - instVars _ Scanner new scanFieldNames: instVarString. - classVars _ (Scanner new scanFieldNames: classVarString) collect: [:x | x asSymbol]. - - "Validate the proposed name" - unsafe ifFalse:[(self validateClassName: className) ifFalse:[^nil]]. - oldClass _ Smalltalk at: className ifAbsent: nil. - oldClass isBehavior - ifFalse:[oldClass _ nil]. "Already checked in #validateClassName:" - copyOfOldClass _ oldClass copy. - - unsafe ifFalse:[ - "Run validation checks so we know that we have a good chance for recompilation" - (self validateSuperclass: newSuper forSubclass: oldClass) ifFalse:[^nil]. - (self validateInstvars: instVars from: oldClass forSuper: newSuper) ifFalse:[^nil]. - (self validateClassvars: classVars from: oldClass forSuper: newSuper) ifFalse:[^nil]. - (self validateSubclassFormat: type from: oldClass forSuper: newSuper extra: instVars size) ifFalse:[^nil]]. - - "See if we need a new subclass" - needNew _ self needsSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass. - needNew ifNil: [^nil]. "some error" - - (needNew and:[unsafe not]) ifTrue:[ - "Make sure we don't redefine any dangerous classes" - (self tooDangerousClasses includes: oldClass name) ifTrue:[ - self error: oldClass name, ' cannot be changed'. - ]. - "Check if the receiver should not be redefined" - (oldClass notNil and:[oldClass shouldNotBeRedefined]) ifTrue:[ - self notify: oldClass name asText allBold, - ' should not be redefined!! \Proceed to store over it.' withNewLines]]. - - needNew ifTrue:[ - "Create the new class" - newClass _ self - newSubclassOf: newSuper - type: type - instanceVariables: instVars - from: oldClass. - newClass ifNil: [ ^nil]. "Some error" - newClass setName: className. - ] ifFalse:[ - "Reuse the old class" - newClass _ oldClass. - ]. - - "Install the class variables and pool dictionaries... " - force _ (newClass declare: classVarString) | (newClass sharing: poolString). - - "... classify ..." - newCategory _ category asSymbol. - organization _ Smalltalk organization. - oldClass ifNotNil: [oldCategory := (organization categoryOfElement: oldClass name) asSymbol]. - organization classify: newClass name under: newCategory. - - "... recompile ..." - newClass _ self recompile: force from: oldClass to: newClass mutate: false. - - "... export if not yet done ..." - (Smalltalk at: newClass name ifAbsent: nil) == newClass ifFalse:[ - [Smalltalk at: newClass name put: newClass] - on: AttemptToWriteReadOnlyGlobal do:[:ex| ex resume: true]. - Smalltalk flushClassNameCache. - ]. - - self doneCompiling: newClass. - - "... notify interested clients ..." - oldClass ifNil: [ - SystemChangeNotifier uniqueInstance classAdded: newClass inCategory: newCategory. - ^ newClass]. - SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass. - newCategory ~= oldCategory - ifTrue: [SystemChangeNotifier uniqueInstance classRecategorized: newClass from: oldCategory to: category]. - ^newClass! ! -!ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:40' prior: 50428635! - moveInstVarNamed: instVarName from: srcClass to: dstClass after: prevInstVarName - "Move the given instVar from srcClass to dstClass" - (srcClass instVarNames includes: instVarName) - ifFalse:[^self error: instVarName,' is not an instance variable of ', srcClass name]. - (prevInstVarName isNil or:[dstClass instVarNames includes: prevInstVarName]) - ifFalse:[^self error: prevInstVarName, 'is not an instance variable of', dstClass name]. - (srcClass inheritsFrom: dstClass) ifTrue:[ - "Move the instvar up the hierarchy." - (self validateClass: srcClass forMoving: instVarName upTo: dstClass) - ifFalse:[^false]. - ]. - (dstClass inheritsFrom: srcClass) ifTrue:[ - "Move the instvar down the hierarchy" - (self validateClass: srcClass forMoving: instVarName downTo: dstClass) - ifFalse:[^false]. - ]. - ^self silentlyMoveInstVarNamed: instVarName from: srcClass to: dstClass after: prevInstVarName! ! - -ProcessorScheduler removeSelector: #anyReceiverInStackIn:orIn:runningProcessSearchStart:! - -ProcessorScheduler removeSelector: #anyReceiverInStackIn:orIn:runningProcessSearchStart:! - -ProcessorScheduler removeSelector: #anyReceiverInStackIn:runningProcessSearchStart:! - -ProcessorScheduler removeSelector: #anyReceiverInStackIn:runningProcessSearchStart:! - -ProcessorScheduler removeSelector: #anyReceiverInStackIsKindOf:! - -ProcessorScheduler removeSelector: #anyReceiverInStackIsKindOf:! - -Smalltalk removeClassNamed: #AttemptToMutateObjectInCallStack! - -Smalltalk removeClassNamed: #AttemptToMutateObjectInCallStack! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3590-BetterCheckForInvalidMethodsInCallStack-JuanVuletich-2019Jan29-12h57m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3590] on 30 January 2019 at 11:26:24 am'! -!ClassBuilder methodsFor: 'class mutation' stamp: 'jmv 1/30/2019 11:26:18' prior: 16804333! - update: oldClass to: newClass - "Convert oldClass, all its instances and possibly its meta class into newClass, - instances of newClass and possibly its meta class. The process is surprisingly - simple in its implementation and surprisingly complex in its nuances and potentially - bad side effects. - We can rely on two assumptions (which are critical): - #1: The method #updateInstancesFrom: will not create any lasting pointers to - 'old' instances ('old' is quote on quote since #updateInstancesFrom: will do - a become of the old vs. the new instances and therefore it will not create - pointers to *new* instances before the #become: which are *old* afterwards) - #2: The non-preemptive execution of the critical piece of code guarantees that - nobody can get a hold by 'other means' (such as process interruption and - reflection) on the old instances. - Given the above two, we know that after #updateInstancesFrom: there are no pointers - to any old instances. After the forwarding become there will be no pointers to the old - class or meta class either. - Meaning that if we throw in a nice fat GC at the end of the critical block, everything will - be gone (but see the comment right there). - Andreas Raab, 2/27/2003 23:42" - | meta | - meta := oldClass isMeta. - "Note: Everything from here on will run without the ability to get interrupted - to prevent any other process to create new instances of the old class." - ["Note: The following removal may look somewhat obscure and needs an explanation. - When we mutate the class hierarchy we create new classes for any existing subclass. - So it may look as if we don't have to remove the old class from its superclass. However, - at the top of the hierarchy (the first class we reshape) that superclass itself is not newly - created so therefore it will hold both the oldClass and newClass in its (obsolete or not) - subclasses. Since the #become: below will transparently replace the pointers to oldClass - with newClass the superclass would have newClass in its subclasses TWICE. With rather - unclear effects if we consider that we may convert the meta-class hierarchy itself (which - is derived from the non-meta class hierarchy). - Due to this problem ALL classes are removed from their superclass just prior to converting - them. Here, breaking the superclass/subclass invariant really doesn't matter since we will - effectively remove the oldClass - (becomeForward: or become+GC) just a few lines below." - - "Convert the instances of oldClass into instances of newClass" - newClass updateInstancesFrom: oldClass. - - oldClass superclass removeSubclass: oldClass. - oldClass superclass removeObsoleteSubclass: oldClass. - - "make sure that the VM cache is clean" - oldClass methodDict do: [:cm | cm flushCache]. - - meta - ifTrue: - [oldClass becomeForward: newClass. - oldClass updateMethodBindingsTo: oldClass binding] - ifFalse: - [{oldClass. oldClass class} elementsForwardIdentityTo: {newClass. newClass class}. - oldClass updateMethodBindingsTo: oldClass binding. - oldClass class updateMethodBindingsTo: oldClass class binding]. - - Smalltalk isSpur - ifTrue: [ - "eem 5/31/2014 07:22 At this point there used to be a garbage collect whose purpose was - to ensure no old instances existed after the becomeForward:. Without the GC it was possible - to resurrect old instances using e.g. allInstancesDo:. This was because the becomeForward: - updated references from the old objects to new objects but didn't destroy the old objects. - But as of late 2013/early 2014 becomeForward: has been modified to free all the old objects." - ] - - ifFalse: [ - "jmv: Squeak 4.6 (pre Spur) includes the GC. So, do it if not Spur. - Not really sure if needed on newer Cog and Stack non-Spur VMs. - Not sure if needed for SqueakJS. - Remove it when we are sure. - - Original note by Andreas Raab below." - Smalltalk garbageCollect. - "Warning: Read this before you even think about removing the GC. Yes, it slows us down. Quite heavily if you have a large image. However, there's no good and simple alternative here, since unfortunately, #become: does change class pointers. What happens is that after the above become all of the instances of the old class will have a class pointer identifying them as instances of newClass. If we get our hands on any of these instances we will break immediately since their expected instance layout (that of its class, e.g., newClass) will not match their actual instance layout (that of oldClass). And getting your hands on any of those instances is really simple - just reshaping one class two times in rapid succession will do it. Reflection techniques, interrupts, etc. will only add to this problem. In the case of Metaclass things get even worse since when we recompile the entire class hierarchy we will recompile both, Metaclass and its instances (and some of its instances will have the old and some the new layout). - The only easy solution to this problem would be to 'fix up' the class pointers of the old instances to point to the old class (using primitiveChangeClassTo:). But this won't work either - as we do a one-way become we would have to search the entire object memory for the oldClass and couldn't even clearly identify it unless we give it some 'special token' which sounds quite error-prone. If you really need to get rid of the GC here are some alternatives: - On the image level, one could create a copy of the oldClass before becoming it into the new class and, after becoming it, 'fix up' the old instances. That would certainly work but it sounds quite complex, as we need to make sure we're not breaking any of the superclass/subclass meta/non-meta class variants. - Alternatively, fix up #becomeForward on the VM-level to 'dump the source objects' of #become. This would be quite doable (just 'convert' them into a well known special class such as bitmap) yet it has problems if (accidentally or not) one of the objects in #become: appears on 'both sides of the fence' (right now, this will work ... in a way ... even though the consequences are unclear). - Another alternative is to provide a dedicated primitive for this (instead of using it implicitly in become) which would allow us to dump all the existing instances right here. This is equivalent to a more general primitiveChangeClassTo: and might be worthwhile but it would likely have to keep in mind the differences between bits and pointer thingies etc. - Since all of the alternatives seem rather complex and magical compared to a straight-forward GC it seems best to stick with the GC solution for now. If someone has a real need to fix this problem, that person will likely be motivated enough to check out the alternatives. Personally I'd probably go for #1 (copy the old class and remap the instances to it) since it's a solution that could be easily reverted from within the image if there's any problem with it. - Andreas Raab, 2/27/2003 23:42" - ] - ] valueUnpreemptively! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3591-AvoidCrashWhenClassMutationFails-JuanVuletich-2019Jan30-11h26m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3591] on 30 January 2019 at 11:54:45 am'! -!ClassDescription methodsFor: 'initialization' stamp: 'jmv 1/30/2019 11:54:25' prior: 50430696! - updateInstancesFrom: oldClass - "Recreate any existing instances of the argument, oldClass, as instances of - the receiver, which is a newly changed class. Permute variables as necessary, - and forward old instances to new instances.. Answer nil to defeat any clients - that expected the old behaviour of answering the array of old instances." - "ar 7/15/1999: The updating below is possibly dangerous. If there are any - contexts having an old instance as receiver it might crash the system if - the new receiver in which the context is executed has a different layout. - See bottom below for a simple example:" - | newMethod oldMethod selector | - Processor - processesDo: [ :p | ] - withStackFramestDo: [ :process :context | - (context receiver isKindOf: oldClass) ifTrue: [ - selector _ context method selector. - oldMethod _ oldClass lookupSelector: selector. - newMethod _ self lookupSelector: selector. - oldMethod = newMethod ifFalse: [ - MethodInCallStackToBecomeInvalid - signal: self class name, ' has some instance running #', selector, ' that would become invalid.'. - ^nil ]]] - runningProcessSearchStart: nil. - self updateInstances: oldClass allInstances asArray from: oldClass isMeta: self isMeta. - ^nil - -"This attempts to crash the VM by stepping off the end of an instance. - As the doctor says, do not do this." -" | crashingBlock class | - class := Object subclass: #CrashTestDummy - instanceVariableNames: 'instVar' - classVariableNames: '' - poolDictionaries: '' - category: 'Crash-Test'. - class compile:'instVar: value instVar := value'. - class compile:'crashingBlock ^[instVar]'. - crashingBlock := (class new) instVar: 42; crashingBlock. - Object subclass: #CrashTestDummy - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Crash-Test'. - crashingBlock value"! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3592-tweak-JuanVuletich-2019Jan30-11h54m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3592] on 30 January 2019 at 3:09:13 pm'! - -Exception subclass: #MethodInCallStackToBecomeInvalid - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #MethodInCallStackToBecomeInvalid category: #'Exceptions Kernel'! -Exception subclass: #MethodInCallStackToBecomeInvalid - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! -!MethodInCallStackToBecomeInvalid methodsFor: 'as yet unclassified' stamp: 'jmv 1/30/2019 15:04:38'! - defaultAction - - self noHandler! ! -!ProtoObject methodsFor: 'system primitives' stamp: 'jmv 1/30/2019 15:02:54' prior: 50430541! -become: otherObject - "Primitive. Swap the object pointers of the receiver and the argument. - All variables in the entire system that used to point to the - receiver now point to the argument, and vice-versa. - Fails if either object is a SmallInteger" - - | selfMethod otherObjectMethod selector contextReceiver | - self class == otherObject class ifFalse: [ - Processor - processesDo: [ :p | ] withStackFramestDo: [ :process :context | - contextReceiver _ context receiver. - (self == contextReceiver or: [ otherObject == contextReceiver ]) ifTrue: [ - selector _ context method selector. - selfMethod _ self class lookupSelector: selector. - otherObjectMethod _ otherObject class lookupSelector: selector. - selfMethod = otherObjectMethod ifFalse: [ - MethodInCallStackToBecomeInvalid - signal: contextReceiver class name, ' has some instance running #', selector, ' that would become invalid.' ]]] - runningProcessSearchStart: thisContext sender. - ]. - { self } elementsExchangeIdentityWith: { otherObject }! ! -!Object methodsFor: 'system primitives' stamp: 'jmv 1/30/2019 15:02:40' prior: 50430577! - becomeForward: otherObject - "Primitive. All variables in the entire system that used to point - to the receiver now point to the argument. - Fails if either argument is a SmallInteger." - - | newMethod oldMethod selector | - self class == otherObject class ifFalse: [ - Processor - processesDo: [ :p | ] withStackFramestDo: [ :process :context | - self == context receiver ifTrue: [ - selector _ context method selector. - oldMethod _ self class lookupSelector: selector. - newMethod _ otherObject class lookupSelector: selector. - oldMethod = newMethod ifFalse: [ - MethodInCallStackToBecomeInvalid - signal: self class name, ' has some instance running #', selector, ' that would become invalid.' ]]] - runningProcessSearchStart: thisContext sender. - ]. - { self } elementsForwardIdentityTo: { otherObject }! ! -!Object methodsFor: 'system primitives' stamp: 'jmv 1/30/2019 15:02:48' prior: 50430607! - becomeForward: otherObject copyHash: copyHash - "Primitive. All variables in the entire system that used to point to the receiver now point to the argument. - If copyHash is true, the argument's identity hash bits will be set to those of the receiver. - Fails if either argument is a SmallInteger." - - | newMethod oldMethod selector | - self class == otherObject class ifFalse: [ - Processor - processesDo: [ :p | ] withStackFramestDo: [ :proces :context | - self == context receiver ifTrue: [ - selector _ context method selector. - oldMethod _ self class lookupSelector: selector. - newMethod _ otherObject class lookupSelector: selector. - oldMethod = newMethod ifFalse: [ - MethodInCallStackToBecomeInvalid - signal: self class name, ' has some instance running #', selector, ' that would become invalid.' ]]] - runningProcessSearchStart: thisContext sender. - ]. - { self } - elementsForwardIdentityTo: { otherObject } - copyHash: copyHash! ! -!ClassDescription methodsFor: 'initialization' stamp: 'jmv 1/30/2019 15:02:33' prior: 50431200! - updateInstancesFrom: oldClass - "Recreate any existing instances of the argument, oldClass, as instances of - the receiver, which is a newly changed class. Permute variables as necessary, - and forward old instances to new instances.. Answer nil to defeat any clients - that expected the old behaviour of answering the array of old instances." - "ar 7/15/1999: The updating below is possibly dangerous. If there are any - contexts having an old instance as receiver it might crash the system if - the new receiver in which the context is executed has a different layout. - See bottom below for a simple example:" - | newMethod oldMethod selector | - Processor - processesDo: [ :p | ] - withStackFramestDo: [ :process :context | - (context receiver isKindOf: oldClass) ifTrue: [ - selector _ context method selector. - oldMethod _ oldClass lookupSelector: selector. - newMethod _ self lookupSelector: selector. - oldMethod = newMethod ifFalse: [ - MethodInCallStackToBecomeInvalid - signal: self class name, ' has some instance running #', selector, ' that would become invalid.' ]]] - runningProcessSearchStart: nil. - self updateInstances: oldClass allInstances asArray from: oldClass isMeta: self isMeta. - ^nil - -"This attempts to crash the VM by stepping off the end of an instance. - As the doctor says, do not do this." -" | crashingBlock class | - class := Object subclass: #CrashTestDummy - instanceVariableNames: 'instVar' - classVariableNames: '' - poolDictionaries: '' - category: 'Crash-Test'. - class compile:'instVar: value instVar := value'. - class compile:'crashingBlock ^[instVar]'. - crashingBlock := (class new) instVar: 42; crashingBlock. - Object subclass: #CrashTestDummy - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Crash-Test'. - crashingBlock value"! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3593-MethodInCallStackToBecomeInvalid-isResumable-JuanVuletich-2019Jan30-15h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3593] on 1 February 2019 at 10:32:03 am'! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'jmv 2/1/2019 10:27:32' prior: 16909686! -doIt - "Set the context to include pool vars of the model. Then evaluate. - Print the result on the Transcript" - ^ self - evaluateSelectionAndDo: [ :result | - Transcript finishEntry. - result print ] - ifFail: nil - profiled: false! ! -!Transcript class methodsFor: 'private' stamp: 'jmv 2/1/2019 10:27:12' prior: 16938455! - finishEntry - | newEntry | - self unfinishedEntrySize > 1 ifTrue: [ - newEntry _ unfinishedEntry contents. - unfinishedEntry reset. - lastDisplayPosition _ 0. - self addEntry: newEntry. - self display ].! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3594-TranscriptTweaks-JuanVuletich-2019Feb01-10h27m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3593] on 1 February 2019 at 10:33:43 am'! -!BreakpointManager class methodsFor: 'private' stamp: 'KLG 1/31/2019 17:21:07' prior: 16791259! - compilePrototype: aSymbol in: aClass - "Compile and return a new method containing a break statement" - - | source node trailer | - trailer _ (aClass compiledMethodAt: aSymbol) trailer. - source := self breakpointMethodSourceFor: aSymbol in: aClass. - node := aClass compilerClass new - compile: source - in: aClass - notifying: nil - ifFail: [self error: '[breakpoint] unable to install breakpoint']. - ^node ifNotNil: [ node generate: trailer ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3595-BreakpointManagerFix-GeraldKlix-2019Feb01-10h32m-KLG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3595] on 1 February 2019 at 11:08:47 am'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 2/1/2019 11:08:32' prior: 50430298! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('AY' 'Angel Yan') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('FGJ' 'Fernando Gasperi Jabalera') - #('FJG' 'Facundo Javier Gelatti') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('KLG' 'Gerald Klix') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('pmon' 'Paolo Montrasi') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('SLD' 'Steve Davies') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3596-AddSteveAsKnownAuthor-JuanVuletich-2019Feb01-11h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3589] on 1 February 2019 at 10:06:52 am'! -!MenuMorph methodsFor: 'events' stamp: 'SLD 2/1/2019 09:58:38' prior: 50339248! - keyStroke: aKeyboardEvent - | matchString char asc selectable | - char := aKeyboardEvent keyCharacter. - asc := char numericValue. - aKeyboardEvent isReturnKey - ifTrue: [ - selectedItem ifNotNil: [ - selectedItem hasSubMenu - ifTrue: [ - aKeyboardEvent hand newMouseFocus: selectedItem subMenu. - ^aKeyboardEvent hand newKeyboardFocus: selectedItem subMenu] - ifFalse: [ - "self delete." - ^selectedItem invokeWithEvent: aKeyboardEvent]]. - (selectable := self items) size = 1 - ifTrue: [^selectable first invokeWithEvent: aKeyboardEvent]. - ^self]. - asc = 27 - ifTrue: [ - "escape key" - self - valueOfProperty: #matchString - ifPresentDo: [ :str | - str isEmpty - ifFalse: [ - "If filtered, first ESC removes filter" - self setProperty: #matchString toValue: String new. - self selectItem: nil. - ^self displayFiltered: aKeyboardEvent]]. - "If a stand-alone menu, just delete it" - ^self delete]. - (asc = 28 or: [asc = 29]) - ifTrue: [ - "left or right arrow key" - (selectedItem notNil and: [selectedItem hasSubMenu]) - ifTrue: [ - aKeyboardEvent hand newMouseFocus: selectedItem subMenu. - selectedItem subMenu moveSelectionDown: 1 event: aKeyboardEvent. - ^aKeyboardEvent hand newKeyboardFocus: selectedItem subMenu] - ifFalse: [^ self]]. - asc = 30 ifTrue: [^self moveSelectionDown: -1 event: aKeyboardEvent]. "up arrow key" - asc = 31 ifTrue: [^self moveSelectionDown: 1 event: aKeyboardEvent]. "down arrow key" - asc = 11 ifTrue: [^self moveSelectionDown: -5 event: aKeyboardEvent]. "page up key" - asc = 12 ifTrue: [^self moveSelectionDown: 5 event: aKeyboardEvent]. "page down key" - matchString := self valueOfProperty: #matchString ifAbsent: [String new]. - matchString := char = Character backspace - ifTrue: [ - matchString isEmpty ifTrue: [matchString] ifFalse: [matchString allButLast]] - ifFalse: [matchString copyWith: aKeyboardEvent keyCharacter]. - self setProperty: #matchString toValue: matchString. - self displayFiltered: aKeyboardEvent! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3597-MenuMorphDropLeftRigh-SteveDavies-2019Jan31-17h38m-SLD.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3589] on 4 February 2019 at 3:31:26 am'! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'AY 2/4/2019 03:26:10'! - atFront - - ^owner firstSubmorph == self! ! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'AY 2/4/2019 03:26:20' prior: 16876877! - comeToFront - - self atFront ifFalse: [owner addMorphFront: self]! ! -!Morph methodsFor: 'user interface' stamp: 'AY 2/4/2019 03:30:37' prior: 50341560! - toggleCollapseOrShow - "If collapsed, show me. - If visible, collapse me." - - (self visible and: [self atFront]) - ifTrue: [ self collapse ] - ifFalse: [ self showAndComeToFront ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3598-WindowSwitchingEnh-AngelYan-2019Feb04-03h15m-AY.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3589] on 7 February 2019 at 12:00:51 am'! - -PluggableButtonMorph subclass: #HoverableButtonMorph - instanceVariableNames: 'mouseEnterSelector mouseLeaveSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #HoverableButtonMorph category: #'Morphic-Views'! -PluggableButtonMorph subclass: #HoverableButtonMorph - instanceVariableNames: 'mouseEnterSelector mouseLeaveSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'AY 2/4/2019 03:26:10' prior: 50431790! - atFront - - ^owner firstSubmorph == self! ! -!Morph methodsFor: 'previewing' stamp: 'AY 2/6/2019 23:55:29'! - beginPreview - - (self visible and: [self atFront]) ifFalse: [ - self visibleBeforePreview: self visible. - self morphBehindBeforePreview: (self owner submorphBehind: self). - self previewing: true. - self showAndComeToFront. ]! ! -!Morph methodsFor: 'previewing' stamp: 'AY 2/6/2019 23:55:39'! - endPreview - - self previewing ifTrue: [ - self visible: self visibleBeforePreview. - self owner addMorph: self inFrontOf: self morphBehindBeforePreview. - self previewing: false. ]! ! -!Morph methodsFor: 'previewing' stamp: 'AY 2/4/2019 05:46:06'! - endPreviewAndToggleCollapseOrShow - - self endPreview. - self toggleCollapseOrShow.! ! -!Morph methodsFor: 'previewing' stamp: 'AY 2/6/2019 05:28:28'! - morphBehindBeforePreview - - ^self valueOfProperty: #morphBehindBeforePreview! ! -!Morph methodsFor: 'previewing' stamp: 'AY 2/6/2019 05:28:19'! - morphBehindBeforePreview: aMorph - - self setProperty: #morphBehindBeforePreview toValue: aMorph! ! -!Morph methodsFor: 'previewing' stamp: 'AY 2/6/2019 23:56:03'! - previewing - - ^(self valueOfProperty: #previewing) = true! ! -!Morph methodsFor: 'previewing' stamp: 'AY 2/6/2019 23:56:28'! - previewing: aBoolean - - self setProperty: #previewing toValue: aBoolean! ! -!Morph methodsFor: 'previewing' stamp: 'AY 2/6/2019 05:27:23'! - visibleBeforePreview - - ^self valueOfProperty: #visibleBeforePreview! ! -!Morph methodsFor: 'previewing' stamp: 'AY 2/6/2019 05:25:28'! - visibleBeforePreview: aBoolean - - self setProperty: #visibleBeforePreview toValue: self visible! ! -!HoverableButtonMorph methodsFor: 'initialization' stamp: 'AY 2/6/2019 04:01:16'! - model: anObject stateGetter: getStateSel action: actionSel onMouseEnterSend: aMouseEnterSelector onMouseLeaveSend: aMouseLeaveSelector - - super model: anObject stateGetter: getStateSel action: actionSel label: nil. - mouseEnterSelector _ aMouseEnterSelector. - mouseLeaveSelector _ aMouseLeaveSelector.! ! -!HoverableButtonMorph methodsFor: 'events' stamp: 'AY 2/4/2019 04:04:24'! - mouseEnter: event - - mouseEnterSelector ifNotNil: [ model perform: mouseEnterSelector ]. - ^super mouseEnter: event! ! -!HoverableButtonMorph methodsFor: 'events' stamp: 'AY 2/4/2019 04:05:06'! -mouseLeave: event - - mouseLeaveSelector ifNotNil: [ model perform: mouseLeaveSelector ]. - ^super mouseLeave: event! ! -!HoverableButtonMorph class methodsFor: 'instance creation' stamp: 'AY 2/6/2019 03:59:26'! - model: anObject stateGetter: getStateSel action: actionSel onMouseEnterSend: aMouseEnterSelector onMouseLeaveSend: aMouseLeaveSelector - - ^ self new - model: anObject - stateGetter: getStateSel - action: actionSel - onMouseEnterSend: aMouseEnterSelector - onMouseLeaveSend: aMouseLeaveSelector! ! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'AY 2/4/2019 03:26:20' prior: 50431795! - comeToFront - - self atFront ifFalse: [owner addMorphFront: self]! ! -!TaskbarMorph methodsFor: 'services' stamp: 'AY 2/6/2019 04:01:56' prior: 50402064! - addButtonFor: aMorph - - | button | - aMorph == self ifFalse: [ - button _ HoverableButtonMorph - model: aMorph - stateGetter: nil - action: #endPreviewAndToggleCollapseOrShow - onMouseEnterSend: #beginPreview - onMouseLeaveSend: #endPreview. - button - color: self color; - icon: (aMorph imageForm: 32); - setBalloonText: #label. - button icon: button magnifiedIcon. - viewBox - addMorph: button - fixedWidth: self defaultHeight ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3599-WindowPreviewing-AngelYan-2019Feb06-03h50m-AY.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3597] on 8 February 2019 at 10:16:00 pm'! -!Browser methodsFor: 'class list' stamp: 'SLD 2/8/2019 22:07:43' prior: 50407312! - classListIndex: anInteger - "Set anInteger to be the index of the current class selection." - - | className recent canSelectClass classList | - - classList _ self classList. - canSelectClass _ classList isInBounds: anInteger. - selectedClassName _ canSelectClass ifTrue: [ | newClassName | - newClassName := classList at: anInteger ifAbsent: [ nil ]. - newClassName := newClassName ifNotNil: [newClassName withoutLeadingBlanks asSymbol]. - newClassName ]. - self setClassOrganizer. - selectedMessage _ nil. - - self classCommentIndicated ifFalse: [ - self editSelection: (canSelectClass - ifTrue: [#editClass] - ifFalse: [ metaClassIndicated | selectedSystemCategory isNil - ifTrue: [#none] - ifFalse: [#newClass]])]. - - self selectedClass ifNotNil: [ - recent _ self class recentClasses. - className _ self selectedClass name. - (recent includes: className) ifTrue: [recent remove: className]. - recent addFirst: className. - recent size > 16 ifTrue: [recent removeLast]]. - - "Clear selectedMessageCategory if there is no match in the new list of categories" - (self messageCategoryList indexOf: selectedMessageCategory) = 0 ifTrue: [ - selectedMessageCategory _ nil]. - - "We have to refresh the class list if somebody wants to select a class that does not exist anymore - Hernan" - anInteger > classList size ifTrue: [ self changed: #classList ]. - self changed: #classSelectionChanged. - self changed: #classCommentText. - self changed: #classListIndex. "update my selection" - self changed: #messageCategoryList. - self changed: #messageList. - self changed: #relabel. - self acceptedContentsChanged! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3600-try-to-keep-messageCategory-SteveDavies-2019Jan29-21h24m-SLD.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3597] on 4 February 2019 at 12:02:07 am'! -!PackageRequirementsList methodsFor: 'accessing' stamp: 'KLG 2/3/2019 23:50:55'! - updateSelectedRequirement - - | selectedPackage featureSpec newRequires selectedName | - self selectionIndex ifNil: [ ^self ]. - self selectionIndex isZero ifTrue: [ ^self ]. - ((codePackageList selectionIndex isNil) or: [ codePackageList selectionIndex isZero ]) - ifTrue: [ ^self ]. - - selectedPackage := codePackageList selection. - featureSpec := selectedPackage featureSpec. - newRequires := (featureSpec requires copyWithout: self selection), - {((selectedName _ self selection name) = Feature baseSystemFeature name) - ifTrue: [ Feature baseSystemFeature requirementOfMe ] - ifFalse: [ (CodePackage installedPackages at: selectedName) requirementOfMe]}. - featureSpec - provides: featureSpec provides - requires: newRequires. - selectedPackage hasUnsavedChanges: true. - requirements := codePackageList selection requires asArray. - self changed: #requirements - - - ! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'KLG 2/3/2019 23:30:07' prior: 50387930! - buildRequirementsPane - - | requirements deleteReqButton "editReqButton" reqLayout buttonLayout updateReqButton | - requirements := PluggableListMorph - model: (PackageRequirementsList fromCodePackageList: model) - listGetter: #requirementsStrings - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - requirements color: Theme current textPane. - - deleteReqButton := PluggableButtonMorph - model: requirements model - action: #deleteSelectedRequirement - label: 'delete'. - deleteReqButton color: self widgetsColor. - updateReqButton _ PluggableButtonMorph - model: requirements model - action: #updateSelectedRequirement - label: 'update'. - updateReqButton color: self widgetsColor. - - buttonLayout := LayoutMorph newRow. - buttonLayout - addMorph: deleteReqButton - layoutSpec: (LayoutSpec - proportionalWidth: 1.0 - proportionalHeight: 1.0 - minorDirectionPadding: #top); - color: self widgetsColor quiteWhiter; - addMorph: updateReqButton - layoutSpec: (LayoutSpec - proportionalWidth: 1.0 - proportionalHeight: 1.0 - minorDirectionPadding: #top); - color: self widgetsColor quiteWhiter. - - model when: #changed: send: #updateRequirementsFromPackageList to: requirements model. - self when: #changed: send: #updateRequirementsFromPackageList to: requirements model. - requirements model when: #changed: send: #verifyContents to: requirements. - self when: #changed: send: #verifyContents to: requirements. - - reqLayout := LayoutMorph newRow. - ^ reqLayout - doAdoptWidgetsColor; - addMorph: requirements - layoutSpec: (LayoutSpec - proportionalWidth: 0.8 - proportionalHeight: 1.0 - minorDirectionPadding: #left); - addMorph: buttonLayout - layoutSpec: (LayoutSpec - proportionalWidth: 0.2 - proportionalHeight: 1.0 - minorDirectionPadding: #right); - color: `Color transparent`; - yourself - ! ! -!CodePackageListWindow methodsFor: 'commands' stamp: 'KLG 2/3/2019 23:35:44' prior: 16811558! - addRequirement - "Ask user for a FeatureRequirement based on loaded packages" - - | current currentName packageNames reqiredNames selectionNames choices selection cuisBaseName req selectedName | - current _ model selection. - current ifNil: [ ^self ]. - - packageNames := model packages collect: [ :pak | pak packageName ]. - currentName := current packageName. - reqiredNames := current requires collect: [ :r | r name ]. - selectionNames := packageNames select: [ :name | - ((name = currentName) or: [reqiredNames includes: name]) not ]. - cuisBaseName := Feature baseSystemFeature name. - choices := OrderedCollection with: #CANCEL. - (reqiredNames includes: cuisBaseName) - ifFalse: [ choices add: cuisBaseName ]. - choices addAll: selectionNames. - choices size = 1 ifTrue: [ - ^ PopUpMenu inform: 'All loaded packages are already required, as is Cuis base system' ]. - selection := PopUpMenu - withCaption: 'Choose package to require' - chooseFrom: choices. - selection <= 1 - ifTrue: [ ^ self ] "1 -> Cance, 0 -> Clicked outside the menu" - ifFalse: [ - selectedName := choices at: selection. - req := (selectedName = cuisBaseName) - ifTrue: [ Feature baseSystemFeature requirementOfMe ] - ifFalse: [ (CodePackage installedPackages at: selectedName) requirementOfMe]. - current featureSpec requires: req. - current hasUnsavedChanges: true. - self changed: #requirement ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3601-InstalledPackagesTool-enh-GeraldKlix-BetterInstalledPackagesBrowser-KLG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3597] on 4 February 2019 at 4:55:07 pm'! -!Editor class methodsFor: 'class initialization' stamp: 'HAW 2/4/2019 16:54:10'! - initializeCmdShortcutsUsing: anInitializationMessage - - | dynamicInitializationMessage | - - self putIntoCmdShortcuts: (self perform: anInitializationMessage). - - dynamicInitializationMessage := (self name asString uncapitalized, anInitializationMessage asString capitalized) asSymbol. - (Smalltalk allClassesImplementing: dynamicInitializationMessage) do: [ :aClass | - self putIntoCmdShortcuts: (aClass soleInstance perform: dynamicInitializationMessage) ]. - - -! ! -!Editor class methodsFor: 'class initialization' stamp: 'HAW 2/4/2019 16:53:40'! -putIntoCmdShortcuts: shortcutsSpec - - shortcutsSpec do: [ :ary | cmdShortcuts at: ary first numericValue + 1 put: ary second ].! ! -!Editor class methodsFor: 'class initialization' stamp: 'HAW 2/4/2019 16:51:32' prior: 16836915! - initializeCmdShortcuts - "Initialize the (unshifted) command-key (or alt-key if not on Mac) shortcut table. - If you want to add a new shortcut for an specific editor, for example SmalltalkEditor, you should - define the message #smalltalkEditorCmdShortcutsSpec in a class of your category and it will - be dynamically send" - - "NOTE: if you don't know what your keyboard generates, use Sensor test" - - " - Editor initialize - " - - cmdShortcuts _ Array new: 256 withAll: #noop:. - - self initializeCmdShortcutsUsing: #basicCmdShortcutsSpec. - self initializeCmdShortcutsUsing: #cmdShortcutsSpec. -! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3602-PluggableEditorShortcuts-HernanWilkinson-2019Feb04-15h45m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3589] on 4 February 2019 at 11:11:35 pm'! -!Collection methodsFor: 'enumerating' stamp: 'AY 2/4/2019 23:11:18' prior: 50381591! - select: selectBlock thenDo: doBlock - "Equivalent to - (self select: selectBlock) do: doBlock - but avoid creating an extra collection." - - self do: [ :each | (selectBlock value: each) ifTrue: [ doBlock value: each ]]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3603-CollectionSelectThenDoMessageFix-AngelYan-2019Feb04-23h11m-AY.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3598] on 6 February 2019 at 12:02:06 pm'! -!Boolean methodsFor: 'logical operations' stamp: 'HAW 2/6/2019 12:01:53'! - xor: aBoolean - - self subclassResponsibility! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3604-Boolean-xor-HernanWilkinson-2019Feb06-12h00m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3598] on 6 February 2019 at 1:38:28 pm'! -!TestCase methodsFor: 'assertions' stamp: 'HAW 2/6/2019 12:17:47' prior: 50424292! - should: aBlockToFail raise: anExceptionHandlingCondition withMessageText: anExpectedErrorMessageCreator - - self - should: aBlockToFail - raise: anExceptionHandlingCondition - withExceptionDo: [ :anException | self assert: anExpectedErrorMessageCreator value equals: anException messageText ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3605-TestCase-enh-HernanWilkinson-2019Feb06-12h04m-HAW.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3598] on 6 February 2019 at 1:57:15 pm'! -!SHTextStylerST80 methodsFor: 'private' stamp: 'HAW 2/6/2019 13:57:03' prior: 50371889! - privateStyle - - | alpha end start count startIndexes c hue | - self parseSetWorkspace: true. - parser ranges ifNotNil: [ :ranges | - self setAttributesFromRanges: ranges ]. - - Preferences highlightBlockNesting ifTrue: [ - startIndexes _ parser blockDepthsStartIndexes. - count _ startIndexes size. - parser blockDepths withIndexDo: [ :depth :idx | - start _ startIndexes at: idx. - end _ idx = count ifTrue: [formattedText size] ifFalse: [ (startIndexes at: idx+1)-1]. - alpha _ depth / 10.0 min: 1.0. - hue _ depth * 60. - c _ Color h: hue s: 0.2 v: 0.5 alpha: alpha. - formattedText - addAttribute: (ShoutTextBackgroundColor color: c ) - from: start - to: end ]]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3606-TextStyler-tweak-HernanWilkinson-2019Feb06-13h38m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3598] on 6 February 2019 at 4:15:11 pm'! -!AutoCompleterMorph methodsFor: 'as yet unclassified' stamp: 'HAW 2/6/2019 16:14:45' prior: 16781473! - updateColor - - | remaining alpha | - - remaining := (self timeout - self timeOfLastActivity). - remaining < 1000 - ifTrue: [ - alpha _ remaining / 1000.0. - self color: (self color alpha: alpha). - self borderColor: (borderColor alpha: alpha) ] - ifFalse: [ - self color: self defaultColor. - self borderColor: self defaultBorderColor ] - - ! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3607-AutoCompleter-fix-HernanWilkinson-2019Feb06-16h14m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3607] on 16 February 2019 at 7:46:40 pm'! -!Morph methodsFor: 'drawing' stamp: 'jmv 2/7/2019 20:44:52' prior: 50337366! - visible: aBoolean - "set the 'visible' attribute of the receiver to aBoolean" - - self visible == aBoolean - ifTrue: [ ^ self ]. - aBoolean ifFalse: [ - self redrawNeeded ]. - self setProperty: #visible toValue: aBoolean. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - aBoolean ifTrue: [ - self redrawNeeded]! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 2/7/2019 20:45:05' prior: 50337293! - wasOpened: aMorph - "aMorph was added to the world. Add button for aMorph if appropriate (see #taskbarIncludesAllWindows)" - - self addButtonFor: aMorph! ! -!TaskbarMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 2/7/2019 20:44:10' prior: 50337622! - noteNewOwner: aMorph - "I have just been added as a submorph of aMorph" - super noteNewOwner: aMorph. - aMorph submorphsDo: [ :m | - self addButtonFor: m ]. - self notifyDisplayResize! ! - -TaskbarMorph removeSelector: #wasMadeVisible:! - -TaskbarMorph removeSelector: #wasMadeVisible:! - -Preferences class removeSelector: #taskbarIncludesAllWindows! - -Preferences class removeSelector: #taskbarIncludesAllWindows! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3608-TaskbarAlwaysShowsAllWindows-JuanVuletich-2019Feb16-19h39m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3597] on 8 February 2019 at 11:44:02 pm'! - -IdentityDictionary subclass: #SystemDictionary - instanceVariableNames: 'cachedClassNames cachedNonClassNames startUpScriptArguments startUpArguments ' - classVariableNames: 'EndianCache LastImageName LastQuitLogPosition LowSpaceProcess LowSpaceSemaphore ShutDownList SourceFileVersionString SpecialSelectors StartUpList StartupStamp WordSize ChangesInitialFileSize ' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #SystemDictionary category: #'System-Support'! -IdentityDictionary subclass: #SystemDictionary - instanceVariableNames: 'cachedClassNames cachedNonClassNames startUpScriptArguments startUpArguments' - classVariableNames: 'ChangesInitialFileSize EndianCache LastImageName LastQuitLogPosition LowSpaceProcess LowSpaceSemaphore ShutDownList SourceFileVersionString SpecialSelectors StartUpList StartupStamp WordSize' - poolDictionaries: '' - category: 'System-Support'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 2/8/2019 23:43:13' prior: 16922741! - saveAs: newName andQuit: aBoolean clearAllClassState: clearAllStateFlag - "Save the image under a new name." - - | newChangesName | - self currentChangesName ifNotNil: [ :oldChangesName | - self closeSourceFiles. "so copying the changes file will always work" - newChangesName _ self fullNameForChangesNamed: newName. - FileIOAccessor default copy: oldChangesName asFileEntry to: newChangesName asFileEntry. - ChangesInitialFileSize ifNotNil: [ - oldChangesName asFileEntry appendStreamDo: [ :strm | strm truncate: ChangesInitialFileSize ]]]. - - self - changeImageNameTo: (self fullNameForImageNamed: newName); - closeSourceFiles; openSourceFiles; "so SNAPSHOT appears in new changes file" - snapshot: true andQuit: aBoolean - clearAllClassState: clearAllStateFlag! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 2/8/2019 23:32:57' prior: 50381428! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag -"WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " -| activeProc | -activeProc _ Processor activeProcess. -[ - | isARealStartup guiRootObject guiRootObjectClass reopenTranscript | - save not & quit - ifTrue: [ - (SourceFiles at: 2) ifNotNil: [ :changes | - ChangesInitialFileSize ifNotNil: [ - changes truncate: ChangesInitialFileSize ]]] - ifFalse: [ self logSnapshot: save andQuit: quit ]. - - reopenTranscript _ false. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | each isInWorld ifTrue: [ each delete. reopenTranscript _ true ]]. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - - - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - - "Cosas que levanto explicitamente abajo" - guiRootObjectClass _ UISupervisor ui class. - guiRootObject _ UISupervisor ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "guiRootObject _ clearAllStateFlag ifFalse: [ UISupervisor ui ]." - UISupervisor stopUIProcess. - activeProc isTerminated ifFalse: [ - activeProc terminate ]. - - "Clean Globals" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: nil. - Smalltalk closeSourceFiles. Smalltalk at: #SourceFiles put: nil. - Smalltalk allClassesDo: [ :cls | cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ Smalltalk printStuffToCleanOnImageSave ]. - - - "Do image save & quit as apropriate" - Cursor write activateCursor. - save - ifTrue: [ - "The snapshot primitive answers false if it was just called to do the snapshot. - But image startup is resumed by returning (again) from the primitive, but this time answering true." - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - - - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: DisplayScreen new. - Smalltalk at: #SourceFiles put: (Array new: 2). - Smalltalk openSourceFiles. - - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - - UISupervisor spawnNewMorphicProcessFor: (guiRootObject ifNil: [ guiRootObject _ guiRootObjectClass newWorld ]). - Display triggerEvent: #screenSizeChanged. - - self restoreLostChangesIfNecessary. - - UISupervisor whenUIinSafeState: [ - "guiRootObject fullRepaintNeeded." - reopenTranscript ifTrue: [ - TranscriptWindow openTranscript ]]. - - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - UISupervisor whenUIinSafeState: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]. - -] forkAt: Processor timingPriority-1 named: 'Startup process'.! ! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'jmv 2/8/2019 23:33:15' prior: 16923339! - openSourcesAndChanges - "Open the changes and sources files and install them in SourceFiles. Inform the user of problems regarding write permissions or Lf/CrLf mixups." - "Note: SourcesName and imageName are full paths; changesName is a - local name." - | sources changes msg wmsg entry | - msg _ 'Cuis cannot locate XfileRef -Please check that the file is named properly and is in the -same directory as this image.'. - wmsg _ 'Cuis cannot write to XfileRef. - -Please check that you have write permission for this file. - -You won''t be able to save this image correctly until you fix this.'. - - "Do not open source files if internalized (i.e. notNil)" - sources _ SourceFiles at: 1. - sources ifNil: [ - entry _ Smalltalk defaultSourcesName asFileEntry. - entry exists ifFalse: [ - entry _ Smalltalk alternativeSourcesName asFileEntry ]. - entry exists ifTrue: [ - sources _ [ entry readStream ] on: FileDoesNotExistException do: [ nil ]]]. - (sources isNil and: [ Preferences valueOfFlag: #warnIfNoSourcesFile ]) - ifTrue: [ - Smalltalk platformName = 'Mac OS' ifTrue: [ - msg _ msg , String newLineString, 'Make sure the sources file is not an Alias.']. - self inform: (msg copyReplaceAll: 'XfileRef' with: 'the sources file named ' , entry pathName) ]. - - "Do not open source files if internalized (i.e. notNil)" - changes _ (SourceFiles at: 2) ifNil: [ - entry _ Smalltalk defaultChangesName asFileEntry. - [ entry appendStream ] on: FileWriteError do: [ nil ] ]. - (changes isNil and: [ Preferences valueOfFlag: #warnIfNoChangesFile ]) - ifTrue: [self inform: (wmsg copyReplaceAll: 'XfileRef' with: 'the changes file named ' , entry pathName)]. - ChangesInitialFileSize _ changes ifNotNil: [ changes position ]. - - SourceFiles _ Array with: sources with: changes! ! - -IdentityDictionary subclass: #SystemDictionary - instanceVariableNames: 'cachedClassNames cachedNonClassNames startUpScriptArguments startUpArguments' - classVariableNames: 'ChangesInitialFileSize EndianCache LastImageName LastQuitLogPosition LowSpaceProcess LowSpaceSemaphore ShutDownList SourceFileVersionString SpecialSelectors StartUpList StartupStamp WordSize' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #SystemDictionary category: #'System-Support'! -IdentityDictionary subclass: #SystemDictionary - instanceVariableNames: 'cachedClassNames cachedNonClassNames startUpScriptArguments startUpArguments' - classVariableNames: 'ChangesInitialFileSize EndianCache LastImageName LastQuitLogPosition LowSpaceProcess LowSpaceSemaphore ShutDownList SourceFileVersionString SpecialSelectors StartUpList StartupStamp WordSize' - poolDictionaries: '' - category: 'System-Support'! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3609-TruncateChangesOnQuitNoSave-JuanVuletich-2019Feb08-23h36m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3609] on 16 February 2019 at 8:06:52 pm'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 2/16/2019 20:06:00' prior: 50369644! -snapshotMessageFor: save andQuit: quit - - | dateAndTime | - dateAndTime _ DateAndTime now. - ^String streamContents: [ :stream | - stream - nextPutAll: self tagHeader; - nextPutAll: (self snapshotTagFor: save andQuit: quit); - nextPutAll: self tagTail. - stream nextPut: $(. - dateAndTime date printOn: stream. - stream space. - dateAndTime time print24: true showSeconds: true on: stream. - stream nextPut: $). - stream - space; - nextPutAll: self imageName asFileEntry name; - nextPutAll: ' priorSource: '; - print: LastQuitLogPosition ].! ! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'jmv 2/16/2019 20:02:34' prior: 16923402! - timeStamp: aStream - "Writes system version and current time on stream aStream." - - | dateTime | - dateTime _ DateAndTime now. - aStream - nextPutAll: 'From '; - nextPutAll: Smalltalk datedVersion; - nextPutAll: ' ['; - nextPutAll: Smalltalk lastUpdateString; - nextPutAll: '] on '. - dateTime date printOn: aStream. - aStream - nextPutAll: ' at '. - dateTime time print24: false showSeconds: true on: aStream! ! -!SystemDictionary methodsFor: 'startup' stamp: 'jmv 2/16/2019 20:03:15' prior: 16925503! - setStartupStamp - - | dateAndTime | - dateAndTime _ DateAndTime now. - StartupStamp _ String streamContents: [ :stream | - stream nextPutAll: '----STARTUP---- ('. - dateAndTime date printOn: stream. - stream space. - dateAndTime time print24: true showSeconds: true on: stream. - stream - nextPutAll: ') as '; - nextPutAll: Smalltalk imageName ] -! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3610-NicerStartupAndSnapshotStamps-JuanVuletich-2019Feb16-19h50m-jmv.1.cs.st----! - -----SNAPSHOT----(16 February 2019 21:33:18) Cuis5.0-3610-v3.image priorSource: 3163412! - -----QUIT----(16 February 2019 21:33:30) Cuis5.0-3610-v3.image priorSource: 3233626! - -----STARTUP---- (15 March 2019 17:27:13) as /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/Cuis5.0-3610-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3598] on 10 February 2019 at 9:09:37 pm'! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'HAW 2/10/2019 21:09:29' prior: 16902967! - namesBeginningWith: aString do: aBlock - "Evaluate aBlock for all available names that start with aString" - - self nonGlobalNamesDo: [ :name | - (name beginsWith: aString) ifTrue: [ aBlock value: name ]]. - Smalltalk namesBeginningWith: aString do: aBlock - -! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3611-CodeStylerTweak-HernanWilkinson-2019Feb06-16h15m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3598] on 14 February 2019 at 5:45:58 pm'! -!TextModelMorph methodsFor: 'initialization' stamp: 'HAW 2/14/2019 17:40:47'! - escAction: aBlock - - self textMorph escAction: aBlock! ! -!InnerTextMorph methodsFor: 'accessing' stamp: 'HAW 2/14/2019 17:37:45'! - escAction - - "Return the action to perform when user presses key" - - ^self valueOfProperty: #escAction! ! -!InnerTextMorph methodsFor: 'accessing' stamp: 'HAW 2/14/2019 17:40:40'! - escAction: aBlock - - "Sets the action to perform when user presses key" - - ^self setProperty: #escAction toValue: aBlock ! ! -!InnerTextMorph methodsFor: 'event handling' stamp: 'HAW 2/14/2019 17:45:05' prior: 16855817! - processKeyStroke: evt - | action | - - (acceptOnCR and: [evt isReturnKey]) ifTrue: [^ self acceptContents]. - - self pauseBlinking. - - "Return - check for special action" - evt isReturnKey ifTrue: [ - action _ self crAction. - action ifNotNil: [ ^action value]]. - - "Esc - check for special action" - evt isEsc ifTrue: [ - action _ self escAction. - action ifNotNil: [ ^action value]]. - - self handleInteraction: [ editor processKeyStroke: evt ]. - - "Is this really needed? It produces whole morph invalidation just by (for example) - moving the cursor around... (jmv Aug 6, 2014)" - "self updateFromTextComposition." - - self scrollSelectionIntoView! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'HAW 2/14/2019 17:42:22' prior: 50385752! - createTextPaneAcceptOnCR: acceptBoolean - "create the textPane" - | result | - - self flag: #todo. "Integrate this method with the Theme system. --cbr" - - result _ TextModelMorph - textProvider: self - textGetter: #response - textSetter: #response: - selectionGetter: #selectionInterval. - - result - hasUnacceptedEdits: true; - acceptOnCR: acceptBoolean; - escAction: [ self cancelClicked ]; - morphExtent: `18@5` * self sizeUnit. - - self addMorph: result position: `1@2` * self sizeUnit. - - ^ result! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3612-EscCancelsFillIntheBlankMorph-HernanWilkinson-2019Feb11-15h04m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3598] on 11 February 2019 at 3:04:48 pm'! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3613-TestCase-MessageCategorization-HernanWilkinson-2019Feb11-14h14m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3612] on 19 February 2019 at 11:50:01 am'! -!SHParserST80 methodsFor: 'aux' stamp: 'jmv 2/19/2019 11:49:22'! - namesBeginningWith: aString do: aBlock in: aCollection - "aCollection is sorted" - " - self new namesBeginningWith: 'O' do: [ :each | each print ] in: Smalltalk classNames - self new namesBeginningWith: 'ObjectExplorer' do: [ :each | each print ] in: Smalltalk classNames - self new namesBeginningWith: 'ObjectExplorerWrapper' do: [ :each | each print ] in: Smalltalk classNames - " - | count | - - "Find the first element starting with aString" - count _ aCollection size. - aCollection - findBinaryIndex: [ :element | - element < aString - ifFalse: [ -1 ] - ifTrue: [ 1 ] ] - do: [ :found | "Will never find any" ] - ifNone: [ :a :b | | i n | - i _ b. - [ i <= count and: [ - n _ aCollection at: i. - aString isEmpty or: [ - n beginsWith: aString ]]] whileTrue: [ - aBlock value: n. - i _ i + 1 ]]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 11:48:10' prior: 50432714! - namesBeginningWith: aString do: aBlock - "Evaluate aBlock for all available names that start with aString" - - self nonGlobalNamesDo: [ :name | - (name beginsWith: aString) ifTrue: [ aBlock value: name ]]. - self namesBeginningWith: aString do: aBlock in: Smalltalk classNames. - self namesBeginningWith: aString do: aBlock in: Smalltalk nonClassNames - -! ! - -SystemDictionary removeSelector: #namesBeginningWith:do:! - -SystemDictionary removeSelector: #namesBeginningWith:do:! - -SystemDictionary removeSelector: #namesBeginningWith:do:in:! - -SystemDictionary removeSelector: #namesBeginningWith:do:in:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3614-CodeColorizerSmallRefactor-JuanVuletich-2019Feb19-11h47m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3612] on 19 February 2019 at 12:26:57 pm'! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'jmv 2/19/2019 12:26:00' prior: 50415515! - computeIdentifierEntries - "Use an aux Set to avoid duplicates, but keep the order given." - | entriesSet lastTitle | - - entriesSet _ Set new. - lastTitle _ nil. - entries _ Array streamContents: [ :strm | - parser namesBeginningWith: prefix do: [ :identifier :kindOfIdentifierTitle | - (entriesSet includes: identifier) ifFalse: [ - kindOfIdentifierTitle = lastTitle ifFalse: [ - strm nextPut: kindOfIdentifierTitle. - lastTitle _ kindOfIdentifierTitle ]. - entriesSet add: identifier. - strm nextPut: identifier ]]]! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:09:28' prior: 16902093! - isBlockArgName: aString - "Answer true if aString is the name of a block argument, false otherwise" - - self blockArgNamesDo: [ :arg :dummy | arg = aString ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:09:18' prior: 16902101! - isBlockTempName: aString - "Answer true if aString is the name of a block temporary. false otherwise" - - self blockTempNamesDo: [ :arg :dummy | arg = aString ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:09:31' prior: 16902130! - isIncompleteBlockArgName: aString - "Answer true if aString is the start of the name of a block argument, false otherwise" - - self blockArgNamesDo: [ :arg :dummy | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:09:21' prior: 16902140! - isIncompleteBlockTempName: aString - "Answer true if aString is the start of the name of a block temporary. false otherwise" - - self blockTempNamesDo: [ :arg :dummy | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:09:05' prior: 16902150! - isIncompleteClassVarName: aString - "Answer true if aString is the start of the name of a class variable, false otherwise" - - self classVarNamesDo: [ :arg :dummy | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:08:54' prior: 16902168! - isIncompleteInstVarName: aString - "Answer true if aString is the start of the name of an instance variable, false otherwise" - - self instVarNamesDo: [ :arg :dummy | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:08:42' prior: 16902178! - isIncompleteMethodArgName: aString - "Answer true if aString is the start of the name of a method argument, false otherwise. - Does not check whether aString is also a blockArgName" - - self methodArgNamesDo: [ :arg :dummy | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:08:34' prior: 16902190! - isIncompleteMethodTempName: aString - "Answer true if aString is the start of the name of a method temporary, false otherwise." - - self methodTempNamesDo: [ :arg :dummy | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:07:49' prior: 16902200! - isIncompletePoolConstantName: aString - "Answer true if aString is the start of the name of a pool constant, false otherwise" - - self poolConstantNamesDo: [ :arg :dummy | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:07:38' prior: 16902219! - isIncompleteWorkspaceVarName: aString - "Answer true if aString is the start of the name of an workspace variable, false otherwise" - - self workspaceNamesDo: [ :arg :dummy | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:08:58' prior: 16902229! - isInstVarName: aString - "Answer true if aString is the name of an instance variable, false otherwise" - - self instVarNamesDo: [ :arg :dummy | arg = aString ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:08:45' prior: 16902238! - isMethodArgName: aString - "Answer true if aString is the name of a method argument, false otherwise. - Does not check whether aString is also a blockArgName" - - self methodArgNamesDo: [ :arg :dummy | arg = aString ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:08:28' prior: 16902248! - isMethodTempName: aString - "Answer true if aString is the name of a method temporary, false otherwise. - Does not check whether aString is also a block temporary - or argument" - - self methodTempNamesDo: [ :arg :dummy | arg = aString ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:23:37' prior: 16902922! - blockArgNamesDo: aBlock - "Iterate over block argument names valid at current blockDepth" - - | title | - title _ '--- Block Arguments ---'. - blockDepth to: 1 by: -1 do: [ :level | - arguments at: level ifPresent: [ :args | args do: [ :name | aBlock value: name value: title ] ]]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:23:47' prior: 16902931! - blockTempNamesDo: aBlock - "Iterate over block temp names valid at current blockDepth" - - | title | - title _ '--- Block Variables ---'. - blockDepth to: 1 by: -1 do: [ :level | - temporaries at: level ifPresent: [ :args | args do: [ :name | aBlock value: name value: title ] ]]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:23:53' prior: 16902940! - classVarNamesDo: aBlock - - | title | - title _ '--- Class Variables ---'. - classOrMetaClass isBehavior - ifTrue: [ - classOrMetaClass theNonMetaClass withAllSuperclasses do: [ :c | - c classPool keysDo: [ :name | aBlock value: name value: title ] ]]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:24:00' prior: 16902948! - instVarNamesDo: aBlock - - | title | - title _ '--- Instance Variables ---'. - instanceVariables do: [ :name | aBlock value: name value: title ]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:24:05' prior: 16902953! - methodArgNamesDo: aBlock - "Iterate over method argument names" - - | title | - title _ '--- Method Arguments ---'. - ^arguments at: 0 ifPresent: [ :args | args do: [ :name | aBlock value: name value: title ] ]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:24:10' prior: 16902960! - methodTempNamesDo: aBlock - "Iterate over method temporary names" - - | title | - title _ '--- Method Variables ---'. - ^temporaries at: 0 ifPresent: [ :args | args do: [ :name | aBlock value: name value: title ] ]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:20:50' prior: 50432839! - namesBeginningWith: aString do: aBlock - "Evaluate aBlock for all available names that start with aString" - - self nonGlobalNamesDo: [ :name :kindOfIdentifierTitle | - (name beginsWith: aString) ifTrue: [ aBlock value: name value: kindOfIdentifierTitle ]]. - self namesBeginningWith: aString do: [ :name | aBlock value: name value: '--- Classes ---' ] in: Smalltalk classNames. - self namesBeginningWith: aString do: [ :name | aBlock value: name value: '--- Globals ---' ] in: Smalltalk nonClassNames! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:24:43' prior: 50368720! - nonGlobalNamesDo: aBlock - "Evaluate aBlock over all available names, except for globals" - - self - blockArgNamesDo: aBlock; - blockTempNamesDo: aBlock; - methodArgNamesDo: aBlock; - methodTempNamesDo: aBlock; - instVarNamesDo: aBlock; - classVarNamesDo: aBlock; - poolConstantNamesDo: aBlock; - workspaceNamesDo: aBlock. - self - reservedNames do: [ :name | - aBlock value: name value: '--- Pseudovariables ---' ]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:24:53' prior: 16902993! - poolConstantNamesDo: aBlock - - | title | - title _ '--- Pool Variables ---'. - classOrMetaClass isBehavior - ifTrue: [ - classOrMetaClass theNonMetaClass withAllSuperclasses do: [ :c | - c sharedPools do: [ :pool | - pool bindingsDo: [ :assoc | aBlock value: assoc key value: title ]]]]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:25:01' prior: 16903009! - workspaceNamesDo: aBlock - - | title | - title _ '--- Workspace Variables ---'. - workspace ifNotNil: [ - workspace bindingNamesDo: [ :name | aBlock value: name value: title ] ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3615-Autocompleter-GroupNamesByKind-JuanVuletich-2019Feb19-11h50m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3590] on 19 February 2019 at 2:11:35 pm'! - -BorderedRectMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity selectorDocumentation originalPosition showUp ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #AutoCompleterMorph category: #'Tools-Autocompletion'! -BorderedRectMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity selectorDocumentation originalPosition showUp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser possibleInvalidSelectors selectorsClasses ' - classVariableNames: 'AccessLock EntriesLimit Selectors ' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #SmalltalkCompleter category: #'Tools-Autocompletion'! -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser possibleInvalidSelectors selectorsClasses' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -SmalltalkCompleter subclass: #DynamicTypingSmalltalkCompleter - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #DynamicTypingSmalltalkCompleter category: #'Tools-Autocompletion'! -SmalltalkCompleter subclass: #DynamicTypingSmalltalkCompleter - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -Object subclass: #AutoCompleterSelectorsCollector - instanceVariableNames: 'categoriesWithSelectors addedSelectorsFastSet prefix entriesToShow possibleInvalidSelectors otherClasses selectorsLimit' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #AutoCompleterSelectorsCollector category: #'Tools-Autocompletion'! -Object subclass: #AutoCompleterSelectorsCollector - instanceVariableNames: 'categoriesWithSelectors addedSelectorsFastSet prefix entriesToShow possibleInvalidSelectors otherClasses selectorsLimit' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -Object subclass: #SHParserST80 - instanceVariableNames: 'classOrMetaClass source workspace arguments sourcePosition currentToken currentTokenFirst temporaries instanceVariables errorBlock currentTokenSourcePosition blockDepth bracketDepth ranges blockDepths blockDepthsStartIndexes allSource ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -!classDefinition: #SHParserST80 category: #'Tools-Syntax Highlighting'! -Object subclass: #SHParserST80 - instanceVariableNames: 'classOrMetaClass source workspace arguments sourcePosition currentToken currentTokenFirst temporaries instanceVariables errorBlock currentTokenSourcePosition blockDepth bracketDepth ranges blockDepths blockDepthsStartIndexes allSource' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! -!TextModel methodsFor: 'shout styling' stamp: 'HAW 1/19/2019 20:23:45'! - shouldStyle: aText with: aSHTextStylerST80 - - ^true! ! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 12:30:03'! - computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 12:30:09'! -computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 12:30:14'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 12:30:20'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 2/6/2019 20:21:41'! - computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName - - textProvider computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName -! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 2/6/2019 20:28:38'! - computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName - - textProvider computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 2/6/2019 19:56:26'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - textProvider computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName -! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 2/6/2019 20:11:16'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - textProvider computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName -! ! -!Workspace methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 12:46:35'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - anAutocompleter computeMessageEntriesForClassOrNil: (self classOfBindingOf: aName)! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 12:30:29'! - computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 12:30:35'! - computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 12:30:44'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 12:30:51'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 2/18/2019 18:18:51'! - computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName - - self computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName -! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 2/6/2019 20:28:21'! - computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName - - ^self computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName ! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 12:35:07'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - contextStackIndex = 0 - ifTrue: [ anAutocompleter computeMessageEntriesForUnknowClass ] - ifFalse: [ anAutocompleter computeMessageEntriesForClass: (self receiver instVarNamed: aName) class]! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 12:35:07'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - | context tempIndex | - - context := self selectedContext. - tempIndex := context tempNames indexOf: aName ifAbsent: [ ^ anAutocompleter computeMessageEntriesForUnknowClass ]. - - anAutocompleter computeMessageEntriesForClass: (self debuggerMap namedTempAt: tempIndex in: context) class - - ! ! -!Inspector methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 12:35:07'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - anAutocompleter computeMessageEntriesForClass: (object instVarNamed: aName) class ! ! -!CompiledMethod methodsFor: 'auto complete' stamp: 'HAW 2/10/2019 17:37:57'! - autoCompleterDocumentationAppendingToParameter: aParameterAppendBlock toReturn: aReturnAppendBlock - - "This message is sent either by the dynamic typing or live typing auto complete. If you do not have - live typing installed you will see one sender, do not refactor it!! - Hernan" - - | methodNode text | - - text := self receiverTextAutoCompleterDocumentation. - - methodNode := self methodNode. - text := self selectorAutoCompleterDocumentationAppendingTo: text using: methodNode appendingToParameter: aParameterAppendBlock. - text := text append: aReturnAppendBlock value. - text := self commentAutoCompleterDocumentationAppendigTo: text using: methodNode. - - ^text! ! -!CompiledMethod methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 18:52:30'! - commentAutoCompleterDocumentationAppendigTo: text using: methodNode - - | comment | - - comment := methodNode comment. - ^ comment - ifNil: [ text ] - ifNotNil: [ text append: (self commentAutoCompleterDocumentationOf: comment)]. - - ! ! -!CompiledMethod methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 18:53:01'! - commentAutoCompleterDocumentationOf: comment - - ^ Text - string: (String streamContents: [ :stream | - stream - newLine; newLine; - nextPutAll: comment first ]) - attributes: (SHTextStylerST80 attributesFor: #comment)! ! -!CompiledMethod methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 18:22:02'! - dynamicTypingAutoCompleterDocumentation - - ^ self - autoCompleterDocumentationAppendingToParameter: [ :parameterName | '' ] - toReturn: [ '' ]! ! -!CompiledMethod methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 18:37:27'! - receiverTextAutoCompleterDocumentation - - | receiverString | - - receiverString := String streamContents: [ :stream | - stream - print: self methodClass; - nextPutAll: '>>' ]. - - ^Text string: receiverString attributes: (SHTextStylerST80 attributesFor: #patternKeyword). - - ! ! -!CompiledMethod methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 18:45:23'! - selectorAutoCompleterDocumentationAppendingTo: sourceText using: methodNode appendingToParameter: aParameterAppendBlock - - | selector text | - - selector := methodNode selectorNode key. - selector isUnary - ifTrue: [ text := sourceText append: (Text string: selector attributes: (SHTextStylerST80 attributesFor: #patternKeyword)) ] - ifFalse: [ - text := sourceText. - selector keywords - with: methodNode argumentNames - do: [ :keyword :argumentName | - text := text append: (Text string: keyword attributes: (SHTextStylerST80 attributesFor: #patternKeyword)). - text := text append: (Text string: ' ', argumentName, ' ' attributes: (SHTextStylerST80 attributesFor: #methodArg)). - text := text append: (aParameterAppendBlock value: argumentName) ] - separatedBy: [ text := text append: String newLineString, String tab ]]. - - ^ text -! ! -!TextEditor methodsFor: 'as yet unclassified' stamp: 'HAW 2/12/2019 17:14:49'! - characterBlockForIndex: anIndex - - ^ textComposition characterBlockForIndex: anIndex ! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'HAW 2/12/2019 18:22:48' prior: 16781439! - resetMenu - - | width newExtent adjustedY | - - self hideSelectorDocumentation. - firstVisible _ 1. - self selected: 1. - - width _ self calculateWidth. - newExtent _ width + 4 @ (self visibleItemsCount * self itemHeight+2). - - adjustedY := (self isYOutOfScreen: originalPosition with: newExtent) - ifTrue: [ originalPosition y - newExtent y - self itemHeight ] - ifFalse: [ originalPosition y ]. - - self morphPosition: originalPosition x @ adjustedY extent: newExtent. -! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/11/2019 20:13:14'! - adjust: aLocation ifOutOfScreenWith: anExtent xOffset: xOffset yOffset: yOffset - - | adjustedLocationX adjustedLocationY | - - adjustedLocationX := (self isXOutOfScreen: aLocation with: anExtent) - ifTrue: [ aLocation x - anExtent x - xOffset ] - ifFalse: [ aLocation x ]. - - adjustedLocationX < 0 ifTrue: [ adjustedLocationX := aLocation x ]. - - adjustedLocationY := (self isYOutOfScreen: aLocation with: anExtent) - ifTrue: [ aLocation y - anExtent y - yOffset ] - ifFalse: [ aLocation y ]. - - ^adjustedLocationX @ adjustedLocationY - ! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/11/2019 18:22:59'! - calculateWidth - - | width font | - - width _ 120. - font _ self class listFont. - - 1 - to: completer entryCount - do: [ :index | width _ width max: (font widthOfString: (completer entries at: index) asString)]. - - completer entryCount > self class itemsPerPage ifTrue: [ width _ width + ScrollBar scrollbarThickness ]. - - ^ width ! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/14/2019 17:10:34'! - colorOf: entry - - ^(completer isPossibleInvalidEntry: entry) - ifTrue: [ `Color blue` ] - ifFalse: [ Theme current text ] - ! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/10/2019 23:23:08'! - drawContainingRectangle: aCanvas - - aCanvas frameAndFillRectangle: (`0@0` extent: extent) fillColor: self color borderWidth: borderWidth borderColor: borderColor. -! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/10/2019 23:55:46'! - drawDownArrowOn: aCanvas thickness: scrollbarThickness - - aCanvas - image: (BitBltCanvas arrowOfDirection: #down size: scrollbarThickness) - at: self downButtonPosition. -! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/10/2019 23:46:59'! - drawItemOf: index on: aCanvas width: width top: itemTop - - | rectangle entry | - - rectangle _ 1@itemTop extent: width@self itemHeight. - index = self selected ifTrue: [ aCanvas fillRectangle: rectangle color: (Theme current listHighlightFocused: true) ]. - - entry _ completer entries at: index. - aCanvas - drawString: entry asString - at: rectangle topLeft - font: self class listFont - color: (self colorOf: entry). - ! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/10/2019 23:51:54'! - drawItemsOn: aCanvas width: width - - | itemTop | - - itemTop _ 1. - self firstVisible - to: self lastVisible - do: [ :index | - self drawItemOf: index on: aCanvas width: width top: itemTop. - itemTop _ itemTop + self itemHeight ].! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/11/2019 00:03:34'! - drawScrollBarMovementBarOn: aCanvas thickness: scrollbarThickness - - | height top bottom | - - height _ extent y - (2 * scrollbarThickness). - top _ (1.0 * self firstVisible-1 / completer entryCount * height) ceiling + 1 + scrollbarThickness-1. - bottom _ (1.0 * self lastVisible / completer entryCount * height) floor + 1 + scrollbarThickness -1. - aCanvas - fillRectangle: (extent x - scrollbarThickness+2@top corner: extent x-2 @ bottom) - color: `Color veryLightGray` ! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/11/2019 00:02:04'! - drawScrollBarOn: aCanvas - - | scrollbarThickness width | - - width _ extent x-2. - completer entryCount > self class itemsPerPage ifTrue: [ - scrollbarThickness _ ScrollBar scrollbarThickness. - width _ width - scrollbarThickness. - - self drawScrollBarRectangleOn: aCanvas thickness: scrollbarThickness. - self drawUpArrowOn: aCanvas thickness: scrollbarThickness. - self drawDownArrowOn: aCanvas thickness: scrollbarThickness. - self drawScrollBarMovementBarOn: aCanvas thickness: scrollbarThickness ]. - - ^width -! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/10/2019 23:57:30'! - drawScrollBarRectangleOn: aCanvas thickness: scrollbarThickness - - aCanvas - frameRectangle: (extent x - scrollbarThickness@0 extent: scrollbarThickness @ extent y) - borderWidth: 1 - color: borderColor. -! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/10/2019 23:54:49'! - drawUpArrowOn: aCanvas thickness: scrollbarThickness - - aCanvas - image: (BitBltCanvas arrowOfDirection: #up size: scrollbarThickness) - at: self upButtonPosition. -! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/14/2019 18:26:25'! - setDefaultColors - - self color: self defaultColor. - self borderColor: self defaultBorderColor ! ! -!AutoCompleterMorph methodsFor: 'selector documentation' stamp: 'HAW 2/8/2019 17:15:51'! - crPressedOnSelectorDocumentation - - self hideSelectorDocumentation. - self activeHand newKeyboardFocus: completer textMorph ! ! -!AutoCompleterMorph methodsFor: 'selector documentation' stamp: 'HAW 2/8/2019 17:13:41'! - hideSelectorDocumentation - - selectorDocumentation ifNotNil: [ selectorDocumentation hide ]. - self stillActive ! ! -!AutoCompleterMorph methodsFor: 'selector documentation' stamp: 'HAW 2/8/2019 17:15:38'! - initializeSelectorDocumentation - - selectorDocumentation := TextModelMorph withText: ''. - selectorDocumentation textMorph - acceptOnCR: false; - crAction: [ self crPressedOnSelectorDocumentation ]. - - selectorDocumentation - wrapFlag: true; - borderColor: Color black; - borderWidth: 1; - disableEditing; - openInWorld - ! ! -!AutoCompleterMorph methodsFor: 'selector documentation' stamp: 'HAW 2/8/2019 17:14:01'! - isShowingSelectorDocumentation - - ^selectorDocumentation notNil and: [ selectorDocumentation visible ]! ! -!AutoCompleterMorph methodsFor: 'selector documentation' stamp: 'HAW 2/8/2019 17:40:55'! - methodDocumentationSeparator - - ^ Text - string: String newLineString, '------------------------------------------------------------------------------------------------', String newLineString - attribute: TextColor black.! ! -!AutoCompleterMorph methodsFor: 'selector documentation' stamp: 'HAW 2/11/2019 16:27:17'! - selectorDefaultDocumentationLocation - - | relativeSelected | - - relativeSelected := (self selected - self firstVisible) min: self class itemsPerPage - 1 max: 0. - - ^location externalizePosition: extent x@(relativeSelected * self itemHeight + 1). - - ! ! -!AutoCompleterMorph methodsFor: 'selector documentation' stamp: 'HAW 2/8/2019 17:12:11'! - selectorDocumentation - - selectorDocumentation ifNil: [ self initializeSelectorDocumentation ]. - ^selectorDocumentation ! ! -!AutoCompleterMorph methodsFor: 'selector documentation' stamp: 'HAW 2/11/2019 16:18:05'! - selectorDocumentationExtent - - ^`600@250`! ! -!AutoCompleterMorph methodsFor: 'selector documentation' stamp: 'HAW 2/8/2019 18:11:20'! - selectorDocumentationText - - | selectedEntry selectorsClasses | - - selectedEntry := completer selectedEntry. - (completer isCategoryEntry: selectedEntry) ifTrue: [ ^'' ]. - selectedEntry := selectedEntry asSymbol. - selectorsClasses := completer selectorsClasses. - - ^ selectorsClasses isEmpty - ifTrue: [ self selectorDocumentationTextForAllImplementorsOf: selectedEntry ] - ifFalse: [ self selectorDocumentationTextOf: selectedEntry forAll: selectorsClasses ]. - ! ! -!AutoCompleterMorph methodsFor: 'selector documentation' stamp: 'HAW 2/18/2019 18:31:56'! - selectorDocumentationTextForAllI: aMethodsCollection - - | selectorDocumentationText implementors methodDocumentationSeparator | - - selectorDocumentationText := Text new. - methodDocumentationSeparator := self methodDocumentationSeparator. - implementors := aMethodsCollection asSortedCollection: [ :leftMethod :rightMethod | leftMethod methodClass classDepth < rightMethod methodClass classDepth ]. - - implementors - do: [ :implementor | selectorDocumentationText := selectorDocumentationText append: (completer documentationOf: implementor)] - separatedBy: [ selectorDocumentationText := selectorDocumentationText append: methodDocumentationSeparator ]. - - ^ selectorDocumentationText! ! -!AutoCompleterMorph methodsFor: 'selector documentation' stamp: 'HAW 2/18/2019 18:16:04'! - selectorDocumentationTextForAllImplementorsOf: selectedEntry - - ^ self selectorDocumentationTextForAllI: (Smalltalk allImplementorsOf: selectedEntry). - - ! ! -!AutoCompleterMorph methodsFor: 'selector documentation' stamp: 'HAW 2/18/2019 18:25:34'! - selectorDocumentationTextOf: selectedEntry forAll: selectorsClasses - - | methodsToShow | - - methodsToShow := selectorsClasses - inject: IdentitySet new - into: [ :methods :aClass | - (aClass lookupSelector: selectedEntry) ifNotNil: [ :method | methods add: method ]. - methods ]. - - ^self selectorDocumentationTextForAllI: methodsToShow ! ! -!AutoCompleterMorph methodsFor: 'selector documentation' stamp: 'HAW 2/14/2019 18:27:16'! - showSelectorDocumentation - - | selectorDocumentationLocation selectorDocumentationExtent | - - selectorDocumentationLocation := self selectorDefaultDocumentationLocation. - selectorDocumentationExtent := self selectorDocumentationExtent. - selectorDocumentationLocation := self adjust: selectorDocumentationLocation ifOutOfScreenWith: selectorDocumentationExtent xOffset: extent x yOffset: self itemHeight negated. - - self setDefaultColors. - - self selectorDocumentation - model: (TextModel withText: self selectorDocumentationText); - morphPosition: selectorDocumentationLocation extent: selectorDocumentationExtent; - wrapFlag: false; - show. - - ! ! -!AutoCompleterMorph methodsFor: 'submorphs-add/remove' stamp: 'HAW 2/8/2019 17:11:23'! - delete - - selectorDocumentation ifNotNil: [ - selectorDocumentation delete. - selectorDocumentation := nil ]. - - ^super delete ! ! -!AutoCompleterMorph methodsFor: 'testing' stamp: 'HAW 2/11/2019 19:45:39'! - isXOutOfScreen: aLocation with: anExtent - - ^aLocation x + anExtent x > DisplayScreen actualScreenSize x! ! -!AutoCompleterMorph methodsFor: 'testing' stamp: 'HAW 2/11/2019 19:43:44'! - isYOutOfScreen: aLocation with: anExtent - - ^aLocation y + anExtent y > DisplayScreen actualScreenSize y! ! -!InnerTextMorph methodsFor: 'accessing' stamp: 'HAW 1/21/2019 00:53:00'! - crAction: aBlock - "Sets the action to perform when user presses key" - ^self setProperty: #crAction toValue: aBlock ! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 12:21:43'! - computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 12:21:54'! - computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 12:22:00'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 12:22:05'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'HAW 1/19/2019 07:07:02'! - isArrowLeft - - ^keyValue = 28! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'HAW 1/18/2019 19:48:13'! - isArrowRight - - ^keyValue = 29 ! ! -!MethodReference methodsFor: 'auto complete' stamp: 'HAW 2/8/2019 18:28:00'! - dynamicTypingAutoCompleterDocumentation - - ^self compiledMethod dynamicTypingAutoCompleterDocumentation ! ! -!MethodReference methodsFor: 'auto complete' stamp: 'HAW 2/18/2019 18:31:40'! - methodClass - - ^self actualClass ! ! -!AutoCompleter methodsFor: 'accessing' stamp: 'HAW 1/21/2019 01:02:40'! - textMorph - - ^textMorph! ! -!AutoCompleter methodsFor: 'entries' stamp: 'HAW 1/19/2019 23:55:50' prior: 16781300! - selectedEntry - - ^self entries at: menuMorph selected! ! -!AutoCompleter methodsFor: 'entries' stamp: 'HAW 2/6/2019 16:22:43'! - selectedEntryFormatted - - ^(self entries at: menuMorph selected), ' '! ! -!AutoCompleter methodsFor: 'testing' stamp: 'HAW 2/8/2019 17:23:31'! - canSelect: anEntry - - ^true! ! -!AutoCompleter methodsFor: 'testing' stamp: 'HAW 2/10/2019 21:35:19'! - isPossibleInvalidEntry: anEntry - - ^false! ! -!SmalltalkCompleter methodsFor: 'entries' stamp: 'HAW 1/19/2019 23:55:29'! - selectedEntryFormatted - - ^(self entries at: menuMorph selected) separateKeywords! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 2/8/2019 17:09:54'! - selectorsClasses - - ^selectorsClasses ! ! -!SmalltalkCompleter methodsFor: 'testing' stamp: 'HAW 2/8/2019 17:29:12'! - canSelect: anEntry - - ^ (self isCategoryEntry: anEntry) not! ! -!SmalltalkCompleter methodsFor: 'testing' stamp: 'HAW 2/8/2019 17:29:29'! - isCategoryEntry: anEntry - - ^anEntry beginsWith: AutoCompleterSelectorsCollector categoryEntryHeader! ! -!SmalltalkCompleter methodsFor: 'testing' stamp: 'HAW 2/10/2019 21:35:32'! - isPossibleInvalidEntry: anEntry - - ^possibleInvalidSelectors includes: anEntry ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 2/8/2019 16:07:20'! - computeEntriesOfUnaryMessageReturnNamed: aSelector at: aRange - - self subclassResponsibility ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 2/8/2019 17:09:54'! - computeMessageEntriesForClass: aClass - - selectorsClasses := Array with: aClass. - - entries := (AutoCompleterSelectorsCollector for: prefix) - addSelectorsOf: aClass; - entriesToShow! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 2/8/2019 12:43:44'! - computeMessageEntriesForClassOrNil: aClassOrNil - - aClassOrNil - ifNil: [ self computeMessageEntriesForUnknowClass ] - ifNotNil: [ self computeMessageEntriesForClass: aClassOrNil ]. - -! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 2/8/2019 16:10:27'! - computeMessageEntriesOfCascadeReceiverAt: aRange - - self subclassResponsibility ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 2/11/2019 00:21:12'! - computeMessageEntriesOfEnclosedExpressionReturnAt: aRange - - self subclassResponsibility ! ! -!SmalltalkCompleter methodsFor: 'message entries for unknown class - private' stamp: 'HAW 2/15/2019 15:40:47'! - computeMessageEntriesForUnknowClass - - | selectorsToShow | - - selectorsClasses _ #(). - possibleInvalidSelectors _ IdentitySet new. - selectorsToShow _ OrderedCollection new. - - self class protected: [ - Selectors forPrefix: prefix keysAndValuesDo: [ :selector :lastUsedTime | - selectorsToShow := self add: selector and: lastUsedTime to: selectorsToShow. - (Object canUnderstand: selector) ifFalse: [ possibleInvalidSelectors add: selector ]]]. - - selectorsToShow size < EntriesLimit ifTrue: [ selectorsToShow _ self sortByLastUsedTime: selectorsToShow ]. - - " To see the timestamps in the menu (need to tweak #insertCompletion: to activate. Right now, just for debugging) - entries _ selectorsToShow collect: [ :ary | ary first, '(', ((DateAndTime fromString: '01/01/1996 00:00') + ary second minutes) printString,')' ] - " - entries _ selectorsToShow collect: [ :selectorAndTime | selectorAndTime first ] - -! ! -!SmalltalkCompleter methodsFor: 'selector documentation' stamp: 'HAW 2/8/2019 18:12:00'! - documentationOf: aMethod - - self subclassResponsibility ! ! -!SmalltalkCompleter class methodsFor: 'instance creation' stamp: 'HAW 2/10/2019 17:44:10'! - withModel: aStringHolder - - "Looks it its subclasses the right autocompleter depending on the Type System. If you do not have - Live Typing installed you will see only one subclass but if Live Typing is intalled LiveTypeingSmalltalkCompleter - subclass is added - Hernan" - - | smalltalkCompleterClass | - - smalltalkCompleterClass := self subclasses detect: [ :aSubclass | aSubclass isForCurrentTypeSystem ]. - - ^smalltalkCompleterClass new setModel: aStringHolder! ! -!SmalltalkCompleter class methodsFor: 'testing' stamp: 'HAW 2/8/2019 15:57:29'! -isForCurrentTypeSystem - - self subclassResponsibility ! ! -!SmalltalkCompleter class methodsFor: 'accessing' stamp: 'HAW 2/15/2019 15:27:22'! - entriesLimit - - ^EntriesLimit ! ! -!DynamicTypingSmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 2/8/2019 16:09:35'! - computeEntriesOfUnaryMessageReturnNamed: aSelector at: aRange - - self computeMessageEntriesForUnknowClass - ! ! -!DynamicTypingSmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 2/8/2019 16:10:08'! - computeMessageEntriesOfCascadeReceiverAt: aRange - - self computeMessageEntriesForUnknowClass - -! ! -!DynamicTypingSmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 2/11/2019 00:21:13'! - computeMessageEntriesOfEnclosedExpressionReturnAt: aRange - - self computeMessageEntriesForUnknowClass - -! ! -!DynamicTypingSmalltalkCompleter methodsFor: 'selector documentation' stamp: 'HAW 2/8/2019 18:13:08'! - documentationOf: aMethod - - ^aMethod dynamicTypingAutoCompleterDocumentation! ! -!DynamicTypingSmalltalkCompleter class methodsFor: 'testing' stamp: 'HAW 2/8/2019 18:35:09'! - isForCurrentTypeSystem - - ^ Smalltalk isLiveTypingInstalled not! ! -!AutoCompleterSelectorsCollector methodsFor: 'initialization' stamp: 'HAW 2/15/2019 15:32:49'! - initializeFor: aPrefix withSelectorsLimitedTo: aLimit - - prefix := aPrefix. - categoriesWithSelectors := OrderedDictionary new. - addedSelectorsFastSet := IdentitySet new. - possibleInvalidSelectors := IdentitySet new. - selectorsLimit := aLimit ! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting' stamp: 'HAW 2/15/2019 15:03:00'! - addSelectorsOf: aClass - - self addSelectorsOf: aClass upTo: nil! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting' stamp: 'HAW 2/15/2019 15:04:08'! - addSelectorsOf: aClass upTo: aSuperclassToExclude - - self addSelectorsOfAll: (Array with: aClass) upTo: aSuperclassToExclude ! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting' stamp: 'HAW 2/15/2019 15:04:18'! - addSelectorsOfAll: classes upTo: aSuperclass - - classes do: [ :aClass | - otherClasses := classes copyWithout: aClass. - self addSelectorsMarkingPossibleInvalidOnesOf: aClass upTo: aSuperclass ]! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting' stamp: 'HAW 2/10/2019 21:54:59'! - addedSelectors: selectors - - addedSelectorsFastSet addAll: selectors ! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting' stamp: 'HAW 2/10/2019 21:32:17'! - possibleInvalidSelectors - - ^possibleInvalidSelectors! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting - private' stamp: 'HAW 2/15/2019 15:34:27'! - addCategoriesAndSelectorsOf: aClass - - | classOrganization | - - classOrganization := aClass organization. - - classOrganization categories do: [ :aCategory | | categorySelectors selectedSelectors | - self hasReachSelectorsLimit ifTrue: [ ^ self ]. - selectedSelectors := self prefixedSelectorsOf: aCategory in: classOrganization. - selectedSelectors isEmpty ifFalse: [ - categorySelectors := categoriesWithSelectors at: aCategory ifAbsentPut: [ OrderedCollection new ]. - categorySelectors addAll: selectedSelectors. - self addedSelectors: selectedSelectors. - self addToPossibleInvalidIfCorrespond: selectedSelectors ]]! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting - private' stamp: 'HAW 2/15/2019 15:35:41'! - addSelectorsMarkingPossibleInvalidOnesOf: aClass upTo: aSuperclassToExclude - - | currentClass | - - currentClass := aClass. - - [ currentClass ~= aSuperclassToExclude and: [ currentClass notNil ] and: [ self hasReachSelectorsLimit not ] ] whileTrue: [ - self addCategoriesAndSelectorsOf: currentClass. - currentClass := currentClass superclass]. - -! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting - private' stamp: 'HAW 2/15/2019 15:19:35'! - addToPossibleInvalidIfCorrespond: selectedSelectors - - selectedSelectors do: [ :aSelector | - (otherClasses allSatisfy: [ :otherClass | otherClass canUnderstand: aSelector ]) ifFalse: [ possibleInvalidSelectors add: aSelector ]]! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting - private' stamp: 'HAW 2/7/2019 18:40:03'! - prefixedSelectorsOf: aCategory in: aClassOrganization - - ^ (aClassOrganization listAtCategoryNamed: aCategory) - select: [ :aSelector | (aSelector beginsWith: prefix) and: [ (addedSelectorsFastSet includes: aSelector) not ] ]. -! ! -!AutoCompleterSelectorsCollector methodsFor: 'entries to show' stamp: 'HAW 2/8/2019 16:25:25'! - entriesToShow - - self hasCollectedOnlyOneSelector - ifTrue: [ entriesToShow := categoriesWithSelectors anyOne ] - ifFalse: [ - entriesToShow := OrderedCollection new. - self - addPrioritizedCategories; - addLeftCategories ]. - - ^entriesToShow - - ! ! -!AutoCompleterSelectorsCollector methodsFor: 'entries to show - private' stamp: 'HAW 2/18/2019 18:26:36'! - addCategory: aCategory with: selectors - - entriesToShow - add: (self categoryEntryFor: aCategory); - addAll: selectors - ! ! -!AutoCompleterSelectorsCollector methodsFor: 'entries to show - private' stamp: 'HAW 2/7/2019 18:26:18'! - addLeftCategories - - categoriesWithSelectors keysAndValuesDo: [ :aCategory :selectors | self addCategory: aCategory with: selectors ]. - ! ! -!AutoCompleterSelectorsCollector methodsFor: 'entries to show - private' stamp: 'HAW 2/7/2019 18:27:10'! - addPrioritizedCategories - - self prioritizedCategories do: [ :aCategory | self addPrioritizedCategory: aCategory ]! ! -!AutoCompleterSelectorsCollector methodsFor: 'entries to show - private' stamp: 'HAW 2/7/2019 18:27:10'! - addPrioritizedCategory: aCategory - - categoriesWithSelectors - at: aCategory - ifPresent: [ :selectors | - self addCategory: aCategory with: selectors. - categoriesWithSelectors removeKey: aCategory ]. -! ! -!AutoCompleterSelectorsCollector methodsFor: 'entries to show - private' stamp: 'HAW 2/8/2019 17:24:26'! - categoryEntryFor: aCategory - - ^self class categoryEntryHeader, aCategory ! ! -!AutoCompleterSelectorsCollector methodsFor: 'entries to show - private' stamp: 'HAW 2/7/2019 18:19:23'! - prioritizedCategories - - ^#('instance creation')! ! -!AutoCompleterSelectorsCollector methodsFor: 'testing' stamp: 'HAW 2/8/2019 16:26:00'! - hasCollectedOnlyOneSelector - - ^ categoriesWithSelectors size = 1 and: [ categoriesWithSelectors anyOne size = 1 ]! ! -!AutoCompleterSelectorsCollector methodsFor: 'testing' stamp: 'HAW 2/15/2019 15:34:27'! - hasReachSelectorsLimit - - ^addedSelectorsFastSet size >= selectorsLimit! ! -!AutoCompleterSelectorsCollector class methodsFor: 'instance creation' stamp: 'HAW 2/15/2019 15:33:47'! - for: aPrefix - - ^self for: aPrefix withSelectorsLimitedTo: SmalltalkCompleter entriesLimit! ! -!AutoCompleterSelectorsCollector class methodsFor: 'instance creation' stamp: 'HAW 2/15/2019 15:33:36'! - for: aPrefix withSelectorsLimitedTo: aLimit - - ^self new initializeFor: aPrefix withSelectorsLimitedTo: aLimit! ! -!AutoCompleterSelectorsCollector class methodsFor: 'category entry' stamp: 'HAW 2/8/2019 17:24:43'! - categoryEntryHeader - - ^ '-- '! ! -!SHParserST80 methodsFor: 'accessing' stamp: 'HAW 2/10/2019 18:35:50'! - allSource - - ^allSource! ! -!SHParserST80 methodsFor: 'accessing' stamp: 'HAW 2/10/2019 18:36:28'! - allSource: aSourceCode - - allSource _ aSourceCode! ! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 1/20/2019 18:47:22' prior: 50417091! - classOfThisContext - - ^ MethodContext ! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 1/20/2019 18:47:47' prior: 50417162! - classOfThisContext - - ^ MethodContext ! ! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'HAW 2/19/2019 14:09:50'! - with: otherCollection do: twoArgBlock separatedBy: separatorBlock - - | beforeFirst | - - beforeFirst := true. - self with: otherCollection do: [ :selfElement :otherCollectionElement | - beforeFirst - ifTrue: [beforeFirst := false] - ifFalse: [separatorBlock value]. - twoArgBlock value: selfElement value: otherCollectionElement ]. - - -! ! -!AutoCompleterMorph methodsFor: 'accessing' stamp: 'HAW 1/19/2019 09:05:56' prior: 16781381! - selected - "Answer the value of selected" - selected ifNil: [ self selected: self firstVisible ]. - ^ selected! ! -!AutoCompleterMorph methodsFor: 'accessing' stamp: 'HAW 2/8/2019 17:14:24' prior: 16781387! - selected: aNumber - - "Set the value of selected" - - ((aNumber between: 1 and: completer entryCount) and: [ aNumber ~= selected ]) - ifTrue: [ - selected _ aNumber. - self isShowingSelectorDocumentation ifTrue: [ self showSelectorDocumentation ]]! ! -!AutoCompleterMorph methodsFor: 'activity tracking' stamp: 'HAW 2/14/2019 18:26:11' prior: 50432299! -updateColor - - | remaining alpha | - - remaining := (self timeout - self timeOfLastActivity). - remaining < 1000 - ifTrue: [ - alpha _ remaining / 1000.0. - self color: (self color alpha: alpha). - self borderColor: (borderColor alpha: alpha) ] - ifFalse: [ self setDefaultColors ] - - ! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/10/2019 23:52:19' prior: 50385037! - downButtonPosition - - ^ `0@0` + (extent - ScrollBar scrollbarThickness)! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/10/2019 23:39:30' prior: 50388245! - drawOn: aCanvas - - | width | - - self drawContainingRectangle: aCanvas. - width _ self drawScrollBarOn: aCanvas. - self drawItemsOn: aCanvas width: width -! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/10/2019 23:52:14' prior: 16781539! - upButtonPosition - - ^extent x - ScrollBar scrollbarThickness@0! ! -!AutoCompleterMorph methodsFor: 'events' stamp: 'HAW 1/19/2019 06:12:38' prior: 50366908! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - (self morphContainsPoint: localEventPosition) - ifTrue: [ - ((self upButtonPosition extent: ScrollBar scrollbarThickness) containsPoint: localEventPosition) - ifTrue: [ ^self stillActive; goUp ]. - ((self downButtonPosition extent: ScrollBar scrollbarThickness) containsPoint: localEventPosition) - ifTrue: [ ^self stillActive; goDown ]. - self selected: (localEventPosition y // self itemHeight) + self firstVisible. - completer insertSelected ] - ifFalse: [ self delete. completer menuClosed ]! ! -!AutoCompleterMorph methodsFor: 'initialization' stamp: 'HAW 2/12/2019 18:22:48' prior: 16781585! - setCompleter: anAutoCompleter position: aPoint - - completer _ anAutoCompleter. - - originalPosition := aPoint. - - self resetMenu. - self openInWorld! ! -!AutoCompleterMorph methodsFor: 'stepping' stamp: 'HAW 2/8/2019 17:14:01' prior: 16781617! - stepAt: millisecondSinceLast - - self isShowingSelectorDocumentation ifTrue: [ ^self ]. - - self timeOfLastActivity > self timeout - ifTrue: [ self delete. completer menuClosed ] - ifFalse: [self updateColor]! ! -!AutoCompleterMorph class methodsFor: 'instance creation' stamp: 'HAW 2/12/2019 17:56:00' prior: 16781678! - completer: anAutoCompleter position: aPoint - - | newObject | - - newObject _ self new. - newObject setCompleter: anAutoCompleter position: aPoint. - - ^ newObject! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 2/6/2019 20:30:26' prior: 50417225! - classOfThisContext - - ^ MethodContext! ! -!AutoCompleter methodsFor: 'menu morph' stamp: 'HAW 2/16/2019 08:33:04' prior: 16781134! - openCompletionMenu - - | theEditor | - - theEditor _ textMorph editor. - position _ theEditor startIndex - 1. - self closeMenu. - self computeEntries. - entries notEmpty - ifTrue: [ | startIndex characterBlock cursorIndex | - cursorIndex := theEditor pointIndex. - startIndex := (theEditor text at: cursorIndex-1) = Character space - ifTrue: [ cursorIndex ] - ifFalse: [ theEditor previousWordStart: (cursorIndex > theEditor text size ifTrue: [ cursorIndex-1 ] ifFalse: [ cursorIndex ])]. - characterBlock := theEditor characterBlockForIndex: startIndex. - menuMorph _ AutoCompleterMorph - completer: self - position: characterBlock bottomLeft + textMorph morphPositionInWorld ]. -! ! -!AutoCompleter methodsFor: 'keyboard' stamp: 'HAW 2/12/2019 18:22:55' prior: 16781156! - handleKeystrokeAfter: aKeyboardEvent - | newPos | - menuMorph ifNil: [^self]. - newPos _ textMorph editor startIndex-1. - newPos = position ifTrue: [^self]. - newPos < position - ifTrue: [ - prefix _ prefix copyFrom: 1 to: prefix size+(newPos-position). - position _ newPos ] - ifFalse: [ - position _ position + 1. - prefix _ prefix copyWith: (model actualContents at: position) ]. - self computeEntries. - entries notEmpty - ifTrue: [ menuMorph resetMenu ] - ifFalse: [ self closeMenu ]! ! -!AutoCompleter methodsFor: 'keyboard' stamp: 'HAW 2/8/2019 17:14:24' prior: 50415181! - handleKeystrokeBefore: kbEvent - - "I return a boolean. true when I have handled the event and no futher processing is needed by the caller." - - | shouldOpenMorph | - - shouldOpenMorph _ self shouldOpenMorph. - - "Stuff to do if the menu is not open" - menuMorph ifNil: [ ^ self openCompletionMenuFor: kbEvent if: shouldOpenMorph ]. - - "Starting here, stuff to do if the menu is open" - menuMorph stillActive. - - kbEvent isEsc ifTrue: [ self closeMenu. ^ true]. - kbEvent isBackspace ifTrue: [ shouldOpenMorph ifFalse: [ self closeMenu ]. ^ false]. - kbEvent isHome ifTrue: [ menuMorph goHome. ^ true ]. - kbEvent isEnd ifTrue: [ menuMorph goToEnd. ^ true]. - kbEvent isQuesitonMark ifTrue: [ menuMorph help. ^true]. - kbEvent isArrowUp ifTrue: [ menuMorph goUp. ^ true]. - kbEvent isArrowDown ifTrue: [ menuMorph goDown. ^ true]. - kbEvent isPageUp ifTrue: [ menuMorph goPageUp. ^ true]. - kbEvent isPageDown ifTrue: [ menuMorph goPageDown. ^ true]. - kbEvent isArrowRight ifTrue: [ menuMorph showSelectorDocumentation. ^ true ]. - kbEvent isArrowLeft ifTrue: [ menuMorph hideSelectorDocumentation. ^ true ]. - (self shouldInsertSelected: kbEvent) ifTrue: [ self insertSelected ifTrue: [^ true]]. - (self shouldCloseMenu: kbEvent) ifTrue: [ self closeMenu ]. - - ^false! ! -!AutoCompleter methodsFor: 'entries' stamp: 'HAW 2/8/2019 17:27:05' prior: 16781274! - insertSelected - - | entry editor selEnd str | - - textMorph ifNil: [ ^false ]. - - entry _ self selectedEntryFormatted. - (self canSelect: entry) ifFalse: [ ^true ]. - - editor _ textMorph editor. - str _ model actualContents string. - selEnd _ position. - [selEnd < str size and: [ (str at: selEnd+1) tokenish ]] whileTrue: [ selEnd _ selEnd + 1 ]. - (selEnd < str size and: [ (str at: selEnd+1) = $ ]) ifTrue: [ selEnd _ selEnd + 1]. - editor selectFrom: position-prefix size+1 to: selEnd. - editor - replaceSelectionWith: entry; - deselectAndPlaceCursorAt: position - prefix size + 1 + (self newCursorPosition: entry). - textMorph redrawNeeded. - menuMorph delete. - menuMorph _ nil. - - ^ true! ! -!SmalltalkCompleter methodsFor: 'entries' stamp: 'HAW 2/10/2019 21:38:01' prior: 50417249! - computeEntries - - | allSource contextClass specificModel last3Ranges range | - - allSource _ model actualContents string. - specificModel _ self textProviderOrModel. - contextClass _ self selectedClassOrMetaClassIn: specificModel. - last3Ranges _ self parse: allSource in: contextClass and: specificModel. - range _ last3Ranges third ifNil: [ ^entries _ #() ]. - possibleInvalidSelectors _ #(). - - range end = position - ifTrue: [ self computeEntriesOfMessageOrIdentifiersFor: allSource using: last3Ranges at: range in: contextClass and: specificModel ] - ifFalse: [ self computeMessageEntriesWithEmptyPrefixFor: allSource at: range in: contextClass and: specificModel ]. - - ! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 2/10/2019 18:35:24' prior: 50415429! - parse: allSource in: contextClass and: specificModel - - parser _ SHParserST80 new. - parser - workspace: ((specificModel is: #providesBindings) ifTrue: [specificModel]); - classOrMetaClass: contextClass; - source: (allSource copyFrom: 1 to: position); - allSource: allSource. - parser parse: (specificModel is: #CodeProvider). - - ^ parser last3Ranges. -! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 2/18/2019 18:13:38' prior: 50429707! - computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel - - | id rangeType | - - id _ allSource copyFrom: range start to: range end. - rangeType _ range rangeType. - - rangeType == #globalVar ifTrue: [ ^self computeMessageEntriesForClass: (Smalltalk at: id asSymbol) class ]. - rangeType == #self ifTrue: [ ^self computeMessageEntriesForClass: contextClass ]. - rangeType == #super ifTrue: [ ^self computeMessageEntriesForClass: contextClass superclass ]. - rangeType == #true ifTrue: [ ^self computeMessageEntriesForClass: True ]. - rangeType == #false ifTrue: [ ^self computeMessageEntriesForClass: False ]. - rangeType == #nil ifTrue: [ ^self computeMessageEntriesForClass: UndefinedObject ]. - rangeType == #character ifTrue: [ ^self computeMessageEntriesForClass: id first class ]. - rangeType == #number ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #string ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #symbol ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #stringSymbol ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #instVar ifTrue: [ ^specificModel computeMessageEntriesIn: self ofInstVarNamed: id ]. - rangeType == #methodArg ifTrue: [ ^specificModel computeMessageEntriesIn: self ofTempVarNamed: id ]. - rangeType == #tempVar ifTrue: [ ^specificModel computeMessageEntriesIn: self ofTempVarNamed: id ]. - rangeType == #blockArg ifTrue: [ ^specificModel computeMessageEntriesIn: self ofBlockArgNamed: id ]. - rangeType == #blockTempVar ifTrue: [ ^specificModel computeMessageEntriesIn: self ofBlockTempVarNamed: id ]. - rangeType == #workspaceVar ifTrue: [ ^self computeMessageEntriesForClassOrNil: (specificModel classOfWorkspaceVarNamed: id) ]. - rangeType == #thisContext ifTrue: [ ^self computeMessageEntriesForClass: (specificModel classOfThisContext) ]. - rangeType == #classVar ifTrue: [ ^self computeMessageEntriesForClassOrNil: (self classOfLocalBindingNamed: id in: contextClass) ]. - rangeType == #poolConstant ifTrue: [ ^self computeMessageEntriesForClassOrNil: (self classOfLocalBindingNamed: id in: contextClass) ]. - rangeType == #blockEnd ifTrue: [ ^self computeMessageEntriesForClass: BlockClosure ]. - rangeType == #arrayEnd ifTrue: [ ^self computeMessageEntriesForClass: Array ]. - rangeType == #rightBrace ifTrue: [ ^self computeMessageEntriesForClass: Array ]. - rangeType == #unary ifTrue: [ ^self computeEntriesOfUnaryMessageReturnNamed: id at: range ]. - rangeType == #rightParenthesis ifTrue: [ ^self computeMessageEntriesOfEnclosedExpressionReturnAt: range ]. - rangeType == #cascadeSeparator ifTrue: [ ^self computeMessageEntriesOfCascadeReceiverAt: range ]. - - self computeMessageEntriesForUnknowClass - - ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 2/8/2019 12:18:59' prior: 50415017! - computeMessageEntriesWhenSendinMessageFor: allSource using: last3Ranges in: contextClass and: specificModel - - | prevPrevRange prevRange | - - "If previous range is a constant or a well known identifier, we might filter messages" - prevRange _ last3Ranges second. - prevPrevRange _ last3Ranges first. - - "3 if -> ifNil: but not ifTrue: - 3=4 -> ifNil: or ifTrue:" - ^ (self canComputeMessageEntriesFor: prevRange and: prevPrevRange) - ifTrue: [ self computeMessageEntriesFor: allSource at: prevRange in: contextClass and: specificModel ] - ifFalse: [ self computeMessageEntriesForUnknowClass ] -! ! -!SmalltalkCompleter class methodsFor: 'class initialization' stamp: 'HAW 2/15/2019 15:36:56' prior: 50424406! - initialize - " - It takes about 6 seconds, mostly because of the time to fetch method stamps from source files... - [ SmalltalkCompleter initialize ]timeToRun - Selectors inspect - " - | maxSortValue allImplemented | - - EntriesLimit _ 100. - - SystemChangeNotifier uniqueInstance - removeActionsWithReceiver: self. "avoid double registration" - - SystemChangeNotifier uniqueInstance - when: #classRemoved send: #classRemoved:fromCategory: to: self; - when: #methodAdded send: #methodAdded:selector:inClass:requestor: to: self; - when: #methodAddedInProtocol send: #methodAdded:selector:inProtocol:class:requestor: to: self; - when: #methodRemoved send: #methodRemoved:selector:inProtocol:class: to: self. - - self protected: [ - allImplemented _ Smalltalk allImplementedMessages. - Selectors _ Trie new. - " - Smalltalk allBehaviorsDo: [:class | - class selectorsAndMethodsDo: [ :sel :method | - Selectors at: sel ifAbsentPut: [ 0 ]. - method messages do: [ :sentMsg | - Selectors at: sentMsg put: (Selectors at: sentMsg ifAbsent: [ 0 ]) + 1 ]]]. - " - Smalltalk allBehaviorsDo: [:class | - class selectorsAndMethodsDo: [ :sel :method | - self addSelector: sel method: method allImplemented: allImplemented]]. - "" - - "The following might not be found in #messages. Give them maximum priority." - maxSortValue _ SmallInteger maxVal. - "From MessageNode>>#initialize" - #( ifTrue: ifFalse: ifTrue:ifFalse: ifFalse:ifTrue: - and: or: - whileFalse: whileTrue: whileFalse whileTrue - to:do: to:by:do: - caseOf: caseOf:otherwise: - ifNil: ifNotNil: ifNil:ifNotNil: ifNotNil:ifNil:) do: [ :sel | - Selectors at: sel put: maxSortValue ]. - - maxSortValue _ SmallInteger maxVal-1. - "From SystemDictionary >>#recreateSpecialObjectsArray" - (1 to: Smalltalk specialSelectorSize) do: [ :i | - Selectors at: (Smalltalk specialSelectorAt: i) put: maxSortValue ]]! ! - -AutoCompleterSelectorsCollector class removeSelector: #for:limitingNumberOfSelectorsTo:! - -AutoCompleterSelectorsCollector class removeSelector: #for:withALimitOf:! - -AutoCompleterSelectorsCollector removeSelector: #addEntriesToShowTo:! - -AutoCompleterSelectorsCollector removeSelector: #addPrioritzedCategory:! - -AutoCompleterSelectorsCollector removeSelector: #addPrioritzedCategory:with:! - -AutoCompleterSelectorsCollector removeSelector: #hasReachNumberOfSelectorsLimit! - -AutoCompleterSelectorsCollector removeSelector: #initialize! - -AutoCompleterSelectorsCollector removeSelector: #initializeFor:! - -AutoCompleterSelectorsCollector removeSelector: #initializeFor:limitingNumberOfSelectorsTo:! - -AutoCompleterSelectorsCollector removeSelector: #markAddedSelectorsAsPossibleInvalid! - -AutoCompleterSelectorsCollector removeSelector: #priorizeCategories! - -DynamicTypingSmalltalkCompleter removeSelector: #computeMessageEntriesOfOfEnclosedExpressionReturnAt:! - -SmalltalkCompleter removeSelector: #computeMessageEntries:! - -SmalltalkCompleter removeSelector: #computeMessageEntries:! - -SmalltalkCompleter removeSelector: #computeMessageEntriesForSelectors:! - -SmalltalkCompleter removeSelector: #computeMessageEntriesForSelectors:! - -SmalltalkCompleter removeSelector: #returnTypeOfEnclosedExpressionAt:! - -SmalltalkCompleter removeSelector: #returnTypeOfEnclosedExpressionAt:! - -SmalltalkCompleter removeSelector: #returnTypeOfUnaryMessage:at:! - -SmalltalkCompleter removeSelector: #returnTypeOfUnaryMessage:at:! - -SmalltalkCompleter removeSelector: #selectedEntry! - -SmalltalkCompleter removeSelector: #selectedEntry! - -SmalltalkCompleter removeSelector: #typeOfCascadeReceiverAt:! - -SmalltalkCompleter removeSelector: #typeOfCascadeReceiverAt:! - -SmalltalkCompleter removeSelectorIfInBaseSystem: #withMethodNodeOf:do:ifError:! - -SmalltalkCompleter removeSelector: #withMethodNodeOf:do:ifError:! - -SmalltalkCompleter removeSelectorIfInBaseSystem: #withMethodNodeOfAllSourceCodeDo:ifError:! - -SmalltalkCompleter removeSelector: #withMethodNodeOfAllSourceCodeDo:ifError:! - -AutoCompleter removeSelector: #keyStroke:! - -ClassNameRequestMorph removeSelector: #classOfBlockArgNamed:! - -ClassNameRequestMorph removeSelector: #classOfBlockArgNamed:! - -ClassNameRequestMorph removeSelector: #classOfBlockTempVarNamed:! - -ClassNameRequestMorph removeSelector: #classOfBlockTempVarNamed:! - -ClassNameRequestMorph removeSelector: #classOfInstVarNamed:! - -ClassNameRequestMorph removeSelector: #classOfInstVarNamed:! - -ClassNameRequestMorph removeSelector: #classOfTempVarNamed:! - -ClassNameRequestMorph removeSelector: #classOfTempVarNamed:! - -AutoCompleterMorph removeSelector: #adjust:ifOutOfScreenWith:! - -AutoCompleterMorph removeSelector: #adjust:ifOutOfScreenWith:xOffset:! - -AutoCompleterMorph removeSelector: #adjustPositionIfOutOfScreen! - -AutoCompleterMorph removeSelector: #adjustPositionIfOutOfScreen:! - -AutoCompleterMorph removeSelector: #adjustedIfOutOfScreen:! - -AutoCompleterMorph removeSelector: #drawItemOn:width:! - -AutoCompleterMorph removeSelector: #isOutOfScreen:with:! - -AutoCompleterMorph removeSelector: #privateExtent:! - -AutoCompleterMorph removeSelector: #resetMenu:! - -AutoCompleterMorph removeSelector: #selectorDocumentationLocation! - -AutoCompleterMorph removeSelector: #testxxx! - -AutoCompleterMorph removeSelector: #testxxxxx! - -Inspector removeSelector: #classOfInstVarNamed:! - -Inspector removeSelector: #classOfInstVarNamed:! - -Debugger removeSelector: #classOfBlockArgNamed:! - -Debugger removeSelector: #classOfBlockArgNamed:! - -Debugger removeSelector: #classOfBlockTempVarNamed:! - -Debugger removeSelector: #classOfBlockTempVarNamed:! - -Debugger removeSelector: #classOfInstVarNamed:! - -Debugger removeSelector: #classOfInstVarNamed:! - -Debugger removeSelector: #classOfTempVarNamed:! - -Debugger removeSelector: #classOfTempVarNamed:! - -TextProvider removeSelector: #classOfBlockArgNamed:! - -TextProvider removeSelector: #classOfBlockArgNamed:! - -TextProvider removeSelector: #classOfBlockTempVarNamed:! - -TextProvider removeSelector: #classOfBlockTempVarNamed:! - -TextProvider removeSelector: #classOfInstVarNamed:! - -TextProvider removeSelector: #classOfInstVarNamed:! - -TextProvider removeSelector: #classOfTempVarNamed:! - -TextProvider removeSelector: #classOfTempVarNamed:! - -Workspace removeSelector: #classOfTempVarNamed:! - -Workspace removeSelector: #classOfTempVarNamed:! - -PluggableTextModel removeSelector: #classOfBlockArgNamed:! - -PluggableTextModel removeSelector: #classOfBlockArgNamed:! - -PluggableTextModel removeSelector: #classOfBlockTempVarNamed:! - -PluggableTextModel removeSelector: #classOfBlockTempVarNamed:! - -PluggableTextModel removeSelector: #classOfInstVarNamed:! - -PluggableTextModel removeSelector: #classOfInstVarNamed:! - -PluggableTextModel removeSelector: #classOfTempVarNamed:! - -PluggableTextModel removeSelector: #classOfTempVarNamed:! - -TextModel removeSelector: #classOfBlockArgNamed:! - -TextModel removeSelector: #classOfBlockArgNamed:! - -TextModel removeSelector: #classOfBlockTempVarNamed:! - -TextModel removeSelector: #classOfBlockTempVarNamed:! - -TextModel removeSelector: #classOfInstVarNamed:! - -TextModel removeSelector: #classOfInstVarNamed:! - -TextModel removeSelector: #classOfTempVarNamed:! - -TextModel removeSelector: #classOfTempVarNamed:! - -BorderedRectMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity selectorDocumentation originalPosition showUp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #AutoCompleterMorph category: #'Tools-Autocompletion'! -BorderedRectMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity selectorDocumentation originalPosition showUp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser selectorsClasses possibleInvalidSelectors' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #SmalltalkCompleter category: #'Tools-Autocompletion'! -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser selectorsClasses possibleInvalidSelectors' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -SmalltalkCompleter initialize! - -Object subclass: #SHParserST80 - instanceVariableNames: 'classOrMetaClass source workspace arguments sourcePosition currentToken currentTokenFirst temporaries instanceVariables errorBlock currentTokenSourcePosition blockDepth bracketDepth ranges blockDepths blockDepthsStartIndexes allSource' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -!classDefinition: #SHParserST80 category: #'Tools-Syntax Highlighting'! -Object subclass: #SHParserST80 - instanceVariableNames: 'classOrMetaClass source workspace arguments sourcePosition currentToken currentTokenFirst temporaries instanceVariables errorBlock currentTokenSourcePosition blockDepth bracketDepth ranges blockDepths blockDepthsStartIndexes allSource' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3616-AutoCompleterBigRefactor-HernanWilkinson-2019Jan18-00h58m-HAW.4.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3590] on 19 February 2019 at 2:19:45 pm'! -!MethodNode methodsFor: 'accessing' stamp: 'HAW 2/19/2019 14:19:05'! - argumentNames - - ^arguments collect: [ :anArgumentNode | anArgumentNode name ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3617-MethodNode-argumentNames-HernanWilkinson-2019Feb19-14h11m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3612] on 19 February 2019 at 12:26:57 pm'! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'jmv 2/19/2019 12:26:00' prior: 50432869! - computeIdentifierEntries - "Use an aux Set to avoid duplicates, but keep the order given." - | entriesSet lastTitle | - - entriesSet _ Set new. - lastTitle _ nil. - entries _ Array streamContents: [ :strm | - parser namesBeginningWith: prefix do: [ :identifier :kindOfIdentifierTitle | - (entriesSet includes: identifier) ifFalse: [ - kindOfIdentifierTitle = lastTitle ifFalse: [ - strm nextPut: kindOfIdentifierTitle. - lastTitle _ kindOfIdentifierTitle ]. - entriesSet add: identifier. - strm nextPut: identifier ]]]! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:09:28' prior: 50432889! - isBlockArgName: aString - "Answer true if aString is the name of a block argument, false otherwise" - - self blockArgNamesDo: [ :arg :dummy | arg = aString ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:09:18' prior: 50432898! - isBlockTempName: aString - "Answer true if aString is the name of a block temporary. false otherwise" - - self blockTempNamesDo: [ :arg :dummy | arg = aString ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:09:31' prior: 50432907! - isIncompleteBlockArgName: aString - "Answer true if aString is the start of the name of a block argument, false otherwise" - - self blockArgNamesDo: [ :arg :dummy | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:09:21' prior: 50432917! - isIncompleteBlockTempName: aString - "Answer true if aString is the start of the name of a block temporary. false otherwise" - - self blockTempNamesDo: [ :arg :dummy | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:09:05' prior: 50432927! - isIncompleteClassVarName: aString - "Answer true if aString is the start of the name of a class variable, false otherwise" - - self classVarNamesDo: [ :arg :dummy | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:08:54' prior: 50432937! - isIncompleteInstVarName: aString - "Answer true if aString is the start of the name of an instance variable, false otherwise" - - self instVarNamesDo: [ :arg :dummy | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:08:42' prior: 50432947! - isIncompleteMethodArgName: aString - "Answer true if aString is the start of the name of a method argument, false otherwise. - Does not check whether aString is also a blockArgName" - - self methodArgNamesDo: [ :arg :dummy | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:08:34' prior: 50432959! - isIncompleteMethodTempName: aString - "Answer true if aString is the start of the name of a method temporary, false otherwise." - - self methodTempNamesDo: [ :arg :dummy | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:07:49' prior: 50432970! - isIncompletePoolConstantName: aString - "Answer true if aString is the start of the name of a pool constant, false otherwise" - - self poolConstantNamesDo: [ :arg :dummy | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:07:38' prior: 50432981! - isIncompleteWorkspaceVarName: aString - "Answer true if aString is the start of the name of an workspace variable, false otherwise" - - self workspaceNamesDo: [ :arg :dummy | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:08:58' prior: 50432992! - isInstVarName: aString - "Answer true if aString is the name of an instance variable, false otherwise" - - self instVarNamesDo: [ :arg :dummy | arg = aString ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:08:45' prior: 50433001! - isMethodArgName: aString - "Answer true if aString is the name of a method argument, false otherwise. - Does not check whether aString is also a blockArgName" - - self methodArgNamesDo: [ :arg :dummy | arg = aString ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 2/19/2019 12:08:28' prior: 50433012! - isMethodTempName: aString - "Answer true if aString is the name of a method temporary, false otherwise. - Does not check whether aString is also a block temporary - or argument" - - self methodTempNamesDo: [ :arg :dummy | arg = aString ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:23:37' prior: 50433024! - blockArgNamesDo: aBlock - "Iterate over block argument names valid at current blockDepth" - - | title | - title _ '-- Block Arguments'. - blockDepth to: 1 by: -1 do: [ :level | - arguments at: level ifPresent: [ :args | args do: [ :name | aBlock value: name value: title ] ]]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:23:47' prior: 50433036! - blockTempNamesDo: aBlock - "Iterate over block temp names valid at current blockDepth" - - | title | - title _ '-- Block Variables'. - blockDepth to: 1 by: -1 do: [ :level | - temporaries at: level ifPresent: [ :args | args do: [ :name | aBlock value: name value: title ] ]]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:23:53' prior: 50433048! - classVarNamesDo: aBlock - - | title | - title _ '-- Class Variables'. - classOrMetaClass isBehavior - ifTrue: [ - classOrMetaClass theNonMetaClass withAllSuperclasses do: [ :c | - c classPool keysDo: [ :name | aBlock value: name value: title ] ]]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:24:00' prior: 50433060! - instVarNamesDo: aBlock - - | title | - title _ '-- Instance Variables'. - instanceVariables do: [ :name | aBlock value: name value: title ]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:24:05' prior: 50433068! - methodArgNamesDo: aBlock - "Iterate over method argument names" - - | title | - title _ '-- Method Arguments'. - ^arguments at: 0 ifPresent: [ :args | args do: [ :name | aBlock value: name value: title ] ]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:24:10' prior: 50433078! - methodTempNamesDo: aBlock - "Iterate over method temporary names" - - | title | - title _ '-- Method Variables'. - ^temporaries at: 0 ifPresent: [ :args | args do: [ :name | aBlock value: name value: title ] ]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:20:50' prior: 50433088! - namesBeginningWith: aString do: aBlock - "Evaluate aBlock for all available names that start with aString" - - self nonGlobalNamesDo: [ :name :kindOfIdentifierTitle | - (name beginsWith: aString) ifTrue: [ aBlock value: name value: kindOfIdentifierTitle ]]. - self namesBeginningWith: aString do: [ :name | aBlock value: name value: '-- Classes' ] in: Smalltalk classNames. - self namesBeginningWith: aString do: [ :name | aBlock value: name value: '-- Globals' ] in: Smalltalk nonClassNames! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:24:43' prior: 50433107! - nonGlobalNamesDo: aBlock - "Evaluate aBlock over all available names, except for globals" - - self - blockArgNamesDo: aBlock; - blockTempNamesDo: aBlock; - methodArgNamesDo: aBlock; - methodTempNamesDo: aBlock; - instVarNamesDo: aBlock; - classVarNamesDo: aBlock; - poolConstantNamesDo: aBlock; - workspaceNamesDo: aBlock. - self - reservedNames do: [ :name | - aBlock value: name value: '-- Pseudovariables' ]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:24:53' prior: 50433124! - poolConstantNamesDo: aBlock - - | title | - title _ '-- Pool Variables'. - classOrMetaClass isBehavior - ifTrue: [ - classOrMetaClass theNonMetaClass withAllSuperclasses do: [ :c | - c sharedPools do: [ :pool | - pool bindingsDo: [ :assoc | aBlock value: assoc key value: title ]]]]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/19/2019 12:25:01' prior: 50433137! - workspaceNamesDo: aBlock - - | title | - title _ '-- Workspace Variables'. - workspace ifNotNil: [ - workspace bindingNamesDo: [ :name | aBlock value: name value: title ] ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3618-Autocompleter-GroupNamesByKind-JuanVuletich-2019Feb19-11h50m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3618] on 20 February 2019 at 6:32:54 pm'! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/20/2019 18:21:26'! - defaultFont11 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont11 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 11) - (setListFontTo: 11) - (setMenuFontTo: 12) - (setWindowTitleFontTo: 14) - (setCodeFontTo: 11) - (setButtonFontTo: 11)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/20/2019 18:21:31'! - defaultFont14 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont14 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 14) - (setListFontTo: 14) - (setMenuFontTo: 14) - (setWindowTitleFontTo: 17) - (setCodeFontTo: 14) - (setButtonFontTo: 14)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/20/2019 18:21:37'! - defaultFont17 - "Sets not only fonts but other GUI elements - to fit high resolution or large screens - Preferences defaultFont17 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 17) - (setListFontTo: 17) - (setMenuFontTo: 17) - (setWindowTitleFontTo: 22) - (setCodeFontTo: 17) - (setButtonFontTo: 17)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/20/2019 18:21:43'! - defaultFont22 - "Sets not only fonts but other GUI elements - to fit high resolution or large screens - Preferences defaultFont22 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 22) - (setListFontTo: 22) - (setMenuFontTo: 22) - (setWindowTitleFontTo: 28) - (setCodeFontTo: 22) - (setButtonFontTo: 22)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/20/2019 18:15:18'! - defaultFont28 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont28 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 28) - (setListFontTo: 28) - (setMenuFontTo: 28) - (setWindowTitleFontTo: 36) - (setCodeFontTo: 28) - (setButtonFontTo: 28)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/20/2019 18:16:03'! - defaultFont36 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont36 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 36) - (setListFontTo: 36) - (setMenuFontTo: 36) - (setWindowTitleFontTo: 46) - (setCodeFontTo: 36) - (setButtonFontTo: 36)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/20/2019 18:17:21'! - defaultFont46 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont46 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 46) - (setListFontTo: 46) - (setMenuFontTo: 46) - (setWindowTitleFontTo: 60) - (setCodeFontTo: 46) - (setButtonFontTo: 46)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/20/2019 18:17:47'! - defaultFont60 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont60 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 60) - (setListFontTo: 60) - (setMenuFontTo: 60) - (setWindowTitleFontTo: 80) - (setCodeFontTo: 60) - (setButtonFontTo: 60)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/20/2019 18:11:33'! - defaultFont8 - "Sets not only fonts but other GUI elements - to fit low resolution or small screens - Preferences defaultFont8 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 8) - (setListFontTo: 8) - (setMenuFontTo: 8) - (setWindowTitleFontTo: 11) - (setCodeFontTo: 8) - (setButtonFontTo: 8)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/20/2019 18:18:00'! - defaultFont80 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont80 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 80) - (setListFontTo: 80) - (setMenuFontTo: 80) - (setWindowTitleFontTo: 80) - (setCodeFontTo: 80) - (setButtonFontTo: 80)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/20/2019 18:20:55'! - defaultFont9 - "Sets not only fonts but other GUI elements - to fit low resolution or small screens - Preferences defaultFont9 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 9) - (setListFontTo: 9) - (setMenuFontTo: 10) - (setWindowTitleFontTo: 12) - (setCodeFontTo: 9) - (setButtonFontTo: 9)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/20/2019 18:12:32' prior: 50397731! - standardFonts - "Sets not only fonts but other GUI elements - to fit regular resolution and size screens - Preferences standardFonts - " - - self defaultFont9! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/20/2019 18:21:06' prior: 50397787! - verySmallFonts - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences verySmallFonts - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 8) - (setListFontTo: 7) - (setMenuFontTo: 7) - (setWindowTitleFontTo: 9) - (setCodeFontTo: 7) - (setButtonFontTo: 7)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!StrikeFont class methodsFor: 'instance creation' stamp: 'jmv 2/20/2019 18:03:06' prior: 50372561! - install: aString -" -StrikeFont install: 'DejaVu'. - -StrikeFont install: 'DejaVu Sans'. -StrikeFont buildLargerPunctuation: 'DejaVu Sans'. -Preferences setDefaultFontFamilyTo: 'DejaVu Sans'. -Preferences standardFonts. -Character initialize. -" -" -StrikeFont install: 'DejaVu Sans Mono'. -Preferences setDefaultFontFamilyTo: 'DejaVu Sans Mono'. -Preferences bigFonts. -Character initialize. -" -" -StrikeFont install: 'Inconsolata' -StrikeFont install: '#PilGi' -StrikeFont install: 'Optima' -StrikeFont install: 'Herculanum' -StrikeFont install: 'Papyrus' -StrikeFont install: 'Handwriting - Dakota' -StrikeFont install: 'Times New Roman' -StrikeFont install: 'Apple Chancery' -StrikeFont install: 'Cochin' -StrikeFont install: 'Cracked' -StrikeFont install: 'Zapfino' -StrikeFont install: 'Brush Script MT' -StrikeFont install: 'Chalkboard' -" - | fontDict | - fontDict _ AvailableFonts at: aString ifAbsentPut: Dictionary new. - #(5 6 7 8 9 10 11 12 14 17 22 28 36 48 60 80) do: [ :s | - (self create: aString size: s bold: true italic: true boldItalic: false) ifNotNil: [ :font | - fontDict - at: s - put: font ]]. - Preferences restoreDefaultFonts! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/6/2018 16:21:32' prior: 50397858! - preferencesMenu - "Build the preferences menu for the world." - - ^ (self menu: 'Preferences...') - addItemsFromDictionaries: `{ - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Font Sizes...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }`! ! -!Theme class methodsFor: 'user interface' stamp: 'jmv 2/20/2019 18:32:44' prior: 50397951! - changeFontSizes - | availableSizes menu | - availableSizes _ AbstractFont pointSizesFor: Preferences defaultFontFamily. - menu _ (MenuMorph new defaultTarget: Preferences) - addTitle: 'Choose a size'; - addStayUpIcons. - (availableSizes includes: 80) ifTrue: [ - menu add: 'Very High Resolution / Big Fonts (80pix)' action: #defaultFont80 ]. - (availableSizes includes: 80) ifTrue: [ - menu add: 'Very High Resolution / Big Fonts (60pix)' action: #defaultFont60 ]. - (availableSizes includes: 60) ifTrue: [ - menu add: 'Very High Resolution / Reg Fonts (46pix)' action: #defaultFont46 ]. - (availableSizes includes: 46) ifTrue: [ - menu add: 'Very High Resolution / Reg Fonts (36pix)' action: #defaultFont36 ]. - (availableSizes includes: 36) ifTrue: [ - menu add: 'High Resolution / Big Fonts (28pix)' action: #defaultFont28 ]. - (availableSizes includes: 28) ifTrue: [ - menu add: 'High Resolution / Big Fonts (22pix)' action: #defaultFont22 ]. - menu - add: 'High Resolution / Reg Fonts (17pix)' action: #defaultFont17; - add: 'High Resolution / Reg Fonts (14pix)' action: #defaultFont14; - add: 'Standard Resolution (11pix)' action: #defaultFont11; - add: 'Standard Resolution (9pix)' action: #defaultFont9; - add: 'Small Fonts (8pix)' action: #defaultFont8; - add: 'Very small Fonts'action: #verySmallFonts; - add: 'Tiny Fonts'action: #tinyFonts; - popUpInWorld: self runningWorld! ! - -Preferences class removeSelector: #bigFonts! - -Preferences class removeSelector: #bigFonts! - -Preferences class removeSelector: #hugeFonts! - -Preferences class removeSelector: #hugeFonts! - -Preferences class removeSelector: #smallFonts! - -Preferences class removeSelector: #smallFonts! - -Preferences class removeSelector: #veryBigFonts! - -Preferences class removeSelector: #veryBigFonts! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3619-BiggerFontSizes-JuanVuletich-2019Feb20-18h02m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3590] on 20 February 2019 at 6:18:18 pm'! -!Behavior methodsFor: 'auto complete' stamp: 'HAW 2/19/2019 17:53:31'! - typeName - - "If the class whishes to be shown in a different way in the selectors documentation. - For example, DenotativeObject does not show it self as a metaclass but as a class - Hernan" - - ^self name! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting - private' stamp: 'HAW 2/19/2019 15:44:12'! - addCategory: aCategory of: classOrganization - - | categorySelectors selectedSelectors | - - selectedSelectors := self prefixedSelectorsOf: aCategory in: classOrganization. - selectedSelectors isEmpty ifFalse: [ - categorySelectors := categoriesWithSelectors at: aCategory ifAbsentPut: [ OrderedCollection new ]. - categorySelectors addAll: selectedSelectors. - self addedSelectors: selectedSelectors. - self addToPossibleInvalidIfCorrespond: selectedSelectors ]! ! -!CompiledMethod methodsFor: 'auto complete' stamp: 'HAW 2/19/2019 17:53:31' prior: 50433442! - receiverTextAutoCompleterDocumentation - - | receiverString | - - receiverString := String streamContents: [ :stream | - stream - nextPutAll: self methodClass typeName; - nextPutAll: '>>' ]. - - ^Text string: receiverString attributes: (SHTextStylerST80 attributesFor: #patternKeyword). - - ! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting - private' stamp: 'HAW 2/19/2019 15:43:38' prior: 50434102! - addCategoriesAndSelectorsOf: aClass - - | classOrganization | - - classOrganization := aClass organization. - - classOrganization categories do: [ :aCategory | - self hasReachSelectorsLimit ifTrue: [ ^ self ]. - self addCategory: aCategory of: classOrganization ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3620-Autocompleter-tweaks-HernanWilkinson-2019Feb19-14h19m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3620] on 20 February 2019 at 7:05:43 pm'! -!CodePackageList methodsFor: 'as yet unclassified' stamp: 'HAW 2/20/2019 19:05:23'! - methodNodeOf: aSourceCode ifErrorsParsing: aParsingErrorBlock - - ^aParsingErrorBlock value: nil! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3621-PackageListFix-HernanWilkinson-2019Feb20-19h04m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3621] on 20 February 2019 at 8:00:52 pm'! -!StrikeFont class methodsFor: 'instance creation' stamp: 'jmv 2/20/2019 19:58:58' prior: 50435474! - install: aString -" -StrikeFont install: 'DejaVu'. - -StrikeFont install: 'DejaVu Sans'. -StrikeFont buildLargerPunctuation: 'DejaVu Sans'. -Preferences setDefaultFontFamilyTo: 'DejaVu Sans'. -Preferences standardFonts. -Character initialize. -" -" -StrikeFont install: 'DejaVu Sans Mono'. -Preferences setDefaultFontFamilyTo: 'DejaVu Sans Mono'. -Preferences bigFonts. -Character initialize. -" -" -StrikeFont install: 'Inconsolata' -StrikeFont install: '#PilGi' -StrikeFont install: 'Optima' -StrikeFont install: 'Herculanum' -StrikeFont install: 'Papyrus' -StrikeFont install: 'Handwriting - Dakota' -StrikeFont install: 'Times New Roman' -StrikeFont install: 'Apple Chancery' -StrikeFont install: 'Cochin' -StrikeFont install: 'Cracked' -StrikeFont install: 'Zapfino' -StrikeFont install: 'Brush Script MT' -StrikeFont install: 'Chalkboard' -" - | fontDict | - fontDict _ nil. - #(5 6 7 8 9 10 11 12 14 17 22 28 36 46 60 80) do: [ :s | - (self create: aString size: s bold: true italic: true boldItalic: false) ifNotNil: [ :font | - fontDict ifNil: [ fontDict _ AvailableFonts at: aString ifAbsentPut: Dictionary new ]. - fontDict - at: s - put: font ]]. - Preferences restoreDefaultFonts! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3622-StrikeFontTweak-JuanVuletich-2019Feb20-20h00m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3622] on 22 February 2019 at 4:50:06 pm'! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'jmv 2/22/2019 16:49:15' prior: 50434965! - computeIdentifierEntries - "Use an aux Set to avoid duplicates, but keep the order given." - | entriesSet lastTitle | - - entriesSet _ Set new. - lastTitle _ nil. - entries _ Array streamContents: [ :strm | - parser namesBeginningWith: prefix do: [ :identifier :kindOfIdentifierTitle | - (entriesSet includes: identifier) ifFalse: [ - kindOfIdentifierTitle = lastTitle ifFalse: [ - strm nextPut: kindOfIdentifierTitle. - lastTitle _ kindOfIdentifierTitle ]. - entriesSet add: identifier. - strm nextPut: identifier ]]]. - entriesSet size = 1 ifTrue: [ - entries _ Array with: entriesSet anyOne ]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/22/2019 16:41:34' prior: 50435120! - blockArgNamesDo: aBlock - "Iterate over block argument names valid at current blockDepth" - - | title | - title _ '-- block arguments'. - blockDepth to: 1 by: -1 do: [ :level | - arguments at: level ifPresent: [ :args | args do: [ :name | aBlock value: name value: title ] ]]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/22/2019 16:41:41' prior: 50435132! - blockTempNamesDo: aBlock - "Iterate over block temp names valid at current blockDepth" - - | title | - title _ '-- block variables'. - blockDepth to: 1 by: -1 do: [ :level | - temporaries at: level ifPresent: [ :args | args do: [ :name | aBlock value: name value: title ] ]]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/22/2019 16:41:48' prior: 50435144! - classVarNamesDo: aBlock - - | title | - title _ '-- class variables'. - classOrMetaClass isBehavior - ifTrue: [ - classOrMetaClass theNonMetaClass withAllSuperclasses do: [ :c | - c classPool keysDo: [ :name | aBlock value: name value: title ] ]]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/22/2019 16:42:08' prior: 50435155! - instVarNamesDo: aBlock - - | title | - title _ '-- instance variables'. - instanceVariables do: [ :name | aBlock value: name value: title ]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/22/2019 16:42:17' prior: 50435163! - methodArgNamesDo: aBlock - "Iterate over method argument names" - - | title | - title _ '-- method arguments'. - ^arguments at: 0 ifPresent: [ :args | args do: [ :name | aBlock value: name value: title ] ]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/22/2019 16:42:24' prior: 50435173! - methodTempNamesDo: aBlock - "Iterate over method temporary names" - - | title | - title _ '-- method variables'. - ^temporaries at: 0 ifPresent: [ :args | args do: [ :name | aBlock value: name value: title ] ]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/22/2019 16:42:33' prior: 50435183! - namesBeginningWith: aString do: aBlock - "Evaluate aBlock for all available names that start with aString" - - self nonGlobalNamesDo: [ :name :kindOfIdentifierTitle | - (name beginsWith: aString) ifTrue: [ aBlock value: name value: kindOfIdentifierTitle ]]. - self namesBeginningWith: aString do: [ :name | aBlock value: name value: '-- classes' ] in: Smalltalk classNames. - self namesBeginningWith: aString do: [ :name | aBlock value: name value: '-- globals' ] in: Smalltalk nonClassNames! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/22/2019 16:43:00' prior: 50435202! - nonGlobalNamesDo: aBlock - "Evaluate aBlock over all available names, except for globals" - - self - blockArgNamesDo: aBlock; - blockTempNamesDo: aBlock; - methodArgNamesDo: aBlock; - methodTempNamesDo: aBlock; - instVarNamesDo: aBlock; - classVarNamesDo: aBlock; - poolConstantNamesDo: aBlock; - workspaceNamesDo: aBlock. - self - reservedNames do: [ :name | - aBlock value: name value: '-- pseudovariables' ]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/22/2019 16:43:31' prior: 50435218! - poolConstantNamesDo: aBlock - - | title | - title _ '-- pool variables'. - classOrMetaClass isBehavior - ifTrue: [ - classOrMetaClass theNonMetaClass withAllSuperclasses do: [ :c | - c sharedPools do: [ :pool | - pool bindingsDo: [ :assoc | aBlock value: assoc key value: title ]]]]! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 2/22/2019 16:43:38' prior: 50435231! - workspaceNamesDo: aBlock - - | title | - title _ '-- workspace variables'. - workspace ifNotNil: [ - workspace bindingNamesDo: [ :name | aBlock value: name value: title ] ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3623-Autocompleter-NameGroupingTweaks-JuanVuletich-2019Feb22-16h41m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3623] on 22 February 2019 at 5:03:32 pm'! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 2/22/2019 17:03:19' prior: 50372167! - setDefaultFont: fontFamilyName spec: defaultFontsSpec - - | font | - defaultFontsSpec do: [ :triplet | - font _ AbstractFont familyName: fontFamilyName pointSize: triplet second. - font ifNil: [ - StrikeFont install: Preferences defaultFontFamily. - font _ AbstractFont familyName: fontFamilyName pointSize: triplet second ]. - font ifNil: [ font _ AbstractFont default ]. - triplet size > 2 ifTrue: [ - font _ font emphasized: triplet third ]. - self - perform: triplet first - with: font]! ! -!StrikeFont class methodsFor: 'instance creation' stamp: 'jmv 2/22/2019 16:57:45' prior: 50372475! - create: fontName size: pointSize bold: includeBold italic: includeItalic boldItalic: includeBoldItalic - " - self create: 'DejaVu Sans Mono' size: 12 bold: true italic: true boldItalic: true - " - | folder base bold oblique boldOblique point | - folder _ DirectoryEntry smalltalkImageDirectory / 'AdditionalFontData'. - point _ pointSize asString. - base _ [ (StrikeFont new - buildFromForm: ((Form fromFileEntry: folder // (fontName, '-0-', point, '.bmp')) asFormOfDepth: 16) - data: (folder // (fontName, '-0-', point, '.txt')) fileContents substrings - name: fontName, ' ', point) - pointSize: pointSize ] on: FileDoesNotExistException do: [ : ex | nil ]. - includeBold ifTrue: [ - bold _ [ (StrikeFont new - buildFromForm: ((Form fromFileEntry: folder // (fontName, '-1-', point, '.bmp')) asFormOfDepth: 16) - data: (folder // (fontName, '-1-', point, '.txt')) fileContents substrings - name: fontName, ' ', point, 'B') - emphasis: 1; - pointSize: pointSize ] on: FileDoesNotExistException do: [ : ex | nil ]]. - includeItalic ifTrue: [ - oblique _ [ (StrikeFont new - buildFromForm: ((Form fromFileEntry: folder // (fontName, '-2-', point, '.bmp')) asFormOfDepth: 16) - data: (folder // (fontName, '-2-', point, '.txt')) fileContents substrings - name: fontName, ' ', point, 'I') - emphasis: 2; - pointSize: pointSize ] on: FileDoesNotExistException do: [ : ex | nil ]]. - includeBoldItalic ifTrue: [ - boldOblique _ [ (StrikeFont new - buildFromForm: ((Form fromFileEntry: folder // (fontName, '-3-', point, '.bmp')) asFormOfDepth: 16) - data: (folder // (fontName, '-3-', point, '.txt')) fileContents substrings - name: fontName, ' ', point, 'BI') - emphasis: 3; - pointSize: pointSize ] on: FileDoesNotExistException do: [ : ex | nil ]]. - "We have a regular, base font. Make others derivatives of it" - base ifNotNil: [ - bold ifNotNil: [ - base derivativeFont: bold at: 1 ]. - oblique ifNotNil: [ - base derivativeFont: oblique at: 2]. - boldOblique ifNotNil: [ - base derivativeFont: boldOblique at: 3 ]. - ^base ]. - "We don't have a base, regular font." - oblique ifNotNil: [ - oblique emphasis: 0. "Hacky. Non regular fonts can not have derivatives. Should change this?" - bold ifNotNil: [ - oblique derivativeFont: bold at: 1 ]. - boldOblique ifNotNil: [ - oblique derivativeFont: boldOblique at: 3 ]. - ^oblique ]. - bold ifNotNil: [ - bold emphasis: 0. "Hacky. Non regular fonts can not have derivatives. Should change this?" - boldOblique ifNotNil: [ - bold derivativeFont: boldOblique at: 3 ]. - ^bold ]. - boldOblique ifNotNil: [ - ^boldOblique ]. - ^nil! ! -!StrikeFont class methodsFor: 'instance creation' stamp: 'jmv 2/22/2019 16:59:13' prior: 50435739! -install: aString -" -StrikeFont install: 'DejaVu'. -" -" -StrikeFont install: 'DejaVu Sans Mono'. -Preferences setDefaultFontFamilyTo: 'DejaVu Sans Mono'. -Preferences bigFonts. -Character initialize. -" -" -StrikeFont install: 'DejaVu Sans'. -StrikeFont buildLargerPunctuation: 'DejaVu Sans'. -Preferences setDefaultFontFamilyTo: 'DejaVu Sans'. -Preferences standardFonts. -Character initialize. -" -" -StrikeFont install: 'Inconsolata' -StrikeFont install: '#PilGi' -StrikeFont install: 'Optima' -StrikeFont install: 'Herculanum' -StrikeFont install: 'Papyrus' -StrikeFont install: 'Handwriting - Dakota' -StrikeFont install: 'Times New Roman' -StrikeFont install: 'Apple Chancery' -StrikeFont install: 'Cochin' -StrikeFont install: 'Cracked' -StrikeFont install: 'Zapfino' -StrikeFont install: 'Brush Script MT' -StrikeFont install: 'Chalkboard' -" - | fontDict | - fontDict _ nil. - 1 to: 200 do: [ :s | - (self create: aString size: s bold: true italic: true boldItalic: false) ifNotNil: [ :font | - font print. - fontDict ifNil: [ fontDict _ AvailableFonts at: aString ifAbsentPut: Dictionary new ]. - fontDict - at: s - put: font ]]. - Preferences restoreDefaultFonts! ! -!Theme class methodsFor: 'user interface' stamp: 'jmv 2/22/2019 17:02:20' prior: 50435600! - changeFontSizes - - (MenuMorph new defaultTarget: Preferences) - addTitle: 'Choose a size'; - addStayUpIcons; - add: 'Very High Resolution / Big Fonts (80pix)' action: #defaultFont80; - add: 'Very High Resolution / Big Fonts (60pix)' action: #defaultFont60; - add: 'Very High Resolution / Reg Fonts (46pix)' action: #defaultFont46; - add: 'Very High Resolution / Reg Fonts (36pix)' action: #defaultFont36; - add: 'High Resolution / Big Fonts (28pix)' action: #defaultFont28; - add: 'High Resolution / Big Fonts (22pix)' action: #defaultFont22; - add: 'High Resolution / Reg Fonts (17pix)' action: #defaultFont17; - add: 'High Resolution / Reg Fonts (14pix)' action: #defaultFont14; - add: 'Standard Resolution (11pix)' action: #defaultFont11; - add: 'Standard Resolution (9pix)' action: #defaultFont9; - add: 'Small Fonts (8pix)' action: #defaultFont8; - add: 'Very small Fonts'action: #verySmallFonts; - add: 'Tiny Fonts'action: #tinyFonts; - popUpInWorld: self runningWorld! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3624-AdditionalFontInstallingEnhancements-JuanVuletich-2019Feb22-16h56m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3622] on 21 February 2019 at 3:10:53 pm'! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'HAW 2/21/2019 11:51:45' prior: 50433490! - resetMenu - - | width newExtent adjustedY | - - self hideSelectorDocumentation. - firstVisible _ 1. - self selected: 1. - - width _ self calculateWidth. - newExtent _ width + 4 @ (self visibleItemsCount * self itemHeight+2). - - adjustedY := (self isYOutOfScreen: originalPosition with: newExtent) - ifTrue: [ originalPosition y - newExtent y - self itemHeight ] - ifFalse: [ originalPosition y ]. - - self morphPosition: originalPosition x @ adjustedY extent: newExtent. - "redraw is needed even if position and extent haven't changed" - self redrawNeeded ! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3625-AutoCompleterMorphRedraw-HernanWilkinson-2019Feb21-08h18m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3622] on 21 February 2019 at 5:09:48 pm'! - -AutoCompleter subclass: #ClassNameCompleter - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #ClassNameCompleter category: #'Tools-Autocompletion'! -AutoCompleter subclass: #ClassNameCompleter - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser selectorsClasses possibleInvalidSelectors canShowSelectorDocumentation ' - classVariableNames: 'AccessLock EntriesLimit Selectors ' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #SmalltalkCompleter category: #'Tools-Autocompletion'! -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser selectorsClasses possibleInvalidSelectors canShowSelectorDocumentation' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! -!AutoCompleter methodsFor: 'testing' stamp: 'HAW 2/21/2019 16:00:50'! - canShowSelectorDocumentation - - self subclassResponsibility! ! -!ClassNameCompleter methodsFor: 'testing' stamp: 'HAW 2/21/2019 16:01:01'! - canShowSelectorDocumentation - - ^false! ! -!ClassNameCompleter methodsFor: 'testing' stamp: 'HAW 2/21/2019 15:54:56'! - opensWithTab - - ^true! ! -!ClassNameCompleter methodsFor: 'entries' stamp: 'HAW 2/21/2019 15:53:24'! - computeEntries - - prefix _ model actualContents string. - entries _ (Smalltalk classNames select: [ :aClassName | aClassName beginsWith: prefix ]) sort. - ! ! -!SmalltalkCompleter methodsFor: 'testing' stamp: 'HAW 2/21/2019 16:06:32'! - canShowSelectorDocumentation - - ^canShowSelectorDocumentation ! ! -!ClassNameRequestMorph methodsFor: 'user interface support' stamp: 'HAW 2/21/2019 15:53:49' prior: 16807427! - autoCompleterClassFor: textGetter - - ^ClassNameCompleter ! ! -!AutoCompleter methodsFor: 'keyboard' stamp: 'HAW 2/21/2019 16:10:52' prior: 50434427! - handleKeystrokeBefore: kbEvent - - "I return a boolean. true when I have handled the event and no futher processing is needed by the caller." - - | shouldOpenMorph | - - shouldOpenMorph _ self shouldOpenMorph. - - "Stuff to do if the menu is not open" - menuMorph ifNil: [ ^ self openCompletionMenuFor: kbEvent if: shouldOpenMorph ]. - - "Starting here, stuff to do if the menu is open" - menuMorph stillActive. - - kbEvent isEsc ifTrue: [ self closeMenu. ^ true]. - kbEvent isBackspace ifTrue: [ shouldOpenMorph ifFalse: [ self closeMenu ]. ^ false]. - kbEvent isHome ifTrue: [ menuMorph goHome. ^ true ]. - kbEvent isEnd ifTrue: [ menuMorph goToEnd. ^ true]. - kbEvent isQuesitonMark ifTrue: [ menuMorph help. ^true]. - kbEvent isArrowUp ifTrue: [ menuMorph goUp. ^ true]. - kbEvent isArrowDown ifTrue: [ menuMorph goDown. ^ true]. - kbEvent isPageUp ifTrue: [ menuMorph goPageUp. ^ true]. - kbEvent isPageDown ifTrue: [ menuMorph goPageDown. ^ true]. - - self canShowSelectorDocumentation - ifTrue: [ - kbEvent isArrowRight ifTrue: [ menuMorph showSelectorDocumentation. ^ true ]. - kbEvent isArrowLeft ifTrue: [ menuMorph hideSelectorDocumentation. ^ true ]] - ifFalse: [ - "If it is showing identifiers I eat the right arrow key because the user is used to it when - showing selectors, so to avoid an unexpected behavior I do nothing with it -Hernan" - kbEvent isArrowRight ifTrue: [ ^ true ]]. - - (self shouldInsertSelected: kbEvent) ifTrue: [ self insertSelected ifTrue: [^ true]]. - (self shouldCloseMenu: kbEvent) ifTrue: [ self closeMenu ]. - - ^false! ! -!AutoCompleter methodsFor: 'testing' stamp: 'HAW 2/21/2019 15:55:35' prior: 16781305! - opensWithTab - - "Returns wheter should open the auto completer when pressing Tab or not" - - ^false! ! -!SmalltalkCompleter methodsFor: 'testing' stamp: 'HAW 2/21/2019 15:55:07' prior: 16909360! - opensWithTab - - ^true! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 2/21/2019 16:05:59' prior: 50434535! - computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel - - | id rangeType | - - canShowSelectorDocumentation _ true. - id _ allSource copyFrom: range start to: range end. - rangeType _ range rangeType. - - rangeType == #globalVar ifTrue: [ ^self computeMessageEntriesForClass: (Smalltalk at: id asSymbol) class ]. - rangeType == #self ifTrue: [ ^self computeMessageEntriesForClass: contextClass ]. - rangeType == #super ifTrue: [ ^self computeMessageEntriesForClass: contextClass superclass ]. - rangeType == #true ifTrue: [ ^self computeMessageEntriesForClass: True ]. - rangeType == #false ifTrue: [ ^self computeMessageEntriesForClass: False ]. - rangeType == #nil ifTrue: [ ^self computeMessageEntriesForClass: UndefinedObject ]. - rangeType == #character ifTrue: [ ^self computeMessageEntriesForClass: id first class ]. - rangeType == #number ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #string ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #symbol ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #stringSymbol ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #instVar ifTrue: [ ^specificModel computeMessageEntriesIn: self ofInstVarNamed: id ]. - rangeType == #methodArg ifTrue: [ ^specificModel computeMessageEntriesIn: self ofTempVarNamed: id ]. - rangeType == #tempVar ifTrue: [ ^specificModel computeMessageEntriesIn: self ofTempVarNamed: id ]. - rangeType == #blockArg ifTrue: [ ^specificModel computeMessageEntriesIn: self ofBlockArgNamed: id ]. - rangeType == #blockTempVar ifTrue: [ ^specificModel computeMessageEntriesIn: self ofBlockTempVarNamed: id ]. - rangeType == #workspaceVar ifTrue: [ ^self computeMessageEntriesForClassOrNil: (specificModel classOfWorkspaceVarNamed: id) ]. - rangeType == #thisContext ifTrue: [ ^self computeMessageEntriesForClass: (specificModel classOfThisContext) ]. - rangeType == #classVar ifTrue: [ ^self computeMessageEntriesForClassOrNil: (self classOfLocalBindingNamed: id in: contextClass) ]. - rangeType == #poolConstant ifTrue: [ ^self computeMessageEntriesForClassOrNil: (self classOfLocalBindingNamed: id in: contextClass) ]. - rangeType == #blockEnd ifTrue: [ ^self computeMessageEntriesForClass: BlockClosure ]. - rangeType == #arrayEnd ifTrue: [ ^self computeMessageEntriesForClass: Array ]. - rangeType == #rightBrace ifTrue: [ ^self computeMessageEntriesForClass: Array ]. - rangeType == #unary ifTrue: [ ^self computeEntriesOfUnaryMessageReturnNamed: id at: range ]. - rangeType == #rightParenthesis ifTrue: [ ^self computeMessageEntriesOfEnclosedExpressionReturnAt: range ]. - rangeType == #cascadeSeparator ifTrue: [ ^self computeMessageEntriesOfCascadeReceiverAt: range ]. - - self computeMessageEntriesForUnknowClass - - ! ! -!SmalltalkCompleter methodsFor: 'identifier entries - private' stamp: 'HAW 2/21/2019 16:03:28' prior: 50435787! - computeIdentifierEntries - "Use an aux Set to avoid duplicates, but keep the order given." - - | entriesSet lastTitle | - entriesSet _ Set new. - lastTitle _ nil. - canShowSelectorDocumentation _ false. - - entries _ Array streamContents: [ :strm | - parser namesBeginningWith: prefix do: [ :identifier :kindOfIdentifierTitle | - (entriesSet includes: identifier) ifFalse: [ - kindOfIdentifierTitle = lastTitle ifFalse: [ - strm nextPut: kindOfIdentifierTitle. - lastTitle _ kindOfIdentifierTitle ]. - entriesSet add: identifier. - strm nextPut: identifier ]]]. - entriesSet size = 1 ifTrue: [ - entries _ Array with: entriesSet anyOne ]! ! -!SmalltalkCompleter methodsFor: 'message entries for unknown class - private' stamp: 'HAW 2/21/2019 16:06:15' prior: 50433961! - computeMessageEntriesForUnknowClass - - | selectorsToShow | - - selectorsClasses _ #(). - possibleInvalidSelectors _ IdentitySet new. - canShowSelectorDocumentation _ true. - selectorsToShow _ OrderedCollection new. - - self class protected: [ - Selectors forPrefix: prefix keysAndValuesDo: [ :selector :lastUsedTime | - selectorsToShow := self add: selector and: lastUsedTime to: selectorsToShow. - (Object canUnderstand: selector) ifFalse: [ possibleInvalidSelectors add: selector ]]]. - - selectorsToShow size < EntriesLimit ifTrue: [ selectorsToShow _ self sortByLastUsedTime: selectorsToShow ]. - - " To see the timestamps in the menu (need to tweak #insertCompletion: to activate. Right now, just for debugging) - entries _ selectorsToShow collect: [ :ary | ary first, '(', ((DateAndTime fromString: '01/01/1996 00:00') + ary second minutes) printString,')' ] - " - entries _ selectorsToShow collect: [ :selectorAndTime | selectorAndTime first ] - -! ! - -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser selectorsClasses possibleInvalidSelectors canShowSelectorDocumentation' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #SmalltalkCompleter category: #'Tools-Autocompletion'! -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser selectorsClasses possibleInvalidSelectors canShowSelectorDocumentation' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3626-ShowClassesOnlyInTheClassNameRequestMorph-HernanWilkinson-2019Feb21-15h10m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3622] on 21 February 2019 at 9:48:42 pm'! - -BorderedRectMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity selectorDocumentation originalPosition showUp itemsPerPage ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #AutoCompleterMorph category: #'Tools-Autocompletion'! -BorderedRectMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity selectorDocumentation originalPosition showUp itemsPerPage' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/21/2019 21:38:59'! - calculateItemsPerPage - - | itemsThatCanFit | - - itemsThatCanFit _ (DisplayScreen actualScreenSize y - originalPosition y - 2) // self itemHeight. - itemsPerPage _ (itemsThatCanFit min: self maxItemsPerPage) min: completer entryCount. - -! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/21/2019 21:31:17'! - maxItemsPerPage - - ^13! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'HAW 2/21/2019 21:40:47' prior: 50368540! - goDown - - "Wrap around" - self selected = completer entryCount ifTrue: [ ^ self goHome ]. - - self selected: self selected + 1. - (self selected > self lastVisible and: [self selected <= completer entryCount]) ifTrue: [firstVisible := firstVisible + 1]. - - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'HAW 2/21/2019 21:40:58' prior: 50366875! - goHome - - firstVisible := 1. - self selected: firstVisible. - - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'HAW 2/21/2019 21:42:25' prior: 50366880! - goPageDown - - (self gotoPage: self currentPage + 1) ifFalse: [ self goToEnd ]. - - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'HAW 2/21/2019 21:42:30' prior: 50366886! -goPageUp - - self gotoPage: self currentPage - 1. - - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'HAW 2/21/2019 21:42:37' prior: 50366891! - goToEnd - - self selected: completer entryCount. - firstVisible := selected - itemsPerPage + 1 max: 1. - - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'HAW 2/21/2019 20:46:55' prior: 50368552! - goUp - - (self selected = 0 and: [self firstVisible = 1]) ifTrue: [^ self]. - "Wrap around" - self selected = 1 ifTrue: [ ^self goToEnd ]. - - self selected: self selected - 1. - self selected < self firstVisible ifTrue: [firstVisible := firstVisible - 1]. - - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'HAW 2/21/2019 21:33:37' prior: 16781400! - help - - TextModel new contents: AutoCompleter helpText; openLabel: 'uCompletion Keyboard Help'! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'HAW 2/21/2019 21:41:36' prior: 50436122! - resetMenu - - | width newExtent | - - self hideSelectorDocumentation. - self goHome. - - self calculateItemsPerPage. - width _ self calculateWidth. - newExtent _ width + 4 @ (itemsPerPage * self itemHeight + 2). - - self morphPosition: originalPosition extent: newExtent. - "redraw is needed even if position and extent haven't changed" - self redrawNeeded ! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/11/2019 20:13:14' prior: 50433507! - adjust: aLocation ifOutOfScreenWith: anExtent xOffset: xOffset yOffset: yOffset - - | adjustedLocationX adjustedLocationY | - - adjustedLocationX := (self isXOutOfScreen: aLocation with: anExtent) - ifTrue: [ aLocation x - anExtent x - xOffset ] - ifFalse: [ aLocation x ]. - - adjustedLocationX < 0 ifTrue: [ adjustedLocationX := aLocation x ]. - - adjustedLocationY := (self isYOutOfScreen: aLocation with: anExtent) - ifTrue: [ aLocation y - anExtent y - yOffset ] - ifFalse: [ aLocation y ]. - - ^adjustedLocationX @ adjustedLocationY - ! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/21/2019 21:25:56' prior: 50433527! - calculateWidth - - | width font | - - width _ 120. - font _ self class listFont. - - 1 - to: completer entryCount - do: [ :index | width _ width max: (font widthOfString: (completer entries at: index) asString)]. - - completer entryCount > itemsPerPage ifTrue: [ width _ width + ScrollBar scrollbarThickness ]. - - ^ width ! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/10/2019 23:51:54' prior: 50433579! - drawItemsOn: aCanvas width: width - - | itemTop | - - itemTop _ 1. - self firstVisible - to: self lastVisible - do: [ :index | - self drawItemOf: index on: aCanvas width: width top: itemTop. - itemTop _ itemTop + self itemHeight ].! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'HAW 2/21/2019 21:26:22' prior: 50433607! - drawScrollBarOn: aCanvas - - | scrollbarThickness width | - - width _ extent x-2. - completer entryCount > itemsPerPage ifTrue: [ - scrollbarThickness _ ScrollBar scrollbarThickness. - width _ width - scrollbarThickness. - - self drawScrollBarRectangleOn: aCanvas thickness: scrollbarThickness. - self drawUpArrowOn: aCanvas thickness: scrollbarThickness. - self drawDownArrowOn: aCanvas thickness: scrollbarThickness. - self drawScrollBarMovementBarOn: aCanvas thickness: scrollbarThickness ]. - - ^width -! ! -!AutoCompleterMorph methodsFor: 'events' stamp: 'HAW 2/21/2019 21:45:16' prior: 50434330! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - - (self morphContainsPoint: localEventPosition) - ifTrue: [ - ((self upButtonPosition extent: ScrollBar scrollbarThickness) containsPoint: localEventPosition) - ifTrue: [ ^self stillActive; goUp ]. - ((self downButtonPosition extent: ScrollBar scrollbarThickness) containsPoint: localEventPosition) - ifTrue: [ ^self stillActive; goDown ]. - self selected: (localEventPosition y // self itemHeight) + self firstVisible. - completer insertSelected ] - ifFalse: [ self delete. completer menuClosed ]! ! -!AutoCompleterMorph methodsFor: 'paging' stamp: 'HAW 2/21/2019 21:26:13' prior: 16781592! - currentPage - - ^(self selected - 1 // itemsPerPage ) + 1.! ! -!AutoCompleterMorph methodsFor: 'paging' stamp: 'HAW 2/21/2019 21:45:37' prior: 50366929! - gotoPage: anInteger - - | item | - - item := ((anInteger - 1) * itemsPerPage) + 1. - item >= completer entryCount ifTrue: [^false]. - - item < 1 ifTrue: [item := 1]. - firstVisible := item. - self selected: firstVisible. - - ^ true! ! -!AutoCompleterMorph methodsFor: 'paging' stamp: 'HAW 2/21/2019 21:28:22' prior: 16781607! - pageCount - - | count | - - completer entryCount = itemsPerPage ifTrue: [^ 1]. - - count _ completer entryCount // itemsPerPage. - (completer entryCount \\ itemsPerPage) > 0 ifTrue: [ count _ count + 1]. - - ^count! ! -!AutoCompleterMorph methodsFor: 'private' stamp: 'HAW 2/21/2019 21:45:53' prior: 16781639! - firstVisible - - ^firstVisible min: completer entryCount! ! -!AutoCompleterMorph methodsFor: 'private' stamp: 'HAW 2/21/2019 21:25:00' prior: 16781644! - lastVisible - - ^ (self firstVisible + itemsPerPage - 1) min: completer entryCount! ! -!AutoCompleterMorph methodsFor: 'selector documentation' stamp: 'HAW 2/21/2019 21:28:49' prior: 50433693! - selectorDefaultDocumentationLocation - - | relativeSelected | - - relativeSelected := (self selected - self firstVisible) min: itemsPerPage - 1 max: 0. - - ^location externalizePosition: extent x@(relativeSelected * self itemHeight + 1). - - ! ! -!AutoCompleterMorph methodsFor: 'selector documentation' stamp: 'HAW 2/11/2019 16:18:05' prior: 50433711! - selectorDocumentationExtent - - ^`600@250`! ! - -AutoCompleterMorph class removeSelector: #itemsPerPage! - -AutoCompleterMorph class removeSelector: #itemsPerPage! - -AutoCompleterMorph class removeSelector: #maxItemsPerPage! - -AutoCompleterMorph removeSelector: #visibleItemsCount! - -AutoCompleterMorph removeSelector: #visibleItemsCount! - -BorderedRectMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity selectorDocumentation originalPosition showUp itemsPerPage' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #AutoCompleterMorph category: #'Tools-Autocompletion'! -BorderedRectMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity selectorDocumentation originalPosition showUp itemsPerPage' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3627-AutoCompleterMorphItemsPerPage-HernanWilkinson-2019Feb21-17h09m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3622] on 21 February 2019 at 10:08:10 pm'! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 2/21/2019 22:00:30'! - ifEmptyEntriesShowAllPrefixedSelectors - - entries isEmpty ifTrue: [ self computeMessageEntriesForUnknowClass ] ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 2/21/2019 21:59:30' prior: 50433930! - computeMessageEntriesForClass: aClass - - selectorsClasses := Array with: aClass. - - entries := (AutoCompleterSelectorsCollector for: prefix) - addSelectorsOf: aClass; - entriesToShow. - - self ifEmptyEntriesShowAllPrefixedSelectors! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3628-ShowsAllPrefixedSelectors-HernanWilkinson-2019Feb21-21h48m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3620] on 21 February 2019 at 12:30:15 am'! -!CodeWindow methodsFor: 'keyboard shortcuts' stamp: 'HAW 2/21/2019 00:29:45' prior: 50401397! - messageCatListKey: aChar from: view - - aChar == $o ifTrue: [^ model fileOutMessageCategories ]. - aChar == $t ifTrue: [^ model runMessageCategoryTests ]. - aChar == $x ifTrue: [^ model removeMessageCategory ]. - aChar == $R ifTrue: [ ^model renameCategory ]. - aChar == $n ifTrue: [^model addCategory ]. - aChar == $e ifTrue: [^model removeEmptyCategories ]. - aChar == $c ifTrue: [^model categorizeAllUncategorizedMethods ].! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'HAW 2/21/2019 00:29:34' prior: 50411439! - messageCategoryMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'fileOut (o)'. - #object -> #model. - #selector -> #fileOutMessageCategories. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'reorganize'. - #object -> #model. - #selector -> #editMessageCategories. - #icon -> #sendReceiveIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'alphabetize'. - #object -> #model. - #selector -> #alphabetizeMessageCategories. - #icon -> #fontXGenericIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'remove empty categories (e)'. - #object -> #model. - #selector -> #removeEmptyCategories. - #icon -> #listRemoveIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 40. - #label -> 'categorize all uncategorized (c)'. - #object -> #model. - #selector -> #categorizeAllUncategorizedMethods. - #icon -> #packageIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 50. - #label -> 'new category... (n)'. - #object -> #model. - #selector -> #addCategory. - #icon -> #newIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'rename... (R)'. - #object -> #model. - #selector -> #renameCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'remove (x)'. - #object -> #model. - #selector -> #removeMessageCategory. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'run tests (t)'. - #object -> #model. - #selector -> #runMessageCategoryTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - }`. - ! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3629-AdditionalShortcutsInMsgCatList-HernanWilkinson-2019Feb20-21h50m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3622] on 21 February 2019 at 8:18:20 am'! -!BrowserWindow class methodsFor: 'instance creation' stamp: 'HAW 2/21/2019 08:14:05'! - openNoSysCat: model label: aString - - self new - model: model; - buildNoSysCatMorphicWindow; - setLabel: aString; - openInWorld! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'HAW 2/21/2019 08:16:48' prior: 16793163! - buildNoSysCatMorphicWindow - "A Browser without the class categories list" - - | mySingletonList upperPanes messageCatList messageList | - mySingletonList _ PluggableListMorph - model: model - listGetter: #systemCategorySingleton - indexGetter: #indexIsOne - indexSetter: #indexIsOne: - mainView: self - menuGetter: #systemCatSingletonMenu - keystrokeAction: #systemCatSingletonKey:from:. - mySingletonList hideScrollBarsIndefinitely. - - messageCatList _ self buildMorphicMessageCatList. - messageList _ self buildMorphicMessageList. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: self buildMorphicClassColumn proportionalWidth: 0.3; - addAdjusterAndMorph: messageCatList proportionalWidth: 0.3; - addAdjusterAndMorph: messageList proportionalWidth: 0.4. - - messageList makeItemsDraggable. - messageCatList - acceptDropsFrom: messageList - performing: #categorizeUnderCategoryAt:selector: - whenOutsideList: #categorizeUnderNewCategorySelector:. - - self layoutMorph - addMorph: mySingletonList fixedHeight: Preferences standardCodeFont height + 10; - addAdjusterAndMorph: upperPanes proportionalHeight: 0.3; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.7. - - model changed: #editSelection! ! - -CodeWindow class removeSelector: #openNoSysCat:label:! - -CodeWindow class removeSelector: #openNoSysCat:label:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3630-MessageDnDInHierarchyBrowser-HernanWilkinson-2019Feb21-08h00m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3610] on 23 February 2019 at 8:07:26 pm'! -!Object methodsFor: 'debugging-haltOnce' stamp: 'GC 2/23/2019 20:05:35'! - clearHaltOnce - "Turn on the halt once flag." - - Smalltalk at: #HaltOnce put: false! ! -!Object methodsFor: 'debugging-haltOnce' stamp: 'GC 2/23/2019 20:05:43'! - haltOnce - "Halt unless we have already done it once." - - self haltOnceEnabled ifTrue: [ - self clearHaltOnce. - ^ self halt - ]! ! -!Object methodsFor: 'debugging-haltOnce' stamp: 'GC 2/23/2019 20:05:48'! - haltOnceEnabled - - ^ Smalltalk - at: #HaltOnce - ifAbsent: [false]! ! -!Object methodsFor: 'debugging-haltOnce' stamp: 'GC 2/23/2019 20:05:52'! - setHaltOnce - "Turn on the halt once flag." - - Smalltalk at: #HaltOnce put: true! ! -!Object methodsFor: 'debugging-haltOnce' stamp: 'GC 2/23/2019 20:00:03'! - toggleHaltOnce - self haltOnceEnabled - ifTrue: [self clearHaltOnce] - ifFalse: [self setHaltOnce]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3631-haltOnce-GastonCaruso-2019Feb23-19h57m-GC.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3631] on 25 February 2019 at 2:34:25 pm'! -!SmalltalkCompleter class methodsFor: 'class initialization' stamp: 'jmv 2/25/2019 14:33:42' prior: 50434656! - initialize - " - It takes about 6 seconds, mostly because of the time to fetch method stamps from source files... - [ SmalltalkCompleter initialize ]timeToRun - Selectors inspect - " - | maxSortValue allImplemented | - - EntriesLimit _ 100. - - SystemChangeNotifier uniqueInstance - removeActionsWithReceiver: self. "avoid double registration" - - SystemChangeNotifier uniqueInstance - when: #classRemoved send: #classRemoved:fromCategory: to: self; - when: #methodAdded send: #methodAdded:selector:inClass:requestor: to: self; - when: #methodAddedInProtocol send: #methodAdded:selector:inProtocol:class:requestor: to: self; - when: #methodRemoved send: #methodRemoved:selector:inProtocol:class: to: self. - - self protected: [ - allImplemented _ Smalltalk allImplementedMessages. - Selectors _ Trie new. - " - Smalltalk allBehaviorsDo: [:class | - class selectorsAndMethodsDo: [ :sel :method | - Selectors at: sel ifAbsentPut: [ 0 ]. - method messages do: [ :sentMsg | - Selectors at: sentMsg put: (Selectors at: sentMsg ifAbsent: [ 0 ]) + 1 ]]]. - " - Smalltalk allBehaviorsDo: [:class | - class selectorsAndMethodsDo: [ :sel :method | - self addSelector: sel method: method allImplemented: allImplemented]]. - "" - - "The following might not be found in #messages. Give them maximum priority." - maxSortValue _ SmallInteger maxVal. - "From MessageNode>>#initialize" - #( ifTrue: ifFalse: ifTrue:ifFalse: ifFalse:ifTrue: - and: or: - whileFalse: whileTrue: whileFalse whileTrue - to:do: to:by:do: - caseOf: caseOf:otherwise: - ifNil: ifNotNil: ifNil:ifNotNil: ifNotNil:ifNil:) do: [ :sel | - Selectors at: sel put: maxSortValue ]. - - maxSortValue _ SmallInteger maxVal-1. - "From SystemDictionary >>#recreateSpecialObjectsArray" - (1 to: Smalltalk specialSelectorSize) do: [ :i | | sym | - sym _ Smalltalk specialSelectorAt: i. - (Selectors includesKey: sym) - ifTrue: [ Selectors at: sym put: maxSortValue ]]]! ! - -SmalltalkCompleter initialize! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3632-SmalltalkCompleterFix-JuanVuletich-2019Feb25-14h26m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3632] on 25 February 2019 at 3:37:56 pm'! -!PluggableListMorph methodsFor: 'events' stamp: 'jmv 2/25/2019 15:21:30' prior: 50426382! - dragEvent: aMouseEvent localPosition: localEventPosition - - | row dragged listItem | - self listMorph highlightedRow: nil. - row _ self rowAtLocation: localEventPosition ifNone: [ ^self ]. - listItem _ self getListItem: row. - - dragged _ DraggingGuideMorph new. - dragged addMorph: (StringMorph contents: listItem). - dragged setProperty: #dragSource toValue: self. - dragged setProperty: #dropSelectorArgument toValue: listItem. - - aMouseEvent hand attachMorphBeside: dragged.! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3633-PluggableListMorphFix-JuanVuletich-2019Feb25-15h37m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3633] on 27 February 2019 at 1:27:51 pm'! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/27/2019 13:20:35'! - bigFonts - "Sets not only fonts but other GUI elements - to fit regular resolution and size screens - Preferences bigFonts - " - - self defaultFont17! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/27/2019 13:03:25'! - defaultFont05 - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences defaultFont05 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 7) - (setListFontTo: 5) - (setMenuFontTo: 5) - (setWindowTitleFontTo: 7) - (setCodeFontTo: 5) - (setButtonFontTo: 5)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/27/2019 13:06:29'! - defaultFont06 - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences defaultFont06 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 7) - (setListFontTo: 6) - (setMenuFontTo: 6) - (setWindowTitleFontTo: 8) - (setCodeFontTo: 6) - (setButtonFontTo: 6)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/27/2019 13:04:07'! - defaultFont07 - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences defaultFont07 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 8) - (setListFontTo: 7) - (setMenuFontTo: 7) - (setWindowTitleFontTo: 9) - (setCodeFontTo: 7) - (setButtonFontTo: 7)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/27/2019 13:02:21'! - defaultFont08 - "Sets not only fonts but other GUI elements - to fit low resolution or small screens - Preferences defaultFont08 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 8) - (setListFontTo: 8) - (setMenuFontTo: 8) - (setWindowTitleFontTo: 11) - (setCodeFontTo: 8) - (setButtonFontTo: 8)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/27/2019 13:02:38'! - defaultFont09 - "Sets not only fonts but other GUI elements - to fit low resolution or small screens - Preferences defaultFont09 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 9) - (setListFontTo: 9) - (setMenuFontTo: 10) - (setWindowTitleFontTo: 12) - (setCodeFontTo: 9) - (setButtonFontTo: 9)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/27/2019 13:05:56'! - defaultFont10 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont10 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 10) - (setListFontTo: 10) - (setMenuFontTo: 11) - (setWindowTitleFontTo: 12) - (setCodeFontTo: 10) - (setButtonFontTo: 10)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/27/2019 13:07:19'! - defaultFont12 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont12 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 12) - (setListFontTo: 12) - (setMenuFontTo: 12) - (setWindowTitleFontTo: 14) - (setCodeFontTo: 12) - (setButtonFontTo: 12)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/27/2019 13:20:12'! - hugeFonts - "Sets not only fonts but other GUI elements - to fit regular resolution and size screens - Preferences hugeFonts - " - - self defaultFont46! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/27/2019 13:21:58'! - smallFonts - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences smallFonts - " - - self defaultFont09! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/27/2019 13:20:22'! - veryBigFonts - "Sets not only fonts but other GUI elements - to fit regular resolution and size screens - Preferences veryBigFonts - " - - self defaultFont28! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/27/2019 13:20:44' prior: 50435446! - standardFonts - "Sets not only fonts but other GUI elements - to fit regular resolution and size screens - Preferences standardFonts - " - - self defaultFont12! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/27/2019 13:03:47' prior: 50397750! - tinyFonts - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences tinyFonts - " - - self defaultFont05! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 2/27/2019 13:04:24' prior: 50435455! - verySmallFonts - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences verySmallFonts - " - - self defaultFont07! ! -!StrikeFont class methodsFor: 'instance creation' stamp: 'jmv 2/27/2019 13:16:39' prior: 50436041! - install: aString -" -StrikeFont install: 'DejaVu'. -" -" -StrikeFont install: 'DejaVu Sans Mono'. -Preferences setDefaultFontFamilyTo: 'DejaVu Sans Mono'. -Preferences bigFonts. -Character initialize. -" -" -StrikeFont install: 'DejaVu Sans'. -StrikeFont buildLargerPunctuation: 'DejaVu Sans'. -Preferences setDefaultFontFamilyTo: 'DejaVu Sans'. -Preferences standardFonts. -Character initialize. -" -" -StrikeFont install: 'Inconsolata' -StrikeFont install: '#PilGi' -StrikeFont install: 'Optima' -StrikeFont install: 'Herculanum' -StrikeFont install: 'Papyrus' -StrikeFont install: 'Handwriting - Dakota' -StrikeFont install: 'Times New Roman' -StrikeFont install: 'Apple Chancery' -StrikeFont install: 'Cochin' -StrikeFont install: 'Cracked' -StrikeFont install: 'Zapfino' -StrikeFont install: 'Brush Script MT' -StrikeFont install: 'Chalkboard' -" - | fontDict | - fontDict _ nil. - 1 to: 200 do: [ :s | - (self create: aString size: s bold: true italic: true boldItalic: false) ifNotNil: [ :font | - font print. - fontDict ifNil: [ fontDict _ AvailableFonts at: aString ifAbsentPut: Dictionary new ]. - fontDict - at: s - put: font ]]! ! -!Theme class methodsFor: 'user interface' stamp: 'jmv 5/6/2018 16:42:00' prior: 50436080! - changeFontSizes - - (MenuMorph new defaultTarget: Preferences) - addTitle: 'Choose a size'; - addStayUpIcons; - add: 'Huge Fonts' action: #hugeFonts; - add: 'Very big Fonts' action: #veryBigFonts; - add: 'Big Fonts' action: #bigFonts; - add: 'Standard Fonts' action: #standardFonts; - add: 'Small Fonts' action: #smallFonts; - add: 'Very small Fonts'action: #verySmallFonts; - add: 'Tiny Fonts'action: #tinyFonts; - popUpInWorld: self runningWorld! ! - -Preferences class removeSelector: #defaultFont8! - -Preferences class removeSelector: #defaultFont8! - -Preferences class removeSelector: #defaultFont9! - -Preferences class removeSelector: #defaultFont9! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Preferences standardFonts! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3634-BetterFontSizeOptions-JuanVuletich-2019Feb27-13h02m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3634] on 1 March 2019 at 1:52:22 pm'! -!InnerTextMorph methodsFor: 'notifications' stamp: 'jmv 3/1/2019 00:34:30' prior: 16855878! - fontPreferenceChanged - - super fontPreferenceChanged. - hasUnacceptedEdits ifFalse: [ - model refetch ]. - self updateFromTextComposition.! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3635-CodePaneFontChangesOnFontSelection-JuanVuletich-2019Mar01-13h51m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3634] on 28 February 2019 at 8:31:40 pm'! - -Smalltalk renameClassNamed: #ProgessiveTestRunner as: #ProgressiveTestRunner! -!Browser methodsFor: 'tdd' stamp: 'HAW 2/28/2019 20:30:14' prior: 50338014! - runClassTests - - self selectedClassName ifNotNil: [ :aClassName | | selectedClass | - selectedClass _ Smalltalk classNamed: aClassName. - (ProgressiveTestRunner for: (TestSuite forClass: selectedClass)) value ]! ! -!Browser methodsFor: 'tdd' stamp: 'HAW 2/28/2019 20:30:14' prior: 50338023! - runMessageCategoryTests - - selectedMessageCategory ifNotNil: [ | selectedClass suite | - selectedClass _ Smalltalk classNamed: selectedClassName. - suite _ TestSuite forMessageCategoryNamed: selectedMessageCategory of: selectedClass categorizedWith: classOrganizer. - (ProgressiveTestRunner for: suite) value ] - - ! ! -!Browser methodsFor: 'tdd' stamp: 'HAW 2/28/2019 20:30:14' prior: 50338035! - runMethodTest - - | suite | - - suite _ TestSuite forCompiledMethod: currentCompiledMethod. - (ProgressiveTestRunner for: suite) value - ! ! -!Browser methodsFor: 'tdd' stamp: 'HAW 2/28/2019 20:30:14' prior: 50338042! - runSystemCategoryTests - - selectedSystemCategory ifNotNil: [ | suite | - suite _ TestSuite forSystemCategoryNamed: selectedSystemCategory using: systemOrganizer. - (ProgressiveTestRunner for: suite) value ] - - ! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HAW 2/28/2019 20:30:14' prior: 50338454! - runTestSuite: aTestSuite - - (ProgressiveTestRunner for: aTestSuite) value - - ! ! -!TestResultWindow methodsFor: 'actions' stamp: 'HAW 2/28/2019 20:30:14' prior: 50343802! - runSuite - - | suite | - - suite := TestSuite new. - suite addTests: testResult tests. - self delete. - (ProgressiveTestRunner for: suite) value. - ! ! -!ProgressiveTestRunner methodsFor: 'show result - private' stamp: 'HAW 2/28/2019 20:30:59' prior: 50343886! - showDeffects - - | defects | - - defects _ testResult defects. - defects size = 1 - ifTrue: [ defects anyOne debug ] - ifFalse: [ self openTestResultWindow]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3636-ProgressiveTestRunnerRenamed-HernanWilkinson-2019Feb28-20h30m-HAW.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3636] on 1 March 2019 at 1:54:06 pm'! - -MethodNode removeSelector: #rangesForInstanceVariable:ifAbsent:! - -MethodNode removeSelector: #rangesForInstanceVariable:ifAbsent:! - -MethodNode removeSelector: #rangesForTemporaryVariable:ifAbsent:! - -MethodNode removeSelector: #rangesForTemporaryVariable:ifAbsent:! - -Encoder removeSelector: #rangesForInstanceVariable:ifAbsent:! - -Encoder removeSelector: #rangesForInstanceVariable:ifAbsent:! - -Encoder removeSelector: #rangesForTemporaryVariable:ifAbsent:! - -Encoder removeSelector: #rangesForTemporaryVariable:ifAbsent:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3637-RemovedUnnecesaryMethodsFromMethodNodeAndEncoder-HernanWilkinson-2019Mar01-12h31m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3637] on 7 March 2019 at 9:40:58 am'! - -Error subclass: #RefactoringError - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RefactoringError category: #'Tools-Refactoring'! -Error subclass: #RefactoringError - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringError subclass: #CanNotRefactorDueToReferencesError - instanceVariableNames: 'references referencee' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #CanNotRefactorDueToReferencesError category: #'Tools-Refactoring'! -RefactoringError subclass: #CanNotRefactorDueToReferencesError - instanceVariableNames: 'references referencee' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Warning subclass: #RefactoringWarning - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RefactoringWarning category: #'Tools-Refactoring'! -Warning subclass: #RefactoringWarning - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ParseNodeVisitor subclass: #ExtractToTemporaryRewriter - instanceVariableNames: 'refactoring finder' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractToTemporaryRewriter category: #'Tools-Refactoring'! -ParseNodeVisitor subclass: #ExtractToTemporaryRewriter - instanceVariableNames: 'refactoring finder' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ParseNodeVisitor subclass: #ParseNodeToReplaceFinder - instanceVariableNames: 'refactoring currentBlock nodesToReplace blockContainingFirstNodeToReplace firstNodeToReplaceIndex currentStatementIndex' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ParseNodeToReplaceFinder category: #'Tools-Refactoring'! -ParseNodeVisitor subclass: #ParseNodeToReplaceFinder - instanceVariableNames: 'refactoring currentBlock nodesToReplace blockContainingFirstNodeToReplace firstNodeToReplaceIndex currentStatementIndex' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MessageSetWindow subclass: #ChangeSelectorWizardStepWindow - instanceVariableNames: 'applier' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ChangeSelectorWizardStepWindow category: #'Tools-Refactoring'! -MessageSetWindow subclass: #ChangeSelectorWizardStepWindow - instanceVariableNames: 'applier' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelectorWizardStepWindow subclass: #ChangeSelectorImplementorsStepWindow - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ChangeSelectorImplementorsStepWindow category: #'Tools-Refactoring'! -ChangeSelectorWizardStepWindow subclass: #ChangeSelectorImplementorsStepWindow - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelectorWizardStepWindow subclass: #ChangeSelectorSendersStepWindow - instanceVariableNames: 'changedMethods' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ChangeSelectorSendersStepWindow category: #'Tools-Refactoring'! -ChangeSelectorWizardStepWindow subclass: #ChangeSelectorSendersStepWindow - instanceVariableNames: 'changedMethods' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Object subclass: #Refactoring - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #Refactoring category: #'Tools-Refactoring'! -Object subclass: #Refactoring - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Refactoring subclass: #AddInstanceVariable - instanceVariableNames: 'newVariable classToRefactor' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #AddInstanceVariable category: #'Tools-Refactoring'! -Refactoring subclass: #AddInstanceVariable - instanceVariableNames: 'newVariable classToRefactor' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Refactoring subclass: #ChangeSelector - instanceVariableNames: 'oldSelector newSelector implementors senders changes' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ChangeSelector category: #'Tools-Refactoring'! -Refactoring subclass: #ChangeSelector - instanceVariableNames: 'oldSelector newSelector implementors senders changes' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelector subclass: #AddParameter - instanceVariableNames: 'newParameter newParameterValue implementorTrailingString senderTrailingString index isAddingLast' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #AddParameter category: #'Tools-Refactoring'! -ChangeSelector subclass: #AddParameter - instanceVariableNames: 'newParameter newParameterValue implementorTrailingString senderTrailingString index isAddingLast' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelector subclass: #RemoveParameter - instanceVariableNames: 'parameterToRemove parameterIndex senderReplacementString isLastParameter' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RemoveParameter category: #'Tools-Refactoring'! -ChangeSelector subclass: #RemoveParameter - instanceVariableNames: 'parameterToRemove parameterIndex senderReplacementString isLastParameter' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelector subclass: #RenameSelector - instanceVariableNames: 'newSelectorKeywords' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameSelector category: #'Tools-Refactoring'! -ChangeSelector subclass: #RenameSelector - instanceVariableNames: 'newSelectorKeywords' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Refactoring subclass: #ExtractToTemporary - instanceVariableNames: 'newVariable parseNodeToExtract methodNodeToRefactor newTemporary' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractToTemporary category: #'Tools-Refactoring'! -Refactoring subclass: #ExtractToTemporary - instanceVariableNames: 'newVariable parseNodeToExtract methodNodeToRefactor newTemporary' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Refactoring subclass: #InsertSuperclass - instanceVariableNames: 'classToRefactor superclassName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #InsertSuperclass category: #'Tools-Refactoring'! -Refactoring subclass: #InsertSuperclass - instanceVariableNames: 'classToRefactor superclassName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Refactoring subclass: #PushUpMethod - instanceVariableNames: 'method' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #PushUpMethod category: #'Tools-Refactoring'! -Refactoring subclass: #PushUpMethod - instanceVariableNames: 'method' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Refactoring subclass: #RemoveAllUnreferencedInstanceVariables - instanceVariableNames: 'classToRefactor' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RemoveAllUnreferencedInstanceVariables category: #'Tools-Refactoring'! -Refactoring subclass: #RemoveAllUnreferencedInstanceVariables - instanceVariableNames: 'classToRefactor' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Refactoring subclass: #RemoveInstanceVariable - instanceVariableNames: 'variableToRemove classToRefactor' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RemoveInstanceVariable category: #'Tools-Refactoring'! -Refactoring subclass: #RemoveInstanceVariable - instanceVariableNames: 'variableToRemove classToRefactor' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Refactoring subclass: #RenameClass - instanceVariableNames: 'classToRename newClassName system undeclared classToRenameOriginalName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameClass category: #'Tools-Refactoring'! -Refactoring subclass: #RenameClass - instanceVariableNames: 'classToRename newClassName system undeclared classToRenameOriginalName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Refactoring subclass: #RenameInstanceVariable - instanceVariableNames: 'oldVariable addInstanceVariable rewriter renamedReferences' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameInstanceVariable category: #'Tools-Refactoring'! -Refactoring subclass: #RenameInstanceVariable - instanceVariableNames: 'oldVariable addInstanceVariable rewriter renamedReferences' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Refactoring subclass: #RenameTemporary - instanceVariableNames: 'oldVariable newVariable methodNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameTemporary category: #'Tools-Refactoring'! -Refactoring subclass: #RenameTemporary - instanceVariableNames: 'oldVariable newVariable methodNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Refactoring subclass: #SafelyRemoveClass - instanceVariableNames: 'classToRemove' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #SafelyRemoveClass category: #'Tools-Refactoring'! -Refactoring subclass: #SafelyRemoveClass - instanceVariableNames: 'classToRemove' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Object subclass: #RefactoringApplier - instanceVariableNames: 'requestExitBlock refactoring changes' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RefactoringApplier category: #'Tools-Refactoring'! -Object subclass: #RefactoringApplier - instanceVariableNames: 'requestExitBlock refactoring changes' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #AddInstanceVariableApplier - instanceVariableNames: 'classToRefactor oldInstanceVariable newInstanceVariable browser' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #AddInstanceVariableApplier category: #'Tools-Refactoring'! -RefactoringApplier subclass: #AddInstanceVariableApplier - instanceVariableNames: 'classToRefactor oldInstanceVariable newInstanceVariable browser' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #ChangeSelectorApplier - instanceVariableNames: 'oldSelector scopeChoice implementors senders implementingClass wizardStepWindow shouldShowChanges browser' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ChangeSelectorApplier category: #'Tools-Refactoring'! -RefactoringApplier subclass: #ChangeSelectorApplier - instanceVariableNames: 'oldSelector scopeChoice implementors senders implementingClass wizardStepWindow shouldShowChanges browser' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelectorApplier subclass: #AddParameterApplier - instanceVariableNames: 'newParameter newParameterValue newKeyword parameterIndex' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #AddParameterApplier category: #'Tools-Refactoring'! -ChangeSelectorApplier subclass: #AddParameterApplier - instanceVariableNames: 'newParameter newParameterValue newKeyword parameterIndex' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelectorApplier subclass: #RemoveParameterApplier - instanceVariableNames: 'newParameter newParameterValue newKeyword originalMethod parameterToRemove' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RemoveParameterApplier category: #'Tools-Refactoring'! -ChangeSelectorApplier subclass: #RemoveParameterApplier - instanceVariableNames: 'newParameter newParameterValue newKeyword originalMethod parameterToRemove' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelectorApplier subclass: #RenameSelectorApplier - instanceVariableNames: 'newSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameSelectorApplier category: #'Tools-Refactoring'! -ChangeSelectorApplier subclass: #RenameSelectorApplier - instanceVariableNames: 'newSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #InsertSuperclassApplier - instanceVariableNames: 'browser newSuperclassName classToRefactor' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #InsertSuperclassApplier category: #'Tools-Refactoring'! -RefactoringApplier subclass: #InsertSuperclassApplier - instanceVariableNames: 'browser newSuperclassName classToRefactor' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #RemoveAllUnreferencedInstanceVariablesApplier - instanceVariableNames: 'classToRefactor browser variableToRemove' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RemoveAllUnreferencedInstanceVariablesApplier category: #'Tools-Refactoring'! -RefactoringApplier subclass: #RemoveAllUnreferencedInstanceVariablesApplier - instanceVariableNames: 'classToRefactor browser variableToRemove' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #RemoveInstanceVariableApplier - instanceVariableNames: 'classToRefactor browser variableToRemove' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RemoveInstanceVariableApplier category: #'Tools-Refactoring'! -RefactoringApplier subclass: #RemoveInstanceVariableApplier - instanceVariableNames: 'classToRefactor browser variableToRemove' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #RenameClassApplier - instanceVariableNames: 'browser classToRename newClassName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameClassApplier category: #'Tools-Refactoring'! -RefactoringApplier subclass: #RenameClassApplier - instanceVariableNames: 'browser classToRename newClassName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #RenameInstanceVariableApplier - instanceVariableNames: 'classToRefactor oldInstanceVariable newInstanceVariable browser' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameInstanceVariableApplier category: #'Tools-Refactoring'! -RefactoringApplier subclass: #RenameInstanceVariableApplier - instanceVariableNames: 'classToRefactor oldInstanceVariable newInstanceVariable browser' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #RenameTemporaryApplier - instanceVariableNames: 'classToRefactor oldVariable newVariable smalltalkEditor methodNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameTemporaryApplier category: #'Tools-Refactoring'! -RefactoringApplier subclass: #RenameTemporaryApplier - instanceVariableNames: 'classToRefactor oldVariable newVariable smalltalkEditor methodNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #SafelyRemoveClassApplier - instanceVariableNames: 'classToRemove browser' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #SafelyRemoveClassApplier category: #'Tools-Refactoring'! -RefactoringApplier subclass: #SafelyRemoveClassApplier - instanceVariableNames: 'classToRemove browser' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Object subclass: #RefactoringMenues - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RefactoringMenues category: #'Tools-Refactoring'! -Object subclass: #RefactoringMenues - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Object subclass: #RefactoringPrecondition - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RefactoringPrecondition category: #'Tools-Refactoring'! -Object subclass: #RefactoringPrecondition - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringPrecondition subclass: #NewClassPrecondition - instanceVariableNames: 'newClassName system undeclared' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #NewClassPrecondition category: #'Tools-Refactoring'! -RefactoringPrecondition subclass: #NewClassPrecondition - instanceVariableNames: 'newClassName system undeclared' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringPrecondition subclass: #NewInstanceVariablePrecondition - instanceVariableNames: 'classToAddInstVar instVarName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #NewInstanceVariablePrecondition category: #'Tools-Refactoring'! -RefactoringPrecondition subclass: #NewInstanceVariablePrecondition - instanceVariableNames: 'classToAddInstVar instVarName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!CanNotRefactorDueToReferencesError methodsFor: 'references' stamp: 'HAW 7/11/2018 16:56:20'! - anyReference - - ^references anyOne ! ! -!CanNotRefactorDueToReferencesError methodsFor: 'references' stamp: 'HAW 7/11/2018 16:54:54'! - numberOfReferences - - ^references size! ! -!CanNotRefactorDueToReferencesError methodsFor: 'references' stamp: 'HAW 8/1/2018 17:26:49'! - references - - ^references copy! ! -!CanNotRefactorDueToReferencesError methodsFor: 'initialization' stamp: 'HAW 8/1/2018 17:32:33'! - initialize: aMessageText references: aCollectionOfReferences to: aReferencee - - self messageText: aMessageText. - references := aCollectionOfReferences. - referencee := aReferencee ! ! -!CanNotRefactorDueToReferencesError methodsFor: 'referencee' stamp: 'HAW 8/1/2018 17:32:46'! - referencee - - ^referencee ! ! -!CanNotRefactorDueToReferencesError class methodsFor: 'signaling' stamp: 'HAW 8/1/2018 17:32:15'! - signal: aMessageText references: references to: aReferencee - - self new - initialize: aMessageText references: references to: aReferencee; - signal! ! -!ExtractToTemporaryRewriter methodsFor: 'initialization' stamp: 'HAW 10/18/2017 18:21:40'! - initializeOf: anExtractToTemporary on: aParseNodeToReplaceFinder - - refactoring := anExtractToTemporary. - finder := aParseNodeToReplaceFinder ! ! -!ExtractToTemporaryRewriter methodsFor: 'visiting' stamp: 'HAW 10/18/2017 18:26:27'! - visitBlockNode: aBlockNode - - | statements | - - statements := aBlockNode statements. - statements withIndexDo: [ :statement :index | - (finder shouldReplace: statement) - ifTrue: [ statements at: index put: refactoring newTemporary ] - ifFalse: [ statement accept: self]]! ! -!ExtractToTemporaryRewriter methodsFor: 'visiting' stamp: 'HAW 10/19/2017 06:24:35'! - visitMessageNode: aMessageNode - - aMessageNode receiver accept: self. - aMessageNode selector accept: self. - aMessageNode argumentsInEvaluationOrder withIndexDo: [:argument :index | - (finder shouldReplace: argument) - ifTrue: [ aMessageNode arguments at: index put: refactoring newTemporary ] - ifFalse: [ argument accept: self]]! ! -!ExtractToTemporaryRewriter methodsFor: 'visiting' stamp: 'HAW 10/19/2017 06:06:05'! - visitReturnNode: aReturnNode - - (finder shouldReplace: aReturnNode expr) - ifTrue: [ aReturnNode expr: refactoring newTemporary ] - ifFalse: [ super visitReturnNode: aReturnNode ]! ! -!ExtractToTemporaryRewriter class methodsFor: 'instance creation' stamp: 'HAW 10/18/2017 18:21:16'! - of: anExtractToTemporary on: aParseNodeToReplaceFinder - - ^self new initializeOf: anExtractToTemporary on: aParseNodeToReplaceFinder - ! ! -!ParseNodeToReplaceFinder methodsFor: 'as yet unclassified' stamp: 'HAW 10/19/2017 06:03:12'! - addNodeToReplace: aParseNode - - nodesToReplace isEmpty ifTrue: [ - blockContainingFirstNodeToReplace := currentBlock. - firstNodeToReplaceIndex := currentStatementIndex ]. - - nodesToReplace add: aParseNode.! ! -!ParseNodeToReplaceFinder methodsFor: 'as yet unclassified' stamp: 'HAW 10/18/2017 18:30:44'! - blockContainingFirstNodeToReplace - - ^blockContainingFirstNodeToReplace! ! -!ParseNodeToReplaceFinder methodsFor: 'as yet unclassified' stamp: 'HAW 10/18/2017 18:31:00'! - firstNodeToReplace - - ^nodesToReplace first! ! -!ParseNodeToReplaceFinder methodsFor: 'as yet unclassified' stamp: 'HAW 10/18/2017 18:39:56'! - firstNodeToReplaceIndex - - ^firstNodeToReplaceIndex! ! -!ParseNodeToReplaceFinder methodsFor: 'as yet unclassified' stamp: 'HAW 10/18/2017 18:12:47'! - keepCurrentBlockIfFirstNodeToReplace - - nodesToReplace isEmpty ifTrue: [ blockContainingFirstNodeToReplace := currentBlock ]. -! ! -!ParseNodeToReplaceFinder methodsFor: 'as yet unclassified' stamp: 'HAW 10/18/2017 18:26:50'! -shouldReplace: aParseNode - - ^nodesToReplace includes: aParseNode ! ! -!ParseNodeToReplaceFinder methodsFor: 'initialization' stamp: 'HAW 10/18/2017 18:12:47'! - initializeOf: anExtractToTemporary - - refactoring := anExtractToTemporary. - nodesToReplace := OrderedCollection new.! ! -!ParseNodeToReplaceFinder methodsFor: 'visiting' stamp: 'HAW 10/19/2017 06:02:34'! - visitBlockNode: aBlockNode - - | previousBlock | - - previousBlock := currentBlock. - currentBlock := aBlockNode. - - aBlockNode statements withIndexDo: [:statement :index | - currentStatementIndex := index. - statement accept: self]. - - currentBlock := previousBlock ! ! -!ParseNodeToReplaceFinder methodsFor: 'visiting' stamp: 'HAW 10/18/2017 18:12:47'! - visitLiteralNode: aLiteralNode - - (refactoring shouldExtract: aLiteralNode) ifTrue: [ self addNodeToReplace: aLiteralNode ]! ! -!ParseNodeToReplaceFinder methodsFor: 'visiting' stamp: 'HAW 10/19/2017 06:20:02'! - visitMessageNode: aMessageNode - - super visitMessageNode: aMessageNode! ! -!ParseNodeToReplaceFinder class methodsFor: 'instance creation' stamp: 'HAW 10/18/2017 18:12:47'! - of: anExtractToTemporary - - ^self new initializeOf: anExtractToTemporary ! ! -!ChangeSelectorWizardStepWindow methodsFor: 'actions' stamp: 'HAW 5/31/2017 17:26:05'! - add - - self subclassResponsibility ! ! -!ChangeSelectorWizardStepWindow methodsFor: 'actions' stamp: 'HAW 5/31/2017 17:36:12'! - addToList: aMethod - - model addMethodReference: aMethod methodReference ifIncluded: [ self inform: 'Method already in list' ]! ! -!ChangeSelectorWizardStepWindow methodsFor: 'actions' stamp: 'HAW 10/9/2018 20:57:59'! - do: aBlock withEnteredClassLabeled: aLabel - - | className | - - className := ClassNameRequestMorph request: aLabel onCancel: [ ^self ]. - ^self withClassNamed: className do: aBlock! ! -!ChangeSelectorWizardStepWindow methodsFor: 'actions' stamp: 'HAW 5/31/2017 18:17:19'! - inform: aClass doesNotImplement: aSelector - - self inform: aClass name, ' does not implement #', aSelector ! ! -!ChangeSelectorWizardStepWindow methodsFor: 'actions' stamp: 'HAW 1/7/2019 11:02:43'! - justRefactor - - applier doNotShowChanges. - self refactor.! ! -!ChangeSelectorWizardStepWindow methodsFor: 'actions' stamp: 'HAW 1/7/2019 11:16:36'! - refactor - - applier wizardStepWindow: self. - applier wizardEnded. - ! ! -!ChangeSelectorWizardStepWindow methodsFor: 'actions' stamp: 'HAW 5/31/2017 17:07:19'! -remove - - model removeMessageFromBrowserKeepingLabel! ! -!ChangeSelectorWizardStepWindow methodsFor: 'actions' stamp: 'HAW 10/10/2018 05:46:24'! - withClassNamed: aName do: aBlock - - | trimmedNamed | - - trimmedNamed := aName withBlanksTrimmed. - - (Smalltalk classNamed: trimmedNamed asSymbol) - ifNotNil: aBlock - ifNil: [ self inform: 'Class ', trimmedNamed , ' does not exist' ]. -! ! -!ChangeSelectorWizardStepWindow methodsFor: 'GUI building' stamp: 'HAW 5/31/2017 17:22:39'! - addButton: button to: row color: buttonColor - - button color: buttonColor. - row addMorph: button proportionalWidth: 10! ! -!ChangeSelectorWizardStepWindow methodsFor: 'GUI building' stamp: 'HAW 5/31/2017 17:18:46'! - addButtonsTo: row color: buttonColor - - self subclassResponsibility ! ! -!ChangeSelectorWizardStepWindow methodsFor: 'GUI building' stamp: 'HAW 5/31/2017 17:26:55'! - buildLowerPanes - - | codeAndButtons | - - codeAndButtons _ LayoutMorph newColumn. - codeAndButtons - addMorph: self buttonsRow fixedHeight: self defaultButtonPaneHeight; - addAdjusterMorph; - addMorph: self buildMorphicCodePane proportionalHeight: 1.0. - - ^codeAndButtons ! ! -!ChangeSelectorWizardStepWindow methodsFor: 'GUI building' stamp: 'HAW 5/31/2017 17:27:25'! - buttonsRow - - | buttonColor row | - - buttonColor := self buttonColor. - row := LayoutMorph newRow. - row doAdoptWidgetsColor. - row color: buttonColor. - - self addButtonsTo: row color: buttonColor. - - ^row - - ! ! -!ChangeSelectorWizardStepWindow methodsFor: 'compile methods' stamp: 'HAW 5/31/2017 17:08:14'! - compiledMethodsFrom: methodReferences - - ^ methodReferences collect: [:aMethodReference | aMethodReference compiledMethod ]! ! -!ChangeSelectorWizardStepWindow methodsFor: 'button creation' stamp: 'HAW 5/31/2017 17:21:11'! - createAddButton - - ^PluggableButtonMorph - model: self - stateGetter: nil - action: #add - label: 'Add'. -! ! -!ChangeSelectorWizardStepWindow methodsFor: 'button creation' stamp: 'HAW 5/31/2017 17:21:19'! - createCancelButton - - ^PluggableButtonMorph - model: self - stateGetter: nil - action: #delete - label: 'Cancel'. -! ! -!ChangeSelectorWizardStepWindow methodsFor: 'button creation' stamp: 'HAW 10/10/2018 19:47:37'! - createJustRefactorButton - - ^PluggableButtonMorph - model: self - stateGetter: nil - action: #justRefactor - label: 'Just Refactor!!'! ! -!ChangeSelectorWizardStepWindow methodsFor: 'button creation' stamp: 'HAW 10/10/2018 19:47:43'! - createRefactorButton - - ^PluggableButtonMorph - model: self - stateGetter: nil - action: #refactor - label: 'Refactor'! ! -!ChangeSelectorWizardStepWindow methodsFor: 'button creation' stamp: 'HAW 5/31/2017 17:16:37'! - createRemoveButton - - ^PluggableButtonMorph - model: self - stateGetter: #isMessageSelected - action: #remove - label: 'Remove'. -! ! -!ChangeSelectorWizardStepWindow methodsFor: 'initialization' stamp: 'HAW 1/7/2019 11:04:02'! - initializeFrom: aChangeSelectorApplier - - applier := aChangeSelectorApplier ! ! -!ChangeSelectorWizardStepWindow methodsFor: 'testing' stamp: 'HAW 6/5/2017 17:40:16'! - isMessageSelected - - ^model isNil ifTrue: [ false ] ifFalse: [ model selection notNil ]! ! -!ChangeSelectorWizardStepWindow methodsFor: 'accessing' stamp: 'HAW 1/7/2019 11:02:43'! - oldSelector - - ^applier oldSelector ! ! -!ChangeSelectorWizardStepWindow class methodsFor: 'instance creation' stamp: 'HAW 5/31/2017 16:59:25'! - methodReferencesOf: methods - - ^methods asOrderedCollection collect: [:aCompiledMethod | aCompiledMethod methodReference ]. -! ! -!ChangeSelectorWizardStepWindow class methodsFor: 'instance creation' stamp: 'HAW 1/7/2019 11:03:50'! - openFrom: aChangeSelectorApplier methods: methods label: aLabel - - | window | - - window := self openMessageList: (self methodReferencesOf: methods) label: aLabel autoSelect: aChangeSelectorApplier oldSelector. - window initializeFrom: aChangeSelectorApplier. - - ^window - -! ! -!ChangeSelectorImplementorsStepWindow methodsFor: 'actions' stamp: 'HAW 6/5/2017 17:33:16'! - add - - self - do: [ :classOfImplementorToAdd | self addImplementorIn: classOfImplementorToAdd ] - withEnteredClassLabeled: 'Class that implements ', self oldSelector ! ! -!ChangeSelectorImplementorsStepWindow methodsFor: 'actions' stamp: 'HAW 6/5/2017 17:33:26'! - addImplementorIn: classOfImplementorToAdd - - | implementorToAdd | - - implementorToAdd := classOfImplementorToAdd - compiledMethodAt: self oldSelector - ifAbsent: [ ^self inform: classOfImplementorToAdd doesNotImplement: self oldSelector ]. - - self addToList: implementorToAdd! ! -!ChangeSelectorImplementorsStepWindow methodsFor: 'actions' stamp: 'HAW 1/7/2019 11:02:43'! - changeImplementors - - applier implementors: (self compiledMethodsFrom: model messageList). - ! ! -!ChangeSelectorImplementorsStepWindow methodsFor: 'actions' stamp: 'HAW 10/10/2018 18:07:57'! - refactor - - self changeImplementors. - super refactor ! ! -!ChangeSelectorImplementorsStepWindow methodsFor: 'actions' stamp: 'HAW 1/7/2019 11:17:47'! - seeSenders - - self changeImplementors. - self delete. - - ChangeSelectorSendersStepWindow openFrom: applier ! ! -!ChangeSelectorImplementorsStepWindow methodsFor: 'GUI building' stamp: 'HAW 10/10/2018 19:55:34'! - addButtonsTo: row color: buttonColor - - self addButton: self createRemoveButton to: row color: buttonColor. - self addButton: self createAddButton to: row color: buttonColor. - self addButton: self createSeeSendersButton to: row color: buttonColor. - self addButton: self createRefactorButton to: row color: buttonColor. - self addButton: self createJustRefactorButton to: row color: buttonColor. - self addButton: self createCancelButton to: row color: buttonColor. -! ! -!ChangeSelectorImplementorsStepWindow methodsFor: 'button creation' stamp: 'HAW 10/10/2018 19:55:52'! - createSeeSendersButton - - ^PluggableButtonMorph - model: self - stateGetter: nil - action: #seeSenders - label: 'See Senders'. - -! ! -!ChangeSelectorImplementorsStepWindow class methodsFor: 'instance creation' stamp: 'HAW 8/18/2018 17:26:33'! - openFrom: aChangeSelectorRequest - - ^self - openFrom: aChangeSelectorRequest - methods: aChangeSelectorRequest implementors - label: 'Implementors of #', aChangeSelectorRequest oldSelector, ' to Refactor' -! ! -!ChangeSelectorSendersStepWindow methodsFor: 'actions' stamp: 'HAW 6/5/2017 17:36:00'! - add - - self - do: [ :classOfSenderToAdd | self askAndAddSenderOf: classOfSenderToAdd ] - withEnteredClassLabeled: 'Class that sends #', self oldSelector - ! ! -!ChangeSelectorSendersStepWindow methodsFor: 'actions' stamp: 'HAW 11/8/2018 15:25:57'! - askAndAddSenderOf: classOfSenderToAdd - - | senderSelector senderToAdd | - - senderSelector := FillInTheBlankMorph request: 'Selector of sender of #', self oldSelector onCancel: [^self ]. - senderToAdd := classOfSenderToAdd - compiledMethodAt: senderSelector asSymbol - ifAbsent: [ ^self inform: classOfSenderToAdd doesNotImplement: senderSelector asSymbol]. - - (senderToAdd sendsOrRefersTo: self oldSelector) ifFalse: [ ^self inform: senderToAdd classAndSelector, ' does not refer to #', self oldSelector ]. - - self addToList: senderToAdd ! ! -!ChangeSelectorSendersStepWindow methodsFor: 'actions' stamp: 'HAW 1/7/2019 11:02:43'! - changeRequestSenders - - applier senders: (self compiledMethodsFrom: model messageList). - ! ! -!ChangeSelectorSendersStepWindow methodsFor: 'actions' stamp: 'HAW 10/10/2018 18:09:18'! - refactor - - self changeRequestSenders. - super refactor ! ! -!ChangeSelectorSendersStepWindow methodsFor: 'actions' stamp: 'HAW 1/7/2019 11:17:34'! - seeImplementors - - self changeRequestSenders. - self delete. - - ChangeSelectorImplementorsStepWindow openFrom: applier! ! -!ChangeSelectorSendersStepWindow methodsFor: 'GUI building' stamp: 'HAW 10/10/2018 19:56:45'! - addButtonsTo: row color: buttonColor - - self addButton: self createRemoveButton to: row color: buttonColor. - self addButton: self createAddButton to: row color: buttonColor. - self addButton: self createSeeImplementorsButton to: row color: buttonColor. - self addButton: self createRefactorButton to: row color: buttonColor. - self addButton: self createJustRefactorButton to: row color: buttonColor. - self addButton: self createCancelButton to: row color: buttonColor. -! ! -!ChangeSelectorSendersStepWindow methodsFor: 'button creation' stamp: 'HAW 10/10/2018 19:56:51'! - createSeeImplementorsButton - - ^PluggableButtonMorph - model: self - stateGetter: nil - action: #seeImplementors - label: 'See Implementors'. -! ! -!ChangeSelectorSendersStepWindow class methodsFor: 'instance creation' stamp: 'HAW 8/18/2018 17:26:18'! - openFrom: aChangeSelectorRequest - - ^self - openFrom: aChangeSelectorRequest - methods: aChangeSelectorRequest senders - label: 'Senders of #', aChangeSelectorRequest oldSelector, ' to Refactor' ! ! -!Refactoring methodsFor: 'applying' stamp: 'HAW 5/24/2017 21:08:11'! - apply - - self subclassResponsibility ! ! -!Refactoring class methodsFor: 'exceptions' stamp: 'HAW 8/17/2018 16:34:16'! - canNotRefactorDueToReferencesError: aMessageText references: references to: referencee - - ^self canNotRefactorDueToReferencesErrorClass - signal: aMessageText - references: references - to: referencee ! ! -!Refactoring class methodsFor: 'exceptions' stamp: 'HAW 8/17/2018 16:32:42'! - canNotRefactorDueToReferencesErrorClass - - ^CanNotRefactorDueToReferencesError! ! -!Refactoring class methodsFor: 'exceptions' stamp: 'HAW 6/3/2017 11:58:07'! - refactoringError: aMessage - - self refactoringErrorClass signal: aMessage.! ! -!Refactoring class methodsFor: 'exceptions' stamp: 'HAW 6/3/2017 11:58:21'! - refactoringErrorClass - - ^ RefactoringError.! ! -!Refactoring class methodsFor: 'warnings' stamp: 'HAW 6/11/2017 18:49:41'! - refactoringWarning: aMessageText - - ^ self refactoringWarningClass signal: aMessageText.! ! -!Refactoring class methodsFor: 'warnings' stamp: 'HAW 6/3/2017 12:05:48'! - refactoringWarningClass - - ^ RefactoringWarning.! ! -!AddInstanceVariable methodsFor: 'applying' stamp: 'HAW 6/11/2017 18:27:26'! -apply - - classToRefactor addInstVarName: newVariable. - ! ! -!AddInstanceVariable methodsFor: 'accessing' stamp: 'HAW 6/11/2017 19:09:54'! - classToRefactor - - ^classToRefactor ! ! -!AddInstanceVariable methodsFor: 'accessing' stamp: 'HAW 6/6/2017 10:10:40'! - newVariable - - ^newVariable ! ! -!AddInstanceVariable methodsFor: 'initialization' stamp: 'HAW 6/6/2017 10:10:26'! - initializeNamed: aNewVariable to: aClassToRefactor - - newVariable := aNewVariable. - classToRefactor := aClassToRefactor ! ! -!AddInstanceVariable class methodsFor: 'instance creation' stamp: 'HAW 3/4/2019 11:43:12'! - named: aVariable to: aClassToRefactor - - | trimmedVariable | - - trimmedVariable := aVariable withBlanksTrimmed. - NewInstanceVariablePrecondition valueOf: trimmedVariable for: aClassToRefactor. - ^self new initializeNamed: trimmedVariable to: aClassToRefactor - ! ! -!ChangeSelector methodsFor: 'applying' stamp: 'HAW 11/29/2018 15:19:19'! - apply - - self - createNewImplementors; - renameSenders; - removeOldImplementors. - - ^changes -! ! -!ChangeSelector methodsFor: 'remove old implementors - private' stamp: 'HAW 8/18/2018 12:02:34'! - removeOldImplementor: anImplementor - - anImplementor methodClass removeSelector: anImplementor selector. - changes add: anImplementor methodReference! ! -!ChangeSelector methodsFor: 'remove old implementors - private' stamp: 'HAW 8/18/2018 12:01:49'! - removeOldImplementors - - implementors do: [:anImplementor | self removeOldImplementor: anImplementor ]! ! -!ChangeSelector methodsFor: 'create new implementors - private' stamp: 'HAW 11/8/2018 15:24:06'! - addToSendersIfOldSelectorIsSentIn: newImplementor - - (newImplementor sendsOrRefersTo: oldSelector) ifTrue: [ senders add: newImplementor ]. - ! ! -!ChangeSelector methodsFor: 'create new implementors - private' stamp: 'HAW 3/4/2019 15:24:22'! - compileNewImplementorOf: anImplementor - - | implementorClassification newSourceCode | - - newSourceCode := self implementorNewSourceCodeOf: anImplementor. - implementorClassification := anImplementor methodClass organization categoryOfElement: oldSelector. - - anImplementor methodClass - compile: newSourceCode - classified: implementorClassification. -! ! -!ChangeSelector methodsFor: 'create new implementors - private' stamp: 'HAW 8/18/2018 12:02:25'! - createNewImplementorOf: anImplementor - - | newImplementor | - - self compileNewImplementorOf: anImplementor. - newImplementor := anImplementor methodClass compiledMethodAt: newSelector. - self addToSendersIfOldSelectorIsSentIn: newImplementor. - - changes add: newImplementor methodReference - - ! ! -!ChangeSelector methodsFor: 'create new implementors - private' stamp: 'HAW 8/18/2018 12:02:52'! - createNewImplementors - - implementors do: [:anImplementor | self createNewImplementorOf: anImplementor ] - ! ! -!ChangeSelector methodsFor: 'create new implementors - private' stamp: 'HAW 8/18/2018 12:06:01'! - implementorNewSourceCodeOf: anImplementor - - self subclassResponsibility ! ! -!ChangeSelector methodsFor: 'rename senders - private' stamp: 'HAW 11/29/2018 15:28:39'! - add: oldSelectorLiteralRanges to: rangesToKeywords - - oldSelectorLiteralRanges do: [ :oldSelectorLiteralRange | - rangesToKeywords add: (oldSelectorLiteralRange first + 1 to: oldSelectorLiteralRange last) -> newSelector ]. - - - ! ! -!ChangeSelector methodsFor: 'rename senders - private' stamp: 'HAW 8/18/2018 12:05:39'! - addMessageSendSelectorKeywordRangesOf: aMethodNode to: rangesToKeywords - - self subclassResponsibility ! ! -!ChangeSelector methodsFor: 'rename senders - private' stamp: 'HAW 11/29/2018 15:29:06'! - addRangesForLiteralInLiteralArrayOf: methodNode to: rangesToKeywords - - | oldSelectorLiteralRanges | - - oldSelectorLiteralRanges := methodNode positionsInLiteralArrayOf: oldSelector. - self add: oldSelectorLiteralRanges to: rangesToKeywords ! ! -!ChangeSelector methodsFor: 'rename senders - private' stamp: 'HAW 11/29/2018 15:28:27'! - addRangesForLiteralOf: methodNode to: rangesToKeywords - - | oldSelectorLiteralRanges | - - oldSelectorLiteralRanges := methodNode positionsForLiteralNode: oldSelector ifAbsent: [ ^#() ]. - self add: oldSelectorLiteralRanges to: rangesToKeywords. - ! ! -!ChangeSelector methodsFor: 'rename senders - private' stamp: 'HAW 11/29/2018 14:16:42'! - rangesToKeywordsOf: aMethod - - | methodNode rangesToKeywords | - - methodNode := aMethod methodNode. - rangesToKeywords := SortedCollection sortBlock: [ :left :right | left key first < right key first ]. - - self addMessageSendSelectorKeywordRangesOf: methodNode to: rangesToKeywords. - self addRangesForLiteralOf: methodNode to: rangesToKeywords. - self addRangesForLiteralInLiteralArrayOf: methodNode to: rangesToKeywords. - - ^rangesToKeywords ! ! -!ChangeSelector methodsFor: 'rename senders - private' stamp: 'HAW 8/18/2018 12:03:19'! - renameSenders - - senders do: [ :aSender | self renameSendersIn: aSender ]. - ! ! -!ChangeSelector methodsFor: 'rename senders - private' stamp: 'HAW 9/4/2018 19:25:20'! - renameSendersIn: aMethod - - | newSource rangesToNewStrings | - - rangesToNewStrings := self rangesToKeywordsOf: aMethod. - newSource := aMethod sourceCode copyReplacing: rangesToNewStrings. - aMethod methodClass compile: newSource. - - changes add: (MethodReference class: aMethod methodClass selector: aMethod selector)! ! -!ChangeSelector methodsFor: 'implementors/senders' stamp: 'HAW 8/18/2018 12:04:37'! - implementorsSize - - ^implementors size! ! -!ChangeSelector methodsFor: 'implementors/senders' stamp: 'HAW 8/18/2018 12:03:31'! - sendersSize - - ^senders size! ! -!ChangeSelector methodsFor: 'initialization' stamp: 'HAW 9/3/2018 17:17:19'! - initializeFrom: anOldSelector to: aNewSelector implementors: aCollectionOfImplementors senders: aCollectionOfSenders - - oldSelector := anOldSelector. - newSelector := aNewSelector. - implementors := aCollectionOfImplementors. - "I have to make a copy of senders because it can change with recursive implementors - Hernan" - senders := aCollectionOfSenders asOrderedCollection. - - changes := Set new - ! ! -!ChangeSelector methodsFor: 'selectors' stamp: 'HAW 1/7/2019 13:59:37'! - newSelector - - ^newSelector ! ! -!ChangeSelector class methodsFor: 'pre-conditions' stamp: 'HAW 8/18/2018 12:39:40'! - assertAllImplementors: implementors haveSame: aSelector - - | invalidImplementors | - - invalidImplementors := implementors reject: [ :anImplementor | anImplementor selector = aSelector ]. - invalidImplementors notEmpty ifTrue: [ self signalInvalidImplementors: invalidImplementors ].! ! -!ChangeSelector class methodsFor: 'pre-conditions' stamp: 'HAW 11/29/2018 12:04:20'! - assertAllSenders: senders send: aSelector - - | invalidSenders | - - invalidSenders := senders reject: [ :aSender | aSender sendsOrRefersTo: aSelector ]. - invalidSenders notEmpty ifTrue: [ self signalInvalidSenders: invalidSenders of: aSelector ]! ! -!ChangeSelector class methodsFor: 'exceptions' stamp: 'HAW 1/7/2019 10:51:35'! - errorMessageForInvalidImplementors: aCollectionOfInvalidImplementors - - ^String streamContents: [ :stream | - stream - nextPutAll: (aCollectionOfInvalidImplementors size = 1 ifTrue: [ 'This method' ] ifFalse: [ 'These methods']); - nextPutAll: ' do not have same the same selector to rename: '. - aCollectionOfInvalidImplementors asCommaSeparated: [:anImplementor | anImplementor printClassAndSelectorOn: stream ] on: stream ] ! ! -!ChangeSelector class methodsFor: 'exceptions' stamp: 'HAW 1/7/2019 10:51:35'! - errorMessageForInvalidSenders: aCollectionOfInvalidSenders of: anOldSelector - - ^String streamContents: [ :stream | - stream - nextPutAll: 'Message #'; - nextPutAll: anOldSelector; - nextPutAll: ' is not send by: '. - aCollectionOfInvalidSenders asCommaSeparated: [:aSender | aSender printClassAndSelectorOn: stream ] on: stream ] ! ! -!ChangeSelector class methodsFor: 'exceptions' stamp: 'HAW 8/18/2018 12:43:59'! - signalInvalidImplementors: invalidImplementors - - self refactoringError: (self errorMessageForInvalidImplementors: invalidImplementors).! ! -!ChangeSelector class methodsFor: 'exceptions' stamp: 'HAW 8/18/2018 15:49:58'! - signalInvalidSenders: invalidSender of: aSelector - - self refactoringError: (self errorMessageForInvalidSenders: invalidSender of: aSelector).! ! -!ChangeSelector class methodsFor: 'implementors and senders' stamp: 'HAW 8/18/2018 17:19:35'! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders forClassAndMetaOf: aPotentialClassToRefactor - - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders of: aPotentialClassToRefactor theNonMetaClass. - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders of: aPotentialClassToRefactor theMetaClass. - -! ! -!ChangeSelector class methodsFor: 'implementors and senders' stamp: 'HAW 8/18/2018 17:19:39'! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategoriesAndHierarchyOf: aClass organizedBy: anOrganization - - | categories | - - categories := Set new. - - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inHierarchyOf: aClass doingPerClass: [:aClassInHierarchy | categories add: aClassInHierarchy category ]. - categories do: [:aCategory | self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategory: aCategory organizedBy: anOrganization ]. -! ! -!ChangeSelector class methodsFor: 'implementors and senders' stamp: 'HAW 8/18/2018 17:19:42'! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategory: aCategory organizedBy: anOrganization - - | classesInCategory | - - classesInCategory := anOrganization classesAt: aCategory. - classesInCategory do: [ :aPotentialClassToRefactor | self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders forClassAndMetaOf: aPotentialClassToRefactor ]. -! ! -!ChangeSelector class methodsFor: 'implementors and senders' stamp: 'HAW 8/18/2018 17:19:45'! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inHierarchyOf: aClass - - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inHierarchyOf: aClass doingPerClass: [ :aClassInHierarchy | ] - - ! ! -!ChangeSelector class methodsFor: 'implementors and senders' stamp: 'HAW 8/18/2018 17:19:49'! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inHierarchyOf: aClass doingPerClass: aBlock - - aClass theNonMetaClass withAllSubAndSuperclassesDo: [ :aPotentialClassToRefactor | - aPotentialClassToRefactor isMeta ifFalse: [ - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders forClassAndMetaOf: aPotentialClassToRefactor. - aBlock value: aPotentialClassToRefactor ]] - ! ! -!ChangeSelector class methodsFor: 'implementors and senders' stamp: 'HAW 8/18/2018 17:19:52'! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inSystem: aSystem - - aSystem allBehaviorsDo: [ :aPotentialClassToRefactor | - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders of: aPotentialClassToRefactor ]. -! ! -!ChangeSelector class methodsFor: 'implementors and senders' stamp: 'HAW 10/15/2018 20:53:23'! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders of: aPotentialClassToRefactor - - | potentialImplementor | - - potentialImplementor := aPotentialClassToRefactor compiledMethodAt: anOldSelector ifAbsent: [ nil ]. - potentialImplementor ifNotNil: [ implementors add: potentialImplementor ]. - - (aPotentialClassToRefactor whichSelectorsReferTo: anOldSelector) do: [ :aSelector | senders add: (aPotentialClassToRefactor compiledMethodAt: aSelector) ]. - ! ! -!AddParameter methodsFor: 'initialization' stamp: 'HAW 9/4/2018 19:00:42'! - initializedNamed: aNewParameter - at: anIndex - addingLast: anIsAddingLast - initializedWith: aNewParameterValue - to: anOldSelector - implementing: aNewSelector - addingToImplementors: anImplementorTrailingString - addingToSenders: aSenderTrailingString - implementors: implementorsCollection - senders: sendersCollection - - super initializeFrom: anOldSelector to: aNewSelector implementors: implementorsCollection senders: sendersCollection. - - newParameter := aNewParameter. - newParameterValue := aNewParameterValue. - implementorTrailingString := anImplementorTrailingString. - senderTrailingString := aSenderTrailingString. - - index := anIndex. - isAddingLast := anIsAddingLast ! ! -!AddParameter methodsFor: 'rename senders - private' stamp: 'HAW 3/4/2019 10:21:05'! - addMessageSendSelectorKeywordRangesOf: aMethodNode to: rangesToKeywords - - | insertionPoints senderSourceCode | - - senderSourceCode := aMethodNode sourceText. - isAddingLast - ifTrue: [ - insertionPoints := aMethodNode messageSendLastPositionsOf: oldSelector ifAbsent: [ #() ]. - insertionPoints do: [ :aPosition | | newPosition | - newPosition := self firstNoSeparatorIndexIn: senderSourceCode startingFrom: aPosition. - rangesToKeywords add: ((newPosition+1) to: newPosition) -> senderTrailingString ]] - ifFalse: [ - insertionPoints := aMethodNode messageSendKeywordPositionsAt: index of: oldSelector ifAbsent: [ #()]. - insertionPoints do: [ :aPosition | - rangesToKeywords add: (aPosition to: aPosition-1) -> senderTrailingString ]] - ! ! -!AddParameter methodsFor: 'rename senders - private' stamp: 'HAW 11/11/2018 14:07:23'! - firstNoLineSeparatorIndexIn: sourceCode startingFrom: aStartingPosition - - ^self firstNot: [ :aChar | aChar isLineSeparator ] indexIn: sourceCode startingFrom: aStartingPosition ! ! -!AddParameter methodsFor: 'rename senders - private' stamp: 'HAW 11/11/2018 14:06:46'! - firstNoSeparatorIndexIn: sourceCode startingFrom: aStartingPosition - - "Looks going back for the first no separator char. See #test24AddingParameterToSendersTakeCaresOfSeparators - It assumes that there is always going to be a no separator wich holds due to how aStartPosition is obtained - Hernan" - - ^self firstNot: [ :aChar | aChar isSeparator ] indexIn: sourceCode startingFrom: aStartingPosition ! ! -!AddParameter methodsFor: 'rename senders - private' stamp: 'HAW 1/7/2019 13:43:36'! - firstNot: aBlock indexIn: sourceCode startingFrom: aStartingPosition - - | noSeparatorIndex | - - noSeparatorIndex := aStartingPosition. - [ noSeparatorIndex > 0 and: [ aBlock value: (sourceCode at: noSeparatorIndex) ]] whileTrue: [ noSeparatorIndex := noSeparatorIndex - 1 ]. - - ^noSeparatorIndex - ! ! -!AddParameter methodsFor: 'create new implementors - private' stamp: 'HAW 11/11/2018 14:07:55'! - implementorNewSourceCodeOf: anImplementor - - | implementorMethodNode newSource originalSource insertionPoint | - - implementorMethodNode := anImplementor methodNode. - insertionPoint := isAddingLast - ifTrue: [ implementorMethodNode selectorLastPosition ] - ifFalse: [ (implementorMethodNode selectorKeywordPositionAt: index) first - 1]. - - originalSource := anImplementor sourceCode. - insertionPoint := self firstNoLineSeparatorIndexIn: originalSource startingFrom: insertionPoint. - - newSource := String streamContents: [ :newSourceStream | - newSourceStream - nextPutAll: (originalSource copyFrom: 1 to: insertionPoint); - nextPutAll: implementorTrailingString; - nextPutAll: (originalSource copyFrom: insertionPoint+1 to: originalSource size) ]. - - ^newSource! ! -!AddParameter class methodsFor: 'instance creation' stamp: 'HAW 9/4/2018 19:59:06'! - named: aNewParameter - at: anIndex - initializedWith: aNewParameterValue - using: aNewKeyword - toKeywordSelector: anOldSelector - implementors: implementorsCollection - senders: sendersCollection - - | validNewParameterValue isAddingLast numberOfParameters | - - self assertIsKeyword: anOldSelector. - self assertIsValidKeywordForNewParameter: aNewKeyword. - validNewParameterValue := self assertNewParameterValueIsValid: aNewParameterValue. - numberOfParameters := anOldSelector numArgs. - self assert: anIndex isValidIndexFor: numberOfParameters. - isAddingLast := anIndex > numberOfParameters. - - ^self - named: aNewParameter - at: anIndex - addingLast: isAddingLast - initializedWith: aNewParameterValue - to: anOldSelector - implementing: (self newSelectorAdding: aNewKeyword at: anIndex to: anOldSelector) - addingToImplementors: (self keywordImplementorTrailingFor: aNewKeyword and: aNewParameter addingLast: isAddingLast) - addingToSenders: (self keywordSenderTrailingFor: aNewKeyword and: validNewParameterValue addingLast: isAddingLast) - implementors: implementorsCollection - senders: sendersCollection -! ! -!AddParameter class methodsFor: 'instance creation' stamp: 'HAW 9/4/2018 19:32:45'! - named: aNewParameter - initializedWith: aNewParameterValue - toUnarySelector: anOldSelector - implementors: implementorsCollection - senders: sendersCollection - - | validNewParameterValue | - - self assertIsUnary: anOldSelector. - validNewParameterValue := self assertNewParameterValueIsValid: aNewParameterValue. - - ^self - named: aNewParameter - at: 1 - addingLast: true - initializedWith: aNewParameterValue - to: anOldSelector - implementing: (self newSelectorFromUnary: anOldSelector) - addingToImplementors: (self unaryImplementorTrailingFor: aNewParameter) - addingToSenders: (self unarySenderTrailingFor: validNewParameterValue) - implementors: implementorsCollection - senders: sendersCollection -! ! -!AddParameter class methodsFor: 'instance creation' stamp: 'HAW 9/4/2018 17:26:10'! - named: aNewParameter - initializedWith: aNewParameterValue - using: aNewKeyword - toKeywordSelector: anOldSelector - implementors: implementorsCollection - senders: sendersCollection - - ^self - named: aNewParameter - at: anOldSelector numArgs + 1 - initializedWith: aNewParameterValue - using: aNewKeyword - toKeywordSelector: anOldSelector - implementors: implementorsCollection - senders: sendersCollection -! ! -!AddParameter class methodsFor: 'instance creation - private' stamp: 'HAW 9/4/2018 19:05:41'! -keywordImplementorTrailingFor: aNewKeyword and: aNewParameter addingLast: isAddingLast - - ^String streamContents: [ :stream | - isAddingLast ifTrue: [ stream space ]. - stream - nextPutAll: aNewKeyword; - space; - nextPutAll: aNewParameter; - space ]! ! -!AddParameter class methodsFor: 'instance creation - private' stamp: 'HAW 9/4/2018 19:23:31'! - keywordSenderTrailingFor: aNewKeyword and: aNewParameterValue addingLast: isAddingLast - - ^String streamContents: [ :stream | - isAddingLast ifTrue: [ stream space ]. - stream - nextPutAll: aNewKeyword; - space; - nextPutAll: aNewParameterValue. - isAddingLast ifFalse: [ stream space ] ] - - ! ! -!AddParameter class methodsFor: 'instance creation - private' stamp: 'HAW 9/4/2018 19:00:16'! - named: aNewParameter - at: anIndex - addingLast: isAddingLast - initializedWith: aNewParameterValue - to: anOldSelector - implementing: aNewSelector - addingToImplementors: implementorTrailingString - addingToSenders: senderTrailingString - implementors: implementorsCollection - senders: sendersCollection - - | trimmedNewParameter | - - trimmedNewParameter := aNewParameter withBlanksTrimmed. - - self assertCanAddParameterTo: anOldSelector. - self assertIsValidParameterName: trimmedNewParameter. - self assertNewParameter: trimmedNewParameter isNotDefinedAsInstanceVariableInAny: implementorsCollection. - self assertNewParameter: trimmedNewParameter isNotDefinedAsLocalInAny: implementorsCollection. - self assertAllImplementors: implementorsCollection haveSame: anOldSelector. - self assertAllSenders: sendersCollection send: anOldSelector. - - ^ self new - initializedNamed: trimmedNewParameter - at: anIndex - addingLast: isAddingLast - initializedWith: aNewParameterValue - to: anOldSelector - implementing: aNewSelector - addingToImplementors: implementorTrailingString - addingToSenders: senderTrailingString - implementors: implementorsCollection - senders: sendersCollection -! ! -!AddParameter class methodsFor: 'instance creation - private' stamp: 'HAW 9/4/2018 21:32:44'! - newSelectorAdding: aNewKeyword at: anIndex to: anOldSelector - - | keywords | - - keywords := anOldSelector keywords asOrderedCollection. - keywords add: aNewKeyword beforeIndex: anIndex. - - ^Symbol fromCollectionOfStrings: keywords. - - ! ! -!AddParameter class methodsFor: 'instance creation - private' stamp: 'HAW 8/18/2018 12:14:00'! - newSelectorFromUnary: anOldSelector - - ^(anOldSelector, ':') asSymbol! ! -!AddParameter class methodsFor: 'instance creation - private' stamp: 'HAW 8/18/2018 12:15:49'! - unaryImplementorTrailingFor: aNewParameter - - ^ ': ', aNewParameter! ! -!AddParameter class methodsFor: 'instance creation - private' stamp: 'HAW 8/18/2018 12:16:32'! - unarySenderTrailingFor: aNewParameterValue - - ^ ': ', aNewParameterValue! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 8/25/2018 11:34:59'! - addParenthesisTo: trimmedNewParameterValue ifNewParameterValueIsKeywordMessage: newParameterValueMethodNode - - | newParameterNode | - - newParameterNode := newParameterValueMethodNode block statements first expr. - - ^ (self hasToAddParenthesisBasedOn: newParameterNode) - ifTrue: [ '(', trimmedNewParameterValue, ')' ] - ifFalse: [ trimmedNewParameterValue ] - ! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/4/2018 20:08:37'! - assert: anIndex isValidIndexFor: aNumberOfParameters - - (anIndex isInteger and: [ (anIndex between: 1 and: aNumberOfParameters + 1)]) ifFalse: [ self signalInvalidParameterIndex: anIndex for: aNumberOfParameters ]! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 8/18/2018 16:02:12'! - assertCanAddParameterTo: aSelector - - aSelector isInfix ifTrue: [ self signalSelectorCanNotBeBinary]! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 8/18/2018 12:29:54'! - assertIsKeyword: aSelector - - aSelector isKeyword ifFalse: [ self signalSelectorMustBeKeyword]! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 8/18/2018 12:23:04'! - assertIsUnary: aSelector - - aSelector isUnary ifFalse: [ self signalSelectorMustBeUnary]! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 8/18/2018 16:30:01'! - assertIsValidKeywordForNewParameter: aNewKeyword - - (aNewKeyword isKeyword and: [aNewKeyword numArgs = 1 ]) ifFalse: [ self signalNotValidKeywordForNewParameter]! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 8/17/2018 12:30:40'! - assertIsValidParameterName: aName - - | scannedNames | - - scannedNames _ Scanner new scanFieldNames: aName. - scannedNames size = 1 ifFalse: [ self signalInvalidParameterName: aName ]. - scannedNames first = aName ifFalse: [ self signalInvalidParameterName: aName ]. -! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 8/17/2018 16:59:29'! - assertNewParameter: aNewParameter isNotDefinedAsInstanceVariableInAny: implementors - - | classesDefiningInsVars | - - classesDefiningInsVars := self classesDefiningInstanceVariable: aNewParameter inAny: implementors. - classesDefiningInsVars notEmpty ifTrue: [ self signalNewParameter: aNewParameter definedAsInstanceVariableIn: classesDefiningInsVars ]! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 8/17/2018 16:59:47'! - assertNewParameter: aNewParameter isNotDefinedAsLocalInAny: implementors - - | implementorsDefiningNewParameterAsLocal | - - implementorsDefiningNewParameterAsLocal := implementors select: [ :implementor | implementor methodNode hasLocalNamed: aNewParameter ]. - implementorsDefiningNewParameterAsLocal notEmpty ifTrue: [ - self signalNewParameter: aNewParameter isDefinedAsLocalIn: implementorsDefiningNewParameterAsLocal ]! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 8/25/2018 11:30:18'! - assertNewParameterValueCompiles: trimmedNewParameterValue - - ^ [ Parser new parse: trimmedNewParameterValue readStream class: self noPattern: true notifying: nil ifFail: [nil] ] - on: SyntaxErrorNotification - do: [ :error | self signalNewParameterValueDoesNotCompile ].! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 8/25/2018 11:31:42'! - assertNewParameterValueDoesNotHaveMoreThanOneStatement: newParameterValueMethodNode - - newParameterValueMethodNode block statements size = 1 ifFalse: [ self signalNewParameterValueCanNotHaveMoreThanOneStatement ]. - ! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 8/17/2018 12:21:40'! - assertNewParameterValueIsNotEmpty: aNewParameterValue - - aNewParameterValue withBlanksTrimmed isEmpty ifTrue: [ self signalNewParameterValueCanNotBeEmpty]! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 8/25/2018 11:33:38'! - assertNewParameterValueIsValid: aNewParameterValue - - | newParameterValueMethodNode trimmedNewParameterValue | - - trimmedNewParameterValue := aNewParameterValue withBlanksTrimmed. - self assertNewParameterValueIsNotEmpty: trimmedNewParameterValue. - - newParameterValueMethodNode := self assertNewParameterValueCompiles: trimmedNewParameterValue. - self assertNewParameterValueDoesNotHaveMoreThanOneStatement: newParameterValueMethodNode. - - ^self addParenthesisTo: trimmedNewParameterValue ifNewParameterValueIsKeywordMessage: newParameterValueMethodNode. - ! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 8/25/2018 11:35:10'! - hasToAddParenthesisBasedOn: newParameterNode - - ^ newParameterNode isMessageNode and: [ newParameterNode selector key isKeyword ]! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/17/2018 15:05:29'! - classesDefiningInstanceVariable: aName inAny: implementors - - ^ implementors - inject: Set new - into: [ :classesDefiningInstVar :implementor | - (implementor methodClass whichClassDefinesInstanceVariable: aName ifNone: [ nil ]) ifNotNil: [ :classDefiningInstVar | - classesDefiningInstVar add: classDefiningInstVar ]. - classesDefiningInstVar ] -! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 9/4/2018 20:03:25'! - errorMessageForInvalidParameterIndex: anIndex for: aNumberOfParameters - - ^anIndex printString, ' is an invalid insertion index. It has to be between 1 and ', (aNumberOfParameters + 1) printString! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/17/2018 12:31:35'! - errorMessageForInvalidParameterName: aName - - ^ '''' , aName , ''' is not a valid parameter name'.! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/17/2018 15:18:46'! - errorMessageForNewParameter: aNewParameter definedAsInstanceVariableIn: definingClasses - - ^ String streamContents: [ :messageStream | - messageStream - nextPutAll: definingClasses asCommaStringAnd; - space; - nextPutAll: (definingClasses size = 1 ifTrue: [ 'defines' ] ifFalse: [ 'define' ]); - space; - nextPutAll: aNewParameter; - nextPutAll: ' as instance variable' ]! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 9/2/2018 19:59:27'! - errorMessageForNewParameterDefinedAsLocal: aNewParameter - - ^ aNewParameter, ' is already defined as parameter or temporary'! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/17/2018 12:22:31'! - newParameterValueCanNotBeEmptyErrorMessage - - ^'New parameter value can not be empty'! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/25/2018 11:26:54'! - newParameterValueCanNotHaveMoreThanOneStatementErrorMessage - - ^'New parameter value can not have more than one statement'! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/17/2018 12:24:53'! - newParameterValueDoesNotCompileErrorMessage - - ^'New parameter value code does not compile'! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/18/2018 16:31:03'! - notValidKeywordForNewParameterErrorMessage - - ^'New keyword must be of keyword type with one parameter'! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 12/13/2018 17:46:33'! - selectorCanNotBeBinaryErrorMessage - - ^'Can not add parameter to a binary selector. -Rename it to a keyword message first.'! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/18/2018 12:26:46'! - selectorMustBeKeywordErrorMessage - - ^'Selector must be of keyword type'! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/18/2018 12:23:47'! - selectorMustBeUnaryErrorMessage - - ^'Selector must be unary'! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 9/4/2018 20:02:24'! - signalInvalidParameterIndex: anIndex for: aNumberOfParameters - - self refactoringError: (self errorMessageForInvalidParameterIndex: anIndex for: aNumberOfParameters)! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/17/2018 12:31:15'! - signalInvalidParameterName: aName - - self refactoringError: (self errorMessageForInvalidParameterName: aName) - -! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/17/2018 15:11:03'! -signalNewParameter: aNewParameter definedAsInstanceVariableIn: definingClasses - - self refactoringError: (self errorMessageForNewParameter: aNewParameter definedAsInstanceVariableIn: definingClasses)! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 9/2/2018 19:59:27'! - signalNewParameter: aNewParameter isDefinedAsLocalIn: implementors - - self - canNotRefactorDueToReferencesError: (self errorMessageForNewParameterDefinedAsLocal: aNewParameter) - references: (implementors collect: [ :implementor | MethodReference method: implementor ]) - to: aNewParameter - ! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/17/2018 12:22:07'! - signalNewParameterValueCanNotBeEmpty - - self refactoringError: self newParameterValueCanNotBeEmptyErrorMessage! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/25/2018 11:27:05'! -signalNewParameterValueCanNotHaveMoreThanOneStatement - - self refactoringError: self newParameterValueCanNotHaveMoreThanOneStatementErrorMessage! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/17/2018 12:24:53'! - signalNewParameterValueDoesNotCompile - - self refactoringError: self newParameterValueDoesNotCompileErrorMessage! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/18/2018 16:25:55'! - signalNotValidKeywordForNewParameter - - self refactoringError: self notValidKeywordForNewParameterErrorMessage! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/18/2018 12:35:05'! -signalSelectorCanNotBeBinary - - self refactoringError: self selectorCanNotBeBinaryErrorMessage! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/18/2018 12:29:54'! - signalSelectorMustBeKeyword - - self refactoringError: self selectorMustBeKeywordErrorMessage! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 8/18/2018 12:23:26'! - signalSelectorMustBeUnary - - self refactoringError: self selectorMustBeUnaryErrorMessage! ! -!RemoveParameter methodsFor: 'initialization' stamp: 'HAW 9/4/2018 14:31:23'! - initializeNamed: aParameterToRemove - ofKeywordAtIndex: aParameterIndex - from: anOldSelector - creating: aNewSelector - implementors: implementorsCollection - senders: sendersCollection - - super initializeFrom: anOldSelector to: aNewSelector implementors: implementorsCollection senders: sendersCollection. - - parameterToRemove := aParameterToRemove. - parameterIndex := aParameterIndex. - senderReplacementString := newSelector isUnary ifTrue: [ newSelector asString ] ifFalse: [ '' ]. - isLastParameter := oldSelector numArgs = parameterIndex - ! ! -!RemoveParameter methodsFor: 'create new implementors - private' stamp: 'HAW 9/4/2018 14:42:51'! - implementorNewSourceCodeOf: anImplementor - - | implementorMethodNode newSource originalSource parameterToRemovePosition selectorToRemovePosition | - - implementorMethodNode := anImplementor methodNode. - selectorToRemovePosition := implementorMethodNode selectorKeywordPositionAt: parameterIndex. - parameterToRemovePosition := implementorMethodNode parameterDefinitionPositionAt: parameterIndex. - - originalSource := anImplementor sourceCode. - newSource := String streamContents: [ :newSourceStream | - self writeBeforeKeywordIn: newSourceStream from: originalSource removing: selectorToRemovePosition. - self writeAfterParameterIn: newSourceStream from: originalSource removing: parameterToRemovePosition ]. - - ^newSource! ! -!RemoveParameter methodsFor: 'create new implementors - private' stamp: 'HAW 9/4/2018 14:42:51'! - writeAfterParameterIn: newSourceStream from: originalSource removing: parameterToRemovePosition - - | afterParameterPosition | - - afterParameterPosition := parameterToRemovePosition last. - isLastParameter ifFalse: [ afterParameterPosition := self lastSeparatorIndexIn: originalSource startingFrom: afterParameterPosition ]. - - newSourceStream nextPutAll: (originalSource copyFrom: afterParameterPosition + 1 to: originalSource size) ! ! -!RemoveParameter methodsFor: 'create new implementors - private' stamp: 'HAW 9/4/2018 14:35:27'! - writeBeforeKeywordIn: newSourceStream from: originalSource removing: selectorToRemovePosition - - newSelector isUnary - ifTrue: [ newSourceStream nextPutAll: newSelector ] - ifFalse: [ newSourceStream nextPutAll: (originalSource copyFrom: 1 to: selectorToRemovePosition first - 1) ]. -! ! -!RemoveParameter methodsFor: 'rename senders - private' stamp: 'HAW 9/4/2018 17:42:53'! - addMessageSendSelectorKeywordRangesOf: aMethodNode to: rangesToKeywords - - | keywordAndParameterPositions senderSourceCode | - - senderSourceCode := aMethodNode sourceText. - keywordAndParameterPositions := aMethodNode messageSendKeywordAndParameterPositionsAt: parameterIndex of: oldSelector ifAbsent: [ #() ]. - keywordAndParameterPositions do: [ :aKeywordAndParameterPosition | | lastPosition | - lastPosition := self lastSeparatorIndexIn: senderSourceCode startingFrom: aKeywordAndParameterPosition last. - rangesToKeywords add: (aKeywordAndParameterPosition first to: lastPosition) -> senderReplacementString ] - ! ! -!RemoveParameter methodsFor: 'rename senders - private' stamp: 'HAW 9/4/2018 12:10:34'! - lastSeparatorIndexIn: senderSourceCode startingFrom: aPosition - - | lastPosition senderSourceCodeSize | - - lastPosition := aPosition. - senderSourceCodeSize := senderSourceCode size. - [ lastPosition := lastPosition + 1. - lastPosition <= senderSourceCodeSize and: [ (senderSourceCode at: lastPosition) isSeparator ]] whileTrue. - - ^lastPosition - 1! ! -!RemoveParameter class methodsFor: 'instance creation' stamp: 'HAW 9/4/2018 15:17:51'! - named: aParameterToRemove from: aMethod implementors: implementorsCollection senders: sendersCollection - - | oldSelector methodNode parameterIndex newSelector | - - oldSelector := aMethod selector. - self assertCanRemoveParameterFrom: oldSelector. - - methodNode := aMethod methodNode. - parameterIndex := self assert: aParameterToRemove isDefinedIn: methodNode. - self assertAllImplementors: implementorsCollection haveSame: oldSelector. - self assertAllSenders: sendersCollection send: oldSelector. - self assertNoImplementorFrom: implementorsCollection reference: aParameterToRemove definedAt: parameterIndex. - - newSelector := self newSelectorFrom: oldSelector removingParameterAt: parameterIndex. - - ^self new - initializeNamed: aParameterToRemove - ofKeywordAtIndex: parameterIndex - from: oldSelector - creating: newSelector - implementors: implementorsCollection - senders: sendersCollection -! ! -!RemoveParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/2/2018 20:07:30'! - assert: aParamerterToRemove isDefinedIn: methodNode - - | parameterIndex | - - parameterIndex := methodNode arguments findFirst: [ :aParameterNode | aParameterNode name = aParamerterToRemove ]. - parameterIndex = 0 ifTrue: [ self signalParameterNotInMessage: aParamerterToRemove ]. - - ^parameterIndex - ! ! -!RemoveParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/4/2018 15:18:13'! - assertCanRemoveParameterFrom: oldSelector - - self assertIsNotUnary: oldSelector. - self assertIsNotBinary: oldSelector.! ! -!RemoveParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/1/2018 12:34:26'! - assertIsNotBinary: aSelector - - aSelector isInfix ifTrue: [ self signalCanNotRemoveParameterFromBinaryMessages]! ! -!RemoveParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/1/2018 12:37:00'! - assertIsNotUnary: aSelector - - aSelector isUnary ifTrue: [ self signalCanNotRemoveParameterFromUnaryMessages]! ! -!RemoveParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/4/2018 15:41:24'! - assertNoImplementorFrom: implementorsCollection reference: aParamerterToRemove definedAt: parameterIndex - - | implementorsReferencingParameter | - - implementorsReferencingParameter := implementorsCollection select: [:anImplementor | anImplementor referencesParameterAt: parameterIndex ]. - - implementorsReferencingParameter isEmpty ifFalse: [ self signalCanNotRemove: aParamerterToRemove dueToReferencesIn: implementorsReferencingParameter ].! ! -!RemoveParameter class methodsFor: 'exceptions' stamp: 'HAW 1/7/2019 15:31:35'! - canNotRemoveParameterFromBinaryMessagesErrorMessage - - ^'Can not remove parameter from binary messages. -Rename message to a keyword one first'! ! -!RemoveParameter class methodsFor: 'exceptions' stamp: 'HAW 9/1/2018 12:36:43'! - canNotRemoveParameterFromUnaryMessagesErrorMessage - - ^'There is no parameter to remove in unary messages'! ! -!RemoveParameter class methodsFor: 'exceptions' stamp: 'HAW 9/2/2018 19:40:52'! - errorMessageForParameterNotInMessage: aParameterToRemove - - ^aParameterToRemove, ' is not define as parameter'! ! -!RemoveParameter class methodsFor: 'exceptions' stamp: 'HAW 9/3/2018 16:27:21'! - errorMessageForParameterToRemoveIsReferenced: aParameterToRemove - - ^aParameterToRemove, ' is being referenced in implementors'! ! -!RemoveParameter class methodsFor: 'exceptions' stamp: 'HAW 9/2/2018 20:21:43'! - signalCanNotRemove: aParameterToRemove dueToReferencesIn: implementorsReferencingParameterToRemove - - self - canNotRefactorDueToReferencesError: (self errorMessageForParameterToRemoveIsReferenced: aParameterToRemove) - references: (implementorsReferencingParameterToRemove collect: [ :implementor | MethodReference method: implementor ]) - to: aParameterToRemove - ! ! -!RemoveParameter class methodsFor: 'exceptions' stamp: 'HAW 9/1/2018 12:34:45'! - signalCanNotRemoveParameterFromBinaryMessages - - self refactoringError: self canNotRemoveParameterFromBinaryMessagesErrorMessage! ! -!RemoveParameter class methodsFor: 'exceptions' stamp: 'HAW 9/1/2018 12:37:00'! - signalCanNotRemoveParameterFromUnaryMessages - - self refactoringError: self canNotRemoveParameterFromUnaryMessagesErrorMessage! ! -!RemoveParameter class methodsFor: 'exceptions' stamp: 'HAW 9/2/2018 19:40:22'! - signalParameterNotInMessage: aParameterToRemove - - self refactoringError: (self errorMessageForParameterNotInMessage: aParameterToRemove)! ! -!RemoveParameter class methodsFor: 'instance creation - private' stamp: 'HAW 9/4/2018 21:22:36'! - newSelectorConcatenating: oldSelectorKeywords removingAt: anIndex - - | keywords | - - keywords := oldSelectorKeywords asOrderedCollection. - keywords removeIndex: anIndex. - - ^Symbol fromCollectionOfStrings: keywords.! ! -!RemoveParameter class methodsFor: 'instance creation - private' stamp: 'HAW 9/4/2018 21:30:47'! - newSelectorFrom: oldSelector removingParameterAt: parameterIndex - - | oldSelectorKeywords newSelector | - - oldSelectorKeywords := oldSelector keywords. - - newSelector := oldSelectorKeywords size = 1 - ifTrue: [ oldSelector allButLast asSymbol ] - ifFalse: [ self newSelectorConcatenating: oldSelectorKeywords removingAt: parameterIndex ]. - - ^newSelector! ! -!RenameSelector methodsFor: 'create new implementors - private' stamp: 'HAW 9/3/2018 19:49:44'! - implementorNewSourceCodeOf: anImplementor - - | newSource rangesToNewKeywords | - - rangesToNewKeywords := OrderedCollection new. - anImplementor methodNode selectorKeywordsPositions withIndexDo: [ :aKeywordRange :index | - rangesToNewKeywords add: aKeywordRange -> (newSelectorKeywords at: index) ]. - - newSource := anImplementor sourceCode copyReplacing: rangesToNewKeywords. - ^newSource! ! -!RenameSelector methodsFor: 'rename senders - private' stamp: 'HAW 9/3/2018 19:47:38'! -addMessageSendSelectorKeywordRangesOf: aMethodNode to: rangesToKeywords - - | oldSelectorKeywordsRanges | - - oldSelectorKeywordsRanges := aMethodNode messageSendSelectorKeywordPositionsOf: oldSelector ifAbsent: [ #() ]. - oldSelectorKeywordsRanges do: [ :aMessageSendSelectorRanges | - aMessageSendSelectorRanges withIndexDo: [ :aRange :index | rangesToKeywords add: aRange -> (newSelectorKeywords at: index) ]]. - ! ! -!RenameSelector methodsFor: 'initialization' stamp: 'HAW 9/3/2018 17:14:47'! - initializeFrom: anOldSelector to: aNewSelector implementors: aCollectionOfImplementors senders: aCollectionOfSenders - - super initializeFrom: anOldSelector to: aNewSelector implementors: aCollectionOfImplementors senders: aCollectionOfSenders. - - newSelectorKeywords := newSelector keywords. - ! ! -!RenameSelector class methodsFor: 'pre-conditions' stamp: 'HAW 5/25/2017 20:02:05'! - assert: aNewSelector hasTheSameNumberOfArgumentsAs: anOldSelector - - aNewSelector numArgs ~= anOldSelector numArgs ifTrue: [ self signalNewSelector: aNewSelector doesNotHaveSameNumberOfArgumentsAs: anOldSelector ]! ! -!RenameSelector class methodsFor: 'pre-conditions' stamp: 'HAW 5/26/2017 00:41:25'! - assert: aNewSelector isNotEqualTo: anOldSelector - - aNewSelector = anOldSelector ifTrue: [ self signalNewSelectorEqualToOldSelector]! ! -!RenameSelector class methodsFor: 'pre-conditions' stamp: 'HAW 12/13/2018 18:53:51'! - assert: aNewSelector isOfSameTypeAs: anOldSelector - - (self isRenamigBetweenBinary: anOldSelector andKeywordOfOneParameter: aNewSelector) ifTrue: [ ^self ]. - (self isRenamigBetweenBinary: aNewSelector andKeywordOfOneParameter: anOldSelector) ifTrue: [ ^self ]. - - aNewSelector precedence ~= anOldSelector precedence ifTrue: [ - self signalNewSelector: aNewSelector isNotOfSameTypeAs: anOldSelector ]! ! -!RenameSelector class methodsFor: 'pre-conditions' stamp: 'HAW 6/3/2017 11:54:48'! - assertIsNotEmpty: aCollection signalMessageText: errorMessageText - - aCollection isEmpty ifTrue: [ self refactoringError: errorMessageText ].! ! -!RenameSelector class methodsFor: 'pre-conditions' stamp: 'HAW 5/26/2017 00:44:37'! - assertIsValidToRenameFrom: anOldSelector to: aNewSelector - - self assertIsNotEmpty: anOldSelector signalMessageText: self oldSelectorCanNotBeEmptyErrorMessage. - self assertIsNotEmpty: aNewSelector signalMessageText: self newSelectorCanNotBeEmptyErrorMessage. - self assert: aNewSelector isNotEqualTo: anOldSelector. - self assert: aNewSelector isOfSameTypeAs: anOldSelector. - self assert: aNewSelector hasTheSameNumberOfArgumentsAs: anOldSelector. - ! ! -!RenameSelector class methodsFor: 'pre-conditions' stamp: 'HAW 5/31/2017 19:38:12'! - assertNoImplementorClassIn: implementorsCollection implements: aNewSelector - - | classesImplementingNewSelector | - - classesImplementingNewSelector := implementorsCollection - select: [ :anImplementor | anImplementor methodClass includesSelector: aNewSelector ] - thenCollect: [ :anImplementor | anImplementor methodClass ]. - - classesImplementingNewSelector notEmpty ifTrue: [ self signalNewSelector: aNewSelector implementedInAll: classesImplementingNewSelector ]! ! -!RenameSelector class methodsFor: 'pre-conditions' stamp: 'HAW 12/13/2018 18:52:19'! - isRenamigBetweenBinary: aPotentiallyBinarySelector andKeywordOfOneParameter: aPotentiallyKeywordSelector - - ^aPotentiallyBinarySelector isInfix - and: [ aPotentiallyKeywordSelector isKeyword - and: [ aPotentiallyKeywordSelector numArgs = 1 ]] -! ! -!RenameSelector class methodsFor: 'pre-conditions' stamp: 'HAW 5/31/2017 20:56:22'! - warnIfImplementionsOf: aNewSelector overridesImplementationInSuperclassesOf: implementorsCollection - - implementorsCollection do: [:anImplementor | - anImplementor methodClass - withSuperclassThatIncludesSelector: aNewSelector - do: [ :aSuperclass | self warnImplementionOf: aNewSelector in: anImplementor methodClass willOverrideImplementationIn: aSuperclass ] - ifNone: []]! ! -!RenameSelector class methodsFor: 'exceptions' stamp: 'HAW 5/25/2017 19:59:44'! - errorMessageForNewSelector: aNewSelector doesNotHaveSameNumberOfArgumentsAs: anOldSelector - - ^'New selector #', aNewSelector, ' does not have the same number of arguments as #', anOldSelector ! ! -!RenameSelector class methodsFor: 'exceptions' stamp: 'HAW 5/31/2017 19:41:36'! - errorMessageForNewSelector: aNewSelector implementedInAll: classesImplementingNewSelector - - ^'Can not rename because #', aNewSelector, ' is implemented in: ', classesImplementingNewSelector asCommaStringAnd ! ! -!RenameSelector class methodsFor: 'exceptions' stamp: 'HAW 5/25/2017 19:54:05'! - errorMessageForNewSelector: aNewSelector isNotOfSameTypeAs: anOldSelector - - ^'New selector #', aNewSelector, ' is not of same type as #', anOldSelector ! ! -!RenameSelector class methodsFor: 'exceptions' stamp: 'HAW 5/25/2017 18:51:46'! - implementorsCanNotBeEmptyErrorMessage - - ^'There are no methods to rename'! ! -!RenameSelector class methodsFor: 'exceptions' stamp: 'HAW 5/25/2017 18:49:15'! - newSelectorCanNotBeEmptyErrorMessage - - ^'New selector can not be empty'! ! -!RenameSelector class methodsFor: 'exceptions' stamp: 'HAW 5/26/2017 00:40:01'! - newSelectorEqualToOldSelectorErrorMessage - - ^'There is nothing to rename when new selector is equals to old selector'! ! -!RenameSelector class methodsFor: 'exceptions' stamp: 'HAW 5/25/2017 18:49:07'! - oldSelectorCanNotBeEmptyErrorMessage - - ^'Old selector can not be empty'! ! -!RenameSelector class methodsFor: 'exceptions' stamp: 'HAW 6/3/2017 11:55:23'! - signalNewSelector: aNewSelector doesNotHaveSameNumberOfArgumentsAs: anOldSelector - - self refactoringError: (self errorMessageForNewSelector: aNewSelector doesNotHaveSameNumberOfArgumentsAs: anOldSelector).! ! -!RenameSelector class methodsFor: 'exceptions' stamp: 'HAW 6/3/2017 11:55:38'! - signalNewSelector: aNewSelector implementedInAll: classesImplementingNewSelector - - self refactoringError: (self errorMessageForNewSelector: aNewSelector implementedInAll: classesImplementingNewSelector).! ! -!RenameSelector class methodsFor: 'exceptions' stamp: 'HAW 6/3/2017 11:55:54'! - signalNewSelector: aNewSelector isNotOfSameTypeAs: anOldSelector - - self refactoringError: (self errorMessageForNewSelector: aNewSelector isNotOfSameTypeAs: anOldSelector).! ! -!RenameSelector class methodsFor: 'exceptions' stamp: 'HAW 6/3/2017 11:55:58'! - signalNewSelectorEqualToOldSelector - - self refactoringError: self newSelectorEqualToOldSelectorErrorMessage.! ! -!RenameSelector class methodsFor: 'instance creation' stamp: 'HAW 5/31/2017 19:58:50'! - from: anOldSelector to: aNewSelector implementors: aCollectionOfImplementors senders: aCollectionOfSenders - - self assertIsValidToRenameFrom: anOldSelector to: aNewSelector. - self assertIsNotEmpty: aCollectionOfImplementors signalMessageText: self implementorsCanNotBeEmptyErrorMessage. - self assertAllImplementors: aCollectionOfImplementors haveSame: anOldSelector. - self assertNoImplementorClassIn: aCollectionOfImplementors implements: aNewSelector. - self assertAllSenders: aCollectionOfSenders send: anOldSelector. - - self warnIfImplementionsOf: aNewSelector overridesImplementationInSuperclassesOf: aCollectionOfImplementors. - - ^self new initializeFrom: anOldSelector to: aNewSelector implementors: aCollectionOfImplementors senders: aCollectionOfSenders - ! ! -!RenameSelector class methodsFor: 'instance creation' stamp: 'HAW 5/26/2017 00:04:36'! - from: anOldSelector to: aNewSelector in: aClassToRefactor - - | implementors senders | - - implementors := OrderedCollection new. - senders := OrderedCollection new. - - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders forClassAndMetaOf: aClassToRefactor theNonMetaClass. - - ^self from: anOldSelector to: aNewSelector implementors: implementors senders: senders ! ! -!RenameSelector class methodsFor: 'instance creation' stamp: 'HAW 5/30/2017 17:45:16'! - from: anOldSelector to: aNewSelector inCategoriesAndHierarchyOf: aClass organizedBy: anOrganization - - | implementors senders | - - implementors := IdentitySet new. - senders := IdentitySet new. - - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategoriesAndHierarchyOf: aClass organizedBy: anOrganization. - - ^self from: anOldSelector to: aNewSelector implementors: implementors senders: senders -! ! -!RenameSelector class methodsFor: 'instance creation' stamp: 'HAW 5/25/2017 23:59:19'! - from: anOldSelector to: aNewSelector inCategoryOf: aClass organizedBy: anOrganization - - | implementors senders | - - implementors := OrderedCollection new. - senders := OrderedCollection new. - - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategory: aClass category organizedBy: anOrganization. - - ^self from: anOldSelector to: aNewSelector implementors: implementors senders: senders -! ! -!RenameSelector class methodsFor: 'instance creation' stamp: 'HAW 5/25/2017 23:53:57'! - from: anOldSelector to: aNewSelector inHierarchyOf: aClass - - | implementors senders | - - implementors := OrderedCollection new. - senders := OrderedCollection new. - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inHierarchyOf: aClass. - - ^self from: anOldSelector to: aNewSelector implementors: implementors senders: senders - - ! ! -!RenameSelector class methodsFor: 'instance creation' stamp: 'HAW 5/30/2017 17:47:27'! - from: anOldSelector to: aNewSelector inSystem: aSystem - - | implementors senders | - - implementors := OrderedCollection new. - senders := OrderedCollection new. - - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inSystem: aSystem. - - ^self from: anOldSelector to: aNewSelector implementors: implementors senders: senders - ! ! -!RenameSelector class methodsFor: 'warnings' stamp: 'HAW 6/3/2017 12:01:34'! - warnImplementionOf: aNewSelector in: aClass willOverrideImplementationIn: aSuperclass - - self refactoringWarning: (self warningMessageForImplementationOf: aNewSelector in: aClass willOverrideImplementationIn: aSuperclass).! ! -!RenameSelector class methodsFor: 'warnings' stamp: 'HAW 8/1/2018 18:15:01'! - warningMessageForImplementationOf: aNewSelector in: aClass willOverrideImplementationIn: aSuperclass - - ^'Implemention of #', aNewSelector, ' in ', aClass name, ' will override implementation in ', aSuperclass name! ! -!ExtractToTemporary methodsFor: 'applying' stamp: 'HAW 10/18/2017 18:39:22'! - apply - - | temporaries finder rewriter | - - newTemporary := methodNodeToRefactor encoder bindTemp: newVariable. - temporaries := methodNodeToRefactor temporaries asOrderedCollection. - temporaries add: newTemporary. - - methodNodeToRefactor temporaries: temporaries. - finder := ParseNodeToReplaceFinder of: self. - methodNodeToRefactor accept: finder. - rewriter := ExtractToTemporaryRewriter of: self on: finder. - methodNodeToRefactor accept: rewriter. - finder blockContainingFirstNodeToReplace statements - add: (AssignmentNode new variable: newTemporary value: parseNodeToExtract) - beforeIndex: finder firstNodeToReplaceIndex. - - ^methodNodeToRefactor ! ! -!ExtractToTemporary methodsFor: 'initialization' stamp: 'HAW 10/4/2017 17:43:11'! - initializeNamed: aNewVariable with: aParseNodeToExtract in: aMethodNodeToRefactor - - newVariable := aNewVariable. - parseNodeToExtract := aParseNodeToExtract. - methodNodeToRefactor := aMethodNodeToRefactor ! ! -!ExtractToTemporary methodsFor: 'accessing' stamp: 'HAW 10/4/2017 18:45:19'! - newTemporary - - ^newTemporary ! ! -!ExtractToTemporary methodsFor: 'accessing' stamp: 'HAW 10/4/2017 18:38:13'! - parseNodeToExtract - - ^parseNodeToExtract! ! -!ExtractToTemporary methodsFor: 'testing' stamp: 'HAW 10/18/2017 18:08:31'! - shouldExtract: aParseNode - - ^parseNodeToExtract = aParseNode ! ! -!ExtractToTemporary methodsFor: 'as yet unclassified' stamp: 'HAW 9/11/2018 15:52:26'! - research - -" -TextEditor>>selectionInterval -hasSelection -selection -"! ! -!ExtractToTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 6/30/2017 06:25:21'! - assert: aSourceCodeToExtract isIncludedIn: aMethodNodeToRefactor - - (aMethodNodeToRefactor sourceText includesSubString: aSourceCodeToExtract) ifFalse: [ - self signalMethodNodeToRefactorDoesNotInclude: aSourceCodeToExtract ] - -! ! -!ExtractToTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 6/26/2017 16:30:52'! -assert: aNewVariable isNotDefinedIn: aMethodNode - - (aMethodNode tempNames includes: aNewVariable) ifTrue: [ self signalNewTemporaryVariable: aNewVariable isAlreadyDefinedIn: aMethodNode ] - ! ! -!ExtractToTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 6/26/2017 16:23:25'! - assertIsNotEmpty: aNewVariable - - aNewVariable isEmpty ifTrue: [ self signalNewVariableCanNotBeEmpty ]! ! -!ExtractToTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 3/6/2018 16:01:34'! -assertIsNotReturn: aSourceCodeToExtract - - "I have to use the source code to check this because parsing it returns the same methodNode for - 1 and ^1, that is, using methodNode does not help to distigished if there was or not a return - Hernan" - - aSourceCodeToExtract withBlanksTrimmed first = $^ ifTrue: [ self signalSourceCodeToExtractCanNotIncludeReturn ]! ! -!ExtractToTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 6/27/2017 17:52:29'! - assertIsOneStatement: aMethodNodeToExtract - - aMethodNodeToExtract block statements size ~= 1 ifTrue: [ self signalColaborationToExtractHasToBeOneStatement]! ! -!ExtractToTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 6/26/2017 16:27:32'! - assertIsValidVariableName: aName - - | scannedNames | - - scannedNames _ Scanner new scanFieldNames: aName. - scannedNames size = 1 ifFalse: [ self signalInvalidTemporaryVariable: aName ]. - scannedNames first = aName ifFalse: [ self signalInvalidTemporaryVariable: aName ].! ! -!ExtractToTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 6/30/2017 06:21:22'! - assertSourceCodeIsNotEmpty: aSourceCodeToExtract - - aSourceCodeToExtract isEmpty ifTrue: [ self signalSourceCodeToExtractCanNotBeEmpty]! ! -!ExtractToTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 6/26/2017 16:33:25'! - warnIf: aNewVariable isDefinedAsInstanceVariableInHierarchyOf: aClass - - | classDefiningNewVariable | - - classDefiningNewVariable := aClass whichClassDefinesInstanceVariable: aNewVariable ifNone: [ ^self ]. - self warn: aNewVariable willHideInstanceVariableDefinedIn: classDefiningNewVariable ! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/26/2017 16:28:07'! - errorMessageForInvalidTemporaryVariable: aName - - ^ '''' , aName , ''' is not a valid temporary variable name'.! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/26/2017 16:31:23'! - errorMessageForNewTemporaryVariable: aNewVariable isAlreadyDefinedIn: aMethodNode - - ^aNewVariable, ' is already defined in ', aMethodNode classAndSelector ! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/30/2017 06:34:01'! - errorMessageForSourceCodeToExtractHasSyntaxError: anErrorDescription - - ^'Can not extract a source code with syntax error: ', anErrorDescription ! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/30/2017 06:26:23'! - errorMessageMethodNodeToRefactorDoesNotInclude: aSourceCodeToExtract - - ^'The source code {', aSourceCodeToExtract, '} is not included in the method to refactor'! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/26/2017 16:24:10'! - newVariableCanNotBeEmptyErrorMessage - - ^'New variable can not be empty'! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/30/2017 06:34:15'! -signalColaborationToExtractHasSyntaxError: aSyntaxErrorNotification - - self refactoringError: (self errorMessageForSourceCodeToExtractHasSyntaxError: aSyntaxErrorNotification messageText)! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/30/2017 06:32:50'! - signalColaborationToExtractHasToBeOneStatement - - self refactoringError: self sourceCodeToExtractHasToBeOneStatementErrorMessage ! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/26/2017 16:27:51'! - signalInvalidTemporaryVariable: aName - - ^ self refactoringError: (self errorMessageForInvalidTemporaryVariable: aName).! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/27/2017 17:23:04'! - signalMethodNodeToRefactorDoesNotInclude: aColaborationToExtract - - ^self refactoringError: (self errorMessageMethodNodeToRefactorDoesNotInclude: aColaborationToExtract)! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/26/2017 16:31:08'! -signalNewTemporaryVariable: aNewVariable isAlreadyDefinedIn: aMethodNode - - self refactoringError: (self errorMessageForNewTemporaryVariable: aNewVariable isAlreadyDefinedIn: aMethodNode )! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/26/2017 16:23:49'! - signalNewVariableCanNotBeEmpty - - self refactoringError: self newVariableCanNotBeEmptyErrorMessage! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/30/2017 06:20:49'! - signalSourceCodeToExtractCanNotBeEmpty - - self refactoringError: self sourceCodeToExtractCanNotBeEmptyErrorMessage! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/30/2017 06:24:37'! - signalSourceCodeToExtractCanNotIncludeReturn - - self refactoringError: self sourceCodeToExtractCanNotIncludeReturnErrorMessage ! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/30/2017 06:20:21'! - sourceCodeToExtractCanNotBeEmptyErrorMessage - - ^'Source code to extract can not be empty'! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/30/2017 06:24:02'! - sourceCodeToExtractCanNotIncludeReturnErrorMessage - - ^'A return can not be extracted'! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/30/2017 06:32:22'! - sourceCodeToExtractHasToBeOneStatementErrorMessage - - ^'Can not extract more than one statement'! ! -!ExtractToTemporary class methodsFor: 'instance creation' stamp: 'HAW 9/11/2018 16:13:23'! - named: aNewVariable at: anIntervalToExtract from: aMethodSourceCode in: aClass - - | trimmedNewVariable parseNodeToExtract trimmedSourceCodeToExtract methodNodeToExtract methodNodeToRefactor sourceCodeToExtract | - - trimmedNewVariable := aNewVariable withBlanksTrimmed. - methodNodeToRefactor := aClass methodNodeFor: aMethodSourceCode. - - self assertIsNotEmpty: trimmedNewVariable. - self assertIsValidVariableName: trimmedNewVariable. - self assert: trimmedNewVariable isNotDefinedIn: methodNodeToRefactor. - - sourceCodeToExtract := aMethodSourceCode copyFrom: anIntervalToExtract first to: anIntervalToExtract last. - trimmedSourceCodeToExtract := sourceCodeToExtract withBlanksTrimmed. - self assertSourceCodeIsNotEmpty: trimmedSourceCodeToExtract. - self assertIsNotReturn: trimmedSourceCodeToExtract. - self assert: trimmedSourceCodeToExtract isIncludedIn: methodNodeToRefactor. - - [ methodNodeToExtract := Parser parse: trimmedSourceCodeToExtract class: methodNodeToRefactor methodClass noPattern: true ] - on: SyntaxErrorNotification - do: [ :anError | self signalColaborationToExtractHasSyntaxError: anError ]. - - parseNodeToExtract := self paseNodeToExtractFrom: methodNodeToExtract. - - self warnIf: trimmedNewVariable isDefinedAsInstanceVariableInHierarchyOf: methodNodeToRefactor methodClass. - - ^self new initializeNamed: trimmedNewVariable with: parseNodeToExtract in: methodNodeToRefactor - - ! ! -!ExtractToTemporary class methodsFor: 'instance creation' stamp: 'HAW 10/4/2017 17:41:59'! - named: aNewVariable with: aSourceCodeToExtract in: aMethodNodeToRefactor - - | trimmedNewVariable parseNodeToExtract trimmedSourceCodeToExtract methodNodeToExtract | - - trimmedNewVariable := aNewVariable withBlanksTrimmed. - - self assertIsNotEmpty: trimmedNewVariable. - self assertIsValidVariableName: trimmedNewVariable. - self assert: trimmedNewVariable isNotDefinedIn: aMethodNodeToRefactor. - - trimmedSourceCodeToExtract := aSourceCodeToExtract withBlanksTrimmed. - self assertSourceCodeIsNotEmpty: trimmedSourceCodeToExtract. - self assertIsNotReturn: trimmedSourceCodeToExtract. - self assert: trimmedSourceCodeToExtract isIncludedIn: aMethodNodeToRefactor. - - [ methodNodeToExtract := Parser parse: trimmedSourceCodeToExtract class: aMethodNodeToRefactor methodClass noPattern: true ] - on: SyntaxErrorNotification - do: [ :anError | self signalColaborationToExtractHasSyntaxError: anError ]. - - parseNodeToExtract := self paseNodeToExtractFrom: methodNodeToExtract. - - self warnIf: trimmedNewVariable isDefinedAsInstanceVariableInHierarchyOf: aMethodNodeToRefactor methodClass. - - ^self new initializeNamed: trimmedNewVariable with: parseNodeToExtract in: aMethodNodeToRefactor - - ! ! -!ExtractToTemporary class methodsFor: 'method node to extract' stamp: 'HAW 6/27/2017 17:58:04'! - paseNodeToExtractFrom: aMethodNodeToExtract - - self assertIsOneStatement: aMethodNodeToExtract. - - ^aMethodNodeToExtract block statements first expr. - ! ! -!ExtractToTemporary class methodsFor: 'warnings' stamp: 'HAW 6/26/2017 16:34:44'! - warn: aNewVariable willHideInstanceVariableDefinedIn: aClass - - self refactoringWarning: (self warningMessageFor: aNewVariable willHideInstanceVariableDefinedIn: aClass)! ! -!ExtractToTemporary class methodsFor: 'warnings' stamp: 'HAW 6/26/2017 16:35:04'! - warningMessageFor: aNewVariable willHideInstanceVariableDefinedIn: aClass - - ^aNewVariable, ' will hide instance variable defined in ', aClass name! ! -!InsertSuperclass methodsFor: 'applying' stamp: 'HAW 8/13/2018 18:31:33'! -apply - - | newSuperclass | - - newSuperclass := self createSuperclass. - self changeSuperclassOf: classToRefactor to: newSuperclass. - - ^newSuperclass ! ! -!InsertSuperclass methodsFor: 'applying - private' stamp: 'HAW 8/13/2018 18:31:43'! - changeSuperclassOf: classToRefactor to: newSuperclass - - newSuperclass subclass: classToRefactor name - instanceVariableNames: classToRefactor instanceVariablesString - classVariableNames: classToRefactor classVariablesString - poolDictionaries: classToRefactor sharedPoolsString - category: classToRefactor category.! ! -!InsertSuperclass methodsFor: 'applying - private' stamp: 'HAW 8/13/2018 18:31:06'! - createSuperclass - - ^classToRefactor superclass subclass: superclassName - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: classToRefactor category.! ! -!InsertSuperclass methodsFor: 'initialization' stamp: 'HAW 8/13/2018 17:36:34'! - initializeTo: aClass named: aSuperclassName - - classToRefactor := aClass. - superclassName := aSuperclassName.! ! -!InsertSuperclass class methodsFor: 'instance creation' stamp: 'HAW 3/3/2019 09:11:36'! - newClassPreconditionClass - - ^NewClassPrecondition ! ! -!InsertSuperclass class methodsFor: 'instance creation' stamp: 'HAW 8/13/2018 17:34:37'! - to: aClass named: aSuperclassName - - ^self to: aClass named: aSuperclassName in: Smalltalk undeclared: Undeclared! ! -!InsertSuperclass class methodsFor: 'instance creation' stamp: 'HAW 3/3/2019 09:11:31'! - to: aClass named: aSuperclassName in: aSystem undeclared: anUndeclared - - self newClassPreconditionClass valueFor: aSuperclassName in: aSystem undeclared: anUndeclared. - - ^self new initializeTo: aClass theNonMetaClass named: aSuperclassName ! ! -!PushUpMethod methodsFor: 'initialization' stamp: 'HAW 8/18/2018 11:44:09'! - initializeFor: aMethodToPushup - - method := aMethodToPushup ! ! -!PushUpMethod methodsFor: 'applying' stamp: 'HAW 3/4/2019 15:23:40'! - apply - - | methodCategory | - - methodCategory := method methodClass organization categoryOfElement: method selector. - method methodClass superclass - compile: method sourceCode - classified: methodCategory. - - method methodClass removeSelector: method selector. - ! ! -!PushUpMethod class methodsFor: 'instance creation' stamp: 'HAW 8/18/2018 11:43:53'! - for: aMethodToPushUp - - ^self new initializeFor: aMethodToPushUp ! ! -!RemoveAllUnreferencedInstanceVariables methodsFor: 'initialization' stamp: 'HAW 8/2/2018 16:14:57'! - initializeFrom: aClassToRefactor - - classToRefactor := aClassToRefactor ! ! -!RemoveAllUnreferencedInstanceVariables methodsFor: 'applying' stamp: 'HAW 8/2/2018 16:05:05'! - apply - - | variableNamesToRemove | - - variableNamesToRemove := classToRefactor unreferencedInstanceVariables. - variableNamesToRemove do: [ :aVariableName | classToRefactor removeInstVarName: aVariableName ]. - - ^variableNamesToRemove! ! -!RemoveAllUnreferencedInstanceVariables class methodsFor: 'instance creation' stamp: 'HAW 8/2/2018 16:14:45'! - from: aClassToRefactor - - ^self new initializeFrom: aClassToRefactor ! ! -!RemoveInstanceVariable methodsFor: 'applying' stamp: 'HAW 6/17/2017 19:46:45'! - apply - - classToRefactor removeInstVarName: variableToRemove ! ! -!RemoveInstanceVariable methodsFor: 'initialization' stamp: 'HAW 6/17/2017 19:45:18'! - initializeNamed: aVariable from: aClassToRefactor - - variableToRemove := aVariable. - classToRefactor := aClassToRefactor ! ! -!RemoveInstanceVariable class methodsFor: 'pre-conditions' stamp: 'HAW 6/12/2017 19:11:50'! - assert: aClass defines: anInstanceVariable - - (aClass definesInstanceVariableNamed: anInstanceVariable) ifFalse: [ self signalInstanceVariable: anInstanceVariable notDefinedIn: aClass ].! ! -!RemoveInstanceVariable class methodsFor: 'pre-conditions' stamp: 'HAW 8/1/2018 19:36:10'! - assert: aVaraible isNotReferencedInHierarchyOf: aClassToRefactor - - | references | - - references := OrderedCollection new. - aClassToRefactor withAllSubclassesDo: [ :aClass | - (aClass whichSelectorsAccess: aVaraible) do: [ :aSelector | references add: (MethodReference class: aClass selector: aSelector) ]]. - - references notEmpty ifTrue: [ self signalInstanceVariable: aVaraible isReferencedInAll: references ]! ! -!RemoveInstanceVariable class methodsFor: 'exceptions' stamp: 'HAW 8/1/2018 19:38:57'! - errorMessageForInstanceVariable: aVariable isReferencedInAll: methods - - ^aVariable, ' can not be removed because it has references'. - ! ! -!RemoveInstanceVariable class methodsFor: 'exceptions' stamp: 'HAW 6/12/2017 19:12:41'! - errorMessageForInstanceVariable: aName notDefinedIn: aClass - - ^ 'Instance variable ''' , aName , ''' is not defined in ' , aClass name.! ! -!RemoveInstanceVariable class methodsFor: 'exceptions' stamp: 'HAW 8/17/2018 16:34:16'! - signalInstanceVariable: aVariable isReferencedInAll: methods - - self - canNotRefactorDueToReferencesError: (self errorMessageForInstanceVariable: aVariable isReferencedInAll: methods) - references: methods - to: aVariable! ! -!RemoveInstanceVariable class methodsFor: 'exceptions' stamp: 'HAW 6/12/2017 19:12:12'! - signalInstanceVariable: aName notDefinedIn: aClass - - ^ self refactoringError: (self errorMessageForInstanceVariable: aName notDefinedIn: aClass).! ! -!RemoveInstanceVariable class methodsFor: 'instance creation' stamp: 'HAW 6/17/2017 19:44:39'! - named: aVariable from: aClassToRefactor - - self assert: aClassToRefactor defines: aVariable. - self assert: aVariable isNotReferencedInHierarchyOf: aClassToRefactor. - - ^self new initializeNamed: aVariable from: aClassToRefactor -! ! -!RenameClass methodsFor: 'applying' stamp: 'HAW 6/4/2017 18:09:21'! - apply - - classToRename safeRenameTo: newClassName. - ^self renameReferences. - - ! ! -!RenameClass methodsFor: 'initialization' stamp: 'HAW 8/9/2018 15:40:00'! - initializeFrom: aClass to: aNewClassName in: aSystem undeclared: anUndeclaredDictionary - - classToRename := aClass. - classToRenameOriginalName := aClass name. - newClassName := aNewClassName. - system := aSystem. - undeclared := anUndeclaredDictionary. - - ! ! -!RenameClass methodsFor: 'accessing' stamp: 'HAW 6/4/2017 18:16:33'! - newClassName - - ^newClassName ! ! -!RenameClass methodsFor: 'accessing' stamp: 'HAW 6/4/2017 18:24:56'! - referencesToOldClass - - ^system allCallsOn: newClassName! ! -!RenameClass methodsFor: 'accessing' stamp: 'HAW 6/4/2017 18:25:56'! - referencesToOldClassName - - ^system allCallsOn: classToRenameOriginalName! ! -!RenameClass methodsFor: 'applying - private' stamp: 'HAW 8/13/2018 15:27:46'! - newSourceCodeOf: aCompiledMethod - - | newSource | - - newSource := aCompiledMethod sourceCode copyReplacing: (self rangesToReplaceOf: aCompiledMethod) with: newClassName. - - ^newSource! ! -!RenameClass methodsFor: 'applying - private' stamp: 'HAW 9/3/2018 19:48:30'! - rangesForLiteralOf: methodNode - - | literalRanges | - - literalRanges := methodNode positionsForLiteralNode: classToRenameOriginalName ifAbsent: [ #() ]. - literalRanges := literalRanges collect: [ :aRange | aRange first + 1 to: aRange last ]. - - ^literalRanges ! ! -!RenameClass methodsFor: 'applying - private' stamp: 'HAW 9/3/2018 19:48:49'! - rangesForLiteralVariableOf: methodNode - - ^methodNode positionsForLiteralVariableNode: classToRenameOriginalName ifAbsent: [ #() ] - ! ! -!RenameClass methodsFor: 'applying - private' stamp: 'HAW 8/13/2018 15:20:40'! - rangesToReplaceOf: aCompiledMethod - - | methodNode ranges | - - methodNode := aCompiledMethod methodNode. - ranges := SortedCollection sortBlock: [ :leftRange :rightRange | leftRange first < rightRange first ]. - - ranges addAll: (self rangesForLiteralVariableOf: methodNode). - ranges addAll: (self rangesForLiteralOf: methodNode). - - ^ranges ! ! -!RenameClass methodsFor: 'applying - private' stamp: 'HAW 8/9/2018 14:50:34'! - references: aMethodReference classVarNamed: aName - - ^aMethodReference actualClass definesClassVariableNamedInHierarchy: aName ! ! -!RenameClass methodsFor: 'applying - private' stamp: 'HAW 8/9/2018 14:50:52'! - referencesNewClassName: aMethodReference - - ^self references: aMethodReference classVarNamed: newClassName ! ! -!RenameClass methodsFor: 'applying - private' stamp: 'HAW 8/9/2018 14:51:07'! - referencesOldClassName: aMethodReference - - ^self references: aMethodReference classVarNamed: classToRenameOriginalName! ! -!RenameClass methodsFor: 'applying - private' stamp: 'HAW 8/9/2018 14:49:43'! - rejectReferencesToClassVariablesFrom: references - - ^references reject: [ :aMethodReference | (self referencesOldClassName: aMethodReference) or: [ self referencesNewClassName: aMethodReference ] ].! ! -!RenameClass methodsFor: 'applying - private' stamp: 'HAW 8/13/2018 15:18:43'! - renameReference: aReferencingMethod - - | newSource | - - newSource := self newSourceCodeOf: aReferencingMethod. - aReferencingMethod methodClass compile: newSource ! ! -!RenameClass methodsFor: 'applying - private' stamp: 'HAW 8/13/2018 15:17:56'! - renameReferences - - | references | - - references := (self referencesToOldClass asSet, self referencesToOldClassName asSet) asOrderedCollection. - references := self rejectReferencesToClassVariablesFrom: references. - references do: [ :aReference | self renameReference: aReference compiledMethod ]. - - ^references! ! -!RenameClass class methodsFor: 'pre-conditions' stamp: 'HAW 6/1/2017 19:06:21'! - assert: aClass isNotNamed: aNewName - - aClass name = aNewName ifTrue: [ self signalNewNameEqualsOldName]! ! -!RenameClass class methodsFor: 'pre-conditions' stamp: 'HAW 6/4/2017 18:49:54'! - assertIsNotMeta: aBehavior - - aBehavior isMeta ifTrue: [ self signalClassToRenameCanNotBeMetaclass]! ! -!RenameClass class methodsFor: 'pre-conditions' stamp: 'HAW 8/13/2018 18:45:26'! - newClassPreconditionClass - - ^NewClassPrecondition ! ! -!RenameClass class methodsFor: 'exceptions' stamp: 'HAW 6/4/2017 18:50:36'! - classToRenameCanNotBeMetaclassErrorMessage - - ^'Class to rename can not be a metaclass'! ! -!RenameClass class methodsFor: 'exceptions' stamp: 'HAW 6/1/2017 19:07:08'! - newNameEqualsOldNameErrorMessage - - ^'New class name equals old one'! ! -!RenameClass class methodsFor: 'exceptions' stamp: 'HAW 6/4/2017 18:50:56'! - signalClassToRenameCanNotBeMetaclass - - self refactoringError: self classToRenameCanNotBeMetaclassErrorMessage! ! -!RenameClass class methodsFor: 'exceptions' stamp: 'HAW 8/13/2018 18:39:00'! - signalNewNameEqualsOldName - - self refactoringError: self newNameEqualsOldNameErrorMessage.! ! -!RenameClass class methodsFor: 'instance creation' stamp: 'HAW 6/2/2017 11:43:48'! - from: aClass to: aNewClassName - - ^self from: aClass to: aNewClassName in: Smalltalk - ! ! -!RenameClass class methodsFor: 'instance creation' stamp: 'HAW 6/2/2017 11:55:32'! - from: aClass to: aNewClassName in: aSystem - - ^self from: aClass to: aNewClassName in: aSystem undeclared: Undeclared - - ! ! -!RenameClass class methodsFor: 'instance creation' stamp: 'HAW 8/13/2018 18:45:15'! - from: aClass to: aNewClassName in: aSystem undeclared: anUndeclaredDictionary - - self assertIsNotMeta: aClass. - self assert: aClass isNotNamed: aNewClassName. - self newClassPreconditionClass valueFor: aNewClassName in: aSystem undeclared: anUndeclaredDictionary. - - ^self new initializeFrom: aClass to: aNewClassName in: aSystem undeclared: anUndeclaredDictionary -! ! -!RenameInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 6/11/2017 19:06:35'! - addNewInstanceVariable - - addInstanceVariable apply! ! -!RenameInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 6/11/2017 19:07:49'! - copyOldInstanceVariableToNewOne - - | oldVariableIndex newVariableIndex | - - oldVariableIndex := self classToRefactor indexOfInstanceVariable: oldVariable. - newVariableIndex := self classToRefactor indexOfInstanceVariable: self newVariable. - self classToRefactor allSubInstancesDo: [ :anInstance | anInstance instVarAt: newVariableIndex put: (anInstance instVarAt: oldVariableIndex) ]. - -! ! -!RenameInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 9/3/2018 19:48:09'! -newSourceOf: aCompiledMethod - - | newSource ranges | - - ranges := aCompiledMethod methodNode positionsForInstanceVariable: oldVariable ifAbsent: [ #() ]. - newSource := aCompiledMethod sourceCode copyReplacing: ranges with: self newVariable. - - ^newSource - ! ! -!RenameInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 6/11/2017 19:07:20'! - removeOldInstanceVariable - - self classToRefactor removeInstVarName: oldVariable.! ! -!RenameInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 6/11/2017 19:07:10'! - renameReferencesToOldVariable - - renamedReferences := OrderedCollection new. - self classToRefactor withAllSubclassesDo: [ :aClass | self renameReferencesToOldVariableInClass: aClass ]! ! -!RenameInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 6/17/2017 19:17:33'! - renameReferencesToOldVariableInClass: aClass - - | referencingMethodNames | - - referencingMethodNames := aClass whichSelectorsAccess: oldVariable. - referencingMethodNames do: [ :referencingMethodName | self renameReferencesToOldVariableInMethod: (aClass compiledMethodAt: referencingMethodName) ] - ! ! -!RenameInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 8/13/2018 14:53:56'! - renameReferencesToOldVariableInMethod: aCompiledMethod - - aCompiledMethod methodClass compile: (self newSourceOf: aCompiledMethod). - renamedReferences add: aCompiledMethod methodReference ! ! -!RenameInstanceVariable methodsFor: 'applying' stamp: 'HAW 6/5/2017 16:53:57'! - apply - - self - addNewInstanceVariable; - copyOldInstanceVariableToNewOne; - renameReferencesToOldVariable; - removeOldInstanceVariable. - - ^renamedReferences - ! ! -!RenameInstanceVariable methodsFor: 'accessing' stamp: 'HAW 6/11/2017 19:09:35'! - classToRefactor - - ^addInstanceVariable classToRefactor! ! -!RenameInstanceVariable methodsFor: 'accessing' stamp: 'HAW 6/11/2017 19:07:37'! - newVariable - - ^ addInstanceVariable newVariable! ! -!RenameInstanceVariable methodsFor: 'initialization' stamp: 'HAW 8/9/2018 17:20:55'! - initializeFrom: anOldvariable addingWith: anAddInstanceVariable - - oldVariable := anOldvariable. - addInstanceVariable := anAddInstanceVariable. -! ! -!RenameInstanceVariable class methodsFor: 'pre-conditions' stamp: 'HAW 5/24/2017 21:49:18'! - assert: aClass defines: anInstanceVariable - - (aClass definesInstanceVariableNamed: anInstanceVariable) ifFalse: [ self signalInstanceVariable: anInstanceVariable notDefinedIn: aClass ].! ! -!RenameInstanceVariable class methodsFor: 'exceptions' stamp: 'HAW 5/24/2017 21:56:02'! - errorMessageForInstanceVariable: aName notDefinedIn: aClass - - ^ 'Instance variable ''' , aName , ''' is not defined in ' , aClass name.! ! -!RenameInstanceVariable class methodsFor: 'exceptions' stamp: 'HAW 6/3/2017 11:54:22'! - signalInstanceVariable: aName notDefinedIn: aClass - - ^ self refactoringError: (self errorMessageForInstanceVariable: aName notDefinedIn: aClass).! ! -!RenameInstanceVariable class methodsFor: 'instance creation' stamp: 'HAW 6/11/2017 19:04:59'! - from: anOldvariable to: aNewVariable in: aClassToRefactor - - | addInstanceVariable | - - self assert: aClassToRefactor defines: anOldvariable. - addInstanceVariable := AddInstanceVariable named: aNewVariable to: aClassToRefactor. - - ^self new initializeFrom: anOldvariable addingWith: addInstanceVariable ! ! -!RenameTemporary methodsFor: 'applying' stamp: 'HAW 9/3/2018 19:49:06'! - apply - - | newSource ranges | - - ranges := methodNode positionsForTemporaryVariable: oldVariable ifAbsent: [ #() ]. - newSource := methodNode sourceText copyReplacing: ranges with: newVariable. - - ^ newSource! ! -!RenameTemporary methodsFor: 'applying' stamp: 'HAW 8/9/2018 19:34:51'! - methodNodeAfterApply - - ^methodNode methodClass methodNodeFor: self apply. - - ! ! -!RenameTemporary methodsFor: 'initialization' stamp: 'HAW 6/25/2017 21:53:31'! - initializeFrom: anOldVariable to: aNewVariable in: aMethodNode - - oldVariable := anOldVariable. - newVariable := aNewVariable. - methodNode := aMethodNode ! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 6/25/2017 21:53:31'! - assert: aVariable isDefinedIn: aMethodNode - - (aMethodNode tempNames includes: aVariable) ifFalse: [ self signalTemporaryVariable: aVariable notDefinedIn: aMethodNode ]! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 6/25/2017 21:53:31'! - assert: aNewVariable isNotDefinedIn: aMethodNode - - (aMethodNode tempNames includes: aNewVariable) ifTrue: [ self signalNewTemporaryVariable: aNewVariable isAlreadyDefinedIn: aMethodNode ] - ! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 6/25/2017 21:53:31'! - assertIsNotEmpty: aNewVariable - - aNewVariable isEmpty ifTrue: [ self signalNewVariableCanNotBeEmpty ]! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 6/25/2017 21:53:31'! - assertIsValidVariableName: aName - - | scannedNames | - - scannedNames _ Scanner new scanFieldNames: aName. - scannedNames size = 1 ifFalse: [ self signalInvalidTemporaryVariable: aName ]. - scannedNames first = aName ifFalse: [ self signalInvalidTemporaryVariable: aName ].! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 6/25/2017 21:53:31'! - warnIf: aNewVariable isDefinedAsInstanceVariableInHierarchyOf: aClass - - | classDefiningNewVariable | - - classDefiningNewVariable := aClass whichClassDefinesInstanceVariable: aNewVariable ifNone: [ ^self ]. - self warn: aNewVariable willHideInstanceVariableDefinedIn: classDefiningNewVariable ! ! -!RenameTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/25/2017 21:53:31'! - errorMessageForInvalidTemporaryVariable: aName - - ^ '''' , aName , ''' is not a valid temporary variable name'.! ! -!RenameTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/25/2017 21:53:31'! - errorMessageForNewTemporaryVariable: aNewVariable isAlreadyDefinedIn: aMethodNode - - ^aNewVariable, ' is already defined in ', aMethodNode classAndSelector ! ! -!RenameTemporary class methodsFor: 'exceptions' stamp: 'HAW 10/4/2017 17:04:37'! - errorMessageForTemporaryVariable: aVariable notDefinedIn: aMethodNode - - ^'Temporary variable ', aVariable, ' is not defined in ', aMethodNode classAndSelector ! ! -!RenameTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/25/2017 21:53:31'! - newVariableCanNotBeEmptyErrorMessage - - ^'New variable can not be empty'! ! -!RenameTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/25/2017 21:53:31'! - signalInvalidTemporaryVariable: aName - - ^ self refactoringError: (self errorMessageForInvalidTemporaryVariable: aName).! ! -!RenameTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/25/2017 21:53:31'! - signalNewTemporaryVariable: aNewVariable isAlreadyDefinedIn: aMethodNode - - self refactoringError: (self errorMessageForNewTemporaryVariable: aNewVariable isAlreadyDefinedIn: aMethodNode )! ! -!RenameTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/25/2017 21:53:31'! - signalNewVariableCanNotBeEmpty - - self refactoringError: self newVariableCanNotBeEmptyErrorMessage! ! -!RenameTemporary class methodsFor: 'exceptions' stamp: 'HAW 10/4/2017 17:04:27'! - signalTemporaryVariable: aVariable notDefinedIn: aMethodNode - - self refactoringError: (self errorMessageForTemporaryVariable: aVariable notDefinedIn: aMethodNode)! ! -!RenameTemporary class methodsFor: 'instance creation' stamp: 'HAW 6/25/2017 21:53:31'! - from: anOldVariable to: aNewVariable in: aMethodNode - - | trimmedNewVariable | - - trimmedNewVariable := aNewVariable withBlanksTrimmed. - - self assert: anOldVariable isDefinedIn: aMethodNode. - self assertIsNotEmpty: trimmedNewVariable. - self assertIsValidVariableName: trimmedNewVariable. - self assert: trimmedNewVariable isNotDefinedIn: aMethodNode. - - self warnIf: trimmedNewVariable isDefinedAsInstanceVariableInHierarchyOf: aMethodNode methodClass. - - ^self new initializeFrom: anOldVariable to: trimmedNewVariable in: aMethodNode -! ! -!RenameTemporary class methodsFor: 'warnings' stamp: 'HAW 6/25/2017 21:53:31'! - warn: aNewVariable willHideInstanceVariableDefinedIn: aClass - - self refactoringWarning: (self warningMessageFor: aNewVariable willHideInstanceVariableDefinedIn: aClass)! ! -!RenameTemporary class methodsFor: 'warnings' stamp: 'HAW 6/25/2017 21:53:31'! - warningMessageFor: aNewVariable willHideInstanceVariableDefinedIn: aClass - - ^aNewVariable, ' will hide instance variable defined in ', aClass name! ! -!SafelyRemoveClass methodsFor: 'applying' stamp: 'HAW 8/1/2018 16:42:17'! -apply - - self removeWithAllSubclasses: classToRemove. - ! ! -!SafelyRemoveClass methodsFor: 'applying - private' stamp: 'HAW 8/1/2018 16:42:17'! - removeWithAllSubclasses: aClassToRemove - - "I have to do 'subclasses do:' and not 'subclassesDo:' because removing a class modifies parent's subclasses collection. - #subclasses returns a copy of superclass' subclasses collection -Hernan" - aClassToRemove subclasses do: [ :aSubclassToRemove | self removeWithAllSubclasses: aSubclassToRemove ]. - aClassToRemove removeFromSystem. - ! ! -!SafelyRemoveClass methodsFor: 'initialization' stamp: 'HAW 8/1/2018 16:42:17'! - initializeOf: aClassToSafetelyRemove - - classToRemove := aClassToSafetelyRemove ! ! -!SafelyRemoveClass class methodsFor: 'instance creation' stamp: 'HAW 8/1/2018 16:42:17'! - of: aClassToSafelyRemove - - | theNonMetaclassToRemove | - - theNonMetaclassToRemove := aClassToSafelyRemove theNonMetaClass. - self assertNoReferencesTo: theNonMetaclassToRemove. - self warnIfHasSubclasses: theNonMetaclassToRemove. - - ^self new initializeOf: theNonMetaclassToRemove ! ! -!SafelyRemoveClass class methodsFor: 'pre-conditions' stamp: 'HAW 8/1/2018 16:42:17'! - assertNoReferencesTo: aClassToSafelyRemove - - | references withAllSubclasses withAllSubclassesNames referenced | - - withAllSubclasses := aClassToSafelyRemove withAllSubclasses. - withAllSubclassesNames := withAllSubclasses collect: [:aClass | aClass name ]. - references :=OrderedCollection new. - referenced := OrderedCollection new. - - withAllSubclasses do: [ :aClass | | allReferences referencesOutsideHierarchy | - allReferences := aClass allCallsOn. - referencesOutsideHierarchy := allReferences reject: [ :aReference | withAllSubclassesNames includes: aReference classSymbol ]. - referencesOutsideHierarchy notEmpty ifTrue: [ - referenced add: aClass. - references addAll: referencesOutsideHierarchy ]]. - - references notEmpty ifTrue: [ self signalCanNotRemove: aClassToSafelyRemove dueToReferences: references toAll: referenced ]! ! -!SafelyRemoveClass class methodsFor: 'pre-conditions' stamp: 'HAW 8/1/2018 16:42:17'! - warnIfHasSubclasses: aClassToSafelyRemove - - | allSubclasses | - - allSubclasses := aClassToSafelyRemove allSubclasses. - allSubclasses isEmpty ifFalse: [ self warn: aClassToSafelyRemove hasSubclasses: allSubclasses ]! ! -!SafelyRemoveClass class methodsFor: 'exceptions' stamp: 'HAW 8/1/2018 18:10:36'! - errorMessageForCanNotRemove: aClassToSafelyRemove dueToReferencesToAll: referenced - - ^String streamContents: [ :stream | - stream - nextPutAll: aClassToSafelyRemove name asString; - nextPutAll: ' can not be removed '. - - referenced size = 1 - ifTrue: [ (referenced includes: aClassToSafelyRemove) - ifTrue: [ stream nextPutAll: 'because it has references' ] - ifFalse: [ stream - nextPutAll: 'because it subclass, '; - nextPutAll: referenced anyOne name asString; - nextPutAll: ', has references' ]] - ifFalse: [ (referenced includes: aClassToSafelyRemove) - ifTrue: [ stream - nextPutAll: 'due to references to: '; - nextPutAll: referenced asCommaStringAnd ] - ifFalse: [ stream - nextPutAll: 'due to references to its subclasses: '; - nextPutAll: referenced asCommaStringAnd ]]]! ! -!SafelyRemoveClass class methodsFor: 'exceptions' stamp: 'HAW 8/17/2018 16:34:16'! - signalCanNotRemove: aClassToSafelyRemove dueToReferences: references toAll: allReferenced - - self - canNotRefactorDueToReferencesError: (self errorMessageForCanNotRemove: aClassToSafelyRemove dueToReferencesToAll: allReferenced) - references: references - to: aClassToSafelyRemove - ! ! -!SafelyRemoveClass class methodsFor: 'warnings' stamp: 'HAW 8/1/2018 16:42:17'! - warn: aClassToSafelyRemove hasSubclasses: allSubclasses - - self refactoringWarning: (self warningMessageFor: aClassToSafelyRemove hasSubclasses: allSubclasses)! ! -!SafelyRemoveClass class methodsFor: 'warnings' stamp: 'HAW 8/1/2018 18:24:31'! - warningMessageFor: aClassToSafelyRemove hasSubclasses: allSubclasses - - ^String streamContents: [ :stream | - stream nextPutAll: aClassToSafelyRemove name asString. - allSubclasses size = 1 - ifTrue: [ stream nextPutAll: ' has a subclass' ] - ifFalse: [ stream - nextPutAll: ' has '; - print: allSubclasses size; - nextPutAll: ' subclasses' ]. - stream nextPutAll: ' that will be removed']. - - ! ! -!RefactoringApplier methodsFor: 'refactoring - applying' stamp: 'HAW 6/5/2017 18:06:39'! - applyRefactoring - - changes := refactoring apply! ! -!RefactoringApplier methodsFor: 'refactoring - creation' stamp: 'HAW 6/5/2017 18:05:46'! - createRefactoring - - self subclassResponsibility ! ! -!RefactoringApplier methodsFor: 'refactoring - creation' stamp: 'HAW 6/5/2017 18:05:20'! - createRefactoringHandlingRefactoringExceptions - - self valueHandlingRefactoringExceptions: [ refactoring := self createRefactoring ] - ! ! -!RefactoringApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 6/5/2017 14:24:04'! - endRequest - - ^requestExitBlock value! ! -!RefactoringApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 6/5/2017 19:04:16'! - requestRefactoringParameters - - self subclassResponsibility ! ! -!RefactoringApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 6/5/2017 19:05:35'! - requestRefactoringParametersHandlingRefactoringExceptions - - self valueHandlingRefactoringExceptions: [ self requestRefactoringParameters ] - ! ! -!RefactoringApplier methodsFor: 'exception handling' stamp: 'HAW 8/17/2018 16:37:38'! - browseReferencesOn: aCanNotRefactorDueToReferencesError - - Smalltalk - browseMessageList: aCanNotRefactorDueToReferencesError references - name: (self referencesBrowserTitleOn: aCanNotRefactorDueToReferencesError) - autoSelect: true -! ! -!RefactoringApplier methodsFor: 'exception handling' stamp: 'HAW 8/17/2018 16:37:55'! - handleCanNotRefactorDueToReferencesError: aCanNotRefactorDueToReferencesError - - | options answer question | - - options := -'Browse references -Cancel'. - - question := PopUpMenu labels: options icons: #(mailForwardIcon cancelIcon). - answer := question startUpWithCaption: aCanNotRefactorDueToReferencesError messageText. - - answer = 1 ifTrue: [ self browseReferencesOn: aCanNotRefactorDueToReferencesError ]. - self endRequest.! ! -!RefactoringApplier methodsFor: 'exception handling' stamp: 'HAW 6/5/2017 18:47:40'! - handleRefactoringError: aRefactoringError - - self inform: aRefactoringError messageText. - self endRequest ! ! -!RefactoringApplier methodsFor: 'exception handling' stamp: 'HAW 8/1/2018 18:15:21'! - handleRefactoringWarning: aRefactoringWarning - - (self confirm: aRefactoringWarning messageText, '. Continue?') - ifTrue: [ aRefactoringWarning resume ] - ifFalse: [ self endRequest]! ! -!RefactoringApplier methodsFor: 'exception handling' stamp: 'HAW 8/17/2018 16:38:07'! - referencesBrowserTitleOn: aCanNotRefactorDueToReferencesError - - ^'References to ', aCanNotRefactorDueToReferencesError referencee asString! ! -!RefactoringApplier methodsFor: 'exception handling' stamp: 'HAW 8/17/2018 16:35:47'! - valueHandlingRefactoringExceptions: aBlock - - ^[[aBlock - on: Refactoring refactoringWarningClass - do: [ :aRefactoringWarning | self handleRefactoringWarning: aRefactoringWarning ]] - on: Refactoring canNotRefactorDueToReferencesErrorClass - do: [ :aCanNotRefactorDueToReferencesError | self handleCanNotRefactorDueToReferencesError: aCanNotRefactorDueToReferencesError ]] - on: Refactoring refactoringErrorClass - do: [ :aRefactoringError | self handleRefactoringError: aRefactoringError ] - ! ! -!RefactoringApplier methodsFor: 'request information' stamp: 'HAW 6/11/2017 19:22:50'! - request: aLabel - - ^self request: aLabel initialAnswer: '' -! ! -!RefactoringApplier methodsFor: 'request information' stamp: 'HAW 6/5/2017 16:03:04'! - request: aLabel initialAnswer: anAnswer - - ^self request: aLabel initialAnswer: anAnswer onCancel: requestExitBlock ! ! -!RefactoringApplier methodsFor: 'request information' stamp: 'HAW 6/5/2017 16:03:30'! - request: aLabel initialAnswer: anAnswer onCancel: cancelBlock - - ^FillInTheBlankMorph request: aLabel initialAnswer: anAnswer onCancel: cancelBlock ! ! -!RefactoringApplier methodsFor: 'refactoring - changes' stamp: 'HAW 6/5/2017 18:06:53'! - showChanges - - self subclassResponsibility - ! ! -!RefactoringApplier methodsFor: 'evaluating' stamp: 'HAW 6/5/2017 19:05:50'! - value - - requestExitBlock := [ ^self ]. - - self - requestRefactoringParametersHandlingRefactoringExceptions; - createRefactoringHandlingRefactoringExceptions; - applyRefactoring; - showChanges - - ! ! -!RefactoringApplier class methodsFor: 'value handling exceptions' stamp: 'HAW 1/7/2019 15:28:18'! - createAndValueHandlingExceptions: creationBlock - - | refactoring | - - refactoring := creationBlock - on: Refactoring refactoringErrorClass - do: [ :refactoringError | ^self inform: refactoringError messageText ]. - - refactoring value ! ! -!AddInstanceVariableApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/30/2017 18:12:33'! - askNewVariableName - - newInstanceVariable := self request: self newVariableNameLabel. - newInstanceVariable := newInstanceVariable withBlanksTrimmed ! ! -!AddInstanceVariableApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/30/2017 18:12:47'! - newVariableNameLabel - - ^'Enter new variable name:'! ! -!AddInstanceVariableApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 6/11/2017 19:18:00'! - requestRefactoringParameters - - self askNewVariableName! ! -!AddInstanceVariableApplier methodsFor: 'refactoring - creation' stamp: 'HAW 6/11/2017 19:19:25'! - createRefactoring - - ^AddInstanceVariable named: newInstanceVariable to: classToRefactor. - ! ! -!AddInstanceVariableApplier methodsFor: 'refactoring - changes' stamp: 'HAW 1/7/2019 14:41:01'! -informChangesToBrowser - - browser acceptedContentsChanged! ! -!AddInstanceVariableApplier methodsFor: 'refactoring - changes' stamp: 'HAW 6/11/2017 19:20:03'! - showChanges - - self informChangesToBrowser! ! -!AddInstanceVariableApplier methodsFor: 'initialization' stamp: 'HAW 1/7/2019 14:40:44'! - initializeOn: aBrowser for: aClassToRefactor - - browser := aBrowser. - classToRefactor := aClassToRefactor ! ! -!AddInstanceVariableApplier class methodsFor: 'instance creation' stamp: 'HAW 1/7/2019 14:40:37'! - on: aBrowser for: aClassToRefactor - - ^self new initializeOn: aBrowser for: aClassToRefactor -! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 1/3/2019 07:57:24'! - askForImplementosAndSenders - - self - askScope; - calculateImplementorsAndSenders; - startWizard ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/18/2018 17:21:12'! - askScope - - | scopeMenu | - - scopeMenu := PopUpMenu labelArray: self scopeOptionLabels. - scopeChoice := scopeMenu startUpWithCaption: 'Select Refactoring Scope'. - scopeChoice = 0 ifTrue: [ self endRequest ]. - ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 12/13/2018 17:41:06'! - calculateImplementorsAndSenders - - implementors := IdentitySet new. - senders := IdentitySet new. - - scopeChoice = 1 ifTrue: [ ^self implementorsAndSendersForClass ]. - scopeChoice = 2 ifTrue: [ ^self implementorsAndSendersForHierarchy ]. - scopeChoice = 3 ifTrue: [ ^self implementorsAndSendersInCategory ]. - scopeChoice = 4 ifTrue: [ ^self implementorsAndSendersInCategoryAndHierarchy ]. - scopeChoice = 5 ifTrue: [ ^self implementorsAndSendersInSystem ]. - - self error: 'Unknown scope option' - - ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/18/2018 17:00:51'! - implementorsAndSendersForClass - - ^self refactoringClass addImplementorsOf: oldSelector to: implementors andSendersTo: senders forClassAndMetaOf: implementingClass! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/18/2018 17:00:56'! - implementorsAndSendersForHierarchy - - ^self refactoringClass addImplementorsOf: oldSelector to: implementors andSendersTo: senders inHierarchyOf: implementingClass! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/18/2018 17:01:01'! - implementorsAndSendersInCategory - - ^self refactoringClass - addImplementorsOf: oldSelector - to: implementors - andSendersTo: senders - inCategory: implementingClass category - organizedBy: SystemOrganization! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/18/2018 17:01:05'! - implementorsAndSendersInCategoryAndHierarchy - - ^self refactoringClass - addImplementorsOf: oldSelector - to: implementors - andSendersTo: senders - inCategoriesAndHierarchyOf: implementingClass - organizedBy: SystemOrganization ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/18/2018 17:01:15'! - implementorsAndSendersInSystem - - ^self refactoringClass addImplementorsOf: oldSelector to: implementors andSendersTo: senders inSystem: Smalltalk ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 12/13/2018 17:41:33'! -scopeOptionLabels - - ^{'In Class'. 'In Hierarchy'. 'In Category'. 'In Hierarchy and its Categories'. 'In System'}.! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 1/7/2019 11:17:34'! - startWizard - - ChangeSelectorImplementorsStepWindow openFrom: self! ! -!ChangeSelectorApplier methodsFor: 'accessing' stamp: 'HAW 8/18/2018 17:02:26'! - implementors - - ^implementors ! ! -!ChangeSelectorApplier methodsFor: 'accessing' stamp: 'HAW 8/18/2018 17:02:29'! - implementors: implementorsCollection - - implementors := implementorsCollection ! ! -!ChangeSelectorApplier methodsFor: 'accessing' stamp: 'HAW 8/18/2018 17:02:33'! - oldSelector - - ^oldSelector ! ! -!ChangeSelectorApplier methodsFor: 'accessing' stamp: 'HAW 8/18/2018 17:02:37'! - senders - - ^senders ! ! -!ChangeSelectorApplier methodsFor: 'accessing' stamp: 'HAW 8/18/2018 17:02:41'! - senders: sendersCollection - - senders := sendersCollection ! ! -!ChangeSelectorApplier methodsFor: 'accessing' stamp: 'HAW 1/7/2019 11:16:36'! - wizardStepWindow: aWizarStepWindow - - wizardStepWindow := aWizarStepWindow ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - changes' stamp: 'HAW 1/7/2019 11:08:33'! - closeBrowser - - wizardStepWindow delete. - ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - changes' stamp: 'HAW 10/10/2018 19:50:39'! - doNotShowChanges - - shouldShowChanges := false! ! -!ChangeSelectorApplier methodsFor: 'refactoring - changes' stamp: 'HAW 1/7/2019 14:09:10'! - informChangesToBrowser - - "If the selected message is not the same as the oldSelector, that is the selector being renamed, - then it implies that we are renaming a selector sent in the source code of the selected message then - I don't have to change the selected message in the browser - Hernan" - browser selectedMessageName = oldSelector ifTrue: [ - browser setSelector: refactoring newSelector ]! ! -!ChangeSelectorApplier methodsFor: 'refactoring - changes' stamp: 'HAW 8/18/2018 17:02:52'! - messageSetWindowClass - - ^MessageSetWindow - ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - changes' stamp: 'HAW 10/10/2018 19:52:08'! - showChanges - - self showChangesInMessageSetWindow! ! -!ChangeSelectorApplier methodsFor: 'refactoring - changes' stamp: 'HAW 8/18/2018 17:28:30'! - showChangesInMessageSetWindow - - self messageSetWindowClass openMessageList: changes asSortedCollection label: 'Changed methods' ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - creation' stamp: 'HAW 1/7/2019 13:51:04'! -createAndApplyRefactoring - - self - createRefactoringHandlingRefactoringExceptions; - applyRefactoring; - informChangesToBrowser. - - shouldShowChanges ifTrue: [ self showChanges ] - - ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - creation' stamp: 'HAW 1/3/2019 08:46:41'! - createAndApplyRefactoringWhenNoSendersAndOneImplementor: anImplementor - - implementors := Array with: anImplementor. - senders := #(). - shouldShowChanges := false. - - self createAndApplyRefactoring ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - creation' stamp: 'HAW 8/18/2018 17:03:58'! - refactoringClass - - self subclassResponsibility ! ! -!ChangeSelectorApplier methodsFor: 'initialization' stamp: 'HAW 1/7/2019 13:47:34'! - initializeOn: aBrowser for: aSelector in: aClass - - oldSelector := aSelector. - implementingClass := aClass. - browser := aBrowser. - shouldShowChanges := true.! ! -!ChangeSelectorApplier methodsFor: 'evaluation' stamp: 'HAW 1/7/2019 14:59:52'! - ifHasNoSendersAndOneImplementor: trueBlock ifNot: falseBlock - - | allImplementors | - - allImplementors := Smalltalk allImplementorsOf: oldSelector. - - "I could try to see if there is one sender and that that sender is in the same method beeing renamed. That could - mean that it is a recursive call but I should also see if the receiver is self to be sure because if it is other 'type' of - object the rename could not be safe. To complex for a small posibility - Hernan" - (allImplementors size = 1 and: [ (Smalltalk allCallsOn: oldSelector) isEmpty ]) - ifTrue: [ trueBlock value: allImplementors anyOne compiledMethod ] - ifFalse: falseBlock! ! -!ChangeSelectorApplier methodsFor: 'evaluation' stamp: 'HAW 1/3/2019 08:41:27'! - value - - requestExitBlock := [ ^self ]. - - self requestRefactoringParametersHandlingRefactoringExceptions. - - self - ifHasNoSendersAndOneImplementor: [ :anImplementor | self createAndApplyRefactoringWhenNoSendersAndOneImplementor: anImplementor ] - ifNot: [ self askForImplementosAndSenders ]! ! -!ChangeSelectorApplier methodsFor: 'evaluation' stamp: 'HAW 1/3/2019 08:46:11'! - wizardEnded - - requestExitBlock := [ ^self ]. - - self - closeBrowser; - createAndApplyRefactoring.! ! -!ChangeSelectorApplier class methodsFor: 'pre-conditions' stamp: 'HAW 8/18/2018 17:17:52'! - assertCanApplyRefactoringFor: aSelector in: aClass - - self subclassResponsibility ! ! -!ChangeSelectorApplier class methodsFor: 'instance creation' stamp: 'HAW 1/7/2019 13:47:54'! - on: aBrowser for: aSelector in: aClass - - self assertCanApplyRefactoringFor: aSelector in: aClass. - - ^self new initializeOn: aBrowser for: aSelector in: aClass - ! ! -!AddParameterApplier methodsFor: 'refactoring - creation' stamp: 'HAW 8/18/2018 16:46:49'! - createRefactoring - - oldSelector isUnary ifTrue: [ ^self createRefactoringForUnarySelector]. - oldSelector isKeyword ifTrue: [ ^self createRefactoringForKeywordSelector ]. - - self error: 'oldSelector should be unary or keyword!!'! ! -!AddParameterApplier methodsFor: 'refactoring - creation' stamp: 'HAW 9/4/2018 20:24:53'! - createRefactoringForKeywordSelector - - ^self refactoringClass - named: newParameter - at: parameterIndex - initializedWith: newParameterValue - using: newKeyword - toKeywordSelector: oldSelector - implementors: implementors - senders: senders ! ! -!AddParameterApplier methodsFor: 'refactoring - creation' stamp: 'HAW 8/18/2018 16:56:55'! - createRefactoringForUnarySelector - - ^self refactoringClass - named: newParameter - initializedWith: newParameterValue - toUnarySelector: oldSelector - implementors: implementors - senders: senders ! ! -!AddParameterApplier methodsFor: 'refactoring - creation' stamp: 'HAW 8/18/2018 16:56:55'! - refactoringClass - - ^AddParameter! ! -!AddParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 9/4/2018 20:33:41'! - askInsertionIndex - - | methodNode originalMethod parameterNames | - - originalMethod := implementingClass compiledMethodAt: oldSelector. - methodNode := originalMethod methodNode. - parameterNames := methodNode argumentNames. - parameterNames add: 'Add as last parameter'. - - parameterIndex := (PopUpMenu labelArray: parameterNames) startUpWithCaption: 'Add Before?'. - parameterIndex = 0 ifTrue: [self endRequest ]. - - ! ! -!AddParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 9/4/2018 20:33:37'! - askInsertionIndexIfNecessary - - oldSelector isKeyword ifTrue: [ self askInsertionIndex ]. - ! ! -!AddParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/18/2018 17:06:28'! - askNewKeyword - - | enteredString | - - enteredString := self request: 'Enter keyword for new parameter'. - newKeyword := enteredString withBlanksTrimmed asSymbol. - self refactoringClass assertIsValidKeywordForNewParameter: newKeyword! ! -!AddParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/18/2018 17:06:28'! - askNewKeywordIfNecessary - - oldSelector isKeyword ifTrue: [self askNewKeyword]! ! -!AddParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/18/2018 16:56:55'! - askNewParameter - - | enteredString | - - enteredString := self request: 'Enter new parameter name'. - newParameter := enteredString withBlanksTrimmed. - self refactoringClass assertIsValidParameterName: newParameter -! ! -!AddParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/25/2018 11:28:58'! - askNewParameterValue - - | enteredString | - - enteredString := self request: 'Enter parameter value for senders'. - newParameterValue := enteredString withBlanksTrimmed. - self refactoringClass assertNewParameterValueIsNotEmpty: newParameterValue. - self refactoringClass assertNewParameterValueIsValid: newParameterValue. -! ! -!AddParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 1/3/2019 08:01:40'! - requestRefactoringParameters - - self - askNewParameter; - askNewParameterValue; - askInsertionIndexIfNecessary; - askNewKeywordIfNecessary - ! ! -!AddParameterApplier class methodsFor: 'pre-conditions' stamp: 'HAW 8/18/2018 17:18:06'! - assertCanApplyRefactoringFor: aSelector in: aClass - - AddParameter assertCanAddParameterTo: aSelector. - - - ! ! -!RemoveParameterApplier methodsFor: 'refactoring - creation' stamp: 'HAW 9/4/2018 15:15:48'! - createRefactoring - - ^self refactoringClass named: parameterToRemove from: originalMethod implementors: implementors senders: senders ! ! -!RemoveParameterApplier methodsFor: 'refactoring - creation' stamp: 'HAW 9/4/2018 15:15:00'! - refactoringClass - - ^RemoveParameter! ! -!RemoveParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 9/4/2018 15:30:50'! - askParameterToRemove - - | methodNode parameterNames | - - originalMethod := implementingClass compiledMethodAt: oldSelector. - methodNode := originalMethod methodNode. - parameterNames := methodNode argumentNames. - - parameterNames size = 1 - ifTrue: [ parameterToRemove := parameterNames first ] - ifFalse: [ parameterToRemove := self selectParameterToRemoveForm: parameterNames ]. - - ! ! -!RemoveParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 1/3/2019 08:01:51'! - requestRefactoringParameters - - self askParameterToRemove - - ! ! -!RemoveParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 9/4/2018 15:36:30'! - selectParameterToRemoveForm: parameterNames - - | parameterIndex | - - parameterIndex := (PopUpMenu labelArray: parameterNames) startUpWithCaption: 'Select parameter to remove'. - parameterIndex = 0 ifTrue: [self endRequest ]. - - ^parameterNames at: parameterIndex.! ! -!RemoveParameterApplier class methodsFor: 'pre-conditions' stamp: 'HAW 9/4/2018 15:17:09'! - assertCanApplyRefactoringFor: aSelector in: aClass - - RemoveParameter assertCanRemoveParameterFrom: aSelector. - - - ! ! -!RenameSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 6/5/2017 17:02:06'! - askNewSelector - - | enteredString | - - enteredString := self request: 'Enter new selector:' initialAnswer: oldSelector. - newSelector := enteredString withBlanksTrimmed asSymbol. - -! ! -!RenameSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/18/2018 16:56:24'! - assertCanRenameSelector - - self refactoringClass assertIsValidToRenameFrom: oldSelector to: newSelector. - ! ! -!RenameSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 1/3/2019 08:02:00'! - requestRefactoringParameters - - self - askNewSelector; - assertCanRenameSelector - ! ! -!RenameSelectorApplier methodsFor: 'refactoring - creation' stamp: 'HAW 8/18/2018 16:56:24'! - createRefactoring - - ^self refactoringClass from: oldSelector to: newSelector implementors: implementors senders: senders. - ! ! -!RenameSelectorApplier methodsFor: 'refactoring - creation' stamp: 'HAW 8/18/2018 17:04:02'! - refactoringClass - - ^RenameSelector ! ! -!RenameSelectorApplier class methodsFor: 'pre-conditions' stamp: 'HAW 8/18/2018 17:24:18'! - assertCanApplyRefactoringFor: aSelector in: aClass - - ! ! -!InsertSuperclassApplier methodsFor: 'initialization' stamp: 'FJG 8/5/2018 22:31:03'! - initializeOn: aBrowser for: aClass - browser _ aBrowser. - classToRefactor _ aClass.! ! -!InsertSuperclassApplier methodsFor: 'refactoring - parameters request' stamp: 'FJG 8/5/2018 22:31:31'! - askNewSuperclassName - newSuperclassName _ self - request: 'Enter new superclass name:'. - newSuperclassName _ newSuperclassName withBlanksTrimmed asSymbol.! ! -!InsertSuperclassApplier methodsFor: 'refactoring - parameters request' stamp: 'FJG 8/5/2018 22:29:07'! - requestRefactoringParameters - - self askNewSuperclassName! ! -!InsertSuperclassApplier methodsFor: 'refactoring - creation' stamp: 'HAW 8/13/2018 15:55:10'! - createRefactoring - - ^InsertSuperclass to: classToRefactor named: newSuperclassName! ! -!InsertSuperclassApplier methodsFor: 'refactoring - changes' stamp: 'FJG 8/5/2018 22:33:49'! - showChanges - - browser changed: #classList. -! ! -!InsertSuperclassApplier class methodsFor: 'instance creation' stamp: 'FJG 8/5/2018 22:27:02'! - on: aBrowser for: aClass - - ^self new initializeOn: aBrowser for: aClass! ! -!RemoveAllUnreferencedInstanceVariablesApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/2/2018 16:11:13'! - requestRefactoringParameters - - ! ! -!RemoveAllUnreferencedInstanceVariablesApplier methodsFor: 'refactoring - creation' stamp: 'HAW 8/2/2018 16:15:05'! - createRefactoring - - ^RemoveAllUnreferencedInstanceVariables from: classToRefactor ! ! -!RemoveAllUnreferencedInstanceVariablesApplier methodsFor: 'refactoring - changes' stamp: 'HAW 1/7/2019 14:42:50'! - informChangesToBrowser - - browser acceptedContentsChanged! ! -!RemoveAllUnreferencedInstanceVariablesApplier methodsFor: 'refactoring - changes' stamp: 'HAW 8/2/2018 16:20:16'! - showChanges - - | removedInstanceVariablesMessage | - - self informChangesToBrowser. - removedInstanceVariablesMessage := changes isEmpty - ifTrue: [ 'No instance variable was removed' ] - ifFalse: [ changes size = 1 - ifTrue: [ changes first, ' was removed' ] - ifFalse: [ changes asCommaStringAnd, ' were removed' ]]. - - self inform: removedInstanceVariablesMessage! ! -!RemoveAllUnreferencedInstanceVariablesApplier methodsFor: 'initialization' stamp: 'HAW 1/7/2019 14:42:41'! -initializeOn: aBrowser for: aClassToRefactor - - browser := aBrowser. - classToRefactor := aClassToRefactor ! ! -!RemoveAllUnreferencedInstanceVariablesApplier class methodsFor: 'instance creation' stamp: 'HAW 1/7/2019 14:42:34'! - on: aBrowser for: aClassToRefactor - - ^self new initializeOn: aBrowser for: aClassToRefactor -! ! -!RemoveInstanceVariableApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/30/2017 18:22:28'! - chooseInstanceVariable - - classToRefactor - chooseDefiningInstanceVariableAlphabeticallyWith: self selectVariableLabel - thenDo: [ :aVariableToRemove | ^variableToRemove := aVariableToRemove ]. - self endRequest - - ! ! -!RemoveInstanceVariableApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 6/17/2017 19:51:21'! - requestRefactoringParameters - - self chooseInstanceVariable. - - ! ! -!RemoveInstanceVariableApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/30/2017 18:22:41'! - selectVariableLabel - - ^'Select instance variable to remove'! ! -!RemoveInstanceVariableApplier methodsFor: 'refactoring - creation' stamp: 'HAW 6/17/2017 19:50:03'! - createRefactoring - - ^RemoveInstanceVariable named: variableToRemove from: classToRefactor ! ! -!RemoveInstanceVariableApplier methodsFor: 'refactoring - changes' stamp: 'HAW 1/7/2019 14:43:43'! - informChangesToBrowser - - browser acceptedContentsChanged! ! -!RemoveInstanceVariableApplier methodsFor: 'refactoring - changes' stamp: 'HAW 6/17/2017 19:50:31'! - showChanges - - self informChangesToBrowser! ! -!RemoveInstanceVariableApplier methodsFor: 'initialization' stamp: 'HAW 1/7/2019 14:43:37'! - initializeOn: aBrowser for: aClassToRefactor - - browser := aBrowser. - classToRefactor := aClassToRefactor ! ! -!RemoveInstanceVariableApplier class methodsFor: 'instance creation' stamp: 'HAW 1/7/2019 14:43:28'! - on: aBrowser for: aClassToRefactor - - ^self new initializeOn: aBrowser for: aClassToRefactor -! ! -!RenameClassApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 6/5/2017 16:02:13'! - askNewClassName - - newClassName := self request: 'Enter new name:' initialAnswer: classToRename name. - newClassName := newClassName withBlanksTrimmed asSymbol. - ! ! -!RenameClassApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 6/5/2017 19:05:08'! - requestRefactoringParameters - - self askNewClassName! ! -!RenameClassApplier methodsFor: 'refactoring - creation' stamp: 'HAW 6/5/2017 18:07:28'! - createRefactoring - - ^RenameClass from: classToRename to: newClassName in: Smalltalk undeclared: Undeclared. - -! ! -!RenameClassApplier methodsFor: 'refactoring - changes' stamp: 'HAW 6/5/2017 16:05:00'! - informChangesToBrowser - - browser changed: #classList. - browser selectClass: classToRename. -! ! -!RenameClassApplier methodsFor: 'refactoring - changes' stamp: 'HAW 6/5/2017 18:08:13'! - openChangedMethods - - changes ifNotEmpty: [ - MessageSetWindow openMessageList: changes label: 'Renamed references' autoSelect: newClassName ] -! ! -!RenameClassApplier methodsFor: 'refactoring - changes' stamp: 'HAW 6/5/2017 18:07:55'! - showChanges - - self - informChangesToBrowser; - openChangedMethods -! ! -!RenameClassApplier methodsFor: 'initialization' stamp: 'HAW 6/5/2017 16:55:57'! - initializeOn: aBrowser for: aClass - - browser := aBrowser. - classToRename := aClass. - ! ! -!RenameClassApplier class methodsFor: 'instance creation' stamp: 'HAW 6/5/2017 12:27:45'! - on: aBrowser for: aClass - - ^self new initializeOn: aBrowser for: aClass! ! -!RenameInstanceVariableApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 6/5/2017 16:49:50'! - askNewVariableName - - newInstanceVariable := self request: 'Enter new name:' initialAnswer: oldInstanceVariable. - newInstanceVariable := newInstanceVariable withBlanksTrimmed ! ! -!RenameInstanceVariableApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 11/28/2018 19:37:54'! - chooseInstanceVariable - - oldInstanceVariable ifNotNil: [ ^self ]. - - classToRefactor - chooseDefiningInstanceVariableAlphabeticallyWith: self selectVariableLabel - thenDo: [ :anOldInstanceVariable | ^oldInstanceVariable := anOldInstanceVariable ]. - self endRequest ! ! -!RenameInstanceVariableApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 6/5/2017 19:05:16'! - requestRefactoringParameters - - self - chooseInstanceVariable; - askNewVariableName! ! -!RenameInstanceVariableApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/30/2017 17:27:22'! - selectVariableLabel - - ^'Select instance variable to rename'! ! -!RenameInstanceVariableApplier methodsFor: 'refactoring - creation' stamp: 'HAW 6/5/2017 18:09:13'! - createRefactoring - - ^RenameInstanceVariable from: oldInstanceVariable to: newInstanceVariable in: classToRefactor. - ! ! -!RenameInstanceVariableApplier methodsFor: 'refactoring - changes' stamp: 'HAW 11/28/2018 19:38:47'! - informChangesToBrowser - - browser acceptedContentsChanged! ! -!RenameInstanceVariableApplier methodsFor: 'refactoring - changes' stamp: 'HAW 8/30/2017 17:30:22'! - openChangedMethods - - changes ifNotEmpty: [ self openChangedMethodsWhenChangesNotEmpty ]! ! -!RenameInstanceVariableApplier methodsFor: 'refactoring - changes' stamp: 'HAW 8/30/2017 17:30:13'! -openChangedMethodsWhenChangesNotEmpty - - MessageSetWindow openMessageList: changes label: 'Renamed references' autoSelect: newInstanceVariable ! ! -!RenameInstanceVariableApplier methodsFor: 'refactoring - changes' stamp: 'HAW 6/5/2017 18:09:30'! - showChanges - - self - informChangesToBrowser; - openChangedMethods ! ! -!RenameInstanceVariableApplier methodsFor: 'initialization' stamp: 'HAW 11/28/2018 19:40:02'! - initializeOn: aBrowserWindow for: anOldInstanceVariable at: aClassToRefactor - - browser := aBrowserWindow. - classToRefactor := aClassToRefactor. - oldInstanceVariable := anOldInstanceVariable ! ! -!RenameInstanceVariableApplier class methodsFor: 'instance creation' stamp: 'HAW 11/29/2018 20:19:06'! - on: aBrowser at: aClassToRefactor - - ^self new initializeOn: aBrowser for: nil at: aClassToRefactor -! ! -!RenameInstanceVariableApplier class methodsFor: 'instance creation' stamp: 'HAW 11/29/2018 20:18:59'! - on: aBrowser for: anInstanceVariableName at: aClassToRefactor - - ^self new initializeOn: aBrowser for: anInstanceVariableName at: aClassToRefactor ! ! -!RenameTemporaryApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 6/25/2017 21:37:58'! - askNewVariableName - - newVariable := (self request: 'Enter new name:' initialAnswer: oldVariable) withBlanksTrimmed ! ! -!RenameTemporaryApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 11/28/2018 19:42:45'! - chooseTemporaryVariable - - | variables | - - oldVariable ifNotNil: [ ^self ]. - - variables := methodNode tempNames. - variables isEmpty - ifTrue: [ self noTemporaryToRename ] - ifFalse: [ self chooseTemporaryVariableFrom: variables ] - - ! ! -!RenameTemporaryApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 10/4/2017 17:15:17'! - chooseTemporaryVariableFrom: variables - - | selection | - - selection := smalltalkEditor selection string withBlanksTrimmed. - oldVariable := (self is: selection temporaryVariableFrom: variables) - ifTrue: [ selection ] - ifFalse: [ self selectTemporaryVariableFrom: variables]! ! -!RenameTemporaryApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 10/4/2017 17:13:25'! - is: selection temporaryVariableFrom: variables - - ^smalltalkEditor hasSelection and: [variables includes: selection]! ! -!RenameTemporaryApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 10/4/2017 17:09:43'! - noTemporaryToRename - - self inform: 'There are no temporary to rename'. - self endRequest ! ! -!RenameTemporaryApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 6/25/2017 21:29:58'! - requestRefactoringParameters - - self - chooseTemporaryVariable; - askNewVariableName! ! -!RenameTemporaryApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 10/4/2017 17:16:25'! -selectTemporaryVariableFrom: variables - - | selectionIndex | - - selectionIndex := (PopUpMenu labelArray: variables lines: #()) startUpWithCaption: 'Select temporary to rename'. - - ^selectionIndex = 0 - ifTrue: [ self endRequest ] - ifFalse: [ variables at: selectionIndex ]! ! -!RenameTemporaryApplier methodsFor: 'refactoring - creation' stamp: 'HAW 6/25/2017 21:54:40'! - createRefactoring - - ^RenameTemporary from: oldVariable to: newVariable in: methodNode - ! ! -!RenameTemporaryApplier methodsFor: 'initialization' stamp: 'HAW 11/28/2018 19:43:15'! - initializeOn: aSmalltalkEditor for: aTemporary - - smalltalkEditor := aSmalltalkEditor. - classToRefactor := smalltalkEditor codeProvider selectedClassOrMetaClass. - methodNode := classToRefactor methodNodeFor: smalltalkEditor actualContents string. - oldVariable := aTemporary - ! ! -!RenameTemporaryApplier methodsFor: 'refactoring - changes' stamp: 'HAW 8/9/2018 19:43:41'! - showChanges - - smalltalkEditor actualContents: changes. - smalltalkEditor hasUnacceptedEdits ifFalse: [ - smalltalkEditor - hasUnacceptedEdits: true; - acceptContents ] - ! ! -!RenameTemporaryApplier class methodsFor: 'exceptions' stamp: 'HAW 10/4/2017 17:05:53'! - errorMessageForCanNotParseMethod: anError - - ^ String streamContents: [ :stream | - stream - nextPutAll: 'Method can not be parsed due to:'; - newLine; - nextPutAll: anError messageText ]! ! -!RenameTemporaryApplier class methodsFor: 'instance creation' stamp: 'HAW 11/28/2018 19:44:13'! - on: aSmalltalkEditor for: aTemporary - - ^self new initializeOn: aSmalltalkEditor for: aTemporary! ! -!SafelyRemoveClassApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/1/2018 16:54:40'! - confirmationMessageText - - ^'Are you sure you want to remove ', classToRemove name asString, '?'! ! -!SafelyRemoveClassApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/1/2018 16:52:57'! - requestRefactoringParameters - - (self confirm: self confirmationMessageText) ifFalse: [ self endRequest ]. - - ! ! -!SafelyRemoveClassApplier methodsFor: 'refactoring - creation' stamp: 'HAW 8/1/2018 16:54:33'! - createRefactoring - - ^SafelyRemoveClass of: classToRemove ! ! -!SafelyRemoveClassApplier methodsFor: 'refactoring - changes' stamp: 'HAW 9/14/2018 13:48:37'! - informChangesToBrowser - - browser classListIndex: 0! ! -!SafelyRemoveClassApplier methodsFor: 'refactoring - changes' stamp: 'HAW 9/14/2018 13:47:58'! - showChanges - - self informChangesToBrowser! ! -!SafelyRemoveClassApplier methodsFor: 'initialization' stamp: 'HAW 9/14/2018 13:47:41'! - initializeOn: aBrowser of: aClassToRemove - - browser := aBrowser. - classToRemove := aClassToRemove ! ! -!SafelyRemoveClassApplier class methodsFor: 'instance creation' stamp: 'HAW 9/14/2018 13:47:16'! - on: aBrowser of: aClassToRemove - - ^self new initializeOn: aBrowser of: aClassToRemove ! ! -!RefactoringMenues class methodsFor: 'editor menus' stamp: 'HAW 11/28/2018 20:23:45'! - smalltalkEditorMenuOptions - - ^`{ - { - #itemGroup -> 35. - #itemOrder -> 10. - #label -> 'Rename... (R)'. - #selector -> #contextualRename. - #icon -> #saveAsIcon - } asDictionary - }`! ! -!RefactoringMenues class methodsFor: 'browser menues' stamp: 'HAW 7/7/2018 19:25:26'! - classListMenuOptions - - ^ `{ - { - #itemGroup -> 5. - #itemOrder -> 10. - #label -> 'refactorings...'. - #selector -> #openClassRefactoringMenu. - #icon -> #listAddIcon - } asDictionary. - }`. - ! ! -!RefactoringMenues class methodsFor: 'browser menues' stamp: 'HAW 8/17/2018 17:50:40'! - classRefactoringMenuOptions - - ^ `{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'rename class ...'. - #object -> #model. - #selector -> #renameClass. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'insert superclass ...'. - #object -> #model. - #selector -> #insertSuperclass. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'safely remove class (x)'. - #object -> #model. - #selector -> #safelyRemoveClass. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'add inst var...'. - #selector -> #addInstVar. - #icon -> #listAddIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'rename inst var...'. - #selector -> #renameInstVar. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'remove inst var...'. - #selector -> #removeInstVar. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 40. - #label -> 'remove all unreferenced inst var...'. - #selector -> #removeAllUnreferencedInstVar. - #icon -> #deleteIcon - } asDictionary. - }`. - ! ! -!RefactoringMenues class methodsFor: 'browser menues' stamp: 'HAW 7/7/2018 19:38:01'! - messageListMenuOptions - - ^ `{ - { - #itemGroup -> 5. - #itemOrder -> 10. - #label -> 'refactorings...'. - #selector -> #openMessageRefactoringMenu. - #icon -> #listAddIcon - } asDictionary. - }`. - ! ! -!RefactoringMenues class methodsFor: 'browser menues' stamp: 'HAW 3/6/2019 15:05:24'! -messsageRefactoringMenuOptions - - ^ `{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'rename...'. - #selector -> #renameSelector. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'add parameter...'. - #selector -> #addParameter. - #icon -> #listAddIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'remove parameter...'. - #selector -> #removeParameter. - #icon -> #listRemoveIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'push up'. - #selector -> #pushUpSelector. - #icon -> #goTopIcon - } asDictionary. - }`. - - ! ! -!RefactoringMenues class methodsFor: 'initialization' stamp: 'HAW 12/28/2018 12:51:56'! - initialize - - Editor initialize! ! -!RefactoringMenues class methodsFor: 'shortcuts' stamp: 'HAW 2/4/2019 16:43:23'! - smalltalkEditorCmdShortcutsSpec - - ^#( - #( $R #contextualRename: 'Renames what is under cursor')) -! ! -!RefactoringPrecondition methodsFor: 'exceptions' stamp: 'HAW 3/4/2019 11:48:22'! - refactoringError: aMessage - - Refactoring refactoringError: aMessage.! ! -!RefactoringPrecondition methodsFor: 'warnings' stamp: 'HAW 3/4/2019 13:30:01'! - refactoringWarning: aMessageText - - ^ Refactoring refactoringWarning: aMessageText ! ! -!NewClassPrecondition methodsFor: 'evaluating' stamp: 'HAW 3/3/2019 09:18:10'! - value - - self assertNewClassNameIsNotEmpty. - self assertNewClassNameSymbol. - self assertNewClassNameStartsWithUppercaseLetter. - self assertNewClassNameHasNoSeparators. - self assertNewClassNameDoesNotExistInSystem. - self assertNewClassNameIsNotUndeclaredInUndeclared. - -! ! -!NewClassPrecondition methodsFor: 'evaluating - private' stamp: 'HAW 3/4/2019 11:55:05'! - assertNewClassNameDoesNotExistInSystem - - system at: newClassName ifPresent: [ :value | - value isBehavior - ifTrue: [ self signalClassAlreadyExists] - ifFalse: [ self signalGlobalAlreadyExists]].! ! -!NewClassPrecondition methodsFor: 'evaluating - private' stamp: 'HAW 3/4/2019 11:50:39'! - assertNewClassNameHasNoSeparators - - (newClassName anySatisfy: [:aChar | aChar isSeparator]) - ifTrue: [ self signalNewClassNameCanNotHaveSeparators]! ! -!NewClassPrecondition methodsFor: 'evaluating - private' stamp: 'HAW 3/4/2019 11:50:43'! - assertNewClassNameIsNotEmpty - - newClassName withBlanksTrimmed isEmpty ifTrue: [ self signalNewClassNameCanNotBeEmpty]! ! -!NewClassPrecondition methodsFor: 'evaluating - private' stamp: 'HAW 3/4/2019 11:55:23'! - assertNewClassNameIsNotUndeclaredInUndeclared - - (undeclared includesKey: newClassName) ifTrue: [ self signalNewClassIsUndeclared]! ! -!NewClassPrecondition methodsFor: 'evaluating - private' stamp: 'HAW 3/4/2019 11:50:51'! - assertNewClassNameStartsWithUppercaseLetter - - newClassName first isUppercase ifFalse: [ self signalNewNameMustStartWithUppercaseLetter]! ! -!NewClassPrecondition methodsFor: 'evaluating - private' stamp: 'HAW 3/4/2019 11:50:55'! - assertNewClassNameSymbol - - newClassName isSymbol ifFalse: [ self signalNewNameMustBeSymbol]! ! -!NewClassPrecondition methodsFor: 'initialization' stamp: 'HAW 8/13/2018 16:00:19'! - initializeFor: aNewClassName in: aSystem undeclared: anUndeclaredDictionary - - newClassName := aNewClassName. - system := aSystem. - undeclared := anUndeclaredDictionary ! ! -!NewClassPrecondition methodsFor: 'exceptions' stamp: 'HAW 3/4/2019 11:54:34'! - signalClassAlreadyExists - - self refactoringError: (self class errorMessageForAlreadyExistClassNamed: newClassName).! ! -!NewClassPrecondition methodsFor: 'exceptions' stamp: 'HAW 3/4/2019 11:55:05'! - signalGlobalAlreadyExists - - self refactoringError: (self class errorMessageForAlreadyExistGlobalNamed: newClassName)! ! -!NewClassPrecondition methodsFor: 'exceptions' stamp: 'HAW 3/4/2019 11:55:23'! - signalNewClassIsUndeclared - - self refactoringError: (self class errorMessageForNewClassIsUndeclared: newClassName).! ! -!NewClassPrecondition methodsFor: 'exceptions' stamp: 'HAW 3/4/2019 11:52:08'! - signalNewClassNameCanNotBeEmpty - - self refactoringError: self class newClassNameCanNotBeEmptyErrorMessage! ! -!NewClassPrecondition methodsFor: 'exceptions' stamp: 'HAW 3/4/2019 11:52:13'! - signalNewClassNameCanNotHaveSeparators - - self refactoringError: self class newClassNameCanNotHaveSeparatorsErrorMessage ! ! -!NewClassPrecondition methodsFor: 'exceptions' stamp: 'HAW 3/4/2019 11:52:17'! - signalNewNameMustBeSymbol - - self refactoringError: self class newNameMustBeSymbolErrorMessage.! ! -!NewClassPrecondition methodsFor: 'exceptions' stamp: 'HAW 3/4/2019 11:52:22'! - signalNewNameMustStartWithUppercaseLetter - - self refactoringError: self class newNameMustStartWithUppercaseLetterErrorMessage.! ! -!NewClassPrecondition class methodsFor: 'error messages' stamp: 'HAW 12/13/2018 17:56:51'! - errorMessageForAlreadyExistClassNamed: aNewClassName - - ^'Class named ', aNewClassName, ' already exist'! ! -!NewClassPrecondition class methodsFor: 'error messages' stamp: 'HAW 12/13/2018 17:59:02'! - errorMessageForAlreadyExistGlobalNamed: aNewClassName - - ^'There is already a global variable named ', aNewClassName ! ! -!NewClassPrecondition class methodsFor: 'error messages' stamp: 'HAW 8/13/2018 15:58:18'! - errorMessageForNewClassIsUndeclared: aNewClassName - - ^aNewClassName, ' is undeclared'! ! -!NewClassPrecondition class methodsFor: 'error messages' stamp: 'HAW 8/13/2018 15:58:18'! - newClassNameCanNotBeEmptyErrorMessage - - ^'New class name can not be empty'! ! -!NewClassPrecondition class methodsFor: 'error messages' stamp: 'HAW 3/3/2019 09:20:59'! - newClassNameCanNotHaveSeparatorsErrorMessage - - ^'New class name can not have separators'! ! -!NewClassPrecondition class methodsFor: 'error messages' stamp: 'HAW 8/13/2018 15:58:18'! - newNameMustBeSymbolErrorMessage - - ^'New class name must be a symbol'! ! -!NewClassPrecondition class methodsFor: 'error messages' stamp: 'HAW 8/13/2018 15:58:18'! - newNameMustStartWithUppercaseLetterErrorMessage - - ^'New class name must start with an uppercase letter'! ! -!NewClassPrecondition class methodsFor: 'instance creation' stamp: 'HAW 8/13/2018 17:31:51'! - for: aNewClassName in: aSystem undeclared: anUndeclaredDictionary - - ^self new initializeFor: aNewClassName in: aSystem undeclared: anUndeclaredDictionary -! ! -!NewClassPrecondition class methodsFor: 'evaluation' stamp: 'HAW 8/13/2018 17:37:20'! - valueFor: aNewClassName in: aSystem undeclared: anUndeclaredDictionary - - ^(self for: aNewClassName in: aSystem undeclared: anUndeclaredDictionary) value! ! -!NewInstanceVariablePrecondition methodsFor: 'initialization' stamp: 'HAW 3/3/2019 08:10:58'! - initializeOf: anInstanceVariableName for: aClass - - instVarName := anInstanceVariableName withBlanksTrimmed. - classToAddInstVar := aClass.! ! -!NewInstanceVariablePrecondition methodsFor: 'evaluating' stamp: 'HAW 3/3/2019 08:30:12'! - value - - self assertIsNotEmpty. - self assertIsNotAReservedName. - self assertIsValidInstanceVariableName. - self assertIsNotAlreadyDefined. - - self warnIfIsDefinedInMethods.! ! -!NewInstanceVariablePrecondition methodsFor: 'pre-conditions' stamp: 'HAW 3/3/2019 08:36:05'! - assertIsNotAReservedName - - (ClassBuilder reservedNames includes: instVarName) ifTrue: [ self signalNewInstanceVariableCanNotBeAReservedName ]! ! -!NewInstanceVariablePrecondition methodsFor: 'pre-conditions' stamp: 'HAW 3/3/2019 08:35:12'! - assertIsNotAlreadyDefined - - ^ classToAddInstVar - withClassesThatDefineInHierarchyInstanceVariable: instVarName - do: [ :definingClasses | self signalAlreadyDefinedInAll: definingClasses ] - ifNone: [ ].! ! -!NewInstanceVariablePrecondition methodsFor: 'pre-conditions' stamp: 'FGJ 12/17/2018 15:29:44'! - assertIsNotEmpty - - instVarName isEmpty ifTrue: [ self signalNewVariableCanNotBeEmpty]! ! -!NewInstanceVariablePrecondition methodsFor: 'pre-conditions' stamp: 'HAW 3/3/2019 08:34:17'! - assertIsValidInstanceVariableName - - | scannedNames | - - scannedNames := Scanner new scanFieldNames: instVarName . - scannedNames size = 1 ifFalse: [ self signalInvalidInstanceVariable ]. - scannedNames first = instVarName ifFalse: [ self signalInvalidInstanceVariable ].! ! -!NewInstanceVariablePrecondition methodsFor: 'exceptions' stamp: 'HAW 3/3/2019 08:35:12'! - signalAlreadyDefinedInAll: classes - - ^ self refactoringError: (self class errorMessageForNewInstanceVariable: instVarName alreadyDefinedInAll: classes).! ! -!NewInstanceVariablePrecondition methodsFor: 'exceptions' stamp: 'HAW 3/3/2019 08:34:09'! - signalInvalidInstanceVariable - - ^ self refactoringError: (self class errorMessageForInvalidInstanceVariable: instVarName).! ! -!NewInstanceVariablePrecondition methodsFor: 'exceptions' stamp: 'HAW 3/3/2019 08:36:00'! - signalNewInstanceVariableCanNotBeAReservedName - - self refactoringError: (self class errorMessageForNewInstanceVariableCanNotBeAReservedName: instVarName)! ! -!NewInstanceVariablePrecondition methodsFor: 'exceptions' stamp: 'FGJ 12/17/2018 16:27:50'! - signalNewVariableCanNotBeEmpty - - self refactoringError: self class newVariableCanNotBeEmptyErrorMessage! ! -!NewInstanceVariablePrecondition methodsFor: 'warnings' stamp: 'HAW 3/3/2019 08:19:24'! - methodsDefiningNewVariable - - | methodsDefiningNewVariableInHierarchy | - - methodsDefiningNewVariableInHierarchy := OrderedCollection new. - - classToAddInstVar withAllSubclassesDo: [ :class | - methodsDefiningNewVariableInHierarchy addAll: (class methodsWithArgumentOrTemporaryNamed: instVarName) ]. - - ^methodsDefiningNewVariableInHierarchy - - ! ! -!NewInstanceVariablePrecondition methodsFor: 'warnings' stamp: 'HAW 3/3/2019 08:13:49'! - warnIfIsDefinedInMethods - - | methodsDefiningNewVariable | - - methodsDefiningNewVariable := self methodsDefiningNewVariable. - - methodsDefiningNewVariable notEmpty ifTrue: [ self warnNewVariable: instVarName willBeHiddenAtAll: methodsDefiningNewVariable ].! ! -!NewInstanceVariablePrecondition methodsFor: 'warnings' stamp: 'FGJ 12/17/2018 16:29:18'! - warnNewVariable: newVariable willBeHiddenAtAll: methods - - ^ self refactoringWarning: (self class warningMessageForNewVariable: newVariable willBeHiddenAtAll: methods).! ! -!NewInstanceVariablePrecondition class methodsFor: 'instance creation' stamp: 'HAW 3/3/2019 08:10:58'! - of: anInstanceVariableName for: aClass - - ^self new initializeOf: anInstanceVariableName for: aClass ! ! -!NewInstanceVariablePrecondition class methodsFor: 'error messages' stamp: 'FGJ 12/17/2018 16:27:09'! - errorMessageForInvalidInstanceVariable: aName - - ^ '''' , aName , ''' is not a valid instance variable name'.! ! -!NewInstanceVariablePrecondition class methodsFor: 'error messages' stamp: 'FGJ 12/17/2018 16:28:18'! - errorMessageForNewInstanceVariable: aName alreadyDefinedInAll: classes - - ^ 'Instance variable ''' , aName , ''' is already defined in ' , classes asCommaStringAnd.! ! -!NewInstanceVariablePrecondition class methodsFor: 'error messages' stamp: 'HAW 3/3/2019 08:32:29'! - errorMessageForNewInstanceVariableCanNotBeAReservedName: aName - - ^'''', aName, ''' can not be used as instance variable name because it is a reserved name'! ! -!NewInstanceVariablePrecondition class methodsFor: 'error messages' stamp: 'FGJ 12/17/2018 16:05:38'! - newVariableCanNotBeEmptyErrorMessage - - ^'New variable can not be empty'! ! -!NewInstanceVariablePrecondition class methodsFor: 'warning messages' stamp: 'HAW 3/3/2019 08:27:30'! - warningMessageForNewVariable: newVariable willBeHiddenAtAll: methods - - ^String streamContents: [ :stream | - stream - nextPutAll: newVariable; - nextPutAll: ' will be hidden at '. - methods asCommaSeparated: [:aMethod | aMethod printClassAndSelectorOn: stream ] on: stream ]! ! -!NewInstanceVariablePrecondition class methodsFor: 'evaluating' stamp: 'HAW 3/3/2019 10:06:23'! - valueOf: anInstanceVariableName for: aClass - - ^(self of: anInstanceVariableName for: aClass) value! ! - -RefactoringMenues initialize! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3638-Refactorings-HernanWilkinson-2019Mar07-09h40m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3639] on 4 March 2019 at 4:23:49 pm'! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:56:13'! - withParseNodeIncluding: aPosition do: aBlock ifAbsent: anAbsentBlock - - | nodeAndPosition | - - nodeAndPosition :=self parseNodeIncluding: aPosition ifAbsent: [ ^ anAbsentBlock value ]. - ^aBlock value: nodeAndPosition key.! ! -!CodeProvider methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:52:13'! - isEditingMethod - - ^false! ! -!Browser methodsFor: 'refactorings' stamp: 'HAW 3/4/2019 16:02:28'! -insertSuperclass - - self selectedClassOrMetaClass ifNotNil: [ :aBehavior | - (InsertSuperclassApplier on: self for: aBehavior theNonMetaClass) value ].! ! -!Browser methodsFor: 'refactorings' stamp: 'HAW 3/4/2019 16:02:36' prior: 16791771! - removeClass - - self safelyRemoveClass ! ! -!Browser methodsFor: 'refactorings' stamp: 'HAW 3/4/2019 16:02:38' prior: 16791778! - renameClass - - self selectedClassOrMetaClass ifNotNil: [ :aBehavior | - (RenameClassApplier on: self for: aBehavior theNonMetaClass) value ].! ! -!Browser methodsFor: 'refactorings' stamp: 'HAW 3/4/2019 16:02:41'! - safelyRemoveClass - - self selectedClassOrMetaClass ifNotNil: [ :aBehavior | - (SafelyRemoveClassApplier on: self of: aBehavior theNonMetaClass) value ].! ! -!Browser methodsFor: 'testing' stamp: 'HAW 3/4/2019 16:02:31'! - isEditingMethod - - ^editSelection = #editMessage or: [ editSelection = #newMessage ] -! ! -!MessageSet methodsFor: 'message list' stamp: 'HAW 3/4/2019 16:11:56'! - addMethodReference: aMethodReferenceToAdd ifIncluded: aBlockClosure - - (messageList includes: aMethodReferenceToAdd) - ifTrue: aBlockClosure - ifFalse: [ self addMethodReference: aMethodReferenceToAdd ]! ! -!MessageSet methodsFor: 'message list' stamp: 'HAW 3/4/2019 16:11:51' prior: 16869941! - removeMessageFromBrowser - "Remove the selected message from the browser." - - self removeMessageFromBrowserKeepingLabel. - self changed: #relabel! ! -!MessageSet methodsFor: 'message list' stamp: 'HAW 3/4/2019 16:11:48'! - removeMessageFromBrowserKeepingLabel - - selectedMessage ifNil: [ ^nil ]. - self deleteFromMessageList: self selection. - self reformulateList. -! ! -!Debugger methodsFor: 'testing' stamp: 'HAW 3/4/2019 16:05:01'! - isEditingMethod - - ^true! ! -!UndefinedObject methodsFor: 'accessing instances and variables' stamp: 'HAW 3/4/2019 15:18:06'! - whichClassDefinesInstanceVariable: aVariable ifNone: aNoneBlock - - ^aNoneBlock value! ! -!Behavior methodsFor: 'accessing method dictionary' stamp: 'HAW 3/4/2019 15:19:49'! - methodsSelect: aCondition - - ^ self methodDict valuesSelect: aCondition! ! -!Behavior methodsFor: 'accessing method dictionary' stamp: 'HAW 3/4/2019 15:20:07'! - methodsWithArgumentOrTemporaryNamed: instVarName - - ^self methodsSelect: [:aMethod | aMethod hasArgumentOrTemporary: instVarName ]! ! -!Behavior methodsFor: 'accessing method dictionary' stamp: 'HAW 3/4/2019 15:20:45'! - withSuperclassThatIncludesSelector: aSelector do: aFoundClosure ifNone: aNoneClosure - - ^superclass - ifNil: aNoneClosure - ifNotNil: [ - (superclass whichClassIncludesSelector: aSelector) - ifNil: aNoneClosure - ifNotNil: aFoundClosure ]! ! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'HAW 3/4/2019 15:18:50'! - definesClassVariableNamedInHierarchy: aClassVariableName - - ^self allClassVarNames includes: aClassVariableName ! ! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'HAW 3/4/2019 15:19:06'! - definesInstanceVariableNamed: anInstanceVariableName - - ^self instVarNames includes: anInstanceVariableName! ! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'HAW 3/4/2019 15:19:30'! - indexOfInstanceVariable: aName - - ^self allInstVarNames indexOf: aName! ! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'HAW 3/4/2019 15:20:24'! - whichClassDefinesInstanceVariable: aVariable ifNone: aNoneBlock - - (self definesInstanceVariableNamed: aVariable) ifTrue: [ ^self ]. - - ^superclass whichClassDefinesInstanceVariable: aVariable ifNone: aNoneBlock! ! -!ClassDescription methodsFor: 'instance variables' stamp: 'HAW 3/4/2019 15:21:47'! - chooseDefiningInstanceVariableAlphabeticallyWith: aCaption thenDo: aBlock - - ^self - chooseDefiningInstanceVariableAlphabeticallyWith: aCaption - thenDo: aBlock - ifNone: [ ^ self inform: 'There are no instance variables defined in ', self name ] ! ! -!ClassDescription methodsFor: 'instance variables' stamp: 'HAW 3/4/2019 15:21:57'! - chooseDefiningInstanceVariableAlphabeticallyWith: aCaption thenDo: aBlock ifNone: noneBlock - - | vars index | - "Put up a menu of the instance variables in the receiver, presented in alphabetical order, and when the user chooses one, evaluate aBlock with the chosen variable as its parameter." - - vars _ self instVarNames sorted. - vars isEmpty ifTrue: [^ noneBlock value ]. - - index _ (PopUpMenu labelArray: vars lines: #()) startUpWithCaption: aCaption. - index = 0 ifTrue: [^ self]. - aBlock value: (vars at: index)! ! -!ClassDescription methodsFor: 'instance variables' stamp: 'HAW 3/4/2019 15:26:00'! - withClassesThatDefineInHierarchyInstanceVariable: aName do: foundBlock ifNone: noneBlock - - ^(self classThatDefinesInstanceVariable: aName) - ifNil: [ self withSubclassesThatDefineInstanceVariable: aName do: foundBlock ifNone: noneBlock ] - ifNotNil: [ :definingClass | foundBlock value: (Array with: definingClass) ]! ! -!ClassDescription methodsFor: 'instance variables' stamp: 'HAW 3/4/2019 15:26:16'! - withSubclassesThatDefineInstanceVariable: aName do: foundBlock ifNone: noneBlock - - | definingSubclasses | - - definingSubclasses := self allSubclasses select: [ :aSubclass | aSubclass definesInstanceVariableNamed: aName ]. - - ^definingSubclasses isEmpty - ifTrue: noneBlock - ifFalse: [ foundBlock value: definingSubclasses ]! ! -!Class methodsFor: 'class name' stamp: 'HAW 3/4/2019 15:27:49' prior: 16802364! - rename: aString - "The new name of the receiver is the argument, aString." - - | newName | - (newName _ aString asSymbol) ~= self name - ifFalse: [^ self]. - (Smalltalk includesKey: newName) - ifTrue: [^ self error: newName , ' already exists']. - (Undeclared includesKey: newName) - ifTrue: [self inform: 'There are references to, ' , aString printString , ' -from Undeclared. Check them after this change.']. - - self safeRenameTo: newName.! ! -!Class methodsFor: 'class name' stamp: 'HAW 3/4/2019 15:27:53'! - safeRenameTo: newName - - Smalltalk renameClass: self as: newName. - name _ newName! ! -!SystemOrganizer methodsFor: 'categories' stamp: 'HAW 3/4/2019 15:58:45'! - hasCategory: aCategory - - ^self categories includes: aCategory ! ! -!SystemOrganizer methodsFor: 'categories' stamp: 'HAW 3/4/2019 15:58:48'! - removeSystemCategories: categories - - (self superclassOrderInAll: categories) reverseDo: [ :class | class removeFromSystem]. - - categories do: [ :aCategory | self removeCategory: aCategory]. -! ! -!SystemOrganizer methodsFor: 'categories' stamp: 'HAW 3/4/2019 15:58:52'! - superclassOrderInAll: categories - - | classes | - - classes := OrderedCollection new. - categories do: [ :aCategory | classes addAll: (self classesAt: aCategory)]. - - ^Array streamContents: [ :stream | Smalltalk hierarchySorted: classes do: [ :aClass | stream nextPut: aClass ]].! ! -!Number methodsFor: 'intervals' stamp: 'HAW 3/4/2019 15:29:17'! - toSelfPlus: aDelta - - ^self to: self + aDelta! ! -!Collection methodsFor: 'converting' stamp: 'HAW 3/4/2019 15:36:16'! - as: aPrintingBlock on: aStream delimiter: delimiter last: lastDelimiter - - | position selfSize | - - position := 1. - selfSize := self size. - - self - do: [:elem | - position := position + 1. - aPrintingBlock value: elem ] - separatedBy: [ - aStream nextPutAll: (position = selfSize ifTrue: [lastDelimiter] ifFalse: [delimiter])]! ! -!Collection methodsFor: 'converting' stamp: 'HAW 3/4/2019 15:36:31'! - asCommaSeparated: aPrintingBlock on: aStream - - ^self as: aPrintingBlock on: aStream delimiter: ', ' last: ' and '! ! -!Collection methodsFor: 'converting' stamp: 'HAW 3/4/2019 15:37:03'! - asCommaStringAnd - - ^String streamContents: [:stream | self asStringOn: stream delimiter: ', ' last: ' and ']! ! -!Collection methodsFor: 'converting' stamp: 'HAW 3/4/2019 15:37:18'! - asStringOn: aStream delimiter: delimString last: lastDelimString - - self as: [ :elem | aStream nextPutAll: elem asString ] on: aStream delimiter: delimString last: lastDelimString! ! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'HAW 3/4/2019 15:38:35'! - intervalOfSubCollection: aSubCollectionToFind - - | startingIndex | - - startingIndex := self indexOfSubCollection: aSubCollectionToFind startingAt: 1. - - ^startingIndex toSelfPlus: aSubCollectionToFind size! ! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'HAW 3/4/2019 15:37:58' prior: 50434267! - with: otherCollection do: twoArgBlock separatedBy: separatorBlock - - | beforeFirst | - - beforeFirst := true. - self with: otherCollection do: [ :selfElement :otherCollectionElement | - beforeFirst - ifTrue: [beforeFirst := false] - ifFalse: [separatorBlock value]. - twoArgBlock value: selfElement value: otherCollectionElement ]. - - -! ! -!String methodsFor: 'copying' stamp: 'HAW 3/4/2019 15:30:11'! - copyReplacing: rangesToNewStrings - - ^self class streamContents: [ :replacementStream | self copyReplacing: rangesToNewStrings into: replacementStream ].! ! -!String methodsFor: 'copying' stamp: 'HAW 3/4/2019 15:30:14'! - copyReplacing: rangesToNewStrings into: replacementStream - - | lastFrom | - - lastFrom := rangesToNewStrings inject: 1 into: [ :from :aRangeToNewString | - self - newFromAfterAppending: aRangeToNewString value - into: replacementStream - keepingFrom: from - skipping: aRangeToNewString key ]. - - replacementStream nextPutAll: (self copyFrom: lastFrom to: self size). -! ! -!String methodsFor: 'copying' stamp: 'HAW 3/4/2019 15:30:18'! - copyReplacing: ranges with: newString - - "Ranges must be in order, with first ranges first. If not, result is unexpected - Hernan" - - ^ self class streamContents: [ :replacementStream | self copyReplacing: ranges with: newString into: replacementStream ] - ! ! -!String methodsFor: 'copying' stamp: 'HAW 3/4/2019 15:30:22'! - copyReplacing: ranges with: newString into: replacementStream - - | lastFrom | - - lastFrom := ranges - inject: 1 - into: [ :from :aRange | - self newFromAfterAppending: newString into: replacementStream keepingFrom: from skipping: aRange ]. - - replacementStream nextPutAll: (self copyFrom: lastFrom to: self size).! ! -!String methodsFor: 'copying' stamp: 'HAW 3/4/2019 15:30:28'! - newFromAfterAppending: aNewString into: replacementStream keepingFrom: from skipping: aRange - - replacementStream - nextPutAll: (self copyFrom: from to: aRange first - 1); - nextPutAll: aNewString. - - ^ aRange last + 1! ! -!Symbol class methodsFor: 'instance creation' stamp: 'HAW 3/4/2019 15:31:05'! - fromCollectionOfStrings: aCollectionOfStrings - - ^self newFrom: aCollectionOfStrings concatenation ! ! -!CompiledMethod methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:32:05'! - hasArgumentOrTemporary: aVariable - - | methodNode | - - methodNode := self methodNode. - - ^methodNode tempNames includes: aVariable ! ! -!CompiledMethod methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:33:16'! - readsInstanceVariable: aName - - ^self readsField: (self methodClass indexOfInstanceVariable: aName) ! ! -!CompiledMethod methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:33:41'! - referencesParameterAt: parameterIndex - - | methodNode implementorParameterNodeToRemove parameterRanges | - - methodNode := self methodNode. - implementorParameterNodeToRemove := methodNode arguments at: parameterIndex. - parameterRanges := methodNode positionsForTemporaryVariable: implementorParameterNodeToRemove name ifAbsent: [#()]. - - ^parameterRanges size ~= 1! ! -!CompiledMethod methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:33:58'! - sendsOrRefersTo: aSelector - - ^ (self hasLiteralThorough: aSelector) or: [ self sendsSelector: aSelector ]! ! -!CompiledMethod methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:34:45'! - writesInstanceVariable: aName - - ^self writesField: (self methodClass indexOfInstanceVariable: aName)! ! -!CompiledMethod methodsFor: 'printing' stamp: 'HAW 3/4/2019 15:31:47'! - classAndSelector - - ^String streamContents: [:stream | self printClassAndSelectorOn: stream ]! ! -!CompiledMethod methodsFor: 'printing' stamp: 'HAW 3/4/2019 15:32:47'! - printClassAndSelectorOn: aStream - - aStream - print: self methodClass; - nextPutAll: '>>'; - nextPutAll: self selector storeString! ! -!CompiledMethod methodsFor: 'printing' stamp: 'HAW 3/4/2019 15:32:51' prior: 16819891! - printOn: aStream - "Overrides method inherited from the byte arrayed collection." - - aStream nextPut: $(. - self printClassAndSelectorOn: aStream. - aStream space; nextPut: $". - self printNameOn: aStream. - aStream nextPut: $(; print: self identityHash; nextPut: $); nextPut: $"; nextPut: $)! ! -!CompiledMethod methodsFor: 'source code management' stamp: 'HAW 3/4/2019 15:34:32'! - sourceCode - - "This method is implemented because getSource is not so intuitive - Hernan" - ^self getSource! ! -!MethodDictionary methodsFor: 'enumeration' stamp: 'HAW 3/4/2019 15:35:17'! - valuesSelect: aCondition - - | selected | - - selected := OrderedCollection new. - self valuesDo: [ :aValue | (aCondition value: aValue) ifTrue: [ selected add: aValue ]]. - - ^selected! ! -!Parser class methodsFor: 'parsing' stamp: 'HAW 3/4/2019 15:41:47'! - parse: sourceCode class: aClass - - ^self parse: sourceCode class: aClass noPattern: false! ! -!Parser class methodsFor: 'parsing' stamp: 'HAW 3/4/2019 15:41:50'! -parse: sourceCode class: aClass noPattern: aBoolean - - ^(self new - encoderClass: EncoderForV3PlusClosures; - parse: sourceCode class: aClass noPattern: aBoolean) - sourceText: sourceCode; - yourself! ! -!ParseNode methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:43:27' prior: 50408653! - isInstanceVariableNode - - ^false! ! -!ParseNode methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:43:38' prior: 50408657! - isMessageNamed: aSelector - - ^false! ! -!ParseNode methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:43:50'! - isReturn - - ^false! ! -!ParseNode methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:43:53'! - isTempOrArg - - ^false! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:39:58'! - messageSendKeywordAndParameterPositionsAt: anIndex of: aSelector ifAbsent: aBlock - - | positions | - - positions := sourceRanges keys - select: [ :aParseNode | aParseNode isMessageNamed: aSelector ] - thenCollect: [ :aMessageSendNode | aMessageSendNode keywordAndParameterPositionAt: anIndex encodedWith: self]. - - ^ positions isEmpty - ifTrue: aBlock - ifFalse: [ positions ] - ! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:40:02'! -messageSendKeywordPositionsAt: anIndex of: aSelector ifAbsent: aBlock - - | positions sortedPositions | - - positions := sourceRanges keys - select: [ :aParseNode | aParseNode isMessageNamed: aSelector ] - thenCollect: [ :aMessageSendNode | (aMessageSendNode keywordPositionAt: anIndex) first ]. - - positions isEmpty ifTrue: [ ^aBlock value ]. - sortedPositions := positions asSortedCollection. - - ^sortedPositions ! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:40:05'! - messageSendLastPositionsOf: aSelector ifAbsent: aBlock - - | positions sortedPositions | - - positions := sourceRanges keys - select: [ :aParseNode | aParseNode isMessageNamed: aSelector ] - thenCollect: [ :aMessageSendNode | (sourceRanges at: aMessageSendNode) last ]. - - positions isEmpty ifTrue: [ ^aBlock value ]. - sortedPositions := positions asSortedCollection. - - ^sortedPositions ! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:40:08'! - messageSendSelectorKeywordPositionsOf: aSelector ifAbsent: aBlock - - | ranges sortedRanges | - - ranges := sourceRanges keys - select: [ :aParseNode | aParseNode isMessageNamed: aSelector ] - thenCollect: [ :aMessageSendNode | aMessageSendNode keywordRanges ]. - - ranges isEmpty ifTrue: [ ^aBlock value ]. - sortedRanges := ranges asSortedCollection: [ :left :right | left first first < right first first ]. - - ^sortedRanges ! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:40:12'! - parameterDefinitionPositionFor: aParameterNode - - ^ (self sourceRangeFor: aParameterNode) first! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:40:15'! - positionsForInstanceVariable: aName ifAbsent: aBlock - - ^ self - rangesForVariable: aName - checkingType: [ :variableNode | variableNode isInstanceVariableNode ] - ifAbsent: aBlock ! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:40:19'! - positionsForLiteralNode: aName ifAbsent: aBlock - - | variableNode | - - variableNode := litSet at: aName ifAbsent: [ ^aBlock value ]. - - ^sourceRanges at: variableNode ifAbsent: aBlock! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:40:23'! - positionsForLiteralVariableNode: aName ifAbsent: aBlock - - | variableNode | - - variableNode := litIndSet values detect: [ :aLiteralVariableNode | aLiteralVariableNode name = aName ] ifNone: [ ^aBlock value ]. - - ^sourceRanges at: variableNode ifAbsent: aBlock! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:40:25'! - positionsForTemporaryVariable: aName ifAbsent: aBlock - - ^ self - rangesForVariable: aName - checkingType: [ :variableNode | variableNode isTemp ] - ifAbsent: aBlock ! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:40:29'! - positionsOfLiteralArraysContaining: aSymbol - - | positions | - - positions := OrderedCollection new. - litSet keysAndValuesDo: [ :aLiteral :aLiteralNode | - (aLiteral isArray and: [ aLiteral hasLiteral: aSymbol ]) ifTrue: [ positions addAll: (sourceRanges at: aLiteralNode) ]]. - - ^positions ! ! -!EncoderForV3PlusClosures methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:41:15'! - hasLocalNamed: aName - - ^ scopeTable includesKey: aName ! ! -!LeafNode methodsFor: 'accessing' stamp: 'HAW 3/4/2019 15:44:23'! - key: aKey - - key := aKey ! ! -!VariableNode methodsFor: 'initialization' stamp: 'HAW 3/4/2019 15:51:10'! - nameAndKey: aName - - name := key := aName ! ! -!InstanceVariableNode methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:51:26' prior: 50408735! - isInstanceVariableNode - - ^true! ! -!TempVariableNode methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:51:43'! - isTempOrArg - - ^self isTemp or: [ self isArg ]! ! -!MessageNode methodsFor: 'source ranges' stamp: 'HAW 3/4/2019 15:45:16'! - keywordAndParameterPositionAt: anIndex encodedWith: anEncoder - - | keywordPosition parameterLastPosition | - - keywordPosition := keywordRanges at: anIndex. - parameterLastPosition := anIndex = arguments size - ifTrue: [ (anEncoder sourceRangeFor: self) last ] - ifFalse: [ (keywordRanges at: anIndex + 1) first - 1]. - - ^keywordPosition first to: parameterLastPosition! ! -!MessageNode methodsFor: 'source ranges' stamp: 'HAW 3/4/2019 15:45:19'! - keywordPositionAt: anIndex - - ^keywordRanges at: anIndex ! ! -!MessageNode methodsFor: 'source ranges' stamp: 'HAW 3/4/2019 15:45:22' prior: 50408739! - keywordRanges - - ^keywordRanges! ! -!MessageNode methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:44:44' prior: 50408743! - isMessageNamed: aSelector - - ^aSelector == self selectorSymbol ! ! -!MessageNode methodsFor: 'accessing' stamp: 'HAW 3/4/2019 16:23:43'! - selectorSymbol - - ^selector key! ! -!MethodNode methodsFor: 'accessing' stamp: 'HAW 3/4/2019 15:46:33' prior: 50434951! - argumentNames - - ^arguments collect: [ :anArgumentNode | anArgumentNode name ]! ! -!MethodNode methodsFor: 'accessing' stamp: 'HAW 3/4/2019 15:48:55'! - tempNodes - - ^encoder tempNodes! ! -!MethodNode methodsFor: 'printing' stamp: 'HAW 3/4/2019 15:47:01'! - classAndSelector - - ^self methodClass name, '>>', self selector storeString! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:46:24'! - addPositionTo: symbolPositions of: symbolString inside: literalArrayPosition - - | insidePosition | - - insidePosition := literalArrayPosition first. - [ insidePosition < literalArrayPosition last ] whileTrue: [ - insidePosition := self nextPositionAfterAddPositionTo: symbolPositions of: symbolString startingAt: insidePosition ]. - ! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:48:09'! - messageSendKeywordAndParameterPositionsAt: anIndex of: aSelector ifAbsent: aClosure - - ^encoder messageSendKeywordAndParameterPositionsAt: anIndex of: aSelector ifAbsent: aClosure! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:48:12'! - messageSendKeywordPositionsAt: anIndex of: aSelector ifAbsent: aBlock - - ^encoder messageSendKeywordPositionsAt: anIndex of: aSelector ifAbsent: aBlock - ! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:48:16'! - messageSendLastPositionsOf: aSelector ifAbsent: aBlock - - ^encoder messageSendLastPositionsOf: aSelector ifAbsent: aBlock! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:48:19'! - messageSendSelectorKeywordPositionsOf: aSelector ifAbsent: aBlock - - ^encoder messageSendSelectorKeywordPositionsOf: aSelector ifAbsent: aBlock! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:48:23'! - nextPositionAfterAddPositionTo: symbolPositions of: symbolString startingAt: insidePosition - - | symbolStartPosition nextPosition | - - symbolStartPosition := sourceText indexOfSubCollection: symbolString startingAt: insidePosition. - - symbolStartPosition = 0 - ifTrue: [ nextPosition := SmallInteger maxVal ] - ifFalse: [ - nextPosition := symbolStartPosition + symbolString size. - (sourceText at: nextPosition) tokenish ifFalse: [ symbolPositions add: (symbolStartPosition to: nextPosition - 1) ]]. - - ^nextPosition - - ! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:48:27'! - parameterDefinitionPositionAt: anIndex - - ^encoder parameterDefinitionPositionFor: (arguments at: anIndex)! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:48:30'! - positionsForInstanceVariable: aName ifAbsent: aBlock - - ^encoder positionsForInstanceVariable: aName ifAbsent: aBlock -! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:48:33'! - positionsForLiteralNode: aName ifAbsent: aBlock - - ^encoder positionsForLiteralNode: aName ifAbsent: aBlock -! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:48:36'! - positionsForLiteralVariableNode: aName ifAbsent: aBlock - - ^encoder positionsForLiteralVariableNode: aName ifAbsent: aBlock! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:48:39'! - positionsForTemporaryVariable: aName ifAbsent: aBlock - - ^encoder positionsForTemporaryVariable: aName ifAbsent: aBlock! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:48:42'! - positionsInLiteralArrayOf: aSymbol - - | literalArrayPositions | - - literalArrayPositions := encoder positionsOfLiteralArraysContaining: aSymbol. - - ^self positionsOf: aSymbol printString containedIn: literalArrayPositions. - -! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:48:45'! - positionsOf: symbolString containedIn: literalArrayPositions - - | symbolPositions | - - symbolPositions := OrderedCollection new. - - literalArrayPositions do: [ :literalArrayPosition | self addPositionTo: symbolPositions of: symbolString inside: literalArrayPosition ]. - - ^symbolPositions - - - - -! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:48:48'! - selectorKeywordPositionAt: anIndex - - ^selectorKeywordsRanges at: anIndex! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 3/4/2019 15:48:52'! - selectorKeywordsPositions - - ^selectorKeywordsRanges! ! -!MethodNode methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:47:33'! - hasArgumentOrTemporary: aVariable - - ^self tempNames includes: aVariable! ! -!MethodNode methodsFor: 'testing' stamp: 'HAW 3/4/2019 16:13:33'! - hasLocalNamed: aName - - ^ encoder hasLocalNamed: aName ! ! -!ReturnNode methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:50:43'! - isImplicitSelfReturnIn: aMethodNode - - ^self isReturnSelf and: [ (aMethodNode encoder rawSourceRanges includesKey: expr) not ]! ! -!ReturnNode methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:50:48'! - isReturn - - ^true! ! -!TextEditor methodsFor: 'accessing' stamp: 'HAW 3/4/2019 15:52:45'! - actualContents - - ^model actualContents ! ! -!TextEditor methodsFor: 'accessing' stamp: 'HAW 3/4/2019 15:52:48'! - actualContents: aString - - model actualContents: aString ! ! -!TextEditor methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:53:18'! - hasUnacceptedEdits - - ^morph hasUnacceptedEdits ! ! -!TextEditor methodsFor: 'testing' stamp: 'HAW 3/4/2019 15:53:29'! - hasUnacceptedEdits: aBoolean - - ^morph hasUnacceptedEdits: aBoolean ! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/4/2019 15:57:20'! - contextualRename - - self - withMethodNodeAndClassDo: [ :methodNode :classToRefactor | self contextualRenameOf: methodNode in: classToRefactor] - ifErrorsParsing: [ :anError | morph flash ]. - - ! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/4/2019 15:57:23'! - contextualRename: aKeyboardEvent - - self contextualRename. - ^true! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/4/2019 15:57:26'! - contextualRenameOf: aMethodNode in: aClassToRefactor - - aMethodNode - withParseNodeIncluding: self startIndex - do: [ :nodeUnderCursor | self rename: nodeUnderCursor in: aClassToRefactor ] - ifAbsent: [ - self startIndex <= aMethodNode selectorLastPosition - ifTrue: [ self ifRenameCanBeAppliedDo: [ self renameSelectorFor: aMethodNode selector in: aClassToRefactor ]] - ifFalse: [ morph flash ]] - - -! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/4/2019 15:57:30'! - ifRenameCanBeAppliedDo: aBlock - - ^(self hasUnacceptedEdits or: [morph hasEditingConflicts ]) - ifTrue: [ self inform: 'Rename can not be applied becuase there are unsaved changes' ] - ifFalse: aBlock! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/4/2019 15:57:35'! - rename: aNodeUnderCursor in: aClassToRefactor - - aNodeUnderCursor isTempOrArg ifTrue: [ ^self renameTemporary: aNodeUnderCursor name ]. - - self ifRenameCanBeAppliedDo: [ - aNodeUnderCursor isMessageNode ifTrue: [ ^ self renameSelectorFor: aNodeUnderCursor selector key in: aClassToRefactor ]. - aNodeUnderCursor isInstanceVariableNode ifTrue: [ ^ self renameInstanceVariableOn: self codeProvider for: aNodeUnderCursor name at: aClassToRefactor ]. - aNodeUnderCursor isLiteralVariableNode ifTrue: [ | posibleBehavior | - posibleBehavior := aNodeUnderCursor key value. - posibleBehavior isBehavior ifTrue: [ ^self renameClassOn: self codeProvider for: posibleBehavior theNonMetaClass ]]. - - ^morph flash ]! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/4/2019 15:57:38'! - renameClassOn: aBrowser for: aClassToRefactor - - (RenameClassApplier on: aBrowser for: aClassToRefactor) value! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/4/2019 15:57:41'! - renameInstanceVariableOn: aBrowser for: anInstanceVariableName at: aClassToRefactor - - (RenameInstanceVariableApplier on: aBrowser for: anInstanceVariableName at: aClassToRefactor) value! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/4/2019 15:57:45'! - renameSelectorFor: aSelector in: aClassToRefactor - - RenameSelectorApplier createAndValueHandlingExceptions: [ RenameSelectorApplier on: model textProvider for: aSelector in: aClassToRefactor ]! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/4/2019 15:57:49'! - renameTemporary: aTemporaryName - - self codeProvider isEditingMethod ifTrue: [ | applier | - [ applier := RenameTemporaryApplier on: self for: aTemporaryName ] - on: SyntaxErrorNotification - do: [:anError | ^self inform: (RenameTemporaryApplier errorMessageForCanNotParseMethod: anError) ]. - applier value ]. -! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/4/2019 15:57:52'! - withMethodNodeAndClassDo: aBlock ifErrorsParsing: anErrorBlock - - | class methodNode | - - class := self codeProvider selectedClassOrMetaClass. - methodNode := [ class methodNodeFor: model actualContents ] on: Error do: [ :anError | ^ anErrorBlock value: anError ]. - - ^aBlock value: methodNode value: class.! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 3/4/2019 15:59:35'! - addInstVar - - model selectedClassOrMetaClass ifNotNil: [ :aClass | - (AddInstanceVariableApplier on: model for: aClass) value ].! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 3/4/2019 15:59:38'! - addParameter - - model selectedMessageName ifNotNil: [ :oldSelector | - AddParameterApplier createAndValueHandlingExceptions: [ AddParameterApplier on: model for: oldSelector in: model selectedClassOrMetaClass ]]! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 3/4/2019 15:59:41'! -classRefactoringMenu - - ^DynamicMenuBuilder buildTitled: 'Refactorings' targeting: self collectingMenuOptionsWith: #classRefactoringMenuOptions.! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 3/4/2019 15:59:47'! - messageRefactoringMenu - - ^DynamicMenuBuilder buildTitled: 'Refactorings' targeting: self collectingMenuOptionsWith: #messsageRefactoringMenuOptions.! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 3/4/2019 15:59:50'! - openClassRefactoringMenu - - ^self classRefactoringMenu popUpInWorld! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 3/4/2019 15:59:53'! - openMessageRefactoringMenu - - ^self messageRefactoringMenu popUpInWorld! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 3/4/2019 16:00:10'! - pushUpSelector - - model selectedMessageName ifNotNil: [ :selectedSelector | - (PushUpMethod for: model selectedClassOrMetaClass>>selectedSelector) apply. - model messageListIndex: 0. - model changed: #messageList. - model setClassOrganizer ].! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 3/4/2019 16:00:13'! - removeAllUnreferencedInstVar - - model selectedClassOrMetaClass ifNotNil: [ :aClass | - (RemoveAllUnreferencedInstanceVariablesApplier on: model for: aClass) value ].! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 3/4/2019 16:00:16'! - removeInstVar - - model selectedClassOrMetaClass ifNotNil: [ :aClass | - (RemoveInstanceVariableApplier on: model for: aClass) value ].! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 3/4/2019 16:00:23'! - removeParameter - - model selectedMessageName ifNotNil: [ :oldSelector | - RemoveParameterApplier createAndValueHandlingExceptions: [ - RemoveParameterApplier on: model for: oldSelector in: model selectedClassOrMetaClass ]]! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 3/4/2019 16:00:26'! - renameInstVar - - model selectedClassOrMetaClass ifNotNil: [ :aClass | - (RenameInstanceVariableApplier on: model at: aClass) value ].! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 3/4/2019 16:00:30'! - renameSelector - - model selectedMessageName ifNotNil: [ :oldSelector | - RenameSelectorApplier createAndValueHandlingExceptions: [ RenameSelectorApplier on: model for: oldSelector in: model selectedClassOrMetaClass ]].! ! -!MessageSetWindow class methodsFor: 'opening' stamp: 'HAW 3/4/2019 16:01:36' prior: 16870560! - openFullProtocolForClass: aClass - "Create and schedule a browser for the entire protocol of the class." - "ProtocolBrowser openFullProtocolForClass: ProtocolBrowser." - - | aPBrowser label | - - aPBrowser _ ProtocolBrowser new on: aClass. - label _ 'Entire protocol of: ', aClass name. - - ^self open: aPBrowser label: label! ! -!MessageSetWindow class methodsFor: 'opening' stamp: 'HAW 3/4/2019 16:01:39' prior: 50343735! - openMessageList: anArray label: aString - "Create a standard system view for the message set on the list, anArray. - The label of the view is aString." - - ^self open: (MessageSet messageList: anArray) label: aString! ! -!MessageSetWindow class methodsFor: 'opening' stamp: 'HAW 3/4/2019 16:01:42' prior: 16870583! - openMessageList: messageList label: labelString autoSelect: autoSelectString - "Open a system view for a MessageSet on messageList. - 1/24/96 sw: the there-are-no msg now supplied by my sender" - - | messageSet | - - messageSet _ MessageSet messageList: messageList. - messageSet autoSelectString: autoSelectString. - - ^self open: messageSet label: labelString ! ! -!MessageSetWindow class methodsFor: 'opening' stamp: 'HAW 3/4/2019 16:01:46' prior: 16870597! - openSubProtocolForClass: aClass - "Create and schedule a browser for the entire protocol of the class." - "ProtocolBrowser openSubProtocolForClass: ProtocolBrowser." - - | aPBrowser label | - - aPBrowser _ ProtocolBrowser new onSubProtocolOf: aClass. - label _ 'Sub-protocol of: ', aClass name. - - ^self open: aPBrowser label: label! ! -!ChangeSelector methodsFor: 'create new implementors - private' stamp: 'HAW 3/4/2019 15:24:22' prior: 50438583! - compileNewImplementorOf: anImplementor - - | implementorClassification newSourceCode | - - newSourceCode := self implementorNewSourceCodeOf: anImplementor. - implementorClassification := anImplementor methodClass organization categoryOfElement: oldSelector. - - anImplementor methodClass - compile: newSourceCode - classified: implementorClassification. -! ! -!PushUpMethod methodsFor: 'applying' stamp: 'HAW 3/4/2019 15:23:40' prior: 50440570! - apply - - | methodCategory | - - methodCategory := method methodClass organization categoryOfElement: method selector. - method methodClass superclass - compile: method sourceCode - classified: methodCategory. - - method methodClass removeSelector: method selector. - ! ! - -MethodNode removeSelector: #selectorKeywordsRanges! - -MethodNode removeSelector: #selectorKeywordsRanges! - -ClassDescription removeSelector: #compile:classifyUnder:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3639-Refactorings-part2-HernanWilkinson-2019Mar03-08h04m-HAW.4xx.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3641] on 6 March 2019 at 4:12:06 pm'! -!ProgressiveTestRunner methodsFor: 'evaluating' stamp: 'HAW 3/6/2019 15:35:58' prior: 50338120! - value - - Utilities authorInitials. - testsStream _ ReadStream on: testSuite tests. - testsStream atEnd - ifTrue: [ self informNoTestToRun ] - ifFalse:[ self createProgressBarAndRun ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3640-ProgressiveTestRunner-HernanWilkinson-2019Mar06-15h06m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3637] on 6 March 2019 at 12:20:34 pm'! - -Encoder removeSelector: #bindTemp:in:! - -Encoder removeSelector: #bindTemp:in:! - -Parser removeSelector: #bindTemp:in:! - -Parser removeSelector: #bindTemp:in:! - -Parser removeSelector: #temporariesIn:! - -Parser removeSelector: #temporariesIn:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3641-Cleanup-JuanVuletich-2019Mar06-12h18m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3637] on 6 March 2019 at 12:21:07 pm'! -!Encoder methodsFor: 'encoding' stamp: 'jmv 3/6/2019 12:06:54' prior: 16837538! - undeclared: name - | sym | - requestor interactive ifTrue: [ - ^self notify: 'Undeclared']. - "Allow knowlegeable clients to squash the undeclared warning if they want (e.g. - Diffing pretty printers that are simply formatting text). As this breaks - compilation it should only be used by clients that want to discard the result - of the compilation. To squash the warning use e.g. - [Compiler format: code in: class notifying: nil decorated: false] - on: UndeclaredVariableWarning - do: [:ex| ex resume: false]" - sym := name asSymbol. - ^(UndeclaredVariableWarning new name: name selector: selector class: class) signal - ifTrue: - [Undeclared at: sym put: nil. - self global: (Undeclared associationAt: sym) name: sym] - ifFalse: - [self global: (Association key: sym) name: sym]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3642-Cleanup-JuanVuletich-2019Mar06-12h20m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3639] on 6 March 2019 at 1:08:21 pm'! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'jmv 3/6/2019 13:07:59' prior: 16806925! - printMethodChunk: selector withPreamble: doPreamble on: outStream moveSource: moveSource toFile: fileIndex - "Copy the source code for the method associated with selector onto the fileStream. If moveSource true, then also set the source code pointer of the method." - | preamble method oldPos newPos sourceFile endPos | - doPreamble - ifTrue: [preamble _ self name , ' methodsFor: ' , - (self organization categoryOfElement: selector) asString printString] - ifFalse: [preamble _ '']. - method _ self methodDict at: selector ifAbsent: [ - outStream nextPutAll: selector; newLine. - outStream tab; nextPutAll: '** ERROR - THIS METHOD IS MISSING ** '; newLine; newLine. - outStream nextPutAll: ' '. - ^ outStream]. - - ((method fileIndex = 0 - or: [(SourceFiles at: method fileIndex) == nil]) - or: [(oldPos _ method filePosition) = 0]) - ifTrue: [ - "The source code is not accessible. We must decompile..." - preamble size > 0 ifTrue: [ outStream newLine; nextPut: $!!; nextChunkPut: preamble; newLine]. - outStream nextChunkPut: method decompileString] - ifFalse: [ - sourceFile _ SourceFiles at: method fileIndex. - preamble size > 0 - ifTrue: "Copy the preamble" - [outStream copyPreamble: preamble from: sourceFile at: oldPos] - ifFalse: - [sourceFile position: oldPos]. - "Copy the method chunk" - fileIndex = 0 ifFalse: [ - outStream padTo: SourceFiles pointerScaleForWriting put: $ ]. - newPos _ outStream position. - outStream copyMethodChunkFrom: sourceFile. - moveSource ifTrue: [ "Set the new method source pointer" - endPos _ outStream position. - method checkOKToAdd: endPos - newPos at: newPos in: method fileIndex. - method setSourcePosition: newPos inFile: fileIndex]]. - preamble size > 0 ifTrue: [ outStream nextChunkPut: ' ' ]. - ^ outStream newLine! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3643-BetterMissingMethodText-JuanVuletich-2019Mar06-13h07m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3640] on 7 March 2019 at 12:04:56 pm'! - -Error subclass: #RecompilationFailure - instanceVariableNames: 'class selector' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #RecompilationFailure category: #'Exceptions Kernel'! -Error subclass: #RecompilationFailure - instanceVariableNames: 'class selector' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! -!RecompilationFailure commentStamp: 'jmv 3/7/2019 11:39:10' prior: 0! - Recompilation of some existing method failed. - -The usual handling of this exception should be to cancel the action that triggered recompilation. If not handled, a debugger will open.! -!RecompilationFailure methodsFor: 'accessing' stamp: 'jmv 3/7/2019 12:02:40'! - messageText - ^ 'In method ', class name,'>>', selector asString,' ', messageText! ! -!RecompilationFailure methodsFor: 'private' stamp: 'jmv 3/7/2019 11:28:08'! -class: aClass selector: aSymbol messageText: aString - class _ aClass. - selector _ aSymbol. - messageText _ aString! ! -!RecompilationFailure class methodsFor: 'instance creation' stamp: 'jmv 3/7/2019 11:28:18'! - class: aClass selector: aSymbol messageText: aString - ^ self new class: aClass selector: aSymbol messageText: aString! ! -!Browser methodsFor: '*LiveTyping' stamp: 'jmv 3/7/2019 12:03:38' prior: 16791377! - contents: input notifying: aRequestor - "The retrieved information has changed and its source must now be - updated. The information can be a variety of things, depending on - the list selections (such as templates for class or message definition, - methods) or the user menu commands (such as definition, comment, - hierarchy). Answer the result of updating the source." - - | aString aText theClass | - aString _ input asString. - aText _ input asText. - editSelection == #editSystemCategories ifTrue: [ ^ self changeSystemCategories: aString ]. - editSelection == #editClass | (editSelection == #newClass) ifTrue: [ - [ - self defineClass: aString notifying: aRequestor - ] on: RecompilationFailure do: [ :ex | - self inform: ex messageText. - ^ false]. - ^ true]. - editSelection == #editComment - ifTrue: [ - theClass _ self selectedClass. - theClass - ifNil: [ - self inform: 'You must select a class -before giving it a comment.'. - ^ false]. - theClass comment: aText stamp: Utilities changeStamp. - self changed: #classCommentText. - ^ true]. - editSelection == #hierarchy ifTrue: [ ^ true ]. - editSelection == #editMessageCategories ifTrue: [ ^ self changeMessageCategories: aString ]. - editSelection == #editMessage | (editSelection == #newMessage) - ifTrue: [ - ^ self okayToAccept - ifFalse:[ false ] - ifTrue: [ - (self compileMessage: aText notifying: aRequestor) - ifTrue: [ self triggerEvent: #annotationChanged ]; - yourself ]]. - editSelection == #none - ifTrue: [ - self inform: 'This text cannot be accepted -in this part of the browser.'. - ^ false]. - self error: 'unacceptable accept'! ! -!Encoder methodsFor: 'private' stamp: 'jmv 3/7/2019 12:02:44' prior: 16837633! - warnAboutShadowed: name - | msg fullMsg | - msg _ 'There already exists a variable named ', name, ' '. - fullMsg _ class name,'>>', selector asString, ' ', msg. - requestor addWarning: fullMsg. - Transcript newLine; show: fullMsg. - InMidstOfFileinNotification signal - ifFalse: [ - requestor interactive - ifTrue: [ - self notify: msg] - ifFalse: [ - (RecompilationFailure - class: class - selector: selector - messageText: msg, String newLineString, 'Please use a different name') signal ]]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3644-DontAllowVariableShadowing-JuanVuletich-2019Mar07-11h24m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3645] on 7 March 2019 at 2:53:00 pm'! - -"Change Set: 3645-CuisCore-AuthorName-2019Mar07-13h02m -Date: 7 March 2019 -Author: Hernan Wilkinson -Removes empty categories and recategorized methods -" -MethodReference organization - classify: #printOn: under: 'printing'. -Browser organization - classify: #classDefinitionText under: 'class functions'; - classify: #contents:notifying: under: 'accessing'; - classify: #selectedMessage under: 'message list'. -MessageSet organization - classify: #contents:notifying: under: 'accessing'; - classify: #selectedMessage under: 'message list'. -Debugger organization - classify: #askForSuperclassOf:toImplement:ifCancel: under: 'method creation'. -CompiledMethod organization - classify: #printOn: under: 'printing'. -CodeProvider organization - classify: #isModeStyleable under: 'shout styling'; - classify: #contentsSymbolQuints under: 'controls'. -ProtoObject withAllSubclassesDo: [ :class | class organization removeEmptyCategories ]. -! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3645-MethodRecategorization-HernanWilkinson-2019Mar07-13h02m-HAW.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3645] on 7 March 2019 at 4:30:23 pm'! -!Browser methodsFor: 'class functions' stamp: 'HAW 3/7/2019 16:29:51' prior: 16791532! - classDefinitionText - "return the text to display for the definition of the currently selected class" - - ^self selectedClassOrMetaClass - ifNil: [''] - ifNotNil: [ :theClass | theClass definition]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3646-classDefinition-HernanWilkinson-2019Mar07-14h53m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3645] on 7 March 2019 at 4:44:03 pm'! -!MethodReference methodsFor: 'printing' stamp: 'HAW 3/7/2019 16:41:54'! - printClassAndSelectorOn: aStream - - aStream nextPutAll: classSymbol. - classIsMeta ifTrue: [ aStream nextPutAll: ' class' ]. - aStream - nextPutAll: '>>#'; - nextPutAll: methodSymbol! ! -!MethodReference methodsFor: 'printing' stamp: 'HAW 3/7/2019 16:43:30' prior: 50364601! - printOn: aStream - "Print the receiver on a stream" - - super printOn: aStream. - aStream space. - self printClassAndSelectorOn: aStream! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3647-MethodReferencePrintOn-HernanWilkinson-2019Mar07-16h30m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3647] on 7 March 2019 at 5:16:10 pm'! -!TestSuite class methodsFor: 'instance creation - private' stamp: 'HAW 3/7/2019 17:15:17' prior: 50338298! - forClasses: classes named: aName - - | suite | - - suite _ classes - inject: (self named: aName) - into: [ :partialSuite :aClass | partialSuite addTests: (self forClass: aClass) tests ]. - - ^suite - -! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3648-TestSuiteVarShadowing-HernanWilkinson-2019Mar07-17h04m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3647] on 7 March 2019 at 5:29:58 pm'! -!InsertSuperclass methodsFor: 'applying - private' stamp: 'HAW 3/7/2019 17:28:52'! - changeSuperclassTo: newSuperclass - - newSuperclass subclass: classToRefactor name - instanceVariableNames: classToRefactor instanceVariablesString - classVariableNames: classToRefactor classVariablesString - poolDictionaries: classToRefactor sharedPoolsString - category: classToRefactor category.! ! -!FileList methodsFor: 'volume list and pattern' stamp: 'HAW 3/7/2019 17:27:14' prior: 16842796! - doesPattern: aPattern allow: entry - - ^(aPattern = '*' or: [ aPattern match: entry name ]) and: [ - "Hide Mac resurce forks and folder service stores" - (entry name = '.DS_Store') not and: [ - ('._*' match: entry name) not ]]! ! -!InsertSuperclass methodsFor: 'applying' stamp: 'HAW 3/7/2019 17:29:03' prior: 50440505! - apply - - | newSuperclass | - - newSuperclass := self createSuperclass. - self changeSuperclassTo: newSuperclass. - - ^newSuperclass ! ! - -InsertSuperclass removeSelector: #changeSuperclassOf:to:! - -InsertSuperclass removeSelector: #changeSuperclassOf:to:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3649-MoreVariablesShadowingFixes-HernanWilkinson-2019Mar07-17h16m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3649] on 8 March 2019 at 11:29:51 am'! -!DummyStream methodsFor: 'as yet unclassified' stamp: 'jmv 3/8/2019 10:17:33'! - padToEndIfCantTruncate - "Only makes sense for file streams with existing content."! ! -!Morph methodsFor: 'as yet unclassified' stamp: 'jmv 3/8/2019 11:24:08'! - whenUIinSafeState: evaluableObject - self world - ifNotNil: [ :w | w whenUIinSafeState: evaluableObject ] - ifNil: evaluableObject! ! -!ProgressMorph methodsFor: 'accessing' stamp: 'jmv 3/8/2019 11:29:08'! - updatePositionAndExtent - | h w newExtent | - w _ ((labelMorph measureContents x max: subLabelMorph measureContents x) max: 200) + 8. - h _ labelMorph morphHeight + subLabelMorph morphHeight + progress morphHeight + 10. - newExtent _ w@h. - self world - ifNotNil: [ :world | self morphPosition: world morphExtent - newExtent // 2 extent: newExtent ] - ifNil: [ self morphExtent: newExtent ]! ! -!ProgressMorph methodsFor: 'accessing' stamp: 'jmv 3/8/2019 11:27:03' prior: 16896249! - label: aString subLabel: otherString - self whenUIinSafeState: [ - labelMorph contents: aString. - subLabelMorph contents: otherString. - self updatePositionAndExtent. ]! ! -!ProgressMorph methodsFor: 'accessing' stamp: 'jmv 3/8/2019 11:24:39' prior: 16896255! - subLabel: aString - self whenUIinSafeState: [ - subLabelMorph contents: aString. - self updatePositionAndExtent. ]! ! -!ProgressMorph methodsFor: 'initialization' stamp: 'jmv 3/8/2019 11:18:58' prior: 16896278! - openInWorld: aWorld - "This msg and its callees result in the window being activeOnlyOnTop" - aWorld addMorph: self. - self updatePositionAndExtent. - labelMorph fitContents. - subLabelMorph fitContents. - layoutNeeded _ true.! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3650-CenterProgressMorph-JuanVuletich-2019Mar08-11h16m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3649] on 7 March 2019 at 11:05:12 pm'! -!ExtractToTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 3/7/2019 22:52:44'! - assert: aNewVariable isNotDefinedAsInstanceVariableInHierarchyOf: aClass - - | classDefiningNewVariable | - - classDefiningNewVariable := aClass whichClassDefinesInstanceVariable: aNewVariable ifNone: [ ^self ]. - self signal: aNewVariable canNotHideInstanceVariableDefinedIn: classDefiningNewVariable ! ! -!ExtractToTemporary class methodsFor: 'warnings' stamp: 'HAW 3/7/2019 22:54:39'! - errorMessageFor: aNewVariable canNotBeNamedAsInstanceVariableDefinedIn: aClass - - ^aNewVariable, ' can not be named as instance variable defined in ', aClass name! ! -!ExtractToTemporary class methodsFor: 'warnings' stamp: 'HAW 3/7/2019 22:54:39'! - signal: aNewVariable canNotHideInstanceVariableDefinedIn: aClass - - self refactoringError: (self errorMessageFor: aNewVariable canNotBeNamedAsInstanceVariableDefinedIn: aClass)! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 3/7/2019 22:52:44'! - assert: aNewVariable isNotDefinedAsInstanceVariableInHierarchyOf: aClass - - | classDefiningNewVariable | - - classDefiningNewVariable := aClass whichClassDefinesInstanceVariable: aNewVariable ifNone: [ ^self ]. - self signal: aNewVariable canNotHideInstanceVariableDefinedIn: classDefiningNewVariable ! ! -!RenameTemporary class methodsFor: 'warnings' stamp: 'HAW 3/7/2019 22:54:39'! - errorMessageFor: aNewVariable canNotBeNamedAsInstanceVariableDefinedIn: aClass - - ^aNewVariable, ' can not be named as instance variable defined in ', aClass name! ! -!RenameTemporary class methodsFor: 'warnings' stamp: 'HAW 3/7/2019 22:54:39'! - signal: aNewVariable canNotHideInstanceVariableDefinedIn: aClass - - self refactoringError: (self errorMessageFor: aNewVariable canNotBeNamedAsInstanceVariableDefinedIn: aClass)! ! -!NewInstanceVariablePrecondition methodsFor: 'warnings' stamp: 'HAW 3/7/2019 22:29:07'! - assertIsDefinedInMethods - - | methodsDefiningNewVariable | - - methodsDefiningNewVariable := self methodsDefiningNewVariable. - - methodsDefiningNewVariable notEmpty ifTrue: [ self signalNewVariable: instVarName willBeHiddenAtAll: methodsDefiningNewVariable ].! ! -!NewInstanceVariablePrecondition methodsFor: 'warnings' stamp: 'HAW 3/7/2019 22:29:57'! - signalNewVariable: newVariable willBeHiddenAtAll: methods - - ^ self refactoringError: (self class errorMessageForNewVariable: newVariable willBeHiddenAtAll: methods).! ! -!NewInstanceVariablePrecondition class methodsFor: 'warning messages' stamp: 'HAW 3/7/2019 23:02:55'! - errorMessageForNewVariable: newVariable willBeHiddenAtAll: methods - - ^String streamContents: [ :stream | - stream - nextPutAll: newVariable; - nextPutAll: ' can not be named as temporary/parameter in '. - methods asCommaSeparated: [:aMethod | aMethod printClassAndSelectorOn: stream ] on: stream ]! ! -!ExtractToTemporary class methodsFor: 'instance creation' stamp: 'HAW 3/7/2019 22:51:29' prior: 50440394! - named: aNewVariable at: anIntervalToExtract from: aMethodSourceCode in: aClass - - | trimmedNewVariable parseNodeToExtract trimmedSourceCodeToExtract methodNodeToExtract methodNodeToRefactor sourceCodeToExtract | - - trimmedNewVariable := aNewVariable withBlanksTrimmed. - methodNodeToRefactor := aClass methodNodeFor: aMethodSourceCode. - - self assertIsNotEmpty: trimmedNewVariable. - self assertIsValidVariableName: trimmedNewVariable. - self assert: trimmedNewVariable isNotDefinedIn: methodNodeToRefactor. - - sourceCodeToExtract := aMethodSourceCode copyFrom: anIntervalToExtract first to: anIntervalToExtract last. - trimmedSourceCodeToExtract := sourceCodeToExtract withBlanksTrimmed. - self assertSourceCodeIsNotEmpty: trimmedSourceCodeToExtract. - self assertIsNotReturn: trimmedSourceCodeToExtract. - self assert: trimmedSourceCodeToExtract isIncludedIn: methodNodeToRefactor. - - [ methodNodeToExtract := Parser parse: trimmedSourceCodeToExtract class: methodNodeToRefactor methodClass noPattern: true ] - on: SyntaxErrorNotification - do: [ :anError | self signalColaborationToExtractHasSyntaxError: anError ]. - - parseNodeToExtract := self paseNodeToExtractFrom: methodNodeToExtract. - - self assert: trimmedNewVariable isNotDefinedAsInstanceVariableInHierarchyOf: methodNodeToRefactor methodClass. - - ^self new initializeNamed: trimmedNewVariable with: parseNodeToExtract in: methodNodeToRefactor - - ! ! -!ExtractToTemporary class methodsFor: 'instance creation' stamp: 'HAW 3/7/2019 22:51:29' prior: 50440441! - named: aNewVariable with: aSourceCodeToExtract in: aMethodNodeToRefactor - - | trimmedNewVariable parseNodeToExtract trimmedSourceCodeToExtract methodNodeToExtract | - - trimmedNewVariable := aNewVariable withBlanksTrimmed. - - self assertIsNotEmpty: trimmedNewVariable. - self assertIsValidVariableName: trimmedNewVariable. - self assert: trimmedNewVariable isNotDefinedIn: aMethodNodeToRefactor. - - trimmedSourceCodeToExtract := aSourceCodeToExtract withBlanksTrimmed. - self assertSourceCodeIsNotEmpty: trimmedSourceCodeToExtract. - self assertIsNotReturn: trimmedSourceCodeToExtract. - self assert: trimmedSourceCodeToExtract isIncludedIn: aMethodNodeToRefactor. - - [ methodNodeToExtract := Parser parse: trimmedSourceCodeToExtract class: aMethodNodeToRefactor methodClass noPattern: true ] - on: SyntaxErrorNotification - do: [ :anError | self signalColaborationToExtractHasSyntaxError: anError ]. - - parseNodeToExtract := self paseNodeToExtractFrom: methodNodeToExtract. - - self assert: trimmedNewVariable isNotDefinedAsInstanceVariableInHierarchyOf: aMethodNodeToRefactor methodClass. - - ^self new initializeNamed: trimmedNewVariable with: parseNodeToExtract in: aMethodNodeToRefactor - - ! ! -!RenameTemporary class methodsFor: 'instance creation' stamp: 'HAW 3/7/2019 22:51:29' prior: 50441140! - from: anOldVariable to: aNewVariable in: aMethodNode - - | trimmedNewVariable | - - trimmedNewVariable := aNewVariable withBlanksTrimmed. - - self assert: anOldVariable isDefinedIn: aMethodNode. - self assertIsNotEmpty: trimmedNewVariable. - self assertIsValidVariableName: trimmedNewVariable. - self assert: trimmedNewVariable isNotDefinedIn: aMethodNode. - - self assert: trimmedNewVariable isNotDefinedAsInstanceVariableInHierarchyOf: aMethodNode methodClass. - - ^self new initializeFrom: anOldVariable to: trimmedNewVariable in: aMethodNode -! ! -!NewInstanceVariablePrecondition methodsFor: 'evaluating' stamp: 'HAW 3/7/2019 22:28:38' prior: 50442733! - value - - self assertIsNotEmpty. - self assertIsNotAReservedName. - self assertIsValidInstanceVariableName. - self assertIsNotAlreadyDefined. - - self assertIsDefinedInMethods.! ! - -NewInstanceVariablePrecondition class removeSelector: #warningMessageForNewVariable:willBeHiddenAtAll:! - -NewInstanceVariablePrecondition class removeSelector: #warningMessageForNewVariable:willBeHiddenAtAll:! - -NewInstanceVariablePrecondition removeSelector: #warnIfIsDefinedInMethods! - -NewInstanceVariablePrecondition removeSelector: #warnIfIsDefinedInMethods! - -NewInstanceVariablePrecondition removeSelector: #warnNewVariable:willBeHiddenAtAll:! - -NewInstanceVariablePrecondition removeSelector: #warnNewVariable:willBeHiddenAtAll:! - -RenameTemporary class removeSelector: #errorMessageFor:canNotHideInstanceVariableDefinedIn:! - -RenameTemporary class removeSelector: #warn:willHideInstanceVariableDefinedIn:! - -RenameTemporary class removeSelector: #warn:willHideInstanceVariableDefinedIn:! - -RenameTemporary class removeSelector: #warnIf:isDefinedAsInstanceVariableInHierarchyOf:! - -RenameTemporary class removeSelector: #warnIf:isDefinedAsInstanceVariableInHierarchyOf:! - -RenameTemporary class removeSelector: #warningMessageFor:willHideInstanceVariableDefinedIn:! - -RenameTemporary class removeSelector: #warningMessageFor:willHideInstanceVariableDefinedIn:! - -ExtractToTemporary class removeSelector: #errorMessageFor:canNotHideInstanceVariableDefinedIn:! - -ExtractToTemporary class removeSelector: #warn:willHideInstanceVariableDefinedIn:! - -ExtractToTemporary class removeSelector: #warn:willHideInstanceVariableDefinedIn:! - -ExtractToTemporary class removeSelector: #warnIf:isDefinedAsInstanceVariableInHierarchyOf:! - -ExtractToTemporary class removeSelector: #warnIf:isDefinedAsInstanceVariableInHierarchyOf:! - -ExtractToTemporary class removeSelector: #warningMessageFor:willHideInstanceVariableDefinedIn:! - -ExtractToTemporary class removeSelector: #warningMessageFor:willHideInstanceVariableDefinedIn:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3651-RefactoringFailsWhenHiddingVariable-HernanWilkinson-2019Mar07-22h09m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3651] on 10 March 2019 at 2:42:17 pm'! -!ProgressMorph methodsFor: 'accessing' stamp: 'jmv 3/10/2019 14:41:35' prior: 50444407! - updatePositionAndExtent - | w newExtent | - w _ ((labelMorph measureContents x max: subLabelMorph measureContents x) max: 200) + 8. - newExtent _ w > extent x - ifTrue: [ w+10@(labelMorph morphHeight + subLabelMorph morphHeight + progress morphHeight + 10) ] - ifFalse: [ extent ]. - self world - ifNotNil: [ :world | self morphPosition: world morphExtent - newExtent // 2 extent: newExtent ] - ifNil: [ self morphExtent: newExtent ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3652-CenterProgressMorphTweak-JuanVuletich-2019Mar10-14h26m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3652] on 11 March 2019 at 3:12:20 pm'! -!TestCase methodsFor: 'assertions' stamp: 'jmv 3/11/2019 15:05:47'! - shouldFix: aBlock - "Currently disable execution on a Block. - The test fails, but it is an expected failure. - Still, the failure should eventually be fixed."! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3653-TestCase-shouldFix-JuanVuletich-2019Mar11-14h59m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3652] on 11 March 2019 at 9:09:24 am'! -!Compiler methodsFor: 'public access' stamp: 'HAW 3/11/2019 09:04:53'! - compileDoIt: textOrStream in: aClass context: aContext notifying: aRequestor ifFail: failBlock - "Similar to #compile:in:notifying:ifFail:, but the compiled code is - expected to be a do-it expression, with no message pattern." - - self from: textOrStream - class: aClass - context: aContext - notifying: aRequestor. - ^self - translate: sourceStream - noPattern: false - doIt: true - ifFail: failBlock! ! -!Compiler methodsFor: 'private' stamp: 'HAW 3/11/2019 09:04:33'! - translate: aStream noPattern: noPattern doIt: doIt ifFail: failBlock - - ^self parser - sourceStreamGetter: sourceStreamGetter; "Cuis specific. Do not remove!!" - ignoreBacktick: false; - parse: aStream - class: class - category: category - noPattern: noPattern - doIt: doIt - context: context - notifying: requestor - ifFail: [^failBlock value]! ! -!Scanner class methodsFor: 'doIt selectors' stamp: 'HAW 3/11/2019 09:00:46'! - doItInSelector - - ^#DoItIn:! ! -!Scanner class methodsFor: 'doIt selectors' stamp: 'HAW 3/11/2019 09:00:54'! - doItSelector - - ^#DoIt! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 3/11/2019 09:01:34'! - method: noPattern doIt: doIt context: ctxt - " pattern [ | temporaries ] block => MethodNode." - - | sap block primitives temporaries messageComment methodNode | - - sap := self pattern: noPattern inContext: ctxt. - "sap={selector, arguments, precedence}" - self properties selector: (sap at: 1). - encoder selector: (sap at: 1). - (sap at: 2) do: [:argNode | argNode beMethodArg]. - - doIt ifFalse: [self pragmaSequence]. - temporaries := self temporaries. - messageComment := currentComment. - currentComment := nil. - doIt ifFalse: [self pragmaSequence]. - primitives := self pragmaPrimitives. - - self statements: #() innerBlock: doIt. - block := parseNode. - doIt - ifTrue: [block returnLast] - ifFalse: [block returnSelfIfNoOther: encoder]. - hereType == #doIt ifFalse: [^self expected: 'Nothing more']. - - methodNode := self newMethodNode comment: messageComment. - methodNode - selector: (sap at: 1) - arguments: (sap at: 2) - precedence: (sap at: 3) - temporaries: temporaries - block: block - encoder: encoder - primitive: primitives - properties: properties - selectorKeywordsRanges: (sap at: 4). - - self interactive ifTrue: [ self performInteractiveChecks: methodNode ]. - - ^methodNode! ! -!Parser methodsFor: 'public access' stamp: 'HAW 3/11/2019 09:02:15'! - parse: sourceStream class: class category: aCategory noPattern: noPattern doIt: doIt context: aContext notifying: aRequestor ifFail: aBlock - - "Answer a MethodNode for the argument, sourceStream, that is the root of - a parse tree. Parsing is done with respect to the argument, class, to find - instance, class, and pool variables; and with respect to the argument, - ctxt, to find temporary variables. Errors in parsing are reported to the - argument, req, if not nil; otherwise aBlock is evaluated. The argument - noPattern is a Boolean that is true if the the sourceStream does not - contain a method header (i.e., for DoIts)." - - | methNode repeatNeeded myStream sourceCode startPosition | - - category _ aCategory. - myStream _ sourceStream. - [ - repeatNeeded _ false. - startPosition _ myStream position. - sourceCode _ myStream upToEnd. - myStream position: startPosition. - self encoder init: class context: aContext notifying: self. - self init: myStream notifying: aRequestor failBlock: [^ aBlock value ]. - doitFlag _ noPattern. - failBlock _ aBlock. - [ methNode _ self method: noPattern doIt: doIt context: aContext ] - on: ReparseAfterSourceEditing - do: [ :ex | - repeatNeeded _ true. - myStream _ sourceStreamGetter notNil "Cuis specific. Do not remove!!" - ifTrue: [ requestor perform: sourceStreamGetter ] - ifFalse: [ ReadStream on: requestor text string ]]. - repeatNeeded - ] whileTrue: [ encoder _ self encoder class new ]. - - methNode sourceText: sourceCode. - "See #xBacktick" - sentInLiterals do: [ :sym | encoder noteOptimizedSelector: sym ]. - - ^ methNode! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3654-DebugginSourceCode1-HernanWilkinson-2019Mar11-09h00m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3651] on 11 March 2019 at 9:12:47 am'! -!CompiledMethod methodsFor: 'decompiling' stamp: 'HAW 3/11/2019 08:53:25'! - createMethodNode - - "Creates the parse tree that represents self" - - | aClass source | - - aClass := self methodClass. - source := self - getSourceFor: (self selector ifNil: [self defaultSelector]) - in: aClass. - - ^ aClass methodNodeFor: source - ! ! -!CompiledMethod methodsFor: 'as yet unclassified' stamp: 'HAW 3/9/2019 02:52:10'! - methodNode: aMethodNode - - self propertyValueAt: #methodNode put: aMethodNode! ! -!Compiler methodsFor: 'public access' stamp: 'HAW 3/11/2019 06:35:05'! - evaluateMethod: method to: receiver logged: doLog profiled: doProfile - - "See evaluate:in:to:notifying:ifFail:logged:profiled: - It does the same but without compiling because it recevies the result of the compilation - as the parameter method. - self should have compile method" - - | value toLog itsSelection itsSelectionString | - - "(jmv) Log before evaluating. This way, if the evaluation is halted by whatever reason, it is logged anyway" - doLog ifTrue: [ - toLog _ ((requestor respondsTo: #selection) - and: [ (itsSelection _ requestor selection) notNil - and: [ (itsSelectionString _ itsSelection asString) isEmptyOrNil not ]]) - ifTrue: [ itsSelectionString ] - ifFalse: [ sourceStream contents ]. - SystemChangeNotifier uniqueInstance evaluated: toLog context: context ]. - - "Evaluate now." - doProfile - ifTrue: [ - AndreasSystemProfiler spyOn: [ - value _ receiver - withArgs: (context ifNil: [#()] ifNotNil: [{context}]) - executeMethod: method ]] - ifFalse: [ - value _ receiver - withArgs: (context ifNil: [#()] ifNotNil: [{context}]) - executeMethod: method ]. - - ^ value! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'HAW 3/11/2019 08:34:11'! - compileSelectionFor: anObject in: evalContext ifFail: failBlock - - | methodNode method sourceCode compiler | - - sourceCode := self selectionDoItSourceCodeIn: evalContext. - - methodNode _ [ - compiler _ Compiler new. - compiler - sourceStreamGetter: #selectionAsStream; "Cuis specific. Do not remove!!" - compileDoIt: sourceCode - in: anObject class - context: evalContext - notifying: self - ifFail: [ ^ failBlock value ]] - on: OutOfScopeNotification - do: [ :ex | ex resume: true ]. - - methodNode block returnLast. - method _ methodNode generate. - method methodNode: methodNode. - - ^{ #method -> method. #compiler -> compiler } asDictionary -! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'HAW 3/11/2019 08:57:46'! - selectionDoItSourceCodeIn: evalContext - - ^String streamContents: [ :stream | - "I use previousContext and not ThisContext as in the parser to avoid - name collision. Also, previousContext is more intention revealing - Hernan" - stream - nextPutAll: (evalContext ifNil: [ Scanner doItSelector ] ifNotNil: [ Scanner doItInSelector, ' previousContext' ]); - newLine; - newLine; - nextPutAll: self selectionAsStream upToEnd ]! ! -!CompiledMethod methodsFor: 'accessing' stamp: 'HAW 3/11/2019 08:35:51' prior: 16819362! - defaultSelector - - "Invent and answer an appropriate message selector (a Symbol) for me, - that is, one that will parse with the correct number of arguments." - - ^Scanner doItSelector numArgs: self numArgs! ! -!CompiledMethod methodsFor: 'source code management' stamp: 'HAW 3/11/2019 08:47:47' prior: 16820444! - getSourceFor: selector in: class - "Retrieve or reconstruct the source code for this method." - - | flagByte source | - - flagByte := self last. - - "If no source pointer..." - source := flagByte < 252 - ifTrue: [ nil ] - ifFalse: [ - "Situation normal; read the sourceCode from the file - An error can happen here if, for example, the changes file has been truncated by an aborted download. - The present solution is to ignore the error and fall back on the decompiler. - A more thorough solution should probably trigger a systematic invalidation of all source pointers past the end of the changes file. - Consider that, as time goes on, the changes file will eventually grow large enough to cover the lost code, and then instead of falling - into this error case, random source code will get returned." - [self getSourceFromFile] - on: Error - do: [ :ex | ex return: nil]]. - - "If source code not available, use DoIt source code or if absent decompile blind (no temps)" - ^source ifNil: [ (class decompilerClass new decompile: selector in: class method: self) decompileString ]! ! -!CompiledMethod methodsFor: 'decompiling' stamp: 'HAW 3/11/2019 08:55:04' prior: 50408791! - methodNode - - "Return the parse tree that represents self" - - "I do not save the method node in the #methodNode property if it does not - exist to avoid keeping the method node in memory. - The methodNode is saved in the property #methodNode to avoid loosing the source - code when debugging - Hernan" - ^self propertyValueAt: #methodNode ifAbsent: [ self createMethodNode ]! ! -!Compiler methodsFor: 'public access' stamp: 'HAW 3/9/2019 00:01:13' prior: 16821912! - evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock - - ^ self evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock logged: false profiled: false! ! -!Compiler methodsFor: 'public access' stamp: 'HAW 3/11/2019 08:45:50' prior: 50382473! - evaluate: textOrStream in: aContext to: aReceiver notifying: aRequestor ifFail: failBlock logged: doLog profiled: doProfile - "Compiles the sourceStream into a parse tree, then generates code into - a method. If aContext is not nil, the text can refer to temporaries in that - context (the Debugger uses this). If aRequestor is not nil, then it will receive - a notify:at: message before the attempt to evaluate is aborted. Finally, the - compiled method is invoked from here via withArgs:executeMethod:, hence - the system no longer creates Doit method litter on errors." - - | methodNode method | - - class _ (aContext ifNil: [ aReceiver ] ifNotNil: [ aContext receiver ]) class. - methodNode _ self compileNoPattern: textOrStream in: class context: aContext notifying: aRequestor ifFail: [^failBlock value]. - method _ methodNode generate. - "I'm not keeping the source nor the methodNode for back compabibility. - The SmalltalkEditor sends the message #evaluateMethod:... which already keep the method node - for the debugger to show the right source code - Hernan" - - ^self evaluateMethod: method to: aReceiver logged: doLog profiled: doProfile! ! -!Compiler methodsFor: 'private' stamp: 'HAW 3/11/2019 07:07:06' prior: 50409901! - translate: aStream noPattern: noPattern ifFail: failBlock - - ^self translate: aStream noPattern: noPattern doIt: noPattern ifFail: failBlock ! ! -!Compiler class methodsFor: 'evaluating' stamp: 'HAW 3/9/2019 00:01:04' prior: 16822139! - evaluate: textOrString for: anObject notifying: aRequestor logged: logFlag - "Compile and execute the argument, textOrString with respect to the class - of anObject. If a compilation error occurs, notify aRequestor. If both - compilation and execution are successful then, if logFlag is true, log - (write) the text onto a system changes file so that it can be replayed if - necessary." - - ^ self new - evaluate: textOrString - in: nil - to: anObject - notifying: aRequestor - ifFail: [^nil] - logged: logFlag - profiled: false! ! -!Scanner methodsFor: 'xBacktick processing - private' stamp: 'HAW 3/11/2019 08:36:29' prior: 50409922! - compileBacktickCode - - | compiler method methodNode | - - compiler _ Compiler new. - methodNode _ compiler compileNoPattern: buffer contents in: UndefinedObject context: nil notifying: nil ifFail: []. - method _ methodNode generate. - - "Grab all messages sent while evaluating literal, so the main method will be shown as senders of them" - sentInLiterals addAll: method messages. - method literalsDo: [ :literal | literal isSymbol ifTrue: [ literal = self class doItSelector ifFalse: [sentInLiterals add: literal ]]]. - - "Evaluate now." - token _ nil withArgs: #() executeMethod: method ! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 3/11/2019 06:42:49' prior: 50409275! - doitPatternInContext: context - - ^context - ifNil: [{self class doItSelector. {}. 1. nil }] - ifNotNil: [{self class doItInSelector. {encoder encodeVariable: encoder doItInContextName}. 3. nil}]! ! -!Parser methodsFor: 'public access' stamp: 'HAW 3/11/2019 08:31:06' prior: 16886850! - parse: sourceStream class: class noPattern: noPattern context: aContext notifying: aRequestor ifFail: aBlock - - ^self parse: sourceStream class: class category: nil noPattern: noPattern doIt: noPattern context: aContext notifying: aRequestor ifFail: aBlock ! ! -!AssignmentNode methodsFor: 'initialization' stamp: 'HAW 3/10/2019 12:37:09' prior: 16780831! - variable: aVariable value: expression from: encoder - - "Case of remote temp vars" - (aVariable isMemberOf: MessageAsTempNode) ifTrue: [ ^aVariable store: expression from: encoder]. - - variable := aVariable. - value := expression. - - ^self - -! ! -!AssignmentNode methodsFor: 'initialization' stamp: 'HAW 3/9/2019 20:03:46' prior: 16780841! - variable: aVariable value: expression from: encoder sourceRange: range - - | realNode | - - realNode := self variable: aVariable value: expression from: encoder. - encoder noteSourceRange: range forNode: realNode. - - ^realNode! ! -!MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'HAW 3/11/2019 08:56:15' prior: 16867539! - store: expr from: encoder - "ctxt tempAt: n -> ctxt tempAt: n put: expr (see Assignment). - For assigning into temps of a context being debugged." - - selector key ~= #namedTempAt: ifTrue: [^self error: 'cant transform this message']. - - ^ MessageAsTempNode new - receiver: receiver - selector: #namedTempAt:put: - arguments: (arguments copyWith: expr) - precedence: precedence - from: encoder! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'HAW 3/11/2019 06:25:51' prior: 16909636! - compileSelectionFor: anObject in: evalContext - - ^(self compileSelectionFor: anObject in: evalContext ifFail: [ ^ nil ]) at: #method -! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'HAW 3/11/2019 08:57:10' prior: 16909670! - debugIt - - | provider method receiver context | - - self lineSelectAndEmptyCheck: [^self]. - - provider _ self codeProvider. - (provider respondsTo: #doItReceiver) - ifTrue: [ - receiver _ provider doItReceiver. - context _ provider doItContext] - ifFalse: [ - receiver _ context _ nil]. - - method _ self compileSelectionFor: receiver in: context. - method ifNotNil: [ self debug: method receiver: receiver in: context ]! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'HAW 3/11/2019 08:42:34' prior: 16909696! - evaluateSelectionAndDo: aBlock ifFail: failBlock profiled: doProfile - "Treat the current selection as an expression; evaluate it and return the result - 3 +4 - " - | provider result receiver context methodAndCompiler | - - self lineSelectAndEmptyCheck: [^ '']. - - provider _ self codeProvider. - (provider respondsTo: #doItReceiver) - ifTrue: [ - receiver _ provider doItReceiver. - context _ provider doItContext] - ifFalse: [receiver _ context _ nil]. - - methodAndCompiler _ self compileSelectionFor: receiver in: context ifFail: [^ failBlock value]. - - result _ (methodAndCompiler at: #compiler) - evaluateMethod: (methodAndCompiler at: #method) - to: receiver - logged: true - profiled: doProfile. - - morph formatAndStyleIfNeeded. "Needed to re-shout workspaces, that might have new variables binded." - - ^ aBlock value: result! ! -!DebuggerMethodMap methodsFor: 'source mapping' stamp: 'HAW 3/11/2019 08:39:26' prior: 16830789! -abstractSourceMap - "Answer with a Dictionary of abstractPC to sourceRange ." - - | theMethodToScan rawSourceRanges concreteSourceRanges abstractPC scanner client | - - abstractSourceRanges ifNotNil: [ ^abstractSourceRanges]. - - methodNode encoder hasGeneratedMethod - ifTrue: [ - rawSourceRanges := methodNode encoder rawSourceRanges. - theMethodToScan := self method ] - ifFalse: [ - "If the methodNode hasn't had a method generated it doesn't have pcs set in its - nodes so we must generate a new method and might as well use it for scanning." - [methodNode rawSourceRangesAndMethodDo: [ :ranges :method | - rawSourceRanges := ranges. - theMethodToScan := method ]] - on: UndeclaredVariableWarning - do: [ :ex | ex resume ]]. - - concreteSourceRanges := Dictionary new. - rawSourceRanges keysAndValuesDo: [ :node :range | - node pc ~= 0 ifTrue: [ | realRange | - realRange := (range isKindOf: OrderedCollection) ifTrue: [ range last ] ifFalse: [ range ]. - concreteSourceRanges at: node pc put: realRange ]]. - - abstractPC := 1. - abstractSourceRanges := Dictionary new. - scanner := InstructionStream on: theMethodToScan. - client := InstructionClient new. - [ - (concreteSourceRanges includesKey: scanner pc) ifTrue: [ - abstractSourceRanges at: abstractPC put: (concreteSourceRanges at: scanner pc)]. - abstractPC := abstractPC + 1. - scanner interpretNextInstructionFor: client. - scanner atEnd ] whileFalse. - - ^abstractSourceRanges! ! -!DebuggerMethodMap methodsFor: 'source mapping' stamp: 'HAW 3/9/2019 03:26:53' prior: 16830892! - sourceText - - ^methodNode sourceText! ! -!DebuggerMethodMap class methodsFor: 'instance creation' stamp: 'HAW 3/11/2019 08:55:37' prior: 16830911! - forMethod: aMethod "" - "Answer a DebuggerMethodMap suitable for debugging activations of aMethod. - Answer an existing instance from the cache if it exists, cacheing a new one if required." - - | methodNode | - - ^self protected: [ - MapCache - at: aMethod - ifAbsent: [ - [ methodNode _ aMethod methodNode ] - on: UndeclaredVariableWarning - do: [ :ex | ex resume ]. - self - cacheDebugMap: (self - forMethod: aMethod - methodNode: methodNode) - forMethod: aMethod] ]! ! -!DebuggerMethodMap class methodsFor: 'instance creation' stamp: 'HAW 3/9/2019 03:16:29' prior: 16830930! - forMethod: aMethod "" methodNode: methodNode "" - "Uncached instance creation method for private use or for tests. - Please consider using forMethod: instead." - ^self new - forMethod: aMethod - methodNode: methodNode! ! - -Parser removeSelector: #method:context:! - -Parser removeSelector: #method:context:! - -Parser removeSelector: #parse:class:category:noPattern:context:notifying:ifFail:! - -Parser removeSelector: #parse:class:category:noPattern:context:notifying:ifFail:! - -Compiler removeSelector: #evaluateMethod:in:to:logged:profiled:! - -Compiler removeSelector: #evaluateMethod:in:to:notifying:ifFail:logged:profiled:! - -Compiler removeSelector: #evaluateMethod:in:to:notifying:logged:profiled:! - -CompiledMethod removeSelector: #doItSourceCodeIfAbsent:! - -CompiledMethod removeSelector: #generateDoItSourceCodeWith:! - -CompiledMethod removeSelector: #keepDoItSourceCodeWith:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3655-DebuggingSourceCode2-HernanWilkinson-2019Mar08-22h34m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3655] on 12 March 2019 at 2:14:59 pm'! -!Date methodsFor: 'squeak protocol' stamp: 'jmv 3/12/2019 13:50:59'! - > aDate - - self assert: aDate class == Date. - ^ self start > aDate start! ! -!Time class methodsFor: 'general inquiries' stamp: 'jmv 3/12/2019 14:02:51' prior: 16937263! - localMicrosecondClock - "Answer the number of microseconds since the Smalltalk epoch, - i.e. 00:00 on the morning of January 1, 1901, in the local host time zone. - In other words, the number of microseconds since it was that time in this time zone. - Answer might be a LargePositiveInteger (very likely on 32-bit images, very unlikely on 64-bit images). - - { Time localMicrosecondClock . Time localMicrosecondClock // 1000000 . Time localSecondClock } print - - Note 1: Never rolls over. Can be used with confidence. Joins primMillisecondClock - rollover control and sync with seconds clock. Uses existing offset if any, and validates result. - Resynchs if needed. Resynch is very robust. No problems if clocks go out of synch for unknown reasons. - - Note 2: This is in local time, i.e. the time the system shows to the user. UTC would be better, - but older VMs don't know about the current time zone" - - "If our VM supports the new primitive, just use it." - self primLocalMicrosecondClock ifNotNil: [ :microSecs | ^microSecs ]. - - "Otherwise we'll have just millisecond precision" - ^self localMillisecondClock * 1000! ! -!Time class methodsFor: 'general inquiries' stamp: 'jmv 3/12/2019 14:02:55' prior: 16937299! - localMillisecondClock - "Answer the number of milliseconds since the Smalltalk epoch, - i.e. 00:00 on the morning of January 1, 1901, in the local host time zone. - In other words, the number of milliseconds since it was that time in this time zone. - Answer might be a LargePositiveInteger (very likely on 32-bit images, very unlikely on 64-bit images). - - { Time localMillisecondClock . Time localMillisecondClock // 1000 . Time localSecondClock } print - - Note 1: Never rolls over. Can be used with confidence. Joins primMillisecondClock - rollover control and sync with seconds clock. Uses existing offset if any, and validates result. - Resynchs if needed. Resynch is very robust. No problems if clocks go out of synch for unknown reasons. - - Note 2: This is in local time, i.e. the time the system shows to the user. UTC would be better, - but older VMs don't know about the current time zone" - - | millisecsSinceStartupOrRollover nowMillisecs nowSecs delay lastSecond | - - "If our VM supports the new primitive, just use it." - self primLocalMicrosecondClock ifNotNil: [ :microSecs | ^microSecs // 1000 ]. - - "Otherwise use millisecond clock and offset from second clock" - MillisecondClockOffset ifNil: [ MillisecondClockOffset _ 0 ]. "Fix it below." - millisecsSinceStartupOrRollover _ self primMillisecondClock. - nowMillisecs _ millisecsSinceStartupOrRollover + MillisecondClockOffset. - - "Do expensive resync (delay 1 second) only on primMillisecondClock rollover, or if for whatever reason offset is wrong." - nowSecs _ self primLocalSecondsClock. - nowMillisecs // 1000 = nowSecs ifFalse: [ - delay _ Delay forMilliseconds: 1. - lastSecond _ self primLocalSecondsClock. - [ lastSecond = self primLocalSecondsClock ] whileTrue: [ delay wait ]. - millisecsSinceStartupOrRollover _ self primMillisecondClock. - nowSecs _ lastSecond + 1. - MillisecondClockOffset _ nowSecs * 1000 - millisecsSinceStartupOrRollover ]. - - nowMillisecs _ MillisecondClockOffset + millisecsSinceStartupOrRollover. - ^nowMillisecs! ! -!Time class methodsFor: 'general inquiries' stamp: 'jmv 3/12/2019 14:03:05' prior: 16937363! - localSecondClock - "Answer the number of milliseconds since the Smalltalk epoch, - i.e. 00:00 on the morning of January 1, 1901, in the local host time zone. - In other words, the number of milliseconds since it was that time in this time zone. - This is in local time, i.e. the time the system shows to the user. - Answer might be a LargePositiveInteger (very likely on 32-bit images, very unlikely on 64-bit images). - - { Time localMillisecondClock . Time localMillisecondClock // 1000 . Time localSecondClock } print - " - ^self localMillisecondClock // 1000! ! -!Time class methodsFor: 'primitives' stamp: 'jmv 3/12/2019 14:03:29' prior: 50378285! - primHighResClock - "Primitive. Answer the value of the high resolution clock if this computer has one. - Usually, this should be the highest resolution value available, for example on Intel - it will be the value of the time stamp counter register. - Answer might be a LargePositiveInteger (very likely on 32-bit images, very unlikely on 64-bit images). - Implemented on Cog, but not in standard interpreter VMs." - " - Time primHighResClock - On Cog on Linux, OS-X and Windows, this gives sub nano second ticks!! - - Time highResTimerTicksPerMillisecond - " - "Not really a clock, but a timer or ticker" - - - ^0! ! -!Time class methodsFor: 'primitives' stamp: 'jmv 3/12/2019 14:03:33' prior: 16937585! - primLocalMicrosecondClock - "Answer the number of microseconds since the local time zone Smalltalk epoch, - i.e. 00:00 on the morning of January 1, 1901, in local time. - Answer might be a LargePositiveInteger (very likely on 32-bit images, very unlikely on 64-bit images). - Cog VMs implement this. Interpreters might not." - " - Time primLocalMicrosecondClock - Time primLocalMicrosecondClock/ 1000 / 1000 / 60 / 60 / 24 / 365.25 - " - - ^nil! ! -!Time class methodsFor: 'primitives' stamp: 'jmv 3/12/2019 14:05:35' prior: 16937600! - primLocalSecondsClock - "Answer the number of seconds since the Smalltalk epoch, - i.e. 00:00 on the morning of January 1, 1901, in the local host time zone. - In other words, the number of seconds since it was that time in this time zone. - Answer is a 32-bit unsigned number. - Answer might be a LargePositiveInteger on 32-bit images. - Note: This is in local time, i.e. the time the system shows to the user. - Essential. See Object documentation whatIsAPrimitive. - - Time primLocalSecondsClock - Time primLocalSecondsClock / 60 / 60 / 24 / 365.25 - - Warning: Will overflow in year 2037 - " - - - self primitiveFailed! ! -!Time class methodsFor: 'primitives' stamp: 'jmv 3/12/2019 14:05:48' prior: 50340954! - primUtcMicrosecondClock - "Answer the number of microseconds since the UTC Smalltalk epoch, - i.e. 00:00 on the morning of January 1, 1901, the start of the 20th century, in UTC time. - The value is derived from the Posix epoch with a constant offset corresponding to elapsed microseconds - between the two epochs according to RFC 868. - Answer might be a LargePositiveInteger (very likely on 32-bit images, very unlikely on 64-bit images). - Cog VMs implement this. Interpreters might not." - " - Time primUtcMicrosecondClock - Time primUtcMicrosecondClock/ 1000 / 1000 / 60 / 60 / 24 / 365.25 - - (Time primUtcMicrosecondClock / 1000 / 1000 + Time primUtcWithOffset second) / 60 / 60 / 24 / 365.25 - (DateAndTime now - (DateAndTime year: 1901 month: 1 day: 1)) totalSeconds / 60 / 60 / 24 / 365.25 - " - - ^nil! ! -!Time class methodsFor: 'primitives' stamp: 'jmv 3/12/2019 14:07:31' prior: 16937663! - primUtcWithOffset - "Answer a two element array. - - First element is the number of microseconds since the UTC Posix (Unix) epoch, - i.e. 00:00 on the morning of January 1, 1970, in UTC time. - It might be a LargePositiveInteger (very likely on 32-bit images, very unlikely on 64-bit images). - - Second element is the current seconds offset from GMT in the local time zone. - - Recent VMs implement this. Older Interpreters might not. - " - " - Time primUtcWithOffset - Time primUtcWithOffset first / 1000 / 1000 / 60 / 60 / 24 / 365.25 - Time primUtcWithOffset second / 60 / 60.0 - - (Time primUtcWithOffset first / 1000 / 1000 + Time primUtcWithOffset second) / 60 / 60 / 24 / 365.25 - (DateAndTime now - (DateAndTime year: 1970 month: 1 day: 1)) totalSeconds / 60 / 60 / 24 / 365.25 - " - - ^nil - - " - Evaluate on various platforms and record the results -{ - Smalltalk vmVersion . - Smalltalk platformName . - Smalltalk platformSubtype . - Smalltalk osVersion . - Time primLocalMicrosecondClock/ 1000 / 1000 / 60 / 60 / 24 / 365.25 . - Time primLocalSecondsClock / 60 / 60 / 24 / 365.25 . - Time primUtcMicrosecondClock / 1000 / 1000 / 60 / 60 / 24 / 365.25 . - Time primUtcWithOffset first / 1000 / 1000 / 60 / 60 / 24 / 365.25 . - Time primUtcWithOffset second / 60 / 60.0 -} - "! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3656-SomeMethodCommentTweaks-JuanVuletich-2019Mar11-17h23m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3652] on 11 March 2019 at 3:33:12 pm'! - -"Change Set: 3653-CuisCore-AuthorName-2019Mar11-14h53m -Date: 11 March 2019 -Author: Nahuel Garbezza - -Categorize a bunch of uncategorized methods"! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3657-MethodsCategorization-NahuelGarbezza-2019Mar11-14h53m-RNG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3652] on 11 March 2019 at 4:34:52 pm'! - -"Change Set: 3653-CuisCore-AuthorName-2019Mar11-15h56m -Date: 11 March 2019 -Author: Nahuel Garbezza - -Add (R) as a shortcut to rename packages, classes, categories and methods"! -!CodeWindow methodsFor: 'keyboard shortcuts' stamp: 'RNG 3/11/2019 16:33:24' prior: 50338607! - messageListKey: aChar from: view - "Respond to a Command key. I am a model with a code pane, and I also - have a listView that has a list of methods. The view knows how to get - the list and selection." - - | sel class | - aChar == $D ifTrue: [^ model toggleDiffing]. - - sel _ model selectedMessageName. - aChar == $m ifTrue: [ "These next two put up a type in if no message selected" - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllImplementorsOf: to: Smalltalk]. - aChar == $n ifTrue: [ - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllCallsOn: to: Smalltalk]. - - "The following require a class selection" - (class _ model selectedClassOrMetaClass) ifNil: [^ self ]. - aChar == $b ifTrue: [^ BrowserWindow fullOnClass: class selector: sel]. - aChar == $N ifTrue: [^ self browseClassRefs]. - aChar == $i ifTrue: [^ self methodHierarchy]. - aChar == $h ifTrue: [^ self browseHierarchy]. - aChar == $p ifTrue: [^ self browseFullProtocol]. - - sel - ifNotNil: [ - "The following require a method selection" - aChar == $o ifTrue: [^ model fileOutMessage]. - aChar == $c ifTrue: [^ model copySelector]. - aChar == $v ifTrue: [^ self browseVersions]. - aChar == $O ifTrue: [^ self openSingleMessageBrowser]. - aChar == $x ifTrue: [^ model removeMessage]. - aChar == $t ifTrue: [^ model runMethodTest]. - aChar == $r ifTrue: [^ model debugMethodTest]. - aChar == $R ifTrue: [^ self renameSelector]] - ifNil: [ - aChar == $R ifTrue: [^ model renameClass]]! ! -!CodeWindow methodsFor: 'keyboard shortcuts' stamp: 'RNG 3/1/2019 21:49:28' prior: 50419679! - systemCatListKey: aChar from: view - "Respond to a Command key. I am a model with a code pane, and I also have a listView that has a list of methods. The view knows how to get the list and selection." - - aChar == $f ifTrue: [ ^ self findClass ]. - aChar == $x ifTrue: [ ^ model removeSystemCategory ]. - aChar == $t ifTrue: [ ^ model runSystemCategoryTests ]. - aChar == $a ifTrue: [ ^ model addSystemCategory ]. - aChar == $A ifTrue: [ ^ model alphabetizeSystemCategories ]. - aChar == $b ifTrue: [ ^ self openSystemCategoryBrowser ]. - aChar == $B ifTrue: [ ^ self browseAllClasses ]. - aChar == $o ifTrue: [ ^ model fileOutSystemCategory ]. - aChar == $u ifTrue: [ ^ model updateSystemCategories ]. - aChar == $R ifTrue: [ ^ model renameSystemCategory ]. - - ^ self classListKey: aChar from: view! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'RNG 3/1/2019 21:50:23' prior: 50411315! - classListMenuOptions - - ^ `{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutClass. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 5. - #label -> 'show classes hierarchically'. - #object -> #model. - #selector -> #enableListClassesHierarchically. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 6. - #label -> 'show classes alphabetically'. - #object -> #model. - #selector -> #enableListClassesAlphabetically. - #icon -> #sendReceiveIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'show hierarchy'. - #object -> #model. - #selector -> #hierarchy. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'show definition'. - #object -> #model. - #selector -> #editClass. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'show comment'. - #object -> #model. - #selector -> #editComment. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'inst var refs...'. - #selector -> #browseInstVarRefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'inst var defs...'. - #selector -> #browseInstVarDefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'class var refs...'. - #selector -> #browseClassVarRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 20. - #label -> 'class vars'. - #selector -> #browseClassVariables. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'class refs (N)'. - #selector -> #browseClassRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'rename class... (R)'. - #object -> #model. - #selector -> #renameClass. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 20. - #label -> 'copy class...'. - #object -> #model. - #selector -> #copyClass. - #icon -> #copyIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 30. - #label -> 'remove class (x)'. - #object -> #model. - #selector -> #removeClass. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 10. - #label -> 'run tests (t)'. - #object -> #model. - #selector -> #runClassTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 20. - #label -> 'more...'. - #selector -> #offerClassListMenu2. - #icon -> #listAddIcon - } asDictionary. - }`. - ! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'RNG 3/1/2019 21:48:16' prior: 50411726! - systemCatSingletonMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'find class... (f)'. - #selector -> #findClass. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'browse all (B)'. - #selector -> #browseAllClasses. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'browse (b)'. - #selector -> #openSystemCategoryBrowser. - #icon -> #packageIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'fileOut (o)'. - #object -> #model. - #selector -> #fileOutSystemCategory. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'update (u)'. - #object -> #model. - #selector -> #updateSystemCategories. - #icon -> #updateIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'rename... (R)'. - #object -> #model. - #selector -> #renameSystemCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'remove (x)'. - #object -> #model. - #selector -> #removeSystemCategory. - #icon -> #deleteIcon - } asDictionary. - }`. - ! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'RNG 3/1/2019 21:48:09' prior: 50419706! - systemCategoryMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'find class... (f)'. - #selector -> #findClass. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'recent classes... (r)'. - #object -> #model. - #selector -> #recent. - #icon -> #clockIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'browse all (B)'. - #selector -> #browseAllClasses. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'browse (b)'. - #selector -> #openSystemCategoryBrowser. - #icon -> #packageIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'fileOut (o)'. - #object -> #model. - #selector -> #fileOutSystemCategory. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'reorganize'. - #object -> #model. - #selector -> #editSystemCategories. - #icon -> #sendReceiveIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'alphabetize (A)'. - #object -> #model. - #selector -> #alphabetizeSystemCategories. - #icon -> #fontXGenericIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'update (u)'. - #object -> #model. - #selector -> #updateSystemCategories. - #icon -> #updateIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 20. - #label -> 'add item... (a)'. - #object -> #model. - #selector -> #addSystemCategory. - #icon -> #newIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'rename... (R)'. - #object -> #model. - #selector -> #renameSystemCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 40. - #label -> 'remove (x)'. - #object -> #model. - #selector -> #removeSystemCategory. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'move to top'. - #object -> #model. - #selector -> #moveSystemCategoryTop. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 20. - #label -> 'move up'. - #object -> #model. - #selector -> #moveSystemCategoryUp. - #icon -> #goUpIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 30. - #label -> 'move down'. - #object -> #model. - #selector -> #moveSystemCategoryDown. - #icon -> #goDownIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 40. - #label -> 'move to bottom'. - #object -> #model. - #selector -> #moveSystemCategoryBottom. - #icon -> #goBottomIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 10. - #label -> 'run tests (t)'. - #object -> #model. - #selector -> #runSystemCategoryTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - }`. - ! ! -!RefactoringMenues class methodsFor: 'browser menues' stamp: 'RNG 3/11/2019 15:58:36' prior: 50442445! - classRefactoringMenuOptions - - ^ `{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'rename class... (R)'. - #object -> #model. - #selector -> #renameClass. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'insert superclass...'. - #object -> #model. - #selector -> #insertSuperclass. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'safely remove class (x)'. - #object -> #model. - #selector -> #safelyRemoveClass. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'add inst var...'. - #selector -> #addInstVar. - #icon -> #listAddIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'rename inst var...'. - #selector -> #renameInstVar. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'remove inst var...'. - #selector -> #removeInstVar. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 40. - #label -> 'remove all unreferenced inst var...'. - #selector -> #removeAllUnreferencedInstVar. - #icon -> #deleteIcon - } asDictionary. - }`. - ! ! -!RefactoringMenues class methodsFor: 'browser menues' stamp: 'RNG 3/11/2019 15:58:48' prior: 50442503! - messsageRefactoringMenuOptions - - ^ `{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'rename... (R)'. - #selector -> #renameSelector. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'add parameter...'. - #selector -> #addParameter. - #icon -> #listAddIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'remove parameter...'. - #selector -> #removeParameter. - #icon -> #listRemoveIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'push up'. - #selector -> #pushUpSelector. - #icon -> #goTopIcon - } asDictionary. - }`. - - ! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3658-Shortcuts-NahuelGarbezza-2019Mar11-15h56m-RNG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3656] on 12 March 2019 at 3:09:32 pm'! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'jmv 3/12/2019 15:07:50' prior: 50436548! - resetMenu - - | width newExtent | - self hideSelectorDocumentation. - - firstVisible := 1. - self selected: ((completer canSelect: (completer entries at: firstVisible)) ifTrue: [firstVisible] ifFalse: [firstVisible+1]). - - self calculateItemsPerPage. - width _ self calculateWidth. - newExtent _ width + 4 @ (itemsPerPage * self itemHeight + 2). - - self morphPosition: originalPosition extent: newExtent. - "redraw is needed even if position and extent haven't changed" - self redrawNeeded ! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3659-skipCategoryTitleInAutocompleter-JuanVuletich-2019Mar12-15h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3659] on 12 March 2019 at 10:00:35 pm'! - -"Change Set: 3660-CuisCore-AuthorName-2019Mar12-21h45m -Date: 12 March 2019 -Author: Nahuel Garbezza - -Add some shortcuts to file list"! -!FileListWindow methodsFor: 'keyboard shortcuts' stamp: 'RNG 3/12/2019 21:55:43'! - fileListKey: aChar from: aView - - aChar == $x ifTrue: [ ^ aView model deleteFile ]. - aChar == $R ifTrue: [ ^ aView model renameFile ]. - aChar == $n ifTrue: [ ^ aView model addNewFile ]. - aChar == $N ifTrue: [ ^ aView model addNewDirectory ].! ! -!FileList methodsFor: 'own services' stamp: 'RNG 3/12/2019 21:57:34' prior: 50427096! - serviceAddNewDirectory - "Answer a service entry characterizing the 'add new directory' command" - - ^ SimpleServiceEntry - provider: self - label: 'add new directory (N)' - selector: #addNewDirectory - description: 'adds a new, empty directory (folder)' - icon: #listAddIcon! ! -!FileList methodsFor: 'own services' stamp: 'RNG 3/12/2019 21:56:19' prior: 50427108! - serviceAddNewFile - "Answer a service entry characterizing the 'add new file' command" - - ^ SimpleServiceEntry - provider: self - label: 'add new file (n)' - selector: #addNewFile - description: 'create a new,. empty file, and add it to the current directory.' - icon: #newIcon! ! -!FileList methodsFor: 'own services' stamp: 'RNG 3/12/2019 21:58:57' prior: 50427129! - serviceDeleteFile - - ^ SimpleServiceEntry - provider: self - label: 'delete (x)' - selector: #deleteFile - description: 'delete the seleted item' - icon: #deleteIcon! ! -!FileList methodsFor: 'own services' stamp: 'RNG 3/12/2019 21:59:33' prior: 50427158! - serviceRenameFile - - ^ SimpleServiceEntry - provider: self - label: 'rename (R)' - selector: #renameFile - description: 'rename file' - icon: #saveAsIcon! ! -!FileListWindow methodsFor: 'GUI building' stamp: 'RNG 3/12/2019 21:47:48' prior: 16843344! - morphicFileListPane - - ^PluggableListMorph - model: model - listGetter: #fileList - indexGetter: #fileListIndex - indexSetter: #fileListIndex: - mainView: self - menuGetter: #fileListMenu - keystrokeAction: #fileListKey:from:! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3660-FileListShortcuts-NahuelGarbezza-2019Mar12-21h45m-RNG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3660] on 13 March 2019 at 11:31:28 am'! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 3/13/2019 11:30:42' prior: 50406067! - parse: isAMethod - "Parse the receiver's text. If isAMethod is true - then treat text as a method, if false as an - expression with no message pattern" - - | continue prevSourcePosition | - self initializeInstanceVariables. - sourcePosition _ 1. - arguments _ Dictionary new. - temporaries _ Dictionary new. - blockDepth _ bracketDepth := 0. - blockDepths _ OrderedCollection with: blockDepth. - blockDepthsStartIndexes _ OrderedCollection with: sourcePosition. - ranges ifNil: [ ranges := OrderedCollection new: 100] ifNotNil: [ ranges reset]. - errorBlock _ [^false]. - [ - self scanNext. - isAMethod - ifTrue: [ - self parseMessagePattern. - self parsePragmaSequence]. - self parseMethodTemporaries. - isAMethod ifTrue: [self parsePragmaSequence]. - "Iterate once for methods, but pontentially several times for workspaces - (to recover after errors, for possible good next lines or chunks)" - continue _ true. - [ continue ] whileTrue: [ - prevSourcePosition _ sourcePosition. - self parseStatementList. - continue _ sourcePosition > prevSourcePosition. - isAMethod - ifTrue: [ - "Only if we are parsing a method, consider everything after this point as error." - currentToken ifNotNil: [ self error ]. - continue _ false] - ifFalse: [ - sourcePosition > source size ifTrue: [continue _ false]]]. - ] ensure: [errorBlock _ nil]. - ^true! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3661-SyntaxHighlighterFix-JuanVuletich-2019Mar13-11h12m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3661] on 14 March 2019 at 1:15:33 pm'! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 3/14/2019 13:04:03' prior: 16880199! - raisedToInteger: anInteger - - "The 0 raisedToInteger: 0 is an special case. In some contexts must be 1 and in others must - be handled as an indeterminate form. - I take the first context because that's the way that was previously handled. - Maybe further discussion is required on this topic." - - | bitProbe result firstTry exponent exponent1 exponent2 | - - anInteger negative ifTrue: [ - exponent := anInteger negated. - firstTry := self raisedToInteger: exponent. - ^firstTry isInfinite - ifFalse: [firstTry reciprocal] - ifTrue: [ - exponent1 _ exponent // 2. - exponent2 _ exponent - exponent1. - (self raisedToInteger: exponent1) reciprocal * (self raisedToInteger: exponent2) reciprocal ]]. - bitProbe := 1 bitShift: anInteger highBit - 1. - result := self class one. - [ - (anInteger bitAnd: bitProbe) = 0 ifFalse: [result := result * self]. - bitProbe := bitProbe bitShift: -1. - bitProbe > 0 ] - whileTrue: [result := result * result]. - - ^result! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3662-fix-raisedToInteger-edgeCases-JuanVuletich-2019Mar14-13h00m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3610] on 14 March 2019 at 4:34:14 pm'! -!Editor methodsFor: 'private' stamp: 'AY 3/14/2019 16:25:09'! - nextWordEndFrom: aPosition goingForwards: goingForwardsBoolean - - "Answer the position of the end of the next word on the current line going - forwards (or backwards). - If the given position is the end (or beginning) of the line then answer the - beginning (or end) of the next (or previous) line." - - | string beginningOfLine endOfLine step offset index newPosition | - - string _ self privateCurrentString. - beginningOfLine _ self beginningOfLine: aPosition. - endOfLine _ self endOfLine: aPosition. - step _ goingForwardsBoolean ifTrue: [1] ifFalse: [-1]. - offset _ goingForwardsBoolean ifTrue: [0] ifFalse: [-1]. - - index _ aPosition. - [(index + step between: beginningOfLine and: endOfLine) - and: [(string at: index + offset) isValidInIdentifiers not]] - whileTrue: [index _ index + step]. - [(index + step between: beginningOfLine and: endOfLine) - and: [(string at: index + offset) isValidInIdentifiers]] - whileTrue: [index _ index + step]. - - newPosition _ index = aPosition ifTrue: [index + step] ifFalse: [index]. - ^newPosition min: string size + 1 max: 1! ! -!Editor methodsFor: 'private' stamp: 'AY 3/14/2019 16:29:31'! - nextWordStartFrom: aPosition goingForwards: goingForwardsBoolean - - "Answer the position of the start of the next word on the current line going - forwards (or backwards). - If the given position is the end (or beginning) of the line then answer the - beginning (or end) of the next (or previous) line." - - | string beginningOfLine endOfLine step offset index newPosition | - - string _ self privateCurrentString. - beginningOfLine _ self beginningOfLine: aPosition. - endOfLine _ self endOfLine: aPosition. - step _ goingForwardsBoolean ifTrue: [1] ifFalse: [-1]. - offset _ goingForwardsBoolean ifTrue: [0] ifFalse: [-1]. - - index _ aPosition. - [(index + step between: beginningOfLine and: endOfLine) - and: [(string at: index + offset) isValidInIdentifiers]] - whileTrue: [index _ index + step]. - [(index + step between: beginningOfLine and: endOfLine) - and: [(string at: index + offset) isValidInIdentifiers not]] - whileTrue: [index _ index + step]. - - newPosition _ index = aPosition ifTrue: [index + step] ifFalse: [index]. - ^newPosition min: string size + 1 max: 1! ! -!Editor methodsFor: 'nonediting/nontyping keys' stamp: 'AY 3/14/2019 01:24:07' prior: 16836563! - cursorLeft: aKeyboardEvent - "Private - Move cursor left one character if nothing selected, otherwise move cursor to beginning of selection. If the shift key is down, start selecting or extending current selection. - Don't allow cursor past beginning of text" - - self - moveCursor: [ :position | | newPos | - newPos _ position - 1. - "Mac standard keystroke" - (aKeyboardEvent rawMacOptionKeyPressed or: [ - "Windows / Linux standard keystroke" - aKeyboardEvent controlKeyPressed ]) - ifTrue: [ newPos _ self previousWordStart: position ]. - "Mac standard keystroke" - aKeyboardEvent commandAltKeyPressed ifTrue: [ - newPos _ self beginningOfLine: position ]. - newPos ] - forward: false - event: aKeyboardEvent. - ^ true! ! -!Editor methodsFor: 'nonediting/nontyping keys' stamp: 'AY 3/14/2019 16:26:36' prior: 16836609! -cursorRight: aKeyboardEvent - "Private - Move cursor right one character if nothing selected, otherwise move cursor to end of selection. If the shift key is down, start selecting characters or extending already selected characters. - Don't allow cursor past end of text" - - self - moveCursor: [ :position | | newPos | - newPos _ position + 1. - "Mac standard keystroke" - (aKeyboardEvent rawMacOptionKeyPressed or: [ - "Windows / Linux standard keystroke" - aKeyboardEvent controlKeyPressed ]) - ifTrue: [ newPos _ self nextWordEnd: position ]. - "Mac standard keystroke" - aKeyboardEvent commandAltKeyPressed ifTrue: [ - newPos _ self endOfLine: position ]. - newPos ] - forward: true - event: aKeyboardEvent. - ^ true! ! -!Editor methodsFor: 'private' stamp: 'AY 3/14/2019 16:30:31' prior: 16836804! - nextWordEnd: aPosition - - ^self nextWordEndFrom: aPosition goingForwards: true! ! -!Editor methodsFor: 'private' stamp: 'AY 3/14/2019 16:30:13' prior: 16836818! -nextWordStart: aPosition - - ^self nextWordStartFrom: aPosition goingForwards: true! ! -!Editor methodsFor: 'private' stamp: 'AY 3/14/2019 16:31:46' prior: 16836832! - previousWordStart: aPosition - - ^self nextWordEndFrom: aPosition goingForwards: false! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3663-NextWord-PreviousWord-tweaks-AngelYan-2019Mar13-22h56m-AY.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3661] on 15 March 2019 at 2:26:59 pm'! -!AutoCompleterMorph methodsFor: 'accessing' stamp: 'AY 3/15/2019 11:51:58'! - entryCount - - ^completer entryCount! ! -!AutoCompleterMorph methodsFor: 'accessing' stamp: 'AY 3/15/2019 13:26:28'! - itemsPerPage - - ^itemsPerPage! ! -!AutoCompleterMorph methodsFor: 'private' stamp: 'AY 3/15/2019 13:04:51'! - firstSelectableEntryIndex - - ^self nextSelectableEntryIndexFrom: 0! ! -!AutoCompleterMorph methodsFor: 'private' stamp: 'AY 3/15/2019 14:01:03'! - firstVisible: anIndex - - firstVisible _ anIndex - min: self entryCount - self itemsPerPage + 1 - max: 1.! ! -!AutoCompleterMorph methodsFor: 'private' stamp: 'AY 3/15/2019 14:10:19'! - lastSelectableEntryIndex - - ^self previousSelectableEntryIndexFrom: 1! ! -!AutoCompleterMorph methodsFor: 'private' stamp: 'AY 3/15/2019 14:01:42'! - lastVisible: anIndex - - self firstVisible: anIndex - self itemsPerPage + 1.! ! -!AutoCompleterMorph methodsFor: 'private' stamp: 'AY 3/15/2019 13:31:48'! - nextSelectableEntryIndexFrom: anIndex - - ^self nextSelectableEntryIndexFrom: anIndex goingForwards: true! ! -!AutoCompleterMorph methodsFor: 'private' stamp: 'AY 3/15/2019 13:31:31'! - nextSelectableEntryIndexFrom: anIndex goingForwards: goingForwardsBoolean - - | direction indicesFromAnIndex | - - direction _ goingForwardsBoolean ifTrue: [1] ifFalse: [-1]. - indicesFromAnIndex _ (1 to: self entryCount) - collect: [ :offset | self wrapIndex: anIndex + (offset*direction) by: self entryCount ]. - - ^indicesFromAnIndex - detect: [ :index | self canSelectEntryAt: index ] - ifNone: [self error: 'there are no selectable entries']! ! -!AutoCompleterMorph methodsFor: 'private' stamp: 'AY 3/15/2019 14:18:28'! - nextSelectableEntryIndexFromAndIncluding: anIndex - - ^self nextSelectableEntryIndexFrom: anIndex - 1! ! -!AutoCompleterMorph methodsFor: 'private' stamp: 'AY 3/15/2019 13:32:02'! - previousSelectableEntryIndexFrom: anIndex - - ^self nextSelectableEntryIndexFrom: anIndex goingForwards: false! ! -!AutoCompleterMorph methodsFor: 'private' stamp: 'AY 3/15/2019 13:25:42'! - wrapIndex: anIndex by: aSize - - ^anIndex - 1 \\ aSize + 1! ! -!AutoCompleterMorph methodsFor: 'testing' stamp: 'AY 3/15/2019 11:55:29'! - canSelectEntryAt: anIndex - - ^completer canSelectEntryAt: anIndex! ! -!AutoCompleter methodsFor: 'entries' stamp: 'AY 3/15/2019 11:47:28'! - entryAt: anIndex - - ^self entries at: anIndex! ! -!AutoCompleter methodsFor: 'testing' stamp: 'AY 3/15/2019 11:47:48'! - canSelectEntryAt: anIndex - - ^self canSelect: (self entryAt: anIndex)! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'AY 3/15/2019 14:10:45' prior: 50436493! - goDown - - self selected: (self nextSelectableEntryIndexFrom: self selected). - (self selected between: self firstVisible and: self lastVisible) - ifFalse: [self lastVisible: self selected]. - - self redrawNeeded.! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'AY 3/15/2019 14:03:40' prior: 50436505! - goHome - - self selected: self firstSelectableEntryIndex. - self firstVisible: 1. - self redrawNeeded.! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'AY 3/15/2019 14:03:32' prior: 50436523! -goToEnd - - self selected: self lastSelectableEntryIndex. - self lastVisible: self selected. - self redrawNeeded.! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'AY 3/15/2019 14:00:18' prior: 50436530! - goUp - - (self selected = 0 and: [self firstVisible = 1]) ifTrue: [^ self]. - - self selected: (self previousSelectableEntryIndexFrom: self selected). - (self selected between: self firstVisible and: self lastVisible) - ifFalse: [self firstVisible: self selected]. - - self redrawNeeded.! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'AY 3/15/2019 14:25:49' prior: 50446123! - resetMenu - - | width newExtent | - self hideSelectorDocumentation. - - self calculateItemsPerPage. - - self firstVisible: 1. - self selected: self firstSelectableEntryIndex. - - width _ self calculateWidth. - newExtent _ width + 4 @ (itemsPerPage * self itemHeight + 2). - - self morphPosition: originalPosition extent: newExtent. - "redraw is needed even if position and extent haven't changed" - self redrawNeeded ! ! -!AutoCompleterMorph methodsFor: 'paging' stamp: 'AY 3/15/2019 14:18:47' prior: 50436651! - gotoPage: anInteger - - | item | - - item := ((anInteger - 1) * itemsPerPage) + 1. - item >= completer entryCount ifTrue: [^false]. - - item < 1 ifTrue: [item := 1]. - firstVisible _ item. - self selected: (self nextSelectableEntryIndexFromAndIncluding: item). - - ^ true! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3664-Autocompleter-skipTitles-AngelYan-2019Mar15-14h07m-AY.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3662] on 15 March 2019 at 5:14:44 pm'! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'AY 3/15/2019 17:13:20' prior: 50436511! - goPageDown - - | oldEntry newEntry nextEntry | - - oldEntry _ self selected. - newEntry _ oldEntry. - [nextEntry _ self nextSelectableEntryIndexFrom: newEntry. - nextEntry > oldEntry and: [nextEntry - oldEntry <= self itemsPerPage]] - whileTrue: [newEntry _ nextEntry]. - - self selected: newEntry. - self firstVisible: newEntry. - - self redrawNeeded.! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'AY 3/15/2019 17:09:51' prior: 50436517! - goPageUp - - | oldEntry newEntry nextEntry | - - oldEntry _ self selected. - newEntry _ oldEntry. - [nextEntry _ self previousSelectableEntryIndexFrom: newEntry. - oldEntry > nextEntry and: [oldEntry - nextEntry <= self itemsPerPage]] - whileTrue: [newEntry _ nextEntry]. - - self selected: newEntry. - self firstVisible: newEntry. - - self redrawNeeded.! ! - -AutoCompleterMorph removeSelector: #currentPage! - -AutoCompleterMorph removeSelector: #currentPage! - -AutoCompleterMorph removeSelector: #gotoPage:! - -AutoCompleterMorph removeSelector: #gotoPage:! - -AutoCompleterMorph removeSelector: #pageCount! - -AutoCompleterMorph removeSelector: #pageCount! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3665-AutoCompleterPageUpDown-AngelYan-2019Mar15-17h08m-AY.1.cs.st----! - -----SNAPSHOT----(15 March 2019 17:36:06) Cuis5.0-3665-v3.image priorSource: 3233715! - -----QUIT----(15 March 2019 17:43:20) Cuis5.0-3665-v3.image priorSource: 3680276! - -----STARTUP---- (23 April 2019 09:06:02) as /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/Cuis5.0-3665-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3665] on 15 March 2019 at 10:06:54 pm'! -!AutoCompleterMorph methodsFor: 'accessing' stamp: 'AY 3/15/2019 21:55:46' prior: 50434288! - selected: aNumber - - "Set the value of selected" - - ((aNumber between: 1 and: self entryCount) and: [ aNumber ~= selected ]) - ifTrue: [ - selected _ aNumber. - self isShowingSelectorDocumentation ifTrue: [ self showSelectorDocumentation ]]! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'AY 3/15/2019 21:54:52' prior: 50446583! - resetMenu - - | width newExtent | - self hideSelectorDocumentation. - - self calculateItemsPerPage. - - self firstVisible: 1. - self selected: self firstSelectableEntryIndex. - - width _ self calculateWidth. - newExtent _ width + 4 @ (self itemsPerPage * self itemHeight + 2). - - self morphPosition: originalPosition extent: newExtent. - "redraw is needed even if position and extent haven't changed" - self redrawNeeded ! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'AY 3/15/2019 21:56:00' prior: 50436479! - calculateItemsPerPage - - | itemsThatCanFit | - - itemsThatCanFit _ (DisplayScreen actualScreenSize y - originalPosition y - 2) // self itemHeight. - itemsPerPage _ (itemsThatCanFit min: self maxItemsPerPage) min: self entryCount. - -! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'AY 3/15/2019 21:56:10' prior: 50436582! - calculateWidth - - | width font | - - width _ 120. - font _ self class listFont. - - 1 - to: self entryCount - do: [ :index | width _ width max: (font widthOfString: (completer entries at: index) asString)]. - - self entryCount > self itemsPerPage ifTrue: [ width _ width + ScrollBar scrollbarThickness ]. - - ^ width ! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'AY 3/15/2019 21:55:40' prior: 50433589! - drawScrollBarMovementBarOn: aCanvas thickness: scrollbarThickness - - | height top bottom | - - height _ extent y - (2 * scrollbarThickness). - top _ (1.0 * self firstVisible-1 / self entryCount * height) ceiling + 1 + scrollbarThickness-1. - bottom _ (1.0 * self lastVisible / self entryCount * height) floor + 1 + scrollbarThickness -1. - aCanvas - fillRectangle: (extent x - scrollbarThickness+2@top corner: extent x-2 @ bottom) - color: `Color veryLightGray` ! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'AY 3/15/2019 21:54:24' prior: 50436606! - drawScrollBarOn: aCanvas - - | scrollbarThickness width | - - width _ extent x-2. - self entryCount > self itemsPerPage ifTrue: [ - scrollbarThickness _ ScrollBar scrollbarThickness. - width _ width - scrollbarThickness. - - self drawScrollBarRectangleOn: aCanvas thickness: scrollbarThickness. - self drawUpArrowOn: aCanvas thickness: scrollbarThickness. - self drawDownArrowOn: aCanvas thickness: scrollbarThickness. - self drawScrollBarMovementBarOn: aCanvas thickness: scrollbarThickness ]. - - ^width -! ! -!AutoCompleterMorph methodsFor: 'private' stamp: 'AY 3/15/2019 22:05:12' prior: 50436671! - firstVisible - - ^firstVisible min: self entryCount! ! -!AutoCompleterMorph methodsFor: 'private' stamp: 'AY 3/15/2019 22:02:14' prior: 50436676! - lastVisible - - ^self firstVisible + self itemsPerPage - 1 min: self entryCount! ! -!AutoCompleterMorph methodsFor: 'selector documentation' stamp: 'AY 3/15/2019 21:54:35' prior: 50436682! - selectorDefaultDocumentationLocation - - | relativeSelected | - - relativeSelected := (self selected - self firstVisible) min: self itemsPerPage - 1 max: 0. - - ^location externalizePosition: extent x@(relativeSelected * self itemHeight + 1). - - ! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3666-AutoCompleterInstVarEncapsulation-AngelYan-2019Mar15-21h54m-AY.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3665] on 17 March 2019 at 9:14:29 am'! -!PasteUpMorph methodsFor: 'accessing' stamp: 'GC 3/17/2019 08:16:08'! - handlesKeyboard - - ^ true ! ! -!BrowserWindow class methodsFor: 'GUI building' stamp: 'GC 3/17/2019 08:13:13'! - findClass - - | allClassNames | - - allClassNames _ Smalltalk classNames asOrderedCollection. - - self findClassFrom: allClassNames ifFound: [:foundClass | self fullOnClass: foundClass ] - - ! ! -!BrowserWindow class methodsFor: 'GUI building' stamp: 'GC 3/17/2019 08:15:15'! - findClassFrom: potentialClassNames ifFound: aBlock - - | classNames exactMatch foundClass index pattern toMatch | - - pattern _ ClassNameRequestMorph request: 'Class name or fragment?'. - pattern isEmpty ifTrue: [^ self flash]. - toMatch _ (pattern copyWithout: $.) asLowercase withBlanksTrimmed. - classNames _ (pattern last = $. or: [pattern last = $ ]) - ifTrue: [potentialClassNames select: [:nm | nm asLowercase = toMatch]] - ifFalse: [potentialClassNames select: [:n | n includesSubstring: toMatch caseSensitive: false]]. - classNames isEmpty ifTrue: [^ self flash]. - exactMatch _ classNames detect: [ :each | each asLowercase = toMatch] ifNone: nil. - - index _ classNames size = 1 - ifTrue: [ 1 ] - ifFalse: [ exactMatch - ifNil: [(PopUpMenu labelArray: classNames lines: #()) startUpMenu] - ifNotNil: [classNames addFirst: exactMatch. - (PopUpMenu labelArray: classNames lines: #(1)) startUpMenu]]. - - index = 0 ifTrue: [^ self flash]. - foundClass _ Smalltalk at: (classNames at: index) asSymbol. - - aBlock value: foundClass.! ! -!BrowserWindow class methodsFor: 'GUI building' stamp: 'GC 3/17/2019 08:15:28'! - fullOnClass: aClass - - self fullOnClass: aClass selector: nil! ! -!Theme methodsFor: 'keyboard shortcuts' stamp: 'HAW 3/17/2019 08:37:46'! - findClassIn: aWindow - - | isBrowserWindow | - - isBrowserWindow _ (aWindow class = BrowserWindow) or: [ aWindow class = HierarchyBrowserWindow ]. - isBrowserWindow - ifTrue: [ aWindow findClass ] - ifFalse: [ BrowserWindow findClass ]! ! -!TextEditor methodsFor: 'menu' stamp: 'HAW 3/17/2019 08:53:17' prior: 50396370! - getMenu - - ^(MenuMorph new defaultTarget: self) - addTitle: self class name; - addStayUpIcons; - addItemsFromDictionaries: `{ - { - #label -> 'Help...'. - #selector -> #openHelp. - #icon -> #helpIcon - } asDictionary. - nil. - { - #label -> 'Find...(F)'. - #selector -> #find. - #icon -> #findIcon - } asDictionary. - { - #label -> 'Find Again (g)'. - #selector -> #findAgain. - #icon -> #systemIcon - } asDictionary. - { - #label -> 'Use Selection for Find (j)'. - #selector -> #setSearchString. - #icon -> #saveAsIcon - } asDictionary. - nil. - { - #label -> 'Undo - multiple (z)'. - #selector -> #undo. - #icon -> #undoIcon - } asDictionary. - { - #label -> 'Redo - multiple (Z)'. - #selector -> #redo. - #icon -> #redoIcon - } asDictionary. - { - #label -> 'Undo / Redo history'. - #selector -> #offerUndoHistory. - #icon -> #changesIcon - } asDictionary. - nil. - { - #label -> 'Copy (c)'. - #selector -> #copySelection. - #icon -> #copyIcon - } asDictionary. - { - #label -> 'Cut (x)'. - #selector -> #cut. - #icon -> #cutIcon - } asDictionary. - { - #label -> 'Paste (v)'. - #selector -> #paste. - #icon -> #pasteIcon - } asDictionary. - { - #label -> 'Paste without Format'. - #selector -> #pasteString. - #icon -> #pasteIcon - } asDictionary. - { - #label -> 'Paste...'. - #selector -> #pasteRecent. - #icon -> #worldIcon - } asDictionary. - nil. - { - #label -> 'Toggle WordWrap'. - #selector -> #wrapOnOff. - #icon -> #genericTextIcon - } asDictionary. - { - #label -> 'Set Font... (k)'. - #selector -> #offerFontMenu. - #icon -> #preferencesDesktopFontIcon - } asDictionary. - { - #label -> 'Clear Font'. - #selector -> #clearFont. - #icon -> #newIcon - } asDictionary. - { - #label -> 'Set Default Font...'. - #selector -> #offerDefaultFontMenu. - #icon -> #fontXGenericIcon - } asDictionary. - { - #label -> 'Set Alignment...'. - #selector -> #chooseAlignment. - #icon -> #formatJustifyLeftIcon - } asDictionary. - }`! ! -!TextEditor class methodsFor: 'keyboard shortcut tables' stamp: 'HAW 3/17/2019 08:58:33' prior: 50423644! - basicCmdShortcutsSpec - " - Editor initialize - " - - "arranged in QWERTY keyboard order" - ^#( - #( $( #enclose: 'Enclose within ( and ), or remove enclosing ( and )') - #( $[ #enclose: 'Enclose within [ and ], or remove enclosing [ and ]') - #( ${ #enclose: 'Enclose within { and }, or remove enclosing { and }') - #( $' #enclose: 'Enclose within single quotes, or remove enclosing single quotes') - #( $" #enclose: 'Enclose within double quotes, or remove enclosing double quotes') - #( $` #enclose: 'Enclose within backticks, or remove enclosing backticks') - #( $< #enclose: 'Enclose within < and >, or remove enclosing < and >') - - #( $a #selectAll: 'Select all') - #( $F #find: 'Find') - #( $g #findAgain: 'Find again') - #( $h #help: 'Open this help') - #( $j #setSearchString: 'Set selection as search string for find again') - - #( $z #undo: 'Undo (multiple levels)') - #( $x #cut: 'Cut selection and store it in the Clipboard') - #( $c #copySelection: 'Copy selection to the Clipboard') - #( $v #paste: 'Paste Clipboard contents') - - #( $R #indent: 'Indent (move selection one tab-stap right)') - #( $Y #makeUppercase: 'Force selection to uppercase') - #( $U #changeLineEndsToLf: 'Convert line endings to LF characters (Cuis convention) in selection') - - #( $H #cursorTopHome: 'Move cursor to start of text') - #( $L #outdent: 'Outdent (move selection one tab-stop left)') - - #( $Z #redo: 'Redo (multiple levels)') - #( $X #makeLowercase: 'Force selection to lowercase') - #( $C #compareToClipboard: 'Compare argument to clipboard') - - #( $ #selectWord: 'Select the current word as with double clicking') - )! ! -!SmalltalkEditor class methodsFor: 'keyboard shortcut tables' stamp: 'HAW 3/17/2019 09:00:30' prior: 50412517! - cmdShortcutsSpec - " - Editor initialize - " - "arranged in QWERTY keyboard order" - ^#( - #( $r #acceptAndDebugTest: 'Saves method and debugs it') - #( $t #acceptAndTest: 'Saves method, runs it as test and then all tests in class. Opens debugger if error') - #( $y #acceptAndTestAll: 'Saves method, runs it as test and then all tests in class category. Opens debugger if error') - #( $i #inspectIt: 'Inspect it (selection is a valid expression, or selection is over an inspect-ilst)') - #( $p #printIt: 'Print it (selection is a valid expression)') - - #( $s #save: 'Save (i.e. accept)') - #( $d #doIt: 'Do it (selection is a valid expression)') - - #( $b #browseIt: 'Browse it (selection is a class name or cursor is over a class-list or message-list)') - #( $n #sendersOfIt: 'Senders of it (selection is a message selector or cursor is over a class-list or message-list)') - #( $m #implementorsOfIt: 'Implementors of it (selection is a message selector or cursor is over a class-list or message-list)') - - #( $E #methodStringsContainingit:'Method strings containing it') - #( $T #displayIfTrue: 'Insert #ifTrue:') - #( $I #exploreIt: 'Inspect via Object Explorer') - - #( $Q #argPrev: 'Previous argument') - #( $A #argNext: 'Next argument') - #( $D #debugIt: 'Debug it') -" #( $F #displayIfFalse: 'Insert #ifFalse:')" - #( $G #fileItIn: 'File in selection') - - #( $V #pasteInitials: 'Paste author initials') - #( $N #referencesToIt: 'References to it (selection is a class name, or cursor is over a class-list or message-list)') - )! ! -!SmalltalkEditor class methodsFor: 'menu' stamp: 'HAW 3/17/2019 08:53:38' prior: 50410993! - smalltalkEditorMenu2Options - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Find...(F)'. - #selector -> #find. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'Find Again (g)'. - #selector -> #findAgain. - #icon -> #systemIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Use Selection for Find (j)'. - #selector -> #setSearchString. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Undo - multiple (z)'. - #selector -> #undo. - #icon -> #undoIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Redo - multiple (Z)'. - #selector -> #redo. - #icon -> #redoIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'Undo / Redo history'. - #selector -> #offerUndoHistory. - #icon -> #changesIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Copy (c)'. - #selector -> #copySelection. - #icon -> #copyIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Cut (x)'. - #selector -> #cut. - #icon -> #cutIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'Paste (v)'. - #selector -> #paste. - #icon -> #pasteIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 40. - #label -> 'Paste without Format'. - #selector -> #pasteString. - #icon -> #pasteIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 50. - #label -> 'Paste...'. - #selector -> #pasteRecent. - #icon -> #worldIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'Toggle WordWrap'. - #selector -> #wrapOnOff. - #icon -> #genericTextIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'Set Font... (k)'. - #selector -> #offerFontMenu. - #icon -> #preferencesDesktopFontIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'Clear Font'. - #selector -> #clearFont. - #icon -> #newIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 40. - #label -> 'Set Default Font...'. - #selector -> #offerDefaultFontMenu. - #icon -> #fontXGenericIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'More...'. - #selector -> #openMenu. - #icon -> #listAddIcon - } asDictionary. - }` -! ! -!BrowserWindow methodsFor: 'commands' stamp: 'GC 3/17/2019 08:13:00' prior: 16793460! - findClass - - | scopedClassNames | - - scopedClassNames _ model potentialClassNames asOrderedCollection. - - self class findClassFrom: scopedClassNames ifFound: [:foundClass | - model selectCategoryForClass: foundClass. - model selectClass: foundClass ]! ! -!HandMorph methodsFor: 'events-processing' stamp: 'GC 3/17/2019 08:15:50' prior: 16851808! - startKeyboardDispatch: aKeyboardEvent - - | focusedElement | - - focusedElement _ self keyboardFocus ifNil: [ self world ]. - focusedElement handleFocusEvent: aKeyboardEvent. - - self mouseOverHandler processMouseOver: self lastMouseEvent! ! -!Theme methodsFor: 'keyboard shortcuts' stamp: 'HAW 3/17/2019 08:59:01' prior: 50381783! - keyStroke: aKeyboardEvent morph: aMorph - - aKeyboardEvent commandAltKeyPressed | aKeyboardEvent controlKeyPressed - ifFalse: [ ^ false ]. - - aKeyboardEvent keyValue = $w numericValue ifTrue: [ - aMorph owningWindow ifNotNil: [ :w | - (w morphContainsPoint: (w internalizeFromWorld: aKeyboardEvent eventPosition)) ifTrue: [ - w delete. - ^ true ]]]. - - aKeyboardEvent keyValue = $f numericValue ifTrue: [ - self findClassIn: aMorph owningWindow. - ^ true]. - - ^ false! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Editor initialize. -! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3667-GlobalFindClass-GastonCaruso-2019Mar17-08h12m-GC.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3667] on 18 March 2019 at 9:47:50 am'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 3/18/2019 09:47:05' prior: 50431505! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('AY' 'Angel Yan') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('bgs' 'Boris G. Shingarov') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('FGJ' 'Fernando Gasperi Jabalera') - #('FJG' 'Facundo Javier Gelatti') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('KLG' 'Gerald Klix') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MM' 'Mariano Montone') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('pmon' 'Paolo Montrasi') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('SLD' 'Steve Davies') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3668-AddBorisAndMarianoAsKnownAuthors-JuanVuletich-2019Mar18-09h47m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3668] on 18 March 2019 at 1:14:24 pm'! -!WriteStream methodsFor: 'character writing' stamp: 'jmv 3/18/2019 12:14:37'! - cr - "Append a cr character to the receiver. - Use this method when you specifically need a cr character. - In many cases, it is advisable to call #newLine" - - self nextPut: Character cr! ! -!Transcript class methodsFor: 'old Transcript compatibility' stamp: 'jmv 3/18/2019 12:12:55'! - cr - "Old Squeak Transcript protocol. Still used for some doIt examples. - In the older TranscriptStream, it added a CR character. - Now, finish the current incomplete entry." - - self finishEntry! ! -!FileIOAccessor methodsFor: 'utilities' stamp: 'jmv 3/18/2019 12:52:32' prior: 16842041! - fileSize: fileEntry - - | pathName f size | - pathName _ fileEntry pathName. - "At least on Linux 64 Cog, opening a directory as a stream and asking #size answers some absurd number: 9223372036854775807" - (self basicDirectoryExists: pathName) ifTrue: [^ nil ]. - f _ self concreteStreamClass new open: pathName forWrite: false. - f ifNil: [^ nil]. - size _ f size. - f close. - ^ size! ! -!FileIOAccessor methodsFor: 'file stream creation' stamp: 'jmv 3/18/2019 13:00:59' prior: 16842134! - privateReadOnlyFile: fileEntry - "Open the existing file with the given name in this directory for read-only access." - - | pathName | - pathName _ fileEntry pathName. - (self basicDirectoryExists: pathName) ifTrue: [ - "If it is a directory, the it is not a file, and the requested file does not exist." - ^ ((FileDoesNotExistException fileName: pathName) readOnly: true) signal ]. - ^(self concreteStreamClass new open: pathName forWrite: false) - ifNil: [ - "File does not exist..." - ((FileDoesNotExistException fileName: pathName) readOnly: true) signal ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3669-FileAccessorFixes-JuanVuletich-2019Mar18-13h14m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3665] on 17 March 2019 at 7:32:51 am'! -!TestCase methodsFor: 'assertions' stamp: 'HAW 3/17/2019 07:08:22'! - shouldFail: aBlock - - self should: aBlock raise: Exception ! ! - -TestCase removeSelector: #shouldFix:! - -TestCase removeSelector: #shouldFix:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3670-ShouldFail-HernanWilkinson-2019Mar17-06h57m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3665] on 17 March 2019 at 6:57:41 am'! - -ChangeSelector subclass: #ChangeSelectorKeepingParameters - instanceVariableNames: 'newSelectorKeywords currentImplementorMethodNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ChangeSelectorKeepingParameters category: #'Tools-Refactoring'! -ChangeSelector subclass: #ChangeSelectorKeepingParameters - instanceVariableNames: 'newSelectorKeywords currentImplementorMethodNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelectorKeepingParameters subclass: #ChangeKeywordsSelectorOrder - instanceVariableNames: 'changedOrder' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ChangeKeywordsSelectorOrder category: #'Tools-Refactoring'! -ChangeSelectorKeepingParameters subclass: #ChangeKeywordsSelectorOrder - instanceVariableNames: 'changedOrder' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelectorKeepingParameters subclass: #RenameSelector - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameSelector category: #'Tools-Refactoring'! -ChangeSelectorKeepingParameters subclass: #RenameSelector - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelectorApplier subclass: #ChangeSelectorKeepingParametersApplier - instanceVariableNames: 'newSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ChangeSelectorKeepingParametersApplier category: #'Tools-Refactoring'! -ChangeSelectorApplier subclass: #ChangeSelectorKeepingParametersApplier - instanceVariableNames: 'newSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelectorKeepingParametersApplier subclass: #ChangeKeywordsSelectorOrderApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ChangeKeywordsSelectorOrderApplier category: #'Tools-Refactoring'! -ChangeSelectorKeepingParametersApplier subclass: #ChangeKeywordsSelectorOrderApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelectorKeepingParametersApplier subclass: #RenameSelectorApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameSelectorApplier category: #'Tools-Refactoring'! -ChangeSelectorKeepingParametersApplier subclass: #RenameSelectorApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'HAW 3/17/2019 05:43:39'! - withIndexDo: elementAndIndexBlock separatedBy: separatorBlock - "Evaluate the elementAndIndexBlock for all elements in the receiver, - and evaluate the separatorBlock between." - - 1 to: self size do: [:index | - index = 1 ifFalse: [separatorBlock value]. - elementAndIndexBlock value: (self at: index) value: index]! ! -!CodeWindow methodsFor: 'as yet unclassified' stamp: 'HAW 3/16/2019 17:58:08'! - changeKeywordOrder - - model selectedMessageName ifNotNil: [ :oldSelector | - ChangeKeywordsSelectorOrderApplier createAndValueHandlingExceptions: [ - ChangeKeywordsSelectorOrderApplier on: model for: oldSelector in: model selectedClassOrMetaClass ]].! ! -!TestCase methodsFor: 'assertions' stamp: 'HAW 3/17/2019 06:29:53'! - shouldntFail: aBlock - - self shouldnt: aBlock raise: Error! ! -!ChangeSelectorKeepingParameters methodsFor: 'create new implementors - private' stamp: 'HAW 3/17/2019 06:24:07'! - addImplementorSelectorRanges: aKeywordRange at: index to: rangesToNewKeywords - - self subclassResponsibility ! ! -!ChangeSelectorKeepingParameters methodsFor: 'create new implementors - private' stamp: 'HAW 3/17/2019 06:24:07'! - implementorNewSourceCodeOf: anImplementor - - | newSource rangesToNewKeywords | - - rangesToNewKeywords := OrderedCollection new. - currentImplementorMethodNode := anImplementor methodNode. - - currentImplementorMethodNode selectorKeywordsPositions withIndexDo: [ :aKeywordRange :index | - self addImplementorSelectorRanges: aKeywordRange at: index to: rangesToNewKeywords ]. - - newSource := anImplementor sourceCode copyReplacing: rangesToNewKeywords. - ^newSource! ! -!ChangeSelectorKeepingParameters methodsFor: 'rename senders - private' stamp: 'HAW 3/17/2019 06:02:54'! - addMessageSendSelectorKeywordRangesOf: aMethodNode to: rangesToKeywords - - | oldSelectorKeywordsRanges | - - oldSelectorKeywordsRanges := aMethodNode messageSendSelectorKeywordPositionsOf: oldSelector ifAbsent: [ #() ]. - oldSelectorKeywordsRanges do: [ :aMessageSendSelectorRanges | - aMessageSendSelectorRanges withIndexDo: [ :aRange :index | rangesToKeywords add: aRange -> (newSelectorKeywords at: index) ]]. - ! ! -!ChangeSelectorKeepingParameters methodsFor: 'initialization' stamp: 'HAW 3/17/2019 06:03:03'! - initializeFrom: anOldSelector to: aNewSelector implementors: aCollectionOfImplementors senders: aCollectionOfSenders - - super initializeFrom: anOldSelector to: aNewSelector implementors: aCollectionOfImplementors senders: aCollectionOfSenders. - - newSelectorKeywords := newSelector keywords. - ! ! -!ChangeSelectorKeepingParameters class methodsFor: 'instance creation' stamp: 'HAW 3/17/2019 05:58:22'! - from: anOldSelector to: aNewSelector implementors: aCollectionOfImplementors senders: aCollectionOfSenders - - self assertIsValidToRenameFrom: anOldSelector to: aNewSelector. - self assertIsNotEmpty: aCollectionOfImplementors signalMessageText: self implementorsCanNotBeEmptyErrorMessage. - self assertAllImplementors: aCollectionOfImplementors haveSame: anOldSelector. - self assertNoImplementorClassIn: aCollectionOfImplementors implements: aNewSelector. - self assertAllSenders: aCollectionOfSenders send: anOldSelector. - - self warnIfImplementionsOf: aNewSelector overridesImplementationInSuperclassesOf: aCollectionOfImplementors. - - ^self new initializeFrom: anOldSelector to: aNewSelector implementors: aCollectionOfImplementors senders: aCollectionOfSenders - ! ! -!ChangeSelectorKeepingParameters class methodsFor: 'instance creation' stamp: 'HAW 3/17/2019 05:58:34'! - from: anOldSelector to: aNewSelector in: aClassToRefactor - - | implementors senders | - - implementors := OrderedCollection new. - senders := OrderedCollection new. - - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders forClassAndMetaOf: aClassToRefactor theNonMetaClass. - - ^self from: anOldSelector to: aNewSelector implementors: implementors senders: senders ! ! -!ChangeSelectorKeepingParameters class methodsFor: 'instance creation' stamp: 'HAW 3/17/2019 05:58:38'! - from: anOldSelector to: aNewSelector inCategoriesAndHierarchyOf: aClass organizedBy: anOrganization - - | implementors senders | - - implementors := IdentitySet new. - senders := IdentitySet new. - - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategoriesAndHierarchyOf: aClass organizedBy: anOrganization. - - ^self from: anOldSelector to: aNewSelector implementors: implementors senders: senders -! ! -!ChangeSelectorKeepingParameters class methodsFor: 'instance creation' stamp: 'HAW 3/17/2019 05:58:43'! - from: anOldSelector to: aNewSelector inCategoryOf: aClass organizedBy: anOrganization - - | implementors senders | - - implementors := OrderedCollection new. - senders := OrderedCollection new. - - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategory: aClass category organizedBy: anOrganization. - - ^self from: anOldSelector to: aNewSelector implementors: implementors senders: senders -! ! -!ChangeSelectorKeepingParameters class methodsFor: 'instance creation' stamp: 'HAW 3/17/2019 05:58:47'! - from: anOldSelector to: aNewSelector inHierarchyOf: aClass - - | implementors senders | - - implementors := OrderedCollection new. - senders := OrderedCollection new. - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inHierarchyOf: aClass. - - ^self from: anOldSelector to: aNewSelector implementors: implementors senders: senders - - ! ! -!ChangeSelectorKeepingParameters class methodsFor: 'instance creation' stamp: 'HAW 3/17/2019 05:58:52'! - from: anOldSelector to: aNewSelector inSystem: aSystem - - | implementors senders | - - implementors := OrderedCollection new. - senders := OrderedCollection new. - - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inSystem: aSystem. - - ^self from: anOldSelector to: aNewSelector implementors: implementors senders: senders - ! ! -!ChangeSelectorKeepingParameters class methodsFor: 'pre-conditions' stamp: 'HAW 3/17/2019 05:59:02'! - assert: aNewSelector hasTheSameNumberOfArgumentsAs: anOldSelector - - aNewSelector numArgs ~= anOldSelector numArgs ifTrue: [ self signalNewSelector: aNewSelector doesNotHaveSameNumberOfArgumentsAs: anOldSelector ]! ! -!ChangeSelectorKeepingParameters class methodsFor: 'pre-conditions' stamp: 'HAW 3/17/2019 05:59:07'! - assert: aNewSelector isNotEqualTo: anOldSelector - - aNewSelector = anOldSelector ifTrue: [ self signalNewSelectorEqualToOldSelector]! ! -!ChangeSelectorKeepingParameters class methodsFor: 'pre-conditions' stamp: 'HAW 3/17/2019 05:59:44'! - assert: aNewSelector isOfSameTypeAs: anOldSelector - - (self isRenamingBetweenBinary: anOldSelector andKeywordOfOneParameter: aNewSelector) ifTrue: [ ^self ]. - (self isRenamingBetweenBinary: aNewSelector andKeywordOfOneParameter: anOldSelector) ifTrue: [ ^self ]. - - aNewSelector precedence ~= anOldSelector precedence ifTrue: [ - self signalNewSelector: aNewSelector isNotOfSameTypeAs: anOldSelector ]! ! -!ChangeSelectorKeepingParameters class methodsFor: 'pre-conditions' stamp: 'HAW 3/17/2019 05:59:14'! - assertIsNotEmpty: aCollection signalMessageText: errorMessageText - - aCollection isEmpty ifTrue: [ self refactoringError: errorMessageText ].! ! -!ChangeSelectorKeepingParameters class methodsFor: 'pre-conditions' stamp: 'HAW 3/17/2019 05:59:19'! - assertIsValidToRenameFrom: anOldSelector to: aNewSelector - - self assertIsNotEmpty: anOldSelector signalMessageText: self oldSelectorCanNotBeEmptyErrorMessage. - self assertIsNotEmpty: aNewSelector signalMessageText: self newSelectorCanNotBeEmptyErrorMessage. - self assert: aNewSelector isNotEqualTo: anOldSelector. - self assert: aNewSelector isOfSameTypeAs: anOldSelector. - self assert: aNewSelector hasTheSameNumberOfArgumentsAs: anOldSelector. - ! ! -!ChangeSelectorKeepingParameters class methodsFor: 'pre-conditions' stamp: 'HAW 3/17/2019 05:59:23'! - assertNoImplementorClassIn: implementorsCollection implements: aNewSelector - - | classesImplementingNewSelector | - - classesImplementingNewSelector := implementorsCollection - select: [ :anImplementor | anImplementor methodClass includesSelector: aNewSelector ] - thenCollect: [ :anImplementor | anImplementor methodClass ]. - - classesImplementingNewSelector notEmpty ifTrue: [ self signalNewSelector: aNewSelector implementedInAll: classesImplementingNewSelector ]! ! -!ChangeSelectorKeepingParameters class methodsFor: 'pre-conditions' stamp: 'HAW 3/17/2019 05:59:50'! - isRenamingBetweenBinary: aPotentiallyBinarySelector andKeywordOfOneParameter: aPotentiallyKeywordSelector - - ^aPotentiallyBinarySelector isInfix - and: [ aPotentiallyKeywordSelector isKeyword - and: [ aPotentiallyKeywordSelector numArgs = 1 ]] -! ! -!ChangeSelectorKeepingParameters class methodsFor: 'pre-conditions' stamp: 'HAW 3/17/2019 05:59:54'! - warnIfImplementionsOf: aNewSelector overridesImplementationInSuperclassesOf: implementorsCollection - - implementorsCollection do: [:anImplementor | - anImplementor methodClass - withSuperclassThatIncludesSelector: aNewSelector - do: [ :aSuperclass | self warnImplementionOf: aNewSelector in: anImplementor methodClass willOverrideImplementationIn: aSuperclass ] - ifNone: []]! ! -!ChangeSelectorKeepingParameters class methodsFor: 'exceptions' stamp: 'HAW 3/17/2019 06:00:00'! - errorMessageForNewSelector: aNewSelector doesNotHaveSameNumberOfArgumentsAs: anOldSelector - - ^'New selector #', aNewSelector, ' does not have the same number of arguments as #', anOldSelector ! ! -!ChangeSelectorKeepingParameters class methodsFor: 'exceptions' stamp: 'HAW 3/17/2019 06:00:04'! - errorMessageForNewSelector: aNewSelector implementedInAll: classesImplementingNewSelector - - ^'Can not rename because #', aNewSelector, ' is implemented in: ', classesImplementingNewSelector asCommaStringAnd ! ! -!ChangeSelectorKeepingParameters class methodsFor: 'exceptions' stamp: 'HAW 3/17/2019 06:00:07'! - errorMessageForNewSelector: aNewSelector isNotOfSameTypeAs: anOldSelector - - ^'New selector #', aNewSelector, ' is not of same type as #', anOldSelector ! ! -!ChangeSelectorKeepingParameters class methodsFor: 'exceptions' stamp: 'HAW 3/17/2019 06:00:11'! - implementorsCanNotBeEmptyErrorMessage - - ^'There are no methods to rename'! ! -!ChangeSelectorKeepingParameters class methodsFor: 'exceptions' stamp: 'HAW 3/17/2019 06:00:16'! - newSelectorCanNotBeEmptyErrorMessage - - ^'New selector can not be empty'! ! -!ChangeSelectorKeepingParameters class methodsFor: 'exceptions' stamp: 'HAW 3/17/2019 06:00:19'! - newSelectorEqualToOldSelectorErrorMessage - - ^'There is nothing to rename when new selector is equals to old selector'! ! -!ChangeSelectorKeepingParameters class methodsFor: 'exceptions' stamp: 'HAW 3/17/2019 06:00:23'! - oldSelectorCanNotBeEmptyErrorMessage - - ^'Old selector can not be empty'! ! -!ChangeSelectorKeepingParameters class methodsFor: 'exceptions' stamp: 'HAW 3/17/2019 06:00:27'! - signalNewSelector: aNewSelector doesNotHaveSameNumberOfArgumentsAs: anOldSelector - - self refactoringError: (self errorMessageForNewSelector: aNewSelector doesNotHaveSameNumberOfArgumentsAs: anOldSelector).! ! -!ChangeSelectorKeepingParameters class methodsFor: 'exceptions' stamp: 'HAW 3/17/2019 06:00:30'! - signalNewSelector: aNewSelector implementedInAll: classesImplementingNewSelector - - self refactoringError: (self errorMessageForNewSelector: aNewSelector implementedInAll: classesImplementingNewSelector).! ! -!ChangeSelectorKeepingParameters class methodsFor: 'exceptions' stamp: 'HAW 3/17/2019 06:00:33'! - signalNewSelector: aNewSelector isNotOfSameTypeAs: anOldSelector - - self refactoringError: (self errorMessageForNewSelector: aNewSelector isNotOfSameTypeAs: anOldSelector).! ! -!ChangeSelectorKeepingParameters class methodsFor: 'exceptions' stamp: 'HAW 3/17/2019 06:00:37'! - signalNewSelectorEqualToOldSelector - - self refactoringError: self newSelectorEqualToOldSelectorErrorMessage.! ! -!ChangeSelectorKeepingParameters class methodsFor: 'warnings' stamp: 'HAW 3/17/2019 06:00:42'! - warnImplementionOf: aNewSelector in: aClass willOverrideImplementationIn: aSuperclass - - self refactoringWarning: (self warningMessageForImplementationOf: aNewSelector in: aClass willOverrideImplementationIn: aSuperclass).! ! -!ChangeSelectorKeepingParameters class methodsFor: 'warnings' stamp: 'HAW 3/17/2019 06:00:46'! -warningMessageForImplementationOf: aNewSelector in: aClass willOverrideImplementationIn: aSuperclass - - ^'Implemention of #', aNewSelector, ' in ', aClass name, ' will override implementation in ', aSuperclass name! ! -!ChangeKeywordsSelectorOrder methodsFor: 'initialization' stamp: 'HAW 3/17/2019 06:14:09'! - initializeChangedOrder: aChangeOrder - - changedOrder := aChangeOrder ! ! -!ChangeKeywordsSelectorOrder methodsFor: 'create new implementors - private' stamp: 'HAW 3/17/2019 06:24:07'! - addImplementorSelectorRanges: aKeywordRange at: index to: rangesToNewKeywords - - rangesToNewKeywords add: aKeywordRange -> (newSelectorKeywords at: index). - rangesToNewKeywords add: - (currentImplementorMethodNode parameterDefinitionPositionAt: index) -> - (currentImplementorMethodNode argumentNames at: (changedOrder at: index))! ! -!ChangeKeywordsSelectorOrder class methodsFor: 'instance creation' stamp: 'HAW 3/17/2019 06:11:48'! - from: anOldSelector to: aNewSelector implementors: aCollectionOfImplementors senders: aCollectionOfSenders - - | changedOrder | - - self assertIsKeywordWithMoreThanOneParameter: anOldSelector. - changedOrder := self changedOrderFrom: anOldSelector to: aNewSelector. - - ^ (super from: anOldSelector to: aNewSelector implementors: aCollectionOfImplementors senders: aCollectionOfSenders) - initializeChangedOrder: changedOrder -! ! -!ChangeKeywordsSelectorOrder class methodsFor: 'pre-conditions' stamp: 'HAW 3/17/2019 06:18:21'! - assertIsKeywordWithMoreThanOneParameter: anOldSelector - - (anOldSelector isKeyword and: [ anOldSelector numArgs > 1 ]) ifFalse: [ self signalSelectorToChangeIsNotKeywordWithMoreThanOneParameter ]! ! -!ChangeKeywordsSelectorOrder class methodsFor: 'exceptions' stamp: 'HAW 3/16/2019 17:45:39'! - newSelectorDoesNotIncludeOldSelectorKeywordsErrorMessage - - ^'New selector keywords do not include old selector keywords'! ! -!ChangeKeywordsSelectorOrder class methodsFor: 'exceptions' stamp: 'HAW 3/17/2019 06:18:58'! - selectorToChangeIsNotKeywordWithMoreThanOneParameterErrorMessage - - ^'Can only change a selector order for keyword messages with more that one parameter'! ! -!ChangeKeywordsSelectorOrder class methodsFor: 'exceptions' stamp: 'HAW 3/16/2019 17:45:39'! - signalNewSelectorDoesNotIncludeOldSelectorKeywords - - self refactoringError: self newSelectorDoesNotIncludeOldSelectorKeywordsErrorMessage! ! -!ChangeKeywordsSelectorOrder class methodsFor: 'exceptions' stamp: 'HAW 3/17/2019 06:18:58'! - signalSelectorToChangeIsNotKeywordWithMoreThanOneParameter - - self refactoringError: self selectorToChangeIsNotKeywordWithMoreThanOneParameterErrorMessage! ! -!ChangeKeywordsSelectorOrder class methodsFor: 'changed order' stamp: 'HAW 3/17/2019 06:13:43'! - changedOrderFrom: anOldSelector to: aNewSelector - - | changedOrder newSelectorKeywords | - - changedOrder := Dictionary new. - newSelectorKeywords := aNewSelector keywords. - anOldSelector keywords withIndexDo: [ :keyword :index | - changedOrder - at: (newSelectorKeywords indexOf: keyword ifAbsent: [ self signalNewSelectorDoesNotIncludeOldSelectorKeywords ]) - put: index ]. - - ^changedOrder ! ! -!RenameSelector methodsFor: 'create new implementors - private' stamp: 'HAW 3/17/2019 06:24:07'! - addImplementorSelectorRanges: aKeywordRange at: index to: rangesToNewKeywords - - rangesToNewKeywords add: aKeywordRange -> (newSelectorKeywords at: index) ! ! -!ChangeSelectorKeepingParametersApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 3/17/2019 06:52:15'! - askNewSelector - - | enteredString | - - enteredString := self request: 'Enter new selector:' initialAnswer: oldSelector. - newSelector := enteredString withBlanksTrimmed asSymbol. - -! ! -!ChangeSelectorKeepingParametersApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 3/17/2019 06:52:23'! - assertCanRenameSelector - - self refactoringClass assertIsValidToRenameFrom: oldSelector to: newSelector. - ! ! -!ChangeSelectorKeepingParametersApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 3/17/2019 06:52:38'! - requestRefactoringParameters - - self - askNewSelector; - assertCanRenameSelector - ! ! -!ChangeSelectorKeepingParametersApplier methodsFor: 'refactoring - creation' stamp: 'HAW 3/17/2019 06:52:28'! - createRefactoring - - ^self refactoringClass from: oldSelector to: newSelector implementors: implementors senders: senders. - ! ! -!ChangeKeywordsSelectorOrderApplier methodsFor: 'refactoring - creation' stamp: 'HAW 3/16/2019 17:55:35'! - refactoringClass - - ^ChangeKeywordsSelectorOrder ! ! -!ChangeKeywordsSelectorOrderApplier class methodsFor: 'pre-conditions' stamp: 'HAW 3/17/2019 06:50:17'! - assertCanApplyRefactoringFor: aSelector in: aClass - - ChangeKeywordsSelectorOrder assertIsKeywordWithMoreThanOneParameter: aSelector ! ! -!RefactoringMenues class methodsFor: 'browser menues' stamp: 'HAW 3/17/2019 06:46:00' prior: 50446088! - messsageRefactoringMenuOptions - - ^ `{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'rename... (R)'. - #selector -> #renameSelector. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 15. - #label -> 'change keyword order...'. - #selector -> #changeKeywordOrder. - #icon -> #sendReceiveIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'add parameter...'. - #selector -> #addParameter. - #icon -> #listAddIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'remove parameter...'. - #selector -> #removeParameter. - #icon -> #listRemoveIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'push up'. - #selector -> #pushUpSelector. - #icon -> #goTopIcon - } asDictionary. - }`. - - ! ! - -RenameSelectorApplier removeSelector: #askNewSelector! - -RenameSelectorApplier removeSelector: #askNewSelector! - -RenameSelectorApplier removeSelector: #assertCanRenameSelector! - -RenameSelectorApplier removeSelector: #assertCanRenameSelector! - -RenameSelectorApplier removeSelector: #createRefactoring! - -RenameSelectorApplier removeSelector: #createRefactoring! - -RenameSelectorApplier removeSelector: #requestRefactoringParameters! - -RenameSelectorApplier removeSelector: #requestRefactoringParameters! - -ChangeKeywordsSelectorOrderApplier class removeSelector: #m1! - -RenameSelector class removeSelector: #assert:hasTheSameNumberOfArgumentsAs:! - -RenameSelector class removeSelector: #assert:hasTheSameNumberOfArgumentsAs:! - -RenameSelector class removeSelector: #assert:isNotEqualTo:! - -RenameSelector class removeSelector: #assert:isNotEqualTo:! - -RenameSelector class removeSelector: #assert:isOfSameTypeAs:! - -RenameSelector class removeSelector: #assert:isOfSameTypeAs:! - -RenameSelector class removeSelector: #assertIsNotEmpty:signalMessageText:! - -RenameSelector class removeSelector: #assertIsNotEmpty:signalMessageText:! - -RenameSelector class removeSelector: #assertIsValidToRenameFrom:to:! - -RenameSelector class removeSelector: #assertIsValidToRenameFrom:to:! - -RenameSelector class removeSelector: #assertNoImplementorClassIn:implements:! - -RenameSelector class removeSelector: #assertNoImplementorClassIn:implements:! - -RenameSelector class removeSelector: #errorMessageForNewSelector:doesNotHaveSameNumberOfArgumentsAs:! - -RenameSelector class removeSelector: #errorMessageForNewSelector:doesNotHaveSameNumberOfArgumentsAs:! - -RenameSelector class removeSelector: #errorMessageForNewSelector:implementedInAll:! - -RenameSelector class removeSelector: #errorMessageForNewSelector:implementedInAll:! - -RenameSelector class removeSelector: #errorMessageForNewSelector:isNotOfSameTypeAs:! - -RenameSelector class removeSelector: #errorMessageForNewSelector:isNotOfSameTypeAs:! - -RenameSelector class removeSelector: #from:to:implementors:senders:! - -RenameSelector class removeSelector: #from:to:implementors:senders:! - -RenameSelector class removeSelector: #from:to:in:! - -RenameSelector class removeSelector: #from:to:in:! - -RenameSelector class removeSelector: #from:to:inCategoriesAndHierarchyOf:organizedBy:! - -RenameSelector class removeSelector: #from:to:inCategoriesAndHierarchyOf:organizedBy:! - -RenameSelector class removeSelector: #from:to:inCategoryOf:organizedBy:! - -RenameSelector class removeSelector: #from:to:inCategoryOf:organizedBy:! - -RenameSelector class removeSelector: #from:to:inHierarchyOf:! - -RenameSelector class removeSelector: #from:to:inHierarchyOf:! - -RenameSelector class removeSelector: #from:to:inSystem:! - -RenameSelector class removeSelector: #from:to:inSystem:! - -RenameSelector class removeSelector: #implementorsCanNotBeEmptyErrorMessage! - -RenameSelector class removeSelector: #implementorsCanNotBeEmptyErrorMessage! - -RenameSelector class removeSelector: #isRenamigBetweenBinary:andKeywordOfOneParameter:! - -RenameSelector class removeSelector: #isRenamigBetweenBinary:andKeywordOfOneParameter:! - -RenameSelector class removeSelector: #isRenamingBetweenBinary:andKeywordOfOneParameter:! - -RenameSelector class removeSelector: #newSelectorCanNotBeEmptyErrorMessage! - -RenameSelector class removeSelector: #newSelectorCanNotBeEmptyErrorMessage! - -RenameSelector class removeSelector: #newSelectorEqualToOldSelectorErrorMessage! - -RenameSelector class removeSelector: #newSelectorEqualToOldSelectorErrorMessage! - -RenameSelector class removeSelector: #oldSelectorCanNotBeEmptyErrorMessage! - -RenameSelector class removeSelector: #oldSelectorCanNotBeEmptyErrorMessage! - -RenameSelector class removeSelector: #signalNewSelector:doesNotHaveSameNumberOfArgumentsAs:! - -RenameSelector class removeSelector: #signalNewSelector:doesNotHaveSameNumberOfArgumentsAs:! - -RenameSelector class removeSelector: #signalNewSelector:implementedInAll:! - -RenameSelector class removeSelector: #signalNewSelector:implementedInAll:! - -RenameSelector class removeSelector: #signalNewSelector:isNotOfSameTypeAs:! - -RenameSelector class removeSelector: #signalNewSelector:isNotOfSameTypeAs:! - -RenameSelector class removeSelector: #signalNewSelectorEqualToOldSelector! - -RenameSelector class removeSelector: #signalNewSelectorEqualToOldSelector! - -RenameSelector class removeSelector: #warnIfImplementionsOf:overridesImplementationInSuperclassesOf:! - -RenameSelector class removeSelector: #warnIfImplementionsOf:overridesImplementationInSuperclassesOf:! - -RenameSelector class removeSelector: #warnImplementionOf:in:willOverrideImplementationIn:! - -RenameSelector class removeSelector: #warnImplementionOf:in:willOverrideImplementationIn:! - -RenameSelector class removeSelector: #warningMessageForImplementationOf:in:willOverrideImplementationIn:! - -RenameSelector class removeSelector: #warningMessageForImplementationOf:in:willOverrideImplementationIn:! - -RenameSelector removeSelector: #addMessageSendSelectorKeywordRangesOf:to:! - -RenameSelector removeSelector: #addMessageSendSelectorKeywordRangesOf:to:! - -RenameSelector removeSelector: #addRanges:at:to:! - -RenameSelector removeSelector: #implementorNewSourceCodeOf:! - -RenameSelector removeSelector: #implementorNewSourceCodeOf:! - -RenameSelector removeSelector: #initializeFrom:to:implementors:senders:! - -RenameSelector removeSelector: #initializeFrom:to:implementors:senders:! - -ChangeKeywordsSelectorOrder class removeSelector: #assertIsNotUnary:! - -ChangeKeywordsSelectorOrder class removeSelector: #assertIsValidToRenameFrom:to:! - -ChangeKeywordsSelectorOrder class removeSelector: #canChangeOrderOfKeywordsInKeywordMessagesErrorDescription! - -ChangeKeywordsSelectorOrder class removeSelector: #canOnlyChangeSelectorOrderForKeywordMessagesWithMoreThanOneParameterErrorDescription! - -ChangeKeywordsSelectorOrder class removeSelector: #cannotChangeSelectorOrderForAUnaryMessage! - -ChangeKeywordsSelectorOrder class removeSelector: #cannotChangeSelectorOrderForAnUnaryMessage! - -ChangeKeywordsSelectorOrder class removeSelector: #newSelectorDoesNotIncludeOldSelectorKeywords! - -ChangeKeywordsSelectorOrder class removeSelector: #signalCanChangeOrderOfKeywordsInKeywordMessages! - -ChangeKeywordsSelectorOrder class removeSelector: #signalCannotChangeSelectorOrderForAUnaryMessage! - -ChangeKeywordsSelectorOrder class removeSelector: #signalCannotChangeSelectorOrderForAnUnaryMessage! - -ChangeKeywordsSelectorOrder removeSelector: #addRanges:at:to:! - -ChangeKeywordsSelectorOrder removeSelector: #apply! - -ChangeKeywordsSelectorOrder removeSelector: #implementorNewSourceCodeOf:! - -ChangeKeywordsSelectorOrder removeSelector: #initializeChangeOrder:! - -ChangeKeywordsSelectorOrder removeSelector: #initializeRenameRefactoring:! - -ChangeSelectorKeepingParameters removeSelector: #addRanges:at:to:! - -ChangeSelectorKeepingParameters subclass: #RenameSelector - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameSelector category: #'Tools-Refactoring'! -ChangeSelectorKeepingParameters subclass: #RenameSelector - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelectorKeepingParametersApplier subclass: #RenameSelectorApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameSelectorApplier category: #'Tools-Refactoring'! -ChangeSelectorKeepingParametersApplier subclass: #RenameSelectorApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3671-ChangeKeywordsSelectorOrder-HernanWilkinson-2019Mar16-16h37m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3610] on 17 March 2019 at 6:14:00 pm'! -!TextModel methodsFor: 'as yet unclassified' stamp: 'jpb 3/17/2019 18:09:39'! - saveOn: stream as: format - "Saves the model to the given stream" - stream binary. - stream nextPutAll: self actualContents asString.! ! -!SystemWindow methodsFor: 'user interface' stamp: 'jpb 3/17/2019 18:12:16'! - saveContents - "Prompts the user for a file name and saves the contents to the file" - | fileName | - self hasSaveAs ifFalse: [^self]. - - fileName _ FillInTheBlankMorph request: 'Filename'. - - fileName isEmptyOrNil - ifTrue: [ self notifyUserWith: 'Contents not saved'] - ifFalse: [ self saveContentsTo: fileName ].! ! -!SystemWindow methodsFor: 'user interface' stamp: 'jpb 3/17/2019 18:12:28'! - saveContentsTo: fileName - "Saves the contents to the given filename" - | stream | - self hasSaveAs ifFalse: [^self]. - - stream _ StandardFileStream new. - stream open: fileName forWrite: true. - - model saveOn: stream as: 'text/plain'. - - stream closed ifFalse: [stream close]. - self notifyUserWith: 'Contents saved'.! ! -!SystemWindow methodsFor: 'menu' stamp: 'jpb 3/16/2019 17:00:59'! - addTileResizerMenuTo: aMenu - "We can look at preferences here to decide what too do" - (Preferences tileResizerInWindowMenu) ifFalse: [ - aMenu add: 'resize full' action: #resizeFull icon: #resizeFullIcon; - add: 'resize top' action: #resizeTop icon: #resizeTopIcon; - add: 'resize left' action: #resizeLeft icon: #resizeLeftIcon; - add: 'resize bottom' action: #resizeBottom icon: #resizeBottomIcon; - add: 'resize right' action: #resizeRight icon: #resizeRightIcon; - add: 'resize top left' action: #resizeTopLeft icon: #resizeTopLeftIcon; - add: 'resize top right' action: #resizeTopRight icon: #resizeTopRightIcon; - add: 'resize bottom left' action: #resizeBottomLeft icon: #resizeBottomLeftIcon; - add: 'resize bottom right' action: #resizeBottomRight icon: #resizeBottomRightIcon] - ifTrue: [ |resizeMorph| - "Use embedded resize morph" - resizeMorph _ TileResizeMorph new - selectionColor: (self widgetsColor adjustSaturation: -0.2 brightness: 0.25) ; - action: [:resize | |resizeMsg| - resizeMsg _ ('resize', resize asString capitalized) asSymbol. - self perform: resizeMsg. - aMenu delete]; - yourself. - aMenu addMorphBack: resizeMorph]. - ^aMenu.! ! -!SystemWindow methodsFor: 'user interface' stamp: 'jpb 3/17/2019 17:49:20'! - hasSaveAs - "Returns true if the window has a model which can be saved to a file" - ^model respondsTo: #saveOn:as:! ! -!SystemWindow methodsFor: 'user interface' stamp: 'jpb 3/17/2019 17:30:24'! -notifyUserWith: message - "Notifies the user with a message and an 'ok' button" - | morph | - morph _ MenuMorph new. - morph addTitle: message. - morph add: 'Ok' action: nil. - morph openInWorld.! ! -!SystemWindow methodsFor: 'menu' stamp: 'jpb 3/16/2019 17:13:12'! - addWindowControlTo: aMenu - - aMenu - add: 'send to back' action: #sendToBack icon: #goBottomIcon; - add: 'make next-to-topmost' action: #makeSecondTopmost icon: #goUpIcon; - addLine; - add: (self isSticky ifTrue: [ 'make draggable' ] ifFalse: [ 'make undraggable' ]) - action: #toggleStickiness icon: (self isSticky ifFalse: [#pushPinIcon]); - addLine; - add: 'close' action: #delete icon: #closeIcon; - add: 'collapse' action: #collapse icon: #collapseIcon; - add: 'expand / contract' action: #expandBoxHit icon: #expandIcon; - addLine; - add: 'resize...' action: #resize. - - ^aMenu! ! -!SystemWindow methodsFor: 'menu' stamp: 'jpb 3/17/2019 17:42:09' prior: 50413252! - buildWindowMenu - - | aMenu | - - aMenu _ MenuMorph new defaultTarget: self. - - aMenu - add: 'change title...' action: #relabel icon: #saveAsIcon; - add: 'window color...' action: #setWindowColor icon: #graphicsIcon. - - self hasSaveAs - ifTrue: [ aMenu add: 'Save as ...' action: #saveContents icon: #saveAsIcon ]. - - aMenu - addLine. - - self addWindowControlTo: aMenu. - self addTileResizerMenuTo: aMenu. - - ^ aMenu! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3672-text-saveAs-JosefPhilipBernhart-2019Mar17-18h07m-jpb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3672] on 19 March 2019 at 12:25:43 am'! - -"Change Set: 3673-CuisCore-AuthorName-2019Mar19-00h10m -Date: 19 March 2019 -Author: Nahuel Garbezza - -Support navigation between PluggableListMorph using left and right arrows. Refactored the key events handler"! - -PluggableScrollPane subclass: #PluggableListMorph - instanceVariableNames: 'list getListSelector getIndexSelector setIndexSelector keystrokeActionSelector autoDeselect lastKeystrokeTime lastKeystrokes doubleClickSelector menuGetter mainView leftSibling rightSibling ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #PluggableListMorph category: #'Morphic-Views'! -PluggableScrollPane subclass: #PluggableListMorph - instanceVariableNames: 'list getListSelector getIndexSelector setIndexSelector keystrokeActionSelector autoDeselect lastKeystrokeTime lastKeystrokes doubleClickSelector menuGetter mainView leftSibling rightSibling' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! -!PluggableListMorph methodsFor: 'events' stamp: 'RNG 3/19/2019 00:18:17'! - gainFocusFrom: aHand - - aHand newKeyboardFocus: self. - self getCurrentSelectionIndex = 0 ifTrue: [ self selectionIndex: 1 ].! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'RNG 3/16/2019 14:24:13'! - navigateDown - "move down, wrapping to top if needed" - - | nextSelection | - nextSelection _ self getCurrentSelectionIndex + 1. - nextSelection > self maximumSelection ifTrue: [ nextSelection _ 1 ]. - - self changeSelectionTo: nextSelection! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'RNG 3/19/2019 00:16:46'! - navigateLeft - - leftSibling ifNotNil: [ leftSibling gainFocusFrom: self activeHand ]! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'RNG 3/16/2019 14:21:05'! - navigateOnePageDown - - | nextSelection | - nextSelection _ self getCurrentSelectionIndex + self numSelectionsInView min: self maximumSelection. - - self getCurrentSelectionIndex ~= nextSelection - ifTrue: [ self changeSelectionTo: nextSelection ]! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'RNG 3/16/2019 14:23:27'! - navigateOnePageUp - - self changeSelectionTo: (self minimumSelection max: self getCurrentSelectionIndex - self numSelectionsInView)! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'RNG 3/19/2019 00:16:35'! - navigateRight - - rightSibling ifNotNil: [ rightSibling gainFocusFrom: self activeHand ]! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'RNG 3/16/2019 14:23:47'! - navigateToBottom - - self changeSelectionTo: self maximumSelection! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'RNG 3/16/2019 14:23:57'! - navigateToTop - - self changeSelectionTo: 1! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'RNG 3/16/2019 14:24:07'! - navigateUp - "move up, wrapping to bottom if needed" - - | nextSelection | - nextSelection _ self getCurrentSelectionIndex - 1. - nextSelection < 1 ifTrue: [ nextSelection _ self maximumSelection ]. - - self changeSelectionTo: nextSelection! ! -!PluggableListMorph methodsFor: 'private' stamp: 'RNG 3/16/2019 14:22:49'! - changeSelectionTo: nextSelection - - self getCurrentSelectionIndex ~= nextSelection ifTrue: [ - | window | - window _ self owningWindow. - (window isNil or: [ window okToChangeDueTo: self ]) ifTrue: [ - "No change if model is locked" - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self listMorph highlightedRow: nextSelection. - "Update the model in next world cycle, so user gets the immediate feedback." - UISupervisor whenUIinSafeState: [ self setSelectionIndex: nextSelection ]. - ] - ]! ! -!PluggableListMorph methodsFor: 'siblings' stamp: 'RNG 3/16/2019 14:08:59'! - leftSibling: aListMorphToTheLeft - - leftSibling _ aListMorphToTheLeft! ! -!PluggableListMorph methodsFor: 'siblings' stamp: 'RNG 3/16/2019 14:08:42'! - leftSibling: aListMorphToTheLeft rightSibling: aListMorphToTheRight - - self leftSibling: aListMorphToTheLeft. - self rightSibling: aListMorphToTheRight.! ! -!PluggableListMorph methodsFor: 'siblings' stamp: 'RNG 3/16/2019 14:08:55'! - rightSibling: aListMorphToTheRight - - rightSibling _ aListMorphToTheRight! ! -!PluggableListMorph methodsFor: 'events' stamp: 'RNG 3/16/2019 14:27:45' prior: 50374041! - keyStroke: aKeyboardEvent - "Process keys" - - | aCharacter | - (Theme current keyStroke: aKeyboardEvent morph: self) - ifTrue: [^ self]. - (self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - (self arrowKey: aKeyboardEvent) ifNotNil: [ ^ self ]. - aCharacter _ aKeyboardEvent keyCharacter. - aCharacter numericValue = 27 ifTrue: [ " escape key" - ^ self mouseButton2Activity]. - aKeyboardEvent anyModifierKeyPressed - ifTrue: [ - (self keystrokeAction: aCharacter) - ifTrue: [ ^self ]]. - ^ self keyboardSearch: aCharacter! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'RNG 3/19/2019 00:12:56' prior: 50391355! - arrowKey: aKeyboardEvent - - aKeyboardEvent isArrowUp ifTrue: [ ^ self navigateUp ]. - aKeyboardEvent isArrowDown ifTrue: [ ^ self navigateDown ]. - aKeyboardEvent isArrowLeft ifTrue: [ ^ self navigateLeft ]. - aKeyboardEvent isArrowRight ifTrue: [ ^ self navigateRight ]. - aKeyboardEvent isHome ifTrue: [ ^ self navigateToTop ]. - aKeyboardEvent isEnd ifTrue: [ ^ self navigateToBottom ]. - aKeyboardEvent isPageUp ifTrue: [ ^ self navigateOnePageUp ]. - aKeyboardEvent isPageDown ifTrue: [ ^ self navigateOnePageDown ]. - ^ nil! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'RNG 3/16/2019 14:29:57' prior: 50426624! - buildMorphicWindow - "Create a pluggable version of all the morphs for a Browser in Morphic" - - | upperPanes messageCatList messageList systemCatList classList | - - systemCatList _ self buildMorphicSystemCatList. - classList _ self buildMorphicClassList. - messageCatList _ self buildMorphicMessageCatList. - messageList _ self buildMorphicMessageList. - - systemCatList rightSibling: classList. - classList leftSibling: systemCatList rightSibling: messageCatList. - messageCatList leftSibling: classList rightSibling: messageList. - messageList leftSibling: messageCatList. - - classList makeItemsDraggable. - systemCatList - acceptDropsFrom: classList - performing: #categorizeUnderCategoryAt:class: - whenOutsideList: #categorizeUnderNewCategoryClass:. - - messageList makeItemsDraggable. - messageCatList - acceptDropsFrom: messageList - performing: #categorizeUnderCategoryAt:selector: - whenOutsideList: #categorizeUnderNewCategorySelector:. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: systemCatList proportionalWidth: 0.2; - addAdjusterAndMorph: (self buildMorphicClassColumnWith: classList) proportionalWidth: 0.2; - addAdjusterAndMorph: messageCatList proportionalWidth: 0.2; - addAdjusterAndMorph: messageList proportionalWidth: 0.4. - - self layoutMorph - addMorph: upperPanes proportionalHeight: 0.3; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.7. - - model changed: #editSelection! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'RNG 3/19/2019 00:24:39' prior: 50436859! - buildNoSysCatMorphicWindow - "A Browser without the class categories list" - - | mySingletonList upperPanes messageCatList messageList classColumn classList | - mySingletonList _ PluggableListMorph - model: model - listGetter: #systemCategorySingleton - indexGetter: #indexIsOne - indexSetter: #indexIsOne: - mainView: self - menuGetter: #systemCatSingletonMenu - keystrokeAction: #systemCatSingletonKey:from:. - mySingletonList hideScrollBarsIndefinitely. - - classColumn _ self buildMorphicClassColumn. - classList _ classColumn submorphs third. - messageCatList _ self buildMorphicMessageCatList. - messageList _ self buildMorphicMessageList. - - classList rightSibling: messageCatList. - messageCatList leftSibling: classList rightSibling: messageList. - messageList leftSibling: messageCatList. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: classColumn proportionalWidth: 0.3; - addAdjusterAndMorph: messageCatList proportionalWidth: 0.3; - addAdjusterAndMorph: messageList proportionalWidth: 0.4. - - messageList makeItemsDraggable. - messageCatList - acceptDropsFrom: messageList - performing: #categorizeUnderCategoryAt:selector: - whenOutsideList: #categorizeUnderNewCategorySelector:. - - self layoutMorph - addMorph: mySingletonList fixedHeight: Preferences standardCodeFont height + 10; - addAdjusterAndMorph: upperPanes proportionalHeight: 0.3; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.7. - - model changed: #editSelection! ! - -PluggableListMorph removeSelector: #leftKeyPressed! - -PluggableListMorph removeSelector: #rightKeyPressed! - -PluggableScrollPane subclass: #PluggableListMorph - instanceVariableNames: 'list getListSelector getIndexSelector setIndexSelector keystrokeActionSelector autoDeselect lastKeystrokeTime lastKeystrokes doubleClickSelector menuGetter mainView leftSibling rightSibling' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #PluggableListMorph category: #'Morphic-Views'! -PluggableScrollPane subclass: #PluggableListMorph - instanceVariableNames: 'list getListSelector getIndexSelector setIndexSelector keystrokeActionSelector autoDeselect lastKeystrokeTime lastKeystrokes doubleClickSelector menuGetter mainView leftSibling rightSibling' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3673-BrowserNavegationWithArrowKeys-NahuelGarbezza-2019Mar19-00h10m-RNG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3672] on 19 March 2019 at 2:19:53 am'! - -"Change Set: 3673-CuisCore-AuthorName-2019Mar19-02h18m -Date: 19 March 2019 -Author: Nahuel Garbezza - -add #isLiteralVariableNode which was needed when renaming contextually in the editor."! -!ParseNode methodsFor: 'testing' stamp: 'RNG 3/19/2019 02:18:54'! - isLiteralVariableNode - - ^ false! ! -!LiteralVariableNode methodsFor: 'testing' stamp: 'RNG 3/19/2019 02:18:42'! - isLiteralVariableNode - - ^ true! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3674-isLiteralVariableNode-NahuelGarbezza-2019Mar19-02h18m-RNG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3672] on 18 March 2019 at 6:45:12 pm'! -!TextModel methodsFor: 'testing' stamp: 'jmv 3/18/2019 18:43:10'! - is: aSymbol - ^ aSymbol == #canSaveContents or: [ super is: aSymbol ]! ! -!SystemWindow methodsFor: 'user interface' stamp: 'jmv 3/18/2019 18:43:17' prior: 50448473! - hasSaveAs - "Returns true if the window has a model which can be saved to a file" - ^model is: #canSaveContents! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3675-saveAs-cleanup-JuanVuletich-2019Mar18-18h44m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3671] on 18 March 2019 at 6:13:27 pm'! -!PasteUpMorph methodsFor: 'events' stamp: 'jmv 3/18/2019 17:56:22'! - keyStroke: aKeyboardEvent - "Handle a keystroke event." - (aKeyboardEvent commandAltKeyPressed or: [ aKeyboardEvent controlKeyPressed ]) - ifTrue: [ - aKeyboardEvent keyCharacter = $b ifTrue: [ BrowserWindow openBrowser ]. - aKeyboardEvent keyCharacter = $f ifTrue: [ BrowserWindow findClass ]]. - "aKeyboardEvent keyCharacter print." - ^ super keyStroke: aKeyboardEvent! ! -!TextEditor methodsFor: 'menu' stamp: 'jmv 5/6/2018 10:32:42' prior: 50446852! - getMenu - - ^(MenuMorph new defaultTarget: self) - addTitle: self class name; - addStayUpIcons; - addItemsFromDictionaries: `{ - { - #label -> 'Help...'. - #selector -> #openHelp. - #icon -> #helpIcon - } asDictionary. - nil. - { - #label -> 'Find...(f)'. - #selector -> #find. - #icon -> #findIcon - } asDictionary. - { - #label -> 'Find Again (g)'. - #selector -> #findAgain. - #icon -> #systemIcon - } asDictionary. - { - #label -> 'Use Selection for Find (j)'. - #selector -> #setSearchString. - #icon -> #saveAsIcon - } asDictionary. - nil. - { - #label -> 'Undo - multiple (z)'. - #selector -> #undo. - #icon -> #undoIcon - } asDictionary. - { - #label -> 'Redo - multiple (Z)'. - #selector -> #redo. - #icon -> #redoIcon - } asDictionary. - { - #label -> 'Undo / Redo history'. - #selector -> #offerUndoHistory. - #icon -> #changesIcon - } asDictionary. - nil. - { - #label -> 'Copy (c)'. - #selector -> #copySelection. - #icon -> #copyIcon - } asDictionary. - { - #label -> 'Cut (x)'. - #selector -> #cut. - #icon -> #cutIcon - } asDictionary. - { - #label -> 'Paste (v)'. - #selector -> #paste. - #icon -> #pasteIcon - } asDictionary. - { - #label -> 'Paste without Format'. - #selector -> #pasteString. - #icon -> #pasteIcon - } asDictionary. - { - #label -> 'Paste...'. - #selector -> #pasteRecent. - #icon -> #worldIcon - } asDictionary. - nil. - { - #label -> 'Toggle WordWrap'. - #selector -> #wrapOnOff. - #icon -> #genericTextIcon - } asDictionary. - { - #label -> 'Set Font... (k)'. - #selector -> #offerFontMenu. - #icon -> #preferencesDesktopFontIcon - } asDictionary. - { - #label -> 'Clear Font'. - #selector -> #clearFont. - #icon -> #newIcon - } asDictionary. - { - #label -> 'Set Default Font...'. - #selector -> #offerDefaultFontMenu. - #icon -> #fontXGenericIcon - } asDictionary. - { - #label -> 'Set Alignment...'. - #selector -> #chooseAlignment. - #icon -> #formatJustifyLeftIcon - } asDictionary. - }`! ! -!TextEditor class methodsFor: 'keyboard shortcut tables' stamp: 'jmv 12/21/2018 08:09:38' prior: 50446928! - basicCmdShortcutsSpec - " - Editor initialize - " - - "arranged in QWERTY keyboard order" - ^#( - #( $( #enclose: 'Enclose within ( and ), or remove enclosing ( and )') - #( $[ #enclose: 'Enclose within [ and ], or remove enclosing [ and ]') - #( ${ #enclose: 'Enclose within { and }, or remove enclosing { and }') - #( $' #enclose: 'Enclose within single quotes, or remove enclosing single quotes') - #( $" #enclose: 'Enclose within double quotes, or remove enclosing double quotes') - #( $` #enclose: 'Enclose within backticks, or remove enclosing backticks') - #( $< #enclose: 'Enclose within < and >, or remove enclosing < and >') - - #( $a #selectAll: 'Select all') - #( $f #find: 'Find') - #( $g #findAgain: 'Find again') - #( $h #help: 'Open this help') - #( $j #setSearchString: 'Set selection as search string for find again') - - #( $z #undo: 'Undo (multiple levels)') - #( $x #cut: 'Cut selection and store it in the Clipboard') - #( $c #copySelection: 'Copy selection to the Clipboard') - #( $v #paste: 'Paste Clipboard contents') - - #( $R #indent: 'Indent (move selection one tab-stap right)') - #( $Y #makeUppercase: 'Force selection to uppercase') - #( $U #changeLineEndsToLf: 'Convert line endings to LF characters (Cuis convention) in selection') - - #( $H #cursorTopHome: 'Move cursor to start of text') - #( $L #outdent: 'Outdent (move selection one tab-stop left)') - - #( $Z #redo: 'Redo (multiple levels)') - #( $X #makeLowercase: 'Force selection to lowercase') - #( $C #compareToClipboard: 'Compare argument to clipboard') - - #( $ #selectWord: 'Select the current word as with double clicking') - )! ! -!SmalltalkEditor class methodsFor: 'keyboard shortcut tables' stamp: 'jmv 9/6/2018 17:50:48' prior: 50446987! - cmdShortcutsSpec - " - Editor initialize - " - "arranged in QWERTY keyboard order" - ^#( - #( $r #acceptAndDebugTest: 'Saves method and debugs it') - #( $t #acceptAndTest: 'Saves method, runs it as test and then all tests in class. Opens debugger if error') - #( $y #acceptAndTestAll: 'Saves method, runs it as test and then all tests in class category. Opens debugger if error') - #( $i #inspectIt: 'Inspect it (selection is a valid expression, or selection is over an inspect-ilst)') - #( $p #printIt: 'Print it (selection is a valid expression)') - - #( $s #save: 'Save (i.e. accept)') - #( $d #doIt: 'Do it (selection is a valid expression)') - - #( $b #browseIt: 'Browse it (selection is a class name or cursor is over a class-list or message-list)') - #( $n #sendersOfIt: 'Senders of it (selection is a message selector or cursor is over a class-list or message-list)') - #( $m #implementorsOfIt: 'Implementors of it (selection is a message selector or cursor is over a class-list or message-list)') - - #( $E #methodStringsContainingit:'Method strings containing it') - #( $T #displayIfTrue: 'Insert #ifTrue:') - #( $I #exploreIt: 'Inspect via Object Explorer') - - #( $Q #argPrev: 'Previous argument') - #( $A #argNext: 'Next argument') - #( $D #debugIt: 'Debug it') - #( $F #displayIfFalse: 'Insert #ifFalse:') - #( $G #fileItIn: 'File in selection') - - #( $V #pasteInitials: 'Paste author initials') - #( $N #referencesToIt: 'References to it (selection is a class name, or cursor is over a class-list or message-list)') - )! ! -!SmalltalkEditor class methodsFor: 'menu' stamp: 'HAW 7/10/2018 19:03:02' prior: 50447042! - smalltalkEditorMenu2Options - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Find...(f)'. - #selector -> #find. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'Find Again (g)'. - #selector -> #findAgain. - #icon -> #systemIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Use Selection for Find (j)'. - #selector -> #setSearchString. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Undo - multiple (z)'. - #selector -> #undo. - #icon -> #undoIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Redo - multiple (Z)'. - #selector -> #redo. - #icon -> #redoIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'Undo / Redo history'. - #selector -> #offerUndoHistory. - #icon -> #changesIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Copy (c)'. - #selector -> #copySelection. - #icon -> #copyIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Cut (x)'. - #selector -> #cut. - #icon -> #cutIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'Paste (v)'. - #selector -> #paste. - #icon -> #pasteIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 40. - #label -> 'Paste without Format'. - #selector -> #pasteString. - #icon -> #pasteIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 50. - #label -> 'Paste...'. - #selector -> #pasteRecent. - #icon -> #worldIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'Toggle WordWrap'. - #selector -> #wrapOnOff. - #icon -> #genericTextIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'Set Font... (k)'. - #selector -> #offerFontMenu. - #icon -> #preferencesDesktopFontIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'Clear Font'. - #selector -> #clearFont. - #icon -> #newIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 40. - #label -> 'Set Default Font...'. - #selector -> #offerDefaultFontMenu. - #icon -> #fontXGenericIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'More...'. - #selector -> #openMenu. - #icon -> #listAddIcon - } asDictionary. - }` -! ! -!Morph methodsFor: 'events' stamp: 'jmv 3/18/2019 17:39:33' prior: 16874640! - mouseLeave: evt - "Handle a mouseLeave event, meaning the mouse just left my bounds with no button pressed." - evt hand releaseKeyboardFocus: self. - "Allow instances to dynamically use properties for handling common events." - self - valueOfProperty: #mouseLeave: - ifPresentDo: [ :handler | handler value: evt ].! ! -!HandMorph methodsFor: 'focus handling' stamp: 'jmv 3/18/2019 17:58:51' prior: 16851989! - releaseKeyboardFocus: aMorph - "If the given morph had the keyboard focus before, release it" - keyboardFocus ifNotNil: [ - keyboardFocus withAllOwnersDo: [ :outerOwner | - outerOwner == aMorph ifTrue: [self releaseKeyboardFocus]]]! ! -!Theme methodsFor: 'keyboard shortcuts' stamp: 'jmv 2/23/2018 15:42:17' prior: 50447157! - keyStroke: aKeyboardEvent morph: aMorph - - (aKeyboardEvent commandAltKeyPressed or: [ aKeyboardEvent controlKeyPressed ]) - ifFalse: [ ^ false ]. - - aKeyboardEvent keyValue = $w numericValue ifTrue: [ - aMorph owningWindow ifNotNil: [ :w | - (w morphContainsPoint: (w internalizeFromWorld: aKeyboardEvent eventPosition)) ifTrue: [ - w delete. - ^true ] ]]. -" aKeyboardEvent keyValue = $f numericValue - ifTrue: [aMorph owningWindow ifNotNil: [ :w | w fullScreen. ^true ]]. -" - ^ false! ! - -Theme removeSelector: #findClassIn:! - -Theme removeSelector: #findClassIn:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3676-GlobalFindOnlyIfFocusOnWorld-JuanVuletich-2019Mar18-18h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3671] on 18 March 2019 at 6:16:32 pm'! -!Morph methodsFor: 'events' stamp: 'jmv 3/18/2019 18:03:59' prior: 16874517! - keyStroke: aKeyboardEvent - "Handle a keystroke event." - - (self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - - "Allow instances to dynamically use properties for handling common events." - self - valueOfProperty: #'keyStroke:' - ifPresentDo: [ :handler | handler value: aKeyboardEvent ]! ! -!PluggableScrollPane methodsFor: 'events' stamp: 'jmv 3/18/2019 18:04:07' prior: 50374006! - keyStroke: aKeyboardEvent - - ( self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - super keyStroke: aKeyboardEvent. - scroller keyStroke: aKeyboardEvent! ! -!HierarchicalListMorph methodsFor: 'events' stamp: 'jmv 3/18/2019 18:03:49' prior: 50374017! - keyStroke: aKeyboardEvent - "Process potential command keys" - - | args aCharacter | - (self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - aCharacter _ aKeyboardEvent keyCharacter. - (self arrowKey: aCharacter) - ifTrue: [ ^self ]. - keystrokeActionSelector ifNil: [^self]. - (args _ keystrokeActionSelector numArgs) = 1 - ifTrue: [^mainView perform: keystrokeActionSelector with: aCharacter]. - args = 2 - ifTrue: [ - ^mainView - perform: keystrokeActionSelector - with: aCharacter - with: self]. - ^self error: 'The keystrokeActionSelector must be a 1- or 2-keyword symbol'! ! -!PluggableListMorph methodsFor: 'events' stamp: 'jmv 3/18/2019 18:04:03' prior: 50448673! - keyStroke: aKeyboardEvent - "Process keys" - - | aCharacter | - (self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - (self arrowKey: aKeyboardEvent) ifNotNil: [ ^ self ]. - aCharacter _ aKeyboardEvent keyCharacter. - aCharacter numericValue = 27 ifTrue: [ " escape key" - ^ self mouseButton2Activity]. - aKeyboardEvent anyModifierKeyPressed - ifTrue: [ - (self keystrokeAction: aCharacter) - ifTrue: [ ^self ]]. - ^ self keyboardSearch: aCharacter! ! -!TextModelMorph methodsFor: 'events' stamp: 'jmv 3/18/2019 18:04:10' prior: 16934057! -keyStroke: aKeyboardEvent - "A keystroke was hit while the receiver had keyboard focus. Pass the keywtroke on to my textMorph, and and also, if I have an event handler, pass it on to that handler" - - (self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - self textMorph keyStroke: aKeyboardEvent! ! -!InnerTextMorph methodsFor: 'events' stamp: 'jmv 3/18/2019 18:03:54' prior: 50374176! - keyStroke: aKeyboardEvent - - (self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - - autoCompleter - ifNil: [ self processKeyStroke: aKeyboardEvent ] - ifNotNil: [ - autoCompleter - autoCompletionAround: [ self processKeyStroke: aKeyboardEvent ] - keyStroke: aKeyboardEvent ]! ! -!KeyboardEvent methodsFor: 'dispatching' stamp: 'jmv 3/18/2019 18:03:20' prior: 16861811! - sentTo: aMorph localPosition: positionInAMorph - "Dispatch the receiver into anObject" - type == #keystroke ifTrue: [ - (self commandAltKeyPressed or: [ self controlKeyPressed ]) - ifTrue: [ - self keyValue = $w numericValue ifTrue: [ - aMorph owningWindow ifNotNil: [ :w | - (w morphContainsPoint: (w internalizeFromWorld: self eventPosition)) ifTrue: [ - w delete. - ^self ]]]]. - ^ aMorph - processKeystroke: self - localPosition: positionInAMorph ]. - type == #keyDown ifTrue: [ - ^ aMorph - processKeyDown: self - localPosition: positionInAMorph ]. - type == #keyUp ifTrue: [ - ^ aMorph - processKeyUp: self - localPosition: positionInAMorph ]. - ^ super - sentTo: aMorph - localPosition: positionInAMorph.! ! - -Theme removeSelector: #keyStroke:morph:! - -Theme removeSelector: #keyStroke:morph:! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Editor initialize! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3677-ThemeCleanup-JuanVuletich-2019Mar18-18h13m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3677] on 19 March 2019 at 5:25:59 pm'! -!AutoCompleterMorph methodsFor: 'events' stamp: 'jmv 3/19/2019 17:25:05'! - mouseEnter: evt - self activeHand newKeyboardFocus: completer textMorph. - ^ super mouseEnter: evt! ! -!AutoCompleterMorph methodsFor: 'event handling testing' stamp: 'jmv 3/19/2019 17:25:18'! - handlesMouseOver: evt - "Do I want to receive mouseEnter: and mouseLeave: when the button is up and the hand is empty?" - ^true! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3678-AutoCompleterMorphFix-JuanVuletich-2019Mar19-17h25m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3678] on 19 March 2019 at 5:34:42 pm'! -!KeyboardEvent methodsFor: 'dispatching' stamp: 'jmv 3/19/2019 17:34:09' prior: 50449320! - sentTo: aMorph localPosition: positionInAMorph - "Dispatch the receiver into anObject" - type == #keystroke ifTrue: [ - (self shiftPressed and: [self keyValue = 13 ]) ifTrue: [ - ^BrowserWindow findClass]. - (self commandAltKeyPressed or: [ self controlKeyPressed ]) - ifTrue: [ - self keyValue = $w numericValue ifTrue: [ - aMorph owningWindow ifNotNil: [ :w | - (w morphContainsPoint: (w internalizeFromWorld: self eventPosition)) ifTrue: [ - w delete. - ^self ]]]]. - ^ aMorph - processKeystroke: self - localPosition: positionInAMorph ]. - type == #keyDown ifTrue: [ - ^ aMorph - processKeyDown: self - localPosition: positionInAMorph ]. - type == #keyUp ifTrue: [ - ^ aMorph - processKeyUp: self - localPosition: positionInAMorph ]. - ^ super - sentTo: aMorph - localPosition: positionInAMorph.! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3679-ShiftEnter-GlobalFindClass-JuanVuletich-2019Mar19-17h30m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3674] on 19 March 2019 at 6:57:48 am'! -!MessageSet methodsFor: 'message list' stamp: 'HAW 3/19/2019 06:56:35' prior: 16870002! - selectedMessage - "Answer the source method for the currently selected message." - - | class selector | - selectedMessage ifNil: [^ 'Class vanished']. - - class _ selectedMessage actualClass. - selector _ selectedMessage methodSymbol. - selector ifNil: [ ^'prims']. - (class notNil and: [ class includesSelector: selector]) ifFalse: [ - currentCompiledMethod _ nil. - ^ 'Missing']. - - selector first isUppercase ifTrue: [ - selector == #Comment ifTrue: [ - currentCompiledMethod _ class organization commentRemoteStr. - ^ class comment]. - selector == #Definition ifTrue: [ - ^ class definition]. - selector == #Hierarchy ifTrue: [^ class printHierarchy]]. - - self showingDecompile ifTrue: [ - ^ self decompiledSource ]. - - currentCompiledMethod _ class compiledMethodAt: selector ifAbsent: nil. - self showingDocumentation ifTrue: [ - ^ self commentContents ]. - - ^self sourceStringPrettifiedAndDiffed! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3680-DeletingAClassWhenSeeingImplementorsOrSenders-HernanWilkinson-2019Mar19-06h52m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3680] on 19 March 2019 at 6:37:26 pm'! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'HAW 3/19/2019 18:36:48' prior: 50380225! - arrowKey: aChar - "Handle a keyboard navigation character. Answer true if handled, false if not." - | keyEvent answer nextSelection oldSelection | - answer := false. - keyEvent := aChar numericValue. - oldSelection := self visualSelectionIndex. - nextSelection := oldSelection. - keyEvent = 31 ifTrue: [ - "down" - nextSelection := oldSelection + 1. - nextSelection > self maximumSelection ifTrue: [ nextSelection := self minimumSelection ]]. - keyEvent = 30 ifTrue: [ - "up" - nextSelection := oldSelection - 1. - nextSelection < self minimumSelection ifTrue: [ nextSelection := self maximumSelection ]]. - keyEvent = 1 ifTrue: [ "home" - nextSelection := 1 ]. - keyEvent = 4 ifTrue: [ "end" - nextSelection := scroller submorphs size ]. - keyEvent = 11 ifTrue: [ "page up" - nextSelection := oldSelection - self numSelectionsInView max: 1 ]. - keyEvent = 12 ifTrue: [ "page down" - nextSelection := oldSelection + self numSelectionsInView ]. - keyEvent = 29 ifTrue: [ - "right" - selectedMorph ifNotNil: [ - (selectedMorph canExpand and: [ selectedMorph isExpanded not ]) - ifTrue: [ - self toggleExpandedState: selectedMorph. - self scrollSelectionIntoView. - answer := true ] - ifFalse: [ nextSelection := oldSelection + 1 ]]]. - keyEvent = 28 ifTrue: [ - "left" - selectedMorph ifNotNil: [ - selectedMorph isExpanded - ifTrue: [ - self toggleExpandedState: selectedMorph. - self scrollSelectionIntoView. - answer := true ] - ifFalse: [ - oldSelection > self minimumSelection ifTrue: [ - nextSelection _ (oldSelection-1 to: 1 by: -1) - detect: [ :i | ( scroller submorphs at: i) indentLevel < selectedMorph indentLevel ] - ifNone: [ oldSelection ]]. - ]]]. - nextSelection = oldSelection ifFalse: [ - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self highlightedMorph: (self listMorphAt: nextSelection). - "Update the model in next world cycle, so user gets the immediate feedback." - UISupervisor whenUIinSafeState: [ self setSelectionIndex: nextSelection ]. - answer := true ]. - ^ answer.! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3681-HierarchicalListMorphLeftKey-HernanWilkinson-2019Mar16-16h37m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3681] on 20 March 2019 at 7:47:50 am'! -!Stream methodsFor: 'accessing' stamp: 'HAW 3/20/2019 06:54:02'! - nextPut: anObject when: aCondition - - aCondition ifTrue: [ self nextPut: anObject ].! ! -!Stream methodsFor: 'accessing' stamp: 'HAW 3/20/2019 06:54:23'! - nextPutAll: aCollection when: aCondition - - aCondition ifTrue: [ self nextPutAll: aCollection ]. - ! ! -!Stream methodsFor: 'printing' stamp: 'HAW 3/20/2019 06:54:30'! - print: anObject when: aCondition - - aCondition ifTrue: [self print: anObject].! ! -!WriteStream methodsFor: 'character writing' stamp: 'HAW 3/20/2019 07:28:29'! -newLineTab: times when: aCondition - - aCondition ifTrue: [ self newLineTab: times ] - - ! ! -!WriteStream methodsFor: 'character writing' stamp: 'HAW 3/20/2019 07:22:21'! - newLineWhen: aCondition - - aCondition ifTrue: [ self newLine ]! ! -!WriteStream methodsFor: 'character writing' stamp: 'HAW 3/20/2019 07:43:22'! - space: times when: aCondition - - aCondition ifTrue: [ self space: times ] - - ! ! -!WriteStream methodsFor: 'character writing' stamp: 'HAW 3/20/2019 07:20:05'! - spaceWhen: aCondition - - aCondition ifTrue: [ self space ]! ! -!WriteStream methodsFor: 'character writing' stamp: 'HAW 3/20/2019 07:26:09'! - tab: times when: aCondition - - aCondition ifTrue: [ self tab: times ] - - ! ! -!WriteStream methodsFor: 'character writing' stamp: 'HAW 3/20/2019 07:23:42'! - tabWhen: aCondition - - aCondition ifTrue: [ self tab ]! ! -!Transcript class methodsFor: 'old Transcript compatibility' stamp: 'HAW 3/20/2019 07:30:29'! - newLineWhen: aCondition - - aCondition ifTrue: [ self newLine ] - - ! ! -!Transcript class methodsFor: 'old Transcript compatibility' stamp: 'HAW 3/20/2019 07:12:13'! - nextPut: anObject when: aCondition - - aCondition ifTrue: [ self nextPut: anObject ].! ! -!Transcript class methodsFor: 'old Transcript compatibility' stamp: 'HAW 3/20/2019 07:11:01'! - nextPutAll: aCollection when: aCondition - - aCondition ifTrue: [ self nextPutAll: aCollection ]. -! ! -!Transcript class methodsFor: 'old Transcript compatibility' stamp: 'HAW 3/20/2019 07:12:56'! - print: anObject when: aCondition - - aCondition ifTrue: [self print: anObject].! ! -!Transcript class methodsFor: 'old Transcript compatibility' stamp: 'HAW 3/20/2019 07:39:41'! - spaceWhen: aCondition - - aCondition ifTrue: [ self space ]! ! -!Transcript class methodsFor: 'old Transcript compatibility' stamp: 'HAW 3/20/2019 07:40:59'! - tabWhen: aCondition - - aCondition ifTrue: [ self tab ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3682-nextPutWhen-HernanModrow-2019Mar20-06h53m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3682] on 20 March 2019 at 3:52:35 pm'! -!Preferences class methodsFor: 'standard queries' stamp: 'GC 3/19/2019 21:00:04' prior: 0! - biggerCursors - ^ self - valueOfFlag: #biggerCursors - ifAbsent: [ false ].! ! -!Preferences class methodsFor: 'themes' stamp: 'GC 3/19/2019 21:02:02' prior: 50391964! - cuisDefaults - " - Preferences cuisDefaults - " - self setPreferencesFrom: - - #( - (balloonHelpEnabled true) - (biggerCursors false) - (browseWithPrettyPrint false) - (caseSensitiveFinds false) - (checkForSlips true) - (cmdDotEnabled true) - (diffsInChangeList true) - (diffsWithPrettyPrint false) - (menuKeyboardControl true) - (optionalButtons true) - (extraDebuggerButtons true) - (subPixelRenderFonts true) - (thoroughSenders true) - (cheapWindowReframe false) - (syntaxHighlightingAsYouType true) - (tapAndHoldEmulatesButton2 true) - (clickGrabsMorphs false) - - (syntaxHighlightingAsYouTypeAnsiAssignment false) - (syntaxHighlightingAsYouTypeLeftArrowAssignment false) - ). - self useMenuIcons - ". - Theme beCurrent. - Taskbar showTaskbar - "! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 3/20/2019 15:49:29' prior: 50435248! - defaultFont11 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont11 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 11) - (setListFontTo: 11) - (setMenuFontTo: 12) - (setWindowTitleFontTo: 14) - (setCodeFontTo: 11) - (setButtonFontTo: 11)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 3/20/2019 15:49:26' prior: 50437162! - defaultFont12 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont12 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 12) - (setListFontTo: 12) - (setMenuFontTo: 12) - (setWindowTitleFontTo: 14) - (setCodeFontTo: 12) - (setButtonFontTo: 12)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 3/20/2019 15:49:22' prior: 50435266! - defaultFont14 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont14 - " - - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: #( - (setSystemFontTo: 14) - (setListFontTo: 14) - (setMenuFontTo: 14) - (setWindowTitleFontTo: 17) - (setCodeFontTo: 14) - (setButtonFontTo: 14)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Preferences standardCodeFont pointSize < 14 ifTrue: [Preferences disable: #biggerCursors]! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3683-DisableBiggerCursorsByDefault-GastonCaruso-JuanVuletich-2019Mar20-15h49m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3683] on 20 March 2019 at 4:37:35 pm'! -!FeatureRequirement methodsFor: 'private' stamp: 'jmv 3/20/2019 16:36:14' prior: 50430078! - placesToLookForPackagesDo: aBlock - - | base myDir | - - "Look inside my own folder" - pathName ifNotNil: [ - myDir _ pathName asFileEntry parent. - aBlock value: myDir ]. - - "Look in Cuis image folder and reasonable subfolders" - base _ DirectoryEntry smalltalkImageDirectory. - base allDirectoriesDo: aBlock. - - "Look in parent directory and reasonable subfolders. - Useful when image is stored in a subdirectory of the main app directory. - This could be the case when the package comes from a 'main' git repo, and image is copied from gitHub. - First try directories including the word Cuis in the name. Then try others." - base parent directoriesDo: [ :dir | - ('*Cuis*' match: dir name) - ifTrue: [aBlock value: dir. dir allDirectoriesDo: aBlock]]. - base parent directoriesDo: [ :dir | - ('*Cuis*' match: dir name) - ifFalse: [aBlock value: dir. dir allDirectoriesDo: aBlock]]. - - "Also look in host OS current directory" - (base ~= DirectoryEntry currentDirectory and: [base parent ~= DirectoryEntry currentDirectory]) - ifTrue: [ - base _ DirectoryEntry currentDirectory. - base allDirectoriesDo: aBlock ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3684-PreferCuisFoldersForSearchingPackages-JuanVuletich-2019Mar20-16h25m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3684] on 21 March 2019 at 11:39:19 am'! -!MorphicScanner methodsFor: 'scanning' stamp: 'jmv 3/21/2019 11:38:24' prior: 16878048! - placeEmbeddedObject: anchoredFormOrMorph - - (super placeEmbeddedObject: anchoredFormOrMorph) ifFalse: [^ false]. - (anchoredFormOrMorph is: #Morph) - ifTrue: [ - anchoredFormOrMorph morphPosition: - ((destX - anchoredFormOrMorph morphWidth)@ - (lineY+ line baseline - anchoredFormOrMorph morphHeight)) - - topLeft. - anchoredFormOrMorph show. - canvas fullDraw: anchoredFormOrMorph ] - ifFalse: [ - destY _ lineY. - canvas - image: anchoredFormOrMorph - at: destX - anchoredFormOrMorph width @ (destY + line baseline - anchoredFormOrMorph height) ]. - ^ true! ! -!InnerTextMorph methodsFor: 'notifications' stamp: 'jmv 3/21/2019 11:37:52' prior: 16856099! - possiblyChanged - | embeddedMorphs | - embeddedMorphs _ model actualContents embeddedMorphs. - self submorphsDo: [:each| - (embeddedMorphs includes: each) ifFalse: [ - self privateRemove: each. - each privateOwner: nil ]]. - embeddedMorphs do: [ :each| - each owner == self ifFalse: [ - self addMorphFront: each. - each hide "Show it only when properly located"]]. - owner possiblyChanged! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3685-MorphsInText-fix-JuanVuletich-2019Mar21-11h33m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3685] on 25 March 2019 at 4:08:19 pm'! -!Editor class methodsFor: 'class initialization' stamp: 'HAW 3/25/2019 16:06:05'! - collectCmdShortcutsSpecUsing: anInitializationMessage - - | shortcutsSpec dynamicInitializationMessage | - - shortcutsSpec := self perform: anInitializationMessage. - - dynamicInitializationMessage := (self name asString uncapitalized, anInitializationMessage asString capitalized) asSymbol. - (Smalltalk allClassesImplementing: dynamicInitializationMessage) do: [ :aClass | - shortcutsSpec := shortcutsSpec, (aClass soleInstance perform: dynamicInitializationMessage) ]. - - ^shortcutsSpec - -! ! -!Editor class methodsFor: 'keyboard shortcut tables' stamp: 'HAW 3/25/2019 16:02:43'! - allCmdShortcutsSpec - - ^ (self collectCmdShortcutsSpecUsing: #basicCmdShortcutsSpec), (self collectCmdShortcutsSpecUsing: #cmdShortcutsSpec)! ! -!Editor class methodsFor: 'keyboard shortcut tables' stamp: 'HAW 3/25/2019 15:57:24'! - allShiftShortcutsSpec - - ^ self shiftShortcutsSpec! ! -!Editor class methodsFor: 'keyboard shortcut tables' stamp: 'HAW 3/25/2019 15:57:38'! - shiftShortcutsSpec - - ^#( - #( 'Enter' #globalFindClass: 'Global Find class name or fragment') - )! ! -!Editor class methodsFor: 'help' stamp: 'HAW 3/25/2019 15:33:02'! - formatShortcutsUsingModifierKey: aModifierKey andSpecs: aSpecs - "Format shortcuts specs with a modifier key" - ^ String streamContents: [ :strm | - aSpecs do: [ :triplet | | c | - c _ triplet first = Character space - ifFalse: [ triplet first asString, ' ' ] - ifTrue: [ 'Space']. - strm nextPutAll: (aModifierKey, '-', c, String tab, String tab, triplet third). - strm newLine ]]! ! -!Editor class methodsFor: 'class initialization' stamp: 'HAW 3/25/2019 15:59:28' prior: 16836902! - basicInitialize - " - Editor initialize - " - self withAllSubclassesDo: [ :c | c initializeShortcuts; initializeCmdShortcuts ]! ! -!Editor class methodsFor: 'class initialization' stamp: 'HAW 3/25/2019 15:59:22' prior: 50334906! -initialize - " - Editor initialize - " - self withAllSubclassesDo: [ :c | c basicInitialize ]! ! -!Editor class methodsFor: 'class initialization' stamp: 'HAW 3/25/2019 16:04:41' prior: 50432189! - initializeCmdShortcuts - "Initialize the (unshifted) command-key (or alt-key if not on Mac) shortcut table. - If you want to add a new shortcut for an specific editor, for example SmalltalkEditor, you should - define the message #smalltalkEditorCmdShortcutsSpec in a class of your category and it will - be dynamically send" - - "NOTE: if you don't know what your keyboard generates, use Sensor test" - - " - Editor initialize - " - - cmdShortcuts _ Array new: 256 withAll: #noop:. - - self putIntoCmdShortcuts: self allCmdShortcutsSpec -! ! -!Editor class methodsFor: 'keyboard shortcut tables' stamp: 'HAW 3/25/2019 15:57:29' prior: 16836973! - basicCmdShortcutsSpec - - ^#()! ! -!Editor class methodsFor: 'keyboard shortcut tables' stamp: 'HAW 3/25/2019 15:57:18' prior: 16836977! - cmdShortcuts - "Same for all instances. - A subclass could handle specific keyboard shortcuts for each instance, though." - - cmdShortcuts ifNil: [self initializeCmdShortcuts ]. - - ^cmdShortcuts! ! -!Editor class methodsFor: 'keyboard shortcut tables' stamp: 'HAW 3/25/2019 15:57:33' prior: 16836986! - cmdShortcutsSpec - - ^#()! ! -!Editor class methodsFor: 'keyboard shortcut tables' stamp: 'HAW 3/25/2019 15:58:00' prior: 16836990! - shortcuts - "Same for all instances. - A subclass could handle specific keyboard shortcuts for each instance, though." - - shortcuts ifNil: [ self initializeShortcuts ]. - - ^shortcuts! ! -!Editor class methodsFor: 'help' stamp: 'HAW 3/25/2019 15:33:02' prior: 50423146! - help - " - TextEditor help edit - SmalltalkEditor help edit - " - ^ (self formatShortcutsUsingModifierKey: 'Shift' andSpecs: self allShiftShortcutsSpec) , - (self formatShortcutsUsingModifierKey: 'Cmd' andSpecs: self allCmdShortcutsSpec). -! ! -!TextEditor class methodsFor: 'keyboard shortcut tables' stamp: 'HAW 3/25/2019 16:00:48' prior: 50448975! - basicCmdShortcutsSpec - " - Editor initialize - " - - "arranged in QWERTY keyboard order" - ^#( - #( $( #enclose: 'Enclose within ( and ), or remove enclosing ( and )') - #( $[ #enclose: 'Enclose within [ and ], or remove enclosing [ and ]') - #( ${ #enclose: 'Enclose within { and }, or remove enclosing { and }') - #( $' #enclose: 'Enclose within single quotes, or remove enclosing single quotes') - #( $" #enclose: 'Enclose within double quotes, or remove enclosing double quotes') - #( $` #enclose: 'Enclose within backticks, or remove enclosing backticks') - #( $< #enclose: 'Enclose within < and >, or remove enclosing < and >') - - #( $a #selectAll: 'Select all') - #( $f #find: 'Find') - #( $g #findAgain: 'Find again') - #( $h #help: 'Open this help') - #( $j #setSearchString: 'Set selection as search string for find again') - - #( $z #undo: 'Undo (multiple levels)') - #( $x #cut: 'Cut selection and store it in the Clipboard') - #( $c #copySelection: 'Copy selection to the Clipboard') - #( $v #paste: 'Paste Clipboard contents') - - #( $Y #makeUppercase: 'Force selection to uppercase') - #( $U #changeLineEndsToLf: 'Convert line endings to LF characters (Cuis convention) in selection') - - #( $H #cursorTopHome: 'Move cursor to start of text') - #( $L #outdent: 'Outdent (move selection one tab-stop left)') - - #( $Z #redo: 'Redo (multiple levels)') - #( $X #makeLowercase: 'Force selection to lowercase') - #( $C #compareToClipboard: 'Compare argument to clipboard') - - #( $ #selectWord: 'Select the current word as with double clicking') - )! ! - -Editor class removeSelector: #collectCmdShortcutsSpecsUsing:! - -Editor class removeSelector: #collectCmdShortcutsUsing:! - -Editor class removeSelector: #formatShortcutsUsingModifierKey:AndSpecs:! - -Editor class removeSelector: #initializeCmdShortcutsUsing:! - -Editor class removeSelector: #initializeCmdShortcutsUsing:! - -Editor initialize! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3686-EditorHelp-Mash-2019Mar25-15h30m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3659] on 18 March 2019 at 2:46:24 pm'! - -Object subclass: #RefactoringApplier - instanceVariableNames: 'requestExitBlock refactoring changes ' - classVariableNames: 'Appliers ' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RefactoringApplier category: #'Tools-Refactoring'! -Object subclass: #RefactoringApplier - instanceVariableNames: 'requestExitBlock refactoring changes' - classVariableNames: 'Appliers' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!ClassDescription methodsFor: 'compiling' stamp: 'HAW 3/12/2019 22:09:16'! - localBindingOf: varNameSymbol - - self subclassResponsibility ! ! -!Metaclass methodsFor: 'compiling' stamp: 'HAW 3/12/2019 22:08:40'! - localBindingOf: varNameSymbol - - ^thisClass localBindingOf: varNameSymbol ! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'HAW 3/13/2019 18:05:09'! - browseMessageList: messageList ofSize: messageListSize name: labelString autoSelect: autoSelectString - - | title | - - "Create and schedule a MessageSet browser on the message list." - - messageListSize = 0 ifTrue: [^ PopUpMenu inform: ('There are no\' , labelString) withNewLines ]. - - title _ messageListSize > 1 - ifFalse: [ labelString ] - ifTrue: [ '[', messageListSize printString, '] ', labelString]. - - MessageSetWindow - openMessageList: messageList - label: title - autoSelect: autoSelectString! ! -!Stream methodsFor: 'accessing' stamp: 'HAW 3/13/2019 20:09:02'! - nextPutAll: aCollection asCommaSeparated: aPrintBlock - - aCollection asCommaSeparated: aPrintBlock on: self! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/15/2019 14:38:44'! -rename: aNodeUnderCursor in: aSelectedClass at: aSelectedSelector - - aNodeUnderCursor isTempOrArg ifTrue: [ ^self renameTemporary: aNodeUnderCursor name ]. - - self ifRenameCanBeAppliedDo: [ - aNodeUnderCursor isMessageNode ifTrue: [ ^ self renameSelectorOf: aNodeUnderCursor in: aSelectedClass at: aSelectedSelector ]. - aNodeUnderCursor isInstanceVariableNode ifTrue: [ ^ self renameInstanceVariableOn: self codeProvider for: aNodeUnderCursor name at: aSelectedClass ]. - aNodeUnderCursor isLiteralVariableNode ifTrue: [ | potentialBehavior | - potentialBehavior := aNodeUnderCursor key value. - potentialBehavior isBehavior ifTrue: [ ^self renameClassOn: self codeProvider for: potentialBehavior theNonMetaClass ]]. - - ^morph flash ]! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/15/2019 14:41:17'! - renameSelectorOf: aMessageNode in: aSelectedClass at: aSelectedSelector - - RefactoringApplier renameSelectorApplier createAndValueHandlingExceptionsOn: model textProvider of: aMessageNode in: aSelectedClass at: aSelectedSelector! ! -!RefactoringApplier class methodsFor: 'initialization' stamp: 'HAW 3/12/2019 22:04:08'! -initialize - - Appliers := IdentityDictionary new.! ! -!RefactoringApplier class methodsFor: 'appliers' stamp: 'HAW 3/12/2019 22:03:31'! - registerRenameSelectorApplier: aRenameSelectorApplierClass - - Appliers at: #renameSelectorApplier put: aRenameSelectorApplierClass name! ! -!RefactoringApplier class methodsFor: 'appliers' stamp: 'HAW 3/12/2019 22:05:45'! - renameSelectorApplier - - ^Appliers - at: #renameSelectorApplier - ifPresent: [ :anApplierName | Smalltalk classNamed: anApplierName ] - ifAbsent: [ RenameSelectorApplier ]! ! -!RefactoringApplier class methodsFor: 'appliers' stamp: 'HAW 3/12/2019 22:12:54'! - resetRenameSelectorApplier - - Appliers removeKey: #renameSelectorApplier ifAbsent: []! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 3/12/2019 22:26:11'! -initializeImplementorsAndSenders - - implementors := IdentitySet new. - senders := IdentitySet new. -! ! -!RenameSelectorApplier methodsFor: 'as yet unclassified' stamp: 'HAW 3/14/2019 18:08:53'! - sendersFrom: methodReferences - - ^ methodReferences collect: [:aMethodReference | aMethodReference compiledMethod ]! ! -!RenameSelectorApplier class methodsFor: 'instance creation' stamp: 'HAW 3/12/2019 22:20:18'! - createAndValueHandlingExceptionsOn: aModel for: anOldSelector in: aClassToRefactor - - self createAndValueHandlingExceptions: [ self on: aModel for: anOldSelector in: aClassToRefactor ]! ! -!RenameSelectorApplier class methodsFor: 'instance creation' stamp: 'HAW 3/15/2019 13:54:21'! - createAndValueHandlingExceptionsOn: aModel of: aMessageNode in: aSelectedClass - - ^self createAndValueHandlingExceptionsOn: aModel for: aMessageNode selector key in: aSelectedClass ! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'HAW 3/13/2019 18:05:40' prior: 50402397! - browseMessageList: messageList name: labelString autoSelect: autoSelectString - - ^self browseMessageList: messageList ofSize: messageList size name: labelString autoSelect: autoSelectString! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/15/2019 13:47:38' prior: 50443709! - contextualRename - - self - withMethodNodeAndClassDo: [ :methodNode :selectedClass | self contextualRenameOf: methodNode in: selectedClass] - ifErrorsParsing: [ :anError | morph flash ]. - - ! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/15/2019 14:36:50' prior: 50443723! - contextualRenameOf: aMethodNode in: aSelectedClass - - aMethodNode - withParseNodeIncluding: self startIndex - do: [ :nodeUnderCursor | self rename: nodeUnderCursor in: aSelectedClass at: aMethodNode selector ] - ifAbsent: [ - self startIndex <= aMethodNode selectorLastPosition - ifTrue: [ self ifRenameCanBeAppliedDo: [ self renameSelectorFor: aMethodNode selector in: aSelectedClass ]] - ifFalse: [ morph flash ]] - - -! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/12/2019 22:15:38' prior: 50443789! - renameSelectorFor: aSelector in: aClassToRefactor - - RefactoringApplier renameSelectorApplier createAndValueHandlingExceptionsOn: model textProvider for: aSelector in: aClassToRefactor ! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/15/2019 13:47:20' prior: 50443811! - withMethodNodeAndClassDo: aBlock ifErrorsParsing: anErrorBlock - - | selectedClass methodNode | - - selectedClass := self codeProvider selectedClassOrMetaClass. - methodNode := [ selectedClass methodNodeFor: model actualContents ] on: Error do: [ :anError | ^ anErrorBlock value: anError ]. - - ^aBlock value: methodNode value: selectedClass.! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 3/12/2019 22:15:54' prior: 50443906! - renameSelector - - model selectedMessageName ifNotNil: [ :oldSelector | - RefactoringApplier renameSelectorApplier createAndValueHandlingExceptionsOn: model for: oldSelector in: model selectedClassOrMetaClass ]! ! -!ChangeSelectorSendersStepWindow methodsFor: 'actions' stamp: 'HAW 3/14/2019 18:08:17' prior: 50438432! - changeRequestSenders - - applier sendersFrom: model messageList - ! ! -!AddInstanceVariable methodsFor: 'accessing' stamp: 'HAW 3/14/2019 09:11:51' prior: 50438527! - classToRefactor - - ^classToRefactor ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 3/12/2019 22:25:49' prior: 50441520! - askForImplementosAndSenders - - self - askScope; - initializeImplementorsAndSenders; - calculateImplementorsAndSenders; - startWizard ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 3/12/2019 22:25:29' prior: 50441537! -calculateImplementorsAndSenders - - scopeChoice = 1 ifTrue: [ ^self implementorsAndSendersForClass ]. - scopeChoice = 2 ifTrue: [ ^self implementorsAndSendersForHierarchy ]. - scopeChoice = 3 ifTrue: [ ^self implementorsAndSendersInCategory ]. - scopeChoice = 4 ifTrue: [ ^self implementorsAndSendersInCategoryAndHierarchy ]. - scopeChoice = 5 ifTrue: [ ^self implementorsAndSendersInSystem ]. - - self error: 'Unknown scope option' - - ! ! -!ChangeSelectorApplier class methodsFor: 'instance creation' stamp: 'HAW 3/15/2019 15:02:08' prior: 50441768! - on: aBrowser for: aSelector in: aClass - - self assertCanApplyRefactoringFor: aSelector in: aClass. - - ^self new initializeOn: aBrowser for: aSelector in: aClass - ! ! -!RenameSelectorApplier methodsFor: 'refactoring - creation' stamp: 'HAW 8/18/2018 16:56:24'! - createRefactoring - - ^self refactoringClass from: oldSelector to: newSelector implementors: implementors senders: senders. - ! ! - -RenameSelector class removeSelector: #addActualImplementorsOf:in:to:andActualSendersTo:inSystem:! - -ChangeSelector class removeSelectorIfInBaseSystem: #addActualImplementorsOf:in:to:andActualSendersTo:inSystem:! - -SmalltalkEditor removeSelector: #rename:in:! - -SmalltalkEditor removeSelector: #rename:in:! - -SmalltalkEditor removeSelector: #renameSelectorOf:in:! - -Object subclass: #RefactoringApplier - instanceVariableNames: 'requestExitBlock refactoring changes' - classVariableNames: 'Appliers' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RefactoringApplier category: #'Tools-Refactoring'! -Object subclass: #RefactoringApplier - instanceVariableNames: 'requestExitBlock refactoring changes' - classVariableNames: 'Appliers' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier initialize! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3687-LiveTypingRefactoringSupport-HernanWilkinson-2019Mar12-21h51m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3685] on 26 March 2019 at 7:58:13 pm'! - -Refactoring subclass: #RenameGlobal - instanceVariableNames: 'system oldName newName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameGlobal category: #'Tools-Refactoring'! -Refactoring subclass: #RenameGlobal - instanceVariableNames: 'system oldName newName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #RenameGlobalApplier - instanceVariableNames: 'browser newName oldName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameGlobalApplier category: #'Tools-Refactoring'! -RefactoringApplier subclass: #RenameGlobalApplier - instanceVariableNames: 'browser newName oldName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringPrecondition subclass: #NewGlobalPrecondition - instanceVariableNames: 'system newName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #NewGlobalPrecondition category: #'Tools-Refactoring'! -RefactoringPrecondition subclass: #NewGlobalPrecondition - instanceVariableNames: 'system newName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!Browser methodsFor: 'refactorings' stamp: 'HAW 3/26/2019 19:11:22'! - renameGlobal - - (RenameGlobalApplier on: self for: '') value! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/26/2019 18:42:51'! - renameGlobalOn: aBrowser for: anOldName - - (RenameGlobalApplier on: aBrowser for: anOldName) value! ! -!RenameGlobal methodsFor: 'applying' stamp: 'HAW 3/26/2019 18:34:07'! - apply - - | renamedReferences | - - system at: newName put: (system at: oldName). - renamedReferences := self renameReferences. - system removeKey: oldName. - - ^renamedReferences - ! ! -!RenameGlobal methodsFor: 'initialization' stamp: 'HAW 3/26/2019 17:55:21'! - initializeFrom: anOldName to: aNewName in: aSystem - - oldName := anOldName. - newName := aNewName. - system := aSystem. - - ! ! -!RenameGlobal methodsFor: 'accessing' stamp: 'HAW 3/26/2019 17:56:01'! - newName - - ^newName ! ! -!RenameGlobal methodsFor: 'accessing' stamp: 'HAW 3/26/2019 18:03:41'! - referencesToOldName - - ^system allCallsOn: oldName! ! -!RenameGlobal methodsFor: 'applying - private' stamp: 'HAW 3/26/2019 17:55:21'! - newSourceCodeOf: aCompiledMethod - - | newSource | - - newSource := aCompiledMethod sourceCode copyReplacing: (self rangesToReplaceOf: aCompiledMethod) with: newName. - - ^newSource! ! -!RenameGlobal methodsFor: 'applying - private' stamp: 'HAW 3/26/2019 18:12:45'! - rangesForLiteralOf: methodNode - - | literalRanges | - - literalRanges := methodNode positionsForLiteralNode: oldName ifAbsent: [ #() ]. - literalRanges := literalRanges collect: [ :aRange | aRange first + 1 to: aRange last ]. - - ^literalRanges ! ! -!RenameGlobal methodsFor: 'applying - private' stamp: 'HAW 3/26/2019 18:12:31'! - rangesForLiteralVariableOf: methodNode - - ^methodNode positionsForLiteralVariableNode: oldName ifAbsent: [ #() ] - ! ! -!RenameGlobal methodsFor: 'applying - private' stamp: 'HAW 3/26/2019 17:14:05'! - rangesToReplaceOf: aCompiledMethod - - | methodNode ranges | - - methodNode := aCompiledMethod methodNode. - ranges := SortedCollection sortBlock: [ :leftRange :rightRange | leftRange first < rightRange first ]. - - ranges addAll: (self rangesForLiteralVariableOf: methodNode). - ranges addAll: (self rangesForLiteralOf: methodNode). - - ^ranges ! ! -!RenameGlobal methodsFor: 'applying - private' stamp: 'HAW 3/26/2019 19:36:06'! - references: aMethodReference classVarNamed: aName - - ^aMethodReference actualClass theNonMetaClass definesClassVariableNamedInHierarchy: aName ! ! -!RenameGlobal methodsFor: 'applying - private' stamp: 'HAW 3/26/2019 18:25:27'! - referencesOldName: aMethodReference - - ^self references: aMethodReference classVarNamed: oldName ! ! -!RenameGlobal methodsFor: 'applying - private' stamp: 'HAW 3/26/2019 18:34:48'! - rejectReferencesToClassVariablesFrom: references - - ^references reject: [ :aMethodReference | self referencesOldName: aMethodReference ].! ! -!RenameGlobal methodsFor: 'applying - private' stamp: 'HAW 3/26/2019 17:14:05'! - renameReference: aReferencingMethod - - | newSource | - - newSource := self newSourceCodeOf: aReferencingMethod. - aReferencingMethod methodClass compile: newSource ! ! -!RenameGlobal methodsFor: 'applying - private' stamp: 'HAW 3/26/2019 18:51:20'! - renameReferences - - | references | - - references := self referencesToOldName. - references := self rejectReferencesToClassVariablesFrom: references. - references do: [ :aReference | self renameReference: aReference compiledMethod ]. - - ^references! ! -!RenameGlobal class methodsFor: 'pre-conditions' stamp: 'HAW 3/26/2019 19:17:48'! - assert: anOldName isDefinedIn: aSystem - - (aSystem bindingOf: anOldName) ifNil: [ self signalGlobalNotDefined: anOldName ]! ! -!RenameGlobal class methodsFor: 'pre-conditions' stamp: 'HAW 3/26/2019 17:20:18'! - assert: anOldName isNotEqualTo: aNewName - - anOldName = aNewName ifTrue: [ self signalNewNameEqualsOldName]! ! -!RenameGlobal class methodsFor: 'pre-conditions' stamp: 'HAW 3/26/2019 17:18:11'! -assertIsNotClass: anOldName - - (Smalltalk classNamed: anOldName) ifNotNil: [ self signalGlobalToRenameCanNotBeClass]! ! -!RenameGlobal class methodsFor: 'pre-conditions' stamp: 'HAW 3/26/2019 19:50:14'! - assertIsNotEmpty: anOldName - - anOldName isEmpty ifTrue: [ self signalOldNameIsEmpty ]! ! -!RenameGlobal class methodsFor: 'pre-conditions' stamp: 'HAW 3/26/2019 17:39:50'! - newGlobalPreconditionClass - - ^NewGlobalPrecondition ! ! -!RenameGlobal class methodsFor: 'exceptions' stamp: 'HAW 3/26/2019 19:18:54'! - errorMessageForGlobalNotDefined: anOldName - - ^ anOldName asString, ' is not defined as global variable'! ! -!RenameGlobal class methodsFor: 'exceptions' stamp: 'HAW 3/26/2019 17:18:56'! - globalCanNotBeClassErrorMessage - - ^'Global to rename can not be a class'! ! -!RenameGlobal class methodsFor: 'exceptions' stamp: 'HAW 3/26/2019 18:56:16'! - newNameEqualsOldNameErrorMessage - - ^'New name is equal to the old one'! ! -!RenameGlobal class methodsFor: 'exceptions' stamp: 'HAW 3/26/2019 19:51:21'! - oldNameCanNotBeEmptyErrorMessage - - ^'Global variable name to rename can not be empty'! ! -!RenameGlobal class methodsFor: 'exceptions' stamp: 'HAW 3/26/2019 19:18:19'! - signalGlobalNotDefined: anOldName - - self refactoringError: (self errorMessageForGlobalNotDefined: anOldName)! ! -!RenameGlobal class methodsFor: 'exceptions' stamp: 'HAW 3/26/2019 17:18:37'! - signalGlobalToRenameCanNotBeClass - - self refactoringError: self globalCanNotBeClassErrorMessage! ! -!RenameGlobal class methodsFor: 'exceptions' stamp: 'HAW 3/26/2019 17:14:05'! - signalNewNameEqualsOldName - - self refactoringError: self newNameEqualsOldNameErrorMessage.! ! -!RenameGlobal class methodsFor: 'exceptions' stamp: 'HAW 3/26/2019 19:50:54'! - signalOldNameIsEmpty - - self refactoringError: self oldNameCanNotBeEmptyErrorMessage! ! -!RenameGlobal class methodsFor: 'instance creation' stamp: 'HAW 3/26/2019 17:15:55'! - from: anOldName to: aNewName - - ^self from: anOldName to: aNewName in: Smalltalk - ! ! -!RenameGlobal class methodsFor: 'instance creation' stamp: 'HAW 3/26/2019 19:48:41'! - from: anOldName to: aNewName in: aSystem - - self assertIsNotEmpty: anOldName. - self assert: anOldName isDefinedIn: aSystem. - self assertIsNotClass: anOldName. - self assert: anOldName isNotEqualTo: aNewName. - self newGlobalPreconditionClass valueFor: aNewName in: aSystem. - - ^self new initializeFrom: anOldName to: aNewName in: aSystem ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 3/26/2019 17:36:48'! - sendersFrom: methodReferences - - ^ methodReferences collect: [:aMethodReference | aMethodReference compiledMethod ]! ! -!RenameSelectorApplier class methodsFor: 'instance creation' stamp: 'HAW 3/26/2019 19:56:53'! - createAndValueHandlingExceptionsOn: aModel of: aMessageNode in: aSelectedClass at: aSelectedSelector - - ^self createAndValueHandlingExceptionsOn: aModel for: aMessageNode selector key in: aSelectedClass -! ! -!RenameGlobalApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 3/26/2019 18:53:42'! - askNewName - - newName := self request: 'Enter new name:' initialAnswer: oldName asString. - newName := newName withBlanksTrimmed asSymbol. - ! ! -!RenameGlobalApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 3/26/2019 19:13:49'! - askOldName - - oldName := self request: 'Enter global name to rename:' initialAnswer: oldName. - oldName := oldName withBlanksTrimmed asSymbol. - ! ! -!RenameGlobalApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 3/26/2019 19:13:00'! - requestRefactoringParameters - - oldName isEmpty ifTrue: [ self askOldName ]. - self askNewName! ! -!RenameGlobalApplier methodsFor: 'refactoring - creation' stamp: 'HAW 3/26/2019 18:36:05'! - createRefactoring - - ^RenameGlobal from: oldName to: newName in: Smalltalk ! ! -!RenameGlobalApplier methodsFor: 'refactoring - changes' stamp: 'HAW 3/26/2019 18:35:42'! - openChangedMethods - - changes ifNotEmpty: [ - MessageSetWindow openMessageList: changes label: 'Renamed references' autoSelect: newName ] -! ! -!RenameGlobalApplier methodsFor: 'refactoring - changes' stamp: 'HAW 3/26/2019 18:36:56'! - showChanges - - self openChangedMethods -! ! -!RenameGlobalApplier methodsFor: 'initialization' stamp: 'HAW 3/26/2019 18:37:12'! - initializeOn: aBrowser for: anOldName - - browser := aBrowser. - oldName := anOldName. - ! ! -!RenameGlobalApplier class methodsFor: 'instance creation' stamp: 'HAW 3/26/2019 19:12:35'! - on: aBrowser - - ^self on: aBrowser for: ''! ! -!RenameGlobalApplier class methodsFor: 'instance creation' stamp: 'HAW 3/26/2019 18:37:50'! - on: aBrowser for: anOldName - - ^self new initializeOn: aBrowser for: anOldName! ! -!NewGlobalPrecondition methodsFor: 'evaluating' stamp: 'HAW 3/26/2019 17:29:43'! - value - - self - assertNewNameIsNotEmpty; - assertNewNameIsSymbol; - assertNewNameHasNoSeparators; - assertNewNameDoesNotExistInSystem. - -! ! -!NewGlobalPrecondition methodsFor: 'evaluating - private' stamp: 'HAW 3/26/2019 17:26:43'! - assertNewNameDoesNotExistInSystem - - system at: newName ifPresent: [ :value | - value isBehavior - ifTrue: [ self signalClassAlreadyExists ] - ifFalse: [ self signalGlobalAlreadyExists ]].! ! -!NewGlobalPrecondition methodsFor: 'evaluating - private' stamp: 'HAW 3/26/2019 17:27:22'! - assertNewNameHasNoSeparators - - (newName anySatisfy: [:aChar | aChar isSeparator]) - ifTrue: [ self signalNewNameCanNotHaveSeparators ]! ! -!NewGlobalPrecondition methodsFor: 'evaluating - private' stamp: 'HAW 3/26/2019 17:28:35'! - assertNewNameIsNotEmpty - - newName withBlanksTrimmed isEmpty ifTrue: [ self signalNewNameCanNotBeEmpty]! ! -!NewGlobalPrecondition methodsFor: 'evaluating - private' stamp: 'HAW 3/26/2019 17:29:43'! - assertNewNameIsSymbol - - newName isSymbol ifFalse: [ self signalNewNameMustBeSymbol]! ! -!NewGlobalPrecondition methodsFor: 'initialization' stamp: 'HAW 3/26/2019 17:37:17'! - initializeFor: aNewName in: aSystem - - newName := aNewName. - system := aSystem. -! ! -!NewGlobalPrecondition methodsFor: 'exceptions' stamp: 'HAW 3/26/2019 17:26:07'! - signalClassAlreadyExists - - self refactoringError: (self class errorMessageForAlreadyExistClassNamed: newName).! ! -!NewGlobalPrecondition methodsFor: 'exceptions' stamp: 'HAW 3/26/2019 17:26:07'! - signalGlobalAlreadyExists - - self refactoringError: (self class errorMessageForAlreadyExistGlobalNamed: newName)! ! -!NewGlobalPrecondition methodsFor: 'exceptions' stamp: 'HAW 3/26/2019 17:28:54'! - signalNewNameCanNotBeEmpty - - self refactoringError: self class newNameCanNotBeEmptyErrorMessage! ! -!NewGlobalPrecondition methodsFor: 'exceptions' stamp: 'HAW 3/26/2019 17:27:57'! - signalNewNameCanNotHaveSeparators - - self refactoringError: self class newNameCanNotHaveSeparatorsErrorMessage ! ! -!NewGlobalPrecondition methodsFor: 'exceptions' stamp: 'HAW 3/26/2019 17:22:52'! - signalNewNameMustBeSymbol - - self refactoringError: self class newNameMustBeSymbolErrorMessage.! ! -!NewGlobalPrecondition class methodsFor: 'error messages' stamp: 'HAW 3/26/2019 17:26:34'! - errorMessageForAlreadyExistClassNamed: aNewName - - ^'Class named ', aNewName, ' already exist'! ! -!NewGlobalPrecondition class methodsFor: 'error messages' stamp: 'HAW 3/26/2019 17:26:21'! - errorMessageForAlreadyExistGlobalNamed: aNewName - - ^'There is already a global variable named ', aNewName ! ! -!NewGlobalPrecondition class methodsFor: 'error messages' stamp: 'HAW 3/26/2019 17:29:00'! - newNameCanNotBeEmptyErrorMessage - - ^'New name can not be empty'! ! -!NewGlobalPrecondition class methodsFor: 'error messages' stamp: 'HAW 3/26/2019 17:28:07'! - newNameCanNotHaveSeparatorsErrorMessage - - ^'New name can not have separators'! ! -!NewGlobalPrecondition class methodsFor: 'error messages' stamp: 'HAW 3/26/2019 17:30:05'! - newNameMustBeSymbolErrorMessage - - ^'New name must be a symbol'! ! -!NewGlobalPrecondition class methodsFor: 'instance creation' stamp: 'HAW 3/26/2019 17:38:25'! - for: aNewName in: aSystem - - ^self new initializeFor: aNewName in: aSystem ! ! -!NewGlobalPrecondition class methodsFor: 'evaluation' stamp: 'HAW 3/26/2019 17:40:04'! - valueFor: aNewName in: aSystem - - ^(self for: aNewName in: aSystem) value! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 3/26/2019 18:57:11' prior: 50450074! - rename: aNodeUnderCursor in: aSelectedClass at: aSelectedSelector - - aNodeUnderCursor isTempOrArg ifTrue: [ ^self renameTemporary: aNodeUnderCursor name ]. - - self ifRenameCanBeAppliedDo: [ - aNodeUnderCursor isMessageNode ifTrue: [ ^ self renameSelectorOf: aNodeUnderCursor in: aSelectedClass at: aSelectedSelector ]. - aNodeUnderCursor isInstanceVariableNode ifTrue: [ ^ self renameInstanceVariableOn: self codeProvider for: aNodeUnderCursor name at: aSelectedClass ]. - aNodeUnderCursor isLiteralVariableNode ifTrue: [ | variableName | - variableName := aNodeUnderCursor key key. - (Smalltalk classNamed: variableName) ifNotNil: [ :classToRename | ^self renameClassOn: self codeProvider for: classToRename ]. - (Smalltalk bindingOf: variableName) ifNotNil: [ ^self renameGlobalOn: self codeProvider for: variableName ] ]. - - ^morph flash ]! ! -!InsertSuperclass class methodsFor: 'instance creation' stamp: 'HAW 3/3/2019 09:11:31' prior: 50440554! - to: aClass named: aSuperclassName in: aSystem undeclared: anUndeclared - - self newClassPreconditionClass valueFor: aSuperclassName in: aSystem undeclared: anUndeclared. - - ^self new initializeTo: aClass theNonMetaClass named: aSuperclassName ! ! -!RenameClass class methodsFor: 'exceptions' stamp: 'HAW 3/26/2019 18:56:37' prior: 50440835! - newNameEqualsOldNameErrorMessage - - ^'New class name is equal to the old one'! ! -!RenameClass class methodsFor: 'instance creation' stamp: 'HAW 8/13/2018 18:45:15' prior: 50440865! - from: aClass to: aNewClassName in: aSystem undeclared: anUndeclaredDictionary - - self assertIsNotMeta: aClass. - self assert: aClass isNotNamed: aNewClassName. - self newClassPreconditionClass valueFor: aNewClassName in: aSystem undeclared: anUndeclaredDictionary. - - ^self new initializeFrom: aClass to: aNewClassName in: aSystem undeclared: anUndeclaredDictionary -! ! -!RefactoringMenues class methodsFor: 'browser menues' stamp: 'HAW 3/26/2019 19:09:35' prior: 50446039! - classRefactoringMenuOptions - - ^ `{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'rename class... (R)'. - #object -> #model. - #selector -> #renameClass. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'insert superclass...'. - #object -> #model. - #selector -> #insertSuperclass. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'safely remove class (x)'. - #object -> #model. - #selector -> #safelyRemoveClass. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'add inst var...'. - #selector -> #addInstVar. - #icon -> #listAddIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'rename inst var...'. - #selector -> #renameInstVar. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'remove inst var...'. - #selector -> #removeInstVar. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 40. - #label -> 'remove all unreferenced inst var...'. - #selector -> #removeAllUnreferencedInstVar. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'rename global...'. - #object -> #model. - #selector -> #renameGlobal. - #icon -> #saveAsIcon - } asDictionary. - }`. - ! ! -!NewClassPrecondition class methodsFor: 'evaluation' stamp: 'HAW 8/13/2018 17:37:20' prior: 50442717! - valueFor: aNewClassName in: aSystem undeclared: anUndeclaredDictionary - - ^(self for: aNewClassName in: aSystem undeclared: anUndeclaredDictionary) value! ! - -NewGlobalPrecondition class removeSelector: #errorMessageForNewClassIsUndeclared:! - -NewGlobalPrecondition class removeSelector: #for:in:undeclared:! - -NewGlobalPrecondition class removeSelector: #newClassCanNotHaveSeparatorsErrorMessage! - -NewGlobalPrecondition class removeSelector: #newClassNameCanNotBeEmptyErrorMessage! - -NewGlobalPrecondition class removeSelector: #newClassNameCanNotHaveSeparatorsErrorMessage! - -NewGlobalPrecondition class removeSelector: #newNameMustStartWithUppercaseLetterErrorMessage! - -NewGlobalPrecondition class removeSelector: #valueFor:in:undeclared:! - -NewGlobalPrecondition removeSelector: #assertNewClassNameDoesNotExistInSystem! - -NewGlobalPrecondition removeSelector: #assertNewClassNameHasNoSeparators! - -NewGlobalPrecondition removeSelector: #assertNewClassNameIsNotEmpty! - -NewGlobalPrecondition removeSelector: #assertNewClassNameIsNotUndeclaredInUndeclared! - -NewGlobalPrecondition removeSelector: #assertNewClassNameStartsWithUppercaseLetter! - -NewGlobalPrecondition removeSelector: #assertNewClassNameSymbol! - -NewGlobalPrecondition removeSelector: #assertNewNameSymbol! - -NewGlobalPrecondition removeSelector: #initializeFor:in:undeclared:! - -NewGlobalPrecondition removeSelector: #signalNewClassIsUndeclared! - -NewGlobalPrecondition removeSelector: #signalNewClassNameCanNotBeEmpty! - -NewGlobalPrecondition removeSelector: #signalNewClassNameCanNotHaveSeparators! - -NewGlobalPrecondition removeSelector: #signalNewNameMustStartWithUppercaseLetter! - -RenameGlobalApplier removeSelector: #askNewClassName! - -RenameGlobalApplier removeSelector: #informChangesToBrowser! - -RenameSelectorApplier class removeSelector: #createAndValueHandlingExceptionsOn:of:in:! - -RenameSelectorApplier class removeSelector: #createAndValueHandlingExceptionsOn:of:in:! - -RenameSelectorApplier removeSelector: #sendersFrom:! - -RenameSelectorApplier removeSelector: #sendersFrom:! - -RenameGlobal class removeSelector: #assert:isNotNamed:! - -RenameGlobal class removeSelector: #assertIsNotMeta:! - -RenameGlobal class removeSelector: #classToRenameCanNotBeMetaclassErrorMessage! - -RenameGlobal class removeSelector: #from:to:in:undeclared:! - -RenameGlobal class removeSelector: #newClassPreconditionClass! - -RenameGlobal class removeSelector: #signalClassToRenameCanNotBeMetaclass! - -RenameGlobal removeSelector: #initializeFrom:to:in:undeclared:! - -RenameGlobal removeSelector: #newClassName! - -RenameGlobal removeSelector: #referencesNewClassName:! - -RenameGlobal removeSelector: #referencesOldClassName:! - -RenameGlobal removeSelector: #referencesToOldClass! - -RenameGlobal removeSelector: #referencesToOldClassName! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3688-RenameGlobalRefactoring-HernanWilkinson-2019Mar24-20h01m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3688] on 27 March 2019 at 10:21:01 am'! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 3/26/2019 12:03:11' prior: 16844595! -arcTan: denominator - "Answer the angle in radians. - Implementation note: use sign in order to catch cases of negativeZero" - - ^self = 0.0 - ifTrue: [denominator sign >= 0 - ifTrue: [ 0.0 ] - ifFalse: [ self sign >= 0 - ifTrue: [ Pi ] - ifFalse: [ Pi negated ]]] - ifFalse: [denominator = 0.0 - ifTrue: [self > 0.0 - ifTrue: [ Halfpi ] - ifFalse: [ Halfpi negated ]] - ifFalse: [denominator > 0.0 - ifTrue: [ (self / denominator) arcTan ] - ifFalse: [self > 0.0 - ifTrue: [ ((self / denominator) arcTan) + Pi ] - ifFalse: [ ((self / denominator) arcTan) - Pi ]]]]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3689-ArcTanTweak-JuanVuletich-2019Mar27-10h20m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3689] on 28 March 2019 at 8:56:04 am'! -!Morph methodsFor: 'events' stamp: 'jmv 3/28/2019 08:54:29' prior: 50449182! - mouseLeave: evt - "Handle a mouseLeave event, meaning the mouse just left my bounds with no button pressed." - Preferences focusFollowsMouse - ifTrue: [evt hand releaseKeyboardFocus: self]. - "Allow instances to dynamically use properties for handling common events." - self - valueOfProperty: #mouseLeave: - ifPresentDo: [ :handler | handler value: evt ].! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3690-FixFocusHandlingIfClickToFocusIsOn-JuanVuletich-2019Mar28-08h55m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3690] on 5 April 2019 at 5:29:12 pm'! -!Float commentStamp: 'jmv 4/5/2019 17:21:41' prior: 50425181! - A note About Floating Point numbers and Floating Point Arithmetic. - -The following is not specific to Cuis or Smalltalk at all. This is about the properties of Float numbers in any computer implementation. - -If you haven't done so already, read https://en.wikipedia.org/wiki/Floating-point_arithmetic - -But if you find the Wikipedia article too detailed, or hard to read, then try http://fabiensanglard.net/floating_point_visually_explained/ (get past "How Floating Point are usually explained" and read "A different way to explain..."). - -Other great reads are: - "Why don't my numbers add up?": - http://floating-point-gui.de/ -and - "What Every Computer Scientist Should Know About Floating-Point Arithmetic": - http://docs.oracle.com/cd/E19957-01/806-3568/ncg_goldberg.html -and also maybe - "Comparing floating point numbers" - https://randomascii.wordpress.com/2012/02/25/comparing-floating-point-numbers-2012-edition/ - -Now that you read them, and we are on the same boat, some further comments (from jmv): - -Floats are (conceptually) approximate real numbers. That's why trig and other trascendental functions always answer Floats. That's why it is ok to round the result of operations. That's why Float is considered more general than Fraction in ST-80 and most Smalltalks. So, when we have a Float value, we must not think about it as a Rational but as a Real (actually as some unknown Real that could hopefully be close to the Rational we can actually represent). Keep this in mind when dealing with Floats, and especially avoid comparing them for equality. - -When doing mixed operations with Floats and Fractions, Cuis, as most other Smalltalks, converts all values to Floats. Some other systems, including Pharo Smalltalk, Scheme and Lisp have two rules: when the answer is a Number, they convert to Float. But when the answer is a boolean (#<, #=, #<=, etc.) they convert to Fraction. We think this is a mistake. There should never be implicit conversions from Float to Fraction. Fractions are to hold exact values, and people expect Fractions to be exact. On the other hand, Floats are to hold approximations (and people should be aware of that!!). But an implicit conversion from Float to Fraction would give a Fraction that should not be considered an exact value (the value comes from an inexact Float), but that knowledge is lost, as it is an instance of Fraction. - -If you want exact arithmetic, usual mathematical properties (like transitivity of equality), can live in the limited world of Rational numbers, and can afford a slight performance penalty, use Fraction instead. Avoid trascendental functions and never convert to Float. - -In any case, most numeric computation is done on Float numbers. There are good reasons for that. One is that in most cases we don't need an exact answer. And in many cases we can't really have it: the inputs to algorithms already have a limited precision, or they use trascendental functions. And even when exact arithmetic possible, if we are doing sound synthesis, 24 bits of resolution is enough. For image processing and graphics, the result is never more than 16 bits per channel. So, these fields don't really need 64 bit Doubles. 32 bit Floats are enough. Other fields do need 64 bit Doubles, like physics simulations and geometry. Games usually prefer special, faster 32 bit Float operations in GPUs that have greater errors but are faster. - -There are some things that can be done to increase the confidence you can have on Float results. One is to do an error propagation analysis on the code you are running. This is not easy, but it is done for any widely used numerical method. Then, you can know real bounds and/or estimates of the errors made. So, understanding your inputs and your algorithms (for example error propagation, condition number, numeric stability), and using Float number if appropriate, is the usual advice. - -Perhaps you have heard about "interval arithmetic". It is a bit better than simple Float, but doesn't really fix the problems. - -The ultimate solution is to do Monte Carlo analysis, with random perturbation of inputs. After the Monte Carlo run, it is needed to do statistical analysis of possible correlations between the distributions of the random noise added to imputs and the result of the algorithm. - -Additional food for thought: http://www.cs.berkeley.edu/~wkahan/Mindless.pdf . According to this, doing Monte Carlo as described above attacks a slightly different problem. This might be yet another reason (besides performance) to try something like the next paragraph. I (jmv) came up with it, and I don't really know if it has been described and or tried before or not. Mhhh. Maybe a defensive publication is in order. - -A possibility that could be a practical solution, being much cheaper than Monte Carlo, but better than interval arithmetic, is to represent each value by 2 Floats: an estimation of the real value (i.e. an estimation of the mean value of the distribution of the corresponding Monte Carlo result), and an estimation of the error (i.e. an estimation of the standard deviation of the corresponding Monte Carlo result). Or perhaps even 3 of them. In addition to the estimation of the real value and an estimation of the error, we could add a hard bound on the error. In many cases it will be useless, because the error can not really be bound. But in those cases where it is possible to bound it, applications could really know about the quality of computed values. - -======================================================================= - -My instances represent IEEE 754 floating-point double-precision numbers. They have about 16 decimal digits of accuracy and their range is between plus and minus 10^307. Some valid examples are: - - 8.0 13.3 0.3 2.5e6 1.27e-30 1.27e-31 -12.987654e12 - -Mainly: no embedded blanks, little e for tens power, and a digit on both sides of the decimal point. It is actually possible to specify a radix for Float constants. This is great for teaching about numbers, but may be confusing to the average reader: - - 3r20.2 --> 6.66666666666667 - 8r20.2 --> 16.25 - -If you don't have access to the definition of IEEE754, you can figure out what is going on by printing various simple values in Float hex. It may help you to know that the basic format is... - sign 1 bit - exponent 11 bits with bias of 1023 (16r3FF), substracted to produce an actual exponent in the range -1022 .. +1023 - - 16r000: - significand = 0: Float zero - significand ~= 0: Denormal number (actual exponent is -1022, not -1023. No implicit leading '1' bit in mantissa) - - 16r7FF: - significand = 0: Infinity - significand ~= 0: Not A Number (NaN) representation - mantissa 53 bits, but only 52 are stored (20 in the first word, 32 in the second). This is because a normalized mantissa, by definition, has a 1 to the right of its floating point, and IEEE 754 omits this redundant bit to gain an extra bit of precision instead. People talk about the mantissa without its leading one as the FRACTION, and with its leading 1 as the SIGNFICAND. - -The single-precision format is... - sign 1 bit - exponent 8 bits with bias of 127 (16r7F, substracted to produce an actual exponent in the range -126 .. +127 - - 16r00: - significand = 0: Float zero - significand ~= 0: Denormal number (actual exponent is -126, not -127. No implicit leading '1' bit in mantissa) - - 16rFF: - significand = 0: Infinity - significand ~= 0: Not A Number (NaN) representation - mantissa 24 bits, but only 23 are stored -This format is used in FloatArray (qv), and much can be learned from the conversion routines, Float asIEEE32BitWord, and Float class fromIEEE32Bit:. - -You might also check https://en.wikipedia.org/wiki/IEEE_754_revision - -Other great reads (covering broader but interesting issues): -https://randomascii.wordpress.com/2013/07/16/floating-point-determinism/ -http://www.ima.umn.edu/2010-2011/W1.10-14.11/activities/Leeser-Miriam/Leeser-GPU-IMA-Jan2011.pdf! -!Number methodsFor: 'testing' stamp: 'jmv 4/5/2019 10:02:36'! - isFinite - ^ true! ! -!Complex methodsFor: 'arithmetic' stamp: 'jmv 4/5/2019 09:09:44'! - complexConjugate - "Return the complex conjugate of this complex number." - - ^self class real: real imaginary: imaginary negated! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 4/5/2019 16:19:44' prior: 50421758! -predecessor - "Answer the largest Float smaller than self" - - self isFinite ifFalse: [ - (self isNaN or: [self negative]) ifTrue: [^self]. - ^Float fmax]. - self signBit = 1 ifTrue: [ "Negative or -0.0" - ^ self nextAwayFromZero ]. - self = 0.0 ifTrue: [ - ^ -0.0 ]. - ^ self nextTowardsZero.! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 4/5/2019 16:11:39' prior: 50425707! - signBit - " - Actual sigh bit part of the floating point representation. - 0 means positive number or 0.0 - 1 means negative number or -0.0 - Just extract the bit. Do not correct denormals. Do not subtract bias. Do nothing with infinites and NaN. - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0. 0.0. -0.0} do: [ :f | - { f. f signBit. f signPart. f sign } print ]. - " - - ^ self partBits: [ :signBit :exponentBits :mantissaBits | signBit ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 4/5/2019 16:14:21' prior: 50414515! - signPart - "The sign of the mantissa. - 1 means positive number or 0.0 - -1 means negative number or -0.0 - See #mantissaPart and #exponentPart" - " - | f | - f := -2.0. - (f signPart * f mantissaPart * (2 raisedToInteger: f exponentPart-52)) asFloat. - " - ^self partValues: [ :sign :exponent :mantissa | sign ]! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 4/5/2019 16:18:03' prior: 50421772! - successor - "Answer the smallest Float greater than self" - - self isFinite ifFalse: [ - (self isNaN or: [self positive]) ifTrue: [^self]. - ^Float fmax negated]. - self signBit = 0 ifTrue: [ - ^ self nextAwayFromZero ]. - self = -0.0 ifTrue: [ - ^ 0.0 ]. - ^ self nextTowardsZero.! ! -!Float methodsFor: 'testing' stamp: 'jmv 4/5/2019 16:14:46' prior: 50425428! - sign - "Answer 1 if the receiver is greater than 0, -1 if less than 0, else 0. - Handle IEEE754 negative-zero by reporting a sign of -1 - Warning!! This makes Float negativeZero the only number in the system such that - x sign negated = x negated sign - evaluates to false!! - This precludes the simpler implementation in #signPart - 0.0 sign -> 0 - 0.0 signPart -> 1 - -0.0 sign -> -1 - -0.0 signPart -> -1 - " - - "Negative number or -0.0" - self signBit = 1 ifTrue: [ ^ -1 ]. - - "Zero" - self = 0.0 ifTrue: [ ^ 0 ]. - - "Positive number otherwise" - ^ 1! ! -!Float class methodsFor: 'instance creation' stamp: 'jmv 4/5/2019 17:23:54' prior: 16845757! - fromIEEE32Bit: word - "Convert the given 32 bit word (which is supposed to be a positive 32bit value) from - a 32bit IEEE floating point representation into an actual Float object (being - 64bit wide). Should only be used for conversion in FloatArrays or likewise objects." - - | sign exponent mantissa exponentBits fractionBits answerFractionBits delta signBit answerExponent | - word negative ifTrue: [ ^ self error: 'Cannot deal with negative numbers' ]. - word = 0 ifTrue: [ ^ Float zero ]. - word = 16r80000000 ifTrue: [ ^Float negativeZero ]. - - signBit _ word bitAnd: 16r80000000. - sign _ (word bitShift: -31) = 0 ifTrue: [1] ifFalse: [-1]. - exponentBits _ (word bitShift: -23) bitAnd: 16rFF. - fractionBits _ word bitAnd: 16r7FFFFF. - - " Special cases: infinites and NaN" - exponentBits = 16rFF ifTrue: [ - fractionBits = 0 ifFalse: [ ^ Float nan ]. - ^ sign positive - ifTrue: [ Float infinity ] - ifFalse: [ Float negativeInfinity ]]. - - " Unbias exponent: 16r3FF is bias" - exponent _ exponentBits - 16r7F. - -"Older version." -false ifTrue: [ - " Replace omitted leading 1 in fraction if appropriate" - "If expPart = 0, I am +/-zero or a denormal value. In such cases, no implicit leading bit in mantissa" - exponentBits = 0 - ifTrue: [ - "gradual underflow (denormalized number) - There is no implied one, but the exponent is -126" - mantissa _ fractionBits. - answerExponent _ exponent + 1 ] - ifFalse: [ - mantissa _ fractionBits + 16r800000. - answerExponent _ exponent ]. - ^ (sign * mantissa) asFloat timesTwoPower: answerExponent - 23 ]. - - "Newer version" - exponentBits = 0 - ifTrue: [ - "gradual underflow (denormalized number) - Remove first bit of mantissa and adjust exponent" - delta := fractionBits highBit. - answerFractionBits := (fractionBits bitAnd: (1 bitShift: delta - 1) - 1) bitShift: 24 - delta. - answerExponent := exponent + delta - 23] - ifFalse: [ - answerFractionBits _ fractionBits. - answerExponent _ exponent ]. - - "Create new float" - ^ (self basicNew: 2) - basicAt: 1 put: ((signBit bitOr: (1023 + answerExponent bitShift: 20)) bitOr: (answerFractionBits bitShift: -3)); - basicAt: 2 put: ((answerFractionBits bitAnd: 7) bitShift: 29); - * 1.0. "reduce to SmallFloat64 if possible" - -" -Float fromIEEE32Bit: Float pi asIEEE32BitWord -(Float fromIEEE32Bit: Float pi asIEEE32BitWord ) = Float pi -(Float fromIEEE32Bit: Float pi asIEEE32BitWord ) - Float pi - -Float fromIEEE32Bit: (Float pi / 1e40) asIEEE32BitWord -(Float fromIEEE32Bit: (Float pi / 1e40) asIEEE32BitWord) = (Float pi / 1e40) -(Float fromIEEE32Bit: (Float pi / 1e40) asIEEE32BitWord) - (Float pi / 1e40) -"! ! -!Float class methodsFor: 'constants' stamp: 'jmv 4/5/2019 17:28:20' prior: 16845859! - denormalized - "Answer whether implementation supports denormalized numbers. - Denormalized numbers guarantees that the result x - y is non-zero when x !!= y." - - ^true! ! -!Float class methodsFor: 'constants' stamp: 'jmv 4/5/2019 17:28:36' prior: 16845897! - fminDenormalized - "Answer the minimum denormalized value representable. - Denormalized numbers guarantees that the result x - y is non-zero when x !!= y. - " - - ^1.0 timesTwoPower: MinValLogBase2! ! -!Float class methodsFor: 'constants' stamp: 'jmv 4/5/2019 16:58:02' prior: 16845942! - negativeZero - "Negative Zero is a very special number - -0.0 = 0.0 evaluates to true - Any function evaluated in -0.0 gives the same result as evaluated in 0.0. - Exceptions are: - 0.0 sign -> 0 - -0.0 sign -> -1 - - 0.0 negated -> -0.0 - -0.0 negated -> 0.0 - - 0.0 sqrt -> 0.0 - -0.0 sqrt -> -0.0 - The behavior of negative zero is specified in IEEE 754 - " - - ^ NegativeZero! ! -!BoxedFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 4/5/2019 16:32:47' prior: 50400391! - primSqrt - "Answer the square root of the receiver. - Optional. See Object documentation whatIsAPrimitive. - Note: - -0.0 primSqrt - -0.0 sqrt - both evaluate to -0.0 - " - - - ^Float nan! ! -!Complex methodsFor: 'arithmetic' stamp: 'jmv 4/5/2019 09:48:03' prior: 16822321! - * aNumber - "Answer the result of multiplying the receiver by aNumber." - | c d newReal newImaginary | - aNumber isComplex - ifTrue: [ - c _ aNumber real. - d _ aNumber imaginary. - newReal _ (real * c) - (imaginary * d). - newImaginary _ (real * d) + (imaginary * c) ] - ifFalse: [ - newReal _ real * aNumber. - newImaginary _ imaginary * aNumber ]. - ^ Complex real: newReal imaginary: newImaginary! ! -!Complex methodsFor: 'arithmetic' stamp: 'jmv 4/5/2019 09:48:36' prior: 16822337! - + aNumber - "Answer the sum of the receiver and aNumber." - ^ Complex - real: real + aNumber real - imaginary: imaginary + aNumber imaginary.! ! -!Complex methodsFor: 'arithmetic' stamp: 'jmv 4/5/2019 09:48:52' prior: 16822351! - - aNumber - "Answer the difference between the receiver and aNumber." - ^ Complex - real: real - aNumber real - imaginary: imaginary - aNumber imaginary.! ! -!Complex methodsFor: 'arithmetic' stamp: 'jmv 4/5/2019 10:34:02' prior: 16822366! - / aNumber - "Answer the result of dividing receiver by aNumber" - | c d newReal newImaginary s e f | - aNumber isComplex - ifTrue: [ - c _ aNumber real. - d _ aNumber imaginary. - e _ (real * c) + (imaginary * d). - e isFinite ifFalse: [ ^ self divideFastAndSecureBy: aNumber ]. - f _ (imaginary * c) - (real * d). - s _ (c * c) + (d * d). - (e isFloat and: [ s = 0.0 ]) ifTrue: [ ^ self divideFastAndSecureBy: aNumber ]. - newReal _ e / s. - newImaginary _ f / s ] - ifFalse: [ - newReal _ real / aNumber. - newImaginary _ imaginary / aNumber ]. - ^ Complex real: newReal imaginary: newImaginary! ! -!Complex methodsFor: 'arithmetic' stamp: 'jmv 4/5/2019 09:58:22' prior: 16822414! - divideFastAndSecureBy: aComplex - "Answer the result of dividing receiver by aNumber" - " Both operands are scaled to avoid arithmetic overflow. - This algorithm works for a wide range of values, and it needs only three divisions." - | r d newReal newImaginary | - aComplex real abs > aComplex imaginary abs - ifTrue: [ - r _ aComplex imaginary / aComplex real. - d _ r * aComplex imaginary + aComplex real. - newReal _ r * imaginary + real / d. - newImaginary _ r negated * real + imaginary / d ] - ifFalse: [ - r _ aComplex real / aComplex imaginary. - d _ r * aComplex real + aComplex imaginary. - newReal _ r * real + imaginary / d. - newImaginary _ r * imaginary - real / d ]. - ^ Complex - real: newReal - imaginary: newImaginary.! ! -!Complex methodsFor: 'comparing' stamp: 'jmv 4/5/2019 08:37:31' prior: 16822502! - = anObject - self == anObject ifTrue: [ ^ true ]. - anObject isNumber ifFalse: [^false]. - ^real = anObject real and: [ imaginary = anObject imaginary ]! ! -!Transcript class methodsFor: 'private' stamp: 'jmv 4/5/2019 16:11:01' prior: 50431463! - finishEntry - | newEntry | - self unfinishedEntrySize > 0 ifTrue: [ - newEntry _ unfinishedEntry contents. - unfinishedEntry reset. - lastDisplayPosition _ 0. - self addEntry: newEntry. - self display ].! ! - -Complex removeSelector: #conjugated! - -Complex removeSelector: #conjugated! - -Complex removeSelector: #divideSecureBy:! - -Complex removeSelector: #divideSecureBy:! - -Number removeSelector: #adaptToComplex:andSend:! - -Number removeSelector: #adaptToComplex:andSend:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3691-FloatAndComplexFixes-JuanVuletich-2019Apr05-08h34m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3690] on 5 April 2019 at 1:21:24 am'! - -"Change Set: 3691-CuisCore-AuthorName-2019Apr05-01h16m -Date: 5 April 2019 -Author: Nahuel Garbezza - -replace calls to messageListIndex: 0 by reformulateList which does that"! -!Browser methodsFor: 'message functions' stamp: 'RNG 4/5/2019 01:19:29' prior: 16792332! - removeMessage - "If a message is selected, create a Confirmer so the user can verify that - the currently selected message should be removed from the system. If - so, - remove it. If the Preference 'confirmMethodRemoves' is set to false, the - confirmer is bypassed." - | messageName confirmation | - selectedMessage ifNil: [ ^self ]. - messageName _ self selectedMessageName. - confirmation _ Smalltalk confirmRemovalOf: messageName on: self selectedClassOrMetaClass. - confirmation = 3 - ifTrue: [^ self]. - self selectedClassOrMetaClass removeSelector: self selectedMessageName. - self reformulateList. - self changed: #messageList. - self setClassOrganizer. - "In case organization not cached" - confirmation = 2 - ifTrue: [Smalltalk browseAllCallsOn: messageName]! ! -!Browser methodsFor: 'initialization' stamp: 'RNG 4/5/2019 01:19:09' prior: 16792851! - methodCategoryChanged - self changed: #messageCategoryList. - self changed: #messageList. - self triggerEvent: #annotationChanged. - self reformulateList! ! -!CodeFileBrowser methodsFor: 'removing' stamp: 'RNG 4/5/2019 01:19:43' prior: 16809136! - removeMessage - | messageName | - selectedMessage ifNil: [ ^self ]. - messageName _ self selectedMessageName. - (self selectedClass confirmRemovalOf: messageName) - ifFalse: [^ false]. - self selectedClassOrMetaClass removeMethod: self selectedMessageName. - self reformulateList. - self setClassOrganizer. - "In case organization not cached" - self changed: #messageList! ! -!CodeFileBrowser methodsFor: 'removing' stamp: 'RNG 4/5/2019 01:20:08' prior: 16809194! - removeUnmodifiedMethods - | theClass cat | - theClass := self selectedClassOrMetaClass. - theClass ifNil: [ ^self]. - cat := self selectedMessageCategoryName. - cat ifNil: [ ^self]. - theClass removeUnmodifiedMethods: (theClass organization listAtCategoryNamed: cat). - self reformulateList. - self changed: #messageList.! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'RNG 4/5/2019 01:18:54' prior: 50443864! - pushUpSelector - - model selectedMessageName ifNotNil: [ :selectedSelector | - (PushUpMethod for: model selectedClassOrMetaClass>>selectedSelector) apply. - model reformulateList. - model changed: #messageList. - model setClassOrganizer ].! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3692-Cleanup-NahuelGarbezza-2019Apr05-01h16m-RNG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3692] on 5 April 2019 at 5:52:57 pm'! -!CodeFileBrowser methodsFor: 'infoView' stamp: 'KenD 3/30/2019 02:10:13' prior: 16809357! - extraInfo - ^ (self - methodDiffFor: (self selectedClassOrMetaClass sourceCodeAt: self selectedMessageName) - class: self selectedClass - selector: self selectedMessageName - meta: self metaClassIndicated) hasAnyAttribute - ifTrue: [' - **MODIFIED**'] - ifFalse: [' - identical']! ! -!CodeFileBrowser methodsFor: 'infoView' stamp: 'KenD 3/30/2019 02:11:17' prior: 16809368! - infoViewContents - | theClass | - editSelection == #newClass ifTrue: [ - ^codeFile - ifNil: [ 'No file selected' ] - ifNotNil: [ codeFile summary ]]. - self selectedClass ifNil: [^ '']. - theClass _ Smalltalk at: self selectedClass name asSymbol ifAbsent: nil. - editSelection == #editClass ifTrue: [ - ^ theClass - ifNotNil: ['Class exists already in the system'] - ifNil: ['Class not in the system']]. - editSelection == #editMessage ifFalse: [^ '']. - (theClass notNil and: [self metaClassIndicated]) - ifTrue: [theClass _ theClass class]. - ^ (theClass notNil and: [theClass includesSelector: self selectedMessageName]) - ifTrue: ['Method already exists' , self extraInfo] - ifFalse: ['**NEW** Method not in the system']! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3693-CodeFileBrowserEnhancement-KenDickey-2019Apr05-17h52m-KenD.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3693] on 8 April 2019 at 9:47:04 am'! -!Float methodsFor: 'testing' stamp: 'jmv 4/8/2019 09:43:05'! - isDenormalized - "Denormalized numbers are only represented as BoxedFloat64" - - ^ false! ! -!BoxedFloat64 methodsFor: 'testing' stamp: 'jmv 4/8/2019 09:43:27'! - isDenormalized - "Denormalized numbers are only represented as BoxedFloat64" - - ^ self partBits: [ :signBit :exponentBits :mantissaBits | - exponentBits = 0 and: [mantissaBits ~=0]]! ! -!Complex methodsFor: 'arithmetic' stamp: 'jmv 4/5/2019 19:37:44'! - safeAbs - "Answer the distance of the receiver from zero (0 + 0 i). - Try avoiding overflow and/or underflow" - - | scale a b | - scale _ real abs max: imaginary abs. - scale = 0.0 - ifTrue: [^0.0]. - a _ real / scale. - b _ imaginary / scale. - ^((a * a) + (b * b)) sqrt * scale! ! -!Complex methodsFor: 'arithmetic' stamp: 'jmv 4/8/2019 09:44:54'! - safeDivideBy: aComplex - "Answer the result of dividing receiver by aNumber" - " Both operands are scaled to avoid arithmetic overflow. - This algorithm works for a wide range of values, and it needs only three divisions." - | r d newReal newImaginary | - aComplex real abs > aComplex imaginary abs - ifTrue: [ - r _ aComplex imaginary / aComplex real. - d _ r * aComplex imaginary + aComplex real. - newReal _ r * imaginary + real / d. - newImaginary _ r negated * real + imaginary / d ] - ifFalse: [ - r _ aComplex real / aComplex imaginary. - d _ r * aComplex real + aComplex imaginary. - newReal _ r * real + imaginary / d. - newImaginary _ r * imaginary - real / d ]. - ^ Complex - real: newReal - imaginary: newImaginary.! ! -!Complex methodsFor: 'arithmetic' stamp: 'jmv 4/8/2019 09:45:16' prior: 50451534! - / aNumber - "Answer the result of dividing receiver by aNumber" - | c d newReal newImaginary s e f | - aNumber isComplex - ifTrue: [ - c _ aNumber real. - d _ aNumber imaginary. - e _ (real * c) + (imaginary * d). - e isFinite ifFalse: [ ^ self safeDivideBy: aNumber ]. - f _ (imaginary * c) - (real * d). - s _ (c * c) + (d * d). - (e isFloat and: [ s = 0.0 ]) ifTrue: [ ^ self safeDivideBy: aNumber ]. - newReal _ e / s. - newImaginary _ f / s ] - ifFalse: [ - newReal _ real / aNumber. - newImaginary _ imaginary / aNumber ]. - ^ Complex real: newReal imaginary: newImaginary! ! -!Complex methodsFor: 'arithmetic' stamp: 'jmv 4/5/2019 19:56:25' prior: 16822382! -abs - "Answer the distance of the receiver from zero (0 + 0 i)." - - | absSquared | - absSquared _ (real * real) + (imaginary * imaginary). - absSquared isFloat ifTrue: [ - absSquared < Float fminNormalized ifTrue: [ - ^ self safeAbs ]. - absSquared isFinite ifFalse: [ - ^ self safeAbs ]]. - ^absSquared sqrt! ! - -Complex removeSelector: #absSecure! - -Complex removeSelector: #absSecure! - -Complex removeSelector: #divideFastAndSecureBy:! - -Complex removeSelector: #divideFastAndSecureBy:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3694-FloatAndComplexTweaks-JuanVuletich-2019Apr08-09h42m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3694] on 8 April 2019 at 2:43:51 pm'! -!Character methodsFor: 'accessing' stamp: 'jmv 4/8/2019 14:19:18'! - leadingChar - "See Squeak if curious." - ^ 0! ! -!AffineTransformation class methodsFor: 'instance creation' stamp: 'jmv 4/8/2019 14:39:23' prior: 16778911! - transformFrom: originalBounds to: resultBounds - "Answer a Transform to translate coordinates inside originalBounds into coordinates inside resultBounds. - Parameters are instances of Rectangle. Therefore, there's no rotation involved, just scale and offset." - - ^((self withTranslation: (resultBounds topLeft + resultBounds bottomRight / 2.0)) composedWith: - (self withPointScale: (resultBounds extent / originalBounds extent) asFloatPoint)) composedWith: - (self withTranslation: (originalBounds topLeft + originalBounds bottomRight / 2.0) negated)! ! - -StrikeFont removeSelector: #maxAscii! - -StrikeFont removeSelector: #maxAscii! - -StrikeFont removeSelector: #minAscii! - -StrikeFont removeSelector: #minAscii! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3695-Tweaks-JuanVuletich-2019Apr08-14h11m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3695] on 16 April 2019 at 10:34:27 am'! -!IndentingListItemMorph methodsFor: 'initialization' stamp: 'KenD 4/14/2019 16:46:00' prior: 16854720! - initWithContents: anObject prior: priorMorph forList: hostList indentLevel: newLevel - - | o | - container _ hostList. - complexContents _ anObject. - self initWithContents: anObject asString font: Preferences standardListFont emphasis: nil. - indentLevel _ 0. - isExpanded _ false. - nextSibling _ firstChild _ nil. - priorMorph ifNotNil: [ - priorMorph nextSibling: self. - ]. - o _ anObject withoutListWrapper. - icon _ o ifNotNil: [ (o respondsTo: #icon) ifTrue: [ o icon ] ]. - indentLevel _ newLevel. -! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3696-IndentingListItemMorph-fix-KenDickey-2019Apr16-10h33m-KenD.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3696] on 17 April 2019 at 2:14:28 pm'! -!PasteUpMorph methodsFor: 'events' stamp: 'jmv 4/17/2019 14:13:14' prior: 16887164! - click: aMouseButtonEvent localPosition: localEventPosition - ^self whenUIinSafeState: [self mouseButton2Activity]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3697-WorldMenuFix-JuanVuletich-2019Apr17-14h14m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3697] on 17 April 2019 at 3:05:02 pm'! -!Parser methodsFor: 'error correction' stamp: 'jmv 4/17/2019 15:01:56' prior: 16886442! - correctSelector: proposedKeyword wordIntervals: aSpots exprInterval: expInt ifAbort: abortAction - "Correct the proposedKeyword to some selector symbol, correcting the original text if such action is indicated. abortAction is invoked if the proposedKeyword couldn't be converted into a valid selector. Spots is an ordered collection of intervals within the test stream of the for each of the keyword parts." - - | correctSelector userSelection delta spots | - "If we can't ask the user, assume that the keyword will be defined later" - self interactive ifFalse: [^proposedKeyword asSymbol]. - - "If the requestor is of an exotic kind (like a telnet server) we might not be allowed to open a PupUpMenu for querying the user" - " - ((requestor isKindOf: Editor) or: [ requestor is: #Morph ]) - ifFalse: [ ^ proposedKeyword asSymbol ]. - " - - userSelection _ requestor selectionInterval. - delta _ userSelection last - aSpots last last. - spots _ aSpots collect: [ :interval | interval first + delta to: interval last + delta ]. - requestor selectFrom: spots first first to: spots last last. - - correctSelector _ UnknownSelector name: proposedKeyword. - correctSelector ifNil: [^abortAction value]. - - requestor selectInvisiblyFrom: userSelection first to: userSelection last. - - self substituteSelector: correctSelector keywords wordIntervals: spots. - ^(proposedKeyword last ~~ $: - and: [correctSelector last == $:]) - ifTrue: [abortAction value] - ifFalse: [correctSelector]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3698-SelectorCorrectionFix-JuanVuletich-2019Apr17-15h04m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3698] on 17 April 2019 at 3:18:04 pm'! - -Object subclass: #Compiler - instanceVariableNames: 'sourceStream requestor class category context parser sourceStreamGetter ' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #Compiler category: #'Compiler-Kernel'! -Object subclass: #Compiler - instanceVariableNames: 'sourceStream requestor class category context parser sourceStreamGetter' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -Scanner subclass: #Parser - instanceVariableNames: 'here hereType hereMark hereEnd prevMark prevEnd encoder requestor parseNode failBlock requestorOffset tempsMark doitFlag properties category sourceStreamGetter ' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #Parser category: #'Compiler-Kernel'! -Scanner subclass: #Parser - instanceVariableNames: 'here hereType hereMark hereEnd prevMark prevEnd encoder requestor parseNode failBlock requestorOffset tempsMark doitFlag properties category sourceStreamGetter' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! -!Compiler methodsFor: 'private' stamp: 'jmv 4/17/2019 15:15:58' prior: 50444785! - translate: aStream noPattern: noPattern doIt: doIt ifFail: failBlock - - ^self parser - ignoreBacktick: false; - parse: aStream - class: class - category: category - noPattern: noPattern - doIt: doIt - context: context - notifying: requestor - ifFail: [^failBlock value]! ! -!Parser methodsFor: 'public access' stamp: 'jmv 4/17/2019 15:17:07' prior: 50444847! - parse: sourceStream class: class category: aCategory noPattern: noPattern doIt: doIt context: aContext notifying: aRequestor ifFail: aBlock - - "Answer a MethodNode for the argument, sourceStream, that is the root of - a parse tree. Parsing is done with respect to the argument, class, to find - instance, class, and pool variables; and with respect to the argument, - ctxt, to find temporary variables. Errors in parsing are reported to the - argument, req, if not nil; otherwise aBlock is evaluated. The argument - noPattern is a Boolean that is true if the the sourceStream does not - contain a method header (i.e., for DoIts)." - - | methNode repeatNeeded myStream sourceCode startPosition | - - category _ aCategory. - myStream _ sourceStream. - [ - repeatNeeded _ false. - startPosition _ myStream position. - sourceCode _ myStream upToEnd. - myStream position: startPosition. - self encoder init: class context: aContext notifying: self. - self init: myStream notifying: aRequestor failBlock: [^ aBlock value ]. - doitFlag _ noPattern. - failBlock _ aBlock. - [ methNode _ self method: noPattern doIt: doIt context: aContext ] - on: ReparseAfterSourceEditing - do: [ :ex | - repeatNeeded _ true. - myStream _ ReadStream on: requestor text string ]. - repeatNeeded - ] whileTrue: [ encoder _ self encoder class new ]. - - methNode sourceText: sourceCode. - "See #xBacktick" - sentInLiterals do: [ :sym | encoder noteOptimizedSelector: sym ]. - - ^ methNode! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'jmv 4/17/2019 15:15:33' prior: 50444960! - compileSelectionFor: anObject in: evalContext ifFail: failBlock - - | methodNode method sourceCode compiler | - - sourceCode := self selectionDoItSourceCodeIn: evalContext. - - methodNode _ [ - compiler _ Compiler new. - compiler - compileDoIt: sourceCode - in: anObject class - context: evalContext - notifying: self - ifFail: [ ^ failBlock value ]] - on: OutOfScopeNotification - do: [ :ex | ex resume: true ]. - - methodNode block returnLast. - method _ methodNode generate. - method methodNode: methodNode. - - ^{ #method -> method. #compiler -> compiler } asDictionary -! ! - -Parser removeSelector: #sourceStreamGetter:! - -Parser removeSelector: #sourceStreamGetter:! - -Compiler removeSelector: #sourceStreamGetter:! - -Compiler removeSelector: #sourceStreamGetter:! - -Object subclass: #Compiler - instanceVariableNames: 'sourceStream requestor class category context parser' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #Compiler category: #'Compiler-Kernel'! -Object subclass: #Compiler - instanceVariableNames: 'sourceStream requestor class category context parser' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -Scanner subclass: #Parser - instanceVariableNames: 'here hereType hereMark hereEnd prevMark prevEnd encoder requestor parseNode failBlock requestorOffset tempsMark doitFlag properties category' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #Parser category: #'Compiler-Kernel'! -Scanner subclass: #Parser - instanceVariableNames: 'here hereType hereMark hereEnd prevMark prevEnd encoder requestor parseNode failBlock requestorOffset tempsMark doitFlag properties category' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3699-CompilerCleanup-JuanVuletich-2019Apr17-15h15m-jmv.1.cs.st----! - -----SNAPSHOT----(23 April 2019 09:06:11) Cuis5.0-3699-v3.image priorSource: 3680362! - -----QUIT----(23 April 2019 09:06:33) Cuis5.0-3699-v3.image priorSource: 3855526! - -----STARTUP---- (29 April 2019 09:02:11) as /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/Cuis5.0-3699-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3699] on 23 April 2019 at 10:14:09 am'! -!Parser methodsFor: 'error correction' stamp: 'jmv 4/23/2019 10:13:10' prior: 16886486! - correctVariable: proposedVariable interval: aSpot - "Correct the proposedVariable to a known variable, or declare it as a new - variable if such action is requested. We support declaring lowercase - variables as temps or inst-vars, and uppercase variables as Globals or - ClassVars, depending on whether the context is nil (class=UndefinedObject). - Spot is the interval within the test stream of the variable. - rr 3/4/2004 10:26 : adds the option to define a new class. " - - "Check if this is an i-var, that has been corrected already (ugly)" - - "Display the pop-up menu" - - | userSelection action delta spot | - (encoder classEncoding instVarNames includes: proposedVariable) ifTrue: [ - ^InstanceVariableNode new - name: proposedVariable - index: (encoder classEncoding allInstVarNames indexOf: proposedVariable)]. - - "First check to see if the requestor knows anything about the variable" - (requestor bindingOf: proposedVariable) - ifNotNil: [ :binding | ^ encoder global: binding name: proposedVariable]. - - "If we can't ask the user for correction, make it undeclared" - self interactive ifFalse: [^encoder undeclared: proposedVariable]. - - userSelection _ requestor selectionInterval. - delta _ userSelection last - aSpot last. - spot _ aSpot first + delta to: aSpot last + delta. - requestor selectFrom: spot first to: spot last. - - "Build the menu with alternatives" - action _ UndeclaredVariable - signalFor: self - name: proposedVariable - inRange: spot. - action ifNil: [^self fail]. - - "Execute the selected action" - requestor selectInvisiblyFrom: userSelection first to: userSelection last. - ^action value! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3700-VariableCorrectionFix-JuanVuletich-2019Apr23-10h05m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3688] on 17 April 2019 at 9:09:08 pm'! - -Object subclass: #ClassDefinitionNodeAnalyzer - instanceVariableNames: 'classDefinitionNode classCreationMessageNode superClassNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Support'! - -!classDefinition: #ClassDefinitionNodeAnalyzer category: #'Compiler-Support'! -Object subclass: #ClassDefinitionNodeAnalyzer - instanceVariableNames: 'classDefinitionNode classCreationMessageNode superClassNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Support'! -!ClassDefinitionNodeAnalyzer methodsFor: 'initialization' stamp: 'HAW 4/17/2019 18:19:19'! - initializeFor: aClassDefinitionMethodNode - - classDefinitionNode := aClassDefinitionMethodNode. - classCreationMessageNode := classDefinitionNode block statements first expr. - superClassNode := classCreationMessageNode receiver. -! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'testing' stamp: 'HAW 4/17/2019 20:47:37'! - isAtCategory: anIndex - - ^self is: anIndex atStringParameterNumber: self class categoryPosition - ! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'testing' stamp: 'HAW 4/17/2019 18:36:15'! - isAtClassName: anIndex - - ^(classDefinitionNode sourceRangeFor: classCreationMessageNode arguments first) first includes: anIndex! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'testing' stamp: 'HAW 4/17/2019 20:46:45'! - isAtInstanceVariables: anIndex - - ^self is: anIndex atStringParameterNumber: self class instanceVariableNamesPosition! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'testing' stamp: 'HAW 4/17/2019 18:34:11'! - isAtSuperclass: anIndex - - ^(classDefinitionNode sourceRangeFor: superClassNode) first includes: anIndex! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'accessing' stamp: 'HAW 4/17/2019 18:41:46'! - superclass - - ^superClassNode key value ! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'testing - private' stamp: 'HAW 4/17/2019 20:37:06'! - is: anIndex atStringParameterNumber: aParameterPosition - - | parameterRange | - - parameterRange := (classDefinitionNode sourceRangeFor: (classCreationMessageNode arguments at: aParameterPosition)) first. - - ^anIndex between: parameterRange first + 1 and: parameterRange last - 1! ! -!ClassDefinitionNodeAnalyzer class methodsFor: 'parameters positions' stamp: 'HAW 4/17/2019 20:47:27'! -categoryPosition - - ^5! ! -!ClassDefinitionNodeAnalyzer class methodsFor: 'parameters positions' stamp: 'HAW 4/17/2019 20:47:15'! - instanceVariableNamesPosition - - ^2! ! -!ClassDefinitionNodeAnalyzer class methodsFor: 'instance creation' stamp: 'HAW 4/17/2019 18:18:03'! - for: aClassDefinitionMethodNode - - ^self new initializeFor: aClassDefinitionMethodNode ! ! -!Editor methodsFor: 'new selection' stamp: 'HAW 4/15/2019 16:01:45'! - wordLeftDelimiters - - ^''! ! -!Editor methodsFor: 'new selection' stamp: 'HAW 4/15/2019 15:57:53'! - wordRangeLeftDelimiters: leftDelimiters rightDelimiters: rightDelimiters - "Select delimited text or word--the result of double-clicking." - - | initialDelimiter finalDelimiter direction match level string here hereChar start stop | - string _ self privateCurrentString. - string size < 2 ifTrue: [^1 to: 1]. - here _ self pointIndex min: string size max: 2. - initialDelimiter _ string at: here - 1. - match _ leftDelimiters indexOf: initialDelimiter. - match > 0 - ifTrue: [ - "delimiter is on left -- match to the right" - start _ here. - direction _ 1. - here _ here - 1. - finalDelimiter _ rightDelimiters at: match] - ifFalse: [ - initialDelimiter _ string at: here. - match _ rightDelimiters indexOf: initialDelimiter. - match > 0 - ifTrue: [ - "delimiter is on right -- match to the left" - stop _ here - 1. - direction _ -1. - finalDelimiter _ leftDelimiters at: match] - ifFalse: [ - "no delimiters -- select a token" - direction _ -1]]. - level _ 1. - [level > 0 and: [direction > 0 - ifTrue: [here < string size] - ifFalse: [here > 1]]] - whileTrue: [ - hereChar _ string at: (here _ here + direction). - match = 0 - ifTrue: [ - "token scan goes left, then right" - hereChar isValidInIdentifiers "Consider $: as a word separator" - ifTrue: [ - here = 1 - ifTrue: [ - start _ 1. - "go right if hit string start" - direction _ 1]] - ifFalse: [ - direction < 0 - ifTrue: [ - start _ here + 1. - "go right if hit non-token" - direction _ 1] - ifFalse: [level _ 0]]] - ifFalse: [ - "delimiter match just counts nesting level" - hereChar = finalDelimiter - ifTrue: [level _ level - 1"leaving nest"] - ifFalse: [ - hereChar = initialDelimiter - ifTrue: [level _ level + 1"entering deeper nest"]]]]. - level > 0 ifTrue: [ - leftDelimiters size + rightDelimiters size = 0 ifFalse: [ - "If we failed to find final delimiter, then just select word." - ^self wordRangeLeftDelimiters: '' rightDelimiters: '' ]. - here _ here + direction ]. - ^ direction > 0 - ifTrue: [ - "If a word ends with $: (a keyword), consider it part of the word" - hereChar = $: ifTrue: [here _ here + 1]. - start to: here - 1] - ifFalse: [ - "But if a word starts with $: (this is the argument to a keyword), then it is not part of the word." - here + 1 to: stop]! ! -!Editor methodsFor: 'new selection' stamp: 'HAW 4/15/2019 16:01:58'! - wordRightDelimiters - - ^''! ! -!Editor methodsFor: 'new selection' stamp: 'HAW 4/17/2019 18:01:07'! - wordUnderCursorRange - - ^self wordRangeLeftDelimiters: self wordLeftDelimiters rightDelimiters: self wordRightDelimiters ! ! -!TextEditor methodsFor: 'model access' stamp: 'HAW 4/17/2019 19:26:58'! - wordUnderCursor - - | wordUnderCursorRange word indexOfSpace | - - wordUnderCursorRange := self wordUnderCursorRange. - word := (model actualContents copyFrom: wordUnderCursorRange first to: wordUnderCursorRange last) asString. - - "I have to handle the edge case where the cursor is for example between a ' and the first letter of the word. - In that case the range will include words with spaces - Hernan" - indexOfSpace := word indexOf: $ ifAbsent: [ ^word ]. - - ^word first: indexOfSpace -1 - - ! ! -!SmalltalkEditor methodsFor: 'new selection' stamp: 'HAW 4/15/2019 16:01:45'! - wordLeftDelimiters - - ^ '([{<|''"`'! ! -!SmalltalkEditor methodsFor: 'new selection' stamp: 'HAW 4/15/2019 16:01:58'! - wordRightDelimiters - - ^ ')]}>|''"`'! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 4/17/2019 20:09:44'! - contextualRenameInClassDefinition - - self ifRenameCanBeAppliedDo: [ - self - withClassDefinitionNodeAndClassDo: [ :classDefinitionNode :selectedClass | self contextualRenameInClassDefinitionOf: classDefinitionNode in: selectedClass] - ifErrorsParsing: [ :anError | morph flash ] ]! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 4/17/2019 21:06:49'! - contextualRenameInClassDefinitionOf: aClassDefinitionNode in: aSelectedClass - - | analyzer cursorPosition | - - analyzer := ClassDefinitionNodeAnalyzer for: aClassDefinitionNode. - cursorPosition := self startIndex. - - (analyzer isAtSuperclass: cursorPosition) - ifTrue: [ ^self renameClassOn: self codeProvider for: analyzer superclass ]. - - (analyzer isAtClassName: cursorPosition) - ifTrue: [ ^self renameClassOn: self codeProvider for: aSelectedClass ]. - - (analyzer isAtInstanceVariables: cursorPosition) - ifTrue: [ ^self renameInstanceVariableOn: self codeProvider for: self wordUnderCursor at: aSelectedClass ]. - - (analyzer isAtCategory: cursorPosition) - ifTrue: [ - "I'm sure codeProvider is a Browser - Hernan" - ^self codeProvider renameSystemCategory ]. - - morph flash - -! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 4/15/2019 14:48:21'! - contextualRenameInMethod - - self - withMethodNodeAndClassDo: [ :methodNode :selectedClass | self contextualRenameOf: methodNode in: selectedClass] - ifErrorsParsing: [ :anError | morph flash ] ! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 4/15/2019 14:54:34'! - withClassDefinitionNodeAndClassDo: aBlock ifErrorsParsing: anErrorBlock - - | selectedClass methodNode | - - selectedClass := self codeProvider selectedClassOrMetaClass. - methodNode := [ selectedClass methodNodeFor: model actualContents noPattern: true ] on: Error do: [ :anError | ^ anErrorBlock value: anError ]. - - ^aBlock value: methodNode value: selectedClass.! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 4/17/2019 20:13:57'! - sourceRangeFor: aParseNode - - ^encoder sourceRangeFor: aParseNode ! ! -!Editor methodsFor: 'new selection' stamp: 'HAW 4/15/2019 16:01:58' prior: 16836452! - selectWord - "Select delimited text or word--the result of double-clicking." - - ^self selectWordLeftDelimiters: self wordLeftDelimiters rightDelimiters: self wordRightDelimiters ! ! -!Editor methodsFor: 'new selection' stamp: 'HAW 4/15/2019 15:48:33' prior: 50421155! - selectWordLeftDelimiters: leftDelimiters rightDelimiters: rightDelimiters - "Select delimited text or word--the result of double-clicking." - - | wordRange | - - wordRange := self wordRangeLeftDelimiters: leftDelimiters rightDelimiters: rightDelimiters. - - self selectFrom: wordRange first to: wordRange last! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 4/15/2019 14:48:08' prior: 50450178! - contextualRename - - self isEditingClassDefinition - ifTrue: [ self contextualRenameInClassDefinition ] - ifFalse: [ self contextualRenameInMethod ]! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 4/17/2019 20:11:29'! - isEditingClassDefinition - - "This is ugly, but I don't find a better way to do it without making a big change in the code provider hierarchy - Hernan" - ^(self codeProvider respondsTo: #editSelection) and: [ self codeProvider editSelection == #editClass]! ! - -SmalltalkEditor removeSelector: #selectWord! - -SmalltalkEditor removeSelector: #selectWord! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3701-ContextualRenameInClassDefinition-HernanWilkinson-2019Mar27-11h04m-HAW.5.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3688] on 17 April 2019 at 9:21:57 pm'! -!Dictionary class methodsFor: 'error descriptions' stamp: 'HAW 4/4/2019 08:14:52'! - keyNotFoundErrorDescription - - ^'key not found'! ! -!Dictionary methodsFor: 'private' stamp: 'HAW 4/4/2019 08:15:21' prior: 16833741! - errorKeyNotFound - - self error: self class keyNotFoundErrorDescription ! ! -!Trie methodsFor: 'private' stamp: 'HAW 4/4/2019 08:15:38' prior: 16939280! - errorKeyNotFound - - self error: Dictionary keyNotFoundErrorDescription ! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3702-KeyNotFound-HernanWilkinson-2019Mar27-11h04m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3688] on 18 April 2019 at 6:07:20 pm'! -!AbstractFont methodsFor: 'as yet unclassified' stamp: 'HAW 4/2/2019 22:15:03'! - ascent - - self subclassResponsibility ! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3703-AbstractFontAscent-HernanWilkinson-2019Mar27-11h04m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3688] on 18 April 2019 at 6:36:44 pm'! -!MessageSetWindow class methodsFor: 'opening' stamp: 'HAW 3/29/2019 11:36:08'! - open: model label: aString - - | window | - - window := super open: model label: aString. - model messageListIndex: 1. - - ^window! ! -!MessageSet methodsFor: 'private' stamp: 'HAW 3/29/2019 11:32:39' prior: 50368656! - initializeMessageList: anArray - - messageList _ anArray. - messageList isEmpty - ifTrue: [ selectedMessage _ nil ] - ifFalse: [ self messageListIndex: 1 ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3704-SelectionWhenOpening-HernanWilkinson-2019Mar27-11h04m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3688] on 18 April 2019 at 8:56:36 pm'! - -PluggableScrollPane subclass: #TextModelMorph - instanceVariableNames: 'shouldAttendActualScopeSenderChanged ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #TextModelMorph category: #'Morphic-Views'! -PluggableScrollPane subclass: #TextModelMorph - instanceVariableNames: 'shouldAttendActualScopeSenderChanged' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! -!MessageSet methodsFor: 'source code ranges' stamp: 'HAW 4/18/2019 20:42:29'! - messageSendsRangesOf: aSelector - - ^ selectedMessage - ifNil: [ #() ] - ifNotNil: [selectedMessage messageSendsRangesOf: aSelector ]! ! -!CompiledMethod methodsFor: 'source code ranges' stamp: 'HAW 4/18/2019 20:41:51'! - messageSendsRangesOf: aSentSelector - - | methodNode ranges | - - methodNode := self methodNode. - ranges := OrderedCollection new. - - methodNode nodesDo: [ :aParseNode | - (aParseNode isMessageNamed: aSentSelector) ifTrue: [ ranges add: (methodNode sourceRangeFor: aParseNode) ]]. - - ^ranges ! ! -!TextModelMorph methodsFor: 'updating' stamp: 'HAW 4/18/2019 20:51:03'! - selectMessage - - | messageSendsRanges | - - messageSendsRanges := model textProvider messageSendsRangesOf: model autoSelectString. - self editor messageSendsRanges: messageSendsRanges. -! ! -!TextModelMorph methodsFor: 'updating' stamp: 'HAW 4/18/2019 20:51:08'! - selectString - - self editor - setSearch: model autoSelectString; - findAndReplaceMany: true ! ! -!TextModelMorph methodsFor: 'updating' stamp: 'HAW 4/18/2019 20:34:31'! - updateAcceptedContents - - self textMorph hasUnacceptedEdits ifTrue: [ - self textMorph hasEditingConflicts: true. - ^self redrawNeeded ]. - model refetch. - "#actualContents also signalled in #refetch. No need to repeat what's done there." - ^self ! ! -!TextModelMorph methodsFor: 'updating' stamp: 'HAW 4/18/2019 20:33:38'! -updateActualContents - - "Some day, it would be nice to keep objects and update them - instead of throwing them away all the time for no good reason..." - self textMorph - releaseEditorAndTextComposition; - installEditorAndTextComposition; - formatAndStyleIfNeeded. - self setScrollDeltas. - self redrawNeeded. - ^self ! ! -!TextModelMorph methodsFor: 'updating' stamp: 'HAW 4/18/2019 20:53:31'! - updateAutoSelect - - TextEditor abandonChangeText. "no replacement!!" - (model autoSelectString isKindOf: Symbol) - ifTrue: [ self selectMessage ] - ifFalse: [ self selectString]. - - self textMorph updateFromTextComposition. - ^self scrollSelectionIntoView! ! -!TextModelMorph methodsFor: 'updating' stamp: 'HAW 4/18/2019 20:37:48'! - updateClearUserEdits - - "Quite ugly" - ^self hasUnacceptedEdits: false -! ! -!TextModelMorph methodsFor: 'updating' stamp: 'HAW 4/18/2019 20:36:13'! - updateInitialSelection - - ^self - setSelection: model getSelection; - redrawNeeded! ! -!TextModelMorph methodsFor: 'updating' stamp: 'HAW 4/18/2019 20:35:31'! - updateRefetched - - "#actualContents also signalled when #refetched is signalled. - No need to repeat what's done there." - self setSelection: model getSelection. - self hasUnacceptedEdits: false. - - ^self ! ! -!TextModelMorph methodsFor: 'updating' stamp: 'HAW 4/18/2019 20:38:23'! - updateShoutStyled - - self textMorph stylerStyled. - ^self redrawNeeded ! ! -!MethodReference methodsFor: 'source code ranges' stamp: 'HAW 4/18/2019 20:17:52'! - messageSendsRangesOf: aSentSelector - - | compiledMethod | - - compiledMethod := self compiledMethodIfAbsent: [ ^#() ]. - ^compiledMethod messageSendsRangesOf: aSentSelector ! ! -!CompiledMethod methodsFor: 'decompiling' stamp: 'HAW 4/18/2019 20:40:33' prior: 50444918! - methodNode: aMethodNode - - self propertyValueAt: #methodNode put: aMethodNode! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'HAW 4/18/2019 20:10:24' prior: 16923849! - browseAllCallsOn: aLiteral - "Create and schedule a message browser on each method that refers to - aLiteral. For example, Smalltalk browseAllCallsOn: #open:label:." - (aLiteral isKindOf: LookupKey) - ifTrue: [ - self - browseMessageList: (self allCallsOn: aLiteral) asArray sort - name: 'Users of ' , aLiteral key - autoSelect: aLiteral key ] - ifFalse: [ - self - browseMessageList: (self allCallsOn: aLiteral) asArray sort - name: 'Senders of ' , aLiteral - autoSelect: aLiteral ].! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'HAW 4/18/2019 20:29:53' prior: 16923881! - browseAllCallsOn: aLiteral localTo: aClass - "Create and schedule a message browser on each method in or below the given class that refers to - aLiteral. For example, Smalltalk browseAllCallsOn: #open:label:." - aClass ifNil: [ ^ self inform: 'no selected class' ]. - (aLiteral isKindOf: LookupKey) - ifTrue: [ - self - browseMessageList: (aClass allLocalCallsOn: aLiteral) asArray sort - name: 'Users of ' , aLiteral key , ' local to ' , aClass name - autoSelect: aLiteral key ] - ifFalse: [ - self - browseMessageList: (aClass allLocalCallsOn: aLiteral) asArray sort - name: 'Senders of ' , aLiteral , ' local to ' , aClass name - autoSelect: aLiteral ].! ! -!TextEditor methodsFor: 'new selection' stamp: 'HAW 4/18/2019 20:56:26'! - messageSendsRanges: aRanges - - selectionStartBlocks := OrderedCollection new. - selectionStopBlocks := OrderedCollection new. - - aRanges do: [ :range | - selectionStartBlocks add: (textComposition characterBlockForIndex: range first). - selectionStopBlocks add: (textComposition characterBlockForIndex: range last + 1) ]! ! -!TextModelMorph methodsFor: 'updating' stamp: 'HAW 4/18/2019 20:39:08' prior: 16934212! - update: aSymbol - - super update: aSymbol. - aSymbol ifNil: [^self]. - - aSymbol == #flash ifTrue: [^self flash]. - aSymbol == #actualContents ifTrue: [ ^self updateActualContents ]. - aSymbol == #acceptedContents ifTrue: [ ^self updateAcceptedContents ]. - aSymbol == #refetched ifTrue: [ ^self updateRefetched ]. - aSymbol == #initialSelection ifTrue: [ ^self updateInitialSelection ]. - aSymbol == #autoSelect ifTrue: [ ^self updateAutoSelect ]. - aSymbol == #clearUserEdits ifTrue: [ ^self updateClearUserEdits ]. - aSymbol == #shoutStyled ifTrue: [ ^self updateShoutStyled ]. -! ! -!MessageSetWindow methodsFor: 'GUI building' stamp: 'jmv 1/1/2015 21:05' prior: 16870413! - buildLowerPanes - | codeAndButtons codeButtonsAndAnnotations | - codeAndButtons _ LayoutMorph newColumn. - Preferences optionalButtons ifTrue: [ - codeAndButtons - addMorph: self optionalButtonRow fixedHeight: self defaultButtonPaneHeight; - addAdjusterMorph ]. - codeAndButtons - addMorph: self buildMorphicCodePane proportionalHeight: 1.0. - Preferences optionalButtons ifFalse: [ - ^codeAndButtons ]. - codeButtonsAndAnnotations _ LayoutMorph newColumn. - codeButtonsAndAnnotations - addMorph: self buildMorphicAnnotationsPane fixedHeight: self defaultAnnotationPaneHeight; - addAdjusterMorph; - addMorph: codeAndButtons proportionalHeight: 1.0. - ^codeButtonsAndAnnotations! ! -!MethodReference methodsFor: 'queries' stamp: 'HAW 4/18/2019 20:17:23'! - compiledMethodIfAbsent: ifAbsentBlock - - ^ self actualClass compiledMethodAt: methodSymbol ifAbsent: ifAbsentBlock ! ! -!RefactoringApplier methodsFor: 'exception handling' stamp: 'HAW 4/15/2019 15:41:14' prior: 50441354! - browseReferencesOn: aCanNotRefactorDueToReferencesError - - Smalltalk - browseMessageList: aCanNotRefactorDueToReferencesError references - name: (self referencesBrowserTitleOn: aCanNotRefactorDueToReferencesError) - autoSelect: aCanNotRefactorDueToReferencesError referencee name asString -! ! - -PluggableScrollPane subclass: #TextModelMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #TextModelMorph category: #'Morphic-Views'! -PluggableScrollPane subclass: #TextModelMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3705-MessageSendSelection-HernanWilkinson-2019Mar27-11h04m-HAW.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3688] on 18 April 2019 at 5:55:07 pm'! -!MessageNode methodsFor: 'testing' stamp: 'HAW 4/18/2019 17:52:07'! - isCascade - - ^receiver isNil ! ! -!MethodNode methodsFor: 'testing' stamp: 'HAW 3/29/2019 23:50:04'! - isMultipleRanges: aRangeOrRanges - - ^aRangeOrRanges isKindOf: OrderedCollection ! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'HAW 3/29/2019 23:42:52'! - inspectSelectionOrLine - - self - evaluateSelectionAndDo: [ :result | result inspect ] - ifFail: [ morph flash ] - profiled: false! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'HAW 3/29/2019 23:58:09'! - selectForInspection: aNodeUnderCursor in: aMethodNode - - (aNodeUnderCursor isLiteralNode or: [ aNodeUnderCursor isVariableNode ]) ifTrue: [ ^self selectNodeRange: aNodeUnderCursor in: aMethodNode ]. - aNodeUnderCursor isMessageNode ifTrue: [ ^self selectMessageNode: aNodeUnderCursor in: aMethodNode ].! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'HAW 3/30/2019 00:29:14'! - selectMessageNode: aMessageNodeUnderCursor in: aMethodNode - - | messageRange | - - self - withReceiverRangeOf: aMessageNodeUnderCursor - in: aMethodNode - selectorPosition: self startIndex - do: [ :receiverRange | - messageRange := aMethodNode sourceRangeFor: aMessageNodeUnderCursor. - self selectFrom: receiverRange first to: messageRange last ] - - ! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'HAW 3/29/2019 23:57:59'! - selectNodeRange: aNodeUnderCursor in: aMethodNode - - | range ranges | - - ranges := aMethodNode sourceRangeFor: aNodeUnderCursor. - range := (aMethodNode isMultipleRanges: ranges) - ifTrue: [ ranges detect: [ :aRange | aRange includes: self startIndex ] ifNone: [ ^self ]] - ifFalse: [ ranges ]. - - self selectFrom: range first to: range last -! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'HAW 3/29/2019 23:57:08'! - selectNodeUnderCursorForInspectionIn: aMethodNode - - aMethodNode - withParseNodeIncluding: self startIndex - do: [ :nodeUnderCursor | self selectForInspection: nodeUnderCursor in: aMethodNode ] - ifAbsent: [] - - -! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'HAW 4/18/2019 17:54:45'! - withReceiverRangeOf: aMessageNode in: aMethodNode selectorPosition: aSelectorPosition do: aBlock - - | receiverRange receiverRangeOrRanges messageNodeReceiver | - - "If aMessageNode receiver isNil it means that it is a cascade receiver so this imposes the question on how to inspect - a cascade message send. We could inspect the result of sending all the messages up to the cursor but the problem is - that when looking for the cascade receiver range it does not find it because it is a different node that the used in the source - ranges... we could do the trick of looking for printString in the sourceRanges keys, but that is too much - Hernan" - aMessageNode isCascade ifFalse: [ - messageNodeReceiver := aMessageNode receiver. - messageNodeReceiver isMessageNode ifTrue: [ - ^self withReceiverRangeOf: messageNodeReceiver in: aMethodNode selectorPosition: (messageNodeReceiver keywordPositionAt: 1) first do: aBlock ]. - - receiverRangeOrRanges := aMethodNode sourceRangeFor: messageNodeReceiver. - - receiverRange := (aMethodNode isMultipleRanges: receiverRangeOrRanges) - ifTrue: [ | closestRange | - closestRange := receiverRangeOrRanges first. - receiverRangeOrRanges do: [ :aRange | (aRange last < aSelectorPosition and: [ aRange last > closestRange last ]) ifTrue: [ closestRange := aRange ]]. - closestRange ] - ifFalse: [ receiverRangeOrRanges ]. - - aBlock value: receiverRange ]! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'HAW 3/30/2019 00:45:22' prior: 16909732! - inspectIt - - self hasSelection ifFalse: [ - self - withMethodNodeAndClassDo: [ :methodNode :selectedClass | self selectNodeUnderCursorForInspectionIn: methodNode ] - ifErrorsParsing: [ :anError | ]]. - - self inspectSelectionOrLine - - ! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 4/18/2019 17:34:21' prior: 50450214! - withMethodNodeAndClassDo: aBlock ifErrorsParsing: anErrorBlock - - | selectedClass methodNode | - - "I have to do this because some codeProviders do no answer selectedClassOrMetaClass like the Workspace - Hernan" - selectedClass := [ self codeProvider selectedClassOrMetaClass ] on: Error do: [ :anError | anError return: UndefinedObject ]. - [ methodNode := selectedClass methodNodeFor: model actualContents ] on: Error do: [ :anError | ^ anErrorBlock value: anError ]. - - aBlock value: methodNode value: selectedClass.! ! -!DebuggerMethodMap methodsFor: 'source mapping' stamp: 'HAW 3/29/2019 23:50:31' prior: 50445273! - abstractSourceMap - "Answer with a Dictionary of abstractPC to sourceRange ." - - | theMethodToScan rawSourceRanges concreteSourceRanges abstractPC scanner client | - - abstractSourceRanges ifNotNil: [ ^abstractSourceRanges]. - - methodNode encoder hasGeneratedMethod - ifTrue: [ - rawSourceRanges := methodNode encoder rawSourceRanges. - theMethodToScan := self method ] - ifFalse: [ - "If the methodNode hasn't had a method generated it doesn't have pcs set in its - nodes so we must generate a new method and might as well use it for scanning." - [methodNode rawSourceRangesAndMethodDo: [ :ranges :method | - rawSourceRanges := ranges. - theMethodToScan := method ]] - on: UndeclaredVariableWarning - do: [ :ex | ex resume ]]. - - concreteSourceRanges := Dictionary new. - rawSourceRanges keysAndValuesDo: [ :node :range | - node pc ~= 0 ifTrue: [ | realRange | - realRange := (methodNode isMultipleRanges: range) ifTrue: [ range last ] ifFalse: [ range ]. - concreteSourceRanges at: node pc put: realRange ]]. - - abstractPC := 1. - abstractSourceRanges := Dictionary new. - scanner := InstructionStream on: theMethodToScan. - client := InstructionClient new. - [ - (concreteSourceRanges includesKey: scanner pc) ifTrue: [ - abstractSourceRanges at: abstractPC put: (concreteSourceRanges at: scanner pc)]. - abstractPC := abstractPC + 1. - scanner interpretNextInstructionFor: client. - scanner atEnd ] whileFalse. - - ^abstractSourceRanges! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3706-InspectUnderCursor-HernanWilkinson-2019Mar27-11h04m-HAW.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3696] on 19 April 2019 at 3:03:00 pm'! - -Transcript class - instanceVariableNames: 'entries firstIndex lastIndex accessSemaphore unfinishedEntry logToFile showOnDisplay lastDisplayPosition bounds logToStdout '! - -!classDefinition: 'Transcript class' category: #'System-Support'! -Transcript class - instanceVariableNames: 'entries firstIndex lastIndex accessSemaphore unfinishedEntry logToFile showOnDisplay lastDisplayPosition bounds logToStdout'! -!Transcript class methodsFor: 'preferred protocol' stamp: 'GC 4/19/2019 14:55:44'! - clearStdout - - logToStdout ifTrue: [ - 15 timesRepeat: [ self stdout newLine ] - ]! ! -!Transcript class methodsFor: 'preferred protocol' stamp: 'GC 4/19/2019 14:56:52'! - logToStdout: aBoolean - - logToStdout _ aBoolean ! ! -!Transcript class methodsFor: 'preferred protocol' stamp: 'GC 4/19/2019 14:56:49'! - logsToStdout - - ^ logToStdout! ! -!Transcript class methodsFor: 'private' stamp: 'GC 4/19/2019 14:37:08'! - addEntry: aString logToFileAndStdout: fileEntryToLog - "Add a new entrie to the entries circular list. If full, a new entry will replace the oldest one." - - accessSemaphore critical: [ - - "Internal circular collection" - lastIndex _ lastIndex \\ self maxEntries + 1. - firstIndex = lastIndex ifTrue: [ firstIndex _ firstIndex \\ self maxEntries + 1 ]. - entries at: lastIndex put: aString. - - fileEntryToLog ifNotNil: [ - self writeToFile: fileEntryToLog. - self writeToStdout: fileEntryToLog - ] - ]! ! -!Transcript class methodsFor: 'private' stamp: 'GC 4/19/2019 14:16:07'! - stdout - - ^ StdIOWriteStream stdout! ! -!Transcript class methodsFor: 'private' stamp: 'GC 4/19/2019 14:37:53'! - writeToFile: anEntry - - self filename asFileEntry appendStreamDo: [ :stream | stream nextPutAll: anEntry ]! ! -!Transcript class methodsFor: 'private' stamp: 'GC 4/19/2019 14:37:47'! - writeToStdout: anEntry - - logToStdout ifTrue: [ self stdout nextPutAll: anEntry ]! ! -!TranscriptMorph methodsFor: 'menu commands' stamp: 'GC 4/19/2019 14:40:27'! - clearStdout - - Transcript clearStdout! ! -!TranscriptMorph methodsFor: 'menu commands' stamp: 'GC 4/19/2019 15:02:25'! - dontLogToStdout - - Transcript logToStdout: false! ! -!TranscriptMorph methodsFor: 'menu commands' stamp: 'GC 4/19/2019 15:02:22'! -logToStdout - - Transcript logToStdout: true! ! -!Transcript class methodsFor: 'preferred protocol' stamp: 'GC 4/19/2019 14:41:02' prior: 16938285! - clearAll - - self clearInternal. - logToFile ifTrue: [ self clearFile ]. - self clearStdout! ! -!Transcript class methodsFor: 'private' stamp: 'GC 4/19/2019 14:34:58' prior: 16938403! - addEntry: aString - "Add a new entrie to the entries circular list. If full, a new entry will replace the oldest one." - | msg now entryToLog | - entryToLog _ [ - now _ DateAndTime now. - msg _ String streamContents: [ :strm | - now printWithMsOn: strm. - strm - nextPutAll: ' process:'; - nextPutAll: Processor activeProcess priority printString; - nextPut: $ ; - nextPutAll: Processor activeProcess hash printString; - nextPut: $ ; - nextPutAll: aString; - newLine ]]. - - logToFile or: [ logToStdout ] :: ifTrue: entryToLog value. - - self addEntry: (aString copyReplaceAll: String newLineString with: ' ') logToFileAndStdout: msg! ! -!Transcript class methodsFor: 'class initialization' stamp: 'GC 4/19/2019 14:01:37' prior: 16938542! - initialize - " - self initialize - " - showOnDisplay _ true. - bounds _ 20@20 extent: 300@500. - logToFile _ false. - logToStdout _ false. - entries _ Array new: self maxEntries. - unfinishedEntry _ String new writeStream. - lastDisplayPosition _ 0. - accessSemaphore _ Semaphore forMutualExclusion. - self clear! ! -!TranscriptMorph methodsFor: 'menus' stamp: 'GC 4/19/2019 14:40:07' prior: 50399651! - getMenu - "Set up the menu to apply to the receiver" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - doImmediateUpdates - ifTrue: [ aMenu add: 'Only update in the regular Morphic cycle' action: #doRegularUpdates ] - ifFalse: [ aMenu add: 'Immediately show each entry' action: #doImmediateUpdates ]. - aMenu - addLine; - add: 'Workspace with Contents' action: #editContents; - addLine; - add: 'Clear Transcript' action: #clearInternal; - add: 'Clear Transcript File' action: #clearFile; - add: 'Clear Transcript Stdout' action: #clearStdout; - add: 'Clear Both' action: #clearAll; - addLine. - Transcript logsToFile - ifTrue: [ aMenu add: 'Stop logging to File' action: #dontLogToFile ] - ifFalse: [ aMenu add: 'Start logging to File' action: #logToFile ]. - aMenu addLine. - Transcript logsToStdout - ifTrue: [ aMenu add: 'Stop logging to Stdout' action: #dontLogToStdout ] - ifFalse: [ aMenu add: 'Start logging to Stdout' action: #logToStdout ]. - - ^ aMenu! ! - -Transcript initialize! - -Transcript class - instanceVariableNames: 'entries firstIndex lastIndex accessSemaphore unfinishedEntry logToFile showOnDisplay lastDisplayPosition bounds logToStdout '! - -!classDefinition: 'Transcript class' category: #'System-Support'! -Transcript class - instanceVariableNames: 'entries firstIndex lastIndex accessSemaphore unfinishedEntry logToFile showOnDisplay lastDisplayPosition bounds logToStdout'! - -"Postscript: -To initialize Transcript logToStdout class variable" -Transcript initialize. -Display restore! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3707-TranscriptCanLogToStdout-GC.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3707] on 24 April 2019 at 4:30:53 pm'! -!Transcript class methodsFor: 'private' stamp: 'jmv 4/24/2019 16:30:16' prior: 50453101! - writeToFile: anEntry - - logToFile ifTrue: [ - self filename asFileEntry appendStreamDo: [ :stream | stream nextPutAll: anEntry ]]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3708-OnlyLogTranscriptToFileIfRequested-JuanVuletich-2019Apr24-16h30m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3708] on 25 April 2019 at 8:41:55 am'! -!StrikeFont methodsFor: 'accessing' stamp: 'jmv 4/24/2019 20:27:07'! - lineSpacing - "Answer the height of the receiver including any additional line gap." - - ^self ascent + self descent! ! -!AbstractFont methodsFor: 'accessing' stamp: 'jmv 4/24/2019 18:11:27' prior: 50452557! - ascent - - self subclassResponsibility ! ! -!AbstractFont methodsFor: 'accessing' stamp: 'jmv 4/25/2019 08:40:28' prior: 16777250! -height - "Answer the line spacing. Prefer calling #lineSpacing, that is more explicit. - Besides, #height is false polymorphism, Fonts are not interchangeable with Form or Rectangle!!" - - ^self lineSpacing! ! -!StrikeFont methodsFor: 'accessing' stamp: 'jmv 4/24/2019 20:25:57' prior: 16914181! - ascent - "Answer the receiver's maximum extent of characters above the baseline. Positive." - - self isSuperscript ifTrue: [ ^ ascent * 1.9 ]. - self isSubscript ifTrue: [ ^ ascent * 0.75 ]. - ^ascent! ! -!StrikeFont methodsFor: 'accessing' stamp: 'jmv 4/24/2019 20:25:44' prior: 16914258! - descent - "Answer the receiver's maximum extent of characters below the baseline. Positive." - - | answer | - answer _ descent. - self isSubscript ifTrue: [ answer _ answer * 2 ]. - ^ answer! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3709-FontRefactor1-JuanVuletich-2019Apr25-08h38m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3708] on 25 April 2019 at 9:14:52 am'! -!Object methodsFor: 'private' stamp: 'jmv 4/24/2019 20:40:04' prior: 50382690! - primitiveError: aString - "This method is called when the error handling results in a recursion in - calling on error: or halt or halt:." - - | context emergencyEvaluator lines r | - r _ `10@10` extent: (Display extent -20 min: `700@1000`). - lines _ r height // AbstractFont default lineSpacing. - emergencyEvaluator _ Transcripter newInFrame: r. - emergencyEvaluator - nextPutAll: '***System error handling failed***'; newLine; - nextPutAll: aString; newLine; - nextPutAll: '-------------------------------'; newLine. - context _ thisContext sender sender. - (30 min: lines - 10) timesRepeat: [context ifNotNil: [emergencyEvaluator print: (context _ context sender); newLine]]. - emergencyEvaluator - nextPutAll: '-------------------------------'; newLine; - nextPutAll: 'Type ''revert'' to revert your last method change.'; newLine; - nextPutAll: 'Type ''exit'' to exit the emergency evaluator.'; newLine. - emergencyEvaluator readEvalPrint! ! -!Transcripter methodsFor: 'accessing' stamp: 'jmv 4/24/2019 20:40:14' prior: 50386611! -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]. - textComposition - setModel: (TextModel withText: c asText); - extentForComposing: frame width-8 @9999. - textComposition composeAll. - d _ textComposition usedHeight - frame height. - d > 0 ifTrue: [ - "Scroll up to keep all contents visible" - cb _ textComposition characterBlockAtPoint: - `0@0` + (0@(d+AbstractFont default lineSpacing)). - self on: (c copyFrom: cb stringIndex to: c size). - readLimit _ position _ collection size. - ^ self endEntry]. - Display fill: (frame insetBy: -2) fillColor: self black; - fill: frame fillColor: self white. - Display getCanvas - textComposition: textComposition - bounds: (`4@4` + frame topLeft extent: Display extent) - color: `Color black` - selectionColor: `Color blue`. - DisplayScreen screenUpdateRequired: nil! ! -!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'jmv 4/24/2019 20:59:12' prior: 50382874! - defaultAction - - | delta textFrame barFrame outerFrame result range width filledWidth f h textWidth textForm innerBarFrame oldFilledWidth oldFilledWidth2 prevContents | - f _ AbstractFont default. - h _ f lineSpacing * 3//2. - textWidth _ (f widthOfString: progressTitle) + h. - width _ 150 max: textWidth. - - textForm _ Form extent: width@h depth: 32. - textForm fillBlack. - textForm fillWhite: (textForm boundingBox insetBy: 2). - progressTitle displayOn: textForm at: (width-textWidth+h//2@4). - barFrame _ Rectangle center: aPoint extent: width@h. - textFrame _ `0@0` extent: width@h. - textFrame _ textFrame - aligned: textFrame bottomCenter - with: barFrame topCenter + `0@2`. - outerFrame _ barFrame merge: textFrame. - delta _ outerFrame amountToTranslateWithin: Display boundingBox. - barFrame _ barFrame translatedBy: delta. - textFrame _ textFrame translatedBy: delta. - outerFrame _ outerFrame translatedBy: delta. - prevContents _ Form fromDisplay: outerFrame. - range _ maxVal = minVal ifTrue: [1] ifFalse: [maxVal - minVal]. "Avoid div by 0" - innerBarFrame _ barFrame insetBy: 2. - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - oldFilledWidth _ 0. - oldFilledWidth2 _ 0. - result _ workBlock value: "Supply the bar-update block for evaluation in the work block" - [ :barVal | - barVal - ifNotNil: [ currentVal _ barVal ] - ifNil: [ - currentVal _ currentVal + 1. - currentVal >= maxVal - ifTrue: [ currentVal _ minVal ]]. - filledWidth _ ((barFrame width-4) asFloat * ((currentVal-minVal) asFloat / range min: 1.0)) asInteger. - filledWidth > oldFilledWidth ifTrue: [ - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - Display fillGray: (barFrame topLeft + `2@2` extent: filledWidth@17). - filledWidth -200 > oldFilledWidth2 - ifFalse: [ - "Usually just request an update, to be done asynchronously." - DisplayScreen screenUpdateRequired: outerFrame ] - ifTrue: [ - "Once in a while, force a real screen update (warning: really slow on MacOS if done too often)" - Display forceToScreen: outerFrame. oldFilledWidth2 _ filledWidth ]. - oldFilledWidth _ filledWidth ]]. - prevContents displayAt: outerFrame topLeft. - self resume: result! ! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 4/24/2019 20:41:49' prior: 50394643! - standardWindowExtent - "Answer the standard default extent for new windows. " - - | grid allowedArea maxLevel | - "NOTE: following copied from strictlyStaggeredInitialFrameFor:" - allowedArea _ self maximumUsableArea insetBy: ( - self scrollBarSetback @ self screenTopSetback extent: `0@0` - ). - "Number to be staggered at each corner (less on small screens)" - maxLevel _ allowedArea area > 700000 ifTrue: [3] ifFalse: [2]. - "Amount by which to stagger (less on small screens)" - grid _ allowedArea area > 700000 ifTrue: [40] ifFalse: [20]. - ^ (allowedArea extent - (grid*(maxLevel+1*2) + (grid//2))) min: `52@40` * Preferences standardCodeFont lineSpacing! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 4/24/2019 20:29:10' prior: 50390681! - displayOn: aForm in: aRectangle - " - 1 to: 2000 do: [ :i | i print ]. - 1 to: 750 do: [ :i | i print ]. - Transcript displayOn: Display in: bounds - " - | font count string x y fh canvas innerR index | - aForm fill: aRectangle fillColor: `Color white`. - font _ AbstractFont default. - - innerR _ aRectangle insetBy: self padding. - canvas _ aForm getCanvas. - canvas newClipRect: innerR. - x _ innerR left. - y _ innerR top. - fh _ font lineSpacing. - count _ lastIndex - firstIndex \\ self maxEntries + 1 min: innerR height // fh - 1. - index _ lastIndex - count \\ self maxEntries + 1. - count timesRepeat: [ - string _ entries at: index. - canvas drawString: string at: x@y font: font color: `Color veryDarkGray`. - y _ y + fh. - index _ index \\ self maxEntries + 1 ]. - string _ unfinishedEntry contents. - canvas drawString: string at: x@y font: font color: `Color veryDarkGray`! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 4/24/2019 20:42:17' prior: 50386846! - displayUnfinishedEntryOn: aForm - - | font count string x y fh canvas r innerR | - innerR _ bounds insetBy: self padding. - lastDisplayPosition < innerR right ifTrue: [ - font _ AbstractFont default. - fh _ font lineSpacing. - count _ innerR height // fh-1. - x _ innerR left. - string _ unfinishedEntry contents. - y _ ((lastIndex - firstIndex \\ self maxEntries) min: count-1) + 1 * font lineSpacing + innerR top. - canvas _ aForm getCanvas. - r _ innerR left: lastDisplayPosition. - canvas newClipRect: r. - (canvas drawString: string at: x@y font: font color: `Color veryDarkGray`) ifNotNil: [ :lastPoint | - lastDisplayPosition _ lastPoint x. - ^r ]]. - ^nil! ! -!GrafPort methodsFor: 'text' stamp: 'jmv 4/24/2019 20:41:09' prior: 16850109! - basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font - "Answer last affected pixel position" - - destY _ aPoint y. - destX _ aPoint x. - - "the following are not really needed, but theBitBlt primitive will fail if not set" - sourceX ifNil: [sourceX _ 100]. - width ifNil: [width _ 100]. - - self primDisplayString: aString from: startIndex to: stopIndex - map: font characterToGlyphMap xTable: font xTable - kern: font baseKern. - ^ destX@(destY+font lineSpacing)! ! -!GrafPort methodsFor: 'text' stamp: 'jmv 4/22/2019 13:06:08' prior: 50358901! - displayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: aStrikeFont color: foregroundColor - "If required, do a second pass with new rule and colorMap. - Answer last affected pixel position - Answer nil if nothing was done - " - - | answer prevRule secondPassMap sourceDepth destDepth | - - "Slight optimization when there's nothing to do." - clipHeight = 0 ifTrue: [^nil]. - clipWidth = 0 ifTrue: [^nil]. - - self installStrikeFont: aStrikeFont foregroundColor: (foregroundColor alpha: 1). - - "If combinationRule is rgbMul, we might need the special two-pass technique for component alpha blending. - If not, do it simply" - combinationRule = 37 "rgbMul" ifFalse: [ - ^self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: aStrikeFont ]. - - "We need to do a second pass. The colormap set is for use in the second pass." - secondPassMap _ colorMap. - sourceDepth _ sourceForm depth. - destDepth _ destForm depth. - colorMap _ sourceDepth ~= destDepth - ifTrue: [ Color cachedColormapFrom: sourceDepth to: destDepth ]. - answer := self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: aStrikeFont. - colorMap := secondPassMap. - secondPassMap ifNotNil: [ - prevRule := combinationRule. - combinationRule := 20. "rgbAdd" - self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: aStrikeFont. - combinationRule := prevRule ]. - ^answer! ! -!GrafPort methodsFor: 'private' stamp: 'jmv 4/25/2019 09:14:34' prior: 16850216! - installStrikeFont: aStrikeFont foregroundColor: foregroundColor - - sourceForm _ aStrikeFont glyphs. - sourceY _ 0. - height _ sourceForm height. - self setRuleAndMapFor: sourceForm depth foregroundColor: foregroundColor! ! -!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jmv 4/24/2019 21:03:12' prior: 50368760! - label: aStringOrNil font: aFontOrNil - "Label this button with the given string." - label _ aStringOrNil. - font _ aFontOrNil. - (self fontToUse notNil and: [ label notNil ]) - ifTrue: [ "Add a bit of padding" - extent := (self fontToUse widthOfString: label) + 10 @ (self fontToUse lineSpacing + 10) ]! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 4/24/2019 20:58:58' prior: 50367606! - drawEmbossedLabelOn: aCanvas - - | availableW center colorForLabel f l labelMargin targetSize w x y | - label ifNotNil: [ - colorForLabel _ Theme current buttonLabel. - self isPressed - ifFalse: [ - self mouseIsOver - ifFalse: [ colorForLabel _ colorForLabel adjustSaturation: -0.10 brightness: 0.10 ]] - ifTrue: [ colorForLabel _ colorForLabel adjustSaturation: 0.0 brightness: -0.07 ]. - f _ self fontToUse. - center _ extent // 2. - labelMargin _ 3. - w _ f widthOfString: label. - availableW _ extent x - labelMargin - labelMargin. - availableW >= w - ifTrue: [ - l _ label ] - ifFalse: [ - x _ labelMargin. - targetSize _ label size * availableW // w. - l _ label squeezedTo: targetSize. - (f widthOfString: l) > availableW ifTrue: [ - targetSize _ targetSize - 1. - l _ label squeezedTo: targetSize ]]. - - w _ f widthOfString: l. - x _ center x - (w // 2). - y _ center y - (f lineSpacing // 2). - aCanvas - drawString: l - at: x@y - font: f - color: colorForLabel - embossed: true ]! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 4/24/2019 20:59:05' prior: 50367641! - drawRegularLabelOn: aCanvas - - | w f center x y availableW l labelMargin | - - f _ self fontToUse. - center _ extent // 2. - - label ifNotNil: [ - labelMargin _ 4. - w _ f widthOfString: label. - availableW _ extent x - labelMargin - labelMargin - 1. - availableW >= w - ifTrue: [ - x _ center x - (w // 2). - l _ label ] - ifFalse: [ - x _ labelMargin. - l _ label squeezedTo: (label size * availableW / w) rounded ]. - y _ center y - (f lineSpacing // 2). - self isPressed ifTrue: [ - x _ x + 1. - y _ y + 1 ]. - aCanvas - drawString: l - at: x@y - font: f - color: Theme current buttonLabel ]! ! -!PluggableListMorph methodsFor: 'geometry' stamp: 'jmv 4/24/2019 20:41:36' prior: 16888733! - scrollDeltaHeight - "Return the increment in pixels which this pane should be scrolled." - ^ self font lineSpacing! ! -!TextModelMorph methodsFor: 'geometry' stamp: 'jmv 4/24/2019 20:40:10' prior: 16934097! - scrollDeltaHeight - "Return the increment in pixels which this pane should be scrolled." - - ^ AbstractFont default lineSpacing! ! -!SystemWindow methodsFor: 'geometry' stamp: 'jmv 4/24/2019 20:40:08' prior: 16926187! - minPaneHeightForReframe - ^AbstractFont default lineSpacing + 10! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 4/24/2019 20:42:07' prior: 50384694! - boxExtent - "answer the extent to use in all the buttons. - - the label height is used to be proportional to the fonts preferences" - | e | - Theme current minimalWindows ifTrue: [^`0@0`]. - e _ Preferences windowTitleFont lineSpacing. - ^e@e! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'jmv 4/24/2019 20:41:02' prior: 50384805! - initialExtent - - ^`540@400` * Preferences standardCodeFont lineSpacing // 14! ! -!CodeWindow methodsFor: 'GUI building' stamp: 'jmv 4/24/2019 20:39:53' prior: 16813005! - defaultAnnotationPaneHeight - "Answer the receiver's preferred default height for new annotation panes." - - ^ AbstractFont default lineSpacing * 2 + 8! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'jmv 4/24/2019 20:39:50' prior: 50426575! - buildMorphicClassColumnWith: classList - - | column | - - column _ LayoutMorph newColumn. - column - addMorphUseAll: classList; - addAdjusterAndMorph: self buildMorphicSwitches fixedHeight: (Theme current minimalWindows ifTrue: [AbstractFont default lineSpacing + 4] ifFalse: [AbstractFont default lineSpacing *2-4]). - - ^column! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'jmv 4/24/2019 20:40:51' prior: 50448761! - buildNoSysCatMorphicWindow - "A Browser without the class categories list" - - | mySingletonList upperPanes messageCatList messageList classColumn classList | - mySingletonList _ PluggableListMorph - model: model - listGetter: #systemCategorySingleton - indexGetter: #indexIsOne - indexSetter: #indexIsOne: - mainView: self - menuGetter: #systemCatSingletonMenu - keystrokeAction: #systemCatSingletonKey:from:. - mySingletonList hideScrollBarsIndefinitely. - - classColumn _ self buildMorphicClassColumn. - classList _ classColumn submorphs third. - messageCatList _ self buildMorphicMessageCatList. - messageList _ self buildMorphicMessageList. - - classList rightSibling: messageCatList. - messageCatList leftSibling: classList rightSibling: messageList. - messageList leftSibling: messageCatList. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: classColumn proportionalWidth: 0.3; - addAdjusterAndMorph: messageCatList proportionalWidth: 0.3; - addAdjusterAndMorph: messageList proportionalWidth: 0.4. - - messageList makeItemsDraggable. - messageCatList - acceptDropsFrom: messageList - performing: #categorizeUnderCategoryAt:selector: - whenOutsideList: #categorizeUnderNewCategorySelector:. - - self layoutMorph - addMorph: mySingletonList fixedHeight: Preferences standardCodeFont lineSpacing + 10; - addAdjusterAndMorph: upperPanes proportionalHeight: 0.3; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.7. - - model changed: #editSelection! ! -!CodeFileBrowserWindow methodsFor: 'GUI building' stamp: 'jmv 4/24/2019 20:40:59' prior: 16809559! - buildMorphicWindow - "Create a pluggable version of all the views for a Browser, using Morphic widgets." - - | list1 list2 upperPanes | - model systemCategoryListIndex: 1. - list1 _ PluggableListMorph - model: model - listGetter: #systemCategorySingleton - indexGetter: #indexIsOne - indexSetter: #indexIsOne: - mainView: self - menuGetter: #codeFileListMenu - keystrokeAction: #codeFileListKey:from:. - list1 hideScrollBarsIndefinitely. - - list2 _ PluggableListMorph - model: model - listGetter: #messageCategoryList - indexGetter: #messageCategoryListIndex - indexSetter: #messageCategoryListIndex: - mainView: self - menuGetter: #messageCategoryMenu - keystrokeAction: nil. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: self buildMorphicClassColumn proportionalWidth: 0.3; - addAdjusterAndMorph: list2 proportionalWidth: 0.3; - addAdjusterAndMorph: self buildMorphicMessageList proportionalWidth: 0.4. - - self layoutMorph - addMorph: list1 fixedHeight: Preferences standardCodeFont lineSpacing + 10; - addAdjusterAndMorph: upperPanes proportionalHeight: 0.3; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.7. - model changed: #editSelection! ! -!ChangeSorterWindow methodsFor: 'GUI building' stamp: 'jmv 4/24/2019 20:40:56' prior: 50384811! - initialExtent - ^`540@300` * Preferences standardCodeFont lineSpacing // 14! ! -!PreDebugWindow methodsFor: 'GUI building' stamp: 'jmv 4/24/2019 20:41:45' prior: 50384817! - initialExtent - ^ `640 @ 320` * Preferences standardCodeFont lineSpacing // 14! ! -!InspectorWindow methodsFor: 'GUI building' stamp: 'jmv 4/24/2019 20:41:30' prior: 50384823! - initialExtent - - ^`600@325` * Preferences standardCodeFont lineSpacing // 14! ! -!ObjectExplorerWindow methodsFor: 'GUI building' stamp: 'jmv 4/24/2019 20:41:33' prior: 50384829! - initialExtent - - ^`300@500` * Preferences standardCodeFont lineSpacing // 14! ! -!AutoCompleterMorph class methodsFor: 'preferences' stamp: 'jmv 4/24/2019 20:40:46' prior: 16781661! - itemHeight - "height must be forced to be even to allow the detail arrow to be drawn correctly" - ^ (self listFont lineSpacing + 2) roundUpTo: 2"14".! ! -!StringMorph methodsFor: 'geometry' stamp: 'jmv 4/24/2019 20:45:28' prior: 50337417! - measureContents - | f | - f _ self fontToUse. - ^((f widthOfString: contents) max: 3) @ f lineSpacing! ! -!LayoutMorph methodsFor: 'private' stamp: 'jmv 4/24/2019 20:40:01' prior: 16863561! - minPaneHeightForReframe - ^AbstractFont default lineSpacing + 10! ! -!TaskbarMorph methodsFor: 'initialization' stamp: 'jmv 4/24/2019 20:42:10' prior: 50337214! - defaultHeight - - ^ Preferences windowTitleFont lineSpacing * 2 * self scale! ! -!InnerListMorph methodsFor: 'list management' stamp: 'jmv 4/24/2019 20:41:19' prior: 16855072! - drawBoundsForRow: row - "calculate the bounds that row should be drawn at. This might be outside our bounds!!" - - self flag: #jmvVer2. - "revisar senders" - ^ 0 @ (self drawYForRow: row) extent: extent x @ font lineSpacing! ! -!InnerListMorph methodsFor: 'list management' stamp: 'jmv 4/24/2019 20:41:22' prior: 16855082! - drawYForRow: row - "calculate the vertical position that row should be drawn at. This might be outside our bounds!!" - ^ row - 1 * font lineSpacing! ! -!InnerListMorph methodsFor: 'list management' stamp: 'jmv 4/24/2019 20:41:25' prior: 16855098! - rowAtLocation: aPoint - "return the number of the row at aPoint" - - listItems isEmpty ifTrue: [ ^0 ]. - ^aPoint y // font lineSpacing + 1 min: listItems size max: 1! ! -!InnerListMorph methodsFor: 'list management' stamp: 'jmv 4/24/2019 20:41:27' prior: 50426113! - rowAtLocation: aPoint ifNone: aNoneBlock - - | potentialRowNumber | - - potentialRowNumber := aPoint y // font lineSpacing + 1. - - ^(listItems isInBounds: potentialRowNumber) - ifTrue: [ potentialRowNumber ] - ifFalse: aNoneBlock! ! -!InnerListMorph methodsFor: 'geometry' stamp: 'jmv 4/24/2019 20:41:16' prior: 16855313! - adjustExtent - "Adjust our height to match the underlying list, - but make it wider if neccesary to fill the available width in our PluggableListMorph - (this is needed to make the selection indicator no narrower than the list)" - self morphExtent: - self desiredWidth @ ((listItems size max: 1) * font lineSpacing) -! ! -!InnerTextMorph methodsFor: 'geometry' stamp: 'jmv 4/24/2019 20:39:58' prior: 16855883! - minimumExtent - - ^(9@(AbstractFont default lineSpacing+2))! ! -!InnerTextMorph methodsFor: 'private' stamp: 'jmv 4/24/2019 20:38:42' prior: 16855971! - fit - "Adjust my bounds to fit the text. - Required after the text changes, - or if wrapFlag is true and the user attempts to change the extent." - - | newExtent newHeight newWidth | - newWidth _ extent x. - "Adjust width only if we don't wrap text to own width!!" - wrapFlag ifFalse: [ - newWidth _ self textComposition usedWidth max: 9 ]. - newHeight _ self textComposition usedHeight max: AbstractFont default lineSpacing + 2. - newExtent _ newWidth @ newHeight. - extent = newExtent - ifTrue: [ - self redrawNeeded. - "Too conservative: only text composition (because of changes in text or styles, etc) - should cause invalidation. - Try to avoid calling #fit unless needed." - ] - ifFalse: [ - extent = newExtent ifFalse: [ - self redrawNeeded. - extent _ newExtent. - self someSubmorphPositionOrExtentChanged. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]]. - - owner innerHeight: newExtent y! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jmv 4/24/2019 20:39:55' prior: 16844192! - sizeUnit - ^AbstractFont default lineSpacing! ! -!TextComposer methodsFor: 'as yet unclassified' stamp: 'jmv 4/24/2019 20:59:37' prior: 16930448! - addEmptyTrailingLine: isANewParagraph - "The line to add is usually the first line of a new paragraph (if last char in text was newLine), - but it can be a new line in same paragraph (if enough spaces ended last line)." - | ts f h bs r lm rm w a leftMarginForAlignment s | - s _ theText size+1. - f _ editor - ifNotNil: [ editor lastFont ] - ifNil: [ theText fontAt: s default: self defaultFont ]. - ts _ editor - ifNotNil: [ editor lastParagraphStyleOrNil ] - ifNil: [ theText paragraphStyleOrNilAt: s]. - - h _ f lineSpacing. - bs _ f ascent. - lm _ 0. - rm _ 0. - w _ extentForComposing x. - a _ 0. - ts ifNotNil: [ - isANewParagraph ifTrue: [ - h _ h + ts spaceBefore. - bs _ bs + ts spaceBefore ]. - lm _ ((isANewParagraph and: [ ts isListStyle not ]) - ifTrue: [ ts firstIndent ] - ifFalse: [ ts restIndent ]). - rm _ ts rightIndent. - a _ ts alignment ]. - - leftMarginForAlignment _ a = CharacterScanner rightFlushCode - ifTrue: [ w - rm] - ifFalse: [ - a = CharacterScanner centeredCode - ifTrue: [ (w - rm - lm) //2 + lm] - ifFalse: [ lm ]]. - r _ leftMarginForAlignment @ currentY extent: 0@h. - - lines addLast: ( - EmptyLine new - firstIndex: s lastIndex: s - 1; - rectangle: r; - lineHeight: h baseline: bs; - paragraphStyle: ts)! ! -!Theme methodsFor: 'other options' stamp: 'jmv 4/24/2019 20:42:14' prior: 16935668! - buttonPaneHeight - "Answer the user's preferred default height for button panes." - - ^Preferences standardButtonFont lineSpacing * 14 // 8! ! -!PopUpMenu methodsFor: 'accessing' stamp: 'jmv 4/24/2019 20:41:39' prior: 16890903! -frameHeight - "Designed to avoid the entire frame computation (includes MVC form), - since the menu may well end up being displayed in Morphic anyway." - | nItems | - nItems _ 1 + labelString lineCount. - ^ (nItems * Preferences standardMenuFont lineSpacing) + 4 "border width"! ! -!PopUpMenu methodsFor: 'basic control sequence' stamp: 'jmv 4/24/2019 20:41:42' prior: 16890928! - startUpSegmented: segmentHeight withCaption: captionOrNil at: location allowKeyboard: aBoolean - "This menu is too big to fit comfortably on the screen. - Break it up into smaller chunks, and manage the relative indices. - Inspired by a special-case solution by Reinier van Loon. The boolean parameter indicates whether the menu should be given keyboard focus (if in morphic)" - -" -(PopUpMenu labels: (String streamContents: [:s | 1 to: 100 do: [:i | s print: i; newLine]. s skip: -1]) - lines: (5 to: 100 by: 5)) startUpWithCaption: 'Give it a whirl...'. -" - | nLines nLinesPer allLabels from to subset subLines index | - allLabels := labelString lines. - nLines _ allLabels size. - lineArray ifNil: [lineArray _ Array new]. - nLinesPer _ segmentHeight // Preferences standardMenuFont lineSpacing - 5. - from := 1. - [ true ] whileTrue: [ - to := (from + nLinesPer) min: nLines. - subset := (allLabels copyFrom: from to: to) asOrderedCollection. - subset add: (to = nLines ifTrue: ['start over...'] ifFalse: ['more...']) - before: subset first. - subLines _ lineArray select: [:n | n >= from] thenCollect: [:n | n - (from-1) + 1]. - subLines _ (Array with: 1) , subLines. - index := (PopUpMenu labels: subset printStringWithNewline lines: subLines) - startUpWithCaption: captionOrNil at: location allowKeyboard: aBoolean. - index = 1 - ifTrue: [from := to + 1. - from > nLines ifTrue: [ from := 1 ]] - ifFalse: [index = 0 ifTrue: [^ 0]. - ^ from + index - 2]]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3710-FontRefactor2-JuanVuletich-2019Apr25-08h41m-jmv.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3710] on 25 April 2019 at 10:12:27 am'! -!StrikeFont methodsFor: 'accessing' stamp: 'jmv 4/25/2019 10:10:55' prior: 50372390! - baseKern - "Return the base kern value to be used for all characters. - What follows is some 'random' text used to visually adjust this method. - HaHbHcHdHeHfHgHhHiHjHkHlHmHnHoHpHqHrHsHtHuHvHwHxHyHzH - HAHBHCHDHEHFHGHHHIHJHKHLHMHNHOHPHQHRHSHTHUHVHWHXHYHXZH - wok yuyo wuwu vuvu rucu tucu WUWU VUVU huevo HUEVO to - k y mate runico ridiculo ARABICO AAAAA TOMATE - TUTU - tatadalajafua - abacadafagahaqawaearatayauaiaoapasadafagahajakalazaxacavabanama - kUxUxa - q?d?h?l?t?f?j?" - - | italic baseKern | - italic _ self isItalic. - - "Assume synthetic will not affect kerning (i.e. synthetic italics are not used)" - "After all, DejaVu Sans are the only StrikeFonts used in Cuis..." -" self familyName = 'DejaVu Sans' - ifTrue: [" - baseKern _ (italic or: [ pointSize < 9 ]) - ifTrue: [ -1 ] - ifFalse: [ 0 ]. - pointSize >= 13 ifTrue: [ - baseKern _ baseKern +1 ]. - pointSize >= 20 ifTrue: [ - baseKern _ baseKern +1 ]"] - ifFalse: [ - baseKern _ pointSize < 12 - ifTrue: [ -1 ] - ifFalse: [ 0 ]. - italic ifTrue: [ - baseKern _ baseKern - 1]]". - - "If synthetic italic" - "See makeItalicGlyphs" - (self isSynthetic and: [ italic and: [ self isBold ]]) ifTrue: [ - baseKern _ baseKern - ((self lineSpacing-1-self ascent+4)//4 max: 0) - - (((self ascent-5+4)//4 max: 0)) ]. - ^baseKern! ! -!StrikeFont methodsFor: 'emphasis' stamp: 'jmv 4/25/2019 10:11:20' prior: 16914509! - makeItalicGlyphs - "Make an italic set of glyphs with same widths by skewing left and right. - In the process, characters would overlap, so we widen them all first. - " - | extraWidth newGlyphs newXTable x newX w extraOnLeft | - extraOnLeft _ (self lineSpacing-1-self ascent+4)//4 max: 0. - extraWidth _ ((self ascent-5+4)//4 max: 0) + extraOnLeft. - newGlyphs _ Form extent: (glyphs width + (maxAscii + 1 - minAscii*extraWidth)) @ glyphs height depth: glyphs depth. - newGlyphs fillWhite. - newXTable _ xTable copy. - - "Copy glyphs into newGlyphs with room on left and right for overlap." - minAscii to: maxAscii+1 do: - [:ascii | x _ xTable at: ascii+1. w _ (xTable at: ascii+2) - x. - newX _ newXTable at: ascii+1. - newGlyphs copy: ((newX + extraOnLeft) @ 0 extent: w @ glyphs height) - from: x @ 0 in: glyphs rule: Form over. - newXTable at: ascii+2 put: newX + w + extraWidth]. - glyphs _ newGlyphs. - xTable _ newXTable. - "Slide the bitmaps left and right for synthetic italic effect." - 4 to: self ascent-1 by: 4 do: - [:y | "Slide ascenders right..." - glyphs copy: (1@0 extent: glyphs width @ (self ascent - y)) - from: 0@0 in: glyphs rule: Form over]. - self ascent to: self height-1 by: 4 do: - [:y | "Slide descenders left..." - glyphs copy: (0@y extent: glyphs width @ glyphs height) - from: 1@y in: glyphs rule: Form over]. - self isSynthetic: true! ! -!StrikeFont methodsFor: 'file in/out' stamp: 'jmv 4/25/2019 10:11:24' prior: 16914590! - printOn: aStream - super printOn: aStream. - aStream - nextPut: $(; - nextPutAll: self name; - space; - print: self lineSpacing; - nextPut: $)! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 4/25/2019 10:10:59' prior: 16914664! - glyphAt: character - "Answer a Form copied out of the glyphs for the argument, character." - | ascii leftX rightX | - ascii _ character numericValue. - (ascii between: minAscii and: maxAscii) ifFalse: [ascii _ maxAscii + 1]. - leftX _ xTable at: ascii + 1. - rightX _ xTable at: ascii + 2. - ^ glyphs copy: (leftX @ 0 corner: rightX @ self lineSpacing)! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 4/25/2019 10:11:09' prior: 16914677! - glyphAt: character put: characterForm - "Copy characterForm over the glyph for the argument, character." - | ascii leftX rightX widthDif newGlyphs | - ascii _ character numericValue. - ascii < minAscii ifTrue: [^ self error: 'Cant store characters below min ascii']. - ascii > maxAscii ifTrue: - [(self confirm: -'This font does not accomodate ascii values higher than ' , maxAscii printString , '. -Do you wish to extend it permanently to handle values up to ' , ascii printString) - ifTrue: [self extendMaxAsciiTo: ascii] - ifFalse: [^ self error: 'No change made']]. - leftX _ xTable at: ascii + 1. - rightX _ xTable at: ascii + 2. - widthDif _ characterForm width - (rightX - leftX). - widthDif ~= 0 ifTrue: - ["Make new glyphs with more or less space for this char" - newGlyphs _ Form extent: (glyphs width + widthDif) @ glyphs height depth: glyphs depth. - newGlyphs copy: (0@0 corner: leftX@glyphs height) - from: 0@0 in: glyphs rule: Form over. - newGlyphs copy: ((rightX+widthDif)@0 corner: newGlyphs width@glyphs height) - from: rightX@0 in: glyphs rule: Form over. - glyphs _ newGlyphs. - "adjust further entries on xTable" - xTable _ xTable copy. - ascii+2 to: xTable size - do: [:i | xTable at: i put: (xTable at: i) + widthDif]]. - glyphs copy: (leftX @ 0 extent: characterForm extent) - from: 0@0 in: characterForm rule: Form over -" -| f | f _ AbstractFont default. -f glyphAt: $ put: (Form extent: (f widthOf: $ )+10@f lineSpacing) -"! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3711-FontRefactor3-JuanVuletich-2019Apr25-10h06m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3710] on 25 April 2019 at 10:25:07 am'! -!Object methodsFor: 'private' stamp: 'jmv 4/25/2019 10:24:39'! - deprecatedMethod - "Warn that this method is deprecated and should not be used" - - '========' print. - thisContext sender print. - '--------------' print. - 'This method is deprecated. It will be removed from the system. Please change this and any other related senders.' print. - '--------------' print. - thisContext sender printStack: 6. - '========' print.! ! -!AbstractFont methodsFor: 'accessing' stamp: 'jmv 4/25/2019 10:21:53' prior: 50453253! - height - "Answer the line spacing. Prefer calling #lineSpacing, that is more explicit. - Besides, #height is false polymorphism, Fonts are not interchangeable with Form or Rectangle!!" - - self deprecatedMethod. - ^self lineSpacing! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3712-DeprecationWarning-JuanVuletich-2019Apr25-10h12m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3707] on 24 April 2019 at 9:22:51 pm'! -!TextModelMorph methodsFor: 'accessing' stamp: 'pb 4/24/2019 20:32:26'! - emptyTextDisplayMessage: aString - self - setProperty: #emptyTextDisplayMessage - toValue: aString.! ! -!FillInTheBlankMorph methodsFor: 'accessing' stamp: 'pb 4/24/2019 21:14:06'! - emptyTextDisplayMessage: aString - self - setProperty: #emptyTextDisplayMessage - toValue: aString.! ! -!Theme methodsFor: 'colors' stamp: 'pb 4/24/2019 20:46:25'! - textEmptyDisplayMessage - ^ `Color veryLightGray`! ! -!Browser methodsFor: 'class functions' stamp: 'pb 4/24/2019 20:20:32' prior: 16791512! - classCommentText - "return the text to display for the comment of the currently selected class" - | theClass | - theClass _ self selectedClassOrMetaClass. - ^ Text - initialFont: Preferences standardCodeFont - stringOrText: - ((theClass notNil and: [ theClass hasComment ]) - ifTrue: [ theClass comment ] - ifFalse: [ '' ]).! ! -!MessageNames methodsFor: 'initialization' stamp: 'pb 4/24/2019 20:40:35' prior: 16867714! - initialize - super initialize. - searchString _ ''! ! -!TextModelMorph methodsFor: 'drawing' stamp: 'pb 4/24/2019 20:57:54' prior: 50387799! - drawOn: aCanvas - "Include a thin red inset border for unaccepted edits, or, if the unaccepted edits are known to conflict with a change made somewhere else to the same method (typically), put a thick red frame" - | bw bc | - self flag: #todo. - "Integrate this method with the Theme system. --cbr" - super drawOn: aCanvas. - bw _ Preferences focusIndicatorWidth. - bc _ nil. - self wantsFrameAdornments ifTrue: [ - model refusesToAccept - ifTrue: [ "Put up feedback showing that code cannot be submitted in this state" - bc _ Color tan ] - ifFalse: [ - self textMorph hasEditingConflicts - ifTrue: [ - bw _ 3. - bc _ Color red ] - ifFalse: [ - self textMorph hasUnacceptedEdits ifTrue: [ bc _ Color red ]]]]. - (drawKeyboardFocusIndicator and: [ self textMorph hasKeyboardFocus ]) - ifTrue: [ bc ifNil: [ bc _ Theme current focusIndicator ]] - ifFalse: [ - bc ifNotNil: [ - bc _ bc - alphaMixed: 0.4 - with: Color white ]]. - bc ifNotNil: [ - aCanvas - frameRectangle: self focusIndicatorRectangle - borderWidth: bw - color: bc ]. - model actualContents isEmpty ifTrue: [ - self - valueOfProperty: #emptyTextDisplayMessage - ifPresentDo: [ :msg | - aCanvas - drawString: msg - at: `0 @ 0` - font: nil - color: Theme current textEmptyDisplayMessage ]].! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'pb 4/24/2019 20:22:29' prior: 16793063! - buildMorphicCommentPane - "Construct the pane that shows the class comment." - ^ (BrowserCommentTextMorph - textProvider: model - textGetter: #classCommentText - textSetter: #newClassComment:) emptyTextDisplayMessage: 'THIS CLASS HAS NO COMMENT!!'.! ! -!MessageNamesWindow methodsFor: 'GUI building' stamp: 'pb 4/24/2019 20:40:18' prior: 16867755! - buildMorphicWindow - "Answer a morphic window with the given initial search string, nil if none" - -"MessageNames openMessageNames" - - | selectorListView firstRow searchButton secondRow | - textMorph _ (TextModelMorph - textProvider: model - textGetter: #searchString - textSetter: #searchString: - selectionGetter: #contentsSelection) emptyTextDisplayMessage: 'type here, then hit Search'. - textMorph textMorph setProperty: #alwaysAccept toValue: true. - textMorph askBeforeDiscardingEdits: false. - textMorph acceptOnCR: true. - textMorph hideScrollBarsIndefinitely. - - searchButton _ PluggableButtonMorph new - model: textMorph textMorph; - label: 'Search'; - action: #acceptContents. - searchButton setBalloonText: 'Type some letters into the pane at right, and then press this Search button (or hit RETURN) and all method selectors that match what you typed will appear in the list pane below. Click on any one of them, and all the implementors of that selector will be shown in the right-hand pane, and you can view and edit their code without leaving this tool.'. - - firstRow _ LayoutMorph newRow. - firstRow color: self windowColor. - firstRow - doAdoptWidgetsColor; - addMorph: searchButton proportionalWidth: 0.25; - addMorph: textMorph proportionalWidth: 0.75. - - selectorListView _ PluggableListMorph - model: model - listGetter: #selectorList - indexGetter: #selectorListIndex - indexSetter: #selectorListIndex: - mainView: self - menuGetter: #selectorListMenu - keystrokeAction: #selectorListKey:from:. - secondRow _ LayoutMorph newRow. - secondRow - addMorph: selectorListView proportionalWidth: 0.5; - addAdjusterAndMorph: self buildMorphicMessageList proportionalWidth: 0.5. - - self layoutMorph - addMorph: firstRow fixedHeight: self defaultButtonPaneHeight+4; - addAdjusterAndMorph: secondRow proportionalHeight: 0.5; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.5. - model changed: #editSelection! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'pb 4/24/2019 21:15:30' prior: 50432776! - createTextPaneAcceptOnCR: acceptBoolean - "create the textPane" - | result | - self flag: #todo. - "Integrate this method with the Theme system. --cbr" - result _ TextModelMorph - textProvider: self - textGetter: #response - textSetter: #response: - selectionGetter: #selectionInterval. - self - valueOfProperty: #emptyTextDisplayMessage - ifPresentDo: [ :msg | - result emptyTextDisplayMessage: msg ]. - result - hasUnacceptedEdits: true; - acceptOnCR: acceptBoolean; - escAction: [ self cancelClicked ]; - morphExtent: `18 @ 5` * self sizeUnit. - self - addMorph: result - position: `1 @ 2` * self sizeUnit. - ^ result.! ! -!FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'pb 4/24/2019 21:19:42' prior: 16844242! - initializedInstance - | aFillInTheBlankMorph | - aFillInTheBlankMorph _ self new - emptyTextDisplayMessage: 'Enter answer here'; - - setQuery: 'queryString' - initialAnswer: '' - acceptOnCR: true. - aFillInTheBlankMorph responseUponCancel: 'returnOnCancel'. - ^ aFillInTheBlankMorph.! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3713-TextModelMorphEmptyMessage-PhilBellalouna-2019Apr24-20h08m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3713] on 26 April 2019 at 8:57:21 am'! -!ZeroDivide commentStamp: '' prior: 16946761! - ZeroDivide may be signaled when a mathematical division by 0 is attempted. - -It might be argued that x / 0.0 is Float infinity or Float negativeInfinity, with the sign of x; and that x / -0.0 is Float infinity or Float negativeInfinity, with the opposite sign of x. But usually infinities are not considered in numeric code. Client code might chose to catch the exception and resume with an appropriate value.! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3714-ZeroDivideComment-JuanVuletich-2019Apr26-08h55m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3713] on 26 April 2019 at 9:06:55 am'! -!Float class methodsFor: 'constants' stamp: 'jmv 4/26/2019 09:02:14' prior: 50451460! - denormalized - "Answer whether implementation supports denormalized numbers. - Allowing denormalized numbers guarantees that the result x - y is non-zero when x !!= y." - - ^true! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3715-CuisCore-JuanVuletich-2019Apr26-08h57m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3715] on 26 April 2019 at 11:10:25 am'! -!MessageNamesWindow methodsFor: 'GUI building' stamp: 'jmv 4/26/2019 11:03:57' prior: 50454353! - buildMorphicWindow - "Answer a morphic window with the given initial search string, nil if none" - -"MessageNames openMessageNames" - - | selectorListView firstRow searchButton secondRow | - textMorph _ (TextModelMorph - textProvider: model - textGetter: #searchString - textSetter: #searchString: - selectionGetter: #contentsSelection) emptyTextDisplayMessage: 'type here, then hit Search'. - textMorph askBeforeDiscardingEdits: false. - textMorph acceptOnCR: true. - textMorph hideScrollBarsIndefinitely. - - searchButton _ PluggableButtonMorph new - model: textMorph textMorph; - label: 'Search'; - action: #acceptContents. - searchButton setBalloonText: 'Type some letters into the pane at right, and then press this Search button (or hit RETURN) and all method selectors that match what you typed will appear in the list pane below. Click on any one of them, and all the implementors of that selector will be shown in the right-hand pane, and you can view and edit their code without leaving this tool.'. - - firstRow _ LayoutMorph newRow. - firstRow color: self windowColor. - firstRow - doAdoptWidgetsColor; - addMorph: searchButton proportionalWidth: 0.25; - addMorph: textMorph proportionalWidth: 0.75. - - selectorListView _ PluggableListMorph - model: model - listGetter: #selectorList - indexGetter: #selectorListIndex - indexSetter: #selectorListIndex: - mainView: self - menuGetter: #selectorListMenu - keystrokeAction: #selectorListKey:from:. - secondRow _ LayoutMorph newRow. - secondRow - addMorph: selectorListView proportionalWidth: 0.5; - addAdjusterAndMorph: self buildMorphicMessageList proportionalWidth: 0.5. - - self layoutMorph - addMorph: firstRow fixedHeight: self defaultButtonPaneHeight+4; - addAdjusterAndMorph: secondRow proportionalHeight: 0.5; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.5. - model changed: #editSelection! ! -!InnerTextMorph methodsFor: 'editing' stamp: 'jmv 4/26/2019 11:02:36' prior: 50379901! - acceptContents - "The message is sent when the user hits return or Cmd-S. - Accept the current contents and end editing." - "Inform the model of text to be accepted, and return true if OK." - - | accepted prevSelection prevScrollValue | - - prevSelection _ self editor selectionInterval copy. - prevScrollValue _ owner verticalScrollBar scrollValue. - - hasUnacceptedEdits ifFalse: [ self flash. ^true ]. - hasEditingConflicts ifTrue: [ - self confirmAcceptAnyway ifFalse: [self flash. ^false]]. - - accepted _ model acceptContentsFrom: owner. - "During the step for the browser, updatePaneIfNeeded is called, and - invariably resets the contents of the code-holding PluggableTextMorph - at that time, resetting the cursor position and scroller in the process. - The following line forces that update without waiting for the step, - then restores the cursor and scrollbar" - - "some implementors of acceptContentsFrom: answer self :(" - ^accepted == true - ifTrue: [ - model refetch. - self editor selectFrom: prevSelection first to: prevSelection last. - UISupervisor whenUIinSafeState: [ - self world ifNotNil: [ :w | w activeHand newKeyboardFocus: self ]. - owner verticalScrollBar internalScrollValue: prevScrollValue]. - true] - ifFalse: [ false ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3716-TextModelMorph-fix-JuanVuletich-2019Apr26-10h38m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3716] on 27 April 2019 at 5:17:15 pm'! -!Number class methodsFor: 'instance creation' stamp: 'jmv 4/27/2019 17:14:36' prior: 16880639! - readFrom: stringOrStream - "Answer a number as described on aStream. The number may - include a leading radix specification, as in 16rFADE" - | value base aStream sign | - aStream _ (stringOrStream isMemberOf: String) - ifTrue: [ReadStream on: stringOrStream] - ifFalse: [stringOrStream]. - (aStream nextMatchAll: 'NaN') ifTrue: [^ Float nan]. - sign _ (aStream peekFor: $-) ifTrue: [-1] ifFalse: [1]. - (aStream nextMatchAll: 'Infinity') ifTrue: [^ Float infinity * sign]. - base _ 10. - value _ Integer readFrom: aStream base: base. - (aStream peekFor: $r) - ifTrue: [ - "r" - (base _ value) < 2 ifTrue: [ - base = 1 ifTrue: [ ^Integer readBaseOneFrom: aStream ]. - ^self error: 'Invalid radix']. - (aStream peekFor: $-) ifTrue: [sign _ sign negated]. - value _ Integer readFrom: aStream base: base]. - (aStream peekFor: $x) - ifTrue: [ - "0x" "Hexadecimal" - base _ 16. - (aStream peekFor: $-) ifTrue: [sign _ sign negated]. - value _ Integer readFrom: aStream base: base]. - ^ self readRemainderOf: value from: aStream base: base withSign: sign.! ! -!Number class methodsFor: 'instance creation' stamp: 'jmv 4/27/2019 16:54:05' prior: 50414617! - readRemainderOf: integerPart from: aStream base: base withSign: sign - "Read optional fractional part and exponent, and return the final result" - | value fraction fracpos peekChar exp scale convertToFloat | - - convertToFloat := false. - value := integerPart. - (aStream peekFor: $.) - ifTrue: [ "." - (aStream atEnd not and: [ aStream peek digitValue between: 0 and: base - 1 ]) - ifTrue: [ - fracpos := aStream position. - fraction := Integer readFrom: aStream base: base. - fraction := fraction / (base raisedToInteger: aStream position - fracpos). - value := value + fraction. - convertToFloat := true ] - ifFalse: [ - "oops - just ." - aStream skip: -1. - "un-gobble the period" - ^ value * sign"Number readFrom: '3r-22.2'"]]. - peekChar := aStream peek. - ('deqp' includes: peekChar) - ifTrue: [ "(e|d|q)>" "(p)>" - aStream next. - (aStream atEnd not and: [ (aStream peek digitValue between: 0 and: 9) or: [ '+-' includes: aStream peek ]]) - ifTrue: [ - exp := Integer readFrom: aStream. - scale := (peekChar = $p ifTrue: [2] ifFalse: [base]) raisedToInteger: exp. - value := value * scale ] - ifFalse: [ - "oops - just ." - aStream skip: -1.]]. - ^convertToFloat - ifTrue: [ - (value = 0.0 and: [ sign = -1 ]) - ifTrue: [ Float negativeZero ] - ifFalse: [ (value * sign) asFloat ]] - ifFalse: [ value * sign ]! ! -!SHParserST80 methodsFor: 'scan' stamp: 'jmv 4/27/2019 17:10:13' prior: 16901854! -scanNumber - | start c nc base | - start := sourcePosition. - self skipDigits. - c := self currentChar. - ('rx' includes: c) - ifTrue: [ - base := Integer readFrom: (ReadStream on: (source copyFrom: start to: sourcePosition - 1)). - self peekChar == $- ifTrue:[self nextChar]. - self skipBigDigits: base. - c := self currentChar. - c == $. - ifTrue: [ - (self isBigDigit: self nextChar base: base) - ifFalse: [sourcePosition := sourcePosition - 1] - ifTrue: [self skipBigDigits: base]]. - c := self currentChar. - ('deqp'includes: c) - ifTrue: [ - ((nc := self nextChar) isDigit or: [nc == $- and:[self peekChar isDigit]]) - ifFalse: [sourcePosition := sourcePosition - 1] - ifTrue: [self skipDigits]]. - c == $s - ifTrue: [ - self nextChar isDigit - ifFalse: [sourcePosition := sourcePosition - 1] - ifTrue: [self skipDigits]]. - currentToken := source copyFrom: start to: sourcePosition - 1. - ^currentTokenSourcePosition := start]. - c == $s - ifTrue: [ - self nextChar isDigit - ifFalse: [sourcePosition := sourcePosition - 1] - ifTrue: [self skipDigits.]. - currentToken := source copyFrom: start to: sourcePosition - 1. - ^currentTokenSourcePosition := start]. - c == $. - ifTrue: [ - self nextChar isDigit - ifFalse: [ - sourcePosition := sourcePosition - 1. - currentToken := source copyFrom: start to: sourcePosition - 1. - ^currentTokenSourcePosition := start] - ifTrue: [self skipDigits]]. - c := self currentChar. - ('deqp' includes: c) - ifTrue: [ - ((nc := self nextChar) isDigit or: [nc == $- and:[self peekChar isDigit]]) - ifFalse: [sourcePosition := sourcePosition - 1] - ifTrue: [self skipDigits]]. - c == $s - ifTrue: [ - self nextChar isDigit - ifFalse: [sourcePosition := sourcePosition - 1] - ifTrue: [self skipDigits]]. - currentToken := source copyFrom: start to: sourcePosition - 1. - ^currentTokenSourcePosition := start! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3717-HexadecimalExponentialNotation-JuanVuletich-2019Apr27-17h15m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3717] on 28 April 2019 at 7:10:10 pm'! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 4/28/2019 19:09:34' prior: 50448693! - arrowKey: aKeyboardEvent - - aKeyboardEvent anyModifierKeyPressed ifFalse: [ - aKeyboardEvent isArrowUp ifTrue: [ ^ self navigateUp ]. - aKeyboardEvent isArrowDown ifTrue: [ ^ self navigateDown ]. - aKeyboardEvent isArrowLeft ifTrue: [ ^ self navigateLeft ]. - aKeyboardEvent isArrowRight ifTrue: [ ^ self navigateRight ]. - aKeyboardEvent isHome ifTrue: [ ^ self navigateToTop ]. - aKeyboardEvent isEnd ifTrue: [ ^ self navigateToBottom ]. - aKeyboardEvent isPageUp ifTrue: [ ^ self navigateOnePageUp ]. - aKeyboardEvent isPageDown ifTrue: [ ^ self navigateOnePageDown ]]. - ^ nil! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3718-ListMorphKeyboardNavigationOnlyIfNoModifiers-JuanVuletich-2019Apr28-19h09m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3718] on 28 April 2019 at 8:39:00 pm'! -!CharacterBlockScanner methodsFor: 'scanning' stamp: 'jmv 4/28/2019 20:37:26' prior: 50410538! - characterBlockAtPoint: aPoint index: index in: textLine - "This method is the Morphic characterBlock finder." - | runLength lineStop stopCondition | - line _ textLine. - rightMargin _ line rightMargin. - lastTabIndex _ lastIndex _ line first. - self setFont. - self setStopConditions. - characterIndex _ index. "nil means scanning for point" - characterPoint _ aPoint. - (characterPoint isNil or: [ characterPoint y > line bottom ]) - ifTrue: [ characterPoint _ line bottomRight ]. - (text isEmpty or: [( characterPoint y < line top or: [ characterPoint x < line left ]) - or: [ characterIndex notNil and: [ characterIndex < line first ]]]) - ifTrue: [^ CharacterBlock - stringIndex: line first - text: text - topLeft: line leftMargin@line top - extent: 0 @ line lineHeight - textLine: line]. - lastTabX _ destX _ leftMargin _ line leftMarginForAlignment: alignment. - destY _ line top. - runLength _ text runLengthFor: line first. - lineStop _ characterIndex "scanning for index" - ifNil: [ line last ]. "scanning for point" - runStopIndex _ lastIndex + (runLength - 1) min: lineStop. - lastCharacterWidth _ 0. - spaceCount _ 0. - - self placeEmbeddedObject. - [ - stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex - in: text string rightX: characterPoint x - stopConditions: stopConditions kern: font baseKern. - "see setStopConditions for stopping conditions for character block operations." - lastCharacterWidth _ specialWidth ifNil: [ font widthOf: (text at: lastIndex) ]. - (self perform: stopCondition) ifTrue: [ - ^characterIndex - ifNil: [ "Result for characterBlockAtPoint: " - CharacterBlock - stringIndex: lastIndex - text: text - topLeft: characterPoint x@line top - extent: lastCharacterWidth @ line lineHeight - textLine: line ] - ifNotNil: [ "Result for characterBlockForIndex: " - CharacterBlock - stringIndex: characterIndex - text: text - topLeft: characterPoint x@line top - extent: lastCharacterWidth @ line lineHeight - textLine: line ]] - ] repeat! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'jmv 4/28/2019 20:33:01' prior: 50406146! - scrollToShow: aRectangle - "scroll to include as much of aRectangle as possible, where aRectangle is in the scroller's local space. - This means that 0@0 is scrolling all the way top and all the way left" - | deltaY | - (aRectangle top >= 0 and: [ - aRectangle bottom <= self viewableHeight ]) - ifTrue: [ - "already visible" - ^self ]. - "Scroll center of selection into view if necessary" - deltaY _ (aRectangle amountToTranslateWithin: (`0@0` extent: self viewableExtent)) y. - deltaY ~= 0 ifTrue: [ - self scrollBy: 0@deltaY ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3719-AvoidExcessiveAutoScrollJumping-JuanVuletich-2019Apr28-20h37m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3719] on 29 April 2019 at 8:59:46 am'! -!Transcript class methodsFor: 'private' stamp: 'jmv 4/29/2019 08:58:28'! - addEntry: aString log: otherString - "Add a new entrie to the entries circular list. If full, a new entry will replace the oldest one." - - accessSemaphore critical: [ - - "Internal circular collection" - lastIndex _ lastIndex \\ self maxEntries + 1. - firstIndex = lastIndex ifTrue: [ firstIndex _ firstIndex \\ self maxEntries + 1 ]. - entries at: lastIndex put: aString. - - otherString ifNotNil: [ - self writeToFile: otherString. - self writeToStdout: otherString - ] - ]! ! -!Transcript class methodsFor: 'private' stamp: 'jmv 4/29/2019 08:58:40' prior: 50453132! - addEntry: aString - "Add a new entrie to the entries circular list. If full, a new entry will replace the oldest one." - | msg now | - logToFile | logToStdout ifTrue: [ - now _ DateAndTime now. - msg _ String streamContents: [ :strm | - now printWithMsOn: strm. - strm - nextPutAll: ' process:'; - nextPutAll: Processor activeProcess priority printString; - nextPut: $ ; - nextPutAll: Processor activeProcess hash printString; - nextPut: $ ; - nextPutAll: aString; - newLine ]]. - - self addEntry: (aString copyReplaceAll: String newLineString with: ' ') log: msg! ! - -Transcript class removeSelector: #addEntry:logToFile:! - -Transcript class removeSelector: #addEntry:logToFile:! - -Transcript class removeSelector: #addEntry:logToFileAndStdout:! - -Transcript class removeSelector: #addEntry:logToFileAndStdout:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3720-TranscriptTweaks-JuanVuletich-2019Apr29-08h58m-jmv.1.cs.st----! - -----SNAPSHOT----(29 April 2019 09:04:44) Cuis5.0-3720-v3.image priorSource: 3855612! - -----QUIT----(29 April 2019 09:05:06) Cuis5.0-3720-v3.image priorSource: 3945284! - -----STARTUP---- (3 June 2019 11:01:31) as /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/Cuis5.0-3720-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3720] on 29 April 2019 at 9:15:50 am'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 4/29/2019 09:14:33' prior: 50343137! - saveAsNewVersion - "Save the image/changes using the next available version number." - " - Smalltalk saveAsNewVersion - " - | fileName newName changesName systemVersion | - self okayToSave ifFalse: [ ^ self ]. - systemVersion _ SystemVersion current. - fileName _ String streamContents: [ :strm | - strm - nextPutAll: 'Cuis'; - print: systemVersion versionMajor; - nextPut: $.; - print: systemVersion versionMinor; - nextPut: $-; - print: systemVersion highestUpdate. - Smalltalk isSpur - ifTrue: [ - Smalltalk wordSize = 4 ifTrue: [ - strm nextPutAll: '-32' ]] - ifFalse: [ - strm nextPutAll: '-v3' ]]. - newName _ fileName, '.image'. - (DirectoryEntry smalltalkImageDirectory // newName) exists ifTrue: [ - newName _ DirectoryEntry smalltalkImageDirectory - nextNameFor: fileName - extension: 'image' ]. - changesName _ self fullNameForChangesNamed: newName. - "Check to see if there is a .changes file that would cause a problem if we saved a new .image file with the new version number" - changesName asFileEntry exists ifTrue: [ - ^ self inform: -'There is already .changes file of the desired name, -', changesName, ' -curiously already present, even though there is no -corresponding .image file. -Please remedy manually and then repeat your request.' ]. - "Try to clear all user state, including all class vars, preferences, etc" - self saveAs: newName andQuit: false clearAllClassState: true! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3721-SaveAsNewVersion-WarningMessageTweak-JuanVuletich-2019Apr29-09h14m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3721] on 2 May 2019 at 8:31:27 am'! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/1/2019 12:50:29'! - navigateDown - "move down, wrapping to top if needed" - | nextSelection | - nextSelection _ self visualSelectionIndex + 1. - nextSelection > self maximumSelection ifTrue: [ nextSelection _ self minimumSelection ]. - self changeSelectionTo: nextSelection! ! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/1/2019 12:51:51'! - navigateLeft - | oldSelection nextSelection | - oldSelection _ self visualSelectionIndex. - nextSelection _ oldSelection. - selectedMorph ifNotNil: [ - selectedMorph isExpanded - ifTrue: [ - self toggleExpandedState: selectedMorph. - self scrollSelectionIntoView ] - ifFalse: [ - oldSelection > self minimumSelection ifTrue: [ - nextSelection _ (oldSelection-1 to: 1 by: -1) - detect: [ :i | ( scroller submorphs at: i) indentLevel < selectedMorph indentLevel ] - ifNone: [ oldSelection ]]. - ]]. - self changeSelectionTo: nextSelection! ! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/1/2019 12:58:27'! - navigateOnePageDown - - self changeSelectionTo: (self visualSelectionIndex + self numSelectionsInView min: self maximumSelection)! ! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/1/2019 12:54:14'! - navigateOnePageUp - - self changeSelectionTo: (self minimumSelection max: self visualSelectionIndex - self numSelectionsInView)! ! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/1/2019 12:51:59'! - navigateRight - | oldSelection nextSelection | - oldSelection _ self visualSelectionIndex. - nextSelection _ oldSelection. - selectedMorph ifNotNil: [ - (selectedMorph canExpand and: [ selectedMorph isExpanded not ]) - ifTrue: [ - self toggleExpandedState: selectedMorph. - self scrollSelectionIntoView ] - ifFalse: [ nextSelection := oldSelection + 1 ]]. - self changeSelectionTo: nextSelection! ! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/1/2019 12:49:21'! - navigateToBottom - - self changeSelectionTo: self maximumSelection! ! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/1/2019 12:52:29'! - navigateToTop - - self changeSelectionTo: self minimumSelection! ! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/1/2019 12:50:43'! - navigateUp - "move up, wrapping to bottom if needed" - | nextSelection | - nextSelection _ self visualSelectionIndex - 1. - nextSelection < self minimumSelection ifTrue: [ nextSelection _ self maximumSelection ]. - self changeSelectionTo: nextSelection! ! -!HierarchicalListMorph methodsFor: 'private' stamp: 'jmv 5/1/2019 12:37:18'! - changeSelectionTo: nextSelection - - nextSelection = self visualSelectionIndex ifFalse: [ - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self highlightedMorph: (self listMorphAt: nextSelection). - "Update the model in next world cycle, so user gets the immediate feedback." - UISupervisor whenUIinSafeState: [ self setSelectionIndex: nextSelection ]].! ! -!HierarchicalListMorph methodsFor: 'events' stamp: 'jmv 5/1/2019 12:55:50' prior: 50449256! - keyStroke: aKeyboardEvent - "Process potential command keys" - - | args | - (self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - (self arrowKey: aKeyboardEvent) ifNotNil: [ ^ self ]. - keystrokeActionSelector ifNil: [^self]. - (args _ keystrokeActionSelector numArgs) = 1 - ifTrue: [^mainView perform: keystrokeActionSelector with: aKeyboardEvent keyCharacter]. - args = 2 - ifTrue: [ - ^mainView - perform: keystrokeActionSelector - with: aKeyboardEvent keyCharacter - with: self]. - ^self error: 'The keystrokeActionSelector must be a 1- or 2-keyword symbol'! ! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/1/2019 12:55:36' prior: 50449463! - arrowKey: aKeyboardEvent - - "Handle a keyboard navigation event. Answer nil if not handled." - aKeyboardEvent isArrowUp ifTrue: [ ^ self navigateUp ]. - aKeyboardEvent isArrowDown ifTrue: [ ^ self navigateDown ]. - aKeyboardEvent isArrowLeft ifTrue: [ ^ self navigateLeft ]. - aKeyboardEvent isArrowRight ifTrue: [ ^ self navigateRight ]. - aKeyboardEvent isHome ifTrue: [ ^ self navigateToTop ]. - aKeyboardEvent isEnd ifTrue: [ ^ self navigateToBottom ]. - aKeyboardEvent isPageUp ifTrue: [ ^ self navigateOnePageUp ]. - aKeyboardEvent isPageDown ifTrue: [ ^ self navigateOnePageDown ]. - ^ nil! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/1/2019 12:55:33' prior: 50454766! - arrowKey: aKeyboardEvent - - "Handle a keyboard navigation event. Answer nil if not handled." - aKeyboardEvent anyModifierKeyPressed ifFalse: [ - aKeyboardEvent isArrowUp ifTrue: [ ^ self navigateUp ]. - aKeyboardEvent isArrowDown ifTrue: [ ^ self navigateDown ]. - aKeyboardEvent isArrowLeft ifTrue: [ ^ self navigateLeft ]. - aKeyboardEvent isArrowRight ifTrue: [ ^ self navigateRight ]. - aKeyboardEvent isHome ifTrue: [ ^ self navigateToTop ]. - aKeyboardEvent isEnd ifTrue: [ ^ self navigateToBottom ]. - aKeyboardEvent isPageUp ifTrue: [ ^ self navigateOnePageUp ]. - aKeyboardEvent isPageDown ifTrue: [ ^ self navigateOnePageDown ]]. - ^ nil! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/1/2019 12:50:55' prior: 50448572! - navigateDown - "move down, wrapping to top if needed" - | nextSelection | - nextSelection _ self getCurrentSelectionIndex + 1. - nextSelection > self maximumSelection ifTrue: [ nextSelection _ self minimumSelection ]. - self changeSelectionTo: nextSelection! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/1/2019 12:58:14' prior: 50448589! - navigateOnePageDown - - self changeSelectionTo: (self getCurrentSelectionIndex + self numSelectionsInView min: self maximumSelection)! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/1/2019 12:52:34' prior: 50448618! - navigateToTop - - self changeSelectionTo: self minimumSelection! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/1/2019 12:51:10' prior: 50448623! - navigateUp - "move up, wrapping to bottom if needed" - | nextSelection | - nextSelection _ self getCurrentSelectionIndex - 1. - nextSelection < self minimumSelection ifTrue: [ nextSelection _ self maximumSelection ]. - self changeSelectionTo: nextSelection! ! -!PluggableListMorph methodsFor: 'private' stamp: 'jmv 5/1/2019 12:36:00' prior: 50448633! - changeSelectionTo: nextSelection - - nextSelection = self getCurrentSelectionIndex ifFalse: [ - | window | - window _ self owningWindow. - (window isNil or: [ window okToChangeDueTo: self ]) ifTrue: [ - "No change if model is locked" - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self listMorph highlightedRow: nextSelection. - "Update the model in next world cycle, so user gets the immediate feedback." - UISupervisor whenUIinSafeState: [ self setSelectionIndex: nextSelection ]. - ] - ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3722-HierarchicalListMorph-refactor-JuanVuletich-2019May02-08h22m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3722] on 2 May 2019 at 9:37:49 am'! -!TextEditor methodsFor: 'accessing' stamp: 'jmv 5/2/2019 09:12:25'! - selectionRectangle - "Answer a rectangle that encompasses single or multiple selection. - If no selection, answer a rectangle that includes cursor." - selectionStartBlocks notEmpty ifTrue: [ - ^ selectionStartBlocks first quickMerge: selectionStopBlocks last]. - ^ markBlock quickMerge: pointBlock! ! -!TextEditor methodsFor: 'accessing-selection' stamp: 'jmv 5/2/2019 09:02:22' prior: 16931381! - hasSelection - ^ markBlock ~= pointBlock or: [ selectionStartBlocks notEmpty ]! ! -!TextEditor methodsFor: 'accessing-selection' stamp: 'jmv 5/2/2019 09:00:31' prior: 16931446! - selectionAsStream - "Answer a ReadStream on the text that is currently selected. - Note: Only considers single selection. See #selection to see how we handle multiple selection." - - ^ReadWriteStream - on: self privateCurrentString - from: self startIndex - to: self stopIndex - 1! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'jmv 5/2/2019 09:33:42' prior: 50454863! - scrollToShow: aRectangle - "scroll to include as much of aRectangle as possible, where aRectangle is in the scroller's local space. - This means that 0@0 is scrolling all the way top and all the way left" - | deltaY | - deltaY _ (aRectangle amountToTranslateWithin: (`0@0` extent: self viewableExtent)) y. - deltaY ~= 0 ifTrue: [ - self scrollBy: 0@deltaY ]! ! -!TextModelMorph methodsFor: 'editor access' stamp: 'jmv 5/2/2019 09:10:04' prior: 16934028! -scrollSelectionIntoView - "Scroll my text into view if necessary and return true, else return false" - - self scrollToShow: (self editor selectionRectangle translatedBy: self textMorph morphPosition)! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3723-scrollSelectionIntoView-fix-JuanVuletich-2019May02-09h35m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3723] on 2 May 2019 at 4:27:24 pm'! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/2/2019 16:25:15' prior: 50455130! - arrowKey: aKeyboardEvent - - "Handle a keyboard navigation event. Answer nil if not handled." - "Ctrl arrows is used to scroll without changing the selection" - aKeyboardEvent controlKeyPressed ifFalse: [ - aKeyboardEvent isArrowUp ifTrue: [ ^ self navigateUp ]. - aKeyboardEvent isArrowDown ifTrue: [ ^ self navigateDown ]. - aKeyboardEvent isArrowLeft ifTrue: [ ^ self navigateLeft ]. - aKeyboardEvent isArrowRight ifTrue: [ ^ self navigateRight ]. - aKeyboardEvent isHome ifTrue: [ ^ self navigateToTop ]. - aKeyboardEvent isEnd ifTrue: [ ^ self navigateToBottom ]. - aKeyboardEvent isPageUp ifTrue: [ ^ self navigateOnePageUp ]. - aKeyboardEvent isPageDown ifTrue: [ ^ self navigateOnePageDown ]]. - ^ nil! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/2/2019 16:24:31' prior: 50455152! - arrowKey: aKeyboardEvent - - "Handle a keyboard navigation event. Answer nil if not handled." - "Ctrl arrows is used to scroll without changing the selection" - aKeyboardEvent controlKeyPressed ifFalse: [ - aKeyboardEvent isArrowUp ifTrue: [ ^ self navigateUp ]. - aKeyboardEvent isArrowDown ifTrue: [ ^ self navigateDown ]. - aKeyboardEvent isArrowLeft ifTrue: [ ^ self navigateLeft ]. - aKeyboardEvent isArrowRight ifTrue: [ ^ self navigateRight ]. - aKeyboardEvent isHome ifTrue: [ ^ self navigateToTop ]. - aKeyboardEvent isEnd ifTrue: [ ^ self navigateToBottom ]. - aKeyboardEvent isPageUp ifTrue: [ ^ self navigateOnePageUp ]. - aKeyboardEvent isPageDown ifTrue: [ ^ self navigateOnePageDown ]]. - ^ nil! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3724-ListMorphKeyboardNavigationOnlyIfNoCtrl-JuanVuletich-2019May02-16h24m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3724] on 4 May 2019 at 9:17:44 pm'! -!KeyboardEvent methodsFor: 'actions' stamp: 'RNG 5/4/2019 21:13:06'! - closeCurrentWindowOf: aMorph - - aMorph owningWindow ifNotNil: [ :w | - (w morphContainsPoint: (w internalizeFromWorld: self eventPosition)) - ifTrue: [ w delete. ] ]! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'RNG 5/4/2019 21:14:18'! - isCloseWindowShortcut - - ^ (self commandAltKeyPressed or: [ self controlKeyPressed ]) - and: [self keyCharacter = $w]! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'RNG 5/4/2019 21:16:04'! - isFindClassShortcut - - ^ self shiftPressed and: [ self isReturnKey ]! ! -!KeyboardEvent methodsFor: 'dispatching' stamp: 'RNG 5/4/2019 21:14:56' prior: 50449386! -sentTo: aMorph localPosition: positionInAMorph - "Dispatch the receiver into anObject" - type == #keystroke ifTrue: [ - self isFindClassShortcut - ifTrue: [ ^ BrowserWindow findClass]. - self isCloseWindowShortcut - ifTrue: [ ^ self closeCurrentWindowOf: aMorph ]. - ^ aMorph - processKeystroke: self - localPosition: positionInAMorph ]. - type == #keyDown ifTrue: [ - ^ aMorph - processKeyDown: self - localPosition: positionInAMorph ]. - type == #keyUp ifTrue: [ - ^ aMorph - processKeyUp: self - localPosition: positionInAMorph ]. - ^ super - sentTo: aMorph - localPosition: positionInAMorph.! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3725-KeyboardEventCleanup-NahuelGarbezza-2019May04-20h42m-RNG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3716] on 5 May 2019 at 6:48:52 pm'! -!CodeProvider methodsFor: 'annotation' stamp: 'pb 5/5/2019 18:18:13' prior: 16811706! -annotation - "Provide a line of content for an annotation pane, representing information about the method associated with the selected class and selector in the receiver." - - | aSelector aClass | - - ((aSelector _ self selectedMessageName) == nil or: [(aClass _ self selectedClassOrMetaClass) == nil]) - ifTrue: [^ '']. - ^ self annotationForSelector: aSelector ofClass: aClass! ! -!Browser methodsFor: 'annotation' stamp: 'pb 5/5/2019 18:19:46' prior: 16791461! - annotation - "Provide a line of content for an annotation pane, representing information about the method associated with the selected class and selector in the receiver." - - | aSelector aClass | - (aClass _ self selectedClassOrMetaClass) - ifNil: [^ '']. - self editSelection == #editComment - ifTrue: [^ self annotationForSelector: #Comment ofClass: aClass]. - self editSelection == #editClass - ifTrue: [^ self annotationForSelector: #Definition ofClass: aClass]. - (aSelector _ self selectedMessageName) - ifNil: [^ '']. - ^ self annotationForSelector: aSelector ofClass: aClass! ! -!ChangeList methodsFor: 'viewing access' stamp: 'pb 5/5/2019 18:19:33' prior: 16796581! - annotation - "Answer the string to be shown in an annotation pane. Make plain that the annotation is associated with the current in-image version of the code, not of the selected disk-based version, and if the corresponding method is missing from the in-image version, mention that fact." - - | change count selectedCount ann1 ann2 | - change _ self currentChange. - - change isNil ifTrue: [ - count _ listSelections size. - selectedCount _ listSelections count: [ :flag | flag ]. - ^ 'Total items: ', count printString, ' - Selected items: ', selectedCount printString ]. - - change changeType == #classDefinition ifTrue: [ - ann1 _ change isMetaClassChange ifTrue: [ 'Metaclass' ] ifFalse: [ 'Class' ]. - ann2 _ (Smalltalk includesKey: change changeClassName) ifTrue: [ ' already exists' ] ifFalse: [ ' not in system' ]. - ^ann1, ann2 ]. - - (self selectedMessageName isNil or: [self selectedClassOrMetaClass isNil]) - ifTrue: [^ '']. - - ^ change methodSelector notNil - ifFalse: [ super annotation] - ifTrue: [ - (self isNewMethod: change) - ifTrue: [ - String streamContents: [ :strm | | sel | - sel _ change methodSelector. - strm - nextPutAll: change changeClassName; - nextPutAll: ' >> '; - nextPutAll: sel; - nextPutAll: ' is not present in the system. It has '. - count _ Smalltalk numberOfImplementorsOf: sel. - count = 1 - ifTrue: [strm nextPutAll: '1 implementor'] - ifFalse: [count printOn: strm. strm nextPutAll: ' implementors' ]. - strm nextPutAll: ' and '. - count _ Smalltalk numberOfSendersOf: sel. - count = 1 - ifTrue: [strm nextPutAll: '1 sender.'] - ifFalse: [count printOn: strm. strm nextPutAll: ' senders.' ]. - ] - ] - ifFalse: [ - 'current version: ', super annotation]]! ! -!TestRunner methodsFor: 'updating' stamp: 'pb 5/5/2019 18:31:36' prior: 16928357! - refreshTR - self updateErrors: TestResult new. - self updateFailures: TestResult new. - self displayPassFail: ''. - self displayDetails: ''! ! -!TestRunner methodsFor: 'initialization' stamp: 'pb 5/5/2019 18:31:29' prior: 16928424! - initialize - - result := TestResult new. - passFail := ''. - details := ''. - failures := OrderedCollection new. - errors := OrderedCollection new. - tests := self gatherTestNames. - selectedSuite := 0. - selectedFailureTest := 0. - selectedErrorTest := 0. - selectedSuites := tests collect: [:ea | true]. - running := nil. - runSemaphore := Semaphore new! ! -!CodePackage methodsFor: 'naming' stamp: 'pb 5/5/2019 17:59:16' prior: 50401524! - packageName: aString - packageName _ aString. - description _ ''. - featureSpec _ FeatureSpec new. - featureSpec provides: (Feature name: packageName version: 1 revision: 0). - hasUnsavedChanges _ self includesAnyCode. - "But reset revision if it was incremented because of marking it dirty!!" - featureSpec provides name: packageName version: 1 revision: 0! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'pb 5/5/2019 18:13:05' prior: 50387856! - buildMorphicWindow - " - CodePackageListWindow open: CodePackageList new - " - | dirtyFlags names fileNames upperRow description summary backColor labelBackground | - backColor := self textBackgroundColor. - labelBackground := Theme current background. - - dirtyFlags := PluggableListMorph - model: model - listGetter: #packageDirtyFlags - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - dirtyFlags color: backColor. - dirtyFlags := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: ' Unsaved?'); - addMorphUseAll: dirtyFlags. - - names := PluggableListMorph - model: model - listGetter: #packageNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - names color: backColor. - names := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: ' Package Name'); - addMorphUseAll: names. - - fileNames := PluggableListMorph - model: model - listGetter: #packageFullNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - fileNames color: backColor. - fileNames := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: ' File Name'); - addMorphUseAll: fileNames. - - upperRow := LayoutMorph newRow. - upperRow - addMorph: dirtyFlags proportionalWidth: 0.13; - addAdjusterAndMorph: names proportionalWidth: 0.27; - addAdjusterAndMorph: fileNames proportionalWidth: 0.6. - - description := (TextModelMorph - textProvider: model - textGetter: #description - textSetter: #description:) emptyTextDisplayMessage: 'Please enter a description for this package'. - - summary := (TextModelMorph - textProvider: model - textGetter: #summary) emptyTextDisplayMessage: 'Package summary (No package selected?)'. - - self layoutMorph - addMorph: upperRow proportionalHeight: 0.6; - addAdjusterAndMorph: self buildButtonPane fixedHeight: Theme current buttonPaneHeight; - addAdjusterAndMorph: summary fixedHeight: 60; - addAdjusterAndMorph: description proportionalHeight: 0.25; - addAdjusterAndMorph: self buildRequirementsPane proportionalHeight: 0.15. - self setLabel: 'Installed Packages'! ! -!CodeWindow methodsFor: 'GUI building' stamp: 'pb 5/5/2019 18:24:20' prior: 16812980! - buildMorphicAnnotationsPane - - | aTextMorph | - aTextMorph _ (TextModelMorph - textProvider: model - textGetter: #annotation) emptyTextDisplayMessage: 'Class or method annotation (not selected?)'. - model when: #annotationChanged send: #refetch to: aTextMorph model. - model when: #decorateButtons send: #decorateButtons to: self. - aTextMorph - askBeforeDiscardingEdits: false; - hideScrollBarsIndefinitely. - ^aTextMorph! ! -!CodeWindow methodsFor: 'GUI building' stamp: 'pb 5/5/2019 18:40:52' prior: 16812994! - buildMorphicCodePane - "Construct the pane that shows the code. - Respect the Preference for standardCodeFont." - ^ (TextModelMorph - textProvider: model - textGetter: #acceptedContents - textSetter: #contents:notifying: - selectionGetter: #contentsSelection) emptyTextDisplayMessage: 'Smalltalk code (nothing selected?)'! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'pb 5/5/2019 18:07:59' prior: 50454342! - buildMorphicCommentPane - "Construct the pane that shows the class comment." - ^ (BrowserCommentTextMorph - textProvider: model - textGetter: #classCommentText - textSetter: #newClassComment:) emptyTextDisplayMessage: 'Please enter a comment for this class'.! ! -!MessageNamesWindow methodsFor: 'GUI building' stamp: 'pb 5/5/2019 18:07:23' prior: 50454498! - buildMorphicWindow - "Answer a morphic window with the given initial search string, nil if none" - -"MessageNames openMessageNames" - - | selectorListView firstRow searchButton secondRow | - textMorph _ (TextModelMorph - textProvider: model - textGetter: #searchString - textSetter: #searchString: - selectionGetter: #contentsSelection) emptyTextDisplayMessage: 'Type here, then hit Search'. - textMorph askBeforeDiscardingEdits: false. - textMorph acceptOnCR: true. - textMorph hideScrollBarsIndefinitely. - - searchButton _ PluggableButtonMorph new - model: textMorph textMorph; - label: 'Search'; - action: #acceptContents. - searchButton setBalloonText: 'Type some letters into the pane at right, and then press this Search button (or hit RETURN) and all method selectors that match what you typed will appear in the list pane below. Click on any one of them, and all the implementors of that selector will be shown in the right-hand pane, and you can view and edit their code without leaving this tool.'. - - firstRow _ LayoutMorph newRow. - firstRow color: self windowColor. - firstRow - doAdoptWidgetsColor; - addMorph: searchButton proportionalWidth: 0.25; - addMorph: textMorph proportionalWidth: 0.75. - - selectorListView _ PluggableListMorph - model: model - listGetter: #selectorList - indexGetter: #selectorListIndex - indexSetter: #selectorListIndex: - mainView: self - menuGetter: #selectorListMenu - keystrokeAction: #selectorListKey:from:. - secondRow _ LayoutMorph newRow. - secondRow - addMorph: selectorListView proportionalWidth: 0.5; - addAdjusterAndMorph: self buildMorphicMessageList proportionalWidth: 0.5. - - self layoutMorph - addMorph: firstRow fixedHeight: self defaultButtonPaneHeight+4; - addAdjusterAndMorph: secondRow proportionalHeight: 0.5; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.5. - model changed: #editSelection! ! -!ChangeListWindow methodsFor: 'GUI building' stamp: 'pb 5/5/2019 18:48:30' prior: 16797072! - buildMorphicCodePane - - ^(TextModelMorph - textProvider: model - textGetter: #acceptedContents) emptyTextDisplayMessage: 'Selection detail (no change selected?)'! ! -!DebuggerWindow methodsFor: 'GUI building' stamp: 'pb 5/5/2019 18:47:09' prior: 50391452! - buildMorphicWindow - "Open a full morphic debugger with the given label" - - | bottomMorph | - - stackList _ PluggableListMorph - model: model - listGetter: #contextStackList - indexGetter: #contextStackIndex - indexSetter: #toggleContextStackIndex: - mainView: self - menuGetter: #contextStackMenu - keystrokeAction: #contextStackKey:from:. - - receiverInspector _ PluggableListMorph - model: model receiverInspector - listGetter: #fieldList - indexGetter: #selectionIndex - indexSetter: #toggleIndex: - mainView: self - menuGetter: #receiverFieldListMenu - keystrokeAction: #inspectorKey:from:. - receiverInspector doubleClickSelector: #inspectSelection. - receiverInspectorText _ (TextModelMorph - textProvider: model receiverInspector - textGetter: #acceptedContents - textSetter: #accept: - selectionGetter: #contentsSelection) emptyTextDisplayMessage: 'Receiver scope'. - contextVariableInspector _ PluggableListMorph - model: model contextVariablesInspector - listGetter: #fieldList - indexGetter: #selectionIndex - indexSetter: #toggleIndex: - mainView: self - menuGetter: #contextFieldListMenu - keystrokeAction: #inspectorKey:from:. - contextVariableInspector doubleClickSelector: #inspectSelection. - contextVariableInspectorText _ (TextModelMorph - textProvider: model contextVariablesInspector - textGetter: #acceptedContents - textSetter: #accept: - selectionGetter: #contentsSelection) emptyTextDisplayMessage: 'Context scope'. - - bottomMorph _ LayoutMorph newRow. - bottomMorph - addMorph: receiverInspector proportionalWidth: 0.2; - addAdjusterAndMorph: receiverInspectorText proportionalWidth: 0.3; - addAdjusterAndMorph: contextVariableInspector proportionalWidth: 0.2; - addAdjusterAndMorph: contextVariableInspectorText proportionalWidth: 0.3. - - self layoutMorph - addMorph: stackList proportionalHeight: 0.25; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.55; - addAdjusterAndMorph: bottomMorph proportionalHeight: 0.2! ! -!InspectorWindow methodsFor: 'GUI building' stamp: 'pb 5/5/2019 18:44:07' prior: 50334402! - buildMorphicWindow - " Inspector openOn: SystemOrganization " - | contentsText list upperRow evaluatorText label | - "Build widgets. We'll assemble them below." - list _ PluggableListMorph - model: model - listGetter: #fieldList - indexGetter: #selectionIndex - indexSetter: #toggleIndex: - mainView: self - menuGetter: #fieldListMenu - keystrokeAction: #inspectorKey:from:. - list doubleClickSelector: #inspectSelection. - contentsText _ TextModelMorph - textProvider: model - textGetter: #acceptedContents - textSetter: #accept: - selectionGetter: #contentsSelection. - evaluatorText _ (TextModelMorph textProvider: model) - askBeforeDiscardingEdits: false; - emptyTextDisplayMessage: 'Smalltalk expression'. - "Upper row has two widgets, side by side: the list of variables at the left side, and the variable contents pane at the right side." - upperRow _ LayoutMorph newRow. - upperRow - addMorph: list proportionalWidth: 0.3; - addAdjusterAndMorph: contentsText proportionalWidth: 0.7. - "Inspector Window has two rows: At the top, the one we just bult. Below it, the evaluation pane." - self layoutMorph - addMorph: upperRow proportionalHeight: 0.7; - addAdjusterAndMorph: evaluatorText proportionalHeight: 0.3. - "Set label" - label _ [model object printStringLimitedTo: 64] - on: UnhandledError - do: [:ex | ex return: model object class printString, ' (printing failed)']. - (label includesSubString: model object class name) - ifFalse: [label _ model object class name, ': ', label]. - self setLabel: label! ! -!ObjectExplorerWindow methodsFor: 'GUI building' stamp: 'pb 5/5/2019 18:42:14' prior: 50334451! - buildMorphicWindow - - | textMorph | - listMorph _ HierarchicalListMorph - model: model - listGetter: #getList - indexGetter: #getCurrentSelection - indexSetter: #noteNewSelection: - mainView: self - menuGetter: #genericMenu - keystrokeAction: #explorerKey:from:. - listMorph autoDeselect: false. - listMorph doubleClickSelector: #inspectSelection. - textMorph _ ((TextModelMorph textProvider: model) - askBeforeDiscardingEdits: false; - emptyTextDisplayMessage: 'Smalltalk expression (self is selected item)'). - self layoutMorph - addMorph: listMorph proportionalHeight: 0.8; - addAdjusterAndMorph: textMorph proportionalHeight: 0.2. - self setLabel: (model rootObject printStringLimitedTo: 64)! ! -!ProcessBrowserWindow methodsFor: 'GUI building' stamp: 'pb 5/5/2019 18:41:54' prior: 16895306! - buildMorphicWindow - "Create a pluggable version of me, answer a window" - | aTextMorph list1 list2 upperRow | - list1 _ PluggableListMorph - model: model - listGetter: #processNameList - indexGetter: #processListIndex - indexSetter: #processListIndex: - mainView: self - menuGetter: #processListMenu - keystrokeAction: #processListKey:from:. - list2 _ PluggableListMorph - model: model - listGetter: #stackNameList - indexGetter: #stackListIndex - indexSetter: #stackListIndex: - mainView: self - menuGetter: #stackListMenu - keystrokeAction: #stackListKey:from:. - upperRow _ LayoutMorph newRow. - upperRow - addMorph: list1 proportionalWidth: 0.5; - addAdjusterAndMorph: list2 proportionalWidth: 0.5. - aTextMorph _ (TextModelMorph - textProvider: model - textGetter: #selectedMethod) emptyTextDisplayMessage: 'Method source (not selected?)'. - aTextMorph askBeforeDiscardingEdits: false. - self layoutMorph - addMorph: upperRow proportionalHeight: 0.5; - addAdjusterAndMorph: aTextMorph proportionalHeight: 0.5. - self setLabel: 'Process Browser'! ! -!TestRunnerWindow methodsFor: 'GUI building' stamp: 'pb 5/5/2019 18:32:14' prior: 16928498! - buildDetailsText - detailsText _ (TextModelMorph - textProvider: model - textGetter: #details) emptyTextDisplayMessage: 'Test run details (no results to display)'. - detailsText hideScrollBarsIndefinitely. - ^detailsText! ! -!TestRunnerWindow methodsFor: 'GUI building' stamp: 'pb 5/5/2019 18:33:10' prior: 16928566! - buildPassFailText - passFailText _ (TextModelMorph - textProvider: model - textGetter: #passFail) emptyTextDisplayMessage: 'Pass/Fail summary (no results to display)'. - passFailText hideScrollBarsIndefinitely. - ^ passFailText! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'pb 5/5/2019 18:39:46' prior: 50454417! - createTextPaneAcceptOnCR: acceptBoolean - "create the textPane" - | result | - self flag: #todo. - "Integrate this method with the Theme system. --cbr" - result _ (TextModelMorph - textProvider: self - textGetter: #response - textSetter: #response: - selectionGetter: #selectionInterval) emptyTextDisplayMessage: 'Enter response'. - self - valueOfProperty: #emptyTextDisplayMessage - ifPresentDo: [ :msg | - result emptyTextDisplayMessage: msg ]. - result - hasUnacceptedEdits: true; - acceptOnCR: acceptBoolean; - escAction: [ self cancelClicked ]; - morphExtent: `18 @ 5` * self sizeUnit. - self - addMorph: result - position: `1 @ 2` * self sizeUnit. - ^ result.! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3726-MoreEmptyMessages-PhilBellalouna-2019May05-17h58m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3725] on 5 May 2019 at 8:59:01 pm'! -!Scanner class methodsFor: 'doIt selectors' stamp: 'HAW 5/5/2019 19:22:41'! - selectionDoItSourceCodeHeaderSizeWithContext: hasContext - - ^(String streamContents: [ :stream | self selectionDoItSourceCodeHeaderWithContext: hasContext into: stream ]) size! ! -!Scanner class methodsFor: 'doIt selectors' stamp: 'HAW 5/5/2019 19:06:58'! - selectionDoItSourceCodeHeaderWithContext: hasContext into: stream - - "I use previousContext and not ThisContext as in the parser to avoid - name collision. Also, previousContext is more intention revealing - Hernan" - stream - nextPutAll: (hasContext ifTrue: [ Scanner doItInSelector, ' previousContext' ] ifFalse: [ Scanner doItSelector ]); - newLine; - newLine! ! -!Parser methodsFor: 'error correction' stamp: 'jmv 5/5/2019 20:54:13'! - correctSourceDelta - - | userSelectionDelta | - userSelectionDelta _ requestor selectionInterval ifEmpty: [0] ifNotEmpty: [ :userSelection | userSelection first-1 ]. - encoder selector = Scanner doItSelector ifTrue: [ - ^ (Scanner selectionDoItSourceCodeHeaderSizeWithContext: false) - userSelectionDelta ]. - encoder selector = Scanner doItInSelector ifTrue: [ - ^ (Scanner selectionDoItSourceCodeHeaderSizeWithContext: true) - userSelectionDelta ]. - - ^ 0! ! -!Parser methodsFor: 'error correction' stamp: 'HAW 5/5/2019 19:42:21' prior: 50451921! - correctSelector: proposedKeyword wordIntervals: aSpots exprInterval: expInt ifAbort: abortAction - "Correct the proposedKeyword to some selector symbol, correcting the original text if such action is indicated. abortAction is invoked if the proposedKeyword couldn't be converted into a valid selector. Spots is an ordered collection of intervals within the test stream of the for each of the keyword parts." - - | correctSelector userSelection delta adjustedSpots | - "If we can't ask the user, assume that the keyword will be defined later" - self interactive ifFalse: [^proposedKeyword asSymbol]. - - "If the requestor is of an exotic kind (like a telnet server) we might not be allowed to open a PupUpMenu for querying the user" - " - ((requestor isKindOf: Editor) or: [ requestor is: #Morph ]) - ifFalse: [ ^ proposedKeyword asSymbol ]. - " - - userSelection _ requestor selectionInterval. - - delta := self correctSourceDelta. - adjustedSpots := aSpots collect: [ :interval | interval first - delta to: interval last - delta ]. - requestor selectFrom: adjustedSpots first first to: adjustedSpots last last. - - correctSelector _ UnknownSelector name: proposedKeyword. - correctSelector ifNil: [^abortAction value]. - - requestor selectInvisiblyFrom: userSelection first to: userSelection last. - - self substituteSelector: correctSelector keywords wordIntervals: adjustedSpots. - ^(proposedKeyword last ~~ $: - and: [correctSelector last == $:]) - ifTrue: [abortAction value] - ifFalse: [correctSelector]! ! -!Parser methodsFor: 'error correction' stamp: 'HAW 5/5/2019 19:38:20' prior: 50452148! - correctVariable: proposedVariable interval: aSpot - "Correct the proposedVariable to a known variable, or declare it as a new - variable if such action is requested. We support declaring lowercase - variables as temps or inst-vars, and uppercase variables as Globals or - ClassVars, depending on whether the context is nil (class=UndefinedObject). - Spot is the interval within the test stream of the variable. - rr 3/4/2004 10:26 : adds the option to define a new class. " - - "Check if this is an i-var, that has been corrected already (ugly)" - - "Display the pop-up menu" - - | userSelection action delta spot | - (encoder classEncoding instVarNames includes: proposedVariable) ifTrue: [ - ^InstanceVariableNode new - name: proposedVariable - index: (encoder classEncoding allInstVarNames indexOf: proposedVariable)]. - - "First check to see if the requestor knows anything about the variable" - (requestor bindingOf: proposedVariable) - ifNotNil: [ :binding | ^ encoder global: binding name: proposedVariable]. - - "If we can't ask the user for correction, make it undeclared" - self interactive ifFalse: [^encoder undeclared: proposedVariable]. - - userSelection _ requestor selectionInterval. - delta _ self correctSourceDelta. - spot _ aSpot first - delta to: aSpot last - delta. - requestor selectFrom: spot first to: spot last. - - "Build the menu with alternatives" - action _ UndeclaredVariable - signalFor: self - name: proposedVariable - inRange: spot. - action ifNil: [^self fail]. - - "Execute the selected action" - requestor selectInvisiblyFrom: userSelection first to: userSelection last. - ^action value! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'HAW 5/5/2019 19:34:47' prior: 50444983! - selectionDoItSourceCodeIn: evalContext - - ^String streamContents: [ :stream | - Scanner selectionDoItSourceCodeHeaderWithContext: evalContext notNil into: stream. - stream nextPutAll: self selectionAsStream upToEnd ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3727-VariableAndSelectorCorrectionFix-HernanWilkinson-JuanVuletich-2019May05-20h57m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3707] on 3 May 2019 at 6:47:45 pm'! - -Object subclass: #FontChanger - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-GUI'! - -!classDefinition: #FontChanger category: #'Tools-GUI'! -Object subclass: #FontChanger - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-GUI'! -!FontChanger class methodsFor: 'prompting user' stamp: 'EB 5/3/2019 17:16:14'! - promptUser - "Present a menu of available font families, and if one is chosen, change to it." - self promptUserWithFamilies: AbstractFont familyNames.! ! -!FontChanger class methodsFor: 'prompting user' stamp: 'EB 5/3/2019 18:11:14'! - promptUserAndInstallIfNecessaryWithFamilies: fontFamilies - " - Present a menu of available font families, and if one is chosen, - install it if necessary, and change to it. - " - self promptUserWithFamilies: fontFamilies withMessageOnSelection: #changeToAndInstallIfNecessary:! ! -!FontChanger class methodsFor: 'prompting user' stamp: 'EB 5/3/2019 18:11:30'! - promptUserWithFamilies: fontFamilies - "Present a menu of font families, and if one is chosen, change to it." - self promptUserWithFamilies: fontFamilies withMessageOnSelection: #changeTo:! ! -!FontChanger class methodsFor: 'prompting user' stamp: 'EB 5/3/2019 18:11:03'! - promptUserWithFamilies: fontFamilies withMessageOnSelection: aMessageSymbol - " - Present a menu of available font families, and if one is chosen, - send aMessageSymbol to self with the corresponding font family as argument. - " - | fontMenu priorFontFamily | - priorFontFamily _ Preferences defaultFontFamily. - fontMenu _ MenuMorph new defaultTarget: self. - fontFamilies do: [:fontName | - | isCurrent label | - isCurrent _ priorFontFamily sameAs: fontName. - label _ self toSelectableMenuLabel: fontName isCurrent: isCurrent. - fontMenu - add: label - target: self - action: aMessageSymbol - argument: fontName. - ]. - fontMenu invokeModal.! ! -!FontChanger class methodsFor: 'changing font' stamp: 'EB 5/3/2019 18:13:51'! - changeToAndInstallIfNecessary: aFontName - "install the font if necessary, and change to it on the whole system without changing point sizes." - self installFontIfNecessary: aFontName. - self changeTo: aFontName. -! ! -!FontChanger class methodsFor: 'changing font' stamp: 'EB 5/3/2019 18:13:38'! - installFontIfNecessary: aFontName - | isFontInstalled | - isFontInstalled _ AbstractFont availableFonts includesKey: aFontName. - isFontInstalled ifFalse: [StrikeFont install: aFontName.].! ! -!FontChanger class methodsFor: 'private' stamp: 'EB 5/3/2019 17:58:16'! - toSelectableMenuLabel: aString isCurrent: isCurrent - | label | - isCurrent ifTrue: [label _ ''] ifFalse: [label _ '']. - ^label, aString! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'EB 5/3/2019 18:44:00' prior: 50435513! - preferencesMenu - "Build the preferences menu for the world." - - ^ (self menu: 'Preferences...') - addItemsFromDictionaries: `{ - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Font Sizes...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Set font...'. - #object -> FontChanger. - #selector -> #promptUserAndInstallIfNecessaryWithFamilies:. - #arguments -> #(('DejaVu' 'DejaVu Sans Mono')). - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'change the current font family.' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }`! ! -!FontChanger class methodsFor: 'changing font' stamp: 'EB 5/3/2019 16:29:08'! - changeTo: aFontName - "Change the font on the whole system without changing point sizes." - Preferences setDefaultFontFamilyTo: aFontName. - Preferences - setDefaultFont: Preferences defaultFontFamily - spec: { - {#setSystemFontTo:. AbstractFont default pointSize}. - {#setListFontTo:. Preferences standardListFont pointSize.}. - {#setMenuFontTo:. Preferences standardMenuFont pointSize.}. - {#setWindowTitleFontTo:. Preferences windowTitleFont pointSize.}. - {#setCodeFontTo:. Preferences standardCodeFont pointSize.}. - {#setButtonFontTo:. Preferences standardButtonFont pointSize.}. - }. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]. - -! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3728-FontChanger-EricBrandwein-2019Apr24-23h47m-EB.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3720] on 6 May 2019 at 9:49:09 am'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 5/6/2019 09:48:47' prior: 50447192! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('AY' 'Angel Yan') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('bgs' 'Boris G. Shingarov') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('EB' 'Eric Brandwein') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('FGJ' 'Fernando Gasperi Jabalera') - #('FJG' 'Facundo Javier Gelatti') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('KLG' 'Gerald Klix') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MM' 'Mariano Montone') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('pmon' 'Paolo Montrasi') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('SLD' 'Steve Davies') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3729-AddEricAsKnownAuthor-JuanVuletich-2019May06-09h48m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3729] on 8 May 2019 at 9:12:09 am'! -!InputSensor class methodsFor: 'constants' stamp: 'jmv 5/8/2019 08:48:48'! - cmdAltOptionCtrlShiftModifierKeys - "Include all of them" - ^ 16r78 "cmd | opt | ctrl | shft "! ! -!Preferences class methodsFor: 'standard queries' stamp: 'jmv 5/8/2019 08:15:39' prior: 50374424! - ctrlArrowsScrollHorizontally - "Enables / disables Ctrl-ArrowKeys horizontal scroll. - By default it is false, to enable ctrl-leftArrow and ctrl-rightArrow to move cursor word by word in text editors." - ^ self - valueOfFlag: #ctrlArrowsScrollHorizontally - ifAbsent: [ false ]! ! -!HierarchicalListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/1/2019 12:55:36' prior: 50455304! - arrowKey: aKeyboardEvent - - "Handle a keyboard navigation event. Answer nil if not handled." - aKeyboardEvent isArrowUp ifTrue: [ ^ self navigateUp ]. - aKeyboardEvent isArrowDown ifTrue: [ ^ self navigateDown ]. - aKeyboardEvent isArrowLeft ifTrue: [ ^ self navigateLeft ]. - aKeyboardEvent isArrowRight ifTrue: [ ^ self navigateRight ]. - aKeyboardEvent isHome ifTrue: [ ^ self navigateToTop ]. - aKeyboardEvent isEnd ifTrue: [ ^ self navigateToBottom ]. - aKeyboardEvent isPageUp ifTrue: [ ^ self navigateOnePageUp ]. - aKeyboardEvent isPageDown ifTrue: [ ^ self navigateOnePageDown ]. - ^ nil! ! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'jmv 5/8/2019 09:09:27' prior: 50455330! - arrowKey: aKeyboardEvent - - "Handle a keyboard navigation event. Answer nil if not handled." - aKeyboardEvent isArrowUp ifTrue: [ ^ self navigateUp ]. - aKeyboardEvent isArrowDown ifTrue: [ ^ self navigateDown ]. - aKeyboardEvent isArrowLeft ifTrue: [ ^ self navigateLeft ]. - aKeyboardEvent isArrowRight ifTrue: [ ^ self navigateRight ]. - aKeyboardEvent isHome ifTrue: [ ^ self navigateToTop ]. - aKeyboardEvent isEnd ifTrue: [ ^ self navigateToBottom ]. - aKeyboardEvent isPageUp ifTrue: [ ^ self navigateOnePageUp ]. - aKeyboardEvent isPageDown ifTrue: [ ^ self navigateOnePageDown ]. - ^ nil! ! -!HandMorph methodsFor: 'private events' stamp: 'jmv 5/8/2019 09:03:50' prior: 50423773! - generateKeyboardEvent: evtBuf - "Generate the appropriate mouse event for the given raw event buffer" - | buttons modifiers type keyValue pressType stamp mouseScrollDirection | - stamp _ evtBuf second. - stamp = 0 ifTrue: [ stamp _ Time localMillisecondClock ]. - (evtBuf sixth <= 0 or: [ (keyValue _ Character iso8859s15CodeForUnicodeCodePoint: evtBuf sixth) isNil ]) ifTrue: [ keyValue _ Character macRomanToLatin1: evtBuf third ]. - Sensor peekEvent ifNotNil: [ :nxt | - "start: Combining diacritical marks (i.e. accents in the Linux VM)" - (nxt fourth = EventSensor eventKeyDown and: [ nxt third > 255 ]) ifTrue: [ - keyValue _ ((Character numericValue: keyValue) withDiacriticalMark: nxt third) iso8859s15Code. - Sensor - nextEvent; - nextEvent; - nextEvent ]. - "end: Combining diacritical marks (i.e. accents in the Linux VM)" - "start: Spurious LF after CR on Ctrl-Enter on Windows VM" - ((evtBuf fourth = EventSensor eventKeyChar and: [ evtBuf third = 13 ]) and: [ - nxt fourth = EventSensor eventKeyChar and: [ nxt third = 10 ]]) ifTrue: [ Sensor nextEvent - "print " ]]. - modifiers _ evtBuf fifth. - pressType _ evtBuf fourth. - pressType = EventSensor eventKeyDown ifTrue: [ - type _ #keyDown. - lastKeyDownValue _ keyValue ]. - pressType = EventSensor eventKeyUp ifTrue: [ - (keyValue = 9 and: [(modifiers anyMask: 1) and: [Smalltalk platformName = 'unix']]) - ifTrue: [ - "Linux VMs don't generate shift-tab keystroke. Turn #keyUp into #keystroke" - pressType _ EventSensor eventKeyChar ] - ifFalse: [type _ #keyUp ]]. - pressType = EventSensor eventKeyChar ifTrue: [ - type _ #keystroke. - "If Control key pressed, and the VM answers a code below 27, - it means it did the translation, convert it back to regular character: - We want to handle the meaning of ctrl ourselves." - (modifiers anyMask: 2) ifTrue: [ - "Control key pressed" - keyValue < 27 ifTrue: [ - "But we don't want to do it for Home/End/PgUp/PgDn, just for alphabetic keys" - lastKeyDownValue = keyValue ifFalse: [ - "If equal, real Home/End/PgUp/PgDn in Windows => don't translate" - (keyValue + 64 = lastKeyDownValue or: [ "If Equal, Ctrl-alphabetic in Windows => do translate" - lastKeyDownValue < 47 ]) ifTrue: [ - "Not on windows. If less (not sure about the bound, but do not translate 48: tab on Mac), alphabetic on Mac => do translate" - keyValue _ (modifiers anyMask: 1) - ifTrue: [ keyValue + 64 ] - ifFalse: [ keyValue + 96 - "shift not pressed: conver to lowercase letter" ]]]]. - "Act as if command/alt was pressed for some usual Windows ctrl-key combinations" - (self shouldControlEmulateAltFor: keyValue) ifTrue: [ modifiers _ modifiers bitOr: 8 ]]]. - buttons _ modifiers bitShift: 3. - "Linux and Windows VM send keyboard ctrl-upArrow and ctrl-downArrow when the user tries to scroll using the mouse wheel - Mac VM sends cmd-option-ctrl-shift-upArrow and cmd-option-ctrl-shift-downArrow for trackpad vertical scroll gestures, - and cmd-option-ctrl-shift-leftArrow and cmd-option-ctrl-shift-rightArrow for horizontal scroll gestures. - This way of reporting scroll events by the VM also enables scrolling using the keyboard (actually, we can't tell if user gesture was on Mouse, Trackpad or Keyboard). - But ctrl-shift and cmdAlt-shift are needed used for selecting while moving by word, line, etc. - Additionally, #ctrlArrowsScrollHorizontally allows chosing between keyboard horizontal scroll and moving word by word in text editors." - mouseScrollDirection _ nil. - "Ctrl for Keyboard or Mouse wheel gestures. All modifiers for Trackpad gestures." - (buttons = InputSensor controlKey or: [buttons = InputSensor cmdAltOptionCtrlShiftModifierKeys]) ifTrue: [ - keyValue = 30 - ifTrue: [mouseScrollDirection _ #up] - ifFalse: [keyValue = 31 - ifTrue: [mouseScrollDirection _ #down]]]. - "Ctrl for Keyboard or Mouse wheel gestures, only if preference is set. All modifiers for Trackpad gestures." - ((buttons = InputSensor controlKey and: [Preferences ctrlArrowsScrollHorizontally]) or: [buttons = InputSensor cmdAltOptionCtrlShiftModifierKeys]) ifTrue: [ - keyValue = 28 - ifTrue: [mouseScrollDirection _ #left] - ifFalse: [keyValue = 29 - ifTrue: [mouseScrollDirection _ #right]]]. - mouseScrollDirection ifNotNil: [ - ^ MouseScrollEvent new - setType: #mouseScroll - position: self morphPosition - direction: mouseScrollDirection - buttons: buttons - hand: self - stamp: stamp ]. - ^ KeyboardEvent new - setType: type - buttons: buttons - position: self morphPosition - keyValue: keyValue - hand: self - stamp: stamp! ! - -TextEditor removeSelector: #scrollBy:! - -TextEditor removeSelector: #scrollBy:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3730-CorrectHandlingOfTrackpadScrollEvents-JuanVuletich-2019May08-09h06m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3725] on 5 May 2019 at 10:54:32 am'! - -Object subclass: #FontFamily - instanceVariableNames: 'familyName baseFontBySizes' - classVariableNames: 'AvailableFamilies DefaultFamilyName DefaultPointSize' - poolDictionaries: '' - category: 'Graphics-Text'! - -!classDefinition: #FontFamily category: #'Graphics-Text'! -Object subclass: #FontFamily - instanceVariableNames: 'familyName baseFontBySizes' - classVariableNames: 'AvailableFamilies DefaultFamilyName DefaultPointSize' - poolDictionaries: '' - category: 'Graphics-Text'! -!FontFamily commentStamp: '' prior: 0! - Also called Typeface.! - -FontFamily subclass: #StrikeFontFamily - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Text'! - -!classDefinition: #StrikeFontFamily category: #'Graphics-Text'! -FontFamily subclass: #StrikeFontFamily - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Text'! -!FontFamily methodsFor: 'initialization' stamp: 'jmv 5/5/2019 10:33:56'! - atPointSize: aNumber - ^baseFontBySizes at: aNumber ifAbsent: nil! ! -!FontFamily methodsFor: 'initialization' stamp: 'jmv 5/4/2019 16:11:02'! - atPointSize: aNumber put: aFontAndSize - "aFontAndSize must have emphasis = 0, i.e. it is a base font" - baseFontBySizes at: aNumber put: aFontAndSize ! ! -!FontFamily methodsFor: 'initialization' stamp: 'jmv 5/4/2019 16:00:18'! - familyName: aString - familyName _ aString. - baseFontBySizes _ Dictionary new! ! -!FontFamily methodsFor: 'accessing' stamp: 'jmv 5/4/2019 16:09:26'! - familyName - ^ familyName! ! -!FontFamily class methodsFor: 'accessing' stamp: 'jmv 5/5/2019 10:54:03'! - familyNames - " - FontFamily familyNames - " - ^AvailableFamilies keys sort! ! -!FontFamily class methodsFor: 'initialization' stamp: 'jmv 5/5/2019 10:54:06'! - initialize - " - FontFamily initialize - " - (AvailableFamilies isNil and: [AbstractFont availableFonts notNil]) ifTrue: [ - self migrate ]! ! -!FontFamily class methodsFor: 'initialization' stamp: 'jmv 5/5/2019 10:54:12'! - migrate - " - FontFamily migrate - " - | family def strikeFontAndSize | - AvailableFamilies _ Dictionary new. - def _ AbstractFont default. - - AbstractFont familyNames do: [ :familyName | - family _ StrikeFontFamily new. - family familyName: familyName. - (AbstractFont pointSizesFor: familyName) do: [ :ps | - strikeFontAndSize _ AbstractFont familyName: familyName pointSize: ps. - family atPointSize: ps put: strikeFontAndSize. - def == strikeFontAndSize ifTrue: [ - DefaultFamilyName _ family familyName. - DefaultPointSize _ ps ]]. - AvailableFamilies at: family familyName put: family ].! ! -!FontFamily class methodsFor: 'accessing fonts' stamp: 'jmv 5/5/2019 10:54:00'! - defaultFamilyPointSize: aNumber - " - FontFamily defaultFamilyPointSize: 12 - " - | family | - family _ AvailableFamilies at: DefaultFamilyName. - ^family atPointSize: aNumber! ! -!FontFamily class methodsFor: 'accessing fonts' stamp: 'jmv 5/5/2019 10:54:08'! - familyName: aString pointSize: aNumber - " - FontFamily familyName: 'DejaVu' pointSize: 12 - " - | family | - family _ AvailableFamilies at: aString ifAbsent: [^nil]. - ^family atPointSize: aNumber! ! - -FontFamily initialize! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3731-FontFamily-JuanVuletich-2019May05-10h53m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3726] on 5 May 2019 at 11:12:11 am'! -!FontFamily methodsFor: 'accessing' stamp: 'jmv 5/5/2019 11:03:44'! - aroundPointSize: aNumber - ^baseFontBySizes at: aNumber ifAbsent: [ |found | - found _ nil. - baseFontBySizes do: [ :font | - (found isNil or: [ (found pointSize - aNumber) abs > (font pointSize - aNumber) abs ]) - ifTrue: [ found _ font ]]. - found - ]! ! -!FontFamily methodsFor: 'accessing' stamp: 'jmv 5/5/2019 11:08:04'! - pointSizes - ^baseFontBySizes keys sort! ! -!FontFamily class methodsFor: 'accessing fonts' stamp: 'jmv 5/5/2019 11:10:37'! - defaultFamilyAndPointSize - " - FontFamily defaultFamilyAndPointSize - " - | family | - family _ AvailableFamilies at: DefaultFamilyName. - ^family atPointSize: DefaultPointSize ! ! -!FontFamily class methodsFor: 'accessing fonts' stamp: 'jmv 5/5/2019 11:04:13'! -familyName: aString aroundPointSize: aNumber - " - FontFamily familyName: 'DejaVu' aroundPointSize: 120 - " - | family | - family _ AvailableFamilies at: aString ifAbsent: [^nil]. - ^family aroundPointSize: aNumber! ! -!FontFamily class methodsFor: 'accessing fonts' stamp: 'jmv 5/5/2019 11:08:33'! - pointSizesFor: aString - " - FontFamily pointSizesFor: 'DejaVu' - " - | family | - family _ AvailableFamilies at: aString ifAbsent: [^nil]. - ^family pointSizes! ! -!SystemDictionary methodsFor: 'shrinking' stamp: 'jmv 5/5/2019 11:09:34' prior: 50391896! - reduceCuis - " - Smalltalk reduceCuis - " - | keep n unused newDicts oldDicts | - - self nominallyUnsent: #reduceCuis. - - "Remove icons" - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - PasteUpMorph allInstancesDo: [ :w | - w backgroundImageData: nil. - w submorphsDo: [ :a | a delete ]]. - Preferences useNoMenuIcons. - Theme current initialize. - Theme content: nil. - Color shutDown. - BitBltCanvas releaseClassCachedState. - - Transcript clear. - Clipboard default initialize. - - - "Remove some methods, even if they have senders." - Utilities removeSelector: #vmStatisticsReportString. - SystemDictionary removeSelector: #recreateSpecialObjectsArray. - - StrikeFont saveSpace. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - - keep := OrderedCollection new. - keep addAll: #(SpaceTally). - AppLauncher appGlobalName ifNotNil: [ :any | - keep add: any ]. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - [ - #hereWeGo print. - unused do: [:c | - c print. - (Smalltalk at: c) removeFromSystem]. - n := Smalltalk removeAllUnSentMessages. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - n > 0 or: [ - unused notEmpty ]] whileTrue. - ChangeSet zapAllChangeSets. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - Symbol rehash. - - "Shrink method dictionaries." - Smalltalk garbageCollect. - oldDicts _ MethodDictionary allInstances. - newDicts _ Array new: oldDicts size. - oldDicts withIndexDo: [:d :index | - newDicts at: index put: d rehashWithoutBecome ]. - oldDicts elementsExchangeIdentityWith: newDicts. - oldDicts _ newDicts _ nil. - - SmalltalkCompleter initialize . - - "Sanity checks" -" Undeclared - Smalltalk cleanOutUndeclared - Smalltalk browseUndeclaredReferences - Smalltalk obsoleteClasses - Smalltalk obsoleteBehaviors - Smalltalk browseObsoleteMethodReferences - SmalltalkImage current fixObsoleteReferences - Smalltalk browseAllUnimplementedCalls"! ! -!AbstractFont class methodsFor: 'instance accessing' stamp: 'jmv 5/5/2019 11:11:03' prior: 16777387! - default - " - Compatibility. - AbstractFont default - " - false ifTrue: [ self deprecatedMethod ]. "Too much senders to activate warnings right now!!" - ^FontFamily defaultFamilyAndPointSize! ! -!AbstractFont class methodsFor: 'instance accessing' stamp: 'jmv 5/5/2019 11:04:58' prior: 50372336! - familyName: aString aroundPointSize: aNumber - " - Compatibility. - AbstractFont familyName: Preferences defaultFontFamily aroundPointSize: 120 - " - false ifTrue: [ self deprecatedMethod ]. "Too much senders to activate warnings right now!!" - ^FontFamily familyName: aString aroundPointSize: aNumber! ! -!AbstractFont class methodsFor: 'instance accessing' stamp: 'jmv 5/5/2019 11:01:15' prior: 50372353! - familyName: aString pointSize: aNumber - " - Compatibility. - AbstractFont familyName: Preferences defaultFontFamily pointSize: 12 - " - false ifTrue: [ self deprecatedMethod ]. "Too much senders to activate warnings right now!!" - ^FontFamily familyName: aString pointSize: aNumber! ! -!AbstractFont class methodsFor: 'instance accessing' stamp: 'jmv 5/5/2019 11:06:50' prior: 16777421! - familyNames - " - Compatibility. - AbstractFont familyNames - " - false ifTrue: [ self deprecatedMethod ]. "Too much senders to activate warnings right now!!" - ^FontFamily familyNames! ! -!AbstractFont class methodsFor: 'instance accessing' stamp: 'jmv 5/5/2019 11:09:11' prior: 50372364! - pointSizesFor: aString - " - Compatibility. - AbstractFont pointSizesFor: Preferences defaultFontFamily - " - false ifTrue: [ self deprecatedMethod ]. "Too much senders to activate warnings right now!!" - ^FontFamily pointSizesFor: aString! ! -!FontFamily methodsFor: 'accessing' stamp: 'jmv 5/5/2019 10:33:56' prior: 50456802! - atPointSize: aNumber - ^baseFontBySizes at: aNumber ifAbsent: nil! ! - -StrikeFont class removeSelector: #removeForPDA! - -StrikeFont class removeSelector: #removeForPDA! - -StrikeFont class removeSelector: #removeMostFonts! - -StrikeFont class removeSelector: #removeMostFonts! - -StrikeFont class removeSelector: #removeSomeFonts! - -StrikeFont class removeSelector: #removeSomeFonts! - -AbstractFont class removeSelector: #initialize! - -AbstractFont class removeSelector: #initialize! - -AbstractFont initialize! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3732-FontStateInFontFamily-JuanVuletich-2019May05-11h01m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3727] on 5 May 2019 at 2:40:12 pm'! -!FontFamily class methodsFor: 'initialization' stamp: 'jmv 5/5/2019 14:33:28'! - defaultFamilyName: aString - DefaultFamilyName _ aString! ! -!FontFamily class methodsFor: 'initialization' stamp: 'jmv 5/5/2019 14:33:45'! - defaultPointSize: aNumber - DefaultPointSize _ aNumber! ! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 5/5/2019 14:34:40' prior: 16892991! - setSystemFontTo: aFont - "Establish the default text font and style" - - aFont ifNil: [^ self]. - FontFamily defaultFamilyName: aFont familyName. - FontFamily defaultPointSize: aFont pointSize.! ! - -AbstractFont class removeSelector: #default:! - -AbstractFont class removeSelector: #default:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3733-AbstractFontStateRemoval1-JuanVuletich-2019May05-14h33m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3728] on 5 May 2019 at 4:11:41 pm'! -!FontFamily class methodsFor: 'accessing' stamp: 'jmv 5/5/2019 14:58:07'! - defaultFamilyName - ^ DefaultFamilyName! ! -!FontFamily class methodsFor: 'initialization' stamp: 'jmv 5/5/2019 14:46:11'! - addFamily: aFontFamily - AvailableFamilies at: aFontFamily familyName put: aFontFamily! ! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 5/5/2019 15:04:20' prior: 50372187! - restoreDefaultFonts - "Since this is called from menus, we can take the opportunity to prompt for missing font styles. - Preferences restoreDefaultFonts - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 9) - (setListFontTo: 9) - (setMenuFontTo: 10) - (setWindowTitleFontTo: 12) - (setCodeFontTo: 9) - (setButtonFontTo: 9))! ! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 5/5/2019 15:05:14' prior: 50435938! - setDefaultFont: fontFamilyName spec: defaultFontsSpec - - | font | - defaultFontsSpec do: [ :triplet | - font _ FontFamily familyName: fontFamilyName pointSize: triplet second. - font ifNil: [ - StrikeFont install: FontFamily defaultFamilyName. - font _ FontFamily familyName: fontFamilyName pointSize: triplet second ]. - font ifNil: [ font _ FontFamily defaultFamilyAndPointSize ]. - triplet size > 2 ifTrue: [ - font _ font emphasized: triplet third ]. - self - perform: triplet first - with: font]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/5/2019 15:03:07' prior: 50437054! - defaultFont05 - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences defaultFont05 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 7) - (setListFontTo: 5) - (setMenuFontTo: 5) - (setWindowTitleFontTo: 7) - (setCodeFontTo: 5) - (setButtonFontTo: 5)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/5/2019 15:03:11' prior: 50437072! - defaultFont06 - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences defaultFont06 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 7) - (setListFontTo: 6) - (setMenuFontTo: 6) - (setWindowTitleFontTo: 8) - (setCodeFontTo: 6) - (setButtonFontTo: 6)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/5/2019 15:03:14' prior: 50437090! - defaultFont07 - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences defaultFont07 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 8) - (setListFontTo: 7) - (setMenuFontTo: 7) - (setWindowTitleFontTo: 9) - (setCodeFontTo: 7) - (setButtonFontTo: 7)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/5/2019 15:03:18' prior: 50437108! - defaultFont08 - "Sets not only fonts but other GUI elements - to fit low resolution or small screens - Preferences defaultFont08 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 8) - (setListFontTo: 8) - (setMenuFontTo: 8) - (setWindowTitleFontTo: 11) - (setCodeFontTo: 8) - (setButtonFontTo: 8)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/5/2019 15:03:22' prior: 50437126! - defaultFont09 - "Sets not only fonts but other GUI elements - to fit low resolution or small screens - Preferences defaultFont09 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 9) - (setListFontTo: 9) - (setMenuFontTo: 10) - (setWindowTitleFontTo: 12) - (setCodeFontTo: 9) - (setButtonFontTo: 9)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/5/2019 15:03:28' prior: 50437144! - defaultFont10 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont10 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 10) - (setListFontTo: 10) - (setMenuFontTo: 11) - (setWindowTitleFontTo: 12) - (setCodeFontTo: 10) - (setButtonFontTo: 10)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/5/2019 15:03:34' prior: 50449661! - defaultFont11 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont11 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 11) - (setListFontTo: 11) - (setMenuFontTo: 12) - (setWindowTitleFontTo: 14) - (setCodeFontTo: 11) - (setButtonFontTo: 11)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/5/2019 15:03:37' prior: 50449680! - defaultFont12 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont12 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 12) - (setListFontTo: 12) - (setMenuFontTo: 12) - (setWindowTitleFontTo: 14) - (setCodeFontTo: 12) - (setButtonFontTo: 12)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/5/2019 15:03:42' prior: 50449699! - defaultFont14 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont14 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 14) - (setListFontTo: 14) - (setMenuFontTo: 14) - (setWindowTitleFontTo: 17) - (setCodeFontTo: 14) - (setButtonFontTo: 14)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/5/2019 15:03:48' prior: 50435284! - defaultFont17 - "Sets not only fonts but other GUI elements - to fit high resolution or large screens - Preferences defaultFont17 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 17) - (setListFontTo: 17) - (setMenuFontTo: 17) - (setWindowTitleFontTo: 22) - (setCodeFontTo: 17) - (setButtonFontTo: 17)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/5/2019 15:03:51' prior: 50435302! -defaultFont22 - "Sets not only fonts but other GUI elements - to fit high resolution or large screens - Preferences defaultFont22 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 22) - (setListFontTo: 22) - (setMenuFontTo: 22) - (setWindowTitleFontTo: 28) - (setCodeFontTo: 22) - (setButtonFontTo: 22)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/5/2019 15:03:56' prior: 50435320! -defaultFont28 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont28 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 28) - (setListFontTo: 28) - (setMenuFontTo: 28) - (setWindowTitleFontTo: 36) - (setCodeFontTo: 28) - (setButtonFontTo: 28)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/5/2019 15:04:00' prior: 50435338! - defaultFont36 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont36 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 36) - (setListFontTo: 36) - (setMenuFontTo: 36) - (setWindowTitleFontTo: 46) - (setCodeFontTo: 36) - (setButtonFontTo: 36)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/5/2019 15:04:06' prior: 50435356! - defaultFont46 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont46 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 46) - (setListFontTo: 46) - (setMenuFontTo: 46) - (setWindowTitleFontTo: 60) - (setCodeFontTo: 46) - (setButtonFontTo: 46)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/5/2019 15:04:10' prior: 50435374! - defaultFont60 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont60 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 60) - (setListFontTo: 60) - (setMenuFontTo: 60) - (setWindowTitleFontTo: 80) - (setCodeFontTo: 60) - (setButtonFontTo: 60)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 5/5/2019 15:04:14' prior: 50435410! - defaultFont80 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont80 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setSystemFontTo: 80) - (setListFontTo: 80) - (setMenuFontTo: 80) - (setWindowTitleFontTo: 80) - (setCodeFontTo: 80) - (setButtonFontTo: 80)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!AbstractFont methodsFor: 'displaying' stamp: 'jmv 5/5/2019 14:58:54' prior: 50372314! - on: aGrafPort displayString: aString from: firstIndex to: lastIndex at: p color: color - "Answer last affected pixel position - Answer nil if nothing was done" - - | char fallbackFont x y answer | - fallbackFont _ (FontFamily - familyName: FontFamily defaultFamilyName - aroundPointSize: self pointSize*0.9) - emphasized: self emphasis. - x _ p x. - y _ p y. - firstIndex to: lastIndex do: [ :i | - char _ aString at: i. - answer _ aGrafPort displayString: char asString from: 1 to: 1 at: x@y strikeFont: fallbackFont color: color. - x _ x + (self widthOf: char) ]. - ^answer! ! -!StrikeFont methodsFor: 'synthetic derivatives' stamp: 'jmv 5/5/2019 15:05:35' prior: 50372434! - syntheticSubscript - "Build and answer a derivative that is Subscript." - - | derivative | - derivative _ ((FontFamily familyName: FontFamily defaultFamilyName aroundPointSize: pointSize * 0.58) - emphasized: emphasis) - copy. - derivative useShortUnderscore. - ^ derivative - -" -StrikeFont allInstances do: [ :a | a reset ]. -('Hi ', (Text string: 'there' attribute: TextEmphasis superscript), ' how ', (Text string: 'are' attribute: TextEmphasis subscript), ' you?') edit. - -que todos, menos estos, tengan superscript y subscript en cero. Y en estos, apropiado. y en 'aca' usarlo. y listo -"! ! -!StrikeFont methodsFor: 'synthetic derivatives' stamp: 'jmv 5/5/2019 15:05:40' prior: 50372456! - syntheticSuperscript - "Build and answer a derivative that is Superscript." - - | derivative | - derivative _ ((FontFamily familyName: FontFamily defaultFamilyName aroundPointSize: pointSize * 0.58) - emphasized: emphasis) - copy. - derivative name: self name , 'Sup'. - ^ derivative - -" -StrikeFont allInstances do: [ :a | a reset ]. -('Hi ', (Text string: 'there' attribute: TextEmphasis superscript), ' how ', (Text string: 'are' attribute: TextEmphasis subscript), ' you?') edit. -"! ! -!StrikeFont class methodsFor: 'instance creation' stamp: 'jmv 5/5/2019 16:01:49' prior: 50437232! - install: aString -" -StrikeFont install: 'DejaVu'. -" -" -StrikeFont install: 'DejaVu Sans Mono'. -FontFamily defaultFamilyName: 'DejaVu Sans Mono'. -Preferences bigFonts. -Character initialize. -" -" -StrikeFont install: 'DejaVu Sans'. -StrikeFont buildLargerPunctuation: 'DejaVu Sans'. -FontFamily defaultFamilyName: 'DejaVu Sans'. -Preferences standardFonts. -Character initialize. -" -" -StrikeFont install: 'Inconsolata' -StrikeFont install: '#PilGi' -StrikeFont install: 'Optima' -StrikeFont install: 'Herculanum' -StrikeFont install: 'Papyrus' -StrikeFont install: 'Handwriting - Dakota' -StrikeFont install: 'Times New Roman' -StrikeFont install: 'Apple Chancery' -StrikeFont install: 'Cochin' -StrikeFont install: 'Cracked' -StrikeFont install: 'Zapfino' -StrikeFont install: 'Brush Script MT' -StrikeFont install: 'Chalkboard' -" - | family | - family _ nil. - 1 to: 200 do: [ :s | - (self create: aString size: s bold: true italic: true boldItalic: false) ifNotNil: [ :font | - font print. - family ifNil: [ - family _ StrikeFontFamily new. - family familyName: aString.]. - family atPointSize: s put: font ]]. - family ifNotNil: [ - FontFamily addFamily: family ]! ! -!FontFamily class methodsFor: 'initialization' stamp: 'jmv 5/5/2019 15:13:29' prior: 50456836! - migrate - " - FontFamily migrate - " - | family def strikeFont | - AvailableFamilies _ Dictionary new. - def _ AbstractFont default. - - AbstractFont familyNames do: [ :familyName | - family _ StrikeFontFamily new. - family familyName: familyName. - (AbstractFont pointSizesFor: familyName) do: [ :ps | - strikeFont _ AbstractFont familyName: familyName pointSize: ps. - family atPointSize: ps put: strikeFont. - def == strikeFont ifTrue: [ - DefaultFamilyName _ family familyName. - DefaultPointSize _ ps ]]. - AvailableFamilies at: family familyName put: family ].! ! -!UpdatingStringMorph class methodsFor: 'new-morph participation' stamp: 'jmv 5/5/2019 15:05:46' prior: 50372709! - initializedInstance - "Answer a digital clock" - - | newInst | - newInst := self - contents: '' - font: (AbstractFont familyName: FontFamily defaultFamilyName pointSize: 22) - emphasis: AbstractFont boldCode. - newInst - stepTime: 500; "half a second" - target: [String streamContents: [ :strm | DateAndTime now printHMSOn: strm]] ; - getSelector: #value. - - ^ newInst! ! - -Preferences class removeSelector: #defaultFontFamily! - -Preferences class removeSelector: #defaultFontFamily! - -Preferences class removeSelector: #setDefaultFontFamilyTo:! - -Preferences class removeSelector: #setDefaultFontFamilyTo:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3734-AbstractFontStateRemoval2-JuanVuletich-2019May05-16h10m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3729] on 5 May 2019 at 4:21:34 pm'! - -Object subclass: #AbstractFont - instanceVariableNames: '' - classVariableNames: 'AvailableFonts DefaultFont ' - poolDictionaries: '' - category: 'Graphics-Text'! - -!classDefinition: #AbstractFont category: #'Graphics-Text'! -Object subclass: #AbstractFont - instanceVariableNames: '' - classVariableNames: 'AvailableFonts DefaultFont' - poolDictionaries: '' - category: 'Graphics-Text'! - -FontFamily class removeSelector: #initialize! - -FontFamily class removeSelector: #initialize! - -FontFamily class removeSelector: #migrate! - -FontFamily class removeSelector: #migrate! - -AbstractFont class removeSelector: #availableFonts! - -AbstractFont class removeSelector: #availableFonts! - -Object subclass: #AbstractFont - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Text'! - -!classDefinition: #AbstractFont category: #'Graphics-Text'! -Object subclass: #AbstractFont - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Text'! - -FontFamily initialize! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3735-AbstractFontStateRemoval3-JuanVuletich-2019May05-16h20m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3735] on 6 May 2019 at 5:52:48 pm'! -!FontFamily class methodsFor: 'accessing' stamp: 'jmv 5/6/2019 17:50:27'! - defaultPointSize - ^ DefaultPointSize ! ! -!FontChanger class methodsFor: 'prompting user' stamp: 'jmv 5/6/2019 17:48:01' prior: 50456163! - promptUserWithFamilies: fontFamilies withMessageOnSelection: aMessageSymbol - " - Present a menu of available font families, and if one is chosen, - send aMessageSymbol to self with the corresponding font family as argument. - " - | fontMenu priorFontFamily | - priorFontFamily _ FontFamily defaultFamilyName. - fontMenu _ MenuMorph new defaultTarget: self. - fontFamilies do: [:fontName | - | isCurrent label | - isCurrent _ priorFontFamily sameAs: fontName. - label _ self toSelectableMenuLabel: fontName isCurrent: isCurrent. - fontMenu - add: label - target: self - action: aMessageSymbol - argument: fontName. - ]. - fontMenu invokeModal.! ! -!FontChanger class methodsFor: 'changing font' stamp: 'jmv 5/6/2019 17:50:36' prior: 50456310! - changeTo: aFontName - "Change the font on the whole system without changing point sizes." - FontFamily defaultFamilyName: aFontName. - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: { - {#setSystemFontTo:. FontFamily defaultPointSize}. - {#setListFontTo:. Preferences standardListFont pointSize.}. - {#setMenuFontTo:. Preferences standardMenuFont pointSize.}. - {#setWindowTitleFontTo:. Preferences windowTitleFont pointSize.}. - {#setCodeFontTo:. Preferences standardCodeFont pointSize.}. - {#setButtonFontTo:. Preferences standardButtonFont pointSize.}. - }. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]. - -! ! -!FontChanger class methodsFor: 'changing font' stamp: 'jmv 5/6/2019 17:52:10' prior: 50456196! - installFontIfNecessary: aFontName - | isFontInstalled | - isFontInstalled _ FontFamily familyNames includes: aFontName. - isFontInstalled ifFalse: [StrikeFont install: aFontName.].! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3736-AdaptFontChanger-JuanVuletich-2019May06-17h47m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3736] on 7 May 2019 at 9:43:54 am'! -!StrikeFontFamily methodsFor: 'accessing' stamp: 'jmv 5/7/2019 09:21:59'! - atPointSize: aNumber put: aFontAndSize - "aFontAndSize must have emphasis = 0, i.e. it is a base font" - baseFontBySizes at: aNumber put: aFontAndSize ! ! - -FontFamily removeSelector: #atPointSize:put:! - -FontFamily removeSelector: #atPointSize:put:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3737-FontFamilyTweak-JuanVuletich-2019May07-07h39m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3738] on 7 May 2019 at 10:14:06 am'! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/7/2019 10:13:23' prior: 50456213! - preferencesMenu - "Build the preferences menu for the world." - - ^ (self menu: 'Preferences...') - addItemsFromDictionaries: { - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Font Sizes...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Set font...'. - #object -> FontChanger. - #selector -> #promptUserAndInstallIfNecessaryWithFamilies:. - #arguments -> {FontFamily familyNames}. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'change the current font family.' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3738-DynamicWorldMenu-JuanVuletich-2019May07-10h10m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3738] on 9 May 2019 at 7:00:28 am'! -!Character class methodsFor: 'class initialization' stamp: 'jmv 5/9/2019 07:00:25' prior: 50417657! - initialize - "Create the table of unique Characters. - Character initialize - " - self initializeLookupTables. - self initializeUnicodeCodePoints.! ! -!Character class methodsFor: 'class initialization' stamp: 'jmv 5/7/2019 19:52:45' prior: 16800808! - initializeUnicodeCodePoints - " - Character initializeUnicodeCodePoints - String streamContents: [ :strm | 28 to: 255 do: [ :i | strm nextPut: (Character numericValue: i) ]] - " - - "Initialize the table of Unicode code points" - UnicodeCodePoints _ Array new: 256. - 0 to: 255 do: [ :code | - UnicodeCodePoints at: code + 1 put: code ]. - - "Arrows" - UnicodeCodePoints at: 28+1 put: 8592. "left arrow" - UnicodeCodePoints at: 29+1 put: 8594. "right arrow" - UnicodeCodePoints at: 30+1 put: 8593. "up arrow" - UnicodeCodePoints at: 31+1 put: 8595. "down arrow" - - "The following codes are different in ISO 8859-15 from those in ISO 8859-1, - so the character code is not equal to the Unicode code point" - UnicodeCodePoints at: 16rA4+1 put: 16r20AC. "euro sign" - UnicodeCodePoints at: 16rA6+1 put: 16r160. "latin capital letter S with caron" - UnicodeCodePoints at: 16rA8+1 put: 16r161. "latin small letter s with caron" - UnicodeCodePoints at: 16rB4+1 put: 16r17D. "latin capital letter Z with caron" - UnicodeCodePoints at: 16rB8+1 put: 16r17E. "latin small letter z with caron" - UnicodeCodePoints at: 16rBC+1 put: 16r152. "latin capital ligature OE" - UnicodeCodePoints at: 16rBD+1 put: 16r153. "latin small ligature oe" - UnicodeCodePoints at: 16rBE+1 put: 16r178. "latin capital letter Y with diaeresis" - - UnicodeCodePoints at: 16r80+1 put: 16r2200. "FOR ALL" - UnicodeCodePoints at: 16r81+1 put: 16r2202. "PARTIAL DIFFERENTIAL" - UnicodeCodePoints at: 16r82+1 put: 16r2203. "THERE EXISTS" - UnicodeCodePoints at: 16r83+1 put: 16r2204. "THERE DOES NOT EXIST" - UnicodeCodePoints at: 16r84+1 put: 16r2205. "EMPTY SET" - UnicodeCodePoints at: 16r85+1 put: 16r221E. "INFINITY" - UnicodeCodePoints at: 16r86+1 put: 16r2102. "DOUBLE-STRUCK CAPITAL C" - UnicodeCodePoints at: 16r87+1 put: 16r210D. "DOUBLE-STRUCK CAPITAL H" - UnicodeCodePoints at: 16r88+1 put: 16r2115. "DOUBLE-STRUCK CAPITAL N" - UnicodeCodePoints at: 16r89+1 put: 16r2119. "DOUBLE-STRUCK CAPITAL P" - UnicodeCodePoints at: 16r8A+1 put: 16r211A. "DOUBLE-STRUCK CAPITAL Q" - UnicodeCodePoints at: 16r8B+1 put: 16r211D. "DOUBLE-STRUCK CAPITAL R" - UnicodeCodePoints at: 16r8C+1 put: 16r2124. "DOUBLE-STRUCK CAPITAL Z" - UnicodeCodePoints at: 16r8D+1 put: 16r2135. "ALEF SYMBOL" - UnicodeCodePoints at: 16r8E+1 put: 16r2A00. "N-ARY CIRCLED DOT OPERATOR" - UnicodeCodePoints at: 16r8F+1 put: 16r2A01. "N-ARY CIRCLED PLUS OPERATOR" - UnicodeCodePoints at: 16r90+1 put: 16r2A02. "N-ARY CIRCLED TIMES OPERATOR" - UnicodeCodePoints at: 16r91+1 put: 16r2211. "N-ARY SUMMATION" - UnicodeCodePoints at: 16r92+1 put: 16r222B. "INTEGRAL" - UnicodeCodePoints at: 16r93+1 put: 16r2A15. "INTEGRAL AROUND A POINT OPERATOR" - UnicodeCodePoints at: 16r94+1 put: 16r2260. "NOT EQUAL TO" - UnicodeCodePoints at: 16r95+1 put: 16r2261. "IDENTICAL TO" - UnicodeCodePoints at: 16r96+1 put: 16r2262. "NOT IDENTICAL TO" - UnicodeCodePoints at: 16r97+1 put: 16r2263. "STRICTLY EQUIVALENT TO" - UnicodeCodePoints at: 16r98+1 put: 16r2264. "LESS-THAN OR EQUAL TO" - UnicodeCodePoints at: 16r99+1 put: 16r2265. "GREATER-THAN OR EQUAL TO" - UnicodeCodePoints at: 16r9A+1 put: 16r2266. "LESS-THAN OVER EQUAL TO" - UnicodeCodePoints at: 16r9B+1 put: 16r2267. "GREATER-THAN OVER EQUAL TO" - UnicodeCodePoints at: 16r9C+1 put: 16r2268. "LESS-THAN BUT NOT EQUAL TO" - UnicodeCodePoints at: 16r9D+1 put: 16r2269. "GREATER-THAN BUT NOT EQUAL TO" - UnicodeCodePoints at: 16r9E+1 put: 16r2218. "RING OPERATOR" - UnicodeCodePoints at: 16r9F+1 put: 16r2219. "BULLET OPERATOR"! ! - -Character initialize! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3739-UnicodeTranslationOfArrows-JuanVuletich-2019May09-06h54m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3739] on 10 May 2019 at 11:14:14 am'! -!FontFamily class methodsFor: 'file read write' stamp: 'jmv 5/10/2019 10:04:51'! - readAdditionalTrueTypeFonts - Feature require: 'VectorGraphics'. - Smalltalk at: #TrueTypeFontFamily ifPresent: [ :cls | cls readAdditionalFonts ]! ! -!FontChanger class methodsFor: 'prompting user' stamp: 'jmv 5/10/2019 10:40:37'! - familyNames - | monospacedStrikeFont options | - monospacedStrikeFont _ 'DejaVu Sans Mono'. - options _ FontFamily familyNames. - (options includes: monospacedStrikeFont) ifFalse: [ - options _ options copyWith: monospacedStrikeFont ]. - ^ options! ! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 5/10/2019 11:12:15' prior: 50457126! - setDefaultFont: fontFamilyName spec: defaultFontsSpec - - | font | - defaultFontsSpec do: [ :triplet | - font _ FontFamily familyName: fontFamilyName pointSize: triplet second. - font ifNil: [ - self revisar. "Please remove this hack meant to install larger DejaVu StrikeFonts on demand." - StrikeFont install: FontFamily defaultFamilyName. - font _ FontFamily familyName: fontFamilyName pointSize: triplet second ]. - font ifNil: [ font _ FontFamily defaultFamilyAndPointSize ]. - triplet size > 2 ifTrue: [ - font _ font emphasized: triplet third ]. - self - perform: triplet first - with: font]! ! -!StrikeFont methodsFor: 'emphasis' stamp: 'jmv 5/6/2019 18:04:56' prior: 50454108! - makeItalicGlyphs - "Make an italic set of glyphs with same widths by skewing left and right. - In the process, characters would overlap, so we widen them all first. - " - | extraWidth newGlyphs newXTable x newX w extraOnLeft | - extraOnLeft _ (self lineSpacing-1-self ascent+4)//4 max: 0. - extraWidth _ ((self ascent-5+4)//4 max: 0) + extraOnLeft. - newGlyphs _ Form extent: (glyphs width + (maxAscii + 1 - minAscii*extraWidth)) @ glyphs height depth: glyphs depth. - newGlyphs fillWhite. - newXTable _ xTable copy. - - "Copy glyphs into newGlyphs with room on left and right for overlap." - minAscii to: maxAscii+1 do: - [:ascii | x _ xTable at: ascii+1. w _ (xTable at: ascii+2) - x. - newX _ newXTable at: ascii+1. - newGlyphs copy: ((newX + extraOnLeft) @ 0 extent: w @ glyphs height) - from: x @ 0 in: glyphs rule: Form over. - newXTable at: ascii+2 put: newX + w + extraWidth]. - glyphs _ newGlyphs. - xTable _ newXTable. - "Slide the bitmaps left and right for synthetic italic effect." - 4 to: self ascent-1 by: 4 do: - [:y | "Slide ascenders right..." - glyphs copy: (1@0 extent: glyphs width @ (self ascent - y)) - from: 0@0 in: glyphs rule: Form over]. - self ascent to: self lineSpacing-1 by: 4 do: - [:y | "Slide descenders left..." - glyphs copy: (0@y extent: glyphs width @ glyphs height) - from: 1@y in: glyphs rule: Form over]. - self isSynthetic: true! ! -!FontFamily class methodsFor: 'initialization' stamp: 'jmv 5/10/2019 11:12:22' prior: 50457072! - defaultFamilyName: aString - | family | - self revisar. "Please remove this hack meant to install larger DejaVu StrikeFonts on demand." - aString = 'DejaVu' ifTrue: [ - family _ AvailableFamilies at: aString. - (family pointSizes includes: DefaultPointSize) ifFalse: [ StrikeFont install: aString]]. - DefaultFamilyName _ aString! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 5/10/2019 10:21:36' prior: 16926073! - drawLabelOn: aCanvas - - | e x0 y0 f w availableW l | - f _ Preferences windowTitleFont. - e _ self boxExtent. - x0 _ e x * 4 + 14. - y0 _ 2+3. - y0 _ e y - f ascent // 2. - availableW _ extent x - x0. - l _ labelString. - w _ f widthOfString: l. - [ w > availableW ] whileTrue: [ - l _ l squeezedTo: (1.0 * l size * availableW / w) truncated. - l isEmpty ifTrue: [ ^self ]. - w _ f widthOfString: l ]. - aCanvas - drawString: l - at: x0@y0 - font: f - color: Theme current windowLabel - embossed: Theme current embossedTitles! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/10/2019 10:39:45' prior: 50457725! - preferencesMenu - "Build the preferences menu for the world." - - ^ (self menu: 'Preferences...') - addItemsFromDictionaries: { - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Font Sizes...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Set font...'. - #object -> FontChanger. - #selector -> #promptUserAndInstallIfNecessaryWithFamilies:. - #arguments -> {FontChanger familyNames}. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'change the current font family.' - } asDictionary. - { - #label -> 'Load extra fonts'. - #object -> FontFamily. - #selector -> #readAdditionalTrueTypeFonts. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'Load additional TrueType fonts included with Cuis.' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3740-TrueTypeFontsOnDemand-JuanVuletich-2019May10-11h13m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3729] on 9 May 2019 at 4:02:29 pm'! -!CodeWindow methodsFor: 'keyboard shortcuts' stamp: 'EB 5/9/2019 16:00:27' prior: 50445678! - messageListKey: aChar from: view - "Respond to a Command key. I am a model with a code pane, and I also - have a listView that has a list of methods. The view knows how to get - the list and selection." - - | sel class | - aChar == $D ifTrue: [^ model toggleDiffing]. - - sel _ model selectedMessageName. - aChar == $m ifTrue: [ "These next two put up a type in if no message selected" - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllImplementorsOf: to: Smalltalk]. - aChar == $n ifTrue: [ - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllCallsOn: to: Smalltalk]. - - "The following require a class selection" - (class _ model selectedClassOrMetaClass) ifNil: [^ self ]. - aChar == $b ifTrue: [^ BrowserWindow fullOnClass: class selector: sel]. - aChar == $N ifTrue: [^ self browseClassRefs]. - aChar == $i ifTrue: [^ self methodHierarchy]. - aChar == $h ifTrue: [^ self browseHierarchy]. - aChar == $p ifTrue: [^ self browseFullProtocol]. - - sel - ifNotNil: [ - "The following require a method selection" - aChar == $o ifTrue: [^ model fileOutMessage]. - aChar == $c ifTrue: [^ model copySelector]. - aChar == $v ifTrue: [^ self browseVersions]. - aChar == $C ifTrue: [^ model showHomeCategory]. - aChar == $O ifTrue: [^ self openSingleMessageBrowser]. - aChar == $x ifTrue: [^ model removeMessage]. - aChar == $t ifTrue: [^ model runMethodTest]. - aChar == $r ifTrue: [^ model debugMethodTest]. - aChar == $R ifTrue: [^ self renameSelector]] - ifNil: [ - aChar == $R ifTrue: [^ model renameClass]]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3741-ShowCategoryShortcut-EricBrandwein-2019May09-15h34m-EB.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3741] on 12 May 2019 at 10:33:47 pm'! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:42:20'! - FF - " - Character FF - " - ^ $! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:34:09'! - circ - " - Character circ - " - ^ $•! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:39:22'! - div - " - Character div - " - ^ $÷! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:33:06'! - epsilon - " - Character epsilon - " - ^ $„! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:39:44'! - pi - " - Character pi - " - ^ $ƒ! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:40:22'! - sqrt - " - Character sqrt - " - ^ $Ÿ! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:44:27'! - zeta - " - Character zeta - " - ^ $…! ! -!Character class methodsFor: 'class initialization' stamp: 'len 5/12/2019 22:31:40' prior: 50457837! - initializeUnicodeCodePoints - " - Character initializeUnicodeCodePoints - String streamContents: [ :strm | 28 to: 255 do: [ :i | strm nextPut: (Character numericValue: i) ]] - " - - "Initialize the table of Unicode code points" - UnicodeCodePoints _ Array new: 256. - 0 to: 255 do: [ :code | - UnicodeCodePoints at: code + 1 put: code ]. - - "Arrows" - UnicodeCodePoints at: 28+1 put: 8592. "left arrow" - UnicodeCodePoints at: 29+1 put: 8594. "right arrow" - UnicodeCodePoints at: 30+1 put: 8593. "up arrow" - UnicodeCodePoints at: 31+1 put: 8595. "down arrow" - - "The following codes are different in ISO 8859-15 from those in ISO 8859-1, - so the character code is not equal to the Unicode code point" - UnicodeCodePoints at: 16rA4+1 put: 16r20AC. "euro sign" - UnicodeCodePoints at: 16rA6+1 put: 16r160. "latin capital letter S with caron" - UnicodeCodePoints at: 16rA8+1 put: 16r161. "latin small letter s with caron" - UnicodeCodePoints at: 16rB4+1 put: 16r17D. "latin capital letter Z with caron" - UnicodeCodePoints at: 16rB8+1 put: 16r17E. "latin small letter z with caron" - UnicodeCodePoints at: 16rBC+1 put: 16r152. "latin capital ligature OE" - UnicodeCodePoints at: 16rBD+1 put: 16r153. "latin small ligature oe" - UnicodeCodePoints at: 16rBE+1 put: 16r178. "latin capital letter Y with diaeresis" - - UnicodeCodePoints at: 16r80+1 put: 16r2205. "EMPTY SET" - UnicodeCodePoints at: 16r81+1 put: 16r221E. "INFINITY" - UnicodeCodePoints at: 16r82+1 put: 16r2135. "ALEF SYMBOL" - UnicodeCodePoints at: 16r83+1 put: 16r03C0. "pi" - UnicodeCodePoints at: 16r84+1 put: 16r03B5. "epsilon" - UnicodeCodePoints at: 16r85+1 put: 16r03B6. "zeta" - UnicodeCodePoints at: 16r86+1 put: 16r0394. "Delta" - UnicodeCodePoints at: 16r87+1 put: 16r03A9. "Omega" - UnicodeCodePoints at: 16r88+1 put: 16r2102. "DOUBLE-STRUCK CAPITAL C" - UnicodeCodePoints at: 16r89+1 put: 16r210D. "DOUBLE-STRUCK CAPITAL H" - UnicodeCodePoints at: 16r8A+1 put: 16r2115. "DOUBLE-STRUCK CAPITAL N" - UnicodeCodePoints at: 16r8B+1 put: 16r2119. "DOUBLE-STRUCK CAPITAL P" - UnicodeCodePoints at: 16r8C+1 put: 16r211A. "DOUBLE-STRUCK CAPITAL Q" - UnicodeCodePoints at: 16r8D+1 put: 16r211D. "DOUBLE-STRUCK CAPITAL R" - UnicodeCodePoints at: 16r8E+1 put: 16r2124. "DOUBLE-STRUCK CAPITAL Z" - UnicodeCodePoints at: 16r8F+1 put: 16r0046. "DOUBLE-STRUCK CAPITAL F" "should be 1D53D, index out of bounds" - UnicodeCodePoints at: 16r90+1 put: 16r2295. "OPLUS" - UnicodeCodePoints at: 16r91+1 put: 16r2297. "OTIMES" - UnicodeCodePoints at: 16r92+1 put: 16r2299. "ODOT" - UnicodeCodePoints at: 16r93+1 put: 16r2296. "OMINUS" - UnicodeCodePoints at: 16r94+1 put: 16r2217. "ASTERISK OPERATOR" - UnicodeCodePoints at: 16r95+1 put: 16r2218. "RING OPERATOR (circ)" - UnicodeCodePoints at: 16r96+1 put: 16r2219. "BULLET OPERATOR (filled circ)" - UnicodeCodePoints at: 16r97+1 put: 16r22C5. "DOT OPERATOR" "(already at B7)" - UnicodeCodePoints at: 16r98+1 put: 16r22C6. "STAR OPERATOR" - UnicodeCodePoints at: 16r99+1 put: 16r21A0. "SURJECTIVE ARROW" - UnicodeCodePoints at: 16r9A+1 put: 16r21A3. "INJECTIVE ARROW" - UnicodeCodePoints at: 16r9B+1 put: 16r2194. "BIJECTIVE ARROW" - UnicodeCodePoints at: 16r9C+1 put: 16r21AA. "INCLUSION ARROW" - UnicodeCodePoints at: 16r9D+1 put: 16r21A6. "MAPPING ARROW" - UnicodeCodePoints at: 16r9E+1 put: 16r2202. "PARTIAL DIFFERENTIAL" - UnicodeCodePoints at: 16r9F+1 put: 16r221A. "SQUARE ROOT" - - UnicodeCodePoints at: 16r2D+1 put: 16r2212. "WIDE MINUS" - UnicodeCodePoints at: 16r2A+1 put: 16r2217. "CENTERED ASTERISK"! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:41:10' prior: 16801334! - CC - " - Character CC - " - ^ $ˆ! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:41:20' prior: 16801338! - HH - " - Character HH - " - ^ $‰! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:41:29' prior: 16801342! - NN - " - Character NN - " - ^ $Š! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:41:38' prior: 16801346! - PP - " - Character PP - " - ^ $‹! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:41:48' prior: 16801350! - QQ - " - Character QQ - " - ^ $Œ! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:41:55' prior: 16801354! - RR - " - Character RR - " - ^ $! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:42:11' prior: 16801358! - ZZ - " - Character ZZ - " - ^ $Ž! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:43:23' prior: 16801362! - aleph - " - Character aleph - " - ^ $‚! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:35:59' prior: 16801367! - bullet - " - Character bullet - " - ^ $–! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:33:17' prior: 16801397! - emptySet - " - Character emptySet - " - ^ $€! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:36:47' prior: 50371930! - infinity - " - Character infinity - " - ^ $! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:36:35' prior: 16801473! - oplus - " - Character oplus - " - ^ $! ! -!Character class methodsFor: 'accessing mathematical symbols' stamp: 'len 5/12/2019 21:37:52' prior: 16801478! - otimes - " - Character otimes - " - ^ $‘! ! -!String class methodsFor: 'initialization' stamp: 'len 5/12/2019 21:51:05' prior: 16917924! - initialize - " - String initialize - " - - | order newOrder lowercase | - - "Case insensitive compare sorts null, space, digits, letters, all the rest..." - newOrder _ Array new: 256. - order _ -1. - newOrder at: 0+1 put: (order _ order+1). - 32 to: 64 do: [ :c | - newOrder at: c + 1 put: (order _ order+1)]. - #(92 94 124 126) do: [ :c | "\^|~" - newOrder at: c + 1 put: (order _ order+1)]. - 16r90 to: 16r9F do: [:c| "special math operators" - newOrder at: c + 1 put: (order _ order+1)]. - Character uppercaseLowercaseAndUnaccentedLetters do: [ :upperAndLowercase | - order _ order+1. - newOrder at: upperAndLowercase first numericValue + 1 put: order. - upperAndLowercase size > 1 ifTrue: [ - newOrder at: upperAndLowercase second numericValue + 1 put: order ]]. - 1 to: newOrder size do: [ :i | - (newOrder at: i) ifNil: [ - newOrder at: i put: (order _ order+1)]]. - CaseInsensitiveOrder _ newOrder asByteArray. - - "Case sensitive compare sorts null, space, digits, letters, all the rest..." - newOrder _ Array new: 256. - order _ -1. - newOrder at: 0+1 put: (order _ order+1). - 32 to: 64 do: [ :c | - newOrder at: c + 1 put: (order _ order+1)]. - #(92 94 124 126) do: [ :c | "\^|~" - newOrder at: c + 1 put: (order _ order+1)]. - 16r90 to: 16r9F do: [:c| "special math operators" - newOrder at: c + 1 put: (order _ order+1)]. - Character uppercaseLowercaseAndUnaccentedLetters do: [ :upperAndLowercase | - upperAndLowercase size > 1 ifTrue: [ - newOrder at: upperAndLowercase first numericValue + 1 put: (order _ order+1) ]]. - Character uppercaseLowercaseAndUnaccentedLetters do: [ :upperAndLowercase | - lowercase _ upperAndLowercase size = 1 - ifTrue: [ upperAndLowercase first ] - ifFalse: [ upperAndLowercase second ]. - newOrder at: lowercase numericValue + 1 put: (order _ order+1) ]. - 1 to: newOrder size do: [ :i | - (newOrder at: i) ifNil: [ - newOrder at: i put: (order _ order+1)]]. - order = 255 ifFalse: [self error: 'order problem']. - CaseSensitiveOrder _ newOrder asByteArray. - - "a table for translating to lower case" - LowercasingTable _ String withAll: (Character characterTable collect: [:c | c asLowercase]). - - "a table for translating to upper case" - UppercasingTable _ String withAll: (Character characterTable collect: [:c | c asUppercase]). - - "a table for testing tokenish (for fast numArgs)" - Tokenish _ String withAll: (Character characterTable collect: - [:c | c tokenish ifTrue: [c] ifFalse: [$~]]). - - "CR and LF--characters that terminate a line" - CSLineEnders _ CharacterSet new. - CSLineEnders add: Character cr. - CSLineEnders add: Character lf. - - "separators and non-separators" - CSSeparators _ CharacterSet separators. - CSNonSeparators _ CSSeparators complement! ! - -Character class removeSelector: #circle! - -Character class removeSelector: #circle! - -Character class removeSelector: #contourIntegral! - -Character class removeSelector: #contourIntegral! - -Character class removeSelector: #doesNotExist! - -Character class removeSelector: #doesNotExist! - -Character class removeSelector: #exists! - -Character class removeSelector: #exists! - -Character class removeSelector: #forAll! - -Character class removeSelector: #forAll! - -Character class removeSelector: #greaterNotEqual! - -Character class removeSelector: #greaterNotEqual! - -Character class removeSelector: #greaterOrEqual! - -Character class removeSelector: #greaterOrEqual! - -Character class removeSelector: #greaterOverEqual! - -Character class removeSelector: #greaterOverEqual! - -Character class removeSelector: #identical! - -Character class removeSelector: #identical! - -Character class removeSelector: #integral! - -Character class removeSelector: #integral! - -Character class removeSelector: #lessNotEqual! - -Character class removeSelector: #lessNotEqual! - -Character class removeSelector: #lessOrEqual! - -Character class removeSelector: #lessOrEqual! - -Character class removeSelector: #lessOverEqual! - -Character class removeSelector: #lessOverEqual! - -Character class removeSelector: #notEqual! - -Character class removeSelector: #notEqual! - -Character class removeSelector: #notIdentical! - -Character class removeSelector: #notIdentical! - -Character class removeSelector: #odot! - -Character class removeSelector: #odot! - -Character class removeSelector: #partial! - -Character class removeSelector: #partial! - -Character class removeSelector: #strictlyEquivalent! - -Character class removeSelector: #strictlyEquivalent! - -Character class removeSelector: #summation! - -Character class removeSelector: #summation! - -Character initialize! - -String initialize! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3742-MathCharacters-LucianoEstebanNotarfrancesco-2019May12-12h53m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3741] on 13 May 2019 at 10:30:38 am'! -!TextEditor methodsFor: 'events' stamp: 'jmv 5/13/2019 10:03:18' prior: 16932039! - mouseMove: aMouseMoveEvent localPosition: localEventPosition - "Change the selection in response to mouse-down drag" - - | newPointBlock goingBackwards newStartBlock newStopBlock interval i1 i2 | - newPointBlock _ textComposition characterBlockAtPoint: localEventPosition. - goingBackwards _ newPointBlock stringIndex < markBlock stringIndex. - - doWordSelection ifTrue: [ - pointBlock _ newPointBlock. - self selectWordLeftDelimiters: '' rightDelimiters: ''. - newStartBlock _ self startBlock min: initialSelectionStart. - newStopBlock _ self stopBlock max: initialSelectionStop. - markBlock _ goingBackwards ifTrue: [newStopBlock] ifFalse: [newStartBlock]. - pointBlock _ goingBackwards ifTrue: [newStartBlock] ifFalse: [newStopBlock]. - self storeSelectionInComposition. - ^self ]. - - doParagraphSelection ifTrue: [ - i1 _ newPointBlock stringIndex min: initialSelectionStart stringIndex. - i2 _ newPointBlock stringIndex max: initialSelectionStop stringIndex-1. - interval _ self privateCurrentString encompassParagraph: (i1 to: i2). - self selectFrom: interval first to: interval last. - newStartBlock _ self startBlock min: initialSelectionStart. - newStopBlock _ self stopBlock max: initialSelectionStop. - markBlock _ goingBackwards ifTrue: [newStopBlock] ifFalse: [newStartBlock]. - pointBlock _ goingBackwards ifTrue: [newStartBlock] ifFalse: [newStopBlock]. - self storeSelectionInComposition. - ^self ]. - - pointBlock _ newPointBlock. - self storeSelectionInComposition! ! -!PluggableScrollPane methodsFor: 'events' stamp: 'jmv 5/13/2019 10:22:02' prior: 16889553! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - - | eventPositionLocalToScroller | - eventPositionLocalToScroller _ localEventPosition - scroller morphPosition. - scroller mouseButton1Down: aMouseButtonEvent localPosition: eventPositionLocalToScroller. - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: nil - clkNHalf: nil - dblClkSel: #doubleClick:localPosition: - dblClkNHalfSel: #doubleClickAndHalf:localPosition: - tripleClkSel: nil! ! -!PluggableScrollPane methodsFor: 'events' stamp: 'jmv 5/13/2019 10:22:51' prior: 16889568! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - - | eventPositionLocalToScroller | - eventPositionLocalToScroller _ localEventPosition - scroller morphPosition. - super mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition. - scroller mouseButton1Up: aMouseButtonEvent localPosition: eventPositionLocalToScroller! ! -!PluggableScrollPane methodsFor: 'events' stamp: 'jmv 5/13/2019 10:22:12' prior: 16889578! - mouseMove: aMouseMoveEvent localPosition: localEventPosition - - | eventPositionLocalToScroller | - eventPositionLocalToScroller _ localEventPosition - scroller morphPosition. - scroller mouseMove: aMouseMoveEvent localPosition: eventPositionLocalToScroller! ! -!TextModelMorph methodsFor: 'editor access' stamp: 'jmv 5/13/2019 10:30:16' prior: 50455286! - scrollSelectionIntoView - "Scroll my text into view if necessary and return true, else return false" - - | delta | - delta _ self textMorph morphPosition. - self editor pointIndex > 1 - ifTrue: [ - self scrollToShow: (self editor pointBlock translatedBy: delta) ] - ifFalse: [ - self scrollToShow: (self editor selectionRectangle translatedBy: delta) ]! ! -!TextModelMorph methodsFor: 'events' stamp: 'jmv 5/13/2019 10:21:37' prior: 50381735! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - - | eventPositionLocalToScroller | - eventPositionLocalToScroller _ localEventPosition - scroller morphPosition. - scroller mouseButton1Down: aMouseButtonEvent localPosition: eventPositionLocalToScroller. - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: nil - clkNHalf: #clickAndHalf:localPosition: - dblClkSel: #doubleClick:localPosition: - dblClkNHalfSel: #doubleClickAndHalf:localPosition: - tripleClkSel: nil! ! -!InnerTextMorph methodsFor: 'event handling' stamp: 'jmv 5/13/2019 09:23:53' prior: 50432752! - processKeyStroke: evt - | action | - - (acceptOnCR and: [evt isReturnKey]) ifTrue: [^ self acceptContents]. - - self pauseBlinking. - - "Return - check for special action" - evt isReturnKey ifTrue: [ - action _ self crAction. - action ifNotNil: [ ^action value]]. - - "Esc - check for special action" - evt isEsc ifTrue: [ - action _ self escAction. - action ifNotNil: [ ^action value]]. - - self handleInteraction: [ editor processKeyStroke: evt ]. - self scrollSelectionIntoView! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3743-DragSelectionAutoscrollFixes-JuanVuletich-2019May13-10h26m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3743] on 13 May 2019 at 12:39:08 pm'! -!Color methodsFor: 'transformations' stamp: 'jmv 5/13/2019 12:37:50'! - *= anObject - super *= anObject. - self clipToValidValues! ! -!Color methodsFor: 'transformations' stamp: 'jmv 5/13/2019 12:38:03'! - += anObject - super += anObject. - self clipToValidValues! ! -!Color methodsFor: 'transformations' stamp: 'jmv 5/13/2019 12:38:13'! - -= anObject - super -= anObject. - self clipToValidValues! ! -!Color methodsFor: 'transformations' stamp: 'jmv 5/13/2019 12:38:18'! - /= anObject - super /= anObject. - self clipToValidValues! ! -!Color methodsFor: 'private' stamp: 'jmv 5/13/2019 12:37:37'! - clipToValidValues - | v | - 1 to: self size do: [ :i | - v _ self at: i. - v > 1 ifTrue: [self at: i put: 1.0]. - v < 0 ifTrue: [self at: i put: 0.0]]! ! -!Color methodsFor: 'transformations' stamp: 'jmv 5/13/2019 12:24:11' prior: 50353947! - * aNumberOrColor - "Answer this color with its RGB multiplied by the given number. " - " - (Color brown *2) display - " - (aNumberOrColor is: #Color) ifTrue: [ - ^ (Color new - setRed: (self red * aNumberOrColor red min: 1.0 max: 0.0) - green: (self green * aNumberOrColor green min: 1.0 max: 0.0) - blue: (self blue * aNumberOrColor blue min: 1.0 max: 0.0)) - alpha: self alpha * aNumberOrColor alpha - ]. - ^ (Color new - setRed: (self red * aNumberOrColor min: 1.0 max: 0.0) - green: (self green * aNumberOrColor min: 1.0 max: 0.0) - blue: (self blue * aNumberOrColor min: 1.0 max: 0.0)) - alpha: self alpha! ! -!Color methodsFor: 'transformations' stamp: 'jmv 5/13/2019 12:25:02' prior: 50353983! - / aNumberOrColor - "Answer this color with its RGB divided by the given number. " - " - (Color red / 2) display - " - (aNumberOrColor is: #Color) ifTrue: [ - ^ Color new - setRed: (self red / aNumberOrColor red min: 1.0 max: 0.0) - green: (self green / aNumberOrColor green min: 1.0 max: 0.0) - blue: (self blue / aNumberOrColor blue min: 1.0 max: 0.0) - ]. - ^ Color new - setRed: (self red / aNumberOrColor min: 1.0 max: 0.0) - green: (self green / aNumberOrColor min: 1.0 max: 0.0) - blue: (self blue / aNumberOrColor min: 1.0 max: 0.0)! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3744-Color-fix-JuanVuletich-2019May13-12h24m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3744] on 13 May 2019 at 11:42:23 pm'! -!StrikeFont methodsFor: 'synthetic derivatives' stamp: 'jmv 5/13/2019 23:33:44' prior: 50457466! - syntheticSubscript - "Build and answer a derivative that is Subscript." - - | derivative | - derivative _ ((FontFamily familyName: self familyName aroundPointSize: pointSize * 0.58) - emphasized: emphasis) - copy. - derivative useShortUnderscore. - ^ derivative - -" -StrikeFont allInstances do: [ :a | a reset ]. -('Hi ', (Text string: 'there' attribute: TextEmphasis superscript), ' how ', (Text string: 'are' attribute: TextEmphasis subscript), ' you?') edit. -"! ! -!StrikeFont methodsFor: 'synthetic derivatives' stamp: 'jmv 5/13/2019 23:33:31' prior: 50457488! - syntheticSuperscript - "Build and answer a derivative that is Superscript." - - | derivative | - derivative _ ((FontFamily familyName: self familyName aroundPointSize: pointSize * 0.58) - emphasized: emphasis) - copy. - derivative name: self name , 'Sup'. - ^ derivative - -" -StrikeFont allInstances do: [ :a | a reset ]. -('Hi ', (Text string: 'there' attribute: TextEmphasis superscript), ' how ', (Text string: 'are' attribute: TextEmphasis subscript), ' you?') edit. -"! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3745-StrikeFont-fix-JuanVuletich-2019May13-23h39m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3745] on 15 May 2019 at 7:29:25 pm'! -!TestCase methodsFor: 'assertions' stamp: 'HAW 5/15/2019 19:24:37'! -assert: anAction changes: aCondition - - | after before | - - before := aCondition value. - anAction value. - after := aCondition value. - - self deny: after = before! ! -!TestCase methodsFor: 'assertions' stamp: 'HAW 5/15/2019 19:25:11'! - assert: anAction changes: aCondition by: aDifference - - | after before | - - before := aCondition value. - anAction value. - after := aCondition value. - - self assert: after equals: before + aDifference! ! -!TestCase methodsFor: 'assertions' stamp: 'HAW 5/15/2019 19:27:33'! - assert: anAction changes: aCondition from: anInitialObject to: aFinalObject - - | after before | - - before := aCondition value. - anAction value. - after := aCondition value. - - self assert: before equals: anInitialObject. - self assert: after equals: aFinalObject! ! -!TestCase methodsFor: 'assertions' stamp: 'HAW 5/15/2019 19:27:43'! - assert: anAction doesNotChange: aCondition - - | after before | - - before := aCondition value. - anAction value. - after := aCondition value. - - self assert: after equals: before! ! -!TestCase methodsFor: 'assertions' stamp: 'HAW 5/15/2019 18:53:33'! - assert: aCollection includes: anObject - - ^ self assert: (aCollection includes: anObject) description: [ aCollection asString, ' does not include ', anObject asString ]! ! -!TestCase methodsFor: 'assertions' stamp: 'HAW 5/15/2019 18:57:54'! - assert: aNumber isNearTo: anotherNumber - - self assert: aNumber isNearTo: anotherNumber withPrecision: self defaultPrecision ! ! -!TestCase methodsFor: 'assertions' stamp: 'HAW 5/15/2019 19:23:07'! - assert: aNumber isNearTo: anotherNumber withPrecision: aPrecision - - self assert: (self is: aNumber biggerThan: anotherNumber withPrecision: aPrecision)! ! -!TestCase methodsFor: 'assertions' stamp: 'HAW 5/15/2019 18:58:32'! -assert: aNumber isNotNearTo: anotherNumber - - self assert: aNumber isNotNearTo: anotherNumber withPrecision: self defaultPrecision ! ! -!TestCase methodsFor: 'assertions' stamp: 'HAW 5/15/2019 19:23:13'! - assert: aFloatNumber isNotNearTo: anotherFloatNumber withPrecision: aPrecision - - self deny: (self is: aFloatNumber biggerThan: anotherFloatNumber withPrecision: aPrecision) -! ! -!TestCase methodsFor: 'assertions' stamp: 'HAW 5/15/2019 19:09:01'! - defaultPrecision - - ^ 0.0001 - ! ! -!TestCase methodsFor: 'assertions' stamp: 'HAW 5/15/2019 19:23:27'! - is: aNumber biggerThan: anotherNumber withPrecision: aPrecision - - aNumber = 0 ifTrue: [ ^ anotherNumber abs < aPrecision ]. - - ^ (aNumber - anotherNumber) abs < (aPrecision * (aNumber abs max: anotherNumber abs))! ! -!TestCase methodsFor: 'assertions' stamp: 'HAW 5/15/2019 19:04:32'! - should: aClosure notTakeMoreThan: aLimit - - | millisecondsLimit | - - millisecondsLimit := aLimit totalMilliseconds. - self assert: aClosure timeToRun <= millisecondsLimit description: [ 'Took more than ', millisecondsLimit printString, ' milliseconds' ]! ! -!TestCase methodsFor: 'assertions' stamp: 'HAW 5/15/2019 18:58:49' prior: 16927399! - deny: aBoolean description: aString - - self assert: aBoolean not description: aString - ! ! - -TestCase removeSelector: #should:takeLessThan:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3746-TestCaseAssertions-GastonCarusoHernanWilkinson-2019May15-18h28m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3746] on 17 May 2019 at 9:03:11 am'! -!ByteArray methodsFor: 'platform independent access' stamp: 'jmv 5/16/2019 16:01:00'! - bitAt: bitIndex - "Answer the bit (0 or 1) at a bit index. - This way, the receiver behaves as a BitArray. - Note: There is no error raised if you the possible access extra bits at the end if size is not multiple of 8." - | bitPosition index | - index _ bitIndex - 1 // 8 + 1. - bitPosition _ bitIndex - 1 \\ 8 + 1. - ^ self bitAt: index bitPosition: bitPosition! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'jmv 5/17/2019 08:52:33'! - bitAt: bitIndex put: aBit - "Set the bit (0 or 1) at a bit index. This way, the receiver behaves as a BitArray - Note: There is no error raised if you the possible access extra bits at the end if size is not multiple of 8. - #[1 0 0 ] bitAt: 1 - #[0 1 0 ] bitAt: 9 - #[0 0 128 ] bitAt: 24 - " - | bitPosition index | - index _ bitIndex - 1 // 8 + 1. - bitPosition _ bitIndex - 1 \\ 8 + 1. - self bitAt: index bitPosition: bitPosition put: aBit! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'jmv 5/17/2019 08:51:43'! - bitBooleanAt: bitIndex - "Consider the bit at bitIndex as a Boolean value. - 0 -> false - 1 -> true" - ^ (self bitAt: bitIndex) = 1! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'jmv 5/17/2019 08:52:49'! - bitBooleanAt: bitIndex put: aBoolean - "Consider the bit at bitIndex as a Boolean value. - 0 -> false - 1 -> true" - self bitAt: bitIndex put: (aBoolean ifTrue: [1] ifFalse: [0])! ! -!ByteArray methodsFor: 'private' stamp: 'jmv 5/16/2019 15:49:51'! - bitAt: index bitPosition: bitPosition - "Answer the bit (0 or 1) at byte at index, at bitPosition. - The bits are indexed starting at 1 for the least significant bit" - ^(self at: index) bitAt: bitPosition! ! -!ByteArray methodsFor: 'private' stamp: 'jmv 5/16/2019 15:58:53'! - bitAt: index bitPosition: bitPosition put: aBit - "Set the bit (0 or 1) at byte at index, at bitPosition. - The bit value should be 0 or 1, otherwise raise an Error. - The bits are indexed starting at 1 for the least significant bit" - self at: index put: ((self at: index) bitAt: bitPosition put: aBit)! ! -!ByteArray class methodsFor: 'instance creation' stamp: 'jmv 5/16/2019 15:59:16'! - newBits: bitCount - " - (ByteArray newBits: 8) bitAt: 8 put: 1; bitAt: 8 - (ByteArray newBits: 9) bitAt: 9 put: 1; bitAt: 9 - " - ^self new: bitCount + 7 // 8! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3747-BitArrayAccessInByteArray-JuanVuletich-2019May17-08h48m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3747] on 17 May 2019 at 9:53:10 am'! -!StrikeFont methodsFor: 'objects from disk' stamp: 'jmv 5/17/2019 09:52:58' prior: 16914907! - objectForDataStream: refStrm - - "I am about to be written on an object file. Write a textual reference instead. - Warning: This saves a lot of space, but might fail if using other fonts than those in AvailableFonts" - - ^ DiskProxy - global: #FontFamily - selector: #familyName:aroundPointSize: - args: (Array with: self familyName with: self pointSize)! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3748-StrikeFontSerialization-tweak-JuanVuletich-2019May17-09h52m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3748] on 18 May 2019 at 5:07:05 pm'! -!Collection class methodsFor: 'instance creation' stamp: 'HAW 5/18/2019 09:36:08'! - ofSize: aSize - - "Create a new collection of size aSize with nil as its elements. - This method exists because OrderedCollection new: aSize creates an - empty collection, not one of size aSize that it is necesary for #streamContents: - when sent to OrderedCollection" - - ^ self new: aSize! ! -!OrderedCollection methodsFor: 'initialization' stamp: 'HAW 5/18/2019 16:49:45'! - initializeOfSize: aSize - - array := Array new: aSize. - firstIndex := 1. - lastIndex := aSize.! ! -!OrderedCollection class methodsFor: 'instance creation' stamp: 'HAW 5/18/2019 16:49:03'! - ofSize: aSize - - "See superclass implementation" - - ^ super new initializeOfSize: aSize! ! -!SequenceableCollection class methodsFor: 'stream creation' stamp: 'HAW 5/18/2019 16:51:23' prior: 16907019! - streamContents: blockWithArg estimatedSize: estimatedSize - - | stream originalContents | - - stream _ WriteStream on: (self ofSize: estimatedSize). - blockWithArg value: stream. - originalContents _ stream originalContents. - - ^stream position = originalContents size - ifTrue: [ originalContents ] - ifFalse: [ stream contents ]! ! -!WriteStream methodsFor: 'private' stamp: 'HAW 5/18/2019 16:53:59' prior: 50341260! - growTo: anInteger - "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. - - anInteger is the required minimal new size of the collection " - - | oldSize grownCollection newSize | - oldSize _ collection size. - newSize _ anInteger + (oldSize max: 20). - grownCollection _ collection class ofSize: newSize. - collection _ grownCollection replaceFrom: 1 to: oldSize with: collection startingAt: 1. - writeLimit _ collection size! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3749-OrderedCollectionStreamContents-HernanWilkinson-2019May18-08h58m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3748] on 18 May 2019 at 5:13:28 pm'! -!Collection methodsFor: 'copying' stamp: 'HAW 5/18/2019 17:09:55'! - flatten - - ^ self species streamContents: [ :flattenedStream | self flattenTo: flattenedStream ]! ! -!Collection methodsFor: 'copying' stamp: 'HAW 5/18/2019 17:10:09'! - flattenTo: flattenedStream - - self do: [ :each | - each isCollection - ifTrue: [ each flattenTo: flattenedStream ] - ifFalse: [ flattenedStream nextPut: each ]]. - - ^ flattenedStream -! ! -!String methodsFor: 'copying' stamp: 'HAW 5/18/2019 17:10:29'! -flattenTo: flattenedStream - - flattenedStream nextPut: self! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3750-Flatten-GF-GC-HernanWilkinson-2019May18-17h09m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3744] on 17 May 2019 at 1:38:30 pm'! - -Smalltalk renameClassNamed: #LocalToInstanceVariable as: #TemporaryToInstanceVariable! - -Refactoring subclass: #TemporaryToInstanceVariable - instanceVariableNames: 'variable method' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #TemporaryToInstanceVariable category: #'Tools-Refactoring'! -Refactoring subclass: #TemporaryToInstanceVariable - instanceVariableNames: 'variable method' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #TemporaryToInstanceVariableApplier - instanceVariableNames: 'smalltalkEditor classToRefactor methodNode variableName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #TemporaryToInstanceVariableApplier category: #'Tools-Refactoring'! -RefactoringApplier subclass: #TemporaryToInstanceVariableApplier - instanceVariableNames: 'smalltalkEditor classToRefactor methodNode variableName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!SmalltalkEditor methodsFor: 'temp to inst var' stamp: 'EB 5/17/2019 13:00:30'! - temporaryToInstanceVariable - self withNodeUnderCursorDo: [ :nodeUnderCursor | - nodeUnderCursor isTemp ifTrue: [ - TemporaryToInstanceVariableApplier on: self for: nodeUnderCursor name :: value - ] ifFalse: [ morph flash ]. - ] ifAbsent: [ morph flash ].! ! -!SmalltalkEditor methodsFor: 'temp to inst var' stamp: 'EB 5/17/2019 13:21:21'! - temporaryToInstanceVariable: aKeyboardEvent - self temporaryToInstanceVariable. - ^true.! ! -!SmalltalkEditor methodsFor: 'temp to inst var' stamp: 'EB 5/17/2019 12:53:43'! - withNodeUnderCursorDo: aDoBlock ifAbsent: anAbsentBlock - self - withMethodNodeAndClassDo: [ :currentMethodNode :currentClass | - currentMethodNode withParseNodeIncluding: self startIndex - do: aDoBlock - ifAbsent: anAbsentBlock. - ] ifErrorsParsing: [ :arg1 | anAbsentBlock value ].! ! -!TemporaryToInstanceVariable methodsFor: 'initialization' stamp: 'EB 5/15/2019 22:52:40'! - initializeNamed: aTemporaryVariableName fromMethod: aMethodNode - variable _ aTemporaryVariableName. - method _ aMethodNode.! ! -!TemporaryToInstanceVariable methodsFor: 'applying' stamp: 'EB 5/16/2019 00:09:59'! - addInstanceVariable - AddInstanceVariable named: variable to: method methodClass :: apply.! ! -!TemporaryToInstanceVariable methodsFor: 'applying' stamp: 'EB 5/17/2019 13:08:04'! - apply - | newSourceCode | - newSourceCode _ self removeTemporary. - self addInstanceVariable. - ^newSourceCode.! ! -!TemporaryToInstanceVariable methodsFor: 'applying' stamp: 'EB 5/17/2019 13:07:44'! - removeTemporary - | temporaryVariablePositions newSourceCode variableDeclarationPosition | - temporaryVariablePositions _ method positionsForTemporaryVariable: variable ifAbsent: []. - variableDeclarationPosition _ {temporaryVariablePositions first}. - newSourceCode _ method sourceText copyReplacing: variableDeclarationPosition with: ''. - method methodClass compile: newSourceCode. - ^newSourceCode. - ! ! -!TemporaryToInstanceVariable class methodsFor: 'instance creation' stamp: 'EB 5/17/2019 01:24:00'! - named: aTemporaryVariableName fromMethod: aMethodNode - | methodClass | - methodClass _ aMethodNode methodClass. - - self assert: aMethodNode hasTemporaryNamed: aTemporaryVariableName. - self assertNoOtherMethodIn: methodClass orSubclassesDefinesTemporaryNamed: aTemporaryVariableName. - self assertSubclassesOf: methodClass haventGotInstanceVariableNamed: aTemporaryVariableName. - - ^self new initializeNamed: aTemporaryVariableName fromMethod: aMethodNode.! ! -!TemporaryToInstanceVariable class methodsFor: 'error descriptions' stamp: 'EB 5/16/2019 00:17:51'! - inexistentTemporaryErrorDescription - ^'The temporary variable does not exist.'! ! -!TemporaryToInstanceVariable class methodsFor: 'error descriptions' stamp: 'EB 5/16/2019 02:43:50'! - temporaryExistsAsInstVarInSubclassesErrorDescription - ^'The temporary variable exists as an instance variable in a subclass.'! ! -!TemporaryToInstanceVariable class methodsFor: 'error descriptions' stamp: 'EB 5/16/2019 00:42:42'! - temporaryExistsInOtherMethodsErrorDescription - ^'Temporary variable exists in other methods; remove those first.'! ! -!TemporaryToInstanceVariable class methodsFor: 'assertions' stamp: 'EB 5/17/2019 13:28:16'! - assert: aMethodNode hasTemporaryNamed: aTemporaryVariableName - aMethodNode hasLocalNamed: aTemporaryVariableName :: ifFalse: [ - self refactoringError: self inexistentTemporaryErrorDescription. - ].! ! -!TemporaryToInstanceVariable class methodsFor: 'assertions' stamp: 'EB 5/17/2019 13:28:45'! - assertNoOtherMethodIn: aClass orSubclassesDefinesTemporaryNamed: aTemporaryVariableName - | methodsDefiningTemporaryInHierarchy | - methodsDefiningTemporaryInHierarchy := OrderedCollection new. - aClass withAllSubclassesDo: [ :subclass | - methodsDefiningTemporaryInHierarchy addAll: (subclass methodsWithArgumentOrTemporaryNamed: aTemporaryVariableName) - ]. - - methodsDefiningTemporaryInHierarchy size > 1 ifTrue: [ - self refactoringError: self temporaryExistsInOtherMethodsErrorDescription. - ].! ! -!TemporaryToInstanceVariable class methodsFor: 'assertions' stamp: 'EB 5/17/2019 13:29:19'! - assertSubclassesOf: aClass haventGotInstanceVariableNamed: anInstanceVariableName - aClass allSubclassesDo: [ :subclass | - subclass instVarNames includes: anInstanceVariableName :: ifTrue: [ - self refactoringError: self temporaryExistsAsInstVarInSubclassesErrorDescription. - ]. - ].! ! -!TemporaryToInstanceVariableApplier methodsFor: 'initialization' stamp: 'EB 5/17/2019 00:59:52'! - initializeOn: aSmalltalkEditor for: aTemporaryVariableName - smalltalkEditor := aSmalltalkEditor. - classToRefactor := smalltalkEditor codeProvider selectedClassOrMetaClass. - methodNode := classToRefactor methodNodeFor: smalltalkEditor actualContents string. - variableName := aTemporaryVariableName - ! ! -!TemporaryToInstanceVariableApplier methodsFor: 'refactoring - creation' stamp: 'EB 5/17/2019 00:58:32'! - createRefactoring - ^TemporaryToInstanceVariable named: variableName fromMethod: methodNode.! ! -!TemporaryToInstanceVariableApplier methodsFor: 'refactoring - parameters request' stamp: 'EB 5/17/2019 01:01:08'! - requestRefactoringParameters - ! ! -!TemporaryToInstanceVariableApplier methodsFor: 'refactoring - changes' stamp: 'EB 5/17/2019 13:08:22'! - showChanges - smalltalkEditor actualContents: changes. - ! ! -!TemporaryToInstanceVariableApplier class methodsFor: 'as yet unclassified' stamp: 'EB 5/17/2019 00:59:39'! - on: aSmalltalkEditor for: aTemporaryVariableName - - ^self new initializeOn: aSmalltalkEditor for: aTemporaryVariableName! ! -!RefactoringMenues class methodsFor: 'editor menus' stamp: 'EB 5/17/2019 13:32:48' prior: 50442425! -smalltalkEditorMenuOptions - - ^`{ - { - #itemGroup -> 35. - #itemOrder -> 10. - #label -> 'Rename... (R)'. - #selector -> #contextualRename. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 10. - #label -> 'Temporary to Instance Variable (P)'. - #selector -> #temporaryToInstanceVariable. - #icon -> #saveAsIcon - } asDictionary. - - }`! ! -!RefactoringMenues class methodsFor: 'shortcuts' stamp: 'EB 5/17/2019 13:21:27' prior: 50442534! - smalltalkEditorCmdShortcutsSpec - - ^#( - #( $R #contextualRename: 'Renames what is under cursor') - #( $P #temporaryToInstanceVariable: 'Extracts temporary variable to instance variable')) -! ! - -SmalltalkEditor removeSelector: #withNodeUnderCursorInside:do:ifAbsent:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3751-TemporaryToInstanceVariable-EricBrandwein-2019May03-18h48m-EB.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3751] on 19 May 2019 at 5:39:14 pm'! -!SmalltalkEditor methodsFor: 'temp to inst var' stamp: 'HAW 5/19/2019 17:27:10' prior: 50459228! - temporaryToInstanceVariable - - self - withNodeUnderCursorDo: [ :nodeUnderCursor | - nodeUnderCursor isTemp - ifTrue: [ TemporaryToInstanceVariableApplier on: self for: nodeUnderCursor name :: value ] - ifFalse: [ morph flash ]] - ifAbsent: [ morph flash ].! ! -!SmalltalkEditor methodsFor: 'temp to inst var' stamp: 'HAW 5/19/2019 17:38:26' prior: 50459239! - temporaryToInstanceVariable: aKeyboardEvent - - self temporaryToInstanceVariable. - - ^true.! ! -!SmalltalkEditor methodsFor: 'temp to inst var' stamp: 'HAW 5/19/2019 17:27:59' prior: 50459245! - withNodeUnderCursorDo: aDoBlock ifAbsent: anAbsentBlock - - self - withMethodNodeAndClassDo: [ :currentMethodNode :currentClass | - currentMethodNode - withParseNodeIncluding: self startIndex - do: aDoBlock - ifAbsent: anAbsentBlock ] - ifErrorsParsing: [ :arg1 | anAbsentBlock value ].! ! -!TemporaryToInstanceVariable methodsFor: 'applying' stamp: 'HAW 5/19/2019 17:26:03' prior: 50459264! - addInstanceVariable - - AddInstanceVariable named: variable to: method methodClass :: apply.! ! -!TemporaryToInstanceVariable methodsFor: 'applying' stamp: 'HAW 5/19/2019 17:25:59' prior: 50459270! - apply - - | newSourceCode | - - newSourceCode _ self removeTemporary. - self addInstanceVariable. - - ^newSourceCode.! ! -!TemporaryToInstanceVariable methodsFor: 'applying' stamp: 'HAW 5/19/2019 17:26:16' prior: 50459277! - removeTemporary - - | temporaryVariablePositions newSourceCode variableDeclarationPosition | - - temporaryVariablePositions _ method positionsForTemporaryVariable: variable ifAbsent: []. - variableDeclarationPosition _ {temporaryVariablePositions first}. - newSourceCode _ method sourceText copyReplacing: variableDeclarationPosition with: ''. - method methodClass compile: newSourceCode. - - ^newSourceCode. - ! ! -!TemporaryToInstanceVariable class methodsFor: 'instance creation' stamp: 'HAW 5/19/2019 17:23:35' prior: 50459293! - named: aTemporaryVariableName fromMethod: aMethodNode - - | methodClass | - - methodClass _ aMethodNode methodClass. - - self assert: aMethodNode hasTemporaryNamed: aTemporaryVariableName. - self assertNoOtherMethodIn: methodClass orSubclassesDefinesTemporaryNamed: aTemporaryVariableName. - self assertSubclassesOf: methodClass haventGotInstanceVariableNamed: aTemporaryVariableName. - - ^self new initializeNamed: aTemporaryVariableName fromMethod: aMethodNode.! ! -!TemporaryToInstanceVariable class methodsFor: 'error descriptions' stamp: 'HAW 5/19/2019 17:23:40' prior: 50459311! - inexistentTemporaryErrorDescription - - ^'The temporary variable does not exist.'! ! -!TemporaryToInstanceVariable class methodsFor: 'error descriptions' stamp: 'HAW 5/19/2019 17:23:44' prior: 50459317! - temporaryExistsAsInstVarInSubclassesErrorDescription - - ^'The temporary variable exists as an instance variable in a subclass.'! ! -!TemporaryToInstanceVariable class methodsFor: 'error descriptions' stamp: 'HAW 5/19/2019 17:23:47' prior: 50459325! - temporaryExistsInOtherMethodsErrorDescription - - ^'Temporary variable exists in other methods; remove those first.'! ! -!TemporaryToInstanceVariable class methodsFor: 'assertions' stamp: 'HAW 5/19/2019 17:23:56' prior: 50459332! - assert: aMethodNode hasTemporaryNamed: aTemporaryVariableName - - aMethodNode hasLocalNamed: aTemporaryVariableName :: ifFalse: [ - self refactoringError: self inexistentTemporaryErrorDescription ].! ! -!TemporaryToInstanceVariable class methodsFor: 'assertions' stamp: 'HAW 5/19/2019 17:24:11' prior: 50459342! - assertNoOtherMethodIn: aClass orSubclassesDefinesTemporaryNamed: aTemporaryVariableName - - | methodsDefiningTemporaryInHierarchy | - - methodsDefiningTemporaryInHierarchy := OrderedCollection new. - aClass withAllSubclassesDo: [ :subclass | - methodsDefiningTemporaryInHierarchy addAll: (subclass methodsWithArgumentOrTemporaryNamed: aTemporaryVariableName) ]. - - methodsDefiningTemporaryInHierarchy size > 1 ifTrue: [ - self refactoringError: self temporaryExistsInOtherMethodsErrorDescription ].! ! -!TemporaryToInstanceVariable class methodsFor: 'assertions' stamp: 'HAW 5/19/2019 17:24:43' prior: 50459361! - assertSubclassesOf: aClass haventGotInstanceVariableNamed: anInstanceVariableName - - aClass allSubclassesDo: [ :subclass | - subclass instVarNames includes: anInstanceVariableName :: ifTrue: [ - self refactoringError: self temporaryExistsAsInstVarInSubclassesErrorDescription ]].! ! -!TemporaryToInstanceVariableApplier methodsFor: 'initialization' stamp: 'HAW 5/19/2019 17:28:47' prior: 50459374! - initializeOn: aSmalltalkEditor for: aTemporaryVariableName - - smalltalkEditor := aSmalltalkEditor. - classToRefactor := smalltalkEditor codeProvider selectedClassOrMetaClass. - methodNode := classToRefactor methodNodeFor: smalltalkEditor actualContents string. - variableName := aTemporaryVariableName - ! ! -!TemporaryToInstanceVariableApplier methodsFor: 'refactoring - creation' stamp: 'HAW 5/19/2019 17:26:37' prior: 50459387! - createRefactoring - - ^TemporaryToInstanceVariable named: variableName fromMethod: methodNode.! ! -!TemporaryToInstanceVariableApplier methodsFor: 'refactoring - changes' stamp: 'HAW 5/19/2019 17:29:06' prior: 50459399! - showChanges - - smalltalkEditor actualContents: changes. - ! ! -!RefactoringMenues class methodsFor: 'editor menus' stamp: 'HAW 5/19/2019 17:37:43' prior: 50459412! - smalltalkEditorMenuOptions - - ^`{ - { - #itemGroup -> 35. - #itemOrder -> 10. - #label -> 'Rename... (R)'. - #selector -> #contextualRename. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 10. - #label -> 'Temporary to Instance Variable (O)'. - #selector -> #temporaryToInstanceVariable. - #icon -> #saveAsIcon - } asDictionary. - - }`! ! -!RefactoringMenues class methodsFor: 'shortcuts' stamp: 'HAW 5/19/2019 17:38:03' prior: 50459429! - smalltalkEditorCmdShortcutsSpec - - ^#( - #( $R #contextualRename: 'Renames what is under cursor') - #( $O #temporaryToInstanceVariable: 'Extracts temporary variable to instance variable')) -! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3752-TemporaryToInstanceVariableFormattingChanges-HernanWilkinson-2019May19-17h23m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3741] on 12 May 2019 at 3:41:55 pm'! - -"Change Set: 3742-CuisCore-AuthorName-2019May11-16h02m -Date: 12 May 2019 -Author: Nahuel Garbezza - -Allow to delete words using ctrl/alt+backspace"! -!Editor methodsFor: 'typing/selecting keys' stamp: 'RNG 5/11/2019 16:34:48' prior: 16836665! - backspace: aKeyboardEvent - "Backspace over the last character." - "This is a user command, and generates undo" - - | startIndex | - (aKeyboardEvent rawMacOptionKeyPressed or: [ aKeyboardEvent controlKeyPressed ]) - ifTrue: [ ^ self backWord: aKeyboardEvent ]. - aKeyboardEvent shiftPressed - ifTrue: [ ^ self forwardDelete: aKeyboardEvent ]. - startIndex _ self markIndex + (self hasSelection ifTrue: [1] ifFalse: [0]). - startIndex _ 1 max: startIndex - 1. - self backTo: startIndex. - ^ false! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3753-backwardDelete-NahuelGarbezza-2019May11-16h02m-RNG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3726] on 7 May 2019 at 9:27:10 pm'! -!SystemDictionary methodsFor: 'ui' stamp: 'pb 5/7/2019 21:26:55'! - systemCategoryFromUserWithPrompt: aString - "Prompt the user to select an existing system category (i.e. the ones that appear in the top left pane in the Browser window)" - | allCats menuIndex | - allCats := self organization categories sorted. - menuIndex := (PopUpMenu labelArray: allCats) startUpWithCaption: aString. - ^ menuIndex = 0 ifTrue: [nil] ifFalse: [allCats at: menuIndex]! ! -!Browser methodsFor: 'system category functions' stamp: 'pb 5/7/2019 21:21:40'! - moveAllToOtherSystemCategory - "If a class category is selected, prompt user for category to move to, - create a Confirmer so the user can verify that all the classes in current category - should be moved to the selected category." - | newSystemCategory | - selectedSystemCategory ifNil: [ ^ self ]. - newSystemCategory _ Smalltalk systemCategoryFromUserWithPrompt: 'Move classes to System Category...'. - (newSystemCategory notNil and: [ - self classList size > 0 and: [ self confirm: 'Are you sure you want to -move classes from ' , selectedSystemCategory , ' -to ' , newSystemCategory , '?' ]]) ifTrue: [ - "Safer this way (#classList will be a collection of strings with spaces and who knows what in the future. So let's just get the classes we need directly)" - (SystemOrganization classesAt: selectedSystemCategory) do: [ :eaClass | - eaClass category: newSystemCategory ]. - self changed: #systemCategoryList ].! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'pb 5/7/2019 19:34:03' prior: 50445929! - systemCategoryMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'find class... (f)'. - #selector -> #findClass. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'recent classes... (r)'. - #object -> #model. - #selector -> #recent. - #icon -> #clockIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'browse all (B)'. - #selector -> #browseAllClasses. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'browse (b)'. - #selector -> #openSystemCategoryBrowser. - #icon -> #packageIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'fileOut (o)'. - #object -> #model. - #selector -> #fileOutSystemCategory. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'reorganize'. - #object -> #model. - #selector -> #editSystemCategories. - #icon -> #sendReceiveIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'alphabetize (A)'. - #object -> #model. - #selector -> #alphabetizeSystemCategories. - #icon -> #fontXGenericIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'update (u)'. - #object -> #model. - #selector -> #updateSystemCategories. - #icon -> #updateIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 20. - #label -> 'add item... (a)'. - #object -> #model. - #selector -> #addSystemCategory. - #icon -> #newIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'rename... (R)'. - #object -> #model. - #selector -> #renameSystemCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 35. - #label -> 'move to... (m)'. - #object -> #model. - #selector -> #moveAllToOtherSystemCategory. - #icon -> #saveAsIcon. - #balloonText -> 'Move all classes in this category to another category' - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 40. - #label -> 'remove (x)'. - #object -> #model. - #selector -> #removeSystemCategory. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'move to top'. - #object -> #model. - #selector -> #moveSystemCategoryTop. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 20. - #label -> 'move up'. - #object -> #model. - #selector -> #moveSystemCategoryUp. - #icon -> #goUpIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 30. - #label -> 'move down'. - #object -> #model. - #selector -> #moveSystemCategoryDown. - #icon -> #goDownIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 40. - #label -> 'move to bottom'. - #object -> #model. - #selector -> #moveSystemCategoryBottom. - #icon -> #goBottomIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 10. - #label -> 'run tests (t)'. - #object -> #model. - #selector -> #runSystemCategoryTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - }`. - ! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3754-SystemCategoryMoveTo-PhilBellalouna-2019May07-19h31m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3751] on 19 May 2019 at 6:28:54 pm'! -!TextModelMorph methodsFor: 'drawing' stamp: 'jmv 5/19/2019 17:45:47' prior: 50454298! - drawOn: aCanvas - "Include a thin red inset border for unaccepted edits, or, if the unaccepted edits are known to conflict with a change made somewhere else to the same method (typically), put a thick red frame" - | bw bc | - self flag: #todo. - "Integrate this method with the Theme system. --cbr" - super drawOn: aCanvas. - bw _ Preferences focusIndicatorWidth. - bc _ nil. - self wantsFrameAdornments ifTrue: [ - model refusesToAccept - ifTrue: [ "Put up feedback showing that code cannot be submitted in this state" - bc _ Color tan ] - ifFalse: [ - self textMorph hasEditingConflicts - ifTrue: [ - bw _ 3. - bc _ Color red ] - ifFalse: [ - self textMorph hasUnacceptedEdits ifTrue: [ bc _ Color red ]]]]. - (drawKeyboardFocusIndicator and: [ self textMorph hasKeyboardFocus ]) - ifTrue: [ bc ifNil: [ bc _ Theme current focusIndicator ]] - ifFalse: [ - bc ifNotNil: [ - bc _ bc - alphaMixed: 0.4 - with: Color white ]]. - bc ifNotNil: [ - aCanvas - frameRectangle: self focusIndicatorRectangle - borderWidth: bw - color: bc ]. - model actualContents isEmpty ifTrue: [ - self - valueOfProperty: #emptyTextDisplayMessage - ifPresentDo: [ :msg | - aCanvas - drawString: msg - at: self xtraBorder @ self xtraBorder - font: nil - color: Theme current textEmptyDisplayMessage ]].! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3755-RepositionEmptyTextMessage-JuanVuletich-2019May19-18h28m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3754] on 20 May 2019 at 9:27:06 am'! -!GeometryTransformation methodsFor: 'converting coordinates' stamp: 'jmv 5/20/2019 08:57:05'! - externalizeRectangle: aRectangle - ^ (self transform: aRectangle origin) corner: (self transform: aRectangle corner)! ! -!Rectangle methodsFor: 'truncation and round off' stamp: 'jmv 5/20/2019 09:03:53' prior: 16898920! - rounded - "Answer a Rectangle whose origin and corner are rounded." - - ^Rectangle origin: origin rounded corner: self corner rounded! ! -!BitBltCanvas methodsFor: 'drawing-ovals' stamp: 'jmv 5/20/2019 09:22:30' prior: 16786642! - ellipseCenterX: mcx y: mcy rx: mrx ry: mry borderWidth: mbw borderColor: mbc fillColor: morphFillColor - - | displayRectangle doBorder doFill | - doBorder _ mbw > 0 and: [ mbc isTransparent not]. - doFill _ morphFillColor isTransparent not. - doBorder | doFill ifTrue: [ - displayRectangle _ (currentTransformation externalizeRectangle: (Rectangle center: mcx@mcy extent: mrx@mry * 2)) rounded. - "draw the border of the oval" - doBorder ifTrue: [ - self setPaintColor: mbc. - port frameOval: displayRectangle borderWidth: mbw]. - "fill the inside" - doFill ifTrue: [ - self setPaintColor: morphFillColor. - port fillOval: (displayRectangle insetBy: mbw) ]]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 5/20/2019 09:06:52' prior: 16786715! - frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor - | rect bw | - - r area = 0 ifTrue: [ ^self ]. - rect _ (currentTransformation externalizeRectangle: r) rounded. - bw _ currentTransformation externalizeScalar: borderWidth. - - "draw the border of the rectangle" - borderColor isTransparent ifFalse: [ - self setPaintColor: borderColor. - port frameRect: rect borderWidth: bw ]. - - "fill the inside" - fillColor isTransparent ifFalse: [ - self setPaintColor: fillColor. - port fillRect: (rect insetBy: bw) ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 5/20/2019 09:23:54' prior: 16786735! - frameRectangle: r borderWidth: borderWidth color: borderColor - " - Display getCanvas - frameRectangle: (10@10 extent: 300@200) - borderWidth: 20 - color: Color red. - Display forceToScreen - " - | rect bw | - (borderWidth > 0 and: [ borderColor isTransparent not ]) ifTrue: [ - rect _ (currentTransformation externalizeRectangle: r) rounded. - bw _ currentTransformation externalizeScalar: borderWidth. - self setPaintColor: borderColor. - port - frameRect: rect - borderWidth: bw ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 5/20/2019 09:24:39' prior: 16786753! - frameRectangle: r color: aColor borderWidth: borderWidth borderStyleSymbol: aSymbol - " - Display getCanvas fillRectangle: (10@10 extent: 300@200) color: Color white. Display forceToScreen. - Display getCanvas - frameRectangle: (10@10 extent: 300@200) - color: Color green - borderWidth: 10 - borderStyleSymbol: #raised. - Display forceToScreen. - " - - | displayRectangle bw | - bw _ (currentTransformation externalizeScalar: borderWidth) rounded. - aSymbol == #raised ifTrue: [ - displayRectangle _ (currentTransformation externalizeRectangle: r) rounded. - ^ self - frameRectangle: displayRectangle - borderWidth: bw - topLeftColor: aColor quiteWhiter - bottomRightColor: aColor quiteBlacker ]. - - aSymbol == #inset ifTrue: [ - displayRectangle _ (currentTransformation externalizeRectangle: r) rounded. - ^ self - frameRectangle: displayRectangle - borderWidth: bw - topLeftColor: aColor quiteBlacker - bottomRightColor: aColor quiteWhiter ]. - - "Unrecognized border style. Draw some border..." - self frameRectangle: r borderWidth: bw color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 5/20/2019 09:25:08' prior: 50388634! - reverseRectangleBorder: r borderWidth: borderWidth - " - Display getCanvas - reverseRectangleBorder: (10@10 extent: 300@200) - borderWidth: 20. - Display forceToScreen - " - | rect | - rect _ (currentTransformation externalizeRectangle: r) rounded. - port - sourceForm: nil; - fillColor: `Color gray`; - combinationRule: Form reverse; - frameRect: rect borderWidth: borderWidth! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 5/20/2019 09:23:29' prior: 50385961! - fillRectangle: aRectangle tilingWith: aForm sourceRect: patternBox rule: aCombinationRule - - | displayRectangle additionalOffset clippedPort targetTopLeft clipOffset ex - targetBox savedMap top left | - - ex _ patternBox extent. - ex x = 0 ifTrue: [ ^self ]. - ex y = 0 ifTrue: [ ^self ]. - displayRectangle _ (currentTransformation externalizeRectangle: aRectangle) rounded. - - "this is a bit of a kludge to get the form to be aligned where I *think* it should be. - something better is needed, but not now" - - additionalOffset _ `0@0`. - clippedPort _ port clippedBy: displayRectangle. - targetTopLeft _ clippedPort clipRect topLeft truncateTo: ex. - clipOffset _ displayRectangle topLeft - targetTopLeft. - additionalOffset _ (clipOffset \\ ex) - ex. - - "do it iteratively" - targetBox _ clippedPort clipRect. - savedMap _ clippedPort colorMap. - clippedPort sourceForm: aForm; - fillColor: nil; - combinationRule: aCombinationRule; - sourceRect: patternBox; - colorMap: (aForm colormapIfNeededFor: clippedPort destForm). - top _ (targetBox top truncateTo: patternBox height) + additionalOffset y. - left _ (targetBox left truncateTo: patternBox width) + additionalOffset x. - - left to: (targetBox right - 1) by: patternBox width do: [:x | - top to: (targetBox bottom - 1) by: patternBox height do: [:y | - clippedPort destOrigin: x@y; copyBits]]. - clippedPort colorMap: savedMap! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3756-BitBltCanvas-roundRectangles-JuanVuletich-2019May20-09h20m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3754] on 20 May 2019 at 9:50:16 am'! -!AbstractFont methodsFor: 'accessing' stamp: 'jmv 5/19/2019 18:42:54'! - leftOffsetAt: aCharacter - ^ 0! ! -!AbstractFont methodsFor: 'accessing' stamp: 'jmv 5/20/2019 09:46:22'! - rightOffsetAt: aCharacter - ^ 0! ! -!CharacterScanner methodsFor: 'scanning' stamp: 'jmv 5/20/2019 09:49:18' prior: 16802018! - scanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernValue - "Primitive. This is the inner loop of text display--but see - scanCharactersFrom: to:rightX: which would get the string, - stopConditions and displaying from the instance. March through source - String from startIndex to stopIndex. If any character is flagged with a - non-nil entry in stops, then return the corresponding value. Determine - width of each character from xTable, indexed by map. - If dextX would exceed rightX, then return stops at: 258. - Advance destX by the width of the character. If stopIndex has been - reached, then return stops at: 257. Optional. - See Object documentation whatIsAPrimitive." - | nextDestX char rightOffset | - - lastIndex _ startIndex. - [ lastIndex <= stopIndex ] - whileTrue: [ - char _ sourceString at: lastIndex. - "stops are only defined for the first 256 characters. - If we (ever) handle Character like objects beyond those in ISO-8859-15, - thenf #iso8859s15Code shound answer nil!!" - char iso8859s15Code ifNotNil: [ :code | - (stops at: code + 1) ifNotNil: [ :stop | ^stop ]]. - nextDestX _ destX + (font widthOf: char). - rightOffset _ font rightOffsetAt: char. - nextDestX + rightOffset > rightX ifTrue: [ - ^stops at: CharacterScanner crossedXCode ]. - destX _ nextDestX. - lastIndex _ lastIndex + 1 ]. - lastIndex _ stopIndex. - ^ stops at: CharacterScanner endOfRunCode! ! -!CompositionScanner methodsFor: 'scanning' stamp: 'jmv 5/20/2019 09:35:12' prior: 50410605! - composeFrom: startIndex inRectangle: lineRectangle firstLine: firstLine leftSide: leftSide rightSide: rightSide - - "Answer an instance of TextLineInterval that represents the next line in the paragraph." - | runLength stopCondition xtraSpaceBefore spaceAfterParagraph | - - lastTabIndex _ lastIndex _ startIndex. "scanning sets last index" - destY _ lineRectangle top. - lineHeight _ baseline _ 0. "Will be increased by setFont" - self setFont. - self setStopConditions. - - "Set up margins" - leftMargin _ lineRectangle left. - leftSide ifTrue: [ - leftMargin _ leftMargin - (font leftOffsetAt: (text string at: lastIndex)) ]. - rightMargin _ lineRectangle right. - xtraSpaceBefore _ 0. - spaceAfterParagraph _ 0. - paragraphStyle ifNotNil: [ - leftSide ifTrue: [ - leftMargin _ leftMargin + - ((firstLine and: [ paragraphStyle isListStyle not ]) - ifTrue: [ paragraphStyle firstIndent ] - ifFalse: [ paragraphStyle restIndent ])]. - rightSide ifTrue: [ - rightMargin _ rightMargin - paragraphStyle rightIndent]. - firstLine ifTrue: [ xtraSpaceBefore _ paragraphStyle spaceBefore ]. - spaceAfterParagraph _ paragraphStyle spaceAfter ]. - lastTabX _ destX _ spaceX _ leftMargin. - - runLength _ text runLengthFor: startIndex. - runStopIndex _ lastIndex + runLength - 1. - line _ (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0) - rectangle: lineRectangle. - line isFirstLine: firstLine. - spaceCount _ 0. - lastLineBreakingSpace _ 0. - leftMargin _ destX. - line leftMargin: leftMargin. - - self placeEmbeddedObject. - [ - stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex - in: text string rightX: rightMargin stopConditions: stopConditions - kern: font baseKern. - "See setStopConditions for stopping conditions for composing." - (self perform: stopCondition) ifTrue: [ - ^ line - lineHeight: lineHeight + xtraSpaceBefore + - (stopCondition == #doNewLine ifTrue: [spaceAfterParagraph] ifFalse: [0]) - baseline: baseline + xtraSpaceBefore ] - ] repeat! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3757-honorLeftAndRightOffsetOfGlyphs-JuanVuletich-2019May20-09h27m-jmv.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3757] on 21 May 2019 at 12:10:25 pm'! -!Morph methodsFor: 'meta-actions' stamp: 'KenD 5/8/2019 20:51:33' prior: 16876423! - potentialEmbeddingTargets - "Return the potential targets for embedding the receiver" - | myRect myWorld | - owner ifNil:[^#()]. - myWorld := owner world ifNil:[^#()]. - myRect := self morphBoundsInWorld. - ^myWorld submorphs select: [ :m | - m isReallyVisible - and: [ m isLocked not - and: [(m morphBoundsInWorld intersects: myRect) - and: [(m ~= self) - and: [(m isKindOf: HaloMorph) not]]]] - ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3758-potentialEmbeddingTargets-KenDickey-2019May21-12h09m-KenD.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3754] on 19 May 2019 at 8:10:56 pm'! - -"Change Set: 3755-CuisCore-AuthorName-2019May19-19h59m -Date: 19 May 2019 -Author: Nahuel Garbezza - -Delete words forward using Ctrl+Del on Win/Linux and Option-Del in Mac"! -!TextEditor methodsFor: 'private' stamp: 'RNG 5/19/2019 20:02:41'! - shouldDeleteAWordForward: aKeyboardEvent - - ^ aKeyboardEvent isDelete and: [ - aKeyboardEvent rawMacOptionKeyPressed or: [ - aKeyboardEvent controlKeyPressed ] ]! ! -!TextEditor methodsFor: 'private' stamp: 'RNG 5/19/2019 20:09:09'! - shouldHandleUsingCmdShortcuts: aKeyboardEvent - ^ (aKeyboardEvent keyValue between: 32 and: 126) and: [ aKeyboardEvent commandAltKeyPressed ]! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'RNG 5/19/2019 20:01:06'! - isDelete - - ^ keyValue = 127! ! -!TextEditor methodsFor: 'typing support' stamp: 'RNG 5/19/2019 20:09:09' prior: 16932450! - dispatchOn: aKeyboardEvent - "Carry out the action associated with this character, if any." - - | asciiValue c | - self clearParens. - asciiValue _ aKeyboardEvent keyValue. - "Control keys are handled by #shortcuts even if they have any modifiers" - (self shouldHandleUsingCmdShortcuts: aKeyboardEvent) ifTrue: [ - ^self perform: (self cmdShortcuts at: asciiValue + 1) with: aKeyboardEvent ]. - - c _ aKeyboardEvent keyCharacter. - (')]}' includes: c) - ifTrue: [ self blinkPrevParen: c ]. - - ^ self perform: (self shortcuts at: asciiValue + 1) with: aKeyboardEvent! ! -!TextEditor methodsFor: 'typing/selecting keys' stamp: 'RNG 5/19/2019 20:02:24' prior: 50367283! - forwardDelete: aKeyboardEvent - "Delete forward over the next character." - "This is a user command, and generates undo" - - | startIndex stopIndex | - - "If there was a selection" - self hasSelection ifTrue: [ - self replaceSelectionWith: self nullText. - ^ false]. - - "Exit if at end" - startIndex _ self markIndex. - startIndex > model textSize ifTrue: [ - ^ false]. - - "Null selection - do the delete forward" - stopIndex _ startIndex. - (self shouldDeleteAWordForward: aKeyboardEvent) - ifTrue: [stopIndex := (self nextWordStart: stopIndex) - 1]. - self selectFrom: startIndex to: stopIndex. - self replaceSelectionWith: self nullText. - self deselectAndPlaceCursorAt: startIndex. - ^false! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3759-forwardDelete-NahuelGarbezza-2019May19-19h59m-RNG.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3740] on 10 May 2019 at 12:46:11 pm'! -!NewClassPrecondition methodsFor: 'evaluating - private' stamp: 'HAW 5/10/2019 12:24:16'! - assertNewClassNameIsNotDeclaredInUndeclared - - (undeclared includesKey: newClassName) ifTrue: [ self signalNewClassIsUndeclared]! ! -!NewClassPrecondition methodsFor: 'evaluating - private' stamp: 'HAW 5/10/2019 12:30:59'! - assertNewClassNameStartsWithRightLetter - - newClassName first isUppercase ifFalse: [ self signalNewNameMustStartWithRightLetter]! ! -!NewClassPrecondition methodsFor: 'exceptions' stamp: 'HAW 5/10/2019 12:31:44'! - signalNewNameMustStartWithRightLetter - - self refactoringError: self class newNameMustStartWithRightLetterErrorMessage.! ! -!NewClassPrecondition class methodsFor: 'error messages' stamp: 'HAW 5/10/2019 12:31:44'! - newNameMustStartWithRightLetterErrorMessage - - ^'New class name must start with an uppercase letter'! ! -!NewClassPrecondition methodsFor: 'evaluating' stamp: 'HAW 5/10/2019 12:24:16' prior: 50442551! - value - - self assertNewClassNameIsNotEmpty. - self assertNewClassNameSymbol. - self assertNewClassNameStartsWithRightLetter. - self assertNewClassNameHasNoSeparators. - self assertNewClassNameDoesNotExistInSystem. - self assertNewClassNameIsNotDeclaredInUndeclared. - -! ! - -NewClassPrecondition class removeSelector: #newNameMustStartWithUppercaseLetterErrorMessage! - -NewClassPrecondition class removeSelector: #newNameMustStartWithUppercaseLetterErrorMessage! - -NewClassPrecondition removeSelector: #assertNewClassNameIsNotUndeclaredInUndeclared! - -NewClassPrecondition removeSelector: #assertNewClassNameIsNotUndeclaredInUndeclared! - -NewClassPrecondition removeSelector: #assertNewClassNameStartsWithUppercaseLetter! - -NewClassPrecondition removeSelector: #assertNewClassNameStartsWithUppercaseLetter! - -NewClassPrecondition removeSelector: #signalNewNameMustStartWithUppercaseLetter! - -NewClassPrecondition removeSelector: #signalNewNameMustStartWithUppercaseLetter! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3760-NewClassPreconditionRefactoring-HernanWilkinson-2019May05-19h58m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3754] on 15 May 2019 at 4:46:46 pm'! -!Array methodsFor: 'converting' stamp: 'len 5/15/2019 16:43:02' prior: 50428695! - elementsExchangeIdentityWith: otherArray - "This primitive performs a bulk mutation, causing all pointers to the elements of the - receiver 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. - - Warning. This is a dangerous operation and it could lead to a crash if some object in receiver or argument is receiver of a method currently in execution. See #anyReceiverInStackIn: See senders for examples." - - - ec == #'bad receiver' ifTrue: - [^self error: 'receiver must be of class Array']. - ec == #'bad argument' ifTrue: - [^self error: (otherArray class == Array - ifTrue: ['arg must be of class Array'] - ifFalse: ['receiver and argument must have the same size'])]. - ec == #'inappropriate operation' ifTrue: - [^self error: 'can''t become immediates such as SmallIntegers or Characters']. - ec == #'no modification' ifTrue: - [^self error: 'can''t become immutable objects']. - ec == #'object is pinned' ifTrue: - [^self error: 'can''t become pinned objects']. - ec == #'insufficient object memory' ifTrue: - [| maxRequired | - "In Spur, two-way become may involve making each pair of objects into a forwarder into a copy of the other. - So if become fails with #'insufficient object memory', garbage collect, and if necessary, grow memory." - maxRequired := (self sum: [:obj | obj class byteSizeOfInstanceOfSize: obj basicSize] ifEmpty: [0]) - + (otherArray sum: [:obj | obj class byteSizeOfInstanceOfSize: obj basicSize] ifEmpty: [0]). - (Smalltalk garbageCollectMost < maxRequired - and: [Smalltalk garbageCollect < maxRequired]) ifTrue: - [Smalltalk growMemoryByAtLeast: maxRequired]. - ^self elementsExchangeIdentityWith: otherArray]. - self primitiveFailed! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'len 5/15/2019 16:43:26' prior: 50365876! - macroBenchmark1 "Smalltalk macroBenchmark1" - "Decompiles and prettyPrints the source for every method in the system (or less depending on the *FILTER*, and then compiles that source and verifies that it generates (and decompiles to) identical code. This currently fails in a number of places because some different patterns (esp involving conditionals where the first branch returns) decompile the same. Because it never installs the new method, it should not cause any flusing of the method cache." - | methodNode oldMethod newMethod badOnes oldCodeString n classes | - classes _ Smalltalk allClasses select: [:c | c name < 'B3']. - badOnes _ OrderedCollection new. -'Decompiling and recompiling...' -displayProgressAt: Sensor mousePoint -from: 0 to: (classes sum: [:c | c selectors size] ifEmpty: [0]) -during: [:barBlock | n _ 0. - classes do: - [:cls | - "Transcript cr; show: cls name." - cls selectors do: - [:selector | barBlock value: (n _ n+1). - oldMethod _ cls compiledMethodAt: selector. - oldCodeString _ (cls decompilerClass new - decompile: selector in: cls method: oldMethod) - decompileString. - methodNode _ cls compilerClass new - compile: oldCodeString - in: cls notifying: nil ifFail: nil. - newMethod _ methodNode generate: #(0 0 0 0). - oldCodeString = (cls decompilerClass new - decompile: selector in: cls method: newMethod) - decompileString ifFalse: [badOnes add: cls name , ' ' , selector]]]. -]. - ^ badOnes size! ! - -Collection removeSelector: #detectSum:! - -Collection removeSelector: #detectSum:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3761-detectSumRemoval-LucianoEstebanNotarfrancesco-2019May15-16h43m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3761] on 23 May 2019 at 8:48:15 am'! -!Parser methodsFor: 'expression types' stamp: 'HAW 5/23/2019 08:42:06' prior: 16886009! - braceExpression - " { elements } => BraceNode." - - | elements locations loc more sourceRangeStart sourceRangeEnd | - - sourceRangeStart _ hereMark. - elements := OrderedCollection new. - locations := OrderedCollection new. - self advance. - more := hereType ~~ #rightBrace. - [more] - whileTrue: - [loc := hereMark + requestorOffset. - self expression - ifTrue: - [elements addLast: parseNode. - locations addLast: loc] - ifFalse: - [^self expected: 'Variable or expression or right brace']. - (self match: #period) - ifTrue: [more := hereType ~~ #rightBrace] - ifFalse: [more := false]]. - parseNode := BraceNode new elements: elements sourceLocations: locations. - sourceRangeEnd _ hereEnd. - - (self match: #rightBrace) ifFalse: [^self expected: 'Period or right brace']. - encoder noteSourceRange: (sourceRangeStart to: sourceRangeEnd) forNode: parseNode. - - ^true! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3762-SourceRangeBraceNode-NahuelGarvezzaHernanWilkinson-2019May23-08h40m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3763] on 23 May 2019 at 10:45:10 am'! -!CompiledMethod methodsFor: 'ometa2preload' stamp: 'jmv 5/23/2019 10:44:49' prior: 50444907! - createMethodNode - "Creates the parse tree that represents self" - | aClass source | - aClass := self methodClass. - source := self - getSourceFor: (self selector ifNil: [ self defaultSelector ]) - in: aClass. - "OMeta2 (and maybe others) could do source code transformations that mean #methodNodeFor: could fail." - ^ (aClass methodNodeFor: source) ifNil: [ self decompile ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3763-HelpOMeta2-JuanVuletich-2019May23-10h40m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3763] on 24 May 2019 at 10:05:57 am'! -!TestRunnerWindow methodsFor: 'GUI building' stamp: 'jmv 5/24/2019 10:04:35' prior: 16928625! - buildUpperControls - | refreshButton filterButton stopButton runOneButton runButton runProfiledButton row column1 column2 column3 theTestsList | - - refreshButton _ self buildRefreshButton. - filterButton _ self buildFilterButton. - stopButton _ self buildStopButton. - column1 _ LayoutMorph newColumn. - column1 doAdoptWidgetsColor. - column1 addMorphs: { refreshButton . filterButton . stopButton }. - - theTestsList _ PluggableListMorphOfMany - model: model - listGetter: #tests - primarySelectionGetter: #selectedSuite - primarySelectionSetter: #selectedSuite: - listSelectionGetter: #listSelectionAt: - listSelectionSetter: #listSelectionAt:put: - mainView: self - menuGetter: #listMenu - keystrokeAction: nil. - theTestsList autoDeselect: false. - theTestsList color: self textBackgroundColor. - column2 _ LayoutMorph newColumn. - column2 - addMorph: theTestsList proportionalHeight: 1; - addMorph: self optionalButtonRow fixedHeight: self defaultButtonPaneHeight. - - runOneButton _ self buildRunOneButton. - runButton _ self buildRunButton. - runProfiledButton := self buildRunProfiledButton. - column3 _ LayoutMorph newColumn. - column3 doAdoptWidgetsColor. - column3 addMorphs: { runOneButton . runButton . runProfiledButton }. - - row _ LayoutMorph newRow. - row - addMorph: column1 proportionalWidth: 0.1; - addMorph: column2 proportionalWidth: 0.7; - addMorph: column3 proportionalWidth: 0.2. - - ^row - -! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3764-TestRunnerButtonsLayoutFix-JuanVuletich-2019May24-10h03m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3763] on 24 May 2019 at 10:19:06 am'! -!Encoder methodsFor: 'source mapping' stamp: 'jmv 5/23/2019 09:49:51'! - rangeForNode: node ifAbsent: aBlock - - ^sourceRanges at: node ifAbsent: aBlock! ! -!MessageNode methodsFor: 'source ranges' stamp: 'jmv 5/23/2019 10:05:52'! - keywordAndParameterPositionAt: anIndex encodedWith: anEncoder ifAbsent: aBlock - - | keywordPosition parameterLastPosition | - - keywordPosition := keywordRanges at: anIndex. - parameterLastPosition := anIndex = arguments size - ifTrue: [ (anEncoder rangeForNode: self ifAbsent: aBlock) last ] - ifFalse: [ (keywordRanges at: anIndex + 1) first - 1]. - - ^keywordPosition first to: parameterLastPosition! ! -!MethodNode methodsFor: 'source mapping' stamp: 'jmv 5/23/2019 09:50:16'! - rangeForNode: node ifAbsent: aBlock - - ^encoder rangeForNode: node ifAbsent: aBlock! ! -!CompiledMethod methodsFor: 'source code ranges' stamp: 'HAW 5/24/2019 09:41:50' prior: 50452612! - messageSendsRangesOf: aSentSelector - - | methodNode ranges | - - methodNode := self methodNode. - ranges := OrderedCollection new. - - methodNode nodesDo: [ :aParseNode | - (aParseNode isMessageNamed: aSentSelector) ifTrue: [ - ranges add: (methodNode - rangeForNode: aParseNode - ifAbsent: [ self error: 'should not happen. aParseNode is part of the methodNode'])]]. - - ^ranges ! ! -!Encoder methodsFor: 'source mapping' stamp: 'jmv 5/23/2019 10:06:08' prior: 50443366! - messageSendKeywordAndParameterPositionsAt: anIndex of: aSelector ifAbsent: aBlock - - | positions | - - positions := sourceRanges keys - select: [ :aParseNode | aParseNode isMessageNamed: aSelector ] - thenCollect: [ :aMessageSendNode | aMessageSendNode keywordAndParameterPositionAt: anIndex encodedWith: self ifAbsent: aBlock]. - - ^ positions isEmpty - ifTrue: aBlock - ifFalse: [ positions ] - ! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 5/24/2019 09:36:14' prior: 50443427! - parameterDefinitionPositionFor: aParameterNode - - ^ (self rangeForNode: aParameterNode ifAbsent: [ self error: 'invalid parameter node' ]) first! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 5/24/2019 09:57:00' prior: 50419602! - selectorLastPosition - - "If #DoIt selector, returns 0 - Hernan" - - ^self selector isUnary - ifTrue: [ selectorKeywordsRanges ifNil: [ 0 ] ifNotNil: [ selectorKeywordsRanges last last ]] - ifFalse: [ - (encoder - rangeForNode: arguments last - ifAbsent: [ self error: 'Should not happen. arguments is part of the encoder' ]) first last ]! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'testing' stamp: 'jmv 5/23/2019 09:51:43' prior: 50452241! - isAtClassName: anIndex - - ^(classDefinitionNode rangeForNode: classCreationMessageNode arguments first ifAbsent: [ ^ false ]) first includes: anIndex! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'testing' stamp: 'jmv 5/23/2019 09:51:59' prior: 50452255! - isAtSuperclass: anIndex - - ^(classDefinitionNode rangeForNode: superClassNode ifAbsent: [ ^ false ]) first includes: anIndex! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'testing - private' stamp: 'jmv 5/23/2019 09:51:14' prior: 50452267! - is: anIndex atStringParameterNumber: aParameterPosition - - | parameterRange | - - parameterRange := (classDefinitionNode rangeForNode: (classCreationMessageNode arguments at: aParameterPosition) ifAbsent: [ ^ false ]) first. - - ^anIndex between: parameterRange first + 1 and: parameterRange last - 1! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'jmv 5/23/2019 10:09:52' prior: 50452879! - selectMessageNode: aMessageNodeUnderCursor in: aMethodNode - - | messageRange | - - self - withReceiverRangeOf: aMessageNodeUnderCursor - in: aMethodNode - selectorPosition: self startIndex - do: [ :receiverRange | - messageRange := aMethodNode rangeForNode: aMessageNodeUnderCursor ifAbsent: [ ^ self ]. - self selectFrom: receiverRange first to: messageRange last ] - - ! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'jmv 5/23/2019 10:10:12' prior: 50452893! - selectNodeRange: aNodeUnderCursor in: aMethodNode - - | range ranges | - - ranges := aMethodNode rangeForNode: aNodeUnderCursor ifAbsent: [ ^ self ]. - range := (aMethodNode isMultipleRanges: ranges) - ifTrue: [ ranges detect: [ :aRange | aRange includes: self startIndex ] ifNone: [ ^self ]] - ifFalse: [ ranges ]. - - self selectFrom: range first to: range last -! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'jmv 5/23/2019 10:10:22' prior: 50452916! - withReceiverRangeOf: aMessageNode in: aMethodNode selectorPosition: aSelectorPosition do: aBlock - - | receiverRange receiverRangeOrRanges messageNodeReceiver | - - "If aMessageNode receiver isNil it means that it is a cascade receiver so this imposes the question on how to inspect - a cascade message send. We could inspect the result of sending all the messages up to the cursor but the problem is - that when looking for the cascade receiver range it does not find it because it is a different node that the used in the source - ranges... we could do the trick of looking for printString in the sourceRanges keys, but that is too much - Hernan" - aMessageNode isCascade ifFalse: [ - messageNodeReceiver := aMessageNode receiver. - messageNodeReceiver isMessageNode ifTrue: [ - ^self withReceiverRangeOf: messageNodeReceiver in: aMethodNode selectorPosition: (messageNodeReceiver keywordPositionAt: 1) first do: aBlock ]. - - receiverRangeOrRanges := aMethodNode rangeForNode: messageNodeReceiver ifAbsent: [ ^ self ]. - - receiverRange := (aMethodNode isMultipleRanges: receiverRangeOrRanges) - ifTrue: [ | closestRange | - closestRange := receiverRangeOrRanges first. - receiverRangeOrRanges do: [ :aRange | (aRange last < aSelectorPosition and: [ aRange last > closestRange last ]) ifTrue: [ closestRange := aRange ]]. - closestRange ] - ifFalse: [ receiverRangeOrRanges ]. - - aBlock value: receiverRange ]! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 5/24/2019 10:14:31' prior: 50439241! - assertIsValidParameterName: aName - - | scannedNames | - - scannedNames _ [ Scanner new scanFieldNames: aName ] - on: Error - do: [ :anError | self signalInvalidParameterName: aName ]. - scannedNames size = 1 ifFalse: [ self signalInvalidParameterName: aName ]. - scannedNames first = aName ifFalse: [ self signalInvalidParameterName: aName ]. -! ! - -MethodNode removeSelector: #sourceRangeFor:! - -MethodNode removeSelector: #sourceRangeFor:! - -MessageNode removeSelector: #keywordAndParameterPositionAt:encodedWith:! - -MessageNode removeSelector: #keywordAndParameterPositionAt:encodedWith:! - -Encoder removeSelector: #sourceRangeFor:! - -Encoder removeSelector: #sourceRangeFor:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3765-missingSourceRanges-forSupportingOMeta-JuanVuletichHernanWilkinson-2019May24-09h35m-HAW.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3766] on 25 May 2019 at 9:36:48 am'! -!CompiledMethod methodsFor: 'source code ranges' stamp: 'jmv 5/23/2019 09:52:58' prior: 50460663! - messageSendsRangesOf: aSentSelector - - | methodNode ranges | - - methodNode := self methodNode. - ranges := OrderedCollection new. - - methodNode nodesDo: [ :aParseNode | - (aParseNode isMessageNamed: aSentSelector) ifTrue: [ - (methodNode rangeForNode: aParseNode ifAbsent: nil) ifNotNil: [ :range | - ranges add: range ]]]. - - ^ranges ! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3766-messageSendsRangesOf-HernanWilkinson-2019May25-09h36m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3766] on 25 May 2019 at 9:51:28 am'! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'len 2/19/2017 18:58:55' prior: 16906364! - combinations: k atATimeDo: aBlock - "Take the items in the receiver, k 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 choose: k) combinations. - - 'abcde' combinations: 3 atATimeDo: [:each | Transcript newLine; show: each printString]. - " - - | aCollection | - k = 0 ifTrue: [aBlock value: #(). ^ self]. - aCollection _ Array new: k. - self combinationsAt: 1 in: aCollection after: 0 do: aBlock! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3767-combinationsWithCero-LucianoNotarfrancesco-2019May25-09h49m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3766] on 25 May 2019 at 10:26:14 am'! -!Number methodsFor: 'mathematical functions' stamp: 'HAW 5/25/2019 10:22:42'! - raisedToNegativeInteger: negativeExponent - - | firstTry positiveExponent exponent1 exponent2 | - - positiveExponent := negativeExponent negated. - firstTry := self raisedToInteger: positiveExponent. - ^firstTry isInfinite - ifFalse: [firstTry reciprocal] - ifTrue: [ - exponent1 _ positiveExponent // 2. - exponent2 _ positiveExponent - exponent1. - (self raisedToInteger: exponent1) reciprocal * (self raisedToInteger: exponent2) reciprocal ]! ! -!Number methodsFor: 'mathematical functions' stamp: 'HAW 5/25/2019 10:24:39' prior: 50400568! - raisedTo: exponent - "Answer the receiver raised to aNumber." - - exponent isInteger ifTrue: [ - "Do the special case of integer power" - ^ self raisedToInteger: exponent]. - exponent isFraction ifTrue: [ - "Special case for fraction power by Nicolas Cellier: - If aNumber is a fraction, but result must be a Float, learn it as quickly as possible, and give quick Float answer - Allows evaluating: - (2009/2000) raisedTo: (3958333/100000) - " - ^ self raisedToFraction: exponent]. - self < 0 ifTrue: [ - ^(Complex basicReal: self imaginary: 0) raisedTo: exponent ]. - 0 = exponent ifTrue: [^ self class one]. "Special case of exponent=0" - 1 = exponent ifTrue: [^ self]. "Special case of exponent=1" - 0 = self ifTrue: [ "Special case of self = 0" - exponent < 0 - ifTrue: [^ (ZeroDivide dividend: self) signal] - ifFalse: [^ self]]. - ^ (exponent * self ln) exp "Otherwise use logarithms"! ! -!Number methodsFor: 'mathematical functions' stamp: 'HAW 5/25/2019 10:24:15' prior: 50400599! - raisedToFraction: exponent - self isZero ifTrue: [ - exponent negative ifTrue: [ - ^ (ZeroDivide dividend: 1) signal ]. - ^ self ]. - self negative ifFalse: [ - ^ (self ln * exponent) exp ]. - exponent denominator = 2 ifTrue: [ - ^ self sqrt raisedToInteger: exponent numerator ]. - (self negative and: [ exponent denominator even ]) ifTrue: [ - ^ (Complex basicReal: self imaginary: 0) raisedToFraction: exponent]. - ^ (self negated ln * exponent) exp negated! ! -!Number methodsFor: 'mathematical functions' stamp: 'HAW 5/25/2019 10:23:49' prior: 50446275! - raisedToInteger: exponent - - "The 0 raisedToInteger: 0 is an special case. In some contexts must be 1 and in others must - be handled as an indeterminate form. - I take the first context because that's the way that was previously handled. - Maybe further discussion is required on this topic." - - | bitProbe result | - - exponent negative ifTrue: [^self raisedToNegativeInteger: exponent ]. - - bitProbe := 1 bitShift: exponent highBit - 1. - result := self class one. - - [(exponent bitAnd: bitProbe) = 0 ifFalse: [result := result * self]. - bitProbe := bitProbe bitShift: -1. - bitProbe > 0 ] whileTrue: [result := result * result]. - - ^result! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3768-raisedToParameterRename-HernanWilkinson-2019May25-09h51m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3765] on 24 May 2019 at 7:25:25 pm'! -!PluggableListMorph methodsFor: 'events' stamp: 'len 5/24/2019 19:23:59'! - mouseLeave: event - super mouseLeave: event. - self listMorph highlightedRow: nil! ! -!PluggableListMorph methodsFor: 'events-processing' stamp: 'len 5/24/2019 19:10:11' prior: 16888707! - processMouseMove: aMouseMoveEvent localPosition: localEventPosition - "Reimplemented because we really want #mouseMove when a morph is dragged around" - - aMouseMoveEvent wasHandled ifTrue: [ ^self ]. "not interested" - self listMorph highlightedRow: (self rowAtLocation: localEventPosition ifNone: []). - (aMouseMoveEvent anyButtonPressed and: [ self hasMouseFocus ]) ifFalse: [ ^self ]. - aMouseMoveEvent wasHandled: true. - self mouseMove: aMouseMoveEvent localPosition: localEventPosition. - (self handlesMouseStillDown: aMouseMoveEvent) ifTrue:[ - "Step at the new location" - self startStepping: #processMouseStillDown stepTime: 1 ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3769-ListHighlightMouseOver-LucianoEstebanNotarfrancesco-2019May24-19h21m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3769] on 25 May 2019 at 4:48:20 pm'! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:34:46'! - focusIndicatorBottom - ^ self hIsScrollbarShowing - ifTrue: [ extent y - borderWidth - self scrollBarClass scrollbarThickness ] - ifFalse: [ extent y - borderWidth ]! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:31:00'! - focusIndicatorLeft - ^ borderWidth! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:34:00'! - focusIndicatorRight - ^ self vIsScrollbarShowing - ifTrue: [ extent x - borderWidth - self scrollBarClass scrollbarThickness ] - ifFalse: [ extent x - borderWidth ]! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:31:43'! - focusIndicatorTop - ^ borderWidth! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:43:21'! - viewableArea - ^ self viewableAreaTopLeft corner: self viewableAreaRight @ self viewableAreaBottom! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:30:36'! - viewableAreaBottom - ^ self focusIndicatorBottom - self xtraBorder! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:31:05'! - viewableAreaLeft - ^ self focusIndicatorLeft + self xtraBorder! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:31:23'! - viewableAreaRight - ^ self focusIndicatorRight - self xtraBorder! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:32:00'! - viewableAreaTop - ^ self focusIndicatorTop + self xtraBorder! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:40:16'! - viewableAreaTopLeft - ^ self viewableAreaLeft @ self viewableAreaTop! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:38:15' prior: 16889616! - focusIndicatorExtent - ^ self focusIndicatorRectangle extent! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:37:59' prior: 16889627! - focusIndicatorRectangle - - ^ self focusIndicatorLeft @ self focusIndicatorTop corner: self focusIndicatorRight @ self focusIndicatorBottom! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:46:16' prior: 16889651! - hScrollBarWidth - "Return the width of the horizontal scrollbar" - - ^ self focusIndicatorRight - self focusIndicatorLeft! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:42:08' prior: 16889742! - scrollerOffset - - ^ scroller morphPosition negated + self viewableAreaTopLeft! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:42:01' prior: 16889747! - scrollerOffset: newOffset - - scroller morphPosition: self viewableAreaTopLeft - newOffset! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:36:45' prior: 16889830! - viewableExtent - - ^ self viewableWidth @ self viewableHeight! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:35:29' prior: 16889835! - viewableHeight - "Viewable height. - Leave room for horizontal scrollbar if present" - - ^ self viewableAreaBottom - self viewableAreaTop ! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 5/25/2019 16:35:54' prior: 16889841! - viewableWidth - "Viewable width. - Leave room for vertical scrollbar if present" - - ^ self viewableAreaRight - self viewableAreaLeft! ! -!PluggableListMorph methodsFor: 'events-processing' stamp: 'jmv 5/25/2019 16:43:26' prior: 50461009! - processMouseMove: aMouseMoveEvent localPosition: localEventPosition - "Reimplemented because we really want #mouseMove when a morph is dragged around" - - aMouseMoveEvent wasHandled ifTrue: [ ^self ]. "not interested" - self listMorph highlightedRow: ( - (self viewableArea containsPoint: localEventPosition) ifTrue: [ - self rowAtLocation: localEventPosition ifNone: []]). - (aMouseMoveEvent anyButtonPressed and: [ self hasMouseFocus ]) ifFalse: [ ^self ]. - aMouseMoveEvent wasHandled: true. - self mouseMove: aMouseMoveEvent localPosition: localEventPosition. - (self handlesMouseStillDown: aMouseMoveEvent) ifTrue:[ - "Step at the new location" - self startStepping: #processMouseStillDown stepTime: 1 ]! ! -!TextModelMorph methodsFor: 'drawing' stamp: 'jmv 5/25/2019 16:44:45' prior: 50459860! - drawOn: aCanvas - "Include a thin red inset border for unaccepted edits, or, if the unaccepted edits are known to conflict with a change made somewhere else to the same method (typically), put a thick red frame" - | bw bc | - self flag: #todo. - "Integrate this method with the Theme system. --cbr" - super drawOn: aCanvas. - bw _ Preferences focusIndicatorWidth. - bc _ nil. - self wantsFrameAdornments ifTrue: [ - model refusesToAccept - ifTrue: [ "Put up feedback showing that code cannot be submitted in this state" - bc _ Color tan ] - ifFalse: [ - self textMorph hasEditingConflicts - ifTrue: [ - bw _ 3. - bc _ Color red ] - ifFalse: [ - self textMorph hasUnacceptedEdits ifTrue: [ bc _ Color red ]]]]. - (drawKeyboardFocusIndicator and: [ self textMorph hasKeyboardFocus ]) - ifTrue: [ bc ifNil: [ bc _ Theme current focusIndicator ]] - ifFalse: [ - bc ifNotNil: [ - bc _ bc - alphaMixed: 0.4 - with: Color white ]]. - bc ifNotNil: [ - aCanvas - frameRectangle: self focusIndicatorRectangle - borderWidth: bw - color: bc ]. - model actualContents isEmpty ifTrue: [ - self - valueOfProperty: #emptyTextDisplayMessage - ifPresentDo: [ :msg | - aCanvas - drawString: msg - at: self viewableAreaTopLeft - font: nil - color: Theme current textEmptyDisplayMessage ]].! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3770-ListHighlightMouseOverTweak-JuanVuletich-2019May25-16h27m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3768] on 25 May 2019 at 1:24:40 pm'! -!SequenceableCollection methodsFor: 'private' stamp: 'sqr 5/25/2019 13:19:43'! - combinationsAt: j upTo: k in: aCollection after: m upTo: n do: aBlock - "Choose k of N items and put in aCollection. j-1 already chosen. Indexes of items are in numerical order to avoid duplication. In this slot, we are allowed to use items in self indexed by m+1 up to n. m is the index used for position j-1." - "(1 to: 6) combinations: 3 atATimeDo: [:each | Transcript cr; show: each printString]" - - m+1 to: n do: [:index | - aCollection at: j put: (self at: index). - j = k - ifTrue: [aBlock value: aCollection] - ifFalse: [self combinationsAt: j + 1 upTo: k in: aCollection after: index upTo: n do: aBlock]]! ! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'sqr 5/25/2019 13:20:59' prior: 50460878! - combinations: k atATimeDo: aBlock - "Take the items in the receiver, k 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 choose: k) combinations. - - 'abcde' combinations: 3 atATimeDo: [:each | Transcript newLine; show: each printString]. - " - - | aCollection | - k = 0 ifTrue: [aBlock value: #(). ^ self]. - aCollection _ Array new: k. - self combinationsAt: 1 upTo: k in: aCollection after: 0 upTo: self size do: aBlock! ! - -SequenceableCollection removeSelector: #combinationsAt:in:after:do:! - -SequenceableCollection removeSelector: #combinationsAt:in:after:do:! - -SequenceableCollection removeSelector: #combinationsAt:upTo:in:after:do:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3771-combinationsPerformanceImprovement-AndresValloud-2019May25-13h09m-sqr.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3771] on 26 May 2019 at 5:08:55 pm'! -!Behavior methodsFor: 'testing' stamp: 'len 5/16/2019 05:56:15'! - isDoubleBytes - "Answer whether the receiver's instances indexed 16-bit integer instance variables. - Above Cog Spur the class format is - <5 bits inst spec><16 bits inst size> - where the 5-bit inst spec is - 0 = 0 sized objects (UndefinedObject True False et al) - 1 = non-indexable objects with inst vars (Point et al) - 2 = indexable objects with no inst vars (Array et al) - 3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al) - 4 = weak indexable objects with inst vars (WeakArray et al) - 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron) - 6 = unused - 7 = immediates (SmallInteger, Character) - 8 = unused - 9 = 64-bit indexable - 10-11 = 32-bit indexable (Bitmap) - 12-15 = 16-bit indexable - 16-23 = 8-bit indexable - 24-31 = compiled methods (CompiledMethod)" - - ^ Smalltalk isSpur and: [ self instSpec = 12 ]! ! -!Behavior methodsFor: 'testing' stamp: 'len 5/16/2019 05:56:02'! - isDoubleWords - "Answer whether the receiver's instances indexed 64-bit integer instance variables. - Above Cog Spur the class format is - <5 bits inst spec><16 bits inst size> - where the 5-bit inst spec is - 0 = 0 sized objects (UndefinedObject True False et al) - 1 = non-indexable objects with inst vars (Point et al) - 2 = indexable objects with no inst vars (Array et al) - 3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al) - 4 = weak indexable objects with inst vars (WeakArray et al) - 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron) - 6 = unused - 7 = immediates (SmallInteger, Character) - 8 = unused - 9 = 64-bit indexable - 10-11 = 32-bit indexable (Bitmap) - 12-15 = 16-bit indexable - 16-23 = 8-bit indexable - 24-31 = compiled methods (CompiledMethod)" - - ^ Smalltalk isSpur and: [ self instSpec = 9 ]! ! -!Class methodsFor: 'subclass creation' stamp: 'len 5/16/2019 05:11:11'! - variableDoubleByteSubclass: t instanceVariableNames: f - classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a - subclass of an existing class (the receiver) in which the subclass is to - have indexable double-byte-sized (16 bits) nonpointer variables." - "Note: Only for Spur images" - - | answer | - answer _ ClassBuilder new - superclass: self - variableDoubleByteSubclass: t - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat. - - Smalltalk - logChange: answer definition - preamble: answer definitionPreamble. - ^answer -! ! -!Class methodsFor: 'subclass creation' stamp: 'len 5/16/2019 05:10:47'! - variableDoubleWordSubclass: t instanceVariableNames: f - classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a - subclass of an existing class (the receiver) in which the subclass is to - have indexable double-word-sized (64 bits) nonpointer variables." - "Note: Only for Spur images" - - | answer | - answer _ ClassBuilder new - superclass: self - variableDoubleWordSubclass: t - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat. - - Smalltalk - logChange: answer definition - preamble: answer definitionPreamble. - ^answer! ! -!ClassBuilder methodsFor: 'public' stamp: 'len 5/16/2019 06:13:03'! - superclass: aClass - variableDoubleByteSubclass: t instanceVariableNames: f - classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a - subclass of an existing class in which the subclass is to - have indexable double-byte-sized (16 bit) nonpointer variables." - "Note: Only for Spur images" - - (aClass instSize > 0) - ifTrue: [^self error: 'cannot make a 16-bit word subclass of a class with named fields']. - (aClass isVariable and: [aClass isPointers]) - ifTrue: [^self error: 'cannot make a 16-bit word subclass of a class with pointer fields']. - (aClass isVariable and: [aClass isDoubleBytes not]) - ifTrue: [^self error: 'cannot make a 16-bit word subclass of a class with 8, 32 or 64 bit fields']. - - ^self - name: t - subclassOf: aClass - type: #shorts - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat! ! -!ClassBuilder methodsFor: 'public' stamp: 'len 5/16/2019 06:12:49'! - superclass: aClass - variableDoubleWordSubclass: t instanceVariableNames: f - classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a - subclass of an existing class in which the subclass is to - have indexable double-word-sized (64 bit) nonpointer variables." - "Note: Only for Spur images" - - (aClass instSize > 0) - ifTrue: [^self error: 'cannot make a 64-bit word subclass of a class with named fields']. - (aClass isVariable and: [aClass isPointers]) - ifTrue: [^self error: 'cannot make a 64-bit word subclass of a class with pointer fields']. - (aClass isVariable and: [aClass isDoubleWords not]) - ifTrue: [^self error: 'cannot make a 64-bit word subclass of a class with 8, 16 or 32 bit fields']. - - ^self - name: t - subclassOf: aClass - type: #longs - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat! ! -!Behavior methodsFor: 'testing' stamp: 'len 5/16/2019 05:53:44' prior: 16783112! - isWords - "Answer whether the receiver's instances indexed 32-bit integer instance variables. - Above Cog Spur the class format is - <5 bits inst spec><16 bits inst size> - where the 5-bit inst spec is - 0 = 0 sized objects (UndefinedObject True False et al) - 1 = non-indexable objects with inst vars (Point et al) - 2 = indexable objects with no inst vars (Array et al) - 3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al) - 4 = weak indexable objects with inst vars (WeakArray et al) - 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron) - 6 = unused - 7 = immediates (SmallInteger, Character) - 8 = unused - 9 = 64-bit indexable - 10-11 = 32-bit indexable (Bitmap) - 12-15 = 16-bit indexable - 16-23 = 8-bit indexable - 24-31 = compiled methods (CompiledMethod)" - - ^ Smalltalk isSpur - ifTrue: [ self instSpec = 10 ] - ifFalse: [ self isBytes not ]! ! -!ClassBuilder methodsFor: 'public' stamp: 'len 5/16/2019 06:09:08' prior: 16804187! - superclass: aClass - variableByteSubclass: t instanceVariableNames: f - classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a - subclass of an existing class in which the subclass is to - have indexable byte-sized nonpointer variables." - | oldClassOrNil actualType | - (aClass instSize > 0) - ifTrue: [^self error: 'cannot make a byte subclass of a class with named fields']. - (aClass isVariable and: [aClass isPointers]) - ifTrue: [^self error: 'cannot make a byte subclass of a class with pointer fields']. - (aClass isVariable and: [aClass isBytes not]) - ifTrue: [^self error: 'cannot make a byte subclass of a class with 16, 32 or 64 bit fields']. - oldClassOrNil := Smalltalk at: t ifAbsent: nil. - actualType := (oldClassOrNil notNil - and: [oldClassOrNil typeOfClass == #compiledMethod]) - ifTrue: [#compiledMethod] - ifFalse: [#bytes]. - ^self - name: t - subclassOf: aClass - type: actualType - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat! ! -!ClassBuilder methodsFor: 'public' stamp: 'len 5/16/2019 06:12:34' prior: 16804243! - superclass: aClass - variableWordSubclass: t instanceVariableNames: f - classVariableNames: d poolDictionaries: s category: cat - "This is the standard initialization message for creating a new class as a - subclass of an existing class in which the subclass is to - have indexable word-sized (32 bit) nonpointer variables." - (aClass instSize > 0) - ifTrue: [^self error: 'cannot make a 32-bit word subclass of a class with named fields']. - (aClass isVariable and: [aClass isPointers]) - ifTrue: [^self error: 'cannot make a 32-bit word subclass of a class with pointer fields']. - (aClass isVariable and: [aClass isWords not]) - ifTrue: [^self error: 'cannot make a 32-bit word subclass of a class with 8, 16 or 64 bit fields']. - - ^self - name: t - subclassOf: aClass - type: #words - instanceVariableNames: f - classVariableNames: d - poolDictionaries: s - category: cat! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3772-16and64bitArrays-LucianoEstebanNotarfrancesco-2019May26-17h07m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3772] on 26 May 2019 at 5:18:23 pm'! -!ClassBuilder methodsFor: 'class format' stamp: 'jmv 5/26/2019 17:17:57' prior: 16803525! - computeFormat: type instSize: newInstSize forSuper: newSuper - "Compute the new format for making oldClass a subclass of newSuper. - Answer the format or nil if there is any problem." - - "Only for Spur!!" - - | instSize isVar isPointers isWeak bitsUnitSize | - type == #compiledMethod ifTrue: - [newInstSize > 0 ifTrue: - [self error: 'A compiled method class cannot have named instance variables'. - ^nil]. - ^CompiledMethod format]. - instSize := newInstSize + (newSuper ifNil:[0] ifNotNil:[newSuper instSize]). - instSize > 65535 ifTrue: - [self error: 'Class has too many instance variables (', instSize printString,')'. - ^nil]. - type == #normal ifTrue:[isVar := isWeak := false. isPointers := true]. - type == #bytes ifTrue:[isVar := true. bitsUnitSize := 1. isPointers := isWeak := false]. - type == #shorts ifTrue:[isVar := true. bitsUnitSize := 2. isPointers := isWeak := false]. - type == #words ifTrue:[isVar := true. bitsUnitSize := 4. isPointers := isWeak := false]. - type == #longs ifTrue:[isVar := true. bitsUnitSize := 8. isPointers := isWeak := false]. - type == #variable ifTrue:[isVar := isPointers := true. isWeak := false]. - type == #weak ifTrue:[isVar := isWeak := isPointers := true]. - type == #ephemeron ifTrue:[isVar := false. isWeak := isPointers := true]. - type == #immediate ifTrue:[isVar := isWeak := isPointers := false]. - isVar ifNil: [ self error: 'Unsupported class format type: ', type. ^ nil ]. - (isPointers not and: [instSize > 0]) ifTrue: - [self error: 'A non-pointer class cannot have named instance variables'. - ^nil]. - ^self format: instSize variable: isVar bitsUnitSize: bitsUnitSize pointers: isPointers weak: isWeak! ! -!ClassBuilder methodsFor: 'class format' stamp: 'jmv 5/26/2019 17:17:52' prior: 16803577! - computeFormat: type instSize: newInstSize forSuper: newSuper ccIndex: ccIndex - "Compute the new format for making oldClass a subclass of newSuper. - Return the format or nil if there is any problem." - - | instSize isVar isWords isPointers isWeak | - - "Spur uses this version" - Smalltalk isSpur ifTrue: [ - ^ self computeFormat: type instSize: newInstSize forSuper: newSuper ]. - - "This for preSpur images" - type == #compiledMethod - ifTrue:[^CompiledMethod format]. - instSize := newInstSize + (newSuper ifNil:[0] ifNotNil:[newSuper instSize]). - instSize > 254 ifTrue:[ - self error: 'Class has too many instance variables (', instSize printString,')'. - ^nil]. - type == #normal ifTrue:[isVar := isWeak := false. isWords := isPointers := true]. - type == #bytes ifTrue:[isVar := true. isWords := isPointers := isWeak := false]. - type == #words ifTrue:[isVar := isWords := true. isPointers := isWeak := false]. - type == #variable ifTrue:[isVar := isPointers := isWords := true. isWeak := false]. - type == #weak ifTrue:[isVar := isWeak := isWords := isPointers := true]. - isVar ifNil: [ self error: 'Unsupported class format type: ', type. ^ nil ]. - (isPointers not and:[instSize > 0]) ifTrue:[ - self error:'A non-pointer class cannot have instance variables'. - ^nil]. - ^(self format: instSize - variable: isVar - words: isWords - pointers: isPointers - weak: isWeak) + (ccIndex bitShift: 11)! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3773-FailClassCreationOnInvalidType-JuanVuletich-2019May26-17h17m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3720] on 26 May 2019 at 11:05:05 pm'! -!Array2D methodsFor: 'accessing' stamp: 'GSC 5/26/2019 23:04:56'! - elements - - ^elements! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3774-FailedWhenYouCompareTwoArray2DByEqual-GonzaloSanchezCano.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3774] on 28 May 2019 at 4:20:41 pm'! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'HAW 5/28/2019 16:15:38'! - definesInstanceVariableNamedInHierarchy: anInstanceVariableName - - ^self allInstVarNames includes: anInstanceVariableName! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'HAW 5/28/2019 16:19:35' prior: 16909935! - referencesToIt - "Open a references browser on the selected symbol: a variable name or class name" - - | selectedSymbol provider environment | - - "look for exactly a whole word" - self selectWord. - selectedSymbol _ self selectedSymbol ifNil: [ ^ morph flash ]. - - "convenient access to class variables, including those in SharedPools" - provider _ self codeProvider. - environment _ (provider respondsTo: #selectedClassOrMetaClass) ifTrue: [ provider selectedClassOrMetaClass ]. - environment _ environment ifNil: [ Smalltalk ]. - - (environment bindingOf: selectedSymbol) - ifNotNil: [ :reference | Smalltalk browseAllCallsOn: reference ] - ifNil: [ (environment ~= Smalltalk and: [ environment definesInstanceVariableNamedInHierarchy: selectedSymbol ]) - ifTrue: [ Smalltalk browseAllAccessesTo: selectedSymbol from: environment ] - ifFalse: [ morph flash ]] - - - ! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3775-ReferencesToInstVarFromEditor-EricBrandweinHernanWilkinson-2019May28-15h58m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3765] on 26 May 2019 at 3:47:55 pm'! -!TemporaryToInstanceVariable methodsFor: 'applying' stamp: 'EB 5/25/2019 00:38:49'! - sourceCodeWithoutAnyTemporaryDeclarations - | firstPipeIndex secondPipeIndex | - firstPipeIndex _ method sourceText findString: '|'. - secondPipeIndex _ method sourceText findString: '|' startingAt: firstPipeIndex + 1. - ^method sourceText copyReplacing: {firstPipeIndex to: secondPipeIndex} with: ' ' ! ! -!TemporaryToInstanceVariable methodsFor: 'applying' stamp: 'EB 5/25/2019 00:39:01'! - sourceCodeWithoutTemporaryDeclaration - | temporaryVariablePositions variableDeclarationPosition | - temporaryVariablePositions _ method positionsForTemporaryVariable: variable ifAbsent: []. - variableDeclarationPosition _ {temporaryVariablePositions first}. - ^method sourceText copyReplacing: variableDeclarationPosition with: ''! ! -!TemporaryToInstanceVariable methodsFor: 'applying' stamp: 'EB 5/25/2019 00:39:01' prior: 50459494! - removeTemporary - - | newSourceCode | - newSourceCode _ method temporaries size = 1 - ifTrue: [ self sourceCodeWithoutAnyTemporaryDeclarations ] - ifFalse: [ self sourceCodeWithoutTemporaryDeclaration]. - - method methodClass compile: newSourceCode. - - ^newSourceCode. - ! ! -!TemporaryToInstanceVariable class methodsFor: 'assertions' stamp: 'EB 5/26/2019 15:40:50' prior: 50459563! - assertNoOtherMethodIn: aClass orSubclassesDefinesTemporaryNamed: aTemporaryVariableName - - | methodsDefiningTemporaryInHierarchy | - - methodsDefiningTemporaryInHierarchy := OrderedCollection new. - aClass withAllSubclassesDo: [ :subclass | - methodsDefiningTemporaryInHierarchy addAll: (subclass methodsWithArgumentOrTemporaryNamed: aTemporaryVariableName) ]. - - methodsDefiningTemporaryInHierarchy size > 1 ifTrue: [ - self - canNotRefactorDueToReferencesError: self temporaryExistsInOtherMethodsErrorDescription - references: (methodsDefiningTemporaryInHierarchy collect: [ :implementor | MethodReference method: implementor ]) - to: aTemporaryVariableName. ].! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3776-TemporaryToInstanceVariableBetterErrorMessageAndRemovesPipes-EricBrandwein-2019May24-18h51m-EB.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3766] on 28 May 2019 at 12:20:29 am'! - -ParseNodeVisitor subclass: #TemporaryVariableDeclarationCounter - instanceVariableNames: 'temporaryVariable count' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #TemporaryVariableDeclarationCounter category: #'Tools-Refactoring'! -ParseNodeVisitor subclass: #TemporaryVariableDeclarationCounter - instanceVariableNames: 'temporaryVariable count' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!TemporaryVariableDeclarationCounter methodsFor: 'initialization' stamp: 'EB 5/27/2019 20:46:01'! - initializeFor: aTemporaryVariable - - temporaryVariable _ aTemporaryVariable. - count _ 0.! ! -!TemporaryVariableDeclarationCounter methodsFor: 'visiting' stamp: 'EB 5/27/2019 20:53:26'! - visitBlockNode: aBlockNode - - | hasTemporaryVariable | - - super visitBlockNode: aBlockNode. - hasTemporaryVariable _ aBlockNode temporaries anySatisfy: [ :temporaryVariableNode | - temporaryVariableNode key = temporaryVariable ]. - hasTemporaryVariable ifTrue: [ count _ count + 1 ]! ! -!TemporaryVariableDeclarationCounter methodsFor: 'count' stamp: 'EB 5/27/2019 20:46:23'! - count - - ^count.! ! -!TemporaryVariableDeclarationCounter class methodsFor: 'instance creation' stamp: 'EB 5/27/2019 20:32:01'! - for: aTemporaryVariable - ^self new initializeFor: aTemporaryVariable.! ! -!TemporaryToInstanceVariable class methodsFor: 'error descriptions' stamp: 'EB 5/27/2019 20:20:10'! - temporaryExistsInOtherBlockErrorDescription - - ^'The temporary exists in other blocks in this method; remove those first.'.! ! -!TemporaryToInstanceVariable class methodsFor: 'assertions' stamp: 'EB 5/27/2019 20:45:47'! - assertNoOtherBlockIn: aMethodNode definesTemporaryNamed: aTemporaryVariableName - - | counter | - - counter _ TemporaryVariableDeclarationCounter for: aTemporaryVariableName. - aMethodNode accept: counter. - counter count > 1 ifTrue: [ - self refactoringError: self temporaryExistsInOtherBlockErrorDescription ].! ! -!TemporaryToInstanceVariable class methodsFor: 'instance creation' stamp: 'EB 5/27/2019 20:22:44' prior: 50459511! - named: aTemporaryVariableName fromMethod: aMethodNode - - | methodClass | - - methodClass _ aMethodNode methodClass. - - self assertNoOtherBlockIn: aMethodNode definesTemporaryNamed: aTemporaryVariableName. - self assert: aMethodNode hasTemporaryNamed: aTemporaryVariableName. - self assertNoOtherMethodIn: methodClass orSubclassesDefinesTemporaryNamed: aTemporaryVariableName. - self assertSubclassesOf: methodClass haventGotInstanceVariableNamed: aTemporaryVariableName. - - ^self new initializeNamed: aTemporaryVariableName fromMethod: aMethodNode.! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3777-TemporaryToInstanceVariableWithMultipleBlocks-EricBrandwein-2019May28-00h17m-EB.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3777] on 29 May 2019 at 9:08:47 am'! - -ParseNodeVisitor subclass: #ParseNodesDeclaringTemporaryVariableVisitor - instanceVariableNames: 'temporaryVariable' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ParseNodesDeclaringTemporaryVariableVisitor category: #'Tools-Refactoring'! -ParseNodeVisitor subclass: #ParseNodesDeclaringTemporaryVariableVisitor - instanceVariableNames: 'temporaryVariable' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ParseNodeVisitor subclass: #TemporaryVariableDeclarationCounter - instanceVariableNames: 'temporaryVariable count ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #TemporaryVariableDeclarationCounter category: #'Tools-Refactoring'! -ParseNodeVisitor subclass: #TemporaryVariableDeclarationCounter - instanceVariableNames: 'temporaryVariable count' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!ParseNodesDeclaringTemporaryVariableVisitor methodsFor: 'visiting' stamp: 'EB 5/28/2019 21:40:33'! - isNodeDeclaringTemporary: aParseNode - - ^aParseNode temporaries anySatisfy: [ :temporaryVariableNode | - temporaryVariableNode key = temporaryVariable - ].! ! -!ParseNodesDeclaringTemporaryVariableVisitor methodsFor: 'visiting' stamp: 'EB 5/28/2019 20:58:20'! - visitBlockNode: aBlockNode - - (self isNodeDeclaringTemporary: aBlockNode) ifTrue: [ - self visitBlockNodeDeclaringTemporary: aBlockNode - ]. - super visitBlockNode: aBlockNode.! ! -!ParseNodesDeclaringTemporaryVariableVisitor methodsFor: 'visiting' stamp: 'EB 5/28/2019 21:40:38'! - visitBlockNodeDeclaringTemporary: aBlockNode - - self subclassResponsibility.! ! -!ParseNodesDeclaringTemporaryVariableVisitor methodsFor: 'visiting' stamp: 'EB 5/28/2019 20:58:33'! - visitMethodNode: aMethodNode - - (self isNodeDeclaringTemporary: aMethodNode) ifTrue: [ - self visitMethodNodeDeclaringTemporary: aMethodNode. - ]. - super visitMethodNode: aMethodNode.! ! -!ParseNodesDeclaringTemporaryVariableVisitor methodsFor: 'visiting' stamp: 'EB 5/28/2019 21:40:42'! - visitMethodNodeDeclaringTemporary: aMethodNode - - self subclassResponsibility.! ! -!ParseNodesDeclaringTemporaryVariableVisitor methodsFor: 'initialization' stamp: 'EB 5/28/2019 20:53:53'! - initializeFor: aTemporaryVariable - - temporaryVariable _ aTemporaryVariable. -! ! -!ParseNodesDeclaringTemporaryVariableVisitor class methodsFor: 'instance creation' stamp: 'EB 5/28/2019 21:40:48'! - for: aTemporaryVariable - - ^self new initializeFor: aTemporaryVariable.! ! - -ParseNodeVisitor subclass: #TemporaryVariableDeclarationCounter - instanceVariableNames: 'count' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #TemporaryVariableDeclarationCounter category: #'Tools-Refactoring'! -ParseNodeVisitor subclass: #TemporaryVariableDeclarationCounter - instanceVariableNames: 'count' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3778-RemovePipesFixPreInstallation-HernanWilkinson-2019May29-09h07m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3777] on 29 May 2019 at 9:14:30 am'! - -ParseNodesDeclaringTemporaryVariableVisitor subclass: #TemporaryVariableDeclarationCounter - instanceVariableNames: 'count ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #TemporaryVariableDeclarationCounter category: #'Tools-Refactoring'! -ParseNodesDeclaringTemporaryVariableVisitor subclass: #TemporaryVariableDeclarationCounter - instanceVariableNames: 'count' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ParseNodesDeclaringTemporaryVariableVisitor subclass: #TemporaryVariableDeclarationRemover - instanceVariableNames: 'methodNode newSourceCode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #TemporaryVariableDeclarationRemover category: #'Tools-Refactoring'! -ParseNodesDeclaringTemporaryVariableVisitor subclass: #TemporaryVariableDeclarationRemover - instanceVariableNames: 'methodNode newSourceCode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!TemporaryVariableDeclarationCounter methodsFor: 'initialization' stamp: 'EB 5/28/2019 21:00:58'! - initialize - - count _ 0.! ! -!TemporaryVariableDeclarationCounter methodsFor: 'visiting' stamp: 'EB 5/28/2019 20:59:44'! - visitBlockNodeDeclaringTemporary: aBlockNode - - count _ count + 1.! ! -!TemporaryVariableDeclarationCounter methodsFor: 'visiting' stamp: 'EB 5/28/2019 21:00:06'! - visitMethodNodeDeclaringTemporary: aMethodNode - - count _ count + 1.! ! -!TemporaryVariableDeclarationRemover methodsFor: 'source text generation' stamp: 'EB 5/28/2019 21:24:38'! - sourceTextWithoutMethodTemporaryDeclarationLine - - | endTempsMark startTempsMark | - - startTempsMark _ methodNode sourceText indexOf: $|. - endTempsMark _ methodNode sourceText indexOf: $| startingAt: startTempsMark + 1. - ^self sourceTextWithoutTemporaryDeclarationLineFrom: startTempsMark to: endTempsMark.! ! -!TemporaryVariableDeclarationRemover methodsFor: 'source text generation' stamp: 'EB 5/28/2019 21:22:07'! -sourceTextWithoutTemporaryDeclaration - - | temporaryVariablePositions variableDeclarationPosition | - - temporaryVariablePositions _ methodNode positionsForTemporaryVariable: temporaryVariable ifAbsent: []. - variableDeclarationPosition _ {temporaryVariablePositions first}. - ^methodNode sourceText copyReplacing: variableDeclarationPosition with: ''! ! -!TemporaryVariableDeclarationRemover methodsFor: 'source text generation' stamp: 'EB 5/28/2019 21:41:15'! - sourceTextWithoutTemporaryDeclarationLineFrom: firstIndex to: lastIndex - - ^methodNode sourceText copyReplaceFrom: firstIndex to: lastIndex with: ' '.! ! -!TemporaryVariableDeclarationRemover methodsFor: 'source text generation' stamp: 'EB 5/28/2019 21:24:38'! - sourceTextWithoutTemporaryDeclarationLineInBlockNode: aBlockNode - - | sourceTextUpToEndTemps endTempsMark startTempsMark | - - endTempsMark _ aBlockNode tempsMark. - sourceTextUpToEndTemps _ methodNode sourceText copyFrom: 1 to: endTempsMark - 1. - startTempsMark _ sourceTextUpToEndTemps findLastOccurrenceOfString: '|' startingAt: 1. - ^self sourceTextWithoutTemporaryDeclarationLineFrom: startTempsMark to: endTempsMark. - - ! ! -!TemporaryVariableDeclarationRemover methodsFor: 'source text generation' stamp: 'EB 5/28/2019 21:27:58'! - sourceTextWithoutTemporaryFromParseNode: aParseNode -withTemporaryDeclarationLineRemover: aTemporaryDeclarationLineRemovingBlock - - ^aParseNode temporaries size = 1 - ifTrue: aTemporaryDeclarationLineRemovingBlock value - ifFalse: [ self sourceTextWithoutTemporaryDeclaration ].! ! -!TemporaryVariableDeclarationRemover methodsFor: 'accessing' stamp: 'EB 5/28/2019 21:12:33'! - methodNode: aMethodNode - - methodNode _ aMethodNode.! ! -!TemporaryVariableDeclarationRemover methodsFor: 'accessing' stamp: 'EB 5/28/2019 21:18:31'! - newSourceCode - - ^newSourceCode ! ! -!TemporaryVariableDeclarationRemover methodsFor: 'visiting' stamp: 'EB 5/28/2019 21:17:14'! - visitBlockNodeDeclaringTemporary: aBlockNode - - self - visitNodeDeclaringTemporary: aBlockNode - withTemporaryDeclarationLineRemover: [ - self sourceTextWithoutTemporaryDeclarationLineInBlockNode: aBlockNode ]! ! -!TemporaryVariableDeclarationRemover methodsFor: 'visiting' stamp: 'EB 5/28/2019 21:17:46'! - visitMethodNodeDeclaringTemporary: aMethodNode - - self - visitNodeDeclaringTemporary: aMethodNode - withTemporaryDeclarationLineRemover: [ self sourceTextWithoutMethodTemporaryDeclarationLine ]! ! -!TemporaryVariableDeclarationRemover methodsFor: 'visiting' stamp: 'EB 5/28/2019 21:27:34'! - visitNodeDeclaringTemporary: aParseNode -withTemporaryDeclarationLineRemover: aTemporaryDeclarationLineRemovingBlock - - newSourceCode _ self - sourceTextWithoutTemporaryFromParseNode: aParseNode - withTemporaryDeclarationLineRemover: aTemporaryDeclarationLineRemovingBlock. - - methodNode methodClass compile: newSourceCode.! ! -!TemporaryVariableDeclarationRemover class methodsFor: 'instance creation' stamp: 'EB 5/28/2019 21:11:31'! - in: aMethodNode for: aTemporaryVariable - - | instance | - - instance _ self for: aTemporaryVariable. - instance methodNode: aMethodNode. - ^instance! ! -!BlockNode methodsFor: 'accessing' stamp: 'EB 5/28/2019 19:43:53' prior: 16789659! - temporaries - "Collection of TempVariableNodes" - ^temporaries ifNil: [#()]! ! -!BlockNode methodsFor: 'accessing' stamp: 'EB 5/28/2019 19:43:59' prior: 16789663! -temporaries: aCollection - "Collection of TempVariableNodes" - temporaries := aCollection! ! -!BlockNode methodsFor: 'accessing' stamp: 'EB 5/28/2019 19:52:48' prior: 16789667! - tempsMark - "Index of the end of the temporaries declarations in the containing MethodNode sourceText" - ^tempsMark! ! -!BlockNode methodsFor: 'accessing' stamp: 'EB 5/28/2019 19:53:04' prior: 16789670! - tempsMark: anInteger - "Index of the end of the temporaries declarations in the containing MethodNode sourceText" - tempsMark := anInteger! ! -!TemporaryToInstanceVariable methodsFor: 'applying' stamp: 'EB 5/28/2019 21:29:47' prior: 50461753! - removeTemporary - - | remover | - - remover _ TemporaryVariableDeclarationRemover in: method for: variable. - method accept: remover. - ^remover newSourceCode. - ! ! - -TemporaryToInstanceVariable removeSelector: #sourceCodeWithoutAnyTemporaryDeclarations! - -TemporaryToInstanceVariable removeSelector: #sourceCodeWithoutAnyTemporaryDeclarations! - -TemporaryToInstanceVariable removeSelector: #sourceCodeWithoutTemporaryDeclaration! - -TemporaryToInstanceVariable removeSelector: #sourceCodeWithoutTemporaryDeclaration! - -TemporaryVariableDeclarationCounter class removeSelector: #for:! - -TemporaryVariableDeclarationCounter class removeSelector: #for:! - -TemporaryVariableDeclarationCounter removeSelector: #initializeFor:! - -TemporaryVariableDeclarationCounter removeSelector: #initializeFor:! - -TemporaryVariableDeclarationCounter removeSelector: #visitBlockNode:! - -TemporaryVariableDeclarationCounter removeSelector: #visitBlockNode:! - -ParseNodesDeclaringTemporaryVariableVisitor subclass: #TemporaryVariableDeclarationCounter - instanceVariableNames: 'count' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #TemporaryVariableDeclarationCounter category: #'Tools-Refactoring'! -ParseNodesDeclaringTemporaryVariableVisitor subclass: #TemporaryVariableDeclarationCounter - instanceVariableNames: 'count' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3779-TemporaryToInstanceVariableRemovesPipesInBlock-EricBrandwein-2019May29-09h08m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3779] on 31 May 2019 at 11:34:28 am'! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 5/31/2019 11:33:02' prior: 50450577! - sendersFrom: methodReferences - - senders := methodReferences collect: [:aMethodReference | aMethodReference compiledMethod ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3780-ChangeSendersOnRenameFix-HernanWilkinson-2019May31-11h33m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3779] on 31 May 2019 at 11:51:56 am'! -!SHParserST80 methodsFor: 'scan' stamp: 'EB 5/30/2019 19:54:12' prior: 16901793! - scanBinary - | c d | - c := self currentChar. - currentTokenSourcePosition := sourcePosition. - currentToken := c asString. - d := self nextChar. - ((self isBinarySelectorCharacter: c) or: [c == $:]) ifFalse: [^currentToken]. - (c == $: and: [d == $=]) - ifTrue: [" := assignment" - currentToken := currentToken , d asString. - self nextChar. - ^currentToken]. - (c == $| and: [d == $|]) - ifTrue: ["|| empty temp declaration" - ^currentToken]. - c _ d. - [ - d _ self peekChar. - c == $- - ifTrue: [ d isDigit not ] - ifFalse: [ self isBinarySelectorCharacter: c ] - ] - whileTrue: [ - currentToken _ currentToken copyWith: c. - c _ self nextChar ]. - ^currentToken! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3781-ParsingTwoPipesAsAnEmptyTempDeclaration-EricBrandwein-HernanWilkinson-2019May31-11h34m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3781] on 3 June 2019 at 10:17:39 am'! -!String class methodsFor: 'initialization' stamp: 'len 5/13/2019 13:50:16' prior: 50458462! - initialize - " - String initialize - " - - | order newOrder lowercase | - "Case insensitive compare sorts null, space, digits, letters, all the rest..." - newOrder _ Array new: 256. - order _ -1. - newOrder at: 0+1 put: (order _ order+1). - 32 to: 64 do: [ :c | - newOrder at: c + 1 put: (order _ order+1)]. - #(92 94 124 126 183 215 247) do: [ :c | "\^|~·÷×" - newOrder at: c + 1 put: (order _ order+1)]. - 16r90 to: 16r9F do: [:c| "special math operators" - newOrder at: c + 1 put: (order _ order+1)]. - Character uppercaseLowercaseAndUnaccentedLetters do: [ :upperAndLowercase | - order _ order+1. - newOrder at: upperAndLowercase first numericValue + 1 put: order. - upperAndLowercase size > 1 ifTrue: [ - newOrder at: upperAndLowercase second numericValue + 1 put: order ]]. - 1 to: newOrder size do: [ :i | - (newOrder at: i) ifNil: [ - newOrder at: i put: (order _ order+1)]]. - CaseInsensitiveOrder _ newOrder asByteArray. - - "Case sensitive compare sorts null, space, digits, letters, all the rest..." - newOrder _ Array new: 256. - order _ -1. - newOrder at: 0+1 put: (order _ order+1). - 32 to: 64 do: [ :c | - newOrder at: c + 1 put: (order _ order+1)]. - #(92 94 124 126 183 215 247) do: [ :c | "\^|~·÷×" - newOrder at: c + 1 put: (order _ order+1)]. - 16r90 to: 16r9F do: [:c| "special math operators" - newOrder at: c + 1 put: (order _ order+1)]. - Character uppercaseLowercaseAndUnaccentedLetters do: [ :upperAndLowercase | - upperAndLowercase size > 1 ifTrue: [ - newOrder at: upperAndLowercase first numericValue + 1 put: (order _ order+1) ]]. - Character uppercaseLowercaseAndUnaccentedLetters do: [ :upperAndLowercase | - lowercase _ upperAndLowercase size = 1 - ifTrue: [ upperAndLowercase first ] - ifFalse: [ upperAndLowercase second ]. - newOrder at: lowercase numericValue + 1 put: (order _ order+1) ]. - 1 to: newOrder size do: [ :i | - (newOrder at: i) ifNil: [ - newOrder at: i put: (order _ order+1)]]. - order = 255 ifFalse: [self error: 'order problem']. - CaseSensitiveOrder _ newOrder asByteArray. - - "a table for translating to lower case" - LowercasingTable _ String withAll: (Character characterTable collect: [:c | c asLowercase]). - - "a table for translating to upper case" - UppercasingTable _ String withAll: (Character characterTable collect: [:c | c asUppercase]). - - "a table for testing tokenish (for fast numArgs)" - Tokenish _ String withAll: (Character characterTable collect: - [:c | c tokenish ifTrue: [c] ifFalse: [$~]]). - - "CR and LF--characters that terminate a line" - CSLineEnders _ CharacterSet new. - CSLineEnders add: Character cr. - CSLineEnders add: Character lf. - - "separators and non-separators" - CSSeparators _ CharacterSet separators. - CSNonSeparators _ CSSeparators complement! ! - -String initialize! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3782-SortingOfMathOperators-tweak-LucianoEstebanNotarfrancesco-2019Jun03-10h16m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3781] on 3 June 2019 at 10:25:49 am'! -!String methodsFor: 'text conversion helpers' stamp: 'len 6/3/2019 10:24:00' prior: 16917730! - bold - "Stuff like - ('X' italic, '2' super, ' + ', 'H' bold, 'ij' sub, ' + ', 'lim' italic under, 'z  ' sub, '(1 / z)' ) edit - " - ^self asText bold! ! -!String methodsFor: 'text conversion helpers' stamp: 'len 6/3/2019 10:24:16' prior: 16917738! - italic - "Stuff like - ('X' italic, '2' super, ' + ', 'H' bold, 'ij' sub, ' + ', 'lim' italic under, 'z  ' sub, '(1 / z)' ) edit - " - ^self asText italic! ! -!String methodsFor: 'text conversion helpers' stamp: 'len 6/3/2019 10:24:18' prior: 16917750! - sub - "Stuff like - ('X' italic, '2' super, ' + ', 'H' bold, 'ij' sub, ' + ', 'lim' italic under, 'z  ' sub, '(1 / z)' ) edit - " - ^self asText sub! ! -!String methodsFor: 'text conversion helpers' stamp: 'len 6/3/2019 10:24:20' prior: 16917758! - super - "Stuff like - ('X' italic, '2' super, ' + ', 'H' bold, 'ij' sub, ' + ', 'lim' italic under, 'z  ' sub, '(1 / z)' ) edit - " - ^self asText super! ! -!String methodsFor: 'text conversion helpers' stamp: 'len 6/3/2019 10:24:24' prior: 16917766! - under - "Stuff like - ('X' italic, '2' super, ' + ', 'H' bold, 'ij' sub, ' + ', 'lim' italic under, 'z  ' sub, '(1 / z)' ) edit - " - ^self asText under! ! -!Text methodsFor: 'adding emphasis' stamp: 'len 6/3/2019 10:24:26' prior: 16929729! - bold - "Stuff like - ('X' italic, '2' super, ' + ', 'H' bold, 'ij' sub, ' + ', 'lim' italic under, 'z  ' sub, '(1 / z)' ) edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextEmphasis bold from: 1 to: string size! ! -!Text methodsFor: 'adding emphasis' stamp: 'len 6/3/2019 10:24:28' prior: 16929739! - italic - "Stuff like - ('X' italic, '2' super, ' + ', 'H' bold, 'ij' sub, ' + ', 'lim' italic under, 'z  ' sub, '(1 / z)' ) edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextEmphasis italic from: 1 to: string size! ! -!Text methodsFor: 'adding emphasis' stamp: 'len 6/3/2019 10:24:30' prior: 16929755! - sub - "Stuff like - ('X' italic, '2' super, ' + ', 'H' bold, 'ij' sub, ' + ', 'lim' italic under, 'z  ' sub, '(1 / z)' ) edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextEmphasis subscript from: 1 to: string size! ! -!Text methodsFor: 'adding emphasis' stamp: 'len 6/3/2019 10:24:32' prior: 16929765! - super - "Stuff like - ('X' italic, '2' super, ' + ', 'H' bold, 'ij' sub, ' + ', 'lim' italic under, 'z  ' sub, '(1 / z)' ) edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextEmphasis superscript from: 1 to: string size! ! -!Text methodsFor: 'adding emphasis' stamp: 'len 6/3/2019 10:24:34' prior: 16929775! - under - "Stuff like - ('X' italic, '2' super, ' + ', 'H' bold, 'ij' sub, ' + ', 'lim' italic under, 'z  ' sub, '(1 / z)' ) edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextEmphasis underlined from: 1 to: string size! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3783-InfinityGlyphChangedForTT-LucianoEstebanNotarfrancesco-2019Jun03-10h18m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3777] on 1 June 2019 at 6:21:58 am'! - -Object subclass: #DamageRecorder - instanceVariableNames: 'invalidRects totalRepaint drSemaphore ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #DamageRecorder category: #'Morphic-Support'! -Object subclass: #DamageRecorder - instanceVariableNames: 'invalidRects totalRepaint drSemaphore' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! -!DamageRecorder methodsFor: 'initialization' stamp: 'pb 6/1/2019 06:02:18'! - initialize - super initialize . - invalidRects _ OrderedCollection new: 15. - totalRepaint _ false! ! -!DamageRecorder methodsFor: 'private' stamp: 'pb 6/1/2019 05:21:24'! - pvtAccessProtect - ^ drSemaphore ifNil: [drSemaphore := Semaphore forMutualExclusion]! ! -!DamageRecorder methodsFor: 'private' stamp: 'pb 6/1/2019 06:00:14'! - pvtInnerRecordInvalidRect: requestedRect - "Record the given rectangle in my damage list, a list of rectangular areas of the display that should be redraw on the next display cycle. - Rectangles are specified in world coordinates (might be not the same as Display coordinates if there is some origin set on some canvas. Usually there will be none, but we can't be sure) - " - "Details: Damaged rectangles are often identical or overlap significantly. In these cases, we merge them to reduce the number of damage rectangles that must be processed when the display is updated. Moreover, above a certain threshold, we ignore the individual rectangles completely, and simply do a complete repaint on the next cycle. - jmv: Important. There should be no overlapping rectangles in the list. If there are, translucent morphs might be drawn several times, with visible defects. - WRT performance, the different paths for various intersections seem a bit complicated. I could not find strong evidence of the best way. - Leave it as it is right now." - | newRect mergeRect indexToReuse | - totalRepaint ifTrue: [ ^ self ]. - "planning full repaint; don't bother collecting damage" - indexToReuse _ nil. - newRect _ requestedRect truncated. - invalidRects withIndexDo: [ :oldRect :index | - oldRect - ifNil: [ indexToReuse ifNil: [ indexToReuse _ index ]] - ifNotNil: [ - "No two rectangles should intersect" - (oldRect intersects: newRect) ifTrue: [ - "newRect already in. Nothing to do then." - (oldRect containsRect: newRect) ifTrue: [ ^ self ]. - "Some oldRect included in newRect. Remove it and continue, as newRect could still intersect others." - (newRect containsRect: oldRect) ifTrue: [ - invalidRects - at: index - put: nil. - "Effectively like 'invalidRects remove: rect', but without performance penalty." - indexToReuse ifNil: [ indexToReuse _ index ]]. - "Merge rectangles if they overlap significantly, i.e. if the merge is not much larger than separated rectangles." - mergeRect _ (oldRect origin min: newRect origin) corner: (oldRect corner max: newRect corner). - mergeRect area > (newRect area + oldRect area * 2) - ifTrue: [ - "Avoid intersections!!" - newRect - areasOutside: oldRect - do: [ :nonIntersection | - "We have brand new newRects. Start all over with each of them." - self pvtInnerRecordInvalidRect: nonIntersection ]. - "newRect no longer needed, then." - ^ self ] - ifFalse: [ - "Merge into newRect, as any overlap with forecoming rectangles in the iteration is detected and treated." - newRect _ mergeRect. - invalidRects - at: index - put: nil. - "Effectively like 'invalidRects remove: rect', but without performance penalty." - indexToReuse ifNil: [ indexToReuse _ index ]]]]]. - invalidRects size >= 10 ifTrue: [ - "if there are too many separate areas, merge them all" - mergeRect _ Rectangle merging: invalidRects. - self pvtReset. - mergeRect ifNotNil: [ invalidRects addLast: mergeRect ]. - indexToReuse _ nil ]. - "Add the given rectangle to the damage list" - indexToReuse - ifNil: [ invalidRects addLast: newRect ] - ifNotNil: [ - invalidRects - at: indexToReuse - put: newRect ].! ! -!DamageRecorder methodsFor: 'private' stamp: 'pb 6/1/2019 05:59:38'! - pvtReset - "Clear the damage list." - invalidRects removeAll. - totalRepaint _ false.! ! -!WorldState methodsFor: 'drawing' stamp: 'pb 6/1/2019 06:06:26' prior: 50381065! - drawInvalidAreasSubmorphs: submorphs - "Redraw the damaged areas of the given canvas and clear the damage list. Return a collection of the areas that were redrawn." - - | initialRectsToRepair currentRectsToRepair newRectsToRepair morphsToDraw rectsForEachMorph thisMorphRects reuse i n morph morphBounds morphClipRect | - - "The simple implementation is slowers as it draws morph areas that will later be covered by other morphs. - But it works, and it is easier to understand. - See en.wikipedia.org/wiki/Painter's_algorithm" - true not ifTrue: [ ^self simpleDrawInvalidAreasSubmorphs: submorphs ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - initialRectsToRepair _ damageRecorder invalidRectsFullBounds: world viewBox. - currentRectsToRepair _ OrderedCollection new. - newRectsToRepair _ OrderedCollection withAll: initialRectsToRepair. - morphsToDraw _ OrderedCollection new. - rectsForEachMorph _ OrderedCollection new. - thisMorphRects _ OrderedCollection new. - n _ submorphs size. - i _ 1. - - "The idea here is to iterate morphs front to back, i.e. first the ones on top. - For each morph, record the rectangles it affects. And if a morph is opaque, remove the area behind it from the list of rectangles to be repaired. - This means, for example, that morphs completely covered might even not be redrawn. - this is a huge performance gain when there are many morphs on screen, especially if there are more than ten open windows, and Theme uses opaque colors. - See 'A reverse painter's algorithm' at en.wikipedia.org/wiki/Painter's_algorithm" - [ i <= n and: [ newRectsToRepair notEmpty ]] whileTrue: [ - morph _ submorphs at: i. - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - reuse _ currentRectsToRepair. - currentRectsToRepair _ newRectsToRepair. - newRectsToRepair _ reuse removeAll. - currentRectsToRepair do: [ :r | - (morphBounds intersects: r) - ifTrue: [ - morphClipRect _ morphBounds intersect: r. - thisMorphRects add: morphClipRect. "We could perhaps try and join adjacent rectangles in this collection..." - morph addPossiblyUncoveredAreasIn: r to: newRectsToRepair ] - ifFalse: [ - newRectsToRepair add: r ]]. - thisMorphRects ifNotEmpty: [ - morphsToDraw add: morph. - rectsForEachMorph add: thisMorphRects. - thisMorphRects _ OrderedCollection new. - ]]. - i _ i + 1 ]. - - "*make this true to flash damaged areas for testing*" - Preferences debugShowDamage ifTrue: [ world fillRects: initialRectsToRepair ]. - - "Draw world background on those areas that were not completely covered by opaque morphs" - i > n ifTrue: [ - newRectsToRepair do: [ :r | - world drawOn: (canvas newClipRect: r) ]]. - - "Now, draw the recorded areas of selected morphs, back to front." - morphsToDraw with: rectsForEachMorph reverseDo: [ :m :xrects | - "Here we could think about merging all xrects into just one call... - This would mean drawing each morph just once. - But that would mean drawing pixels we were not told to. There could be other morphs in that area that are not even being drawn!! - See WorldState class >> #experiment1" - "*make this true to flash damaged areas for testing*" - Preferences debugShowDamage2 ifTrue: [ - world fillRects: xrects ]. -" rr _ nil." - xrects do: [ :r | -" rr _ rr ifNil: [ r ] ifNotNil: [ r quickMerge: rr ]." - (canvas newClipRect: r) fullDraw: m. - ]. -" (canvas newClipRect: rr) fullDraw: m" - ]. - - "Answer a list of rectangles to be updated on the Display. - This usually is not performance critical, drawing morphs is slower than just exposing the Display." - "What should we force on Display? Whatever was asked? Each small rect that was updated? A single bigger rect? - Right now, answer whatever was asked... Maybe this could be changed if that enhances performance... - (think of vnc over slow networks)" - ^ initialRectsToRepair! ! -!WorldState methodsFor: 'drawing' stamp: 'pb 6/1/2019 06:06:40' prior: 50339784! - simpleDrawInvalidAreasSubmorphs: submorphs - - "mover todo esto al canvas, no? - Y ver que hacer con los argumentos, etc.... Toda esta bananarama!!" - - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - This simple implementation just does as requested: No optimizations are done." - - | rectsToRepair morphBounds | - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ damageRecorder invalidRectsFullBounds: world viewBox. - - "Draw World" - rectsToRepair do: [ :r | - world drawOn: (canvas newClipRect: r) ]. - - "Draw morphs" - submorphs reverseDo: [ :morph | - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - rectsToRepair do: [ :r | - (morphBounds intersects: r) ifTrue: [ - (canvas newClipRect: r) fullDraw: morph ]]]]. - - ^ rectsToRepair! ! -!DamageRecorder methodsFor: 'recording' stamp: 'pb 6/1/2019 06:05:16' prior: 16826973! - invalidRectsFullBounds: aRectangle - "Return a collection of damaged rectangles for the given canvas. If a total repaint has been requested, return the given rectangle." - "The collection answered should not be modified outside this method. In addition, it could contain nil objects, that should be ignored." - | answer | - answer _ totalRepaint - ifTrue: [ Array with: aRectangle ]. - self pvtAccessProtect critical: [ - answer ifNil: [answer := invalidRects reject: [ :r | - r isNil ]]. - self pvtReset]. - ^ answer.! ! -!DamageRecorder methodsFor: 'recording' stamp: 'pb 6/1/2019 05:39:59' prior: 16826990! - recordInvalidRect: requestedRect - ^ self pvtAccessProtect critical: [ self pvtInnerRecordInvalidRect: requestedRect ]! ! -!DamageRecorder methodsFor: 'testing' stamp: 'pb 6/1/2019 05:34:58' prior: 16827091! - updateIsNeeded - "Return true if the display needs to be updated. - Note: This could give a false positive (i.e. answer true) if invalidRects is not empty but it only contains nils. - Senders should be aware of this." - ^ totalRepaint or: [ self pvtAccessProtect critical: [invalidRects notEmpty] ].! ! - -DamageRecorder class removeSelector: #new! - -DamageRecorder class removeSelector: #new! - -DamageRecorder removeSelector: #reset! - -DamageRecorder removeSelector: #reset! - -Object subclass: #DamageRecorder - instanceVariableNames: 'invalidRects totalRepaint drSemaphore' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #DamageRecorder category: #'Morphic-Support'! -Object subclass: #DamageRecorder - instanceVariableNames: 'invalidRects totalRepaint drSemaphore' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3784-BackgroundSafeRedrawNeeded-PhilBellalouna-2019Jun01-05h20m-pb.1.cs.st----! - -----SNAPSHOT----(3 June 2019 11:01:39) Cuis5.0-3784-v3.image priorSource: 3945370! - -----QUIT----(3 June 2019 11:02:11) Cuis5.0-3784-v3.image priorSource: 4197962! - -----STARTUP---- (11 June 2019 14:16:32) as /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/Cuis5.0-3784-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3784] on 5 June 2019 at 2:42:46 pm'! -!TextReplaceCommand methodsFor: 'as yet unclassified' stamp: 'EB 6/5/2019 14:41:58'! - stopPosition - ^position + new size.! ! -!TextModel methodsFor: 'undoable commands' stamp: 'EB 6/5/2019 14:41:58' prior: 16933816! - logUndoAndReplaceFrom: start to: stop with: replacement - "As requested." - - | command now | - "Time millisecondClockValue rolls over and is generally not adviced. - But here, we don't care. A user edit doing during rollover would be split in two, as if the user did a pause. - Not a problem." - - now _ Time millisecondClockValue. - command _ self commandForReplaceFrom: start to: stop with: replacement. - (stop+1 = start and: [ lastEditTimeStamp notNil and: [ now - lastEditTimeStamp < 1000 and: [start = undoRedoCommands last stopPosition] ]]) - ifTrue: [ - "Don't use the command we just built" - undoRedoCommands last appendToNew: replacement - ] - ifFalse: [ - undoRedoCommands - nextPut: command; - truncateAtPosition. "To disable redo of previous commands, now invalidated." - ]. - command doOn: self. - lastEditTimeStamp _ now! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3785-SyntaxErrorUndoFix-EricBrandwein-2019Jun05-03h24m-EB.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3784] on 7 June 2019 at 3:27:40 am'! -!Random methodsFor: 'accessing' stamp: 'len 5/13/2019 10:04:43'! - nextBoolean - ^ (self nextBits: 1) = 1! ! -!Random methodsFor: 'accessing' stamp: 'len 6/7/2019 02:40:48' prior: 16897822! - nextBits: anInteger - "Answer a random integer in the interval [0, 2^anInteger - 1]" - - | toGo remainder answer | - anInteger < 0 ifTrue: [self error: 'invalid interval']. - remainder := anInteger \\ self nextChunkSize. - answer _ remainder > 0 - ifTrue: [self nextChunkBits bitShift: remainder - self nextChunkSize] - ifFalse: [0]. - toGo := anInteger - self nextChunkSize. - [toGo > 0] whileTrue: - [ - answer _ answer bitShift: self nextChunkSize :: bitXor: self nextChunkBits. - toGo _ toGo - self nextChunkSize - ]. - ^answer! ! -!Random methodsFor: 'accessing' stamp: 'len 6/7/2019 02:40:59' prior: 16897839! -nextInteger: anInteger - "Answer a random integer in the interval [1, anInteger]" - - | answer | - anInteger >= 1 ifFalse: [self error: 'invalid interval']. - [(answer _ self nextBits: anInteger highBit) >= anInteger] whileTrue. - ^ answer + 1! ! -!LaggedFibonacciRandom methodsFor: 'private' stamp: 'len 6/7/2019 03:23:02' prior: 16862087! - seed: anInteger - - | random | - random _ ParkMiller93Random seed: anInteger. - self initializeRingWith: random. - self last: 1! ! -!ParkMiller88Random methodsFor: 'private' stamp: 'len 6/6/2019 05:48:02' prior: 16884603! - seed: anInteger - seed _ anInteger - 1 \\ (self m - 1) truncated + 1. -" (seed between: 1 and: self m - 1) ifFalse: [self error: 'Seed out of range']"! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3786-MoreRandomFixes-LucianoEstebanNotarfrancesco-2019Jun07-02h37m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3785] on 7 June 2019 at 9:38:59 am'! -!Random methodsFor: 'accessing' stamp: 'HAW 6/7/2019 09:34:08' prior: 50462894! - nextBits: anInteger - "Answer a random integer in the interval [0, 2^anInteger - 1]" - - | toGo remainder answer | - - anInteger negative ifTrue: [self error: 'invalid interval']. - remainder := anInteger \\ self nextChunkSize. - answer _ remainder > 0 - ifTrue: [self nextChunkBits bitShift: remainder - self nextChunkSize] - ifFalse: [0]. - toGo := anInteger - self nextChunkSize. - [toGo > 0] whileTrue: - [ - answer _ answer bitShift: self nextChunkSize :: bitXor: self nextChunkBits. - toGo _ toGo - self nextChunkSize - ]. - ^answer! ! -!Random methodsFor: 'accessing' stamp: 'HAW 6/7/2019 09:37:25' prior: 50462913! - nextInteger: anInteger - "Answer a random integer in the interval [1, anInteger]" - - | answer | - - anInteger strictlyPositive ifFalse: [self error: 'invalid interval']. - [(answer _ self nextBits: anInteger highBit) >= anInteger] whileTrue. - - ^ answer + 1! ! -!ParkMiller88Random methodsFor: 'private' stamp: 'HAW 6/7/2019 09:33:01' prior: 50462931! - seed: anInteger - - seed _ anInteger - 1 \\ (self m - 1) truncated + 1. - ! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3786-RandomChanges-HernanWilkinson-2019Jun07-09h29m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3786] on 8 June 2019 at 6:28:48 pm'! -!String methodsFor: 'converting' stamp: 'HAW 6/8/2019 18:20:03'! - withoutSeparators - - ^self reject: [ :aCharacter | aCharacter isSeparator ]! ! -!TextEditor methodsFor: 'accessing-selection' stamp: 'HAW 6/8/2019 18:16:53'! - selectedString - - ^self selection string! ! -!TextEditor methodsFor: 'editing keys' stamp: 'HAW 6/8/2019 18:23:09' prior: 16931693! - changeLineEndsToLf: aKeyboardEvent - "Replace all CRs and CrLfs by LFs. - Triggered by Cmd-U -- useful when getting code from FTP sites" - "This is a user command, and generates undo" - - self replaceSelectionWith: self selectedString withCuisLineEndings. - ^ true! ! -!TextEditor methodsFor: 'editing keys' stamp: 'HAW 6/8/2019 18:23:30' prior: 16931770! - hiddenInfo - "In TextLinks, TextDoits, TextColor, and TextURLs, there is hidden info. Return the entire string that was used by Cmd-6 to create this text attribute. Usually enclosed in < >." - - | attrList | - attrList _ model actualContents attributesAt: (self pointIndex + self markIndex)//2. - attrList do: [:attr | - attr forTextActionInfoDo: [ :info | - ^ self selectedString, '<', info, '>']]. - "If none of the above" - attrList do: [:attr | - attr forTextColorDo: [ :color | - ^ self selectedString, '<', color printString, '>']]. - ^ self selectedString, '[No hidden info]'! ! -!TextEditor methodsFor: 'editing keys' stamp: 'HAW 6/8/2019 18:23:38' prior: 16931883! - makeCapitalized: aKeyboardEvent - "Force the current selection to uppercase. Triggered by Cmd-X." - "This is a user command, and generates undo" - - | prev | - prev _ $-. "not a letter" - self replaceSelectionWith: - (self selectedString collect: - [:c | prev _ prev isLetter ifTrue: [c asLowercase] ifFalse: [c asUppercase]]). - ^ true! ! -!TextEditor methodsFor: 'editing keys' stamp: 'HAW 6/8/2019 18:23:45' prior: 16931896! - makeLowercase: aKeyboardEvent - "Force the current selection to lowercase. Triggered by Cmd-X." - "This is a user command, and generates undo" - - self replaceSelectionWith: self selectedString asLowercase. - ^ true! ! -!TextEditor methodsFor: 'editing keys' stamp: 'HAW 6/8/2019 18:23:53' prior: 16931905! - makeUppercase: aKeyboardEvent - "Force the current selection to uppercase. Triggered by Cmd-Y." - "This is a user command, and generates undo" - - self replaceSelectionWith: self selectedString asUppercase. - ^ true! ! -!TextEditor methodsFor: 'menu messages' stamp: 'HAW 6/8/2019 18:24:07' prior: 16932192! - setSearchString - "Make the current selection, if any, be the current search string." - self hasSelection ifFalse: [morph flash. ^ self]. - self setSearch: self selectedString! ! -!TextEditor methodsFor: 'nonediting/nontyping keys' stamp: 'HAW 6/8/2019 18:24:13' prior: 16932375! - setSearchString: aKeyboardEvent - "Establish the current selection as the current search string." - - | aString | - self lineSelectAndEmptyCheck: [^ true]. - aString _ self selectedString. - aString size = 0 - ifTrue: [ self flash ] - ifFalse: [ self setSearch: aString ]. - ^ true! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'HAW 6/8/2019 18:21:46' prior: 16909761! - browseClassFromIt - "Launch a hierarchy browser for the class indicated by the current selection. If multiple classes matching the selection exist, let the user choose among them." - - | aClass | - self wordSelectAndEmptyCheck: [^ self]. - - aClass _ Utilities - classFromPattern: self selectedString withBlanksCondensed - withCaption: 'choose a class to browse...'. - aClass ifNil: [^ morph flash]. - - HierarchyBrowserWindow - onClass: aClass - selector: nil! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'HAW 6/8/2019 18:21:52' prior: 16909803! - classCommentsContainingIt - "Open a browser class comments which contain the current selection somewhere in them." - - self lineSelectAndEmptyCheck: [^ self]. - Smalltalk browseClassCommentsWithString: self selectedString! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'HAW 6/8/2019 18:22:28' prior: 16909813! - explain - "Try to shed some light on what kind of entity the current selection is. - The selection must be a single token or construct. Insert the answer after - the selection. Send private messages whose names begin with 'explain' - that return a string if they recognize the selection, else nil." - - | string tiVars cgVars selectors delimitors numbers sorry reply symbol provider | - sorry _ 'Sorry, I can''t explain that. Please select a single -token, construct, or special character.'. - (string _ self selectedString) isEmpty - ifTrue: [reply _ ''] - ifFalse: [ - string _ string withBlanksTrimmed. - "Remove space, tab, cr" - "Temps and Instance vars need only test strings that are all letters" - (string detect: [:char | char isValidInIdentifiers not] - ifNone: nil) ifNil: [ - tiVars _ (self explainTemp: string) - ifNil: [self explainInst: string]]. - - provider _ self codeProvider. - (tiVars == nil and: [provider respondsTo: #explainSpecial:]) - ifTrue: [tiVars _ provider explainSpecial: string]. - tiVars _ tiVars - ifNil: [ ''] - ifNotNil: [ tiVars , '\' withNewLines]. - "Context, Class, Pool, and Global vars, and Selectors need - only test symbols" - (Symbol hasInterned: string ifTrue: [:s | symbol _ s]) - ifTrue: [ - cgVars _ (self explainCtxt: symbol) - ifNil: [ (self explainClass: symbol) - ifNil: [ self explainGlobal: symbol]]. - "See if it is a Selector (sent here or not)" - selectors _ (self explainMySel: symbol) - ifNil: [(self explainPartSel: string) - ifNil: [ self explainAnySel: symbol]]] - ifFalse: [selectors _ self explainPartSel: string]. - cgVars _ cgVars - ifNil: [ ''] - ifNotNil: [cgVars , '\' withNewLines]. - selectors _ selectors - ifNil: [ ''] - ifNotNil: [ selectors , '\' withNewLines]. - delimitors _ string size = 1 - ifTrue: ["single special characters" - self explainChar: string] - ifFalse: ["matched delimitors" - self explainDelimitor: string]. - numbers _ self explainNumber: string. - numbers ifNil: [numbers _ '']. - delimitors ifNil: [delimitors _ '']. - reply _ tiVars , cgVars , selectors , delimitors , numbers]. - reply size = 0 ifTrue: [reply _ sorry]. - - morph showBalloon: reply. - self runningWorld ifNotNil: [ :w | w findATranscript ]. - reply print! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'HAW 6/8/2019 18:22:40' prior: 16909914! - methodSourceContainingIt - "Open a browser on methods which contain the current selection in their source (case-sensitive full-text search of source). Slow!!" - - self lineSelectAndEmptyCheck: [^ self]. - Smalltalk browseMethodsWithSourceString: self selectedString! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'HAW 6/8/2019 18:22:47' prior: 16909925! - methodStringsContainingit - "Open a browser on methods which contain the current selection as part of a string constant." - - self lineSelectAndEmptyCheck: [^ self]. - Smalltalk browseMethodsWithString: self selectedString! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'HAW 6/8/2019 18:25:03' prior: 50461688! - referencesToIt - "Open a references browser on the selected symbol: a variable name or class name" - - | selectedString provider environment | - - "look for exactly a whole word" - self selectWord. - selectedString _ self selectedString withoutSeparators. - - "convenient access to class variables, including those in SharedPools" - provider _ self codeProvider. - environment _ (provider respondsTo: #selectedClassOrMetaClass) ifTrue: [ provider selectedClassOrMetaClass ]. - environment _ environment ifNil: [ Smalltalk ]. - - (environment bindingOf: selectedString) - ifNotNil: [ :reference | Smalltalk browseAllCallsOn: reference ] - ifNil: [ (environment ~= Smalltalk and: [ environment definesInstanceVariableNamedInHierarchy: selectedString ]) - ifTrue: [ Smalltalk browseAllAccessesTo: selectedString from: environment ] - ifFalse: [ morph flash ]] - - - ! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'HAW 6/8/2019 18:22:55' prior: 16909957! - selectedSelector - "Try to make a selector out of the current text selection" - - ^ self selectedString findSelector! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'HAW 6/8/2019 18:20:31' prior: 16909964! - selectedSymbol - "Return the currently selected symbol, or nil if none. Spaces, tabs and returns are ignored" - - | aString | - self hasSelection ifFalse: [^ nil]. - aString _ self selectedString withoutSeparators. - aString size = 0 ifTrue: [^ nil]. - Symbol hasInterned: aString ifTrue: [:sym | ^ sym]. - - ^ nil! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3787-ReferencesToItFixStringWithoutSeparators-HernanWilkinson-2019Jun08-18h16m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3786] on 7 June 2019 at 5:12:13 pm'! -!TextModel methodsFor: 'undoable commands' stamp: 'EB 6/7/2019 17:02:49'! - logUndoAndReplaceFrom: start to: stop with: replacement shouldMergeCommandsIfPossible: shouldMergeCommands - "As requested." - - | command now | - "Time millisecondClockValue rolls over and is generally not adviced. - But here, we don't care. A user edit doing during rollover would be split in two, as if the user did a pause. - Not a problem." - - now _ Time millisecondClockValue. - command _ self commandForReplaceFrom: start to: stop with: replacement. - (shouldMergeCommands and: [ - stop+1 = start and: [ lastEditTimeStamp notNil and: [ now - lastEditTimeStamp < 1000 and: [start = undoRedoCommands last stopPosition] ]]]) - ifTrue: [ - "Don't use the command we just built" - undoRedoCommands last appendToNew: replacement - ] - ifFalse: [ - undoRedoCommands - nextPut: command; - truncateAtPosition. "To disable redo of previous commands, now invalidated." - ]. - command doOn: self. - lastEditTimeStamp _ now! ! -!TextEditor methodsFor: 'accessing' stamp: 'EB 6/7/2019 17:04:15'! - replaceSelectionWith: aTextOrString shouldMergeCommandsIfPossible: shouldMergeCommands - "Deselect, and replace the selection text by aText." - "This is a user command, and generates undo" - - | start stop replacement | - - morph disablesEditing ifTrue: [ - ^ self ]. - - start _ self startIndex. - stop _ self stopIndex. - (aTextOrString isEmpty and: [stop > start]) ifTrue: [ - "If deleting, then set emphasisHere from 1st character of the deletion" - emphasisHere _ (model actualContents attributesAt: start) select: [:att | - att mayBeExtended]]. - - (start = stop and: [ aTextOrString isEmpty ]) ifFalse: [ - replacement _ self addAttributesForPasting: aTextOrString. - model logUndoAndReplaceFrom: start to: stop - 1 with: replacement shouldMergeCommandsIfPossible: shouldMergeCommands. - textComposition - recomposeFrom: start - to: start + replacement size - 1 - delta: replacement size - (stop-start). - self deselectAndPlaceCursorAt: start + replacement size. - selectionStartBlocks _ #(). - selectionStopBlocks _ #(). - self userHasEdited " -- note text now dirty" ]. - - morph possiblyChanged! ! -!TextEditor methodsFor: 'new selection' stamp: 'EB 6/7/2019 16:55:51'! - insertAndSelect: aString at: anInteger shouldMergeCommandsIfPossible: shouldMergeCommands - "This is a user command, and generates undo" - - | newText | - newText _ (aString is: #Text) ifTrue: [aString] ifFalse: [Text string: aString attributes: emphasisHere]. - self deselectAndPlaceCursorAt: anInteger. - self replaceSelectionWith: newText shouldMergeCommandsIfPossible: shouldMergeCommands. - self selectFrom: anInteger to: anInteger + newText size - 1! ! -!TextModel methodsFor: 'undoable commands' stamp: 'EB 6/7/2019 17:03:26' prior: 50462854! - logUndoAndReplaceFrom: start to: stop with: replacement - "As requested." - self logUndoAndReplaceFrom: start to: stop with: replacement shouldMergeCommandsIfPossible: true.! ! -!TextEditor methodsFor: 'accessing' stamp: 'EB 6/7/2019 17:03:59' prior: 50369356! - replaceSelectionWith: aTextOrString - "Deselect, and replace the selection text by aText." - "This is a user command, and generates undo" - self replaceSelectionWith: aTextOrString shouldMergeCommandsIfPossible: true.! ! -!TextEditor methodsFor: 'new selection' stamp: 'EB 6/7/2019 17:05:33' prior: 16932257! - insertAndSelect: aString at: anInteger - "This is a user command, and generates undo" - self insertAndSelect: aString at: anInteger shouldMergeCommandsIfPossible: true.! ! -!SmalltalkEditor methodsFor: 'new selection' stamp: 'EB 6/7/2019 17:07:30' prior: 16910549! - notify: aString at: anInteger in: aStream - "The compilation of text failed. The syntax error is noted as the argument, - aString. Insert it in the text at starting character position anInteger." - "This is a user command, and generates undo" - self insertAndSelect: aString at: (anInteger max: 1) shouldMergeCommandsIfPossible: false.! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3788-UndoSyntaxErrorsSeparately-EricBrandwein-2019Jun07-16h45m-EB.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3777] on 9 June 2019 at 10:04:40 pm'! -!MorphicCanvas methodsFor: 'drawing' stamp: 'pb 5/31/2019 19:35:57'! - line: pt1 to: pt2 width: wp color: c - self subclassResponsibility ! ! -!MorphicCanvas methodsFor: 'drawing-icons' stamp: 'pb 5/31/2019 19:45:10'! - drawButtonIconFromCurrentMorph - self subclassResponsibility ! ! -!MorphicCanvas methodsFor: 'drawing-images' stamp: 'pb 5/31/2019 19:39:09'! - image: aForm at: aPoint - self subclassResponsibility ! ! -!MorphicCanvas methodsFor: 'drawing-images' stamp: 'pb 5/31/2019 19:39:29'! - image: aForm at: aPoint sourceRect: sourceRect - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-images' stamp: 'pb 5/31/2019 19:39:52'! - image: aForm multipliedBy: aColor at: aPoint - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-images' stamp: 'pb 5/31/2019 19:40:07'! - stencil: stencilForm at: aPoint color: aColor - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-images' stamp: 'pb 5/31/2019 19:40:17'! - stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-ovals' stamp: 'pb 5/31/2019 19:34:51'! - ellipseCenterX: mcx y: mcy rx: mrx ry: mry borderWidth: mbw borderColor: mbc fillColor: morphFillColor - self subclassResponsibility ! ! -!MorphicCanvas methodsFor: 'drawing-rectangles' stamp: 'pb 5/31/2019 19:41:12'! - fillRectangle: aRectangle color: aColor - self subclassResponsibility ! ! -!MorphicCanvas methodsFor: 'drawing-rectangles' stamp: 'pb 5/31/2019 19:41:22'! - fillRectangle: aRectangle color: aColor borderWidth: borderWidth borderStyleSymbol: aSymbol baseColorForBorder: baseColorForBorder - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-rectangles' stamp: 'pb 5/31/2019 19:41:31'! - fillRectangle: aRectangle tilingWith: aForm multipliedBy: aColor - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-rectangles' stamp: 'pb 5/31/2019 19:41:47'! - frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor - self subclassResponsibility ! ! -!MorphicCanvas methodsFor: 'drawing-rectangles' stamp: 'pb 5/31/2019 19:42:05'! - frameRectangle: r borderWidth: borderWidth color: borderColor - self subclassResponsibility ! ! -!MorphicCanvas methodsFor: 'drawing-rectangles' stamp: 'pb 5/31/2019 19:42:23'! - frameRectangle: r color: aColor borderWidth: borderWidth borderStyleSymbol: aSymbol - self subclassResponsibility ! ! -!MorphicCanvas methodsFor: 'drawing-rectangles' stamp: 'pb 5/31/2019 19:42:33'! - reverseRectangleBorder: r borderWidth: borderWidth - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-roundedRectangles' stamp: 'pb 5/31/2019 19:43:02'! - roundRect: aRectangle color: aColor radius: r - self subclassResponsibility ! ! -!MorphicCanvas methodsFor: 'drawing-roundedRectangles' stamp: 'pb 5/31/2019 19:43:12'! - roundRect: displayRectangle color: aColor radius: r gradientTop: topFactor gradientBottom: bottomFactor gradientHeight: h - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-roundedRectangles' stamp: 'pb 5/31/2019 19:43:22'! - roundRect: aRectangle color: aColor radius: r gradientTop: topFactor gradientCenter: centerFactor gradientBottom: bottomFactor gradient1Height: h1 - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-roundedRectangles' stamp: 'pb 5/31/2019 19:43:31'! - windowFrame: aRectangle color: aColor radius: r border: bw labelHeight: lh gradientTop: topFactor gradientBottom: bottomFactor insideColor: insideColor - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'pb 5/31/2019 19:38:04'! - drawString: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - self subclassResponsibility ! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'pb 5/31/2019 19:49:08'! - clippingRectForCurrentMorph - "In form coordinates" - "En M3, es el obtenido al dibujarlo, recien. -Dejar eso claro en el nombre. Eliminar 'clipping'" - ^ currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds.! ! -!MorphicCanvas methodsFor: 'testing' stamp: 'pb 5/31/2019 19:50:24'! - isCurrentMorphVisible - | aRectangle | - currentMorph visible ifFalse: [ ^ false ]. - aRectangle _ currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds. - "Optimization" - aRectangle right < clipLeft ifTrue: [ ^ false ]. - aRectangle left > (clipRight + 1) ifTrue: [ ^ false ]. - aRectangle bottom < clipTop ifTrue: [ ^ false ]. - aRectangle top > (clipBottom + 1) ifTrue: [ ^ false ]. - ^ true.! ! -!MorphicCanvas methodsFor: 'private' stamp: 'pb 5/31/2019 19:32:16'! - setForm: aForm - form _ aForm.! ! -!BitBltCanvas methodsFor: 'private' stamp: 'pb 5/31/2019 19:32:31' prior: 16787141! - setForm: aForm - super setForm: aForm. - self resetGrafPort. - self newClipRect: nil.! ! - -BitBltCanvas removeSelector: #clippingRectForCurrentMorph! - -BitBltCanvas removeSelector: #clippingRectForCurrentMorph! - -BitBltCanvas removeSelector: #isCurrentMorphVisible! - -BitBltCanvas removeSelector: #isCurrentMorphVisible! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3789-CanvasCleanup-PhilBellalouna-2019May31-19h32m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3789] on 10 June 2019 at 10:59:02 am'! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 6/10/2019 10:39:02'! - clippingRectForCurrentMorph - "In form coordinates" - - ^currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds! ! -!BitBltCanvas methodsFor: 'testing' stamp: 'jmv 6/10/2019 10:47:56'! - isCurrentMorphVisible - - | aRectangle | - currentMorph visible ifFalse: [ ^false ]. - aRectangle _ self clippingRectForCurrentMorph. - "Optimization" - aRectangle right < clipLeft ifTrue: [^ false]. - aRectangle left > (clipRight+1) ifTrue: [^ false]. - aRectangle bottom < clipTop ifTrue: [^ false]. - aRectangle top > (clipBottom+1) ifTrue: [^ false]. - ^ true -! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 6/10/2019 10:53:51' prior: 16875248! - externalizeDisplayBounds: r - - | inOwners | - "All senders of #displayBoundsOfTransformOf: should be rethought..." - self flag: #jmvVer2. - - inOwners _ location displayBoundsOfTransformOf: r. - ^owner - ifNotNil: [ owner externalizeDisplayBounds: inOwners ] - ifNil: [ inOwners ]! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 6/10/2019 10:44:13' prior: 50463531! - clippingRectForCurrentMorph - "This only works reasonably with BitBltCanvas (where submorph clipping is only about Rectangles (aligned with target form pixel grille). - For submorph cliping in VectorCanvas we use #currentOwnerIfClips:, and this 'clippingRect' is just an optimization of the area to be redrawn. - So, we need a better name than #clippingRectForCurrentMorph" - self revisar. - self subclassResponsibility! ! -!MorphicCanvas methodsFor: 'testing' stamp: 'jmv 6/10/2019 10:34:59' prior: 50463541! - isCurrentMorphVisible - self subclassResponsibility! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3790-CanvasTweaks-JuanVuletich-2019Jun10-10h57m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3771] on 26 May 2019 at 7:38:33 am'! -!IndentingListItemMorph methodsFor: 'events' stamp: 'len 5/26/2019 05:08:15'! - mouseEnter: event - isHighlighted _ true. - self redrawNeeded. - ^super mouseEnter: event! ! -!IndentingListItemMorph methodsFor: 'events' stamp: 'len 5/26/2019 05:08:59'! - mouseLeave: event - isHighlighted _ false. - self redrawNeeded. - ^super mouseEnter: event! ! -!IndentingListItemMorph methodsFor: 'event handling testing' stamp: 'len 5/26/2019 05:12:45'! - handlesMouseOver: event - ^ true! ! -!IndentingListItemMorph methodsFor: 'drawing' stamp: 'len 5/26/2019 07:35:54' prior: 50385175! - drawOn: aCanvas - - | tRect colorToUse sLeft aForm centeringOffset | - isHighlighted ifTrue: [ - aCanvas - fillRectangle: (`0@0` extent: extent) - color: ((Theme current - listHighlightFocused: owner owner hasKeyboardFocus) alpha: 0.3) ]. - isSelected ifTrue: [ - aCanvas - fillRectangle: (`0@0` extent: extent) - color: (Theme current - listHighlightFocused: owner owner hasKeyboardFocus) ]. - - tRect _ self toggleRectangle. - aForm _ isExpanded - ifTrue: [ container expandedForm ] - ifFalse: [ container notExpandedForm ]. - centeringOffset _ ((tRect height - aForm extent y) / 2.0) rounded. - - complexContents hasContents ifTrue: [ - aCanvas - image: aForm - at: (tRect topLeft translatedBy: 0 @ centeringOffset) ]. - - icon isNil - ifFalse: [ - aCanvas - image: icon - at: (tRect topLeft translatedBy: icon width @ centeringOffset). - sLeft _ indentLevel * 12 + 16 + (icon width + 2). - ] - ifTrue: [ - sLeft _ indentLevel * 12 + 16. - ]. - colorToUse _ complexContents preferredColor ifNil: [ color ]. - - aCanvas - drawString: contents asString - at: sLeft@0 - font: self fontToUse - color: colorToUse! ! -!InnerListMorph methodsFor: 'drawing' stamp: 'len 5/26/2019 07:34:30' prior: 50385652! - drawHighlightOn: aCanvas -"Ademas, poner el mouse pointer de relojito si tarda... Detectarlo automaticamente, etc. Aunque no estoy seguro de como hacerlo... quizas colgar un cachito de codigo en un proceso de mayor prioridad, onda 'si pasa 1 segundo, y todavia no te resetee este flag, entonces pone el relojito'" - | selectionDrawBounds | - highlightedRow ifNil: [ ^self ]. - highlightedRow = 0 ifTrue: [ ^self ]. - selectionDrawBounds _ self drawBoundsForRow: highlightedRow. - selectionDrawBounds _ selectionDrawBounds intersect: (`0@0` extent: extent). - aCanvas - fillRectangle: selectionDrawBounds - color: ((Theme current listHighlightFocused: owner hasKeyboardFocus) alpha: 0.3)! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3791-MouseOverHighlightImprovements-LucianoEstebanNotarfrancesco-2019May26-07h31m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3791] on 11 June 2019 at 11:07:45 am'! -!Character methodsFor: 'accessing' stamp: 'jmv 6/11/2019 11:04:59'! - codePointOfGlyphToUse - " - For certain ASCII characters, we prefer a non ASCII Unicode glyph if available (i.e. with TrueType fonts). - $* codePoint hex - $* codePointOfGlyphToUse hex - " - self = $- ifTrue: [ ^16r2212 ]. "WIDE MINUS" - self = $* ifTrue: [ ^16r2217 ]. "CENTERED ASTERISK" - ^ self codePoint! ! -!Character class methodsFor: 'class initialization' stamp: 'jmv 6/11/2019 11:05:22' prior: 50457829! - initialize - "Create the table of unique Characters. - Character initialize - " - self initializeLookupTables. - self initializeUnicodeCodePoints.! ! -!Character class methodsFor: 'class initialization' stamp: 'jmv 6/11/2019 11:05:16' prior: 50458283! - initializeUnicodeCodePoints - " - Character initializeUnicodeCodePoints - String streamContents: [ :strm | 28 to: 255 do: [ :i | strm nextPut: (Character numericValue: i) ]] - " - - "Initialize the table of Unicode code points" - UnicodeCodePoints _ Array new: 256. - 0 to: 255 do: [ :code | - UnicodeCodePoints at: code + 1 put: code ]. - - "Arrows" - UnicodeCodePoints at: 28+1 put: 8592. "left arrow" - UnicodeCodePoints at: 29+1 put: 8594. "right arrow" - UnicodeCodePoints at: 30+1 put: 8593. "up arrow" - UnicodeCodePoints at: 31+1 put: 8595. "down arrow" - - "The following codes are different in ISO 8859-15 from those in ISO 8859-1, - so the character code is not equal to the Unicode code point" - UnicodeCodePoints at: 16rA4+1 put: 16r20AC. "euro sign" - UnicodeCodePoints at: 16rA6+1 put: 16r160. "latin capital letter S with caron" - UnicodeCodePoints at: 16rA8+1 put: 16r161. "latin small letter s with caron" - UnicodeCodePoints at: 16rB4+1 put: 16r17D. "latin capital letter Z with caron" - UnicodeCodePoints at: 16rB8+1 put: 16r17E. "latin small letter z with caron" - UnicodeCodePoints at: 16rBC+1 put: 16r152. "latin capital ligature OE" - UnicodeCodePoints at: 16rBD+1 put: 16r153. "latin small ligature oe" - UnicodeCodePoints at: 16rBE+1 put: 16r178. "latin capital letter Y with diaeresis" - - UnicodeCodePoints at: 16r80+1 put: 16r2205. "EMPTY SET" - UnicodeCodePoints at: 16r81+1 put: 16r221E. "INFINITY" - UnicodeCodePoints at: 16r82+1 put: 16r2135. "ALEF SYMBOL" - UnicodeCodePoints at: 16r83+1 put: 16r03C0. "pi" - UnicodeCodePoints at: 16r84+1 put: 16r03B5. "epsilon" - UnicodeCodePoints at: 16r85+1 put: 16r03B6. "zeta" - UnicodeCodePoints at: 16r86+1 put: 16r0394. "Delta" - UnicodeCodePoints at: 16r87+1 put: 16r03A9. "Omega" - UnicodeCodePoints at: 16r88+1 put: 16r2102. "DOUBLE-STRUCK CAPITAL C" - UnicodeCodePoints at: 16r89+1 put: 16r210D. "DOUBLE-STRUCK CAPITAL H" - UnicodeCodePoints at: 16r8A+1 put: 16r2115. "DOUBLE-STRUCK CAPITAL N" - UnicodeCodePoints at: 16r8B+1 put: 16r2119. "DOUBLE-STRUCK CAPITAL P" - UnicodeCodePoints at: 16r8C+1 put: 16r211A. "DOUBLE-STRUCK CAPITAL Q" - UnicodeCodePoints at: 16r8D+1 put: 16r211D. "DOUBLE-STRUCK CAPITAL R" - UnicodeCodePoints at: 16r8E+1 put: 16r2124. "DOUBLE-STRUCK CAPITAL Z" - UnicodeCodePoints at: 16r8F+1 put: 16r0046. "DOUBLE-STRUCK CAPITAL F" "should be 1D53D, index out of bounds" - UnicodeCodePoints at: 16r90+1 put: 16r2295. "OPLUS" - UnicodeCodePoints at: 16r91+1 put: 16r2297. "OTIMES" - UnicodeCodePoints at: 16r92+1 put: 16r2299. "ODOT" - UnicodeCodePoints at: 16r93+1 put: 16r2296. "OMINUS" - UnicodeCodePoints at: 16r94+1 put: 16r2217. "ASTERISK OPERATOR" - UnicodeCodePoints at: 16r95+1 put: 16r2218. "RING OPERATOR (circ)" - UnicodeCodePoints at: 16r96+1 put: 16r2219. "BULLET OPERATOR (filled circ)" - UnicodeCodePoints at: 16r97+1 put: 16r22C5. "DOT OPERATOR" "(already at B7)" - UnicodeCodePoints at: 16r98+1 put: 16r22C6. "STAR OPERATOR" - UnicodeCodePoints at: 16r99+1 put: 16r21A0. "SURJECTIVE ARROW" - UnicodeCodePoints at: 16r9A+1 put: 16r21A3. "INJECTIVE ARROW" - UnicodeCodePoints at: 16r9B+1 put: 16r2194. "BIJECTIVE ARROW" - UnicodeCodePoints at: 16r9C+1 put: 16r21AA. "INCLUSION ARROW" - UnicodeCodePoints at: 16r9D+1 put: 16r21A6. "MAPPING ARROW" - UnicodeCodePoints at: 16r9E+1 put: 16r2202. "PARTIAL DIFFERENTIAL" - UnicodeCodePoints at: 16r9F+1 put: 16r221A. "SQUARE ROOT" - - "Additionally, see #codePointOfGlyphToUse"! ! - -Character initialize! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3792-TrueTypeGlyphsTweak-JuanVuletich-2019Jun11-10h49m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3791] on 11 June 2019 at 11:56:29 am'! -!Number methodsFor: 'comparing' stamp: 'jmv 6/11/2019 11:41:36'! - = aNumber - "Note: Consistency between #= and #hash for numeric classes is not done in the usual way (redefining them together), because we also need #= and #hash consistency across numeric classes: - (3 = 3.0) ifTrue: [3 hash = 3.0 hash] - Therefore, consistency between #= and #hash for numeric classes is validated by specific tests" - - ^self subclassResponsibility! ! -!Number methodsFor: 'comparing' stamp: 'jmv 6/11/2019 11:41:27'! - hash - "Note: Consistency between #= and #hash for numeric classes is not done in the usual way (redefining them together), because we also need #= and #hash consistency across numeric classes: - (3 = 3.0) ifTrue: [3 hash = 3.0 hash] - Therefore, consistency between #= and #hash for numeric classes is validated by specific tests" - - ^self subclassResponsibility! ! -!TextDoIt methodsFor: 'comparing' stamp: 'jmv 6/11/2019 11:43:43'! - hash - "Hash is reimplemented because = is implemented." - - ^evalString hash! ! -!TextURL methodsFor: 'comparing' stamp: 'jmv 6/11/2019 11:43:54'! - hash - "Hash is reimplemented because = is implemented." - - ^url hash! ! -!TextAnchor methodsFor: 'comparing' stamp: 'jmv 6/11/2019 11:44:13'! - hash - "Hash is reimplemented because = is implemented." - - ^anchoredFormOrMorph hash! ! -!FeatureRequirement methodsFor: 'comparing' stamp: 'jmv 6/11/2019 11:45:31'! - hash - "Hash is reimplemented because = is implemented." - - ^name hash! ! -!CharacterBlock methodsFor: 'comparing' stamp: 'jmv 6/11/2019 11:42:38'! - hash - "Hash is reimplemented because = is implemented." - - ^stringIndex hash! ! -!MouseScrollEvent methodsFor: 'comparing' stamp: 'jmv 6/11/2019 11:54:11'! - = aMorphicEvent - - "Any object is equal to itself" - self == aMorphicEvent ifTrue: [ ^ true ]. - - self class == aMorphicEvent class ifFalse: [ ^ false ]. - - position = aMorphicEvent eventPosition ifFalse: [ ^ false ]. - buttons = aMorphicEvent buttons ifFalse: [ ^ false ]. - direction = aMorphicEvent direction ifFalse: [ ^ false ]. - ^ true! ! - -MorphicEvent removeSelector: #hash! - -MorphicEvent removeSelector: #hash! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3793-hashCleanup-JuanVuletich-2019Jun11-11h16m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3793] on 11 June 2019 at 2:07:48 pm'! -!Character methodsFor: 'testing' stamp: 'jmv 6/11/2019 12:14:09'! - is: aSymbol - ^ aSymbol == #Character or: [ super is: aSymbol ]! ! -!String methodsFor: 'enumerating' stamp: 'jmv 6/11/2019 12:23:44'! - collect: aBlock - "Refer to the comment in Collection|collect:." - | result value stillAString | - result _ self species new: self size. - stillAString _ true. - 1 to: self size do: [ :index | - value _ aBlock value: (self at: index). - (stillAString and: [ (value is: #Character) not]) ifTrue: [ - result _ result asArray. - stillAString _ false ]. - result at: index put: value]. - ^ result! ! -!Collection methodsFor: 'private' stamp: 'jmv 6/11/2019 12:08:53' prior: 16814664! - species - "Answer the preferred class for reconstructing the receiver. For example, - collections create new collections whenever enumeration messages such as - collect: or select: are invoked. The new kind of collection is determined by - the species of the original collection. Species and class are not always the - same. For example, the species of Interval is Array." - "Redefined here just for reference. See inheritance. - #collect: avoids using #species in String, when there are non-Character objects - #select: and #copy avoid using it in SortedCollection" - - ^ self class! ! -!String methodsFor: 'accessing' stamp: 'jmv 6/11/2019 12:14:25' prior: 16915413! - 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." - - - (aCharacter is: #Character) - ifTrue: [ - index isInteger - ifTrue: [self errorSubscriptBounds: index] - ifFalse: [self errorNonIntegerIndex]] - ifFalse: [self error: 'Strings only store Characters']! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3794-String-collect-enhancements-JuanVuletich-2019Jun11-14h06m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3793] on 11 June 2019 at 2:08:54 pm'! -!Semaphore methodsFor: 'private' stamp: 'jmv 6/11/2019 12:31:53'! - species - "So we are never equal an Array" - - ^ self class! ! -!RunArray methodsFor: 'accessing' stamp: 'jmv 6/11/2019 12:34:02' prior: 16901152! - = otherArray - self == otherArray ifTrue: [ ^ true ]. - - self species == otherArray species ifFalse: [^ false]. - - "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]! ! -!Dictionary methodsFor: 'testing' stamp: 'jmv 6/11/2019 12:41:01' prior: 16833502! - is: aSymbol - "Dictionaries and Sets have different #species. So, aDictionary is: #Set should be false." - aSymbol == #Set ifTrue: [ ^ false ]. - ^aSymbol == #Dictionary or: [ super is: aSymbol ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3795-Collections-equality-fixes-JuanVuletich-2019Jun11-14h07m-jmv.1.cs.st----! - -----SNAPSHOT----(11 June 2019 14:16:39) Cuis5.0-3795-v3.image priorSource: 4198046! - -----QUIT----(11 June 2019 14:16:58) Cuis5.0-3795-v3.image priorSource: 4236638! - -----STARTUP---- (12 July 2019 10:26:57) as /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/Cuis5.0-3795-v3.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3795] on 11 June 2019 at 8:54:49 pm'! -!SequenceableCollection methodsFor: 'comparing' stamp: 'jmv 6/11/2019 18:53:56'! - hashQuick - | hash size step | - - size _ self size. - hash _ (self species hash + size hash) hashMultiply. - step _ size < 64 ifTrue: [1] ifFalse: [size//64]. - 1 to: size by: step do: [ :i | | elem | - elem _ self at: i. - elem == self ifFalse: [ - hash _ (hash + elem hash) hashMultiply]]. - ^hash! ! -!FloatArray methodsFor: 'comparing' stamp: 'jmv 6/11/2019 16:12:42'! - hashFull - | hash | - - hash _ (self species hash + self size hash) hashMultiply. - 1 to: self size do: [:i | hash _ (hash + (self basicAt: i)) hashMultiply]. - ^hash! ! -!Association methodsFor: 'comparing' stamp: 'jmv 6/11/2019 18:22:00' prior: 16780999! - hash - "Hash is reimplemented because = is implemented." - - value == self ifTrue: [ ^ key hash ]. - ^key hash bitXor: value hash.! ! -!Collection methodsFor: 'comparing' stamp: 'jmv 6/11/2019 19:07:39' prior: 16814019! - hash - "A default hash function for any collection. Note that this method only considers a few elements so you might want to refine this behavior." - - | size hash count | - size _ self size. - hash _ self species hash bitXor: size hash. - count _ 0. - self do: [ :elem | - elem == self ifFalse: [ - hash _ hash bitXor: elem hash. - count _ count + 1. - count =64 ifTrue: [ - ^ hash]]]. - ^ hash! ! -!SequenceableCollection methodsFor: 'comparing' stamp: 'jmv 6/11/2019 16:08:53' prior: 16906036! - hash - "Subclasses might use other methods. - However #hashQuick is suggested for very large collections." - ^ self hashQuick! ! -!String methodsFor: 'comparing' stamp: 'jmv 6/11/2019 16:23:20' prior: 16915822! - = aString - "Answer whether the receiver sorts equally as aString. - This means same characters in same order." - - "Any object is equal to itself" - self == aString ifTrue: [ ^ true ]. - - "If argument is not a String or Symbol, maybe it is a Text?" - aString species == String ifFalse: [ - (aString is: #Text) ifTrue: [ ^ self = aString string ]. - ^ false]. - - self size = aString size ifFalse: [ - ^false ]. - - self size > 256 ifTrue: [ - self hashQuick = aString hashQuick ifFalse: [ ^false ]]. - - ^ (self compare: self with: aString collated: CaseSensitiveOrder) = 2! ! -!String methodsFor: 'comparing' stamp: 'jmv 6/11/2019 16:13:53' prior: 16916053! - hash - "#hash is implemented, because #= is implemented" - self size > 256 ifTrue: [ ^ self hashQuick ]. - ^ByteArray - hashBytes: self - startingWith: self species hash! ! -!ByteArray methodsFor: 'comparing' stamp: 'jmv 6/11/2019 16:09:49' prior: 16793826! - hash - "#hash is implemented, because #= is implemented" - self size > 256 ifTrue: [ ^ self hashQuick ]. - ^self class - hashBytes: self - startingWith: self species hash! ! -!FloatArray methodsFor: 'comparing' stamp: 'jmv 6/11/2019 16:22:31' prior: 50348235! -= another - self == another ifTrue: [ ^ true ]. - self class == another class ifFalse: [ ^ false ]. - self size > 256 ifTrue: [ - self hashQuick = another hashQuick ifFalse: [ ^false ]]. - ^self primitiveEqual: another! ! -!FloatArray methodsFor: 'comparing' stamp: 'jmv 6/11/2019 16:10:44' prior: 16846547! - hash - self size > 256 ifTrue: [ ^ self hashQuick ]. - ^ self hashFull! ! -!Set methodsFor: 'testing' stamp: 'jmv 6/11/2019 18:46:53' prior: 16907334! - = aSet - - self == aSet ifTrue: [^ true]. "Any object is equal to itself" - self species == aSet species ifFalse: [^ false]. - self size = aSet size ifFalse: [^ false]. - self do: [ :each | (aSet includes: each) ifFalse: [^ false]]. - ^ true! ! -!Dictionary methodsFor: 'testing' stamp: 'jmv 7/4/2016 22:13' prior: 50464032! - is: aSymbol - ^aSymbol == #Dictionary or: [ super is: aSymbol ]! ! -!Dictionary methodsFor: 'comparing' stamp: 'jmv 6/11/2019 18:47:15' prior: 16833837! - = 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]. "Any object is equal to itself" - self species == aDictionary species ifFalse: [^ false]. - self size = aDictionary size ifFalse: [^false]. - self associationsDo: [:assoc| - (aDictionary at: assoc key ifAbsent: [^false]) = assoc value - ifFalse: [^false]]. - ^true - -! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3796-AdditionalHashAndEqualityEnhancements-JuanVuletich-2019Jun11-20h52m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3796] on 11 June 2019 at 9:19:18 pm'! -!Association methodsFor: 'comparing' stamp: 'jmv 6/11/2019 21:18:46' prior: 50464080! - hash - "Hash is reimplemented because = is implemented." - - ^ key hash! ! -!Collection methodsFor: 'comparing' stamp: 'di 12/14/1999 07:45' prior: 50464087! - hash - "A default hash function for any collection. Note that this method is insensitive to contents when the size is greater than 10, so critical applications that compare many large collections of the same length will want to refine this behavior." - - | hash | - hash _ self species hash. - self size <= 10 ifTrue: - [self do: [:elem | hash _ hash bitXor: elem hash]]. - ^ hash bitXor: self size hash -! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3797-Collection-hash-rollBack-Association-hash-dontRecurse-JuanVuletich-2019Jun11-21h15m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3797] on 11 June 2019 at 10:14:24 pm'! -!Dictionary methodsFor: 'comparing' stamp: 'jmv 6/11/2019 22:13:22'! - hash - "Note that this method is insensitive to contents when the size is greater than 10, so critical applications that compare many large collections of the same length will want to refine this behavior." - - | hash | - hash _ self species hash. - self size <= 10 ifTrue: [ - self associationsDo: [ :association | hash _ hash bitXor: association hash ]]. - ^ hash bitXor: self size hash! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3798-Dictionary-hash-JuanVuletich-2019Jun11-22h11m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3798] on 12 June 2019 at 9:19:25 am'! -!ParseNode methodsFor: 'testing' stamp: 'jmv 6/12/2019 09:17:45'! - isSuperPseudoVariable - "Overridden in VariableNode." - ^false! ! -!VariableNode methodsFor: 'testing' stamp: 'jmv 6/12/2019 09:17:53'! - isSuperPseudoVariable - "Answer if this ParseNode represents the 'self' pseudo-variable." - - ^ key = 'super' or: [name = '{{super}}']! ! -!MessageNode methodsFor: 'private' stamp: 'jmv 6/12/2019 09:18:46' prior: 16868602! - pvtCheckForPvtSelector: encoder - "If the code being compiled is trying to send a private message (e.g. 'pvtCheckForPvtSelector:') to anyone other than self, then complain to encoder." - - selector isPvtSelector ifTrue: [ - (receiver isSelfPseudoVariable or: [ receiver isSuperPseudoVariable ]) ifFalse: [ - encoder notify: 'Private messages may only be sent to self or super']].! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3799-AllowSuperSendsOfPvtMethods-JuanVuletich-2019Jun12-09h17m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3799] on 12 June 2019 at 5:45:08 pm'! -!Symbol methodsFor: 'testing' stamp: 'jmv 6/12/2019 09:46:50'! - isPvtInitializeSelector - "Answer whether the receiver is a private instance initialization message selector, that is, - begins with 'pvtInitialize' (followed or not by additional stuff, as a unary message, or as keyword with arguments)" - - ^ self beginsWith: 'pvtInitialize'! ! -!ParseNode methodsFor: 'testing' stamp: 'jmv 6/12/2019 17:44:11'! - isSelfBasicNewMessageSend - "Overridden in MessageNode." - ^false! ! -!ParseNode methodsFor: 'testing' stamp: 'jmv 6/12/2019 09:44:25'! - isSelfNewMessageSend - "Overridden in MessageNode." - ^false! ! -!SelectorNode methodsFor: 'testing' stamp: 'jmv 6/12/2019 09:47:15'! - isPvtInitializeSelector - "Answer whether the receiver is a private instance initialization message selecto" - - ^ key isPvtInitializeSelector! ! -!MessageNode methodsFor: 'testing' stamp: 'jmv 6/12/2019 17:44:09'! - isSelfBasicNewMessageSend - "Answer if this ParseNode represents the 'self new'' message send." - - ^ receiver isSelfPseudoVariable and: [ self selectorSymbol == #basicNew ]! ! -!MessageNode methodsFor: 'testing' stamp: 'jmv 6/12/2019 09:44:22'! - isSelfNewMessageSend - "Answer if this ParseNode represents the 'self new'' message send." - - ^ receiver isSelfPseudoVariable and: [ self selectorSymbol == #new ]! ! -!MessageNode methodsFor: 'private' stamp: 'jmv 6/12/2019 17:44:32' prior: 50464266! - pvtCheckForPvtSelector: encoder - "If the code being compiled is trying to send a private message (e.g. 'pvtCheckForPvtSelector:') to anyone other than self, then complain to encoder." - - selector isPvtInitializeSelector ifTrue: [ - (receiver isSelfNewMessageSend or: [receiver isSelfBasicNewMessageSend]) ifFalse: [ - encoder notify: 'Private instance initialization messages may only be sent to ''self new'' or "self basicNew" (by class instance creation methods)']. - ^ self ]. - selector isPvtSelector ifTrue: [ - (receiver isSelfPseudoVariable or: [ receiver isSuperPseudoVariable ]) ifFalse: [ - encoder notify: 'Private messages may only be sent to self or super']].! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3800-pvtInitialize-support-JuanVuletich-2019Jun12-17h42m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3799] on 12 June 2019 at 10:02:22 am'! -!Point methodsFor: 'private - initialization' stamp: 'jmv 6/12/2019 09:55:41'! - pvtInitializeX: xValue y: yValue - "Points are immutable." - x _ xValue. - y _ yValue! ! -!Point class methodsFor: 'instance creation' stamp: 'jmv 6/12/2019 09:55:51' prior: 50335837! - x: anX y: anY - "Answer an instance of me with supplied coordinates." - - ^self new pvtInitializeX: anX y: anY! ! - -Point removeSelector: #privateSetX:setY:! - -Point removeSelector: #privateSetX:setY:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3801-ImmutablePoints-JuanVuletich-2019Jun12-10h00m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3799] on 12 June 2019 at 10:15:34 am'! -!CharacterSet methodsFor: 'collection ops' stamp: 'jmv 6/12/2019 10:11:23' prior: 16802206! - includes: aCharacter - (aCharacter is: #Character) ifFalse: [ ^ false ]. - ^(map at: aCharacter numericValue + 1) > 0! ! -!Interval methodsFor: 'testing' stamp: 'jmv 6/12/2019 10:14:04' prior: 16861288! - includes: aNumber - aNumber isNumber ifFalse: [ ^ false ]. - ^ aNumber between: self first and: self last! ! -!Trie methodsFor: 'testing' stamp: 'jmv 6/12/2019 10:14:56' prior: 16939257! - includes: aString - "Consistent with Set, but not with Dictionary, as in Dictionary, #includes: - finds a value regardless of the key. To get this behavior, use #includesValue:" - - aString isString ifFalse: [ ^ false ]. - self at: aString ifPresent: [ :v | ^v = aString ]. - ^false! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3802-universalIncludes-JuanVuletich-2019Jun12-10h02m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3802] on 12 June 2019 at 6:11:48 pm'! -!Collection methodsFor: 'comparing' stamp: 'jmv 6/12/2019 18:08:54'! - emptyCollectionHash - ^self species hash! ! -!Set methodsFor: 'comparing' stamp: 'jmv 6/12/2019 18:09:50'! - emptyCollectionHash - ^ Set hash! ! -!Dictionary methodsFor: 'comparing' stamp: 'jmv 6/12/2019 18:10:04'! - emptyCollectionHash - ^ Dictionary hash! ! -!Collection methodsFor: 'comparing' stamp: 'jmv 6/12/2019 18:09:13' prior: 50464208! - hash - "A default hash function for any collection. Note that this method is insensitive to contents when the size is greater than 10, so critical applications that compare many large collections of the same length will want to refine this behavior." - - | hash | - hash _ self emptyCollectionHash. - self size <= 10 ifTrue: [ - self do: [ :elem | hash _ hash bitXor: elem hash]]. - ^ hash bitXor: self size hash -! ! -!Set methodsFor: 'testing' stamp: 'jmv 6/12/2019 18:05:55' prior: 50464162! - = aSet - - self == aSet ifTrue: [^ true]. "Any object is equal to itself" - (aSet is: #Set) ifFalse: [^ false]. - (aSet is: #Dictionary) ifTrue: [^ false]. - self size = aSet size ifFalse: [^ false]. - self do: [ :each | (aSet includes: each) ifFalse: [^ false]]. - ^ true! ! -!Dictionary methodsFor: 'comparing' stamp: 'jmv 7/5/2016 09:20' prior: 50464177! - = 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]. "Any object is equal to itself" - (aDictionary is: #Dictionary) ifFalse: [^false]. - self size = aDictionary size ifFalse: [^false]. - self associationsDo: [:assoc| - (aDictionary at: assoc key ifAbsent: [^false]) = assoc value - ifFalse: [^false]]. - ^true - -! ! -!Dictionary methodsFor: 'comparing' stamp: 'jmv 6/12/2019 18:11:13' prior: 50464232! - hash - "Note that this method is insensitive to contents when the size is greater than 10, so critical applications that compare many large collections of the same length will want to refine this behavior." - - | hash | - hash _ self emptyCollectionHash. - self size <= 10 ifTrue: [ - self associationsDo: [ :association | hash _ hash bitXor: association hash ]]. - ^ hash bitXor: self size hash! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3803-SetAndIdentitySetMayBeEqual-JuanVuletich-2019Jun12-18h02m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3801] on 12 June 2019 at 5:27:40 pm'! -!ParseNode methodsFor: 'testing' stamp: 'HAW 6/12/2019 17:23:21'! - isFalsePseudoVariable - "Overridden in VariableNode." - ^false! ! -!ParseNode methodsFor: 'testing' stamp: 'HAW 6/12/2019 17:23:26'! - isNilPseudoVariable - "Overridden in VariableNode." - ^false! ! -!ParseNode methodsFor: 'testing' stamp: 'HAW 6/12/2019 17:23:34'! - isThisContextPseudoVariable - "Overridden in VariableNode." - ^false! ! -!ParseNode methodsFor: 'testing' stamp: 'HAW 6/12/2019 17:23:42'! - isTruePseudoVariable - "Overridden in VariableNode." - ^false! ! -!VariableNode methodsFor: 'testing' stamp: 'HAW 6/12/2019 17:25:37'! - isFalsePseudoVariable - - ^key = 'false' or: [name = '{{false}}']! ! -!VariableNode methodsFor: 'testing' stamp: 'HAW 6/12/2019 17:25:44'! - isNilPseudoVariable - - ^ key = 'nil' or: [name = '{{nil}}']! ! -!VariableNode methodsFor: 'testing' stamp: 'HAW 6/12/2019 17:26:06'! - isThisContextPseudoVariable - - ^key = 'thisContext' or: [name = '{{thisContext}}']! ! -!VariableNode methodsFor: 'testing' stamp: 'HAW 6/12/2019 17:25:56'! - isTruePseudoVariable - - ^ key = 'true' or: [name = '{{true}}']! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3804-isXxxPseudoVariable-HernanWilkinson-2019Jun12-17h22m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3804] on 13 June 2019 at 8:56:28 am'! -!Symbol methodsFor: 'testing' stamp: 'jmv 6/13/2019 08:54:44'! - isInitializePvtSelector - "Answer whether the receiver is a private instance initialization message selector, that is, - begins with 'initializePvt' (followed or not by additional stuff, as a unary message, or as keyword with arguments)" - - ^ self beginsWith: 'initializePvt'! ! -!SelectorNode methodsFor: 'testing' stamp: 'jmv 6/13/2019 08:54:32'! - isInitializePvtSelector - "Answer whether the receiver is a private instance initialization message selector" - - ^ key isInitializePvtSelector! ! -!Point methodsFor: 'private - initialization' stamp: 'jmv 6/13/2019 08:51:25'! - initializePvtX: xValue y: yValue - "Points are immutable." - x _ xValue. - y _ yValue! ! -!MessageNode methodsFor: 'private' stamp: 'jmv 6/13/2019 08:52:31' prior: 50464332! - pvtCheckForPvtSelector: encoder - "If the code being compiled is trying to send a private message (e.g. 'pvtCheckForPvtSelector:') to anyone other than self, then complain to encoder." - - selector isInitializePvtSelector ifTrue: [ - (receiver isSelfNewMessageSend or: [receiver isSelfBasicNewMessageSend]) ifFalse: [ - encoder notify: 'Private instance initialization messages may only be sent to ''self new'' or "self basicNew" (by class instance creation methods)']]. - selector isPvtSelector ifTrue: [ - (receiver isSelfPseudoVariable or: [ receiver isSuperPseudoVariable ]) ifFalse: [ - encoder notify: 'Private messages may only be sent to self or super']].! ! -!Point class methodsFor: 'instance creation' stamp: 'jmv 6/13/2019 08:55:26' prior: 50464370! - x: anX y: anY - "Answer an instance of me with supplied coordinates." - - ^self new initializePvtX: anX y: anY! ! - -Point removeSelector: #pvtInitializeX:y:! - -Point removeSelector: #pvtInitializeX:y:! - -SelectorNode removeSelector: #isPvtInitializeSelector! - -SelectorNode removeSelector: #isPvtInitializeSelector! - -Symbol removeSelector: #isPvtInitializeSelector! - -Symbol removeSelector: #isPvtInitializeSelector! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3805-ImmutableInitializationEnh-JuanVuletich-2019Jun13-08h51m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3805] on 22 June 2019 at 3:21:51 pm'! -!SUnitNameResolver class methodsFor: 'Camp Smalltalk' stamp: 'sqr 6/22/2019 15:21:45' prior: 16903599! - errorObject - ^UnhandledError! ! -!TestCase methodsFor: 'assertions' stamp: 'sqr 6/26/2019 12:51:03' prior: 50447590! - shouldntFail: aBlock - - self shouldnt: aBlock raise: TestResult exError! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3806-SUnitFix-AndresValloud-2019Jun22-15h20m-sqr.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3805] on 22 June 2019 at 3:26:49 pm'! - -ArithmeticError subclass: #NegativePowerError - instanceVariableNames: 'base argument selector' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #NegativePowerError category: #'Exceptions Kernel'! -ArithmeticError subclass: #NegativePowerError - instanceVariableNames: 'base argument selector' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! -!NegativePowerError methodsFor: 'initialization' stamp: 'jmv 6/22/2019 15:00:02'! - base: aNumber selector: aSymbol argument: otherNumber - base _ aNumber. - selector _ aSymbol. - argument _ otherNumber ! ! -!NegativePowerError methodsFor: 'initialization' stamp: 'jmv 6/22/2019 15:01:03'! - signalBase: aNumber selector: aSymbol argument: otherNumber - ^self - base: aNumber selector: aSymbol argument: otherNumber; - signal! ! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 6/22/2019 15:01:22' prior: 50460923! - raisedTo: exponent - "Answer the receiver raised to aNumber." - - exponent isInteger ifTrue: [ - "Do the special case of integer power" - ^ self raisedToInteger: exponent]. - exponent isFraction ifTrue: [ - "Special case for fraction power by Nicolas Cellier: - If aNumber is a fraction, but result must be a Float, learn it as quickly as possible, and give quick Float answer - Allows evaluating: - (2009/2000) raisedTo: (3958333/100000) - " - ^ self raisedToFraction: exponent]. - self < 0 ifTrue: [ - ^NegativePowerError new signalBase: self selector: #raisedTo: argument: exponent]. - 0 = exponent ifTrue: [^ self class one]. "Special case of exponent=0" - 1 = exponent ifTrue: [^ self]. "Special case of exponent=1" - 0 = self ifTrue: [ "Special case of self = 0" - exponent < 0 - ifTrue: [^ (ZeroDivide dividend: self) signal] - ifFalse: [^ self]]. - ^ (exponent * self ln) exp "Otherwise use logarithms"! ! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 6/22/2019 15:04:09' prior: 50460954! - raisedToFraction: aFraction - self isZero ifTrue: [ - aFraction negative ifTrue: [ - ^ (ZeroDivide dividend: 1) signal ]. - ^ self ]. - self negative ifFalse: [ - ^ (self ln * aFraction) exp ]. - aFraction denominator = 2 ifTrue: [ - ^ self sqrt raisedToInteger: aFraction numerator ]. - (self negative and: [ aFraction denominator even ]) ifTrue: [ - ^NegativePowerError new signalBase: self selector: #raisedToFraction: argument: aFraction]. - ^ (self negated ln * aFraction) exp negated! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 6/22/2019 15:05:38' prior: 50400471! - nthRoot: aPositiveInteger - "Answer the nth root of the receiver." - aPositiveInteger = 2 ifTrue: [ - ^self sqrt ]. - - (aPositiveInteger isInteger not or: [ aPositiveInteger negative ]) - ifTrue: [^ ArithmeticError signal: 'nth root only defined for positive Integer n.']. - - ^self negative - ifTrue: [ - aPositiveInteger even - ifTrue: [ NegativePowerError new signalBase: self selector: #nthRoot: argument: aPositiveInteger ] - ifFalse: [ (self negated nthRoot: aPositiveInteger) negated ]] - ifFalse: [ self raisedTo: 1.0 / aPositiveInteger ]! ! -!Fraction methodsFor: 'mathematical functions' stamp: 'jmv 6/22/2019 15:06:05' prior: 50400491! - nthRoot: aPositiveInteger - "Answer the nth root of the receiver." - | guess | - aPositiveInteger = 2 ifTrue: [ - ^ self sqrt ]. - - (aPositiveInteger isInteger not or: [ aPositiveInteger negative ]) - ifTrue: [^ ArithmeticError signal: 'nth root only defined for positive Integer n.']. - - (self negative and: [ aPositiveInteger even ]) ifTrue: [ - ^ NegativePowerError new signalBase: self selector: #nthRoot: argument: aPositiveInteger ]. - - guess _ (numerator nthRootTruncated: aPositiveInteger) / - (denominator nthRootTruncated: aPositiveInteger). - (guess raisedTo: aPositiveInteger) = self ifTrue: [ - ^ guess ]. - "There is no exact nth root, so answer a Float approximation" - ^ (self abs ln / aPositiveInteger) exp * self sign! ! -!Fraction methodsFor: 'mathematical functions' stamp: 'jmv 6/22/2019 15:03:56' prior: 50400617! - raisedToFraction: aFraction - | root | - aFraction denominator = 2 ifTrue: [ - ^ self sqrt raisedToInteger: aFraction numerator ]. - (self negative and: [ aFraction denominator even ]) ifTrue: [ - ^NegativePowerError new signalBase: self selector: #raisedToFraction: argument: aFraction]. - root _ (self numerator nthRootTruncated: aFraction denominator) / - (self denominator nthRootTruncated: aFraction denominator). - (root raisedToInteger: aFraction denominator) = self ifTrue: [ - ^ root raisedToInteger: aFraction numerator ]. - ^ super raisedToFraction: aFraction! ! -!Integer methodsFor: 'mathematical functions' stamp: 'jmv 6/22/2019 15:06:14' prior: 50400517! - nthRoot: aPositiveInteger - "Answer the nth root of the receiver. - Answer an Integer if root is exactly this Integer, else answer the Float nearest the exact root." - - | guess excess scaled nBits | - self = 0 ifTrue: [ ^0 ]. - - aPositiveInteger = 2 ifTrue: [ - ^ self sqrt ]. - - (aPositiveInteger isInteger not or: [ aPositiveInteger negative ]) - ifTrue: [^ ArithmeticError signal: 'nth root only defined for positive Integer n.']. - - (self negative and: [ aPositiveInteger even ]) ifTrue: [ - ^ NegativePowerError new signalBase: self selector: #nthRoot: argument: aPositiveInteger ]. - - guess _ self nthRootRounded: aPositiveInteger. - excess _ (guess raisedTo: aPositiveInteger) - self. - excess = 0 ifTrue: [ ^ guess ]. - - nBits _ Float precision - guess highBitOfMagnitude. - nBits <= 0 ifTrue: [ ^(Fraction numerator: guess * 4 - excess sign denominator: 4) asFloat]. - - scaled _ self << (nBits * aPositiveInteger). - guess _ scaled nthRootRounded: aPositiveInteger. - excess _ (guess raisedTo: aPositiveInteger) - scaled. - ^(Fraction numerator: guess * 4 - excess sign denominator: 1 << (nBits + 2)) asFloat! ! -!Integer methodsFor: 'mathematical functions' stamp: 'jmv 6/22/2019 15:04:35' prior: 50400638! - raisedToFraction: aFraction - | root | - self = 0 ifTrue: [ ^0 ]. - aFraction denominator = 2 ifTrue: [ - ^ self sqrt raisedToInteger: aFraction numerator ]. - (self negative and: [ aFraction denominator even ]) ifTrue: [ - ^NegativePowerError new signalBase: self selector: #raisedToFraction: argument: aFraction]. - root _ self nthRootTruncated: aFraction denominator. - (root raisedToInteger: aFraction denominator) = self ifTrue: [ - ^ root raisedToInteger: aFraction numerator ]. - ^ super raisedToFraction: aFraction! ! - -Number removeSelector: #asComplex! - -Number removeSelector: #asComplex! - -Number removeSelector: #i! - -Number removeSelector: #i! - -Smalltalk removeClassNamed: #Complex! - -Smalltalk removeClassNamed: #Complex! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3807-LoadableComplex-AndresValloud-JuanVuletich-2019Jun22-15h21m-sqr.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3805] on 22 June 2019 at 3:27:28 pm'! -!Float64Array methodsFor: 'arithmetic' stamp: 'jmv 6/22/2019 14:40:41' prior: 50404485! - /= anObject - - ^self divideBy: anObject - ifDivisorZero: [ZeroDivide signalWithDividend: self] - ifBothZero: [ZeroDivide signalWithDividend: self]! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'jmv 6/22/2019 14:40:49' prior: 50404493! - /= anObject - - ^self divideBy: anObject - ifDivisorZero: [ZeroDivide signalWithDividend: self] - ifBothZero: [ZeroDivide signalWithDividend: self]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3808-Cleanup-AndresValloud-JuanVuletich-2019Jun22-15h26m-sqr.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3808] on 22 June 2019 at 3:36:06 pm'! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 6/22/2019 15:34:46' prior: 50420539! - sqrtNonPrimitive - "Answer the square root of the receiver. " - | exp guess delta | - - self = 0.0 ifTrue: [ - ^self ]. "Answer 0.0 for 0.0, but -0.0 for -0.0. See IEEE 754 standard" - - self <= 0.0 - ifTrue: [ - ^NegativePowerError new signalBase: self selector: #raisedTo: argument: 1/2 ]. - - "NaN and Infinity" - self isFinite ifFalse: [ - ^ self ]. - - "Newton-Raphson" - "first guess is half the exponent" - exp _ self exponent // 2. - guess _ self timesTwoPower: 0 - exp. - [ - delta _ self - (guess * guess) / (guess * 2.0). - delta abs >= guess ulp ] - whileTrue: [ - guess _ guess + delta ]. - ^ guess! ! -!LargeNegativeInteger methodsFor: 'mathematical functions' stamp: 'jmv 6/22/2019 15:32:24' prior: 50400425! - sqrt - "Answer the square root of the receiver." - ^NegativePowerError new signalBase: self selector: #raisedTo: argument: 1/2! ! -!SmallInteger methodsFor: 'mathematical functions' stamp: 'jmv 6/22/2019 15:32:02' prior: 50400431! - sqrt - - self positive ifTrue: [^super sqrt]. - ^NegativePowerError new signalBase: self selector: #raisedTo: argument: 1/2! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3809-LoadableComplex-p2-AndresValloud-JuanVuletich-2019Jun22-15h30m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3809] on 23 June 2019 at 5:17:18 pm'! -!JPEGReadWriter2 methodsFor: 'public access' stamp: 'jmv 6/23/2019 17:16:57' prior: 16861429! - compress: aForm quality: quality progressiveJPEG: progressiveFlag usingBuffer: aByteArrayOrNil into: aBlock - "Encode the given Form with the given settings. Quality goes from 0 (low) to 100 (high), where -1 means default. If progressiveFlag is true, encode as a progressive JPEG. - - Evaluate aBlock with two arguments. The first is a ByteArray with the data. Usually bigger than needed. - The second argument is the actual maningful bytes. - - We can only compress: - * 32-bit deep Forms - * -32-bit deep Forms - * 16-bit deep Forms - * -16-bit deep Forms - * 8-bit deep GrayForms - * -8-bit deep GrayForms" - - | sourceForm jpegCompressStruct jpegErrorMgr2Struct buffer byteCount | - self supportsGrayForms - ifTrue: [ - "Newer plugin supports 32bpp, 16bpp, GrayForms" - sourceForm _ (aForm depth = 32) | (aForm depth = 16) | (aForm is: #GrayForm) - ifTrue: [aForm] - ifFalse: [aForm asFormOfDepth: 16]] - ifFalse: [ - "Original plugin supports 32bpp and even width big endian 16bpp" - sourceForm _ (aForm depth = 32) | (aForm width even & (aForm nativeDepth = 16)) - ifTrue: [aForm] - ifFalse: [aForm asFormOfDepth: 32]]. - - jpegCompressStruct _ ByteArray new: self primJPEGCompressStructSize. - jpegErrorMgr2Struct _ ByteArray new: self primJPEGErrorMgr2StructSize. - "Most likely more than needed" - buffer _ aByteArrayOrNil ifNil: [ByteArray new: sourceForm width * sourceForm height // 2+1024]. - [ - byteCount _ self jpegWriteImage: jpegCompressStruct - onByteArray: buffer - form: sourceForm - quality: quality - progressiveJPEG: progressiveFlag - errorMgr: jpegErrorMgr2Struct. - byteCount = 0 ] whileTrue: [ - "But if not, ask for some more" - buffer _ ByteArray new: buffer size * 14 // 10 ]. - - aBlock value: buffer value: byteCount! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3810-JPEG-fix-JuanVuletich-2019Jun23-17h15m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3810] on 25 June 2019 at 6:48:07 pm'! - -Error subclass: #ArithmeticMessageError - instanceVariableNames: 'receiver selector arguments' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #ArithmeticMessageError category: #'Exceptions Kernel'! -Error subclass: #ArithmeticMessageError - instanceVariableNames: 'receiver selector arguments' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -ArithmeticMessageError subclass: #NegativePowerError - instanceVariableNames: 'base argument ' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #NegativePowerError category: #'Exceptions Kernel'! -ArithmeticMessageError subclass: #NegativePowerError - instanceVariableNames: 'base argument' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -ArithmeticMessageError subclass: #ZeroDivide - instanceVariableNames: 'dividend ' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #ZeroDivide category: #'Exceptions Kernel'! -ArithmeticMessageError subclass: #ZeroDivide - instanceVariableNames: 'dividend' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! -!ZeroDivide commentStamp: '' prior: 50454459! - ZeroDivide may be signaled when a mathematical division by 0 is attempted.! -!ArithmeticMessageError methodsFor: 'initialization' stamp: 'jmv 6/25/2019 18:26:00'! - receiver: aNumber selector: aSymbol argument: otherNumber - self receiver: aNumber selector: aSymbol arguments: {otherNumber}! ! -!ArithmeticMessageError methodsFor: 'initialization' stamp: 'jmv 6/25/2019 18:26:00'! - receiver: aNumber selector: aSymbol arguments: aCollection - receiver _ aNumber. - selector _ aSymbol. - arguments _ aCollection! ! -!ArithmeticMessageError methodsFor: 'exceptionDescription' stamp: 'jmv 6/25/2019 18:26:00'! - defaultAction - (receiver isFloat or: [ arguments anySatisfy: [ :a | a isFloat ]]) ifTrue: [ - ^self floatErrorValue ]. - ^ super defaultAction! ! -!ArithmeticMessageError methodsFor: 'signaling' stamp: 'jmv 6/25/2019 18:26:00'! - floatErrorValue - ^ self subclassResponsibility! ! -!ArithmeticMessageError methodsFor: 'signaling' stamp: 'jmv 6/25/2019 18:26:00'! - signalReceiver: aNumber selector: aSymbol argument: otherNumber - - ^self - receiver: aNumber selector: aSymbol argument: otherNumber; - signal! ! -!ArithmeticMessageError methodsFor: 'signaling' stamp: 'jmv 6/25/2019 18:26:00'! - signalReceiver: aNumber selector: aSymbol arguments: aCollection - - ^self - receiver: aNumber selector: aSymbol arguments: aCollection; - signal! ! -!NegativePowerError methodsFor: 'signaling' stamp: 'jmv 6/25/2019 18:41:08'! -floatErrorValue - ^ Float nan! ! -!ZeroDivide methodsFor: 'signaling' stamp: 'jmv 6/25/2019 18:47:06'! - floatErrorValue - receiver isZero ifTrue: [ ^ Float nan ]. - ^ (receiver * arguments first) sign = -1 - ifTrue: [ Float negativeInfinity ] - ifFalse: [ Float infinity ]! ! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:06:04' prior: 50464663! - raisedTo: exponent - "Answer the receiver raised to aNumber." - - exponent isInteger ifTrue: [ - "Do the special case of integer power" - ^ self raisedToInteger: exponent]. - exponent isFraction ifTrue: [ - "Special case for fraction power by Nicolas Cellier: - If aNumber is a fraction, but result must be a Float, learn it as quickly as possible, and give quick Float answer - Allows evaluating: - (2009/2000) raisedTo: (3958333/100000) - " - ^ self raisedToFraction: exponent]. - self < 0 ifTrue: [ - ^NegativePowerError new signalReceiver: self selector: #raisedTo: argument: exponent]. - 0 = exponent ifTrue: [^ self class one]. "Special case of exponent=0" - 1 = exponent ifTrue: [^ self]. "Special case of exponent=1" - 0 = self ifTrue: [ "Special case of self = 0" - exponent < 0 - ifTrue: [^ ZeroDivide new signalReceiver: self selector: #raisedTo: argument: exponent] - ifFalse: [^ self]]. - ^ (exponent * self ln) exp "Otherwise use logarithms"! ! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:06:12' prior: 50464695! - raisedToFraction: aFraction - self isZero ifTrue: [ - aFraction negative ifTrue: [ - ^ZeroDivide new signalReceiver: self selector: #raisedToFraction: argument: aFraction]. - ^ self ]. - self negative ifFalse: [ - ^ (self ln * aFraction) exp ]. - aFraction denominator = 2 ifTrue: [ - ^ self sqrt raisedToInteger: aFraction numerator ]. - (self negative and: [ aFraction denominator even ]) ifTrue: [ - ^NegativePowerError new signalReceiver: self selector: #raisedToFraction: argument: aFraction]. - ^ (self negated ln * aFraction) exp negated! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:17:58' prior: 16844544! - arCosh - "Answer receiver's area hyperbolic cosine. - That is the inverse function of cosh." - - self < 1 - ifTrue: [^ Float nan]. - ^self + 1 = self - ifTrue: [self abs ln + 2 ln] - ifFalse: [((self squared - 1) sqrt + self) ln]! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:18:29' prior: 16844567! - arTanh - "Answer receiver's area hyperbolic tangent. - That is the inverse function of tanh." - - self = 0.0 ifTrue: [^self]. "Handle negativeZero" - self abs = 1 ifTrue: [^self copySignTo: Float infinity]. - self abs > 1 ifTrue: [^ Float nan]. - ^((1 + self) / (1 - self)) ln / 2! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:18:55' prior: 16844584! - arcSin - "Answer the angle in radians." - - ((self < -1.0) or: [self > 1.0]) ifTrue: [^ Float nan]. - ^((self = -1.0) or: [self = 1.0]) - ifTrue: [Halfpi * self] - ifFalse: [(self / (1.0 - (self * self)) sqrt) arcTan]! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:19:05' prior: 50420484! - lnNonPrimitive - "Answer the natural logarithm of the receiver. - Optional. See Object documentation whatIsAPrimitive." - - | expt n mant x div pow delta sum | - - "Taylor series" - self <= 0.0 ifTrue: [^ Float nan]. - - "get a rough estimate from binary exponent" - expt := self exponent. - n := Ln2 * expt. - mant := self timesTwoPower: 0 - expt. - - "compute fine correction from mantinssa in Taylor series" - "mant is in the range [0..2]" - "we unroll the loop to avoid use of abs" - x := mant - 1.0. - div := 1.0. - pow := delta := sum := x. - x := x negated. "x <= 0" - [delta > (n + sum) ulp] whileTrue: [ - "pass one: delta is positive" - div := div + 1.0. - pow := pow * x. - delta := pow / div. - sum := sum + delta. - "pass two: delta is negative" - div := div + 1.0. - pow := pow * x. - delta := pow / div. - sum := sum + delta]. - - ^ n + sum - - "Float e ln 1.0"! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:07:09' prior: 50464714! - nthRoot: aPositiveInteger - "Answer the nth root of the receiver." - aPositiveInteger = 2 ifTrue: [ - ^self sqrt ]. - - (aPositiveInteger isInteger not or: [ aPositiveInteger negative ]) - ifTrue: [^ DomainError signal: 'nth root only defined for positive Integer n.']. - - ^self negative - ifTrue: [ - aPositiveInteger even - ifTrue: [ NegativePowerError new signalReceiver: self selector: #nthRoot: argument: aPositiveInteger ] - ifFalse: [ (self negated nthRoot: aPositiveInteger) negated ]] - ifFalse: [ self raisedTo: 1.0 / aPositiveInteger ]! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:04:46' prior: 50464879! - sqrtNonPrimitive - "Answer the square root of the receiver. " - | exp guess delta | - - self = 0.0 ifTrue: [ - ^self ]. "Answer 0.0 for 0.0, but -0.0 for -0.0. See IEEE 754 standard" - - self <= 0.0 - ifTrue: [ - ^NegativePowerError new signalReceiver: self selector: #sqrtNonPrimitive arguments: {} ]. - - "NaN and Infinity" - self isFinite ifFalse: [ - ^ self ]. - - "Newton-Raphson" - "first guess is half the exponent" - exp _ self exponent // 2. - guess _ self timesTwoPower: 0 - exp. - [ - delta _ self - (guess * guess) / (guess * 2.0). - delta abs >= guess ulp ] - whileTrue: [ - guess _ guess + delta ]. - ^ guess! ! -!BoxedFloat64 methodsFor: 'arithmetic' stamp: 'jmv 6/25/2019 17:44:27' prior: 16790493! - / aNumber - "Primitive. Answer the result of dividing receiver by aNumber. - Fail if the argument is not a Float. - Essential. See Object clas >> whatIsAPrimitive." - - - aNumber isZero ifTrue: [^ ZeroDivide new signalReceiver: self selector: #/ argument: aNumber]. - ^ aNumber adaptToFloat: self andSend: #/! ! -!SmallFloat64 methodsFor: 'arithmetic' stamp: 'jmv 6/25/2019 18:01:31' prior: 16908219! - / aNumber - "Primitive. Answer the result of dividing receiver by aNumber. - Fail if the argument is not a Float. - Essential. See Object clas >> whatIsAPrimitive." - - - aNumber isZero ifTrue: [^ZeroDivide new signalReceiver: self selector: #/ argument: aNumber ]. - ^ aNumber adaptToFloat: self andSend: #/! ! -!Fraction methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:21:44' prior: 16849641! - ln - "This function is defined because super ln might overflow." - | res | - self <= 0 ifTrue: [^DomainError signal: 'ln is only defined for x > 0']. - "Test self < 1 before converting to float in order to avoid precision loss due to gradual underflow." - numerator < denominator ifTrue: [^self reciprocal ln negated]. - res := super ln. - res isFinite ifTrue: [^res]. - ^numerator ln - denominator ln! ! -!Fraction methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:21:48' prior: 16849656! - log - " - (1/(10 raisedTo: 215)) log - (1/((10 raisedTo: 215)+(10 raisedTo: 213))) log - " - | res | - self <= 0 ifTrue: [^DomainError signal: 'log is only defined for x > 0']. - - "Integer answer if possible!!" - numerator = 1 - ifTrue: [ ^denominator log negated ]. - - "This because super log might overflow." - "Test self < 1 before converting to float in order to avoid precision loss due to gradual underflow." - numerator < denominator ifTrue: [ ^self reciprocal log negated ]. - res := super log. - res isFinite ifTrue: [^res]. - ^numerator log - denominator log! ! -!Fraction methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:07:13' prior: 50464735! - nthRoot: aPositiveInteger - "Answer the nth root of the receiver." - | guess | - aPositiveInteger = 2 ifTrue: [ - ^ self sqrt ]. - - (aPositiveInteger isInteger not or: [ aPositiveInteger negative ]) - ifTrue: [^ DomainError signal: 'nth root only defined for positive Integer n.']. - - (self negative and: [ aPositiveInteger even ]) ifTrue: [ - ^ NegativePowerError new signalReceiver: self selector: #nthRoot: argument: aPositiveInteger ]. - - guess _ (numerator nthRootTruncated: aPositiveInteger) / - (denominator nthRootTruncated: aPositiveInteger). - (guess raisedTo: aPositiveInteger) = self ifTrue: [ - ^ guess ]. - "There is no exact nth root, so answer a Float approximation" - ^ (self abs ln / aPositiveInteger) exp * self sign! ! -!Fraction methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:05:14' prior: 50464761! - raisedToFraction: aFraction - | root | - aFraction denominator = 2 ifTrue: [ - ^ self sqrt raisedToInteger: aFraction numerator ]. - (self negative and: [ aFraction denominator even ]) ifTrue: [ - ^NegativePowerError new signalReceiver: self selector: #raisedToFraction: argument: aFraction]. - root _ (self numerator nthRootTruncated: aFraction denominator) / - (self denominator nthRootTruncated: aFraction denominator). - (root raisedToInteger: aFraction denominator) = self ifTrue: [ - ^ root raisedToInteger: aFraction numerator ]. - ^ super raisedToFraction: aFraction! ! -!Fraction methodsFor: 'private' stamp: 'jmv 6/25/2019 17:57:12' prior: 16849897! - setNumerator: n denominator: d - - d = 0 - ifTrue: [^ZeroDivide new signalReceiver: self selector: #setNumerator:denominator: arguments: {n.d}] - ifFalse: [ - numerator _ n asInteger. - denominator _ d asInteger abs. "keep sign in numerator" - d < 0 ifTrue: [numerator _ numerator negated]]! ! -!Integer methodsFor: 'arithmetic' stamp: 'jmv 6/25/2019 17:47:55' prior: 16858901! - // aNumber - | q | - aNumber = 0 ifTrue: [^ ZeroDivide new signalReceiver: self selector: #// argument: aNumber]. - self = 0 ifTrue: [^ 0]. - q _ self quo: aNumber. - "Refer to the comment in Number>>#//." - ^(q negative - ifTrue: [q * aNumber ~= self] - ifFalse: [q = 0 and: [self negative ~= aNumber negative]]) - ifTrue: [q - 1"Truncate towards minus infinity."] - ifFalse: [q]! ! -!Integer methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:21:59' prior: 16859597! - ln - "This function is defined because super ln might overflow." - | res h | - self <= 0 ifTrue: [^DomainError signal: 'ln is only defined for x > 0']. - res := super ln. - res isFinite ifTrue: [^res]. - h := self highBit. - ^2 ln * h + (self / (1 << h)) asFloat ln! ! -!Integer methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:22:05' prior: 16859608! - log - "This function is defined because super log might overflow. - (10 raisedTo: 215) log - ((10 raisedTo: 215)+(10 raisedTo: 213)) log - Answers an integer number if appropriate. Doing this is somewhat expensive. If you care about performance and not about using Floats, do 'aNumber asFloat log: another'. - " - | floatAnswer roundedAnswer | - self <= 0 ifTrue: [^DomainError signal: 'log is only defined for x > 0']. - floatAnswer _ self floatLog. - roundedAnswer _ floatAnswer rounded. - (10 raisedToInteger: roundedAnswer) = self - ifTrue: [ ^roundedAnswer ]. - ^floatAnswer! ! -!Integer methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:22:11' prior: 16859640! - log: aNumber - "Answer the log base aNumber of the receiver. - (3 raisedTo: 215) log: 3 - ((3 raisedTo: 215)+(3 raisedTo: 213)) log: 3 - Answers an integer number if appropriate. Doing this is somewhat expensive. If you care about performance and not about using Floats, do 'aNumber asFloat log: another'. - " - | floatAnswer roundedAnswer | - self <= 0 ifTrue: [^DomainError signal: 'log is only defined for x > 0']. - floatAnswer _ self asFloat log: aNumber. - roundedAnswer _ floatAnswer rounded. - (aNumber raisedToInteger: roundedAnswer) = self - ifTrue: [ ^roundedAnswer ]. - ^floatAnswer! ! -!Integer methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:07:17' prior: 50464782! - nthRoot: aPositiveInteger - "Answer the nth root of the receiver. - Answer an Integer if root is exactly this Integer, else answer the Float nearest the exact root." - - | guess excess scaled nBits | - self = 0 ifTrue: [ ^0 ]. - - aPositiveInteger = 2 ifTrue: [ - ^ self sqrt ]. - - (aPositiveInteger isInteger not or: [ aPositiveInteger negative ]) - ifTrue: [^ DomainError signal: 'nth root only defined for positive Integer n.']. - - (self negative and: [ aPositiveInteger even ]) ifTrue: [ - ^ NegativePowerError new signalReceiver: self selector: #nthRoot: argument: aPositiveInteger ]. - - guess _ self nthRootRounded: aPositiveInteger. - excess _ (guess raisedTo: aPositiveInteger) - self. - excess = 0 ifTrue: [ ^ guess ]. - - nBits _ Float precision - guess highBitOfMagnitude. - nBits <= 0 ifTrue: [ ^(Fraction numerator: guess * 4 - excess sign denominator: 4) asFloat]. - - scaled _ self << (nBits * aPositiveInteger). - guess _ scaled nthRootRounded: aPositiveInteger. - excess _ (guess raisedTo: aPositiveInteger) - scaled. - ^(Fraction numerator: guess * 4 - excess sign denominator: 1 << (nBits + 2)) asFloat! ! -!Integer methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:07:44' prior: 16859690! - nthRootRounded: aPositiveInteger - "Answer the integer nearest the nth root of the receiver. -http://stackoverflow.com/questions/39794338/precise-nth-root - -http://smallissimo.blogspot.com.ar/2011/09/clarifying-and-optimizing.html -Ojo 32/64!! - -Tambien -http://smallissimo.blogspot.com.ar/2011/09/reviewing-fraction-asfloat.html -" - | guess | - self = 0 ifTrue: [^0]. - self negative - ifTrue: [ - aPositiveInteger even ifTrue: [ ^DomainError signal: 'Negative numbers don''t have even roots.' ]. - ^(self negated nthRootRounded: aPositiveInteger) negated]. - guess := self nthRootTruncated: aPositiveInteger. - ^self * 2 > ((guess + 1 raisedTo: aPositiveInteger) + (guess raisedTo: aPositiveInteger)) - ifTrue: [guess + 1] - ifFalse: [guess]! ! -!Integer methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:08:30' prior: 16859718! - nthRootTruncated: aPositiveInteger - "Answer the integer part of the nth root of the receiver." - | guess guessToTheNthMinusOne nextGuess | - self = 0 ifTrue: [^0]. - self negative - ifTrue: [ - aPositiveInteger even ifTrue: [ ^DomainError signal: 'Negative numbers don''t have even roots.' ]. - ^(self negated nthRootTruncated: aPositiveInteger) negated]. - guess := 1 bitShift: self highBitOfMagnitude + aPositiveInteger - 1 // aPositiveInteger. - [ - guessToTheNthMinusOne := guess raisedTo: aPositiveInteger - 1. - nextGuess := (aPositiveInteger - 1 * guess * guessToTheNthMinusOne + self) // (guessToTheNthMinusOne * aPositiveInteger). - nextGuess >= guess ] whileFalse: - [ guess := nextGuess ]. - ( guess raisedTo: aPositiveInteger) > self ifTrue: - [ guess := guess - 1 ]. - ^guess! ! -!Integer methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:05:31' prior: 50464821! - raisedToFraction: aFraction - | root | - self = 0 ifTrue: [ ^0 ]. - aFraction denominator = 2 ifTrue: [ - ^ self sqrt raisedToInteger: aFraction numerator ]. - (self negative and: [ aFraction denominator even ]) ifTrue: [ - ^NegativePowerError new signalReceiver: self selector: #raisedToFraction: argument: aFraction]. - root _ self nthRootTruncated: aFraction denominator. - (root raisedToInteger: aFraction denominator) = self ifTrue: [ - ^ root raisedToInteger: aFraction numerator ]. - ^ super raisedToFraction: aFraction! ! -!Integer methodsFor: 'private' stamp: 'jmv 6/25/2019 17:58:27' prior: 16860338! - digitDiv: arg neg: ng - "Answer with an array of (quotient, remainder)." - | quo rem ql d div dh dnh dl qhi qlo j l hi lo r3 a t | - - arg = 0 ifTrue: [^ ZeroDivide new signalReceiver: self selector: #digitDiv:neg: arguments: {arg.ng}]. - "TFEI added this line" - l _ self digitLength - arg digitLength + 1. - l <= 0 ifTrue: [^ Array with: 0 with: self]. - "shortcut against #highBit" - d _ 8 - arg lastDigit highBitOfMagnitude. - div _ arg digitLshift: d. - div _ div growto: div digitLength + 1. - "shifts so high order word is >=128" - rem _ self digitLshift: d. - rem digitLength = self digitLength ifTrue: [rem _ rem growto: self digitLength + 1]. - "makes a copy and shifts" - quo _ Integer new: l neg: ng. - dl _ div digitLength - 1. - "Last actual byte of data" - ql _ l. - dh _ div digitAt: dl. - dnh _ dl = 1 - ifTrue: [0] - ifFalse: [div digitAt: dl - 1]. - 1 to: ql do: - [:k | - "maintain quo*arg+rem=self" - "Estimate rem/div by dividing the leading to bytes of rem by dh." - "The estimate is q = qhi*16+qlo, where qhi and qlo are nibbles." - j _ rem digitLength + 1 - k. - "r1 _ rem digitAt: j." - (rem digitAt: j) - = dh - ifTrue: [qhi _ qlo _ 15 - "i.e. q=255"] - ifFalse: - ["Compute q = (r1,r2)//dh, t = (r1,r2)\\dh. - Note that r1,r2 are bytes, not nibbles. - Be careful not to generate intermediate results exceeding 13 - bits." - "r2 _ (rem digitAt: j - 1)." - t _ ((rem digitAt: j) - bitShift: 4) - + ((rem digitAt: j - 1) - bitShift: -4). - qhi _ t // dh. - t _ (t \\ dh bitShift: 4) - + ((rem digitAt: j - 1) - bitAnd: 15). - qlo _ t // dh. - t _ t \\ dh. - "Next compute (hi,lo) _ q*dnh" - hi _ qhi * dnh. - lo _ qlo * dnh + ((hi bitAnd: 15) - bitShift: 4). - hi _ (hi bitShift: -4) - + (lo bitShift: -8). - lo _ lo bitAnd: 255. - "Correct overestimate of q. - Max of 2 iterations through loop -- see Knuth vol. 2" - r3 _ j < 3 - ifTrue: [0] - ifFalse: [rem digitAt: j - 2]. - [(t < hi - or: [t = hi and: [r3 < lo]]) - and: - ["i.e. (t,r3) < (hi,lo)" - qlo _ qlo - 1. - lo _ lo - dnh. - lo < 0 - ifTrue: - [hi _ hi - 1. - lo _ lo + 256]. - hi >= dh]] - whileTrue: [hi _ hi - dh]. - qlo < 0 - ifTrue: - [qhi _ qhi - 1. - qlo _ qlo + 16]]. - "Subtract q*div from rem" - l _ j - dl. - a _ 0. - 1 to: div digitLength do: - [:i | - hi _ (div digitAt: i) - * qhi. - lo _ a + (rem digitAt: l) - ((hi bitAnd: 15) - bitShift: 4) - ((div digitAt: i) - * qlo). - rem digitAt: l put: lo - (lo // 256 * 256). - "sign-tolerant form of (lo bitAnd: 255)" - a _ lo // 256 - (hi bitShift: -4). - l _ l + 1]. - a < 0 - ifTrue: - ["Add div back into rem, decrease q by 1" - qlo _ qlo - 1. - l _ j - dl. - a _ 0. - 1 to: div digitLength do: - [:i | - a _ (a bitShift: -8) - + (rem digitAt: l) + (div digitAt: i). - rem digitAt: l put: (a bitAnd: 255). - l _ l + 1]]. - quo digitAt: quo digitLength + 1 - k put: (qhi bitShift: 4) - + qlo]. - rem _ rem - digitRshift: d - bytes: 0 - lookfirst: dl. - ^ Array with: quo with: rem! ! -!LargeNegativeInteger methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:05:55' prior: 50464902! - sqrt - "Answer the square root of the receiver." - ^NegativePowerError new signalReceiver: self selector: #sqrt arguments: {}! ! -!SmallInteger methodsFor: 'arithmetic' stamp: 'jmv 6/25/2019 18:01:37' prior: 16908637! - / aNumber - "Primitive. This primitive (for /) divides the receiver by the argument - and returns the result if the division is exact. Fail if the result is not a - whole integer. Fail if the argument is 0 or is not a SmallInteger. Optional. - No Lookup. See Object documentation whatIsAPrimitive." - - - aNumber isZero ifTrue: [^ZeroDivide new signalReceiver: self selector: #/ argument: aNumber ]. - ^(aNumber isMemberOf: SmallInteger) - ifTrue: [(Fraction numerator: self denominator: aNumber) reduced] - ifFalse: [super / aNumber]! ! -!SmallInteger methodsFor: 'arithmetic' stamp: 'jmv 6/25/2019 18:01:48' prior: 16908691! - quo: aNumber - "Primitive. Divide the receiver by the argument and answer with the - result. Round the result down towards zero to make it a whole integer. - Fail if the argument is 0 or is not a SmallInteger. Optional. See Object - documentation whatIsAPrimitive." - - aNumber = 0 ifTrue: [^ZeroDivide new signalReceiver: self selector: #quo: argument: aNumber ]. - (aNumber isMemberOf: SmallInteger) - ifFalse: [^ super quo: aNumber]. - (aNumber = -1 and: [self = self class minVal]) - ifTrue: ["result is aLargeInteger" ^ self negated]. - self primitiveFailed! ! -!SmallInteger methodsFor: 'mathematical functions' stamp: 'jmv 6/25/2019 18:06:25' prior: 50464910! - sqrt - - self positive ifTrue: [^super sqrt]. - ^NegativePowerError new signalReceiver: self selector: #sqrt arguments: {}! ! -!Float64Array methodsFor: 'arithmetic' stamp: 'jmv 6/25/2019 17:43:40' prior: 50464855! - /= anObject - - ^self divideBy: anObject - ifDivisorZero: [ZeroDivide new signalReceiver: self selector: #/= argument: anObject] - ifBothZero: [ZeroDivide new signalReceiver: self selector: #/= argument: anObject]! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'jmv 6/25/2019 17:43:52' prior: 50464863! - /= anObject - - ^self divideBy: anObject - ifDivisorZero: [ZeroDivide new signalReceiver: self selector: #/= argument: anObject] - ifBothZero: [ZeroDivide new signalReceiver: self selector: #/= argument: anObject]! ! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jmv 6/25/2019 18:09:04' prior: 16921076! - maxExternalSemaphores: aSize - "Changes the size of table where external semaphores are registered. - The size can only grow, and will always be the next power of two larger than the parameter. - - Setting this at any time other than start-up can potentially lose requests. - i.e. during the realloc new storage is allocated, t - he old contents are copied and then pointers are switched. - Requests occurring during copying won't be seen if they occur to indices already copied. - The intended use is to set the table to some adequate maximum at start-up" - - self isRunningCog ifFalse: [^0]. - "The vm-header field is a short, maximum 64k entries. Well, on most platforms anyways " - (aSize < 0 or: [aSize > 16rFFFF]) ifTrue: [^Error signal: 'Must be in the range (0 to: 16rFFFF)']. - ^self vmParameterAt: 49 put: aSize! ! - -ZeroDivide class removeSelector: #dividend:! - -ZeroDivide class removeSelector: #dividend:! - -ZeroDivide class removeSelector: #signalWithDividend:! - -ZeroDivide class removeSelector: #signalWithDividend:! - -ZeroDivide removeSelector: #dividend! - -ZeroDivide removeSelector: #dividend! - -ZeroDivide removeSelector: #dividend:! - -ZeroDivide removeSelector: #dividend:! - -NegativePowerError removeSelector: #base:selector:argument:! - -NegativePowerError removeSelector: #base:selector:argument:! - -NegativePowerError removeSelector: #signalBase:selector:argument:! - -NegativePowerError removeSelector: #signalBase:selector:argument:! - -ArithmeticMessageError subclass: #NegativePowerError - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #NegativePowerError category: #'Exceptions Kernel'! -ArithmeticMessageError subclass: #NegativePowerError - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -ArithmeticMessageError subclass: #ZeroDivide - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #ZeroDivide category: #'Exceptions Kernel'! -ArithmeticMessageError subclass: #ZeroDivide - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3811-DoAnswerFloatNan-JuanVuletich-2019Jun25-18h28m-jmv.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3811] on 26 June 2019 at 10:17:44 am'! -!BlockClosure methodsFor: 'testing' stamp: 'sqr 6/26/2019 09:59:10'! - hasNonLocalReturn - "Answer whether the receiver has a method-return ('^') in its code." - | myMethod scanner preceedingBytecodeMessage end | - "Determine end of block from the instruction preceding it. - Find the instruction by using an MNU handler to capture - the instruction message sent by the scanner." - myMethod := outerContext method. - scanner := InstructionStream new method: myMethod pc: myMethod initialPC. - [scanner pc < startpc] whileTrue: - [[scanner interpretNextInstructionFor: nil] - on: MessageNotUnderstood - do: [:ex| preceedingBytecodeMessage := ex message]]. - end := preceedingBytecodeMessage arguments last + startpc - 1. - scanner method: myMethod pc: startpc. - scanner scanFor: [:byte | (byte between: 120 and: 124) or: [scanner pc > end]]. - ^scanner pc <= end! ! -!MethodContext methodsFor: 'accessing' stamp: 'sqr 6/26/2019 09:58:58'! - hasNonLocalReturn - ^closureOrNil hasNonLocalReturn! ! -!ContextPart methodsFor: 'system simulation' stamp: 'sqr 6/26/2019 09:59:16' prior: 16824643! - runSimulated: aBlock contextAtEachStep: block2 - "Simulate the execution of the argument, aBlock, until it ends. aBlock - MUST NOT contain an '^'. Evaluate block2 with the current context - prior to each instruction executed. Answer the simulated value of aBlock." - | current | - aBlock hasNonLocalReturn - ifTrue: [self error: 'simulation of blocks with ^ can run loose']. - current := aBlock asContext. - current pushArgs: Array new from: self. - [current == self] - whileFalse: - [block2 value: current. - current := current step]. - ^self pop! ! - -MethodContext removeSelector: #hasMethodReturn! - -MethodContext removeSelector: #hasMethodReturn! - -BlockClosure removeSelector: #hasMethodReturn! - -BlockClosure removeSelector: #hasMethodReturn! - -BlockClosure removeSelector: #valueUninterruptably! - -BlockClosure removeSelector: #valueUninterruptably! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3812-BlockClosureCleanup-AndresValloud-2019Jun26-09h47m-sqr.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3795] on 28 June 2019 at 10:45:24 am'! -!Integer methodsFor: 'mathematical functions' stamp: 'len 6/17/2019 04:28:05' prior: 16859591! - lcm: anInteger - "Answer the least common multiple of the receiver and anInteger. - This is the smallest non-negative integer divisible by the receiver and the argument. - If either the receiver or the argument is zero, the result is zero." - - (self = 0 or: [anInteger = 0]) ifTrue: [^ 0]. - ^self abs // (self gcd: anInteger) * anInteger abs! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3813-lcmFix-LucianoNotarfrancesco-2019Jun27-18h17m-sqr.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3725] on 5 May 2019 at 11:45:31 pm'! - -"Change Set: 3726-CuisCore-AuthorName-2019May05-23h41m -Date: 5 May 2019 -Author: Nahuel Garbezza - -When installing new updates, handle (ignore) files that are not updates"! -!ChangeSet class methodsFor: 'services' stamp: 'RNG 5/5/2019 23:44:16'! - isNewUpdate: aFile - - ^ aFile name first isDigit and: [ aFile name asNumber > SystemVersion current highestUpdate ]! ! -!ChangeSet class methodsFor: 'services' stamp: 'RNG 5/5/2019 23:41:26' prior: 16799320! - newUpdates: updatesFileDirectory - - ^ (updatesFileDirectory files select: [ :each | self isNewUpdate: each ]) - asSortedCollection: [ :a :b | a name < b name ]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3814-DontFailOnExtraFilesInUpdates-NahuelGarbezza-2019May05-23h41m-RNG.1.cs.st----! - -'From Cuis 5.0 [latest update: #3814] on 1 July 2019 at 8:26:12 am'! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'jmv 7/1/2019 08:24:52' prior: 50432667! - timeStamp: aStream - "Writes system version and current time on stream aStream." - - | dateTime | - dateTime _ DateAndTime now. - aStream - nextPutAll: 'From '; - nextPutAll: Smalltalk version; - nextPutAll: ' ['; - nextPutAll: Smalltalk lastUpdateString; - nextPutAll: '] on '. - dateTime date printOn: aStream. - aStream - nextPutAll: ' at '. - dateTime time print24: false showSeconds: true on: aStream! ! -!SystemVersion methodsFor: 'printing' stamp: 'jmv 7/1/2019 08:25:27' prior: 16925852! - printOn: stream - stream - nextPutAll: self version; - nextPutAll: ' update ' , self highestUpdate printString! ! - -SystemVersion removeSelector: #datedVersion! - -SystemVersion removeSelector: #datedVersion! - -SystemDictionary removeSelector: #datedVersion! - -SystemDictionary removeSelector: #datedVersion! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3815-DontIncludeOriginalReleaseDateInStamps-JuanVuletich-2019Jul01-08h24m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3815] on 1 July 2019 at 4:37:34 pm'! -!TestCase methodsFor: 'assertions' stamp: 'jmv 7/1/2019 16:22:32'! - assert: aNumber isCloseTo: anotherNumber - - self assert: aNumber isCloseTo: anotherNumber withPrecision: self defaultPrecision ! ! -!TestCase methodsFor: 'assertions' stamp: 'jmv 7/1/2019 16:22:01'! - assert: aNumber isCloseTo: anotherNumber withPrecision: aPrecision - - self assert: (self is: aNumber closeTo: anotherNumber withPrecision: aPrecision)! ! -!TestCase methodsFor: 'assertions' stamp: 'jmv 7/1/2019 16:23:17'! - assert: aNumber isNotCloseTo: anotherNumber - - self assert: aNumber isNotCloseTo: anotherNumber withPrecision: self defaultPrecision ! ! -!TestCase methodsFor: 'assertions' stamp: 'jmv 7/1/2019 16:23:12'! - assert: aFloatNumber isNotCloseTo: anotherFloatNumber withPrecision: aPrecision - - self deny: (self is: aFloatNumber closeTo: anotherFloatNumber withPrecision: aPrecision) -! ! -!TestCase methodsFor: 'assertions' stamp: 'jmv 7/1/2019 16:37:25'! - is: aNumber closeTo: anotherNumber withPrecision: aPrecision - "This way of comparing numbers could be useful for many tests, but there is no single correct way to do it for numerical algorithms. That's why this method is here and not at Float." - - aNumber = 0 ifTrue: [ ^ anotherNumber abs < aPrecision ]. - - ^ (aNumber - anotherNumber) abs < (aPrecision * (aNumber abs max: anotherNumber abs))! ! - -TestCase removeSelector: #assert:isNearTo:! - -TestCase removeSelector: #assert:isNearTo:! - -TestCase removeSelector: #assert:isNearTo:withPrecision:! - -TestCase removeSelector: #assert:isNearTo:withPrecision:! - -TestCase removeSelector: #assert:isNotNearTo:! - -TestCase removeSelector: #assert:isNotNearTo:! - -TestCase removeSelector: #assert:isNotNearTo:withPrecision:! - -TestCase removeSelector: #assert:isNotNearTo:withPrecision:! - -TestCase removeSelector: #is:biggerThan:withPrecision:! - -TestCase removeSelector: #is:biggerThan:withPrecision:! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3816-BetterNamesForTestCaseNumberHelpers-JuanVuletich-2019Jul01-16h19m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3805] on 26 June 2019 at 9:02:51 am'! -!InnerTextMorph methodsFor: 'events' stamp: 'HAW 6/26/2019 09:02:18' prior: 50449308! - keyStroke: aKeyboardEvent - - (self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - - autoCompleter - ifNil: [ self processKeyStroke: aKeyboardEvent ] - ifNotNil: [ - autoCompleter - autoCompletionAround: [ self processKeyStroke: aKeyboardEvent ] - keyStroke: aKeyboardEvent ]. - - super keyStroke: aKeyboardEvent! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3817-keyStrokeDinamicHandlerOnInnerTextMorph-HernanWilkinson-2019Jun26-09h02m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3817] on 2 July 2019 at 11:34:51 am'! -!Object methodsFor: 'testing' stamp: 'jmv 7/2/2019 08:22:13'! - isFloatOrFloatComplex - "Overridden to return true in Float and Complex" - ^ false! ! -!Float methodsFor: 'testing' stamp: 'jmv 7/2/2019 08:22:25'! - isFloatOrFloatComplex - ^ true! ! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 7/2/2019 11:30:18' prior: 50465088! - raisedTo: exponent - "Answer the receiver raised to aNumber." - - exponent isInteger ifTrue: [ - "Do the special case of integer power" - ^ self raisedToInteger: exponent]. - exponent isFraction ifTrue: [ - "Special case for fraction power by Nicolas Cellier: - If aNumber is a fraction, but result must be a Float, learn it as quickly as possible, and give quick Float answer - Allows evaluating: - (2009/2000) raisedTo: (3958333/100000) - " - ^ self raisedToFraction: exponent]. - self < 0 ifTrue: [ - ^NegativePowerError new signalReceiver: self selector: #raisedTo: argument: exponent]. - 0 = exponent ifTrue: [^ self class one]. "Special case of exponent=0" - 1 = exponent ifTrue: [^ self]. "Special case of exponent=1" - 0 = self ifTrue: [ "Special case of self = 0" - exponent < 0 - ifTrue: [^ (self raisedTo: exponent negated) reciprocal] - ifFalse: [^ self]]. - ^ (exponent * self ln) exp "Otherwise use logarithms"! ! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 7/2/2019 11:30:27' prior: 50465121! - raisedToFraction: aFraction - self isZero ifTrue: [ - aFraction negative ifTrue: [^ (self raisedToFraction: aFraction negated) reciprocal]. - ^ self ]. - self negative ifFalse: [ - ^ (self ln * aFraction) exp ]. - aFraction denominator = 2 ifTrue: [ - ^ self sqrt raisedToInteger: aFraction numerator ]. - (self negative and: [ aFraction denominator even ]) ifTrue: [ - ^NegativePowerError new signalReceiver: self selector: #raisedToFraction: argument: aFraction]. - ^ (self negated ln * aFraction) exp negated! ! -!ArithmeticMessageError methodsFor: 'exceptionDescription' stamp: 'jmv 7/2/2019 10:05:55' prior: 50465047! - defaultAction - (receiver isFloatOrFloatComplex or: [ arguments notNil and: [arguments anySatisfy: [ :a | a isFloatOrFloatComplex ]]]) ifTrue: [ - ^self floatErrorValue ]. - ^ super defaultAction! ! -!NegativePowerError methodsFor: 'signaling' stamp: 'jmv 7/2/2019 08:25:33' prior: 50465075! - floatErrorValue - ^ receiver class nan! ! -!ZeroDivide methodsFor: 'signaling' stamp: 'jmv 7/2/2019 11:13:46' prior: 50465079! - floatErrorValue - | answerClass answerSign | - - receiver isZero ifTrue: [ - answerClass _ receiver isComplex ifTrue: [ receiver class ] ifFalse: [ Float ]. - ^ answerClass nan ]. - - receiver isComplex ifFalse: [ - answerSign _ arguments first isComplex - ifTrue: [ receiver sign ] - ifFalse: [ (receiver * arguments first) sign ]. - ^ answerSign = -1 - ifTrue: [ Float negativeInfinity ] - ifFalse: [ Float infinity ]]. - - ^ receiver class infinity! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3818-ArithmeticErrorsWithComplex-JuanVuletich-2019Jul02-11h29m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3817] on 2 July 2019 at 11:35:21 am'! -!ChangeList methodsFor: 'scanning' stamp: 'jmv 7/2/2019 10:01:30' prior: 16795919! - scanCategory: category class: class meta: meta stamp: stamp - | itemPosition method | - [ - itemPosition _ file position. - method _ file nextChunk. - method size > 0 ] "done when double terminators" - whileTrue: [ - self - addItem: (ChangeRecord new file: file position: itemPosition type: #method - class: class category: category meta: meta stamp: stamp) - text: 'method: ' , class , (meta ifTrue: [' class '] ifFalse: [' ']) - , (((Smalltalk at: class ifAbsent: [Object class]) parserClass selectorFrom: method) ifNil: ['']) - , (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp])]! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3819-ChangeList-fix-JuanVuletich-2019Jul02-11h34m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3817] on 1 July 2019 at 5:36:37 pm'! -!HandMorph methodsFor: 'private events' stamp: 'jmv 7/1/2019 17:36:19' prior: 50456618! - generateKeyboardEvent: evtBuf - "Generate the appropriate mouse event for the given raw event buffer" - | buttons modifiers type keyValue pressType stamp mouseScrollDirection | - stamp _ evtBuf second. - stamp = 0 ifTrue: [ stamp _ Time localMillisecondClock ]. - (evtBuf sixth <= 0 or: [ (keyValue _ Character iso8859s15CodeForUnicodeCodePoint: evtBuf sixth) isNil ]) ifTrue: [ keyValue _ Character macRomanToLatin1: evtBuf third ]. - Sensor peekEvent ifNotNil: [ :nxt | - "start: Combining diacritical marks (i.e. accents in the Linux VM)" - (nxt fourth = EventSensor eventKeyDown and: [ nxt third > 255 ]) ifTrue: [ - keyValue _ ((Character numericValue: keyValue) withDiacriticalMark: nxt third) iso8859s15Code. - Sensor - nextEvent; - nextEvent; - nextEvent ]. - "end: Combining diacritical marks (i.e. accents in the Linux VM)" - "start: Spurious LF after CR on Ctrl-Enter on Windows VM" - ((evtBuf fourth = EventSensor eventKeyChar and: [ evtBuf third = 13 ]) and: [ - nxt fourth = EventSensor eventKeyChar and: [ nxt third = 10 ]]) ifTrue: [ Sensor nextEvent - "print " ]]. - modifiers _ evtBuf fifth. - pressType _ evtBuf fourth. - pressType = EventSensor eventKeyDown ifTrue: [ - type _ #keyDown. - lastKeyDownValue _ keyValue ]. - pressType = EventSensor eventKeyUp ifTrue: [ - (keyValue = 9 and: [(modifiers anyMask: 1) and: [Smalltalk platformName = 'unix']]) - ifTrue: [ - "Linux VMs don't generate shift-tab keystroke. Turn #keyUp into #keystroke" - pressType _ EventSensor eventKeyChar ] - ifFalse: [type _ #keyUp ]]. - pressType = EventSensor eventKeyChar ifTrue: [ - type _ #keystroke. - "If Control key pressed, and the VM answers a code below 27, - it means it did the translation, convert it back to regular character: - We want to handle the meaning of ctrl ourselves." - (modifiers anyMask: 2) ifTrue: [ - "Control key pressed" - keyValue < 27 ifTrue: [ - "But we don't want to do it for Home/End/PgUp/PgDn, just for alphabetic keys" - lastKeyDownValue = keyValue ifFalse: [ - "If equal, real Home/End/PgUp/PgDn in Windows => don't translate" - (keyValue + 64 = lastKeyDownValue or: [ "If Equal, Ctrl-alphabetic in Windows => do translate" - lastKeyDownValue < 47 ]) ifTrue: [ - "Not on windows. If less (not sure about the bound, but do not translate 48: tab on Mac), alphabetic on Mac => do translate" - keyValue _ (modifiers anyMask: 1) - ifTrue: [ keyValue + 64 ] - ifFalse: [ keyValue + 96 - "shift not pressed: conver to lowercase letter" ]]]]. - "On Windows, ctrl-backSpace is reported as ctrl-forwardDelete. But keyDown is ok, so we can know and fix." - (keyValue = 127 and: [ lastKeyDownValue = 8 ]) - ifTrue: [ keyValue _ 8 ]. - "Act as if command/alt was pressed for some usual Windows ctrl-key combinations" - (self shouldControlEmulateAltFor: keyValue) ifTrue: [ modifiers _ modifiers bitOr: 8 ]]]. - buttons _ modifiers bitShift: 3. - "Linux and Windows VM send keyboard ctrl-upArrow and ctrl-downArrow when the user tries to scroll using the mouse wheel - Mac VM sends cmd-option-ctrl-shift-upArrow and cmd-option-ctrl-shift-downArrow for trackpad vertical scroll gestures, - and cmd-option-ctrl-shift-leftArrow and cmd-option-ctrl-shift-rightArrow for horizontal scroll gestures. - This way of reporting scroll events by the VM also enables scrolling using the keyboard (actually, we can't tell if user gesture was on Mouse, Trackpad or Keyboard). - But ctrl-shift and cmdAlt-shift are needed used for selecting while moving by word, line, etc. - Additionally, #ctrlArrowsScrollHorizontally allows chosing between keyboard horizontal scroll and moving word by word in text editors." - mouseScrollDirection _ nil. - "Ctrl for Keyboard or Mouse wheel gestures. All modifiers for Trackpad gestures." - (buttons = InputSensor controlKey or: [buttons = InputSensor cmdAltOptionCtrlShiftModifierKeys]) ifTrue: [ - keyValue = 30 - ifTrue: [mouseScrollDirection _ #up] - ifFalse: [keyValue = 31 - ifTrue: [mouseScrollDirection _ #down]]]. - "Ctrl for Keyboard or Mouse wheel gestures, only if preference is set. All modifiers for Trackpad gestures." - ((buttons = InputSensor controlKey and: [Preferences ctrlArrowsScrollHorizontally]) or: [buttons = InputSensor cmdAltOptionCtrlShiftModifierKeys]) ifTrue: [ - keyValue = 28 - ifTrue: [mouseScrollDirection _ #left] - ifFalse: [keyValue = 29 - ifTrue: [mouseScrollDirection _ #right]]]. - mouseScrollDirection ifNotNil: [ - ^ MouseScrollEvent new - setType: #mouseScroll - position: self morphPosition - direction: mouseScrollDirection - buttons: buttons - hand: self - stamp: stamp ]. - ^ KeyboardEvent new - setType: type - buttons: buttons - position: self morphPosition - keyValue: keyValue - hand: self - stamp: stamp! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3820-fixCtrlBackspaceOnWindows-JuanVuletich-2019Jul01-17h35m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3817] on 1 July 2019 at 8:44:05 pm'! - -"Change Set: 3818-CuisCore-AuthorName-2019Jul01-20h42m -Date: 1 July 2019 -Author: Nahuel Garbezza - -Adds a convenient CompiledMethod>>browse method"! -!CompiledMethod methodsFor: 'user interface support' stamp: 'RNG 7/1/2019 20:42:52'! - browse - - BrowserWindow fullOnClass: self methodClass selector: self selector! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3821-CompiledMethod-browse-NahuelGarbezza-2019Jul01-20h42m-RNG.1.cs.st----! - -'From Cuis 5.0 [latest update: #3821] on 3 July 2019 at 10:11:52 am'! -!Parser methodsFor: 'error correction' stamp: 'jmv 7/3/2019 10:11:08'! - sourceDelta - - | userSelectionDelta | - requestor notNil ifTrue: [ - userSelectionDelta _ requestor selectionInterval ifEmpty: [0] ifNotEmpty: [ :userSelection | userSelection first-1 ]. - encoder selector = Scanner doItSelector ifTrue: [ - ^ (Scanner selectionDoItSourceCodeHeaderSizeWithContext: false) - userSelectionDelta ]. - encoder selector = Scanner doItInSelector ifTrue: [ - ^ (Scanner selectionDoItSourceCodeHeaderSizeWithContext: true) - userSelectionDelta ]]. - - ^ 0! ! -!Parser methodsFor: 'error handling' stamp: 'jmv 7/3/2019 10:11:21' prior: 16885713! - notify: string at: location - | adjustedLocation | - adjustedLocation _ location - self sourceDelta. - requestor - ifNil: [ - (encoder == self or: [encoder isNil]) ifTrue: [^ self fail "failure setting up syntax error"]. - SyntaxErrorNotification - inClass: encoder classEncoding - category: category - withCode: - (source contents - copyReplaceFrom: adjustedLocation - to: adjustedLocation - 1 - with: string , ' ->') - doitFlag: doitFlag - errorMessage: string - location: adjustedLocation] - ifNotNil: [ - requestor - notify: string , ' ->' - at: adjustedLocation - in: source]. - ^self fail! ! -!Parser methodsFor: 'error correction' stamp: 'jmv 7/3/2019 10:11:16' prior: 50456003! - correctSelector: proposedKeyword wordIntervals: aSpots exprInterval: expInt ifAbort: abortAction - "Correct the proposedKeyword to some selector symbol, correcting the original text if such action is indicated. abortAction is invoked if the proposedKeyword couldn't be converted into a valid selector. Spots is an ordered collection of intervals within the test stream of the for each of the keyword parts." - - | correctSelector userSelection delta adjustedSpots | - "If we can't ask the user, assume that the keyword will be defined later" - self interactive ifFalse: [^proposedKeyword asSymbol]. - - "If the requestor is of an exotic kind (like a telnet server) we might not be allowed to open a PupUpMenu for querying the user" - " - ((requestor isKindOf: Editor) or: [ requestor is: #Morph ]) - ifFalse: [ ^ proposedKeyword asSymbol ]. - " - - userSelection _ requestor selectionInterval. - - delta := self sourceDelta. - adjustedSpots := aSpots collect: [ :interval | interval first - delta to: interval last - delta ]. - requestor selectFrom: adjustedSpots first first to: adjustedSpots last last. - - correctSelector _ UnknownSelector name: proposedKeyword. - correctSelector ifNil: [^abortAction value]. - - requestor selectInvisiblyFrom: userSelection first to: userSelection last. - - self substituteSelector: correctSelector keywords wordIntervals: adjustedSpots. - ^(proposedKeyword last ~~ $: - and: [correctSelector last == $:]) - ifTrue: [abortAction value] - ifFalse: [correctSelector]! ! -!Parser methodsFor: 'error correction' stamp: 'jmv 7/3/2019 10:11:19' prior: 50456053! - correctVariable: proposedVariable interval: aSpot - "Correct the proposedVariable to a known variable, or declare it as a new - variable if such action is requested. We support declaring lowercase - variables as temps or inst-vars, and uppercase variables as Globals or - ClassVars, depending on whether the context is nil (class=UndefinedObject). - Spot is the interval within the test stream of the variable. - rr 3/4/2004 10:26 : adds the option to define a new class. " - - "Check if this is an i-var, that has been corrected already (ugly)" - - "Display the pop-up menu" - - | userSelection action delta spot | - (encoder classEncoding instVarNames includes: proposedVariable) ifTrue: [ - ^InstanceVariableNode new - name: proposedVariable - index: (encoder classEncoding allInstVarNames indexOf: proposedVariable)]. - - "First check to see if the requestor knows anything about the variable" - (requestor bindingOf: proposedVariable) - ifNotNil: [ :binding | ^ encoder global: binding name: proposedVariable]. - - "If we can't ask the user for correction, make it undeclared" - self interactive ifFalse: [^encoder undeclared: proposedVariable]. - - userSelection _ requestor selectionInterval. - delta _ self sourceDelta. - spot _ aSpot first - delta to: aSpot last - delta. - requestor selectFrom: spot first to: spot last. - - "Build the menu with alternatives" - action _ UndeclaredVariable - signalFor: self - name: proposedVariable - inRange: spot. - action ifNil: [^self fail]. - - "Execute the selected action" - requestor selectInvisiblyFrom: userSelection first to: userSelection last. - ^action value! ! - -Parser removeSelector: #correctSourceDelta! - -Parser removeSelector: #correctSourceDelta! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3822-NothingMoreExpectedFix-JuanVuletich-2019Jul03-10h10m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3822] on 3 July 2019 at 9:40:21 am'! -!BlockClosure methodsFor: 'testing' stamp: 'jmv 7/3/2019 09:37:11'! - isCleanClosure - "A clean closure is one that doesn't really need the home context because: - - It doesn't send messages to self or super - - It doesn't access any instance variable - - It doesn't access any outer temp - - It doesn't do non local return (return from method to caller, i.e. ^ something) - Therefore it doesn't close over a lexical scope, and in this sense they are trivial. - They can also be called 'context free' or 'simple block'. - " - - | recreated source | - source _ self decompile decompileString. - - "This catches any acess to outer context!!" - recreated _ [ Compiler evaluate: source ] on: UndeclaredVariableWarning do: [ :ex | ^ false ]. - - "Fail if returns from outer context, or uses self" - Smalltalk - eliotsClosureMeasurementsOn: recreated outerContext method - over: [ :closuresCount :hasIndirectTemps :anyClosureHasCopied :anyClosureDoesNonLocalReturn :anyClosureUsesSelf | - anyClosureDoesNonLocalReturn ifTrue: [ ^ false ]. - anyClosureUsesSelf ifTrue: [ ^ false ]]. - - "Ok." - ^true! ! -!BlockClosure methodsFor: 'objects from disk' stamp: 'jmv 7/3/2019 09:38:53' prior: 16788614! - objectForDataStream: refStrm - "I am about to be written on an object file. Write a textual reference instead." - self isCleanClosure ifFalse: [ - self error: 'Can only serialize clean (context free) closures.' ]. - ^ DiskProxy - global: #Compiler - selector: #evaluate: - args: (Array with: self decompile decompileString)! ! -!SystemDictionary methodsFor: 'Closure measurements' stamp: 'jmv 7/3/2019 09:24:10' prior: 16924388! - browseMethodsWithClosuresThatAccessOuterTemps - " - Smalltalk browseMethodsWithClosuresThatAccessOuterTemps - " - - self - browseMessageList: (self allSelect: [ :m | - self eliotsClosureMeasurementsOn: m over: [ :closuresCount - :hasIndirectTemps :anyClosureHasCopied :anyClosureDoesNonLocalReturn :anyClosureUsesSelf | - anyClosureHasCopied ]. - ]) - name: 'Closures that read or write to outer temps'! ! -!SystemDictionary methodsFor: 'Closure measurements' stamp: 'jmv 7/3/2019 09:24:14' prior: 16924404! - browseMethodsWithClosuresThatOnlyReadOuterTemps - " - Smalltalk browseMethodsWithClosuresThatOnlyReadOuterTemps - " - - self - browseMessageList: (self allSelect: [ :m | - self eliotsClosureMeasurementsOn: m over: [ :closuresCount - :hasIndirectTemps :anyClosureHasCopiedValues :anyClosureDoesNonLocalReturn :anyClosureUsesSelf | - anyClosureHasCopiedValues & hasIndirectTemps not]. - ]) - name: 'Closures that read but not write to outer temps'! ! -!SystemDictionary methodsFor: 'Closure measurements' stamp: 'jmv 7/3/2019 09:24:19' prior: 16924421! - browseMethodsWithClosuresThatWriteOuterTemps - " - Smalltalk browseMethodsWithClosuresThatWriteOuterTemps - " - - self - browseMessageList: (self allSelect: [ :m | - self eliotsClosureMeasurementsOn: m over: [ :closuresCount - :hasIndirectTemps :anyClosureHasCopied :anyClosureDoesNonLocalReturn :anyClosureUsesSelf | - hasIndirectTemps ]. - ]) - name: ' Closures that write to outer temps'! ! -!SystemDictionary methodsFor: 'Closure measurements' stamp: 'jmv 7/3/2019 09:24:25' prior: 16924436! - browseMethodsWithClosuresThatWriteOuterTempsButCleanOtherwise - " - Smalltalk browseMethodsWithClosuresThatWriteOuterTempsButCleanOtherwise - " - - self - browseMessageList: (self allSelect: [ :m | - self eliotsClosureMeasurementsOn: m over: [ :closuresCount - :hasIndirectTemps :anyClosureHasCopied :anyClosureDoesNonLocalReturn :anyClosureUsesSelf | - hasIndirectTemps and: [ anyClosureDoesNonLocalReturn not and: [ anyClosureUsesSelf not ] ] ]. - ]) - name: ' Closures that write to outer temps, but clean otherwise'! ! -!SystemDictionary methodsFor: 'Closure measurements' stamp: 'jmv 7/3/2019 09:24:29' prior: 16924474! - browseMethodsWithMoreThanOneClosure - " - Smalltalk browseMethodsWithMoreThanOneClosure - " - - self - browseMessageList: (self allSelect: [ :m | - self eliotsClosureMeasurementsOn: m over: [ :closuresCount - :hasIndirectTemps :anyClosureHasCopied :anyClosureDoesNonLocalReturn :anyClosureUsesSelf | - closuresCount > 1 ]. - ]) - name: 'Methods with more than one Closure'! ! -!SystemDictionary methodsFor: 'Closure measurements' stamp: 'jmv 7/3/2019 09:24:34' prior: 16924489! - browseMethodsWithOnlyCleanClosures - " - Smalltalk browseMethodsWithOnlyCleanClosures - " - self - browseMessageList: ( - self allSelect: [ :m | - self eliotsClosureMeasurementsOn: m over: [ :closuresCount - :hasIndirectTemps :anyClosureHasCopied :anyClosureDoesNonLocalReturn :anyClosureUsesSelf | - closuresCount > 0 and: [ - (anyClosureHasCopied or: [ anyClosureDoesNonLocalReturn or: [ anyClosureUsesSelf ]]) not ]. - ] - ]) - name: 'Methods with only Clean Closures'! ! -!SystemDictionary methodsFor: 'Closure measurements' stamp: 'jmv 7/3/2019 09:24:43' prior: 16924507! - closuresInfoStringForClass: aClass selector: aSelector - " - Smalltalk closuresInfoStringFor: PlayingWithClosures class >> #exp01Argument - " - | answer all someDo noneDoes method | - method _ aClass compiledMethodAt: aSelector ifAbsent: [ ^'' ]. - self eliotsClosureMeasurementsOn: method over: [ - :closuresCount :hasIndirectTemps :anyClosureHasCopied :anyClosureDoesNonLocalReturn :anyClosureUsesSelf | - - closuresCount > 0 - ifFalse: [ answer _ 'No real (non-optimized) Closures' ] - ifTrue: [ - closuresCount = 1 - ifTrue: [ - answer _ '1 Closure: '. - all _ ''. - someDo _ 'does'. - noneDoes _ 'does not' ] - ifFalse: [ - answer _ closuresCount printString, ' Closures: '. - all _ 'all '. - someDo _ 'some do'. - noneDoes _ 'none does' ]. - (anyClosureHasCopied or: [ anyClosureDoesNonLocalReturn or: [ anyClosureUsesSelf ]]) - ifFalse: [ answer _ answer, all, 'clean' ] - ifTrue: [ - answer _ answer, (anyClosureHasCopied - ifTrue: [ - hasIndirectTemps - ifTrue: [ someDo, ' write (and maybe ', someDo, ' read)' ] - ifFalse: [ someDo, ' read (but ', noneDoes, ' write)' ] ] - ifFalse: [ noneDoes, ' access' ]), ' outer temps; '. - answer _ answer, (anyClosureDoesNonLocalReturn - ifTrue: [ someDo ] - ifFalse: [ noneDoes ]), ' ^return; '. - answer _ answer, (anyClosureUsesSelf - ifTrue: [ someDo ] - ifFalse: [ noneDoes ]), ' use self' - ]. - ] - ]. - ^answer! ! -!SystemDictionary methodsFor: 'Closure measurements' stamp: 'jmv 7/3/2019 09:34:34' prior: 16924556! - eliotsClosureMeasurements - " - Smalltalk eliotsClosureMeasurements - From http://www.mirandabanda.org/cogblog/2008/11/14/mechanised-modifications-and-miscellaneous-measurements/ - by Eliot Miranda - " - | numMethods numMethodsWithClosure numMethodsWithIndirectTemps - numClosures numClosuresWithCopiedValues numCopiedValuesForClosure - numRemoteTemps numScopesWithRemoteTemps - nonLocalReturnsInClosure closureUsesSelfs nonLocalReturnAndUsesSelfs numClean | - - numMethods := numMethodsWithClosure := numMethodsWithIndirectTemps := - numClosures := numClosuresWithCopiedValues := numCopiedValuesForClosure := - numRemoteTemps := numScopesWithRemoteTemps := - nonLocalReturnsInClosure := closureUsesSelfs := nonLocalReturnAndUsesSelfs := numClean := 0. - self allSelect: [ :m | - | s hasClosure hasIndirectTemps blkPc blkSz doesNonLocalReturn usesSelf hasCopied sel | - sel _ false. - hasClosure := hasIndirectTemps := false. - s := InstructionStream on: m. - s scanFor: - [:b| - b = 143 "closure creation" ifTrue: - [hasClosure := true. - numClosures := numClosures + 1. - s followingByte >= 16 ifTrue: - [numClosuresWithCopiedValues := numClosuresWithCopiedValues + 1. - numCopiedValuesForClosure := numCopiedValuesForClosure + (s followingByte >> 4)]]. - (b = 138 "indirect temp vector creation" - and: [s followingByte <= 127]) ifTrue: - [hasIndirectTemps := true. - numScopesWithRemoteTemps := numScopesWithRemoteTemps + 1. - numRemoteTemps := numRemoteTemps + s followingByte]. - false]. - numMethods := numMethods + 1. - hasClosure ifTrue: - [numMethodsWithClosure := numMethodsWithClosure + 1. - s pc: m initialPC; scanFor: [:b| b = 143]. - -"jmv-This looks like the correct place to do this" - hasCopied := s followingByte >= 16. - - blkSz := s interpretNextInstructionFor: BlockStartLocator new. - blkPc := s pc. - doesNonLocalReturn := usesSelf := false. - -"jmv-Doing this here looks like a bug. See the other comment" - hasCopied := s followingByte >= 16. - -"jmv-Another bug. This only considers the first closure (and any nested closure in it), but not later ones" - - s scanFor: - [:b| - s pc >= (blkPc + blkSz) - ifTrue: [true] - ifFalse: - [doesNonLocalReturn := doesNonLocalReturn or: [s willReturn and: [s willBlockReturn not]]. - usesSelf := usesSelf or: [b = 112 "pushSelf" - or: [b < 16 "pushInstVar" - or: [(b = 128 and: [s followingByte <= 63]) "pushInstVar" - or: [(b between: 96 and: 96 + 7) "storePopInstVar" - or: [(b = 130 and: [s followingByte <= 63]) "storePopInstVar" - or: [(b = 129 and: [s followingByte <= 63]) "storeInstVar" - or: [b = 132 and: [s followingByte = 160]]]]]]]]. - false]]. - doesNonLocalReturn ifTrue: - [nonLocalReturnsInClosure := nonLocalReturnsInClosure + 1]. - usesSelf ifTrue: - [closureUsesSelfs := closureUsesSelfs + 1]. - (doesNonLocalReturn and: [usesSelf]) ifTrue: - [nonLocalReturnAndUsesSelfs := nonLocalReturnAndUsesSelfs + 1]. - (doesNonLocalReturn or: [usesSelf or: [hasCopied]]) ifFalse: - [numClean := numClean + 1]]. - hasIndirectTemps ifTrue: [numMethodsWithIndirectTemps := numMethodsWithIndirectTemps + 1]. - sel]. -^ { {'Methods'. numMethods}. {'MethodsWithClosure'. numMethodsWithClosure}. {'MethodsWithIndirectTemps'. numMethodsWithIndirectTemps}. - {'Closures'. numClosures}. {'CopiedValuesForClosures'. numCopiedValuesForClosure}. {'ClosuresWithCopiedValues'. numClosuresWithCopiedValues}. - {'RemoteTemps'. numRemoteTemps}. {'ScopesWithRemoteTemps'. numScopesWithRemoteTemps}. - {'MethodsWithNonLocalReturnsInClosures'. nonLocalReturnsInClosure}. {'MethodsWithReferencesToSelfInClosures'. closureUsesSelfs}. {'Both'. nonLocalReturnAndUsesSelfs}. - {'MethodsWithOnlyCleanClosures'. numClean} }! ! -!SystemDictionary methodsFor: 'Closure measurements' stamp: 'jmv 7/3/2019 09:30:32' prior: 16924733! - eliotsClosureMeasurements2 - " - Smalltalk eliotsClosureMeasurements2 - " - | numMethods numMethodsWithClosure numMethodsWithIndirectTemps anyClosureDoesNonLocalReturnCount anyClosureUsesSelfCount bothCount onlyCleanBlocksCount anyClosureHasCopiedCount | - - numMethods := numMethodsWithClosure := numMethodsWithIndirectTemps := - anyClosureDoesNonLocalReturnCount := anyClosureUsesSelfCount := bothCount := onlyCleanBlocksCount := 0. - anyClosureHasCopiedCount _ 0. - self allSelect: [ :m | - self eliotsClosureMeasurementsOn: m over: [ :closuresCount :hasIndirectTemps :anyClosureHasCopied :anyClosureDoesNonLocalReturn :anyClosureUsesSelf | - numMethods := numMethods + 1. - closuresCount > 0 ifTrue: [ numMethodsWithClosure := numMethodsWithClosure + 1 ]. - hasIndirectTemps ifTrue: [ numMethodsWithIndirectTemps := numMethodsWithIndirectTemps + 1]. - anyClosureDoesNonLocalReturn ifTrue: [ anyClosureDoesNonLocalReturnCount := anyClosureDoesNonLocalReturnCount + 1]. - anyClosureUsesSelf ifTrue: [ anyClosureUsesSelfCount := anyClosureUsesSelfCount + 1]. - (anyClosureDoesNonLocalReturn and: [anyClosureUsesSelf]) ifTrue: [ bothCount := bothCount + 1]. - closuresCount > 0 ifTrue: [ - (anyClosureDoesNonLocalReturn or: [anyClosureUsesSelf or: [anyClosureHasCopied]]) ifFalse: [ - onlyCleanBlocksCount := onlyCleanBlocksCount + 1]]. - anyClosureHasCopied ifTrue: [ anyClosureHasCopiedCount _ anyClosureHasCopiedCount + 1 ]. - false. - ] - ]. - ^{ - {'Methods'. numMethods}. {'MethodsWithClosure'. numMethodsWithClosure}. - {'WithClosuresAccessingOuterTemps'. anyClosureHasCopiedCount}. - {'WithClosuresWritingOuterTemps'. numMethodsWithIndirectTemps}. - {'WithNonLocalReturnsInClosures'. anyClosureDoesNonLocalReturnCount}. - {'WithReferencesToSelfInClosures'. anyClosureUsesSelfCount}. - {'BothAbove'. bothCount}. - {'WithOnlyCleanClosures'. onlyCleanBlocksCount}. - }! ! -!SystemDictionary methodsFor: 'Closure measurements' stamp: 'jmv 7/3/2019 09:30:39' prior: 16924794! -eliotsClosureMeasurements2On: aMethod - " - A Couple of Clean Closures - Smalltalk eliotsClosureMeasurements2On: PlayingWithClosures class >> #exp01Argument - Smalltalk eliotsClosureMeasurements2On: PlayingWithClosures class >> #exp01LocalTemp - - Closures reading and writing to outer temps - Smalltalk eliotsClosureMeasurements2On: PlayingWithClosures class >> #exp01RemoteTemp - Smalltalk eliotsClosureMeasurements2On: PlayingWithClosures class >> #exp01RemoteTempWithAssignment - - Closure doing an method return - Smalltalk eliotsClosureMeasurements2On: PlayingWithClosures class >> #exp01UpArrowReturn - - Closures sending messages to self & super - Smalltalk eliotsClosureMeasurements2On: PlayingWithClosures class >> #exp01SelfSend - Smalltalk eliotsClosureMeasurements2On: PlayingWithClosures class >> #exp01SuperSend - - A couple of non-closures, i.e. blocks that are optimized by the compiler and a closure is never created - Smalltalk eliotsClosureMeasurements2On: PlayingWithClosures class >> #exp01RemoteTempOptimized - Smalltalk eliotsClosureMeasurements2On: PlayingWithClosures class >> #exp01RemoteTempOptimizedWithAssignment - - A remote temp whose declaration can not be moved inside the block - Smalltalk eliotsClosureMeasurements2On: PlayingWithClosures class >> #exp01RemoteTempCantBeMovedInside - Smalltalk eliotsClosureMeasurements2On: PlayingWithClosures class >> #exp01RemoteTempAssignedTwice - A remote temp whose declaration can be moved inside the block - Smalltalk eliotsClosureMeasurements2On: PlayingWithClosures class >> #exp01RemoteTempCanBeMovedInside - A not-so remote temp. The declaration was moved inside the block, making it a clean block - Smalltalk eliotsClosureMeasurements2On: PlayingWithClosures class >> #exp01LocalTemp - " - | numMethods numMethodsWithClosure numMethodsWithIndirectTemps anyClosureDoesNonLocalReturnCount anyClosureUsesSelfCount bothCount onlyCleanBlocksCount anyClosureHasCopiedCount | - - numMethods := numMethodsWithClosure := numMethodsWithIndirectTemps := - anyClosureDoesNonLocalReturnCount := anyClosureUsesSelfCount := bothCount := onlyCleanBlocksCount := 0. - anyClosureHasCopiedCount _ 0. - self eliotsClosureMeasurementsOn: aMethod over: [ :closuresCount :hasIndirectTemps :anyClosureHasCopied :anyClosureDoesNonLocalReturn :anyClosureUsesSelf | - numMethods := numMethods + 1. - closuresCount > 0 ifTrue: [ numMethodsWithClosure := numMethodsWithClosure + 1 ]. - hasIndirectTemps ifTrue: [ numMethodsWithIndirectTemps := numMethodsWithIndirectTemps + 1]. - anyClosureDoesNonLocalReturn ifTrue: [ anyClosureDoesNonLocalReturnCount := anyClosureDoesNonLocalReturnCount + 1]. - anyClosureUsesSelf ifTrue: [ anyClosureUsesSelfCount := anyClosureUsesSelfCount + 1]. - (anyClosureDoesNonLocalReturn and: [anyClosureUsesSelf]) ifTrue: [ bothCount := bothCount + 1]. - closuresCount > 0 ifTrue: [ - (anyClosureDoesNonLocalReturn or: [anyClosureUsesSelf or: [anyClosureHasCopied]]) ifFalse: [ - onlyCleanBlocksCount := onlyCleanBlocksCount + 1]]. - anyClosureHasCopied ifTrue: [ anyClosureHasCopiedCount _ anyClosureHasCopiedCount + 1 ]. - ]. - ^{ - {'Methods'. numMethods}. {'MethodsWithClosure'. numMethodsWithClosure}. - {'WithClosuresAccessingOuterTemps'. anyClosureHasCopiedCount}. - {'WithClosuresWritingOuterTemps'. numMethodsWithIndirectTemps}. - {'WithNonLocalReturnsInClosures'. anyClosureDoesNonLocalReturnCount}. - {'WithReferencesToSelfInClosures'. anyClosureUsesSelfCount}. - {'BothAbove'. bothCount}. - {'WithOnlyCleanClosures'. onlyCleanBlocksCount}. - }! ! -!SystemDictionary methodsFor: 'Closure measurements' stamp: 'jmv 7/3/2019 09:28:27' prior: 16924906! - eliotsClosureMeasurementsOn: m over: aFiveArgBlock - " - See senders. - Or try something like: - Smalltalk - eliotsClosureMeasurementsOn: FileList >> #defaultContents - over: [ :closuresCount :hasCopiedValuesForClosure :hasIndirectTemps :anyClosureHasCopied :anyClosureDoesNonLocalReturn :anyClosureUsesSelf | - (Array with: closuresCount with: hasCopiedValuesForClosure with: hasIndirectTemps with: anyClosureHasCopied with: anyClosureDoesNonLocalReturn with: anyClosureUsesSelf)] - - From http://www.mirandabanda.org/cogblog/2008/11/14/mechanised-modifications-and-miscellaneous-measurements/ - by Eliot Miranda - - Note: This could perhaps be refactored to use the newer #embeddedBlockClosures and testing methods on the closures themselves. - " - | s nextScanStart thisClosureHasCopied closuresCount hasIndirectTemps blkPc blkSz anyClosureHasCopied anyClosureDoesNonLocalReturn anyClosureUsesSelf analyzedClosures | - closuresCount := 0. - hasIndirectTemps := false. - anyClosureHasCopied := anyClosureDoesNonLocalReturn := anyClosureUsesSelf := false. - s := InstructionStream on: m. - s scanFor: [ :b | - b = 16r8F "16r8F = 143 closure creation" ifTrue: [ - closuresCount := closuresCount + 1]. - (b = 16r8A "16r8A = 138indirect temp vector creation" and: [ s followingByte <= 127]) ifTrue: [ - hasIndirectTemps := true]. - false]. - nextScanStart := m initialPC. - analyzedClosures := 0. - [ analyzedClosures < closuresCount ] whileTrue: [ - s pc: nextScanStart; scanFor: [ :b | b = 16r8F ]. "16r8F = 143 Search for first closure" - analyzedClosures := analyzedClosures + 1. - thisClosureHasCopied := s followingByte >= 16r10. - anyClosureHasCopied := anyClosureHasCopied | thisClosureHasCopied. - blkSz := s interpretNextInstructionFor: BlockStartLocator new. "Findout size of first closure" - blkPc := s pc. - s scanFor: [ :b | - s pc >= (blkPc + blkSz) - ifTrue: [ - nextScanStart := s pc. - true] - ifFalse: [ - b = 16r8F ifTrue: [ - thisClosureHasCopied := s followingByte >= 16r10. - anyClosureHasCopied := anyClosureHasCopied | thisClosureHasCopied. - analyzedClosures := analyzedClosures + 1 ]. - anyClosureDoesNonLocalReturn := anyClosureDoesNonLocalReturn or: [s willReturn and: [s willBlockReturn not]]. - anyClosureUsesSelf := anyClosureUsesSelf or: [b = 16r70 "pushSelf" - or: [b < 16r10 "pushInstVar" - or: [(b = 16r80 and: [s followingByte <= 16r3F]) "pushInstVar" - or: [(b between: 16r60 and: 16r60 + 7) "storePopInstVar" - or: [(b = 16r82 and: [s followingByte <= 63]) "storePopInstVar" - or: [(b = 16r81 and: [s followingByte <= 63]) "storeInstVar" - or: [b = 16r84 and: [s followingByte = 160]]]]]]]]. - false]]]. - ^aFiveArgBlock valueWithArguments: (Array - with: closuresCount - with: hasIndirectTemps - with: anyClosureHasCopied - with: anyClosureDoesNonLocalReturn - with: anyClosureUsesSelf)! ! - -BlockClosure removeSelector: #isTrivialClosure! - -BlockClosure removeSelector: #isTrivialClosure! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3823-BetterNamesForClosuresStuff-JuanVuletich-2019Jul03-09h23m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3823] on 11 July 2019 at 2:45:03 pm'! -!ProtocolBrowser methodsFor: 'accessing' stamp: 'HAW 7/11/2019 14:44:31' prior: 50374609! - labelString - "Answer the string for the window title" - - ^ 'Protocol for: ', baseClass name, ' up to: ', (selectedName ifNil: [ ProtoObject name asString ])! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3824-ProtocolBrowserFix-HernanWilkinson-2019Jul11-14h35m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3823] on 11 July 2019 at 5:10:57 pm'! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 7/11/2019 16:14:04' prior: 50452974! - withMethodNodeAndClassDo: aBlock ifErrorsParsing: anErrorBlock - - | selectedClass methodNode | - - "I have to do this because some codeProviders do no answer selectedClassOrMetaClass like the Workspace - Hernan" - selectedClass := [ self codeProvider selectedClassOrMetaClass ] on: Error do: [ :anError | anError return: UndefinedObject ]. - [ methodNode := selectedClass methodNodeFor: model actualContents ] on: Error do: [ :anError | ^ anErrorBlock value: anError ]. - - ^aBlock value: methodNode value: selectedClass.! ! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3825-ReturnOnWithMethodNodeAndClassDo-HernanWilkinson-2019Jul11-14h45m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3823] on 11 July 2019 at 5:44:59 pm'! -!Editor methodsFor: 'new selection' stamp: 'HAW 7/11/2019 17:31:59'! - wordRangeLeftDelimiters: leftDelimiters rightDelimiters: rightDelimiters startingAt: pointIndex - "Select delimited text or word--the result of double-clicking." - - | initialDelimiter finalDelimiter direction match level string here hereChar start stop | - string _ self privateCurrentString. - string size < 2 ifTrue: [^1 to: 1]. - here _ pointIndex min: string size max: 2. - initialDelimiter _ string at: here - 1. - match _ leftDelimiters indexOf: initialDelimiter. - match > 0 - ifTrue: [ - "delimiter is on left -- match to the right" - start _ here. - direction _ 1. - here _ here - 1. - finalDelimiter _ rightDelimiters at: match] - ifFalse: [ - initialDelimiter _ string at: here. - match _ rightDelimiters indexOf: initialDelimiter. - match > 0 - ifTrue: [ - "delimiter is on right -- match to the left" - stop _ here - 1. - direction _ -1. - finalDelimiter _ leftDelimiters at: match] - ifFalse: [ - "no delimiters -- select a token" - direction _ -1]]. - level _ 1. - [level > 0 and: [direction > 0 - ifTrue: [here < string size] - ifFalse: [here > 1]]] - whileTrue: [ - hereChar _ string at: (here _ here + direction). - match = 0 - ifTrue: [ - "token scan goes left, then right" - hereChar isValidInIdentifiers "Consider $: as a word separator" - ifTrue: [ - here = 1 - ifTrue: [ - start _ 1. - "go right if hit string start" - direction _ 1]] - ifFalse: [ - direction < 0 - ifTrue: [ - start _ here + 1. - "go right if hit non-token" - direction _ 1] - ifFalse: [level _ 0]]] - ifFalse: [ - "delimiter match just counts nesting level" - hereChar = finalDelimiter - ifTrue: [level _ level - 1"leaving nest"] - ifFalse: [ - hereChar = initialDelimiter - ifTrue: [level _ level + 1"entering deeper nest"]]]]. - level > 0 ifTrue: [ - leftDelimiters size + rightDelimiters size = 0 ifFalse: [ - "If we failed to find final delimiter, then just select word." - ^self wordRangeLeftDelimiters: '' rightDelimiters: '' ]. - here _ here + direction ]. - ^ direction > 0 - ifTrue: [ - "If a word ends with $: (a keyword), consider it part of the word" - hereChar = $: ifTrue: [here _ here + 1]. - start to: here - 1] - ifFalse: [ - "But if a word starts with $: (this is the argument to a keyword), then it is not part of the word." - here + 1 to: stop]! ! -!Editor methodsFor: 'new selection' stamp: 'HAW 7/11/2019 17:37:54'! - wordRangeUnder: aPositionInText - - ^self wordRangeLeftDelimiters: self wordLeftDelimiters rightDelimiters: self wordRightDelimiters startingAt: aPositionInText ! ! -!TextEditor methodsFor: 'model access' stamp: 'HAW 7/11/2019 17:37:01'! - wordUnder: aPositionInText - - | wordUnderCursorRange word indexOfSpace | - - wordUnderCursorRange := self wordRangeUnder: aPositionInText. - word := (model actualContents copyFrom: wordUnderCursorRange first to: wordUnderCursorRange last) asString. - - "I have to handle the edge case where the cursor is for example between a ' and the first letter of the word. - In that case the range will include words with spaces - Hernan" - indexOfSpace := word indexOf: $ ifAbsent: [ ^word ]. - - ^word first: indexOfSpace -1 - - ! ! -!Editor methodsFor: 'new selection' stamp: 'HAW 7/11/2019 17:32:34' prior: 50452299! - wordRangeLeftDelimiters: leftDelimiters rightDelimiters: rightDelimiters - "Select delimited text or word--the result of double-clicking." - - ^self wordRangeLeftDelimiters: leftDelimiters rightDelimiters: rightDelimiters startingAt: self pointIndex ! ! -!TextEditor methodsFor: 'model access' stamp: 'HAW 7/11/2019 17:39:22' prior: 50452387! - wordUnderCursor - - ^self wordUnder: self pointIndex! ! - -Editor removeSelector: #wordUnderCursorRange! - -Editor removeSelector: #wordUnderCursorRange! - -----End fileIn of /home/juan/Cuis-Smalltalk/Cuis-Smalltalk-Dev/CoreUpdates/3826-BetterWordRangeSupport-HernanWilkinson-2019Jul11-17h10m-HAW.1.cs.st----! - -----SNAPSHOT----(12 July 2019 10:27:10) Cuis5.0-3826-v3.image priorSource: 4236723! - -----QUIT----(12 July 2019 10:27:37) Cuis5.0-3826-v3.image priorSource: 4342382! - -----STARTUP---- (23 August 2019 10:05:33) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-3826-v3.image! - - -'From Cuis 5.0 [latest update: #3826] on 17 July 2019 at 5:45:34 pm'! -!InspectorWindow methodsFor: 'GUI building' stamp: 'HAW 7/17/2019 17:34:49'! - buildContentsText - - | contentsText | - - contentsText _ TextModelMorph - textProvider: model - textGetter: #acceptedContents - textSetter: #accept: - selectionGetter: #contentsSelection. - - ^contentsText! ! -!InspectorWindow methodsFor: 'GUI building' stamp: 'HAW 7/17/2019 17:35:31'! - buildEvaluatorText - - | evaluatorText | - - evaluatorText _ (TextModelMorph textProvider: model) - askBeforeDiscardingEdits: false; - emptyTextDisplayMessage: 'Smalltalk expression'. - - ^evaluatorText ! ! -!InspectorWindow methodsFor: 'GUI building' stamp: 'HAW 7/17/2019 17:34:02'! - buildList - - | list | - - list _ PluggableListMorph - model: model - listGetter: #fieldList - indexGetter: #selectionIndex - indexSetter: #toggleIndex: - mainView: self - menuGetter: #fieldListMenu - keystrokeAction: #inspectorKey:from:. - list doubleClickSelector: #inspectSelection. - - ^list! ! -!InspectorWindow methodsFor: 'GUI building' stamp: 'HAW 7/17/2019 17:35:57' prior: 50455797! - buildMorphicWindow - " Inspector openOn: SystemOrganization " - | contentsText list upperRow evaluatorText label | - - "Build widgets. We'll assemble them below." - list _ self buildList. - contentsText _ self buildContentsText. - evaluatorText _ self buildEvaluatorText. - - "Upper row has two widgets, side by side: the list of variables at the left side, and the variable contents pane at the right side." - upperRow _ LayoutMorph newRow. - upperRow - addMorph: list proportionalWidth: 0.3; - addAdjusterAndMorph: contentsText proportionalWidth: 0.7. - "Inspector Window has two rows: At the top, the one we just bult. Below it, the evaluation pane." - self layoutMorph - addMorph: upperRow proportionalHeight: 0.7; - addAdjusterAndMorph: evaluatorText proportionalHeight: 0.3. - "Set label" - label _ [model object printStringLimitedTo: 64] - on: UnhandledError - do: [:ex | ex return: model object class printString, ' (printing failed)']. - (label includesSubString: model object class name) - ifFalse: [label _ model object class name, ': ', label]. - self setLabel: label! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3827-InspectorWindowGUIBuildingRefactoring-HernanWilkinson-2019Jul17-12h40m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3826] on 19 July 2019 at 8:20:27 am'! -!CodeWindow methodsFor: 'keyboard shortcuts' stamp: 'HAW 7/19/2019 08:19:18' prior: 50458191! - messageListKey: aChar from: view - "Respond to a Command key. I am a model with a code pane, and I also - have a listView that has a list of methods. The view knows how to get - the list and selection." - - | sel class | - aChar == $D ifTrue: [^ model toggleDiffing]. - - sel _ model selectedMessageName. - aChar == $m ifTrue: [ "These next two put up a type in if no message selected" - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllImplementorsOf: to: Smalltalk]. - aChar == $n ifTrue: [ - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllCallsOn: to: Smalltalk]. - - aChar == $M ifTrue: [ ^ self browseActualImplementorsOfSelectedMethod ]. - aChar == $B ifTrue: [ ^ self browseActualSendersOfSelectedMethod ]. - - "The following require a class selection" - (class _ model selectedClassOrMetaClass) ifNil: [^ self ]. - aChar == $b ifTrue: [^ BrowserWindow fullOnClass: class selector: sel]. - aChar == $N ifTrue: [^ self browseClassRefs]. - aChar == $i ifTrue: [^ self methodHierarchy]. - aChar == $h ifTrue: [^ self browseHierarchy]. - aChar == $p ifTrue: [^ self browseFullProtocol]. - aChar == $R ifTrue: [^ model renameClass]. - - sel - ifNotNil: [ - "The following require a method selection" - aChar == $o ifTrue: [^ model fileOutMessage]. - aChar == $c ifTrue: [^ model copySelector]. - aChar == $v ifTrue: [^ self browseVersions]. - aChar == $C ifTrue: [^ model showHomeCategory]. - aChar == $O ifTrue: [^ self openSingleMessageBrowser]. - aChar == $x ifTrue: [^ model removeMessage]. - aChar == $t ifTrue: [^ model runMethodTest]. - aChar == $r ifTrue: [^ model debugMethodTest]. - aChar == $R ifTrue: [^ self renameSelector]] - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3828-CuisCore-HernanWilkinson-2019Jul17-17h45m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3826] on 14 July 2019 at 3:54:15 pm'! -!DirectoryEntry class methodsFor: 'instance creation' stamp: 'jmv 7/14/2019 15:49:59' prior: 50406639! - currentDirectory - "Answer the current directory. - - In Unix it is the current directory in the OS shell that started us. - In Windows the same happens if the image file is in a subree of the Windows current directory. - - But it defaults to the directory in wich this Smalltalk image was started (or last saved) if this fails - (this usually happens, for example, if the image is dropped on the VM in a Windows explorer). - See #getCurrentWorkingDirectory - - DirectoryEntry currentDirectory - " - - CurrentDirectory ifNil: [ - CurrentDirectory _ Smalltalk getCurrentWorkingDirectory - ifNotNil: [ :wd | self withPathName: wd ] - ifNil: [ (self withPathName: Smalltalk imagePath) parent ]]. - ^ CurrentDirectory! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -DirectoryEntry releaseClassCachedState! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3829-CurrentDirectoryFix-JuanVuletich-2019Jul14-15h49m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3829] on 1 August 2019 at 11:18:12 am'! -!MouseEvent methodsFor: 'button state' stamp: 'jmv 8/1/2019 10:45:48'! - turnMouseButton1Into2 - "Answer true if modifier keys are such that button 1 should be considered as button 2. - ctrl - click -> right click - " - - (self controlKeyPressed and: [self shiftPressed not]) ifTrue: [ ^ true ]. - ^ false! ! -!MouseEvent methodsFor: 'button state' stamp: 'jmv 8/1/2019 11:01:35'! - turnMouseButton1Into3 - "Answer true if modifier keys are such that button 1 should be considered as button 3. - ctrl - shift - click -> center click - alt -> click -> center click (effective only on Windows, - the vm on Mac already reports center click, and on Linux right click) - " - - (self controlKeyPressed and: [self shiftPressed]) ifTrue: [ ^ true ]. - self commandAltKeyPressed ifTrue: [ ^ true ]. - ^ false! ! -!MouseEvent methodsFor: 'button state' stamp: 'jmv 8/1/2019 11:14:36' prior: 50405073! - mouseButton1Pressed - "Answer true if the mouseButton1 is being pressed. - Reported by the VM for the single/first mouse button, usually the one at the left. - But if they are combined with modifier keys, it is might button 2 or 3. - See mouseButton2Pressed and mouseButton3Pressed. - See also #mouseButton1Changed" - - self turnMouseButton1Into2 ifTrue: [ ^ false ]. - self turnMouseButton1Into3 ifTrue: [ ^ false ]. - ^ buttons anyMask: InputSensor mouseButton1! ! -!MouseEvent methodsFor: 'button state' stamp: 'jmv 8/1/2019 11:12:43' prior: 50405088! - mouseButton2Pressed - "Answer true if the mouseButton2 is being pressed. - Reported by the VM for right mouse button or option+click on the Mac, ctrl-click on Windows, or ctrl-click or alt-click on Linux. - It is also emulated here with ctrl-click on any platform." - - (self turnMouseButton1Into2 and: [ buttons anyMask: InputSensor mouseButton1 ]) - ifTrue: [ ^ true ]. - ^ buttons anyMask: InputSensor mouseButton2! ! -!MouseEvent methodsFor: 'button state' stamp: 'jmv 8/1/2019 11:12:08' prior: 50405103! - mouseButton3Pressed - "Answer true if the mouseButton3 is being pressed. - Reported by the VM for center (wheel) mouse button or cmd+click on the Mac or win/meta+click on Windows and Linux. - It is also emulated here with shift-ctrl-click on any platform." - - (self turnMouseButton1Into3 and: [ buttons anyMask: InputSensor mouseButton1 ]) - ifTrue: [ ^ true ]. - ^ buttons anyMask: InputSensor mouseButton3! ! -!MouseButtonEvent methodsFor: 'accessing' stamp: 'jmv 8/1/2019 11:14:43' prior: 50405119! - mouseButton1Changed - "Answer true if the mouseButton1 has changed. - Reported by the VM for the single/first mouse button, usually the one at the left. - But if they are combined with modifier keys, it is might button 2 or 3. - See mouseButton1Changed and mouseButton3Changed. - The check for button change (instead of button press) is specially useful on buttonUp events. - See also #mouseButton1Pressed" - - self turnMouseButton1Into2 ifTrue: [ ^ false ]. - self turnMouseButton1Into3 ifTrue: [ ^ false ]. - ^ whichButton anyMask: InputSensor mouseButton1! ! -!MouseButtonEvent methodsFor: 'accessing' stamp: 'jmv 8/1/2019 11:12:49' prior: 50405136! - mouseButton2Changed - "Answer true if the mouseButton2 has changed. - Reported by the VM for right mouse button or option+click on the Mac. - It is also emulated here with ctrl-click on any platform. - The check for button change (instead of button press) is specially useful on buttonUp events." - - (self turnMouseButton1Into2 and: [ whichButton anyMask: InputSensor mouseButton1 ]) - ifTrue: [ ^ true ]. - ^ whichButton anyMask: InputSensor mouseButton2! ! -!MouseButtonEvent methodsFor: 'accessing' stamp: 'jmv 8/1/2019 11:12:33' prior: 50405154! - mouseButton3Changed - "Answer true if the mouseButton3 has changed. - Reported by the VM for center (wheel) mouse button or cmd+click on the Mac or meta+click on Linux. - It is also emulated here with shift-ctrl-click on any platform. - The check for button change (instead of button press) is specially useful on buttonUp events." - - (self turnMouseButton1Into3 and: [ whichButton anyMask: InputSensor mouseButton1 ]) - ifTrue: [ ^ true ]. - ^ whichButton anyMask: InputSensor mouseButton3! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3830-makeCtrlClickMeanButton2OnMac-JuanVuletich-2019Aug01-10h25m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3830] on 2 August 2019 at 9:27:45 am'! -!BoxedFloat64 methodsFor: 'testing' stamp: 'jmv 8/1/2019 16:42:44'! - isFinite - "simple, byte-order independent test for rejecting Not-a-Number and (Negative)Infinity" - - ^(self - self) = 0.0! ! -!BoxedFloat64 methodsFor: 'testing' stamp: 'jmv 8/1/2019 16:42:00'! -isInfinite - "Return true if the receiver is positive or negative infinity." - - ^ self = Infinity or: [self = NegativeInfinity]! ! -!BoxedFloat64 methodsFor: 'testing' stamp: 'jmv 8/1/2019 16:39:56'! - isNaN - "simple, byte-order independent test for Not-a-Number" - - ^ self ~= self! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 8/1/2019 16:59:41' prior: 50465152! - arTanh - "Answer receiver's area hyperbolic tangent. - That is the inverse function of tanh." - - self = 0.0 ifTrue: [^self]. "Handle negativeZero" - self = 1 ifTrue: [^ Float infinity]. - self = -1 ifTrue: [^Float negativeInfinity]. - self abs > 1 ifTrue: [^ Float nan]. - ^((1 + self) / (1 - self)) ln / 2! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 8/1/2019 17:02:16' prior: 16844737! - sinh - "Answer receivers hyperbolic sine" - - | ex | - ex _ self abs exp. - ^ (ex - ex reciprocal) / 2 * self sign! ! -!Float methodsFor: 'testing' stamp: 'jmv 8/1/2019 16:43:28' prior: 50418717! - isFinite - "Infinities and Not a Number are only represented as BoxedFloat64" - - ^ true! ! -!Float methodsFor: 'testing' stamp: 'jmv 8/2/2019 09:22:50' prior: 16845083! - isInfinite - "Infinities are only represented as BoxedFloat64" - - ^ false -! ! -!Float methodsFor: 'testing' stamp: 'jmv 8/1/2019 16:40:18' prior: 16845099! - isNaN - "Not a Number are only represented as BoxedFloat64" - - ^ false! ! -!BoxedFloat64 methodsFor: 'truncation and round off' stamp: 'jmv 8/1/2019 18:39:12' prior: 50417887! - exponent - "Primitive. Consider the receiver to be represented as a power of two - multiplied by a mantissa between one and two or between -1 and -2 (#significand). - Answer with the SmallInteger to whose power two is raised. - Optional. See Object documentation whatIsAPrimitive. - Note: invalid for infinities, NaN and zero. - See also #signPart, #significandAsInteger and #exponentPart - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. f significand . f exponent. f significand * (2 raisedToInteger: f exponent) = f } print ]. - " - - | positive | - - self >= 1.0 ifTrue: [^self floorLog: 2]. - self > 0.0 - ifTrue: - [positive _ (1.0 / self) exponent. - self = (1.0 / (1.0 timesTwoPower: positive)) - ifTrue: [^positive negated] - ifFalse: [^positive negated - 1]]. - self = 0.0 ifTrue: [^-1]. - ^self negated exponent! ! -!SmallFloat64 methodsFor: 'truncation and round off' stamp: 'jmv 8/1/2019 18:39:17' prior: 50414587! - exponent - "Primitive. Consider the receiver to be represented as a power of two - multiplied by a mantissa between one and two (#significand). - Answer with the SmallInteger to whose power two is raised. - Optional. See Object documentation whatIsAPrimitive. - Note: invalid for infinities, NaN and zero. - See comment at BoxedFloat64" - - | positive | - - self >= 1.0 ifTrue: [^self floorLog: 2]. - self > 0.0 - ifTrue: - [positive _ (1.0 / self) exponent. - self = (1.0 / (1.0 timesTwoPower: positive)) - ifTrue: [^positive negated] - ifFalse: [^positive negated - 1]]. - self = 0.0 ifTrue: [^-1]. - ^self negated exponent! ! -!Duration class methodsFor: 'squeak protocol' stamp: 'jmv 8/1/2019 16:57:21' prior: 16836217! - readFrom: aStream - "Formatted as per ANSI 5.8.2.16: [-]D:HH:MM:SS[.S]" - - | sign days hours minutes seconds nanos nanosBuffer | - sign := (aStream peekFor: $-) ifTrue: [-1] ifFalse: [1]. - days := (aStream upTo: $:) asInteger * sign. - hours := (aStream upTo: $:) asInteger * sign. - minutes := (aStream upTo: $:) asInteger * sign. - seconds := (aStream upTo: $.) asInteger * sign. - nanosBuffer := '000000000' copy. - nanos := WriteStream on: nanosBuffer. - [aStream atEnd not and: [aStream peek isDigit]] - whileTrue: [nanos nextPut: aStream next]. - - ^ self - days: days - hours: hours - minutes: minutes - seconds: seconds - nanoSeconds: (nanosBuffer asInteger * sign) - - " '0:00:00:00' asDuration - '0:00:00:00.000000001' asDuration - '0:00:00:00.999999999' asDuration - '0:00:00:00.100000000' asDuration - '0:00:00:00.001 ' asDuration - '0:00:00:00.1' asDuration - '0:00:00:01 ' asDuration - '0:12:45:45' asDuration - '1:00:00:00' asDuration - '365:00:00:00' asDuration - '-7:09:12:06.10' asDuration - '+0:01:02:3' asDuration - "! ! - -Float removeSelector: #sign:! - -Float removeSelector: #sign:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3831-FloatCleanup-JuanVuletich-2019Aug02-09h15m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3830] on 2 August 2019 at 11:49:09 am'! -!BoxedFloat64 methodsFor: 'arithmetic' stamp: 'jmv 8/2/2019 11:02:05'! - arg - "Compatibility with Complex numbers." - self isNaN ifTrue: [^self]. - ^super arg! ! -!BoxedFloat64 methodsFor: 'arithmetic' stamp: 'jmv 8/2/2019 11:02:02'! - argument - "Compatibility with Complex numbers." - self isNaN ifTrue: [^self]. - ^super argument! ! -!BoxedFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 8/1/2019 19:23:08'! - raisedTo: exponent - "Answer the receiver raised to aNumber." - - self isNaN ifTrue: [ ^self ]. - ^super raisedTo: exponent! ! -!BoxedFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 8/2/2019 10:36:02'! - raisedToInteger: exponent - "Answer the receiver raised to aNumber." - - self isNaN ifTrue: [ ^self ]. - ^super raisedToInteger: exponent! ! -!BoxedFloat64 methodsFor: 'testing' stamp: 'jmv 8/1/2019 16:53:05'! - sign - "Answer 1 if the receiver is greater than 0, -1 if less than 0, else 0." - - self isNaN ifTrue: [ self error: 'Can not handle Not-a-Number' ]. - ^super sign! ! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 8/1/2019 19:23:05' prior: 50466071! -raisedTo: exponent - "Answer the receiver raised to aNumber." - - exponent isInteger ifTrue: [ - "Do the special case of integer power" - ^ self raisedToInteger: exponent]. - exponent isFraction ifTrue: [ - "Special case for fraction power by Nicolas Cellier: - If aNumber is a fraction, but result must be a Float, learn it as quickly as possible, and give quick Float answer - Allows evaluating: - (2009/2000) raisedTo: (3958333/100000) - " - ^ self raisedToFraction: exponent]. - self < 0 ifTrue: [ - ^NegativePowerError new signalReceiver: self selector: #raisedTo: argument: exponent]. - 0.0 = exponent ifTrue: [^ self class one]. "Special case of exponent=0" - 1.0 = exponent ifTrue: [^ self]. "Special case of exponent=1" - 0 = self ifTrue: [ "Special case of self = 0" - exponent isNaN ifTrue: [ ^exponent ]. - ^exponent < 0 - ifTrue: [(self raisedTo: exponent negated) reciprocal] - ifFalse: [self]]. - ^ (exponent * self ln) exp "Otherwise use logarithms"! ! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 8/2/2019 09:47:02' prior: 50466103! - raisedToFraction: aFraction - "Raise an exception if argument is not a Fraction" - aFraction denominator = 2 ifTrue: [ - ^ self sqrt raisedToInteger: aFraction numerator ]. - self isZero ifTrue: [ - aFraction negative ifTrue: [^ (self raisedToFraction: aFraction negated) reciprocal]. - ^ self ]. - self negative ifFalse: [ - ^ (self ln * aFraction) exp ]. - (self negative and: [ aFraction denominator even ]) ifTrue: [ - ^NegativePowerError new signalReceiver: self selector: #raisedToFraction: argument: aFraction]. - ^ (self negated ln * aFraction) exp negated! ! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 8/2/2019 11:47:20' prior: 50460972! - raisedToInteger: exponent - "The 0 raisedToInteger: 0 is an special case. In some contexts must be 1 and in others must - be handled as an indeterminate form. - Maybe further discussion is required on this topic." - - | bitProbe result | - - exponent negative ifTrue: [^self raisedToNegativeInteger: exponent ]. - exponent = 0 ifTrue: [^ self class one]. - exponent = 1 ifTrue: [^ self]. - - bitProbe := 1 bitShift: exponent highBit - 1. - result := self class one. - [ - (exponent bitAnd: bitProbe) = 0 ifFalse: [result := result * self]. - bitProbe := bitProbe bitShift: -1. - bitProbe > 0 ] - whileTrue: [ - result := result * result]. - ^result! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 8/2/2019 10:46:33' prior: 50450985! -arcTan: denominator - "Answer the angle in radians. - Implementation note: use sign in order to catch cases of negativeZero" - - self isNaN ifTrue: [ ^self ]. - denominator isNaN ifTrue: [ ^denominator class nan ]. "if Complex, answer complex nan" - ^self = 0.0 - ifTrue: [denominator sign >= 0 - ifTrue: [ 0.0 ] - ifFalse: [ self sign >= 0 - ifTrue: [ Pi ] - ifFalse: [ Pi negated ]]] - ifFalse: [denominator = 0.0 - ifTrue: [self > 0.0 - ifTrue: [ Halfpi ] - ifFalse: [ Halfpi negated ]] - ifFalse: [denominator > 0.0 - ifTrue: [ (self / denominator) arcTan ] - ifFalse: [self > 0.0 - ifTrue: [ ((self / denominator) arcTan) + Pi ] - ifFalse: [ ((self / denominator) arcTan) - Pi ]]]]! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 8/2/2019 10:49:29' prior: 16844618! - copySignTo: aNumber - "Return a number with same magnitude as aNumber and same sign as self. - Implementation note: take care of Float negativeZero, which is considered as having a negative sign." - - self isNaN ifTrue: [ ^self ]. - (self > 0.0 or: [(self at: 1) = 0]) ifTrue: [^ aNumber abs]. - ^aNumber withNegativeSign! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 8/1/2019 18:32:12' prior: 50412257! - smoothStep - "A Function that is - x <= -1 -> 1 - -1 < x < 1 -> smooth differentiable transition from 1 to 0 - 1 <= x -> 0 - - It is a 'smooth' version of an #negative - Has countless applications. For example in image and signal processing, but also in other fields." - " - | g | - Feature require: 'Morphic-Widgets-Extras'. - g _ FunctionGraphMorph new. - g domain: (-4 to: 4). - g addFunction: [ :x | x abs < 1 ifTrue: [1] ifFalse:[0] ] color: Color brown. - g addFunction: [ :x | x smoothStep ] color: Color red. - (g embeddedInMorphicWindowLabeled: 'graph') openInWorld - " - self isNaN ifTrue: [ ^self ]. - self > -1 ifFalse: [ ^ 1 ]. - 1 > self ifFalse: [ ^ 0 ]. - ^ (self +2 * Float halfPi) sin * 0.5 + 0.5! ! -!BoxedFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 8/1/2019 19:10:12' prior: 16790782! - timesTwoPower: anInteger - "Primitive. Answer with the receiver multiplied by 2 raised to the power of the argument. - Optional. See Object documentation whatIsAPrimitive." - - - anInteger isInteger ifFalse: [ ^DomainError signal: '#timesTwoPower: only defined for Integer argument.']. - self isFinite ifFalse: [^self]. - self isZero ifTrue: [^self]. - - "Make sure that (2.0 raisedTo: Integer) can be safely used without overflow - For example: - Float fminNormalized * (2.0 raisedTo: 2000) = Float infinity. - while: - (Float fminNormalized timesTwoPower: 2000) = (2.0 raisedTo: 2000+Float emin)." - anInteger > Float emax ifTrue: [^(self timesTwoPower: Float emax) timesTwoPower: anInteger - Float emax]. - - "In case of gradual underflow, timesTwoPower: is not exact, so greatest care must be taken - because two consecutive timesTwoPower: might differ from a single one" - anInteger < Float emin - ifTrue: [ - | deltaToUnderflow | - deltaToUnderflow := Float emin - self exponent max: Float emin. - deltaToUnderflow >= 0 ifTrue: [ - "self is already near or past underflow, so don't care, result will be zero" - deltaToUnderflow := Float emin]. - ^(self timesTwoPower: deltaToUnderflow) timesTwoPower: anInteger - deltaToUnderflow]. - - "If (2.0 raisedToInteger: anInteger) fit in a positive SmallInteger, then use faster SmallInteger conversion. - Note that SmallInteger maxVal highBit = 30 in a 32 bits image, so 1 can be shifted 29 times." - anInteger > -29 ifTrue: [ - anInteger < 0 ifTrue: [^ self / (1 bitShift: (0 - anInteger)) asFloat]. - anInteger < 30 ifTrue: [^ self * (1 bitShift: anInteger) asFloat]]. - - ^ self * (2.0 raisedToInteger: anInteger)! ! -!BoxedFloat64 methodsFor: 'truncation and round off' stamp: 'jmv 8/2/2019 09:34:43' prior: 16790863! - truncated - "Answer with a SmallInteger equal to the value of the receiver without - its fractional part. The primitive fails if the truncated value cannot be - represented as a SmallInteger. In that case, the code below will compute - a LargeInteger truncated value. - Raise an exception if no conversion to integer is possible, i.e. for Infinities and NaN. - Essential. See Object documentation whatIsAPrimitive. " - - - - ^ self partValues: [ :sign :exponent :mantissa | - sign * (mantissa bitShift: exponent - 52) ]! ! -!SmallFloat64 methodsFor: 'mathematical functions' stamp: 'jmv 8/1/2019 19:10:21' prior: 16908447! - timesTwoPower: anInteger - "Primitive. Answer with the receiver multiplied by 2 raised to the power of the argument. - Optional. See Object documentation whatIsAPrimitive." - - - anInteger isInteger ifFalse: [ ^DomainError signal: '#timesTwoPower: only defined for Integer argument.']. - self isFinite ifFalse: [^self]. - self isZero ifTrue: [^self]. - - "Make sure that (2.0 raisedTo: Integer) can be safely used without overflow - For example: - Float fminNormalized * (2.0 raisedTo: 2000) = Float infinity. - while: - (Float fminNormalized timesTwoPower: 2000) = (2.0 raisedTo: 2000+Float emin)." - anInteger > Float emax ifTrue: [^(self timesTwoPower: Float emax) timesTwoPower: anInteger - Float emax]. - - "In case of gradual underflow, timesTwoPower: is not exact, so greatest care must be taken - because two consecutive timesTwoPower: might differ from a single one" - anInteger < Float emin - ifTrue: [ - | deltaToUnderflow | - deltaToUnderflow := Float emin - self exponent max: Float emin. - deltaToUnderflow >= 0 ifTrue: [ - "self is already near or past underflow, so don't care, result will be zero" - deltaToUnderflow := Float emin]. - ^(self timesTwoPower: deltaToUnderflow) timesTwoPower: anInteger - deltaToUnderflow]. - - "If (2.0 raisedToInteger: anInteger) fit in a positive SmallInteger, then use faster SmallInteger conversion. - Note that SmallInteger maxVal highBit = 30 in a 32 bits image, so 1 can be shifted 29 times." - anInteger > -29 ifTrue: [ - anInteger < 0 ifTrue: [^ self / (1 bitShift: (0 - anInteger)) asFloat]. - anInteger < 30 ifTrue: [^ self * (1 bitShift: anInteger) asFloat]]. - - ^ self * (2.0 raisedToInteger: anInteger)! ! -!SmallFloat64 methodsFor: 'truncation and round off' stamp: 'jmv 8/2/2019 09:34:46' prior: 16908530! - truncated - "Answer with a SmallInteger equal to the value of the receiver without - its fractional part. The primitive fails if the truncated value cannot be - represented as a SmallInteger. In that case, the code below will compute - a LargeInteger truncated value. - Raise an exception if no conversion to integer is possible, i.e. for Infinities and NaN. - Essential. See Object documentation whatIsAPrimitive. " - - - - ^ self partValues: [ :sign :exponent :mantissa | - sign * (mantissa bitShift: exponent - 52) ]! ! -!Fraction methodsFor: 'mathematical' stamp: 'jmv 8/2/2019 10:07:49' prior: 16849624! - reciprocal - "Refer to the comment in Number|reciprocal." - - ^denominator / numerator! ! -!Fraction methodsFor: 'mathematical functions' stamp: 'jmv 8/2/2019 09:47:13' prior: 50465337! - raisedToFraction: aFraction - "Raise an exception if argument is not a Fraction" - | root | - aFraction denominator = 2 ifTrue: [ - ^ self sqrt raisedToInteger: aFraction numerator ]. - (self negative and: [ aFraction denominator even ]) ifTrue: [ - ^NegativePowerError new signalReceiver: self selector: #raisedToFraction: argument: aFraction]. - root _ (self numerator nthRootTruncated: aFraction denominator) / - (self denominator nthRootTruncated: aFraction denominator). - (root raisedToInteger: aFraction denominator) = self ifTrue: [ - ^ root raisedToInteger: aFraction numerator ]. - ^ super raisedToFraction: aFraction! ! -!Fraction methodsFor: 'mathematical functions' stamp: 'jmv 8/2/2019 10:05:14' prior: 16849711! - raisedToInteger: anInteger - "See Number | raisedToInteger:" - "Raise an exception if argument is not a anInteger" - - ^ (numerator raisedToInteger: anInteger) / (denominator raisedToInteger: anInteger)! ! -!Integer methodsFor: 'arithmetic' stamp: 'jmv 8/1/2019 17:26:46' prior: 50465370! - // aNumber - | q | - aNumber = 0 ifTrue: [^ ZeroDivide new signalReceiver: self selector: #// argument: aNumber]. - aNumber isInteger ifFalse: [ ^super // aNumber ]. - self = 0 ifTrue: [^ 0]. - q _ self quo: aNumber. - "Refer to the comment in Number>>#//." - ^(q negative - ifTrue: [q * aNumber ~= self] - ifFalse: [q = 0 and: [self negative ~= aNumber negative]]) - ifTrue: [q - 1"Truncate towards minus infinity."] - ifFalse: [q]! ! -!Integer methodsFor: 'mathematical functions' stamp: 'jmv 8/2/2019 10:56:57' prior: 50465440! - nthRoot: aPositiveInteger - "Answer the nth root of the receiver. - Answer an Integer if root is exactly this Integer, else answer the Float nearest the exact root." - - | guess excess scaled nBits | - aPositiveInteger = 2 ifTrue: [ - ^ self sqrt ]. - - (aPositiveInteger isInteger not or: [ aPositiveInteger negative ]) - ifTrue: [^ DomainError signal: 'nth root only defined for positive Integer n.']. - - self = 0 ifTrue: [ ^0 ]. - - (self negative and: [ aPositiveInteger even ]) ifTrue: [ - ^ NegativePowerError new signalReceiver: self selector: #nthRoot: argument: aPositiveInteger ]. - - guess _ self nthRootRounded: aPositiveInteger. - excess _ (guess raisedTo: aPositiveInteger) - self. - excess = 0 ifTrue: [ ^ guess ]. - - nBits _ Float precision - guess highBitOfMagnitude. - nBits <= 0 ifTrue: [ ^(Fraction numerator: guess * 4 - excess sign denominator: 4) asFloat]. - - scaled _ self << (nBits * aPositiveInteger). - guess _ scaled nthRootRounded: aPositiveInteger. - excess _ (guess raisedTo: aPositiveInteger) - scaled. - ^(Fraction numerator: guess * 4 - excess sign denominator: 1 << (nBits + 2)) asFloat! ! -!Integer methodsFor: 'mathematical functions' stamp: 'jmv 8/2/2019 09:47:05' prior: 50465542! - raisedToFraction: aFraction - "Raise an exception if argument is not a Fraction" - | root | - aFraction denominator = 2 ifTrue: [ - ^ self sqrt raisedToInteger: aFraction numerator ]. - self = 0 ifTrue: [ ^0 ]. - (self negative and: [ aFraction denominator even ]) ifTrue: [ - ^NegativePowerError new signalReceiver: self selector: #raisedToFraction: argument: aFraction]. - root _ self nthRootTruncated: aFraction denominator. - (root raisedToInteger: aFraction denominator) = self ifTrue: [ - ^ root raisedToInteger: aFraction numerator ]. - ^ super raisedToFraction: aFraction! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3832-NaNpropagationFixes-JuanVuletich-2019Aug02-09h27m-jmv.2.cs.st----! - -'From Cuis 5.0 [latest update: #3826] on 3 August 2019 at 9:21:49 am'! -!Behavior methodsFor: 'accessing method dictionary' stamp: 'HAW 8/3/2019 09:16:52'! - highestClassImplementing: aSelector ifNone: aNoneBlock - - | highestImplementorClass | - - self withAllSuperclassesDo: [ :aBehavior | (aBehavior includesSelector: aSelector) ifTrue: [ highestImplementorClass := aBehavior ]]. - - ^ highestImplementorClass ifNil: aNoneBlock ! ! -!ChangeSelector class methodsFor: 'implementors and senders' stamp: 'HAW 8/3/2019 09:13:18' prior: 50438857! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inHierarchyOf: aClass doingPerClass: aBlock - - | highestClassImplementingOldSelector | - - highestClassImplementingOldSelector := aClass highestClassImplementing: anOldSelector ifNone: [ aClass ]. - highestClassImplementingOldSelector theNonMetaClass withAllSubAndSuperclassesDo: [ :aPotentialClassToRefactor | - aPotentialClassToRefactor isMeta ifFalse: [ - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders forClassAndMetaOf: aPotentialClassToRefactor. - aBlock value: aPotentialClassToRefactor ]] - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3833-HierarchyScopeRenameFix-HernanWilkinson-2019Jul19-08h20m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3826] on 5 August 2019 at 10:56:29 am'! -!Debugger methodsFor: 'private' stamp: 'jmv 8/5/2019 10:51:08' prior: 50430029! - contextStackIndex: anInteger oldContextWas: oldContext - "Change the context stack index to anInteger, perhaps in response to user selection." - - | isNewMethod selectedContextSlotName index | - contextStackIndex _ anInteger. - anInteger = 0 ifTrue: [ - currentCompiledMethod _ nil. - self changed: #contextStackIndex. - self acceptedContentsChanged. - contextVariablesInspector object: nil. - self fixReceiverInspector. - ^ self ]. - selectedContextSlotName _ contextVariablesInspector selectedSlotName. - isNewMethod _ oldContext == nil - or: [ oldContext method ~~ (currentCompiledMethod _ self selectedContext method) ]. - isNewMethod ifTrue: [ - self acceptedContentsChanged. - self pcRange ]. - self changed: #contextStackIndex. - self triggerEvent: #decorateButtons. - contextVariablesInspector object: self selectedContext. - ((index _ contextVariablesInspector fieldList indexOf: selectedContextSlotName) ~= 0 and: [ - index ~= contextVariablesInspector selectionIndex ]) ifTrue: [ - contextVariablesInspector toggleIndex: index ]. - self fixReceiverInspector. - isNewMethod ifFalse: [ self changed: #contentsSelection ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3834-contextStackIndexoldContextWas-hadLostSourceCode-JuanVuletich-2019Aug05-10h47m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3826] on 3 August 2019 at 12:15:41 am'! -!Boolean methodsFor: 'testing' stamp: 'jpb 8/3/2019 00:11:00'! - is: aSymbol - ^#Boolean = aSymbol or: [ super is: aSymbol ]! ! -!Number methodsFor: 'testing' stamp: 'jpb 8/2/2019 23:58:01'! - is: aSymbol - "Note: Senders might prefer #isNumber for perfomance reasons. Still, Cuis tries to keep isXXX testing selectors to a minimum." - ^#Number = aSymbol or: [ super is: aSymbol]! ! -!Fraction methodsFor: 'testing' stamp: 'jpb 8/3/2019 00:08:08'! - is: aSymbol - "Note: Senders might prefer #isFraction for perfomance reasons. Still, Cuis tries to keep isXXX testing selectors to a minimum." - ^#Fraction = aSymbol or: [ super is: aSymbol ]! ! -!Integer methodsFor: 'testing' stamp: 'jpb 8/2/2019 23:58:43'! -is: aSymbol - "Note: Senders might prefer #isInteger for perfomance reasons. Still, Cuis tries to keep isXXX testing selectors to a minimum." - ^#Integer = aSymbol or: [ super is: aSymbol ]! ! -!Collection methodsFor: 'testing' stamp: 'jpb 8/2/2019 23:59:42'! - is: aSymbol - "Note: Senders might prefer #isCollection for perfomance reasons. Still, Cuis tries to keep isXXX testing selectors to a minimum." - ^#Collection = aSymbol or: [ super is: aSymbol ]! ! -!String methodsFor: 'testing' stamp: 'jpb 8/3/2019 00:01:22'! - is: aSymbol - "Note: Senders might prefer #isString for perfomance reasons. Still, Cuis tries to keep isXXX testing selectors to a minimum." - ^#String = aSymbol or: [ super is: aSymbol]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3835-Additional-is-methods-JosefPhilipBernhart-2019Aug02-23h58m-jpb.1.cs.st----! - -'From Cuis 5.0 [latest update: #3832] on 4 August 2019 at 10:07:59 pm'! -!Debugger methodsFor: 'accessing' stamp: 'HAW 8/4/2019 22:06:34' prior: 16829568! -contents: aText notifying: aController - "The retrieved information has changed and its source must now be updated. - In this case, the retrieved information is the method of the selected context." - - | result selector classOfMethod category h ctxt newMethod | - - contextStackIndex = 0 ifTrue: [^false]. - - classOfMethod := self selectedClass. - category := self selectedMessageCategoryName. - selector :=self selectedClass parserClass selectorFrom: aText. - - selector ~= self selectedMessageName ifTrue: [ - self inform: 'Can not change the selector in the debugger'. - ^false]. - (classOfMethod = UndefinedObject and: [ selector = Scanner doItSelector or: [ selector = Scanner doItInSelector ]]) ifTrue: [ - self inform: 'DoIt and DoItIn: methods can not be changed'. - ^false]. - - self selectedContext isExecutingBlock ifTrue: [ - h := self selectedContext activeHome. - h ifNil: [ - self inform: 'Method for block not found on stack, can''t edit and continue'. - ^false]. - (self confirm: 'I will have to revert to the method from\which this block originated. Is that OK?' withNewLines) ifFalse: [^false]. - self resetContext: h. - (result := self contents: aText notifying: aController) ifTrue: [self acceptedContentsChanged]. - ^result]. - - selector := classOfMethod - compile: aText - classified: category - notifying: aController. - selector ifNil: [^false]. "compile cancelled" - newMethod := classOfMethod compiledMethodAt: selector. - - newMethod isQuick ifTrue: [ - contextStackIndex + 1 > contextStack size ifTrue: [ - self inform: 'Can not compile a quick method in the stack base context'. - ^false]. - self down. - self selectedContext jump: (self selectedContext previousPc - self selectedContext pc)]. - - ctxt := interruptedProcess popTo: self selectedContext. - ctxt == self selectedContext - ifFalse: - [self inform: 'Method saved, but current context unchanged\because of unwind error. Click OK to see error' withNewLines] - ifTrue: - [newMethod isQuick ifFalse: - [interruptedProcess - restartTopWith: newMethod; - stepToSendOrReturn]. - contextVariablesInspector object: nil]. - self resetContext: ctxt. - ^true! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3836-ChangeSelectorOrDoitInDebugger-HernanWilkinson-2019Aug04-18h56m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3836] on 5 August 2019 at 3:35:31 pm'! -!ChangeSelector class methodsFor: 'implementors and senders' stamp: 'HAW 8/5/2019 15:35:03' prior: 50468296! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inHierarchyOf: aClass doingPerClass: aBlock - - | highestClassImplementingOldSelector | - - highestClassImplementingOldSelector := aClass highestClassImplementing: anOldSelector ifNone: [ aClass ]. - highestClassImplementingOldSelector theNonMetaClass withAllSubclassesDo: [ :aPotentialClassToRefactor | - aPotentialClassToRefactor isMeta ifFalse: [ - self addImplementorsOf: anOldSelector to: implementors andSendersTo: senders forClassAndMetaOf: aPotentialClassToRefactor. - aBlock value: aPotentialClassToRefactor ]] - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3837-RenameSelectorHierarchyFix-HernanWilkinson-2019Aug05-15h35m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3837] on 5 August 2019 at 4:25:51 pm'! -!CodeWindow methodsFor: 'keyboard shortcuts' stamp: 'EB 5/9/2019 16:00:27' prior: 50467439! - messageListKey: aChar from: view - "Respond to a Command key. I am a model with a code pane, and I also - have a listView that has a list of methods. The view knows how to get - the list and selection." - - | sel class | - aChar == $D ifTrue: [^ model toggleDiffing]. - - sel _ model selectedMessageName. - aChar == $m ifTrue: [ "These next two put up a type in if no message selected" - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllImplementorsOf: to: Smalltalk]. - aChar == $n ifTrue: [ - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllCallsOn: to: Smalltalk]. - - "The following require a class selection" - (class _ model selectedClassOrMetaClass) ifNil: [^ self ]. - aChar == $b ifTrue: [^ BrowserWindow fullOnClass: class selector: sel]. - aChar == $N ifTrue: [^ self browseClassRefs]. - aChar == $i ifTrue: [^ self methodHierarchy]. - aChar == $h ifTrue: [^ self browseHierarchy]. - aChar == $p ifTrue: [^ self browseFullProtocol]. - - sel - ifNotNil: [ - "The following require a method selection" - aChar == $o ifTrue: [^ model fileOutMessage]. - aChar == $c ifTrue: [^ model copySelector]. - aChar == $v ifTrue: [^ self browseVersions]. - aChar == $C ifTrue: [^ model showHomeCategory]. - aChar == $O ifTrue: [^ self openSingleMessageBrowser]. - aChar == $x ifTrue: [^ model removeMessage]. - aChar == $t ifTrue: [^ model runMethodTest]. - aChar == $r ifTrue: [^ model debugMethodTest]. - aChar == $R ifTrue: [^ self renameSelector]] - ifNil: [ - aChar == $R ifTrue: [^ model renameClass]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3838-RenameMessageHotKeyFix-HernanWilkinson-2019Aug05-16h23m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3838] on 6 August 2019 at 8:37:30 am'! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 8/6/2019 08:36:15' prior: 50402050! - setBalloonText: stringTextOrSymbol - "Set receiver's balloon help text. Pass nil to remove the help." - - stringTextOrSymbol - ifNil: [ self removeProperty: #balloonText ] - ifNotNil: [ - self - setProperty: #balloonText - toValue: stringTextOrSymbol string ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3839-fixABadIsSender-JuanVuletich-2019Aug06-08h35m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3839] on 11 August 2019 at 11:41:15 pm'! -!CompiledMethod methodsFor: 'decompiling' stamp: 'HAW 8/11/2019 22:36:12'! - selectorAndArgumentsAsString - - ^self methodNode selectorAndArgumentsAsString ! ! -!MethodNode methodsFor: 'printing' stamp: 'HAW 8/11/2019 23:38:22'! - ifPrimitivePrintOn: aStream - - primitive > 0 ifTrue: - [(primitive between: 255 and: 519) ifFalse: "Dont decompile quick prims e.g, ^ self or ^instVar" - [aStream newLineTab: 1. - self printPrimitiveOn: aStream]]. -! ! -!MethodNode methodsFor: 'printing' stamp: 'HAW 8/11/2019 23:37:02'! - printCommentOn: aStream - - comment ifNotNil: [ - aStream newLineTab: 1. - self printCommentOn: aStream indent: 1].! ! -!MethodNode methodsFor: 'printing' stamp: 'HAW 8/11/2019 22:34:14'! - printSelectorAndArgumentsOn: aStream - - | selectorNode | - - selectorNode _ self selectorNode. - precedence = 1 - ifTrue: - [selectorNode isForFFICall - ifTrue: [selectorNode - printAsFFICallWithArguments: arguments - on: aStream - indent: 0] - ifFalse: [aStream nextPutAll: selectorNode key]] - ifFalse: - [selectorNode key keywords withIndexDo: - [:kwd :i | | arg | - arg _ arguments at: i. - i = 1 ifFalse: [ aStream space ]. - aStream nextPutAll: kwd; space; nextPutAll: arg key ]]. -! ! -!MethodNode methodsFor: 'printing' stamp: 'HAW 8/11/2019 23:37:36'! - printTemporariesOn: aStream - - block printTemporaries: temporaries on: aStream doPrior: [aStream newLineTab: 1]. -! ! -!MethodNode methodsFor: 'printing' stamp: 'HAW 8/11/2019 22:34:14'! - selectorAndArgumentsAsString - - ^String streamContents: [ :aStream | self printSelectorAndArgumentsOn: aStream ]! ! -!MethodNode methodsFor: 'printing' stamp: 'HAW 8/11/2019 23:39:17' prior: 16872740! - printOn: aStream - - self - printSelectorAndArgumentsOn: aStream; - printCommentOn: aStream; - printTemporariesOn: aStream; - ifPrimitivePrintOn: aStream; - printPropertiesOn: aStream; - printPragmasOn: aStream. - - aStream newLineTab: 1. - block printStatementsOn: aStream indent: 0! ! - -MethodNode removeSelector: #printSelectorOn:! - -MethodNode removeSelector: #selectorAsString! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3840-MethodNodePrintOnRefactoring-HernanWilkinson-2019Aug11-21h52m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3839] on 17 August 2019 at 11:24:04 am'! -!RenameSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/17/2019 11:17:16'! - openChangeSelectorSendersStepWindow - - ChangeSelectorSendersStepWindow openFrom: self ! ! -!ChangeSelectorImplementorsStepWindow methodsFor: 'actions' stamp: 'HAW 8/17/2019 11:23:47' prior: 50438361! - seeSenders - - self changeImplementors. - self delete. - - "Necesary indirection to support actual senders in LiveTyping - Hernan" - applier openChangeSelectorSendersStepWindow! ! -!AddInstanceVariable methodsFor: 'applying' stamp: 'HAW 8/16/2019 11:24:02' prior: 50438522! - apply - - classToRefactor addInstVarName: newVariable. - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3841-RenameSenderWindowIndirection-HernanWilkinson-2019Aug13-19h10m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3839] on 17 August 2019 at 12:35:37 pm'! -!ChangeSelectorKeepingParameters methodsFor: 'rename senders - private' stamp: 'HAW 8/17/2019 12:29:38'! - addRangesOf: oldSelectorKeywordsRanges to: rangesToKeywords - - oldSelectorKeywordsRanges do: [ :aMessageSendSelectorRanges | - aMessageSendSelectorRanges withIndexDo: [ :aRange :index | rangesToKeywords add: aRange -> (newSelectorKeywords at: index) ]]. - - - ! ! -!ChangeSelectorKeepingParameters methodsFor: 'rename senders - private' stamp: 'HAW 8/17/2019 12:29:21' prior: 50447622! - addMessageSendSelectorKeywordRangesOf: aMethodNode to: rangesToKeywords - - | oldSelectorKeywordsRanges | - - oldSelectorKeywordsRanges := aMethodNode messageSendSelectorKeywordPositionsOf: oldSelector ifAbsent: [ #() ]. - self addRangesOf: oldSelectorKeywordsRanges to: rangesToKeywords. - - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3842-RenameSelectorRefactoring-HernanWilkinson-2019Aug17-11h24m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3839] on 19 August 2019 at 6:19:21 am'! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 8/17/2019 16:17:55'! - withMessageSendKeywordPositionsOf: aSelector do: aMessageSendNodeBlock ifAbsent: aBlock - - | positions sortedPositions | - - positions := sourceRanges keys - select: [ :aParseNode | aParseNode isMessageNamed: aSelector ] - thenCollect: aMessageSendNodeBlock. - - positions isEmpty ifTrue: [ ^aBlock value ]. - sortedPositions := positions asSortedCollection. - - ^sortedPositions ! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 8/19/2019 05:37:27'! - ifChangeSelectorCanBeAppliedDo: aBlock - - ^(self hasUnacceptedEdits or: [morph hasEditingConflicts ]) - ifTrue: [ self inform: 'Rename, Add Parameter and Remove Parameter can not be applied when there are unsaved changes' ] - ifFalse: aBlock! ! -!SmalltalkEditor methodsFor: 'contextual add parameter' stamp: 'HAW 8/19/2019 05:39:02'! - addParameter: aNodeUnderCursor in: aSelectedClass at: aSelectedSelector - - self ifChangeSelectorCanBeAppliedDo: [ - aNodeUnderCursor isMessageNode - ifTrue: [ self addParameterOf: aNodeUnderCursor in: aSelectedClass at: aSelectedSelector ] - ifFalse: [ morph flash ]] -! ! -!SmalltalkEditor methodsFor: 'contextual add parameter' stamp: 'HAW 8/19/2019 05:43:57'! - addParameterOf: aMessageNode in: aSelectedClass at: aSelectedSelector - - RefactoringApplier addParameterApplier - createAndValueHandlingExceptionsOn: model textProvider - of: aMessageNode - in: aSelectedClass - at: aSelectedSelector! ! -!SmalltalkEditor methodsFor: 'contextual add parameter' stamp: 'HAW 8/19/2019 05:47:11'! - addParameterTo: aSelector in: aClassToRefactor - - RefactoringApplier addParameterApplier - createAndValueHandlingExceptionsOn: model textProvider - for: aSelector - in: aClassToRefactor ! ! -!SmalltalkEditor methodsFor: 'contextual add parameter' stamp: 'HAW 8/18/2019 20:55:50'! - contextualAddParameter - - self isEditingClassDefinition - ifTrue: [ morph flash ] - ifFalse: [ self contextualAddParameterInMethod ]! ! -!SmalltalkEditor methodsFor: 'contextual add parameter' stamp: 'HAW 8/18/2019 20:54:15'! - contextualAddParameter: aKeyboardEvent - - self contextualAddParameter. - ^true! ! -!SmalltalkEditor methodsFor: 'contextual add parameter' stamp: 'HAW 8/18/2019 20:56:07'! - contextualAddParameterInMethod - - self - withMethodNodeAndClassDo: [ :methodNode :selectedClass | self contextualAddParameterOf: methodNode in: selectedClass] - ifErrorsParsing: [ :anError | morph flash ] ! ! -!SmalltalkEditor methodsFor: 'contextual add parameter' stamp: 'HAW 8/19/2019 05:36:00'! - contextualAddParameterOf: aMethodNode in: aSelectedClass - - aMethodNode - withParseNodeIncluding: self startIndex - do: [ :nodeUnderCursor | self addParameter: nodeUnderCursor in: aSelectedClass at: aMethodNode selector ] - ifAbsent: [ - self startIndex <= aMethodNode selectorLastPosition - ifTrue: [ self ifChangeSelectorCanBeAppliedDo: [ self addParameterTo: aMethodNode selector in: aSelectedClass ]] - ifFalse: [ morph flash ]] -! ! -!SmalltalkEditor methodsFor: 'contextual remove parameter' stamp: 'HAW 8/19/2019 05:50:19'! - contextualRemoveParameter - - self isEditingClassDefinition - ifTrue: [ morph flash ] - ifFalse: [ self contextualRemoveParameterInMethod ]! ! -!SmalltalkEditor methodsFor: 'contextual remove parameter' stamp: 'HAW 8/19/2019 05:49:23'! - contextualRemoveParameter: aKeyboardEvent - - self contextualRemoveParameter. - ^true! ! -!SmalltalkEditor methodsFor: 'contextual remove parameter' stamp: 'HAW 8/19/2019 05:50:49'! - contextualRemoveParameterInMethod - - self - withMethodNodeAndClassDo: [ :methodNode :selectedClass | self contextualRemoveParameterOf: methodNode in: selectedClass] - ifErrorsParsing: [ :anError | morph flash ]! ! -!SmalltalkEditor methodsFor: 'contextual remove parameter' stamp: 'HAW 8/19/2019 05:51:33'! - contextualRemoveParameterOf: aMethodNode in: aSelectedClass - - aMethodNode - withParseNodeIncluding: self startIndex - do: [ :nodeUnderCursor | self removeParameter: nodeUnderCursor in: aSelectedClass at: aMethodNode selector ] - ifAbsent: [ - self startIndex <= aMethodNode selectorLastPosition - ifTrue: [ self ifChangeSelectorCanBeAppliedDo: [ self removeParameterTo: aMethodNode selector in: aSelectedClass ]] - ifFalse: [ morph flash ]] -! ! -!SmalltalkEditor methodsFor: 'contextual remove parameter' stamp: 'HAW 8/19/2019 05:52:50'! - removeParameter: aNodeUnderCursor in: aSelectedClass at: aSelectedSelector - - self ifChangeSelectorCanBeAppliedDo: [ - aNodeUnderCursor isMessageNode - ifTrue: [ self removeParameterOf: aNodeUnderCursor in: aSelectedClass at: aSelectedSelector ] - ifFalse: [ morph flash ]] -! ! -!SmalltalkEditor methodsFor: 'contextual remove parameter' stamp: 'HAW 8/19/2019 05:53:28'! - removeParameterOf: aMessageNode in: aSelectedClass at: aSelectedSelector - - RefactoringApplier removeParameterApplier - createAndValueHandlingExceptionsOn: model textProvider - of: aMessageNode - in: aSelectedClass - at: aSelectedSelector! ! -!SmalltalkEditor methodsFor: 'contextual remove parameter' stamp: 'HAW 8/19/2019 05:55:27'! - removeParameterTo: aSelector in: aClassToRefactor - - RefactoringApplier removeParameterApplier - createAndValueHandlingExceptionsOn: model textProvider - for: aSelector - in: aClassToRefactor ! ! -!AddParameter methodsFor: 'rename senders - private' stamp: 'HAW 8/17/2019 16:37:49'! - addKeywordRangesForLastPositionOf: aMethodNode using: insertionPoints to: rangesToKeywords - - | originalSourceCode | - - originalSourceCode := aMethodNode sourceText. - insertionPoints do: [ :aPosition | | newPosition | - newPosition := self firstNoSeparatorIndexIn: originalSourceCode startingFrom: aPosition. - rangesToKeywords add: ((newPosition+1) to: newPosition) -> senderTrailingString ]! ! -!AddParameter methodsFor: 'rename senders - private' stamp: 'HAW 8/17/2019 16:38:39'! - addKeywordRangesUsing: insertionPoints to: rangesToKeywords - - insertionPoints do: [ :aPosition | - rangesToKeywords add: (aPosition to: aPosition-1) -> senderTrailingString ] -! ! -!AddParameter methodsFor: 'rename senders - private' stamp: 'HAW 8/17/2019 15:57:54'! - messageSendKeywordPositionsIn: aMethodNode - - ^aMethodNode messageSendKeywordPositionsAt: index of: oldSelector ifAbsent: [ #()].! ! -!AddParameter methodsFor: 'rename senders - private' stamp: 'HAW 8/17/2019 15:58:04'! - messageSendLastPositionIn: aMethodNode - - ^aMethodNode messageSendLastPositionsOf: oldSelector ifAbsent: [ #() ].! ! -!ChangeSelectorKeepingParameters methodsFor: 'rename senders - private' stamp: 'HAW 8/17/2019 15:59:10'! - messageSendSelectorKeywordPositionsIn: aMethodNode - - ^aMethodNode messageSendSelectorKeywordPositionsOf: oldSelector ifAbsent: [ #() ].! ! -!RemoveParameter methodsFor: 'rename senders - private' stamp: 'HAW 8/18/2019 12:11:04'! - keywordAndParameterPositionsIn: aMethodNode - - ^aMethodNode messageSendKeywordAndParameterPositionsAt: parameterIndex of: oldSelector ifAbsent: [ #() ].! ! -!RefactoringApplier class methodsFor: 'appliers - registering' stamp: 'HAW 8/18/2019 20:02:30'! - registerAddParameterApplier: anAddParameterApplierClass - - self registerApplierAt: self addParameterApplierId with: anAddParameterApplierClass ! ! -!RefactoringApplier class methodsFor: 'appliers - registering' stamp: 'HAW 8/18/2019 20:03:28'! - registerRemoveParameterApplier: aRemoveParameterApplierClass - - self registerApplierAt: self removeParameterApplierId with: aRemoveParameterApplierClass ! ! -!RefactoringApplier class methodsFor: 'appliers - getting' stamp: 'HAW 8/18/2019 19:59:32'! - addParameterApplier - - ^self applierAt: self addParameterApplierId ifAbsent: [ AddParameterApplier ]! ! -!RefactoringApplier class methodsFor: 'appliers - getting' stamp: 'HAW 8/18/2019 20:16:16'! - removeParameterApplier - - ^self applierAt: self removeParameterApplierId ifAbsent: [ RemoveParameterApplier ]! ! -!RefactoringApplier class methodsFor: 'appliers - id' stamp: 'HAW 8/18/2019 20:00:08'! - addParameterApplierId - - ^#addParameterApplier! ! -!RefactoringApplier class methodsFor: 'appliers - id' stamp: 'HAW 8/18/2019 20:00:21'! - removeParameterApplierId - - ^#removeParameterApplier! ! -!RefactoringApplier class methodsFor: 'appliers - id' stamp: 'HAW 8/18/2019 20:01:09'! - renameSelectorApplierId - - ^#renameSelectorApplier! ! -!RefactoringApplier class methodsFor: 'appliers - resetting' stamp: 'HAW 8/18/2019 20:04:34'! - resetAddParameterApplier - - self resetApplierAt: self addParameterApplierId! ! -!RefactoringApplier class methodsFor: 'appliers - resetting' stamp: 'HAW 8/18/2019 20:16:43'! - resetRemoveParameterApplier - - self resetApplierAt: self removeParameterApplierId ! ! -!RefactoringApplier class methodsFor: 'appliers - private' stamp: 'HAW 8/18/2019 19:55:48'! - applierAt: anApplierId ifAbsent: absentBlock - - ^Appliers - at: anApplierId - ifPresent: [ :anApplierName | Smalltalk classNamed: anApplierName ] - ifAbsent: absentBlock ! ! -!RefactoringApplier class methodsFor: 'appliers - private' stamp: 'HAW 8/18/2019 20:03:03'! - registerApplierAt: anApplierId with: anApplierClass - - Appliers at: anApplierId put: anApplierClass name ! ! -!RefactoringApplier class methodsFor: 'appliers - private' stamp: 'HAW 8/18/2019 20:04:48'! - resetApplierAt: anApplierId - - Appliers removeKey: anApplierId ifAbsent: []! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/17/2019 22:18:41'! - createImplementors - - ^IdentitySet new.! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/17/2019 22:19:08'! - createSenders - - ^IdentitySet new. -! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/17/2019 22:41:27'! - openChangeSelectorSendersStepWindow - - ChangeSelectorSendersStepWindow openFrom: self ! ! -!ChangeSelectorApplier class methodsFor: 'instance creation' stamp: 'HAW 8/17/2019 22:30:43'! - createAndValueHandlingExceptionsOn: aModel for: anOldSelector in: aClassToRefactor - - self createAndValueHandlingExceptions: [ self on: aModel for: anOldSelector in: aClassToRefactor ]! ! -!AddParameterApplier class methodsFor: 'instance creation' stamp: 'HAW 8/19/2019 05:42:49'! - createAndValueHandlingExceptionsOn: aModel of: aMessageNode in: aSelectedClass at: aSelectedSelector - - ^self createAndValueHandlingExceptionsOn: aModel for: aMessageNode selector key in: aSelectedClass -! ! -!RemoveParameterApplier class methodsFor: 'instance creation' stamp: 'HAW 8/19/2019 05:43:07'! - createAndValueHandlingExceptionsOn: aModel of: aMessageNode in: aSelectedClass at: aSelectedSelector - - ^self createAndValueHandlingExceptionsOn: aModel for: aMessageNode selector key in: aSelectedClass -! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 8/17/2019 16:18:44' prior: 50443380! - messageSendKeywordPositionsAt: anIndex of: aSelector ifAbsent: absentBlock - - ^self - withMessageSendKeywordPositionsOf: aSelector - do: [ :aMessageSendNode | (aMessageSendNode keywordPositionAt: anIndex) first ] - ifAbsent: absentBlock - ! ! -!Encoder methodsFor: 'source mapping' stamp: 'HAW 8/17/2019 16:19:39' prior: 50443396! - messageSendLastPositionsOf: aSelector ifAbsent: absentBlock - - ^self - withMessageSendKeywordPositionsOf: aSelector - do: [ :aMessageSendNode | (sourceRanges at: aMessageSendNode) last ] - ifAbsent: absentBlock - ! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 8/19/2019 05:35:49' prior: 50452414! - contextualRenameInClassDefinition - - self ifChangeSelectorCanBeAppliedDo: [ - self - withClassDefinitionNodeAndClassDo: [ :classDefinitionNode :selectedClass | self contextualRenameInClassDefinitionOf: classDefinitionNode in: selectedClass] - ifErrorsParsing: [ :anError | morph flash ] ]! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 8/19/2019 05:35:49' prior: 50450188! - contextualRenameOf: aMethodNode in: aSelectedClass - - aMethodNode - withParseNodeIncluding: self startIndex - do: [ :nodeUnderCursor | self rename: nodeUnderCursor in: aSelectedClass at: aMethodNode selector ] - ifAbsent: [ - self startIndex <= aMethodNode selectorLastPosition - ifTrue: [ self ifChangeSelectorCanBeAppliedDo: [ self renameSelectorFor: aMethodNode selector in: aSelectedClass ]] - ifFalse: [ morph flash ]] - - -! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 8/19/2019 05:35:49' prior: 50450770! - rename: aNodeUnderCursor in: aSelectedClass at: aSelectedSelector - - aNodeUnderCursor isTempOrArg ifTrue: [ ^self renameTemporary: aNodeUnderCursor name ]. - - self ifChangeSelectorCanBeAppliedDo: [ - aNodeUnderCursor isMessageNode ifTrue: [ ^ self renameSelectorOf: aNodeUnderCursor in: aSelectedClass at: aSelectedSelector ]. - aNodeUnderCursor isInstanceVariableNode ifTrue: [ ^ self renameInstanceVariableOn: self codeProvider for: aNodeUnderCursor name at: aSelectedClass ]. - aNodeUnderCursor isLiteralVariableNode ifTrue: [ | variableName | - variableName := aNodeUnderCursor key key. - (Smalltalk classNamed: variableName) ifNotNil: [ :classToRename | ^self renameClassOn: self codeProvider for: classToRename ]. - (Smalltalk bindingOf: variableName) ifNotNil: [ ^self renameGlobalOn: self codeProvider for: variableName ] ]. - - ^morph flash ]! ! -!CodeWindow methodsFor: 'keyboard shortcuts' stamp: 'HAW 8/19/2019 06:04:39' prior: 50468534! - messageListKey: aChar from: view - "Respond to a Command key. I am a model with a code pane, and I also - have a listView that has a list of methods. The view knows how to get - the list and selection." - - | sel class | - aChar == $D ifTrue: [^ model toggleDiffing]. - - sel _ model selectedMessageName. - aChar == $m ifTrue: [ "These next two put up a type in if no message selected" - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllImplementorsOf: to: Smalltalk]. - aChar == $n ifTrue: [ - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllCallsOn: to: Smalltalk]. - - "The following require a class selection" - (class _ model selectedClassOrMetaClass) ifNil: [^ self ]. - aChar == $b ifTrue: [^ BrowserWindow fullOnClass: class selector: sel]. - aChar == $N ifTrue: [^ self browseClassRefs]. - aChar == $i ifTrue: [^ self methodHierarchy]. - aChar == $h ifTrue: [^ self browseHierarchy]. - aChar == $p ifTrue: [^ self browseFullProtocol]. - - sel - ifNotNil: [ - "The following require a method selection" - aChar == $o ifTrue: [^ model fileOutMessage]. - aChar == $c ifTrue: [^ model copySelector]. - aChar == $v ifTrue: [^ self browseVersions]. - aChar == $C ifTrue: [^ model showHomeCategory]. - aChar == $O ifTrue: [^ self openSingleMessageBrowser]. - aChar == $x ifTrue: [^ model removeMessage]. - aChar == $t ifTrue: [^ model runMethodTest]. - aChar == $r ifTrue: [^ model debugMethodTest]. - aChar == $R ifTrue: [^ self renameSelector]. - aChar == $U ifTrue: [^ self addParameter ]. - aChar == $I ifTrue: [^ self removeParameter ]] - ifNil: [ - aChar == $R ifTrue: [^ model renameClass]]! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 8/18/2019 20:37:30' prior: 50443830! - addParameter - - model selectedMessageName ifNotNil: [ :oldSelector | - RefactoringApplier addParameterApplier createAndValueHandlingExceptionsOn: model for: oldSelector in: model selectedClassOrMetaClass ]! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 8/18/2019 20:29:17' prior: 50443889! - removeParameter - - model selectedMessageName ifNotNil: [ :oldSelector | - RefactoringApplier removeParameterApplier createAndValueHandlingExceptionsOn: model for: oldSelector in: model selectedClassOrMetaClass ]. - - ! ! -!ChangeSelectorSendersStepWindow methodsFor: 'actions' stamp: 'HAW 8/18/2019 11:46:24' prior: 50438443! - seeImplementors - - self delete. - - ChangeSelectorImplementorsStepWindow openFrom: applier! ! -!AddParameter methodsFor: 'rename senders - private' stamp: 'HAW 8/17/2019 16:38:25' prior: 50438928! - addMessageSendSelectorKeywordRangesOf: aMethodNode to: rangesToKeywords - - | insertionPoints | - - isAddingLast - ifTrue: [ - insertionPoints := self messageSendLastPositionIn: aMethodNode. - self addKeywordRangesForLastPositionOf: aMethodNode using: insertionPoints to: rangesToKeywords ] - ifFalse: [ - insertionPoints := self messageSendKeywordPositionsIn: aMethodNode. - self addKeywordRangesUsing: insertionPoints to: rangesToKeywords ]! ! -!ChangeSelectorKeepingParameters methodsFor: 'rename senders - private' stamp: 'HAW 8/17/2019 15:58:57' prior: 50468728! - addMessageSendSelectorKeywordRangesOf: aMethodNode to: rangesToKeywords - - | oldSelectorKeywordsRanges | - - oldSelectorKeywordsRanges := self messageSendSelectorKeywordPositionsIn: aMethodNode. - self addRangesOf: oldSelectorKeywordsRanges to: rangesToKeywords. - - ! ! -!RemoveParameter methodsFor: 'rename senders - private' stamp: 'HAW 8/18/2019 12:10:48' prior: 50439588! - addMessageSendSelectorKeywordRangesOf: aMethodNode to: rangesToKeywords - - | keywordAndParameterPositions senderSourceCode | - - senderSourceCode := aMethodNode sourceText. - keywordAndParameterPositions := self keywordAndParameterPositionsIn: aMethodNode. - keywordAndParameterPositions do: [ :aKeywordAndParameterPosition | | lastPosition | - lastPosition := self lastSeparatorIndexIn: senderSourceCode startingFrom: aKeywordAndParameterPosition last. - rangesToKeywords add: (aKeywordAndParameterPosition first to: lastPosition) -> senderReplacementString ] - ! ! -!RefactoringApplier class methodsFor: 'appliers - registering' stamp: 'HAW 8/18/2019 20:03:49' prior: 50450115! - registerRenameSelectorApplier: aRenameSelectorApplierClass - - self registerApplierAt: self renameSelectorApplierId with: aRenameSelectorApplierClass ! ! -!RefactoringApplier class methodsFor: 'appliers - getting' stamp: 'HAW 8/18/2019 20:01:43' prior: 50450122! - renameSelectorApplier - - ^self applierAt: self renameSelectorApplierId ifAbsent: [ RenameSelectorApplier ]! ! -!RefactoringApplier class methodsFor: 'appliers - resetting' stamp: 'HAW 8/18/2019 20:15:33' prior: 50450131! - resetRenameSelectorApplier - - self resetApplierAt: self renameSelectorApplierId ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 8/17/2019 22:19:01' prior: 50450137! - initializeImplementorsAndSenders - - implementors := self createImplementors. - senders := self createSenders! ! -!RefactoringMenues class methodsFor: 'editor menus' stamp: 'HAW 8/18/2019 20:51:47' prior: 50459622! - smalltalkEditorMenuOptions - - ^`{ - { - #itemGroup -> 35. - #itemOrder -> 10. - #label -> 'Rename... (R)'. - #selector -> #contextualRename. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 20. - #label -> 'Add Parameter... (U)'. - #selector -> #contextualAddParameter. - #icon -> #listAddIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 30. - #label -> 'Remove Parameter... (I)'. - #selector -> #contextualRemoveParameter. - #icon -> #listRemoveIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 40. - #label -> 'Temporary to Instance Variable (O)'. - #selector -> #temporaryToInstanceVariable. - #icon -> #saveAsIcon - } asDictionary. - - }`! ! -!RefactoringMenues class methodsFor: 'shortcuts' stamp: 'HAW 8/19/2019 06:12:02' prior: 50459639! - smalltalkEditorCmdShortcutsSpec - - ^#( - #( $R #contextualRename: 'Renames what is under cursor') - #( $U #contextualAddParameter: 'Adds parameter to message that is under cursor') - #( $I #contextualRemoveParameter: 'Removes parameter to message that is under cursor') - #( $O #temporaryToInstanceVariable: 'Extracts temporary variable to instance variable')) -! ! - -RenameSelectorApplier class removeSelector: #createAndValueHandlingExceptionsOn:for:in:! - -RenameSelectorApplier class removeSelector: #createAndValueHandlingExceptionsOn:for:in:! - -RenameSelectorApplier removeSelector: #openChangeSelectorSendersStepWindow! - -RenameSelectorApplier removeSelector: #openChangeSelectorSendersStepWindow! - -ChangeSelectorApplier removeSelectorIfInBaseSystem: #sendersFrom:! - -ChangeSelectorApplier removeSelector: #sendersFrom:! - -AddParameter removeSelector: #messageSendKeywordPositionsOf:! - -AddParameter removeSelector: #messageSendLastPositionOf:! - -ChangeSelectorSendersStepWindow removeSelector: #changeRequestSenders! - -ChangeSelectorSendersStepWindow removeSelector: #changeRequestSenders! - -ChangeSelectorSendersStepWindow removeSelector: #refactor! - -ChangeSelectorSendersStepWindow removeSelector: #refactor! - -SmalltalkEditor removeSelector: #ifRenameCanBeAppliedDo:! - -SmalltalkEditor removeSelector: #ifRenameCanBeAppliedDo:! - -"Postscript: -Initializes editor shortcuts" -Editor initialize. -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3843-RefactoringsRefactoring-HernanWilkinson-2019Aug17-12h36m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3843] on 19 August 2019 at 1:15:38 pm'! -!SmalltalkEditor methodsFor: 'contextual add/remove parameter' stamp: 'HAW 8/19/2019 12:32:23'! - changeSelector: aNodeUnderCursor in: aSelectedClass at: aSelectedSelector using: aChangeSelectorApplier - - aNodeUnderCursor isMessageNode - ifTrue: [ self changeSelectorOf: aNodeUnderCursor in: aSelectedClass at: aSelectedSelector using: aChangeSelectorApplier ] - ifFalse: [ morph flash ] -! ! -!SmalltalkEditor methodsFor: 'contextual add/remove parameter' stamp: 'HAW 8/19/2019 12:32:54'! - changeSelectorOf: aMessageNode in: aSelectedClass at: aSelectedSelector using: aChangeSelectorApplier - - aChangeSelectorApplier - createAndValueHandlingExceptionsOn: model textProvider - of: aMessageNode - in: aSelectedClass - at: aSelectedSelector! ! -!SmalltalkEditor methodsFor: 'contextual add/remove parameter' stamp: 'HAW 8/19/2019 12:33:40'! - changeSelectorTo: aSelector in: aClassToRefactor using: aChangeSelectorApplier - - aChangeSelectorApplier - createAndValueHandlingExceptionsOn: model textProvider - for: aSelector - in: aClassToRefactor ! ! -!SmalltalkEditor methodsFor: 'contextual add/remove parameter' stamp: 'HAW 8/19/2019 12:30:16'! - contextualChangeSelectorInMethodUsing: aChangeSelectorApplier - - self - withMethodNodeAndClassDo: [ :methodNode :selectedClass | self contextualChangeSelectorOf: methodNode in: selectedClass using: aChangeSelectorApplier ] - ifErrorsParsing: [ :anError | morph flash ] ! ! -!SmalltalkEditor methodsFor: 'contextual add/remove parameter' stamp: 'HAW 8/19/2019 12:31:37'! - contextualChangeSelectorOf: aMethodNode in: aSelectedClass using: aChangeSelectorApplier - - aMethodNode - withParseNodeIncluding: self startIndex - do: [ :nodeUnderCursor | self changeSelector: nodeUnderCursor in: aSelectedClass at: aMethodNode selector using: aChangeSelectorApplier ] - ifAbsent: [ - self startIndex <= aMethodNode selectorLastPosition - ifTrue: [ self changeSelectorTo: aMethodNode selector in: aSelectedClass using: aChangeSelectorApplier ] - ifFalse: [ morph flash ]] -! ! -!SmalltalkEditor methodsFor: 'contextual add/remove parameter' stamp: 'HAW 8/19/2019 12:29:50'! - contextualChangeSelectorUsing: aChangeSelectorApplier - - self isEditingClassDefinition - ifTrue: [ morph flash ] - ifFalse: [ self ifChangeSelectorCanBeAppliedDo: [ self contextualChangeSelectorInMethodUsing: aChangeSelectorApplier ]]! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 8/19/2019 12:22:15'! - changeKeywordOrder - - model selectedMessageName ifNotNil: [ :oldSelector | - ChangeKeywordsSelectorOrderApplier createAndValueHandlingExceptions: [ - ChangeKeywordsSelectorOrderApplier on: model for: oldSelector in: model selectedClassOrMetaClass ]].! ! -!SmalltalkEditor methodsFor: 'contextual add/remove parameter' stamp: 'HAW 8/19/2019 12:34:29' prior: 50468805! - contextualAddParameter - - self contextualChangeSelectorUsing: RefactoringApplier addParameterApplier ! ! -!SmalltalkEditor methodsFor: 'contextual add/remove parameter' stamp: 'HAW 8/19/2019 13:14:32' prior: 50468846! - contextualRemoveParameter - - self contextualChangeSelectorUsing: RefactoringApplier removeParameterApplier ! ! -!SmalltalkEditor methodsFor: 'contextual add/remove parameter' stamp: 'HAW 8/19/2019 13:15:03' prior: 50468854! - contextualRemoveParameter: aKeyboardEvent - - self contextualRemoveParameter. - ^true! ! - -CodeWindow removeSelector: #changeKeywordOrder! - -CodeWindow removeSelector: #changeKeywordOrder! - -SmalltalkEditor removeSelector: #addParameter:in:at:! - -SmalltalkEditor removeSelector: #addParameter:in:at:! - -SmalltalkEditor removeSelector: #addParameterOf:in:at:! - -SmalltalkEditor removeSelector: #addParameterOf:in:at:! - -SmalltalkEditor removeSelector: #addParameterOf:in:at:using:! - -SmalltalkEditor removeSelector: #addParameterTo:in:! - -SmalltalkEditor removeSelector: #addParameterTo:in:! - -SmalltalkEditor removeSelector: #contextualAddParameterInMethod! - -SmalltalkEditor removeSelector: #contextualAddParameterInMethod! - -SmalltalkEditor removeSelector: #contextualAddParameterOf:in:! - -SmalltalkEditor removeSelector: #contextualAddParameterOf:in:! - -SmalltalkEditor removeSelector: #contextualRemoveParameterInMethod! - -SmalltalkEditor removeSelector: #contextualRemoveParameterInMethod! - -SmalltalkEditor removeSelector: #contextualRemoveParameterOf:in:! - -SmalltalkEditor removeSelector: #contextualRemoveParameterOf:in:! - -SmalltalkEditor removeSelector: #removeParameter:in:at:! - -SmalltalkEditor removeSelector: #removeParameter:in:at:! - -SmalltalkEditor removeSelector: #removeParameterOf:in:at:! - -SmalltalkEditor removeSelector: #removeParameterOf:in:at:! - -SmalltalkEditor removeSelector: #removeParameterTo:in:! - -SmalltalkEditor removeSelector: #removeParameterTo:in:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3844-ContextualAddRemoveParameterRefactoring-HernanWilkinson-2019Aug19-06h48m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3843] on 21 August 2019 at 9:20:26 am'! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'HAW 8/21/2019 00:20:09'! - addAllSubclassesTo: allSubclasses - - self subclassesDo: [ :aSubclass | - allSubclasses add: aSubclass. - aSubclass addAllSubclassesTo: allSubclasses ]! ! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'HAW 8/21/2019 09:16:33' prior: 16783550! - allSubclasses - "Answer a Set of the receiver, the receiver's descendent's, and the - receiver's descendent's subclasses." - - | allSubclasses | - - allSubclasses := OrderedCollection new. - self addAllSubclassesTo: allSubclasses. - - ^allSubclasses ! ! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'HAW 8/21/2019 09:16:38' prior: 16783643! - withAllSubclasses - "Answer a Set of the receiver, the receiver's descendent's, and the - receiver's descendent's subclasses." - - | allSubclasses | - - allSubclasses := OrderedCollection with: self. - self addAllSubclassesTo: allSubclasses. - - ^allSubclasses ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3845-allSubclassesImprovement-HernanWilkinson-2019Aug20-19h44m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3826] on 16 August 2019 at 5:44:37 pm'! -!PluggableListMorph methodsFor: 'keyboard navigation' stamp: 'jpb 8/16/2019 17:34:29'! - deleteAction - "Handles deleting action, which happens when the user presses backspace or delete key within me" - | deleteActionBlock | - deleteActionBlock _ self valueOfProperty: #deleteAction ifAbsent: [ nil ]. - deleteActionBlock isNil - ifTrue: [ self flash ] - ifFalse: [ deleteActionBlock value ]. - ^self! ! -!PluggableListMorph methodsFor: 'events' stamp: 'jpb 8/16/2019 17:27:02' prior: 50449278! - keyStroke: aKeyboardEvent - "Process keys" - | aCharacter | - (self focusKeyboardFor: aKeyboardEvent) ifTrue: [ ^ self ]. - - (self arrowKey: aKeyboardEvent) ifNotNil: [ ^ self ]. - - aKeyboardEvent isEsc ifTrue: [ " escape key" ^ self mouseButton2Activity ]. - aKeyboardEvent isDelete ifTrue: [ "delete key" ^ self deleteAction ]. - aKeyboardEvent isBackspace ifTrue: [ "backspace key" ^ self deleteAction ]. - - aCharacter _ aKeyboardEvent keyCharacter. - - aKeyboardEvent anyModifierKeyPressed - ifTrue: [ - (self keystrokeAction: aCharacter) - ifTrue: [ ^self ]]. - ^ self keyboardSearch: aCharacter! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'jpb 8/16/2019 16:46:40' prior: 50414823! - isBackspace - "Returns true if the pressed key is a backspace key. In Text Editors, pressing backspace usually means to delete the character before the cursor position" - ^ keyValue = 8! ! -!KeyboardEvent methodsFor: 'testing' stamp: 'jpb 8/16/2019 16:47:15' prior: 50460268! - isDelete - "Returns true on the delete key, which is not the same as the backspace key. In Text Editors, it usually means to delete the character after the cursor" - ^keyValue = 127 ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3846-DeleteActioninPluggableListMorph-JosefPhilipBernhart-2019Aug16-16h39m-jpb.1.cs.st----! - -'From Cuis 5.0 [latest update: #3840] on 21 August 2019 at 12:30:57 pm'! -!CPUWatcher methodsFor: 'startup-shutdown' stamp: 'pb 8/21/2019 12:23:45' prior: 16795059! - monitorProcessPeriod: secs sampleRate: msecs suspendPorcine: aBoolean - | delay | - self stopMonitoring. - watcher _ [ - delay _ Delay forMilliseconds: msecs truncated. - [ | thisTally | - thisTally _ IdentityBag new: 20. - secs * 1000 // msecs timesRepeat: [ - delay wait. - thisTally add: Processor nextReadyProcess ]. - tally _ thisTally. - aBoolean ifTrue: [ self findThePig ]] repeat ] newProcess. - watcher - priority: Processor highestPriority; - name: 'CPUWatcher monitor'; - resume. - Processor yield.! ! -!ProcessBrowser methodsFor: 'initialization' stamp: 'pb 8/21/2019 12:16:40' prior: 16895080! - startCPUWatcher - "Answers whether I started the CPUWatcher" - - CPUWatcher isMonitoring ifFalse: [ - CPUWatcher startMonitoringPeriod: 1 rate: 25 threshold: 0.85 suspendPorcine: false. - ^true - ]. - ^false -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3847-CPUWatcher-fix-PhilBellalouna-2019Aug21-11h57m-pb.1.cs.st----! - -'From Cuis 5.0 [latest update: #3846] on 22 August 2019 at 3:48:21 pm'! -!ChangeSelectorWizardStepWindow class methodsFor: 'instance creation' stamp: 'HAW 8/22/2019 15:41:07'! - openFrom: aChangeSelectorApplier methods: methods label: aLabel selecting: somethingToSelect - - | window | - - window := self openMessageList: (self methodReferencesOf: methods) label: aLabel autoSelect: somethingToSelect. - window initializeFrom: aChangeSelectorApplier. - - ^window - -! ! -!ChangeSelectorImplementorsStepWindow class methodsFor: 'instance creation' stamp: 'HAW 8/22/2019 15:41:48' prior: 50438394! - openFrom: aChangeSelectorApplier - - ^self - openFrom: aChangeSelectorApplier - methods: aChangeSelectorApplier implementors - label: 'Implementors of #', aChangeSelectorApplier oldSelector, ' to Refactor' - selecting: nil -! ! -!ChangeSelectorSendersStepWindow class methodsFor: 'instance creation' stamp: 'HAW 8/22/2019 15:41:39' prior: 50438476! - openFrom: aChangeSelectorApplier - - ^self - openFrom: aChangeSelectorApplier - methods: aChangeSelectorApplier senders - label: 'Senders of #', aChangeSelectorApplier oldSelector, ' to Refactor' - selecting: aChangeSelectorApplier oldSelector ! ! - -ChangeSelectorWizardStepWindow class removeSelector: #openFrom:methods:label:! - -ChangeSelectorWizardStepWindow class removeSelector: #openFrom:methods:label:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3848-RenameImplementorsSelection-HernanWilkinson-2019Aug22-11h43m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3840] on 22 August 2019 at 12:10:43 pm'! -!Morph methodsFor: 'geometry' stamp: 'pb 8/22/2019 12:08:01' prior: 16875445! - morphPosition: aPoint - "Change the position of this morph. Argument is in owner's coordinates." - (location isTranslation: aPoint) ifTrue: [ "Null change" - ^ self ]. - "Invalidate the rectangle at the old position..." - self redrawNeeded. - location _ location withTranslation: aPoint. - "... and the new position" - self redrawNeeded. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3849-morphPosition-comment-PhilBellalouna-2019Aug22-12h07m-pb.1.cs.st----! - -----SNAPSHOT----(23 August 2019 10:05:41) Cuis5.0-3849-v3.image priorSource: 4342467! - -----QUIT----(23 August 2019 10:06:08) Cuis5.0-3849-v3.image priorSource: 4420400! - -----STARTUP---- (6 September 2019 11:34:07) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-3849-v3.image! - - -'From Cuis 5.0 [latest update: #3846] on 23 August 2019 at 3:54:52 pm'! -!TestSuite class methodsFor: 'instance creation - private' stamp: 'HAW 8/23/2019 15:53:43' prior: 50444336! - forClasses: classes named: aName - - | testMethods suite classTests tests testMethod | - - "I don't want repeated tests. TestCase does not redefine #= so instead of redefining it and use a Set - I decided to keep the related tests methods in a different set and decide to add it or note base on that - - Hernan" - - testMethods := IdentitySet new. - tests := OrderedCollection new. - - classes do: [ :aClass | - classTests := (self forClass: aClass) tests. - classTests do: [ :aTest | - testMethod := aTest methodForTest. - (testMethods includes: testMethod) ifFalse: [ - testMethods add: testMethod. - tests add: aTest ]]]. - - suite := self named: aName. - suite addTests: tests. - - ^suite - -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3850-AvoidRepeatedTests-HernanWilkinson-2019Aug23-10h11m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3850] on 24 August 2019 at 10:45:54 am'! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'sqr 8/23/2019 15:32' prior: 50469594! - allSubclasses - "A breadth-first iterative algorithm. Significantly faster than a recursive, depth-first implementation." - - | answer finger fingerLimit each | - answer := OrderedCollection new. - self subclassesDo: [:some | answer add: some]. - finger := 0. - fingerLimit := answer size. - [finger < fingerLimit] whileTrue: - [ - finger + 1 to: fingerLimit do: - [:index | - each := answer at: index. - each subclassesDo: [:some | answer add: some] - ]. - finger := fingerLimit. - fingerLimit := answer size. - ]. - ^answer! ! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'sqr 8/23/2019 15:41' prior: 16783603! - allSuperclasses - "Answer an OrderedCollection of the receiver's and the receiver's - ancestor's superclasses. The first element is the receiver's immediate - superclass, followed by its superclass; the last element is Object." - - | answer pivot | - answer := OrderedCollection new. - pivot := superclass. - [pivot == nil] whileFalse: - [ - answer add: pivot. - pivot := pivot superclass - ]. - ^answer! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3851-faster-allSubclasses-allSuperclasses-AndresValloud-2019Aug24-10h36m-sqr.1.cs.st----! - -'From Cuis 5.0 [latest update: #3851] on 25 August 2019 at 11:21:31 am'! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'sqr 8/24/2019 18:19' prior: 50469854! - allSuperclasses - "Answer an OrderedCollection of the receiver's and the receiver's - ancestor's superclasses. The first element is the receiver's immediate - superclass, followed by its superclass and subsequent superclasses, - and proceeding as long as there is a non-nil superclass." - - | answer pivot | - answer := OrderedCollection new. - pivot := superclass. - [pivot == nil] whileFalse: - [ - answer add: pivot. - pivot := pivot superclass - ]. - ^answer! ! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'sqr 8/24/2019 18:25' prior: 16783618! - subclasses - "slow implementation since Behavior does not keep track of subclasses" - - ^ self class allInstances select: [:each | each superclass = self ]! ! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'HAW 8/24/2019 15:23:44' prior: 50469605! -withAllSubclasses - "Answer an OrderedCollection with the receiver, the receiver's descendents, and the - receiver's descendents' subclasses." - - ^self allSubclasses addFirst: self; yourself! ! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'sqr 8/24/2019 18:21' prior: 16783651! - withAllSuperclasses - "Answer an OrderedCollection of the receiver and the receiver's - superclasses. See also #allSuperclasses." - - ^self allSuperclasses addFirst: self; yourself! ! - -Behavior removeSelector: #addAllSubclassesTo:! - -Behavior removeSelector: #addAllSubclassesTo:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3852-allSubclassesAndFriends-AndresValloud-HernanWilkinson-2019Aug25-11h15m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3852] on 1 September 2019 at 2:19:12 pm'! -!Utilities class methodsFor: 'default desktop' stamp: 'pb 9/1/2019 14:07:42'! - pvtDefaultTextEditorContents - ^ Text - string: ' - -Cuis Smalltalk - - - -"Yay, Juan. You GO, guy!! ...a great example of malleable software (and a clever mind) at work." - Dan Ingalls - -"I like it... It''s nice and clean and simple and pretty. Nice stuff!!" - Alan Kay - -"I think you have a very elegant design aesthetic." - John Maloney - -Cuis is: - - - Small - - Clean - - Appropriable - - -Like Squeak, Cuis is also: - - - Open Source - - Multiplatform - - -Like other Smalltalk systems (including Squeak, Pharo and others), Cuis is also: - - - A complete development environment written in itself - - A pure, dynamic Object Oriented language - - -Cuis assumes very little on the underlying platform, and this lets it run out-of-the-box on Windows, MacOS, Linux, ChromeOS and WebBrowsers. Cuis shares the [OpenSmalltalk Virtual Machine](http://www.opensmalltalk.org) with Squeak, Pharo and Newspeak. - -What sets Cuis apart from the other members of the Squeak family is the focus on Smalltalk-80 and an active attitude towards system complexity: - -Unbound complexity growth, together with development strategies focused only in the short term, are the worst long term enemies of all software systems. As systems grow older, they usually become more complex. New features are added as layers on top of whatever is below, sometimes without really understanding it, and almost always without modifying it. Complexity and size grow without control. Evolution slows down. Understanding the system becomes harder every day. Bugs are harder to fix. Codebases become huge for no clear reason. At some point, the system can''t evolve anymore and becomes "legacy code". - -Complexity puts a limit to the level of understanding of the system a person might reach, and therefore limits the things that can be done with it. Dan Ingalls says all this in ["Design Principles Behind Smalltalk"](http://www.cs.virginia.edu/~evans/cs655/readings/smalltalk.html). Even if you have already done so, please go and read it again!! - -Cuis Smalltalk is our attempt at this challenge. Furthermore, we believe we are doing something else that no other Smalltalk, commercial or open source, does. We attempt to give the true Smalltalk-80 experience, and keep Smalltalk-80 not as legacy software historic significance, but as a live, evolving system. We feel we are the keepers of the Smalltalk-80 heritage, and enablers of the Dynabook experience. - -Cuis is continuously evolving towards simplicity. Each release is better (i.e. simpler) than the previous one. At the same time, features are enhanced, and any reported bugs fixed. We also adopt recent enhancements from Squeak and share our work with the wider Squeak and Smalltalk community. - - -License - -Cuis is distributed subject to the MIT License, as in http://www.opensource.org/licenses/mit-license.php . Any contribution submitted for incorporation into or for distribution with Cuis shall be presumed subject to the same license. -Portions of Cuis are: -Copyright (c) Xerox Corp. 1981, 1982 -Copyright (c) Apple Computer, Inc. 1985-1996 -Copyright (c) Contributors to Squeak and Cuis projects. 1997-2019' - runs: - (RunArray - runs: #(2 14 1 4 98 11 73 8 56 12 1 1 1 8 2 42 3 26 2 37 4 80 2 105 2065 7 405 ) - values: - ((Array new: 27) - - at: 1 - put: #(); - - at: 2 - put: - ((Array new: 4) - - at: 1 - put: - (TextAlignment basicNew - - instVarAt: 1 - put: 2; - yourself); - - at: 2 - put: - (TextFontFamilyAndSize basicNew - - instVarAt: 1 - put: 'DejaVu'; - - instVarAt: 2 - put: 22; - yourself); - - at: 3 - put: - (TextEmphasis basicNew - - instVarAt: 1 - put: 1; - yourself); - - at: 4 - put: - (TextColor basicNew - - instVarAt: 1 - put: - (Color - r: 0.0 - g: 0.0 - b: 1.0); - yourself); - yourself); - - at: 3 - put: - ((Array new: 1) - - at: 1 - put: - (TextAlignment basicNew - - instVarAt: 1 - put: 2; - yourself); - yourself); - - at: 4 - put: #(); - - at: 5 - put: - ((Array new: 2) - - at: 1 - put: - (TextAlignment basicNew - - instVarAt: 1 - put: 1; - yourself); - - at: 2 - put: - (TextFontFamilyAndSize basicNew - - instVarAt: 1 - put: 'DejaVu'; - - instVarAt: 2 - put: 9; - yourself); - yourself); - - at: 6 - put: - ((Array new: 3) - - at: 1 - put: - (TextAlignment basicNew - - instVarAt: 1 - put: 1; - yourself); - - at: 2 - put: - (TextEmphasis basicNew - - instVarAt: 1 - put: 2; - yourself); - - at: 3 - put: - (TextFontFamilyAndSize basicNew - - instVarAt: 1 - put: 'DejaVu'; - - instVarAt: 2 - put: 9; - yourself); - yourself); - - at: 7 - put: - ((Array new: 2) - - at: 1 - put: - (TextAlignment basicNew - - instVarAt: 1 - put: 1; - yourself); - - at: 2 - put: - (TextFontFamilyAndSize basicNew - - instVarAt: 1 - put: 'DejaVu'; - - instVarAt: 2 - put: 9; - yourself); - yourself); - - at: 8 - put: - ((Array new: 3) - - at: 1 - put: - (TextAlignment basicNew - - instVarAt: 1 - put: 1; - yourself); - - at: 2 - put: - (TextEmphasis basicNew - - instVarAt: 1 - put: 2; - yourself); - - at: 3 - put: - (TextFontFamilyAndSize basicNew - - instVarAt: 1 - put: 'DejaVu'; - - instVarAt: 2 - put: 9; - yourself); - yourself); - - at: 9 - put: - ((Array new: 2) - - at: 1 - put: - (TextAlignment basicNew - - instVarAt: 1 - put: 1; - yourself); - - at: 2 - put: - (TextFontFamilyAndSize basicNew - - instVarAt: 1 - put: 'DejaVu'; - - instVarAt: 2 - put: 9; - yourself); - yourself); - - at: 10 - put: - ((Array new: 3) - - at: 1 - put: - (TextAlignment basicNew - - instVarAt: 1 - put: 1; - yourself); - - at: 2 - put: - (TextEmphasis basicNew - - instVarAt: 1 - put: 2; - yourself); - - at: 3 - put: - (TextFontFamilyAndSize basicNew - - instVarAt: 1 - put: 'DejaVu'; - - instVarAt: 2 - put: 9; - yourself); - yourself); - - at: 11 - put: - ((Array new: 2) - - at: 1 - put: - (TextAlignment basicNew - - instVarAt: 1 - put: 1; - yourself); - - at: 2 - put: - (TextFontFamilyAndSize basicNew - - instVarAt: 1 - put: 'DejaVu'; - - instVarAt: 2 - put: 9; - yourself); - yourself); - - at: 12 - put: - ((Array new: 1) - - at: 1 - put: - (TextFontFamilyAndSize basicNew - - instVarAt: 1 - put: 'DejaVu'; - - instVarAt: 2 - put: 9; - yourself); - yourself); - - at: 13 - put: #(); - - at: 14 - put: - ((Array new: 1) - - at: 1 - put: - (TextEmphasis basicNew - - instVarAt: 1 - put: 1; - yourself); - yourself); - - at: 15 - put: #(); - - at: 16 - put: - ((Array new: 2) - - at: 1 - put: - (TextColor basicNew - - instVarAt: 1 - put: - (Color - r: 0.0 - g: 0.0 - b: 1.0); - yourself); - - at: 2 - put: - (TextFontFamilyAndSize basicNew - - instVarAt: 1 - put: 'DejaVu'; - - instVarAt: 2 - put: 14; - yourself); - yourself); - - at: 17 - put: #(); - - at: 18 - put: - ((Array new: 1) - - at: 1 - put: - (TextEmphasis basicNew - - instVarAt: 1 - put: 1; - yourself); - yourself); - - at: 19 - put: #(); - - at: 20 - put: - ((Array new: 2) - - at: 1 - put: - (TextFontFamilyAndSize basicNew - - instVarAt: 1 - put: 'DejaVu'; - - instVarAt: 2 - put: 14; - yourself); - - at: 2 - put: - (TextColor basicNew - - instVarAt: 1 - put: - (Color - r: 0.0 - g: 0.0 - b: 1.0); - yourself); - yourself); - - at: 21 - put: #(); - - at: 22 - put: - ((Array new: 1) - - at: 1 - put: - (TextEmphasis basicNew - - instVarAt: 1 - put: 1; - yourself); - yourself); - - at: 23 - put: #(); - - at: 24 - put: - ((Array new: 2) - - at: 1 - put: - (TextColor basicNew - - instVarAt: 1 - put: - (Color - r: 0.0 - g: 0.0 - b: 1.0); - yourself); - - at: 2 - put: - (TextFontFamilyAndSize basicNew - - instVarAt: 1 - put: 'DejaVu'; - - instVarAt: 2 - put: 14; - yourself); - yourself); - - at: 25 - put: #(); - - at: 26 - put: - ((Array new: 1) - - at: 1 - put: - (TextEmphasis basicNew - - instVarAt: 1 - put: 1; - yourself); - yourself); - - at: 27 - put: #(); - yourself)).! ! -!Utilities class methodsFor: 'default desktop' stamp: 'pb 9/1/2019 13:55:38'! - recreateDefaultDesktop - | editor | - TranscriptWindow openTranscript - morphPosition: 5 @ 290; - morphExtent: 988 @ 399. - editor _ TextEditor openTextEditor - morphPosition: 463 @ 4; - morphExtent: 894 @ 686. - editor model actualContents: self pvtDefaultTextEditorContents. - self runningWorld showTaskbar.! ! -!Utilities class methodsFor: 'default desktop' stamp: 'pb 9/1/2019 14:18:37'! - tearDownDesktop - self runningWorld hideTaskbar. - SystemWindow allSubInstancesDo: [ :ea | - ea delete ].! ! -!TextEditor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 13:30:38' prior: 16933261! - openTextEditor - - ^ SystemWindow editText: TextModel new label: 'Text Editor' wrap: true! ! -!TranscriptWindow class methodsFor: 'GUI building' stamp: 'pb 9/1/2019 13:27:51' prior: 16938768! - openTranscript - " - TranscriptWindow openTranscript - " - | win | - win _ TranscriptWindow new. - win - setLabel: 'Transcript'; - model: Transcript. - win layoutMorph addMorph: TranscriptMorph new proportionalHeight: 1. - win model when: #redraw send: #redrawNeeded to: win. - ^ win openInWorld. -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3853-recreate-default-desktop-PhilBellalouna-2019Sep01-13h18m-pb.1.cs.st----! - -'From Cuis 5.0 [latest update: #3852] on 1 September 2019 at 5:49:54 am'! - -Form subclass: #Cursor - instanceVariableNames: '' - classVariableNames: 'BlankCursor BottomLeftCursor BottomRightCursor CornerCursor CrossHairCursor CurrentCursor DownCursor MarkerCursor MenuCursor MoveCursor NormalCursor OriginCursor ReadCursor ResizeLeftCursor ResizeTopCursor ResizeTopLeftCursor ResizeTopRightCursor RightArrowCursor SquareCursor TargetCursor TopLeftCursor TopRightCursor UpCursor WaitCursor WebLinkCursor WriteCursor XeqCursor CursorDict ' - poolDictionaries: '' - category: 'Graphics-Display Objects'! - -!classDefinition: #Cursor category: #'Graphics-Display Objects'! -Form subclass: #Cursor - instanceVariableNames: '' - classVariableNames: 'BlankCursor BottomLeftCursor BottomRightCursor CornerCursor CrossHairCursor CurrentCursor CursorDict DownCursor MarkerCursor MenuCursor MoveCursor NormalCursor OriginCursor ReadCursor ResizeLeftCursor ResizeTopCursor ResizeTopLeftCursor ResizeTopRightCursor RightArrowCursor SquareCursor TargetCursor TopLeftCursor TopRightCursor UpCursor WaitCursor WebLinkCursor WriteCursor XeqCursor' - poolDictionaries: '' - category: 'Graphics-Display Objects'! -!Cursor commentStamp: '' prior: 16825810! - I am a Form that is a possible appearance for a mouse cursor. My size is always 16x16, ever since the original implementation on the Alto. - -Predefined cursors should accessed via #cursorAt: which caches Cursor instances. For example "Cursor cursorAt: #normalCursorWithMask". You can also dynamically add your own cursors or modify existing ones via #cursorAt:put: as desired.! - -LayoutAdjustingMorph subclass: #WindowEdgeAdjustingMorph - instanceVariableNames: 'selector coordinateGetter cursorGetter cursorKey ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -!classDefinition: #WindowEdgeAdjustingMorph category: #'Morphic-Layouts'! -LayoutAdjustingMorph subclass: #WindowEdgeAdjustingMorph - instanceVariableNames: 'selector coordinateGetter cursorGetter cursorKey' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! -!Cursor class methodsFor: 'accessing' stamp: 'pb 9/1/2019 00:43:01'! - cursorAt: cursorKey - ^ CursorDict - at: cursorKey - ifAbsent: [ - (self respondsTo: cursorKey) ifTrue: [ | newCursor | - newCursor _ self perform: cursorKey. - newCursor hasMask ifFalse: [ newCursor _ newCursor withMask ]. - self - cursorAt: cursorKey - put: newCursor ]].! ! -!Cursor class methodsFor: 'accessing' stamp: 'pb 8/31/2019 23:11:45'! - cursorAt: cursorKey put: aCursor - ^ CursorDict at: cursorKey put: aCursor! ! -!Cursor class methodsFor: 'accessing' stamp: 'pb 9/1/2019 04:32:41'! - defaultCursor - "Answer the instance of me that is the shape of an arrow slanted left." - ^ Preferences biggerCursors - ifTrue: [ CursorWithAlpha biggerNormal ] - ifFalse: [ self cursorAt: #normalCursorWithMask ].! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:40:46'! - blankCursor - "Answer the instance of me that is all white." - ^ self new.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 8/31/2019 23:29:22'! - bottomLeftCursor - ^ self - extent: 16 @ 16 - fromArray: #(49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 65532 65532 0 0 ) - offset: 0 @ -16.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 8/31/2019 23:29:16'! - bottomRightCursor - ^ self - extent: 16 @ 16 - fromArray: #(12 12 12 12 12 12 12 12 12 12 12 12 65532 65532 0 0 ) - offset: -16 @ -16.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:41:03'! - cornerCursor - "Answer the instance of me that is the shape of the bottom right corner - of a rectangle." - ^ self - extent: 16 @ 16 - fromArray: #(12 12 12 12 12 12 12 12 12 12 12 12 65532 65532 0 0 ) - offset: -16 @ -16.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:41:14'! - crossHairCursor - "Answer the instance of me that is the shape of a cross." - ^ self - extent: 16 @ 16 - fromArray: #(0 256 256 256 256 256 256 32764 256 256 256 256 256 256 0 0 ) - offset: -7 @ -7.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:41:27'! - downCursor - "Answer the instance of me that is the shape of an arrow facing - downward." - ^ self - extent: 16 @ 16 - fromArray: #(12288 12288 12288 12288 12288 12288 12288 64512 30720 12288 0 0 0 0 0 0 ) - offset: 0 @ 0.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:42:56'! - executeCursor - "Answer the instance of me that is the shape of an arrow slanted left - with a star next to it." - ^ self - extent: 16 @ 16 - fromArray: #(32800 49184 57456 62462 63884 64648 65272 61656 55692 39172 3072 3072 1536 1536 0 0 ) - offset: 0 @ 0.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:43:07'! - markerCursor - "Answer the instance of me that is the shape of a small ball." - ^ self - extent: 16 @ 16 - fromArray: #(28672 63488 63488 28672 0 0 0 0 0 0 0 0 0 0 0 0 ) - offset: 0 @ 0.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:43:17'! - menuCursor - "Answer the instance of me that is the shape of a menu." - ^ self - extent: 16 @ 16 - fromArray: #(65504 32800 42528 32800 54112 65504 32800 45728 32800 44192 32800 42272 32800 65504 0 ) - offset: 0 @ 0.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:43:27'! - moveCursor - "Answer the instance of me that is the shape of a cross inside a square." - ^ self - extent: 16 @ 16 - fromArray: #(65532 65532 49932 49932 49932 49932 65532 65532 49932 49932 49932 49932 65532 65532 0 0 ) - offset: 0 @ 0.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:43:41'! - normalCursor - "Answer the instance of me that is the shape of an arrow slanted left." - ^ self - extent: 16 @ 16 - fromArray: #(32768 49152 57344 61440 63488 64512 65024 63488 63488 38912 3072 3072 1536 1536 768 768 ) - offset: 0 @ 0.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 8/31/2019 23:54:01'! - normalCursorWithMask - "Cursor initNormalWithMask. Cursor normal show" - "Next two lines work simply for any cursor..." - " - self initNormal. - NormalCursor _ CursorWithMask derivedFrom: NormalCursor. - " - "But for a good looking cursor, you have to tweak things..." - ^ (CursorWithMask - extent: 16 @ 16 - depth: 1 - fromArray: #(0 1073741824 1610612736 1879048192 2013265920 2080374784 2113929216 2130706432 2139095040 2080374784 1811939328 1174405120 100663296 50331648 50331648 0 ) - offset: -1 @ -1) setMaskForm: - (Form - extent: 16 @ 16 - depth: 1 - fromArray: #(3221225472 3758096384 4026531840 4160749568 4227858432 4261412864 4278190080 4286578688 4290772992 4292870144 4261412864 4009754624 3472883712 2273312768 125829120 58720256 ) - offset: 0 @ 0).! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:43:57'! - originCursor - "Answer the instance of me that is the shape of the top left corner of a - rectangle." - ^ self - extent: 16 @ 16 - fromArray: #(65532 65532 49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 0 0 ) - offset: 0 @ 0.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:44:07'! - readCursor - "Answer the instance of me that is the shape of eyeglasses." - ^ self - extent: 16 @ 16 - fromArray: #(0 0 4104 10260 16416 64480 33824 33824 46496 31680 0 0 0 0 0 0 ) - offset: 0 @ 0.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:07:52'! - resizeBottomCursor - ^ self cursorAt: #resizeTopCursor! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:08:37'! - resizeBottomLeftCursor - ^ self cursorAt: #resizeTopRightCursor! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:11:24'! - resizeBottomRightCursor - ^ self cursorAt: #resizeTopLeftCursor! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 8/31/2019 23:38:39'! - resizeLeftCursor - ^ (self - extent: 16 @ 16 - fromArray: #(0 1152 1152 1152 5280 13488 29880 64764 29880 13488 5280 1152 1152 1152 0 0 ) - offset: -7 @ -7) withMask.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:12:01'! - resizeRightCursor - ^ self cursorAt: #resizeLeftCursor! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 8/31/2019 23:39:40'! - resizeTopCursor - ^ (self - extent: 16 @ 16 - fromArray: #(256 896 1984 4064 256 32764 0 0 32764 256 4064 1984 896 256 0 ) - offset: -7 @ -7) withMask.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 8/31/2019 23:40:11'! - resizeTopLeftCursor - ^ (self - extent: 16 @ 16 - fromArray: #(0 31760 30752 28740 26760 17680 544 1088 2176 4420 8748 1052 2108 124 0 0 ) - offset: -7 @ -7) withMask.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 8/31/2019 23:40:38'! - resizeTopRightCursor - ^ (self - extent: 16 @ 16 - fromArray: #(0 4220 2108 17436 8748 4420 2176 1088 544 17680 26760 28736 30752 31744 0 0 ) - offset: -7 @ -7) withMask.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:44:30'! - rightArrowCursor - "Answer the instance of me that is the shape of an arrow pointing to the right." - ^ self - extent: 16 @ 16 - fromArray: #(1536 1920 2016 65528 2016 1920 1536 0 0 0 0 0 0 0 0 0 ) - offset: 0 @ 0.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:44:49'! - squareCursor - "Answer the instance of me that is the shape of a square." - ^ self - extent: 16 @ 16 - fromArray: #(0 0 0 0 0 960 960 960 960 0 0 0 0 0 0 0 ) - offset: -8 @ -8.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:45:00'! - targetCursor - "Answer the instance of me that is the shape of a gunsight." - ^ self - extent: 16 @ 16 - fromArray: #(1984 6448 8456 16644 17284 33026 35106 65278 35106 33026 17284 16644 8456 6448 1984 0 ) - offset: -7 @ -7.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 8/31/2019 23:44:44'! - topLeftCursor - ^ self - extent: 16 @ 16 - fromArray: #(65532 65532 49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 0 0 ) - offset: 0 @ 0.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 8/31/2019 23:45:08'! - topRightCursor - ^ self - extent: 16 @ 16 - fromArray: #(65532 65532 12 12 12 12 12 12 12 12 12 12 12 12 0 0 ) - offset: -16 @ 0.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:45:13'! - upCursor - "Answer the instance of me that is the shape of an arrow facing upward." - ^ self - extent: 16 @ 16 - fromArray: #(12288 30720 64512 12288 12288 12288 12288 12288 12288 12288 0 0 0 0 0 0 ) - offset: 0 @ 0.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:45:22'! - waitCursor - "Answer the instance of me that is the shape of an Hourglass (was in the - shape of three small balls)." - ^ self - extent: 16 @ 16 - fromArray: #(65532 32772 16392 8208 7392 4032 1920 1920 2368 4384 8592 17352 36852 65532 0 ) - offset: 0 @ 0.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:45:34'! - webLinkCursor - "Return a cursor that can be used for emphasizing web links" - ^ (CursorWithMask - extent: 16 @ 16 - fromArray: #(3072 4608 4608 4608 4608 5046 4681 29257 37449 37449 32769 32769 49155 16386 24582 16380 ) - offset: -5 @ 0) setMaskForm: - (Form - extent: 16 @ 16 - fromArray: - (#(3072 7680 7680 7680 7680 8118 8191 32767 65535 65535 65535 65535 65535 32766 32766 16380 ) collect: [ :bits | - bits bitShift: 16 ]) - offset: 0 @ 0).! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:45:43'! - writeCursor - "Answer the instance of me that is the shape of a pen writing." - ^ self - extent: 16 @ 16 - fromArray: #(24 60 72 144 288 580 1156 2316 4624 9232 30728 20728 57728 32512 0 0 ) - offset: 0 @ 0.! ! -!Debugger methodsFor: 'initialization' stamp: 'pb 9/1/2019 04:32:41' prior: 50379248! - openNotifierContents: msgString label: label - "Create and schedule a notifier view with the given label and message. A notifier view shows just the message or the first several lines of the stack, with a menu that allows the user to open a full debugger if so desired." - "NOTE: When this method returns, a new process has been scheduled to run the windows, and thus this notifier, but the previous active porcess has not been suspended. The sender will do this." - | msg | - Sensor flushKeyboard. - savedCursor _ Cursor currentCursor. - Cursor defaultCursor activateCursor. - msg _ (label beginsWith: 'Space is low') - ifTrue: [ self lowSpaceChoices , (msgString ifNil: [ '' ]) ] - ifFalse: [ msgString ]. - interruptedProcessUI _ UISupervisor newProcessIfUI: interruptedProcess. - UISupervisor whenUIinSafeState: [ - PreDebugWindow - open: self - label: label - message: msg ].! ! -!EventSensor methodsFor: 'private' stamp: 'pb 9/1/2019 04:32:41' prior: 16839421! - eventTickler - "If the UI process hasn't processed events in a while, do it here. - This is needed to detect the interrupt key." - | delay delta | - delay _ Delay forMilliseconds: self class eventPollPeriod. - self lastEventPoll. - "ensure not nil." - [ - [ - delay wait. - delta _ Time localMillisecondClock - lastEventPoll. - delta > self class eventPollPeriod ifTrue: [ - "See #doOneCycleNowFor:" - Cursor currentCursor = Cursor defaultCursor ifTrue: [ (Cursor cursorAt: #waitCursor) activateCursor ]. - "Discard any mouse events. This code is run when the UI is slow, essentially to have a working - interrupt key. Processing mouse events is pointless: the UI will not handle them anyway. - In addition, at least on Windows 7, when the machine is suspended and resumed with Cuis - running, a lot of meaningless mouseMove events with the same coordinates are sent, maing - Cuis extremely slow and CPU hungry for a few minutes without reason. Discarding mouse - events makes the 'processing' of those very quick." - self fetchMoreEventsDiscardingMouseEvents: true ]] - on: Error - do: [ :ex | - nil ]] repeat.! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'pb 9/1/2019 01:30:55' prior: 50432421! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag - "WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " - | activeProc | - activeProc _ Processor activeProcess. - [ | isARealStartup guiRootObject guiRootObjectClass reopenTranscript | - save not & quit - ifTrue: [ - (SourceFiles at: 2) ifNotNil: [ :changes | - ChangesInitialFileSize ifNotNil: [ changes truncate: ChangesInitialFileSize ]]] - ifFalse: [ - self - logSnapshot: save - andQuit: quit ]. - reopenTranscript _ false. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | - each isInWorld ifTrue: [ - each delete. - reopenTranscript _ true ]]. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - "Cosas que levanto explicitamente abajo" - guiRootObjectClass _ UISupervisor ui class. - guiRootObject _ UISupervisor ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "guiRootObject _ clearAllStateFlag ifFalse: [ UISupervisor ui ]." - UISupervisor stopUIProcess. - activeProc isTerminated ifFalse: [ activeProc terminate ]. - "Clean Globals" - Smalltalk - at: #Sensor - put: nil. - Smalltalk - at: #Display - put: nil. - Smalltalk closeSourceFiles. - Smalltalk - at: #SourceFiles - put: nil. - Smalltalk allClassesDo: [ :cls | - cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | - cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ Smalltalk printStuffToCleanOnImageSave ]. - "Do image save & quit as apropriate" - (Cursor cursorAt: #writeCursor) activateCursor. - save - ifTrue: [ - "The snapshot primitive answers false if it was just called to do the snapshot. - But image startup is resumed by returning (again) from the primitive, but this time answering true." - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk - at: #Sensor - put: nil. - Smalltalk - at: #Display - put: DisplayScreen new. - Smalltalk - at: #SourceFiles - put: (Array new: 2). - Smalltalk openSourceFiles. - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | - cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - UISupervisor spawnNewMorphicProcessFor: (guiRootObject ifNil: [ guiRootObject _ guiRootObjectClass newWorld ]). - Display triggerEvent: #screenSizeChanged. - self restoreLostChangesIfNecessary. - UISupervisor whenUIinSafeState: [ - "guiRootObject fullRepaintNeeded." - reopenTranscript ifTrue: [ TranscriptWindow openTranscript ]]. - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - UISupervisor whenUIinSafeState: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]] - forkAt: Processor timingPriority - 1 - named: 'Startup process'.! ! -!SystemDictionary methodsFor: 'startup' stamp: 'pb 9/1/2019 04:32:41' prior: 50381548! - doStartUp: isARealStartup - " - isARealStartup - true: system is coming up (VM and image just started) - false: we have just saved an image snapshot, but didn't quit. - " - "Here, startup begins!!" - Cursor defaultCursor activateCursor. - self setGCParameters. - isARealStartup ifTrue: [ self clearExternalObjects ]. - self readCommandLineArguments. - self processStartUpList: isARealStartup. - isARealStartup ifTrue: [ - self setPlatformPreferences. - self setStartupStamp ].! ! -!UISupervisor class methodsFor: 'services' stamp: 'pb 9/1/2019 04:32:41' prior: 50380117! - restoreDisplay - DisplayScreen startUp. - self ui ifNotNil: [ :guiRootObject | - guiRootObject restoreDisplay ]. - self whenUIinSafeState: [ Cursor defaultCursor activateCursor ].! ! -!Cursor class methodsFor: 'class initialization' stamp: 'pb 9/1/2019 03:36:04' prior: 16826333! - initialize - CursorDict _ Dictionary new. -! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 03:19:53' prior: 16826391! - resizeForEdge: aSymbol - "Cursor resizeForEdge: #topCursor" - "Cursor resizeForEdge: #bottomLeftCursor" - - "Do not erase this literal, as it helps 'senders' workproperly, and it protects these methods from accidental deletion" - self nominallyUnsent: #(#resizeBottomCursor #resizeBottomLeftCursor #resizeBottomRightCursor #resizeLeftCursor #resizeRightCursor #resizeTopCursor #resizeTopLeftCursor #resizeTopRightCursor ). - - ^ self perform: ('resize' , aSymbol first asString asUppercase - , (aSymbol copyFrom: 2 to: aSymbol size), 'Cursor') asSymbol! ! -!CursorWithAlpha methodsFor: 'accessing' stamp: 'pb 9/1/2019 04:02:28' prior: 16826611! -fallback - ^fallback ifNil: [self class cursorAt: #normalCursorWithMask]! ! -!Point class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 04:32:41' prior: 16890849! - fromUser - Sensor waitNoButton. - (Cursor cursorAt: #crossHairCursor) activateCursor. - Sensor waitButton. - Cursor defaultCursor activateCursor. - ^ Sensor mousePoint"Point fromUser".! ! -!Rectangle class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:30:37' prior: 16899091! - fromUser - "Answer a Rectangle that is determined by having the user - designate the top left and bottom right corners." - | originRect | - originRect _ (Cursor cursorAt: #originCursor) showWhile: [ - (Sensor mousePoint extent: 0 @ 0) newRectFrom: [ :f | - Sensor mousePoint extent: 0 @ 0 ]]. - ^ (Cursor cursorAt: #cornerCursor) showWhile: [ - originRect newRectFrom: [ :f | - f origin corner: Sensor mousePoint ]].! ! -!Rectangle class methodsFor: 'instance creation' stamp: 'pb 9/1/2019 01:30:41' prior: 16899156! - originFromUser: extentPoint - "Answer an instance of me that is determined by having the user - designate the top left corner. The width and height are determined by - extentPoint." - ^ (Cursor cursorAt: #originCursor) showWhile: [ - (Sensor mousePoint extent: extentPoint) newRectFrom: [ :f | - Sensor mousePoint extent: extentPoint ]].! ! -!PasteUpMorph class methodsFor: 'system startup' stamp: 'pb 9/1/2019 04:32:41' prior: 50380978! - initClassCachedState - "Should use some other way to find relevant instances" - self flag: #jmvVer2. - self allInstancesDo: [ :each | - each buildMagnifiedBackgroundImage. - each isWorldMorph ifTrue: [ each redrawNeeded ]]. - Cursor defaultCursor activateCursor.! ! -!HandMorph methodsFor: 'drawing' stamp: 'pb 9/1/2019 01:31:41' prior: 50388300! - drawOn: aCanvas - "Draw the hand itself (i.e., the cursor)." - "This method is only called when we are carrying morphs around..." - aCanvas - stencil: (Cursor cursorAt: #moveCursor) - at: 0 @ 0 - color: Color black.! ! -!HandMorph methodsFor: 'drawing' stamp: 'pb 9/1/2019 01:31:53' prior: 16851639! - needsToBeDrawn - "Return true if this hand must be drawn explicitely instead of being drawn via the hardware cursor. This is the case if it (a) it is a remote hand, (b) it is showing a temporary cursor, or (c) it is not empty and there are any visible submorphs. If using the software cursor, ensure that the hardware cursor is hidden." - "Details: Return true if this hand has a saved patch to ensure that is is processed by the world. This saved patch will be deleted after one final display pass when it becomes possible to start using the hardware cursor again. This trick gives us one last display cycle to allow us to remove the software cursor from the display." - "Note. We draw the hand as a regular morph (using #drawOn:), disabling the hardware cursor, when we carry submorphs. The reason is to lock the mouse pointer and the carried morph together. Otherwhise the carried morph would lag behind the mouse pointer. - This method answers whether the regular #drawOn: drawing mechanism is used for us. - - Check senders. Hand drawing is handled explicitly by the world, because the Hand is not a submorph of the world!!" - (savedPatch notNil or: [ - submorphs anySatisfy: [ :ea | - ea visible ]]) ifTrue: [ - "using the software cursor; hide the hardware one" - Cursor currentCursor == (Cursor cursorAt: #blankCursor) ifFalse: [ (Cursor cursorAt: #blankCursor) activateCursor ]. - ^ true ]. - ^ false.! ! -!HandMorph methodsFor: 'drawing' stamp: 'pb 9/1/2019 04:32:41' prior: 16851684! - restoreSavedPatchOn: aCanvas - "Clear the changed flag and restore the part of the given canvas under this hand from the previously saved patch. If necessary, handle the transition to using the hardware cursor." - hasChanged _ false. - savedPatch ifNotNil: [ - aCanvas - image: savedPatch - at: savedPatch offset. - submorphs notEmpty ifTrue: [ ^ self ]. - "Make the transition to using hardware cursor. Clear savedPatch and - report one final damage rectangle to erase the image of the software cursor." - " owner invalidateDisplayRect: (savedPatch offset extent: savedPatch extent) from: nil." - self - invalidateDisplayRect: (self morphPosition extent: extent) - from: nil. - Cursor currentCursor == Cursor defaultCursor ifFalse: [ Cursor defaultCursor activateCursor ]. - "show hardware cursor" - savedPatch _ nil ].! ! -!HandMorph methodsFor: 'initialization' stamp: 'pb 9/1/2019 04:32:41' prior: 16852171! - initialize - super initialize. - self initForEvents. - keyboardFocus _ nil. - mouseFocus _ nil. - extent _ CursorWithMask defaultCursor extent. - damageRecorder _ DamageRecorder new. - grabMorphData _ IdentityDictionary new. - self initForEvents.! ! -!LayoutAdjustingMorph methodsFor: 'accessing' stamp: 'pb 9/1/2019 03:02:06' prior: 16862873! - cursor - ^ owner direction == #horizontal - ifTrue: [ Cursor cursorAt: #resizeLeftCursor ] - ifFalse: [ Cursor cursorAt: #resizeTopCursor ].! ! -!LayoutAdjustingMorph methodsFor: 'events' stamp: 'pb 9/1/2019 04:32:41' prior: 16862905! - mouseLeave: anEvent - super mouseLeave: anEvent. - hand ifNotNil: [ - hand _ nil. - Cursor defaultCursor activateCursor ].! ! -!LayoutAdjustingMorph methodsFor: 'stepping' stamp: 'pb 9/1/2019 04:32:41' prior: 16862921! - stepAt: millisecondSinceLast - "got the #mouseLeave: message" - | p | - hand ifNil: [ - Cursor currentCursor == self cursor ifTrue: [ Cursor defaultCursor activateCursor ]. - ^ self stopStepping ]. - "hasn't got the #mouseLeave: message (yet)" - p _ hand morphPosition. - hand lastMouseEvent mouseButton1Pressed - ifTrue: [ - self adjustOwnerAt: p. - Preferences cheapWindowReframe ifTrue: [ - owner morphBoundsInWorld newRectFrom: [ :f | - self adjustOwnerAt: Sensor mousePoint. - owner morphBoundsInWorld ]]] - ifFalse: [ - self stopStepping. - "If the button was unpressed outside the morph (can happen if you try to go outside container), - we might not get the #mouseLeave: message" - (self morphContainsPoint: (self internalizeFromWorld: p)) ifFalse: [ - hand _ nil. - Cursor defaultCursor activateCursor ]].! ! -!WindowEdgeAdjustingMorph methodsFor: 'initialization' stamp: 'pb 9/1/2019 05:47:40' prior: 16945044! - initializeBottom - selector _ #windowBottom:. - coordinateGetter _ #y. - cursorKey _ #resizeBottomCursor! ! -!WindowEdgeAdjustingMorph methodsFor: 'initialization' stamp: 'pb 9/1/2019 05:47:14' prior: 16945050! - initializeBottomLeft - selector _ #windowBottomLeft:. - coordinateGetter _ #yourself. - cursorKey _ #resizeBottomLeftCursor! ! -!WindowEdgeAdjustingMorph methodsFor: 'initialization' stamp: 'pb 9/1/2019 05:47:22' prior: 16945057! - initializeBottomRight - selector _ #windowBottomRight:. - coordinateGetter _ #yourself. - cursorKey _ #resizeBottomRightCursor! ! -!WindowEdgeAdjustingMorph methodsFor: 'initialization' stamp: 'pb 9/1/2019 05:47:07' prior: 16945064! - initializeLeft - selector _ #windowLeft:. - coordinateGetter _ #x. - cursorKey _ #resizeLeftCursor! ! -!WindowEdgeAdjustingMorph methodsFor: 'initialization' stamp: 'pb 9/1/2019 05:47:34' prior: 16945070! - initializeRight - selector _ #windowRight:. - coordinateGetter _ #x. - cursorKey _ #resizeRightCursor! ! -!WindowEdgeAdjustingMorph methodsFor: 'initialization' stamp: 'pb 9/1/2019 05:48:00' prior: 16945076! - initializeTop - selector _ #windowTop:. - coordinateGetter _ #y. - cursorKey _ #resizeTopCursor! ! -!WindowEdgeAdjustingMorph methodsFor: 'initialization' stamp: 'pb 9/1/2019 05:47:55' prior: 16945082! - initializeTopLeft - selector _ #windowTopLeft:. - coordinateGetter _ #yourself. - cursorKey _ #resizeTopLeftCursor! ! -!WindowEdgeAdjustingMorph methodsFor: 'initialization' stamp: 'pb 9/1/2019 05:47:49' prior: 16945089! - initializeTopRight - selector _ #windowTopRight:. - coordinateGetter _ #yourself. - cursorKey _ #resizeTopRightCursor! ! -!WindowEdgeAdjustingMorph methodsFor: 'accessing' stamp: 'pb 9/1/2019 05:47:45' prior: 16945106! - cursor - ^ Cursor cursorAt: cursorKey.! ! -!WorldState methodsFor: 'update cycle' stamp: 'pb 9/1/2019 04:32:41' prior: 50339959! - doOneCycleNow - "Immediately do one cycle of the interaction loop." - "See #eventTickler" - | hadAnyEvent | - Cursor currentCursor = (Cursor cursorAt: #waitCursor) ifTrue: [ Cursor defaultCursor activateCursor ]. - "Repair visual damage." - DisplayScreen checkForNewScreenSize. - self displayWorldSafely. - "Run steps, alarms and deferred UI messages" - self runStepMethods. - "Process user input events. Run all event triggered code." - hadAnyEvent _ false. - self handsDo: [ :h | - activeHand _ h. - hadAnyEvent _ hadAnyEvent | h processEventQueue. - activeHand _ nil ]. - "The default is the primary hand" - activeHand _ self hands first. - ^ hadAnyEvent.! ! - -Cursor class removeSelector: #blank! - -Cursor class removeSelector: #blank! - -Cursor class removeSelector: #bottomLeft! - -Cursor class removeSelector: #bottomLeft! - -Cursor class removeSelector: #bottomRight! - -Cursor class removeSelector: #bottomRight! - -Cursor class removeSelector: #corner! - -Cursor class removeSelector: #corner! - -Cursor class removeSelector: #crossHair! - -Cursor class removeSelector: #crossHair! - -Cursor class removeSelector: #down! - -Cursor class removeSelector: #down! - -Cursor class removeSelector: #execute! - -Cursor class removeSelector: #execute! - -Cursor class removeSelector: #initBottomLeft! - -Cursor class removeSelector: #initBottomLeft! - -Cursor class removeSelector: #initBottomRight! - -Cursor class removeSelector: #initBottomRight! - -Cursor class removeSelector: #initCorner! - -Cursor class removeSelector: #initCorner! - -Cursor class removeSelector: #initCrossHair! - -Cursor class removeSelector: #initCrossHair! - -Cursor class removeSelector: #initDown! - -Cursor class removeSelector: #initDown! - -Cursor class removeSelector: #initMarker! - -Cursor class removeSelector: #initMarker! - -Cursor class removeSelector: #initMenu! - -Cursor class removeSelector: #initMenu! - -Cursor class removeSelector: #initMove! - -Cursor class removeSelector: #initMove! - -Cursor class removeSelector: #initNormal! - -Cursor class removeSelector: #initNormal! - -Cursor class removeSelector: #initNormalWithMask! - -Cursor class removeSelector: #initNormalWithMask! - -Cursor class removeSelector: #initOrigin! - -Cursor class removeSelector: #initOrigin! - -Cursor class removeSelector: #initRead! - -Cursor class removeSelector: #initRead! - -Cursor class removeSelector: #initResizeLeft! - -Cursor class removeSelector: #initResizeLeft! - -Cursor class removeSelector: #initResizeTop! - -Cursor class removeSelector: #initResizeTop! - -Cursor class removeSelector: #initResizeTopLeft! - -Cursor class removeSelector: #initResizeTopLeft! - -Cursor class removeSelector: #initResizeTopRight! - -Cursor class removeSelector: #initResizeTopRight! - -Cursor class removeSelector: #initRightArrow! - -Cursor class removeSelector: #initRightArrow! - -Cursor class removeSelector: #initSquare! - -Cursor class removeSelector: #initSquare! - -Cursor class removeSelector: #initTarget! - -Cursor class removeSelector: #initTarget! - -Cursor class removeSelector: #initTopLeft! - -Cursor class removeSelector: #initTopLeft! - -Cursor class removeSelector: #initTopRight! - -Cursor class removeSelector: #initTopRight! - -Cursor class removeSelector: #initUp! - -Cursor class removeSelector: #initUp! - -Cursor class removeSelector: #initWait! - -Cursor class removeSelector: #initWait! - -Cursor class removeSelector: #initWrite! - -Cursor class removeSelector: #initWrite! - -Cursor class removeSelector: #initXeq! - -Cursor class removeSelector: #initXeq! - -Cursor class removeSelector: #makeCursorsWithMask! - -Cursor class removeSelector: #makeCursorsWithMask! - -Cursor class removeSelector: #marker! - -Cursor class removeSelector: #marker! - -Cursor class removeSelector: #menu! - -Cursor class removeSelector: #menu! - -Cursor class removeSelector: #move! - -Cursor class removeSelector: #move! - -Cursor class removeSelector: #normal! - -Cursor class removeSelector: #normal! - -Cursor class removeSelector: #normalOrBiggerCursor! - -Cursor class removeSelector: #origin! - -Cursor class removeSelector: #origin! - -Cursor class removeSelector: #read! - -Cursor class removeSelector: #read! - -Cursor class removeSelector: #resizeBottom! - -Cursor class removeSelector: #resizeBottom! - -Cursor class removeSelector: #resizeBottomLeft! - -Cursor class removeSelector: #resizeBottomLeft! - -Cursor class removeSelector: #resizeBottomRight! - -Cursor class removeSelector: #resizeBottomRight! - -Cursor class removeSelector: #resizeLeft! - -Cursor class removeSelector: #resizeLeft! - -Cursor class removeSelector: #resizeRight! - -Cursor class removeSelector: #resizeRight! - -Cursor class removeSelector: #resizeTop! - -Cursor class removeSelector: #resizeTop! - -Cursor class removeSelector: #resizeTopLeft! - -Cursor class removeSelector: #resizeTopLeft! - -Cursor class removeSelector: #resizeTopRight! - -Cursor class removeSelector: #resizeTopRight! - -Cursor class removeSelector: #rightArrow! - -Cursor class removeSelector: #rightArrow! - -Cursor class removeSelector: #square! - -Cursor class removeSelector: #square! - -Cursor class removeSelector: #target! - -Cursor class removeSelector: #target! - -Cursor class removeSelector: #topLeft! - -Cursor class removeSelector: #topLeft! - -Cursor class removeSelector: #topRight! - -Cursor class removeSelector: #topRight! - -Cursor class removeSelector: #up! - -Cursor class removeSelector: #up! - -Cursor class removeSelector: #wait! - -Cursor class removeSelector: #wait! - -Cursor class removeSelector: #webLink! - -Cursor class removeSelector: #webLink! - -Cursor class removeSelector: #write! - -Cursor class removeSelector: #write! - -Cursor class removeSelector: #xeqCursor! - -Form subclass: #Cursor - instanceVariableNames: '' - classVariableNames: 'CurrentCursor CursorDict' - poolDictionaries: '' - category: 'Graphics-Display Objects'! - -!classDefinition: #Cursor category: #'Graphics-Display Objects'! -Form subclass: #Cursor - instanceVariableNames: '' - classVariableNames: 'CurrentCursor CursorDict' - poolDictionaries: '' - category: 'Graphics-Display Objects'! - -Cursor initialize! - -LayoutAdjustingMorph subclass: #WindowEdgeAdjustingMorph - instanceVariableNames: 'selector coordinateGetter cursorKey' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -!classDefinition: #WindowEdgeAdjustingMorph category: #'Morphic-Layouts'! -LayoutAdjustingMorph subclass: #WindowEdgeAdjustingMorph - instanceVariableNames: 'selector coordinateGetter cursorKey' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -Utilities runningWorld hideTaskbar! - -TranscriptWindow allInstancesDo: [ :t | t delete ]! - -SystemWindow allInstancesDo: [ :t | t delete ]! - -Cursor initialize! - -Utilities recreateDefaultDesktop! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3854-Cursor-cleanup-PhilBellalouna-2019Aug31-23h08m-pb.1.cs.st----! - -'From Cuis 5.0 [latest update: #3854] on 3 September 2019 at 11:58:35 am'! -!String methodsFor: 'text conversion emphasis' stamp: 'jmv 9/3/2019 10:17:21'! - pointSize: pointSize - "Stuff like - ('Hello World' pointSize: 22) edit - " - ^self asText pointSize: pointSize! ! -!String methodsFor: 'text conversion attributes' stamp: 'jmv 9/3/2019 10:08:21'! -centered - "Stuff like - ('Hello world' centered ) edit - " - ^self asText centered! ! -!String methodsFor: 'text conversion attributes' stamp: 'jmv 9/3/2019 10:08:52'! - justified - "Stuff like - ('Hello world' justified ) edit - " - ^self asText justified! ! -!String methodsFor: 'text conversion attributes' stamp: 'jmv 9/3/2019 10:09:50'! - leftFlush - "Stuff like - ('Hello world' leftFlush ) edit - " - ^self asText leftFlush! ! -!String methodsFor: 'text conversion attributes' stamp: 'jmv 9/3/2019 10:10:05'! - rightFlush - "Stuff like - ('Hello world' rightFlush ) edit - " - ^self asText rightFlush! ! -!String methodsFor: 'text conversion color' stamp: 'jmv 9/3/2019 10:29:49'! - black - "Stuff like - 'Hello world' black edit - " - ^self asText black! ! -!String methodsFor: 'text conversion color' stamp: 'jmv 9/3/2019 10:29:58'! - blue - "Stuff like - 'Hello world' blue edit - " - ^self asText blue! ! -!String methodsFor: 'text conversion color' stamp: 'jmv 9/3/2019 10:30:04'! - cyan - "Stuff like - 'Hello world' cyan edit - " - ^self asText cyan! ! -!String methodsFor: 'text conversion color' stamp: 'jmv 9/3/2019 10:30:11'! - gray - "Stuff like - 'Hello world' gray edit - " - ^self asText gray! ! -!String methodsFor: 'text conversion color' stamp: 'jmv 9/3/2019 10:30:19'! - green - "Stuff like - 'Hello world' green edit - " - ^self asText green! ! -!String methodsFor: 'text conversion color' stamp: 'jmv 9/3/2019 10:31:04'! - magenta - "Stuff like - 'Hello world' magenta edit - " - ^self asText magenta! ! -!String methodsFor: 'text conversion color' stamp: 'jmv 9/3/2019 10:31:17'! - red - "Stuff like - 'Hello world' red edit - " - ^self asText red! ! -!String methodsFor: 'text conversion color' stamp: 'jmv 9/3/2019 10:31:27'! - yellow - "Stuff like - 'Hello world' yellow edit - " - ^self asText yellow! ! -!Text methodsFor: 'adding emphasis' stamp: 'jmv 9/3/2019 10:16:59'! - pointSize: pointSize - "Stuff like - ('Hello World' pointSize: 22) edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: (TextFontFamilyAndSize pointSize: pointSize) from: 1 to: string size! ! -!Text methodsFor: 'adding attributes' stamp: 'jmv 9/3/2019 10:08:33'! - centered - "Stuff like - ('Hello world' centered ) edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextAlignment centered from: 1 to: string size! ! -!Text methodsFor: 'adding attributes' stamp: 'jmv 9/3/2019 10:08:58'! - justified - "Stuff like - ('Hello world' justified ) edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextAlignment justified from: 1 to: string size! ! -!Text methodsFor: 'adding attributes' stamp: 'jmv 9/3/2019 10:09:57'! - leftFlush - "Stuff like - ('Hello world' leftFlush ) edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextAlignment leftFlush from: 1 to: string size! ! -!Text methodsFor: 'adding attributes' stamp: 'jmv 9/3/2019 10:10:10'! - rightFlush - "Stuff like - ('Hello world' rightFlush ) edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextAlignment rightFlush from: 1 to: string size! ! -!Text methodsFor: 'adding color' stamp: 'jmv 9/3/2019 10:30:49'! - black - "Stuff like - 'Hello world' black edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextColor black from: 1 to: string size! ! -!Text methodsFor: 'adding color' stamp: 'jmv 9/3/2019 10:30:43'! - blue - "Stuff like - 'Hello world' blue edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextColor blue from: 1 to: string size! ! -!Text methodsFor: 'adding color' stamp: 'jmv 9/3/2019 10:30:38'! - cyan - "Stuff like - 'Hello world' cyan edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextColor cyan from: 1 to: string size! ! -!Text methodsFor: 'adding color' stamp: 'jmv 9/3/2019 10:30:32'! - gray - "Stuff like - 'Hello world' gray edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextColor gray from: 1 to: string size! ! -!Text methodsFor: 'adding color' stamp: 'jmv 9/3/2019 10:30:27'! - green - "Stuff like - 'Hello world' green edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextColor green from: 1 to: string size! ! -!Text methodsFor: 'adding color' stamp: 'jmv 9/3/2019 10:31:00'! - magenta - "Stuff like - 'Hello world' magenta edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextColor magenta from: 1 to: string size! ! -!Text methodsFor: 'adding color' stamp: 'jmv 9/3/2019 10:31:13'! - red - "Stuff like - 'Hello world' red edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextColor red from: 1 to: string size! ! -!Text methodsFor: 'adding color' stamp: 'jmv 9/3/2019 10:31:31'! - yellow - "Stuff like - 'Hello world' yellow edit - " - string size = 0 ifTrue: [ ^self ]. - self addAttribute: TextColor yellow from: 1 to: string size! ! -!Text methodsFor: 'emphasis' stamp: 'jmv 9/3/2019 11:44:38' prior: 50370505! - fontIfApplying: textAttributes default: defaultFont - "Answer the font for characters as specified by the argument." - - | fn ps | - self withAttributeValues: textAttributes do: [ :familyName :pointSize :emphasis :color :alignment :characterStyle :paragraphStyle :backgroundColor | - fn _ familyName ifNil: [ defaultFont ifNotNil: [ defaultFont familyName ] ifNil: [ FontFamily defaultFamilyName ]]. - ps _ pointSize ifNil: [ defaultFont ifNotNil: [ defaultFont pointSize ] ifNil: [ FontFamily defaultPointSize ]]. - ^((AbstractFont familyName: fn pointSize: ps) ifNil: [ - AbstractFont familyName: fn aroundPointSize: ps]) - emphasized: emphasis ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3855-TextEnhancements-JuanVuletich-2019Sep03-11h57m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3854] on 3 September 2019 at 11:13:52 am'! -!TextFontFamilyAndSize class methodsFor: 'instance creation' stamp: 'jmv 9/3/2019 10:14:04'! - pointSize: aNumber - "Reference only baseFonts. Any emphasis should be done with TextEmphasis. - Store only familiName and pointSize" - ^ self new familyName: FontFamily defaultFamilyName pointSize: aNumber! ! -!MessageNode methodsFor: 'private' stamp: 'jmv 9/3/2019 10:01:06' prior: 50464570! - pvtCheckForPvtSelector: encoder - "If the code being compiled is trying to send a private message (e.g. 'pvtCheckForPvtSelector:') to anyone other than self, then complain to encoder." - - selector isInitializePvtSelector ifTrue: [ - (receiver isSelfNewMessageSend or: [receiver isSelfBasicNewMessageSend]) ifFalse: [ - encoder notify: 'Private instance initialization messages may only be sent to ''self new'' or "self basicNew" (by class instance creation methods)']]. - selector isPvtSelector ifTrue: [ - (receiver isSelfPseudoVariable or: [ receiver isSuperPseudoVariable ]) ifFalse: [ - self halt. - encoder notify: 'Private messages may only be sent to self or super']].! ! -!Utilities class methodsFor: 'default desktop' stamp: 'jmv 9/3/2019 10:58:38' prior: 50469934! - pvtDefaultTextEditorContents - ^ (' -', -('Cuis Smalltalk - -' centered blue pointSize: FontFamily defaultPointSize * 3), -(' -"Yay, Juan. You GO, guy!! ...a great example of malleable software (and a clever mind) at work." -' rightFlush pointSize: FontFamily defaultPointSize * 0.6), -('Dan Ingalls -' italic rightFlush pointSize: FontFamily defaultPointSize * 0.6), -(' -"I like it... It''s nice and clean and simple and pretty. Nice stuff!!" -' rightFlush pointSize: FontFamily defaultPointSize * 0.6), -('Alan Kay -' italic rightFlush pointSize: FontFamily defaultPointSize * 0.6), -(' -"I think you have a very elegant design aesthetic." -' rightFlush pointSize: FontFamily defaultPointSize * 0.6), -('John Maloney -'italic rightFlush pointSize: FontFamily defaultPointSize * 0.6), -' - -', -'Cuis is a modern, Open Source, multiplatform, Smalltalk-80 system. - - -', -'Cuis is: - -' bold, -' - Small - - Clean - - Appropriable -' blue, -' - -Additionally, Cuis is: - -' bold, -' - Open Source - - Multiplatform -' blue, -' - -Like other Smalltalk systems, Cuis is also: - -' bold, -' - A complete development environment written in itself - - A pure, dynamic Object Oriented language -' blue, -' - -Cuis assumes very little on the underlying platform, and this lets it run out-of-the-box on Windows, MacOS, Linux, ChromeOS and WebBrowsers. Cuis shares the [OpenSmalltalk Virtual Machine] (http://www.opensmalltalk.org) with Squeak, Pharo and Newspeak. - -What sets Cuis apart from the other members of the Squeak family is the focus on Smalltalk-80 and an active attitude towards system complexity: - -Unbound complexity growth, together with development strategies focused only in the short term, are the worst long term enemies of all software systems. As systems grow older, they usually become more complex. New features are added as layers on top of whatever is below, sometimes without really understanding it, and almost always without modifying it. Complexity and size grow without control. Evolution slows down. Understanding the system becomes harder every day. Bugs are harder to fix. Codebases become huge for no clear reason. At some point, the system can''t evolve anymore and becomes "legacy code". - -Complexity puts a limit to the level of understanding of the system a person might reach, and therefore limits the things that can be done with it. Dan Ingalls says all this in ["Design Principles Behind Smalltalk"] (http://www.cs.virginia.edu/~evans/cs655/readings/smalltalk.html). Even if you have already done so, please go and read it again!! - -Cuis Smalltalk is our attempt at this challenge. Furthermore, we believe we are doing something else that no other Smalltalk, commercial or open source, does. We attempt to give the true Smalltalk-80 experience, and keep Smalltalk-80 not as legacy software historic significance, but as a live, evolving system. We feel we are the keepers of the Smalltalk-80 heritage, and enablers of the Dynabook experience. - -As Cuis evolves, we keep on these values. Every update, be it a bug fix or a feature enhancement, is reviewed carefully to avoid adding unneded complexity to the system. Every opportunity to remove unneded complexity is followed. As we go, features are enhanced, and any reported bugs fixed. We also adopt selected enhancements from Squeak and Pharo, and share our work with the wider Smalltalk community. - - -' justified, -'License -' bold, -' -Cuis is distributed subject to the MIT License, as in http://www.opensource.org/licenses/mit-license.php . Any contribution submitted for incorporation into or for distribution with Cuis shall be presumed subject to the same license. - -Portions of Cuis are: -Copyright (c) Xerox Corp. 1981, 1982 -Copyright (c) Apple Computer, Inc. 1985-1996 -Copyright (c) Contributors to Squeak and Cuis projects. 1997-2019')! ! -!Utilities class methodsFor: 'default desktop' stamp: 'jmv 9/3/2019 11:05:35' prior: 50470294! - recreateDefaultDesktop - | editor | - Utilities runningWorld hideTaskbar. - TranscriptWindow allInstancesDo: [ :t | t delete ]. - SystemWindow allInstancesDo: [ :t | t delete ]. - TranscriptWindow openTranscript - morphPosition: 5 @ 290; - morphExtent: 990 @ 400. - editor _ TextEditor openTextEditor - morphPosition: 456 @ 10; - morphExtent: 900 @ 680. - editor setLabel: 'About Cuis'. - editor model actualContents: self pvtDefaultTextEditorContents. - self runningWorld showTaskbar.! ! -!FontFamily class methodsFor: 'initialization' stamp: 'jmv 9/3/2019 11:07:48' prior: 50458045! - defaultFamilyName: aString - | family | - self revisar. "Please remove this hack meant to install larger DejaVu StrikeFonts on demand." - aString = 'DejaVu' ifTrue: [ - family _ AvailableFamilies at: aString. - (family pointSizes includes: DefaultPointSize) ifFalse: [ StrikeFont install: aString]]. - DefaultFamilyName _ aString. - Utilities recreateDefaultDesktop.! ! -!FontFamily class methodsFor: 'initialization' stamp: 'jmv 9/3/2019 11:07:44' prior: 50457077! - defaultPointSize: aNumber - DefaultPointSize _ aNumber. - Utilities recreateDefaultDesktop.! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Utilities recreateDefaultDesktop.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3856-AboutWindowTweaks-JuanVuletich-2019Sep03-11h12m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3856] on 5 September 2019 at 11:18:24 am'! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 9/5/2019 10:58:07'! - createCloseButton - ^ (PluggableButtonMorph model: self action: #closeBoxHit) - icon: Theme current closeIcon; - iconName: #drawCloseIcon; - setBalloonText: 'close this window'; - morphExtent: self titleBarButtonsExtent! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 9/5/2019 10:58:11'! - createCollapseButton - ^(PluggableButtonMorph model: self action: #collapse) - icon: Theme current collapseIcon; - iconName: #drawCollapseIcon; - setBalloonText: 'collapse this window'; - morphExtent: self titleBarButtonsExtent! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 9/5/2019 10:58:40'! - createExpandButton - ^ (PluggableButtonMorph model: self action: #expandBoxHit) - icon: Theme current expandIcon; - iconName: #drawExpandIcon; - setBalloonText: 'expand to full screen'; - morphExtent: self titleBarButtonsExtent! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 9/5/2019 10:58:54'! - createMenuButton - ^ (PluggableButtonMorph model: self action: #offerWindowMenu) - icon: Theme current windowMenuIcon; - iconName: #drawMenuIcon; - setBalloonText: 'window menu'; - morphExtent: self titleBarButtonsExtent! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 9/5/2019 08:17:04'! - titleBarButtonsExtent - "answer the extent to use for close & other title bar buttons. - - the label height is used to be proportional to the fonts preferences" - | e | - Theme current minimalWindows ifTrue: [^`0@0`]. - e _ Preferences windowTitleFont pointSize. - ^e@e! ! -!PluggableButtonMorph methodsFor: 'private' stamp: 'jmv 9/5/2019 08:24:08' prior: 50367719! - magnifiedIcon - | factor magnifiedExtent w h | - - icon ifNil: [ ^nil ]. - magnifiedIcon ifNil: [ - magnifiedIcon _ icon. - w _ icon width. - h _ icon height. - w*h = 0 ifFalse: [ - factor _ 1.0 * extent x / w min: 1.0 * extent y / h. - factor = 1.0 ifFalse: [ - magnifiedExtent _ (icon extent * factor) rounded. - magnifiedIcon _ icon magnifyTo: magnifiedExtent ]]]. - ^magnifiedIcon! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 9/5/2019 08:20:12' prior: 50458058! - drawLabelOn: aCanvas - - | x0 y0 f w availableW l | - f _ Preferences windowTitleFont. - x0 _ f lineSpacing * 4 + 14. - y0 _ 2+3. - y0 _ f lineSpacing - f ascent // 2. - availableW _ extent x - x0. - l _ labelString. - w _ f widthOfString: l. - [ w > availableW ] whileTrue: [ - l _ l squeezedTo: (1.0 * l size * availableW / w) truncated. - l isEmpty ifTrue: [ ^self ]. - w _ f widthOfString: l ]. - aCanvas - drawString: l - at: x0@y0 - font: f - color: Theme current windowLabel - embossed: Theme current embossedTitles! ! -!SystemWindow methodsFor: 'geometry' stamp: 'jmv 9/5/2019 08:36:52' prior: 50384678! - rescaleButtons - "boxExtent changed. Update my buttons." - | buttonPos buttonExtent buttonDelta| - buttonExtent := self titleBarButtonsExtent. - buttonPos _ self labelHeight + borderWidth - buttonExtent // 2 * (1@1). - buttonDelta _ buttonExtent x *14//10. - self submorphsReverseDo: [ :aMorph | - (aMorph is: #PluggableButtonMorph) - ifTrue: [ - aMorph morphExtent: buttonExtent. - aMorph morphPosition: buttonPos. - buttonPos _ buttonPos + (buttonDelta@0). - ]. - ]! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 9/5/2019 08:31:34' prior: 50384737! - initializeLabelArea - "Initialize the label area (titlebar) for the window." - - | topLeft spacing | - topLeft _ self labelHeight + borderWidth - self titleBarButtonsExtent // 2 * (1@1). - spacing _ self titleBarButtonsExtent x *14//10. - self addMorph: self createCloseButton position: topLeft. - self addMorph: self createCollapseButton position: spacing@0 + topLeft. - self addMorph: self createExpandButton position: spacing*2@0 + topLeft. - self addMorph: self createMenuButton position: spacing*3@0 + topLeft! ! -!SystemWindow methodsFor: 'label' stamp: 'jmv 9/5/2019 08:20:31' prior: 16926332! - labelHeight - "Answer the height for the window label." - - ^ Preferences windowTitleFont lineSpacing+1! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 9/5/2019 11:14:23' prior: 50388172! - addStayUpIcons - | closeButton pinButton w buttonHW | - Preferences optionalButtons ifFalse: [ ^self ]. - (self valueOfProperty: #hasStayUpIcons ifAbsent: [ false ]) - ifTrue: [ - self removeProperty: #needsStayUpIcons. - ^self ]. - titleMorph ifNil: [ - "Title not yet there. Flag ourself, so this method is called again when adding title." - self setProperty: #needsStayUpIcons toValue: true. - ^ self]. - buttonHW _ Preferences windowTitleFont pointSize. - closeButton _ PluggableButtonMorph model: self action: #delete. - closeButton icon: Theme current closeIcon; color: `Color transparent`. - pinButton _ PluggableButtonMorph model: self action: #stayUp. - pinButton icon: Theme current pushPinIcon; color: `Color transparent`. - w _ (titleMorph hasSubmorphs ifTrue: [ titleMorph firstSubmorph morphWidth ] ifFalse: [ 0 ]) + 60. - self addMorphFront: - (LayoutMorph newRow - "Make room for buttons" - morphExtent: w @ (titleMorph morphHeight max: buttonHW); - color: `Color transparent`; - addMorph: closeButton fixedWidth: buttonHW; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedWidth: buttonHW//3; - addMorph: titleMorph proportionalWidth: 1; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedWidth: buttonHW//3; - addMorph: pinButton fixedWidth: buttonHW). - - self setProperty: #hasStayUpIcons toValue: true. - self removeProperty: #needsStayUpIcons! ! - -SystemWindow removeSelector: #boxExtent! - -SystemWindow removeSelector: #boxExtent! - -SystemWindow removeSelector: #createCloseBox! - -SystemWindow removeSelector: #createCloseBox! - -SystemWindow removeSelector: #createCollapseBox! - -SystemWindow removeSelector: #createCollapseBox! - -SystemWindow removeSelector: #createExpandBox! - -SystemWindow removeSelector: #createExpandBox! - -SystemWindow removeSelector: #createMenuBox! - -SystemWindow removeSelector: #createMenuBox! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3857-BetterScalingOfWindowButtons-JuanVuletich-2019Sep05-10h56m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3849] on 3 September 2019 at 11:42:23 pm'! -!SmalltalkEditor methodsFor: 'typing/selecting keys' stamp: 'EB 9/3/2019 23:41:10' prior: 16910020! - newLine: aKeyboardEvent - "Replace the current text selection with a newLine (i.e. LF) followed by as many tabs - as there are leading tabs on the current line (+/- bracket count)." - - | char s i tabCount stopIndex newLineString | - s _ self privateCurrentString. - stopIndex _ self stopIndex. - i _ stopIndex. - tabCount _ 0. - [ (i _ i-1) > 0 and: [ (char _ s at: i) isLineSeparator not ] ] whileTrue: [ - "Count brackets" - char = $[ ifTrue: [tabCount _ tabCount + 1]. - char = $] ifTrue: [tabCount _ tabCount - 1]]. - [ (i _ i + 1) < stopIndex and: [ (char _ s at: i) isSeparator ] ] whileTrue: [ - "Count leading tabs" - char = Character tab ifTrue: [ tabCount _ tabCount + 1 ]]. - "Now inject newline with tabCount tabs, generating a new undoable command" - newLineString _ String streamContents: [ :strm | strm newLineTab: tabCount ]. - self replaceSelectionWith: newLineString shouldMergeCommandsIfPossible: false. - ^ false! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3858-NewLineSeparatesUndo-EricBrandwein-2019Sep03-23h41m-EB.1.cs.st----! - -'From Cuis 5.0 [latest update: #3858] on 5 September 2019 at 11:39:06 am'! -!TextModel methodsFor: 'undoable commands' stamp: 'jmv 9/5/2019 11:35:32'! - startNewUndoRedoCommand - - lastEditTimeStamp _ nil! ! -!TextModel methodsFor: 'undoable commands' stamp: 'jmv 9/5/2019 11:32:02' prior: 50463355! - logUndoAndReplaceFrom: start to: stop with: replacement - "As requested." - - | command now | - "Time millisecondClockValue rolls over and is generally not adviced. - But here, we don't care. A user edit doing during rollover would be split in two, as if the user did a pause. - Not a problem." - - now _ Time millisecondClockValue. - command _ self commandForReplaceFrom: start to: stop with: replacement. - (stop+1 = start and: [ lastEditTimeStamp notNil and: [ now - lastEditTimeStamp < 1000 and: [start = undoRedoCommands last stopPosition] ]]) - ifTrue: [ - "Don't use the command we just built" - undoRedoCommands last appendToNew: replacement - ] - ifFalse: [ - undoRedoCommands - nextPut: command; - truncateAtPosition. "To disable redo of previous commands, now invalidated." - ]. - command doOn: self. - lastEditTimeStamp _ now! ! -!TextEditor methodsFor: 'accessing' stamp: 'jmv 9/5/2019 11:33:21' prior: 50463364! - replaceSelectionWith: aTextOrString - "Deselect, and replace the selection text by aText." - "This is a user command, and generates undo" - - | start stop replacement | - - morph disablesEditing ifTrue: [ - ^ self ]. - - start _ self startIndex. - stop _ self stopIndex. - (aTextOrString isEmpty and: [stop > start]) ifTrue: [ - "If deleting, then set emphasisHere from 1st character of the deletion" - emphasisHere _ (model actualContents attributesAt: start) select: [:att | - att mayBeExtended]]. - - (start = stop and: [ aTextOrString isEmpty ]) ifFalse: [ - replacement _ self addAttributesForPasting: aTextOrString. - model logUndoAndReplaceFrom: start to: stop - 1 with: replacement. - textComposition - recomposeFrom: start - to: start + replacement size - 1 - delta: replacement size - (stop-start). - self deselectAndPlaceCursorAt: start + replacement size. - selectionStartBlocks _ #(). - selectionStopBlocks _ #(). - self userHasEdited " -- note text now dirty" ]. - - morph possiblyChanged! ! -!TextEditor methodsFor: 'new selection' stamp: 'jmv 9/5/2019 11:37:06' prior: 50463374! - insertAndSelect: aString at: anInteger - "This is a user command, and generates undo" - - | newText | - newText _ (aString is: #Text) ifTrue: [aString] ifFalse: [Text string: aString attributes: emphasisHere]. - self deselectAndPlaceCursorAt: anInteger. - self replaceSelectionWith: newText. - self selectFrom: anInteger to: anInteger + newText size - 1! ! -!SmalltalkEditor methodsFor: 'typing/selecting keys' stamp: 'jmv 9/5/2019 11:36:14' prior: 50472062! - newLine: aKeyboardEvent - "Replace the current text selection with a newLine (i.e. LF) followed by as many tabs - as there are leading tabs on the current line (+/- bracket count)." - - | char s i tabCount stopIndex newLineString | - s _ self privateCurrentString. - stopIndex _ self stopIndex. - i _ stopIndex. - tabCount _ 0. - [ (i _ i-1) > 0 and: [ (char _ s at: i) isLineSeparator not ] ] whileTrue: [ - "Count brackets" - char = $[ ifTrue: [tabCount _ tabCount + 1]. - char = $] ifTrue: [tabCount _ tabCount - 1]]. - [ (i _ i + 1) < stopIndex and: [ (char _ s at: i) isSeparator ] ] whileTrue: [ - "Count leading tabs" - char = Character tab ifTrue: [ tabCount _ tabCount + 1 ]]. - "Now inject newline with tabCount tabs, generating a new undoable command" - newLineString _ String streamContents: [ :strm | strm newLineTab: tabCount ]. - model startNewUndoRedoCommand. - self replaceSelectionWith: newLineString. - ^ false! ! -!SmalltalkEditor methodsFor: 'new selection' stamp: 'jmv 9/5/2019 11:37:26' prior: 50463383! - notify: aString at: anInteger in: aStream - "The compilation of text failed. The syntax error is noted as the argument, - aString. Insert it in the text at starting character position anInteger." - "This is a user command, and generates undo" - model startNewUndoRedoCommand. - self insertAndSelect: aString at: (anInteger max: 1).! ! - -TextEditor removeSelector: #insertAndSelect:at:shouldMergeCommandsIfPossible:! - -TextEditor removeSelector: #insertAndSelect:at:shouldMergeCommandsIfPossible:! - -TextEditor removeSelector: #replaceSelectionWith:shouldMergeCommandsIfPossible:! - -TextEditor removeSelector: #replaceSelectionWith:shouldMergeCommandsIfPossible:! - -TextModel removeSelector: #logUndoAndReplaceFrom:to:with:shouldMergeCommandsIfPossible:! - -TextModel removeSelector: #logUndoAndReplaceFrom:to:with:shouldMergeCommandsIfPossible:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3859-TextUndoCleanup-JuanVuletich-2019Sep05-11h32m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3859] on 5 September 2019 at 12:09:26 pm'! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'jmv 9/5/2019 11:57:33' prior: 50420764! - implementorsOfIt - "Open an implementors browser. - If text selection defines a selector, take it. Otherwise, try finding selector under cursor. If this fails, consider the whole line." - - self selectedSelector ifNotNil: [ :selector | - ^ Smalltalk browseAllImplementorsOf: selector ]. - self - withSelectorUnderCursorDo: [ :selector | Smalltalk browseAllImplementorsOf: selector ] - otherwise: [ self implementorsOfItWhenErrorsParsing ]! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'jmv 9/5/2019 11:58:03' prior: 50420779! - sendersOfIt - "Open a senders browser. - If text selection defines a selector, take it. Otherwise, try finding selector under cursor. If this fails, consider the whole line." - - self selectedSelector ifNotNil: [ :selector | - ^ Smalltalk browseAllCallsOn: selector ]. - self - withSelectorUnderCursorDo: [ :selector | Smalltalk browseAllCallsOn: selector ] - otherwise: [ self sendersOfItWhenErrorsParsing ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3860-SendersOfSelectionWhenPartOfOtherSelector-JuanVuletich-2019Sep05-12h08m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3859] on 5 September 2019 at 12:10:04 pm'! -!TextEditor methodsFor: 'new selection' stamp: 'jmv 9/5/2019 12:06:44' prior: 50452755! - messageSendsRanges: aRanges - - selectionStartBlocks := OrderedCollection new. - selectionStopBlocks := OrderedCollection new. - - aRanges do: [ :range | - selectionStartBlocks add: (textComposition characterBlockForIndex: range first). - selectionStopBlocks add: (textComposition characterBlockForIndex: range last + 1) ]. - aRanges notEmpty ifTrue: [ - self selectFrom: aRanges last first to: aRanges last last ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3861-AutoselectFix-JuanVuletich-2019Sep05-12h09m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3861] on 5 September 2019 at 5:43:43 pm'! -!MenuItemMorph methodsFor: 'accessing' stamp: 'jmv 5/1/2018 14:17:12' prior: 50393655! - setIcon: symbolOrFormOrNil - "Argument can be a Form, a Symbol (to be sent to Theme current) or nil." - - icon _ symbolOrFormOrNil isSymbol - ifTrue: [Theme current perform: symbolOrFormOrNil] - ifFalse: [ symbolOrFormOrNil ]! ! -!MenuItemMorph methodsFor: 'drawing' stamp: 'jmv 9/5/2019 17:31:30' prior: 50392651! - drawOn: aCanvas - | stringColor leftEdge | - - stringColor _ color. - isSelected & isEnabled - ifTrue: [ - aCanvas fillRectangle: (`0@0` extent: extent) color: Theme current menuHighlight]. - leftEdge _ 0. - - self hasMarker ifTrue: [ - leftEdge _ leftEdge + submorphs first morphWidth + 8 ]. - - icon ifNotNil: [ - | iconForm w h factor magnifiedExtent magnifiedIcon | - iconForm _ isEnabled ifTrue: [ icon ] ifFalse: [ icon asGrayScaleAndTransparent ]. - magnifiedIcon _ iconForm. - w _ iconForm width. - h _ iconForm height. - w*h = 0 ifFalse: [ - factor _ extent y * 0.8 / h. - factor = 1.0 ifFalse: [ - magnifiedExtent _ (iconForm extent * factor) rounded. - magnifiedIcon _ iconForm magnifyTo: magnifiedExtent ]]. - aCanvas image: magnifiedIcon at: leftEdge+1 @ (magnifiedIcon height *1//10). - leftEdge _ magnifiedIcon width *12//10 + leftEdge]. - - aCanvas - drawString: contents - at: leftEdge @ 1 - font: self fontToUse - color: stringColor. - subMenu ifNotNil: [ - aCanvas - image: self class subMenuMarker - at: extent x - 8 @ (extent y - self class subMenuMarker height // 2) ]! ! -!MenuItemMorph methodsFor: 'layout' stamp: 'jmv 9/5/2019 17:28:38' prior: 50392679! - minItemWidth - | fontToUse iconWidth subMenuWidth markerWidth | - fontToUse _ self fontToUse. - subMenuWidth _ self hasSubMenu - ifFalse: [0] - ifTrue: [10]. - iconWidth _ icon - ifNotNil: [icon width * 12//10] - ifNil: [0]. - markerWidth _ self hasMarker - ifTrue: [ submorphs first morphWidth + 8 ] - ifFalse: [ 0 ]. - ^ (fontToUse widthOfString: contents) - + subMenuWidth + iconWidth + markerWidth.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3862-ScaleMenuIIcons-JuanVuletich-2019Sep05-17h43m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3861] on 5 September 2019 at 5:46:32 pm'! -!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'jmv 9/5/2019 17:41:17' prior: 50453356! - defaultAction - - | delta textFrame barFrame outerFrame result range width filledWidth f h textWidth textForm innerBarFrame oldFilledWidth oldFilledWidth2 prevContents | - f _ AbstractFont default. - h _ f lineSpacing * 3//2. - textWidth _ (f widthOfString: progressTitle) + h. - width _ 150 max: textWidth. - - textForm _ Form extent: width@h depth: 32. - textForm fillBlack. - textForm fillWhite: (textForm boundingBox insetBy: 2). - progressTitle displayOn: textForm at: (width-textWidth+h//2@4). - barFrame _ Rectangle center: aPoint extent: width@h. - textFrame _ `0@0` extent: width@h. - textFrame _ textFrame - aligned: textFrame bottomCenter - with: barFrame topCenter + `0@2`. - outerFrame _ barFrame merge: textFrame. - delta _ outerFrame amountToTranslateWithin: Display boundingBox. - barFrame _ barFrame translatedBy: delta. - textFrame _ textFrame translatedBy: delta. - outerFrame _ outerFrame translatedBy: delta. - prevContents _ Form fromDisplay: outerFrame. - range _ maxVal = minVal ifTrue: [1] ifFalse: [maxVal - minVal]. "Avoid div by 0" - innerBarFrame _ barFrame insetBy: 2. - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - oldFilledWidth _ 0. - oldFilledWidth2 _ 0. - result _ workBlock value: "Supply the bar-update block for evaluation in the work block" - [ :barVal | - barVal - ifNotNil: [ currentVal _ barVal ] - ifNil: [ - currentVal _ currentVal + 1. - currentVal >= maxVal - ifTrue: [ currentVal _ minVal ]]. - filledWidth _ ((barFrame width-4) asFloat * ((currentVal-minVal) asFloat / range min: 1.0)) asInteger. - filledWidth > oldFilledWidth ifTrue: [ - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - Display fillGray: (barFrame topLeft + `2@2` extent: filledWidth@(h-4)). - filledWidth -200 > oldFilledWidth2 - ifFalse: [ - "Usually just request an update, to be done asynchronously." - DisplayScreen screenUpdateRequired: outerFrame ] - ifTrue: [ - "Once in a while, force a real screen update (warning: really slow on MacOS if done too often)" - Display forceToScreen: outerFrame. oldFilledWidth2 _ filledWidth ]. - oldFilledWidth _ filledWidth ]]. - prevContents displayAt: outerFrame topLeft. - self resume: result! ! -!ProgressMorph methodsFor: 'initialization' stamp: 'jmv 9/5/2019 17:34:15' prior: 50385518! - initialize - super initialize. - self separation: 0. - labelMorph _ StringMorph contents: '' font: AbstractFont default. - subLabelMorph _ StringMorph contents: '' font: AbstractFont default. - progress _ ProgressBarMorph new. - progress morphExtent: 200 @ AbstractFont default lineSpacing. - self addMorphFront: labelMorph. - self addMorphFront: subLabelMorph. - self addMorph: progress fixedHeight: AbstractFont default lineSpacing! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3863-BetterScalingOfProgressBars-JuanVuletich-2019Sep05-17h43m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3863] on 5 September 2019 at 6:18:36 pm'! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 9/5/2019 18:12:41' prior: 50457111! - restoreDefaultFonts - "Since this is called from menus, we can take the opportunity to prompt for missing font styles. - Preferences restoreDefaultFonts - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 9) - (setMenuFontTo: 10) - (setWindowTitleFontTo: 12) - (setCodeFontTo: 9) - (setButtonFontTo: 9) - (setSystemFontTo: 9))! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/5/2019 18:08:38' prior: 50457146! - defaultFont05 - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences defaultFont05 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 5) - (setMenuFontTo: 5) - (setWindowTitleFontTo: 7) - (setCodeFontTo: 5) - (setButtonFontTo: 5) - (setSystemFontTo: 7)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/5/2019 18:09:16' prior: 50457165! - defaultFont06 - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences defaultFont06 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 6) - (setMenuFontTo: 6) - (setWindowTitleFontTo: 8) - (setCodeFontTo: 6) - (setButtonFontTo: 6) - (setSystemFontTo: 7)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/5/2019 18:09:35' prior: 50457184! - defaultFont07 - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences defaultFont07 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 7) - (setMenuFontTo: 7) - (setWindowTitleFontTo: 9) - (setCodeFontTo: 7) - (setButtonFontTo: 7) - (setSystemFontTo: 8)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/5/2019 18:10:10' prior: 50457203! - defaultFont08 - "Sets not only fonts but other GUI elements - to fit low resolution or small screens - Preferences defaultFont08 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 8) - (setMenuFontTo: 8) - (setWindowTitleFontTo: 11) - (setCodeFontTo: 8) - (setButtonFontTo: 8) - (setSystemFontTo: 8)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/5/2019 18:10:36' prior: 50457221! - defaultFont09 - "Sets not only fonts but other GUI elements - to fit low resolution or small screens - Preferences defaultFont09 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 9) - (setMenuFontTo: 10) - (setWindowTitleFontTo: 12) - (setCodeFontTo: 9) - (setButtonFontTo: 9) - (setSystemFontTo: 9)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/5/2019 18:10:45' prior: 50457239! - defaultFont10 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont10 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 10) - (setMenuFontTo: 11) - (setWindowTitleFontTo: 12) - (setCodeFontTo: 10) - (setButtonFontTo: 10) - (setSystemFontTo: 10)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/5/2019 18:10:56' prior: 50457258! - defaultFont11 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont11 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 11) - (setMenuFontTo: 12) - (setWindowTitleFontTo: 14) - (setCodeFontTo: 11) - (setButtonFontTo: 11) - (setSystemFontTo: 11)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/5/2019 18:11:03' prior: 50457277! - defaultFont12 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont12 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 12) - (setMenuFontTo: 12) - (setWindowTitleFontTo: 14) - (setCodeFontTo: 12) - (setButtonFontTo: 12) - (setSystemFontTo: 12)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/5/2019 18:11:11' prior: 50457296! - defaultFont14 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont14 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 14) - (setMenuFontTo: 14) - (setWindowTitleFontTo: 17) - (setCodeFontTo: 14) - (setButtonFontTo: 14) - (setSystemFontTo: 14)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/5/2019 18:11:20' prior: 50457315! - defaultFont17 - "Sets not only fonts but other GUI elements - to fit high resolution or large screens - Preferences defaultFont17 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 17) - (setMenuFontTo: 17) - (setWindowTitleFontTo: 22) - (setCodeFontTo: 17) - (setButtonFontTo: 17) - (setSystemFontTo: 17)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/5/2019 18:11:26' prior: 50457333! -defaultFont22 - "Sets not only fonts but other GUI elements - to fit high resolution or large screens - Preferences defaultFont22 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 22) - (setMenuFontTo: 22) - (setWindowTitleFontTo: 28) - (setCodeFontTo: 22) - (setButtonFontTo: 22) - (setSystemFontTo: 22)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/5/2019 18:11:46' prior: 50457351! -defaultFont28 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont28 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 28) - (setMenuFontTo: 28) - (setWindowTitleFontTo: 36) - (setCodeFontTo: 28) - (setButtonFontTo: 28) - (setSystemFontTo: 28)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/5/2019 18:11:56' prior: 50457370! - defaultFont36 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont36 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 36) - (setMenuFontTo: 36) - (setWindowTitleFontTo: 46) - (setCodeFontTo: 36) - (setButtonFontTo: 36) - (setSystemFontTo: 36)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/5/2019 18:12:11' prior: 50457389! - defaultFont46 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont46 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 46) - (setMenuFontTo: 46) - (setWindowTitleFontTo: 60) - (setCodeFontTo: 46) - (setButtonFontTo: 46) - (setSystemFontTo: 46)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/5/2019 18:12:19' prior: 50457408! - defaultFont60 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont60 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 60) - (setMenuFontTo: 60) - (setWindowTitleFontTo: 80) - (setCodeFontTo: 60) - (setButtonFontTo: 60) - (setSystemFontTo: 60)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/5/2019 18:12:31' prior: 50457427! - defaultFont80 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont80 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 80) - (setMenuFontTo: 80) - (setWindowTitleFontTo: 80) - (setCodeFontTo: 80) - (setButtonFontTo: 80) - (setSystemFontTo: 80)). - Preferences enable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!UpdatingStringMorph class methodsFor: 'new-morph participation' stamp: 'jmv 9/5/2019 17:51:19' prior: 50457568! - initializedInstance - "Answer a digital clock" - - | newInst | - newInst := self - contents: '' - font: Preferences windowTitleFont - emphasis: AbstractFont boldCode. - newInst - stepTime: 500; "half a second" - target: [String streamContents: [ :strm | DateAndTime now printHMSOn: strm]] ; - getSelector: #value. - - ^ newInst! ! -!TaskbarMorph methodsFor: 'initialization' stamp: 'jmv 9/5/2019 17:59:48' prior: 50337223! - initialize - super initialize. - viewBox _ LayoutMorph newRow color: self defaultColor. - self - addMorph: UpdatingStringMorph initializedInstance - layoutSpec: (LayoutSpec morphWidthProportionalHeight: 0.5). - self - addMorph: viewBox - layoutSpec: (LayoutSpec - proportionalWidth: 1.0 - proportionalHeight: 1.0 - minorDirectionPadding: #right). - viewBox separation: self defaultHeight // 8 -! ! -!FontChanger class methodsFor: 'changing font' stamp: 'jmv 9/5/2019 18:08:23' prior: 50457666! - changeTo: aFontName - "Change the font on the whole system without changing point sizes." - FontFamily defaultFamilyName: aFontName. - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: { - {#setListFontTo:. Preferences standardListFont pointSize.}. - {#setMenuFontTo:. Preferences standardMenuFont pointSize.}. - {#setWindowTitleFontTo:. Preferences windowTitleFont pointSize.}. - {#setCodeFontTo:. Preferences standardCodeFont pointSize.}. - {#setButtonFontTo:. Preferences standardButtonFont pointSize.}. - {#setSystemFontTo:. FontFamily defaultPointSize}. - }. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]. - -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3864-BetterScalingOfTaskbar-JuanVuletich-2019Sep05-18h17m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3864] on 5 September 2019 at 7:58:35 pm'! -!MessageNode methodsFor: 'private' stamp: 'jmv 6/13/2019 08:52:31' prior: 50471660! - pvtCheckForPvtSelector: encoder - "If the code being compiled is trying to send a private message (e.g. 'pvtCheckForPvtSelector:') to anyone other than self, then complain to encoder." - - selector isInitializePvtSelector ifTrue: [ - (receiver isSelfNewMessageSend or: [receiver isSelfBasicNewMessageSend]) ifFalse: [ - encoder notify: 'Private instance initialization messages may only be sent to ''self new'' or "self basicNew" (by class instance creation methods)']]. - selector isPvtSelector ifTrue: [ - (receiver isSelfPseudoVariable or: [ receiver isSuperPseudoVariable ]) ifFalse: [ - encoder notify: 'Private messages may only be sent to self or super']].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3865-RemoveSpuriousHalt-JuanVuletich-2019Sep05-19h58m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3865] on 6 September 2019 at 10:37:54 am'! -!Utilities class methodsFor: 'default desktop' stamp: 'jmv 9/6/2019 09:31:05'! - defaultTextEditorContents - ^ (' -', -('Cuis Smalltalk - -' centered blue pointSize: FontFamily defaultPointSize * 3), -(' -"Yay, Juan. You GO, guy!! ...a great example of malleable software (and a clever mind) at work." -' rightFlush pointSize: FontFamily defaultPointSize * 0.6), -('Dan Ingalls -' italic rightFlush pointSize: FontFamily defaultPointSize * 0.6), -(' -"I like it... It''s nice and clean and simple and pretty. Nice stuff!!" -' rightFlush pointSize: FontFamily defaultPointSize * 0.6), -('Alan Kay -' italic rightFlush pointSize: FontFamily defaultPointSize * 0.6), -(' -"I think you have a very elegant design aesthetic." -' rightFlush pointSize: FontFamily defaultPointSize * 0.6), -('John Maloney -'italic rightFlush pointSize: FontFamily defaultPointSize * 0.6), -' - -', -'Cuis is a modern, Open Source, multiplatform, Smalltalk-80 system. - - -', -'Cuis is: - -' bold, -' - Small - - Clean - - Appropriable -' blue, -' - -Additionally, Cuis is: - -' bold, -' - Open Source - - Multiplatform -' blue, -' - -Like other Smalltalk systems, Cuis is also: - -' bold, -' - A complete development environment written in itself - - A pure, dynamic Object Oriented language -' blue, -' - -Cuis assumes very little on the underlying platform, and this lets it run out-of-the-box on Windows, MacOS, Linux, ChromeOS and WebBrowsers. Cuis shares the [OpenSmalltalk Virtual Machine] (http://www.opensmalltalk.org) with Squeak, Pharo and Newspeak. - -What sets Cuis apart from the other members of the Squeak family is the focus on Smalltalk-80 and an active attitude towards system complexity: - -Unbound complexity growth, together with development strategies focused only in the short term, are the worst long term enemies of all software systems. As systems grow older, they usually become more complex. New features are added as layers on top of whatever is below, sometimes without really understanding it, and almost always without modifying it. Complexity and size grow without control. Evolution slows down. Understanding the system becomes harder every day. Bugs are harder to fix. Codebases become huge for no clear reason. At some point, the system can''t evolve anymore and becomes "legacy code". - -Complexity puts a limit to the level of understanding of the system a person might reach, and therefore limits the things that can be done with it. Dan Ingalls says all this in ["Design Principles Behind Smalltalk"] (http://www.cs.virginia.edu/~evans/cs655/readings/smalltalk.html). Even if you have already done so, please go and read it again!! - -Cuis Smalltalk is our attempt at this challenge. Furthermore, we believe we are doing something else that no other Smalltalk, commercial or open source, does. We attempt to give the true Smalltalk-80 experience, and keep Smalltalk-80 not as legacy software historic significance, but as a live, evolving system. We feel we are the keepers of the Smalltalk-80 heritage, and enablers of the Dynabook experience. - -As Cuis evolves, we keep on these values. Every update, be it a bug fix or a feature enhancement, is reviewed carefully to avoid adding unneded complexity to the system. Every opportunity to remove unneded complexity is followed. As we go, features are enhanced, and any reported bugs fixed. We also adopt selected enhancements from Squeak and Pharo, and share our work with the wider Smalltalk community. - - -' justified, -'License -' bold, -' -Cuis is distributed subject to the MIT License, as in http://www.opensource.org/licenses/mit-license.php . Any contribution submitted for incorporation into or for distribution with Cuis shall be presumed subject to the same license. - -Portions of Cuis are: -Copyright (c) Xerox Corp. 1981, 1982 -Copyright (c) Apple Computer, Inc. 1985-1996 -Copyright (c) Contributors to Squeak and Cuis projects. 1997-2019')! ! -!FontFamily class methodsFor: 'initialization' stamp: 'jmv 9/6/2019 09:41:59'! - defaultFamilyName: aStringOrNil defaultPointSize: aNumberOrNil - "Nil just means leave it as it is now." - | family | - aStringOrNil ifNotNil: [DefaultFamilyName _ aStringOrNil]. - aNumberOrNil ifNotNil: [DefaultPointSize _ aNumberOrNil]. - self revisar. "Please remove this hack meant to install larger DejaVu StrikeFonts on demand." - DefaultFamilyName = 'DejaVu' ifTrue: [ - family _ AvailableFamilies at: DefaultFamilyName. - (family pointSizes includes: DefaultPointSize) ifFalse: [ StrikeFont install: DefaultFamilyName]]. - UISupervisor ui ifNotNil: [ :world | world recreateDefaultDesktop ].! ! -!PasteUpMorph methodsFor: 'defaul desktop' stamp: 'jmv 9/6/2019 09:35:32'! -recreateDefaultDesktop - | editor | - self whenUIinSafeState: [ - self hideTaskbar. - submorphs - do: [ :ea | - (ea class == SystemWindow) ifTrue: [ ea delete ]. - (ea class == TranscriptWindow) ifTrue: [ ea delete ]]. - TranscriptWindow openTranscript - morphPosition: 5 @ 290; - morphExtent: 990 @ 400. - editor _ TextEditor openTextEditor - morphPosition: 456 @ 10; - morphExtent: 900 @ 680. - editor setLabel: 'About Cuis'. - editor model actualContents: Utilities defaultTextEditorContents. - self showTaskbar. - ].! ! -!PasteUpMorph methodsFor: 'defaul desktop' stamp: 'jmv 9/6/2019 09:35:42'! - tearDownDesktop - self whenUIinSafeState: [ - self hideTaskbar. - submorphs - do: [ :ea | (ea is: #SystemWindow) ifTrue: [ ea delete ]]].! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 9/6/2019 10:37:39' prior: 50470789! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag - "WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " - | activeProc | - activeProc _ Processor activeProcess. - [ | isARealStartup guiRootObject guiRootObjectClass | - save not & quit - ifTrue: [ - (SourceFiles at: 2) ifNotNil: [ :changes | - ChangesInitialFileSize ifNotNil: [ changes truncate: ChangesInitialFileSize ]]] - ifFalse: [ - self - logSnapshot: save - andQuit: quit ]. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | - each isInWorld ifTrue: [ - each delete.]]. - UISupervisor ui tearDownDesktop. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - "Cosas que levanto explicitamente abajo" - guiRootObjectClass _ UISupervisor ui class. - guiRootObject _ UISupervisor ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "guiRootObject _ clearAllStateFlag ifFalse: [ UISupervisor ui ]." - UISupervisor stopUIProcess. - activeProc isTerminated ifFalse: [ activeProc terminate ]. - "Clean Globals" - Smalltalk - at: #Sensor - put: nil. - Smalltalk - at: #Display - put: nil. - Smalltalk closeSourceFiles. - Smalltalk - at: #SourceFiles - put: nil. - Smalltalk allClassesDo: [ :cls | - cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | - cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ Smalltalk printStuffToCleanOnImageSave ]. - "Do image save & quit as apropriate" - (Cursor cursorAt: #writeCursor) activateCursor. - save - ifTrue: [ - "The snapshot primitive answers false if it was just called to do the snapshot. - But image startup is resumed by returning (again) from the primitive, but this time answering true." - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk - at: #Sensor - put: nil. - Smalltalk - at: #Display - put: DisplayScreen new. - Smalltalk - at: #SourceFiles - put: (Array new: 2). - Smalltalk openSourceFiles. - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | - cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - UISupervisor spawnNewMorphicProcessFor: (guiRootObject ifNil: [ guiRootObject _ guiRootObjectClass newWorld ]). - Display triggerEvent: #screenSizeChanged. - self restoreLostChangesIfNecessary. - clearAllStateFlag ifTrue: [ - UISupervisor whenUIinSafeState: [ - guiRootObject recreateDefaultDesktop ]]. - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - UISupervisor whenUIinSafeState: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]] - forkAt: Processor timingPriority - 1 - named: 'Startup process'.! ! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 9/6/2019 09:22:28' prior: 50457082! - setSystemFontTo: aFont - "Establish the default text font and style" - - aFont ifNil: [^ self]. - FontFamily defaultFamilyName: aFont familyName defaultPointSize: aFont pointSize.! ! -!FontFamily class methodsFor: 'initialization' stamp: 'jmv 9/6/2019 09:42:26' prior: 50471825! - defaultFamilyName: aString - self defaultFamilyName: aString defaultPointSize: nil! ! -!FontFamily class methodsFor: 'initialization' stamp: 'jmv 9/6/2019 09:42:35' prior: 50471840! - defaultPointSize: aNumber - self defaultFamilyName: nil defaultPointSize: aNumber! ! - -Utilities class removeSelector: #pvtDefaultTextEditorContents! - -Utilities class removeSelector: #pvtDefaultTextEditorContents! - -Utilities class removeSelector: #recreateDefaultDesktop! - -Utilities class removeSelector: #recreateDefaultDesktop! - -Utilities class removeSelector: #tearDownDesktop! - -Utilities class removeSelector: #tearDownDesktop! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3866-FixSaveAsNewVersion-JuanVuletich-2019Sep06-10h35m-jmv.1.cs.st----! - -----SNAPSHOT----(6 September 2019 11:34:17) Cuis5.0-3866-v3.image priorSource: 4420487! - -----QUIT----(6 September 2019 11:34:41) Cuis5.0-3866-v3.image priorSource: 4530573! - -----STARTUP---- (15 November 2019 09:45:21) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-3866-v3.image! - - -'From Cuis 5.0 [latest update: #3866] on 7 September 2019 at 8:37:40 pm'! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/7/2019 20:20:19' prior: 50437046! - bigFonts - "Sets not only fonts but other GUI elements - to fit regular resolution and size screens - Preferences bigFonts - " - - self defaultFont17! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/7/2019 20:34:57' prior: 50472502! - defaultFont05 - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences defaultFont05 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 5) - (setMenuFontTo: 6) - (setWindowTitleFontTo: 7) - (setCodeFontTo: 5) - (setButtonFontTo: 5) - (setSystemFontTo: 6)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/7/2019 20:34:46' prior: 50472521! - defaultFont06 - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences defaultFont06 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 6) - (setMenuFontTo: 7) - (setWindowTitleFontTo: 8) - (setCodeFontTo: 6) - (setButtonFontTo: 6) - (setSystemFontTo: 7)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/7/2019 20:34:28' prior: 50472540! - defaultFont07 - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences defaultFont07 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 7) - (setMenuFontTo: 8) - (setWindowTitleFontTo: 9) - (setCodeFontTo: 7) - (setButtonFontTo: 7) - (setSystemFontTo: 8)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/7/2019 20:34:19' prior: 50472559! - defaultFont08 - "Sets not only fonts but other GUI elements - to fit low resolution or small screens - Preferences defaultFont08 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 8) - (setMenuFontTo: 9) - (setWindowTitleFontTo: 10) - (setCodeFontTo: 8) - (setButtonFontTo: 8) - (setSystemFontTo: 8)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/7/2019 20:33:57' prior: 50472577! - defaultFont09 - "Sets not only fonts but other GUI elements - to fit low resolution or small screens - Preferences defaultFont09 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 9) - (setMenuFontTo: 10) - (setWindowTitleFontTo: 11) - (setCodeFontTo: 9) - (setButtonFontTo: 9) - (setSystemFontTo: 9)). - Preferences disable: #biggerCursors. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/7/2019 20:20:33' prior: 50437180! - hugeFonts - "Sets not only fonts but other GUI elements - to fit regular resolution and size screens - Preferences hugeFonts - " - - self defaultFont28! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/7/2019 20:24:07' prior: 50437188! - smallFonts - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences smallFonts - " - - self defaultFont11! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/7/2019 20:20:10' prior: 50437205! - standardFonts - "Sets not only fonts but other GUI elements - to fit regular resolution and size screens - Preferences standardFonts - " - - self defaultFont14! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/7/2019 20:24:24' prior: 50437214! - tinyFonts - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences tinyFonts - " - - self defaultFont06! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/7/2019 20:20:29' prior: 50437196! - veryBigFonts - "Sets not only fonts but other GUI elements - to fit regular resolution and size screens - Preferences veryBigFonts - " - - self defaultFont22! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 9/7/2019 20:24:18' prior: 50437223! - verySmallFonts - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences verySmallFonts - " - - self defaultFont08! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3867-FontSizeChoicesTweaks-JuanVuletich-2019Sep07-20h03m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3867] on 8 September 2019 at 7:37:20 pm'! -!FontChanger class methodsFor: 'changing font' stamp: 'jmv 9/8/2019 19:30:55' prior: 50472832! - changeTo: aFontName - "Change the font on the whole system without changing point sizes." - FontFamily defaultFamilyName: aFontName. - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: { - {#setListFontTo:. Preferences standardListFont pointSize.}. - {#setMenuFontTo:. Preferences standardMenuFont pointSize.}. - {#setWindowTitleFontTo:. Preferences windowTitleFont pointSize.}. - {#setCodeFontTo:. Preferences standardCodeFont pointSize.}. - {#setButtonFontTo:. Preferences standardButtonFont pointSize.}. - }. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]. - -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3868-FontChangeFix-JuanVuletich-2019Sep08-19h36m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3846] on 9 September 2019 at 8:58:25 am'! -!Object methodsFor: 'associating' stamp: 'HAW 9/9/2019 08:57:04' prior: 16880944! - -> anObject - "Answer an Association between self and anObject" - - ^Association key: self value: anObject! ! -!Browser methodsFor: 'class list' stamp: 'HAW 9/9/2019 08:56:20' prior: 50407177! - createHierarchyTreeOf: col - - "Create a tree from a flat collection of classes" - - | transformed | - - transformed := col collect: [:ea | - | childs indexes | - childs := col select: [:class | class superclass = ea]. - indexes := childs collect: [:child | col indexOf: child]. - Association key: ea value: indexes]. - transformed copy do: [:ea | - ea value: (ea value collect: [:idx | - | val | - val := transformed at: idx. - transformed at: idx put: nil. - val])]. - ^ transformed select: [:ea | ea notNil]. -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3869-BrowserFixWhenAssociationMessageRedefined-HernanWilkinson-2019Sep09-08h55m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3869] on 12 September 2019 at 12:53:24 pm'! -!TextEditor class methodsFor: 'keyboard shortcut tables' stamp: 'jmv 9/12/2019 11:05:51' prior: 50449953! - basicCmdShortcutsSpec - " - Editor initialize - " - - "arranged in QWERTY keyboard order" - ^#( - #( $( #enclose: 'Enclose within ( and ), or remove enclosing ( and )') - #( $[ #enclose: 'Enclose within [ and ], or remove enclosing [ and ]') - #( ${ #enclose: 'Enclose within { and }, or remove enclosing { and }') - #( $' #enclose: 'Enclose within single quotes, or remove enclosing single quotes') - #( $" #enclose: 'Enclose within double quotes, or remove enclosing double quotes') - #( $` #enclose: 'Enclose within backticks, or remove enclosing backticks') - #( $< #enclose: 'Enclose within < and >, or remove enclosing < and >') - - #( $a #selectAll: 'Select all') - #( $f #find: 'Find') - #( $g #findAgain: 'Find again') - #( $h #help: 'Open this help') - #( $j #setSearchString: 'Set selection as search string for find again') - - #( $z #undo: 'Undo (multiple levels)') - #( $x #cut: 'Cut selection and store it in the Clipboard') - #( $c #copySelection: 'Copy selection to the Clipboard') - #( $v #paste: 'Paste Clipboard contents') - - #( $Y #makeUppercase: 'Force selection to uppercase') - #( $U #changeLineEndsToLf: 'Convert line endings to LF characters (Cuis convention) in selection') - - #( $H #cursorTopHome: 'Move cursor to start of text') - - #( $Z #redo: 'Redo (multiple levels)') - #( $X #makeLowercase: 'Force selection to lowercase') - #( $C #compareToClipboard: 'Compare argument to clipboard') - )! ! -!SmalltalkEditor class methodsFor: 'keyboard shortcut tables' stamp: 'jmv 9/12/2019 11:10:04' prior: 50449034! - cmdShortcutsSpec - " - Editor initialize - " - "arranged in QWERTY keyboard order" - ^#( - #( $r #acceptAndDebugTest: 'Saves method and debugs it') - #( $t #acceptAndTest: 'Saves method, runs it as test and then all tests in class. Opens debugger if error') - #( $y #acceptAndTestAll: 'Saves method, runs it as test and then all tests in class category. Opens debugger if error') - #( $i #inspectIt: 'Inspect it (selection is a valid expression, or selection is over an inspect-ilst)') - #( $p #printIt: 'Print it (selection is a valid expression)') - - #( $s #save: 'Save (i.e. accept)') - #( $d #doIt: 'Do it (selection is a valid expression)') - - #( $b #browseIt: 'Browse it (selection is a class name or cursor is over a class-list or message-list)') - #( $n #sendersOfIt: 'Senders of it (selection is a message selector or cursor is over a class-list or message-list)') - #( $m #implementorsOfIt: 'Implementors of it (selection is a message selector or cursor is over a class-list or message-list)') - - #( $E #methodStringsContainingit:'Method strings containing it') - #( $I #exploreIt: 'Inspect via Object Explorer') - - #( $Q #argPrev: 'Previous argument') - #( $W #argNext: 'Next argument') - #( $D #debugIt: 'Debug it') - - #( $N #referencesToIt: 'References to it (selection is a class name, or cursor is over a class-list or message-list)') - )! ! -!RefactoringMenues class methodsFor: 'editor menus' stamp: 'jmv 9/12/2019 11:19:24' prior: 50469343! - smalltalkEditorMenuOptions - - ^`{ - { - #itemGroup -> 35. - #itemOrder -> 10. - #label -> 'Rename... (R)'. - #selector -> #contextualRename. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 20. - #label -> 'Add Parameter... (A)'. - #selector -> #contextualAddParameter. - #icon -> #listAddIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 30. - #label -> 'Remove Parameter... (S)'. - #selector -> #contextualRemoveParameter. - #icon -> #listRemoveIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 40. - #label -> 'Temporary to Instance Variable (O)'. - #selector -> #temporaryToInstanceVariable. - #icon -> #saveAsIcon - } asDictionary. - - }`! ! -!RefactoringMenues class methodsFor: 'shortcuts' stamp: 'jmv 9/12/2019 11:15:55' prior: 50469373! - smalltalkEditorCmdShortcutsSpec - - ^#( - #( $R #contextualRename: 'Renames what is under cursor') - #( $A #contextualAddParameter: 'Adds parameter to message that is under cursor') - #( $S #contextualRemoveParameter: 'Removes parameter to message that is under cursor') - #( $O #temporaryToInstanceVariable: 'Extracts temporary variable to instance variable')) -! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Editor initialize! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3870-EditorShortcutsTweaks-HernanWilkinson-JuanVuletich-2019Sep12-12h52m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3870] on 12 September 2019 at 1:04:57 pm'! -!Editor methodsFor: 'typing/selecting keys' stamp: 'jmv 9/12/2019 13:03:45' prior: 16836711! - returnKey: aKeyboardEvent - "Return / Enter / key was pressed" - "Process the various Return / Enter keystrokes" - - morph acceptOnCR ifTrue: [ - ^ true]. - aKeyboardEvent commandAltKeyPressed print ifTrue: [ - (aKeyboardEvent controlKeyPressed | aKeyboardEvent rawMacOptionKeyPressed) print ifTrue: [ - self addString: String crString. - ^false ]. - self addString: String crlfString. - ^false ]. - ^ self newLine: aKeyboardEvent! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3871-crLf-cr-keystrokes-JuanVuletich-2019Sep12-12h56m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3871] on 16 September 2019 at 11:53:10 am'! -!TestResult methodsFor: 'running' stamp: 'FJG 9/16/2019 11:52:06' prior: 50422903! - runCase: aTestCase - - | testCasePassed | - - testCasePassed _ - [ - [ - self reportAboutToRun: aTestCase. - aTestCase runCase. - self reportPassed: aTestCase. - true] - on: self class failure - do: [ :signal | - self reportFailed: aTestCase because: signal. - (self failures isEmpty or: [ failures last ~~ aTestCase ]) - ifTrue: [ failures add: aTestCase ]. - signal sunitExitWith: false ]] - on: self class error - do: [ :signal | - self reportError: aTestCase because: signal. - aTestCase errored: signal. - self errors add: aTestCase. - signal sunitExitWith: false ]. - - testCasePassed - ifTrue: [ self passed add: aTestCase ]! ! -!TestResult methodsFor: 'logging' stamp: 'FJG 9/16/2019 11:52:20'! - reportAboutToRun: aTestCase - - Transcript show: 'Will run: '; print: aTestCase; newLine! ! -!TestResult methodsFor: 'logging' stamp: 'FJG 9/16/2019 11:52:23'! - reportError: aTestCase because: anException - - Transcript print: anException; newLine.! ! -!TestResult methodsFor: 'logging' stamp: 'FJG 9/16/2019 11:52:27'! - reportFailed: aTestCase because: anException - - Transcript print: anException; newLine. - ! ! -!TestResult methodsFor: 'logging' stamp: 'FJG 9/16/2019 11:52:30'! - reportPassed: aTestCase - - Transcript show: 'finished.'; newLine! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3872-TestResultRefactor-FacundoJavierGelatti-2019Sep16-11h52m-FJG.1.cs.st----! - -'From Cuis 5.0 [latest update: #3871] on 16 September 2019 at 11:54:40 am'! -!StdIOWriteStream methodsFor: 'character writing' stamp: 'FJG 9/15/2019 02:53:23'! - printUtf8CodePoint: utf8CodePoint - "Example: printing a checkmark on the console - 'StdIOWriteStream stdout printUtf8CodePoint: 16r2713; flush.' - " - - | characterBytes | - - characterBytes _ Character utf8BytesOfUnicodeCodePoint: utf8CodePoint. - - self primWrite: fileID from: characterBytes startingAt: 1 count: characterBytes size -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3873-StdIO_Utf8-FacundoJavierGelatti-2019Sep16-11h53m-FJG.1.cs.st----! - -'From Cuis 5.0 [latest update: #3873] on 16 September 2019 at 12:35:33 pm'! -!StdIOWriteStream methodsFor: 'open / close' stamp: 'jmv 9/16/2019 11:23:26' prior: 50332310! - openOnHandle: aFileID name: streamName - "Initialize the instance with the given file handle. - N.B. Do _not_ register the stream. We do not want it to be - closed implicitly (e.g. on GC). There may be multiple instances - accessing the same stream. The stream is not a file." - - fileID _ aFileID. - name _ streamName. - buffer1 _ ByteArray new: 1! ! -!StdIOWriteStream methodsFor: 'streaming' stamp: 'jmv 9/16/2019 12:34:21' prior: 50332329! - nextPut: charOrByte - "Write the given character or byte to this file. - We can handle String (possibly including NCRs) and ByteArray (with utf-8 contents) - - StdIOWriteStream stdout nextPutAll: ('--- r2713; ===' asUtf8: true); flush. - StdIOWriteStream stdout nextPutAll: ('--- ✓ ===' asUtf8: true); flush. - StdIOWriteStream stdout nextPutAll: #[226 156 147]; flush. - StdIOWriteStream stdout nextPutAll: '¿El Ñandú toma agüita?', String newLineString; flush. - StdIOWriteStream stdout nextPutAll: ('¿El Ñandú toma agüita?', String newLineString) asUtf8 ; flush. - See at the end of this method for a larger example with NCRs for arbitrary Unicode - " - charOrByte isNumber ifTrue: [ - buffer1 at: 1 put: charOrByte. - self primWrite: fileID from: buffer1 startingAt: 1 count: 1. - ^ charOrByte ]. - Character - evaluate: [ :byte | self nextPut: byte ] - withUtf8BytesOfUnicodeCodePoint: charOrByte codePoint. - ^ charOrByte -" -StdIOWriteStream stdout nextPutAll: (' -Αα Alpha -Ββ Beta -Γγ Gamma -†δ Delta -Ε„ Epsilon -Ζ… Zeta -Ηη Eta -Θθ Theta -Ιι Iota -Κκ Kappa -Λλ Lambda -Μμ Mu -Νν Nu -Ξξ Xi -Οο Omicron -Πƒ Pi -Ρρ Rho -Σσς Sigma -Ττ Tau -Υυ Upsilon -Φφ Phi -Χχ Chi -Ψψ Psi -‡ω Omega -&# 937;&# 969; Not a NCR, just regular ASCII chars!! -' asUtf8: true); flush -"! ! - -StdIOWriteStream removeSelector: #printUtf8CodePoint:! - -StdIOWriteStream removeSelector: #printUtf8CodePoint:! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -StdIOWriteStream releaseClassCachedState! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3874-StdOut-utf8-JuanVuletich-2019Sep16-12h28m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3852] on 28 August 2019 at 11:20:43 pm'! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'pb 8/28/2019 23:19:53' prior: 50422633! - forceChangesToDisk - "Just flush the buffer and trust the OS to do its job." - | changesFile | - "Expensive and not worth doing, esp. in Windows with antivirus active, when installing large packages" - ChangeSet notInstallOrTestRun ifTrue: [ - changesFile _ SourceFiles at: 2. - changesFile isFileStream ifTrue: [ changesFile flush ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3875-forceChangesToDisk-enough-already-its-2019-PhilBellalouna-2019Aug28-23h07m-pb.1.cs.st----! - -'From Cuis 5.0 [latest update: #3875] on 16 September 2019 at 1:30:10 pm'! - -SimpleServiceEntry removeSelector: #icon! - -SimpleServiceEntry removeSelector: #icon! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3876-remove-icon-method-JuanVuletich-2019Sep16-13h18m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3876] on 16 September 2019 at 1:48:19 pm'! - -Stream subclass: #StdIOWriteStream - instanceVariableNames: 'fileID name buffer1 ' - classVariableNames: 'StdErr StdOut ' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #StdIOWriteStream category: #'System-Support'! -Stream subclass: #StdIOWriteStream - instanceVariableNames: 'fileID name buffer1' - classVariableNames: 'StdErr StdOut' - poolDictionaries: '' - category: 'System-Support'! -!StdIOWriteStream methodsFor: 'streaming' stamp: 'jmv 9/16/2019 13:46:59'! - nextPutAll: aStringOrUTF8Bytes - "Write the given String (possibly including NCRs) or ByteArray (with utf-8 contents) - StdIOWriteStream stdout nextPutAll: '--- r2713; ==='; flush. - StdIOWriteStream stdout nextPutAll: '--- ✓ ==='; flush. - StdIOWriteStream stdout nextPutAll: #[226 156 147]; flush. - StdIOWriteStream stdout nextPutAll: '¿El Ñandú toma agüita?', String newLineString; flush. - StdIOWriteStream stdout nextPutAll: ('¿El Ñandú toma agüita?', String newLineString) asUtf8 ; flush. - See at the end of this method for a larger example with NCRs for arbitrary Unicode - " - | utf8Bytes | - utf8Bytes _ aStringOrUTF8Bytes isString - ifTrue: [ aStringOrUTF8Bytes asUtf8: true ] - ifFalse: [ aStringOrUTF8Bytes ]. - self primWrite: fileID from: utf8Bytes startingAt: 1 count: utf8Bytes size. - ^aStringOrUTF8Bytes -" -StdIOWriteStream stdout nextPutAll: ' -Αα Alpha -Ββ Beta -Γγ Gamma -†δ Delta -Ε„ Epsilon -Ζ… Zeta -Ηη Eta -Θθ Theta -Ιι Iota -Κκ Kappa -Λλ Lambda -Μμ Mu -Νν Nu -Ξξ Xi -Οο Omicron -Πƒ Pi -Ρρ Rho -Σσς Sigma -Ττ Tau -Υυ Upsilon -Φφ Phi -Χχ Chi -Ψψ Psi -‡ω Omega -&# 937;&# 969; Not a NCR, just regular ASCII chars!! -'; flush -"! ! -!StdIOWriteStream methodsFor: 'open / close' stamp: 'jmv 9/16/2019 13:47:35' prior: 50473729! - openOnHandle: aFileID name: streamName - "Initialize the instance with the given file handle. - N.B. Do _not_ register the stream. We do not want it to be - closed implicitly (e.g. on GC). There may be multiple instances - accessing the same stream. The stream is not a file." - - fileID _ aFileID. - name _ streamName.! ! -!StdIOWriteStream methodsFor: 'streaming' stamp: 'jmv 9/16/2019 13:46:29' prior: 50473743! - nextPut: aCharacter - "Write the given character or byte to this file. - StdIOWriteStream stdout nextPut: $a; flush. - " - self nextPutAll: aCharacter asString. - ^aCharacter! ! - -Stream subclass: #StdIOWriteStream - instanceVariableNames: 'fileID name' - classVariableNames: 'StdErr StdOut' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #StdIOWriteStream category: #'System-Support'! -Stream subclass: #StdIOWriteStream - instanceVariableNames: 'fileID name' - classVariableNames: 'StdErr StdOut' - poolDictionaries: '' - category: 'System-Support'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3877-StdOut-Unicode-BetterImplementation-JuanVuletich-2019Sep16-13h42m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3877] on 16 September 2019 at 10:53:22 pm'! -!SimpleServiceEntry methodsFor: 'accessing' stamp: 'jmv 9/16/2019 22:52:17'! - iconSpec - - ^icon! ! -!DropFilesAction methodsFor: 'evaluating - private' stamp: 'jmv 9/16/2019 22:52:28' prior: 50426985! - createMenuFor: options - - | icons lines labels | - - "options is a small collection, no problem to collect twice - Hernan" - labels := options collect: [ :option | option label ]. - icons := options collect: [ :option | option iconSpec ]. - - shouldAskToStop - ifTrue: [ - lines := Array with: labels size. - labels add: 'stop here'. - icons add: #cancelIcon ] - ifFalse: [ lines := #() ]. - - ^PopUpMenu labelArray: labels lines: lines icons: icons! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3878-stFileDnDFix-JuanVuletich-2019Sep16-22h52m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3878] on 19 September 2019 at 5:33:19 pm'! -!TextEditor methodsFor: 'new selection' stamp: 'jmv 9/19/2019 17:31:32' prior: 50472294! - messageSendsRanges: aRanges - "aRanges must be notEmpty" - - selectionStartBlocks := OrderedCollection new. - selectionStopBlocks := OrderedCollection new. - - aRanges do: [ :range | - selectionStartBlocks add: (textComposition characterBlockForIndex: range first). - selectionStopBlocks add: (textComposition characterBlockForIndex: range last + 1) ]. - self selectFrom: aRanges last first to: aRanges last last! ! -!TextModelMorph methodsFor: 'updating' stamp: 'jmv 9/19/2019 17:31:48' prior: 50452624! - selectMessage - - | messageSendsRanges | - - messageSendsRanges := model textProvider messageSendsRangesOf: model autoSelectString. - ^ messageSendsRanges notEmpty - ifTrue: [ self editor messageSendsRanges: messageSendsRanges ]; yourself! ! -!TextModelMorph methodsFor: 'updating' stamp: 'jmv 9/19/2019 17:30:20' prior: 50452662! - updateAutoSelect - - TextEditor abandonChangeText. "no replacement!!" - self selectMessage - ifFalse: [ self selectString ]. - - self textMorph updateFromTextComposition. - ^self scrollSelectionIntoView! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3879-AutoselectFix-JuanVuletich-2019Sep19-17h32m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3852] on 29 August 2019 at 2:41:42 pm'! -!Editor class methodsFor: 'class initialization' stamp: 'jmv 8/29/2019 10:42:05' prior: 50432181! - putIntoCmdShortcuts: shortcutsSpec - - shortcutsSpec do: [ :ary | | i previous | - i _ ary first numericValue + 1. - previous _ cmdShortcuts at: i. - previous = #noop: - ifTrue: [ - cmdShortcuts at: i put: ary second ] - ifFalse: [ ('Editor shortcut: ', ary first printString, ' already taken for: ', previous, '. Override request for: ', ary second, ' ignored') print ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3880-LogAndIgnoreShortcutOverride-JuanVuletich-2019Aug29-14h40m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3870] on 12 September 2019 at 1:04:57 pm'! -!Editor methodsFor: 'typing/selecting keys' stamp: 'jmv 9/12/2019 13:03:45' prior: 50473632! - returnKey: aKeyboardEvent - "Return / Enter / key was pressed" - "Process the various Return / Enter keystrokes" - - morph acceptOnCR ifTrue: [ - ^ true]. - aKeyboardEvent commandAltKeyPressed ifTrue: [ - (aKeyboardEvent controlKeyPressed | aKeyboardEvent rawMacOptionKeyPressed) ifTrue: [ - self addString: String crString. - ^false ]. - self addString: String crlfString. - ^false ]. - ^ self newLine: aKeyboardEvent! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3881-crLf-cr-keystrokes-JuanVuletich-2019Sep19-12h56m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3878] on 18 September 2019 at 8:25:36 pm'! -!Cursor class methodsFor: 'accessing' stamp: 'pb 9/18/2019 20:24:42'! - cursorAt: cursorKey ifAbsent: aBlock - ^ (CursorDict - at: cursorKey - ifAbsent: [ - (self respondsTo: cursorKey) ifTrue: [ | newCursor | - newCursor _ self perform: cursorKey. - newCursor hasMask ifFalse: [ newCursor _ newCursor withMask ]. - self - cursorAt: cursorKey - put: newCursor ]]) ifNil: aBlock.! ! -!Cursor class methodsFor: 'accessing' stamp: 'pb 9/18/2019 20:25:12' prior: 50470403! - cursorAt: cursorKey - ^ self - cursorAt: cursorKey - ifAbsent: [ self defaultCursor ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3882-Cursor-missing-use-default-PhilBellalouna-2019Sep18-20h14m-pb.1.cs.st----! - -'From Cuis 5.0 [latest update: #3866] on 17 September 2019 at 9:46:20 pm'! -!TextEditor methodsFor: 'menu' stamp: 'jpb 9/17/2019 21:44:24'! - addCutAndPasteMenuSectionTo: aMenu - "Adds typical cut and paste operations section to a menu" - - self hasUnacceptedEdits ifTrue: [ - aMenu - add: 'Accept (s)' - action: #acceptContents - icon: #acceptIcon - ]. - - aMenu - add: 'Copy (c)' - action: #copySelection - icon: #copyIcon. - - aMenu - add: 'Cut (x)' - action: #cut - icon: #cutIcon. - - aMenu - add: 'Paste (v)' - action: #paste - icon: #pasteIcon. - - aMenu - add: 'Paste without Format' - action: #pasteString - icon: #pasteIcon. - - aMenu - add: 'Paste...' - action: #pasteRecent - icon: #worldIcon. - - ^aMenu! ! -!TextEditor methodsFor: 'menu' stamp: 'jpb 9/17/2019 21:34:30'! - addFinderMenuSectionTo: aMenu - "Build a submenu with finding related operations" - - aMenu addItemsFromDictionaries: - `{ - { - #label -> 'Find...(f)'. - #selector -> #find. - #icon -> #findIcon - } asDictionary. - { - #label -> 'Find Again (g)'. - #selector -> #findAgain. - #icon -> #systemIcon - } asDictionary. - { - #label -> 'Use Selection for Find (j)'. - #selector -> #setSearchString. - #icon -> #saveAsIcon - } asDictionary. - }`. - ^aMenu! ! -!TextEditor methodsFor: 'menu' stamp: 'jpb 9/17/2019 21:41:04'! - addStyleMenuSectionTo: aMenu - "Adds to the given menu text styiling related operations" - - aMenu - addItemsFromDictionaries: - `{ - { - #label -> 'Toggle WordWrap'. - #selector -> #wrapOnOff. - #icon -> #genericTextIcon - } asDictionary. - { - #label -> 'Set Font... (k)'. - #selector -> #offerFontMenu. - #icon -> #preferencesDesktopFontIcon - } asDictionary. - { - #label -> 'Clear Font'. - #selector -> #clearFont. - #icon -> #newIcon - } asDictionary. - { - #label -> 'Set Default Font...'. - #selector -> #offerDefaultFontMenu. - #icon -> #fontXGenericIcon - } asDictionary. - { - #label -> 'Set Alignment...'. - #selector -> #chooseAlignment. - #icon -> #formatJustifyLeftIcon - } asDictionary. - }`. - ^aMenu! ! -!TextEditor methodsFor: 'menu' stamp: 'jpb 9/17/2019 21:36:55'! - addUndoMenuSectionTo: aMenu - "Adds undo operations to the given menu" - - aMenu - addItemsFromDictionaries: - `{ - nil. - { - #label -> 'Undo - multiple (z)'. - #selector -> #undo. - #icon -> #undoIcon - } asDictionary. - { - #label -> 'Redo - multiple (Z)'. - #selector -> #redo. - #icon -> #redoIcon - } asDictionary. - { - #label -> 'Undo / Redo history'. - #selector -> #offerUndoHistory. - #icon -> #changesIcon - } asDictionary. - }`. - - ^aMenu.! ! -!TextEditor methodsFor: 'menu' stamp: 'jpb 9/17/2019 21:44:32' prior: 50448899! - getMenu - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu - addTitle: self class name; - addStayUpIcons. - - aMenu - add: 'Help...' - action: #openHelp - icon: #helpIcon. - aMenu addLine. - - self addFinderMenuSectionTo: aMenu. - self addUndoMenuSectionTo: aMenu. - aMenu addLine. - - self addCutAndPasteMenuSectionTo: aMenu. - aMenu addLine. - - self addStyleMenuSectionTo: aMenu. - - ^aMenu ! ! - -TextEditor removeSelector: #addOperationsMenuTo:! - -TextEditor removeSelector: #addTextstyleMenuTo:! - -TextEditor removeSelector: #addUndoMenuTo:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3883-EditorMenuEnh-JosefPhilipBernhart-2019Sep17-20h06m-jpb.1.cs.st----! - -'From Cuis 5.0 [latest update: #3883] on 25 September 2019 at 5:03:34 pm'! -!DiskProxy commentStamp: '' prior: 16834863! - A DiskProxy is an externalized form of an object to write on a -DataStream. It contains a "constructor" message to regenerate -the object, in context, when sent a comeFullyUpOnReload: message -(i.e. "internalize"). - -We are now using DiskProxy for shared system objects like StrikeFonts. - -The idea is to define, for each kind of object that needs special -externalization, a class method that will internalize the object by -reconstructing it from its defining state. We call this a -"constructor" method. Then externalize such an object as a frozen -message that invokes this method--a DiskProxy. - -(Here is the old comment: -Constructing a new object is good for any object that (1) can not be -externalized simply by snapshotting and reloading its instance -variables (like a CompiledMethod or a Picture), or (2) wants to be -free to evolve its internal representation without making stored -instances obsolete (and dangerous). Snapshotting and reloading an -object"s instance variables is a dangerous breach of encapsulation. - -The internal structure of the class is then free to evolve. All -externalized instances will be useful as long as the -constructor methods are maintained with the same semantics. - -There may be several constructor methods for a particular class. This -is useful for (1) instances with characteristically different -defining state, and (2) newer, evolved forms of an object and its -constructors, with the old constructor methods kept around so old -data can still be properly loaded.) - -Create one like this example from class Picture - - DiskProxy global: #Picture - selector: #fromByteArray: - args: (Array with: self storage asByteArray) - -* See also subclass DiskProxyQ that will construct an object in -the above manner and then send it a sequence of messages. This may save -creating a wide variety of constructor methods. It is also useful because -the newly read-in DiskProxyQ can catch messages like #objectContainedIn: -(via #doesNotUnderstand:) and add them to the queue of messages to -send to the new object. - -* We may also want a subclass of DiskProxy that evaluates a string -expression to compute the receiver of the constructor message. - -My instance variables: -* globalObjectName -- the Symbol name of a global object in the - System dictionary (usually a class). -* constructorSelector -- the constructor message selector Symbol to - send to the global object (perform:withArguments:), typically a - variation on newFrom:. -* constructorArgs -- the Array of arguments to pass in the - constructor message. - --- 11/9/92 Jerry Morrison -! -!VariableNode methodsFor: 'testing' stamp: 'jmv 9/24/2019 12:51:03' prior: 50464259! - isSuperPseudoVariable - "Answer if this ParseNode represents the 'super' pseudo-variable." - - ^ key = 'super' or: [name = '{{super}}']! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3884-CommentTweaks-JuanVuletich-2019Sep25-17h01m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3883] on 25 September 2019 at 5:05:25 pm'! -!BlockClosure methodsFor: 'accessing' stamp: 'jmv 9/25/2019 10:55:23'! - outerContextsDo: aBlock - - outerContext outerContextsDo: aBlock! ! -!MethodContext methodsFor: 'accessing' stamp: 'jmv 9/25/2019 10:54:45'! - outerContextsDo: aBlock - "Answer the context in which the receiver was defined." - - closureOrNil - ifNotNil: [ closureOrNil outerContextsDo: aBlock ]. - aBlock value: self! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3885-outerContextsDo-JuanVuletich-2019Sep25-17h03m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3885] on 26 September 2019 at 10:00:23 am'! -!BlockClosure methodsFor: 'accessing' stamp: 'jmv 9/25/2019 09:16:04'! - capturedValues - | n copiedValues | - n _ self numCopiedValues. - copiedValues _ Array new: n. - 1 to: n do: [ :i | - copiedValues at: i put: (self copiedValueAt: i) ]. - ^copiedValues! ! -!BlockClosure methodsFor: 'accessing' stamp: 'jmv 9/26/2019 09:19:46'! - endpc - "Determine end of block from the instruction preceding it. - Find the instruction by using an MNU handler to capture - the instruction message sent by the scanner." - | myMethod scanner preceedingBytecodeMessage end | - myMethod := self method. - scanner := InstructionStream new method: myMethod pc: myMethod initialPC. - [scanner pc < startpc] whileTrue: - [[scanner interpretNextInstructionFor: nil] - on: MessageNotUnderstood - do: [:ex| preceedingBytecodeMessage := ex message]]. - end := preceedingBytecodeMessage arguments last + startpc - 1. - ^end! ! -!BlockClosure methodsFor: 'testing' stamp: 'jmv 9/26/2019 09:41:53'! - sendsToSuper - "Answer whether the receiver sends any message to super." - | myMethod scanner end | - myMethod := self method. - scanner := InstructionStream new method: myMethod pc: startpc. - end := self endpc. - scanner scanFor: [ :byte | - (byte = 16r85 or: [ - byte = 16r84 and: [scanner followingByte between: 16r20 and: 16r3F]]) - or: [scanner pc > end]]. - ^scanner pc <= end! ! -!BlockClosure methodsFor: 'testing' stamp: 'jmv 9/26/2019 09:41:42' prior: 50465820! - hasNonLocalReturn - "Answer whether the receiver has a method-return ('^') in its code." - | myMethod scanner end | - myMethod := self method. - scanner := InstructionStream new method: myMethod pc: startpc. - end := self endpc. - scanner scanFor: [:byte | (byte between: 120 and: 124) or: [scanner pc > end]]. - ^scanner pc <= end! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3886-BlockClosure-hasNonLocalReturn-JuanVuletich-2019Sep26-09h59m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3885] on 26 September 2019 at 9:56:21 am'! -!Decompiler methodsFor: 'public access' stamp: 'jmv 9/25/2019 17:51:15' prior: 16832266! - decompileBlock: aBlock - "Decompile aBlock, returning the result as a BlockNode. - Show temp names from source if available." - "Decompiler new decompileBlock: [3 + 4]" - | methodNode home | - (home := aBlock home) ifNil: [^ nil]. - method := home method. - (home methodClass) == #unknown ifTrue: [^ nil]. - aBlock isClosure ifTrue: - [(methodNode := method decompile) - ifNil: [^nil] - ifNotNil: [methodNode nodesDo: [:node| node pc = aBlock startpc ifTrue: [^node]]]. - ^self error: 'cannot find block node matching aBlock']. - ^self error: 'can only decompile BlockClosures'! ! -!Compiler methodsFor: 'public access' stamp: 'jmv 9/26/2019 09:55:33' prior: 50445073! - evaluate: textOrStream in: aContext to: aReceiver notifying: aRequestor ifFail: failBlock logged: doLog profiled: doProfile - "Compiles the sourceStream into a parse tree, then generates code into - a method. If aContext is not nil, the text can refer to temporaries in that - context (the Debugger uses this). If aRequestor is not nil, then it will receive - a notify:at: message before the attempt to evaluate is aborted. Finally, the - compiled method is invoked from here via withArgs:executeMethod:, hence - the system no longer creates Doit method litter on errors." - - | methodNode method | - - class _ (aReceiver ifNotNil: [ aReceiver ] ifNil: [ aContext ifNotNil: [ :c | c receiver ]]) class. - methodNode _ self compileNoPattern: textOrStream in: class context: aContext notifying: aRequestor ifFail: [^failBlock value]. - method _ methodNode generate. - "I'm not keeping the source nor the methodNode for back compabibility. - The SmalltalkEditor sends the message #evaluateMethod:... which already keep the method node - for the debugger to show the right source code - Hernan" - ^self evaluateMethod: method to: aReceiver logged: doLog profiled: doProfile! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3887-Compiler-Decompiler-tweaks-JuanVuletich-2019Sep26-09h54m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3887] on 26 September 2019 at 7:38:16 pm'! - -Decompiler subclass: #SerializableClosureDecompiler - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #SerializableClosureDecompiler category: #'System-Support'! -Decompiler subclass: #SerializableClosureDecompiler - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! - -AssignmentNode subclass: #SerializableClosureAssignmentNode - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #SerializableClosureAssignmentNode category: #'System-Support'! -AssignmentNode subclass: #SerializableClosureAssignmentNode - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! - -InstanceVariableNode subclass: #SerializableClosureInstanceVariableNode - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #SerializableClosureInstanceVariableNode category: #'System-Support'! -InstanceVariableNode subclass: #SerializableClosureInstanceVariableNode - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! - -TempVariableNode subclass: #SerializableClosureTempVariableNode - instanceVariableNames: 'capturedIndex' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #SerializableClosureTempVariableNode category: #'System-Support'! -TempVariableNode subclass: #SerializableClosureTempVariableNode - instanceVariableNames: 'capturedIndex' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! - -DecompilerConstructor subclass: #SerializableClosureDecompilerConstructor - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #SerializableClosureDecompilerConstructor category: #'System-Support'! -DecompilerConstructor subclass: #SerializableClosureDecompilerConstructor - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! - -Object subclass: #SerializableBlockClosure - instanceVariableNames: 'theSelf sourceCode capturedValues' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #SerializableBlockClosure category: #'System-Support'! -Object subclass: #SerializableBlockClosure - instanceVariableNames: 'theSelf sourceCode capturedValues' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! -!SerializableBlockClosure commentStamp: 'jmv 9/25/2019 17:21:45' prior: 0! - A SerializableBlockClosure is a regular Smalltalk object (and hence serializable by ReferenceStream and SmartRefStream), that hold the source code for a BlockClosure, together with the state (originally in outer temps) that the BlockClosure might access. - -When sent #asEvaluable (even after materializing in the same or different Smalltalk image / machine), the result is a BlockClosure that can be evaluated with identical result as the original. - -By making BlockClosure>>objectForDataStream: call #asSerializable, we enable serialization and #veryDeepCopy of BlockClosures as if they were regular Smalltalk objects. - -(The only limitation is that we can't meaningfully handle non-local returns. This limitation also applies to regular BlockClosures if evaluation is attempted when there's nowhere to return to.)! -!BlockClosure methodsFor: 'objects from disk' stamp: 'jmv 9/20/2019 21:17:34'! - asSerializable - ^SerializableBlockClosure onBlockClosure: self! ! -!SerializableClosureDecompiler methodsFor: 'instruction decoding' stamp: 'jmv 9/25/2019 18:23:40'! - pushReceiver - - stack addLast: (InstanceVariableNode new - name: 'theSelf' - index: 1)! ! -!SerializableClosureDecompiler methodsFor: 'public access' stamp: 'jmv 9/25/2019 18:00:20'! - decompileBlockAndMethod: aBlock - "Decompile aBlock, returning the result as a BlockNode, and the corresponding MethodNode." - "Decompiler new decompileBlockAndMethod: [3 + 4]" - - | homeMethod methodNode home methodClass methodSelector | - (home := aBlock home) ifNil: [^ nil]. - homeMethod := home method. - (home methodClass) == #unknown ifTrue: [^ nil]. - aBlock isClosure ifTrue: [ - methodClass := homeMethod methodClass ifNil: [Object]. - methodSelector := homeMethod selector ifNil: [homeMethod defaultSelector]. - methodNode := self decompile: methodSelector in: methodClass method: homeMethod. - methodNode - ifNil: [^nil] - ifNotNil: [methodNode nodesDo: [:node| node pc = aBlock startpc ifTrue: [^{node. methodNode}]]]. - ^self error: 'cannot find block node matching aBlock']. - ^self error: 'can only decompile BlockClosures'! ! -!SerializableClosureDecompiler methodsFor: 'private' stamp: 'jmv 9/26/2019 18:48:55'! - constructorForMethod: aMethod - - ^SerializableClosureDecompilerConstructor new! ! -!SerializableClosureAssignmentNode methodsFor: 'printing' stamp: 'jmv 9/26/2019 18:47:12'! - printOn: aStream indent: level - - "For temps and args local to a block" - (variable isTemp and: [variable isCapturedByClosure not]) ifTrue: [ ^super printOn: aStream indent: level ]. - - "For outer temps, but also for ivars" - aStream nextPutAll: '('. - variable printIndirectOn: aStream indent: level. - aStream nextPutAll: ' put: '. - value printOn: aStream indent: level. - aStream nextPutAll: ')'.! ! -!SerializableClosureInstanceVariableNode methodsFor: 'printing' stamp: 'jmv 9/26/2019 18:44:09'! - printIndirectOn: aStream indent: level - - aStream nextPutAll: 'theSelf instVarNamed: ''', name, ''''! ! -!SerializableClosureInstanceVariableNode methodsFor: 'printing' stamp: 'jmv 9/26/2019 18:44:22'! - printOn: aStream indent: level - - aStream nextPut: $(. - self printIndirectOn: aStream indent: level. - aStream nextPut: $).! ! -!SerializableClosureTempVariableNode methodsFor: 'printing' stamp: 'jmv 9/26/2019 18:44:13'! - printIndirectOn: aStream indent: level - - self isRemote - ifTrue: [ aStream nextPutAll: 'capturedValues last at: ', capturedIndex printString ] - ifFalse: [ aStream nextPutAll: 'capturedValues at: ', capturedIndex printString ]! ! -!SerializableClosureTempVariableNode methodsFor: 'printing' stamp: 'jmv 9/26/2019 18:47:08'! - printOn: aStream indent: level - - "For temps local to the block" - self isCapturedByClosure ifFalse: [ - ^super printOn: aStream indent: level ]. - - "For outer temps" - aStream nextPut: $(. - self printIndirectOn: aStream indent: level. - aStream nextPut: $).! ! -!SerializableClosureTempVariableNode methodsFor: 'testing' stamp: 'jmv 9/26/2019 16:14:58'! - isCapturedByClosure - - ^capturedIndex notNil! ! -!SerializableClosureTempVariableNode methodsFor: 'accessing' stamp: 'jmv 9/26/2019 16:03:48'! - capturedIndex: idx - - capturedIndex _ idx! ! -!SerializableClosureDecompilerConstructor methodsFor: 'constructor' stamp: 'jmv 9/26/2019 18:49:23'! - codeAssignTo: variable value: expression - - ^ SerializableClosureAssignmentNode new variable: variable value: expression! ! -!SerializableClosureDecompilerConstructor methodsFor: 'constructor' stamp: 'jmv 9/26/2019 18:49:54'! -codeInst: index - - ^ SerializableClosureInstanceVariableNode new - name: (instVars at: index + 1 ifAbsent: ['unknown', index asString]) - index: index + 1! ! -!SerializableClosureDecompilerConstructor methodsFor: 'constructor' stamp: 'jmv 9/26/2019 18:49:40'! - codeTemp: index - - ^ SerializableClosureTempVariableNode new - name: 'temp' , (index + 1) printString - index: index - type: LdTempType - scope: 0! ! -!SerializableClosureDecompilerConstructor methodsFor: 'constructor' stamp: 'jmv 9/26/2019 18:49:40'! - codeTemp: index named: tempName - - ^ SerializableClosureTempVariableNode new - name: tempName - index: index - type: LdTempType - scope: 0! ! -!SerializableBlockClosure methodsFor: 'initialization' stamp: 'jmv 9/26/2019 19:34:11'! - onBlockClosure: aBlockClosure - - | both blockNode methodNode indirectTempNames sortedOuterTemps ownNames usedOuterNames sortedUsedOuterNames | - aBlockClosure hasNonLocalReturn ifTrue: [ - self error: 'Can not serialize closures with non-local returns.' ]. - aBlockClosure sendsToSuper ifTrue: [ - self error: 'Can not currently serialize closures with super sends.' ]. - both _ SerializableClosureDecompiler new decompileBlockAndMethod: aBlockClosure. - blockNode _ both first. - methodNode _ both second. - - indirectTempNames _ methodNode temporaries - detect: [ :node | node isIndirectTempVector ] - ifFound: [ :node | node remoteTemps collect: [ :n | n name ]] - ifNone: [#()]. - sortedOuterTemps _ OrderedCollection new. - aBlockClosure outerContextsDo: [ :c | c closure ifNotNil: [ :cc | - | ccn | - ccn _ cc decompile. - sortedOuterTemps addAll: ccn arguments; addAll: ccn temporaries ]]. - sortedOuterTemps addAll: methodNode temporaries; addAll: methodNode arguments. - - ownNames _ ((blockNode arguments, blockNode temporaries) - collect: [ :node | node name ]) asSet. - usedOuterNames _ Set new. - blockNode nodesDo: [ :node | node isTemp ifTrue: [ - (ownNames includes: node name) | (indirectTempNames includes: node name) ifFalse: [ - usedOuterNames add: node name]]]. - - sortedUsedOuterNames _ sortedOuterTemps select: [ :node | - usedOuterNames includes: node name ]. "sort them" - sortedUsedOuterNames _ sortedUsedOuterNames collect: [ :node | node name ]. - - blockNode nodesDo: [ :node | node isTemp ifTrue: [ - node isRemote - ifTrue: [node capturedIndex: (indirectTempNames indexOf: node name) ] - ifFalse: [ - (sortedUsedOuterNames includes: node name) - ifTrue: [node capturedIndex: (sortedUsedOuterNames indexOf: node name)]]]]. - - theSelf _ aBlockClosure receiver. - capturedValues _ aBlockClosure capturedValues. - sourceCode _ blockNode decompileString.! ! -!SerializableBlockClosure methodsFor: 'evaluating' stamp: 'jmv 9/25/2019 17:14:00'! - asEvaluable - - ^Compiler evaluate: sourceCode for: self logged: false! ! -!SerializableBlockClosure methodsFor: 'objects from disk' stamp: 'jmv 9/25/2019 11:43:02'! - comeFullyUpOnReload: smartRefStream - - ^ self asEvaluable! ! -!SerializableBlockClosure class methodsFor: 'instance creation' stamp: 'jmv 9/20/2019 21:18:13'! - onBlockClosure: aBlockClosure - ^self new onBlockClosure: aBlockClosure! ! -!BlockClosure methodsFor: 'objects from disk' stamp: 'jmv 9/26/2019 09:26:56' prior: 50466554! - objectForDataStream: refStrm - "I am about to be written on an object file. - Write a textual reference if possible. If not, attempt converting to a serializable object. - This might also fail. See #onBlockClosure:" - - self isCleanClosure ifTrue: [ - ^ DiskProxy - global: #Compiler - selector: #evaluate: - args: (Array with: self decompile decompileString) ]. - ^self asSerializable! ! -!MethodContext methodsFor: 'accessing' stamp: 'jmv 9/26/2019 17:23:06' prior: 50474308! - outerContextsDo: aBlock - "Answer the context in which the receiver was defined." - - aBlock value: self. - closureOrNil - ifNotNil: [ closureOrNil outerContextsDo: aBlock ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3888-BlockClosureSerialization-JuanVuletich-2019Sep26-19h37m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3888] on 29 September 2019 at 1:08:13 pm'! -!ArrayedCollection class methodsFor: 'instance creation' stamp: 'jmv 9/29/2019 12:48:46'! - instancesMustBeOfSpecificSize - "Some subclasses create instances of a specific size, and answer true" - ^self numElements ~= 0! ! -!ArrayedCollection class methodsFor: 'instance creation' stamp: 'jmv 9/29/2019 12:47:53'! - numElements - "Some subclasses create instances of a specific size, and a non-zero number" - ^0! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3889-FixedSizeCollctionTweaks-p1-JuanVuletich-2019Sep29-13h08m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3888] on 29 September 2019 at 1:09:24 pm'! -!ArrayedCollection methodsFor: 'private' stamp: 'jmv 9/29/2019 13:00:32'! - species - "For methods such as #select:, and for instances of fixed size classes, such as Color, - find an appropriate class for new instances." - | candidate | - candidate _ self class. - [ candidate instancesMustBeOfSpecificSize ] whileTrue: [ - candidate _ candidate superclass ]. - ^candidate! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 9/29/2019 12:49:41'! - numElements - ^3! ! -!TranslucentColor class methodsFor: 'instance creation' stamp: 'jmv 9/29/2019 12:49:48'! - numElements - ^4! ! -!ArrayedCollection class methodsFor: 'instance creation' stamp: 'jmv 9/29/2019 12:52:40' prior: 16780577! - new - "Answer a new instance of me, with size = 0, unles a specific size is used." - - ^self new: self numElements! ! - -TranslucentColor class removeSelector: #new! - -TranslucentColor class removeSelector: #new! - -Color class removeSelector: #new! - -Color class removeSelector: #new! - -Float64Array class removeSelector: #new! - -Float64Array class removeSelector: #new! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3890-FixedSizeCollectionTweaks-p2-JuanVuletich-2019Sep29-13h08m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3890] on 29 September 2019 at 1:52:09 pm'! -!FeatureRequirement methodsFor: 'testing' stamp: 'KenD 9/26/2019 16:16:32'! - satisfies: anotherFeatureRequirement - - "Answer true if anotherFeatureRequirement is satisfied by me" - (self name = anotherFeatureRequirement name) ifFalse: [^false]. - "FIXME: add version,revision checks" - ^true! ! -!FeatureRequirement methodsFor: 'private' stamp: 'KenD 9/28/2019 09:03:11'! - addToLoad: toLoad withMyRequirements: requirements - - "Add self to OrderedCollection toLoad before any requirements I have" - | requires | - requires := requirements collect: [:r| r name]. "a set" - toLoad do: [ :featureReq | - (requires includes: featureReq name) - ifTrue: [ - "Transcript show: ('adding ', self name asString, ' before: ', featureReq name asString); newLine." - toLoad add: self before: featureReq. - ^ toLoad - ] - ]. - "Transcript show: ('adding ', self name asString); newLine." - toLoad addLast: self. - ^ toLoad - ! ! -!FeatureRequirement methodsFor: 'requires' stamp: 'KenD 9/28/2019 09:03:54' prior: 16840798! - require - "See if all the transitive closure of requirements can be met and answer the load order if so" - - | packagesToLoad | - - "Preflight before load" - [packagesToLoad _ self requireUnlessIn: OrderedCollection new main: nil] - on: FeatureRequirementUnsatisfied - do: [ :error | error defaultAction. - ^self "exit" - ]. - "Transcript show: 'packagesToLoad: '; newLine. - packagesToLoad do: [ :x |Transcript show: x; newLine ]. - Transcript newLine . -self halt." - packagesToLoad reverseDo: [ :requirement | - requirement isAlreadySatisfied ifFalse: [ - requirement install ]]. - self isAlreadySatisfied ifFalse: [ - self install ]! ! -!FeatureRequirement methodsFor: 'requires' stamp: 'KenD 9/27/2019 16:09:25' prior: 16840816! - requireUnlessIn: toLoad main: mainFeatureOrNil - "See if all the requirements can be met and answer the load order" - - self isAlreadySatisfied ifFalse: [ - (toLoad anySatisfy: [ :featReq | featReq satisfies: self]) - ifFalse: [ - (self findPackageFileAsReqOf: mainFeatureOrNil) - ifTrue: [ | otherRequirements | - otherRequirements := self requirements. - self == mainFeatureOrNil ifFalse: [ - self addToLoad: toLoad withMyRequirements: otherRequirements ]. - otherRequirements ifNotNil: [ - otherRequirements do: [ :requires | - requires requireUnlessIn: toLoad main: (mainFeatureOrNil ifNil: [self])]]] - ifFalse: [ - FeatureRequirementUnsatisfied - signal: 'Could not find package supplying: ', - String newLineString, ' ', - self printString - ]]]. - - ^ toLoad! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3891-FeatureReq-KenDickey-2019Sep29-13h51m-KenD.1.cs.st----! - -'From Cuis 5.0 [latest update: #3891] on 29 September 2019 at 1:56:19 pm'! -!Morph methodsFor: 'submorphs-accessing' stamp: 'jmv 9/29/2019 13:55:44' prior: 16876717! - submorphBehind: aMorph - - self submorphsBehind: aMorph do: [ :m | ^m ]. - ^nil! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3892-no-submorphBehind-JuanVuletich-2019Sep29-13h55m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3892] on 2 October 2019 at 10:56:50 am'! - -ArrayedCollection removeSelector: #species! - -ArrayedCollection removeSelector: #species! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3893-species-generally-means-class-JuanVuletich-2019Oct02-10h56m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3893] on 2 October 2019 at 11:39:31 am'! - -Object variableWordSubclass: #Float32SlotsObject - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Objects'! - -!classDefinition: #Float32SlotsObject category: #'Kernel-Objects'! -Object variableWordSubclass: #Float32SlotsObject - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Objects'! -!Float32SlotsObject commentStamp: '' prior: 0! - Abstract superclass for objects whose slots are 32 bit Floating Point values, but don't inherit from FloatArray because they are not collections, and collection protocol makes no sense on them.! -!Float32SlotsObject methodsFor: 'private' stamp: 'jmv 10/2/2019 11:38:34'! - at: index -" -'---------'print. -thisContext printStack: 10. -'======'print. -" -^self slotAt: index! ! -!Float32SlotsObject methodsFor: 'private' stamp: 'jmv 10/2/2019 11:38:42'! - at: index put: stuff -" -'---------'print. -thisContext printStack: 10. -'======'print. -" -^self slotAt: index put: stuff! ! -!Float32SlotsObject methodsFor: 'private' stamp: 'jmv 10/2/2019 11:21:16'! - slotAt: index - - ^Float fromIEEE32Bit: (self basicAt: index)! ! -!Float32SlotsObject methodsFor: 'private' stamp: 'jmv 10/2/2019 11:21:55'! -slotAt: index put: value - - value isFloat - ifTrue: [ self basicAt: index put: value asIEEE32BitWord ] - ifFalse: [ self slotAt: index put: value asFloat ]. - ^value! ! -!Float32SlotsObject class methodsFor: 'instance creation' stamp: 'jmv 10/2/2019 11:19:44'! - new - "Answer a new instance of me, with size = 0, unles a specific size is used." - - ^self new: self numSlots! ! -!Float32SlotsObject class methodsFor: 'instance creation' stamp: 'jmv 10/2/2019 11:39:11'! - numSlots - ^0! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3894-Float32SlotsObject-JuanVuletich-2019Oct02-11h38m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3894] on 2 October 2019 at 11:53:53 am'! -!Color methodsFor: 'comparing' stamp: 'jmv 10/2/2019 20:37:24'! - primitiveEqual: aColor - | length | - - aColor class == self class ifFalse: [^ false]. - length _ self size. - length = aColor size ifFalse: [^ false]. - 1 to: self size do: [ :i | - (self basicAt: i) = (aColor basicAt: i) ifFalse: [^ false]]. - ^ true! ! -!Color methodsFor: 'comparing' stamp: 'jmv 10/2/2019 20:31:03'! - = another - self == another ifTrue: [ ^ true ]. - self class == another class ifFalse: [ ^ false ]. - ^self primitiveEqual: another! ! -!Color methodsFor: 'private' stamp: 'jmv 10/2/2019 11:40:28'! - slotAt: index - - ^Float fromIEEE32Bit: (self basicAt: index)! ! -!Color methodsFor: 'private' stamp: 'jmv 10/2/2019 11:40:37'! - slotAt: index put: value - - value isFloat - ifTrue: [ self basicAt: index put: value asIEEE32BitWord ] - ifFalse: [ self slotAt: index put: value asFloat ]. - ^value! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 10/2/2019 11:19:25'! - numSlots - ^3! ! -!TranslucentColor class methodsFor: 'instance creation' stamp: 'jmv 10/2/2019 11:42:58'! - numSlots - ^4! ! -!Color methodsFor: 'access' stamp: 'jmv 10/2/2019 11:25:11' prior: 50353221! - blue - "Return the blue component of this color, a float in the range [0.0..1.0]." - - ^ self slotAt: 3! ! -!Color methodsFor: 'access' stamp: 'jmv 10/2/2019 11:25:44' prior: 50353249! - green - "Return the green component of this color, a float in the range [0.0..1.0]." - - ^ self slotAt: 2! ! -!Color methodsFor: 'access' stamp: 'jmv 10/2/2019 11:26:27' prior: 50353296! - red - "Return the red component of this color, a float in the range [0.0..1.0]." - - ^ self slotAt: 1! ! -!Color methodsFor: 'conversions' stamp: 'jmv 10/2/2019 11:26:14' prior: 50364619! - pixelValueForDepth: d - "Returns an integer representing the bits that appear in a single pixel of this color in a Form of the given depth. The depth must be one of 1, 2, 4, 8, 16, or 32. Contrast with pixelWordForDepth: and bitPatternForDepth:, which return either a 32-bit word packed with the given pixel value or a multiple-word Bitmap containing a pattern. The inverse is the class message colorFromPixelValue:depth:" - "Details: For depths of 8 or less, the result is a colorMap index. For depths of 16 and 32, it is a direct color value with 5 or 8 bits per color component." - "Transparency: The pixel value zero is reserved for transparent. For depths greater than 8 and less than 32 (no Indexed colors, no real alpha), black maps to the darkest possible blue. - Note that - Color transparent class = TranslucentColor - this special case is handled in TranslucentColor >> #pixelValueForDepth: - " - - | bitBltFakeBlack val | - "Most common case" - "eight bits per component; top 8 bits set to all ones (opaque alpha)" - d = 32 ifTrue: [ - ^ 16rFF000000 bitOr: - ((((self slotAt: 1) * 255.999) truncated bitShift: 16) bitOr: - ((((self slotAt: 2) * 255.999) truncated bitShift: 8) bitOr: - (((self slotAt: 3) * 255.999) truncated))) ]. - -"Faster in 32 bit systems, but slower in 64 bits" -" d = 32 ifTrue: [ - val _ LargePositiveInteger new: 4. - val at: 3 put: ((self at: 1) * 255.999) truncated. - val at: 2 put: ((self at: 2) * 255.999) truncated. - val at: 1 put: ((self at: 3) * 255.999) truncated. - val at: 4 put: 16rFF. - ^ val normalize]." - - d = 8 ifTrue: [^ self closestPixelValue8]. "common case" - d < 8 ifTrue: [ - d = 4 ifTrue: [^ self closestPixelValue4]. - d = 2 ifTrue: [^ self closestPixelValue2]. - d = 1 ifTrue: [^ self closestPixelValue1]]. - - "For the depth 16, pixelValue = 0 means transparent, black is represented as 16r8000 (rgb=0, pixelvalue !!= 0)." - (d = 16) | (d = 15) ifTrue: [ - "five bits per component; top bits ignored" - val _ ((self red * 31) rounded bitShift: 10) bitOr: - (((self green * 31) rounded bitShift: 5) bitOr: - ((self blue * 31) rounded)). - ^ val = 0 - ifTrue: [d = 16 ifTrue: [16r8000] ifFalse: [1]] - ifFalse: [val]]. - - "For the rest of the depths, pixelValue = 0 means transparent, and darkest blue is considered to be black." - bitBltFakeBlack := 1. "closest black that is not transparent in RGB - Not for depths <=8 (Indexed) or = 32 (RGBA)" - d = 12 ifTrue: [ "for indexing a color map with 4 bits per color component" - val _ ((self red * 15) rounded bitShift: 8) bitOr: - (((self green * 15) rounded bitShift: 4) bitOr: - ((self blue * 15) rounded)). - ^ val = 0 ifTrue: [bitBltFakeBlack] ifFalse: [val]]. - - d = 9 ifTrue: [ "for indexing a color map with 3 bits per color component" - val _ ((self red * 7) rounded bitShift: 6) bitOr: - (((self green * 7) rounded bitShift: 3) bitOr: - ((self blue * 7) rounded)). - ^ val = 0 ifTrue: [bitBltFakeBlack] ifFalse: [val]]. - - self error: 'unknown pixel depth: ', d printString! ! -!Color methodsFor: 'queries' stamp: 'jmv 10/2/2019 11:25:51' prior: 50353813! - isBlack - "Return true if the receiver represents black" - (self slotAt: 1) = 0.0 ifFalse: [ ^ false ]. - (self slotAt: 2) = 0.0 ifFalse: [ ^ false ]. - (self slotAt: 3) = 0.0 ifFalse: [ ^ false ]. - ^ true! ! -!Color methodsFor: 'queries' stamp: 'jmv 10/2/2019 11:25:59' prior: 50353826! - isWhite - "Return true if the receiver represents white" - (self slotAt: 1) = 1.0 ifFalse: [ ^ false ]. - (self slotAt: 2) = 1.0 ifFalse: [ ^ false ]. - (self slotAt: 3) = 1.0 ifFalse: [ ^ false ]. - ^ true! ! -!Color methodsFor: 'private' stamp: 'jmv 10/2/2019 11:21:43' prior: 50354202! - basicSetRed: r green: g blue: b - "Initialize this color's r, g, and b components to the given values in the range [0.0..1.0]." - - self - slotAt: 1 put: r; - slotAt: 2 put: g; - slotAt: 3 put: b! ! -!Color methodsFor: 'private' stamp: 'jmv 10/2/2019 11:25:15' prior: 50458787! - clipToValidValues - | v | - 1 to: self size do: [ :i | - v _ self slotAt: i. - v > 1 ifTrue: [self slotAt: i put: 1.0]. - v < 0 ifTrue: [self slotAt: i put: 0.0]]! ! -!TranslucentColor methodsFor: 'accessing' stamp: 'jmv 10/2/2019 11:50:06' prior: 50356492! - alpha - "Return my alpha value, a number between 0.0 and 1.0 where 0.0 is completely transparent and 1.0 is completely opaque." - - ^ self slotAt: 4! ! -!TranslucentColor methodsFor: 'private' stamp: 'jmv 10/2/2019 11:51:07' prior: 50356590! - setRed: r green: g blue: b alpha: alphaValue - - self basicSetRed: r green: g blue: b. - self slotAt: 4 put: alphaValue! ! - -Color removeSelector: #convertToCurrentVersion:refStream:! - -Color removeSelector: #convertToCurrentVersion:refStream:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3895-Color-part1-JuanVuletich-2019Oct02-11h53m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3894] on 2 October 2019 at 11:43:53 am'! - -Float32SlotsObject variableWordSubclass: #Color - instanceVariableNames: '' - classVariableNames: 'CachedColormaps FromGrayColormaps GrayToIndexMap IndexedColors MaskingMap ToGrayColormaps' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -!classDefinition: #Color category: #'Graphics-Primitives'! -Float32SlotsObject variableWordSubclass: #Color - instanceVariableNames: '' - classVariableNames: 'CachedColormaps FromGrayColormaps GrayToIndexMap IndexedColors MaskingMap ToGrayColormaps' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3896-Color-part2-JuanVuletich-2019Oct02-11h43m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3894] on 2 October 2019 at 11:46:14 am'! - -TranslucentColor class removeSelector: #numElements! - -TranslucentColor class removeSelector: #numElements! - -Color class removeSelector: #numElements! - -Color class removeSelector: #numElements! - -Color removeSelector: #slotAt:! - -Color removeSelector: #slotAt:! - -Color removeSelector: #slotAt:put:! - -Color removeSelector: #slotAt:put:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3897-Color-part3-JuanVuletich-2019Oct02-11h43m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3897] on 2 October 2019 at 11:57:45 am'! - -Float32SlotsObject removeSelector: #at:! - -Float32SlotsObject removeSelector: #at:! - -Float32SlotsObject removeSelector: #at:put:! - -Float32SlotsObject removeSelector: #at:put:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3898-Float32SlotsObject-cleanup-JuanVuletich-2019Oct02-11h56m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3898] on 2 October 2019 at 2:16:17 pm'! -!Color methodsFor: 'object serialization' stamp: 'jmv 6/22/2017 12:54:10'! - convertToCurrentVersion: varDict refStream: smartRefStrm - - "subclasses should implement if they wish to convert old instances to modern ones" - self size = 0 ifTrue: [ - ^ Color new copyFrom: (varDict at: 'floatRGB') ]. - ^ self! ! -!Color methodsFor: 'private' stamp: 'jmv 10/2/2019 13:53:40' prior: 50354326! - setRed: r green: g blue: b range: range - "Initialize this color's r, g, and b components to the given values in the range [0..r]." - - self basicSetRed: r/range green: g/range blue: b/range. - self clipToValidValues! ! - -Color removeSelector: #*=! - -Color removeSelector: #*=! - -Color removeSelector: #+=! - -Color removeSelector: #+=! - -Color removeSelector: #-=! - -Color removeSelector: #-=! - -Color removeSelector: #/=! - -Color removeSelector: #/=! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3899-Color-fixes-JuanVuletich-2019Oct02-14h15m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3892] on 30 September 2019 at 3:25:41 pm'! -!FeatureRequirement methodsFor: 'testing' stamp: 'KenD 9/30/2019 08:12:46'! - checkRequirement - "Answer if I am satisfied by package found at pathName" - - pathName asFileEntry readStreamDo: [ :stream | | fSpec | - fSpec := ((CodePackageFile buildFileStream: stream) featureSpec). - ((fSpec isNil) or: [(fSpec provides satisfies: self) not]) - ifTrue: [ - FeatureRequirementUnsatisfied - signal: pathName, - String newLineString, - ' could not satisfy ', self printString. - ^false - ] - ifFalse: [ ^true ] - ] - -! ! -!FeatureRequirement methodsFor: 'testing' stamp: 'KenD 9/30/2019 09:51:40'! - sameNameAs: anotherFeatureRequirement - - "Answer true if anotherFeatureRequirement has same name as me" - ^(self name = anotherFeatureRequirement name)! ! -!CodePackageFile methodsFor: 'accessing' stamp: 'KenD 9/29/2019 21:28:27'! - featureSpec - - ^ featureSpec! ! -!FeatureRequirement methodsFor: 'requires' stamp: 'KenD 9/30/2019 15:12:46' prior: 50474906! - require - "See if all the transitive closure of requirements can be met and answer the load order if so" - - | packagesToLoad | - - "Preflight before load - [1] Build transitive closure as load order where Feature comes - before its required features." - [packagesToLoad _ self requireUnlessIn: OrderedCollection new main: nil] - on: FeatureRequirementUnsatisfied - do: [ :error | error defaultAction. - ^self "exit" - ]. - - "Transcript show: 'packagesToLoad: '; newLine. - packagesToLoad do: [ :x |Transcript show: x; newLine ]. - Transcript newLine." - - "[2] Check to see that each requirement is actually satisfied" - [packagesToLoad do: [ :fReq | fReq checkRequirement ]] - on: FeatureRequirementUnsatisfied - do: [ :error | error defaultAction. - ^self "exit" - ]. - - "[3] Load required packages before packages that require them" - packagesToLoad reverseDo: [ :requirement | - requirement isAlreadySatisfied ifFalse: [ - requirement install ]]. - self isAlreadySatisfied ifFalse: [ - self install ]! ! -!FeatureRequirement methodsFor: 'requires' stamp: 'KenD 9/30/2019 15:23:40' prior: 50474929! - requireUnlessIn: toLoad main: mainFeatureOrNil - "See if all the requirements can be met and answer the load order" - - self isAlreadySatisfied ifFalse: [ - (toLoad anySatisfy: [ :featReq | featReq sameNameAs: self]) - ifFalse: [ - (self findPackageFileAsReqOf: mainFeatureOrNil) - ifTrue: [ | otherRequirements | - otherRequirements := self requirements. - otherRequirements ifNotNil: [ - otherRequirements do: [ :requires | - requires requireUnlessIn: toLoad main: (mainFeatureOrNil ifNil: [self])]]. - self == mainFeatureOrNil ifFalse: [ - self addToLoad: toLoad withMyRequirements: otherRequirements ]. - ] - ifFalse: [ - FeatureRequirementUnsatisfied - signal: 'Could not find package supplying: ', - String newLineString, ' ', - self printString - ]]]. - - ^ toLoad! ! -!FeatureRequirement methodsFor: 'private' stamp: 'KenD 9/30/2019 15:13:19' prior: 50474886! - addToLoad: toLoad withMyRequirements: requirements - - "Add self to OrderedCollection 'toLoad' before any requirements I have" - | myRequirements | - myRequirements := self requirements. - toLoad do: [ :featureReq | - (myRequirements anySatisfy: [ :req | featureReq sameNameAs: req]) - ifTrue: [ - "Transcript show: ('adding ', self name asString, ' before: ', featureReq name asString); newLine." - toLoad add: self before: featureReq. - ^ toLoad - ] - ]. - "Transcript show: ('adding ', self name asString); newLine." - toLoad addLast: self. - ^ toLoad - ! ! - -FeatureRequirement removeSelector: #satisfies:! - -FeatureRequirement removeSelector: #satisfies:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3900-FeatureReFix-KenD-2019Sep30-15h20m-KenD.1.st----! - -'From Cuis 5.0 [latest update: #3900] on 2 October 2019 at 8:48:36 pm'! -!Color methodsFor: 'comparing' stamp: 'jmv 10/2/2019 20:31:03' prior: 50475066! - = another - self == another ifTrue: [ ^ true ]. - self class == another class ifFalse: [ ^ false ]. - ^self primitiveEqual: another! ! -!Color methodsFor: 'comparing' stamp: 'jmv 10/2/2019 20:37:59'! - hash - | hash | - - hash _ (self species hash + self size hash) hashMultiply. - 1 to: self size do: [ :i | hash _ (hash + (self basicAt: i)) hashMultiply]. - ^hash! ! -!Color methodsFor: 'comparing' stamp: 'jmv 10/2/2019 20:37:24' prior: 50475054! - primitiveEqual: aColor - | length | - - aColor class == self class ifFalse: [^ false]. - length _ self size. - length = aColor size ifFalse: [^ false]. - 1 to: self size do: [ :i | - (self basicAt: i) = (aColor basicAt: i) ifFalse: [^ false]]. - ^ true! ! -!Color methodsFor: 'object serialization' stamp: 'jmv 10/2/2019 20:45:01'! - 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." - - Smalltalk isLittleEndian ifTrue: [ - BitBlt swapBytesIn32BitWords: self ]! ! -!Color methodsFor: 'object serialization' stamp: 'jmv 10/2/2019 20:46:32'! - 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." - aStream nextSignedInt32Put: self basicSize bigEndian: true. - aStream nextWordsPutAll: self.! ! -!Color class methodsFor: 'class initialization' stamp: 'jmv 10/2/2019 20:47:49'! - newFromStream: s - "Only meant for my subclasses that are raw bits and word-like. For quick unpack form the disk." - | len | - len _ s nextSignedInt32BigEndian: true. - ^ s nextWordsInto: (self basicNew: len)! ! - -Color removeSelector: #hashFull! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3901-Color-fixes-JuanVuletich-2019Oct02-20h29m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3901] on 6 October 2019 at 10:24:14 am'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 10/6/2019 10:23:56' prior: 50456342! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('AY' 'Angel Yan') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('bgs' 'Boris G. Shingarov') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('EB' 'Eric Brandwein') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('FGJ' 'Fernando Gasperi Jabalera') - #('FJG' 'Facundo Javier Gelatti') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('KLG' 'Gerald Klix') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MM' 'Mariano Montone') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('pmon' 'Paolo Montrasi') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('SLD' 'Steve Davies') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('ss' 'Sebastian Sujarchuk') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3902-AddSebastianAsKnownAuthor-JuanVuletich-2019Oct06-10h23m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3901] on 6 October 2019 at 10:24:55 am'! -!BasicClassOrganizer methodsFor: 'private' stamp: 'ss 10/3/2019 19:59:34'! - hasClassComment - - ^classComment notNil and: [^classComment text notNil]! ! -!BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'ss 10/3/2019 19:59:25' prior: 50405684! - fileOutCommentOn: aFileStream moveSource: moveSource toFile: fileIndex - "Copy the class comment to aFileStream. If moveSource is true (as in compressChanges or compressSources, then update classComment to point to the new file." - | fileComment | - self hasClassComment ifTrue: [ - aFileStream newLine. - fileComment _ RemoteString newString: self classComment - onFileNumber: fileIndex toFile: aFileStream. - moveSource ifTrue: [classComment _ fileComment]. - Smalltalk defaultUserChangesName asFileEntry appendStreamDo: [ :stream | - stream newLine; nextChunkPut: self classComment ]]! ! -!BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'ss 10/3/2019 19:58:31' prior: 16782685! - putCommentOnFile: aFileStream numbered: sourceIndex moveSource: moveSource forClass: aClass - "Store the comment about the class onto file, aFileStream." - | header | - self hasClassComment ifTrue: [ - aFileStream newLine; nextPut: $!!. - header _ String streamContents: [:strm | - strm nextPutAll: aClass name; - nextPutAll: ' commentStamp: '. - commentStamp ifNil: [commentStamp _ '']. - commentStamp storeOn: strm. - strm nextPutAll: ' prior: '; nextPutAll: '0']. - aFileStream nextChunkPut: header. - aClass organization fileOutCommentOn: aFileStream - moveSource: moveSource toFile: sourceIndex. - aFileStream newLine]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3903-FileoutWithNoClassCommentFix-SebastianSujarchuk-2019Oct06-10h24m-ss.1.cs.st----! - -'From Cuis 5.0 [latest update: #3903] on 6 October 2019 at 10:34:39 am'! -!Float32SlotsObject methodsFor: 'accessing' stamp: 'jmv 10/6/2019 10:34:22'! - byteSize - ^self size * 4! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3904-Color-byteSize-JuanVuletich-2019Oct06-10h34m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3904] on 8 October 2019 at 7:59:11 am'! -!Integer methodsFor: 'mathematical functions' stamp: 'sqr 10/8/2019 07:57:23' prior: 50337797! - raisedTo: n modulo: m - "Answer the modular exponential. - Note: this implementation is optimized for case of large integers raised to large powers." - | a s mInv | - n = 0 ifTrue: [^1 \\ m]. - (self >= m or: [self < 0]) ifTrue: [^self \\ m raisedTo: n modulo: m]. - n < 0 ifTrue: [^(self reciprocalModulo: m) raisedTo: n negated modulo: m]. - (n < 4096 or: [m even]) - ifTrue: - ["Overhead of Montgomery method might cost more than naive divisions, use naive" - ^self slidingLeftRightRaisedTo: n modulo: m]. - - mInv := self montgomeryDigitBase - ((m bitAnd: self montgomeryDigitMax) reciprocalModulo: self montgomeryDigitBase). - - "Initialize the result to R=self montgomeryDigitModulo raisedTo: m montgomeryNumberOfDigits" - a := (1 bitShift: m montgomeryNumberOfDigits * m montgomeryDigitLength) \\ m. - - "Montgomerize self (multiply by R)" - (s := self montgomeryTimes: (a*a \\ m) modulo: m mInvModB: mInv) - ifNil: - ["No Montgomery primitive available ? fallback to naive divisions" - ^self slidingLeftRightRaisedTo: n modulo: m]. - - "Exponentiate self*R" - a := s montgomeryRaisedTo: n times: a modulo: m mInvModB: mInv. - - "Demontgomerize the result (divide by R)" - ^a montgomeryTimes: 1 modulo: m mInvModB: mInv! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3905-Integer-raisedTo-modulo-fix-AndresValloud-AgustinSansone-2019Oct08-07h57m-sqr.1.cs.st----! - -'From Cuis 5.0 [latest update: #3905] on 8 October 2019 at 8:44:06 am'! -!FeatureRequirement methodsFor: 'requires' stamp: 'KenD 10/7/2019 10:59:06' prior: 16840839! - satisfyRequirementsAndInstall - "Like #require, but install me even if already satisified (i.e. installed)" - - | packagesToLoad | - - "Preflight before load" - [packagesToLoad _ self requireUnlessIn: OrderedCollection new main: self] - on: FeatureRequirementUnsatisfied - do: [ :error | error defaultAction. - ^self "exit" - ]. - - "Check to see that each requirement is actually satisfied" - [packagesToLoad do: [ :fReq | fReq checkRequirement ]] - on: FeatureRequirementUnsatisfied - do: [ :error | error defaultAction. - ^self "exit" - ]. - - "All requirements are satisfied; do the deed" - packagesToLoad reverseDo: [ :requirement | - requirement isAlreadySatisfied ifFalse: [ - requirement install ]]. - self install! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3906-FileList-install-fix-KenDickey-2019Oct08-08h42m-KenD.1.cs.st----! - -'From Cuis 5.0 [latest update: #3906] on 9 October 2019 at 11:38:23 am'! -!DirectoryEntry methodsFor: 'enumeration' stamp: 'jmv 10/9/2019 11:23:46'! - allRegularDirectoriesDo: aBlock - self regularDirectoriesDo: [ :child | - aBlock value: child. - child allRegularDirectoriesDo: aBlock]! ! -!DirectoryEntry methodsFor: 'enumeration' stamp: 'jmv 10/9/2019 11:23:21'! - regularDirectoriesDo: aBlock - self childrenDo: [ :each | - each isFile ifFalse: [ - each isRegularDirectory ifTrue: [ - aBlock value: each ]]]! ! -!DirectoryEntry methodsFor: 'testing' stamp: 'jmv 10/9/2019 11:28:39'! - isRegularDirectory - "hidden convention in Unix" - name first = $. ifTrue: [ ^false ]. - "in MacOS, applications are actually directories, but are usually not treated as such" - self extension = 'app' ifTrue: [ ^false ]. - "in MacOS, .bundle directories, are resource packages" - self extension = 'bundle' ifTrue: [ ^false ]. - ^true! ! -!FeatureRequirement methodsFor: 'private' stamp: 'jmv 10/9/2019 11:35:55' prior: 50449737! - placesToLookForPackagesDo: aBlock - - | myDir base packagesDirectory | - - "Look inside my own folder" - pathName ifNotNil: [ - myDir _ pathName asFileEntry parent. - aBlock value: myDir ]. - - "Look in Cuis image folder and reasonable subfolders" - base _ DirectoryEntry smalltalkImageDirectory. - aBlock value: base. - packagesDirectory _ base / 'Packages'. - aBlock value: packagesDirectory. - packagesDirectory allRegularDirectoriesDo: aBlock. - base regularDirectoriesDo: [ :child | - child = packagesDirectory ifFalse: [ - aBlock value: child. - child allRegularDirectoriesDo: aBlock]]. - - "Look in parent directory and reasonable subfolders. - Useful when image is stored in a subdirectory of the main app directory. - This could be the case when the package comes from a 'main' git repo, and image is copied from gitHub. - First try directories including the word Cuis in the name. Then try others." - base parent regularDirectoriesDo: [ :dir | - dir ~= base ifTrue: [ - ('*Cuis*' match: dir name) - ifTrue: [aBlock value: dir. dir allRegularDirectoriesDo: aBlock]]]. - base parent regularDirectoriesDo: [ :dir | - dir ~= base ifTrue: [ - ('*Cuis*' match: dir name) - ifFalse: [aBlock value: dir. dir allRegularDirectoriesDo: aBlock]]]. - - "Also look in host OS current directory" - (base ~= DirectoryEntry currentDirectory and: [base parent ~= DirectoryEntry currentDirectory]) - ifTrue: [ - base _ DirectoryEntry currentDirectory. - base allRegularDirectoriesDo: aBlock ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3907-PackageLookupImprovements-JuanVuletich-2019Oct09-11h04m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3907] on 9 October 2019 at 12:17:11 pm'! -!FeatureRequirementUnsatisfied methodsFor: 'exceptionDescription' stamp: 'jmv 10/9/2019 11:57:30' prior: 16841023! - defaultAction - "The default action taken if the exception is signaled." - - self messageText print. - PopUpMenu inform: - self messageText, - String newLineString, String newLineString, - 'You can view loaded Packages and their requirements via', - String newLineString, - ' World menu > Open.. > Installed Packages', - String newLineString - -! ! -!FeatureRequirement methodsFor: 'requires' stamp: 'jmv 10/9/2019 12:14:51' prior: 16840767! - findPackageFileAsReqOf: mainFeatureOrNil - "Look in known places for packages providing required feature. - Answer wether search was successful." - | packageFileName entry | - pathName ifNotNil: [ - pathName asFileEntry exists ifTrue: [ ^ true ]]. - packageFileName _ self packageFileName. - (mainFeatureOrNil ifNil: [ self ]) placesToLookForPackagesDo: [ :directory | - entry _ directory // packageFileName. - entry exists ifTrue: [ - pathName _ entry pathName. - self checkRequirement ifTrue: [ ^true ]. - pathName _ nil]]. - ^ false! ! -!FeatureRequirement methodsFor: 'testing' stamp: 'jmv 10/9/2019 12:16:13' prior: 50475360! - checkRequirement - "Answer if I am satisfied by package found at pathName" - - pathName asFileEntry readStreamDo: [ :stream | | fSpec | - fSpec := ((CodePackageFile buildFileStream: stream) featureSpec). - ^ fSpec notNil and: [fSpec provides satisfies: self]] - -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3908-RequirementsCheckEnhancements-JuanVuletich-2019Oct09-12h14m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3908] on 9 October 2019 at 2:36:48 pm'! -!SystemDictionary methodsFor: 'shrinking' stamp: 'jmv 10/9/2019 14:36:43' prior: 50456924! - reduceCuis - " - Smalltalk reduceCuis - " - | keep n unused newDicts oldDicts | - - self nominallyUnsent: #reduceCuis. - - "Remove icons" - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - PasteUpMorph allInstancesDo: [ :w | - w backgroundImageData: nil. - w submorphsDo: [ :a | a delete ]]. - Preferences useNoMenuIcons. - Theme current initialize. - Theme content: nil. - Color shutDown. - BitBltCanvas releaseClassCachedState. - - Transcript clear. - Clipboard default initialize. - - - "Remove some methods, even if they have senders." - Utilities removeSelector: #vmStatisticsReportString. - SystemDictionary removeSelector: #recreateSpecialObjectsArray. - - StrikeFont saveSpace. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - - keep := OrderedCollection new. - keep addAll: #(SpaceTally DynamicTypingSmalltalkCompleter). - AppLauncher appGlobalName ifNotNil: [ :any | - keep add: any ]. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - [ - #hereWeGo print. - unused do: [:c | - c print. - (Smalltalk at: c) removeFromSystem]. - n := Smalltalk removeAllUnSentMessages. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - n > 0 or: [ - unused notEmpty ]] whileTrue. - ChangeSet zapAllChangeSets. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - Symbol rehash. - - "Shrink method dictionaries." - Smalltalk garbageCollect. - oldDicts _ MethodDictionary allInstances. - newDicts _ Array new: oldDicts size. - oldDicts withIndexDo: [:d :index | - newDicts at: index put: d rehashWithoutBecome ]. - oldDicts elementsExchangeIdentityWith: newDicts. - oldDicts _ newDicts _ nil. - - SmalltalkCompleter initialize . - - "Sanity checks" -" Undeclared - Smalltalk cleanOutUndeclared - Smalltalk browseUndeclaredReferences - Smalltalk obsoleteClasses - Smalltalk obsoleteBehaviors - Smalltalk browseObsoleteMethodReferences - SmalltalkImage current fixObsoleteReferences - Smalltalk browseAllUnimplementedCalls"! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3909-reduceCuis-fix-JuanVuletich-2019Oct09-14h36m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3904] on 8 October 2019 at 10:16:09 pm'! -!TheWorldMenu methodsFor: 'private' stamp: 'pb 10/8/2019 22:07:22'! - pvtAlphaSplitListDepth - "Split factor. A higher number results in fewer items in each submenu" - ^ 4! ! -!TheWorldMenu methodsFor: 'private' stamp: 'pb 10/8/2019 22:07:30'! - pvtCategorySplitListDepth - "Split factor. A higher number results in fewer items in each submenu" - ^ 2.! ! -!TheWorldMenu methodsFor: 'private' stamp: 'pb 10/8/2019 22:14:40'! - pvtMaxItemsPerCategorySubMenu - "If the number of items exceeds this value, split the category submenu into sub-submenus" - ^ 15.! ! -!TheWorldMenu methodsFor: 'private' stamp: 'pb 10/8/2019 22:00:02'! - pvtNewMenuForSplitLists: splitLists -| firstChar lastChar menu subMenu | -menu := MenuMorph new defaultTarget: self. - 1 - to: splitLists size - do: [ :i | - firstChar := i = 1 - ifTrue: [ $A ] - ifFalse: [ - (splitLists at: i) first name first: 3 ]. - lastChar := i = splitLists size - ifTrue: [ $Z ] - ifFalse: [ - (splitLists at: i) last name first: 3 ]. - subMenu := MenuMorph new. - (splitLists at: i) do: [ :cl | - subMenu - add: cl name - target: self - action: #newMorphOfClass:event: - argument: cl ]. - menu - add: firstChar asString , ' - ' , lastChar asString - subMenu: subMenu ]. - ^ menu.! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'pb 10/8/2019 22:07:54' prior: 50393211! - alphabeticalMorphMenu - | list splitLists | - list := Morph withAllSubclasses select: [ :m | - m includeInNewMorphMenu ]. - list := list asArray sort: [ :c1 :c2 | - c1 name < c2 name ]. - splitLists := self - splitNewMorphList: list - depth: self pvtAlphaSplitListDepth . - ^ self pvtNewMenuForSplitLists: splitLists -! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'pb 10/8/2019 22:11:22' prior: 50393320! - newMorph - "The user requested 'new morph' from the world menu. Put up a menu that allows many ways of obtaining new morphs. If the preference #classicNewMorphMenu is true, the full form of yore is used; otherwise, a much shortened form is used." - | menu catDict | - menu _ self menu: 'Add a new morph'. - menu - - add: 'From Clipboard' - target: myHand - action: #pasteMorph; - - add: 'From Alphabetical List' - subMenu: self alphabeticalMorphMenu. - menu addLine. - "Add 'Classic' New Morph menu" - catDict _ Dictionary new. - Morph allSubclassesDo: [ :eaSubclass | - eaSubclass includeInNewMorphMenu ifTrue: [ | category | - (eaSubclass respondsTo: #categoryInNewMorphMenu) - ifTrue: [ category _ eaSubclass categoryInNewMorphMenu ] - ifFalse: [ category _ 'Unknown' ]. - (catDict includesKey: category) - ifTrue: [ (catDict at: category) add: eaSubclass ] - ifFalse: [ - catDict - at: category - put: (OrderedCollection with: eaSubclass) ]]]. - catDict keys sort do: [ :categ | | morphsInCat | - morphsInCat _ (catDict at: categ) asArray sort: [ :c1 :c2 | - c1 name < c2 name ]. - morphsInCat size > self pvtMaxItemsPerCategorySubMenu - ifTrue: [ - menu - add: categ - subMenu: - (self pvtNewMenuForSplitLists: - (self - splitNewMorphList: morphsInCat - depth: self pvtCategorySplitListDepth )) ] - ifFalse: [ | subMenu | - subMenu _ MenuMorph new. - morphsInCat do: [ :cl | - subMenu - add: cl name - target: self - action: #newMorphOfClass:event: - argument: cl ]. - menu - add: categ - subMenu: subMenu ]]. - self doPopUp: menu.! ! - -TheWorldMenu removeSelector: #pvtMaxItemsPerCategory! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3910-New-Morph-category-menu-split-PhilBellalouna-2019Oct08-21h55m-pb.1.cs.st----! - -'From Cuis 5.0 [latest update: #3846] on 9 October 2019 at 10:19:37 am'! - -Refactoring subclass: #RenameInstanceVariable - instanceVariableNames: 'oldVariable addInstanceVariable rewriter renamedReferences newVariable methodsAndRangesToChange classToRefactor ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameInstanceVariable category: #'Tools-Refactoring'! -Refactoring subclass: #RenameInstanceVariable - instanceVariableNames: 'oldVariable addInstanceVariable rewriter renamedReferences newVariable methodsAndRangesToChange classToRefactor' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!CodeProvider methodsFor: 'contents' stamp: 'HAW 10/8/2019 16:39:33'! - instanceVariableRenamed - - self acceptedContentsChanged -! ! -!Debugger methodsFor: 'accessing' stamp: 'HAW 10/8/2019 16:52:56'! - resetToSelectedContextWith: newMethod - - | ctxt | - - ctxt := interruptedProcess popTo: self selectedContext. - ctxt == self selectedContext - ifFalse: - [self inform: 'Method saved, but current context unchanged\because of unwind error. Click OK to see error' withNewLines] - ifTrue: - [newMethod isQuick ifFalse: - [interruptedProcess - restartTopWith: newMethod; - stepToSendOrReturn]. - contextVariablesInspector object: nil]. - self resetContext: ctxt. - ! ! -!Debugger methodsFor: 'contents' stamp: 'HAW 10/8/2019 16:54:07'! - instanceVariableRenamed - - | newMethod | - - newMethod := self selectedClass compiledMethodAt: self selectedContext selector. - self resetToSelectedContextWith: newMethod ! ! -!Categorizer class methodsFor: 'well known categories' stamp: 'HAW 10/8/2019 14:45:15'! - initialization - - ^'initialization'! ! -!Categorizer class methodsFor: 'well known categories' stamp: 'HAW 10/8/2019 17:18:38'! - instanceCreation - - ^'instance creation'! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'testing' stamp: 'HAW 10/9/2019 10:06:00'! - isAtClassNameInClassDefinition: anIndex - - ^(classDefinitionNode rangeForNode: classCreationMessageNode arguments first ifAbsent: [ ^ false ]) first includes: anIndex! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'testing' stamp: 'HAW 10/9/2019 10:04:36'! - isAtSuperclassInClassDefinition: anIndex - - ^(classDefinitionNode rangeForNode: superClassNode ifAbsent: [ ^ false ]) first includes: anIndex ! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'testing' stamp: 'HAW 10/9/2019 10:14:44'! - isClassDefinition - - ^classDefinitionNode encoder classEncoding isMeta not! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'parameters positions' stamp: 'HAW 10/9/2019 10:18:15'! - instanceVariableNamesPosition - - ^self isClassDefinition ifTrue: [ self class instanceVariableNamesPositionForClassDefinition ] ifFalse: [ self class instanceVariableNamesPositionForMetaclassDefinition ]! ! -!ClassDefinitionNodeAnalyzer class methodsFor: 'parameters positions' stamp: 'HAW 10/9/2019 10:18:41'! - instanceVariableNamesPositionForClassDefinition - - ^2! ! -!ClassDefinitionNodeAnalyzer class methodsFor: 'parameters positions' stamp: 'HAW 10/9/2019 10:18:46'! - instanceVariableNamesPositionForMetaclassDefinition - - ^1! ! -!RenameInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 10/9/2019 09:16:21'! - changeInstanceVariableName - - | instanceVariableNames oldVariableIndex | - - instanceVariableNames := classToRefactor instVarNames. - oldVariableIndex := instanceVariableNames indexOf: oldVariable. - instanceVariableNames at: oldVariableIndex put: newVariable.! ! -!RenameInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 10/9/2019 09:07:24'! - keepMethodToChangeNamed: aSelector in: aClass - - | methodToChange rangesToChange | - - methodToChange := aClass >> aSelector. - rangesToChange := methodToChange methodNode positionsForInstanceVariable: oldVariable ifAbsent: [ #() ]. - - methodsAndRangesToChange add: methodToChange -> rangesToChange ! ! -!RenameInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 10/9/2019 09:16:15'! - lookForMethodsReferencingOldVariable - - methodsAndRangesToChange := OrderedCollection new. - classToRefactor withAllSubclassesDo: [ :aClass | self lookForMethodsReferencingOldVariableIn: aClass ]. -! ! -!RenameInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 10/9/2019 09:06:51'! - lookForMethodsReferencingOldVariableIn: aClass - - (aClass whichSelectorsAccess: oldVariable) do: [ :aSelector | self keepMethodToChangeNamed: aSelector in: aClass ]. - ! ! -!RenameInstanceVariable methodsFor: 'initialization' stamp: 'HAW 10/9/2019 09:14:17'! -initializeFrom: anOldvariable to: aNewVariable in: aClassToRefactor - - oldVariable := anOldvariable. - newVariable := aNewVariable. - classToRefactor := aClassToRefactor ! ! -!Debugger methodsFor: 'accessing' stamp: 'HAW 10/8/2019 16:53:16' prior: 50468425! - contents: aText notifying: aController - "The retrieved information has changed and its source must now be updated. - In this case, the retrieved information is the method of the selected context." - - | result selector classOfMethod category h newMethod | - - contextStackIndex = 0 ifTrue: [^false]. - - classOfMethod := self selectedClass. - category := self selectedMessageCategoryName. - selector :=self selectedClass parserClass selectorFrom: aText. - - selector ~= self selectedMessageName ifTrue: [ - self inform: 'Can not change the selector in the debugger'. - ^false]. - (classOfMethod = UndefinedObject and: [ selector = Scanner doItSelector or: [ selector = Scanner doItInSelector ]]) ifTrue: [ - self inform: 'DoIt and DoItIn: methods can not be changed'. - ^false]. - - self selectedContext isExecutingBlock ifTrue: [ - h := self selectedContext activeHome. - h ifNil: [ - self inform: 'Method for block not found on stack, can''t edit and continue'. - ^false]. - (self confirm: 'I will have to revert to the method from\which this block originated. Is that OK?' withNewLines) ifFalse: [^false]. - self resetContext: h. - (result := self contents: aText notifying: aController) ifTrue: [self acceptedContentsChanged]. - ^result]. - - selector := classOfMethod - compile: aText - classified: category - notifying: aController. - selector ifNil: [^false]. "compile cancelled" - newMethod := classOfMethod compiledMethodAt: selector. - - newMethod isQuick ifTrue: [ - contextStackIndex + 1 > contextStack size ifTrue: [ - self inform: 'Can not compile a quick method in the stack base context'. - ^false]. - self down. - self selectedContext jump: (self selectedContext previousPc - self selectedContext pc)]. - - self resetToSelectedContextWith: newMethod. - - ^true! ! -!Debugger methodsFor: 'context stack menu' stamp: 'HAW 10/8/2019 17:18:14' prior: 16829788! - askForCategoryIn: aClass default: aDefaultCategory - - | categories index category classCategories | - - categories := OrderedCollection with: 'new ...'. - - aClass isMeta ifTrue: [ categories add: Categorizer instanceCreation ]. - classCategories := aClass allMethodCategoriesIntegratedThrough: Object. - aClass isMeta ifTrue: [ classCategories remove: Categorizer instanceCreation ifAbsent: []]. - - categories addAll: classCategories. - index := PopUpMenu - withCaption: 'Please provide a good category for the new method!!' - chooseFrom: categories. - index = 0 ifTrue: [^ aDefaultCategory]. - category := index = 1 - ifTrue: [FillInTheBlankMorph request: 'Enter category name:'] - ifFalse: [categories at: index]. - - ^ category isEmpty ifTrue: [aDefaultCategory] ifFalse: [category]! ! -!Debugger methodsFor: 'method creation' stamp: 'HAW 10/8/2019 17:15:10' prior: 50418474! - implement: aMessage inClass: aClass context: aContext - - self implement: aMessage inCategory: (self askForCategoryIn: aClass default: Categorizer default) fromClass: aClass context: aContext! ! -!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'HAW 10/8/2019 17:21:29' prior: 16806150! - allMethodCategoriesIntegratedThrough: mostGenericClass - "Answer a list of all the method categories of the receiver and all its superclasses, up through mostGenericClass" - - | aColl | - aColl _ OrderedCollection new. - self withAllSuperclasses do: [ :aClass | - (aClass includesBehavior: mostGenericClass) - ifTrue: [ aColl addAll: aClass organization categories ]]. - aColl remove: 'no messages' asSymbol ifAbsent: nil. - - ^ aColl asSet asSortedCollection: [ :a :b | a asLowercase < b asLowercase ] - -"ColorTileMorph allMethodCategoriesIntegratedThrough: TileMorph"! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'testing' stamp: 'HAW 10/9/2019 10:14:50' prior: 50452235! - isAtCategory: anIndex - - ^self isClassDefinition and: [ self is: anIndex atStringParameterNumber: self class categoryPosition ] - ! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'testing' stamp: 'HAW 10/9/2019 10:14:57' prior: 50460716! - isAtClassName: anIndex - - ^self isClassDefinition and: [ self isAtClassNameInClassDefinition: anIndex ] - ! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'testing' stamp: 'HAW 10/9/2019 10:09:14' prior: 50452248! - isAtInstanceVariables: anIndex - - ^self is: anIndex atStringParameterNumber: self instanceVariableNamesPosition! ! -!ClassDefinitionNodeAnalyzer methodsFor: 'testing' stamp: 'HAW 10/9/2019 10:15:11' prior: 50460724! - isAtSuperclass: anIndex - - ^self isClassDefinition and: [ self isAtSuperclassInClassDefinition: anIndex ]! ! -!AutoCompleterSelectorsCollector methodsFor: 'entries to show - private' stamp: 'HAW 10/8/2019 17:19:27' prior: 50434213! - prioritizedCategories - - ^{Categorizer instanceCreation}! ! -!RenameInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 10/9/2019 09:14:52' prior: 50440900! - newSourceOf: aMethodAndRangesToChange - - | newSource ranges methodToChange | - - methodToChange := aMethodAndRangesToChange key. - ranges := aMethodAndRangesToChange value. - newSource := methodToChange sourceCode copyReplacing: ranges with: newVariable. - - ^newSource - ! ! -!RenameInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 10/9/2019 09:09:41' prior: 50440917! - renameReferencesToOldVariable - - renamedReferences := OrderedCollection new. - methodsAndRangesToChange do: [ :aMethodAndRangesToChange | self renameReferencesToOldVariableInMethod: aMethodAndRangesToChange ]. - ! ! -!RenameInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 10/9/2019 09:01:03' prior: 50440939! -renameReferencesToOldVariableInMethod: aMethodAndRangesToChange - - | methodToChange | - - methodToChange := aMethodAndRangesToChange key. - methodToChange methodClass compile: (self newSourceOf: aMethodAndRangesToChange). - renamedReferences add: methodToChange methodReference ! ! -!RenameInstanceVariable methodsFor: 'applying' stamp: 'HAW 10/9/2019 09:08:49' prior: 50440948! - apply - - self - lookForMethodsReferencingOldVariable; - changeInstanceVariableName; - renameReferencesToOldVariable. - - ^renamedReferences - ! ! -!RenameInstanceVariable class methodsFor: 'instance creation' stamp: 'HAW 10/9/2019 09:13:37' prior: 50440999! - from: anOldvariable to: aNewVariable in: aClassToRefactor - - | trimmedNewVariable | - - trimmedNewVariable := aNewVariable withBlanksTrimmed. - self assert: aClassToRefactor defines: anOldvariable. - NewInstanceVariablePrecondition valueOf: trimmedNewVariable for: aClassToRefactor. - - ^self new initializeFrom: anOldvariable to: trimmedNewVariable in: aClassToRefactor ! ! -!RenameInstanceVariableApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 10/9/2019 09:21:29' prior: 50442202! - requestRefactoringParameters - - self - chooseInstanceVariable; - askNewVariableName! ! -!RenameInstanceVariableApplier methodsFor: 'refactoring - changes' stamp: 'HAW 10/8/2019 16:55:08' prior: 50442222! - informChangesToBrowser - - browser instanceVariableRenamed ! ! -!RenameInstanceVariableApplier methodsFor: 'refactoring - changes' stamp: 'HAW 10/8/2019 16:55:44' prior: 50442242! - showChanges - - self informChangesToBrowser! ! -!RenameInstanceVariableApplier class methodsFor: 'instance creation' stamp: 'HAW 10/8/2019 17:02:16' prior: 50442265! - on: aBrowser for: anInstanceVariableName at: aClassToRefactor - - ^self new initializeOn: aBrowser for: anInstanceVariableName at: aClassToRefactor ! ! - -RenameInstanceVariableApplier removeSelector: #applyRefactoring! - -RenameInstanceVariableApplier removeSelector: #isOnDebugger! - -RenameInstanceVariableApplier removeSelector: #openChangedMethods! - -RenameInstanceVariableApplier removeSelector: #openChangedMethods! - -RenameInstanceVariableApplier removeSelector: #openChangedMethodsWhenChangesNotEmpty! - -RenameInstanceVariableApplier removeSelector: #openChangedMethodsWhenChangesNotEmpty! - -RenameInstanceVariableApplier removeSelector: #value! - -RenameInstanceVariableApplier removeSelector: #warnIfOnDebugger! - -RenameInstanceVariable removeSelector: #addNewInstanceVariable! - -RenameInstanceVariable removeSelector: #addNewInstanceVariable! - -RenameInstanceVariable removeSelector: #classToRefactor! - -RenameInstanceVariable removeSelector: #classToRefactor! - -RenameInstanceVariable removeSelector: #copyOldInstanceVariableToNewOne! - -RenameInstanceVariable removeSelector: #copyOldInstanceVariableToNewOne! - -RenameInstanceVariable removeSelector: #initializeFrom:addingWith:! - -RenameInstanceVariable removeSelector: #initializeFrom:addingWith:! - -RenameInstanceVariable removeSelector: #newVariable! - -RenameInstanceVariable removeSelector: #newVariable! - -RenameInstanceVariable removeSelector: #removeOldInstanceVariable! - -RenameInstanceVariable removeSelector: #removeOldInstanceVariable! - -RenameInstanceVariable removeSelector: #renameReferencesToOldVariableInClass:! - -RenameInstanceVariable removeSelector: #renameReferencesToOldVariableInClass:! - -ClassDefinitionNodeAnalyzer class removeSelector: #instanceVariableNamesPosition! - -ClassDefinitionNodeAnalyzer class removeSelector: #instanceVariableNamesPosition! - -ClassDefinitionNodeAnalyzer removeSelector: #isMetaclassDefinition! - -Refactoring subclass: #RenameInstanceVariable - instanceVariableNames: 'oldVariable renamedReferences methodsAndRangesToChange newVariable classToRefactor' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameInstanceVariable category: #'Tools-Refactoring'! -Refactoring subclass: #RenameInstanceVariable - instanceVariableNames: 'oldVariable renamedReferences methodsAndRangesToChange newVariable classToRefactor' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3911-RenameInstanceVariableRefactoring-HernanWilkinson-2019Oct07-14h29m-HAW.2.cs.st----! - -'From Cuis 5.0 [latest update: #3911] on 10 October 2019 at 9:24:43 am'! -!TextEditor methodsFor: 'new selection' stamp: 'jmv 10/10/2019 09:22:28' prior: 50473976! - messageSendsRanges: aRanges - "aRanges must be notEmpty" - | lastRange | - - selectionStartBlocks := OrderedCollection new. - selectionStopBlocks := OrderedCollection new. - lastRange := nil. - - aRanges do: [ :range | - selectionStartBlocks add: (textComposition characterBlockForIndex: range first). - selectionStopBlocks add: (textComposition characterBlockForIndex: range last + 1). - ( lastRange isNil or: [ range first > lastRange first ]) ifTrue: [ - lastRange _ range ]]. - self selectFrom: lastRange first to: lastRange last! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3912-messageSendsRanges-mightBeASet-JuanVuletich-2019Oct10-09h22m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3912] on 10 October 2019 at 10:19:48 am'! - -Error subclass: #RecompilationFailure - instanceVariableNames: 'class selector ' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #RecompilationFailure category: #'Exceptions Kernel'! -Error subclass: #RecompilationFailure - instanceVariableNames: 'class selector' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! -!RecompilationFailure methodsFor: 'private' stamp: 'HAW 10/10/2019 10:09:03'! - class: aClass messageText: aString - class _ aClass. - messageText _ aString! ! -!RecompilationFailure class methodsFor: 'instance creation' stamp: 'HAW 10/10/2019 10:09:30'! - class: aClass messageText: aString - ^ self new class: aClass messageText: aString! ! -!Encoder methodsFor: 'private' stamp: 'HAW 10/10/2019 10:15:32' prior: 50444232! - warnAboutShadowed: name - - | msg | - - msg _ 'There already exists a variable named ', name, ' '. - requestor addWarning: msg. - Transcript newLine; show: msg. - InMidstOfFileinNotification signal - ifFalse: [ - requestor interactive - ifTrue: [ - self notify: msg] - ifFalse: [ - (RecompilationFailure - class: class - messageText: msg, String newLineString, 'Please use a different name') signal ]]! ! - -RecompilationFailure class removeSelector: #class:selector:messageText:! - -RecompilationFailure class removeSelector: #class:selector:messageText:! - -RecompilationFailure removeSelector: #class:selector:messageText:! - -RecompilationFailure removeSelector: #class:selector:messageText:! - -RecompilationFailure removeSelector: #messageText! - -RecompilationFailure removeSelector: #messageText! - -Error subclass: #RecompilationFailure - instanceVariableNames: 'class' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #RecompilationFailure category: #'Exceptions Kernel'! -Error subclass: #RecompilationFailure - instanceVariableNames: 'class' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3913-RecompilationFailureRemovedSelector-HernanWilkinson-2019Oct10-10h05m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3913] on 11 October 2019 at 10:12:30 pm'! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'eem 8/28/2009 14:52'! - voidCogVMState - "Void any internal caches the VM maintains other than the method lookup caches. - These comprise - - the stack zone, where method activations are stored, and - - the machine code zone, where the machine code form of CompiledMethods is held." - - ^self primitiveFailed - - "Time millisecondsToRun: [Smalltalk voidCogVMState]" - "(1 to: 10) collect: [:ign| Time millisecondsToRun: [Smalltalk voidCogVMState]]"! ! -!SystemDictionary methodsFor: 'vm parameters' stamp: 'jmv 10/11/2019 22:09:36'! - doMixedArithmetic - "If true, then primitives can handle the conversions: - SmallInteger arithmeticOp: Float (Small or Boxed) - SmallInteger compareOp: Float (Small or Boxed) - Else, the primitive fail in case of mixed arithmetic, and conversion will be performed at image side. - See doMixedArithmetic: - - Note: - OpenSmalltalk VMs after March, 2019 can set the option and will honor it. The comparison operation behaves as if the Float was converted #asTrueFraction. This means that some rather big SmallIntegers in 64 bit systems, that can not be represented exactly as a Float will not be equal to any Float. Squeak adopted this critera. Cuis follows the more conventional, Smalltalk-80 tradition to always convert to Float if any operand is Float. Therefore Cuis needs to do 'Smalltalk doMixedArithmetic: false'. - Previous VMs can not set the option, and will answer true when queried. But these VMs did the conversion to Float, and the requested operation in Floats. So, with these VMs, Cuis will also have the desired behavior." - - ^ ((Smalltalk vmParameterAt: 48) allMask: 64) not! ! -!SystemDictionary methodsFor: 'vm parameters' stamp: 'jmv 10/11/2019 22:10:11'! - doMixedArithmetic: aBoolean - "If set to true, then primitives can handle the conversions: - SmallInteger arithmeticOp: Float (Small or Boxed) - SmallInteger compareOp: Float (Small or Boxed) - Else, the primitive fail in case of mixed arithmetic, and conversion will be performed at image side. - - Please see comment at #doMixedArithmetic" - - "Ignore request if VM doesn't support it" - [ - self vmParameterAt: 48 put: ((self vmParameterAt: 48) bitClear: 64) + (aBoolean ifTrue: [0] ifFalse: [64]). - ] on: Error do: [].! ! -!SystemDictionary methodsFor: 'startup' stamp: 'jmv 10/11/2019 22:11:55' prior: 50470922! -doStartUp: isARealStartup - " - isARealStartup - true: system is coming up (VM and image just started) - false: we have just saved an image snapshot, but didn't quit. - " - "Here, startup begins!!" - Cursor defaultCursor activateCursor. - self setGCParameters. - isARealStartup ifTrue: [ self clearExternalObjects ]. - - "We need to do this on startup because we can not know if the image was saved with a pre March2019 VM, - and started with a later VM that handles the option. - Please see comment at #doMixedArithmetic" - self doMixedArithmetic: false. - - self readCommandLineArguments. - self processStartUpList: isARealStartup. - isARealStartup ifTrue: [ - self setPlatformPreferences. - self setStartupStamp ].! ! -!SystemDictionary methodsFor: 'vm parameters' stamp: 'jmv 10/11/2019 19:12:58' prior: 16921183! - vmParameterAt: parameterIndex - "parameterIndex is a positive integer corresponding to one of the VM's internal parameter/metric registers. - Answer with the current value of that register. - Answer nil if the VM doesn't provide the register, and the primitive fails. - - Also see #getVMParameters and #vmParameterAt:put: These 3 methods call the - same primitive, whose behavior depends on argument count: - 0 args: return an Array of VM parameter values; - 1 arg: return the indicated VM parameter; - 2 args: set the VM indicated parameter. - - VM parameters are numbered as follows: - 1 end (v3) / size(Spur) of old-space (0-based, read-only) - 2 end of young-space (v3) / size of new-space (Spur) (read-only) - 3 end (v3) / size(Spur) of heap (read-only) - 4 nil (was allocationCount (read-only)) - 5 nil (was allocations between GCs (read-write) - 6 survivor count tenuring threshold (read-write) - 7 full GCs since startup (read-only) - 8 total milliseconds in full GCs since startup (read-only) - 9 incremental GCs (v3) / scavenges (Spur) since startup (read-only) - 10 total milliseconds in incremental GCs (v3) / scavenges (Spur) since startup (read-only) - 11 tenures of surving objects since startup or reset (read-write) - 12-20 were specific to ikp's JITTER VM, now 12-15 are open for use - 16 total microseconds at idle since start-up (if non-zero) - 17 fraction of the code zone to use (Sista only; used to control code zone use to preserve sendAndBranchData on counter tripped callback) - 18 total milliseconds in compaction phase of full GC since start-up (Spur only) - 19 scavenge threshold, the effective size of eden. When eden fills to the threshold a scavenge is scheduled. Newer Spur VMs only. - 20 utc microseconds at VM start-up (actually at time initialization, which precedes image load). - 21 root/remembered table size (occupancy) (read-only) - 22 root table overflows since startup (read-only) - 23 bytes of extra memory to reserve for VM buffers, plugins, etc (stored in image file header). - 24 memory threshold above which shrinking object memory (rw) - 25 memory headroom when growing object memory (rw) - 26 interruptChecksEveryNms - force an ioProcessEvents every N milliseconds (rw) - 27 number of times mark loop iterated for current IGC/FGC (read-only) includes ALL marking - 28 number of times sweep loop iterated for current IGC/FGC (read-only) - 29 number of times make forward loop iterated for current IGC/FGC (read-only) - 30 number of times compact move loop iterated for current IGC/FGC (read-only) - 31 number of grow memory requests (read-only) - 32 number of shrink memory requests (read-only) - 33 number of root table entries used for current IGC/FGC (read-only) - 34 Spur: bytes allocated in total since start-up or reset (read-write) (Used to be number of allocations done before current IGC/FGC (read-only)) - 35 number of survivor objects after current IGC/FGC (read-only) - 36 millisecond clock when current IGC/FGC completed (read-only) - 37 number of marked objects for Roots of the world, not including Root Table entries for current IGC/FGC (read-only) - 38 milliseconds taken by current IGC (read-only) - 39 Number of finalization signals for Weak Objects pending when current IGC/FGC completed (read-only) - 40 BytesPerOop for this image - 41 imageFormatVersion for the VM - 42 number of stack pages in use - 43 desired number of stack pages (stored in image file header, max 65535) - 44 size of eden, in bytes - 45 desired size of eden, in bytes (stored in image file header) - 46 machine code zone size, in bytes (Cog only; otherwise nil) - 47 desired machine code zone size (stored in image file header; Cog only; otherwise nil) - 48 various header flags. - Bit 0: tells the VM that the image's Process class has threadId as its 5th inst var (after nextLink, suspendedContext, priority & myList) - Bit 1: on Cog JIT VMs asks the VM to set the flag bit in interpreted methods - Bit 2: if set, preempting a process puts it to the head of its run queue, not the back, - i.e. preempting a process by a higher priority one will not cause the preempted process to yield - to others at the same priority. - Bit 3: in a muilt-threaded VM, if set, the Window system will only be accessed from the first VM thread - Bit 4: in a Spur vm, if set, causes weaklings and ephemerons to be queued individually for finalization - Bit 5: (on VMs that support it) if set, implies wheel events will be delivered as such and not mapped to arrow key events - Bit 6: (on VMs that support it) whether the arithmetic primitives perform conversion in case of mixed SmallInteger/Float (not set) or fail (set) - (on VMs that don't support it, those primitives will fail in those cases) - 49 max size the image promises to grow the external semaphore table to (0 sets to default, which is 256 as of writing) - 50-51 nil; reserved for VM parameters that persist in the image (such as eden above) - 52 root/remembered table capacity - 53 number of segments (Spur only; otherwise nil) - 54 total size of free old space (Spur only, otherwise nil) - 55 ratio of growth and image size at or above which a GC will be performed post scavenge - 56 number of process switches since startup (read-only) - 57 number of ioProcessEvents calls since startup (read-only) - 58 number of ForceInterruptCheck calls since startup (read-only) - 59 number of check event calls since startup (read-only) - 60 number of stack page overflows since startup (read-only) - 61 number of stack page divorces since startup (read-only) - 62 compiled code compactions since startup (read-only; Cog only; otherwise nil) - 63 total milliseconds in compiled code compactions since startup (read-only; Cog only; otherwise nil) - 64 the number of methods that currently have jitted machine-code - 65 whether the VM supports a certain feature, MULTIPLE_BYTECODE_SETS is bit 0, IMMUTABILITY is bit 1 - 66 the byte size of a stack page - 67 the max allowed size of old space (Spur only; nil otherwise; 0 implies no limit except that of the underlying platform) - 68 the average number of live stack pages when scanned by GC (at scavenge/gc/become et al) (read-write) - 69 the maximum number of live stack pages when scanned by GC (at scavenge/gc/become et al) (read-write) - 70 the vmProxyMajorVersion (the interpreterProxy VM_MAJOR_VERSION) - 71 the vmProxyMinorVersion (the interpreterProxy VM_MINOR_VERSION) - 72 total milliseconds in full GCs Mark phase since startup (read-only) - 73 total milliseconds in full GCs Sweep phase since startup (read-only, can be 0 depending on compactors) - 74 maximum pause time due to segment allocation" - - - ^nil! ! -!SystemDictionary methodsFor: 'vm parameters' stamp: 'jmv 10/11/2019 19:12:16' prior: 16921316! - vmParameterAt: parameterIndex put: newValue - "parameterIndex is a positive integer corresponding to one of the VM's internal - parameter/metric registers. Store newValue (a positive integer) into that - register and answer with the previous value that was stored there. - Fail if newValue is out of range, if parameterIndex has no corresponding - register, or if the corresponding register is read-only. - - As of mid 2017 the parameters which can be set are - 5 allocations between GCs (read-write; nil in Cog VMs) - 6 survivor count tenuring threshold (read-write) - 17 proportion of code zone available for use (Sista VMs only) - 23 bytes of extra memory to reserve for VM buffers, plugins, etc. - 24 memory threshold above whichto shrink object memory (read-write) - 25 memory headroom when growing object memory (read-write) - 26 interruptChecksEveryNms - force an ioProcessEvents every N milliseconds (read-write) - 34 bytes allocated in total since start-up or reset (read-write) - 43 desired number of stack pages (stored in image file header, max 65535; Cog VMs only, otherwise nil) - 45 desired size of eden, in bytes (stored in image file header; Cog VMs only, otherwise nil) - 47 desired size of machine code zone, in bytes (applies at startup only, stored in image file header; Cog JIT VM only) - 48 various properties of the Cog VM as an integer encoding an array of bit flags. - Bit 0: tells the VM that the image's Process class has threadId as its 5th inst var (after nextLink, suspendedContext, priority & myList) - Bit 1: on Cog JIT VMs asks the VM to set the flag bit in interpreted methods - Bit 2: if set, preempting a process puts it to the head of its run queue, not the back, - i.e. preempting a process by a higher priority one will not cause the preempted process to yield - to others at the same priority. - Bit 3: in a muilt-threaded VM, if set, the Window system will only be accessed from the first VM thread - Bit 4: in a Spur vm, if set, causes weaklings and ephemerons to be queued individually for finalization - Bit 5: (on VMs that support it) if set, implies wheel events will be delivered as such and not mapped to arrow key events - Bit 6: (on VMs that support it) whether the arithmetic primitives perform conversion in case of mixed SmallInteger/Float (not set) or fail (set) - (on VMs that don't support it, those primitives will fail in those cases) - 49 the size of the external semaphore table (read-write; Cog VMs only) - 55 ratio of growth and image size at or above which a GC will be performed post scavenge (Spur only, otherwise nil) - 67 the maximum allowed size of old space in bytes, 0 implies no internal limit (Spur only)." - - - self primitiveFailed! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Smalltalk doMixedArithmetic: false.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3914-SetMixedArithmeticVMOption-JuanVuletich-2019Oct11-22h00m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3914] on 12 October 2019 at 11:35:42 am'! -!Integer methodsFor: 'testing' stamp: 'a s + sqr 10/11/2019 23:51:08' prior: 16860216! - isPrime - - self < 3 ifTrue: [^self = 2]. - self even ifTrue: [^false]. - self \\ 3 = 0 ifTrue: [^self = 3]. - self \\ 5 = 0 ifTrue: [^self = 5]. - self < 8281 ifTrue: [ - "Approximate sqrtFloor to avoid computational expense" - self \\ 7 = 0 ifTrue: [^self = 7]. - self \\ 11 = 0 ifTrue: [^self = 11]. - self \\ 13 = 0 ifTrue: [^self = 13]. - 12 to: (self bitShift: -6) + 11 by: 6 do: [:each | - self \\ (each+5) = 0 ifTrue: [^false]. - self \\ (each+7) = 0 ifTrue: [^false] - ]. - ^true - ]. - "Now 2, 3 and 5 do not divide self. So, self is of the form - 30*k + {1, 7, 11, 13, 17, 19, 23, 29} for integer k >= 0. - The 31 case below is the 30k+1 case, excluding k = 0" - 0 to: self sqrtFloor by: 30 do: [:each | - self \\ (each+7) = 0 ifTrue: [^false]. - self \\ (each+11) = 0 ifTrue: [^false]. - self \\ (each+13) = 0 ifTrue: [^false]. - self \\ (each+17) = 0 ifTrue: [^false]. - self \\ (each+19) = 0 ifTrue: [^false]. - self \\ (each+23) = 0 ifTrue: [^false]. - self \\ (each+29) = 0 ifTrue: [^false]. - self \\ (each+31) = 0 ifTrue: [^false] - ]. - ^true! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3915-isPrime-performanceImprovements-AgustinSansone-AndresValloud-2019Oct12-11h34m-sqr.1.cs.st----! - -'From Cuis 5.0 [latest update: #3913] on 11 October 2019 at 12:35:03 pm'! -!FeatureRequirement methodsFor: 'requires' stamp: 'jmv 10/11/2019 12:34:45'! - requireUnlessIn: toLoad main: mainFeatureOrNil requiringFeature: requiringFeatureOrNil - "See if all the requirements can be met and answer the load order" - - self isAlreadySatisfied ifFalse: [ - (toLoad anySatisfy: [ :featReq | featReq sameNameAs: self]) ifFalse: [ - (self findPackageFileAsReqOf: mainFeatureOrNil) - ifTrue: [ | otherRequirements | - otherRequirements := self requirements. - otherRequirements ifNotNil: [ - otherRequirements do: [ :requires | - requires requireUnlessIn: toLoad main: (mainFeatureOrNil ifNil: [self]) requiringFeature: self ]]. - self == mainFeatureOrNil ifFalse: [ - self addToLoad: toLoad withMyRequirements: otherRequirements ]. - ] - ifFalse: [ | failureMessage | - failureMessage := 'Could not find package supplying: ', self printString, String newLineString, - 'Required by: ', (requiringFeatureOrNil ifNil: [ self ]) printString, String newLineString, - 'For installing: ', (mainFeatureOrNil ifNil: [ self ]) printString, String newLineString. - FeatureRequirementUnsatisfied signal: failureMessage. - ]]]. - - ^ toLoad! ! -!PackageRequirementsList methodsFor: 'accessing' stamp: 'jmv 10/11/2019 12:16:09' prior: 50432016! - updateSelectedRequirement - - | selectedPackage requiredPackage featureSpec requirementToUpdate updatedRequirement newRequires selectedName | - self selectionIndex ifNil: [ ^self ]. - self selectionIndex isZero ifTrue: [ ^self ]. - ((codePackageList selectionIndex isNil) or: [ codePackageList selectionIndex isZero ]) - ifTrue: [ ^self ]. - - selectedPackage := codePackageList selection. - featureSpec := selectedPackage featureSpec. - requirementToUpdate := self selection. - updatedRequirement := (selectedName _ requirementToUpdate name) = Feature baseSystemFeature name - ifTrue: [ Feature baseSystemFeature requirementOfMe ] - ifFalse: [ - requiredPackage := CodePackage installedPackages at: selectedName. - requiredPackage hasUnsavedChanges - ifTrue: [ self notify: 'Please save package ', requiredPackage packageName, ' first. Requirement version of an unsaved package can not be updated.'. ^self ]. - requiredPackage requirementOfMe ]. - newRequires := (featureSpec requires copyWithout: requirementToUpdate) copyWith: updatedRequirement. - featureSpec - provides: featureSpec provides - requires: newRequires. - selectedPackage hasUnsavedChanges: true. - requirements := codePackageList selection requires asArray. - self changed: #requirements - - - ! ! -!FeatureRequirement methodsFor: 'requires' stamp: 'jmv 10/11/2019 12:25:39' prior: 50475389! - require - "See if all the transitive closure of requirements can be met and answer the load order if so" - - | packagesToLoad | - - "Preflight before load - [1] Build transitive closure as load order where Feature comes - before its required features." - [packagesToLoad _ self requireUnlessIn: OrderedCollection new main: nil requiringFeature: nil] - on: FeatureRequirementUnsatisfied - do: [ :error | error defaultAction. - ^self "exit" - ]. - - "Transcript show: 'packagesToLoad: '; newLine. - packagesToLoad do: [ :x |Transcript show: x; newLine ]. - Transcript newLine." - - "[2] Check to see that each requirement is actually satisfied" - [packagesToLoad do: [ :fReq | fReq checkRequirement ]] - on: FeatureRequirementUnsatisfied - do: [ :error | error defaultAction. - ^self "exit" - ]. - - "[3] Load required packages before packages that require them" - packagesToLoad reverseDo: [ :requirement | - requirement isAlreadySatisfied ifFalse: [ - requirement install ]]. - self isAlreadySatisfied ifFalse: [ - self install ]! ! -!FeatureRequirement methodsFor: 'requires' stamp: 'jmv 10/11/2019 12:26:13' prior: 50475891! - satisfyRequirementsAndInstall - "Like #require, but install me even if already satisified (i.e. installed)" - - | packagesToLoad | - - "Preflight before load" - [packagesToLoad _ self requireUnlessIn: OrderedCollection new main: self requiringFeature: self] - on: FeatureRequirementUnsatisfied - do: [ :error | error defaultAction. - ^self "exit" - ]. - - "Check to see that each requirement is actually satisfied" - [packagesToLoad do: [ :fReq | fReq checkRequirement ]] - on: FeatureRequirementUnsatisfied - do: [ :error | error defaultAction. - ^self "exit" - ]. - - "All requirements are satisfied; do the deed" - packagesToLoad reverseDo: [ :requirement | - requirement isAlreadySatisfied ifFalse: [ - requirement install ]]. - self install! ! - -FeatureRequirement removeSelector: #requireUnlessIn:main:! - -FeatureRequirement removeSelector: #requireUnlessIn:main:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3916-FeatureRequirement-enh-JuanVuletich-2019Oct11-12h02m-jmv.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3812] on 26 June 2019 at 2:14:05 pm'! -!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'jmv 6/26/2019 14:12:51'! - title: argString at: argPoint from: argMinVal to: argMaxVal workBlock: argWorkBlock - - progressTitle _ argString. - aPoint _ argPoint. - minVal _ argMinVal. - maxVal _ argMaxVal. - currentVal _ minVal. - workBlock _ argWorkBlock.! ! -!ProgressInitiationException methodsFor: 'instance migration protection' stamp: 'jmv 6/26/2019 14:03:36'! - aPoint - ^aPoint! ! -!ProgressInitiationException methodsFor: 'instance migration protection' stamp: 'jmv 6/26/2019 14:04:37'! - currentVal - ^currentVal! ! -!ProgressInitiationException methodsFor: 'instance migration protection' stamp: 'jmv 6/26/2019 14:05:16'! - currentVal: val - currentVal _ val! ! -!ProgressInitiationException methodsFor: 'instance migration protection' stamp: 'jmv 6/26/2019 14:03:51'! - maxVal - ^maxVal! ! -!ProgressInitiationException methodsFor: 'instance migration protection' stamp: 'jmv 6/26/2019 14:03:57'! - minVal - ^minVal! ! -!ProgressInitiationException methodsFor: 'instance migration protection' stamp: 'jmv 6/26/2019 14:02:59'! - progressTitle - ^progressTitle! ! -!ProgressInitiationException methodsFor: 'instance migration protection' stamp: 'jmv 6/26/2019 14:04:22'! - workBlock - ^workBlock! ! -!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'jmv 6/26/2019 14:06:27' prior: 50472388! - defaultAction - - | delta textFrame barFrame outerFrame result range width filledWidth f h textWidth textForm innerBarFrame oldFilledWidth oldFilledWidth2 prevContents | - f _ AbstractFont default. - h _ f lineSpacing * 3//2. - textWidth _ (f widthOfString: self progressTitle) + h. - width _ 150 max: textWidth. - - textForm _ Form extent: width@h depth: 32. - textForm fillBlack. - textForm fillWhite: (textForm boundingBox insetBy: 2). - self progressTitle displayOn: textForm at: (width-textWidth+h//2@4). - barFrame _ Rectangle center: self aPoint extent: width@h. - textFrame _ `0@0` extent: width@h. - textFrame _ textFrame - aligned: textFrame bottomCenter - with: barFrame topCenter + `0@2`. - outerFrame _ barFrame merge: textFrame. - delta _ outerFrame amountToTranslateWithin: Display boundingBox. - barFrame _ barFrame translatedBy: delta. - textFrame _ textFrame translatedBy: delta. - outerFrame _ outerFrame translatedBy: delta. - prevContents _ Form fromDisplay: outerFrame. - range _ self maxVal = self minVal ifTrue: [1] ifFalse: [self maxVal - self minVal]. "Avoid div by 0" - innerBarFrame _ barFrame insetBy: 2. - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - oldFilledWidth _ 0. - oldFilledWidth2 _ 0. - result _ self workBlock value: "Supply the bar-update block for evaluation in the work block" - [ :barVal | - barVal - ifNotNil: [ self currentVal: barVal ] - ifNil: [ - self currentVal: self currentVal + 1. - self currentVal >= self maxVal - ifTrue: [ self currentVal: self minVal ]]. - filledWidth _ ((barFrame width-4) asFloat * ((self currentVal - self minVal) asFloat / range min: 1.0)) asInteger. - filledWidth > oldFilledWidth ifTrue: [ - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - Display fillGray: (barFrame topLeft + `2@2` extent: filledWidth@(h-4)). - filledWidth -200 > oldFilledWidth2 - ifFalse: [ - "Usually just request an update, to be done asynchronously." - DisplayScreen screenUpdateRequired: outerFrame ] - ifTrue: [ - "Once in a while, force a real screen update (warning: really slow on MacOS if done too often)" - Display forceToScreen: outerFrame. oldFilledWidth2 _ filledWidth ]. - oldFilledWidth _ filledWidth ]]. - prevContents displayAt: outerFrame topLeft. - self resume: result! ! -!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'jmv 6/26/2019 14:13:40' prior: 16896146! - display: argString at: argPoint from: argMinVal to: argMaxVal during: argWorkBlock - - self title: argString at: argPoint from: argMinVal to: argMaxVal workBlock: argWorkBlock. - ^self signal! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3917-EnableProgress-JuanVuletich-2019Jun26-14h12m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3813] on 26 June 2019 at 2:22:04 pm'! - -Object subclass: #Exception - instanceVariableNames: 'messageText tag signalContext handlerContexts outerContext handlerBlockNotCurtailed ' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #Exception category: #'Exceptions Kernel'! -Object subclass: #Exception - instanceVariableNames: 'messageText tag signalContext handlerContexts outerContext handlerBlockNotCurtailed' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! -!Exception methodsFor: 'handling' stamp: 'sqr 6/26/2019 11:19:08' prior: 16840031! - outer - "Evaluate the enclosing exception action and return to here instead of signal if it resumes (see #resumeUnchecked:)." - - | prevOuterContext | - handlerBlockNotCurtailed _ true. - self isResumable ifTrue: [ - prevOuterContext _ outerContext. - outerContext _ thisContext contextTag. - ]. - self topHandlerContext nextHandlerContext handleSignal: self! ! -!Exception methodsFor: 'handling' stamp: 'sqr 6/26/2019 11:19:23' prior: 16840044! - pass - "Yield control to the enclosing exception action for the receiver." - - | nextHandler | - handlerBlockNotCurtailed _ true. - nextHandler := self topHandlerContext nextHandlerContext. - self popHandlerContext. - nextHandler handleSignal: self! ! -!Exception methodsFor: 'handling' stamp: 'sqr 6/26/2019 11:19:27' prior: 16840053! - resignalAs: replacementException - "Signal an alternative exception in place of the receiver." - - handlerBlockNotCurtailed _ true. - signalContext resumeEvaluating: [replacementException signal]! ! -!Exception methodsFor: 'handling' stamp: 'sqr 6/26/2019 11:23:41' prior: 16840067! - resume: resumptionValue - "Return resumptionValue as the value of the signal message." - - handlerBlockNotCurtailed _ true. - self isResumable ifFalse: [IllegalResumeAttempt signal]. - self resumeUnchecked: resumptionValue! ! -!Exception methodsFor: 'handling' stamp: 'sqr 6/26/2019 11:20:01' prior: 16840075! - resumeUnchecked: resumptionValue - "Return resumptionValue as the value of #signal, unless this was called after an #outer message, then return resumptionValue as the value of #outer." - - | ctxt | - handlerBlockNotCurtailed _ true. - outerContext ifNil: [ - signalContext return: resumptionValue - ] ifNotNil: [ - ctxt _ outerContext. - outerContext _ ctxt tempAt: 1. "prevOuterContext in #outer" - ctxt return: resumptionValue - ]. -! ! -!Exception methodsFor: 'handling' stamp: 'sqr 6/26/2019 11:20:09' prior: 16840090! - retry - "Abort an exception handler and re-evaluate its protected block." - - handlerBlockNotCurtailed _ true. - self topHandlerContext restart! ! -!Exception methodsFor: 'handling' stamp: 'sqr 6/26/2019 11:20:14' prior: 16840096! - retryUsing: alternativeBlock - "Abort an exception handler and evaluate a new block in place of the handler's protected block." - - handlerBlockNotCurtailed _ true. - self topHandlerContext restartWithNewReceiver: alternativeBlock -! ! -!Exception methodsFor: 'handling' stamp: 'sqr 6/26/2019 11:18:21' prior: 16840111! - return: returnValue - "Return the argument as the value of the block protected by the active exception handler." - - handlerBlockNotCurtailed _ true. - self topHandlerContext return: returnValue! ! - -Object subclass: #Exception - instanceVariableNames: 'messageText tag signalContext handlerContexts outerContext handlerBlockNotCurtailed' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #Exception category: #'Exceptions Kernel'! -Object subclass: #Exception - instanceVariableNames: 'messageText tag signalContext handlerContexts outerContext handlerBlockNotCurtailed' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3918-ExceptionHandlerBlocksWithoutNonlocalReturns-p1-AndresValloud-2019Jun26-14h21m-sqr.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3813] on 26 June 2019 at 2:23:06 pm'! -!Exception methodsFor: 'priv handling' stamp: 'sqr 6/26/2019 13:07:12'! - evaluateHandlerBlock: aBlock - - | handlerEx | - handlerBlockNotCurtailed := false. - ^[ - | answer | - answer _ [aBlock valueWithPossibleArgument: self] on: Exception do: [:ex | handlerEx _ ex. ex pass]. - handlerBlockNotCurtailed _ true. - answer - ] ifCurtailed: - [ - (handlerBlockNotCurtailed not and: [handlerEx isNil or: [handlerEx handlerBlockNotCurtailed not]]) - ifTrue: [self error: 'Exception handler blocks must not do non local returns'] - ifFalse: [handlerBlockNotCurtailed _ true] - ]! ! -!Exception methodsFor: 'priv handling' stamp: 'sqr 6/26/2019 12:29:35'! - handlerBlockNotCurtailed - - ^handlerBlockNotCurtailed! ! -!ContextPart methodsFor: 'private-exceptions' stamp: 'sqr 6/26/2019 10:30:43' prior: 16824974! - evaluateSignal: exception - "The following primitive is just a marker used to find the evaluation context. - See MethodContext>>#isHandlerOrSignalingContext. " - - - | value | - exception pushHandlerContext: self contextTag. - value := exception evaluateHandlerBlock: self exceptionHandlerBlock. - "return from self if not otherwise directed in handle block" - self return: value! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3919-ExceptionHandlerBlocksWithoutNonlocalReturns-p2-AndresValloud-2019Jun26-14h22m-sqr.1.cs.st----! - -'From Cuis 5.0 [latest update: #3916] on 12 October 2019 at 10:29:16 pm'! -!ProgressInitiationException methodsFor: 'exceptionDescription' stamp: 'jmv 9/5/2019 17:41:17' prior: 50477482! -defaultAction - - | delta textFrame barFrame outerFrame result range width filledWidth f h textWidth textForm innerBarFrame oldFilledWidth oldFilledWidth2 prevContents | - f _ AbstractFont default. - h _ f lineSpacing * 3//2. - textWidth _ (f widthOfString: progressTitle) + h. - width _ 150 max: textWidth. - - textForm _ Form extent: width@h depth: 32. - textForm fillBlack. - textForm fillWhite: (textForm boundingBox insetBy: 2). - progressTitle displayOn: textForm at: (width-textWidth+h//2@4). - barFrame _ Rectangle center: aPoint extent: width@h. - textFrame _ `0@0` extent: width@h. - textFrame _ textFrame - aligned: textFrame bottomCenter - with: barFrame topCenter + `0@2`. - outerFrame _ barFrame merge: textFrame. - delta _ outerFrame amountToTranslateWithin: Display boundingBox. - barFrame _ barFrame translatedBy: delta. - textFrame _ textFrame translatedBy: delta. - outerFrame _ outerFrame translatedBy: delta. - prevContents _ Form fromDisplay: outerFrame. - range _ maxVal = minVal ifTrue: [1] ifFalse: [maxVal - minVal]. "Avoid div by 0" - innerBarFrame _ barFrame insetBy: 2. - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - oldFilledWidth _ 0. - oldFilledWidth2 _ 0. - result _ workBlock value: "Supply the bar-update block for evaluation in the work block" - [ :barVal | - barVal - ifNotNil: [ currentVal _ barVal ] - ifNil: [ - currentVal _ currentVal + 1. - currentVal >= maxVal - ifTrue: [ currentVal _ minVal ]]. - filledWidth _ ((barFrame width-4) asFloat * ((currentVal-minVal) asFloat / range min: 1.0)) asInteger. - filledWidth > oldFilledWidth ifTrue: [ - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - Display fillGray: (barFrame topLeft + `2@2` extent: filledWidth@(h-4)). - filledWidth -200 > oldFilledWidth2 - ifFalse: [ - "Usually just request an update, to be done asynchronously." - DisplayScreen screenUpdateRequired: outerFrame ] - ifTrue: [ - "Once in a while, force a real screen update (warning: really slow on MacOS if done too often)" - Display forceToScreen: outerFrame. oldFilledWidth2 _ filledWidth ]. - oldFilledWidth _ filledWidth ]]. - prevContents displayAt: outerFrame topLeft. - self resume: result! ! -!ProgressInitiationException methodsFor: 'exceptionDescription' stamp: 'jmv 1/30/2009 15:24' prior: 50477560! - display: argString at: argPoint from: argMinVal to: argMaxVal during: argWorkBlock - - progressTitle _ argString. - aPoint _ argPoint. - minVal _ argMinVal. - maxVal _ argMaxVal. - currentVal _ minVal. - workBlock _ argWorkBlock. - ^self signal! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3920-DisableHindrance-JuanVuletich-2019Oct12-22h27m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3815] on 26 June 2019 at 2:34:09 pm'! - -ProgressInitiationException removeSelector: #aPoint! - -ProgressInitiationException removeSelector: #aPoint! - -ProgressInitiationException removeSelector: #currentVal! - -ProgressInitiationException removeSelector: #currentVal! - -ProgressInitiationException removeSelector: #currentVal:! - -ProgressInitiationException removeSelector: #currentVal:! - -ProgressInitiationException removeSelector: #maxVal! - -ProgressInitiationException removeSelector: #maxVal! - -ProgressInitiationException removeSelector: #minVal! - -ProgressInitiationException removeSelector: #minVal! - -ProgressInitiationException removeSelector: #progressTitle! - -ProgressInitiationException removeSelector: #progressTitle! - -ProgressInitiationException removeSelector: #title:at:from:to:workBlock:! - -ProgressInitiationException removeSelector: #title:at:from:to:workBlock:! - -ProgressInitiationException removeSelector: #workBlock! - -ProgressInitiationException removeSelector: #workBlock! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3921-CeaseAndDesist-AndresValloud-2019Jun26-14h31m-sqr.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3817] on 26 June 2019 at 2:47:57 pm'! -!BlockClosure methodsFor: 'testing' stamp: 'sqr 6/26/2019 12:09:30' prior: 50466519! - isCleanClosure - "A clean closure is one that doesn't really need the home context because: - - It doesn't send messages to self or super - - It doesn't access any instance variable - - It doesn't access any outer temp - - It doesn't do ^ return (return from method to caller) - Therefore it doesn't close over a lexical scope, and in this sense they are trivial. - They can also be called 'context free', 'clean' or 'simple block'. - " - - | recreated source | - source _ self decompile decompileString. - - "This catches any acess to outer context!!" - recreated _ [ Compiler evaluate: source. ] on: UndeclaredVariableWarning do: [ :ex | ex return]. - recreated isNil ifTrue: [^false]. - - "Fail if returns from outer context, or uses self" - Smalltalk - eliotsClosureMeasurementsOn: recreated outerContext method - over: [ :closuresCount :hasIndirectTemps :anyClosureHasCopied :anyClosureDoesMethodReturn :anyClosureUsesSelf | - anyClosureDoesMethodReturn ifTrue: [ ^ false ]. - anyClosureUsesSelf ifTrue: [ ^ false ]]. - - "Ok." - ^true! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'sqr 6/26/2019 12:46:01' prior: 50420793! - withSelectorUnderCursorDo: aBlock ifErrorsParsing: aParsingErrorBlock ifNoSelector: aNoSelectorBlock - - | methodNode nodeAtRange nodeUnderCursor | - methodNode := self codeProvider - methodNodeOf: model actualContents - ifErrorsParsing: [ :anError | aParsingErrorBlock valueWithPossibleArgument: anError. anError return ]. - methodNode isNil ifTrue: [^nil]. - - self startIndex < methodNode selectorLastPosition ifTrue: [ ^aBlock value: methodNode selector ]. - nodeAtRange := methodNode parseNodeIncluding: self startIndex ifAbsent: [ ^ aNoSelectorBlock value ]. - nodeUnderCursor := nodeAtRange key. - nodeUnderCursor isMessageNode ifTrue: [ ^aBlock value: nodeAtRange key selector key ]. - (nodeUnderCursor isLiteralNode and: [ nodeUnderCursor literalValue isSymbol ]) ifTrue: [ ^aBlock value: nodeUnderCursor literalValue ]. - - ^ aNoSelectorBlock value ! ! -!TestCase methodsFor: 'assertions' stamp: 'sqr 6/26/2019 11:36:48' prior: 50343626! - should: aBlock raise: anExceptonHandlingCondition - - self should: aBlock raise: anExceptonHandlingCondition withExceptionDo: [ :anException | ] - ! ! -!TestCase methodsFor: 'assertions' stamp: 'sqr 6/26/2019 11:36:34' prior: 50343634! - should: aBlock raise: anExceptonHandlingCondition description: aFailDescription - - self should: aBlock raise: anExceptonHandlingCondition withExceptionDo: [:anException | ] description: aFailDescription! ! -!TestCase methodsFor: 'assertions' stamp: 'sqr 6/26/2019 11:36:39' prior: 50343643! - should: aBlock raise: anExceptonHandlingCondition withExceptionDo: assertionsBlock - - self should: aBlock raise: anExceptonHandlingCondition withExceptionDo: assertionsBlock description: self defaultFailDescription! ! -!TestCase methodsFor: 'assertions' stamp: 'sqr 6/26/2019 11:56:51' prior: 50390661! - should: aBlock raise: anExceptionHandlingCondition withExceptionDo: assertionsBlock description: aFailDescription - - | passed | - passed := [aBlock value. false] - on: anExceptionHandlingCondition - do: [:ex | assertionsBlock value: ex. ex return: true]. - passed ifFalse: [self failWith: aFailDescription]! ! -!TestCase methodsFor: 'assertions' stamp: 'sqr 6/26/2019 11:37:05' prior: 50343664! - shouldnt: aBlock raise: anExceptonHandlingCondition - - self shouldnt: aBlock raise: anExceptonHandlingCondition description: anExceptonHandlingCondition printString, ' was not expected to be raised'! ! -!TestCase methodsFor: 'assertions' stamp: 'sqr 6/26/2019 11:37:10' prior: 50343673! - shouldnt: aBlock raise: anExceptonHandlingCondition description: aFailDescription - - aBlock - on: anExceptonHandlingCondition - do: [ :anException | self failWith: aFailDescription ] -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3922-ExceptionHandlingRefinements-AndresValloud-2019Jun26-14h43m-sqr.1.cs.st----! - -'From Cuis 5.0 [latest update: #3922] on 14 October 2019 at 7:46:20 am'! -!Exception methodsFor: 'priv handling' stamp: 'jmv 10/14/2019 07:43:10' prior: 50477704! - evaluateHandlerBlock: aBlock - - | handlerEx | - handlerBlockNotCurtailed := false. - ^[ - | answer | - answer _ [aBlock valueWithPossibleArgument: self] on: Exception do: [:ex | handlerEx _ ex. ex pass]. - handlerBlockNotCurtailed _ true. - answer - ] ifCurtailed: - [ - (handlerBlockNotCurtailed not and: [handlerEx isNil or: [handlerEx handlerBlockNotCurtailed not]]) - ifTrue: [ - "self error: 'Exception handler blocks must not do non local returns'." - "Please see -https://gator3294.hostgator.com:2096/cpsess8738249540/3rdparty/squirrelmail/src/read_body.php?account=0&mailbox=INBOX&passed_id=116522&startMessage=1 -https://gator3294.hostgator.com:2096/cpsess8738249540/3rdparty/squirrelmail/src/read_body.php?account=0&mailbox=INBOX&passed_id=116533&startMessage=1 - Also see the rest of the tread in detail. - This is work in progress. - Currently (October 14, 2019) system behavior is unaffected, except for the following message to the Transcript. But the necessary code to detect the questionable method returns in exception handlers is kept, to aid in further development. - " - 'It is advisable to avoid method returns (non local returns) in exception handler blocks' print. - ] - ifFalse: [handlerBlockNotCurtailed _ true] - ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3923-TemporarilyDisableRecentExceptionHandlersReturnLimitation-JuanVuletich-2019Oct14-07h35m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3923] on 18 October 2019 at 10:50:50 am'! -!Preferences class methodsFor: 'exception handling' stamp: 'jmv 10/18/2019 10:49:40'! - allowNonLocalReturnsInExceptionHandlers - ^ self - valueOfFlag: #allowNonLocalReturnsInExceptionHandlers - ifAbsent: [ true ].! ! -!Preferences class methodsFor: 'exception handling' stamp: 'jmv 10/18/2019 10:49:45'! - warnAboutNonLocalReturnsInExceptionHandlers - ^ self - valueOfFlag: #warnAboutNonLocalReturnsInExceptionHandlers - ifAbsent: [ true ].! ! -!Exception methodsFor: 'priv handling' stamp: 'jmv 10/18/2019 10:50:17' prior: 50478017! - evaluateHandlerBlock: aBlock - - | handlerEx | - handlerBlockNotCurtailed := false. - ^[ - | answer | - answer _ [aBlock valueWithPossibleArgument: self] on: Exception do: [:ex | handlerEx _ ex. ex pass]. - signalContext := nil. "To enable recycling of exceptions, but only after handler block has finished execution." - handlerBlockNotCurtailed _ true. - answer - ] ifCurtailed: - [ - signalContext := nil. "To enable recycling of exceptions, but only after handler block has finished execution." - (handlerBlockNotCurtailed not and: [handlerEx isNil or: [handlerEx handlerBlockNotCurtailed not]]) - ifTrue: [ - "Please see - https://lists.cuis.st/mailman/archives/cuis-dev/2019-October/000800.html - https://lists.cuis.st/mailman/archives/cuis-dev/2019-October/000809.html - Also see the rest of the tread in detail. - This is work in progress." - Preferences allowNonLocalReturnsInExceptionHandlers - ifFalse: [ self error: 'Exception handler blocks must not do non local returns' ] - ifTrue: [ - Preferences warnAboutNonLocalReturnsInExceptionHandlers - ifTrue: [ 'It is advisable to avoid method returns (non local returns) in exception handler blocks' print ]. - handlerBlockNotCurtailed _ true ]. - ] - ifFalse: [handlerBlockNotCurtailed _ true] - ]! ! -!Exception methodsFor: 'signaling' stamp: 'jmv 10/18/2019 09:50:15' prior: 16840181! - signalIn: aContext - "Ask ContextHandlers in the sender chain to handle this signal. The default is to execute and return my defaultAction." - - signalContext ifNotNil: [self error: 'This exception has already been signaled and its handler block is being executed.']. - signalContext _ aContext contextTag. - ^ aContext nextHandlerContext handleSignal: self! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3924-noReSignalInExceptionHandlers-PreferencesForNonLocalReturns-JuanVuletich-2019Oct18-10h48m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3913] on 18 October 2019 at 6:43:17 pm'! -!RenameInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 10/18/2019 18:39:55'! - logClassDefinition - - Smalltalk - logChange: classToRefactor definition - preamble: classToRefactor definitionPreamble.! ! -!RenameInstanceVariable methodsFor: 'applying' stamp: 'HAW 10/18/2019 18:40:03' prior: 50476592! - apply - - self - lookForMethodsReferencingOldVariable; - changeInstanceVariableName; - logClassDefinition; - renameReferencesToOldVariable. - - ^renamedReferences - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3925-LogRenameInstanceVarClassDefinition-HernanWilkinson-2019Oct18-18h39m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3924] on 23 October 2019 at 8:56:55 am'! -!Object methodsFor: 'error handling' stamp: 'HAW 10/23/2019 08:11:45'! - shouldNotHappen - "Used to announce that something that should not happen by design, happened. - For example: (Array with: 1) at: 1 ifAbsent: [self shouldNotHappen]. - See #shouldNotHappenBecause: also" - - self error: self shouldNotHappenErrorMessage! ! -!Object methodsFor: 'error handling' stamp: 'HAW 10/23/2019 08:12:51'! - shouldNotHappenBecause: aReason - "Used to announce that something that should not happen by design, happened. - For example: (Array with: 1) at: 1 ifAbsent: [self shouldNotHappenBecause: 'The array has one element']. - See #shouldNotHappen also" - - self error: self shouldNotHappenBecauseErrorMessage, aReason! ! -!Object methodsFor: 'error handling' stamp: 'HAW 10/23/2019 08:13:13'! - shouldNotHappenBecauseErrorMessage - - ^self shouldNotHappenErrorMessage, ' because: '! ! -!Object methodsFor: 'error handling' stamp: 'HAW 10/23/2019 08:11:58'! - shouldNotHappenErrorMessage - - ^'Should not happen'! ! -!BlockNode methodsFor: 'code generation (closures)' stamp: 'HAW 10/23/2019 08:15:24' prior: 16789071! - addRemoteTemp: aTempVariableNode rootNode: rootNode "" - "Add aTempVariableNode to my actualScope's sequence of - remote temps. If I am an optimized block then the actual - scope is my actualScopeIfOptimized, otherwise it is myself." - remoteTempNode == nil ifTrue: - [remoteTempNode := RemoteTempVectorNode new - name: self remoteTempNodeName - index: arguments size + temporaries size - type: LdTempType - scope: 0. - actualScopeIfOptimized - ifNil: - [self addTempNode: remoteTempNode. - remoteTempNode definingScope: self] - ifNotNil: [actualScopeIfOptimized addHoistedTemps: { remoteTempNode }]]. - remoteTempNode addRemoteTemp: aTempVariableNode encoder: rootNode encoder. - "use remove:ifAbsent: because the deferred analysis for optimized - loops can result in the temp has already been hoised into the root." - self removeTempNode: aTempVariableNode ifAbsent: [ - self actualScope removeTempNode: aTempVariableNode ifAbsent: [self shouldNotHappen ]]. - ^remoteTempNode! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 10/23/2019 08:14:45' prior: 50460702! - selectorLastPosition - - "If #DoIt selector, returns 0 - Hernan" - - ^self selector isUnary - ifTrue: [ selectorKeywordsRanges ifNil: [ 0 ] ifNotNil: [ selectorKeywordsRanges last last ]] - ifFalse: [ - (encoder - rangeForNode: arguments last - ifAbsent: [ self shouldNotHappenBecause: 'arguments are part of the encoder' ]) first last ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3926-shouldNotHappen-HernanWilkinson-2019Oct23-08h09m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3926] on 23 October 2019 at 11:04:22 am'! -!Preferences class methodsFor: 'user changes' stamp: 'HAW 10/23/2019 11:03:16'! - defaultUserChangesFileName - "Answer the default full path to the changes file corresponding to the image file name." - - ^(FileIOAccessor default baseNameFor: Smalltalk imageName), '.user.changes'! ! -!Preferences class methodsFor: 'user changes' stamp: 'MGD 2/19/2019 10:24:39'! - userChangesFileName - ^ self - valueOfFlag: #userChangesFileName - ifAbsent: [ self defaultUserChangesFileName ].! ! -!SystemDictionary methodsFor: 'image, changes name' stamp: 'MGD 2/19/2019 10:17:37' prior: 50405588! - defaultUserChangesName - "Answer the default full path to the changes file corresponding to the image file name." - " - Smalltalk defaultUserChangesName - " - ^ Preferences userChangesFileName.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3927-UserChangesFileNamePreference-HernanWilkinson-2019Oct23-10h51m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3926] on 23 October 2019 at 11:07:03 am'! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'HAW 10/23/2019 11:06:10' prior: 16923105! - classRemoved: aClass fromCategory: aCategoryName - - aClass acceptsLoggingOfCompilation - ifTrue: [ - self - logChange: aClass definition - preamble: 'classRemoval: ', aClass name printString, ' stamp: ', Utilities changeStamp printString ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3928-ClassRemovedChangeLog-HernanWilkinson-2019Oct23-11h04m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3926] on 23 October 2019 at 11:21:36 am'! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'HAW 10/23/2019 11:20:23' prior: 16923312! - methodRemoved: aMethod selector: aSymbol inProtocol: protocol class: aClass - - aClass acceptsLoggingOfCompilation - ifTrue: [ self - logChange: aMethod sourceCode - preamble: 'methodRemoval: ', aClass printString, '>>#', aSymbol, ' stamp: ', Utilities changeStamp printString ]. ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3929-MethodRemovedChangeLog-HernanWilkinson-2019Oct23-11h07m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3926] on 26 October 2019 at 2:37:20 pm'! - -ChangeListElement subclass: #ClassDeletionChangeRecord - instanceVariableNames: 'className doItOnlyIfInBaseSystem stamp classDefinition ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #ClassDeletionChangeRecord category: #'Tools-Changes'! -ChangeListElement subclass: #ClassDeletionChangeRecord - instanceVariableNames: 'className doItOnlyIfInBaseSystem stamp classDefinition' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -ChangeListElement subclass: #MethodDeletionChangeRecord - instanceVariableNames: 'methodReference doItOnlyIfInBaseSystem sourceCode stamp ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #MethodDeletionChangeRecord category: #'Tools-Changes'! -ChangeListElement subclass: #MethodDeletionChangeRecord - instanceVariableNames: 'methodReference doItOnlyIfInBaseSystem sourceCode stamp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -Object subclass: #ClassChangeRecord - instanceVariableNames: 'inForce changeTypes priorDefinition thisName priorName methodChanges stamp ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #ClassChangeRecord category: #'Tools-Changes'! -Object subclass: #ClassChangeRecord - instanceVariableNames: 'inForce changeTypes priorDefinition thisName priorName methodChanges stamp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -Object subclass: #MethodChangeRecord - instanceVariableNames: 'changeType currentMethod infoFromRemoval stamp ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #MethodChangeRecord category: #'Tools-Changes'! -Object subclass: #MethodChangeRecord - instanceVariableNames: 'changeType currentMethod infoFromRemoval stamp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 11:25:33'! - itemIsRecognized: item - - ^ self knownPreambles anySatisfy: [ :preamble | item includesSubString: preamble ] ! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/23/2019 11:25:05'! - knownPreambles - - ^ `{ - 'commentStamp:'. - 'methodsFor:'. - 'classDefinition:'. - 'classRemoval:'. - 'methodRemoval:'. - 'methodMoveToSomePackage:'. - 'classMoveToSomePackage:'. - 'provides'. - 'requires' }`! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 11:42:13'! - notSeparatorChar - - | prevChar | - - [file atEnd not and: [file peek isSeparator]] whileTrue: [prevChar _ file next]. - - ^prevChar! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/23/2019 11:41:41'! - scanAndIgnore: item in: position - - | record | - - record _ ChangeRecord new - file: file - position: position - type: #preamble. - - self - addItem: record - text: ('preamble: ' , item contractTo: 160) -! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 11:30:10'! - scanClassComment: tokens - - | className stamp record | - - className _ tokens first. - stamp _ tokens third. - record _ ChangeRecord new - file: file - position: file position - type: #classComment - class: className - category: nil - meta: false - stamp: stamp. - - self - addItem: record - text: 'class comment for ' , className, (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp]). - - file nextChunk. -! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 11:32:17'! - scanClassDefinition: tokens - - | classDefinition isMeta itemPosition className record fullClassName | - - itemPosition _ file position. - fullClassName _ tokens second. - isMeta _ fullClassName includesSubString: ' class'. - className _ isMeta ifTrue: [fullClassName substrings first] ifFalse: [fullClassName]. - classDefinition _ file nextChunk. - - record _ ChangeRecord new - file: file - position: itemPosition - type: #classDefinition - class: className asSymbol - category: tokens last - meta: isMeta - stamp: nil. - - self addItem: record text: 'classDefinition: ', classDefinition.! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/25/2019 10:54:48'! - scanClassRemoval: tokens - - | doItOnlyIfInBaseSystem removeType classDefinition className description record stamp | - - removeType _ tokens first. - className _ tokens second. - doItOnlyIfInBaseSystem _ removeType == #classMoveToSomePackage:. - classDefinition _ file nextChunk. - stamp _ tokens last. - - record _ ClassDeletionChangeRecord - className: className - definition: classDefinition - doItOnlyIfInBaseSystem: doItOnlyIfInBaseSystem - stamp: stamp. - - description _ doItOnlyIfInBaseSystem - ifTrue: ['clase move to some package: '] - ifFalse: ['class removal: ']. - - self - addItem: record - text: description, className, '; ', stamp ! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 11:48:24'! - scanDoIt - - | itemPosition command | - - itemPosition _ file position. - command _ file nextChunk. - - command notEmpty ifTrue: [ - self - addItem: (ChangeRecord new file: file position: itemPosition type: #doIt) - text: 'do it: ' , (command contractTo: 160)]! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/23/2019 11:44:09'! - scanFeatureProvision: tokens - - | feature | - - feature _ FeatureChangeRecord new - type: #provides - feature: (Feature name: tokens second version: tokens third revision: tokens fourth). - - self addItem: feature text: feature string! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 11:39:44'! - scanFeatureRequirement: tokens - - | feature requirement | - - requirement _ FeatureRequirement - name: tokens second - minVersion: tokens third - minRevision: tokens fourth - maxVersion: (tokens size > 4 ifTrue: [tokens fifth]). - - feature _ FeatureChangeRecord new - type: #requires - feature: requirement. - - self addItem: feature text: feature string.! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 11:52:16'! - scanMethodDefinition: tokens - - | stamp stampIndex className | - - className _ tokens first. - stamp _ ''. - stampIndex _ tokens indexOf: #stamp: ifAbsent: nil. - stampIndex ifNotNil: [stamp _ tokens at: (stampIndex + 1)]. - - tokens second == #methodsFor: ifTrue: [ - ^ self scanCategory: tokens third class: className meta: false stamp: stamp ]. - - tokens third == #methodsFor: ifTrue: [ - ^ self scanCategory: tokens fourth class: className meta: true stamp: stamp ]. - - self shouldNotHappen -! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/23/2019 23:35:04'! - scanMethodRemoval: tokens - - | doItOnlyIfInBaseSystem removeType isMeta sourceCode methodReference className description record selector stamp | - - removeType _ tokens first. - className _ tokens second. - doItOnlyIfInBaseSystem _ removeType == #methodMoveToSomePackage:. - - sourceCode _ file nextChunk. - isMeta _ tokens third == #class. - selector _ tokens at: tokens size - 2. - stamp _ tokens last. - - methodReference _ MethodReference new - setClassSymbol: className - classIsMeta: isMeta - methodSymbol: selector - stringVersion: className, (isMeta ifTrue: [' class '] ifFalse: [' ']), selector,'; ', stamp. - - record _ MethodDeletionChangeRecord - methodReference: methodReference - doItOnlyIfInBaseSystem: doItOnlyIfInBaseSystem - source: sourceCode - stamp: stamp. - - description _ doItOnlyIfInBaseSystem - ifTrue: ['method move to some package: '] - ifFalse: ['method removal: ']. - - self - addItem: record - text: description, methodReference stringVersion! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 11:45:05'! - scanSpecificChangeRecordTypeIfNotAtEnd: prevChar - - (prevChar notNil and: [ prevChar isLineSeparator ]) ifTrue: [self scanSpecificChangeRecordType]! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 11:51:26'! - scanUpTo: stopPosition informing: barBlock - - [file position < stopPosition] whileTrue: [ | prevChar | - barBlock value: file position. - prevChar _ self notSeparatorChar. - "A line starting with $!! means a specific ChangeRecord type" - (file peekFor: $!!) - ifTrue: [ self scanSpecificChangeRecordTypeIfNotAtEnd: prevChar] - ifFalse: [ self scanDoIt ]]! ! -!Class methodsFor: 'fileIn/Out' stamp: 'HAW 10/24/2019 09:41:50'! - definitionReplacingCategoryWith: aNewCategory - - | definition categoryDefinitionIndex currentCategoryDefinition definitionWithNewCategory | - - definition := self definition. - "category can be nil, that is why I sent asString to it - Hernan" - currentCategoryDefinition := 'category: ''', self category asString, ''''. - categoryDefinitionIndex := definition - indexOfSubCollection: currentCategoryDefinition - startingAt: 1 - ifAbsent: [ self error: 'Definition of category not found!!' ]. - - definitionWithNewCategory := definition first: categoryDefinitionIndex - 1. - definitionWithNewCategory := definitionWithNewCategory, 'category: ''', aNewCategory, ''''. - - ^definitionWithNewCategory ! ! -!MethodReference methodsFor: 'queries' stamp: 'HAW 10/23/2019 20:56:40'! - actualClassIfAbsent: anAbsentBlock - - ^Smalltalk - at: classSymbol - ifPresent: [ :actualClass | - classIsMeta - ifTrue: [ actualClass class ] - ifFalse: [ actualClass ] ] - ifAbsent: anAbsentBlock -! ! -!MethodReference methodsFor: 'queries' stamp: 'HAW 10/23/2019 21:40:47'! - sourceCodeIfAbsent: aBlock - - | actualClass | - - actualClass := self actualClassIfAbsent: [ ^aBlock value ]. - ^actualClass sourceCodeAt: methodSymbol ifAbsent: aBlock! ! -!MethodReference class methodsFor: 'instance creation' stamp: 'HAW 10/23/2019 21:05:22'! - classSymbol: aClassName classIsMeta: isMeta methodSymbol: aSelector - - ^self new setClassSymbol: aClassName classIsMeta: isMeta methodSymbol: aSelector stringVersion: ''.! ! -!MethodReference class methodsFor: 'error description' stamp: 'HAW 10/23/2019 21:38:36'! - classDoesNotExistErrorMessage - - ^'Class does not exist'! ! -!ChangeListElement methodsFor: 'perform' stamp: 'HAW 10/25/2019 10:35:21'! - performOn: aCodeFile - - ^aCodeFile perform: (self changeType copyWith: $:) asSymbol with: self ! ! -!ChangeRecord methodsFor: 'printing' stamp: 'HAW 10/26/2019 11:57:37'! - printOn: aStream - - super printOn: aStream. - aStream - nextPutAll: ' - type: '; - nextPutAll: type ! ! -!ClassDeletionChangeRecord methodsFor: 'accessing' stamp: 'HAW 10/24/2019 08:57:18'! - className: aSymbol - - className _ aSymbol! ! -!ClassDeletionChangeRecord methodsFor: 'initialization' stamp: 'HAW 10/24/2019 08:55:20'! - initializeClassName: aClassName definition: aClassDefinition doItOnlyIfInBaseSystem: aDoItOnlyIfInBaseSystem stamp: aStamp - - className := aClassName. - classDefinition := aClassDefinition. - doItOnlyIfInBaseSystem := aDoItOnlyIfInBaseSystem. - stamp := aStamp.! ! -!ClassDeletionChangeRecord methodsFor: 'services' stamp: 'HAW 10/26/2019 10:38:56'! - command - - ^doItOnlyIfInBaseSystem - ifTrue: [ 'Smalltalk removeClassNamedIfInBaseSystem: #', className ] - ifFalse: [ 'Smalltalk removeClassNamed: #', className ]. -! ! -!ClassDeletionChangeRecord class methodsFor: 'instance creation' stamp: 'HAW 10/24/2019 08:55:05'! - className: aClassName definition: aClassDefinition doItOnlyIfInBaseSystem: aDoItOnlyIfInBaseSystem stamp: aStamp - - ^self new - initializeClassName: aClassName - definition: aClassDefinition - doItOnlyIfInBaseSystem: aDoItOnlyIfInBaseSystem - stamp: aStamp ! ! -!MethodDeletionChangeRecord methodsFor: 'initialization' stamp: 'HAW 10/23/2019 23:35:56'! - initializeMethodReference: aMethodReference doItOnlyIfInBaseSystem: aDoit source: aSourceCode stamp: aStamp - - methodReference := aMethodReference. - doItOnlyIfInBaseSystem := aDoit. - sourceCode := aSourceCode. - stamp := aStamp ! ! -!MethodDeletionChangeRecord methodsFor: 'perform' stamp: 'HAW 10/25/2019 10:37:08'! - performOn: aCodeFile - - ^aCodeFile removedMethod: self command with: self ! ! -!MethodDeletionChangeRecord class methodsFor: 'instance creation' stamp: 'HAW 10/23/2019 23:36:19'! - methodReference: aMethodReference doItOnlyIfInBaseSystem: aDoit source: aSourceCode stamp: aStamp - - ^self new - initializeMethodReference: aMethodReference - doItOnlyIfInBaseSystem: aDoit - source: aSourceCode - stamp: aStamp ! ! -!ChangeSet methodsFor: 'accessing' stamp: 'HAW 10/26/2019 12:27:22'! - movedClassRecords - - ^ changeRecords values select: [ :aChangeRecord | aChangeRecord isClassMoveToOtherPackage ]! ! -!ChangeSet methodsFor: 'accessing' stamp: 'HAW 10/25/2019 10:02:15'! - removedClassRecords - - ^ changeRecords values select: [ :aChangeRecord | aChangeRecord isClassRemoval]! ! -!ChangeSet methodsFor: 'accessing' stamp: 'HAW 10/26/2019 12:27:57'! - sortedClassRecords: classRecords - - ^ classRecords sort: [:left :rigth | left thisName < rigth thisName ]! ! -!ChangeSet methodsFor: 'accessing' stamp: 'HAW 10/26/2019 12:27:57'! - sortedMovedClassesToOtherPackage - - ^ self sortedClassRecords: self movedClassRecords! ! -!ChangeSet methodsFor: 'accessing' stamp: 'HAW 10/26/2019 12:27:57'! - sortedRemovedClassRecords - - ^ self sortedClassRecords: self removedClassRecords! ! -!ChangeSet methodsFor: 'class changes' stamp: 'HAW 10/25/2019 09:51:55'! - noteRemovalOf: class fromCategory: aCategoryName - "The class is about to be removed from the system. - Adjust the receiver to reflect that fact." - - class wantsChangeSetLogging ifFalse: [^ self]. - (self changeRecorderFor: class) noteRemoved: class fromCategory: aCategoryName. - changeRecords removeKey: class class name ifAbsent: nil. - self hasUnsavedChanges: true! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 12:41:49'! - fileOutClassDefinitionsOf: classList on: stream - - classList do: [ :aClass | self fileOutClassDefinition: aClass on: stream ]! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 12:35:49'! - fileOutClassDeletionFrom: aClassChangeRecord doItOnlyIfInBaseSystem: aDoIt on: stream - - | record | - - record := ClassDeletionChangeRecord - className: aClassChangeRecord thisName - definition: aClassChangeRecord priorDefinition - doItOnlyIfInBaseSystem: aDoIt - stamp: aClassChangeRecord stamp. - - record fileOutOn: stream - -! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 12:44:32'! - fileOutClassInitializationsOf: classList on: stream - - ^ classList do: [ :aClass | - self fileOutPSFor: aClass on: stream ]! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 10/23/2019 23:37:18'! - fileOutMethodRemovalOf: selector for: class movedToOtherPackage: moved on: stream stamp: stamp - - | methodReference changeRecord | - - methodReference := MethodReference class: class selector: selector. - - changeRecord := MethodDeletionChangeRecord - methodReference: methodReference - doItOnlyIfInBaseSystem: moved - source: (methodReference sourceCodeIfAbsent: [ 'Missing' ]) - stamp: stamp. - - changeRecord fileOutOn: stream ! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 10/24/2019 08:40:10'! - fileOutMethodRemovalsOf: changeTypes movedToOtherPackage: moved for: class on: stream - "Write out removals and initialization for this class." - - | classRecord methodChanges changeType | - - classRecord _ changeRecords at: class name ifAbsent: [^ self]. - methodChanges _ classRecord methodChanges. - - methodChanges keysAndValuesDo: [:selector :aMethodChange | - changeType _ aMethodChange changeType. - (changeTypes includes: changeType) - ifTrue: [ self - fileOutMethodRemovalOf: selector - for: class - movedToOtherPackage: moved - on: stream - stamp: aMethodChange stamp ]]. -! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 12:41:55'! - fileOutMethodsAdditionsOf: classList on: stream - - classList do: [ :aClass | self fileOutMethodAdditionsFor: aClass on: stream ]! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 12:42:26'! - fileOutMethodsChangesOf: stream on: classList - - ^ classList do: [ :aClass | self fileOutMethodChangesFor: aClass on: stream ]! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 12:36:11'! - fileOutMovedClassRecord: aRemovedClassRecord on: stream - - self fileOutClassDeletionFrom: aRemovedClassRecord doItOnlyIfInBaseSystem: true on: stream -! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 12:45:35'! - fileOutMovedClassesOn: stream - - ^ self sortedMovedClassesToOtherPackage do: [ :aMovedClassRecord | - self fileOutMovedClassRecord: aMovedClassRecord on: stream ]! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 12:43:33'! - fileOutRemovedAndMovedMethodsOf: classList on: stream - - ^ classList reverseDo: [ :aClass | - self fileOutMethodRemovalsFor: aClass on: stream. - self fileOutMethodMovedToOtherPackagesFor: aClass on: stream ]! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 12:35:04'! - fileOutRemovedClassRecord: aRemovedClassRecord on: stream - - self fileOutClassDeletionFrom: aRemovedClassRecord doItOnlyIfInBaseSystem: false on: stream -! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 12:45:13'! - fileOutRemovedClassesOn: stream - - ^ self sortedRemovedClassRecords do: [ :aRemovedClassRecord | - self fileOutRemovedClassRecord: aRemovedClassRecord on: stream ]! ! -!ClassChangeRecord methodsFor: 'all changes' stamp: 'HAW 10/25/2019 10:10:10'! - noteRemoved: class fromCategory: aCategoryName - - priorDefinition := class definitionReplacingCategoryWith: aCategoryName. - self noteChangeType: #remove fromClass: class -! ! -!ClassChangeRecord methodsFor: 'stamp' stamp: 'HAW 10/25/2019 10:19:05'! - stamp - - ^stamp! ! -!MethodChangeRecord methodsFor: 'stamp' stamp: 'HAW 10/23/2019 23:41:48'! - stamp - - ^stamp ! ! -!MethodChangeRecord methodsFor: 'perform' stamp: 'HAW 10/25/2019 10:36:24'! - performOn: aCodeFile - - ^aCodeFile perform: (self changeType copyWith: $:) asSymbol with: self ! ! -!CodeFile methodsFor: 'reading' stamp: 'HAW 10/26/2019 12:51:11'! - buildFrom: changes informingTo: barBlock - - changes withIndexDo: [ :changeRecord :anIndex | - barBlock value: anIndex. - changeRecord performOn: self. - ]. -! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 11:39:00' prior: 50466161! - scanCategory: category class: class meta: meta stamp: stamp - - | itemPosition method | - - [ - itemPosition _ file position. - method _ file nextChunk. - method notEmpty ] whileTrue: [ "done when double terminators" - self - addItem: (ChangeRecord new - file: file - position: itemPosition - type: #method - class: class - category: category - meta: meta - stamp: stamp) - text: 'method: ' , class , (meta ifTrue: [' class '] ifFalse: [' ']) - , (((Smalltalk at: class ifAbsent: [Object class]) parserClass selectorFrom: method) ifNil: ['']) - , (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp])]! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 11:50:35' prior: 50365563! - scanFile: aFile from: startPosition to: stopPosition - - file _ aFile. - changeList _ OrderedCollection new. - list _ OrderedCollection new. - listIndex _ 0. - file position: startPosition. - - 'Scanning ', aFile localName, '...' - displayProgressAt: Sensor mousePoint - from: startPosition to: stopPosition - during: [ :barBlock | self scanUpTo: stopPosition informing: barBlock ]. - - self clearSelections! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/23/2019 22:47:43' prior: 16795976! - scanSpecificChangeRecordType - "Scan anything that involves more than one chunk" - - | itemPosition item tokens firstToken secondToken | - - itemPosition _ file position. - item _ file nextChunk. - - (self itemIsRecognized: item) ifFalse: [ - "Maybe a preamble, but not one we recognize; bail out with the preamble trick" - ^ self scanAndIgnore: item in: itemPosition ]. - - tokens _ Scanner new scanTokens: item. - tokens size >= 2 ifTrue: [ - firstToken _ tokens first. - secondToken _ tokens second. - - firstToken == #classDefinition: - ifTrue: [ ^ self scanClassDefinition: tokens ]. - (firstToken == #classRemoval: or: [ firstToken == #classMoveToSomePackage: ]) - ifTrue: [ ^ self scanClassRemoval: tokens ]. - (firstToken == #methodRemoval: or: [ firstToken == #methodMoveToSomePackage: ]) - ifTrue: [ ^ self scanMethodRemoval: tokens ]. - (secondToken == #methodsFor: or: [ tokens third == #methodsFor: ]) - ifTrue: [ ^ self scanMethodDefinition: tokens ]. - secondToken == #commentStamp: - ifTrue: [ ^ self scanClassComment: tokens ]. - firstToken == #provides: - ifTrue: [ ^ self scanFeatureProvision: tokens ]. - firstToken == #requires: - ifTrue: [ ^ self scanFeatureRequirement: tokens ]. - ]! ! -!ChangeList class methodsFor: 'public access' stamp: 'HAW 10/24/2019 08:57:14' prior: 16796836! - browsePackageContents: aFileEntry - "Opens a changeList on a fileStream" - | changeList packageFile | - aFileEntry readStreamDo: [ :stream | - changeList _ self new scanFile: stream from: 0 to: stream size. - stream reset. - packageFile _ CodePackageFile buildFileStream: stream. - ]. - "Add deletions of methods and classes that are in the CodePackage (i.e., active in the system) - but are no longer in the CodePackageFile being viewed." - packageFile methodsToRemove do: [ :methodReference | - changeList - addItem: (MethodDeletionChangeRecord new methodReference: methodReference) - text: 'method no longer in package: ', methodReference stringVersion ]. - packageFile classesToRemove do: [ :clsName | - changeList - addItem: (ClassDeletionChangeRecord new className: clsName) - text: 'class no longer in package: ', clsName ]. - changeList clearSelections. - ChangeListWindow open: changeList label: aFileEntry name! ! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'HAW 10/24/2019 09:45:22' prior: 50478295! - classRemoved: aClass fromCategory: aCategoryName - - | classDefinition | - - aClass acceptsLoggingOfCompilation - ifTrue: [ - "I have to recreate the category because the classs has already been removed form the - SystemOrganizer - Hernan" - classDefinition := aClass definitionReplacingCategoryWith: aCategoryName. - - self - logChange: classDefinition - preamble: 'classRemoval: ', aClass name printString, ' stamp: ', Utilities changeStamp printString ]. - - ! ! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'HAW 10/23/2019 19:09:00' prior: 50478314! - methodRemoved: aMethod selector: aSymbol inProtocol: protocol class: aClass - - aClass acceptsLoggingOfCompilation - ifTrue: [ self - logChange: aMethod sourceCode - preamble: 'methodRemoval: ', aClass name, ' ', aSymbol storeString, ' stamp: ', Utilities changeStamp printString ]. -! ! -!MethodReference methodsFor: 'queries' stamp: 'HAW 10/23/2019 20:58:03' prior: 16873043! - actualClass - - ^self actualClassIfAbsent: [ nil ]! ! -!MethodReference methodsFor: 'queries' stamp: 'HAW 10/23/2019 21:38:10' prior: 16873093! - sourceCode - - ^ (self actualClassIfAbsent: [ self error: self class classDoesNotExistErrorMessage ]) - sourceCodeAt: methodSymbol! ! -!ClassDeletionChangeRecord methodsFor: 'fileIn/fileOut' stamp: 'HAW 10/25/2019 10:41:36' prior: 16805542! - fileIn - - doItOnlyIfInBaseSystem - ifTrue: [ Smalltalk removeClassNamedIfInBaseSystem: className] - ifFalse: [ self changeClass ifNotNil: [ :aClass | aClass removeFromSystem ] ]! ! -!ClassDeletionChangeRecord methodsFor: 'fileIn/fileOut' stamp: 'HAW 10/26/2019 10:50:42' prior: 16805550! - fileOutOn: stream - "File the receiver out on the given file stream" - - | record | - - record := String streamContents: [ :recordStream | - recordStream - nextPutAll: (doItOnlyIfInBaseSystem ifTrue: [ 'classMoveToSomePackage: #' ] ifFalse: ['classRemoval: #']); - nextPutAll: className; - nextPutAll: ' stamp: '; - print: stamp ]. - - stream - nextPut: $!!; - nextChunkPut: record; - newLine; - nextChunkPut: self command; - newLine; newLine. - ! ! -!ClassDeletionChangeRecord methodsFor: 'accessing' stamp: 'HAW 10/24/2019 08:54:41' prior: 16805567! - changeClass - ^Smalltalk at: className ifAbsent: nil! ! -!ClassDeletionChangeRecord methodsFor: 'accessing' stamp: 'HAW 10/24/2019 08:54:42' prior: 16805572! - changeClassName - ^className! ! -!ClassDeletionChangeRecord methodsFor: 'accessing' stamp: 'HAW 10/24/2019 08:56:50' prior: 16805597! - string - - ^classDefinition ifNil: [ '' ]! ! -!MethodDeletionChangeRecord methodsFor: 'accessing' stamp: 'HAW 10/23/2019 17:22:05' prior: 16871939! - string - - ^sourceCode ifNil: [ '' ]! ! -!MethodDeletionChangeRecord methodsFor: 'fileIn/fileOut' stamp: 'HAW 10/26/2019 10:48:23' prior: 16871953! - fileOutOn: stream - "File the receiver out on the given file stream" - - | record | - - record := String streamContents: [ :recordStream | - recordStream - nextPutAll: (doItOnlyIfInBaseSystem ifTrue: [ 'methodMoveToSomePackage: ' ] ifFalse: ['methodRemoval: ']); - nextPutAll: self changeClassName; - space; - nextPutAll: self methodSelector storeString; - nextPutAll: ' stamp: '; - print: stamp ]. - - stream - nextPut: $!!; - nextChunkPut: record; - newLine; - nextChunkPut: self command; - newLine - -! ! -!MethodDeletionChangeRecord methodsFor: 'services' stamp: 'HAW 10/26/2019 10:48:08' prior: 16871970! - command - - ^String streamContents: [ :stream | - stream - nextPutAll: self changeClassName; - space; - nextPutAll: (doItOnlyIfInBaseSystem ifTrue: ['removeSelectorIfInBaseSystem:'] ifFalse: ['removeSelector:']); - space; - nextPutAll: self methodSelector storeString ]! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 10/23/2019 22:26:35' prior: 16798429! - fileOutMethodMovedToOtherPackagesFor: class on: stream - "Write out removals and initialization for this class." - - self - fileOutMethodRemovalsOf: #(movedToOtherPackage) - movedToOtherPackage: true - for: class - on: stream -! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 10/23/2019 22:26:05' prior: 16798450! - fileOutMethodRemovalsFor: class on: stream - "Write out removals and initialization for this class." - - self - fileOutMethodRemovalsOf: #(remove addedThenRemoved) - movedToOtherPackage: false - for: class - on: stream - ! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 12:46:36' prior: 16798470! - fileOutOn: stream - "Write out all the changes the receiver knows about" - - | classList | - - self isEmpty ifTrue: [ self inform: 'Warning: no changes to file out' ]. - - classList _ Array streamContents: [ :strm | - Smalltalk hierarchySorted: self changedClasses do: [ :cls | strm nextPut: cls ]]. - - self fileOutClassDefinitionsOf: classList on: stream. - self fileOutMethodsAdditionsOf: classList on: stream. - self fileOutMethodsChangesOf: stream on: classList. - self fileOutRemovedAndMovedMethodsOf: classList on: stream. - self fileOutClassInitializationsOf: classList on: stream. - self fileOutRemovedClassesOn: stream. - self fileOutMovedClassesOn: stream. -! ! -!ChangeSet methodsFor: 'system change notifications' stamp: 'HAW 10/24/2019 15:00:59' prior: 16798746! - classRemoved: aClass fromCategory: aCategoryName - - self noteRemovalOf: aClass fromCategory: aCategoryName! ! -!ClassChangeRecord methodsFor: 'all changes' stamp: 'HAW 10/25/2019 09:53:27' prior: 16804996! - noteChangeType: changeSymbol fromClass: class - - stamp _ Utilities changeStamp. - - changeSymbol == #movedToOtherPackage ifTrue: [ - ^ changeTypes add: changeSymbol]. - "Any other change type meanse we're still here!!" - changeTypes remove: #movedToOtherPackage ifAbsent: nil. - - (changeSymbol == #new or: [changeSymbol == #add]) ifTrue: [ - changeTypes add: #add. - changeTypes remove: #change ifAbsent: nil. - ^ self]. - changeSymbol == #change ifTrue: [ - (changeTypes includes: #add) ifTrue: [^ self]. - ^ changeTypes add: changeSymbol]. - changeSymbol == #addedThenRemoved ifTrue: [ - ^ self]. "An entire class was added but then removed" - changeSymbol == #comment ifTrue: [ - ^ changeTypes add: changeSymbol]. - changeSymbol == #reorganize ifTrue: [ - ^ changeTypes add: changeSymbol]. - changeSymbol == #rename ifTrue: [ - ^ changeTypes add: changeSymbol]. - (changeSymbol beginsWith: 'oldName: ') ifTrue: [ - "Must only be used when assimilating other changeSets" - (changeTypes includes: #add) ifTrue: [^ self]. - priorName _ changeSymbol copyFrom: 'oldName: ' size + 1 to: changeSymbol size. - ^ changeTypes add: #rename]. - changeSymbol == #remove ifTrue: [ - (changeTypes includes: #add) - ifTrue: [changeTypes add: #addedThenRemoved] - ifFalse: [changeTypes add: #remove]. - ^ changeTypes removeAllFoundIn: #(add change comment reorganize)]. - - self error: 'Unrecognized changeType'! ! -!ClassChangeRecord methodsFor: 'method changes' stamp: 'HAW 10/24/2019 08:49:09' prior: 16805172! - findOrMakeMethodChangeAt: selector priorMethod: priorMethod - - ^ methodChanges - at: selector - ifAbsentPut: [MethodChangeRecord new priorMethod: priorMethod]! ! -!MethodChangeRecord methodsFor: 'change type' stamp: 'HAW 10/25/2019 17:21:14' prior: 16871354! - noteChangeType: newChangeType - - stamp _ Utilities changeStamp. - - "Change of an added method, is still an add" - (changeType == #add and: [ newChangeType == #change ]) - ifTrue: [ ^self ]. - - "Change of an added method, is still an add" - (changeType == #addedThenRemoved and: [ newChangeType == #change ]) - ifTrue: [ - changeType _ #add. - ^self ]. - - changeType _ newChangeType.! ! -!CodeFile methodsFor: 'reading' stamp: 'HAW 10/26/2019 12:50:49' prior: 50366505! - buildFrom: aStream - - | changes | - - changes _ (ChangeList new scanFile: aStream from: 0 to: aStream size) changeList. - - ('Processing ', self name) - displayProgressAt: Sensor mousePoint - from: 1 - to: changes size - during: [ :barBlock | self buildFrom: changes informingTo: barBlock ]. -! ! - -ChangeSet removeSelector: #classMovesToOtherPackage! - -!methodRemoval: ChangeSet #classMovesToOtherPackage stamp: 'jmv 11/15/2019 09:45:31'! -classMovesToOtherPackage - "Unlike some related methods, answer an Array (not a Set)" - ^ changeRecords keys select: [ :className | - (changeRecords at: className) isClassMoveToOtherPackage]! - -ChangeSet removeSelector: #fileOutMethodRemovalOf:for:movedToOtherPackage:on:! - -ChangeSet removeSelector: #classRemoves! - -!methodRemoval: ChangeSet #classRemoves stamp: 'jmv 11/15/2019 09:45:31'! -classRemoves - "Unlike some related methods, answer an Array (not a Set)" - ^ changeRecords keys select: [ :className | - (changeRecords at: className) isClassRemoval]! - -ChangeSet removeSelector: #fileOutRemovedClassRecord:! - -ChangeSet removeSelector: #noteRemovalOf:! - -!methodRemoval: ChangeSet #noteRemovalOf: stamp: 'jmv 11/15/2019 09:45:31'! -noteRemovalOf: class - "The class is about to be removed from the system. - Adjust the receiver to reflect that fact." - - class wantsChangeSetLogging ifFalse: [^ self]. - (self changeRecorderFor: class) - noteChangeType: #remove fromClass: class. - changeRecords removeKey: class class name ifAbsent: nil. - self hasUnsavedChanges: true! - -ChangeSet removeSelector: #fileOutInitializationOf:on:! - -ChangeSet removeSelector: #sorteClassRecords:! - -MethodDeletionChangeRecord class removeSelector: #methodReference:doItOnlyIfInBaseSystem:source:! - -MethodDeletionChangeRecord removeSelector: #initializeMethodReference:doItOnlyIfInBaseSystem:source:! - -ClassDeletionChangeRecord removeSelector: #clsName:! - -!methodRemoval: ClassDeletionChangeRecord #clsName: stamp: 'jmv 11/15/2019 09:45:31'! -clsName: aSymbol - clsName _ aSymbol! - -MethodReference class removeSelector: #classSymbol:isMeta:selector:! - -MethodReference removeSelector: #sourceCodeIfMissing:! - -ChangeListElement subclass: #ClassDeletionChangeRecord - instanceVariableNames: 'className doItOnlyIfInBaseSystem classDefinition stamp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #ClassDeletionChangeRecord category: #'Tools-Changes'! -ChangeListElement subclass: #ClassDeletionChangeRecord - instanceVariableNames: 'className doItOnlyIfInBaseSystem classDefinition stamp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -ChangeListElement subclass: #MethodDeletionChangeRecord - instanceVariableNames: 'methodReference doItOnlyIfInBaseSystem sourceCode stamp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #MethodDeletionChangeRecord category: #'Tools-Changes'! -ChangeListElement subclass: #MethodDeletionChangeRecord - instanceVariableNames: 'methodReference doItOnlyIfInBaseSystem sourceCode stamp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -Object subclass: #ClassChangeRecord - instanceVariableNames: 'inForce changeTypes priorDefinition thisName priorName methodChanges stamp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #ClassChangeRecord category: #'Tools-Changes'! -Object subclass: #ClassChangeRecord - instanceVariableNames: 'inForce changeTypes priorDefinition thisName priorName methodChanges stamp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -Object subclass: #MethodChangeRecord - instanceVariableNames: 'changeType currentMethod infoFromRemoval stamp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #MethodChangeRecord category: #'Tools-Changes'! -Object subclass: #MethodChangeRecord - instanceVariableNames: 'changeType currentMethod infoFromRemoval stamp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3930-ChangesScanningRefactoring-HernanWilkinson-2019Oct23-11h21m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3926] on 26 October 2019 at 3:08:06 pm'! -!ChangeList class methodsFor: 'scanning' stamp: 'HAW 10/26/2019 14:54:50'! - knownFileInPreambles - - ^ `{ - 'classDefinition:'. - 'classRemoval:'. - 'methodRemoval:'. - 'methodMoveToSomePackage:'. - 'classMoveToSomePackage:'. - 'provides:'. - 'requires:' }`! ! -!ChangeList class methodsFor: 'scanning' stamp: 'HAW 10/26/2019 14:55:26'! - knownPreambles - - ^ `{ 'commentStamp:'. 'methodsFor:'. }, ChangeList knownFileInPreambles`! ! -!PositionableStream methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 15:01:19'! - compileNextChunk - - (self peekFor: $!!) - ifTrue: [ self compileNextChunkWhenStartsWithExclamationMark ] - ifFalse: [ self compileNextChunkWhenDoesNotStartWithExclamationMark ]! ! -!PositionableStream methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 14:43:50'! - compileNextChunkHandlingExceptions - - [ self compileNextChunk ] - on: InMidstOfFileinNotification, UndeclaredVariableWarning - do: [ :ex | ex resume: true ]! ! -!PositionableStream methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 15:03:58'! - compileNextChunkWhenDoesNotStartWithExclamationMark - - | chunk | - - chunk := self nextChunk. - self checkForPreamble: chunk. - self evaluate: [ Compiler evaluate: chunk logged: true ] printingErrorWith: chunk - ! ! -!PositionableStream methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 15:04:31'! - compileNextChunkWhenStartsWithExclamationMark - - | chunk | - - chunk := self nextChunk. - - "These are the ones that should do nothing, - because next line is a doit that does the stuff - (or because it is handled elsewhere)" - - ((chunk beginsWith: 'description: ') - or: [ ChangeList knownFileInPreambles anySatisfy: [ :aPreamble | chunk beginsWith: aPreamble ]]) - ifFalse: [ self evaluate: [ (Compiler evaluate: chunk logged: false) scanFrom: self ] printingErrorWith: chunk ]! ! -!PositionableStream methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 15:03:41'! - evaluate: aBlock printingErrorWith: chunk - - aBlock - on: Error - do: [ :ex | - ex print. - ('while evaluating: ', chunk) print. - ex pass ] - ! ! -!PositionableStream methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 14:44:04'! - fileInInformingTo: barBlock - - [ self atEnd ] whileFalse: [ - barBlock value: self position. - self skipSeparators. - self compileNextChunkHandlingExceptions ]! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 14:56:01' prior: 50478393! - itemIsRecognized: item - - ^ self class knownPreambles anySatisfy: [ :preamble | item includesSubString: preamble ] ! ! -!PositionableStream methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 15:07:52' prior: 50430137! - 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. Put up a progress report with the given announcement as the title." - - Utilities logsUserChanges: false. - - announcement - displayProgressAt: Sensor mousePoint - from: 0 - to: self size - during: [ :barBlock | self fileInInformingTo: barBlock ]. - - "Note: The main purpose of this banner is to flush the changes file." - Utilities logsUserChanges: true. - Smalltalk logChange: '----End fileIn of ' , self name , '----'. - ! ! - -PositionableStream removeSelector: #m1! - -ChangeList removeSelector: #knownPreambles! - -!methodRemoval: ChangeList #knownPreambles stamp: 'jmv 11/15/2019 09:45:31'! -knownPreambles - - ^ `{ - 'commentStamp:'. - 'methodsFor:'. - 'classDefinition:'. - 'classRemoval:'. - 'methodRemoval:'. - 'methodMoveToSomePackage:'. - 'classMoveToSomePackage:'. - 'provides'. - 'requires' }`! - -ChangeList removeSelector: #knownFileInPreambles! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3931-FileInRefactoring-HernanWilkinson-2019Oct26-14h37m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3931] on 26 October 2019 at 6:02:11 pm'! - -ChangeListElement subclass: #ChangeRecord - instanceVariableNames: 'file position type class category meta stamp prior ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #ChangeRecord category: #'Tools-Changes'! -ChangeListElement subclass: #ChangeRecord - instanceVariableNames: 'file position type class category meta stamp prior' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 17:59:01'! - priorMethodReferenceFrom: tokens - - | priorMethodReference tagIndex | - - tagIndex _ tokens indexOf: #prior: ifAbsent: [ ^ nil ]. - priorMethodReference _ tokens at: tagIndex + 1. - - ^ priorMethodReference -! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 18:00:17'! - scanCategory: category class: class meta: meta stamp: stamp prior: aPriorMethod - - | itemPosition method | - - [ - itemPosition _ file position. - method _ file nextChunk. - method notEmpty ] whileTrue: [ "done when double terminators" - self - addItem: (ChangeRecord new - file: file - position: itemPosition - type: #method - class: class - category: category - meta: meta - stamp: stamp - prior: aPriorMethod) - text: 'method: ' , class , (meta ifTrue: [' class '] ifFalse: [' ']) - , (((Smalltalk at: class ifAbsent: [Object class]) parserClass selectorFrom: method) ifNil: ['']) - , (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp])]! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 17:58:04'! - stampFrom: tokens - - | stamp stampIndex | - - stampIndex _ tokens indexOf: #stamp: ifAbsent: [ ^'' ]. - stamp _ tokens at: stampIndex + 1. - - ^ stamp -! ! -!ChangeRecord methodsFor: 'access' stamp: 'HAW 10/26/2019 18:01:07'! - prior - - ^prior! ! -!ChangeRecord methodsFor: 'initialization' stamp: 'HAW 10/26/2019 18:00:29'! - file: aFile position: aPosition type: aType class: aClassName category: aClassCategory meta: isMeta stamp: aStamp prior: aPrior - - self file: aFile position: aPosition type: aType. - class _ aClassName. - category _ aClassCategory. - meta _ isMeta. - stamp _ aStamp. - prior _ aPrior.! ! -!ClassDeletionChangeRecord methodsFor: 'accessing' stamp: 'HAW 10/26/2019 17:53:44'! - stamp - - ^stamp! ! -!MethodDeletionChangeRecord methodsFor: 'accessing' stamp: 'HAW 10/26/2019 17:53:57'! - stamp - - ^stamp! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 17:58:04' prior: 50478440! - scanClassDefinition: tokens - - | classDefinition isMeta itemPosition className record fullClassName stamp | - - itemPosition _ file position. - fullClassName _ tokens second. - isMeta _ fullClassName includesSubString: ' class'. - className _ isMeta ifTrue: [fullClassName substrings first] ifFalse: [fullClassName]. - stamp _ self stampFrom: tokens. - classDefinition _ file nextChunk. - - record _ ChangeRecord new - file: file - position: itemPosition - type: #classDefinition - class: className asSymbol - category: tokens last - meta: isMeta - stamp: stamp. - - self addItem: record text: 'classDefinition: ', classDefinition.! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 17:58:04' prior: 50478461! - scanClassRemoval: tokens - - | doItOnlyIfInBaseSystem removeType classDefinition className description record stamp | - - removeType _ tokens first. - className _ tokens second. - doItOnlyIfInBaseSystem _ removeType == #classMoveToSomePackage:. - stamp _ self stampFrom: tokens. - classDefinition _ file nextChunk. - - record _ ClassDeletionChangeRecord - className: className - definition: classDefinition - doItOnlyIfInBaseSystem: doItOnlyIfInBaseSystem - stamp: stamp. - - description _ doItOnlyIfInBaseSystem - ifTrue: ['clase move to some package: '] - ifFalse: ['class removal: ']. - - self - addItem: record - text: description, className, '; ', stamp ! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 17:59:01' prior: 50478519! - scanMethodDefinition: tokens - - | stamp className priorMethod | - - className _ tokens first. - stamp _ self stampFrom: tokens. - priorMethod _ self priorMethodReferenceFrom: tokens. - - tokens second == #methodsFor: ifTrue: [ - ^ self scanCategory: tokens third class: className meta: false stamp: stamp prior: priorMethod ]. - - tokens third == #methodsFor: ifTrue: [ - ^ self scanCategory: tokens fourth class: className meta: true stamp: stamp prior: priorMethod ]. - - self error: 'Unsupported method definition' -! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 17:58:04' prior: 50478537! - scanMethodRemoval: tokens - - | doItOnlyIfInBaseSystem removeType isMeta sourceCode methodReference className description record selector stamp | - - removeType _ tokens first. - className _ tokens second. - doItOnlyIfInBaseSystem _ removeType == #methodMoveToSomePackage:. - - sourceCode _ file nextChunk. - isMeta _ tokens third == #class. - selector _ tokens at: tokens size - 2. - stamp _ self stampFrom: tokens. - - methodReference _ MethodReference new - setClassSymbol: className - classIsMeta: isMeta - methodSymbol: selector - stringVersion: className, (isMeta ifTrue: [' class '] ifFalse: [' ']), selector,'; ', stamp. - - record _ MethodDeletionChangeRecord - methodReference: methodReference - doItOnlyIfInBaseSystem: doItOnlyIfInBaseSystem - source: sourceCode - stamp: stamp. - - description _ doItOnlyIfInBaseSystem - ifTrue: ['method move to some package: '] - ifFalse: ['method removal: ']. - - self - addItem: record - text: description, methodReference stringVersion! ! -!ChangeRecord methodsFor: 'initialization' stamp: 'HAW 10/26/2019 17:22:59' prior: 16797422! - file: aFile position: aPosition type: aType - - file _ aFile. - position _ aPosition. - type _ aType. -" -file closed ifFalse: [ - '' print. - file print. - self print. - thisContext printStack: 10 ] -"! ! -!ChangeRecord methodsFor: 'initialization' stamp: 'HAW 10/26/2019 18:00:17' prior: 16797430! -file: aFile position: aPosition type: aType class: aClassName category: aClassCategory meta: isMeta stamp: aStamp - - self - file: aFile - position: aPosition - type: aType - class: aClassName - category: aClassCategory - meta: isMeta - stamp: aStamp - prior: nil -! ! -!ClassDeletionChangeRecord methodsFor: 'accessing' stamp: 'HAW 10/26/2019 18:01:23' prior: 16805576! - changeType - - ^ #classRemoval! ! - -ChangeRecord removeSelector: #priorMethod! - -ChangeRecord removeSelector: #file:position:type:class:category:meta:stamp:priorMethod:! - -ChangeList removeSelector: #scanCategory:class:meta:stamp:! - -!methodRemoval: ChangeList #scanCategory:class:meta:stamp: stamp: 'jmv 11/15/2019 09:45:31'! -scanCategory: category class: class meta: meta stamp: stamp - - | itemPosition method | - - [ - itemPosition _ file position. - method _ file nextChunk. - method notEmpty ] whileTrue: [ "done when double terminators" - self - addItem: (ChangeRecord new - file: file - position: itemPosition - type: #method - class: class - category: category - meta: meta - stamp: stamp) - text: 'method: ' , class , (meta ifTrue: [' class '] ifFalse: [' ']) - , (((Smalltalk at: class ifAbsent: [Object class]) parserClass selectorFrom: method) ifNil: ['']) - , (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp])]! - -ChangeList removeSelector: #scanChangeStamp:! - -ChangeList removeSelector: #scanPriorMethodReference:! - -ChangeListElement subclass: #ChangeRecord - instanceVariableNames: 'file position type class category meta stamp prior' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #ChangeRecord category: #'Tools-Changes'! -ChangeListElement subclass: #ChangeRecord - instanceVariableNames: 'file position type class category meta stamp prior' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3932-ReferenceToPriorAndRefactorings-HernanWilkinson-2019Oct26-15h09m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3931] on 26 October 2019 at 7:10:18 pm'! -!CodeFile methodsFor: 'change record types' stamp: 'HAW 10/26/2019 19:09:58'! - classRemoval: aClassDeletionChangeRecord - - ^self classDefinition: aClassDeletionChangeRecord ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3933-ClassRemovalFix-HernanWilkinson-2019Oct26-18h02m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3931] on 26 October 2019 at 11:35:30 pm'! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 20:10:35'! - classDefinitionRecordFrom: tokens - - | classDefinition isMeta itemPosition className record fullClassName stamp | - - itemPosition _ file position. - fullClassName _ tokens second. - isMeta _ fullClassName includesSubString: ' class'. - className _ isMeta ifTrue: [fullClassName substrings first] ifFalse: [fullClassName]. - stamp _ self stampFrom: tokens. - classDefinition _ file nextChunk. - - record _ ChangeRecord new - file: file - position: itemPosition - type: #classDefinition - class: className asSymbol - category: tokens last - meta: isMeta - stamp: stamp. - - ^record -! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 20:12:15' prior: 50479606! - scanClassDefinition: tokens - - | record | - - record _ self classDefinitionRecordFrom: tokens. - - self addItem: record text: 'classDefinition: ', record changeClassName. - ! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 23:23:14' prior: 50479672! - scanMethodRemoval: tokens - - | doItOnlyIfInBaseSystem removeType isMeta sourceCode methodReference className description record selector stamp | - - removeType _ tokens first. - className _ tokens second. - doItOnlyIfInBaseSystem _ removeType == #methodMoveToSomePackage:. - - sourceCode _ file nextChunk. - isMeta _ tokens third == #class. - selector _ isMeta ifTrue: [ tokens fourth ] ifFalse: [ tokens third ]. - stamp _ self stampFrom: tokens. - - methodReference _ MethodReference new - setClassSymbol: className - classIsMeta: isMeta - methodSymbol: selector - stringVersion: className, (isMeta ifTrue: [' class '] ifFalse: [' ']), selector,'; ', stamp. - - record _ MethodDeletionChangeRecord - methodReference: methodReference - doItOnlyIfInBaseSystem: doItOnlyIfInBaseSystem - source: sourceCode - stamp: stamp. - - description _ doItOnlyIfInBaseSystem - ifTrue: ['method move to some package: '] - ifFalse: ['method removal: ']. - - self - addItem: record - text: description, methodReference stringVersion! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3934-ScandDefinitionRefactoringMethodRemovalFix-HernanWilkinson-2019Oct26-19h10m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3931] on 26 October 2019 at 11:50:18 pm'! -!Utilities class methodsFor: 'identification' stamp: 'HAW 10/26/2019 23:43:23'! - changeStampField - - ^' stamp: ', self changeStamp printString.! ! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'HAW 10/26/2019 23:49:20' prior: 16806649! - definitionPreamble - - ^'classDefinition: ', self name printString, ' category: ', self category printString, Utilities changeStampField! ! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'HAW 10/26/2019 23:45:14' prior: 50479023! - classRemoved: aClass fromCategory: aCategoryName - - | classDefinition | - - aClass acceptsLoggingOfCompilation - ifTrue: [ - "I have to recreate the category because the classs has already been removed form the - SystemOrganizer - Hernan" - classDefinition := aClass definitionReplacingCategoryWith: aCategoryName. - - self - logChange: classDefinition - preamble: 'classRemoval: ', aClass name printString, Utilities changeStampField ]! ! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'HAW 10/26/2019 23:45:25' prior: 50479042! - methodRemoved: aMethod selector: aSymbol inProtocol: protocol class: aClass - - aClass acceptsLoggingOfCompilation - ifTrue: [ self - logChange: aMethod sourceCode - preamble: 'methodRemoval: ', aClass name, ' ', aSymbol storeString, Utilities changeStampField ]. -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3935-ChangeStampField-HernanWilkinson-2019Oct26-23h35m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3935] on 28 October 2019 at 1:00:31 am'! - -Object subclass: #AutoCompleterSelectorsCollector - instanceVariableNames: 'categoriesWithSelectors addedSelectorsFastSet prefix entriesToShow possibleInvalidSelectors otherClasses selectorsLimit selectorSelectionCondition ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #AutoCompleterSelectorsCollector category: #'Tools-Autocompletion' stamp: 'jmv 11/15/2019 09:45:31'! -Object subclass: #AutoCompleterSelectorsCollector - instanceVariableNames: 'categoriesWithSelectors addedSelectorsFastSet prefix entriesToShow possibleInvalidSelectors otherClasses selectorsLimit selectorSelectionCondition' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:46:37'! - computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:48:30'! - computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:43:00'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:45:40'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:46:37'! - computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName with: possibleBinaryMessageSendRange - - textProvider computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName with: possibleBinaryMessageSendRange -! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:48:30'! - computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName with: possibleBinaryMessageSendRange - - textProvider computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName with: possibleBinaryMessageSendRange! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:43:01'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName with: possibleBinaryMessageSendRange - - textProvider computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName with: possibleBinaryMessageSendRange -! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:45:40'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange - - textProvider computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange -! ! -!Workspace methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:47:59'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForClassOrNil: (self classOfBindingOf: aName) with: possibleBinaryMessageSendRange! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:46:37'! - computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:48:30'! - computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:43:00'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:45:40'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:46:37'! - computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName with: possibleBinaryMessageSendRange - - self computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange -! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:48:30'! - computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName with: possibleBinaryMessageSendRange - - ^self computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange ! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:43:00'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName with: possibleBinaryMessageSendRange - - contextStackIndex = 0 - ifTrue: [ anAutocompleter computeMessageEntriesForUnknowClass ] - ifFalse: [ anAutocompleter computeMessageEntriesForClass: (self receiver instVarNamed: aName) class with: possibleBinaryMessageSendRange]! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:45:40'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange - - | context tempIndex | - - context := self selectedContext. - tempIndex := context tempNames indexOf: aName ifAbsent: [ ^ anAutocompleter computeMessageEntriesForUnknowClass ]. - - anAutocompleter computeMessageEntriesForClass: (self debuggerMap namedTempAt: tempIndex in: context) class with: possibleBinaryMessageSendRange - - ! ! -!Inspector methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:43:00'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForClass: (object instVarNamed: aName) class with: possibleBinaryMessageSendRange ! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:46:37'! - computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:48:30'! - computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:43:00'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 10/27/2019 21:45:40'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 10/27/2019 20:09:37'! - canComputeMessageEntriesFor: prevRange - - ^ prevRange notNil ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 10/27/2019 18:38:46'! - computeEntriesOfUnaryMessageReturnNamed: aSelector at: aRange with: possibleBinaryMessageSendRange - - self subclassResponsibility ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 10/28/2019 00:24:58'! - computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel with: possibleBinarySendRange - - | id rangeType | - - canShowSelectorDocumentation _ true. - id _ allSource copyFrom: range start to: range end. - rangeType _ range rangeType. - - rangeType == #globalVar - ifTrue: [ ^self computeMessageEntriesForClass: (Smalltalk at: id asSymbol) class with: possibleBinarySendRange ]. - rangeType == #self - ifTrue: [ ^self computeMessageEntriesForClass: contextClass with: possibleBinarySendRange ]. - rangeType == #super - ifTrue: [ ^self computeMessageEntriesForClass: contextClass superclass with: possibleBinarySendRange ]. - rangeType == #true - ifTrue: [ ^self computeMessageEntriesForClass: True with: possibleBinarySendRange ]. - rangeType == #false - ifTrue: [ ^self computeMessageEntriesForClass: False with: possibleBinarySendRange ]. - rangeType == #nil - ifTrue: [ ^self computeMessageEntriesForClass: UndefinedObject with: possibleBinarySendRange ]. - rangeType == #character - ifTrue: [ ^self computeMessageEntriesForClass: id first class with: possibleBinarySendRange ]. - rangeType == #number - ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) with: possibleBinarySendRange ]. - rangeType == #string - ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) with: possibleBinarySendRange ]. - rangeType == #symbol - ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) with: possibleBinarySendRange ]. - rangeType == #stringSymbol - ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) with: possibleBinarySendRange ]. - rangeType == #instVar - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofInstVarNamed: id with: possibleBinarySendRange ]. - rangeType == #methodArg - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofTempVarNamed: id with: possibleBinarySendRange ]. - rangeType == #tempVar - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofTempVarNamed: id with: possibleBinarySendRange ]. - rangeType == #blockArg - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofBlockArgNamed: id with: possibleBinarySendRange ]. - rangeType == #blockTempVar - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofBlockTempVarNamed: id with: possibleBinarySendRange ]. - rangeType == #workspaceVar - ifTrue: [ ^self computeMessageEntriesForClassOrNil: (specificModel classOfWorkspaceVarNamed: id) with: possibleBinarySendRange ]. - rangeType == #thisContext - ifTrue: [ ^self computeMessageEntriesForClass: (specificModel classOfThisContext) with: possibleBinarySendRange ]. - rangeType == #classVar - ifTrue: [ ^self computeMessageEntriesForClassOrNil: (self classOfLocalBindingNamed: id in: contextClass) with: possibleBinarySendRange ]. - rangeType == #poolConstant - ifTrue: [ ^self computeMessageEntriesForClassOrNil: (self classOfLocalBindingNamed: id in: contextClass) with: possibleBinarySendRange ]. - rangeType == #blockEnd - ifTrue: [ ^self computeMessageEntriesForClass: BlockClosure with: possibleBinarySendRange ]. - rangeType == #arrayEnd - ifTrue: [ ^self computeMessageEntriesForClass: Array with: possibleBinarySendRange ]. - rangeType == #rightBrace - ifTrue: [ ^self computeMessageEntriesForClass: Array with: possibleBinarySendRange ]. - rangeType == #unary - ifTrue: [ ^self computeEntriesOfUnaryMessageReturnNamed: id at: range with: possibleBinarySendRange ]. - rangeType == #rightParenthesis - ifTrue: [ ^self computeMessageEntriesOfEnclosedExpressionReturnAt: range with: possibleBinarySendRange ]. - rangeType == #cascadeSeparator - ifTrue: [ ^self computeMessageEntriesOfCascadeReceiverAt: range with: possibleBinarySendRange ]. - - self computeMessageEntriesForUnknowClass - - ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 10/27/2019 21:55:05' prior: 50436741! -computeMessageEntriesForClass: aClass - - selectorsClasses := Array with: aClass. - - entries := (AutoCompleterSelectorsCollector for: prefix) - addSelectorsOf: aClass; - entriesToShow! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 10/27/2019 21:54:40'! - computeMessageEntriesForClass: aClass with: possibleBinaryMessageSendRange - - (self isBinaryMessageSend: possibleBinaryMessageSendRange) - ifTrue: [ self computeMessageEntriesForClass: aClass withPreviousBinaryMessageSend: possibleBinaryMessageSendRange ] - ifFalse: [ self computeMessageEntriesForClass: aClass ]. - - self ifEmptyEntriesShowAllPrefixedSelectors! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 10/27/2019 21:55:51'! - computeMessageEntriesForClass: aClass withPreviousBinaryMessageSend: possibleBinaryMessageSendRange - - self computeMessageEntriesForClass: aClass - ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 10/27/2019 21:47:59'! - computeMessageEntriesForClassOrNil: aClassOrNil with: possibleBinaryMessageSendRange - - aClassOrNil - ifNil: [ self computeMessageEntriesForUnknowClass ] - ifNotNil: [ self computeMessageEntriesForClass: aClassOrNil with: possibleBinaryMessageSendRange ]. - -! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 10/27/2019 23:31:06'! - computeMessageEntriesOfCascadeReceiverAt: aRange with: possibleBinaryMessageSendRange - - self subclassResponsibility ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 10/27/2019 23:30:13'! - computeMessageEntriesOfEnclosedExpressionReturnAt: aRange with: possibleBinaryMessageSendRange - - self subclassResponsibility ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 10/27/2019 19:56:52'! - computeMessageEntriesWithEmptyPrefixFor: allSource using: last3Ranges at: range in: contextClass and: specificModel - - prefix _ ''. - self computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel with: last3Ranges second.! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 10/27/2019 18:40:11'! - isBinaryMessageSend: possibleBinaryMessageSendRange - - ^possibleBinaryMessageSendRange notNil and: [ possibleBinaryMessageSendRange rangeType = #binary ]. - - ! ! -!DynamicTypingSmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 10/27/2019 18:38:46'! - computeEntriesOfUnaryMessageReturnNamed: aSelector at: aRange with: possibleBinaryMessageSendRange - - self computeMessageEntriesForUnknowClass - ! ! -!DynamicTypingSmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 10/27/2019 23:31:06'! - computeMessageEntriesOfCascadeReceiverAt: aRange with: possibleBinaryMessageSendRange - - self computeMessageEntriesForUnknowClass - -! ! -!DynamicTypingSmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 10/27/2019 23:30:13'! - computeMessageEntriesOfEnclosedExpressionReturnAt: aRange with: possibleBinaryMessageSendRange - - self computeMessageEntriesForUnknowClass - -! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting' stamp: 'HAW 10/28/2019 00:38:01'! - addKeywordSelectorsOf: aClass - - self selectKeywordSelectorsWhile: [ self addSelectorsOf: aClass ]! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting' stamp: 'HAW 10/28/2019 00:38:01'! - addKeywordSelectorsOf: aClass upTo: aSuperclassToExclude - - self selectKeywordSelectorsWhile: [ self addSelectorsOf: aClass upTo: aSuperclassToExclude ]! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting' stamp: 'HAW 10/28/2019 00:38:01'! - addKeywordSelectorsOfAll: classes upTo: aSuperclass - - self selectKeywordSelectorsWhile: [ self addSelectorsOfAll: classes upTo: aSuperclass ]! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting' stamp: 'HAW 10/27/2019 19:38:13'! - addUnaryAndBinarySelectorsOf: aClass - - self selectUnaryAndBinarySelectorsWhile: [ self addSelectorsOf: aClass ]. - ! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting' stamp: 'HAW 10/27/2019 23:54:56'! - addUnaryAndBinarySelectorsOf: aClass upTo: aSuperclassToExclude - - self selectUnaryAndBinarySelectorsWhile: [ self addSelectorsOf: aClass upTo: aSuperclassToExclude ]. - ! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting' stamp: 'HAW 10/27/2019 23:55:50'! - addUnaryAndBinarySelectorsOfAll: classes upTo: aSuperclassToExclude - - self selectUnaryAndBinarySelectorsWhile: [ self addSelectorsOfAll: classes upTo: aSuperclassToExclude ]. - ! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting - private' stamp: 'HAW 10/28/2019 00:38:01'! - selectKeywordSelectorsWhile: aClosure - - self selectSelectorsThatSatisfy: [ :aSelector | aSelector isKeyword ] while: aClosure -! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting - private' stamp: 'HAW 10/27/2019 19:36:18'! - selectSelectorsThatSatisfy: aSelectorsSelectionCondition while: aClosure - - | currentSelectorsSelectionCondition | - - currentSelectorsSelectionCondition := selectorSelectionCondition. - [ selectorSelectionCondition := aSelectorsSelectionCondition. - aClosure value ] ensure: [ selectorSelectionCondition := currentSelectorsSelectionCondition ].! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting - private' stamp: 'HAW 10/27/2019 19:38:54'! -selectUnaryAndBinarySelectorsWhile: aClosure - - self selectSelectorsThatSatisfy: [ :aSelector | aSelector isKeyword not ] while: aClosure -! ! -!SmalltalkCompleter methodsFor: 'entries' stamp: 'HAW 10/27/2019 12:40:42' prior: 50434495! - computeEntries - - | allSource contextClass specificModel last3Ranges range | - - allSource _ model actualContents string. - specificModel _ self textProviderOrModel. - contextClass _ self selectedClassOrMetaClassIn: specificModel. - last3Ranges _ self parse: allSource in: contextClass and: specificModel. - range _ last3Ranges third ifNil: [ ^entries _ #() ]. - possibleInvalidSelectors _ #(). - - range end = position - ifTrue: [ self computeEntriesOfMessageOrIdentifiersFor: allSource using: last3Ranges at: range in: contextClass and: specificModel ] - ifFalse: [ self computeMessageEntriesWithEmptyPrefixFor: allSource using: last3Ranges at: range in: contextClass and: specificModel ]. - - ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 10/27/2019 20:09:37' prior: 50434633! - computeMessageEntriesWhenSendinMessageFor: allSource using: last3Ranges in: contextClass and: specificModel - - | prevPrevRange prevRange | - - "If previous range is a constant or a well known identifier, we might filter messages" - prevRange _ last3Ranges second. - prevPrevRange _ last3Ranges first. - - "3 if -> ifNil: but not ifTrue: - 3=4 -> ifNil: or ifTrue:" - - ^ (self canComputeMessageEntriesFor: prevRange ) - ifTrue: [ self computeMessageEntriesFor: allSource at: prevRange in: contextClass and: specificModel with: prevPrevRange ] - ifFalse: [ self computeMessageEntriesForUnknowClass ] -! ! -!AutoCompleterSelectorsCollector methodsFor: 'initialization' stamp: 'HAW 10/27/2019 19:20:29' prior: 50434058! - initializeFor: aPrefix withSelectorsLimitedTo: aLimit - - prefix := aPrefix. - categoriesWithSelectors := OrderedDictionary new. - addedSelectorsFastSet := IdentitySet new. - possibleInvalidSelectors := IdentitySet new. - selectorsLimit := aLimit. - selectorSelectionCondition := [ :aSelector | true ]! ! -!AutoCompleterSelectorsCollector methodsFor: 'collecting - private' stamp: 'HAW 10/27/2019 19:22:52' prior: 50434151! - prefixedSelectorsOf: aCategory in: aClassOrganization - - ^ (aClassOrganization listAtCategoryNamed: aCategory) - select: [ :aSelector | - (aSelector beginsWith: prefix) - and: [ (selectorSelectionCondition value: aSelector) - and: [ (addedSelectorsFastSet includes: aSelector) not ]]]. -! ! - -AutoCompleterSelectorsCollector removeSelector: #addBinarySelectorsOfAll:upTo:! - -AutoCompleterSelectorsCollector removeSelector: #selectBinaryKeywordWhile:! - -AutoCompleterSelectorsCollector removeSelector: #addBinarySelectorsOf:upTo:! - -AutoCompleterSelectorsCollector removeSelector: #addBinarySelectorsOf:! - -AutoCompleterSelectorsCollector removeSelector: #selectBinarySelectorsWhile:! - -DynamicTypingSmalltalkCompleter removeSelector: #computeMessageEntriesOfCascadeReceiverAt:! - -!methodRemoval: DynamicTypingSmalltalkCompleter #computeMessageEntriesOfCascadeReceiverAt: stamp: 'jmv 11/15/2019 09:45:31'! -computeMessageEntriesOfCascadeReceiverAt: aRange - - self computeMessageEntriesForUnknowClass - -! - -DynamicTypingSmalltalkCompleter removeSelector: #computeEntriesOfUnaryMessageReturnNamed:at:! - -!methodRemoval: DynamicTypingSmalltalkCompleter #computeEntriesOfUnaryMessageReturnNamed:at: stamp: 'jmv 11/15/2019 09:45:31'! -computeEntriesOfUnaryMessageReturnNamed: aSelector at: aRange - - self computeMessageEntriesForUnknowClass - ! - -DynamicTypingSmalltalkCompleter removeSelector: #computeMessageEntriesOfEnclosedExpressionReturnAt:! - -!methodRemoval: DynamicTypingSmalltalkCompleter #computeMessageEntriesOfEnclosedExpressionReturnAt: stamp: 'jmv 11/15/2019 09:45:31'! -computeMessageEntriesOfEnclosedExpressionReturnAt: aRange - - self computeMessageEntriesForUnknowClass - -! - -SmalltalkCompleter removeSelector: #computeMessageEntriesOfEnclosedExpressionReturnAt:! - -!methodRemoval: SmalltalkCompleter #computeMessageEntriesOfEnclosedExpressionReturnAt: stamp: 'jmv 11/15/2019 09:45:31'! -computeMessageEntriesOfEnclosedExpressionReturnAt: aRange - - self subclassResponsibility ! - -SmalltalkCompleter removeSelector: #computeEntriesOfUnaryMessageReturnNamed:at:! - -!methodRemoval: SmalltalkCompleter #computeEntriesOfUnaryMessageReturnNamed:at: stamp: 'jmv 11/15/2019 09:45:31'! -computeEntriesOfUnaryMessageReturnNamed: aSelector at: aRange - - self subclassResponsibility ! - -SmalltalkCompleter removeSelector: #computeMessageEntriesOfCascadeReceiverAt:! - -!methodRemoval: SmalltalkCompleter #computeMessageEntriesOfCascadeReceiverAt: stamp: 'jmv 11/15/2019 09:45:31'! -computeMessageEntriesOfCascadeReceiverAt: aRange - - self subclassResponsibility ! - -SmalltalkCompleter removeSelector: #computeMessageEntriesForClassOrNil:! - -!methodRemoval: SmalltalkCompleter #computeMessageEntriesForClassOrNil: stamp: 'jmv 11/15/2019 09:45:31'! -computeMessageEntriesForClassOrNil: aClassOrNil - - aClassOrNil - ifNil: [ self computeMessageEntriesForUnknowClass ] - ifNotNil: [ self computeMessageEntriesForClass: aClassOrNil ]. - -! - -SmalltalkCompleter removeSelector: #canComputeMessageEntriesFor:and:! - -!methodRemoval: SmalltalkCompleter #canComputeMessageEntriesFor:and: stamp: 'jmv 11/15/2019 09:45:31'! -canComputeMessageEntriesFor: prevRange and: prevPrevRange - - ^ prevRange notNil and: [ prevPrevRange isNil or: [ prevPrevRange rangeType ~= #binary ]]! - -SmalltalkCompleter removeSelector: #computeMessageEntriesWithEmptyPrefixFor:at:in:and:! - -!methodRemoval: SmalltalkCompleter #computeMessageEntriesWithEmptyPrefixFor:at:in:and: stamp: 'jmv 11/15/2019 09:45:31'! -computeMessageEntriesWithEmptyPrefixFor: allSource at: range in: contextClass and: specificModel - - prefix _ ''. - self computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel ! - -SmalltalkCompleter removeSelector: #computeMessageEntriesFor:at:in:and:! - -!methodRemoval: SmalltalkCompleter #computeMessageEntriesFor:at:in:and: stamp: 'jmv 11/15/2019 09:45:31'! -computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel - - | id rangeType | - - canShowSelectorDocumentation _ true. - id _ allSource copyFrom: range start to: range end. - rangeType _ range rangeType. - - rangeType == #globalVar ifTrue: [ ^self computeMessageEntriesForClass: (Smalltalk at: id asSymbol) class ]. - rangeType == #self ifTrue: [ ^self computeMessageEntriesForClass: contextClass ]. - rangeType == #super ifTrue: [ ^self computeMessageEntriesForClass: contextClass superclass ]. - rangeType == #true ifTrue: [ ^self computeMessageEntriesForClass: True ]. - rangeType == #false ifTrue: [ ^self computeMessageEntriesForClass: False ]. - rangeType == #nil ifTrue: [ ^self computeMessageEntriesForClass: UndefinedObject ]. - rangeType == #character ifTrue: [ ^self computeMessageEntriesForClass: id first class ]. - rangeType == #number ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #string ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #symbol ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #stringSymbol ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #instVar ifTrue: [ ^specificModel computeMessageEntriesIn: self ofInstVarNamed: id ]. - rangeType == #methodArg ifTrue: [ ^specificModel computeMessageEntriesIn: self ofTempVarNamed: id ]. - rangeType == #tempVar ifTrue: [ ^specificModel computeMessageEntriesIn: self ofTempVarNamed: id ]. - rangeType == #blockArg ifTrue: [ ^specificModel computeMessageEntriesIn: self ofBlockArgNamed: id ]. - rangeType == #blockTempVar ifTrue: [ ^specificModel computeMessageEntriesIn: self ofBlockTempVarNamed: id ]. - rangeType == #workspaceVar ifTrue: [ ^self computeMessageEntriesForClassOrNil: (specificModel classOfWorkspaceVarNamed: id) ]. - rangeType == #thisContext ifTrue: [ ^self computeMessageEntriesForClass: (specificModel classOfThisContext) ]. - rangeType == #classVar ifTrue: [ ^self computeMessageEntriesForClassOrNil: (self classOfLocalBindingNamed: id in: contextClass) ]. - rangeType == #poolConstant ifTrue: [ ^self computeMessageEntriesForClassOrNil: (self classOfLocalBindingNamed: id in: contextClass) ]. - rangeType == #blockEnd ifTrue: [ ^self computeMessageEntriesForClass: BlockClosure ]. - rangeType == #arrayEnd ifTrue: [ ^self computeMessageEntriesForClass: Array ]. - rangeType == #rightBrace ifTrue: [ ^self computeMessageEntriesForClass: Array ]. - rangeType == #unary ifTrue: [ ^self computeEntriesOfUnaryMessageReturnNamed: id at: range ]. - rangeType == #rightParenthesis ifTrue: [ ^self computeMessageEntriesOfEnclosedExpressionReturnAt: range ]. - rangeType == #cascadeSeparator ifTrue: [ ^self computeMessageEntriesOfCascadeReceiverAt: range ]. - - self computeMessageEntriesForUnknowClass - - ! - -ClassNameRequestMorph removeSelector: #computeMessageEntriesIn:ofInstVarNamed:! - -!methodRemoval: ClassNameRequestMorph #computeMessageEntriesIn:ofInstVarNamed: stamp: 'jmv 11/15/2019 09:45:31'! -computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! - -ClassNameRequestMorph removeSelector: #computeMessageEntriesIn:ofTempVarNamed:! - -!methodRemoval: ClassNameRequestMorph #computeMessageEntriesIn:ofTempVarNamed: stamp: 'jmv 11/15/2019 09:45:31'! -computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! - -ClassNameRequestMorph removeSelector: #computeMessageEntriesIn:ofBlockArgNamed:! - -!methodRemoval: ClassNameRequestMorph #computeMessageEntriesIn:ofBlockArgNamed: stamp: 'jmv 11/15/2019 09:45:31'! -computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! - -ClassNameRequestMorph removeSelector: #computeMessageEntriesIn:ofBlockTempVarNamed:! - -!methodRemoval: ClassNameRequestMorph #computeMessageEntriesIn:ofBlockTempVarNamed: stamp: 'jmv 11/15/2019 09:45:31'! -computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! - -Inspector removeSelector: #computeMessageEntriesIn:ofInstVarNamed:! - -!methodRemoval: Inspector #computeMessageEntriesIn:ofInstVarNamed: stamp: 'jmv 11/15/2019 09:45:31'! -computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - anAutocompleter computeMessageEntriesForClass: (object instVarNamed: aName) class ! - -Debugger removeSelector: #computeMessageEntriesIn:ofInstVarNamed:! - -!methodRemoval: Debugger #computeMessageEntriesIn:ofInstVarNamed: stamp: 'jmv 11/15/2019 09:45:31'! -computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - contextStackIndex = 0 - ifTrue: [ anAutocompleter computeMessageEntriesForUnknowClass ] - ifFalse: [ anAutocompleter computeMessageEntriesForClass: (self receiver instVarNamed: aName) class]! - -Debugger removeSelector: #computeMessageEntriesIn:ofTempVarNamed:! - -!methodRemoval: Debugger #computeMessageEntriesIn:ofTempVarNamed: stamp: 'jmv 11/15/2019 09:45:31'! -computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - | context tempIndex | - - context := self selectedContext. - tempIndex := context tempNames indexOf: aName ifAbsent: [ ^ anAutocompleter computeMessageEntriesForUnknowClass ]. - - anAutocompleter computeMessageEntriesForClass: (self debuggerMap namedTempAt: tempIndex in: context) class - - ! - -Debugger removeSelector: #computeMessageEntriesIn:ofBlockArgNamed:! - -!methodRemoval: Debugger #computeMessageEntriesIn:ofBlockArgNamed: stamp: 'jmv 11/15/2019 09:45:31'! -computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName - - self computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName -! - -Debugger removeSelector: #computeMessageEntriesIn:ofBlockTempVarNamed:! - -!methodRemoval: Debugger #computeMessageEntriesIn:ofBlockTempVarNamed: stamp: 'jmv 11/15/2019 09:45:31'! -computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName - - ^self computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName ! - -TextProvider removeSelector: #computeMessageEntriesIn:ofInstVarNamed:! - -!methodRemoval: TextProvider #computeMessageEntriesIn:ofInstVarNamed: stamp: 'jmv 11/15/2019 09:45:31'! -computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! - -TextProvider removeSelector: #computeMessageEntriesIn:ofTempVarNamed:! - -!methodRemoval: TextProvider #computeMessageEntriesIn:ofTempVarNamed: stamp: 'jmv 11/15/2019 09:45:31'! -computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! - -TextProvider removeSelector: #computeMessageEntriesIn:ofBlockArgNamed:! - -!methodRemoval: TextProvider #computeMessageEntriesIn:ofBlockArgNamed: stamp: 'jmv 11/15/2019 09:45:31'! -computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! - -TextProvider removeSelector: #computeMessageEntriesIn:ofBlockTempVarNamed:! - -!methodRemoval: TextProvider #computeMessageEntriesIn:ofBlockTempVarNamed: stamp: 'jmv 11/15/2019 09:45:31'! -computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! - -Workspace removeSelector: #computeMessageEntriesIn:ofTempVarNamed:! - -!methodRemoval: Workspace #computeMessageEntriesIn:ofTempVarNamed: stamp: 'jmv 11/15/2019 09:45:31'! -computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - anAutocompleter computeMessageEntriesForClassOrNil: (self classOfBindingOf: aName)! - -PluggableTextModel removeSelector: #computeMessageEntriesIn:ofInstVarNamed:! - -!methodRemoval: PluggableTextModel #computeMessageEntriesIn:ofInstVarNamed: stamp: 'jmv 11/15/2019 09:45:31'! -computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - textProvider computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName -! - -PluggableTextModel removeSelector: #computeMessageEntriesIn:ofTempVarNamed:! - -!methodRemoval: PluggableTextModel #computeMessageEntriesIn:ofTempVarNamed: stamp: 'jmv 11/15/2019 09:45:31'! -computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - textProvider computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName -! - -PluggableTextModel removeSelector: #computeMessageEntriesIn:ofBlockArgNamed:! - -!methodRemoval: PluggableTextModel #computeMessageEntriesIn:ofBlockArgNamed: stamp: 'jmv 11/15/2019 09:45:31'! -computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName - - textProvider computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName -! - -PluggableTextModel removeSelector: #computeMessageEntriesIn:ofBlockTempVarNamed:! - -!methodRemoval: PluggableTextModel #computeMessageEntriesIn:ofBlockTempVarNamed: stamp: 'jmv 11/15/2019 09:45:31'! -computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName - - textProvider computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName! - -TextModel removeSelector: #computeMessageEntriesIn:ofInstVarNamed:! - -!methodRemoval: TextModel #computeMessageEntriesIn:ofInstVarNamed: stamp: 'jmv 11/15/2019 09:45:31'! -computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! - -TextModel removeSelector: #computeMessageEntriesIn:ofTempVarNamed:! - -!methodRemoval: TextModel #computeMessageEntriesIn:ofTempVarNamed: stamp: 'jmv 11/15/2019 09:45:31'! -computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! - -TextModel removeSelector: #computeMessageEntriesIn:ofBlockArgNamed:! - -!methodRemoval: TextModel #computeMessageEntriesIn:ofBlockArgNamed: stamp: 'jmv 11/15/2019 09:45:32'! -computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! - -TextModel removeSelector: #computeMessageEntriesIn:ofBlockTempVarNamed:! - -!methodRemoval: TextModel #computeMessageEntriesIn:ofBlockTempVarNamed: stamp: 'jmv 11/15/2019 09:45:32'! -computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! - -Object subclass: #AutoCompleterSelectorsCollector - instanceVariableNames: 'categoriesWithSelectors addedSelectorsFastSet prefix entriesToShow possibleInvalidSelectors otherClasses selectorsLimit selectorSelectionCondition' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #AutoCompleterSelectorsCollector category: #'Tools-Autocompletion' stamp: 'jmv 11/15/2019 09:45:32'! -Object subclass: #AutoCompleterSelectorsCollector - instanceVariableNames: 'categoriesWithSelectors addedSelectorsFastSet prefix entriesToShow possibleInvalidSelectors otherClasses selectorsLimit selectorSelectionCondition' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3936-AutoCompleteRecognitionOfBinaryMessageSend-HernanWilkinson-2019Oct27-00h56m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3935] on 28 October 2019 at 1:24:17 am'! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 10/28/2019 01:23:36' prior: 50480306! - computeMessageEntriesForClass: aClass withPreviousBinaryMessageSend: possibleBinaryMessageSendRange - - selectorsClasses := Array with: aClass. - - entries := (AutoCompleterSelectorsCollector for: prefix) - addUnaryAndBinarySelectorsOf: aClass; - entriesToShow! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3937-ShowOnlyUnaryAndBinary-HernanWilkinson-2019Oct28-01h00m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3937] on 28 October 2019 at 8:56:17 am'! -!ChangeRecord methodsFor: 'initialization' stamp: 'HAW 10/28/2019 08:36:56'! - markAsTest: aBoolean - - isTest := aBoolean ! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/28/2019 08:32:47' prior: 50479798! - classDefinitionRecordFrom: tokens - - | classDefinition isMeta itemPosition className record fullClassName stamp | - - itemPosition _ file position. - fullClassName _ tokens second. - isMeta _ fullClassName includesSubString: ' class'. - className _ isMeta ifTrue: [fullClassName substrings first] ifFalse: [fullClassName]. - stamp _ self stampFrom: tokens. - classDefinition _ file nextChunk. - - record _ ChangeRecord new - file: file - position: itemPosition - type: #classDefinition - class: className asSymbol - category: tokens last - meta: isMeta - stamp: stamp. - - record markAsTest: (classDefinition beginsWith: TestCase name asString). - - ^record -! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/28/2019 08:35:29' prior: 50479819! - scanClassDefinition: tokens - - | record | - - record _ self classDefinitionRecordFrom: tokens. - - self addItem: record text: 'classDefinition: ', record changeClassName. - ! ! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'HAW 10/28/2019 08:41:18' prior: 50479876! - definitionPreamble - - ^'classDefinition: ', self name printString, ' category: ', self category printString, Utilities changeStampField! ! -!ChangeRecord methodsFor: 'initialization' stamp: 'HAW 10/28/2019 08:38:08' prior: 50479706! - file: aFile position: aPosition type: aType - - file _ aFile. - position _ aPosition. - type _ aType. - - self markAsTest: false. -" -file closed ifFalse: [ - '' print. - file print. - self print. - thisContext printStack: 10 ] -"! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3938-TestClassDefinition-HernanWilkinson-2019Oct28-08h25m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3938] on 28 October 2019 at 9:56:04 am'! -!Class methodsFor: 'fileIn/Out' stamp: 'HAW 10/28/2019 09:53:14' prior: 50478591! - definitionReplacingCategoryWith: aNewCategory - - | definition categoryDefinitionIndex currentCategoryDefinition definitionWithNewCategory | - - definition := self definition. - "category can be nil, that is why I sent asString to it - Hernan" - currentCategoryDefinition := 'category: ''', self category asString, ''''. - categoryDefinitionIndex := definition - indexOfSubCollection: currentCategoryDefinition - startingAt: 1 - ifAbsent: [ self error: 'Definition of category not found!!' ]. - - definitionWithNewCategory := definition first: categoryDefinitionIndex - 1. - definitionWithNewCategory := definitionWithNewCategory, 'category: ''', aNewCategory asString, ''''. - - ^definitionWithNewCategory ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3939-definitionReplacingCategoryWith-HernanWilkinson-2019Oct28-09h48m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3938] on 28 October 2019 at 10:08:28 am'! - -ChangeListElement subclass: #ChangeRecord - instanceVariableNames: 'file position type class category meta stamp prior isTest ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #ChangeRecord category: #'Tools-Changes' stamp: 'jmv 11/15/2019 09:45:32'! -ChangeListElement subclass: #ChangeRecord - instanceVariableNames: 'file position type class category meta stamp prior isTest' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -ChangeListElement subclass: #ChangeRecord - instanceVariableNames: 'file position type class category meta stamp prior isTest' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #ChangeRecord category: #'Tools-Changes' stamp: 'jmv 11/15/2019 09:45:32'! -ChangeListElement subclass: #ChangeRecord - instanceVariableNames: 'file position type class category meta stamp prior isTest' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3940-ChangeRecordDefinition-HernanWilkinson-2019Oct28-09h56m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3940] on 28 October 2019 at 4:50:46 pm'! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'jmv 10/28/2019 16:49:45' prior: 50407528! - logChange: aStringOrText preamble: preambleOrNil - "Write the argument, aString, onto the changes file." - | aString changesFile | - self assureStartupStampLogged. - aString _ aStringOrText asString. - aString firstNoBlankIndex = 0 ifTrue: [^ self]. "null doits confuse replay" - - (SourceFiles notNil and: [(changesFile _ SourceFiles at: 2) notNil]) ifTrue: [ - changesFile isReadOnly ifFalse: [ - changesFile setToEnd; newLine; newLine. - preambleOrNil ifNotNil: [ - changesFile nextPut: $!!; nextChunkPut: preambleOrNil; newLine ]. - changesFile nextChunkPut: aString. - self forceChangesToDisk ]]. - Utilities logsUserChanges ifTrue: [ - Smalltalk defaultUserChangesName asFileEntry appendStreamDo: [ :stream | - stream newLine; newLine. - preambleOrNil ifNotNil: [ - stream nextPut: $!!; nextChunkPut: preambleOrNil; newLine ]. - stream nextChunkPut: aString ]]! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -ClassOrganizer allInstancesDo: [:co | co removeEmptyCategories]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3941-veryMinorCleanup-JuanVuletich-2019Oct28-16h49m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3941] on 28 October 2019 at 5:27:04 pm'! - -"Change Set: 3840-CuisCore-SantiagoDandois-2019Oct27 -Date: 27 October 2019 -Author: Santiago José Dandois - -Small changes to TextModel acceptContents. - -Check if new contents equal previousContents before resetting undeRedoBuffers. -This way you can safely save (Cmd-s) and undo changes (Cmd-z) after saving."! -!TextModel methodsFor: 'accessing' stamp: 'sjd 10/28/2019 17:23:39' prior: 16933681! - actualContents: aTextOrString - self basicActualContents: aTextOrString. - self changed: #actualContents! ! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 10/28/2019 17:26:50' prior: 50475558! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('AY' 'Angel Yan') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('bgs' 'Boris G. Shingarov') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('EB' 'Eric Brandwein') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('FGJ' 'Fernando Gasperi Jabalera') - #('FJG' 'Facundo Javier Gelatti') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('KLG' 'Gerald Klix') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MM' 'Mariano Montone') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('pmon' 'Paolo Montrasi') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('sjd' 'Santiago Jose Dandois') - #('SLD' 'Steve Davies') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('ss' 'Sebastian Sujarchuk') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3942-UndoingAfterSaving-SantiagoJoseDandois-2019Oct28-17h08m-sjd.1.cs.st----! - -'From Cuis 5.0 [latest update: #3942] on 28 October 2019 at 6:15:49 pm'! -!MessageSetWindow class methodsFor: 'opening' stamp: 'jmv 10/28/2019 18:14:40'! - findInSourceCode - | textToSearch | - - textToSearch _ FillInTheBlankMorph request: 'Text to search Source Code for?'. - Smalltalk browseMethodsWithSourceString: textToSearch! ! -!PasteUpMorph methodsFor: 'events' stamp: 'jmv 10/28/2019 18:13:11' prior: 50448884! - keyStroke: aKeyboardEvent - "Handle a keystroke event." - (aKeyboardEvent commandAltKeyPressed or: [ aKeyboardEvent controlKeyPressed ]) - ifTrue: [ - aKeyboardEvent keyCharacter = $b ifTrue: [ BrowserWindow openBrowser ]. - aKeyboardEvent keyCharacter = $f ifTrue: [ BrowserWindow findClass ]. - aKeyboardEvent keyCharacter = $F ifTrue: [ MessageSetWindow findInSourceCode ]. - ]. - "aKeyboardEvent keyCharacter print." - ^ super keyStroke: aKeyboardEvent! ! - -MessageSetWindow class removeSelector: #findSourceCode! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3943-SourceCodeFinder-GastonCaruso-JuanVuletich-2019Oct28-18h12m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3943] on 29 October 2019 at 11:08:22 am'! -!ChangeList methodsFor: 'as yet unclassified' stamp: 'HAW 10/29/2019 11:06:21'! - classCategoryFrom: tokens - - ^self field: #category: from: tokens ifAbsentOrNil: [ Categorizer default ]! ! -!ChangeList methodsFor: 'as yet unclassified' stamp: 'HAW 10/29/2019 10:53:32'! - field: aFieldName from: tokens ifAbsentOrNil: aBlock - - | fieldValue fieldIndex | - - fieldIndex _ tokens indexOf: aFieldName ifAbsent: [ ^aBlock value ]. - fieldValue _ tokens at: fieldIndex + 1 ifAbsent: [ ^aBlock value ]. - - ^ fieldValue ifNil: aBlock! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/29/2019 11:06:27' prior: 50481026! - classDefinitionRecordFrom: tokens - - | classDefinition isMeta itemPosition className record fullClassName category stamp | - - itemPosition _ file position. - fullClassName _ tokens second. - isMeta _ fullClassName includesSubString: ' class'. - className _ isMeta ifTrue: [fullClassName substrings first] ifFalse: [fullClassName]. - category _ self classCategoryFrom: tokens. - stamp _ self stampFrom: tokens. - classDefinition _ file nextChunk. - - record _ ChangeRecord new - file: file - position: itemPosition - type: #classDefinition - class: className asSymbol - category: category - meta: isMeta - stamp: stamp. - - record markAsTest: (classDefinition beginsWith: TestCase name asString). - - ^record -! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/29/2019 10:54:41' prior: 50479576! - stampFrom: tokens - - ^self field: #stamp: from: tokens ifAbsentOrNil: [ '' ] - -! ! - -ChangeList removeSelector: #categoryFrom:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3944-ClassCategoryRefactoring-HernanWilkinson-2019Oct29-10h41m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3944] on 4 November 2019 at 11:11:21 am'! -!Duration methodsFor: 'ansi protocol' stamp: 'jmv 11/4/2019 11:10:43' prior: 16835967! - hash - ^seconds hash bitXor: nanos hash! ! -!Time methodsFor: 'ansi protocol' stamp: 'jmv 11/4/2019 11:11:16' prior: 16936970! - hash - - ^ seconds hash bitXor: nanos hash! ! -!Character methodsFor: 'comparing' stamp: 'jmv 11/4/2019 11:03:26' prior: 16800457! -hash - "Hash is reimplemented because = is implemented." - - ^self numericValue hash! ! -!Timespan methodsFor: 'ansi protocol' stamp: 'jmv 11/4/2019 11:02:38' prior: 16938011! - hash - - ^ start hash bitXor: duration hash -! ! -!Interval methodsFor: 'comparing' stamp: 'jmv 11/4/2019 11:07:17' prior: 16861220! - hash - "Hash is reimplemented because = is implemented." - - ^ (start hash bitXor: stop hash) bitXor: count hash! ! -!KeyboardEvent methodsFor: 'comparing' stamp: 'jmv 11/4/2019 11:02:03' prior: 16861807! - hash - ^buttons hash bitXor: keyValue hash -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3945-hash-enh-JuanVuletich-2019Nov04-11h02m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3866] on 2 November 2019 at 8:46:40 pm'! -!SmallInteger methodsFor: 'enumerating' stamp: 'sqr 11/2/2019 20:45:34'! - timesRepeat: aBlock - "Evaluate the argument, aBlock, the number of times represented by the - receiver." - - self < 1 ifTrue: [^self]. - 1 to: (self bitAnd: 31) do: [:x | aBlock value]. - 1 to: (self bitAnd: -32) by: 32 do: - [:x | - aBlock value. aBlock value. aBlock value. aBlock value. - aBlock value. aBlock value. aBlock value. aBlock value. - aBlock value. aBlock value. aBlock value. aBlock value. - aBlock value. aBlock value. aBlock value. aBlock value. - aBlock value. aBlock value. aBlock value. aBlock value. - aBlock value. aBlock value. aBlock value. aBlock value. - aBlock value. aBlock value. aBlock value. aBlock value. - aBlock value. aBlock value. aBlock value. aBlock value - ]! ! -!Integer methodsFor: 'enumerating' stamp: 'sqr 11/2/2019 20:17:15' prior: 16859496! - timesRepeat: aBlock - "Evaluate the argument, aBlock, the number of times represented by the - receiver." - - | toGo thisRound | - toGo := self. - [toGo > 0] whileTrue: - [ - thisRound := toGo min: SmallInteger maxVal. - thisRound timesRepeat: aBlock. - toGo := toGo - thisRound - ]! ! - -LargePositiveInteger removeSelector: #timesRepeat:! - -!methodRemoval: LargePositiveInteger #timesRepeat: stamp: 'jmv 11/15/2019 09:45:32'! -timesRepeat: aBlock - "Evaluate the argument, aBlock, the number of times represented by the - receiver." - - | toGo thisRound count | - toGo := self. - [toGo > 0] whileTrue: - [ - thisRound := toGo min: SmallInteger maxVal. - count := 1. - [count <= thisRound] whileTrue: - [ - aBlock value. - count := count + 1 - ]. - toGo := toGo - thisRound - ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3946-faster-timesRepeatAndresValloud-2019Nov02-20h00m-sqr.1.cs.st----! - -'From Cuis 5.0 [latest update: #3946] on 7 November 2019 at 2:09:32 pm'! -!LargePositiveInteger methodsFor: 'enumerating' stamp: 'sqr 11/2/2019 20:17:15'! - timesRepeat: aBlock - "Evaluate the argument, aBlock, the number of times represented by the - receiver." - - | toGo thisRound | - toGo := self. - [toGo > 0] whileTrue: - [ - thisRound := toGo min: SmallInteger maxVal. - thisRound timesRepeat: aBlock. - toGo := toGo - thisRound - ]! ! -!Integer methodsFor: 'enumerating' stamp: '' prior: 50481593! - timesRepeat: aBlock - "Evaluate the argument, aBlock, the number of times represented by the - receiver." - - | count | - count _ 1. - [count <= self] - whileTrue: - [aBlock value. - count _ count + 1]! ! -!Integer methodsFor: 'testing' stamp: 'dtl 1/23/2010 14:16' prior: 50477239! - isPrime - "Answer true if the receiver is a prime number. See isProbablyPrime for a probabilistic - implementation that is much faster for large integers, and that is correct to an extremely - high statistical level of confidence (effectively deterministic)." - - self <= 1 ifTrue: [ ^false ]. - self even ifTrue: [ ^self = 2]. - 3 to: self sqrtFloor by: 2 do: [ :each | - self \\ each = 0 ifTrue: [ ^false ] ]. - ^true! ! - -SmallInteger removeSelector: #timesRepeat:! - -!methodRemoval: SmallInteger #timesRepeat: stamp: 'jmv 11/15/2019 09:45:32'! -timesRepeat: aBlock - "Evaluate the argument, aBlock, the number of times represented by the - receiver." - - self < 1 ifTrue: [^self]. - 1 to: (self bitAnd: 31) do: [:x | aBlock value]. - 1 to: (self bitAnd: -32) by: 32 do: - [:x | - aBlock value. aBlock value. aBlock value. aBlock value. - aBlock value. aBlock value. aBlock value. aBlock value. - aBlock value. aBlock value. aBlock value. aBlock value. - aBlock value. aBlock value. aBlock value. aBlock value. - aBlock value. aBlock value. aBlock value. aBlock value. - aBlock value. aBlock value. aBlock value. aBlock value. - aBlock value. aBlock value. aBlock value. aBlock value. - aBlock value. aBlock value. aBlock value. aBlock value - ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3947-RecentFasterAlternativesMovedToOwnPackage-JuanVuletich-2019Nov07-14h09m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3924] on 22 October 2019 at 4:56:30 pm'! -!Compiler commentStamp: 'jmv 10/22/2019 16:55:21' prior: 16821828! - The compiler accepts Smalltalk source code and compiles it with respect to a given class. The user of the compiler supplies a context so that temporary variables are accessible during compilation. If there is an error, a requestor is sent the message notify:at:in: so that the error message can be displayed. If there is no error, then the result of compilation is a MethodNode, which is the root of a parse tree whose nodes are kinds of ParseNodes. The parse tree can be sent messages to (1) generate code for a CompiledMethod (this is done for compiling methods or evaluating expressions); (2) pretty-print the code (for formatting); or (3) produce a map from object code back to source code (used by debugger program-counter selection). See also Parser, Encoder, ParseNode. - -See http://www.whysmalltalk.com/articles/bykov/HitchHiker.htm! -!Scanner commentStamp: 'jmv 10/22/2019 16:56:07' prior: 16903621! - I scan a string or text, picking out Smalltalk syntactic tokens. I look one character ahead. I put each token found into the instance variable, token, and its type (a Symbol) into the variable, tokenType. At the end of the input stream, I pretend to see an endless sequence of special characters called doIts. - -Instance Variables - aheadChar: - buffer: - currentComment: - hereChar: - mark: - source: - token: - tokenType: - typeTable: - -aheadChar - - the next character in the input stream - -buffer - - a reusable WriteStream on a String which is used for building strings. Shouldn't be used from multiple methods without resetting. - -currentComment - - an OrderedCollection of strings which contain all comments between the current token and the previous token or the beginning of the source. - -hereChar - - the current character - -mark - - the position of the current token in the source stream - -source - - the input stream of characters - -token - - the current token - -tokenType - - the type of the current token. The possible token types are: #binary, #character, #colon, #doIt, #keyword, #leftArrow, #leftBrace, #leftBracket, #leftParenthesis, #literal, #period, #rightBrace, #rightBracket, #rightParenthesis, #semicolon, #string, #upArrow, #verticalBar, #word, #xBinary, #xColon, #xDelimiter, #xDigit, #xDollar, #xDoubleQuote, #xLetter, #xLitQuote, #xSingleQuote, #xUnderscore - -typeTable - - an array that maps each an evaluable tokenType to each character with asciiValue between 0 and 255 - -See http://www.whysmalltalk.com/articles/bykov/HitchHiker.htm! -!Parser commentStamp: 'jmv 10/22/2019 16:56:12' prior: 16885486! - I parse Smalltalk syntax and create a MethodNode that is the root of the parse tree. I look one token ahead. - -See http://www.whysmalltalk.com/articles/bykov/HitchHiker.htm! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3948-CompilerCommentTweak-JuanVuletich-2019Oct22-16h55m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3948] on 7 November 2019 at 5:58:12 pm'! - -LargePositiveInteger removeSelector: #timesRepeat:! - -!methodRemoval: LargePositiveInteger #timesRepeat: stamp: 'jmv 11/15/2019 09:45:32'! -timesRepeat: aBlock - "Evaluate the argument, aBlock, the number of times represented by the - receiver." - - | toGo thisRound | - toGo := self. - [toGo > 0] whileTrue: - [ - thisRound := toGo min: SmallInteger maxVal. - thisRound timesRepeat: aBlock. - toGo := toGo - thisRound - ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3949-LargeInteger-timesRepeat-toPerfImprovPck-JuanVuletich-2019Nov07-17h57m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3949] on 7 November 2019 at 7:30:54 pm'! -!MenuMorph methodsFor: 'modal control' stamp: 'jmv 11/7/2019 19:16:35' prior: 50340010! - invokeModal: allowKeyboardControl - "Invoke this menu and don't return until the user has chosen a value. If the allowKeyboarControl boolean is true, permit keyboard control of the menu - See senders of this method for finding out how to use modal menu morphs." - | w oldFocus actHand delay | - w _ self runningWorld. - actHand _ w activeHand. - oldFocus _ actHand keyboardFocus. - w doOneMinimalCycleNow. - self - popUpAt: actHand morphPosition - forHand: actHand - allowKeyboard: allowKeyboardControl. - self isModalInvokationDone: false. - delay _ Delay forSeconds: 0.1. - [ self isInWorld and: [self isModalInvokationDone not] ] whileTrue: [ w doOneMinimalCycleNow. delay wait ]. - self delete. - oldFocus ifNotNil: [ actHand newKeyboardFocus: oldFocus ]. - ^ self modalSelection! ! -!MVCMenuMorph methodsFor: 'invoking' stamp: 'jmv 11/7/2019 19:14:21' prior: 50395741! - invokeAt: aPoint allowKeyboard: aBoolean - "Add this menu to the given world centered at the given point. Wait for the user to make a selection and answer it. The selection value returned is an integer in keeping with PopUpMenu, if the menu is converted from an MVC-style menu." - "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop." - |actHand w oldFocus delay | - w _ self runningWorld. - actHand _ w activeHand. - oldFocus _ actHand keyboardFocus. - w doOneMinimalCycleNow. - self - popUpAt: aPoint - forHand: actHand - allowKeyboard: aBoolean. - done _ false. - delay _ Delay forSeconds: 0.1. - [ done not and: [self isInWorld] ] whileTrue: [ w doOneMinimalCycleNow. delay wait ]. - self delete. - oldFocus ifNotNil: [ actHand newKeyboardFocus: oldFocus ]. - ^ mvcSelection ! ! -!FillInTheBlankMorph methodsFor: 'invoking' stamp: 'jmv 11/7/2019 19:15:41' prior: 50340070! -getUserResponse - "Wait for the user to accept or cancel, and answer the result string. Answers the empty string if the user cancels." - "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop." - - | w delay | - w _ self world. - w isNil ifTrue: [^ response]. - done _ false. - textPane focusText. - delay _ Delay forSeconds: 0.1. - [done] whileFalse: [ w doOneMinimalCycleNow. delay wait ]. - self delete. - w doOneMinimalCycleNow. - ^ response -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3950-FixHighCPUUsageOnMenus-JuanVuletich-2019Nov07-19h30m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3944] on 31 October 2019 at 3:42:59 pm'! -!SystemDictionary methodsFor: 'image, changes name' stamp: 'HAW 10/31/2019 13:15:44' prior: 50478278! - defaultUserChangesName - "Answer the default full path to the changes file corresponding to the image file name." - " - Smalltalk defaultUserChangesName - " - ^(FileIOAccessor default baseNameFor: self imageName), '.user.changes'! ! - -Preferences class removeSelector: #userChangesFileName! - -!methodRemoval: Preferences class #userChangesFileName stamp: 'jmv 11/15/2019 09:45:32'! -userChangesFileName - ^ self - valueOfFlag: #userChangesFileName - ifAbsent: [ self defaultUserChangesFileName ].! - -Preferences class removeSelector: #defaultUserChangesFileName! - -!methodRemoval: Preferences class #defaultUserChangesFileName stamp: 'jmv 11/15/2019 09:45:32'! -defaultUserChangesFileName - "Answer the default full path to the changes file corresponding to the image file name." - - ^(FileIOAccessor default baseNameFor: Smalltalk imageName), '.user.changes'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3951-UserChangesFileName-HernanWilkinson-2019Oct31-13h15m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3944] on 1 November 2019 at 4:37:21 pm'! -!Preferences class methodsFor: 'user changes' stamp: 'HAW 10/31/2019 16:16:59'! - use: aFileExtension asUserChangesFileNameExtensionWhile: aBlock - - ^[ self parameters at: #userChangesFileNameExtension put: aFileExtension. - aBlock value ] ensure: [ self parameters removeKey: #userChangesFileNameExtension ifAbsent: [] ].! ! -!Preferences class methodsFor: 'user changes' stamp: 'HAW 10/31/2019 16:16:15'! - userChangesFileNameExtension - - ^self parameters at: #userChangesFileNameExtension ifAbsent: [ '.user.changes' ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3952-UserChangesFileExtention-HernanWilkinson-2019Oct31-15h42m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3944] on 1 November 2019 at 4:37:44 pm'! -!SystemDictionary methodsFor: 'image, changes name' stamp: 'HAW 11/1/2019 16:37:26' prior: 50481908! - defaultUserChangesName - "Answer the default full path to the changes file corresponding to the image file name." - " - Smalltalk defaultUserChangesName - " - ^(FileIOAccessor default baseNameFor: self imageName), - Preferences userChangesFileNameExtension ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3953-defaultUserChangesName-HernanWilkinson-2019Nov01-16h37m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3953] on 9 November 2019 at 10:47:28 am'! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'HAW 11/9/2019 10:35:24'! - definitionPreambleWithoutStamp - - ^'classDefinition: ', self name printString, ' category: ', self category printString! ! -!ChangeRecord methodsFor: 'testing' stamp: 'HAW 11/9/2019 10:44:49'! - isTestClassChange - - ^ isTest! ! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'HAW 11/9/2019 10:35:36' prior: 50481059! - definitionPreamble - - ^self definitionPreambleWithoutStamp, Utilities changeStampField! ! -!CodePackage methodsFor: 'saving' stamp: 'HAW 11/9/2019 10:41:04' prior: 16810555! - write: classes classDefinitionsOn: aStream - - classes - do: [ :class | - aStream - nextPut: $!!; nextChunkPut: class definitionPreambleWithoutStamp; newLine; - nextChunkPut: class definition; newLine; - - nextPut: $!!; nextChunkPut: class class definitionPreambleWithoutStamp; newLine; - nextChunkPut: class class definition; newLine; - - newLine ] - displayingProgress: 'Saving class definitions...'.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3954-ClassDefinitionWithoutTimeStampForPackage-HernanWilkinson-2019Nov09-10h34m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3953] on 9 November 2019 at 11:05:02 am'! -!MenuMorph methodsFor: 'modal control' stamp: 'HAW 11/9/2019 11:03:35' prior: 50481819! - invokeModal: allowKeyboardControl - "Invoke this menu and don't return until the user has chosen a value. If the allowKeyboarControl boolean is true, permit keyboard control of the menu - See senders of this method for finding out how to use modal menu morphs." - | w oldFocus actHand delay | - w _ self runningWorld. - actHand _ w activeHand. - oldFocus _ actHand keyboardFocus. - w doOneMinimalCycleNow. - self - popUpAt: actHand morphPosition - forHand: actHand - allowKeyboard: allowKeyboardControl. - self isModalInvokationDone: false. - delay _ Delay forMilliseconds: 10. - [ self isInWorld and: [self isModalInvokationDone not] ] whileTrue: [ w doOneMinimalCycleNow. delay wait ]. - self delete. - oldFocus ifNotNil: [ actHand newKeyboardFocus: oldFocus ]. - ^ self modalSelection! ! -!MVCMenuMorph methodsFor: 'invoking' stamp: 'HAW 11/9/2019 11:03:22' prior: 50481846! - invokeAt: aPoint allowKeyboard: aBoolean - "Add this menu to the given world centered at the given point. Wait for the user to make a selection and answer it. The selection value returned is an integer in keeping with PopUpMenu, if the menu is converted from an MVC-style menu." - "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop." - |actHand w oldFocus delay | - w _ self runningWorld. - actHand _ w activeHand. - oldFocus _ actHand keyboardFocus. - w doOneMinimalCycleNow. - self - popUpAt: aPoint - forHand: actHand - allowKeyboard: aBoolean. - done _ false. - delay _ Delay forMilliseconds: 10. - [ done not and: [self isInWorld] ] whileTrue: [ w doOneMinimalCycleNow. delay wait ]. - self delete. - oldFocus ifNotNil: [ actHand newKeyboardFocus: oldFocus ]. - ^ mvcSelection ! ! -!FillInTheBlankMorph methodsFor: 'invoking' stamp: 'HAW 11/9/2019 11:02:25' prior: 50481878! - getUserResponse - "Wait for the user to accept or cancel, and answer the result string. Answers the empty string if the user cancels." - "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop." - - | w delay | - w _ self world. - w isNil ifTrue: [^ response]. - done _ false. - textPane focusText. - delay _ Delay forMilliseconds: 10. - [done] whileFalse: [ w doOneMinimalCycleNow. delay wait. ]. - self delete. - w doOneMinimalCycleNow. - ^ response -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3955-FixHighCPUUsageOnMenusShorterDelay-HernanWilkinson-2019Nov09-10h47m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3955] on 9 November 2019 at 3:37:56 pm'! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'HAW 11/9/2019 15:35:45' prior: 16806760! - fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex - "File a description of the receiver on aFileStream. If the boolean - argument, moveSource, is true, then set the trailing bytes to the position - of aFileStream and to fileIndex in order to indicate where to find the - source code." - - aFileStream nextPut: $!!; nextChunkPut: self definitionPreambleWithoutStamp; newLine. - aFileStream nextChunkPut: self definition. - - self organization - putCommentOnFile: aFileStream - numbered: fileIndex - moveSource: moveSource - forClass: self. - self organization categories do: [ :heading | - self fileOutCategory: heading - on: aFileStream - moveSource: moveSource - toFile: fileIndex]! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 11/9/2019 15:35:19' prior: 16798519! - fileOutPSFor: class on: stream - "Write out removals and initialization for this class." - - | dict classRecord currentDef | - classRecord _ changeRecords at: class name ifAbsent: [^ self]. - dict _ classRecord methodChangeTypes. - ((dict includesKey: #initialize) and: [ class isMeta ]) ifTrue: [ - stream nextChunkPut: class soleInstance name, ' initialize'; newLine]. - ((classRecord includesChangeType: #change) - and: [(currentDef _ class definition) ~= (self fatDefForClass: class)]) ifTrue: [ - stream - nextPut: $!!; - nextChunkPut: class definitionPreambleWithoutStamp; newLine; - nextChunkPut: currentDef; newLine]. - (classRecord includesChangeType: #reorganize) ifTrue: [ - class fileOutOrganizationOn: stream. - stream newLine]! ! -!ChangeSet methodsFor: 'private' stamp: 'HAW 11/9/2019 15:37:00' prior: 16798678! - fileOutClassDefinition: class on: stream - "Write out class definition for the given class on the given stream, if the class definition was added or changed." - - (self atClass: class includes: #rename) ifTrue: [ - stream nextChunkPut: 'Smalltalk renameClassNamed: #', (self oldNameFor: class), ' as: #', class name; newLine]. - - (self atClass: class includes: #change) ifTrue: [ "fat definition only needed for changes" - stream - nextPut: $!!; nextChunkPut: class definitionPreambleWithoutStamp; newLine; - nextChunkPut: (self fatDefForClass: class); newLine. - ] ifFalse: [ - (self atClass: class includes: #add) ifTrue: [ "use current definition for add" - stream - nextPut: $!!; nextChunkPut: class definitionPreambleWithoutStamp; newLine; - nextChunkPut: class definition; newLine. - ]. - ]. - - (self atClass: class includes: #comment) ifTrue: [ - class theNonMetaClass organization putCommentOnFile: stream numbered: 0 moveSource: false forClass: class theNonMetaClass. - stream newLine]. - -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3956-RemoveFileOutClassDefinitionStamp-HernanWilkinson-2019Nov09-15h33m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3956] on 12 November 2019 at 11:29:19 am'! - -Refactoring subclass: #PushDownMethod - instanceVariableNames: 'method' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #PushDownMethod category: #'Tools-Refactoring' stamp: 'jmv 11/15/2019 09:45:32'! -Refactoring subclass: #PushDownMethod - instanceVariableNames: 'method' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 11/12/2019 11:25:59'! - pushDownSelector - - model selectedMessageName ifNotNil: [ :selectedSelector | - (PushDownMethod for: model selectedClassOrMetaClass>>selectedSelector) apply. - model reformulateList. - model changed: #messageList. - model setClassOrganizer ].! ! -!PushDownMethod methodsFor: 'initialization' stamp: 'HAW 11/12/2019 11:26:37'! - initializeFor: aMethodToPushDown - - method := aMethodToPushDown ! ! -!PushDownMethod methodsFor: 'applying' stamp: 'HAW 11/12/2019 11:27:19'! - apply - - | methodCategory | - - methodCategory := method methodClass organization categoryOfElement: method selector. - method methodClass subclassesDo: [:subClass | - subClass - compile: method sourceCode - classified: methodCategory. - ]. - - method methodClass removeSelector: method selector. - ! ! -!PushDownMethod class methodsFor: 'instance creation' stamp: 'HAW 11/12/2019 11:26:28'! - for: aMethodToPushDown - - ^self new initializeFor: aMethodToPushDown ! ! -!RefactoringMenues class methodsFor: 'browser menues' stamp: 'HAW 11/12/2019 11:28:03' prior: 50448121! - messsageRefactoringMenuOptions - - ^ `{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'rename... (R)'. - #selector -> #renameSelector. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 15. - #label -> 'change keyword order...'. - #selector -> #changeKeywordOrder. - #icon -> #sendReceiveIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'add parameter...'. - #selector -> #addParameter. - #icon -> #listAddIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'remove parameter...'. - #selector -> #removeParameter. - #icon -> #listRemoveIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'push up'. - #selector -> #pushUpSelector. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 50. - #label -> 'push down'. - #selector -> #pushDownSelector. - #icon -> #goBottomIcon - } asDictionary. - }`. - - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3957-PushDownRefactoring-HernanWilkinson-2019Nov12-08h51m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3956] on 12 November 2019 at 11:49:46 am'! - -Refactoring subclass: #PushUpMethod - instanceVariableNames: 'method' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #PushUpMethod category: #'Tools-Refactoring' stamp: 'jmv 11/15/2019 09:45:32'! -Refactoring subclass: #PushUpMethod - instanceVariableNames: 'method' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #PushUpMethodApplier - instanceVariableNames: 'browser methodToPushUp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #PushUpMethodApplier category: #'Tools-Refactoring' stamp: 'jmv 11/15/2019 09:45:32'! -RefactoringApplier subclass: #PushUpMethodApplier - instanceVariableNames: 'browser methodToPushUp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!CompiledMethod methodsFor: 'testing' stamp: 'MSC 10/14/2019 13:44:00'! - accessesInstanceVariable: aName - - ^(self readsInstanceVariable: aName) or: [self writesInstanceVariable: aName].! ! -!PushUpMethod class methodsFor: 'pre-conditions' stamp: 'HAW 11/12/2019 11:30:59'! - assertIsNotAccessingInstanceVariable: aMethodToPushUp - - aMethodToPushUp methodClass instVarNames - do: [ :instVarName | - (aMethodToPushUp accessesInstanceVariable: instVarName) ifTrue: [self signalMethodCannotAccessInstanceVariable]].! ! -!PushUpMethod class methodsFor: 'pre-conditions' stamp: 'MSC 10/14/2019 20:57:57'! - assertIsValidToPushUpMethod: aMethodToPushUp - - self assertIsNotAccessingInstanceVariable: aMethodToPushUp. -! ! -!PushUpMethod class methodsFor: 'warnings' stamp: 'MSC 10/19/2019 23:33:15'! - warnIfExistMethodToPushUpOnSuperClass: aMethodToPushUp - - ((aMethodToPushUp methodClass superclass) methodDict includesKey: aMethodToPushUp selector) - ifTrue: [self refactoringWarning: self warningMesssageForExistMethodToPushUpOnSuperClass ].! ! -!PushUpMethod class methodsFor: 'warnings' stamp: 'MSC 10/19/2019 22:41:32'! - warnIsValidToPushUpMethod: aMethodToPushUp - - self warnIfExistMethodToPushUpOnSuperClass: aMethodToPushUp. -! ! -!PushUpMethod class methodsFor: 'warnings' stamp: 'HAW 11/12/2019 11:39:38'! - warningMesssageForExistMethodToPushUpOnSuperClass - - ^'Method already exist in superclass'. - - ! ! -!PushUpMethod class methodsFor: 'exceptions' stamp: 'HAW 11/12/2019 11:38:58'! - errorMessageForMethodCannotAccessInstanceVariable - - ^ 'Can not push up a method that access an instance variable'! ! -!PushUpMethod class methodsFor: 'exceptions' stamp: 'MSC 10/19/2019 23:29:03'! - signalMethodCannotAccessInstanceVariable - - self refactoringError: self errorMessageForMethodCannotAccessInstanceVariable! ! -!PushUpMethodApplier methodsFor: 'initialization' stamp: 'MSC 10/14/2019 13:09:53'! - initializeOn: aBrowser for: aMethodToPushUp - - browser := aBrowser. - methodToPushUp := aMethodToPushUp.! ! -!PushUpMethodApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 11/12/2019 11:41:50'! - requestRefactoringParameters - - ! ! -!PushUpMethodApplier methodsFor: 'refactoring - creation' stamp: 'MSC 10/14/2019 19:37:02'! - createRefactoring - - ^self refactoringClass for: methodToPushUp.! ! -!PushUpMethodApplier methodsFor: 'refactoring - creation' stamp: 'MSC 10/14/2019 19:36:48'! - refactoringClass - - ^PushUpMethod! ! -!PushUpMethodApplier methodsFor: 'refactoring - changes' stamp: 'MSC 10/14/2019 13:10:22'! - informChangesToBrowser - - | classMethod | - - classMethod := methodToPushUp methodClass asString. - - browser classListIndex: (browser classListIndexOf: classMethod).! ! -!PushUpMethodApplier methodsFor: 'refactoring - changes' stamp: 'MSC 10/14/2019 13:09:46'! - showChanges - - self informChangesToBrowser.! ! -!PushUpMethodApplier class methodsFor: 'instance creation' stamp: 'MSC 10/14/2019 12:11:10'! - on: aBrowser for: aMethodToPushUp - - ^self new initializeOn: aBrowser for: aMethodToPushUp ! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 11/12/2019 11:44:45' prior: 50451684! - pushUpSelector - - model selectedMessageName ifNotNil: [ :selectedSelector | - (PushUpMethodApplier on: model for: model selectedClassOrMetaClass>>selectedSelector) value ].! ! -!PushUpMethod methodsFor: 'initialization' stamp: 'HAW 8/18/2018 11:44:09' prior: 50440565! - initializeFor: aMethodToPushup - - method := aMethodToPushup ! ! -!PushUpMethod methodsFor: 'applying' stamp: 'HAW 3/4/2019 15:23:40' prior: 50443982! - apply - - | methodCategory | - - methodCategory := method methodClass organization categoryOfElement: method selector. - method methodClass superclass - compile: method sourceCode - classified: methodCategory. - - method methodClass removeSelector: method selector. - ! ! -!PushUpMethod class methodsFor: 'instance creation' stamp: 'MSC 10/19/2019 22:42:30' prior: 50440582! - for: aMethodToPushUp - - self assertIsValidToPushUpMethod: aMethodToPushUp. - self warnIsValidToPushUpMethod: aMethodToPushUp. - - ^self new initializeFor: aMethodToPushUp! ! - -PushUpMethodApplier removeSelector: #askConfirmation! - -PushUpMethodApplier removeSelector: #confirmationMessageText! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3958-PushUpImprovement-HernanWilkinson-2019Nov12-11h30m-HAW.1.cs.st----! - -----SNAPSHOT----(15 November 2019 09:45:37) Cuis5.0-3958-v3.image priorSource: 4530662! - -----QUIT----(15 November 2019 09:45:51) Cuis5.0-3958-v3.image priorSource: 4826496! - -----STARTUP---- (15 November 2019 10:08:47) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-3958-v3.image! - - -'From Cuis 5.0 [latest update: #3958] on 15 November 2019 at 10:06:34 am'! -!ChangeSet class methodsFor: 'change set to use' stamp: 'jmv 11/15/2019 10:06:10'! - installingString - ^Installing ! ! -!Utilities class methodsFor: 'identification' stamp: 'jmv 11/15/2019 10:02:06' prior: 16940644! - authorInitials - "Answer the initials to be used to identify the current code author. " - " - Utilities clearAuthor; authorInitials - " - ChangeSet notInstallOrTestRun ifFalse: [ - ^ ChangeSet installingString ]. - - [AuthorInitials isNil or: [AuthorInitials isEmpty]] whileTrue: [self setAuthor]. - ^ AuthorInitials! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3959-DontAskInitialsForPackageInstall-JuanVuletich-2019Nov15-10h06m-jmv.1.cs.st----! - -----SNAPSHOT----(15 November 2019 10:08:55) Cuis5.0-3959-v3.image priorSource: 4826585! - -----QUIT----(15 November 2019 10:09:01) Cuis5.0-3959-v3.image priorSource: 4827623! - -----STARTUP---- (15 November 2019 10:09:07) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-3959-v3.image! - - -----QUIT----(15 November 2019 10:09:15) Cuis5.0-3959-v3.image priorSource: 4827712! - -----STARTUP---- (11 January 2020 17:58:43) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-3959-v3.image! - - -'From Cuis 5.0 [latest update: #3958] on 16 November 2019 at 1:10:59 pm'! -!NewInstanceVariablePrecondition methodsFor: 'evaluating' stamp: 'HAW 11/13/2019 20:46:26'! - valueForSuperclass - - self assertIsNotEmpty. - self assertIsNotAReservedName. - self assertIsValidInstanceVariableName. - self assertIsNotAlreadyDefinedInSuperclasses. - - ! ! -!NewInstanceVariablePrecondition methodsFor: 'pre-conditions' stamp: 'HAW 11/13/2019 20:47:54'! - assertIsNotAlreadyDefinedInSuperclasses - - ^ (classToAddInstVar classThatDefinesInstanceVariable: instVarName) - ifNotNil: [ :definingClasses | self signalAlreadyDefinedInAll: definingClasses ] - ! ! -!NewInstanceVariablePrecondition methodsFor: 'pre-conditions' stamp: 'HAW 11/13/2019 20:43:43'! - assertIsNotDefinedInMethods - - | methodsDefiningNewVariable | - - methodsDefiningNewVariable := self methodsDefiningNewVariable. - - methodsDefiningNewVariable notEmpty ifTrue: [ self signalNewVariable: instVarName willBeHiddenAtAll: methodsDefiningNewVariable ].! ! -!ParseNodeVisitor methodsFor: 'visiting' stamp: 'HAW 11/16/2019 13:09:55' prior: 16885384! - visitMessageNode: aMessageNode - - aMessageNode receiver accept: self. - aMessageNode selector accept: self. - aMessageNode argumentsInEvaluationOrder do: [:argument| argument accept: self]! ! -!NewInstanceVariablePrecondition methodsFor: 'evaluating' stamp: 'HAW 11/13/2019 20:43:43' prior: 50444658! - value - - self assertIsNotEmpty. - self assertIsNotAReservedName. - self assertIsValidInstanceVariableName. - self assertIsNotAlreadyDefined. - - self assertIsNotDefinedInMethods.! ! - -NewInstanceVariablePrecondition removeSelector: #assertIsDefinedInMethods! - -!methodRemoval: NewInstanceVariablePrecondition #assertIsDefinedInMethods stamp: 'Install-3960-NewInstVarPreconditionForSuperclass-HernanWilkinson-2019Nov12-15h55m-HAW.1.cs.st 1/11/2020 17:58:48'! -assertIsDefinedInMethods - - | methodsDefiningNewVariable | - - methodsDefiningNewVariable := self methodsDefiningNewVariable. - - methodsDefiningNewVariable notEmpty ifTrue: [ self signalNewVariable: instVarName willBeHiddenAtAll: methodsDefiningNewVariable ].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3960-NewInstVarPreconditionForSuperclass-HernanWilkinson-2019Nov12-15h55m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3958] on 25 November 2019 at 2:49:34 pm'! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 11/25/2019 14:47:40' prior: 50452426! - contextualRenameInClassDefinitionOf: aClassDefinitionNode in: aSelectedClass - - | analyzer cursorPosition | - - analyzer := ClassDefinitionNodeAnalyzer for: aClassDefinitionNode. - cursorPosition := self startIndex. - - (analyzer isAtSuperclass: cursorPosition) - ifTrue: [ ^self renameClassOn: self codeProvider for: analyzer superclass ]. - - (analyzer isAtClassName: cursorPosition) - ifTrue: [ ^self renameClassOn: self codeProvider for: aSelectedClass ]. - - (analyzer isAtInstanceVariables: cursorPosition) - ifTrue: [ |selection variableToRename| - selection := self selectedString. - variableToRename := selection isEmpty ifTrue: [ self wordUnderCursor ] ifFalse: [ selection ]. - ^self renameInstanceVariableOn: self codeProvider for: variableToRename at: aSelectedClass ]. - - (analyzer isAtCategory: cursorPosition) - ifTrue: [ - "I'm sure codeProvider is a Browser - Hernan" - ^self codeProvider renameSystemCategory ]. - - morph flash - -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3961-SelectedInstVarRenameOnClassDefinitionFix-HernanWilkinson-2019Nov25-14h45m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3958] on 27 November 2019 at 4:38:55 pm'! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 8/18/2018 16:30:01' prior: 50439233! - assertIsValidKeywordForNewParameter: aNewKeyword - - (aNewKeyword isKeyword and: [aNewKeyword numArgs = 1 ]) ifFalse: [ self signalNotValidKeywordForNewParameter]! ! -!AddParameter class methodsFor: 'exceptions' stamp: 'HAW 11/27/2019 16:26:50' prior: 50439409! - notValidKeywordForNewParameterErrorMessage - - ^'New keyword can not be unary or binary. It has to be a keyword with one parameter'! ! -!AddParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 11/27/2019 16:34:16' prior: 50441838! - askNewKeyword - - | enteredString | - - enteredString := (self request: 'Enter keyword for new parameter') withBlanksTrimmed. - (enteredString endsWith: ':') ifFalse: [ enteredString := enteredString, ':' ]. - newKeyword := enteredString asSymbol. - self refactoringClass assertIsValidKeywordForNewParameter: newKeyword! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3962-CuisCore-HernanWilkinson-2019Nov27-16h25m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3962] on 4 December 2019 at 11:18:08 am'! - -RefactoringApplier subclass: #RenameClassApplier - instanceVariableNames: 'browser classToRename newClassName ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameClassApplier category: #'Tools-Refactoring' stamp: 'Install-3963-RenameClassLogAndRefreshFix-HernanWilkinson-2019Dec03-16h25m-HAW.1.cs.st 1/11/2020 17:58:48'! -RefactoringApplier subclass: #RenameClassApplier - instanceVariableNames: 'browser classToRename newClassName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!Browser methodsFor: 'class list' stamp: 'HAW 12/4/2019 10:43:04'! - originalSelectedClassName - "Returns the selectedClassName no matter if it exits or not. - It is used for refreshing the browser when renaming a class - Hernan" - - ^selectedClassName! ! -!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'HAW 12/3/2019 18:08:42'! - aboutToRenameClass: aClass from: oldClassName to: newClassName inCategory: aCategoryName - - self - triggerEvent: #aboutToRenameClass - withArguments: { aClass . oldClassName . newClassName . aCategoryName }! ! -!SystemChangeNotifier methodsFor: 'system triggers' stamp: 'HAW 12/3/2019 18:09:31' prior: 16919116! - classRenamed: aClass from: oldClassName to: newClassName inCategory: aCategoryName - - self - triggerEvent: #classRenamed - withArguments: { aClass . oldClassName . newClassName . aCategoryName }! ! -!SystemDictionary methodsFor: 'class names' stamp: 'HAW 12/4/2019 10:54:31'! - prepareToRenameClass: aClass as: newName - - ^self prepareToRenameClass: aClass from: aClass name to: newName! ! -!SystemDictionary methodsFor: 'class names' stamp: 'HAW 12/4/2019 10:54:28'! - prepareToRenameClass: aClass from: oldName to: newName - - "Rename the class, aClass, to have the title newName." - - | oldref i category | - - category := SystemOrganization categoryOfElement: oldName. - SystemOrganization classify: newName under: category. - SystemOrganization removeElement: oldName. - oldref _ self associationAt: oldName. - self removeKey: oldName. - oldref key: newName. - self add: oldref. "Old association preserves old refs" - (Array with: StartUpList with: ShutDownList) do: - [:list | i _ list indexOf: aClass name ifAbsent: [0]. - i > 0 ifTrue: [list at: i put: newName]]. - self flushClassNameCache. - - SystemChangeNotifier uniqueInstance aboutToRenameClass: aClass from: oldName to: newName inCategory: category. - ! ! -!SystemDictionary methodsFor: 'class names' stamp: 'HAW 12/3/2019 18:11:03'! - renamedClass: aClass from: oldName - - | newName | - - newName := aClass name. - - SystemChangeNotifier uniqueInstance classRenamed: aClass from: oldName to: newName inCategory: aClass category. - Smalltalk - logChange: 'Smalltalk renameClassNamed: #', oldName, ' as: #', newName - preamble: 'classRenamed: #', oldName, ' as: #', newName, Utilities changeStampField! ! -!CodeWindow methodsFor: 'updating' stamp: 'HAW 12/3/2019 17:05:07'! - classRenamed: aClass from: oldClassName to: newClassName inCategory: aCategoryName - - "Do nothing here. Subclasses should implement if necessary - Hernan"! ! -!CodeWindow methodsFor: 'notification actions' stamp: 'HAW 12/4/2019 11:01:38'! - initializeNotificationActions - - "Avoid double registration" - self - removeNotificationActions; - registerNotificationActionsIfModelNotNil -! ! -!CodeWindow methodsFor: 'notification actions' stamp: 'HAW 12/4/2019 11:02:26'! -registerNotificationActions - - SystemChangeNotifier uniqueInstance - when: #classAdded send: #updateListsAndCode to: self; - when: #classCommented send: #updateListsAndCode to: self; - when: #classDefinitionChanged send: #updateListsAndCode to: self; - when: #classRecategorized send: #updateListsAndCode to: self; - when: #classRemoved send: #updateListsAndCode to: self; - when: #classRenamed send: #classRenamed:from:to:inCategory: to: self; - when: #classReorganized send: #updateListsAndCode to: self; - when: #methodAdded send: #updateListsAndCode to: self; - when: #methodAddedInProtocol send: #updateListsAndCode to: self; - when: #methodChanged send: #updateListsAndCode to: self; - when: #methodRemoved send: #updateListsAndCode to: self; - when: #selectorRecategorized send: #updateListsAndCode to: self ! ! -!CodeWindow methodsFor: 'notification actions' stamp: 'HAW 12/4/2019 11:02:39'! - registerNotificationActionsIfModelNotNil - - "model set to nil on delete" - model ifNotNil: [ self registerNotificationActions ] ! ! -!CodeWindow methodsFor: 'notification actions' stamp: 'HAW 12/4/2019 11:01:04'! - removeNotificationActions - - SystemChangeNotifier uniqueInstance removeActionsWithReceiver: self. -! ! -!BrowserWindow methodsFor: 'updating' stamp: 'HAW 12/4/2019 10:41:57'! - classRenamed: aClass from: oldClassName to: newClassName inCategory: aCategoryName - - | currentSelectedClass | - - self canDiscardEdits ifTrue: [ - self model selectedSystemCategoryName = aCategoryName ifTrue: [ - currentSelectedClass := self model selectedClass. - currentSelectedClass ifNil: [ - self model originalSelectedClassName = oldClassName ifTrue: [ - currentSelectedClass := aClass ]]. - - self model changed: #classList. - self model selectClass: currentSelectedClass ]]! ! -!DebuggerWindow methodsFor: 'notification actions' stamp: 'HAW 12/4/2019 11:09:30'! - registerNotificationActions - - super registerNotificationActions. - model when: #closeViews send: #closeView to: self ! ! -!PreDebugWindow methodsFor: 'notification actions' stamp: 'HAW 12/4/2019 11:09:19'! - registerNotificationActions - - super registerNotificationActions. - model when: #closeViews send: #closeView to: self ! ! -!ChangeSet methodsFor: 'system change notifications' stamp: 'HAW 12/3/2019 18:06:13'! - aboutToRenameClass: aClass from: oldClassName to: newClassName inCategory: aCategoryName - - self noteRenameClass: aClass as: newClassName! ! -!ChangeSet class methodsFor: 'class initialization' stamp: 'HAW 12/4/2019 10:48:12'! - initializeNotificationActions - - "Avoid double registration" - self - removeNotificationActions; - registerNotificationActions ! ! -!ChangeSet class methodsFor: 'class initialization' stamp: 'HAW 12/4/2019 11:09:58'! - registerNotificationActions - - "Only sent when model is not nil - Hernan" - SystemChangeNotifier uniqueInstance - when: #classAdded send: #classAdded:inCategory: to: self; - when: #classCommented send: #classCommented: to: self; - when: #classDefinitionChanged send: #classDefinitionChangedFrom:to: to: self; - when: #classRecategorized send: #classRecategorized:from:to: to: self; - when: #classRemoved send: #classRemoved:fromCategory: to: self; - when: #aboutToRenameClass send: #aboutToRenameClass:from:to:inCategory: to: self; - when: #classReorganized send: #classReorganized: to: self; - when: #methodAdded send: #methodAdded:selector:inClass:requestor: to: self; - when: #methodAddedInProtocol send: #methodAdded:selector:inProtocol:class:requestor: to: self; - when: #methodChanged send: #methodChangedFrom:to:selector:inClass:requestor: to: self; - when: #methodRemoved send: #methodRemoved:selector:inProtocol:class: to: self; - when: #selectorRecategorized send: #selectorRecategorized:from:to:inClass: to: self! ! -!ChangeSet class methodsFor: 'class initialization' stamp: 'HAW 12/4/2019 10:47:36'! - removeNotificationActions - - SystemChangeNotifier uniqueInstance removeActionsWithReceiver: self. - - ! ! -!ChangeSet class methodsFor: 'system change notifications' stamp: 'HAW 12/3/2019 18:06:45'! - aboutToRenameClass: aClass from: oldClassName to: newClassName inCategory: aCategoryName - - | packageOrNil | - packageOrNil _ CodePackage - packageOfSystemCategory: aCategoryName ifNone: nil. - (self changeSetForPackage: packageOrNil) ifNotNil: [ :changeSet | - changeSet - aboutToRenameClass: aClass - from: oldClassName - to: newClassName - inCategory: aCategoryName ]. - packageOrNil ifNotNil: [ - packageOrNil hasUnsavedChanges: true ]! ! -!RenameClassApplier methodsFor: 'initialization' stamp: 'HAW 12/3/2019 17:58:34'! - initializeFor: aClass - - classToRename := aClass. - ! ! -!RenameClassApplier class methodsFor: 'instance creation' stamp: 'HAW 12/3/2019 17:58:52'! - for: aClass - - ^self new initializeFor: aClass! ! -!Browser methodsFor: 'refactorings' stamp: 'HAW 12/3/2019 17:59:08' prior: 50442931! - renameClass - - self selectedClassOrMetaClass ifNotNil: [ :aBehavior | - (RenameClassApplier for: aBehavior theNonMetaClass) value ].! ! -!Class methodsFor: 'class name' stamp: 'HAW 12/4/2019 10:54:09' prior: 50443109! - safeRenameTo: newName - - | oldName | - - oldName := name. - Smalltalk prepareToRenameClass: self as: newName. - name _ newName. - Smalltalk renamedClass: self from: oldName! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 12/3/2019 17:59:14' prior: 50443773! - renameClassOn: aBrowser for: aClassToRefactor - - (RenameClassApplier for: aClassToRefactor) value! ! -!CodeWindow methodsFor: 'initialization' stamp: 'HAW 12/4/2019 11:04:33' prior: 16813837! - model: anObject - "Set my model and make me me a dependent of the given object." - - super model: anObject. - - self initializeNotificationActions! ! -!ChangeSet class methodsFor: 'class initialization' stamp: 'HAW 12/4/2019 10:47:19' prior: 16798835! - initialize - " - ChangeSet initialize - " - AllChangeSets _ OrderedCollection new. - - self initializeNotificationActions! ! -!RenameClassApplier methodsFor: 'refactoring - changes' stamp: 'HAW 12/3/2019 17:57:58' prior: 50442163! - showChanges - - self openChangedMethods -! ! - -RenameClassApplier class removeSelector: #on:for:! - -!methodRemoval: RenameClassApplier class #on:for: stamp: 'Install-3963-RenameClassLogAndRefreshFix-HernanWilkinson-2019Dec03-16h25m-HAW.1.cs.st 1/11/2020 17:58:48'! -on: aBrowser for: aClass - - ^self new initializeOn: aBrowser for: aClass! - -RenameClassApplier removeSelector: #initializeOn:for:! - -!methodRemoval: RenameClassApplier #initializeOn:for: stamp: 'Install-3963-RenameClassLogAndRefreshFix-HernanWilkinson-2019Dec03-16h25m-HAW.1.cs.st 1/11/2020 17:58:48'! -initializeOn: aBrowser for: aClass - - browser := aBrowser. - classToRename := aClass. - ! - -RenameClassApplier removeSelector: #informChangesToBrowser! - -!methodRemoval: RenameClassApplier #informChangesToBrowser stamp: 'Install-3963-RenameClassLogAndRefreshFix-HernanWilkinson-2019Dec03-16h25m-HAW.1.cs.st 1/11/2020 17:58:48'! -informChangesToBrowser - - browser changed: #classList. - browser selectClass: classToRename. -! - -ChangeSet class removeSelector: #classRenamed:from:to:inCategory:! - -!methodRemoval: ChangeSet class #classRenamed:from:to:inCategory: stamp: 'Install-3963-RenameClassLogAndRefreshFix-HernanWilkinson-2019Dec03-16h25m-HAW.1.cs.st 1/11/2020 17:58:48'! -classRenamed: aClass from: oldClassName to: newClassName inCategory: aCategoryName - - | packageOrNil | - packageOrNil _ CodePackage - packageOfSystemCategory: aCategoryName ifNone: nil. - (self changeSetForPackage: packageOrNil) ifNotNil: [ :changeSet | - changeSet - classRenamed: aClass - from: oldClassName - to: newClassName - inCategory: aCategoryName ]. - packageOrNil ifNotNil: [ - packageOrNil hasUnsavedChanges: true ]! - -ChangeSet removeSelector: #classRenamed:from:to:inCategory:! - -!methodRemoval: ChangeSet #classRenamed:from:to:inCategory: stamp: 'Install-3963-RenameClassLogAndRefreshFix-HernanWilkinson-2019Dec03-16h25m-HAW.1.cs.st 1/11/2020 17:58:48'! -classRenamed: aClass from: oldClassName to: newClassName inCategory: aCategoryName - - self noteRenameClass: aClass as: newClassName! - -PreDebugWindow removeSelector: #model:! - -!methodRemoval: PreDebugWindow #model: stamp: 'Install-3963-RenameClassLogAndRefreshFix-HernanWilkinson-2019Dec03-16h25m-HAW.1.cs.st 1/11/2020 17:58:48'! -model: aDebugger - super model: aDebugger. - aDebugger ifNotNil: [ - aDebugger when: #closeViews send: #closeView to: self ]! - -DebuggerWindow removeSelector: #model:! - -!methodRemoval: DebuggerWindow #model: stamp: 'Install-3963-RenameClassLogAndRefreshFix-HernanWilkinson-2019Dec03-16h25m-HAW.1.cs.st 1/11/2020 17:58:48'! -model: aDebugger - super model: aDebugger. - aDebugger ifNotNil: [ - aDebugger when: #closeViews send: #closeView to: self ]! - -SystemDictionary removeSelector: #renamedClass:from:to:! - -SystemDictionary removeSelector: #renameClass:from:to:! - -!methodRemoval: SystemDictionary #renameClass:from:to: stamp: 'Install-3963-RenameClassLogAndRefreshFix-HernanWilkinson-2019Dec03-16h25m-HAW.1.cs.st 1/11/2020 17:58:48'! -renameClass: aClass from: oldName to: newName - "Rename the class, aClass, to have the title newName." - | oldref i category | - category := SystemOrganization categoryOfElement: oldName. - SystemOrganization classify: newName under: category. - SystemOrganization removeElement: oldName. - oldref _ self associationAt: oldName. - self removeKey: oldName. - oldref key: newName. - self add: oldref. "Old association preserves old refs" - (Array with: StartUpList with: ShutDownList) do: - [:list | i _ list indexOf: aClass name ifAbsent: [0]. - i > 0 ifTrue: [list at: i put: newName]]. - self flushClassNameCache. - SystemChangeNotifier uniqueInstance classRenamed: aClass from: oldName to: newName inCategory: category! - -SystemDictionary removeSelector: #renameClass:as:! - -!methodRemoval: SystemDictionary #renameClass:as: stamp: 'Install-3963-RenameClassLogAndRefreshFix-HernanWilkinson-2019Dec03-16h25m-HAW.1.cs.st 1/11/2020 17:58:48'! -renameClass: aClass as: newName - ^self renameClass: aClass from: aClass name to: newName! - -ChangeSet initialize! - -RefactoringApplier subclass: #RenameClassApplier - instanceVariableNames: 'classToRename newClassName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameClassApplier category: #'Tools-Refactoring' stamp: 'Install-3963-RenameClassLogAndRefreshFix-HernanWilkinson-2019Dec03-16h25m-HAW.1.cs.st 1/11/2020 17:58:48'! -RefactoringApplier subclass: #RenameClassApplier - instanceVariableNames: 'classToRename newClassName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -"Postscript: -Due to changes in the rename class notification, the ChangeSet and CodeWindows -must reinitialize the notification actions" -ChangeSet initializeNotificationActions. -CodeWindow allSubInstances do: [:aCodeWindow | aCodeWindow initializeNotificationActions ]. -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3963-RenameClassLogAndRefreshFix-HernanWilkinson-2019Dec03-16h25m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3963] on 4 December 2019 at 4:17:22 pm'! - -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser selectorsClasses possibleInvalidSelectors canShowSelectorDocumentation possibleBinarySendRange ' - classVariableNames: 'AccessLock EntriesLimit Selectors ' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #SmalltalkCompleter category: #'Tools-Autocompletion' stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser selectorsClasses possibleInvalidSelectors canShowSelectorDocumentation possibleBinarySendRange' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:16:53'! - computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:17:33'! - computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:11:59'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextModel methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:15:51'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:16:53'! - computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName - - textProvider computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName ! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:17:33'! - computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName - - textProvider computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName ! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:11:59'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - textProvider computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName ! ! -!PluggableTextModel methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:15:51'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - textProvider computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName ! ! -!Workspace methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:15:51'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - anAutocompleter computeMessageEntriesForClassOrNil: (self classOfBindingOf: aName) ! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:16:53'! - computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:17:33'! - computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:11:59'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!TextProvider methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:15:51'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:16:53'! - computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName - - self computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName ! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:17:33'! - computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName - - ^self computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName ! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:52:45'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - contextStackIndex = 0 - ifTrue: [ anAutocompleter computeMessageEntriesForUnknowClass ] - ifFalse: [ anAutocompleter computeMessageEntriesForClass: (self receiver instVarNamed: aName) class ]! ! -!Debugger methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:37:54'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - | context tempIndex | - - context := self selectedContext. - tempIndex := context tempNames indexOf: aName ifAbsent: [ ^ anAutocompleter computeMessageEntriesForUnknowClass ]. - - anAutocompleter computeMessageEntriesForClass: - (self debuggerMap namedTempAt: tempIndex in: context) class ! ! -!Inspector methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:37:55'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - anAutocompleter computeMessageEntriesForClass: (object instVarNamed: aName) class ! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:16:53'! - computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:17:33'! - computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:11:59'! - computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!ClassNameRequestMorph methodsFor: 'auto complete' stamp: 'HAW 12/4/2019 15:15:51'! - computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName - - anAutocompleter computeMessageEntriesForUnknowClass! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 12/4/2019 15:18:56'! - computeEntriesOfUnaryMessageReturnNamed: aSelector at: aRange - - self subclassResponsibility ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 12/4/2019 15:37:55'! - computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel - - | id rangeType | - - canShowSelectorDocumentation _ true. - id _ allSource copyFrom: range start to: range end. - rangeType _ range rangeType. - - rangeType == #globalVar - ifTrue: [ ^self computeMessageEntriesForClass: (Smalltalk at: id asSymbol) class ]. - rangeType == #self - ifTrue: [ ^self computeMessageEntriesForClass: contextClass ]. - rangeType == #super - ifTrue: [ ^self computeMessageEntriesForClass: contextClass superclass ]. - rangeType == #true - ifTrue: [ ^self computeMessageEntriesForClass: True ]. - rangeType == #false - ifTrue: [ ^self computeMessageEntriesForClass: False ]. - rangeType == #nil - ifTrue: [ ^self computeMessageEntriesForClass: UndefinedObject ]. - rangeType == #character - ifTrue: [ ^self computeMessageEntriesForClass: id first class ]. - rangeType == #number - ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #string - ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #symbol - ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #stringSymbol - ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #instVar - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofInstVarNamed: id ]. - rangeType == #methodArg - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofTempVarNamed: id ]. - rangeType == #tempVar - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofTempVarNamed: id ]. - rangeType == #blockArg - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofBlockArgNamed: id ]. - rangeType == #blockTempVar - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofBlockTempVarNamed: id ]. - rangeType == #workspaceVar - ifTrue: [ ^self computeMessageEntriesForClassOrNil: (specificModel classOfWorkspaceVarNamed: id) ]. - rangeType == #thisContext - ifTrue: [ ^self computeMessageEntriesForClass: (specificModel classOfThisContext) ]. - rangeType == #classVar - ifTrue: [ ^self computeMessageEntriesForClassOrNil: (self classOfLocalBindingNamed: id in: contextClass) ]. - rangeType == #poolConstant - ifTrue: [ ^self computeMessageEntriesForClassOrNil: (self classOfLocalBindingNamed: id in: contextClass) ]. - rangeType == #blockEnd - ifTrue: [ ^self computeMessageEntriesForClass: BlockClosure ]. - rangeType == #arrayEnd - ifTrue: [ ^self computeMessageEntriesForClass: Array ]. - rangeType == #rightBrace - ifTrue: [ ^self computeMessageEntriesForClass: Array ]. - rangeType == #unary - ifTrue: [ ^self computeEntriesOfUnaryMessageReturnNamed: id at: range ]. - rangeType == #rightParenthesis - ifTrue: [ ^self computeMessageEntriesOfEnclosedExpressionReturnAt: range ]. - rangeType == #cascadeSeparator - ifTrue: [ ^self computeMessageEntriesOfCascadeReceiverAt: range ]. - - self computeMessageEntriesForUnknowClass - - ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 12/4/2019 15:37:54' prior: 50480282! - computeMessageEntriesForClass: aClass - - self isPreviousMessageSendBinary - ifTrue: [ self computeMessageEntriesWithBinaryMessageForClass: aClass ] - ifFalse: [ self computeMessageEntriesWithoutBinaryMessageForClass: aClass ]. - - self ifEmptyEntriesShowAllPrefixedSelectors! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 12/4/2019 15:37:55'! - computeMessageEntriesForClassOrNil: aClassOrNil - - aClassOrNil - ifNil: [ self computeMessageEntriesForUnknowClass ] - ifNotNil: [ self computeMessageEntriesForClass: aClassOrNil ]. - -! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 12/4/2019 15:20:04'! - computeMessageEntriesOfCascadeReceiverAt: aRange - - self subclassResponsibility ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 12/4/2019 15:19:35'! - computeMessageEntriesOfEnclosedExpressionReturnAt: aRange - - self subclassResponsibility ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 12/4/2019 15:37:14'! - computeMessageEntriesWithBinaryMessageForClass: aClass - - selectorsClasses := Array with: aClass. - - entries := (AutoCompleterSelectorsCollector for: prefix) - addUnaryAndBinarySelectorsOf: aClass; - entriesToShow! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 12/4/2019 15:36:49'! - computeMessageEntriesWithoutBinaryMessageForClass: aClass - - selectorsClasses := Array with: aClass. - - entries := (AutoCompleterSelectorsCollector for: prefix) - addSelectorsOf: aClass; - entriesToShow! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 12/4/2019 15:26:55'! - isPreviousMessageSendBinary - - ^possibleBinarySendRange notNil and: [ possibleBinarySendRange rangeType = #binary ]. - - ! ! -!DynamicTypingSmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 12/4/2019 15:18:56'! - computeEntriesOfUnaryMessageReturnNamed: aSelector at: aRange - - self computeMessageEntriesForUnknowClass - ! ! -!DynamicTypingSmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 12/4/2019 15:20:04'! - computeMessageEntriesOfCascadeReceiverAt: aRange - - self computeMessageEntriesForUnknowClass - -! ! -!DynamicTypingSmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 12/4/2019 15:19:35'! - computeMessageEntriesOfEnclosedExpressionReturnAt: aRange - - self computeMessageEntriesForUnknowClass - -! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 12/4/2019 15:25:10' prior: 50480490! - computeMessageEntriesWhenSendinMessageFor: allSource using: last3Ranges in: contextClass and: specificModel - - | prevRange | - - "If previous range is a constant or a well known identifier, we might filter messages" - prevRange _ last3Ranges second. - possibleBinarySendRange _ last3Ranges first. - - ^ (self canComputeMessageEntriesFor: prevRange ) - ifTrue: [ self computeMessageEntriesFor: allSource at: prevRange in: contextClass and: specificModel ] - ifFalse: [ self computeMessageEntriesForUnknowClass ] -! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 12/4/2019 15:25:10' prior: 50480341! - computeMessageEntriesWithEmptyPrefixFor: allSource using: last3Ranges at: range in: contextClass and: specificModel - - prefix _ ''. - possibleBinarySendRange _ last3Ranges second. - - self computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel .! ! - -DynamicTypingSmalltalkCompleter removeSelector: #computeMessageEntriesOfEnclosedExpressionReturnAt:with:! - -!methodRemoval: DynamicTypingSmalltalkCompleter #computeMessageEntriesOfEnclosedExpressionReturnAt:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -computeMessageEntriesOfEnclosedExpressionReturnAt: aRange with: possibleBinaryMessageSendRange - - self computeMessageEntriesForUnknowClass - -! - -DynamicTypingSmalltalkCompleter removeSelector: #computeMessageEntriesOfCascadeReceiverAt:with:! - -!methodRemoval: DynamicTypingSmalltalkCompleter #computeMessageEntriesOfCascadeReceiverAt:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -computeMessageEntriesOfCascadeReceiverAt: aRange with: possibleBinaryMessageSendRange - - self computeMessageEntriesForUnknowClass - -! - -DynamicTypingSmalltalkCompleter removeSelector: #computeEntriesOfUnaryMessageReturnNamed:at:with:! - -!methodRemoval: DynamicTypingSmalltalkCompleter #computeEntriesOfUnaryMessageReturnNamed:at:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -computeEntriesOfUnaryMessageReturnNamed: aSelector at: aRange with: possibleBinaryMessageSendRange - - self computeMessageEntriesForUnknowClass - ! - -SmalltalkCompleter removeSelector: #computeMessageEntriesForClass:with:! - -!methodRemoval: SmalltalkCompleter #computeMessageEntriesForClass:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -computeMessageEntriesForClass: aClass with: possibleBinaryMessageSendRange - - (self isBinaryMessageSend: possibleBinaryMessageSendRange) - ifTrue: [ self computeMessageEntriesForClass: aClass withPreviousBinaryMessageSend: possibleBinaryMessageSendRange ] - ifFalse: [ self computeMessageEntriesForClass: aClass ]. - - self ifEmptyEntriesShowAllPrefixedSelectors! - -SmalltalkCompleter removeSelector: #computeMessageEntriesWithPossibleBinaryMessageSendForClass:! - -SmalltalkCompleter removeSelector: #computeMessageEntriesOfCascadeReceiverAt:with:! - -!methodRemoval: SmalltalkCompleter #computeMessageEntriesOfCascadeReceiverAt:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -computeMessageEntriesOfCascadeReceiverAt: aRange with: possibleBinaryMessageSendRange - - self subclassResponsibility ! - -SmalltalkCompleter removeSelector: #computeMessageEntriesWithBinaryMessageSendForClass:withPreviousBinaryMessageSend:! - -SmalltalkCompleter removeSelector: #computeMessageEntriesForClassOrNil:with:! - -!methodRemoval: SmalltalkCompleter #computeMessageEntriesForClassOrNil:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -computeMessageEntriesForClassOrNil: aClassOrNil with: possibleBinaryMessageSendRange - - aClassOrNil - ifNil: [ self computeMessageEntriesForUnknowClass ] - ifNotNil: [ self computeMessageEntriesForClass: aClassOrNil with: possibleBinaryMessageSendRange ]. - -! - -SmalltalkCompleter removeSelector: #computeMessageEntriesOfEnclosedExpressionReturnAt:with:! - -!methodRemoval: SmalltalkCompleter #computeMessageEntriesOfEnclosedExpressionReturnAt:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -computeMessageEntriesOfEnclosedExpressionReturnAt: aRange with: possibleBinaryMessageSendRange - - self subclassResponsibility ! - -SmalltalkCompleter removeSelector: #computeMessageEntriesFor:at:in:and:with:! - -!methodRemoval: SmalltalkCompleter #computeMessageEntriesFor:at:in:and:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel with: possibleBinarySendRange - - | id rangeType | - - canShowSelectorDocumentation _ true. - id _ allSource copyFrom: range start to: range end. - rangeType _ range rangeType. - - rangeType == #globalVar - ifTrue: [ ^self computeMessageEntriesForClass: (Smalltalk at: id asSymbol) class with: possibleBinarySendRange ]. - rangeType == #self - ifTrue: [ ^self computeMessageEntriesForClass: contextClass with: possibleBinarySendRange ]. - rangeType == #super - ifTrue: [ ^self computeMessageEntriesForClass: contextClass superclass with: possibleBinarySendRange ]. - rangeType == #true - ifTrue: [ ^self computeMessageEntriesForClass: True with: possibleBinarySendRange ]. - rangeType == #false - ifTrue: [ ^self computeMessageEntriesForClass: False with: possibleBinarySendRange ]. - rangeType == #nil - ifTrue: [ ^self computeMessageEntriesForClass: UndefinedObject with: possibleBinarySendRange ]. - rangeType == #character - ifTrue: [ ^self computeMessageEntriesForClass: id first class with: possibleBinarySendRange ]. - rangeType == #number - ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) with: possibleBinarySendRange ]. - rangeType == #string - ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) with: possibleBinarySendRange ]. - rangeType == #symbol - ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) with: possibleBinarySendRange ]. - rangeType == #stringSymbol - ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) with: possibleBinarySendRange ]. - rangeType == #instVar - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofInstVarNamed: id with: possibleBinarySendRange ]. - rangeType == #methodArg - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofTempVarNamed: id with: possibleBinarySendRange ]. - rangeType == #tempVar - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofTempVarNamed: id with: possibleBinarySendRange ]. - rangeType == #blockArg - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofBlockArgNamed: id with: possibleBinarySendRange ]. - rangeType == #blockTempVar - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofBlockTempVarNamed: id with: possibleBinarySendRange ]. - rangeType == #workspaceVar - ifTrue: [ ^self computeMessageEntriesForClassOrNil: (specificModel classOfWorkspaceVarNamed: id) with: possibleBinarySendRange ]. - rangeType == #thisContext - ifTrue: [ ^self computeMessageEntriesForClass: (specificModel classOfThisContext) with: possibleBinarySendRange ]. - rangeType == #classVar - ifTrue: [ ^self computeMessageEntriesForClassOrNil: (self classOfLocalBindingNamed: id in: contextClass) with: possibleBinarySendRange ]. - rangeType == #poolConstant - ifTrue: [ ^self computeMessageEntriesForClassOrNil: (self classOfLocalBindingNamed: id in: contextClass) with: possibleBinarySendRange ]. - rangeType == #blockEnd - ifTrue: [ ^self computeMessageEntriesForClass: BlockClosure with: possibleBinarySendRange ]. - rangeType == #arrayEnd - ifTrue: [ ^self computeMessageEntriesForClass: Array with: possibleBinarySendRange ]. - rangeType == #rightBrace - ifTrue: [ ^self computeMessageEntriesForClass: Array with: possibleBinarySendRange ]. - rangeType == #unary - ifTrue: [ ^self computeEntriesOfUnaryMessageReturnNamed: id at: range with: possibleBinarySendRange ]. - rangeType == #rightParenthesis - ifTrue: [ ^self computeMessageEntriesOfEnclosedExpressionReturnAt: range with: possibleBinarySendRange ]. - rangeType == #cascadeSeparator - ifTrue: [ ^self computeMessageEntriesOfCascadeReceiverAt: range with: possibleBinarySendRange ]. - - self computeMessageEntriesForUnknowClass - - ! - -SmalltalkCompleter removeSelector: #computeMessageEntriesWithPossibleBinaryMessageSendForClass:with:! - -SmalltalkCompleter removeSelector: #computeMessageEntriesForClass:withPreviousBinaryMessageSend:! - -!methodRemoval: SmalltalkCompleter #computeMessageEntriesForClass:withPreviousBinaryMessageSend: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -computeMessageEntriesForClass: aClass withPreviousBinaryMessageSend: possibleBinaryMessageSendRange - - selectorsClasses := Array with: aClass. - - entries := (AutoCompleterSelectorsCollector for: prefix) - addUnaryAndBinarySelectorsOf: aClass; - entriesToShow! - -SmalltalkCompleter removeSelector: #isBinaryMessageSend:! - -!methodRemoval: SmalltalkCompleter #isBinaryMessageSend: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -isBinaryMessageSend: possibleBinaryMessageSendRange - - ^possibleBinaryMessageSendRange notNil and: [ possibleBinaryMessageSendRange rangeType = #binary ]. - - ! - -SmalltalkCompleter removeSelector: #computeMessageEntriesWithBinaryMessageSendForClass:! - -SmalltalkCompleter removeSelector: #isPreviousMessageSendBinary:! - -SmalltalkCompleter removeSelector: #computeEntriesOfUnaryMessageReturnNamed:at:with:! - -!methodRemoval: SmalltalkCompleter #computeEntriesOfUnaryMessageReturnNamed:at:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -computeEntriesOfUnaryMessageReturnNamed: aSelector at: aRange with: possibleBinaryMessageSendRange - - self subclassResponsibility ! - -ClassNameRequestMorph removeSelector: #computeMessageEntriesIn:ofBlockArgNamed:with:! - -!methodRemoval: ClassNameRequestMorph #computeMessageEntriesIn:ofBlockArgNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! - -ClassNameRequestMorph removeSelector: #computeMessageEntriesIn:ofTempVarNamed:with:! - -!methodRemoval: ClassNameRequestMorph #computeMessageEntriesIn:ofTempVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! - -ClassNameRequestMorph removeSelector: #computeMessageEntriesIn:ofBlockTempVarNamed:with:! - -!methodRemoval: ClassNameRequestMorph #computeMessageEntriesIn:ofBlockTempVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! - -ClassNameRequestMorph removeSelector: #computeMessageEntriesIn:ofInstVarNamed:with:! - -!methodRemoval: ClassNameRequestMorph #computeMessageEntriesIn:ofInstVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! - -Inspector removeSelector: #computeMessageEntriesIn:ofInstVarNamed:with:! - -!methodRemoval: Inspector #computeMessageEntriesIn:ofInstVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForClass: (object instVarNamed: aName) class with: possibleBinaryMessageSendRange ! - -Debugger removeSelector: #computeMessageEntriesIn:ofBlockArgNamed:with:! - -!methodRemoval: Debugger #computeMessageEntriesIn:ofBlockArgNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName with: possibleBinaryMessageSendRange - - self computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange -! - -Debugger removeSelector: #computeMessageEntriesIn:ofTempVarNamed:with:! - -!methodRemoval: Debugger #computeMessageEntriesIn:ofTempVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange - - | context tempIndex | - - context := self selectedContext. - tempIndex := context tempNames indexOf: aName ifAbsent: [ ^ anAutocompleter computeMessageEntriesForUnknowClass ]. - - anAutocompleter computeMessageEntriesForClass: (self debuggerMap namedTempAt: tempIndex in: context) class with: possibleBinaryMessageSendRange - - ! - -Debugger removeSelector: #computeMessageEntriesIn:ofBlockTempVarNamed:with:! - -!methodRemoval: Debugger #computeMessageEntriesIn:ofBlockTempVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName with: possibleBinaryMessageSendRange - - ^self computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange ! - -Debugger removeSelector: #computeMessageEntriesIn:ofInstVarNamed:with:! - -!methodRemoval: Debugger #computeMessageEntriesIn:ofInstVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName with: possibleBinaryMessageSendRange - - contextStackIndex = 0 - ifTrue: [ anAutocompleter computeMessageEntriesForUnknowClass ] - ifFalse: [ anAutocompleter computeMessageEntriesForClass: (self receiver instVarNamed: aName) class with: possibleBinaryMessageSendRange]! - -TextProvider removeSelector: #computeMessageEntriesIn:ofBlockArgNamed:with:! - -!methodRemoval: TextProvider #computeMessageEntriesIn:ofBlockArgNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! - -TextProvider removeSelector: #computeMessageEntriesIn:ofTempVarNamed:with:! - -!methodRemoval: TextProvider #computeMessageEntriesIn:ofTempVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! - -TextProvider removeSelector: #computeMessageEntriesIn:ofBlockTempVarNamed:with:! - -!methodRemoval: TextProvider #computeMessageEntriesIn:ofBlockTempVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! - -TextProvider removeSelector: #computeMessageEntriesIn:ofInstVarNamed:with:! - -!methodRemoval: TextProvider #computeMessageEntriesIn:ofInstVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! - -Workspace removeSelector: #computeMessageEntriesIn:ofTempVarNamed:with:! - -!methodRemoval: Workspace #computeMessageEntriesIn:ofTempVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForClassOrNil: (self classOfBindingOf: aName) with: possibleBinaryMessageSendRange! - -PluggableTextModel removeSelector: #computeMessageEntriesIn:ofBlockArgNamed:with:! - -!methodRemoval: PluggableTextModel #computeMessageEntriesIn:ofBlockArgNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName with: possibleBinaryMessageSendRange - - textProvider computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName with: possibleBinaryMessageSendRange -! - -PluggableTextModel removeSelector: #computeMessageEntriesIn:ofTempVarNamed:with:! - -!methodRemoval: PluggableTextModel #computeMessageEntriesIn:ofTempVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange - - textProvider computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange -! - -PluggableTextModel removeSelector: #computeMessageEntriesIn:ofBlockTempVarNamed:with:! - -!methodRemoval: PluggableTextModel #computeMessageEntriesIn:ofBlockTempVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName with: possibleBinaryMessageSendRange - - textProvider computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName with: possibleBinaryMessageSendRange! - -PluggableTextModel removeSelector: #computeMessageEntriesIn:ofInstVarNamed:with:! - -!methodRemoval: PluggableTextModel #computeMessageEntriesIn:ofInstVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName with: possibleBinaryMessageSendRange - - textProvider computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName with: possibleBinaryMessageSendRange -! - -TextModel removeSelector: #computeMessageEntriesIn:ofBlockArgNamed:with:! - -!methodRemoval: TextModel #computeMessageEntriesIn:ofBlockArgNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -computeMessageEntriesIn: anAutocompleter ofBlockArgNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! - -TextModel removeSelector: #computeMessageEntriesIn:ofTempVarNamed:with:! - -!methodRemoval: TextModel #computeMessageEntriesIn:ofTempVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -computeMessageEntriesIn: anAutocompleter ofTempVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! - -TextModel removeSelector: #computeMessageEntriesIn:ofBlockTempVarNamed:with:! - -!methodRemoval: TextModel #computeMessageEntriesIn:ofBlockTempVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -computeMessageEntriesIn: anAutocompleter ofBlockTempVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! - -TextModel removeSelector: #computeMessageEntriesIn:ofInstVarNamed:with:! - -!methodRemoval: TextModel #computeMessageEntriesIn:ofInstVarNamed:with: stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -computeMessageEntriesIn: anAutocompleter ofInstVarNamed: aName with: possibleBinaryMessageSendRange - - anAutocompleter computeMessageEntriesForUnknowClass! - -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser selectorsClasses possibleInvalidSelectors canShowSelectorDocumentation possibleBinarySendRange' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #SmalltalkCompleter category: #'Tools-Autocompletion' stamp: 'Install-3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st 1/11/2020 17:58:48'! -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser selectorsClasses possibleInvalidSelectors canShowSelectorDocumentation possibleBinarySendRange' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3964-AutoCompleteRefactoring-HernanWilkinson-2019Dec04-12h00m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3958] on 9 December 2019 at 1:56:57 am'! - -Refactoring subclass: #MoveToInstanceOrClassMethod - instanceVariableNames: 'methodToMove originalClass newClass' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #MoveToInstanceOrClassMethod category: #'Tools-Refactoring' stamp: 'Install-3965-MoveToInsClassSide-LeandroMartinYampolsky-2019Dec08-14h41m-LMY.1.cs.st 1/11/2020 17:58:48'! -Refactoring subclass: #MoveToInstanceOrClassMethod - instanceVariableNames: 'methodToMove originalClass newClass' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MoveToInstanceOrClassMethod class - instanceVariableNames: ''! - -!classDefinition: 'MoveToInstanceOrClassMethod class' category: #'Tools-Refactoring' stamp: 'Install-3965-MoveToInsClassSide-LeandroMartinYampolsky-2019Dec08-14h41m-LMY.1.cs.st 1/11/2020 17:58:48'! -MoveToInstanceOrClassMethod class - instanceVariableNames: ''! - -RefactoringApplier subclass: #MoveToInstanceOrClassMethodApplier - instanceVariableNames: 'browser methodToMove' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #MoveToInstanceOrClassMethodApplier category: #'Tools-Refactoring' stamp: 'Install-3965-MoveToInsClassSide-LeandroMartinYampolsky-2019Dec08-14h41m-LMY.1.cs.st 1/11/2020 17:58:48'! -RefactoringApplier subclass: #MoveToInstanceOrClassMethodApplier - instanceVariableNames: 'browser methodToMove' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!BrowserWindow methodsFor: 'refactorings' stamp: 'LMY 12/9/2019 00:34:31'! - moveToInstanceOrClassMethod - - model selectedMessageName ifNotNil: [ :selectedSelector | - (MoveToInstanceOrClassMethodApplier on: model for: model selectedClassOrMetaClass>>selectedSelector) value ].! ! -!MoveToInstanceOrClassMethod methodsFor: 'initialization' stamp: 'LMY 12/9/2019 00:01:14'! - initializeFor: aMethodToMove - - methodToMove := aMethodToMove. - originalClass := aMethodToMove methodClass. - newClass := aMethodToMove methodClass isMeta - ifTrue: [aMethodToMove methodClass soleInstance] - ifFalse: [aMethodToMove methodClass class]! ! -!MoveToInstanceOrClassMethod methodsFor: 'applying' stamp: 'LMY 12/9/2019 00:02:43'! - apply - - | methodCategory | - - methodCategory := originalClass organization categoryOfElement: methodToMove selector. - newClass - compile: methodToMove sourceCode - classified: methodCategory. - - originalClass removeSelector: methodToMove selector. - ! ! -!MoveToInstanceOrClassMethod class methodsFor: 'instance creation' stamp: 'LMY 12/8/2019 18:44:15'! - for: aMethodToMove - - self assertIsNotAccessingInstanceVariable: aMethodToMove. - self assertLocalVariableDoesNotConflictWithInstanceVariable: aMethodToMove. - - ^self new initializeFor: aMethodToMove ! ! -!MoveToInstanceOrClassMethod class methodsFor: 'exceptions' stamp: 'LMY 12/8/2019 18:42:50'! - localVariableConflictsWithInstanceVariableErrorMessage - - ^ 'Can not move a method that uses a local variable with same name as an instance variable'! ! -!MoveToInstanceOrClassMethod class methodsFor: 'exceptions' stamp: 'LMY 12/8/2019 17:58:30'! - referencingInstanceVariablesErrorMessage - - ^ 'Can not move a method that accesses an instance variable'! ! -!MoveToInstanceOrClassMethod class methodsFor: 'exceptions' stamp: 'LMY 12/8/2019 18:42:11'! - signalLocalVariableConflictsWithInstanceVariable - - self refactoringError: self localVariableConflictsWithInstanceVariableErrorMessage! ! -!MoveToInstanceOrClassMethod class methodsFor: 'exceptions' stamp: 'LMY 12/8/2019 17:58:37'! - signalMethodCannotAccessInstanceVariable - - self refactoringError: self referencingInstanceVariablesErrorMessage! ! -!MoveToInstanceOrClassMethod class methodsFor: 'pre-conditions' stamp: 'LMY 12/8/2019 17:56:44'! - assertIsNotAccessingInstanceVariable: aMethodToMove - - aMethodToMove methodClass instVarNames - do: [ :instVarName | - (aMethodToMove accessesInstanceVariable: instVarName) ifTrue: [self signalMethodCannotAccessInstanceVariable]].! ! -!MoveToInstanceOrClassMethod class methodsFor: 'pre-conditions' stamp: 'LMY 12/9/2019 00:08:13'! - assertLocalVariableDoesNotConflictWithInstanceVariable: aMethodToMove - - | newClass | - - aMethodToMove methodClass isMeta - ifTrue: [newClass := aMethodToMove methodClass soleInstance] - ifFalse: [newClass := aMethodToMove methodClass class]. - - newClass instVarNames - do: [ :instVarName | - (aMethodToMove methodNode hasLocalNamed: instVarName) - ifTrue: [self signalLocalVariableConflictsWithInstanceVariable] - ]! ! -!MoveToInstanceOrClassMethodApplier methodsFor: 'initialization' stamp: 'LMY 12/9/2019 00:26:42'! - initializeOn: aBrowser for: aMethodToMove - - browser := aBrowser. - methodToMove := aMethodToMove.! ! -!MoveToInstanceOrClassMethodApplier methodsFor: 'refactoring - creation' stamp: 'LMY 12/9/2019 00:30:05'! - createRefactoring - - ^self refactoringClass for: methodToMove.! ! -!MoveToInstanceOrClassMethodApplier methodsFor: 'refactoring - creation' stamp: 'LMY 12/9/2019 00:29:41'! - refactoringClass - - ^MoveToInstanceOrClassMethod! ! -!MoveToInstanceOrClassMethodApplier methodsFor: 'refactoring - changes' stamp: 'LMY 12/9/2019 00:31:04'! - informChangesToBrowser - - | classMethod | - - classMethod := methodToMove methodClass asString. - - browser classListIndex: (browser classListIndexOf: classMethod).! ! -!MoveToInstanceOrClassMethodApplier methodsFor: 'refactoring - changes' stamp: 'LMY 12/9/2019 00:30:19'! - showChanges - - self informChangesToBrowser.! ! -!MoveToInstanceOrClassMethodApplier methodsFor: 'refactoring - parameters request' stamp: 'LMY 12/9/2019 01:26:59'! - confirmationMessageText - - ^'This message has senders. Are you sure you want to move it?'! ! -!MoveToInstanceOrClassMethodApplier methodsFor: 'refactoring - parameters request' stamp: 'LMY 12/9/2019 01:46:26'! - methodHasSenders - - ^(methodToMove methodClass whichSelectorsReferTo: methodToMove selector) isEmpty not.! ! -!MoveToInstanceOrClassMethodApplier methodsFor: 'refactoring - parameters request' stamp: 'LMY 12/9/2019 01:25:16'! -requestRefactoringParameters - - self methodHasSenders ifTrue: [ - (self confirm: self confirmationMessageText) ifFalse: [ self endRequest ] - ]! ! -!MoveToInstanceOrClassMethodApplier class methodsFor: 'instance creation' stamp: 'LMY 12/9/2019 00:46:41'! - on: aBrowser for: aMethodToMove - - ^self new initializeOn: aBrowser for: aMethodToMove ! ! -!RefactoringMenues class methodsFor: 'browser menues' stamp: 'LMY 12/9/2019 01:56:12' prior: 50482261! - messsageRefactoringMenuOptions - - ^ `{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'rename... (R)'. - #selector -> #renameSelector. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 15. - #label -> 'change keyword order...'. - #selector -> #changeKeywordOrder. - #icon -> #sendReceiveIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'add parameter...'. - #selector -> #addParameter. - #icon -> #listAddIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'remove parameter...'. - #selector -> #removeParameter. - #icon -> #listRemoveIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'push up'. - #selector -> #pushUpSelector. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 50. - #label -> 'push down'. - #selector -> #pushDownSelector. - #icon -> #goBottomIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 60. - #label -> 'move to instance/class method'. - #selector -> #moveToInstanceOrClassMethod. - #icon -> #changesIcon - } asDictionary. - }`. - - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3965-MoveToInsClassSide-LeandroMartinYampolsky-2019Dec08-14h41m-LMY.1.cs.st----! - -'From Cuis 5.0 [latest update: #3959] on 12 December 2019 at 2:15:11 am'! -!Parser methodsFor: 'error correction' stamp: 'EB 12/12/2019 02:12:58'! - removeUnusedTemp: aTempName - - | positionsForVariable end start | - - positionsForVariable := (encoder positionsForTemporaryVariable: aTempName ifAbsent: []) first. - start := positionsForVariable first. - end := positionsForVariable last. - requestor correctFrom: start to: end with: ''.! ! -!Parser methodsFor: 'error correction' stamp: 'EB 12/12/2019 02:10:49' prior: 16886708! - removeUnusedTemps - "Scan for unused temp names, and prompt the user about the prospect of removing each one found" - - | str madeChanges | - madeChanges := false. - str := requestor text asString. - ((tempsMark between: 1 and: str size) - and: [(str at: tempsMark) = $|]) ifFalse: [^ self]. - encoder unusedTempNames do: - [:temp | (UnusedVariable name: temp) ifTrue: - [(encoder lookupVariable: temp ifAbsent: []) isUndefTemp - ifTrue: [ - self removeUnusedTemp: temp. - madeChanges := true. ] - ifFalse: - [self inform: -'You''ll first have to remove the\statement where it''s stored into' withNewLines]]]. - madeChanges ifTrue: [ReparseAfterSourceEditing signal]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3966-RemoveUnusedTempInsideBlock-EricBrandwein-2019Dec09-17h42m-EB.1.cs.st----! - -'From Cuis 5.0 [latest update: #3959] on 12 December 2019 at 2:53:20 am'! -!Parser methodsFor: 'error correction' stamp: 'EB 12/12/2019 02:49:07' prior: 50484479! - removeUnusedTemps - "Scan for unused temp names, and prompt the user about the prospect of removing each one found" - - | str madeChanges | - madeChanges := false. - str := requestor text asString. - ((tempsMark between: 1 and: str size) - and: [(str at: tempsMark) = $|]) ifFalse: [^ self]. - encoder unusedTempNames findFirst: - [:temp | (UnusedVariable name: temp) ifTrue: - [(encoder lookupVariable: temp ifAbsent: []) isUndefTemp - ifTrue: [ - self removeUnusedTemp: temp. - madeChanges := true. ] - ifFalse: [ - self inform: 'You''ll first have to remove the\statement where it''s stored into' withNewLines]]. - madeChanges ]. - madeChanges ifTrue: [ReparseAfterSourceEditing signal]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3967-ReparseAfterRemovingEachUnusedTemp-EricBrandwein-2019Dec12-02h15m-EB.1.cs.st----! - -'From Cuis 5.0 [latest update: #3965] on 12 December 2019 at 4:27:54 pm'! -!Parser methodsFor: 'error correction' stamp: 'HAW 12/12/2019 16:13:57'! - tryToRemoveUnusedTemp: aTemp - - (encoder lookupVariable: aTemp ifAbsent: []) isUndefTemp - ifTrue: [ - self removeUnusedTemp: aTemp. - ^true. ] - ifFalse: [ - self inform: 'You''ll first have to remove the\statement where it''s stored into' withNewLines. - ^false]! ! -!Parser methodsFor: 'error correction' stamp: 'HAW 12/12/2019 16:13:50' prior: 50484467! - removeUnusedTemp: aTemp - - | positionsForVariable end start | - - positionsForVariable := (encoder positionsForTemporaryVariable: aTemp ifAbsent: []) first. - start := positionsForVariable first. - end := positionsForVariable last. - - requestor correctFrom: start to: end with: ''.! ! -!Parser methodsFor: 'error correction' stamp: 'HAW 12/12/2019 16:19:26' prior: 50484511! - removeUnusedTemps - "Scan for unused temp names, and prompt the user about the prospect of removing each one found" - - | index | - - index := encoder unusedTempNames findFirst: [:temp | - (UnusedVariable name: temp) - ifTrue: [ self tryToRemoveUnusedTemp: temp ] - ifFalse: [ false ]]. - - index ~=0 ifTrue: [ReparseAfterSourceEditing signal]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3968-ImprovementOnRemoveUnusedTemps-HernanWilkinson-2019Dec12-15h46m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3968] on 12 December 2019 at 5:46:19 pm'! -!Parser methodsFor: 'error correction' stamp: 'HAW 12/12/2019 17:34:00'! - filterSeparatorsToTheLeftOn: currentSource startingAt: anInitialPosition - - | start | - - start := anInitialPosition. - [ (currentSource at: start-1) isSeparator ] whileTrue: [ start := start - 1 ]. - - ^start - ! ! -!Parser methodsFor: 'error correction' stamp: 'HAW 12/12/2019 17:34:04'! -filterSeparatorsToTheRightOn: currentSource startingAt: anInitialPosition - - | end | - - end := anInitialPosition. - [ (currentSource at: end+1) isSeparator ] whileTrue: [ end := end + 1 ]. - - ^end -! ! -!Parser methodsFor: 'error correction' stamp: 'HAW 12/12/2019 16:49:15'! - ifHasToRemove: aTemp addTo: tempsToRemove - - (encoder lookupVariable: aTemp ifAbsent: []) isUndefTemp - ifTrue: [ tempsToRemove add: ((encoder positionsForTemporaryVariable: aTemp ifAbsent: []) first)] - ifFalse: [ self inform: 'You''ll first have to remove the\statement where it''s stored into' withNewLines]! ! -!Parser methodsFor: 'error correction' stamp: 'HAW 12/12/2019 17:44:22'! - newRangeRemovingTempsDeclarationFrom: currentSource - startingAt: start - to: originalEnd - - | end | - - end := self filterSeparatorsToTheRightOn: currentSource startingAt: originalEnd. - - (currentSource at: end+1) = $| ifTrue: [ | possibleNewStart | - possibleNewStart := (self filterSeparatorsToTheLeftOn: currentSource startingAt: start) - 1. - (currentSource at: possibleNewStart) = $| ifTrue: [ ^Array with: possibleNewStart with: end + 1 ]]. - - ^Array with: start with: end -! ! -!Parser methodsFor: 'error correction' stamp: 'HAW 12/12/2019 17:42:34'! - removeUnusedTempRange: aRangeToRemove with: delta - - | currentSource start end newRangeToRemove | - - currentSource := requestor text. - newRangeToRemove := self - newRangeRemovingTempsDeclarationFrom: currentSource - startingAt: aRangeToRemove first - delta - to: aRangeToRemove last - delta. - start := newRangeToRemove first. - end := newRangeToRemove last. - - requestor correctFrom: start to: end with: ''. - - ^delta + end - start + 1 -! ! -!Parser methodsFor: 'error correction' stamp: 'HAW 12/12/2019 17:23:59'! - removeUnusedTempsRanges: tempsToRemove - - tempsToRemove inject: 0 into: [ :delta :aRangeToRemove | - self removeUnusedTempRange: aRangeToRemove with: delta ]! ! -!Parser methodsFor: 'error correction' stamp: 'HAW 12/12/2019 17:20:50' prior: 50484568! - removeUnusedTemps - "Scan for unused temp names, and prompt the user about the prospect of removing each one found" - - | tempsToRemove | - - tempsToRemove := SortedCollection sortBlock: [ :leftRange :rightRange | leftRange first < rightRange first ]. - - encoder unusedTempNames do: [:temp | - (UnusedVariable name: temp) ifTrue: [ self ifHasToRemove: temp addTo: tempsToRemove ]]. - - self removeUnusedTempsRanges: tempsToRemove -! ! - -Parser removeSelector: #tryToRemoveUnusedTemp:! - -!methodRemoval: Parser #tryToRemoveUnusedTemp: stamp: 'Install-3969-RemoveUnusedTempsRefactoring-HernanWilkinson-2019Dec12-16h46m-HAW.1.cs.st 1/11/2020 17:58:48'! -tryToRemoveUnusedTemp: aTemp - - (encoder lookupVariable: aTemp ifAbsent: []) isUndefTemp - ifTrue: [ - self removeUnusedTemp: aTemp. - ^true. ] - ifFalse: [ - self inform: 'You''ll first have to remove the\statement where it''s stored into' withNewLines. - ^false]! - -Parser removeSelector: #removeUnusedTemp:! - -!methodRemoval: Parser #removeUnusedTemp: stamp: 'Install-3969-RemoveUnusedTempsRefactoring-HernanWilkinson-2019Dec12-16h46m-HAW.1.cs.st 1/11/2020 17:58:48'! -removeUnusedTemp: aTemp - - | positionsForVariable end start | - - positionsForVariable := (encoder positionsForTemporaryVariable: aTemp ifAbsent: []) first. - start := positionsForVariable first. - end := positionsForVariable last. - - requestor correctFrom: start to: end with: ''.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3969-RemoveUnusedTempsRefactoring-HernanWilkinson-2019Dec12-16h46m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3969] on 14 December 2019 at 11:29:06 am'! - -Refactoring subclass: #MoveMethod - instanceVariableNames: 'method' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #MoveMethod category: #'Tools-Refactoring' stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:58:48'! -Refactoring subclass: #MoveMethod - instanceVariableNames: 'method' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MoveMethod subclass: #MoveToInstanceOrClassMethod - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #MoveToInstanceOrClassMethod category: #'Tools-Refactoring' stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:58:48'! -MoveMethod subclass: #MoveToInstanceOrClassMethod - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MoveMethod subclass: #PushDownMethod - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #PushDownMethod category: #'Tools-Refactoring' stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:58:48'! -MoveMethod subclass: #PushDownMethod - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MoveMethod subclass: #PushUpMethod - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #PushUpMethod category: #'Tools-Refactoring' stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:58:48'! -MoveMethod subclass: #PushUpMethod - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #MoveMethodApplier - instanceVariableNames: 'browser methodToMove' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #MoveMethodApplier category: #'Tools-Refactoring' stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:58:48'! -RefactoringApplier subclass: #MoveMethodApplier - instanceVariableNames: 'browser methodToMove' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MoveMethodApplier subclass: #MoveToInstanceOrClassMethodApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #MoveToInstanceOrClassMethodApplier category: #'Tools-Refactoring' stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:58:48'! -MoveMethodApplier subclass: #MoveToInstanceOrClassMethodApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MoveMethodApplier subclass: #PushDownMethodApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #PushDownMethodApplier category: #'Tools-Refactoring' stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:58:48'! -MoveMethodApplier subclass: #PushDownMethodApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MoveMethodApplier subclass: #PushUpMethodApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #PushUpMethodApplier category: #'Tools-Refactoring' stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:58:48'! -MoveMethodApplier subclass: #PushUpMethodApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!MoveMethod methodsFor: 'initialization' stamp: 'HAW 12/14/2019 11:04:04'! - initializeFor: aMethodToPushup - - method := aMethodToPushup! ! -!MoveMethod methodsFor: 'applying - private' stamp: 'HAW 12/14/2019 11:05:51'! - moveMethod - - self subclassResponsibility ! ! -!MoveMethod methodsFor: 'applying - private' stamp: 'HAW 12/14/2019 11:09:30'! - removeMethod - - method methodClass removeSelector: method selector. - ! ! -!MoveMethod methodsFor: 'applying' stamp: 'HAW 12/14/2019 11:05:41'! - apply - - self - moveMethod; - removeMethod - ! ! -!MoveMethod methodsFor: 'applying' stamp: 'HAW 12/14/2019 11:05:01'! - methodCategory - - ^method methodClass organization categoryOfElement: method selector! ! -!MoveToInstanceOrClassMethod methodsFor: 'applying - private' stamp: 'HAW 12/14/2019 11:08:02'! - moveMethod - - | targetClass | - - targetClass := method methodClass isMeta - ifTrue: [method methodClass soleInstance] - ifFalse: [method methodClass class]. - - targetClass - compile: method sourceCode - classified: self methodCategory. - - ! ! -!PushDownMethod methodsFor: 'applying - private' stamp: 'HAW 12/14/2019 11:10:31'! - moveMethod - - | methodCategory sourceCode | - - methodCategory := self methodCategory. - sourceCode := method sourceCode. - - method methodClass subclassesDo: [:subclass | - subclass - compile: sourceCode - classified: methodCategory. - ]. -! ! -!PushDownMethod class methodsFor: 'pre-conditions' stamp: 'HAW 12/14/2019 10:27:16'! - addShadowedInstVarsOf: subclass in: aMethodToPushDown to: subclassesWithShadowedInstVarNames - - | shadowedInstVarNames | - - shadowedInstVarNames := subclass instVarNames select: [:instVarName | - (aMethodToPushDown hasArgumentOrTemporary: instVarName) ]. - - shadowedInstVarNames ifNotEmpty: [ - subclassesWithShadowedInstVarNames at: subclass put: shadowedInstVarNames ]! ! -!PushDownMethod class methodsFor: 'pre-conditions' stamp: 'HAW 12/14/2019 10:26:56'! - assertIsValidToPushDownMethod: aMethodToPushDown - - | subclassesWithShadowedInstVarNames | - - subclassesWithShadowedInstVarNames := Dictionary new. - - aMethodToPushDown methodClass subclassesDo: [:subclass | - self addShadowedInstVarsOf: subclass in: aMethodToPushDown to: subclassesWithShadowedInstVarNames ]. - - subclassesWithShadowedInstVarNames ifNotEmpty: [ - self signalMethodCannotShadowInstVarOfSubclasses: subclassesWithShadowedInstVarNames] - ! ! -!PushDownMethod class methodsFor: 'pre-conditions' stamp: 'HAW 12/14/2019 10:57:17'! - warnIfExistMethodToPushDownOnSubClass: aMethodToPushDown - - | subclassesImplementingMessage | - - subclassesImplementingMessage := aMethodToPushDown methodClass subclasses select: [:subclass | - subclass includesSelector: aMethodToPushDown selector ]. - - subclassesImplementingMessage ifNotEmpty: [ - self warnMessageAlreadyImplementedIn: subclassesImplementingMessage ] - ! ! -!PushDownMethod class methodsFor: 'exceptions' stamp: 'HAW 12/14/2019 11:23:44'! - errorMessageCanNotPushDownWithShadowedInstVarsOf: subclassesWithShadowedInstVarNames - - ^String streamContents: [ :stream | - stream - nextPutAll: 'Can not push down method because the following subclasses'; - newLine; - nextPutAll: 'would have shadowed instance variables:'. - - subclassesWithShadowedInstVarNames - keysAndValuesDo: [ :class :instVarNames | - stream - newLine; - print: class; - nextPutAll: ': '. - instVarNames asCommaSeparated: [:instVarName | stream nextPutAll: instVarName ] on: stream ]]. - - -! ! -!PushDownMethod class methodsFor: 'exceptions' stamp: 'HAW 12/14/2019 10:39:22'! - signalMethodCannotShadowInstVarOfSubclasses: subclassesWithShadowedInstVarNames - - self refactoringError: ( - self errorMessageCanNotPushDownWithShadowedInstVarsOf: subclassesWithShadowedInstVarNames)! ! -!PushDownMethod class methodsFor: 'warnings' stamp: 'HAW 12/14/2019 10:58:41'! - warnMessageAlreadyImplementedIn: subclassesImplementingMessage - - self refactoringWarning: - (self warningMesssageForMessageAlreadyImplementedIn: subclassesImplementingMessage)! ! -!PushDownMethod class methodsFor: 'warnings' stamp: 'HAW 12/14/2019 10:49:27'! - warningMesssageForMessageAlreadyImplementedIn: subclassesImplementingMessage - - ^String streamContents: [ :stream | - stream - nextPutAll: 'Method already exist in the following subclasses:'; - newLine. - - subclassesImplementingMessage asCommaSeparated: [ :aClass | stream print: aClass ] on: stream. - - stream - newLine; - nextPutAll: 'If you continue they will be overwritten' ].! ! -!PushUpMethod methodsFor: 'applying - private' stamp: 'HAW 12/14/2019 11:11:15'! - moveMethod - - method methodClass superclass - compile: method sourceCode - classified: self methodCategory! ! -!PushUpMethod class methodsFor: 'warnings' stamp: 'HAW 12/14/2019 10:54:05'! - methodToPushUpExistOnSuperclassWarningMessage - - ^'Method already exist in superclass'. - - ! ! -!MoveMethodApplier methodsFor: 'initialization' stamp: 'HAW 12/14/2019 11:15:12'! - initializeOn: aBrowser for: aMethodToMove - - browser := aBrowser. - methodToMove := aMethodToMove.! ! -!MoveMethodApplier methodsFor: 'refactoring - creation' stamp: 'HAW 12/14/2019 11:15:34'! - createRefactoring - - ^self refactoringClass for: methodToMove.! ! -!MoveMethodApplier methodsFor: 'refactoring - creation' stamp: 'HAW 12/14/2019 11:19:17'! - refactoringClass - - self subclassResponsibility ! ! -!MoveMethodApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 12/14/2019 11:16:56'! - requestRefactoringParameters - - ! ! -!MoveMethodApplier methodsFor: 'refactoring - changes' stamp: 'HAW 12/14/2019 11:17:14'! - informChangesToBrowser - - browser - reformulateList; - changed: #messageList; - setClassOrganizer! ! -!MoveMethodApplier methodsFor: 'refactoring - changes' stamp: 'HAW 12/14/2019 11:17:10'! - showChanges - - self informChangesToBrowser.! ! -!MoveMethodApplier class methodsFor: 'instance creation' stamp: 'HAW 12/14/2019 11:13:33'! - on: aBrowser for: aMethodToMove - - ^self new initializeOn: aBrowser for: aMethodToMove ! ! -!PushDownMethodApplier methodsFor: 'refactoring - creation' stamp: 'fz 12/4/2019 15:38:49'! - refactoringClass - - ^PushDownMethod! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'HAW 12/14/2019 11:27:21' prior: 50482226! - pushDownSelector - - model selectedMessageName ifNotNil: [ :selectedSelector | - (PushDownMethodApplier on: model for: model selectedClassOrMetaClass>>selectedSelector) value ].! ! -!PushDownMethod class methodsFor: 'instance creation' stamp: 'HAW 12/14/2019 10:04:49' prior: 50482255! - for: aMethodToPushDown - - self assertIsValidToPushDownMethod: aMethodToPushDown. - self warnIfExistMethodToPushDownOnSubClass: aMethodToPushDown. - - ^self new initializeFor: aMethodToPushDown ! ! -!PushUpMethod class methodsFor: 'instance creation' stamp: 'HAW 12/14/2019 10:52:55' prior: 50482462! - for: aMethodToPushUp - - self assertIsValidToPushUpMethod: aMethodToPushUp. - self warnIfExistMethodToPushUpOnSuperClass: aMethodToPushUp. - - ^self new initializeFor: aMethodToPushUp! ! -!PushUpMethod class methodsFor: 'warnings' stamp: 'HAW 12/14/2019 10:54:19' prior: 50482358! - warnIfExistMethodToPushUpOnSuperClass: aMethodToPushUp - - (aMethodToPushUp methodClass superclass includesSelector: aMethodToPushUp selector) - ifTrue: [self refactoringWarning: self methodToPushUpExistOnSuperclassWarningMessage ].! ! - -PushUpMethodApplier class removeSelector: #on:for:! - -!methodRemoval: PushUpMethodApplier class #on:for: stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:58:48'! -on: aBrowser for: aMethodToPushUp - - ^self new initializeOn: aBrowser for: aMethodToPushUp ! - -PushUpMethodApplier removeSelector: #createRefactoring! - -!methodRemoval: PushUpMethodApplier #createRefactoring stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:58:48'! -createRefactoring - - ^self refactoringClass for: methodToPushUp.! - -PushUpMethodApplier removeSelector: #initializeOn:for:! - -!methodRemoval: PushUpMethodApplier #initializeOn:for: stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:58:48'! -initializeOn: aBrowser for: aMethodToPushUp - - browser := aBrowser. - methodToPushUp := aMethodToPushUp.! - -PushUpMethodApplier removeSelector: #requestRefactoringParameters! - -!methodRemoval: PushUpMethodApplier #requestRefactoringParameters stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:58:48'! -requestRefactoringParameters - - ! - -PushUpMethodApplier removeSelector: #showChanges! - -!methodRemoval: PushUpMethodApplier #showChanges stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:58:48'! -showChanges - - self informChangesToBrowser.! - -PushUpMethodApplier removeSelector: #informChangesToBrowser! - -!methodRemoval: PushUpMethodApplier #informChangesToBrowser stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:58:48'! -informChangesToBrowser - - | classMethod | - - classMethod := methodToPushUp methodClass asString. - - browser classListIndex: (browser classListIndexOf: classMethod).! - -PushDownMethodApplier class removeSelector: #on:for:! - -PushDownMethodApplier removeSelector: #informChangesToBrowser! - -PushDownMethodApplier removeSelector: #initializeOn:for:! - -PushDownMethodApplier removeSelector: #showChanges! - -PushDownMethodApplier removeSelector: #createRefactoring! - -PushDownMethodApplier removeSelector: #requestRefactoringParameters! - -MoveToInstanceOrClassMethodApplier class removeSelector: #on:for:! - -!methodRemoval: MoveToInstanceOrClassMethodApplier class #on:for: stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:58:48'! -on: aBrowser for: aMethodToMove - - ^self new initializeOn: aBrowser for: aMethodToMove ! - -MoveToInstanceOrClassMethodApplier removeSelector: #createRefactoring! - -!methodRemoval: MoveToInstanceOrClassMethodApplier #createRefactoring stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:58:48'! -createRefactoring - - ^self refactoringClass for: methodToMove.! - -MoveToInstanceOrClassMethodApplier removeSelector: #informChangesToBrowser! - -!methodRemoval: MoveToInstanceOrClassMethodApplier #informChangesToBrowser stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:58:48'! -informChangesToBrowser - - | classMethod | - - classMethod := methodToMove methodClass asString. - - browser classListIndex: (browser classListIndexOf: classMethod).! - -MoveToInstanceOrClassMethodApplier removeSelector: #showChanges! - -!methodRemoval: MoveToInstanceOrClassMethodApplier #showChanges stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:58:48'! -showChanges - - self informChangesToBrowser.! - -MoveToInstanceOrClassMethodApplier removeSelector: #initializeOn:for:! - -!methodRemoval: MoveToInstanceOrClassMethodApplier #initializeOn:for: stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:58:48'! -initializeOn: aBrowser for: aMethodToMove - - browser := aBrowser. - methodToMove := aMethodToMove.! - -PushUpMethod class removeSelector: #warningMesssageForExistMethodToPushUpOnSuperClass! - -!methodRemoval: PushUpMethod class #warningMesssageForExistMethodToPushUpOnSuperClass stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:58:48'! -warningMesssageForExistMethodToPushUpOnSuperClass - - ^'Method already exist in superclass'. - - ! - -PushUpMethod class removeSelector: #warnIsValidToPushUpMethod:! - -!methodRemoval: PushUpMethod class #warnIsValidToPushUpMethod: stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:58:48'! -warnIsValidToPushUpMethod: aMethodToPushUp - - self warnIfExistMethodToPushUpOnSuperClass: aMethodToPushUp. -! - -PushUpMethod removeSelector: #initializeFor:! - -!methodRemoval: PushUpMethod #initializeFor: stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:58:48'! -initializeFor: aMethodToPushup - - method := aMethodToPushup ! - -PushUpMethod removeSelector: #apply! - -!methodRemoval: PushUpMethod #apply stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:58:48'! -apply - - | methodCategory | - - methodCategory := method methodClass organization categoryOfElement: method selector. - method methodClass superclass - compile: method sourceCode - classified: methodCategory. - - method methodClass removeSelector: method selector. - ! - -PushDownMethod class removeSelector: #warningMesssageForExistMethodToPushDownOnSubClass! - -PushDownMethod class removeSelector: #signalMethodCannotShadowInstVarOfSubclasses! - -PushDownMethod class removeSelector: #warningMesssageForMessageAlreadyImplementedIn! - -PushDownMethod class removeSelector: #errorMessageCanNotPushDownWithShadowedInstVarsOf! - -PushDownMethod class removeSelector: #warnMethodAlreadyImplementedIn:! - -PushDownMethod class removeSelector: #errorMessageForTempOrArgVarDeclaredAsInstVarOnSubClass! - -PushDownMethod class removeSelector: #signalMethodCannotShadowAnInstVarOfASubClass! - -PushDownMethod class removeSelector: #warnIsValidToPushDownMethod:! - -PushDownMethod removeSelector: #initializeFor:! - -!methodRemoval: PushDownMethod #initializeFor: stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:58:48'! -initializeFor: aMethodToPushDown - - method := aMethodToPushDown ! - -PushDownMethod removeSelector: #apply! - -!methodRemoval: PushDownMethod #apply stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:58:48'! -apply - - | methodCategory | - - methodCategory := method methodClass organization categoryOfElement: method selector. - method methodClass subclassesDo: [:subClass | - subClass - compile: method sourceCode - classified: methodCategory. - ]. - - method methodClass removeSelector: method selector. - ! - -MoveToInstanceOrClassMethod removeSelector: #initializeFor:! - -!methodRemoval: MoveToInstanceOrClassMethod #initializeFor: stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:58:48'! -initializeFor: aMethodToMove - - methodToMove := aMethodToMove. - originalClass := aMethodToMove methodClass. - newClass := aMethodToMove methodClass isMeta - ifTrue: [aMethodToMove methodClass soleInstance] - ifFalse: [aMethodToMove methodClass class]! - -MoveToInstanceOrClassMethod removeSelector: #apply! - -!methodRemoval: MoveToInstanceOrClassMethod #apply stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:58:48'! -apply - - | methodCategory | - - methodCategory := originalClass organization categoryOfElement: methodToMove selector. - newClass - compile: methodToMove sourceCode - classified: methodCategory. - - originalClass removeSelector: methodToMove selector. - ! - -MoveMethod subclass: #MoveToInstanceOrClassMethod - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #MoveToInstanceOrClassMethod category: #'Tools-Refactoring' stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:58:48'! -MoveMethod subclass: #MoveToInstanceOrClassMethod - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MoveMethod subclass: #PushDownMethod - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #PushDownMethod category: #'Tools-Refactoring' stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:58:48'! -MoveMethod subclass: #PushDownMethod - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MoveMethod subclass: #PushUpMethod - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #PushUpMethod category: #'Tools-Refactoring' stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:58:48'! -MoveMethod subclass: #PushUpMethod - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MoveMethodApplier subclass: #MoveToInstanceOrClassMethodApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #MoveToInstanceOrClassMethodApplier category: #'Tools-Refactoring' stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:58:48'! -MoveMethodApplier subclass: #MoveToInstanceOrClassMethodApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MoveMethodApplier subclass: #PushUpMethodApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #PushUpMethodApplier category: #'Tools-Refactoring' stamp: 'Install-3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st 1/11/2020 17:58:48'! -MoveMethodApplier subclass: #PushUpMethodApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3970-MoveMethodRefactoring-HernanWilkinson-2019Dec14-10h03m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3959] on 14 December 2019 at 12:33:24 pm'! -!Browser methodsFor: 'testing' stamp: 'HAW 12/14/2019 12:01:16'! - is: aSymbol - - ^ aSymbol == #Browser or: [ super is: aSymbol ]! ! -!Browser methodsFor: 'testing' stamp: 'HAW 12/14/2019 12:30:56'! - isEditingClass - - ^self isEditingExistingClass or: [ self isEditingNewClass ]! ! -!Browser methodsFor: 'testing' stamp: 'HAW 12/14/2019 12:29:57'! - isEditingExistingClass - - ^editSelection == #editClass! ! -!Browser methodsFor: 'testing' stamp: 'HAW 12/14/2019 12:14:04'! - isEditingNewClass - - ^editSelection == #newClass ! ! -!Browser methodsFor: 'accessing' stamp: 'HAW 12/14/2019 12:29:57' prior: 16791323! - acceptedStringOrText - "Depending on the current selection, different information is retrieved. - Answer a string description of that information. This information is the - method of the currently selected class and message." - - | comment theClass latestCompiledMethod | - latestCompiledMethod _ currentCompiledMethod. - currentCompiledMethod _ nil. - - editSelection == #none ifTrue: [^ '']. - editSelection == #editSystemCategories - ifTrue: [^ systemOrganizer printString]. - self isEditingNewClass - ifTrue: [^ (theClass _ self selectedClass) - ifNil: [ - Class template: selectedSystemCategory] - ifNotNil: [ - Class templateForSubclassOf: theClass category: selectedSystemCategory]]. - self isEditingExistingClass - ifTrue: [^ self classDefinitionText ]. - editSelection == #editComment - ifTrue: [ - (theClass _ self selectedClass) ifNil: [^ '']. - comment _ theClass comment. - currentCompiledMethod _ theClass organization commentRemoteStr. - ^ comment size = 0 - ifTrue: ['This class has not yet been commented.'] - ifFalse: [comment]]. - editSelection == #hierarchy - ifTrue: [^ self selectedClassOrMetaClass printHierarchy]. - editSelection == #editMessageCategories - ifTrue: [^ self classOrMetaClassOrganizer printString]. - editSelection == #newMessage - ifTrue: [ - ^ (theClass _ self selectedClassOrMetaClass) - ifNil: [''] - ifNotNil: [theClass sourceCodeTemplate]]. - editSelection == #editMessage - ifTrue: [ - self showingByteCodes ifTrue: [^ self selectedBytecodes]. - currentCompiledMethod _ latestCompiledMethod. - ^ self selectedMessage]. - - self error: 'Browser internal error: unknown edit selection.'! ! -!Browser methodsFor: 'accessing' stamp: 'HAW 12/14/2019 12:30:40' prior: 50444178! - contents: input notifying: aRequestor - "The retrieved information has changed and its source must now be - updated. The information can be a variety of things, depending on - the list selections (such as templates for class or message definition, - methods) or the user menu commands (such as definition, comment, - hierarchy). Answer the result of updating the source." - - | aString aText theClass | - aString _ input asString. - aText _ input asText. - editSelection == #editSystemCategories ifTrue: [ ^ self changeSystemCategories: aString ]. - self isEditingClass ifTrue: [ - [ - self defineClass: aString notifying: aRequestor - ] on: RecompilationFailure do: [ :ex | - self inform: ex messageText. - ^ false]. - ^ true]. - editSelection == #editComment - ifTrue: [ - theClass _ self selectedClass. - theClass - ifNil: [ - self inform: 'You must select a class -before giving it a comment.'. - ^ false]. - theClass comment: aText stamp: Utilities changeStamp. - self changed: #classCommentText. - ^ true]. - editSelection == #hierarchy ifTrue: [ ^ true ]. - editSelection == #editMessageCategories ifTrue: [ ^ self changeMessageCategories: aString ]. - editSelection == #editMessage | (editSelection == #newMessage) - ifTrue: [ - ^ self okayToAccept - ifFalse:[ false ] - ifTrue: [ - (self compileMessage: aText notifying: aRequestor) - ifTrue: [ self triggerEvent: #annotationChanged ]; - yourself ]]. - editSelection == #none - ifTrue: [ - self inform: 'This text cannot be accepted -in this part of the browser.'. - ^ false]. - self error: 'unacceptable accept'! ! -!Browser methodsFor: 'annotation' stamp: 'HAW 12/14/2019 12:29:57' prior: 50455426! - annotation - "Provide a line of content for an annotation pane, representing information about the method associated with the selected class and selector in the receiver." - - | aSelector aClass | - (aClass _ self selectedClassOrMetaClass) - ifNil: [^ '']. - self editSelection == #editComment - ifTrue: [^ self annotationForSelector: #Comment ofClass: aClass]. - self isEditingExistingClass - ifTrue: [^ self annotationForSelector: #Definition ofClass: aClass]. - (aSelector _ self selectedMessageName) - ifNil: [^ '']. - ^ self annotationForSelector: aSelector ofClass: aClass! ! -!Browser methodsFor: 'class functions' stamp: 'HAW 12/14/2019 12:30:40' prior: 16791681! - explainSpecial: string - "Answer a string explaining the code pane selection if it is displaying - one of the special edit functions." - - | classes whole lits reply | - self isEditingClass - ifTrue: - ["Selector parts in class definition" - string last == $: ifFalse: [^nil]. - lits _ Array with: - #subclass:instanceVariableNames:classVariableNames:poolDictionaries:category:. - (whole _ lits detect: [:each | (each keywords - detect: [:frag | frag = string] ifNone: nil) notNil] - ifNone: nil) notNil - ifTrue: [reply _ '"' , string , ' is one part of the message selector ' , whole , '.'] - ifFalse: [^nil]. - classes _ Smalltalk allClassesImplementing: whole. - classes _ 'these classes ' , classes printString. - ^reply , ' It is defined in ' , classes , '." -Smalltalk browseAllImplementorsOf: #' , whole]. - - editSelection == #hierarchy - ifTrue: - ["Instance variables in subclasses" - classes _ self selectedClassOrMetaClass allSubclasses. - classes _ classes detect: [:each | (each instVarNames - detect: [:name | name = string] ifNone: nil) notNil] - ifNone: [^nil]. - classes _ classes printString. - ^'"is an instance variable in class ' , classes , '." -' , classes , ' browseAllAccessesTo: ''' , string , '''.']. - editSelection == #editSystemCategories ifTrue: [^nil]. - editSelection == #editMessageCategories ifTrue: [^nil]. - ^nil! ! -!CodeFileBrowser methodsFor: 'accessing' stamp: 'HAW 12/14/2019 12:29:57' prior: 16809070! - acceptedStringOrText - self updateInfoView. - (self isEditingNewClass and: [ codeFile notNil ]) - ifTrue: [ ^codeFile description ]. - self isEditingExistingClass - ifTrue:[ ^self modifiedClassDefinition ]. - ^super acceptedStringOrText! ! -!CodeFileBrowser methodsFor: 'infoView' stamp: 'HAW 12/14/2019 12:29:57' prior: 50451714! - infoViewContents - | theClass | - self isEditingNewClass ifTrue: [ - ^codeFile - ifNil: [ 'No file selected' ] - ifNotNil: [ codeFile summary ]]. - self selectedClass ifNil: [^ '']. - theClass _ Smalltalk at: self selectedClass name asSymbol ifAbsent: nil. - self isEditingExistingClass ifTrue: [ - ^ theClass - ifNotNil: ['Class exists already in the system'] - ifNil: ['Class not in the system']]. - editSelection == #editMessage ifFalse: [^ '']. - (theClass notNil and: [self metaClassIndicated]) - ifTrue: [theClass _ theClass class]. - ^ (theClass notNil and: [theClass includesSelector: self selectedMessageName]) - ifTrue: ['Method already exists' , self extraInfo] - ifFalse: ['**NEW** Method not in the system']! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 12/14/2019 12:29:57' prior: 50452512! - isEditingClassDefinition - - ^(self codeProvider is: #Browser) and: [ self codeProvider isEditingExistingClass ]! ! -!BrowserCommentTextMorph methodsFor: 'updating' stamp: 'HAW 12/14/2019 12:29:57' prior: 16792978! - update: anAspect - super update: anAspect. - anAspect == #editSelection ifFalse: [ ^self ]. - model textProvider isEditingExistingClass - ifTrue: [ self showPane ] - ifFalse: [ self hidePane ]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 12/14/2019 12:30:40' prior: 50434520! - parse: allSource in: contextClass and: specificModel - - | isMethod | - - parser _ SHParserST80 new. - parser - workspace: ((specificModel is: #providesBindings) ifTrue: [specificModel]); - classOrMetaClass: contextClass; - source: (allSource copyFrom: 1 to: position); - allSource: allSource. - - isMethod := (specificModel is: #Browser) - ifTrue: [ specificModel isEditingClass not ] - ifFalse: [ specificModel is: #CodeProvider ]. - parser parse: isMethod. - - ^ parser last3Ranges. -! ! - -Browser removeSelector: #isEditingClassOrNewClass! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3971-AutoCompleteWhenEditingClass-HernanWilkinson-2019Dec14-11h53m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3969] on 12 December 2019 at 10:54:47 pm'! -!Parser methodsFor: 'error correction' stamp: 'EB 12/12/2019 20:48:34'! - declarationRangesForTemps: someTempNodes - - ^someTempNodes collect: [ :temporaryNode | - (encoder rangeForNode: temporaryNode ifAbsent: []) first ].! ! -!Parser methodsFor: 'error correction' stamp: 'EB 12/12/2019 20:58:49'! - rangesForRemovableUnusedTemps - - | tempsToRemove | - - tempsToRemove := SortedCollection sortBlock: [ :leftRange :rightRange | leftRange first < rightRange first ]. - - parseNode nodesDo: [ :node | - node isBlockNode ifTrue: [ - tempsToRemove addAll: (self rangesForRemovableUnusedTempsInBlockNode: node) ]]. - - ^tempsToRemove! ! -!Parser methodsFor: 'error correction' stamp: 'EB 12/12/2019 20:57:18'! - rangesForRemovableUnusedTempsInBlockNode: aBlockNode - - | removableTemps unusedTemps | - - unusedTemps := self unusedTempsOf: aBlockNode. - removableTemps := self selectRemovableUnusedTempsFrom: unusedTemps. - ^self declarationRangesForTemps: removableTemps.! ! -!Parser methodsFor: 'error correction' stamp: 'EB 12/12/2019 20:57:44'! - selectRemovableUnusedTempsFrom: someUnusedTemps - - ^someUnusedTemps select: [ :temporaryNode | - (UnusedVariable name: temporaryNode name) and: [ - temporaryNode isUndefTemp - ifTrue: [ true ] - ifFalse: [ - self inform: 'You''ll first have to remove the\statement where it''s stored into' withNewLines. - false ] - ] - ].! ! -!Parser methodsFor: 'error correction' stamp: 'EB 12/12/2019 22:50:35'! - unusedTempsOf: aBlockNode - - ^aBlockNode temporaries select: [ :temporaryNode | temporaryNode isUnusedTemp ]! ! -!Parser methodsFor: 'expression types' stamp: 'EB 12/12/2019 22:51:14' prior: 50444807! - method: noPattern doIt: doIt context: ctxt - " pattern [ | temporaries ] block => MethodNode." - - | sap block primitives temporaries messageComment methodNode | - - sap := self pattern: noPattern inContext: ctxt. - "sap={selector, arguments, precedence}" - self properties selector: (sap at: 1). - encoder selector: (sap at: 1). - (sap at: 2) do: [:argNode | argNode beMethodArg]. - - doIt ifFalse: [self pragmaSequence]. - temporaries := self temporaries. - messageComment := currentComment. - currentComment := nil. - doIt ifFalse: [self pragmaSequence]. - primitives := self pragmaPrimitives. - - self statements: #() innerBlock: doIt. - parseNode temporaries: temporaries. - block := parseNode. - doIt - ifTrue: [block returnLast] - ifFalse: [block returnSelfIfNoOther: encoder]. - hereType == #doIt ifFalse: [^self expected: 'Nothing more']. - - methodNode := self newMethodNode comment: messageComment. - methodNode - selector: (sap at: 1) - arguments: (sap at: 2) - precedence: (sap at: 3) - temporaries: temporaries - block: block - encoder: encoder - primitive: primitives - properties: properties - selectorKeywordsRanges: (sap at: 4). - - self interactive ifTrue: [ self performInteractiveChecks: methodNode ]. - - ^methodNode! ! -!Parser methodsFor: 'error correction' stamp: 'EB 12/12/2019 20:56:04' prior: 50484663! - removeUnusedTemps - "Scan for unused temp names, and prompt the user about the prospect of removing each one found" - - self removeUnusedTempsRanges: self rangesForRemovableUnusedTemps. -! ! - -Parser removeSelector: #ifHasToRemove:addTo:! - -!methodRemoval: Parser #ifHasToRemove:addTo: stamp: 'Install-3972-RemoveUnusedTemporariesWithManyVariablesWithSameName-EricBrandwein-2019Dec12-17h56m-EB.1.cs.st 1/11/2020 17:58:49'! -ifHasToRemove: aTemp addTo: tempsToRemove - - (encoder lookupVariable: aTemp ifAbsent: []) isUndefTemp - ifTrue: [ tempsToRemove add: ((encoder positionsForTemporaryVariable: aTemp ifAbsent: []) first)] - ifFalse: [ self inform: 'You''ll first have to remove the\statement where it''s stored into' withNewLines]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3972-RemoveUnusedTemporariesWithManyVariablesWithSameName-EricBrandwein-2019Dec12-17h56m-EB.1.cs.st----! - -'From Cuis 5.0 [latest update: #3972] on 17 December 2019 at 9:16:27 am'! -!Parser methodsFor: 'error correction' stamp: 'HAW 12/17/2019 09:13:58'! - rangesForRemovableUnusedTempsOf: aMethodNode - - | tempsToRemove | - - tempsToRemove := SortedCollection sortBlock: [ :leftRange :rightRange | leftRange first < rightRange first ]. - - tempsToRemove addAll: (self rangesForRemovableUnusedTempsInBlockNode: aMethodNode). - aMethodNode nodesDo: [ :node | - node isBlockNode ifTrue: [ - tempsToRemove addAll: (self rangesForRemovableUnusedTempsInBlockNode: node) ]]. - - ^tempsToRemove! ! -!Parser methodsFor: 'error correction' stamp: 'HAW 12/17/2019 09:13:21'! - removeUnusedTempsOf: aMethodNode - "Scan for unused temp names, and prompt the user about the prospect of removing each one found" - - self removeUnusedTempsRanges: (self rangesForRemovableUnusedTempsOf: aMethodNode)! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 3/11/2019 09:01:34' prior: 50485729! - method: noPattern doIt: doIt context: ctxt - " pattern [ | temporaries ] block => MethodNode." - - | sap block primitives temporaries messageComment methodNode | - - sap := self pattern: noPattern inContext: ctxt. - "sap={selector, arguments, precedence}" - self properties selector: (sap at: 1). - encoder selector: (sap at: 1). - (sap at: 2) do: [:argNode | argNode beMethodArg]. - - doIt ifFalse: [self pragmaSequence]. - temporaries := self temporaries. - messageComment := currentComment. - currentComment := nil. - doIt ifFalse: [self pragmaSequence]. - primitives := self pragmaPrimitives. - - self statements: #() innerBlock: doIt. - block := parseNode. - doIt - ifTrue: [block returnLast] - ifFalse: [block returnSelfIfNoOther: encoder]. - hereType == #doIt ifFalse: [^self expected: 'Nothing more']. - - methodNode := self newMethodNode comment: messageComment. - methodNode - selector: (sap at: 1) - arguments: (sap at: 2) - precedence: (sap at: 3) - temporaries: temporaries - block: block - encoder: encoder - primitive: primitives - properties: properties - selectorKeywordsRanges: (sap at: 4). - - self interactive ifTrue: [ self performInteractiveChecks: methodNode ]. - - ^methodNode! ! -!Parser methodsFor: 'error correction' stamp: 'HAW 12/17/2019 09:15:06' prior: 50485698! - rangesForRemovableUnusedTempsInBlockNode: aNodeWithTemporaries - - | removableTemps unusedTemps | - - unusedTemps := self unusedTempsOf: aNodeWithTemporaries. - removableTemps := self selectRemovableUnusedTempsFrom: unusedTemps. - - ^self declarationRangesForTemps: removableTemps.! ! -!Parser methodsFor: 'error correction' stamp: 'HAW 12/17/2019 09:14:42' prior: 50485722! - unusedTempsOf: aNodeWithTemporaries - - ^aNodeWithTemporaries temporaries select: [ :temporaryNode | temporaryNode isUnusedTemp ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3973-ParserUnusedVaraiblesRefactoring-HernanWilkinson-2019Dec17-09h12m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3972] on 17 December 2019 at 9:21:05 am'! -!Parser methodsFor: 'expression types' stamp: 'HAW 12/17/2019 09:18:00' prior: 50409632! - performInteractiveChecks: aMethodNode - - self - declareUndeclaredTemps: aMethodNode; - removeUnusedTempsOf: aMethodNode ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3974-ParserUnusedVaraiblesRefactoring-HernanWilkinson-2019Dec17-09h16m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3972] on 17 December 2019 at 9:23:58 am'! - -Parser removeSelector: #removeUnusedTemps! - -!methodRemoval: Parser #removeUnusedTemps stamp: 'Install-3975-ParserUnusedVaraiblesRefactoring-HernanWilkinson-2019Dec17-09h21m-HAW.1.cs.st 1/11/2020 17:58:49'! -removeUnusedTemps - "Scan for unused temp names, and prompt the user about the prospect of removing each one found" - - self removeUnusedTempsRanges: self rangesForRemovableUnusedTemps. -! - -Parser removeSelector: #rangesForRemovableUnusedTemps! - -!methodRemoval: Parser #rangesForRemovableUnusedTemps stamp: 'Install-3975-ParserUnusedVaraiblesRefactoring-HernanWilkinson-2019Dec17-09h21m-HAW.1.cs.st 1/11/2020 17:58:49'! -rangesForRemovableUnusedTemps - - | tempsToRemove | - - tempsToRemove := SortedCollection sortBlock: [ :leftRange :rightRange | leftRange first < rightRange first ]. - - parseNode nodesDo: [ :node | - node isBlockNode ifTrue: [ - tempsToRemove addAll: (self rangesForRemovableUnusedTempsInBlockNode: node) ]]. - - ^tempsToRemove! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3975-ParserUnusedVaraiblesRefactoring-HernanWilkinson-2019Dec17-09h21m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3972] on 17 December 2019 at 11:16:36 am'! -!ParserNotification methodsFor: 'name' stamp: 'HAW 12/17/2019 10:47:30'! - name - - ^name! ! -!ParserNotification methodsFor: 'initialization' stamp: 'HAW 12/17/2019 10:46:22'! - initializeNamed: aName - - name _ aName! ! -!ParserNotification class methodsFor: 'instance creation' stamp: 'HAW 12/17/2019 10:47:11' prior: 16886988! - name: aName - - ^(self new initializeNamed: aName) signal! ! - -ParserNotification removeSelector: #setName:! - -!methodRemoval: ParserNotification #setName: stamp: 'Install-3976-ParseNotificationAccessing-HernanWilkinson-2019Dec17-10h46m-HAW.1.cs.st 1/11/2020 17:58:49'! -setName: aString - - name _ aString! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3976-ParseNotificationAccessing-HernanWilkinson-2019Dec17-10h46m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3970] on 13 December 2019 at 1:28:36 am'! -!Parser methodsFor: 'error correction' stamp: 'EB 12/13/2019 01:21:02'! - createTempDeclarationInBlockWith: tempName before: aTempsMark - "Return the new tempsMark." - - | delta insertion offset | - - insertion := ' | ' , tempName , ' |'. - delta := 1. "the bar" - offset := self insertWord: insertion at: aTempsMark + 1. - - ^aTempsMark + offset - delta.! ! -!Parser methodsFor: 'error correction' stamp: 'EB 12/13/2019 01:20:31'! -createTempDeclarationInMethodWith: aTempName - "No bars - insert some with CR, tab. Return the new tempsMark." - - | characterBeforeMark delta insertion theTextString offset | - - theTextString := requestor text string. - characterBeforeMark := theTextString at: tempsMark - 1 ifAbsent: [$ ]. - insertion := '| ', aTempName, ' |', String newLineString. - delta := 2. "the bar and CR" - characterBeforeMark = Character tab ifTrue: [ - insertion := insertion , String tab. - delta := delta + 1. "the tab" - ]. - - offset := self insertWord: insertion at: tempsMark. - - ^tempsMark + offset - delta.! ! -!Parser methodsFor: 'error correction' stamp: 'EB 12/13/2019 01:19:25'! - insertWord: anInsertion at: aPosition - - ^self substituteWord: anInsertion - wordInterval: (aPosition to: aPosition - 1) - offset: 0.! ! -!Parser methodsFor: 'error correction' stamp: 'EB 12/13/2019 01:20:01'! - pasteTemp: name before: aTempsMark - "Return the new position of the tempsMark." - - | insertion theTextString characterBeforeMark offset | - - theTextString := requestor text string. - insertion := name, ' '. - characterBeforeMark := theTextString at: aTempsMark - 1 ifAbsent: [$ ]. - characterBeforeMark isSeparator ifFalse: [ insertion := ' ', insertion]. - offset := self insertWord: insertion at: aTempsMark. - - ^aTempsMark + offset.! ! -!Parser methodsFor: 'error correction' stamp: 'EB 12/13/2019 01:09:37'! - pasteTemp: tempName inBlock: aBlockNode - - | theTextString blockTempsMark newTempsMark | - - theTextString := requestor text string. - blockTempsMark := aBlockNode tempsMark + requestorOffset. - - newTempsMark := - (theTextString at: blockTempsMark) = $| - ifTrue: [ - "Paste it before the second vertical bar" - aBlockNode tempsMark: (self pasteTemp: tempName before: blockTempsMark) ] - ifFalse: [ - "The tempsMark is at the beginning of the block, we should insert after it." - self createTempDeclarationInBlockWith: tempName before: blockTempsMark ]. - - aBlockNode tempsMark: newTempsMark.! ! -!Parser methodsFor: 'error correction' stamp: 'EB 12/13/2019 00:18:45' prior: 16886592! - declareUndeclaredTemps: methodNode - "Declare any undeclared temps, declaring them at the smallest enclosing scope." - | undeclared userSelection blocksToVars | - (undeclared _ encoder undeclaredTemps) isEmpty ifTrue: [ ^ self ]. - userSelection _ requestor selectionInterval. - blocksToVars _ IdentityDictionary new. - undeclared do: [ :var | - (blocksToVars - at: (var tag == #method - ifTrue: [ methodNode block ] - ifFalse: [ methodNode accept: (VariableScopeFinder new ofVariable: var) ]) - ifAbsentPut: [ SortedCollection new ]) add: var name ]. - (blocksToVars removeKey: methodNode block ifAbsent: nil) ifNotNil: [ :rootVars | - rootVars do: [ :varName | - self pasteTempAtMethodLevel: varName ]]. - (blocksToVars keys sort: [ :a :b | - a tempsMark < b tempsMark ]) do: [ :block | - (blocksToVars at: block) do: [ :varName | self pasteTemp: varName inBlock: block ]]. - requestor - selectInvisiblyFrom: userSelection first - to: userSelection last + requestorOffset. - ReparseAfterSourceEditing signal! ! -!Parser methodsFor: 'error correction' stamp: 'EB 12/13/2019 01:26:43' prior: 16886663! - pasteTempAtMethodLevel: name - - | theTextString | - - theTextString := requestor text string. - tempsMark := - (theTextString at: tempsMark) = $| - ifTrue: [ - "Paste it before the second vertical bar" - self pasteTemp: name before: tempsMark ] - ifFalse: [ self createTempDeclarationInMethodWith: name ]. - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3977-DeclareUndeclaredInBlockFix-EricBrandwein-2019Dec12-23h47m-EB.1.cs.st----! - -'From Cuis 5.0 [latest update: #3976] on 17 December 2019 at 5:20:19 pm'! -!UndeclaredVariable methodsFor: 'exception handling - private' stamp: 'HAW 12/17/2019 17:09:06'! - declareBlockTempAction - - ^[ parser declareTemp: name at: #block ]! ! -!UndeclaredVariable methodsFor: 'exception handling - private' stamp: 'HAW 12/17/2019 17:09:53'! - declareInstanceVariableAction - - ^[ parser declareInstVar: name ]! ! -!UndeclaredVariable methodsFor: 'exception handling - private' stamp: 'HAW 12/17/2019 17:09:25'! - declareMethodTempAction - - ^[ parser declareTemp: name at: #method ].! ! -!UndeclaredVariable methodsFor: 'exception handling - private' stamp: 'HAW 12/17/2019 17:09:43' prior: 50402274! - addLocalVariableOptionsTo: labels actions: actions - - labels add: 'declare block-local temp'. - actions add: self declareBlockTempAction. - - labels add: 'declare method temp'. - actions add: self declareMethodTempAction. - - parser canDeclareInstanceVariable ifTrue: [ - labels add: 'declare instance'. - actions add: self declareInstanceVariableAction]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3978-UndeclareVariabeRefactoring-HernanWilkinson-2019Dec17-12h05m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3978] on 17 December 2019 at 7:20:58 pm'! - -RefactoringApplier subclass: #RenameTemporaryApplier - instanceVariableNames: 'classToRefactor oldVariable newVariable smalltalkEditor methodNode oldVariableNode ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameTemporaryApplier category: #'Tools-Refactoring' stamp: 'Install-3979-RenameTemporaryOnSameVarNameFix-HernanWilkinson-2019Dec17-17h22m-HAW.1.cs.st 1/11/2020 17:58:49'! -RefactoringApplier subclass: #RenameTemporaryApplier - instanceVariableNames: 'classToRefactor oldVariable newVariable smalltalkEditor methodNode oldVariableNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Refactoring subclass: #RenameTemporary - instanceVariableNames: 'oldVariableNode newVariable methodNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameTemporary category: #'Tools-Refactoring' stamp: 'Install-3979-RenameTemporaryOnSameVarNameFix-HernanWilkinson-2019Dec17-17h22m-HAW.1.cs.st 1/11/2020 17:58:49'! -Refactoring subclass: #RenameTemporary - instanceVariableNames: 'oldVariableNode newVariable methodNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!CompiledMethod methodsFor: 'testing' stamp: 'HAW 12/17/2019 19:12:33'! - hasArgumentOrTemporaryNamed: aVariable - - | methodNode | - - methodNode := self methodNode. - - ^methodNode tempNames includes: aVariable ! ! -!BlockNode methodsFor: 'testing' stamp: 'HAW 12/17/2019 19:14:02'! - isArgumentOrTemporary: aParseNode - - ^(self temporaries includes: aParseNode) or: [ self arguments includes: aParseNode ] - ! ! -!MethodNode methodsFor: 'testing' stamp: 'HAW 12/17/2019 19:12:33'! - hasArgumentOrTemporaryNamed: aVariable - - ^self tempNames includes: aVariable! ! -!MethodNode methodsFor: 'testing' stamp: 'HAW 12/17/2019 19:13:21'! - isArgumentOrTemporary: aParseNode - - ^(self temporaries includes: aParseNode) or: [ self arguments includes: aParseNode ] - ! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 12/17/2019 18:33:53'! - renameTemporary: aTemporaryNode at: aMethodNode - - self codeProvider isEditingMethod ifTrue: [ | applier | - [ applier := RenameTemporaryApplier on: self for: aTemporaryNode at: aMethodNode ] - on: SyntaxErrorNotification - do: [:anError | ^self inform: (RenameTemporaryApplier errorMessageForCanNotParseMethod: anError) ]. - applier value ]. -! ! -!RenameTemporary methodsFor: 'initialization' stamp: 'HAW 12/17/2019 19:16:57'! - initializeFromOldVariableNode: anOldVariableNode to: aNewVariable in: aMethodNode - - oldVariableNode := anOldVariableNode. - newVariable := aNewVariable. - methodNode := aMethodNode ! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 12/17/2019 19:14:24'! - assert: anOldVariableNode isPartOf: aMethodNode - - "I can not use tempNode becuase it uses scopeTable that does not have - repeated nodes for variables with same name - Hernan" - - (aMethodNode isArgumentOrTemporary: anOldVariableNode) ifTrue: [ ^self ]. - - aMethodNode nodesDo: [ :aNode | - aNode isBlockNode ifTrue: [ - (aNode isArgumentOrTemporary: anOldVariableNode) ifTrue: [ ^self ]]]. - - self signalOldVariableNodeNotPartOfMethodNode ! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 12/17/2019 18:52:51'! - assertIsArgOrTempNode: anOldVariableNode - - anOldVariableNode isTempOrArg ifFalse: [ self signalOldVariableNodeMustBeArgOrTempNodeErrorDescription ]! ! -!RenameTemporary class methodsFor: 'exceptions' stamp: 'HAW 12/17/2019 18:53:23'! - oldVariableNodeMustBeArgOrTempNodeErrorDescription - - ^'Old variable node must be argument or temporary node'! ! -!RenameTemporary class methodsFor: 'exceptions' stamp: 'HAW 12/17/2019 18:49:53'! - oldVariableNodeNotPartOfMethodNodeErrorDescription - - ^'Node of variable to rename is not part of method''s method node'! ! -!RenameTemporary class methodsFor: 'exceptions' stamp: 'HAW 12/17/2019 18:53:03'! - signalOldVariableNodeMustBeArgOrTempNodeErrorDescription - - self refactoringError: self oldVariableNodeMustBeArgOrTempNodeErrorDescription! ! -!RenameTemporary class methodsFor: 'exceptions' stamp: 'HAW 12/17/2019 18:49:23'! - signalOldVariableNodeNotPartOfMethodNode - - self refactoringError: self oldVariableNodeNotPartOfMethodNodeErrorDescription! ! -!RenameTemporary class methodsFor: 'instance creation' stamp: 'HAW 12/17/2019 19:16:57'! - fromOldVariableNode: anOldVariableNode to: aNewVariable in: aMethodNode - - | trimmedNewVariable | - - trimmedNewVariable := aNewVariable withBlanksTrimmed. - - self assertIsArgOrTempNode: anOldVariableNode. - self assert: anOldVariableNode isPartOf: aMethodNode. - self assertIsNotEmpty: trimmedNewVariable. - self assertIsValidVariableName: trimmedNewVariable. - self assert: trimmedNewVariable isNotDefinedIn: aMethodNode. - - self assert: trimmedNewVariable isNotDefinedAsInstanceVariableInHierarchyOf: aMethodNode methodClass. - - ^self new initializeFromOldVariableNode: anOldVariableNode to: trimmedNewVariable in: aMethodNode -! ! -!RenameTemporaryApplier methodsFor: 'initialization' stamp: 'HAW 12/17/2019 18:41:46'! - initializeOn: aSmalltalkEditor for: aTemporaryNode at: aMethodNode - - smalltalkEditor := aSmalltalkEditor. - classToRefactor := smalltalkEditor codeProvider selectedClassOrMetaClass. - methodNode := aMethodNode. - oldVariableNode := aTemporaryNode. - ! ! -!RenameTemporaryApplier class methodsFor: 'instance creation' stamp: 'HAW 12/17/2019 18:34:06'! - on: aSmalltalkEditor for: aTemporaryNode at: aMethodNode - - ^self new initializeOn: aSmalltalkEditor for: aTemporaryNode at: aMethodNode! ! -!Behavior methodsFor: 'accessing method dictionary' stamp: 'HAW 12/17/2019 19:12:33' prior: 50442989! - methodsWithArgumentOrTemporaryNamed: instVarName - - ^self methodsSelect: [:aMethod | aMethod hasArgumentOrTemporaryNamed: instVarName ]! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 12/17/2019 18:31:46' prior: 50469132! - contextualRenameOf: aMethodNode in: aSelectedClass - - aMethodNode - withParseNodeIncluding: self startIndex - do: [ :nodeUnderCursor | self rename: nodeUnderCursor in: aSelectedClass at: aMethodNode ] - ifAbsent: [ - self startIndex <= aMethodNode selectorLastPosition - ifTrue: [ self ifChangeSelectorCanBeAppliedDo: [ self renameSelectorFor: aMethodNode selector in: aSelectedClass ]] - ifFalse: [ morph flash ]] - - -! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 12/17/2019 18:33:32' prior: 50469149! - rename: aNodeUnderCursor in: aSelectedClass at: aMethodNode - - aNodeUnderCursor isTempOrArg ifTrue: [ ^self renameTemporary: aNodeUnderCursor at: aMethodNode ]. - - self ifChangeSelectorCanBeAppliedDo: [ - aNodeUnderCursor isMessageNode ifTrue: [ - ^ self renameSelectorOf: aNodeUnderCursor in: aSelectedClass at: aMethodNode selector ]. - aNodeUnderCursor isInstanceVariableNode ifTrue: [ - ^ self renameInstanceVariableOn: self codeProvider for: aNodeUnderCursor name at: aSelectedClass ]. - aNodeUnderCursor isLiteralVariableNode ifTrue: [ | variableName | - variableName := aNodeUnderCursor key key. - (Smalltalk classNamed: variableName) ifNotNil: [ :classToRename | - ^self renameClassOn: self codeProvider for: classToRename ]. - (Smalltalk bindingOf: variableName) ifNotNil: [ - ^self renameGlobalOn: self codeProvider for: variableName ] ]. - - ^morph flash ]! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 12/17/2019 18:38:47' prior: 50467196! - withMethodNodeAndClassDo: aBlock ifErrorsParsing: anErrorBlock - - | selectedClass methodNode | - - "I have to do this because some codeProviders do no answer selectedClassOrMetaClass like the Workspace - Hernan" - selectedClass := [ self codeProvider selectedClassOrMetaClass ] on: Error do: [ :anError | anError return: UndefinedObject ]. - [ methodNode := selectedClass methodNodeFor: model actualContents asString ] on: Error do: [ :anError | ^ anErrorBlock value: anError ]. - - ^aBlock value: methodNode value: selectedClass.! ! -!PushDownMethod class methodsFor: 'pre-conditions' stamp: 'HAW 12/17/2019 19:12:33' prior: 50484886! - addShadowedInstVarsOf: subclass in: aMethodToPushDown to: subclassesWithShadowedInstVarNames - - | shadowedInstVarNames | - - shadowedInstVarNames := subclass instVarNames select: [:instVarName | - (aMethodToPushDown hasArgumentOrTemporaryNamed: instVarName) ]. - - shadowedInstVarNames ifNotEmpty: [ - subclassesWithShadowedInstVarNames at: subclass put: shadowedInstVarNames ]! ! -!RenameTemporary methodsFor: 'applying' stamp: 'HAW 12/17/2019 18:23:43' prior: 50441011! - apply - - | newSource ranges | - - ranges := methodNode rangeForNode: oldVariableNode ifAbsent: [ #() ]. - newSource := methodNode sourceText copyReplacing: ranges with: newVariable. - - ^ newSource! ! -!RenameTemporary class methodsFor: 'instance creation - private' stamp: 'HAW 12/17/2019 19:16:37' prior: 50444637! - from: anOldVariable to: aNewVariable in: aMethodNode - - | oldVariableNode | - - "I keept this message for testing only, the applier now uses the one that receives the - old variable node, that fixes the problem when renaming a temp that is in more than - one block - Hernan" - oldVariableNode := aMethodNode tempNodes - detect: [ :aTempNode | aTempNode name = anOldVariable ] - ifNone: [ self signalTemporaryVariable: anOldVariable notDefinedIn: aMethodNode ]. - - ^self fromOldVariableNode: oldVariableNode to: aNewVariable in: aMethodNode ! ! -!RenameTemporaryApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 12/17/2019 18:41:40' prior: 50442274! - askNewVariableName - - newVariable := (self request: 'Enter new name:' initialAnswer: oldVariableNode name) withBlanksTrimmed ! ! -!RenameTemporaryApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 12/17/2019 18:40:46' prior: 50442321! - requestRefactoringParameters - - self askNewVariableName! ! -!RenameTemporaryApplier methodsFor: 'refactoring - creation' stamp: 'HAW 12/17/2019 19:15:28' prior: 50442339! - createRefactoring - - ^RenameTemporary fromOldVariableNode: oldVariableNode to: newVariable in: methodNode - ! ! - -RenameTemporaryApplier class removeSelector: #on:for:! - -!methodRemoval: RenameTemporaryApplier class #on:for: stamp: 'Install-3979-RenameTemporaryOnSameVarNameFix-HernanWilkinson-2019Dec17-17h22m-HAW.1.cs.st 1/11/2020 17:58:49'! -on: aSmalltalkEditor for: aTemporary - - ^self new initializeOn: aSmalltalkEditor for: aTemporary! - -RenameTemporaryApplier removeSelector: #selectTemporaryVariableFrom:! - -!methodRemoval: RenameTemporaryApplier #selectTemporaryVariableFrom: stamp: 'Install-3979-RenameTemporaryOnSameVarNameFix-HernanWilkinson-2019Dec17-17h22m-HAW.1.cs.st 1/11/2020 17:58:49'! -selectTemporaryVariableFrom: variables - - | selectionIndex | - - selectionIndex := (PopUpMenu labelArray: variables lines: #()) startUpWithCaption: 'Select temporary to rename'. - - ^selectionIndex = 0 - ifTrue: [ self endRequest ] - ifFalse: [ variables at: selectionIndex ]! - -RenameTemporaryApplier removeSelector: #chooseTemporaryVariable! - -!methodRemoval: RenameTemporaryApplier #chooseTemporaryVariable stamp: 'Install-3979-RenameTemporaryOnSameVarNameFix-HernanWilkinson-2019Dec17-17h22m-HAW.1.cs.st 1/11/2020 17:58:49'! -chooseTemporaryVariable - - | variables | - - oldVariable ifNotNil: [ ^self ]. - - variables := methodNode tempNames. - variables isEmpty - ifTrue: [ self noTemporaryToRename ] - ifFalse: [ self chooseTemporaryVariableFrom: variables ] - - ! - -RenameTemporaryApplier removeSelector: #noTemporaryToRename! - -!methodRemoval: RenameTemporaryApplier #noTemporaryToRename stamp: 'Install-3979-RenameTemporaryOnSameVarNameFix-HernanWilkinson-2019Dec17-17h22m-HAW.1.cs.st 1/11/2020 17:58:49'! -noTemporaryToRename - - self inform: 'There are no temporary to rename'. - self endRequest ! - -RenameTemporaryApplier removeSelector: #initializeOn:for:! - -!methodRemoval: RenameTemporaryApplier #initializeOn:for: stamp: 'Install-3979-RenameTemporaryOnSameVarNameFix-HernanWilkinson-2019Dec17-17h22m-HAW.1.cs.st 1/11/2020 17:58:49'! -initializeOn: aSmalltalkEditor for: aTemporary - - smalltalkEditor := aSmalltalkEditor. - classToRefactor := smalltalkEditor codeProvider selectedClassOrMetaClass. - methodNode := classToRefactor methodNodeFor: smalltalkEditor actualContents string. - oldVariable := aTemporary - ! - -RenameTemporaryApplier removeSelector: #is:temporaryVariableFrom:! - -!methodRemoval: RenameTemporaryApplier #is:temporaryVariableFrom: stamp: 'Install-3979-RenameTemporaryOnSameVarNameFix-HernanWilkinson-2019Dec17-17h22m-HAW.1.cs.st 1/11/2020 17:58:49'! -is: selection temporaryVariableFrom: variables - - ^smalltalkEditor hasSelection and: [variables includes: selection]! - -RenameTemporaryApplier removeSelector: #chooseTemporaryVariableFrom:! - -!methodRemoval: RenameTemporaryApplier #chooseTemporaryVariableFrom: stamp: 'Install-3979-RenameTemporaryOnSameVarNameFix-HernanWilkinson-2019Dec17-17h22m-HAW.1.cs.st 1/11/2020 17:58:49'! -chooseTemporaryVariableFrom: variables - - | selection | - - selection := smalltalkEditor selection string withBlanksTrimmed. - oldVariable := (self is: selection temporaryVariableFrom: variables) - ifTrue: [ selection ] - ifFalse: [ self selectTemporaryVariableFrom: variables]! - -RenameTemporary class removeSelector: #fromNodeOfOld:to:in:! - -RenameTemporary removeSelector: #initializeFrom:to:in:! - -!methodRemoval: RenameTemporary #initializeFrom:to:in: stamp: 'Install-3979-RenameTemporaryOnSameVarNameFix-HernanWilkinson-2019Dec17-17h22m-HAW.1.cs.st 1/11/2020 17:58:49'! -initializeFrom: anOldVariable to: aNewVariable in: aMethodNode - - oldVariable := anOldVariable. - newVariable := aNewVariable. - methodNode := aMethodNode ! - -RenameTemporary removeSelector: #initializeFromNodeOfOld:to:in:! - -SmalltalkEditor removeSelector: #renameTemporary:! - -!methodRemoval: SmalltalkEditor #renameTemporary: stamp: 'Install-3979-RenameTemporaryOnSameVarNameFix-HernanWilkinson-2019Dec17-17h22m-HAW.1.cs.st 1/11/2020 17:58:49'! -renameTemporary: aTemporaryName - - self codeProvider isEditingMethod ifTrue: [ | applier | - [ applier := RenameTemporaryApplier on: self for: aTemporaryName ] - on: SyntaxErrorNotification - do: [:anError | ^self inform: (RenameTemporaryApplier errorMessageForCanNotParseMethod: anError) ]. - applier value ]. -! - -MethodNode removeSelector: #hasArgumentOrTemporary:! - -!methodRemoval: MethodNode #hasArgumentOrTemporary: stamp: 'Install-3979-RenameTemporaryOnSameVarNameFix-HernanWilkinson-2019Dec17-17h22m-HAW.1.cs.st 1/11/2020 17:58:49'! -hasArgumentOrTemporary: aVariable - - ^self tempNames includes: aVariable! - -CompiledMethod removeSelector: #hasArgumentOrTemporary:! - -!methodRemoval: CompiledMethod #hasArgumentOrTemporary: stamp: 'Install-3979-RenameTemporaryOnSameVarNameFix-HernanWilkinson-2019Dec17-17h22m-HAW.1.cs.st 1/11/2020 17:58:49'! -hasArgumentOrTemporary: aVariable - - | methodNode | - - methodNode := self methodNode. - - ^methodNode tempNames includes: aVariable ! - -RefactoringApplier subclass: #RenameTemporaryApplier - instanceVariableNames: 'classToRefactor newVariable smalltalkEditor methodNode oldVariableNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameTemporaryApplier category: #'Tools-Refactoring' stamp: 'Install-3979-RenameTemporaryOnSameVarNameFix-HernanWilkinson-2019Dec17-17h22m-HAW.1.cs.st 1/11/2020 17:58:49'! -RefactoringApplier subclass: #RenameTemporaryApplier - instanceVariableNames: 'classToRefactor newVariable smalltalkEditor methodNode oldVariableNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Refactoring subclass: #RenameTemporary - instanceVariableNames: 'oldVariableNode newVariable methodNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameTemporary category: #'Tools-Refactoring' stamp: 'Install-3979-RenameTemporaryOnSameVarNameFix-HernanWilkinson-2019Dec17-17h22m-HAW.1.cs.st 1/11/2020 17:58:49'! -Refactoring subclass: #RenameTemporary - instanceVariableNames: 'oldVariableNode newVariable methodNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3979-RenameTemporaryOnSameVarNameFix-HernanWilkinson-2019Dec17-17h22m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3979] on 18 December 2019 at 4:07:57 pm'! - -RefactoringWarning subclass: #ReferencesRefactoringWarning - instanceVariableNames: 'references primaryReferencee allreferenced' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ReferencesRefactoringWarning category: #'Tools-Refactoring' stamp: 'Install-3980-RemovingClassWarnsForReferencesToName-HernanWilkinson-2019Dec18-11h06m-HAW.1.cs.st 1/11/2020 17:58:49'! -RefactoringWarning subclass: #ReferencesRefactoringWarning - instanceVariableNames: 'references primaryReferencee allreferenced' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Object subclass: #ClassReferencesCollector - instanceVariableNames: 'classToLookForReferences referencesToClass referencedAsClass referencesToName referencedAsName withAllSubclassesNames' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ClassReferencesCollector category: #'Tools-Refactoring' stamp: 'Install-3980-RemovingClassWarnsForReferencesToName-HernanWilkinson-2019Dec18-11h06m-HAW.1.cs.st 1/11/2020 17:58:49'! -Object subclass: #ClassReferencesCollector - instanceVariableNames: 'classToLookForReferences referencesToClass referencedAsClass referencesToName referencedAsName withAllSubclassesNames' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!CompiledMethod methodsFor: 'testing' stamp: 'HAW 12/18/2019 12:01:17'! - hasVariableBindingTo: aClass - - self literalsDo: [ :aLiteral | - (aLiteral isVariableBinding and: [ aLiteral value = aClass ]) ifTrue: [ ^true ]]. - - ^false! ! -!CanNotRefactorDueToReferencesError methodsFor: 'initialization' stamp: 'HAW 12/18/2019 12:23:57'! - initializeWith: aMessageText references: aCollectionOfReferences to: aReferencee - - self messageText: aMessageText. - references := aCollectionOfReferences. - referencee := aReferencee ! ! -!CanNotRefactorDueToReferencesError class methodsFor: 'instance creation' stamp: 'HAW 12/18/2019 12:23:36'! - with: aMessageText references: references to: aReferencee - - ^self new initializeWith: aMessageText references: references to: aReferencee! ! -!ReferencesRefactoringWarning methodsFor: 'initialization' stamp: 'HAW 12/18/2019 12:26:09'! - initializeWith: aMessageText references: aReferences of: aPrimaryReferencee toAll: anAllReferenced - - self messageText: aMessageText. - references := aReferences. - primaryReferencee := aPrimaryReferencee. - allreferenced := anAllReferenced ! ! -!ReferencesRefactoringWarning methodsFor: 'accessing' stamp: 'HAW 12/18/2019 15:14:58'! - referencee - - ^primaryReferencee ! ! -!ReferencesRefactoringWarning methodsFor: 'accessing' stamp: 'HAW 12/18/2019 15:14:48'! - references - - ^references! ! -!ReferencesRefactoringWarning methodsFor: 'references' stamp: 'HAW 12/18/2019 16:04:55'! - anyReference - - ^references anyOne ! ! -!ReferencesRefactoringWarning methodsFor: 'references' stamp: 'HAW 12/18/2019 16:04:39'! -numberOfReferences - - ^references size! ! -!ReferencesRefactoringWarning class methodsFor: 'as yet unclassified' stamp: 'HAW 12/18/2019 12:24:17'! - signal: aMessageText references: references of: primaryReferencee toAll: allReferenced - - (self with: aMessageText references: references of: primaryReferencee toAll: allReferenced) signal! ! -!ReferencesRefactoringWarning class methodsFor: 'instance creation' stamp: 'HAW 12/18/2019 12:24:55'! - with: aMessageText references: references of: primaryReferencee toAll: allReferenced - - ^self new initializeWith: aMessageText references: references of: primaryReferencee toAll: allReferenced! ! -!MethodReference methodsFor: 'testing' stamp: 'HAW 12/18/2019 11:59:43'! - hasVariableBindingTo: aClass - - ^self compiledMethod hasVariableBindingTo: aClass -! ! -!ClassReferencesCollector methodsFor: 'initialization' stamp: 'HAW 12/18/2019 15:50:25'! - initializeOf: aClassToLookForReferences - - classToLookForReferences := aClassToLookForReferences ! ! -!ClassReferencesCollector methodsFor: 'evaluating - private' stamp: 'HAW 12/18/2019 15:55:55'! - add: aClass asReferencedToClassWith: referencesToVariableBinding - - referencedAsClass add: aClass. - referencesToClass addAll: referencesToVariableBinding ! ! -!ClassReferencesCollector methodsFor: 'evaluating - private' stamp: 'HAW 12/18/2019 15:55:44'! - add: aClass asReferencedToNameWith: referencesToClassName - - referencedAsName add: aClass. - referencesToName addAll: referencesToClassName - ! ! -!ClassReferencesCollector methodsFor: 'evaluating - private' stamp: 'HAW 12/18/2019 15:55:55'! - collectReferencesOf: aClass - - | allReferences referencesOutsideHierarchy referencesToVariableBinding referencesToClassName | - - allReferences := aClass allCallsOn. - referencesOutsideHierarchy := allReferences reject: [ :aReference | withAllSubclassesNames includes: aReference classSymbol ]. - referencesToVariableBinding := referencesOutsideHierarchy select: [ :aReference | aReference hasVariableBindingTo: aClass ]. - referencesToClassName := referencesOutsideHierarchy difference: referencesToVariableBinding. - - referencesToVariableBinding notEmpty ifTrue: [ self add: aClass asReferencedToClassWith: referencesToVariableBinding ]. - referencesToClassName notEmpty ifTrue: [ self add: aClass asReferencedToNameWith: referencesToClassName ]. - ! ! -!ClassReferencesCollector methodsFor: 'evaluating - private' stamp: 'HAW 12/18/2019 15:57:22'! - initializeCollectionFor: withAllSubclasses - - withAllSubclassesNames := withAllSubclasses collect: [:aClass | aClass name ]. - referencesToClass := OrderedCollection new. - referencedAsClass := OrderedCollection new. - referencesToName := OrderedCollection new. - referencedAsName := OrderedCollection new! ! -!ClassReferencesCollector methodsFor: 'evaluating' stamp: 'HAW 12/18/2019 15:57:12'! - value - - | withAllSubclasses | - - withAllSubclasses := classToLookForReferences withAllSubclasses. - self initializeCollectionFor: withAllSubclasses. - - withAllSubclasses do: [ :aClass | self collectReferencesOf: aClass ]. - - ! ! -!ClassReferencesCollector methodsFor: 'testing' stamp: 'HAW 12/18/2019 15:58:27'! - hasReferencesToClass - - ^referencesToClass notEmpty! ! -!ClassReferencesCollector methodsFor: 'testing' stamp: 'HAW 12/18/2019 15:58:43'! - hasReferencesToName - - ^referencesToName notEmpty ! ! -!ClassReferencesCollector methodsFor: 'accessing' stamp: 'HAW 12/18/2019 15:59:32'! - referencedAsClass - - ^referencedAsClass! ! -!ClassReferencesCollector methodsFor: 'accessing' stamp: 'HAW 12/18/2019 15:59:00'! - referencedAsName - - ^referencedAsName! ! -!ClassReferencesCollector methodsFor: 'accessing' stamp: 'HAW 12/18/2019 15:59:23'! - referencesToClass - - ^referencesToClass! ! -!ClassReferencesCollector methodsFor: 'accessing' stamp: 'HAW 12/18/2019 15:58:52'! - referencesToName - - ^referencesToName! ! -!ClassReferencesCollector class methodsFor: 'evaluating' stamp: 'HAW 12/18/2019 15:49:34'! - valueOf: aClassToLookForReferences - - ^(self of: aClassToLookForReferences) value! ! -!ClassReferencesCollector class methodsFor: 'instance creation' stamp: 'HAW 12/18/2019 15:49:47'! - of: aClassToLookForReferences - - ^self new initializeOf: aClassToLookForReferences! ! -!Refactoring class methodsFor: 'warnings' stamp: 'HAW 12/18/2019 12:21:19'! - referencesWarningClass - - ^ReferencesRefactoringWarning! ! -!Refactoring class methodsFor: 'warnings' stamp: 'HAW 12/18/2019 15:37:30'! - warnAboutReferences: references with: aMessageText of: primaryReferencee toAll: allReferenced - - ^self referencesWarningClass - signal: aMessageText - references: references - of: primaryReferencee - toAll: allReferenced ! ! -!SafelyRemoveClass class methodsFor: 'warnings' stamp: 'HAW 12/18/2019 15:37:44'! - warnAboutRemoveOf: aClassToSafelyRemove dueToNameReferences: references toAll: allReferenced - - self - warnAboutReferences: references - with: (self warningMessageForReferencesToNames: allReferenced) - of: aClassToSafelyRemove - toAll: allReferenced - ! ! -!SafelyRemoveClass class methodsFor: 'warnings' stamp: 'HAW 12/18/2019 12:08:06'! - warningMessageForReferencesToNames: referenced - - ^'There are references to the name of ', referenced asCommaStringAnd ! ! -!RefactoringApplier methodsFor: 'exception handling' stamp: 'HAW 12/18/2019 15:18:30'! - handleReferencesWarning: aReferencesWarning - - | options answer question | - - options := -'Browse references and Cancel -Browse references and Continue -Continue'. - - question := PopUpMenu labels: options icons: #(cancelIcon mailForwardIcon acceptIcon). - answer := question startUpWithCaption: aReferencesWarning messageText. - - answer <= 2 ifTrue: [ self browseReferencesOn: aReferencesWarning ]. - answer = 1 ifTrue: [ self endRequest ]. - aReferencesWarning resume.! ! -!CanNotRefactorDueToReferencesError class methodsFor: 'signaling' stamp: 'HAW 12/18/2019 12:23:14' prior: 50438026! - signal: aMessageText references: references to: aReferencee - - (self with: aMessageText references: references to: aReferencee) signal! ! -!SafelyRemoveClass class methodsFor: 'instance creation' stamp: 'HAW 12/18/2019 15:18:38' prior: 50441201! - of: aClassToSafelyRemove - - | theNonMetaclassToRemove | - - theNonMetaclassToRemove := aClassToSafelyRemove theNonMetaClass. - self assertNoReferencesTo: theNonMetaclassToRemove. - self warnIfHasSubclasses: theNonMetaclassToRemove. - - ^self new initializeOf: theNonMetaclassToRemove ! ! -!SafelyRemoveClass class methodsFor: 'pre-conditions' stamp: 'HAW 12/18/2019 15:49:06' prior: 50441213! - assertNoReferencesTo: aClassToSafelyRemove - - | referencesCollector | - - referencesCollector := ClassReferencesCollector valueOf: aClassToSafelyRemove. - - referencesCollector hasReferencesToClass ifTrue: [ - ^self - signalCanNotRemove: aClassToSafelyRemove - dueToReferences: referencesCollector referencesToClass - toAll: referencesCollector referencedAsClass ]. - - referencesCollector hasReferencesToName ifTrue: [ - ^self - warnAboutRemoveOf: aClassToSafelyRemove - dueToNameReferences: referencesCollector referencesToName - toAll: referencesCollector referencedAsName ]. -! ! -!RefactoringApplier methodsFor: 'exception handling' stamp: 'HAW 12/18/2019 12:28:15' prior: 50441406! - valueHandlingRefactoringExceptions: aBlock - - ^[[[aBlock - on: Refactoring referencesWarningClass - do: [ :aReferencesRefactoringWarning | self handleReferencesWarning: aReferencesRefactoringWarning ]] - on: Refactoring refactoringWarningClass - do: [ :aRefactoringWarning | self handleRefactoringWarning: aRefactoringWarning ]] - on: Refactoring canNotRefactorDueToReferencesErrorClass - do: [ :aCanNotRefactorDueToReferencesError | self handleCanNotRefactorDueToReferencesError: aCanNotRefactorDueToReferencesError ]] - on: Refactoring refactoringErrorClass - do: [ :aRefactoringError | self handleRefactoringError: aRefactoringError ] - ! ! - -Refactoring class removeSelector: #warnAboutReferences:references:of:toAll:! - -ClassReferencesCollector removeSelector: #add:asReferenceeToClassWith:! - -CanNotRefactorDueToReferencesError removeSelector: #initialize:references:to:! - -!methodRemoval: CanNotRefactorDueToReferencesError #initialize:references:to: stamp: 'Install-3980-RemovingClassWarnsForReferencesToName-HernanWilkinson-2019Dec18-11h06m-HAW.1.cs.st 1/11/2020 17:58:49'! -initialize: aMessageText references: aCollectionOfReferences to: aReferencee - - self messageText: aMessageText. - references := aCollectionOfReferences. - referencee := aReferencee ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3980-RemovingClassWarnsForReferencesToName-HernanWilkinson-2019Dec18-11h06m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3980] on 18 December 2019 at 6:39:08 pm'! - -Refactoring subclass: #RenameInstanceVariable - instanceVariableNames: 'oldVariable renamedReferences methodsAndRangesToChange newVariable classToRefactor originalClassToRefactor ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameInstanceVariable category: #'Tools-Refactoring' stamp: 'Install-3981-RenameInstVarLogChange-HernanWilkinson-2019Dec18-17h51m-HAW.1.cs.st 1/11/2020 17:58:49'! -Refactoring subclass: #RenameInstanceVariable - instanceVariableNames: 'oldVariable renamedReferences methodsAndRangesToChange newVariable classToRefactor originalClassToRefactor' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!Behavior methodsFor: 'testing' stamp: 'HAW 12/18/2019 18:18:28'! - hasChangedComparedTo: anotherClass - - ^self superclass ~~ anotherClass superclass - or: [ self instVarNames ~= anotherClass instVarNames - or: [ self classVarNames ~= anotherClass classVarNames - or: [ self sharedPools ~= anotherClass sharedPools ]]]! ! -!ChangeSet methodsFor: 'testing' stamp: 'HAW 12/18/2019 18:37:51'! -isWithClass: aClass - - ^changeRecords includesKey: aClass name! ! -!ChangeSet class methodsFor: 'enumerating' stamp: 'HAW 12/18/2019 18:37:51'! - allChangeSetsWithClass: aClass - - ^ AllChangeSets select: [ :aChangeSet | aChangeSet isWithClass: aClass ]! ! -!RenameInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 12/18/2019 18:26:23'! - logChange - - Smalltalk - logChange: classToRefactor definition - preamble: classToRefactor definitionPreamble. - - ChangeSet - classDefinitionChangedFrom: originalClassToRefactor to: classToRefactor ! ! -!ChangeSet methodsFor: 'system change notifications' stamp: 'HAW 12/18/2019 18:18:57' prior: 16798726! - classDefinitionChangedFrom: oldClass to: newClass - - (newClass hasChangedComparedTo: oldClass) ifTrue: [ - self noteChangeClass: newClass from: oldClass ]! ! -!RenameInstanceVariable methodsFor: 'applying' stamp: 'HAW 12/18/2019 18:26:00' prior: 50478157! - apply - - originalClassToRefactor := classToRefactor copy. - - self - lookForMethodsReferencingOldVariable; - changeInstanceVariableName; - logChange; - renameReferencesToOldVariable. - - ^renamedReferences - ! ! - -RenameInstanceVariable removeSelector: #logClassDefinition! - -!methodRemoval: RenameInstanceVariable #logClassDefinition stamp: 'Install-3981-RenameInstVarLogChange-HernanWilkinson-2019Dec18-17h51m-HAW.1.cs.st 1/11/2020 17:58:49'! -logClassDefinition - - Smalltalk - logChange: classToRefactor definition - preamble: classToRefactor definitionPreamble.! - -ChangeSet class removeSelector: #allChangeSetWithClass:! - -ChangeSet removeSelector: #isForClass:! - -Refactoring subclass: #RenameInstanceVariable - instanceVariableNames: 'oldVariable renamedReferences methodsAndRangesToChange newVariable classToRefactor originalClassToRefactor' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RenameInstanceVariable category: #'Tools-Refactoring' stamp: 'Install-3981-RenameInstVarLogChange-HernanWilkinson-2019Dec18-17h51m-HAW.1.cs.st 1/11/2020 17:58:49'! -Refactoring subclass: #RenameInstanceVariable - instanceVariableNames: 'oldVariable renamedReferences methodsAndRangesToChange newVariable classToRefactor originalClassToRefactor' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3981-RenameInstVarLogChange-HernanWilkinson-2019Dec18-17h51m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3981] on 18 December 2019 at 8:57:41 pm'! -!ChangeSet class methodsFor: 'system change notifications' stamp: 'HAW 12/18/2019 19:57:53' prior: 50482925! - aboutToRenameClass: aClass from: oldClassName to: newClassName inCategory: aCategoryName - - | packageOrNil | - - aClass wantsChangeSetLogging ifFalse: [ ^self ]. - - packageOrNil _ CodePackage packageOfSystemCategory: aCategoryName ifNone: nil. - (self changeSetForPackage: packageOrNil) ifNotNil: [ :changeSet | - changeSet - aboutToRenameClass: aClass - from: oldClassName - to: newClassName - inCategory: aCategoryName ]. - packageOrNil ifNotNil: [ - packageOrNil hasUnsavedChanges: true ]! ! -!ChangeSet class methodsFor: 'system change notifications' stamp: 'HAW 12/18/2019 19:57:46' prior: 16798884! - classAdded: aClass inCategory: aCategoryName - - | packageOrNil | - - aClass wantsChangeSetLogging ifFalse: [ ^self ]. - - packageOrNil _ CodePackage packageOfSystemCategory: aCategoryName ifNone: nil. - (self changeSetForPackage: packageOrNil) ifNotNil: [ :changeSet | - changeSet classAdded: aClass inCategory: aCategoryName ]. - packageOrNil ifNotNil: [ - packageOrNil hasUnsavedChanges: true ]! ! -!ChangeSet class methodsFor: 'system change notifications' stamp: 'HAW 12/18/2019 19:58:08' prior: 16798898! - classCommented: aClass - - | packageOrNil | - - aClass wantsChangeSetLogging ifFalse: [ ^self ]. - - packageOrNil _ CodePackage packageOfClass: aClass ifNone: nil. - (self changeSetForPackage: packageOrNil) ifNotNil: [ :changeSet | - changeSet classCommented: aClass ]. - packageOrNil ifNotNil: [ - packageOrNil hasUnsavedChanges: true ].! ! -!ChangeSet class methodsFor: 'system change notifications' stamp: 'HAW 12/18/2019 19:58:19' prior: 16798910! - classDefinitionChangedFrom: oldClass to: newClass - "In case the class is moved from one package to another, both change sets should be affected. - But there's no need to do it here, as #classRecategorized:from:to: is also called." - - | packageOrNil | - - newClass wantsChangeSetLogging ifFalse: [ ^self ]. - - packageOrNil _ CodePackage packageOfClass: newClass ifNone: nil. - (self changeSetForPackage: packageOrNil) ifNotNil: [ :changeSet | - changeSet classDefinitionChangedFrom: oldClass to: newClass ]. - packageOrNil ifNotNil: [ - packageOrNil hasUnsavedChanges: true ]! ! -!ChangeSet class methodsFor: 'system change notifications' stamp: 'HAW 12/18/2019 19:58:38' prior: 16798929! - classRecategorized: aClass from: oldCategory to: newCategory - "If the class was moved to a dfferent package, out of the base system, record the fact in the change set. - The actual class redefinition is done at #classDefinitionChangedFrom:to: that is also called (if the class really changed)." - - | oldPackageOrNil newPackageOrNil newChangeSet | - - aClass wantsChangeSetLogging ifFalse: [ ^self ]. - - newPackageOrNil _ CodePackage - packageOfSystemCategory: newCategory - ifNone: nil. - newPackageOrNil ifNotNil: [ newPackageOrNil hasUnsavedChanges: true ]. - newChangeSet _ ChangeSet changeSetForPackage: newPackageOrNil. - newChangeSet noteRecategorizationOfClass: aClass. - - oldPackageOrNil _ CodePackage - packageOfSystemCategory: oldCategory - ifNone: nil. - oldPackageOrNil - ifNotNil: [ oldPackageOrNil hasUnsavedChanges: true ] - ifNil: [ - "If destination is a package, but source isn't, then record the change in the base system changeset" - newPackageOrNil ifNotNil: [ - self changeSetForBaseSystem noteClassMoveToOtherPackage: aClass ]]! ! -!ChangeSet class methodsFor: 'system change notifications' stamp: 'HAW 12/18/2019 19:59:02' prior: 16798963! - classRemoved: aClass fromCategory: aCategoryName - - | packageOrNil | - - aClass wantsChangeSetLogging ifFalse: [ ^self ]. - - packageOrNil _ CodePackage packageOfSystemCategory: aCategoryName ifNone: nil. - (self changeSetForPackage: packageOrNil) ifNotNil: [ :changeSet | - changeSet classRemoved: aClass fromCategory: aCategoryName ]. - packageOrNil ifNotNil: [ - packageOrNil hasUnsavedChanges: true ]! ! -!ChangeSet class methodsFor: 'system change notifications' stamp: 'HAW 12/18/2019 19:59:14' prior: 16798994! -classReorganized: aClass - - | packageOrNil | - - aClass wantsChangeSetLogging ifFalse: [ ^self ]. - - packageOrNil _ CodePackage packageOfClass: aClass ifNone: nil. - (self changeSetForPackage: packageOrNil) ifNotNil: [ :changeSet | - changeSet classReorganized: aClass ]. - packageOrNil ifNotNil: [ - packageOrNil hasUnsavedChanges: true ]! ! -!ChangeSet class methodsFor: 'system change notifications' stamp: 'HAW 12/18/2019 19:59:24' prior: 16799006! -methodAdded: aCompiledMethod selector: aSymbol inClass: aClass requestor: requestor - - | packageOrNil | - - aClass wantsChangeSetLogging ifFalse: [ ^self ]. - - packageOrNil _ CodePackage packageOfMethod: aCompiledMethod methodReference ifNone: nil. - (self changeSetForPackage: packageOrNil) ifNotNil: [ :changeSet | - changeSet - methodAdded: aCompiledMethod - selector: aSymbol - inClass: aClass - requestor: requestor ]. - packageOrNil ifNotNil: [ - packageOrNil hasUnsavedChanges: true ]! ! -!ChangeSet class methodsFor: 'system change notifications' stamp: 'HAW 12/18/2019 19:59:32' prior: 16799023! - methodAdded: aCompiledMethod selector: aSymbol inProtocol: aCategoryName class: aClass requestor: requestor - - | packageOrNil | - - aClass wantsChangeSetLogging ifFalse: [ ^self ]. - - packageOrNil _ CodePackage packageOfMethod: aCompiledMethod methodReference ifNone: nil. - (self changeSetForPackage: packageOrNil) ifNotNil: [ :changeSet | - changeSet - methodAdded: aCompiledMethod - selector: aSymbol - inProtocol: aCategoryName - class: aClass - requestor: requestor ]. - packageOrNil ifNotNil: [ - packageOrNil hasUnsavedChanges: true ]! ! -!ChangeSet class methodsFor: 'system change notifications' stamp: 'HAW 12/18/2019 19:59:39' prior: 16799042! - methodChangedFrom: oldMethod to: newMethod selector: aSymbol inClass: aClass requestor: requestor - - | packageOrNil | - - aClass wantsChangeSetLogging ifFalse: [ ^self ]. - - packageOrNil _ CodePackage packageOfMethod: newMethod methodReference ifNone: nil. - (self changeSetForPackage: packageOrNil) ifNotNil: [ :changeSet | - changeSet - methodChangedFrom: oldMethod - to: newMethod - selector: aSymbol - inClass: aClass - requestor: requestor ]. - packageOrNil ifNotNil: [ - packageOrNil hasUnsavedChanges: true ]! ! -!ChangeSet class methodsFor: 'system change notifications' stamp: 'HAW 12/18/2019 19:59:51' prior: 16799060! - methodRemoved: aCompiledMethod selector: aSymbol inProtocol: aCategoryName class: aClass - - | packageOrNil | - - aClass wantsChangeSetLogging ifFalse: [ ^self ]. - - packageOrNil _ CodePackage packageOfMethodCategory: aCategoryName ofClass: aClass ifNone: nil. - (self changeSetForPackage: packageOrNil) ifNotNil: [ :changeSet | - changeSet - methodRemoved: aCompiledMethod - selector: aSymbol - inProtocol: aCategoryName - class: aClass ]. - packageOrNil ifNotNil: [ - packageOrNil hasUnsavedChanges: true ]! ! -!ChangeSet class methodsFor: 'system change notifications' stamp: 'HAW 12/18/2019 20:00:33' prior: 16799078! - selectorRecategorized: selector from: oldCategory to: newCategory inClass: aClass - "If the method was moved to a dfferent package, affect the package that lost the it. Tell it that it lost the method. - The actual method redefinition is done at one of the method definition methods, that is also called." - - | newPackageOrNil newChangeSet oldPackageOrNil | - - aClass wantsChangeSetLogging ifFalse: [ ^self ]. - - newPackageOrNil _ CodePackage packageOfMethodCategory: newCategory ofClass: aClass ifNone: nil. - newPackageOrNil ifNotNil: [ newPackageOrNil hasUnsavedChanges: true ]. - newChangeSet _ ChangeSet changeSetForPackage: newPackageOrNil. - newChangeSet selectorRecategorized: selector from: oldCategory to: newCategory inClass: aClass. - - oldPackageOrNil _ CodePackage packageOfMethodCategory: oldCategory ofClass: aClass ifNone: nil. - oldPackageOrNil - ifNotNil: [ oldPackageOrNil hasUnsavedChanges: true ] - ifNil: [ - "If destination is a package, but source isn't, then record the change in the base system changeset" - newPackageOrNil ifNotNil: [ - self changeSetForBaseSystem noteMethodMoveToOtherPackage: selector forClass: aClass ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3982-wantsChangeSetLoggingFix-HernanWilkinson-2019Dec18-19h57m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3982] on 20 December 2019 at 8:59:35 pm'! -!Parser methodsFor: 'error correction' stamp: 'EB 12/20/2019 20:54:07' prior: 50486033! - pasteTemp: tempName inBlock: aBlockNode - - | theTextString blockTempsMark | - - theTextString := requestor text string. - blockTempsMark := aBlockNode tempsMark + requestorOffset. - - (theTextString at: blockTempsMark) = $| - ifTrue: [ - "Paste it before the second vertical bar" - self pasteTemp: tempName before: blockTempsMark ] - ifFalse: [ - "The tempsMark is at the beginning of the block, we should insert after it." - self createTempDeclarationInBlockWith: tempName before: blockTempsMark ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3983-DeclareMoreThanOneUndeclaredInSameBlock-EricBrandwein-2019Dec20-20h02m-EB.1.cs.st----! - -'From Cuis 5.0 [latest update: #3979] on 18 December 2019 at 6:58:51 pm'! - -ParseNodeVisitor subclass: #BlockNodeParentsFinder - instanceVariableNames: 'selectedBlockNode root parents found' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #BlockNodeParentsFinder category: #'Tools-Refactoring' stamp: 'Install-3984-RenameTemporaryWithOtherBlocksDeclaringNewVariable-EricBrandwein-2019Dec18-16h29m-EB.1.cs.st 1/11/2020 17:58:49'! -ParseNodeVisitor subclass: #BlockNodeParentsFinder - instanceVariableNames: 'selectedBlockNode root parents found' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!BlockNodeParentsFinder commentStamp: 'EB 12/18/2019 18:55:03' prior: 0! - I find the BlockNode parents of a BlockNode in the ParseNode tree starting from a ParseNode supplied to #parentsIn:. ! -!BlockNodeParentsFinder methodsFor: 'initializing' stamp: 'EB 12/18/2019 18:09:42'! - initializeFor: aSelectedBlockNode - - selectedBlockNode := aSelectedBlockNode. - parents := OrderedCollection new. - found := false.! ! -!BlockNodeParentsFinder methodsFor: 'visiting' stamp: 'EB 12/18/2019 18:09:00'! - visitBlockNode: aBlockNode - - found ifFalse: [ - aBlockNode = selectedBlockNode - ifTrue: [ found := true ] - ifFalse: [ - parents add: aBlockNode. - super visitBlockNode: aBlockNode. - found ifFalse: [ parents removeLast ] - ] - ] - - - ! ! -!BlockNodeParentsFinder methodsFor: 'accessing' stamp: 'EB 12/18/2019 18:13:27'! - parentsIn: aParseNode - - aParseNode accept: self. - ^parents! ! -!BlockNodeParentsFinder class methodsFor: 'instance creation' stamp: 'EB 12/18/2019 18:10:08'! - for: aSelectedBlockNode - - ^self new initializeFor: aSelectedBlockNode.! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'EB 12/18/2019 17:01:45'! - any: someBlockOrMethodNodes declaresTempNamed: aTempName - - ^someBlockOrMethodNodes anySatisfy: [ :node | - self is: aTempName declaredIn: node ]! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'EB 12/18/2019 18:50:44'! - assert: aTempName isNotDeclaredInParseTreeBranchOfNodeDeclaring: aTempNode in: aMethodNode - - | blockNode | - - blockNode := self blockNodeDeclaringTempNode: aTempNode in: aMethodNode. - ((self is: aTempName declaredInChildrenOf: blockNode) or: [ - self is: aTempName declaredInParentsOf: blockNode in: aMethodNode ]) - ifTrue: [ self signalNewTemporaryVariable: aTempName isAlreadyDefinedIn: aMethodNode ].! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'EB 12/18/2019 18:51:30'! - blockNodeDeclaringTempNode: aTempNode in: aMethodNode - - | blockNode | - - aMethodNode nodesDo: [ :node | - (node isBlockNode and: [ node isArgumentOrTemporary: aTempNode ]) - ifTrue: [ blockNode := node ]]. - blockNode ifNil: [ blockNode := aMethodNode body ]. - ^blockNode! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'EB 12/18/2019 17:01:52'! - is: aTempName declaredIn: aBlockOrMethodNode - - ^(aBlockOrMethodNode temporaries union: aBlockOrMethodNode arguments) anySatisfy: [ :tempNode | - tempNode name = aTempName ]! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'EB 12/18/2019 18:36:52'! - is: aTempName declaredInChildrenOf: aBlockNode - - aBlockNode nodesDo: [ :node | - (node isBlockNode and: [ self is: aTempName declaredIn: node ]) ifTrue: [^true]]. - ^false! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'EB 12/18/2019 18:53:37'! - is: aTempName declaredInParentsOf: aBlockNode in: aMethodNode - - | parents | - - parents := (BlockNodeParentsFinder for: aBlockNode) parentsIn: aMethodNode. - parents add: aMethodNode. - ^self any: parents declaresTempNamed: aTempName! ! -!RenameTemporary class methodsFor: 'instance creation' stamp: 'EB 12/18/2019 18:47:12' prior: 50486291! - fromOldVariableNode: anOldVariableNode to: aNewVariable in: aMethodNode - - | trimmedNewVariable | - - trimmedNewVariable := aNewVariable withBlanksTrimmed. - - self assertIsArgOrTempNode: anOldVariableNode. - self assert: anOldVariableNode isPartOf: aMethodNode. - self assertIsNotEmpty: trimmedNewVariable. - self assertIsValidVariableName: trimmedNewVariable. - self assert: trimmedNewVariable isNotDeclaredInParseTreeBranchOfNodeDeclaring: anOldVariableNode in: aMethodNode. - self assert: trimmedNewVariable isNotDefinedAsInstanceVariableInHierarchyOf: aMethodNode methodClass. - - ^self new initializeFromOldVariableNode: anOldVariableNode to: trimmedNewVariable in: aMethodNode -! ! - -RenameTemporary class removeSelector: #assert:isNotDefinedIn:! - -!methodRemoval: RenameTemporary class #assert:isNotDefinedIn: stamp: 'Install-3984-RenameTemporaryWithOtherBlocksDeclaringNewVariable-EricBrandwein-2019Dec18-16h29m-EB.1.cs.st 1/11/2020 17:58:49'! -assert: aNewVariable isNotDefinedIn: aMethodNode - - (aMethodNode tempNames includes: aNewVariable) ifTrue: [ self signalNewTemporaryVariable: aNewVariable isAlreadyDefinedIn: aMethodNode ] - ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3984-RenameTemporaryWithOtherBlocksDeclaringNewVariable-EricBrandwein-2019Dec18-16h29m-EB.1.cs.st----! - -'From Cuis 5.0 [latest update: #3984] on 22 December 2019 at 8:33:28 pm'! -!ParseNode methodsFor: 'testing' stamp: 'HAW 12/22/2019 20:21:52'! - hasNodeIn: aCollectionOfNodes named: aName - - ^aCollectionOfNodes anySatisfy: [ :tempNode | tempNode name = aName ]! ! -!BlockNode methodsFor: 'testing' stamp: 'HAW 12/22/2019 20:22:33'! - hasLocallyArgumentOrTemporaryNamed: aVariableName - - ^(self hasNodeIn: self temporaries named: aVariableName) - or: [self hasNodeIn: self arguments named: aVariableName ]! ! -!BlockNode methodsFor: 'testing' stamp: 'HAW 12/22/2019 20:30:26'! - isLocalArgumentOrTemporary: aParseNode - - ^(self temporaries includes: aParseNode) or: [ self arguments includes: aParseNode ] - ! ! -!MethodNode methodsFor: 'testing' stamp: 'HAW 12/22/2019 20:28:55'! - hasLocallyArgumentOrTemporaryNamed: aVariableName - - "See #hasArgumentOrTemporaryNamed: comment - Hernan" - ^(self hasNodeIn: self temporaries named: aVariableName) - or: [self hasNodeIn: self arguments named: aVariableName ]! ! -!MethodNode methodsFor: 'testing' stamp: 'HAW 12/22/2019 20:30:47'! - isLocalArgumentOrTemporary: aParseNode - - "Looks only in this scope - Hernan" - ^(self temporaries includes: aParseNode) or: [ self arguments includes: aParseNode ] - ! ! -!CompiledMethod methodsFor: 'testing' stamp: 'HAW 12/22/2019 20:23:52' prior: 50486189! -hasArgumentOrTemporaryNamed: aVariable - - ^self methodNode hasArgumentOrTemporaryNamed: aVariable -! ! -!MethodNode methodsFor: 'testing' stamp: 'HAW 12/22/2019 20:28:34' prior: 50486203! - hasArgumentOrTemporaryNamed: aVariableName - - " - - hasArgumentOrTemporaryNamed: returns true if there is a temp or variable in this scope or subscopes - named aVariableName - - hasLocalName: returns true if there is a variable in the scopeTable name aVariableName. That includes - temps, arguments, instance variables and pseudo-variables - - hasLocallyArgumentOrTemporaryNamed: returns true if ony this scope defines a temp or argument - named aVariableName. - Hernan" - ^self tempNames includes: aVariableName! ! -!MethodNode methodsFor: 'testing' stamp: 'HAW 12/22/2019 20:28:48' prior: 50443678! - hasLocalNamed: aName - - "See #hasArgumentOrTemporaryNamed: comment - Hernan" - ^ encoder hasLocalNamed: aName ! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 12/22/2019 20:20:02' prior: 50487512! - any: someBlockOrMethodNodes declaresTempNamed: aTempName - - ^someBlockOrMethodNodes anySatisfy: [ :node | node hasLocallyArgumentOrTemporaryNamed: aTempName]! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 12/22/2019 20:30:26' prior: 50486238! - assert: anOldVariableNode isPartOf: aMethodNode - - "I can not use tempNode becuase it uses scopeTable that does not have - repeated nodes for variables with same name - Hernan" - - (aMethodNode isLocalArgumentOrTemporary: anOldVariableNode) ifTrue: [ ^self ]. - - aMethodNode nodesDo: [ :aNode | - aNode isBlockNode ifTrue: [ - (aNode isLocalArgumentOrTemporary: anOldVariableNode) ifTrue: [ ^self ]]]. - - self signalOldVariableNodeNotPartOfMethodNode ! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 12/22/2019 20:33:00' prior: 50487536! - blockNodeDeclaringTempNode: aTempNode in: aMethodNode - - | blockNode | - - aMethodNode nodesDo: [ :node | - (node isBlockNode and: [ node isLocalArgumentOrTemporary: aTempNode ]) - ifTrue: [ blockNode := node ]]. - blockNode ifNil: [ blockNode := aMethodNode body ]. - - ^blockNode! ! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'HAW 12/22/2019 20:20:14' prior: 50487557! -is: aTempName declaredInChildrenOf: aBlockNode - - aBlockNode nodesDo: [ :node | - (node isBlockNode and: [ node hasLocallyArgumentOrTemporaryNamed: aTempName ]) ifTrue: [^true]]. - - ^false! ! - -RenameTemporary class removeSelector: #is:declaredIn:! - -!methodRemoval: RenameTemporary class #is:declaredIn: stamp: 'Install-3985-RenameTemporaryRefactors-HernanWilkinson-2019Dec22-20h17m-HAW.1.cs.st 1/11/2020 17:58:49'! -is: aTempName declaredIn: aBlockOrMethodNode - - ^(aBlockOrMethodNode temporaries union: aBlockOrMethodNode arguments) anySatisfy: [ :tempNode | - tempNode name = aTempName ]! - -MethodNode removeSelector: #isArgumentOrTemporary:! - -!methodRemoval: MethodNode #isArgumentOrTemporary: stamp: 'Install-3985-RenameTemporaryRefactors-HernanWilkinson-2019Dec22-20h17m-HAW.1.cs.st 1/11/2020 17:58:49'! -isArgumentOrTemporary: aParseNode - - ^(self temporaries includes: aParseNode) or: [ self arguments includes: aParseNode ] - ! - -BlockNode removeSelector: #isArgumentOrTemporary:! - -!methodRemoval: BlockNode #isArgumentOrTemporary: stamp: 'Install-3985-RenameTemporaryRefactors-HernanWilkinson-2019Dec22-20h17m-HAW.1.cs.st 1/11/2020 17:58:49'! -isArgumentOrTemporary: aParseNode - - ^(self temporaries includes: aParseNode) or: [ self arguments includes: aParseNode ] - ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3985-RenameTemporaryRefactors-HernanWilkinson-2019Dec22-20h17m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3985] on 23 December 2019 at 7:21:35 am'! - -ParseNode subclass: #CodeNode - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #CodeNode category: #'Compiler-ParseNodes' stamp: 'Install-3986-CodeNodeRefactoring-HernanWilkinson-2019Dec23-07h12m-HAW.1.cs.st 1/11/2020 17:58:49'! -ParseNode subclass: #CodeNode - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -CodeNode subclass: #BlockNode - instanceVariableNames: 'arguments statements returns nArgsNode size remoteCopyNode temporaries optimized optimizedMessageNode actualScopeIfOptimized blockExtent remoteTempNode copiedValues closureCreationNode startOfLastStatement tempsMark ' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #BlockNode category: #'Compiler-ParseNodes' stamp: 'Install-3986-CodeNodeRefactoring-HernanWilkinson-2019Dec23-07h12m-HAW.1.cs.st 1/11/2020 17:58:49'! -CodeNode subclass: #BlockNode - instanceVariableNames: 'arguments statements returns nArgsNode size remoteCopyNode temporaries optimized optimizedMessageNode actualScopeIfOptimized blockExtent remoteTempNode copiedValues closureCreationNode startOfLastStatement tempsMark' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -CodeNode subclass: #MethodNode - instanceVariableNames: 'selectorOrFalse precedence arguments block primitive encoder temporaries properties sourceText locationCounter localsPool selectorKeywordsRanges ' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #MethodNode category: #'Compiler-ParseNodes' stamp: 'Install-3986-CodeNodeRefactoring-HernanWilkinson-2019Dec23-07h12m-HAW.1.cs.st 1/11/2020 17:58:49'! -CodeNode subclass: #MethodNode - instanceVariableNames: 'selectorOrFalse precedence arguments block primitive encoder temporaries properties sourceText locationCounter localsPool selectorKeywordsRanges' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! -!CodeNode methodsFor: 'accessing' stamp: 'HAW 12/23/2019 07:13:13'! - arguments - - self subclassResponsibility ! ! -!CodeNode methodsFor: 'accessing' stamp: 'HAW 12/23/2019 07:13:20'! - temporaries - - self subclassResponsibility ! ! -!CodeNode methodsFor: 'testing' stamp: 'HAW 12/23/2019 07:14:12'! - hasLocallyArgumentOrTemporaryNamed: aVariableName - - "See #hasArgumentOrTemporaryNamed: comment - Hernan" - ^(self hasNodeIn: self temporaries named: aVariableName) - or: [self hasNodeIn: self arguments named: aVariableName ]! ! -!CodeNode methodsFor: 'testing' stamp: 'HAW 12/23/2019 07:16:18'! - hasNodeIn: aCollectionOfNodes named: aName - - ^aCollectionOfNodes anySatisfy: [ :tempNode | tempNode name = aName ]! ! -!CodeNode methodsFor: 'testing' stamp: 'HAW 12/23/2019 07:15:28'! - isLocalArgumentOrTemporary: aParseNode - - "Looks only in this scope - Hernan" - ^(self temporaries includes: aParseNode) or: [ self arguments includes: aParseNode ] - ! ! - -CodeNode removeSelector: #hasArgumentOrTemporaryNamed:! - -CodeNode subclass: #BlockNode - instanceVariableNames: 'arguments statements returns nArgsNode size remoteCopyNode temporaries optimized optimizedMessageNode actualScopeIfOptimized blockExtent remoteTempNode copiedValues closureCreationNode startOfLastStatement tempsMark' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #BlockNode category: #'Compiler-ParseNodes' stamp: 'Install-3986-CodeNodeRefactoring-HernanWilkinson-2019Dec23-07h12m-HAW.1.cs.st 1/11/2020 17:58:49'! -CodeNode subclass: #BlockNode - instanceVariableNames: 'arguments statements returns nArgsNode size remoteCopyNode temporaries optimized optimizedMessageNode actualScopeIfOptimized blockExtent remoteTempNode copiedValues closureCreationNode startOfLastStatement tempsMark' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -CodeNode subclass: #MethodNode - instanceVariableNames: 'selectorOrFalse precedence arguments block primitive encoder temporaries properties sourceText locationCounter localsPool selectorKeywordsRanges' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #MethodNode category: #'Compiler-ParseNodes' stamp: 'Install-3986-CodeNodeRefactoring-HernanWilkinson-2019Dec23-07h12m-HAW.1.cs.st 1/11/2020 17:58:49'! -CodeNode subclass: #MethodNode - instanceVariableNames: 'selectorOrFalse precedence arguments block primitive encoder temporaries properties sourceText locationCounter localsPool selectorKeywordsRanges' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3986-CodeNodeRefactoring-HernanWilkinson-2019Dec23-07h12m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3985] on 23 December 2019 at 7:26:58 am'! -!CodeNode methodsFor: 'testing' stamp: 'HAW 12/23/2019 07:24:08' prior: 50487855! - hasLocallyArgumentOrTemporaryNamed: aVariableName - - "- hasArgumentOrTemporaryNamed: returns true if there is a temp or variable in this scope or subscopes - named aVariableName - - hasLocalName: returns true if there is a variable in the scopeTable name aVariableName. That includes - temps, arguments, instance variables and pseudo-variables - - hasLocallyArgumentOrTemporaryNamed: returns true if ony this scope defines a temp or argument - named aVariableName. - Hernan" - - ^(self hasNodeIn: self temporaries named: aVariableName) - or: [self hasNodeIn: self arguments named: aVariableName ]! ! -!MethodNode methodsFor: 'testing' stamp: 'HAW 12/23/2019 07:24:55' prior: 50487668! - hasArgumentOrTemporaryNamed: aVariableName - - "See #hasLocallyArgumentOrTemporaryNamed: comment - Hernan" - - ^self tempNames includes: aVariableName! ! -!MethodNode methodsFor: 'testing' stamp: 'HAW 12/23/2019 07:25:03' prior: 50487687! - hasLocalNamed: aName - - "See #hasLocallyArgumentOrTemporaryNamed: comment - Hernan" - - ^ encoder hasLocalNamed: aName ! ! - -MethodNode removeSelector: #hasLocallyArgumentOrTemporaryNamed:! - -!methodRemoval: MethodNode #hasLocallyArgumentOrTemporaryNamed: stamp: 'Install-3987-CodeNodeRefactoring2-HernanWilkinson-2019Dec23-07h21m-HAW.1.cs.st 1/11/2020 17:58:49'! -hasLocallyArgumentOrTemporaryNamed: aVariableName - - "See #hasArgumentOrTemporaryNamed: comment - Hernan" - ^(self hasNodeIn: self temporaries named: aVariableName) - or: [self hasNodeIn: self arguments named: aVariableName ]! - -MethodNode removeSelector: #isLocalArgumentOrTemporary:! - -!methodRemoval: MethodNode #isLocalArgumentOrTemporary: stamp: 'Install-3987-CodeNodeRefactoring2-HernanWilkinson-2019Dec23-07h21m-HAW.1.cs.st 1/11/2020 17:58:49'! -isLocalArgumentOrTemporary: aParseNode - - "Looks only in this scope - Hernan" - ^(self temporaries includes: aParseNode) or: [ self arguments includes: aParseNode ] - ! - -BlockNode removeSelector: #hasLocallyArgumentOrTemporaryNamed:! - -!methodRemoval: BlockNode #hasLocallyArgumentOrTemporaryNamed: stamp: 'Install-3987-CodeNodeRefactoring2-HernanWilkinson-2019Dec23-07h21m-HAW.1.cs.st 1/11/2020 17:58:49'! -hasLocallyArgumentOrTemporaryNamed: aVariableName - - ^(self hasNodeIn: self temporaries named: aVariableName) - or: [self hasNodeIn: self arguments named: aVariableName ]! - -BlockNode removeSelector: #isLocalArgumentOrTemporary:! - -!methodRemoval: BlockNode #isLocalArgumentOrTemporary: stamp: 'Install-3987-CodeNodeRefactoring2-HernanWilkinson-2019Dec23-07h21m-HAW.1.cs.st 1/11/2020 17:58:49'! -isLocalArgumentOrTemporary: aParseNode - - ^(self temporaries includes: aParseNode) or: [ self arguments includes: aParseNode ] - ! - -ParseNode removeSelector: #hasNodeIn:named:! - -!methodRemoval: ParseNode #hasNodeIn:named: stamp: 'Install-3987-CodeNodeRefactoring2-HernanWilkinson-2019Dec23-07h21m-HAW.1.cs.st 1/11/2020 17:58:50'! -hasNodeIn: aCollectionOfNodes named: aName - - ^aCollectionOfNodes anySatisfy: [ :tempNode | tempNode name = aName ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3987-CodeNodeRefactoring2-HernanWilkinson-2019Dec23-07h21m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3987] on 23 December 2019 at 8:33:32 am'! -!CodeNode methodsFor: 'accessing' stamp: 'HAW 12/23/2019 08:32:49'! - arguments: aCollectionOfArguments - - self subclassResponsibility ! ! -!CodeNode methodsFor: 'accessing' stamp: 'HAW 12/23/2019 08:29:27'! - block - - self subclassResponsibility ! ! -!CodeNode methodsFor: 'accessing' stamp: 'HAW 12/23/2019 08:31:57'! - temporaries: aCollectionOfTemporaries - - self subclassResponsibility ! ! -!CodeNode methodsFor: 'printing' stamp: 'HAW 12/23/2019 08:30:31'! - decompileString - - self subclassResponsibility ! ! -!BlockNode methodsFor: 'accessing' stamp: 'HAW 12/23/2019 08:32:32' prior: 16789587! - arguments: aCollectionOfArguments - "Decompile." - - arguments := aCollectionOfArguments! ! -!BlockNode methodsFor: 'accessing' stamp: 'HAW 12/23/2019 08:31:43' prior: 50462164! - temporaries: aCollectionOfTemporaries - "Collection of TempVariableNodes" - temporaries := aCollectionOfTemporaries! ! -!MethodNode methodsFor: 'accessing' stamp: 'HAW 12/23/2019 08:32:45' prior: 16872338! - arguments: aCollectionOfArguments - - "For transformations etc, not used in compilation" - arguments := aCollectionOfArguments! ! -!MethodNode methodsFor: 'accessing' stamp: 'HAW 12/23/2019 08:31:49' prior: 16872401! - temporaries: aCollectionOfTemporaries - "For transformations etc, not used in compilation" - temporaries := aCollectionOfTemporaries! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3988-CodeNodeRefactoring3-HernanWilkinson-2019Dec23-08h29m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3983] on 22 December 2019 at 7:34:47 pm'! - -ParseNodeVisitor subclass: #ArgumentDeclarationCounter - instanceVariableNames: 'argumentName counter' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ArgumentDeclarationCounter category: #'Tools-Refactoring' stamp: 'Install-3989-TemporaryToInstanceVariableWithArgumentsFix-EricBrandwein-2019Dec22-17h06m-EB.1.cs.st 1/11/2020 17:58:50'! -ParseNodeVisitor subclass: #ArgumentDeclarationCounter - instanceVariableNames: 'argumentName counter' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Smalltalk renameClassNamed: #ParseNodesDeclaringTemporaryVariableVisitor as: #ParseNodesDeclaringTemporaryVariableVisitor! - -Smalltalk renameClassNamed: #TemporaryVariableDeclarationCounter as: #TemporaryVariableDeclarationCounter! -!TemporaryVariableDeclarationRemover commentStamp: '' prior: 0! -I remove declarations of a temporary variable from the children of a ParseNode.! -!ArgumentDeclarationCounter methodsFor: 'initialization' stamp: 'EB 12/22/2019 19:14:35'! - initializeFor: anArgumentName - - argumentName := anArgumentName. - counter := 0! ! -!ArgumentDeclarationCounter methodsFor: 'visiting' stamp: 'EB 12/22/2019 19:21:08'! - declaresSoughtArgument: aParseNode - - ^aParseNode arguments anySatisfy: [ :argument | argument name = argumentName ]! ! -!ArgumentDeclarationCounter methodsFor: 'visiting' stamp: 'EB 12/22/2019 19:18:07'! - visitBlockNode: aBlockNode - - self visitPotentiallyDeclaringParseNode: aBlockNode. - super visitBlockNode: aBlockNode! ! -!ArgumentDeclarationCounter methodsFor: 'visiting' stamp: 'EB 12/22/2019 19:17:52'! - visitMethodNode: aMethodNode - - self visitPotentiallyDeclaringParseNode: aMethodNode. - super visitMethodNode: aMethodNode! ! -!ArgumentDeclarationCounter methodsFor: 'visiting' stamp: 'EB 12/22/2019 19:22:02'! - visitPotentiallyDeclaringParseNode: aParseNode - - (self declaresSoughtArgument: aParseNode) ifTrue: [ counter := counter + 1 ]! ! -!ArgumentDeclarationCounter methodsFor: 'accessing' stamp: 'EB 12/22/2019 19:12:12'! - count - - ^counter! ! -!ArgumentDeclarationCounter class methodsFor: 'instance creation' stamp: 'EB 12/22/2019 19:14:12'! - for: anArgumentName - - ^self new initializeFor: anArgumentName ! ! -!ParseNodesDeclaringTemporaryVariableVisitor methodsFor: 'visiting' stamp: 'EB 12/22/2019 18:41:19' prior: 50461921! - isNodeDeclaringTemporary: aParseNode - - ^aParseNode temporaries anySatisfy: [ :temporaryVariableNode | - temporaryVariableNode key = temporaryVariable - ].! ! -!SmalltalkEditor methodsFor: 'temp to inst var' stamp: 'EB 12/22/2019 19:31:10' prior: 50459449! - temporaryToInstanceVariable - - self - withNodeUnderCursorDo: [ :nodeUnderCursor | - (nodeUnderCursor isTemp and: [nodeUnderCursor isArg not]) - ifTrue: [ TemporaryToInstanceVariableApplier on: self for: nodeUnderCursor name :: value ] - ifFalse: [ morph flash ]] - ifAbsent: [ morph flash ].! ! -!TemporaryToInstanceVariable class methodsFor: 'assertions' stamp: 'EB 12/22/2019 18:48:54' prior: 50459553! - assert: aMethodNode hasTemporaryNamed: aTemporaryVariableName - - | counter | - - counter := TemporaryVariableDeclarationCounter for: aTemporaryVariableName. - aMethodNode accept: counter. - - counter count = 1 :: ifFalse: [ - self refactoringError: self inexistentTemporaryErrorDescription ].! ! -!TemporaryToInstanceVariable class methodsFor: 'assertions' stamp: 'EB 12/22/2019 19:32:35' prior: 50461848! - assertNoOtherBlockIn: aMethodNode definesTemporaryNamed: aTemporaryVariableName - - | temporaryCounter argumentCounter | - - temporaryCounter := TemporaryVariableDeclarationCounter for: aTemporaryVariableName. - aMethodNode accept: temporaryCounter. - - argumentCounter := ArgumentDeclarationCounter for: aTemporaryVariableName. - aMethodNode accept: argumentCounter. - - temporaryCounter count + argumentCounter count > 1 ifTrue: [ - self refactoringError: self temporaryExistsInOtherBlockErrorDescription ]. - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3989-TemporaryToInstanceVariableWithArgumentsFix-EricBrandwein-2019Dec22-17h06m-EB.1.cs.st----! - -'From Cuis 5.0 [latest update: #3987] on 23 December 2019 at 8:59:27 am'! -!CodeNode methodsFor: 'testing' stamp: 'HAW 12/23/2019 08:49:29'! - hasLocallyArgumentNamed: aVariableName - - ^self hasNodeIn: self arguments named: aVariableName! ! -!CodeNode methodsFor: 'testing' stamp: 'HAW 12/23/2019 08:49:24'! - hasLocallyTemporaryNamed: aVariableName - - ^self hasNodeIn: self temporaries named: aVariableName ! ! -!CodeNode methodsFor: 'testing' stamp: 'HAW 12/23/2019 08:47:40' prior: 50487939! - hasLocallyArgumentOrTemporaryNamed: aVariableName - - "- hasArgumentOrTemporaryNamed: returns true if there is a temp or variable in this scope or subscopes - named aVariableName - - hasLocalName: returns true if there is a variable in the scopeTable name aVariableName. That includes - temps, arguments, instance variables and pseudo-variables - - hasLocallyArgumentOrTemporaryNamed: returns true if ony this scope defines a temp or argument - named aVariableName. - Hernan" - - ^(self hasLocallyArgumentNamed: aVariableName) - or: [self hasLocallyTemporaryNamed: aVariableName]! ! -!ArgumentDeclarationCounter methodsFor: 'visiting' stamp: 'HAW 12/23/2019 08:48:15' prior: 50488133! - declaresSoughtArgument: aParseNode - - ^aParseNode hasLocallyArgumentNamed: argumentName - - ! ! -!ParseNodesDeclaringTemporaryVariableVisitor methodsFor: 'visiting' stamp: 'HAW 12/23/2019 08:51:24' prior: 50488171! - isNodeDeclaringTemporary: aParseNode - - ^aParseNode hasLocallyTemporaryNamed: temporaryVariable - ! ! -!ParseNodesDeclaringTemporaryVariableVisitor methodsFor: 'visiting' stamp: 'HAW 12/23/2019 08:53:50' prior: 50461930! - visitBlockNode: aBlockNode - - (self isNodeDeclaringTemporary: aBlockNode) ifTrue: [ - self visitBlockNodeDeclaringTemporary: aBlockNode ]. - - super visitBlockNode: aBlockNode.! ! -!ParseNodesDeclaringTemporaryVariableVisitor methodsFor: 'visiting' stamp: 'HAW 12/23/2019 08:53:57' prior: 50461945! - visitMethodNode: aMethodNode - - (self isNodeDeclaringTemporary: aMethodNode) ifTrue: [ - self visitMethodNodeDeclaringTemporary: aMethodNode ]. - - super visitMethodNode: aMethodNode.! ! -!TemporaryVariableDeclarationRemover methodsFor: 'visiting' stamp: 'HAW 12/23/2019 08:54:15' prior: 50462137! - visitNodeDeclaringTemporary: aParseNode - withTemporaryDeclarationLineRemover: aTemporaryDeclarationLineRemovingBlock - - newSourceCode _ self - sourceTextWithoutTemporaryFromParseNode: aParseNode - withTemporaryDeclarationLineRemover: aTemporaryDeclarationLineRemovingBlock. - - methodNode methodClass compile: newSourceCode.! ! -!TemporaryToInstanceVariable class methodsFor: 'assertions' stamp: 'HAW 12/23/2019 08:52:40' prior: 50488192! - assert: aMethodNode hasTemporaryNamed: aTemporaryVariableName - - | counter | - - counter := TemporaryVariableDeclarationCounter for: aTemporaryVariableName. - aMethodNode accept: counter. - - counter count = 1 ifFalse: [ - self refactoringError: self inexistentTemporaryErrorDescription ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3990-TemporaryToInstanceVariableWithArgumentsRefactoring-HernanWilkinson-2019Dec23-08h47m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3982] on 20 December 2019 at 8:56:58 pm'! - -"Change Set: 3983-CuisCore-AuthorName-2019Dec20-20h38m -Date: 20 December 2019 -Author: Nahuel Garbezza - -Extract Method refactoring"! - -Refactoring subclass: #ExtractMethod - instanceVariableNames: 'intervalToExtract categoryOfNewSelector newMessage extractedSourceCode existingMethod' - classVariableNames: '' - poolDictionaries: '' - category: 'Refactorings-ExtractMethod'! - -!classDefinition: #ExtractMethod category: #'Refactorings-ExtractMethod' stamp: 'Install-3991-ExtractMethod-NahuelGarbezza-2019Dec20-20h38m-RNG.1.cs.st 1/11/2020 17:58:50'! -Refactoring subclass: #ExtractMethod - instanceVariableNames: 'intervalToExtract categoryOfNewSelector newMessage extractedSourceCode existingMethod' - classVariableNames: '' - poolDictionaries: '' - category: 'Refactorings-ExtractMethod'! - -RefactoringApplier subclass: #ExtractMethodApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newSelector newMessageArguments' - classVariableNames: '' - poolDictionaries: '' - category: 'Refactorings-ExtractMethod'! - -!classDefinition: #ExtractMethodApplier category: #'Refactorings-ExtractMethod' stamp: 'Install-3991-ExtractMethod-NahuelGarbezza-2019Dec20-20h38m-RNG.1.cs.st 1/11/2020 17:58:50'! -RefactoringApplier subclass: #ExtractMethodApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newSelector newMessageArguments' - classVariableNames: '' - poolDictionaries: '' - category: 'Refactorings-ExtractMethod'! - -RefactoringPrecondition subclass: #ExtractMethodNewSelectorPrecondition - instanceVariableNames: 'selectorToValidate classToDefineSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Refactorings-ExtractMethod'! - -!classDefinition: #ExtractMethodNewSelectorPrecondition category: #'Refactorings-ExtractMethod' stamp: 'Install-3991-ExtractMethod-NahuelGarbezza-2019Dec20-20h38m-RNG.1.cs.st 1/11/2020 17:58:50'! -RefactoringPrecondition subclass: #ExtractMethodNewSelectorPrecondition - instanceVariableNames: 'selectorToValidate classToDefineSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Refactorings-ExtractMethod'! - -Object subclass: #ExtractMethodEditorMenu - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Refactorings-ExtractMethod'! - -!classDefinition: #ExtractMethodEditorMenu category: #'Refactorings-ExtractMethod' stamp: 'Install-3991-ExtractMethod-NahuelGarbezza-2019Dec20-20h38m-RNG.1.cs.st 1/11/2020 17:58:50'! -Object subclass: #ExtractMethodEditorMenu - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Refactorings-ExtractMethod'! - -Object subclass: #ExtractMethodExpressionValidation - instanceVariableNames: 'method intervalToExtract methodNode sourceCode initialNode finalNode initialNodeAncestors finalNodeAncestors' - classVariableNames: '' - poolDictionaries: '' - category: 'Refactorings-ExtractMethod'! - -!classDefinition: #ExtractMethodExpressionValidation category: #'Refactorings-ExtractMethod' stamp: 'Install-3991-ExtractMethod-NahuelGarbezza-2019Dec20-20h38m-RNG.1.cs.st 1/11/2020 17:58:50'! -Object subclass: #ExtractMethodExpressionValidation - instanceVariableNames: 'method intervalToExtract methodNode sourceCode initialNode finalNode initialNodeAncestors finalNodeAncestors' - classVariableNames: '' - poolDictionaries: '' - category: 'Refactorings-ExtractMethod'! - -Object subclass: #ExtractMethodIntervalTrimmer - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Refactorings-ExtractMethod'! - -!classDefinition: #ExtractMethodIntervalTrimmer category: #'Refactorings-ExtractMethod' stamp: 'Install-3991-ExtractMethod-NahuelGarbezza-2019Dec20-20h38m-RNG.1.cs.st 1/11/2020 17:58:50'! -Object subclass: #ExtractMethodIntervalTrimmer - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Refactorings-ExtractMethod'! -!Message methodsFor: 'accessing' stamp: 'RNG 6/23/2019 20:03:36'! - fullName - - ^ String streamContents: [ :messageStream | - args - ifEmpty: [ messageStream nextPutAll: selector ] - ifNotEmpty: [ - self selector keywords withIndexDo: [ :keyword :index | - messageStream - nextPutAll: keyword; - nextPut: Character space; - nextPutAll: (args at: index). - "add an space unless it's the last keyword" - index = self selector keywords size ifFalse: [ messageStream nextPut: Character space ] - ] - ]. - ]! ! -!Symbol methodsFor: 'testing' stamp: 'RNG 9/10/2019 19:09:10'! - isValidSelector - - ^ (self isUnary and: [ self allSatisfy: [ :character | character isValidInIdentifiers ] ]) - or: [ self isKeyword and: [ self keywords allSatisfy: [ :keywordString | keywordString allButLast asSymbol isValidSelector ] ] ]! ! -!ParseNode methodsFor: 'testing' stamp: 'RNG 9/28/2019 01:40:07'! - equivalentTo: aParseNode - - ^ aParseNode isTemp and: [ self key = aParseNode key ]! ! -!ParseNode methodsFor: 'testing' stamp: 'RNG 9/8/2019 19:05:07'! - isAssignmentToTemporary - - ^ false! ! -!ParseNode methodsFor: 'private' stamp: 'RNG 9/10/2019 17:12:27'! - consolidateAsCollection: sourceRanges - - ^ sourceRanges isInterval - ifTrue: [ OrderedCollection with: sourceRanges ] - ifFalse: [ sourceRanges ]! ! -!ParseNode methodsFor: 'source ranges' stamp: 'RNG 9/7/2019 20:05:56'! - expandIfEnclosedWithParentheses: sourceRange on: sourceCode - - | startsWithParen endsWithParen | - self flag: #RNG. "take into account other cases: spaces in middle, multiple parenthesis" - startsWithParen _ (sourceCode at: sourceRange first - 1 ifAbsent: [nil]) = $(. - endsWithParen _ (sourceCode at: sourceRange last + 1 ifAbsent: [nil]) = $). - ^ startsWithParen & endsWithParen - ifTrue: [ sourceRange first - 1 to: sourceRange last + 1 ] - ifFalse: [ sourceRange ]! ! -!ParseNode methodsFor: 'source ranges' stamp: 'RNG 7/9/2019 15:55:40'! - expandRange: aSourceRange basedOn: sourceRangesOfChildNode - - | intervals | - intervals _ sourceRangesOfChildNode isInterval - ifTrue: [ OrderedCollection with: sourceRangesOfChildNode ] ifFalse: [ sourceRangesOfChildNode ]. - intervals withIndexDo: [ :interval :index | - (interval first > aSourceRange first) ifTrue: [ - ^ (aSourceRange first min: (intervals at: index - 1 ifAbsent: [ intervals last ]) first) to: aSourceRange last ] ]. - ^ (aSourceRange first min: intervals last first) to: aSourceRange last! ! -!ParseNode methodsFor: 'source ranges' stamp: 'RNG 9/10/2019 17:33:30'! - expandRanges: sourceRanges basedOn: allSourceRanges using: sourceCode - - ^ (self consolidateAsCollection: sourceRanges) - collect: [ :sourceRange | self expandIfEnclosedWithParentheses: sourceRange on: sourceCode ]! ! -!Encoder methodsFor: 'source mapping' stamp: 'RNG 9/7/2019 19:58:40'! - completeSourceRangesBasedOn: sourceCode - - | completeSourceRanges | - completeSourceRanges _ Dictionary new. - sourceRanges keysAndValuesDo: [ :parseNode :nodeRanges | - | expandedNodeSourceRanges | - expandedNodeSourceRanges _ parseNode expandRanges: nodeRanges basedOn: sourceRanges using: sourceCode. - completeSourceRanges at: parseNode put: expandedNodeSourceRanges ]. - ^ completeSourceRanges! ! -!Encoder methodsFor: 'source mapping' stamp: 'RNG 7/9/2019 11:14:09'! - parseNodesPathAt: aPosition using: expandedSourceRanges ifAbsent: aBlockClosure - - | nodesWithRangeAtPosition | - nodesWithRangeAtPosition _ SortedCollection sortBlock: [ :nodePathOne :nodePathTwo | - nodePathOne value first >= nodePathTwo value first and: [ - nodePathOne value last <= nodePathTwo value last ] ]. - - expandedSourceRanges associationsDo: [ :nodeAtRange | - self withRangesOf: nodeAtRange including: aPosition do: [ :aRange | - nodesWithRangeAtPosition add: (nodeAtRange key -> aRange) ] ]. - - ^ nodesWithRangeAtPosition - ifEmpty: aBlockClosure - ifNotEmpty: [ nodesWithRangeAtPosition ]! ! -!AssignmentNode methodsFor: 'testing' stamp: 'RNG 9/8/2019 19:03:48'! - isAssignmentToTemporary - - ^ self isAssignmentNode and: [ variable isTemp ]! ! -!AssignmentNode methodsFor: 'source ranges' stamp: 'RNG 12/20/2019 20:51:44'! - expandRanges: sourceRanges basedOn: allSourceRanges using: sourceCode - - ^ self consolidateAsCollection: (self - expandRange: (sourceRanges isInterval ifTrue: [ sourceRanges ] ifFalse: [ sourceRanges first ]) - basedOn: (allSourceRanges at: variable))! ! -!BlockNode methodsFor: 'testing' stamp: 'RNG 12/20/2019 20:49:06'! - hasArgumentOrTemporaryNamed: aName - - ^ (temporaries union: arguments) anySatisfy: [ :temp | temp isNamed: aName ]! ! -!BlockNode methodsFor: 'source ranges' stamp: 'RNG 9/10/2019 17:13:25'! - expandRanges: sourceRanges basedOn: allSourceRanges using: sourceCode - "the closure creation node already contains the source ranges including the [ ] and arguments declaration" - - ^ self consolidateAsCollection: (allSourceRanges at: closureCreationNode)! ! -!LiteralNode methodsFor: 'testing' stamp: 'RNG 9/19/2019 21:32:10'! - equivalentTo: aParseNode - - ^ aParseNode isLiteralNode and: [ self key = aParseNode key ]! ! -!VariableNode methodsFor: 'testing' stamp: 'RNG 9/8/2019 20:46:04'! -isNamed: aName - - ^ self name = aName! ! -!MessageNode methodsFor: 'source ranges' stamp: 'RNG 9/19/2019 21:16:03'! - expandRanges: aSourceRange basedOn: sourceRanges using: sourceCode - - | receiverExpandedRanges expandedRangeWithReceiver | - receiverExpandedRanges _ self isCascade - ifTrue: [ self flag: #RNG . aSourceRange ] "fix source ranges for cascade messages" - ifFalse: [ receiver expandRanges: (self receiverSourceRangesFrom: sourceRanges) basedOn: sourceRanges using: sourceCode ]. - expandedRangeWithReceiver _ self - expandRange: (aSourceRange isInterval ifTrue: [ aSourceRange ] ifFalse: [ aSourceRange first ]) - basedOn: receiverExpandedRanges. - ^ self consolidateAsCollection: (self expandIfEnclosedWithParentheses: expandedRangeWithReceiver on: sourceCode)! ! -!MessageNode methodsFor: 'source ranges' stamp: 'RNG 9/19/2019 21:24:41'! - receiverSourceRangesFrom: sourceRanges - "we can't just do #at: because sometimes what it is on the source ranges map - is not the exact same object than the receiver or the originalReceiver - (like when optimizations are made), so we look for an 'equivalent' one - (at least for using as a key in the source ranges)" - - ^ sourceRanges at: receiver ifAbsent: [ - | parseNodeOfReceiver | - parseNodeOfReceiver _ sourceRanges keys detect: [ :parseNode | - (parseNode equivalentTo: receiver) or: [ parseNode equivalentTo: originalReceiver ] ]. - sourceRanges at: parseNodeOfReceiver - ]! ! -!MessageNode methodsFor: 'testing' stamp: 'RNG 9/19/2019 21:31:18'! - equivalentTo: aParseNode - - self flag: #RNG. "complete definition by checking each argument" - ^ aParseNode isMessageNode - :: and: [ self receiver equivalentTo: aParseNode ] - :: and: [ self selector = aParseNode selector ] - :: and: [ self arguments isEmpty ]! ! -!MethodNode methodsFor: '*Refactorings-ExtractMethod' stamp: 'RNG 9/10/2019 17:19:25'! - allParseNodesWithin: aSourceCodeInterval satisfy: aCondition - - self completeSourceRangesDo: [ :parseNode :sourceRanges | - (aCondition value: parseNode) ifTrue: [ - sourceRanges anySatisfy: [ :sourceRange | aSourceCodeInterval rangeIncludes: sourceRange first ] - :: ifTrue: [ ^ false ] - ] ]. - ^ true! ! -!MethodNode methodsFor: '*Refactorings-ExtractMethod' stamp: 'RNG 9/7/2019 20:00:55'! - completeSourceRanges - "Returns the 'expanded' version of the source ranges, for instance in message sends it also includes the receiver, and if there are parentheses they are included in the source range as well. Right now used for refactorings." - - ^ encoder completeSourceRangesBasedOn: self sourceText! ! -!MethodNode methodsFor: '*Refactorings-ExtractMethod' stamp: 'RNG 9/10/2019 17:10:08'! - completeSourceRangesDo: aBinaryBlock - "block has to receive parse node and collection of source ranges" - - ^ self completeSourceRanges keysAndValuesDo: aBinaryBlock! ! -!MethodNode methodsFor: '*Refactorings-ExtractMethod' stamp: 'RNG 9/7/2019 19:41:58'! - parseNodesPathAt: aPosition ifAbsent: aBlockClosure - - ^ encoder - parseNodesPathAt: aPosition - using: self completeSourceRanges - ifAbsent: aBlockClosure! ! -!SmalltalkEditor methodsFor: 'extract method' stamp: 'RNG 12/20/2019 20:54:56'! - extractMethod - - "hack to prevent the extract method to be evaluated on editors w/o methods like the workspace" - self codeProvider respondsTo: #currentCompiledMethod - :: and: [ self codeProvider currentCompiledMethod notNil ] - :: ifFalse: [ ^ nil ]. - - morph owningWindow okToChange ifTrue: [ - ExtractMethodApplier createAndValueHandlingExceptions: [ - ExtractMethodApplier for: self selectionInterval of: self codeProvider currentCompiledMethod ] ]! ! -!SmalltalkEditor methodsFor: 'extract method' stamp: 'RNG 5/9/2019 00:06:54'! - extractMethod: aKeyboardEvent - - self extractMethod. - ^true! ! -!ExtractMethod methodsFor: 'applying' stamp: 'RNG 4/29/2019 00:45:18'! - apply - - self - defineExtractedMethod; - changeExistingMethod! ! -!ExtractMethod methodsFor: 'applying' stamp: 'RNG 6/23/2019 20:29:44'! - changeExistingMethod - - self sourceClass - compile: self updatedSourceCodeOfExistingMethod - classified: existingMethod category! ! -!ExtractMethod methodsFor: 'applying' stamp: 'RNG 6/23/2019 20:25:44'! - defineExtractedMethod - - self sourceClass - compile: self newMethodSourceCode - classified: categoryOfNewSelector! ! -!ExtractMethod methodsFor: 'initialization' stamp: 'RNG 6/23/2019 20:29:44'! - initializeExtractedSourceCode - - extractedSourceCode _ existingMethod sourceCode - copyFrom: intervalToExtract first - to: intervalToExtract last! ! -!ExtractMethod methodsFor: 'initialization' stamp: 'RNG 6/23/2019 20:29:44'! - initializeFrom: anIntervalToExtract of: aMethodToExtractCodeFrom to: aNewMessage in: aCategory - - intervalToExtract _ anIntervalToExtract. - existingMethod _ aMethodToExtractCodeFrom. - newMessage _ aNewMessage. - categoryOfNewSelector _ aCategory. - self initializeExtractedSourceCode.! ! -!ExtractMethod methodsFor: 'private - source code' stamp: 'RNG 10/13/2019 19:00:16'! - callingExpression - - | expression | - expression _ 'self ', self newMessageString. - - ^ self shouldBeEnclosedWithParens - ifTrue: [ '(' , expression , ')' ] - ifFalse: [ expression ]! ! -!ExtractMethod methodsFor: 'private - source code' stamp: 'RNG 6/23/2019 19:57:48'! - newMessageString - - ^ newMessage fullName! ! -!ExtractMethod methodsFor: 'private - source code' stamp: 'RNG 9/19/2019 22:04:14'! -newMethodSourceCode - - ^ self newMessageString - , self startingMethodIdentation - , self returnCharacterIfNeeded - , extractedSourceCode! ! -!ExtractMethod methodsFor: 'private - source code' stamp: 'RNG 6/23/2019 20:26:40'! - returnCharacterIfNeeded - - | parseNode | - parseNode _ Parser parse: extractedSourceCode class: self sourceClass noPattern: true. - ^ parseNode block statements size = 1 ifTrue: [ '^ ' ] ifFalse: [ '' ]! ! -!ExtractMethod methodsFor: 'private - source code' stamp: 'RNG 10/13/2019 18:58:51'! -shouldBeEnclosedWithParens - - | initialNode finalNode parseNodesInCommon methodNode initialNodeAncestors finalNodeAncestors insideMessageNodeExpressions | - - methodNode _ existingMethod methodNode. - initialNodeAncestors _ methodNode parseNodesPathAt: intervalToExtract first ifAbsent: [ ^ false]. - finalNodeAncestors _ methodNode parseNodesPathAt: intervalToExtract last ifAbsent: [ ^ false ]. - parseNodesInCommon _ initialNodeAncestors intersection: finalNodeAncestors. - - initialNode _ (parseNodesInCommon at: 1 ifAbsent: [ ^ false ]) key. - finalNode _ (parseNodesInCommon at: 2 ifAbsent: [ ^ false ]) key. - insideMessageNodeExpressions _ initialNode isMessageNode and: [ finalNode isMessageNode ]. - - ^ insideMessageNodeExpressions - and: [ initialNode precedence < newMessage selector precedence ] - :: and: [ initialNode precedence <= finalNode precedence ]! ! -!ExtractMethod methodsFor: 'private - source code' stamp: 'RNG 6/23/2019 20:29:44'! - sourceClass - - ^ existingMethod methodClass! ! -!ExtractMethod methodsFor: 'private - source code' stamp: 'RNG 9/19/2019 22:04:09'! - startingMethodIdentation - - ^ String lfString , String lfString , String tab! ! -!ExtractMethod methodsFor: 'private - source code' stamp: 'RNG 10/13/2019 18:26:11'! - updatedSourceCodeOfExistingMethod - - ^ existingMethod sourceCode - copyReplaceFrom: intervalToExtract first - to: intervalToExtract last - with: self callingExpression! ! -!ExtractMethod class methodsFor: 'validations' stamp: 'RNG 5/4/2019 22:40:07'! - ensure: aSelector canBeDefinedIn: aClass - - ExtractMethodNewSelectorPrecondition valueFor: aSelector on: aClass! ! -!ExtractMethod class methodsFor: 'validations' stamp: 'RNG 9/7/2019 19:23:53'! - ensure: anIntervalToExtract isValidIntervalOn: aMethodToExtractCodeFrom - - self isNotEmpty: anIntervalToExtract - :: ifFalse: [ self signalNoSelectedCodeError ]. - self is: anIntervalToExtract withinBoundsOf: aMethodToExtractCodeFrom sourceCode - :: ifFalse: [ self signalOutOfBoundsIntervalError ]. - self method: aMethodToExtractCodeFrom containsAValidExpressionOn: anIntervalToExtract - :: ifFalse: [ self signalSelectedCodeIsInvalidForExtractError ].! ! -!ExtractMethod class methodsFor: 'validations - private' stamp: 'RNG 5/28/2019 00:22:21'! - is: anIntervalToExtract withinBoundsOf: aSourceCode - - ^ anIntervalToExtract first >= 1 and: [ anIntervalToExtract last <= aSourceCode size ]! ! -!ExtractMethod class methodsFor: 'validations - private' stamp: 'RNG 9/7/2019 19:26:15'! - isNotEmpty: anInterval - - ^ anInterval first <= anInterval last! ! -!ExtractMethod class methodsFor: 'validations - private' stamp: 'RNG 7/6/2019 20:06:09'! - method: aMethod containsAValidExpressionOn: anIntervalToExtract - - ^ (ExtractMethodExpressionValidation for: anIntervalToExtract of: aMethod) passed! ! -!ExtractMethod class methodsFor: 'error messages' stamp: 'RNG 9/7/2019 19:20:33'! - noSelectionErrorMessage - - ^ 'Please select some code for extraction'! ! -!ExtractMethod class methodsFor: 'error messages' stamp: 'RNG 4/20/2019 21:53:45'! - outOfBoundsSelectionErrorMessage - - ^ 'The source code selection interval is out of bounds'! ! -!ExtractMethod class methodsFor: 'error messages' stamp: 'RNG 5/12/2019 23:42:45'! - selectedCodeInvalidForExtractErrorMessage - - ^ 'The selected code can not be extracted to a method'! ! -!ExtractMethod class methodsFor: 'exceptions' stamp: 'RNG 9/7/2019 19:24:57'! - signalNoSelectedCodeError - - self refactoringError: self noSelectionErrorMessage! ! -!ExtractMethod class methodsFor: 'exceptions' stamp: 'RNG 4/20/2019 21:53:24'! - signalOutOfBoundsIntervalError - - self refactoringError: self outOfBoundsSelectionErrorMessage! ! -!ExtractMethod class methodsFor: 'exceptions' stamp: 'RNG 5/12/2019 23:54:19'! - signalSelectedCodeIsInvalidForExtractError - - self refactoringError: self selectedCodeInvalidForExtractErrorMessage! ! -!ExtractMethod class methodsFor: 'instance creation' stamp: 'RNG 6/23/2019 18:24:36'! - fromInterval: anIntervalToExtract of: aMethodToExtractCodeFrom to: newMessage categorizedAs: aCategory - - | trimmedIntervalToExtract | - trimmedIntervalToExtract _ ExtractMethodIntervalTrimmer - trim: anIntervalToExtract locatedIn: aMethodToExtractCodeFrom sourceCode. - self - ensure: newMessage selector canBeDefinedIn: aMethodToExtractCodeFrom methodClass; - ensure: trimmedIntervalToExtract isValidIntervalOn: aMethodToExtractCodeFrom. - - ^ self new - initializeFrom: trimmedIntervalToExtract - of: aMethodToExtractCodeFrom - to: newMessage - in: aCategory! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 9/10/2019 17:26:45'! - blockNodesEnclosingIntervalToExtract - - | nodes | - nodes _ Set new. - methodToExtractCodeFrom methodNode completeSourceRangesDo: [ :parseNode :sourceRanges | - parseNode isBlockNode - :: and: [ self intervalToExtractIsCoveredByAnyOf: sourceRanges ] - :: ifTrue: [ nodes add: parseNode ] ]. - ^ nodes! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 9/10/2019 18:31:16'! - buildInitialSelectorAnswer: parseNodesToParameterize - "builds a selector with the shape of #m1 if unary, or #m1: something m2: else if it has args" - - ^ parseNodesToParameterize - ifEmpty: [ self formatAsKeyword: 'm1' ] - ifNotEmpty: [ parseNodesToParameterize - inject: '' - into: [ :partialSelector :parseNode | - | currentKeyword | - currentKeyword _ 'm' , (parseNodesToParameterize indexOf: parseNode) asString , ': '. - partialSelector - , (self formatAsKeyword: currentKeyword) - , (self formatAsMethodArgument: parseNode name) - , String newLineString ] ]! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 12/20/2019 20:48:35'! - definedInOuterScope: parseNode - - ^ self nodesThatAddVariablesToScope - anySatisfy: [ :node | node hasArgumentOrTemporaryNamed: parseNode name ]! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 9/10/2019 18:30:31'! - formatAsKeyword: aKeyword - - ^ Text - string: aKeyword - attributes: (SHTextStylerST80 attributesFor: #patternKeyword)! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 9/10/2019 18:31:37'! - formatAsMethodArgument: aMethodArgumentName - - ^ Text - string: aMethodArgumentName - attributes: (SHTextStylerST80 attributesFor: #methodArg)! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 9/10/2019 17:26:57'! - intervalToExtractIsCoveredByAnyOf: sourceRanges - - ^ sourceRanges anySatisfy: [ :sourceRange | - sourceRange first < intervalToExtract first - and: [ sourceRange last > intervalToExtract last ] ]! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 9/10/2019 17:30:00'! - nodesThatAddVariablesToScope - - ^ (Set with: methodToExtractCodeFrom methodNode) , self blockNodesEnclosingIntervalToExtract! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 9/10/2019 17:15:34'! - parseNodesToParameterize - - | parseNodesFound | - parseNodesFound _ OrderedCollection new. - methodToExtractCodeFrom methodNode completeSourceRangesDo: [ :parseNode :sourceRanges | - (self shouldBeParameterized: parseNode appearingIn: sourceRanges) - ifTrue: [ parseNodesFound add: parseNode ] - ]. - ^ parseNodesFound! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 9/8/2019 20:51:17'! - saveBinaryOrKeywordSelector: userAnswer withArguments: parseNodesToParameterize - - self saveMessageArgumentsForEach: parseNodesToParameterize using: userAnswer. - newSelector _ '' join: (self selectorTokensOf: userAnswer) :: asSymbol.! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 9/19/2019 22:11:12'! - saveMessageArgumentsForEach: parseNodesToParameterize using: userAnswer - - | newSelectorKeywords | - newSelectorKeywords _ self selectorTokensOf: userAnswer. - self validateRequiredParameters: parseNodesToParameterize haveACorrespondingKeywordIn: newSelectorKeywords. - parseNodesToParameterize withIndexDo: [ :parseNode :index | - newMessageArguments at: (newSelectorKeywords at: index) put: parseNode ]! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 9/8/2019 20:55:52'! - selectorTokensOf: userAnswer - "this selects the pieces of strings before each $:" - - ^ (userAnswer findTokens: ':') allButLast - collect: [ :tok | (tok findTokens: Character separators) last , ':' ]! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 9/10/2019 17:16:48'! - shouldBeParameterized: parseNode appearingIn: sourceRanges - - ^ sourceRanges anySatisfy: [ :sourceRange | intervalToExtract includes: sourceRange first ] - :: and: [ parseNode isTempOrArg ] - :: and: [ self definedInOuterScope: parseNode ]! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 9/19/2019 20:43:42'! - signalExtractMethodWithWrongNumberOfArgumentsError - - ^ ExtractMethod refactoringError: 'The number of arguments in the entered selector is not correct'! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 9/19/2019 22:11:43'! - validateRequiredParameters: parseNodesToParameterize haveACorrespondingKeywordIn: newSelectorKeywords - - newSelectorKeywords size = parseNodesToParameterize size - ifFalse: [ self signalExtractMethodWithWrongNumberOfArgumentsError ]! ! -!ExtractMethodApplier methodsFor: 'refactoring - parameters request' stamp: 'RNG 9/10/2019 18:23:12'! - requestRefactoringParameters - - | parseNodesToParameterize initialAnswer userAnswer | - parseNodesToParameterize _ self parseNodesToParameterize. - initialAnswer _ self buildInitialSelectorAnswer: parseNodesToParameterize. - userAnswer _ self request: 'New method name:' initialAnswer: initialAnswer. - - parseNodesToParameterize - ifEmpty: [ self saveUnarySelector: userAnswer ] - ifNotEmpty: [ self saveBinaryOrKeywordSelector: userAnswer withArguments: parseNodesToParameterize ]! ! -!ExtractMethodApplier methodsFor: 'initialization' stamp: 'RNG 6/23/2019 19:08:58'! - initializeFor: anIntervalToExtract of: aMethodToExtractCodeFrom - - intervalToExtract _ anIntervalToExtract. - methodToExtractCodeFrom _ aMethodToExtractCodeFrom. - newMessageArguments _ Dictionary new! ! -!ExtractMethodApplier methodsFor: 'private - new message' stamp: 'RNG 9/8/2019 20:39:42'! - buildNewMessage - - ^ Message - selector: newSelector - arguments: self newMessageArgumentNames! ! -!ExtractMethodApplier methodsFor: 'private - new message' stamp: 'RNG 9/8/2019 20:39:33'! - newMessageArgumentNames - - ^ newMessageArguments values collect: [ :parseNode | parseNode name ]! ! -!ExtractMethodApplier methodsFor: 'private - new message' stamp: 'RNG 9/8/2019 20:05:08'! - saveUnarySelector: userAnswer - - ^ newSelector _ userAnswer asSymbol! ! -!ExtractMethodApplier methodsFor: 'refactoring - creation' stamp: 'RNG 6/23/2019 20:11:34'! - createRefactoring - - ^ ExtractMethod - fromInterval: intervalToExtract - of: methodToExtractCodeFrom - to: self buildNewMessage - categorizedAs: methodToExtractCodeFrom category! ! -!ExtractMethodApplier methodsFor: 'refactoring - changes' stamp: 'RNG 5/13/2019 02:17:27'! - showChanges! ! -!ExtractMethodApplier class methodsFor: 'instance creation' stamp: 'RNG 6/2/2019 18:56:51'! - for: anIntervalToExtract of: aMethodToExtractCodeFrom - - | trimmedIntervalToExtract sourceCode | - sourceCode _ aMethodToExtractCodeFrom sourceCode. - trimmedIntervalToExtract _ ExtractMethodIntervalTrimmer trim: anIntervalToExtract locatedIn: sourceCode. - - self assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: trimmedIntervalToExtract. - - ^ self new initializeFor: trimmedIntervalToExtract of: aMethodToExtractCodeFrom! ! -!ExtractMethodApplier class methodsFor: 'pre-conditions' stamp: 'RNG 5/13/2019 02:06:39'! - assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: anIntervalToExtract - - ExtractMethod - ensure: anIntervalToExtract - isValidIntervalOn: aMethodToExtractCodeFrom! ! -!ExtractMethodNewSelectorPrecondition methodsFor: 'exceptions' stamp: 'RNG 6/2/2019 19:20:09'! - signalNewSelectorBeginsWithAnInvalidCharacter - - self refactoringError: self class invalidStartingCharacterOfNewSelectorErrorMessage! ! -!ExtractMethodNewSelectorPrecondition methodsFor: 'exceptions' stamp: 'RNG 4/18/2019 15:11:55'! - signalNewSelectorCanNotBeEmptyError - - self refactoringError: self class newSelectorCanNotBeEmptyErrorMessage! ! -!ExtractMethodNewSelectorPrecondition methodsFor: 'exceptions' stamp: 'RNG 5/5/2019 12:22:02'! - signalNewSelectorCanNotContainSeparatorsError - - self refactoringError: self class newSelectorCanNotContainSeparatorsErrorMessage! ! -!ExtractMethodNewSelectorPrecondition methodsFor: 'exceptions' stamp: 'RNG 9/10/2019 18:53:55'! - signalNewSelectorContainsInvalidCharactersError - - self refactoringError: self class invalidCharacterInsideNewSelectorErrorMessage! ! -!ExtractMethodNewSelectorPrecondition methodsFor: 'exceptions' stamp: 'RNG 5/5/2019 12:22:40'! - signalNewSelectorIsAlreadyDefinedInTheClassError - - self refactoringError: self class newSelectorAlreadyDefinedOnTheClassErrorMessage! ! -!ExtractMethodNewSelectorPrecondition methodsFor: 'evaluating - private' stamp: 'RNG 6/2/2019 19:21:50'! - assertNewSelectorBeginsWithAValidCharacter - - selectorToValidate first isValidStartOfIdentifiers - ifFalse: [ self signalNewSelectorBeginsWithAnInvalidCharacter ]! ! -!ExtractMethodNewSelectorPrecondition methodsFor: 'evaluating - private' stamp: 'RNG 12/20/2019 20:53:38'! - assertNewSelectorContainsOnlyValidCharacters - - selectorToValidate isValidSelector - ifFalse: [ self signalNewSelectorContainsInvalidCharactersError ]! ! -!ExtractMethodNewSelectorPrecondition methodsFor: 'evaluating - private' stamp: 'RNG 4/18/2019 15:13:52'! - assertNewSelectorDoesNotContainSeparators - - (selectorToValidate anySatisfy: [ :character | character isSeparator ]) - ifTrue: [ self signalNewSelectorCanNotContainSeparatorsError ]! ! -!ExtractMethodNewSelectorPrecondition methodsFor: 'evaluating - private' stamp: 'RNG 9/8/2019 20:49:51'! - assertNewSelectorIsNotAlreadyDefinedInTheClass - - (classToDefineSelector includesSelector: selectorToValidate) - ifTrue: [ self signalNewSelectorIsAlreadyDefinedInTheClassError ]! ! -!ExtractMethodNewSelectorPrecondition methodsFor: 'evaluating - private' stamp: 'RNG 5/5/2019 12:23:16'! - assertNewSelectorIsNotEmpty - - selectorToValidate ifEmpty: [ self signalNewSelectorCanNotBeEmptyError ]! ! -!ExtractMethodNewSelectorPrecondition methodsFor: 'evaluating' stamp: 'RNG 9/10/2019 18:52:36'! - value - - self - assertNewSelectorIsNotEmpty; - assertNewSelectorDoesNotContainSeparators; - assertNewSelectorBeginsWithAValidCharacter; - assertNewSelectorContainsOnlyValidCharacters; - assertNewSelectorIsNotAlreadyDefinedInTheClass! ! -!ExtractMethodNewSelectorPrecondition methodsFor: 'initialization' stamp: 'RNG 4/18/2019 16:04:44'! - initializeFor: aSelectorToValidate on: aClassToDefineSelector - - selectorToValidate _ aSelectorToValidate. - classToDefineSelector _ aClassToDefineSelector! ! -!ExtractMethodNewSelectorPrecondition class methodsFor: 'error messages' stamp: 'RNG 9/10/2019 18:51:15'! - invalidCharacterInsideNewSelectorErrorMessage - - ^ 'New selector should only contain letters, numbers or _'! ! -!ExtractMethodNewSelectorPrecondition class methodsFor: 'error messages' stamp: 'RNG 6/2/2019 19:18:14'! - invalidStartingCharacterOfNewSelectorErrorMessage - - ^ 'New selector should begin with a lowercase letter or _'! ! -!ExtractMethodNewSelectorPrecondition class methodsFor: 'error messages' stamp: 'RNG 4/18/2019 15:58:58'! - newSelectorAlreadyDefinedOnTheClassErrorMessage - - ^ 'New selector is already defined on this class'! ! -!ExtractMethodNewSelectorPrecondition class methodsFor: 'error messages' stamp: 'RNG 4/18/2019 14:40:21'! - newSelectorCanNotBeEmptyErrorMessage - - ^ 'New selector can not be empty'! ! -!ExtractMethodNewSelectorPrecondition class methodsFor: 'error messages' stamp: 'RNG 4/18/2019 15:05:41'! - newSelectorCanNotContainSeparatorsErrorMessage - - ^ 'New selector can not contain separators'! ! -!ExtractMethodNewSelectorPrecondition class methodsFor: 'instance creation' stamp: 'RNG 4/18/2019 16:01:43'! - for: aSelectorToValidate on: aClass - - ^ self new initializeFor: aSelectorToValidate on: aClass! ! -!ExtractMethodNewSelectorPrecondition class methodsFor: 'evaluating' stamp: 'RNG 4/18/2019 15:59:44'! - valueFor: aSelectorToValidate on: aClass - - ^ (self for: aSelectorToValidate on: aClass) value! ! -!ExtractMethodEditorMenu class methodsFor: 'shortcuts' stamp: 'RNG 9/8/2019 20:56:48'! - smalltalkEditorCmdShortcutsSpec - - ^#(#($K #extractMethod: 'Extracts the selected code into a separate method'))! ! -!ExtractMethodEditorMenu class methodsFor: 'menu items' stamp: 'RNG 9/8/2019 20:56:43'! - smalltalkEditorMenuOptions - - ^`{ - { - #itemGroup -> 35. - #itemOrder -> 20. - #label -> 'Extract Method... (K)'. - #selector -> #extractMethod. - #icon -> #saveAsIcon - } asDictionary - }`! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 9/28/2019 01:21:30'! - containsValidNodes - - ^ self isNotLeftSideOfAssignment - :: and: [ self thereAreNoLocalVariableAssignments ] - :: and: [ self thereAreNoReturnExpressions ] - :: and: [ self isNotATempDeclaration ]! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 9/19/2019 22:16:05'! - intervalCoversCompleteAstNodes - - ^ (self trimmed: (initialNode value first to: finalNode value last)) = intervalToExtract! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 7/9/2019 15:59:28'! - intervalMatchesBeginningOfStatement - - ^ initialNodeAncestors last value first = intervalToExtract first! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 7/9/2019 15:59:45'! - intervalMatchesEndOfStatement - - ^ finalNodeAncestors last value last = intervalToExtract last! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 9/28/2019 00:05:30'! - isDeclaredWithinIntervalToExtract: aVariableNode - - ^ methodNode - allParseNodesWithin: intervalToExtract - satisfy: [ :parseNode | parseNode isBlockNode - and: [ parseNode temporaries includes: aVariableNode ] ]! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 9/8/2019 21:14:54'! - isLeftSideOfAssignment - - ^ initialNodeAncestors size > 1 - :: and: [ initialNodeAncestors second key isAssignmentNode ] - :: and: [ initialNodeAncestors second key variable = initialNode key ]! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 9/28/2019 01:41:03'! - isNotATempDeclaration - - | startOfFirstOccurrence sourceRanges tempKey allTempSourceRanges | - initialNode key isTemp ifFalse: [ ^ true ]. - sourceRanges _ methodNode rawSourceRanges. - tempKey _ sourceRanges keys detect: [ :parseNode | parseNode isTemp and: [ parseNode equivalentTo: initialNode key ] ]. - allTempSourceRanges _ sourceRanges at: tempKey. - startOfFirstOccurrence _ allTempSourceRanges isInterval - ifTrue: [ allTempSourceRanges first ] ifFalse: [ allTempSourceRanges first first ]. - ^ startOfFirstOccurrence ~= intervalToExtract first! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 7/6/2019 20:40:51'! - isNotLeftSideOfAssignment - - ^ (self startAndEndParseNodesAreTheSame and: [ self isLeftSideOfAssignment ]) not! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 7/9/2019 15:59:45'! - parseNodesInCommon - - ^ initialNodeAncestors intersection: finalNodeAncestors! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 7/9/2019 16:03:15'! - startAndEndNodesShareAParentNode - - | parseNodesInCommon | - parseNodesInCommon _ self parseNodesInCommon. - ^ parseNodesInCommon notEmpty and: [ - (self trimmed: parseNodesInCommon first value) = intervalToExtract - ] - - -! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 7/9/2019 15:59:04'! - startAndEndParseNodesAreTheSame - - ^ initialNode key = finalNode key! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 9/28/2019 00:04:36'! - thereAreNoLocalVariableAssignments - - ^ methodNode - allParseNodesWithin: intervalToExtract - satisfy: [ :parseNode | parseNode isAssignmentToTemporary - and: [ self isDeclaredWithinIntervalToExtract: parseNode variable ] ]! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 9/8/2019 19:05:37'! - thereAreNoReturnExpressions - - ^ methodNode - allParseNodesWithin: intervalToExtract - satisfy: [ :parseNode | parseNode isReturn ]! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 7/9/2019 16:03:24'! - trimmed: anInterval - - ^ ExtractMethodIntervalTrimmer trim: anInterval locatedIn: sourceCode! ! -!ExtractMethodExpressionValidation methodsFor: 'validation' stamp: 'RNG 9/8/2019 18:42:38'! - passed - - methodNode _ method methodNode. - sourceCode _ method sourceCode. - initialNodeAncestors _ methodNode parseNodesPathAt: intervalToExtract first ifAbsent: [ ^ false]. - finalNodeAncestors _ methodNode parseNodesPathAt: intervalToExtract last ifAbsent: [ ^ false ]. - initialNode _ initialNodeAncestors first. - finalNode _ finalNodeAncestors first. - - ^ self intervalCoversCompleteAstNodes - :: and: [ self containsValidNodes ] - :: and: [ self startAndEndParseNodesAreTheSame - :: or: [ self startAndEndNodesShareAParentNode ] - :: or: [ self intervalMatchesBeginningOfStatement and: [ self intervalMatchesEndOfStatement ] ] ]! ! -!ExtractMethodExpressionValidation methodsFor: 'initialization' stamp: 'RNG 9/19/2019 22:14:50'! - initializeFor: anIntervalToExtract of: aMethodUnderValidation - - intervalToExtract _ anIntervalToExtract. - method _ aMethodUnderValidation! ! -!ExtractMethodExpressionValidation class methodsFor: 'instance creation' stamp: 'RNG 7/6/2019 20:07:49'! - for: anIntervalToExtract of: aMethod - - ^ self new initializeFor: anIntervalToExtract of: aMethod! ! -!ExtractMethodIntervalTrimmer class methodsFor: 'private' stamp: 'RNG 7/6/2019 19:18:23'! - shouldTrim: sourceCode atIndex: currentIndex - - | currentChar | - currentChar _ sourceCode at: currentIndex ifAbsent: [ ^ false ]. - ^ currentChar isSeparator or: [ currentChar = $. ] -! ! -!ExtractMethodIntervalTrimmer class methodsFor: 'evaluating' stamp: 'RNG 7/6/2019 19:22:50'! - trim: anInterval locatedIn: sourceCode - - | trimmedInterval | - trimmedInterval _ anInterval. - [ self shouldTrim: sourceCode atIndex: trimmedInterval first ] - whileTrue: [ trimmedInterval _ trimmedInterval first + 1 to: trimmedInterval last ]. - [ self shouldTrim: sourceCode atIndex: trimmedInterval last ] - whileTrue: [ trimmedInterval _ trimmedInterval first to: trimmedInterval last - 1 ]. - - [ - | initialChar endingChar | - initialChar _ sourceCode at: trimmedInterval first ifAbsent: [ nil ]. - endingChar _ sourceCode at: trimmedInterval last ifAbsent: [ nil ]. - initialChar = $( and: [ endingChar = $) ] - ] - whileTrue: [ trimmedInterval _ trimmedInterval first + 1 to: trimmedInterval last - 1 ]. - - ^ trimmedInterval! ! - -MethodNode removeSelector: #hasTemporaryOrArgumentNamed:! - -"Postscript: -Reload the shortcuts to get the new Extract Method shortcut" -SmalltalkEditor initializeCmdShortcuts! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3991-ExtractMethod-NahuelGarbezza-2019Dec20-20h38m-RNG.1.cs.st----! - -'From Cuis 5.0 [latest update: #3990] on 23 December 2019 at 11:14:21 am'! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 12/23/2019 10:59:16'! - ifSourceCodeRefactoringCanBeAppliedDo: aBlock - - ^(self hasUnacceptedEdits or: [morph hasEditingConflicts ]) - ifTrue: [ self inform: 'This refactoring can not be applied when there are unsaved changes' ] - ifFalse: aBlock! ! -!CodeNode methodsFor: 'testing' stamp: 'HAW 12/23/2019 09:58:07' prior: 50487865! - hasNodeIn: aCollectionOfNodes named: aName - - ^aCollectionOfNodes anySatisfy: [ :tempNode | tempNode isNamed: aName ]! ! -!BlockNode methodsFor: 'testing' stamp: 'HAW 12/23/2019 09:59:19' prior: 50488594! - hasArgumentOrTemporaryNamed: aName - - ^ self hasLocallyArgumentOrTemporaryNamed: aName! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 12/23/2019 10:40:42' prior: 50488688! - completeSourceRanges - "Returns the 'expanded' version of the source ranges, for instance in message sends it also includes the receiver, and if there are parentheses they are included in the source range as well. Right now used for refactorings." - - ^ encoder completeSourceRangesBasedOn: self sourceText! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 12/23/2019 10:40:45' prior: 50488701! - completeSourceRangesDo: aBinaryBlock - "block has to receive parse node and collection of source ranges" - - ^ self completeSourceRanges keysAndValuesDo: aBinaryBlock! ! -!MethodNode methodsFor: 'source mapping' stamp: 'HAW 12/23/2019 10:41:00' prior: 50488709! - parseNodesPathAt: aPosition ifAbsent: aBlockClosure - - ^ encoder - parseNodesPathAt: aPosition - using: self completeSourceRanges - ifAbsent: aBlockClosure! ! -!MethodNode methodsFor: 'testing' stamp: 'HAW 12/23/2019 11:10:37' prior: 50488675! - allParseNodesWithin: aSourceCodeInterval satisfy: aCondition - - self completeSourceRangesDo: [ :parseNode :sourceRanges | - (aCondition value: parseNode) ifTrue: [ - sourceRanges anySatisfy: [ :sourceRange | aSourceCodeInterval rangeIncludes: sourceRange first ] - :: ifTrue: [ ^ false ]]]. - - ^ true! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 12/23/2019 10:59:16' prior: 50469119! - contextualRenameInClassDefinition - - self ifSourceCodeRefactoringCanBeAppliedDo: [ - self - withClassDefinitionNodeAndClassDo: [ :classDefinitionNode :selectedClass | self contextualRenameInClassDefinitionOf: classDefinitionNode in: selectedClass] - ifErrorsParsing: [ :anError | morph flash ] ]! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 12/23/2019 10:59:16' prior: 50486341! - contextualRenameOf: aMethodNode in: aSelectedClass - - aMethodNode - withParseNodeIncluding: self startIndex - do: [ :nodeUnderCursor | self rename: nodeUnderCursor in: aSelectedClass at: aMethodNode ] - ifAbsent: [ - self startIndex <= aMethodNode selectorLastPosition - ifTrue: [ self ifSourceCodeRefactoringCanBeAppliedDo: [ self renameSelectorFor: aMethodNode selector in: aSelectedClass ]] - ifFalse: [ morph flash ]] - - -! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 12/23/2019 10:59:16' prior: 50486358! - rename: aNodeUnderCursor in: aSelectedClass at: aMethodNode - - aNodeUnderCursor isTempOrArg ifTrue: [ ^self renameTemporary: aNodeUnderCursor at: aMethodNode ]. - - self ifSourceCodeRefactoringCanBeAppliedDo: [ - aNodeUnderCursor isMessageNode ifTrue: [ - ^ self renameSelectorOf: aNodeUnderCursor in: aSelectedClass at: aMethodNode selector ]. - aNodeUnderCursor isInstanceVariableNode ifTrue: [ - ^ self renameInstanceVariableOn: self codeProvider for: aNodeUnderCursor name at: aSelectedClass ]. - aNodeUnderCursor isLiteralVariableNode ifTrue: [ | variableName | - variableName := aNodeUnderCursor key key. - (Smalltalk classNamed: variableName) ifNotNil: [ :classToRename | - ^self renameClassOn: self codeProvider for: classToRename ]. - (Smalltalk bindingOf: variableName) ifNotNil: [ - ^self renameGlobalOn: self codeProvider for: variableName ] ]. - - ^morph flash ]! ! -!SmalltalkEditor methodsFor: 'contextual add/remove parameter' stamp: 'HAW 12/23/2019 10:59:16' prior: 50469493! - contextualChangeSelectorUsing: aChangeSelectorApplier - - self isEditingClassDefinition - ifTrue: [ morph flash ] - ifFalse: [ self ifSourceCodeRefactoringCanBeAppliedDo: [ self contextualChangeSelectorInMethodUsing: aChangeSelectorApplier ]]! ! -!SmalltalkEditor methodsFor: 'extract method' stamp: 'HAW 12/23/2019 10:59:16' prior: 50488717! - extractMethod - - "hack to prevent the extract method to be evaluated on editors w/o methods like the workspace" - self codeProvider respondsTo: #currentCompiledMethod - :: and: [ self codeProvider currentCompiledMethod notNil ] - :: ifFalse: [ ^ nil ]. - - self ifSourceCodeRefactoringCanBeAppliedDo: [ - ExtractMethodApplier createAndValueHandlingExceptions: [ - ExtractMethodApplier for: self selectionInterval of: self codeProvider currentCompiledMethod ] ]! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'HAW 12/23/2019 10:02:36' prior: 50489027! - nodesThatAddVariablesToScope - - ^ (Set with: methodToExtractCodeFrom methodNode) - addAll: self blockNodesEnclosingIntervalToExtract; - yourself! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'HAW 12/23/2019 10:20:54' prior: 50489453! - startAndEndNodesShareAParentNode - - | parseNodesInCommon | - parseNodesInCommon _ self parseNodesInCommon. - - ^ parseNodesInCommon notEmpty and: [ - (self trimmed: parseNodesInCommon first value) = intervalToExtract] - - -! ! - -SmalltalkEditor removeSelector: #ifChangeSelectorCanBeAppliedDo:! - -!methodRemoval: SmalltalkEditor #ifChangeSelectorCanBeAppliedDo: stamp: 'Install-3992-ExtractMethodRefactorings-HernanWilkinson-2019Dec23-09h51m-HAW.1.cs.st 1/11/2020 17:58:50'! -ifChangeSelectorCanBeAppliedDo: aBlock - - ^(self hasUnacceptedEdits or: [morph hasEditingConflicts ]) - ifTrue: [ self inform: 'Rename, Add Parameter and Remove Parameter can not be applied when there are unsaved changes' ] - ifFalse: aBlock! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3992-ExtractMethodRefactorings-HernanWilkinson-2019Dec23-09h51m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3992] on 23 December 2019 at 11:48:22 am'! - -Object subclass: #ExtractMethodExpressionValidation - instanceVariableNames: 'method intervalToExtract methodNode sourceCode initialNode finalNode initialNodeAncestors finalNodeAncestors' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractMethodExpressionValidation category: #'Tools-Refactoring' stamp: 'Install-3993-ExtractMethodRefactorings2-HernanWilkinson-2019Dec23-11h44m-HAW.1.cs.st 1/11/2020 17:58:50'! -Object subclass: #ExtractMethodExpressionValidation - instanceVariableNames: 'method intervalToExtract methodNode sourceCode initialNode finalNode initialNodeAncestors finalNodeAncestors' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Object subclass: #ExtractMethodIntervalTrimmer - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractMethodIntervalTrimmer category: #'Tools-Refactoring' stamp: 'Install-3993-ExtractMethodRefactorings2-HernanWilkinson-2019Dec23-11h44m-HAW.1.cs.st 1/11/2020 17:58:50'! -Object subclass: #ExtractMethodIntervalTrimmer - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Refactoring subclass: #ExtractMethod - instanceVariableNames: 'intervalToExtract categoryOfNewSelector newMessage extractedSourceCode existingMethod' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractMethod category: #'Tools-Refactoring' stamp: 'Install-3993-ExtractMethodRefactorings2-HernanWilkinson-2019Dec23-11h44m-HAW.1.cs.st 1/11/2020 17:58:50'! -Refactoring subclass: #ExtractMethod - instanceVariableNames: 'intervalToExtract categoryOfNewSelector newMessage extractedSourceCode existingMethod' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #ExtractMethodApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newSelector newMessageArguments' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractMethodApplier category: #'Tools-Refactoring' stamp: 'Install-3993-ExtractMethodRefactorings2-HernanWilkinson-2019Dec23-11h44m-HAW.1.cs.st 1/11/2020 17:58:50'! -RefactoringApplier subclass: #ExtractMethodApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newSelector newMessageArguments' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringPrecondition subclass: #ExtractMethodNewSelectorPrecondition - instanceVariableNames: 'selectorToValidate classToDefineSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractMethodNewSelectorPrecondition category: #'Tools-Refactoring' stamp: 'Install-3993-ExtractMethodRefactorings2-HernanWilkinson-2019Dec23-11h44m-HAW.1.cs.st 1/11/2020 17:58:50'! -RefactoringPrecondition subclass: #ExtractMethodNewSelectorPrecondition - instanceVariableNames: 'selectorToValidate classToDefineSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!RefactoringMenues class methodsFor: 'editor menus' stamp: 'HAW 12/23/2019 11:45:31' prior: 50473570! - smalltalkEditorMenuOptions - - ^`{ - { - #itemGroup -> 35. - #itemOrder -> 10. - #label -> 'Rename... (R)'. - #selector -> #contextualRename. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 20. - #label -> 'Extract Method... (K)'. - #selector -> #extractMethod. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 30. - #label -> 'Add Parameter... (A)'. - #selector -> #contextualAddParameter. - #icon -> #listAddIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 40. - #label -> 'Remove Parameter... (S)'. - #selector -> #contextualRemoveParameter. - #icon -> #listRemoveIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 50. - #label -> 'Temporary to Instance Variable (O)'. - #selector -> #temporaryToInstanceVariable. - #icon -> #saveAsIcon - } asDictionary. - }`! ! -!RefactoringMenues class methodsFor: 'shortcuts' stamp: 'HAW 12/23/2019 11:44:05' prior: 50473600! - smalltalkEditorCmdShortcutsSpec - - ^#( - #( $R #contextualRename: 'Renames what is under cursor') - #( $A #contextualAddParameter: 'Adds parameter to message that is under cursor') - #( $S #contextualRemoveParameter: 'Removes parameter to message that is under cursor') - #( $O #temporaryToInstanceVariable: 'Extracts temporary variable to instance variable') - #( $K #extractMethod: 'Extracts the selected code into a separate method') - ) -! ! - -Smalltalk removeClassNamed: #ExtractMethodEditorMenu! - -!classRemoval: #ExtractMethodEditorMenu stamp: 'Install-3993-ExtractMethodRefactorings2-HernanWilkinson-2019Dec23-11h44m-HAW.1.cs.st 1/11/2020 17:58:50'! -Object subclass: #ExtractMethodEditorMenu - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Refactorings-ExtractMethod'! - -"Postscript:" -SystemOrganization removeSystemCategory: 'Refactorings-ExtractMethod'. -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3993-ExtractMethodRefactorings2-HernanWilkinson-2019Dec23-11h44m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3993] on 26 December 2019 at 8:24:25 am'! -!Process methodsFor: 'debugging' stamp: 'HAW 12/26/2019 08:17:53' prior: 16894514! - debug: context title: title full: bool - "Open debugger on self with context shown on top" - - | topContext | - - topContext _ self isRunning ifTrue: [thisContext] ifFalse: [self suspendedContext]. - (topContext notNil and: [ topContext hasContext: context ]) ifFalse: [^ self error: 'context not in process']. - Debugger openOn: self context: context label: title fullView: bool. -! ! -!TestFailure methodsFor: 'Camp Smalltalk' stamp: 'HAW 12/26/2019 08:21:50' prior: 16927789! - defaultAction - - self noHandler! ! - -SyntaxErrorNotification removeSelector: #defaultAction! - -!methodRemoval: SyntaxErrorNotification #defaultAction stamp: 'Install-3994-ThroughHangFixWhenTestFail-HernanWilkinson-2019Dec26-08h20m-HAW.1.cs.st 1/11/2020 17:58:50'! -defaultAction - - "Handle a syntax error" - | | -true ifTrue: [ ^super defaultAction ]. -" notifier := SyntaxError new - setClass: self errorClass - code: self errorCode - debugger: (Debugger context: self signalerContext) - doitFlag: self doitFlag. - notifier category: self category. - SyntaxError open: notifier. - "! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3994-ThroughHangFixWhenTestFail-HernanWilkinson-2019Dec26-08h20m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3994] on 26 December 2019 at 10:03:58 am'! -!UISupervisor class methodsFor: 'gui process' stamp: 'HAW 12/26/2019 10:01:29' prior: 50378934! - spawnNewMorphicProcessFor: guiRootObject - - | previousUIProcess | - - previousUIProcess := UIProcess. - UIProcess _ guiRootObject runProcess. - previousUIProcess ifNotNil: [ previousUIProcess animatedUI: nil ]. - UIProcess resume! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3995-UIFreezeBugFixWhenSimulatingExecution-HernanWilkinson-2019Dec26-10h01m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3994] on 26 December 2019 at 11:10:16 am'! -!Process methodsFor: 'changing suspended state' stamp: 'HAW 12/26/2019 10:59:25'! - canSearchForSignalerContextOf: anException - - ^ (anException class includesBehavior: Exception) - and: [anException canSearchForSignalerContext]! ! -!Process methodsFor: 'changing suspended state' stamp: 'HAW 12/26/2019 10:55:07'! - completeStepUpTo: aContext - - [aContext == suspendedContext] - whileFalse: [self completeStep: suspendedContext].! ! -!Process methodsFor: 'changing suspended state' stamp: 'HAW 12/26/2019 10:59:09'! - ifSuspendedContextIsUnhandledErrorDo: aBlock - - | unhandledError | - - self isSuspendedContextSignalUnhandledError ifTrue: [ - unhandledError := suspendedContext tempAt: 1. - (self canSearchForSignalerContextOf: unhandledError) ifTrue: [ - aBlock value: unhandledError ]].! ! -!Process methodsFor: 'changing suspended state' stamp: 'HAW 12/26/2019 10:56:50'! - isSuspendedContextSignalUnhandledError - - ^ suspendedContext selector == #signalForException: - and: [suspendedContext receiver isBehavior - and: [suspendedContext receiver includesBehavior: UnhandledError]]! ! -!Notification methodsFor: 'debugger updating' stamp: 'HAW 12/26/2019 11:01:45'! - isToUpdateDebuggerOn: aContext - - ^tag isArray - and: [tag size = 2 - and: [(tag first == aContext or: [tag first hasSender: aContext])]]! ! -!Notification methodsFor: 'debugger updating' stamp: 'HAW 12/26/2019 11:01:48'! - withNewDebuggerLabelOn: aContext do: labelBlock ifNone: noneBlok - - ^(self isToUpdateDebuggerOn: aContext) - ifTrue: [ labelBlock value: tag second description ] - ifFalse: noneBlok ! ! -!Notification class methodsFor: 'debugger updating - signaling' stamp: 'HAW 12/26/2019 11:02:18'! - signalToUpdateDebuggerOn: unhandledErrorSignalerContext dueTo: anError - - self new - tag: {unhandledErrorSignalerContext. anError}; - signal.! ! -!Object methodsFor: 'testing' stamp: 'HAW 12/26/2019 10:04:01'! - isContext - - ^false ! ! -!Debugger methodsFor: 'context stack menu' stamp: 'HAW 12/26/2019 10:19:57' prior: 50367108! - handleLabelUpdatesIn: aBlock whenExecuting: aContext - "Send the selected message in the accessed method, and regain control - after the invoked method returns." - - ^aBlock - on: Notification - do: [:aNotification| - aNotification - withNewDebuggerLabelOn: aContext - do: [ :aNewLabel | - self labelString: aNewLabel. - aNotification resume] - ifNone: [aNotification pass]]! ! -!Debugger class methodsFor: 'class initialization' stamp: 'HAW 12/26/2019 10:05:14' prior: 50373333! - openContext: aContext label: aString contents: contentsStringOrNil - "Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger." - - "Simulation guard" - - (self errorRecursion not and: [Preferences logDebuggerStackToFile]) ifTrue: - [Smalltalk logError: aString inContext: aContext to: 'CuisDebug']. - ErrorRecursion ifTrue: [ - ErrorRecursion _ false. - contentsStringOrNil - ifNil: [ - self primitiveError: 'Can not open debugger due to recursion error.', - String newLineString, aString] - ifNotNil: [ - self primitiveError: 'Can not open debugger due to recursion error.', - String newLineString, aString, String newLineString, contentsStringOrNil ]]. - ErrorRecursion _ true. - [self informExistingDebugger: aContext label: aString. - (Debugger context: aContext) - openNotifierContents: contentsStringOrNil - label: aString.] ensure: [ ErrorRecursion _ false ]. - Processor activeProcess suspend. -! ! -!Process methodsFor: 'changing suspended state' stamp: 'HAW 12/26/2019 11:09:25' prior: 50367197! - stepToHome: aContext - "Resume self until the home of top context is aContext. Top context may be a block context. - Catch any UnhandledErrors that are created while stepping, answering the relevant signalerContext - if so. Note that this will cause weird effects if using through to step through UnhandledError - code, but as the doctor ordered, don't do that; use over or into instead." - - | home | - - home := aContext home. - [suspendedContext := suspendedContext step. - home == suspendedContext home or: [home isDead]] whileFalse: - [self ifSuspendedContextIsUnhandledErrorDo: [ :anError | - anError signalerContext ifNotNil: [:unhandledErrorSignalerContext| - self completeStepUpTo: unhandledErrorSignalerContext. - - "Give a debugger a chance to update its title to reflect the new exception" - Notification signalToUpdateDebuggerOn: unhandledErrorSignalerContext dueTo: anError. - ^unhandledErrorSignalerContext]]]. - - ^suspendedContext! ! -!PasteUpMorph methodsFor: 'interaction loop' stamp: 'HAW 12/26/2019 10:05:45' prior: 50378679! - runProcess - - | process | - - process _ [ self mainLoop ] newProcess. - process - priority: Processor userSchedulingPriority; - name: 'Morphic UI'; - animatedUI: self. - - ^ process! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3996-DebuggerRefactorings-HernanWilkinson-2019Dec26-10h03m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3996] on 26 December 2019 at 11:35:35 am'! -!PreDebugWindow class methodsFor: 'instance creation' stamp: 'HAW 12/26/2019 11:18:10'! - forceOpen: model label: aString message: messageString - - | window | - - window _ self new. - window - model: model; - buildMorphicWindowMessage: messageString print. - aString ifNotNil: [ window setLabel: aString ]. - - window openInWorld ! ! -!Debugger methodsFor: 'initialization' stamp: 'HAW 12/26/2019 11:18:22' prior: 50470719! - openNotifierContents: msgString label: label - "Create and schedule a notifier view with the given label and message. A notifier view shows just the message or the first several lines of the stack, with a menu that allows the user to open a full debugger if so desired." - "NOTE: When this method returns, a new process has been scheduled to run the windows, and thus this notifier, but the previous active porcess has not been suspended. The sender will do this." - | msg | - Sensor flushKeyboard. - savedCursor _ Cursor currentCursor. - Cursor defaultCursor activateCursor. - msg _ (label beginsWith: 'Space is low') - ifTrue: [ self lowSpaceChoices , (msgString ifNil: [ '' ]) ] - ifFalse: [ msgString ]. - interruptedProcessUI _ UISupervisor newProcessIfUI: interruptedProcess. - UISupervisor whenUIinSafeState: [ - PreDebugWindow - forceOpen: self - label: label - message: msg ].! ! -!PreDebugWindow class methodsFor: 'instance creation' stamp: 'HAW 12/26/2019 11:17:49' prior: 50417417! - open: model label: aString message: messageString - - (Preferences usePreDebugWindow or: [messageString notNil]) - ifTrue: [self forceOpen: model label: aString message: messageString] - ifFalse: [model openFullMorphicLabel: aString ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3997-UsePreDebugWindowForInternalErrors-HernanWilkinson-2019Dec26-11h11m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3997] on 26 December 2019 at 10:03:20 pm'! - -Refactoring subclass: #MoveInstanceVariable - instanceVariableNames: 'classToRefactor instanceVariableToMove' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #MoveInstanceVariable category: #'Tools-Refactoring' stamp: 'Install-3998-PushUpDownInstanceVariable-HernanWilkinson-2019Dec26-19h05m-HAW.1.cs.st 1/11/2020 17:58:50'! -Refactoring subclass: #MoveInstanceVariable - instanceVariableNames: 'classToRefactor instanceVariableToMove' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MoveInstanceVariable subclass: #PushDownInstanceVariable - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #PushDownInstanceVariable category: #'Tools-Refactoring' stamp: 'Install-3998-PushUpDownInstanceVariable-HernanWilkinson-2019Dec26-19h05m-HAW.1.cs.st 1/11/2020 17:58:50'! -MoveInstanceVariable subclass: #PushDownInstanceVariable - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MoveInstanceVariable subclass: #PushUpInstanceVariable - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #PushUpInstanceVariable category: #'Tools-Refactoring' stamp: 'Install-3998-PushUpDownInstanceVariable-HernanWilkinson-2019Dec26-19h05m-HAW.1.cs.st 1/11/2020 17:58:50'! -MoveInstanceVariable subclass: #PushUpInstanceVariable - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #MoveInstanceVariableApplier - instanceVariableNames: 'browser classToRefactor instanceVariableName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #MoveInstanceVariableApplier category: #'Tools-Refactoring' stamp: 'Install-3998-PushUpDownInstanceVariable-HernanWilkinson-2019Dec26-19h05m-HAW.1.cs.st 1/11/2020 17:58:50'! -RefactoringApplier subclass: #MoveInstanceVariableApplier - instanceVariableNames: 'browser classToRefactor instanceVariableName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MoveInstanceVariableApplier subclass: #PushDownInstanceVariableApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #PushDownInstanceVariableApplier category: #'Tools-Refactoring' stamp: 'Install-3998-PushUpDownInstanceVariable-HernanWilkinson-2019Dec26-19h05m-HAW.1.cs.st 1/11/2020 17:58:50'! -MoveInstanceVariableApplier subclass: #PushDownInstanceVariableApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MoveInstanceVariableApplier subclass: #PushUpInstanceVariableApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #PushUpInstanceVariableApplier category: #'Tools-Refactoring' stamp: 'Install-3998-PushUpDownInstanceVariable-HernanWilkinson-2019Dec26-19h05m-HAW.1.cs.st 1/11/2020 17:58:50'! -MoveInstanceVariableApplier subclass: #PushUpInstanceVariableApplier - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!CodeProvider methodsFor: 'contents' stamp: 'MSC 12/19/2019 07:20:34'! - instanceVariablePushedUp - - self acceptedContentsChanged -! ! -!SmalltalkEditor methodsFor: 'contextual push up/down inst. var' stamp: 'HAW 12/26/2019 19:37:18'! - apply: aBlock inClassDefinitionOf: aClassDefinitionNode in: aSelectedClass - - | analyzer cursorPosition | - - analyzer := ClassDefinitionNodeAnalyzer for: aClassDefinitionNode. - cursorPosition := self startIndex. - - (analyzer isAtInstanceVariables: cursorPosition) - ifTrue: [ aBlock value: aSelectedClass ] - ifFalse: [ morph flash ] - -! ! -!SmalltalkEditor methodsFor: 'contextual push up/down inst. var' stamp: 'HAW 12/26/2019 19:37:20'! - contextualPushDownInClassDefinition - - self inClassDefinitionContextuallyApply: [ :aSelectedClass | - (PushDownInstanceVariableApplier - on: self codeProvider - for: self wordUnderCursor - at: aSelectedClass ) value ]! ! -!SmalltalkEditor methodsFor: 'contextual push up/down inst. var' stamp: 'HAW 12/26/2019 19:37:25'! - contextualPushUpInClassDefinition - - self inClassDefinitionContextuallyApply: [ :aSelectedClass | - (PushUpInstanceVariableApplier - on: self codeProvider - for: self wordUnderCursor - at: aSelectedClass) value ]! ! -!SmalltalkEditor methodsFor: 'contextual push up/down inst. var' stamp: 'HAW 12/26/2019 19:37:28'! - ifEditingClassDefinitionDoOrWarn: aBlock - - self isEditingClassDefinition - ifTrue: aBlock - ifFalse: [ self informRefactoringCanOnlyBeAppliedInClassDefinition ]! ! -!SmalltalkEditor methodsFor: 'contextual push up/down inst. var' stamp: 'HAW 12/26/2019 19:37:32'! - inClassDefinitionContextuallyApply: aBlock - - self ifEditingClassDefinitionDoOrWarn: [ - self ifSourceCodeRefactoringCanBeAppliedDo: [ - self - withClassDefinitionNodeAndClassDo: [ :classDefinitionNode :selectedClass | - self apply: aBlock inClassDefinitionOf: classDefinitionNode in: selectedClass ] - ifErrorsParsing: [ :anError | morph flash ]]]! ! -!SmalltalkEditor methodsFor: 'contextual push up/down inst. var' stamp: 'HAW 12/26/2019 19:37:35'! - informRefactoringCanOnlyBeAppliedInClassDefinition - - self inform: 'This refactoring can only be applied from the class definition'! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'MSC 12/21/2019 10:54:17'! - pushDownInstanceVariable - - model selectedClassOrMetaClass ifNotNil: [ :aClass | - (PushDownInstanceVariableApplier on: model at: aClass ) value].! ! -!BrowserWindow methodsFor: 'refactorings' stamp: 'MSC 12/19/2019 07:09:01'! - pushUpInstanceVariable - - model selectedClassOrMetaClass ifNotNil: [ :aClass | - (PushUpInstanceVariableApplier on: model at: aClass ) value].! ! -!ChangeListElement methodsFor: 'fileIn/fileOut' stamp: 'HAW 12/26/2019 19:06:18'! - fileIn - - self subclassResponsibility ! ! -!ChangeListElement methodsFor: 'fileIn/fileOut' stamp: 'HAW 12/26/2019 19:07:08'! - fileOutOn: aFileStream - - self subclassResponsibility ! ! -!FeatureChangeRecord methodsFor: 'fileIn/fileOut' stamp: 'HAW 12/26/2019 19:05:33'! - fileIn - - "It does nothing - Hernan"! ! -!FeatureChangeRecord methodsFor: 'fileIn/fileOut' stamp: 'HAW 12/26/2019 19:07:28'! - fileOutOn: aFileStream - - "Nothing to file out - Hernan"! ! -!MoveInstanceVariable methodsFor: 'initialization' stamp: 'HAW 12/26/2019 20:23:54'! - initializeNamed: anInstanceVariableToMove from: aClassToRefactor - - instanceVariableToMove := anInstanceVariableToMove. - classToRefactor := aClassToRefactor.! ! -!MoveInstanceVariable class methodsFor: 'instance creation' stamp: 'HAW 12/26/2019 20:36:55'! - named: anInstanceVariable from: aClassToRefactor - - self assertCanMove: anInstanceVariable from: aClassToRefactor. - - ^self new initializeNamed: anInstanceVariable from: aClassToRefactor! ! -!MoveInstanceVariable class methodsFor: 'pre-conditions' stamp: 'HAW 12/26/2019 20:36:58'! - assert: aClassToRefactor hasInstanceVariable: anInstanceVariable - - (aClassToRefactor definesInstanceVariableNamed: anInstanceVariable) ifFalse: [self refactoringError: self instanceVariableDoesNotExistOnClassToRefactor]. - - ! ! -!MoveInstanceVariable class methodsFor: 'pre-conditions' stamp: 'HAW 12/26/2019 20:37:02'! - assertCanMove: anInstanceVariable from: aClassToRefactor - - self subclassResponsibility ! ! -!MoveInstanceVariable class methodsFor: 'error descriptions' stamp: 'HAW 12/26/2019 20:37:05'! - instanceVariableDoesNotExistOnClassToRefactor - - ^ 'Instance variable does not exist on class to refactor'! ! -!PushDownInstanceVariable methodsFor: 'applying' stamp: 'HAW 12/26/2019 20:23:14'! - apply - - classToRefactor removeInstVarName: instanceVariableToMove. - self pushDownInstanceVariableToAllSubclasses! ! -!PushDownInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 12/26/2019 20:23:14'! - pushDownInstanceVariableToAllSubclasses - - classToRefactor subclassesDo: [ :subClass | - subClass addInstVarName: instanceVariableToMove ]! ! -!PushDownInstanceVariable class methodsFor: 'pre-conditions' stamp: 'HAW 12/26/2019 20:37:10'! - assert: aClassToRefactor isNotAccessingInstanceVariable: anInstanceVariable - - | selectorsReferencingInstVar | - - selectorsReferencingInstVar := aClassToRefactor whichSelectorsAccess: anInstanceVariable. - selectorsReferencingInstVar ifNotEmpty: [ - self - canNotRefactorDueToReferencesError: ( - self errorMessageForInstanceVariable: anInstanceVariable isAccessedInMethodsOf: aClassToRefactor) - references: (selectorsReferencingInstVar collect: [ :selector | - MethodReference class: aClassToRefactor selector: selector ]) asArray - to: anInstanceVariable ]! ! -!PushDownInstanceVariable class methodsFor: 'pre-conditions' stamp: 'HAW 12/26/2019 20:37:13'! - assertCanMove: anInstanceVariable from: aClassToRefactor - - self assert: aClassToRefactor hasInstanceVariable: anInstanceVariable. - self assert: aClassToRefactor isNotAccessingInstanceVariable: anInstanceVariable. - - ! ! -!PushDownInstanceVariable class methodsFor: 'error descriptions' stamp: 'HAW 12/26/2019 20:37:16'! - errorMessageForInstanceVariable: anInstanceVariable isAccessedInMethodsOf: aClassToRefactor - - ^ 'Cannot push down ', anInstanceVariable, ' because it is accessed in methods of ', aClassToRefactor name! ! -!PushUpInstanceVariable methodsFor: 'applying' stamp: 'HAW 12/26/2019 20:36:17'! - apply - - self removeSubclassesInstanceVariable. - classToRefactor superclass addInstVarName: instanceVariableToMove.! ! -!PushUpInstanceVariable methodsFor: 'applying - private' stamp: 'HAW 12/26/2019 20:36:02'! - removeSubclassesInstanceVariable - - classToRefactor superclass subclassesDo: [ :subclass | - (subclass definesInstanceVariableNamed: instanceVariableToMove) ifTrue: [ subclass removeInstVarName: instanceVariableToMove]. - ].! ! -!PushUpInstanceVariable class methodsFor: 'pre-conditions' stamp: 'HAW 12/26/2019 20:37:25'! - assertCanMove: anInstanceVariable from: aClassToRefactor - - self assert: aClassToRefactor hasInstanceVariable: anInstanceVariable. - self assertNoOtherMethodIn: aClassToRefactor superclass definesTemporaryNamed: anInstanceVariable.! ! -!PushUpInstanceVariable class methodsFor: 'pre-conditions' stamp: 'HAW 12/26/2019 21:59:38'! - assertNoOtherMethodIn: aSuperclass definesTemporaryNamed: anInstanceVariableName - - | methodsDefiningTemporaryInSuperclass | - - methodsDefiningTemporaryInSuperclass := OrderedCollection new. - methodsDefiningTemporaryInSuperclass addAll: ( - aSuperclass methodsWithArgumentOrTemporaryNamed: anInstanceVariableName). - - methodsDefiningTemporaryInSuperclass ifNotEmpty: [ - self - canNotRefactorDueToReferencesError: ( - self errorMessageForInstanceVariable: anInstanceVariableName isDefinedInMethodsOf: aSuperclass) - references: ( - methodsDefiningTemporaryInSuperclass collect: [ :aMethod | MethodReference method: aMethod ]) - to: anInstanceVariableName ]! ! -!PushUpInstanceVariable class methodsFor: 'error descriptions' stamp: 'HAW 12/26/2019 20:35:21'! - errorMessageForInstanceVariable: anInstanceVariableName isDefinedInMethodsOf: aSuperclass - - ^ anInstanceVariableName, ' exist as temporary in methods of ', aSuperclass name! ! -!MoveInstanceVariableApplier methodsFor: 'initialization' stamp: 'HAW 12/26/2019 20:44:46'! - initializeOn: aBrowserWindow for: anInstanceVariableName at: aClassToRefactor - - browser := aBrowserWindow. - classToRefactor := aClassToRefactor. - instanceVariableName := anInstanceVariableName! ! -!MoveInstanceVariableApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 12/26/2019 20:45:00'! - chooseInstanceVariable - - instanceVariableName ifNotNil: [ ^self ]. - - classToRefactor - chooseDefiningInstanceVariableAlphabeticallyWith: self selectVariableLabel - thenDo: [ :anInstanceVariable | ^instanceVariableName := anInstanceVariable ]. - - self endRequest ! ! -!MoveInstanceVariableApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 12/26/2019 20:45:09'! - requestRefactoringParameters - - self chooseInstanceVariable! ! -!MoveInstanceVariableApplier methodsFor: 'refactoring - changes' stamp: 'HAW 12/26/2019 20:45:33'! - informChangesToBrowser - - browser acceptedContentsChanged.! ! -!MoveInstanceVariableApplier methodsFor: 'refactoring - changes' stamp: 'HAW 12/26/2019 20:45:38'! -showChanges - - self informChangesToBrowser! ! -!MoveInstanceVariableApplier class methodsFor: 'instance creation' stamp: 'HAW 12/26/2019 20:46:23'! - on: aBrowser at: aClassToRefactor - - ^self on: aBrowser for: nil at: aClassToRefactor! ! -!MoveInstanceVariableApplier class methodsFor: 'instance creation' stamp: 'HAW 12/26/2019 20:46:28'! - on: aBrowser for: anInstanceVariableName at: aClassToRefactor - - ^self new initializeOn: aBrowser for: anInstanceVariableName at: aClassToRefactor! ! -!PushDownInstanceVariableApplier methodsFor: 'refactoring - parameters request' stamp: 'MSC 12/21/2019 11:03:46'! - selectVariableLabel - - ^'Select instance variable to push down'! ! -!PushDownInstanceVariableApplier methodsFor: 'refactoring - creation' stamp: 'HAW 12/26/2019 20:17:41'! - createRefactoring - - ^PushDownInstanceVariable named: instanceVariableName from: classToRefactor. - ! ! -!PushUpInstanceVariableApplier methodsFor: 'refactoring - parameters request' stamp: 'MSC 12/19/2019 07:11:47'! - selectVariableLabel - - ^'Select instance variable to push up'! ! -!PushUpInstanceVariableApplier methodsFor: 'refactoring - creation' stamp: 'HAW 12/26/2019 20:41:01'! - createRefactoring - - ^PushUpInstanceVariable named: instanceVariableName from: classToRefactor. - ! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 12/26/2019 19:16:11' prior: 50489646! - contextualRenameInClassDefinition - - self ifSourceCodeRefactoringCanBeAppliedDo: [ - self - withClassDefinitionNodeAndClassDo: [ :classDefinitionNode :selectedClass | - self contextualRenameInClassDefinitionOf: classDefinitionNode in: selectedClass] - ifErrorsParsing: [ :anError | morph flash ] ]! ! -!ChangeRecord methodsFor: 'fileIn/fileOut' stamp: 'HAW 12/26/2019 19:06:40' prior: 50370018! - fileIn - "File the receiver in. If I represent a method or a class-comment, file the method in and make a note of it in the recent-submissions list; if I represent a do-it, then, well, do it." - | s | - type == #method ifTrue: [ - self changeClass ifNotNil: [ :methodClass | - methodClass - compile: self text - classified: category - withStamp: stamp - notifying: nil ]]. - self isDoIt ifTrue: [ - ((s _ self string) beginsWith: '----') ifFalse: [ Compiler evaluate: s ]]. - type == #classDefinition ifTrue: [ Compiler evaluate: self string ]. - type == #classComment ifTrue: [ - (Smalltalk at: class asSymbol) - comment: self text - stamp: stamp ]! ! -!ChangeRecord methodsFor: 'fileIn/fileOut' stamp: 'HAW 12/26/2019 19:06:52' prior: 16797355! - fileOutOn: aFileStream - "File the receiver out on the given file stream" - - | aString | - type == #method - ifTrue: [ - aFileStream newLine; nextPut: $!!. - aString _ class asString - , (meta ifTrue: [' class methodsFor: '] - ifFalse: [' methodsFor: ']) - , category asString printString. - stamp ifNotNil: [ - aString _ aString, ' stamp: ''', stamp, '''']. - aFileStream nextChunkPut: aString. - aFileStream newLine ]. - - type == #preamble ifTrue: [ aFileStream nextPut: $!! ]. - - type == #classComment - ifTrue: [ - aFileStream nextPut: $!!. - aFileStream nextChunkPut: class asString, ' commentStamp: ', stamp storeString. - aFileStream newLine ]. - - type == #classDefinition ifTrue: [ - aFileStream nextPut: $!!. - aFileStream nextChunkPut: - 'classDefinition: ', - (self isMetaClassChange ifTrue: [self changeClassName, ' class'] ifFalse: [self changeClassName]) printString, - ' category: ', self category printString. - aFileStream newLine ]. - - aFileStream nextChunkPut: self string. - - type == #method ifTrue: [ aFileStream nextChunkPut: ' '; newLine ]. - type == #classComment ifTrue: [ aFileStream newLine ]. - aFileStream newLine! ! -!RefactoringApplier methodsFor: 'exception handling' stamp: 'HAW 12/26/2019 22:03:03' prior: 50452820! - browseReferencesOn: aCanNotRefactorDueToReferencesError - - Smalltalk - browseMessageList: aCanNotRefactorDueToReferencesError references - name: (self referencesBrowserTitleOn: aCanNotRefactorDueToReferencesError) - autoSelect: aCanNotRefactorDueToReferencesError referencee asString -! ! -!RefactoringMenues class methodsFor: 'editor menus' stamp: 'HAW 12/26/2019 20:51:34' prior: 50489878! - smalltalkEditorMenuOptions - - ^`{ - { - #itemGroup -> 35. - #itemOrder -> 10. - #label -> 'Rename... (R)'. - #selector -> #contextualRename. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 20. - #label -> 'Extract Method... (K)'. - #selector -> #extractMethod. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 30. - #label -> 'Add Parameter... (A)'. - #selector -> #contextualAddParameter. - #icon -> #listAddIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 40. - #label -> 'Remove Parameter... (S)'. - #selector -> #contextualRemoveParameter. - #icon -> #listRemoveIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 50. - #label -> 'Temporary to Instance Variable (O)'. - #selector -> #temporaryToInstanceVariable. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 60. - #label -> 'Push Up Instance Variable'. - #selector -> #contextualPushUpInClassDefinition. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 70. - #label -> 'Push Down Instance Variable'. - #selector -> #contextualPushDownInClassDefinition. - #icon -> #goBottomIcon - } asDictionary. - }`! ! -!RefactoringMenues class methodsFor: 'browser menues' stamp: 'MSC 12/21/2019 10:53:57' prior: 50450832! - classRefactoringMenuOptions - - ^ `{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'rename class... (R)'. - #object -> #model. - #selector -> #renameClass. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'insert superclass...'. - #object -> #model. - #selector -> #insertSuperclass. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'safely remove class (x)'. - #object -> #model. - #selector -> #safelyRemoveClass. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'add inst var...'. - #selector -> #addInstVar. - #icon -> #listAddIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'rename inst var...'. - #selector -> #renameInstVar. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'remove inst var...'. - #selector -> #removeInstVar. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 40. - #label -> 'remove all unreferenced inst var...'. - #selector -> #removeAllUnreferencedInstVar. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 50. - #label -> 'push up inst var...'. - #selector -> #pushUpInstanceVariable. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 60. - #label -> 'push down inst var...'. - #selector -> #pushDownInstanceVariable. - #icon -> #goBottomIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'rename global...'. - #object -> #model. - #selector -> #renameGlobal. - #icon -> #saveAsIcon - } asDictionary. - }`. - ! ! - -PushUpInstanceVariableApplier class removeSelector: #on:at:! - -PushUpInstanceVariableApplier class removeSelector: #on:for:at:! - -PushUpInstanceVariableApplier removeSelector: #showChanges! - -PushUpInstanceVariableApplier removeSelector: #chooseInstanceVariable! - -PushUpInstanceVariableApplier removeSelector: #initializeOn:for:at:! - -PushUpInstanceVariableApplier removeSelector: #requestRefactoringParameters! - -PushUpInstanceVariableApplier removeSelector: #informChangesToBrowser! - -PushDownInstanceVariableApplier class removeSelector: #on:at:! - -PushDownInstanceVariableApplier class removeSelector: #on:for:at:! - -PushDownInstanceVariableApplier removeSelector: #showChanges! - -PushDownInstanceVariableApplier removeSelector: #chooseInstanceVariable! - -PushDownInstanceVariableApplier removeSelector: #initializeOn:for:at:! - -PushDownInstanceVariableApplier removeSelector: #requestRefactoringParameters! - -PushDownInstanceVariableApplier removeSelector: #informChangesToBrowser! - -PushUpInstanceVariable class removeSelector: #assert:pushUp:! - -PushUpInstanceVariable class removeSelector: #errorMessageForInstanceVariableNotExistOnClassToRefactor! - -PushUpInstanceVariable class removeSelector: #assert:hasInstanceVariable:! - -PushUpInstanceVariable class removeSelector: #named:from:! - -PushUpInstanceVariable class removeSelector: #instanceVariableDoesNotExistOnClassToRefactor! - -PushUpInstanceVariable class removeSelector: #errorMessageForInstanceVariableAlreadyExistsOnSuperClassToRefactorAsTemporary:! - -PushUpInstanceVariable class removeSelector: #errorMessageForInstanceVariable:! - -PushUpInstanceVariable class removeSelector: #named:to:! - -PushUpInstanceVariable class removeSelector: #errorMessageForInstanceVariableAlreadyExistsOnSuperClassToRefactorAsTemporary! - -PushUpInstanceVariable removeSelector: #initializeNamed:from:! - -PushUpInstanceVariable removeSelector: #removeSubclassesInstanceVariables:from:! - -PushUpInstanceVariable removeSelector: #initializeNamed:to:! - -PushDownInstanceVariable class removeSelector: #errorMessageForInstanceVariableNotExistOnClassToRefactor! - -PushDownInstanceVariable class removeSelector: #assert:hasInstanceVariable:! - -PushDownInstanceVariable class removeSelector: #assert:IsNotAccessingInstanceVariable:! - -PushDownInstanceVariable class removeSelector: #assert:pushDown:! - -PushDownInstanceVariable class removeSelector: #errorMessageForInstanceVariableIsAccessesOnClassToRefactor! - -PushDownInstanceVariable class removeSelector: #named:from:! - -PushDownInstanceVariable class removeSelector: #instanceVariableDoesNotExistOnClassToRefactor! - -PushDownInstanceVariable class removeSelector: #errorMessageForInstanceVariable:! - -PushDownInstanceVariable class removeSelector: #errorMessageForInstanceVariableIsAccessesOnClassToRefactor:! - -PushDownInstanceVariable class removeSelector: #named:to:! - -PushDownInstanceVariable class removeSelector: #assertCanPushDown:from:! - -PushDownInstanceVariable removeSelector: #initializeNamed:from:! - -PushDownInstanceVariable removeSelector: #pushDownInstanceVariableToAllSubclasses:to:! - -PushDownInstanceVariable removeSelector: #initializeNamed:to:! - -SmalltalkEditor removeSelector: #contextualPushDown! - -SmalltalkEditor removeSelector: #pushUpInstanceVariableOn:for:at:! - -SmalltalkEditor removeSelector: #contextualPushUp! - -SmalltalkEditor removeSelector: #contextualPushUpInClassDefinitionOf:in:! - -SmalltalkEditor removeSelector: #pushDownInstanceVariableOn:for:at:! - -SmalltalkEditor removeSelector: #contextualPushDownInClassDefinitionOf:in:! - -CodeProvider removeSelector: #instanceVariablePushedDown! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3998-PushUpDownInstanceVariable-HernanWilkinson-2019Dec26-19h05m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3997] on 30 December 2019 at 6:23:44 pm'! -!ChangeSelector class methodsFor: 'pre-conditions' stamp: 'HAW 12/30/2019 18:11:22'! - assertIsNotEmpty: aCollection signalMessageText: errorMessageText - - aCollection isEmpty ifTrue: [ self refactoringError: errorMessageText ].! ! -!ChangeSelectorWizardStepWindow methodsFor: 'compile methods' stamp: 'HAW 12/30/2019 17:03:12' prior: 50438248! -compiledMethodsFrom: methodReferences - - ^ methodReferences - select: [ :aMethodReference | aMethodReference isValid ] - thenCollect: [:aMethodReference | aMethodReference compiledMethod ]! ! -!ChangeSelectorKeepingParameters class methodsFor: 'instance creation' stamp: 'HAW 12/30/2019 17:55:51' prior: 50447651! - from: anOldSelector to: aNewSelector implementors: aCollectionOfImplementors senders: aCollectionOfSenders - - self assertIsValidToRenameFrom: anOldSelector to: aNewSelector. - self assertAllImplementors: aCollectionOfImplementors haveSame: anOldSelector. - self assertNoImplementorClassIn: aCollectionOfImplementors implements: aNewSelector. - self assertAllSenders: aCollectionOfSenders send: anOldSelector. - - self warnIfImplementionsOf: aNewSelector overridesImplementationInSuperclassesOf: aCollectionOfImplementors. - - ^self new initializeFrom: anOldSelector to: aNewSelector implementors: aCollectionOfImplementors senders: aCollectionOfSenders - ! ! -!RefactoringApplier class methodsFor: 'value handling exceptions' stamp: 'HAW 12/30/2019 16:46:47' prior: 50441459! - createAndValueHandlingExceptions: creationBlock - - | applier | - - applier := creationBlock - on: Refactoring refactoringErrorClass - do: [ :refactoringError | ^self inform: refactoringError messageText ]. - - applier value ! ! - -ChangeSelectorKeepingParameters class removeSelector: #implementorsCanNotBeEmptyErrorMessage! - -!methodRemoval: ChangeSelectorKeepingParameters class #implementorsCanNotBeEmptyErrorMessage stamp: 'Install-3999-RenameSelectorWithEmptyImplementors-HernanWilkinson-2019Dec30-12h36m-HAW.1.cs.st 1/11/2020 17:58:50'! -implementorsCanNotBeEmptyErrorMessage - - ^'There are no methods to rename'! - -ChangeSelectorKeepingParameters class removeSelector: #assertCanChangeSelectorFrom:to:implementors:senders:! - -ChangeSelectorKeepingParameters class removeSelector: #assertIsNotEmpty:signalMessageText:! - -!methodRemoval: ChangeSelectorKeepingParameters class #assertIsNotEmpty:signalMessageText: stamp: 'Install-3999-RenameSelectorWithEmptyImplementors-HernanWilkinson-2019Dec30-12h36m-HAW.1.cs.st 1/11/2020 17:58:50'! -assertIsNotEmpty: aCollection signalMessageText: errorMessageText - - aCollection isEmpty ifTrue: [ self refactoringError: errorMessageText ].! - -ChangeSelectorKeepingParameters class removeSelector: #doesNotMakeSenseToApplyRefactoringWithOutImplementors! - -ChangeSelector class removeSelectorIfInBaseSystem: #doesNotMakeSenseToApplyRefactoringWithOutImplementors! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\3999-RenameSelectorWithEmptyImplementors-HernanWilkinson-2019Dec30-12h36m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3997] on 31 December 2019 at 3:01:26 pm'! -!ProgressMorph methodsFor: 'accessing' stamp: 'HAW 12/31/2019 15:00:11' prior: 50444731! - updatePositionAndExtent - | w newExtent | - w _ ((labelMorph measureContents x max: subLabelMorph measureContents x) max: 200) + 18. - w _ w min: Display extent x. - newExtent _ w > extent x - ifTrue: [ w@(labelMorph morphHeight + subLabelMorph morphHeight + progress morphHeight + 10) ] - ifFalse: [ extent ]. - self world - ifNotNil: [ :world | self morphPosition: world morphExtent - newExtent // 2 extent: newExtent ] - ifNil: [ self morphExtent: newExtent ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4000-ProgressMorphOutOfScreenFix-HernanWilkinson-2019Dec30-18h32m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #4000] on 31 December 2019 at 5:35:23 pm'! -!Process methodsFor: 'debugging' stamp: 'jmv 12/31/2019 17:34:38' prior: 50489952! - debug: context title: title full: bool - "Open debugger on self with context shown on top" - - | topCtxt | - self isTerminated ifTrue: [^ self error: 'can not debug a terminated process']. - topCtxt _ self isRunning ifTrue: [thisContext] ifFalse: [self suspendedContext]. - (topCtxt hasContext: context) ifFalse: [^ self error: 'context not in process']. - Debugger openOn: self context: context label: title fullView: bool. -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4001-TweakToTerminatedProcessDebugMessage-JuanVuletich-2019Dec31-17h31m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4001] on 1 January 2020 at 4:56:07 pm'! -!Utilities class methodsFor: 'default desktop' stamp: 'jmv 1/1/2020 16:48:22' prior: 50472895! - defaultTextEditorContents - ^ (' -', -('Cuis Smalltalk - -' centered blue pointSize: FontFamily defaultPointSize * 3), -(' -"Yay, Juan. You GO, guy!! ...a great example of malleable software (and a clever mind) at work." -' rightFlush pointSize: FontFamily defaultPointSize * 0.6), -('Dan Ingalls -' italic rightFlush pointSize: FontFamily defaultPointSize * 0.6), -(' -"I like it... It''s nice and clean and simple and pretty. Nice stuff!!" -' rightFlush pointSize: FontFamily defaultPointSize * 0.6), -('Alan Kay -' italic rightFlush pointSize: FontFamily defaultPointSize * 0.6), -(' -"I think you have a very elegant design aesthetic." -' rightFlush pointSize: FontFamily defaultPointSize * 0.6), -('John Maloney -'italic rightFlush pointSize: FontFamily defaultPointSize * 0.6), -' - -', -'Cuis is a modern, Open Source, multiplatform, Smalltalk-80 system. - - -', -'Cuis is: - -' bold, -' - Small - - Clean - - Appropriable -' blue, -' - -Additionally, Cuis is: - -' bold, -' - Open Source - - Multiplatform -' blue, -' - -Like other Smalltalk systems, Cuis is also: - -' bold, -' - A complete development environment written in itself - - A pure, dynamic Object Oriented language -' blue, -' - -Cuis assumes very little on the underlying platform, and this lets it run out-of-the-box on Windows, MacOS, Linux, ChromeOS and WebBrowsers. Cuis shares the [OpenSmalltalk Virtual Machine] (http://www.opensmalltalk.org) with Squeak, Pharo and Newspeak. - -What sets Cuis apart from the other members of the Squeak family is the focus on Smalltalk-80 and an active attitude towards system complexity: - -Unbound complexity growth, together with development strategies focused only in the short term, are the worst long term enemies of all software systems. As systems grow older, they usually become more complex. New features are added as layers on top of whatever is below, sometimes without really understanding it, and almost always without modifying it. Complexity and size grow without control. Evolution slows down. Understanding the system becomes harder every day. Bugs are harder to fix. Codebases become huge for no clear reason. At some point, the system can''t evolve anymore and becomes "legacy code". - -Complexity puts a limit to the level of understanding of the system a person might reach, and therefore limits the things that can be done with it. Dan Ingalls says all this in ["Design Principles Behind Smalltalk"] (http://www.cs.virginia.edu/~evans/cs655/readings/smalltalk.html). Even if you have already done so, please go and read it again!! - -Cuis Smalltalk is our attempt at this challenge. Furthermore, we believe we are doing something else that no other Smalltalk, commercial or open source, does. We attempt to give the true Smalltalk-80 experience, and keep Smalltalk-80 not as legacy software historic significance, but as a live, evolving system. We feel we are the keepers of the Smalltalk-80 heritage, and enablers of the Dynabook experience. - -As Cuis evolves, we keep on these values. Every update, be it a bug fix or a feature enhancement, is reviewed carefully to avoid adding unneded complexity to the system. Every opportunity to remove unneded complexity is followed. As we go, features are enhanced, and any reported bugs fixed. We also adopt selected enhancements from Squeak and Pharo, and share our work with the wider Smalltalk community. - - -' justified, -'License -' bold, -' -Cuis is distributed subject to the MIT License, as in http://www.opensource.org/licenses/mit-license.php . Any contribution submitted for incorporation into or for distribution with Cuis shall be presumed subject to the same license. - -Portions of Cuis are: -Copyright (c) Xerox Corp. 1981, 1982 -Copyright (c) Apple Computer, Inc. 1985-1996 -Copyright (c) Contributors to Squeak project. 1997-2020 -Copyright (c) Contributors to Cuis project. 1997-2020')! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4002-UpdateCopyrightNoticeYear-JuanVuletich-2020Jan01-16h44m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3997] on 2 January 2020 at 7:05:52 am'! - -RefactoringApplier subclass: #ChangeSelectorApplier - instanceVariableNames: 'oldSelector scopeChoice implementors senders implementingClass wizardStepWindow shouldShowChanges browser selectedClass ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ChangeSelectorApplier category: #'Tools-Refactoring' stamp: 'Install-4003-RefactoringAndBugFixingOfChangeSelectorRefactoring-HernanWilkinson-2019Dec31-15h01m-HAW.1.cs.st 1/11/2020 17:58:50'! -RefactoringApplier subclass: #ChangeSelectorApplier - instanceVariableNames: 'oldSelector scopeChoice implementors senders implementingClass wizardStepWindow shouldShowChanges browser selectedClass' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelectorApplier subclass: #AddParameterApplier - instanceVariableNames: 'newParameter newParameterValue newKeyword parameterIndex' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #AddParameterApplier category: #'Tools-Refactoring' stamp: 'Install-4003-RefactoringAndBugFixingOfChangeSelectorRefactoring-HernanWilkinson-2019Dec31-15h01m-HAW.1.cs.st 1/11/2020 17:58:50'! -ChangeSelectorApplier subclass: #AddParameterApplier - instanceVariableNames: 'newParameter newParameterValue newKeyword parameterIndex' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelectorApplier subclass: #RemoveParameterApplier - instanceVariableNames: 'newParameter newParameterValue newKeyword originalMethod parameterToRemove parameterToRemoveIndex parameterToRemoveName ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RemoveParameterApplier category: #'Tools-Refactoring' stamp: 'Install-4003-RefactoringAndBugFixingOfChangeSelectorRefactoring-HernanWilkinson-2019Dec31-15h01m-HAW.1.cs.st 1/11/2020 17:58:50'! -ChangeSelectorApplier subclass: #RemoveParameterApplier - instanceVariableNames: 'newParameter newParameterValue newKeyword originalMethod parameterToRemove parameterToRemoveIndex parameterToRemoveName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!MethodReference methodsFor: 'testing' stamp: 'HAW 1/2/2020 06:45:07'! - referencesParameterAt: parameterIndex - - ^(self compiledMethodIfAbsent: [ ^false ]) referencesParameterAt: parameterIndex ! ! -!RemoveParameter class methodsFor: 'instance creation' stamp: 'HAW 1/1/2020 23:34:04'! - atIndex: parameterIndex named: aParameterToRemove from: oldSelector implementors: implementorsCollection senders: sendersCollection - - | newSelector | - - self assertCanRemoveParameterFrom: oldSelector. - self assert: parameterIndex isValidFor: oldSelector. - - self assertAllImplementors: implementorsCollection haveSame: oldSelector. - self assertAllSenders: sendersCollection send: oldSelector. - self assertNoImplementorFrom: implementorsCollection reference: aParameterToRemove definedAt: parameterIndex. - - newSelector := self newSelectorFrom: oldSelector removingParameterAt: parameterIndex. - - ^self new - initializeNamed: aParameterToRemove - ofKeywordAtIndex: parameterIndex - from: oldSelector - creating: newSelector - implementors: implementorsCollection - senders: sendersCollection -! ! -!RemoveParameter class methodsFor: 'pre-conditions' stamp: 'HAW 1/1/2020 23:39:59'! - assert: parameterIndex isValidFor: oldSelector - - parameterIndex isInteger ifFalse: [ self signalInvalidParameterIndex ]. - (parameterIndex between: 1 and: oldSelector numArgs) ifFalse: [ self signalInvalidParameterIndex ].! ! -!RemoveParameter class methodsFor: 'exceptions' stamp: 'HAW 1/1/2020 23:35:34'! - invalidParameterIndexErrorMessage - - ^'Invalid parameter index'! ! -!RemoveParameter class methodsFor: 'exceptions' stamp: 'HAW 1/1/2020 23:35:19'! - signalInvalidParameterIndex - - self refactoringError: self invalidParameterIndexErrorMessage! ! -!ChangeSelectorApplier class methodsFor: 'instance creation' stamp: 'HAW 1/2/2020 00:05:51'! - on: aMessageNode createAndValueHandlingExceptionsOn: aModel in: aSelectedClass at: aSelectedSelector - - ^self createAndValueHandlingExceptionsOn: aModel for: aMessageNode selector key in: aSelectedClass -! ! -!AddParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 1/1/2020 23:52:39'! - addAsLastParameterLabel - - ^ 'Add as last parameter'! ! -!AddParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 1/1/2020 23:52:39'! - askInsertionIndexUsingKeywords - - | keywords | - - keywords := oldSelector keywords asOrderedCollection. - keywords add: self addAsLastParameterLabel. - - parameterIndex := (PopUpMenu labelArray: keywords) startUpWithCaption: 'Select keyword to add parameter before'. - parameterIndex = 0 ifTrue: [self endRequest ]. - - ! ! -!RemoveParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 1/1/2020 23:19:25'! - askKeywordToRemove - - | keywords | - - keywords := oldSelector keywords. - - keywords size = 1 - ifTrue: [ parameterToRemoveIndex := 1 ] - ifFalse: [ parameterToRemoveIndex := self selectKeywordIndexToRemoveFrom: keywords ]. - - "Because I do not know the parameter name, I'll use this one as explanation - Hernan" - parameterToRemoveName := 'Parameter related to keyword ', (keywords at: parameterToRemoveIndex) ! ! -!RemoveParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 1/1/2020 23:18:18'! -selectKeywordIndexToRemoveFrom: keywords - - | keywordIndex | - - keywordIndex := (PopUpMenu labelArray: keywords) startUpWithCaption: 'Select keyword related to parameter to remove'. - keywordIndex = 0 ifTrue: [self endRequest ]. - - ^keywordIndex! ! -!RemoveParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 1/1/2020 23:21:19'! - selectParameterIndexToRemoveFrom: parameterNames - - | parameterIndex | - - parameterIndex := (PopUpMenu labelArray: parameterNames) startUpWithCaption: 'Select parameter to remove'. - parameterIndex = 0 ifTrue: [self endRequest ]. - - ^parameterIndex! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 1/2/2020 00:04:31' prior: 50450100! - renameSelectorOf: aMessageNode in: aSelectedClass at: aSelectedSelector - - RefactoringApplier renameSelectorApplier - on: aMessageNode - createAndValueHandlingExceptionsOn: model textProvider - in: aSelectedClass - at: aSelectedSelector! ! -!SmalltalkEditor methodsFor: 'contextual add/remove parameter' stamp: 'HAW 1/2/2020 00:04:31' prior: 50469441! - changeSelectorOf: aMessageNode in: aSelectedClass at: aSelectedSelector using: aChangeSelectorApplier - - aChangeSelectorApplier - on: aMessageNode - createAndValueHandlingExceptionsOn: model textProvider - in: aSelectedClass - at: aSelectedSelector! ! -!ChangeSelectorWizardStepWindow methodsFor: 'compile methods' stamp: 'HAW 1/1/2020 19:45:32' prior: 50491017! - compiledMethodsFrom: methodReferences - - "If the method is not implemented, I leave the not implemented reference because actual senders of it - should be renamed. This is important for LiveTyping Actual Scope Refactorings - Hernan" - ^ methodReferences collect: [:aMethodReference | - aMethodReference compiledMethodIfAbsent: [ aMethodReference ]]! ! -!MethodReference methodsFor: 'queries' stamp: 'HAW 1/1/2020 19:46:02' prior: 50452813! - compiledMethodIfAbsent: ifAbsentBlock - - ^ self actualClass - ifNil: ifAbsentBlock - ifNotNil: [ :aClass | aClass compiledMethodAt: methodSymbol ifAbsent: ifAbsentBlock ] ! ! -!MethodReference methodsFor: 'testing' stamp: 'HAW 1/2/2020 06:45:39' prior: 50486788! - hasVariableBindingTo: aClass - - ^(self compiledMethodIfAbsent: [ ^false ]) hasVariableBindingTo: aClass -! ! -!ChangeSelector methodsFor: 'create new implementors - private' stamp: 'HAW 1/1/2020 19:44:25' prior: 50438611! - createNewImplementors - - implementors - select: [ :anImplementor | anImplementor isValid ] - thenDo: [:anImplementor | self createNewImplementorOf: anImplementor ] - ! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 1/2/2020 07:00:51' prior: 50439252! - assertNewParameter: aNewParameter isNotDefinedAsInstanceVariableInAny: implementors - - | classesDefiningInsVars | - - classesDefiningInsVars := self classesDefiningInstanceVariable: aNewParameter inAny: implementors. - classesDefiningInsVars ifNotEmpty: [ - self signalNewParameter: aNewParameter definedAsInstanceVariableIn: classesDefiningInsVars ]! ! -!AddParameter class methodsFor: 'pre-conditions' stamp: 'HAW 1/2/2020 07:00:58' prior: 50439266! - assertNewParameter: aNewParameter isNotDefinedAsLocalInAny: implementors - - | implementorsDefiningNewParameterAsLocal | - - implementorsDefiningNewParameterAsLocal := implementors select: [ :implementor | - implementor isValid and: [ implementor methodNode hasLocalNamed: aNewParameter ]]. - implementorsDefiningNewParameterAsLocal ifNotEmpty: [ - self signalNewParameter: aNewParameter isDefinedAsLocalIn: implementorsDefiningNewParameterAsLocal ]! ! -!RemoveParameter class methodsFor: 'instance creation' stamp: 'HAW 1/2/2020 00:23:12' prior: 50439625! - named: aParameterToRemove from: aMethod implementors: implementorsCollection senders: sendersCollection - - | parameterIndex | - - parameterIndex := self assert: aParameterToRemove isDefinedIn: aMethod methodNode. - - ^self - atIndex: parameterIndex - named: aParameterToRemove - from: aMethod selector - implementors: implementorsCollection - senders: sendersCollection ! ! -!RefactoringApplier class methodsFor: 'value handling exceptions' stamp: 'HAW 12/30/2019 16:46:47' prior: 50491051! - createAndValueHandlingExceptions: creationBlock - - | applier | - - applier := creationBlock - on: Refactoring refactoringErrorClass - do: [ :refactoringError | ^self inform: refactoringError messageText ]. - - applier value ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 1/1/2020 21:52:03' prior: 50441556! - implementorsAndSendersForClass - - ^self refactoringClass - addImplementorsOf: oldSelector - to: implementors - andSendersTo: senders - forClassAndMetaOf: selectedClass! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 1/1/2020 21:52:03' prior: 50441565! -implementorsAndSendersForHierarchy - - ^self refactoringClass - addImplementorsOf: oldSelector - to: implementors - andSendersTo: senders - inHierarchyOf: selectedClass! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 1/1/2020 21:52:03' prior: 50441574! -implementorsAndSendersInCategory - - ^self refactoringClass - addImplementorsOf: oldSelector - to: implementors - andSendersTo: senders - inCategory: selectedClass category - organizedBy: SystemOrganization! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 1/1/2020 21:52:02' prior: 50441585! - implementorsAndSendersInCategoryAndHierarchy - - ^self refactoringClass - addImplementorsOf: oldSelector - to: implementors - andSendersTo: senders - inCategoriesAndHierarchyOf: selectedClass - organizedBy: SystemOrganization ! ! -!ChangeSelectorApplier methodsFor: 'initialization' stamp: 'HAW 1/1/2020 21:54:19' prior: 50441712! - initializeOn: aBrowser for: aSelector in: aSelectedClass - - oldSelector := aSelector. - selectedClass := aSelectedClass. - browser := aBrowser. - shouldShowChanges := true.! ! -!ChangeSelectorApplier class methodsFor: 'pre-conditions' stamp: 'HAW 1/1/2020 21:55:17' prior: 50441762! - assertCanApplyRefactoringFor: aSelector in: aSelectedClass - - self subclassResponsibility ! ! -!ChangeSelectorApplier class methodsFor: 'instance creation' stamp: 'HAW 1/1/2020 21:54:30' prior: 50450275! - on: aBrowser for: aSelector in: aSelectedClass - - self assertCanApplyRefactoringFor: aSelector in: aSelectedClass. - - ^self new initializeOn: aBrowser for: aSelector in: aSelectedClass - ! ! -!AddParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 1/2/2020 07:02:14' prior: 50441814! - askInsertionIndex - - | methodNode originalMethod parameterNames | - - "See RemoveParameterApplier#askParameterToRemove to understand why I ask for the index using - the keywords when no method is found - Hernan" - originalMethod := selectedClass - compiledMethodAt: oldSelector - ifAbsent: [ ^self askInsertionIndexUsingKeywords ]. - - methodNode := originalMethod methodNode. - parameterNames := methodNode argumentNames. - parameterNames add: self addAsLastParameterLabel. - - parameterIndex := (PopUpMenu labelArray: parameterNames) startUpWithCaption: 'Add parameter before?'. - parameterIndex = 0 ifTrue: [self endRequest ]. - - ! ! -!AddParameterApplier class methodsFor: 'pre-conditions' stamp: 'HAW 1/1/2020 21:55:05' prior: 50441887! - assertCanApplyRefactoringFor: aSelector in: aSelectedClass - - AddParameter assertCanAddParameterTo: aSelector. - - - ! ! -!ChangeKeywordsSelectorOrderApplier class methodsFor: 'pre-conditions' stamp: 'HAW 1/1/2020 21:55:12' prior: 50448113! - assertCanApplyRefactoringFor: aSelector in: aSelectedClass - - ChangeKeywordsSelectorOrder assertIsKeywordWithMoreThanOneParameter: aSelector ! ! -!RenameSelectorApplier class methodsFor: 'pre-conditions' stamp: 'HAW 1/1/2020 21:55:26' prior: 50441982! - assertCanApplyRefactoringFor: aSelector in: aSelectedClass - - ! ! -!RemoveParameterApplier methodsFor: 'refactoring - creation' stamp: 'HAW 1/1/2020 23:25:59' prior: 50441894! - createRefactoring - - ^self refactoringClass - atIndex: parameterToRemoveIndex - named: parameterToRemoveName - from: oldSelector - implementors: implementors - senders: senders ! ! -!RemoveParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 1/1/2020 23:28:37' prior: 50441907! - askParameterToRemove - - | methodNode parameterNames selectedMethod | - - "If the compiled method does not exist it means that the remove is being executed from the - editor, in a message send therefore we can not ask for the parameter name unless we look for implementors or - use LiveTyping to look for actual implementors, etc. - To make it simpler, when we can know the parameter names, we use that. When we can not, we use the keyword - names. I tried to used only keyword names but it is not so intuitive. I decided to use two different ways of asking - instead of one (asking for keyword names) becuase I think the programmer prefers to see parameter names. - - It could happen that the selected class implements the message to remove the parameter but that the remove - is executed from the editor (not sending to self), in that case the parameters of selected class implementation - will be use... it is a rare case and I think it will not confuse the programmer - Hernan" - - selectedMethod := selectedClass - compiledMethodAt: oldSelector - ifAbsent: [ ^self askKeywordToRemove ]. - - methodNode := selectedMethod methodNode. - parameterNames := methodNode argumentNames. - - parameterToRemoveIndex := parameterNames size = 1 - ifTrue: [ 1 ] - ifFalse: [ self selectParameterIndexToRemoveFrom: parameterNames ]. - - parameterToRemoveName := parameterNames at: parameterToRemoveIndex. - - - ! ! -!RemoveParameterApplier class methodsFor: 'pre-conditions' stamp: 'HAW 1/1/2020 21:55:21' prior: 50441941! - assertCanApplyRefactoringFor: aSelector in: aSelectedClass - - RemoveParameter assertCanRemoveParameterFrom: aSelector. - - - ! ! -!CompiledMethod methodsFor: 'testing' stamp: 'HAW 1/2/2020 07:21:15'! - isValid - - "To be polimorphic with MethodReference, important for refactorings - Hernan" - ^true! ! - -RemoveParameterApplier class removeSelector: #createAndValueHandlingExceptionsOn:of:in:at:! - -!methodRemoval: RemoveParameterApplier class #createAndValueHandlingExceptionsOn:of:in:at: stamp: 'Install-4003-RefactoringAndBugFixingOfChangeSelectorRefactoring-HernanWilkinson-2019Dec31-15h01m-HAW.1.cs.st 1/11/2020 17:58:50'! -createAndValueHandlingExceptionsOn: aModel of: aMessageNode in: aSelectedClass at: aSelectedSelector - - ^self createAndValueHandlingExceptionsOn: aModel for: aMessageNode selector key in: aSelectedClass -! - -RemoveParameterApplier class removeSelector: #on:createAndValueHandlingExceptionsOn:of:in:at:! - -RemoveParameterApplier class removeSelector: #on:createAndValueHandlingExceptionsOn:in:at:! - -RemoveParameterApplier removeSelector: #selectKeywordToRemoveFrom:! - -RemoveParameterApplier removeSelector: #selectParameterToRemoveForm:! - -!methodRemoval: RemoveParameterApplier #selectParameterToRemoveForm: stamp: 'Install-4003-RefactoringAndBugFixingOfChangeSelectorRefactoring-HernanWilkinson-2019Dec31-15h01m-HAW.1.cs.st 1/11/2020 17:58:50'! -selectParameterToRemoveForm: parameterNames - - | parameterIndex | - - parameterIndex := (PopUpMenu labelArray: parameterNames) startUpWithCaption: 'Select parameter to remove'. - parameterIndex = 0 ifTrue: [self endRequest ]. - - ^parameterNames at: parameterIndex.! - -RemoveParameterApplier removeSelector: #selectParameterToRemoveFrom:! - -RenameSelectorApplier class removeSelector: #createAndValueHandlingExceptionsOn:of:in:at:! - -!methodRemoval: RenameSelectorApplier class #createAndValueHandlingExceptionsOn:of:in:at: stamp: 'Install-4003-RefactoringAndBugFixingOfChangeSelectorRefactoring-HernanWilkinson-2019Dec31-15h01m-HAW.1.cs.st 1/11/2020 17:58:50'! -createAndValueHandlingExceptionsOn: aModel of: aMessageNode in: aSelectedClass at: aSelectedSelector - - ^self createAndValueHandlingExceptionsOn: aModel for: aMessageNode selector key in: aSelectedClass -! - -RenameSelectorApplier class removeSelector: #on:createAndValueHandlingExceptionsOn:of:in:at:! - -RenameSelectorApplier class removeSelector: #on:createAndValueHandlingExceptionsOn:in:at:! - -AddParameterApplier class removeSelector: #createAndValueHandlingExceptionsOn:of:in:at:! - -!methodRemoval: AddParameterApplier class #createAndValueHandlingExceptionsOn:of:in:at: stamp: 'Install-4003-RefactoringAndBugFixingOfChangeSelectorRefactoring-HernanWilkinson-2019Dec31-15h01m-HAW.1.cs.st 1/11/2020 17:58:50'! -createAndValueHandlingExceptionsOn: aModel of: aMessageNode in: aSelectedClass at: aSelectedSelector - - ^self createAndValueHandlingExceptionsOn: aModel for: aMessageNode selector key in: aSelectedClass -! - -AddParameterApplier class removeSelector: #on:createAndValueHandlingExceptionsOn:of:in:at:! - -AddParameterApplier class removeSelector: #on:createAndValueHandlingExceptionsOn:in:at:! - -RefactoringApplier subclass: #ChangeSelectorApplier - instanceVariableNames: 'oldSelector scopeChoice implementors senders selectedClass wizardStepWindow shouldShowChanges browser' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ChangeSelectorApplier category: #'Tools-Refactoring' stamp: 'Install-4003-RefactoringAndBugFixingOfChangeSelectorRefactoring-HernanWilkinson-2019Dec31-15h01m-HAW.1.cs.st 1/11/2020 17:58:51'! -RefactoringApplier subclass: #ChangeSelectorApplier - instanceVariableNames: 'oldSelector scopeChoice implementors senders selectedClass wizardStepWindow shouldShowChanges browser' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -ChangeSelectorApplier subclass: #RemoveParameterApplier - instanceVariableNames: 'parameterToRemoveIndex parameterToRemoveName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #RemoveParameterApplier category: #'Tools-Refactoring' stamp: 'Install-4003-RefactoringAndBugFixingOfChangeSelectorRefactoring-HernanWilkinson-2019Dec31-15h01m-HAW.1.cs.st 1/11/2020 17:58:51'! -ChangeSelectorApplier subclass: #RemoveParameterApplier - instanceVariableNames: 'parameterToRemoveIndex parameterToRemoveName' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4003-RefactoringAndBugFixingOfChangeSelectorRefactoring-HernanWilkinson-2019Dec31-15h01m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #3997] on 2 January 2020 at 11:25:04 am'! -!SmalltalkEditor methodsFor: 'menu' stamp: 'HAW 1/2/2020 10:13:18'! - openSmalltalkEditorRefactoringMenu - - ^self refactoringMenu popUpInWorld! ! -!SmalltalkEditor methodsFor: 'menu' stamp: 'HAW 1/2/2020 11:21:36'! - refactoringMenu - - ^DynamicMenuBuilder - buildTitled: 'More refactorings' - targeting: self - collectingMenuOptionsWith: #smalltalkEditorRefactoringMenuOptions.! ! -!RefactoringMenues class methodsFor: 'editor menus' stamp: 'HAW 1/2/2020 11:21:44'! - smalltalkEditorRefactoringMenuOptions - - ^`{ - { - #itemGroup -> 35. - #itemOrder -> 30. - #label -> 'Add Parameter... (A)'. - #selector -> #contextualAddParameter. - #icon -> #listAddIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 40. - #label -> 'Remove Parameter... (S)'. - #selector -> #contextualRemoveParameter. - #icon -> #listRemoveIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 50. - #label -> 'Temporary to Instance Variable (O)'. - #selector -> #temporaryToInstanceVariable. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 60. - #label -> 'Push Up Instance Variable'. - #selector -> #contextualPushUpInClassDefinition. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 70. - #label -> 'Push Down Instance Variable'. - #selector -> #contextualPushDownInClassDefinition. - #icon -> #goBottomIcon - } asDictionary. - }`! ! -!RefactoringMenues class methodsFor: 'editor menus' stamp: 'HAW 1/2/2020 10:12:44' prior: 50490773! - smalltalkEditorMenuOptions - - ^`{ - { - #itemGroup -> 35. - #itemOrder -> 10. - #label -> 'Rename... (R)'. - #selector -> #contextualRename. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 20. - #label -> 'Extract Method... (K)'. - #selector -> #extractMethod. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 30. - #label -> 'More Refactorings...'. - #selector -> #openSmalltalkEditorRefactoringMenu. - #icon -> #listAddIcon - } asDictionary. - }`! ! - -SmalltalkEditor removeSelector: #openClassRefactoringMenu! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4004-SmalltalkEditorRefactoringMenu-HernanWilkinson-2020Jan02-07h21m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #4003] on 2 January 2020 at 10:01:34 pm'! - -"Change Set: 4004-CuisCore-AuthorName-2020Jan02-21h40m -Date: 2 January 2020 -Author: Nahuel Garbezza - -Fixes to Extract Method refactoring: - -* bug: extra arguments were selected for the extracted message when extracting blocks -* change :: usage to facilitate interoperability -* rename 'ensure' by 'assert' to have consistency with other refactorings"! -!ExtractMethod class methodsFor: 'validations' stamp: 'RNG 1/2/2020 21:50:31'! - assert: aSelector canBeDefinedIn: aClass - - ExtractMethodNewSelectorPrecondition valueFor: aSelector on: aClass! ! -!ExtractMethod class methodsFor: 'validations' stamp: 'RNG 1/2/2020 21:51:30'! - assert: anIntervalToExtract isValidIntervalOn: aMethodToExtractCodeFrom - - (self isNotEmpty: anIntervalToExtract) - ifFalse: [ self signalNoSelectedCodeError ]. - (self is: anIntervalToExtract withinBoundsOf: aMethodToExtractCodeFrom sourceCode) - ifFalse: [ self signalOutOfBoundsIntervalError ]. - (self method: aMethodToExtractCodeFrom containsAValidExpressionOn: anIntervalToExtract) - ifFalse: [ self signalSelectedCodeIsInvalidForExtractError ].! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 1/2/2020 21:55:44' prior: 50489367! - containsValidNodes - - ^ self isNotLeftSideOfAssignment - and: [ self thereAreNoLocalVariableAssignments ] - and: [ self thereAreNoReturnExpressions ] - and: [ self isNotATempDeclaration ]! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 1/2/2020 21:56:11' prior: 50489409! - isLeftSideOfAssignment - - ^ initialNodeAncestors size > 1 - and: [ initialNodeAncestors second key isAssignmentNode ] - and: [ initialNodeAncestors second key variable = initialNode key ]! ! -!ExtractMethodExpressionValidation methodsFor: 'validation' stamp: 'RNG 1/2/2020 21:56:53' prior: 50489495! - passed - - methodNode _ method methodNode. - sourceCode _ method sourceCode. - initialNodeAncestors _ methodNode parseNodesPathAt: intervalToExtract first ifAbsent: [ ^ false]. - finalNodeAncestors _ methodNode parseNodesPathAt: intervalToExtract last ifAbsent: [ ^ false ]. - initialNode _ initialNodeAncestors first. - finalNode _ finalNodeAncestors first. - - ^ self intervalCoversCompleteAstNodes - and: [ self containsValidNodes ] - and: [ self startAndEndParseNodesAreTheSame - or: [ self startAndEndNodesShareAParentNode ] - or: [ self intervalMatchesBeginningOfStatement and: [ self intervalMatchesEndOfStatement ] ] ]! ! -!ExtractMethod methodsFor: 'private - source code' stamp: 'RNG 1/2/2020 21:58:40' prior: 50488807! - shouldBeEnclosedWithParens - - | initialNode finalNode parseNodesInCommon methodNode initialNodeAncestors finalNodeAncestors insideMessageNodeExpressions | - - methodNode _ existingMethod methodNode. - initialNodeAncestors _ methodNode parseNodesPathAt: intervalToExtract first ifAbsent: [ ^ false]. - finalNodeAncestors _ methodNode parseNodesPathAt: intervalToExtract last ifAbsent: [ ^ false ]. - parseNodesInCommon _ initialNodeAncestors intersection: finalNodeAncestors. - - initialNode _ (parseNodesInCommon at: 1 ifAbsent: [ ^ false ]) key. - finalNode _ (parseNodesInCommon at: 2 ifAbsent: [ ^ false ]) key. - insideMessageNodeExpressions _ initialNode isMessageNode and: [ finalNode isMessageNode ]. - - ^ insideMessageNodeExpressions - and: [ initialNode precedence < newMessage selector precedence ] - and: [ initialNode precedence <= finalNode precedence ]! ! -!ExtractMethod class methodsFor: 'instance creation' stamp: 'RNG 1/2/2020 21:51:11' prior: 50488938! - fromInterval: anIntervalToExtract of: aMethodToExtractCodeFrom to: newMessage categorizedAs: aCategory - - | trimmedIntervalToExtract | - trimmedIntervalToExtract _ ExtractMethodIntervalTrimmer - trim: anIntervalToExtract locatedIn: aMethodToExtractCodeFrom sourceCode. - self - assert: newMessage selector canBeDefinedIn: aMethodToExtractCodeFrom methodClass; - assert: trimmedIntervalToExtract isValidIntervalOn: aMethodToExtractCodeFrom. - - ^ self new - initializeFrom: trimmedIntervalToExtract - of: aMethodToExtractCodeFrom - to: newMessage - in: aCategory! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 1/2/2020 21:53:15' prior: 50488959! - blockNodesEnclosingIntervalToExtract - - | nodes | - nodes _ Set new. - methodToExtractCodeFrom methodNode completeSourceRangesDo: [ :parseNode :sourceRanges | - (parseNode isBlockNode and: [ self intervalToExtractIsCoveredByAnyOf: sourceRanges ]) - ifTrue: [ nodes add: parseNode ] ]. - ^ nodes! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 1/2/2020 21:47:50' prior: 50488994! - definedInOuterScope: parseNode - - ^ self nodesThatAddVariablesToScope - anySatisfy: [ :node | node hasLocallyArgumentOrTemporaryNamed: parseNode name ]! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 1/2/2020 21:45:39' prior: 50489017! - intervalToExtractIsCoveredByAnyOf: sourceRanges - - ^ sourceRanges anySatisfy: [ :sourceRange | - sourceRange first < intervalToExtract first - and: [ sourceRange last > intervalToExtract last ] ]! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 1/2/2020 21:53:56' prior: 50489047! - saveBinaryOrKeywordSelector: userAnswer withArguments: parseNodesToParameterize - - self saveMessageArgumentsForEach: parseNodesToParameterize using: userAnswer. - newSelector _ ('' join: (self selectorTokensOf: userAnswer)) asSymbol.! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 1/2/2020 21:59:32' prior: 50489084! - shouldBeParameterized: parseNode appearingIn: sourceRanges - - ^ (sourceRanges anySatisfy: [ :sourceRange | intervalToExtract includes: sourceRange first ]) - and: [ parseNode isTempOrArg ] - and: [ self definedInOuterScope: parseNode ]! ! -!ExtractMethodApplier class methodsFor: 'pre-conditions' stamp: 'RNG 1/2/2020 21:51:11' prior: 50489190! - assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: anIntervalToExtract - - ExtractMethod - assert: anIntervalToExtract - isValidIntervalOn: aMethodToExtractCodeFrom! ! - -ExtractMethod class removeSelector: #ensure:isValidIntervalOn:! - -!methodRemoval: ExtractMethod class #ensure:isValidIntervalOn: stamp: 'Install-4005-ExtractMethodFix-NahuelGarbezza-2020Jan02-21h40m-RNG.1.cs.st 1/11/2020 17:58:51'! -ensure: anIntervalToExtract isValidIntervalOn: aMethodToExtractCodeFrom - - self isNotEmpty: anIntervalToExtract - :: ifFalse: [ self signalNoSelectedCodeError ]. - self is: anIntervalToExtract withinBoundsOf: aMethodToExtractCodeFrom sourceCode - :: ifFalse: [ self signalOutOfBoundsIntervalError ]. - self method: aMethodToExtractCodeFrom containsAValidExpressionOn: anIntervalToExtract - :: ifFalse: [ self signalSelectedCodeIsInvalidForExtractError ].! - -ExtractMethod class removeSelector: #ensure:canBeDefinedIn:! - -!methodRemoval: ExtractMethod class #ensure:canBeDefinedIn: stamp: 'Install-4005-ExtractMethodFix-NahuelGarbezza-2020Jan02-21h40m-RNG.1.cs.st 1/11/2020 17:58:51'! -ensure: aSelector canBeDefinedIn: aClass - - ExtractMethodNewSelectorPrecondition valueFor: aSelector on: aClass! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4005-ExtractMethodFix-NahuelGarbezza-2020Jan02-21h40m-RNG.1.cs.st----! - -'From Cuis 5.0 [latest update: #4005] on 9 January 2020 at 4:34:58 pm'! -!Text methodsFor: 'emphasis' stamp: 'jmv 1/9/2020 11:59:43'! - colorAt: characterIndex - "Answer the color for characters in the run beginning at characterIndex." - - self - withAttributeValues: (self attributesAt: characterIndex) - do: [ :familyName :pointSize :emphasis :color :alignment :characterStyle :paragraphStyle :backgroundColor | - ^ color ]! ! -!Text methodsFor: 'adding color' stamp: 'jmv 1/9/2020 12:15:35'! - color: aColor - "Stuff like - 'Hello world' blue edit - " - self addAttribute: (TextColor color: aColor)! ! -!Text methodsFor: 'emphasis' stamp: 'jmv 1/9/2020 12:11:24' prior: 16929248! - addAttribute: att - string size = 0 ifTrue: [ ^self ]. - ^ self addAttribute: att from: 1 to: self size! ! -!Text methodsFor: 'adding emphasis' stamp: 'jmv 1/9/2020 12:16:25' prior: 50462427! - bold - "Stuff like - ('X' italic, '2' super, ' + ', 'H' bold, 'ij' sub, ' + ', 'lim' italic under, 'z  ' sub, '(1 / z)' ) edit - " - self addAttribute: TextEmphasis bold! ! -!Text methodsFor: 'adding emphasis' stamp: 'jmv 1/9/2020 12:16:49' prior: 50462437! - italic - "Stuff like - ('X' italic, '2' super, ' + ', 'H' bold, 'ij' sub, ' + ', 'lim' italic under, 'z  ' sub, '(1 / z)' ) edit - " - self addAttribute: TextEmphasis italic! ! -!Text methodsFor: 'adding emphasis' stamp: 'jmv 1/9/2020 12:18:12' prior: 50471521! - pointSize: pointSize - "Stuff like - ('Hello World' pointSize: 22) edit - " - self addAttribute: (TextFontFamilyAndSize pointSize: pointSize)! ! -!Text methodsFor: 'adding emphasis' stamp: 'jmv 1/9/2020 12:18:47' prior: 16929749! - struck - "Stuff like - ('Hello world' struck ) edit - " - self addAttribute: TextEmphasis struckThrough! ! -!Text methodsFor: 'adding emphasis' stamp: 'jmv 1/9/2020 12:19:00' prior: 50462447! - sub - "Stuff like - ('X' italic, '2' super, ' + ', 'H' bold, 'ij' sub, ' + ', 'lim' italic under, 'z  ' sub, '(1 / z)' ) edit - " - self addAttribute: TextEmphasis subscript! ! -!Text methodsFor: 'adding emphasis' stamp: 'jmv 1/9/2020 12:19:10' prior: 50462457! - super - "Stuff like - ('X' italic, '2' super, ' + ', 'H' bold, 'ij' sub, ' + ', 'lim' italic under, 'z  ' sub, '(1 / z)' ) edit - " - self addAttribute: TextEmphasis superscript! ! -!Text methodsFor: 'adding emphasis' stamp: 'jmv 1/9/2020 12:19:21' prior: 50462468! - under - "Stuff like - ('X' italic, '2' super, ' + ', 'H' bold, 'ij' sub, ' + ', 'lim' italic under, 'z  ' sub, '(1 / z)' ) edit - " - self addAttribute: TextEmphasis underlined! ! -!Text methodsFor: 'adding attributes' stamp: 'jmv 1/9/2020 12:16:39' prior: 50471530! - centered - "Stuff like - ('Hello world' centered ) edit - " - self addAttribute: TextAlignment centered! ! -!Text methodsFor: 'adding attributes' stamp: 'jmv 1/9/2020 12:17:33' prior: 50471538! - justified - "Stuff like - ('Hello world. Hello world. Hello world. Hello world. Hello world. Hello world. Hello world. Hello world. Hello world. Hello world. Hello world. Hello world. Hello world. Hello world. Hello world. Hello world. Hello world. Hello world. Hello world. Hello world. Hello world. ' justified ) edit - " - self addAttribute: TextAlignment justified! ! -!Text methodsFor: 'adding attributes' stamp: 'jmv 1/9/2020 12:17:54' prior: 50471546! - leftFlush - "Stuff like - ('Hello world' leftFlush ) edit - " - self addAttribute: TextAlignment leftFlush! ! -!Text methodsFor: 'adding attributes' stamp: 'jmv 1/9/2020 12:18:23' prior: 50471554! -rightFlush - "Stuff like - ('Hello world' rightFlush ) edit - " - self addAttribute: TextAlignment rightFlush! ! -!Text methodsFor: 'adding color' stamp: 'jmv 1/9/2020 12:12:58' prior: 50471562! - black - "Stuff like - 'Hello world' black edit - " - self color: Color black! ! -!Text methodsFor: 'adding color' stamp: 'jmv 1/9/2020 12:12:40' prior: 50471569! - blue - "Stuff like - 'Hello world' blue edit - " - self color: Color blue! ! -!Text methodsFor: 'adding color' stamp: 'jmv 1/9/2020 12:13:20' prior: 50471576! - cyan - "Stuff like - 'Hello world' cyan edit - " - self color: Color cyan! ! -!Text methodsFor: 'adding color' stamp: 'jmv 1/9/2020 12:13:38' prior: 50471583! - gray - "Stuff like - 'Hello world' gray edit - " - self color: Color gray! ! -!Text methodsFor: 'adding color' stamp: 'jmv 1/9/2020 12:13:51' prior: 50471590! - green - "Stuff like - 'Hello world' green edit - " - self color: Color green! ! -!Text methodsFor: 'adding color' stamp: 'jmv 1/9/2020 12:14:13' prior: 50471597! - magenta - "Stuff like - 'Hello world' magenta edit - " - self color: Color magenta! ! -!Text methodsFor: 'adding color' stamp: 'jmv 1/9/2020 12:14:27' prior: 50471604! - red - "Stuff like - 'Hello world' red edit - " - self color: Color red! ! -!Text methodsFor: 'adding color' stamp: 'jmv 1/9/2020 12:14:45' prior: 50471611! - yellow - "Stuff like - 'Hello world' yellow edit - " - self color: Color yellow! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4006-Text-cleanup-JuanVuletich-2020Jan09-16h33m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4006] on 9 January 2020 at 4:38:36 pm'! -!InnerListMorph methodsFor: 'drawing' stamp: 'jmv 1/9/2020 16:37:23' prior: 16855140! - draw: item atRow: row on: canvas - "display the given item at row row" - | f | - f _ (item is: #Text) - ifTrue: [ font emphasized: (item emphasisAt: 1) ] - ifFalse: [ font ]. - canvas - drawString: item - at: 0 @ (self drawYForRow: row) - font: f - color: Theme current text! ! - -Theme removeSelector: #listSelectedRowText! - -!methodRemoval: Theme #listSelectedRowText stamp: 'Install-4007-InnerListMorph-cleanup-JuanVuletich-2020Jan09-16h37m-jmv.1.cs.st 1/11/2020 17:58:51'! -listSelectedRowText - ^ self text! - -Theme removeSelector: #listUnselectedRowText! - -!methodRemoval: Theme #listUnselectedRowText stamp: 'Install-4007-InnerListMorph-cleanup-JuanVuletich-2020Jan09-16h37m-jmv.1.cs.st 1/11/2020 17:58:51'! -listUnselectedRowText - ^ self text! - -InnerListMorph removeSelector: #colorForRow:! - -!methodRemoval: InnerListMorph #colorForRow: stamp: 'Install-4007-InnerListMorph-cleanup-JuanVuletich-2020Jan09-16h37m-jmv.1.cs.st 1/11/2020 17:58:51'! -colorForRow: row - ^(selectedRow notNil and: [ row = selectedRow]) - ifTrue: [ Theme current listSelectedRowText ] - ifFalse: [ Theme current listUnselectedRowText ].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4007-InnerListMorph-cleanup-JuanVuletich-2020Jan09-16h37m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4007] on 9 January 2020 at 5:25:46 pm'! -!ChangeList methodsFor: 'menu actions' stamp: 'jmv 1/9/2020 17:25:05' prior: 16796356! - removeUpToDate - "Remove all up to date version of entries from the receiver" - - | newChangeList newList | - newChangeList _ OrderedCollection new. - newList _ OrderedCollection new. - changeList with: list do: [ :chRec :strNstamp | | keep cls name | - keep _ chRec isClassDeletion not or: [ chRec changeClass notNil ]. "If a class deletion, and class already gone, don't keep it" - keep ifTrue: [ - (cls _ chRec changeClass) ifNotNil: [ | sel str | - str _ chRec string. - sel _ chRec methodSelector. - keep _ chRec isMethodDeletion - ifTrue: [cls includesSelector: sel] - ifFalse: [(cls sourceCodeAt: sel ifAbsent: nil) ~= str]]]. - (chRec changeType == #classComment and: [ - name _ chRec changeClassName. - Smalltalk includesKey: name]) ifTrue: [ - cls _ Smalltalk at: name. - keep _ cls organization classComment ~= chRec text ]. - (chRec changeType == #classDefinition and: [ - name _ chRec changeClassName. - Smalltalk includesKey: name]) ifTrue: [ - cls _ Smalltalk at: name. - chRec isMetaClassChange ifTrue: [ cls _ cls class ]. - keep _ cls definition ~= chRec text ]. - keep ifTrue: [ - newChangeList add: chRec. - newList add: strNstamp]]. - newChangeList size < changeList size ifTrue: [ - changeList _ newChangeList. - list _ newList. - listIndex _ 0. - self clearSelections ]. - self changed: #list! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4008-removeUpToDate-doRemoveDeletionOfMissingMethods-JuanVuletich-2020Jan09-17h22m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4008] on 9 January 2020 at 5:43:07 pm'! -!Browser methodsFor: 'message list' stamp: 'jmv 1/9/2020 17:41:56' prior: 16792365! - messageList - "Answer an Array of the message selectors of the currently selected message category, provided that the messageCategoryListIndex is in proper range. Otherwise, answer an empty Array If messageCategoryListIndex is found to be larger than the number of categories (it happens!!), it is reset to zero." - | classOrMetaClassOrganizer sel answer | - classOrMetaClassOrganizer _ self classOrMetaClassOrganizer. - classOrMetaClassOrganizer isNil ifTrue: [ ^#() ]. - sel _ self messageCategoryListSelection. - (sel isNil or: [ sel == ClassOrganizer allCategory ]) ifTrue: [ - ^ classOrMetaClassOrganizer allMethodSelectors]. - selectedMessageCategory isNil ifTrue: [ ^#() ]. - answer _ classOrMetaClassOrganizer listAtCategoryNamed: selectedMessageCategory. - answer isNil ifTrue: [ - selectedMessageCategory _ nil. - answer _ #() ]. - ^answer! ! -!PluggableListMorph methodsFor: 'initialization' stamp: 'jmv 1/9/2020 17:28:19' prior: 16888766! - initialize - super initialize. - scroller morphWidth: extent x.! ! - -PluggableListMorph removeSelector: #textColor! - -!methodRemoval: PluggableListMorph #textColor stamp: 'Install-4009-Cleanup-JuanVuletich-2020Jan09-17h28m-jmv.1.cs.st 1/11/2020 17:58:51'! -textColor - "" - ^ Theme current text! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4009-Cleanup-JuanVuletich-2020Jan09-17h28m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4009] on 9 January 2020 at 6:04:38 pm'! -!Browser methodsFor: 'message category functions' stamp: 'jmv 1/9/2020 18:00:54' prior: 16792026! -categoryOfCurrentMethod - "Determine the method category associated with the receiver at the current moment, or nil if none" - - | category | - ^ super categoryOfCurrentMethod ifNil: [ - category _ selectedMessageCategory. - category == ClassOrganizer allCategory - ifTrue: [nil] - ifFalse: [category]]! ! -!Browser methodsFor: 'message list' stamp: 'jmv 1/9/2020 18:01:53' prior: 50492492! - messageList - "Answer an Array of the message selectors of the currently selected message category, provided that the messageCategoryListIndex is in proper range. Otherwise, answer an empty Array If messageCategoryListIndex is found to be larger than the number of categories (it happens!!), it is reset to zero." - | classOrMetaClassOrganizer answer | - classOrMetaClassOrganizer _ self classOrMetaClassOrganizer. - classOrMetaClassOrganizer isNil ifTrue: [ ^#() ]. - (selectedMessageCategory isNil or: [ selectedMessageCategory == ClassOrganizer allCategory ]) ifTrue: [ - ^ classOrMetaClassOrganizer allMethodSelectors]. - answer _ classOrMetaClassOrganizer listAtCategoryNamed: selectedMessageCategory. - answer isNil ifTrue: [ - selectedMessageCategory _ nil. - answer _ #() ]. - ^answer! ! - -Browser removeSelector: #messageCategoryListSelection! - -!methodRemoval: Browser #messageCategoryListSelection stamp: 'Install-4010-Browser-cleanup-JuanVuletich-2020Jan09-17h51m-jmv.1.cs.st 1/11/2020 17:58:51'! -messageCategoryListSelection - "Return the selected category name or nil." - - ^ ((self messageCategoryList size = 0 - or: [self messageCategoryListIndex = 0]) - or: [self messageCategoryList size < self messageCategoryListIndex]) - ifTrue: [nil] - ifFalse: [self messageCategoryList at: (self messageCategoryListIndex max: 1)]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4010-Browser-cleanup-JuanVuletich-2020Jan09-17h51m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4010] on 9 January 2020 at 7:32:25 pm'! -!Browser methodsFor: 'message list' stamp: 'jmv 1/9/2020 12:07:48' prior: 50390499! - messageListIndex: anInteger - "Set the selected message selector to be the one indexed by anInteger." - - | index messageList | - - messageList _ self messageList. - index _ messageList ifInBounds: anInteger ifNot: 0. - - selectedMessage _ index = 0 ifFalse: [ (messageList at: index) string ]. - self editSelection: (index > 0 - ifTrue: [#editMessage] - ifFalse: [self messageCategoryListIndex > 0 - ifTrue: [#newMessage] - ifFalse: [self classListIndex > 0 - ifTrue: [#editClass] - ifFalse: [#newClass]]]). - self changed: #messageListIndex. "update my selection" - self acceptedContentsChanged! ! -!InnerListMorph methodsFor: 'drawing' stamp: 'jmv 1/9/2020 12:00:12' prior: 50492394! - draw: item atRow: row on: canvas - "display the given item at row row" - | f c | - (item is: #Text) - ifTrue: [ - f _ font emphasized: (item emphasisAt: 1). - c _ item colorAt: 1] - ifFalse: [ - f _ font. - c _ Theme current text]. - canvas - drawString: item - at: 0 @ (self drawYForRow: row) - font: f - color: c! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4011-AllowTextAsListItems-JuanVuletich-2020Jan09-19h31m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4010] on 9 January 2020 at 7:49:25 pm'! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'jmv 1/9/2020 19:47:47' prior: 50477920! - withSelectorUnderCursorDo: aBlock ifErrorsParsing: aParsingErrorBlock ifNoSelector: aNoSelectorBlock - - | methodNode nodeAtRange nodeUnderCursor alternativeAnswer failed | - failed _ false. - methodNode := self codeProvider - methodNodeOf: model actualContents - ifErrorsParsing: [ :anError | - alternativeAnswer _ aParsingErrorBlock valueWithPossibleArgument: anError. - failed _ true ]. - failed ifTrue: [ ^alternativeAnswer ]. - - self startIndex < methodNode selectorLastPosition ifTrue: [ ^aBlock value: methodNode selector ]. - nodeAtRange := methodNode parseNodeIncluding: self startIndex ifAbsent: [ ^ aNoSelectorBlock value ]. - nodeUnderCursor := nodeAtRange key. - nodeUnderCursor isMessageNode ifTrue: [ ^aBlock value: nodeAtRange key selector key ]. - (nodeUnderCursor isLiteralNode and: [ nodeUnderCursor literalValue isSymbol ]) ifTrue: [ ^aBlock value: nodeUnderCursor literalValue ]. - - ^ aNoSelectorBlock value ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4012-SmalltalkEditor-fix-JuanVuletich-2020Jan09-19h32m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4005] on 9 January 2020 at 3:57:20 pm'! - -Browser subclass: #CodeFileBrowser - instanceVariableNames: 'codeFile caseCodeSource baseCodeSource ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Code File Browser'! - -!classDefinition: #CodeFileBrowser category: #'Tools-Code File Browser' stamp: 'Install-4013-CodeFileBrowser-flexible-case-and-base-PhilBellalouna-2020Jan09-15h14m-pb.1.cs.st 1/11/2020 17:58:51'! -Browser subclass: #CodeFileBrowser - instanceVariableNames: 'codeFile caseCodeSource baseCodeSource' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Code File Browser'! -!CodeFileBrowser methodsFor: 'accessing' stamp: 'pb 12/11/2019 01:12:35'! - baseCodeSource - ^ baseCodeSource ifNil: [ Smalltalk ].! ! -!CodeFileBrowser methodsFor: 'accessing' stamp: 'pb 12/11/2019 01:12:28'! - baseCodeSource: aCodeFile - baseCodeSource _ aCodeFile! ! -!CodeFileBrowser methodsFor: 'accessing' stamp: 'pb 12/11/2019 01:12:39'! - caseCodeSource - ^ caseCodeSource ifNil: [ Smalltalk ].! ! -!CodeFileBrowser methodsFor: 'accessing' stamp: 'pb 12/11/2019 01:12:44'! - caseCodeSource: aCodeFile - caseCodeSource _ aCodeFile! ! -!CodeFileBrowser methodsFor: 'private' stamp: 'pb 12/11/2019 23:51:51'! - pvtBaseClassOrMetaclass - | theClass | - theClass _ [self baseCodeSource classNamed: self selectedClass name asSymbol] on: Error do: ["Class not found in base?"]. - ^ (theClass notNil and: [ self metaClassIndicated ]) - ifTrue: [ theClass class ] - ifFalse: [ theClass ].! ! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'pb 12/5/2019 03:00:05'! - browseCodeFileEntry: aFileEntry - self browseCodeSource: (CodeFile newFromFile: aFileEntry )! ! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'pb 12/11/2019 01:23:20'! - browseCodeSource: aCaseCodeSource - self browseCodeSource: aCaseCodeSource base: nil! ! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'pb 12/12/2019 01:50:16'! - browseCodeSource: aCaseCodeSource base: aBaseCodeSource - | useCaseCodeSource useCaseClasses browser useCaseOrganizer useHeading | - browser _ self new. - browser - caseCodeSource: aCaseCodeSource; - baseCodeSource: aBaseCodeSource. - useCaseCodeSource _ browser caseCodeSource. - useCaseClasses _ useCaseCodeSource classes collect: [ :ea | - ea name ]. - useCaseOrganizer _ useCaseCodeSource organization. - useHeading _ (useCaseCodeSource isLiveSmalltalkImage not and: [ browser baseCodeSource isLiveSmalltalkImage ]) - ifTrue: [ useCaseCodeSource name ] - ifFalse: [ "This is a non-standard configuration... make the user aware" - useCaseCodeSource name , '(' , useCaseCodeSource class name , '), target: ' , aBaseCodeSource name , '(' , aBaseCodeSource class name , ')' ]. - (useCaseCodeSource notNil and: [ useCaseCodeSource isLiveSmalltalkImage not ]) ifTrue: [ - useCaseOrganizer - classifyAll: useCaseClasses - under: useHeading ]. - browser - systemOrganizer: useCaseOrganizer; - caseCodeSource: useCaseCodeSource. - aBaseCodeSource ifNotNil: [ browser baseCodeSource: aBaseCodeSource ]. - CodeFileBrowserWindow - open: browser - label: nil.! ! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'pb 12/5/2019 02:59:59'! - browsePackageFileEntry: aFileEntry - self browseCodeSource: (CodePackageFile newFromFile: aFileEntry )! ! -!ClassDescription methodsFor: 'testing' stamp: 'pb 12/11/2019 23:57:24'! - hasDefinition - ^ true! ! -!SystemDictionary methodsFor: 'accessing' stamp: 'pb 12/11/2019 02:56:50'! - description - "Needed by CodeFileBrowser to use Smalltalk as the 'case' source" - ^ self name! ! -!SystemDictionary methodsFor: 'accessing' stamp: 'pb 12/5/2019 02:17:02'! - name - ^ 'Image'! ! -!SystemDictionary methodsFor: 'accessing' stamp: 'pb 12/11/2019 02:56:15'! - summary - "Needed by CodeFileBrowser to use Smalltalk as the 'case' source" - ^ self name! ! -!SystemDictionary methodsFor: 'private' stamp: 'pb 1/9/2020 15:28:55'! - baseLabel - ^ 'system'! ! -!SystemDictionary methodsFor: 'testing' stamp: 'pb 12/5/2019 03:21:11'! - isLiveSmalltalkImage - ^ true! ! -!CodeFileBrowserWindow methodsFor: 'GUI building' stamp: 'pb 12/12/2019 01:22:31'! - optionalButtonTuples - "Answer a tuple buttons, in the format: - button label - selector to send - help message" - ^ (self model baseCodeSource isLiveSmalltalkImage and: [ self model caseCodeSource isLiveSmalltalkImage not ]) - ifTrue: [ super optionalButtonTuples ] - ifFalse: [ "For non-standard browser configurations assume most of the default buttons are invalid" - #( - #(10 'show...' #offerWhatToShowMenu 'menu of what to show in lower pane' ) - ) ].! ! -!CodeFile methodsFor: 'accessing' stamp: 'pb 12/11/2019 01:51:02'! - classDictionary - ^classes! ! -!CodeFile methodsFor: 'accessing' stamp: 'pb 12/11/2019 23:14:13'! -classNamed: className - ^ classes at: className! ! -!CodeFile methodsFor: 'accessing' stamp: 'pb 12/5/2019 00:22:02'! - organization - ^ SystemOrganizer defaultList: Array new.! ! -!CodeFile methodsFor: 'testing' stamp: 'pb 12/5/2019 03:16:55'! - isLiveSmalltalkImage - ^ false! ! -!CodeFile methodsFor: 'private' stamp: 'pb 1/9/2020 15:29:37'! -baseLabel - ^ 'base'! ! -!CodeFile class methodsFor: 'instance creation' stamp: 'pb 12/5/2019 00:24:43'! - newFromFile: aFileEntry - ^ aFileEntry readStreamDo: [ :stream | - self new - fullName: aFileEntry pathName; - buildFrom: stream ].! ! -!PseudoClass methodsFor: 'accessing' stamp: 'pb 12/11/2019 23:20:55'! - theMetaClass - ^ metaClass ifNil: [ metaClass _ PseudoMetaclass new name: self name ].! ! -!CodeFileBrowser methodsFor: 'accessing' stamp: 'pb 12/11/2019 01:13:28' prior: 50485596! - acceptedStringOrText - self updateInfoView. - (editSelection == #newClass and: [ caseCodeSource notNil ]) - ifTrue: [ ^caseCodeSource description ]. - editSelection == #editClass - ifTrue:[ ^self modifiedClassDefinition ]. - ^super acceptedStringOrText! ! -!CodeFileBrowser methodsFor: 'class list' stamp: 'pb 12/11/2019 02:39:26' prior: 16809207! - classList - "Answer an array of the class names of the selected category. Answer an - empty array if no selection exists." - - ^(selectedSystemCategory isNil or: [ caseCodeSource isNil ]) - ifTrue: [ #() ] - ifFalse: [ (caseCodeSource classes collect: [:ea| ea name]) sort ]! ! -!CodeFileBrowser methodsFor: 'class list' stamp: 'pb 12/11/2019 01:53:26' prior: 16809217! - renameClass - | oldName newName | - selectedClassName ifNil: [ ^self ]. - oldName _ self selectedClass name. - newName _ (self request: 'Please type new class name' - initialAnswer: oldName) asSymbol. - (newName isEmpty or:[newName = oldName]) ifTrue: [^ self]. - (caseCodeSource classDictionary includesKey: newName) - ifTrue: [^ self error: newName , ' already exists in the CodeFile']. - systemOrganizer classify: newName under: selectedSystemCategory. - systemOrganizer removeElement: oldName. - caseCodeSource renameClass: self selectedClass to: newName. - self changed: #classList. - self classListIndex: ((systemOrganizer listAtCategoryNamed: selectedSystemCategory) indexOf: newName). -! ! -!CodeFileBrowser methodsFor: 'class list' stamp: 'pb 12/11/2019 23:14:26' prior: 16809241! - selectedClass - "Answer the class that is currently selected. Answer nil if no selection - exists." - - ^self selectedClassName ifNotNil: [ :scn | - caseCodeSource classNamed: scn ]! ! -!CodeFileBrowser methodsFor: 'diffs' stamp: 'pb 1/9/2020 15:22:58' prior: 16809273! - methodDiffFor: aString class: aPseudoClass selector: selector meta: meta - "Answer the diff between the current copy of the given class/selector/meta for the string provided" - | theClass source | - theClass _ self pvtBaseClassOrMetaclass. - theClass ifNotNil: [ - meta ifTrue: [ theClass _ theClass class ]. - (theClass includesSelector: selector) ifTrue: [ source _ theClass sourceCodeAt: selector ]]. - ^ DifferenceFinder - displayPatchFrom: (source ifNil: ['']) - to: aString - tryWords: self shouldDiffWords - prettyPrintedIn: - (self showingAnyKindOfPrettyDiffs ifTrue: [ theClass ]).! ! -!CodeFileBrowser methodsFor: 'diffs' stamp: 'pb 12/11/2019 23:58:45' prior: 16809294! - modifiedClassDefinition - | pClass rClass old new | - pClass := self selectedClassOrMetaClass. - pClass ifNil: [^'']. - pClass hasDefinition ifFalse: [ ^pClass definition]. - rClass := [self baseCodeSource classNamed: self selectedClass name] on: Error do: ["Missing class"]. - rClass ifNil: [ ^pClass definition]. - self metaClassIndicated ifTrue:[ rClass := rClass class]. - old := rClass definition. - new := pClass definition. - ^ DifferenceFinder displayPatchFrom: old to: new tryWords: true! ! -!CodeFileBrowser methodsFor: 'fileIn/fileOut' stamp: 'pb 12/11/2019 01:18:26' prior: 16809311! - fileIn - caseCodeSource fileIn! ! -!CodeFileBrowser methodsFor: 'fileIn/fileOut' stamp: 'pb 12/11/2019 01:14:09' prior: 16809332! -fileOut - - caseCodeSource fileOut! ! -!CodeFileBrowser methodsFor: 'infoView' stamp: 'pb 1/9/2020 15:56:50' prior: 50485607! - infoViewContents - | theClass useLabel | - useLabel _ self baseCodeSource baseLabel. - editSelection == #newClass ifTrue: [ ^ caseCodeSource - ifNil: [ 'No file selected' ] - ifNotNil: [ caseCodeSource summary ]]. - self selectedClass ifNil: [ ^ '' ]. - theClass _ self pvtBaseClassOrMetaclass. - editSelection == #editClass ifTrue: [ ^ theClass - ifNil: [ 'Class not in the ' , useLabel ] - ifNotNil: [ 'Class exists already in the ' , useLabel ]]. - editSelection == #editMessage ifFalse: [ ^ '' ]. - (theClass notNil and: [ self metaClassIndicated ]) ifTrue: [ theClass _ theClass class ]. - ^ (theClass notNil and: [ theClass includesSelector: self selectedMessageName ]) - ifTrue: [ 'Method already exists' , self extraInfo ] - ifFalse: [ '**NEW** Method not in the ' , useLabel ].! ! -!CodeFileBrowser methodsFor: 'metaclass' stamp: 'pb 12/11/2019 23:18:54' prior: 16809397! - selectedClassOrMetaClass - "Answer the selected class or metaclass." - - | cls | - self metaClassIndicated - ifTrue: [^ (cls _ self selectedClass) ifNotNil: [cls theMetaClass]] - ifFalse: [^ self selectedClass]! ! -!CodeFileBrowser methodsFor: 'metaclass' stamp: 'pb 12/11/2019 23:16:03' prior: 16809406! - setClassOrganizer - "Install whatever organization is appropriate" - | theClass | - classOrganizer _ nil. - metaClassOrganizer _ nil. - selectedClassName ifNil: [ ^self ]. - theClass _ self selectedClass. - theClass ifNil: [classOrganizer := self baseCodeSource organization. - metaClassOrganizer := self baseCodeSource organization] ifNotNil: [ - classOrganizer _ theClass organization. - metaClassOrganizer _ theClass theMetaClass organization. - -]! ! -!CodeFileBrowser methodsFor: 'removing' stamp: 'pb 12/11/2019 01:16:45' prior: 16809125! - removeClass - | class | - selectedClassName ifNil: [ ^self ]. - class _ self selectedClass. - (self confirm:'Are you certain that you -want to delete the class ', class name, '?') ifFalse:[^self]. - caseCodeSource removeClass: class. - self classListIndex: 0. - self changed: #classList.! ! -!CodeFileBrowser methodsFor: 'removing' stamp: 'pb 12/11/2019 23:18:54' prior: 16809172! - removeUnmodifiedCategories - | theClass | - theClass _ self selectedClass. - theClass ifNil: [^self]. - theClass removeUnmodifiedMethods: theClass selectors. - theClass theMetaClass removeUnmodifiedMethods: theClass theMetaClass selectors. - self messageCategoryListIndex: 0. - self changed: #messageCategoryList! ! -!CodeFileBrowser methodsFor: 'removing' stamp: 'pb 12/11/2019 02:41:02' prior: 16809184! - removeUnmodifiedClasses - caseCodeSource isLiveSmalltalkImage - ifTrue: [ self error: 'Do not perform on a live image!!' ] - ifFalse: [ - caseCodeSource classDictionary copy do: [ :theClass | - theClass removeAllUnmodified. - theClass hasChanges ifFalse: [ caseCodeSource removeClass: theClass ]]. - self classListIndex: 0. - self changed: #classList ].! ! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'pb 12/5/2019 00:48:37' prior: 50427017! - serviceBrowseCode - "Answer the service of opening a file-contents browser" - - ^ (SimpleServiceEntry - provider: self - label: 'browse code' - selector: #browseCodeFileEntry: - description: 'open a "file-contents browser" on this file, allowing you to view and selectively load its code' - buttonLabel: 'code' - icon: #editFindReplaceIcon) - sortOrder: 10; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'pb 12/5/2019 00:49:55' prior: 50427034! - serviceBrowsePackage - "Answer the service of opening a file-contents browser" - - ^ (SimpleServiceEntry - provider: self - label: 'browse package' - selector: #browsePackageFileEntry: - description: 'open a "package file browser" on this file, allowing you to view and selectively load its code' - buttonLabel: 'package browser' - icon: #editFindReplaceIcon) - sortOrder: 10; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!CodeFileBrowserWindow methodsFor: 'menu building' stamp: 'pb 12/11/2019 01:09:41' prior: 50398619! - classListMenu - | aMenu itemColl | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Class List'. - itemColl _ OrderedCollection new. - itemColl addAll: - { - {#label -> 'definition'. #object -> #model. #selector -> #editClass. #icon -> #editFindReplaceIcon} asDictionary. - {#label -> 'comment'. #object -> #model. #selector -> #editComment. #icon -> #editFindReplaceIcon} asDictionary. - nil - }. - self model baseCodeSource isLiveSmalltalkImage ifTrue: [ - itemColl addAll: - { - {#label -> 'browse full (b)'. #selector -> #browseMethodFull. #icon -> #editFindReplaceIcon} asDictionary. - {#label -> 'class refs (N)'. #selector -> #browseClassRefs. #icon -> #classIcon} asDictionary. - nil. - {#label -> 'fileIn'. #object -> #model. #selector -> #fileInClass. #icon -> #updateIcon} asDictionary - } ]. - itemColl addAll: - { - {#label -> 'fileOut'. #object -> #model. #selector -> #fileOutClass. #icon -> #fileOutIcon} asDictionary. - nil. - {#label -> 'rename...'. #object -> #model. #selector -> #renameClass. #icon -> #saveAsIcon} asDictionary. - {#label -> 'remove'. #object -> #model. #selector -> #removeClass. #icon -> #listRemoveIcon} asDictionary. - nil. - {#label -> 'remove existing'. #object -> #model. #selector -> #removeUnmodifiedCategories. #icon -> #deleteIcon} asDictionary - }. - aMenu addItemsFromDictionaries: itemColl. - ^ aMenu.! ! -!CodeFileBrowserWindow methodsFor: 'menu building' stamp: 'pb 12/11/2019 01:10:17' prior: 50398975! - codeFileListMenu - | aMenu itemColl | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Code File'. - itemColl _ OrderedCollection new. - itemColl addAll: - { - {#label -> 'find class... (f)'. #selector -> #findClass} asDictionary. - nil - }. - self model baseCodeSource isLiveSmalltalkImage ifTrue: [ - itemColl add: - {#label -> 'fileIn'. #object -> #model. #selector -> #fileIn} asDictionary ]. - itemColl add: - {#label -> 'fileOut'. #object -> #model. #selector -> #fileOut} asDictionary. - self model caseCodeSource isLiveSmalltalkImage ifFalse: [ - itemColl add: - {#label -> 'remove existing'. #object -> #model. #selector -> #removeUnmodifiedClasses} asDictionary ]. - aMenu addItemsFromDictionaries: itemColl. - ^ aMenu.! ! -!CodeFileBrowserWindow methodsFor: 'menu building' stamp: 'pb 12/11/2019 01:10:17' prior: 50398671! - messageCategoryMenu - | aMenu itemColl | - aMenu _ MenuMorph new defaultTarget: model. - "All the options are for the model." - aMenu addTitle: 'Message Category'. - itemColl _ OrderedCollection new. - self model baseCodeSource isLiveSmalltalkImage ifTrue: [ - itemColl add: - {#label -> 'fileIn'. #selector -> #fileInMessageCategories. #icon -> #updateIcon} asDictionary ]. - itemColl addAll: - { - {#label -> 'fileOut'. #selector -> #fileOutMessageCategories. #icon -> #fileOutIcon} asDictionary. - nil. - {#label -> 'reorganize'. #selector -> #editMessageCategories. #icon -> #sendReceiveIcon} asDictionary. - nil. - {#label -> 'add item...'. #selector -> #addCategory. #icon -> #newIcon} asDictionary. - nil. - {#label -> 'rename...'. #selector -> #renameCategory. #icon -> #saveAsIcon} asDictionary. - {#label -> 'remove'. #selector -> #removeMessageCategory. #icon -> #listRemoveIcon} asDictionary - }. - self model caseCodeSource isLiveSmalltalkImage ifFalse: [ - itemColl addAll: - { - nil. - {#label -> 'remove existing'. #selector -> #removeUnmodifiedMethods. #icon -> #deleteIcon} asDictionary - } ]. - aMenu addItemsFromDictionaries: itemColl. - ^ aMenu.! ! -!CodeFileBrowserWindow methodsFor: 'menu building' stamp: 'pb 12/11/2019 01:09:41' prior: 50398711! - messageListMenu - | aMenu itemColl | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Message List'. - itemColl _ OrderedCollection new. - self model baseCodeSource isLiveSmalltalkImage ifTrue: [ - itemColl add: - {#label -> 'fileIn'. #object -> #model. #selector -> #fileInMessage. #icon -> #updateIcon} asDictionary ]. - itemColl addAll: - { - {#label -> 'fileOut'. #object -> #model. #selector -> #fileOutMessage. #icon -> #fileOutIcon} asDictionary. - nil - }. - self model baseCodeSource isLiveSmalltalkImage ifTrue: [ - itemColl addAll: - { - {#label -> 'senders (n)'. #selector -> #browseSenders. #icon -> #mailForwardIcon} asDictionary. - {#label -> 'implementors (m)'. #selector -> #browseImplementors. #icon -> #developmentIcon} asDictionary. - {#label -> 'method inheritance (h)'. #selector -> #methodHierarchy. #icon -> #goDownIcon} asDictionary. - {#label -> 'versions (v)'. #selector -> #browseVersions. #icon -> #clockIcon} asDictionary - } ]. - itemColl addAll: - { - nil. - {#label -> 'remove method (x)'. #object -> #model. #selector -> #removeMessage. #icon -> #deleteIcon} asDictionary - }. - aMenu addItemsFromDictionaries: itemColl. - ^ aMenu.! ! -!CodeFileBrowserWindow methodsFor: 'commands' stamp: 'pb 12/11/2019 01:53:06' prior: 16809729! - findClass - | pattern foundClass classNames index foundCodeFile | - self okToChange ifFalse: [^ self flash]. - pattern _ (FillInTheBlankMorph request: 'Class Name?') asLowercase. - pattern isEmpty ifTrue: [^ self]. - classNames := Set new. - classNames addAll: model caseCodeSource classDictionary keys. - classNames := classNames asArray select: - [:n | (n asLowercase indexOfSubCollection: pattern startingAt: 1) > 0]. - classNames isEmpty ifTrue: [^ self]. - index _ classNames size = 1 - ifTrue: [1] - ifFalse: [(PopUpMenu labelArray: classNames lines: #()) startUpMenu]. - index = 0 ifTrue: [^ self]. - foundCodeFile := nil. - foundClass := nil. - (model caseCodeSource classDictionary includesKey: (classNames at: index)) ifTrue:[ - foundClass := model caseCodeSource classDictionary at: (classNames at: index). - foundCodeFile := model caseCodeSource ]. - foundClass ifNotNil: [ - model systemCategoryListIndex: (model systemCategoryList indexOf: foundCodeFile name asSymbol). - model classListIndex: (model classList indexOf: foundClass name) ]! ! -!CodeFile methodsFor: 'accessing' stamp: 'pb 12/11/2019 02:38:00' prior: 16808703! - classes - ^ self classDictionary values! ! -!CodeFile methodsFor: 'fileIn/fileOut' stamp: 'pb 12/11/2019 23:18:54' prior: 16808936! - fileIn - | doitsMark | - doitsMark := 1. - doIts isEmpty ifFalse:[doitsMark := self askForDoits]. - doitsMark = 4 ifTrue: [^nil]. - doitsMark = 2 ifTrue:[self fileInDoits]. - classOrder do:[:cls| - cls fileInDefinition. - ]. - classes do:[:cls| - Transcript newLine; show:'Filing in ', cls name. - cls fileInMethods. - cls hasMetaclass ifTrue:[cls theMetaClass fileInMethods]. - ]. - doitsMark = 3 ifTrue: [ self fileInDoits ]! ! -!CodeFile methodsFor: 'fileIn/fileOut' stamp: 'pb 12/11/2019 23:18:54' prior: 16808976! - fileOutOn: aStream - | doitsMark | - doitsMark := 1. - doIts isEmpty ifFalse:[doitsMark := self askForDoits]. - doitsMark = 4 ifTrue: [^nil]. - doitsMark = 2 ifTrue:[self fileOutDoits: aStream]. - classOrder do:[:cls| - cls fileOutDefinitionOn: aStream. - ]. - classes do:[:cls| - cls fileOutMethodsOn: aStream. - cls hasMetaclass ifTrue:[cls theMetaClass fileOutMethodsOn: aStream]. - ]. - doitsMark = 3 ifTrue:[self fileOutDoits: aStream].! ! -!CodeFile methodsFor: 'xtras' stamp: 'pb 12/11/2019 23:18:54' prior: 16809011! - allMethodReferences - "Create an answer a Set with method references for all methods in us" - | answer className metaClass | - answer _ Set new. - - classes do: [ :pseudoClass | - className _ pseudoClass name. - pseudoClass selectors do: [ :selector | - answer add: - (MethodReference new - setClassSymbol: className - classIsMeta: false - methodSymbol: selector - stringVersion: className, ' ' , selector) ]. - pseudoClass hasMetaclass ifTrue: [ - metaClass _ pseudoClass theMetaClass. - metaClass selectors do: [ :selector | - answer add: - (MethodReference new - setClassSymbol: className - classIsMeta: true - methodSymbol: selector - stringVersion: className, ' class ' , selector) ]. - ]]. - ^answer! ! -!CodeFile methodsFor: 'private' stamp: 'pb 12/11/2019 23:18:54' prior: 16808789! - metaClassDefinition: string with: chgRec - | tokens theClass | - tokens := Scanner new scanTokens: string. - theClass := self getClass: (tokens at: 1). - theClass theMetaClass definition: string. - classOrder add: theClass theMetaClass.! ! -!CodeFile methodsFor: 'private' stamp: 'pb 12/11/2019 23:18:54' prior: 16808799! - msgClassComment: string with: chgRec - | tokens theClass | - tokens := Scanner new scanTokens: string. - (tokens size = 3 and:[(tokens at: 3) class == String]) ifTrue:[ - theClass := self getClass: tokens first. - ^theClass classComment: tokens last]. - (tokens size = 4 and:[(tokens at: 3) asString = 'class' and:[(tokens at: 4) class == String]]) ifTrue:[ - theClass := self getClass: tokens first. - theClass theMetaClass classComment: tokens last]. -! ! -!CodeFile methodsFor: 'private' stamp: 'pb 12/11/2019 23:18:54' prior: 16808826! - removedMethod: string with: chgRec - | class tokens firstToken secondToken thirdToken | - tokens _ Scanner new scanTokens: string. - tokens size >= 3 ifTrue: [ - firstToken _ tokens at: 1. - secondToken _ tokens at: 2. - thirdToken _ tokens at: 3. - (tokens size = 3 and: [ secondToken == #removeSelector: or: [ secondToken == #removeSelectorIfInBaseSystem: ]]) ifTrue:[ - class _ self getClass: firstToken. - ^class perform: secondToken with: thirdToken. - ]. - (tokens size = 4 and: [ secondToken == #class and: [ thirdToken == #removeSelector: or: [ thirdToken == #removeSelectorIfInBaseSystem: ]]]) ifTrue:[ - class _ self getClass: firstToken. - ^class theMetaClass perform: thirdToken with: (tokens at: 4). - ]. - ]. - doIts add: chgRec! ! -!PseudoClass methodsFor: 'testing' stamp: 'pb 12/11/2019 23:18:54' prior: 16896947! - needsInitialize - ^self hasMetaclass and:[ - self theMetaClass realClass includesSelector: #initialize]! ! -!PseudoClass methodsFor: 'methods' stamp: 'pb 12/11/2019 23:18:54' prior: 16897122! - methodChange: aChangeRecord - aChangeRecord isMetaClassChange ifTrue:[ - ^self theMetaClass addMethodChange: aChangeRecord. - ] ifFalse:[ - ^self addMethodChange: aChangeRecord. - ]. -! ! -!PseudoClass methodsFor: 'testing method dictionary' stamp: 'pb 12/5/2019 03:20:39' prior: 16897194! - includesSelector: aSymbol - ^ source keys includes: aSymbol.! ! - -PseudoClass removeSelector: #metaClass! - -!methodRemoval: PseudoClass #metaClass stamp: 'Install-4013-CodeFileBrowser-flexible-case-and-base-PhilBellalouna-2020Jan09-15h14m-pb.1.cs.st 1/11/2020 17:58:51'! -metaClass - ^metaClass ifNil:[metaClass := PseudoMetaclass new name: (self name)].! - -CodeFile removeSelector: #classAt:! - -!methodRemoval: CodeFile #classAt: stamp: 'Install-4013-CodeFileBrowser-flexible-case-and-base-PhilBellalouna-2020Jan09-15h14m-pb.1.cs.st 1/11/2020 17:58:51'! -classAt: className - ^ classes at: className! - -CodeFileBrowserWindow class removeSelector: #browseFile:! - -!methodRemoval: CodeFileBrowserWindow class #browseFile: stamp: 'Install-4013-CodeFileBrowser-flexible-case-and-base-PhilBellalouna-2020Jan09-15h14m-pb.1.cs.st 1/11/2020 17:58:51'! -browseFile: aFileEntry - - | codeFile organizer browser | - organizer _ SystemOrganizer defaultList: Array new. - aFileEntry readStreamDo: [ :stream | - codeFile _ (CodeFile new fullName: aFileEntry pathName; buildFrom: stream) ]. - organizer - classifyAll: codeFile classes keys - under: codeFile name. - (browser _ CodeFileBrowser new) - systemOrganizer: organizer; - codeFile: codeFile. - self open: browser label: nil! - -CodeFileBrowserWindow class removeSelector: #browsePackageFile:! - -!methodRemoval: CodeFileBrowserWindow class #browsePackageFile: stamp: 'Install-4013-CodeFileBrowser-flexible-case-and-base-PhilBellalouna-2020Jan09-15h14m-pb.1.cs.st 1/11/2020 17:58:51'! -browsePackageFile: aFileEntry - - | codeFile organizer browser | - organizer _ SystemOrganizer defaultList: Array new. - aFileEntry readStreamDo: [ :stream | - codeFile _ (CodePackageFile new fullName: aFileEntry pathName; buildFrom: stream) ]. - organizer - classifyAll: codeFile classes keys - under: codeFile name. - (browser _ CodeFileBrowser new) - systemOrganizer: organizer; - codeFile: codeFile. - self open: browser label: nil! - -CodeFileBrowserWindow removeSelector: #buildWindowMenu! - -CodeFileBrowser class removeSelector: #browseCode:! - -!methodRemoval: CodeFileBrowser class #browseCode: stamp: 'Install-4013-CodeFileBrowser-flexible-case-and-base-PhilBellalouna-2020Jan09-15h14m-pb.1.cs.st 1/11/2020 17:58:51'! -browseCode: aFileEntry - - CodeFileBrowserWindow browseFile: aFileEntry! - -CodeFileBrowser class removeSelector: #browsePackage:! - -!methodRemoval: CodeFileBrowser class #browsePackage: stamp: 'Install-4013-CodeFileBrowser-flexible-case-and-base-PhilBellalouna-2020Jan09-15h14m-pb.1.cs.st 1/11/2020 17:58:51'! -browsePackage: aFileEntry - - CodeFileBrowserWindow browsePackageFile: aFileEntry! - -CodeFileBrowser removeSelector: #shouldShowFalseColorDiffs! - -CodeFileBrowser removeSelector: #toggleShowFalseColorDiffsLabel! - -CodeFileBrowser removeSelector: #codeFile:! - -!methodRemoval: CodeFileBrowser #codeFile: stamp: 'Install-4013-CodeFileBrowser-flexible-case-and-base-PhilBellalouna-2020Jan09-15h14m-pb.1.cs.st 1/11/2020 17:58:51'! -codeFile: aCodeFile - codeFile _ aCodeFile! - -CodeFileBrowser removeSelector: #toggleShowFalseColorDiffs! - -CodeFileBrowser removeSelector: #initialize! - -CodeFileBrowser removeSelector: #selectedCodeFile! - -!methodRemoval: CodeFileBrowser #selectedCodeFile stamp: 'Install-4013-CodeFileBrowser-flexible-case-and-base-PhilBellalouna-2020Jan09-15h14m-pb.1.cs.st 1/11/2020 17:58:51'! -selectedCodeFile - ^codeFile! - -Browser subclass: #CodeFileBrowser - instanceVariableNames: 'baseCodeSource caseCodeSource' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Code File Browser'! - -!classDefinition: #CodeFileBrowser category: #'Tools-Code File Browser' stamp: 'Install-4013-CodeFileBrowser-flexible-case-and-base-PhilBellalouna-2020Jan09-15h14m-pb.1.cs.st 1/11/2020 17:58:51'! -Browser subclass: #CodeFileBrowser - instanceVariableNames: 'baseCodeSource caseCodeSource' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Code File Browser'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4013-CodeFileBrowser-flexible-case-and-base-PhilBellalouna-2020Jan09-15h14m-pb.1.cs.st----! - -'From Cuis 5.0 [latest update: #4012] on 10 January 2020 at 12:21:32 am'! -!CodeFileBrowser methodsFor: 'message list' stamp: 'pb 1/10/2020 00:20:12'! - messageList - "Colorize messages as needed" - ^ super messageList collect: [ :eaListItem | | foundCat useAttr | - foundCat _ classOrganizer categoryOfElement: eaListItem. - " - Transcript - show: foundCat class name; - finishEntry. - " - useAttr _ foundCat = PseudoClass removedCategoryName - ifTrue: [ TextColor red ] - ifFalse: [ | baseSrc | - baseSrc _ self pvtBaseSelectedMessageSourceCodeFor: eaListItem. - baseSrc - ifNil: [ TextColor green ] - ifNotNil: [ | caseSrc | - caseSrc _ self pvtCaseSelectedMessageSourceCodeFor: eaListItem. - baseSrc = caseSrc ifFalse: [ TextColor blue ]]]. - useAttr - ifNil: [ eaListItem ] - ifNotNil: [ :attr | - Text - string: eaListItem - attribute: attr ]].! ! -!CodeFileBrowser methodsFor: 'private' stamp: 'pb 1/9/2020 23:39:45'! - pvtBaseSelectedMessageSourceCodeFor: selector - ^ self pvtBaseClassOrMetaclass ifNotNil: [ :theClass | | useClass | - self metaClassIndicated - ifTrue: [ useClass _ theClass class ] - ifFalse: [ useClass _ theClass ]. - (useClass includesSelector: selector) ifTrue: [ useClass sourceCodeAt: selector ]].! ! -!CodeFileBrowser methodsFor: 'private' stamp: 'pb 1/9/2020 23:40:02'! - pvtCaseSelectedMessageSourceCodeFor: selector - | class | - class _ self selectedClassOrMetaClass. - ^ class sourceCodeAt: selector.! ! -!PseudoClass class methodsFor: 'categories' stamp: 'pb 1/9/2020 22:19:49'! - removedCategoryName - ^ `Text string: '*** removed methods ***' attribute: TextColor red`! ! -!Categorizer methodsFor: 'accessing' stamp: 'pb 1/9/2020 21:21:38' prior: 16795291! - addCategory: catString before: nextCategory - "Add a new category named heading. - If default category exists and is empty, remove it. - If nextCategory is nil, then add the new one at the end, - otherwise, insert it before nextCategory." - | index newCategory | - newCategory _ catString . - (categoryArray indexOf: newCategory) > 0 - ifTrue: [^self]. "heading already exists, so done" - index _ categoryArray indexOf: nextCategory - ifAbsent: [categoryArray size + 1]. - categoryArray _ categoryArray - copyReplaceFrom: index - to: index-1 - with: (Array with: newCategory). - categoryStops _ categoryStops - copyReplaceFrom: index - to: index-1 - with: (Array with: (index = 1 - ifTrue: [0] - ifFalse: [categoryStops at: index-1])). - "remove empty default category" - (newCategory ~= Default - and: [(self listAtCategoryNamed: Default) isEmpty]) - ifTrue: [self removeCategory: Default]! ! -!Categorizer methodsFor: 'accessing' stamp: 'pb 1/9/2020 21:21:47' prior: 16795449! - classify: element under: heading suppressIfDefault: aBoolean - "Store the argument, element, in the category named heading. If aBoolean is true, then invoke special logic such that the classification is NOT done if the new heading is the Default and the element already had a non-Default classification -- useful for filein" - - | catName catIndex elemIndex realHeading | - ((heading = NullCategory) or: [heading == nil]) - ifTrue: [realHeading _ Default] - ifFalse: [realHeading _ heading ]. - (catName _ self categoryOfElement: element) = realHeading - ifTrue: [^ self]. "done if already under that category" - - catName ifNotNil: [ - (aBoolean and: [realHeading = Default]) - ifTrue: [^ self]. "return if non-Default category already assigned in memory" - self removeElement: element]. "remove if in another category" - - (categoryArray indexOf: realHeading) = 0 ifTrue: [self addCategory: realHeading]. - - catIndex _ categoryArray indexOf: realHeading. - elemIndex _ - catIndex > 1 - ifTrue: [categoryStops at: catIndex - 1] - ifFalse: [0]. - [(elemIndex _ elemIndex + 1) <= (categoryStops at: catIndex) - and: [element >= (elementArray at: elemIndex)]] whileTrue. - - "elemIndex is now the index for inserting the element. Do the insertion before it." - elementArray _ elementArray copyReplaceFrom: elemIndex to: elemIndex-1 - with: (Array with: element). - - "add one to stops for this and later categories" - catIndex to: categoryArray size do: - [:i | categoryStops at: i put: (categoryStops at: i) + 1]. - - (self listAtCategoryNamed: Default) size = 0 ifTrue: [self removeCategory: Default]! ! -!CodeFileBrowserWindow methodsFor: 'GUI building' stamp: 'pb 1/9/2020 22:41:38' prior: 50453764! - buildMorphicWindow - "Create a pluggable version of all the views for a Browser, using Morphic widgets." - - | sysCatList msgCatList upperPanes clsLayout msgLayout clsList msgList | - model systemCategoryListIndex: 1. - sysCatList _ PluggableListMorph - model: model - listGetter: #systemCategorySingleton - indexGetter: #indexIsOne - indexSetter: #indexIsOne: - mainView: self - menuGetter: #codeFileListMenu - keystrokeAction: #codeFileListKey:from:. - sysCatList hideScrollBarsIndefinitely. - - msgCatList _ PluggableListMorph - model: model - listGetter: #messageCategoryList - indexGetter: #messageCategoryListIndex - indexSetter: #messageCategoryListIndex: - mainView: self - menuGetter: #messageCategoryMenu - keystrokeAction: nil. - clsLayout := self buildMorphicClassColumn. - msgLayout := self buildMorphicMessageList. - clsList := clsLayout findDeepSubmorphThat: [:tstMorph| tstMorph class = PluggableListMorph] ifAbsent: [nil]. - msgList := msgLayout findDeepSubmorphThat: [:tstMorph| tstMorph class = PluggableListMorph] ifAbsent: [nil]. - sysCatList rightSibling: clsList. - clsList leftSibling: sysCatList rightSibling: msgCatList. - msgCatList leftSibling: clsList rightSibling: msgList. - msgList leftSibling: msgCatList . - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: clsLayout proportionalWidth: 0.3; - addAdjusterAndMorph: msgCatList proportionalWidth: 0.3; - addAdjusterAndMorph: msgLayout proportionalWidth: 0.4. - - self layoutMorph - addMorph: sysCatList fixedHeight: Preferences standardCodeFont lineSpacing + 10; - addAdjusterAndMorph: upperPanes proportionalHeight: 0.3; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.7. - model changed: #editSelection! ! -!PseudoClass methodsFor: 'fileIn/fileOut' stamp: 'pb 1/9/2020 22:20:09' prior: 16896988! - fileInMethods: aCollection - "FileIn all methods with selectors taken from aCollection" - | theClass | - self exists ifFalse:[^self classNotDefined]. - theClass := self realClass. - aCollection do:[:sel| - | cat | - cat := self organization categoryOfElement: sel. - cat = self class removedCategoryName ifFalse:[ - theClass - compile: (self sourceCodeAt: sel) - classified: cat - withStamp: (self stampAt: sel) - notifying: nil. - ]. - ].! ! -!PseudoClass methodsFor: 'fileIn/fileOut' stamp: 'pb 1/9/2020 22:20:04' prior: 16897044! - fileOutMethods: aCollection on: aStream - "FileOut all methods with selectors taken from aCollection" - | categories | - categories := Dictionary new. - aCollection do:[:sel| - | cat | - cat := self organization categoryOfElement: sel. - cat = self class removedCategoryName ifFalse:[ - (categories includesKey: cat) - ifFalse:[ categories at: cat put: Set new ]. - (categories at: cat) add: sel]. - ]. - categories associationsDo:[:assoc| - assoc value do: [ :sel | - aStream newLine. - (self sourceCode at: sel) fileOutOn: aStream. - ]. - ].! ! -!PseudoClass methodsFor: 'methods' stamp: 'pb 1/9/2020 22:19:59' prior: 16897134! - removeSelector: aSelector - | catName | - catName := self class removedCategoryName. - self organization addCategory: catName before: self organization categories first. - self organization classify: aSelector under: catName. - self sourceCodeAt: aSelector put:'methodWasRemoved' asText.! ! -!SequenceDifference methodsFor: 'printing' stamp: 'pb 1/9/2020 23:51:15' prior: 16905320! - attributesFor: condition - condition == #unchanged - ifTrue: [ - ^ {TextEmphasis normal} ]. - condition == #removed - ifTrue: [ - ^ {TextEmphasis struckThrough. TextColor red} ]. - condition == #inserted - ifTrue: [ - ^ {TextColor green} ]! ! - -PseudoClass removeSelector: #removedCategoryName! - -!methodRemoval: PseudoClass #removedCategoryName stamp: 'Install-4014-CodeFileBrowser-color-lists-PhilBellalouna-2020Jan09-21h17m-pb.1.cs.st 1/11/2020 17:58:51'! -removedCategoryName - ^'*** removed methods ***' asSymbol! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4014-CodeFileBrowser-color-lists-PhilBellalouna-2020Jan09-21h17m-pb.1.cs.st----! - -'From Cuis 5.0 [latest update: #4014] on 10 January 2020 at 2:43:44 pm'! -!BrowserWindow methodsFor: 'GUI building' stamp: 'jmv 1/10/2020 14:38:33' prior: 50453714! - buildNoSysCatMorphicWindow - "A Browser without the class categories list" - - | mySingletonList upperPanes messageCatList messageList classColumn classList | - mySingletonList _ PluggableListMorph - model: model - listGetter: #systemCategorySingleton - indexGetter: #indexIsOne - indexSetter: #indexIsOne: - mainView: self - menuGetter: #systemCatSingletonMenu - keystrokeAction: #systemCatSingletonKey:from:. - mySingletonList hideScrollBarsIndefinitely. - - classList _ self buildMorphicClassList. - classColumn _ self buildMorphicClassColumnWith: classList. - messageCatList _ self buildMorphicMessageCatList. - messageList _ self buildMorphicMessageList. - - classList rightSibling: messageCatList. - messageCatList leftSibling: classList rightSibling: messageList. - messageList leftSibling: messageCatList. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: classColumn proportionalWidth: 0.3; - addAdjusterAndMorph: messageCatList proportionalWidth: 0.3; - addAdjusterAndMorph: messageList proportionalWidth: 0.4. - - messageList makeItemsDraggable. - messageCatList - acceptDropsFrom: messageList - performing: #categorizeUnderCategoryAt:selector: - whenOutsideList: #categorizeUnderNewCategorySelector:. - - self layoutMorph - addMorph: mySingletonList fixedHeight: Preferences standardCodeFont lineSpacing + 10; - addAdjusterAndMorph: upperPanes proportionalHeight: 0.3; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.7. - - model changed: #editSelection! ! -!CodeFileBrowserWindow methodsFor: 'GUI building' stamp: 'jmv 1/10/2020 14:42:40' prior: 50493698! - buildMorphicWindow - "Create a pluggable version of all the views for a Browser, using Morphic widgets." - - | sysCatList msgCatList upperPanes clsLayout clsList msgList | - model systemCategoryListIndex: 1. - sysCatList _ PluggableListMorph - model: model - listGetter: #systemCategorySingleton - indexGetter: #indexIsOne - indexSetter: #indexIsOne: - mainView: self - menuGetter: #codeFileListMenu - keystrokeAction: #codeFileListKey:from:. - sysCatList hideScrollBarsIndefinitely. - - msgCatList _ PluggableListMorph - model: model - listGetter: #messageCategoryList - indexGetter: #messageCategoryListIndex - indexSetter: #messageCategoryListIndex: - mainView: self - menuGetter: #messageCategoryMenu - keystrokeAction: nil. - - clsList := self buildMorphicClassList. - clsLayout := self buildMorphicClassColumnWith: clsList. - msgList := self buildMorphicMessageList. - sysCatList rightSibling: clsList. - clsList leftSibling: sysCatList rightSibling: msgCatList. - msgCatList leftSibling: clsList rightSibling: msgList. - msgList leftSibling: msgCatList. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: clsLayout proportionalWidth: 0.3; - addAdjusterAndMorph: msgCatList proportionalWidth: 0.3; - addAdjusterAndMorph: msgList proportionalWidth: 0.4. - - self layoutMorph - addMorph: sysCatList fixedHeight: Preferences standardCodeFont lineSpacing + 10; - addAdjusterAndMorph: upperPanes proportionalHeight: 0.3; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.7. - model changed: #editSelection! ! - -BrowserWindow removeSelector: #buildMorphicClassColumn! - -!methodRemoval: BrowserWindow #buildMorphicClassColumn stamp: 'Install-4015-Cleanup-JuanVuletich-2020Jan10-14h35m-jmv.1.cs.st 1/11/2020 17:58:51'! -buildMorphicClassColumn - - ^self buildMorphicClassColumnWith: self buildMorphicClassList! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4015-Cleanup-JuanVuletich-2020Jan10-14h35m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4014] on 10 January 2020 at 3:47:01 pm'! -!CodeFileBrowser methodsFor: 'diffs' stamp: 'jmv 1/10/2020 15:39:10'! - methodDiffFor: aString selector: selector - "Answer the diff between the current copy of the given class/selector/meta for the string provided" - | theClass source | - source _ ''. - theClass _ self pvtBaseClassOrMetaclass. - theClass ifNotNil: [ - (theClass includesSelector: selector) ifTrue: [ - source _ theClass sourceCodeAt: selector ]]. - ^ DifferenceFinder - displayPatchFrom: source - to: aString - tryWords: self shouldDiffWords - prettyPrintedIn: - (self showingAnyKindOfPrettyDiffs ifTrue: [ theClass ]).! ! -!PseudoClassOrganizer methodsFor: 'testing' stamp: 'jmv 1/10/2020 15:29:44'! - isRemoved: aSelector - ^(self categoryOfElement: aSelector) = PseudoClass removedCategoryName! ! -!CodeFileBrowser methodsFor: 'edit pane' stamp: 'jmv 1/10/2020 15:41:21' prior: 16809253! - selectedMessage - "Answer a copy of the source code for the selected message selector." - - | class selector answer | - class _ self selectedClassOrMetaClass. - selector _ self selectedMessageName. - answer _ class sourceCodeAt: selector. - (self classOrMetaClassOrganizer isRemoved: selector) ifTrue: [ - ^ Text - string: answer - attribute: TextColor red ]. - Preferences browseWithPrettyPrint ifTrue: [ - answer _ class compilerClass new - format: answer in: class notifying: nil ]. - self showingAnyKindOfDiffs ifTrue: [ - answer _ self - methodDiffFor: answer - selector: self selectedMessageName ]. - ^ answer! ! -!CodeFileBrowser methodsFor: 'infoView' stamp: 'jmv 1/10/2020 15:38:07' prior: 50451702! - extraInfo - ^ (self - methodDiffFor: (self selectedClassOrMetaClass sourceCodeAt: self selectedMessageName) - selector: self selectedMessageName) - hasAnyAttribute - ifTrue: [' - **MODIFIED**'] - ifFalse: [' - identical']! ! -!CodeFileBrowser methodsFor: 'infoView' stamp: 'jmv 1/10/2020 15:33:10' prior: 50492976! - infoViewContents - | theClass selector useLabel | - useLabel _ self baseCodeSource baseLabel. - editSelection == #newClass ifTrue: [ - ^ caseCodeSource - ifNil: [ 'No file selected' ] - ifNotNil: [ caseCodeSource summary ]]. - self selectedClass ifNil: [ ^ '' ]. - theClass _ self pvtBaseClassOrMetaclass. - editSelection == #editClass ifTrue: [ - ^ theClass - ifNil: [ 'Class not in the ' , useLabel ] - ifNotNil: [ 'Class exists already in the ' , useLabel ]]. - editSelection == #editMessage ifFalse: [ ^ '' ]. - selector _ self selectedMessageName. - ^ (theClass notNil and: [ theClass includesSelector: selector ]) - ifTrue: [ 'Method already exists' , self extraInfo ] - ifFalse: [ - (self classOrMetaClassOrganizer isRemoved: selector) - ifTrue: [ 'Method not in the ' , useLabel ] - ifFalse: [ '**NEW** Method not in the ' , useLabel ]]! ! -!CodeFileBrowser methodsFor: 'message list' stamp: 'jmv 1/10/2020 15:30:55' prior: 50493562! - messageList - "Colorize messages as needed" - ^ super messageList collect: [ :eaListItem | | useAttr | - useAttr _ (self classOrMetaClassOrganizer isRemoved: eaListItem) - ifTrue: [ TextColor red ] - ifFalse: [ | baseSrc | - baseSrc _ self pvtBaseSelectedMessageSourceCodeFor: eaListItem. - baseSrc - ifNil: [ TextColor green ] - ifNotNil: [ | caseSrc | - caseSrc _ self pvtCaseSelectedMessageSourceCodeFor: eaListItem. - baseSrc = caseSrc ifFalse: [ TextColor blue ]]]. - useAttr - ifNil: [ eaListItem ] - ifNotNil: [ :attr | - Text - string: eaListItem - attribute: attr ]].! ! -!CodeFileBrowser methodsFor: 'private' stamp: 'jmv 1/10/2020 15:14:57' prior: 50493588! - pvtBaseSelectedMessageSourceCodeFor: selector - ^ self pvtBaseClassOrMetaclass ifNotNil: [ :theClass | - (theClass includesSelector: selector) ifTrue: [ theClass sourceCodeAt: selector ]].! ! - -CodeFileBrowser removeSelector: #methodDiffFor:class:selector:meta:! - -!methodRemoval: CodeFileBrowser #methodDiffFor:class:selector:meta: stamp: 'Install-4016-CodeFileBrowser-color-lists-fixes-JuanVuletich-2020Jan10-15h35m-jmv.1.cs.st 1/11/2020 17:58:51'! -methodDiffFor: aString class: aPseudoClass selector: selector meta: meta - "Answer the diff between the current copy of the given class/selector/meta for the string provided" - | theClass source | - theClass _ self pvtBaseClassOrMetaclass. - theClass ifNotNil: [ - meta ifTrue: [ theClass _ theClass class ]. - (theClass includesSelector: selector) ifTrue: [ source _ theClass sourceCodeAt: selector ]]. - ^ DifferenceFinder - displayPatchFrom: (source ifNil: ['']) - to: aString - tryWords: self shouldDiffWords - prettyPrintedIn: - (self showingAnyKindOfPrettyDiffs ifTrue: [ theClass ]).! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4016-CodeFileBrowser-color-lists-fixes-JuanVuletich-2020Jan10-15h35m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4012] on 10 January 2020 at 12:41:08 am'! -!Semaphore commentStamp: '' prior: 16905069! - I provide synchronized communication of a single bit of information (a "signal") between Processes. A signal is sent by sending the message signal and received by sending the message wait. If no signal has been sent when a wait message is sent, the sending Process will be suspended until a signal is sent. - -Beware that if a process calls 'aSemaphore critical: []' while already in a critical section for that semaphore, it will enter a deadlock. In some cases, a Mutex can be used instead. Refer to the Mutex class comment. - -More detail on the implementation as provided by Eliot Miranda: - -A semaphore is a queue (implemented as a linked list) and an excess signals count, which is a non-negative integer. On instance creation a new semaphore is empty and has a zero excess signals count. A semaphore created for mutual exclusion is empty and has an excess signals count of one. - -When a process waits on a semaphore, if the semaphore's excess signals count is non-zero, then the excess signal count is decremented, and the process proceeds. But if the semaphore has a zero excess signals count then the process is unscheduled and added to the end of the semaphore, after any other processes that are queued on the semaphore. - -When a semaphore is signaled, if it is not empty, the first process is removed from it and added to the runnable processes in the scheduler. If the semaphore is empty its excess signals count is incremented.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4017-Semaphore-class-comment-PhilBellalouna-2020Jan10-00h40m-pb.1.cs.st----! - -'From Cuis 5.0 [latest update: #3959] on 11 January 2020 at 5:38:50 pm'! -!BitBltCanvas methodsFor: 'drawing' stamp: 'jmv 1/11/2020 17:37:21' prior: 16786555! - line: pt1 to: pt2 width: wp color: c - | p1 p2 w | - (wp > 0 and: [ c isTransparent not ]) ifTrue: [ - p1 _ (currentTransformation transform: pt1) rounded. - p2 _ (currentTransformation transform: pt2) rounded. - w _ currentTransformation externalizeScalar: wp. - self setPaintColor: c. - port ifNil: [ self resetGrafPort ]. - port - width: w; - height: w; - drawFrom: p1 to: p2 ]! ! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 1/11/2020 17:38:10' prior: 50367316! - image: aForm at: aPoint sourceRect: sourceRect - "Draw a translucent image using the best available way of representing translucency. - Note: This will be fixed in the future." - | r p | - p _ (currentTransformation transform: aPoint) rounded. - r _ (self depth < 32 or: [ aForm mightBeTranslucent not ]) - ifTrue: [ - "Rule Form paint treats pixels with a value of zero as transparent" - Form paint ] - ifFalse: [ Form blend ]. - port ifNil: [ self resetGrafPort ]. - port colorMap: (aForm colormapIfNeededFor: form); fillColor: nil. - port image: aForm at: p sourceRect: sourceRect rule: r. - (self depth = 32 and: [ aForm depth < 32 ]) ifTrue: [ - "If we blit to 32bpp from one of smaller depth, - it will have zero in the alpha channel (until BitBlt is fixed!!) - This is the same workaround as in #asFormOfDepth:" - port sourceForm: nil. - port combinationRule: 40. "fixAlpha:with:" - port copyBits ]! ! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 1/11/2020 17:38:02' prior: 16786629! - stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor - "Flood this canvas with aColor wherever stencilForm has non-zero pixels" - | p | - p _ (currentTransformation transform: aPoint) rounded. - self setPaintColor: aColor. - port ifNil: [ self resetGrafPort ]. - port colorMap: stencilForm maskingMap. - port stencil: stencilForm - at: p - sourceRect: sourceRect! ! -!BitBltCanvas methodsFor: 'drawing-ovals' stamp: 'jmv 1/11/2020 17:38:14' prior: 50459927! - ellipseCenterX: mcx y: mcy rx: mrx ry: mry borderWidth: mbw borderColor: mbc fillColor: morphFillColor - - | displayRectangle doBorder doFill | - doBorder _ mbw > 0 and: [ mbc isTransparent not]. - doFill _ morphFillColor isTransparent not. - doBorder | doFill ifTrue: [ - displayRectangle _ (currentTransformation externalizeRectangle: (Rectangle center: mcx@mcy extent: mrx@mry * 2)) rounded. - "draw the border of the oval" - port ifNil: [ self resetGrafPort ]. - doBorder ifTrue: [ - self setPaintColor: mbc. - port frameOval: displayRectangle borderWidth: mbw]. - "fill the inside" - doFill ifTrue: [ - self setPaintColor: morphFillColor. - port fillOval: (displayRectangle insetBy: mbw) ]]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 1/11/2020 17:38:07' prior: 50459951! - frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor - | rect bw | - - r area = 0 ifTrue: [ ^self ]. - rect _ (currentTransformation externalizeRectangle: r) rounded. - bw _ currentTransformation externalizeScalar: borderWidth. - - "draw the border of the rectangle" - port ifNil: [ self resetGrafPort ]. - borderColor isTransparent ifFalse: [ - self setPaintColor: borderColor. - port frameRect: rect borderWidth: bw ]. - - "fill the inside" - fillColor isTransparent ifFalse: [ - self setPaintColor: fillColor. - port fillRect: (rect insetBy: bw) ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 1/11/2020 17:37:34' prior: 50459972! - frameRectangle: r borderWidth: borderWidth color: borderColor - " - Display getCanvas - frameRectangle: (10@10 extent: 300@200) - borderWidth: 20 - color: Color red. - Display forceToScreen - " - | rect bw | - (borderWidth > 0 and: [ borderColor isTransparent not ]) ifTrue: [ - rect _ (currentTransformation externalizeRectangle: r) rounded. - bw _ currentTransformation externalizeScalar: borderWidth. - self setPaintColor: borderColor. - port ifNil: [ self resetGrafPort ]. - port - frameRect: rect - borderWidth: bw ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 1/11/2020 17:37:55' prior: 50460027! - reverseRectangleBorder: r borderWidth: borderWidth - " - Display getCanvas - reverseRectangleBorder: (10@10 extent: 300@200) - borderWidth: 20. - Display forceToScreen - " - | rect | - rect _ (currentTransformation externalizeRectangle: r) rounded. - port ifNil: [ self resetGrafPort ]. - port - sourceForm: nil; - fillColor: `Color gray`; - combinationRule: Form reverse; - frameRect: rect borderWidth: borderWidth! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 1/11/2020 17:38:18' prior: 16787001! - drawString: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | p1 font | - "Don't waste any time if NOP" - lastIndex = 0 ifTrue: [ - ^nil ]. - - p1 _ (currentTransformation transform: aPoint) rounded. - port ifNil: [ self resetGrafPort ]. - port colorMap: nil. - font _ fontOrNil ifNil: [ AbstractFont default ]. - ^font on: port - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: aColor! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 1/11/2020 17:37:51' prior: 50460042! - fillRectangle: aRectangle tilingWith: aForm sourceRect: patternBox rule: aCombinationRule - - | displayRectangle additionalOffset clippedPort targetTopLeft clipOffset ex - targetBox savedMap top left | - - ex _ patternBox extent. - ex x = 0 ifTrue: [ ^self ]. - ex y = 0 ifTrue: [ ^self ]. - displayRectangle _ (currentTransformation externalizeRectangle: aRectangle) rounded. - - "this is a bit of a kludge to get the form to be aligned where I *think* it should be. - something better is needed, but not now" - - additionalOffset _ `0@0`. - port ifNil: [ self resetGrafPort ]. - clippedPort _ port clippedBy: displayRectangle. - targetTopLeft _ clippedPort clipRect topLeft truncateTo: ex. - clipOffset _ displayRectangle topLeft - targetTopLeft. - additionalOffset _ (clipOffset \\ ex) - ex. - - "do it iteratively" - targetBox _ clippedPort clipRect. - savedMap _ clippedPort colorMap. - clippedPort sourceForm: aForm; - fillColor: nil; - combinationRule: aCombinationRule; - sourceRect: patternBox; - colorMap: (aForm colormapIfNeededFor: clippedPort destForm). - top _ (targetBox top truncateTo: patternBox height) + additionalOffset y. - left _ (targetBox left truncateTo: patternBox width) + additionalOffset x. - - left to: (targetBox right - 1) by: patternBox width do: [:x | - top to: (targetBox bottom - 1) by: patternBox height do: [:y | - clippedPort destOrigin: x@y; copyBits]]. - clippedPort colorMap: savedMap! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 1/11/2020 17:37:40' prior: 16787100! - frameRectangle: rect borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor - " - rect and borderWidth are in form coordinates. No transformation is done. - Display getCanvas - frameRectangle: (10@10 extent: 300@200) - borderWidth: 20 - topLeftColor: Color green - bottomRightColor: Color red - Display getCanvas fillRectangle: (10@10 extent: 300@200) color: Color white - " - | w h | - - rect area = 0 ifTrue: [^ self]. - - self setPaintColor: topLeftColor. - - port ifNil: [ self resetGrafPort ]. - port frameRectTopLeft: rect borderWidth: borderWidth. - - borderWidth isNumber - ifTrue: [w _ h _ borderWidth] - ifFalse: [w _ borderWidth x. h _ borderWidth y]. - self setPaintColor: bottomRightColor. - port - frameRectRight: rect width: w; - frameRectBottom: rect height: h! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 1/11/2020 17:37:44' prior: 16787135! - setClipRect: aRectangle - "In form coordinates" - - super setClipRect: aRectangle. - port ifNil: [ self resetGrafPort ]. - port clipRect: aRectangle! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 1/11/2020 17:37:59' prior: 50388649! - setPaintColor: aColor - "Install a new color used for filling." - | paintColor | - paintColor _ aColor ifNil: [ `Color transparent` ]. - (paintColor is: #Color) ifFalse: [ - ^ self error: 'Cannot install color' ]. - - "Okay, so paintColor really *is* a color" - port ifNil: [ self resetGrafPort ]. - port sourceForm: nil. - (paintColor isOpaque or: [ self depth < 32]) ifTrue: [ - port fillColor: paintColor. - port combinationRule: Form paint. - ^ self ]. - - "BitBlt setup for alpha mapped transfer" - port fillColor: paintColor. - port combinationRule: Form blend! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4018-BitBltCanvasCleanup1-JuanVuletich-2020Jan11-17h37m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #3959] on 11 January 2020 at 5:40:48 pm'! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph drawingMorphStack engine ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support' stamp: 'Install-4019-BitBltCanvasCleanup2-JuanVuletich-2020Jan11-17h38m-jmv.1.cs.st 1/11/2020 17:58:51'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph drawingMorphStack engine' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 1/11/2020 17:40:22' prior: 16787126! - resetGrafPort - "Private!! Create a new grafPort for a new copy." - - port _ GrafPort toForm: form. - "Init BitBlt so that the first call to the 'primitiveDisplayString' primitive will not fail" - port sourceX: 0; width: 0. - engine _ port! ! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph drawingMorphStack engine' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support' stamp: 'Install-4019-BitBltCanvasCleanup2-JuanVuletich-2020Jan11-17h38m-jmv.1.cs.st 1/11/2020 17:58:51'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph drawingMorphStack engine' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - -BitBltCanvas allInstancesDo: [ :canvas | canvas resetGrafPort ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4019-BitBltCanvasCleanup2-JuanVuletich-2020Jan11-17h38m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4017] on 11 January 2020 at 3:14:31 pm'! - -Smalltalk renameClassNamed: #GrafPort as: #BitBltCanvasEngine! - -!classRenamed: #GrafPort as: #BitBltCanvasEngine stamp: 'Install-4020-BitBltCanvasCleanup3-JuanVuletich-2020Jan11-15h08m-jmv.1.cs.st 1/11/2020 17:58:51'! -Smalltalk renameClassNamed: #GrafPort as: #BitBltCanvasEngine! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph drawingMorphStack engine ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support' stamp: 'Install-4020-BitBltCanvasCleanup3-JuanVuletich-2020Jan11-15h08m-jmv.1.cs.st 1/11/2020 17:58:51'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph drawingMorphStack engine' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! -!AbstractFont methodsFor: 'BitBltCanvas support' stamp: 'jmv 1/11/2020 15:11:46'! - onBitBltCanvasEngine: engine displayString: aString from: firstIndex to: lastIndex at: p color: color - "Answer last affected pixel position - Answer nil if nothing was done" - - | char fallbackFont x y answer | - fallbackFont _ (FontFamily - familyName: FontFamily defaultFamilyName - aroundPointSize: self pointSize*0.9) - emphasized: self emphasis. - x _ p x. - y _ p y. - firstIndex to: lastIndex do: [ :i | - char _ aString at: i. - answer _ engine displayString: char asString from: 1 to: 1 at: x@y strikeFont: fallbackFont color: color. - x _ x + (self widthOf: char) ]. - ^answer! ! -!StrikeFont methodsFor: 'BitBltCanvas support' stamp: 'jmv 1/11/2020 15:11:58'! - onBitBltCanvasEngine: engine displayString: aString from: firstIndex to: lastIndex at: p color: color - "Answer last affected pixel position. - Answer nil if nothing was done." - - ^engine - displayString: aString - from: firstIndex - to: lastIndex - at: p - strikeFont: self - color: color! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 1/11/2020 15:09:59'! - resetEngine - "Private!! Create a new BitBltCanvasEngine for a new copy." - - engine _ BitBltCanvasEngine toForm: form. - "Init BitBlt so that the first call to the 'primitiveDisplayString' primitive will not fail" - engine sourceX: 0; width: 0. - port _ engine! ! -!Form class methodsFor: 'instance creation' stamp: 'jmv 1/11/2020 15:08:13' prior: 50387125! -fakeSphereAt: aPoint diameter: diameter color: aColor - "Create a form which contains a round black dot." - | bb rect d p | - bb _ BitBltCanvasEngine toForm: Display. - bb fillColor: aColor. - bb combinationRule: Form blend. - rect _ aPoint extent: diameter. - bb fillOval: rect. - p _ (diameter * 2 // 5) asPoint + aPoint. - #(2 3 4 5 6 ) do: [ :i | - "simulate facade by circles of gray" - bb fillColor: `Color white alpha: 0.3`. - d _ i * diameter // 10. - rect _ Rectangle - center: p - extent: d. - bb fillOval: rect ]. - DisplayScreen screenUpdateRequired: nil. -" - Form fakeSphereAt: 50@50 diameter: 30 color: (Color red alpha: 0.5) -"! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 1/11/2020 15:12:09' prior: 50494301! - drawString: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | p1 font | - "Don't waste any time if NOP" - lastIndex = 0 ifTrue: [ - ^nil ]. - - p1 _ (currentTransformation transform: aPoint) rounded. - port colorMap: nil. - font _ fontOrNil ifNil: [ AbstractFont default ]. - ^font - onBitBltCanvasEngine: port - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: aColor! ! -!BitBltCanvas methodsFor: 'initialization' stamp: 'jmv 1/11/2020 15:10:03' prior: 16787190! - initializeWith: aForm origin: aPoint - - super initializeWith: aForm origin: aPoint. - self resetEngine! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 1/11/2020 15:10:07' prior: 50463561! - setForm: aForm - super setForm: aForm. - self resetEngine. - self newClipRect: nil.! ! - -BitBltCanvas removeSelector: #resetGrafPort! - -!methodRemoval: BitBltCanvas #resetGrafPort stamp: 'Install-4020-BitBltCanvasCleanup3-JuanVuletich-2020Jan11-15h08m-jmv.1.cs.st 1/11/2020 17:58:51'! -resetGrafPort - "Private!! Create a new grafPort for a new copy." - - port _ GrafPort toForm: form. - "Init BitBlt so that the first call to the 'primitiveDisplayString' primitive will not fail" - port sourceX: 0; width: 0. - engine _ port! - -StrikeFont removeSelector: #on:displayString:from:to:at:color:! - -!methodRemoval: StrikeFont #on:displayString:from:to:at:color: stamp: 'Install-4020-BitBltCanvasCleanup3-JuanVuletich-2020Jan11-15h08m-jmv.1.cs.st 1/11/2020 17:58:51'! -on: aGrafPort displayString: aString from: firstIndex to: lastIndex at: p color: color - "Answer last affected pixel position. - Answer nil if nothing was done." - - ^aGrafPort - displayString: aString - from: firstIndex - to: lastIndex - at: p - strikeFont: self - color: color! - -AbstractFont removeSelector: #on:displayString:from:to:at:color:! - -!methodRemoval: AbstractFont #on:displayString:from:to:at:color: stamp: 'Install-4020-BitBltCanvasCleanup3-JuanVuletich-2020Jan11-15h08m-jmv.1.cs.st 1/11/2020 17:58:51'! -on: aGrafPort displayString: aString from: firstIndex to: lastIndex at: p color: color - "Answer last affected pixel position - Answer nil if nothing was done" - - | char fallbackFont x y answer | - fallbackFont _ (FontFamily - familyName: FontFamily defaultFamilyName - aroundPointSize: self pointSize*0.9) - emphasized: self emphasis. - x _ p x. - y _ p y. - firstIndex to: lastIndex do: [ :i | - char _ aString at: i. - answer _ aGrafPort displayString: char asString from: 1 to: 1 at: x@y strikeFont: fallbackFont color: color. - x _ x + (self widthOf: char) ]. - ^answer! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -BitBltCanvas allInstancesDo: [ :canvas | canvas resetEngine ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4020-BitBltCanvasCleanup3-JuanVuletich-2020Jan11-15h08m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4018] on 11 January 2020 at 3:20:49 pm'! -!BitBltCanvas methodsFor: 'drawing' stamp: 'jmv 1/11/2020 15:17:59' prior: 50494156! - line: pt1 to: pt2 width: wp color: c - | p1 p2 w | - (wp > 0 and: [ c isTransparent not ]) ifTrue: [ - p1 _ (currentTransformation transform: pt1) rounded. - p2 _ (currentTransformation transform: pt2) rounded. - w _ currentTransformation externalizeScalar: wp. - self setPaintColor: c. - engine - width: w; - height: w; - drawFrom: p1 to: p2 ]! ! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 1/11/2020 15:19:31' prior: 50494171! - image: aForm at: aPoint sourceRect: sourceRect - "Draw a translucent image using the best available way of representing translucency. - Note: This will be fixed in the future." - | r p | - p _ (currentTransformation transform: aPoint) rounded. - r _ (self depth < 32 or: [ aForm mightBeTranslucent not ]) - ifTrue: [ - "Rule Form paint treats pixels with a value of zero as transparent" - Form paint ] - ifFalse: [ Form blend ]. - engine colorMap: (aForm colormapIfNeededFor: form); fillColor: nil. - engine image: aForm at: p sourceRect: sourceRect rule: r. - (self depth = 32 and: [ aForm depth < 32 ]) ifTrue: [ - "If we blit to 32bpp from one of smaller depth, - it will have zero in the alpha channel (until BitBlt is fixed!!) - This is the same workaround as in #asFormOfDepth:" - engine sourceForm: nil. - engine combinationRule: 40. "fixAlpha:with:" - engine copyBits ]! ! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 1/11/2020 15:19:17' prior: 50494203! - stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor - "Flood this canvas with aColor wherever stencilForm has non-zero pixels" - | p | - p _ (currentTransformation transform: aPoint) rounded. - self setPaintColor: aColor. - engine colorMap: stencilForm maskingMap. - engine stencil: stencilForm - at: p - sourceRect: sourceRect! ! -!BitBltCanvas methodsFor: 'drawing-ovals' stamp: 'jmv 1/11/2020 15:19:39' prior: 50494218! - ellipseCenterX: mcx y: mcy rx: mrx ry: mry borderWidth: mbw borderColor: mbc fillColor: morphFillColor - - | displayRectangle doBorder doFill | - doBorder _ mbw > 0 and: [ mbc isTransparent not]. - doFill _ morphFillColor isTransparent not. - doBorder | doFill ifTrue: [ - displayRectangle _ (currentTransformation externalizeRectangle: (Rectangle center: mcx@mcy extent: mrx@mry * 2)) rounded. - "draw the border of the oval" - doBorder ifTrue: [ - self setPaintColor: mbc. - engine frameOval: displayRectangle borderWidth: mbw]. - "fill the inside" - doFill ifTrue: [ - self setPaintColor: morphFillColor. - engine fillOval: (displayRectangle insetBy: mbw) ]]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 1/11/2020 15:19:21' prior: 50494243! - frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor - | rect bw | - - r area = 0 ifTrue: [ ^self ]. - rect _ (currentTransformation externalizeRectangle: r) rounded. - bw _ currentTransformation externalizeScalar: borderWidth. - - "draw the border of the rectangle" - borderColor isTransparent ifFalse: [ - self setPaintColor: borderColor. - engine frameRect: rect borderWidth: bw ]. - - "fill the inside" - fillColor isTransparent ifFalse: [ - self setPaintColor: fillColor. - engine fillRect: (rect insetBy: bw) ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 1/11/2020 15:18:04' prior: 50494265! - frameRectangle: r borderWidth: borderWidth color: borderColor - " - Display getCanvas - frameRectangle: (10@10 extent: 300@200) - borderWidth: 20 - color: Color red. - Display forceToScreen - " - | rect bw | - (borderWidth > 0 and: [ borderColor isTransparent not ]) ifTrue: [ - rect _ (currentTransformation externalizeRectangle: r) rounded. - bw _ currentTransformation externalizeScalar: borderWidth. - self setPaintColor: borderColor. - engine - frameRect: rect - borderWidth: bw ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 1/11/2020 15:19:00' prior: 50494285! - reverseRectangleBorder: r borderWidth: borderWidth - " - Display getCanvas - reverseRectangleBorder: (10@10 extent: 300@200) - borderWidth: 20. - Display forceToScreen - " - | rect | - rect _ (currentTransformation externalizeRectangle: r) rounded. - engine - sourceForm: nil; - fillColor: `Color gray`; - combinationRule: Form reverse; - frameRect: rect borderWidth: borderWidth! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 1/11/2020 15:19:46' prior: 50494599! - drawString: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | p1 font | - "Don't waste any time if NOP" - lastIndex = 0 ifTrue: [ - ^nil ]. - - p1 _ (currentTransformation transform: aPoint) rounded. - engine colorMap: nil. - font _ fontOrNil ifNil: [ AbstractFont default ]. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: aColor! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 1/11/2020 15:19:54' prior: 50494320! - fillRectangle: aRectangle tilingWith: aForm sourceRect: patternBox rule: aCombinationRule - - | displayRectangle additionalOffset clippedEngine targetTopLeft clipOffset ex - targetBox savedMap top left | - - ex _ patternBox extent. - ex x = 0 ifTrue: [ ^self ]. - ex y = 0 ifTrue: [ ^self ]. - displayRectangle _ (currentTransformation externalizeRectangle: aRectangle) rounded. - - "this is a bit of a kludge to get the form to be aligned where I *think* it should be. - something better is needed, but not now" - - additionalOffset _ `0@0`. - clippedEngine _ engine clippedBy: displayRectangle. - targetTopLeft _ clippedEngine clipRect topLeft truncateTo: ex. - clipOffset _ displayRectangle topLeft - targetTopLeft. - additionalOffset _ (clipOffset \\ ex) - ex. - - "do it iteratively" - targetBox _ clippedEngine clipRect. - savedMap _ clippedEngine colorMap. - clippedEngine sourceForm: aForm; - fillColor: nil; - combinationRule: aCombinationRule; - sourceRect: patternBox; - colorMap: (aForm colormapIfNeededFor: clippedEngine destForm). - top _ (targetBox top truncateTo: patternBox height) + additionalOffset y. - left _ (targetBox left truncateTo: patternBox width) + additionalOffset x. - - left to: (targetBox right - 1) by: patternBox width do: [:x | - top to: (targetBox bottom - 1) by: patternBox height do: [:y | - clippedEngine destOrigin: x@y; copyBits]]. - clippedEngine colorMap: savedMap! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 1/11/2020 15:18:12' prior: 50494367! - frameRectangle: rect borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor - " - rect and borderWidth are in form coordinates. No transformation is done. - Display getCanvas - frameRectangle: (10@10 extent: 300@200) - borderWidth: 20 - topLeftColor: Color green - bottomRightColor: Color red - Display getCanvas fillRectangle: (10@10 extent: 300@200) color: Color white - " - | w h | - - rect area = 0 ifTrue: [^ self]. - - self setPaintColor: topLeftColor. - - engine frameRectTopLeft: rect borderWidth: borderWidth. - - borderWidth isNumber - ifTrue: [w _ h _ borderWidth] - ifFalse: [w _ borderWidth x. h _ borderWidth y]. - self setPaintColor: bottomRightColor. - engine - frameRectRight: rect width: w; - frameRectBottom: rect height: h! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 1/11/2020 15:18:17' prior: 50494395! - setClipRect: aRectangle - "In form coordinates" - - super setClipRect: aRectangle. - engine clipRect: aRectangle! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 1/11/2020 15:19:11' prior: 50494403! - setPaintColor: aColor - "Install a new color used for filling." - | paintColor | - paintColor _ aColor ifNil: [ `Color transparent` ]. - (paintColor is: #Color) ifFalse: [ - ^ self error: 'Cannot install color' ]. - - "Okay, so paintColor really *is* a color" - engine sourceForm: nil. - (paintColor isOpaque or: [ self depth < 32]) ifTrue: [ - engine fillColor: paintColor. - engine combinationRule: Form paint. - ^ self ]. - - "BitBlt setup for alpha mapped transfer" - engine fillColor: paintColor. - engine combinationRule: Form blend! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4021-BitBltCanvasCleanup4-JuanVuletich-2020Jan11-15h17m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4019] on 11 January 2020 at 3:22:11 pm'! - -MorphicCanvas subclass: #BitBltCanvas - instanceVariableNames: 'port ' - classVariableNames: 'AccessProtect AuxBlitter AuxForm CachedForms ' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #BitBltCanvas category: #'Morphic-Support' stamp: 'Install-4022-BitBltCanvasCleanup5-JuanVuletich-2020Jan11-15h21m-jmv.1.cs.st 1/11/2020 17:58:52'! -MorphicCanvas subclass: #BitBltCanvas - instanceVariableNames: 'port' - classVariableNames: 'AccessProtect AuxBlitter AuxForm CachedForms' - poolDictionaries: '' - category: 'Morphic-Support'! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 1/11/2020 15:21:45' prior: 50494565! - resetEngine - "Private!! Create a new BitBltCanvasEngine for a new copy." - - engine _ BitBltCanvasEngine toForm: form. - "Init BitBlt so that the first call to the 'primitiveDisplayString' primitive will not fail" - engine sourceX: 0; width: 0! ! - -MorphicCanvas subclass: #BitBltCanvas - instanceVariableNames: '' - classVariableNames: 'AccessProtect AuxBlitter AuxForm CachedForms' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #BitBltCanvas category: #'Morphic-Support' stamp: 'Install-4022-BitBltCanvasCleanup5-JuanVuletich-2020Jan11-15h21m-jmv.1.cs.st 1/11/2020 17:58:52'! -MorphicCanvas subclass: #BitBltCanvas - instanceVariableNames: '' - classVariableNames: 'AccessProtect AuxBlitter AuxForm CachedForms' - poolDictionaries: '' - category: 'Morphic-Support'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4022-BitBltCanvasCleanup5-JuanVuletich-2020Jan11-15h21m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4020] on 11 January 2020 at 3:33:30 pm'! -!AbstractFont methodsFor: 'BitBltCanvas support' stamp: 'jmv 1/11/2020 15:32:19' prior: 50494532! - onBitBltCanvasEngine: engine displayString: aString from: firstIndex to: lastIndex at: p color: color - "Answer last affected pixel position - Answer nil if nothing was done" - - self subclassResponsibility! ! -!StrikeFont methodsFor: 'BitBltCanvas support' stamp: 'jmv 1/11/2020 15:32:02' prior: 50494553! - onBitBltCanvasEngine: engine displayString: aString from: firstIndex to: lastIndex at: p color: color - "Answer last affected pixel position. - Answer nil if nothing was done." - - ^ engine - displayString: aString - from: firstIndex - to: lastIndex - at: p - strikeFont: self - color: color! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4023-BitBltCanvasCleanup6-JuanVuletich-2020Jan11-15h32m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4021] on 11 January 2020 at 3:49:54 pm'! -!PasteUpMorph methodsFor: 'defaul desktop' stamp: 'jmv 1/11/2020 15:47:27' prior: 50473038! - recreateDefaultDesktop - | editor | - self whenUIinSafeState: [ - self hideTaskbar. - (submorphs - select: [ :ea | ea class == SystemWindow or: [ea class == TranscriptWindow]]) - do: [ :ea | ea delete ]. - TranscriptWindow openTranscript - morphPosition: 5 @ 290; - morphExtent: 990 @ 400. - editor _ TextEditor openTextEditor - morphPosition: 456 @ 10; - morphExtent: 900 @ 680. - editor setLabel: 'About Cuis'. - editor model actualContents: Utilities defaultTextEditorContents. - self showTaskbar. - ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4024-RecreateDefaultDesktop-fix-JuanVuletich-2020Jan11-15h49m-jmv.1.cs.st----! - -----SNAPSHOT----(11 January 2020 17:59:03) Cuis5.0-4024-v3.image priorSource: 4827926! - -----QUIT----(11 January 2020 17:59:25) Cuis5.0-4024-v3.image priorSource: 5229511! - -----STARTUP---- (1 April 2020 17:57:08) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4024-v3.image! - - -'From Cuis 5.0 [latest update: #4024] on 12 January 2020 at 9:41:15 pm'! - -"Change Set: 4025-CuisCore-AuthorName-2020Jan12-21h12m -Date: 12 January 2020 -Author: Nahuel Garbezza - -Ability to extract quoted expressions in the extract method refactoring"! -!ParseNode methodsFor: 'source ranges' stamp: 'RNG 1/12/2020 21:20:28'! - expandIfEnclosed: sourceRange on: sourceCode - "takes a source range and a source code and if the source range represents an - expression that can be expanded and still is valid, it returns the source range - 'grown'. Examples: (*3 + 4*) to *(3 + 4)*; `*3 + 4*` to *`3 + 4`*" - - | firstChar lastChar | - firstChar _ sourceCode at: sourceRange first - 1 ifAbsent: [ nil ]. - lastChar _ sourceCode at: sourceRange last + 1 ifAbsent: [ nil ]. - ^ ((firstChar = $( and: [ lastChar = $) ]) - or: [ firstChar = $` and: [ lastChar = $` ] ]) - ifTrue: [ sourceRange first - 1 to: sourceRange last + 1 ] - ifFalse: [ sourceRange ]! ! -!ParseNode methodsFor: 'source ranges' stamp: 'RNG 1/12/2020 21:12:37' prior: 50488532! - expandRanges: sourceRanges basedOn: allSourceRanges using: sourceCode - - ^ (self consolidateAsCollection: sourceRanges) - collect: [ :sourceRange | self expandIfEnclosed: sourceRange on: sourceCode ]! ! -!MessageNode methodsFor: 'source ranges' stamp: 'RNG 1/12/2020 21:12:37' prior: 50488620! - expandRanges: aSourceRange basedOn: sourceRanges using: sourceCode - - | receiverExpandedRanges expandedRangeWithReceiver | - receiverExpandedRanges _ self isCascade - ifTrue: [ self flag: #RNG . aSourceRange ] "fix source ranges for cascade messages" - ifFalse: [ receiver expandRanges: (self receiverSourceRangesFrom: sourceRanges) basedOn: sourceRanges using: sourceCode ]. - expandedRangeWithReceiver _ self - expandRange: (aSourceRange isInterval ifTrue: [ aSourceRange ] ifFalse: [ aSourceRange first ]) - basedOn: receiverExpandedRanges. - ^ self consolidateAsCollection: (self expandIfEnclosed: expandedRangeWithReceiver on: sourceCode)! ! - -ParseNode removeSelector: #expandIfEnclosedWithParentheses:on:! - -!methodRemoval: ParseNode #expandIfEnclosedWithParentheses:on: stamp: 'Install-4025-CuisCore-NahuelGarbezza-2020Jan12-21h12m-RNG.1.cs.st 4/1/2020 17:57:13'! -expandIfEnclosedWithParentheses: sourceRange on: sourceCode - - | startsWithParen endsWithParen | - self flag: #RNG. "take into account other cases: spaces in middle, multiple parenthesis" - startsWithParen _ (sourceCode at: sourceRange first - 1 ifAbsent: [nil]) = $(. - endsWithParen _ (sourceCode at: sourceRange last + 1 ifAbsent: [nil]) = $). - ^ startsWithParen & endsWithParen - ifTrue: [ sourceRange first - 1 to: sourceRange last + 1 ] - ifFalse: [ sourceRange ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4025-CuisCore-NahuelGarbezza-2020Jan12-21h12m-RNG.1.cs.st----! - -'From Cuis 5.0 [latest update: #4024] on 14 January 2020 at 9:33:11 am'! -!MorphicCanvas methodsFor: 'accessing' stamp: 'jmv 1/14/2020 09:32:14' prior: 16877371! - clipRect - "Return the currently active clipping rectangle" - "In targetForm coordinates" - - ^ clipLeft@clipTop corner: clipRight@clipBottom+1! ! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 1/14/2020 09:32:17' prior: 16877358! - setClipRect: aRectangle - "by convention, aRectangle includes left and top but does not include right and bottom. - We do draw clipRight and clipBottom but not beyond. - " - "In targetForm coordinates" - - clipLeft _ aRectangle left. - clipTop _ aRectangle top. - clipRight _ aRectangle right - 1. - clipBottom _ aRectangle bottom - 1! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 1/14/2020 09:32:06' prior: 50494906! - frameRectangle: rect borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor - " - rect and borderWidth are in targetForm coordinates. No transformation is done. - Display getCanvas - frameRectangle: (10@10 extent: 300@200) - borderWidth: 20 - topLeftColor: Color green - bottomRightColor: Color red - Display getCanvas fillRectangle: (10@10 extent: 300@200) color: Color white - " - | w h | - - rect area = 0 ifTrue: [^ self]. - - self setPaintColor: topLeftColor. - - engine frameRectTopLeft: rect borderWidth: borderWidth. - - borderWidth isNumber - ifTrue: [w _ h _ borderWidth] - ifFalse: [w _ borderWidth x. h _ borderWidth y]. - self setPaintColor: bottomRightColor. - engine - frameRectRight: rect width: w; - frameRectBottom: rect height: h! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 1/14/2020 09:32:10' prior: 50494933! - setClipRect: aRectangle - "In targetForm coordinates" - - super setClipRect: aRectangle. - engine clipRect: aRectangle! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 1/14/2020 09:32:00' prior: 50463581! - clippingRectForCurrentMorph - "In targetForm coordinates" - - ^currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds! ! -!BitBltCanvas methodsFor: 'testing' stamp: 'jmv 1/14/2020 09:30:46' prior: 50463588! - isCurrentMorphVisible - - | aRectangle | - currentMorph visible ifFalse: [ ^false ]. - "#clippingRectForCurrentMorph is valid even before drawing currentMorph, only in BitBltCanvas!!" - aRectangle _ self clippingRectForCurrentMorph. - aRectangle right < clipLeft ifTrue: [^ false]. - aRectangle left > (clipRight+1) ifTrue: [^ false]. - aRectangle bottom < clipTop ifTrue: [^ false]. - aRectangle top > (clipBottom+1) ifTrue: [^ false]. - ^ true -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4026-CommentsTweaks-JuanVuletich-2020Jan14-09h19m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4026] on 17 January 2020 at 10:23:32 am'! -!BlockClosure methodsFor: 'evaluating' stamp: 'jmv 1/17/2020 10:22:55' prior: 50371844! - bench - "See how many times I can value in 5 seconds. I'll answer a meaningful description. - [ Float pi printString ] bench print. - [ 80000 factorial printString ] bench print. - " - - | secondsPerRun startTime endTime count run | - count _ 0. - run _ true. - [ (Delay forSeconds: 5) wait. run _ false ] forkAt: Processor timingPriority - 1. - startTime _ Time localMillisecondClock. - [ run ] whileTrue: [ self value. count _ count + 1 ]. - endTime _ Time localMillisecondClock. - secondsPerRun _ (endTime - startTime) / (count * 1000). - secondsPerRun >= 1 - ifTrue: [ - secondsPerRun withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - ^String streamContents: [ :strm | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixSymbol; - nextPutAll: ' seconds per run']] - ] - ifFalse: [ - 1.0 / secondsPerRun withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - ^String streamContents: [ :strm | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixSymbol; - nextPutAll: ' runs per second' ]] - ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4027-bench-fix-JuanVuletich-2020Jan17-10h14m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4026] on 18 January 2020 at 2:28:39 pm'! -!BitBltCanvasEngine methodsFor: 'private' stamp: 'jmv 1/18/2020 14:26:21' prior: 50387484! - setRuleAndMapFor: sourceDepth foregroundColor: foregroundColor - - | targetColor destDepth | - destDepth _ destForm depth. - halftoneForm _ nil. "Don't use fillColor. Use a more powerful ColorMap" - - sourceDepth = 1 ifTrue: [ - self combinationRule: Form paint. - "Set up color map for a different source depth (color font)" - "Uses caching for reasonable efficiency" - colorMap _ self cachedFontColormapFrom1BitTo: destDepth. - colorMap at: 1 put: (destForm pixelValueFor: `Color transparent`). - colorMap at: 2 put: (destForm pixelValueFor: foregroundColor) ] - - ifFalse: [ - "Enable subpixel rendering if requested, but never for translucent text: - This technique always draws opaque text. This could be added, by using an extra colormap for the rgbMul phase... - So far, no need arised for doing so." - (sourceDepth > 8 and: [ - Preferences subPixelRenderFonts and: [ foregroundColor = `Color black` or: [ - Preferences subPixelRenderColorFonts and: [ foregroundColor isOpaque ]]]]) ifTrue: [ - destDepth > 8 ifTrue: [ - "rgbMul is equivalent to component alpha blend if text is black (only faster, hehe)" - self combinationRule: 37. "rgbMul" - colorMap _ (foregroundColor ~= `Color black` or: [ - destDepth = 32 and: [ destForm ~~ Display or: [Preferences properDisplayAlphaForFonts] ]]) ifTrue: [ - "rgbMul / rgbAdd IS component alpha blend for any color of text (neat trick, eh!!)" - "This colorMap is to be used on the second pass with rule 20 (rgbAdd) - See #displayString:from:to:at:strikeFont:color:" - "Note: In 32bpp, if we want the correct alpha in the result, we need the second pass, as the destination could have transparent pixels, - and we need to add to the alpha channel" - self colorConvertingMap: foregroundColor from: sourceDepth to: destDepth keepSubPixelAA: true]] - ifFalse: [ - self combinationRule: 25. "Paint" - targetColor _ foregroundColor = `Color black` ifFalse: [ foregroundColor ]. - colorMap _ self colorConvertingMap: targetColor from: sourceDepth to: destDepth keepSubPixelAA: true]] - ifFalse: [ - "Do not use rule 34 for 16bpp display." - self combinationRule: (destDepth = 32 ifTrue: [34 "alphaBlendScaled"] ifFalse: [25 "Paint"]). - colorMap _ self colorConvertingMap: foregroundColor from: sourceDepth to: destDepth keepSubPixelAA: false]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4028-BitBltCommentFix-JuanVuletich-2020Jan18-14h15m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4026] on 19 January 2020 at 9:41:37 am'! - -StrikeFont removeSelector: #setGlyphs:! - -!methodRemoval: StrikeFont #setGlyphs: stamp: 'Install-4029-setGlyphs-removal-JuanVuletich-2020Jan19-09h22m-jmv.1.cs.st 4/1/2020 17:57:13'! -setGlyphs: newGlyphs - "Replace the glyphs form. Used to make a synthetic bold or italic font quickly." - - glyphs _ newGlyphs! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4029-setGlyphs-removal-JuanVuletich-2020Jan19-09h22m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4029] on 19 January 2020 at 11:57:15 pm'! - -"Change Set: 4030-CuisCore-AuthorName-2020Jan19-23h10m -Date: 19 January 2020 -Author: Nahuel Garbezza - -Small improvements to the inspector contextual menu"! -!InspectorWindow methodsFor: 'menu building' stamp: 'RNG 1/19/2020 23:53:02'! - addCollectionSpecificMenuOptionsTo: aMenu - - | object | - object _ model object. - (object is: #Dictionary) ifTrue: [ - aMenu addItemsFromDictionaries: self menuOptionsForDictionary ] - ifFalse: [ (object is: #Set) ifTrue: [ - aMenu addItemsFromDictionaries: self menuOptionsForSet ]]! ! -!InspectorWindow methodsFor: 'menu building' stamp: 'RNG 1/19/2020 23:27:18'! - basicMenuOptions - - ^ `{ - { - #label -> 'inspect (i)'. - #selector -> #inspectSelection. - #icon -> #inspectIcon - } asDictionary. - { - #label -> 'explore (I)'. - #selector -> #exploreSelection. - #icon -> #exploreIcon - } asDictionary. - { - #label -> 'copy to clipboard (c)'. - #selector -> #copySelectionToClipboard. - #icon -> #copyIcon - } asDictionary. - { - #label -> 'basic inspect'. - #selector -> #inspectBasic. - #icon -> #inspectIcon - } asDictionary. - { - #label -> 'references finder'. - #selector -> #openReferencesFinder. - #icon -> #exploreIcon - } asDictionary. - { - #label -> 'weight explorer'. - #selector -> #openWeightExplorer. - #icon -> #exploreIcon - } asDictionary. - }`! ! -!InspectorWindow methodsFor: 'menu building' stamp: 'RNG 1/19/2020 23:24:15'! - menuOptionsForBrowsing - - ^ `{ - nil. - { - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - }`! ! -!InspectorWindow methodsFor: 'menu building' stamp: 'RNG 1/19/2020 23:25:40'! - menuOptionsForDictionary - - ^ `{ - nil. - { - #label -> 'senders of this key'. - #selector -> #sendersOfSelectedKey. - #icon -> #mailForwardIcon - } asDictionary. - { - #label -> 'add key'. - #selector -> #addEntry. - #icon -> #listAddIcon - } asDictionary. - { - #label -> 'rename key'. - #selector -> #renameEntry. - #icon -> #saveAsIcon - } asDictionary. - { - #label -> 'remove'. - #object -> #model. - #selector -> #removeSelection. - #icon -> #listRemoveIcon - } asDictionary. - }`! ! -!InspectorWindow methodsFor: 'menu building' stamp: 'RNG 1/19/2020 23:25:27'! - menuOptionsForSet - - ^ `{ - nil. - { - #label -> 'remove'. - #object -> #model. - #selector -> #removeSelection. - #icon -> #listRemoveIcon - } asDictionary. - }`! ! -!InspectorWindow methodsFor: 'menu building' stamp: 'RNG 1/19/2020 23:52:42' prior: 50399277! - fieldListMenu - "Arm the supplied menu with items for the field-list of the receiver" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addItemsFromDictionaries: self basicMenuOptions. - self addCollectionSpecificMenuOptionsTo: aMenu. - aMenu addItemsFromDictionaries: self menuOptionsForBrowsing. - ^ aMenu! ! -!InspectorWindow methodsFor: 'menu commands' stamp: 'RNG 1/19/2020 23:11:27' prior: 16857378! - sendersOfSelectedKey - | key | - key _ model selectedKey. - key isString ifFalse: [ ^self ]. - Smalltalk browseAllCallsOn: key! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4030-InspectorImprovement-NahuelGarbezza-2020Jan19-23h10m-RNG.1.cs.st----! - -'From Cuis 5.0 [latest update: #4029] on 19 January 2020 at 2:37:19 pm'! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 1/19/2020 14:06:22' prior: 16914792! - useLeftArrow - "Use left arrow glyph instead of underscore, and up arrow glyph instead of caret" - self characterToGlyphMap. - characterToGlyphMap at: 96 put: 28. - characterToGlyphMap at: 95 put: 30! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 1/19/2020 14:07:34' prior: 16914798! - useRightArrow - "Use right arrow glyph instead of underscore, and up arrow glyph instead of caret" - self characterToGlyphMap. - characterToGlyphMap at: 96 put: 29. - characterToGlyphMap at: 95 put: 30! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 1/19/2020 14:06:46' prior: 16914809! - useUnderscore - "Sets underscore and caret glyphs for chars 95 and 94. - ASCII standard glyphs" - self characterToGlyphMap. - characterToGlyphMap at: 96 put: 95. - characterToGlyphMap at: 95 put: 94! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4031-StrikeFont-comments-JuanVuletich-2020Jan19-14h06m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4030] on 26 January 2020 at 9:04:24 am'! -!Character class methodsFor: 'class initialization' stamp: 'jmv 1/26/2020 08:29:15' prior: 50463750! - initializeUnicodeCodePoints - " - Character initializeUnicodeCodePoints - String streamContents: [ :strm | 28 to: 255 do: [ :i | strm nextPut: (Character numericValue: i) ]] - " - - "Initialize the table of Unicode code points" - UnicodeCodePoints _ Array new: 256. - 0 to: 255 do: [ :code | - UnicodeCodePoints at: code + 1 put: code ]. - - "Arrows" - UnicodeCodePoints at: 28+1 put: 8592. "left arrow" - UnicodeCodePoints at: 29+1 put: 8594. "right arrow" - UnicodeCodePoints at: 30+1 put: 8593. "up arrow" - UnicodeCodePoints at: 31+1 put: 8595. "down arrow" - - "The following codes are different in ISO 8859-15 from those in ISO 8859-1, - so the character code is not equal to the Unicode code point" - UnicodeCodePoints at: 16rA4+1 put: 16r20AC. "euro sign" - UnicodeCodePoints at: 16rA6+1 put: 16r160. "latin capital letter S with caron" - UnicodeCodePoints at: 16rA8+1 put: 16r161. "latin small letter s with caron" - UnicodeCodePoints at: 16rB4+1 put: 16r17D. "latin capital letter Z with caron" - UnicodeCodePoints at: 16rB8+1 put: 16r17E. "latin small letter z with caron" - UnicodeCodePoints at: 16rBC+1 put: 16r152. "latin capital ligature OE" - UnicodeCodePoints at: 16rBD+1 put: 16r153. "latin small ligature oe" - UnicodeCodePoints at: 16rBE+1 put: 16r178. "latin capital letter Y with diaeresis" - - UnicodeCodePoints at: 16r80+1 put: 16r2205. "EMPTY SET" - UnicodeCodePoints at: 16r81+1 put: 16r221E. "INFINITY" - UnicodeCodePoints at: 16r82+1 put: 16r2135. "ALEF SYMBOL" - UnicodeCodePoints at: 16r83+1 put: 16r03C0. "pi" - UnicodeCodePoints at: 16r84+1 put: 16r03B5. "epsilon" - UnicodeCodePoints at: 16r85+1 put: 16r03B6. "zeta" - UnicodeCodePoints at: 16r86+1 put: 16r0394. "Delta" - UnicodeCodePoints at: 16r87+1 put: 16r03A9. "Omega" - UnicodeCodePoints at: 16r88+1 put: 16r2102. "DOUBLE-STRUCK CAPITAL C" - UnicodeCodePoints at: 16r89+1 put: 16r210D. "DOUBLE-STRUCK CAPITAL H" - UnicodeCodePoints at: 16r8A+1 put: 16r2115. "DOUBLE-STRUCK CAPITAL N" - UnicodeCodePoints at: 16r8B+1 put: 16r2119. "DOUBLE-STRUCK CAPITAL P" - UnicodeCodePoints at: 16r8C+1 put: 16r211A. "DOUBLE-STRUCK CAPITAL Q" - UnicodeCodePoints at: 16r8D+1 put: 16r211D. "DOUBLE-STRUCK CAPITAL R" - UnicodeCodePoints at: 16r8E+1 put: 16r2124. "DOUBLE-STRUCK CAPITAL Z" - UnicodeCodePoints at: 16r8F+1 put: 16r0046. "DOUBLE-STRUCK CAPITAL F" "should be 1D53D, index out of bounds" - UnicodeCodePoints at: 16r90+1 put: 16r2295. "OPLUS" - UnicodeCodePoints at: 16r91+1 put: 16r2297. "OTIMES" - UnicodeCodePoints at: 16r92+1 put: 16r2299. "ODOT" - UnicodeCodePoints at: 16r93+1 put: 16r2296. "OMINUS" - UnicodeCodePoints at: 16r94+1 put: 16r2217. "ASTERISK OPERATOR" - UnicodeCodePoints at: 16r95+1 put: 16r2218. "RING OPERATOR (circ)" - UnicodeCodePoints at: 16r96+1 put: 16r2219. "BULLET OPERATOR (filled circ)" - UnicodeCodePoints at: 16r97+1 put: 16r22C5. "DOT OPERATOR" "(already at B7)" - UnicodeCodePoints at: 16r98+1 put: 16r22C6. "STAR OPERATOR" - UnicodeCodePoints at: 16r99+1 put: 16r21A0. "SURJECTIVE ARROW" - UnicodeCodePoints at: 16r9A+1 put: 16r21A3. "INJECTIVE ARROW" - UnicodeCodePoints at: 16r9B+1 put: 16r2194. "BIJECTIVE ARROW" - UnicodeCodePoints at: 16r9C+1 put: 16r21AA. "INCLUSION ARROW" - UnicodeCodePoints at: 16r9D+1 put: 16r21A6. "MAPPING ARROW" - UnicodeCodePoints at: 16r9E+1 put: 16r2202. "PARTIAL DIFFERENTIAL" - UnicodeCodePoints at: 16r9F+1 put: 16r221A. "SQUARE ROOT" -! ! - -Character removeSelector: #codePointOfGlyphToUse! - -!methodRemoval: Character #codePointOfGlyphToUse stamp: 'Install-4032-Character-cleanup-JuanVuletich-2020Jan26-08h29m-jmv.1.cs.st 4/1/2020 17:57:13'! -codePointOfGlyphToUse - " - For certain ASCII characters, we prefer a non ASCII Unicode glyph if available (i.e. with TrueType fonts). - $* codePoint hex - $* codePointOfGlyphToUse hex - " - self = $- ifTrue: [ ^16r2212 ]. "WIDE MINUS" - self = $* ifTrue: [ ^16r2217 ]. "CENTERED ASTERISK" - ^ self codePoint! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4032-Character-cleanup-JuanVuletich-2020Jan26-08h29m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4032] on 28 January 2020 at 9:56:35 am'! -!InnerListMorph methodsFor: 'drawing' stamp: 'jmv 1/28/2020 09:55:26' prior: 50492628! - draw: item atRow: row on: canvas - "display the given item at row row" - | f c | - (item is: #Text) - ifTrue: [ - f _ font emphasized: (item emphasisAt: 1). - c _ (item colorAt: 1) ifNil: [Theme current text]] - ifFalse: [ - f _ font. - c _ Theme current text]. - canvas - drawString: item - at: 0 @ (self drawYForRow: row) - font: f - color: c! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4033-FixBugIntroducedIn4011-JuanVuletich-2020Jan28-09h55m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4030] on 25 January 2020 at 6:29:18 pm'! -!MessageNames commentStamp: '' prior: 0! -Search for message names. There are several special characters that alter how searchString is interpreted: -$; - separate several search criteria (like 'editorClassFor:;contentsSelection') -$* - matches a string pattern rather than just a simple string match (i.e. 'set*text') -$# - matches a single character (for example, 'ini###lize'! -!MessageNamesWindow methodsFor: 'GUI building' stamp: 'pb 1/25/2020 18:22:25' prior: 50455662! - buildMorphicWindow - "Answer a morphic window with the given initial search string, nil if none" - "MessageNames openMessageNames" - | selectorListView firstRow searchButton secondRow | - textMorph _ (TextModelMorph - textProvider: model - textGetter: #searchString - textSetter: #searchString: - selectionGetter: #contentsSelection) - setBalloonText: 'See MessageNames class comment for search string options'; - emptyTextDisplayMessage: 'Type here, then hit Search'. - textMorph askBeforeDiscardingEdits: false. - textMorph acceptOnCR: true. - textMorph hideScrollBarsIndefinitely. - searchButton _ PluggableButtonMorph new - model: textMorph textMorph; - label: 'Search'; - action: #acceptContents. - searchButton setBalloonText: 'Type some letters into the pane at right, and then press this Search button (or hit RETURN) and all method selectors that match what you typed will appear in the list pane below. Click on any one of them, and all the implementors of that selector will be shown in the right-hand pane, and you can view and edit their code without leaving this tool.'. - firstRow _ LayoutMorph newRow. - firstRow color: self windowColor. - firstRow - doAdoptWidgetsColor; - - addMorph: searchButton - proportionalWidth: 0.25; - - addMorph: textMorph - proportionalWidth: 0.75. - selectorListView _ PluggableListMorph - model: model - listGetter: #selectorList - indexGetter: #selectorListIndex - indexSetter: #selectorListIndex: - mainView: self - menuGetter: #selectorListMenu - keystrokeAction: #selectorListKey:from:. - secondRow _ LayoutMorph newRow. - secondRow - - addMorph: selectorListView - proportionalWidth: 0.5; - - addAdjusterAndMorph: self buildMorphicMessageList - proportionalWidth: 0.5. - self layoutMorph - - addMorph: firstRow - fixedHeight: self defaultButtonPaneHeight + 4; - - addAdjusterAndMorph: secondRow - proportionalHeight: 0.5; - - addAdjusterAndMorph: self buildLowerPanes - proportionalHeight: 0.5. - model changed: #editSelection.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4034-MessageNames-searchString-documentation-PhilBellalouna-2020Jan25-18h00m-pb.1.cs.st----! - -'From Cuis 5.0 [latest update: #4034] on 17 February 2020 at 3:33:24 pm'! -!Feature class methodsFor: 'convenience' stamp: 'jmv 2/17/2020 15:27:42'! - require: featureName version: integerVersion revision: integerRevision - " - Feature require: 'Sound' version: 1 revision: 0 - Feature require: 'Tests' version: 1 revision: 0 - " - (FeatureRequirement name: featureName version: integerVersion revision: integerRevision) require! ! -!Feature class methodsFor: 'convenience' stamp: 'jmv 2/17/2020 15:27:34' prior: 16840628! - require: featureName version: versionNumber - " - Feature require: 'StyledTextInstaller' version: 1 - Feature require: 'Sound' version: 1 - Feature require: 'Tests' version: 1 - " - (FeatureRequirement name: featureName version: versionNumber) require! ! -!FeatureRequirement methodsFor: 'printing' stamp: 'jmv 2/17/2020 15:26:20' prior: 16840869! - printDetailsOn: aStream - aStream - nextPutAll: name; - nextPut: $ . - minVersion - ifNil: [ - aStream nextPutAll: '*.*)'. - ^self ] - ifNotNil: [ minVersion printOn: aStream ]. - aStream nextPut: $.. - minRevision - ifNil: [ aStream nextPut: $* ] - ifNotNil: [ minRevision printOn: aStream ]. - (minRevision notNil or: [ maxVersion isNil or: [maxVersion > minVersion ]]) ifTrue: [ - aStream nextPutAll: ' to '. - maxVersion - ifNil: [ aStream nextPut: $* ] - ifNotNil: [ maxVersion printOn: aStream ]. - maxVersion = minVersion - ifTrue: [ aStream nextPutAll: '.999' ] - ifFalse: [ aStream nextPutAll: '.*' ] - ]! ! -!FeatureRequirement class methodsFor: 'instance creation' stamp: 'jmv 2/17/2020 15:32:03' prior: 16840985! - name: aSymbol minVersion: minVersionOrNil minRevision: minRevisionOrNil maxVersion: maxVersionOrNil - - | newInst | - (minVersionOrNil isNil or: [ minVersionOrNil isInteger ]) ifFalse: [ - self error: 'Version numbers must be Integer numbers. Specify also Revision number if needed.' ]. - (minRevisionOrNil isNil or: [ minRevisionOrNil isInteger ]) ifFalse: [ - self error: 'Revision numbers must be Integer numbers.' ]. - (maxVersionOrNil isNil or: [ maxVersionOrNil isInteger ]) ifFalse: [ - self error: 'Version numbers must be Integer numbers. Specify also Revision number if needed.' ]. - newInst _ self new. - newInst name: aSymbol minVersion: minVersionOrNil minRevision: minRevisionOrNil maxVersion: maxVersionOrNil. - - ^ newInst! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4035-FeatureRequirement-fixes-JuanVuletich-2020Feb17-15h11m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4034] on 10 February 2020 at 1:34:40 pm'! -!PasteUpMorph methodsFor: 'geometry' stamp: 'jmv 2/10/2020 13:34:12'! - fontPreferenceChanged - self recreateDefaultDesktop. - super fontPreferenceChanged! ! -!FontFamily class methodsFor: 'initialization' stamp: 'jmv 2/10/2020 13:34:19' prior: 50473017! - defaultFamilyName: aStringOrNil defaultPointSize: aNumberOrNil - "Nil just means leave it as it is now." - | family | - aStringOrNil ifNotNil: [DefaultFamilyName _ aStringOrNil]. - aNumberOrNil ifNotNil: [DefaultPointSize _ aNumberOrNil]. - self revisar. "Please remove this hack meant to install larger DejaVu StrikeFonts on demand." - DefaultFamilyName = 'DejaVu' ifTrue: [ - family _ AvailableFamilies at: DefaultFamilyName. - (family pointSizes includes: DefaultPointSize) ifFalse: [ StrikeFont install: DefaultFamilyName]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4036-Cleanup-JuanVuletich-2020Feb10-13h33m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4035] on 16 February 2020 at 9:01:19 pm'! -!String methodsFor: 'displaying' stamp: 'jmv 2/16/2020 20:59:55' prior: 50365656! - 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 mousePoint - from: 0 to: 100 - during: [:barBlock | - 1 to: 100 do: [:x | - (Delay forMilliseconds: 10) wait. - barBlock value: x.]]. - -['Now here''s some Real Progress' - displayProgressAt: Sensor mousePoint - from: 0 to: 100 - during: [:barBlock | - 1 to: 100 do: [:x | barBlock value: x. - (Delay forMilliseconds: 100) wait]].] fork - -['Now here''s some Real Progress' - displayProgressAt: Sensor mousePoint - from: 0 to: 10 - during: [:barBlock | - 1 to: 30 do: [:x | barBlock value: x \\ 11. - (Delay forMilliseconds: 100) wait]]] fork - -'Now here''s some Real Progress' - displayProgressAt: Sensor mousePoint - from: 0 to: 10 - during: [:barBlock | - 1 to: 30 do: [:x | barBlock value: nil. - (Delay forMilliseconds: 200) 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. - -The use of ProgressInitiationException allows for avoiding actual -progress display, by catching the exception. -" - | answer duration | - Transcript show: self; show: '...'. - duration _ [ - answer _ ProgressInitiationException - display: self - at: aPoint - from: minVal - to: maxVal - during: workBlock] durationToRun. - Transcript show: ' done. Took '; show: duration printString; newLine. - ^answer! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4037-LogProgressToTranscript-JuanVuletich-2020Feb16-20h54m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4034] on 29 January 2020 at 8:52:03 am'! -!Behavior methodsFor: 'compiling' stamp: 'jmv 1/29/2020 08:47:49' prior: 16783295! - compile: code notifying: requestor - "Compile the argument, code, as source code in the context of the - receiver and install the result in the receiver's method dictionary. The - second argument, requestor, is to be notified if an error occurs. The - argument code is either a string or an object that converts to a string or - a PositionableStream. This method also saves the source code." - - | methodAndNode | - methodAndNode _ self - basicCompile: code "a Text" - notifying: requestor - trailer: self defaultMethodTrailer - ifFail: [^nil]. - methodAndNode method putSource: code fromParseNode: methodAndNode node inFile: 2 - withPreamble: [:f | f newLine; nextPut: $!!; nextChunkPut: 'Behavior method'; newLine]. - self addSelectorSilently: methodAndNode selector withMethod: methodAndNode method. - ^ methodAndNode selector! ! -!Decompiler class methodsFor: 'testing' stamp: 'jmv 1/29/2020 08:46:03' prior: 16832427! - recompileAllTest - "[Decompiler recompileAllTest]" - "decompile every method and compile it back; if the decompiler is correct then the system should keep running. :)" - - Smalltalk allBehaviorsDo: [ :behavior | - Utilities informUser: (behavior printString) during: [ - behavior selectors do: [ :sel | - | decompiled ast compiled | - decompiled := Decompiler new decompile: sel in: behavior. - ast := Compiler new compile: decompiled in: behavior notifying: nil ifFail: [ self error: 'failed' ]. - compiled := ast generate: (behavior compiledMethodAt: sel) trailer. - behavior addSelectorSilently: sel withMethod: compiled. ] ] ]! ! -!CodeWindow methodsFor: 'notification actions' stamp: 'jmv 1/29/2020 08:49:25' prior: 50482793! - registerNotificationActions - - SystemChangeNotifier uniqueInstance - when: #classAdded send: #updateListsAndCode to: self; - when: #classCommented send: #updateListsAndCode to: self; - when: #classDefinitionChanged send: #updateListsAndCode to: self; - when: #classRecategorized send: #updateListsAndCode to: self; - when: #classRemoved send: #updateListsAndCode to: self; - when: #classRenamed send: #classRenamed:from:to:inCategory: to: self; - when: #classReorganized send: #updateListsAndCode to: self; - when: #methodAddedInProtocol send: #updateListsAndCode to: self; - when: #methodChanged send: #updateListsAndCode to: self; - when: #methodRemoved send: #updateListsAndCode to: self; - when: #selectorRecategorized send: #updateListsAndCode to: self ! ! -!ChangeSet class methodsFor: 'class initialization' stamp: 'jmv 1/29/2020 08:49:18' prior: 50482883! - registerNotificationActions - - "Only sent when model is not nil - Hernan" - SystemChangeNotifier uniqueInstance - when: #classAdded send: #classAdded:inCategory: to: self; - when: #classCommented send: #classCommented: to: self; - when: #classDefinitionChanged send: #classDefinitionChangedFrom:to: to: self; - when: #classRecategorized send: #classRecategorized:from:to: to: self; - when: #classRemoved send: #classRemoved:fromCategory: to: self; - when: #aboutToRenameClass send: #aboutToRenameClass:from:to:inCategory: to: self; - when: #classReorganized send: #classReorganized: to: self; - when: #methodAddedInProtocol send: #methodAdded:selector:inProtocol:class:requestor: to: self; - when: #methodChanged send: #methodChangedFrom:to:selector:inClass:requestor: to: self; - when: #methodRemoved send: #methodRemoved:selector:inProtocol:class: to: self; - when: #selectorRecategorized send: #selectorRecategorized:from:to:inClass: to: self! ! -!SmalltalkCompleter class methodsFor: 'class initialization' stamp: 'jmv 1/29/2020 08:49:30' prior: 50436948! - initialize - " - It takes about 6 seconds, mostly because of the time to fetch method stamps from source files... - [ SmalltalkCompleter initialize ]timeToRun - Selectors inspect - " - | maxSortValue allImplemented | - - EntriesLimit _ 100. - - SystemChangeNotifier uniqueInstance - removeActionsWithReceiver: self. "avoid double registration" - - SystemChangeNotifier uniqueInstance - when: #classRemoved send: #classRemoved:fromCategory: to: self; - when: #methodAddedInProtocol send: #methodAdded:selector:inProtocol:class:requestor: to: self; - when: #methodRemoved send: #methodRemoved:selector:inProtocol:class: to: self. - - self protected: [ - allImplemented _ Smalltalk allImplementedMessages. - Selectors _ Trie new. - " - Smalltalk allBehaviorsDo: [:class | - class selectorsAndMethodsDo: [ :sel :method | - Selectors at: sel ifAbsentPut: [ 0 ]. - method messages do: [ :sentMsg | - Selectors at: sentMsg put: (Selectors at: sentMsg ifAbsent: [ 0 ]) + 1 ]]]. - " - Smalltalk allBehaviorsDo: [:class | - class selectorsAndMethodsDo: [ :sel :method | - self addSelector: sel method: method allImplemented: allImplemented]]. - "" - - "The following might not be found in #messages. Give them maximum priority." - maxSortValue _ SmallInteger maxVal. - "From MessageNode>>#initialize" - #( ifTrue: ifFalse: ifTrue:ifFalse: ifFalse:ifTrue: - and: or: - whileFalse: whileTrue: whileFalse whileTrue - to:do: to:by:do: - caseOf: caseOf:otherwise: - ifNil: ifNotNil: ifNil:ifNotNil: ifNotNil:ifNil:) do: [ :sel | - Selectors at: sel put: maxSortValue ]. - - maxSortValue _ SmallInteger maxVal-1. - "From SystemDictionary >>#recreateSpecialObjectsArray" - (1 to: Smalltalk specialSelectorSize) do: [ :i | | sym | - sym _ Smalltalk specialSelectorAt: i. - (Selectors includesKey: sym) - ifTrue: [ Selectors at: sym put: maxSortValue ]]]! ! - -SmalltalkCompleter class removeSelector: #methodAdded:selector:inClass:requestor:! - -!methodRemoval: SmalltalkCompleter class #methodAdded:selector:inClass:requestor: stamp: 'Install-4038-remove-methodAdded-event-JuanVuletich-2020Jan29-08h46m-jmv.1.cs.st 4/1/2020 17:57:13'! -methodAdded: aMethod selector: aSymbol inClass: aClass requestor: requestor - - self protected: [ - self addSelector: aSymbol method: aMethod allImplemented: nil ]! - -ChangeSet class removeSelector: #methodAdded:selector:inClass:requestor:! - -!methodRemoval: ChangeSet class #methodAdded:selector:inClass:requestor: stamp: 'Install-4038-remove-methodAdded-event-JuanVuletich-2020Jan29-08h46m-jmv.1.cs.st 4/1/2020 17:57:13'! -methodAdded: aCompiledMethod selector: aSymbol inClass: aClass requestor: requestor - - | packageOrNil | - - aClass wantsChangeSetLogging ifFalse: [ ^self ]. - - packageOrNil _ CodePackage packageOfMethod: aCompiledMethod methodReference ifNone: nil. - (self changeSetForPackage: packageOrNil) ifNotNil: [ :changeSet | - changeSet - methodAdded: aCompiledMethod - selector: aSymbol - inClass: aClass - requestor: requestor ]. - packageOrNil ifNotNil: [ - packageOrNil hasUnsavedChanges: true ]! - -ChangeSet removeSelector: #methodAdded:selector:inClass:requestor:! - -!methodRemoval: ChangeSet #methodAdded:selector:inClass:requestor: stamp: 'Install-4038-remove-methodAdded-event-JuanVuletich-2020Jan29-08h46m-jmv.1.cs.st 4/1/2020 17:57:13'! -methodAdded: aMethod selector: aSymbol inClass: aClass requestor: requestor - - self - noteNewMethod: aMethod - forClass: aClass - selector: aSymbol - priorMethod: nil! - -ClassDescription removeSelector: #addSelector:withMethod:notifying:! - -!methodRemoval: ClassDescription #addSelector:withMethod:notifying: stamp: 'Install-4038-remove-methodAdded-event-JuanVuletich-2020Jan29-08h46m-jmv.1.cs.st 4/1/2020 17:57:13'! -addSelector: selector withMethod: compiledMethod notifying: requestor - | priorMethodOrNil newProtocolOrNil priorProtocolOrNil | - priorMethodOrNil _ self compiledMethodAt: selector ifAbsent: nil. - priorProtocolOrNil _ self whichCategoryIncludesSelector: selector. - self addSelectorSilently: selector withMethod: compiledMethod. - newProtocolOrNil _ self whichCategoryIncludesSelector: selector. - priorMethodOrNil - ifNil: [ - SystemChangeNotifier uniqueInstance - methodAdded: compiledMethod - selector: selector - inClass: self - requestor: requestor ] - ifNotNil: [ - SystemChangeNotifier uniqueInstance - methodChangedFrom: priorMethodOrNil - to: compiledMethod - selector: selector - inClass: self - requestor: requestor. - - newProtocolOrNil = priorProtocolOrNil ifFalse: [ - SystemChangeNotifier uniqueInstance - selectorRecategorized: selector - from: priorProtocolOrNil - to: newProtocolOrNil - inClass: self ]]! - -Behavior removeSelector: #addSelector:withMethod:! - -!methodRemoval: Behavior #addSelector:withMethod: stamp: 'Install-4038-remove-methodAdded-event-JuanVuletich-2020Jan29-08h46m-jmv.1.cs.st 4/1/2020 17:57:13'! -addSelector: selector withMethod: compiledMethod - ^ self addSelector: selector withMethod: compiledMethod notifying: nil! - -Behavior removeSelector: #addSelector:withMethod:notifying:! - -!methodRemoval: Behavior #addSelector:withMethod:notifying: stamp: 'Install-4038-remove-methodAdded-event-JuanVuletich-2020Jan29-08h46m-jmv.1.cs.st 4/1/2020 17:57:13'! -addSelector: selector withMethod: compiledMethod notifying: requestor - ^ self addSelectorSilently: selector withMethod: compiledMethod! - -SystemChangeNotifier removeSelector: #methodAdded:selector:inClass:requestor:! - -!methodRemoval: SystemChangeNotifier #methodAdded:selector:inClass:requestor: stamp: 'Install-4038-remove-methodAdded-event-JuanVuletich-2020Jan29-08h46m-jmv.1.cs.st 4/1/2020 17:57:13'! -methodAdded: aMethod selector: aSymbol inClass: aClass requestor: requestor - "A method with the given selector was added to aClass, but not put in a protocol." - - self - triggerEvent: #methodAdded - withArguments: { aMethod . aSymbol . aClass . requestor }! - -SmalltalkCompleter initialize! - -ChangeSet initialize! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4038-remove-methodAdded-event-JuanVuletich-2020Jan29-08h46m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4035] on 29 January 2020 at 9:52:36 am'! -!ClassDescription methodsFor: 'compiling' stamp: 'jmv 1/29/2020 09:51:41' prior: 16806418! - compile: text classified: category withStamp: changeStamp notifying: requestor logSource: logSource - | methodAndNode | - methodAndNode _ self basicCompile: text asString notifying: requestor - trailer: self defaultMethodTrailer ifFail: [^nil]. - logSource ifTrue: [ - self logMethodSource: text forMethodWithNode: methodAndNode - inCategory: category withStamp: changeStamp notifying: requestor. - ]. - self addAndClassifySelector: methodAndNode selector withMethod: methodAndNode - method inProtocol: category notifying: requestor. - ^ methodAndNode selector! ! - -ClassDescription removeSelector: #noteCompilationOf:meta:! - -!methodRemoval: ClassDescription #noteCompilationOf:meta: stamp: 'Install-4039-noteCompilationOfmeta-removal-JuanVuletich-2020Jan29-09h03m-jmv.1.cs.st 4/1/2020 17:57:14'! -noteCompilationOf: aSelector meta: isMeta - "A hook allowing some classes to react to recompilation of certain selectors"! - -Object class removeSelector: #noteCompilationOf:meta:! - -!methodRemoval: Object class #noteCompilationOf:meta: stamp: 'Install-4039-noteCompilationOfmeta-removal-JuanVuletich-2020Jan29-09h03m-jmv.1.cs.st 4/1/2020 17:57:14'! -noteCompilationOf: aSelector meta: isMeta - "A hook allowing some classes to react to recompilation of certain selectors. - This implementor catches class methods."! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4039-noteCompilationOfmeta-removal-JuanVuletich-2020Jan29-09h03m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4035] on 29 January 2020 at 10:25:30 am'! -!Object class methodsFor: 'compiling' stamp: 'pb 1/29/2020 10:24:14'! - isOkToAddMethod: selector isMeta: isMeta - "A hook allowing some classes to disallow and/or react to addition of certain selectors before the change is committed - This implementor is only for convenience, as the method is meant to be redefined in class side as needed." - ^super isOkToAddMethod: selector isMeta: isMeta! ! -!Object class methodsFor: 'compiling' stamp: 'pb 1/29/2020 10:24:22'! - isOkToChangeMethod: selector isMeta: isMeta - "A hook allowing some classes to disallow and/or react to recompilation of certain selectors before the change is committed - This implementor is only for convenience, as the method is meant to be redefined in class side as needed." - ^super isOkToChangeMethod: selector isMeta: isMeta! ! -!Object class methodsFor: 'compiling' stamp: 'pb 1/29/2020 10:24:26'! - isOkToRemoveMethod: selector isMeta: isMeta - "A hook allowing some classes to disallow and/or react to removal of certain selectors before the change is committed - This implementor is only for convenience, as the method is meant to be redefined in class side as needed." - ^super isOkToRemoveMethod: selector isMeta: isMeta! ! -!ClassDescription methodsFor: 'compiling' stamp: 'pb 1/29/2020 10:09:40'! - isOkToAddMethod: selector isMeta: isMeta - "A hook allowing some classes to disallow and/or react to addition of certain selectors before the change is committed" - ^true! ! -!ClassDescription methodsFor: 'compiling' stamp: 'pb 1/29/2020 10:24:45'! - isOkToChangeMethod: selector isMeta: isMeta - "A hook allowing some classes to disallow and/or react to recompilation of certain selectors before the change is committed" - ^true! ! -!ClassDescription methodsFor: 'compiling' stamp: 'pb 1/29/2020 10:10:16'! - isOkToRemoveMethod: selector isMeta: isMeta - "A hook allowing some classes to disallow and/or react to removal of certain selectors before the change is committed" - ^true! ! -!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'pb 1/29/2020 10:21:42' prior: 16806248! - removeSelector: selector - | priorMethod priorProtocol | - "Remove the message whose selector is given from the method - dictionary of the receiver, if it is there. Answer nil otherwise." - - priorMethod _ self compiledMethodAt: selector ifAbsent: [^ nil]. - (self theNonMetaClass isOkToRemoveMethod: selector isMeta: self isMeta) - ifFalse: [self error: 'Method removal not allowed']. - priorProtocol _ self whichCategoryIncludesSelector: selector. - SystemChangeNotifier uniqueInstance doSilently: [ - self organization removeElement: selector]. - super removeSelector: selector. - SystemChangeNotifier uniqueInstance - methodRemoved: priorMethod selector: selector inProtocol: priorProtocol class: self.! ! -!ClassDescription methodsFor: 'compiling' stamp: 'pb 1/29/2020 10:21:23' prior: 50496290! - compile: text classified: category withStamp: changeStamp notifying: requestor logSource: logSource - | methodAndNode selector isExistingMethod | - methodAndNode _ self basicCompile: text asString notifying: requestor - trailer: self defaultMethodTrailer ifFail: [^nil]. - selector _ methodAndNode selector. - isExistingMethod _ self includesSelector: selector. - isExistingMethod - ifTrue: [ - (self theNonMetaClass isOkToChangeMethod: selector isMeta: self isMeta) - ifFalse: [self error: 'Method modification not allowed']] - ifFalse: [ - (self theNonMetaClass isOkToAddMethod: selector isMeta: self isMeta) - ifFalse: [self error: 'Method addition not allowed']]. - logSource ifTrue: [ - self logMethodSource: text forMethodWithNode: methodAndNode - inCategory: category withStamp: changeStamp notifying: requestor. - ]. - self addAndClassifySelector: selector withMethod: methodAndNode - method inProtocol: category notifying: requestor. - ^ methodAndNode selector! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4040-tracking-method-changes-globally-PhilBellalouna-2020Jan29-10h00m-pb.2.cs.st----! - -'From Cuis 5.0 [latest update: #4040] on 18 February 2020 at 11:01:29 am'! -!CodePackage methodsFor: 'listing' stamp: 'jmv 2/18/2020 11:00:34' prior: 16810099! - sortedExtensionMethodsDo: aBlock displayingProgress: aString - "Include both class and instance methods we define, for classes we don't define." - | externalClasses methods | - externalClasses _ self externalClasses. - aString - displayProgressAt: Sensor mousePoint - from: 0 to: externalClasses size - during: [ :barBlock | - externalClasses withIndexDo: [ :classOrMetaClass :i | - barBlock value: i. - methods _ Array streamContents: [ :stream | - (self extensionCategoriesForClass: classOrMetaClass) do: [ :cat | - self methodsInCategory: cat ofClass: classOrMetaClass do: [ :m | - stream nextPut: m ]]]. - methods sort: [ :a :b | - a methodSymbol < b methodSymbol ]. - methods do: aBlock. - ] - ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4041-AvoidExcessiveProgressDialogs-JuanVuletich-2020Feb18-11h00m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4034] on 2 February 2020 at 12:45:03 pm'! - -"Change Set: 4035-CuisCore-AuthorName-2020Feb02-12h37m -Date: 2 February 2020 -Author: Nahuel Garbezza - -Add an option to inspect keys on dictionaty inspector"! -!InspectorWindow methodsFor: 'menu commands' stamp: 'RNG 2/2/2020 12:44:24'! - inspectSelectedKey - - ^ model selectedKey inspect! ! -!InspectorWindow methodsFor: 'menu building' stamp: 'RNG 2/2/2020 12:41:50' prior: 50495470! - menuOptionsForDictionary - - ^ `{ - nil. - { - #label -> 'inspect key'. - #selector -> #inspectSelectedKey. - #icon -> #findIcon - } asDictionary. - { - #label -> 'senders of this key'. - #selector -> #sendersOfSelectedKey. - #icon -> #mailForwardIcon - } asDictionary. - { - #label -> 'add key'. - #selector -> #addEntry. - #icon -> #listAddIcon - } asDictionary. - { - #label -> 'rename key'. - #selector -> #renameEntry. - #icon -> #saveAsIcon - } asDictionary. - { - #label -> 'remove'. - #object -> #model. - #selector -> #removeSelection. - #icon -> #listRemoveIcon - } asDictionary. - }`! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4042-inspectKey-option-in-Dictionaries-NahuelGarbezza-2020Feb02-12h37m-RNG.1.cs.st----! - -'From Cuis 5.0 [latest update: #4042] on 19 February 2020 at 11:16:25 am'! -!SystemDictionary methodsFor: 'browsing' stamp: 'pb 2/17/2020 20:04:57'! - browseAllReferencesToLiteral: aLiteral - "Create and schedule a message browser on each method that references aLiteral. For example, - Smalltalk browseAllReferencesToLiteral: 47. - Smalltalk browseAllReferencesToLiteral: `0 @ 0`." - ^ self - browseMessageList: (self allReferencesToLiteral: aLiteral) - name: 'References to literal ' , aLiteral asString.! ! -!SystemDictionary methodsFor: 'retrieving' stamp: 'pb 2/17/2020 19:53:49'! - allReferencesToLiteral: aLiteral - | coll | - coll := OrderedCollection new. - Smalltalk allBehaviorsDo: [ :eaClass | - eaClass - addMethodsTo: coll - thatReferenceTo: aLiteral - special: false - byte: nil ]. - ^ coll.! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'pb 2/19/2020 10:58:00'! - referencesToSelectedLiteral - "Evaluate the selected text and browse methods that reference the same literal" - [ - self - evaluateSelectionAndDo: [ :result | - Smalltalk - browseMessageList: (Smalltalk allReferencesToLiteral: result) asArray sort - name: 'Users of literal: ' , result asString - autoSelect: self selection ] - ifFail: nil - profiled: false ] - on: UndeclaredVariableReference , UnknownSelector - do: [ :ex | - morph flash ]! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'pb 2/19/2020 10:55:00' prior: 50463212! - referencesToIt - "Open a references browser on the selected symbol: a variable name or class name" - - | selectedString provider environment | - - "look for exactly a whole word" - selectedString _ self selectedString withoutSeparators. - - "convenient access to class variables, including those in SharedPools" - provider _ self codeProvider. - environment _ (provider respondsTo: #selectedClassOrMetaClass) ifTrue: [ provider selectedClassOrMetaClass ]. - environment _ environment ifNil: [ Smalltalk ]. - - (environment bindingOf: selectedString) - ifNotNil: [ :reference | Smalltalk browseAllCallsOn: reference ] - ifNil: [ (environment ~= Smalltalk and: [ environment definesInstanceVariableNamedInHierarchy: selectedString ]) - ifTrue: [ Smalltalk browseAllAccessesTo: selectedString from: environment ] - ifFalse: [ self referencesToSelectedLiteral ]] - - - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4043-browse-literal-references-PhilBellalouna-2020Feb19-10h49m-pb.1.cs.st----! - -'From Cuis 5.0 [latest update: #4043] on 19 February 2020 at 12:22:13 pm'! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'jmv 2/19/2020 12:18:39' prior: 50496589! - referencesToIt - "Open a references browser on the selected symbol: a variable name or class name" - - | selectedSymbol provider environment selectedString | - self hasSelection ifFalse: [ self selectWord ]. - selectedSymbol _ self selectedSymbol. - - "convenient access to class variables, including those in SharedPools" - provider _ self codeProvider. - environment _ (provider respondsTo: #selectedClassOrMetaClass) ifTrue: [ provider selectedClassOrMetaClass ]. - environment _ environment ifNil: [ Smalltalk ]. - - (selectedSymbol ifNotNil: [environment bindingOf: selectedSymbol]) ifNotNil: [ :reference | - Smalltalk browseAllCallsOn: reference. - ^ self ]. - - selectedString _ self selectedString withoutSeparators. - (environment ~= Smalltalk and: [ environment definesInstanceVariableNamedInHierarchy: selectedString ]) ifTrue: [ - Smalltalk browseAllAccessesTo: selectedString from: environment. - ^ self ]. - - self referencesToSelectedLiteral! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4044-FixReferencesToGlobalNames-JuanVuletich-2020Feb19-12h21m-jmv.1.cs.st----! - -'From Cuis 5.0 [latest update: #4044] on 19 February 2020 at 12:57:24 pm'! -!SequenceableCollection methodsFor: 'accessing' stamp: 'EB 1/27/2020 19:50:15'! - lastIndexOf: anElement startingAt: lastIndex endingAt: firstIndex 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: lastIndex endingAt: firstIndex do: [ :index | ^index ]. - ^exceptionBlock value.! ! -!Parser methodsFor: 'error correction' stamp: 'EB 1/27/2020 02:36:44'! - createEmptyTempsDeclarationAfter: aDeclarationPosition - "Return the position of the end of the declaration." - | offset | - - offset := self insertWord: ' | |' at: aDeclarationPosition + 1. - ^aDeclarationPosition + offset! ! -!Parser methodsFor: 'error correction' stamp: 'EB 1/27/2020 03:01:19'! - createEmptyTempsDeclarationIfNecessaryIn: aBlockNode - "Return the new tempsMark for this BlockNode" - | blockTempsMark | - - blockTempsMark := aBlockNode tempsMark + requestorOffset. - (self hasNoTempDeclarationPipes: aBlockNode) ifTrue: [ - blockTempsMark := self createEmptyTempsDeclarationAfter: blockTempsMark ]. - ^blockTempsMark! ! -!Parser methodsFor: 'error correction' stamp: 'EB 1/27/2020 02:39:26'! - declareUndeclaredTemps: undeclaredTempNodes inBlock: aDeclaringBlockNode - - | blockTempsMark | - - blockTempsMark := self createEmptyTempsDeclarationIfNecessaryIn: aDeclaringBlockNode. - undeclaredTempNodes do: [ :varName | blockTempsMark := self pasteTemp: varName before: blockTempsMark ]! ! -!Parser methodsFor: 'error correction' stamp: 'EB 1/27/2020 20:18:18'! - hasNoTempDeclarationPipes: aBlockNode - "Determine if a BlockNode already has the '| |' used to declare temps." - | blockTempsMark sourceCode hasNoTemps | - - sourceCode := requestor text string. - blockTempsMark := aBlockNode tempsMark + requestorOffset. - hasNoTemps := aBlockNode temporaries isEmpty. - ^hasNoTemps and: [ (self isLastPipeOfEmptyTempsDeclaration: blockTempsMark) not ].! ! -!Parser methodsFor: 'error correction' stamp: 'EB 1/27/2020 20:19:48'! - isLastPipeOfEmptyTempsDeclaration: pipeIndex - - | indexOfPreviousPipe sourceCode | - - sourceCode := requestor text string. - indexOfPreviousPipe := sourceCode lastIndexOf: $| startingAt: pipeIndex - 1 endingAt: 1 ifAbsent: [ ^false ]. - ^(sourceCode at: pipeIndex) = $| and: [ - (sourceCode copyFrom: indexOfPreviousPipe + 1 to: pipeIndex - 1) allSatisfy: [ :char | char isSeparator ]]! ! -!Parser methodsFor: 'error correction' stamp: 'EB 1/27/2020 02:16:43' prior: 50486055! - declareUndeclaredTemps: methodNode - "Declare any undeclared temps, declaring them at the smallest enclosing scope." - | undeclared userSelection blocksToVars | - (undeclared _ encoder undeclaredTemps) isEmpty ifTrue: [ ^ self ]. - userSelection _ requestor selectionInterval. - blocksToVars _ IdentityDictionary new. - undeclared do: [ :var | - (blocksToVars - at: (var tag == #method - ifTrue: [ methodNode block ] - ifFalse: [ methodNode accept: (VariableScopeFinder new ofVariable: var) ]) - ifAbsentPut: [ SortedCollection new ]) add: var name ]. - (blocksToVars removeKey: methodNode block ifAbsent: nil) ifNotNil: [ :rootVars | - rootVars do: [ :varName | - self pasteTempAtMethodLevel: varName ]]. - (blocksToVars keys sort: [ :a :b | - a tempsMark < b tempsMark ]) do: [ :block | | blockUndeclaredVars | - blockUndeclaredVars := blocksToVars at: block. - self declareUndeclaredTemps: blockUndeclaredVars inBlock: block ]. - requestor - selectInvisiblyFrom: userSelection first - to: userSelection last + requestorOffset. - ReparseAfterSourceEditing signal! ! - -Parser removeSelector: #pasteTemp:inBlock:! - -!methodRemoval: Parser #pasteTemp:inBlock: stamp: 'Install-4045-DeclareUndeclaredWithBlockArgumentsFix-EricBrandwein-2020Feb19-12h55m-EB.1.cs.st 4/1/2020 17:57:14'! -pasteTemp: tempName inBlock: aBlockNode - - | theTextString blockTempsMark | - - theTextString := requestor text string. - blockTempsMark := aBlockNode tempsMark + requestorOffset. - - (theTextString at: blockTempsMark) = $| - ifTrue: [ - "Paste it before the second vertical bar" - self pasteTemp: tempName before: blockTempsMark ] - ifFalse: [ - "The tempsMark is at the beginning of the block, we should insert after it." - self createTempDeclarationInBlockWith: tempName before: blockTempsMark ].! - -Parser removeSelector: #createTempDeclarationInBlockWith:before:! - -!methodRemoval: Parser #createTempDeclarationInBlockWith:before: stamp: 'Install-4045-DeclareUndeclaredWithBlockArgumentsFix-EricBrandwein-2020Feb19-12h55m-EB.1.cs.st 4/1/2020 17:57:14'! -createTempDeclarationInBlockWith: tempName before: aTempsMark - "Return the new tempsMark." - - | delta insertion offset | - - insertion := ' | ' , tempName , ' |'. - delta := 1. "the bar" - offset := self insertWord: insertion at: aTempsMark + 1. - - ^aTempsMark + offset - delta.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4045-DeclareUndeclaredWithBlockArgumentsFix-EricBrandwein-2020Feb19-12h55m-EB.1.cs.st----! - -'From Cuis 5.0 [latest update: #4045] on 21 February 2020 at 12:41:15 am'! -!Integer methodsFor: 'printing' stamp: 'jmv 2/20/2020 16:52:31' prior: 50342176! - printOn: aStream length: minimum zeroPadded: zeroFlag - " - 7 printOn: Transcript length: 4 zeroPadded: true. Transcript newLine. - " - self printOn: aStream base: 10 length: minimum padded: zeroFlag! ! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'jmv 2/20/2020 16:51:14' prior: 50405760! - assureStartupStampLogged - "If there is a startup stamp not yet actually logged to disk, do it now." - | changesFile directory oldUserChanges oldUserChangesName | - StartupStamp ifNil: [^ self]. - (SourceFiles notNil and: [(changesFile _ SourceFiles at: 2) notNil]) ifTrue: [ - changesFile isReadOnly ifFalse: [ - changesFile setToEnd; newLine; newLine. - changesFile nextChunkPut: StartupStamp asString; newLine. - self forceChangesToDisk ]]. - oldUserChanges _ Smalltalk defaultUserChangesName asFileEntry. - oldUserChanges exists ifTrue: [ - directory _ oldUserChanges parent. - oldUserChangesName _ directory nextNameFor: oldUserChanges nameWithoutExtension extension: 'changes'. - oldUserChanges rename: oldUserChangesName ]. - Smalltalk defaultUserChangesName asFileEntry appendStreamDo: [ :stream | - stream newLine; newLine. - stream nextChunkPut: StartupStamp asString; newLine ]. - StartupStamp _ nil! ! -!FileIOAccessor methodsFor: 'utilities' stamp: 'jmv 2/20/2020 16:40:54' prior: 16842049! - splitNameVersionExtensionFor: fileName - " answer an array with the root name, version # and extension. - See comment in senders for more details" - - | baseName version i j | - self baseNameAndExtensionFor: fileName do: [ :b :extension | - baseName _ b. - i := j := baseName findLast: [:c | c isDigit not]. - i = 0 - ifTrue: [version := 0] - ifFalse: [ - (baseName at: i) = $. - ifTrue: [ - version := (baseName copyFrom: i+1 to: baseName size) asNumber. - j := j - 1] - ifFalse: [version := 0]. - baseName := baseName copyFrom: 1 to: j ]. - ^ Array with: baseName with: version with: extension ]! ! -!DirectoryEntry methodsFor: 'services' stamp: 'jmv 2/21/2020 00:38:45' prior: 16834728! -nextNameFor: baseFileName coda: fileNameCoda extension: extension - "Assumes a file name includes a version number encoded as '.' followed by digits - preceding the file extension. Increment the version number and answer the new file name. - If a version number is not found, set the version to 1 and answer a new file name. - fileNameCoda is ignored during version number search, but added to the final name. It allows sequences like: - someFileName-authorXX.cs - someFileName-authorYY.1.cs - someFileName-authorZZ.2.cs - " - - | files splits version candidate | - files _ self fileNamesMatching: (baseFileName,'*.', extension). - splits _ files collect: [ :file | self fileAccessor splitNameVersionExtensionFor: file ]. - splits _ splits asArray sort: [ :a :b | (a at: 2) < (b at: 2)]. - splits isEmpty - ifTrue: [ version _ 1 ] - ifFalse: [ version _ (splits last at: 2) + 1 ]. - candidate _ (baseFileName, fileNameCoda, '.', (String streamContents: [ :strm | version printOn: strm length: 3 zeroPadded: true ]), '.', extension) asFileName. - ^ candidate! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4046-SequentialUserChangesFiles-JuanVuletich-2020Feb20-16h38m-jmv.008.cs.st----! - -'From Cuis 5.0 [latest update: #4046] on 21 February 2020 at 1:29:11 pm'! -!IdentitySet methodsFor: 'accessing' stamp: 'jmv 2/21/2020 12:47:37'! - elementForIdentityHash: aNumber - "Answer any element matching argument. - Answer nil if none found" - | finish scale index element | - finish _ array size. - scale _ finish // (Smalltalk maxIdentityHash + 1). - scale = 0 ifTrue: [scale _ 1]. - index _ aNumber * scale \\ finish + 1. - - element _ array at: index. - ^element identityHash = aNumber ifTrue: [ element ]! ! -!WeakIdentitySet methodsFor: 'accessing' stamp: 'jmv 2/21/2020 12:50:06'! - elementForIdentityHash: aNumber - "Answer any element matching argument. - Answer nil if none found" - | finish scale index element | - finish _ array size. - scale _ finish // (Smalltalk maxIdentityHash + 1). - scale = 0 ifTrue: [scale _ 1]. - index _ aNumber * scale \\ finish + 1. - - element _ array at: index. - element == flag ifTrue: [ ^ nil ]. - ^element identityHash = aNumber ifTrue: [ element ]! ! -!ProtoObject methodsFor: 'comparing' stamp: 'jmv 2/21/2020 11:02:26' prior: 16896484! - identityHash - "Answer a SmallInteger whose value is related to the receiver's identity. - This method must not be overridden, except by immediate classes such as SmallInteger, - and in Spur systems, Character and SmallFloat64. - Primitive. Fails if the receiver is a SmallInteger. Essential. - See Object documentation whatIsAPrimitive. - - Do not override." - - - self primitiveFailed! ! -!Set methodsFor: 'private' stamp: 'jmv 2/21/2020 12:39:07' prior: 16907261! - keyAt: index - "May be overridden by subclasses so that fixCollisionsFrom: will work" - ^ array at: index! ! -!Set methodsFor: 'private' stamp: 'jmv 2/21/2020 12:39:37' prior: 16907302! - swap: oneIndex with: otherIndex - "May be overridden by subclasses so that fixCollisionsFrom: will work" - - array swap: oneIndex with: otherIndex -! ! -!Dictionary methodsFor: 'private' stamp: 'jmv 2/21/2020 12:39:24' prior: 16833748! - keyAt: index - "May be overridden by subclasses so that fixCollisionsFrom: will work" - | assn | - assn _ array at: index. - assn ifNil: [^ nil]. - ^ assn key! ! -!IdentityDictionary methodsFor: 'private' stamp: 'jmv 2/21/2020 12:33:35' prior: 16853954! - 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 scale start element | - finish _ array size. - scale _ finish // (Smalltalk maxIdentityHash + 1). - scale = 0 ifTrue: [scale _ 1]. - start _ anObject identityHash * scale \\ 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"! ! -!WeakIdentityKeyDictionary methodsFor: 'private' stamp: 'jmv 2/21/2020 12:33:40' prior: 16943757! - 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." - | finish scale start element | - finish _ array size. - scale _ finish // (Smalltalk maxIdentityHash + 1). - scale = 0 ifTrue: [scale _ 1]. - start _ anObject identityHash * scale \\ 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"! ! -!WeakIdentityKeyDictionary methodsFor: 'private' stamp: 'jmv 2/21/2020 12:33:43' prior: 16943793! - scanForNil: anObject - "Private. Scan the key array for the first slot containing nil (indicating an empty slot). Answer the index of that slot." - - | finish scale start | - finish _ array size. - scale _ finish // (Smalltalk maxIdentityHash + 1). - scale = 0 ifTrue: [scale _ 1]. - start _ anObject identityHash * scale \\ finish + 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"! ! -!IdentitySet methodsFor: 'private' stamp: 'jmv 2/21/2020 12:33:27' prior: 16854018! - 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 scale start element | - finish _ array size. - scale _ finish // (Smalltalk maxIdentityHash + 1). - scale = 0 ifTrue: [scale _ 1]. - start _ anObject identityHash * scale \\ 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"! ! -!WeakIdentitySet methodsFor: 'private' stamp: 'jmv 2/21/2020 12:33:47' prior: 16943822! - 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 scale start element | - finish _ array size. - scale _ finish // (Smalltalk maxIdentityHash + 1). - scale = 0 ifTrue: [scale _ 1]. - start _ anObject identityHash * scale \\ 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"! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -IdentityDictionary allInstancesDo: [ :d | d rehash ]. -IdentitySet allInstancesDo: [ :d | d rehash ]. -WeakIdentityKeyDictionary allInstancesDo: [ :d | d rehash ]. -WeakIdentitySet allInstancesDo: [ :d | d rehash ].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4047-UseAllBitsOfIdentityHash-JuanVuletich-2020Feb21-11h02m-jmv.009.cs.st----! - -'From Cuis 5.0 [latest update: #4045] on 24 February 2020 at 11:53:19 pm'! - -"Change Set: 4046-CuisCore-AuthorName-2020Feb20-08h41m -Date: 24 February 2020 -Author: Nahuel Garbezza - -Refactorings and additions on Refactorings package: - -* Cleanups on extract method helpers -* Extract new temporary validations to a separate class (helpful for the upcoming ExtractToTemporary) -* Add some class comments"! -!ArgumentDeclarationCounter commentStamp: '' prior: 0! - I am responsible for counting the times an argument name appears in different block nodes across a method node.! -!ExtractMethodExpressionValidation commentStamp: '' prior: 0! - I check if an expression selected for extract method can be actually extracted. - -Many conditions have to happen: -* we are selecting from the beginning of an AST node to an end of an AST node -* it is a smalltalk expression, a single statement or a sequence of complete statements -* the expression does not contain returns, or temporary variable assignments! -!Refactoring commentStamp: 'RNG 2/24/2020 23:36:38' prior: 0! - I am a refactoring, a code transformation preserving behavior, based on some input (provided from the end user through a RefactoringApplier; or provided programmatically). Instances of me have usually only public method, #apply, which does all the work. - -In case the refactoring cannot be made, or there is a problem during the application of it, I can throw errors using the class message #refactoringError:, or warnings using the class message #refactoringWarning:! -!AddInstanceVariable commentStamp: 'RNG 2/24/2020 23:37:30' prior: 0! - I can add a new instance variable to a class. Input parameters are: - -* name of the new variable -* class to add that variable! -!ChangeSelector commentStamp: 'RNG 2/24/2020 23:38:29' prior: 0! - I am a refactoring abstract class whose purpose is to change a given selector; either by renaming it or changing arguments (adding, removing, change order)! -!AddParameter commentStamp: 'RNG 2/24/2020 23:43:14' prior: 0! - I am a refactoring that adds a new parameter to a given selector (that has to be a unary or keyword). The input is the following: - -* the new parameter name -* the selector that is going to be modified -* the position of the new parameter in the selector -* the keyword for the new parameter -* the default value for senders of this message -* the collection of implementors affected by the change -* the collection of senders affected by the change! -!ExtractMethod commentStamp: 'RNG 2/24/2020 23:48:02' prior: 0! - I am a refactoring that extracts a selected piece of code to a separate method. The input is the following: - -* interval of code to extract (from index - to index) -* the CompiledMethod where this change applies -* the new method selector + argument names (instance of Message) -* the category name for the new method - -Many conditions have to be satisfied for this refactoring to be made, I delegate into ExtractMethodExpressionValidation and ExtractMethodNewSelectorPrecondition some of these checks. Refer to the class comment of those classes for more information.! - -RefactoringPrecondition subclass: #NewTemporaryPrecondition - instanceVariableNames: 'newTemporaryVariableName methodNode blockNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #NewTemporaryPrecondition category: #'Tools-Refactoring' stamp: 'Install-4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st 4/1/2020 17:57:14'! -RefactoringPrecondition subclass: #NewTemporaryPrecondition - instanceVariableNames: 'newTemporaryVariableName methodNode blockNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!NewTemporaryPrecondition commentStamp: '' prior: 0! - I am responsible for checking if a new temporary variable can be introduced in a specific block node of a method. If that is not possible, I raise a refactoring error.! -!RenameTemporary class methodsFor: 'pre-conditions' stamp: 'RNG 2/23/2020 20:55:30'! - newTemporaryPreconditionClass - - ^ NewTemporaryPrecondition! ! -!RefactoringPrecondition methodsFor: 'evaluating' stamp: 'RNG 2/24/2020 23:51:09'! - value - - self subclassResponsibility! ! -!NewTemporaryPrecondition methodsFor: 'private' stamp: 'RNG 2/23/2020 21:36:35'! - isDeclaredInAnyOf: someBlockOrMethodNodes - - ^ someBlockOrMethodNodes anySatisfy: [ :node | node hasLocallyArgumentOrTemporaryNamed: newTemporaryVariableName ]! ! -!NewTemporaryPrecondition methodsFor: 'private' stamp: 'RNG 2/23/2020 21:33:07'! - isDeclaredInChildrenOfBlockNode - - blockNode nodesDo: [ :node | - (node isBlockNode and: [ node hasLocallyArgumentOrTemporaryNamed: newTemporaryVariableName ]) ifTrue: [ ^ true ] ]. - - ^ false! ! -!NewTemporaryPrecondition methodsFor: 'private' stamp: 'RNG 2/23/2020 21:35:53'! - isDeclaredInParentsOfBlockNode - - | parents | - parents _ (BlockNodeParentsFinder for: blockNode) parentsIn: methodNode. - parents add: methodNode. - ^ self isDeclaredInAnyOf: parents! ! -!NewTemporaryPrecondition methodsFor: 'evaluating' stamp: 'RNG 2/23/2020 21:33:58'! - value - - self - assertIsNotEmpty; - assertIsValidVariableName; - assertIsNotDefinedAsInstanceVariableInHierarchyOfMethodClass; - assertIsNotDeclaredInParentsOrChildrenScopes! ! -!NewTemporaryPrecondition methodsFor: 'initialization' stamp: 'RNG 2/23/2020 21:41:48'! - initializeFor: aNewTemporaryVariableName in: aBlockNode of: aMethodNode - - newTemporaryVariableName _ aNewTemporaryVariableName. - blockNode _ aBlockNode. - methodNode _ aMethodNode! ! -!NewTemporaryPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 2/23/2020 21:33:58'! - assertIsNotDeclaredInParentsOrChildrenScopes - - (self isDeclaredInChildrenOfBlockNode or: [ self isDeclaredInParentsOfBlockNode ]) - ifTrue: [ self signalNewTemporaryVariableisAlreadyDefined ]! ! -!NewTemporaryPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 2/23/2020 20:36:51'! - assertIsNotDefinedAsInstanceVariableInHierarchyOfMethodClass - - | classDefiningNewVariable | - - classDefiningNewVariable _ methodNode methodClass - whichClassDefinesInstanceVariable: newTemporaryVariableName ifNone: [ ^ self ]. - - self signalNewVariableCanNotHideInstanceVariableDefinedIn: classDefiningNewVariable! ! -!NewTemporaryPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 2/22/2020 22:15:22'! - assertIsNotEmpty - - newTemporaryVariableName isEmpty ifTrue: [ self signalNewVariableCanNotBeEmpty ]! ! -!NewTemporaryPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 2/23/2020 20:32:31'! - assertIsValidVariableName - - | scannedNames | - scannedNames _ Scanner new scanFieldNames: newTemporaryVariableName. - scannedNames size = 1 ifFalse: [ self signalInvalidTemporaryVariable ]. - scannedNames first = newTemporaryVariableName ifFalse: [ self signalInvalidTemporaryVariable ].! ! -!NewTemporaryPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 2/23/2020 21:38:31'! - signalNewTemporaryVariableisAlreadyDefined - - self refactoringError: ( - self class - errorMessageForNewTemporaryVariable: newTemporaryVariableName - isAlreadyDefinedIn: methodNode)! ! -!NewTemporaryPrecondition methodsFor: 'exceptions' stamp: 'RNG 2/23/2020 20:39:23'! - signalInvalidTemporaryVariable - - self refactoringError: (self class errorMessageForInvalidTemporaryVariable: newTemporaryVariableName)! ! -!NewTemporaryPrecondition methodsFor: 'exceptions' stamp: 'RNG 2/23/2020 20:23:57'! - signalNewVariableCanNotBeEmpty - - self refactoringError: self class errorMessageForEmptyTemporaryVariable! ! -!NewTemporaryPrecondition methodsFor: 'exceptions' stamp: 'RNG 2/23/2020 20:39:02'! - signalNewVariableCanNotHideInstanceVariableDefinedIn: aClass - - self refactoringError: ( - self class - errorMessageFor: newTemporaryVariableName - canNotBeNamedAsInstanceVariableDefinedIn: aClass)! ! -!NewTemporaryPrecondition class methodsFor: 'evaluating' stamp: 'RNG 2/23/2020 21:42:24'! - valueFor: aNewTemporaryVariableName in: aBlockNode of: aMethodNode - - ^ (self for: aNewTemporaryVariableName in: aBlockNode of: aMethodNode) value! ! -!NewTemporaryPrecondition class methodsFor: 'instance creation' stamp: 'RNG 2/23/2020 21:41:24'! - for: aNewTemporaryVariableName in: aBlockNode of: aMethodNode - - ^ self new initializeFor: aNewTemporaryVariableName in: aBlockNode of: aMethodNode! ! -!NewTemporaryPrecondition class methodsFor: 'error messages' stamp: 'RNG 2/23/2020 20:39:50'! - errorMessageFor: aNewVariable canNotBeNamedAsInstanceVariableDefinedIn: aClass - - ^ aNewVariable, ' can not be named as instance variable defined in ', aClass name! ! -!NewTemporaryPrecondition class methodsFor: 'error messages' stamp: 'RNG 2/23/2020 20:23:44'! - errorMessageForEmptyTemporaryVariable - - ^ 'New variable can not be empty'! ! -!NewTemporaryPrecondition class methodsFor: 'error messages' stamp: 'RNG 2/22/2020 22:21:57'! - errorMessageForInvalidTemporaryVariable: aName - - ^ '''' , aName , ''' is not a valid temporary variable name'! ! -!NewTemporaryPrecondition class methodsFor: 'error messages' stamp: 'RNG 2/23/2020 21:38:55'! - errorMessageForNewTemporaryVariable: aNewVariable isAlreadyDefinedIn: aMethodNode - - ^ aNewVariable , ' is already defined in ' , aMethodNode classAndSelector! ! -!Encoder methodsFor: 'source mapping' stamp: 'RNG 2/20/2020 08:41:40' prior: 50488556! - parseNodesPathAt: aPosition using: completeSourceRanges ifAbsent: aBlockClosure - - | nodesWithRangeAtPosition | - nodesWithRangeAtPosition _ SortedCollection sortBlock: [ :nodePathOne :nodePathTwo | - nodePathOne value first >= nodePathTwo value first and: [ - nodePathOne value last <= nodePathTwo value last ] ]. - - completeSourceRanges associationsDo: [ :nodeAtRange | - self withRangesOf: nodeAtRange including: aPosition do: [ :aRange | - nodesWithRangeAtPosition add: (nodeAtRange key -> aRange) ] ]. - - ^ nodesWithRangeAtPosition - ifEmpty: aBlockClosure - ifNotEmpty: [ nodesWithRangeAtPosition ]! ! -!MessageNode methodsFor: 'source ranges' stamp: 'RNG 2/22/2020 20:42:15' prior: 50495123! - expandRanges: aSourceRange basedOn: sourceRanges using: sourceCode - - | receiverExpandedRanges expandedRangeWithReceiver | - receiverExpandedRanges _ self isCascade - ifTrue: [ self flag: #RNG . aSourceRange ] "fix source ranges for cascade messages" - ifFalse: [ receiver expandRanges: (self receiverSourceRangesFrom: sourceRanges) basedOn: sourceRanges using: sourceCode ]. - expandedRangeWithReceiver _ self - expandRange: (aSourceRange isInterval ifTrue: [ aSourceRange ] ifFalse: [ aSourceRange first ]) - basedOn: receiverExpandedRanges. - ^ super - expandRanges: expandedRangeWithReceiver - basedOn: expandedRangeWithReceiver - using: sourceCode! ! -!RenameTemporary class methodsFor: 'instance creation' stamp: 'RNG 2/23/2020 21:46:34' prior: 50487577! - fromOldVariableNode: anOldVariableNode to: aNewVariable in: aMethodNode - - | trimmedNewVariable blockNode | - - trimmedNewVariable := aNewVariable withBlanksTrimmed. - - self assertIsArgOrTempNode: anOldVariableNode. - self assert: anOldVariableNode isPartOf: aMethodNode. - - blockNode _ self blockNodeDeclaringTempNode: anOldVariableNode in: aMethodNode. - self newTemporaryPreconditionClass valueFor: trimmedNewVariable in: blockNode of: aMethodNode. - - ^ self new initializeFromOldVariableNode: anOldVariableNode to: trimmedNewVariable in: aMethodNode -! ! - -RenameTemporary class removeSelector: #errorMessageForInvalidTemporaryVariable:! - -!methodRemoval: RenameTemporary class #errorMessageForInvalidTemporaryVariable: stamp: 'Install-4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st 4/1/2020 17:57:14'! -errorMessageForInvalidTemporaryVariable: aName - - ^ '''' , aName , ''' is not a valid temporary variable name'.! - -RenameTemporary class removeSelector: #assertIsValidVariableName:! - -!methodRemoval: RenameTemporary class #assertIsValidVariableName: stamp: 'Install-4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st 4/1/2020 17:57:14'! -assertIsValidVariableName: aName - - | scannedNames | - - scannedNames _ Scanner new scanFieldNames: aName. - scannedNames size = 1 ifFalse: [ self signalInvalidTemporaryVariable: aName ]. - scannedNames first = aName ifFalse: [ self signalInvalidTemporaryVariable: aName ].! - -RenameTemporary class removeSelector: #assertIsNotEmpty:! - -!methodRemoval: RenameTemporary class #assertIsNotEmpty: stamp: 'Install-4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st 4/1/2020 17:57:14'! -assertIsNotEmpty: aNewVariable - - aNewVariable isEmpty ifTrue: [ self signalNewVariableCanNotBeEmpty ]! - -RenameTemporary class removeSelector: #signalNewVariableCanNotBeEmpty! - -!methodRemoval: RenameTemporary class #signalNewVariableCanNotBeEmpty stamp: 'Install-4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st 4/1/2020 17:57:14'! -signalNewVariableCanNotBeEmpty - - self refactoringError: self newVariableCanNotBeEmptyErrorMessage! - -RenameTemporary class removeSelector: #assert:isNotDeclaredInParseTreeBranchOfNodeDeclaring:in:! - -!methodRemoval: RenameTemporary class #assert:isNotDeclaredInParseTreeBranchOfNodeDeclaring:in: stamp: 'Install-4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st 4/1/2020 17:57:14'! -assert: aTempName isNotDeclaredInParseTreeBranchOfNodeDeclaring: aTempNode in: aMethodNode - - | blockNode | - - blockNode := self blockNodeDeclaringTempNode: aTempNode in: aMethodNode. - ((self is: aTempName declaredInChildrenOf: blockNode) or: [ - self is: aTempName declaredInParentsOf: blockNode in: aMethodNode ]) - ifTrue: [ self signalNewTemporaryVariable: aTempName isAlreadyDefinedIn: aMethodNode ].! - -RenameTemporary class removeSelector: #signalNewTemporaryVariable:isAlreadyDefinedIn:! - -!methodRemoval: RenameTemporary class #signalNewTemporaryVariable:isAlreadyDefinedIn: stamp: 'Install-4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st 4/1/2020 17:57:14'! -signalNewTemporaryVariable: aNewVariable isAlreadyDefinedIn: aMethodNode - - self refactoringError: (self errorMessageForNewTemporaryVariable: aNewVariable isAlreadyDefinedIn: aMethodNode )! - -RenameTemporary class removeSelector: #is:declaredInParentsOf:in:! - -!methodRemoval: RenameTemporary class #is:declaredInParentsOf:in: stamp: 'Install-4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st 4/1/2020 17:57:14'! -is: aTempName declaredInParentsOf: aBlockNode in: aMethodNode - - | parents | - - parents := (BlockNodeParentsFinder for: aBlockNode) parentsIn: aMethodNode. - parents add: aMethodNode. - ^self any: parents declaresTempNamed: aTempName! - -RenameTemporary class removeSelector: #signal:canNotHideInstanceVariableDefinedIn:! - -!methodRemoval: RenameTemporary class #signal:canNotHideInstanceVariableDefinedIn: stamp: 'Install-4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st 4/1/2020 17:57:14'! -signal: aNewVariable canNotHideInstanceVariableDefinedIn: aClass - - self refactoringError: (self errorMessageFor: aNewVariable canNotBeNamedAsInstanceVariableDefinedIn: aClass)! - -RenameTemporary class removeSelector: #is:declaredInChildrenOf:! - -!methodRemoval: RenameTemporary class #is:declaredInChildrenOf: stamp: 'Install-4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st 4/1/2020 17:57:14'! -is: aTempName declaredInChildrenOf: aBlockNode - - aBlockNode nodesDo: [ :node | - (node isBlockNode and: [ node hasLocallyArgumentOrTemporaryNamed: aTempName ]) ifTrue: [^true]]. - - ^false! - -RenameTemporary class removeSelector: #errorMessageFor:canNotBeNamedAsInstanceVariableDefinedIn:! - -!methodRemoval: RenameTemporary class #errorMessageFor:canNotBeNamedAsInstanceVariableDefinedIn: stamp: 'Install-4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st 4/1/2020 17:57:14'! -errorMessageFor: aNewVariable canNotBeNamedAsInstanceVariableDefinedIn: aClass - - ^aNewVariable, ' can not be named as instance variable defined in ', aClass name! - -RenameTemporary class removeSelector: #any:declaresTempNamed:! - -!methodRemoval: RenameTemporary class #any:declaresTempNamed: stamp: 'Install-4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st 4/1/2020 17:57:14'! -any: someBlockOrMethodNodes declaresTempNamed: aTempName - - ^someBlockOrMethodNodes anySatisfy: [ :node | node hasLocallyArgumentOrTemporaryNamed: aTempName]! - -RenameTemporary class removeSelector: #assert:isNotDefinedAsInstanceVariableInHierarchyOf:! - -!methodRemoval: RenameTemporary class #assert:isNotDefinedAsInstanceVariableInHierarchyOf: stamp: 'Install-4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st 4/1/2020 17:57:14'! -assert: aNewVariable isNotDefinedAsInstanceVariableInHierarchyOf: aClass - - | classDefiningNewVariable | - - classDefiningNewVariable := aClass whichClassDefinesInstanceVariable: aNewVariable ifNone: [ ^self ]. - self signal: aNewVariable canNotHideInstanceVariableDefinedIn: classDefiningNewVariable ! - -RenameTemporary class removeSelector: #signalInvalidTemporaryVariable:! - -!methodRemoval: RenameTemporary class #signalInvalidTemporaryVariable: stamp: 'Install-4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st 4/1/2020 17:57:15'! -signalInvalidTemporaryVariable: aName - - ^ self refactoringError: (self errorMessageForInvalidTemporaryVariable: aName).! - -RenameTemporary class removeSelector: #newVariableCanNotBeEmptyErrorMessage! - -!methodRemoval: RenameTemporary class #newVariableCanNotBeEmptyErrorMessage stamp: 'Install-4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st 4/1/2020 17:57:15'! -newVariableCanNotBeEmptyErrorMessage - - ^'New variable can not be empty'! - -RenameTemporary class removeSelector: #errorMessageForNewTemporaryVariable:isAlreadyDefinedIn:! - -!methodRemoval: RenameTemporary class #errorMessageForNewTemporaryVariable:isAlreadyDefinedIn: stamp: 'Install-4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st 4/1/2020 17:57:15'! -errorMessageForNewTemporaryVariable: aNewVariable isAlreadyDefinedIn: aMethodNode - - ^aNewVariable, ' is already defined in ', aMethodNode classAndSelector ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4048-CuisCore-NahuelGarbezza-2020Feb20-08h41m-RNG.1.cs.st----! - -'From Cuis 5.0 [latest update: #4047] on 25 February 2020 at 12:09:20 am'! - -"Change Set: 4048-CuisCore-AuthorName-2020Feb25-00h08m -Date: 25 February 2020 -Author: Nahuel Garbezza - -Remove old and unused implementation of the extract to temporary refactoring"! - -Smalltalk removeClassNamed: #ExtractToTemporary! - -!classRemoval: #ExtractToTemporary stamp: 'Install-4049-CuisCore-NahuelGarbezza-2020Feb25-00h08m-RNG.001.cs.st 4/1/2020 17:57:15'! -Refactoring subclass: #ExtractToTemporary - instanceVariableNames: 'newVariable parseNodeToExtract methodNodeToRefactor newTemporary' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4049-CuisCore-NahuelGarbezza-2020Feb25-00h08m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4049] on 29 February 2020 at 6:14:13 pm'! -!Parser methodsFor: 'expression types' stamp: 'HAW 2/29/2020 18:10:55' prior: 50409582! - variable - - ^self advanceWithRangeDo: [ :variableName :range | | varName result rightRange | - varName := variableName. - - "See ParserTest>>#testRangesAreOkWhenReturningAVariableWithoutSpaceAfterThat - There is a very difficult bug to fix. It happends when the source code ends with a return of a variable of - one char an no other char after that, for example: '^a' - In that case the range includes the ^ that is incorrect and makes the rename temporary fail. - I do this fix becuase changing how the range is calculated is almost imposible due to the coupling - and complexity of the parser. This change applies only to variables and therefore it assures no - unexpected behavior. I'm not cheching for size = 1 because it is redundant - Hernan" - rightRange := varName size = range size - ifTrue: [ range ] - ifFalse: [ range last - varName size + 1 to: range last ]. - - [result _ encoder encodeVariable: varName sourceRange: rightRange ifUnknown: [ nil ]. - result ifNil: [ - result _ (UndeclaredVariableReference new) - parser: self; - varName: varName; - varStart: rightRange first; - varEnd: rightRange last; - signal ]. - result isString ] whileTrue: [ varName _ result]. - encoder addMultiRange: rightRange for: result ]. - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4050-Parser-variableRangeFix-HernanWilkinson-2020Feb29-18h10m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4047] on 28 February 2020 at 12:34:49 pm'! -!FloatArray methodsFor: 'accessing' stamp: 'jmv 2/28/2020 12:09:11'! - floatAt: index - - ^Float fromIEEE32Bit: (self basicAt: index)! ! -!FloatArray methodsFor: 'accessing' stamp: 'jmv 2/28/2020 12:09:39'! - floatAt: index put: value - - value isFloat - ifTrue: [self basicAt: index put: value asIEEE32BitWord] - ifFalse: [self floatAt: index put: value asFloat]. - ^value! ! -!IntegerArray methodsFor: 'accessing' stamp: 'jmv 2/28/2020 12:22:43'! - integerAt: index - "Return the integer at the given index" - | word | - - word _ self basicAt: index. - word < 16r3FFFFFFF ifTrue:[^word]. "Avoid LargeInteger computations" - ^word >= 16r80000000 "Negative?!!" - ifTrue:["word - 16r100000000" - (word bitInvert32 + 1) negated] - ifFalse:[word]! ! -!IntegerArray methodsFor: 'accessing' stamp: 'jmv 2/28/2020 12:24:33'! - integerAt: index put: anInteger - "Store the integer at the given index" - | word | - - anInteger < 0 - ifTrue:["word _ 16r100000000 + anInteger" - word _ (anInteger + 1) negated bitInvert32] - ifFalse:[word _ anInteger]. - self basicAt: index put: word. - ^anInteger! ! -!FloatArray methodsFor: 'accessing' stamp: 'jmv 2/28/2020 12:11:02' prior: 16846406! - at: index - ^self floatAt: index! ! -!FloatArray methodsFor: 'accessing' stamp: 'jmv 2/28/2020 12:10:34' prior: 16846412! - at: index put: value - ^self floatAt: index put: value! ! -!IntegerArray methodsFor: 'accessing' stamp: 'jmv 2/28/2020 12:25:30' prior: 16861100! - at: index - ^self integerAt: index! ! -!IntegerArray methodsFor: 'accessing' stamp: 'jmv 2/28/2020 12:24:58' prior: 16861111! - at: index put: anInteger - ^self integerAt: index put: anInteger! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4051-enablePointCollectionSubclasses-JuanVuletich-2020Feb28-11h02m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4048] on 28 February 2020 at 6:23:37 pm'! -!AffineTransformation class methodsFor: 'instance creation' stamp: 'jmv 2/28/2020 18:12:45'! - withPointScale: aPoint position: otherPoint - " - (AffineTransformation withPointScale: 4@3) transform: 1@1 - " - ^self new - setPointScale: aPoint; - setTranslation: otherPoint! ! -!AffineTransformation class methodsFor: 'instance creation' stamp: 'jmv 2/28/2020 18:15:20' prior: 16778956! - withScale: aNumber - ^self new setPointScale: aNumber@aNumber! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4052-AffineTransformation-tweaks-JuanVuletich-2020Feb28-16h46m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4047] on 26 February 2020 at 2:26:37 pm'! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'pb 2/26/2020 12:39:06'! - fileReaderServicesForFileEntry: filename suffix: suffix - "FileList buttons that open a CodeFileBrowserWindow on contents." - - (#('st' 'cs' 'cs.st') includes: suffix) ifTrue: [ - ^ { self serviceBrowseCode } ]. - - (suffix = 'pck') | (suffix = 'pck.st') ifTrue: [ - ^ { self serviceBrowsePackage } ]. - - ^#()! ! -!ChangeList class methodsFor: 'fileIn/Out' stamp: 'pb 2/26/2020 12:39:06'! - fileReaderServicesForFileEntry: filename suffix: suffix - "FileList buttons that open a ChangeListWindow on contents" - - (#('st' 'cs' 'cs.st') includes: suffix) - ifTrue: [ ^ {self serviceContents} ]. - - (suffix = 'pck') | (suffix = 'pck.st') - ifTrue: [ ^ {self servicePackageContents} ]. - - suffix = 'changes' - ifTrue: [ ^ {self serviceRecentChanges} ]. - - ^#()! ! -!FileList methodsFor: 'file list menu' stamp: 'pb 2/26/2020 12:43:21'! - itemsForFileEntry: aFileEntry - "Answer a list of services appropriate for a file of the given name" - ^ self class itemsForFileEntry: aFileEntry! ! -!FileList class methodsFor: 'file reader registration' stamp: 'pb 2/26/2020 12:43:21'! - itemsForFileEntry: aFileEntry - "Answer a list of services appropriate for a file of the given name" - | services suffix classList | - " - suffix _ (FileIOAccessor default extensionFor: filename) asLowercase. - " - suffix := aFileEntry extension asLowercase. - "Build the list dynamically for all implementers of the appropriate class method... registration no longer required" - classList _ (Smalltalk allClassesImplementing: #fileReaderServicesForFileEntry:suffix:) - collect: [ :item | - item class == Metaclass ifTrue: [ item soleInstance ]] - thenSelect: [ :item | - item notNil ]. - services _ OrderedCollection new. - classList do: [ :reader | - services addAll: - (reader - fileReaderServicesForFileEntry: aFileEntry - suffix: suffix) ]. - services sort: [ :a :b | a sortOrder < b sortOrder ]. - ^ services.! ! -!FileEntry methodsFor: 'accessing' stamp: 'pb 2/26/2020 13:37:21'! - baseDirectory - "The directory this file is located in" - ^ DirectoryEntry - withPathComponents: self pathComponents allButLast - drive: nil.! ! -!ChangeSet class methodsFor: 'file list services' stamp: 'pb 2/26/2020 12:39:06'! - fileReaderServicesForFileEntry: filename suffix: suffix - "These would better be done by ChangeSorter!!" - - (#('cs' 'cs.st') includes: suffix) ifTrue: [ - ^{self serviceInstall} ]. - - (#('st') includes: suffix) ifTrue: [ - ^{self serviceFileIn} ]. - - ^#()! ! -!CodePackageFile class methodsFor: 'file list services' stamp: 'pb 2/26/2020 12:39:06'! - fileReaderServicesForFileEntry: filename suffix: suffix - "FileList buttons that are serviced by us." - - (suffix = 'pck') | (suffix = 'pck.st') - ifTrue: [ ^ { self serviceInstallPackage } ]. - ^#()! ! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'pb 2/26/2020 14:25:31' prior: 50493071! - serviceBrowseCode - "Answer the service of opening a file-contents browser" - - ^ (SimpleServiceEntry - provider: self - label: 'browse code' - selector: #browseCodeFileEntry: - description: 'open a "file-contents browser" on this file, allowing you to view and selectively load its code' - buttonLabel: 'code' - icon: #editFindReplaceIcon) - sortOrder: 10! ! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'pb 2/26/2020 14:25:39' prior: 50493088! - serviceBrowsePackage - "Answer the service of opening a file-contents browser" - - ^ (SimpleServiceEntry - provider: self - label: 'browse package' - selector: #browsePackageFileEntry: - description: 'open a "package file browser" on this file, allowing you to view and selectively load its code' - buttonLabel: 'package browser' - icon: #editFindReplaceIcon) - sortOrder: 10! ! -!ChangeList class methodsFor: 'public access' stamp: 'pb 2/26/2020 12:46:51' prior: 50406173! - browseRecentLogOn: origChangesFileEntry - "figure out where the last snapshot or quit was, then browse the recent entries." - - | end done block positions prevBlock | - origChangesFileEntry readStreamDo: [ :changesFile | - positions _ SortedCollection new. - end _ changesFile size. - prevBlock _ end. - block _ end - 1024 max: 0. - done _ false. - [ done or: [ positions size > 0 ]] - whileFalse: [ - changesFile position: block. - "ignore first fragment" - changesFile nextChunk. - [ changesFile position < prevBlock ] - whileTrue: [ - | pos chunk | - pos _ changesFile position. - chunk _ changesFile nextChunk. - ((Smalltalk isQuitRecord: chunk) or: [ Smalltalk isSnapshotRecord: chunk ]) - ifTrue: [ positions add: pos ]]. - block = 0 - ifTrue: [done _ true] - ifFalse: [ - prevBlock _ block. - block _ block - 1024 max: 0]]. - ]. - self browseRecentLogOn: origChangesFileEntry startingFrom: (positions isEmpty ifTrue: [0] ifFalse: [positions last])! ! -!ChangeList class methodsFor: 'fileIn/Out' stamp: 'pb 2/26/2020 14:25:02' prior: 50427051! - serviceContents - "Answer a service for opening a changelist browser on a file" - - ^ (SimpleServiceEntry - provider: self - label: 'see code file contents' - selector: #browseContents: - description: 'open a code file contents tool on this file' - buttonLabel: 'contents' - icon: #changesIcon) - sortOrder: 20! ! -!ChangeList class methodsFor: 'fileIn/Out' stamp: 'pb 2/26/2020 14:25:10' prior: 50427066! - servicePackageContents - "Answer a service for opening a changelist browser on a file" - - ^ (SimpleServiceEntry - provider: self - label: 'see package file contents' - selector: #browsePackageContents: - description: 'open a code file contents tool on this package file' - buttonLabel: 'pck contents' - icon: #changesIcon) - sortOrder: 20! ! -!FileList methodsFor: 'initialization' stamp: 'pb 2/26/2020 12:43:21' prior: 16842586! - dynamicButtonServices - "Answer services for buttons that may come and go in the button pane, depending on selection" - - ^ fileName isEmptyOrNil - ifTrue: - [#()] - ifFalse: - [ | toReject | - toReject _ self buttonSelectorsToSuppress. - (self itemsForFileEntry: self selectedFileEntry) reject: - [:svc | toReject includes: svc selector]]! ! -!SimpleServiceEntry methodsFor: 'performing service' stamp: 'pb 2/26/2020 14:24:39' prior: 16907933! - getArgumentsFrom: aProvider - - argumentGetter ifNil: [^aProvider selectedFileEntry ]. - ^argumentGetter value: aProvider! ! -!FileListWindow methodsFor: 'menu building' stamp: 'pb 2/26/2020 12:43:21' prior: 16843400! - fileSelectedMenu - - | itemsPart1 itemsPart2 itemsPart3 itemsPart4 n1 n2 n3 services aMenu | - aMenu _ MenuMorph new defaultTarget: model. - itemsPart1 _ model itemsForAnyFile1. - itemsPart2 _ model itemsForFileEntry: model selectedFileEntry. - itemsPart3 _ model itemsForAnyFile2. - itemsPart4 _ model itemsForNoFile. - n1 _ itemsPart1 size. - n2 _ n1 + itemsPart2 size. - n3 _ n2 + itemsPart3 size. - services _ itemsPart1, itemsPart2, itemsPart3, itemsPart4. - services do: [ :svc | svc when: #fileListChanged send: #updateFileList to: model ]. - ^ aMenu - addServices: services - for: model - extraLines:{ n1 . n2 . n3 } -! ! -!DropFilesAction methodsFor: 'evaluating - private' stamp: 'pb 2/26/2020 12:43:21' prior: 50427261! - fileNamedDropped: aFileName - - | options selectionIndex menu | - - selectedFileEntry := aFileName asFileEntry. - options := FileList itemsForFileEntry: selectedFileEntry. - options isEmpty ifTrue: [ ^self inform: 'No action found for ', selectedFileEntry name ]. - menu := self createMenuFor: options. - - selectionIndex := menu startUpWithCaption: 'Select action for ', selectedFileEntry name. - - selectionIndex = 0 ifTrue: [ ^self ]. - (options isInBounds: selectionIndex) ifTrue: [ ^self performService: (options at: selectionIndex) ]. - "The only available option is 'stop here'. This could change if #createMenuFor: changes - Hernan" - stopHereBlock value - -! ! -!ChangeSet class methodsFor: 'file list services' stamp: 'pb 2/26/2020 14:25:16' prior: 50427285! - serviceFileIn - "Answer a service for filing in an entire file" - - ^ (SimpleServiceEntry - provider: self - label: 'file in' - selector: #fileIn: - description: 'file in the entire contents of the file, which is expected to contain Smalltalk code in fileout ("chunk") format' - buttonLabel: 'filein' - icon: #saveIcon) - sortOrder: 100! ! -!ChangeSet class methodsFor: 'file list services' stamp: 'pb 2/26/2020 14:25:23' prior: 50427301! - serviceInstall - "Answer a service for filing in an entire file" - - ^ (SimpleServiceEntry - provider: self - label: 'install code' - selector: #install: - description: 'install change set' - buttonLabel: 'install' - icon: #saveIcon) - sortOrder: 100! ! -!CodePackageFile class methodsFor: 'file list services' stamp: 'pb 2/26/2020 14:25:45' prior: 50427315! - serviceInstallPackage - "Answer the service of installing a CodePackageFile (a chunk format file for a CodePackage)" - - ^ (SimpleServiceEntry - provider: self - label: 'install package' - selector: #installPackage: - description: 'install the package, replacing all existing code in the package (if any); create a new change set just for the installation' - buttonLabel: 'install package' - icon: #saveIcon) - sortOrder: 100! ! - -CodePackageFile class removeSelector: #fileReaderServicesForFile:suffix:! - -!methodRemoval: CodePackageFile class #fileReaderServicesForFile:suffix: stamp: 'Install-4053-fileReaderServices-use-FileEntry-PhilBellalouna-2020Feb26-12h37m-pb.001.cs.st 4/1/2020 17:57:15'! -fileReaderServicesForFile: filename suffix: suffix - "FileList buttons that are serviced by us." - - (suffix = 'pck') | (suffix = 'pck.st') - ifTrue: [ ^ { self serviceInstallPackage } ]. - ^#()! - -ChangeSet class removeSelector: #fileReaderServicesForFile:suffix:! - -!methodRemoval: ChangeSet class #fileReaderServicesForFile:suffix: stamp: 'Install-4053-fileReaderServices-use-FileEntry-PhilBellalouna-2020Feb26-12h37m-pb.001.cs.st 4/1/2020 17:57:15'! -fileReaderServicesForFile: filename suffix: suffix - "These would better be done by ChangeSorter!!" - - (#('cs' 'cs.st') includes: suffix) ifTrue: [ - ^{self serviceInstall} ]. - - (#('st') includes: suffix) ifTrue: [ - ^{self serviceFileIn} ]. - - ^#()! - -FileList class removeSelector: #itemsForFile:! - -!methodRemoval: FileList class #itemsForFile: stamp: 'Install-4053-fileReaderServices-use-FileEntry-PhilBellalouna-2020Feb26-12h37m-pb.001.cs.st 4/1/2020 17:57:15'! -itemsForFile: filename - "Answer a list of services appropriate for a file of the given name" - | services suffix classList | - suffix _ (FileIOAccessor default extensionFor: filename) asLowercase. - "Build the list dynamically for all implementers of the appropriate class method... registration no longer required" - classList _ (Smalltalk allClassesImplementing: #fileReaderServicesForFile:suffix:) - collect: [ :item | - item class == Metaclass ifTrue: [ item soleInstance ]] - thenSelect: [ :item | - item notNil ]. - services _ OrderedCollection new. - classList do: [ :reader | - services addAll: - (reader - fileReaderServicesForFile: filename - suffix: suffix) ]. - services sort: [ :a :b | a sortOrder < b sortOrder ]. - ^ services.! - -FileList removeSelector: #itemsForFile:! - -!methodRemoval: FileList #itemsForFile: stamp: 'Install-4053-fileReaderServices-use-FileEntry-PhilBellalouna-2020Feb26-12h37m-pb.001.cs.st 4/1/2020 17:57:15'! -itemsForFile: filename - "Answer a list of services appropriate for a file of the given name" - ^ self class itemsForFile: filename! - -ChangeList class removeSelector: #fileReaderServicesForFile:suffix:! - -!methodRemoval: ChangeList class #fileReaderServicesForFile:suffix: stamp: 'Install-4053-fileReaderServices-use-FileEntry-PhilBellalouna-2020Feb26-12h37m-pb.001.cs.st 4/1/2020 17:57:15'! -fileReaderServicesForFile: filename suffix: suffix - "FileList buttons that open a ChangeListWindow on contents" - - (#('st' 'cs' 'cs.st') includes: suffix) - ifTrue: [ ^ {self serviceContents} ]. - - (suffix = 'pck') | (suffix = 'pck.st') - ifTrue: [ ^ {self servicePackageContents} ]. - - suffix = 'changes' - ifTrue: [ ^ {self serviceRecentChanges} ]. - - ^#()! - -CodeFileBrowser class removeSelector: #fileReaderServicesForFile:suffix:! - -!methodRemoval: CodeFileBrowser class #fileReaderServicesForFile:suffix: stamp: 'Install-4053-fileReaderServices-use-FileEntry-PhilBellalouna-2020Feb26-12h37m-pb.001.cs.st 4/1/2020 17:57:15'! -fileReaderServicesForFile: filename suffix: suffix - "FileList buttons that open a CodeFileBrowserWindow on contents." - - (#('st' 'cs' 'cs.st') includes: suffix) ifTrue: [ - ^ { self serviceBrowseCode } ]. - - (suffix = 'pck') | (suffix = 'pck.st') ifTrue: [ - ^ { self serviceBrowsePackage } ]. - - ^#()! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4053-fileReaderServices-use-FileEntry-PhilBellalouna-2020Feb26-12h37m-pb.001.cs.st----! - -'From Cuis 5.0 [latest update: #4048] on 28 February 2020 at 4:42:54 pm'! -!IndentingListItemMorph methodsFor: 'geometry' stamp: 'KenD 2/28/2020 16:35:26'! - fontPreferenceChanged - - super fontPreferenceChanged. - self font: Preferences standardListFont.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4054-HonorFontPreferenceChange-KenD-2020Feb28-07h41m-KenD.001.cs.st----! - -'From Cuis 5.0 [latest update: #4047] on 3 March 2020 at 4:04:48 am'! -!Color class methodsFor: 'color from user' stamp: 'pb 3/3/2020 03:54:12' prior: 50357339! - colorPaletteForDepth: depth extent: chartExtent - "Display a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." - "Note: It is slow to build this palette, so it should be cached for quick access." - "(Color colorPaletteForDepth: 16 extent: 190@60) display" - - | basicHue x y startHue palette transHt vSteps transCaption grayWidth hSteps | - palette _ Form extent: chartExtent depth: depth. - transCaption _ - (Form extent: 34@9 depth: 1 - fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0) - offset: `0@0`). - transHt _ transCaption height. - palette fillWhite: (`0@0` extent: palette width@transHt). - palette fillBlack: (0@transHt extent: palette width@1). - transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0). - grayWidth _ 10. - startHue _ 338.0. - vSteps _ palette height - transHt // 2. - hSteps _ palette width - grayWidth. - x _ 0. - startHue to: startHue + 360.0 by: 360.0/hSteps do: [ :h | - basicHue _ Color h: h asFloat s: 1.0 v: 1.0. - y _ transHt+1. - 0 to: vSteps do: [ :n | | c | - c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Color white. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - 1 to: vSteps do: [ :n | | c | - c _ Color black mixed: (n asFloat / vSteps asFloat) with: basicHue. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - x _ x + 1]. - y _ transHt + 1. - 1 to: vSteps * 2 do: [ :n | | c | - c _ Color black mixed: (n asFloat / (vSteps*2) asFloat) with: Color white. - palette fill: (x@y extent: 10@1) fillColor: c. - y _ y + 1]. - ^ palette -! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:00:30' prior: 50470435! - bottomLeftCursor - ^ self - extent: `16 @ 16` - fromArray: #(49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 65532 65532 0 0 ) - offset: `0 @ -16`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:00:40' prior: 50470443! - bottomRightCursor - ^ self - extent: `16 @ 16` - fromArray: #(12 12 12 12 12 12 12 12 12 12 12 12 65532 65532 0 0 ) - offset: `-16 @ -16`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:00:50' prior: 50470450! - cornerCursor - "Answer the instance of me that is the shape of the bottom right corner - of a rectangle." - ^ self - extent: `16 @ 16` - fromArray: #(12 12 12 12 12 12 12 12 12 12 12 12 65532 65532 0 0 ) - offset: `-16 @ -16`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:01:07' prior: 50470460! - crossHairCursor - "Answer the instance of me that is the shape of a cross." - ^ self - extent: `16 @ 16` - fromArray: #(0 256 256 256 256 256 256 32764 256 256 256 256 256 256 0 0 ) - offset: `-7 @ -7`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:01:13' prior: 50470469! - downCursor - "Answer the instance of me that is the shape of an arrow facing - downward." - ^ self - extent: `16 @ 16` - fromArray: #(12288 12288 12288 12288 12288 12288 12288 64512 30720 12288 0 0 0 0 0 0 ) - offset: `0 @ 0`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:01:19' prior: 50470479! - executeCursor - "Answer the instance of me that is the shape of an arrow slanted left - with a star next to it." - ^ self - extent: `16 @ 16` - fromArray: #(32800 49184 57456 62462 63884 64648 65272 61656 55692 39172 3072 3072 1536 1536 0 0 ) - offset: `0 @ 0`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:01:27' prior: 16826365! - extent: extentPoint fromArray: anArray offset: offsetPoint - "Answer a new instance of me with width and height specified by - extentPoint, offset by offsetPoint, and bits from anArray. - NOTE: This has been kluged to take an array of 16-bit constants, - and shift them over so they are left-justified in a 32-bit bitmap" - - extentPoint = (`16 @ 16`) - ifTrue: - [^ super - extent: extentPoint - fromArray: (anArray collect: [:bits | bits bitShift: 16]) - offset: offsetPoint] - ifFalse: [self error: 'cursors must be 16@16']! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:01:32' prior: 50470490! - markerCursor - "Answer the instance of me that is the shape of a small ball." - ^ self - extent: `16 @ 16` - fromArray: #(28672 63488 63488 28672 0 0 0 0 0 0 0 0 0 0 0 0 ) - offset: `0 @ 0`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:01:37' prior: 50470499! - menuCursor - "Answer the instance of me that is the shape of a menu." - ^ self - extent: `16 @ 16` - fromArray: #(65504 32800 42528 32800 54112 65504 32800 45728 32800 44192 32800 42272 32800 65504 0 ) - offset: `0 @ 0`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:01:44' prior: 50470509! - moveCursor - "Answer the instance of me that is the shape of a cross inside a square." - ^ self - extent: `16 @ 16` - fromArray: #(65532 65532 49932 49932 49932 49932 65532 65532 49932 49932 49932 49932 65532 65532 0 0 ) - offset: `0 @ 0`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 03:48:43' prior: 16826384! - new - - ^ self extent: `16 @ 16` - fromArray: (Array new: 16 withAll: 0) - offset: `0 @ 0` - - "Cursor new bitEdit show"! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 03:48:52' prior: 50470519! - normalCursor - "Answer the instance of me that is the shape of an arrow slanted left." - ^ self - extent: `16 @ 16` - fromArray: #(32768 49152 57344 61440 63488 64512 65024 63488 63488 38912 3072 3072 1536 1536 768 768 ) - offset: `0 @ 0`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 03:49:10' prior: 50470529! - normalCursorWithMask - "Cursor initNormalWithMask. Cursor normal show" - "Next two lines work simply for any cursor..." - " - self initNormal. - NormalCursor _ CursorWithMask derivedFrom: NormalCursor. - " - "But for a good looking cursor, you have to tweak things..." - ^ (CursorWithMask - extent: `16 @ 16` - depth: 1 - fromArray: #(0 1073741824 1610612736 1879048192 2013265920 2080374784 2113929216 2130706432 2139095040 2080374784 1811939328 1174405120 100663296 50331648 50331648 0 ) - offset: -1 @ -1) setMaskForm: - (Form - extent: `16 @ 16` - depth: 1 - fromArray: #(3221225472 3758096384 4026531840 4160749568 4227858432 4261412864 4278190080 4286578688 4290772992 4292870144 4261412864 4009754624 3472883712 2273312768 125829120 58720256 ) - offset: `0 @ 0`).! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 03:49:18' prior: 50470556! -originCursor - "Answer the instance of me that is the shape of the top left corner of a - rectangle." - ^ self - extent: `16 @ 16` - fromArray: #(65532 65532 49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 0 0 ) - offset: `0 @ 0`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 03:49:28' prior: 50470567! - readCursor - "Answer the instance of me that is the shape of eyeglasses." - ^ self - extent: `16 @ 16` - fromArray: #(0 0 4104 10260 16416 64480 33824 33824 46496 31680 0 0 0 0 0 0 ) - offset: `0 @ 0`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:02:13' prior: 50470591! - resizeLeftCursor - ^ (self - extent: `16 @ 16` - fromArray: #(0 1152 1152 1152 5280 13488 29880 64764 29880 13488 5280 1152 1152 1152 0 0 ) - offset: `-7 @ -7`) withMask.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:02:22' prior: 50470604! - resizeTopCursor - ^ (self - extent: `16 @ 16` - fromArray: #(256 896 1984 4064 256 32764 0 0 32764 256 4064 1984 896 256 0 ) - offset: `-7 @ -7`) withMask.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:02:30' prior: 50470612! - resizeTopLeftCursor - ^ (self - extent: `16 @ 16` - fromArray: #(0 31760 30752 28740 26760 17680 544 1088 2176 4420 8748 1052 2108 124 0 0 ) - offset: `-7 @ -7`) withMask.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:02:37' prior: 50470620! - resizeTopRightCursor - ^ (self - extent: `16 @ 16` - fromArray: #(0 4220 2108 17436 8748 4420 2176 1088 544 17680 26760 28736 30752 31744 0 0 ) - offset: `-7 @ -7`) withMask.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 03:49:38' prior: 50470628! - rightArrowCursor - "Answer the instance of me that is the shape of an arrow pointing to the right." - ^ self - extent: `16 @ 16` - fromArray: #(1536 1920 2016 65528 2016 1920 1536 0 0 0 0 0 0 0 0 0 ) - offset: `0 @ 0`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:02:48' prior: 50470638! - squareCursor - "Answer the instance of me that is the shape of a square." - ^ self - extent: `16 @ 16` - fromArray: #(0 0 0 0 0 960 960 960 960 0 0 0 0 0 0 0 ) - offset: `-8 @ -8`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:02:56' prior: 50470646! - targetCursor - "Answer the instance of me that is the shape of a gunsight." - ^ self - extent: `16 @ 16` - fromArray: #(1984 6448 8456 16644 17284 33026 35106 65278 35106 33026 17284 16644 8456 6448 1984 0 ) - offset: `-7 @ -7`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 03:49:50' prior: 50470656! - topLeftCursor - ^ self - extent: `16 @ 16` - fromArray: #(65532 65532 49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 49152 0 0 ) - offset: `0 @ 0`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 04:03:08' prior: 50470664! - topRightCursor - ^ self - extent: `16 @ 16` - fromArray: #(65532 65532 12 12 12 12 12 12 12 12 12 12 12 12 0 0 ) - offset: `-16 @ 0`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 03:49:59' prior: 50470671! - upCursor - "Answer the instance of me that is the shape of an arrow facing upward." - ^ self - extent: `16 @ 16` - fromArray: #(12288 30720 64512 12288 12288 12288 12288 12288 12288 12288 0 0 0 0 0 0 ) - offset: `0 @ 0`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 03:50:07' prior: 50470681! - waitCursor - "Answer the instance of me that is the shape of an Hourglass (was in the - shape of three small balls)." - ^ self - extent: `16 @ 16` - fromArray: #(65532 32772 16392 8208 7392 4032 1920 1920 2368 4384 8592 17352 36852 65532 0 ) - offset: `0 @ 0`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 03:50:19' prior: 50470692! - webLinkCursor - "Return a cursor that can be used for emphasizing web links" - ^ (CursorWithMask - extent: `16 @ 16` - fromArray: #(3072 4608 4608 4608 4608 5046 4681 29257 37449 37449 32769 32769 49155 16386 24582 16380 ) - offset: -5 @ 0) setMaskForm: - (Form - extent: `16 @ 16` - fromArray: - (#(3072 7680 7680 7680 7680 8118 8191 32767 65535 65535 65535 65535 65535 32766 32766 16380 ) collect: [ :bits | - bits bitShift: 16 ]) - offset: `0 @ 0`).! ! -!Cursor class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 03:50:30' prior: 50470709! - writeCursor - "Answer the instance of me that is the shape of a pen writing." - ^ self - extent: `16 @ 16` - fromArray: #(24 60 72 144 288 580 1156 2316 4624 9232 30728 20728 57728 32512 0 0 ) - offset: `0 @ 0`.! ! -!CursorWithMask class methodsFor: 'as yet unclassified' stamp: 'pb 3/3/2020 03:54:50' prior: 16826711! - derivedFrom: aForm "Cursor initNormalWithMask. Cursor normal show" - "aForm is presumably a cursor" - | cursor mask ext | - ext _ aForm extent. - cursor _ self extent: ext. - cursor copy: (1@1 extent: ext) from: `0@0` in: aForm rule: Form over. - mask _ Form extent: ext. - (1@1) eightNeighbors do: - [:p | mask copy: (p extent: ext) from: `0@0` in: aForm rule: Form under]. - cursor setMaskForm: mask. - cursor offset: ((aForm offset - (1@1)) max: ext negated). - ^ cursor! ! -!Rectangle class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 03:51:23' prior: 50470989! - fromUser - "Answer a Rectangle that is determined by having the user - designate the top left and bottom right corners." - | originRect | - originRect _ (Cursor cursorAt: #originCursor) showWhile: [ - (Sensor mousePoint extent: `0 @ 0`) newRectFrom: [ :f | - Sensor mousePoint extent: `0 @ 0` ]]. - ^ (Cursor cursorAt: #cornerCursor) showWhile: [ - originRect newRectFrom: [ :f | - f origin corner: Sensor mousePoint ]].! ! -!StrikeFont methodsFor: 'emphasis' stamp: 'pb 3/3/2020 03:57:46' prior: 50457999! - makeItalicGlyphs - "Make an italic set of glyphs with same widths by skewing left and right. - In the process, characters would overlap, so we widen them all first. - " - | extraWidth newGlyphs newXTable x newX w extraOnLeft | - extraOnLeft _ (self lineSpacing-1-self ascent+4)//4 max: 0. - extraWidth _ ((self ascent-5+4)//4 max: 0) + extraOnLeft. - newGlyphs _ Form extent: (glyphs width + (maxAscii + 1 - minAscii*extraWidth)) @ glyphs height depth: glyphs depth. - newGlyphs fillWhite. - newXTable _ xTable copy. - - "Copy glyphs into newGlyphs with room on left and right for overlap." - minAscii to: maxAscii+1 do: - [:ascii | x _ xTable at: ascii+1. w _ (xTable at: ascii+2) - x. - newX _ newXTable at: ascii+1. - newGlyphs copy: ((newX + extraOnLeft) @ 0 extent: w @ glyphs height) - from: x @ 0 in: glyphs rule: Form over. - newXTable at: ascii+2 put: newX + w + extraWidth]. - glyphs _ newGlyphs. - xTable _ newXTable. - "Slide the bitmaps left and right for synthetic italic effect." - 4 to: self ascent-1 by: 4 do: - [:y | "Slide ascenders right..." - glyphs copy: (`1@0` extent: glyphs width @ (self ascent - y)) - from: `0@0` in: glyphs rule: Form over]. - self ascent to: self lineSpacing-1 by: 4 do: - [:y | "Slide descenders left..." - glyphs copy: (0@y extent: glyphs width @ glyphs height) - from: 1@y in: glyphs rule: Form over]. - self isSynthetic: true! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'pb 3/3/2020 03:57:26' prior: 50454176! - glyphAt: character put: characterForm - "Copy characterForm over the glyph for the argument, character." - | ascii leftX rightX widthDif newGlyphs | - ascii _ character numericValue. - ascii < minAscii ifTrue: [^ self error: 'Cant store characters below min ascii']. - ascii > maxAscii ifTrue: - [(self confirm: -'This font does not accomodate ascii values higher than ' , maxAscii printString , '. -Do you wish to extend it permanently to handle values up to ' , ascii printString) - ifTrue: [self extendMaxAsciiTo: ascii] - ifFalse: [^ self error: 'No change made']]. - leftX _ xTable at: ascii + 1. - rightX _ xTable at: ascii + 2. - widthDif _ characterForm width - (rightX - leftX). - widthDif ~= 0 ifTrue: - ["Make new glyphs with more or less space for this char" - newGlyphs _ Form extent: (glyphs width + widthDif) @ glyphs height depth: glyphs depth. - newGlyphs copy: (`0@0` corner: leftX@glyphs height) - from: `0@0` in: glyphs rule: Form over. - newGlyphs copy: ((rightX+widthDif)@0 corner: newGlyphs width@glyphs height) - from: rightX@0 in: glyphs rule: Form over. - glyphs _ newGlyphs. - "adjust further entries on xTable" - xTable _ xTable copy. - ascii+2 to: xTable size - do: [:i | xTable at: i put: (xTable at: i) + widthDif]]. - glyphs copy: (leftX @ 0 extent: characterForm extent) - from: 0@0 in: characterForm rule: Form over -" -| f | f _ AbstractFont default. -f glyphAt: $ put: (Form extent: (f widthOf: $ )+10@f lineSpacing) -"! ! -!StrikeFont methodsFor: 'building' stamp: 'pb 3/3/2020 03:57:08' prior: 50371975! - buildFromForm: allGlyphs data: data name: aString - - | x shortUnderscore firstGlyphInFiles | - pointSize _ data first asNumber. - ascent _ data second asNumber. - descent _ data third asNumber. - - firstGlyphInFiles _ 257-(data size-3). - minAscii _ 1. - maxAscii _ 255. - name _ aString. - type _ 0. "ignored for now" - superscript _ ascent - descent // 3. - subscript _ descent - ascent // 3. - emphasis _ 0. - - xTable _ (Array new: 258) atAllPut: 0. - maxWidth _ 0. - glyphs _ allGlyphs depth > 16 ifTrue: [ allGlyphs asFormOfDepth: 16 ] ifFalse: [ allGlyphs ]. - x _ 0. - 4 to: data size do: [ :i | - x _ (data at: i) asNumber. - xTable at: i+firstGlyphInFiles+1-4 put: x]. - xTable at: 258 put: x. - self reset. - derivativeFonts _ nil. - - self makeCrVisible. - - "Replace glyph for 127 (a box) with a short version of the underscore (used to optionally mark subscript in code)" - shortUnderscore _ self glyphAt: $_. - shortUnderscore _ shortUnderscore copy: (`0@0` extent: 1@shortUnderscore height). - self glyphAt: (Character numericValue: 127) put: shortUnderscore! ! -!StrikeFont methodsFor: 'building' stamp: 'pb 3/3/2020 03:57:59' prior: 16914891! - stripHighGlyphs - "Remove glyphs for characters above 128" - | i | - - characterToGlyphMap _ nil. - maxAscii _ 127. - - xTable _ xTable copyFrom: 1 to: maxAscii + 3. - i _ xTable at: maxAscii + 2. - xTable at: maxAscii + 3 put: i. - glyphs _ glyphs copy: (`0@0` extent: i+1@glyphs height). - maxWidth _ 0. - 2 to: xTable size do: [ :ii | - maxWidth _ maxWidth max: (xTable at: ii) - (xTable at: ii-1)-1 ]. - self reset! ! -!TileResizeMorph methodsFor: 'as yet unclassified' stamp: 'pb 3/3/2020 03:58:50' prior: 50413111! - resizeAtPoint: aPoint - - |region| - - region _ (aPoint min: extent - 1) // (extent // 3). - - ^ region caseOf: { - [`0@0`] -> [#topLeft]. - [`1@0`] -> [#top]. - [`2@0`] -> [#topRight]. - [`0@1`] -> [#left]. - [`1@1`] -> [#full]. - [`2@1`] -> [#right]. - [`0@2`] -> [#bottomLeft]. - [`1@2`] -> [#bottom]. - [`2@2`] -> [#bottomRight]. - } otherwise: [nil]! ! -!TileResizeMorph methodsFor: 'as yet unclassified' stamp: 'pb 3/3/2020 03:59:07' prior: 50413139! - selectionRectangle: region - - ^ region caseOf: { - [#topLeft] -> [`0@0` corner: (extent // 2)]. - [#top] -> [`0@0` corner: (extent x@(extent y // 2))]. - [#topRight] -> [(extent x // 2)@0 corner: (extent x@(extent y // 2))]. - [#left] -> [`0@0` corner: (extent x // 2)@extent y]. - [#full] -> [`0@0` corner: extent]. - [#right] -> [(extent x // 2)@0 corner: extent]. - [#bottomLeft] -> [0@(extent y // 2) corner: (extent x // 2)@extent y]. - [#bottomRight] -> [(extent x // 2)@(extent y // 2) corner: extent]. - [#bottom] -> [0@(extent y // 2) corner: extent]. - }! ! -!DraggingGuideMorph methodsFor: 'initialization' stamp: 'pb 3/3/2020 03:54:58' prior: 50426071! - initialize - - super initialize. - extent _ `0@0`.! ! -!HandMorph methodsFor: 'drawing' stamp: 'pb 3/3/2020 03:50:54' prior: 50471031! - drawOn: aCanvas - "Draw the hand itself (i.e., the cursor)." - "This method is only called when we are carrying morphs around..." - aCanvas - stencil: (Cursor cursorAt: #moveCursor) - at: `0 @ 0` - color: Color black.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4055-fix-some-Point-literals-PhilBellalouna-2020Mar03-03h47m-pb.001.cs.st----! - -'From Cuis 5.0 [latest update: #4047] on 3 March 2020 at 7:46:29 pm'! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 19:45:18' prior: 50492738! - browseCodeFileEntry: aFileEntry - ^ self browseCodeSource: (CodeFile newFromFile: aFileEntry )! ! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 19:45:11' prior: 50492744! - browseCodeSource: aCaseCodeSource - ^ self browseCodeSource: aCaseCodeSource base: nil! ! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 19:45:02' prior: 50492750! - browseCodeSource: aCaseCodeSource base: aBaseCodeSource - | useCaseCodeSource useCaseClasses browser useCaseOrganizer useHeading | - browser _ self new. - browser - caseCodeSource: aCaseCodeSource; - baseCodeSource: aBaseCodeSource. - useCaseCodeSource _ browser caseCodeSource. - useCaseClasses _ useCaseCodeSource classes collect: [ :ea | - ea name ]. - useCaseOrganizer _ useCaseCodeSource organization. - useHeading _ (useCaseCodeSource isLiveSmalltalkImage not and: [ browser baseCodeSource isLiveSmalltalkImage ]) - ifTrue: [ useCaseCodeSource name ] - ifFalse: [ "This is a non-standard configuration... make the user aware" - useCaseCodeSource name , '(' , useCaseCodeSource class name , '), target: ' , aBaseCodeSource name , '(' , aBaseCodeSource class name , ')' ]. - (useCaseCodeSource notNil and: [ useCaseCodeSource isLiveSmalltalkImage not ]) ifTrue: [ - useCaseOrganizer - classifyAll: useCaseClasses - under: useHeading ]. - browser - systemOrganizer: useCaseOrganizer; - caseCodeSource: useCaseCodeSource. - aBaseCodeSource ifNotNil: [ browser baseCodeSource: aBaseCodeSource ]. - ^ CodeFileBrowserWindow - open: browser - label: nil.! ! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'pb 3/3/2020 19:45:27' prior: 50492789! - browsePackageFileEntry: aFileEntry - ^ self browseCodeSource: (CodePackageFile newFromFile: aFileEntry )! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4056-CodeFileBrowser-does-not-return-instance-PhilBellalouna-2020Mar03-19h45m-pb.001.cs.st----! - -'From Cuis 5.0 [latest update: #4056] on 5 March 2020 at 9:55:36 pm'! -!ChangeSelectorSendersStepWindow methodsFor: 'actions' stamp: 'HAW 3/5/2020 21:07:36'! - changeSenders - - applier senders: model messageList - ! ! -!ChangeSelectorSendersStepWindow methodsFor: 'actions' stamp: 'HAW 3/5/2020 19:21:40'! - refactor - - self changeSenders. - super refactor ! ! -!ChangeSelectorKeepingParameters class methodsFor: 'convertion' stamp: 'HAW 3/5/2020 21:22:32'! - collectCompiledMethodsOf: aCollectionOfMethodReferences - - ^aCollectionOfMethodReferences collect: [ :aMethodReference | aMethodReference compiledMethod ]. - - ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - creation' stamp: 'HAW 3/5/2020 20:59:45'! - convertSendersToCompiledMethods - - senders := senders collect: [ :aMethodReference | aMethodReference compiledMethod ]! ! -!ChangeSelectorWizardStepWindow class methodsFor: 'instance creation' stamp: 'HAW 3/5/2020 21:05:27' prior: 50469721! - openFrom: aChangeSelectorApplier methods: methods label: aLabel selecting: somethingToSelect - - | window | - - window := self openMessageList: methods label: aLabel autoSelect: somethingToSelect. - window initializeFrom: aChangeSelectorApplier. - - ^window - -! ! -!ChangeSelectorImplementorsStepWindow class methodsFor: 'instance creation' stamp: 'HAW 3/5/2020 21:04:09' prior: 50469734! -openFrom: aChangeSelectorApplier - - ^self - openFrom: aChangeSelectorApplier - methods: (self methodReferencesOf: aChangeSelectorApplier implementors) - label: 'Implementors of #', aChangeSelectorApplier oldSelector, ' to Refactor' - selecting: nil -! ! -!ChangeSelectorSendersStepWindow methodsFor: 'actions' stamp: 'HAW 3/5/2020 19:25:10' prior: 50469254! - seeImplementors - - self changeSenders. - self delete. - - ChangeSelectorImplementorsStepWindow openFrom: applier! ! -!ChangeSelectorSendersStepWindow class methodsFor: 'instance creation' stamp: 'HAW 3/5/2020 21:05:36' prior: 50469745! - openFrom: aChangeSelectorApplier - - ^self - openFrom: aChangeSelectorApplier - methods: aChangeSelectorApplier senders asOrderedCollection - label: 'Senders of #', aChangeSelectorApplier oldSelector, ' to Refactor' - selecting: aChangeSelectorApplier oldSelector ! ! -!ChangeSelector class methodsFor: 'implementors and senders' stamp: 'HAW 3/5/2020 19:47:57' prior: 50438810! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategoriesAndHierarchyOf: aClass organizedBy: anOrganization - - | categories | - - categories := Set new. - - self - addImplementorsOf: anOldSelector - to: implementors - andSendersTo: senders - inHierarchyOf: aClass - doingPerClass: [:aClassInHierarchy | categories add: aClassInHierarchy category ]. - - categories do: [:aCategory | - self - addImplementorsOf: anOldSelector - to: implementors - andSendersTo: senders - inCategory: aCategory - organizedBy: anOrganization ]. -! ! -!ChangeSelector class methodsFor: 'implementors and senders' stamp: 'HAW 3/5/2020 19:48:17' prior: 50438830! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategory: aCategory organizedBy: anOrganization - - | classesInCategory | - - classesInCategory := anOrganization classesAt: aCategory. - classesInCategory do: [ :aPotentialClassToRefactor | - self - addImplementorsOf: anOldSelector - to: implementors - andSendersTo: senders - forClassAndMetaOf: aPotentialClassToRefactor ]. -! ! -!ChangeSelector class methodsFor: 'implementors and senders' stamp: 'HAW 3/5/2020 19:48:32' prior: 50438846! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inHierarchyOf: aClass - - self - addImplementorsOf: anOldSelector - to: implementors - andSendersTo: senders - inHierarchyOf: aClass - doingPerClass: [ :aClassInHierarchy | ] - - ! ! -!ChangeSelector class methodsFor: 'implementors and senders' stamp: 'HAW 3/5/2020 19:48:48' prior: 50468504! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inHierarchyOf: aClass doingPerClass: aBlock - - | highestClassImplementingOldSelector | - - highestClassImplementingOldSelector := aClass highestClassImplementing: anOldSelector ifNone: [ aClass ]. - highestClassImplementingOldSelector theNonMetaClass withAllSubclassesDo: [ :aPotentialClassToRefactor | - aPotentialClassToRefactor isMeta ifFalse: [ - self - addImplementorsOf: anOldSelector - to: implementors - andSendersTo: senders - forClassAndMetaOf: aPotentialClassToRefactor. - aBlock value: aPotentialClassToRefactor ]] - ! ! -!ChangeSelector class methodsFor: 'implementors and senders' stamp: 'HAW 3/5/2020 19:49:40' prior: 50438886! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders of: aPotentialClassToRefactor - - | potentialImplementor | - - potentialImplementor := aPotentialClassToRefactor compiledMethodAt: anOldSelector ifAbsent: [ nil ]. - potentialImplementor ifNotNil: [ implementors add: potentialImplementor ]. - - (aPotentialClassToRefactor whichSelectorsReferTo: anOldSelector) do: [ :aSelector | - senders add: (MethodReference class: aPotentialClassToRefactor selector: aSelector) ]! ! -!ChangeSelectorKeepingParameters class methodsFor: 'instance creation' stamp: 'HAW 3/5/2020 21:49:45' prior: 50447679! -from: anOldSelector to: aNewSelector in: aClassToRefactor - - | implementors senders | - - implementors := OrderedCollection new. - senders := OrderedCollection new. - - self - addImplementorsOf: anOldSelector - to: implementors - andSendersTo: senders - forClassAndMetaOf: aClassToRefactor theNonMetaClass. - - ^self from: anOldSelector to: aNewSelector implementors: implementors senders: (self collectCompiledMethodsOf: senders)! ! -!ChangeSelectorKeepingParameters class methodsFor: 'instance creation' stamp: 'HAW 3/5/2020 21:51:08' prior: 50447695! - from: anOldSelector to: aNewSelector inCategoriesAndHierarchyOf: aClass organizedBy: anOrganization - - | implementors senders | - - implementors := IdentitySet new. - senders := Set new. - - self - addImplementorsOf: anOldSelector - to: implementors - andSendersTo: senders - inCategoriesAndHierarchyOf: aClass - organizedBy: anOrganization. - - "I have to convert senders to OrderedCollection because CompiledMethod>>#= does not compare the class - where it is installed - Hernan" - ^self - from: anOldSelector - to: aNewSelector - implementors: implementors - senders: (self collectCompiledMethodsOf: senders asOrderedCollection) -! ! -!ChangeSelectorKeepingParameters class methodsFor: 'instance creation' stamp: 'HAW 3/5/2020 21:51:17' prior: 50447712! - from: anOldSelector to: aNewSelector inCategoryOf: aClass organizedBy: anOrganization - - | implementors senders | - - implementors := OrderedCollection new. - senders := OrderedCollection new. - - self - addImplementorsOf: anOldSelector - to: implementors - andSendersTo: senders - inCategory: aClass category - organizedBy: anOrganization. - - ^self from: anOldSelector to: aNewSelector implementors: implementors senders: (self collectCompiledMethodsOf: senders) -! ! -!ChangeSelectorKeepingParameters class methodsFor: 'instance creation' stamp: 'HAW 3/5/2020 21:51:28' prior: 50447729! - from: anOldSelector to: aNewSelector inHierarchyOf: aClass - - | implementors senders | - - implementors := OrderedCollection new. - senders := OrderedCollection new. - - self - addImplementorsOf: anOldSelector - to: implementors - andSendersTo: senders - inHierarchyOf: aClass. - - ^self from: anOldSelector to: aNewSelector implementors: implementors senders: (self collectCompiledMethodsOf: senders) - - ! ! -!ChangeSelectorKeepingParameters class methodsFor: 'instance creation' stamp: 'HAW 3/5/2020 21:51:40' prior: 50447744! - from: anOldSelector to: aNewSelector inSystem: aSystem - - | implementors senders | - - implementors := OrderedCollection new. - senders := OrderedCollection new. - - self - addImplementorsOf: anOldSelector - to: implementors - andSendersTo: senders - inSystem: aSystem. - - ^self from: anOldSelector to: aNewSelector implementors: implementors senders: (self collectCompiledMethodsOf: senders) - ! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 3/5/2020 21:06:18' prior: 50469058! - createSenders - - ^Set new -! ! -!ChangeSelectorApplier methodsFor: 'refactoring - creation' stamp: 'HAW 3/5/2020 19:54:38' prior: 50441688! - createAndApplyRefactoring - - self convertSendersToCompiledMethods. - - self - createRefactoringHandlingRefactoringExceptions; - applyRefactoring; - informChangesToBrowser. - - shouldShowChanges ifTrue: [ self showChanges ] - - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4057-RemovingSendersInRefactoringFix-HernanWilkinson-2020Mar05-19h01m-HAW.002.cs.st----! - -'From Cuis 5.0 [latest update: #4057] on 7 March 2020 at 6:54:33 pm'! -!ChangeSelector class methodsFor: 'implementors and senders' stamp: 'HAW 3/7/2020 18:53:49' prior: 50499154! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders of: aPotentialClassToRefactor - - | potentialImplementor | - - "Phil B. requested to avoid refactoring OMeta2 classes, so right now - it avoids implementors and senders whose compilerClass is not Compiler - It is not common to subclass Compiler and keep Smalltalk syntax, that it is why I - check for Compiler and not for a list of allowed/disallowed compilers - Hernan" - aPotentialClassToRefactor compilerClass = Compiler ifFalse: [^self ]. - - potentialImplementor := aPotentialClassToRefactor compiledMethodAt: anOldSelector ifAbsent: [ nil ]. - potentialImplementor ifNotNil: [ implementors add: potentialImplementor ]. - - (aPotentialClassToRefactor whichSelectorsReferTo: anOldSelector) do: [ :aSelector | - senders add: (MethodReference class: aPotentialClassToRefactor selector: aSelector) ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4058-AvoidRefactoringOtherLanguageMethods-HernanWilkinson-2020Mar07-18h27m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4057] on 7 March 2020 at 8:14:42 pm'! - -"Change Set: 4058-CuisCore-AuthorName-2020Mar06-09h46m -Date: 7 March 2020 -Author: Nahuel Garbezza - -Fix flaky test on the ExtractMethod refactoring"! -!Encoder methodsFor: 'source mapping' stamp: 'RNG 3/6/2020 16:41:44'! - criteriaToSortSourceRangeBetween: parseNodeWithSourceRangeOne and: parseNodeWithSourceRangeTwo - - | sourceRangeOne sourceRangeTwo | - sourceRangeOne _ parseNodeWithSourceRangeOne value. - sourceRangeTwo _ parseNodeWithSourceRangeTwo value. - ^ sourceRangeOne first > sourceRangeTwo first - or: [ sourceRangeOne first = sourceRangeTwo first - and: [ sourceRangeOne last <= sourceRangeTwo last ] ]! ! -!Encoder methodsFor: 'source mapping' stamp: 'RNG 3/6/2020 16:40:40' prior: 50497471! - parseNodesPathAt: aPosition using: completeSourceRanges ifAbsent: aBlockClosure - - | nodesWithRangeAtPosition | - nodesWithRangeAtPosition _ SortedCollection sortBlock: [ :parseNodeWithSourceRangeOne :parseNodeWithSourceRangeTwo | - self criteriaToSortSourceRangeBetween: parseNodeWithSourceRangeOne and: parseNodeWithSourceRangeTwo ]. - - completeSourceRanges associationsDo: [ :nodeAtRange | - self withRangesOf: nodeAtRange including: aPosition do: [ :aRange | - nodesWithRangeAtPosition add: (nodeAtRange key -> aRange) ] ]. - - ^ nodesWithRangeAtPosition - ifEmpty: aBlockClosure - ifNotEmpty: [ nodesWithRangeAtPosition ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4059-ExtractMethodFix-NahuelGarbezza-2020Mar06-09h46m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4057] on 6 March 2020 at 11:09:45 am'! -!ChangeList class methodsFor: 'public access' stamp: 'jmv 3/6/2020 11:08:35' prior: 50370755! - browseFrom: startPosition on: aChangesFileEntry labeled: aLabel - - " - ChangeList browseFrom: Smalltalk lastQuitLogPosition on: Smalltalk currentChangesName labeled: 'Lost changes' - " - - | changeList end | - - aChangesFileEntry readStreamDo: [ :changesFile | - end _ changesFile size. - changeList _ self new - scanFile: changesFile - from: startPosition - to: end. - ]. - - ChangeListWindow open: changeList label: aLabel! ! -!ChangeList class methodsFor: 'public access' stamp: 'jmv 3/6/2020 11:07:19' prior: 16796867! - browseRecent: charCount on: origChangesFileEntry - "Opens a changeList on the end of the specified changes log file" - - | changeList end | - origChangesFileEntry readStreamDo: [ :changesFile | - end _ changesFile size. - changeList _ self new - scanFile: changesFile - from: (0 max: end - charCount) - to: end. - ]. - ChangeListWindow open: changeList label: 'Recent changes'! ! -!ChangeList class methodsFor: 'public access' stamp: 'jmv 3/6/2020 11:07:42' prior: 16796882! - browseRecentLog - "ChangeList browseRecentLog" - "Prompt with a menu of how far back to go to browse the current image's changes log file" - ^ self - browseRecentLogOn: Smalltalk currentChangesName asFileEntry - startingFrom: Smalltalk lastQuitLogPosition! ! -!ChangeList class methodsFor: 'public access' stamp: 'jmv 3/6/2020 11:07:26' prior: 50406208! - browseRecentLogOn: origChangesFileEntry startingFrom: initialPos - "Prompt with a menu of how far back to go when browsing a changes file." - - | end banners positions pos chunk i | - origChangesFileEntry readStreamDo: [ :changesFile | - banners _ OrderedCollection new. - positions _ OrderedCollection new. - end _ changesFile size. - pos _ initialPos. - [pos = 0 - or: [banners size > 20]] "Go back at most 20 image exits" - whileFalse: [ - changesFile position: pos. - chunk _ changesFile nextChunk. - i _ chunk indexOfSubCollection: 'priorSource: ' startingAt: 1. - i > 0 - ifTrue: [ - positions addLast: pos. - banners addLast: (chunk copyFrom: 5 to: i - 2). - pos _ Number readFrom: (chunk copyFrom: i + 13 to: chunk size)] - ifFalse: [ - pos _ 0]]. - ]. - positions addLast: 0. - banners addLast: 'Whole file'. - pos _ (SelectionMenu labelList: banners selections: positions) - startUpWithCaption: 'Browse as far back as...'. - pos - ifNil: [^ self]. - self browseRecent: end - pos on: origChangesFileEntry! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'jmv 3/6/2020 11:08:54' prior: 50370773! - restoreLostChangesManually - - ChangeList browseFrom: LastQuitLogPosition on: self currentChangesName asFileEntry labeled: 'Lost changes' -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4060-fileName-fileEntry-fix-JuanVuletich-2020Mar06-11h06m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4058] on 7 March 2020 at 6:23:55 pm'! - -RectangleLikeMorph subclass: #LayoutMorph - instanceVariableNames: 'direction separation padding cachedMinExtent doAdoptWidgetsColor ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -!classDefinition: #LayoutMorph category: #'Morphic-Layouts' stamp: 'Install-4061-HonorMinimumExtent-fix-JuanVuletich-2020Mar07-18h23m-jmv.001.cs.st 4/1/2020 17:57:15'! -RectangleLikeMorph subclass: #LayoutMorph - instanceVariableNames: 'direction separation padding cachedMinExtent doAdoptWidgetsColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! -!Morph methodsFor: 'geometry' stamp: 'jmv 3/7/2020 18:19:05'! - minimumLayoutExtent - "This returns the minimum extent that the morph may be shrunk to. - It is expressed in the morph own coordinates, like morphExtent." - - | minExtent | - minExtent _ self minimumExtent. - ^ layoutSpec - ifNil: [ minExtent ] - ifNotNil: [ minExtent max: layoutSpec minimumLayoutWidth @ layoutSpec minimumLayoutHeight ]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 3/6/2020 18:01:08'! - fixedOrMinimumLayoutHeight - ^fixedHeight ifNil: [0]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 3/6/2020 18:01:13'! - fixedOrMinimumLayoutWidth - ^fixedWidth ifNil: [0]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 3/6/2020 17:59:40'! - minimumLayoutHeight - "Generally prefer asking the morph itself!!" - - proportionalHeight ifNil: [ ^0 ]. - ^fixedHeight ifNil: [0]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 3/6/2020 17:59:48'! - minimumLayoutWidth - "Generally prefer asking the morph itself!!" - - proportionalWidth ifNil: [ ^0 ]. - ^fixedWidth ifNil: [0]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 3/6/2020 18:02:32'! -proportionaLayoutlHeight - - ^ proportionalHeight ifNil: [ 0 ]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 3/6/2020 18:03:02'! - proportionalLayoutWidth - - ^ proportionalWidth ifNil: [ 0 ]! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 3/7/2020 18:19:15' prior: 50384181! - minimumExtent - "This returns the minimum extent that the morph may be shrunk to. - It is expressed in the morph own coordinates, like morphExtent." - - ^ `1@1`! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 3/7/2020 18:16:34' prior: 16889705! - minimumExtent - | minW minH | - "Figure out the minimum extent for this pane so that either content, or at least required scrollbars, will fit" - minW _ self xtraBorder * 2 + scroller morphWidth min: self scrollBarClass scrollbarThickness * 2. - self vIsScrollbarShowing - ifTrue: [ - minW _ minW + self scrollBarClass scrollbarThickness]. - minH _ self xtraBorder * 2 + scroller morphHeight. - self hIsScrollbarShowing - ifTrue: [ - minH _ minH + self scrollBarClass scrollbarThickness]. - minH _ minH min: self scrollBarClass scrollbarThickness * 2. - ^ (minW + (borderWidth * 2)) @ (minH + (borderWidth * 2))! ! -!BrowserCommentTextMorph methodsFor: 'displaying' stamp: 'jmv 3/6/2020 18:37:46' prior: 16792955! - hidePane - - self hide. - separator visible ifTrue: [ - proportionalHeight _ self layoutSpec proportionaLayoutlHeight. - separatorHeight _ separator layoutSpec fixedOrMinimumLayoutHeight ]. - separator layoutSpec fixedHeight: 0. - self layoutSpec proportionalHeight: 0. - separator ifNotNil: [ separator hide ]! ! -!SystemWindow methodsFor: 'geometry' stamp: 'jmv 3/7/2020 18:16:44' prior: 50384674! - minimumExtent - - ^layoutMorph minimumExtent + (borderWidth * 2) + (0@self labelHeight)! ! -!LayoutMorph methodsFor: 'adjust' stamp: 'jmv 3/7/2020 18:19:33' prior: 50375330! - adjustHorizontallyBy: aLayoutAdjustMorph at: aPoint - | delta l ls r rs lNewWidth rNewWidth i lCurrentWidth rCurrentWidth | - i _ submorphs indexOf: aLayoutAdjustMorph. - l _ self submorphs at: i +1. - ls _ l layoutSpec. - lCurrentWidth _ l morphWidth max: 1. "avoid division by zero" - r _ self submorphs at: i - 1. - rs _ r layoutSpec. - rCurrentWidth _ r morphWidth max: 1. "avoid division by zero" - delta _ aPoint x - aLayoutAdjustMorph referencePosition x. - delta _ delta max: l minimumLayoutExtent x - lCurrentWidth. - delta _ delta min: rCurrentWidth - r minimumLayoutExtent x. - delta = 0 ifTrue: [ ^self ]. - rNewWidth _ rCurrentWidth - delta. - lNewWidth _ lCurrentWidth + delta. - (ls isProportionalWidth and: [ rs isProportionalWidth ]) - ifTrue: [ | leftNewProportion rightNewProportion toDistribute | "If both proportional, update them" - leftNewProportion _ lNewWidth / (lNewWidth + rNewWidth). - rightNewProportion _ 1.0 - leftNewProportion. - toDistribute _ ls proportionalLayoutWidth + rs proportionalLayoutWidth. - ls setProportionalWidth: leftNewProportion * toDistribute. - rs setProportionalWidth: rightNewProportion * toDistribute ] - ifFalse: ["If at least one is fixed, update only the fixed" - ls isProportionalWidth ifFalse: [ - ls fixedOrMorphWidth: lNewWidth ]. - rs isProportionalWidth ifFalse: [ - rs fixedOrMorphWidth: rNewWidth ]]. - self layoutSubmorphs.! ! -!LayoutMorph methodsFor: 'adjust' stamp: 'jmv 3/7/2020 18:19:39' prior: 16863103! - adjustVerticallyBy: aLayoutAdjustMorph at: aPoint - | delta t ts b bs tNewHeight bNewHeight i tCurrentHeight bCurrentHeight | - i _ submorphs indexOf: aLayoutAdjustMorph. - t _ self submorphs at: i +1. - ts _ t layoutSpec. - tCurrentHeight _ t morphHeight max: 1. "avoid division by zero" - b _ self submorphs at: i - 1. - bs _ b layoutSpec. - bCurrentHeight _ b morphHeight max: 1. "avoid division by zero" - delta _ aPoint y - aLayoutAdjustMorph referencePosition y. - delta _ delta max: t minimumLayoutExtent y - tCurrentHeight. - delta _ delta min: bCurrentHeight - b minimumLayoutExtent y. - delta = 0 ifTrue: [ ^self ]. - tNewHeight _ tCurrentHeight + delta. - bNewHeight _ bCurrentHeight - delta. - (ts isProportionalHeight and: [ bs isProportionalHeight ]) - ifTrue: [ | bottomNewProportion toDistribute topNewProportion | "If both proportional, update them" - topNewProportion _ tNewHeight / (tNewHeight + bNewHeight). - bottomNewProportion _ 1.0 - topNewProportion. - toDistribute _ ts proportionaLayoutlHeight + bs proportionaLayoutlHeight. - ts setProportionalHeight: topNewProportion * toDistribute. - bs setProportionalHeight: bottomNewProportion * toDistribute ] - ifFalse: ["If at least one is fixed, update only the fixed" - ts isProportionalHeight ifFalse: [ - ts fixedOrMorphHeight: tNewHeight ]. - bs isProportionalHeight ifFalse: [ - bs fixedOrMorphHeight: bNewHeight ]]. - self layoutSubmorphs! ! -!LayoutMorph methodsFor: 'geometry' stamp: 'jmv 3/7/2020 18:20:11' prior: 16863282! - minimumExtent - "Answer size sufficient to frame my submorphs." - - | width height | - width := self ySeparation. - height := self xSeparation. - (self direction = #vertical) - ifTrue: [ - self submorphsDo: [ :sm | | smMinExtent | - smMinExtent := sm minimumLayoutExtent. - "use maximum width across submorphs" - width := width max: (smMinExtent x max: sm layoutSpec fixedOrMinimumLayoutWidth). - "sum up submorph heights" - height := height + (smMinExtent y max: sm layoutSpec fixedOrMinimumLayoutHeight) + self ySeparation. - ]. - width := width + self xSeparation. - ] - ifFalse: [ - self submorphsDo: [ :sm | | smMinExtent | - smMinExtent := sm minimumLayoutExtent. - "sum up submorphs width" - width := width + (smMinExtent x max: sm layoutSpec fixedOrMinimumLayoutWidth) + self xSeparation. - "use maximum height across submorph" - height := height max: (smMinExtent y max: sm layoutSpec fixedOrMinimumLayoutHeight). - ]. - height := height + self xSeparation. - ]. - - ^ (width @ height) + self extentBorder! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 3/7/2020 18:19:43' prior: 50385334! - layoutSubmorphsHorizontallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - | xSep ySep usableWidth sumOfFixedOrMinimum normalizationFactor availableForPropWidth - fractionalWidths integerWidths theLeft usableHeight boundsTop boundsRight theTop minWidth submorphsToLayout - nextMorph ht wd ls theRight boundsBottom theBottom alternativeWidths count diff i | - - boundsForLayout extent > `2@2` "self minimumExtent" - ifFalse: [ ^self ]. "Too small. Don't bother!!" - - submorphsToLayout := self submorphsToLayout. - xSep := self xSeparation. - ySep := self ySeparation. - usableWidth := boundsForLayout width - ((submorphsToLayout size + 1) * xSep). - sumOfFixedOrMinimum := submorphsToLayout sum: [ :m | m minimumLayoutExtent x max: m layoutSpec fixedOrMinimumLayoutWidth ]. - availableForPropWidth := usableWidth - sumOfFixedOrMinimum max: 0. - normalizationFactor := self proportionalWidthNormalizationFactor. - availableForPropWidth := availableForPropWidth * normalizationFactor. - - fractionalWidths := submorphsToLayout collect: [ :m | m layoutSpec widthFor: availableForPropWidth ]. - "Compute integer widths, mostly rounding but with occasional #floor or #ceiling as needed to keep sum" - integerWidths _ fractionalWidths collect: [ :w | w rounded ]. - diff _ integerWidths sum - fractionalWidths sum rounded. - alternativeWidths _ diff > 0 ifTrue: [ fractionalWidths collect: [ :w | w floor ]] ifFalse: [ fractionalWidths collect: [ :w | w ceiling ]]. - count _ diff abs. - i _ 1. - [ count > 0] whileTrue: [ - (integerWidths at: i) = (alternativeWidths at: i) ifFalse: [ - integerWidths at: i put: (alternativeWidths at: i). - count _ count -1 ]. - i _ i + 1 ]. - minWidth := integerWidths sum. - theLeft := ((usableWidth - minWidth) * (padding ifNil: [0]) max: 0) + boundsForLayout left + xSep. - usableHeight := boundsForLayout height - (ySep * 2) max: 0. - boundsTop := boundsForLayout top + ySep. - boundsRight := boundsForLayout right - xSep. - boundsBottom := boundsForLayout bottom - ySep. - - submorphsToLayout size to: 1 by: -1 do: [ :index | - nextMorph := submorphsToLayout at: index. - "major direction" - wd := integerWidths at: index. - "minor direction" - ls := nextMorph layoutSpec. - ht := (ls heightFor: usableHeight) min: usableHeight. - theTop := ((usableHeight - ht) * ls minorDirectionPadding) floor + boundsTop. - theBottom := (theTop + ht) ceiling min: boundsBottom. - theRight := (theLeft + (wd min: minWidth)) "ceiling "min: boundsRight. - "Set bounds and adjust major direction for next step" - self flag: #jmvVer2. "should extent be set in m's coordinate system? what if its scale is not 1?" - ls usesMorphExtent - ifTrue: [ - nextMorph morphPosition: theLeft floor @ theTop floor ] - ifFalse: [ - nextMorph morphPosition: theLeft floor @ theTop floor extent: theRight - theLeft @ (theBottom - theTop) ]. - theLeft := theRight + xSep - ]! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 3/7/2020 18:19:47' prior: 50385425! - layoutSubmorphsVerticallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - | xSep ySep usableHeight sumOfFixedOrMinimum normalizationFactor availableForPropHeight - fractionalHeights integerHeights theTop usableWidth boundsLeft boundsBottom theLeft minHeight submorphsToLayout - nextMorph ht wd ls theBottom boundsRight theRight alternativeHeights count diff i | - - boundsForLayout extent > `2@2` "self minimumExtent" - ifFalse: [ ^self ]. "Too small. Don't bother!!" - - submorphsToLayout := self submorphsToLayout. - xSep := self xSeparation. - ySep := self ySeparation. - usableHeight := boundsForLayout height - ((submorphsToLayout size + 1) * ySep). - sumOfFixedOrMinimum := submorphsToLayout sum: [ :m | m minimumLayoutExtent y max: m layoutSpec fixedOrMinimumLayoutHeight ]. - availableForPropHeight := usableHeight - sumOfFixedOrMinimum max: 0. - normalizationFactor := self proportionalHeightNormalizationFactor. - availableForPropHeight := availableForPropHeight * normalizationFactor. - - fractionalHeights := submorphsToLayout collect: [ :m | m layoutSpec heightFor: availableForPropHeight ]. - "Compute integer widths, mostly rounding but with occasional #floor or #ceiling as needed to keep sum" - integerHeights _ fractionalHeights collect: [ :w | w rounded ]. - diff _ integerHeights sum - fractionalHeights sum rounded. - alternativeHeights _ diff > 0 ifTrue: [ fractionalHeights collect: [ :w | w floor ]] ifFalse: [ fractionalHeights collect: [ :w | w ceiling ]]. - count _ diff abs. - i _ 1. - [ count > 0] whileTrue: [ - (integerHeights at: i) = (alternativeHeights at: i) ifFalse: [ - integerHeights at: i put: (alternativeHeights at: i). - count _ count -1 ]. - i _ i + 1 ]. - minHeight := integerHeights sum. - theTop := ((usableHeight - minHeight) * (padding ifNil: [0]) max: 0) + boundsForLayout top + ySep. - usableWidth := boundsForLayout width - (xSep * 2) max: 0. - boundsLeft := boundsForLayout left + xSep. - boundsBottom := boundsForLayout bottom - ySep. - boundsRight := boundsForLayout right - xSep. - - submorphsToLayout size to: 1 by: -1 do: [ :index | - nextMorph := submorphsToLayout at: index. - "major direction" - ht := integerHeights at: index. - "minor direction" - ls := nextMorph layoutSpec. - wd := (ls widthFor: usableWidth) min: usableWidth. - theLeft := ((usableWidth - wd) * ls minorDirectionPadding) floor + boundsLeft. - theRight := (theLeft + wd) ceiling min: boundsRight. - theBottom := (theTop + (ht min: minHeight)) "ceiling" min: boundsBottom. - "Set bounds and adjust major direction for next step" - self flag: #jmvVer2. "should extent be set in m's coordinate system? what if its scale is not 1?" - ls usesMorphExtent - ifTrue: [ - nextMorph morphPosition: theLeft floor @ theTop floor ] - ifFalse: [ - nextMorph morphPosition: theLeft floor @ theTop floor extent: theRight - theLeft @ (theBottom - theTop) ]. - theTop := theBottom + ySep - ]! ! -!LayoutMorph methodsFor: 'private' stamp: 'jmv 3/6/2020 18:37:57' prior: 16863569! - proportionalHeightNormalizationFactor - - | sumOfProportional | - sumOfProportional _ self submorphsToLayout sum: [ :m | m layoutSpec proportionaLayoutlHeight ]. - ^1.0 / (sumOfProportional max: 1.0).! ! -!LayoutMorph methodsFor: 'private' stamp: 'jmv 3/6/2020 18:38:18' prior: 16863578! - proportionalWidthNormalizationFactor - - | sumOfProportional | - sumOfProportional _ self submorphsToLayout sum: [ :m | m layoutSpec proportionalLayoutWidth ]. - ^1.0 / (sumOfProportional max: 1.0).! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 3/6/2020 16:06:23' prior: 50359919! -example1 -" - self example1 -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example1. -pane color: Color red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addMorph: (BorderedRectMorph new color: (Color blue); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addMorph: (BorderedRectMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 200 fixedHeight: 200). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #G) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8); - addMorph: (BorderedRectMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (BorderedRectMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -pane morphPosition: 150@130 extent: 400@300. -pane openInWorld! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 3/7/2020 18:20:17' prior: 16864341! - heightFor: availableSpace - "If proportional is zero, answer stored fixed extent, or actual morph extent if undefined. - Otherwise, we do proportional layout, and the stored extent is a minimum extent. - If there is no minimum extent, it should be set to zero." - - ^proportionalHeight isNil - ifTrue: [fixedHeight ifNil: [morph morphHeight]] - ifFalse: [proportionalHeight * availableSpace + morph minimumLayoutExtent y]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 3/7/2020 18:20:21' prior: 16864364! - widthFor: availableSpace - "If proportional is zero, answer stored fixed extent, or actual morph extent if undefined. - Otherwise, we do proportional layout, and the stored extent is a minimum extent. - If there is no minimum extent, it should be set to zero." - - ^proportionalWidth isNil - ifTrue: [fixedWidth ifNil: [morph morphWidth]] - ifFalse: [proportionalWidth * availableSpace + morph minimumLayoutExtent x]! ! - -LayoutSpec removeSelector: #fixedWidth! - -!methodRemoval: LayoutSpec #fixedWidth stamp: 'Install-4061-HonorMinimumExtent-fix-JuanVuletich-2020Mar07-18h23m-jmv.001.cs.st 4/1/2020 17:57:15'! -fixedWidth - "If proportional is zero, answer stored fixed extent, or actual morph extent if undefined. (no proportional extent is computed) - Otherwise, we do proportional layout, and the stored extent is a minimum extent, so we don't really a fixed extent." - proportionalWidth ifNil: [ ^ fixedWidth ifNil: [ morph morphWidth ] ]. - ^ 0! - -LayoutSpec removeSelector: #proportionalHeight! - -!methodRemoval: LayoutSpec #proportionalHeight stamp: 'Install-4061-HonorMinimumExtent-fix-JuanVuletich-2020Mar07-18h23m-jmv.001.cs.st 4/1/2020 17:57:15'! -proportionalHeight - - ^ proportionalHeight ifNil: [ 0 ]! - -LayoutSpec removeSelector: #fixedHeight! - -!methodRemoval: LayoutSpec #fixedHeight stamp: 'Install-4061-HonorMinimumExtent-fix-JuanVuletich-2020Mar07-18h23m-jmv.001.cs.st 4/1/2020 17:57:15'! -fixedHeight - "If proportional is zero, answer stored fixed extent, or actual morph extent if undefined. (no proportional extent is computed) - Otherwise, we do proportional layout, and the stored extent is a minimum extent, so we don't really a fixed extent." - proportionalHeight ifNil: [ ^ fixedHeight ifNil: [ morph morphHeight ] ]. - ^ 0! - -LayoutSpec removeSelector: #proportionalWidth! - -!methodRemoval: LayoutSpec #proportionalWidth stamp: 'Install-4061-HonorMinimumExtent-fix-JuanVuletich-2020Mar07-18h23m-jmv.001.cs.st 4/1/2020 17:57:15'! -proportionalWidth - - ^ proportionalWidth ifNil: [ 0 ]! - -LayoutMorph removeSelector: #fontPreferenceChanged! - -!methodRemoval: LayoutMorph #fontPreferenceChanged stamp: 'Install-4061-HonorMinimumExtent-fix-JuanVuletich-2020Mar07-18h23m-jmv.001.cs.st 4/1/2020 17:57:15'! -fontPreferenceChanged - "Something may have changed. - Update my cache with the current size" - - super fontPreferenceChanged. - cachedMinExtent := self calculateMinimumExtent ! - -LayoutMorph removeSelector: #calculateMinimumExtent! - -!methodRemoval: LayoutMorph #calculateMinimumExtent stamp: 'Install-4061-HonorMinimumExtent-fix-JuanVuletich-2020Mar07-18h23m-jmv.001.cs.st 4/1/2020 17:57:15'! -calculateMinimumExtent - "Answer size sufficient to frame my submorphs." - - | width height | - width := self ySeparation. - height := self xSeparation. - (self direction = #vertical) - ifTrue: [ - self submorphsDo: [ :sm | | smMinExtent | - smMinExtent := sm minimumExtent. - "use maximum width across submorphs" - width := width max: smMinExtent x. - "sum up submorph heights" - height := height + smMinExtent y + self ySeparation. - ]. - width := width + self xSeparation. - ] - ifFalse: [ - self submorphsDo: [ :sm | | smMinExtent | - smMinExtent := sm minimumExtent. - "sum up submorphs width" - width := width + smMinExtent x + self xSeparation. - "use maximum height across submorph" - height := height max: smMinExtent y. - ]. - height := height + self xSeparation. - ]. - - ^ (width @ height) + self extentBorder.! - -LayoutMorph removeSelector: #minPaneHeightForReframe! - -!methodRemoval: LayoutMorph #minPaneHeightForReframe stamp: 'Install-4061-HonorMinimumExtent-fix-JuanVuletich-2020Mar07-18h23m-jmv.001.cs.st 4/1/2020 17:57:15'! -minPaneHeightForReframe - ^AbstractFont default lineSpacing + 10! - -LayoutMorph removeSelector: #minPaneWidthForReframe! - -!methodRemoval: LayoutMorph #minPaneWidthForReframe stamp: 'Install-4061-HonorMinimumExtent-fix-JuanVuletich-2020Mar07-18h23m-jmv.001.cs.st 4/1/2020 17:57:15'! -minPaneWidthForReframe - - ^(self submorphs collect: [ :m | m minimumExtent x ]) max! - -SystemWindow removeSelector: #minPaneWidthForReframe! - -!methodRemoval: SystemWindow #minPaneWidthForReframe stamp: 'Install-4061-HonorMinimumExtent-fix-JuanVuletich-2020Mar07-18h23m-jmv.001.cs.st 4/1/2020 17:57:15'! -minPaneWidthForReframe - ^ScrollBar scrollbarThickness * 3! - -SystemWindow removeSelector: #minPaneHeightForReframe! - -!methodRemoval: SystemWindow #minPaneHeightForReframe stamp: 'Install-4061-HonorMinimumExtent-fix-JuanVuletich-2020Mar07-18h23m-jmv.001.cs.st 4/1/2020 17:57:15'! -minPaneHeightForReframe - ^AbstractFont default lineSpacing + 10! - -Morph removeSelector: #minPaneWidthForReframe! - -!methodRemoval: Morph #minPaneWidthForReframe stamp: 'Install-4061-HonorMinimumExtent-fix-JuanVuletich-2020Mar07-18h23m-jmv.001.cs.st 4/1/2020 17:57:15'! -minPaneWidthForReframe - ^ self minimumExtent x! - -RectangleLikeMorph subclass: #LayoutMorph - instanceVariableNames: 'direction separation padding doAdoptWidgetsColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -!classDefinition: #LayoutMorph category: #'Morphic-Layouts' stamp: 'Install-4061-HonorMinimumExtent-fix-JuanVuletich-2020Mar07-18h23m-jmv.001.cs.st 4/1/2020 17:57:15'! -RectangleLikeMorph subclass: #LayoutMorph - instanceVariableNames: 'direction separation padding doAdoptWidgetsColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4061-HonorMinimumExtent-fix-JuanVuletich-2020Mar07-18h23m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4061] on 8 March 2020 at 4:29:11 pm'! -!LayoutMorph methodsFor: 'geometry' stamp: 'KenD 2/22/2020 16:55:11'! - refreshExtent - "Flush cache & recalculate" - self morphExtent: (self morphExtent max: self minimumExtent)! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 3/8/2020 16:27:44' prior: 50499493! - minimumLayoutExtent - "This returns the minimum extent that the morph may be shrunk to, when resizing LayoutMorphs or when adjusting a LayoutAdjustingMorph. - It is expressed in the morph own coordinates, like morphExtent." - - | minExtent | - minExtent _ self minimumExtent. - ^ layoutSpec - ifNil: [ minExtent ] - ifNotNil: [ minExtent max: layoutSpec minimumLayoutWidth @ layoutSpec minimumLayoutHeight ]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 3/8/2020 16:28:31' prior: 50499506! - fixedOrMinimumLayoutHeight - ^fixedHeight ifNil: [ morph morphHeight ]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 3/8/2020 16:28:20' prior: 50499510! - fixedOrMinimumLayoutWidth - ^fixedWidth ifNil: [ morph morphWidth ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4062-HonorMinimumExtent-part2-JuanVuletich-2020Mar08-16h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4059] on 8 March 2020 at 1:47:57 pm'! -!ScrollBar methodsFor: 'geometry' stamp: 'KenD 3/8/2020 13:40:38'! - fontPreferenceChanged - "Rescale" - - self recreateSubmorphs! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4063-CuisCoreScrollRsz-KenD-2020Mar08-13h37m-KenD.001.cs.st----! - -'From Cuis 5.0 [latest update: #4063] on 9 March 2020 at 10:14:50 am'! -!Morph methodsFor: 'testing' stamp: 'jmv 3/9/2020 10:11:38'! - isOwnedByWorld - ^owner is: #PasteUpMorph! ! -!PasteUpMorph methodsFor: 'testing' stamp: 'jmv 3/9/2020 10:13:47'! - is: aSymbol - ^ aSymbol == #PasteUpMorph or: [ super is: aSymbol ]! ! -!LayoutMorph methodsFor: 'accessing' stamp: 'KenD 2/24/2020 14:16:35'! - addMorphFrontFromWorldPosition: aMorph - - super addMorphFrontFromWorldPosition: aMorph. - self refreshExtent. -! ! -!PasteUpMorph methodsFor: 'geometry' stamp: 'jmv 3/9/2020 09:55:00' prior: 50495880! - fontPreferenceChanged - self recreateDefaultDesktop. - self submorphsDo: [ :m | - m morphExtent: (m morphExtent max: m minimumExtent). - m fontPreferenceChanged ]! ! -!SystemWindow methodsFor: 'geometry' stamp: 'jmv 3/9/2020 09:52:24' prior: 50499581! - minimumExtent - - ^layoutMorph minimumExtent + (borderWidth * 2) + (0@self labelHeight) max: self titleBarButtonsExtent x * 6 @ 0! ! -!LayoutMorph methodsFor: 'geometry' stamp: 'jmv 3/9/2020 10:14:14' prior: 50500185! - refreshExtent - "Flush cache & recalculate" - (self isOwnedByWorld or: [self isOwnedByHand]) ifTrue: [ - self morphExtent: (self morphExtent max: self minimumExtent) ]! ! -!LayoutMorph methodsFor: 'initialization' stamp: 'KenD 2/22/2020 11:41:51' prior: 16863292! - beColumn - direction _ #vertical. - self padding: #center. - self refreshExtent.! ! -!LayoutMorph methodsFor: 'initialization' stamp: 'KenD 2/22/2020 11:41:57' prior: 16863297! - beRow - direction _ #horizontal. - self padding: #left. - self refreshExtent.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4064-MinExtent-furtherTweaks-JuanVuletich-2020Mar09-10h06m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4064] on 11 March 2020 at 2:32:08 pm'! -!Morph methodsFor: 'drawing' stamp: 'jmv 3/11/2020 14:26:26'! - imageForm: extent depth: depth - | canvas | - canvas _ BitBltCanvas depth: depth over: (self morphPosition extent: (self morphExtent min: extent)). - canvas fullDraw: self. - ^ canvas form! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 3/11/2020 14:26:57' prior: 16874111! - icon - ^ (self imageForm: 400@300 depth: 32) - ifNil: [ Theme current morphsIcon ] - ifNotNil: [ :form | form icon ]! ! -!Morph methodsFor: 'printing' stamp: 'jmv 3/11/2020 14:27:36' prior: 50333020! - printOn: aStream - "Add the identity of the receiver to a stream" - aStream isText - ifTrue: [ - aStream - withAttribute: (TextAnchor new anchoredFormOrMorph: (owner ifNil: [self] ifNotNil: [self imageForm: 32@32 depth: 32])) - do: [ aStream nextPut: $* ]. - ^ self]. - super printOn: aStream. "a(n) className" - aStream - nextPut: $(; - print: self identityHash; - nextPut: $). - self valueOfProperty: #morphName ifPresentDo: [ :x | aStream nextPutAll: x asString]! ! -!SystemWindow class methodsFor: 'top window' stamp: 'jmv 3/11/2020 14:30:03' prior: 16926881! - noteTopWindowIn: aWorld but: aWindow - | newTop | - "TopWindow must be nil or point to the top window in this project." - TopWindow _ nil. - aWorld ifNil: [^ nil]. - newTop := aWorld submorphs - detect: [:m | (m is: #SystemWindow) and: [m visible and: [m ~~ aWindow]]] - ifNone: [^nil]. - newTop activate. - ^newTop! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 3/11/2020 14:27:17' prior: 50431931! - addButtonFor: aMorph - - | button | - aMorph == self ifFalse: [ - button _ HoverableButtonMorph - model: aMorph - stateGetter: nil - action: #endPreviewAndToggleCollapseOrShow - onMouseEnterSend: #beginPreview - onMouseLeaveSend: #endPreview. - button - color: self color; - icon: (aMorph imageForm: 400@300 depth: 32); - setBalloonText: #label. - button icon: button magnifiedIcon. - viewBox - addMorph: button - fixedWidth: self defaultHeight ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4065-AvoidPotentialHugeFormAllocation-JuanVuletich-2020Mar11-14h17m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4064] on 11 March 2020 at 2:48:24 pm'! -!Preferences class methodsFor: 'standard queries' stamp: 'jmv 3/11/2020 14:47:53'! - autoNumberUserChanges - ^ self - valueOfFlag: #autoNumberUserChanges - ifAbsent: [ true ].! ! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'jmv 3/11/2020 14:47:57' prior: 50496840! - assureStartupStampLogged - "If there is a startup stamp not yet actually logged to disk, do it now." - | changesFile directory oldUserChanges oldUserChangesName | - StartupStamp ifNil: [^ self]. - (SourceFiles notNil and: [(changesFile _ SourceFiles at: 2) notNil]) ifTrue: [ - changesFile isReadOnly ifFalse: [ - changesFile setToEnd; newLine; newLine. - changesFile nextChunkPut: StartupStamp asString; newLine. - self forceChangesToDisk ]]. - Preferences autoNumberUserChanges ifTrue: [ - oldUserChanges _ Smalltalk defaultUserChangesName asFileEntry. - oldUserChanges exists ifTrue: [ - directory _ oldUserChanges parent. - oldUserChangesName _ directory nextNameFor: oldUserChanges nameWithoutExtension extension: 'changes'. - oldUserChanges rename: oldUserChangesName ]]. - Smalltalk defaultUserChangesName asFileEntry appendStreamDo: [ :stream | - stream newLine; newLine. - stream nextChunkPut: StartupStamp asString; newLine ]. - StartupStamp _ nil! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4066-AutoNumberUserChangesPrefernce-JuanVuletich-2020Mar11-14h32m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4064] on 11 March 2020 at 2:59:20 pm'! -!SHTextStyler methodsFor: 'styling' stamp: 'jmv 3/11/2020 14:57:11' prior: 16903138! - formatAndStyle: text allowBackgroundStyleProcess: aBoolean - "Do the styling on a copy of the model text. - After finishing, send it to the model, by triggering #shoutStyled - The model should grab the TextAttributes we added to the copy, as appropriate." - self terminateBackgroundStylingProcess. - formattedText _ text. - self privateFormatAndConvert. - (aBoolean and: [formattedText size > 4096]) - ifTrue: [ - formattedText size < 65536 ifTrue: [ - self styleInBackgroundProcess ]] - ifFalse: [ - self privateStyle. - textModel changed: #shoutStyled ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4067-DontShoutLargeText-JuanVuletich-2020Mar11-14h48m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4067] on 11 March 2020 at 3:17:47 pm'! -!LayoutAdjustingMorph methodsFor: 'stepping' stamp: 'jmv 3/11/2020 15:17:12' prior: 50471143! - stepAt: millisecondSinceLast - "got the #mouseLeave: message" - | p | - hand ifNil: [ - Cursor currentCursor == self cursor ifTrue: [ Cursor defaultCursor activateCursor ]. - ^ self stopStepping ]. - "hasn't got the #mouseLeave: message (yet)" - p _ hand morphPosition. - hand lastMouseEvent mouseButton1Pressed - ifTrue: [ - self adjustOwnerAt: p. - (Preferences cheapWindowReframe or: [ millisecondSinceLast > 200]) ifTrue: [ - owner morphBoundsInWorld newRectFrom: [ :f | - self adjustOwnerAt: Sensor mousePoint. - owner morphBoundsInWorld ]]] - ifFalse: [ - self stopStepping. - "If the button was unpressed outside the morph (can happen if you try to go outside container), - we might not get the #mouseLeave: message" - (self morphContainsPoint: (self internalizeFromWorld: p)) ifFalse: [ - hand _ nil. - Cursor defaultCursor activateCursor ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4068-cheapWindowReframeIfTooSlow-JuanVuletich-2020Mar11-15h12m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4068] on 11 March 2020 at 3:31:36 pm'! -!LayoutMorph methodsFor: 'initialization' stamp: 'jmv 3/11/2020 15:31:04' prior: 50500275! - beColumn - direction _ #vertical. - padding ifNil: [self padding: #center]. - self refreshExtent.! ! -!LayoutMorph methodsFor: 'initialization' stamp: 'jmv 3/11/2020 15:31:13' prior: 50500281! - beRow - direction _ #horizontal. - padding ifNil: [self padding: #left]. - self refreshExtent.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4069-keepPaddingIfAtAllPossible-JuanVuletich-2020Mar11-15h30m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4069] on 13 March 2020 at 8:19:20 am'! -!Duration methodsFor: 'squeak protocol' stamp: 'jmv 3/13/2020 08:18:50' prior: 50342313! - printOn: aStream - "Format as per ANSI 5.8.2.16: [-]D:HH:MM:SS[.S] - (Duration days: 2 hours: 3 minutes: 16 seconds: 43) printString = '2:03:16:43' - " - | d h m s n | - d _ self days abs. - h _ self hours abs. - m _ self minutes abs. - s _ self seconds abs truncated. - n _ self nanoSeconds abs. self negative ifTrue: [ aStream nextPut: $- ]. - d printOn: aStream. aStream nextPut: $:. - h printOn: aStream length: 2 zeroPadded: true.aStream nextPut: $:. - m printOn: aStream length: 2 zeroPadded: true.aStream nextPut: $:. - s printOn: aStream length: 2 zeroPadded: true. - n = 0 ifFalse: [ - | z ps | - aStream nextPut: $.. - ps _ n printString padded: #left to: 9 with: $0. - z _ ps findLast: [ :c | c digitValue > 0 ]. - z _ #(3 6 9) detect: [ :ez | ez >= z ]. "print either milliseconds, microseconds or nanoseconds" - ps from: 1 to: z do: [ :c | aStream nextPut: c ] ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4070-Duration-printString-tweak-JuanVuletich-2020Mar13-08h18m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4070] on 18 March 2020 at 10:57:34 am'! -!CharacterScanner methodsFor: 'scanning' stamp: 'jmv 1/25/2014 13:42' prior: 50460103! - scanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernValue - "Primitive. This is the inner loop of text display--but see - scanCharactersFrom: to:rightX: which would get the string, - stopConditions and displaying from the instance. March through source - String from startIndex to stopIndex. If any character is flagged with a - non-nil entry in stops, then return the corresponding value. Determine - width of each character from xTable, indexed by map. - If dextX would exceed rightX, then return stops at: 258. - Advance destX by the width of the character. If stopIndex has been - reached, then return stops at: 257. Optional. - See Object documentation whatIsAPrimitive." - | nextDestX char | - - lastIndex _ startIndex. - [ lastIndex <= stopIndex ] - whileTrue: [ - char _ sourceString at: lastIndex. - "stops are only defined for the first 256 characters. - If we (ever) handle Character like objects beyond those in ISO-8859-15, - thenf #iso8859s15Code shound answer nil!!" - char iso8859s15Code ifNotNil: [ :code | - (stops at: code + 1) ifNotNil: [ :stop | ^stop ]]. - nextDestX _ destX + (font widthOf: char). - nextDestX > rightX ifTrue: [ - ^stops at: CharacterScanner crossedXCode ]. - destX _ nextDestX. - lastIndex _ lastIndex + 1 ]. - lastIndex _ stopIndex. - ^ stops at: CharacterScanner endOfRunCode! ! -!CompositionScanner methodsFor: 'scanning' stamp: 'jmv 9/2/2018 23:27:51' prior: 50460152! - composeFrom: startIndex inRectangle: lineRectangle firstLine: firstLine leftSide: leftSide rightSide: rightSide - - "Answer an instance of TextLineInterval that represents the next line in the paragraph." - | runLength stopCondition xtraSpaceBefore spaceAfterParagraph | - - lastTabIndex _ lastIndex _ startIndex. "scanning sets last index" - destY _ lineRectangle top. - lineHeight _ baseline _ 0. "Will be increased by setFont" - self setFont. - self setStopConditions. - - "Set up margins" - leftMargin _ lineRectangle left. - rightMargin _ lineRectangle right. - xtraSpaceBefore _ 0. - spaceAfterParagraph _ 0. - paragraphStyle ifNotNil: [ - leftSide ifTrue: [ - leftMargin _ leftMargin + - ((firstLine and: [ paragraphStyle isListStyle not ]) - ifTrue: [ paragraphStyle firstIndent ] - ifFalse: [ paragraphStyle restIndent ])]. - rightSide ifTrue: [ - rightMargin _ rightMargin - paragraphStyle rightIndent]. - firstLine ifTrue: [ xtraSpaceBefore _ paragraphStyle spaceBefore ]. - spaceAfterParagraph _ paragraphStyle spaceAfter ]. - lastTabX _ destX _ spaceX _ leftMargin. - - runLength _ text runLengthFor: startIndex. - runStopIndex _ lastIndex + runLength - 1. - line _ (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0) - rectangle: lineRectangle. - line isFirstLine: firstLine. - spaceCount _ 0. - lastLineBreakingSpace _ 0. - leftMargin _ destX. - line leftMargin: leftMargin. - - self placeEmbeddedObject. - [ - stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex - in: text string rightX: rightMargin stopConditions: stopConditions - kern: font baseKern. - "See setStopConditions for stopping conditions for composing." - (self perform: stopCondition) ifTrue: [ - ^ line - lineHeight: lineHeight + xtraSpaceBefore + - (stopCondition == #doNewLine ifTrue: [spaceAfterParagraph] ifFalse: [0]) - baseline: baseline + xtraSpaceBefore ] - ] repeat! ! - -AbstractFont removeSelector: #rightOffsetAt:! - -!methodRemoval: AbstractFont #rightOffsetAt: stamp: 'Install-4071-Font-smallSimplification-JuanVuletich-2020Mar18-10h56m-jmv.001.cs.st 4/1/2020 17:57:16'! -rightOffsetAt: aCharacter - ^ 0! - -AbstractFont removeSelector: #leftOffsetAt:! - -!methodRemoval: AbstractFont #leftOffsetAt: stamp: 'Install-4071-Font-smallSimplification-JuanVuletich-2020Mar18-10h56m-jmv.001.cs.st 4/1/2020 17:57:16'! -leftOffsetAt: aCharacter - ^ 0! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4071-Font-smallSimplification-JuanVuletich-2020Mar18-10h56m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4071] on 21 March 2020 at 10:32:12 am'! -!AbstractFont class methodsFor: 'initialization' stamp: 'jmv 3/21/2020 10:30:25'! - assignmentGlyphSelectorPreferenceChanged - "Subclasses should adjust their instances accordingly."! ! -!StrikeFont class methodsFor: 'initialization' stamp: 'jmv 3/21/2020 10:18:08'! - assignmentGlyphSelectorPreferenceChanged - self allInstancesDo: [ :each | each reset ]! ! -!Preferences class methodsFor: 'shout' stamp: 'jmv 3/21/2020 10:30:40' prior: 16893889! - useAssignmentGlyphLeftArrow - " - Preferences useAssignmentGlyphLeftArrow - " - Preferences setPreference: #assignmentGlyphSelector toValue: #useLeftArrow. - AbstractFont withAllSubclassesDo: [ :fontClass | fontClass assignmentGlyphSelectorPreferenceChanged ].! ! -!Preferences class methodsFor: 'shout' stamp: 'jmv 3/21/2020 10:30:45' prior: 16893898! - useAssignmentGlyphRightArrow - " - Preferences useAssignmentGlyphRightArrow - " - Preferences setPreference: #assignmentGlyphSelector toValue: #useRightArrow. - AbstractFont withAllSubclassesDo: [ :fontClass | fontClass assignmentGlyphSelectorPreferenceChanged ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4072-AssignmentGlyphPrefRefacor-JuanVuletich-2020Mar21-10h29m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4072] on 22 March 2020 at 11:37:21 pm'! -!Character class methodsFor: 'converting' stamp: 'jmv 3/22/2020 23:19:17'! - nextCodePointBytesFromUtf8: anUtf8Stream into: aBlock - "anUtf8Stream can be over a ByteArray. - See senders." - - | byte1 byte2 byte3 byte4 | - byte1 _ anUtf8Stream next. - byte1 < 128 ifTrue: [ "single byte" - ^ aBlock value: byte1 value: nil value: nil value: nil ]. - - "At least 2 bytes" - byte2 _ anUtf8Stream next. - (byte2 bitAnd: 16rC0) = 16r80 ifFalse: [^nil]. "invalid UTF-8" - (byte1 bitAnd: 16rE0) = 192 ifTrue: [ "two bytes" - ^ aBlock value: byte1 value: byte2 value: nil value: nil ]. - - "At least 3 bytes" - byte3 _ anUtf8Stream next. - (byte3 bitAnd: 16rC0) = 16r80 ifFalse: [^nil]. "invalid UTF-8" - (byte1 bitAnd: 16rF0) = 224 ifTrue: [ "three bytes" - ^ aBlock value: byte1 value: byte2 value: byte3 value: nil ]. - - "4 bytes" - byte4 _ anUtf8Stream next. - (byte4 bitAnd: 16rC0) = 16r80 ifFalse: [^nil]. "invalid UTF-8" - (byte1 bitAnd: 16rF8) = 240 ifTrue: [ "four bytes" - ^ aBlock value: byte1 value: byte2 value: byte3 value: byte4 ]. - - ^nil! ! -!Character class methodsFor: 'converting' stamp: 'jmv 3/22/2020 23:33:20' prior: 16801277! - nextUnicodeCodePointFromUtf8: anUtf8Stream - "anUtf8Stream can be over a ByteArray - Answer nil if conversion not possible, because of invalid UTF-8. - Also answer nil for codePoint U+FEFF (BOM, unneededly added by Win clipboard)" - - ^ self - nextCodePointBytesFromUtf8: anUtf8Stream - into: [ :byte1 :byte2 :byte3 :byte4 | - byte4 notNil - ifTrue: [ ((byte1 bitAnd: 16r7) bitShift: 18) + ((byte2 bitAnd: 63) bitShift: 12) + ((byte3 bitAnd: 63) bitShift: 6) + (byte4 bitAnd: 63) ] - ifFalse: [ - byte3 notNil - ifTrue: [ | codePoint | - codePoint _ ((byte1 bitAnd: 15) bitShift: 12) + ((byte2 bitAnd: 63) bitShift: 6) + (byte3 bitAnd: 63). - codePoint = 16rFEFF - ifFalse: [ codePoint ] - ifTrue: [ nil ]] - ifFalse: [ - byte2 notNil - ifTrue: [ ((byte1 bitAnd: 31) bitShift: 6) + (byte2 bitAnd: 63) ] - ifFalse: [ byte1 ]]]]! ! - -Character class removeSelector: #nextCodePointBytesFromUtf8:ifOneByte:ifTwoBytes:ifThreeBytes:ifFourBytes:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4073-RefactoringCharacter-JuanVuletich-2020Mar22-23h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4073] on 24 March 2020 at 10:39:45 am'! -!LayoutMorph methodsFor: 'geometry' stamp: 'jmv 3/24/2020 10:23:22' prior: 50499680! - minimumExtent - "Answer size sufficient to frame my submorphs." - - | width height | - width := self ySeparation. - height := self xSeparation. - (self direction = #vertical) - ifTrue: [ - self submorphsDo: [ :sm | | smMinExtent | - smMinExtent := sm minimumLayoutExtent. - "use maximum width across submorphs" - width := width max: (smMinExtent x max: sm layoutSpec fixedOrMinimumLayoutWidth). - "sum up submorph heights" - height := height + (smMinExtent y max: sm layoutSpec fixedOrMinimumLayoutHeight) + self ySeparation. - ]. - width := width + self xSeparation. - ] - ifFalse: [ - self submorphsDo: [ :sm | | smMinExtent | - smMinExtent := sm minimumLayoutExtent. - "sum up submorphs width" - width := width + (smMinExtent x max: sm layoutSpec fixedOrMinimumLayoutWidth) + self xSeparation. - "use maximum height across submorph" - height := height max: (smMinExtent y max: sm layoutSpec fixedOrMinimumLayoutHeight). - ]. - height := height + self ySeparation. - ]. - - ^ (width @ height) + self extentBorder! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4074-LayoutFix-JuanVuletich-2020Mar24-10h23m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #3964] on 21 March 2020 at 3:51:01 pm'! - -ChangeListElement subclass: #ChangeRecord - instanceVariableNames: 'file position type class category meta stamp prior isTest overrides ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #ChangeRecord category: #'Tools-Changes' stamp: 'Install-4075-MethodOverrideChange-MatiasDinota-2020Jan02-09h08m-MGD.1.cs.st 4/1/2020 17:57:16'! -ChangeListElement subclass: #ChangeRecord - instanceVariableNames: 'file position type class category meta stamp prior isTest overrides' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! -!ChangeList methodsFor: 'scanning' stamp: 'MGD 3/17/2020 19:35:38'! -overridenMethodReferenceFrom: tokens - - | overridenMethodReference tagIndex | - - tagIndex _ tokens indexOf: #overrides: ifAbsent: [ ^ nil ]. - overridenMethodReference _ tokens at: tagIndex + 1. - - ^ overridenMethodReference -! ! -!ChangeList methodsFor: 'scanning' stamp: 'MGD 3/17/2020 19:37:43'! - scanCategory: category class: class meta: meta stamp: stamp prior: aPriorMethod overrides: anOverridenMethod - - | itemPosition method | - - [ - itemPosition _ file position. - method _ file nextChunk. - method notEmpty ] whileTrue: [ "done when double terminators" - self - addItem: (ChangeRecord new - file: file - position: itemPosition - type: #method - class: class - category: category - meta: meta - stamp: stamp - prior: aPriorMethod - overrides: anOverridenMethod) - text: 'method: ' , class , (meta ifTrue: [' class '] ifFalse: [' ']) - , (((Smalltalk at: class ifAbsent: [Object class]) parserClass selectorFrom: method) ifNil: ['']) - , (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp])]! ! -!ClassDescription methodsFor: 'fileIn/Out'! - printCategoryChunk: category on: aFileStream withStamp: changeStamp priorMethod: priorMethod overridesMethod: overridenMethod - "Print a method category preamble. This must have a category name. - It may have an author/date stamp, and it may have a prior source link. - If it has a prior source link, it MUST have a stamp, even if it is empty." - -"The current design is that changeStamps and prior source links are preserved in the changes file. All fileOuts include changeStamps. Condensing sources, however, eliminates all stamps (and links, natch)." - - aFileStream newLine; nextPut: $!!. - aFileStream nextChunkPut: (String streamContents: [ :strm | - strm nextPutAll: self name; nextPutAll: ' methodsFor: '; print: category asString. - (changeStamp notNil and: [ - changeStamp size > 0 or: [priorMethod notNil]]) ifTrue: [ - strm nextPutAll: ' stamp: '; print: changeStamp]. - priorMethod notNil ifTrue: [ - strm nextPutAll: ' prior: '; print: priorMethod sourcePointer]. - overridenMethod notNil ifTrue: [ - strm nextPutAll: ' overrides: '; print: overridenMethod sourcePointer] - ]). -! ! -!CompiledMethod methodsFor: 'source code management' stamp: 'MGD 3/17/2020 18:12:26'! - putSource: sourceStr fromParseNode: methodNode class: class category: catName - withStamp: changeStamp inFile: fileIndex priorMethod: priorMethod overridesMethod: overridenMethod - - ^ self putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble: [ :file | - class - printCategoryChunk: catName - on: file - withStamp: changeStamp - priorMethod: priorMethod - overridesMethod: overridenMethod. - file newLine ]! ! -!ChangeRecord methodsFor: 'access' stamp: 'MGD 3/17/2020 19:40:04'! - overridesASuperclassMethod - ^ overrides notNil ! ! -!ChangeRecord methodsFor: 'initialization' stamp: 'MGD 3/17/2020 19:39:04'! - file: aFile position: aPosition type: aType class: aClassName category: aClassCategory meta: isMeta stamp: aStamp prior: aPrior overrides: anOverridenMethod - - self file: aFile position: aPosition type: aType. - class _ aClassName. - category _ aClassCategory. - meta _ isMeta. - stamp _ aStamp. - prior _ aPrior. - overrides _ anOverridenMethod.! ! -!ChangeList methodsFor: 'scanning' stamp: 'MGD 3/17/2020 19:35:05' prior: 50479653! - scanMethodDefinition: tokens - - | stamp className priorMethod overridenMethod | - - className _ tokens first. - stamp _ self stampFrom: tokens. - priorMethod _ self priorMethodReferenceFrom: tokens. - overridenMethod _ self overridenMethodReferenceFrom: tokens. - - tokens second == #methodsFor: ifTrue: [ - ^ self scanCategory: tokens third class: className meta: false stamp: stamp prior: priorMethod overrides: overridenMethod ]. - - tokens third == #methodsFor: ifTrue: [ - ^ self scanCategory: tokens fourth class: className meta: true stamp: stamp prior: priorMethod overrides: overridenMethod ]. - - self error: 'Unsupported method definition' -! ! -!ClassDescription methodsFor: 'private' stamp: 'MGD 3/17/2020 19:08:00' prior: 16807087! -logMethodSource: aText forMethodWithNode: aCompiledMethodWithNode inCategory: category withStamp: changeStamp notifying: requestor - | priorMethodOrNil overridenMethodOrNil | - - priorMethodOrNil := self compiledMethodAt: aCompiledMethodWithNode selector ifAbsent: nil. - overridenMethodOrNil := self superclass ifNotNil: [ self superclass lookupSelector: aCompiledMethodWithNode selector ]. - - aCompiledMethodWithNode method putSource: aText asString - fromParseNode: aCompiledMethodWithNode node - class: self category: category withStamp: changeStamp - inFile: 2 priorMethod: priorMethodOrNil overridesMethod: overridenMethodOrNil.! ! - -ChangeList removeSelector: #scanCategory:class:meta:stamp:prior:! - -!methodRemoval: ChangeList #scanCategory:class:meta:stamp:prior: stamp: 'Install-4075-MethodOverrideChange-MatiasDinota-2020Jan02-09h08m-MGD.1.cs.st 4/1/2020 17:57:16'! -scanCategory: category class: class meta: meta stamp: stamp prior: aPriorMethod - - | itemPosition method | - - [ - itemPosition _ file position. - method _ file nextChunk. - method notEmpty ] whileTrue: [ "done when double terminators" - self - addItem: (ChangeRecord new - file: file - position: itemPosition - type: #method - class: class - category: category - meta: meta - stamp: stamp - prior: aPriorMethod) - text: 'method: ' , class , (meta ifTrue: [' class '] ifFalse: [' ']) - , (((Smalltalk at: class ifAbsent: [Object class]) parserClass selectorFrom: method) ifNil: ['']) - , (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp])]! - -ChangeListElement subclass: #ChangeRecord - instanceVariableNames: 'file position type class category meta stamp prior isTest overrides' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #ChangeRecord category: #'Tools-Changes' stamp: 'Install-4075-MethodOverrideChange-MatiasDinota-2020Jan02-09h08m-MGD.1.cs.st 4/1/2020 17:57:16'! -ChangeListElement subclass: #ChangeRecord - instanceVariableNames: 'file position type class category meta stamp prior isTest overrides' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4075-MethodOverrideChange-MatiasDinota-2020Jan02-09h08m-MGD.1.cs.st----! - -'From Cuis 5.0 [latest update: #4070] on 24 March 2020 at 11:24:31 am'! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'HAW 3/24/2020 11:20:25' prior: 16806885! - printCategoryChunk: category on: aFileStream withStamp: changeStamp priorMethod: priorMethod - - ^self - printCategoryChunk: category - on: aFileStream - withStamp: changeStamp - priorMethod: priorMethod - overridesMethod: nil ! ! -!ClassDescription methodsFor: 'private' stamp: 'HAW 3/24/2020 11:16:12' prior: 50500975! - logMethodSource: aText forMethodWithNode: aCompiledMethodWithNode inCategory: category withStamp: changeStamp notifying: requestor - | priorMethodOrNil overridenMethodOrNil | - - priorMethodOrNil := self compiledMethodAt: aCompiledMethodWithNode selector ifAbsent: nil. - overridenMethodOrNil := self superclass ifNotNil: [ :aSuperclass | - aSuperclass lookupSelector: aCompiledMethodWithNode selector ]. - - aCompiledMethodWithNode method - putSource: aText asString - fromParseNode: aCompiledMethodWithNode node - class: self - category: category - withStamp: changeStamp - inFile: 2 - priorMethod: priorMethodOrNil - overridesMethod: overridenMethodOrNil.! ! - -CompiledMethod removeSelector: #putSource:fromParseNode:class:category:withStamp:inFile:priorMethod:! - -!methodRemoval: CompiledMethod #putSource:fromParseNode:class:category:withStamp:inFile:priorMethod: stamp: 'Install-4076-MethodOverrideChangeImprovements-HernanWilkinson-2020Mar24-11h15m-HAW.001.cs.st 4/1/2020 17:57:16'! -putSource: sourceStr fromParseNode: methodNode class: class category: catName - withStamp: changeStamp inFile: fileIndex priorMethod: priorMethod - - ^ self putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble: [ :file | - class - printCategoryChunk: catName - on: file - withStamp: changeStamp - priorMethod: priorMethod. - file newLine ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4076-MethodOverrideChangeImprovements-HernanWilkinson-2020Mar24-11h15m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #3964] on 2 January 2020 at 9:08:33 am'! - -ChangeListElement subclass: #ClassRenamedChangeRecord - instanceVariableNames: 'previousName newName stamp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #ClassRenamedChangeRecord category: #'Tools-Changes' stamp: 'Install-4077-ClassRenameChangeReification-MatiasDinota-2020Jan02-09h08m-MGD.1.cs.st 4/1/2020 17:57:16'! -ChangeListElement subclass: #ClassRenamedChangeRecord - instanceVariableNames: 'previousName newName stamp' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! -!ChangeList methodsFor: 'scanning' stamp: 'MGD 12/19/2019 19:36:26'! - scanClassRenamed: tokens - - | record stamp newName previousName preamble | - - preamble _ tokens first. - previousName _ tokens second. - newName _ tokens fourth. - stamp _ self stampFrom: tokens. - file nextChunk. - - record _ ClassRenamedChangeRecord from: previousName to: newName stamp: stamp. - - self - addItem: record - text: preamble, previousName, ' - ', newName, '; ', stamp ! ! -!ClassRenamedChangeRecord methodsFor: 'initialization' stamp: 'MGD 12/19/2019 19:19:01'! - initializeFrom: previousClassName to: newClassName stamp: aString - - previousName := previousClassName. - newName := newClassName. - stamp := aString.! ! -!ClassRenamedChangeRecord methodsFor: 'accessing' stamp: 'MGD 12/19/2019 21:14:43'! - changeClass - ^ nil! ! -!ClassRenamedChangeRecord methodsFor: 'accessing' stamp: 'MGD 12/19/2019 19:32:01'! - changeClassName - ^ previousName ! ! -!ClassRenamedChangeRecord methodsFor: 'accessing' stamp: 'MGD 12/19/2019 19:19:28'! - changeType - ^ #classRenamed! ! -!ClassRenamedChangeRecord methodsFor: 'accessing' stamp: 'MGD 12/19/2019 19:33:26'! - newClassName - ^ newName ! ! -!ClassRenamedChangeRecord methodsFor: 'accessing' stamp: 'MGD 12/19/2019 19:31:06'! - stamp - ^stamp! ! -!ClassRenamedChangeRecord methodsFor: 'printing' stamp: 'MGD 12/19/2019 21:13:47'! - string - ^ 'classRenamed: #', previousName, ' as: #', newName, stamp ! ! -!ClassRenamedChangeRecord methodsFor: 'fileIn/fileOut' stamp: 'MGD 1/2/2020 08:58:15' overrides: 50490430! - fileIn - ! ! -!ClassRenamedChangeRecord class methodsFor: 'instance creation' stamp: 'MGD 12/19/2019 19:17:45'! - from: previousClassName to: newClassName stamp: aString - ^self new initializeFrom: previousClassName to: newClassName stamp: aString ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4077-ClassRenameChangeReification-MatiasDinota-2020Jan02-09h08m-MGD.1.cs.st----! - -'From Cuis 5.0 [latest update: #4071] on 24 March 2020 at 11:34:19 am'! -!ChangeList methodsFor: '*TDDGuruFirstBootstrapping' stamp: 'HAW 3/24/2020 11:30:46' prior: 50478950! - scanSpecificChangeRecordType - "Scan anything that involves more than one chunk" - - | itemPosition item tokens firstToken secondToken | - - itemPosition _ file position. - item _ file nextChunk. - - (self itemIsRecognized: item) ifFalse: [ - "Maybe a preamble, but not one we recognize; bail out with the preamble trick" - ^ self scanAndIgnore: item in: itemPosition ]. - - tokens _ Scanner new scanTokens: item. - tokens size >= 2 ifTrue: [ - firstToken _ tokens first. - secondToken _ tokens second. - - firstToken == #classDefinition: - ifTrue: [ ^ self scanClassDefinition: tokens ]. - (firstToken == #classRemoval: or: [ firstToken == #classMoveToSomePackage: ]) - ifTrue: [ ^ self scanClassRemoval: tokens ]. - (firstToken == #methodRemoval: or: [ firstToken == #methodMoveToSomePackage: ]) - ifTrue: [ ^ self scanMethodRemoval: tokens ]. - (secondToken == #methodsFor: or: [ tokens third == #methodsFor: ]) - ifTrue: [ ^ self scanMethodDefinition: tokens ]. - secondToken == #commentStamp: - ifTrue: [ ^ self scanClassComment: tokens ]. - firstToken == #provides: - ifTrue: [ ^ self scanFeatureProvision: tokens ]. - firstToken == #requires: - ifTrue: [ ^ self scanFeatureRequirement: tokens ]. - firstToken == #classRenamed: - ifTrue: [ ^ self scanClassRenamed: tokens ]. - ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4078-ClassRenameChangeReification-HernanWilkinson-2020Mar24-11h26m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4074] on 24 March 2020 at 12:18:49 pm'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4079-ChangeListMethodsRecategorization-HernanWilkinson-2020Mar24-12h16m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4075] on 24 March 2020 at 3:26:46 pm'! -!ChangeList class methodsFor: 'scanning' stamp: 'HAW 3/24/2020 15:26:32' prior: 50479404! - knownFileInPreambles - - ^ `{ - 'classDefinition:'. - 'classRemoval:'. - 'methodRemoval:'. - 'methodMoveToSomePackage:'. - 'classMoveToSomePackage:'. - 'provides:'. - 'requires:'. - 'classRenamed:'. }`! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4080-ClassRenameChangeReification-HernanWilkinson-2020Mar24-15h26m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4069] on 20 March 2020 at 9:39:27 pm'! -!Preferences class methodsFor: 'standard queries' stamp: 'pb 3/20/2020 21:02:28'! - transcriptLogVerbose - ^ self - valueOfFlag: #transcriptLogVerbose - ifAbsent: [ true ].! ! -!String methodsFor: 'displaying' stamp: 'pb 3/20/2020 21:04:16' prior: 50495912! - 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 mousePoint - from: 0 to: 100 - during: [:barBlock | - 1 to: 100 do: [:x | - (Delay forMilliseconds: 10) wait. - barBlock value: x.]]. - -['Now here''s some Real Progress' - displayProgressAt: Sensor mousePoint - from: 0 to: 100 - during: [:barBlock | - 1 to: 100 do: [:x | barBlock value: x. - (Delay forMilliseconds: 100) wait]].] fork - -['Now here''s some Real Progress' - displayProgressAt: Sensor mousePoint - from: 0 to: 10 - during: [:barBlock | - 1 to: 30 do: [:x | barBlock value: x \\ 11. - (Delay forMilliseconds: 100) wait]]] fork - -'Now here''s some Real Progress' - displayProgressAt: Sensor mousePoint - from: 0 to: 10 - during: [:barBlock | - 1 to: 30 do: [:x | barBlock value: nil. - (Delay forMilliseconds: 200) 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. - -The use of ProgressInitiationException allows for avoiding actual -progress display, by catching the exception. -" - | answer duration | - Preferences transcriptLogVerbose ifTrue: [ - Transcript show: self; show: '...']. - duration _ [ - answer _ ProgressInitiationException - display: self - at: aPoint - from: minVal - to: maxVal - during: workBlock] durationToRun. - Preferences transcriptLogVerbose ifTrue: [ - Transcript show: ' done. Took '; show: duration printString; newLine]. - ^answer! ! -!ChangeSet class methodsFor: 'services' stamp: 'pb 3/20/2020 21:18:53' prior: 16799283! - install: aFileEntry - "File in the entire contents of the file specified by the name provided. - Do not affect the user change sets, store changes in separate one" - - ChangeSet installing: aFileEntry name do: [ self fileIn: aFileEntry ]. - Preferences transcriptLogVerbose ifTrue: [ - ('Installed ChangeSet: ', aFileEntry name) print]! ! -!CodeFile methodsFor: 'fileIn/fileOut' stamp: 'pb 3/20/2020 21:05:57' prior: 50493302! - fileIn - | doitsMark | - doitsMark := 1. - doIts isEmpty ifFalse:[doitsMark := self askForDoits]. - doitsMark = 4 ifTrue: [^nil]. - doitsMark = 2 ifTrue:[self fileInDoits]. - classOrder do:[:cls| - cls fileInDefinition. - ]. - classes do:[:cls| - Preferences transcriptLogVerbose ifTrue: [ - Transcript newLine; show:'Filing in ', cls name]. - cls fileInMethods. - cls hasMetaclass ifTrue:[cls theMetaClass fileInMethods]. - ]. - doitsMark = 3 ifTrue: [ self fileInDoits ]! ! -!CodePackageFile methodsFor: 'services' stamp: 'pb 3/20/2020 21:29:40' prior: 50430211! - install: aFileStream - "Installs the package. Replace all existing code in the CodePackage, removing any code that is not included in us." - | localName newCodePackage pckClass currentCS | - - "Give reasonable warnings if there is stuff that can't be properly cleaned. Give the user the chance to abort." - Preferences transcriptLogVerbose ifTrue: [ - '=============' print. - classesToRemove notEmpty ifTrue: [ - ('classesToRemove: ', classesToRemove printString) print. - '=============' print ]. - methodsToRemove notEmpty ifTrue: [ - 'methodsToRemove: ' print. - methodsToRemove do: [ :methodReference | methodReference print ]. - '=============' print ]]. - - "Create, install and answer a (sub)instance of CodePackage" - localName _ fullName asFileEntry name. - ChangeSet installing: packageName do: [ - "This change set will capture a possible class definition for a subclass of CodePackage. - If it only has that, then remove it after package install. - One example needing this is 'Color-Extras.pck.st'" - currentCS _ ChangeSet changeSetForBaseSystem. - currentCS isEmpty ifFalse: [ currentCS _ nil ]. - pckClass _ CodePackage. - classes do: [ :ee | - (ee hasDefinition and: [ee superclassName = 'CodePackage']) ifTrue: [ - ee fileInDefinitionAndMetaclass. - pckClass _ Smalltalk at: ee name ]]. - newCodePackage _ pckClass - named: packageName - createIfAbsent: true - registerIfNew: true. - newCodePackage - fullFileName: fullName; - sourceSystem: sourceSystem; - description: description; - featureSpec: featureSpec. - aFileStream fileInAnnouncing: 'Installing ', localName, '...'. - methodsToRemove do: [ :methodReference | methodReference actualClass removeSelector: methodReference selector ]. - classesToRemove do: [ :className | (Smalltalk at: className) removeFromSystem ]. - currentCS ifNotNil: [ ChangeSet removeChangeSet: currentCS ]]. - newCodePackage hasUnsavedChanges: false; triggerEvent: #dirtyFlagChanged. - DataStream initialize. "Just in case" - "If we are installing an already installed package, zap the change set with possible changes done, - as they are irrelevant now: we have the package from disk" - ChangeSet removeChangeSet: (ChangeSet existingOrNewChangeSetForPackage: newCodePackage). - Preferences transcriptLogVerbose ifTrue: [ - Transcript newLine; show: 'Package ', packageName, ' successfully installed'; newLine. - Smalltalk cleanOutUndeclared. - Undeclared notEmpty ifTrue: [ - ('Undeclared: ', Undeclared printString) print ]]. - ^newCodePackage! ! -!TestResult methodsFor: 'logging' stamp: 'pb 3/20/2020 21:36:27' prior: 50473680! - reportAboutToRun: aTestCase - Preferences transcriptLogVerbose ifTrue: [ - Transcript show: 'Will run: '; print: aTestCase; newLine]! ! -!TestResult methodsFor: 'logging' stamp: 'pb 3/20/2020 21:35:31' prior: 50473690! - reportFailed: aTestCase because: anException - Preferences transcriptLogVerbose ifTrue: [ - Transcript print: anException; newLine].! ! -!TestResult methodsFor: 'logging' stamp: 'pb 3/20/2020 21:35:55' prior: 50473695! - reportPassed: aTestCase - Preferences transcriptLogVerbose ifTrue: [ - Transcript show: 'finished.'; newLine]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4081-Preferences-verbose-logging-PhilBellalouna-2020Mar20-21h02m-pb.001.cs.st----! - -'From Cuis 5.0 [latest update: #4081] on 30 March 2020 at 6:31:58 pm'! -!MorphicTranslation methodsFor: 'composing' stamp: 'pb 3/15/2020 16:23:20' prior: 16878340! - composedWith: aTransformation into: result - "Return the composition of the receiver and the transformation passed in. - Store the composed matrix into result. - Please see the comment at: #composedWith:" - - result setTranslation: self translation + aTransformation translation. - ^ result! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4082-MorphicTranslation-methods-behave-according-to-documentation-PhilBellalouna-2020Mar30-18h28m-pb.001.cs.st----! - -'From Cuis 5.0 [latest update: #4069] on 20 March 2020 at 12:56:57 pm'! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph drawingMorphStack engine clipRect ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support' stamp: 'Install-4083-Canvas-clipRect-PhilBellalouna-2020Mar20-12h41m-pb.001.cs.st 4/1/2020 17:57:17'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph drawingMorphStack engine clipRect' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! -!MorphicCanvas methodsFor: 'accessing' stamp: 'pb 3/20/2020 12:49:43' prior: 50495175! - clipRect - "Return the currently active clipping rectangle" - "In targetForm coordinates" - ^ clipRect ifNil: [clipRect := clipLeft@clipTop corner: clipRight@clipBottom+1]! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'pb 3/20/2020 12:44:46' prior: 50385921! - textComposition: aTextComposition bounds: boundsRect color: c selectionColor: sc - | displayScanner leftInRun line boundsInWorld tl | - - tl _ boundsRect topLeft. - boundsInWorld _ currentTransformation displayBoundsOfTransformOf: boundsRect. - - displayScanner _ MorphicScanner new - defaultFont: aTextComposition defaultFont; - text: aTextComposition textComposed - foreground: c. - displayScanner canvas: self. - - leftInRun _ 0. - "Take clipRect into account. Extrememly fast scrolls and redraws of huge files (like .sources)" - (aTextComposition lineIndexForPoint: (`0@0` max: self clipRect origin - boundsInWorld origin)) - to: (aTextComposition lineIndexForPoint: (boundsInWorld extent min: self clipRect corner - boundsInWorld origin)) - do: [ :i | - line _ aTextComposition lines at: i. - aTextComposition - displaySelectionInLine: line - on: self - textTopLeft: tl - selectionColor: sc. - leftInRun _ displayScanner displayLine: line textTopLeft: tl leftInRun: leftInRun ]! ! -!MorphicCanvas methodsFor: 'private' stamp: 'pb 3/20/2020 12:49:28' prior: 50495183! - setClipRect: aRectangle - "by convention, aRectangle includes left and top but does not include right and bottom. - We do draw clipRight and clipBottom but not beyond. - " - "In targetForm coordinates" - clipRect := aRectangle! ! -!BitBltCanvas methodsFor: 'testing' stamp: 'pb 3/20/2020 12:48:36' prior: 50495238 overrides: 50463630! - isCurrentMorphVisible - | aRectangle myClipRect | - currentMorph visible ifFalse: [ ^false ]. - "#clippingRectForCurrentMorph is valid even before drawing currentMorph, only in BitBltCanvas!!" - aRectangle := self clippingRectForCurrentMorph. - myClipRect := self clipRect. - aRectangle right < myClipRect left ifTrue: [^ false]. - aRectangle left > myClipRect right ifTrue: [^ false]. - aRectangle bottom < myClipRect top ifTrue: [^ false]. - aRectangle top > myClipRect bottom ifTrue: [^ false]. - ^ true -! ! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipRect clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph drawingMorphStack engine' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support' stamp: 'Install-4083-Canvas-clipRect-PhilBellalouna-2020Mar20-12h41m-pb.001.cs.st 4/1/2020 17:57:17'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipRect clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph drawingMorphStack engine' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4083-Canvas-clipRect-PhilBellalouna-2020Mar20-12h41m-pb.001.cs.st----! - -'From Cuis 5.0 [latest update: #4070] on 20 March 2020 at 1:01:06 pm'! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipRect clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph drawingMorphStack engine ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support' stamp: 'Install-4084-Canvas-clipRect-cleanup-PhilBellalouna-2020Mar20-12h59m-pb.001.cs.st 4/1/2020 17:57:17'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipRect clipLeft clipTop clipRight clipBottom transformations currentTransformation cti currentMorph drawingMorphStack engine' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -BitBltCanvas allInstances do:[:eaCanvas| eaCanvas clipRect]! -!MorphicCanvas methodsFor: 'accessing' stamp: 'pb 3/20/2020 12:59:56' prior: 50501532! - clipRect - "Return the currently active clipping rectangle" - "In targetForm coordinates" - ^ clipRect! ! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipRect transformations currentTransformation cti currentMorph drawingMorphStack engine' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support' stamp: 'Install-4084-Canvas-clipRect-cleanup-PhilBellalouna-2020Mar20-12h59m-pb.001.cs.st 4/1/2020 17:57:17'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipRect transformations currentTransformation cti currentMorph drawingMorphStack engine' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4084-Canvas-clipRect-cleanup-PhilBellalouna-2020Mar20-12h59m-pb.001.cs.st----! - -'From Cuis 5.0 [latest update: #4058] on 7 March 2020 at 10:34:03 pm'! - -"Change Set: 4059-CuisCore-AuthorName-2020Mar07-22h12m -Date: 7 March 2020 -Author: Nahuel Garbezza - -Adds two new parse nodes representing a temporaries assignment and each individual assignment, add those to each MethodNode and BlockNode (coexisting with the current approach -list of temporaries-)"! - -CodeNode subclass: #BlockNode - instanceVariableNames: 'arguments statements returns nArgsNode size remoteCopyNode temporaries optimized optimizedMessageNode actualScopeIfOptimized blockExtent remoteTempNode copiedValues closureCreationNode startOfLastStatement tempsMark temporariesDeclaration ' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #BlockNode category: #'Compiler-ParseNodes' stamp: 'Install-4085-TemporariesDefinitionASTNode-NahuelGarbezza-2020Mar07-22h12m-RNG.001.cs.st 4/1/2020 17:57:17'! -CodeNode subclass: #BlockNode - instanceVariableNames: 'arguments statements returns nArgsNode size remoteCopyNode temporaries optimized optimizedMessageNode actualScopeIfOptimized blockExtent remoteTempNode copiedValues closureCreationNode startOfLastStatement tempsMark temporariesDeclaration' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! -!BlockNode commentStamp: '' prior: 16789015! - I represent a bracketed block with 0 or more arguments and 1 or more statements. If I am initialized with no statements, I create one. I have a flag to tell whether my last statement returns a value from the enclosing method. My last three fields remember data needed for code generation. I can emit for value in the usual way, in which case I create a literal method (actually a context remotely copied) to be evaluated by sending it value: at run time. Or I can emit code to be evaluated in line; this only happens at the top level of a method and in conditionals and while-loops, none of which have arguments. - -We are in the process of refactoring "temporaries" inst var to a "temporariesDeclaration" inst var which is a parse node that contains more than just the temporaries' nodes, it is the node that represents the declaration itself. Refer to the class comment in MethodNode for more information on how to migrate to "temporariesDeclaration".! - -CodeNode subclass: #MethodNode - instanceVariableNames: 'selectorOrFalse precedence arguments block primitive encoder temporaries properties sourceText locationCounter localsPool selectorKeywordsRanges temporariesDeclaration ' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #MethodNode category: #'Compiler-ParseNodes' stamp: 'Install-4085-TemporariesDefinitionASTNode-NahuelGarbezza-2020Mar07-22h12m-RNG.001.cs.st 4/1/2020 17:57:17'! -CodeNode subclass: #MethodNode - instanceVariableNames: 'selectorOrFalse precedence arguments block primitive encoder temporaries properties sourceText locationCounter localsPool selectorKeywordsRanges temporariesDeclaration' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! -!MethodNode commentStamp: '' prior: 16872285! - I am the root of the parse tree.. - -Instance Variables - arguments: - block: - encoder: - localsPool: - locationCounter: - precedence: - primitive: - properties: - selectorOrFalse: - sourceText: - temporaries: - temporariesDeclaration: - -arguments - - the collection of parsed or decompiled method arguments - -block - - the BlockNode holding the method's statements - -encoder - - the object that comprises the copiler's scope table, literal pool and back-end bytecode generator - -localsPool - - a set used to determine the set of copied values for each block in the method - -locationCounter - - an integer used to mark block scopes for the purposes of the closure transformation. See BlockNode>>#analyseArguments:temporaries:rootNode: - -precedence - - the precedence of the method's selector (see Symbol>>precedence) - -primitive - - if non-zero this is the integer code of the method's primitive - -properties - - the object used to accumulate method properties (a.k.a. pragmas) - -selectorOrFalse - - the method's selector or false if this is a doit - -sourceText - - the source test from which the method was compiled - -temporaries - - the collection of parsed or decompiled method temporaries - -temporariesDeclaration - - an alternative way to represent the temporaries declaration, by using a parse node to represent that; it should eventually replace the need for the "temporaries" instance variable (because the temporaries can be obtained through this object); every read to "temporaries" can be replaced by sending #allDeclaredVariableNodes to this object; right now the Parser initializes both "temporaries" and "temporariesDeclaration" to ease the migration process! - -ParseNode subclass: #TemporariesDeclarationNode - instanceVariableNames: 'tempDeclarationNodes' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #TemporariesDeclarationNode category: #'Compiler-ParseNodes' stamp: 'Install-4085-TemporariesDefinitionASTNode-NahuelGarbezza-2020Mar07-22h12m-RNG.001.cs.st 4/1/2020 17:57:17'! -ParseNode subclass: #TemporariesDeclarationNode - instanceVariableNames: 'tempDeclarationNodes' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -ParseNode subclass: #TemporaryDeclarationNode - instanceVariableNames: 'variableNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #TemporaryDeclarationNode category: #'Compiler-ParseNodes' stamp: 'Install-4085-TemporariesDefinitionASTNode-NahuelGarbezza-2020Mar07-22h12m-RNG.001.cs.st 4/1/2020 17:57:17'! -ParseNode subclass: #TemporaryDeclarationNode - instanceVariableNames: 'variableNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! -!ParseNode methodsFor: 'testing' stamp: 'RNG 3/7/2020 22:29:21'! - isTemporariesDeclaration - - ^ false! ! -!BlockNode methodsFor: 'accessing' stamp: 'RNG 3/7/2020 22:31:36'! - temporariesDeclaration - - ^ temporariesDeclaration! ! -!BlockNode methodsFor: 'accessing' stamp: 'RNG 3/7/2020 22:22:01'! - temporariesDeclaration: aTemporariesDeclarationNode - "RNG: after removing all the usages of the temporaries inst var, the last line can be removed" - - temporariesDeclaration := aTemporariesDeclarationNode. - self temporaries: aTemporariesDeclarationNode allDeclaredVariableNodes! ! -!MethodNode methodsFor: 'accessing' stamp: 'RNG 3/7/2020 22:32:32'! - temporariesDeclaration - - ^ temporariesDeclaration! ! -!MethodNode methodsFor: 'accessing' stamp: 'RNG 3/7/2020 22:20:11'! - temporariesDeclaration: aTemporariesDeclarationNode - "RNG: after removing all the usages of the temporaries inst var, the last line can be removed" - - temporariesDeclaration := aTemporariesDeclarationNode. - self temporaries: aTemporariesDeclarationNode allDeclaredVariableNodes! ! -!MethodNode methodsFor: 'initialization' stamp: 'RNG 3/7/2020 22:24:48'! - selector: selOrFalse arguments: args precedence: p temporariesDeclaration: tempsDeclaration block: blk encoder: anEncoder primitive: prim properties: propDict - "Initialize the receiver with respect to the arguments given." - "RNG: this is the preferred initializer (with temporariesDeclaration) as opposed to the one with 'temporaries' that is going to be deprecated" - - encoder := anEncoder. - selectorOrFalse := selOrFalse. - precedence := p. - arguments := args. - temporariesDeclaration _ tempsDeclaration. - temporaries := tempsDeclaration allDeclaredVariableNodes. - block := blk. - primitive := prim. - properties := propDict.! ! -!MethodNode methodsFor: 'initialization' stamp: 'RNG 3/7/2020 22:25:18'! - selector: selOrFalse arguments: args precedence: p temporariesDeclaration: tempsDeclaration block: blk encoder: anEncoder primitive: prim properties: propDict selectorKeywordsRanges: range - "RNG: this is the preferred initializer (with temporariesDeclaration) as opposed to the one with 'temporaries' that is going to be deprecated" - - selectorKeywordsRanges := range. - - ^ self selector: selOrFalse arguments: args precedence: p temporariesDeclaration: tempsDeclaration block: blk encoder: anEncoder primitive: prim properties: propDict! ! -!TemporariesDeclarationNode methodsFor: 'testing' stamp: 'RNG 3/7/2020 22:28:39'! - declaresAnyVariable - - ^ tempDeclarationNodes notEmpty! ! -!TemporariesDeclarationNode methodsFor: 'testing' stamp: 'RNG 3/7/2020 22:28:44'! - declaresVariable: aVariableNode - - ^ self allDeclaredVariableNodes - anySatisfy: [ :variableNode | variableNode isNamed: aVariableNode name ]! ! -!TemporariesDeclarationNode methodsFor: 'testing' stamp: 'RNG 3/7/2020 22:28:50' overrides: 50501880! - isTemporariesDeclaration - - ^ true! ! -!TemporariesDeclarationNode methodsFor: 'accessing' stamp: 'RNG 3/7/2020 22:28:14'! - allDeclaredVariableNodes - - ^ tempDeclarationNodes collect: [ :tempDeclaration | tempDeclaration variableNode ]! ! -!TemporariesDeclarationNode methodsFor: 'accessing' stamp: 'RNG 3/7/2020 22:33:16'! - temporaryDeclarationNodes - - ^ tempDeclarationNodes! ! -!TemporariesDeclarationNode methodsFor: 'printing' stamp: 'RNG 3/7/2020 22:27:53'! - printEachTempVarDeclarationOn: aStream - - ^ tempDeclarationNodes do: [ :tempDeclarationNode | - aStream nextPutAll: tempDeclarationNode variableName; space]! ! -!TemporariesDeclarationNode methodsFor: 'printing' stamp: 'RNG 3/7/2020 22:28:00' overrides: 16884940! - printOn: aStream indent: anInteger - - aStream nextPut: $|; space. - self printEachTempVarDeclarationOn: aStream. - aStream nextPut: $|.! ! -!TemporariesDeclarationNode methodsFor: 'initialization' stamp: 'RNG 3/7/2020 22:27:28'! - initializeWithAll: aCollectionOfTempDeclarationNodes - - tempDeclarationNodes _ aCollectionOfTempDeclarationNodes! ! -!TemporariesDeclarationNode class methodsFor: 'instance creation' stamp: 'RNG 3/7/2020 22:27:06'! - empty - - ^ self withAll: #()! ! -!TemporariesDeclarationNode class methodsFor: 'instance creation' stamp: 'RNG 3/7/2020 22:27:12'! - withAll: tempDeclarationNodes - - ^ self new initializeWithAll: tempDeclarationNodes! ! -!TemporaryDeclarationNode methodsFor: 'testing' stamp: 'RNG 3/7/2020 22:30:38'! - declaresVariable: aVariableNode - - ^ variableNode isNamed: aVariableNode name! ! -!TemporaryDeclarationNode methodsFor: 'testing' stamp: 'RNG 3/7/2020 22:30:46' overrides: 50501880! - isTemporariesDeclaration - - ^ true! ! -!TemporaryDeclarationNode methodsFor: 'printing' stamp: 'RNG 3/7/2020 22:30:25' overrides: 16884940! - printOn: aStream indent: anInteger - - aStream nextPut: $|; space. - variableNode printOn: aStream indent: anInteger. - aStream space; nextPut: $|.! ! -!TemporaryDeclarationNode methodsFor: 'accessing' stamp: 'RNG 3/7/2020 22:30:10'! - variableName - - ^ self variableNode name! ! -!TemporaryDeclarationNode methodsFor: 'accessing' stamp: 'RNG 3/7/2020 22:30:16'! - variableNode - - ^ variableNode! ! -!TemporaryDeclarationNode methodsFor: 'initialization' stamp: 'RNG 3/7/2020 22:29:58'! - initializeVariableNode: aVariableNode - - variableNode _ aVariableNode! ! -!TemporaryDeclarationNode class methodsFor: 'instance creation' stamp: 'RNG 3/7/2020 22:29:44'! - of: aVariableNode - - ^ self new initializeVariableNode: aVariableNode! ! -!BlockNode methodsFor: 'accessing' stamp: 'RNG 3/7/2020 22:21:23' prior: 50462159 overrides: 50487851! - temporaries - "Collection of TempVariableNodes" - - "RNG: implementation can be changed after adopting the use of temporariesDeclaration inst var. - After that, the implementation for this message can be changed to: - ^ temporariesDeclaration allDeclaredVariableNodes - - Or we can analyze the senders and change the way we request the temporaries" - - ^temporaries ifNil: [#()]! ! -!BlockNode methodsFor: 'accessing' stamp: 'RNG 3/7/2020 22:21:49' prior: 50488068 overrides: 50488052! - temporaries: aCollectionOfTemporaries - "Collection of TempVariableNodes" - "RNG: deprecated, try to use #temporariesDeclaration: instead" - - temporaries := aCollectionOfTemporaries! ! -!MethodNode methodsFor: 'accessing' stamp: 'RNG 3/7/2020 22:22:33' prior: 16872396 overrides: 50487851! - temporaries - "For transformations etc, not used in compilation" - - "RNG: implementation can be changed after adopting the use of temporariesDeclaration inst var. - After that, the implementation for this message can be changed to: - ^ temporariesDeclaration allDeclaredVariableNodes - - Or we can analyze the senders and change the way we request the temporaries" - - ^temporaries! ! -!MethodNode methodsFor: 'accessing' stamp: 'RNG 3/7/2020 22:22:44' prior: 50488082 overrides: 50488052! - temporaries: aCollectionOfTemporaries - "For transformations etc, not used in compilation" - "RNG: deprecated in favor of #temporariesDeclaration:" - - temporaries := aCollectionOfTemporaries! ! -!MethodNode methodsFor: 'initialization' stamp: 'RNG 3/7/2020 22:24:02' prior: 16873004! - selector: selOrFalse arguments: args precedence: p temporaries: temps block: blk encoder: anEncoder primitive: prim - "RNG: deprecated, use one of the methods that receives a temporariesDeclaration instead of the collection of temporaries" - - self - selector: selOrFalse - arguments: args - precedence: p - temporaries: temps - block: blk - encoder: anEncoder - primitive: prim - properties: AdditionalMethodState new.! ! -!MethodNode methodsFor: 'initialization' stamp: 'RNG 3/7/2020 22:24:16' prior: 16873016! - selector: selOrFalse arguments: args precedence: p temporaries: temps block: blk encoder: anEncoder primitive: prim properties: propDict - "Initialize the receiver with respect to the arguments given." - "RNG: its external use is deprecated, in favor of any of the methods that receives a temporariesDeclaration instead of the collection of temporaries" - - encoder := anEncoder. - selectorOrFalse := selOrFalse. - precedence := p. - arguments := args. - temporaries := temps. - block := blk. - primitive := prim. - properties := propDict.! ! -!MethodNode methodsFor: 'initialization' stamp: 'RNG 3/7/2020 22:24:34' prior: 50408777! - selector: selOrFalse arguments: args precedence: p temporaries: temps block: blk encoder: anEncoder primitive: prim properties: propDict selectorKeywordsRanges: range - "RNG: deprecated, use one of the methods that receives a temporariesDeclaration instead of the collection of temporaries" - - selectorKeywordsRanges := range. - - ^self selector: selOrFalse arguments: args precedence: p temporaries: temps block: blk encoder: anEncoder primitive: prim properties: propDict! ! - -CodeNode subclass: #BlockNode - instanceVariableNames: 'arguments statements returns nArgsNode size remoteCopyNode temporaries optimized optimizedMessageNode actualScopeIfOptimized blockExtent remoteTempNode copiedValues closureCreationNode startOfLastStatement tempsMark temporariesDeclaration' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #BlockNode category: #'Compiler-ParseNodes' stamp: 'Install-4085-TemporariesDefinitionASTNode-NahuelGarbezza-2020Mar07-22h12m-RNG.001.cs.st 4/1/2020 17:57:17'! -CodeNode subclass: #BlockNode - instanceVariableNames: 'arguments statements returns nArgsNode size remoteCopyNode temporaries optimized optimizedMessageNode actualScopeIfOptimized blockExtent remoteTempNode copiedValues closureCreationNode startOfLastStatement tempsMark temporariesDeclaration' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -CodeNode subclass: #MethodNode - instanceVariableNames: 'selectorOrFalse precedence arguments block primitive encoder temporaries properties sourceText locationCounter localsPool selectorKeywordsRanges temporariesDeclaration' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #MethodNode category: #'Compiler-ParseNodes' stamp: 'Install-4085-TemporariesDefinitionASTNode-NahuelGarbezza-2020Mar07-22h12m-RNG.001.cs.st 4/1/2020 17:57:17'! -CodeNode subclass: #MethodNode - instanceVariableNames: 'selectorOrFalse precedence arguments block primitive encoder temporaries properties sourceText locationCounter localsPool selectorKeywordsRanges temporariesDeclaration' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4085-TemporariesDefinitionASTNode-NahuelGarbezza-2020Mar07-22h12m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4059] on 13 March 2020 at 12:25:29 am'! - -"Change Set: 4060-CuisCore-AuthorName-2020Mar13-00h15m -Date: 13 March 2020 -Author: Nahuel Garbezza - -Allow Parser to parse temp declaration nodes. It has some code that needs to be cleaned up after integrating this change"! -!Parser methodsFor: 'temps' stamp: 'RNG 3/13/2020 00:16:54'! - createTempDeclarationOf: variableNode sourceRange: sourceRange - - | declarationNode | - declarationNode _ TemporaryDeclarationNode of: variableNode. - encoder noteSourceRange: sourceRange forNode: declarationNode. - ^ declarationNode! ! -!Parser methodsFor: 'temps' stamp: 'RNG 3/13/2020 00:17:01'! - createTempsDeclarationWith: tempDeclarationNodes sourceRange: sourceRange - - |tempsDeclarationNode| - tempsDeclarationNode _ TemporariesDeclarationNode withAll: tempDeclarationNodes. - encoder noteSourceRange: sourceRange forNode: tempsDeclarationNode. - ^ tempsDeclarationNode! ! -!Parser methodsFor: 'temps' stamp: 'RNG 3/13/2020 00:17:09'! - noTempsDeclaration - - ^ TemporariesDeclarationNode empty! ! -!Parser methodsFor: 'expression types' stamp: 'RNG 3/13/2020 00:23:38' prior: 50409712! - blockExpression - "[ ({:var} |) (| {temps} |) (statements) ] => BlockNode." - - | blockNode variableNodes temporaryBlockVariables start | - blockNode := BlockNode new. - variableNodes := OrderedCollection new. - start := prevMark + requestorOffset. - "Gather parameters." - [self match: #colon] whileTrue: - [self argumentNameWithRangeDo: [ :argumentName :range | - variableNodes addLast: (encoder bindBlockArg: argumentName within: blockNode range: range)]]. - (variableNodes size > 0 & (hereType ~~ #rightBracket) and: [(self match: #verticalBar) not]) ifTrue: - [^self expected: 'Vertical bar']. - - temporaryBlockVariables := self temporaryBlockVariablesFor: blockNode. - - "RNG - temporary change until we fully start using temporary declaration nodes in the parser" - temporaryBlockVariables isCollection - ifTrue: [ blockNode temporaries: temporaryBlockVariables ] - ifFalse: [ blockNode temporariesDeclaration: temporaryBlockVariables ]. - - self statements: variableNodes innerBlock: true blockNode: blockNode. - - (self match: #rightBracket) ifFalse: [^self expected: 'Period or right bracket']. - - blockNode noteSourceRangeStart: start end: self endOfLastToken encoder: encoder. - - "The scope of the parameters and temporary block variables is no longer active." - "RNG - temporary change until we fully start using temporary declaration nodes in the parser" - temporaryBlockVariables isCollection - ifTrue: [ temporaryBlockVariables do: [:variable | variable scope: -1] ] - ifFalse: [ temporaryBlockVariables allDeclaredVariableNodes do: [:variable | variable scope: -1] ]. - - variableNodes do: [:variable | variable scope: -1]! ! -!Parser methodsFor: 'expression types' stamp: 'RNG 3/13/2020 00:16:04' prior: 50485830! - method: noPattern doIt: doIt context: ctxt - " pattern [ | temporaries ] block => MethodNode." - - | sap block primitives temporaries messageComment methodNode | - - sap := self pattern: noPattern inContext: ctxt. - "sap={selector, arguments, precedence}" - self properties selector: (sap at: 1). - encoder selector: (sap at: 1). - (sap at: 2) do: [:argNode | argNode beMethodArg]. - - doIt ifFalse: [self pragmaSequence]. - temporaries := self temporaries. - messageComment := currentComment. - currentComment := nil. - doIt ifFalse: [self pragmaSequence]. - primitives := self pragmaPrimitives. - - self statements: #() innerBlock: doIt. - block := parseNode. - doIt - ifTrue: [block returnLast] - ifFalse: [block returnSelfIfNoOther: encoder]. - hereType == #doIt ifFalse: [^self expected: 'Nothing more']. - - methodNode := self newMethodNode comment: messageComment. - - "RNG - temporary change, until we start using temporary declaration nodes in the parser" - temporaries isCollection - ifTrue: [ - methodNode - selector: (sap at: 1) - arguments: (sap at: 2) - precedence: (sap at: 3) - temporaries: temporaries - block: block - encoder: encoder - primitive: primitives - properties: properties - selectorKeywordsRanges: (sap at: 4) ] - ifFalse: [ - methodNode - selector: (sap at: 1) - arguments: (sap at: 2) - precedence: (sap at: 3) - temporariesDeclaration: temporaries - block: block - encoder: encoder - primitive: primitives - properties: properties - selectorKeywordsRanges: (sap at: 4) ]. - - self interactive ifTrue: [ self performInteractiveChecks: methodNode ]. - - ^methodNode! ! -!Parser methodsFor: 'expression types' stamp: 'RNG 3/13/2020 00:24:08' prior: 50409553! - temporaries - " [ '|' (variable)* '|' ]" - | tempDeclarationNodes theActualText declarationStartIndex | - (self match: #verticalBar) ifFalse: - ["no temps" - doitFlag ifTrue: - [tempsMark := self interactive - ifTrue: [requestor selectionInterval first] - ifFalse: [1]. - ^ self noTempsDeclaration ]. - tempsMark := hereMark "formerly --> prevMark + prevToken". - tempsMark > 0 ifTrue: - [theActualText := source contents. - [tempsMark < theActualText size and: [(theActualText at: tempsMark) isSeparator]] - whileTrue: [tempsMark := tempsMark + 1]]. - ^ self noTempsDeclaration ]. - tempDeclarationNodes _ OrderedCollection new. - declarationStartIndex _ prevMark. - [hereType == #word] whileTrue: [ - self advanceWithRangeDo: [ :variableName :range | - | variableNode | - variableNode _ encoder bindTemp: variableName range: range. - tempDeclarationNodes addLast: (self createTempDeclarationOf: variableNode sourceRange: range) ] ]. - (self match: #verticalBar) ifTrue: [ - tempsMark := prevMark. - ^ self - createTempsDeclarationWith: tempDeclarationNodes - sourceRange: (declarationStartIndex to: prevMark) ]. - ^ self expected: 'Vertical bar'! ! -!Parser methodsFor: 'expression types' stamp: 'RNG 3/13/2020 00:24:05' prior: 50409751! - temporaryBlockVariablesFor: aBlockNode - "Scan and answer temporary block variables." - - | tempDeclarationNodes declarationStartIndex | - (self match: #verticalBar) ifFalse: - "There are't any temporary variables." - [aBlockNode tempsMark: prevMark + requestorOffset. - ^ self noTempsDeclaration ]. - - tempDeclarationNodes _ OrderedCollection new. - declarationStartIndex _ prevMark. - [hereType == #word] whileTrue: [ - self advanceWithRangeDo: [ :variableName :range | - | variableNode | - variableNode _ encoder bindBlockTemp: variableName within: aBlockNode range: range. - tempDeclarationNodes addLast: (self createTempDeclarationOf: variableNode sourceRange: range) ] ]. - (self match: #verticalBar) ifFalse: - [^self expected: 'Vertical bar']. - aBlockNode tempsMark: prevMark + requestorOffset. - ^ self - createTempsDeclarationWith: tempDeclarationNodes - sourceRange: (declarationStartIndex to: prevMark)! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4086-TemporariesDefinitionASTNode-NahuelGarbezza-2020Mar13-00h15m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4060] on 13 March 2020 at 12:29:32 am'! - -"Change Set: 4061-CuisCore-AuthorName-2020Mar13-00h27m -Date: 13 March 2020 -Author: Nahuel Garbezza - -Cleanup parse logic for temporaries as Array. Now generating temporary declaration nodes"! -!Parser methodsFor: 'expression types' stamp: 'RNG 3/13/2020 00:28:02' prior: 50502258! - blockExpression - "[ ({:var} |) (| {temps} |) (statements) ] => BlockNode." - - | blockNode tempsDeclarationNode variableNodes temporaryBlockVariables start | - blockNode := BlockNode new. - variableNodes := OrderedCollection new. - start := prevMark + requestorOffset. - "Gather parameters." - [self match: #colon] whileTrue: - [self argumentNameWithRangeDo: [ :argumentName :range | - variableNodes addLast: (encoder bindBlockArg: argumentName within: blockNode range: range)]]. - (variableNodes size > 0 & (hereType ~~ #rightBracket) and: [(self match: #verticalBar) not]) ifTrue: - [^self expected: 'Vertical bar']. - - tempsDeclarationNode := self temporaryBlockVariablesFor: blockNode. - temporaryBlockVariables := tempsDeclarationNode allDeclaredVariableNodes. - self statements: variableNodes innerBlock: true blockNode: blockNode. - blockNode temporariesDeclaration: tempsDeclarationNode. - - (self match: #rightBracket) ifFalse: [^self expected: 'Period or right bracket']. - - blockNode noteSourceRangeStart: start end: self endOfLastToken encoder: encoder. - - "The scope of the parameters and temporary block variables is no longer active." - temporaryBlockVariables do: [:variable | variable scope: -1]. - variableNodes do: [:variable | variable scope: -1]! ! -!Parser methodsFor: 'expression types' stamp: 'RNG 3/13/2020 00:27:50' prior: 50502312! - method: noPattern doIt: doIt context: ctxt - " pattern [ | temporaries ] block => MethodNode." - - | sap block primitives tempsDeclarationNode messageComment methodNode | - - sap := self pattern: noPattern inContext: ctxt. - "sap={selector, arguments, precedence}" - self properties selector: (sap at: 1). - encoder selector: (sap at: 1). - (sap at: 2) do: [:argNode | argNode beMethodArg]. - - doIt ifFalse: [self pragmaSequence]. - tempsDeclarationNode := self temporaries. - messageComment := currentComment. - currentComment := nil. - doIt ifFalse: [self pragmaSequence]. - primitives := self pragmaPrimitives. - - self statements: #() innerBlock: doIt. - block := parseNode. - doIt - ifTrue: [block returnLast] - ifFalse: [block returnSelfIfNoOther: encoder]. - hereType == #doIt ifFalse: [^self expected: 'Nothing more']. - - methodNode := self newMethodNode comment: messageComment. - methodNode - selector: (sap at: 1) - arguments: (sap at: 2) - precedence: (sap at: 3) - temporariesDeclaration: tempsDeclarationNode - block: block - encoder: encoder - primitive: primitives - properties: properties - selectorKeywordsRanges: (sap at: 4). - - self interactive ifTrue: [ self performInteractiveChecks: methodNode ]. - - ^methodNode! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4087-TemporariesDefinitionASTNode-NahuelGarbezza-2020Mar13-00h27m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4061] on 29 March 2020 at 4:05:51 pm'! - -"Change Set: 4062-CuisCore-AuthorName-2020Mar29-15h59m -Date: 29 March 2020 -Author: Nahuel Garbezza - -Add visitor protocol to temporary declaration nodes"! -!TemporariesDeclarationNode methodsFor: 'enumerating' stamp: 'RNG 3/29/2020 16:03:34'! - temporaryDeclarationNodesDo: aBlock - - self temporaryDeclarationNodes do: aBlock! ! -!TemporariesDeclarationNode methodsFor: 'visiting' stamp: 'RNG 3/29/2020 15:59:33' overrides: 16884650! - accept: aVisitor - - ^ aVisitor visitTemporariesDeclarationNode: self! ! -!TemporaryDeclarationNode methodsFor: 'visiting' stamp: 'RNG 3/29/2020 16:00:46' overrides: 16884650! - accept: aVisitor - - ^ aVisitor visitTemporaryDeclarationNode: self! ! -!ParseNodeVisitor methodsFor: 'visiting' stamp: 'RNG 3/29/2020 16:02:42'! - visitTemporariesDeclarationNode: aTemporariesDeclarationNode - - aTemporariesDeclarationNode temporaryDeclarationNodesDo: - [ :temporaryDeclarationNode | temporaryDeclarationNode accept: self ]! ! -!ParseNodeVisitor methodsFor: 'visiting' stamp: 'RNG 3/29/2020 16:01:42'! - visitTemporaryDeclarationNode: aTemporaryDeclarationNode! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4088-TemporariesDefinitionASTVisitor-NahuelGarbezza-2020Mar29-15h59m-RNG.1.cs.st----! - -'From Cuis 5.0 [latest update: #4062] on 29 March 2020 at 4:26:28 pm'! - -"Change Set: 4063-CuisCore-AuthorName-2020Mar29-16h16m -Date: 29 March 2020 -Author: Nahuel Garbezza - -Allow ParseNodeVisitor to visit temporary declaration nodes"! -!ParseNodeVisitor methodsFor: 'private - visiting' stamp: 'RNG 3/29/2020 16:23:39'! - visitIfNotNil: aParseNode - "RNG: this was implemented to support unexpected nil temporary declarations - (coming from instances of MethodNode and BlockNode that were living in the image - before the new parse nodes were introduced)" - - aParseNode ifNotNil: [ aParseNode accept: self ]! ! -!ParseNodeVisitor methodsFor: 'visiting' stamp: 'RNG 3/29/2020 16:22:29' prior: 16885349! - visitBlockNode: aBlockNode - - self visitIfNotNil: aBlockNode temporariesDeclaration. - aBlockNode statements do: - [ :statement| statement accept: self ]! ! -!ParseNodeVisitor methodsFor: 'visiting' stamp: 'RNG 3/29/2020 16:25:47' prior: 16885404! - visitMethodNode: aMethodNode - - self visitIfNotNil: aMethodNode temporariesDeclaration. - aMethodNode block accept: self! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4089-TemporariesDefinitionASTVisitor-NahuelGarbezza-2020Mar29-16h16m-RNG.1.cs.st----! - -'From Cuis 5.0 [latest update: #4062] on 29 March 2020 at 4:42:17 pm'! - -"Change Set: 4064-CuisCore-AuthorName-2020Mar29-16h26m -Date: 29 March 2020 -Author: Nahuel Garbezza - -Encapsulate iteration of collections for some parse nodes"! -!BraceNode methodsFor: 'enumerating' stamp: 'RNG 3/29/2020 16:29:30'! - elementsDo: aBlock - - elements do: aBlock! ! -!BlockNode methodsFor: 'enumerating' stamp: 'RNG 3/29/2020 16:37:51'! - statementsDo: aBlock - - statements do: aBlock! ! -!BraceNode methodsFor: 'code generation (closures)' stamp: 'RNG 3/29/2020 16:29:52' prior: 16790936! - analyseTempsWithin: scopeBlock "" rootNode: rootNode "" assignmentPools: assignmentPools "" - - self elementsDo: [ :node | - node analyseTempsWithin: scopeBlock rootNode: rootNode assignmentPools: assignmentPools ]! ! -!BraceNode methodsFor: 'code generation (new scheme)' stamp: 'RNG 3/29/2020 16:35:42' prior: 16791007! - emitCodeForValue: stack encoder: encoder - - (encoder supportsClosureOpcodes - "Hack; we have no way of knowing how much stack space is available" - and: [elements size <= self maxElementsForConsArray]) ifTrue: - [ self elementsDo: [:node| node emitCodeForValue: stack encoder: encoder]. - encoder genPushConsArray: elements size. - stack - pop: elements size; - push: 1. - ^self]. - ^emitNode emitCodeForValue: stack encoder: encoder! ! -!MessageNode methodsFor: 'macro transformations' stamp: 'RNG 3/29/2020 16:36:18' prior: 16869163! - transformCase: encoder - - | caseNode | - caseNode := arguments first. - (caseNode isMemberOf: BraceNode) ifFalse: [^false]. - (caseNode blockAssociationCheck: encoder) ifFalse: [^false]. - (arguments size = 1 - or: [self checkBlock: arguments last as: 'otherwise arg' from: encoder maxArgs: 0]) ifFalse: - [^false]. - caseNode elementsDo: - [:messageNode | - messageNode receiver noteOptimizedIn: self. - messageNode arguments first noteOptimizedIn: self]. - arguments size = 2 ifTrue: - [arguments last noteOptimizedIn: self]. - ^true! ! -!TemporariesDeclarationNode methodsFor: 'enumerating' stamp: 'RNG 3/29/2020 16:38:52' prior: 50502548! - temporaryDeclarationNodesDo: aBlock - - tempDeclarationNodes do: aBlock! ! -!ParseNodeVisitor methodsFor: 'visiting' stamp: 'RNG 3/29/2020 16:27:55' prior: 50502604! - visitBlockNode: aBlockNode - - self visitIfNotNil: aBlockNode temporariesDeclaration. - aBlockNode statementsDo: - [ :statement| statement accept: self ]! ! -!ParseNodeVisitor methodsFor: 'visiting' stamp: 'RNG 3/29/2020 16:36:33' prior: 16885355! - visitBraceNode: aBraceNode - - aBraceNode elementsDo: - [ :element | element accept: self ]! ! -!VariableScopeFinder methodsFor: 'visiting' stamp: 'RNG 3/29/2020 16:28:09' prior: 16942180 overrides: 50502695! - visitBlockNode: aBlockNode - "Answer the minimum enclosing node for aVariabe or nil if none. - If the variable is accessed in more than one statement then aBlockNode is the - enclosing node, otherwise it is which ever single block node that includes it, if any." - ^(self enclosingNodeFor: [:aBlock| aBlockNode statementsDo: aBlock] of: aBlockNode) ifNotNil: - [:aNode| - aNode isBlockNode ifTrue: [aNode] ifFalse: [aBlockNode]]! ! -!VariableScopeFinder methodsFor: 'visiting' stamp: 'RNG 3/29/2020 16:37:34' prior: 16942196 overrides: 50502703! - visitBraceNode: aBraceNode - "Answer the minimum enclosing node for aVariabe or nil if none. - If the variable is accessed in more than one subexpression then aBraceNode - is the enclosing node, otherwise it is which ever single node that includes it, if any." - ^self - enclosingNodeFor: [:aBlock| aBraceNode elementsDo: aBlock] - of: aBraceNode! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4090-TemporariesDefinitionASTVisitor-NahuelGarbezza-2020Mar29-16h26m-RNG.1.cs.st----! - -'From Cuis 5.0 [latest update: #4085] on 30 March 2020 at 3:14:54 pm'! -!ChangeList class methodsFor: 'scanning' stamp: 'HAW 3/30/2020 15:09:24' prior: 50479413! - knownPreambles - - ^ { 'commentStamp:'. 'methodsFor:'. }, ChangeList knownFileInPreambles! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4091-knownPreambles-HernanWilkinson-2020Mar30-15h09m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4085] on 30 March 2020 at 3:38:39 pm'! -!Compiler class methodsFor: 'utilities' stamp: 'HAW 3/30/2020 15:38:12'! - notSameMethodsAfterCompilingAll - - " - self notSameMethodsAfterCompilingAll - " - - | notEqual | - - notEqual := OrderedCollection new. - - ProtoObject withAllSubclassesDo: [ :class | - class selectorsDo: [ :selector | | currentCompiledMethod newCompiledMethod | - currentCompiledMethod := class >> selector. - newCompiledMethod := class - basicCompile: currentCompiledMethod sourceCode - notifying: nil - trailer: class defaultMethodTrailer - ifFail: [^self error: 'error compiling']. - currentCompiledMethod = newCompiledMethod method ifFalse: [ notEqual add: currentCompiledMethod ]]. - ]. - - ^notEqual.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4092-notSameMethodsAfterCompilingAll-HernanWilkinson-2020Mar30-15h36m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4074] on 29 March 2020 at 5:06:59 pm'! - -"Change Set: 4075-CuisCore-AuthorName-2020Mar29-16h47m -Date: 29 March 2020 -Author: Nahuel Garbezza - -Fix Extract Method error occurring on some optimized selector cases"! -!MessageNode methodsFor: 'testing' stamp: 'RNG 3/29/2020 17:02:11'! - hasEquivalentArgumentsWith: aMessageNode - - self arguments with: aMessageNode arguments do: - [ :myArgument :otherParseNodeArgument | (myArgument equivalentTo: otherParseNodeArgument) ifFalse: [ ^ false ] ]. - ^ true! ! -!MessageNode methodsFor: 'testing' stamp: 'RNG 3/29/2020 17:06:17' prior: 50488664 overrides: 50488480! - equivalentTo: aParseNode - - ^ ((aParseNode isMessageNode - and: [ self receiver equivalentTo: aParseNode receiver ]) - and: [ self selector = aParseNode selector ]) - and: [ self hasEquivalentArgumentsWith: aParseNode ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4093-ExtractMethodSpecialSelectors-NahuelGarbezza-2020Mar29-16h47m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4074] on 29 March 2020 at 7:37:44 pm'! - -"Change Set: 4075-CuisCore-AuthorName-2020Mar29-19h36m -Date: 29 March 2020 -Author: Nahuel Garbezza - -Remove unused classes from the old implementation of the Extract Temporary refactoring."! - -Smalltalk removeClassNamed: #ExtractToTemporaryRewriter! - -!classRemoval: #ExtractToTemporaryRewriter stamp: 'Install-4094-ExtractMethodClassesRemoval-NahuelGarbezza-2020Mar29-19h36m-RNG.001.cs.st 4/1/2020 17:57:17'! -ParseNodeVisitor subclass: #ExtractToTemporaryRewriter - instanceVariableNames: 'refactoring finder' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Smalltalk removeClassNamed: #ParseNodeToReplaceFinder! - -!classRemoval: #ParseNodeToReplaceFinder stamp: 'Install-4094-ExtractMethodClassesRemoval-NahuelGarbezza-2020Mar29-19h36m-RNG.001.cs.st 4/1/2020 17:57:17'! -ParseNodeVisitor subclass: #ParseNodeToReplaceFinder - instanceVariableNames: 'refactoring currentBlock nodesToReplace blockContainingFirstNodeToReplace firstNodeToReplaceIndex currentStatementIndex' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4094-ExtractMethodClassesRemoval-NahuelGarbezza-2020Mar29-19h36m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4069] on 23 March 2020 at 4:50:04 pm'! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'NPM 3/18/2020 19:50:30'! - selectorsOf: aClass beginningWith: aPrefix - - ^ (AutoCompleterSelectorsCollector for: aPrefix) - addSelectorsOf: aClass; - entriesToShow! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'NPM 3/18/2020 19:50:06'! - unaryAndBinarySelectorsOf: aClass beginningWith: aPrefix - - ^ (AutoCompleterSelectorsCollector for: aPrefix) - addUnaryAndBinarySelectorsOf: aClass; - entriesToShow! ! -!SmalltalkCompleter methodsFor: 'identifier entries - private' stamp: 'NPM 3/17/2020 17:53:08'! - computeIdentifierEntriesBeginningWith: aPrefix - "Use an aux Set to avoid duplicates, but keep the order given." - - | entriesSet lastTitle candidates | - entriesSet _ Set new. - lastTitle _ nil. - - candidates _ Array streamContents: [ :strm | - parser namesBeginningWith: aPrefix do: [ :identifier :kindOfIdentifierTitle | - (entriesSet includes: identifier) ifFalse: [ - kindOfIdentifierTitle = lastTitle ifFalse: [ - strm nextPut: kindOfIdentifierTitle. - lastTitle _ kindOfIdentifierTitle ]. - entriesSet add: identifier. - strm nextPut: identifier ]]]. - entriesSet size = 1 ifTrue: [ - ^ Array with: entriesSet anyOne ] - ifFalse: [ ^ candidates ]! ! -!SmalltalkCompleter methodsFor: 'message entries for unknown class - private' stamp: 'NPM 3/16/2020 23:09:03'! - computeMessageEntriesForUnknowClassAddingPossibleInvalidSelectorsTo: aCollection - - | selectorsToShow | - selectorsToShow _ OrderedCollection new. - - self class protected: [ - Selectors forPrefix: prefix keysAndValuesDo: [ :selector :lastUsedTime | - selectorsToShow := self add: selector and: lastUsedTime to: selectorsToShow. - (Object canUnderstand: selector) ifFalse: [ aCollection add: selector ]]]. - - selectorsToShow size < EntriesLimit ifTrue: [ selectorsToShow _ self sortByLastUsedTime: selectorsToShow ]. - - " To see the timestamps in the menu (need to tweak #insertCompletion: to activate. Right now, just for debugging) - entries _ selectorsToShow collect: [ :ary | ary first, '(', ((DateAndTime fromString: '01/01/1996 00:00') + ary second minutes) printString,')' ] - " - ^ selectorsToShow collect: [ :selectorAndTime | selectorAndTime first ] - -! ! -!SmalltalkCompleter methodsFor: 'accessing' stamp: 'NPM 3/17/2020 03:12:11'! - changePositionTo: newPosition - - position _ newPosition! ! -!SmalltalkCompleter methodsFor: 'accessing' stamp: 'NPM 3/17/2020 17:30:02'! - possibleInvalidSelectors - - ^ possibleInvalidSelectors! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'NPM 3/18/2020 19:50:06' prior: 50483482! - computeMessageEntriesWithBinaryMessageForClass: aClass - - selectorsClasses := Array with: aClass. - - entries := self unaryAndBinarySelectorsOf: aClass beginningWith: prefix. - ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'NPM 3/18/2020 19:51:12' prior: 50483492! - computeMessageEntriesWithoutBinaryMessageForClass: aClass - - selectorsClasses := Array with: aClass. - - entries := self selectorsOf: aClass beginningWith: prefix.! ! -!SmalltalkCompleter methodsFor: 'identifier entries - private' stamp: 'NPM 3/18/2020 20:44:01' prior: 50436375! - computeIdentifierEntries - - canShowSelectorDocumentation _ false. - entries _ self computeIdentifierEntriesBeginningWith: prefix.! ! -!SmalltalkCompleter methodsFor: 'message entries for unknown class - private' stamp: 'NPM 3/18/2020 20:47:56' prior: 50436400! - computeMessageEntriesForUnknowClass - - selectorsClasses _ #(). - possibleInvalidSelectors _ IdentitySet new. - canShowSelectorDocumentation _ true. - entries _ self computeMessageEntriesForUnknowClassAddingPossibleInvalidSelectorsTo: possibleInvalidSelectors.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4095-AutoCompleteRefactor-NicolasPapagnaMaldonado-2020Mar16-22h56m-NPM.5.cs.st----! - -'From Cuis 5.0 [latest update: #4074] on 30 March 2020 at 5:35:06 pm'! - -"Change Set: 4075-CuisCore-AuthorName-2020Mar30-17h23m -Date: 30 March 2020 -Author: Nahuel Garbezza - -Validate temporaries declaration cannot be extracted to a method if it is used outside of the selection interval"! -!MethodNode methodsFor: 'testing' stamp: 'RNG 3/30/2020 17:32:21'! - anyParseNodeWithin: aSourceCodeInterval satisfy: aCondition - - self completeSourceRangesDo: [ :parseNode :sourceRanges | - (aCondition value: parseNode) ifTrue: [ - sourceRanges anySatisfy: [ :sourceRange | aSourceCodeInterval rangeIncludes: sourceRange first ] - :: ifTrue: [ ^ true ]]]. - - ^ false! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 3/30/2020 17:31:54'! - isNotATempDeclarationWithUsagesOutOfIntervalToExtract - - initialNode key isTemporariesDeclaration ifFalse: [ ^ true ]. - - ^ (methodNode - anyParseNodeWithin: (intervalToExtract last to: sourceCode size) - satisfy: [ :parseNode | - parseNode isVariableNode - and: [ initialNode key declaresVariable: parseNode ] ]) not! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 3/30/2020 17:33:26'! - isNotDeclaredWithinIntervalToExtract: aVariableNode - - ^ (methodNode - anyParseNodeWithin: intervalToExtract - satisfy: [ :parseNode | parseNode isTemporariesDeclaration - and: [ parseNode declaresVariable: aVariableNode ] ]) not! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 3/30/2020 17:33:23'! - thereAreNoLocalVariableAssignmentsWithoutDeclaration - - ^ (methodNode - anyParseNodeWithin: intervalToExtract - satisfy: [ :parseNode | - parseNode isAssignmentToTemporary - and: [ self isNotDeclaredWithinIntervalToExtract: parseNode variable ] ]) not! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 3/30/2020 17:32:59' prior: 50492034! - containsValidNodes - - ^ self isNotLeftSideOfAssignment - and: [ self thereAreNoLocalVariableAssignmentsWithoutDeclaration ] - and: [ self thereAreNoReturnExpressions ] - and: [ self isNotATempDeclarationWithUsagesOutOfIntervalToExtract ] - and: [ self isNotATempDeclaration ]! ! - -ExtractMethodExpressionValidation removeSelector: #thereAreNoLocalVariableAssignments! - -!methodRemoval: ExtractMethodExpressionValidation #thereAreNoLocalVariableAssignments stamp: 'Install-4096-ExtractMethodFix-NahuelGarbezza-2020Mar30-17h23m-RNG.001.cs.st 4/1/2020 17:57:18'! -thereAreNoLocalVariableAssignments - - ^ methodNode - allParseNodesWithin: intervalToExtract - satisfy: [ :parseNode | parseNode isAssignmentToTemporary - and: [ self isDeclaredWithinIntervalToExtract: parseNode variable ] ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4096-ExtractMethodFix-NahuelGarbezza-2020Mar30-17h23m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4024] on 30 March 2020 at 6:10:32 pm'! - -Notification subclass: #PoolDefinitionNotification - instanceVariableNames: 'name' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Classes'! - -!classDefinition: #PoolDefinitionNotification category: #'Kernel-Classes' stamp: 'Install-4097-PoolDefinitionNotification-HernanWilkinson-2020Mar30-18h08m-HAW.1.cs.st 4/1/2020 17:57:18'! -Notification subclass: #PoolDefinitionNotification - instanceVariableNames: 'name' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Classes'! -!Class methodsFor: 'initialization' stamp: 'HAW 3/30/2020 18:09:32' prior: 16803027! - sharing: poolString - "Set up sharedPools. Answer whether recompilation is advisable." - | oldPools | - oldPools _ self sharedPools. - sharedPools _ OrderedCollection new. - (Scanner new scanFieldNames: poolString) do: - [:poolName | - sharedPools add: (Smalltalk at: poolName asSymbol ifAbsent:[ - (PoolDefinitionNotification signalNamed: poolName) - ifTrue:[Smalltalk at: poolName asSymbol put: Dictionary new] - ifFalse:[^self error: poolName,' does not exist']])]. - sharedPools isEmpty ifTrue: [sharedPools _ nil]. - ^oldPools anySatisfy: [ :pool | - self sharedPools noneSatisfy: [ :p | p == pool ]]! ! -!PositionableStream methodsFor: 'fileIn/Out' stamp: 'HAW 3/30/2020 18:09:14' prior: 50479428! -compileNextChunkHandlingExceptions - - [ self compileNextChunk ] - on: InMidstOfFileinNotification, UndeclaredVariableWarning, PoolDefinitionNotification - do: [ :ex | ex resume: true ]! ! -!PoolDefinitionNotification methodsFor: 'exception handling' stamp: 'HAW 3/30/2020 18:10:04' overrides: 16879527! - defaultAction - - | shouldResume | - - shouldResume := PopUpMenu confirm: 'The pool dictionary ', name,' does not exist.', - '\Do you want it automatically created?' withNewLines. - - ^ self resume: shouldResume ! ! -!PoolDefinitionNotification methodsFor: 'initialization' stamp: 'HAW 3/30/2020 18:10:08'! - initializeNamed: aName - - name := aName ! ! -!PoolDefinitionNotification class methodsFor: 'signaling' stamp: 'HAW 3/30/2020 18:09:58'! - signalNamed: aName - - ^(self named: aName) signal! ! -!PoolDefinitionNotification class methodsFor: 'instance creation' stamp: 'HAW 3/30/2020 18:09:54'! - named: aName - - ^self new initializeNamed: aName! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4097-PoolDefinitionNotification-HernanWilkinson-2020Mar30-18h08m-HAW.1.cs.st----! - -'From Cuis 5.0 [latest update: #4069] on 30 March 2020 at 7:41:32 pm'! -!SHTextStyler methodsFor: 'private' stamp: 'pb 3/30/2020 19:39:57' prior: 16903183! - privateFormatAndConvert - self subclassResponsibility ! ! -!SHTextStyler methodsFor: 'private' stamp: 'pb 3/30/2020 19:40:05' prior: 16903187! - privateStyle - self subclassResponsibility ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4098-should-be-subclassResponsibility-PhilBellalouna-2020Mar30-19h39m-pb.001.cs.st----! - -'From Cuis 5.0 [latest update: #4069] on 17 March 2020 at 1:55:28 pm'! -!Form methodsFor: 'analyzing' stamp: 'pb 3/17/2020 13:39:41' prior: 50383310! - primCountBits - "Count the non-zero pixels of this form." - self depth > 8 ifTrue: [ - ^(self asFormOfDepth: 8) primCountBits]. - ^ (BitBlt toForm: self) - fillColor: (Bitmap with: 0); - destRect: self boundingBox; - combinationRule: 32; - copyBits! ! -!Form methodsFor: 'converting' stamp: 'pb 3/17/2020 13:38:02' prior: 50383504! - asGrayForm: componentIndex -"Native depth" - "Assume the receiver is a grayscale image. Return a GrayForm computed by extracting the brightness levels of one color component. This technique allows a 32-bit Form to be converted to an 8-bit GrayForm to save space while retaining a full 255 levels of gray. (The usual colormapping technique quantizes to 8, 16, or 32 levels, which loses information.) - - If component = 1, take the alpha component - If component = 2, take the red component - If component = 3, take the green component - If component = 4, take the blue component - " - | f32 result map mask shift | - self depth = 32 ifFalse: [ - f32 _ Form extent: self extent depth: 32. - self displayOn: f32. - ^ f32 asGrayForm: componentIndex ]. - - result _ GrayForm extent: self extent. - shift _ #(-24 -16 -8 0) at: componentIndex. - mask _ #(16rFF000000 16rFF0000 16rFF00 16rFF) at: componentIndex. - map _ ColorMap masks: { mask. 0. 0. 0 } shifts: { shift. 0. 0. 0 }. - (BitBlt toForm: result) - sourceForm: self; - combinationRule: Form over; - colorMap: map; - sourceRect: self boundingBox ; - destOrigin: `0@0`; - copyBits. - ^ result! ! -!Form methodsFor: 'converting' stamp: 'pb 3/17/2020 13:39:15' prior: 50383543! - asGrayScaleAndTransparent: componentIndex -"Native depth" - "Assume the receiver is a grayscale image. Return a grayscale ColorForm computed by extracting the brightness levels of one color component. This technique allows a 32-bit Form to be converted to an 8-bit ColorForm to save space while retaining a full 255 levels of gray. (The usual colormapping technique quantizes to 8, 16, or 32 levels, which loses information.) - - If component = 1, take the alpha component - If component = 2, take the red component - If component = 3, take the green component - If component = 4, take the blue component - " - | f32 result map mask shift | - self depth = 32 ifFalse: [ - f32 _ Form extent: self extent depth: 32. - self displayOn: f32. - ^ f32 asGrayScaleAndTransparent: componentIndex ]. - - result _ ColorForm grayScaleAndTransparentExtent: self extent. - shift _ #(-24 -16 -8 0) at: componentIndex. - mask _ #(16rFF000000 16rFF0000 16rFF00 16rFF) at: componentIndex. - map _ ColorMap masks: { mask. 0. 0. 0 } shifts: { shift. 0. 0. 0 }. - (BitBlt toForm: result) - sourceForm: self; - combinationRule: Form over; - colorMap: map; - sourceRect: self boundingBox; - destOrigin: `0@0`; - copyBits. - - "final BitBlt to zero-out pixels that were truely transparent in the original" - map _ Bitmap new: 512. - map at: 1 put: 16rFF. - (BitBlt toForm: result) - sourceForm: self; - sourceRect: self boundingBox; - destOrigin: `0@0`; - combinationRule: Form erase; - colorMap: map; - copyBits. - ^ result! ! -!Morph methodsFor: 'geometry' stamp: 'pb 3/17/2020 13:51:15' prior: 50384200! - morphPositionInWorld - - self flag: #jmvVer2. - "Most likely we don't want to use global coordinates... - In fact, we could be in many frames of reference at the same time... - This method makes no sense at all!!" - - ^self externalizeToWorld: self morphTopLeft ! ! -!PasteUpMorph methodsFor: 'change reporting' stamp: 'pb 3/17/2020 13:41:52' prior: 50384234 overrides: 16874147! - invalidateDisplayRect: damageRect from: aMorph - "Clip damage reports to my bounds, since drawing is clipped to my bounds." - - self == self world - ifTrue: [ worldState recordDamagedRect: (damageRect intersect: self morphLocalBounds ) ] - ifFalse: [ super invalidateDisplayRect: damageRect from: aMorph ]! ! -!PasteUpMorph methodsFor: 'project state' stamp: 'pb 3/17/2020 13:42:03' prior: 50384283! - viewBox - - ^ worldState - ifNotNil: [ - self morphLocalBounds ] - ifNil: [ - self world viewBox ]! ! -!EllipseMorph methodsFor: 'geometry testing' stamp: 'pb 3/17/2020 13:36:07' prior: 50384323 overrides: 16875610! - morphContainsPoint: aLocalPoint - - | radius other delta xOverY | - (self morphLocalBounds containsPoint: aLocalPoint) ifFalse: [^ false]. "quick elimination" - extent > `1@1` - ifFalse: [^ true]. "Degenerate case -- code below fails by a bit" - - radius _ extent y asFloat / 2. - other _ extent x asFloat / 2. - delta _ aLocalPoint - (other@radius). - xOverY _ extent x asFloat / extent y asFloat. - ^ (delta x asFloat / xOverY) squared + delta y squared <= radius squared! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:42:18' prior: 50384376! - draw3DLookOn: aCanvas - - | borderStyleSymbol c | - borderStyleSymbol _ self isPressed ifFalse: [ #raised ] ifTrue: [ #inset ]. - c _ color. - self mouseIsOver ifTrue: [ c _ c lighter ]. - aCanvas - fillRectangle: self morphLocalBounds - color: c - borderWidth: borderWidth - borderStyleSymbol: borderStyleSymbol - baseColorForBorder: c. - - self drawRegularLabelOn: aCanvas! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:42:43' prior: 50384391! - drawRoundGradientLookOn: aCanvas - | r colorForButton rect bottomFactor topFactor | - - self isPressed - ifFalse: [ - topFactor _ Theme current buttonGradientTopFactor. - bottomFactor _ Theme current buttonGradientBottomFactor. - self mouseIsOver - ifTrue: [ - colorForButton _ Color h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ - colorForButton _ color ]] - ifTrue: [ - topFactor _ Theme current buttonGradientBottomFactor. - bottomFactor _ Theme current buttonGradientTopFactor. - colorForButton _ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - Theme current useButtonGradient - ifTrue: [ - rect _ self morphLocalBounds insetBy: `1@3`. - aCanvas - roundRect: rect - color: colorForButton - radius: r - gradientTop: topFactor - gradientBottom: bottomFactor - gradientHeight: Theme current buttonGradientHeight ] - ifFalse: [ - rect _ self morphLocalBounds insetBy: `1@3`. - aCanvas roundRect: rect color: colorForButton radius: r ] - ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawEmbossedLabelOn: aCanvas ] - ifFalse: [ self drawRegularLabelOn: aCanvas ]! ! -!PluggableButtonMorph methodsFor: 'geometry testing' stamp: 'pb 3/17/2020 13:43:00' prior: 50384447 overrides: 16875610! - morphContainsPoint: aLocalPoint - - | iconOrigin | - (self morphLocalBounds containsPoint: aLocalPoint) ifFalse: [ ^false ]. - ^ self isOrthoRectangularMorph or: [ - magnifiedIcon isNil or: [ - iconOrigin _ extent - magnifiedIcon extent // 2. - (magnifiedIcon isTransparentAt: (aLocalPoint - iconOrigin) rounded) not ]]! ! -!SystemWindow methodsFor: 'change reporting' stamp: 'pb 3/17/2020 13:53:05' prior: 50384590! - invalidateTitleArea - - "not really pretty... also invalidating the top border, regardless of it being above or below the title area - (Different themes use various looks, this covers them all)" - self invalidateLocalRect: (self morphTopLeft extent: extent x @ (self labelHeight + borderWidth))! ! -!SystemWindow methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:43:27' prior: 50384602! - drawClassicFrameOn: aCanvas color: titleColor - "Window border encompasses title area. No round corners. No title gradient." - - aCanvas fillRectangle: self morphLocalBounds color: color borderWidth: borderWidth borderStyleSymbol: #simple baseColorForBorder: self widgetsColor. - - "A border was drawn at the left, top and right of the title area. - The look is that the title area is inside the window" - aCanvas fillRectangle: (borderWidth@borderWidth extent: extent x - (2*borderWidth)@ self labelHeight) color: titleColor! ! -!SystemWindow methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:43:37' prior: 50384621! - drawRoundedFrameOn: aCanvas color: widgetsColor - "Title area is not inside window borders" - | bottomFactor topFactor | - Theme current useWindowTitleGradient - ifTrue: [ - topFactor _ Theme current titleGradientTopFactor. - bottomFactor _ Theme current titleGradientBottomFactor ] - ifFalse: [ - topFactor _ 1. - bottomFactor _ 1 ]. - aCanvas - windowFrame: self morphLocalBounds - color: widgetsColor * Theme current titleGradientExtraLightness - radius: Theme current roundedWindowRadius - border: borderWidth - labelHeight: self labelHeight + borderWidth - gradientTop: topFactor - gradientBottom: bottomFactor - insideColor: color! ! -!ScrollBar methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:43:16' prior: 50384846 overrides: 16790395! - drawOn: aCanvas - - aCanvas - fillRectangle: self morphLocalBounds - color: (color alphaMixed: 0.3 with: Theme current scrollbarColor) - borderWidth: borderWidth - borderStyleSymbol: #simple - baseColorForBorder: borderColor! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:35:12' prior: 50433547! - drawContainingRectangle: aCanvas - - aCanvas frameAndFillRectangle: self morphLocalBounds fillColor: self color borderWidth: borderWidth borderColor: borderColor. -! ! -!ImageMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:48:15' prior: 50385157 overrides: 16899205! - drawOn: aCanvas - - aCanvas image: image at: self morphTopLeft! ! -!StringMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:52:32' prior: 50385162 overrides: 16899205! - drawOn: aCanvas - aCanvas - drawString: (contents ifNil: [ '' ]) - at: self morphTopLeft - font: self fontToUse - color: color! ! -!IndentingListItemMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:40:18' prior: 50463659 overrides: 50503485! - drawOn: aCanvas - - | tRect colorToUse sLeft aForm centeringOffset | - isHighlighted ifTrue: [ - aCanvas - fillRectangle: self morphLocalBounds - color: ((Theme current - listHighlightFocused: owner owner hasKeyboardFocus) alpha: 0.3) ]. - isSelected ifTrue: [ - aCanvas - fillRectangle: self morphLocalBounds - color: (Theme current - listHighlightFocused: owner owner hasKeyboardFocus) ]. - - tRect _ self toggleRectangle. - aForm _ isExpanded - ifTrue: [ container expandedForm ] - ifFalse: [ container notExpandedForm ]. - centeringOffset _ ((tRect height - aForm extent y) / 2.0) rounded. - - complexContents hasContents ifTrue: [ - aCanvas - image: aForm - at: (tRect topLeft translatedBy: 0 @ centeringOffset) ]. - - icon isNil - ifFalse: [ - aCanvas - image: icon - at: (tRect topLeft translatedBy: icon width @ centeringOffset). - sLeft _ indentLevel * 12 + 16 + (icon width + 2). - ] - ifTrue: [ - sLeft _ indentLevel * 12 + 16. - ]. - colorToUse _ complexContents preferredColor ifNil: [ color ]. - - aCanvas - drawString: contents asString - at: sLeft@0 - font: self fontToUse - color: colorToUse! ! -!MenuItemMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:41:40' prior: 50472327 overrides: 50503485! - drawOn: aCanvas - | stringColor leftEdge | - - stringColor _ color. - isSelected & isEnabled - ifTrue: [ - aCanvas fillRectangle: self morphLocalBounds color: Theme current menuHighlight]. - leftEdge _ 0. - - self hasMarker ifTrue: [ - leftEdge _ leftEdge + submorphs first morphWidth + 8 ]. - - icon ifNotNil: [ - | iconForm w h factor magnifiedExtent magnifiedIcon | - iconForm _ isEnabled ifTrue: [ icon ] ifFalse: [ icon asGrayScaleAndTransparent ]. - magnifiedIcon _ iconForm. - w _ iconForm width. - h _ iconForm height. - w*h = 0 ifFalse: [ - factor _ extent y * 0.8 / h. - factor = 1.0 ifFalse: [ - magnifiedExtent _ (iconForm extent * factor) rounded. - magnifiedIcon _ iconForm magnifyTo: magnifiedExtent ]]. - aCanvas image: magnifiedIcon at: leftEdge+1 @ (magnifiedIcon height *1//10). - leftEdge _ magnifiedIcon width *12//10 + leftEdge]. - - aCanvas - drawString: contents - at: leftEdge @ 1 - font: self fontToUse - color: stringColor. - subMenu ifNotNil: [ - aCanvas - image: self class subMenuMarker - at: extent x - 8 @ (extent y - self class subMenuMarker height // 2) ]! ! -!LayoutAdjustingMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:41:10' prior: 50385322 overrides: 16899205! - drawOn: aCanvas - - aCanvas - fillRectangle: self morphLocalBounds - color: color! ! -!LayoutMorph methodsFor: 'layout' stamp: 'pb 3/17/2020 13:41:27' prior: 50385328! - layoutBounds - "Return the bounds for laying out children of the receiver" - - ^ self morphLocalBounds! ! -!HaloHandleMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:49:31' prior: 50385533 overrides: 16899205! - drawOn: aCanvas - - aCanvas - image: (self class circleForm: extent) - multipliedBy: color - at: self morphTopLeft ! ! -!InnerHierarchicalListMorph methodsFor: 'geometry' stamp: 'pb 3/17/2020 13:50:18' prior: 50385607! - itemFromPoint: aPoint - "Return the list element (morph) at the given point or nil if outside" - | ptY last | - self hasSubmorphs ifFalse: [ ^nil ]. - (aPoint > self morphTopLeft and: [ aPoint < extent ]) ifFalse: [ ^nil ]. - ptY _ aPoint y. - "note: following assumes that submorphs are vertical, non-overlapping, and ordered" - self firstSubmorph morphPosition y > ptY ifTrue: [ ^nil ]. - last _ self lastSubmorph. - last morphPosition y + last morphHeight < ptY ifTrue: [ ^nil ]. - "now use binary search" - ^self - findSubmorphBinary: [ :m | - (m morphPosition y <= ptY and: [ m morphPosition y + m morphHeight >= ptY ]) - ifTrue: [ 0 ] "found" - ifFalse: [ m morphPosition y + (m morphHeight // 2) > ptY ifTrue: [-1] ifFalse: [1]]]! ! -!InnerListMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:40:29' prior: 50385633! - drawBackgroundForMulti: row on: aCanvas - | selectionDrawBounds c | - "shade the background darker, if this row is selected" - selectionDrawBounds _ self drawBoundsForRow: row. - selectionDrawBounds _ selectionDrawBounds intersect: self morphLocalBounds. - c _ (selectedRow notNil and: [ row = selectedRow]) - ifTrue: [ Theme current listHighlightFocused: owner hasKeyboardFocus ] - ifFalse: [ Theme current listMultiHighlightFocused: owner hasKeyboardFocus ]. - aCanvas fillRectangle: selectionDrawBounds color: c! ! -!InnerListMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:40:40' prior: 50463697! - drawHighlightOn: aCanvas -"Ademas, poner el mouse pointer de relojito si tarda... Detectarlo automaticamente, etc. Aunque no estoy seguro de como hacerlo... quizas colgar un cachito de codigo en un proceso de mayor prioridad, onda 'si pasa 1 segundo, y todavia no te resetee este flag, entonces pone el relojito'" - | selectionDrawBounds | - highlightedRow ifNil: [ ^self ]. - highlightedRow = 0 ifTrue: [ ^self ]. - selectionDrawBounds _ self drawBoundsForRow: highlightedRow. - selectionDrawBounds _ selectionDrawBounds intersect: self morphLocalBounds. - aCanvas - fillRectangle: selectionDrawBounds - color: ((Theme current listHighlightFocused: owner hasKeyboardFocus) alpha: 0.3)! ! -!InnerListMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:40:50' prior: 50385676! - drawSelectionOn: aCanvas - | selectionDrawBounds | - selectedRow ifNil: [ ^self ]. - selectedRow = 0 ifTrue: [ ^self ]. - selectionDrawBounds _ self drawBoundsForRow: selectedRow. - selectionDrawBounds _ selectionDrawBounds intersect: self morphLocalBounds. - aCanvas - fillRectangle: selectionDrawBounds - color: (Theme current listHighlightFocused: owner hasKeyboardFocus)! ! -!InnerTextMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:41:01' prior: 50385691 overrides: 16899205! - drawOn: aCanvas - "Draw the receiver on a canvas" - - false ifTrue: [ self debugDrawLineRectsOn: aCanvas ]. "show line rects for debugging" - - aCanvas - textComposition: self textComposition - bounds: self morphLocalBounds - color: color - selectionColor: (Theme current textHighlightFocused: self hasKeyboardFocus)! ! -!FillInTheBlankMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:36:24' prior: 50385776 overrides: 16899205! - drawOn: aCanvas - - Theme current roundWindowCorners - ifTrue: [ - aCanvas - roundRect: self morphLocalBounds - color: color - radius: Theme current roundedWindowRadius ] - ifFalse: [ super drawOn: aCanvas ]! ! -!TranscriptMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:54:36' prior: 50385786 overrides: 16899205! - drawOn: aCanvas - Transcript - showOnDisplay: true; - displayOn: form in: self morphLocalBounds. - aCanvas image: form at: self morphTopLeft. - Transcript - bounds: self morphBoundsInWorld; - showOnDisplay: doImmediateUpdates. - self updateWorkspace! ! -!MenuLineMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:50:47' prior: 50385797 overrides: 16899205! - drawOn: aCanvas - | baseColor | - baseColor _ owner color. - aCanvas - fillRectangle: (self morphTopLeft corner: extent x @ (extent y / 2)) - color: baseColor twiceDarker. - - aCanvas - fillRectangle: (0 @ (extent y / 2) corner: extent) - color: baseColor twiceLighter! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4099-use-morph-bounds-PhilBellalouna-2020Mar17-13h35m-pb.001.cs.st----! - -'From Cuis 5.0 [latest update: #4099] on 31 March 2020 at 3:55:45 pm'! - -Object subclass: #FontPicker - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #FontPicker category: #'Morphic-Widgets' stamp: 'Install-4100-FontChanger-FontPicker-JuanVuletich-2020Mar31-15h53m-jmv.001.cs.st 4/1/2020 17:57:18'! -Object subclass: #FontPicker - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! -!FontFamily class methodsFor: 'accessing fonts' stamp: 'jmv 3/31/2020 10:18:34'! - familyNamed: aString - " - FontFamily familyNamed: 'DejaVu' - " - ^AvailableFamilies at: aString ifAbsent: [].! ! -!FontPicker class methodsFor: 'prompting user' stamp: 'jmv 3/31/2020 10:42:28'! - familyNames - | monospacedStrikeFont options | - monospacedStrikeFont _ 'DejaVu Sans Mono'. - options _ FontFamily familyNames. - (options includes: monospacedStrikeFont) ifFalse: [ - options _ options copyWith: monospacedStrikeFont ]. - ^ options! ! -!FontPicker class methodsFor: 'prompting user' stamp: 'jmv 3/31/2020 10:42:28'! - promptUser - "Present a menu of font families, answer selection. - FontChanger promptUser - " - ^self promptUserWithFamilies: AbstractFont familyNames.! ! -!FontPicker class methodsFor: 'prompting user' stamp: 'jmv 3/31/2020 10:42:28'! - promptUserAndSetDefault - "Present a menu of available font families, and if one is chosen, change to it." - self promptUserAndSetDefaultWithFamilies: AbstractFont familyNames.! ! -!FontPicker class methodsFor: 'prompting user' stamp: 'jmv 3/31/2020 10:42:28'! - promptUserAndSetDefaultWithFamilies: fontFamilies - "Present a menu of font families, and if one is chosen, change to it." - self promptUserWithFamilies: fontFamilies withMessageOnSelection: #setDefaultFont:! ! -!FontPicker class methodsFor: 'prompting user' stamp: 'jmv 3/31/2020 10:42:28'! - promptUserInstallIfNecessaryWithFamilies: fontFamilies - " - Present a menu of available font families, and if one is chosen, - install it if necessary, and change to it. - " - self promptUserWithFamilies: fontFamilies withMessageOnSelection: #promptUserAndSetDefaultWithFamilies:! ! -!FontPicker class methodsFor: 'prompting user' stamp: 'jmv 3/31/2020 10:42:28'! - promptUserWithFamilies: fontFamilies - "Present a menu of font families, answer selection." - | fontMenu priorFontFamily | - priorFontFamily _ FontFamily defaultFamilyName. - fontMenu _ MenuMorph new defaultTarget: self. - fontFamilies do: [:fontName | - | isCurrent label | - isCurrent _ priorFontFamily sameAs: fontName. - label _ self toSelectableMenuLabel: fontName isCurrent: isCurrent. - fontMenu - add: label - target: fontMenu - action: #modalSelection: - argument: fontName. - ]. - ^FontFamily familyNamed: fontMenu invokeModal.! ! -!FontPicker class methodsFor: 'prompting user' stamp: 'jmv 3/31/2020 10:42:28'! - promptUserWithFamilies: fontFamilies withMessageOnSelection: aMessageSymbol - " - Present a menu of available font families, and if one is chosen, - send aMessageSymbol to self with the corresponding font family as argument. - " - | fontMenu priorFontFamily | - priorFontFamily _ FontFamily defaultFamilyName. - fontMenu _ MenuMorph new defaultTarget: self. - fontFamilies do: [:fontName | - | isCurrent label | - isCurrent _ priorFontFamily sameAs: fontName. - label _ self toSelectableMenuLabel: fontName isCurrent: isCurrent. - fontMenu - add: label - target: self - action: aMessageSymbol - argument: fontName. - ]. - ^fontMenu invokeModal.! ! -!FontPicker class methodsFor: 'changing font' stamp: 'jmv 3/31/2020 10:42:28'! - changeTo: aFontName - "Change the font on the whole system without changing point sizes." - FontFamily defaultFamilyName: aFontName. - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: { - {#setListFontTo:. Preferences standardListFont pointSize.}. - {#setMenuFontTo:. Preferences standardMenuFont pointSize.}. - {#setWindowTitleFontTo:. Preferences windowTitleFont pointSize.}. - {#setCodeFontTo:. Preferences standardCodeFont pointSize.}. - {#setButtonFontTo:. Preferences standardButtonFont pointSize.}. - }. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]. -! ! -!FontPicker class methodsFor: 'changing font' stamp: 'jmv 3/31/2020 10:42:28'! - installFontIfNecessary: aFontName - | isFontInstalled | - isFontInstalled _ FontFamily familyNames includes: aFontName. - isFontInstalled ifFalse: [StrikeFont install: aFontName.].! ! -!FontPicker class methodsFor: 'changing font' stamp: 'jmv 3/31/2020 10:42:28'! - setDefaultAndInstallIfNecessary: aFontName - "install the font if necessary, and change to it on the whole system without changing point sizes." - self installFontIfNecessary: aFontName. - self setDefaultFont: aFontName. -! ! -!FontPicker class methodsFor: 'changing font' stamp: 'jmv 3/31/2020 10:42:28'! - setDefaultFont: aFontName - "Change the font on the whole system without changing point sizes." - FontFamily defaultFamilyName: aFontName. - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: { - {#setListFontTo:. Preferences standardListFont pointSize.}. - {#setMenuFontTo:. Preferences standardMenuFont pointSize.}. - {#setWindowTitleFontTo:. Preferences windowTitleFont pointSize.}. - {#setCodeFontTo:. Preferences standardCodeFont pointSize.}. - {#setButtonFontTo:. Preferences standardButtonFont pointSize.}. - }. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]. - -! ! -!FontPicker class methodsFor: 'private' stamp: 'jmv 3/31/2020 10:42:28'! - toSelectableMenuLabel: aString isCurrent: isCurrent - | label | - isCurrent ifTrue: [label _ ''] ifFalse: [label _ '']. - ^label, aString! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 3/31/2020 10:43:09' prior: 50458078! - preferencesMenu - "Build the preferences menu for the world." - - ^ (self menu: 'Preferences...') - addItemsFromDictionaries: { - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Font Sizes...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Set font...'. - #object -> FontPicker. - #selector -> #promptUserInstallIfNecessaryWithFamilies:. - #arguments -> {FontPicker familyNames}. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'change the current font family.' - } asDictionary. - { - #label -> 'Load extra fonts'. - #object -> FontFamily. - #selector -> #readAdditionalTrueTypeFonts. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'Load additional TrueType fonts included with Cuis.' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }! ! - -Smalltalk removeClassNamed: #FontChanger! - -!classRemoval: #FontChanger stamp: 'Install-4100-FontChanger-FontPicker-JuanVuletich-2020Mar31-15h53m-jmv.001.cs.st 4/1/2020 17:57:18'! -Object subclass: #FontChanger - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-GUI'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4100-FontChanger-FontPicker-JuanVuletich-2020Mar31-15h53m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4100] on 31 March 2020 at 6:32:04 pm'! -!Character class methodsFor: 'converting' stamp: 'jmv 3/31/2020 18:30:21'! - evaluateOnce: aBlock withUtf8BytesOfUnicodeCodePoint: aCodePoint - "Similar to #evaluate:withUtf8BytesOfUnicodeCodePoint:, but aBlock is evaluated just once, and must have 4 parameters." - - | mask nBytes shift byte1 byte2 byte3 byte4 | - aCodePoint < 128 ifTrue: [ - ^aBlock value: aCodePoint value: nil value: nil value: nil ]. - nBytes _ aCodePoint highBit + 3 // 5. - mask _ #(128 192 224 240 248 252 254 255) at: nBytes. - shift _ nBytes - 1 * -6. - byte1 _ (aCodePoint bitShift: shift) + mask. - nBytes >= 2 ifTrue: [ - shift _ shift + 6. - byte2 _ ((aCodePoint bitShift: shift) bitAnd: 63) + 128. - nBytes >= 3 ifTrue: [ - shift _ shift + 6. - byte3 _ ((aCodePoint bitShift: shift) bitAnd: 63) + 128. - nBytes = 4 ifTrue: [ - shift _ shift + 6. - byte4 _ ((aCodePoint bitShift: shift) bitAnd: 63) + 128. - ]. - ]. - ]. - ^aBlock value: byte1 value: byte2 value: byte3 value: byte4.! ! -!String class methodsFor: 'instance creation' stamp: 'jmv 3/31/2020 16:22:54'! - utf32FromUtf8: aByteArray - "Convert the given string from UTF-8 to UTF-32" - - ^IntegerArray streamContents: [ :strm | | bytes codePoint | - bytes _ aByteArray readStream. - [ bytes atEnd ] whileFalse: [ - codePoint _ (Character nextUnicodeCodePointFromUtf8: bytes). - codePoint ifNotNil: [ - strm nextPut: codePoint ]]]! ! -!String class methodsFor: 'instance creation' stamp: 'jmv 3/31/2020 16:25:01'! - utf8FromUtf32: anIntegerArray - "Convert the given string from UTF-8 to UTF-32" - - ^ByteArray streamContents: [ :strm | - anIntegerArray do: [ :codePoint | - Character - evaluate: [ :byte | strm nextPut: byte ] - withUtf8BytesOfUnicodeCodePoint: codePoint ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4101-utf32-JuanVuletich-2020Mar31-18h29m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4101] on 31 March 2020 at 7:07:55 pm'! -!FontPicker class methodsFor: 'prompting user' stamp: 'jmv 3/31/2020 19:00:47'! - promptUserAndSetDefaultInstallIfNecessaryWithFamilies: fontFamilies - " - Present a menu of available font families, and if one is chosen, - install it if necessary, and change to it. - " - self promptUserWithFamilies: fontFamilies withMessageOnSelection: #setDefaultAndInstallIfNecessary:! ! -!FontPicker class methodsFor: 'prompting user' stamp: 'jmv 3/31/2020 19:07:33' prior: 50503761! - promptUser - "Present a menu of font families, answer selection. - FontPicker promptUser - " - ^self promptUserWithFamilies: AbstractFont familyNames.! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 3/31/2020 19:02:26' prior: 50503914! - preferencesMenu - "Build the preferences menu for the world." - - ^ (self menu: 'Preferences...') - addItemsFromDictionaries: { - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Font Sizes...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Set font...'. - #object -> FontPicker. - #selector -> #promptUserAndSetDefaultInstallIfNecessaryWithFamilies:. - #arguments -> {FontPicker familyNames}. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'change the current font family.' - } asDictionary. - { - #label -> 'Load extra fonts'. - #object -> FontFamily. - #selector -> #readAdditionalTrueTypeFonts. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'Load additional TrueType fonts included with Cuis.' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }! ! - -FontPicker class removeSelector: #promptUserInstallIfNecessaryWithFamilies:! - -!methodRemoval: FontPicker class #promptUserInstallIfNecessaryWithFamilies: stamp: 'Install-4102-FontPicker-fixes-JuanVuletich-2020Mar31-19h06m-jmv.001.cs.st 4/1/2020 17:57:18'! -promptUserInstallIfNecessaryWithFamilies: fontFamilies - " - Present a menu of available font families, and if one is chosen, - install it if necessary, and change to it. - " - self promptUserWithFamilies: fontFamilies withMessageOnSelection: #promptUserAndSetDefaultWithFamilies:! - -FontPicker class removeSelector: #changeTo:! - -!methodRemoval: FontPicker class #changeTo: stamp: 'Install-4102-FontPicker-fixes-JuanVuletich-2020Mar31-19h06m-jmv.001.cs.st 4/1/2020 17:57:18'! -changeTo: aFontName - "Change the font on the whole system without changing point sizes." - FontFamily defaultFamilyName: aFontName. - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: { - {#setListFontTo:. Preferences standardListFont pointSize.}. - {#setMenuFontTo:. Preferences standardMenuFont pointSize.}. - {#setWindowTitleFontTo:. Preferences windowTitleFont pointSize.}. - {#setCodeFontTo:. Preferences standardCodeFont pointSize.}. - {#setButtonFontTo:. Preferences standardButtonFont pointSize.}. - }. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]. -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4102-FontPicker-fixes-JuanVuletich-2020Mar31-19h06m-jmv.001.cs.st----! - -----SNAPSHOT----(1 April 2020 17:57:22) Cuis5.0-4102-v3.image priorSource: 5229599! - -----QUIT----(1 April 2020 17:57:31) Cuis5.0-4102-v3.image priorSource: 5523849! - -----STARTUP---- (3 April 2020 11:07:41) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4102-v3.image! - - -'From Cuis 5.0 [latest update: #4102] on 2 April 2020 at 3:45:31 pm'! -!CompiledMethod methodsFor: 'source code management' stamp: 'jmv 4/2/2020 11:38:53'! - getPreamble - | file preamble | - self fileIndex = 0 ifTrue: [^ String new]. "no source pointer for this method" - file _ SourceFiles at: self fileIndex. - file ifNil: [^ '']. "sources file not available" - "file does not exist happens in secure mode" - [ - file name asFileEntry readStreamDo: [ :stream | - preamble _ (self getPreambleFrom: stream at: (0 max: self filePosition)) ifNil: [ '' ]. - ] - ] on: FileDoesNotExistException do: [ :ex | preamble _ '' ]. - ^ preamble! ! -!CompiledMethod class methodsFor: 'source code management aux' stamp: 'HAW 10/29/2019 11:06:21'! - classCategoryFrom: tokens - - ^self field: #category: from: tokens ifAbsentOrNil: [ Categorizer default ]! ! -!CompiledMethod class methodsFor: 'source code management aux' stamp: 'HAW 10/29/2019 10:53:32'! - field: aFieldName from: tokens ifAbsentOrNil: aBlock - - | fieldValue fieldIndex | - - fieldIndex _ tokens indexOf: aFieldName ifAbsent: [ ^aBlock value ]. - fieldValue _ tokens at: fieldIndex + 1 ifAbsent: [ ^aBlock value ]. - - ^ fieldValue ifNil: aBlock! ! -!CompiledMethod class methodsFor: 'source code management aux' stamp: 'jmv 4/2/2020 12:50:44'! - overridenMethodReferenceFrom: tokens - - ^ self field: #overrides: from: tokens ifAbsentOrNil: [ nil ]! ! -!CompiledMethod class methodsFor: 'source code management aux' stamp: 'jmv 4/2/2020 12:51:03'! - priorReferenceFrom: tokens - - ^ self field: #prior: from: tokens ifAbsentOrNil: [ nil ]! ! -!CompiledMethod class methodsFor: 'source code management aux' stamp: 'HAW 10/29/2019 10:54:41'! - stampFrom: tokens - - ^self field: #stamp: from: tokens ifAbsentOrNil: [ '' ] - -! ! -!MessageSet methodsFor: 'message list' stamp: 'jmv 4/2/2020 13:12:43' prior: 50449423 overrides: 16792430! - selectedMessage - "Answer the source method for the currently selected message." - - | class selector | - selectedMessage ifNil: [^ 'Class vanished']. - - class _ selectedMessage actualClass. - selector _ selectedMessage methodSymbol. - selector ifNil: [ ^'prims']. - - selector first isUppercase ifTrue: [ - selector == #Comment ifTrue: [ - currentCompiledMethod _ class organization commentRemoteStr. - ^ class comment ]. - selector == #Definition ifTrue: [ - ^ class definition ]. - selector == #Hierarchy ifTrue: [ - ^ class printHierarchy ]]. - - (class notNil and: [ class includesSelector: selector]) ifFalse: [ - currentCompiledMethod _ nil. - ^ 'Missing']. - - self showingDecompile ifTrue: [ - ^ self decompiledSource ]. - - currentCompiledMethod _ class compiledMethodAt: selector ifAbsent: nil. - self showingDocumentation ifTrue: [ - ^ self commentContents ]. - - ^self sourceStringPrettifiedAndDiffed! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/29/2019 11:06:27' prior: 50481490! - classDefinitionRecordFrom: tokens - - | classDefinition isMeta itemPosition className record fullClassName category stamp | - - itemPosition _ file position. - fullClassName _ tokens second. - isMeta _ fullClassName includesSubString: ' class'. - className _ isMeta ifTrue: [fullClassName substrings first] ifFalse: [fullClassName]. - category _ CompiledMethod classCategoryFrom: tokens. - stamp _ CompiledMethod stampFrom: tokens. - classDefinition _ file nextChunk. - - record _ ChangeRecord new - file: file - position: itemPosition - type: #classDefinition - class: className asSymbol - category: category - meta: isMeta - stamp: stamp. - - record markAsTest: (classDefinition beginsWith: TestCase name asString). - - ^record -! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 17:58:04' prior: 50479629! - scanClassRemoval: tokens - - | doItOnlyIfInBaseSystem removeType classDefinition className description record stamp | - - removeType _ tokens first. - className _ tokens second. - doItOnlyIfInBaseSystem _ removeType == #classMoveToSomePackage:. - stamp _ CompiledMethod stampFrom: tokens. - classDefinition _ file nextChunk. - - record _ ClassDeletionChangeRecord - className: className - definition: classDefinition - doItOnlyIfInBaseSystem: doItOnlyIfInBaseSystem - stamp: stamp. - - description _ doItOnlyIfInBaseSystem - ifTrue: ['clase move to some package: '] - ifFalse: ['class removal: ']. - - self - addItem: record - text: description, className, '; ', stamp ! ! -!ChangeList methodsFor: 'scanning' stamp: 'MGD 12/19/2019 19:36:26' prior: 50501134! - scanClassRenamed: tokens - - | record stamp newName previousName preamble | - - preamble _ tokens first. - previousName _ tokens second. - newName _ tokens fourth. - stamp _ CompiledMethod stampFrom: tokens. - file nextChunk. - - record _ ClassRenamedChangeRecord from: previousName to: newName stamp: stamp. - - self - addItem: record - text: preamble, previousName, ' - ', newName, '; ', stamp ! ! -!ChangeList methodsFor: 'scanning' stamp: 'jmv 4/2/2020 12:51:10' prior: 50500952! - scanMethodDefinition: tokens - - | stamp className priorMethod overridenMethod | - - className _ tokens first. - stamp _ CompiledMethod stampFrom: tokens. - priorMethod _ CompiledMethod priorReferenceFrom: tokens. - overridenMethod _ CompiledMethod overridenMethodReferenceFrom: tokens. - - tokens second == #methodsFor: ifTrue: [ - ^ self scanCategory: tokens third class: className meta: false stamp: stamp prior: priorMethod overrides: overridenMethod ]. - - tokens third == #methodsFor: ifTrue: [ - ^ self scanCategory: tokens fourth class: className meta: true stamp: stamp prior: priorMethod overrides: overridenMethod ]. - - self error: 'Unsupported method definition' -! ! -!ChangeList methodsFor: 'scanning' stamp: 'HAW 10/26/2019 23:23:14' prior: 50479828! - scanMethodRemoval: tokens - - | doItOnlyIfInBaseSystem removeType isMeta sourceCode methodReference className description record selector stamp | - - removeType _ tokens first. - className _ tokens second. - doItOnlyIfInBaseSystem _ removeType == #methodMoveToSomePackage:. - - sourceCode _ file nextChunk. - isMeta _ tokens third == #class. - selector _ isMeta ifTrue: [ tokens fourth ] ifFalse: [ tokens third ]. - stamp _ CompiledMethod stampFrom: tokens. - - methodReference _ MethodReference new - setClassSymbol: className - classIsMeta: isMeta - methodSymbol: selector - stringVersion: className, (isMeta ifTrue: [' class '] ifFalse: [' ']), selector,'; ', stamp. - - record _ MethodDeletionChangeRecord - methodReference: methodReference - doItOnlyIfInBaseSystem: doItOnlyIfInBaseSystem - source: sourceCode - stamp: stamp. - - description _ doItOnlyIfInBaseSystem - ifTrue: ['method move to some package: '] - ifFalse: ['method removal: ']. - - self - addItem: record - text: description, methodReference stringVersion! ! -!VersionsBrowser methodsFor: 'init & update' stamp: 'jmv 4/2/2020 12:51:19' prior: 16942342! - scanVersionsOf: method class: class meta: meta category: category selector: selector - | position stamp prevPos prevFileIndex preamble tokens sourceFilesCopy | - selectorOfMethod _ selector. - currentCompiledMethod _ method. - classOfMethod _ meta ifTrue: [class class] ifFalse: [class]. - changeList _ OrderedCollection new. - list _ OrderedCollection new. - self addedChangeRecord ifNotNil: [ :change | - self addItem: change text: ('{1} (in {2})' format: { change stamp. change fileName }) ]. - listIndex _ 0. - position _ method filePosition. - sourceFilesCopy _ SourceFiles collect: - [:x | x ifNotNil: [ x name asFileEntry readStream ]]. - method fileIndex = 0 ifTrue: [^ nil]. - file _ sourceFilesCopy at: method fileIndex. - [position notNil & file notNil] - whileTrue: - [file position: (0 max: position-150). "Skip back to before the preamble" - [file position < (position-1)] "then pick it up from the front" - whileTrue: [ - preamble _ file nextChunk. - file skipSeparators "Skip any padding" - ]. - - "Preamble is likely a linked method preamble, if we're in - a changes file (not the sources file). Try to parse it - for prior source position and file index" - prevFileIndex _ nil. - prevPos _ nil. - stamp _ ''. - (preamble includesSubString: 'methodsFor:') - ifTrue: [ - tokens _ Scanner new scanTokens: preamble. - stamp _ CompiledMethod stampFrom: tokens. - (CompiledMethod priorReferenceFrom: tokens) ifNotNil: [ :priorMethodRef | - prevFileIndex _ sourceFilesCopy fileIndexFromSourcePointer: priorMethodRef. - prevPos _ sourceFilesCopy filePositionFromSourcePointer: priorMethodRef ]]. - self addItem: - (ChangeRecord new file: file position: position type: #method - class: class name category: category meta: meta stamp: stamp) - text: stamp , ' ' , class name , (meta ifTrue: [' class '] ifFalse: [' ']) , selector. - position _ prevPos. - prevPos notNil ifTrue: [ - file _ sourceFilesCopy at: prevFileIndex]]. - sourceFilesCopy do: [:x | x notNil ifTrue: [x close]]. - self clearSelections! ! -!ClassCommentVersionsBrowser methodsFor: 'basic function' stamp: 'jmv 4/2/2020 12:55:42' prior: 16805352! - scanVersionsOf: class - "Scan for all past versions of the class comment of the given class" - - | oldCommentRemoteStr sourceFilesCopy position prevPos stamp preamble tokens prevFileIndex | - - classOfMethod _ class. - oldCommentRemoteStr _ class organization commentRemoteStr. - currentCompiledMethod _ oldCommentRemoteStr. - selectorOfMethod _ #Comment. - changeList _ OrderedCollection new. - list _ OrderedCollection new. - listIndex _ 0. - oldCommentRemoteStr ifNil:[^ nil] ifNotNil: [oldCommentRemoteStr sourcePointer]. - - sourceFilesCopy _ SourceFiles collect: [ :x | x ifNotNil: [x name asFileEntry readStream]]. - position _ oldCommentRemoteStr position. - file _ sourceFilesCopy at: oldCommentRemoteStr sourceFileNumber. - [ position notNil & file notNil] whileTrue: [ - file position: (0 max: position-150). " Skip back to before the preamble" - [file position < (position-1)] "then pick it up from the front" - whileTrue: [ - preamble _ file nextChunk. - file skipSeparators "Skip any padding" - ]. - - prevPos _ nil. - stamp _ ''. - (preamble includesSubString: 'commentStamp:') - ifTrue: [ - tokens _ Scanner new scanTokens: preamble. - stamp _ CompiledMethod field: #commentStamp: from: tokens ifAbsentOrNil: [ '' ]. - (CompiledMethod priorReferenceFrom: tokens) ifNotNil: [ :priorRef | - prevFileIndex _ sourceFilesCopy fileIndexFromSourcePointer: priorRef. - prevPos _ sourceFilesCopy filePositionFromSourcePointer: priorRef ]] - ifFalse: [ - "The stamp get lost, maybe after a condenseChanges" - stamp _ '']. - self addItem: - (ChangeRecord new file: file position: position type: #classComment - class: class name category: nil meta: class isMeta stamp: stamp) - text: stamp , ' ' , class name , ' class comment'. - prevPos = 0 ifTrue: [ prevPos _ nil ]. - position _ prevPos. - prevPos notNil ifTrue: [ file _ sourceFilesCopy at: prevFileIndex ]]. - sourceFilesCopy do: [ :x | x notNil ifTrue: [ x close ]]. - self clearSelections! ! -!CompiledMethod methodsFor: 'time stamp' stamp: 'jmv 4/2/2020 12:23:16' prior: 50381380! - timeStamp - "Answer the authoring time-stamp for the given method, retrieved from the sources or changes file. Answer the empty string if no time stamp is available. - (CompiledMethod compiledMethodAt: #timeStamp) timeStamp - " - | preamble tokens | - preamble _ self getPreamble. - (preamble includesSubString: 'methodsFor:') ifFalse: [ ^'']. - tokens _ Scanner new scanTokens: preamble. - ^CompiledMethod stampFrom: tokens! ! -!SystemDictionary methodsFor: 'retrieving' stamp: 'jmv 4/2/2020 12:18:19' prior: 16921749! - allMethodsWithString: aString - "Answer a sorted Collection of all the methods that contain, in a string literal, aString as a substring. 2/1/96 sw. The search is case-sensitive, and does not dive into complex literals, confining itself to string constants. - 5/2/96 sw: fixed so that duplicate occurrences of aString in the same method don't result in duplicated entries in the browser" - | aStringSize list | - aStringSize _ aString size. - list _ Set new. - self allBehaviorsDo: [ :class | - class selectorsDo: [ :sel | - (class compiledMethodAt: sel) literalsDo: [ :aLiteral | - ((aLiteral isMemberOf: String) and: [ aLiteral size >= aStringSize ]) ifTrue: [ - (aLiteral includesSubString: aString) ifTrue: [ - list add: - (MethodReference new - setStandardClass: class - methodSymbol: sel) ]]]]]. - ^ list asArray sort! ! -!CodeWindow methodsFor: 'menu commands' stamp: 'jmv 4/2/2020 13:09:20' prior: 16813417! - browseVersions - "Create and schedule a Versions Browser, showing all versions of the - currently selected message. Answer the browser or nil." - | selector class | - selector _ model selectedMessageName. - (selector isNil or: [ MessageSet isPseudoSelector: selector ]) ifTrue: [ - ^ VersionsBrowserWindow - browseCommentOf: model selectedClass ]. - class _ model selectedClassOrMetaClass. - ^ VersionsBrowserWindow - browseVersionsOf: (class compiledMethodAt: selector) - class: model selectedClass - meta: class isMeta - category: (class organization categoryOfElement: selector) - selector: selector! ! - -ChangeList removeSelector: #field:from:ifAbsentOrNil:! - -!methodRemoval: ChangeList #field:from:ifAbsentOrNil: stamp: 'Install-4103-FixMethodPreambleAccess-JuanVuletich-2020Apr02-15h40m-jmv.001.cs.st 4/3/2020 11:07:46'! -field: aFieldName from: tokens ifAbsentOrNil: aBlock - - | fieldValue fieldIndex | - - fieldIndex _ tokens indexOf: aFieldName ifAbsent: [ ^aBlock value ]. - fieldValue _ tokens at: fieldIndex + 1 ifAbsent: [ ^aBlock value ]. - - ^ fieldValue ifNil: aBlock! - -ChangeList removeSelector: #overridenMethodReferenceFrom:! - -!methodRemoval: ChangeList #overridenMethodReferenceFrom: stamp: 'Install-4103-FixMethodPreambleAccess-JuanVuletich-2020Apr02-15h40m-jmv.001.cs.st 4/3/2020 11:07:46'! -overridenMethodReferenceFrom: tokens - - | overridenMethodReference tagIndex | - - tagIndex _ tokens indexOf: #overrides: ifAbsent: [ ^ nil ]. - overridenMethodReference _ tokens at: tagIndex + 1. - - ^ overridenMethodReference -! - -ChangeList removeSelector: #classCategoryFrom:! - -!methodRemoval: ChangeList #classCategoryFrom: stamp: 'Install-4103-FixMethodPreambleAccess-JuanVuletich-2020Apr02-15h40m-jmv.001.cs.st 4/3/2020 11:07:46'! -classCategoryFrom: tokens - - ^self field: #category: from: tokens ifAbsentOrNil: [ Categorizer default ]! - -ChangeList removeSelector: #priorMethodReferenceFrom:! - -!methodRemoval: ChangeList #priorMethodReferenceFrom: stamp: 'Install-4103-FixMethodPreambleAccess-JuanVuletich-2020Apr02-15h40m-jmv.001.cs.st 4/3/2020 11:07:46'! -priorMethodReferenceFrom: tokens - - | priorMethodReference tagIndex | - - tagIndex _ tokens indexOf: #prior: ifAbsent: [ ^ nil ]. - priorMethodReference _ tokens at: tagIndex + 1. - - ^ priorMethodReference -! - -ChangeList removeSelector: #stampFrom:! - -!methodRemoval: ChangeList #stampFrom: stamp: 'Install-4103-FixMethodPreambleAccess-JuanVuletich-2020Apr02-15h40m-jmv.001.cs.st 4/3/2020 11:07:46'! -stampFrom: tokens - - ^self field: #stamp: from: tokens ifAbsentOrNil: [ '' ] - -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4103-FixMethodPreambleAccess-JuanVuletich-2020Apr02-15h40m-jmv.001.cs.st----! - -----SNAPSHOT----(3 April 2020 11:07:50) Cuis5.0-4103-v3.image priorSource: 5523934! - -----QUIT----(3 April 2020 11:07:58) Cuis5.0-4103-v3.image priorSource: 5539435! - -----STARTUP---- (14 April 2020 17:29:13) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4103-v3.image! - - -'From Cuis 5.0 [latest update: #4103] on 4 April 2020 at 1:04:53 pm'! - -Object subclass: #FeatureRequirement - instanceVariableNames: 'name minVersion minRevision maxVersion pathName codePackageFile ' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Package Support'! - -!classDefinition: #FeatureRequirement category: #'System-Package Support' stamp: 'Install-4104-FasterPackageLoad-JuanVuletich-2020Apr04-13h03m-jmv.001.cs.st 4/14/2020 17:29:17'! -Object subclass: #FeatureRequirement - instanceVariableNames: 'name minVersion minRevision maxVersion pathName codePackageFile' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Package Support'! -!FeatureRequirement methodsFor: 'accessing' stamp: 'jmv 4/4/2020 12:24:23'! - codePackageFile - codePackageFile isNil ifTrue: [ - codePackageFile _ CodePackageFile onFileEntry: pathName asFileEntry. - pathName _ nil ]. - ^codePackageFile! ! -!CodePackageFile methodsFor: 'services' stamp: 'jmv 4/4/2020 12:54:10'! - install - "Create, install and answer a (sub)instance of CodePackage - Replace all existing code in the possibly existing CodePackage, removing any code that is not included in us." - | localName newCodePackage pckClass currentCS | - - localName _ fullName asFileEntry name. - ChangeSet installing: packageName do: [ - "This change set will capture a possible class definition for a subclass of CodePackage. - If it only has that, then remove it after package install. - One example needing this is 'Color-Extras.pck.st'" - currentCS _ ChangeSet changeSetForBaseSystem. - currentCS isEmpty ifFalse: [ currentCS _ nil ]. - pckClass _ CodePackage. - classes do: [ :ee | - (ee hasDefinition and: [ee superclassName = 'CodePackage']) ifTrue: [ - ee fileInDefinitionAndMetaclass. - pckClass _ Smalltalk at: ee name ]]. - newCodePackage _ pckClass - named: packageName - createIfAbsent: true - registerIfNew: true. - newCodePackage - fullFileName: fullName; - sourceSystem: sourceSystem; - description: description; - featureSpec: featureSpec. - - fullName asFileEntry readStreamDo: [ :stream | stream fileInAnnouncing: 'Installing ', localName, '...' ]. - methodsToRemove do: [ :methodReference | methodReference actualClass removeSelector: methodReference selector ]. - classesToRemove do: [ :className | (Smalltalk at: className) removeFromSystem ]. - currentCS ifNotNil: [ ChangeSet removeChangeSet: currentCS ]]. - - newCodePackage hasUnsavedChanges: false; triggerEvent: #dirtyFlagChanged. - DataStream initialize. "Just in case" - "If we are installing an already installed package, zap the change set with possible changes done, - as they are irrelevant now: we have the package from disk" - ChangeSet removeChangeSet: (ChangeSet existingOrNewChangeSetForPackage: newCodePackage). - Preferences transcriptLogVerbose ifTrue: [ - Transcript newLine; show: 'Package ', packageName, ' successfully installed'; newLine. - Smalltalk cleanOutUndeclared. - Undeclared notEmpty ifTrue: [ - ('Undeclared: ', Undeclared printString) print ]]. - ^newCodePackage! ! -!CodePackageFile methodsFor: 'accessing' stamp: 'jmv 4/4/2020 12:07:26'! - packageName - ^packageName! ! -!CodePackageFile class methodsFor: 'instance creation' stamp: 'jmv 4/4/2020 11:55:38'! - onFileEntry: aFileEntry - | fullFileName instance pkName | - fullFileName _ aFileEntry pathName. - pkName _ CodePackageFile packageNameFrom: fullFileName. - aFileEntry readStreamDo: [ :stream | - instance _ self new. - instance buildFileStream: stream packageName: pkName fullName: fullFileName ]. - ^instance! ! -!ChangeList methodsFor: 'scanning' stamp: 'jmv 4/4/2020 11:38:19' prior: 50478934! - scanFile: aFile from: startPosition to: stopPosition - - file _ aFile. - changeList _ OrderedCollection new. - list _ OrderedCollection new. - listIndex _ 0. - file position: startPosition. - - 'Scanning ', aFile localName - displayProgressAt: Sensor mousePoint - from: startPosition to: stopPosition - during: [ :barBlock | self scanUpTo: stopPosition informing: barBlock ]. - - self clearSelections! ! -!ChangeList class methodsFor: 'public access' stamp: 'jmv 4/4/2020 12:29:13' prior: 50478991! - browsePackageContents: aFileEntry - "Opens a changeList on a fileStream" - | changeList packageFile | - packageFile _ CodePackageFile onFileEntry: aFileEntry. - aFileEntry readStreamDo: [ :stream | - changeList _ self new scanFile: stream from: 0 to: stream size ]. - "Add deletions of methods and classes that are in the CodePackage (i.e., active in the system) - but are no longer in the CodePackageFile being viewed." - packageFile methodsToRemove do: [ :methodReference | - changeList - addItem: (MethodDeletionChangeRecord new methodReference: methodReference) - text: 'method no longer in package: ', methodReference stringVersion ]. - packageFile classesToRemove do: [ :clsName | - changeList - addItem: (ClassDeletionChangeRecord new className: clsName) - text: 'class no longer in package: ', clsName ]. - changeList clearSelections. - ChangeListWindow open: changeList label: aFileEntry name! ! -!FeatureRequirement methodsFor: 'accessing' stamp: 'jmv 4/4/2020 12:22:56' prior: 16840754! - pathName: aPathNameString - - pathName _ aPathNameString. - codePackageFile _ nil! ! -!FeatureRequirement methodsFor: 'accessing' stamp: 'jmv 4/4/2020 11:58:01' prior: 16840759! - requirements - "Answer my requirements" - - ^self codePackageFile requires! ! -!FeatureRequirement methodsFor: 'requires' stamp: 'jmv 4/4/2020 12:25:19' prior: 50476024! - findPackageFileAsReqOf: mainFeatureOrNil - "Look in known places for packages providing required feature. - Answer wether search was successful." - | packageFileName entry | - pathName ifNotNil: [ - pathName asFileEntry exists ifTrue: [ ^ true ]]. - packageFileName _ self packageFileName. - (mainFeatureOrNil ifNil: [ self ]) placesToLookForPackagesDo: [ :directory | - entry _ directory // packageFileName. - entry exists ifTrue: [ - "Try this one. If success, keep it." - self pathName: entry pathName. - self checkRequirement ifTrue: [ ^true ]. - "Nope. Don't keep it." - self pathName: nil ]]. - ^ false! ! -!FeatureRequirement methodsFor: 'requires' stamp: 'jmv 4/4/2020 12:24:31' prior: 16840785! - install - "Preconditions have been satisfied. Install the required package." - - | existing | - existing _ CodePackage named: self codePackageFile packageName createIfAbsent: false registerIfNew: false. - (existing isNil - or: [ existing hasUnsavedChanges not - or: [ self confirm: 'If you install this package, there are unsaved changes that will be lost.', String newLineString, 'Continue?' ]]) ifTrue: [ - self codePackageFile install. - ]! ! -!FeatureRequirement methodsFor: 'testing' stamp: 'jmv 4/4/2020 11:59:07' prior: 50476044! - checkRequirement - "Answer if I am satisfied by package found at pathName" - - | featureSpec | - featureSpec _ self codePackageFile featureSpec. - ^ featureSpec notNil and: [featureSpec provides satisfies: self ]! ! - -CodePackageFile class removeSelector: #buildFileStream:packageName:fullName:! - -!methodRemoval: CodePackageFile class #buildFileStream:packageName:fullName: stamp: 'Install-4104-FasterPackageLoad-JuanVuletich-2020Apr04-13h03m-jmv.001.cs.st 4/14/2020 17:29:17'! -buildFileStream: aFileStream packageName: pkName fullName: fullFileName - | instance | - instance _ self new. - instance buildFileStream: aFileStream packageName: pkName fullName: fullFileName. - ^instance! - -CodePackageFile class removeSelector: #installFileStream:packageName:fullName:! - -!methodRemoval: CodePackageFile class #installFileStream:packageName:fullName: stamp: 'Install-4104-FasterPackageLoad-JuanVuletich-2020Apr04-13h03m-jmv.001.cs.st 4/14/2020 17:29:17'! -installFileStream: aFileStream packageName: pkName fullName: fullFileName - | instance | - instance _ self new. - instance installFileStream: aFileStream packageName: pkName fullName: fullFileName. - ^instance! - -CodePackageFile class removeSelector: #buildFileStream:! - -!methodRemoval: CodePackageFile class #buildFileStream: stamp: 'Install-4104-FasterPackageLoad-JuanVuletich-2020Apr04-13h03m-jmv.001.cs.st 4/14/2020 17:29:17'! -buildFileStream: aStream - - | fullFileName pkName | - fullFileName _ aStream name. - pkName _ CodePackageFile packageNameFrom: fullFileName. - ^self buildFileStream: aStream packageName: pkName fullName: fullFileName! - -CodePackageFile class removeSelector: #basicInstallPackageStream:! - -!methodRemoval: CodePackageFile class #basicInstallPackageStream: stamp: 'Install-4104-FasterPackageLoad-JuanVuletich-2020Apr04-13h03m-jmv.001.cs.st 4/14/2020 17:29:17'! -basicInstallPackageStream: aStream - - | fullName pkName existing | - fullName _ aStream name. - pkName _ CodePackageFile packageNameFrom: fullName. - existing _ CodePackage named: pkName createIfAbsent: false registerIfNew: false. - (existing isNil - or: [ existing hasUnsavedChanges not - or: [ self confirm: 'If you install this package, there are unsaved changes that will be lost.', String newLineString, 'Continue?' ]]) ifTrue: [ - CodePackageFile - installFileStream: aStream - packageName: pkName - fullName: fullName ]! - -CodePackageFile removeSelector: #install:! - -!methodRemoval: CodePackageFile #install: stamp: 'Install-4104-FasterPackageLoad-JuanVuletich-2020Apr04-13h03m-jmv.001.cs.st 4/14/2020 17:29:17'! -install: aFileStream - "Installs the package. Replace all existing code in the CodePackage, removing any code that is not included in us." - | localName newCodePackage pckClass currentCS | - - "Give reasonable warnings if there is stuff that can't be properly cleaned. Give the user the chance to abort." - Preferences transcriptLogVerbose ifTrue: [ - '=============' print. - classesToRemove notEmpty ifTrue: [ - ('classesToRemove: ', classesToRemove printString) print. - '=============' print ]. - methodsToRemove notEmpty ifTrue: [ - 'methodsToRemove: ' print. - methodsToRemove do: [ :methodReference | methodReference print ]. - '=============' print ]]. - - "Create, install and answer a (sub)instance of CodePackage" - localName _ fullName asFileEntry name. - ChangeSet installing: packageName do: [ - "This change set will capture a possible class definition for a subclass of CodePackage. - If it only has that, then remove it after package install. - One example needing this is 'Color-Extras.pck.st'" - currentCS _ ChangeSet changeSetForBaseSystem. - currentCS isEmpty ifFalse: [ currentCS _ nil ]. - pckClass _ CodePackage. - classes do: [ :ee | - (ee hasDefinition and: [ee superclassName = 'CodePackage']) ifTrue: [ - ee fileInDefinitionAndMetaclass. - pckClass _ Smalltalk at: ee name ]]. - newCodePackage _ pckClass - named: packageName - createIfAbsent: true - registerIfNew: true. - newCodePackage - fullFileName: fullName; - sourceSystem: sourceSystem; - description: description; - featureSpec: featureSpec. - aFileStream fileInAnnouncing: 'Installing ', localName, '...'. - methodsToRemove do: [ :methodReference | methodReference actualClass removeSelector: methodReference selector ]. - classesToRemove do: [ :className | (Smalltalk at: className) removeFromSystem ]. - currentCS ifNotNil: [ ChangeSet removeChangeSet: currentCS ]]. - newCodePackage hasUnsavedChanges: false; triggerEvent: #dirtyFlagChanged. - DataStream initialize. "Just in case" - "If we are installing an already installed package, zap the change set with possible changes done, - as they are irrelevant now: we have the package from disk" - ChangeSet removeChangeSet: (ChangeSet existingOrNewChangeSetForPackage: newCodePackage). - Preferences transcriptLogVerbose ifTrue: [ - Transcript newLine; show: 'Package ', packageName, ' successfully installed'; newLine. - Smalltalk cleanOutUndeclared. - Undeclared notEmpty ifTrue: [ - ('Undeclared: ', Undeclared printString) print ]]. - ^newCodePackage! - -CodePackageFile removeSelector: #installFileStream:packageName:fullName:! - -!methodRemoval: CodePackageFile #installFileStream:packageName:fullName: stamp: 'Install-4104-FasterPackageLoad-JuanVuletich-2020Apr04-13h03m-jmv.001.cs.st 4/14/2020 17:29:17'! -installFileStream: aFileStream packageName: pkName fullName: fullFileName - - self buildFileStream: aFileStream packageName: pkName fullName: fullFileName. - aFileStream reset. - self install: aFileStream! - -Object subclass: #FeatureRequirement - instanceVariableNames: 'name minVersion minRevision maxVersion pathName codePackageFile' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Package Support'! - -!classDefinition: #FeatureRequirement category: #'System-Package Support' stamp: 'Install-4104-FasterPackageLoad-JuanVuletich-2020Apr04-13h03m-jmv.001.cs.st 4/14/2020 17:29:17'! -Object subclass: #FeatureRequirement - instanceVariableNames: 'name minVersion minRevision maxVersion pathName codePackageFile' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Package Support'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4104-FasterPackageLoad-JuanVuletich-2020Apr04-13h03m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4106] on 4 April 2020 at 12:47:59 pm'! -!Dictionary methodsFor: 'removing' stamp: 'jmv 4/4/2020 12:47:43' prior: 50365739! - unreferencedKeys - | currentClass associations referencedAssociations | - currentClass := nil. - associations := self associations asIdentitySet. - referencedAssociations := IdentitySet new: associations size. - Smalltalk allSelect: [ :m | - m methodClass ~~ currentClass ifTrue: [ - currentClass := m methodClass ]. - m literalsDo: [ :l | - (l isVariableBinding and: [associations includes: l]) ifTrue: [ - referencedAssociations add: l]]. - false ]. - ^((associations reject: [:assoc | referencedAssociations includes: assoc]) collect: [:assoc| assoc key]) asSet! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4105-removeUnnededProgressBar-JuanVuletich-2020Apr04-12h47m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4105] on 4 April 2020 at 1:23:47 pm'! -!String methodsFor: 'displaying' stamp: 'jmv 7/17/2017 15:41:46' prior: 50501285! - 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 mousePoint - from: 0 to: 100 - during: [:barBlock | - 1 to: 100 do: [:x | - (Delay forMilliseconds: 10) wait. - barBlock value: x.]]. - -['Now here''s some Real Progress' - displayProgressAt: Sensor mousePoint - from: 0 to: 100 - during: [:barBlock | - 1 to: 100 do: [:x | barBlock value: x. - (Delay forMilliseconds: 100) wait]].] fork - -['Now here''s some Real Progress' - displayProgressAt: Sensor mousePoint - from: 0 to: 10 - during: [:barBlock | - 1 to: 30 do: [:x | barBlock value: x \\ 11. - (Delay forMilliseconds: 100) wait]]] fork - -'Now here''s some Real Progress' - displayProgressAt: Sensor mousePoint - from: 0 to: 10 - during: [:barBlock | - 1 to: 30 do: [:x | barBlock value: nil. - (Delay forMilliseconds: 200) 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. - -The use of ProgressInitiationException allows for avoiding actual -progress display, by catching the exception. -" - ^ProgressInitiationException - display: self - at: aPoint - from: minVal - to: maxVal - during: workBlock! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4106-removeProgressBarLoggingToTranscript-JuanVuletich-2020Apr04-13h21m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4106] on 6 April 2020 at 12:00:48 am'! - -"Change Set: 4107-CuisCore-AuthorName-2020Apr05-23h12m -Date: 5 April 2020 -Author: Nahuel Garbezza - -Allow extract method refactoring to extract declaration of temp variables if they are not used outside of the selection interval. Also refactored parse nodes to parameterize detection logic outside of the applier"! - -Object subclass: #ExtractMethodParametersDetector - instanceVariableNames: 'intervalToExtract methodNodeToRefactor' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractMethodParametersDetector category: #'Tools-Refactoring' stamp: 'Install-4107-CuisCore-NahuelGarbezza-2020Apr05-23h12m-RNG.001.cs.st 4/14/2020 17:29:18'! -Object subclass: #ExtractMethodParametersDetector - instanceVariableNames: 'intervalToExtract methodNodeToRefactor' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!ExtractMethodParametersDetector commentStamp: '' prior: 0! - I am responsible for returning the parse nodes we need to parameterize before performing an extract method refactoring.! -!CodeNode methodsFor: 'accessing' stamp: 'RNG 4/5/2020 19:45:20'! - temporariesDeclaration - - self subclassResponsibility! ! -!CodeNode methodsFor: 'accessing' stamp: 'RNG 4/5/2020 19:45:28'! - temporariesDeclaration: aTemporariesDeclarationNode - - self subclassResponsibility! ! -!CodeNode methodsFor: 'testing' stamp: 'RNG 4/5/2020 19:45:40'! - hasTemporaryVariables - - ^ self temporariesDeclaration declaresAnyVariable! ! -!MethodNode methodsFor: 'accessing' stamp: 'RNG 4/5/2020 19:45:58'! - numberOfStatements - - ^ block statements size! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 4/5/2020 19:46:24'! - findSourceRangeOfNextStatementIn: listOfAncestors - - ^ listOfAncestors - detect: [ :assoc | assoc key isBlockNode or: [ assoc key class = LeafNode ] ] - ifFound: [ :assoc | - (listOfAncestors at: (listOfAncestors indexOf: assoc) - 1) value ] - ifNone: [ listOfAncestors last value ]! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 4/5/2020 19:46:34'! - isNotInsideATempDeclaration - - methodNode completeSourceRangesDo: [ :parseNode :sourceRanges | - (parseNode isTemporariesDeclaration - and: [ sourceRanges anySatisfy: [ :sourceRange | - sourceRange first < intervalToExtract first and: [ sourceRange last > intervalToExtract last ] ] ]) - ifTrue: [ ^ false ] ]. - ^ true! ! -!ExtractMethodParametersDetector methodsFor: 'evaluating' stamp: 'RNG 4/5/2020 22:44:44' overrides: 16881508! - value - - | parseNodesFound | - parseNodesFound := OrderedCollection new. - methodNodeToRefactor completeSourceRangesDo: [ :parseNode :sourceRanges | - (self shouldBeParameterized: parseNode appearingIn: sourceRanges) - ifTrue: [ parseNodesFound add: parseNode ] - ]. - ^ parseNodesFound! ! -!ExtractMethodParametersDetector methodsFor: 'initialization' stamp: 'RNG 4/5/2020 22:48:06'! - initializeFor: aMethodNodeToRefactor at: anIntervalToExtract - - methodNodeToRefactor := aMethodNodeToRefactor. - intervalToExtract := anIntervalToExtract! ! -!ExtractMethodParametersDetector methodsFor: 'private' stamp: 'RNG 4/5/2020 22:45:20'! - blockNodesEnclosingIntervalToExtract - - | nodes | - nodes := Set new. - methodNodeToRefactor completeSourceRangesDo: [ :parseNode :sourceRanges | - (parseNode isBlockNode and: [ self intervalToExtractIsCoveredByAnyOf: sourceRanges ]) - ifTrue: [ nodes add: parseNode ] ]. - ^ nodes! ! -!ExtractMethodParametersDetector methodsFor: 'private' stamp: 'RNG 4/5/2020 22:35:53'! - definedInOuterScope: parseNode - - ^ self nodesThatAddVariablesToScope - anySatisfy: [ :node | node hasLocallyArgumentOrTemporaryNamed: parseNode name ]! ! -!ExtractMethodParametersDetector methodsFor: 'private' stamp: 'RNG 4/5/2020 22:46:47'! - intervalToExtractIncludesAnyOf: sourceRanges - - ^ sourceRanges anySatisfy: [ :sourceRange | - intervalToExtract includes: sourceRange first ]! ! -!ExtractMethodParametersDetector methodsFor: 'private' stamp: 'RNG 4/5/2020 22:38:04'! - intervalToExtractIsCoveredByAnyOf: sourceRanges - - ^ sourceRanges anySatisfy: [ :sourceRange | - sourceRange first < intervalToExtract first - and: [ sourceRange last > intervalToExtract last ] ]! ! -!ExtractMethodParametersDetector methodsFor: 'private' stamp: 'RNG 4/5/2020 22:47:03'! - isNotExtractedAlongWithItsDeclaration: parseNode - - ^ (methodNodeToRefactor - anyParseNodeWithin: intervalToExtract - satisfy: [ :parseNodeInInterval | - parseNodeInInterval isTemporariesDeclaration - and: [ parseNode isVariableNode ] - and: [ parseNodeInInterval declaresVariable: parseNode ] ]) not! ! -!ExtractMethodParametersDetector methodsFor: 'private' stamp: 'RNG 4/5/2020 22:47:08'! - nodesThatAddVariablesToScope - - ^ (Set with: methodNodeToRefactor) - addAll: self blockNodesEnclosingIntervalToExtract; - yourself! ! -!ExtractMethodParametersDetector methodsFor: 'private' stamp: 'RNG 4/5/2020 22:46:30'! - shouldBeParameterized: parseNode appearingIn: sourceRanges - - ^ (self intervalToExtractIncludesAnyOf: sourceRanges) - and: [ parseNode isTempOrArg ] - and: [ self definedInOuterScope: parseNode ] - and: [ self isNotExtractedAlongWithItsDeclaration: parseNode ]! ! -!ExtractMethodParametersDetector class methodsFor: 'instance creation' stamp: 'RNG 4/5/2020 22:47:48'! - for: aMethodNodeToRefactor at: anIntervalToExtract - - ^ self new initializeFor: aMethodNodeToRefactor at: anIntervalToExtract! ! -!ExtractMethodParametersDetector class methodsFor: 'evaluating' stamp: 'RNG 4/5/2020 22:47:55'! -valueFor: aMethodNodeToRefactor at: anIntervalToExtract - - ^ (self for: aMethodNodeToRefactor at: anIntervalToExtract) value! ! -!ExtractMethod class methodsFor: 'validations' stamp: 'RNG 4/5/2020 23:42:05'! - assert: newMessage hasValidParametersForExtracting: anIntervalToExtract from: aMethodNodeToRefactor - - | parseNodesToParameterize | - parseNodesToParameterize := ExtractMethodParametersDetector - valueFor: aMethodNodeToRefactor - at: anIntervalToExtract. - newMessage arguments size = parseNodesToParameterize size - ifFalse: [ self signalExtractMethodWithWrongNumberOfArgumentsError ]! ! -!ExtractMethod class methodsFor: 'error messages' stamp: 'RNG 4/5/2020 22:53:43'! - wrongNumberOrArgumentsGivenErrorMessage - - ^ 'The number of arguments in the given selector is not correct'! ! -!ExtractMethod class methodsFor: 'exceptions' stamp: 'RNG 4/5/2020 23:02:46'! - signalExtractMethodWithWrongNumberOfArgumentsError - - self refactoringError: self wrongNumberOrArgumentsGivenErrorMessage! ! -!ExtractMethodApplier methodsFor: 'refactoring - creation' stamp: 'RNG 4/5/2020 23:40:59'! - refactoringClass - - ^ ExtractMethod! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 4/5/2020 19:46:51' prior: 50503053! - containsValidNodes - - ^ self isNotLeftSideOfAssignment - and: [ self thereAreNoLocalVariableAssignmentsWithoutDeclaration ] - and: [ self thereAreNoReturnExpressions ] - and: [ self isNotATempDeclarationWithUsagesOutOfIntervalToExtract ] - and: [ self isNotInsideATempDeclaration ]! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 4/5/2020 19:47:16' prior: 50489385! - intervalMatchesBeginningOfStatement - - ^ (self findSourceRangeOfNextStatementIn: initialNodeAncestors) value first = intervalToExtract first! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 4/5/2020 19:47:25' prior: 50489392! - intervalMatchesEndOfStatement - - ^ (self findSourceRangeOfNextStatementIn: finalNodeAncestors) last = intervalToExtract last! ! -!ExtractMethod methodsFor: 'private - source code' stamp: 'RNG 4/5/2020 19:47:58' prior: 50488798! - returnCharacterIfNeeded - - | extractedMethodNode | - extractedMethodNode _ Parser parse: extractedSourceCode class: self sourceClass noPattern: true. - ^ (extractedMethodNode numberOfStatements > 1 or: [ extractedMethodNode hasTemporaryVariables ]) - ifTrue: [ '' ] ifFalse: [ '^ ' ]! ! -!ExtractMethod class methodsFor: 'instance creation' stamp: 'RNG 4/5/2020 23:42:05' prior: 50492108! - fromInterval: anIntervalToExtract of: aMethodToExtractCodeFrom to: newMessage categorizedAs: aCategory - - | trimmedIntervalToExtract | - trimmedIntervalToExtract := ExtractMethodIntervalTrimmer - trim: anIntervalToExtract locatedIn: aMethodToExtractCodeFrom sourceCode. - self - assert: newMessage selector canBeDefinedIn: aMethodToExtractCodeFrom methodClass; - assert: trimmedIntervalToExtract isValidIntervalOn: aMethodToExtractCodeFrom; - assert: newMessage hasValidParametersForExtracting: anIntervalToExtract from: aMethodToExtractCodeFrom methodNode. - - ^ self new - initializeFrom: trimmedIntervalToExtract - of: aMethodToExtractCodeFrom - to: newMessage - in: aCategory! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 4/5/2020 22:48:26' prior: 50489034! - parseNodesToParameterize - - ^ ExtractMethodParametersDetector - valueFor: methodToExtractCodeFrom methodNode - at: intervalToExtract! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'RNG 4/5/2020 23:40:39' prior: 50489103! - validateRequiredParameters: parseNodesToParameterize haveACorrespondingKeywordIn: newSelectorKeywords - - newSelectorKeywords size = parseNodesToParameterize size - ifFalse: [ self refactoringClass signalExtractMethodWithWrongNumberOfArgumentsError ]! ! -!ExtractMethodApplier methodsFor: 'refactoring - creation' stamp: 'RNG 4/5/2020 23:41:07' prior: 50489160 overrides: 50441322! - createRefactoring - - ^ self refactoringClass - fromInterval: intervalToExtract - of: methodToExtractCodeFrom - to: self buildNewMessage - categorizedAs: methodToExtractCodeFrom category! ! - -ExtractMethodApplier removeSelector: #shouldBeParameterized:appearingIn:! - -!methodRemoval: ExtractMethodApplier #shouldBeParameterized:appearingIn: stamp: 'Install-4107-CuisCore-NahuelGarbezza-2020Apr05-23h12m-RNG.001.cs.st 4/14/2020 17:29:18'! -shouldBeParameterized: parseNode appearingIn: sourceRanges - - ^ (sourceRanges anySatisfy: [ :sourceRange | intervalToExtract includes: sourceRange first ]) - and: [ parseNode isTempOrArg ] - and: [ self definedInOuterScope: parseNode ]! - -ExtractMethodApplier removeSelector: #intervalToExtractIsCoveredByAnyOf:! - -!methodRemoval: ExtractMethodApplier #intervalToExtractIsCoveredByAnyOf: stamp: 'Install-4107-CuisCore-NahuelGarbezza-2020Apr05-23h12m-RNG.001.cs.st 4/14/2020 17:29:18'! -intervalToExtractIsCoveredByAnyOf: sourceRanges - - ^ sourceRanges anySatisfy: [ :sourceRange | - sourceRange first < intervalToExtract first - and: [ sourceRange last > intervalToExtract last ] ]! - -ExtractMethodApplier removeSelector: #nodesThatAddVariablesToScope! - -!methodRemoval: ExtractMethodApplier #nodesThatAddVariablesToScope stamp: 'Install-4107-CuisCore-NahuelGarbezza-2020Apr05-23h12m-RNG.001.cs.st 4/14/2020 17:29:18'! -nodesThatAddVariablesToScope - - ^ (Set with: methodToExtractCodeFrom methodNode) - addAll: self blockNodesEnclosingIntervalToExtract; - yourself! - -ExtractMethodApplier removeSelector: #signalExtractMethodWithWrongNumberOfArgumentsError! - -!methodRemoval: ExtractMethodApplier #signalExtractMethodWithWrongNumberOfArgumentsError stamp: 'Install-4107-CuisCore-NahuelGarbezza-2020Apr05-23h12m-RNG.001.cs.st 4/14/2020 17:29:18'! -signalExtractMethodWithWrongNumberOfArgumentsError - - ^ ExtractMethod refactoringError: 'The number of arguments in the entered selector is not correct'! - -ExtractMethodApplier removeSelector: #blockNodesEnclosingIntervalToExtract! - -!methodRemoval: ExtractMethodApplier #blockNodesEnclosingIntervalToExtract stamp: 'Install-4107-CuisCore-NahuelGarbezza-2020Apr05-23h12m-RNG.001.cs.st 4/14/2020 17:29:18'! -blockNodesEnclosingIntervalToExtract - - | nodes | - nodes _ Set new. - methodToExtractCodeFrom methodNode completeSourceRangesDo: [ :parseNode :sourceRanges | - (parseNode isBlockNode and: [ self intervalToExtractIsCoveredByAnyOf: sourceRanges ]) - ifTrue: [ nodes add: parseNode ] ]. - ^ nodes! - -ExtractMethodApplier removeSelector: #definedInOuterScope:! - -!methodRemoval: ExtractMethodApplier #definedInOuterScope: stamp: 'Install-4107-CuisCore-NahuelGarbezza-2020Apr05-23h12m-RNG.001.cs.st 4/14/2020 17:29:18'! -definedInOuterScope: parseNode - - ^ self nodesThatAddVariablesToScope - anySatisfy: [ :node | node hasLocallyArgumentOrTemporaryNamed: parseNode name ]! - -ExtractMethodExpressionValidation removeSelector: #isDeclaredWithinIntervalToExtract:! - -!methodRemoval: ExtractMethodExpressionValidation #isDeclaredWithinIntervalToExtract: stamp: 'Install-4107-CuisCore-NahuelGarbezza-2020Apr05-23h12m-RNG.001.cs.st 4/14/2020 17:29:18'! -isDeclaredWithinIntervalToExtract: aVariableNode - - ^ methodNode - allParseNodesWithin: intervalToExtract - satisfy: [ :parseNode | parseNode isBlockNode - and: [ parseNode temporaries includes: aVariableNode ] ]! - -ExtractMethodExpressionValidation removeSelector: #isNotATempDeclaration! - -!methodRemoval: ExtractMethodExpressionValidation #isNotATempDeclaration stamp: 'Install-4107-CuisCore-NahuelGarbezza-2020Apr05-23h12m-RNG.001.cs.st 4/14/2020 17:29:18'! -isNotATempDeclaration - - | startOfFirstOccurrence sourceRanges tempKey allTempSourceRanges | - initialNode key isTemp ifFalse: [ ^ true ]. - sourceRanges _ methodNode rawSourceRanges. - tempKey _ sourceRanges keys detect: [ :parseNode | parseNode isTemp and: [ parseNode equivalentTo: initialNode key ] ]. - allTempSourceRanges _ sourceRanges at: tempKey. - startOfFirstOccurrence _ allTempSourceRanges isInterval - ifTrue: [ allTempSourceRanges first ] ifFalse: [ allTempSourceRanges first first ]. - ^ startOfFirstOccurrence ~= intervalToExtract first! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4107-CuisCore-NahuelGarbezza-2020Apr05-23h12m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4103] on 6 April 2020 at 12:05:43 am'! - -"Change Set: 4104-CuisCore-AuthorName-2020Apr06-00h03m -Date: 6 April 2020 -Author: Nahuel Garbezza - -Change Symbol>>isValidSelector implementation to support binary messages"! -!Symbol methodsFor: 'testing' stamp: 'RNG 3/29/2020 19:56:14'! - isValidBinarySelector - - ^ self isInfix and: [ self allSatisfy: [ :character | character isValidInBinarySelectors ] ]! ! -!Symbol methodsFor: 'testing' stamp: 'RNG 3/29/2020 19:56:38'! - isValidKeywordSelector - - ^ self isKeyword and: [ self keywords allSatisfy: [ :keywordString | keywordString allButLast asSymbol isValidSelector ] ]! ! -!Symbol methodsFor: 'testing' stamp: 'RNG 3/29/2020 19:56:03'! - isValidUnarySelector - - ^ self isUnary and: [ self allSatisfy: [ :character | character isValidInIdentifiers ] ]! ! -!Symbol methodsFor: 'testing' stamp: 'RNG 3/29/2020 19:56:45' prior: 50488470! - isValidSelector - - ^ self isValidUnarySelector - or: [ self isValidBinarySelector ] - or: [ self isValidKeywordSelector ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4108-CuisCore-NahuelGarbezza-2020Apr06-00h03m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4106] on 9 April 2020 at 4:16:20 pm'! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'HAW 4/9/2020 16:11:38'! - addReferencesOf: anInstVarName at: anInstVarIndex to: references - - | reference | - - self methodsDo: [ :aMethod | - (aMethod accessorDescriptionOf: anInstVarName at: anInstVarIndex) ifNotEmpty: [ :description | - reference := MethodReference method: aMethod. - reference prefixStringVersionWith: '[',description, '] - '. - references add: reference ]]. - ! ! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'HAW 4/9/2020 16:12:05'! - allAccessesTo: instVarName - - | references instVarIndex definingClass | - - definingClass _ self whichClassDefinesInstanceVariable: instVarName ifNone: [ ^#() ]. - instVarIndex _ self indexOfInstanceVariable: instVarName. - references _ SortedCollection sortBlock: [ :left :right | left stringVersion <= right stringVersion ]. - - definingClass withAllSubclassesDo: [ :class | class addReferencesOf: instVarName at: instVarIndex to: references ]. - - ^ references ! ! -!InstructionStream methodsFor: 'as yet unclassified' stamp: 'HAW 4/9/2020 15:36:10'! - movePcForward - - pc := self followingPc. -! ! -!CompiledMethod methodsFor: 'accessing' stamp: 'HAW 4/7/2020 15:48:05'! - accessorDescriptionOf: anInstVarName at: anInstVarIndex - - | isReader isWriter | - - (self isGetterOf: anInstVarName at: anInstVarIndex) ifTrue: [ ^ 'getter' ]. - (self isSetterOf: anInstVarName at: anInstVarIndex) ifTrue: [ ^ 'setter' ]. - - isReader := self readsField: anInstVarIndex. - isWriter := self writesField: anInstVarIndex. - - (isReader and: [ isWriter ]) ifTrue: [ ^ 'write/read' ]. - isReader ifTrue: [ ^ 'read' ]. - isWriter ifTrue: [ ^ 'write' ]. - - ^''! ! -!CompiledMethod methodsFor: 'testing' stamp: 'HAW 4/5/2020 23:27:48'! - isGetterOf: anInstVarName at: anInstVarIndex - - ^ self selector = anInstVarName - and: [ self isReturnField - and: [ self returnField + 1 = anInstVarIndex ]]. -! ! -!CompiledMethod methodsFor: 'testing' stamp: 'HAW 4/9/2020 15:36:10'! - isSetterOf: anInstVarName at: anInstVarIndex - - | varIndexCode scanner | - - self isQuick ifTrue: [ ^false ]. - self selector = (anInstVarName, ':') ifFalse: [ ^false ]. - - "I could have use the AST of the method, but parsing the source code could generate errors - that it is why I decided to check the bytecodes - Hernan" - varIndexCode := anInstVarIndex - 1. - scanner := InstructionStream on: self. - scanner nextByte = 16r10 ifFalse: [ ^false ]. - scanner movePcForward. - (self writesFieldCode: varIndexCode with: scanner nextByte using: scanner) ifFalse: [ ^false ]. - scanner movePcForward. - ^scanner nextByte = 16r78 - - ! ! -!CompiledMethod methodsFor: 'scanning' stamp: 'HAW 4/5/2020 23:00:20'! - writesFieldCode: varIndexCode with: byteCode using: scanner - - ^byteCode >= 96 - and: [byteCode <= 103 - ifTrue: [byteCode - 96 = varIndexCode] - ifFalse: - [(byteCode = 129 or: [byteCode = 130]) - ifTrue: [scanner followingByte = varIndexCode and: [varIndexCode <= 63]] - ifFalse: - [byteCode = 132 - and: [(scanner followingByte between: 160 and: 223) - and: [scanner thirdByte = varIndexCode]]]]] -! ! -!MethodReference methodsFor: 'setting' stamp: 'HAW 4/5/2020 22:31:48'! - prefixStringVersionWith: aString - - stringVersion := aString, stringVersion ! ! -!InstructionStream methodsFor: 'scanning' stamp: 'HAW 4/7/2020 15:58:47' prior: 16858255! - scanFor: scanBlock - "Check all bytecode instructions with scanBlock, answer true if scanBlock answers true. - This can be used to, e.g., check whether a method contains 'push closure' bytecodes like this: - aMethod scanFor: [ :b | b = 143 ]" - - | method encoderClass end byteCode | - - method := self method. - end := method endPC. - encoderClass := method encoderClass. - - [pc <= end] whileTrue: [ - byteCode := method at: pc. - (scanBlock value: byteCode) ifTrue: [^true]. - pc := pc + (encoderClass bytecodeSize: byteCode)]. - - ^false! ! -!CompiledMethod methodsFor: 'testing' stamp: 'HAW 4/5/2020 23:29:55' prior: 50491772! - isValid - - "To be polimorphic with MethodReference, important for refactorings - Hernan" - ^true! ! -!CompiledMethod methodsFor: 'scanning' stamp: 'HAW 4/7/2020 15:56:58' prior: 16820348! - writesField: varIndex - "Answer whether the receiver stores into the instance variable indexed - by the argument." - "eem 5/24/2008 Rewritten to no longer assume the compler uses the - most compact encoding available (for EncoderForLongFormV3 support)." - - | varIndexCode scanner | - - self isQuick ifTrue: [^false]. - - varIndexCode := varIndex - 1. - ^(scanner := InstructionStream on: self) scanFor: [:byteCode| - self writesFieldCode: varIndexCode with: byteCode using: scanner ] -! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'HAW 4/9/2020 16:14:03' prior: 16923827! - browseAllAccessesTo: instVarName from: aClass - "Create and schedule a Message Set browser for all the receiver's methods - or any methods of a subclass/superclass that refer to the instance variable name." - - "self new browseAllAccessesTo: 'contents' from: Collection." - - ^ self - browseMessageList: (aClass allAccessesTo: instVarName) - name: 'Accesses to ' , instVarName - autoSelect: instVarName! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4109-ShowAccessInInstVarAccesorBrowser-HernanWilkinson-2020Apr05-20h06m-HAW.003.cs.st----! - -'From Cuis 5.0 [latest update: #4106] on 6 April 2020 at 9:36:16 am'! - -"Change Set: 4110-AddIdIvarToMorph-JuanVuletich-2020Apr06-09h34m -Date: 6 April 2020 -Author: Juan Vuletich - -Adding an instance variable to Morph is tricky. Hence this preamble." -| ui b cs | -Utilities authorInitialsPerSe ifNil: [ Utilities setAuthor ]. -(nil confirm: 'In order to add a new instance variable to Morph, -we need to restart the User Interface process. -You''ll need to re-start the image update to install the next updates.') ifFalse: [ self halt ]. -[ - ui _ UISupervisor ui. - UISupervisor stopUIProcess. - b _ ClassBuilder isSilent. - ClassBuilder beSilent: true. - ClassBuilder new - superclass: Object - subclass: #Morph - instanceVariableNames: 'owner submorphs location layoutNeeded layoutSpec properties id' - classVariableNames: 'LastMorphId' - poolDictionaries: '' - category: 'Morphic-Kernel'. - ClassBuilder beSilent: b. - UISupervisor spawnNewMorphicProcessFor: ui. - ChangeSet installing: '4110-AddIdIvarToMorph-JuanVuletich-2020Apr06-09h34m-jmv.003.cs.st' do: []. - cs _ ChangeSet changeSetForBaseSystem. - (cs name beginsWith: '4110') ifTrue: [ - ChangeSet removeChangeSet: cs ]. - 'Done adding ivar ''id'' to Morph.' print. - 'Please restart [Install New Updates].' print. -] forkAt: 41! - -'From Cuis 5.0 [latest update: #4106] on 6 April 2020 at 10:55:58 am'! - -Object subclass: #Morph - instanceVariableNames: 'owner submorphs location layoutNeeded layoutSpec properties id ' - classVariableNames: 'LastMorphId ' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -!classDefinition: #Morph category: #'Morphic-Kernel' stamp: 'Install-4111-AddIvarIdToMorph-p2-JuanVuletich-2020Apr06-10h53m-jmv.001.cs.st 4/14/2020 17:29:28'! -Object subclass: #Morph - instanceVariableNames: 'owner submorphs location layoutNeeded layoutSpec properties id' - classVariableNames: 'LastMorphId' - poolDictionaries: '' - category: 'Morphic-Kernel'! -!Morph methodsFor: 'accessing' stamp: 'jmv 4/6/2020 10:48:47'! - morphId - "Non zero. Zero id means no Morph." - id isNil ifTrue: [ - LastMorphId isNil ifTrue: [ LastMorphId _ 0 ]. - LastMorphId _ LastMorphId + 1. - id _ LastMorphId ]. - ^id! ! -!Morph class methodsFor: 'initialize-release' stamp: 'jmv 4/6/2020 10:48:10' overrides: 50417623! - releaseClassCachedState - - LastMorphId _ nil. - self allSubInstancesDo: [ :each | - each releaseCachedState ]! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 4/4/2020 19:32:35'! - clippingMorph: aMorph! ! -!Morph methodsFor: 'caching' stamp: 'jmv 4/6/2020 10:45:56' prior: 16874130! - releaseCachedState - "Release any state that can be recomputed on demand, such as the pixel values for a color gradient or the editor state for a TextMorph. This method may be called to save space when a morph becomes inaccessible. Implementations of this method should do 'super releaseCachedState'." - id _ nil.! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 4/4/2020 19:32:57' prior: 16877482! - fullDraw: aMorph - "Draw the full Morphic structure on us" - - "We are already set with a proper transformation from aMorph owner's coordinates to those of our target form." - - | oldClipRect | - self flag: #jmvVer3. - aMorph visible ifFalse: [^ self]. - self into: aMorph. - - currentMorph layoutSubmorphsIfNeeded. - - currentMorph isKnownFailing ifTrue: [ - self drawCurrentAsError. - self outOfMorph. - ^ self]. - - (currentMorph isOwnedByHand and: [ Preferences cheapWindowReframe ]) ifTrue: [ - self drawCurrentAsOutline. - self outOfMorph. - ^ self]. - - "Draw current Morph" - self isCurrentMorphVisible ifTrue: [ - currentMorph drawOn: self ]. - - "Display submorphs back to front" - "coordinate system stack already set up for aMorph - ('ivars transformations' and 'currentTransformation')" - currentMorph hasSubmorphs ifTrue: [ - currentMorph clippedSubmorph ifNotNil: [ :clipped | - self clippingMorph: currentMorph. - oldClipRect _ self clipRect. - self setClipRect: (oldClipRect intersect: self clippingRectForCurrentMorph). - self fullDraw: clipped. - self setClipRect: oldClipRect. - self clippingMorph: nil ]. - currentMorph unclippedSubmorphsReverseDo: [ :m | - self fullDraw: m ]. - ]. - self outOfMorph! ! - -MorphicCanvas removeSelector: #currentOwnerIfClips:! - -!methodRemoval: MorphicCanvas #currentOwnerIfClips: stamp: 'Install-4111-AddIvarIdToMorph-p2-JuanVuletich-2020Apr06-10h53m-jmv.001.cs.st 4/14/2020 17:29:28'! -currentOwnerIfClips: currentMorphOwnerOrNil! - -PasteUpMorph class removeSelector: #releaseClassCachedState! - -!methodRemoval: PasteUpMorph class #releaseClassCachedState stamp: 'Install-4111-AddIvarIdToMorph-p2-JuanVuletich-2020Apr06-10h53m-jmv.001.cs.st 4/14/2020 17:29:28'! -releaseClassCachedState - - "Should use some other way to find relevant instances" - self flag: #jmvVer2. - self allInstancesDo: [ :each | - each releaseCachedState ]! - -Object subclass: #Morph - instanceVariableNames: 'owner submorphs location layoutNeeded layoutSpec properties id' - classVariableNames: 'LastMorphId' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -!classDefinition: #Morph category: #'Morphic-Kernel' stamp: 'Install-4111-AddIvarIdToMorph-p2-JuanVuletich-2020Apr06-10h53m-jmv.001.cs.st 4/14/2020 17:29:28'! -Object subclass: #Morph - instanceVariableNames: 'owner submorphs location layoutNeeded layoutSpec properties id' - classVariableNames: 'LastMorphId' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4111-AddIvarIdToMorph-p2-JuanVuletich-2020Apr06-10h53m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4106] on 5 April 2020 at 9:27:25 pm'! -!String methodsFor: 'displaying' stamp: 'jmv 4/5/2020 21:19:20' prior: 50386203! - 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` - " - 'Display' displayOn: Display at: 10@10. Display forceToScreen. - "! ! -!MenuItemMorph methodsFor: 'private' stamp: 'jmv 4/5/2020 21:18:11' prior: 50388327! - offImage - "Return the form to be used for indicating an '' marker" - | form | - form _ Form extent: (self fontToUse ascent-2) asPoint depth: 32. - form getCanvas - frameAndFillRectangle: form boundingBox fillColor: `(Color gray: 0.9)` - borderWidth: 1 borderColor: `Color black`. - ^form! ! -!MenuItemMorph methodsFor: 'private' stamp: 'jmv 4/5/2020 21:18:07' prior: 50388339! - onImage - "Return the form to be used for indicating an '' marker" - | form | - form _ Form extent: (self fontToUse ascent-2) asPoint depth: 32. - form getCanvas - frameAndFillRectangle: form boundingBox fillColor: `Color gray: 0.8` - borderWidth: 1 borderColor: `Color black`; - fillRectangle: (form boundingBox insetBy: 2) color: `Color black`. - ^form! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4112-UseOnly32BitCanvas-JuanVuletich-2020Apr05-21h18m-jmv.001.cs.st----! - -----SNAPSHOT----(14 April 2020 17:29:31) Cuis5.0-4112-v3.image priorSource: 5539520! - -----QUIT----(14 April 2020 17:29:39) Cuis5.0-4112-v3.image priorSource: 5583719! - -----STARTUP---- (26 May 2020 17:09:01) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4112-v3.image! - - -'From Cuis 5.0 [latest update: #4112] on 14 April 2020 at 6:03:54 pm'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 4/14/2020 17:53:47'! - clippingByCurrentMorphDo: aBlock - | prevClipRect | - - prevClipRect _ self clipRect. - self setClipRect: (prevClipRect intersect: self clippingRectForCurrentMorph). - self clippingMorph: currentMorph. - aBlock ensure: [ - self clippingMorph: nil. - self setClipRect: prevClipRect. ]! ! -!TextModelMorph methodsFor: 'drawing' stamp: 'jmv 3/6/2020 20:03:32' prior: 50461174 overrides: 16790395! - drawOn: aCanvas - "Include a thin red inset border for unaccepted edits, or, if the unaccepted edits are known to conflict with a change made somewhere else to the same method (typically), put a thick red frame" - | bw bc | - self flag: #todo. - "Integrate this method with the Theme system. --cbr" - super drawOn: aCanvas. - bw _ Preferences focusIndicatorWidth. - bc _ nil. - self wantsFrameAdornments ifTrue: [ - model refusesToAccept - ifTrue: [ "Put up feedback showing that code cannot be submitted in this state" - bc _ Color tan ] - ifFalse: [ - self textMorph hasEditingConflicts - ifTrue: [ - bw _ 3. - bc _ Color red ] - ifFalse: [ - self textMorph hasUnacceptedEdits ifTrue: [ bc _ Color red ]]]]. - (drawKeyboardFocusIndicator and: [ self textMorph hasKeyboardFocus ]) - ifTrue: [ bc ifNil: [ bc _ Theme current focusIndicator ]] - ifFalse: [ - bc ifNotNil: [ - bc _ bc - alphaMixed: 0.4 - with: Color white ]]. - bc ifNotNil: [ - aCanvas - frameRectangle: self focusIndicatorRectangle - borderWidth: bw - color: bc ]. - model actualContents isEmpty ifTrue: [ - self - valueOfProperty: #emptyTextDisplayMessage - ifPresentDo: [ :msg | - aCanvas clippingByCurrentMorphDo: [ - aCanvas - drawString: msg - at: self viewableAreaTopLeft - font: nil - color: Theme current textEmptyDisplayMessage ]]].! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 4/14/2020 18:01:25' prior: 50463614! - clippingRectForCurrentMorph - "This rectangle is used for clipping submorphs in BitBltCanvas. - In VectorCanvas we support clipping by any shape, not just rectangles. Then, this rectangle is used as an optimization of the area to be redrawn." - - self subclassResponsibility! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 4/14/2020 17:55:05' prior: 50506012! - fullDraw: aMorph - "Draw the full Morphic structure on us" - - "We are already set with a proper transformation from aMorph owner's coordinates to those of our target form." - - - self flag: #jmvVer3. - aMorph visible ifFalse: [^ self]. - self into: aMorph. - - currentMorph layoutSubmorphsIfNeeded. - - currentMorph isKnownFailing ifTrue: [ - self drawCurrentAsError. - self outOfMorph. - ^ self]. - - (currentMorph isOwnedByHand and: [ Preferences cheapWindowReframe ]) ifTrue: [ - self drawCurrentAsOutline. - self outOfMorph. - ^ self]. - - "Draw current Morph" - self isCurrentMorphVisible ifTrue: [ - currentMorph drawOn: self ]. - - "Display submorphs back to front" - "coordinate system stack already set up for aMorph - ('ivars transformations' and 'currentTransformation')" - currentMorph hasSubmorphs ifTrue: [ - currentMorph clippedSubmorph ifNotNil: [ :clipped | - self clippingByCurrentMorphDo: [ self fullDraw: clipped ]]. - currentMorph unclippedSubmorphsReverseDo: [ :m | - self fullDraw: m ]. - ]. - self outOfMorph! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4113-emptyTextDisplayMessage-fix-JuanVuletich-2020Apr14-17h51m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4113] on 15 April 2020 at 5:38:57 pm'! -!GeometryTransformation commentStamp: '' prior: 16849934! - Superclass of several Geometry Transformations used mainly to specify locations of Morphs. - -Morphs specify a coordinate system in which they and their submorphs are expressed. A Morph's coordinate system is defined by a GeometryTransformation that is applied to points in inner space to convert them to points in outer space. Therefore #externalizePosition: is equivalent of #transform: and #internalizePosition: is equivalent to #inverseTransform:! -!Morph commentStamp: '' prior: 50408175! - A Morph (from the Greek "shape" or "form") is an interactive graphical object. General information on the Morphic system can be found at http://wiki.squeak.org/squeak/morph. - -Morphs exist in a tree, rooted at a World (generally a PasteUpMorph). The morphs owned by a morph are its submorphs. Morphs are drawn recursively; if a Morph has no owner it never gets drawn. To hide a Morph and its submorphs, set its #visible property to false using the #visible: method. - -Structure: -instance var Type Description -owner Morph My parent Morph, or nil for the top-level Morph, which is a - or nil world, typically a PasteUpMorph. -submorphs Array My child Morphs. -location GeometryTransformation Specifies position (and possibly, angle of rotation and scale change) inside owner - See comment at GeometryTransformation -extension MorphExtension Allows extra properties to be stored without adding a - or nil storage burden to all morphs. -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4114-CoupleOfClassComments-JuanVuletich-2020Apr15-17h22m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4109] on 13 April 2020 at 12:10:39 am'! - -"Change Set: 4104-CuisCore-AuthorName-2020Apr04-12h34m -Date: 13 April 2020 -Author: Nahuel Garbezza - -Alpha version of the Extract to Temporary refactoring"! - -ParseNode subclass: #TemporariesDeclarationNode - instanceVariableNames: 'tempDeclarationNodes declarationWritten ' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #TemporariesDeclarationNode category: #'Compiler-ParseNodes' stamp: 'Install-4115-ExtractToTemporary-NahuelGarbezza-2020Apr04-12h34m-RNG.001.cs.st 5/26/2020 17:09:05'! -ParseNode subclass: #TemporariesDeclarationNode - instanceVariableNames: 'tempDeclarationNodes declarationWritten' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -Refactoring subclass: #ExtractToTemporary - instanceVariableNames: 'newVariableName parseNodeToExtract methodNodeToRefactor methodToRefactor updatedSourceCode intervalToExtract sourceCodeToExtract parseNodeWithNewVariableScope' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractToTemporary category: #'Tools-Refactoring' stamp: 'Install-4115-ExtractToTemporary-NahuelGarbezza-2020Apr04-12h34m-RNG.001.cs.st 5/26/2020 17:09:05'! -Refactoring subclass: #ExtractToTemporary - instanceVariableNames: 'newVariableName parseNodeToExtract methodNodeToRefactor methodToRefactor updatedSourceCode intervalToExtract sourceCodeToExtract parseNodeWithNewVariableScope' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #ExtractToTemporaryApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newVariable' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractToTemporaryApplier category: #'Tools-Refactoring' stamp: 'Install-4115-ExtractToTemporary-NahuelGarbezza-2020Apr04-12h34m-RNG.001.cs.st 5/26/2020 17:09:05'! -RefactoringApplier subclass: #ExtractToTemporaryApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newVariable' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!Interval methodsFor: 'refactorings' stamp: 'RNG 4/13/2020 00:06:02'! - shouldTrimToMatchExpressionOn: sourceCode atIndex: currentIndex - - | currentChar | - currentChar := sourceCode at: currentIndex ifAbsent: [ ^ false ]. - ^ currentChar isSeparator or: [ currentChar = $. ] -! ! -!Interval methodsFor: 'refactorings' stamp: 'RNG 4/13/2020 00:05:57'! - trimMatchingParenthesesOn: aSourceCode - - | trimmedInterval | - trimmedInterval := self. - [ - | initialChar endingChar | - initialChar := aSourceCode at: trimmedInterval first ifAbsent: [ nil ]. - endingChar := aSourceCode at: trimmedInterval last ifAbsent: [ nil ]. - initialChar = $( and: [ endingChar = $) ] - ] - whileTrue: [ trimmedInterval _ trimmedInterval first + 1 to: trimmedInterval last - 1 ]. - ^ trimmedInterval! ! -!Interval methodsFor: 'refactorings' stamp: 'RNG 4/13/2020 00:06:21'! - trimToMatchExpressionOn: aSourceCode - - | trimmedInterval | - trimmedInterval := self. - [ self shouldTrimToMatchExpressionOn: aSourceCode atIndex: trimmedInterval first ] - whileTrue: [ trimmedInterval := trimmedInterval first + 1 to: trimmedInterval last ]. - [ self shouldTrimToMatchExpressionOn: aSourceCode atIndex: trimmedInterval last ] - whileTrue: [ trimmedInterval := trimmedInterval first to: trimmedInterval last - 1 ]. - - ^ trimmedInterval trimMatchingParenthesesOn: aSourceCode! ! -!ParseNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 13:03:46'! - isBraceNode - - ^ false! ! -!ParseNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 13:09:00'! - isSelectorNode - - ^ false! ! -!ParseNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 12:54:25'! - isTemporaryDeclaration - - ^ false! ! -!AssignmentNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 12:56:01' overrides: 50488480! - equivalentTo: aParseNode - - ^ aParseNode isAssignmentNode - and: [ self variable equivalentTo: aParseNode variable ] - and: [ self value equivalentTo: aParseNode value ]! ! -!BraceNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 13:07:05' overrides: 50488480! - equivalentTo: aParseNode - - ^ aParseNode isBraceNode and: [ self hasEquivalentElementsTo: aParseNode ]! ! -!BraceNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 13:03:33' overrides: 50506433! - isBraceNode - - ^ true! ! -!BraceNode methodsFor: 'private' stamp: 'RNG 4/4/2020 13:06:30'! - hasEquivalentElementsTo: aBraceNode - - elements with: aBraceNode elements do: [ :myElement :otherElement | - (myElement equivalentTo: otherElement) ifFalse: [ ^ false ] ]. - ^ true! ! -!CodeNode methodsFor: 'accessing' stamp: 'RNG 4/5/2020 19:45:20' prior: 50505302! - temporariesDeclaration - - self subclassResponsibility! ! -!CodeNode methodsFor: 'accessing' stamp: 'RNG 4/5/2020 19:45:28' prior: 50505306! - temporariesDeclaration: aTemporariesDeclarationNode - - self subclassResponsibility! ! -!CodeNode methodsFor: 'private' stamp: 'RNG 4/4/2020 13:41:00'! - hasEquivalentArgumentsWith: aCodeNode - - self arguments with: aCodeNode arguments do: [ :myArgument :otherCodeNodeArgument | - (myArgument equivalentTo: otherCodeNodeArgument) ifFalse: [ ^ false ] ]. - ^ true! ! -!CodeNode methodsFor: 'private' stamp: 'RNG 4/12/2020 20:44:29'! - hasEquivalentTemporariesDeclarationWith: aCodeNode - - ^ (self temporariesDeclaration isNil and: [ aCodeNode temporariesDeclaration isNil ]) - or: [ self temporariesDeclaration equivalentTo: aCodeNode temporariesDeclaration ]! ! -!CodeNode methodsFor: 'testing' stamp: 'RNG 4/5/2020 19:45:40' prior: 50505311! - hasTemporaryVariables - - ^ self temporariesDeclaration declaresAnyVariable! ! -!BlockNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 13:40:17' overrides: 50488480! - equivalentTo: aParseNode - - ^ aParseNode isBlockNode - and: [ self hasEquivalentArgumentsWith: aParseNode ] - and: [ self hasEquivalentTemporariesDeclarationWith: aParseNode ] - and: [ self hasEquivalentStatementsWith: aParseNode ]! ! -!BlockNode methodsFor: 'private' stamp: 'RNG 4/12/2020 17:14:17'! - hasEquivalentStatementsWith: aCodeNode - - self statements with: aCodeNode statements do: [ :myStatement :otherCodeNodeStatement | - (myStatement equivalentTo: otherCodeNodeStatement) ifFalse: [ ^ false ] ]. - ^ true! ! -!MethodNode methodsFor: 'source mapping' stamp: 'RNG 4/4/2020 20:02:38'! - singleCompleteSourceRangeOf: requestedParseNode - "Returns the source range associated with the requested parse node. - Fails if there is no source range, or if there are multiple source ranges." - - self completeSourceRangesDo: [ :parseNode :sourceRanges | - (parseNode equivalentTo: requestedParseNode) ifTrue: [ - sourceRanges size > 1 ifTrue: [ self error: 'there are multiple source ranges for this parse node' ]. - ^ sourceRanges first ] ]. - self error: 'could not find source range for this parse node'! ! -!LeafNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 13:35:08' overrides: 50488480! - equivalentTo: aParseNode - - ^ self class = aParseNode class and: [ self key = aParseNode key ]! ! -!SelectorNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 13:21:32' overrides: 50506544! - equivalentTo: aParseNode - - ^ aParseNode isSelectorNode and: [ super equivalentTo: aParseNode ]! ! -!SelectorNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 13:08:43' overrides: 50506436! - isSelectorNode - - ^ true! ! -!VariableNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 13:21:40' overrides: 50506544! - equivalentTo: aParseNode - - ^ aParseNode isVariableNode and: [ super equivalentTo: aParseNode ]! ! -!MessageNode methodsFor: 'equation translation' stamp: 'RNG 4/12/2020 20:42:11'! - originalArguments - - ^ originalArguments! ! -!MessageNode methodsFor: 'equation translation' stamp: 'RNG 4/12/2020 20:39:00'! - originalReceiver - - ^ originalReceiver! ! -!MessageNode methodsFor: 'private' stamp: 'RNG 4/12/2020 23:20:49'! - compare: myArguments with: othersArguments - - myArguments with: othersArguments do: [ :myArgument :otherArgument | - (myArgument equivalentTo: otherArgument) ifFalse: [ ^ false ] ]. - ^ true! ! -!MessageNode methodsFor: 'private' stamp: 'RNG 4/12/2020 23:21:37'! - hasEquivalentReceiverWith: aMessageNode - - ^ self isCascade - ifTrue: [ originalReceiver equivalentTo: aMessageNode originalReceiver ] - ifFalse: [ receiver equivalentTo: aMessageNode receiver ]! ! -!ReturnNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 12:50:40' overrides: 50488480! - equivalentTo: aParseNode - - ^ aParseNode isReturn and: [ expr equivalentTo: aParseNode expr ]! ! -!TemporariesDeclarationNode methodsFor: 'initialization' stamp: 'RNG 4/4/2020 12:51:49'! - initializeWithAll: aCollectionOfTempDeclarationNodes declarationWritten: aBoolean - - tempDeclarationNodes := aCollectionOfTempDeclarationNodes. - declarationWritten := aBoolean! ! -!TemporariesDeclarationNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 12:53:45'! - declarationWritten - - ^ declarationWritten! ! -!TemporariesDeclarationNode methodsFor: 'testing' stamp: 'RNG 4/13/2020 00:09:45'! -declaresSameVariablesThan: aTemporariesDeclarationNode - - self temporaryDeclarationNodes with: aTemporariesDeclarationNode temporaryDeclarationNodes do: [ :myTempDeclaration :otherTempDeclaration | - (myTempDeclaration equivalentTo: otherTempDeclaration) ifFalse: [ ^ false ] ]. - ^ true! ! -!TemporariesDeclarationNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 12:52:52' overrides: 50488480! - equivalentTo: aParseNode - - ^ aParseNode isTemporariesDeclaration - and: [ self declaresSameVariablesThan: aParseNode ]! ! -!TemporariesDeclarationNode class methodsFor: 'instance creation' stamp: 'RNG 4/4/2020 12:51:26'! - withAll: tempDeclarationNodes declarationWritten: aBoolean - - ^ self new initializeWithAll: tempDeclarationNodes declarationWritten: aBoolean! ! -!TemporaryDeclarationNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 12:54:43' overrides: 50488480! - equivalentTo: aParseNode - - ^ aParseNode isTemporaryDeclaration - and: [ self declaresVariable: aParseNode variableNode ]! ! -!TemporaryDeclarationNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 12:54:00' overrides: 50506439! -isTemporaryDeclaration - - ^ true! ! -!SmalltalkEditor methodsFor: 'extract to temporary' stamp: 'RNG 4/4/2020 13:28:28'! - extractToTemporary - - self ifSourceCodeRefactoringCanBeAppliedDo: [ - ExtractToTemporaryApplier createAndValueHandlingExceptions: [ - ExtractToTemporaryApplier for: self selectionInterval of: self codeProvider currentCompiledMethod ] ]! ! -!SmalltalkEditor methodsFor: 'extract to temporary' stamp: 'RNG 4/4/2020 13:28:19'! - extractToTemporary: aKeyboardEvent - - self extractToTemporary. - ^true! ! -!SmalltalkEditor methodsFor: 'private' stamp: 'RNG 4/4/2020 13:29:56'! - hasValidCurrentCompiledMethod - - ^ (self codeProvider respondsTo: #currentCompiledMethod) - and: [ self codeProvider currentCompiledMethod notNil ]! ! -!ExtractToTemporary methodsFor: 'applying' stamp: 'RNG 2/25/2020 19:06:03' overrides: 50438485! - apply - - self - replaceExtractedCodeWithNewTemporaryVariable; - writeAssignmentStatementOfNewTemporaryVariable; - declareNewTemporaryVariable; - reflectSourceCodeChanges! ! -!ExtractToTemporary methodsFor: 'initialization' stamp: 'RNG 3/29/2020 23:13:34'! - initializeNamed: aNewVariable extractingCodeAt: anIntervalToExtract from: aMethodToRefactor declaringTempIn: blockNodeOfNewVariable - - newVariableName _ aNewVariable. - intervalToExtract _ anIntervalToExtract. - methodToRefactor _ aMethodToRefactor. - methodNodeToRefactor _ methodToRefactor methodNode. - updatedSourceCode _ aMethodToRefactor sourceCode. - sourceCodeToExtract _ updatedSourceCode copyFrom: intervalToExtract first to: intervalToExtract last. - parseNodeWithNewVariableScope _ blockNodeOfNewVariable! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 4/4/2020 19:32:46'! - addNewTemporaryVariableToExistingDeclarationStatement - - | sourceRangeOfLastTempDeclaration positionOfLastTempDeclaration | - parseNodeWithNewVariableScope hasTemporaryVariables - ifTrue: [ - sourceRangeOfLastTempDeclaration := methodNodeToRefactor singleCompleteSourceRangeOf: self lastTemporaryDeclaration. - positionOfLastTempDeclaration := sourceRangeOfLastTempDeclaration last + 1 ] - ifFalse: [ - sourceRangeOfLastTempDeclaration := methodNodeToRefactor singleCompleteSourceRangeOf: parseNodeWithNewVariableScope temporariesDeclaration. - positionOfLastTempDeclaration := sourceRangeOfLastTempDeclaration last - 1 ]. - - self insertAt: positionOfLastTempDeclaration newCodeWith: ' ' , newVariableName! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 3/29/2020 23:16:07'! - declareNewTemporaryVariable - - self hasTemporariesDeclarationBlock - ifTrue: [ self addNewTemporaryVariableToExistingDeclarationStatement ] - ifFalse: [ self insertNewTemporaryDeclarationWithNewVariable ]! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 4/13/2020 00:03:15'! - formattedNewVariableAssignment - - | newVariableAssignment | - newVariableAssignment := newVariableName , ' ' , self preferredAssignmentOperator , ' ' , sourceCodeToExtract , '.'. - ^ newVariableAssignment , String newLineString , String tab! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 3/29/2020 23:38:38'! - hasTemporariesDeclarationBlock - - ^ parseNodeWithNewVariableScope temporariesDeclaration declarationWritten! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 4/13/2020 00:02:27'! - insertAt: aPositionInSourceCode newCodeWith: sourceCodeContents - - updatedSourceCode := updatedSourceCode - copyReplaceFrom: aPositionInSourceCode - to: aPositionInSourceCode - 1 - with: sourceCodeContents! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 4/13/2020 00:02:42'! - insertNewTemporaryDeclarationWithNewVariable - - | newVariableDeclaration positionToInsertTempVarDeclaration sourceRangeOfFirstStatement | - sourceRangeOfFirstStatement := methodNodeToRefactor singleCompleteSourceRangeOf: self siblingStatementsOfTemporaryAssignment first. - positionToInsertTempVarDeclaration := sourceRangeOfFirstStatement first. - newVariableDeclaration := '| ' , newVariableName , ' |' , String newLineString , String tab. - - self insertAt: positionToInsertTempVarDeclaration newCodeWith: newVariableDeclaration! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 3/29/2020 23:14:02'! - lastTemporaryDeclaration - - ^ parseNodeWithNewVariableScope temporariesDeclaration temporaryDeclarationNodes last! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 2/26/2020 12:36:45'! - positionToInsertNewTemporaryVariableAssignment - - ^ (methodNodeToRefactor singleCompleteSourceRangeOf: self statementNodeIncludingCodeToExtract) first! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 3/24/2020 22:21:22'! - preferredAssignmentOperator - - ^ Preferences leftArrowAssignmentsInGeneratedCodeWithComputedDefault - ifTrue: [ '_' ] - ifFalse: [ ':=' ]! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 4/2/2020 22:29:19'! - reflectSourceCodeChanges - - self flag: #RNG. "remove the error handler once all the cases are supported" - - [ methodToRefactor methodClass - compile: updatedSourceCode - classified: methodToRefactor category ] - on: SyntaxErrorNotification - do: [ :syntaxError | self class refactoringError: 'Syntax error: unsupported refactoring case' ]! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 4/13/2020 00:03:26'! - replaceExtractedCodeWithNewTemporaryVariable - - updatedSourceCode := updatedSourceCode - copyReplaceFrom: intervalToExtract first - to: intervalToExtract last - with: newVariableName! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 3/29/2020 23:18:06'! - siblingStatementsOfTemporaryAssignment - - ^ parseNodeWithNewVariableScope isBlockNode - ifTrue: [ parseNodeWithNewVariableScope statements ] - ifFalse: [ parseNodeWithNewVariableScope block statements ]! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 4/13/2020 00:03:00'! - statementNodeIncludingCodeToExtract - - ^ self siblingStatementsOfTemporaryAssignment detect: [ :statement | - (methodNodeToRefactor singleCompleteSourceRangeOf: statement) last >= intervalToExtract last ]! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 2/26/2020 12:37:27'! - writeAssignmentStatementOfNewTemporaryVariable - - self - insertAt: self positionToInsertNewTemporaryVariableAssignment - newCodeWith: self formattedNewVariableAssignment! ! -!ExtractToTemporary class methodsFor: 'error messages' stamp: 'RNG 4/12/2020 20:13:23'! - errorMessageForSourceCodeIncludingAnInvalidExpression - - ^ 'The source code selection contains an invalid expression'! ! -!ExtractToTemporary class methodsFor: 'error messages' stamp: 'RNG 2/25/2020 15:14:33'! - errorMessageForSourceCodeSelectionOutOfBounds - - ^ 'The source code selection interval is out of bounds'! ! -!ExtractToTemporary class methodsFor: 'error messages' stamp: 'RNG 2/24/2020 22:59:12'! - errorMessageForSourceCodeToExtractCanNotBeEmpty - - ^ 'Source code to extract can not be empty'! ! -!ExtractToTemporary class methodsFor: 'error messages' stamp: 'RNG 2/24/2020 23:02:10'! - errorMessageForSourceCodeToExtractCanNotIncludeReturn - - ^ 'An expression containing a return can not be extracted'! ! -!ExtractToTemporary class methodsFor: 'error messages' stamp: 'RNG 2/24/2020 22:59:08'! - errorMessageForSourceCodeToExtractHasSyntaxError: anErrorDescription - - ^ 'Can not extract a source code with syntax error: ', anErrorDescription ! ! -!ExtractToTemporary class methodsFor: 'error messages' stamp: 'RNG 2/24/2020 23:00:15'! - errorMessageForSourceCodeToExtractHasToBeOneStatement - - ^ 'Can not extract more than one statement'! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'HAW 6/30/2017 06:34:15'! - signalColaborationToExtractHasSyntaxError: aSyntaxErrorNotification - - self refactoringError: (self errorMessageForSourceCodeToExtractHasSyntaxError: aSyntaxErrorNotification messageText)! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'RNG 2/24/2020 23:00:16'! - signalColaborationToExtractHasToBeOneStatement - - self refactoringError: self errorMessageForSourceCodeToExtractHasToBeOneStatement ! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'RNG 2/25/2020 15:21:32'! - signalOutOfBoundsIntervalError - - self refactoringError: self errorMessageForSourceCodeSelectionOutOfBounds! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'RNG 4/12/2020 23:09:03'! - signalSourceCodeSelectionIncludesAnInvalidExpression - - self refactoringError: self errorMessageForSourceCodeIncludingAnInvalidExpression! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'RNG 2/24/2020 22:58:36'! -signalSourceCodeToExtractCanNotBeEmpty - - self refactoringError: self errorMessageForSourceCodeToExtractCanNotBeEmpty! ! -!ExtractToTemporary class methodsFor: 'exceptions' stamp: 'RNG 2/24/2020 23:02:10'! - signalSourceCodeToExtractCanNotIncludeReturn - - self refactoringError: self errorMessageForSourceCodeToExtractCanNotIncludeReturn ! ! -!ExtractToTemporary class methodsFor: 'instance creation' stamp: 'RNG 4/12/2020 23:54:43'! -named: aNewVariable at: anIntervalToExtract from: aMethodToRefactor - - | trimmedNewVariable trimmedIntervalToExtract codeNodeForNewVariable methodNodeToRefactor | - - self assertCanApplyRefactoringOn: aMethodToRefactor at: anIntervalToExtract. - methodNodeToRefactor := aMethodToRefactor methodNode. - trimmedNewVariable := aNewVariable withBlanksTrimmed. - trimmedIntervalToExtract := anIntervalToExtract trimToMatchExpressionOn: aMethodToRefactor sourceCode. - codeNodeForNewVariable := self methodOrBlockNodeIncluding: anIntervalToExtract in: methodNodeToRefactor. - self newTemporaryPreconditionClass valueFor: trimmedNewVariable in: codeNodeForNewVariable of: methodNodeToRefactor. - - ^ self new - initializeNamed: trimmedNewVariable - extractingCodeAt: trimmedIntervalToExtract - from: aMethodToRefactor - declaringTempIn: codeNodeForNewVariable! ! -!ExtractToTemporary class methodsFor: 'preconditions' stamp: 'RNG 4/12/2020 23:54:29'! - assertCanApplyRefactoringOn: aMethodToRefactor at: anIntervalToExtract - - | trimmedSourceCodeToExtract methodNodeToExtract sourceCodeToExtract trimmedIntervalToExtract originalSourceCode | - - self assert: anIntervalToExtract isValidIntervalOn: aMethodToRefactor. - originalSourceCode := aMethodToRefactor sourceCode. - sourceCodeToExtract := originalSourceCode copyFrom: anIntervalToExtract first to: anIntervalToExtract last. - trimmedSourceCodeToExtract := sourceCodeToExtract withBlanksTrimmed. - trimmedIntervalToExtract := anIntervalToExtract trimToMatchExpressionOn: originalSourceCode. - self assertSourceCodeIsNotEmpty: trimmedSourceCodeToExtract. - methodNodeToExtract := self tryToParse: trimmedSourceCodeToExtract on: aMethodToRefactor methodClass. - self assertHasOneStatement: methodNodeToExtract. - self assertIsNotReturn: trimmedSourceCodeToExtract. - self assert: trimmedIntervalToExtract enclosesAValidExpressionOn: aMethodToRefactor.! ! -!ExtractToTemporary class methodsFor: 'private - parsing' stamp: 'RNG 2/25/2020 15:18:08'! - is: anIntervalToExtract withinBoundsOf: aSourceCode - - ^ anIntervalToExtract first >= 1 and: [ anIntervalToExtract last <= aSourceCode size ]! ! -!ExtractToTemporary class methodsFor: 'private - parsing' stamp: 'RNG 4/4/2020 12:41:16'! - methodOrBlockNodeIncluding: anIntervalToExtract in: methodNodeToRefactor - "Finds the appropriate block node to define a variable that will reference the code in the interval to extract. - The possibles results are the top-level methodNode or a block node inside some of the method statements." - - self flag: #RNG. "use Interval>>isIncludedIn: once is merged" - methodNodeToRefactor completeSourceRangesDo: [ :parseNode :sourceRanges | - (parseNode isBlockNode - and: [ parseNode ~= methodNodeToRefactor block ] - and: [ sourceRanges anySatisfy: [ :sourceRange | - (sourceRange rangeIncludes: anIntervalToExtract first) and: [ sourceRange rangeIncludes: anIntervalToExtract last ] ] ]) - ifTrue: [ ^ parseNode ] - ]. - ^ methodNodeToRefactor! ! -!ExtractToTemporary class methodsFor: 'private - parsing' stamp: 'RNG 4/12/2020 19:21:29'! - tryToParse: aSourceCode on: aClassToRefactor - - ^ [ Parser parse: aSourceCode class: aClassToRefactor noPattern: true ] - on: SyntaxErrorNotification - do: [ :anError | self signalColaborationToExtractHasSyntaxError: anError ]! ! -!ExtractToTemporary class methodsFor: 'private - preconditions' stamp: 'RNG 4/12/2020 23:54:12'! - anySourceRangeOf: aMethodToRefactor matches: anIntervalToExtract - - | sourceRangeCollections allSourceRanges sourceCode | - sourceRangeCollections := aMethodToRefactor methodNode completeSourceRanges values. - allSourceRanges := sourceRangeCollections - inject: Set new - into: [ :sourceRanges :sourceRangeCollection | sourceRanges addAll: sourceRangeCollection; yourself ]. - sourceCode := aMethodToRefactor sourceCode. - ^ allSourceRanges anySatisfy: [ :sourceRange | - (sourceRange trimToMatchExpressionOn: sourceCode) = anIntervalToExtract ]! ! -!ExtractToTemporary class methodsFor: 'private - preconditions' stamp: 'RNG 4/12/2020 23:28:52'! - assert: anIntervalToExtract enclosesAValidExpressionOn: aMethodToRefactor - - (self anySourceRangeOf: aMethodToRefactor matches: anIntervalToExtract) - ifFalse: [ self signalSourceCodeSelectionIncludesAnInvalidExpression ]! ! -!ExtractToTemporary class methodsFor: 'private - preconditions' stamp: 'RNG 4/12/2020 23:08:37'! - assert: anIntervalToExtract isValidIntervalOn: aMethodToRefactor - - (self is: anIntervalToExtract withinBoundsOf: aMethodToRefactor sourceCode) - ifFalse: [ self signalOutOfBoundsIntervalError ]! ! -!ExtractToTemporary class methodsFor: 'private - preconditions' stamp: 'RNG 4/12/2020 23:14:04'! - assertHasOneStatement: aMethodNodeToExtract - - aMethodNodeToExtract numberOfStatements ~= 1 - ifTrue: [ self signalColaborationToExtractHasToBeOneStatement ]! ! -!ExtractToTemporary class methodsFor: 'private - preconditions' stamp: 'RNG 4/12/2020 23:08:48'! - assertIsNotReturn: aSourceCodeToExtract - - "I have to use the source code to check this because parsing it returns the same methodNode for - 1 and ^1, that is, using methodNode does not help to distinguish if there was or not a return - Hernan" - - aSourceCodeToExtract withBlanksTrimmed first = $^ - ifTrue: [ self signalSourceCodeToExtractCanNotIncludeReturn ]! ! -!ExtractToTemporary class methodsFor: 'private - preconditions' stamp: 'RNG 2/24/2020 22:57:24'! - assertSourceCodeIsNotEmpty: aSourceCodeToExtract - - aSourceCodeToExtract isEmpty ifTrue: [ self signalSourceCodeToExtractCanNotBeEmpty ]! ! -!ExtractToTemporary class methodsFor: 'private - preconditions' stamp: 'RNG 2/22/2020 22:09:40'! - newTemporaryPreconditionClass - - ^ NewTemporaryPrecondition! ! -!ExtractToTemporaryApplier methodsFor: 'initialization' stamp: 'RNG 2/15/2020 16:16:53'! - initializeFor: anIntervalToExtract of: aMethodToExtractCodeFrom - - intervalToExtract _ anIntervalToExtract. - methodToExtractCodeFrom _ aMethodToExtractCodeFrom.! ! -!ExtractToTemporaryApplier methodsFor: 'refactoring - changes' stamp: 'RNG 2/15/2020 16:50:13' overrides: 50441445! - showChanges - - ! ! -!ExtractToTemporaryApplier methodsFor: 'refactoring - creation' stamp: 'RNG 2/15/2020 17:05:41' overrides: 50441322! - createRefactoring - - ^ self refactoringClass - named: newVariable - at: intervalToExtract - from: methodToExtractCodeFrom! ! -!ExtractToTemporaryApplier methodsFor: 'refactoring - creation' stamp: 'RNG 2/15/2020 16:26:52'! - refactoringClass - - ^ ExtractToTemporary! ! -!ExtractToTemporaryApplier methodsFor: 'refactoring - parameters request' stamp: 'RNG 4/13/2020 00:04:58'! - askNewVariableName - - newVariable := (self request: 'Enter new temp name:' initialAnswer: '') withBlanksTrimmed! ! -!ExtractToTemporaryApplier methodsFor: 'refactoring - parameters request' stamp: 'RNG 2/15/2020 16:22:35' overrides: 50441340! - requestRefactoringParameters - - self askNewVariableName! ! -!ExtractToTemporaryApplier class methodsFor: 'as yet unclassified' stamp: 'RNG 3/24/2020 23:40:22'! - assertCanApplyRefactoringOn: aMethodToRefactor at: anIntervalToExtract - - ExtractToTemporary - assertCanApplyRefactoringOn: aMethodToRefactor - at: anIntervalToExtract! ! -!ExtractToTemporaryApplier class methodsFor: 'as yet unclassified' stamp: 'RNG 2/25/2020 16:36:24'! - for: anIntervalToExtract of: aMethodToExtractCodeFrom - - self assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: anIntervalToExtract. - - ^ self new initializeFor: anIntervalToExtract of: aMethodToExtractCodeFrom! ! -!ParseNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 13:01:23' prior: 50488480! - equivalentTo: aParseNode - - ^ false! ! -!LiteralNode methodsFor: 'testing' stamp: 'RNG 4/4/2020 13:21:24' prior: 50488611 overrides: 50506544! - equivalentTo: aParseNode - - ^ aParseNode isLiteralNode and: [ super equivalentTo: aParseNode ]! ! -!MessageNode methodsFor: 'testing' stamp: 'RNG 4/12/2020 20:34:23' prior: 50502808 overrides: 50507191! - equivalentTo: aParseNode - - ^ aParseNode isMessageNode - and: [ self hasEquivalentReceiverWith: aParseNode ] - and: [ self selector equivalentTo: aParseNode selector ] - and: [ self hasEquivalentArgumentsWith: aParseNode ]! ! -!MessageNode methodsFor: 'private' stamp: 'RNG 4/12/2020 23:20:14' prior: 50502797! - hasEquivalentArgumentsWith: aMessageNode - - ^ self isCascade - ifTrue: [ self compare: originalArguments with: aMessageNode originalArguments ] - ifFalse: [ self compare: arguments with: aMessageNode arguments ]! ! -!TemporariesDeclarationNode class methodsFor: 'instance creation' stamp: 'RNG 4/4/2020 12:52:12' prior: 50502010! - empty - - ^ self withAll: #() declarationWritten: false! ! -!TemporariesDeclarationNode class methodsFor: 'instance creation' stamp: 'RNG 4/4/2020 12:52:06' prior: 50502015! - withAll: tempDeclarationNodes - - ^ self new initializeWithAll: tempDeclarationNodes declarationWritten: true! ! -!SmalltalkEditor methodsFor: 'extract method' stamp: 'RNG 4/4/2020 13:29:24' prior: 50489719! - extractMethod - - "To prevent the extract method to be evaluated on editors w/o methods like the workspace" - self hasValidCurrentCompiledMethod ifFalse: [ ^ nil ]. - - self ifSourceCodeRefactoringCanBeAppliedDo: [ - ExtractMethodApplier createAndValueHandlingExceptions: [ - ExtractMethodApplier for: self selectionInterval of: self codeProvider currentCompiledMethod ] ]! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 4/12/2020 23:49:38' prior: 50489489! - trimmed: anInterval - - ^ anInterval trimToMatchExpressionOn: sourceCode! ! -!ExtractMethod class methodsFor: 'instance creation' stamp: 'RNG 4/12/2020 23:47:26' prior: 50505527! - fromInterval: anIntervalToExtract of: aMethodToExtractCodeFrom to: newMessage categorizedAs: aCategory - - | trimmedIntervalToExtract | - trimmedIntervalToExtract := anIntervalToExtract trimToMatchExpressionOn: aMethodToExtractCodeFrom sourceCode. - self - assert: newMessage selector canBeDefinedIn: aMethodToExtractCodeFrom methodClass; - assert: trimmedIntervalToExtract isValidIntervalOn: aMethodToExtractCodeFrom; - assert: newMessage hasValidParametersForExtracting: anIntervalToExtract from: aMethodToExtractCodeFrom methodNode. - - ^ self new - initializeFrom: trimmedIntervalToExtract - of: aMethodToExtractCodeFrom - to: newMessage - in: aCategory! ! -!ExtractMethodApplier class methodsFor: 'instance creation' stamp: 'RNG 4/13/2020 00:01:51' prior: 50489173! - for: anIntervalToExtract of: aMethodToExtractCodeFrom - - | trimmedIntervalToExtract sourceCode | - sourceCode := aMethodToExtractCodeFrom sourceCode. - trimmedIntervalToExtract := anIntervalToExtract trimToMatchExpressionOn: sourceCode. - - self assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: trimmedIntervalToExtract. - - ^ self new initializeFor: trimmedIntervalToExtract of: aMethodToExtractCodeFrom! ! -!RefactoringMenues class methodsFor: 'editor menus' stamp: 'RNG 4/4/2020 13:32:20' prior: 50491966! - smalltalkEditorMenuOptions - - ^`{ - { - #itemGroup -> 35. - #itemOrder -> 10. - #label -> 'Rename... (R)'. - #selector -> #contextualRename. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 20. - #label -> 'Extract Temporary... (J)'. - #selector -> #extractToTemporary. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 30. - #label -> 'Extract Method... (K)'. - #selector -> #extractMethod. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 40. - #label -> 'More Refactorings...'. - #selector -> #openSmalltalkEditorRefactoringMenu. - #icon -> #listAddIcon - } asDictionary. - }`! ! -!RefactoringMenues class methodsFor: 'shortcuts' stamp: 'RNG 4/4/2020 13:27:51' prior: 50489913! - smalltalkEditorCmdShortcutsSpec - - ^#( - #($R #contextualRename: 'Renames what is under cursor') - #($A #contextualAddParameter: 'Adds parameter to message that is under cursor') - #($S #contextualRemoveParameter: 'Removes parameter to message that is under cursor') - #($O #temporaryToInstanceVariable: 'Extracts temporary variable to instance variable') - #($J #extractToTemporary: 'Extracts the selected code into a temporary variable') - #($K #extractMethod: 'Extracts the selected code into a separate method') - )! ! - -TemporaryDeclarationNode removeSelector: #isTemporariesDeclaration! - -!methodRemoval: TemporaryDeclarationNode #isTemporariesDeclaration stamp: 'Install-4115-ExtractToTemporary-NahuelGarbezza-2020Apr04-12h34m-RNG.001.cs.st 5/26/2020 17:09:05'! -isTemporariesDeclaration - - ^ true! - -ParseNode subclass: #TemporariesDeclarationNode - instanceVariableNames: 'tempDeclarationNodes declarationWritten' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #TemporariesDeclarationNode category: #'Compiler-ParseNodes' stamp: 'Install-4115-ExtractToTemporary-NahuelGarbezza-2020Apr04-12h34m-RNG.001.cs.st 5/26/2020 17:09:05'! -ParseNode subclass: #TemporariesDeclarationNode - instanceVariableNames: 'tempDeclarationNodes declarationWritten' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -Smalltalk removeClassNamed: #ExtractMethodIntervalTrimmer! - -!classRemoval: #ExtractMethodIntervalTrimmer stamp: 'Install-4115-ExtractToTemporary-NahuelGarbezza-2020Apr04-12h34m-RNG.001.cs.st 5/26/2020 17:09:05'! -Object subclass: #ExtractMethodIntervalTrimmer - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -"Postscript:" -SmalltalkEditor initializeCmdShortcuts.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4115-ExtractToTemporary-NahuelGarbezza-2020Apr04-12h34m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4113] on 14 April 2020 at 8:53:11 pm'! -!Parser methodsFor: 'expression types' stamp: 'RNG 4/14/2020 20:50:40'! - createCascadeNodeWith: receiverNode and: messageNodes - - | sourceRangeOfFirstMessage | - - parseNode := CascadeNode new receiver: receiverNode messages: messageNodes. - sourceRangeOfFirstMessage := encoder rawSourceRanges at: messageNodes first. - sourceRangeOfFirstMessage ifNotNil: [ - | cascadeSourceRangeStart | - cascadeSourceRangeStart := sourceRangeOfFirstMessage first. - encoder noteSourceRange: (cascadeSourceRangeStart to: hereMark + 1) forNode: parseNode ]! ! -!CascadeNode methodsFor: 'source ranges' stamp: 'RNG 4/14/2020 20:45:23' overrides: 50495113! - expandRanges: aSourceRange basedOn: sourceRanges using: sourceCode - - | receiverExpandedRanges expandedRangeWithReceiver | - receiverExpandedRanges _ receiver expandRanges: (sourceRanges at: receiver) basedOn: sourceRanges using: sourceCode. - expandedRangeWithReceiver _ self - expandRange: (aSourceRange isInterval ifTrue: [ aSourceRange ] ifFalse: [ aSourceRange first ]) - basedOn: receiverExpandedRanges. - ^ super - expandRanges: expandedRangeWithReceiver - basedOn: expandedRangeWithReceiver - using: sourceCode! ! -!Parser methodsFor: 'expression types' stamp: 'RNG 4/14/2020 20:50:21' prior: 16886034! - cascade - " {; message} => CascadeNode." - - | receiverNode messageNodes sourceRangeOfFirstMessage | - parseNode canCascade ifFalse: - [^self expected: 'Cascading not']. - parseNode ensureCanCascade: encoder. - receiverNode := parseNode cascadeReceiver. - messageNodes := OrderedCollection with: parseNode. - [self match: #semicolon] - whileTrue: - [parseNode := receiverNode. - (self messagePart: 3 repeat: false) - ifFalse: [^self expected: 'Cascade']. - parseNode canCascade ifFalse: - [^self expected: '<- No special messages']. - parseNode ensureCanCascade: encoder. - parseNode cascadeReceiver. - messageNodes addLast: parseNode]. - self flag: #RNG. "to be replaced by self createCascadeNodeWith: receiverNode and: messageNodes in next changeset" - parseNode := CascadeNode new receiver: receiverNode messages: messageNodes. - sourceRangeOfFirstMessage := encoder rawSourceRanges at: messageNodes first. - sourceRangeOfFirstMessage ifNotNil: [ - | cascadeSourceRangeStart | - cascadeSourceRangeStart := sourceRangeOfFirstMessage first. - encoder noteSourceRange: (cascadeSourceRangeStart to: hereMark + 1) forNode: parseNode ]! ! -!MessageNode methodsFor: 'source ranges' stamp: 'RNG 4/14/2020 20:42:46' prior: 50497493 overrides: 50495113! - expandRanges: aSourceRange basedOn: sourceRanges using: sourceCode - - | receiverExpandedRanges expandedRangeWithReceiver | - receiverExpandedRanges _ self isCascade - ifTrue: [ aSourceRange ] "not expanded because expansion is handled in CascadeNode" - ifFalse: [ receiver expandRanges: (self receiverSourceRangesFrom: sourceRanges) basedOn: sourceRanges using: sourceCode ]. - expandedRangeWithReceiver _ self - expandRange: (aSourceRange isInterval ifTrue: [ aSourceRange ] ifFalse: [ aSourceRange first ]) - basedOn: receiverExpandedRanges. - ^ super - expandRanges: expandedRangeWithReceiver - basedOn: expandedRangeWithReceiver - using: sourceCode! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4116-CascadeMessagesRanges-NahuelGarbezza-2020Apr14-20h09m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4113] on 14 April 2020 at 8:54:36 pm'! -!Parser methodsFor: 'expression types' stamp: 'RNG 4/14/2020 20:53:34' prior: 50507432! - cascade - " {; message} => CascadeNode." - - | receiverNode messageNodes | - parseNode canCascade ifFalse: - [^self expected: 'Cascading not']. - parseNode ensureCanCascade: encoder. - receiverNode := parseNode cascadeReceiver. - messageNodes := OrderedCollection with: parseNode. - [self match: #semicolon] - whileTrue: - [parseNode := receiverNode. - (self messagePart: 3 repeat: false) - ifFalse: [^self expected: 'Cascade']. - parseNode canCascade ifFalse: - [^self expected: '<- No special messages']. - parseNode ensureCanCascade: encoder. - parseNode cascadeReceiver. - messageNodes addLast: parseNode]. - self createCascadeNodeWith: receiverNode and: messageNodes! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4117-CascadeMessagesRanges2-NahuelGarbezza-2020Apr14-20h53m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4117] on 21 April 2020 at 12:44:16 pm'! -!FeatureRequirement methodsFor: 'private' stamp: 'KenD 4/12/2020 11:26:48' prior: 50475952! - placesToLookForPackagesDo: aBlock - - | myDir base packagesDirectory | - - "Look inside my own folder" - pathName ifNotNil: [ - myDir _ pathName asFileEntry parent. - aBlock value: myDir ]. - - "Look in codePackageFile folder" - codePackageFile ifNotNil: [ - myDir := codePackageFile fullName asFileEntry parent. - aBlock value: myDir ]. - - "Look in Cuis image folder and reasonable subfolders" - base _ DirectoryEntry smalltalkImageDirectory. - aBlock value: base. - packagesDirectory _ base / 'Packages'. - aBlock value: packagesDirectory. - packagesDirectory allRegularDirectoriesDo: aBlock. - base regularDirectoriesDo: [ :child | - child = packagesDirectory ifFalse: [ - aBlock value: child. - child allRegularDirectoriesDo: aBlock]]. - - "Look in parent directory and reasonable subfolders. - Useful when image is stored in a subdirectory of the main app directory. - This could be the case when the package comes from a 'main' git repo, and image is copied from gitHub. - First try directories including the word Cuis in the name. Then try others." - base parent regularDirectoriesDo: [ :dir | - dir ~= base ifTrue: [ - ('*Cuis*' match: dir name) - ifTrue: [aBlock value: dir. dir allRegularDirectoriesDo: aBlock]]]. - base parent regularDirectoriesDo: [ :dir | - dir ~= base ifTrue: [ - ('*Cuis*' match: dir name) - ifFalse: [aBlock value: dir. dir allRegularDirectoriesDo: aBlock]]]. - - "Also look in host OS current directory" - (base ~= DirectoryEntry currentDirectory and: [base parent ~= DirectoryEntry currentDirectory]) - ifTrue: [ - base _ DirectoryEntry currentDirectory. - base allRegularDirectoriesDo: aBlock ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4118-placesToLookForPackagesDo-KenDickey-2020Apr21-12h43m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4118] on 21 April 2020 at 1:03:06 pm'! -!Refactoring class methodsFor: 'services - source code' stamp: 'jmv 4/21/2020 12:53:58'! - shouldTrimToMatchExpressionOn: sourceCode atIndex: currentIndex - - | currentChar | - currentChar := sourceCode at: currentIndex ifAbsent: [ ^ false ]. - ^ currentChar isSeparator or: [ currentChar = $. ] -! ! -!Refactoring class methodsFor: 'services - source code' stamp: 'jmv 4/21/2020 12:53:25'! - trim: anInterval matchingParenthesesOn: aSourceCode - - | trimmedInterval | - trimmedInterval := anInterval. - [ - | initialChar endingChar | - initialChar := aSourceCode at: trimmedInterval first ifAbsent: [ nil ]. - endingChar := aSourceCode at: trimmedInterval last ifAbsent: [ nil ]. - initialChar = $( and: [ endingChar = $) ] - ] - whileTrue: [ trimmedInterval _ trimmedInterval first + 1 to: trimmedInterval last - 1 ]. - ^ trimmedInterval! ! -!Refactoring class methodsFor: 'services - source code' stamp: 'jmv 4/21/2020 12:59:54'! - trim: anInterval toMatchExpressionOn: aSourceCode - - | trimmedInterval | - trimmedInterval := anInterval. - [ self shouldTrimToMatchExpressionOn: aSourceCode atIndex: trimmedInterval first ] - whileTrue: [ trimmedInterval := trimmedInterval first + 1 to: trimmedInterval last ]. - [ self shouldTrimToMatchExpressionOn: aSourceCode atIndex: trimmedInterval last ] - whileTrue: [ trimmedInterval := trimmedInterval first to: trimmedInterval last - 1 ]. - - ^ self trim: trimmedInterval matchingParenthesesOn: aSourceCode! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'jmv 4/21/2020 12:55:38' prior: 50507253! - trimmed: anInterval - - ^ Refactoring trim: anInterval toMatchExpressionOn: sourceCode! ! -!ExtractMethod class methodsFor: 'instance creation' stamp: 'jmv 4/21/2020 12:55:14' prior: 50507259! - fromInterval: anIntervalToExtract of: aMethodToExtractCodeFrom to: newMessage categorizedAs: aCategory - - | trimmedIntervalToExtract | - trimmedIntervalToExtract := Refactoring trim: anIntervalToExtract toMatchExpressionOn: aMethodToExtractCodeFrom sourceCode. - self - assert: newMessage selector canBeDefinedIn: aMethodToExtractCodeFrom methodClass; - assert: trimmedIntervalToExtract isValidIntervalOn: aMethodToExtractCodeFrom; - assert: newMessage hasValidParametersForExtracting: anIntervalToExtract from: aMethodToExtractCodeFrom methodNode. - - ^ self new - initializeFrom: trimmedIntervalToExtract - of: aMethodToExtractCodeFrom - to: newMessage - in: aCategory! ! -!ExtractToTemporary class methodsFor: 'instance creation' stamp: 'jmv 4/21/2020 12:56:09' prior: 50506945! - named: aNewVariable at: anIntervalToExtract from: aMethodToRefactor - - | trimmedNewVariable trimmedIntervalToExtract codeNodeForNewVariable methodNodeToRefactor | - - self assertCanApplyRefactoringOn: aMethodToRefactor at: anIntervalToExtract. - methodNodeToRefactor := aMethodToRefactor methodNode. - trimmedNewVariable := aNewVariable withBlanksTrimmed. - trimmedIntervalToExtract := Refactoring trim: anIntervalToExtract toMatchExpressionOn: aMethodToRefactor sourceCode. - codeNodeForNewVariable := self methodOrBlockNodeIncluding: anIntervalToExtract in: methodNodeToRefactor. - self newTemporaryPreconditionClass valueFor: trimmedNewVariable in: codeNodeForNewVariable of: methodNodeToRefactor. - - ^ self new - initializeNamed: trimmedNewVariable - extractingCodeAt: trimmedIntervalToExtract - from: aMethodToRefactor - declaringTempIn: codeNodeForNewVariable! ! -!ExtractToTemporary class methodsFor: 'preconditions' stamp: 'jmv 4/21/2020 12:55:58' prior: 50506975! - assertCanApplyRefactoringOn: aMethodToRefactor at: anIntervalToExtract - - | trimmedSourceCodeToExtract methodNodeToExtract sourceCodeToExtract trimmedIntervalToExtract originalSourceCode | - - self assert: anIntervalToExtract isValidIntervalOn: aMethodToRefactor. - originalSourceCode := aMethodToRefactor sourceCode. - sourceCodeToExtract := originalSourceCode copyFrom: anIntervalToExtract first to: anIntervalToExtract last. - trimmedSourceCodeToExtract := sourceCodeToExtract withBlanksTrimmed. - trimmedIntervalToExtract := Refactoring trim: anIntervalToExtract toMatchExpressionOn: originalSourceCode. - self assertSourceCodeIsNotEmpty: trimmedSourceCodeToExtract. - methodNodeToExtract := self tryToParse: trimmedSourceCodeToExtract on: aMethodToRefactor methodClass. - self assertHasOneStatement: methodNodeToExtract. - self assertIsNotReturn: trimmedSourceCodeToExtract. - self assert: trimmedIntervalToExtract enclosesAValidExpressionOn: aMethodToRefactor.! ! -!ExtractToTemporary class methodsFor: 'private - preconditions' stamp: 'jmv 4/21/2020 12:55:47' prior: 50507054! - anySourceRangeOf: aMethodToRefactor matches: anIntervalToExtract - - | sourceRangeCollections allSourceRanges sourceCode | - sourceRangeCollections := aMethodToRefactor methodNode completeSourceRanges values. - allSourceRanges := sourceRangeCollections - inject: Set new - into: [ :sourceRanges :sourceRangeCollection | sourceRanges addAll: sourceRangeCollection; yourself ]. - sourceCode := aMethodToRefactor sourceCode. - ^ allSourceRanges anySatisfy: [ :sourceRange | - (Refactoring trim: sourceRange toMatchExpressionOn: sourceCode) = anIntervalToExtract ]! ! -!ExtractMethodApplier class methodsFor: 'instance creation' stamp: 'jmv 4/21/2020 12:55:26' prior: 50507283! - for: anIntervalToExtract of: aMethodToExtractCodeFrom - - | trimmedIntervalToExtract sourceCode | - sourceCode := aMethodToExtractCodeFrom sourceCode. - trimmedIntervalToExtract := Refactoring trim: anIntervalToExtract toMatchExpressionOn: sourceCode. - - self assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: trimmedIntervalToExtract. - - ^ self new initializeFor: trimmedIntervalToExtract of: aMethodToExtractCodeFrom! ! - -Interval removeSelector: #trimToMatchExpressionOn:! - -!methodRemoval: Interval #trimToMatchExpressionOn: stamp: 'Install-4119-Interval-cleanup-JuanVuletich-2020Apr21-12h58m-jmv.001.cs.st 5/26/2020 17:09:05'! -trimToMatchExpressionOn: aSourceCode - - | trimmedInterval | - trimmedInterval := self. - [ self shouldTrimToMatchExpressionOn: aSourceCode atIndex: trimmedInterval first ] - whileTrue: [ trimmedInterval := trimmedInterval first + 1 to: trimmedInterval last ]. - [ self shouldTrimToMatchExpressionOn: aSourceCode atIndex: trimmedInterval last ] - whileTrue: [ trimmedInterval := trimmedInterval first to: trimmedInterval last - 1 ]. - - ^ trimmedInterval trimMatchingParenthesesOn: aSourceCode! - -Interval removeSelector: #shouldTrimToMatchExpressionOn:atIndex:! - -!methodRemoval: Interval #shouldTrimToMatchExpressionOn:atIndex: stamp: 'Install-4119-Interval-cleanup-JuanVuletich-2020Apr21-12h58m-jmv.001.cs.st 5/26/2020 17:09:05'! -shouldTrimToMatchExpressionOn: sourceCode atIndex: currentIndex - - | currentChar | - currentChar := sourceCode at: currentIndex ifAbsent: [ ^ false ]. - ^ currentChar isSeparator or: [ currentChar = $. ] -! - -Interval removeSelector: #trimMatchingParenthesesOn:! - -!methodRemoval: Interval #trimMatchingParenthesesOn: stamp: 'Install-4119-Interval-cleanup-JuanVuletich-2020Apr21-12h58m-jmv.001.cs.st 5/26/2020 17:09:05'! -trimMatchingParenthesesOn: aSourceCode - - | trimmedInterval | - trimmedInterval := self. - [ - | initialChar endingChar | - initialChar := aSourceCode at: trimmedInterval first ifAbsent: [ nil ]. - endingChar := aSourceCode at: trimmedInterval last ifAbsent: [ nil ]. - initialChar = $( and: [ endingChar = $) ] - ] - whileTrue: [ trimmedInterval _ trimmedInterval first + 1 to: trimmedInterval last - 1 ]. - ^ trimmedInterval! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4119-Interval-cleanup-JuanVuletich-2020Apr21-12h58m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4112] on 22 April 2020 at 10:49:25 pm'! -!ImageReadWriter class methodsFor: 'instance creation' stamp: 'KenD 4/22/2020 16:41:45'! - fileReaderServicesForFileEntry: filename suffix: suffix - "FileList buttons that read a TrueType font on contents." - - ( self allTypicalFileExtensions includes: suffix) ifTrue: [ - ^ { self serviceReadImage } ]. - - ^#()! ! -!ImageReadWriter class methodsFor: 'instance creation' stamp: 'KenD 4/22/2020 16:44:34'! - imageMorphFromFileEntry: imageFileEntry - "Import an image from a file" - - (ImageMorph new image: (ImageReadWriter formFromFileEntry: imageFileEntry) ) openInWorld. - ! ! -!ImageReadWriter class methodsFor: 'instance creation' stamp: 'KenD 4/22/2020 16:43:53'! - serviceReadImage - "Answer the service of importing an image" - - ^ (SimpleServiceEntry - provider: self - label: 'import as ImageMorph' - selector: #imageMorphFromFileEntry: - description: 'import image as ImageMorph' - buttonLabel: 'import image' - icon: ((Theme content from: 'Theme' get: {'16x16'. 'mimetypes'}) at: 'image-x-generic.png') - ) argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'jmv 4/22/2020 22:41:52'! - formFromFileEntry: aFileEntry - "Answer a Form stored on the file with the given name." - - ^ aFileEntry readStreamDo: [ :stream | - stream useBytes. - self formFromStream: stream ]! ! -!ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'jmv 4/22/2020 22:41:57' prior: 16854457! - formFromFileNamed: fileName - "Answer a Form stored on the file with the given name." - - ^fileName asFileEntry readStreamDo: [ :stream | - stream useBytes. - self formFromStream: stream ]! ! -!ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'jmv 4/22/2020 22:42:34' prior: 16854466! - formFromStream: aBinaryStream - "Answer a Form stored on the given stream." - | reader readerClass form featureName | - - readerClass _ self withAllSubclasses - detect: [ :subclass | subclass understandsImageFormat: aBinaryStream reset ] - ifNone: [ - featureName _ 'Graphics-Files-Additional'. - ^(FeatureRequirement name: featureName) isAlreadySatisfied - ifTrue: [ self error: 'Unsupported image file format.' ] - ifFalse: [ - self error: 'Unsupported image format. Try "', featureName, '".']]. - reader _ readerClass onBinaryStream: aBinaryStream reset. - form _ reader nextImage. - ^ form! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4120-FileList-ImportPicures-JuanVuletich-2020Apr22-22h48m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4120] on 25 April 2020 at 11:03:53 am'! -!False methodsFor: 'controlling' stamp: 'LC 4/25/2020 10:34:34'! - orNot: alternativeBlock - - ^alternativeBlock value not! ! -!True methodsFor: 'controlling' stamp: 'LC 4/25/2020 10:34:49'! - orNot: alternativeBlock - "Nonevaluating disjunction -- answer true since the receiver is true." - - ^self! ! -!String methodsFor: 'grammar' stamp: 'LC 4/25/2020 10:35:17'! - article - | article first letter second | - self isEmpty ifTrue: [^self]. - article := self first isVowel ifTrue: ['an'] ifFalse: ['a']. - first := self first asLowercase. - letter := self size = 1. - second := letter ifFalse: [self second asLowercase]. - (first = $f and: [letter orNot: ['aeiloru' includes: second]]) - ifTrue: [^'an']. - first = $u ifTrue: [ - (letter or: ['ck' includes: second]) ifTrue: [^'a']. - second = $n - ifTrue: [(self size = 2 or: [self third isVowel]) ifTrue: [^'a']]]. - (first = $e and: [second = $u]) ifTrue: [^'a']. - ^article! ! -!String methodsFor: 'grammar' stamp: 'LC 4/25/2020 10:29:48'! - asPlural - | k trimmed plural n | - k := self findFirst: [:ch | ch isSeparator not]. - k > 1 - ifTrue: [^(self copyFrom: 1 to: k - 1) , (self allButFirst: k - 1) asPlural]. - trimmed := self withBlanksTrimmed. - trimmed isEmpty ifTrue: [^'']. - plural := trimmed asLowercase lowercasePlural. - n := trimmed size min: plural size. - 1 to: n do: [:i | - (trimmed at: i) isUppercase - ifTrue: [plural at: i put: (plural at: i) asUppercase]]. - ^plural! ! -!String methodsFor: 'grammar' stamp: 'LC 4/25/2020 10:25:30'! - exceptionalPlural - | singular plural index | - singular := #( - 'addendum' 'aircraft' 'alga' 'alumnus' 'amoeba' 'antenna' 'appendix' - 'bacterium' 'barracks' - 'cactus' 'child' 'criterion' 'curriculum' - 'datum' 'deer' 'dwarf' - 'echo' 'ephemeris' 'embargo' - 'fish' 'focus' 'foot' 'forum' 'fungus' - 'gallows' 'genus' 'goose' - 'hero' - 'index' 'is' - 'larva' 'louse' - 'matrix' 'means' 'memorandum' 'mithos' 'money' 'mouse' - 'nucleus' - 'offspring' 'ox' - 'person' 'phenomenon' 'potato' 'proof' - 'roof' - 'series' 'sheep' 'species' 'spoof' 'stimulus' 'syllabus' - 'tomato' 'tooth' 'torpedo' 'trilby' - 'vertebra' 'veto' - 'was'). - plural := #( - 'addenda' 'aircraft' 'algae' 'alumni' 'amoebae' 'antennae' 'appendices' - 'bacteria' 'barracks' - 'cacti' 'children' 'criteria' 'curricula' - 'data' 'deer' 'dwarfs' - 'echoes' 'ephemerides' 'embargoes' - 'fish' 'foci' 'feet' 'fora' 'fungi' - 'gallows' 'genera' 'geese' - 'heroes' - 'indices' - 'are' - 'larvae' 'lice' - 'matrices' 'means' 'memoranda' 'mythoi' 'moneys' 'mice' - 'nuclei' - 'offspring' 'oxen' - 'people' 'phenomena' 'potatoes' 'proofs' - 'roofs' - 'series' 'sheep' 'species' 'spoofs' 'stimuli' 'syllabi' - 'tomatoes' 'teeth' 'torpedoes' 'trilbys' - 'vertebrae' 'vetoes' - 'were'). - index := singular indexOf: self. - ^index > 0 ifTrue: [plural at: index]! ! -!String methodsFor: 'grammar' stamp: 'LC 4/25/2020 10:25:45'! - isUninflictedNoun - | nouns | - nouns := #( - 'bison' 'bream' 'breeches' 'britches' - 'carp' 'chassis' 'clippers' 'cod' 'contretemps' 'corps' - 'debris' 'diabetes' 'djinn' - 'eland' 'elk' - 'flounder' - 'gallows' 'graffiti' - 'headquarters' 'herpes' 'high-jinks' 'homework' - 'innings' - 'jackanapes' - 'mackerel' 'measles' 'mews' 'mumps' - 'news' - 'pincers' 'pliers' 'proceedings' - 'rabies' - 'salmon' 'scissors' 'sea-bass' 'series' 'shears' 'species' 'swine' - 'trout' 'tuna' - 'whiting' 'wildebeest'). - ^nouns includes: self! ! -!String methodsFor: 'grammar' stamp: 'LC 4/25/2020 10:24:38'! - lowercasePlural - | last | - self exceptionalPlural ifNotNil: [:pl | ^pl]. - self isUninflictedNoun ifTrue: [^self]. - last := self last. - last = $y ifTrue: [ - #('ay' 'ey' 'oy' 'uy') do: [:t | - (self endsWith: t) ifTrue: [^self , 's']. - ^self allButLast , 'ies']]. - #('zz' 'ch' 'sh') do: [:t | (self endsWith: t) ifTrue: [^self , 'es']]. - last = $s ifTrue: [ - self = 'its' ifTrue: [^'their']. - #('bs' 'cs' 'ds' 'ks' 'ls' 'ms' 'rs' 'ts' 'ws') - do: [:t | (self endsWith: t) ifTrue: [^self]]. - #('sis' 'xis') - do: [:t | (self endsWith: t) ifTrue: [^(self allButLast: 2) , 'es']]]. - last = $z ifTrue: [^self , 'zes']. - (last = $x or: [last = $s]) ifTrue: [^self , 'es']. - (self endsWith: 'man') ifTrue: [^(self allButLast: 2) , 'en']. - last = $f ifTrue: [^self allButLast , 'ves']. - (self endsWith: 'fe') ifTrue: [^(self allButLast: 2) , 'ves']. - ^self , 's'! ! -!String methodsFor: 'grammar' stamp: 'LC 4/25/2020 10:26:19'! -pluralize: aBoolean - ^aBoolean ifTrue: [self asPlural] ifFalse: [self]! ! -!String methodsFor: 'grammar' stamp: 'LC 4/25/2020 10:45:49'! - withArticle - ^self article , ' ' , self! ! -!Semaphore methodsFor: 'printing' stamp: 'LC 4/25/2020 10:32:35' overrides: 16814613! - printOn: aStream - super printOn: aStream. - aStream - nextPutAll: ' with '; - nextPutAll: excessSignals asString; - space; - nextPutAll: ('signal' pluralize: excessSignals ~= 1)! ! -!Object methodsFor: 'message handling' stamp: 'LC 4/25/2020 11:00:15' prior: 50368102! - argumentName - | name | - name _ self argumentNameSufix. - ^name article, name! ! -!Object methodsFor: 'printing' stamp: 'LC 4/25/2020 11:01:36' prior: 50368225! - printOn: aStream - "Append to the argument, aStream, a sequence of characters that - identifies the receiver." - - aStream - nextPutAll: self class name withArticle! ! -!Object methodsFor: 'printing' stamp: 'LC 4/25/2020 11:02:06' prior: 50368235! - printWithClosureAnalysisOn: aStream - "Append to the argument, aStream, a sequence of characters that - identifies the receiver." - - aStream - nextPutAll: self class name withArticle! ! -!ContextPart methodsFor: 'debugger access' stamp: 'LC 4/25/2020 11:02:34' prior: 50368246! - print: anObject on: aStream - "Safely print anObject in the face of direct ProtoObject subclasses." - | objClass | - objClass _ self objectClass: anObject. - (objClass canUnderstand: #printOn:) ifTrue: [ - ^anObject printOn: aStream]. - aStream nextPutAll: objClass name withArticle! ! - -String removeSelector: #aOrAnPrefix! - -!methodRemoval: String #aOrAnPrefix stamp: 'Install-4121-String-plurals-indefiniteArticles-LeandroCaniglia-2020Apr25-10h24m-LC.001.cs.st 5/26/2020 17:09:05'! -aOrAnPrefix - - ^self isEmpty - ifTrue: [ self ] - ifFalse: [ self first isVowel ifTrue: ['an'] ifFalse: ['a'] ] -! - -String removeSelector: #prefixedWithAOrAn! - -!methodRemoval: String #prefixedWithAOrAn stamp: 'Install-4121-String-plurals-indefiniteArticles-LeandroCaniglia-2020Apr25-10h24m-LC.001.cs.st 5/26/2020 17:09:05'! -prefixedWithAOrAn - - ^self aOrAnPrefix, self! - -String removeSelector: #trackwithArticle! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4121-String-plurals-indefiniteArticles-LeandroCaniglia-2020Apr25-10h24m-LC.001.cs.st----! - -'From Cuis 5.0 [latest update: #4121] on 25 April 2020 at 12:26:07 pm'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4122-Cleanup-JuanVuletich-2020Apr25-12h25m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4122] on 26 April 2020 at 9:46:37 pm'! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 4/26/2020 21:46:01'! - privateFixedHeight - - ^fixedHeight! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 4/26/2020 21:46:11'! - privateProportionalHeight - - ^ proportionalHeight! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4123-LayoutSpec-PrivateAccessors-JuanVuletich-2020Apr26-21h43m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4123] on 27 April 2020 at 5:32:08 pm'! -!UpdatingStringMorph methodsFor: 'accessing' stamp: 'KenD 4/26/2020 07:11:30'! - showPrintStringFor: anObject - - self contents: anObject printString! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4124-HandyMethodInUpdatingStringMorph-KenDickey-2020Apr27-17h31m-KenD.001.cs.st----! - -'From Cuis 5.0 [latest update: #4124] on 28 April 2020 at 10:15:56 am'! -!Utilities class methodsFor: 'support windows' stamp: 'jmv 4/28/2020 10:11:55' prior: 50400713! - codeManagementInCuisContents - ^ self class firstCommentAt: #codeManagementInCuisContents - -" -Managing your code in Cuis -================== - -(https://github.com/Cuis-Smalltalk/Cuis-Smalltalk-Dev/blob/master/Documentation/CodeManagementInCuis.md) - -Cuis includes tools and procedures for managing Smalltalk code. Code that is not part of the Cuis Core image itself, like applications, frameworks and libraries, should be stored in Packages. New code that are meant as patches, fixes or additions; that could eventually become part of Cuis itself, is not part of any Package, and is therefore automatically stored in ChangeSets. - - -Packages ------------ - -Let's start with Packages. The Package implementation in Cuis is based on PackageInfo, the standard way to specify packages in Squeak and its derivatives, and used, for example, by Monticello. It uses Package names to specify prefixes for Class and Method categories. Classes and Methods whose categories match a Package's prefixes belong in that Package. More details about how PackageInfo decides what code belongs in a package are available at http://wiki.squeak.org/squeak/3329 . - -To install packages (.pck.st files) in Cuis, use the FileList, navigate to the appropriate directory (on disk, or in a GitHub repository, etc), select the package file and click on [Install Package]. - -Cuis includes a tool to manage installed Packages. It is at World / Open / Installed Packages. To create a new package (instead of installing an existing one from a file), click on [Create Package] This creates a new package, and associates with it all the existing code in the image that matches the package name. - -The operations available on installed or newly created packages are: - -[Save] Saves a package on the file system. Overwrites any existing version. It is good to save the package from time to time, to reduce the risk of losing code. - -[Delete] Removes the Package instance from the image. Does not remove any code. This means, effectively, to merge back the code into Cuis. - -[Browse unsaved Changes] This opens a ChangeSorter on the ChangeSet that captures all the changes done to the Package since it was last saved. Therefore it shows the work done on the package that would be lost if the package is not saved. - -[Browse package code] This opens a Class Browser that only shows the code that belongs in the package. This is useful for working on a package, or studying it. - -[Add requirement] This opens a select list of loaded packages. Each package provides a Feature. You can CANCEL, require the current Cuis base version (at a minimum) or require any of the packages on the list. Required packages will be loaded before the selected package (Feature require: #'your-package'.). When a package is selected, the lower browser pane shows its requirents, which may be deleted. Don't forget to Save your package after adding or deleting requirements!! - -The tool shows, for each Package, the name, whether it is dirty (has unsaved changes) and the file it was installed from / saved to. - -Handling Packages like this, Cuis behaves as a sort of document editor (like, for example a regular text editor) whose documents are Package files (.pck.st). Cuis doesn't handle Package versions, ancestries, etc. If versioning of Packages is desired, the best is to use a versioning file repository, such as Git or Mercurial. The recommendation is to use a GitHub repository with a name beginning with 'Cuis-Smalltalk-', so it will be easy for anybody to find it. Cuis Package files are uncompressed, use Lf (ASCII 10) as newLine, and are encoded in ISO 8859-15. This means they are Git friendly, and Git/GitHub can diff and merge them, and browse them with syntax highlighting. - -This is not unlike using Git or GitHub with a file-based development environment such as Eclipse or a text editor. Like Cuis, these tools don't do version handling themselves, they just load and save files; and let Git do its magic. - - -Changes to the Cuis base image ------------------------------------------ - -The way ChangeSets are created and managed in Cuis is different from Squeak. This was done to make ChangeSets a good way to manage changes to the base Cuis Core image, while keeping code in Packages out of the way, so they don't get mixed together. - -What is not in a Package belongs (at least temporarily) to the Cuis Core image. Such code is automatically captured in a ChangeSet. The ChangeSet for Core changes is created automatically and named like '1243-CuisCore-JuanVuletich-2012Apr03-22h50m'. The number at the beginning is the next number for the Cuis update stream, and is provided only as a suggestion. The 'CuisCore' part is to reveal that the code belongs in the base image and not in some package. Then we have author name and date / time of creation. These ChangeSets are created automatically. There is no longer a way to manually create them, or make them 'current' or 'active'. It is best to rename them, replacing 'CuisCore' with some meaningful name. These ChangeSets will not capture any code that belongs in a Package. - -Opening a Change Sorter will show the CuisCore change set. This is useful, for example, to check that no code that was intended for a Package ends here by mistake (because of the wrong class or method category). But it is also useful when doing changes to the base system. Now, we can do changes both to the base system and to a number of packages, all in the same session, without having to be careful about selecting the proper change set before saving a method: The code is automatically added to the proper Package or ChangeSet, simply following the class or method category. Gone are the days of messed up change sets and lost code!! - -When the changes to the base system are complete, it is a good time to review the CuisCore change set and, maybe remove from it changes that we don't want to keep (for example, experiments, halts, etc). Then, just do right click / File out and remove. This saves the ChangeSet on disk. It also removes it from the ChangeSorter (but it doesn't remove any code). This is good, because the next changes done will end in a new CuisCore change set, and there's no risk of having undesired changes in the old one. As changes to the base image progress, and several CuisCore ChangeSets are saved to disk, these numbered files are created in sequence. They will be ready to be loaded back in proper order in a fresh Cuis image, or to be sent to Cuis maintainers for integration in the update stream and in next releases of Cuis. - -Installing ChangeSet files into Cuis - -[Install] loads all the code in the file into a separate, new ChangeSet object (viewable in the ChangeSorter tool). This is appropriate for loading Cuis updates, or other code that we are not authoring, as it doesn't add new items (class or method definitions) to the current ChangeSet used to record the changes we make to Cuis. Usually any ChangeSets should be installed before doing changes to the image. The reason is that an installed ChangeSet could overwrite changes done by you, or packages you have installed. If this is the case, the affected packages would appear as dirty, and your change set would include any installed changes (that don't belong in a package). Be careful when saving packages or change sets if this was the case!! - -Cherry picking individual changes from ChangeSet or Package files ------------------------------------------------------------------------------------ - -Additionally, you can study a Package (.pck.st) or ChangeSet (.cs) file without installing it. To do this, use the FileList, navigate to the appropriate directory, select the file and click on [Contents]. You will get a ChangeList tool with the contents of the file. You can select each change, to see the code, and compare it with what is currently loaded in the system (if that is the case). You can also various filters on the list. See the right-click menu. Once you have one or more changes selected, you can do right-click / 'fileIn selections'. Changes that belong in a package that is already there will be captured by that package, that will now be dirty. Code that doesn't belong in a loaded package will be included in the current ChangeSet, together with code you save in a Browser. A new Package or ChangeSet will not be created. This is especially useful when reviewing code, or when we are combining code from more than one source into a single ChangeSet or Package. -" - -" -Utilities codeManagementInCuisContents edit -"! ! -!Utilities class methodsFor: 'support windows' stamp: 'jmv 4/28/2020 10:14:31' prior: 16941308! - cuisAndGitHubContents - ^ self class firstCommentAt: #cuisAndGitHubContents - -" -Using Git and GitHub to host and manage Cuis code -=================================== - -(https://github.com/Cuis-Smalltalk/Cuis-Smalltalk-Dev/blob/master/Documentation/CuisAndGitHub.md) - -Cuis includes tools and procedures for managing Smalltalk code. Central to this is the management of Packages and Package Files (.pck). But Cuis doesn't do version control. Instead, we suggest using external VCS tools. In particular, we're using [GitHub](http://www.github.com/), and the first project we're hosting there is [StyledTextEditor](https://github.com/bpieber/Cuis-StyledTextEditor). - -The guiding principle is to *not duplicate concepts and behavior*. As we're using an external tool (Git) for version control, then we use it as it meant to be used. Most people use Git for version control and a file based IDE such as Eclipse for development. Such IDEs don't do version control themselves. It is done by Git. Do the same: do not include package version control in Cuis. This is a departure from the Monticello /Git integration (smallsource and MonticelloFileTree) by Otto Behrens, Dale Henrichs, etc. - -We use GitHub to host, version, diff and merge external packages (.pck files), i.e. code that is maintained independently and outside Cuis. - -Package files need to be simple text files. Cuis encoding for latin alphabet (ISO 8859-15) is handled without problems by GitHub. Cuis uses the LF (ascii code 10) newline convention, as preferred in GitHub. This allows Git/GitHub to diff versions, and merge branches. - -Each GitHub repository has one set of users and permissions. Each GitHub repository has one state (Git commits repositories, not individual files). Branch and merges are done on the whole repository and not on individual files. Therefore, we need a separate GitHub repository for each project, i.e., for each package or set of closely related packages that are always loaded and maintained together as a whole. - -Development process for External Packages --------------------------------------------------------- - -This is the suggested procedure for developing external packages. Usually do this every day. - -* Start with a standard (i.e. fresh) Cuis image. Never save the image. - -* Set up Git repositories for external packages (if not already done) - -* Install packages from Git repositories. - -* Develop. Modify and/or create packages. - -* Save own packages (to Git repositories). - -* Git add / commit / push as appropriate. - -* Fileout changes that are not part of any package. These are automatically captured in numbered changesets, separated from changes to packages. - -* Exit the image. Usually without saving. -" - -" -Utilities cuisAndGitHubContents edit -"! ! -!Utilities class methodsFor: 'support windows' stamp: 'jmv 4/28/2020 09:56:12' prior: 16941390! - openCodeManagementInCuis - " - Utilities openCodeManagementInCuis - " - - self codeManagementInCuisContents editLabel: 'Managing your code in Cuis'! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4125-UpdateInImageDocs-JuanVuletich-2020Apr28-09h56m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4125] on 28 April 2020 at 12:21:30 pm'! -!ChangeList class methodsFor: 'public access' stamp: 'jmv 4/28/2020 12:19:04' prior: 50499423! - browseRecentLogOn: origChangesFileEntry startingFrom: initialPos - "Prompt with a menu of how far back to go when browsing a changes file." - - | end banners positions pos chunk i | - origChangesFileEntry readStreamDo: [ :changesFile | - banners _ OrderedCollection new. - positions _ OrderedCollection new. - end _ changesFile size. - pos _ initialPos. - [pos = 0 - or: [banners size > 20]] "Go back at most 20 image exits" - whileFalse: [ - changesFile position: pos. - chunk _ changesFile nextChunk. - i _ chunk indexOfSubCollection: 'priorSource: ' startingAt: 1. - i > 0 - ifTrue: [ - positions addLast: pos. - banners addLast: (chunk copyFrom: 5 to: i - 2). - pos _ Number readFrom: (chunk copyFrom: i + 13 to: chunk size)] - ifFalse: [ - pos _ 0]]. - ]. - positions isEmpty - ifTrue: [ pos _ 0 ] - ifFalse: [ - positions addLast: 0. - banners addLast: 'Whole file'. - pos _ (SelectionMenu labelList: banners selections: positions) - startUpWithCaption: 'Browse as far back as...'. - pos - ifNil: [^ self]]. - self browseRecent: end - pos on: origChangesFileEntry! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4126-AvoidRecentChangesMenuIfUseless-JuanVuletich-2020Apr28-12h20m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4126] on 28 April 2020 at 3:39:34 pm'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4127-removeEmptyCategories-JuanVuletich-2020Apr28-15h39m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4120] on 26 April 2020 at 3:30:07 pm'! - -"Change Set: 4121-CuisCore-AuthorName-2020Apr24-20h33m -Date: 26 April 2020 -Author: Nahuel Garbezza - -Changes on Extract Temporary refactoring: - -* make sure it is not possible to extract the left side of an assignment -* allow to extract cascade expressions -* allow to extract entire blocks into variables -* validate new temporary is not a reserved name - -Changes on Extract Method refactoring: - -* solve bug where 2 statements (one being a block) could not be extracted - -Changes on Rename Temporary refactoring: - -* validate new temporary is not a reserved name"! - -Refactoring subclass: #ExtractToTemporary - instanceVariableNames: 'newVariableName parseNodeToExtract methodNodeToRefactor methodToRefactor updatedSourceCode intervalToExtract sourceCodeToExtract parseNodeWithNewVariableScope ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractToTemporary category: #'Tools-Refactoring' stamp: 'Install-4128-ExtractToTemporaryRefactoring-NahuelGarbezza-2020Apr24-20h33m-RNG.001.cs.st 5/26/2020 17:09:05'! -Refactoring subclass: #ExtractToTemporary - instanceVariableNames: 'newVariableName parseNodeToExtract methodNodeToRefactor methodToRefactor updatedSourceCode intervalToExtract sourceCodeToExtract parseNodeWithNewVariableScope' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!ParseNode methodsFor: 'testing' stamp: 'RNG 4/25/2020 13:17:19'! - isCascadeNode - - ^ false! ! -!CascadeNode methodsFor: 'testing' stamp: 'RNG 4/25/2020 13:17:36' overrides: 50507191! - equivalentTo: aParseNode - - ^ aParseNode isCascadeNode - and: [ receiver equivalentTo: aParseNode receiver ] - and: [ self hasEquivalentMessagesWith: aParseNode ]! ! -!CascadeNode methodsFor: 'testing' stamp: 'RNG 4/25/2020 13:17:44'! - hasEquivalentMessagesWith: aCascadeNode - - messages with: aCascadeNode messages do: [ :myMessage :otherNodeMessage | - (myMessage equivalentTo: otherNodeMessage) ifFalse: [ ^ false ] ]. - ^ true! ! -!CascadeNode methodsFor: 'testing' stamp: 'RNG 4/25/2020 13:17:29' overrides: 50508643! - isCascadeNode - - ^ true! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 4/24/2020 20:42:39'! - findSourceRangeOfCloserStatementIn: listOfAncestors - - ^ (listOfAncestors - detect: [ :assoc | assoc key isBlockNode ] - ifFound: [ :assoc | listOfAncestors before: assoc ifNone: [ listOfAncestors last ] ] - ifNone: [ listOfAncestors last ]) value! ! -!ExtractToTemporary class methodsFor: 'private - preconditions' stamp: 'RNG 4/25/2020 13:20:06'! - assert: anIntervalToExtract enclosesACompleteExpressionOn: aMethodToRefactor - - (self anySourceRangeOf: aMethodToRefactor matches: anIntervalToExtract) - ifFalse: [ self signalSourceCodeSelectionIncludesAnInvalidExpression ]! ! -!ExtractToTemporary class methodsFor: 'private - preconditions' stamp: 'RNG 4/25/2020 13:20:22'! - assert: anIntervalToExtract enclosesAValidNodeOn: aMethodToRefactor - - (self parseNodeUnder: anIntervalToExtract canBeExtractedToAVariableOn: aMethodToRefactor) - ifFalse: [ self signalSourceCodeSelectionIncludesAnInvalidExpression ]! ! -!ExtractToTemporary class methodsFor: 'private - preconditions' stamp: 'RNG 4/25/2020 13:20:32'! - parseNodeUnder: anIntervalToExtract canBeExtractedToAVariableOn: aMethodToRefactor - - aMethodToRefactor methodNode completeSourceRangesDo: [ :parseNode :sourceRanges | - (parseNode isAssignmentNode - and: [ sourceRanges anySatisfy: [ :sourceRange | sourceRange first = anIntervalToExtract first ] ]) - ifTrue: [ ^ false ] - ]. - ^ true! ! -!NewTemporaryPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 4/26/2020 15:16:59'! - assertIsNotAReservedName - - (ClassBuilder reservedNames includes: newTemporaryVariableName) - ifTrue: [ self signalNewTemporaryVariableCanNotBeAReservedName ]! ! -!NewTemporaryPrecondition methodsFor: 'exceptions' stamp: 'RNG 4/26/2020 15:19:20'! - signalNewTemporaryVariableCanNotBeAReservedName - - self refactoringError: ( - self class errorMessageForNewTemporaryVariableCanNotBeAReservedName: newTemporaryVariableName)! ! -!NewTemporaryPrecondition class methodsFor: 'error messages' stamp: 'RNG 4/26/2020 15:19:20'! - errorMessageForNewTemporaryVariableCanNotBeAReservedName: aName - - ^ '''', aName, ''' can not be used as temporary variable name because it is a reserved name'! ! -!Encoder methodsFor: 'source mapping' stamp: 'RNG 4/25/2020 12:51:38' prior: 50488541! - completeSourceRangesBasedOn: sourceCode - - | completeSourceRanges | - completeSourceRanges _ Dictionary new. - sourceRanges keysAndValuesDo: [ :parseNode :nodeRanges | - "leaf nodes excluded because they have the same complete source ranges than the block nodes they wrap - Nahuel" - parseNode class = LeafNode ifFalse: [ - | expandedNodeSourceRanges | - expandedNodeSourceRanges _ parseNode expandRanges: nodeRanges basedOn: sourceRanges using: sourceCode. - completeSourceRanges at: parseNode put: expandedNodeSourceRanges ] ]. - ^ completeSourceRanges! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 4/25/2020 12:54:00' prior: 50505497! - intervalMatchesBeginningOfStatement - - ^ (self findSourceRangeOfCloserStatementIn: initialNodeAncestors) first = intervalToExtract first! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 4/24/2020 20:37:59' prior: 50505506! - intervalMatchesEndOfStatement - - ^ (self findSourceRangeOfCloserStatementIn: finalNodeAncestors) last = intervalToExtract last! ! -!ExtractToTemporary class methodsFor: 'preconditions' stamp: 'RNG 4/25/2020 13:21:54' prior: 50507704! - assertCanApplyRefactoringOn: aMethodToRefactor at: anIntervalToExtract - - | trimmedSourceCodeToExtract methodNodeToExtract sourceCodeToExtract trimmedIntervalToExtract originalSourceCode | - - self assert: anIntervalToExtract isValidIntervalOn: aMethodToRefactor. - originalSourceCode := aMethodToRefactor sourceCode. - sourceCodeToExtract := originalSourceCode copyFrom: anIntervalToExtract first to: anIntervalToExtract last. - trimmedSourceCodeToExtract := sourceCodeToExtract withBlanksTrimmed. - trimmedIntervalToExtract := Refactoring trim: anIntervalToExtract toMatchExpressionOn: originalSourceCode. - self assertSourceCodeIsNotEmpty: trimmedSourceCodeToExtract. - methodNodeToExtract := self tryToParse: trimmedSourceCodeToExtract on: aMethodToRefactor methodClass. - self - assertHasOneStatement: methodNodeToExtract; - assertIsNotReturn: trimmedSourceCodeToExtract; - assert: trimmedIntervalToExtract enclosesACompleteExpressionOn: aMethodToRefactor; - assert: trimmedIntervalToExtract enclosesAValidNodeOn: aMethodToRefactor! ! -!ExtractToTemporary class methodsFor: 'private - parsing' stamp: 'RNG 4/25/2020 12:54:15' prior: 50507016! - methodOrBlockNodeIncluding: anIntervalToExtract in: methodNodeToRefactor - "Finds the appropriate block node to define a variable that will reference the code in the interval to extract. - The possibles results are the top-level methodNode or a block node inside some of the method statements." - - methodNodeToRefactor completeSourceRangesDo: [ :parseNode :sourceRanges | - (parseNode isBlockNode - and: [ parseNode ~= methodNodeToRefactor block ] - and: [ sourceRanges anySatisfy: [ :sourceRange | - sourceRange first < anIntervalToExtract first and: [ sourceRange last > anIntervalToExtract last ] ] ]) - ifTrue: [ ^ parseNode ] - ]. - ^ methodNodeToRefactor! ! -!NewTemporaryPrecondition methodsFor: 'evaluating' stamp: 'RNG 4/26/2020 15:14:43' prior: 50497334 overrides: 50497304! - value - - self - assertIsNotEmpty; - assertIsValidVariableName; - assertIsNotAReservedName; - assertIsNotDefinedAsInstanceVariableInHierarchyOfMethodClass; - assertIsNotDeclaredInParentsOrChildrenScopes! ! - -NewTemporaryPrecondition removeSelector: #signalNewInstanceVariableCanNotBeAReservedName! - -ExtractToTemporary class removeSelector: #assert:enclosesAValidExpressionOn:! - -!methodRemoval: ExtractToTemporary class #assert:enclosesAValidExpressionOn: stamp: 'Install-4128-ExtractToTemporaryRefactoring-NahuelGarbezza-2020Apr24-20h33m-RNG.001.cs.st 5/26/2020 17:09:05'! -assert: anIntervalToExtract enclosesAValidExpressionOn: aMethodToRefactor - - (self anySourceRangeOf: aMethodToRefactor matches: anIntervalToExtract) - ifFalse: [ self signalSourceCodeSelectionIncludesAnInvalidExpression ]! - -ExtractMethodExpressionValidation removeSelector: #findSourceRangeOfNextStatementIn:! - -!methodRemoval: ExtractMethodExpressionValidation #findSourceRangeOfNextStatementIn: stamp: 'Install-4128-ExtractToTemporaryRefactoring-NahuelGarbezza-2020Apr24-20h33m-RNG.001.cs.st 5/26/2020 17:09:05'! -findSourceRangeOfNextStatementIn: listOfAncestors - - ^ listOfAncestors - detect: [ :assoc | assoc key isBlockNode or: [ assoc key class = LeafNode ] ] - ifFound: [ :assoc | - (listOfAncestors at: (listOfAncestors indexOf: assoc) - 1) value ] - ifNone: [ listOfAncestors last value ]! - -Refactoring subclass: #ExtractToTemporary - instanceVariableNames: 'newVariableName methodNodeToRefactor methodToRefactor updatedSourceCode intervalToExtract sourceCodeToExtract parseNodeWithNewVariableScope' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractToTemporary category: #'Tools-Refactoring' stamp: 'Install-4128-ExtractToTemporaryRefactoring-NahuelGarbezza-2020Apr24-20h33m-RNG.001.cs.st 5/26/2020 17:09:06'! -Refactoring subclass: #ExtractToTemporary - instanceVariableNames: 'newVariableName methodNodeToRefactor methodToRefactor updatedSourceCode intervalToExtract sourceCodeToExtract parseNodeWithNewVariableScope' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4128-ExtractToTemporaryRefactoring-NahuelGarbezza-2020Apr24-20h33m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4109] on 2 May 2020 at 12:13:20 am'! - -Object subclass: #Refactoring - instanceVariableNames: '' - classVariableNames: 'AllowedToRefactorClassCompilers ' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #Refactoring category: #'Tools-Refactoring' stamp: 'Install-4129-RefactoringCheckForCompilerClass-HernanWilkinson-2020Apr23-16h31m-HAW.001.cs.st 5/26/2020 17:09:06'! -Object subclass: #Refactoring - instanceVariableNames: '' - classVariableNames: 'AllowedToRefactorClassCompilers' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!Refactoring class methodsFor: 'testing' stamp: 'HAW 5/1/2020 23:58:00'! - canRefactor: aPotentialClassToRefactor - - ^self allowedToRefactorClassCompilersIncludes: aPotentialClassToRefactor compilerClass! ! -!Refactoring class methodsFor: 'allowed to refactor class compilers' stamp: 'HAW 5/2/2020 00:03:05'! - addAllowedToRefactorClassCompiler: aCompiler - - self allowedToRefactorClassCompilers add: aCompiler ! ! -!Refactoring class methodsFor: 'allowed to refactor class compilers' stamp: 'HAW 5/1/2020 23:59:39'! - allowedToRefactorClassCompilers - - AllowedToRefactorClassCompilers ifNil: [ - AllowedToRefactorClassCompilers := Set with: Compiler ]. - - ^AllowedToRefactorClassCompilers! ! -!Refactoring class methodsFor: 'allowed to refactor class compilers' stamp: 'HAW 5/1/2020 23:58:58'! - allowedToRefactorClassCompilersIncludes: aCompiler - - ^self allowedToRefactorClassCompilers includes: aCompiler ! ! -!ChangeSelector class methodsFor: 'implementors and senders' stamp: 'HAW 5/1/2020 23:55:29' prior: 50499292! -addImplementorsOf: anOldSelector to: implementors andSendersTo: senders of: aPotentialClassToRefactor - - | potentialImplementor | - - "Phil B. requested to avoid refactoring OMeta2 classes, so right now - it avoids implementors and senders whose compilerClass is not register - as allowed compiler - Hernan" - (self canRefactor: aPotentialClassToRefactor) ifFalse: [ ^self ]. - - potentialImplementor := aPotentialClassToRefactor compiledMethodAt: anOldSelector ifAbsent: [ nil ]. - potentialImplementor ifNotNil: [ implementors add: potentialImplementor ]. - - (aPotentialClassToRefactor whichSelectorsReferTo: anOldSelector) do: [ :aSelector | - senders add: (MethodReference class: aPotentialClassToRefactor selector: aSelector) ]! ! - -Object subclass: #Refactoring - instanceVariableNames: '' - classVariableNames: 'AllowedToRefactorClassCompilers' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #Refactoring category: #'Tools-Refactoring' stamp: 'Install-4129-RefactoringCheckForCompilerClass-HernanWilkinson-2020Apr23-16h31m-HAW.001.cs.st 5/26/2020 17:09:06'! -Object subclass: #Refactoring - instanceVariableNames: '' - classVariableNames: 'AllowedToRefactorClassCompilers' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4129-RefactoringCheckForCompilerClass-HernanWilkinson-2020Apr23-16h31m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4129] on 2 May 2020 at 12:48:49 pm'! -!Interval methodsFor: 'testing' stamp: 'HAW 5/2/2020 11:53:30' prior: 50464394 overrides: 16906982! - includes: aNumber - - | index | - - aNumber isNumber ifFalse: [ ^ false ]. - - ^ start = stop - ifTrue: [ start = aNumber ] - ifFalse: [ - index := (aNumber - start) / (stop-start) * (count-1) + 1. - index isInteger and: [ index between: 1 and: count ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4130-IntervalIncludes-HernanWilkinson-2020May02-11h21m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4129] on 2 May 2020 at 12:49:24 pm'! -!NewInstanceVariablePrecondition methodsFor: 'pre-conditions' stamp: 'HAW 5/2/2020 12:48:57' prior: 50482542! - assertIsNotAlreadyDefinedInSuperclasses - - ^ (classToAddInstVar classThatDefinesInstanceVariable: instVarName) - ifNotNil: [ :definingClass | self signalAlreadyDefinedInAll: {definingClass} ] - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4131-NewInstanceVariablePreconditionFix-HernanWilkinson-2020May02-12h48m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4129] on 3 May 2020 at 2:02:23 am'! - -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser selectorsClasses possibleInvalidSelectors canShowSelectorDocumentation possibleBinarySendRange' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #SmalltalkCompleter category: #'Tools-Autocompletion' stamp: 'Install-4132-AutoCompleterImprovement-HernanWilkinson-2020May02-18h09m-HAW.001.cs.st 5/26/2020 17:09:06'! -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser selectorsClasses possibleInvalidSelectors canShowSelectorDocumentation possibleBinarySendRange' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! -!SequenceableCollection methodsFor: 'accessing' stamp: 'HAW 5/3/2020 00:48:51'! - antepenultimate - - ^self antepenultimateIfAbsent: [ self errorCollectionTooSmall ]! ! -!SequenceableCollection methodsFor: 'accessing' stamp: 'HAW 5/3/2020 00:47:42'! - antepenultimateIfAbsent: aBlock - - | size | - - size := self size. - size >= 3 ifTrue: [ ^self at: size - 2 ]. - ^aBlock value! ! -!SequenceableCollection methodsFor: 'accessing' stamp: 'HAW 5/3/2020 00:39:34'! - penultimateIfAbsent: aBlock - - | size | - - size := self size. - size >= 2 ifTrue: [ ^self at: size-1 ]. - ^aBlock value! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 5/3/2020 01:42:05'! - possibleBinarySendRangeFrom: allRanges - - | penultimate antepenultimate | - - penultimate := allRanges penultimateIfAbsent: [ SHRange nilObject ]. - antepenultimate := allRanges antepenultimateIfAbsent: [ SHRange nilObject ]. - - possibleBinarySendRange _ penultimate rangeType = #arrayStart - ifTrue: [ antepenultimate rangeType = #symbol - ifTrue: [ allRanges at: allRanges size - 3 ifAbsent: [ SHRange nilObject ] ]] - ifFalse: [ - ({#leftBrace. #'$'. #symbol. #blockStart. } includes: penultimate rangeType) - ifTrue: [ antepenultimate ] - ifFalse: [ penultimate ]]! ! -!SmalltalkCompleter class methodsFor: 'accessing' stamp: 'HAW 5/2/2020 20:47:22'! - changeEntriesLimitTo: aNewLimit during: aBlock - - | previousLimit | - - previousLimit := EntriesLimit. - EntriesLimit := aNewLimit. - - ^aBlock ensure: [ EntriesLimit := previousLimit ]! ! -!SHParserST80 methodsFor: 'accessing' stamp: 'HAW 5/3/2020 00:14:19'! - rangesWithoutExcessCode - - ^ranges - ifEmpty: [ ranges ] - ifNotEmpty: [ - ranges last rangeType = #excessCode - ifTrue: [ ranges allButLast ] - ifFalse: [ ranges ]]! ! -!SHParserST80 methodsFor: 'testing' stamp: 'HAW 5/3/2020 00:27:29'! - isIdentifier: aSymbol - - ^ #(#incompleteIdentifier - #blockTempVar #blockArg #tempVar #methodArg - #instVar #classVar - #workspaceVar #poolConstant #globalVar ) statePointsTo:aSymbol! ! -!SHParserST80 methodsFor: 'testing' stamp: 'HAW 5/3/2020 00:27:56'! - isReservedName: aSymbol - - ^ self reservedNames statePointsTo: aSymbol! ! -!SHRange class methodsFor: 'instance creation' stamp: 'HAW 5/3/2020 01:10:44'! - nilObject - - "I can not reference self inside backtick - Hernan" - ^`SHRange start: 0 end: 0 type: nil`! ! -!SequenceableCollection methodsFor: 'accessing' stamp: 'HAW 5/3/2020 00:42:09' prior: 50419375! - penultimate - "Answer the penultimate element of the receiver. - Raise an error if the collection is empty or has just one element." - - ^self penultimateIfAbsent: [self errorCollectionTooSmall]. -! ! -!SmalltalkCompleter methodsFor: 'entries' stamp: 'HAW 5/3/2020 01:41:33' prior: 50480464 overrides: 16781250! - computeEntries - - | allSource contextClass specificModel allRanges range | - - allSource _ model actualContents string. - specificModel _ self textProviderOrModel. - contextClass _ self selectedClassOrMetaClassIn: specificModel. - allRanges _ self parse: allSource in: contextClass and: specificModel. - range _ allRanges ifEmpty: [ ^entries _ #() ] ifNotEmpty: [ allRanges last ]. - possibleInvalidSelectors _ #(). - - range end = position - ifTrue: [ self computeEntriesOfMessageOrIdentifiersFor: allSource using: allRanges at: range in: contextClass and: specificModel ] - ifFalse: [ self computeMessageEntriesWithEmptyPrefixFor: allSource using: allRanges at: range in: contextClass and: specificModel ]. - - ! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 5/3/2020 01:09:40' prior: 50480147! - canComputeMessageEntriesFor: prevRange - - ^ prevRange rangeType notNil ! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 5/3/2020 00:15:12' prior: 50414954! - computeEntriesOfMessageOrIdentifiersFor: allSource using: allRanges at: range in: contextClass and: specificModel - - prefix _ allSource copyFrom: range start to: range end. - (parser isMessage: range rangeType) ifTrue: [ - ^self computeMessageEntriesWhenSendinMessageFor: allSource using: allRanges in: contextClass and: specificModel ]. - (parser isPartialOrFullIdentifier: range rangeType) ifTrue: [ ^self computeIdentifierEntries ]. - - "If we don't know what to do, do nothing" - entries _ #() ! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 5/3/2020 00:14:30' prior: 50485650! - parse: allSource in: contextClass and: specificModel - - | isMethod | - - parser _ SHParserST80 new. - parser - workspace: ((specificModel is: #providesBindings) ifTrue: [specificModel]); - classOrMetaClass: contextClass; - source: (allSource copyFrom: 1 to: position); - allSource: allSource. - - isMethod := (specificModel is: #Browser) - ifTrue: [ specificModel isEditingClass not ] - ifFalse: [ specificModel is: #CodeProvider ]. - parser parse: isMethod. - - ^ parser rangesWithoutExcessCode. -! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 5/3/2020 01:41:14' prior: 50483531! - computeMessageEntriesWhenSendinMessageFor: allSource using: allRanges in: contextClass and: specificModel - - | prevRange | - - "If previous range is a constant or a well known identifier, we might filter messages" - prevRange _ allRanges penultimateIfAbsent: [ SHRange nilObject ]. - possibleBinarySendRange _ allRanges antepenultimateIfAbsent: [ SHRange nilObject ]. - - ^ (self canComputeMessageEntriesFor: prevRange) - ifTrue: [ self computeMessageEntriesFor: allSource at: prevRange in: contextClass and: specificModel ] - ifFalse: [ self computeMessageEntriesForUnknowClass ] -! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 5/3/2020 00:58:01' prior: 50483551! - computeMessageEntriesWithEmptyPrefixFor: allSource using: allRanges at: range in: contextClass and: specificModel - - self possibleBinarySendRangeFrom: allRanges. - prefix _ ''. - - self computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel .! ! -!SHParserST80 methodsFor: 'testing' stamp: 'HAW 5/3/2020 00:28:13' prior: 50368734! - isPartialOrFullIdentifier: aSymbol - - ^(self isIdentifier: aSymbol) or: [ self isReservedName: aSymbol ]! ! - -SHParserST80 removeSelector: #isPartialIdentifier:! - -SmalltalkCompleter removeSelector: #initialize! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4132-AutoCompleterImprovement-HernanWilkinson-2020May02-18h09m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4127] on 4 May 2020 at 4:40:37 pm'! -!QSystemTally methodsFor: 'report' stamp: 'jmv 5/4/2020 16:31:25' prior: 50378335 overrides: 16897317! - printOn: textStream linesOn: linesStream talliesOn: talliesStreams tabs: tabsAndTreeLines total: total totalTime: totalTime parent: parentTally - - | aSelector aClass percentage line | - line _ String streamContents: [ :lineStream | - tabsAndTreeLines do: [ :tabOrLineChar | lineStream nextPutAll: tabOrLineChar ]. - percentage _ tally asFloat / total * 100.0. - percentage printOn: lineStream fractionDigits: 2. - lineStream nextPutAll: '% ('. - percentage * totalTime / 100 printOn: lineStream fractionDigits: 1. - lineStream nextPutAll: ' ms) '. - aSelector _ class selectorAtMethod: method setClass: [ :c | aClass _ c]. - blockNesting > 0 ifTrue: [ - lineStream - next: blockNesting put: $[; - next: blockNesting put: $]; - space ]. - lineStream - nextPutAll: class name; - nextPutAll: (aClass == class - ifTrue: ['>>'] - ifFalse: ['(' , aClass name , ')>>']); - nextPutAll: aSelector. - wasInPrimitive ifTrue: [ - self flag: #profilerFriendlyCall:. - parentTally methodSymbol == #profilerFriendlyCall: - ifTrue: [ - lineStream nextPutAll: ' -- primitive (reported properly)' ] - ifFalse: [ - lineStream nextPutAll: ' -- primitive (real sender possibly omitted, see #profilerFriendlyCall:)' ] - ]. - ]. - textStream nextPutAll: line; newLine. - linesStream nextPut: line. - talliesStreams nextPut: self! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4133-MessageTally-fix-JuanVuletich-2020May04-16h31m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #3866] on 1 May 2020 at 4:43:58 pm'! -!EventSensor methodsFor: 'private-I/O' stamp: 'tg 5/1/2020 13:21:30' prior: 16839672! - processSensorEvent: evt discardingMouseEvents: discardMouseEvents - "Process a single event. This method is run at high priority." - | type | - type _ evt at: 1. - - "Check if the event is a user interrupt" - (type = EventSensor eventTypeKeyboard and: [ (evt at: 4) = 0 and: [ - ((evt at: 3) bitOr: (((evt at: 5) bitAnd: 8) bitShift: 8)) = interruptKey]]) - ifTrue: [ - "interrupt key is meta - not reported as event" - ^interruptSemaphore signal]. - - "Store the event in the queue if there's any" - type = EventSensor eventTypeMouse ifTrue: [ - "Only swap secondary and tertiary buttons if there is no command or option modifier keys. - This swap is done so a 3-button mouse is - left -> mouseButton1 (select) - center -> mouseButton3 (halo) - right -> mouseButton2 (menu). - This is only needed on the Mac, Window VM does this mapping by default. - We avoid ding the swap if there are modifier keys, because in that case the buttons were generated by the VM as follows: - left -> mouseButton1 - macOption + left -> mouseButton3 - command + left -> mouseButton2, - but Mac users are already used to - macOption + left -> menu - command + left -> halo. - See #installMouseDecodeTable" - ((evt at: 6) anyMask: 12) ifFalse: [ - evt at: 5 put: (ButtonDecodeTable at: (evt at: 5) + 1)]]. - - (discardMouseEvents and: [ type = EventSensor eventTypeMouse ]) ifFalse: [ - self queueEvent: evt ]. - - "Update state for InputSensor." - type = EventSensor eventTypeMouse ifTrue: [ - self processMouseSensorEvent: evt ]. - type = EventSensor eventTypeKeyboard ifTrue: [ - self processKeyboardSensorEvent: evt ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4134-FixInterruptKeyForFrenchKeyboard-ThierryGoubier-2020May01-13h21m-tg.1.cs.st----! - -'From Cuis 5.0 [latest update: #4134] on 6 May 2020 at 12:17:40 pm'! -!SystemWindow methodsFor: 'label' stamp: 'len 5/1/2020 06:34:51' prior: 50471986! - labelHeight - "Answer the height for the window label." - Theme current minimalWindows ifTrue: [^ 0]. - ^ Preferences windowTitleFont lineSpacing+1! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4135-minimalWindows-fix-LucianoEstebanNotarfrancesco-2020May06-12h17m-len.001.cs.st----! - -'From Cuis 5.0 [latest update: #4132] on 3 May 2020 at 3:16:45 pm'! -!BoxedFloat64 methodsFor: 'printing' stamp: 'HAW 5/3/2020 15:05:51' overrides: 50418762! - storeOn: aStream base: base - - self isFinite - ifTrue: [ super storeOn: aStream base: base ] - ifFalse: [ self isNaN - ifTrue: [aStream nextPutAll: 'Float nan'] - ifFalse: [self > 0.0 - ifTrue: [aStream nextPutAll: 'Float infinity'] - ifFalse: [aStream nextPutAll: 'Float infinity negated']]]! ! -!Float methodsFor: 'printing' stamp: 'HAW 5/3/2020 15:06:05' prior: 50418762 overrides: 16880428! - storeOn: aStream base: base - - "Print the Number exactly so it can be interpreted back unchanged" - - self sign = -1 ifTrue: [aStream nextPutAll: '-']. - base = 10 ifFalse: [aStream print: base; nextPut: $r]. - self isZero - ifTrue: [aStream nextPutAll: '0.0'] - ifFalse: [self abs absPrintExactlyOn: aStream base: base]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4136-FloatStoreOnImprovement-HernanWilkinson-2020May03-12h35m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4132] on 6 May 2020 at 11:46:42 pm'! - -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser selectorsClasses possibleInvalidSelectors canShowSelectorDocumentation possibleBinarySendRange allRanges ' - classVariableNames: 'AccessLock EntriesLimit Selectors ' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #SmalltalkCompleter category: #'Tools-Autocompletion' stamp: 'Install-4137-AutoCompleteImprovements-HernanWilkinson-2020May03-15h16m-HAW.001.cs.st 5/26/2020 17:09:06'! -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser selectorsClasses possibleInvalidSelectors canShowSelectorDocumentation possibleBinarySendRange allRanges' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -Object subclass: #SHParserST80 - instanceVariableNames: 'classOrMetaClass source workspace arguments sourcePosition currentToken currentTokenFirst temporaries instanceVariables errorBlock currentTokenSourcePosition blockDepth bracketDepth ranges blockDepths blockDepthsStartIndexes allSource braceDepth ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -!classDefinition: #SHParserST80 category: #'Tools-Syntax Highlighting' stamp: 'Install-4137-AutoCompleteImprovements-HernanWilkinson-2020May03-15h16m-HAW.001.cs.st 5/26/2020 17:09:06'! -Object subclass: #SHParserST80 - instanceVariableNames: 'classOrMetaClass source workspace arguments sourcePosition currentToken currentTokenFirst temporaries instanceVariables errorBlock currentTokenSourcePosition blockDepth bracketDepth ranges blockDepths blockDepthsStartIndexes allSource braceDepth' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! -!SequenceableCollection methodsFor: 'accessing' stamp: 'HAW 5/4/2020 00:39:03'! - lastIfEmpty: aBlock - - ^self ifEmpty: aBlock ifNotEmpty: [ self at: self size ]! ! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'HAW 5/4/2020 02:07:45'! - computeEntriesOfMessageOrIdentifiersFor: allSource at: range in: contextClass and: specificModel - - prefix _ allSource copyFrom: range start to: range end. - (parser isMessage: range rangeType) ifTrue: [ - ^self computeMessageEntriesWhenSendinMessageFor: allSource in: contextClass and: specificModel ]. - (parser isPartialOrFullIdentifier: range rangeType) ifTrue: [ ^self computeIdentifierEntries ]. - - "If we don't know what to do, do nothing" - entries _ #() ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 5/4/2020 15:42:32'! - computeMessageEntriesWhenSendinMessageFor: allSource in: contextClass and: specificModel - - | lastRange | - - allRanges removeLast. - lastRange _ allRanges lastIfEmpty: [ SHRange nilObject ]. - possibleBinarySendRange _ self lookForBinarySendRange. - - ^ (self canComputeMessageEntriesFor: lastRange) - ifTrue: [ self computeMessageEntriesFor: allSource at: lastRange in: contextClass and: specificModel ] - ifFalse: [ self computeMessageEntriesForUnknowClass ] -! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 5/4/2020 15:42:32'! - computeMessageEntriesWithEmptyPrefixFor: allSource at: range in: contextClass and: specificModel - - possibleBinarySendRange _ self lookForBinarySendRange. - prefix _ ''. - - self computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel .! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 5/4/2020 15:49:19'! - lookForBinarySelectorAfter: aStopToken startingAt: anIndex with: aCandidate - - | currentRange currentIndex | - - currentIndex := anIndex. - [ currentRange := allRanges at: currentIndex. - currentRange rangeType ~= aStopToken and: [ currentIndex > 1 ]] whileTrue: [ currentIndex := currentIndex - 1 ]. - - ^currentIndex > 1 - ifTrue: [ allRanges at: currentIndex - 1 ] - ifFalse: [ aCandidate ]. -! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 5/4/2020 15:43:49'! - lookForBinarySelectorAfterArrayStartStartingAt: anIndex with: aCandidate - - | foundRange foundRangeIndex | - - foundRange := self lookForBinarySelectorAfter: #arrayStart startingAt: anIndex with: aCandidate. - - ^foundRange rangeType = #symbol - ifTrue: [ - foundRangeIndex := allRanges indexOf: foundRange. - allRanges at: foundRangeIndex - 1 ifAbsent: [ aCandidate ]] - ifFalse: [ aCandidate ]! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 5/4/2020 15:45:27'! - lookForBinarySendRange - - | penultimate currentIndex currentRangeType | - - currentIndex := self lookForNoUnaryMessageSend. - penultimate := allRanges at: currentIndex - 1 ifAbsent: [ SHRange nilObject ]. - - currentRangeType := (allRanges at: currentIndex) rangeType. - currentRangeType = #rightParenthesis ifTrue: [ - ^self lookForBinarySelectorAfter: #leftParenthesis startingAt: currentIndex with: penultimate ]. - currentRangeType = #rightBrace ifTrue: [ - ^self lookForBinarySelectorAfter: #leftBrace startingAt: currentIndex with: penultimate ]. - currentRangeType = #blockEnd ifTrue: [ - ^self lookForBinarySelectorAfter: #blockStart startingAt: currentIndex with: penultimate ]. - currentRangeType = #arrayEnd ifTrue: [ - ^self lookForBinarySelectorAfterArrayStartStartingAt: currentIndex with: penultimate ]. - - ^({#'$'. #symbol} includes: penultimate rangeType) - ifTrue: [ allRanges at: currentIndex - 2 ifAbsent: [ SHRange nilObject ] ] - ifFalse: [ penultimate ]! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 5/4/2020 15:46:02'! - lookForNoUnaryMessageSend - - | currentIndex currentRangeType | - - currentIndex := allRanges size. - [ currentRangeType := (allRanges at: currentIndex) rangeType. - currentRangeType = #unary and: [ currentIndex > 1 ]] whileTrue: [ currentIndex := currentIndex - 1 ]. - - ^currentIndex! ! -!SmalltalkCompleter methodsFor: 'entries' stamp: 'HAW 5/4/2020 02:09:47' prior: 50509162 overrides: 16781250! - computeEntries - - | allSource contextClass specificModel range | - - allSource _ model actualContents string. - specificModel _ self textProviderOrModel. - contextClass _ self selectedClassOrMetaClassIn: specificModel. - allRanges _ self parse: allSource in: contextClass and: specificModel. - "For debugging porpouses: - allRanges collect: [ :r | r rangeType ] - " - range _ allRanges lastIfEmpty: [ ^entries _ #() ]. - possibleInvalidSelectors _ #(). - - range end = position - ifTrue: [ self computeEntriesOfMessageOrIdentifiersFor: allSource at: range in: contextClass and: specificModel ] - ifFalse: [ self computeMessageEntriesWithEmptyPrefixFor: allSource at: range in: contextClass and: specificModel ]. - - ! ! -!SmalltalkCompleter methodsFor: 'message entries - private' stamp: 'HAW 5/4/2020 16:06:03' prior: 50483352! - computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel - - | id rangeType | - - canShowSelectorDocumentation _ true. - id _ allSource copyFrom: range start to: range end. - rangeType _ range rangeType. - - rangeType == #globalVar - ifTrue: [ ^self computeMessageEntriesForClass: (Smalltalk at: id asSymbol) class ]. - rangeType == #self - ifTrue: [ ^self computeMessageEntriesForClass: contextClass ]. - rangeType == #super - ifTrue: [ ^self computeMessageEntriesForClass: contextClass superclass ]. - rangeType == #true - ifTrue: [ ^self computeMessageEntriesForClass: True ]. - rangeType == #false - ifTrue: [ ^self computeMessageEntriesForClass: False ]. - rangeType == #nil - ifTrue: [ ^self computeMessageEntriesForClass: UndefinedObject ]. - rangeType == #character - ifTrue: [ ^self computeMessageEntriesForClass: id first class ]. - rangeType == #number - ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #string - ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #symbol - ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #stringSymbol - ifTrue: [ ^self computeMessageEntriesForClass: (self classOfLiteral: id in: contextClass) ]. - rangeType == #instVar - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofInstVarNamed: id ]. - rangeType == #methodArg - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofTempVarNamed: id ]. - rangeType == #tempVar - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofTempVarNamed: id ]. - rangeType == #blockArg - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofBlockArgNamed: id ]. - rangeType == #blockTempVar - ifTrue: [ ^specificModel computeMessageEntriesIn: self ofBlockTempVarNamed: id ]. - rangeType == #workspaceVar - ifTrue: [ ^self computeMessageEntriesForClassOrNil: (specificModel classOfWorkspaceVarNamed: id) ]. - rangeType == #thisContext - ifTrue: [ ^self computeMessageEntriesForClass: (specificModel classOfThisContext) ]. - rangeType == #classVar - ifTrue: [ ^self computeMessageEntriesForClassOrNil: (self classOfLocalBindingNamed: id in: contextClass) ]. - rangeType == #poolConstant - ifTrue: [ ^self computeMessageEntriesForClassOrNil: (self classOfLocalBindingNamed: id in: contextClass) ]. - (rangeType beginsWith: #blockEnd) - ifTrue: [ ^self computeMessageEntriesForClass: BlockClosure ]. - rangeType == #arrayEnd - ifTrue: [ ^self computeMessageEntriesForClass: Array ]. - (rangeType beginsWith: #rightBrace) - ifTrue: [ ^self computeMessageEntriesForClass: Array ]. - rangeType == #unary - ifTrue: [ ^self computeEntriesOfUnaryMessageReturnNamed: id at: range ]. - (rangeType beginsWith: #rightParenthesis) - ifTrue: [ ^self computeMessageEntriesOfEnclosedExpressionReturnAt: range ]. - rangeType == #cascadeSeparator - ifTrue: [ ^self computeMessageEntriesOfCascadeReceiverAt: range ]. - - self computeMessageEntriesForUnknowClass - - ! ! -!SHParserST80 methodsFor: 'parse' stamp: 'HAW 5/3/2020 21:54:53' prior: 50446222! - parse: isAMethod - "Parse the receiver's text. If isAMethod is true - then treat text as a method, if false as an - expression with no message pattern" - - | continue prevSourcePosition | - self initializeInstanceVariables. - sourcePosition _ 1. - arguments _ Dictionary new. - temporaries _ Dictionary new. - blockDepth _ bracketDepth _ braceDepth _ 0. - blockDepths _ OrderedCollection with: blockDepth. - blockDepthsStartIndexes _ OrderedCollection with: sourcePosition. - ranges ifNil: [ ranges := OrderedCollection new: 100] ifNotNil: [ ranges reset]. - errorBlock _ [^false]. - [ - self scanNext. - isAMethod - ifTrue: [ - self parseMessagePattern. - self parsePragmaSequence]. - self parseMethodTemporaries. - isAMethod ifTrue: [self parsePragmaSequence]. - "Iterate once for methods, but pontentially several times for workspaces - (to recover after errors, for possible good next lines or chunks)" - continue _ true. - [ continue ] whileTrue: [ - prevSourcePosition _ sourcePosition. - self parseStatementList. - continue _ sourcePosition > prevSourcePosition. - isAMethod - ifTrue: [ - "Only if we are parsing a method, consider everything after this point as error." - currentToken ifNotNil: [ self error ]. - continue _ false] - ifFalse: [ - sourcePosition > source size ifTrue: [continue _ false]]]. - ] ensure: [errorBlock _ nil]. - ^true! ! -!SHParserST80 methodsFor: 'parse' stamp: 'HAW 5/3/2020 21:56:35' prior: 16902482! - parseBraceArray - self parseStatementListForBraceArray. - self failUnless: currentTokenFirst == $}. - self scanPast: #rightBrace level: braceDepth. - braceDepth := braceDepth - 1! ! -!SHParserST80 methodsFor: 'parse' stamp: 'HAW 5/3/2020 21:57:08' prior: 50386104! - parseTerm - self failWhen: currentToken isNil. - currentTokenFirst == $( - ifTrue: [ - bracketDepth := bracketDepth + 1. - self scanPast: #leftParenthesis level: bracketDepth. - self parseExpression. - self failUnless: currentTokenFirst == $). - self scanPast: #rightParenthesis level: bracketDepth. - bracketDepth := bracketDepth - 1. - ^self ]. - currentTokenFirst == $[ ifTrue: [^self parseBlock]. - currentTokenFirst == $` ifTrue: [^self parseBacktick]. - currentTokenFirst == ${ - ifTrue: [ - braceDepth := braceDepth + 1. - self scanPast: #leftBrace level: braceDepth. - self parseBraceArray. - ^self ]. - self isName ifTrue: [^self scanPast: (self resolve: currentToken)]. - self parseLiteral: false! ! - -SmalltalkCompleter removeSelector: #lookForBinarySelectorAfter:in:startingAt:with:! - -SmalltalkCompleter removeSelector: #computeMessageEntriesWhenSendinMessageFor:using:in:and:! - -!methodRemoval: SmalltalkCompleter #computeMessageEntriesWhenSendinMessageFor:using:in:and: stamp: 'Install-4137-AutoCompleteImprovements-HernanWilkinson-2020May03-15h16m-HAW.001.cs.st 5/26/2020 17:09:06'! -computeMessageEntriesWhenSendinMessageFor: allSource using: allRanges in: contextClass and: specificModel - - | prevRange | - - "If previous range is a constant or a well known identifier, we might filter messages" - prevRange _ allRanges penultimateIfAbsent: [ SHRange nilObject ]. - possibleBinarySendRange _ allRanges antepenultimateIfAbsent: [ SHRange nilObject ]. - - ^ (self canComputeMessageEntriesFor: prevRange) - ifTrue: [ self computeMessageEntriesFor: allSource at: prevRange in: contextClass and: specificModel ] - ifFalse: [ self computeMessageEntriesForUnknowClass ] -! - -SmalltalkCompleter removeSelector: #computeEntriesOfMessageOrIdentifiersFor:using:at:in:and:! - -!methodRemoval: SmalltalkCompleter #computeEntriesOfMessageOrIdentifiersFor:using:at:in:and: stamp: 'Install-4137-AutoCompleteImprovements-HernanWilkinson-2020May03-15h16m-HAW.001.cs.st 5/26/2020 17:09:06'! -computeEntriesOfMessageOrIdentifiersFor: allSource using: allRanges at: range in: contextClass and: specificModel - - prefix _ allSource copyFrom: range start to: range end. - (parser isMessage: range rangeType) ifTrue: [ - ^self computeMessageEntriesWhenSendinMessageFor: allSource using: allRanges in: contextClass and: specificModel ]. - (parser isPartialOrFullIdentifier: range rangeType) ifTrue: [ ^self computeIdentifierEntries ]. - - "If we don't know what to do, do nothing" - entries _ #() ! - -SmalltalkCompleter removeSelector: #moveUpTo:from:! - -SmalltalkCompleter removeSelector: #xinitialize! - -SmalltalkCompleter removeSelector: #moveUpTo:from:in:! - -SmalltalkCompleter removeSelector: #initialize! - -SmalltalkCompleter removeSelector: #startingAt:with:! - -SmalltalkCompleter removeSelector: #eatParenthesisFrom:in:! - -SmalltalkCompleter removeSelector: #possibleBinarySendRangeFrom:! - -!methodRemoval: SmalltalkCompleter #possibleBinarySendRangeFrom: stamp: 'Install-4137-AutoCompleteImprovements-HernanWilkinson-2020May03-15h16m-HAW.001.cs.st 5/26/2020 17:09:06'! -possibleBinarySendRangeFrom: allRanges - - | penultimate antepenultimate | - - penultimate := allRanges penultimateIfAbsent: [ SHRange nilObject ]. - antepenultimate := allRanges antepenultimateIfAbsent: [ SHRange nilObject ]. - - possibleBinarySendRange _ penultimate rangeType = #arrayStart - ifTrue: [ antepenultimate rangeType = #symbol - ifTrue: [ allRanges at: allRanges size - 3 ifAbsent: [ SHRange nilObject ] ]] - ifFalse: [ - ({#leftBrace. #'$'. #symbol. #blockStart. } includes: penultimate rangeType) - ifTrue: [ antepenultimate ] - ifFalse: [ penultimate ]]! - -SmalltalkCompleter removeSelector: #possibleBinarySendRangeFrom! - -SmalltalkCompleter removeSelector: #lookForBinarySelectorAfter:in:startingAt:! - -SmalltalkCompleter removeSelector: #lookForBinarySelectorAfterArrayStartIn:startingAt:with:! - -SmalltalkCompleter removeSelector: #computeMessageEntriesWithEmptyPrefixFor:using:at:in:and:! - -!methodRemoval: SmalltalkCompleter #computeMessageEntriesWithEmptyPrefixFor:using:at:in:and: stamp: 'Install-4137-AutoCompleteImprovements-HernanWilkinson-2020May03-15h16m-HAW.001.cs.st 5/26/2020 17:09:06'! -computeMessageEntriesWithEmptyPrefixFor: allSource using: allRanges at: range in: contextClass and: specificModel - - self possibleBinarySendRangeFrom: allRanges. - prefix _ ''. - - self computeMessageEntriesFor: allSource at: range in: contextClass and: specificModel .! - -SmalltalkCompleter removeSelector: #lookForBinarySelectorAfterArrayStartIn:startingAt:! - -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser selectorsClasses possibleInvalidSelectors canShowSelectorDocumentation possibleBinarySendRange allRanges' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #SmalltalkCompleter category: #'Tools-Autocompletion' stamp: 'Install-4137-AutoCompleteImprovements-HernanWilkinson-2020May03-15h16m-HAW.001.cs.st 5/26/2020 17:09:06'! -AutoCompleter subclass: #SmalltalkCompleter - instanceVariableNames: 'parser selectorsClasses possibleInvalidSelectors canShowSelectorDocumentation possibleBinarySendRange allRanges' - classVariableNames: 'AccessLock EntriesLimit Selectors' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -Object subclass: #SHParserST80 - instanceVariableNames: 'classOrMetaClass source workspace arguments sourcePosition currentToken currentTokenFirst temporaries instanceVariables errorBlock currentTokenSourcePosition blockDepth bracketDepth ranges blockDepths blockDepthsStartIndexes allSource braceDepth' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -!classDefinition: #SHParserST80 category: #'Tools-Syntax Highlighting' stamp: 'Install-4137-AutoCompleteImprovements-HernanWilkinson-2020May03-15h16m-HAW.001.cs.st 5/26/2020 17:09:06'! -Object subclass: #SHParserST80 - instanceVariableNames: 'classOrMetaClass source workspace arguments sourcePosition currentToken currentTokenFirst temporaries instanceVariables errorBlock currentTokenSourcePosition blockDepth bracketDepth ranges blockDepths blockDepthsStartIndexes allSource braceDepth' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4137-AutoCompleteImprovements-HernanWilkinson-2020May03-15h16m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4137] on 7 May 2020 at 4:30:44 pm'! -!PseudoClass methodsFor: 'as yet unclassified' stamp: 'HAW 5/7/2020 13:02:06'! - printHierarchy - - ^'Hierarchy view not supported'! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4139-PseudoClass-printHierarchy fix-HernanWilkinson-2020May07-13h01m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4139] on 8 May 2020 at 12:00:19 pm'! -!Morph methodsFor: 'caching' stamp: 'jmv 5/8/2020 11:43:26'! - clearId - id _ nil.! ! -!Morph class methodsFor: 'initialize-release' stamp: 'jmv 5/8/2020 11:53:06' overrides: 16785014! - releaseClassState - - LastMorphId _ nil. - self allSubInstancesDo: [ :each | - each clearId. - each releaseCachedState ]! ! -!Behavior methodsFor: 'system startup' stamp: 'jmv 5/8/2020 11:39:03' prior: 50417623! - releaseClassCachedState - "Will be called for each class on shutdown or snapshot. - All class vars or class instVar vars that can be cheaply recreated lazily on demand, should be nilled. - For more expensive stuff to clean and recreate, consider #releaseClassState that is not called on every image save. - See implementors for examples"! ! -!Behavior methodsFor: 'system startup' stamp: 'jmv 5/8/2020 11:40:43' prior: 16785014! - releaseClassState - "Will be called for each class on 'Save as new version'. - All class vars or class instVar vars that can be recreated lazily on demand, should be nilled. This is done not only to save space, but more importantly, to prepare Cuis for a complete bootstrap from sources. For this, it should be possible to recreate all class state, at least with default values. - See implementors for examples"! ! -!Morph methodsFor: 'caching' stamp: 'jmv 5/8/2020 11:44:22' prior: 50505999! - releaseCachedState - "Release any state that can be recomputed on demand, such as the pixel values for a color gradient or the editor state for a TextMorph. This method may be called to save space when a morph becomes inaccessible. Implementations of this method should do 'super releaseCachedState'."! ! - -Morph class removeSelector: #releaseClassCachedState! - -!methodRemoval: Morph class #releaseClassCachedState stamp: 'Install-4140-AvoidExpensiveClearOnEveryImageSave-JuanVuletich-2020May08-11h57m-jmv.001.cs.st 5/26/2020 17:09:06'! -releaseClassCachedState - - LastMorphId _ nil. - self allSubInstancesDo: [ :each | - each releaseCachedState ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4140-AvoidExpensiveClearOnEveryImageSave-JuanVuletich-2020May08-11h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4140] on 14 May 2020 at 4:58:32 pm'! - -Bitmap removeSelector: #byteSize! - -!methodRemoval: Bitmap #byteSize stamp: 'Install-4141-RemoveSuperfluousMethods-JuanVuletich-2020May14-15h34m-jmv.001.cs.st 5/26/2020 17:09:06'! -byteSize - ^self size * 4! - -WordArray removeSelector: #byteSize! - -!methodRemoval: WordArray #byteSize stamp: 'Install-4141-RemoveSuperfluousMethods-JuanVuletich-2020May14-15h34m-jmv.001.cs.st 5/26/2020 17:09:06'! -byteSize - ^self size * 4! - -ByteArray removeSelector: #byteSize! - -!methodRemoval: ByteArray #byteSize stamp: 'Install-4141-RemoveSuperfluousMethods-JuanVuletich-2020May14-15h34m-jmv.001.cs.st 5/26/2020 17:09:06'! -byteSize - ^self size! - -String removeSelector: #byteSize! - -!methodRemoval: String #byteSize stamp: 'Install-4141-RemoveSuperfluousMethods-JuanVuletich-2020May14-15h34m-jmv.001.cs.st 5/26/2020 17:09:06'! -byteSize - ^self size! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4141-RemoveSuperfluousMethods-JuanVuletich-2020May14-15h34m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4140] on 14 May 2020 at 5:15:37 pm'! - -Object variableWordSubclass: #ThirtyTwoBitSlotsObject - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Objects'! - -!classDefinition: #ThirtyTwoBitSlotsObject category: #'Kernel-Objects' stamp: 'Install-4142-ThirtyTwoBitSlotsObject-JuanVuletich-2020May14-16h58m-jmv.001.cs.st 5/26/2020 17:09:06'! -Object variableWordSubclass: #ThirtyTwoBitSlotsObject - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Objects'! -!ThirtyTwoBitSlotsObject commentStamp: '' prior: 0! - Abstract superclass for objects whose slots are 32 bit values. -- Each can be Float or Integer, but always 32 bit. -- They have a fixed size, defined by the class. -- They don't have collection protocol.! -!Float32SlotsObject methodsFor: 'private' stamp: 'jmv 5/14/2020 17:04:33'! - floatSlotAt: index - - ^Float fromIEEE32Bit: (self basicAt: index)! ! -!Float32SlotsObject methodsFor: 'private' stamp: 'jmv 5/14/2020 17:05:55'! - floatSlotAt: index put: value - - value isFloat - ifTrue: [ self basicAt: index put: value asIEEE32BitWord ] - ifFalse: [ self floatSlotAt: index put: value asFloat ]. - ^value! ! -!ThirtyTwoBitSlotsObject methodsFor: 'accessing' stamp: 'jmv 5/14/2020 17:01:35'! - byteSize - ^self size * 4! ! -!ThirtyTwoBitSlotsObject methodsFor: 'private' stamp: 'jmv 5/14/2020 17:13:27'! - bytesAt: index - "Answer a ByteArray of 4 elements. - The 32-bit word is split in 4 bytes, in little endian format - ThirtyTwoBitSlotsObject new:1 :: at: 1 put: 16rFF32791B ; bytesAt: 1 :: hex - " - - | bytes word | - bytes _ ByteArray new: 4. - word _ self basicAt: index. "Usually a SmallInteger, but may be a Large Integer in 32-bit images" - 1 to: 4 do: [ :i | bytes at: i put: (word digitAt: i) ]. - ^ bytes! ! -!ThirtyTwoBitSlotsObject methodsFor: 'private' stamp: 'jmv 5/14/2020 17:14:38'! - bytesAt: index put: aByteArray - "Takes a ByteArray of 4 elements. - Store the 32-bit word made with those byes, in little endian format - ThirtyTwoBitSlotsObject new: 1 :: bytesAt: 1 put: #[16r1B 16r79 16r32 16rFF]; basicAt: 1 :: hex - " - - | word | - word _ 0. - 4 to: 1 by: -1 do: [ :i | word _ word * 256 + (aByteArray at: i) ]. - self basicAt: index put: word! ! -!ThirtyTwoBitSlotsObject methodsFor: 'private' stamp: 'jmv 5/14/2020 17:03:42'! - floatSlotAt: index - - ^Float fromIEEE32Bit: (self basicAt: index)! ! -!ThirtyTwoBitSlotsObject methodsFor: 'private' stamp: 'jmv 5/14/2020 17:05:41'! - floatSlotAt: index put: value - - value isFloat - ifTrue: [ self basicAt: index put: value asIEEE32BitWord ] - ifFalse: [ self floatSlotAt: index put: value asFloat ]. - ^value! ! -!ThirtyTwoBitSlotsObject methodsFor: 'private' stamp: 'jmv 5/14/2020 17:07:17'! - integerSlotAt: index - "Return the integer at the given index" - | word | - - word _ self basicAt: index. - word < 16r3FFFFFFF ifTrue:[^word]. "Avoid LargeInteger computations" - ^word >= 16r80000000 "Negative?!!" - ifTrue:["word - 16r100000000" - (word bitInvert32 + 1) negated] - ifFalse:[word]! ! -!ThirtyTwoBitSlotsObject methodsFor: 'private' stamp: 'jmv 5/14/2020 17:07:30'! - integerSlotAt: index put: anInteger - "Store the integer at the given index" - | word | - - anInteger < 0 - ifTrue:["word _ 16r100000000 + anInteger" - word _ (anInteger + 1) negated bitInvert32] - ifFalse:[word _ anInteger]. - self basicAt: index put: word. - ^anInteger! ! -!ThirtyTwoBitSlotsObject methodsFor: 'private' stamp: 'jmv 5/14/2020 17:15:15'! - unsignedIntAt: index - - ^self basicAt: index! ! -!ThirtyTwoBitSlotsObject methodsFor: 'private' stamp: 'jmv 5/14/2020 17:15:24'! - unsignedIntAt: index put: anInteger - - ^self basicAt: index put: anInteger! ! -!ThirtyTwoBitSlotsObject class methodsFor: 'instance creation' stamp: 'jmv 5/14/2020 17:01:35' overrides: 16783533! - new - "Answer a new instance of me, with size = 0, unles a specific size is used." - - ^self new: self numSlots! ! -!ThirtyTwoBitSlotsObject class methodsFor: 'instance creation' stamp: 'jmv 5/14/2020 17:01:35'! - numSlots - ^0! ! -!WordArray methodsFor: 'as yet unclassified' stamp: 'jmv 5/14/2020 17:09:03' overrides: 16880774! - at: x - ^super at: x! ! -!WordArray methodsFor: 'as yet unclassified' stamp: 'jmv 5/14/2020 17:09:10' overrides: 16880792! - at: x put: y - ^super at: x put: y! ! -!WordArray methodsFor: 'as yet unclassified' stamp: 'jmv 5/14/2020 17:10:29' overrides: 16880817! - basicAt: index - ^super basicAt: index ! ! -!WordArray methodsFor: 'as yet unclassified' stamp: 'jmv 5/14/2020 17:10:45' overrides: 16880833! - basicAt: x put: y - ^super basicAt: x put: y! ! -!Color methodsFor: 'access' stamp: 'jmv 5/14/2020 17:04:45' prior: 50475096! - blue - "Return the blue component of this color, a float in the range [0.0..1.0]." - - ^ self floatSlotAt: 3! ! -!Color methodsFor: 'access' stamp: 'jmv 5/14/2020 17:04:54' prior: 50475102! - green - "Return the green component of this color, a float in the range [0.0..1.0]." - - ^ self floatSlotAt: 2! ! -!Color methodsFor: 'access' stamp: 'jmv 5/14/2020 17:05:16' prior: 50475108! - red - "Return the red component of this color, a float in the range [0.0..1.0]." - - ^ self floatSlotAt: 1! ! -!Color methodsFor: 'conversions' stamp: 'jmv 5/14/2020 17:05:10' prior: 50475114! - pixelValueForDepth: d - "Returns an integer representing the bits that appear in a single pixel of this color in a Form of the given depth. The depth must be one of 1, 2, 4, 8, 16, or 32. Contrast with pixelWordForDepth: and bitPatternForDepth:, which return either a 32-bit word packed with the given pixel value or a multiple-word Bitmap containing a pattern. The inverse is the class message colorFromPixelValue:depth:" - "Details: For depths of 8 or less, the result is a colorMap index. For depths of 16 and 32, it is a direct color value with 5 or 8 bits per color component." - "Transparency: The pixel value zero is reserved for transparent. For depths greater than 8 and less than 32 (no Indexed colors, no real alpha), black maps to the darkest possible blue. - Note that - Color transparent class = TranslucentColor - this special case is handled in TranslucentColor >> #pixelValueForDepth: - " - - | bitBltFakeBlack val | - "Most common case" - "eight bits per component; top 8 bits set to all ones (opaque alpha)" - d = 32 ifTrue: [ - ^ 16rFF000000 bitOr: - ((((self floatSlotAt: 1) * 255.999) truncated bitShift: 16) bitOr: - ((((self floatSlotAt: 2) * 255.999) truncated bitShift: 8) bitOr: - (((self floatSlotAt: 3) * 255.999) truncated))) ]. - -"Faster in 32 bit systems, but slower in 64 bits" -" d = 32 ifTrue: [ - val _ LargePositiveInteger new: 4. - val at: 3 put: ((self at: 1) * 255.999) truncated. - val at: 2 put: ((self at: 2) * 255.999) truncated. - val at: 1 put: ((self at: 3) * 255.999) truncated. - val at: 4 put: 16rFF. - ^ val normalize]." - - d = 8 ifTrue: [^ self closestPixelValue8]. "common case" - d < 8 ifTrue: [ - d = 4 ifTrue: [^ self closestPixelValue4]. - d = 2 ifTrue: [^ self closestPixelValue2]. - d = 1 ifTrue: [^ self closestPixelValue1]]. - - "For the depth 16, pixelValue = 0 means transparent, black is represented as 16r8000 (rgb=0, pixelvalue !!= 0)." - (d = 16) | (d = 15) ifTrue: [ - "five bits per component; top bits ignored" - val _ ((self red * 31) rounded bitShift: 10) bitOr: - (((self green * 31) rounded bitShift: 5) bitOr: - ((self blue * 31) rounded)). - ^ val = 0 - ifTrue: [d = 16 ifTrue: [16r8000] ifFalse: [1]] - ifFalse: [val]]. - - "For the rest of the depths, pixelValue = 0 means transparent, and darkest blue is considered to be black." - bitBltFakeBlack := 1. "closest black that is not transparent in RGB - Not for depths <=8 (Indexed) or = 32 (RGBA)" - d = 12 ifTrue: [ "for indexing a color map with 4 bits per color component" - val _ ((self red * 15) rounded bitShift: 8) bitOr: - (((self green * 15) rounded bitShift: 4) bitOr: - ((self blue * 15) rounded)). - ^ val = 0 ifTrue: [bitBltFakeBlack] ifFalse: [val]]. - - d = 9 ifTrue: [ "for indexing a color map with 3 bits per color component" - val _ ((self red * 7) rounded bitShift: 6) bitOr: - (((self green * 7) rounded bitShift: 3) bitOr: - ((self blue * 7) rounded)). - ^ val = 0 ifTrue: [bitBltFakeBlack] ifFalse: [val]]. - - self error: 'unknown pixel depth: ', d printString! ! -!Color methodsFor: 'queries' stamp: 'jmv 5/14/2020 17:04:58' prior: 50475211! - isBlack - "Return true if the receiver represents black" - (self floatSlotAt: 1) = 0.0 ifFalse: [ ^ false ]. - (self floatSlotAt: 2) = 0.0 ifFalse: [ ^ false ]. - (self floatSlotAt: 3) = 0.0 ifFalse: [ ^ false ]. - ^ true! ! -!Color methodsFor: 'queries' stamp: 'jmv 5/14/2020 17:05:03' prior: 50475220! - isWhite - "Return true if the receiver represents white" - (self floatSlotAt: 1) = 1.0 ifFalse: [ ^ false ]. - (self floatSlotAt: 2) = 1.0 ifFalse: [ ^ false ]. - (self floatSlotAt: 3) = 1.0 ifFalse: [ ^ false ]. - ^ true! ! -!Color methodsFor: 'private' stamp: 'jmv 5/14/2020 17:05:35' prior: 50475229! - basicSetRed: r green: g blue: b - "Initialize this color's r, g, and b components to the given values in the range [0.0..1.0]." - - self - floatSlotAt: 1 put: r; - floatSlotAt: 2 put: g; - floatSlotAt: 3 put: b! ! -!Color methodsFor: 'private' stamp: 'jmv 5/14/2020 17:05:49' prior: 50475238! - clipToValidValues - | v | - 1 to: self size do: [ :i | - v _ self floatSlotAt: i. - v > 1 ifTrue: [self floatSlotAt: i put: 1.0]. - v < 0 ifTrue: [self floatSlotAt: i put: 0.0]]! ! -!TranslucentColor methodsFor: 'accessing' stamp: 'jmv 5/14/2020 17:05:20' prior: 50475246 overrides: 50353215! - alpha - "Return my alpha value, a number between 0.0 and 1.0 where 0.0 is completely transparent and 1.0 is completely opaque." - - ^ self floatSlotAt: 4! ! -!TranslucentColor methodsFor: 'private' stamp: 'jmv 5/14/2020 17:06:02' prior: 50475254! - setRed: r green: g blue: b alpha: alphaValue - - self basicSetRed: r green: g blue: b. - self floatSlotAt: 4 put: alphaValue! ! - -ThirtyTwoBitSlotsObject removeSelector: #integerSloatAt:! - -ThirtyTwoBitSlotsObject removeSelector: #slotAt:put:! - -ThirtyTwoBitSlotsObject removeSelector: #slotAt:! - -Float32SlotsObject removeSelector: #slotAt:! - -!methodRemoval: Float32SlotsObject #slotAt: stamp: 'Install-4142-ThirtyTwoBitSlotsObject-JuanVuletich-2020May14-16h58m-jmv.001.cs.st 5/26/2020 17:09:06'! -slotAt: index - - ^Float fromIEEE32Bit: (self basicAt: index)! - -Float32SlotsObject removeSelector: #slotAt:put:! - -!methodRemoval: Float32SlotsObject #slotAt:put: stamp: 'Install-4142-ThirtyTwoBitSlotsObject-JuanVuletich-2020May14-16h58m-jmv.001.cs.st 5/26/2020 17:09:06'! -slotAt: index put: value - - value isFloat - ifTrue: [ self basicAt: index put: value asIEEE32BitWord ] - ifFalse: [ self slotAt: index put: value asFloat ]. - ^value! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4142-ThirtyTwoBitSlotsObject-JuanVuletich-2020May14-16h58m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4140] on 14 May 2020 at 5:15:56 pm'! - -ThirtyTwoBitSlotsObject variableWordSubclass: #Color - instanceVariableNames: '' - classVariableNames: 'CachedColormaps FromGrayColormaps GrayToIndexMap IndexedColors MaskingMap ToGrayColormaps ' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -!classDefinition: #Color category: #'Graphics-Primitives' stamp: 'Install-4143-ColorIsThirtyTwoBitSlotsObject-JuanVuletich-2020May14-17h15m-jmv.001.cs.st 5/26/2020 17:09:07'! -ThirtyTwoBitSlotsObject variableWordSubclass: #Color - instanceVariableNames: '' - classVariableNames: 'CachedColormaps FromGrayColormaps GrayToIndexMap IndexedColors MaskingMap ToGrayColormaps' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -ThirtyTwoBitSlotsObject variableWordSubclass: #Color - instanceVariableNames: '' - classVariableNames: 'CachedColormaps FromGrayColormaps GrayToIndexMap IndexedColors MaskingMap ToGrayColormaps' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -!classDefinition: #Color category: #'Graphics-Primitives' stamp: 'Install-4143-ColorIsThirtyTwoBitSlotsObject-JuanVuletich-2020May14-17h15m-jmv.001.cs.st 5/26/2020 17:09:07'! -ThirtyTwoBitSlotsObject variableWordSubclass: #Color - instanceVariableNames: '' - classVariableNames: 'CachedColormaps FromGrayColormaps GrayToIndexMap IndexedColors MaskingMap ToGrayColormaps' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4143-ColorIsThirtyTwoBitSlotsObject-JuanVuletich-2020May14-17h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4140] on 14 May 2020 at 5:16:14 pm'! - -Smalltalk removeClassNamed: #Float32SlotsObject! - -!classRemoval: #Float32SlotsObject stamp: 'Install-4144-remove-Float32SlotsObject-JuanVuletich-2020May14-17h15m-jmv.001.cs.st 5/26/2020 17:09:07'! -Object variableWordSubclass: #Float32SlotsObject - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Objects'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4144-remove-Float32SlotsObject-JuanVuletich-2020May14-17h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4140] on 14 May 2020 at 5:49:46 pm'! -!ThirtyTwoBitSlotsObject methodsFor: 'private' stamp: 'jmv 5/14/2020 17:49:24'! - intSlotAt: index - "Return the integer at the given index" - | word | - - word _ self basicAt: index. - word < 16r3FFFFFFF ifTrue:[^word]. "Avoid LargeInteger computations" - ^word >= 16r80000000 "Negative?!!" - ifTrue:["word - 16r100000000" - (word bitInvert32 + 1) negated] - ifFalse:[word]! ! -!ThirtyTwoBitSlotsObject methodsFor: 'private' stamp: 'jmv 5/14/2020 17:49:30'! - intSlotAt: index put: anInteger - "Store the integer at the given index" - | word | - - anInteger < 0 - ifTrue:["word _ 16r100000000 + anInteger" - word _ (anInteger + 1) negated bitInvert32] - ifFalse:[word _ anInteger]. - self basicAt: index put: word. - ^anInteger! ! - -ThirtyTwoBitSlotsObject removeSelector: #integerSlotAt:! - -!methodRemoval: ThirtyTwoBitSlotsObject #integerSlotAt: stamp: 'Install-4145-ThirtyTwoBitSlotsObject-tweaks-JuanVuletich-2020May14-17h16m-jmv.001.cs.st 5/26/2020 17:09:07'! -integerSlotAt: index - "Return the integer at the given index" - | word | - - word _ self basicAt: index. - word < 16r3FFFFFFF ifTrue:[^word]. "Avoid LargeInteger computations" - ^word >= 16r80000000 "Negative?!!" - ifTrue:["word - 16r100000000" - (word bitInvert32 + 1) negated] - ifFalse:[word]! - -ThirtyTwoBitSlotsObject removeSelector: #integerSlotAt:put:! - -!methodRemoval: ThirtyTwoBitSlotsObject #integerSlotAt:put: stamp: 'Install-4145-ThirtyTwoBitSlotsObject-tweaks-JuanVuletich-2020May14-17h16m-jmv.001.cs.st 5/26/2020 17:09:07'! -integerSlotAt: index put: anInteger - "Store the integer at the given index" - | word | - - anInteger < 0 - ifTrue:["word _ 16r100000000 + anInteger" - word _ (anInteger + 1) negated bitInvert32] - ifFalse:[word _ anInteger]. - self basicAt: index put: word. - ^anInteger! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4145-ThirtyTwoBitSlotsObject-tweaks-JuanVuletich-2020May14-17h16m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4146] on 17 May 2020 at 5:49:20 am'! -!Fraction commentStamp: '' prior: 16849428! - Fraction provides methods for dealing with rational numbers like 1/3 as true fractions (not approximations as a Float 0.33333...). All public arithmetic operations answer reduced fractions, or Integers when the denominator is 1. - -Examples: (note the parentheses required to get the right answers in Smalltalk): - -(2/3) + (2/3) -(6/4) "Fractions are reduced to the smallest numerator and denominator possible" -(1/-3) "Denominator is kept positive, the sign is always in the numerator" -(2/3) + (1/3) "When the denominator reduces to 1, the answer is an Integer" -! -!Integer commentStamp: '' prior: 16858841! - I am a common abstract superclass for all Integer implementations. My implementation subclasses are SmallInteger, LargePositiveInteger, and LargeNegativeInteger. - -There are three implementation of Euclidean division of 'a' by 'b', where 'a' and 'b' are Integers considered as elements of the rational integers ring Z: - - Euclidean division with the quotient rounded towards negative infinity: // and \\ answer 'q' and 'r' such that 'a = bq + r' with 'r abs < b abs', where 'r' is 0 or has the same sign as 'b'. This is sometimes called Knuth's division, and it matches the division commonly implemented in CPUs. - - Euclidean division with the quotient rounded towards zero: #quo: and #rem: answer 'q' and 'r' such that 'a = bq + r' with 'r abs < b abs', where 'r' is 0 or has the same sign as 'a'. - - Euclidean division with non-negative remainder: #div: and #mod: answer 'q' and 'r' such that 'a = bq + r' with '0 <= r < b abs'. -Note that, taking the absolute value as Euclidean function, all of these divisions comply with the definition of Euclidean division. However requiring only 'r abs < b abs' is not enough for producing a unique quotient and remainder, and the additional requirements for the sign of 'r' (different in each of the three kinds of division) guarantee a unique choice of quotient and remainder. - -Additionally, the division in the rational field is implemented with the message / that answers a Fraction 'a/b' if the result is not a whole integer. Note that in the current design of the Number hierarchy, because Fractions reduce to Integers when the denominator is 1, an Integer per-se doesn't know if it is an element of the rational integers ring Z or a member of the rational field Q. In the rational field Q, the quotient of the Euclidean division is / and the remainder is always 0, and the other three divisions are not Euclidean divisions.! -!Number methodsFor: 'arithmetic' stamp: 'len 5/17/2020 05:40:28' prior: 16879694! - div: aNumber - "Integer division with non-negative remainder. - (9 div:4) = 2 - (-9 div: 4) = -3 - (-0.9 div: 0.4) = -3 - #mod: answers the remainder from this division. See comments and examples there. - See #//, #quo:, #div:" - "Answer an integer q such that: - for some r, aNumber * q + r = self - with 0 <= r < | aNumber |" - - aNumber positive ifTrue: [ ^self // aNumber ]. - ^ (self // aNumber abs) negated! ! -!Number methodsFor: 'arithmetic' stamp: 'len 5/17/2020 05:39:46' prior: 50405300! - mod: divisor - "Modulo operation. Remainder of the integer division #div:. - Answer a Number that is never negative (it is positive or zero). - (9 mod: 4) = 1 - (-9 mod: 4) = 3 - (9 mod: -4) = 1 - (0.9 mod: 0.4) = 0.1 - See http://en.wikipedia.org/wiki/Modulo_operation - See #\\, #rem: and #mod: - See detailed discussion at http://mathforum.org/library/drmath/view/52343.html - And https://biblio.ugent.be/input/download?func=downloadFile&recordOId=314490&fileOId=452146 - " - "Answer r such that: - for some integer q, aNumber * q + r = self - with 0 <= r < | aNumber |" - - ^self \\ divisor abs - - "Evaluate the following:" -" -| g d | -d _ 1. -Feature require: 'Morphic-Widgets-Extras'. -g _ FunctionGraphMorph new. -g domain: (-4 to: 4). -g addFunction: [ :x | x mod: d ] color: Color green. -g addFunction: [ :x | x div: d ] color: Color red. -g openInWorld -" -" -| g d | -d _ -1. -Feature require: 'Morphic-Widgets-Extras'. -g _ FunctionGraphMorph new. -g domain: (-4 to: 4). -g addFunction: [ :x | x mod: d ] color: Color green. -g addFunction: [ :x | x div: d ] color: Color red. -g openInWorld -" -! ! -!Number methodsFor: 'arithmetic' stamp: 'len 5/17/2020 05:35:19' prior: 16879748! - quo: aNumber - "Integer division with truncation towards zero. - (-9 quo: 4) = -2 - (-0.9 quo: 0.4) = -2 - #rem: answers the remainder from this division. - See #//, #quo:, #div:" - - ^ (self / aNumber) truncated! ! -!Number methodsFor: 'arithmetic' stamp: 'len 5/17/2020 05:41:49' prior: 16879763! - rem: divisor - "Modulo operation. Remainder of the integer division #quo: (division with truncation towards zero). - Answer a Number with the same sign as dividend (i.e., self). - (9 rem: 4) = 1. - (-9 rem: 4) = -1. - (0.9 rem: 0.4) = 0.1. - See http://en.wikipedia.org/wiki/Modulo_operation - See #\\, #rem: and #mod: - See detailed discussion at http://mathforum.org/library/drmath/view/52343.html - " - - ^self - ((self quo: divisor) * divisor) - - "Evaluate the following:" -" -| g d | -d _ 1. -g _ FunctionGraphMorph new. -g domain: (-4 to: 4). -g addFunction: [ :x | x rem: d ] color: Color green. -g addFunction: [ :x | x quo: d ] color: Color red. -g openInWorld -" -" -| g d | -d _ -1. -g _ FunctionGraphMorph new. -g domain: (-4 to: 4). -g addFunction: [ :x | x rem: d ] color: Color green. -g addFunction: [ :x | x quo: d ] color: Color red. -g openInWorld -"! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4146-DivisionDocumentation-LucianoEstebanNotarfrancesco-2020May17-05h31m-len.001.cs.st----! - -'From Cuis 5.0 [latest update: #4145] on 18 May 2020 at 2:54:04 pm'! -!Number methodsFor: 'arithmetic' stamp: 'jmv 5/18/2020 14:53:46' prior: 50510730! - mod: divisor - "Modulo operation. Remainder of the integer division #div: (Euclidean division) - Answer a Number that is never negative (it is positive or zero). - (9 mod: 4) = 1 - (-9 mod: 4) = 3 - (9 mod: -4) = 1 - (0.9 mod: 0.4) = 0.1 - See http://en.wikipedia.org/wiki/Modulo_operation - See #\\, #rem: and #mod: - See detailed discussion at http://mathforum.org/library/drmath/view/52343.html - And 'The Euclidean Definition of the Functions div and mod' by Raymond T. Boute, https://core.ac.uk/download/pdf/55698442.pdf - " - "Answer r such that: - for some integer q, aNumber * q + r = self - with 0 <= r < | aNumber |" - - ^self \\ divisor abs - - "Evaluate the following:" -" -| g d | -d _ 1. -Feature require: 'Morphic-Widgets-Extras'. -g _ FunctionGraphMorph new. -g domain: (-4 to: 4). -g addFunction: [ :x | x mod: d ] color: Color green. -g addFunction: [ :x | x div: d ] color: Color red. -g openInWorld -" -" -| g d | -d _ -1. -Feature require: 'Morphic-Widgets-Extras'. -g _ FunctionGraphMorph new. -g domain: (-4 to: 4). -g addFunction: [ :x | x mod: d ] color: Color green. -g addFunction: [ :x | x div: d ] color: Color red. -g openInWorld -" -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4147-FixMissingWebLink-JuanVuletich-2020May18-14h53m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4147] on 18 May 2020 at 3:09:14 pm'! -!Number methodsFor: 'arithmetic' stamp: 'jmv 5/18/2020 15:07:11' prior: 50405268! - \\ divisor - "Modulo operation. Remainder of the integer division #// (Floored division, truncated to minus infinity, a.k.a Knuth's division) - Answer a Number with the same sign as divisor. - 9\\4 = 1 - -9\\4 = 3 - 9\\-4 = -3 - 0.9\\0.4 = 0.1 - See http://en.wikipedia.org/wiki/Modulo_operation - See #\\, #rem: and #mod: - See detailed discussion at http://mathforum.org/library/drmath/view/52343.html - " - - ^self - (self // divisor * divisor) - - "Evaluate the following:" -" -Compiler evaluate: ' - | g d | - d _ 1. - Feature require: ''Morphic-Widgets-Extras''. - g _ FunctionGraphMorph new. - g domain: (-4 to: 4). - g addFunction: [ :x | x \\ d ] color: Color green. - g addFunction: [ :x | x // d ] color: Color red. - g openInWorld' -" -" -Compiler evaluate: ' - | g d | - d _ -1. - Feature require: ''Morphic-Widgets-Extras''. - g _ FunctionGraphMorph new. - g domain: (-4 to: 4). - g addFunction: [ :x | x \\ d ] color: Color green. - g addFunction: [ :x | x // d ] color: Color red. - g openInWorld' -"! ! -!Number methodsFor: 'arithmetic' stamp: 'jmv 5/18/2020 15:07:30' prior: 50510814! - mod: divisor - "Modulo operation. Remainder of the integer division #div: (Euclidean division) - Answer a Number that is never negative (it is positive or zero). - (9 mod: 4) = 1 - (-9 mod: 4) = 3 - (9 mod: -4) = 1 - (0.9 mod: 0.4) = 0.1 - See http://en.wikipedia.org/wiki/Modulo_operation - See #\\, #rem: and #mod: - See detailed discussion at http://mathforum.org/library/drmath/view/52343.html - And 'The Euclidean Definition of the Functions div and mod' by Raymond T. Boute, https://core.ac.uk/download/pdf/55698442.pdf - " - "Answer r such that: - for some integer q, aNumber * q + r = self - with 0 <= r < | aNumber |" - - ^self \\ divisor abs - - "Evaluate the following:" -" -Compiler evaluate: ' - | g d | - d _ 1. - Feature require: ''Morphic-Widgets-Extras''. - g _ FunctionGraphMorph new. - g domain: (-4 to: 4). - g addFunction: [ :x | x mod: d ] color: Color green. - g addFunction: [ :x | x div: d ] color: Color red. - g openInWorld' -" -" -Compiler evaluate: ' - | g d | - d _ -1. - Feature require: ''Morphic-Widgets-Extras''. - g _ FunctionGraphMorph new. - g domain: (-4 to: 4). - g addFunction: [ :x | x mod: d ] color: Color green. - g addFunction: [ :x | x div: d ] color: Color red. - g openInWorld' -" -! ! -!Number methodsFor: 'arithmetic' stamp: 'jmv 5/18/2020 15:08:09' prior: 50510777! - rem: divisor - "Modulo operation. Remainder of the integer division #quo: (division with truncation towards zero). - Answer a Number with the same sign as dividend (i.e., self). - (9 rem: 4) = 1. - (-9 rem: 4) = -1. - (0.9 rem: 0.4) = 0.1. - See http://en.wikipedia.org/wiki/Modulo_operation - See #\\, #rem: and #mod: - See detailed discussion at http://mathforum.org/library/drmath/view/52343.html - " - - ^self - ((self quo: divisor) * divisor) - - "Evaluate the following:" -" -Compiler evaluate: ' - | g d | - d _ 1. - Feature require: ''Morphic-Widgets-Extras''. - g _ FunctionGraphMorph new. - g domain: (-4 to: 4). - g addFunction: [ :x | x rem: d ] color: Color green. - g addFunction: [ :x | x quo: d ] color: Color red. - g openInWorld' -" -" -Compiler evaluate: ' - | g d | - d _ -1. - Feature require: ''Morphic-Widgets-Extras''. - g _ FunctionGraphMorph new. - g domain: (-4 to: 4). - g addFunction: [ :x | x rem: d ] color: Color green. - g addFunction: [ :x | x quo: d ] color: Color red. - g openInWorld' -"! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 5/18/2020 15:08:33' prior: 50410399! - smoothIsAbsBelow: threshold - "A Function that is 1 at zero, 0 outside a bounded interval of size 4*threshold, and is continuous and differentiable. - - It is a 'smooth' version of an #isAbsBelow: function: x abs < threshold. - Useful when we need to 'count' stuff, but still want continuous and differentiable stuff." - " -Compiler evaluate: ' - | g | - Feature require: ''Morphic-Widgets-Extras''. - g _ FunctionGraphMorph new. - g domain: (-4 to: 4). - g addFunction: [ :x | x abs < Float halfPi ifTrue: [1] ifFalse:[0] ] color: Color brown. - g addFunction: [ :x | x smoothIsAbsBelow: Float halfPi ] color: Color red. - (g embeddedInMorphicWindowLabeled: ''graph'') openInWorld' - " - | scaled | - scaled _ self / threshold. - ^ scaled abs < 2 ifTrue: [ (scaled * Float halfPi) cos + 1.0 * 0.5 ] ifFalse: [ 0 ]! ! -!Float methodsFor: 'mathematical functions' stamp: 'jmv 5/18/2020 15:08:52' prior: 50467985! - smoothStep - "A Function that is - x <= -1 -> 1 - -1 < x < 1 -> smooth differentiable transition from 1 to 0 - 1 <= x -> 0 - - It is a 'smooth' version of an #negative - Has countless applications. For example in image and signal processing, but also in other fields." - " -Compiler evaluate: ' - | g | - Feature require: ''Morphic-Widgets-Extras''. - g _ FunctionGraphMorph new. - g domain: (-4 to: 4). - g addFunction: [ :x | x abs < 1 ifTrue: [1] ifFalse:[0] ] color: Color brown. - g addFunction: [ :x | x smoothStep ] color: Color red. - (g embeddedInMorphicWindowLabeled: ''graph'') openInWorld' - " - self isNaN ifTrue: [ ^self ]. - self > -1 ifFalse: [ ^ 1 ]. - 1 > self ifFalse: [ ^ 0 ]. - ^ (self +2 * Float halfPi) sin * 0.5 + 0.5! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4148-FixBrokenExamplesInComments-JuanVuletich-2020May18-15h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4148] on 18 May 2020 at 5:29:26 pm'! -!SequenceableCollection methodsFor: 'accessing' stamp: 'sqr 5/17/2020 00:15:12'! - head: anInteger - "Answer the first anInteger objects in the receiver, subject to availability" - - ^self first: (anInteger min: self size)! ! -!SequenceableCollection methodsFor: 'accessing' stamp: 'sqr 5/17/2020 00:15:23'! - tail: anInteger - "Answer the last anInteger objects in the receiver, subject to availability" - - ^self last: (anInteger min: self size)! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4149-head-tail-AndresValloud-2020May18-17h28m-sqr.001.cs.st----! - -'From Cuis 5.0 [latest update: #4149] on 20 May 2020 at 3:25:56 pm'! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 5/20/2020 15:18:06' prior: 50494840 overrides: 50463524! - drawString: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | p1 font | - "Don't waste any time if NOP" - lastIndex = 0 ifTrue: [ - ^nil ]. - - p1 _ (currentTransformation transform: aPoint rounded) rounded. - engine colorMap: nil. - font _ fontOrNil ifNil: [ AbstractFont default ]. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: aColor! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4150-TrueTypeFix-JuanVuletich-2020May20-15h25m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4145] on 17 May 2020 at 9:11:22 am'! -!BlockClosure methodsFor: 'evaluating' stamp: 'jmv 5/16/2020 21:40:20'! - microsecondsToRun - "Answer the number of microseconds taken to execute this block." - - ^ Time microsecondsToRun: self -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4151-microsecondsToRun-JuanVuletich-2020May17-09h08m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4151] on 21 May 2020 at 2:29:11 pm'! -!Parser methodsFor: 'expression types' stamp: 'jmv 5/21/2020 14:12:42'! - method: noPattern context: ctxt - " pattern [ | temporaries ] block => MethodNode." - - | sap block primitives tempsDeclarationNode messageComment methodNode | - - sap := self pattern: noPattern inContext: ctxt. - "sap={selector, arguments, precedence}" - self properties selector: (sap at: 1). - encoder selector: (sap at: 1). - (sap at: 2) do: [:argNode | argNode beMethodArg]. - - noPattern ifFalse: [self pragmaSequence]. - tempsDeclarationNode := self temporaries. - messageComment := currentComment. - currentComment := nil. - noPattern ifFalse: [self pragmaSequence]. - primitives := self pragmaPrimitives. - - self statements: #() innerBlock: noPattern. - block := parseNode. - noPattern - ifTrue: [block returnLast] - ifFalse: [block returnSelfIfNoOther: encoder]. - hereType == #doIt ifFalse: [^self expected: 'Nothing more']. - - methodNode := self newMethodNode comment: messageComment. - methodNode - selector: (sap at: 1) - arguments: (sap at: 2) - precedence: (sap at: 3) - temporariesDeclaration: tempsDeclarationNode - block: block - encoder: encoder - primitive: primitives - properties: properties - selectorKeywordsRanges: (sap at: 4). - - self interactive ifTrue: [ self performInteractiveChecks: methodNode ]. - - ^methodNode! ! -!Parser methodsFor: 'public access' stamp: 'jmv 5/21/2020 14:13:11'! - parse: sourceStream class: class category: aCategory noPattern: noPattern context: aContext notifying: aRequestor ifFail: aBlock - - "Answer a MethodNode for the argument, sourceStream, that is the root of - a parse tree. Parsing is done with respect to the argument, class, to find - instance, class, and pool variables; and with respect to the argument, - ctxt, to find temporary variables. Errors in parsing are reported to the - argument, req, if not nil; otherwise aBlock is evaluated. The argument - noPattern is a Boolean that is true if the the sourceStream does not - contain a method header (i.e., for DoIts)." - - | methNode repeatNeeded myStream sourceCode startPosition | - - category _ aCategory. - myStream _ sourceStream. - [ - repeatNeeded _ false. - startPosition _ myStream position. - sourceCode _ myStream upToEnd. - myStream position: startPosition. - self encoder init: class context: aContext notifying: self. - self init: myStream notifying: aRequestor failBlock: [^ aBlock value ]. - doitFlag _ noPattern. - failBlock _ aBlock. - [ methNode _ self method: noPattern context: aContext ] - on: ReparseAfterSourceEditing - do: [ :ex | - repeatNeeded _ true. - myStream _ ReadStream on: requestor text string ]. - repeatNeeded - ] whileTrue: [ encoder _ self encoder class new ]. - - methNode sourceText: sourceCode. - "See #xBacktick" - sentInLiterals do: [ :sym | encoder noteOptimizedSelector: sym ]. - - ^ methNode! ! -!Decompiler methodsFor: 'private' stamp: 'eem 9/6/2008 08:45' prior: 16832035! - blockScopeRefersOnlyOnceToTemp: offset - | nRefs byteCode extension scanner scan | - scanner := InstructionStream on: method. - nRefs := 0. - scan := offset <= 15 - ifTrue: - [byteCode := 16 + offset. - [:instr | - instr = byteCode ifTrue: - [nRefs := nRefs + 1]. - nRefs > 1]] - ifFalse: - [extension := 64 + offset. - [:instr | - (instr = 128 and: [scanner followingByte = extension]) ifTrue: - [nRefs := nRefs + 1]. - nRefs > 1]]. - self scanBlockScopeFor: pc from: method initialPC to: method endPC with: scan scanner: scanner. - ^nRefs = 1! ! -!Compiler methodsFor: 'private' stamp: 'jmv 5/21/2020 14:14:22' prior: 50445112! - translate: aStream noPattern: noPattern ifFail: failBlock - - ^self parser - ignoreBacktick: false; - parse: aStream - class: class - category: category - noPattern: noPattern - context: context - notifying: requestor - ifFail: [^failBlock value]! ! -!Parser methodsFor: 'public access' stamp: 'jmv 5/21/2020 14:13:27' prior: 50445171! - parse: sourceStream class: class noPattern: noPattern context: aContext notifying: aRequestor ifFail: aBlock - - ^self parse: sourceStream class: class category: nil noPattern: noPattern context: aContext notifying: aRequestor ifFail: aBlock ! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'jmv 5/21/2020 14:16:37' prior: 50452073! - compileSelectionFor: anObject in: evalContext ifFail: failBlock - - | methodNode method sourceCode compiler | - - sourceCode := self selectionDoItSourceCodeIn: evalContext. - - methodNode _ [ - compiler _ Compiler new. - compiler - compileNoPattern: sourceCode - in: anObject class - context: evalContext - notifying: self - ifFail: [ ^ failBlock value ]] - on: OutOfScopeNotification - do: [ :ex | ex resume: true ]. - - methodNode block returnLast. - method _ methodNode generate. - method methodNode: methodNode. - - ^{ #method -> method. #compiler -> compiler } asDictionary -! ! - -Parser removeSelector: #parse:class:category:noPattern:doIt:context:notifying:ifFail:! - -!methodRemoval: Parser #parse:class:category:noPattern:doIt:context:notifying:ifFail: stamp: 'Install-4152-ParserClanup-JuanVuletich-2020May21-14h10m-jmv.001.cs.st 5/26/2020 17:09:07'! -parse: sourceStream class: class category: aCategory noPattern: noPattern doIt: doIt context: aContext notifying: aRequestor ifFail: aBlock - - "Answer a MethodNode for the argument, sourceStream, that is the root of - a parse tree. Parsing is done with respect to the argument, class, to find - instance, class, and pool variables; and with respect to the argument, - ctxt, to find temporary variables. Errors in parsing are reported to the - argument, req, if not nil; otherwise aBlock is evaluated. The argument - noPattern is a Boolean that is true if the the sourceStream does not - contain a method header (i.e., for DoIts)." - - | methNode repeatNeeded myStream sourceCode startPosition | - - category _ aCategory. - myStream _ sourceStream. - [ - repeatNeeded _ false. - startPosition _ myStream position. - sourceCode _ myStream upToEnd. - myStream position: startPosition. - self encoder init: class context: aContext notifying: self. - self init: myStream notifying: aRequestor failBlock: [^ aBlock value ]. - doitFlag _ noPattern. - failBlock _ aBlock. - [ methNode _ self method: noPattern doIt: doIt context: aContext ] - on: ReparseAfterSourceEditing - do: [ :ex | - repeatNeeded _ true. - myStream _ ReadStream on: requestor text string ]. - repeatNeeded - ] whileTrue: [ encoder _ self encoder class new ]. - - methNode sourceText: sourceCode. - "See #xBacktick" - sentInLiterals do: [ :sym | encoder noteOptimizedSelector: sym ]. - - ^ methNode! - -Parser removeSelector: #method:doIt:context:! - -!methodRemoval: Parser #method:doIt:context: stamp: 'Install-4152-ParserClanup-JuanVuletich-2020May21-14h10m-jmv.001.cs.st 5/26/2020 17:09:07'! -method: noPattern doIt: doIt context: ctxt - " pattern [ | temporaries ] block => MethodNode." - - | sap block primitives tempsDeclarationNode messageComment methodNode | - - sap := self pattern: noPattern inContext: ctxt. - "sap={selector, arguments, precedence}" - self properties selector: (sap at: 1). - encoder selector: (sap at: 1). - (sap at: 2) do: [:argNode | argNode beMethodArg]. - - doIt ifFalse: [self pragmaSequence]. - tempsDeclarationNode := self temporaries. - messageComment := currentComment. - currentComment := nil. - doIt ifFalse: [self pragmaSequence]. - primitives := self pragmaPrimitives. - - self statements: #() innerBlock: doIt. - block := parseNode. - doIt - ifTrue: [block returnLast] - ifFalse: [block returnSelfIfNoOther: encoder]. - hereType == #doIt ifFalse: [^self expected: 'Nothing more']. - - methodNode := self newMethodNode comment: messageComment. - methodNode - selector: (sap at: 1) - arguments: (sap at: 2) - precedence: (sap at: 3) - temporariesDeclaration: tempsDeclarationNode - block: block - encoder: encoder - primitive: primitives - properties: properties - selectorKeywordsRanges: (sap at: 4). - - self interactive ifTrue: [ self performInteractiveChecks: methodNode ]. - - ^methodNode! - -Compiler removeSelector: #translate:noPattern:doIt:ifFail:! - -!methodRemoval: Compiler #translate:noPattern:doIt:ifFail: stamp: 'Install-4152-ParserClanup-JuanVuletich-2020May21-14h10m-jmv.001.cs.st 5/26/2020 17:09:07'! -translate: aStream noPattern: noPattern doIt: doIt ifFail: failBlock - - ^self parser - ignoreBacktick: false; - parse: aStream - class: class - category: category - noPattern: noPattern - doIt: doIt - context: context - notifying: requestor - ifFail: [^failBlock value]! - -Compiler removeSelector: #compileDoIt:in:context:notifying:ifFail:! - -!methodRemoval: Compiler #compileDoIt:in:context:notifying:ifFail: stamp: 'Install-4152-ParserClanup-JuanVuletich-2020May21-14h10m-jmv.001.cs.st 5/26/2020 17:09:07'! -compileDoIt: textOrStream in: aClass context: aContext notifying: aRequestor ifFail: failBlock - "Similar to #compile:in:notifying:ifFail:, but the compiled code is - expected to be a do-it expression, with no message pattern." - - self from: textOrStream - class: aClass - context: aContext - notifying: aRequestor. - ^self - translate: sourceStream - noPattern: false - doIt: true - ifFail: failBlock! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4152-ParserClanup-JuanVuletich-2020May21-14h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4152] on 21 May 2020 at 2:41:16 pm'! -!Character class methodsFor: 'class initialization' stamp: 'len 5/21/2020 08:23:36'! - blackboardLetters - "Answer the 'blackboard bold' or 'double struck' letters included in our font within the ASCII range. - These are considered uppercase letters and can be used as identifiers (variable names, keyword or unary messages, etc)." - ^ '‚ƒ„…†‡'! ! -!Character class methodsFor: 'class initialization' stamp: 'len 5/21/2020 08:24:19'! - greekLowercaseLetters - "Answer the lowercase greek letters included in our font within the ASCII range. - These are considered lowercase letters and can be used as identifiers (variable names, keyword or unary messages, etc)." - ^ 'ˆ‰Š‹ŒŽµ'! ! -!Character class methodsFor: 'class initialization' stamp: 'len 5/21/2020 08:24:46'! - greekUppercaseLetters - "Answer the uppercase greek letters included in our font within the ASCII range. - These are considered uppercase letters and can be used as identifiers (variable names, keyword or unary messages, etc)." - ^ '–—˜'! ! -!Character class methodsFor: 'constants' stamp: 'len 5/21/2020 08:26:58'! - namedCharactersTable - "Table of named characters that we can enter in an editor using \name. - Please keep the names short and try to follow the naming convention used in LaTeX." - ^ #((left $) (right $) (up $) (down $) (oplus $) (otimes $‘) (times $×) (div $÷) #(circ $’) (dot $·) (bullet $“) (diamond $”) (star $•) (alpha $ˆ) (beta $‰) (gamma $Š) (delta $‹) (epsilon $Œ) (lambda $) (mu $µ) (pi $Ž) (zeta $) (Delta $–) (Gamma $—) (Omega $˜) (N $‚) (Z $ƒ) (Q $„) (R $…) (C $†) (P $‡) (infty $€) (aleph $) (sqrt $Ÿ) (partial $ž) (degree $°))! ! -!SmalltalkEditor methodsFor: 'typing/selecting keys' stamp: 'len 5/21/2020 06:41:21' overrides: 16836703! - normalCharacter: aKeyboardEvent - "A nonspecial character is to be added to the stream of characters." - - | stopIndex startIndex string key | - aKeyboardEvent keyCharacter isLetter ifTrue: [^ super normalCharacter: aKeyboardEvent]. - "Allow to enter named (otherwise untypable) characters like the alpha greek letter as \alpha." - string _ self privateCurrentString. - stopIndex _ self pointIndex - 1. - (stopIndex between: 2 and: string size) - ifFalse: [^ super normalCharacter: aKeyboardEvent]. - startIndex _ stopIndex. - "Look backwards and find a character that is not a letter (we want to find '\' just a few characters behind):" - [startIndex > 0 and: [stopIndex - startIndex < 7 and: [(string at: startIndex) isLetter]]] whileTrue: [startIndex _ startIndex - 1]. - (startIndex > 0 and: [(string at: startIndex) = $\]) - ifFalse: [^ super normalCharacter: aKeyboardEvent]. - key _ string copyFrom: startIndex+1 to: stopIndex. - (Character namedCharactersTable detect: [:one| key = one first] ifNone: []) - ifNotNil: [:aPair| self selectFrom: startIndex to: stopIndex; replaceSelectionWith: aPair second asString]. - ^ super normalCharacter: aKeyboardEvent! ! -!Character class methodsFor: 'class initialization' stamp: 'len 5/21/2020 06:35:42' prior: 50375727! - initializeLookupTables - LowercaseMappingTable _ Array new: 256. - LowercaseTruthTable _ Array new: 256. - UppercaseMappingTable _ Array new: 256. - UppercaseTruthTable _ Array new: 256. - LetterTruthTable _ Array new: 256. - UnaccentedTable _ ByteArray new: 256. - 0 - to: 255 - do: [ :idx | | char | - "Default to an identity mapping with a false truth mapping" - char _ self numericValue: idx. - LowercaseMappingTable - at: idx + 1 - put: char. - LowercaseTruthTable - at: idx + 1 - put: false. - UppercaseMappingTable - at: idx + 1 - put: char. - UppercaseTruthTable - at: idx + 1 - put: false. - LetterTruthTable - at: idx + 1 - put: false. - UnaccentedTable at: idx + 1 put: idx]. - "Now override as needed" - Character uppercaseLowercaseAndUnaccentedLetters do: [ :group | | uppercase lowercase | - group size > 1 - ifTrue: [ | lowercaseChar uppercaseChar | - uppercase _ group first numericValue. - lowercase _ group second numericValue. - lowercaseChar _ self numericValue: lowercase. - uppercaseChar _ self numericValue: uppercase. - LowercaseMappingTable - at: lowercase + 1 - put: lowercaseChar. - LowercaseMappingTable - at: uppercase + 1 - put: lowercaseChar. - LowercaseTruthTable - at: lowercase + 1 - put: true. - LetterTruthTable - at: lowercase + 1 - put: true. - UppercaseMappingTable - at: lowercase + 1 - put: uppercaseChar. - UppercaseMappingTable - at: uppercase + 1 - put: uppercaseChar. - UppercaseTruthTable - at: uppercase + 1 - put: true. - LetterTruthTable - at: uppercase + 1 - put: true. - group size > 2 - ifTrue: [|unaccentedUppercase unaccentedLowercase| - unaccentedUppercase _ group third numericValue. - unaccentedLowercase _ group fourth numericValue. - UnaccentedTable at: uppercase+1 put: unaccentedUppercase. - UnaccentedTable at: lowercase+1 put: unaccentedLowercase]] - ifFalse: [ | lowercaseChar | - lowercase _ group first numericValue. - lowercaseChar _ self numericValue: lowercase. - LowercaseMappingTable - at: lowercase + 1 - put: lowercaseChar. - UppercaseMappingTable - at: lowercase + 1 - put: lowercaseChar. - LowercaseTruthTable - at: lowercase + 1 - put: true. - UppercaseTruthTable - at: lowercase + 1 - put: false. - LetterTruthTable - at: lowercase + 1 - put: true ]]. - Character greekLowercaseLetters do: [:each| - LowercaseTruthTable at: each numericValue + 1 put: true. - LetterTruthTable at: each numericValue + 1 put: true]. - Character greekUppercaseLetters do: [:each| - LowercaseTruthTable at: each numericValue + 1 put: true. - LetterTruthTable at: each numericValue + 1 put: true]. - Character blackboardLetters do: [:each| - UppercaseTruthTable at: each numericValue + 1 put: true. - LetterTruthTable at: each numericValue + 1 put: true]! ! -!Character class methodsFor: 'class initialization' stamp: 'len 5/20/2020 17:34:43' prior: 50495562! - initializeUnicodeCodePoints - " - Character initializeUnicodeCodePoints - String streamContents: [ :strm | 28 to: 255 do: [ :i | strm nextPut: (Character numericValue: i) ]] - " - - "Initialize the table of Unicode code points" - UnicodeCodePoints _ Array new: 256. - 0 to: 255 do: [ :code | - UnicodeCodePoints at: code + 1 put: code ]. - - "Arrows" - UnicodeCodePoints at: 28+1 put: 8592. "left arrow" - UnicodeCodePoints at: 29+1 put: 8594. "right arrow" - UnicodeCodePoints at: 30+1 put: 8593. "up arrow" - UnicodeCodePoints at: 31+1 put: 8595. "down arrow" - - "The following codes are different in ISO 8859-15 from those in ISO 8859-1, - so the character code is not equal to the Unicode code point" - UnicodeCodePoints at: 16rA4+1 put: 16r20AC. "euro sign" - UnicodeCodePoints at: 16rA6+1 put: 16r160. "latin capital letter S with caron" - UnicodeCodePoints at: 16rA8+1 put: 16r161. "latin small letter s with caron" - UnicodeCodePoints at: 16rB4+1 put: 16r17D. "latin capital letter Z with caron" - UnicodeCodePoints at: 16rB8+1 put: 16r17E. "latin small letter z with caron" - UnicodeCodePoints at: 16rBC+1 put: 16r152. "latin capital ligature OE" - UnicodeCodePoints at: 16rBD+1 put: 16r153. "latin small ligature oe" - UnicodeCodePoints at: 16rBE+1 put: 16r178. "latin capital letter Y with diaeresis" - - - UnicodeCodePoints at: 16r80+1 put: 16r221E. "INFINITY" - UnicodeCodePoints at: 16r81+1 put: 16r2135. "ALEF SYMBOL" - UnicodeCodePoints at: 16r82+1 put: 16r2115. "DOUBLE-STRUCK CAPITAL N" - UnicodeCodePoints at: 16r83+1 put: 16r2124. "DOUBLE-STRUCK CAPITAL Z" - UnicodeCodePoints at: 16r84+1 put: 16r211A. "DOUBLE-STRUCK CAPITAL Q" - UnicodeCodePoints at: 16r85+1 put: 16r211D. "DOUBLE-STRUCK CAPITAL R" - UnicodeCodePoints at: 16r86+1 put: 16r2102. "DOUBLE-STRUCK CAPITAL C" - UnicodeCodePoints at: 16r87+1 put: 16r2119. "DOUBLE-STRUCK CAPITAL P" - UnicodeCodePoints at: 16r88+1 put: 16r03B1. "alpha" - UnicodeCodePoints at: 16r89+1 put: 16r03B2. "beta" - UnicodeCodePoints at: 16r8A+1 put: 16r03B3. "gamma" - UnicodeCodePoints at: 16r8B+1 put: 16r03B4. "delta" - UnicodeCodePoints at: 16r8C+1 put: 16r03B5. "epsilon" - UnicodeCodePoints at: 16r8D+1 put: 16r03BB. "lambda" - UnicodeCodePoints at: 16r8E+1 put: 16r03C0. "pi" - UnicodeCodePoints at: 16r8F+1 put: 16r03B6. "zeta" - UnicodeCodePoints at: 16r90+1 put: 16r2295. "OPLUS" - UnicodeCodePoints at: 16r91+1 put: 16r2297. "OTIMES" - UnicodeCodePoints at: 16r92+1 put: 16r2218. "RING OPERATOR (circ)" - UnicodeCodePoints at: 16r93+1 put: 16r2219. "BULLET OPERATOR" - UnicodeCodePoints at: 16r94+1 put: 16r22C4. "DIAMOND OPERATOR" - UnicodeCodePoints at: 16r95+1 put: 16r22C6. "STAR OPERATOR" - UnicodeCodePoints at: 16r96+1 put: 16r0394. "Delta" - UnicodeCodePoints at: 16r97+1 put: 16r0393. "Gamma" - UnicodeCodePoints at: 16r98+1 put: 16r03A9. "Omega" - UnicodeCodePoints at: 16r99+1 put: 16r21A0. "SURJECTIVE ARROW" - UnicodeCodePoints at: 16r9A+1 put: 16r21A3. "INJECTIVE ARROW" - UnicodeCodePoints at: 16r9B+1 put: 16r2194. "BIJECTIVE ARROW" - UnicodeCodePoints at: 16r9C+1 put: 16r21AA. "INCLUSION ARROW" - UnicodeCodePoints at: 16r9D+1 put: 16r21A6. "MAPPING ARROW" - UnicodeCodePoints at: 16r9E+1 put: 16r2202. "PARTIAL DIFFERENTIAL" - UnicodeCodePoints at: 16r9F+1 put: 16r221A. "SQUARE ROOT" -! ! -!Scanner class methodsFor: 'cached class state' stamp: 'len 5/21/2020 08:07:57' prior: 50422125! - initTypeTable - | newTable | - newTable := Array new: 256 withAll: #xIllegal. "default" - newTable atAll: #(9 10 12 13 32 ) put: #xDelimiter. "tab lf ff cr space" - - 1 to: 255 - do: [:index | - (Character numericValue: index) isValidInIdentifiers - ifTrue: [ - "Digits and $_ are overwritten later" - newTable at: index put: #xLetter ]]. - - newTable atAll: ($0 numericValue to: $9 numericValue) put: #xDigit. - newTable atAll: '¡!!%&+-*/\·×÷¬­¯,<=>«»¿?@~‘’“”•žŸ™š›œ' asByteArray put: #xBinary. - newTable at: self doItCharacterValue put: #doIt. - newTable at: $" numericValue put: #xDoubleQuote. - newTable at: $# numericValue put: #xLitQuote. - newTable at: $$ numericValue put: #xDollar. - newTable at: $' numericValue put: #xSingleQuote. - newTable at: $` numericValue put: #xBacktick. - newTable at: $: numericValue put: #xColon. - newTable at: $( numericValue put: #leftParenthesis. - newTable at: $) numericValue put: #rightParenthesis. - newTable at: $. numericValue put: #period. - newTable at: $; numericValue put: #semicolon. - newTable at: $[ numericValue put: #leftBracket. - newTable at: $] numericValue put: #rightBracket. - newTable at: ${ numericValue put: #leftBrace. - newTable at: $} numericValue put: #rightBrace. - newTable at: $^ numericValue put: #upArrow. - newTable at: $_ numericValue put: #xUnderscore. - newTable at: $| numericValue put: #verticalBar. - TypeTable := newTable "bon voyage!!" - - " - Scanner initTypeTable - "! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Character initialize. -Scanner initialize.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4153-MathSymbolsUpdate-LucianoEstebanNotarfrancesco-2020May21-14h39m-len.001.cs.st----! - -'From Cuis 5.0 [latest update: #4153] on 21 May 2020 at 2:43:56 pm'! - -Character class removeSelector: #aleph! - -!methodRemoval: Character class #aleph stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:09:07'! -aleph - " - Character aleph - " - ^ $‚! - -Character class removeSelector: #zeta! - -!methodRemoval: Character class #zeta stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:09:07'! -zeta - " - Character zeta - " - ^ $…! - -Character class removeSelector: #PP! - -!methodRemoval: Character class #PP stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:09:07'! -PP - " - Character PP - " - ^ $‹! - -Character class removeSelector: #QQ! - -!methodRemoval: Character class #QQ stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:09:07'! -QQ - " - Character QQ - " - ^ $Œ! - -Character class removeSelector: #circ! - -!methodRemoval: Character class #circ stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:09:07'! -circ - " - Character circ - " - ^ $•! - -Character class removeSelector: #div! - -!methodRemoval: Character class #div stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:09:07'! -div - " - Character div - " - ^ $÷! - -Character class removeSelector: #NN! - -!methodRemoval: Character class #NN stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:09:07'! -NN - " - Character NN - " - ^ $Š! - -Character class removeSelector: #pi! - -!methodRemoval: Character class #pi stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:09:07'! -pi - " - Character pi - " - ^ $ƒ! - -Character class removeSelector: #otimes! - -!methodRemoval: Character class #otimes stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:09:07'! -otimes - " - Character otimes - " - ^ $‘! - -Character class removeSelector: #FF! - -!methodRemoval: Character class #FF stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:09:07'! -FF - " - Character FF - " - ^ $! - -Character class removeSelector: #RR! - -!methodRemoval: Character class #RR stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:09:07'! -RR - " - Character RR - " - ^ $! - -Character class removeSelector: #infinity! - -!methodRemoval: Character class #infinity stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:09:07'! -infinity - " - Character infinity - " - ^ $! - -Character class removeSelector: #epsilon! - -!methodRemoval: Character class #epsilon stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:09:07'! -epsilon - " - Character epsilon - " - ^ $„! - -Character class removeSelector: #dot! - -!methodRemoval: Character class #dot stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:09:07'! -dot - " - Character dot - " - ^ $·! - -Character class removeSelector: #degree! - -!methodRemoval: Character class #degree stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:09:07'! -degree - " - Character degree - " - ^ $°! - -Character class removeSelector: #emptySet! - -!methodRemoval: Character class #emptySet stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:09:07'! -emptySet - " - Character emptySet - " - ^ $€! - -Character class removeSelector: #HH! - -!methodRemoval: Character class #HH stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:09:07'! -HH - " - Character HH - " - ^ $‰! - -Character class removeSelector: #sqrt! - -!methodRemoval: Character class #sqrt stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:09:07'! -sqrt - " - Character sqrt - " - ^ $Ÿ! - -Character class removeSelector: #ZZ! - -!methodRemoval: Character class #ZZ stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:09:07'! -ZZ - " - Character ZZ - " - ^ $Ž! - -Character class removeSelector: #CC! - -!methodRemoval: Character class #CC stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:09:07'! -CC - " - Character CC - " - ^ $ˆ! - -Character class removeSelector: #oplus! - -!methodRemoval: Character class #oplus stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:09:07'! -oplus - " - Character oplus - " - ^ $! - -Character class removeSelector: #times! - -!methodRemoval: Character class #times stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:09:07'! -times - " - Character times - " - ^ $×! - -Character class removeSelector: #bullet! - -!methodRemoval: Character class #bullet stamp: 'Install-4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st 5/26/2020 17:09:07'! -bullet - " - Character bullet - " - ^ $–! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4154-MathSymbolsUpdate-coda-LucianoEstebanNotarfrancesco-2020May21-14h43m-len.001.cs.st----! - -'From Cuis 5.0 [latest update: #4154] on 21 May 2020 at 3:21:23 pm'! -!LayoutMorph methodsFor: 'geometry' stamp: 'jmv 5/21/2020 15:12:52'! - desiredLayoutHeight - - | fixed proportional | - proportional _ 0. - fixed _ 0. - self submorphsToLayout do: [ :m | | ls | - ls _ m layoutSpec. - ls isProportionalHeight ifTrue: [ - proportional _ proportional max: ls fixedOrMinimumLayoutHeight / ls proportionalLayoutHeight ] - ifFalse: [ - fixed _ fixed + ls fixedOrMinimumLayoutHeight ]]. - ^fixed + proportional! ! -!LayoutMorph methodsFor: 'geometry' stamp: 'jmv 4/30/2020 17:13:46'! - desiredLayoutWidth - - | fixed proportional | - proportional _ 0. - fixed _ 0. - self submorphsToLayout do: [ :m | | ls | - ls _ m layoutSpec. - ls isProportionalWidth ifTrue: [ - proportional _ proportional max: ls fixedOrMinimumLayoutWidth / ls proportionalLayoutWidth ] - ifFalse: [ - fixed _ fixed + ls fixedOrMinimumLayoutWidth ]]. - ^fixed + proportional! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 5/21/2020 15:11:39'! - heightForComfortable: availableSpace - "Similar to #heightFor:. To be used when we know availableSpace is more than the minimum required to apply proportional layout and still get more than our minimum. See senders." - - ^proportionalHeight isNil - ifTrue: [fixedHeight ifNil: [morph morphHeight]] - ifFalse: [proportionalHeight * availableSpace]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 5/21/2020 15:12:30'! - proportionalLayoutHeight - - ^ proportionalHeight ifNil: [ 0 ]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 4/30/2020 17:01:00'! - widthForComfortable: availableSpace - "Similar to #widthFor:. To be used when we know availableSpace is more than the minimum required to apply proportional layout and still get more than our minimum. See senders." - - ^proportionalWidth isNil - ifTrue: [fixedWidth ifNil: [morph morphWidth]] - ifFalse: [proportionalWidth * availableSpace]! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 4/30/2020 17:13:33' prior: 50499716! - layoutSubmorphsHorizontallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - | xSep ySep usableWidth normalizationFactor - fractionalWidths integerWidths theLeft usableHeight boundsTop boundsRight theTop minWidth submorphsToLayout - nextMorph ht wd ls theRight boundsBottom theBottom alternativeWidths count diff i desiredLayoutWidth | - - boundsForLayout extent > `2@2` "self minimumExtent" - ifFalse: [ ^self ]. "Too small. Don't bother!!" - - submorphsToLayout := self submorphsToLayout. - xSep := self xSeparation. - ySep := self ySeparation. - usableWidth := boundsForLayout width - ((submorphsToLayout size + 1) * xSep). - - desiredLayoutWidth _ self desiredLayoutWidth. - normalizationFactor := self proportionalWidthNormalizationFactor. - usableWidth > desiredLayoutWidth - ifTrue: [ - fractionalWidths := submorphsToLayout collect: [ :m | m layoutSpec widthForComfortable: usableWidth*normalizationFactor ]] - ifFalse: [ | sumOfFixedOrMinimum availableForPropWidth | - sumOfFixedOrMinimum := submorphsToLayout sum: [ :m | m minimumLayoutExtent x max: m layoutSpec fixedOrMinimumLayoutWidth ]. - availableForPropWidth := usableWidth - sumOfFixedOrMinimum max: 0. - fractionalWidths := submorphsToLayout collect: [ :m | m layoutSpec widthFor: availableForPropWidth * normalizationFactor ]]. - "Compute integer widths, mostly rounding but with occasional #floor or #ceiling as needed to keep sum" - integerWidths _ fractionalWidths collect: [ :w | w rounded ]. - diff _ integerWidths sum - fractionalWidths sum rounded. - alternativeWidths _ diff > 0 ifTrue: [ fractionalWidths collect: [ :w | w floor ]] ifFalse: [ fractionalWidths collect: [ :w | w ceiling ]]. - count _ diff abs. - i _ 1. - [ count > 0] whileTrue: [ - (integerWidths at: i) = (alternativeWidths at: i) ifFalse: [ - integerWidths at: i put: (alternativeWidths at: i). - count _ count -1 ]. - i _ i + 1 ]. - minWidth := integerWidths sum. - theLeft := ((usableWidth - minWidth) * (padding ifNil: [0]) max: 0) + boundsForLayout left + xSep. - usableHeight := boundsForLayout height - (ySep * 2) max: 0. - boundsTop := boundsForLayout top + ySep. - boundsRight := boundsForLayout right - xSep. - boundsBottom := boundsForLayout bottom - ySep. - - submorphsToLayout size to: 1 by: -1 do: [ :index | - nextMorph := submorphsToLayout at: index. - "major direction" - wd := integerWidths at: index. - "minor direction" - ls := nextMorph layoutSpec. - ht := (ls heightFor: usableHeight) min: usableHeight. - theTop := ((usableHeight - ht) * ls minorDirectionPadding) floor + boundsTop. - theBottom := (theTop + ht) ceiling min: boundsBottom. - theRight := (theLeft + (wd min: minWidth)) "ceiling "min: boundsRight. - "Set bounds and adjust major direction for next step" - self flag: #jmvVer2. "should extent be set in m's coordinate system? what if its scale is not 1?" - ls usesMorphExtent - ifTrue: [ - nextMorph morphPosition: theLeft floor @ theTop floor ] - ifFalse: [ - nextMorph morphPosition: theLeft floor @ theTop floor extent: theRight - theLeft @ (theBottom - theTop) ]. - theLeft := theRight + xSep - ]! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 5/21/2020 15:19:28' prior: 50499810! - layoutSubmorphsVerticallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - | xSep ySep usableHeight normalizationFactor - fractionalHeights integerHeights theTop usableWidth boundsLeft boundsBottom theLeft minHeight submorphsToLayout - nextMorph ht wd ls theBottom boundsRight theRight alternativeHeights count diff i desiredLayoutHeight | - - boundsForLayout extent > `2@2` "self minimumExtent" - ifFalse: [ ^self ]. "Too small. Don't bother!!" - - submorphsToLayout := self submorphsToLayout. - xSep := self xSeparation. - ySep := self ySeparation. - usableHeight := boundsForLayout height - ((submorphsToLayout size + 1) * ySep). - - desiredLayoutHeight _ self desiredLayoutHeight. - normalizationFactor := self proportionalHeightNormalizationFactor. - usableHeight > desiredLayoutHeight - ifTrue: [ - fractionalHeights := submorphsToLayout collect: [ :m | m layoutSpec heightForComfortable: usableHeight*normalizationFactor ]] - ifFalse: [ | sumOfFixedOrMinimum availableForPropHeight | - sumOfFixedOrMinimum := submorphsToLayout sum: [ :m | m minimumLayoutExtent y max: m layoutSpec fixedOrMinimumLayoutHeight ]. - availableForPropHeight := usableHeight - sumOfFixedOrMinimum max: 0. - fractionalHeights := submorphsToLayout collect: [ :m | m layoutSpec heightFor: availableForPropHeight * normalizationFactor ]]. - - "Compute integer widths, mostly rounding but with occasional #floor or #ceiling as needed to keep sum" - integerHeights _ fractionalHeights collect: [ :w | w rounded ]. - diff _ integerHeights sum - fractionalHeights sum rounded. - alternativeHeights _ diff > 0 ifTrue: [ fractionalHeights collect: [ :w | w floor ]] ifFalse: [ fractionalHeights collect: [ :w | w ceiling ]]. - count _ diff abs. - i _ 1. - [ count > 0] whileTrue: [ - (integerHeights at: i) = (alternativeHeights at: i) ifFalse: [ - integerHeights at: i put: (alternativeHeights at: i). - count _ count -1 ]. - i _ i + 1 ]. - minHeight := integerHeights sum. - theTop := ((usableHeight - minHeight) * (padding ifNil: [0]) max: 0) + boundsForLayout top + ySep. - usableWidth := boundsForLayout width - (xSep * 2) max: 0. - boundsLeft := boundsForLayout left + xSep. - boundsBottom := boundsForLayout bottom - ySep. - boundsRight := boundsForLayout right - xSep. - - submorphsToLayout size to: 1 by: -1 do: [ :index | - nextMorph := submorphsToLayout at: index. - "major direction" - ht := integerHeights at: index. - "minor direction" - ls := nextMorph layoutSpec. - wd := (ls widthFor: usableWidth) min: usableWidth. - theLeft := ((usableWidth - wd) * ls minorDirectionPadding) floor + boundsLeft. - theRight := (theLeft + wd) ceiling min: boundsRight. - theBottom := (theTop + (ht min: minHeight)) "ceiling" min: boundsBottom. - "Set bounds and adjust major direction for next step" - self flag: #jmvVer2. "should extent be set in m's coordinate system? what if its scale is not 1?" - ls usesMorphExtent - ifTrue: [ - nextMorph morphPosition: theLeft floor @ theTop floor ] - ifFalse: [ - nextMorph morphPosition: theLeft floor @ theTop floor extent: theRight - theLeft @ (theBottom - theTop) ]. - theTop := theBottom + ySep - ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4155-ProportionalLayoutEnh-JuanVuletich-2020May21-15h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4133] on 9 May 2020 at 4:10:58 pm'! - -"Change Set: 4134-CuisCore-AuthorName-2020May04-19h23m -Date: 9 May 2020 -Author: Nahuel Garbezza - -Main changes: - -Introduce the SourceCodeInterval class as an especialization of Interval, capable of dealing with source code transformations. Start to use SourceCodeInterval in the source ranges reported by the Parser, and on the intervals created on refactorings. This helped us to reduce utilitary methods related source code on the Refactoring and ParseNode classes. - -Changes on refactorings: - -* [extract temporary] allow to extract entire statements without introducing an unnecessary extra statement -* [extract temporary] do not allow the user to extract on a smalltalk editor that does not contain a method -* [extract temporary] change the #apply message to return the updated source code -* [extract method] allow to extract expressions with multiple levels of parentheses and spaces between them"! - -Interval subclass: #SourceCodeInterval - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #SourceCodeInterval category: #'Compiler-Kernel' stamp: 'Install-4156-SourceCodeRange-NahuelGarbezza-2020May04-19h23m-RNG.001.cs.st 5/26/2020 17:09:07'! -Interval subclass: #SourceCodeInterval - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! -!SourceCodeInterval commentStamp: 'RNG 5/8/2020 22:10:02' prior: 0! - I represent a special case of interval, I refer to source code intervals. There are two main users of me: - -* The debugger (to display which is the current piece of code being debugged) -* Refactorings (to select code for refactoring, validating against other intervals and rewriting code)! -!Interval methodsFor: 'converting' stamp: 'RNG 5/8/2020 20:59:03'! - asSourceCodeInterval - - ^ SourceCodeInterval from: start to: stop! ! -!SourceCodeInterval methodsFor: 'source code' stamp: 'RNG 5/9/2020 15:41:07'! - expandToMatchExpressionOn: aSourceCode - "takes a source code and if the source range references an expression - that can be expanded and still is valid, it returns the source range - 'grown'. Examples: (*3 + 4*) to *(3 + 4)*; `*3 + 4*` to *`3 + 4`*" - - | firstChar lastChar | - firstChar _ aSourceCode at: start - 1 ifAbsent: [ nil ]. - lastChar _ aSourceCode at: stop + 1 ifAbsent: [ nil ]. - ^ (self canBeExpandedStartingWith: firstChar endingWith: lastChar) - ifTrue: [ (self expandBy: 1) expandToMatchExpressionOn: aSourceCode ] - ifFalse: [ self ]! ! -!SourceCodeInterval methodsFor: 'source code' stamp: 'RNG 5/8/2020 21:42:20'! - trimToMatchExpressionOn: aSourceCode - - | startOffset endOffset initialChar endingChar shouldTrimStart shouldTrimEnd shouldTrimBoth | - startOffset := 0. - endOffset := 0. - initialChar := aSourceCode at: start ifAbsent: [ nil ]. - endingChar := aSourceCode at: stop ifAbsent: [ nil ]. - shouldTrimBoth := initialChar = $( and: [ endingChar = $) ]. - shouldTrimStart := self canBeTrimmed: initialChar. - shouldTrimEnd := self canBeTrimmed: endingChar. - (shouldTrimBoth or: [ shouldTrimStart ]) ifTrue: [ startOffset := 1 ]. - (shouldTrimBoth or: [ shouldTrimEnd ]) ifTrue: [ endOffset := 1 ]. - ^ (shouldTrimBoth or: [ shouldTrimStart ] or: [ shouldTrimEnd ]) - ifTrue: [ (self trimLeft: startOffset right: endOffset) trimToMatchExpressionOn: aSourceCode ] - ifFalse: [ self ]! ! -!SourceCodeInterval methodsFor: 'private - source code' stamp: 'RNG 5/9/2020 15:39:55'! - canBeExpandedStartingWith: firstChar endingWith: lastChar - - ^ (firstChar = $( and: [ lastChar = $) ]) or: [ firstChar = $` and: [ lastChar = $` ] ]! ! -!SourceCodeInterval methodsFor: 'private - source code' stamp: 'RNG 5/8/2020 21:30:59'! - canBeTrimmed: initialChar - - ^ initialChar notNil and: [ initialChar isSeparator or: [ initialChar = $. ] ]! ! -!SourceCodeInterval methodsFor: 'private - source code' stamp: 'RNG 5/9/2020 15:38:43'! - expandBy: quantity - - ^ (start - quantity to: stop + quantity) asSourceCodeInterval! ! -!SourceCodeInterval methodsFor: 'private - source code' stamp: 'RNG 5/8/2020 21:41:42'! - trimLeft: startOffset right: endOffset - - ^ (start + startOffset to: stop - endOffset) asSourceCodeInterval! ! -!ParseNode methodsFor: 'source ranges' stamp: 'RNG 5/8/2020 21:59:21'! - expandRange: parentSourceRange basedOnChildRange: childSourceRange - - ^ ((parentSourceRange first min: childSourceRange first) to: parentSourceRange last) asSourceCodeInterval! ! -!MethodNode methodsFor: 'source mapping' stamp: 'RNG 5/6/2020 23:25:56'! - singleCompleteSourceRangeOf: requestedParseNode ifPresent: sourceRangePresentBlock ifAbsent: sourceRangeAbsentBlock - "Finds the source range associated with the requested parse node. - If it is present, evaluates sourceRangePresentBlock with the result. - Otherwise, it evaluates sourceRangeAbsentBlock. - Raises an error if the requested parse node has multiple source ranges" - - self completeSourceRangesDo: [ :parseNode :sourceRanges | - (parseNode equivalentTo: requestedParseNode) ifTrue: [ - sourceRanges size > 1 ifTrue: [ - self error: 'there are multiple source ranges for the parse node: ' , requestedParseNode printString ]. - ^ sourceRangePresentBlock value: sourceRanges first ] ]. - ^ sourceRangeAbsentBlock value! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 5/4/2020 19:29:08'! - addAssignmentToCurrentStatement - - self - insertAt: intervalToExtract first - newCodeWith: newVariableName , ' ' , self preferredAssignmentOperator , ' '! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 5/6/2020 23:20:14'! - extractingAnEntireStatement - - ^ self siblingStatementsOfTemporaryAssignment anySatisfy: [ :statement | - methodNodeToRefactor - singleCompleteSourceRangeOf: statement - ifPresent: [ :sourceRange | sourceRange = intervalToExtract ] - ifAbsent: [ false ] ]! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 5/6/2020 22:46:32'! - positionToInsertNewVariableDeclaration - - ^ (methodNodeToRefactor singleCompleteSourceRangeOf: parseNodeWithNewVariableScope temporariesDeclaration) last - 1! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 5/4/2020 19:32:43'! - resolveNewVariableAssignment - - self extractingAnEntireStatement - ifTrue: [ self addAssignmentToCurrentStatement ] - ifFalse: [ - self - replaceExtractedCodeWithNewTemporaryVariable; - writeAssignmentStatementOfNewTemporaryVariable ]! ! -!ParseNode methodsFor: 'source ranges' stamp: 'RNG 5/8/2020 21:59:47' prior: 50488513! - expandRange: aSourceRange basedOn: sourceRangesOfChildNode - - | intervals | - intervals := self consolidateAsCollection: sourceRangesOfChildNode. - intervals withIndexDo: [ :interval :index | - (interval first > aSourceRange first) ifTrue: [ - ^ self expandRange: aSourceRange basedOnChildRange: (intervals at: index - 1 ifAbsent: [ intervals last ]) ] ]. - ^ self expandRange: aSourceRange basedOnChildRange: intervals last! ! -!ParseNode methodsFor: 'source ranges' stamp: 'RNG 5/9/2020 15:41:07' prior: 50495113! -expandRanges: sourceRanges basedOn: allSourceRanges using: sourceCode - - ^ (self consolidateAsCollection: sourceRanges) - collect: [ :sourceRange | sourceRange expandToMatchExpressionOn: sourceCode ]! ! -!Encoder methodsFor: 'source mapping' stamp: 'RNG 5/8/2020 21:10:16' prior: 50408677! -addMultiRange: aRange for: aNode - - | ranges | - - "I'm using an OrderedCollection because ranges are added in order, while parsing the source code. - If this constrain is not hold, a SortedCollection should be used - Hernan" - ranges := sourceRanges at: aNode ifAbsentPut: [ OrderedCollection new ]. - ranges add: aRange asSourceCodeInterval. - - ^aNode ! ! -!Encoder methodsFor: 'source mapping' stamp: 'RNG 5/8/2020 21:10:23' prior: 16837644! - noteSourceRange: range forNode: node - - sourceRanges at: node put: range asSourceCodeInterval! ! -!BraceNode methodsFor: 'private' stamp: 'RNG 5/6/2020 23:50:26' prior: 50506461! - hasEquivalentElementsTo: aBraceNode - - elements size ~= aBraceNode elements size ifTrue: [ ^ false ]. - - elements with: aBraceNode elements do: [ :myElement :otherElement | - (myElement equivalentTo: otherElement) ifFalse: [ ^ false ] ]. - ^ true! ! -!CascadeNode methodsFor: 'testing' stamp: 'RNG 5/6/2020 23:51:24' prior: 50508655! - hasEquivalentMessagesWith: aCascadeNode - - messages size ~= aCascadeNode messages size ifTrue: [ ^ false ]. - - messages with: aCascadeNode messages do: [ :myMessage :otherNodeMessage | - (myMessage equivalentTo: otherNodeMessage) ifFalse: [ ^ false ] ]. - ^ true! ! -!CodeNode methodsFor: 'private' stamp: 'RNG 5/6/2020 23:52:46' prior: 50506480! - hasEquivalentArgumentsWith: aCodeNode - - self arguments size ~= aCodeNode arguments size ifTrue: [ ^ false ]. - - self arguments with: aCodeNode arguments do: [ :myArgument :otherCodeNodeArgument | - (myArgument equivalentTo: otherCodeNodeArgument) ifFalse: [ ^ false ] ]. - ^ true! ! -!BlockNode methodsFor: 'private' stamp: 'RNG 5/6/2020 23:54:27' prior: 50506515! - hasEquivalentStatementsWith: aBlockNode - - statements size ~= aBlockNode statements size ifTrue: [ ^ false ]. - - statements with: aBlockNode statements do: [ :myStatement :otherBlockNodeStatement | - (myStatement equivalentTo: otherBlockNodeStatement) ifFalse: [ ^ false ] ]. - ^ true! ! -!MethodNode methodsFor: 'source mapping' stamp: 'RNG 5/6/2020 23:24:10' prior: 50506525! - singleCompleteSourceRangeOf: requestedParseNode - "Returns the source range associated with the requested parse node. - Fails if there is no source range, or if there are multiple source ranges." - - self - singleCompleteSourceRangeOf: requestedParseNode - ifPresent: [ :sourceRange | ^ sourceRange ] - ifAbsent: [ self error: 'could not find source range for node: ' , requestedParseNode printString ]! ! -!MessageNode methodsFor: 'private' stamp: 'RNG 5/6/2020 23:53:18' prior: 50506574! - compare: myArguments with: othersArguments - - myArguments size ~= othersArguments size ifTrue: [ ^ false ]. - - myArguments with: othersArguments do: [ :myArgument :otherArgument | - (myArgument equivalentTo: otherArgument) ifFalse: [ ^ false ] ]. - ^ true! ! -!TemporariesDeclarationNode methodsFor: 'testing' stamp: 'RNG 5/6/2020 23:55:08' prior: 50506611! - declaresSameVariablesThan: aTemporariesDeclarationNode - - tempDeclarationNodes size ~= aTemporariesDeclarationNode temporaryDeclarationNodes size ifTrue: [ ^ false ]. - - tempDeclarationNodes with: aTemporariesDeclarationNode temporaryDeclarationNodes do: [ :myTempDeclaration :otherTempDeclaration | - (myTempDeclaration equivalentTo: otherTempDeclaration) ifFalse: [ ^ false ] ]. - ^ true! ! -!SmalltalkEditor methodsFor: 'extract to temporary' stamp: 'RNG 5/8/2020 21:30:47' prior: 50506650! - extractToTemporary - - "To prevent the refactoring to be evaluated on editors w/o methods like the workspace - Nahuel" - self hasValidCurrentCompiledMethod ifFalse: [ ^ nil ]. - - self ifSourceCodeRefactoringCanBeAppliedDo: [ - ExtractToTemporaryApplier createAndValueHandlingExceptions: [ - ExtractToTemporaryApplier - for: self selectionInterval asSourceCodeInterval - of: self codeProvider currentCompiledMethod ] ]! ! -!SmalltalkEditor methodsFor: 'extract method' stamp: 'RNG 5/8/2020 21:30:28' prior: 50507237! - extractMethod - - "To prevent the refactoring to be evaluated on editors w/o methods like the workspace - Nahuel" - self hasValidCurrentCompiledMethod ifFalse: [ ^ nil ]. - - self ifSourceCodeRefactoringCanBeAppliedDo: [ - ExtractMethodApplier createAndValueHandlingExceptions: [ - ExtractMethodApplier - for: self selectionInterval asSourceCodeInterval - of: self codeProvider currentCompiledMethod ] ]! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 5/8/2020 21:12:34' prior: 50489377! - intervalCoversCompleteAstNodes - - ^ (self trimmed: (initialNode value first to: finalNode value last) asSourceCodeInterval) = intervalToExtract! ! -!ExtractMethodExpressionValidation methodsFor: 'validation - private' stamp: 'RNG 5/8/2020 21:12:12' prior: 50507642! - trimmed: aSourceCodeInterval - - ^ aSourceCodeInterval trimToMatchExpressionOn: sourceCode! ! -!ExtractMethod class methodsFor: 'instance creation' stamp: 'RNG 5/8/2020 21:03:17' prior: 50507648! - fromInterval: anIntervalToExtract of: aMethodToExtractCodeFrom to: newMessage categorizedAs: aCategory - - | trimmedIntervalToExtract | - trimmedIntervalToExtract := anIntervalToExtract trimToMatchExpressionOn: aMethodToExtractCodeFrom sourceCode. - self - assert: newMessage selector canBeDefinedIn: aMethodToExtractCodeFrom methodClass; - assert: trimmedIntervalToExtract isValidIntervalOn: aMethodToExtractCodeFrom; - assert: newMessage hasValidParametersForExtracting: anIntervalToExtract from: aMethodToExtractCodeFrom methodNode. - - ^ self new - initializeFrom: trimmedIntervalToExtract - of: aMethodToExtractCodeFrom - to: newMessage - in: aCategory! ! -!ExtractToTemporary methodsFor: 'applying' stamp: 'RNG 5/9/2020 15:12:17' prior: 50506674 overrides: 50438485! - apply - - self - resolveNewVariableAssignment; - declareNewTemporaryVariable; - reflectSourceCodeChanges. - ^ updatedSourceCode! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 5/6/2020 22:46:41' prior: 50506701! - addNewTemporaryVariableToExistingDeclarationStatement - - self - insertAt: self positionToInsertNewVariableDeclaration - newCodeWith: ' ' , newVariableName! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 5/6/2020 23:28:33' prior: 50506808! - reflectSourceCodeChanges - - methodToRefactor methodClass - compile: updatedSourceCode - classified: methodToRefactor category! ! -!ExtractToTemporary methodsFor: 'private - applying steps ' stamp: 'RNG 5/6/2020 23:29:53' prior: 50506841! - statementNodeIncludingCodeToExtract - - ^ self siblingStatementsOfTemporaryAssignment detect: [ :statement | - methodNodeToRefactor - singleCompleteSourceRangeOf: statement - ifPresent: [ :sourceRange | sourceRange last >= intervalToExtract last ] - ifAbsent: [ false ] ]! ! -!ExtractToTemporary class methodsFor: 'instance creation' stamp: 'RNG 5/8/2020 21:04:28' prior: 50507673! - named: aNewVariable at: anIntervalToExtract from: aMethodToRefactor - - | trimmedNewVariable trimmedIntervalToExtract codeNodeForNewVariable methodNodeToRefactor | - - self assertCanApplyRefactoringOn: aMethodToRefactor at: anIntervalToExtract. - methodNodeToRefactor := aMethodToRefactor methodNode. - trimmedNewVariable := aNewVariable withBlanksTrimmed. - trimmedIntervalToExtract := anIntervalToExtract trimToMatchExpressionOn: aMethodToRefactor sourceCode. - codeNodeForNewVariable := self methodOrBlockNodeIncluding: anIntervalToExtract in: methodNodeToRefactor. - self newTemporaryPreconditionClass valueFor: trimmedNewVariable in: codeNodeForNewVariable of: methodNodeToRefactor. - - ^ self new - initializeNamed: trimmedNewVariable - extractingCodeAt: trimmedIntervalToExtract - from: aMethodToRefactor - declaringTempIn: codeNodeForNewVariable! ! -!ExtractToTemporary class methodsFor: 'preconditions' stamp: 'RNG 5/8/2020 21:04:18' prior: 50508780! - assertCanApplyRefactoringOn: aMethodToRefactor at: anIntervalToExtract - - | trimmedSourceCodeToExtract methodNodeToExtract sourceCodeToExtract trimmedIntervalToExtract originalSourceCode | - - self assert: anIntervalToExtract isValidIntervalOn: aMethodToRefactor. - originalSourceCode := aMethodToRefactor sourceCode. - sourceCodeToExtract := originalSourceCode copyFrom: anIntervalToExtract first to: anIntervalToExtract last. - trimmedSourceCodeToExtract := sourceCodeToExtract withBlanksTrimmed. - trimmedIntervalToExtract := anIntervalToExtract trimToMatchExpressionOn: originalSourceCode. - self assertSourceCodeIsNotEmpty: trimmedSourceCodeToExtract. - methodNodeToExtract := self tryToParse: trimmedSourceCodeToExtract on: aMethodToRefactor methodClass. - self - assertHasOneStatement: methodNodeToExtract; - assertIsNotReturn: trimmedSourceCodeToExtract; - assert: trimmedIntervalToExtract enclosesACompleteExpressionOn: aMethodToRefactor; - assert: trimmedIntervalToExtract enclosesAValidNodeOn: aMethodToRefactor! ! -!ExtractToTemporary class methodsFor: 'private - preconditions' stamp: 'RNG 5/8/2020 21:04:03' prior: 50507738! - anySourceRangeOf: aMethodToRefactor matches: anIntervalToExtract - - | sourceRangeCollections allSourceRanges sourceCode | - sourceRangeCollections := aMethodToRefactor methodNode completeSourceRanges values. - allSourceRanges := sourceRangeCollections - inject: Set new - into: [ :sourceRanges :sourceRangeCollection | sourceRanges addAll: sourceRangeCollection; yourself ]. - sourceCode := aMethodToRefactor sourceCode. - ^ allSourceRanges anySatisfy: [ :sourceRange | - (sourceRange trimToMatchExpressionOn: sourceCode) = anIntervalToExtract ]! ! -!ExtractMethodApplier class methodsFor: 'instance creation' stamp: 'RNG 5/8/2020 21:03:23' prior: 50507759! - for: anIntervalToExtract of: aMethodToExtractCodeFrom - - | trimmedIntervalToExtract sourceCode | - sourceCode := aMethodToExtractCodeFrom sourceCode. - trimmedIntervalToExtract := anIntervalToExtract trimToMatchExpressionOn: sourceCode.. - - self assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: trimmedIntervalToExtract. - - ^ self new initializeFor: trimmedIntervalToExtract of: aMethodToExtractCodeFrom! ! - -ExtractToTemporary removeSelector: #lastTemporaryDeclaration! - -!methodRemoval: ExtractToTemporary #lastTemporaryDeclaration stamp: 'Install-4156-SourceCodeRange-NahuelGarbezza-2020May04-19h23m-RNG.001.cs.st 5/26/2020 17:09:07'! -lastTemporaryDeclaration - - ^ parseNodeWithNewVariableScope temporariesDeclaration temporaryDeclarationNodes last! - -Refactoring class removeSelector: #trim:toMatchExpressionOn:! - -!methodRemoval: Refactoring class #trim:toMatchExpressionOn: stamp: 'Install-4156-SourceCodeRange-NahuelGarbezza-2020May04-19h23m-RNG.001.cs.st 5/26/2020 17:09:07'! -trim: anInterval toMatchExpressionOn: aSourceCode - - | trimmedInterval | - trimmedInterval := anInterval. - [ self shouldTrimToMatchExpressionOn: aSourceCode atIndex: trimmedInterval first ] - whileTrue: [ trimmedInterval := trimmedInterval first + 1 to: trimmedInterval last ]. - [ self shouldTrimToMatchExpressionOn: aSourceCode atIndex: trimmedInterval last ] - whileTrue: [ trimmedInterval := trimmedInterval first to: trimmedInterval last - 1 ]. - - ^ self trim: trimmedInterval matchingParenthesesOn: aSourceCode! - -Refactoring class removeSelector: #trim:matchingParenthesesOn:! - -!methodRemoval: Refactoring class #trim:matchingParenthesesOn: stamp: 'Install-4156-SourceCodeRange-NahuelGarbezza-2020May04-19h23m-RNG.001.cs.st 5/26/2020 17:09:07'! -trim: anInterval matchingParenthesesOn: aSourceCode - - | trimmedInterval | - trimmedInterval := anInterval. - [ - | initialChar endingChar | - initialChar := aSourceCode at: trimmedInterval first ifAbsent: [ nil ]. - endingChar := aSourceCode at: trimmedInterval last ifAbsent: [ nil ]. - initialChar = $( and: [ endingChar = $) ] - ] - whileTrue: [ trimmedInterval _ trimmedInterval first + 1 to: trimmedInterval last - 1 ]. - ^ trimmedInterval! - -Refactoring class removeSelector: #shouldTrimToMatchExpressionOn:atIndex:! - -!methodRemoval: Refactoring class #shouldTrimToMatchExpressionOn:atIndex: stamp: 'Install-4156-SourceCodeRange-NahuelGarbezza-2020May04-19h23m-RNG.001.cs.st 5/26/2020 17:09:07'! -shouldTrimToMatchExpressionOn: sourceCode atIndex: currentIndex - - | currentChar | - currentChar := sourceCode at: currentIndex ifAbsent: [ ^ false ]. - ^ currentChar isSeparator or: [ currentChar = $. ] -! - -ParseNode removeSelector: #expandIfEnclosed:on:! - -!methodRemoval: ParseNode #expandIfEnclosed:on: stamp: 'Install-4156-SourceCodeRange-NahuelGarbezza-2020May04-19h23m-RNG.001.cs.st 5/26/2020 17:09:07'! -expandIfEnclosed: sourceRange on: sourceCode - "takes a source range and a source code and if the source range represents an - expression that can be expanded and still is valid, it returns the source range - 'grown'. Examples: (*3 + 4*) to *(3 + 4)*; `*3 + 4*` to *`3 + 4`*" - - | firstChar lastChar | - firstChar _ sourceCode at: sourceRange first - 1 ifAbsent: [ nil ]. - lastChar _ sourceCode at: sourceRange last + 1 ifAbsent: [ nil ]. - ^ ((firstChar = $( and: [ lastChar = $) ]) - or: [ firstChar = $` and: [ lastChar = $` ] ]) - ifTrue: [ sourceRange first - 1 to: sourceRange last + 1 ] - ifFalse: [ sourceRange ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4156-SourceCodeRange-NahuelGarbezza-2020May04-19h23m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4156] on 21 May 2020 at 5:06:14 pm'! -!SequenceableCollection methodsFor: 'accessing' stamp: 'HAW 5/21/2020 16:56:01'! - firstAvailable: numberOfObjects - "Answer the first numberOfObjects in the receiver, subject to availability" - - ^self first: (numberOfObjects min: self size)! ! -!SequenceableCollection methodsFor: 'accessing' stamp: 'HAW 5/21/2020 16:56:32'! - lastAvailable: numberOfObjects - "Answer the last numberOfObjects in the receiver, subject to availability" - - ^self last: (numberOfObjects min: self size)! ! - -SequenceableCollection removeSelector: #head:! - -!methodRemoval: SequenceableCollection #head: stamp: 'Install-4157-headToFirstAvailableRename-HernanWilkinson-2020May21-16h50m-HAW.001.cs.st 5/26/2020 17:09:07'! -head: anInteger - "Answer the first anInteger objects in the receiver, subject to availability" - - ^self first: (anInteger min: self size)! - -SequenceableCollection removeSelector: #tail:! - -!methodRemoval: SequenceableCollection #tail: stamp: 'Install-4157-headToFirstAvailableRename-HernanWilkinson-2020May21-16h50m-HAW.001.cs.st 5/26/2020 17:09:07'! -tail: anInteger - "Answer the last anInteger objects in the receiver, subject to availability" - - ^self last: (anInteger min: self size)! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4157-headToFirstAvailableRename-HernanWilkinson-2020May21-16h50m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4156] on 21 May 2020 at 5:35:24 pm'! -!SequenceableCollection methodsFor: 'accessing' stamp: 'HAW 5/21/2020 17:34:06'! - head: anInteger - "Answer the first anInteger objects in the receiver, subject to availability" - - ^self firstAvailable: anInteger ! ! -!SequenceableCollection methodsFor: 'accessing' stamp: 'HAW 5/21/2020 17:34:34'! - tail: anInteger - "Answer the last anInteger objects in the receiver, subject to availability" - - ^self lastAvailable: anInteger ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4158-headTail-HernanWilkinson-2020May21-17h06m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4158] on 21 May 2020 at 5:47:22 pm'! -!Compiler methodsFor: 'public access' stamp: 'HAW 3/11/2019 09:04:53'! - compileDoIt: textOrStream in: aClass context: aContext notifying: aRequestor ifFail: failBlock - "Similar to #compile:in:notifying:ifFail:, but the compiled code is - expected to be a do-it expression, with no message pattern." - - self from: textOrStream - class: aClass - context: aContext - notifying: aRequestor. - ^self - translate: sourceStream - noPattern: false - doIt: true - ifFail: failBlock! ! -!Compiler methodsFor: 'private' stamp: 'jmv 4/17/2019 15:15:58'! - translate: aStream noPattern: noPattern doIt: doIt ifFail: failBlock - - ^self parser - ignoreBacktick: false; - parse: aStream - class: class - category: category - noPattern: noPattern - doIt: doIt - context: context - notifying: requestor - ifFail: [^failBlock value]! ! -!Parser methodsFor: 'expression types' stamp: 'RNG 3/13/2020 00:27:50'! - method: noPattern doIt: doIt context: ctxt - " pattern [ | temporaries ] block => MethodNode." - - | sap block primitives tempsDeclarationNode messageComment methodNode | - - sap := self pattern: noPattern inContext: ctxt. - "sap={selector, arguments, precedence}" - self properties selector: (sap at: 1). - encoder selector: (sap at: 1). - (sap at: 2) do: [:argNode | argNode beMethodArg]. - - doIt ifFalse: [self pragmaSequence]. - tempsDeclarationNode := self temporaries. - messageComment := currentComment. - currentComment := nil. - doIt ifFalse: [self pragmaSequence]. - primitives := self pragmaPrimitives. - - self statements: #() innerBlock: doIt. - block := parseNode. - doIt - ifTrue: [block returnLast] - ifFalse: [block returnSelfIfNoOther: encoder]. - hereType == #doIt ifFalse: [^self expected: 'Nothing more']. - - methodNode := self newMethodNode comment: messageComment. - methodNode - selector: (sap at: 1) - arguments: (sap at: 2) - precedence: (sap at: 3) - temporariesDeclaration: tempsDeclarationNode - block: block - encoder: encoder - primitive: primitives - properties: properties - selectorKeywordsRanges: (sap at: 4). - - self interactive ifTrue: [ self performInteractiveChecks: methodNode ]. - - ^methodNode! ! -!Parser methodsFor: 'public access' stamp: 'jmv 4/17/2019 15:17:07'! - parse: sourceStream class: class category: aCategory noPattern: noPattern doIt: doIt context: aContext notifying: aRequestor ifFail: aBlock - - "Answer a MethodNode for the argument, sourceStream, that is the root of - a parse tree. Parsing is done with respect to the argument, class, to find - instance, class, and pool variables; and with respect to the argument, - ctxt, to find temporary variables. Errors in parsing are reported to the - argument, req, if not nil; otherwise aBlock is evaluated. The argument - noPattern is a Boolean that is true if the the sourceStream does not - contain a method header (i.e., for DoIts)." - - | methNode repeatNeeded myStream sourceCode startPosition | - - category _ aCategory. - myStream _ sourceStream. - [ - repeatNeeded _ false. - startPosition _ myStream position. - sourceCode _ myStream upToEnd. - myStream position: startPosition. - self encoder init: class context: aContext notifying: self. - self init: myStream notifying: aRequestor failBlock: [^ aBlock value ]. - doitFlag _ noPattern. - failBlock _ aBlock. - [ methNode _ self method: noPattern doIt: doIt context: aContext ] - on: ReparseAfterSourceEditing - do: [ :ex | - repeatNeeded _ true. - myStream _ ReadStream on: requestor text string ]. - repeatNeeded - ] whileTrue: [ encoder _ self encoder class new ]. - - methNode sourceText: sourceCode. - "See #xBacktick" - sentInLiterals do: [ :sym | encoder noteOptimizedSelector: sym ]. - - ^ methNode! ! -!Compiler methodsFor: 'private' stamp: 'HAW 3/11/2019 07:07:06' prior: 50511203! - translate: aStream noPattern: noPattern ifFail: failBlock - - ^self translate: aStream noPattern: noPattern doIt: noPattern ifFail: failBlock ! ! -!Parser methodsFor: 'public access' stamp: 'HAW 3/11/2019 08:31:06' prior: 50511214! - parse: sourceStream class: class noPattern: noPattern context: aContext notifying: aRequestor ifFail: aBlock - - ^self parse: sourceStream class: class category: nil noPattern: noPattern doIt: noPattern context: aContext notifying: aRequestor ifFail: aBlock ! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'jmv 4/17/2019 15:15:33' prior: 50511225! - compileSelectionFor: anObject in: evalContext ifFail: failBlock - - | methodNode method sourceCode compiler | - - sourceCode := self selectionDoItSourceCodeIn: evalContext. - - methodNode _ [ - compiler _ Compiler new. - compiler - compileDoIt: sourceCode - in: anObject class - context: evalContext - notifying: self - ifFail: [ ^ failBlock value ]] - on: OutOfScopeNotification - do: [ :ex | ex resume: true ]. - - methodNode block returnLast. - method _ methodNode generate. - method methodNode: methodNode. - - ^{ #method -> method. #compiler -> compiler } asDictionary -! ! - -Parser removeSelector: #parse:class:category:noPattern:context:notifying:ifFail:! - -!methodRemoval: Parser #parse:class:category:noPattern:context:notifying:ifFail: stamp: 'Install-4159-rollback-4152-JuanVuletich-2020May21-17h46m-jmv.001.cs.st 5/26/2020 17:09:07'! -parse: sourceStream class: class category: aCategory noPattern: noPattern context: aContext notifying: aRequestor ifFail: aBlock - - "Answer a MethodNode for the argument, sourceStream, that is the root of - a parse tree. Parsing is done with respect to the argument, class, to find - instance, class, and pool variables; and with respect to the argument, - ctxt, to find temporary variables. Errors in parsing are reported to the - argument, req, if not nil; otherwise aBlock is evaluated. The argument - noPattern is a Boolean that is true if the the sourceStream does not - contain a method header (i.e., for DoIts)." - - | methNode repeatNeeded myStream sourceCode startPosition | - - category _ aCategory. - myStream _ sourceStream. - [ - repeatNeeded _ false. - startPosition _ myStream position. - sourceCode _ myStream upToEnd. - myStream position: startPosition. - self encoder init: class context: aContext notifying: self. - self init: myStream notifying: aRequestor failBlock: [^ aBlock value ]. - doitFlag _ noPattern. - failBlock _ aBlock. - [ methNode _ self method: noPattern context: aContext ] - on: ReparseAfterSourceEditing - do: [ :ex | - repeatNeeded _ true. - myStream _ ReadStream on: requestor text string ]. - repeatNeeded - ] whileTrue: [ encoder _ self encoder class new ]. - - methNode sourceText: sourceCode. - "See #xBacktick" - sentInLiterals do: [ :sym | encoder noteOptimizedSelector: sym ]. - - ^ methNode! - -Parser removeSelector: #method:context:! - -!methodRemoval: Parser #method:context: stamp: 'Install-4159-rollback-4152-JuanVuletich-2020May21-17h46m-jmv.001.cs.st 5/26/2020 17:09:07'! -method: noPattern context: ctxt - " pattern [ | temporaries ] block => MethodNode." - - | sap block primitives tempsDeclarationNode messageComment methodNode | - - sap := self pattern: noPattern inContext: ctxt. - "sap={selector, arguments, precedence}" - self properties selector: (sap at: 1). - encoder selector: (sap at: 1). - (sap at: 2) do: [:argNode | argNode beMethodArg]. - - noPattern ifFalse: [self pragmaSequence]. - tempsDeclarationNode := self temporaries. - messageComment := currentComment. - currentComment := nil. - noPattern ifFalse: [self pragmaSequence]. - primitives := self pragmaPrimitives. - - self statements: #() innerBlock: noPattern. - block := parseNode. - noPattern - ifTrue: [block returnLast] - ifFalse: [block returnSelfIfNoOther: encoder]. - hereType == #doIt ifFalse: [^self expected: 'Nothing more']. - - methodNode := self newMethodNode comment: messageComment. - methodNode - selector: (sap at: 1) - arguments: (sap at: 2) - precedence: (sap at: 3) - temporariesDeclaration: tempsDeclarationNode - block: block - encoder: encoder - primitive: primitives - properties: properties - selectorKeywordsRanges: (sap at: 4). - - self interactive ifTrue: [ self performInteractiveChecks: methodNode ]. - - ^methodNode! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4159-rollback-4152-JuanVuletich-2020May21-17h46m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4159] on 21 May 2020 at 6:36:14 pm'! -!LayoutSpec methodsFor: 'accessing' stamp: 'jmv 5/21/2020 18:18:34'! - fixedHeight - ^proportionalHeight isNil ifTrue: [fixedHeight ifNil: [morph morphHeight]] ifFalse: [ 0 ]! ! -!LayoutSpec methodsFor: 'accessing' stamp: 'jmv 5/21/2020 18:13:55'! - fixedWidth - ^proportionalWidth isNil ifTrue: [ fixedWidth ] ifFalse: [ 0 ]! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 5/21/2020 18:35:44' prior: 50512084! - layoutSubmorphsVerticallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - | xSep ySep usableHeight normalizationFactor - fractionalHeights integerHeights theTop usableWidth boundsLeft boundsBottom theLeft minHeight submorphsToLayout - nextMorph ht wd ls theBottom boundsRight theRight alternativeHeights count diff i desiredLayoutHeight | - - boundsForLayout extent > `2@2` "self minimumExtent" - ifFalse: [ ^self ]. "Too small. Don't bother!!" - - submorphsToLayout := self submorphsToLayout. - xSep := self xSeparation. - ySep := self ySeparation. - usableHeight := boundsForLayout height - ((submorphsToLayout size + 1) * ySep). - - desiredLayoutHeight _ self desiredLayoutHeight. - normalizationFactor := self proportionalHeightNormalizationFactor. - usableHeight > desiredLayoutHeight - ifTrue: [ | sumOfFixed | - sumOfFixed := submorphsToLayout sum: [ :m | m layoutSpec fixedHeight ]. - {usableHeight*normalizationFactor - sumOfFixed. usableHeight*normalizationFactor. usableHeight.normalizationFactor. sumOfFixed} print. - fractionalHeights := submorphsToLayout collect: [ :m | m layoutSpec heightForComfortable: usableHeight - sumOfFixed * normalizationFactor]. - fractionalHeights print. - ] - ifFalse: [ | sumOfFixedOrMinimum availableForPropHeight | - sumOfFixedOrMinimum := submorphsToLayout sum: [ :m | m minimumLayoutExtent y max: m layoutSpec fixedOrMinimumLayoutHeight ]. - availableForPropHeight := usableHeight - sumOfFixedOrMinimum max: 0. - fractionalHeights := submorphsToLayout collect: [ :m | m layoutSpec heightFor: availableForPropHeight * normalizationFactor ]]. - - "Compute integer widths, mostly rounding but with occasional #floor or #ceiling as needed to keep sum" - integerHeights _ fractionalHeights collect: [ :w | w rounded ]. - diff _ integerHeights sum - fractionalHeights sum rounded. - alternativeHeights _ diff > 0 ifTrue: [ fractionalHeights collect: [ :w | w floor ]] ifFalse: [ fractionalHeights collect: [ :w | w ceiling ]]. - count _ diff abs. - i _ 1. - [ count > 0] whileTrue: [ - (integerHeights at: i) = (alternativeHeights at: i) ifFalse: [ - integerHeights at: i put: (alternativeHeights at: i). - count _ count -1 ]. - i _ i + 1 ]. - minHeight := integerHeights sum. - theTop := ((usableHeight - minHeight) * (padding ifNil: [0]) max: 0) + boundsForLayout top + ySep. - usableWidth := boundsForLayout width - (xSep * 2) max: 0. - boundsLeft := boundsForLayout left + xSep. - boundsBottom := boundsForLayout bottom - ySep. - boundsRight := boundsForLayout right - xSep. - - submorphsToLayout size to: 1 by: -1 do: [ :index | - nextMorph := submorphsToLayout at: index. - "major direction" - ht := integerHeights at: index. - "minor direction" - ls := nextMorph layoutSpec. - wd := (ls widthFor: usableWidth) min: usableWidth. - theLeft := ((usableWidth - wd) * ls minorDirectionPadding) floor + boundsLeft. - theRight := (theLeft + wd) ceiling min: boundsRight. - theBottom := (theTop + (ht min: minHeight)) "ceiling" min: boundsBottom. - "Set bounds and adjust major direction for next step" - self flag: #jmvVer2. "should extent be set in m's coordinate system? what if its scale is not 1?" - ls usesMorphExtent - ifTrue: [ - nextMorph morphPosition: theLeft floor @ theTop floor ] - ifFalse: [ - nextMorph morphPosition: theLeft floor @ theTop floor extent: theRight - theLeft @ (theBottom - theTop) ]. - theTop := theBottom + ySep - ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4160-ProportionalLayoutFix-JuanVuletich-2020May21-18h09m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4160] on 21 May 2020 at 6:53:25 pm'! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 5/21/2020 18:39:54' prior: 50511984! - layoutSubmorphsHorizontallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - | xSep ySep usableWidth normalizationFactor - fractionalWidths integerWidths theLeft usableHeight boundsTop boundsRight theTop minWidth submorphsToLayout - nextMorph ht wd ls theRight boundsBottom theBottom alternativeWidths count diff i desiredLayoutWidth | - - boundsForLayout extent > `2@2` "self minimumExtent" - ifFalse: [ ^self ]. "Too small. Don't bother!!" - - submorphsToLayout := self submorphsToLayout. - xSep := self xSeparation. - ySep := self ySeparation. - usableWidth := boundsForLayout width - ((submorphsToLayout size + 1) * xSep). - - desiredLayoutWidth _ self desiredLayoutWidth. - normalizationFactor := self proportionalWidthNormalizationFactor. - usableWidth > desiredLayoutWidth - ifTrue: [ | sumOfFixed | - sumOfFixed := submorphsToLayout sum: [ :m | m layoutSpec fixedWidth ]. - fractionalWidths := submorphsToLayout collect: [ :m | m layoutSpec widthForComfortable: usableWidth-sumOfFixed * normalizationFactor]] - ifFalse: [ | sumOfFixedOrMinimum availableForPropWidth | - sumOfFixedOrMinimum := submorphsToLayout sum: [ :m | m minimumLayoutExtent x max: m layoutSpec fixedOrMinimumLayoutWidth ]. - availableForPropWidth := usableWidth - sumOfFixedOrMinimum max: 0. - fractionalWidths := submorphsToLayout collect: [ :m | m layoutSpec widthFor: availableForPropWidth * normalizationFactor ]]. - "Compute integer widths, mostly rounding but with occasional #floor or #ceiling as needed to keep sum" - integerWidths _ fractionalWidths collect: [ :w | w rounded ]. - diff _ integerWidths sum - fractionalWidths sum rounded. - alternativeWidths _ diff > 0 ifTrue: [ fractionalWidths collect: [ :w | w floor ]] ifFalse: [ fractionalWidths collect: [ :w | w ceiling ]]. - count _ diff abs. - i _ 1. - [ count > 0] whileTrue: [ - (integerWidths at: i) = (alternativeWidths at: i) ifFalse: [ - integerWidths at: i put: (alternativeWidths at: i). - count _ count -1 ]. - i _ i + 1 ]. - minWidth := integerWidths sum. - theLeft := ((usableWidth - minWidth) * (padding ifNil: [0]) max: 0) + boundsForLayout left + xSep. - usableHeight := boundsForLayout height - (ySep * 2) max: 0. - boundsTop := boundsForLayout top + ySep. - boundsRight := boundsForLayout right - xSep. - boundsBottom := boundsForLayout bottom - ySep. - - submorphsToLayout size to: 1 by: -1 do: [ :index | - nextMorph := submorphsToLayout at: index. - "major direction" - wd := integerWidths at: index. - "minor direction" - ls := nextMorph layoutSpec. - ht := (ls heightFor: usableHeight) min: usableHeight. - theTop := ((usableHeight - ht) * ls minorDirectionPadding) floor + boundsTop. - theBottom := (theTop + ht) ceiling min: boundsBottom. - theRight := (theLeft + (wd min: minWidth)) "ceiling "min: boundsRight. - "Set bounds and adjust major direction for next step" - self flag: #jmvVer2. "should extent be set in m's coordinate system? what if its scale is not 1?" - ls usesMorphExtent - ifTrue: [ - nextMorph morphPosition: theLeft floor @ theTop floor ] - ifFalse: [ - nextMorph morphPosition: theLeft floor @ theTop floor extent: theRight - theLeft @ (theBottom - theTop) ]. - theLeft := theRight + xSep - ]! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 5/21/2020 18:39:48' prior: 50513188! - layoutSubmorphsVerticallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - | xSep ySep usableHeight normalizationFactor - fractionalHeights integerHeights theTop usableWidth boundsLeft boundsBottom theLeft minHeight submorphsToLayout - nextMorph ht wd ls theBottom boundsRight theRight alternativeHeights count diff i desiredLayoutHeight | - - boundsForLayout extent > `2@2` "self minimumExtent" - ifFalse: [ ^self ]. "Too small. Don't bother!!" - - submorphsToLayout := self submorphsToLayout. - xSep := self xSeparation. - ySep := self ySeparation. - usableHeight := boundsForLayout height - ((submorphsToLayout size + 1) * ySep). - - desiredLayoutHeight _ self desiredLayoutHeight. - normalizationFactor := self proportionalHeightNormalizationFactor. - usableHeight > desiredLayoutHeight - ifTrue: [ | sumOfFixed | - sumOfFixed := submorphsToLayout sum: [ :m | m layoutSpec fixedHeight ]. - fractionalHeights := submorphsToLayout collect: [ :m | m layoutSpec heightForComfortable: usableHeight-sumOfFixed * normalizationFactor]] - ifFalse: [ | sumOfFixedOrMinimum availableForPropHeight | - sumOfFixedOrMinimum := submorphsToLayout sum: [ :m | m minimumLayoutExtent y max: m layoutSpec fixedOrMinimumLayoutHeight ]. - availableForPropHeight := usableHeight - sumOfFixedOrMinimum max: 0. - fractionalHeights := submorphsToLayout collect: [ :m | m layoutSpec heightFor: availableForPropHeight * normalizationFactor ]]. - - "Compute integer widths, mostly rounding but with occasional #floor or #ceiling as needed to keep sum" - integerHeights _ fractionalHeights collect: [ :w | w rounded ]. - diff _ integerHeights sum - fractionalHeights sum rounded. - alternativeHeights _ diff > 0 ifTrue: [ fractionalHeights collect: [ :w | w floor ]] ifFalse: [ fractionalHeights collect: [ :w | w ceiling ]]. - count _ diff abs. - i _ 1. - [ count > 0] whileTrue: [ - (integerHeights at: i) = (alternativeHeights at: i) ifFalse: [ - integerHeights at: i put: (alternativeHeights at: i). - count _ count -1 ]. - i _ i + 1 ]. - minHeight := integerHeights sum. - theTop := ((usableHeight - minHeight) * (padding ifNil: [0]) max: 0) + boundsForLayout top + ySep. - usableWidth := boundsForLayout width - (xSep * 2) max: 0. - boundsLeft := boundsForLayout left + xSep. - boundsBottom := boundsForLayout bottom - ySep. - boundsRight := boundsForLayout right - xSep. - - submorphsToLayout size to: 1 by: -1 do: [ :index | - nextMorph := submorphsToLayout at: index. - "major direction" - ht := integerHeights at: index. - "minor direction" - ls := nextMorph layoutSpec. - wd := (ls widthFor: usableWidth) min: usableWidth. - theLeft := ((usableWidth - wd) * ls minorDirectionPadding) floor + boundsLeft. - theRight := (theLeft + wd) ceiling min: boundsRight. - theBottom := (theTop + (ht min: minHeight)) "ceiling" min: boundsBottom. - "Set bounds and adjust major direction for next step" - self flag: #jmvVer2. "should extent be set in m's coordinate system? what if its scale is not 1?" - ls usesMorphExtent - ifTrue: [ - nextMorph morphPosition: theLeft floor @ theTop floor ] - ifFalse: [ - nextMorph morphPosition: theLeft floor @ theTop floor extent: theRight - theLeft @ (theBottom - theTop) ]. - theTop := theBottom + ySep - ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4161-YAlayoutFix-JuanVuletich-2020May21-18h53m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4161] on 21 May 2020 at 7:47:20 pm'! -!LayoutSpec methodsFor: 'accessing' stamp: 'jmv 5/21/2020 19:46:50' prior: 50513182! - fixedWidth - ^proportionalWidth isNil ifTrue: [fixedWidth ifNil: [morph morphWidth]] ifFalse: [ 0 ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4162-yetAnotherLayoutFix-JuanVuletich-2020May21-19h46m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4162] on 21 May 2020 at 10:31:06 pm'! -!BoxedFloat64 methodsFor: 'truncation and round off' stamp: 'jmv 5/21/2020 22:23:44' prior: 50468067 overrides: 16880628! - truncated - "Answer with a SmallInteger equal to the value of the receiver without - its fractional part. The primitive fails if the truncated value cannot be - represented as a SmallInteger. In that case, the code below will compute - a LargeInteger truncated value. - Raise an exception if no conversion to integer is possible, i.e. for Infinities and NaN. - Essential. See Object documentation whatIsAPrimitive. " - - - self isFinite ifFalse: [ ^self ]. - ^ self partValues: [ :sign :exponent :mantissa | - sign * (mantissa bitShift: exponent - 52) ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4163-InfinityAndNaN-truncated-fix-JuanVuletich-2020May21-22h30m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4163] on 23 May 2020 at 8:51:22 pm'! - -BorderedRectMorph subclass: #StringRequestMorph - instanceVariableNames: 'response acceptBlock cancelBlock validationBlock' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #StringRequestMorph category: #'Morphic-Widgets' stamp: 'Install-4164-NonModalStringRequests-LucianoEstebanNotarfrancesco-2020May23-20h43m-len.001.cs.st 5/26/2020 17:09:07'! -BorderedRectMorph subclass: #StringRequestMorph - instanceVariableNames: 'response acceptBlock cancelBlock validationBlock' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -StringRequestMorph subclass: #ClassNameRequestMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #ClassNameRequestMorph category: #'Morphic-Widgets' stamp: 'Install-4164-NonModalStringRequests-LucianoEstebanNotarfrancesco-2020May23-20h43m-len.001.cs.st 5/26/2020 17:09:07'! -StringRequestMorph subclass: #ClassNameRequestMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! -!Object methodsFor: 'user interface' stamp: 'len 5/20/2020 04:00:44'! - request: queryString do: aBlock - ^ self request: queryString initialAnswer: '' verifying: [:aString| true] do: aBlock orCancel: []! ! -!Object methodsFor: 'user interface' stamp: 'len 5/20/2020 06:32:35'! - request: queryString initialAnswer: defaultAnswer - "This is deprecated because using it requires blocking the user interface until the user provides a response. Please use the variants that are not modal." - ^ self request: queryString initialAnswer: defaultAnswer orCancel: ['']! ! -!Object methodsFor: 'user interface' stamp: 'len 5/20/2020 04:11:48'! -request: queryString initialAnswer: defaultAnswer do: aBlock - ^ self request: queryString initialAnswer: defaultAnswer verifying: [:aString| true] do: aBlock orCancel: []! ! -!Object methodsFor: 'user interface' stamp: 'len 5/20/2020 03:59:45'! - request: queryString initialAnswer: defaultAnswer do: aBlock orCancel: cancelBlock - ^ self request: queryString initialAnswer: defaultAnswer verifying: [:aString| true] do: aBlock orCancel: cancelBlock! ! -!Object methodsFor: 'user interface' stamp: 'len 5/20/2020 04:50:27'! - request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock - "This is deprecated because using it requires blocking the user interface until the user provides a response. Please use the variants that are not modal." - ^ StringRequestMorph request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock! ! -!Object methodsFor: 'user interface' stamp: 'len 5/20/2020 07:37:39'! - request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock - ^ self request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: []! ! -!Object methodsFor: 'user interface' stamp: 'len 5/20/2020 07:38:05'! - request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock - ^ StringRequestMorph request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock! ! -!StringRequestMorph methodsFor: 'accessing' stamp: 'len 5/19/2020 06:58:15'! - emptyTextDisplayMessage: aString - self - setProperty: #emptyTextDisplayMessage - toValue: aString.! ! -!StringRequestMorph methodsFor: 'accessing' stamp: 'len 5/19/2020 08:23:39'! - response - ^ response -! ! -!StringRequestMorph methodsFor: 'accessing' stamp: 'len 5/20/2020 04:06:50'! - response: aText - "Sent when text pane accepts." - response _ aText. - validationBlock ifNotNil: [(validationBlock value: aText asString) ifFalse: [self flash. ^ false]]. - [acceptBlock ifNotNil: [acceptBlock value: aText asString]] ensure: [self delete]. - ^ true! ! -!StringRequestMorph methodsFor: 'drawing' stamp: 'len 5/19/2020 06:59:55' overrides: 16790395! - drawOn: aCanvas - - | roundCorners | - roundCorners _ Theme current roundWindowCorners. - roundCorners - ifTrue: [ - aCanvas roundRect: self morphLocalBounds color: color radius: Theme current roundedWindowRadius ] - ifFalse: [ - aCanvas fillRectangle: self morphLocalBounds color: color borderWidth: borderWidth borderStyleSymbol: #raised baseColorForBorder: color ]! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'len 5/20/2020 04:03:27'! - acceptBlock: aBlock - acceptBlock _ aBlock! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'len 5/20/2020 09:00:16'! - addTextPane - | result | - result _ (TextModelMorph - textProvider: self - textGetter: #response - textSetter: #response: - selectionGetter: #selectionInterval) emptyTextDisplayMessage: 'Enter response'. - self - valueOfProperty: #emptyTextDisplayMessage - ifPresentDo: [ :msg | - result emptyTextDisplayMessage: msg ]. - result - hasUnacceptedEdits: true; - acceptOnCR: true; - escAction: [ self cancel ]. - "If the initial response is big or has multiple lines we make the text pane bigger and with scrollbars:" - (response size > 20 or: [response includes: Character lf]) - ifTrue: [result morphExtent: 32 @ 3 * AbstractFont default lineSpacing] - ifFalse: - [result hideScrollBarsIndefinitely; - morphExtent: 18 @ 1 * AbstractFont default lineSpacing + (0@8).]. - self addMorphBack: result. - ^ result.! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'len 5/19/2020 08:18:15'! - addTitle: aString - | titleMorph s pp w | - titleMorph _ RectangleLikeMorph new. - titleMorph color: Theme current menuTitleBar. - pp _ `8@2`. - aString asString linesDo: [ :line | - s _ StringMorph new - contents: line; - font: Preferences standardMenuFont bold. - titleMorph addMorphBack: s position: pp. - pp _ pp + (0@(s morphHeight+2)) ]. - w _ titleMorph submorphs inject: 0 into: [ :prev :each | - prev max: each morphWidth ]. - titleMorph morphExtent: (w + 16) @ (pp y). - self addMorphFront: titleMorph.! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'len 5/20/2020 04:03:33'! - cancelBlock: aBlock - cancelBlock _ aBlock! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'len 5/19/2020 07:00:19' overrides: 16790416! - defaultBorderWidth - ^ (Theme current roundWindowCorners or: [Theme current minimalWindows]) - ifTrue: [0] - ifFalse: [Preferences menuBorderWidth]! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'len 5/19/2020 07:00:42' overrides: 50387674! - defaultColor - ^ Theme current menu! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'len 5/20/2020 08:54:26' overrides: 16790421! - initialize - super initialize. - extent _ `20@10`. - response _ ''! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'len 5/19/2020 19:27:25' overrides: 16875917! - intoWorld: aWorld - "The receiver has just appeared in a new world. Note: - * aWorld can be nil (due to optimizations in other places) - * owner is already set - * owner's submorphs may not include receiver yet. - Important: Keep this method fast - it is run whenever morphs are added." - super intoWorld: aWorld. - self adjustSubmorphsLayout. -"this doesnt work: aWorld ifNotNil: [aWorld activeHand newKeyboardFocus: textPane]"! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'len 5/19/2020 19:27:47'! - setQuery: queryString initialAnswer: initialAnswer - response _ initialAnswer. - self addTitle: queryString. - self addTextPane! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'len 5/20/2020 04:03:48'! - validationBlock: aBlock - validationBlock _ aBlock! ! -!StringRequestMorph methodsFor: 'private' stamp: 'len 5/19/2020 07:38:08'! -adjustSubmorphsLayout - "Enlarge the width of submorphs as needed - so all of them are have the same width, and no less than #minWidth. - Also adjust their vertical position. - Finally, set our own extent." - - | w p h | - - submorphs isEmpty ifTrue: [ ^self ]. - w _ submorphs inject: 0 into: [ :prev :each | - prev max: each minItemWidth]. - - w _ w + 1. - p _ `5 @ 5`. - submorphs do: [ :m | - h _ m morphHeight. - m morphPosition: p extent: w@h. - p _ p + (0@(h + 1)) ]. - - self morphExtent: w+4 @ p y + 5! ! -!StringRequestMorph methodsFor: 'private' stamp: 'len 5/19/2020 08:55:51'! -cancel - self delete. - cancelBlock ifNotNil: [cancelBlock value]! ! -!StringRequestMorph methodsFor: 'private' stamp: 'len 5/20/2020 05:01:41'! - getUserResponseOrCancel: aBlock - "Wait for the user to accept or cancel, and answer the result string. Answers the empty string if the user cancels." - "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop." - | w delay done canceled | - w _ self world. - w isNil ifTrue: [^ response asString]. - done _ false. - canceled _ false. -" textPane focusText." - acceptBlock _ [:aString| done _ true]. - cancelBlock _ [done _ true. canceled _ true]. - delay _ Delay forMilliseconds: 10. - [done not and: [self isInWorld]] whileTrue: [ w doOneMinimalCycleNow. delay wait ]. - self delete. - w doOneMinimalCycleNow. - canceled ifTrue: [^ aBlock value]. - ^ response asString! ! -!StringRequestMorph methodsFor: 'private' stamp: 'len 5/19/2020 06:58:15'! - selectionInterval - ^ 1 to: response size -! ! -!StringRequestMorph class methodsFor: 'instance creation' stamp: 'len 5/20/2020 06:02:15'! - request: queryString centeredAt: aPoint initialAnswer: defaultAnswer validationBlock: validationBlock acceptBlock: acceptBlock cancelBlock: cancelBlock - | answer | - answer _ self new - setQuery: queryString - initialAnswer: defaultAnswer; - validationBlock: validationBlock; - acceptBlock: acceptBlock; - cancelBlock: cancelBlock. - self runningWorld addMorph: answer centeredNear: aPoint - self deltaToTextPane. - ^ answer! ! -!StringRequestMorph class methodsFor: 'instance creation' stamp: 'len 5/20/2020 06:00:53' overrides: 50513615! - request: queryString initialAnswer: defaultAnswer do: acceptBlock - ^ self request: queryString centeredAt: self runningWorld activeHand morphPosition initialAnswer: defaultAnswer validationBlock: [:aString| true] acceptBlock: acceptBlock cancelBlock: []! ! -!StringRequestMorph class methodsFor: 'instance creation' stamp: 'len 5/20/2020 04:48:06' overrides: 50513632! - request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock - | morph world | - morph _ self new - setQuery: queryString - initialAnswer: defaultAnswer. - (world _ self runningWorld) addMorph: morph centeredNear: world activeHand morphPosition - self deltaToTextPane. - ^ morph getUserResponseOrCancel: cancelBlock! ! -!StringRequestMorph class methodsFor: 'instance creation' stamp: 'len 5/20/2020 07:38:12' overrides: 50513654! - request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock - ^ self request: queryString centeredAt: self runningWorld activeHand morphPosition initialAnswer: defaultAnswer validationBlock: validationBlock acceptBlock: acceptBlock cancelBlock: cancelBlock! ! -!StringRequestMorph class methodsFor: 'private' stamp: 'len 5/19/2020 19:32:56'! - deltaToTextPane - "Answer a distance to translate an instance of the receiver by when it is opened in the world in order to have the hand be over the text pane (so the text pane has focus)." - ^ 40@40! ! -!CodeProvider methodsFor: 'categories' stamp: 'len 5/20/2020 08:08:08' prior: 16811919! - categoryFromUserWithPrompt: aPrompt for: aClass - "self new categoryFromUserWithPrompt: 'testing' for: SystemDictionary" - - | labels myCategories reject lines newName menuIndex | - labels _ OrderedCollection with: 'new...'. - labels addAll: (myCategories _ aClass organization categories asArray copy sort: - [ :a :b | a asLowercase < b asLowercase ]). - reject _ myCategories asSet. - reject - add: ClassOrganizer nullCategory; - add: ClassOrganizer default. - lines _ OrderedCollection with: 1 with: (myCategories size + 1). - - aClass allSuperclasses do: [ :cls | | cats | - cats _ cls organization categories reject: [ :cat | reject includes: cat]. - cats isEmpty ifFalse: [ - lines add: labels size. - labels addAll: (cats asArray sort: [ :a :b | a asLowercase < b asLowercase]). - reject addAll: cats]]. - - (labels size = 1 or: [ - menuIndex _ (PopUpMenu labelArray: labels lines: lines) - startUpWithCaption: aPrompt. - menuIndex = 0 ifTrue: [^ nil]. - menuIndex = 1]) - ifTrue:[ - newName _ self request: 'New category name?' initialAnswer: 'Category-Name'. - newName isEmpty ifTrue: [ ^nil ]] - ifFalse: [ newName _ labels at: menuIndex ]. - ^ newName ifNotNil: [ newName asSymbol ]! ! -!Browser methodsFor: 'class functions' stamp: 'len 5/20/2020 07:23:01' prior: 16791541! - copyClass - | originalClass originalName copysName newDefinition newMetaDefinition newClass | - selectedClassName ifNil: [^ self]. - originalClass _ self selectedClass. - originalName _ originalClass name. - self request: 'New class name?' - initialAnswer: originalName - verifying: [:aString| aString notEmpty and: [aString ~= originalName]] - do: [:aString| - copysName _ aString asSymbol. - (Smalltalk includesKey: copysName) - ifTrue: [self error: copysName , ' already exists']. - newDefinition _ originalClass definition - copyReplaceAll: originalName printString - with: copysName printString. - newClass _ Compiler evaluate: newDefinition logged: true. - newMetaDefinition _ originalClass class definition - copyReplaceAll: originalClass class name - with: newClass class name. - Compiler evaluate: newMetaDefinition logged: true. - newClass copyAllCategoriesFrom: originalClass. - newClass class copyAllCategoriesFrom: originalClass class. - originalClass hasComment ifTrue: [newClass comment: originalClass comment]. - self classListIndex: 0. - self changed: #classList]! ! -!Browser methodsFor: 'message category functions' stamp: 'len 5/20/2020 07:00:28' prior: 50426785! - newMethodCategoryNameIfNone: aNoneBlock - - | labels lines menuIndex newName reject | - - labels _ OrderedCollection with: 'new...'. - reject _ Set new. - reject - addAll: self selectedClassOrMetaClass organization categories; - add: ClassOrganizer nullCategory; - add: ClassOrganizer default. - lines _ OrderedCollection new. - self selectedClassOrMetaClass allSuperclasses do: [:cls | | cats | - cls = Object ifFalse: [ - cats _ cls organization categories reject: - [:cat | reject includes: cat]. - cats isEmpty ifFalse: [ - lines add: labels size. - labels addAll: cats asArray sort. - reject addAll: cats]]]. - newName _ (labels size = 1 or: [ - menuIndex _ (PopUpMenu labelArray: labels lines: lines) - startUpWithCaption: 'Add Category'. - menuIndex = 0 ifTrue: [^ aNoneBlock value]. - menuIndex = 1]) - ifTrue: [ - self request: 'New category name?' - initialAnswer: 'Category-Name'] - ifFalse: [ - labels at: menuIndex]. - - ^ newName isEmpty - ifTrue: aNoneBlock - ifFalse: [newName asSymbol]! ! -!Browser methodsFor: 'message category functions' stamp: 'len 5/20/2020 07:25:11' prior: 16792115! - renameCategory - "Prompt for a new category name and add it before the - current selection, or at the end if no current selection" - | oldIndex oldName newName | - selectedClassName ifNil: [^ self]. - selectedMessageCategory ifNil: [ ^self ]. - oldIndex _ self messageCategoryListIndex. - oldName _ self selectedMessageCategoryName. - newName _ self - request: 'New category name?' - initialAnswer: oldName - verifying: [:aString| aString notEmpty and: [aString ~= oldName]] - do: [:aString| - newName _ aString asSymbol. - self classOrMetaClassOrganizer - renameCategory: oldName - toBe: newName. - self classListIndex: self classListIndex. - self messageCategoryListIndex: oldIndex. - self changed: #messageCategoryList]! ! -!Browser methodsFor: 'system category functions' stamp: 'len 5/20/2020 06:58:53' prior: 50426820! - newSystemCategoryNameIfNone: aNoneBlock - - | newName | - - newName _ self - request: 'New category name?' - initialAnswer: 'Category-Name'. - - ^newName isEmpty - ifTrue: aNoneBlock - ifFalse: [newName asSymbol].! ! -!Browser methodsFor: 'system category functions' stamp: 'len 5/20/2020 07:26:14' prior: 16792688! - renameSystemCategory - "Prompt for a new category name and add it before the - current selection, or at the end if no current selection - - 21-Mar-2012 jmv Note: This is not recorded appropriately in change sets. - The easiest solution is to trigger #classRecategorized for all classes in the category. - But this is not a real solution, as the resulting changeset would not do a rename, - but create a new category (that would go to the bottom) with all the classes. - - In the meantime, disable the menu entry. This is not so important after all. - " - | oldIndex oldName newName | - selectedSystemCategory ifNil: [ ^ self]. "no selection" - oldIndex _ self systemCategoryListIndex. - oldName _ selectedSystemCategory. - newName _ self - request: 'New category name?' - initialAnswer: oldName - verifying: [:aString| aString notEmpty and: [aString ~= oldName]] - do: [:aString| - newName _ aString asSymbol. - systemOrganizer - renameCategory: oldName - toBe: newName. - self systemCategoryListIndex: oldIndex. - self changed: #systemCategoryList]! ! -!MessageSet methodsFor: 'filtering' stamp: 'len 5/20/2020 06:47:08' prior: 16870166! - filterToImplementorsOf - "Filter the receiver's list down to only those items with a given selector." - - self request: 'Enter selector:' initialAnswer: '' verifying: [:aString| aString notEmpty] do: [:aString| - Symbol hasInterned: aString withBlanksTrimmed ifTrue: - [:aSymbol | - self filterFrom: - [:aClass :aSelector | - aSelector == aSymbol]]]! ! -!MessageSet methodsFor: 'filtering' stamp: 'len 5/20/2020 06:44:54' prior: 16870268! - filterToNotImplementorsOf - "Filter the receiver's list down to only those items whose selector is NOT one solicited from the user." - - self request: 'Enter selector:' initialAnswer: '' verifying: [:aString| aString notEmpty] do: [:aString| - Symbol hasInterned: aString withBlanksTrimmed ifTrue: - [:aSymbol | - self filterFrom: - [:aClass :aSelector | - aSelector ~~ aSymbol]]]! ! -!MessageSet methodsFor: 'filtering' stamp: 'len 5/20/2020 06:47:00' prior: 16870286! - filterToNotSendersOf - "Filter the receiver's list down to only those items which do not send a given selector." - - self request: 'Enter selector:' initialAnswer: '' verifying: [:aString| aString notEmpty] do: [:aString| - Symbol hasInterned: aString withBlanksTrimmed ifTrue: - [:aSymbol | - self filterFrom: - [:aClass :aSelector | | aMethod | - (aMethod _ aClass compiledMethodAt: aSelector) isNil or: - [(aMethod hasLiteralThorough: aSymbol) not]]]]! ! -!MessageSet methodsFor: 'filtering' stamp: 'len 5/20/2020 06:47:19' prior: 16870306! - filterToSendersOf - "Filter the receiver's list down to only those items which send a given selector." - - self request: 'Enter selector:' initialAnswer: '' verifying: [:aString| aString notEmpty] do: [:aString| - Symbol hasInterned: aString withBlanksTrimmed ifTrue: - [:aSymbol | - self filterFrom: - [:aClass :aSelector | | aMethod | - (aMethod _ aClass compiledMethodAt: aSelector) notNil and: - [aMethod hasLiteralThorough: aSymbol]]]]! ! -!CodeFileBrowser methodsFor: 'class list' stamp: 'len 5/20/2020 07:28:17' prior: 50492893 overrides: 50482952! - renameClass - | oldName newName | - selectedClassName ifNil: [ ^self ]. - oldName _ self selectedClass name. - self request: 'New class name?' - initialAnswer: oldName - verifying: [:aString| aString notEmpty and: [aString ~= oldName]] - do: [:aString| - newName _ aString asSymbol. - (caseCodeSource classDictionary includesKey: newName) - ifTrue: [self error: newName , ' already exists in the CodeFile']. - systemOrganizer classify: newName under: selectedSystemCategory. - systemOrganizer removeElement: oldName. - caseCodeSource renameClass: self selectedClass to: newName. - self changed: #classList. - self classListIndex: ((systemOrganizer listAtCategoryNamed: selectedSystemCategory) indexOf: newName)]! ! -!ChangeList methodsFor: 'menu actions' stamp: 'len 5/20/2020 04:12:13' prior: 50344434! - fileOutCurrentVersionsOfSelections - self request: 'Enter file name' initialAnswer: 'Filename.st' do: [:aString| - aString asFileEntry writeStreamDo: [ :stream | - stream timeStamp. - self currentVersionsOfSelections do: [ :methodRef | - methodRef actualClass - printMethodChunk: methodRef methodSymbol - withPreamble: true - on: stream - moveSource: false - toFile: 0 ]]]! ! -!ChangeList methodsFor: 'menu actions' stamp: 'len 5/20/2020 04:12:37' prior: 16796233! - fileOutSelections - self request: 'Enter file name' initialAnswer: 'Filename.st' do: [ :aString | - aString asFileEntry writeStreamDo: [ :stream | - stream timeStamp. - listSelections with: changeList do: [ :selected :item | - selected ifTrue: [ item fileOutOn: stream ]]]]! ! -!ChangeSorter methodsFor: 'changeSet menu' stamp: 'len 5/20/2020 06:13:26' prior: 16799624! - rename - "Store a new name string into the selected ChangeSet. reject duplicate name; allow user to back out" - - self request: 'New name for this change set' initialAnswer: myChangeSet name do: [:newName| - (newName = myChangeSet name or: [newName size = 0]) - ifTrue: [Smalltalk beep] - ifFalse: - [(ChangeSet changeSetNamed: newName) notNil - ifTrue: [self inform: 'Sorry that name is already used'] - ifFalse: - [myChangeSet name: newName. - self update. - self changed: #mainButtonName. - self changed: #relabel]]]! ! -!Debugger methodsFor: 'context stack menu' stamp: 'len 5/20/2020 08:27:52' prior: 50476463! - askForCategoryIn: aClass default: aDefaultCategory - - | categories index category classCategories | - - categories := OrderedCollection with: 'new ...'. - - aClass isMeta ifTrue: [ categories add: Categorizer instanceCreation ]. - classCategories := aClass allMethodCategoriesIntegratedThrough: Object. - aClass isMeta ifTrue: [ classCategories remove: Categorizer instanceCreation ifAbsent: []]. - - categories addAll: classCategories. - index := PopUpMenu - withCaption: 'Please provide a good category for the new method!!' - chooseFrom: categories. - index = 0 ifTrue: [^ aDefaultCategory]. - category := index = 1 - ifTrue: [self request: 'Enter category name:' initialAnswer: ''] - ifFalse: [categories at: index]. - - ^ category isEmpty ifTrue: [aDefaultCategory] ifFalse: [category]! ! -!FileList methodsFor: 'file menu action' stamp: 'len 5/20/2020 06:39:43' prior: 16842467! - addNew: aString byEvaluating: aBlock - "A parameterization of earlier versions of #addNewDirectory and - #addNewFile. Fixes the bug in each that pushing the cancel button - in the FillInTheBlank dialog gave a walkback." - - | newName index | - self request: ('New {1} name?' format: {aString}) - initialAnswer: ('{1}Name' format: {aString}) - verifying: [:response| response notEmpty] - do: [:response| - newName _ response asFileName. - aBlock value: newName. - self updateFileList. - index _(1 to: list size) detect: [ :i | - (list at: i) includesSubString: newName ] ifNone: [ 0 ]. - self fileListIndex: index]! ! -!FileList methodsFor: 'file menu action' stamp: 'len 5/20/2020 06:39:51' prior: 16842489! - addNewDirectory - - self - addNew: 'directory' - byEvaluating: [ :newName | (directory / newName) assureExistence ]. - self updateDirectory. - self changed: #initialDirectoryList! ! -!FileList methodsFor: 'file menu action' stamp: 'len 5/20/2020 06:39:54' prior: 16842497! - addNewFile - - self - addNew: 'file' - byEvaluating: [ :newName | (directory // newName) assureExistence ] -! ! -!FileList methodsFor: 'file menu action' stamp: 'len 5/20/2020 06:39:31' prior: 16842534! - renameFile - "Rename the currently selected file" - listIndex = 0 ifTrue: [^ self]. - self request: 'New file name?' - initialAnswer: fileName - verifying: [:response| response notEmpty and: [response asFileName ~= fileName]] - do: [:response| - | newName | - newName _ response asFileName. - directory // fileName rename: newName. - self updateFileList. - listIndex _ list findFirst: [:item | (self fileNameFromFormattedItem: item) = newName]. - listIndex > 0 ifTrue: [fileName _ newName]. - self changed: #fileListIndex. - self triggerEvent: #updateButtonRow]! ! -!TestRunner methodsFor: 'menus' stamp: 'len 5/20/2020 04:15:57' prior: 16928148! - setFilter - self - request: 'Pattern for added test cases (#* OK)' - initialAnswer: '*' - do: [:aString| - filter _ aString. - (filter endsWith: '*') ifFalse: [ filter _ filter, '*' ]. - selectedSuites _ (tests asOrderedCollection with: selectedSuites collect: [ :ea :sel | - sel or: [ filter match: ea asString ] - ]). - selectedSuite _ selectedSuites indexOf: true ifAbsent: [0]. - self changed: #allSelections]! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'len 5/20/2020 06:20:10' prior: 50365816! - condenseSources - "Move all the changes onto a compacted sources file." - "Smalltalk condenseSources" - - | classCount oldChanges oldChangesLocalName oldChangesPathName newChangesPathName newSourcesName | - self request: 'Please name the new sources file' initialAnswer: SourceFileVersionString verifying: [:newVersionString| newVersionString ~= SourceFileVersionString] do: [:newVersionString| - SourceFileVersionString _ newVersionString. - - "Write all sources with fileIndex 1" - newSourcesName _ self defaultSourcesName. - newSourcesName asFileEntry writeStreamDo: [ :f | - f timeStamp. - 'Condensing Sources File...' - displayProgressAt: Sensor mousePoint - from: 0 to: Smalltalk classNames size - during: [ :barBlock | - classCount _ 0. - Smalltalk allClassesDo: [ :class | - barBlock value: (classCount _ classCount + 1). - class fileOutOn: f moveSource: true toFile: 1]]]. - - CompiledMethod allInstancesDo: [ :e | - e isInstalled ifFalse: [ e destroySourcePointer ] ]. - - "Make a new empty changes file" - oldChanges _ SourceFiles at: 2. - oldChangesPathName _ oldChanges name. - oldChangesLocalName _ oldChanges localName. - self closeSourceFiles. - oldChangesPathName ifNotNil: [ - (oldChangesPathName, '.old') asFileEntry delete. - oldChangesPathName asFileEntry rename: oldChangesLocalName, '.old' ]. - newChangesPathName _ self defaultChangesName. - newChangesPathName asFileEntry writeStreamDo: [ :stream | - stream timeStamp ]. - LastQuitLogPosition _ 0. - - self openSourceFiles. - self inform: 'Source files have been rewritten!! - -Check that all is well, and then save/quit. - -Otherwise, remove new sources/changes, -replace them with the former ones, and -exit without saving the image. - ']! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'len 5/20/2020 08:37:42' prior: 16922729! - saveAs - "Put up the 'saveAs' prompt, obtain a name, and save the image under that new name." - - self request: 'New file name?' initialAnswer: self imageName asFileEntry name do: [:newName| - ((((self fullNameForImageNamed: newName) asFileEntry exists not - and: [(self fullNameForChangesNamed: newName) asFileEntry exists not]) - or: [self confirm: ('{1} already exists. Overwrite?' format: {newName})]) - and: [self okayToSave]) - ifTrue: - [self saveAs: newName andQuit: false clearAllClassState: false]]! ! -!StandardFileStream class methodsFor: 'error handling' stamp: 'len 5/20/2020 08:30:22' prior: 16913757! - fileDoesNotExistUserHandling: fullFileName - - | selection newName | - selection _ (PopUpMenu labels: -'create a new file -choose another name -cancel') - startUpWithCaption: fullFileName asFileEntry name, ' -does not exist.'. - selection = 1 ifTrue: - [^ self new open: fullFileName forWrite: true]. - selection = 2 ifTrue: - [ newName _ self request: 'Enter a new file name' - initialAnswer: fullFileName. - ^ FileIOAccessor default privateWriteableFile: newName asFileEntry ]. - self halt! ! -!StandardFileStream class methodsFor: 'error handling' stamp: 'len 5/20/2020 08:30:28' prior: 16913776! - fileExistsUserHandling: fullFileName - | dir localName choice newName entry | - entry _ fullFileName asFileEntry. - dir _ entry parent. - localName _ entry name. - choice _ (PopUpMenu - labels: -'overwrite that file\choose another name\cancel' withNewLines) - startUpWithCaption: localName, ' -already exists.'. - - choice = 1 ifTrue: [ - dir removeKey: localName - ifAbsent: [self error: 'Could not delete the old version of that file']. - ^ self new open: fullFileName forWrite: true]. - - choice = 2 ifTrue: [ - newName _ self request: 'Enter a new file name' initialAnswer: fullFileName. - ^ FileIOAccessor default privateNewFile: newName asFileEntry ]. - - self error: 'Please close this to abort file opening'! ! -!StandardFileStream class methodsFor: 'error handling' stamp: 'len 5/20/2020 08:31:13' prior: 50425022! - readOnlyFileDoesNotExistUserHandling: fullFileName - - | dir files choices selection newName fileName | - dir _ fullFileName asFileEntry parent. - files _ dir fileNames. - fileName _ fullFileName asFileEntry name. - choices _ fileName correctAgainst: files. - choices add: 'Choose another name'. - choices add: 'Cancel'. - selection _ (PopUpMenu labelArray: choices lines: (Array with: 5) ) - startUpWithCaption: fullFileName asFileEntry name, ' -does not exist.'. - selection = choices size ifTrue:["cancel" ^ nil "should we raise another exception here?"]. - selection < (choices size - 1) ifTrue: [ - newName _ (dir pathName , '/', (choices at: selection))]. - selection = (choices size - 1) ifTrue: [ - newName _ self request: 'Enter a new file name' initialAnswer: fileName. - "If Cancel was pressed, no file should be opened - Hernan" - newName isEmpty ifTrue: [ ^nil ]]. - newName = '' ifFalse: [^ FileIOAccessor default privateReadOnlyFile: newName asFileEntry ]. - ^ self error: 'Could not open a file'! ! -!SmartRefStream methodsFor: 'class changed shape' stamp: 'len 5/20/2020 08:30:12' prior: 16911567! - writeClassRenameMethod: sel was: oldName fromInstVars: oldList - "The class coming is unknown. Ask the user for the existing class it maps to. If got one, write a method, and restart the obj fileIn. If none, write a dummy method and get the user to complete it later. " - - | tell choice newName answ code oldVer newList newVer instSel | - self flag: #bobconv. - tell := 'Reading an instance of ' , oldName - , '. -Which modern class should it translate to?'. - answ := (PopUpMenu - labels: 'Let me type the name now -Let me think about it -Let me find a conversion file on the disk') - startUpWithCaption: tell. - answ = 1 - ifTrue: [ - tell := 'Name of the modern class {1} should translate to:' format: {oldName}. - choice := self request: tell initialAnswer: ''. "class name" - choice size = 0 - ifTrue: [answ := 'conversion method needed'] - ifFalse: - [newName := choice. - answ := Smalltalk at: newName asSymbol - ifAbsent: ['conversion method needed']. - answ class == String - ifFalse: [renamed at: oldName asSymbol put: answ name]]]. - answ = 3 | (answ = 0) - ifTrue: [ - byteStream close. - ^'conversion method needed']. - answ = 2 ifTrue: [answ := 'conversion method needed']. - answ = 'conversion method needed' - ifTrue: [ - byteStream close. - newName := 'PutNewClassHere']. - answ class == String - ifFalse: - [oldVer := self versionSymbol: (structures at: oldName). - newList := (Array with: answ classVersion) , answ allInstVarNames. - newVer := self versionSymbol: newList. - instSel := 'convert' , oldVer , ':' , newVer , ':']. - code := WriteStream on: (String new: 500). - code - nextPutAll: sel; - newLine. - answ class == String - ifFalse: [ - code - newLine; - tab; - nextPutAll: 'reshaped at: #' , oldName , ' put: #' , instSel , '.'. - code - newLine; - tab; - tab; - nextPutAll: '"Be sure to define that conversion method in class ' - , answ name , '"']. - code - newLine; - tab; - nextPutAll: '^ ' , newName. "Return new class" - self class compile: code contents classified: 'conversion'. - newName = 'PutNewClassHere' - ifTrue: [ - self - inform: 'Please complete the following method and -then read-in the object file again.'. - Smalltalk browseAllImplementorsOf: sel asSymbol]. - self flag: #violateBasicLayerPrinciples. - "SmartRefStream should not refer to UI!!!!!!!!!! (sd)" - - "The class version number only needs to change under one specific circumstance. That is when the first letters of the instance variables have stayed the same, but their meaning has changed. A conversion method is needed, but this system does not know it. - If this is true for class Foo, define classVersion in Foo class. - Beware of previous object fileouts already written after the change in meaning, but before bumping the version number. They have the old (wrong) version number, say 2. If this is true, your method must be able to test the data and successfully read files that say version 2 but are really 3." - ^answ! ! -!Parser methodsFor: 'error correction' stamp: 'len 5/20/2020 08:28:19' prior: 16886638! - defineClass: className - "prompts the user to define a new class, - asks for it's category, and lets the users edit further - the definition" - | sym cat def d2 | - sym := className asSymbol. - cat := self request: 'Enter class category : ' initialAnswer: self encoder classEncoding theNonMetaClass category. - cat - ifEmpty: [cat := 'Unknown']. - def := 'Object subclass: #' , sym , ' - instanceVariableNames: '''' - classVariableNames: '''' - poolDictionaries: '''' - category: ''' , cat , ''''. - d2 := self request: 'Edit class definition : ' initialAnswer: def. - d2 - ifEmpty: [d2 := def]. - Compiler evaluate: d2. - ^ encoder - global: (Smalltalk associationAt: sym) - name: sym! ! -!TextEditor methodsFor: 'menu messages' stamp: 'len 5/20/2020 06:23:28' prior: 16932150! - find - "Prompt the user for a string to search for, and search the receiver from the current selection onward for it. 1/26/96 sw" - - self - request: 'Find what?' - initialAnswer: self class findText - do: [:aString| - aString isEmpty ifFalse: - ["Set focus on our text morph, so that cmd-g does the search again" - morph world activeHand newKeyboardFocus: morph. - self setSearch: aString. - ChangeText _ self class findText. "Implies no replacement to againOnce: method" - (self findAndReplaceMany: false) - ifFalse: [ self flash ]]]. - -" morph installEditorToReplace: self"! ! -!Utilities class methodsFor: 'identification' stamp: 'len 5/22/2020 04:30:45' prior: 16940801! - setAuthor - "Put up a dialog allowing the user to specify the author's initials. - Utilities setAuthor - " - | authorName | - AuthorInitials _ (self - request: 'Please type your initials: ' - initialAnswer: (AuthorInitials ifNil: [''])) withBlanksTrimmed. - authorName _ (Smalltalk knownInitialsAndNames - detect: [ :pair | - pair first = AuthorInitials ] - ifNone: [ - AuthorName _ (self - request: 'Please type your name:' - initialAnswer: 'Your Name') withBlanksTrimmed. - ^ self ]) second withBlanksTrimmed. - (self confirm: 'Are you ' , authorName , '?') - ifTrue: [ AuthorName _ authorName ] - ifFalse: [ - self inform: 'Please enter different initials, then'. - self setAuthor ]! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'len 5/20/2020 05:09:58' prior: 16875706! - editBalloonHelpContent: aString - self - request: 'Edit the balloon help text for ' , (self printStringLimitedTo: 40) - initialAnswer: (aString ifNil: [self noHelpString] ifNotNil: [aString]) - do: [:reply| - (reply isEmpty or: [reply asString = self noHelpString]) - ifTrue: [self setBalloonText: nil] - ifFalse: [self setBalloonText: reply]]! ! -!Morph methodsFor: 'menus' stamp: 'len 5/20/2020 06:16:32' prior: 16876285! - exportAsBMP - "Export the receiver's image as a BMP." - self request: 'Enter file name' - initialAnswer: (self printStringLimitedTo: 20),'.bmp' - do: [:aString| (self imageForm: 32) writeBMPfileNamed: aString]! ! -!Morph methodsFor: 'menus' stamp: 'len 5/20/2020 06:16:41' prior: 16876294! - exportAsJPEG - "Export the receiver's image as a JPEG." - self request: 'Enter file name' - initialAnswer: (self printStringLimitedTo: 20),'.jpeg' - do: [:aString| (self imageForm: 32) writeJPEGfileNamed: aString]! ! -!SystemWindow methodsFor: 'label' stamp: 'len 5/20/2020 06:20:49' prior: 16926337! - relabel - self request: 'New title for this window' initialAnswer: labelString verifying: [:aString| aString notEmpty] do: [:aString| self setLabel: aString]! ! -!SystemWindow methodsFor: 'user interface' stamp: 'len 5/20/2020 06:57:02' prior: 50448407! - saveContents - "Prompts the user for a file name and saves the contents to the file" - self hasSaveAs ifFalse: [^self]. - self request: 'Enter file name' initialAnswer: '' verifying: [:aString| aString notEmpty] do: [:fileName| self saveContentsTo: fileName]! ! -!CodePackageListWindow methodsFor: 'commands' stamp: 'len 5/20/2020 04:08:36' prior: 16811622! - createPackage - self request: 'Name for new package?' do: [:aString| - aString ifNotEmpty: - [CodePackage - named: aString - createIfAbsent: true - registerIfNew: true]]! ! -!CodeWindow methodsFor: 'misc' stamp: 'len 5/20/2020 08:09:08' prior: 16813655! - getSelectorAndSendQuery: querySelector to: queryPerformer with: queryArgs - "Obtain a selector relevant to the current context, and then send the querySelector to the queryPerformer with the selector obtained and queryArgs as its arguments. If no message is currently selected, then obtain a method name from a user type-in" - - | strm array | - strm _ WriteStream on: (array _ Array new: queryArgs size + 1). - strm nextPut: nil. - strm nextPutAll: queryArgs. - - model selectedMessageName ifNil: [ | selector | - selector _ self request: 'Type selector:' initialAnswer: 'flag:'. - ^ selector isEmpty ifFalse: [ - (Symbol hasInterned: selector - ifTrue: [ :aSymbol | - array at: 1 put: aSymbol. - queryPerformer perform: querySelector withArguments: array]) - ifFalse: [ self inform: 'no such selector'] - ] - ]. - - self selectMessageAndEvaluate: [:selector | - array at: 1 put: selector. - queryPerformer perform: querySelector withArguments: array - ]! ! -!CodeWindow methodsFor: 'misc' stamp: 'len 5/20/2020 08:15:43' prior: 16813720! - sendQuery: querySelector to: queryPerformer - "Apply a query to the primary selector associated with the current context. If no such selection exists, obtain one by user type-in. Then send querySelector to queryPerformer with the selector as its argument." - - model selectedMessageName ifNotNil: [^ queryPerformer perform: querySelector with: querySelector]. - self request: 'Type selector:' initialAnswer: 'flag:' verifying: [:aString| aString notEmpty] do: [:aString| - (Symbol hasInterned: aString ifTrue: [ :aSymbol | queryPerformer perform: querySelector with: aSymbol]) - ifFalse: [self inform: 'no such selector']]! ! -!CodeWindow methodsFor: 'misc' stamp: 'len 5/20/2020 08:15:27' prior: 16813743! -useSelector: incomingSelector orGetSelectorAndSendQuery: querySelector to: queryPerformer - "If incomingSelector is not nil, use it, else obtain a selector from user type-in. Using the determined selector, send the query to the performer provided." - - incomingSelector ifNotNil: [^ queryPerformer perform: querySelector with: incomingSelector]. - self request: 'Type selector:' initialAnswer: 'flag:' verifying: [:aString| aString notEmpty] do: [:aString| - (Symbol hasInterned: aString ifTrue: [:aSymbol| queryPerformer perform: querySelector with: aSymbol]) - ifFalse: [self inform: 'no such selector']]! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'len 5/19/2020 15:57:32' prior: 50448713! - buildMorphicWindow - "Create a pluggable version of all the morphs for a Browser in Morphic" - - | upperPanes messageCatList messageList systemCatList classList | - - systemCatList _ self buildMorphicSystemCatList. - classList _ self buildMorphicClassList. - messageCatList _ self buildMorphicMessageCatList. - messageList _ self buildMorphicMessageList. - - systemCatList rightSibling: classList. - classList leftSibling: systemCatList rightSibling: messageCatList. - messageCatList leftSibling: classList rightSibling: messageList. - messageList leftSibling: messageCatList. - -" classList makeItemsDraggable." - systemCatList - acceptDropsFrom: classList - performing: #categorizeUnderCategoryAt:class: - whenOutsideList: #categorizeUnderNewCategoryClass:. - -" messageList makeItemsDraggable." - messageCatList - acceptDropsFrom: messageList - performing: #categorizeUnderCategoryAt:selector: - whenOutsideList: #categorizeUnderNewCategorySelector:. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: systemCatList proportionalWidth: 0.2; - addAdjusterAndMorph: (self buildMorphicClassColumnWith: classList) proportionalWidth: 0.2; - addAdjusterAndMorph: messageCatList proportionalWidth: 0.2; - addAdjusterAndMorph: messageList proportionalWidth: 0.4. - - self layoutMorph - addMorph: upperPanes proportionalHeight: 0.3; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.7. - - model changed: #editSelection! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'len 5/19/2020 15:57:45' prior: 50493831! - buildNoSysCatMorphicWindow - "A Browser without the class categories list" - - | mySingletonList upperPanes messageCatList messageList classColumn classList | - mySingletonList _ PluggableListMorph - model: model - listGetter: #systemCategorySingleton - indexGetter: #indexIsOne - indexSetter: #indexIsOne: - mainView: self - menuGetter: #systemCatSingletonMenu - keystrokeAction: #systemCatSingletonKey:from:. - mySingletonList hideScrollBarsIndefinitely. - - classList _ self buildMorphicClassList. - classColumn _ self buildMorphicClassColumnWith: classList. - messageCatList _ self buildMorphicMessageCatList. - messageList _ self buildMorphicMessageList. - - classList rightSibling: messageCatList. - messageCatList leftSibling: classList rightSibling: messageList. - messageList leftSibling: messageCatList. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: classColumn proportionalWidth: 0.3; - addAdjusterAndMorph: messageCatList proportionalWidth: 0.3; - addAdjusterAndMorph: messageList proportionalWidth: 0.4. - -" messageList makeItemsDraggable." - messageCatList - acceptDropsFrom: messageList - performing: #categorizeUnderCategoryAt:selector: - whenOutsideList: #categorizeUnderNewCategorySelector:. - - self layoutMorph - addMorph: mySingletonList fixedHeight: Preferences standardCodeFont lineSpacing + 10; - addAdjusterAndMorph: upperPanes proportionalHeight: 0.3; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.7. - - model changed: #editSelection! ! -!BrowserWindow class methodsFor: 'GUI building' stamp: 'len 5/20/2020 06:06:03' prior: 50446802! - findClassFrom: potentialClassNames ifFound: aBlock - | classNames exactMatch foundClass index toMatch | - ClassNameRequestMorph request: 'Class name or fragment?' initialAnswer: '' do: [:pattern| - pattern isEmpty - ifTrue: [self flash] - ifFalse: - [toMatch _ (pattern copyWithout: $.) asLowercase withBlanksTrimmed. - classNames _ (pattern last = $. or: [pattern last = $ ]) - ifTrue: [potentialClassNames select: [:nm | nm asLowercase = toMatch]] - ifFalse: [potentialClassNames select: [:n | n includesSubstring: toMatch caseSensitive: false]]. - classNames isEmpty - ifTrue: [self flash] - ifFalse: - [exactMatch _ classNames detect: [ :each | each asLowercase = toMatch] ifNone: nil. - - index _ classNames size = 1 - ifTrue: [ 1 ] - ifFalse: [ exactMatch - ifNil: [(PopUpMenu labelArray: classNames lines: #()) startUpMenu] - ifNotNil: [classNames addFirst: exactMatch. - (PopUpMenu labelArray: classNames lines: #(1)) startUpMenu]]. - - index = 0 - ifTrue: [self flash] - ifFalse: - [foundClass _ Smalltalk at: (classNames at: index) asSymbol. - - aBlock value: foundClass]]]]! ! -!CodeFileBrowserWindow methodsFor: 'commands' stamp: 'len 5/20/2020 06:54:25' prior: 50493261 overrides: 50447135! - findClass - | pattern foundClass classNames index foundCodeFile | - self okToChange ifFalse: [^ self flash]. - self request: 'Class name?' do: [:aString| - aString isEmpty ifFalse: - [pattern _ aString asLowercase. - classNames _ Set new. - classNames addAll: model caseCodeSource classDictionary keys. - classNames _ classNames asArray select: - [:n | (n asLowercase indexOfSubCollection: pattern startingAt: 1) > 0]. - classNames isEmpty ifFalse: - [index _ classNames size = 1 - ifTrue: [1] - ifFalse: [(PopUpMenu labelArray: classNames lines: #()) startUpMenu]. - index = 0 ifFalse: - [foundCodeFile _ nil. - foundClass _ nil. - (model caseCodeSource classDictionary includesKey: (classNames at: index)) - ifTrue: - [foundClass := model caseCodeSource classDictionary at: (classNames at: index). - foundCodeFile := model caseCodeSource]. - foundClass ifNotNil: - [model systemCategoryListIndex: (model systemCategoryList indexOf: foundCodeFile name asSymbol). - model classListIndex: (model classList indexOf: foundClass name)]]]]]! ! -!MessageSetWindow class methodsFor: 'opening' stamp: 'len 5/20/2020 04:09:03' prior: 50481437! - findInSourceCode - self request: 'Text to search source code for?' do: [:aString| - Smalltalk browseMethodsWithSourceString: aString]! ! -!ChangeSelectorWizardStepWindow methodsFor: 'actions' stamp: 'len 5/20/2020 05:59:49' prior: 50438171! - do: aBlock withEnteredClassLabeled: aLabel - ClassNameRequestMorph - request: aLabel - initialAnswer: '' - do: [:className| self withClassNamed: className do: aBlock]! ! -!ChangeSelectorSendersStepWindow methodsFor: 'actions' stamp: 'len 5/20/2020 08:07:14' prior: 50438412! - askAndAddSenderOf: classOfSenderToAdd - - | senderSelector senderToAdd | - - senderSelector := self request: 'Selector of sender of #', self oldSelector initialAnswer: '' orCancel: [^self ]. - senderToAdd := classOfSenderToAdd - compiledMethodAt: senderSelector asSymbol - ifAbsent: [ ^self inform: classOfSenderToAdd doesNotImplement: senderSelector asSymbol]. - - (senderToAdd sendsOrRefersTo: self oldSelector) ifFalse: [ ^self inform: senderToAdd classAndSelector, ' does not refer to #', self oldSelector ]. - - self addToList: senderToAdd ! ! -!DebuggerWindow methodsFor: 'menu commands' stamp: 'len 5/20/2020 05:04:59' prior: 16831221! - returnValue - self request: 'Enter expression for return value:' do: [:aString| model returnValue: aString]! ! -!InspectorWindow methodsFor: 'menu commands' stamp: 'len 5/20/2020 05:08:06' prior: 16857283! - addEntry - self request: -'Enter new key, then type RETURN. -(Expression will be evaluated for value.) -Examples: #Fred ''a string'' 3+4' - do: [:aString| - model addEntry: (Compiler evaluate: aString)]! ! -!InspectorWindow methodsFor: 'menu commands' stamp: 'len 5/20/2020 06:15:29' prior: 16857364! - renameEntry - self request: -'Enter new key, then type RETURN. -(Expression will be evaluated for value.) -Examples: #Fred ''a string'' 3+4' - initialAnswer: model selectedKey printString - do: [:aString| aString isEmpty ifFalse: [model renameEntryTo: (Compiler evaluate: aString)]]! ! -!ProcessBrowserWindow methodsFor: 'menu commands' stamp: 'len 5/20/2020 07:34:54' prior: 16895419! - changePriority - | newPriority rule | - rule _ (model class rulesFor: model selectedProcess) second. - rule - ifFalse: [self inform: 'Nope, won''t change priority of ' , model selectedProcess name. - ^ self]. - self request: 'New priority' - initialAnswer: model selectedProcess priority asString - verifying: [:aString| ([aString asNumber asInteger] on: Error do: []) isInteger] - do: [:aString| - newPriority _ aString asNumber asInteger. - (newPriority between: 1 and: Processor highestPriority) - ifTrue: - [model class setProcess: model selectedProcess toPriority: newPriority. - model updateProcessList] - ifFalse: [self inform: 'Bad priority']]! ! -!ProcessBrowserWindow methodsFor: 'menu commands' stamp: 'len 5/20/2020 07:35:42' prior: 16895469! - findContext - self request: 'Enter a string to search for in the process stack lists' - initialAnswer: model searchString - do: [:searchString| model findContext: searchString]! ! -!ImageMorph methodsFor: 'menu commands' stamp: 'len 5/20/2020 06:17:35' prior: 16854152! - readFromFile - self request: 'Enter file name' - initialAnswer: 'fileName' - do: [:fileName| self image: (Form fromFileNamed: fileName)]! ! -!TheWorldMenu methodsFor: 'commands' stamp: 'len 5/20/2020 04:09:37' prior: 16934644! - saveWorldInFile - "Save the world's submorphs, model, and stepList in a file. " - - self request: 'File name for this morph?' do: [ :fileName | - fileName isEmpty ifTrue: [^ self]. "abort" - "Save only model, stepList, submorphs in this world" - myWorld submorphsDo: [ :m | m allMorphsDo: [ :subM | subM prepareToBeSaved ]]. "Amen" - (fileName, '.morph') asFileEntry writeStreamDo: [ :fileStream | - fileStream fileOutObject: myWorld ]]! ! -!TextComposition methodsFor: 'display' stamp: 'len 5/19/2020 05:56:06' prior: 16930849! - displaySelectionStartBlock: startBlock stopBlock: stopBlock InLine: line on: aCanvas textTopLeft: textTopLeft selectionColor: sc - "textTopLeft is relative to the morph currently being drawn" - - | leftX rightX idx textCursorFont t b textCursorAttributes | - - startBlock ifNil: [^self]. "No selection" - startBlock = stopBlock - ifTrue: [ - "Only show text cursor on line where clicked" - startBlock textLine first = line first ifFalse: [ - ^self ]. - showTextCursor ifTrue: [ - leftX _ textTopLeft x + startBlock left. - idx _ startBlock stringIndex. - textCursorAttributes _ editor ifNotNil: [ editor currentAttributes ]. - textCursorFont _ textCursorAttributes - ifNil: [ model actualContents fontAt: idx default: self defaultFont ] - ifNotNil: [ model actualContents fontIfApplying: textCursorAttributes default: self defaultFont ]. - b _ textTopLeft y + line top + line baseline + textCursorFont descent-1. - t _ textTopLeft y + line top + line baseline - textCursorFont ascent+1. - lastTextCursorRect _ nil. - self - displayTextCursorAtX: leftX - top: t - bottom: b - emphasis: textCursorFont emphasis - on: aCanvas - textLeft: textTopLeft x ]] - ifFalse: [ - "Test entire selection before or after here" - (stopBlock stringIndex < line first - or: [startBlock stringIndex > (line last + 1)]) - ifTrue: [^self]. "No selection on this line" - (stopBlock stringIndex = line first - and: [stopBlock textLine ~= line]) - ifTrue: [^self]. "Selection ends on line above" - (startBlock stringIndex = (line last + 1) - and: [stopBlock textLine ~= line]) - ifTrue: [^self]. - lastTextCursorRect _ nil. - leftX _ textTopLeft x + (startBlock stringIndex < line first - ifTrue: [ line ] - ifFalse: [ startBlock ]) left. - rightX _ textTopLeft x + ((stopBlock stringIndex > (line last + 1) or: [ - stopBlock stringIndex = (line last + 1) - and: [stopBlock textLine ~= line]]) - ifTrue: [line right] - ifFalse: [stopBlock left]). - aCanvas - fillRectangle: (leftX @ (line top + textTopLeft y) corner: rightX @ (line bottom + textTopLeft y)) - color: sc ]. "Selection begins on line below"! ! -!CodeFile methodsFor: 'fileIn/fileOut' stamp: 'len 5/20/2020 04:15:19' prior: 16808956! - fileOut - self request: 'Enter the file name' initialAnswer: '' do: [ :aString | - aString asFileEntry writeStreamDo: [ :stream | - sourceSystem isEmpty - ifFalse: [ stream nextChunkPut: sourceSystem printString; newLine ]. - self fileOutOn: stream. - stream newLine; newLine. - classes do: [ :cls | - cls needsInitialize - ifTrue: [ stream newLine; nextChunkPut: cls name,' initialize']]. - stream newLine ]]! ! -!RefactoringApplier methodsFor: 'request information' stamp: 'len 5/20/2020 05:00:03' prior: 50441430 overrides: 50513604! - request: aLabel initialAnswer: anAnswer - ^self request: aLabel initialAnswer: anAnswer orCancel: requestExitBlock ! ! - -RefactoringApplier removeSelector: #request:initialAnswer:onCancel:! - -!methodRemoval: RefactoringApplier #request:initialAnswer:onCancel: stamp: 'Install-4164-NonModalStringRequests-LucianoEstebanNotarfrancesco-2020May23-20h43m-len.001.cs.st 5/26/2020 17:09:07'! -request: aLabel initialAnswer: anAnswer onCancel: cancelBlock - - ^FillInTheBlankMorph request: aLabel initialAnswer: anAnswer onCancel: cancelBlock ! - -SystemDictionary removeSelector: #getFileNameFromUser! - -!methodRemoval: SystemDictionary #getFileNameFromUser stamp: 'Install-4164-NonModalStringRequests-LucianoEstebanNotarfrancesco-2020May23-20h43m-len.001.cs.st 5/26/2020 17:09:07'! -getFileNameFromUser - - | newName | - newName _ FillInTheBlankMorph - request: 'New File Name?' - initialAnswer: self imageName asFileEntry name. - newName isEmpty ifTrue: [ ^nil ]. - ((self fullNameForImageNamed: newName) asFileEntry exists or: [ - (self fullNameForChangesNamed: newName) asFileEntry exists ] ) ifTrue: [ - (self confirm: ('{1} already exists. Overwrite?' format: {newName})) - ifFalse: [ ^nil ]]. - ^newName -! - -Text class removeSelector: #fromUser! - -!methodRemoval: Text class #fromUser stamp: 'Install-4164-NonModalStringRequests-LucianoEstebanNotarfrancesco-2020May23-20h43m-len.001.cs.st 5/26/2020 17:09:07'! -fromUser - "Answer an instance of me obtained by requesting the user to type a string." - "Text fromUser" - - ^ self fromString: - (FillInTheBlankMorph request: 'Enter text followed by [Return]') -! - -Browser removeSelector: #request:initialAnswer:! - -!methodRemoval: Browser #request:initialAnswer: stamp: 'Install-4164-NonModalStringRequests-LucianoEstebanNotarfrancesco-2020May23-20h43m-len.001.cs.st 5/26/2020 17:09:07'! -request: prompt initialAnswer: initialAnswer - - ^ FillInTheBlankMorph - request: prompt - initialAnswer: initialAnswer -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4164-NonModalStringRequests-LucianoEstebanNotarfrancesco-2020May23-20h43m-len.001.cs.st----! - -'From Cuis 5.0 [latest update: #4163] on 23 May 2020 at 9:00:17 pm'! -!Object methodsFor: 'user interface' stamp: 'jmv 5/23/2020 21:00:08' prior: 50513632! - request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock - "This is deprecated because using it requires blocking the user interface until the user provides a response. Please use the variants that are not modal." - ^ UISupervisor ui request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock! ! -!Object methodsFor: 'user interface' stamp: 'jmv 5/23/2020 21:00:11' prior: 50513654! - request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock - ^ UISupervisor ui request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock! ! -!PasteUpMorph methodsFor: 'ui services' stamp: 'jmv 5/23/2020 21:00:01' overrides: 50515284! - request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock - "This is deprecated because using it requires blocking the user interface until the user provides a response. Please use the variants that are not modal." - ^ StringRequestMorph request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock! ! -!PasteUpMorph methodsFor: 'ui services' stamp: 'jmv 5/23/2020 21:00:05' overrides: 50515297! - request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock - ^ StringRequestMorph request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4165-AvoidMorphRefsInObject-JuanVuletich-2020May23-20h59m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4165] on 23 May 2020 at 9:08:32 pm'! -!FillInTheBlankMorph commentStamp: '' prior: 16844083! - A simple dialog with an entry field and accept / cancel buttons. - -This class is deprecated. Please use StringRequestMorph instead. This class will be deleted in the future.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4166-Mark-FillInTheBlankMorph-asObsolete-JuanVuletich-2020May23-21h07m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4166] on 24 May 2020 at 9:40:32 am'! -!StringRequestMorph class methodsFor: 'new-morph participation' stamp: 'KenD 5/23/2020 19:20:43' overrides: 16877229! - initializedInstance -" - StringRequestMorph initializedInstance. -" - | stringRequestMorph | - stringRequestMorph _ self - request: 'Enter answer here' - initialAnswer: 'What is the Answer?' - do: [:answer | PopUpMenu inform: answer ]. - ^stringRequestMorph! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4167-StringRequestMorph-new-morphParticipation-KenDickey-2020May24-09h38m-KenD.001.cs.st----! - -'From Cuis 5.0 [latest update: #4166] on 24 May 2020 at 9:41:25 am'! -!StringRequestMorph commentStamp: '' prior: 0! - This is a simple morph that allows the user to input a string. The user has the option to cancel (with the Esc key), or input a string and then accept (pressing Enter). For example: - - StringRequestMorph - request: 'What''s your name?' - initialAnswer: 'Jose' - do: [:aString| PopUpMenu inform: 'Hello ', aString, '!!'] - -Note that the request is not modal and a handler block must be provided. When the user accepts the input, the handler block is called with the user-provided string as argument. There's also the option to handle cancellation: - - StringRequestMorph - request: 'What''s your name?' - initialAnswer: 'Jose' - do: [:aString| PopUpMenu inform: 'Hello ', aString, '!!'] - orCancel: [PopUpMenu inform: 'Ok, nevermind'] - -And there's the option to provide a validation block that prevents from accepting invalid input: - - StringRequestMorph - request: 'Guess an even number between 1 and 3' - initialAnswer: '42' - verifying: [:aString| aString size > 0 and: [aString allSatisfy: [:each| each isDigit]]] - do: [:aString| PopUpMenu inform: (aString asInteger = 2 ifTrue: ['Yeah!!'] ifFalse: ['Nope'])] -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4168-StringRequestMorph-ClassComment-LucianoEstebanNotarfrancesco-2020May24-09h40m-len.001.cs.st----! - -'From Cuis 5.0 [latest update: #4166] on 24 May 2020 at 9:48:05 am'! -!Integer commentStamp: '' prior: 50510652! - I am a common abstract superclass for all Integer implementations. My implementation subclasses are SmallInteger, LargePositiveInteger, and LargeNegativeInteger. - -There are three implementations of division with remainder. For 'a' and 'b' Integers: - - Floored division, with the quotient rounded towards negative infinity: // and \\ answer 'q' and 'r' such that 'a = bq + r' with 'r abs < b abs', where 'r' is 0 or has the same sign as 'b'; - - Truncated division, with the quotient rounded towards zero: #quo: and #rem: answer 'q' and 'r' such that 'a = bq + r' with 'r abs < b abs', where 'r' is 0 or has the same sign as 'a'; - - Euclidean division with non-negative remainder: #div: and #mod: answer 'q' and 'r' such that 'a = bq + r' with '0 <= r < b abs'. - -Note that, strictly speaking, all of these divisions satisfy the definition of Euclidean division. The requirements imposed on the sign of the remainder (different for each type of division) guarantee a unique choice of quotient and remainder. - -Additionally, the division in the rational field is implemented with the message / that answers a Fraction 'a/b' if the result is not a whole integer.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4169-DivisionDocumentationFixed-LucianoEstebanNotarfrancesco-2020May24-09h41m-len.001.cs.st----! - -'From Cuis 5.0 [latest update: #4163] on 22 May 2020 at 7:13:13 am'! -!PasteUpMorph methodsFor: 'defaul desktop' stamp: 'len 5/22/2020 05:21:04' prior: 50495049! - recreateDefaultDesktop - | editor | - self whenUIinSafeState: [ - self hideTaskbar. - (submorphs - select: [ :ea | ea class == SystemWindow or: [ea class == TranscriptWindow]]) - do: [ :ea | ea delete ]. - TranscriptWindow openTranscript - morphPosition: 5 @ 290; - morphExtent: 990 @ 400. - editor _ TextEditor openTextEditor - morphPosition: 456 @ 10; - morphExtent: 900 @ 680. - editor setLabel: 'About Cuis'. - editor model actualContents: Utilities defaultTextEditorContents. - Theme current useTaskbar ifTrue: [self showTaskbar]. - ].! ! -!SystemWindow methodsFor: 'initialization' stamp: 'len 5/22/2020 05:29:29' prior: 16926321 overrides: 50379670! - openInWorld - "Ensure all widgets have proper colors before opening" - self widgetsColor: self windowColor. - super openInWorld! ! -!SystemWindow methodsFor: 'open/close' stamp: 'len 5/22/2020 05:30:12' prior: 16926561 overrides: 16876882! - delete - | thisWorld | - self okToChange ifFalse: [^self]. - thisWorld _ self world. - SystemWindow noteTopWindowIn: thisWorld but: self. - self sendToBack. - self removeHalo. - super delete. - self model: nil! ! - -Theme removeSelector: #windowClosed:! - -!methodRemoval: Theme #windowClosed: stamp: 'Install-4170-ThemeCleanupAndRespectTaksbarThemeSetting-LucianoEstebanNotarfrancesco-2020May22-05h14m-len.001.cs.st 5/26/2020 17:09:08'! -windowClosed: aSystemWindow - ^ self! - -Theme removeSelector: #windowOpen:! - -!methodRemoval: Theme #windowOpen: stamp: 'Install-4170-ThemeCleanupAndRespectTaksbarThemeSetting-LucianoEstebanNotarfrancesco-2020May22-05h14m-len.001.cs.st 5/26/2020 17:09:08'! -windowOpen: aSystemWindow - ^ self! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4170-ThemeCleanupAndRespectTaksbarThemeSetting-LucianoEstebanNotarfrancesco-2020May22-05h14m-len.001.cs.st----! - -'From Cuis 5.0 [latest update: #4170] on 24 May 2020 at 10:08:42 am'! -!PasteUpMorph methodsFor: 'geometry' stamp: 'jmv 5/24/2020 10:07:38' prior: 50500251 overrides: 16875287! - fontPreferenceChanged - self submorphsDo: [ :m | - m morphExtent: (m morphExtent max: m minimumExtent). - m fontPreferenceChanged ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4171-DontBeSoPedanticWithTheDefaultDesktop-JuanVuletich-2020May24-10h07m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4163] on 22 May 2020 at 7:49:10 pm'! -!Inspector methodsFor: 'constants' stamp: 'sqr 5/21/2020 18:34:19'! - indexHead - "This is the max index shown before skipping to the - last i2 elements of very long arrays" - ^ 500! ! -!Inspector methodsFor: 'constants' stamp: 'sqr 5/21/2020 18:41:19'! - indexLabelsForSize: aSize - - ^aSize <= self indexSize - ifTrue: [(1 to: aSize) collect: [:i | i printString]] - ifFalse: [(1 to: self indexHead) , (aSize - self indexTail + 1 to: aSize) collect: [:i | i printString]]! ! -!Inspector methodsFor: 'constants' stamp: 'sqr 5/21/2020 18:34:42'! - indexSize - ^self indexHead + self indexTail! ! -!Inspector methodsFor: 'constants' stamp: 'sqr 5/21/2020 18:34:25'! - indexTail - "This is the number of elements to show at the end - of very long arrays" - ^ 30! ! -!Inspector methodsFor: 'constants' stamp: 'sqr 5/21/2020 17:37:50'! - lastMetaField - "This value must be synchronized with the base field list, the - string selection indices, and the senders of this message" - - ^2! ! -!Inspector methodsFor: 'constants' stamp: 'sqr 5/21/2020 17:26:53'! - printStringLimit - - ^12000! ! -!Inspector methodsFor: 'constants' stamp: 'sqr 5/21/2020 17:30:31'! - stringSelectionIndices - - ^#(0 2)! ! -!Inspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 17:36:21'! - safelyPrintWith: aBlock - - ^aBlock - on: UnhandledError - do: - [:ex | - ex return: - (self printStringErrorText - addAttribute: TextColor red; - yourself) - ]! ! -!Inspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:52:35'! - selectedObjectIndex - "Answer the index of the inspectee's collection that the current selection refers to." - - | basicIndex | - basicIndex _ self selectionIndexNonMeta - self objectClassInstSize. - ^(self objectSize <= self indexSize or: [basicIndex <= self indexHead]) - ifTrue: [basicIndex] - ifFalse: [self objectSize - self indexSize + basicIndex]! ! -!Inspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:20:57'! - selectionIndexNonMeta - - ^self selectionIndex - self lastMetaField! ! -!Inspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:18:07'! - selectionIsMeta - - ^self selectionIndex <= self lastMetaField! ! -!Inspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:18:36'! - selectionIsUnmodifiable - "Answer if the current selected variable is modifiable via acceptance in the code pane. For most inspectors, no selection and a selection of self (selectionIndex = 1) are unmodifiable" - - ^self selectionIsMeta! ! -!Inspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:20:18'! - selectionMeta - "Answer the value of the selected meta field" - - self selectionIndex = 0 ifTrue: [^ '']. - self selectionIndex = 1 ifTrue: [^ object]. - self selectionIndex = 2 ifTrue: [^ self safelyPrintWith: [object longPrintStringLimitedTo: self printStringLimit]]. - ^self selectionMetaUnknown! ! -!Inspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:20:01'! - selectionMetaUnknown - - ^''! ! -!Inspector methodsFor: 'private' stamp: 'sqr 5/21/2020 18:51:48'! - objectClassInstSize - - ^object class instSize! ! -!Inspector methodsFor: 'private' stamp: 'sqr 5/21/2020 18:59:15'! - objectSize - - ^object basicSize! ! -!Inspector methodsFor: 'private' stamp: 'sqr 5/21/2020 18:18:45'! - printStringErrorFieldName - - ^self selectionIsUnmodifiable - ifTrue: ['self'] - ifFalse: [self selectedSlotName ifNil: ['??']]! ! -!CompiledMethodInspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:27:08' overrides: 50515620! - selectionIsUnmodifiable - "Answer if the current selected variable is unmodifiable via acceptance in the code pane. For most inspectors, no selection and a selection of self (selectionIndex = 1) are unmodifiable" - - ^ true! ! -!CompiledMethodInspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 19:09:37' overrides: 50515630! - selectionMeta - - self selectionIndex = 0 ifTrue: [^ '']. - self selectionIndex = 1 ifTrue: [^ object ]. - self selectionIndex = 2 ifTrue: [^ self safelyPrintWith: [object symbolic]]. - self selectionIndex = 3 ifTrue: [^ self safelyPrintWith: [object headerDescription]]. - ^self selectionMetaUnknown! ! -!CompiledMethodInspector methodsFor: 'constants' stamp: 'sqr 5/21/2020 17:55:47' overrides: 50515573! - lastMetaField - "This value must be synchronized with the base field list, the - string selection indices, and the senders of this message" - - ^3! ! -!CompiledMethodInspector methodsFor: 'constants' stamp: 'sqr 5/21/2020 17:57:32' overrides: 50515584! - stringSelectionIndices - - ^#(0 2 3)! ! -!DictionaryInspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:03:31'! - nonFixedSelectionIndex - ^self selectionIndex - self numberOfFixedFields! ! -!DictionaryInspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:01:20'! - selectionIndexFixed - ^self selectionIndex <= self numberOfFixedFields! ! -!DictionaryInspector methodsFor: 'constants' stamp: 'sqr 5/21/2020 17:57:08' overrides: 50515584! - stringSelectionIndices - - ^#(0)! ! -!OrderedCollectionInspector methodsFor: 'accessing' stamp: 'sqr 5/22/2020 19:47:10' overrides: 50515652! - objectSize - - ^object size! ! -!OrderedCollectionInspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 19:33:54' overrides: 16856992! - selectedSlotName - - self selectionIsMeta ifTrue: [^super selectedSlotName]. - self selectionIndexNonMeta <= self objectClassInstSize ifTrue: [^super selectedSlotName]. - ^'(self at: ', super selectedSlotName, ')'! ! -!Inspector methodsFor: 'accessing' stamp: 'sqr 5/21/2020 19:03:54' prior: 16856867! - fieldList - "Answer the base field list plus an abbreviated list of indices." - - object class isVariable ifFalse: [^ self baseFieldList]. - ^ self baseFieldList , (self indexLabelsForSize: self objectSize)! ! -!Inspector methodsFor: 'accessing' stamp: 'sqr 5/21/2020 18:18:41' prior: 16856897! - object: anObject - "Set anObject to be the object being inspected by the receiver." - - | oldIndex | - anObject == object - ifTrue: [self update] - ifFalse: - [oldIndex := self selectionIsUnmodifiable ifTrue: [selectionIndex] ifFalse: [0]. - self inspect: anObject. - oldIndex := oldIndex min: self fieldList size. - self changed: #inspectObject. - oldIndex > 0 - ifTrue: [self toggleIndex: oldIndex]. - self changed: #fieldList. - self acceptedContentsChanged ]! ! -!Inspector methodsFor: 'accessing' stamp: 'sqr 5/21/2020 18:18:50' prior: 16856914! - selectedClass - "Answer the class of the receiver's current selection" - - self selectionIsUnmodifiable ifTrue: [^ object class]. - ^ self selection class! ! -!Inspector methodsFor: 'accessing' stamp: 'sqr 5/21/2020 17:38:47' prior: 16856926! - update - "Reshow contents, assuming selected value may have changed." - - selectionIndex = 0 ifTrue: [^self]. - acceptedContentsCache _ self selectionPrintString. - self acceptedContentsChanged. - self changed: #selectionIndex! ! -!Inspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 19:01:51' prior: 16856963! - replaceSelectionValue: anObject - "The receiver has a list of variables of its inspected object. One of these - is selected. The value of the selected variable is set to the value, - anObject." - | si instVarIndex | - self selectionIsUnmodifiable ifTrue: [ - self toggleIndex: (si := selectionIndex). - self toggleIndex: si. - ^ object]. - instVarIndex := self selectionIndexNonMeta. - instVarIndex > self objectClassInstSize - ifFalse: [^ object instVarAt: instVarIndex put: anObject]. - object class isVariable or: [self error: 'Cannot replace selection']. - ^object basicAt: self selectedObjectIndex put: anObject! ! -!Inspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 19:01:10' prior: 16856997! - selection - "The receiver has a list of variables of its inspected object. - One of these is selected. Answer the value of the selected variable." - | index | - self selectionIsMeta ifTrue: [^self selectionMeta]. - self selectionIndexNonMeta <= self objectClassInstSize - ifTrue: [^ object instVarAt: self selectionIndexNonMeta]. - index _ self selectedObjectIndex. - ^object isString - ifTrue: [ object at: index ] - ifFalse: [ object basicAt: index ]! ! -!Inspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:30:40' prior: 16857030! - selectionPrintString - - (self stringSelectionIndices includes: self selectionIndex) ifTrue: [^self selection]. - ^self safelyPrintWith: [self selection printTextLimitedTo: self printStringLimit]! ! -!Inspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 19:16:57' prior: 16857048! - toggleIndex: anInteger - "The receiver has a list of variables of its inspected object. One of these - is selected. If anInteger is the index of this variable, then deselect it. - Otherwise, make the variable whose index is anInteger be the selected - item." - - selectionIndex := selectionIndex = anInteger ifTrue: [0] ifFalse: [anInteger]. - acceptedContentsCache _ self selectionPrintString. - self acceptedContentsChanged. - self changed: #selectionIndex! ! -!Inspector methodsFor: 'stepping' stamp: 'sqr 5/21/2020 17:43:15' prior: 16857091 overrides: 16882488! - stepAt: millisecondSinceLast - | newText | - newText := self selectionPrintString. - newText = acceptedContentsCache ifFalse: [ - acceptedContentsCache _ newText. - self acceptedContentsChanged ]! ! -!Inspector methodsFor: 'private' stamp: 'sqr 5/21/2020 17:46:30' prior: 16857082! - printStringErrorText - - ^('') asText! ! -!CompiledMethodInspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:28:30' prior: 16821748 overrides: 50515799! - selection - - | bytecodeIndex | - self selectionIsMeta ifTrue: [^self selectionMeta]. - self selectionIndexNonMeta <= object numLiterals - ifTrue: [ ^ object objectAt: selectionIndex - self lastMetaField + 1 ]. - bytecodeIndex _ selectionIndex - object numLiterals - self lastMetaField. - ^ object at: object initialPC + bytecodeIndex - 1! ! -!ContextInspector methodsFor: 'accessing' stamp: 'sqr 5/21/2020 18:54:07' prior: 16823498 overrides: 50515799! - selection - "The receiver has a list of variables of its inspected object. - One of these is selected. Answer the value of the selected variable." - | basicIndex | - self selectionIsMeta ifTrue: [^self selectionMeta]. - self selectionIndexNonMeta <= self objectClassInstSize - ifTrue: [^ object instVarAt: self selectionIndexNonMeta]. - basicIndex := self selectionIndexNonMeta - self objectClassInstSize. - ^object debuggerMap namedTempAt: basicIndex in: object -! ! -!DictionaryInspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:04:32' prior: 16833959 overrides: 50515777! - replaceSelectionValue: anObject - self selectionIndexFixed ifTrue: [^ super replaceSelectionValue: anObject]. - ^ object - at: (keyArray at: self nonFixedSelectionIndex) - put: anObject! ! -!DictionaryInspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:04:40' prior: 16833969! - selectedKey - "Create a browser on all senders of the selected key" - | i | - i _ self nonFixedSelectionIndex. - i > 0 ifFalse: [ ^ nil ]. - ^keyArray at: i! ! -!DictionaryInspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:04:52' prior: 16833977 overrides: 50515799! - selection - - self selectionIndexFixed ifTrue: [^ super selection]. - ^ object at: (keyArray at: self nonFixedSelectionIndex) ifAbsent: nil! ! -!DictionaryInspector methodsFor: 'menu' stamp: 'sqr 5/21/2020 18:04:11' prior: 16833985! - removeSelection - selectionIndex = 0 ifTrue: [^ self changed: #flash]. - object removeKey: (keyArray at: self nonFixedSelectionIndex). - selectionIndex := 0. - acceptedContentsCache _ ''. - self calculateKeyArray. - self changed: #inspectObject. - self changed: #selectionIndex. - self changed: #fieldList! ! -!DictionaryInspector methodsFor: 'menu' stamp: 'sqr 5/21/2020 18:05:08' prior: 16833998! - renameEntryTo: newKey - - | value | - value := object at: (keyArray at: self nonFixedSelectionIndex). - object removeKey: (keyArray at: self nonFixedSelectionIndex). - object at: newKey put: value. - self calculateKeyArray. - selectionIndex := self numberOfFixedFields + (keyArray indexOf: newKey). - self changed: #selectionIndex. - self changed: #inspectObject. - self changed: #fieldList. - self update! ! -!DictionaryInspector methodsFor: 'private' stamp: 'sqr 5/21/2020 18:54:20' prior: 16834014! - numberOfFixedFields - ^self lastMetaField + self objectClassInstSize! ! -!OrderedCollectionInspector methodsFor: 'accessing' stamp: 'sqr 5/22/2020 19:47:49' prior: 50367177 overrides: 50515731! -fieldList - - | fieldsHere | - object isNil ifTrue: [^#()]. - fieldsHere _ [self indexLabelsForSize: self objectSize] - on: UnhandledError - do: [:ex | ex return: #()]. - ^self baseFieldList , fieldsHere -" -OrderedCollection new inspect -(OrderedCollection newFrom: #(3 5 7 123)) inspect -(OrderedCollection newFrom: (1 to: 1000)) inspect -"! ! -!OrderedCollectionInspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:54:40' prior: 16884354 overrides: 50515777! - replaceSelectionValue: anObject - "The receiver has a list of variables of its inspected object. One of these - is selected. The value of the selected variable is set to the value, anObject." - - self selectionIndexNonMeta <= self objectClassInstSize - ifTrue: [^ super replaceSelectionValue: anObject]. - object at: self selectedObjectIndex put: anObject! ! -!OrderedCollectionInspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:53:08' prior: 16884382 overrides: 50515799! - selection - "The receiver has a list of variables of its inspected object. - One of these is selected. Answer the value of the selected variable." - - self selectionIndexNonMeta <= self objectClassInstSize ifTrue: [^ super selection]. - ^ object at: self selectedObjectIndex! ! -!SetInspector methodsFor: 'menu' stamp: 'sqr 5/21/2020 18:53:25' prior: 16907441! - removeSelection - selectionIndex <= self objectClassInstSize ifTrue: [^ self changed: #flash]. - object remove: self selection. - selectionIndex := 0. - acceptedContentsCache _ ''. - self changed: #inspectObject. - self changed: #fieldList. - self changed: #selectionIndex.! ! -!SetInspector methodsFor: 'selecting' stamp: 'sqr 5/21/2020 18:53:34' prior: 16907463 overrides: 50515799! - selection - self selectionIsMeta ifTrue: [^self selectionMeta]. - self selectionIndexNonMeta <= self objectClassInstSize - ifTrue: [^ object instVarAt: self selectionIndexNonMeta]. - ^ object array at: self arrayIndexForSelection! ! -!Float64Array methodsFor: 'inspecting' stamp: 'sqr 5/22/2020 19:48:34' prior: 16846169 overrides: 16881790! - inspectorClass - "Answer the class of the inspector to be used on the receiver. Called by inspect; - use basicInspect to get a normal (less useful) type of inspector." - - ^OrderedCollectionInspector! ! - -OrderedCollectionInspector removeSelector: #selectedObjectIndex! - -!methodRemoval: OrderedCollectionInspector #selectedObjectIndex stamp: 'Install-4172-InspectorRefactorAndFixes-AndresValloud-2020May22-19h44m-sqr.001.cs.st 5/26/2020 17:09:08'! -selectedObjectIndex - "Answer the index of the inspectee's collection that the current selection refers to." - - | basicIndex | - basicIndex _ selectionIndex - 2 - object class instSize. - ^ (object size <= (self i1 + self i2) or: [basicIndex <= self i1]) - ifTrue: [basicIndex] - ifFalse: [object size - (self i1 + self i2) + basicIndex]! - -DictionaryInspector removeSelector: #contentsIsString! - -!methodRemoval: DictionaryInspector #contentsIsString stamp: 'Install-4172-InspectorRefactorAndFixes-AndresValloud-2020May22-19h44m-sqr.001.cs.st 5/26/2020 17:09:08'! -contentsIsString - "Hacked so contents empty when deselected" - - ^ (selectionIndex = 0)! - -CompiledMethodInspector removeSelector: #selectionUnmodifiable! - -!methodRemoval: CompiledMethodInspector #selectionUnmodifiable stamp: 'Install-4172-InspectorRefactorAndFixes-AndresValloud-2020May22-19h44m-sqr.001.cs.st 5/26/2020 17:09:08'! -selectionUnmodifiable - "Answer if the current selected variable is unmodifiable via acceptance in the code pane. For most inspectors, no selection and a selection of self (selectionIndex = 1) are unmodifiable" - - ^ true! - -CompiledMethodInspector removeSelector: #contentsIsString! - -!methodRemoval: CompiledMethodInspector #contentsIsString stamp: 'Install-4172-InspectorRefactorAndFixes-AndresValloud-2020May22-19h44m-sqr.001.cs.st 5/26/2020 17:09:08'! -contentsIsString - "Hacked so contents empty when deselected" - - ^ #(0 2 3) includes: selectionIndex! - -Inspector removeSelector: #selectionUnmodifiable! - -!methodRemoval: Inspector #selectionUnmodifiable stamp: 'Install-4172-InspectorRefactorAndFixes-AndresValloud-2020May22-19h44m-sqr.001.cs.st 5/26/2020 17:09:08'! -selectionUnmodifiable - "Answer if the current selected variable is modifiable via acceptance in the code pane. For most inspectors, no selection and a selection of self (selectionIndex = 1) are unmodifiable" - - ^ selectionIndex <= 2! - -Inspector removeSelector: #contentsIsString! - -!methodRemoval: Inspector #contentsIsString stamp: 'Install-4172-InspectorRefactorAndFixes-AndresValloud-2020May22-19h44m-sqr.001.cs.st 5/26/2020 17:09:08'! -contentsIsString - "Hacked so contents empty when deselected and = long printString when item 2" - - ^ (selectionIndex = 2) | (selectionIndex = 0)! - -Inspector removeSelector: #i2! - -!methodRemoval: Inspector #i2 stamp: 'Install-4172-InspectorRefactorAndFixes-AndresValloud-2020May22-19h44m-sqr.001.cs.st 5/26/2020 17:09:08'! -i2 - "This is the number of elements to show at the end - of very long arrays" - ^ 30! - -Inspector removeSelector: #i1! - -!methodRemoval: Inspector #i1 stamp: 'Install-4172-InspectorRefactorAndFixes-AndresValloud-2020May22-19h44m-sqr.001.cs.st 5/26/2020 17:09:08'! -i1 - "This is the max index shown before skipping to the - last i2 elements of very long arrays" - ^ 500! - -Smalltalk removeClassNamed: #SequenceableCollectionInspector! - -!classRemoval: #SequenceableCollectionInspector stamp: 'Install-4172-InspectorRefactorAndFixes-AndresValloud-2020May22-19h44m-sqr.001.cs.st 5/26/2020 17:09:08'! -Inspector subclass: #SequenceableCollectionInspector - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Inspector'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4172-InspectorRefactorAndFixes-AndresValloud-2020May22-19h44m-sqr.001.cs.st----! - -'From Cuis 5.0 [latest update: #4164] on 22 May 2020 at 7:53:38 pm'! - -Smalltalk renameClassNamed: #OrderedCollectionInspector as: #SequenceableCollectionInspector! - -!classRenamed: #OrderedCollectionInspector as: #SequenceableCollectionInspector stamp: 'Install-4173-OrderedCollectionInspector-rename-AndresValloud-2020May22-19h53m-sqr.001.cs.st 5/26/2020 17:09:08'! -Smalltalk renameClassNamed: #OrderedCollectionInspector as: #SequenceableCollectionInspector! -!Float64Array methodsFor: 'inspecting' stamp: 'sqr 5/22/2020 19:53:21' prior: 50516018 overrides: 16881790! - inspectorClass - "Answer the class of the inspector to be used on the receiver. Called by inspect; - use basicInspect to get a normal (less useful) type of inspector." - - ^SequenceableCollectionInspector! ! -!FloatArray methodsFor: 'inspecting' stamp: 'sqr 5/22/2020 19:53:21' prior: 16846648 overrides: 16881790! - inspectorClass - "Answer the class of the inspector to be used on the receiver. Called by inspect; - use basicInspect to get a normal (less useful) type of inspector." - - ^SequenceableCollectionInspector! ! -!OrderedCollection methodsFor: 'inspecting' stamp: 'sqr 5/22/2020 19:53:21' prior: 16884066 overrides: 16881790! -inspectorClass - "Answer the class of the inspector to be used on the receiver. Called by inspect; - use basicInspect to get a normal (less useful) type of inspector." - - ^SequenceableCollectionInspector! ! -!AffineTransformation methodsFor: 'inspecting' stamp: 'sqr 5/22/2020 19:53:21' prior: 16778870 overrides: 16881790! - inspectorClass - "Answer the class of the inspector to be used on the receiver. Called by inspect; - use basicInspect to get a normal (less useful) type of inspector." - - ^SequenceableCollectionInspector! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4173-OrderedCollectionInspector-rename-AndresValloud-2020May22-19h53m-sqr.001.cs.st----! - -'From Cuis 5.0 [latest update: #4165] on 22 May 2020 at 6:01:28 pm'! -!Inspector methodsFor: 'initialization' stamp: 'sqr 5/22/2020 17:29:29'! - initializeEvents - - SystemChangeNotifier uniqueInstance - when: #classDefinitionChanged send: #classDefinitionChangedFrom:to: to: self! ! -!Inspector methodsFor: 'user interface support' stamp: 'sqr 5/22/2020 17:46:24'! - displayLabel - - | label | - label := [self object printStringLimitedTo: 64] - on: UnhandledError - do: [:ex | ex return: self objectClass printString, ' (printing failed)']. - "Note this is ambiguous: what happens with (Array with: Array)?" - (label includesSubString: self objectClass name) ifTrue: [^label]. - ^self objectClass name, ': ', label! ! -!Inspector methodsFor: 'user interface support' stamp: 'sqr 5/22/2020 17:58:49'! - suggestObjectSpecificMenuItemsFor: aMenu from: aWindow - - ^self! ! -!Inspector methodsFor: 'private' stamp: 'sqr 5/22/2020 17:30:31'! - classDefinitionChangedFrom: oldClass to: newClass - - self objectClass = newClass ifTrue: [self changed: #fieldList]! ! -!Inspector methodsFor: 'private' stamp: 'sqr 5/22/2020 17:20:22'! - objectClass - - ^self objectClass: self object! ! -!Inspector methodsFor: 'private - mirror interface' stamp: 'sqr 5/22/2020 17:19:32'! - object: anObject basicAt: index - "Answer the value of an indexable element in the argument anObject without sending - it a message. Fail if the argument index is not an Integer or is out of bounds, or if - anObject is not indexable. This mimics the action of the VM when it indexes an object. - Used to simulate the execution machinery by, for example, the debugger. - Primitive. See Object documentation whatIsAPrimitive." - - - index isInteger ifTrue: [self errorSubscriptBounds: index]. - index isNumber - ifTrue: [^self object: anObject basicAt: index asInteger] - ifFalse: [self errorNonIntegerIndex]! ! -!Inspector methodsFor: 'private - mirror interface' stamp: 'sqr 5/22/2020 17:19:26'! - object: anObject instVarAt: anIndex - "Primitive. Answer a fixed variable in an object. The numbering of the - variables corresponds to the named instance variables. Fail if the index - is not an Integer or is not the index of a fixed variable. Essential for the - debugger. See Object documentation whatIsAPrimitive." - - - "Access beyond fixed variables." - ^self object: anObject basicAt: anIndex - (self objectClass: anObject) instSize! ! -!Inspector methodsFor: 'private - mirror interface' stamp: 'sqr 5/22/2020 17:19:03'! - objectClass: anObject - - - self primitiveFailed! ! -!Inspector methodsFor: 'private - mirror interface' stamp: 'sqr 5/22/2020 17:19:20'! - objectSize: anObject - "Answer the number of indexable variables in the argument anObject without sending - it a message. This mimics the action of the VM when it fetches an object's variable size. - Used to simulate the execution machinery by, for example, the debugger. - Primitive. See Object documentation whatIsAPrimitive." - - - "The number of indexable fields of fixed-length objects is 0" - ^0! ! -!DictionaryInspector methodsFor: 'user interface support' stamp: 'sqr 5/22/2020 17:59:18' overrides: 50516223! - suggestObjectSpecificMenuItemsFor: aMenu from: aWindow - - aMenu addItemsFromDictionaries: aWindow menuOptionsForDictionary! ! -!SetInspector methodsFor: 'user interface support' stamp: 'sqr 5/22/2020 17:59:43' overrides: 50516223! - suggestObjectSpecificMenuItemsFor: aMenu from: aWindow - - aMenu addItemsFromDictionaries: aWindow menuOptionsForSet! ! -!Object methodsFor: 'inspecting' stamp: 'sqr 5/22/2020 17:57:17' prior: 16881767! - basicInspect - "Create and schedule an Inspector in which the user can examine the - receiver's variables. This method should not be overriden." - - Inspector openOn: self! ! -!Inspector methodsFor: 'initialization' stamp: 'sqr 5/22/2020 17:29:42' prior: 16857107 overrides: 16896425! - initialize - - super initialize. - acceptedContentsCache _ ''. - selectionIndex := 0. - self initializeEvents! ! -!Inspector methodsFor: 'private' stamp: 'sqr 5/22/2020 17:20:12' prior: 50515648! - objectClassInstSize - - ^self objectClass instSize! ! -!Inspector methodsFor: 'private' stamp: 'sqr 5/22/2020 17:20:38' prior: 50515652! - objectSize - - ^self objectSize: self object! ! -!InspectorWindow methodsFor: 'GUI building' stamp: 'sqr 5/22/2020 17:26:00' prior: 50467394! - buildMorphicWindow - " Inspector openOn: SystemOrganization " - | contentsText list upperRow evaluatorText | - - "Build widgets. We'll assemble them below." - list _ self buildList. - contentsText _ self buildContentsText. - evaluatorText _ self buildEvaluatorText. - - "Upper row has two widgets, side by side: the list of variables at the left side, and the variable contents pane at the right side." - upperRow _ LayoutMorph newRow. - upperRow - addMorph: list proportionalWidth: 0.3; - addAdjusterAndMorph: contentsText proportionalWidth: 0.7. - "Inspector Window has two rows: At the top, the one we just bult. Below it, the evaluation pane." - self layoutMorph - addMorph: upperRow proportionalHeight: 0.7; - addAdjusterAndMorph: evaluatorText proportionalHeight: 0.3. - "Set label" - self setLabel: model displayLabel! ! -!InspectorWindow methodsFor: 'menu building' stamp: 'sqr 5/22/2020 17:44:18' prior: 50495500! - fieldListMenu - "Arm the supplied menu with items for the field-list of the receiver" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addItemsFromDictionaries: self basicMenuOptions. - self model suggestObjectSpecificMenuItemsFor: aMenu from: self. - aMenu addItemsFromDictionaries: self menuOptionsForBrowsing. - ^ aMenu! ! - -InspectorWindow removeSelector: #classDefinitionChangedFrom:to:! - -!methodRemoval: InspectorWindow #classDefinitionChangedFrom:to: stamp: 'Install-4174-Inspector-MirrorPrimitives-AndresValloud-2020May22-17h15m-sqr.001.cs.st 5/26/2020 17:09:08'! -classDefinitionChangedFrom: oldClass to: newClass - - model ifNotNil: [ model object class = newClass ifTrue: [ model changed: #fieldList ]]! - -InspectorWindow removeSelector: #addCollectionSpecificMenuOptionsTo:! - -!methodRemoval: InspectorWindow #addCollectionSpecificMenuOptionsTo: stamp: 'Install-4174-Inspector-MirrorPrimitives-AndresValloud-2020May22-17h15m-sqr.001.cs.st 5/26/2020 17:09:08'! -addCollectionSpecificMenuOptionsTo: aMenu - - | object | - object _ model object. - (object is: #Dictionary) ifTrue: [ - aMenu addItemsFromDictionaries: self menuOptionsForDictionary ] - ifFalse: [ (object is: #Set) ifTrue: [ - aMenu addItemsFromDictionaries: self menuOptionsForSet ]]! - -InspectorWindow removeSelector: #model:! - -!methodRemoval: InspectorWindow #model: stamp: 'Install-4174-Inspector-MirrorPrimitives-AndresValloud-2020May22-17h15m-sqr.001.cs.st 5/26/2020 17:09:08'! -model: aModel - - super model: aModel. - model ifNotNil: [ - SystemChangeNotifier uniqueInstance - when: #classDefinitionChanged send: #classDefinitionChangedFrom:to: to: self ] -! - -Inspector removeSelector: #suggestObjectSpecificMenuItemsTo:for:! - -Smalltalk removeClassNamed: #BasicInspector! - -!classRemoval: #BasicInspector stamp: 'Install-4174-Inspector-MirrorPrimitives-AndresValloud-2020May22-17h15m-sqr.001.cs.st 5/26/2020 17:09:08'! -Inspector subclass: #BasicInspector - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Inspector'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4174-Inspector-MirrorPrimitives-AndresValloud-2020May22-17h15m-sqr.001.cs.st----! - -'From Cuis 5.0 [latest update: #4166] on 23 May 2020 at 8:15:03 pm'! -!ProtoObject methodsFor: 'testing' stamp: 'jmv 5/23/2020 19:54:19'! - isObject - ^false! ! -!Object methodsFor: 'testing' stamp: 'jmv 5/23/2020 19:54:03' overrides: 50516444! - isObject - ^true! ! -!Inspector methodsFor: 'accessing' stamp: 'jmv 5/23/2020 19:59:02' prior: 16856846! - baseFieldList - "Answer an Array consisting of 'self' - and the instance variable names of the inspected object." - - ^ (Array with: 'self' with: 'all inst vars') - , self objectClass allInstVarNames! ! -!Inspector methodsFor: 'accessing' stamp: 'jmv 5/23/2020 19:59:18' prior: 50515731! - fieldList - "Answer the base field list plus an abbreviated list of indices." - - self objectClass isVariable ifFalse: [^ self baseFieldList]. - ^ self baseFieldList , (self indexLabelsForSize: self objectSize)! ! -!Inspector methodsFor: 'accessing' stamp: 'jmv 5/23/2020 19:59:47' prior: 50515759! - selectedClass - "Answer the class of the receiver's current selection" - - self selectionIsUnmodifiable ifTrue: [^ self objectClass]. - ^ self selection class! ! -!Inspector methodsFor: 'selecting' stamp: 'jmv 5/23/2020 19:59:34' prior: 50515777! - replaceSelectionValue: anObject - "The receiver has a list of variables of its inspected object. One of these - is selected. The value of the selected variable is set to the value, - anObject." - | si instVarIndex | - self selectionIsUnmodifiable ifTrue: [ - self toggleIndex: (si := selectionIndex). - self toggleIndex: si. - ^ object]. - instVarIndex := self selectionIndexNonMeta. - instVarIndex > self objectClassInstSize - ifFalse: [^ object instVarAt: instVarIndex put: anObject]. - self objectClass isVariable or: [self error: 'Cannot replace selection']. - ^object basicAt: self selectedObjectIndex put: anObject! ! -!Inspector methodsFor: 'selecting' stamp: 'jmv 5/23/2020 20:12:32' prior: 50515799! -selection - "The receiver has a list of variables of its inspected object. - One of these is selected. Answer the value of the selected variable." - | index | - self selectionIsMeta ifTrue: [^self selectionMeta]. - self selectionIndexNonMeta <= self objectClassInstSize - ifTrue: [^ self object: object instVarAt: self selectionIndexNonMeta]. - index _ self selectedObjectIndex. - ^(object isObject and: [object isString]) - ifTrue: [ object at: index ] - ifFalse: [ self object: object basicAt: index ]! ! -!Inspector methodsFor: 'shout styling' stamp: 'jmv 5/23/2020 19:59:09' prior: 50367382! - bindingNamesDo: aBlock - self objectClass allInstVarNames do: aBlock! ! -!Inspector methodsFor: 'shout styling' stamp: 'jmv 5/23/2020 19:59:25' prior: 50367387! - hasBindingOf: aString - ^ self objectClass allInstVarNames includes: aString! ! -!Inspector methodsFor: 'user interface support' stamp: 'jmv 5/23/2020 20:02:35' prior: 50516209! - displayLabel - - | label | - object isObject ifFalse: [^self objectClass name]. - label := [object printStringLimitedTo: 64] - on: UnhandledError - do: [:ex | ex return: self objectClass printString, ' (printing failed)']. - "Note this is ambiguous: what happens with (Array with: Array)?" - (label includesSubString: self objectClass name) ifTrue: [^label]. - ^self objectClass name, ': ', label! ! -!Inspector methodsFor: 'private' stamp: 'sqr 5/23/2020 19:47:40' prior: 50516234! - objectClass - - ^self objectClass: object! ! -!Inspector methodsFor: 'private' stamp: 'sqr 5/23/2020 19:47:52' prior: 50516336! - objectSize - - ^self objectSize: object! ! - -Inspector removeSelector: #object! - -!methodRemoval: Inspector #object stamp: 'Install-4175-AvoidUnwantedMaterialization-JuanVuletich-2020May23-20h14m-jmv.001.cs.st 5/26/2020 17:09:08'! -object - "Answer the object being inspected by the receiver." - - ^object! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4175-AvoidUnwantedMaterialization-JuanVuletich-2020May23-20h14m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4167] on 23 May 2020 at 5:08:44 pm'! -!Inspector methodsFor: 'accessing' stamp: 'sqr 5/23/2020 17:05:55' prior: 50515741! - object: anObject - "Set anObject to be the object being inspected by the receiver." - - | oldIndex | - anObject == object ifTrue: [^self update]. - oldIndex := self selectionIsUnmodifiable ifTrue: [selectionIndex] ifFalse: [0]. - self inspect: anObject. - oldIndex := oldIndex min: self fieldList size. - self changed: #inspectObject. - oldIndex > 0 ifTrue: [self toggleIndex: oldIndex]. - self changed: #fieldList. - self acceptedContentsChanged! ! -!Inspector methodsFor: 'accessing' stamp: 'sqr 5/23/2020 17:06:28' prior: 50515767! - update - "Reshow contents, assuming selected value may have changed." - - selectionIndex = 0 ifFalse: [self changedSelectionIndex]! ! -!Inspector methodsFor: 'selecting' stamp: 'sqr 5/23/2020 17:06:21' prior: 50515825! - toggleIndex: anInteger - "The receiver has a list of variables of its inspected object. One of these - is selected. If anInteger is the index of this variable, then deselect it. - Otherwise, make the variable whose index is anInteger be the selected - item." - - selectionIndex := selectionIndex = anInteger ifTrue: [0] ifFalse: [anInteger]. - self changedSelectionIndex! ! -!Inspector methodsFor: 'private' stamp: 'sqr 5/23/2020 17:05:06'! - changedSelectionIndex - - acceptedContentsCache _ self selectionPrintString. - self acceptedContentsChanged. - self changed: #selectionIndex! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4176-AdditionalInspectorCleanup-AndresValloud-2020May23-17h04m-sqr.001.cs.st----! - -'From Cuis 5.0 [latest update: #4176] on 24 May 2020 at 8:20:17 pm'! -!SequenceableCollectionInspector methodsFor: 'accessing' stamp: 'sqr 5/24/2020 06:32:42' prior: 50515953 overrides: 50516461! - fieldList - - | fieldsHere | - object isNil ifTrue: [^#()]. - fieldsHere _ self indexLabelsForSize: self objectSize. - ^self baseFieldList , fieldsHere -" -OrderedCollection new inspect -(OrderedCollection newFrom: #(3 5 7 123)) inspect -(OrderedCollection newFrom: (1 to: 1000)) inspect -"! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4177-RemoveExtraneousExceptionHandler-AndresValloud-2020May24-20h19m-sqr.001.cs.st----! - -'From Cuis 5.0 [latest update: #4176] on 24 May 2020 at 8:25:32 pm'! -!SmalltalkCompleter methodsFor: 'entries - private ' stamp: 'jmv 5/24/2020 20:25:23' prior: 50415442! - selectedClassOrMetaClassIn: specificModel - - (specificModel is: #CodeProvider) ifTrue: [ ^ specificModel selectedClassOrMetaClass ]. - - "I can not use #selectedClassOrMetaClass becuase it changes with the selection but when compiling to evaluate it assumes object as receiver - Hernan" - ^ (specificModel isKindOf: Inspector) ifTrue: [ specificModel objectClass ] ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4178-FixSmalltalkCompleterInInspector-JuanVuletich-2020May24-20h20m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4176] on 24 May 2020 at 9:22:20 pm'! -!SetInspector methodsFor: 'selecting' stamp: 'jmv 5/24/2020 21:18:03'! - selectionIndexFixed - ^self selectionIndexNonMeta <= self objectClassInstSize! ! -!DictionaryInspector methodsFor: 'menu' stamp: 'jmv 5/24/2020 21:15:04' prior: 50515918! - removeSelection - - self selectionIndexFixed ifTrue: [^ self changed: #flash]. - object removeKey: (keyArray at: self nonFixedSelectionIndex). - selectionIndex := 0. - acceptedContentsCache _ ''. - self calculateKeyArray. - self changed: #inspectObject. - self changed: #selectionIndex. - self changed: #fieldList! ! -!DictionaryInspector methodsFor: 'menu' stamp: 'jmv 5/24/2020 21:15:48' prior: 50515931! - renameEntryTo: newKey - - | oldKey value | - self selectionIndexFixed ifTrue: [^ self changed: #flash]. - oldKey _ keyArray at: self nonFixedSelectionIndex. - value _ object at: oldKey. - object removeKey: oldKey. - object at: newKey put: value. - self calculateKeyArray. - selectionIndex := self numberOfFixedFields + (keyArray indexOf: newKey). - self changed: #selectionIndex. - self changed: #inspectObject. - self changed: #fieldList. - self update! ! -!SetInspector methodsFor: 'menu' stamp: 'jmv 5/24/2020 21:18:19' prior: 50515995! - removeSelection - - self selectionIndexFixed ifTrue: [^ self changed: #flash]. - object remove: self selection. - selectionIndex := 0. - acceptedContentsCache _ ''. - self changed: #inspectObject. - self changed: #fieldList. - self changed: #selectionIndex.! ! -!SetInspector methodsFor: 'selecting' stamp: 'jmv 5/24/2020 21:20:23' prior: 16907457 overrides: 50516479! - replaceSelectionValue: anObject - self selectionIndexFixed ifTrue: [^ super replaceSelectionValue: anObject]. - ^ object array at: self arrayIndexForSelection put: anObject! ! -!SetInspector methodsFor: 'selecting' stamp: 'jmv 5/24/2020 21:21:47' prior: 50516007 overrides: 50516501! - selection - - self selectionIndexFixed ifTrue: [^ super selection]. - ^ object array at: self arrayIndexForSelection! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4179-InspectorFixes-JuanVuletich-2020May24-20h25m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4179] on 24 May 2020 at 9:02:58 pm'! -!SequenceableCollectionInspector methodsFor: 'accessing' stamp: 'sqr 5/24/2020 21:00:15' prior: 50516624 overrides: 50516461! - fieldList - "Must tolerate malformed objects" - - | fieldsHere | - object isNil ifTrue: [^#()]. - fieldsHere _ [self indexLabelsForSize: self objectSize] - on: UnhandledError - do: [:ex | ex return: #()]. - ^self baseFieldList , fieldsHere -" -OrderedCollection new inspect -(OrderedCollection newFrom: #(3 5 7 123)) inspect -(OrderedCollection newFrom: (1 to: 1000)) inspect -"! ! -!SequenceableCollectionInspector methodsFor: 'accessing' stamp: 'sqr 5/24/2020 21:00:01' prior: 50515716 overrides: 50516550! - objectSize - "Must tolerate malformed objects" - - ^[object size] - on: UnhandledError - do: [:ex | ex return: 0]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4180-InspectorTolerance-AndresValloud-2020May24-20h58m-sqr.001.cs.st----! - -'From Cuis 5.0 [latest update: #4179] on 24 May 2020 at 9:15:22 pm'! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'sqr 5/24/2020 21:13:36'! - doItProfiling: aBoolean - "Set the context to include pool vars of the model. Then evaluate. - Print the result on the Transcript" - ^ self - evaluateSelectionAndDo: [ :result | - Transcript finishEntry. - [result print] - on: UnhandledError - do: [:ex | 'printing doIt result failed' print]] - ifFail: nil - profiled: aBoolean! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'sqr 5/24/2020 21:13:48' prior: 50431452! - doIt - - ^self doItProfiling: false! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'sqr 5/24/2020 21:14:03' prior: 16909753! - profileIt - - ^self doItProfiling: true! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4181-SmalltalkEditorTolerance-AndresValloud-2020May24-21h02m-sqr.001.cs.st----! - -'From Cuis 5.0 [latest update: #4171] on 24 May 2020 at 10:21:53 am'! -!Preferences class methodsFor: 'shout' stamp: 'len 5/22/2020 20:10:48'! -useAlwaysLeftArrow - " - Preferences useAlwaysLeftArrow - " - Preferences setPreference: #assignmentGlyphSelector toValue: #useAlwaysLeftArrow. - AbstractFont withAllSubclassesDo: [ :fontClass | fontClass assignmentGlyphSelectorPreferenceChanged ].! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'len 5/22/2020 20:09:51'! - useAlwaysLeftArrow - ^ self useLeftArrow! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4182-useAlwaysLeftArrow-LucianoEstebanNotarfrancesco-2020May24-10h18m-len.001.cs.st----! - -'From Cuis 5.0 [latest update: #4172] on 24 May 2020 at 10:50:45 am'! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 5/24/2020 10:36:55'! - loadOnlyLatinGlyphData - ^ self - valueOfFlag: #loadOnlyLatinGlyphData - ifAbsent: [true]! ! -!FontFamily methodsFor: 'caching' stamp: 'jmv 5/24/2020 10:46:19'! - releaseCachedState - - baseFontBySizes keysAndValuesDo: [ :size :font | - font releaseCachedState ]! ! -!FontFamily class methodsFor: 'cached state access' stamp: 'jmv 5/24/2020 10:46:40' overrides: 50510042! - releaseClassCachedState - - AvailableFamilies keysAndValuesDo: [ :familyName :fontFamily | - fontFamily releaseCachedState ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4183-loadOnlyLatin-releaseFontCachedData-JuanVuletich-2020May24-10h48m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4183] on 25 May 2020 at 10:31:26 am'! -!CodeWindow methodsFor: 'misc' stamp: 'len 5/25/2020 07:08:44' prior: 50514778! - sendQuery: querySelector to: queryPerformer - "Apply a query to the primary selector associated with the current context. If no such selection exists, obtain one by user type-in. Then send querySelector to queryPerformer with the selector as its argument." - - model selectedMessageName ifNotNil: [:aSymbol| ^ queryPerformer perform: querySelector with: aSymbol]. - self request: 'Type selector:' initialAnswer: 'flag:' verifying: [:aString| aString notEmpty] do: [:aString| - (Symbol hasInterned: aString ifTrue: [ :aSymbol | queryPerformer perform: querySelector with: aSymbol]) - ifFalse: [self inform: 'no such selector']]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4184-sendQueryto-fix-LucianoEstebanNotarfrancesco-2020May25-10h31m-len.001.cs.st----! - -'From Cuis 5.0 [latest update: #4176] on 24 May 2020 at 9:30:33 pm'! -!TaskbarMorph methodsFor: 'resize' stamp: 'jmv 5/24/2020 21:29:40'! - scaleSmall - - self scale: 1/2! ! -!TaskbarMorph methodsFor: 'menus' stamp: 'jmv 5/24/2020 21:29:02' prior: 50337325 overrides: 16874769! - mouseButton2Activity - - | menu | - menu _ MenuMorph new defaultTarget: self. - menu - addLine; - add: 'Small Height' action: #scaleSmall; - add: 'Normal Height' action: #scaleNormal; - add: 'Scale x 2' action: #scaleX2; - add: 'Scale x 4' action: #scaleX4. - menu popUpInWorld! ! -!TaskbarMorph methodsFor: 'resize' stamp: 'jmv 5/24/2020 21:30:02' prior: 50337335! - scale: anInteger - - (anInteger between: 1/2 and: 4) ifFalse: [ self error: 'scale should be 1/2, 1, 2 or 4' ]. - scale := anInteger. - self screenSizeChanged. "rescale self" - viewBox ifNotNil: [ "rescale buttons" - viewBox submorphs do: [ :button | - button layoutSpec fixedWidth: self defaultHeight - ] - ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4185-TaskbarScaleOneHalf-JuanVuletich-2020May24-21h22m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4176] on 24 May 2020 at 9:41:38 pm'! - -PluggableMorph subclass: #PluggableButtonMorph - instanceVariableNames: 'label font icon getStateSelector actionSelector isPressed mouseIsOver magnifiedIcon actWhen roundButtonStyle iconName secondaryActionSelector ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #PluggableButtonMorph category: #'Morphic-Views' stamp: 'Install-4186-rightClickInTaskbar-JuanVuletich-2020May24-21h30m-jmv.001.cs.st 5/26/2020 17:09:08'! -PluggableMorph subclass: #PluggableButtonMorph - instanceVariableNames: 'label font icon getStateSelector actionSelector isPressed mouseIsOver magnifiedIcon actWhen roundButtonStyle iconName secondaryActionSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! -!PluggableButtonMorph methodsFor: 'events' stamp: 'jmv 5/24/2020 21:38:17' overrides: 16874580! - mouseButton2Up: aMouseButtonEvent localPosition: localEventPosition - - secondaryActionSelector ifNotNil: [ - model perform: secondaryActionSelector ]. - self redrawNeeded! ! -!PluggableButtonMorph methodsFor: 'initialization' stamp: 'jmv 5/24/2020 21:36:57'! -secondaryActionSelector: actionSel - - secondaryActionSelector _ actionSel.! ! -!HoverableButtonMorph methodsFor: 'initialization' stamp: 'jmv 5/24/2020 21:35:06' prior: 50431888! - model: anObject stateGetter: getStateSel action: actionSel onMouseEnterSend: aMouseEnterSelector onMouseLeaveSend: aMouseLeaveSelector - - self model: anObject stateGetter: getStateSel action: actionSel label: nil. - mouseEnterSelector _ aMouseEnterSelector. - mouseLeaveSelector _ aMouseLeaveSelector.! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 5/24/2020 21:40:25' prior: 50500340! - addButtonFor: aMorph - - | button | - aMorph == self ifFalse: [ - button _ HoverableButtonMorph - model: aMorph - stateGetter: nil - action: #endPreviewAndToggleCollapseOrShow - onMouseEnterSend: #beginPreview - onMouseLeaveSend: #endPreview. - (aMorph is: #SystemWindow) ifTrue: [ - button - secondaryActionSelector: #offerWindowMenu ]. - button - color: self color; - icon: (aMorph imageForm: 400@300 depth: 32); - setBalloonText: #label. - button icon: button magnifiedIcon. - viewBox - addMorph: button - fixedWidth: self defaultHeight ]! ! - -PluggableMorph subclass: #PluggableButtonMorph - instanceVariableNames: 'label font icon getStateSelector actionSelector isPressed mouseIsOver magnifiedIcon actWhen roundButtonStyle iconName secondaryActionSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #PluggableButtonMorph category: #'Morphic-Views' stamp: 'Install-4186-rightClickInTaskbar-JuanVuletich-2020May24-21h30m-jmv.001.cs.st 5/26/2020 17:09:08'! -PluggableMorph subclass: #PluggableButtonMorph - instanceVariableNames: 'label font icon getStateSelector actionSelector isPressed mouseIsOver magnifiedIcon actWhen roundButtonStyle iconName secondaryActionSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4186-rightClickInTaskbar-JuanVuletich-2020May24-21h30m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4171] on 25 May 2020 at 12:59:52 am'! - -"Change Set: 4172-CuisCore-AuthorName-2020May24-19h34m -Date: 25 May 2020 -Author: Nahuel Garbezza - -[extract temporary / rename temporary] - - fix error message for instance variable already defined in class - - allow to perform the refactoring in a debugger - -[extract method] - - extracting to an existing selector (in the current class or any superclass) now raises a warning - - allow to perform the refactoring in a debugger - - improve error messages and validation logic - -[documentation] - - add a comment on RefactoringPrecondition class"! - -RefactoringApplier subclass: #ExtractMethodApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newSelector newMessageArguments codeProvider ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractMethodApplier category: #'Tools-Refactoring' stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:09:08'! -RefactoringApplier subclass: #ExtractMethodApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newSelector newMessageArguments codeProvider' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #ExtractToTemporaryApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newVariable codeProvider ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractToTemporaryApplier category: #'Tools-Refactoring' stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:09:09'! -RefactoringApplier subclass: #ExtractToTemporaryApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newVariable codeProvider' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!RefactoringPrecondition commentStamp: '' prior: 0! - I represent a precondition, a prerequisite for a refactoring to be evaluated successfully. My public instance protocol includes only one message, #value, which could raise either a RefactoringError (in case the refactoring cannot be performed) or a RefactoringWarning (in case something needs the programmer's attention, but it can be resumed to continue with the refactoring).! - -Smalltalk renameClassNamed: #ExtractMethodExpressionValidation as: #SourceCodeOfMethodToBeExtractedPrecondition! - -!classRenamed: #ExtractMethodExpressionValidation as: #SourceCodeOfMethodToBeExtractedPrecondition stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:09:09'! -Smalltalk renameClassNamed: #ExtractMethodExpressionValidation as: #SourceCodeOfMethodToBeExtractedPrecondition! - -RefactoringPrecondition subclass: #SourceCodeOfMethodToBeExtractedPrecondition - instanceVariableNames: 'method intervalToExtract methodNode sourceCode initialNode finalNode initialNodeAncestors finalNodeAncestors ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #SourceCodeOfMethodToBeExtractedPrecondition category: #'Tools-Refactoring' stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:09:09'! -RefactoringPrecondition subclass: #SourceCodeOfMethodToBeExtractedPrecondition - instanceVariableNames: 'method intervalToExtract methodNode sourceCode initialNode finalNode initialNodeAncestors finalNodeAncestors' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!SourceCodeOfMethodToBeExtractedPrecondition commentStamp: '' prior: 50497192! - I check if a piece of source code selected for extract method can actually be extracted. - -Many conditions have to happen: -* we are selecting from the beginning of an AST node to an end of an AST node -* it is a smalltalk expression, a single statement or a sequence of complete statements -* the expression does not contain returns, or temporary variable assignments (if there is a temporary variable assignment, the declaration and all the usages should be extracted as well)! -!CodeProvider methodsFor: 'contents' stamp: 'RNG 5/24/2020 21:27:20'! - currentMethodRefactored - - self acceptedContentsChanged -! ! -!Debugger methodsFor: 'contents' stamp: 'RNG 5/24/2020 21:27:20' overrides: 50517148! - currentMethodRefactored - - | newMethod | - - newMethod := self selectedClass compiledMethodAt: self selectedContext selector. - self resetToSelectedContextWith: newMethod ! ! -!SmalltalkEditor methodsFor: 'private' stamp: 'RNG 5/24/2020 21:34:17'! - performCodeExtractionRefactoringWith: aRefactoringApplierClass - - "To prevent the refactoring to be evaluated on editors w/o methods like the workspace - Nahuel" - self hasValidCurrentCompiledMethod ifFalse: [ ^ nil ]. - - self ifSourceCodeRefactoringCanBeAppliedDo: [ - - aRefactoringApplierClass createAndValueHandlingExceptions: [ - aRefactoringApplierClass - on: self codeProvider - for: self selectionInterval asSourceCodeInterval - of: self codeProvider currentCompiledMethod ] ]! ! -!ExtractMethod class methodsFor: 'error messages' stamp: 'RNG 5/24/2020 19:50:32'! - wrongNumberOfArgumentsGivenErrorMessage - - ^ 'The number of arguments in the given selector is not correct'! ! -!ExtractMethod class methodsFor: 'pre-conditions' stamp: 'RNG 5/24/2020 22:36:58'! - assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: anIntervalToExtract - - self - assertIntervalToExtractIsNotEmpty: anIntervalToExtract; - assert: anIntervalToExtract isWithinBoundsOf: aMethodToExtractCodeFrom sourceCode; - assert: aMethodToExtractCodeFrom containsValidCodeToBeExtractedAt: anIntervalToExtract! ! -!ExtractMethod class methodsFor: 'private - pre-conditions' stamp: 'RNG 5/24/2020 22:33:47'! - assert: aMethodToRefactor containsValidCodeToBeExtractedAt: anIntervalToExtract - - SourceCodeOfMethodToBeExtractedPrecondition valueFor: anIntervalToExtract of: aMethodToRefactor! ! -!ExtractMethod class methodsFor: 'private - pre-conditions' stamp: 'RNG 5/24/2020 22:37:04'! - assert: anIntervalToExtract isWithinBoundsOf: sourceCode - - (self is: anIntervalToExtract withinBoundsOf: sourceCode) - ifFalse: [ self signalOutOfBoundsIntervalError ]! ! -!ExtractMethod class methodsFor: 'private - pre-conditions' stamp: 'RNG 5/24/2020 22:35:01'! - assertIntervalToExtractIsNotEmpty: anIntervalToExtract - - (self isNotEmpty: anIntervalToExtract) - ifFalse: [ self signalNoSelectedCodeError ]! ! -!ExtractMethodApplier methodsFor: 'initialization' stamp: 'RNG 5/24/2020 21:11:57'! - initializeOn: aCodeProvider for: anIntervalToExtract of: aMethodToExtractCodeFrom - - codeProvider := aCodeProvider. - intervalToExtract := anIntervalToExtract. - methodToExtractCodeFrom := aMethodToExtractCodeFrom. - newMessageArguments := Dictionary new! ! -!ExtractMethodApplier class methodsFor: 'instance creation' stamp: 'RNG 5/24/2020 22:32:42'! - on: aCodeProvider for: anIntervalToExtract of: aMethodToRefactor - - | trimmedIntervalToExtract sourceCode | - sourceCode := aMethodToRefactor sourceCode. - trimmedIntervalToExtract := anIntervalToExtract trimToMatchExpressionOn: sourceCode.. - - self assertCanApplyRefactoringOn: aMethodToRefactor at: trimmedIntervalToExtract. - - ^ self new initializeOn: aCodeProvider for: trimmedIntervalToExtract of: aMethodToRefactor! ! -!ExtractToTemporaryApplier methodsFor: 'initialization' stamp: 'RNG 5/24/2020 21:12:30'! - initializeOn: aCodeProvider for: anIntervalToExtract of: aMethodToExtractCodeFrom - - codeProvider := aCodeProvider. - intervalToExtract := anIntervalToExtract. - methodToExtractCodeFrom := aMethodToExtractCodeFrom.! ! -!ExtractToTemporaryApplier class methodsFor: 'instance creation' stamp: 'RNG 5/24/2020 21:10:47'! - on: aCodeProvider for: anIntervalToExtract of: aMethodToExtractCodeFrom - - self assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: anIntervalToExtract. - - ^ self new initializeOn: aCodeProvider for: anIntervalToExtract of: aMethodToExtractCodeFrom! ! -!ExtractMethodNewSelectorPrecondition methodsFor: 'evaluating - private' stamp: 'RNG 5/24/2020 20:25:43'! - assertNewSelectorIsNotAlreadyDefinedWithinTheClassHierarchy - - (classToDefineSelector whichClassIncludesSelector: selectorToValidate) - ifNotNil: [ :classDefiningSelector | self warn: selectorToValidate isAlreadyDefinedIn: classDefiningSelector ]! ! -!ExtractMethodNewSelectorPrecondition methodsFor: 'warnings' stamp: 'RNG 5/24/2020 20:37:46'! - warn: aSelector isAlreadyDefinedIn: aClassDefiningSelector - - self refactoringWarning: (self class warningMessageFor: aSelector isAlreadyDefinedIn: aClassDefiningSelector)! ! -!ExtractMethodNewSelectorPrecondition class methodsFor: 'warning messages' stamp: 'RNG 5/24/2020 20:41:41'! - warningMessageFor: existingSelector isAlreadyDefinedIn: classDefiningSelector - - ^ existingSelector , ' is already defined in ' , classDefiningSelector name! ! -!NewTemporaryPrecondition class methodsFor: 'error messages' stamp: 'RNG 5/24/2020 20:01:16'! - errorMessageFor: aNewVariable canNotBeNamedDueToInstanceVariableDefinedIn: aClass - - ^ aNewVariable, ' cannot be used as temporary variable name because it is an instance variable defined in ', aClass name! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'evaluating' stamp: 'RNG 5/25/2020 00:51:57' overrides: 50497304! - value - - self - initializeParseNodesMatchingSelectionInterval; - assertSourceCodeDoesNotIncludeReturnExpressions; - assertSourceCodeIsNotLeftSideOfAssignment; - assertSourceCodeIsNotPartOfTemporariesDeclaration; - assertSourceCodeDoesNotIncludeTemporaryAssignmentsWithoutDeclaration; - assertSourceCodeDoesNotHaveTemporaryVariablesUsedOutsideOfSelectionInterval; - assertSourceCodeContainsAValidExpression! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'exceptions' stamp: 'RNG 5/24/2020 22:08:41'! - signalExtractingLeftSideOfAssignmentError - - self refactoringError: self class errorMessageForExtractingLeftSideOfAssignment! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'exceptions' stamp: 'RNG 5/25/2020 00:13:13'! - signalExtractingTemporaryVariableDefinitionError - - self refactoringError: self class errorMessageForExtractingTemporaryVariablesDefinition! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'exceptions' stamp: 'RNG 5/25/2020 00:48:13'! - signalSourceCodeContainsAnInvalidExpressionError - - self refactoringError: self class errorMessageForSourceCodeContainingInvalidExpression! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'exceptions' stamp: 'RNG 5/24/2020 21:57:41'! - signalSourceCodeIncludesAReturnStatementError - - self refactoringError: self class errorMessageForSourceCodeIncludingAReturnStatement! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'exceptions' stamp: 'RNG 5/25/2020 00:54:43'! - signalTemporaryAssignmentUsedOutsideOfSelectionIntervalError - - self refactoringError: self class errorMessageForTemporaryAssignmentWithUsagesOutsideOfSelectionInterval! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'exceptions' stamp: 'RNG 5/25/2020 00:30:02'! - signalTemporaryAssignmentWithoutDeclarationError - - self refactoringError: self class errorMessageForExtractedTemporaryAssignmentWithoutItsDeclaration! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 5/25/2020 00:52:33'! - assertSourceCodeContainsAValidExpression - - (self intervalCoversCompleteAstNodes and: [ self startAndEndNodesShareAParentNode - or: [ self intervalMatchesBeginningOfStatement and: [ self intervalMatchesEndOfStatement ] ] ]) - - ifFalse: [ self signalSourceCodeContainsAnInvalidExpressionError ]! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 5/25/2020 00:39:55'! - assertSourceCodeDoesNotHaveTemporaryVariablesUsedOutsideOfSelectionInterval - - self isNotATempDeclarationWithUsagesOutOfIntervalToExtract - ifFalse: [ self signalTemporaryAssignmentUsedOutsideOfSelectionIntervalError ]! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 5/24/2020 22:03:51'! - assertSourceCodeDoesNotIncludeReturnExpressions - - self thereAreReturnExpressions - ifTrue: [ self signalSourceCodeIncludesAReturnStatementError ]! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 5/25/2020 00:28:44'! -assertSourceCodeDoesNotIncludeTemporaryAssignmentsWithoutDeclaration - - self thereAreNoLocalVariableAssignmentsWithoutDeclaration - ifFalse: [ self signalTemporaryAssignmentWithoutDeclarationError ]! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 5/25/2020 00:07:42'! - assertSourceCodeIsNotLeftSideOfAssignment - - self isLeftSideOfAssignment - ifTrue: [ self signalExtractingLeftSideOfAssignmentError ]! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 5/25/2020 00:12:37'! - assertSourceCodeIsNotPartOfTemporariesDeclaration - - self isNotInsideATempDeclaration - ifFalse: [ self signalExtractingTemporaryVariableDefinitionError ]! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'private' stamp: 'RNG 5/25/2020 00:47:29'! - initializeParseNodesMatchingSelectionInterval - - initialNodeAncestors := methodNode parseNodesPathAt: intervalToExtract first ifAbsent: [ self signalSourceCodeContainsAnInvalidExpressionError ]. - finalNodeAncestors := methodNode parseNodesPathAt: intervalToExtract last ifAbsent: [ self signalSourceCodeContainsAnInvalidExpressionError ]. - initialNode := initialNodeAncestors first. - finalNode := finalNodeAncestors first! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'private' stamp: 'RNG 5/25/2020 00:22:31'! - intervalToExtractIsIncludedInAnyOf: sourceRanges - - ^ sourceRanges anySatisfy: [ :sourceRange | - sourceRange first <= intervalToExtract first and: [ sourceRange last >= intervalToExtract last ] ]! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'private' stamp: 'RNG 5/25/2020 00:44:55' prior: 50489464! - startAndEndParseNodesAreTheSame - - ^ initialNode key = finalNode key! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'private' stamp: 'RNG 5/24/2020 22:03:51'! - thereAreReturnExpressions - - ^ (methodNode - allParseNodesWithin: intervalToExtract - satisfy: [ :parseNode | parseNode isReturn ]) not! ! -!SourceCodeOfMethodToBeExtractedPrecondition class methodsFor: 'error messages' stamp: 'RNG 5/25/2020 00:26:39'! - errorMessageForExtractedTemporaryAssignmentWithoutItsDeclaration - - ^ self extractMethodErrorMessagePrefix , 'an assignment is being extracted without its declaration'! ! -!SourceCodeOfMethodToBeExtractedPrecondition class methodsFor: 'error messages' stamp: 'RNG 5/24/2020 22:14:48'! - errorMessageForExtractingLeftSideOfAssignment - - ^ self extractMethodErrorMessagePrefix , 'it is not possible to extract the left side of an assignment'! ! -!SourceCodeOfMethodToBeExtractedPrecondition class methodsFor: 'error messages' stamp: 'RNG 5/24/2020 22:57:11'! - errorMessageForExtractingTemporaryVariablesDefinition - - ^ self extractMethodErrorMessagePrefix , 'it is not possible to extract temporary variable definitions'! ! -!SourceCodeOfMethodToBeExtractedPrecondition class methodsFor: 'error messages' stamp: 'RNG 5/25/2020 00:48:55'! - errorMessageForSourceCodeContainingInvalidExpression - - ^ self extractMethodErrorMessagePrefix , 'the selected code contains an invalid expression'! ! -!SourceCodeOfMethodToBeExtractedPrecondition class methodsFor: 'error messages' stamp: 'RNG 5/24/2020 22:15:04'! - errorMessageForSourceCodeIncludingAReturnStatement - - ^ self extractMethodErrorMessagePrefix , 'the selected code includes a return statement'! ! -!SourceCodeOfMethodToBeExtractedPrecondition class methodsFor: 'error messages' stamp: 'RNG 5/25/2020 00:38:28'! - errorMessageForTemporaryAssignmentWithUsagesOutsideOfSelectionInterval - - ^ self extractMethodErrorMessagePrefix , 'there are temporary variables used outside of the code selection'! ! -!SourceCodeOfMethodToBeExtractedPrecondition class methodsFor: 'evaluating' stamp: 'RNG 5/24/2020 22:19:38'! - valueFor: anIntervalToExtract of: aMethod - - ^ (self for: anIntervalToExtract of: aMethod) value! ! -!SourceCodeOfMethodToBeExtractedPrecondition class methodsFor: 'private - error messages' stamp: 'RNG 5/24/2020 22:14:33'! - extractMethodErrorMessagePrefix - - ^ 'Cannot extract method: '! ! -!MethodNode methodsFor: 'testing' stamp: 'RNG 5/24/2020 21:54:35' prior: 50489633! - allParseNodesWithin: aSourceCodeInterval satisfy: aCondition - - self completeSourceRangesDo: [ :parseNode :sourceRanges | - (aCondition value: parseNode) ifTrue: [ - (sourceRanges anySatisfy: [ :sourceRange | aSourceCodeInterval rangeIncludes: sourceRange first ]) - ifTrue: [ ^ false ] ] ]. - ^ true! ! -!SmalltalkEditor methodsFor: 'extract to temporary' stamp: 'RNG 5/24/2020 21:35:15' prior: 50512534! - extractToTemporary - - self performCodeExtractionRefactoringWith: ExtractToTemporaryApplier! ! -!SmalltalkEditor methodsFor: 'extract method' stamp: 'RNG 5/24/2020 21:34:55' prior: 50512551! - extractMethod - - self performCodeExtractionRefactoringWith: ExtractMethodApplier! ! -!ExtractMethod class methodsFor: 'error messages' stamp: 'RNG 5/24/2020 21:38:48' prior: 50488907! - outOfBoundsSelectionErrorMessage - - ^ 'The requested source code selection interval is out of bounds'! ! -!ExtractMethod class methodsFor: 'exceptions' stamp: 'RNG 5/24/2020 19:50:32' prior: 50505472! - signalExtractMethodWithWrongNumberOfArgumentsError - - self refactoringError: self wrongNumberOfArgumentsGivenErrorMessage! ! -!ExtractMethod class methodsFor: 'instance creation' stamp: 'RNG 5/24/2020 22:37:50' prior: 50512584! - fromInterval: anIntervalToExtract of: aMethodToExtractCodeFrom to: newMessage categorizedAs: aCategory - - | trimmedIntervalToExtract | - trimmedIntervalToExtract := anIntervalToExtract trimToMatchExpressionOn: aMethodToExtractCodeFrom sourceCode. - self - assert: newMessage selector canBeDefinedIn: aMethodToExtractCodeFrom methodClass; - assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: trimmedIntervalToExtract; - assert: newMessage hasValidParametersForExtracting: anIntervalToExtract from: aMethodToExtractCodeFrom methodNode. - - ^ self new - initializeFrom: trimmedIntervalToExtract - of: aMethodToExtractCodeFrom - to: newMessage - in: aCategory! ! -!ExtractMethodApplier methodsFor: 'refactoring - changes' stamp: 'RNG 5/24/2020 21:27:20' prior: 50489169 overrides: 50441445! - showChanges - - codeProvider currentMethodRefactored! ! -!ExtractMethodApplier class methodsFor: 'pre-conditions' stamp: 'RNG 5/24/2020 22:32:28' prior: 50492183! -assertCanApplyRefactoringOn: aMethodToRefactor at: anIntervalToExtract - - ExtractMethod - assertCanApplyRefactoringOn: aMethodToRefactor - at: anIntervalToExtract! ! -!ExtractToTemporaryApplier methodsFor: 'refactoring - changes' stamp: 'RNG 5/24/2020 21:27:20' prior: 50507142 overrides: 50441445! - showChanges - - codeProvider currentMethodRefactored! ! -!RenameInstanceVariableApplier methodsFor: 'refactoring - changes' stamp: 'RNG 5/24/2020 21:27:51' prior: 50476624! - informChangesToBrowser - - browser currentMethodRefactored! ! -!ExtractMethodNewSelectorPrecondition methodsFor: 'evaluating' stamp: 'RNG 5/24/2020 20:14:39' prior: 50489282 overrides: 50497304! - value - - self - assertNewSelectorIsNotEmpty; - assertNewSelectorDoesNotContainSeparators; - assertNewSelectorBeginsWithAValidCharacter; - assertNewSelectorContainsOnlyValidCharacters; - assertNewSelectorIsNotAlreadyDefinedWithinTheClassHierarchy! ! -!NewTemporaryPrecondition methodsFor: 'exceptions' stamp: 'RNG 5/24/2020 20:01:16' prior: 50497415! - signalNewVariableCanNotHideInstanceVariableDefinedIn: aClass - - self refactoringError: ( - self class - errorMessageFor: newTemporaryVariableName - canNotBeNamedDueToInstanceVariableDefinedIn: aClass)! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'initialization' stamp: 'RNG 5/24/2020 22:50:39' prior: 50489518! - initializeFor: anIntervalToExtract of: aMethodUnderValidation - - intervalToExtract := anIntervalToExtract. - method := aMethodUnderValidation. - methodNode := method methodNode. - sourceCode := method sourceCode.! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'private' stamp: 'RNG 5/25/2020 00:45:10' prior: 50492044! - isLeftSideOfAssignment - - ^ initialNodeAncestors size > 1 - and: [ self startAndEndParseNodesAreTheSame ] - and: [ initialNodeAncestors second key isAssignmentNode ] - and: [ initialNodeAncestors second key variable = initialNode key ]! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'private' stamp: 'RNG 5/25/2020 00:22:21' prior: 50505334! - isNotInsideATempDeclaration - - methodNode completeSourceRangesDo: [ :parseNode :sourceRanges | - (parseNode isTemporariesDeclaration - and: [ self intervalToExtractIsIncludedInAnyOf: sourceRanges ]) - ifTrue: [ ^ false ] ]. - ^ true! ! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #thereAreNoReturnExpressions! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition #thereAreNoReturnExpressions stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:09:09'! -thereAreNoReturnExpressions - - ^ methodNode - allParseNodesWithin: intervalToExtract - satisfy: [ :parseNode | parseNode isReturn ]! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #isNotLeftSideOfAssignment! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition #isNotLeftSideOfAssignment stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:09:09'! -isNotLeftSideOfAssignment - - ^ (self startAndEndParseNodesAreTheSame and: [ self isLeftSideOfAssignment ]) not! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #passed! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition #passed stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:09:09'! -passed - - methodNode _ method methodNode. - sourceCode _ method sourceCode. - initialNodeAncestors _ methodNode parseNodesPathAt: intervalToExtract first ifAbsent: [ ^ false]. - finalNodeAncestors _ methodNode parseNodesPathAt: intervalToExtract last ifAbsent: [ ^ false ]. - initialNode _ initialNodeAncestors first. - finalNode _ finalNodeAncestors first. - - ^ self intervalCoversCompleteAstNodes - and: [ self containsValidNodes ] - and: [ self startAndEndParseNodesAreTheSame - or: [ self startAndEndNodesShareAParentNode ] - or: [ self intervalMatchesBeginningOfStatement and: [ self intervalMatchesEndOfStatement ] ] ]! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #containsValidNodes! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition #containsValidNodes stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:09:09'! -containsValidNodes - - ^ self isNotLeftSideOfAssignment - and: [ self thereAreNoLocalVariableAssignmentsWithoutDeclaration ] - and: [ self thereAreNoReturnExpressions ] - and: [ self isNotATempDeclarationWithUsagesOutOfIntervalToExtract ] - and: [ self isNotInsideATempDeclaration ]! - -NewTemporaryPrecondition class removeSelector: #errorMessageFor:canNotBeNamedAsInstanceVariableDefinedIn:! - -!methodRemoval: NewTemporaryPrecondition class #errorMessageFor:canNotBeNamedAsInstanceVariableDefinedIn: stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:09:09'! -errorMessageFor: aNewVariable canNotBeNamedAsInstanceVariableDefinedIn: aClass - - ^ aNewVariable, ' can not be named as instance variable defined in ', aClass name! - -ExtractMethodNewSelectorPrecondition class removeSelector: #newSelectorAlreadyDefinedOnTheClassErrorMessage! - -!methodRemoval: ExtractMethodNewSelectorPrecondition class #newSelectorAlreadyDefinedOnTheClassErrorMessage stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:09:09'! -newSelectorAlreadyDefinedOnTheClassErrorMessage - - ^ 'New selector is already defined on this class'! - -ExtractMethodNewSelectorPrecondition removeSelector: #assertNewSelectorIsNotAlreadyDefinedInTheClass! - -!methodRemoval: ExtractMethodNewSelectorPrecondition #assertNewSelectorIsNotAlreadyDefinedInTheClass stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:09:09'! -assertNewSelectorIsNotAlreadyDefinedInTheClass - - (classToDefineSelector includesSelector: selectorToValidate) - ifTrue: [ self signalNewSelectorIsAlreadyDefinedInTheClassError ]! - -ExtractMethodNewSelectorPrecondition removeSelector: #signalNewSelectorIsAlreadyDefinedInTheClassError! - -!methodRemoval: ExtractMethodNewSelectorPrecondition #signalNewSelectorIsAlreadyDefinedInTheClassError stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:09:09'! -signalNewSelectorIsAlreadyDefinedInTheClassError - - self refactoringError: self class newSelectorAlreadyDefinedOnTheClassErrorMessage! - -ExtractToTemporaryApplier class removeSelector: #for:of:! - -!methodRemoval: ExtractToTemporaryApplier class #for:of: stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:09:09'! -for: anIntervalToExtract of: aMethodToExtractCodeFrom - - self assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: anIntervalToExtract. - - ^ self new initializeFor: anIntervalToExtract of: aMethodToExtractCodeFrom! - -ExtractToTemporaryApplier removeSelector: #initializeFor:of:! - -!methodRemoval: ExtractToTemporaryApplier #initializeFor:of: stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:09:09'! -initializeFor: anIntervalToExtract of: aMethodToExtractCodeFrom - - intervalToExtract _ anIntervalToExtract. - methodToExtractCodeFrom _ aMethodToExtractCodeFrom.! - -ExtractMethodApplier class removeSelector: #for:of:! - -!methodRemoval: ExtractMethodApplier class #for:of: stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:09:09'! -for: anIntervalToExtract of: aMethodToExtractCodeFrom - - | trimmedIntervalToExtract sourceCode | - sourceCode := aMethodToExtractCodeFrom sourceCode. - trimmedIntervalToExtract := anIntervalToExtract trimToMatchExpressionOn: sourceCode.. - - self assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: trimmedIntervalToExtract. - - ^ self new initializeFor: trimmedIntervalToExtract of: aMethodToExtractCodeFrom! - -ExtractMethodApplier removeSelector: #initializeFor:of:! - -!methodRemoval: ExtractMethodApplier #initializeFor:of: stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:09:09'! -initializeFor: anIntervalToExtract of: aMethodToExtractCodeFrom - - intervalToExtract _ anIntervalToExtract. - methodToExtractCodeFrom _ aMethodToExtractCodeFrom. - newMessageArguments _ Dictionary new! - -ExtractMethod class removeSelector: #assert:isValidIntervalOn:! - -!methodRemoval: ExtractMethod class #assert:isValidIntervalOn: stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:09:09'! -assert: anIntervalToExtract isValidIntervalOn: aMethodToExtractCodeFrom - - (self isNotEmpty: anIntervalToExtract) - ifFalse: [ self signalNoSelectedCodeError ]. - (self is: anIntervalToExtract withinBoundsOf: aMethodToExtractCodeFrom sourceCode) - ifFalse: [ self signalOutOfBoundsIntervalError ]. - (self method: aMethodToExtractCodeFrom containsAValidExpressionOn: anIntervalToExtract) - ifFalse: [ self signalSelectedCodeIsInvalidForExtractError ].! - -ExtractMethod class removeSelector: #signalSelectedCodeIsInvalidForExtractError! - -!methodRemoval: ExtractMethod class #signalSelectedCodeIsInvalidForExtractError stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:09:09'! -signalSelectedCodeIsInvalidForExtractError - - self refactoringError: self selectedCodeInvalidForExtractErrorMessage! - -ExtractMethod class removeSelector: #wrongNumberOrArgumentsGivenErrorMessage! - -!methodRemoval: ExtractMethod class #wrongNumberOrArgumentsGivenErrorMessage stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:09:09'! -wrongNumberOrArgumentsGivenErrorMessage - - ^ 'The number of arguments in the given selector is not correct'! - -ExtractMethod class removeSelector: #selectedCodeInvalidForExtractErrorMessage! - -!methodRemoval: ExtractMethod class #selectedCodeInvalidForExtractErrorMessage stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:09:09'! -selectedCodeInvalidForExtractErrorMessage - - ^ 'The selected code can not be extracted to a method'! - -ExtractMethod class removeSelector: #method:containsAValidExpressionOn:! - -!methodRemoval: ExtractMethod class #method:containsAValidExpressionOn: stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:09:09'! -method: aMethod containsAValidExpressionOn: anIntervalToExtract - - ^ (ExtractMethodExpressionValidation for: anIntervalToExtract of: aMethod) passed! - -Debugger removeSelector: #instanceVariableRenamed! - -!methodRemoval: Debugger #instanceVariableRenamed stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:09:09'! -instanceVariableRenamed - - | newMethod | - - newMethod := self selectedClass compiledMethodAt: self selectedContext selector. - self resetToSelectedContextWith: newMethod ! - -CodeProvider removeSelector: #instanceVariablePushedUp! - -!methodRemoval: CodeProvider #instanceVariablePushedUp stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:09:09'! -instanceVariablePushedUp - - self acceptedContentsChanged -! - -CodeProvider removeSelector: #instanceVariableRenamed! - -!methodRemoval: CodeProvider #instanceVariableRenamed stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:09:09'! -instanceVariableRenamed - - self acceptedContentsChanged -! - -RefactoringApplier subclass: #ExtractMethodApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newSelector newMessageArguments codeProvider' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractMethodApplier category: #'Tools-Refactoring' stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:09:09'! -RefactoringApplier subclass: #ExtractMethodApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newSelector newMessageArguments codeProvider' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringApplier subclass: #ExtractToTemporaryApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newVariable codeProvider' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractToTemporaryApplier category: #'Tools-Refactoring' stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:09:09'! -RefactoringApplier subclass: #ExtractToTemporaryApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newVariable codeProvider' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -RefactoringPrecondition subclass: #SourceCodeOfMethodToBeExtractedPrecondition - instanceVariableNames: 'method intervalToExtract methodNode sourceCode initialNode finalNode initialNodeAncestors finalNodeAncestors' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #SourceCodeOfMethodToBeExtractedPrecondition category: #'Tools-Refactoring' stamp: 'Install-4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st 5/26/2020 17:09:09'! -RefactoringPrecondition subclass: #SourceCodeOfMethodToBeExtractedPrecondition - instanceVariableNames: 'method intervalToExtract methodNode sourceCode initialNode finalNode initialNodeAncestors finalNodeAncestors' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4187-FixesAndImprovementsOnExtractMethodAndTemporary-NahuelGarbezza-2020May24-19h34m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4187] on 25 May 2020 at 10:51:22 pm'! -!Morph methodsFor: 'previewing' stamp: 'jmv 5/25/2020 22:49:11' prior: 50431844! - endPreview - - self previewing ifTrue: [ - self visible: self visibleBeforePreview. - owner notNil ifTrue: [ owner addMorph: self inFrontOf: self morphBehindBeforePreview ]. - self previewing: false. ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4188-FixTaskbarEndDuringPreview-JuanVuletich-2020May25-22h50m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4188] on 26 May 2020 at 11:42:00 am'! -!StringRequestMorph class methodsFor: 'private' stamp: 'KenD 5/25/2020 12:37:58' prior: 50513916! - deltaToTextPane - "Answer a distance to translate an instance of the receiver by when it is opened in the world in order to have the hand be over the text pane (so the text pane has focus). - Distance is relative to font size" - | e | - e _ Preferences windowTitleFont lineSpacing. - ^ (2 * e)@(1.5 * e)! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4189-StringRequestMorph-deltaToTextPane-KenDickey-2020May26-11h41m-KenD.001.cs.st----! - -'From Cuis 5.0 [latest update: #4189] on 26 May 2020 at 2:56:59 pm'! -!Workspace methodsFor: 'user interface support' stamp: 'jmv 5/26/2020 14:55:37' overrides: 50368780! - formatAndStyleIfNeededWith: anSHTextStyler - | separator fragmentStart fragmentEnd done| - (anSHTextStyler notNil and: [self shouldStyle: self actualContents with: anSHTextStyler]) - ifFalse: [^ self]. - - actualContents _ actualContents optimizedForMutationSpeed. - anSHTextStyler formatWorkspace: actualContents. - separator _ String newLineString, String newLineString. - fragmentStart _ 1. - done _ false. - [done] whileFalse: [ - fragmentEnd _ actualContents - indexOfSubCollection: separator - startingAt: fragmentStart - ifAbsent: [done _ true. actualContents size]. - anSHTextStyler styleWorkspaceFrom: fragmentStart to: fragmentEnd. - fragmentStart _ fragmentEnd+separator size ]. - self changed: #shoutStyled! ! -!SHTextStylerST80 methodsFor: 'styling' stamp: 'jmv 5/26/2020 14:15:23'! - formatWorkspace: text - "Do first stage of styling. - Afterweards, call #styleWorkspaceFrom:to: as needed. - Note: classOrMetaClass is assumed to be nil" - - self terminateBackgroundStylingProcess. - formattedText _ text. - self privateFormatAndConvert. - formattedText removeAttributesThat: [ :attribute | attribute isForShout ]. - - parser ifNil: [ parser := SHParserST80 new ]. - parser - workspace: workspace; - classOrMetaClass: nil! ! -!SHTextStylerST80 methodsFor: 'styling' stamp: 'jmv 5/26/2020 14:23:29'! - styleWorkspaceFrom: start to: end - "Style a copy of part of the model text. Then apply attributes to model text. Useful for Workspaces. - Call #formatWorkspace: becore calling us. - Note: classOrMetaClass is assumed to be nil. - Note: after last call, do `textModel changed: #shoutStyled`" - - parser - source: (formattedText asString copyFrom: start to: end). - parser parse. - parser ranges ifNotNil: [ :ranges | - ranges do: [ :range | - (self attributesFor: range rangeType) ifNotNil: [ :attributes | - attributes do: [ :each | - formattedText - addAttribute: each - from: range start +start-1 - to: range end +start-1 ]]]].! ! -!SHTextStyler methodsFor: 'styling' stamp: 'jmv 5/26/2020 14:22:37' prior: 50500413! - formatAndStyle: text allowBackgroundStyleProcess: aBoolean - "Do the styling on the model text. - After finishing, tell model, by triggering #shoutStyled." - self terminateBackgroundStylingProcess. - formattedText _ text. - self privateFormatAndConvert. - (aBoolean and: [formattedText size > 4096]) - ifTrue: [ - formattedText size < 65536 ifTrue: [ - self styleInBackgroundProcess ]] - ifFalse: [ - self privateStyle. - textModel changed: #shoutStyled ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4190-ShoutWorkspacesInParagraphs-JuanVuletich-2020May26-14h53m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4112] on 26 May 2020 at 5:03:49 pm'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 5/26/2020 16:58:40' prior: 50473065! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag - "WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " - | activeProc | - activeProc _ Processor activeProcess. - [ | isARealStartup guiRootObject guiRootObjectClass | - save not & quit - ifTrue: [ - (SourceFiles at: 2) ifNotNil: [ :changes | - ChangesInitialFileSize ifNotNil: [ changes truncate: ChangesInitialFileSize ]]] - ifFalse: [ - self - logSnapshot: save - andQuit: quit ]. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | - each isInWorld ifTrue: [ - each delete.]]. - UISupervisor ui tearDownDesktop. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - "Cosas que levanto explicitamente abajo" - guiRootObjectClass _ UISupervisor ui class. - guiRootObject _ UISupervisor ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "guiRootObject _ clearAllStateFlag ifFalse: [ UISupervisor ui ]." - UISupervisor stopUIProcess. - activeProc isTerminated ifFalse: [ activeProc terminate ]. - "Clean Globals" - Smalltalk - at: #Sensor - put: nil. - Smalltalk - at: #Display - put: nil. - Smalltalk closeSourceFiles. - Smalltalk - at: #SourceFiles - put: nil. - Smalltalk allClassesDo: [ :cls | - cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | - cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ - Smalltalk printStuffToCleanOnImageSave. - "Remove this call to actually see the image clean report." - Transcript clear. - ]. - "Do image save & quit as apropriate" - (Cursor cursorAt: #writeCursor) activateCursor. - save - ifTrue: [ - "The snapshot primitive answers false if it was just called to do the snapshot. - But image startup is resumed by returning (again) from the primitive, but this time answering true." - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk - at: #Sensor - put: nil. - Smalltalk - at: #Display - put: DisplayScreen new. - Smalltalk - at: #SourceFiles - put: (Array new: 2). - Smalltalk openSourceFiles. - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | - cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - UISupervisor spawnNewMorphicProcessFor: (guiRootObject ifNil: [ guiRootObject _ guiRootObjectClass newWorld ]). - Display triggerEvent: #screenSizeChanged. - self restoreLostChangesIfNecessary. - clearAllStateFlag ifTrue: [ - UISupervisor whenUIinSafeState: [ - guiRootObject recreateDefaultDesktop ]]. - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - UISupervisor whenUIinSafeState: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]] - forkAt: Processor timingPriority - 1 - named: 'Startup process'.! ! -!PasteUpMorph methodsFor: 'defaul desktop' stamp: 'jmv 5/26/2020 17:03:06' prior: 50515469! - recreateDefaultDesktop - | editor | - self whenUIinSafeState: [ - self hideTaskbar. - (submorphs - select: [ :ea | ea class == SystemWindow or: [ea class == TranscriptWindow]]) - do: [ :ea | ea delete ]. - TranscriptWindow openTranscript - morphPosition: 5 @ 283; - morphExtent: 990 @ 400. - editor _ TextEditor openTextEditor - morphPosition: 456 @ 3; - morphExtent: 900 @ 680. - editor setLabel: 'About Cuis'. - editor model actualContents: Utilities defaultTextEditorContents. - Theme current useTaskbar ifTrue: [self showTaskbar]. - ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4191-ImageSaveTweaks-JuanVuletich-2020May26-17h00m-jmv.001.cs.st----! - -----SNAPSHOT----(26 May 2020 17:09:13) Cuis5.0-4191-v3.image priorSource: 5583805! - -----STARTUP---- (25 June 2020 16:07:26) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4191-v3.image! - - -'From Cuis 5.0 [latest update: #4191] on 27 May 2020 at 12:05:23 am'! -!Morph methodsFor: 'previewing' stamp: 'jmv 5/27/2020 00:04:36' prior: 50518074! - endPreview - - self previewing ifTrue: [ - owner notNil ifTrue: [ - self visible: self visibleBeforePreview. - owner addMorph: self inFrontOf: self morphBehindBeforePreview ]. - self previewing: false. ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4192-FixTaskbarEndDuringPreview-again-JuanVuletich-2020May27-00h04m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4192] on 27 May 2020 at 10:45:48 am'! -!Preferences class methodsFor: 'standard queries'! - showAnnotations - ^ self - valueOfFlag: #showAnnotations - ifAbsent: [ true ]! ! -!CodeProvider methodsFor: 'annotation' stamp: 'len 5/27/2020 06:05:39' prior: 16811688! - addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream - "add an annotation detailing the prior versions count" - | versionsCount | - - versionsCount _ VersionsBrowser versionCountForSelector: aSelector class: aClass. - aStream nextPutAll: - ((versionsCount > 1 - ifTrue: - [versionsCount = 2 ifTrue: - ['1 prior version'] - ifFalse: - [versionsCount printString, ' prior versions']] - ifFalse: - ['no prior versions']))! ! -!CodeProvider methodsFor: 'annotation' stamp: 'len 5/27/2020 05:54:38' prior: 16811738! - annotationForClassDefinitionFor: aClass - "Provide a line of content for an annotation pane, given that the receiver is pointing at the class definition of the given class." - - | separator | - separator _ self annotationSeparator. - ^ String streamContents: [ :strm | - strm - nextPutAll: 'class definition for '; - nextPutAll: aClass name; - nextPutAll: separator; - print: aClass theNonMetaClass selectors size; - nextPutAll: ' instance methods'; - nextPutAll: separator; - print: aClass theMetaClass selectors size; - nextPutAll: ' class methods'; - nextPutAll: separator; - print: aClass theNonMetaClass linesOfCode; - nextPutAll: ' total lines of code' ]! ! -!CodeProvider methodsFor: 'annotation' stamp: 'len 5/27/2020 06:41:23' prior: 50419086! - annotationForSelector: aSelector ofClass: aClass - "Provide a line of content for an annotation pane, representing - information about the given selector and class" - | stamp sendersCount implementorsCount aCategory separator aString aList aComment stream requestList | - aSelector == #Comment - ifTrue: [^ self annotationForClassCommentFor: aClass]. - aSelector == #Definition - ifTrue: [^ self annotationForClassDefinitionFor: aClass]. - aSelector == #Hierarchy - ifTrue: [^ self annotationForHierarchyFor: aClass]. - stream _ WriteStream on: String new. - requestList _ self annotationRequests. - separator _ self annotationSeparator. - requestList - do: [:aRequest | - aRequest == #firstComment - ifTrue: [ - aComment _ aClass firstCommentAt: aSelector. - aComment isEmptyOrNil - ifFalse: [stream position = 0 ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: aComment]]. - aRequest == #masterComment - ifTrue: [ - aComment _ aClass supermostPrecodeCommentFor: aSelector. - aComment isEmptyOrNil - ifFalse: [stream position = 0 ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: aComment]]. - aRequest == #documentation - ifTrue: [ - aComment _ aClass precodeCommentOrInheritedCommentFor: aSelector. - aComment isEmptyOrNil - ifFalse: [stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: aComment]]. - aRequest == #timeStamp - ifTrue: [ - stamp _ self timeStamp. - stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: (stamp size > 0 ifTrue: [stamp] ifFalse: ['no timestamp'])]. - aRequest == #messageCategory - ifTrue: [ - aCategory _ aClass organization categoryOfElement: aSelector. - aCategory - ifNotNil: ["woud be nil for a method no longer present, - e.g. in a recent-submissions browser" - stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: aCategory]]. - aRequest == #sendersCount - ifTrue: [ - sendersCount _ Smalltalk numberOfSendersOf: aSelector. - sendersCount _ sendersCount = 1 - ifTrue: ['1 sender'] - ifFalse: [sendersCount printString , ' senders']. - stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: sendersCount]. - aRequest == #implementorsCount - ifTrue: [ - implementorsCount _ Smalltalk numberOfImplementorsOf: aSelector. - implementorsCount _ implementorsCount = 1 - ifTrue: ['1 implementor'] - ifFalse: [implementorsCount printString , ' implementors']. - stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: implementorsCount]. - aRequest == #priorVersionsCount - ifTrue: [ - stream isEmpty ifFalse: [stream nextPutAll: separator]. - self - addPriorVersionsCountForSelector: aSelector - ofClass: aClass - to: stream]. - aRequest == #priorTimeStamp - ifTrue: [ - stamp _ VersionsBrowser - timeStampFor: aSelector - class: aClass - reverseOrdinal: 2. - stamp - ifNotNil: [stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: 'prior timestamp: ' , stamp]]. - aRequest == #packages - ifTrue: [ - (aClass compiledMethodAt: aSelector ifAbsent: nil) ifNotNil: [ :cm | - stream isEmpty ifFalse: [stream nextPutAll: separator]. - (CodePackage packageOfMethod: cm methodReference ifNone: nil) - ifNil: [ stream nextPutAll: 'in no package' ] - ifNotNil: [ :codePackage | - stream nextPutAll: 'in package '; nextPutAll: codePackage packageName ]]]. - aRequest == #changeSets - ifTrue: [ - stream isEmpty ifFalse: [stream nextPutAll: separator]. - aList _ ChangeSet allChangeSetsWithClass: aClass selector: aSelector. - aList size > 0 - ifTrue: [aList size = 1 - ifTrue: [stream nextPutAll: 'only in change set'] - ifFalse: [stream nextPutAll: 'in change sets:']. - aList - do: [:aChangeSet | stream nextPut: Character space; nextPutAll: aChangeSet name ] - separatedBy: [ stream nextPut: $, ]] - ifFalse: [stream nextPutAll: 'in no change set']]. - aRequest == #allChangeSets - ifTrue: [ - stream isEmpty ifFalse: [stream nextPutAll: separator]. - aList _ ChangeSet allChangeSetsWithClass: aClass selector: aSelector. - aList size > 0 - ifTrue: [aList size = 1 - ifTrue: [stream nextPutAll: 'only in change set'] - ifFalse: [stream nextPutAll: 'in change sets:']. - aList - do: [:aChangeSet | stream nextPut: Character space; nextPutAll: aChangeSet name ] - separatedBy: [ stream nextPut: $, ]] - ifFalse: [stream nextPutAll: 'in no change set']]. - aRequest == #allBaseSystemChangeSets - ifTrue: [ - stream isEmpty ifFalse: [stream nextPutAll: separator]. - aList _ (ChangeSet allChangeSetsWithClass: aClass selector: aSelector) select: [ :it | it isForBaseSystem ]. - aList size > 0 - ifTrue: [ - aList size = 1 - ifTrue: [stream nextPutAll: 'only in base system change set'] - ifFalse: [stream nextPutAll: 'in base system change sets:']. - aList - do: [:aChangeSet | stream nextPut: Character space; nextPutAll: aChangeSet name ] - separatedBy: [ stream nextPut: $, ]] - ifFalse: [stream nextPutAll: 'in no base system change set']]. - aRequest == #closuresInfo - ifTrue: [ - aString _ aClass closuresInfoAt: aSelector. - aString size > 0 - ifTrue: [stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: aString]]. - ]. - ^ stream contents! ! -!VersionsBrowser methodsFor: 'misc' stamp: 'len 5/27/2020 06:16:00' prior: 16942576 overrides: 50518390! - addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream - "Add an annotation detailing the prior versions count. Specially handled here for the case of a selector no longer in the system, whose prior versions are seen in a versions browser -- in this case, the inherited version of this method will not work." - - (aClass includesSelector: aSelector) ifTrue: - [^ super addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream]. - - aStream nextPutAll: - ((changeList size > 0 - ifTrue: - [changeList size = 1 - ifTrue: - ['deleted - one prior version'] - ifFalse: - ['deleted - ', changeList size printString, ' prior versions']] - ifFalse: - ['surprisingly, no prior versions']))! ! -!ChangeSorter methodsFor: 'annotation' stamp: 'len 5/27/2020 06:05:47' prior: 16799915 overrides: 50518390! - addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream - "Add an annotation detailing the prior versions count. Specially handled here for the case of a selector no longer in the system, whose prior version is pointed to by the lost-method pointer in the change held on to by the changeset" - - (aClass includesSelector: aSelector) ifTrue: - [^ super addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream]. - aStream nextPutAll: - ((myChangeSet methodInfoFromRemoval: {aClass name. aSelector}) - ifNil: - ['no prior versions'] - ifNotNil: - ['version(s) retrievable here'])! ! -!CodeWindow methodsFor: 'GUI building' stamp: 'len 5/27/2020 05:41:56' prior: 16812956! - buildLowerPanes - | codeAndButtons codeButtonsAndAnnotations | - codeAndButtons _ LayoutMorph newColumn. - Preferences optionalButtons ifTrue: [ - codeAndButtons - addMorph: self optionalButtonRow fixedHeight: self defaultButtonPaneHeight; - addAdjusterMorph ]. - codeAndButtons - addMorph: self buildMorphicCodePane proportionalHeight: 1.0. - Preferences showAnnotations ifFalse: [ - ^codeAndButtons ]. - codeButtonsAndAnnotations _ LayoutMorph newColumn. - codeButtonsAndAnnotations - addMorph: self buildMorphicAnnotationsPane fixedHeight: self defaultAnnotationPaneHeight; - addAdjusterMorph; - addMorph: codeAndButtons proportionalHeight: 1.0. - ^codeButtonsAndAnnotations! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'len 5/27/2020 05:42:09' prior: 16793009 overrides: 50518659! - buildLowerPanes - | codeAndButtons codeButtonsAndAnnotations comment separator | - comment _ self buildMorphicCommentPane. - separator _ LayoutAdjustingMorph new. - comment separator: separator. - codeAndButtons _ LayoutMorph newColumn. - Preferences optionalButtons ifTrue: [ - codeAndButtons - addMorph: self optionalButtonRow fixedHeight: self defaultButtonPaneHeight; - addAdjusterMorph ]. - codeAndButtons - addMorph: self buildMorphicCodePane proportionalHeight: 2.0; - addMorph: separator fixedHeight: 4; - addMorph: comment proportionalHeight: 2.0. - Preferences showAnnotations ifFalse: [ - ^codeAndButtons ]. - codeButtonsAndAnnotations _ LayoutMorph newColumn. - codeButtonsAndAnnotations - addMorph: self buildMorphicAnnotationsPane fixedHeight: self defaultAnnotationPaneHeight; - addAdjusterMorph; - addMorph: codeAndButtons proportionalHeight: 1.0. - ^codeButtonsAndAnnotations! ! -!MessageSetWindow methodsFor: 'GUI building' stamp: 'len 5/27/2020 05:43:00' prior: 50452789 overrides: 50518684! - buildLowerPanes - | codeAndButtons codeButtonsAndAnnotations | - codeAndButtons _ LayoutMorph newColumn. - Preferences optionalButtons ifTrue: [ - codeAndButtons - addMorph: self optionalButtonRow fixedHeight: self defaultButtonPaneHeight; - addAdjusterMorph ]. - codeAndButtons - addMorph: self buildMorphicCodePane proportionalHeight: 1.0. - Preferences showAnnotations ifFalse: [ - ^codeAndButtons ]. - codeButtonsAndAnnotations _ LayoutMorph newColumn. - codeButtonsAndAnnotations - addMorph: self buildMorphicAnnotationsPane fixedHeight: self defaultAnnotationPaneHeight; - addAdjusterMorph; - addMorph: codeAndButtons proportionalHeight: 1.0. - ^codeButtonsAndAnnotations! ! -!MessageSetWindow methodsFor: 'GUI building' stamp: 'len 6/30/2016 07:20' prior: 16870437 overrides: 50514822! - buildMorphicWindow - "Answer a morphic window with the given label that can display the receiver" - - self layoutMorph - addMorph: self buildMorphicMessageList proportionalHeight: 0.4; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.6. - model changed: #editSelection! ! -!VersionsBrowserWindow methodsFor: 'menu building' stamp: 'len 5/27/2020 06:34:56' prior: 50396653! - methodVersionsMenu - "Fill aMenu with menu items appropriate to the receiver" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Versions'. - aMenu addStayUpIcons. - model listIndex > 0 ifTrue:[ - (model list size > 1 ) ifTrue: [ - aMenu addItemsFromDictionaries: `{ - { - #label -> 'compare to current'. - #object -> #model. - #selector -> #compareToCurrentVersion. - #balloonText -> 'compare selected version to the current version' - } asDictionary. - { - #label -> 'compare to version...'. - #object -> #model. - #selector -> #compareToOtherVersion. - #balloonText -> 'compare selected version to another selected version' - } asDictionary. - }` ]. - "Note: Revert to selected should be visible for lists of length one for having the ability to revert to an accidentally deleted method" - aMenu addItemsFromDictionaries: `{ - { - #label -> 'revert to selected version (z)'. - #object -> #model. - #selector -> #fileInSelections. - #balloonText -> 'resubmit the selected version, so that it becomes the current version' - } asDictionary. - }` ]. - - aMenu addItemsFromDictionaries: `{ - { - #label -> 'edit current method (O)'. - #selector -> #openSingleMessageBrowser. - #balloonText -> 'open a single-message browser on the current version of this method' - } asDictionary. - nil. - { - #label -> 'toggle diffing (D)'. - #object -> #model. - #selector -> #toggleDiffing. - #balloonText -> 'toggle whether or not diffs should be shown here' - } asDictionary. - { - #label -> 'update list'. - #object -> #model. - #selector -> #reformulateList. - #balloonText -> 'reformulate the list of versions, in case it somehow got out of synch with reality' - } asDictionary. - nil. - { - #label -> 'senders (n)'. - #selector -> #browseSenders. - #balloonText -> 'browse all senders of this selector' - } asDictionary. - { - #label -> 'implementors (m)'. - #selector -> #browseImplementors. - #balloonText -> 'browse all implementors of this selector' - } asDictionary. - nil. - { - #label -> 'help...'. - #object -> #model. - #selector -> #offerVersionsHelp. - #balloonText -> 'provide an explanation of the use of this tool' - } asDictionary. - }`. - ^aMenu! ! -!VersionsBrowserWindow methodsFor: 'keyboard shortcuts' stamp: 'len 5/27/2020 06:32:28' prior: 16942855 overrides: 16797291! - changeListKey: aChar from: view - "Respond to a Command key in the list pane. of the versions browser" - - aChar == $z ifTrue: [^ model fileInSelections]. - ^ self messageListKey: aChar from: view! ! -!DebuggerWindow methodsFor: 'GUI building' stamp: 'len 5/27/2020 05:42:49' prior: 16830991 overrides: 50518659! - buildLowerPanes - | codeAndButtons codeButtonsAndAnnotations twoRowsOfButtons h | - twoRowsOfButtons _ LayoutMorph newColumn. - h _ self defaultButtonPaneHeight. - Preferences optionalButtons ifTrue: [ - h _ self defaultButtonPaneHeight * 2. - twoRowsOfButtons - addMorph: self optionalButtonRow proportionalHeight: 1.0; - addAdjusterMorph ]. - twoRowsOfButtons - addMorph: self customButtonRow proportionalHeight: 1.0. - codeAndButtons _ LayoutMorph newColumn. - codeAndButtons - addMorph: twoRowsOfButtons fixedHeight: h; - addAdjusterMorph; - addMorph: self buildMorphicCodePane proportionalHeight: 1.0. - Preferences showAnnotations ifFalse: [ - ^codeAndButtons ]. - codeButtonsAndAnnotations _ LayoutMorph newColumn. - codeButtonsAndAnnotations - addMorph: self buildMorphicAnnotationsPane fixedHeight: self defaultAnnotationPaneHeight; - addAdjusterMorph; - addMorph: codeAndButtons proportionalHeight: 1.0. - ^codeButtonsAndAnnotations! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4193-AnnotationsTweaks-LucianoEstebanNotarfrancesco-2020May27-10h45m-len.001.cs.st----! - -'From Cuis 5.0 [latest update: #4193] on 28 May 2020 at 11:21:51 am'! -!CodeProvider methodsFor: 'categories' stamp: 'len 5/28/2020 11:20:47' prior: 50513926! - categoryFromUserWithPrompt: aPrompt for: aClass - "self new categoryFromUserWithPrompt: 'testing' for: SystemDictionary" - - | labels myCategories reject lines newName menuIndex | - labels _ OrderedCollection with: 'new...'. - labels addAll: (myCategories _ aClass organization categories asArray copy sort: - [ :a :b | a asLowercase < b asLowercase ]). - reject _ myCategories asSet. - reject - add: ClassOrganizer nullCategory; - add: ClassOrganizer default. - lines _ OrderedCollection with: 1 with: (myCategories size + 1). - - aClass allSuperclasses do: [ :cls | | cats | - cats _ cls organization categories reject: [ :cat | reject includes: cat]. - cats isEmpty ifFalse: [ - lines add: labels size. - labels addAll: (cats asArray sort: [ :a :b | a asLowercase < b asLowercase]). - reject addAll: cats]]. - - (labels size = 1 or: [ - menuIndex _ (PopUpMenu labelArray: labels lines: lines) - startUpWithCaption: aPrompt. - menuIndex = 0 ifTrue: [^ nil]. - menuIndex = 1]) - ifTrue:[ - newName _ self request: 'New category name?' initialAnswer: 'category-name'. - newName isEmpty ifTrue: [ ^nil ]] - ifFalse: [ newName _ labels at: menuIndex ]. - ^ newName ifNotNil: [ newName asSymbol ]! ! -!Browser methodsFor: 'message category functions' stamp: 'len 5/28/2020 11:19:42' prior: 50514005! - newMethodCategoryNameIfNone: aNoneBlock - - | labels lines menuIndex newName reject | - - labels _ OrderedCollection with: 'new...'. - reject _ Set new. - reject - addAll: self selectedClassOrMetaClass organization categories; - add: ClassOrganizer nullCategory; - add: ClassOrganizer default. - lines _ OrderedCollection new. - self selectedClassOrMetaClass allSuperclasses do: [:cls | | cats | - cls = Object ifFalse: [ - cats _ cls organization categories reject: - [:cat | reject includes: cat]. - cats isEmpty ifFalse: [ - lines add: labels size. - labels addAll: cats asArray sort. - reject addAll: cats]]]. - newName _ (labels size = 1 or: [ - menuIndex _ (PopUpMenu labelArray: labels lines: lines) - startUpWithCaption: 'Add Category'. - menuIndex = 0 ifTrue: [^ aNoneBlock value]. - menuIndex = 1]) - ifTrue: [ - self request: 'New category name?' - initialAnswer: 'category-name'] - ifFalse: [ - labels at: menuIndex]. - - ^ newName isEmpty - ifTrue: aNoneBlock - ifFalse: [newName asSymbol]! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'RNG 3/16/2019 14:29:57' prior: 50514822! - buildMorphicWindow - "Create a pluggable version of all the morphs for a Browser in Morphic" - - | upperPanes messageCatList messageList systemCatList classList | - - systemCatList _ self buildMorphicSystemCatList. - classList _ self buildMorphicClassList. - messageCatList _ self buildMorphicMessageCatList. - messageList _ self buildMorphicMessageList. - - systemCatList rightSibling: classList. - classList leftSibling: systemCatList rightSibling: messageCatList. - messageCatList leftSibling: classList rightSibling: messageList. - messageList leftSibling: messageCatList. - - classList makeItemsDraggable. - systemCatList - acceptDropsFrom: classList - performing: #categorizeUnderCategoryAt:class: - whenOutsideList: #categorizeUnderNewCategoryClass:. - - messageList makeItemsDraggable. - messageCatList - acceptDropsFrom: messageList - performing: #categorizeUnderCategoryAt:selector: - whenOutsideList: #categorizeUnderNewCategorySelector:. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: systemCatList proportionalWidth: 0.2; - addAdjusterAndMorph: (self buildMorphicClassColumnWith: classList) proportionalWidth: 0.2; - addAdjusterAndMorph: messageCatList proportionalWidth: 0.2; - addAdjusterAndMorph: messageList proportionalWidth: 0.4. - - self layoutMorph - addMorph: upperPanes proportionalHeight: 0.3; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.7. - - model changed: #editSelection! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'jmv 1/10/2020 14:38:33' prior: 50514870! - buildNoSysCatMorphicWindow - "A Browser without the class categories list" - - | mySingletonList upperPanes messageCatList messageList classColumn classList | - mySingletonList _ PluggableListMorph - model: model - listGetter: #systemCategorySingleton - indexGetter: #indexIsOne - indexSetter: #indexIsOne: - mainView: self - menuGetter: #systemCatSingletonMenu - keystrokeAction: #systemCatSingletonKey:from:. - mySingletonList hideScrollBarsIndefinitely. - - classList _ self buildMorphicClassList. - classColumn _ self buildMorphicClassColumnWith: classList. - messageCatList _ self buildMorphicMessageCatList. - messageList _ self buildMorphicMessageList. - - classList rightSibling: messageCatList. - messageCatList leftSibling: classList rightSibling: messageList. - messageList leftSibling: messageCatList. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: classColumn proportionalWidth: 0.3; - addAdjusterAndMorph: messageCatList proportionalWidth: 0.3; - addAdjusterAndMorph: messageList proportionalWidth: 0.4. - - messageList makeItemsDraggable. - messageCatList - acceptDropsFrom: messageList - performing: #categorizeUnderCategoryAt:selector: - whenOutsideList: #categorizeUnderNewCategorySelector:. - - self layoutMorph - addMorph: mySingletonList fixedHeight: Preferences standardCodeFont lineSpacing + 10; - addAdjusterAndMorph: upperPanes proportionalHeight: 0.3; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.7. - - model changed: #editSelection! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4194-RestoreDnDAndCategoryNamePromptTweak-LucianoEstebanNotarfrancesco-2020May28-11h08m-len.001.cs.st----! - -'From Cuis 5.0 [latest update: #4194] on 29 May 2020 at 4:32:09 pm'! -!Workspace methodsFor: 'testing' stamp: 'jmv 5/29/2020 16:30:47'! - styleByParagraphs - "Answer true if each paragraph should be styled independent of the others. - This is useful in Workspaces, where the whole contents might not be valid Smalltalk. - Note that this precludes multi paragraph comments. Multiple comments are required in such cases." - - ^true! ! -!Workspace methodsFor: 'user interface support' stamp: 'jmv 5/29/2020 16:31:26' prior: 50518112 overrides: 50368780! - formatAndStyleIfNeededWith: anSHTextStyler - | separator fragmentStart fragmentEnd done| - (anSHTextStyler notNil and: [self shouldStyle: self actualContents with: anSHTextStyler]) - ifFalse: [^ self]. - - self styleByParagraphs ifFalse: [ - ^super formatAndStyleIfNeededWith: anSHTextStyler ]. - - actualContents _ actualContents optimizedForMutationSpeed. - anSHTextStyler formatWorkspace: actualContents. - separator _ String newLineString, String newLineString. - fragmentStart _ 1. - done _ false. - [done] whileFalse: [ - fragmentEnd _ actualContents - indexOfSubCollection: separator - startingAt: fragmentStart - ifAbsent: [done _ true. actualContents size]. - anSHTextStyler styleWorkspaceFrom: fragmentStart to: fragmentEnd. - fragmentStart _ fragmentEnd+separator size ]. - self changed: #shoutStyled! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4195-AllowWorkspaceSubclassesUseWholeContentsStyling-JuanVuletich-2020May29-16h29m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4195] on 31 May 2020 at 3:50:57 pm'! -!LayoutAdjustingMorph commentStamp: '' prior: 0! - When added to the submorphs of a LayoutMorph, -I am a way of directly adjusting layout width or height. - -I take care of the user interactions and delegate the actual changes to my containing LayoutMorph. -See LayoutAdjustingMorph>>adjustOwnerAt: - -The way adjustments are made differs between fixed and proportional Morphs. - -If I am between two proportional Morphs, the relative Morph proportions on both sides of me are adjusted. - -If the user is moving me between a fixed and a proportional morph, the fixed size is adjusted. - -The general effect is that if between 2 proportional Morphs, the proportions are adjusted and the -user sees the boundary between two morphs change. If one Morph is fixed, then the user sees -the proportional Morphs ALL adjust. An "accordian like" effect. This is NOT due to a change -in relative proportions but just the proportional expansion or squeezing of the proportional -Morphs themselves. - -E.g. note LayoutMorph class>>example11 which has a fixed Morph at each end. -! -!WindowEdgeAdjustingMorph commentStamp: '' prior: 0! - I am a LayoutAdjustingMorph which acts on window edges or corners. -! -!Symbol methodsFor: 'testing' stamp: 'KenD 4/30/2020 11:52:10' overrides: 50468409! - is: aSymbol - "Answer false if I am not a Symbol. - ??Note: A Symbol is also a String; should we check for #String and answer false??" - ^#Symbol = aSymbol or: [ super is: aSymbol]! ! -!Morph methodsFor: 'geometry' stamp: 'KenD 5/21/2020 15:17:30'! - allocHeightForFactor: aFactor - - "Morphs with LayoutSpecs may specify propottional layouts and minimum extents - amountToAlloc * proportion * factor >= minHeight - so breakeven is when - amountToAlloc = minHeight / proportion * factor" - | minHeight | - minHeight := self minimumLayoutHeight. - ^(self isProportionalHeight) - ifFalse: [ minHeight ] - ifTrue: [ minHeight / (aFactor * self layoutSpec privateProportionalHeight) ]! ! -!Morph methodsFor: 'geometry' stamp: 'KenD 5/21/2020 13:46:57'! - allocWidthForFactor: aFactor - - "Morphs with LayoutSpecs may specify propottional layouts and minimum extents - amountToAlloc * proportion * factor >= minWidth - so breakeven is when - amountToAlloc = minWidth / proportion * factor" - | minWidth | - minWidth := self minimumLayoutWidth. - ^(self isProportionalWidth) - ifFalse: [ minWidth ] - ifTrue: [ minWidth / (aFactor * self layoutSpec privateProportionalWidth) ]! ! -!Morph methodsFor: 'layout' stamp: 'KenD 5/11/2020 12:48:34'! - minLayoutHeight - - self flag: #deprecated. - ^ self layoutSpecOrNil - ifNil: [ self morphHeight ] - ifNotNil: [ :ls | ls minimumSpecHeight ] -! ! -!Morph methodsFor: 'layout' stamp: 'KenD 5/11/2020 12:48:26'! - minLayoutWidth - - self flag: #deprecated. - ^ self layoutSpecOrNil - ifNil: [ self morphWidth ] - ifNotNil: [ :ls | ls minimumSpecWidth ]! ! -!Morph methodsFor: 'layout' stamp: 'KenD 5/11/2020 12:42:30'! - minimumLayoutHeight - "I combine information from a Morph and its optional LayoutSpec" - | minHeight | - - minHeight _ self minimumExtent y. "from morph (me)." - ^ self layoutSpecOrNil - ifNil: [ minHeight ] - ifNotNil: [ :ls | minHeight max: (ls minimumSpecHeight )] -! ! -!Morph methodsFor: 'layout' stamp: 'KenD 5/11/2020 12:43:28'! - minimumLayoutWidth - "I combine information from a Morph and its optional LayoutSpec" - | minWidth | - - minWidth _ self minimumExtent x. "from morph (me)." - ^ self layoutSpecOrNil - ifNil: [ minWidth ] - ifNotNil: [ :ls | minWidth max: (ls minimumSpecWidth )] -! ! -!Morph methodsFor: 'layout' stamp: 'KenD 5/28/2020 21:38:39'! - minimumShrinkExtent - "This returns the minimum extent that the morph may be shrunk to. - It is expressed in the morph own coordinates, like morphExtent." - - | minExtent | - minExtent _ self minimumExtent. - ^ layoutSpec - ifNil: [ minExtent ] - ifNotNil: [ minExtent max: layoutSpec minimumShrinkWidth @ layoutSpec minimumShrinkHeight ]! ! -!Morph methodsFor: 'layout' stamp: 'KenD 5/31/2020 14:20:14'! - minimumShrinkHeight - "This returns the minimum height that the morph may be shrunk to by a LayoutAdjustingMorph. - It is expressed in the morph own coordinates, like morphExtent." - - | minShrinkHeight | - minShrinkHeight _ self minimumExtent y. - ^ layoutSpec - ifNil: [ minShrinkHeight ] - ifNotNil: [ minShrinkHeight max: layoutSpec minimumShrinkHeight ]! ! -!Morph methodsFor: 'layout' stamp: 'KenD 5/28/2020 21:47:43'! - minimumShrinkWidth - "This returns the minimum width that the morph may be shrunk to by a LayoutAdjustingMorph. - It is expressed in the morph own coordinates, like morphExtent." - - | minShrinkWidth | - minShrinkWidth _ self minimumExtent x. - ^ layoutSpec - ifNil: [ minShrinkWidth ] - ifNotNil: [ minShrinkWidth max: layoutSpec minimumShrinkWidth ]! ! -!Morph methodsFor: 'testing' stamp: 'KenD 5/11/2020 13:04:22'! - isProportionalHeight - "Answer true if I have a layoutSpec which specifies a proportional layout" - - ^self layoutSpecOrNil - ifNil: [ false ] - ifNotNil: [ :ls | ls isProportionalHeight ]! ! -!Morph methodsFor: 'testing' stamp: 'KenD 5/11/2020 13:04:10'! - isProportionalWidth - "Answer true if I have a layoutSpec which specifies a proportional layout" - - ^self layoutSpecOrNil - ifNil: [ false ] - ifNotNil: [ :ls | ls isProportionalWidth ]! ! -!PluggableButtonMorph methodsFor: 'geometry' stamp: 'KenD 5/5/2020 12:15:55' overrides: 50519194! -minLayoutHeight - - ^ self minimumExtent y! ! -!PluggableButtonMorph methodsFor: 'geometry' stamp: 'KenD 5/5/2020 12:16:08' overrides: 50519201! - minLayoutWidth - - ^ self minimumExtent x! ! -!PluggableButtonMorph methodsFor: 'geometry' stamp: 'KenD 5/5/2020 17:07:16' overrides: 50499537! - minimumExtent - - | e | - e _ Preferences windowTitleFont pointSize + 2. - ^e@e! ! -!LayoutMorph methodsFor: 'accessing' stamp: 'KenD 5/2/2020 15:09:07'! - axisEdgeWeight - - ^ padding! ! -!LayoutMorph methodsFor: 'accessing' stamp: 'KenD 4/30/2020 11:54:47'! - axisEdgeWeight: aSymbolOrNumber - "Along the Major or Layout Axis, subMorphs may be attracted toward one side (0.0) or the other (1.0). This is the LayoutMorph's axisEdgeWeight. A numeric value is between 0.0 and 1.0 - - If a Row, one can specify this weight symbolically as - { #rowLeft (0.0), #center (0.5), #rowRight (1.0)} - - If a Column, one can specify the weight symbolically as: - { #columnTop (0.0), #center (0.5), #columnBottom (1.0) }" -" - self axisEdgeWeight: #rowLeft. -- axis must be horizontal - self axisEdgeWeight: #columnTop. -- axis must be vertical -" - | edgeWeight | - (aSymbolOrNumber is: #Number) - ifTrue: [ (aSymbolOrNumber between: 0.0 and: 1.0) - ifTrue: [edgeWeight := aSymbolOrNumber ] - ifFalse: [self error: 'axisEdgeWeight ', aSymbolOrNumber printString, ' is out of range 0.0 to 1.0'] - ] - ifFalse: [ - (self direction = #horizontal) - ifTrue: [ "Row" - edgeWeight := aSymbolOrNumber - caseOf: { - [ #rowLeft ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #rowRight ] -> [ 1.0 ] - } - otherwise: [ self error: 'bad axisEdgeWeight for Row: ', aSymbolOrNumber printString ]. - ] - ifFalse: [ "vertical => Column" - edgeWeight := aSymbolOrNumber - caseOf: { - [ #columnTop ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #columnBottom ] -> [ 1.0 ] - } - otherwise: [ self error: 'bad axisEdgeWeight for Column: ', aSymbolOrNumber printString ]. - ] - ]. - padding := edgeWeight. - "self layoutSubmorphs"! ! -!LayoutMorph methodsFor: 'layout' stamp: 'KenD 5/27/2020 12:32:46'! - heightsFor: visibleSubs within: overallHeight - "Answer array of morphHeights for visibleSubs." - "Preconditions: - ySepararations already subtracted from overallHeight. - overallHeight is large enough to contain minimumLayoutHeights of visibleSubs." - - | numSubs scaleFactor heightToAllocate - sumOfPropMin sumOfPropDesired sumOfFixedMin - allocatedHeights propIndices desiredProps - maxOfMinAllocHeight - | - numSubs := visibleSubs size. - sumOfFixedMin := 0. "pixels" - sumOfPropMin := 0. "pixels" - sumOfPropDesired := 0. "sum of percentage fractions; may be more than 100%" - allocatedHeights := Array ofSize: numSubs. - desiredProps := Array ofSize: numSubs. - propIndices := Set new. "keep set of proportional morph indices" - 1 to: numSubs do: [ :index | | sm layoutHeightMin | - sm := visibleSubs at: index. - layoutHeightMin := sm minimumLayoutHeight. - allocatedHeights at: index put: layoutHeightMin. - (sm isProportionalHeight) - ifTrue: [ | propDesired | - propIndices add: index. - propDesired := sm layoutSpec privateProportionalHeight. - desiredProps at: index put: propDesired. - sumOfPropDesired := sumOfPropDesired + propDesired. - sumOfPropMin := sumOfPropMin + layoutHeightMin. - ] - ifFalse: [ "Allocate height for non-proportional-height morphs" - sumOfFixedMin := sumOfFixedMin + layoutHeightMin. - ] - ]. - - ((propIndices size = 0) "already finished" - or: [(overallHeight - (sumOfFixedMin + sumOfPropMin)) < 2]) "close enough" - ifTrue: [ ^ allocatedHeights ]. - - "All fixed heights allocated; rest is for proportional + leftOver" - heightToAllocate := (overallHeight - sumOfFixedMin) max: 0. - scaleFactor := 1.0 / (sumOfPropDesired max: 1.0). "if > 100% then below 1" - - "Do simple default scaling" - propIndices do: [ :morphIndex | - allocatedHeights at: morphIndex - put: ((allocatedHeights at: morphIndex) max: - (heightToAllocate - * scaleFactor - * (desiredProps at: morphIndex))) - ]. - - "Find the min alloc size at which adding height is above max of minHeights - Keep the proportions over the minHeights at this allocation." - maxOfMinAllocHeight := propIndices max: [ :morphIndex | - (visibleSubs at: morphIndex) allocHeightForFactor: scaleFactor - ]. - - "Below the balance point, calculate proportions from belowBalanceDeltas, - above, use desiredProps" - (heightToAllocate <= maxOfMinAllocHeight) ifTrue: [ | belowBalanceDeltas sumOfDeltas | - (sumOfPropDesired < 1.0) "Trim off space to save" - ifTrue: [ heightToAllocate := heightToAllocate * sumOfPropDesired ]. - belowBalanceDeltas := Array ofSize: visibleSubs size. - propIndices do: [ :morphIndex | | heightAtBalance | - heightAtBalance := maxOfMinAllocHeight * scaleFactor * (desiredProps at: morphIndex). - belowBalanceDeltas at: morphIndex - put: heightAtBalance "delta above min height" - - ((visibleSubs at: morphIndex) minimumLayoutHeight) - ]. - sumOfDeltas := belowBalanceDeltas sum: [ :b | b ifNil: [0]]. - (sumOfDeltas > propIndices size) ifTrue: [ "space desired < 100%" - propIndices do: [ :morphIndex | - allocatedHeights at: morphIndex - put: ((visibleSubs at: morphIndex) minimumLayoutHeight) - + (((heightToAllocate - sumOfPropMin ) max: 0.0) - * (belowBalanceDeltas at: morphIndex) / sumOfDeltas) - ] - ] - ]. - - ^ allocatedHeights! ! -!LayoutMorph methodsFor: 'layout' stamp: 'KenD 5/12/2020 14:07:31'! - offHorizontalMetricFor: aMorph withinExtent: boundsForLayout - "Answer a point: height@y for a single morph -- offAxis calculation for a Row" - - | spec minMorphHeight theSeparation proportionalHeight - availableForPropHeight actualPropHeight - leftOver yPos | - spec := aMorph layoutSpec. - theSeparation := self ySeparation. - minMorphHeight := aMorph minimumLayoutHeight. - availableForPropHeight := (boundsForLayout height) - (2 * theSeparation).. - proportionalHeight := spec proportionalLayoutHeight min: 1.0. - actualPropHeight := (availableForPropHeight * proportionalHeight) - max: minMorphHeight. - leftOver := availableForPropHeight - actualPropHeight. - - yPos := boundsForLayout origin y - + theSeparation - + (leftOver * spec offAxisEdgeWeight). "first Y, edge shifted" - - ^ actualPropHeight @ yPos - - ! ! -!LayoutMorph methodsFor: 'layout' stamp: 'KenD 5/12/2020 14:07:42'! - offVerticalMetricFor: aMorph withinExtent: boundsForLayout - "Answer a point: x@width for a single morph -- offAxis calculation for a Column" - - | spec minMorphWidth theSeparation proportionalWidth - availableForPropWidth actualPropWidth - leftOver xPos | - spec := aMorph layoutSpec. - theSeparation := self xSeparation. - minMorphWidth := aMorph minimumLayoutWidth. - availableForPropWidth := (boundsForLayout width) - (2 * theSeparation). - proportionalWidth := spec proportionalLayoutWidth min: 1.0. - actualPropWidth := (availableForPropWidth * proportionalWidth) - max: minMorphWidth. - leftOver := availableForPropWidth - actualPropWidth. - - xPos := boundsForLayout origin x - + theSeparation - + (leftOver * spec offAxisEdgeWeight). "first X, edge shifted" - - ^ xPos @ actualPropWidth - ! ! -!LayoutMorph methodsFor: 'layout' stamp: 'KenD 5/27/2020 12:33:28'! - widthsFor: visibleSubs within: overallWidth - "Answer array of morphWidths for visibleSubs." - "Preconditions: - xSepararations already subtracted from overallWidth. - overallWidth is large enough to contain minimumLayoutWidths of visibleSubs." - - | numSubs scaleFactor widthToAllocate - sumOfPropMin sumOfPropDesired sumOfFixedMin - allocatedWidths propIndices desiredProps - maxOfMinAllocWidth - | - numSubs := visibleSubs size. - sumOfFixedMin := 0. "pixels" - sumOfPropMin := 0. "pixels" - sumOfPropDesired := 0. "sum of percentage fractions; may be more than 100%" - allocatedWidths := Array ofSize: numSubs. - desiredProps := Array ofSize: numSubs. - propIndices := Set new. "keep set of proportional morph indices" - 1 to: numSubs do: [ :index | | sm layoutWidthMin | - sm := visibleSubs at: index. - layoutWidthMin := sm minimumLayoutWidth. - allocatedWidths at: index put: layoutWidthMin. - (sm isProportionalWidth) - ifTrue: [ | propDesired | - propIndices add: index. - propDesired := sm layoutSpec privateProportionalWidth. - desiredProps at: index put: propDesired. - sumOfPropDesired := sumOfPropDesired + propDesired. - sumOfPropMin := sumOfPropMin + layoutWidthMin. - ] - ifFalse: [ "Allocate width for non-proportional-width morphs" - sumOfFixedMin := sumOfFixedMin + layoutWidthMin. - ] - ]. - - ((propIndices size = 0) "already finished" - or: [(overallWidth - (sumOfFixedMin + sumOfPropMin)) < 2]) "close enough" - ifTrue: [ ^ allocatedWidths ]. - - "All fixed widths allocated; rest is for proportional + leftOver" - widthToAllocate := (overallWidth - sumOfFixedMin) max: 0. - scaleFactor := 1.0 / (sumOfPropDesired max: 1.0). "if > 100% then below 1" - - "Do simple default scaling" - propIndices do: [ :morphIndex | - allocatedWidths at: morphIndex - put: ((allocatedWidths at: morphIndex) max: - (widthToAllocate - * scaleFactor - * (desiredProps at: morphIndex))) - ]. - - "Find the min alloc size at which adding width is above max of minWidths - Keep the proportions over the minWidths at this allocation." - maxOfMinAllocWidth := propIndices max: [ :morphIndex | - (visibleSubs at: morphIndex) allocWidthForFactor: scaleFactor - ]. - - "Below the balance point, calculate proportions from belowBalanceDeltas, - above, use desiredProps" - (widthToAllocate <= maxOfMinAllocWidth) ifTrue: [ | belowBalanceDeltas sumOfDeltas | - (sumOfPropDesired < 1.0) "Trim off space to save" - ifTrue: [ widthToAllocate := widthToAllocate * sumOfPropDesired ]. - belowBalanceDeltas := Array ofSize: visibleSubs size. - propIndices do: [ :morphIndex | | widthAtBalance | - widthAtBalance := maxOfMinAllocWidth * scaleFactor * (desiredProps at: morphIndex). - belowBalanceDeltas at: morphIndex - put: widthAtBalance "delta above min width" - - ((visibleSubs at: morphIndex) minimumLayoutWidth) - ]. - sumOfDeltas := belowBalanceDeltas sum: [ :b | b ifNil: [0]]. - (sumOfDeltas > propIndices size) ifTrue: [ "space desired < 100%" - propIndices do: [ :morphIndex | - allocatedWidths at: morphIndex - put: ((visibleSubs at: morphIndex) minimumLayoutWidth) - + (((widthToAllocate - sumOfPropMin ) max: 0.0) - * (belowBalanceDeltas at: morphIndex) / sumOfDeltas) - ] - ] - ]. - - ^ allocatedWidths! ! -!LayoutMorph methodsFor: 'submorphs-add/remove' stamp: 'KenD 5/26/2020 15:14:45' overrides: 16876848! - addMorphFront: aMorph - "Add a submorph, at the bottom or right, with a default LayoutSpec if none was provided." - - aMorph layoutSpec. - super addMorphFront: aMorph! ! -!LayoutMorph methodsFor: 'submorphs-add/remove' stamp: 'KenD 5/28/2020 07:33:52' overrides: 16876964! - removedMorph: aMorph - "One of my submorphs has been removed." - - super removedMorph: aMorph. - self layoutSubmorphs! ! -!LayoutMorph methodsFor: 'testing' stamp: 'KenD 5/4/2020 12:58:45'! - isColumn - - ^ direction = #vertical! ! -!LayoutMorph methodsFor: 'testing' stamp: 'KenD 5/4/2020 12:57:59'! - isRow - - ^ direction = #horizontal! ! -!LayoutMorph methodsFor: 'private' stamp: 'KenD 5/29/2020 13:57:00' overrides: 16877049! - privateAddAllMorphs: aCollection atIndex: index - aCollection do: [ :m | m layoutSpec ]. - ^super privateAddAllMorphs: aCollection atIndex: index! ! -!LayoutMorph methodsFor: 'private' stamp: 'KenD 5/29/2020 13:57:16' overrides: 16877086! - privateAddMorph: aMorph atIndex: index - aMorph layoutSpec. - ^super privateAddMorph: aMorph atIndex: index! ! -!LayoutMorph methodsFor: 'private' stamp: 'KenD 5/29/2020 13:57:32' overrides: 16877128! - privateAddMorph: aMorph atIndex: index position: aPoint - aMorph layoutSpec. - ^super privateAddMorph: aMorph atIndex: index position: aPoint! ! -!LayoutMorph methodsFor: 'deprecated' stamp: 'KenD 5/31/2020 14:13:54'! - padding - - self flag: #deprecated - ^ padding! ! -!LayoutMorph methodsFor: '*morphic-misc1' stamp: 'KenD 12/24/2013 15:14'! - direction: horizOrVert - - self flag: #jmvVer. "Move to category #accessing" - - direction := horizOrVert! ! -!LayoutSpec methodsFor: 'accessing' stamp: 'KenD 4/30/2020 09:34:28'! - offAxisEdgeWeight - ^minorDirectionPadding! ! -!LayoutSpec methodsFor: 'accessing' stamp: 'KenD 5/28/2020 07:31:23'! - offAxisEdgeWeight: aSymbolOrNumber - "A LayoutSpec may indicate a weighting perpendicular to the Layout Axis. - - This is the LayoutSpec's offAxisEdgeWeight which is between 0.0 and 1.0. - - As with LayoutSpec's a symbol may be used. - - If in a Row (preferred): { #rowTop (0.0), #center (0.5), #rowBottom (1.0)} - - If in a Column (preferred): { #columnLeft (0.0), #center (0.5), #columnRight (1.0) } - - Also accepted: { #leftOrTop (0.0), #center (0.5), #rightOrBottom (1.0) } - " - | edgeWeight | - edgeWeight := (aSymbolOrNumber is: #Number) - ifTrue: [ (aSymbolOrNumber between: 0.0 and: 1.0) - ifTrue: [ aSymbolOrNumber ] - ifFalse: [self error: 'axisEdgeWeight ', aSymbolOrNumber printString, ' is out of range 0.0 to 1.0'] - ] - ifFalse: [ aSymbolOrNumber - caseOf: { - [ #leftOrTop ] -> [ 0.0 ]. - [ #rowTop ] -> [ 0.0 ]. - [ #columnLeft ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #rightOrBottom ] -> [ 1.0 ]. - [ #rowBottom ] -> [ 1.0 ]. - [ #columnRight ] -> [ 1.0 ] - } - otherwise: [ self error: 'bad offAxisEdgeWeight specifier: ', aSymbolOrNumber printString ] - ]. - minorDirectionPadding _ edgeWeight! ! -!LayoutSpec methodsFor: 'layout' stamp: 'KenD 5/28/2020 21:35:37'! - minimumShrinkHeight - "Generally prefer asking the morph itself!!" - - proportionalHeight ifNil: [ ^0 ]. - ^fixedHeight ifNil: [0]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'KenD 5/28/2020 21:35:20'! - minimumShrinkWidth - "Generally prefer asking the morph itself!!" - - proportionalWidth ifNil: [ ^0 ]. - ^fixedWidth ifNil: [0]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'KenD 5/11/2020 12:51:04'! - minimumSpecExtent - - ^ self minimumSpecWidth @ self minimumSpecHeight ! ! -!LayoutSpec methodsFor: 'layout' stamp: 'KenD 5/11/2020 12:36:37'! - minimumSpecHeight - "If fixedHeight is not nil, use it. - If fixdHeight and propostionlHeight are nil, use morphHeight" - - ^ fixedHeight ifNil: [ proportionalHeight ifNotNil: [ 0 ] ifNil: [ morph morphHeight ] ]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'KenD 5/11/2020 12:37:14'! - minimumSpecWidth - "If fixedWidth is not nil, use it. - If fixdWidth and propostionlWidth are nil, use morphWidth" - - ^ fixedWidth ifNil: [ proportionalWidth ifNotNil: [ 0 ] ifNil: [ morph morphWidth ] ]! ! -!LayoutSpec methodsFor: 'deprecated' stamp: 'KenD 5/31/2020 14:19:05'! - fixedOrMorphHeight - - self flag: #deprecated. - - ^fixedHeight ifNil: [ morph morphHeight ]! ! -!LayoutSpec methodsFor: 'deprecated' stamp: 'KenD 5/31/2020 14:18:45'! - fixedOrMorphWidth - - self flag: #deprecated. - - ^fixedWidth ifNil: [ morph morphWidth ]! ! -!LayoutSpec methodsFor: '*morphic-misc1' stamp: 'KenD 4/18/2015 20:18'! - morph - "For #showHalo" - ^ morph! ! -!LayoutSpec methodsFor: '*morphic-misc1' stamp: 'KenD 12/24/2013 15:15'! - privateFixedWidth - - ^ fixedWidth! ! -!LayoutSpec methodsFor: '*morphic-misc1' stamp: 'KenD 12/24/2013 15:15'! - privateProportionalWidth - - ^ proportionalWidth ! ! -!LayoutSpec class methodsFor: 'instance creation' stamp: 'KenD 5/22/2020 13:49:12'! - fixedWidth: aNumber fixedHeight: otherNumber offAxisEdgeWeight: aSymbolOrNumber - ^ LayoutSpec new - fixedWidth: aNumber; - fixedHeight: otherNumber; - offAxisEdgeWeight: aSymbolOrNumber! ! -!LayoutSpec class methodsFor: 'instance creation' stamp: 'KenD 5/22/2020 13:54:56'! - fixedWidth: aNumber proportionalHeight: otherNumber offAxisEdgeWeight: aSymbolOrNumber - - ^self new - fixedWidth: aNumber; - proportionalHeight: otherNumber; - offAxisEdgeWeight: aSymbolOrNumber! ! -!LayoutSpec class methodsFor: 'instance creation' stamp: 'KenD 5/22/2020 13:55:19'! - proportionalWidth: aNumber fixedHeight: otherNumber offAxisEdgeWeight: aSymbolOrNumber - - ^self new - proportionalWidth: aNumber; - fixedHeight: otherNumber; - offAxisEdgeWeight: aSymbolOrNumber! ! -!LayoutSpec class methodsFor: 'instance creation' stamp: 'KenD 5/22/2020 13:56:21'! - proportionalWidth: aNumber proportionalHeight: otherNumber offAxisEdgeWeight: aSymbolOrNumber - - ^self new - proportionalWidth: aNumber; - proportionalHeight: otherNumber; - offAxisEdgeWeight: aSymbolOrNumber! ! -!Morph methodsFor: 'geometry' stamp: 'KenD 5/29/2020 14:15:06' prior: 50500191! - minimumLayoutExtent - "This returns the minimum extent that the morph may be shrunk to, - when resizing LayoutMorphs. - It is expressed in the morph own coordinates, like morphExtent." - - "This method combines the information from a Morph and its optional LayoutSpec" - | minExtent | - minExtent _ self minimumExtent. - ^ layoutSpec - ifNil: [ minExtent ] - ifNotNil: [ minExtent max: ( layoutSpec minimumSpecWidth @ layoutSpec minimumSpecHeight ) ]! ! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'KenD 5/29/2020 14:03:30' prior: 16876780! - addAllMorphs: aCollection - ^ (aCollection size > 0) - ifTrue: [ self privateAddAllMorphs: aCollection atIndex: submorphs size ] - ifFalse: [ self ]! ! -!BrowserCommentTextMorph methodsFor: 'displaying' stamp: 'KenD 5/5/2020 17:24:59' prior: 50499568! - hidePane - - self hide. - separator visible ifTrue: [ - proportionalHeight _ self layoutSpec proportionalLayoutHeight. - separatorHeight _ separator layoutSpec fixedOrMorphHeight ]. - separator layoutSpec fixedHeight: 0. - self layoutSpec proportionalHeight: 0. - separator ifNotNil: [ separator hide ]! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'KenD 5/22/2020 13:59:53' prior: 50432047! - buildRequirementsPane - - | requirements deleteReqButton "editReqButton" reqLayout buttonLayout updateReqButton | - requirements := PluggableListMorph - model: (PackageRequirementsList fromCodePackageList: model) - listGetter: #requirementsStrings - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - requirements color: Theme current textPane. - - deleteReqButton := PluggableButtonMorph - model: requirements model - action: #deleteSelectedRequirement - label: 'delete'. - deleteReqButton color: self widgetsColor. - updateReqButton _ PluggableButtonMorph - model: requirements model - action: #updateSelectedRequirement - label: 'update'. - updateReqButton color: self widgetsColor. - - buttonLayout := LayoutMorph newRow. - buttonLayout - addMorph: deleteReqButton - layoutSpec: (LayoutSpec - proportionalWidth: 1.0 - proportionalHeight: 1.0 - offAxisEdgeWeight: #leftOrTop); - color: self widgetsColor quiteWhiter; - addMorph: updateReqButton - layoutSpec: (LayoutSpec - proportionalWidth: 1.0 - proportionalHeight: 1.0 - offAxisEdgeWeight: #leftOrTop); - color: self widgetsColor quiteWhiter. - - model when: #changed: send: #updateRequirementsFromPackageList to: requirements model. - self when: #changed: send: #updateRequirementsFromPackageList to: requirements model. - requirements model when: #changed: send: #verifyContents to: requirements. - self when: #changed: send: #verifyContents to: requirements. - - reqLayout := LayoutMorph newRow. - ^ reqLayout - doAdoptWidgetsColor; - addMorph: requirements - layoutSpec: (LayoutSpec - proportionalWidth: 0.8 - proportionalHeight: 1.0 - offAxisEdgeWeight: #leftOrTop); - addMorph: buttonLayout - layoutSpec: (LayoutSpec - proportionalWidth: 0.2 - proportionalHeight: 1.0 - offAxisEdgeWeight: #rightOrBottom); - color: `Color transparent`; - yourself - ! ! -!StringRequestMorph class methodsFor: 'private' stamp: 'KenD 5/25/2020 12:37:58' prior: 50518091! - deltaToTextPane - "Answer a distance to translate an instance of the receiver by when it is opened in the world in order to have the hand be over the text pane (so the text pane has focus). - Distance is relative to font size" - | e | - e _ Preferences windowTitleFont lineSpacing. - ^ (2 * e)@(1.5 * e)! ! -!LayoutMorph methodsFor: 'accessing' stamp: 'KenD 5/15/2020 17:49:30' prior: 50500244 overrides: 16876867! - addMorphFrontFromWorldPosition: aMorph - - aMorph layoutSpecOrNil ifNil: [aMorph layoutSpec: LayoutSpec keepMorphExtent ]. - self addMorphFront: aMorph. - self layoutSubmorphs. -! ! -!LayoutMorph methodsFor: 'adjust' stamp: 'KenD 5/31/2020 15:38:28' prior: 16863051! - adjustBy: aLayoutAdjustMorph at: aPoint - "See Class Comment of LayoutAdjustingMorph" - - direction == #horizontal ifTrue: [ - self adjustHorizontallyBy: aLayoutAdjustMorph at: aPoint ]. - - direction == #vertical ifTrue: [ - self adjustVerticallyBy: aLayoutAdjustMorph at: aPoint ].! ! -!LayoutMorph methodsFor: 'adjust' stamp: 'KenD 5/28/2020 21:46:22' prior: 50499587! - adjustHorizontallyBy: aLayoutAdjustMorph at: aPoint - | delta l ls r rs lNewWidth rNewWidth i lCurrentWidth rCurrentWidth | - i _ submorphs indexOf: aLayoutAdjustMorph. - l _ self submorphs at: i +1. - ls _ l layoutSpec. - lCurrentWidth _ l morphWidth max: 1. "avoid division by zero" - r _ self submorphs at: i - 1. - rs _ r layoutSpec. - rCurrentWidth _ r morphWidth max: 1. "avoid division by zero" - delta _ aPoint x - aLayoutAdjustMorph referencePosition x. - delta _ delta max: l minimumShrinkWidth - lCurrentWidth. - delta _ delta min: rCurrentWidth - r minimumShrinkWidth. - delta = 0 ifTrue: [ ^self ]. - rNewWidth _ rCurrentWidth - delta. - lNewWidth _ lCurrentWidth + delta. - (ls isProportionalWidth and: [ rs isProportionalWidth ]) - ifTrue: [ | leftNewProportion rightNewProportion toDistribute | "If both proportional, update them" - leftNewProportion _ lNewWidth / (lNewWidth + rNewWidth). - rightNewProportion _ 1.0 - leftNewProportion. - toDistribute _ ls proportionalLayoutWidth + rs proportionalLayoutWidth. - ls setProportionalWidth: leftNewProportion * toDistribute. - rs setProportionalWidth: rightNewProportion * toDistribute ] - ifFalse: ["If at least one is fixed, update only the fixed" - ls isProportionalWidth ifFalse: [ - ls fixedOrMorphWidth: lNewWidth ]. - rs isProportionalWidth ifFalse: [ - rs fixedOrMorphWidth: rNewWidth ]]. - self layoutSubmorphs.! ! -!LayoutMorph methodsFor: 'adjust' stamp: 'KenD 5/28/2020 21:49:25' prior: 50499633! - adjustVerticallyBy: aLayoutAdjustMorph at: aPoint - | delta t ts b bs tNewHeight bNewHeight i tCurrentHeight bCurrentHeight | - i _ submorphs indexOf: aLayoutAdjustMorph. - t _ self submorphs at: i +1. - ts _ t layoutSpec. - tCurrentHeight _ t morphHeight max: 1. "avoid division by zero" - b _ self submorphs at: i - 1. - bs _ b layoutSpec. - bCurrentHeight _ b morphHeight max: 1. "avoid division by zero" - delta _ aPoint y - aLayoutAdjustMorph referencePosition y. - delta _ delta max: t minimumShrinkHeight - tCurrentHeight. - delta _ delta min: bCurrentHeight - b minimumShrinkHeight. - delta = 0 ifTrue: [ ^self ]. - tNewHeight _ tCurrentHeight + delta. - bNewHeight _ bCurrentHeight - delta. - (ts isProportionalHeight and: [ bs isProportionalHeight ]) - ifTrue: [ | bottomNewProportion toDistribute topNewProportion | "If both proportional, update them" - topNewProportion _ tNewHeight / (tNewHeight + bNewHeight). - bottomNewProportion _ 1.0 - topNewProportion. - toDistribute _ ts proportionalLayoutHeight + bs proportionalLayoutHeight. - ts setProportionalHeight: topNewProportion * toDistribute. - bs setProportionalHeight: bottomNewProportion * toDistribute ] - ifFalse: ["If at least one is fixed, update only the fixed" - ts isProportionalHeight ifFalse: [ - ts fixedOrMorphHeight: tNewHeight ]. - bs isProportionalHeight ifFalse: [ - bs fixedOrMorphHeight: bNewHeight ]]. - self layoutSubmorphs! ! -!LayoutMorph methodsFor: 'geometry' stamp: 'KenD 5/15/2020 19:24:31' prior: 50500785 overrides: 50499537! - minimumExtent - "Answer size sufficient to frame my submorphs." - - | width height | - width := 0. - height := 0. - (self direction = #vertical) - ifTrue: [ "Column" - self submorphsToLayout do: [ :sm | - "use maximum width across submorphs" - width := width max: sm minimumLayoutWidth. - "sum up submorph heights, including separation" - height := height + (sm minimumLayoutHeight) + self ySeparation. - ]. - width := width + (2 * self xSeparation). "separation on each side" - height := height + self ySeparation. "one side already separated" - ] - ifFalse: [ "Row" - self submorphsToLayout do: [ :sm | - "sum up submorphs width" - width := width + (sm minimumLayoutWidth) + self xSeparation. - "use maximum height across submorph" - height := height max: sm minimumLayoutHeight. - ]. - height := height + (2 * self ySeparation). "separation on each side" - width := width + self xSeparation. "one side already separated" - ]. - - ^ (width @ height) + self extentBorder! ! -!LayoutMorph methodsFor: 'initialization' stamp: 'KenD 5/12/2020 09:23:30' prior: 50500479! - beColumn - "Establish the major layout axis, with default edge weight" - - direction _ #vertical. - self axisEdgeWeight ifNil: [self axisEdgeWeight: #center]. - self layoutSubmorphs.! ! -!LayoutMorph methodsFor: 'initialization' stamp: 'KenD 5/12/2020 09:23:35' prior: 50500485! - beRow - "Establish the major layout axis, with default edge weight" - - direction _ #horizontal. - self axisEdgeWeight ifNil: [self axisEdgeWeight: #rowLeft]. - self layoutSubmorphs.! ! -!LayoutMorph methodsFor: 'layout' stamp: 'pb 3/17/2020 13:41:27' prior: 50503576! - layoutBounds - "Return the bounds for laying out children of the receiver" - - ^ self morphLocalBounds! ! -!LayoutMorph methodsFor: 'layout' stamp: 'KenD 5/9/2020 14:25:12' prior: 16863321 overrides: 16876028! - layoutSubmorphs - "Compute a new layout based on the given layout bounds." - - submorphs isEmpty ifTrue: [ - layoutNeeded _ false. - ^self]. - - "Invariant: morphExtent >= minimumLayoutExtent" - self refreshExtent. - - direction == #horizontal ifTrue: [ - self layoutSubmorphsHorizontallyIn: self layoutBounds ]. - - direction == #vertical ifTrue: [ - self layoutSubmorphsVerticallyIn: self layoutBounds ]. - - layoutNeeded _ false! ! -!LayoutMorph methodsFor: 'layout' stamp: 'KenD 5/12/2020 14:10:38' prior: 50513305! - layoutSubmorphsHorizontallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - - | visibleSubmorphs sumOfWidths theSeparation widthsArray - widthToAllocate leftOver nextX | - "Preconditions: self isRow & morphExtent >= minimumLayoutExtent" - visibleSubmorphs := self submorphsToLayout reversed. "Display Order" - theSeparation := self xSeparation. - - widthToAllocate := (boundsForLayout width - ((visibleSubmorphs size + 1) * theSeparation)). - widthsArray := self widthsFor: visibleSubmorphs within: widthToAllocate. - sumOfWidths := widthsArray sum: [ :w | w ] . - leftOver := widthToAllocate - sumOfWidths. - nextX := boundsForLayout origin x - + theSeparation - + (leftOver * self axisEdgeWeight). "first X, edge shifted" -"Transcript log: 'first X=', nextX asString, ' leftOver=', leftOver asString; cr. -" 1 to: visibleSubmorphs size do: [ :index | | sm smX smWidth heightAndY newExtent | - sm := visibleSubmorphs at: index. - smX := nextX. - smWidth := widthsArray at: index. - nextX := smX + smWidth + theSeparation. - heightAndY := self offHorizontalMetricFor: sm withinExtent: boundsForLayout. - sm morphPosition: smX @ (heightAndY y). - newExtent := smWidth @ (heightAndY x). - (sm morphExtent = newExtent) ifFalse: [ sm morphExtent: newExtent ]. - ] -! ! -!LayoutMorph methodsFor: 'layout' stamp: 'KenD 5/12/2020 14:09:59' prior: 50513408! - layoutSubmorphsVerticallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - - | visibleSubmorphs sumOfHeights theSeparation heightsArray - heightToAllocate leftOver nextY | - "Preconditions: self isRow & morphExtent >= minimumLayoutExtent" - visibleSubmorphs := self submorphsToLayout reversed. "Display Order" - - theSeparation := self ySeparation. - heightToAllocate := (boundsForLayout height - ((visibleSubmorphs size + 1) * theSeparation)). - heightsArray := self heightsFor: visibleSubmorphs within: heightToAllocate. - sumOfHeights := heightsArray sum: [ :w | w ] . - leftOver := heightToAllocate - sumOfHeights. - nextY := boundsForLayout origin y - + theSeparation - + (leftOver * self axisEdgeWeight). "first Y, edge shifted" -"Transcript log: 'first Y=', nextY asString, ' leftOver=', leftOver asString; cr. -" 1 to: visibleSubmorphs size do: [ :index | | sm smY smHeight xAndWidth newExtent | - sm := visibleSubmorphs at: index. - smY := nextY. - smHeight := heightsArray at: index. - nextY := smY + smHeight + theSeparation. - xAndWidth := self offVerticalMetricFor: sm withinExtent: boundsForLayout. - sm morphPosition: (xAndWidth x) @ smY. - newExtent := (xAndWidth y) @ smHeight. - (sm morphExtent = newExtent) ifFalse: [ sm morphExtent: newExtent ]. - ] -! ! -!LayoutMorph methodsFor: 'layout' stamp: 'KenD 5/9/2020 14:24:33' prior: 50500266! - refreshExtent - "Invariant: my morphExtent >= my minimumExtent" - - self morphExtent: (self morphExtent max: self minimumExtent)! ! -!LayoutMorph methodsFor: 'submorphs-add/remove' stamp: 'KenD 5/26/2020 15:15:01' prior: 16863540 overrides: 16876794! - addMorph: aMorph - "Add a submorph, at the bottom or right, with a default LayoutSpec if none was provided." - - aMorph layoutSpec. - super addMorphFront: aMorph! ! -!LayoutMorph methodsFor: 'submorphs-add/remove' stamp: 'KenD 5/26/2020 15:15:38' prior: 16863548! - addMorph: aMorph layoutSpec: aLayoutSpec - - "Add a submorph, at the bottom or right, with aLayoutSpec" - aMorph layoutSpec: aLayoutSpec. - super addMorphFront: aMorph! ! -!LayoutMorph methodsFor: 'deprecated' stamp: 'KenD 5/28/2020 07:27:28' prior: 16863013! - padding: aSymbolOrNumber - "This sets how extra space is used when doing layout. For example, a column might have extra , unneded vertical space. #top means widgets are set close to the top, and extra space is at bottom. Conversely, #bottom means widgets are set close to the bottom, and extra space is at top. Valid values include #left and #right (for rows) and #center. Alternatively, any number between 0.0 and 1.0 might be used. - self new padding: #center - self new padding: 0.9 - " - self flag: #deprecated. - padding _ aSymbolOrNumber - caseOf: { - [ #top ] -> [ 0.0 ]. - [ #left ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #right ] -> [ 1.0 ]. - [ #bottom ] -> [ 1.0 ] - } - otherwise: [ aSymbolOrNumber ]! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'KenD 5/22/2020 13:57:31' prior: 50360123! - example13 - " - self example13 - " - | pane row innerRow | -pane _ (LayoutMorph newColumn separation: 5) name: #example13. - pane color: Color red. - row _ (LayoutMorph newRow separation: 5) name: #Row. - innerRow _ (LayoutMorph newRow separation: 5) name: #InnerRow; - color: Color red. - innerRow - addMorph: (BorderedRectMorph new name: #Box1) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (BorderedRectMorph new name: #Box2) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (BorderedRectMorph new name: #Bar) - layoutSpec: (LayoutSpec proportionalWidth: 1.0 fixedHeight: 10). - row - color: (Color h: 270 s: 0.2 v: 0.6); - addMorph: innerRow - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 30 offAxisEdgeWeight: #center); - addMorph: LayoutAdjustingMorph new layoutSpec: (LayoutSpec fixedWidth: 5); - addMorph: (BorderedRectMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #Rect1) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40 offAxisEdgeWeight: #leftOrTop); - addMorph: LayoutAdjustingMorph new layoutSpec: (LayoutSpec fixedWidth: 5); - addMorph: (BorderedRectMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #Rect2) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). - pane addMorph: row layoutSpec: (LayoutSpec proportionalHeight: 0.9). - pane morphPosition: 250@130 extent: 400@300. - pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'KenD 5/22/2020 13:55:23' prior: 50360232! - example2 - " - self example2 - " - | pane row | - pane _ (LayoutMorph newColumn separation: 5) name: #example2. - pane color: Color red. - row _ (LayoutMorph newRow separation: 5) name: #Row. - row - color: (Color h: 270 s: 0.2 v: 0.6); - addMorph: (BorderedRectMorph new color: (Color h: 120 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8 offAxisEdgeWeight: #rightOrBottom); - addMorph: (BorderedRectMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8 fixedHeight: 40 offAxisEdgeWeight: #leftOrTop); - addMorph: (BorderedRectMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 0.7 offAxisEdgeWeight: #center). - pane addMorph: row layoutSpec: (LayoutSpec proportionalHeight: 0.9). - pane morphPosition: 200@180 extent: 400@300. - pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'KenD 5/22/2020 13:58:02' prior: 50360287! - example3 - " - self example3 - " - | pane row innerRow | -pane _ (LayoutMorph newColumn separation: 5) name: #example3. - pane color: Color red. - row _ (LayoutMorph newRow separation: 5) name: #Row. - innerRow _ (LayoutMorph newRow separation: 5) name: #InnerRow; - color: Color red. - innerRow - addMorph: (BorderedRectMorph new name: #Box1) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (BorderedRectMorph new name: #Box2) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (BorderedRectMorph new name: #Bar) - layoutSpec: (LayoutSpec proportionalWidth: 1.0 fixedHeight: 10). - row - color: (Color h: 270 s: 0.2 v: 0.6); - addMorph: innerRow - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 30 offAxisEdgeWeight: #center); - addMorph: (BorderedRectMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #Rect1) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40 offAxisEdgeWeight: #leftOrTop); - addMorph: (BorderedRectMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #Rect2) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). - pane addMorph: row layoutSpec: (LayoutSpec proportionalHeight: 0.9). - pane morphPosition: 250@130 extent: 400@300. - pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'KenD 5/22/2020 13:51:32' prior: 50360330! - example6 - " - Useful example contributed by Ken Dickey - All these should look the same, right? (mmmh this should be a test...) - self example6 - " -| pane rect1 rect2 | -pane _ LayoutMorph newRow separation: 5. "1" -pane addMorph: (StringMorph contents: '1'). - -rect1 := BorderedRectMorph new color: (Color lightOrange); - morphExtent: 20 @ 30. -pane addMorphFront: rect1. -rect2 := BorderedRectMorph new color: (Color cyan); - morphExtent: 20 @ 30. -pane addMorphFront: rect2. -pane - color: Color lightGreen; - morphPosition: 120 @ 50 extent: 180 @ 100; - openInWorld. - -pane _ LayoutMorph newRow separation: 5. "2" -pane addMorph: (StringMorph contents: '2'). - -rect1 := BorderedRectMorph new color: (Color lightOrange); - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 offAxisEdgeWeight: #center). -pane addMorph: rect1. -rect2 := BorderedRectMorph new color: (Color cyan). -pane addMorph: rect2 - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 offAxisEdgeWeight: #center). -pane - color: Color lightGreen; - morphPosition: 320 @ 50 extent: 180 @ 100; - openInWorld. - - -pane _ LayoutMorph newRow separation: 5. "3" -pane addMorph: (StringMorph contents: '3'). - -rect1 := BorderedRectMorph new color: (Color lightOrange). -pane addMorph: rect1 - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 offAxisEdgeWeight: #center). -rect2 := BorderedRectMorph new color: (Color cyan); - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 offAxisEdgeWeight: #center). -pane addMorph: rect2. -pane - color: Color lightGreen; - morphPosition: 520 @ 50 extent: 180 @ 100; - openInWorld! ! -!TaskbarMorph methodsFor: 'initialization' stamp: 'KenD 5/22/2020 14:00:30' prior: 50472816 overrides: 16863310! - initialize - super initialize. - viewBox _ LayoutMorph newRow color: self defaultColor. - self - addMorph: UpdatingStringMorph initializedInstance - layoutSpec: (LayoutSpec morphWidthProportionalHeight: 0.5). - self - addMorph: viewBox - layoutSpec: (LayoutSpec - proportionalWidth: 1.0 - proportionalHeight: 1.0 - offAxisEdgeWeight: #rightOrBottom). - viewBox separation: self defaultHeight // 8 -! ! -!LayoutSpec methodsFor: 'accessing' stamp: 'KenD 5/5/2020 08:16:57' prior: 16864181! - fixedOrMorphHeight: aNumber - "aNumber is taken as the fixed height to use. - No proportional part." - fixedHeight - ifNotNil: [ fixedHeight _ aNumber ] - ifNil: [ fixedHeight _ aNumber. - morph morphHeight: aNumber - ]. - proportionalHeight _ nil! ! -!LayoutSpec methodsFor: 'accessing' stamp: 'KenD 5/5/2020 08:17:15' prior: 16864190! - fixedOrMorphWidth: aNumber - "aNumber is taken as the fixed width to use. - No proportional part." - fixedWidth - ifNotNil: [ fixedWidth _ aNumber ] - ifNil: [ fixedWidth _ aNumber. morph morphWidth: aNumber ]. - proportionalWidth _ nil! ! -!LayoutSpec methodsFor: 'layout' stamp: 'KenD 5/5/2020 17:24:59' prior: 50511965! - proportionalLayoutHeight - - ^ proportionalHeight ifNil: [ 0 ]! ! -!LayoutSpec methodsFor: 'deprecated' stamp: 'KenD 5/28/2020 07:28:09' prior: 16864206! - minorDirectionPadding - self flag: #deprecated. - ^minorDirectionPadding! ! -!LayoutSpec methodsFor: 'deprecated' stamp: 'KenD 5/28/2020 07:27:51' prior: 16864210! - minorDirectionPadding: aSymbolOrNumber - "This sets how padding is done in the secondary direction. For instance, if the owning morph is set in a row, the row will control horizontal layout. But if there is unused vertical space, it will be used according to this parameter. For instance, #top sets the owning morph at the top. Same for #bottom and #center. If the owner is contained in a column, #left, #center or #right should be used. Alternatively, any number between 0.0 and 1.0 can be used. - self new minorDirectionPadding: #center - self new minorDirectionPadding: 0.9 - " - self flag: #deprecated. - minorDirectionPadding _ aSymbolOrNumber - caseOf: { - [ #top ] -> [ 0.0 ]. - [ #left ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #right ] -> [ 1.0 ]. - [ #bottom ] -> [ 1.0 ] - } - otherwise: [ aSymbolOrNumber ]! ! -!LayoutSpec methodsFor: '*morphic-misc1' stamp: 'KenD 12/24/2013 15:14' prior: 50508146! - privateFixedHeight - - ^ fixedHeight! ! -!LayoutSpec methodsFor: '*morphic-misc1' stamp: 'KenD 12/24/2013 15:15' prior: 50508150! - privateProportionalHeight - - ^ proportionalHeight! ! -!LayoutSpec class methodsFor: 'deprecated' stamp: 'KenD 5/28/2020 07:29:16' prior: 16864440! - fixedWidth: aNumber fixedHeight: otherNumber minorDirectionPadding: aSymbolOrNumber - self flag: #deprecated. - ^ LayoutSpec new - fixedWidth: aNumber; - fixedHeight: otherNumber; - minorDirectionPadding: aSymbolOrNumber! ! -!LayoutSpec class methodsFor: 'deprecated' stamp: 'KenD 5/28/2020 07:29:23' prior: 16864456! - fixedWidth: aNumber proportionalHeight: otherNumber minorDirectionPadding: aSymbolOrNumber - self flag: #deprecated. - ^self new - fixedWidth: aNumber; - proportionalHeight: otherNumber; - minorDirectionPadding: aSymbolOrNumber! ! -!LayoutSpec class methodsFor: 'deprecated' stamp: 'KenD 5/28/2020 07:29:29' prior: 16864513! - proportionalWidth: aNumber fixedHeight: otherNumber minorDirectionPadding: aSymbolOrNumber - self flag: #deprecated. - ^self new - proportionalWidth: aNumber; - fixedHeight: otherNumber; - minorDirectionPadding: aSymbolOrNumber! ! -!LayoutSpec class methodsFor: 'deprecated' stamp: 'KenD 5/28/2020 07:30:00' prior: 16864529! - proportionalWidth: aNumber proportionalHeight: otherNumber minorDirectionPadding: aSymbolOrNumber - self flag: #deprecated. - ^self new - proportionalWidth: aNumber; - proportionalHeight: otherNumber; - minorDirectionPadding: aSymbolOrNumber! ! -!Theme methodsFor: 'other options' stamp: 'KenD 5/31/2020 08:09:44' prior: 16935688! - layoutAdjusterThickness - - self flag: #todo. "Revisit this; consider moving proportional stuff out of Theme entirely." - - ^ Preferences standardListFont pointSize // 2! ! - -LayoutMorph removeSelector: #proportionalHeightNormalizationFactor! - -!methodRemoval: LayoutMorph #proportionalHeightNormalizationFactor stamp: 'Install-4196-BetterLayoutAlgorithms-KenDickey-2020May29-07h19m-KenD.005.cs.st 6/25/2020 16:07:30'! -proportionalHeightNormalizationFactor - - | sumOfProportional | - sumOfProportional _ self submorphsToLayout sum: [ :m | m layoutSpec proportionaLayoutlHeight ]. - ^1.0 / (sumOfProportional max: 1.0).! - -LayoutMorph removeSelector: #addAllMorphs:! - -LayoutMorph removeSelector: #addAllMorphs:after:! - -LayoutMorph removeSelector: #proportionalWidthNormalizationFactor! - -!methodRemoval: LayoutMorph #proportionalWidthNormalizationFactor stamp: 'Install-4196-BetterLayoutAlgorithms-KenDickey-2020May29-07h19m-KenD.005.cs.st 6/25/2020 16:07:30'! -proportionalWidthNormalizationFactor - - | sumOfProportional | - sumOfProportional _ self submorphsToLayout sum: [ :m | m layoutSpec proportionalLayoutWidth ]. - ^1.0 / (sumOfProportional max: 1.0).! - -Morph removeSelector: #requiredWidthOrSpec! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4196-BetterLayoutAlgorithms-KenDickey-2020May29-07h19m-KenD.005.cs.st----! - -'From Cuis 5.0 [latest update: #4171] on 25 May 2020 at 12:59:52 am'! - -"Change Set: 4192-CuisCore-NahuelGarbezza-2020May27-18h58m -Date: 27 May 2020 -Author: Nahuel Garbezza - -* Fix confusing error message in extract temporary refactoring -* Redefine #asSourceCodeInterval in SourceCodeInterval for performance reasons"! -!SourceCodeInterval methodsFor: 'converting' stamp: 'RNG 5/28/2020 00:00:00' overrides: 50512247! - asSourceCodeInterval - - ^ self! ! -!NewTemporaryPrecondition class methodsFor: 'error messages' stamp: 'RNG 5/28/2020 00:28:53' prior: 50517302! - errorMessageFor: aNewVariable canNotBeNamedDueToInstanceVariableDefinedIn: aClass - - ^ aNewVariable, ' cannot be used as a temporary variable name because it is defined as an instance variable in ', aClass name! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4197-BetterErrorMessage-NahuelGarbezza-2020May27-18h58m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4197] on 1 June 2020 at 8:50:00 pm'! -!LayoutMorph methodsFor: 'adjust' stamp: 'KenD 6/1/2020 20:48:47' prior: 50519959! - adjustHorizontallyBy: aLayoutAdjustMorph at: aPoint - | delta l ls r rs lNewWidth rNewWidth i lCurrentWidth rCurrentWidth | - i _ submorphs indexOf: aLayoutAdjustMorph. - ((i = 1) or: [i = self submorphs size]) ifTrue: [ - self inform: 'LayoutAdjustingMorphs require morphs before and after'. - ^self - ]. - l _ self submorphs at: i +1. - ls _ l layoutSpec. - lCurrentWidth _ l morphWidth max: 1. "avoid division by zero" - r _ self submorphs at: i - 1. - rs _ r layoutSpec. - rCurrentWidth _ r morphWidth max: 1. "avoid division by zero" - delta _ aPoint x - aLayoutAdjustMorph referencePosition x. - delta _ delta max: l minimumShrinkWidth - lCurrentWidth. - delta _ delta min: rCurrentWidth - r minimumShrinkWidth. - delta = 0 ifTrue: [ ^self ]. - rNewWidth _ rCurrentWidth - delta. - lNewWidth _ lCurrentWidth + delta. - (ls isProportionalWidth and: [ rs isProportionalWidth ]) - ifTrue: [ | leftNewProportion rightNewProportion toDistribute | "If both proportional, update them" - leftNewProportion _ lNewWidth / (lNewWidth + rNewWidth). - rightNewProportion _ 1.0 - leftNewProportion. - toDistribute _ ls proportionalLayoutWidth + rs proportionalLayoutWidth. - ls setProportionalWidth: leftNewProportion * toDistribute. - rs setProportionalWidth: rightNewProportion * toDistribute ] - ifFalse: ["If at least one is fixed, update only the fixed" - ls isProportionalWidth ifFalse: [ - ls fixedOrMorphWidth: lNewWidth ]. - rs isProportionalWidth ifFalse: [ - rs fixedOrMorphWidth: rNewWidth ]]. - self layoutSubmorphs.! ! -!LayoutMorph methodsFor: 'adjust' stamp: 'KenD 6/1/2020 20:49:20' prior: 50520005! - adjustVerticallyBy: aLayoutAdjustMorph at: aPoint - | delta t ts b bs tNewHeight bNewHeight i tCurrentHeight bCurrentHeight | - i _ submorphs indexOf: aLayoutAdjustMorph. - ((i = 1) or: [i = self submorphs size]) ifTrue: [ - self inform: 'LayoutAdjustingMorphs require morphs above and below'. - ^self - ]. t _ self submorphs at: i +1. - ts _ t layoutSpec. - tCurrentHeight _ t morphHeight max: 1. "avoid division by zero" - b _ self submorphs at: i - 1. - bs _ b layoutSpec. - bCurrentHeight _ b morphHeight max: 1. "avoid division by zero" - delta _ aPoint y - aLayoutAdjustMorph referencePosition y. - delta _ delta max: t minimumShrinkHeight - tCurrentHeight. - delta _ delta min: bCurrentHeight - b minimumShrinkHeight. - delta = 0 ifTrue: [ ^self ]. - tNewHeight _ tCurrentHeight + delta. - bNewHeight _ bCurrentHeight - delta. - (ts isProportionalHeight and: [ bs isProportionalHeight ]) - ifTrue: [ | bottomNewProportion toDistribute topNewProportion | "If both proportional, update them" - topNewProportion _ tNewHeight / (tNewHeight + bNewHeight). - bottomNewProportion _ 1.0 - topNewProportion. - toDistribute _ ts proportionalLayoutHeight + bs proportionalLayoutHeight. - ts setProportionalHeight: topNewProportion * toDistribute. - bs setProportionalHeight: bottomNewProportion * toDistribute ] - ifFalse: ["If at least one is fixed, update only the fixed" - ts isProportionalHeight ifFalse: [ - ts fixedOrMorphHeight: tNewHeight ]. - bs isProportionalHeight ifFalse: [ - bs fixedOrMorphHeight: bNewHeight ]]. - self layoutSubmorphs! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4198-GuardedAdjuster-KenDickey-2020Jun01-20h40m-KenD.001.cs.st----! - -'From Cuis 5.0 [latest update: #4195] on 1 June 2020 at 9:26:30 am'! -!Form methodsFor: 'other' stamp: 'jmv 5/31/2020 19:00:18'! - divideByAlpha - "Divide each pixel by its alpha. Needed after using rule 24 (alphaBlend) on translucent forms." - - | v a r g b | - depth = 32 ifFalse: [^self]. - 1 to: bits size do: [ :i | - v := bits at: i. - a := v bitShift: -24. - a = 0 ifFalse: [ - r := ((v bitShift: -16) bitAnd: 255) * 255 // a. - g := ((v bitShift: -8) bitAnd: 255) * 255 // a. - b := (v bitAnd: 255) * 255 // a. - bits at: i put: (a bitShift: 24) + (r bitShift: 16) + (g bitShift: 8) + b]].! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 5/31/2020 19:01:47' prior: 16874318! - imageForm: depth - | canvas | - canvas _ BitBltCanvas depth: depth over: (self morphPosition extent: self morphExtent). - canvas fullDraw: self. - ^ canvas form divideByAlpha! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 5/31/2020 19:01:52' prior: 50500293! - imageForm: extent depth: depth - | canvas | - canvas _ BitBltCanvas depth: depth over: (self morphPosition extent: (self morphExtent min: extent)). - canvas fullDraw: self. - ^ canvas form divideByAlpha! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4199-translucent-imageForm-fix-JuanVuletich-2020Jun01-09h25m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4199] on 3 June 2020 at 10:10:23 am'! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/3/2020 10:09:36'! - fromRgbOrRgba: list - ^ list size caseOf: { - [0] -> [ `Color transparent` ]. - [3] -> [ Color r: list first g: list second b: list third ]. - [4] -> [ TranslucentColor r: list first g: list second b: list third alpha: list fourth ] - }! ! -!ColorForm methodsFor: 'fileIn/Out' stamp: 'jmv 6/3/2020 10:06:41'! - colorsFromArray: anArrayOfTriplesOrQuartets - "Set my color palette to the given collection." - - | colorCount newColors | - anArrayOfTriplesOrQuartets ifNil: [ - colors _ cachedDepth _ cachedColormap _ nil. - ^ self]. - - colorCount _ anArrayOfTriplesOrQuartets size. - newColors _ ColorArray new: (1 bitShift: self depth). - 1 to: newColors size do: [:i | - i <= colorCount - ifTrue: [newColors at: i put: (Color fromRgbOrRgba: (anArrayOfTriplesOrQuartets at: i))] - ifFalse: [newColors at: i put: `Color transparent` ]]. - - colors _ newColors. - cachedDepth _ nil. - cachedColormap _ nil. -! ! -!ColorForm methodsFor: 'accessing' stamp: 'jmv 6/3/2020 09:57:14' prior: 50387356! - colors: colorList - "Set my color palette to the given collection." - - | colorArray colorCount newColors | - colorList ifNil: [ - colors _ cachedDepth _ cachedColormap _ nil. - ^ self]. - - colorArray _ colorList asArray. - colorCount _ colorArray size. - newColors _ ColorArray new: (1 bitShift: self depth). - 1 to: newColors size do: [:i | - i <= colorCount - ifTrue: [newColors at: i put: (colorArray at: i)] - ifFalse: [newColors at: i put: `Color transparent` ]]. - - colors _ newColors. - cachedDepth _ nil. - cachedColormap _ nil. -! ! -!ColorForm methodsFor: 'private' stamp: 'jmv 6/3/2020 09:57:24' prior: 16818950! - setColors: colorArray cachedColormap: aBitmap depth: anInteger - "Semi-private. Set the color array, cached colormap, and cached colormap depth to avoid having to recompute the colormap when switching color palettes in animations." - - colors _ colorArray asColorArray. - cachedDepth _ anInteger. - cachedColormap _ aBitmap. -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4200-ColorForm-fix-JuanVuletich-2020Jun03-09h53m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4200] on 3 June 2020 at 10:31:53 am'! -!ImageMorph class methodsFor: 'cached state access' stamp: 'jmv 6/3/2020 10:31:25' prior: 16854167! - defaultForm - " - On an Inspector on the Form, do - self writeBMPfileNamed: 'DefaultForm.bmp' - self writeJPEGfileNamed: 'DefaultForm.jpg' - (Base64MimeConverter mimeEncode: ( 'DefaultForm.jpg' asFileEntry binaryContents readStream)) upToEnd edit - Select all, copy, paste in the String literal in this method. - ImageMorph defaultForm display - " - - DefaultForm ifNotNil: [ ^DefaultForm ]. - DefaultForm _ Form fromBinaryStream: - '/9j/4AAQSkZJRgABAQAAAQABAAD/2wBDAAgGBgcGBQgHBwcJCQgKDBQNDAsLDBkSEw8UHRof -Hh0aHBwgJC4nICIsIxwcKDcpLDAxNDQ0Hyc5PTgyPC4zNDL/2wBDAQkJCQwLDBgNDRgyIRwh -MjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjL/wAAR -CAA5AFUDASIAAhEBAxEB/8QAHwAAAQUBAQEBAQEAAAAAAAAAAAECAwQFBgcICQoL/8QAtRAA -AgEDAwIEAwUFBAQAAAF9AQIDAAQRBRIhMUEGE1FhByJxFDKBkaEII0KxwRVS0fAkM2JyggkK -FhcYGRolJicoKSo0NTY3ODk6Q0RFRkdISUpTVFVWV1hZWmNkZWZnaGlqc3R1dnd4eXqDhIWG -h4iJipKTlJWWl5iZmqKjpKWmp6ipqrKztLW2t7i5usLDxMXGx8jJytLT1NXW19jZ2uHi4+Tl -5ufo6erx8vP09fb3+Pn6/8QAHwEAAwEBAQEBAQEBAQAAAAAAAAECAwQFBgcICQoL/8QAtREA -AgECBAQDBAcFBAQAAQJ3AAECAxEEBSExBhJBUQdhcRMiMoEIFEKRobHBCSMzUvAVYnLRChYk -NOEl8RcYGRomJygpKjU2Nzg5OkNERUZHSElKU1RVVldYWVpjZGVmZ2hpanN0dXZ3eHl6goOE -hYaHiImKkpOUlZaXmJmaoqOkpaanqKmqsrO0tba3uLm6wsPExcbHyMnK0tPU1dbX2Nna4uPk -5ebn6Onq8vP09fb3+Pn6/9oADAMBAAIRAxEAPwD3+iisbxP4ks/C+jvfXWHkJ2W9uGw08nZR -/MnsAT2oA5nxP8UbXwx4oOlXGntJbQxpJc3AnCugfONsePmHT+IHrgHu1fjL4UN2sBOoKu8I -8rWrBUyCQT39OACeRxjJHjHinxJHe64us67KjX0iCOMRR4WNAScADnALHlsnnrgYFe80qC5s -540jUSur7HPJVmOc5+tAH1PYX9pqljDfWNxHcWsy7o5Y2yrD/PFTySJFG0kjqiICzMxwAB1J -NfMfhrXNf0SF5bDWLq1WchzEu1ozwMkI4YKWIJJAB55NP1C9vtXZm1XULq/LNvK3MpaMN6rH -9xT/ALqigD3Sb4ieEYJmifX7QspwdhLD8CAQauaX4w8Oa1P5Gna1ZT3H/PETASHpyEOCRyOc -Yr55AAGAMCmyRpKu10DDryKAPqOivA/D/j/XvDgSIP8A2nYr/wAu11IQ6jGAEk5I7cEEcY4z -ket+GvGmj+KXnisZJY7mEBnt7hNj7f7w5IYZ4yCefqMgHQ0UUUAFfNviK/vr/wAWaodVdjfQ -zvEUIOIow3yIvGNuCD75z3r6SrjfF/w503xXcC8W4m06/wABZLi3APmqOgdTwSOx644zjigD -wyW3gnZGmhjkKHKF1B2n1GelSV0XjD4fa34VsItQt72PUbVFP2t/s/liHnhiN5IXHBbJx1Ix -05Lzb2QYS3ij/wBt5Nwx7ADn9KAJ5ZkhVS+fmZUAHUknFSVXhtdriWaQzSjozAAL/ujt/P3q -xQAUUUUAFTWmoXOkX9vqdmC1zaOJUUHG/HVeo4YZH41DRQB9NWV5b6jYW99aSCW2uYlmikAI -DIwyDz6giiub+Gs3nfD3SP8AWYiR4Bv64jkZBj2wvHtiigDq6KKKAEZVdSrAFSMEEcEV8za7 -p58O6/qWkRxNLFZXBjTY2SsTKskY55JCOoPfIPWvpiSRIo2kkdURAWZmOAAOpJrwNLT/AITn -4n30cMhW3vLqSSSeEZAt4QsQdW5HzhEIJ4+fPtQBzMU0cy7o3DD9R9R2p9dV8Thoenavp9to -8US/YrFxciAbgQSvlKTzlwFfrz8wJzkV3WifC/w7aaRE2sWCXl+yB7medj8pxkqMHAVeQB+J -JJJIB43UYuIWnaASp5q8lM/Nj1x6V6RqNx8IJHuIlwjsxzcada3LKDnPyPGpQj6ZHavMtZm0 -eXU7i10aO/1KziAKPdRKjh+cjdwOOMHCn2JGaALNM0qz1DVtWGj6apubmYZikYfLHyQTIQOF -X169RycZghvLZtL8pbC4i1G2QCa5F/5sHqTIpT5SFzwGHIHOM16J8MtF1+28Sw6lb2clrpNz -ETdyyIqi4XafL2g/NncwO4DBAOSeKAPWtH0yDRdGstMts+TaQrCpPVtoxk+56n3NFXaKACii -igDmvGPgy18a2dtZ3t/eW1tC5kZLYqPMOMDO5WHHUcflVTRPhtoWg2d7DbyX00t5ataS3U9w -TL5ZGCFIACnvkDORXYUUAef6b8HfDGmzxyK+ozrHL5qxzXPycNuC4AGQD/LnNd9JGksbRyIr -o4KsrDIIPUEU6igDn/8AhBfCO3b/AMItopXOQDYREA8dBt46CiTwL4SleNn8M6QfLBCr9jj2 -9AOVxg8DjPTtXQUUAZ+maFo+ieb/AGTpVjYedjzPslukW/GcZ2gZxk9fU1oUUUAFFFFAH//Z' - base64Decoded asByteArray readStream. - ^DefaultForm! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4201-defaultForm-fixComment-JuanVuletich-2020Jun03-10h23m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4200] on 3 June 2020 at 1:39:17 pm'! -!CodeWindow methodsFor: 'keyboard shortcuts' stamp: 'len 5/31/2020 06:15:22' prior: 50436760! - messageCatListKey: aChar from: view - - aChar == $o ifTrue: [^ model fileOutMessageCategories ]. - aChar == $t ifTrue: [^ model runMessageCategoryTests ]. - aChar == $x ifTrue: [^ model removeMessageCategory ]. - aChar == $R ifTrue: [ ^model renameCategory ]. - aChar == $n ifTrue: [^model addCategory ]. - aChar == $e ifTrue: [^model removeEmptyCategories ]. - aChar == $c ifTrue: [^model categorizeAllUncategorizedMethods ]. - aChar == $a ifTrue: [ ^ model alphabetizeMessageCategories ]. - aChar == $r ifTrue: [ ^ model editMessageCategories ]! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'len 5/31/2020 06:14:40' prior: 50436777! - messageCategoryMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'fileOut (o)'. - #object -> #model. - #selector -> #fileOutMessageCategories. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'reorganize (r)'. - #object -> #model. - #selector -> #editMessageCategories. - #icon -> #sendReceiveIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'alphabetize (a)'. - #object -> #model. - #selector -> #alphabetizeMessageCategories. - #icon -> #fontXGenericIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'remove empty categories (e)'. - #object -> #model. - #selector -> #removeEmptyCategories. - #icon -> #listRemoveIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 40. - #label -> 'categorize all uncategorized (c)'. - #object -> #model. - #selector -> #categorizeAllUncategorizedMethods. - #icon -> #packageIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 50. - #label -> 'new category... (n)'. - #object -> #model. - #selector -> #addCategory. - #icon -> #newIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'rename... (R)'. - #object -> #model. - #selector -> #renameCategory. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'remove (x)'. - #object -> #model. - #selector -> #removeMessageCategory. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'run tests (t)'. - #object -> #model. - #selector -> #runMessageCategoryTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - }`. - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4202-MessageCategoriesShortcuts-LucianoEstebanNotarfrancesco-2020Jun03-13h37m-len.001.cs.st----! - -'From Cuis 5.0 [latest update: #4200] on 3 June 2020 at 1:37:27 pm'! -!HaloMorph methodsFor: 'private' stamp: 'len 6/3/2020 13:07:09' prior: 50388429! - addNameString: aString - "Add a name display centered beneath the bottom of the outer rectangle. Return the handle." - - | nameMorph verticalNamePosition namePosition nameBackground | - nameBackground _ RectangleLikeMorph new - color: ((target is: #SystemWindow) ifTrue: [target windowColor] ifFalse: [`Color lightBlue alpha: 0.9`]). - nameMorph _ StringMorph contents: aString. - nameMorph color: `Color black`. - nameBackground morphExtent: nameMorph morphExtent + 4. - verticalNamePosition _ haloBox bottom + self class handleSize. - self world ifNotNil: [:w| verticalNamePosition + nameMorph morphHeight > w morphHeight ifTrue: [verticalNamePosition _ haloBox bottom - nameMorph morphHeight - self class handleSize]]. - namePosition _ haloBox width - nameMorph morphWidth // 2 + haloBox left @ verticalNamePosition. - self addMorph: nameBackground. - nameBackground morphPositionInWorld: namePosition - 2. - self addMorph: nameMorph. - nameMorph morphPositionInWorld: namePosition. - ^nameMorph! ! -!HaloMorph methodsFor: 'stepping' stamp: 'len 6/3/2020 13:09:52' prior: 50332875 overrides: 16876533! - step - self comeToFront. - (target isNil or: [target isInWorld not]) ifTrue: [self delete]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4203-HaloFixes-LucianoEstebanNotarfrancesco-2020Jun03-13h36m-len.001.cs.st----! - -'From Cuis 5.0 [latest update: #4203] on 3 June 2020 at 2:26:53 pm'! -!Point methodsFor: 'testing' stamp: 'jmv 6/3/2020 11:55:20'! - isIntegerPoint - ^x isInteger and:[y isInteger]! ! -!Rectangle methodsFor: 'truncation and round off' stamp: 'jmv 6/3/2020 11:56:00'! - encompassingIntegerRectangle - "Answer a Rectangle whose origin and corner are integer, and that completely includes the receiver." - - (origin isIntegerPoint and: [ corner isIntegerPoint ]) ifTrue: [ ^self ]. - ^Rectangle origin: origin floor corner: self corner ceiling! ! -!Rectangle class methodsFor: 'instance creation' stamp: 'jmv 6/3/2020 14:23:25'! -encompassingInteger: listOfPoints - "Like #encompassing:, but with integer coordinates." - | topLeft bottomRight | - topLeft _ bottomRight _ nil. - listOfPoints do: [ :p | - topLeft - ifNil: [ - topLeft _ p floor. - bottomRight _ p ceiling] - ifNotNil: [ - topLeft _ topLeft min: p floor. - bottomRight _ bottomRight max: p ceiling]]. - ^ topLeft corner: bottomRight! ! -!AffineTransformation methodsFor: 'transforming rects' stamp: 'jmv 6/3/2020 11:45:09' prior: 50384120! - displayBoundsOfTransformOf: aRectangle - "Externalize aRectangle, and find a bounding rectangle with horizontal - and vertical bounds and integer coordinates (i.e. adisplayBounds)." - - ^Rectangle encompassingInteger: (aRectangle corners collect: [ :pt | - self transform: pt ])! ! -!MorphicTranslation methodsFor: 'transforming rects' stamp: 'jmv 6/3/2020 11:45:54' prior: 50419059! - displayBoundsOfTransformOf: aRectangle - "Externalize aRectangle, and find a bounding rectangle with horizontal - and vertical bounds and integer coordinates (i.e. adisplayBounds)." - - ^(aRectangle translatedBy: self translation) encompassingIntegerRectangle! ! -!DamageRecorder methodsFor: 'private' stamp: 'jmv 6/3/2020 11:56:09' prior: 50462510! - pvtInnerRecordInvalidRect: requestedRect - "Record the given rectangle in my damage list, a list of rectangular areas of the display that should be redraw on the next display cycle. - Rectangles are specified in world coordinates (might be not the same as Display coordinates if there is some origin set on some canvas. Usually there will be none, but we can't be sure) - " - "Details: Damaged rectangles are often identical or overlap significantly. In these cases, we merge them to reduce the number of damage rectangles that must be processed when the display is updated. Moreover, above a certain threshold, we ignore the individual rectangles completely, and simply do a complete repaint on the next cycle. - jmv: Important. There should be no overlapping rectangles in the list. If there are, translucent morphs might be drawn several times, with visible defects. - WRT performance, the different paths for various intersections seem a bit complicated. I could not find strong evidence of the best way. - Leave it as it is right now." - | newRect mergeRect indexToReuse | - totalRepaint ifTrue: [ ^ self ]. - "planning full repaint; don't bother collecting damage" - indexToReuse _ nil. - newRect _ requestedRect encompassingIntegerRectangle. - invalidRects withIndexDo: [ :oldRect :index | - oldRect - ifNil: [ indexToReuse ifNil: [ indexToReuse _ index ]] - ifNotNil: [ - "No two rectangles should intersect" - (oldRect intersects: newRect) ifTrue: [ - "newRect already in. Nothing to do then." - (oldRect containsRect: newRect) ifTrue: [ ^ self ]. - "Some oldRect included in newRect. Remove it and continue, as newRect could still intersect others." - (newRect containsRect: oldRect) ifTrue: [ - invalidRects - at: index - put: nil. - "Effectively like 'invalidRects remove: rect', but without performance penalty." - indexToReuse ifNil: [ indexToReuse _ index ]]. - "Merge rectangles if they overlap significantly, i.e. if the merge is not much larger than separated rectangles." - mergeRect _ (oldRect origin min: newRect origin) corner: (oldRect corner max: newRect corner). - mergeRect area > (newRect area + oldRect area * 2) - ifTrue: [ - "Avoid intersections!!" - newRect - areasOutside: oldRect - do: [ :nonIntersection | - "We have brand new newRects. Start all over with each of them." - self pvtInnerRecordInvalidRect: nonIntersection ]. - "newRect no longer needed, then." - ^ self ] - ifFalse: [ - "Merge into newRect, as any overlap with forecoming rectangles in the iteration is detected and treated." - newRect _ mergeRect. - invalidRects - at: index - put: nil. - "Effectively like 'invalidRects remove: rect', but without performance penalty." - indexToReuse ifNil: [ indexToReuse _ index ]]]]]. - invalidRects size >= 10 ifTrue: [ - "if there are too many separate areas, merge them all" - mergeRect _ Rectangle merging: invalidRects. - self pvtReset. - mergeRect ifNotNil: [ invalidRects addLast: mergeRect ]. - indexToReuse _ nil ]. - "Add the given rectangle to the damage list" - indexToReuse - ifNil: [ invalidRects addLast: newRect ] - ifNotNil: [ - invalidRects - at: indexToReuse - put: newRect ].! ! - -AffineTransformation removeSelector: #primDisplayBoundsOfTransformOf:into:! - -!methodRemoval: AffineTransformation #primDisplayBoundsOfTransformOf:into: stamp: 'Install-4204-DrawingArtifactsFix-JuanVuletich-2020Jun03-14h21m-jmv.001.cs.st 6/25/2020 16:07:30'! -primDisplayBoundsOfTransformOf: srcRect into: dstRect - "Externalize srcRect, and find a bounding rectangle with horizontal and vertical bounds and integer coordinates (i.e. adisplayBounds). - Store result into dstRect." - - "Warning: the answer is rounded to integers by the primitive - Warning: if answer is not strictly positive, it is off by one. Evaluate: - - AffineTransformation new primDisplayBoundsOfTransformOf: (-2@ 2 extent: 10@10) into: Rectangle new - AffineTransformation new primDisplayBoundsOfTransformOf: (-12@ 12 extent: 10@10) into: Rectangle new - (AffineTransformation withTranslation: 2) primDisplayBoundsOfTransformOf: (-4@ 2 extent: 10@10) into: Rectangle new - (AffineTransformation withTranslation: -4) primDisplayBoundsOfTransformOf: (2@ 2 extent: 10@10) into: Rectangle new - (AffineTransformation withTranslation: 2) primDisplayBoundsOfTransformOf: (-14@ 2 extent: 10@10) into: Rectangle new - (AffineTransformation withTranslation: 4) primDisplayBoundsOfTransformOf: (-12@ 2 extent: 10@10) into: Rectangle new - (AffineTransformation withTranslation: -4) primDisplayBoundsOfTransformOf: (12@ 2 extent: 10@10) into: Rectangle new - - These are Ok (answer is positive) - (AffineTransformation withTranslation: -2) primDisplayBoundsOfTransformOf: (4@ 2 extent: 10@10) into: Rectangle new - (AffineTransformation withTranslation: 4) primDisplayBoundsOfTransformOf: (-2@ 2 extent: 10@10) into: Rectangle new - " - - - ^nil! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4204-DrawingArtifactsFix-JuanVuletich-2020Jun03-14h21m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4204] on 4 June 2020 at 9:32:52 pm'! -!Form methodsFor: 'fileIn/Out' stamp: 'jmv 6/4/2020 21:30:35' prior: 16847841! - storeOn: aStream base: anInteger - "Store the receiver out as an expression that can be evaluated to recreate a Form with the same contents as the original." - - aStream nextPut: $(. - aStream nextPutAll: self species name. - aStream newLineTab: 1. - aStream nextPutAll: 'extent: '. - self extent printOn: aStream. - aStream newLineTab: 1. - aStream nextPutAll: 'depth: '. - self nativeDepth printOn: aStream. - aStream newLineTab: 1. - aStream nextPutAll: 'fromArray: #('. - self storeBitsOn:aStream base:anInteger. - aStream nextPut: $). - aStream newLineTab: 1. - aStream nextPutAll: 'offset: '. - self offset printOn: aStream. - aStream nextPut: $). -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4205-FormSerializationFix-JuanVuletich-2020Jun04-20h27m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4204] on 4 June 2020 at 2:26:09 pm'! - -RectangleLikeMorph subclass: #LayoutMorph - instanceVariableNames: 'direction separation padding doAdoptWidgetsColor axisEdgeWeight ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -!classDefinition: #LayoutMorph category: #'Morphic-Layouts' stamp: 'Install-4206-LayoutCleanup-KenDickey-2020Jun04-13h11m-KenD.003.cs.st 6/25/2020 16:07:31'! -RectangleLikeMorph subclass: #LayoutMorph - instanceVariableNames: 'direction separation padding doAdoptWidgetsColor axisEdgeWeight' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -Object subclass: #LayoutSpec - instanceVariableNames: 'morph fixedWidth fixedHeight minorDirectionPadding proportionalWidth proportionalHeight offAxisEdgeWeight ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -!classDefinition: #LayoutSpec category: #'Morphic-Layouts' stamp: 'Install-4206-LayoutCleanup-KenDickey-2020Jun04-13h11m-KenD.003.cs.st 6/25/2020 16:07:31'! -Object subclass: #LayoutSpec - instanceVariableNames: 'morph fixedWidth fixedHeight minorDirectionPadding proportionalWidth proportionalHeight offAxisEdgeWeight' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! -!LayoutMorph methodsFor: 'accessing' stamp: 'KenD 6/4/2020 13:11:42' prior: 50519302! - axisEdgeWeight - - ^ axisEdgeWeight! ! -!LayoutMorph methodsFor: 'accessing' stamp: 'KenD 6/4/2020 13:11:42' prior: 50519306! - axisEdgeWeight: aSymbolOrNumber - "Along the Major or Layout Axis, subMorphs may be attracted toward one side (0.0) or the other (1.0). This is the LayoutMorph's axisEdgeWeight. A numeric value is between 0.0 and 1.0 - - If a Row, one can specify this weight symbolically as - { #rowLeft (0.0), #center (0.5), #rowRight (1.0)} - - If a Column, one can specify the weight symbolically as: - { #columnTop (0.0), #center (0.5), #columnBottom (1.0) }" -" - self axisEdgeWeight: #rowLeft. -- axis must be horizontal - self axisEdgeWeight: #columnTop. -- axis must be vertical -" - | edgeWeight | - (aSymbolOrNumber is: #Number) - ifTrue: [ (aSymbolOrNumber between: 0.0 and: 1.0) - ifTrue: [edgeWeight := aSymbolOrNumber ] - ifFalse: [self error: 'axisEdgeWeight ', aSymbolOrNumber printString, ' is out of range 0.0 to 1.0'] - ] - ifFalse: [ - (self direction = #horizontal) - ifTrue: [ "Row" - edgeWeight := aSymbolOrNumber - caseOf: { - [ #rowLeft ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #rowRight ] -> [ 1.0 ] - } - otherwise: [ self error: 'bad axisEdgeWeight for Row: ', aSymbolOrNumber printString ]. - ] - ifFalse: [ "vertical => Column" - edgeWeight := aSymbolOrNumber - caseOf: { - [ #columnTop ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #columnBottom ] -> [ 1.0 ] - } - otherwise: [ self error: 'bad axisEdgeWeight for Column: ', aSymbolOrNumber printString ]. - ] - ]. - axisEdgeWeight := edgeWeight. - "self layoutSubmorphs"! ! -!LayoutMorph methodsFor: 'accessing' stamp: 'KenD 6/4/2020 13:13:50' prior: 50519676! - direction: horizOrVert - - direction := horizOrVert! ! -!LayoutMorph methodsFor: 'initialization' stamp: 'KenD 6/4/2020 14:22:33' prior: 16863310 overrides: 50384228! - initialize - super initialize. - separation _ 0. - axisEdgeWeight _ 0.0. - doAdoptWidgetsColor _ false! ! -!LayoutMorph methodsFor: 'layout' stamp: 'KenD 6/4/2020 14:25:55' prior: 50520129! - layoutSubmorphsHorizontallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - - | visibleSubmorphs sumOfWidths theSeparation widthsArray - widthToAllocate leftOver nextX | - "Preconditions: self isRow & morphExtent >= minimumLayoutExtent" - visibleSubmorphs := self submorphsToLayout reversed. "Display Order" - theSeparation := self xSeparation. - - widthToAllocate := (boundsForLayout width - ((visibleSubmorphs size + 1) * theSeparation)). - widthsArray := self widthsFor: visibleSubmorphs within: widthToAllocate. - sumOfWidths := widthsArray sum: [ :w | w ] . - leftOver := widthToAllocate - sumOfWidths. - nextX := boundsForLayout origin x - + theSeparation - + (leftOver * (self axisEdgeWeight ifNil: [0.0])). "first X, edge shifted" -"Transcript log: 'first X=', nextX asString, ' leftOver=', leftOver asString; cr. -" 1 to: visibleSubmorphs size do: [ :index | | sm smX smWidth heightAndY newExtent | - sm := visibleSubmorphs at: index. - smX := nextX. - smWidth := widthsArray at: index. - nextX := smX + smWidth + theSeparation. - heightAndY := self offHorizontalMetricFor: sm withinExtent: boundsForLayout. - sm morphPosition: smX @ (heightAndY y). - newExtent := smWidth @ (heightAndY x). - (sm morphExtent = newExtent) ifFalse: [ sm morphExtent: newExtent ]. - ] -! ! -!LayoutMorph methodsFor: 'layout' stamp: 'KenD 6/4/2020 14:26:19' prior: 50520172! - layoutSubmorphsVerticallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - - | visibleSubmorphs sumOfHeights theSeparation heightsArray - heightToAllocate leftOver nextY | - "Preconditions: self isRow & morphExtent >= minimumLayoutExtent" - visibleSubmorphs := self submorphsToLayout reversed. "Display Order" - - theSeparation := self ySeparation. - heightToAllocate := (boundsForLayout height - ((visibleSubmorphs size + 1) * theSeparation)). - heightsArray := self heightsFor: visibleSubmorphs within: heightToAllocate. - sumOfHeights := heightsArray sum: [ :w | w ] . - leftOver := heightToAllocate - sumOfHeights. - nextY := boundsForLayout origin y - + theSeparation - + (leftOver * (self axisEdgeWeight ifNil: [0.5])). "first Y, edge shifted" -"Transcript log: 'first Y=', nextY asString, ' leftOver=', leftOver asString; cr. -" 1 to: visibleSubmorphs size do: [ :index | | sm smY smHeight xAndWidth newExtent | - sm := visibleSubmorphs at: index. - smY := nextY. - smHeight := heightsArray at: index. - nextY := smY + smHeight + theSeparation. - xAndWidth := self offVerticalMetricFor: sm withinExtent: boundsForLayout. - sm morphPosition: (xAndWidth x) @ smY. - newExtent := (xAndWidth y) @ smHeight. - (sm morphExtent = newExtent) ifFalse: [ sm morphExtent: newExtent ]. - ] -! ! -!LayoutMorph methodsFor: 'layout' stamp: 'KenD 6/4/2020 14:21:05' prior: 50519464! - offHorizontalMetricFor: aMorph withinExtent: boundsForLayout - "Answer a point: height@y for a single morph -- offAxis calculation for a Row" - - | spec minMorphHeight theSeparation proportionalHeight - availableForPropHeight actualPropHeight - leftOver yPos | - spec := aMorph layoutSpec. - theSeparation := self ySeparation. - minMorphHeight := aMorph minimumLayoutHeight. - availableForPropHeight := (boundsForLayout height) - (2 * theSeparation).. - proportionalHeight := spec proportionalLayoutHeight min: 1.0. - actualPropHeight := (availableForPropHeight * proportionalHeight) - max: minMorphHeight. - leftOver := availableForPropHeight - actualPropHeight. - - yPos := boundsForLayout origin y - + theSeparation - + (leftOver * (spec offAxisEdgeWeight ifNil: [0.5])). "first Y, edge shifted" - - ^ actualPropHeight @ yPos - - ! ! -!LayoutMorph methodsFor: 'layout' stamp: 'KenD 6/4/2020 14:21:30' prior: 50519492! - offVerticalMetricFor: aMorph withinExtent: boundsForLayout - "Answer a point: x@width for a single morph -- offAxis calculation for a Column" - - | spec minMorphWidth theSeparation proportionalWidth - availableForPropWidth actualPropWidth - leftOver xPos | - spec := aMorph layoutSpec. - theSeparation := self xSeparation. - minMorphWidth := aMorph minimumLayoutWidth. - availableForPropWidth := (boundsForLayout width) - (2 * theSeparation). - proportionalWidth := spec proportionalLayoutWidth min: 1.0. - actualPropWidth := (availableForPropWidth * proportionalWidth) - max: minMorphWidth. - leftOver := availableForPropWidth - actualPropWidth. - - xPos := boundsForLayout origin x - + theSeparation - + (leftOver * (spec offAxisEdgeWeight ifNil: [0.5])). "first X, edge shifted" - - ^ xPos @ actualPropWidth - ! ! -!LayoutMorph methodsFor: 'deprecated' stamp: 'KenD 6/4/2020 13:14:39' prior: 50519672! - padding - - self flag: #deprecated. "use axisEdgeWeight" - ^ axisEdgeWeight! ! -!LayoutMorph methodsFor: 'deprecated' stamp: 'KenD 6/4/2020 13:14:22' prior: 50520241! - padding: aSymbolOrNumber - "This sets how extra space is used when doing layout. For example, a column might have extra , unneded vertical space. #top means widgets are set close to the top, and extra space is at bottom. Conversely, #bottom means widgets are set close to the bottom, and extra space is at top. Valid values include #left and #right (for rows) and #center. Alternatively, any number between 0.0 and 1.0 might be used. - self new padding: #center - self new padding: 0.9 - " - self flag: #deprecated. "use axisEdgeWeight:" - axisEdgeWeight _ aSymbolOrNumber - caseOf: { - [ #top ] -> [ 0.0 ]. - [ #left ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #right ] -> [ 1.0 ]. - [ #bottom ] -> [ 1.0 ] - } - otherwise: [ aSymbolOrNumber ]! ! -!LayoutSpec methodsFor: 'initialization' stamp: 'KenD 6/4/2020 13:11:57' prior: 16864165 overrides: 16896425! - initialize - "Just some reasonable defaults, use all available space" - offAxisEdgeWeight _ 0.5. - fixedWidth _ 0. - fixedHeight _ 0. - proportionalWidth _ 1.0. - proportionalHeight _ 1.0! ! -!LayoutSpec methodsFor: 'accessing' stamp: 'KenD 6/4/2020 13:14:56' prior: 50519773! - morph - "For #showHalo" - ^ morph! ! -!LayoutSpec methodsFor: 'accessing' stamp: 'KenD 6/4/2020 13:11:57' prior: 50519682! - offAxisEdgeWeight - ^offAxisEdgeWeight! ! -!LayoutSpec methodsFor: 'accessing' stamp: 'KenD 6/4/2020 13:11:57' prior: 50519686! - offAxisEdgeWeight: aSymbolOrNumber - "A LayoutSpec may indicate a weighting perpendicular to the Layout Axis. - - This is the LayoutSpec's offAxisEdgeWeight which is between 0.0 and 1.0. - - As with LayoutSpec's a symbol may be used. - - If in a Row (preferred): { #rowTop (0.0), #center (0.5), #rowBottom (1.0)} - - If in a Column (preferred): { #columnLeft (0.0), #center (0.5), #columnRight (1.0) } - - Also accepted: { #leftOrTop (0.0), #center (0.5), #rightOrBottom (1.0) } - " - | edgeWeight | - edgeWeight := (aSymbolOrNumber is: #Number) - ifTrue: [ (aSymbolOrNumber between: 0.0 and: 1.0) - ifTrue: [ aSymbolOrNumber ] - ifFalse: [self error: 'axisEdgeWeight ', aSymbolOrNumber printString, ' is out of range 0.0 to 1.0'] - ] - ifFalse: [ aSymbolOrNumber - caseOf: { - [ #leftOrTop ] -> [ 0.0 ]. - [ #rowTop ] -> [ 0.0 ]. - [ #columnLeft ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #rightOrBottom ] -> [ 1.0 ]. - [ #rowBottom ] -> [ 1.0 ]. - [ #columnRight ] -> [ 1.0 ] - } - otherwise: [ self error: 'bad offAxisEdgeWeight specifier: ', aSymbolOrNumber printString ] - ]. - offAxisEdgeWeight _ edgeWeight! ! -!LayoutSpec methodsFor: 'deprecated' stamp: 'KenD 6/4/2020 13:16:05' prior: 50520483! - minorDirectionPadding - self flag: #deprecated. "use offAxisEdgeWeight" - ^offAxisEdgeWeight! ! -!LayoutSpec methodsFor: 'deprecated' stamp: 'KenD 6/4/2020 13:15:55' prior: 50520489! - minorDirectionPadding: aSymbolOrNumber - "This sets how padding is done in the secondary direction. For instance, if the owning morph is set in a row, the row will control horizontal layout. But if there is unused vertical space, it will be used according to this parameter. For instance, #top sets the owning morph at the top. Same for #bottom and #center. If the owner is contained in a column, #left, #center or #right should be used. Alternatively, any number between 0.0 and 1.0 can be used. - self new minorDirectionPadding: #center - self new minorDirectionPadding: 0.9 - " - self flag: #deprecated. "use offAxisEdgeWeight:" - offAxisEdgeWeight _ aSymbolOrNumber - caseOf: { - [ #top ] -> [ 0.0 ]. - [ #left ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #right ] -> [ 1.0 ]. - [ #bottom ] -> [ 1.0 ] - } - otherwise: [ aSymbolOrNumber ]! ! - -RectangleLikeMorph subclass: #LayoutMorph - instanceVariableNames: 'direction separation axisEdgeWeight doAdoptWidgetsColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -!classDefinition: #LayoutMorph category: #'Morphic-Layouts' stamp: 'Install-4206-LayoutCleanup-KenDickey-2020Jun04-13h11m-KenD.003.cs.st 6/25/2020 16:07:31'! -RectangleLikeMorph subclass: #LayoutMorph - instanceVariableNames: 'direction separation axisEdgeWeight doAdoptWidgetsColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -Object subclass: #LayoutSpec - instanceVariableNames: 'morph fixedWidth fixedHeight offAxisEdgeWeight proportionalWidth proportionalHeight' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -!classDefinition: #LayoutSpec category: #'Morphic-Layouts' stamp: 'Install-4206-LayoutCleanup-KenDickey-2020Jun04-13h11m-KenD.003.cs.st 6/25/2020 16:07:31'! -Object subclass: #LayoutSpec - instanceVariableNames: 'morph fixedWidth fixedHeight offAxisEdgeWeight proportionalWidth proportionalHeight' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4206-LayoutCleanup-KenDickey-2020Jun04-13h11m-KenD.003.cs.st----! - -'From Cuis 5.0 [latest update: #4202] on 3 June 2020 at 3:28:27 pm'! -!LayoutMorph methodsFor: 'accessing' stamp: 'KenD 6/2/2020 19:15:47' prior: 50521415! - axisEdgeWeight: aSymbolOrNumber - "Along the Major or Layout Axis, subMorphs may be attracted toward one side (0.0) or the other (1.0). This is the LayoutMorph's axisEdgeWeight. A numeric value is between 0.0 and 1.0 - - If a Row, one can specify this weight symbolically as - { #rowLeft (0.0), #center (0.5), #rowRight (1.0)} - - If a Column, one can specify the weight symbolically as: - { #columnTop (0.0), #center (0.5), #columnBottom (1.0) }" -" - self axisEdgeWeight: #rowLeft. -- axis must be horizontal - self axisEdgeWeight: #columnTop. -- axis must be vertical -" - | edgeWeight | - (aSymbolOrNumber is: #Number) - ifTrue: [ (aSymbolOrNumber between: 0.0 and: 1.0) - ifTrue: [edgeWeight := aSymbolOrNumber ] - ifFalse: [self error: 'axisEdgeWeight ', aSymbolOrNumber printString, ' is out of range 0.0 to 1.0'] - ] - ifFalse: [ - (self direction = #horizontal) - ifTrue: [ "Row" - edgeWeight := aSymbolOrNumber - caseOf: { - [ #rowLeft ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #rowRight ] -> [ 1.0 ] - } - otherwise: [ self error: 'bad axisEdgeWeight for Row: ', aSymbolOrNumber printString ]. - ] - ifFalse: [ "vertical => Column" - edgeWeight := aSymbolOrNumber - caseOf: { - [ #columnTop ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #columnBottom ] -> [ 1.0 ] - } - otherwise: [ self error: 'bad axisEdgeWeight for Column: ', aSymbolOrNumber printString ]. - ] - ]. - axisEdgeWeight := edgeWeight. - self layoutSubmorphs! ! -!LayoutMorph methodsFor: 'accessing' stamp: 'KenD 6/2/2020 19:16:08' prior: 16863037! - separation: aNumberOrPoint - separation _ aNumberOrPoint. - self layoutSubmorphs! ! - -LayoutSpec removeSelector: #widthFor:! - -!methodRemoval: LayoutSpec #widthFor: stamp: 'Install-4207-LayoutUpdate-KenDickey-2020Jun02-18h41m-KenD.001.cs.st 6/25/2020 16:07:31'! -widthFor: availableSpace - "If proportional is zero, answer stored fixed extent, or actual morph extent if undefined. - Otherwise, we do proportional layout, and the stored extent is a minimum extent. - If there is no minimum extent, it should be set to zero." - - ^proportionalWidth isNil - ifTrue: [fixedWidth ifNil: [morph morphWidth]] - ifFalse: [proportionalWidth * availableSpace + morph minimumLayoutExtent x]! - -LayoutSpec removeSelector: #widthForComfortable:! - -!methodRemoval: LayoutSpec #widthForComfortable: stamp: 'Install-4207-LayoutUpdate-KenDickey-2020Jun02-18h41m-KenD.001.cs.st 6/25/2020 16:07:31'! -widthForComfortable: availableSpace - "Similar to #widthFor:. To be used when we know availableSpace is more than the minimum required to apply proportional layout and still get more than our minimum. See senders." - - ^proportionalWidth isNil - ifTrue: [fixedWidth ifNil: [morph morphWidth]] - ifFalse: [proportionalWidth * availableSpace]! - -LayoutMorph removeSelector: #desiredLayoutWidth! - -!methodRemoval: LayoutMorph #desiredLayoutWidth stamp: 'Install-4207-LayoutUpdate-KenDickey-2020Jun02-18h41m-KenD.001.cs.st 6/25/2020 16:07:31'! -desiredLayoutWidth - - | fixed proportional | - proportional _ 0. - fixed _ 0. - self submorphsToLayout do: [ :m | | ls | - ls _ m layoutSpec. - ls isProportionalWidth ifTrue: [ - proportional _ proportional max: ls fixedOrMinimumLayoutWidth / ls proportionalLayoutWidth ] - ifFalse: [ - fixed _ fixed + ls fixedOrMinimumLayoutWidth ]]. - ^fixed + proportional! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4207-LayoutUpdate-KenDickey-2020Jun02-18h41m-KenD.001.cs.st----! - -'From Cuis 5.0 [latest update: #4206] on 4 June 2020 at 6:40:09 pm'! -!LayoutMorph methodsFor: 'accessing' stamp: 'KenD 6/4/2020 18:28:12' prior: 50521789! - axisEdgeWeight: aSymbolOrNumber - "Along the Major or Layout Axis, subMorphs may be attracted toward one side (0.0) or the other (1.0). This is the LayoutMorph's axisEdgeWeight. A numeric value is between 0.0 and 1.0 - - If a Row, one can specify this weight symbolically as - { #rowLeft (0.0), #center (0.5), #rowRight (1.0)} - - If a Column, one can specify the weight symbolically as: - { #columnTop (0.0), #center (0.5), #columnBottom (1.0) }" -" - self axisEdgeWeight: #rowLeft. -- axis must be horizontal - self axisEdgeWeight: #columnTop. -- axis must be vertical -" - | edgeWeight | - (aSymbolOrNumber is: #Number) - ifTrue: [ (aSymbolOrNumber between: 0.0 and: 1.0) - ifTrue: [edgeWeight := aSymbolOrNumber ] - ifFalse: [self error: 'axisEdgeWeight ', aSymbolOrNumber printString, ' is out of range 0.0 to 1.0'] - ] - ifFalse: [ - (self direction = #horizontal) - ifTrue: [ "Row" - edgeWeight := aSymbolOrNumber - caseOf: { - [ #rowLeft ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #rowRight ] -> [ 1.0 ] - } - otherwise: [ self error: 'bad axisEdgeWeight for Row: ', aSymbolOrNumber printString ]. - ] - ifFalse: [ "vertical => Column" - edgeWeight := aSymbolOrNumber - caseOf: { - [ #columnTop ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #columnBottom ] -> [ 1.0 ] - } - otherwise: [ self error: 'bad axisEdgeWeight for Column: ', aSymbolOrNumber printString ]. - ] - ]. - axisEdgeWeight := edgeWeight. - self layoutSubmorphs! ! -!LayoutMorph methodsFor: 'accessing' stamp: 'KenD 6/4/2020 18:27:53' prior: 50521839! - separation: aNumberOrPoint - separation _ aNumberOrPoint. - self layoutSubmorphs ! ! -!LayoutSpec class methodsFor: 'deprecated' stamp: 'KenD 6/4/2020 18:39:02' prior: 50520527! - fixedWidth: aNumber fixedHeight: otherNumber minorDirectionPadding: aSymbolOrNumber - self flag: #deprecated. "use fixedWidth:fixedHeight:offAxisEdgeWeight:" - ^ LayoutSpec new - fixedWidth: aNumber; - fixedHeight: otherNumber; - minorDirectionPadding: aSymbolOrNumber! ! -!LayoutSpec class methodsFor: 'deprecated' stamp: 'KenD 6/4/2020 18:40:09' prior: 50520537! - fixedWidth: aNumber proportionalHeight: otherNumber minorDirectionPadding: aSymbolOrNumber - self flag: #deprecated. "use fixedWidth:proportionalHeight:offAxisEdgeWeight:" - ^self new - fixedWidth: aNumber; - proportionalHeight: otherNumber; - minorDirectionPadding: aSymbolOrNumber! ! -!LayoutSpec class methodsFor: 'deprecated' stamp: 'KenD 6/4/2020 18:41:13' prior: 50520548! - proportionalWidth: aNumber fixedHeight: otherNumber minorDirectionPadding: aSymbolOrNumber - self flag: #deprecated. "proportionalWidth:fixedHeight:offAxisEdgeWeight:" - ^self new - proportionalWidth: aNumber; - fixedHeight: otherNumber; - minorDirectionPadding: aSymbolOrNumber! ! -!LayoutSpec class methodsFor: 'deprecated' stamp: 'KenD 6/4/2020 18:42:09' prior: 50520559! - proportionalWidth: aNumber proportionalHeight: otherNumber minorDirectionPadding: aSymbolOrNumber - self flag: #deprecated. "use proportionalWidth:proportionalHeight:offAxisEdgeWeight: -" - ^self new - proportionalWidth: aNumber; - proportionalHeight: otherNumber; - minorDirectionPadding: aSymbolOrNumber! ! - -LayoutSpec removeSelector: #minimumLayoutHeight! - -!methodRemoval: LayoutSpec #minimumLayoutHeight stamp: 'Install-4208-LayoutRemoveUnused-KenDickey-2020Jun04-18h22m-KenD.003.cs.st 6/25/2020 16:07:31'! -minimumLayoutHeight - "Generally prefer asking the morph itself!!" - - proportionalHeight ifNil: [ ^0 ]. - ^fixedHeight ifNil: [0]! - -LayoutSpec removeSelector: #heightFor:! - -!methodRemoval: LayoutSpec #heightFor: stamp: 'Install-4208-LayoutRemoveUnused-KenDickey-2020Jun04-18h22m-KenD.003.cs.st 6/25/2020 16:07:31'! -heightFor: availableSpace - "If proportional is zero, answer stored fixed extent, or actual morph extent if undefined. - Otherwise, we do proportional layout, and the stored extent is a minimum extent. - If there is no minimum extent, it should be set to zero." - - ^proportionalHeight isNil - ifTrue: [fixedHeight ifNil: [morph morphHeight]] - ifFalse: [proportionalHeight * availableSpace + morph minimumLayoutExtent y]! - -LayoutSpec removeSelector: #widthFor:! - -LayoutSpec removeSelector: #fixedOrMorphWidth! - -!methodRemoval: LayoutSpec #fixedOrMorphWidth stamp: 'Install-4208-LayoutRemoveUnused-KenDickey-2020Jun04-18h22m-KenD.003.cs.st 6/25/2020 16:07:31'! -fixedOrMorphWidth - - self flag: #deprecated. - - ^fixedWidth ifNil: [ morph morphWidth ]! - -LayoutSpec removeSelector: #heightForComfortable:! - -!methodRemoval: LayoutSpec #heightForComfortable: stamp: 'Install-4208-LayoutRemoveUnused-KenDickey-2020Jun04-18h22m-KenD.003.cs.st 6/25/2020 16:07:31'! -heightForComfortable: availableSpace - "Similar to #heightFor:. To be used when we know availableSpace is more than the minimum required to apply proportional layout and still get more than our minimum. See senders." - - ^proportionalHeight isNil - ifTrue: [fixedHeight ifNil: [morph morphHeight]] - ifFalse: [proportionalHeight * availableSpace]! - -LayoutSpec removeSelector: #minimumLayoutWidth! - -!methodRemoval: LayoutSpec #minimumLayoutWidth stamp: 'Install-4208-LayoutRemoveUnused-KenDickey-2020Jun04-18h22m-KenD.003.cs.st 6/25/2020 16:07:31'! -minimumLayoutWidth - "Generally prefer asking the morph itself!!" - - proportionalWidth ifNil: [ ^0 ]. - ^fixedWidth ifNil: [0]! - -LayoutSpec removeSelector: #widthForComfortable:! - -Morph removeSelector: #minLayoutWidth! - -!methodRemoval: Morph #minLayoutWidth stamp: 'Install-4208-LayoutRemoveUnused-KenDickey-2020Jun04-18h22m-KenD.003.cs.st 6/25/2020 16:07:31'! -minLayoutWidth - - self flag: #deprecated. - ^ self layoutSpecOrNil - ifNil: [ self morphWidth ] - ifNotNil: [ :ls | ls minimumSpecWidth ]! - -Morph removeSelector: #minLayoutHeight! - -!methodRemoval: Morph #minLayoutHeight stamp: 'Install-4208-LayoutRemoveUnused-KenDickey-2020Jun04-18h22m-KenD.003.cs.st 6/25/2020 16:07:31'! -minLayoutHeight - - self flag: #deprecated. - ^ self layoutSpecOrNil - ifNil: [ self morphHeight ] - ifNotNil: [ :ls | ls minimumSpecHeight ] -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4208-LayoutRemoveUnused-KenDickey-2020Jun04-18h22m-KenD.003.cs.st----! - -'From Cuis 5.0 [latest update: #4208] on 5 June 2020 at 10:41:48 am'! - -TextModelMorph subclass: #BrowserCommentTextMorph - instanceVariableNames: 'separator separatorHeight proportionalHeight ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #BrowserCommentTextMorph category: #'Morphic-Views' stamp: 'Install-4209-Layouts-mark-deprecated-methods-JuanVuletich-2020Jun05-10h22m-jmv.002.cs.st 6/25/2020 16:07:31'! -TextModelMorph subclass: #BrowserCommentTextMorph - instanceVariableNames: 'separator separatorHeight proportionalHeight' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! -!BrowserCommentTextMorph methodsFor: 'displaying' stamp: 'jmv 6/5/2020 10:38:23' prior: 50519848! - hidePane - - self hide. - separator visible ifTrue: [ - proportionalHeight _ self layoutSpec proportionalLayoutHeight ]. - separator layoutSpec fixedHeight: 0. - self layoutSpec proportionalHeight: 0. - separator ifNotNil: [ separator hide ]! ! -!BrowserCommentTextMorph methodsFor: 'displaying' stamp: 'jmv 6/5/2020 10:38:45' prior: 16792967! - showPane - - self show. - proportionalHeight ifNotNil: [ - self layoutSpec proportionalHeight: proportionalHeight ]. - separator ifNotNil: [ - separator layoutSpec fixedHeight: Theme current layoutAdjusterThickness. - separator show ]! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'jmv 6/5/2020 10:38:00' prior: 50518684 overrides: 50518659! - buildLowerPanes - | codeAndButtons codeButtonsAndAnnotations comment separator | - comment _ self buildMorphicCommentPane. - separator _ LayoutAdjustingMorph new. - comment separator: separator. - codeAndButtons _ LayoutMorph newColumn. - Preferences optionalButtons ifTrue: [ - codeAndButtons - addMorph: self optionalButtonRow fixedHeight: self defaultButtonPaneHeight; - addAdjusterMorph ]. - codeAndButtons - addMorph: self buildMorphicCodePane proportionalHeight: 2.0; - addMorph: separator fixedHeight: Theme current layoutAdjusterThickness; - addMorph: comment proportionalHeight: 2.0. - Preferences showAnnotations ifFalse: [ - ^codeAndButtons ]. - codeButtonsAndAnnotations _ LayoutMorph newColumn. - codeButtonsAndAnnotations - addMorph: self buildMorphicAnnotationsPane fixedHeight: self defaultAnnotationPaneHeight; - addAdjusterMorph; - addMorph: codeAndButtons proportionalHeight: 1.0. - ^codeButtonsAndAnnotations! ! -!LayoutMorph methodsFor: 'deprecated' stamp: 'jmv 6/5/2020 10:22:53' prior: 50521623! - padding - - self deprecatedMethod. "use axisEdgeWeight" - ^ axisEdgeWeight! ! -!LayoutMorph methodsFor: 'deprecated' stamp: 'jmv 6/5/2020 10:23:08' prior: 50521629! - padding: aSymbolOrNumber - "This sets how extra space is used when doing layout. For example, a column might have extra , unneded vertical space. #top means widgets are set close to the top, and extra space is at bottom. Conversely, #bottom means widgets are set close to the bottom, and extra space is at top. Valid values include #left and #right (for rows) and #center. Alternatively, any number between 0.0 and 1.0 might be used. - self new padding: #center - self new padding: 0.9 - " - self deprecatedMethod. "use axisEdgeWeight:" - axisEdgeWeight _ aSymbolOrNumber - caseOf: { - [ #top ] -> [ 0.0 ]. - [ #left ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #right ] -> [ 1.0 ]. - [ #bottom ] -> [ 1.0 ] - } - otherwise: [ aSymbolOrNumber ]! ! -!LayoutSpec methodsFor: 'deprecated' stamp: 'jmv 6/5/2020 10:23:12' prior: 50519761! - fixedOrMorphHeight - - self deprecatedMethod. - - ^fixedHeight ifNil: [ morph morphHeight ]! ! -!LayoutSpec methodsFor: 'deprecated' stamp: 'jmv 6/5/2020 10:23:15' prior: 50521711! - minorDirectionPadding - self deprecatedMethod. "use offAxisEdgeWeight" - ^offAxisEdgeWeight! ! -!LayoutSpec methodsFor: 'deprecated' stamp: 'jmv 6/5/2020 10:23:19' prior: 50521717! - minorDirectionPadding: aSymbolOrNumber - "This sets how padding is done in the secondary direction. For instance, if the owning morph is set in a row, the row will control horizontal layout. But if there is unused vertical space, it will be used according to this parameter. For instance, #top sets the owning morph at the top. Same for #bottom and #center. If the owner is contained in a column, #left, #center or #right should be used. Alternatively, any number between 0.0 and 1.0 can be used. - self new minorDirectionPadding: #center - self new minorDirectionPadding: 0.9 - " - self deprecatedMethod. "use offAxisEdgeWeight:" - offAxisEdgeWeight _ aSymbolOrNumber - caseOf: { - [ #top ] -> [ 0.0 ]. - [ #left ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #right ] -> [ 1.0 ]. - [ #bottom ] -> [ 1.0 ] - } - otherwise: [ aSymbolOrNumber ]! ! -!LayoutSpec class methodsFor: 'deprecated' stamp: 'jmv 6/5/2020 10:23:22' prior: 50521960! - fixedWidth: aNumber fixedHeight: otherNumber minorDirectionPadding: aSymbolOrNumber - self deprecatedMethod. "use fixedWidth:fixedHeight:offAxisEdgeWeight:" - ^ LayoutSpec new - fixedWidth: aNumber; - fixedHeight: otherNumber; - minorDirectionPadding: aSymbolOrNumber! ! -!LayoutSpec class methodsFor: 'deprecated' stamp: 'jmv 6/5/2020 10:23:25' prior: 50521972! - fixedWidth: aNumber proportionalHeight: otherNumber minorDirectionPadding: aSymbolOrNumber - self deprecatedMethod. "use fixedWidth:proportionalHeight:offAxisEdgeWeight:" - ^self new - fixedWidth: aNumber; - proportionalHeight: otherNumber; - minorDirectionPadding: aSymbolOrNumber! ! -!LayoutSpec class methodsFor: 'deprecated' stamp: 'jmv 6/5/2020 10:23:27' prior: 50521984! - proportionalWidth: aNumber fixedHeight: otherNumber minorDirectionPadding: aSymbolOrNumber - self deprecatedMethod. "proportionalWidth:fixedHeight:offAxisEdgeWeight:" - ^self new - proportionalWidth: aNumber; - fixedHeight: otherNumber; - minorDirectionPadding: aSymbolOrNumber! ! -!LayoutSpec class methodsFor: 'deprecated' stamp: 'jmv 6/5/2020 10:23:34' prior: 50521996! - proportionalWidth: aNumber proportionalHeight: otherNumber minorDirectionPadding: aSymbolOrNumber - self deprecatedMethod. "use proportionalWidth:proportionalHeight:offAxisEdgeWeight: -" - ^self new - proportionalWidth: aNumber; - proportionalHeight: otherNumber; - minorDirectionPadding: aSymbolOrNumber! ! -!Theme methodsFor: 'other options' stamp: 'jmv 6/5/2020 10:39:44' prior: 50520570! - layoutAdjusterThickness - - self flag: #todo. "Revisit this; consider moving proportional stuff out of Theme entirely." - - ^ Preferences standardListFont pointSize // 3! ! - -PluggableButtonMorph removeSelector: #minLayoutWidth! - -!methodRemoval: PluggableButtonMorph #minLayoutWidth stamp: 'Install-4209-Layouts-mark-deprecated-methods-JuanVuletich-2020Jun05-10h22m-jmv.002.cs.st 6/25/2020 16:07:31'! -minLayoutWidth - - ^ self minimumExtent x! - -PluggableButtonMorph removeSelector: #minLayoutHeight! - -!methodRemoval: PluggableButtonMorph #minLayoutHeight stamp: 'Install-4209-Layouts-mark-deprecated-methods-JuanVuletich-2020Jun05-10h22m-jmv.002.cs.st 6/25/2020 16:07:31'! -minLayoutHeight - - ^ self minimumExtent y! - -TextModelMorph subclass: #BrowserCommentTextMorph - instanceVariableNames: 'separator proportionalHeight' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #BrowserCommentTextMorph category: #'Morphic-Views' stamp: 'Install-4209-Layouts-mark-deprecated-methods-JuanVuletich-2020Jun05-10h22m-jmv.002.cs.st 6/25/2020 16:07:31'! -TextModelMorph subclass: #BrowserCommentTextMorph - instanceVariableNames: 'separator proportionalHeight' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4209-Layouts-mark-deprecated-methods-JuanVuletich-2020Jun05-10h22m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4209] on 8 June 2020 at 10:55:41 am'! - -LayoutSpec class removeSelector: #proportionalWidth:proportionalHeight:minorDirectionPadding:! - -!methodRemoval: LayoutSpec class #proportionalWidth:proportionalHeight:minorDirectionPadding: stamp: 'Install-4210-Layouts-delete-deprecated-methods-JuanVuletich-2020Jun08-10h49m-jmv.001.cs.st 6/25/2020 16:07:31'! -proportionalWidth: aNumber proportionalHeight: otherNumber minorDirectionPadding: aSymbolOrNumber - self deprecatedMethod. "use proportionalWidth:proportionalHeight:offAxisEdgeWeight: -" - ^self new - proportionalWidth: aNumber; - proportionalHeight: otherNumber; - minorDirectionPadding: aSymbolOrNumber! - -LayoutSpec class removeSelector: #proportionalWidth:fixedHeight:minorDirectionPadding:! - -!methodRemoval: LayoutSpec class #proportionalWidth:fixedHeight:minorDirectionPadding: stamp: 'Install-4210-Layouts-delete-deprecated-methods-JuanVuletich-2020Jun08-10h49m-jmv.001.cs.st 6/25/2020 16:07:31'! -proportionalWidth: aNumber fixedHeight: otherNumber minorDirectionPadding: aSymbolOrNumber - self deprecatedMethod. "proportionalWidth:fixedHeight:offAxisEdgeWeight:" - ^self new - proportionalWidth: aNumber; - fixedHeight: otherNumber; - minorDirectionPadding: aSymbolOrNumber! - -LayoutSpec class removeSelector: #fixedWidth:fixedHeight:minorDirectionPadding:! - -!methodRemoval: LayoutSpec class #fixedWidth:fixedHeight:minorDirectionPadding: stamp: 'Install-4210-Layouts-delete-deprecated-methods-JuanVuletich-2020Jun08-10h49m-jmv.001.cs.st 6/25/2020 16:07:31'! -fixedWidth: aNumber fixedHeight: otherNumber minorDirectionPadding: aSymbolOrNumber - self deprecatedMethod. "use fixedWidth:fixedHeight:offAxisEdgeWeight:" - ^ LayoutSpec new - fixedWidth: aNumber; - fixedHeight: otherNumber; - minorDirectionPadding: aSymbolOrNumber! - -LayoutSpec class removeSelector: #fixedWidth:proportionalHeight:minorDirectionPadding:! - -!methodRemoval: LayoutSpec class #fixedWidth:proportionalHeight:minorDirectionPadding: stamp: 'Install-4210-Layouts-delete-deprecated-methods-JuanVuletich-2020Jun08-10h49m-jmv.001.cs.st 6/25/2020 16:07:31'! -fixedWidth: aNumber proportionalHeight: otherNumber minorDirectionPadding: aSymbolOrNumber - self deprecatedMethod. "use fixedWidth:proportionalHeight:offAxisEdgeWeight:" - ^self new - fixedWidth: aNumber; - proportionalHeight: otherNumber; - minorDirectionPadding: aSymbolOrNumber! - -LayoutSpec removeSelector: #minorDirectionPadding! - -!methodRemoval: LayoutSpec #minorDirectionPadding stamp: 'Install-4210-Layouts-delete-deprecated-methods-JuanVuletich-2020Jun08-10h49m-jmv.001.cs.st 6/25/2020 16:07:31'! -minorDirectionPadding - self deprecatedMethod. "use offAxisEdgeWeight" - ^offAxisEdgeWeight! - -LayoutSpec removeSelector: #fixedOrMorphHeight! - -!methodRemoval: LayoutSpec #fixedOrMorphHeight stamp: 'Install-4210-Layouts-delete-deprecated-methods-JuanVuletich-2020Jun08-10h49m-jmv.001.cs.st 6/25/2020 16:07:31'! -fixedOrMorphHeight - - self deprecatedMethod. - - ^fixedHeight ifNil: [ morph morphHeight ]! - -LayoutSpec removeSelector: #minorDirectionPadding:! - -!methodRemoval: LayoutSpec #minorDirectionPadding: stamp: 'Install-4210-Layouts-delete-deprecated-methods-JuanVuletich-2020Jun08-10h49m-jmv.001.cs.st 6/25/2020 16:07:31'! -minorDirectionPadding: aSymbolOrNumber - "This sets how padding is done in the secondary direction. For instance, if the owning morph is set in a row, the row will control horizontal layout. But if there is unused vertical space, it will be used according to this parameter. For instance, #top sets the owning morph at the top. Same for #bottom and #center. If the owner is contained in a column, #left, #center or #right should be used. Alternatively, any number between 0.0 and 1.0 can be used. - self new minorDirectionPadding: #center - self new minorDirectionPadding: 0.9 - " - self deprecatedMethod. "use offAxisEdgeWeight:" - offAxisEdgeWeight _ aSymbolOrNumber - caseOf: { - [ #top ] -> [ 0.0 ]. - [ #left ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #right ] -> [ 1.0 ]. - [ #bottom ] -> [ 1.0 ] - } - otherwise: [ aSymbolOrNumber ]! - -LayoutMorph removeSelector: #padding:! - -!methodRemoval: LayoutMorph #padding: stamp: 'Install-4210-Layouts-delete-deprecated-methods-JuanVuletich-2020Jun08-10h49m-jmv.001.cs.st 6/25/2020 16:07:31'! -padding: aSymbolOrNumber - "This sets how extra space is used when doing layout. For example, a column might have extra , unneded vertical space. #top means widgets are set close to the top, and extra space is at bottom. Conversely, #bottom means widgets are set close to the bottom, and extra space is at top. Valid values include #left and #right (for rows) and #center. Alternatively, any number between 0.0 and 1.0 might be used. - self new padding: #center - self new padding: 0.9 - " - self deprecatedMethod. "use axisEdgeWeight:" - axisEdgeWeight _ aSymbolOrNumber - caseOf: { - [ #top ] -> [ 0.0 ]. - [ #left ] -> [ 0.0 ]. - [ #center ] -> [ 0.5 ]. - [ #right ] -> [ 1.0 ]. - [ #bottom ] -> [ 1.0 ] - } - otherwise: [ aSymbolOrNumber ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4210-Layouts-delete-deprecated-methods-JuanVuletich-2020Jun08-10h49m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4208] on 8 June 2020 at 11:06:28 am'! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 6/8/2020 11:05:56' overrides: 50388595! - drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - - ^super drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint x @ (aPoint y // 2 * 2) font: fontOrNil color: aColor! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4211-EmbossedTextFix-JuanVuletich-2020Jun08-11h02m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4208] on 8 June 2020 at 11:42:03 am'! -!ProgressMorph methodsFor: 'accessing' stamp: 'jmv 6/8/2020 11:41:25' prior: 50444422! - label: aString subLabel: otherString - | label subLabel n | - label _ aString. - subLabel _ otherString. - layoutSpec notNil ifTrue: [ - n _ label size * self morphWidth * 0.95 // (AbstractFont default widthOfString: label). - label _ label squeezedTo: n. - n _ subLabel size * self morphWidth * 0.95 // (AbstractFont default widthOfString: subLabel). - subLabel _ subLabel squeezedTo: n ]. - self whenUIinSafeState: [ - labelMorph contents: label. - subLabelMorph contents: subLabel. - self updatePositionAndExtent. ]! ! -!ProgressMorph methodsFor: 'accessing' stamp: 'jmv 6/8/2020 11:26:00' prior: 50491106! - updatePositionAndExtent - | w newExtent | - layoutSpec notNil ifTrue: [ - ^self ]. - w _ ((labelMorph measureContents x max: subLabelMorph measureContents x) max: 200) + 18. - w _ w min: Display extent x. - newExtent _ w > extent x - ifTrue: [ w@(labelMorph morphHeight + subLabelMorph morphHeight + progress morphHeight + 10) ] - ifFalse: [ extent ]. - self world - ifNotNil: [ :world | - self morphPosition: world morphExtent - newExtent // 2 extent: newExtent ] - ifNil: [ self morphExtent: newExtent ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4212-ProgressMorph-fix-JuanVuletich-2020Jun08-11h06m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4212] on 8 June 2020 at 12:13:53 pm'! - -LayoutMorph removeSelector: #padding! - -!methodRemoval: LayoutMorph #padding stamp: 'Install-4213-delete-deprecated-methods-JuanVuletich-2020Jun08-12h13m-jmv.001.cs.st 6/25/2020 16:07:31'! -padding - - self deprecatedMethod. "use axisEdgeWeight" - ^ axisEdgeWeight! - -AbstractFont removeSelector: #height! - -!methodRemoval: AbstractFont #height stamp: 'Install-4213-delete-deprecated-methods-JuanVuletich-2020Jun08-12h13m-jmv.001.cs.st 6/25/2020 16:07:31'! -height - "Answer the line spacing. Prefer calling #lineSpacing, that is more explicit. - Besides, #height is false polymorphism, Fonts are not interchangeable with Form or Rectangle!!" - - self deprecatedMethod. - ^self lineSpacing! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4213-delete-deprecated-methods-JuanVuletich-2020Jun08-12h13m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4213] on 11 June 2020 at 10:10:34 am'! -!FontFamily class methodsFor: 'defaults' stamp: 'jmv 6/11/2020 09:58:10'! -defaultLineSpacing - ^FontFamily defaultFamilyAndPointSize lineSpacing! ! -!Object methodsFor: 'private' stamp: 'jmv 6/11/2020 10:01:05' prior: 50453288! - primitiveError: aString - "This method is called when the error handling results in a recursion in - calling on error: or halt or halt:." - - | context emergencyEvaluator lines r | - r _ `10@10` extent: (Display extent -20 min: `700@1000`). - lines _ r height // FontFamily defaultLineSpacing. - emergencyEvaluator _ Transcripter newInFrame: r. - emergencyEvaluator - nextPutAll: '***System error handling failed***'; newLine; - nextPutAll: aString; newLine; - nextPutAll: '-------------------------------'; newLine. - context _ thisContext sender sender. - (30 min: lines - 10) timesRepeat: [context ifNotNil: [emergencyEvaluator print: (context _ context sender); newLine]]. - emergencyEvaluator - nextPutAll: '-------------------------------'; newLine; - nextPutAll: 'Type ''revert'' to revert your last method change.'; newLine; - nextPutAll: 'Type ''exit'' to exit the emergency evaluator.'; newLine. - emergencyEvaluator readEvalPrint! ! -!Text methodsFor: 'emphasis' stamp: 'jmv 6/11/2020 10:07:59' prior: 50471619! - fontIfApplying: textAttributes default: defaultFont - "Answer the font for characters as specified by the argument." - - | fn ps | - self withAttributeValues: textAttributes do: [ :familyName :pointSize :emphasis :color :alignment :characterStyle :paragraphStyle :backgroundColor | - fn _ familyName ifNil: [ defaultFont ifNotNil: [ defaultFont familyName ] ifNil: [ FontFamily defaultFamilyName ]]. - ps _ pointSize ifNil: [ defaultFont ifNotNil: [ defaultFont pointSize ] ifNil: [ FontFamily defaultPointSize ]]. - ^((FontFamily familyName: fn pointSize: ps) ifNil: [ - FontFamily familyName: fn aroundPointSize: ps]) - emphasized: emphasis ]! ! -!Transcripter methodsFor: 'accessing' stamp: 'jmv 6/11/2020 10:01:22' prior: 50453320! - 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]. - textComposition - setModel: (TextModel withText: c asText); - extentForComposing: frame width-8 @9999. - textComposition composeAll. - d _ textComposition usedHeight - frame height. - d > 0 ifTrue: [ - "Scroll up to keep all contents visible" - cb _ textComposition characterBlockAtPoint: - `0@0` + (0@(d+FontFamily defaultLineSpacing)). - self on: (c copyFrom: cb stringIndex to: c size). - readLimit _ position _ collection size. - ^ self endEntry]. - Display fill: (frame insetBy: -2) fillColor: self black; - fill: frame fillColor: self white. - Display getCanvas - textComposition: textComposition - bounds: (`4@4` + frame topLeft extent: Display extent) - color: `Color black` - selectionColor: `Color blue`. - DisplayScreen screenUpdateRequired: nil! ! -!ProgressInitiationException methodsFor: 'exceptionDescription' stamp: 'jmv 6/11/2020 10:03:05' prior: 50477752 overrides: 16839987! - defaultAction - - | delta textFrame barFrame outerFrame result range width filledWidth f h textWidth textForm innerBarFrame oldFilledWidth oldFilledWidth2 prevContents | - f _ FontFamily defaultFamilyAndPointSize. - h _ f lineSpacing * 3//2. - textWidth _ (f widthOfString: progressTitle) + h. - width _ 150 max: textWidth. - - textForm _ Form extent: width@h depth: 32. - textForm fillBlack. - textForm fillWhite: (textForm boundingBox insetBy: 2). - progressTitle displayOn: textForm at: (width-textWidth+h//2@4). - barFrame _ Rectangle center: aPoint extent: width@h. - textFrame _ `0@0` extent: width@h. - textFrame _ textFrame - aligned: textFrame bottomCenter - with: barFrame topCenter + `0@2`. - outerFrame _ barFrame merge: textFrame. - delta _ outerFrame amountToTranslateWithin: Display boundingBox. - barFrame _ barFrame translatedBy: delta. - textFrame _ textFrame translatedBy: delta. - outerFrame _ outerFrame translatedBy: delta. - prevContents _ Form fromDisplay: outerFrame. - range _ maxVal = minVal ifTrue: [1] ifFalse: [maxVal - minVal]. "Avoid div by 0" - innerBarFrame _ barFrame insetBy: 2. - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - oldFilledWidth _ 0. - oldFilledWidth2 _ 0. - result _ workBlock value: "Supply the bar-update block for evaluation in the work block" - [ :barVal | - barVal - ifNotNil: [ currentVal _ barVal ] - ifNil: [ - currentVal _ currentVal + 1. - currentVal >= maxVal - ifTrue: [ currentVal _ minVal ]]. - filledWidth _ ((barFrame width-4) asFloat * ((currentVal-minVal) asFloat / range min: 1.0)) asInteger. - filledWidth > oldFilledWidth ifTrue: [ - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - Display fillGray: (barFrame topLeft + `2@2` extent: filledWidth@(h-4)). - filledWidth -200 > oldFilledWidth2 - ifFalse: [ - "Usually just request an update, to be done asynchronously." - DisplayScreen screenUpdateRequired: outerFrame ] - ifTrue: [ - "Once in a while, force a real screen update (warning: really slow on MacOS if done too often)" - Display forceToScreen: outerFrame. oldFilledWidth2 _ filledWidth ]. - oldFilledWidth _ filledWidth ]]. - prevContents displayAt: outerFrame topLeft. - self resume: result! ! -!TextEditor methodsFor: 'initialization' stamp: 'jmv 6/11/2020 10:03:22' prior: 16933051 overrides: 16896425! - initialize - selectionStartBlocks _ #(). - selectionStopBlocks _ #(). - initialSelectionStart _ nil. - initialSelectionStop _ nil. - doWordSelection _ false. - doParagraphSelection _ false. - defaultFont _ FontFamily defaultFamilyAndPointSize! ! -!TextFontFamilyAndSize methodsFor: 'accessing' stamp: 'jmv 6/11/2020 10:08:22' prior: 16933393! - font - - ^ FontFamily familyName: familyName pointSize: pointSize! ! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 6/11/2020 10:07:40' prior: 16892967! - setDefaultFonts: defaultFontsSpec - - | font | - defaultFontsSpec do: [ :triplet | - font _ FontFamily familyName: triplet second pointSize: triplet third. - font ifNil: [ font _ FontFamily defaultFamilyAndPointSize ]. - triplet size > 3 ifTrue: [ - font _ font emphasized: triplet fourth ]. - self - perform: triplet first - with: font]! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 6/11/2020 10:03:24' prior: 50453455! - displayOn: aForm in: aRectangle - " - 1 to: 2000 do: [ :i | i print ]. - 1 to: 750 do: [ :i | i print ]. - Transcript displayOn: Display in: bounds - " - | font count string x y fh canvas innerR index | - aForm fill: aRectangle fillColor: `Color white`. - font _ FontFamily defaultFamilyAndPointSize. - - innerR _ aRectangle insetBy: self padding. - canvas _ aForm getCanvas. - canvas newClipRect: innerR. - x _ innerR left. - y _ innerR top. - fh _ font lineSpacing. - count _ lastIndex - firstIndex \\ self maxEntries + 1 min: innerR height // fh - 1. - index _ lastIndex - count \\ self maxEntries + 1. - count timesRepeat: [ - string _ entries at: index. - canvas drawString: string at: x@y font: font color: `Color veryDarkGray`. - y _ y + fh. - index _ index \\ self maxEntries + 1 ]. - string _ unfinishedEntry contents. - canvas drawString: string at: x@y font: font color: `Color veryDarkGray`! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 6/11/2020 10:03:26' prior: 50453486! - displayUnfinishedEntryOn: aForm - - | font count string x y fh canvas r innerR | - innerR _ bounds insetBy: self padding. - lastDisplayPosition < innerR right ifTrue: [ - font _ FontFamily defaultFamilyAndPointSize. - fh _ font lineSpacing. - count _ innerR height // fh-1. - x _ innerR left. - string _ unfinishedEntry contents. - y _ ((lastIndex - firstIndex \\ self maxEntries) min: count-1) + 1 * font lineSpacing + innerR top. - canvas _ aForm getCanvas. - r _ innerR left: lastDisplayPosition. - canvas newClipRect: r. - (canvas drawString: string at: x@y font: font color: `Color veryDarkGray`) ifNotNil: [ :lastPoint | - lastDisplayPosition _ lastPoint x. - ^r ]]. - ^nil! ! -!AbstractFont methodsFor: 'measuring' stamp: 'jmv 6/11/2020 10:02:52' prior: 16777299! - widthOfString: aString - aString ifNil:[^0]. - ^self widthOfString: aString from: 1 to: aString size. -" - FontFamily defaultFamilyAndPointSize widthOfString: 'zort' -"! ! -!AbstractFont class methodsFor: 'instance accessing' stamp: 'jmv 5/5/2019 11:11:03' prior: 50456991! - default - " - Compatibility. - AbstractFont default - " - false ifTrue: [ self deprecatedMethod ]. "Too much senders to activate warnings right now!!" - ^FontFamily defaultFamilyAndPointSize! ! -!AbstractFont class methodsFor: 'instance accessing' stamp: 'jmv 6/11/2020 10:09:27' prior: 50393000! - fromUser: priorFont - " - AbstractFont fromUser - " - "Present a menu of available fonts, and if one is chosen, return it. - Otherwise return nil. - Show only baseFonts i.e. FamilyName, pointSize (but do not include emphasis, such as italic or bold)" - - | fontList fontMenu active ptMenu label spec | - fontList := FontFamily familyNames. - fontMenu := MenuMorph new defaultTarget: self. - fontList do: [:fontName | - active := priorFont familyName sameAs: fontName. - ptMenu := MenuMorph new defaultTarget: self. - (FontFamily pointSizesFor:fontName ) do: [ :pt | - (active and: [pt = priorFont pointSize]) - ifTrue: [label := ''] - ifFalse: [label := '']. - label := label , pt printString , ' pt'. - ptMenu - add: label - target: fontMenu - action: #modalSelection: - argument: { - fontName. - pt}]. - active ifTrue: [label := ''] ifFalse: [label := '']. - label := label , fontName. - fontMenu add: label subMenu: ptMenu]. - spec := fontMenu invokeModal. - spec ifNil: [^nil]. - ^FontFamily familyName: spec first pointSize: spec last! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 6/11/2020 10:03:13' prior: 50498783! - glyphAt: character put: characterForm - "Copy characterForm over the glyph for the argument, character." - | ascii leftX rightX widthDif newGlyphs | - ascii _ character numericValue. - ascii < minAscii ifTrue: [^ self error: 'Cant store characters below min ascii']. - ascii > maxAscii ifTrue: - [(self confirm: -'This font does not accomodate ascii values higher than ' , maxAscii printString , '. -Do you wish to extend it permanently to handle values up to ' , ascii printString) - ifTrue: [self extendMaxAsciiTo: ascii] - ifFalse: [^ self error: 'No change made']]. - leftX _ xTable at: ascii + 1. - rightX _ xTable at: ascii + 2. - widthDif _ characterForm width - (rightX - leftX). - widthDif ~= 0 ifTrue: - ["Make new glyphs with more or less space for this char" - newGlyphs _ Form extent: (glyphs width + widthDif) @ glyphs height depth: glyphs depth. - newGlyphs copy: (`0@0` corner: leftX@glyphs height) - from: `0@0` in: glyphs rule: Form over. - newGlyphs copy: ((rightX+widthDif)@0 corner: newGlyphs width@glyphs height) - from: rightX@0 in: glyphs rule: Form over. - glyphs _ newGlyphs. - "adjust further entries on xTable" - xTable _ xTable copy. - ascii+2 to: xTable size - do: [:i | xTable at: i put: (xTable at: i) + widthDif]]. - glyphs copy: (leftX @ 0 extent: characterForm extent) - from: 0@0 in: characterForm rule: Form over -" -| f | f _ FontFamily defaultFamilyAndPointSize. -f glyphAt: $ put: (Form extent: (f widthOf: $ )+10@f lineSpacing) -"! ! -!TextModelMorph methodsFor: 'geometry' stamp: 'jmv 6/11/2020 10:01:19' prior: 50453663 overrides: 16889728! - scrollDeltaHeight - "Return the increment in pixels which this pane should be scrolled." - - ^ FontFamily defaultLineSpacing! ! -!CodeWindow methodsFor: 'GUI building' stamp: 'jmv 6/11/2020 10:00:39' prior: 50453692! - defaultAnnotationPaneHeight - "Answer the receiver's preferred default height for new annotation panes." - - ^ FontFamily defaultLineSpacing * 2 + 8! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'jmv 6/11/2020 10:00:16' prior: 50453700! - buildMorphicClassColumnWith: classList - - | column | - - column _ LayoutMorph newColumn. - column - addMorphUseAll: classList; - addAdjusterAndMorph: self buildMorphicSwitches fixedHeight: - (Theme current minimalWindows - ifTrue: [FontFamily defaultLineSpacing + 4] - ifFalse: [FontFamily defaultLineSpacing *2-4]). - - ^column! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'jmv 6/11/2020 10:01:17' prior: 50513706! - addTextPane - | result | - result _ (TextModelMorph - textProvider: self - textGetter: #response - textSetter: #response: - selectionGetter: #selectionInterval) emptyTextDisplayMessage: 'Enter response'. - self - valueOfProperty: #emptyTextDisplayMessage - ifPresentDo: [ :msg | - result emptyTextDisplayMessage: msg ]. - result - hasUnacceptedEdits: true; - acceptOnCR: true; - escAction: [ self cancel ]. - "If the initial response is big or has multiple lines we make the text pane bigger and with scrollbars:" - (response size > 20 or: [response includes: Character lf]) - ifTrue: [result morphExtent: 32 @ 3 * FontFamily defaultLineSpacing] - ifFalse: - [result hideScrollBarsIndefinitely; - morphExtent: 18 @ 1 * FontFamily defaultLineSpacing + (0@8).]. - self addMorphBack: result. - ^ result.! ! -!StringMorph methodsFor: 'accessing' stamp: 'jmv 6/11/2020 10:03:16' prior: 16918173! - fontToUse - | fontToUse | - fontToUse := font ifNil: [FontFamily defaultFamilyAndPointSize]. - ^(emphasis isNil or: [emphasis = 0]) - ifTrue: [ fontToUse] - ifFalse: [ fontToUse emphasized: emphasis]! ! -!ProgressMorph methodsFor: 'accessing' stamp: 'jmv 6/11/2020 10:03:58' prior: 50522531! - label: aString subLabel: otherString - | label subLabel n | - label _ aString. - subLabel _ otherString. - layoutSpec notNil ifTrue: [ - n _ label size * self morphWidth * 0.95 // (FontFamily defaultFamilyAndPointSize widthOfString: label). - label _ label squeezedTo: n. - n _ subLabel size * self morphWidth * 0.95 // (FontFamily defaultFamilyAndPointSize widthOfString: subLabel). - subLabel _ subLabel squeezedTo: n ]. - self whenUIinSafeState: [ - labelMorph contents: label. - subLabelMorph contents: subLabel. - self updatePositionAndExtent. ]! ! -!ProgressMorph methodsFor: 'initialization' stamp: 'jmv 6/11/2020 10:03:55' prior: 50472463 overrides: 50521471! - initialize - super initialize. - self separation: 0. - labelMorph _ StringMorph contents: '' font: FontFamily defaultFamilyAndPointSize. - subLabelMorph _ StringMorph contents: '' font: FontFamily defaultFamilyAndPointSize. - progress _ ProgressBarMorph new. - progress morphExtent: 200 @ FontFamily defaultLineSpacing. - self addMorphFront: labelMorph. - self addMorphFront: subLabelMorph. - self addMorph: progress fixedHeight: FontFamily defaultLineSpacing! ! -!InnerListMorph methodsFor: 'drawing' stamp: 'jmv 6/11/2020 10:02:59' prior: 16855228! - font: newFont - font _ newFont ifNil: [ FontFamily defaultFamilyAndPointSize ]. - self adjustExtent! ! -!InnerTextMorph methodsFor: 'geometry' stamp: 'jmv 6/11/2020 10:00:48' prior: 50453904 overrides: 50499537! - minimumExtent - - ^(9@(FontFamily defaultLineSpacing+2))! ! -!InnerTextMorph methodsFor: 'private' stamp: 'jmv 6/11/2020 10:00:45' prior: 50453909! - fit - "Adjust my bounds to fit the text. - Required after the text changes, - or if wrapFlag is true and the user attempts to change the extent." - - | newExtent newHeight newWidth | - newWidth _ extent x. - "Adjust width only if we don't wrap text to own width!!" - wrapFlag ifFalse: [ - newWidth _ self textComposition usedWidth max: 9 ]. - newHeight _ self textComposition usedHeight max: FontFamily defaultLineSpacing + 2. - newExtent _ newWidth @ newHeight. - extent = newExtent - ifTrue: [ - self redrawNeeded. - "Too conservative: only text composition (because of changes in text or styles, etc) - should cause invalidation. - Try to avoid calling #fit unless needed." - ] - ifFalse: [ - extent = newExtent ifFalse: [ - self redrawNeeded. - extent _ newExtent. - self someSubmorphPositionOrExtentChanged. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]]. - - owner innerHeight: newExtent y! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jmv 6/11/2020 10:00:42' prior: 50453942! - sizeUnit - ^FontFamily defaultLineSpacing! ! -!FontPicker class methodsFor: 'prompting user' stamp: 'jmv 6/11/2020 10:05:21' prior: 50504111! - promptUser - "Present a menu of font families, answer selection. - FontPicker promptUser - " - ^self promptUserWithFamilies: FontFamily familyNames.! ! -!FontPicker class methodsFor: 'prompting user' stamp: 'jmv 6/11/2020 10:05:24' prior: 50503769! - promptUserAndSetDefault - "Present a menu of available font families, and if one is chosen, change to it." - self promptUserAndSetDefaultWithFamilies: FontFamily familyNames.! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 6/11/2020 10:02:56' prior: 50511053 overrides: 50463524! - drawString: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | p1 font | - "Don't waste any time if NOP" - lastIndex = 0 ifTrue: [ - ^nil ]. - - p1 _ (currentTransformation transform: aPoint rounded) rounded. - engine colorMap: nil. - font _ fontOrNil ifNil: [ FontFamily defaultFamilyAndPointSize ]. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: aColor! ! -!TextComposer methodsFor: 'accessing' stamp: 'jmv 6/11/2020 10:03:18' prior: 16930647! - defaultFont - ^editor ifNil: [ FontFamily defaultFamilyAndPointSize ] ifNotNil: [ editor defaultFont ]! ! -!TextComposition methodsFor: 'access' stamp: 'jmv 6/11/2020 10:03:20' prior: 16930683! -defaultFont - ^editor ifNil: [ FontFamily defaultFamilyAndPointSize ] ifNotNil: [ editor defaultFont ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4214-Font-Cleanup-JuanVuletich-2020Jun11-09h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4214] on 11 June 2020 at 10:21:51 am'! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 6/10/2020 22:06:23' prior: 50457977! - setDefaultFont: fontFamilyName spec: defaultFontsSpec - - | font | - defaultFontsSpec do: [ :triplet | - font _ FontFamily familyName: fontFamilyName pointSize: triplet second. - font ifNil: [ font _ FontFamily defaultFamilyAndPointSize ]. - triplet size > 2 ifTrue: [ - font _ font emphasized: triplet third ]. - self - perform: triplet first - with: font]! ! -!FontFamily class methodsFor: 'initialization' stamp: 'jmv 6/10/2020 22:07:13' prior: 50495886! - defaultFamilyName: aStringOrNil defaultPointSize: aNumberOrNil - "Nil just means leave it as it is now." - - aStringOrNil ifNotNil: [DefaultFamilyName _ aStringOrNil]. - aNumberOrNil ifNotNil: [DefaultPointSize _ aNumberOrNil].! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 6/11/2020 10:19:09' prior: 50504119! - preferencesMenu - "Build the preferences menu for the world." - - ^ (self menu: 'Preferences...') - addItemsFromDictionaries: { - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Font Sizes...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Set font...'. - #object -> FontPicker. - #selector -> #promptUserAndSetDefaultWithFamilies:. - #arguments -> {FontPicker familyNames}. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'change the current font family.' - } asDictionary. - { - #label -> 'Load extra fonts'. - #object -> FontFamily. - #selector -> #readAdditionalTrueTypeFonts. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'Load additional TrueType fonts included with Cuis.' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }! ! - -FontPicker class removeSelector: #promptUserAndSetDefaultInstallIfNecessaryWithFamilies:! - -!methodRemoval: FontPicker class #promptUserAndSetDefaultInstallIfNecessaryWithFamilies: stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:07:31'! -promptUserAndSetDefaultInstallIfNecessaryWithFamilies: fontFamilies - " - Present a menu of available font families, and if one is chosen, - install it if necessary, and change to it. - " - self promptUserWithFamilies: fontFamilies withMessageOnSelection: #setDefaultAndInstallIfNecessary:! - -FontPicker class removeSelector: #setDefaultAndInstallIfNecessary:! - -!methodRemoval: FontPicker class #setDefaultAndInstallIfNecessary: stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:07:31'! -setDefaultAndInstallIfNecessary: aFontName - "install the font if necessary, and change to it on the whole system without changing point sizes." - self installFontIfNecessary: aFontName. - self setDefaultFont: aFontName. -! - -FontPicker class removeSelector: #installFontIfNecessary:! - -!methodRemoval: FontPicker class #installFontIfNecessary: stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:07:31'! -installFontIfNecessary: aFontName - | isFontInstalled | - isFontInstalled _ FontFamily familyNames includes: aFontName. - isFontInstalled ifFalse: [StrikeFont install: aFontName.].! - -StrikeFont class removeSelector: #install:! - -!methodRemoval: StrikeFont class #install: stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:07:31'! -install: aString -" -StrikeFont install: 'DejaVu'. -" -" -StrikeFont install: 'DejaVu Sans Mono'. -FontFamily defaultFamilyName: 'DejaVu Sans Mono'. -Preferences bigFonts. -Character initialize. -" -" -StrikeFont install: 'DejaVu Sans'. -StrikeFont buildLargerPunctuation: 'DejaVu Sans'. -FontFamily defaultFamilyName: 'DejaVu Sans'. -Preferences standardFonts. -Character initialize. -" -" -StrikeFont install: 'Inconsolata' -StrikeFont install: '#PilGi' -StrikeFont install: 'Optima' -StrikeFont install: 'Herculanum' -StrikeFont install: 'Papyrus' -StrikeFont install: 'Handwriting - Dakota' -StrikeFont install: 'Times New Roman' -StrikeFont install: 'Apple Chancery' -StrikeFont install: 'Cochin' -StrikeFont install: 'Cracked' -StrikeFont install: 'Zapfino' -StrikeFont install: 'Brush Script MT' -StrikeFont install: 'Chalkboard' -" - | family | - family _ nil. - 1 to: 200 do: [ :s | - (self create: aString size: s bold: true italic: true boldItalic: false) ifNotNil: [ :font | - font print. - family ifNil: [ - family _ StrikeFontFamily new. - family familyName: aString.]. - family atPointSize: s put: font ]]. - family ifNotNil: [ - FontFamily addFamily: family ]! - -StrikeFont class removeSelector: #create:size:bold:italic:boldItalic:! - -!methodRemoval: StrikeFont class #create:size:bold:italic:boldItalic: stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:07:31'! -create: fontName size: pointSize bold: includeBold italic: includeItalic boldItalic: includeBoldItalic - " - self create: 'DejaVu Sans Mono' size: 12 bold: true italic: true boldItalic: true - " - | folder base bold oblique boldOblique point | - folder _ DirectoryEntry smalltalkImageDirectory / 'AdditionalFontData'. - point _ pointSize asString. - base _ [ (StrikeFont new - buildFromForm: ((Form fromFileEntry: folder // (fontName, '-0-', point, '.bmp')) asFormOfDepth: 16) - data: (folder // (fontName, '-0-', point, '.txt')) fileContents substrings - name: fontName, ' ', point) - pointSize: pointSize ] on: FileDoesNotExistException do: [ : ex | nil ]. - includeBold ifTrue: [ - bold _ [ (StrikeFont new - buildFromForm: ((Form fromFileEntry: folder // (fontName, '-1-', point, '.bmp')) asFormOfDepth: 16) - data: (folder // (fontName, '-1-', point, '.txt')) fileContents substrings - name: fontName, ' ', point, 'B') - emphasis: 1; - pointSize: pointSize ] on: FileDoesNotExistException do: [ : ex | nil ]]. - includeItalic ifTrue: [ - oblique _ [ (StrikeFont new - buildFromForm: ((Form fromFileEntry: folder // (fontName, '-2-', point, '.bmp')) asFormOfDepth: 16) - data: (folder // (fontName, '-2-', point, '.txt')) fileContents substrings - name: fontName, ' ', point, 'I') - emphasis: 2; - pointSize: pointSize ] on: FileDoesNotExistException do: [ : ex | nil ]]. - includeBoldItalic ifTrue: [ - boldOblique _ [ (StrikeFont new - buildFromForm: ((Form fromFileEntry: folder // (fontName, '-3-', point, '.bmp')) asFormOfDepth: 16) - data: (folder // (fontName, '-3-', point, '.txt')) fileContents substrings - name: fontName, ' ', point, 'BI') - emphasis: 3; - pointSize: pointSize ] on: FileDoesNotExistException do: [ : ex | nil ]]. - "We have a regular, base font. Make others derivatives of it" - base ifNotNil: [ - bold ifNotNil: [ - base derivativeFont: bold at: 1 ]. - oblique ifNotNil: [ - base derivativeFont: oblique at: 2]. - boldOblique ifNotNil: [ - base derivativeFont: boldOblique at: 3 ]. - ^base ]. - "We don't have a base, regular font." - oblique ifNotNil: [ - oblique emphasis: 0. "Hacky. Non regular fonts can not have derivatives. Should change this?" - bold ifNotNil: [ - oblique derivativeFont: bold at: 1 ]. - boldOblique ifNotNil: [ - oblique derivativeFont: boldOblique at: 3 ]. - ^oblique ]. - bold ifNotNil: [ - bold emphasis: 0. "Hacky. Non regular fonts can not have derivatives. Should change this?" - boldOblique ifNotNil: [ - bold derivativeFont: boldOblique at: 3 ]. - ^bold ]. - boldOblique ifNotNil: [ - ^boldOblique ]. - ^nil! - -StrikeFont class removeSelector: #buildLargerPunctuation:! - -!methodRemoval: StrikeFont class #buildLargerPunctuation: stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:07:31'! -buildLargerPunctuation: familyName - " - StrikeFont buildLargerPunctuation: 'DejaVu Sans' - " - | form form2 f10 f11 f12 f9 | - - f9 _ AbstractFont familyName: familyName pointSize: 9. - f10 _ AbstractFont familyName: familyName pointSize: 10. - f11 _ AbstractFont familyName: familyName pointSize: 11. - f12 _ AbstractFont familyName: familyName pointSize: 12. - - - f9 takeGlyphFor: $. from: $. in: f12. - f9 takeGlyphFor: $, from: $, in: f12. - - form _ f9 glyphAt: $.. - form copy: (0@9 extent: 3@14) from: form to: 0@4 rule: Form and. - f9 glyphAt: $: put: form. - - form _ f9 glyphAt: $,. - form2 _ f9 glyphAt: $.. - form copy: (0@9 extent: 3@14) from: form2 to: 1@4 rule: Form and. - f9 glyphAt: $; put: form. - - - - f10 takeGlyphFor: $. from: $. in: f12. - f10 takeGlyphFor: $, from: $, in: f12. - - form _ f10 glyphAt: $. . - form copy: (0@9 extent: 3@14) from: form to: 0@4 rule: Form and. - f10 glyphAt: $: put: form. - - form _ f10 glyphAt: $,. - form2 _ f10 glyphAt: $.. - form copy: (0@9 extent: 3@14) from: form2 to: 1@4 rule: Form and. - f10 glyphAt: $; put: form. - - - - f11 takeGlyphFor: $. from: $. in: f12. - f11 takeGlyphFor: $, from: $, in: f12. - f11 takeGlyphFor: $: from: $: in: f12. - f11 takeGlyphFor: $; from: $; in: f12! - -StrikeFont removeSelector: #fixDerivatives! - -!methodRemoval: StrikeFont #fixDerivatives stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:07:31'! -fixDerivatives - self isBaseFont - ifTrue: [ - baseFont _ nil. - derivativeFonts ifNotNil: [ - derivativeFonts valuesDo: [ :der | - der ifNotNil: [ - der baseFont: self. - der fixDerivatives ]]]] - ifFalse: [ - derivativeFonts _ nil ].! - -StrikeFont removeSelector: #widen:by:! - -!methodRemoval: StrikeFont #widen:by: stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:07:31'! -widen: char by: delta - | newForm | - ^ self alter: char formBlock: "Make a new form, wider or narrower..." - [:charForm | newForm _ Form extent: charForm extent + (delta@0). - charForm displayOn: newForm. "Copy this image into it" - newForm] "and substitute it in the font"! - -StrikeFont removeSelector: #derivativeFont:at:! - -!methodRemoval: StrikeFont #derivativeFont:at: stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:07:31'! -derivativeFont: aStrikeFontOrNil at: index - "Store aStrikeFontOrNil at index - If arg is nil, then remove font at index. But if index = 0, then remove all derivatives." - - (aStrikeFontOrNil isNil and: [ index = 0 ]) - ifTrue: [ - derivativeFonts _ nil. - ^ self]. - - self isBaseFont ifFalse: [ - derivativeFonts _ nil. - self error: 'Derivative fonts can not have derivatives' ]. - - derivativeFonts ifNil: [ derivativeFonts _ Dictionary new ]. - aStrikeFontOrNil - ifNil: [ derivativeFonts removeKey: index ] - ifNotNil: [ - derivativeFonts at: index put: aStrikeFontOrNil. - aStrikeFontOrNil baseFont: self ]! - -StrikeFont removeSelector: #pointSize:! - -!methodRemoval: StrikeFont #pointSize: stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:07:31'! -pointSize: anInteger - pointSize _ anInteger! - -StrikeFont removeSelector: #checkCharacter:! - -!methodRemoval: StrikeFont #checkCharacter: stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:07:31'! -checkCharacter: character - "Answer a Character that is within the ascii range of the receiver--either - character or the last character in the receiver." - - | ascii | - ascii _ character numericValue. - ((ascii < minAscii) or: [ascii > maxAscii]) - ifTrue: [^maxAscii asCharacter] - ifFalse: [^character] -! - -StrikeFont removeSelector: #characterToGlyphMap:! - -!methodRemoval: StrikeFont #characterToGlyphMap: stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:07:31'! -characterToGlyphMap: anArray - characterToGlyphMap _ anArray.! - -StrikeFont removeSelector: #takeGlyphFor:from:in:! - -!methodRemoval: StrikeFont #takeGlyphFor:from:in: stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:07:31'! -takeGlyphFor: aCharacter from: sourceCharacter in: aFont - "Copy characterForm over the glyph for the argument, character." - | f r characterForm | - characterForm _ aFont glyphAt: sourceCharacter. - r _ 0@(0 + aFont ascent - self ascent) extent: characterForm width @ glyphs height. - f _ characterForm copy: r. - self glyphAt: aCharacter put: f! - -StrikeFont removeSelector: #alter:formBlock:! - -!methodRemoval: StrikeFont #alter:formBlock: stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:07:31'! -alter: char formBlock: formBlock - self - glyphAt: char - put: (formBlock value: (self glyphAt: char))! - -StrikeFont removeSelector: #buildFromForm:data:name:! - -!methodRemoval: StrikeFont #buildFromForm:data:name: stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:07:31'! -buildFromForm: allGlyphs data: data name: aString - - | x shortUnderscore firstGlyphInFiles | - pointSize _ data first asNumber. - ascent _ data second asNumber. - descent _ data third asNumber. - - firstGlyphInFiles _ 257-(data size-3). - minAscii _ 1. - maxAscii _ 255. - name _ aString. - type _ 0. "ignored for now" - superscript _ ascent - descent // 3. - subscript _ descent - ascent // 3. - emphasis _ 0. - - xTable _ (Array new: 258) atAllPut: 0. - maxWidth _ 0. - glyphs _ allGlyphs depth > 16 ifTrue: [ allGlyphs asFormOfDepth: 16 ] ifFalse: [ allGlyphs ]. - x _ 0. - 4 to: data size do: [ :i | - x _ (data at: i) asNumber. - xTable at: i+firstGlyphInFiles+1-4 put: x]. - xTable at: 258 put: x. - self reset. - derivativeFonts _ nil. - - self makeCrVisible. - - "Replace glyph for 127 (a box) with a short version of the underscore (used to optionally mark subscript in code)" - shortUnderscore _ self glyphAt: $_. - shortUnderscore _ shortUnderscore copy: (`0@0` extent: 1@shortUnderscore height). - self glyphAt: (Character numericValue: 127) put: shortUnderscore! - -StrikeFont removeSelector: #maxWidth! - -!methodRemoval: StrikeFont #maxWidth stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:07:31'! -maxWidth - "Answer the integer that is the width of the receiver's widest character." - - ^maxWidth! - -StrikeFont removeSelector: #derivativeFonts! - -!methodRemoval: StrikeFont #derivativeFonts stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:07:31'! -derivativeFonts - ^derivativeFonts! - -AbstractFont removeSelector: #derivativeFonts! - -!methodRemoval: AbstractFont #derivativeFonts stamp: 'Install-4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st 6/25/2020 16:07:31'! -derivativeFonts - ^#()! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4215-Font-Cleanup-JuanVuletich-2020Jun11-10h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4214] on 11 June 2020 at 10:25:09 am'! - -AbstractFont class removeSelector: #familyName:pointSize:! - -!methodRemoval: AbstractFont class #familyName:pointSize: stamp: 'Install-4216-Font-Cleanup-JuanVuletich-2020Jun11-10h21m-jmv.001.cs.st 6/25/2020 16:07:31'! -familyName: aString pointSize: aNumber - " - Compatibility. - AbstractFont familyName: Preferences defaultFontFamily pointSize: 12 - " - false ifTrue: [ self deprecatedMethod ]. "Too much senders to activate warnings right now!!" - ^FontFamily familyName: aString pointSize: aNumber! - -AbstractFont class removeSelector: #default! - -!methodRemoval: AbstractFont class #default stamp: 'Install-4216-Font-Cleanup-JuanVuletich-2020Jun11-10h21m-jmv.001.cs.st 6/25/2020 16:07:31'! -default - " - Compatibility. - AbstractFont default - " - false ifTrue: [ self deprecatedMethod ]. "Too much senders to activate warnings right now!!" - ^FontFamily defaultFamilyAndPointSize! - -AbstractFont class removeSelector: #familyName:aroundPointSize:! - -!methodRemoval: AbstractFont class #familyName:aroundPointSize: stamp: 'Install-4216-Font-Cleanup-JuanVuletich-2020Jun11-10h21m-jmv.001.cs.st 6/25/2020 16:07:31'! -familyName: aString aroundPointSize: aNumber - " - Compatibility. - AbstractFont familyName: Preferences defaultFontFamily aroundPointSize: 120 - " - false ifTrue: [ self deprecatedMethod ]. "Too much senders to activate warnings right now!!" - ^FontFamily familyName: aString aroundPointSize: aNumber! - -AbstractFont class removeSelector: #pointSizesFor:! - -!methodRemoval: AbstractFont class #pointSizesFor: stamp: 'Install-4216-Font-Cleanup-JuanVuletich-2020Jun11-10h21m-jmv.001.cs.st 6/25/2020 16:07:31'! -pointSizesFor: aString - " - Compatibility. - AbstractFont pointSizesFor: Preferences defaultFontFamily - " - false ifTrue: [ self deprecatedMethod ]. "Too much senders to activate warnings right now!!" - ^FontFamily pointSizesFor: aString! - -AbstractFont class removeSelector: #familyNames! - -!methodRemoval: AbstractFont class #familyNames stamp: 'Install-4216-Font-Cleanup-JuanVuletich-2020Jun11-10h21m-jmv.001.cs.st 6/25/2020 16:07:31'! -familyNames - " - Compatibility. - AbstractFont familyNames - " - false ifTrue: [ self deprecatedMethod ]. "Too much senders to activate warnings right now!!" - ^FontFamily familyNames! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4216-Font-Cleanup-JuanVuletich-2020Jun11-10h21m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4214] on 11 June 2020 at 10:27:04 am'! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 6/11/2020 10:26:23' prior: 50523205! - preferencesMenu - "Build the preferences menu for the world." - - ^ (self menu: 'Preferences...') - addItemsFromDictionaries: { - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Font Sizes...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Set font...'. - #object -> FontPicker. - #selector -> #promptUserAndSetDefaultWithFamilies:. - #arguments -> {FontFamily familyNames}. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'change the current font family.' - } asDictionary. - { - #label -> 'Load extra fonts'. - #object -> FontFamily. - #selector -> #readAdditionalTrueTypeFonts. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'Load additional TrueType fonts included with Cuis.' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }! ! - -FontPicker class removeSelector: #familyNames! - -!methodRemoval: FontPicker class #familyNames stamp: 'Install-4217-Font-Cleanup-JuanVuletich-2020Jun11-10h25m-jmv.001.cs.st 6/25/2020 16:07:31'! -familyNames - | monospacedStrikeFont options | - monospacedStrikeFont _ 'DejaVu Sans Mono'. - options _ FontFamily familyNames. - (options includes: monospacedStrikeFont) ifFalse: [ - options _ options copyWith: monospacedStrikeFont ]. - ^ options! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4217-Font-Cleanup-JuanVuletich-2020Jun11-10h25m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4214] on 11 June 2020 at 10:33:07 am'! -!Text methodsFor: 'emphasis' stamp: 'jmv 6/11/2020 10:32:11' prior: 50522641! - fontIfApplying: textAttributes default: defaultFont - "Answer the font for characters as specified by the argument." - - | fn ps | - self withAttributeValues: textAttributes do: [ :familyName :pointSize :emphasis :color :alignment :characterStyle :paragraphStyle :backgroundColor | - fn _ familyName ifNil: [ defaultFont ifNotNil: [ defaultFont familyName ] ifNil: [ FontFamily defaultFamilyName ]]. - ps _ pointSize ifNil: [ defaultFont ifNotNil: [ defaultFont pointSize ] ifNil: [ FontFamily defaultPointSize ]]. - ^((FontFamily familyName: fn pointSize: ps) ifNil: [ FontFamily defaultFamilyAndPointSize ]) - emphasized: emphasis ]! ! -!AbstractFont class methodsFor: 'instance accessing' stamp: 'jmv 6/10/2020 23:17:59' prior: 16777426! - fromUser - " - AbstractFont fromUser - " - ^self fromUser: FontFamily defaultFamilyAndPointSize ! ! -!StrikeFont methodsFor: 'objects from disk' stamp: 'jmv 6/11/2020 10:30:27' prior: 50459083 overrides: 16881992! - objectForDataStream: refStrm - - "I am about to be written on an object file. Write a textual reference instead. - Warning: This saves a lot of space, but might fail if using other fonts than those in AvailableFonts" - - ^ DiskProxy - global: #FontFamily - selector: #familyName:pointSize: - args: (Array with: self familyName with: self pointSize)! ! -!StrikeFont methodsFor: 'synthetic derivatives' stamp: 'jmv 6/11/2020 10:30:32' prior: 50458845! - syntheticSubscript - "Build and answer a derivative that is Subscript." - - | derivative | - derivative _ ((FontFamily familyName: self familyName pointSize: pointSize * 0.58) - emphasized: emphasis) - copy. - derivative useShortUnderscore. - ^ derivative - -" -StrikeFont allInstances do: [ :a | a reset ]. -('Hi ', (Text string: 'there' attribute: TextEmphasis superscript), ' how ', (Text string: 'are' attribute: TextEmphasis subscript), ' you?') edit. -"! ! -!StrikeFont methodsFor: 'synthetic derivatives' stamp: 'jmv 6/11/2020 10:30:38' prior: 50458863! - syntheticSuperscript - "Build and answer a derivative that is Superscript." - - | derivative | - derivative _ ((FontFamily familyName: self familyName pointSize: pointSize * 0.58) - emphasized: emphasis) - copy. - derivative name: self name , 'Sup'. - ^ derivative - -" -StrikeFont allInstances do: [ :a | a reset ]. -('Hi ', (Text string: 'there' attribute: TextEmphasis superscript), ' how ', (Text string: 'are' attribute: TextEmphasis subscript), ' you?') edit. -"! ! -!FontFamily methodsFor: 'accessing' stamp: 'jmv 6/11/2020 10:29:28' prior: 50457046! - atPointSize: aNumber -" - ^baseFontBySizes at: aNumber ifAbsent: nil -" - ^baseFontBySizes at: aNumber ifAbsent: [ |found | - found _ nil. - baseFontBySizes do: [ :font | - (found isNil or: [ (found pointSize - aNumber) abs > (font pointSize - aNumber) abs ]) - ifTrue: [ found _ font ]]. - found - ]! ! - -FontFamily class removeSelector: #familyName:aroundPointSize:! - -!methodRemoval: FontFamily class #familyName:aroundPointSize: stamp: 'Install-4218-Font-Cleanup-JuanVuletich-2020Jun11-10h27m-jmv.001.cs.st 6/25/2020 16:07:31'! -familyName: aString aroundPointSize: aNumber - " - FontFamily familyName: 'DejaVu' aroundPointSize: 120 - " - | family | - family _ AvailableFamilies at: aString ifAbsent: [^nil]. - ^family aroundPointSize: aNumber! - -FontFamily removeSelector: #aroundPointSize:! - -!methodRemoval: FontFamily #aroundPointSize: stamp: 'Install-4218-Font-Cleanup-JuanVuletich-2020Jun11-10h27m-jmv.001.cs.st 6/25/2020 16:07:31'! -aroundPointSize: aNumber - ^baseFontBySizes at: aNumber ifAbsent: [ |found | - found _ nil. - baseFontBySizes do: [ :font | - (found isNil or: [ (found pointSize - aNumber) abs > (font pointSize - aNumber) abs ]) - ifTrue: [ found _ font ]]. - found - ]! - -Preferences class removeSelector: #setDefaultFonts:! - -!methodRemoval: Preferences class #setDefaultFonts: stamp: 'Install-4218-Font-Cleanup-JuanVuletich-2020Jun11-10h27m-jmv.001.cs.st 6/25/2020 16:07:31'! -setDefaultFonts: defaultFontsSpec - - | font | - defaultFontsSpec do: [ :triplet | - font _ FontFamily familyName: triplet second pointSize: triplet third. - font ifNil: [ font _ FontFamily defaultFamilyAndPointSize ]. - triplet size > 3 ifTrue: [ - font _ font emphasized: triplet fourth ]. - self - perform: triplet first - with: font]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4218-Font-Cleanup-JuanVuletich-2020Jun11-10h27m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4218] on 12 June 2020 at 11:30:20 am'! -!FontFamily class methodsFor: 'accessing fonts' stamp: 'jmv 6/11/2020 16:47:20' prior: 50456866! - familyName: aString pointSize: aNumber - " - FontFamily familyName: FontFamily defaultFamilyName pointSize: 12 - FontFamily defaultFamilyPointSize: 12 - " - | family | - family _ AvailableFamilies at: aString ifAbsent: [^nil]. - ^family atPointSize: aNumber! ! -!FontFamily class methodsFor: 'accessing fonts' stamp: 'jmv 6/11/2020 16:52:09' prior: 50503744! - familyNamed: aString - " - FontFamily familyNamed: FontFamily defaultFamilyName - " - ^AvailableFamilies at: aString ifAbsent: [].! ! -!FontFamily class methodsFor: 'accessing fonts' stamp: 'jmv 6/11/2020 16:39:34' prior: 50456916! - pointSizesFor: aString - " - FontFamily pointSizesFor: FontFamily defaultFamilyName - " - | family | - family _ AvailableFamilies at: aString ifAbsent: [^nil]. - ^family pointSizes! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -dict _ (FontFamily bindingOf: 'AvailableFamilies') value. -#('DejaVu Sans Mono' 'DejaVu') do: [ :familyName | - family _ FontFamily familyNamed: familyName. - family class = StrikeFontFamily ifTrue: [ - newName _ familyName, ' Bitmap'. - family instVarNamed: 'familyName' put: newName. - dict at: newName put: family. - dict removeKey: familyName. - FontFamily defaultFamilyName = familyName ifTrue: [ - FontPicker setDefaultFont: newName. - "FontFamily defaultFamilyName: newName defaultPointSize: nil" ]. - StrikeFont allInstancesDo: [ :sf | - ((sf name beginsWith: familyName) and: [ (sf name beginsWith: newName) not]) - ifTrue: [ sf name: (newName, (sf name copyFrom: familyName size+1 to: sf name size)) ]] - ]. -]. -StrikeFont allInstances collect: [ :sf | sf pointSize > 14 ifTrue: [ sf setGlyphsDepthAtMost: 4 ]]. -UISupervisor whenUIinSafeState: [self runningWorld recreateDefaultDesktop] -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4219-Font-Cleanup-JuanVuletich-2020Jun12-11h28m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4219] on 15 June 2020 at 1:43:33 pm'! -!WeakMessageSend commentStamp: '' prior: 16944070! - Instances of WeakMessageSend encapsulate message sends to objects, like MessageSend. Unlike MessageSend it is not necessarily a valid mesage. A request to value only results in a send if in fact it is valid. - -See MessageSendComments also. WeakMessageSend is used primarily for event regristration. - -Unlike MessageSend WeakMessageSend stores the receiver (object receiving the message send) as the first and only element of its array as opposed to a named ivar. -But like MessageSend, it does have - selector Symbol -- message selector - arguments Array -- bound arguments -and it also has - shouldBeNil Boolean -- used to ensure array of arguments is not all nils! -!Float commentStamp: '' prior: 50451035! - A note About Floating Point numbers and Floating Point Arithmetic. - -The following is not specific to Cuis or Smalltalk at all. This is about the properties of Float numbers in any computer implementation. - -If you haven't done so already, read https://en.wikipedia.org/wiki/Floating-point_arithmetic - -But if you find the Wikipedia article too detailed, or hard to read, then try http://fabiensanglard.net/floating_point_visually_explained/ (get past "How Floating Point are usually explained" and read "A different way to explain..."). - -Other great reads are: - "Why don't my numbers add up?": - http://floating-point-gui.de/ -and - "What Every Computer Scientist Should Know About Floating-Point Arithmetic": - http://docs.oracle.com/cd/E19957-01/806-3568/ncg_goldberg.html -and also maybe - "Comparing floating point numbers" - https://randomascii.wordpress.com/2012/02/25/comparing-floating-point-numbers-2012-edition/ - -Now that you read them, and we are on the same boat, some further comments (from jmv): - -Floats are (conceptually) approximate real numbers. That's why trig and other trascendental functions always answer Floats. That's why it is ok to round the result of operations. That's why Float is considered more general than Fraction in ST-80 and most Smalltalks. So, when we have a Float value, we must not think about it as a Rational but as a Real (actually as some unknown Real that could hopefully be close to the Rational we can actually represent). Keep this in mind when dealing with Floats, and especially avoid comparing them for equality. - -When doing mixed operations with Floats and Fractions, Cuis, as most other Smalltalks, converts all values to Floats. Some other systems, including Pharo Smalltalk, Scheme and Lisp have two rules: when the answer is a Number, they convert to Float. But when the answer is a boolean (#<, #=, #<=, etc.) they convert to Fraction. We think this is a mistake. There should never be implicit conversions from Float to Fraction. Fractions are to hold exact values, and people expect Fractions to be exact. On the other hand, Floats are to hold approximations (and people should be aware of that!!). But an implicit conversion from Float to Fraction would give a Fraction that should not be considered an exact value (the value comes from an inexact Float), but that knowledge is lost, as it is an instance of Fraction. - -If you want exact arithmetic, usual mathematical properties (like transitivity of equality), can live in the limited world of Rational numbers, and can afford a slight performance penalty, use Fraction instead. Avoid trascendental functions and never convert to Float. - -In any case, most numeric computation is done on Float numbers. There are good reasons for that. One is that in most cases we don't need an exact answer. And in many cases we can't really have it: the inputs to algorithms already have a limited precision, or they use transcendental functions. And even when exact arithmetic is possible, if we are doing sound synthesis, 24 bits of resolution is enough. For image processing and graphics, the result is never more than 16 bits per channel. So, these fields don't really need 64 bit Doubles. 32 bit Floats are enough. Other fields do need 64 bit Doubles, like physics simulations and geometry. Games usually prefer special, faster 32 bit Float operations in GPUs that have greater errors but are faster. - -There are some things that can be done to increase the confidence you can have on Float results. One is to do an error propagation analysis on the code you are running. This is not easy, but it is done for any widely used numerical method. Then, you can know real bounds and/or estimates of the errors made. So, understanding your inputs and your algorithms (for example error propagation, condition number, numeric stability), and using Float number if appropriate, is the usual advice. - -Perhaps you have heard about "interval arithmetic". It is a bit better than simple Float, but doesn't really fix the problems. - -The ultimate solution is to do Monte Carlo analysis, with random perturbation of inputs. After the Monte Carlo run, it is needed to do statistical analysis of possible correlations between the distributions of the random noise added to imputs and the result of the algorithm. - -Additional food for thought: http://www.cs.berkeley.edu/~wkahan/Mindless.pdf . According to this, doing Monte Carlo as described above attacks a slightly different problem. This might be yet another reason (besides performance) to try something like the next paragraph. I (jmv) came up with it, and I don't really know if it has been described and or tried before or not. Mhhh. Maybe a defensive publication is in order. - -A possibility that could be a practical solution, being much cheaper than Monte Carlo, but better than interval arithmetic, is to represent each value by 2 Floats: an estimation of the real value (i.e. an estimation of the mean value of the distribution of the corresponding Monte Carlo result), and an estimation of the error (i.e. an estimation of the standard deviation of the corresponding Monte Carlo result). Or perhaps even 3 of them. In addition to the estimation of the real value and an estimation of the error, we could add a hard bound on the error. In many cases it will be useless, because the error can not really be bound. But in those cases where it is possible to bound it, applications could really know about the quality of computed values. - -======================================================================= - -My instances represent IEEE 754 floating-point double-precision numbers. They have about 16 decimal digits of accuracy and their range is between plus and minus 10^307. Some valid examples are: - - 8.0 13.3 0.3 2.5e6 1.27e-30 1.27e-31 -12.987654e12 - -Mainly: no embedded blanks, little e for tens power, and a digit on both sides of the decimal point. It is actually possible to specify a radix for Float constants. This is great for teaching about numbers, but may be confusing to the average reader: - - 3r20.2 --> 6.66666666666667 - 8r20.2 --> 16.25 - -If you don't have access to the definition of IEEE754, you can figure out what is going on by printing various simple values in Float hex. It may help you to know that the basic format is... - sign 1 bit - exponent 11 bits with bias of 1023 (16r3FF), substracted to produce an actual exponent in the range -1022 .. +1023 - - 16r000: - significand = 0: Float zero - significand ~= 0: Denormal number (actual exponent is -1022, not -1023. No implicit leading '1' bit in mantissa) - - 16r7FF: - significand = 0: Infinity - significand ~= 0: Not A Number (NaN) representation - mantissa 53 bits, but only 52 are stored (20 in the first word, 32 in the second). This is because a normalized mantissa, by definition, has a 1 to the right of its floating point, and IEEE 754 omits this redundant bit to gain an extra bit of precision instead. People talk about the mantissa without its leading one as the FRACTION, and with its leading 1 as the SIGNFICAND. - -The single-precision format is... - sign 1 bit - exponent 8 bits with bias of 127 (16r7F, substracted to produce an actual exponent in the range -126 .. +127 - - 16r00: - significand = 0: Float zero - significand ~= 0: Denormal number (actual exponent is -126, not -127. No implicit leading '1' bit in mantissa) - - 16rFF: - significand = 0: Infinity - significand ~= 0: Not A Number (NaN) representation - mantissa 24 bits, but only 23 are stored -This format is used in FloatArray (qv), and much can be learned from the conversion routines, Float asIEEE32BitWord, and Float class fromIEEE32Bit:. - -You might also check https://en.wikipedia.org/wiki/IEEE_754_revision - -Other great reads (covering broader but interesting issues): -https://randomascii.wordpress.com/2013/07/16/floating-point-determinism/ -https://web.archive.org/web/20150909015114/http://www.ima.umn.edu/2010-2011/W1.10-14.11/activities/Leeser-Miriam/Leeser-GPU-IMA-Jan2011.pdf -! -!SmallInteger commentStamp: '' prior: 16908586! - In 32-bit images my instances are 31-bit numbers, stored in twos complement form. The allowable range is approximately +- 1 billion. - -In 64-bit images my instances are 61-bit numbers, stored in twos complement form. The allowable range is approximately +- 10^18 (+- 1 quintillion) - -(See SmallInteger minVal, maxVal). - -Of the various classes in the Number hierarchy, SmallInteger gives: -- Maximum performance -- Top precision -- Restricted possible values - -LargePositive(Negative)Integer and Fraction give increasing generality (more possible values) at the expense of performance. - -Float gives more generality at the expense of precision. - -Please see the class comments of the other Number classes.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4220-CommentFixes-DouglasBrebner-2020Jun15-13h40m-db.001.cs.st----! - -'From Cuis 5.0 [latest update: #4219] on 13 June 2020 at 5:33:51 pm'! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 6/13/2020 17:06:24'! - setDefaultFont: aFontName - "Change the font on the whole system without changing point sizes." - FontFamily defaultFamilyName: aFontName. - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: { - {#setListFontTo:. Preferences standardListFont pointSize.}. - {#setMenuFontTo:. Preferences standardMenuFont pointSize.}. - {#setWindowTitleFontTo:. Preferences windowTitleFont pointSize.}. - {#setCodeFontTo:. Preferences standardCodeFont pointSize.}. - {#setButtonFontTo:. Preferences standardButtonFont pointSize.}. - }. - DisplayScreen runningWorld ifNotNil: [ :world | world fontPreferenceChanged ]. - -! ! -!FontFamily class methodsFor: 'ui' stamp: 'jmv 6/13/2020 17:32:17'! - promptUser - "Present a menu of font families, answer selection. - FontFamily promptUser - " - | fontMenu priorFontFamily | - priorFontFamily _ FontFamily defaultFamilyName. - fontMenu _ MenuMorph new. - FontFamily familyNames do: [:fontName | - fontMenu - add: ((priorFontFamily sameAs: fontName) ifTrue: [''] ifFalse: [''] ), fontName - target: fontMenu - action: #modalSelection: - argument: fontName. - ]. - ^FontFamily familyNamed: fontMenu invokeModal.! ! -!FontFamily class methodsFor: 'ui' stamp: 'jmv 6/13/2020 17:32:58'! - promptUserAndSetDefault - "Present a menu of available font families, and if one is chosen, change to it. - FontFamily promptUserAndSetDefault - " - self promptUser ifNotNil: [ :fontFamily | Preferences setDefaultFont: fontFamily familyName ]! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 6/13/2020 17:32:34' prior: 50523785! - preferencesMenu - "Build the preferences menu for the world." - - ^ (self menu: 'Preferences...') - addItemsFromDictionaries: { - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Font Sizes...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Set System Font...'. - #object -> FontFamily. - #selector -> #promptUserAndSetDefault. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'change the current system font family.' - } asDictionary. - { - #label -> 'Load extra fonts'. - #object -> FontFamily. - #selector -> #readAdditionalTrueTypeFonts. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'Load additional TrueType fonts included with Cuis.' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }! ! - -Smalltalk removeClassNamed: #FontPicker! - -!classRemoval: #FontPicker stamp: 'Install-4221-FontPicker-remove-JuanVuletich-2020Jun13-17h23m-jmv.002.cs.st 6/25/2020 16:07:32'! -Object subclass: #FontPicker - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4221-FontPicker-remove-JuanVuletich-2020Jun13-17h23m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4221] on 16 June 2020 at 6:17:57 pm'! -!MenuItemMorph methodsFor: 'layout' stamp: 'jmv 6/14/2020 18:18:47'! - magnifiedIcon - - | iconForm w h factor magnifiedExtent magnifiedIcon | - icon ifNil: [ ^nil ]. - iconForm _ isEnabled ifTrue: [ icon ] ifFalse: [ icon asGrayScaleAndTransparent ]. - magnifiedIcon _ iconForm. - w _ iconForm width. - h _ iconForm height. - w*h = 0 ifFalse: [ - factor _ extent y * 0.8 / h. - factor = 1.0 ifFalse: [ - magnifiedExtent _ (iconForm extent * factor) rounded. - magnifiedIcon _ iconForm magnifyTo: magnifiedExtent ]]. - ^magnifiedIcon! ! -!MenuItemMorph methodsFor: 'drawing' stamp: 'jmv 6/14/2020 18:19:11' prior: 50503532 overrides: 50503485! - drawOn: aCanvas - | stringColor leftEdge magnifiedIcon | - - stringColor _ color. - isSelected & isEnabled - ifTrue: [ - aCanvas fillRectangle: self morphLocalBounds color: Theme current menuHighlight]. - leftEdge _ 0. - - self hasMarker ifTrue: [ - leftEdge _ leftEdge + submorphs first morphWidth + 8 ]. - - icon ifNotNil: [ - magnifiedIcon _ self magnifiedIcon. - aCanvas image: magnifiedIcon at: leftEdge+1 @ (magnifiedIcon height *1//10). - leftEdge _ magnifiedIcon width *12//10 + leftEdge]. - - aCanvas - drawString: contents - at: leftEdge @ 1 - font: self fontToUse - color: stringColor. - subMenu ifNotNil: [ - aCanvas - image: self class subMenuMarker - at: extent x - 8 @ (extent y - self class subMenuMarker height // 2) ]! ! -!MenuItemMorph methodsFor: 'layout' stamp: 'jmv 6/14/2020 18:19:22' prior: 50472364 overrides: 16876050! - minItemWidth - | fontToUse iconWidth subMenuWidth markerWidth | - fontToUse _ self fontToUse. - subMenuWidth _ self hasSubMenu - ifFalse: [0] - ifTrue: [10]. - iconWidth _ icon - ifNotNil: [self magnifiedIcon width * 12//10] - ifNil: [0]. - markerWidth _ self hasMarker - ifTrue: [ submorphs first morphWidth + 8 ] - ifFalse: [ 0 ]. - ^ (fontToUse widthOfString: contents) - + subMenuWidth + iconWidth + markerWidth.! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 6/14/2020 18:04:51' prior: 50524485! -preferencesMenu - "Build the preferences menu for the world." - - ^ (self menu: 'Preferences...') - addItemsFromDictionaries: { - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Font Sizes...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Set System Font...'. - #object -> FontFamily. - #selector -> #promptUserAndSetDefault. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'change the current system font family.' - } asDictionary. - { - #label -> 'Load all TrueType Fonts'. - #object -> FontFamily. - #selector -> #readAdditionalTrueTypeFonts. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'Load additional TrueType fonts included with Cuis.' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }! ! - -MenuItemMorph removeSelector: #iconSeparation! - -!methodRemoval: MenuItemMorph #iconSeparation stamp: 'Install-4222-MenuFix-JuanVuletich-2020Jun16-18h17m-jmv.001.cs.st 6/25/2020 16:07:32'! -iconSeparation - ^5! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4222-MenuFix-JuanVuletich-2020Jun16-18h17m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4222] on 16 June 2020 at 6:59:04 pm'! -!FontFamily methodsFor: 'accessing' stamp: 'jmv 6/16/2020 18:30:05'! - folderName - ^nil! ! -!FontFamily class methodsFor: 'accessing' stamp: 'jmv 6/16/2020 18:43:47'! - availableFamilies - ^AvailableFamilies! ! -!FontFamily class methodsFor: 'ui' stamp: 'jmv 6/16/2020 18:56:36'! - promptUserAlt - "Present a menu of font families, answer selection. - Alternative implementation: Show only installed fonts. - FontFamily promptUserAlt - " - | fontMenu priorFontFamily | - priorFontFamily _ FontFamily defaultFamilyName. - fontMenu _ MenuMorph new. - FontFamily familyNames do: [:fontName | - fontMenu - add: ((priorFontFamily sameAs: fontName) ifTrue: [''] ifFalse: [''] ), fontName - target: fontMenu - action: #modalSelection: - argument: fontName. - ]. - ^FontFamily familyNamed: fontMenu invokeModal.! ! -!FontFamily class methodsFor: 'ui' stamp: 'jmv 6/16/2020 18:58:14' prior: 50524457! - promptUser - "Present a menu of font families, answer selection. - FontFamily promptUser - " - | menu selectedDirectory dejaVuBitmap current this | - current _ (FontFamily familyNamed: FontFamily defaultFamilyName) folderName. - menu _ MenuMorph new. - ((DirectoryEntry smalltalkImageDirectory / 'TrueTypeFonts') - directories sorted: [ :a :b | a name < b name ]) do: [ :dir | | subDirs | - subDirs _ dir directories sorted: [ :a :b | a name < b name ]. - subDirs isEmpty - ifTrue: [ - this _ dir name. - menu - add: (this=current ifTrue: [''] ifFalse: ['']), this - target: menu - action: #modalSelection: - argument: dir ] - ifFalse: [ | submenu | - submenu _ MenuMorph new. - subDirs do: [ :subdir | - this _ subdir name. - submenu - add: (this=current ifTrue: [''] ifFalse: ['']), this - target: menu - action: #modalSelection: - argument: subdir ]. - menu add: dir name, '... ' subMenu: submenu - ]]. - dejaVuBitmap _ 'DejaVu Bitmap'. - menu - add: (dejaVuBitmap = FontFamily defaultFamilyName ifTrue: [''] ifFalse: ['']), dejaVuBitmap - target: menu - action: #modalSelection: - argument: this. - selectedDirectory _ menu invokeModal. - selectedDirectory = this - ifTrue: [ ^FontFamily familyNamed: dejaVuBitmap ]. - selectedDirectory isNil ifTrue: [ ^nil ]. - ^FontFamily availableFamilies values - detect: [ :any | any folderName = selectedDirectory name ] - ifNone: [ - Feature require: 'VectorGraphics'. - FontFamily familyNamed: ((Smalltalk at: #TrueTypeFontFamily) read: selectedDirectory) anyOne ]! ! -!FontFamily class methodsFor: 'ui' stamp: 'jmv 6/13/2020 17:32:58' prior: 50524474! - promptUserAndSetDefault - "Present a menu of available font families, and if one is chosen, change to it. - FontFamily promptUserAndSetDefault - " - self promptUser ifNotNil: [ :fontFamily | Preferences setDefaultFont: fontFamily familyName ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4223-NewFontMenu-JuanVuletich-2020Jun16-18h21m-jmv.003.cs.st----! - -'From Cuis 5.0 [latest update: #4223] on 16 June 2020 at 7:25:31 pm'! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 6/16/2020 19:24:29' prior: 50522513 overrides: 50388595! - drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - | p1 font | - p1 _ (currentTransformation transform: aPoint rounded) rounded. - engine colorMap: nil. - font _ fontOrNil ifNil: [ FontFamily defaultFamilyAndPointSize ]. - - aColor = `Color black` ifFalse: [ | topColor | - topColor _ aColor alphaMixed: 0.25 with: `Color black`. - font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: topColor ]. - aColor = `Color white` ifFalse: [ | bottomColor | - bottomColor _ aColor alphaMixed: 0.22 with: `Color white`. - font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + `0@2` - color: bottomColor ]. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + `0@1` - color: aColor.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4224-EmbossedTextFix-JuanVuletich-2020Jun16-19h12m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4224] on 16 June 2020 at 7:41:14 pm'! -!Text methodsFor: 'emphasis' stamp: 'jmv 6/16/2020 19:36:42' prior: 50370542! - withAttributeValues: attributes do: aBlock - "Evaluate aBlock with the values of various attributes that affect text formatting, applied in the correct order - The order is (each overwriting the previous one) - 1) basic defaults - 2) ParagraphStyleReferene - 3) CharacterStyleReference - 4) TextFontReference - 5) TextEmphasis" - - | paragraphStyle characterStyle familyName pointSize emphasis alignment color backgroundColor | - paragraphStyle _ nil. - characterStyle _ nil. - familyName _ nil. - pointSize _ nil. - emphasis _ 0. - alignment _ 0. - color _ nil. - backgroundColor _ nil. - - "ParagraphStyle is the first to set several values" - attributes do: [ :attribute | - attribute forParagraphStyleReferenceDo: [ :s | - paragraphStyle _ s. - familyName _ s familyName. - pointSize _ s pointSize. - emphasis _ s emphasis. - alignment _ s alignment. - s color ifNotNil: [ :c | color _ c ]]]. - - "CharacterStyle, if present, can override font and color" - attributes do: [ :attribute | - attribute forCharacterStyleReferenceDo: [ :s | - characterStyle _ s. - familyName _ s familyName. - pointSize _ s pointSize. - emphasis _ s emphasis. - s color ifNotNil: [ :c | color _ c ]]]. - - "These will not interfere with each other, and all of them take precedence over previous values" - attributes do: [ :attribute | - attribute forFontFamilyAndSizeDo: [ :fn :ps | fn notNil ifTrue: [familyName _ fn]. pointSize _ ps ]. - attribute forTextEmphasisDo: [ :e | emphasis _ emphasis bitOr: e ]. - attribute forTextColorDo: [ :c | color _ c ]. - attribute forTextBackgroundColorDo: [ :c | backgroundColor _ c ]. - attribute forTextAlignmentDo: [ :a | alignment _ a ]. - ]. - - "Done. Now evaluate the block." - ^aBlock valueWithArguments: { familyName. pointSize. emphasis. color. alignment. characterStyle. paragraphStyle. backgroundColor }! ! -!TextFontFamilyAndSize methodsFor: 'accessing' stamp: 'jmv 6/16/2020 19:37:03' prior: 16933387! - familyName: aStringOrNil pointSize: aNumber - familyName _ aStringOrNil. - pointSize _ aNumber! ! -!TextFontFamilyAndSize methodsFor: 'accessing' stamp: 'jmv 6/16/2020 19:35:53' prior: 50522787! -font - - ^familyName isNil - ifTrue: [ FontFamily defaultFamilyPointSize: pointSize] - ifFalse: [ FontFamily familyName: familyName pointSize: pointSize ]! ! -!TextFontFamilyAndSize class methodsFor: 'instance creation' stamp: 'jmv 6/16/2020 19:39:55' prior: 50471650! - pointSize: aNumber - "Reference only default family baseFont. Any emphasis should be done with TextEmphasis. - Store only pointSize" - ^ self new familyName: nil pointSize: aNumber! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4225-TextAttributesFix-JuanVuletich-2020Jun16-19h33m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4225] on 16 June 2020 at 8:00:35 pm'! -!FontFamily class methodsFor: 'ui' stamp: 'jmv 6/16/2020 19:59:24' prior: 50524809! - promptUser - "Present a menu of font families, answer selection. - FontFamily promptUser - " - | menu selectedNameOrDirectory familyName current | - current _ (FontFamily familyNamed: FontFamily defaultFamilyName) folderName. - menu _ MenuMorph new. - ((DirectoryEntry smalltalkImageDirectory / 'TrueTypeFonts') - directories sorted: [ :a :b | a name < b name ]) do: [ :dir | | subDirs | - subDirs _ dir directories sorted: [ :a :b | a name < b name ]. - subDirs isEmpty - ifTrue: [ | this | - this _ dir name. - menu - add: (this=current ifTrue: [''] ifFalse: ['']), this - target: menu - action: #modalSelection: - argument: dir ] - ifFalse: [ | submenu this | - submenu _ MenuMorph new. - subDirs do: [ :subdir | - this _ subdir name. - submenu - add: (this=current ifTrue: [''] ifFalse: ['']), this - target: menu - action: #modalSelection: - argument: subdir ]. - menu add: dir name, '... ' subMenu: submenu - ]]. - FontFamily availableFamilies values do: [ :family | - family folderName isNil ifTrue: [ - familyName _ family familyName. - menu - add: (familyName = FontFamily defaultFamilyName ifTrue: [''] ifFalse: ['']), familyName - target: menu - action: #modalSelection: - argument: familyName ]]. - selectedNameOrDirectory _ menu invokeModal. - selectedNameOrDirectory isNil ifTrue: [ ^nil ]. - (FontFamily familyNamed: selectedNameOrDirectory) - ifNotNil: [ :it | ^it ]. - ^FontFamily availableFamilies values - detect: [ :any | any folderName = selectedNameOrDirectory name ] - ifNone: [ - Feature require: 'VectorGraphics'. - FontFamily familyNamed: ((Smalltalk at: #TrueTypeFontFamily) read: selectedNameOrDirectory) anyOne ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4226-FontMenuFix-JuanVuletich-2020Jun16-19h49m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4226] on 18 June 2020 at 9:33:45 am'! -!BrowserWindow class methodsFor: 'GUI building' stamp: 'HAW 6/18/2020 09:31:57'! - classNameRequester - - ^ClassNameRequestMorph! ! -!BrowserWindow class methodsFor: 'GUI building' stamp: 'HAW 6/18/2020 09:32:01'! - findClassDialogTitle - - ^ 'Class name or fragment?'! ! -!BrowserWindow class methodsFor: 'GUI building' stamp: 'HAW 6/18/2020 09:27:38' prior: 50514920! - findClassFrom: potentialClassNames ifFound: aBlock - | classNames exactMatch foundClass index toMatch | - self classNameRequester request: self findClassDialogTitle initialAnswer: '' do: [:pattern| - pattern isEmpty - ifTrue: [self flash] - ifFalse: - [toMatch _ (pattern copyWithout: $.) asLowercase withBlanksTrimmed. - classNames _ (pattern last = $. or: [pattern last = $ ]) - ifTrue: [potentialClassNames select: [:nm | nm asLowercase = toMatch]] - ifFalse: [potentialClassNames select: [:n | n includesSubstring: toMatch caseSensitive: false]]. - classNames isEmpty - ifTrue: [self flash] - ifFalse: - [exactMatch _ classNames detect: [ :each | each asLowercase = toMatch] ifNone: nil. - - index _ classNames size = 1 - ifTrue: [ 1 ] - ifFalse: [ exactMatch - ifNil: [(PopUpMenu labelArray: classNames lines: #()) startUpMenu] - ifNotNil: [classNames addFirst: exactMatch. - (PopUpMenu labelArray: classNames lines: #(1)) startUpMenu]]. - - index = 0 - ifTrue: [self flash] - ifFalse: - [foundClass _ Smalltalk at: (classNames at: index) asSymbol. - - aBlock value: foundClass]]]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4227-findClassCustomization-HernanWilkinson-2020Jun17-16h06m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4226] on 18 June 2020 at 4:10:54 pm'! -!Scanner methodsFor: 'xBacktick processing - private' stamp: 'HAW 6/18/2020 16:09:06'! - assertNodesIn: methodNode canBeReferencedInsideBacktickUsing: compiler - - ^ methodNode nodesDo: [ :aNode | - (self canNotBeReferencedInsideBacktick: aNode) ifTrue: [ - compiler notify: (self class canNotReferencePseudoVarInsideBacktickErrorDescriptionFor: aNode key) ]]! ! -!Scanner methodsFor: 'xBacktick processing - private' stamp: 'HAW 6/18/2020 16:09:27'! - canNotBeReferencedInsideBacktick: aNode - - ^ aNode isSelfPseudoVariable - or: [ aNode isSuperPseudoVariable - or: [ aNode isThisContextPseudoVariable ]]! ! -!Scanner class methodsFor: 'xBacktick processing - private' stamp: 'HAW 6/18/2020 15:39:25'! - canNotReferencePseudoVarInsideBacktickErrorDescriptionFor: pseudoVariable - - ^ 'Can not reference ', pseudoVariable, ' inside backtick'! ! -!Scanner methodsFor: 'xBacktick processing - private' stamp: 'HAW 6/18/2020 16:09:14' prior: 50445140! - compileBacktickCode - - | compiler method methodNode | - - compiler _ Compiler new. - methodNode _ compiler compileNoPattern: buffer contents in: UndefinedObject context: nil notifying: nil ifFail: []. - self assertNodesIn: methodNode canBeReferencedInsideBacktickUsing: compiler. - method _ methodNode generate. - - "Grab all messages sent while evaluating literal, so the main method will be shown as senders of them" - sentInLiterals addAll: method messages. - method literalsDo: [ :literal | literal isSymbol ifTrue: [ literal = self class doItSelector ifFalse: [sentInLiterals add: literal ]]]. - - "Evaluate now." - token _ nil withArgs: #() executeMethod: method ! ! - -Scanner removeSelector: #canNotReferencePseudoVarInsideBacktickErrorDescriptionFor:! - -Scanner removeSelector: #canNotReferencePseudoVarInsideBacktickErrorDescriptionFor! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4228-CanNotReferenceSelfSuperThisContextInsideBacktick-HernanWilkinson-2020Jun18-15h25m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4228] on 19 June 2020 at 1:29:46 pm'! -!String methodsFor: 'grammar' stamp: 'LC 6/19/2020 12:52:49' prior: 50507968! - exceptionalPlural - | singular plural index | - singular := #( - 'addendum' 'aircraft' 'alga' 'alumna' 'alumnus' 'amoeba' 'antenna' 'appendix' 'automaton' - 'bacillus' 'bacterium' 'barracks' - 'cactus' 'calculus' 'child' 'cicatrix' 'colossus' 'corpus' 'corrigendum' 'criterion' 'curriculum' - 'datum' 'deer' 'desideratum' 'dwarf' - 'echo' 'embargo' 'ephemeris' 'erratum' 'extremum' - 'fish' 'focus' 'foot' 'forum' 'fungus' - 'gallows' 'genus' 'goose' - 'hero' - 'index' 'infimum' 'is' - 'lacuna' 'larva' 'louse' - 'matrix' 'maximum' 'means' 'memorandum' 'minimum' 'mythos' 'money' 'mouse' - 'nucleus' - 'offspring' 'optimum' 'opus' 'ox' - 'person' 'phenomenon' 'phylum' 'potato' 'proof' - 'quantum' - 'roof' - 'series' 'sheep' 'species' 'spoof' 'stimulus' 'stratum' 'syllabus' - 'tomato' 'tooth' 'torpedo' 'trilby' - 'vertebra' 'vertex' 'veto' - 'was'). - plural := #( - 'addenda' 'aircraft' 'algae' 'alumnae' 'alumni' 'amoebae' 'antennae' 'appendices' 'automata' - 'bacilli' 'bacteria' 'barracks' - 'cacti' 'calculi' 'children' 'cicatrices' 'colossi' 'corpora' 'corrigenda' 'criteria' 'curricula' - 'data' 'deer' 'desiderata' 'dwarfs' - 'echoes' 'embargoes' 'ephemerides' 'errata' 'extrema' - 'fish' 'foci' 'feet' 'fora' 'fungi' - 'gallows' 'genera' 'geese' - 'heroes' - 'indices' 'infima' 'are' - 'lacunae' 'larvae' 'lice' - 'matrices' 'maxima' 'means' 'memoranda' 'minima' 'mythoi' 'moneys' 'mice' - 'nuclei' - 'offspring' 'optima' 'opera' 'oxen' - 'people' 'phenomena' 'phyla' 'potatoes' 'proofs' - 'quanta' - 'roofs' - 'series' 'sheep' 'species' 'spoofs' 'stimuli' 'strata' 'syllabi' - 'tomatoes' 'teeth' 'torpedoes' 'trilbys' - 'vertebrae' 'vertices' 'vetoes' - 'were'). - index := singular indexOf: self. - ^index > 0 ifTrue: [plural at: index]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4229-asPlural-improvements-LeandroCaniglia-2020Jun19-12h52m-LC.001.cs.st----! - -'From Cuis 5.0 [latest update: #4213] on 16 June 2020 at 7:48:29 pm'! - -"Change Set: 4214-CuisCore-AuthorName-2020Jun08-23h50m -Date: 16 June 2020 -Author: Nahuel Garbezza - -Use consistently class methods to create MethodReference instances"! -!ProtocolBrowser methodsFor: 'private' stamp: 'RNG 6/9/2020 00:16:22' prior: 16896698! - onSubProtocolOf: aClass - "Initialize with the entire protocol for the class, aClass, - but excluding those inherited from Object." - | selectors | - selectors _ Set new. - (aClass withAllSuperclassesPreviousTo: Object) - do: [ :each | selectors addAll: each selectors ]. - self - initListFrom: selectors asArray sort - highlighting: aClass.! ! -!ChangeList methodsFor: 'menu actions' stamp: 'RNG 6/8/2020 23:53:46' prior: 16796147! - currentVersionsOfSelections - "Opens a message-list browser on the current in-memory versions of all methods that are currently seleted" - | aList | - - aList _ OrderedCollection new. - 1 to: changeList size do: [ :i | - (listSelections at: i) ifTrue: [ - | aClass aChange | - aChange _ changeList at: i. - (aChange changeType == #method - and: [(aClass _ aChange changeClass) notNil - and: [aClass includesSelector: aChange methodSelector]]) - ifTrue: [ - aList add: (MethodReference - class: aClass - selector: aChange methodSelector)]]]. - ^ aList! ! -!SystemDictionary methodsFor: 'retrieving' stamp: 'RNG 6/9/2020 00:10:27' prior: 16921493! - allCallsOn: firstLiteral and: secondLiteral - "Answer a SortedCollection of all the methods that call on both aLiteral - and secondLiteral." - - | aCollection secondArray firstSpecial secondSpecial firstByte secondByte | - aCollection _ SortedCollection new. - firstSpecial _ self hasSpecialSelector: firstLiteral ifTrueSetByte: [:b | firstByte _ b]. - secondSpecial _ self hasSpecialSelector: secondLiteral ifTrueSetByte: [:b | secondByte _ b]. - self allBehaviorsDo: [ :class | - secondArray _ class - whichSelectorsReferTo: secondLiteral - special: secondSpecial - byte: secondByte. - ((class whichSelectorsReferTo: firstLiteral special: firstSpecial byte: firstByte) select: [ :aSel | - (secondArray includes: aSel)]) do: [ :sel | - aCollection add: (MethodReference class: class selector: sel )]]. - ^aCollection! ! -!SystemDictionary methodsFor: 'retrieving' stamp: 'RNG 6/9/2020 00:10:45' prior: 16921626! - allImplementorsOf: aSelector - "Answer a SortedCollection of all the methods that implement the message - aSelector." - - | aCollection | - - aCollection _ SortedCollection new. - self allBehaviorsDo: [ :class | - (class includesSelector: aSelector) ifTrue: [ - aCollection add: (MethodReference class: class selector: aSelector )]]. - ^aCollection! ! -!SystemDictionary methodsFor: 'retrieving' stamp: 'RNG 6/9/2020 00:01:28' prior: 16921641! - allImplementorsOf: aSelector localTo: aClass - "Answer a sorted Collection of all the methods that implement the message - aSelector in, above, or below the given class." - - | aSet cls | - aSet _ Set new. - cls _ aClass theNonMetaClass. - cls withAllSuperAndSubclassesDoGently: [ :class | - (class includesSelector: aSelector) - ifTrue: [ aSet add: (MethodReference class: class selector: aSelector) ] ]. - cls class withAllSuperAndSubclassesDoGently: [ :class | - (class includesSelector: aSelector) - ifTrue: [ aSet add: (MethodReference class: class selector: aSelector) ] ]. - ^aSet asArray sort! ! -!SystemDictionary methodsFor: 'retrieving' stamp: 'RNG 6/8/2020 23:50:24' prior: 16921665! - allMethodsInCategory: category - | aCollection | - aCollection := SortedCollection new. - self allBehaviorsDo: [ :x | - (x organization listAtCategoryNamed: category) do: [ :sel | - aCollection add: (MethodReference class: x method: sel)]]. - ^aCollection! ! -!SystemDictionary methodsFor: 'retrieving' stamp: 'RNG 6/8/2020 23:56:43' prior: 50366121! - allMethodsSourceStringMatching: aString - "Answer a sorted Collection of all the methods that contain, in source code, aString as a substring. - Search the class comments also. - Argument might include $*, that matches any subsequence. - For example, try: - ensure:*[*close*] - " - | list classCount adder | - list _ Set new. - adder _ [ :mrClass :mrSel | - list add: (MethodReference class: mrClass selector: mrSel) ]. - 'Searching all source code...' - displayProgressAt: Sensor mousePoint - from: 0 - to: Smalltalk classNames size - during: [ :barBlock | - classCount _ 0. - Smalltalk allClassesDo: [ :class | - barBlock value: (classCount _ classCount + 1). - (Array - with: class - with: class class) do: [ :cl | - cl selectorsDo: [ :sel | - (aString match: (cl sourceCodeAt: sel)) ifTrue: [ - adder - value: cl - value: sel ]]. - - (aString match: cl organization classComment asString) ifTrue: [ - adder - value: cl - value: #Comment ]]]]. - ^ list asArray sort.! ! -!SystemDictionary methodsFor: 'retrieving' stamp: 'RNG 6/8/2020 23:56:34' prior: 50366157! - allMethodsWithSourceString: aString matchCase: caseSensitive - "Answer a sorted Collection of all the methods that contain, in source code, aString as a substring. Search the class comments also" - | list classCount adder | - list _ Set new. - adder _ [ :mrClass :mrSel | - list add: (MethodReference class: mrClass selector: mrSel) ]. - 'Searching all source code...' - displayProgressAt: Sensor mousePoint - from: 0 - to: Smalltalk classNames size - during: [ :barBlock | - classCount _ 0. - Smalltalk allClassesDo: [ :class | - barBlock value: (classCount _ classCount + 1). - (Array - with: class - with: class class) do: [ :cl | - cl selectorsDo: [ :sel | - ((cl sourceCodeAt: sel) - findString: aString - startingAt: 1 - caseSensitive: caseSensitive) > 0 ifTrue: [ - adder - value: cl - value: sel ]]. - (cl organization classComment asString - findString: aString - startingAt: 1 - caseSensitive: caseSensitive) > 0 ifTrue: [ - adder - value: cl - value: #Comment ]]]]. - ^ list asArray sort.! ! -!SystemDictionary methodsFor: 'retrieving' stamp: 'RNG 6/8/2020 23:57:01' prior: 50504641! - allMethodsWithString: aString - "Answer a sorted Collection of all the methods that contain, in a string literal, aString as a substring. 2/1/96 sw. The search is case-sensitive, and does not dive into complex literals, confining itself to string constants. - 5/2/96 sw: fixed so that duplicate occurrences of aString in the same method don't result in duplicated entries in the browser" - | aStringSize list | - aStringSize _ aString size. - list _ Set new. - self allBehaviorsDo: [ :class | - class selectorsDo: [ :sel | - (class compiledMethodAt: sel) literalsDo: [ :aLiteral | - ((aLiteral isMemberOf: String) and: [ aLiteral size >= aStringSize ]) ifTrue: [ - (aLiteral includesSubString: aString) ifTrue: [ - list add: (MethodReference class: class selector: sel) ]]]]]. - ^ list asArray sort! ! -!SystemDictionary methodsFor: 'retrieving' stamp: 'RNG 6/8/2020 23:57:40' prior: 16921865! - allSelect: aBlock - "Answer a SortedCollection of each method that, when used as the block - argument to aBlock, gives a true result." - | aCollection | - aCollection _ SortedCollection new. - self allBehaviorsDo: [ :class | - class selectorsDo: [ :sel | - (aBlock value: (class compiledMethodAt: sel)) ifTrue: [ - aCollection add: (MethodReference class: class selector: sel) - ]]]. - ^ aCollection! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'RNG 6/8/2020 23:58:01' prior: 16924016! - browseAllStoresInto: instVarName from: aClass - "Create and schedule a Message Set browser for all the receiver's methods - or any methods of a subclass/superclass that refer to the instance variable name." - - "self new browseAllStoresInto: 'contents' from: Collection." - - | coll | - coll _ OrderedCollection new. - aClass withAllSubAndSuperclassesDo: [:class | - (class whichSelectorsStoreInto: instVarName) do: [:sel | - coll add: (MethodReference class: class selector: sel)]]. - ^ self - browseMessageList: coll - name: 'Stores into ' , instVarName - autoSelect: instVarName! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'RNG 6/8/2020 23:59:45' prior: 16924061! - browseClassCommentsWithString: aString - "Smalltalk browseClassCommentsWithString: 'my instances' " - "Launch a message list browser on all class comments containing aString as a substring." - | caseSensitive suffix list | - suffix _ (caseSensitive _ Sensor shiftPressed) - ifTrue: [ ' (case-sensitive)' ] - ifFalse: [ ' (use shift for case-sensitive)' ]. - list _ Set new. - Smalltalk allClassesDo: [ :class | - (class organization classComment asString - findString: aString - startingAt: 1 - caseSensitive: caseSensitive) > 0 ifTrue: [ - list add: (MethodReference class: class selector: #Comment) ]]. - ^ self - browseMessageList: list asArray sort - name: 'Class comments containing ', aString printString, suffix - autoSelect: aString.! ! -!CodePackage methodsFor: 'testing' stamp: 'RNG 6/8/2020 23:54:20' prior: 16810396! - referenceForMethod: aSymbol ofClass: aClass - ^ MethodReference class: aClass selector: aSymbol! ! -!CodeWindow methodsFor: 'menu commands' stamp: 'RNG 6/8/2020 23:54:34' prior: 16813521! - openSingleMessageBrowser - | msgName mr | - "Create and schedule a message list browser populated only by the currently selected message" - - (msgName _ model selectedMessageName) ifNil: [^ self]. - - mr _ MethodReference - class: model selectedClassOrMetaClass - selector: msgName. - - Smalltalk - browseMessageList: (Array with: mr) - name: mr stringVersion - autoSelect: nil! ! -!MethodReference methodsFor: 'setting' stamp: 'RNG 6/9/2020 00:03:27' prior: 16873098! - setClass: aClass methodSymbol: methodSym stringVersion: aString - - self - setClassSymbol: aClass theNonMetaClass name - classIsMeta: aClass isMeta - methodSymbol: methodSym - stringVersion: aString! ! -!MethodReference methodsFor: 'setting' stamp: 'RNG 6/9/2020 00:04:05' prior: 16873116! - setStandardClass: aClass methodSymbol: methodSym - - self - setClass: aClass - methodSymbol: methodSym - stringVersion: aClass name , ' ' , methodSym! ! -!ChangeSelector methodsFor: 'rename senders - private' stamp: 'RNG 6/9/2020 00:08:19' prior: 50438686! - renameSendersIn: aMethod - - | newSource rangesToNewStrings | - - rangesToNewStrings := self rangesToKeywordsOf: aMethod. - newSource := aMethod sourceCode copyReplacing: rangesToNewStrings. - aMethod methodClass compile: newSource. - - changes add: (MethodReference method: aMethod)! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4230-MethodReferenceInstantiationRefactoring-NahuelGarbezza-2020Jun08-23h50m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4226] on 22 June 2020 at 4:18:36 pm'! - -ParseNode subclass: #BacktickNode - instanceVariableNames: 'sourceCode expression literalNode parser range' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! - -!classDefinition: #BacktickNode category: #'Compiler-ParseNodes' stamp: 'Install-4231-BacktickParseNode-HernanWilkinson-2020Jun18-09h33m-HAW.001.cs.st 6/25/2020 16:07:32'! -ParseNode subclass: #BacktickNode - instanceVariableNames: 'sourceCode expression literalNode parser range' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-ParseNodes'! -!Parser methodsFor: 'as yet unclassified' stamp: 'HAW 6/22/2020 16:05:36'! - addToSentInLiterals: aSymbol - - sentInLiterals add: aSymbol ! ! -!Parser methodsFor: 'as yet unclassified' stamp: 'HAW 6/22/2020 16:15:27'! - backtickExpression - - | start range | - - start := self startOfNextToken. - self advance. - self expression ifFalse: [^self expected: 'expression']. - (self match: #backtick) ifFalse: [^self expected: 'backtick']. - range := start to: prevEnd. - - parseNode := BacktickNode - expression: parseNode - source: (source contents copyFrom: range first+1 to: range last-1) - parser: self - range: range. - - encoder noteSourceRange: range forNode: parseNode.! ! -!BacktickNode methodsFor: 'initialization' stamp: 'HAW 6/22/2020 16:07:07'! - addSymbolsOfExpressionToParser - - expression nodesDo: [ :aNode | - aNode isMessageNode ifTrue: [ parser addToSentInLiterals: aNode selector key ]. - aNode isLiteralNode ifTrue: [ (aNode literalValue isSymbol and: [ aNode literalValue ~= Scanner doItSelector ]) - ifTrue: [ parser addToSentInLiterals: aNode literalValue ]]]! ! -!BacktickNode methodsFor: 'initialization' stamp: 'HAW 6/22/2020 16:06:52'! - initializeExpression: anExpression source: aSourceCode parser: aParser range: aRange - - expression := anExpression. - sourceCode := aSourceCode. - parser := aParser. - range := aRange. - - self addSymbolsOfExpressionToParser.! ! -!BacktickNode methodsFor: 'literal node' stamp: 'HAW 6/21/2020 17:09:55'! - evaluateBacktickSourceCode - - ^[[[Compiler evaluate: sourceCode ] - on: SyntaxErrorNotification - do: [ :ex | parser notify: 'Can not compile: ', ex errorMessage at: range first ]] - on: UndeclaredVariableReference - do: [ :ex | parser notify: 'Can not compile: Variable ''', ex varName, ''' is not declared' at: range first ]] - on: Error - do: [ :ex | parser notify: 'Can not evaluate code: ', ex description at: range first ].! ! -!BacktickNode methodsFor: 'literal node' stamp: 'HAW 6/21/2020 17:09:36'! - initializeLiteralNode - - | backtickValue | - - backtickValue := self evaluateBacktickSourceCode. - literalNode := parser encoder encodeLiteral: backtickValue range: range - -! ! -!BacktickNode methodsFor: 'literal node' stamp: 'HAW 6/22/2020 15:22:48'! - literalNode - - "The literalNode is initialize if really needed. There are situations when only the method node of a compiled method is needed - and therefore the literal generated for the backtick is not necessary. - The literal is needed when compiling the source code and sadly, when debugging because the debugger needs to regenerate - the code for the temp bindings and the relationship between the bytecodes and the source ranges of the nodes. - - If some message of the backtick source code has changed since the time the method was compiled, the resulting literal - could be different to the one generated when the method was originally compiled. - The change could include signaling an exception. That could happen while debuggin. That would mean that the backtick - code is not compliant with what currently should happen, so although it is a bothering solution, it is the more correct one - since it shows the difference - Hernan" - - literalNode ifNil: [ self initializeLiteralNode ]. - ^literalNode! ! -!BacktickNode methodsFor: 'visiting' stamp: 'HAW 6/21/2020 13:20:00' overrides: 16884650! - accept: aVisitor - - aVisitor visitBacktickNode: self. - ! ! -!BacktickNode methodsFor: 'visiting' stamp: 'HAW 6/21/2020 13:25:36'! -visitExpressionWith: aVisitor - - expression accept: aVisitor! ! -!BacktickNode methodsFor: 'visiting' stamp: 'HAW 6/22/2020 15:13:14'! - visitLiteralWith: aVisitor - - "Remember that creating the literal can signal an exception if the message sent in the expression - has changed since the method was compiled - Hernan" - self literalNode accept: aVisitor ! ! -!BacktickNode methodsFor: 'printing' stamp: 'HAW 6/22/2020 10:34:24' overrides: 16884940! - printOn: aStream indent: level - - aStream nextPut: $`. - expression printOn: aStream indent: level. - aStream nextPut: $`.! ! -!BacktickNode methodsFor: 'code generation' stamp: 'HAW 6/21/2020 13:27:32'! - analyseTempsWithin: scopeBlock rootNode: rootNode assignmentPools: assignmentPools - - ^self! ! -!BacktickNode methodsFor: 'code generation' stamp: 'HAW 6/21/2020 17:10:23'! - emitCodeForValue: aParseStack encoder: anEncoder - - ^self literalNode emitCodeForValue: aParseStack encoder: anEncoder ! ! -!BacktickNode methodsFor: 'code generation' stamp: 'HAW 6/21/2020 17:10:44'! - sizeCodeForValue: anEncoder - - ^self literalNode sizeCodeForValue: anEncoder ! ! -!BacktickNode class methodsFor: 'instance creation' stamp: 'HAW 6/22/2020 16:07:16'! - expression: anExpression source: aSourceCode parser: aParser range: aRange - - self assertNodesIn: anExpression canBeReferencedInsideBacktickUsing: aParser startingAt: aRange first. - - ^self new initializeExpression: anExpression source: aSourceCode parser: aParser range: aRange ! ! -!BacktickNode class methodsFor: 'assertions' stamp: 'HAW 6/22/2020 16:03:49'! - assertNodesIn: anExpression canBeReferencedInsideBacktickUsing: aParser startingAt: aPosition - - ^ anExpression nodesDo: [ :aNode | - (self canNotBeReferencedInsideBacktick: aNode) ifTrue: [ - aParser - notify: (self canNotReferencePseudoVarInsideBacktickErrorDescriptionFor: aNode key) - at: aPosition ]]! ! -!BacktickNode class methodsFor: 'assertions' stamp: 'HAW 6/22/2020 15:59:58'! - canNotBeReferencedInsideBacktick: aNode - - ^ aNode isSelfPseudoVariable - or: [ aNode isSuperPseudoVariable - or: [ aNode isThisContextPseudoVariable ]]! ! -!BacktickNode class methodsFor: 'assertions' stamp: 'HAW 6/22/2020 15:59:41'! - canNotReferencePseudoVarInsideBacktickErrorDescriptionFor: pseudoVariable - - ^ 'Can not reference ', pseudoVariable, ' inside backtick'! ! -!ParseNodeVisitor methodsFor: 'visiting' stamp: 'HAW 6/22/2020 15:11:41'! - visitBacktickNode: aBacktickNode - - "By default only visits the expresion of the backtick and not its literal. - If visiting the literal is necessary, you can use the message visitLiteralWith: but - remember that the litercal can be nil if the expresion was not evaluated - Hernan" - - aBacktickNode visitExpressionWith: self.! ! -!ParseNodeEnumerator methodsFor: 'visiting' stamp: 'HAW 6/21/2020 12:43:54' overrides: 50525808! - visitBacktickNode: aBacktickNode - - (theSelectBlock isNil or: [theSelectBlock value: aBacktickNode]) ifFalse: - [^nil]. - theBlock value: aBacktickNode. - ^super visitBacktickNode: aBacktickNode! ! -!Compiler methodsFor: 'private' stamp: 'HAW 6/22/2020 16:10:03' prior: 50512931! - translate: aStream noPattern: noPattern doIt: doIt ifFail: failBlock - - ^self parser - parse: aStream - class: class - category: category - noPattern: noPattern - doIt: doIt - context: context - notifying: requestor - ifFail: [^failBlock value]! ! -!Scanner methodsFor: 'expression types - private' stamp: 'HAW 8/15/2018 19:53:35' prior: 50409824! - skipDelimitersAndBacktickIfNecessary - - [self skipDelimiters. - self isBacktickAndShouldIgnoreIt ] whileTrue: [self step]. ! ! -!Scanner methodsFor: 'expression types' stamp: 'HAW 6/22/2020 16:11:44' prior: 50409879! - scanToken - - "Skip delimiters fast, there almost always is one." - self skipDelimiters. - - mark := source position - 1. - (tokenType at: 1) = $x "x as first letter" - ifTrue: [self perform: tokenType "means perform to compute token & type"] - ifFalse: [token := self step asSymbol "else just unique the first char"]. - ^token! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'HAW 6/22/2020 16:08:32' prior: 50410257! - xBacktick - - token := $` asSymbol. - tokenType := #backtick. - self step.! ! -!Scanner methodsFor: 'initialization' stamp: 'HAW 6/22/2020 16:10:19' prior: 50409831! - initScanner - - buffer := WriteStream on: (String new: 40). - typeTable := Scanner typeTable. - isForTokenization := false. - sentInLiterals := Set new. - ! ! -!Scanner methodsFor: 'initialization' stamp: 'HAW 6/22/2020 16:10:23' prior: 50409840! - initScannerForTokenization - "Don't raise xIllegal when enocuntering an _" - "Simpler implementation for Cuis" - isForTokenization _ true. - ! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 6/22/2020 16:16:06' prior: 50409507! - primaryExpression - - hereType == #word - ifTrue: [ - parseNode _ self variable. - - " - (parseNode isUndefTemp and: [self interactive] and: [ - ((requestor isKindOf: Editor) or: [ requestor is: #Morph ])]) - " - "If the requestor is of an exotic kind (like a telnet server) we might not be - allowed to open a PupUpMenu for querying the user" - - (parseNode isUndefTemp and: [ self interactive ]) - ifTrue: [self queryUndefined]. - parseNode nowHasRef. - ^ true]. - hereType == #leftBracket - ifTrue: [ - self advance. - self blockExpression. - ^true]. - hereType == #leftBrace - ifTrue: [ - self braceExpression. - ^true]. - hereType == #leftParenthesis - ifTrue: [ - self advance. - self expression ifFalse: [^self expected: 'expression']. - (self match: #rightParenthesis) - ifFalse: [^self expected: 'right parenthesis']. - ^true]. - (hereType == #string or: [hereType == #number or: [hereType == #literal]]) - ifTrue: [ - parseNode := self advanceWithRangeDo: [ :lexema :range | encoder encodeLiteral: lexema range: range ]. - ^true]. - (here == #- and: [tokenType == #number]) - ifTrue: [ - self advanceWithRangeDo: [ :minusChar :minusRange | - self advanceWithRangeDo: [ :number :numberRange | - parseNode := encoder encodeLiteral: number negated range: (minusRange first to: numberRange last)]]. - ^true]. - - hereType == #backtick - ifTrue: [ - self backtickExpression. - ^true ]. - - ^false! ! - -BacktickNode class removeSelector: #addSymbolsOf:to:! - -BacktickNode class removeSelector: #of:source:! - -BacktickNode class removeSelector: #expression:literal:! - -BacktickNode class removeSelector: #expression:source:encoder:range:! - -BacktickNode class removeSelector: #assertNodesIn:canBeReferencedInsideBacktickStartingAt:! - -BacktickNode class removeSelector: #of:! - -BacktickNode removeSelector: #initializeExpression:literal:! - -BacktickNode removeSelector: #addSymbolsOf:to:! - -BacktickNode removeSelector: #initializeLiteral! - -BacktickNode removeSelector: #initializeOf:! - -BacktickNode removeSelector: #literal! - -BacktickNode removeSelector: #assertWasCompiledNotIgnoringBacktick! - -BacktickNode removeSelector: #expression! - -BacktickNode removeSelector: #initializeOf:source:! - -BacktickNode removeSelector: #initializeExpression:source:encoder:range:! - -Parser class removeSelector: #canNotReferencePseudoVarInsideBacktickErrorDescriptionFor:! - -Parser removeSelector: #compileBacktickCodeHandlingErrors:! - -Parser removeSelector: #canNotBeReferencedInsideBacktick:! - -Parser removeSelector: #compileBacktickCodeHandlingErrors:at:! - -Parser removeSelector: #evaluateBacktickCode:handlingErrorsAt:! - -Scanner removeSelector: #compileBacktickCodeHandlingErrors! - -!methodRemoval: Scanner #compileBacktickCodeHandlingErrors stamp: 'Install-4231-BacktickParseNode-HernanWilkinson-2020Jun18-09h33m-HAW.001.cs.st 6/25/2020 16:07:32'! -compileBacktickCodeHandlingErrors - - [[[self compileBacktickCode ] - on: SyntaxErrorNotification - do: [ :ex | self notify: 'Can not compile: ', ex errorMessage at: mark]] - on: UndeclaredVariableReference - do: [ :ex | self notify: 'Can not compile: Variable ''', ex varName, ''' is not declared' at: mark ]] - on: Error - do: [ :ex | self notify: 'Can not evaluate code: ', ex description at: mark ]. - - tokenType _ #literal! - -Scanner removeSelector: #compileBacktickCode:! - -Scanner removeSelector: #compileBacktickCode! - -!methodRemoval: Scanner #compileBacktickCode stamp: 'Install-4231-BacktickParseNode-HernanWilkinson-2020Jun18-09h33m-HAW.001.cs.st 6/25/2020 16:07:32'! -compileBacktickCode - - | compiler method methodNode | - - compiler _ Compiler new. - methodNode _ compiler compileNoPattern: buffer contents in: UndefinedObject context: nil notifying: nil ifFail: []. - self assertNodesIn: methodNode canBeReferencedInsideBacktickUsing: compiler. - method _ methodNode generate. - - "Grab all messages sent while evaluating literal, so the main method will be shown as senders of them" - sentInLiterals addAll: method messages. - method literalsDo: [ :literal | literal isSymbol ifTrue: [ literal = self class doItSelector ifFalse: [sentInLiterals add: literal ]]]. - - "Evaluate now." - token _ nil withArgs: #() executeMethod: method ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4231-BacktickParseNode-HernanWilkinson-2020Jun18-09h33m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4226] on 22 June 2020 at 4:38:20 pm'! - -Object subclass: #Scanner - instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable isForTokenization sentInLiterals ignoreBacktick ' - classVariableNames: 'DoItCharacter TypeTable ' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #Scanner category: #'Compiler-Kernel' stamp: 'Install-4232-BacktickParseNode-HernanWilkinson-2020Jun22-16h27m-HAW.001.cs.st 6/25/2020 16:07:32'! -Object subclass: #Scanner - instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable isForTokenization sentInLiterals ignoreBacktick' - classVariableNames: 'DoItCharacter TypeTable' - poolDictionaries: '' - category: 'Compiler-Kernel'! -!ParseNode methodsFor: 'testing' stamp: 'HAW 6/22/2020 16:35:06'! - isBacktickNode - - ^false! ! -!BacktickNode methodsFor: 'expression' stamp: 'HAW 6/22/2020 16:34:36'! - expression - - ^expression! ! -!BacktickNode methodsFor: 'testing' stamp: 'HAW 6/22/2020 16:33:53' overrides: 50507191! - equivalentTo: aParseNode - - ^ aParseNode isBacktickNode - and: [ expression equivalentTo: aParseNode expression ]! ! -!BacktickNode methodsFor: 'testing' stamp: 'HAW 6/22/2020 16:34:24' overrides: 50526048! - isBacktickNode - - ^true! ! - -Scanner removeSelector: #skipDelimitersAndBacktickIfNecessary! - -!methodRemoval: Scanner #skipDelimitersAndBacktickIfNecessary stamp: 'Install-4232-BacktickParseNode-HernanWilkinson-2020Jun22-16h27m-HAW.001.cs.st 6/25/2020 16:07:32'! -skipDelimitersAndBacktickIfNecessary - - [self skipDelimiters. - self isBacktickAndShouldIgnoreIt ] whileTrue: [self step]. ! - -Scanner removeSelector: #isBacktickAndShouldIgnoreIt! - -!methodRemoval: Scanner #isBacktickAndShouldIgnoreIt stamp: 'Install-4232-BacktickParseNode-HernanWilkinson-2020Jun22-16h27m-HAW.001.cs.st 6/25/2020 16:07:32'! -isBacktickAndShouldIgnoreIt - - "I compare with true because there are many ways to initialize the scanner and ingoreBacktick could be nil - Hernan" - ^ ignoreBacktick == true and: [tokenType = #xBacktick]! - -Scanner removeSelector: #ignoreBacktick:! - -!methodRemoval: Scanner #ignoreBacktick: stamp: 'Install-4232-BacktickParseNode-HernanWilkinson-2020Jun22-16h27m-HAW.001.cs.st 6/25/2020 16:07:32'! -ignoreBacktick: aBoolean - - ignoreBacktick := aBoolean ! - -Object subclass: #Scanner - instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable isForTokenization sentInLiterals' - classVariableNames: 'DoItCharacter TypeTable' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #Scanner category: #'Compiler-Kernel' stamp: 'Install-4232-BacktickParseNode-HernanWilkinson-2020Jun22-16h27m-HAW.001.cs.st 6/25/2020 16:07:32'! -Object subclass: #Scanner - instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable isForTokenization sentInLiterals' - classVariableNames: 'DoItCharacter TypeTable' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4232-BacktickParseNode-HernanWilkinson-2020Jun22-16h27m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4230] on 22 June 2020 at 4:43:45 pm'! - -Scanner removeSelector: #canNotBeReferencedInsideBacktick:! - -!methodRemoval: Scanner #canNotBeReferencedInsideBacktick: stamp: 'Install-4233-BacktickParseNode-HernanWilkinson-2020Jun22-16h19m-HAW.001.cs.st 6/25/2020 16:07:32'! -canNotBeReferencedInsideBacktick: aNode - - ^ aNode isSelfPseudoVariable - or: [ aNode isSuperPseudoVariable - or: [ aNode isThisContextPseudoVariable ]]! - -Scanner removeSelector: #assertNodesIn:canBeReferencedInsideBacktickUsing:! - -!methodRemoval: Scanner #assertNodesIn:canBeReferencedInsideBacktickUsing: stamp: 'Install-4233-BacktickParseNode-HernanWilkinson-2020Jun22-16h19m-HAW.001.cs.st 6/25/2020 16:07:32'! -assertNodesIn: methodNode canBeReferencedInsideBacktickUsing: compiler - - ^ methodNode nodesDo: [ :aNode | - (self canNotBeReferencedInsideBacktick: aNode) ifTrue: [ - compiler notify: (self class canNotReferencePseudoVarInsideBacktickErrorDescriptionFor: aNode key) ]]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4233-BacktickParseNode-HernanWilkinson-2020Jun22-16h19m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4233] on 23 June 2020 at 4:11:05 pm'! - -Scanner class removeSelector: #canNotReferencePseudoVarInsideBacktickErrorDescriptionFor:! - -!methodRemoval: Scanner class #canNotReferencePseudoVarInsideBacktickErrorDescriptionFor: stamp: 'Install-4234-BacktickParseNode-HernanWilkinson-2020Jun23-15h40m-HAW.001.cs.st 6/25/2020 16:07:32'! -canNotReferencePseudoVarInsideBacktickErrorDescriptionFor: pseudoVariable - - ^ 'Can not reference ', pseudoVariable, ' inside backtick'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4234-BacktickParseNode-HernanWilkinson-2020Jun23-15h40m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4233] on 23 June 2020 at 6:59:08 pm'! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'HAW 6/23/2020 18:58:46'! - fileOutOrganizationOn: aFileStream excludingExtensions: shouldExcludeExtensions - "File a description of the receiver's organization on aFileStream. - Excludes extentions categories if shouldExcludeExtensions" - - | organizationString | - - aFileStream newLine; nextPut: $!!. - aFileStream nextChunkPut: self name, ' reorganize'; newLine. - organizationString := String streamContents: [ :aStream | - self organization printOn: aStream excludingExtensions: shouldExcludeExtensions ]. - aFileStream nextChunkPut: organizationString; newLine! ! -!Categorizer methodsFor: 'printing' stamp: 'HAW 6/23/2020 18:35:31'! - printCategory: aCategory at: aCategoryIndex with: aStartElementIndex on: aStream - - | elementIndex | - - elementIndex := aStartElementIndex. - aStream nextPut: $(. - aCategory printOn: aStream. - - [elementIndex <= (categoryStops at: aCategoryIndex)] whileTrue: [ - aStream space; nextPutAll: (elementArray at: elementIndex). - elementIndex _ elementIndex + 1]. - - aStream nextPut: $); newLine. - - ^elementIndex ! ! -!Categorizer methodsFor: 'printing' stamp: 'HAW 6/23/2020 18:57:52'! -printOn: aStream excludingExtensions: shouldExcludeExtensions - "Refer to the comment in Object|printOn:." - - | elementIndex | - - elementIndex _ 1. - 1 to: categoryArray size do: [ :categoryIndex | | category | - category _ (categoryArray at: categoryIndex) asString. - (shouldExcludeExtensions and: [ self isPackageCategoryExtension: category ]) ifFalse: [ - elementIndex _ self printCategory: category at: categoryIndex with: elementIndex on: aStream.]]! ! -!Categorizer methodsFor: 'testing' stamp: 'HAW 6/23/2020 18:55:22'! - isPackageCategoryExtension: aCategory - - ^aCategory beginsWith: '*'! ! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'HAW 6/23/2020 18:58:23' prior: 16806784! - fileOutOrganizationOn: aFileStream - "File a description of the receiver's organization on aFileStream." - - self fileOutOrganizationOn: aFileStream excludingExtensions: false! ! -!ClassDescription class methodsFor: 'utilities' stamp: 'HAW 6/23/2020 18:55:22' prior: 50426703! - printPackageExtensionCategories - "In a bare image, without any packages, should print nothing - ClassDescription printPackageExtensionCategories - ClassOrganizer allInstancesDo: [:co | co removeEmptyCategories]. - " - ClassDescription allSubInstances do: [ :class | | classOrganization | - classOrganization _ class organization. - classOrganization categories do: [ :category | - (classOrganization isPackageCategoryExtension: category) ifTrue: [ - {class. category} print ]]].! ! -!Categorizer methodsFor: 'printing' stamp: 'HAW 6/23/2020 18:57:52' prior: 16795740 overrides: 50508084! - printOn: aStream - "Refer to the comment in Object|printOn:." - - self printOn: aStream excludingExtensions: false! ! -!ChangeSet methodsFor: 'fileIn/Out' stamp: 'HAW 6/23/2020 18:58:23' prior: 50482145! - fileOutPSFor: class on: stream - "Write out removals and initialization for this class." - - | dict classRecord currentDef | - classRecord _ changeRecords at: class name ifAbsent: [^ self]. - dict _ classRecord methodChangeTypes. - ((dict includesKey: #initialize) and: [ class isMeta ]) ifTrue: [ - stream nextChunkPut: class soleInstance name, ' initialize'; newLine]. - ((classRecord includesChangeType: #change) - and: [(currentDef _ class definition) ~= (self fatDefForClass: class)]) ifTrue: [ - stream - nextPut: $!!; - nextChunkPut: class definitionPreambleWithoutStamp; newLine; - nextChunkPut: currentDef; newLine]. - (classRecord includesChangeType: #reorganize) ifTrue: [ - class fileOutOrganizationOn: stream excludingExtensions: true. - stream newLine]! ! - -Categorizer removeSelector: #printOn:excludingExtentions:! - -Categorizer removeSelector: #isPackageCategoryExtention:! - -ClassDescription removeSelector: #fileOutOrganizationOn:excludingExtentions:! - -ClassDescription removeSelector: #organizationExcludingExtentions:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4235-ExcludeExtensionCategories-HernanWilkinson-2020Jun23-16h11m-HAW.003.cs.st----! - -'From Cuis 5.0 [latest update: #4235] on 24 June 2020 at 3:55:33 pm'! -!LargePositiveInteger methodsFor: 'bit manipulation' stamp: 'jmv 6/24/2020 11:23:30' prior: 16862407 overrides: 16859251! - bitReverse: highBit - "This implementation is faster than super" - - | digitSize reversed adjust | - highBit < self highBit ifTrue: [ self error: 'Not enough bits.' ]. - digitSize := highBit + 7 // 8. - reversed := self class new: digitSize. - 1 to: self digitLength do: [:i | - reversed digitAt: digitSize + 1 - i put: (self digitAt: i) byteReversed]. - adjust _ highBit - (digitSize * 8). - ^adjust = 0 - ifTrue: [reversed normalize] - ifFalse: [reversed bitShift: adjust]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4236-bitReverse-fix-JuanVuletich-2020Jun24-15h55m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4236] on 24 June 2020 at 4:08:25 pm'! - -FileEntry removeSelector: #baseDirectory! - -!methodRemoval: FileEntry #baseDirectory stamp: 'Install-4237-cleanup-JuanVuletich-2020Jun24-16h07m-jmv.001.cs.st 6/25/2020 16:07:32'! -baseDirectory - "The directory this file is located in" - ^ DirectoryEntry - withPathComponents: self pathComponents allButLast - drive: nil.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4237-cleanup-JuanVuletich-2020Jun24-16h07m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4236] on 24 June 2020 at 4:10:29 pm'! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'jmv 6/22/2020 16:07:44' prior: 50505765! - allAccessesTo: instVarName - - | references instVarIndex | - - instVarIndex _ self indexOfInstanceVariable: instVarName. - references _ SortedCollection sortBlock: [ :left :right | left stringVersion <= right stringVersion ]. - - self withAllSubAndSuperclassesDo: [:class | class addReferencesOf: instVarName at: instVarIndex to: references ]. - - ^ references ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4238-ivarAccessTool-fix-JuanVuletich-2020Jun24-16h08m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4230] on 23 June 2020 at 12:29:05 pm'! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jmv 6/23/2020 10:48:01' prior: 50378809! - handleUserInterrupt - Utilities reportCPUandRAM. - Preferences cmdDotEnabled ifTrue: [ - [ UISupervisor userInterrupt ] fork]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4239-DebugAidsOnBreak-JuanVuletich-2020Jun23-12h28m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4219] on 15 June 2020 at 8:08:32 pm'! - -Object subclass: #CharacterScanner - instanceVariableNames: 'destX lastIndex xTable destY stopConditions text alignment leftMargin rightMargin font line runStopIndex spaceCount spaceWidth tabWidth kern paragraphStyle defaultFont lastTabX lastTabIndex tabCount ' - classVariableNames: 'DefaultStopConditions StopConditionsWithPaddedSpace StopConditionsWithSpace ' - poolDictionaries: '' - category: 'Graphics-Text'! - -!classDefinition: #CharacterScanner category: #'Graphics-Text' stamp: 'Install-4240-TabHandling-JuanVuletich-2020Jun15-19h22m-jmv.001.cs.st 6/25/2020 16:07:32'! -Object subclass: #CharacterScanner - instanceVariableNames: 'destX lastIndex xTable destY stopConditions text alignment leftMargin rightMargin font line runStopIndex spaceCount spaceWidth tabWidth kern paragraphStyle defaultFont lastTabX lastTabIndex tabCount' - classVariableNames: 'DefaultStopConditions StopConditionsWithPaddedSpace StopConditionsWithSpace' - poolDictionaries: '' - category: 'Graphics-Text'! -!Integer methodsFor: 'benchmarks' stamp: 'jmv 6/15/2020 20:07:36' prior: 50381978! - tinyBenchmarks - "Report the results of running the two tiny Squeak benchmarks. - ar 9/10/1999: Adjusted to run at least 1 sec to get more stable results - - - Performance of early 80's experimental Smalltalk systems. - Estimations from - http://wiki.c2.com/?GreenBook - http://www.wirfs-brock.com/allen/things/smalltalk-things/tektronix-smalltalk-document-archive/1982-qtr4-magnolia-perf-graph.pdf - http://www.wirfs-brock.com/allen/things/smalltalk-things/tektronix-smalltalk-document-archive/1983-Magnolia-st-perf.pdf - - DEC PDP-11/23 5,000 bytecodes/sec (Green Book, p.128) - Apple 5MHz 68000 9,000 to 11,000 bytecodes/sec (Green Book, p.187, awb) 5000 clocks/bytecode - VAX-11/780 5MHz C HP Smalltalk 5,000 to 25,000 bytecodes/sec (Green Book, p.235) 330 clocks/bytecode - VAX-11/780 5MHz C Berkeley Smalltalk 12,000 to 23000 bytecodes/sec (Green Book, p.203, awb) 300 clocks/bytecode - DEC VAX-11/780 5MHz assembly 20,000 to 25,000 bytecodes/sec (Green Book, p.149, awb) 200 clocks/bytecode - Xerox Dolphin µcode 20,000 to 40,000 bytecodes/sec (Green Book, p.44, p.203, awb) - TEK Magnolia 10MHz 68000 50,000 bytecodes/sec (awb) 200 clocks/bytecode - Xerox Dorado 14MHz µcode 400,000 to 500,000 bytecodes/sec (G.B., p.44, p.203, awb) 28 clocks/bytecode - - - 0 tinyBenchmarks - - 292 MHz G3 Mac: 22,727,272 bytecodes/sec; 984,169 sends/sec 12.8 clocks/bytecode - 400 MHz PII/Win98: 18,028,169 bytecodes/sec; 1,081,272 sends/sec 22.2 clocks/bytecode - - 900MHz RasPi2 - StackVM: 37,758,112 bytecodes/sec; 2,412,667 sends/sec 16.2 clocks/bytecode - 900MHz RasPi2- CogSSpur: 157,441,574 bytecodes/sec; 10,946,039 sends/sec 5.7 clocks/bytecode - - 1GHz C.H.I.P. (*1) - StackVM: 55,315,471 bytecodes/sec; 3,348,667 sends/sec 18.1 clocks/bytecode - 1GHz C.H.I.P. (*1) - CogSpur: 253,716,551 bytecodes/sec; 16,853,816 sends/sec 3.9 clocks/bytecode - - 1.2GHz RasPi3B - StackSpur: 44,107,512 bytecodes/sec; 2,767,863 sends/sec 27.2 clocks/bytecode - 1.2GHz RasPi3B - CogSpur: 281,783,159 bytecodes/sec; 16,404,381 sends/sec 6.6 clocks/bytecode - - 1.66GHz Atom N450 - Cog: 244,274,809 bytecodes/sec; 28,795,277 sends/sec 6.8 clocks/bytecode - 1.66GHz Atom N450 - CogSpur: 469,724,770 bytecodes/sec; 30,754,699 sends/sec 3.5 clocks/bytecode - - 1.33GHz Atom 3735G - Cog: 326,114,649 bytecodes/sec; 34,985,976 sends/sec 4.1 clocks/bytecode - 1.33GHz Atom 3735G - CogSpur: 632,098,765 bytecodes/sec; 33,692,910 sends/sec 2.1 clocks/bytecode - - 1.5GHz AMD A4-5000 APU - Cog: 390,243,902 bytecodes/sec; 47,507,997 sends/sec 3.8 clocks/bytecode - 1.5GHz AMD A4-5000 APU - CogSpur: 675,907,590 bytecodes/sec; 40,669,724 sends/sec 2.2 clocks/bytecode - 1.5GHz AMD A4-5000 APU - CogSpur64: 659,368,963 bytecodes/sec; 50,338,916 sends/sec 2.2 clocks/bytecode - - 2.3GHz Tegra (*2) - StackVM: 258,847,320 bytecodes/sec; 13,014,759 sends/sec 8.9 clocks/bytecode - 2.3GHz Tegra (*2) - CogSpur: 1,083,024,854 bytecodes/sec; 64,289,750 sends/sec 2.1 clocks/bytecode - - 3.1GHz Core i3-2100 - Cog: 1,203,290,246 bytecodes/sec; 165,723,327 sends/sec 2.6 clocks/bytecode - 3.1GHz Core i3-2100 - CogSpur: 2,042,892,768 bytecodes/sec; 127,837,794 sends/sec 1.5 clocks/bytecode - - 2.70GHz Core i5-6400 -CogSpur64: 3,162,934,362 bytecodes/sec; 243,321,293 sends/sec 0.85 clocks/bytecode - - (*1) C.H.I.P. $9 Computer [Next Thing Co], Allwinner R8 Single-Core ARM Cortex-A8 - 1 GHz - (*2) ACER Chromebook CB5-311 - NVIDIA Tegra K1 Quad-Core ARM Cortex-A15 'r3' - 2.3 GHz - - It is interesting to note that Spur for the first time brings ARM hardware (RasPi and C.H.I.P.) into a 'Morphic is confortable and nice to use' level of performance. - " - | t1 t2 r n1 n2 | - n1 _ 1. - [ - t1 _ Time millisecondsToRun: [n1 benchmark]. - t1 < 1000] - whileTrue: [n1 _ n1 * 2]. "Note: #benchmark's runtime is about O(n)" - - n2 _ 28. - [ - t2 _ Time millisecondsToRun: [r _ n2 benchFib]. - t2 < 1000] - whileTrue: [n2 _ n2 + 1]. - "Note: #benchFib's runtime is about O(k^n), - where k is the golden number = (1 + 5 sqrt) / 2 = 1.618...." - - ^String streamContents: [ :strm | - (n1 * 500000 * 1000) // t1 withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixName; - nextPutAll: 'Bytecodes/second; ' ]. - (r * 1000) // t2 withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixName; - nextPutAll: 'Sends/second' ]]! ! -!CharacterScanner methodsFor: 'private' stamp: 'jmv 6/15/2020 19:49:07' prior: 50410471! - setFont - | attributes | - "Set the font and other emphasis. - In fact set actual ParagraphStyle (or nil), alignment, font and emphasis" - - self setActualFont: (text fontAt: lastIndex default: defaultFont). - attributes _ text attributesAt: lastIndex. - text - withAttributeValues: attributes - do: [ :familyNameInText :pointSizeInText :emphasisInText :colorInText :alignmentInText :characterStyleInText :paragraphStyleInText :backgroundColorInText | - colorInText ifNotNil: [ self textColor: colorInText ]. - self backgroundColor: backgroundColorInText. - alignment _ alignmentInText. - paragraphStyle _ paragraphStyleInText ]. - - "Hardcoded color for TextAction" - attributes do: [ :attribute | - attribute forTextActionInfoDo: [ :info | - self textColor: TextAction textActionColor ]]. - - "Install various parameters from the font." - spaceWidth _ font widthOf: Character space. - tabWidth _ (font widthOf: $0) * 4. - xTable _ font xTable! ! -!CharacterScanner methodsFor: 'stop conditions' stamp: 'jmv 6/15/2020 19:56:51' prior: 50410504! - tabDestX - "This is the basic method of adjusting destX for a tab." - - ^paragraphStyle - ifNotNil: [ - paragraphStyle - nextTabXFrom: destX - leftMargin: leftMargin - rightMargin: rightMargin ] - ifNil: [ - (tabCount+1 * tabWidth max: spaceWidth//3 + destX) min: rightMargin ].! ! -!CharacterScanner methodsFor: 'initialization' stamp: 'jmv 6/15/2020 19:32:08' prior: 50410519 overrides: 16896425! - initialize - tabCount _ destX _ destY _ leftMargin _ rightMargin _ 0.! ! -!CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'jmv 6/15/2020 19:31:56' prior: 50410525 overrides: 16802069! - tab - | currentX | - currentX _ self tabDestX. - lastSpaceOrTabWidth _ currentX - destX max: 0. - currentX >= characterPoint x - ifTrue: [ - lastCharacterWidth _ lastSpaceOrTabWidth. - ^ self crossedX ]. - destX _ currentX. - lastIndex _ lastIndex + 1. - tabCount _ tabCount + 1. - ^false! ! -!CharacterBlockScanner methodsFor: 'scanning' stamp: 'jmv 6/15/2020 19:31:39' prior: 50454796! - characterBlockAtPoint: aPoint index: index in: textLine - "This method is the Morphic characterBlock finder." - | runLength lineStop stopCondition | - line _ textLine. - rightMargin _ line rightMargin. - lastIndex _ line first. - tabCount _ 0. - self setFont. - self setStopConditions. - characterIndex _ index. "nil means scanning for point" - characterPoint _ aPoint. - (characterPoint isNil or: [ characterPoint y > line bottom ]) - ifTrue: [ characterPoint _ line bottomRight ]. - (text isEmpty or: [( characterPoint y < line top or: [ characterPoint x < line left ]) - or: [ characterIndex notNil and: [ characterIndex < line first ]]]) - ifTrue: [^ CharacterBlock - stringIndex: line first - text: text - topLeft: line leftMargin@line top - extent: 0 @ line lineHeight - textLine: line]. - destX _ leftMargin _ line leftMarginForAlignment: alignment. - destY _ line top. - runLength _ text runLengthFor: line first. - lineStop _ characterIndex "scanning for index" - ifNil: [ line last ]. "scanning for point" - runStopIndex _ lastIndex + (runLength - 1) min: lineStop. - lastCharacterWidth _ 0. - spaceCount _ 0. - - self placeEmbeddedObject. - [ - stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex - in: text string rightX: characterPoint x - stopConditions: stopConditions kern: font baseKern. - "see setStopConditions for stopping conditions for character block operations." - lastCharacterWidth _ specialWidth ifNil: [ font widthOf: (text at: lastIndex) ]. - (self perform: stopCondition) ifTrue: [ - ^characterIndex - ifNil: [ "Result for characterBlockAtPoint: " - CharacterBlock - stringIndex: lastIndex - text: text - topLeft: characterPoint x@line top - extent: lastCharacterWidth @ line lineHeight - textLine: line ] - ifNotNil: [ "Result for characterBlockForIndex: " - CharacterBlock - stringIndex: characterIndex - text: text - topLeft: characterPoint x@line top - extent: lastCharacterWidth @ line lineHeight - textLine: line ]] - ] repeat! ! -!CompositionScanner methodsFor: 'scanning' stamp: 'jmv 6/15/2020 19:33:05' prior: 50500584! - composeFrom: startIndex inRectangle: lineRectangle firstLine: firstLine leftSide: leftSide rightSide: rightSide - - "Answer an instance of TextLineInterval that represents the next line in the paragraph." - | runLength stopCondition xtraSpaceBefore spaceAfterParagraph | - - lastIndex _ startIndex. "scanning sets last index" - tabCount _ 0. - destY _ lineRectangle top. - lineHeight _ baseline _ 0. "Will be increased by setFont" - self setFont. - self setStopConditions. - - "Set up margins" - leftMargin _ lineRectangle left. - rightMargin _ lineRectangle right. - xtraSpaceBefore _ 0. - spaceAfterParagraph _ 0. - paragraphStyle ifNotNil: [ - leftSide ifTrue: [ - leftMargin _ leftMargin + - ((firstLine and: [ paragraphStyle isListStyle not ]) - ifTrue: [ paragraphStyle firstIndent ] - ifFalse: [ paragraphStyle restIndent ])]. - rightSide ifTrue: [ - rightMargin _ rightMargin - paragraphStyle rightIndent]. - firstLine ifTrue: [ xtraSpaceBefore _ paragraphStyle spaceBefore ]. - spaceAfterParagraph _ paragraphStyle spaceAfter ]. - destX _ spaceX _ leftMargin. - - runLength _ text runLengthFor: startIndex. - runStopIndex _ lastIndex + runLength - 1. - line _ (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0) - rectangle: lineRectangle. - line isFirstLine: firstLine. - spaceCount _ 0. - lastLineBreakingSpace _ 0. - leftMargin _ destX. - line leftMargin: leftMargin. - - self placeEmbeddedObject. - [ - stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex - in: text string rightX: rightMargin stopConditions: stopConditions - kern: font baseKern. - "See setStopConditions for stopping conditions for composing." - (self perform: stopCondition) ifTrue: [ - ^ line - lineHeight: lineHeight + xtraSpaceBefore + - (stopCondition == #doNewLine ifTrue: [spaceAfterParagraph] ifFalse: [0]) - baseline: baseline + xtraSpaceBefore ] - ] repeat! ! -!CompositionScanner methodsFor: 'stop conditions' stamp: 'jmv 6/15/2020 19:33:16' prior: 50410668 overrides: 16802069! - tab - "Advance destination x according to tab settings in the current - ParagraphStyle. Answer whether the character has crossed the right edge of - the composition rectangle of the TextComposition." - - destX _ self tabDestX. - destX > rightMargin ifTrue: [^self crossedX]. - lastIndex _ lastIndex + 1. - tabCount _ tabCount + 1. - ^false -! ! -!MorphicScanner methodsFor: 'scanning' stamp: 'jmv 6/15/2020 19:34:49' prior: 50410682! - displayLine: textLine textTopLeft: textTopLeft leftInRun: leftInRun - "The call on the primitive (scanCharactersFrom:to:in:rightX:) will be interrupted according to an array of stop conditions passed to the scanner at which time the code to handle the stop condition is run and the call on the primitive continued until a stop condition returns true (which means the line has terminated). leftInRun is the # of characters left to scan in the current run; when 0, it is time to call setStopConditions." - - "textTopLeft is relative to the morph currently being drawn" - | stopCondition nowLeftInRun startIndex string lastPos x1 | - - topLeft _ textTopLeft. - line _ textLine. - lineY _ line top + textTopLeft y. - rightMargin _ line rightMargin + textTopLeft x. - lastIndex _ line first. - tabCount _ 0. - leftInRun <= 0 ifTrue: [ - self setFont. - self setStopConditions ]. - leftMargin _ (line leftMarginForAlignment: alignment) + textTopLeft x. - destX _ leftMargin. - destY _ lineY + line baseline - font ascent. - - textLine isEmptyLine ifTrue: [ - textLine paragraphStyle ifNotNil: [ :ps | - ps = paragraphStyle ifFalse: [ - foregroundColor _ defaultColor. - self setActualFont: ps font. - ps color ifNotNil: [ :color | self textColor: color ]. - alignment _ ps alignment. - paragraphStyle _ ps. - spaceWidth _ font widthOf: Character space. - xTable _ font xTable. - self setStopConditions. - text ifNotNil: [ destY _ lineY + line baseline - font ascent ]]]. - self displayBulletIfAppropriateFor: textLine textLeft: textTopLeft x. - ^leftInRun ]. - - self displayBulletIfAppropriateFor: textLine textLeft: textTopLeft x. - - leftInRun <= 0 - ifTrue: [nowLeftInRun _ text runLengthFor: lastIndex] - ifFalse: [nowLeftInRun _ leftInRun]. - runStopIndex _ lastIndex + (nowLeftInRun - 1) min: line last. - spaceCount _ 0. - string _ text string. - - self placeEmbeddedObject. - [ - startIndex _ lastIndex. - lastPos _ destX@destY. - stopCondition _ self - scanCharactersFrom: lastIndex to: runStopIndex - in: string rightX: rightMargin stopConditions: stopConditions - kern: font baseKern. - backgroundColor ifNotNil: [ - x1 _ destX. - (Preferences backgroundColorFillsAllBackground and: [startIndex > line last]) ifTrue: [ - x1 _ rightMargin ]. - canvas - fillRectangle: (lastPos corner: x1 @ (line bottom + textTopLeft y)) - color: backgroundColor. - (Preferences backgroundColorFillsAllBackground and: [stopCondition = #tab]) ifTrue: [ - canvas - fillRectangle: (destX @ lastPos y corner: self tabDestX @ (line bottom + textTopLeft y)) - color: backgroundColor ]]. - lastIndex >= startIndex ifTrue: [ - canvas - drawString: string - from: startIndex - to: lastIndex - at: lastPos - font: font - color: foregroundColor ]. - "see setStopConditions for stopping conditions for displaying." - (self perform: stopCondition) ifTrue: [ - "Number of characters remaining in the current run" - ^ runStopIndex - lastIndex ] - ] repeat! ! -!MorphicScanner methodsFor: 'stop conditions' stamp: 'jmv 6/15/2020 19:33:48' prior: 50410778 overrides: 16802069! - tab - destX _ self tabDestX. - lastIndex _ lastIndex + 1. - tabCount _ tabCount + 1. - ^ false! ! - -Object subclass: #CharacterScanner - instanceVariableNames: 'destX lastIndex xTable destY stopConditions text alignment leftMargin rightMargin font line runStopIndex spaceCount spaceWidth tabWidth kern paragraphStyle defaultFont tabCount' - classVariableNames: 'DefaultStopConditions StopConditionsWithPaddedSpace StopConditionsWithSpace' - poolDictionaries: '' - category: 'Graphics-Text'! - -!classDefinition: #CharacterScanner category: #'Graphics-Text' stamp: 'Install-4240-TabHandling-JuanVuletich-2020Jun15-19h22m-jmv.001.cs.st 6/25/2020 16:07:33'! -Object subclass: #CharacterScanner - instanceVariableNames: 'destX lastIndex xTable destY stopConditions text alignment leftMargin rightMargin font line runStopIndex spaceCount spaceWidth tabWidth kern paragraphStyle defaultFont tabCount' - classVariableNames: 'DefaultStopConditions StopConditionsWithPaddedSpace StopConditionsWithSpace' - poolDictionaries: '' - category: 'Graphics-Text'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4240-TabHandling-JuanVuletich-2020Jun15-19h22m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4228] on 18 June 2020 at 3:07:00 pm'! -!Integer methodsFor: 'benchmarks' stamp: 'jmv 6/18/2020 15:05:55' prior: 50526430! - tinyBenchmarks - "Report the results of running the two tiny Squeak benchmarks. - ar 9/10/1999: Adjusted to run at least 1 sec to get more stable results - - Estimations from - https://dl.acm.org/doi/epdf/10.1145/3386335 ('The evolution of Smalltalk: from Smalltalk-72 through Squeak' by Dan Ingalls, p.96) - http://wiki.c2.com/?GreenBook - http://www.wirfs-brock.com/allen/things/smalltalk-things/tektronix-smalltalk-document-archive/1982-qtr4-magnolia-perf-graph.pdf - http://www.wirfs-brock.com/allen/things/smalltalk-things/tektronix-smalltalk-document-archive/1983-Magnolia-st-perf.pdf - - Xerox PARC systems - Alto Smalltalk-72 5MHz µcode 694 bytecodes/sec 54 sends/sec 7200 µclocks/bytecode - Alto Smalltalk-74 5MHz µcode 607 bytecodes/sec 46 sends/sec 8200 µclocks/bytecode - Alto Smalltalk-76 5MHz µcode 16k bytecodes/sec 118 sends/sec 310 µclocks/bytecode - NoteTaker Smalltalk-78 5MHz 8086 30k bytecodes/sec 250 sends/sec 166.67 clocks/bytecode - Dorado Smalltalk-76 16.67MHz µcode 1M bytecodes/sec 50k sends/sec 16.67 µClocks/bytecode - - Green Book systems - DEC PDP-11/23 5k bytecodes/sec (Green Book, p.128) - Apple 5MHz 68000 11k bytecodes/sec (Green Book, p.187, awb) 5000 clocks/bytecode - VAX-11/780 5MHz C HP Smalltalk 10k bytecodes/sec (Green Book, p.235) 450 clocks/bytecode - VAX-11/780 5MHz C Berkeley St 17k bytecodes/sec (Green Book, p.203, awb) 300 clocks/bytecode - DEC VAX-11/780 5MHz assembly 20k bytecodes/sec (Green Book, p.149, awb) 250 clocks/bytecode - TEK Magnolia 10MHz 68000 50k bytecodes/sec (awb) 200 clocks/bytecode - - Squeak & Cuis - 110 MHz PowerPC Mac 8100 4M bytecodes/sec; 175k sends/sec 26.8 clocks/bytecode - 292 MHz G3 Mac: 23M bytecodes/sec; 984k sends/sec 12.8 clocks/bytecode - 400 MHz PII/Win98: 18M bytecodes/sec; 1.08M sends/sec 22.2 clocks/bytecode - - 900MHz RasPi2 - StackVM: 38M bytecodes/sec; 2.41M sends/sec 16.2 clocks/bytecode - 900MHz RasPi2- CogSSpur: 157M bytecodes/sec; 10.95M sends/sec 5.7 clocks/bytecode - - 1GHz C.H.I.P. (*1) - StackVM: 55M bytecodes/sec; 3.35M sends/sec 18.1 clocks/bytecode - 1GHz C.H.I.P. (*1) - CogSpur: 254M bytecodes/sec; 16.85M sends/sec 3.9 clocks/bytecode - - 1.2GHz RasPi3B - StackSpur: 44M bytecodes/sec; 2.77M sends/sec 27.2 clocks/bytecode - 1.2GHz RasPi3B - CogSpur: 282M bytecodes/sec; 16.40M sends/sec 6.6 clocks/bytecode - - 1.66GHz Atom N450 - Cog: 244M bytecodes/sec; 28.80M sends/sec 6.8 clocks/bytecode - 1.66GHz Atom N450 - CogSpur: 470M bytecodes/sec; 30.75M sends/sec 3.5 clocks/bytecode - - 1.33GHz Atom 3735G - Cog: 326M bytecodes/sec; 34.99M sends/sec 4.1 clocks/bytecode - 1.33GHz Atom 3735G - CogSpur: 632M bytecodes/sec; 33.69M sends/sec 2.1 clocks/bytecode - - 1.5GHz AMD A4-5000 - Cog: 390M bytecodes/sec; 47.51M sends/sec 3.8 clocks/bytecode - 1.5GHz AMD A4-5000 - CogSpur: 676M bytecodes/sec; 40.67M sends/sec 2.2 clocks/bytecode - 1.5GHz AMD A4-5000 - CogSpur64: 659M bytecodes/sec; 50.34M sends/sec 2.2 clocks/bytecode - - 2.3GHz Tegra (*2) - StackVM: 259M bytecodes/sec; 13.01M sends/sec 8.9 clocks/bytecode - 2.3GHz Tegra (*2) - CogSpur: 1.08G bytecodes/sec; 64.29M sends/sec 2.1 clocks/bytecode - - 3.1GHz Core i3-2100 - Cog: 1.20G bytecodes/sec; 165.72M sends/sec 2.6 clocks/bytecode - 3.1GHz Core i3-2100 - CogSpur: 2.04G bytecodes/sec; 127.84M sends/sec 1.5 clocks/bytecode - - 2.70GHz Core i5-6400 -CogSpur64 3.16G bytecodes/sec; 243.32M sends/sec 0.85 clocks/bytecode - - (*1) C.H.I.P. $9 Computer [Next Thing Co], Allwinner R8 Single-Core ARM Cortex-A8 - 1 GHz - (*2) ACER Chromebook CB5-311 - NVIDIA Tegra K1 Quad-Core ARM Cortex-A15 'r3' - 2.3 GHz - - It is interesting to note that Spur for the first time brings ARM hardware (RasPi and C.H.I.P.) into a 'Morphic is confortable and nice to use' level of performance, - i.e. around 100 Dorados. - " - | t1 t2 r n1 n2 | - n1 _ 1. - [ - t1 _ Time millisecondsToRun: [n1 benchmark]. - t1 < 1000] - whileTrue: [n1 _ n1 * 2]. "Note: #benchmark's runtime is about O(n)" - - n2 _ 28. - [ - t2 _ Time millisecondsToRun: [r _ n2 benchFib]. - t2 < 1000] - whileTrue: [n2 _ n2 + 1]. - "Note: #benchFib's runtime is about O(k^n), - where k is the golden number = (1 + 5 sqrt) / 2 = 1.618...." - - ^String streamContents: [ :strm | - (n1 * 500000 * 1000) // t1 withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixName; - nextPutAll: 'Bytecodes/second; ' ]. - (r * 1000) // t2 withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixName; - nextPutAll: 'Sends/second' ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4241-tinyBenchmarks-update-JuanVuletich-2020Jun18-12h17m-jmv.001.cs.st----! - -----SNAPSHOT----(25 June 2020 16:07:38) Cuis5.0-4241-v3.image priorSource: 5974656! - -----STARTUP---- (5 August 2020 22:22:39) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4241-v3.image! - - -'From Cuis 5.0 [latest update: #4241] on 26 June 2020 at 5:06:35 pm'! -!BitBlt commentStamp: 'jmv 6/26/2020 15:21:57' prior: 16785227! - WARNING: BitBlt's shape cannot be modified since WarpBlt relies on the exact layout. Important primitives will break if you fail to heed this warning. - -I represent a block transfer (BLT) of pixels from one Form ( the sourceForm) into a rectangle (destX, destY, width, height) of the destinationForm, as modified by a combination rule, a possible halftoneForm and a possible color map. - -The source of pixels may be a similar rectangle (at sourceX, sourceY) in the sourceForm, or the halftoneForm, or both. If both are specified, their pixel values are combined by a logical AND function prior to any further combination rule processing. The halftoneForm may be an actual Form or a simple WordArray of 32 bit values usually intended to represent Color values. In either case the 'top' of the form is effectively aligned with the top of the destinationForm and for each scanline the destination y modulo the size of the halftoneForm gives the index of the word to use. This makes it easy to make horizontal stripes, for example. - -In any case, the pixels from the source (AND'd with the halftone, remember) are combined with those of the destination by as specified by the combinationRules below- - name rule result - - 0 always 0 - and 1 src AND dst - 2 src AND not(dst) - over 3 src only - erase 4 not(src) AND dst - 5 dst only - reverse 6 src XOR dst - under 7 src OR dst - 8 not(src) AND not(dst) - 9 not(src) XOR dst - 10 not(dst) - 11 src OR not(dst) - 12 not(src) - 13 not(src) OR dst - 14 not(src) OR not(dst) - 15 always 1 -(You can find an interesting explanation of how this comes to be in http://dev-docs.atariforge.org/files/BLiTTER_1-25-1990.pdf - which interestingly fails to mention any connection to Smalltalk and PARC.) - -Forms may be of different depths, see the comment in class Form. - -In addition to the original 16 combination rules invented for monochrome Forms, this BitBlt supports - 16 fails (to simulate paint bits) - 17 fails (to simulate erase bits) - 18 sourceWord + destinationWord - 19 sourceWord - destinationWord - 20 rgbAdd: sourceWord with: destinationWord. Sum of color components - 21 rgbSub: sourceWord with: destinationWord. Difference of color components - 22 OLDrgbDiff: sourceWord with: destinationWord. Sum of abs of differences in components - 23 OLDtallyIntoMap: destinationWord. Tallies pixValues into a colorMap - these old versions don't do bitwise dest clipping. Use 32 and 33 now. - blend 24 alphaBlend: sourceWord with: destinationWord. 32-bit source and dest only. Blend sourceWord - with destinationWord, assuming both are 32-bit pixels. The source is assumed to have 255*alpha - in the high 8 bits of each pixel, while the high 8 bits of the destinationWord will be ignored. - The blend produced is alpha*source + (1-alpha)*dest, with the computation being performed - independently on each color component. The high byte of the result will be 0. - paint 25 pixPaint: sourceWord with: destinationWord. Wherever the sourceForm is non-zero, it replaces - the destination. Can be used with a 1-bit source color mapped to (0, FFFFFFFF), and a fillColor - to fill the dest with that color wherever the source is 1. - erase1BitShape 26 pixMask: sourceWord with: destinationWord. Like pixPaint, but fills with 0. - 27 rgbMax: sourceWord with: destinationWord. Max of each color component. - 28 rgbMin: sourceWord with: destinationWord. Min of each color component. - 29 rgbMin: sourceWord bitInvert32 with: destinationWord. Min with (max-source) - blendAlpha 30 alphaBlendConst: sourceWord with: destinationWord. alpha is an arg. works in 16 bits. Blend - sourceWord with destinationWord using a constant alpha. Alpha is encoded as 0 meaning - 0.0, and 255 meaning 1.0. The blend produced is alpha*source + (1.0-alpha)*dest, with - the computation being performed independently on each color component. - paintAlpha 31 alphaPaintConst: sourceWord with: destinationWord. alpha is an arg. works in 16 bits. - 32 rgbDiff: sourceWord with: destinationWord. Sum of abs of differences in components - 33 tallyIntoMap: destinationWord. Tallies pixValues into a colorMap - Those tallied are exactly - those in the destination rectangle. Note that the source should be specified == destination, - in order for the proper color map checks be performed at setup. - blendAlphaScaled 34 alphaBlendScaled: srcWord with: dstWord. Alpha blend of scaled srcWord and destWord. In contrast - to alphaBlend:with: the color produced is srcColor + (1-srcAlpha) * dstColor - 35 & 36 not used - rgbMul 37 rgbMul: srcWord with: dstWord. - 38 pixSwap: srcWord with: dstWord. - 39 pixClear: srcWord with: dstWord. Clear all pixels in destinationWord for which the pixels of - sourceWord have the same values. Used to clear areas of some constant color to zero. - 40 fixAlpha: srcWord with: dstWord. For any non-zero pixel value in destinationWord with zero alpha - channel take the alpha from sourceWord and fill it in. Intended for fixing alpha channels left at - zero during 16->32 bpp conversions. - 41 rgbComponentAlpha: srcWord with: dstWord. - -Any transfer specified is further clipped by the specified clipping rectangle (clipX, clipY, clipWidth, clipHeight), and also by the bounds of the source and destination forms. - To make a small Form repeat and fill a big form, use an InfiniteForm as the source. - -Pixels copied from a source to a destination whose pixels have a different depth are converted based on the optional colorMap. If colorMap is nil, then conversion to more bits is done by filling the new high-order bits with zero, and conversion to fewer bits is done by truncating the lost high-order bits. - -The colorMap, if specified, must be a either word array (ie Bitmap) with 2^n elements, where n is the pixel depth of the source, or a fully specified ColorMap which may contain a lookup table (ie Bitmap) and/or four separate masks and shifts which are applied to the pixels. For every source pixel, BitBlt will first perform masking and shifting and then index the lookup table, and select the corresponding pixelValue and mask it to the destination pixel size before storing. - When blitting from a 32 or 16 bit deep Form to one 8 bits or less, the default is truncation. This will produce very strange colors, since truncation of the high bits does not produce the nearest encoded color. Supply a 512 long colorMap, and red, green, and blue will be shifted down to 3 bits each, and mapped. The message copybits...stdColors will use the best map to the standard colors for destinations of depths 8, 4, 2 and 1. Two other sized of colorMaps are allowed, 4096 (4 bits per color) and 32786 (five bits per color). - Normal blits between 16 and 32 bit forms truncates or pads the colors automatically to provide the best preservation of colors. - Colors can be remapped at the same depth. Sometimes a Form is in terms of colors that are not the standard colors for this depth, for example in a GIF file. Convert the Form to a MaskedForm and send colorMap: the list of colors that the picture is in terms of. (Note also that a Form can be copied to itself, and transformed in the process, if a non-nil colorMap is supplied.)! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 6/26/2020 16:01:09' prior: 50453431! - standardWindowExtent - "Answer the standard default extent for new windows. " - - | grid allowedArea maxLevel | - "NOTE: following copied from strictlyStaggeredInitialFrameFor:" - allowedArea _ self maximumUsableArea insetBy: ( - self scrollBarSetback @ self screenTopSetback extent: `0@0` - ). - "Number to be staggered at each corner (less on small screens)" - maxLevel _ allowedArea area > 700000 ifTrue: [3] ifFalse: [2]. - "Amount by which to stagger (less on small screens)" - grid _ allowedArea area > 700000 ifTrue: [40] ifFalse: [20]. - ^ ((allowedArea extent - (grid*(maxLevel+1*2) + (grid//2))) min: `52@40` * Preferences standardCodeFont lineSpacing) rounded! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4242-MakeDefaultWindowBoundsIntegers-JuanVuletich-2020Jun26-17h06m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4241] on 27 June 2020 at 6:50:36 pm'! - -Scanner subclass: #Parser - instanceVariableNames: 'here hereType hereMark hereEnd prevMark prevEnd encoder requestor parseNode failBlock requestorOffset tempsMark doitFlag properties category advanced ' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #Parser category: #'Compiler-Kernel' stamp: 'Install-4243-ParserRefactoring-HernanWilkinson-2020Jun27-18h34m-HAW.001.cs.st 8/5/2020 22:22:43'! -Scanner subclass: #Parser - instanceVariableNames: 'here hereType hereMark hereEnd prevMark prevEnd encoder requestor parseNode failBlock requestorOffset tempsMark doitFlag properties category advanced' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! -!Parser methodsFor: 'expression types' stamp: 'HAW 6/27/2020 18:41:23'! - literalExpression - - parseNode := self advanceWithRangeDo: [ :lexema :range | encoder encodeLiteral: lexema range: range ]. - - ^true! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 6/27/2020 18:41:41'! - literalNumberExpression - - self advanceWithRangeDo: [ :minusChar :minusRange | - self advanceWithRangeDo: [ :number :numberRange | - parseNode := encoder encodeLiteral: number negated range: (minusRange first to: numberRange last)]]. - - ^true! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 6/27/2020 18:47:00'! - parenthesisExpression - - self advance. - self expression ifFalse: [^self expected: 'expression']. - (self match: #rightParenthesis) ifFalse: [^self expected: 'right parenthesis']. - - ^true! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 6/27/2020 18:40:19'! - variableExpression - - parseNode _ self variable. - - " - (parseNode isUndefTemp and: [self interactive] and: [ - ((requestor isKindOf: Editor) or: [ requestor is: #Morph ])]) - " - "If the requestor is of an exotic kind (like a telnet server) we might not be - allowed to open a PupUpMenu for querying the user" - - (parseNode isUndefTemp and: [ self interactive ]) - ifTrue: [self queryUndefined]. - parseNode nowHasRef. - - ^true! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 6/27/2020 18:46:12' prior: 50502452! -blockExpression - "[ ({:var} |) (| {temps} |) (statements) ] => BlockNode." - - | blockNode tempsDeclarationNode variableNodes temporaryBlockVariables start | - - blockNode := BlockNode new. - variableNodes := OrderedCollection new. - start := prevMark + requestorOffset. - "Gather parameters." - [self match: #colon] whileTrue: - [self argumentNameWithRangeDo: [ :argumentName :range | - variableNodes addLast: (encoder bindBlockArg: argumentName within: blockNode range: range)]]. - (variableNodes size > 0 & (hereType ~~ #rightBracket) and: [(self match: #verticalBar) not]) ifTrue: - [^self expected: 'Vertical bar']. - - tempsDeclarationNode := self temporaryBlockVariablesFor: blockNode. - temporaryBlockVariables := tempsDeclarationNode allDeclaredVariableNodes. - self statements: variableNodes innerBlock: true blockNode: blockNode. - blockNode temporariesDeclaration: tempsDeclarationNode. - - (self match: #rightBracket) ifFalse: [^self expected: 'Period or right bracket']. - - blockNode noteSourceRangeStart: start end: self endOfLastToken encoder: encoder. - - "The scope of the parameters and temporary block variables is no longer active." - temporaryBlockVariables do: [:variable | variable scope: -1]. - variableNodes do: [:variable | variable scope: -1]. - - ^true! ! -!Parser methodsFor: 'backtick' stamp: 'HAW 6/27/2020 18:47:29' prior: 50525624! - backtickExpression - - | start range | - - start := self startOfNextToken. - self advance. - self expression ifFalse: [^self expected: 'expression']. - (self match: #backtick) ifFalse: [^self expected: 'backtick']. - range := start to: prevEnd. - - parseNode := BacktickNode - expression: parseNode - source: (source contents copyFrom: range first+1 to: range last-1) - parser: self - range: range. - - encoder noteSourceRange: range forNode: parseNode. - - ^true! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 6/27/2020 19:05:25' prior: 50525885! - primaryExpression - - hereType == #word - ifTrue: [ - parseNode _ self variable. - - " - (parseNode isUndefTemp and: [self interactive] and: [ - ((requestor isKindOf: Editor) or: [ requestor is: #Morph ])]) - " - "If the requestor is of an exotic kind (like a telnet server) we might not be - allowed to open a PupUpMenu for querying the user" - - (parseNode isUndefTemp and: [ self interactive ]) - ifTrue: [self queryUndefined]. - parseNode nowHasRef. - ^ true]. - hereType == #leftBracket - ifTrue: [ - advanced := true. - self advance. - self blockExpression. - ^true]. - hereType == #leftBrace - ifTrue: [ - self braceExpression. - ^true]. - hereType == #leftParenthesis - ifTrue: [ - self advance. - self expression ifFalse: [^self expected: 'expression']. - (self match: #rightParenthesis) - ifFalse: [^self expected: 'right parenthesis']. - ^true]. - (hereType == #string or: [hereType == #number or: [hereType == #literal]]) - ifTrue: [ - parseNode := self advanceWithRangeDo: [ :lexema :range | encoder encodeLiteral: lexema range: range ]. - ^true]. - (here == #- and: [tokenType == #number]) - ifTrue: [ - self advanceWithRangeDo: [ :minusChar :minusRange | - self advanceWithRangeDo: [ :number :numberRange | - parseNode := encoder encodeLiteral: number negated range: (minusRange first to: numberRange last)]]. - ^true]. - - hereType == #backtick - ifTrue: [ - self backtickExpression. - ^true ]. - - ^false! ! - -Scanner subclass: #Parser - instanceVariableNames: 'here hereType hereMark hereEnd prevMark prevEnd encoder requestor parseNode failBlock requestorOffset tempsMark doitFlag properties category advanced' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #Parser category: #'Compiler-Kernel' stamp: 'Install-4243-ParserRefactoring-HernanWilkinson-2020Jun27-18h34m-HAW.001.cs.st 8/5/2020 22:22:43'! -Scanner subclass: #Parser - instanceVariableNames: 'here hereType hereMark hereEnd prevMark prevEnd encoder requestor parseNode failBlock requestorOffset tempsMark doitFlag properties category advanced' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4243-ParserRefactoring-HernanWilkinson-2020Jun27-18h34m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4242] on 27 June 2020 at 7:07:50 pm'! -!Parser methodsFor: 'expression types' stamp: 'HAW 6/27/2020 19:06:38' prior: 50527453! - blockExpression - "[ ({:var} |) (| {temps} |) (statements) ] => BlockNode." - - | blockNode tempsDeclarationNode variableNodes temporaryBlockVariables start | - - advanced == true ifFalse: [ self advance ]. - - blockNode := BlockNode new. - variableNodes := OrderedCollection new. - start := prevMark + requestorOffset. - "Gather parameters." - [self match: #colon] whileTrue: - [self argumentNameWithRangeDo: [ :argumentName :range | - variableNodes addLast: (encoder bindBlockArg: argumentName within: blockNode range: range)]]. - (variableNodes size > 0 & (hereType ~~ #rightBracket) and: [(self match: #verticalBar) not]) ifTrue: - [^self expected: 'Vertical bar']. - - tempsDeclarationNode := self temporaryBlockVariablesFor: blockNode. - temporaryBlockVariables := tempsDeclarationNode allDeclaredVariableNodes. - self statements: variableNodes innerBlock: true blockNode: blockNode. - blockNode temporariesDeclaration: tempsDeclarationNode. - - (self match: #rightBracket) ifFalse: [^self expected: 'Period or right bracket']. - - blockNode noteSourceRangeStart: start end: self endOfLastToken encoder: encoder. - - "The scope of the parameters and temporary block variables is no longer active." - temporaryBlockVariables do: [:variable | variable scope: -1]. - variableNodes do: [:variable | variable scope: -1]. - - ^true! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4244-ParserRefactoring-HernanWilkinson-2020Jun27-19h05m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4242] on 27 June 2020 at 7:09:35 pm'! -!Parser methodsFor: 'expression types' stamp: 'HAW 6/27/2020 19:08:46'! - isLiteralExpression - - ^ hereType == #string or: [hereType == #number or: [hereType == #literal]]! ! -!Parser methodsFor: 'expression types' stamp: 'HAW 6/27/2020 19:09:05'! - isLiteralNumberExpression - - ^ here == #- and: [tokenType == #number]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4245-ParserRefactoring-HernanWilkinson-2020Jun27-19h07m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4242] on 27 June 2020 at 7:13:18 pm'! -!Parser methodsFor: 'expression types' stamp: 'HAW 6/27/2020 19:12:36' prior: 50527512! - primaryExpression - - hereType == #word ifTrue: [ ^self variableExpression ]. - hereType == #leftBracket ifTrue: [ ^self blockExpression ]. - hereType == #leftBrace ifTrue: [ ^self braceExpression ]. - hereType == #leftParenthesis ifTrue: [ ^self parenthesisExpression ]. - (self isLiteralExpression) ifTrue: [ ^self literalExpression ]. - (self isLiteralNumberExpression) ifTrue: [ ^self literalNumberExpression ]. - hereType == #backtick ifTrue: [ ^self backtickExpression ]. - - ^false! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4246-ParserRefactoring-HernanWilkinson-2020Jun27-19h09m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4242] on 27 June 2020 at 7:14:34 pm'! - -Scanner subclass: #Parser - instanceVariableNames: 'here hereType hereMark hereEnd prevMark prevEnd encoder requestor parseNode failBlock requestorOffset tempsMark doitFlag properties category advanced ' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #Parser category: #'Compiler-Kernel' stamp: 'Install-4247-ParserExpression-HernanWilkinson-2020Jun27-19h13m-HAW.001.cs.st 8/5/2020 22:22:43'! -Scanner subclass: #Parser - instanceVariableNames: 'here hereType hereMark hereEnd prevMark prevEnd encoder requestor parseNode failBlock requestorOffset tempsMark doitFlag properties category advanced' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! -!Parser methodsFor: 'expression types' stamp: 'HAW 6/27/2020 19:13:39' prior: 50527592! - blockExpression - "[ ({:var} |) (| {temps} |) (statements) ] => BlockNode." - - | blockNode tempsDeclarationNode variableNodes temporaryBlockVariables start | - - self advance. - - blockNode := BlockNode new. - variableNodes := OrderedCollection new. - start := prevMark + requestorOffset. - "Gather parameters." - [self match: #colon] whileTrue: - [self argumentNameWithRangeDo: [ :argumentName :range | - variableNodes addLast: (encoder bindBlockArg: argumentName within: blockNode range: range)]]. - (variableNodes size > 0 & (hereType ~~ #rightBracket) and: [(self match: #verticalBar) not]) ifTrue: - [^self expected: 'Vertical bar']. - - tempsDeclarationNode := self temporaryBlockVariablesFor: blockNode. - temporaryBlockVariables := tempsDeclarationNode allDeclaredVariableNodes. - self statements: variableNodes innerBlock: true blockNode: blockNode. - blockNode temporariesDeclaration: tempsDeclarationNode. - - (self match: #rightBracket) ifFalse: [^self expected: 'Period or right bracket']. - - blockNode noteSourceRangeStart: start end: self endOfLastToken encoder: encoder. - - "The scope of the parameters and temporary block variables is no longer active." - temporaryBlockVariables do: [:variable | variable scope: -1]. - variableNodes do: [:variable | variable scope: -1]. - - ^true! ! - -Scanner subclass: #Parser - instanceVariableNames: 'here hereType hereMark hereEnd prevMark prevEnd encoder requestor parseNode failBlock requestorOffset tempsMark doitFlag properties category' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -!classDefinition: #Parser category: #'Compiler-Kernel' stamp: 'Install-4247-ParserExpression-HernanWilkinson-2020Jun27-19h13m-HAW.001.cs.st 8/5/2020 22:22:43'! -Scanner subclass: #Parser - instanceVariableNames: 'here hereType hereMark hereEnd prevMark prevEnd encoder requestor parseNode failBlock requestorOffset tempsMark doitFlag properties category' - classVariableNames: '' - poolDictionaries: '' - category: 'Compiler-Kernel'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4247-ParserExpression-HernanWilkinson-2020Jun27-19h13m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4246] on 27 June 2020 at 7:52:55 pm'! -!BrowserWindow class methodsFor: 'GUI building' stamp: 'HAW 6/27/2020 19:48:57'! - classNamesFrom: potentialClassNames with: pattern matching: toMatch - - ^ (pattern last = $. or: [pattern last = $ ]) - ifTrue: [potentialClassNames select: [:className | className asLowercase = toMatch]] - ifFalse: [potentialClassNames select: [:className | className includesSubstring: toMatch caseSensitive: false]]! ! -!BrowserWindow class methodsFor: 'GUI building' stamp: 'HAW 6/27/2020 19:48:57'! - findClassFrom: potentialClassNames ifFound: aBlock with: pattern - - | exactMatch foundClass index classNames toMatch | - - pattern isEmpty ifTrue: [^self flash]. - - toMatch _ (pattern copyWithout: $.) asLowercase withBlanksTrimmed. - classNames _ self classNamesFrom: potentialClassNames with: pattern matching: toMatch. - classNames isEmpty ifTrue: [^self flash]. - - exactMatch _ classNames detect: [ :each | each asLowercase = toMatch] ifNone: [ nil ]. - index _ self indexOfClassFrom: classNames exactMatch: exactMatch. - index = 0 ifTrue: [^self flash]. - - foundClass _ Smalltalk at: (classNames at: index) asSymbol. - aBlock value: foundClass! ! -!BrowserWindow class methodsFor: 'GUI building' stamp: 'HAW 6/27/2020 19:51:15'! - indexOfClassFrom: classNames exactMatch: exactMatch - - | options | - - classNames size = 1 ifTrue: [ ^1 ]. - - options := exactMatch - ifNil: [ PopUpMenu labelArray: classNames lines: #()] - ifNotNil: [ - classNames remove: exactMatch ifAbsent: []. - classNames addFirst: exactMatch. - PopUpMenu labelArray: classNames lines: #(1)]. - - ^options startUpMenu! ! -!BrowserWindow methodsFor: 'commands' stamp: 'HAW 6/27/2020 19:43:29' prior: 50447135! -findClass - - | scopedClassNames | - - scopedClassNames _ model potentialClassNames asOrderedCollection. - - self class - findClassFrom: scopedClassNames - ifFound: [:foundClass | - model selectCategoryForClass: foundClass. - model selectClass: foundClass ]! ! -!BrowserWindow class methodsFor: 'GUI building' stamp: 'HAW 6/27/2020 19:49:27' prior: 50525086! - findClassFrom: potentialClassNames ifFound: aBlock - - self classNameRequester - request: self findClassDialogTitle - initialAnswer: '' - do: [ :pattern | self findClassFrom: potentialClassNames ifFound: aBlock with: pattern ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4248-FindClassRefactoring-HernanWilkinson-2020Jun27-19h22m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4242] on 29 June 2020 at 1:45:03 pm'! -!Behavior methodsFor: 'accessing' stamp: 'HAW 6/28/2020 10:57:39'! - theNonMetaClass - - self subclassResponsibility ! ! -!Behavior methodsFor: 'printing' stamp: 'HAW 6/28/2020 12:25:41'! - printSubclassesOn: aStream level: level - "As part of the algorithm for printing a description of the receiver, print the - subclass on the file stream, aStream, indenting level times." - | subclassNames | - aStream newLineTab: level. - aStream nextPutAll: self name. - aStream - space; - print: self instVarNames. - self == Class ifTrue: [ - aStream - newLineTab: level + 1; - nextPutAll: '[ ... all the Metaclasses ... ]'. - ^ self ]. - subclassNames _ self subclasses asArray sort: [ :c1 :c2 | - c1 name <= c2 name ]. - "Print subclasses in alphabetical order" - subclassNames do: [ :subclass | - subclass - printSubclassesOn: aStream - level: level + 1 ].! ! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'HAW 6/28/2020 12:05:30'! - subclassesDo: aBlock - "Evaluate the argument, aBlock, for each of the receiver's immediate subclasses." - ^self subclasses do: aBlock! ! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'jmv 6/29/2020 13:06:24'! - subclassesDoGently: aBlock - "Evaluate the argument, aBlock, for each of the receiver's immediate subclasses." - - ^self subclassesDo: aBlock! ! -!Behavior methodsFor: 'accessing method dictionary' stamp: 'HAW 6/28/2020 12:20:34'! - recoverFromMDFaultWithTrace - - self subclassResponsibility ! ! -!Behavior methodsFor: 'accessing method dictionary' stamp: 'HAW 6/28/2020 12:22:58'! - ultimateSourceCodeAt: selector ifAbsent: aBlock - "Return the source code at selector, deferring to superclass if necessary" - - ^ self - sourceCodeAt: selector - ifAbsent: [ - superclass - ifNil: [aBlock value] - ifNotNil: [superclass ultimateSourceCodeAt: selector ifAbsent: aBlock]]! ! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'HAW 6/28/2020 11:54:26'! - allBroadAccessesTo: instVarName - - | references instVarIndex definingClass | - - definingClass _ self whichClassDefinesInstanceVariable: instVarName ifNone: [ ^#() ]. - instVarIndex _ self indexOfInstanceVariable: instVarName. - references _ SortedCollection sortBlock: [ :left :right | left stringVersion <= right stringVersion ]. - - definingClass withAllSubclassesDo: [ :class | class addReferencesOf: instVarName at: instVarIndex to: references ]. - - ^ references ! ! -!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'HAW 6/28/2020 12:18:42' overrides: 16783715! - changeRecordsAt: selector - "Return a list of ChangeRecords for all versions of the method at selector. Source code can be retrieved by sending string to any one. Return nil if the method is absent." - - "(Pen changeRecordsAt: #go:) collect: [:cRec | cRec string]" - | aList | - aList _ VersionsBrowser new - scanVersionsOf: (self compiledMethodAt: selector ifAbsent: [^ nil]) - class: self meta: self isMeta - category: (self whichCategoryIncludesSelector: selector) - selector: selector. - ^ aList ifNotNil: [aList changeList]! ! -!ClassDescription methodsFor: 'accessing instances and variables' stamp: 'HAW 6/28/2020 12:13:50' overrides: 50407120! - allUnreferencedInstanceVariables - - "Return a list of the instance variables known to the receiver which are not referenced in the receiver or any of its subclasses OR superclasses" - - ^ self allInstVarNames reject: [ :instanceVariableName | | definingClass | - definingClass _ self classThatDefinesInstanceVariable: instanceVariableName. - definingClass isInstanceVariableNamedReferencedInHierarchy: instanceVariableName ]! ! -!ClassDescription methodsFor: 'pool variables' stamp: 'HAW 6/28/2020 12:30:46'! - classPool - - self subclassResponsibility ! ! -!Class methodsFor: 'private' stamp: 'jmv 6/29/2020 13:02:26' overrides: 50430641! - becomeCompact - "Here are the restrictions on compact classes in order for export segments to work: A compact class index may not be reused. If a class was compact in a release of Squeak, no other class may use that index. The class might not be compact later, and there should be nil in its place in the array." - | cct index | - - Smalltalk isSpur ifTrue: [^ self halt: 'No Compact Classes support in Spur']. - self isWeak ifTrue:[^ self halt: 'You must not make a weak class compact']. - cct _ Smalltalk compactClassesArray. - (self indexIfCompact > 0 or: [cct includes: self]) - ifTrue: [^ self halt: self name , 'is already compact']. - index _ cct indexOf: nil - ifAbsent: [^ self halt: 'compact class table is full']. - "Install this class in the compact class table" - cct at: index put: self. - "Update instspec so future instances will be compact" - format _ format + (index bitShift: 11). - "Make up new instances and become old ones into them" - self updateInstancesFrom: self. - "Purge any old instances" - Smalltalk garbageCollect.! ! -!Class methodsFor: 'private' stamp: 'jmv 6/29/2020 13:03:05' overrides: 16784763! - becomeCompactSimplyAt: index - "Make me compact, but don't update the instances. For importing segments." -"Here are the restrictions on compact classes in order for export segments to work: A compact class index may not be reused. If a class was compact in a release of Squeak, no other class may use that index. The class might not be compact later, and there should be nil in its place in the array." - | cct | - - Smalltalk isSpur ifTrue: [^ self halt: 'No Compact Classes support in Spur']. - self isWeak ifTrue:[^ self halt: 'You must not make a weak class compact']. - cct _ Smalltalk compactClassesArray. - (self indexIfCompact > 0 or: [cct includes: self]) - ifTrue: [^ self halt: self name , 'is already compact']. - (cct at: index) ifNotNil: [^ self halt: 'compact table slot already in use']. - "Install this class in the compact class table" - cct at: index put: self. - "Update instspec so future instances will be compact" - format _ format + (index bitShift: 11). - "Caller must convert the instances" -! ! -!Class methodsFor: 'private' stamp: 'jmv 6/29/2020 13:02:15' overrides: 50430676! - becomeUncompact - | cct index | - cct _ Smalltalk compactClassesArray. - (index _ self indexIfCompact) = 0 - ifTrue: [^ self]. - (cct includes: self) - ifFalse: [^ self halt "inconsistent state"]. - "Update instspec so future instances will not be compact" - format _ format - (index bitShift: 11). - "Make up new instances and become old ones into them" - self updateInstancesFrom: self. - "Make sure there are no compact ones left around" - Smalltalk garbageCollect. - "Remove this class from the compact class table" - cct at: index put: nil. -! ! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'jmv 6/29/2020 13:18:25' prior: 16784063! - allRegularInstVarNames - "Answer an Array of the names of the receiver's instance variables. The - Array ordering is the order in which the variables are stored and - accessed by the interpreter. - - Quite like asking #allInstVarNames, but do not include Behavior state (i.e. Smalltalk internals)" - - ^ (self == ProtoObject class or: [ superclass isNil ]) - ifTrue: [self instVarNames copy] "Guarantee a copy is answered." - ifFalse: [superclass allRegularInstVarNames , self instVarNames].! ! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'HAW 6/28/2020 12:34:05' prior: 16806705! - fileOutChangedMessages: aSet on: aFileStream moveSource: moveSource toFile: fileIndex - "File a description of the messages of this class that have been - changed (i.e., are entered into the argument, aSet) onto aFileStream. If - moveSource, is true, then set the method source pointer to the new file position. - Note when this method is called with moveSource=true, it is condensing the - .changes file, and should only write a preamble for every method." - - | org categories | - - org _ self organization. - categories _ org categories. - - categories ifNotNil: [ categories do: [ :cat | | sels | - sels _ (org listAtCategoryNamed: cat) select: [:sel | aSet includes: sel]. - sels do: [:sel | - self printMethodChunk: sel withPreamble: true on: aFileStream moveSource: moveSource toFile: fileIndex]]]! ! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'HAW 6/28/2020 12:38:48' prior: 50482120! - fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex - "File a description of the receiver on aFileStream. If the boolean - argument, moveSource, is true, then set the trailing bytes to the position - of aFileStream and to fileIndex in order to indicate where to find the - source code." - - | categories | - - aFileStream nextPut: $!!; nextChunkPut: self definitionPreambleWithoutStamp; newLine. - aFileStream nextChunkPut: self definition. - - self organization - putCommentOnFile: aFileStream - numbered: fileIndex - moveSource: moveSource - forClass: self. - categories := self organization categories. - categories ifNotNil: [ categories do: [ :heading | - self fileOutCategory: heading - on: aFileStream - moveSource: moveSource - toFile: fileIndex]]! ! -!Class methodsFor: 'class variables' stamp: 'HAW 6/28/2020 16:34:20' prior: 16802479! - removeClassVarName: aString - "Remove the class variable whose name is the argument, aString, from - the names defined in the receiver, a class. Create an error notification if - aString is not a class variable or if it is still being used in the code of - the class." - - | aSymbol | - aSymbol _ aString asSymbol. - (classPool isNil or: [(classPool includesKey: aSymbol) not]) - ifTrue: [ ^self error: aString, ' is not a class variable']. - self withAllSubclasses do:[:subclass | - (Array with: subclass with: subclass class) do: [ :classOrMeta | - (classOrMeta whichSelectorsReferTo: (classPool associationAt: aSymbol)) - isEmpty ifFalse: [ - InMidstOfFileinNotification signal ifTrue: [ - Transcript newLine; show: self name, ' (' , aString , ' is Undeclared) '. - ^Undeclared declare: aSymbol from: classPool ]. - (self confirm: (aString,' is still used in code of class ', classOrMeta name, - '.\Is it okay to move it to Undeclared?') withNewLines) - ifTrue: [ ^Undeclared declare: aSymbol from: classPool ] - ifFalse: [ ^self ]]]]. - classPool removeKey: aSymbol. - classPool isEmpty ifTrue: [ classPool _ nil ]! ! -!Class methodsFor: 'pool variables' stamp: 'HAW 6/28/2020 16:39:55' prior: 16802546! - removeSharedPool: aDictionary - "Remove the pool dictionary, aDictionary, as one of the receiver's pool - dictionaries. Create an error notification if the dictionary is not one of - the pools. - : Note that it removes the wrong one if there are two empty Dictionaries in the list." - - | satisfiedSet workingSet aSubclass | - - (sharedPools isNil or: [(sharedPools includes: aDictionary) not ]) - ifTrue: [^self error: 'the dictionary is not in my pool']. - - "first see if it is declared in a superclass in which case we can remove it." - (self selectSuperclasses: [:class | class sharedPools includes: aDictionary]) isEmpty - ifFalse: [sharedPools remove: aDictionary. - sharedPools isEmpty ifTrue: [sharedPools _ nil]. - ^self]. - - "second get all the subclasses that reference aDictionary through me rather than a - superclass that is one of my subclasses." - - workingSet _ self subclasses asOrderedCollection. - satisfiedSet _ Set new. - [workingSet isEmpty] whileFalse: - [aSubclass _ workingSet removeFirst. - (aSubclass sharedPools includes: aDictionary) - ifFalse: - [satisfiedSet add: aSubclass. - workingSet addAll: aSubclass subclasses]]. - - "for each of these, see if they refer to any of the variables in aDictionary because - if they do, we can not remove the dictionary." - satisfiedSet add: self. - satisfiedSet do: - [:sub | - aDictionary associationsDo: - [:aGlobal | - (sub whichSelectorsReferTo: aGlobal) isEmpty - ifFalse: [^self error: aGlobal key - , ' is still used in code of class ' - , sub name]]]. - sharedPools remove: aDictionary. - sharedPools isEmpty ifTrue: [sharedPools _ nil]! ! -!Class methodsFor: 'release' stamp: 'HAW 6/28/2020 16:32:41' prior: 16803101! - removeFromSystem: logged - "Forget the receiver from the Smalltalk global dictionary. Any existing - instances will refer to an obsolete version of the receiver." - - "keep the class name and category for triggering the system change message. If we wait to long, then we get obsolete information which is not what we want." - - "tell class to unload itself" - self unload. - self superclass ifNotNil: [:aSuperclass | - "If we have no superclass there's nothing to be remembered" - aSuperclass addObsoleteSubclass: self]. - Smalltalk forgetClass: self logged: logged. - self obsolete.! ! -!Metaclass methodsFor: 'accessing instances and variables' stamp: 'HAW 6/28/2020 11:38:18' overrides: 16784017! - allClassVarNames - - "Metaclasses do not define class vars - Hernan" - - ^superclass allClassVarNames! ! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'HAW 6/28/2020 11:34:48' prior: 16784017! - allClassVarNames - "Answer a Set of the names of the receiver's and the receiver's ancestor's - class variables." - - self subclassResponsibility ! ! - -ClassDescription removeSelector: #subclassesDo:! - -!methodRemoval: ClassDescription #subclassesDo: stamp: 'Install-4249-BehaviorHierarchyTypeErrorFixes-HernanWilkinson-JuanVuletich-2020Jun29-13h02m-jmv.001.cs.st 8/5/2020 22:22:43'! -subclassesDo: aBlock - "Evaluate the argument, aBlock, for each of the receiver's immediate subclasses." - ^self subclasses do: aBlock! - -ClassDescription removeSelector: #printSubclassesOn:level:! - -!methodRemoval: ClassDescription #printSubclassesOn:level: stamp: 'Install-4249-BehaviorHierarchyTypeErrorFixes-HernanWilkinson-JuanVuletich-2020Jun29-13h02m-jmv.001.cs.st 8/5/2020 22:22:43'! -printSubclassesOn: aStream level: level - "As part of the algorithm for printing a description of the receiver, print the - subclass on the file stream, aStream, indenting level times." - | subclassNames | - aStream newLineTab: level. - aStream nextPutAll: self name. - aStream - space; - print: self instVarNames. - self == Class ifTrue: [ - aStream - newLineTab: level + 1; - nextPutAll: '[ ... all the Metaclasses ... ]'. - ^ self ]. - subclassNames _ self subclasses asArray sort: [ :c1 :c2 | - c1 name <= c2 name ]. - "Print subclasses in alphabetical order" - subclassNames do: [ :subclass | - subclass - printSubclassesOn: aStream - level: level + 1 ].! - -ClassDescription removeSelector: #ultimateSourceCodeAt:ifAbsent:! - -!methodRemoval: ClassDescription #ultimateSourceCodeAt:ifAbsent: stamp: 'Install-4249-BehaviorHierarchyTypeErrorFixes-HernanWilkinson-JuanVuletich-2020Jun29-13h02m-jmv.001.cs.st 8/5/2020 22:22:43'! -ultimateSourceCodeAt: selector ifAbsent: aBlock - "Return the source code at selector, deferring to superclass if necessary" - ^ self sourceCodeAt: selector ifAbsent: - [superclass - ifNil: - [aBlock value] - ifNotNil: - [superclass ultimateSourceCodeAt: selector ifAbsent: aBlock]]! - -Behavior removeSelector: #becomeUncompact! - -!methodRemoval: Behavior #becomeUncompact stamp: 'Install-4249-BehaviorHierarchyTypeErrorFixes-HernanWilkinson-JuanVuletich-2020Jun29-13h02m-jmv.001.cs.st 8/5/2020 22:22:43'! -becomeUncompact - | cct index | - cct _ Smalltalk compactClassesArray. - (index _ self indexIfCompact) = 0 - ifTrue: [^ self]. - (cct includes: self) - ifFalse: [^ self halt "inconsistent state"]. - "Update instspec so future instances will not be compact" - format _ format - (index bitShift: 11). - "Make up new instances and become old ones into them" - self updateInstancesFrom: self. - "Make sure there are no compact ones left around" - Smalltalk garbageCollect. - "Remove this class from the compact class table" - cct at: index put: nil. -! - -Behavior removeSelector: #becomeCompact! - -!methodRemoval: Behavior #becomeCompact stamp: 'Install-4249-BehaviorHierarchyTypeErrorFixes-HernanWilkinson-JuanVuletich-2020Jun29-13h02m-jmv.001.cs.st 8/5/2020 22:22:43'! -becomeCompact - "Here are the restrictions on compact classes in order for export segments to work: A compact class index may not be reused. If a class was compact in a release of Squeak, no other class may use that index. The class might not be compact later, and there should be nil in its place in the array." - | cct index | - - Smalltalk isSpur ifTrue: [^ self halt: 'No Compact Classes support in Spur']. - self isWeak ifTrue:[^ self halt: 'You must not make a weak class compact']. - cct _ Smalltalk compactClassesArray. - (self indexIfCompact > 0 or: [cct includes: self]) - ifTrue: [^ self halt: self name , 'is already compact']. - index _ cct indexOf: nil - ifAbsent: [^ self halt: 'compact class table is full']. - "Install this class in the compact class table" - cct at: index put: self. - "Update instspec so future instances will be compact" - format _ format + (index bitShift: 11). - "Make up new instances and become old ones into them" - self updateInstancesFrom: self. - "Purge any old instances" - Smalltalk garbageCollect.! - -Behavior removeSelector: #allUnreferencedInstanceVariables! - -!methodRemoval: Behavior #allUnreferencedInstanceVariables stamp: 'Install-4249-BehaviorHierarchyTypeErrorFixes-HernanWilkinson-JuanVuletich-2020Jun29-13h02m-jmv.001.cs.st 8/5/2020 22:22:43'! -allUnreferencedInstanceVariables - - "Return a list of the instance variables known to the receiver which are not referenced in the receiver or any of its subclasses OR superclasses" - - ^ self allInstVarNames reject: [ :instanceVariableName | | definingClass | - definingClass _ self classThatDefinesInstanceVariable: instanceVariableName. - definingClass isInstanceVariableNamedReferencedInHierarchy: instanceVariableName ]! - -Behavior removeSelector: #becomeCompactSimplyAt:! - -!methodRemoval: Behavior #becomeCompactSimplyAt: stamp: 'Install-4249-BehaviorHierarchyTypeErrorFixes-HernanWilkinson-JuanVuletich-2020Jun29-13h02m-jmv.001.cs.st 8/5/2020 22:22:43'! -becomeCompactSimplyAt: index - "Make me compact, but don't update the instances. For importing segments." -"Here are the restrictions on compact classes in order for export segments to work: A compact class index may not be reused. If a class was compact in a release of Squeak, no other class may use that index. The class might not be compact later, and there should be nil in its place in the array." - | cct | - - Smalltalk isSpur ifTrue: [^ self halt: 'No Compact Classes support in Spur']. - self isWeak ifTrue:[^ self halt: 'You must not make a weak class compact']. - cct _ Smalltalk compactClassesArray. - (self indexIfCompact > 0 or: [cct includes: self]) - ifTrue: [^ self halt: self name , 'is already compact']. - (cct at: index) ifNotNil: [^ self halt: 'compact table slot already in use']. - "Install this class in the compact class table" - cct at: index put: self. - "Update instspec so future instances will be compact" - format _ format + (index bitShift: 11). - "Caller must convert the instances" -! - -Behavior removeSelector: #changeRecordsAt:! - -!methodRemoval: Behavior #changeRecordsAt: stamp: 'Install-4249-BehaviorHierarchyTypeErrorFixes-HernanWilkinson-JuanVuletich-2020Jun29-13h02m-jmv.001.cs.st 8/5/2020 22:22:43'! -changeRecordsAt: selector - "Return a list of ChangeRecords for all versions of the method at selector. Source code can be retrieved by sending string to any one. Return nil if the method is absent." - - "(Pen changeRecordsAt: #go:) collect: [:cRec | cRec string]" - | aList | - aList _ VersionsBrowser new - scanVersionsOf: (self compiledMethodAt: selector ifAbsent: [^ nil]) - class: self meta: self isMeta - category: (self whichCategoryIncludesSelector: selector) - selector: selector. - ^ aList ifNotNil: [aList changeList]! - -Behavior removeSelector: #allSharedPools! - -!methodRemoval: Behavior #allSharedPools stamp: 'Install-4249-BehaviorHierarchyTypeErrorFixes-HernanWilkinson-JuanVuletich-2020Jun29-13h02m-jmv.001.cs.st 8/5/2020 22:22:44'! -allSharedPools - "Answer a Set of the names of the pools (Dictionaries or SharedPool subclasses) that the receiver and the receiver's ancestors share." - - ^superclass allSharedPools! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4249-BehaviorHierarchyTypeErrorFixes-HernanWilkinson-JuanVuletich-2020Jun29-13h02m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4249] on 1 July 2020 at 5:10:38 pm'! -!KeyboardEvent methodsFor: 'testing' stamp: 'db 7/1/2020 17:09:47'! - isQuestionMark - - ^ self keyCharacter = $? ! ! -!AutoCompleter methodsFor: 'keyboard' stamp: 'db 7/1/2020 17:09:47' prior: 50436212! - handleKeystrokeBefore: kbEvent - - "I return a boolean. true when I have handled the event and no futher processing is needed by the caller." - - | shouldOpenMorph | - - shouldOpenMorph _ self shouldOpenMorph. - - "Stuff to do if the menu is not open" - menuMorph ifNil: [ ^ self openCompletionMenuFor: kbEvent if: shouldOpenMorph ]. - - "Starting here, stuff to do if the menu is open" - menuMorph stillActive. - - kbEvent isEsc ifTrue: [ self closeMenu. ^ true]. - kbEvent isBackspace ifTrue: [ shouldOpenMorph ifFalse: [ self closeMenu ]. ^ false]. - kbEvent isHome ifTrue: [ menuMorph goHome. ^ true ]. - kbEvent isEnd ifTrue: [ menuMorph goToEnd. ^ true]. - kbEvent isQuestionMark ifTrue: [ menuMorph help. ^true]. - kbEvent isArrowUp ifTrue: [ menuMorph goUp. ^ true]. - kbEvent isArrowDown ifTrue: [ menuMorph goDown. ^ true]. - kbEvent isPageUp ifTrue: [ menuMorph goPageUp. ^ true]. - kbEvent isPageDown ifTrue: [ menuMorph goPageDown. ^ true]. - - self canShowSelectorDocumentation - ifTrue: [ - kbEvent isArrowRight ifTrue: [ menuMorph showSelectorDocumentation. ^ true ]. - kbEvent isArrowLeft ifTrue: [ menuMorph hideSelectorDocumentation. ^ true ]] - ifFalse: [ - "If it is showing identifiers I eat the right arrow key because the user is used to it when - showing selectors, so to avoid an unexpected behavior I do nothing with it -Hernan" - kbEvent isArrowRight ifTrue: [ ^ true ]]. - - (self shouldInsertSelected: kbEvent) ifTrue: [ self insertSelected ifTrue: [^ true]]. - (self shouldCloseMenu: kbEvent) ifTrue: [ self closeMenu ]. - - ^false! ! - -KeyboardEvent removeSelector: #isQuesitonMark! - -!methodRemoval: KeyboardEvent #isQuesitonMark stamp: 'Install-4250-fixTypoInSelector-DouglasBrebner-2020Jul01-17h08m-db.001.cs.st 8/5/2020 22:22:44'! -isQuesitonMark - - ^ self keyCharacter = $? ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4250-fixTypoInSelector-DouglasBrebner-2020Jul01-17h08m-db.001.cs.st----! - -'From Cuis 5.0 [latest update: #4249] on 1 July 2020 at 5:36:25 pm'! -!RunNotArray commentStamp: '' prior: 16901565! - A replacement for RunArray that does not optimize space. Essentially just an array, with a few idiosyncratic methods for compatibility with RunArray. - -Rationale: When styling Smalltalk text, runs are very short. Space saving is not significant. Maybe 90% of the time is spent building and coalescing RunArrays. So, don't save space. Save time!!! -!Editor commentStamp: '' prior: 16836270! - New text editors. -TextEditor provides most of the functionality that used to be in TextMorphEditor. -SmalltalkEditor has Smalltalk code specific features. -SimpleEditor provides basic functionality for single line text editing. It does not handle fonts and styles, aligning and Smalltalk utilities. It handles one single line.! -!TextAlignment commentStamp: '' prior: 16930019! - Warning: TextAlignment and ParagraphStyleReference (What is this referring to?) should always be applied to whole 'paragraphs' in the text. See #isParagraphAttribute - -( -(Text string: 'This text has no style set', String crString), -(Text string: 'This is centered', String crString attribute: TextAlignment centered), -(Text string: 'This text has no style set', String crString) -) edit! -!StringMorph commentStamp: '' prior: 16918124! - StringMorph is a "lightweight" Morph to display a String. It supports only a single font, color, and emphasis combination. For multiple text styles, use TextModelMorph. - -Structure: -instance var Type Description -font StrikeFont (normally nil; then the accessor #font gives back a Font or nil #defaultFont) -emphasis SmallInteger bitmask determining character attributes (underline, bold, italics, struckThrough) -contents String The text that will be displayed. -! -!TaskbarMorph commentStamp: '' prior: 50337080! - A simple task bar written for Cuis. - -dashBoard contains views/controls -viewBox contains graphic buttons of "iconized" windows/morphs. -scale allows 1x 2x 4x taskbar height. [scale= 1,2,4]! -!AutoCompleter commentStamp: '' prior: 16781109! - An InnerTextMorph can have an autocompleter in the same way it might have a styler. My instances implement autocompletion.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4251-fixTyposInComments-DouglasBrebner-2020Jul01-17h10m-db.001.cs.st----! - -'From Cuis 5.0 [latest update: #4249] on 5 July 2020 at 4:48:41 pm'! -!String methodsFor: 'grammar' stamp: 'LC 7/5/2020 16:47:58' prior: 50507932! - article - | article first letter second | - self isEmpty ifTrue: [^self]. - article := self first isVowel ifTrue: ['an'] ifFalse: ['a']. - first := self first asLowercase. - letter := self size = 1. - second := letter ifFalse: [self second asLowercase]. - (first = $f and: [letter orNot: ['aeiloru' includes: second]]) - ifTrue: [^'an']. - first = $u ifTrue: [ - (letter or: ['cks' includes: second]) ifTrue: [^'a']. - second = $n - ifTrue: [(self size = 2 or: [self third isVowel]) ifTrue: [^'a']]]. - (first = $e and: [second = $u]) ifTrue: [^'a']. - ^article! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4252-article-tweaks-LeandroCaniglia-2020Jul05-16h47m-LC.001.cs.st----! - -'From Cuis 5.0 [latest update: #4249] on 6 July 2020 at 10:16:58 am'! - -BorderedRectMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity originalPosition showUp itemsPerPage ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #AutoCompleterMorph category: #'Tools-Autocompletion' stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:22:44'! -BorderedRectMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity originalPosition showUp itemsPerPage' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -AutoCompleterMorph subclass: #SmalltalkCompleterMorph - instanceVariableNames: 'selectorDocumentation' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #SmalltalkCompleterMorph category: #'Tools-Autocompletion' stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:22:44'! -AutoCompleterMorph subclass: #SmalltalkCompleterMorph - instanceVariableNames: 'selectorDocumentation' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! -!SmalltalkCompleterMorph commentStamp: '' prior: 0! - Specific for Smalltalk code.! -!SmalltalkCompleterMorph methodsFor: 'selector documentation' stamp: 'jmv 7/6/2020 09:28:19' overrides: 50433649! - crPressedOnSelectorDocumentation - - self hideSelectorDocumentation. - self activeHand newKeyboardFocus: completer textMorph ! ! -!SmalltalkCompleterMorph methodsFor: 'selector documentation' stamp: 'jmv 7/6/2020 09:26:11' overrides: 50433656! - hideSelectorDocumentation - - selectorDocumentation ifNotNil: [ selectorDocumentation hide ]. - self stillActive ! ! -!SmalltalkCompleterMorph methodsFor: 'selector documentation' stamp: 'jmv 7/6/2020 09:26:19' overrides: 50433663! - initializeSelectorDocumentation - - selectorDocumentation := TextModelMorph withText: ''. - selectorDocumentation textMorph - acceptOnCR: false; - crAction: [ self crPressedOnSelectorDocumentation ]. - - selectorDocumentation - wrapFlag: true; - borderColor: Color black; - borderWidth: 1; - disableEditing; - openInWorld - ! ! -!SmalltalkCompleterMorph methodsFor: 'selector documentation' stamp: 'jmv 7/6/2020 09:26:24' overrides: 50433676! - isShowingSelectorDocumentation - - ^selectorDocumentation notNil and: [ selectorDocumentation visible ]! ! -!SmalltalkCompleterMorph methodsFor: 'selector documentation' stamp: 'jmv 7/6/2020 09:27:58' overrides: 50433683! - methodDocumentationSeparator - - ^ Text - string: String newLineString, '------------------------------------------------------------------------------------------------', String newLineString - attribute: TextColor black.! ! -!SmalltalkCompleterMorph methodsFor: 'selector documentation' stamp: 'jmv 7/6/2020 09:27:17' overrides: 50446771! - selectorDefaultDocumentationLocation - - | relativeSelected | - - relativeSelected := (self selected - self firstVisible) min: self itemsPerPage - 1 max: 0. - - ^location externalizePosition: extent x@(relativeSelected * self itemHeight + 1). - - ! ! -!SmalltalkCompleterMorph methodsFor: 'selector documentation' stamp: 'jmv 7/6/2020 09:26:58' overrides: 50433704! - selectorDocumentation - - selectorDocumentation ifNil: [ self initializeSelectorDocumentation ]. - ^selectorDocumentation ! ! -!SmalltalkCompleterMorph methodsFor: 'selector documentation' stamp: 'jmv 7/6/2020 09:27:08' overrides: 50436693! - selectorDocumentationExtent - - ^`600@250`! ! -!SmalltalkCompleterMorph methodsFor: 'selector documentation' stamp: 'jmv 7/6/2020 09:27:22' overrides: 50433716! - selectorDocumentationText - - | selectedEntry selectorsClasses | - - selectedEntry := completer selectedEntry. - (completer isCategoryEntry: selectedEntry) ifTrue: [ ^'' ]. - selectedEntry := selectedEntry asSymbol. - selectorsClasses := completer selectorsClasses. - - ^ selectorsClasses isEmpty - ifTrue: [ self selectorDocumentationTextForAllImplementorsOf: selectedEntry ] - ifFalse: [ self selectorDocumentationTextOf: selectedEntry forAll: selectorsClasses ]. - ! ! -!SmalltalkCompleterMorph methodsFor: 'selector documentation' stamp: 'jmv 7/6/2020 09:27:27' overrides: 50433734! -selectorDocumentationTextForAllI: aMethodsCollection - - | selectorDocumentationText implementors methodDocumentationSeparator | - - selectorDocumentationText := Text new. - methodDocumentationSeparator := self methodDocumentationSeparator. - implementors := aMethodsCollection asSortedCollection: [ :leftMethod :rightMethod | leftMethod methodClass classDepth < rightMethod methodClass classDepth ]. - - implementors - do: [ :implementor | selectorDocumentationText := selectorDocumentationText append: (completer documentationOf: implementor)] - separatedBy: [ selectorDocumentationText := selectorDocumentationText append: methodDocumentationSeparator ]. - - ^ selectorDocumentationText! ! -!SmalltalkCompleterMorph methodsFor: 'selector documentation' stamp: 'jmv 7/6/2020 09:27:34' overrides: 50433759! - selectorDocumentationTextForAllImplementorsOf: selectedEntry - - ^ self selectorDocumentationTextForAllI: (Smalltalk allImplementorsOf: selectedEntry). - - ! ! -!SmalltalkCompleterMorph methodsFor: 'selector documentation' stamp: 'jmv 7/6/2020 09:27:38' overrides: 50433767! - selectorDocumentationTextOf: selectedEntry forAll: selectorsClasses - - | methodsToShow | - - methodsToShow := selectorsClasses - inject: IdentitySet new - into: [ :methods :aClass | - (aClass lookupSelector: selectedEntry) ifNotNil: [ :method | methods add: method ]. - methods ]. - - ^self selectorDocumentationTextForAllI: methodsToShow ! ! -!SmalltalkCompleterMorph methodsFor: 'selector documentation' stamp: 'jmv 7/6/2020 09:27:44' overrides: 50433781! - showSelectorDocumentation - - | selectorDocumentationLocation selectorDocumentationExtent | - - selectorDocumentationLocation := self selectorDefaultDocumentationLocation. - selectorDocumentationExtent := self selectorDocumentationExtent. - selectorDocumentationLocation := self adjust: selectorDocumentationLocation ifOutOfScreenWith: selectorDocumentationExtent xOffset: extent x yOffset: self itemHeight negated. - - self setDefaultColors. - - self selectorDocumentation - model: (TextModel withText: self selectorDocumentationText); - morphPosition: selectorDocumentationLocation extent: selectorDocumentationExtent; - wrapFlag: false; - show. - - ! ! -!SmalltalkCompleterMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 7/6/2020 09:28:43' overrides: 50433805! - delete - - selectorDocumentation ifNotNil: [ - selectorDocumentation delete. - selectorDocumentation := nil ]. - - ^super delete ! ! -!SmalltalkCompleterMorph methodsFor: 'actions' stamp: 'jmv 7/6/2020 10:12:40' overrides: 50446683! - resetMenu - - self hideSelectorDocumentation. - super resetMenu! ! -!SmalltalkCompleterMorph methodsFor: 'accessing' stamp: 'jmv 7/6/2020 10:15:33' overrides: 50446672! - selected: aNumber - "Set the value of selected" - - ((aNumber between: 1 and: self entryCount) and: [ aNumber ~= selected ]) - ifTrue: [ - selected _ aNumber. - self isShowingSelectorDocumentation ifTrue: [ self showSelectorDocumentation ]]! ! -!SmalltalkCompleterMorph methodsFor: 'stepping' stamp: 'jmv 7/6/2020 10:16:05' overrides: 50434360! - stepAt: millisecondSinceLast - - self isShowingSelectorDocumentation ifTrue: [ ^self ]. - super stepAt: millisecondSinceLast! ! -!AutoCompleter methodsFor: 'menu morph' stamp: 'jmv 7/6/2020 09:23:02'! - morphClass - ^AutoCompleterMorph! ! -!AutoCompleter methodsFor: 'keyboard' stamp: 'jmv 7/6/2020 10:05:22'! - handleLeftArrowKeystrokeBefore: kbEvent - "Subclasses might do something" - ^true! ! -!AutoCompleter methodsFor: 'keyboard' stamp: 'jmv 7/6/2020 10:05:28'! - handleRightArrowKeystrokeBefore: kbEvent - "Subclasses might do something" - ^true! ! -!ClassNameCompleter methodsFor: 'menu morph' stamp: 'jmv 7/6/2020 09:23:38' overrides: 50528918! - morphClass - ^SmalltalkCompleterMorph! ! -!SmalltalkCompleter methodsFor: 'menu morph' stamp: 'jmv 7/6/2020 09:23:50' overrides: 50528918! - morphClass - ^SmalltalkCompleterMorph! ! -!SmalltalkCompleter methodsFor: 'keyboard' stamp: 'jmv 7/6/2020 10:06:22' overrides: 50528922! - handleLeftArrowKeystrokeBefore: kbEvent - canShowSelectorDocumentation ifTrue: [ - menuMorph hideSelectorDocumentation ]. - ^ true! ! -!SmalltalkCompleter methodsFor: 'keyboard' stamp: 'jmv 7/6/2020 10:06:11' overrides: 50528927! - handleRightArrowKeystrokeBefore: kbEvent - canShowSelectorDocumentation ifTrue: [ - menuMorph showSelectorDocumentation ]. - ^ true! ! -!AutoCompleterMorph methodsFor: 'accessing' stamp: 'jmv 7/6/2020 10:15:09' prior: 50446672! - selected: aNumber - "Set the value of selected" - - ((aNumber between: 1 and: self entryCount) and: [ aNumber ~= selected ]) - ifTrue: [ - selected _ aNumber ]! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'jmv 7/6/2020 10:12:50' prior: 50446683! - resetMenu - | width newExtent | - - self calculateItemsPerPage. - - self firstVisible: 1. - self selected: self firstSelectableEntryIndex. - - width _ self calculateWidth. - newExtent _ width + 4 @ (self itemsPerPage * self itemHeight + 2). - - self morphPosition: originalPosition extent: newExtent. - "redraw is needed even if position and extent haven't changed" - self redrawNeeded ! ! -!AutoCompleterMorph methodsFor: 'stepping' stamp: 'jmv 7/6/2020 10:16:14' prior: 50434360 overrides: 16876536! - stepAt: millisecondSinceLast - - self timeOfLastActivity > self timeout - ifTrue: [ self delete. completer menuClosed ] - ifFalse: [self updateColor]! ! -!AutoCompleterMorph class methodsFor: 'instance creation' stamp: 'jmv 7/6/2020 09:24:40' prior: 50385094 overrides: 16877229! - initializedInstance - | completer m | - completer _ SmalltalkCompleter withModel: (TextModel withText: 'Small'). - completer - instVarNamed: 'position' - put: 5. - completer computeEntries. - m _ completer morphClass - completer: completer - position: `200 @ 200`. - completer instVarNamed: 'menuMorph' put: m. - ^m! ! -!AutoCompleter methodsFor: 'menu morph' stamp: 'jmv 7/6/2020 09:24:31' prior: 50434384! - openCompletionMenu - - | theEditor | - - theEditor _ textMorph editor. - position _ theEditor startIndex - 1. - self closeMenu. - self computeEntries. - entries notEmpty - ifTrue: [ | startIndex characterBlock cursorIndex | - cursorIndex := theEditor pointIndex. - startIndex := (theEditor text at: cursorIndex-1) = Character space - ifTrue: [ cursorIndex ] - ifFalse: [ theEditor previousWordStart: (cursorIndex > theEditor text size ifTrue: [ cursorIndex-1 ] ifFalse: [ cursorIndex ])]. - characterBlock := theEditor characterBlockForIndex: startIndex. - menuMorph _ self morphClass - completer: self - position: characterBlock bottomLeft + textMorph morphPositionInWorld ]. -! ! -!AutoCompleter methodsFor: 'keyboard' stamp: 'jmv 7/6/2020 10:10:44' prior: 50528505! - handleKeystrokeBefore: kbEvent - "I return a boolean. true when I have handled the event and no futher processing is needed by the caller." - - | shouldOpenMorph | - shouldOpenMorph _ self shouldOpenMorph. - - "Stuff to do if the menu is not open" - menuMorph ifNil: [ ^ self openCompletionMenuFor: kbEvent if: shouldOpenMorph ]. - - "Starting here, stuff to do if the menu is open" - menuMorph stillActive. - - kbEvent isEsc ifTrue: [ self closeMenu. ^ true]. - kbEvent isBackspace ifTrue: [ shouldOpenMorph ifFalse: [ self closeMenu ]. ^ false]. - kbEvent isHome ifTrue: [ menuMorph goHome. ^ true ]. - kbEvent isEnd ifTrue: [ menuMorph goToEnd. ^ true]. - kbEvent isQuestionMark ifTrue: [ menuMorph help. ^true]. - kbEvent isArrowUp ifTrue: [ menuMorph goUp. ^ true]. - kbEvent isArrowDown ifTrue: [ menuMorph goDown. ^ true]. - kbEvent isPageUp ifTrue: [ menuMorph goPageUp. ^ true]. - kbEvent isPageDown ifTrue: [ menuMorph goPageDown. ^ true]. - - kbEvent isArrowRight ifTrue: [ ^self handleRightArrowKeystrokeBefore: kbEvent ]. - kbEvent isArrowLeft ifTrue: [ ^self handleLeftArrowKeystrokeBefore: kbEvent ]. - - (self shouldInsertSelected: kbEvent) ifTrue: [ self insertSelected ifTrue: [^ true]]. - (self shouldCloseMenu: kbEvent) ifTrue: [ self closeMenu ]. - - ^false! ! - -SmalltalkCompleter removeSelector: #handleKeystrokeBefore:! - -SmalltalkCompleter removeSelector: #canShowSelectorDocumentation! - -!methodRemoval: SmalltalkCompleter #canShowSelectorDocumentation stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:22:44'! -canShowSelectorDocumentation - - ^canShowSelectorDocumentation ! - -ClassNameCompleter removeSelector: #canShowSelectorDocumentation! - -!methodRemoval: ClassNameCompleter #canShowSelectorDocumentation stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:22:44'! -canShowSelectorDocumentation - - ^false! - -AutoCompleter removeSelector: #canShowSelectorDocumentation! - -!methodRemoval: AutoCompleter #canShowSelectorDocumentation stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:22:44'! -canShowSelectorDocumentation - - self subclassResponsibility! - -AutoCompleterMorph removeSelector: #isShowingSelectorDocumentation! - -!methodRemoval: AutoCompleterMorph #isShowingSelectorDocumentation stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:22:44'! -isShowingSelectorDocumentation - - ^selectorDocumentation notNil and: [ selectorDocumentation visible ]! - -AutoCompleterMorph removeSelector: #selectorDefaultDocumentationLocation! - -!methodRemoval: AutoCompleterMorph #selectorDefaultDocumentationLocation stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:22:44'! -selectorDefaultDocumentationLocation - - | relativeSelected | - - relativeSelected := (self selected - self firstVisible) min: self itemsPerPage - 1 max: 0. - - ^location externalizePosition: extent x@(relativeSelected * self itemHeight + 1). - - ! - -AutoCompleterMorph removeSelector: #methodDocumentationSeparator! - -!methodRemoval: AutoCompleterMorph #methodDocumentationSeparator stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:22:44'! -methodDocumentationSeparator - - ^ Text - string: String newLineString, '------------------------------------------------------------------------------------------------', String newLineString - attribute: TextColor black.! - -AutoCompleterMorph removeSelector: #initializeSelectorDocumentation! - -!methodRemoval: AutoCompleterMorph #initializeSelectorDocumentation stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:22:44'! -initializeSelectorDocumentation - - selectorDocumentation := TextModelMorph withText: ''. - selectorDocumentation textMorph - acceptOnCR: false; - crAction: [ self crPressedOnSelectorDocumentation ]. - - selectorDocumentation - wrapFlag: true; - borderColor: Color black; - borderWidth: 1; - disableEditing; - openInWorld - ! - -AutoCompleterMorph removeSelector: #selectorDocumentationExtent! - -!methodRemoval: AutoCompleterMorph #selectorDocumentationExtent stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:22:44'! -selectorDocumentationExtent - - ^`600@250`! - -AutoCompleterMorph removeSelector: #selectorDocumentationTextOf:forAll:! - -!methodRemoval: AutoCompleterMorph #selectorDocumentationTextOf:forAll: stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:22:44'! -selectorDocumentationTextOf: selectedEntry forAll: selectorsClasses - - | methodsToShow | - - methodsToShow := selectorsClasses - inject: IdentitySet new - into: [ :methods :aClass | - (aClass lookupSelector: selectedEntry) ifNotNil: [ :method | methods add: method ]. - methods ]. - - ^self selectorDocumentationTextForAllI: methodsToShow ! - -AutoCompleterMorph removeSelector: #showSelectorDocumentation! - -!methodRemoval: AutoCompleterMorph #showSelectorDocumentation stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:22:44'! -showSelectorDocumentation - - | selectorDocumentationLocation selectorDocumentationExtent | - - selectorDocumentationLocation := self selectorDefaultDocumentationLocation. - selectorDocumentationExtent := self selectorDocumentationExtent. - selectorDocumentationLocation := self adjust: selectorDocumentationLocation ifOutOfScreenWith: selectorDocumentationExtent xOffset: extent x yOffset: self itemHeight negated. - - self setDefaultColors. - - self selectorDocumentation - model: (TextModel withText: self selectorDocumentationText); - morphPosition: selectorDocumentationLocation extent: selectorDocumentationExtent; - wrapFlag: false; - show. - - ! - -AutoCompleterMorph removeSelector: #crPressedOnSelectorDocumentation! - -!methodRemoval: AutoCompleterMorph #crPressedOnSelectorDocumentation stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:22:44'! -crPressedOnSelectorDocumentation - - self hideSelectorDocumentation. - self activeHand newKeyboardFocus: completer textMorph ! - -AutoCompleterMorph removeSelector: #selectorDocumentation! - -!methodRemoval: AutoCompleterMorph #selectorDocumentation stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:22:44'! -selectorDocumentation - - selectorDocumentation ifNil: [ self initializeSelectorDocumentation ]. - ^selectorDocumentation ! - -AutoCompleterMorph removeSelector: #selectorDocumentationTextForAllI:! - -!methodRemoval: AutoCompleterMorph #selectorDocumentationTextForAllI: stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:22:44'! -selectorDocumentationTextForAllI: aMethodsCollection - - | selectorDocumentationText implementors methodDocumentationSeparator | - - selectorDocumentationText := Text new. - methodDocumentationSeparator := self methodDocumentationSeparator. - implementors := aMethodsCollection asSortedCollection: [ :leftMethod :rightMethod | leftMethod methodClass classDepth < rightMethod methodClass classDepth ]. - - implementors - do: [ :implementor | selectorDocumentationText := selectorDocumentationText append: (completer documentationOf: implementor)] - separatedBy: [ selectorDocumentationText := selectorDocumentationText append: methodDocumentationSeparator ]. - - ^ selectorDocumentationText! - -AutoCompleterMorph removeSelector: #selectorDocumentationTextForAllImplementorsOf:! - -!methodRemoval: AutoCompleterMorph #selectorDocumentationTextForAllImplementorsOf: stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:22:44'! -selectorDocumentationTextForAllImplementorsOf: selectedEntry - - ^ self selectorDocumentationTextForAllI: (Smalltalk allImplementorsOf: selectedEntry). - - ! - -AutoCompleterMorph removeSelector: #hideSelectorDocumentation! - -!methodRemoval: AutoCompleterMorph #hideSelectorDocumentation stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:22:44'! -hideSelectorDocumentation - - selectorDocumentation ifNotNil: [ selectorDocumentation hide ]. - self stillActive ! - -AutoCompleterMorph removeSelector: #selectorDocumentationText! - -!methodRemoval: AutoCompleterMorph #selectorDocumentationText stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:22:44'! -selectorDocumentationText - - | selectedEntry selectorsClasses | - - selectedEntry := completer selectedEntry. - (completer isCategoryEntry: selectedEntry) ifTrue: [ ^'' ]. - selectedEntry := selectedEntry asSymbol. - selectorsClasses := completer selectorsClasses. - - ^ selectorsClasses isEmpty - ifTrue: [ self selectorDocumentationTextForAllImplementorsOf: selectedEntry ] - ifFalse: [ self selectorDocumentationTextOf: selectedEntry forAll: selectorsClasses ]. - ! - -AutoCompleterMorph removeSelector: #delete! - -!methodRemoval: AutoCompleterMorph #delete stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:22:44'! -delete - - selectorDocumentation ifNotNil: [ - selectorDocumentation delete. - selectorDocumentation := nil ]. - - ^super delete ! - -BorderedRectMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity originalPosition showUp itemsPerPage' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #AutoCompleterMorph category: #'Tools-Autocompletion' stamp: 'Install-4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st 8/5/2020 22:22:44'! -BorderedRectMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity originalPosition showUp itemsPerPage' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4253-AutoCompleterNotSmalltalkSpecific-JuanVuletich-2020Jul06-09h21m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4253] on 12 July 2020 at 7:19:18 pm'! - -"Change Set: 4254-CuisCore-AuthorName-2020Jul12-15h05m -Date: 12 July 2020 -Author: Nahuel Garbezza - -Improvements on ExtractMethod and ExtractToTemporary refactorings: - -* update class comments and introduce new ones for some classes -* extract source code interval validations from the extract temporary class to a precondition class -* make hierarchy of source code preconditions for extract method and extract temporary -* fix a bug where argument names from the method signature can be extracted -* renamed ExtractMethodNewSelectorPrecondition to NewSelectorPrecondition because it does not have anything in particular for extract method"! -!RefactoringWarning commentStamp: '' prior: 0! - I represent a situation that needs user intervention, in the scope of refactorings. It can be resumed or not. For instance, trying to override an existing method.! -!ExtractMethod commentStamp: '' prior: 50497252! - I am a refactoring that extracts a selected piece of code to a separate method. The input is the following: - -* interval of code to extract (from index - to index) -* the CompiledMethod where this change applies -* the new method selector + argument names (instance of Message) -* the category name for the new method - -Many conditions have to be satisfied for this refactoring to be made, I delegate into SourceCodeOfMethodToBeExtractedPrecondition and NewSelectorPrecondition most of these checks. Refer to those classes' comments for more information.! -!ExtractToTemporary commentStamp: '' prior: 0! - I am a refactoring that extracts a selected piece of code to a temporary variable. The input is the following: - -* interval of code to extract (from index - to index) -* the CompiledMethod where this change applies -* the new temporary variable name - -Many conditions have to be satisfied for this refactoring to be made, I delegate into SourceCodeOfTemporaryToBeExtractedPrecondition and NewTemporaryPrecondition most of these checks. Refer to those classes' comments for more information.! -!NewInstanceVariablePrecondition commentStamp: '' prior: 0! - I am responsible for checking if a new instance variable can be introduced in a specific class. If that is not possible, I raise a refactoring error.! - -Smalltalk renameClassNamed: #ExtractMethodNewSelectorPrecondition as: #NewSelectorPrecondition! - -!classRenamed: #ExtractMethodNewSelectorPrecondition as: #NewSelectorPrecondition stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -Smalltalk renameClassNamed: #ExtractMethodNewSelectorPrecondition as: #NewSelectorPrecondition! -!NewSelectorPrecondition commentStamp: '' prior: 0! - I am responsible for checking if a new method with a given name can be introduced in a specific class. If that is not possible, I raise a refactoring error.! - -RefactoringPrecondition subclass: #SourceCodeIntervalPrecondition - instanceVariableNames: 'intervalToExtract method sourceCode methodNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #SourceCodeIntervalPrecondition category: #'Tools-Refactoring' stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -RefactoringPrecondition subclass: #SourceCodeIntervalPrecondition - instanceVariableNames: 'intervalToExtract method sourceCode methodNode' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!SourceCodeIntervalPrecondition commentStamp: '' prior: 0! - I am an abstract class that validates things that are required for source code intervals.! - -SourceCodeIntervalPrecondition subclass: #SourceCodeOfMethodToBeExtractedPrecondition - instanceVariableNames: 'initialNode finalNode initialNodeAncestors finalNodeAncestors ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #SourceCodeOfMethodToBeExtractedPrecondition category: #'Tools-Refactoring' stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -SourceCodeIntervalPrecondition subclass: #SourceCodeOfMethodToBeExtractedPrecondition - instanceVariableNames: 'initialNode finalNode initialNodeAncestors finalNodeAncestors' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!SourceCodeOfMethodToBeExtractedPrecondition commentStamp: '' prior: 50517130! - I check if a piece of source code selected for ExtractMethod can actually be extracted. - -Many conditions have to happen: -* we are selecting from the beginning of an AST node to an end of an AST node -* it is a smalltalk expression, a single statement or a sequence of complete statements -* the expression does not contain returns, or temporary variable assignments (if there is a temporary variable assignment, the declaration and all the usages should be extracted as well)! - -SourceCodeIntervalPrecondition subclass: #SourceCodeOfTemporaryToBeExtractedPrecondition - instanceVariableNames: 'sourceCodeToExtract parseNodeToExtract' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #SourceCodeOfTemporaryToBeExtractedPrecondition category: #'Tools-Refactoring' stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -SourceCodeIntervalPrecondition subclass: #SourceCodeOfTemporaryToBeExtractedPrecondition - instanceVariableNames: 'sourceCodeToExtract parseNodeToExtract' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!SourceCodeOfTemporaryToBeExtractedPrecondition commentStamp: '' prior: 0! - I check if a piece of source code selected for ExtractToTemporary can actually be extracted. - -Many conditions have to happen: -* we are selecting from the beginning of an AST node to an end of an AST node -* it is a complete smalltalk expression, a single statement or a sequence of complete statements -* the expression does not contain returns, nor assignments! -!SourceCodeIntervalPrecondition methodsFor: 'evaluating' stamp: 'RNG 7/12/2020 18:53:35' overrides: 50497304! - value - - self subclassResponsibility! ! -!SourceCodeIntervalPrecondition methodsFor: 'exceptions' stamp: 'RNG 7/12/2020 18:56:32'! - signalExtractingPartOfMethodSignatureError - - self refactoringError: self class errorMessageForExtractingPartOfMethodSignature! ! -!SourceCodeIntervalPrecondition methodsFor: 'exceptions' stamp: 'RNG 7/12/2020 18:56:36'! - signalExtractingTemporaryVariableDefinitionError - - self refactoringError: self class errorMessageForExtractingTemporaryVariablesDefinition! ! -!SourceCodeIntervalPrecondition methodsFor: 'exceptions' stamp: 'RNG 7/12/2020 18:57:12'! - signalSourceCodeContainsAnInvalidExpressionError - - self refactoringError: self class errorMessageForSourceCodeContainingInvalidExpression! ! -!SourceCodeIntervalPrecondition methodsFor: 'exceptions' stamp: 'RNG 7/12/2020 18:54:41'! - signalSourceCodeIncludesAReturnStatementError - - self refactoringError: self class errorMessageForSourceCodeIncludingAReturnStatement! ! -!SourceCodeIntervalPrecondition methodsFor: 'initialization' stamp: 'RNG 7/12/2020 19:02:30'! - initializeFor: anIntervalToExtract of: aMethodUnderValidation - - intervalToExtract := anIntervalToExtract. - method := aMethodUnderValidation. - methodNode := method methodNode. - sourceCode := method sourceCode.! ! -!SourceCodeIntervalPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 7/12/2020 18:54:20'! - assertSourceCodeDoesNotIncludeReturnExpressions - - self thereAreReturnExpressions - ifTrue: [ self signalSourceCodeIncludesAReturnStatementError ]! ! -!SourceCodeIntervalPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 7/12/2020 18:56:09'! - assertSourceCodeIsNotPartOfMethodSignature - - self intervalToExtractIncludesPartOfMethodSignature - ifTrue: [ self signalExtractingPartOfMethodSignatureError ]! ! -!SourceCodeIntervalPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 7/12/2020 18:56:16'! -assertSourceCodeIsNotPartOfTemporariesDeclaration - - self isNotInsideATempDeclaration - ifFalse: [ self signalExtractingTemporaryVariableDefinitionError ]! ! -!SourceCodeIntervalPrecondition methodsFor: 'private' stamp: 'RNG 7/12/2020 19:03:03'! - firstParseNodeOfMethodDefinition - - ^ methodNode hasTemporaryVariables - ifTrue: [ methodNode temporariesDeclaration ] - ifFalse: [ methodNode block statements first - ifNotNil: [ :statement | statement ] - ifNil: [ methodNode ] ]! ! -!SourceCodeIntervalPrecondition methodsFor: 'private' stamp: 'RNG 7/12/2020 19:03:15'! - intervalToExtractIncludesPartOfMethodSignature - - ^ intervalToExtract first < self methodDefinitionStartPosition! ! -!SourceCodeIntervalPrecondition methodsFor: 'private' stamp: 'RNG 7/12/2020 19:05:39'! - intervalToExtractIsIncludedInAnyOf: sourceRanges - - ^ sourceRanges anySatisfy: [ :sourceRange | - sourceRange first <= intervalToExtract first and: [ sourceRange last >= intervalToExtract last ] ]! ! -!SourceCodeIntervalPrecondition methodsFor: 'private' stamp: 'RNG 7/12/2020 19:03:37'! - isNotInsideATempDeclaration - - methodNode completeSourceRangesDo: [ :parseNode :sourceRanges | - (parseNode isTemporariesDeclaration - and: [ self intervalToExtractIsIncludedInAnyOf: sourceRanges ]) - ifTrue: [ ^ false ] ]. - ^ true! ! -!SourceCodeIntervalPrecondition methodsFor: 'private' stamp: 'RNG 7/12/2020 19:03:22'! - methodDefinitionStartPosition - - ^ methodNode - singleCompleteSourceRangeOf: self firstParseNodeOfMethodDefinition - ifPresent: [ :sourceRange | sourceRange first ] - ifAbsent: [ sourceCode size ]! ! -!SourceCodeIntervalPrecondition methodsFor: 'private' stamp: 'RNG 7/12/2020 19:03:28'! - thereAreReturnExpressions - - ^ (methodNode - allParseNodesWithin: intervalToExtract - satisfy: [ :parseNode | parseNode isReturn ]) not! ! -!SourceCodeIntervalPrecondition class methodsFor: 'instance creation' stamp: 'RNG 7/12/2020 19:07:02'! - for: anIntervalToExtract of: aMethod - - ^ self new initializeFor: anIntervalToExtract of: aMethod! ! -!SourceCodeIntervalPrecondition class methodsFor: 'evaluating' stamp: 'RNG 7/12/2020 19:07:07'! - valueFor: anIntervalToExtract of: aMethod - - ^ (self for: anIntervalToExtract of: aMethod) value! ! -!SourceCodeIntervalPrecondition class methodsFor: 'private - error messages' stamp: 'RNG 7/12/2020 19:07:39'! - refactoringErrorMessagePrefix - - self subclassResponsibility! ! -!SourceCodeIntervalPrecondition class methodsFor: 'error messages' stamp: 'RNG 7/12/2020 19:08:04'! - errorMessageForExtractingPartOfMethodSignature - - ^ self refactoringErrorMessagePrefix , 'it is not possible to extract part of method signature'! ! -!SourceCodeIntervalPrecondition class methodsFor: 'error messages' stamp: 'RNG 7/12/2020 19:08:09'! - errorMessageForExtractingTemporaryVariablesDefinition - - ^ self refactoringErrorMessagePrefix , 'it is not possible to extract temporary variable definitions'! ! -!SourceCodeIntervalPrecondition class methodsFor: 'error messages' stamp: 'RNG 7/12/2020 19:08:19'! - errorMessageForSourceCodeContainingInvalidExpression - - ^ self refactoringErrorMessagePrefix , 'the selected code contains an invalid expression'! ! -!SourceCodeIntervalPrecondition class methodsFor: 'error messages' stamp: 'RNG 7/12/2020 19:08:23'! - errorMessageForSourceCodeIncludingAReturnStatement - - ^ self refactoringErrorMessagePrefix , 'the selected code includes a return statement'! ! -!SourceCodeOfMethodToBeExtractedPrecondition class methodsFor: 'private - error messages' stamp: 'RNG 7/12/2020 15:57:25' overrides: 50529691! - refactoringErrorMessagePrefix - - ^ 'Cannot extract method: '! ! -!SourceCodeOfTemporaryToBeExtractedPrecondition methodsFor: 'evaluating' stamp: 'RNG 7/12/2020 16:52:51' overrides: 50529552! - value - - self - initializeParseNodeToExtract; - assertSourceCodeDoesNotIncludeReturnExpressions; - assertSourceCodeIsNotPartOfTemporariesDeclaration; - assertSourceCodeIsNotPartOfMethodSignature; - assertSourceCodeHasOneStatement; - assertSourceCodeIsACompleteExpression; - assertSourceCodeContainValidNodes! ! -!SourceCodeOfTemporaryToBeExtractedPrecondition methodsFor: 'exceptions' stamp: 'RNG 7/12/2020 17:04:38'! -signalCollaborationToExtractHasSyntaxError: aSyntaxErrorNotification - - self refactoringError: (self class errorMessageForSourceCodeToExtractHasSyntaxError: aSyntaxErrorNotification messageText)! ! -!SourceCodeOfTemporaryToBeExtractedPrecondition methodsFor: 'exceptions' stamp: 'RNG 7/12/2020 17:04:50'! - signalCollaborationToExtractHasToBeOneStatementError - - self refactoringError: self class errorMessageForSourceCodeToExtractHasToBeOneStatement! ! -!SourceCodeOfTemporaryToBeExtractedPrecondition methodsFor: 'initialization' stamp: 'RNG 7/12/2020 19:02:49' overrides: 50529588! - initializeFor: anIntervalToExtract of: aMethodUnderValidation - - super initializeFor: anIntervalToExtract of: aMethodUnderValidation. - sourceCodeToExtract := sourceCode copyFrom: intervalToExtract first to: intervalToExtract last! ! -!SourceCodeOfTemporaryToBeExtractedPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 7/12/2020 18:58:24'! - assertSourceCodeContainValidNodes - - self parseNodeUnderIntervalToExtractCanBeExtractedToAVariable - ifFalse: [ self signalSourceCodeContainsAnInvalidExpressionError ]! ! -!SourceCodeOfTemporaryToBeExtractedPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 7/12/2020 17:03:34'! - assertSourceCodeHasOneStatement - - parseNodeToExtract numberOfStatements ~= 1 - ifTrue: [ self signalCollaborationToExtractHasToBeOneStatementError ]! ! -!SourceCodeOfTemporaryToBeExtractedPrecondition methodsFor: 'pre-conditions' stamp: 'RNG 7/12/2020 16:26:44'! - assertSourceCodeIsACompleteExpression - - self anySourceRangeMatchesExactlyTheIntervalToExtract - ifFalse: [ self signalSourceCodeContainsAnInvalidExpressionError ]! ! -!SourceCodeOfTemporaryToBeExtractedPrecondition methodsFor: 'private' stamp: 'RNG 7/12/2020 17:08:18'! - anySourceRangeMatchesExactlyTheIntervalToExtract - - | sourceRangeCollections allSourceRanges | - sourceRangeCollections := methodNode completeSourceRanges values. - allSourceRanges := sourceRangeCollections - inject: Set new - into: [ :sourceRanges :sourceRangeCollection | sourceRanges addAll: sourceRangeCollection; yourself ]. - ^ allSourceRanges anySatisfy: [ :sourceRange | - (sourceRange trimToMatchExpressionOn: sourceCode) = intervalToExtract ]! ! -!SourceCodeOfTemporaryToBeExtractedPrecondition methodsFor: 'private' stamp: 'RNG 7/12/2020 17:03:15'! - initializeParseNodeToExtract - - parseNodeToExtract := [ Parser parse: sourceCodeToExtract class: method methodClass noPattern: true ] - on: SyntaxErrorNotification - do: [ :anError | self signalCollaborationToExtractHasSyntaxError: anError ]! ! -!SourceCodeOfTemporaryToBeExtractedPrecondition methodsFor: 'private' stamp: 'RNG 7/12/2020 17:07:28'! - parseNodeUnderIntervalToExtractCanBeExtractedToAVariable - - methodNode completeSourceRangesDo: [ :parseNode :sourceRanges | - (parseNode isAssignmentNode - and: [ sourceRanges anySatisfy: [ :sourceRange | sourceRange first = intervalToExtract first ] ]) - ifTrue: [ ^ false ] - ]. - ^ true! ! -!SourceCodeOfTemporaryToBeExtractedPrecondition class methodsFor: 'error messages' stamp: 'RNG 7/12/2020 16:54:14'! - errorMessageForSourceCodeToExtractHasSyntaxError: anErrorDescription - - ^ 'Can not extract a source code with syntax error: ', anErrorDescription ! ! -!SourceCodeOfTemporaryToBeExtractedPrecondition class methodsFor: 'error messages' stamp: 'RNG 7/12/2020 16:19:18'! - errorMessageForSourceCodeToExtractHasToBeOneStatement - - ^ self refactoringErrorMessagePrefix , 'cannot extract more than one statement'! ! -!SourceCodeOfTemporaryToBeExtractedPrecondition class methodsFor: 'private - error messages' stamp: 'RNG 7/12/2020 15:58:44' overrides: 50529691! - refactoringErrorMessagePrefix - - ^ 'Cannot extract temporary: '! ! -!MethodNode methodsFor: 'testing' stamp: 'RNG 7/12/2020 16:57:24' prior: 50503003! - anyParseNodeWithin: aSourceCodeInterval satisfy: aCondition - - self completeSourceRangesDo: [ :parseNode :sourceRanges | - (aCondition value: parseNode) ifTrue: [ - (sourceRanges anySatisfy: [ :sourceRange | aSourceCodeInterval rangeIncludes: sourceRange first ]) - ifTrue: [ ^ true ] ] ]. - ^ false! ! -!ExtractMethod class methodsFor: 'private - pre-conditions' stamp: 'RNG 7/12/2020 19:13:15' prior: 50492009! - assert: aSelector canBeDefinedIn: aClass - - NewSelectorPrecondition valueFor: aSelector on: aClass! ! -!ExtractToTemporary class methodsFor: 'preconditions' stamp: 'RNG 7/12/2020 16:58:30' prior: 50512675! - assertCanApplyRefactoringOn: aMethodToRefactor at: anIntervalToExtract - - | trimmedSourceCodeToExtract sourceCodeToExtract trimmedIntervalToExtract originalSourceCode | - - self assert: anIntervalToExtract isValidIntervalOn: aMethodToRefactor. - originalSourceCode := aMethodToRefactor sourceCode. - sourceCodeToExtract := originalSourceCode copyFrom: anIntervalToExtract first to: anIntervalToExtract last. - trimmedSourceCodeToExtract := sourceCodeToExtract withBlanksTrimmed. - trimmedIntervalToExtract := anIntervalToExtract trimToMatchExpressionOn: originalSourceCode. - self assertSourceCodeIsNotEmpty: trimmedSourceCodeToExtract. - - SourceCodeOfTemporaryToBeExtractedPrecondition - valueFor: trimmedIntervalToExtract of: aMethodToRefactor! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'evaluating' stamp: 'RNG 7/12/2020 15:05:27' prior: 50517313 overrides: 50529552! - value - - self - initializeParseNodesMatchingSelectionInterval; - assertSourceCodeDoesNotIncludeReturnExpressions; - assertSourceCodeIsNotLeftSideOfAssignment; - assertSourceCodeIsNotPartOfTemporariesDeclaration; - assertSourceCodeIsNotPartOfMethodSignature; - assertSourceCodeDoesNotIncludeTemporaryAssignmentsWithoutDeclaration; - assertSourceCodeDoesNotHaveTemporaryVariablesUsedOutsideOfSelectionInterval; - assertSourceCodeContainsAValidExpression! ! -!SourceCodeOfMethodToBeExtractedPrecondition class methodsFor: 'error messages' stamp: 'RNG 7/12/2020 15:57:56' prior: 50517479! - errorMessageForExtractedTemporaryAssignmentWithoutItsDeclaration - - ^ self refactoringErrorMessagePrefix , 'an assignment is being extracted without its declaration'! ! -!SourceCodeOfMethodToBeExtractedPrecondition class methodsFor: 'error messages' stamp: 'RNG 7/12/2020 15:58:04' prior: 50517488! - errorMessageForExtractingLeftSideOfAssignment - - ^ self refactoringErrorMessagePrefix , 'it is not possible to extract the left side of an assignment'! ! -!SourceCodeOfMethodToBeExtractedPrecondition class methodsFor: 'error messages' stamp: 'RNG 7/12/2020 15:58:17' prior: 50517524! - errorMessageForTemporaryAssignmentWithUsagesOutsideOfSelectionInterval - - ^ self refactoringErrorMessagePrefix , 'there are temporary variables used outside of the code selection'! ! - -SourceCodeOfTemporaryToBeExtractedPrecondition class removeSelector: #errorMessageForExtractingPartOfMethodSignature! - -SourceCodeOfTemporaryToBeExtractedPrecondition class removeSelector: #errorMessageForExtractedTemporaryAssignmentWithoutItsDeclaration! - -SourceCodeOfTemporaryToBeExtractedPrecondition class removeSelector: #errorMessageForSourceCodeContainingInvalidExpression! - -SourceCodeOfTemporaryToBeExtractedPrecondition class removeSelector: #extractMethodErrorMessagePrefix! - -SourceCodeOfTemporaryToBeExtractedPrecondition class removeSelector: #errorMessageForExtractingTemporaryVariablesDefinition! - -SourceCodeOfTemporaryToBeExtractedPrecondition class removeSelector: #for:of:! - -SourceCodeOfTemporaryToBeExtractedPrecondition class removeSelector: #errorMessageForSourceCodeIncludingAReturnStatement! - -SourceCodeOfTemporaryToBeExtractedPrecondition class removeSelector: #errorMessageForSourceCodeToExtractCanNotIncludeReturn! - -SourceCodeOfTemporaryToBeExtractedPrecondition class removeSelector: #errorMessageForTemporaryAssignmentWithUsagesOutsideOfSelectionInterval! - -SourceCodeOfTemporaryToBeExtractedPrecondition class removeSelector: #errorMessageForExtractingLeftSideOfAssignment! - -SourceCodeOfTemporaryToBeExtractedPrecondition class removeSelector: #valueFor:of:! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #thereAreNoLocalVariableAssignmentsWithoutDeclaration! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #assertSourceCodeDoesNotIncludeReturnExpressions! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #assertSourceCodeIsNotLeftSideOfAssignment! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #assertSourceCodeDoesNotIncludeTemporaryAssignmentsWithoutDeclaration! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #intervalMatchesBeginningOfStatement! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #isLeftSideOfAssignment! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #signalSourceCodeContainsAnInvalidExpressionError! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #trimmed:! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #signalTemporaryAssignmentUsedOutsideOfSelectionIntervalError! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #intervalToExtractIsIncludedInAnyOf:! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #isNotInsideATempDeclaration! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #firstParseNodeOfMethodDefinition! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #intervalMatchesEndOfStatement! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #signalExtractingLeftSideOfAssignmentError! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #startAndEndNodesShareAParentNode! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #signalSourceCodeSelectionIncludesAnInvalidExpressionError! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #intervalToExtractIncludesPartOfMethodSignature! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #isNotATempDeclarationWithUsagesOutOfIntervalToExtract! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #assertSourceCodeIsNotPartOfTemporariesDeclaration! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #assertSourceCodeIsNotPartOfMethodSignature! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #parseNodesInCommon! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #assertSourceCodeDoesNotHaveTemporaryVariablesUsedOutsideOfSelectionInterval! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #signalColaborationToExtractHasToBeOneStatementError! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #findSourceRangeOfCloserStatementIn:! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #signalSourceCodeIncludesAReturnStatementError! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #signalTemporaryAssignmentWithoutDeclarationError! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #intervalCoversCompleteAstNodes! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #methodDefinitionStartPosition! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #signalExtractingPartOfMethodSignatureError! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #initializeParseNodesMatchingSelectionInterval! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #startAndEndParseNodesAreTheSame! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #signalExtractingTemporaryVariableDefinitionError! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #assertSourceCodeContainsAValidExpression! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #thereAreReturnExpressions! - -SourceCodeOfTemporaryToBeExtractedPrecondition removeSelector: #isNotDeclaredWithinIntervalToExtract:! - -SourceCodeOfMethodToBeExtractedPrecondition class removeSelector: #errorMessageForExtractingPartOfMethodSignature! - -SourceCodeOfMethodToBeExtractedPrecondition class removeSelector: #errorMessageForExtractingPartOfMethodDefinition! - -SourceCodeOfMethodToBeExtractedPrecondition class removeSelector: #extractMethodErrorMessagePrefix! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition class #extractMethodErrorMessagePrefix stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -extractMethodErrorMessagePrefix - - ^ 'Cannot extract method: '! - -SourceCodeOfMethodToBeExtractedPrecondition class removeSelector: #errorMessageForSourceCodeContainingInvalidExpression! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition class #errorMessageForSourceCodeContainingInvalidExpression stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -errorMessageForSourceCodeContainingInvalidExpression - - ^ self extractMethodErrorMessagePrefix , 'the selected code contains an invalid expression'! - -SourceCodeOfMethodToBeExtractedPrecondition class removeSelector: #errorMessageForExtractingTemporaryVariablesDefinition! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition class #errorMessageForExtractingTemporaryVariablesDefinition stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -errorMessageForExtractingTemporaryVariablesDefinition - - ^ self extractMethodErrorMessagePrefix , 'it is not possible to extract temporary variable definitions'! - -SourceCodeOfMethodToBeExtractedPrecondition class removeSelector: #for:of:! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition class #for:of: stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -for: anIntervalToExtract of: aMethod - - ^ self new initializeFor: anIntervalToExtract of: aMethod! - -SourceCodeOfMethodToBeExtractedPrecondition class removeSelector: #errorMessageForSourceCodeIncludingAReturnStatement! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition class #errorMessageForSourceCodeIncludingAReturnStatement stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -errorMessageForSourceCodeIncludingAReturnStatement - - ^ self extractMethodErrorMessagePrefix , 'the selected code includes a return statement'! - -SourceCodeOfMethodToBeExtractedPrecondition class removeSelector: #valueFor:of:! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition class #valueFor:of: stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -valueFor: anIntervalToExtract of: aMethod - - ^ (self for: anIntervalToExtract of: aMethod) value! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #initializeFor:of:! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition #initializeFor:of: stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -initializeFor: anIntervalToExtract of: aMethodUnderValidation - - intervalToExtract := anIntervalToExtract. - method := aMethodUnderValidation. - methodNode := method methodNode. - sourceCode := method sourceCode.! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #isNotInsideATempDeclaration! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition #isNotInsideATempDeclaration stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -isNotInsideATempDeclaration - - methodNode completeSourceRangesDo: [ :parseNode :sourceRanges | - (parseNode isTemporariesDeclaration - and: [ self intervalToExtractIsIncludedInAnyOf: sourceRanges ]) - ifTrue: [ ^ false ] ]. - ^ true! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #intervalToExtractIsIncludedInAnyOf:! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition #intervalToExtractIsIncludedInAnyOf: stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -intervalToExtractIsIncludedInAnyOf: sourceRanges - - ^ sourceRanges anySatisfy: [ :sourceRange | - sourceRange first <= intervalToExtract first and: [ sourceRange last >= intervalToExtract last ] ]! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #signalExtractingPartOfMethodSignatureError! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #assertSourceCodeDoesNotIncludeReturnExpressions! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition #assertSourceCodeDoesNotIncludeReturnExpressions stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -assertSourceCodeDoesNotIncludeReturnExpressions - - self thereAreReturnExpressions - ifTrue: [ self signalSourceCodeIncludesAReturnStatementError ]! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #signalExtractingTemporaryVariableDefinitionError! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition #signalExtractingTemporaryVariableDefinitionError stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -signalExtractingTemporaryVariableDefinitionError - - self refactoringError: self class errorMessageForExtractingTemporaryVariablesDefinition! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #assertSourceCodeIsNotPartOfTemporariesDeclaration! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition #assertSourceCodeIsNotPartOfTemporariesDeclaration stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -assertSourceCodeIsNotPartOfTemporariesDeclaration - - self isNotInsideATempDeclaration - ifFalse: [ self signalExtractingTemporaryVariableDefinitionError ]! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #assertSourceCodeIsNotPartOfMethodSignature! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #signalSourceCodeContainsAnInvalidExpressionError! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition #signalSourceCodeContainsAnInvalidExpressionError stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -signalSourceCodeContainsAnInvalidExpressionError - - self refactoringError: self class errorMessageForSourceCodeContainingInvalidExpression! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #thereAreReturnExpressions! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition #thereAreReturnExpressions stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -thereAreReturnExpressions - - ^ (methodNode - allParseNodesWithin: intervalToExtract - satisfy: [ :parseNode | parseNode isReturn ]) not! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #signalSourceCodeIncludesAReturnStatementError! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition #signalSourceCodeIncludesAReturnStatementError stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -signalSourceCodeIncludesAReturnStatementError - - self refactoringError: self class errorMessageForSourceCodeIncludingAReturnStatement! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #intervalToExtractIncludesPartOfMethodSignature! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #methodDefinitionStartPosition! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #firstParseNodeOfMethodDefinition! - -ExtractToTemporary class removeSelector: #assert:enclosesAValidNodeOn:! - -!methodRemoval: ExtractToTemporary class #assert:enclosesAValidNodeOn: stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -assert: anIntervalToExtract enclosesAValidNodeOn: aMethodToRefactor - - (self parseNodeUnder: anIntervalToExtract canBeExtractedToAVariableOn: aMethodToRefactor) - ifFalse: [ self signalSourceCodeSelectionIncludesAnInvalidExpression ]! - -ExtractToTemporary class removeSelector: #parseNodeUnder:canBeExtractedToAVariableOn:! - -!methodRemoval: ExtractToTemporary class #parseNodeUnder:canBeExtractedToAVariableOn: stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -parseNodeUnder: anIntervalToExtract canBeExtractedToAVariableOn: aMethodToRefactor - - aMethodToRefactor methodNode completeSourceRangesDo: [ :parseNode :sourceRanges | - (parseNode isAssignmentNode - and: [ sourceRanges anySatisfy: [ :sourceRange | sourceRange first = anIntervalToExtract first ] ]) - ifTrue: [ ^ false ] - ]. - ^ true! - -ExtractToTemporary class removeSelector: #signalSourceCodeSelectionIncludesAnInvalidExpression! - -!methodRemoval: ExtractToTemporary class #signalSourceCodeSelectionIncludesAnInvalidExpression stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -signalSourceCodeSelectionIncludesAnInvalidExpression - - self refactoringError: self errorMessageForSourceCodeIncludingAnInvalidExpression! - -ExtractToTemporary class removeSelector: #signalColaborationToExtractHasSyntaxError:! - -!methodRemoval: ExtractToTemporary class #signalColaborationToExtractHasSyntaxError: stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -signalColaborationToExtractHasSyntaxError: aSyntaxErrorNotification - - self refactoringError: (self errorMessageForSourceCodeToExtractHasSyntaxError: aSyntaxErrorNotification messageText)! - -ExtractToTemporary class removeSelector: #anySourceRangeOf:matches:! - -!methodRemoval: ExtractToTemporary class #anySourceRangeOf:matches: stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -anySourceRangeOf: aMethodToRefactor matches: anIntervalToExtract - - | sourceRangeCollections allSourceRanges sourceCode | - sourceRangeCollections := aMethodToRefactor methodNode completeSourceRanges values. - allSourceRanges := sourceRangeCollections - inject: Set new - into: [ :sourceRanges :sourceRangeCollection | sourceRanges addAll: sourceRangeCollection; yourself ]. - sourceCode := aMethodToRefactor sourceCode. - ^ allSourceRanges anySatisfy: [ :sourceRange | - (sourceRange trimToMatchExpressionOn: sourceCode) = anIntervalToExtract ]! - -ExtractToTemporary class removeSelector: #signalSourceCodeToExtractCanNotIncludeReturn! - -!methodRemoval: ExtractToTemporary class #signalSourceCodeToExtractCanNotIncludeReturn stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -signalSourceCodeToExtractCanNotIncludeReturn - - self refactoringError: self errorMessageForSourceCodeToExtractCanNotIncludeReturn ! - -ExtractToTemporary class removeSelector: #errorMessageForSourceCodeIncludingAnInvalidExpression! - -!methodRemoval: ExtractToTemporary class #errorMessageForSourceCodeIncludingAnInvalidExpression stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -errorMessageForSourceCodeIncludingAnInvalidExpression - - ^ 'The source code selection contains an invalid expression'! - -ExtractToTemporary class removeSelector: #signalColaborationToExtractHasToBeOneStatement! - -!methodRemoval: ExtractToTemporary class #signalColaborationToExtractHasToBeOneStatement stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -signalColaborationToExtractHasToBeOneStatement - - self refactoringError: self errorMessageForSourceCodeToExtractHasToBeOneStatement ! - -ExtractToTemporary class removeSelector: #assertHasOneStatement:! - -!methodRemoval: ExtractToTemporary class #assertHasOneStatement: stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -assertHasOneStatement: aMethodNodeToExtract - - aMethodNodeToExtract numberOfStatements ~= 1 - ifTrue: [ self signalColaborationToExtractHasToBeOneStatement ]! - -ExtractToTemporary class removeSelector: #assert:enclosesACompleteExpressionOn:! - -!methodRemoval: ExtractToTemporary class #assert:enclosesACompleteExpressionOn: stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -assert: anIntervalToExtract enclosesACompleteExpressionOn: aMethodToRefactor - - (self anySourceRangeOf: aMethodToRefactor matches: anIntervalToExtract) - ifFalse: [ self signalSourceCodeSelectionIncludesAnInvalidExpression ]! - -ExtractToTemporary class removeSelector: #assertIsNotReturn:! - -!methodRemoval: ExtractToTemporary class #assertIsNotReturn: stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -assertIsNotReturn: aSourceCodeToExtract - - "I have to use the source code to check this because parsing it returns the same methodNode for - 1 and ^1, that is, using methodNode does not help to distinguish if there was or not a return - Hernan" - - aSourceCodeToExtract withBlanksTrimmed first = $^ - ifTrue: [ self signalSourceCodeToExtractCanNotIncludeReturn ]! - -ExtractToTemporary class removeSelector: #errorMessageForSourceCodeToExtractHasSyntaxError:! - -!methodRemoval: ExtractToTemporary class #errorMessageForSourceCodeToExtractHasSyntaxError: stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -errorMessageForSourceCodeToExtractHasSyntaxError: anErrorDescription - - ^ 'Can not extract a source code with syntax error: ', anErrorDescription ! - -ExtractToTemporary class removeSelector: #tryToParse:on:! - -!methodRemoval: ExtractToTemporary class #tryToParse:on: stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -tryToParse: aSourceCode on: aClassToRefactor - - ^ [ Parser parse: aSourceCode class: aClassToRefactor noPattern: true ] - on: SyntaxErrorNotification - do: [ :anError | self signalColaborationToExtractHasSyntaxError: anError ]! - -ExtractToTemporary class removeSelector: #errorMessageForSourceCodeToExtractCanNotIncludeReturn! - -!methodRemoval: ExtractToTemporary class #errorMessageForSourceCodeToExtractCanNotIncludeReturn stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -errorMessageForSourceCodeToExtractCanNotIncludeReturn - - ^ 'An expression containing a return can not be extracted'! - -ExtractToTemporary class removeSelector: #errorMessageForSourceCodeToExtractHasToBeOneStatement! - -!methodRemoval: ExtractToTemporary class #errorMessageForSourceCodeToExtractHasToBeOneStatement stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -errorMessageForSourceCodeToExtractHasToBeOneStatement - - ^ 'Can not extract more than one statement'! - -SourceCodeIntervalPrecondition subclass: #SourceCodeOfMethodToBeExtractedPrecondition - instanceVariableNames: 'initialNode finalNode initialNodeAncestors finalNodeAncestors' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #SourceCodeOfMethodToBeExtractedPrecondition category: #'Tools-Refactoring' stamp: 'Install-4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st 8/5/2020 22:22:44'! -SourceCodeIntervalPrecondition subclass: #SourceCodeOfMethodToBeExtractedPrecondition - instanceVariableNames: 'initialNode finalNode initialNodeAncestors finalNodeAncestors' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4254-CuisCore-NahuelGarbezza-2020Jul12-15h05m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4253] on 27 July 2020 at 6:40:16 pm'! -!ClassNameCompleter methodsFor: 'testing' stamp: 'HAW 2/21/2019 16:01:01'! - canShowSelectorDocumentation - - ^false! ! -!SmalltalkCompleter methodsFor: 'testing' stamp: 'HAW 2/21/2019 16:06:32'! - canShowSelectorDocumentation - - ^canShowSelectorDocumentation ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4255-SmalltalkCompleterFixes-HernanWilkinson-2020Jul27-18h39m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4255] on 28 July 2020 at 5:12:12 pm'! -!Browser methodsFor: 'shout styling' stamp: 'KLG 7/27/2020 19:00:02' prior: 50368824 overrides: 50368815! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text. - Set the classOrMetaClass in anSHTextStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - | type | - - self isModeStyleable ifFalse: [^false]. - type _ self editSelection. - (#(newMessage editMessage editClass newClass) includes: type) ifFalse:[^false]. - anSHTextStyler classOrMetaClass: ((#(editClass newClass) includes: type) ifFalse:[ - self selectedClassOrMetaClass]). - ^true! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4256-NewClassTemplate-styleFix-GeraldKlix-2020Jul28-17h11m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4253] on 10 July 2020 at 11:15:42 pm'! -!RectangleLikeMorph methodsFor: 'drawing' stamp: 'jmv 7/10/2020 17:19:27' overrides: 16874275! - addPossiblyUncoveredAreasIn: aRectangle to: aCollection - "Answer an array of rectangles encompassing those areas in aRectangle not completely - covered by self. - All areas that might possibly be uncovered must be included." - (self isOrthoRectangularMorph and: [ self isOpaqueMorph ]) ifTrue: [ - aRectangle areasOutside: self morphBoundsInWorld do: [ :r | aCollection add: r ]. - ^self ]. - aCollection add: aRectangle! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/10/2020 20:01:06'! - drawCurrentAndSubmorphs - - self isCurrentMorphVisible - ifTrue: [ - currentMorph drawOn: self. - - "Display submorphs back to front" - "coordinate system stack already set up for aMorph - ('ivars transformations' and 'currentTransformation')" - currentMorph hasSubmorphs ifTrue: [ - currentMorph clippedSubmorph ifNotNil: [ :clipped | - self clippingByCurrentMorphDo: [ self fullDraw: clipped ]]. - currentMorph unclippedSubmorphsReverseDo: [ :m | - self fullDraw: m ]. - ]].! ! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 7/9/2020 16:17:45'! - canvasToUse - - ^self.! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 7/10/2020 17:20:04' prior: 16874275! - addPossiblyUncoveredAreasIn: aRectangle to: aCollection - "Answer an array of rectangles encompassing those areas in aRectangle not completely - covered by self. - All areas that might possibly be uncovered must be included." - aCollection add: aRectangle! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/9/2020 18:35:09' prior: 50506224! - fullDraw: aMorph - "Draw the full Morphic structure on us" - - "We are already set with a proper transformation from aMorph owner's coordinates to those of our target form." - - self flag: #jmvVer3. - aMorph visible ifFalse: [^ self]. - self into: aMorph. - - currentMorph layoutSubmorphsIfNeeded. - - currentMorph isKnownFailing ifTrue: [ - self drawCurrentAsError. - self outOfMorph. - ^ self]. - - (currentMorph isOwnedByHand and: [ Preferences cheapWindowReframe ]) ifTrue: [ - self drawCurrentAsOutline. - self outOfMorph. - ^ self]. - - "Draw current Morph and submorphs" - self canvasToUse drawCurrentAndSubmorphs. - - self outOfMorph! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4257-MorphicRefactor-JuanVuletich-2020Jul10-23h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4255] on 10 July 2020 at 11:56:14 pm'! -!TextModelMorph methodsFor: 'drawing' stamp: 'jmv 7/10/2020 23:52:27' prior: 50506166 overrides: 16790395! - drawOn: aCanvas - "Include a thin red inset border for unaccepted edits, or, if the unaccepted edits are known to conflict with a change made somewhere else to the same method (typically), put a thick red frame" - | bw bc | - self flag: #todo. - "Integrate this method with the Theme system. --cbr" - super drawOn: aCanvas. - bw _ Preferences focusIndicatorWidth. - bc _ nil. - self wantsFrameAdornments ifTrue: [ - model refusesToAccept - ifTrue: [ "Put up feedback showing that code cannot be submitted in this state" - bc _ Color tan ] - ifFalse: [ - self textMorph hasEditingConflicts - ifTrue: [ - bw _ 3. - bc _ Color red ] - ifFalse: [ - self textMorph hasUnacceptedEdits ifTrue: [ bc _ Color red ]]]]. - (drawKeyboardFocusIndicator and: [ self textMorph hasKeyboardFocus ]) - ifTrue: [ bc ifNil: [ bc _ Theme current focusIndicator ]] - ifFalse: [ - bc ifNotNil: [ - bc _ bc - alphaMixed: 0.4 - with: Color white ]]. - bc ifNotNil: [ - aCanvas - frameRectangle: self focusIndicatorRectangle - borderWidth: bw - color: bc ].! ! -!InnerTextMorph methodsFor: 'drawing' stamp: 'jmv 7/10/2020 23:54:05' prior: 50503675 overrides: 16899205! - drawOn: aCanvas - "Draw the receiver on a canvas" - - false ifTrue: [ self debugDrawLineRectsOn: aCanvas ]. "show line rects for debugging" - - aCanvas - textComposition: self textComposition - bounds: self morphLocalBounds - color: color - selectionColor: (Theme current textHighlightFocused: self hasKeyboardFocus). - - model actualContents isEmpty ifTrue: [ - owner - valueOfProperty: #emptyTextDisplayMessage - ifPresentDo: [ :msg | - aCanvas - drawString: msg - at: self morphTopLeft - font: nil - color: Theme current textEmptyDisplayMessage ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4258-EmptyTextMessageReimplementation-JuanVuletich-2020Jul10-23h52m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4257] on 11 July 2020 at 8:56:41 pm'! -!MenuMorph methodsFor: 'control' stamp: 'jmv 7/11/2020 17:57:50' prior: 50384883! - popUpAdjacentTo: rightOrLeftPointInWorld from: sourceItem - "Present this menu at the given point under control of the given hand. - Used mostly for submenus." - - | delta tryToPlace selectedOffset | - popUpOwner _ sourceItem. - selectedOffset _ (selectedItem ifNil: [ self items first ]) morphPosition. - sourceItem world addMorphFront: self. - - tryToPlace _ [ :where :mustFit | - self morphPosition: where - selectedOffset. - delta _ self morphBoundsInWorld - amountToTranslateWithin: sourceItem world morphBoundsInWorld. - (delta x = 0 | mustFit) ifTrue: [ - delta = `0@0` ifFalse: [ self morphPosition: self morphPosition + delta ]. - ^ self]]. - tryToPlace - value: rightOrLeftPointInWorld first value: false; - value: rightOrLeftPointInWorld last - (extent x @ 0) value: false; - value: rightOrLeftPointInWorld first value: true! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4259-tweak-JuanVuletich-2020Jul11-20h55m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4260] on 12 July 2020 at 12:18:16 pm'! -!Morph methodsFor: 'private' stamp: 'jmv 7/11/2020 21:57:34'! - privateMoveBackMorph: aMorph - - | oldIndex myWorld index | - myWorld _ self world. - "aMorph's position changes within in the submorph chain" - "moving aMorph to front" - oldIndex _ submorphs indexOf: aMorph. - "moving aMorph to back" - index _ submorphs size. - submorphs replaceFrom: oldIndex to: index-1 with: submorphs startingAt: oldIndex+1. - submorphs at: index put: aMorph. - myWorld ifNotNil: [aMorph redrawNeeded]. - self someSubmorphPositionOrExtentChanged.! ! -!Morph methodsFor: 'private' stamp: 'jmv 7/11/2020 21:58:44'! - privateMoveFrontMorph: aMorph - - | oldIndex myWorld | - myWorld _ self world. - "aMorph's position changes within in the submorph chain" - "moving aMorph to front" - oldIndex _ submorphs indexOf: aMorph. - oldIndex-1 to: 1 by: -1 do: [ :i | - submorphs at: i+1 put: (submorphs at: i)]. - submorphs at: 1 put: aMorph. - myWorld ifNotNil: [aMorph redrawNeeded]. - self someSubmorphPositionOrExtentChanged.! ! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'jmv 7/11/2020 21:58:57' prior: 50431926! - comeToFront - - self atFront ifFalse: [owner privateMoveFrontMorph: self]! ! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'jmv 7/11/2020 21:58:00' prior: 16876912! - goBehind - - owner privateMoveFrontMorph: self. -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4260-MorphicRefactor-JuanVuletich-2020Jul12-12h18m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4263] on 12 July 2020 at 8:59:50 pm'! -!HaloMorph methodsFor: 'event handling' stamp: 'jmv 7/12/2020 20:59:04' overrides: 16877018! - redrawNeeded - "Report that the area occupied by this morph should be redrawn." - - self - invalidateDisplayRect: - ((self morphBoundsInWorld - outsetBy: self class handleSize*2) - extendBy: 0@(FontFamily defaultLineSpacing+self class handleSize)) - from: nil.! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/12/2020 20:54:19' prior: 50385573! - basicBox - | aBox minSide anExtent w | - minSide _ 4 * self class handleSize. - anExtent _ extent + (self class handleSize*2) max: minSide@minSide. - aBox _ Rectangle center: self morphBoundsInWorld center extent: anExtent. - w _ self world ifNil: [ target world ]. - ^ w - ifNil: - [ aBox ] - ifNotNil: - [ aBox intersect: (w viewBox insetBy: `8@8`) ]! ! -!HaloMorph methodsFor: 'stepping' stamp: 'jmv 7/12/2020 18:55:39' prior: 50521108 overrides: 16876533! - step - (target isNil or: [target isInWorld not]) ifTrue: [self delete]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4261-HaloFixes-JuanVuletich-2020Jul12-20h40m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4258] on 17 July 2020 at 5:15:13 pm'! -!Morph methodsFor: 'events-processing' stamp: 'jmv 7/13/2020 16:20:20' prior: 16875151! -rejectsEvent: aMorphicEvent - "Return true to reject the given event. Submorphs might still handle it." - - ^ false! ! -!Morph methodsFor: 'events-processing' stamp: 'jmv 7/13/2020 16:07:54'! - rejectsEventFully: aMorphicEvent - "Return true to reject the given event, for thereceiver and all submorphs." - - ^ self isLocked or: [ self visible not ]! ! -!HaloMorph methodsFor: 'events-processing' stamp: 'jmv 7/13/2020 16:20:15' prior: 16850703 overrides: 50530923! - rejectsEvent: aMorphicEvent - "Return true to reject the given event. Submorphs might still handle it." - - "Only mouseButton3 events are handled by the halo itself" - (aMorphicEvent isMouse and: [ - aMorphicEvent isMouseDown and: [ aMorphicEvent mouseButton3Pressed ]]) - ifTrue: [ - ^ false ]. - ^true! ! -!HaloMorph methodsFor: 'events-processing' stamp: 'jmv 7/13/2020 16:08:07' overrides: 50530929! - rejectsEventFully: anEvent - "Return true to reject the given event, for thereceiver and all submorphs." - - (super rejectsEventFully: anEvent) ifTrue: [^true]. - anEvent isDropEvent ifTrue: [^true]. "never attempt to drop on halos" - ^false! ! -!Morph methodsFor: 'events-processing' stamp: 'jmv 7/13/2020 16:08:20' prior: 16874850! - dispatchEvent: aMorphicEvent localPosition: localPosition - "This is the central entry for dispatching events in morphic. Given some event, find the right receiver and let him handle it. - localPosition is in our coordinates." - - ^ (self rejectsEventFully: aMorphicEvent) - ifTrue: [ #rejected ] - ifFalse: [ aMorphicEvent dispatchWith: self localPosition: localPosition ]! ! -!Morph methodsFor: 'events-processing' stamp: 'jmv 7/13/2020 16:22:57' prior: 50365528! - processMouseOver: aMouseEvent localPosition: localEventPosition - "System level event handling." - self hasMouseFocus ifTrue: [ - "Got this directly through #handleFocusEvent: so check explicitly" - ((self rejectsEvent: aMouseEvent) not and: [self fullContainsPoint: localEventPosition]) ifFalse: [ - ^self ]]. - aMouseEvent hand noticeMouseOver: self event: aMouseEvent. - "Open question: should any unhandled mouse move events be filtered out? (i.e. should mouseHover:localPosition: be called when a mouse button is pressed but the morph doesn't have mouse button handlers? Essentially, what are the limits of what is considered 'hovering'?" - (self handlesMouseHover and: [aMouseEvent wasHandled not]) ifTrue: [ - self - mouseHover: aMouseEvent - localPosition: localEventPosition ].! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/13/2020 12:06:02' prior: 16875588! - fullContainsPoint: aLocalPoint - - "If not visible, won't contain any point at all." - self visible ifFalse: [ ^false ]. - - (self morphContainsPoint: aLocalPoint) ifTrue: [ ^ true ]. "quick acceptance" - self submorphsDrawingOutsideReverseDo: [ :m | - (m fullContainsPoint: (m internalize: aLocalPoint)) ifTrue: [ ^ true ]]. - ^ false! ! -!MorphicEvent methodsFor: 'dispatching' stamp: 'jmv 7/13/2020 16:23:09' prior: 16877793! - dispatchWith: aMorph localPosition: positionInAMorph - "Dispatch me. The event will be passed to the front-most visible submorph that contains the position wrt. to the event." - | handledByInner eventPositionInChild | - - "Try to get out quickly" - (aMorph fullContainsPoint: positionInAMorph) - ifFalse: [ ^#rejected ]. - - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - - "Check for being inside the receiver" - (handledByInner or: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsPoint: positionInAMorph] ]) - ifTrue: [ ^ self sentTo: aMorph localPosition: positionInAMorph ]. - - ^ #rejected! ! -!DropEvent methodsFor: 'dispatching' stamp: 'jmv 7/13/2020 16:21:40' prior: 16835677 overrides: 50531019! - dispatchWith: aMorph localPosition: positionInAMorph - "Drop is done on the innermost target that accepts it." - | eventPositionInChild dropped | - - "Try to get out quickly" - (aMorph fullContainsPoint: positionInAMorph) - ifFalse: [ ^#rejected ]. - - "Go looking if any of our submorphs wants it" - aMorph submorphsDo: [ :eachChild | - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ - ^self ]]. - - (aMorph allowsMorphDrop and: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsPoint: positionInAMorph] ]) - ifTrue: [ - "Do a symmetric check if both morphs like each other" - dropped _ self contents. - ((aMorph wantsDroppedMorph: dropped event: self) "I want her" - and: [dropped wantsToBeDroppedInto: aMorph]) "she wants me" - ifTrue: [ - ^ self sentTo: aMorph localPosition: positionInAMorph ]]. - ^#rejected! ! -!DropFilesEvent methodsFor: 'dispatching' stamp: 'jmv 7/13/2020 16:22:06' prior: 50424937 overrides: 50531019! - dispatchWith: aMorph localPosition: positionInAMorph - "Drop is done on the innermost target that accepts it." - - | eventPositionInChild | - - "Try to get out quickly" - (aMorph fullContainsPoint: positionInAMorph) ifFalse: [ ^#rejected ]. - - "Go looking if any of our submorphs wants it" - aMorph submorphsDo: [ :eachChild | - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ ^self ]]. - - (aMorph allowsFilesDrop and: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsPoint: positionInAMorph] ]) - ifTrue: [^ self sentTo: aMorph localPosition: positionInAMorph ]. - - ^#rejected! ! -!MouseButtonEvent methodsFor: 'dispatching' stamp: 'jmv 7/13/2020 16:23:25' prior: 16878696 overrides: 50531019! - dispatchWith: aMorph localPosition: positionInAMorph - "Find the appropriate receiver for the event and let it handle it. Default rules: - * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. - * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. - * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. - * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. - " - | aMorphHandlesIt grabAMorph handledByInner eventPositionInChild | - "Only for MouseDown" - self isMouseDown ifFalse: [ - ^super dispatchWith: aMorph localPosition: positionInAMorph ]. - - "Try to get out quickly" - (aMorph fullContainsPoint: positionInAMorph) - ifFalse: [ ^#rejected ]. - - "Install the prospective handler for the receiver" - aMorphHandlesIt _ false. - grabAMorph _ false. - self mouseButton3Pressed - ifTrue: [ - (eventHandler isNil or: [ eventHandler isWorldMorph or: [ - self shiftPressed or: [ aMorph is: #HaloMorph ]]]) - ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]] - ifFalse: [ - (aMorph handlesMouseDown: self) ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]. - "If button 1, and both aMorph and the owner allows grabbing with the hand (to initiate drag & drop), so be it." - self mouseButton1Pressed ifTrue: [ - aMorph owner ifNotNil: [ :o | - (o allowsSubmorphDrag and: [ aMorph isSticky not ]) ifTrue: [ - grabAMorph _ true ]]]]. - - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - - (handledByInner or: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsPoint: positionInAMorph] ]) ifTrue: [ - "aMorph is in the top-most unlocked, visible morph in the chain." - aMorphHandlesIt - ifTrue: [ ^self sentTo: aMorph localPosition: positionInAMorph ] - ifFalse: [ - (grabAMorph and: [ handledByInner not ]) ifTrue: [ - self hand - waitForClicksOrDrag: aMorph event: self - dragSel: (Preferences clickGrabsMorphs ifFalse: [#dragEvent:localPosition:]) - clkSel: (Preferences clickGrabsMorphs ifTrue: [#dragEvent:localPosition:]). - "false ifTrue: [ self hand grabMorph: aMorph ]." - Preferences clickGrabsMorphs ifFalse: [aMorph activateWindow]. - self wasHandled: true. - ^self ]]]. - - handledByInner ifTrue: [ ^self ]. - "Mouse was not on aMorph nor any of its children" - ^ #rejected! ! -!MouseScrollEvent methodsFor: 'dispatching' stamp: 'jmv 7/13/2020 16:23:48' prior: 50373749 overrides: 50531019! - dispatchWith: aMorph localPosition: positionInAMorph - "Find the appropriate receiver for the event and let it handle it. Default rules: - * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. - * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. - * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. - * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. - " - "Try to get out quickly" - | aMorphHandlesIt handledByInner eventPositionInChild focus| - focus := self hand keyboardFocus. - "FIXME - this works in all tested cases but one: when the window directly under the mouse doesn't have keyboard focus (i.e. a Transcript window)" - ((aMorph fullContainsPoint: positionInAMorph) and: [(aMorph = focus) or: [focus notNil and: [aMorph notNil and: [focus hasOwner: aMorph]]]]) ifFalse: [ ^ #rejected ]. - "Install the prospective handler for the receiver" - aMorphHandlesIt _ false. - (aMorph handlesMouseScroll: self) ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]. - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild - dispatchEvent: self - localPosition: eventPositionInChild) == #rejected ifFalse: [ "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - (handledByInner or: [ - (aMorph rejectsEvent: self) not and: [aMorph fullContainsPoint: positionInAMorph]]) ifTrue: [ - "aMorph is in the top-most unlocked, visible morph in the chain." - aMorphHandlesIt ifTrue: [ ^ self - sentTo: aMorph - localPosition: positionInAMorph ]]. - handledByInner ifTrue: [ ^ self ]. - "Mouse was not on aMorph nor any of its children" - ^ #rejected.! ! - -HaloMorph removeSelector: #containsPoint:event:! - -!methodRemoval: HaloMorph #containsPoint:event: stamp: 'Install-4262-Morphic-Refactor-JuanVuletich-2020Jul17-17h01m-jmv.001.cs.st 8/5/2020 22:22:44'! -containsPoint: aLocalPoint event: aMorphicEvent - - self visible ifFalse: [ ^false ]. - - "mouseButton3 events are handled by the halo" - (aMorphicEvent isMouse and: [ - aMorphicEvent isMouseDown and: [ aMorphicEvent mouseButton3Pressed ]]) - ifTrue: [ - ^ self morphLocalBounds containsPoint: aLocalPoint ]. - - ^false! - -Morph removeSelector: #containsPoint:event:! - -!methodRemoval: Morph #containsPoint:event: stamp: 'Install-4262-Morphic-Refactor-JuanVuletich-2020Jul17-17h01m-jmv.001.cs.st 8/5/2020 22:22:44'! -containsPoint: aLocalPoint event: anEvent - "Return true if aPoint is considered to be inside the receiver for the given event. - The default implementation treats locked children as integral part of their owners." - - "Should this method be called #fullContainsPoint:event: ? - Should it be merged with #fullContainsPoint: ? - " - self visible ifFalse: [ ^false ]. - (self morphContainsPoint: aLocalPoint) ifTrue: [ ^true ]. - self submorphsDrawingOutsideReverseDo: [ :m | - (m isLocked and: [ m fullContainsPoint: (m internalize: aLocalPoint) ]) - ifTrue: [ ^true ]]. - ^false! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4262-Morphic-Refactor-JuanVuletich-2020Jul17-17h01m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4259] on 17 July 2020 at 5:48:35 pm'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/10/2020 16:20:44'! - boundingRectOfCurrentMorphAfterDraw - "This rectangle is used for clipping submorphs in BitBltCanvas. - In VectorCanvas we support clipping by any shape, not just rectangles. Then, this rectangle is used as an optimization of the area to be redrawn." -" -Y ademas es el rectangulo afectado por la ultima operacion de dibujado. Que se yo. -Renombrarlo onda #currentMorphDisplayBounds o #currentMorphAffectedRect o algo asi. -" -self flag: #puff. - self subclassResponsibility! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 7/17/2020 17:41:13'! - boundingRectOfCurrentMorph - "In targetForm coordinates" - - ^currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 7/10/2020 17:23:40' overrides: 50531331! - boundingRectOfCurrentMorphAfterDraw - "In targetForm coordinates" - self flag: #puff. - ^ self boundingRectOfCurrentMorph! ! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 7/17/2020 17:45:55' prior: 50506153! - clippingByCurrentMorphDo: aBlock - | prevClipRect | - - prevClipRect _ self clipRect. - "Might use the fact that currentMorph has just been drawn." - self setClipRect: (prevClipRect intersect: self boundingRectOfCurrentMorphAfterDraw). - self clippingMorph: currentMorph. - aBlock ensure: [ - self clippingMorph: nil. - self setClipRect: prevClipRect. ]! ! -!BitBltCanvas methodsFor: 'testing' stamp: 'jmv 7/10/2020 17:23:43' prior: 50501586 overrides: 50463630! - isCurrentMorphVisible - | aRectangle myClipRect | - currentMorph visible ifFalse: [ ^false ]. - aRectangle := self boundingRectOfCurrentMorph. - myClipRect := self clipRect. - aRectangle right < myClipRect left ifTrue: [^ false]. - aRectangle left > myClipRect right ifTrue: [^ false]. - aRectangle bottom < myClipRect top ifTrue: [^ false]. - aRectangle top > myClipRect bottom ifTrue: [^ false]. - ^ true -! ! - -BitBltCanvas removeSelector: #clippingRectForCurrentMorph! - -!methodRemoval: BitBltCanvas #clippingRectForCurrentMorph stamp: 'Install-4263-MorphicRefactor-JuanVuletich-2020Jul17-17h38m-jmv.001.cs.st 8/5/2020 22:22:44'! -clippingRectForCurrentMorph - "In targetForm coordinates" - - ^currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds! - -MorphicCanvas removeSelector: #clippingRectForCurrentMorph! - -!methodRemoval: MorphicCanvas #clippingRectForCurrentMorph stamp: 'Install-4263-MorphicRefactor-JuanVuletich-2020Jul17-17h38m-jmv.001.cs.st 8/5/2020 22:22:44'! -clippingRectForCurrentMorph - "This rectangle is used for clipping submorphs in BitBltCanvas. - In VectorCanvas we support clipping by any shape, not just rectangles. Then, this rectangle is used as an optimization of the area to be redrawn." - - self subclassResponsibility! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4263-MorphicRefactor-JuanVuletich-2020Jul17-17h38m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4260] on 17 July 2020 at 5:58:42 pm'! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipRect transformations currentTransformation cti currentMorph drawingMorphStack engine world ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support' stamp: 'Install-4264-Morphic-refactor-JuanVuletich-2020Jul17-17h58m-jmv.001.cs.st 8/5/2020 22:22:45'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'form clipRect transformations currentTransformation cti currentMorph drawingMorphStack engine world' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! -!MorphicCanvas methodsFor: 'initialization' stamp: 'jmv 7/11/2020 00:01:48'! - world: aPasteUpMorph - world _ aPasteUpMorph. - self into: world! ! -!WorldState methodsFor: 'canvas' stamp: 'jmv 7/11/2020 00:01:55' prior: 16945729! - setCanvas: aMorphicCanvas - canvas _ aMorphicCanvas. - canvas world: world. - damageRecorder - ifNil: [ damageRecorder _ DamageRecorder new]. - damageRecorder doFullRepaint! ! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'world form clipRect transformations currentTransformation cti currentMorph drawingMorphStack engine' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support' stamp: 'Install-4264-Morphic-refactor-JuanVuletich-2020Jul17-17h58m-jmv.001.cs.st 8/5/2020 22:22:45'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'world form clipRect transformations currentTransformation cti currentMorph drawingMorphStack engine' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4264-Morphic-refactor-JuanVuletich-2020Jul17-17h58m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4260] on 17 July 2020 at 6:04:24 pm'! - -PasteUpMorph removeSelector: #acceptDroppingMorph:event:! - -!methodRemoval: PasteUpMorph #acceptDroppingMorph:event: stamp: 'Install-4265-Morph-simplify-JuanVuletich-2020Jul17-17h58m-jmv.001.cs.st 8/5/2020 22:22:45'! -acceptDroppingMorph: aMorph event: evt - "The supplied morph, known to be acceptable to the receiver, is now to be assimilated; the precipitating event is supplied" - - self isWorldMorph - ifTrue: [ - "Add the given morph to this world and start stepping it if it wants to be." - self addMorphFront: aMorph. - (aMorph morphFullBoundsInWorld intersects: self viewBox) - ifFalse: [ - Smalltalk beep. - aMorph morphPosition: extent // 2]] - ifFalse: [super acceptDroppingMorph: aMorph event: evt]. - aMorph submorphsDo: [ :m | (m is: #HaloMorph) ifTrue: [ m delete ]]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4265-Morph-simplify-JuanVuletich-2020Jul17-17h58m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4263] on 19 July 2020 at 4:07:56 pm'! -!HaloMorph methodsFor: 'event handling' stamp: 'jmv 7/12/2020 21:28:50' prior: 50530885 overrides: 16877018! - redrawNeeded - "Report that the area occupied by this morph should be redrawn." - - self - invalidateDisplayRect: - ((self morphBoundsInWorld - outsetBy: self class handleSize*2) - extendBy: 0@(FontFamily defaultLineSpacing+self class handleSize)) - from: nil. - "Label could be wider than us..." - self submorphsDrawingOutsideReverseDo: [ :m | m redrawNeeded ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4266-HaloFix-JuanVuletich-2020Jul19-15h56m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4263] on 19 July 2020 at 5:22:10 pm'! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/13/2020 16:59:51'! - fullContainsGlobalPoint: worldPoint -"Answer true even if aLocalPoint is in some unclipped submorph, but outside us " - - "If not visible, won't contain any point at all." - | canvas | - self visible ifFalse: [ ^false ]. - - canvas _ self world canvas. - canvas isNil ifTrue: [ ^false ]. - (canvas morph: self isAtPoint: worldPoint) ifTrue: [ ^ true ]. - self submorphsDrawingOutsideReverseDo: [ :m | - (m fullContainsGlobalPoint: worldPoint) ifTrue: [ ^ true ]]. - ^ false! ! -!RectangleLikeMorph methodsFor: 'geometry testing' stamp: 'jmv 7/13/2020 16:37:51' overrides: 16875610! - morphContainsPoint: aLocalPoint -"Answer true even if aLocalPoint is in asubmorph, as long as it is in our shape" - - "If not visible, won't contain any point at all." - self visible ifFalse: [ ^false ]. - - "Most morphs answer true to to #isOrthoRectangularMorph, or redefine this method..." - self isOrthoRectangularMorph ifTrue: [ - ^ self morphLocalBounds containsPoint: aLocalPoint ]. - - "...But for those who not, provide correct albeit expensive behavior." - "Can't do better. Please redefine in subclasses as appropriate!! (or finish Morphic 3!!)" - "Mhhh. Podria usar el #imageForm: y ver si es transparente... deberia andar" - ^ self morphLocalBounds containsPoint: aLocalPoint! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 7/13/2020 16:43:16'! - morph: aMorph isAtPoint: aPoint - - ^aMorph morphContainsPoint: - (aMorph internalizeFromWorld: aPoint)! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/13/2020 17:00:03' prior: 50531005! -fullContainsPoint: aLocalPoint -"Answer true even if aLocalPoint is in some unclipped submorph, but outside us " - - "If not visible, won't contain any point at all." - self visible ifFalse: [ ^false ]. - - ^self fullContainsGlobalPoint: (self externalizeToWorld: aLocalPoint).! ! - -Morph removeSelector: #morphContainsPoint:! - -!methodRemoval: Morph #morphContainsPoint: stamp: 'Install-4267-fullContainsPoint-JuanVuletich-2020Jul19-17h15m-jmv.001.cs.st 8/5/2020 22:22:45'! -morphContainsPoint: aLocalPoint - - "If not visible, won't contain any point at all." - self visible ifFalse: [ ^false ]. - - "Most morphs answer true to to #isOrthoRectangularMorph, or redefine this method..." - self isOrthoRectangularMorph ifTrue: [ - ^ self morphLocalBounds containsPoint: aLocalPoint ]. - - "...But for those who not, provide correct albeit expensive behavior." - "Can't do better. Please redefine in subclasses as appropriate!! (or finish Morphic 3!!)" - "Mhhh. Podria usar el #imageForm: y ver si es transparente... deberia andar" - ^ self morphLocalBounds containsPoint: aLocalPoint! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4267-fullContainsPoint-JuanVuletich-2020Jul19-17h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4264] on 20 July 2020 at 4:24:39 pm'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/20/2020 16:14:37'! - drawWorld: aPasteUpMorph submorphs: worldSubmorphs repair: aDamageRecorder - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rectsToRepair previousRectsToRepair reuse previousCount morphBounds | - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ aDamageRecorder invalidRectsFullBounds: aPasteUpMorph viewBox. - - rectsToRepair size > 1 ifTrue: [ "Or there is no point in attempting to merge them!!" - previousRectsToRepair _ OrderedCollection new. - - "Until no more rectangles are merged, i.e. each morph intersects at most one rectangle." - previousCount _ 0. - [rectsToRepair size = previousCount] whileFalse: [ - previousCount _ rectsToRepair size. - worldSubmorphs reverseDo: [ :morph | | thisMorphRectangle thisMorphBounds | - morph visible ifTrue: [ - reuse _ previousRectsToRepair. - previousRectsToRepair _ rectsToRepair. - rectsToRepair _ reuse removeAll. - thisMorphRectangle _ nil. - thisMorphBounds _ morph morphFullBoundsInWorld. - previousRectsToRepair do: [ :r | - (thisMorphBounds intersects: r) - ifTrue: [ thisMorphRectangle _ r quickMerge: thisMorphRectangle ] - ifFalse: [ rectsToRepair add: r ]]. - thisMorphRectangle - ifNotNil: [rectsToRepair add: thisMorphRectangle]]]]. - ]. - - "Draw World" - rectsToRepair do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - "Draw morphs" - worldSubmorphs reverseDo: [ :morph | - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - rectsToRepair do: [ :r | - (morphBounds intersects: r) ifTrue: [ - (self newClipRect: r) fullDraw: morph ]]]]. - - ^ rectsToRepair! ! -!Rectangle methodsFor: 'rectangle functions' stamp: 'jmv 7/20/2020 12:44:18' prior: 16898788! - merge: aRectangle - "Answer a Rectangle that contains both the receiver and aRectangle. - See #quickMerge:" - - ^Rectangle - origin: (origin min: aRectangle origin) - corner: (corner max: aRectangle corner)! ! -!Rectangle methodsFor: 'rectangle functions' stamp: 'jmv 7/20/2020 12:44:59' prior: 16898810! - quickMerge: aRectangle - "Answer the receiver if it encloses the given rectangle or the merge of the two rectangles if it doesn't. - This method is an optimization to reduce extra rectangle creations. - Accept nil as argument" - - | useRcvr rOrigin rCorner minX maxX minY maxY | - aRectangle ifNil: [ ^self ]. - - useRcvr _ true. - rOrigin _ aRectangle topLeft. - rCorner _ aRectangle bottomRight. - minX _ rOrigin x < origin x ifTrue: [ useRcvr _ false. rOrigin x ] ifFalse: [ origin x ]. - maxX _ rCorner x > corner x ifTrue: [ useRcvr _ false. rCorner x ] ifFalse: [ corner x ]. - minY _ rOrigin y < origin y ifTrue: [ useRcvr _ false. rOrigin y ] ifFalse: [ origin y ]. - maxY _ rCorner y > corner y ifTrue: [useRcvr _ false. rCorner y ] ifFalse: [ corner y ]. - - ^useRcvr - ifTrue: [ self ] - ifFalse: [ Rectangle origin: minX@minY corner: maxX@maxY ].! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 7/20/2020 12:43:39' prior: 50385116! - savePatchFrom: aCanvas appendDamageTo: aStream - "Save the part of the given canvas under this hand as a Form and return its bounding rectangle." - - "Details: The previously used patch Form is recycled when possible to reduce the burden on storage management." - - | fullBounds | - fullBounds _ self morphFullBoundsInWorld. - fullBounds ifNil: [ ^self ]. - - fullBounds _ fullBounds intersect: (`0@0` extent: aCanvas extent). - (savedPatch isNil or: [savedPatch extent ~= fullBounds extent]) - ifTrue: [ - "allocate new patch form if needed" - savedPatch _ Form extent: fullBounds extent depth: aCanvas depth ]. - aCanvas - contentsOfArea: fullBounds - into: savedPatch. - savedPatch offset: fullBounds topLeft. - prevFullBounds - ifNil: [ aStream nextPut: fullBounds ] - ifNotNil: [ aStream nextPut: (fullBounds quickMerge: prevFullBounds)]. - prevFullBounds _ fullBounds! ! -!WorldState methodsFor: 'drawing' stamp: 'jmv 7/20/2020 16:15:29' prior: 50339614! - displayWorldAndSubmorphs: submorphs - "Update this world's display." - - | deferredUpdateVMMode worldDamageRects handsToDraw allDamage | - self checkIfUpdateNeeded ifFalse: [ ^ self ]. "display is already up-to-date" - "I (jmv) removed the call to 'deferUpdates: false' below. No more need to call this every time." - deferredUpdateVMMode _ self tryDeferredUpdatingAndSetCanvas. - - "repair world's damage on canvas" - worldDamageRects _ canvas drawWorld: world submorphs: submorphs repair: damageRecorder. - - "Check which hands need to be drawn (they are not the hardware mouse pointer)" - handsToDraw _ self selectHandsToDrawForDamage: worldDamageRects. - allDamage _ Array streamContents: [ :strm | - strm nextPutAll: worldDamageRects. - handsToDraw do: [ :h | - h savePatchFrom: canvas appendDamageTo: strm ]]. - - "Draw hands (usually carying morphs) onto world canvas" - canvas newClipRect: nil. - handsToDraw reverseDo: [ :h | canvas fullDrawHand: h ]. - - "quickly copy altered rects of canvas to Display:" - deferredUpdateVMMode ifFalse: [ - "Drawing was done to off-Display canvas. Copy content to Display" - canvas showAt: world viewBox origin invalidRects: allDamage ]. - - "Display deferUpdates: false." - "Display forceDisplayUpdate" - Display forceDamageToScreen: allDamage. - - "Restore world canvas under hands and their carried morphs" - handsToDraw do: [ :h | h restoreSavedPatchOn: canvas ].! ! -!DamageRecorder methodsFor: 'recording' stamp: 'jmv 7/20/2020 15:55:32' prior: 50462775! - invalidRectsFullBounds: aRectangle - "Return a collection of damaged rectangles for the given canvas. - If a total repaint has been requested, return the given rectangle. - Forget about all damage." - | answer | - answer _ totalRepaint ifTrue: [ Array with: aRectangle ]. - self pvtAccessProtect critical: [ - answer ifNil: [ - answer _ invalidRects reject: [ :r | - r isNil ]]. - self pvtReset ]. - ^ answer.! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/20/2020 12:43:25' prior: 16877438! - displayFullBoundsInWorldOf: aMorph - "Answer a rectangle that completely bounds aMorph and submorphs when drawn - (if the world was to be fully drawn, i.e. only to be used on a Canvas on the full world). - Might be larger than strictly required. See comment at #displayBoundsInWorldOf:" - - | r | - "Think about doing a BoundsFinderCanvas even for Morphic 2" - - self flag: #jmvVer2. - - r _ self displayBoundsInWorldOf: aMorph. - aMorph submorphsDrawingOutsideReverseDo: [ :m | - m visible ifTrue: [ - r _ r quickMerge: (self displayFullBoundsInWorldOf: m) ]]. - - ^r! ! - -WorldState class removeSelector: #experiment1! - -!methodRemoval: WorldState class #experiment1 stamp: 'Install-4268-Morphic-Refactor-JuanVuletich-2020Jul20-16h20m-jmv.001.cs.st 8/5/2020 22:22:45'! -experiment1 - "To play with and learn about morphic Display update logic. - Remove the morphs when done!!" - " - WorldState experiment1 - " - | dr morph1 morph2 s w | - morph1 _ RectangleLikeMorph new openInWorld. - morph2 _ RectangleLikeMorph new openInWorld. - morph2 color: `Color green`. - morph2 morphPosition: 200@800 extent: 50@40. - morph1 morphPosition: 120@720 extent: 220@100. - - w _ self runningWorld. - s _ w instVarNamed: 'worldState'. - dr _ s instVarNamed: 'damageRecorder'. - - dr doFullRepaint. - dr reset; - " recordInvalidRect: (100@700 corner: 400@900);" - recordInvalidRect: (100@700 corner: 150@900); - recordInvalidRect: (300@700 corner: 400@900). - Display fillColor: `Color gray`. - "Do not draw the area used by the small rectangle, unless it is also drawn!!" - s drawInvalidAreasSubmorphs: {morph1. morph2 }! - -WorldState removeSelector: #drawInvalidAreasSubmorphs:! - -!methodRemoval: WorldState #drawInvalidAreasSubmorphs: stamp: 'Install-4268-Morphic-Refactor-JuanVuletich-2020Jul20-16h20m-jmv.001.cs.st 8/5/2020 22:22:45'! -drawInvalidAreasSubmorphs: submorphs - "Redraw the damaged areas of the given canvas and clear the damage list. Return a collection of the areas that were redrawn." - - | initialRectsToRepair currentRectsToRepair newRectsToRepair morphsToDraw rectsForEachMorph thisMorphRects reuse i n morph morphBounds morphClipRect | - - "The simple implementation is slowers as it draws morph areas that will later be covered by other morphs. - But it works, and it is easier to understand. - See en.wikipedia.org/wiki/Painter's_algorithm" - true not ifTrue: [ ^self simpleDrawInvalidAreasSubmorphs: submorphs ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - initialRectsToRepair _ damageRecorder invalidRectsFullBounds: world viewBox. - currentRectsToRepair _ OrderedCollection new. - newRectsToRepair _ OrderedCollection withAll: initialRectsToRepair. - morphsToDraw _ OrderedCollection new. - rectsForEachMorph _ OrderedCollection new. - thisMorphRects _ OrderedCollection new. - n _ submorphs size. - i _ 1. - - "The idea here is to iterate morphs front to back, i.e. first the ones on top. - For each morph, record the rectangles it affects. And if a morph is opaque, remove the area behind it from the list of rectangles to be repaired. - This means, for example, that morphs completely covered might even not be redrawn. - this is a huge performance gain when there are many morphs on screen, especially if there are more than ten open windows, and Theme uses opaque colors. - See 'A reverse painter's algorithm' at en.wikipedia.org/wiki/Painter's_algorithm" - [ i <= n and: [ newRectsToRepair notEmpty ]] whileTrue: [ - morph _ submorphs at: i. - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - reuse _ currentRectsToRepair. - currentRectsToRepair _ newRectsToRepair. - newRectsToRepair _ reuse removeAll. - currentRectsToRepair do: [ :r | - (morphBounds intersects: r) - ifTrue: [ - morphClipRect _ morphBounds intersect: r. - thisMorphRects add: morphClipRect. "We could perhaps try and join adjacent rectangles in this collection..." - morph addPossiblyUncoveredAreasIn: r to: newRectsToRepair ] - ifFalse: [ - newRectsToRepair add: r ]]. - thisMorphRects ifNotEmpty: [ - morphsToDraw add: morph. - rectsForEachMorph add: thisMorphRects. - thisMorphRects _ OrderedCollection new. - ]]. - i _ i + 1 ]. - - "*make this true to flash damaged areas for testing*" - Preferences debugShowDamage ifTrue: [ world fillRects: initialRectsToRepair ]. - - "Draw world background on those areas that were not completely covered by opaque morphs" - i > n ifTrue: [ - newRectsToRepair do: [ :r | - world drawOn: (canvas newClipRect: r) ]]. - - "Now, draw the recorded areas of selected morphs, back to front." - morphsToDraw with: rectsForEachMorph reverseDo: [ :m :xrects | - "Here we could think about merging all xrects into just one call... - This would mean drawing each morph just once. - But that would mean drawing pixels we were not told to. There could be other morphs in that area that are not even being drawn!! - See WorldState class >> #experiment1" - "*make this true to flash damaged areas for testing*" - Preferences debugShowDamage2 ifTrue: [ - world fillRects: xrects ]. -" rr _ nil." - xrects do: [ :r | -" rr _ rr ifNil: [ r ] ifNotNil: [ r quickMerge: rr ]." - (canvas newClipRect: r) fullDraw: m. - ]. -" (canvas newClipRect: rr) fullDraw: m" - ]. - - "Answer a list of rectangles to be updated on the Display. - This usually is not performance critical, drawing morphs is slower than just exposing the Display." - "What should we force on Display? Whatever was asked? Each small rect that was updated? A single bigger rect? - Right now, answer whatever was asked... Maybe this could be changed if that enhances performance... - (think of vnc over slow networks)" - ^ initialRectsToRepair! - -WorldState removeSelector: #simpleDrawInvalidAreasSubmorphs:! - -!methodRemoval: WorldState #simpleDrawInvalidAreasSubmorphs: stamp: 'Install-4268-Morphic-Refactor-JuanVuletich-2020Jul20-16h20m-jmv.001.cs.st 8/5/2020 22:22:45'! -simpleDrawInvalidAreasSubmorphs: submorphs - - "mover todo esto al canvas, no? - Y ver que hacer con los argumentos, etc.... Toda esta bananarama!!" - - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - This simple implementation just does as requested: No optimizations are done." - - | rectsToRepair morphBounds | - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ damageRecorder invalidRectsFullBounds: world viewBox. - - "Draw World" - rectsToRepair do: [ :r | - world drawOn: (canvas newClipRect: r) ]. - - "Draw morphs" - submorphs reverseDo: [ :morph | - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - rectsToRepair do: [ :r | - (morphBounds intersects: r) ifTrue: [ - (canvas newClipRect: r) fullDraw: morph ]]]]. - - ^ rectsToRepair! - -SystemWindow removeSelector: #addPossiblyUncoveredAreasIn:to:! - -!methodRemoval: SystemWindow #addPossiblyUncoveredAreasIn:to: stamp: 'Install-4268-Morphic-Refactor-JuanVuletich-2020Jul20-16h20m-jmv.001.cs.st 8/5/2020 22:22:45'! -addPossiblyUncoveredAreasIn: aRectangle to: aCollection - "Answer an array of rectangles encompassing those areas in aRectangle not completely - covered by self. These are the areas that might require further drawing (of morphs below us) - All areas that might possibly be uncovered must be included." - | bounds radious | - color mightBeTranslucent ifTrue: [ - aCollection add: aRectangle. - ^self ]. - - bounds _ self morphBoundsInWorld. - bounds ifNil: [ - aCollection add: aRectangle. - ^self ]. - - "Solid rectangle. - This will be the fastest in many cases. So, please disable rounded corners if on slow hardware!!" - Theme current roundWindowCorners ifFalse: [ - aRectangle areasOutside: bounds do: [ :rect | aCollection add: rect ]. - ^self ]. - - "The solid rectangle does not include the corners. - Report a couple of rows (top and bottom) or columns (left and right) as uncovered areas. - We could also try to be more careful and answer each rounded corner... - Right now, report top and bottom rows as uncovered areas" - radious _ Theme current roundedWindowRadius. - aRectangle areasOutside: (bounds insetBy: 0@radious) do: [ :rect | aCollection add: rect ]! - -RectangleLikeMorph removeSelector: #addPossiblyUncoveredAreasIn:to:! - -!methodRemoval: RectangleLikeMorph #addPossiblyUncoveredAreasIn:to: stamp: 'Install-4268-Morphic-Refactor-JuanVuletich-2020Jul20-16h20m-jmv.001.cs.st 8/5/2020 22:22:45'! -addPossiblyUncoveredAreasIn: aRectangle to: aCollection - "Answer an array of rectangles encompassing those areas in aRectangle not completely - covered by self. - All areas that might possibly be uncovered must be included." - (self isOrthoRectangularMorph and: [ self isOpaqueMorph ]) ifTrue: [ - aRectangle areasOutside: self morphBoundsInWorld do: [ :r | aCollection add: r ]. - ^self ]. - aCollection add: aRectangle! - -Morph removeSelector: #addPossiblyUncoveredAreasIn:to:! - -!methodRemoval: Morph #addPossiblyUncoveredAreasIn:to: stamp: 'Install-4268-Morphic-Refactor-JuanVuletich-2020Jul20-16h20m-jmv.001.cs.st 8/5/2020 22:22:45'! -addPossiblyUncoveredAreasIn: aRectangle to: aCollection - "Answer an array of rectangles encompassing those areas in aRectangle not completely - covered by self. - All areas that might possibly be uncovered must be included." - aCollection add: aRectangle! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4268-Morphic-Refactor-JuanVuletich-2020Jul20-16h20m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4262] on 18 July 2020 at 9:43:11 pm'! -!RectangleLikeMorph commentStamp: '' prior: 16899175! - Hierarchy for morphs that are rectangle like, and that occupy an area that can be specified as a Rectangle. This means that, besides being of rectangular shape, sides are aligned with local coordinate axes. Including rectangles with rounded corners and such. The idea is that the 'extent' ivar is all that's needed to establish our dimensions and shape. Subclasses can add things like 'roundedCornerRadious' or such.! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/18/2020 21:35:00'! - requiresVectorCanvas - "True if we use VectorCanvas protocol, or we are rotated or zoomed. - If false, we occupy a Rectangle in local coordinates. Allows for many optimizations to be done. - Note: If answer is false, but some owner requiresVectorCanvas, then we also do. Canvas takes care of this. - Note: SystemWindow answers false, but implements #addPossiblyUncoveredAreasIn:to: to take care of rounded corners." - - ^true! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/18/2020 21:38:32'! - submorphsMightProtrude - "Answered false by morphs that can guarantee that submorphs, and all morphs in their submorphs tree, will lie inside their bounds, - either 'naturally' (by construction) or by being clipped by their owner (#clipsLastSubmorph). Allows for many optimizations to be done." - - ^true! ! -!RectangleLikeMorph methodsFor: 'geometry testing' stamp: 'jmv 7/18/2020 21:35:08' overrides: 50532141! - requiresVectorCanvas - "True if we use VectorCanvas protocol, or we are rotated or zoomed. - If false, we occupy a Rectangle in local coordinates. Allows for many optimizations to be done. - Note: If answer is false, but some owner requiresVectorCanvas, then we also do. Canvas takes care of this. - Note: SystemWindow answers false, but implements #addPossiblyUncoveredAreasIn:to: to take care of rounded corners." - - ^location isPureTranslation not! ! -!RectangleLikeMorph methodsFor: 'geometry testing' stamp: 'jmv 7/18/2020 21:38:44' overrides: 50532157! - submorphsMightProtrude - "Answered false by morphs that can guarantee that submorphs, and all morphs in their submorphs tree, will lie inside their bounds, - either 'naturally' (by construction) or by being clipped by their owner (#clipsLastSubmorph). Allows for many optimizations to be done." - - ^false! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/18/2020 21:37:13' prior: 16874291! - clipsLastSubmorph - "Answer true if we clip the shape of our last submorph to ours. - Answer true only when clipping by the canvas is needed." - - ^ false! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/18/2020 21:35:45' prior: 16875601! - isOrthoRectangularMorph - "True if we are of rectangular shape, aligned with local coordinate axes. - Doesn't take into account possible rotation of our or some owner's local coordinates. - Note: SystemWindow answers true, but implements #addPossiblyUncoveredAreasIn:to: to take care of rounded corners." - - ^false! ! -!RectangleLikeMorph methodsFor: 'geometry testing' stamp: 'jmv 7/18/2020 21:35:50' prior: 16899320 overrides: 50532209! - isOrthoRectangularMorph - "True if we are of rectangular shape, aligned with local coordinate axes. - Doesn't take into account possible rotation of our or some owner's local coordinates. - Note: SystemWindow answers true, but implements #addPossiblyUncoveredAreasIn:to: to take care of rounded corners." - - ^true! ! -!PluggableScrollPane methodsFor: 'geometry testing' stamp: 'jmv 7/18/2020 21:37:41' prior: 16889528 overrides: 50532201! - clipsLastSubmorph - "Answer true if we clip the shape of our last submorph to ours. - Answer true only when clipping by the canvas is needed." - - ^ true! ! -!WindowEdgeAdjustingMorph methodsFor: 'geometry testing' stamp: 'jmv 7/18/2020 21:32:52' prior: 16945120 overrides: 50532223! - isOrthoRectangularMorph - ^false! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4269-NewProtocolsAndComments-JuanVuletich-2020Jul18-20h52m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4266] on 20 July 2020 at 5:20:13 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/20/2020 17:06:19'! - displayBounds - "At time of last draw. nil if unknown." - - self visible ifFalse: [ ^nil ]. - ^ self valueOfProperty: #displayBounds! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/20/2020 17:12:49'! - displayBounds: aRectangle - "If we update know bounds, chances are last draw operation used incorrect value. Draw again then." - - self displayBounds ~= aRectangle ifTrue: [ - self setProperty: #displayBounds toValue: aRectangle ].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/20/2020 17:11:35'! - displayBoundsOrBogus - "Never answer nil. A bogus value will trigger a draw operation, and bounds will then be corrected." -"Ver si esto aun tiene algun sentido" - ^self displayBounds ifNil: [ - Rectangle center: (self externalizeToWorld: 0@0) extent: 2@2 ]! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/20/2020 17:10:46'! - displayFullBounds - "Answer a rectangle that completely bounds receiver and submorphs when last drawn - (if the world was to be fully drawn, i.e. only to be used on a Canvas on the full world)." - - | answer | - answer _ self displayBounds. - answer isNil ifTrue: [ ^nil ]. - self submorphsDrawingOutsideReverseDo: [ :m | - answer _ answer quickMerge: m displayFullBounds ]. - ^answer! ! -!PasteUpMorph methodsFor: 'geometry' stamp: 'jmv 7/20/2020 17:14:34' overrides: 50532257! - displayBounds - ^self isWorldMorph ifTrue: [0@0 extent: extent] ifFalse: [super displayBounds]! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 7/20/2020 17:16:36' overrides: 50532285! - displayFullBounds -"ver lo que habia hecho. #lastPos, reusar cuando se mueve." - ^super displayFullBounds! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/20/2020 17:18:36' prior: 16877416! - displayBoundsInWorldOf: aMorph - "Answer a rectangle that completely bounds aMorph when drawn on our form. - Might be larger than strictly required. - - In Morphic 2, this could cause clipping artifacts. This doesn't usually happen because: - a) Morphic 2 doesn't use scaling and rotation - b) Most Morphic 2 morphs have rectangular shape. - - In Morphic 3, clipping also considers the real shape of the owner morph. This avoids those artifacts." -"borrar?" - "Think about doing a BoundsFinderCanvas even for Morphic 2" - self flag: #jmvVer2. - - ^self externalizeDisplayBounds: aMorph morphLocalBounds from: aMorph! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/20/2020 17:18:44' prior: 50531825! - displayFullBoundsInWorldOf: aMorph - "Answer a rectangle that completely bounds aMorph and submorphs when drawn - (if the world was to be fully drawn, i.e. only to be used on a Canvas on the full world). - Might be larger than strictly required. See comment at #displayBoundsInWorldOf:" - - | r | - "Think about doing a BoundsFinderCanvas even for Morphic 2" -"borrar?" - self flag: #jmvVer2. - - r _ self displayBoundsInWorldOf: aMorph. - aMorph submorphsDrawingOutsideReverseDo: [ :m | - m visible ifTrue: [ - r _ r quickMerge: (self displayFullBoundsInWorldOf: m) ]]. - - ^r! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/20/2020 17:19:44' prior: 50530670! - drawCurrentAndSubmorphs - - self isCurrentMorphVisible ifTrue: [ - currentMorph drawOn: self. - world notNil ifTrue: [ - currentMorph displayBounds: self boundingRectOfCurrentMorphAfterDraw ]. - "Display submorphs back to front" - "coordinate system stack already set up for aMorph - ('ivars transformations' and 'currentTransformation')" - currentMorph hasSubmorphs ifTrue: [ - currentMorph clippedSubmorph ifNotNil: [ :clipped | - self clippingByCurrentMorphDo: [ self fullDraw: clipped ]]. - currentMorph unclippedSubmorphsReverseDo: [ :m | - self fullDraw: m ]]].! ! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 7/11/2020 09:41:46' prior: 50531331! - boundingRectOfCurrentMorphAfterDraw - "This rectangle is used for clipping submorphs in BitBltCanvas. - In VectorCanvas we support clipping by any shape, not just rectangles. Then, this rectangle is used as an optimization of the area to be redrawn." - - self subclassResponsibility! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4270-Morphic-VG-JuanVuletich-2020Jul20-17h01m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4267] on 21 July 2020 at 11:16:42 am'! -!Morph methodsFor: 'updating' stamp: 'jmv 7/20/2020 17:26:13'! - isRedrawNeeded - "Report that the area occupied by this morph should be redrawn." -"Creo que es mejor transformarlo en una coleccion. Ver." - - self visible ifFalse: [ ^false ]. - ^ self valueOfProperty: #isRedrawNeeded ifAbsent: [ false ]! ! -!WorldState methodsFor: 'drawing' stamp: 'jmv 7/20/2020 17:30:42'! - displayWorldAndSubmorphs - "Update this world's display." - - | deferredUpdateVMMode worldDamageRects handsToDraw allDamage | - self checkIfUpdateNeeded ifFalse: [ ^ self ]. "display is already up-to-date" - "I (jmv) removed the call to 'deferUpdates: false' below. No more need to call this every time." - deferredUpdateVMMode _ self tryDeferredUpdatingAndSetCanvas. - - "repair world's damage on canvas" - worldDamageRects _ canvas drawWorld: world repair: damageRecorder. - - "Check which hands need to be drawn (they are not the hardware mouse pointer)" - handsToDraw _ self selectHandsToDrawForDamage: worldDamageRects. - allDamage _ Array streamContents: [ :strm | - strm nextPutAll: worldDamageRects. - handsToDraw do: [ :h | - h savePatchFrom: canvas appendDamageTo: strm ]]. - - "Draw hands (usually carying morphs) onto world canvas" - canvas newClipRect: nil. - handsToDraw reverseDo: [ :h | canvas fullDrawHand: h ]. - - "quickly copy altered rects of canvas to Display:" - deferredUpdateVMMode ifFalse: [ - "Drawing was done to off-Display canvas. Copy content to Display" - canvas showAt: world viewBox origin invalidRects: allDamage ]. - - "Display deferUpdates: false." - "Display forceDisplayUpdate" - Display forceDamageToScreen: allDamage. - - "Restore world canvas under hands and their carried morphs" - handsToDraw do: [ :h | h restoreSavedPatchOn: canvas ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/20/2020 17:52:34'! - drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rectsToRepair previousRectsToRepair reuse previousCount morphBounds | - - "Add dirty rectangles for all dirty morphs" - aPasteUpMorph allMorphsDo: [ :morph | - morph isRedrawNeeded ifTrue: [ - morph setProperty: #isRedrawNeeded toValue: false. - morph displayFullBounds ifNotNil: [ :r | - aDamageRecorder recordInvalidRect: r ]]]. - - "Aca agregar el seoudodibujado para actualizar los bounds que sean necesarios" - - "Add dirty rectangles for all dirty morphs" - aPasteUpMorph allMorphsDo: [ :morph | - morph isRedrawNeeded ifTrue: [ - morph displayFullBounds ifNotNil: [ :r | - aDamageRecorder recordInvalidRect: r ]]]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ aDamageRecorder invalidRectsFullBounds: aPasteUpMorph viewBox. - - rectsToRepair size > 1 ifTrue: [ "Or there is no point in attempting to merge them!!" - previousRectsToRepair _ OrderedCollection new. - - "Until no more rectangles are merged, i.e. each morph intersects at most one rectangle." - previousCount _ 0. - [rectsToRepair size = previousCount] whileFalse: [ - previousCount _ rectsToRepair size. - aPasteUpMorph submorphsReverseDo: [ :morph | | thisMorphRectangle thisMorphBounds | - morph visible ifTrue: [ - reuse _ previousRectsToRepair. - previousRectsToRepair _ rectsToRepair. - rectsToRepair _ reuse removeAll. - thisMorphRectangle _ nil. - thisMorphBounds _ morph morphFullBoundsInWorld. - previousRectsToRepair do: [ :r | - (thisMorphBounds intersects: r) - ifTrue: [ thisMorphRectangle _ r quickMerge: thisMorphRectangle ] - ifFalse: [ rectsToRepair add: r ]]. - thisMorphRectangle - ifNotNil: [rectsToRepair add: thisMorphRectangle]]]]. - ]. - - "Draw World" - rectsToRepair do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - "Draw morphs" - aPasteUpMorph submorphsReverseDo: [ :morph | - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - rectsToRepair do: [ :r | - (morphBounds intersects: r) ifTrue: [ - (self newClipRect: r) fullDraw: morph ]]]]. - - ^ rectsToRepair! ! -!Morph methodsFor: 'updating' stamp: 'jmv 7/21/2020 10:48:14' prior: 16877018! - redrawNeeded - "Report that the area occupied by this morph should be redrawn." - - self flag: #jmvVer2. - "Invalidate the appropriate display rectangle... Include submorphs if we don't clip!! - Think about it. We don't to know about a specific display rectangle... How do we notify our 'observers' (i.e. the possible canvases we end drawn upon)?" - - self isRedrawNeeded ifFalse: [ - self setProperty: #isRedrawNeeded toValue: true ]. -"Dummy, so #updateIsNeeded answers true if some morph dirty" -self invalidateDisplayRect: (10@10 extent: 2@2) from: nil. -false ifTrue: [ - self morphBoundsInWorld ifNotNil: [ :r | - self invalidateDisplayRect: r from: nil. - "Expensive in many cases..." - self submorphsDrawingOutsideReverseDo: [ :m | m redrawNeeded ]] -]! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 7/20/2020 17:30:57' prior: 50339875! - privateOuterDisplayWorld - - worldState displayWorldAndSubmorphs! ! - -MorphicCanvas removeSelector: #drawWorld:submorphs:repair:! - -!methodRemoval: MorphicCanvas #drawWorld:submorphs:repair: stamp: 'Install-4271-Morphic-VG-JuanVuletich-2020Jul21-10h41m-jmv.001.cs.st 8/5/2020 22:22:45'! -drawWorld: aPasteUpMorph submorphs: worldSubmorphs repair: aDamageRecorder - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rectsToRepair previousRectsToRepair reuse previousCount morphBounds | - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ aDamageRecorder invalidRectsFullBounds: aPasteUpMorph viewBox. - - rectsToRepair size > 1 ifTrue: [ "Or there is no point in attempting to merge them!!" - previousRectsToRepair _ OrderedCollection new. - - "Until no more rectangles are merged, i.e. each morph intersects at most one rectangle." - previousCount _ 0. - [rectsToRepair size = previousCount] whileFalse: [ - previousCount _ rectsToRepair size. - worldSubmorphs reverseDo: [ :morph | | thisMorphRectangle thisMorphBounds | - morph visible ifTrue: [ - reuse _ previousRectsToRepair. - previousRectsToRepair _ rectsToRepair. - rectsToRepair _ reuse removeAll. - thisMorphRectangle _ nil. - thisMorphBounds _ morph morphFullBoundsInWorld. - previousRectsToRepair do: [ :r | - (thisMorphBounds intersects: r) - ifTrue: [ thisMorphRectangle _ r quickMerge: thisMorphRectangle ] - ifFalse: [ rectsToRepair add: r ]]. - thisMorphRectangle - ifNotNil: [rectsToRepair add: thisMorphRectangle]]]]. - ]. - - "Draw World" - rectsToRepair do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - "Draw morphs" - worldSubmorphs reverseDo: [ :morph | - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - rectsToRepair do: [ :r | - (morphBounds intersects: r) ifTrue: [ - (self newClipRect: r) fullDraw: morph ]]]]. - - ^ rectsToRepair! - -WorldState removeSelector: #displayWorldAndSubmorphs:! - -!methodRemoval: WorldState #displayWorldAndSubmorphs: stamp: 'Install-4271-Morphic-VG-JuanVuletich-2020Jul21-10h41m-jmv.001.cs.st 8/5/2020 22:22:45'! -displayWorldAndSubmorphs: submorphs - "Update this world's display." - - | deferredUpdateVMMode worldDamageRects handsToDraw allDamage | - self checkIfUpdateNeeded ifFalse: [ ^ self ]. "display is already up-to-date" - "I (jmv) removed the call to 'deferUpdates: false' below. No more need to call this every time." - deferredUpdateVMMode _ self tryDeferredUpdatingAndSetCanvas. - - "repair world's damage on canvas" - worldDamageRects _ canvas drawWorld: world submorphs: submorphs repair: damageRecorder. - - "Check which hands need to be drawn (they are not the hardware mouse pointer)" - handsToDraw _ self selectHandsToDrawForDamage: worldDamageRects. - allDamage _ Array streamContents: [ :strm | - strm nextPutAll: worldDamageRects. - handsToDraw do: [ :h | - h savePatchFrom: canvas appendDamageTo: strm ]]. - - "Draw hands (usually carying morphs) onto world canvas" - canvas newClipRect: nil. - handsToDraw reverseDo: [ :h | canvas fullDrawHand: h ]. - - "quickly copy altered rects of canvas to Display:" - deferredUpdateVMMode ifFalse: [ - "Drawing was done to off-Display canvas. Copy content to Display" - canvas showAt: world viewBox origin invalidRects: allDamage ]. - - "Display deferUpdates: false." - "Display forceDisplayUpdate" - Display forceDamageToScreen: allDamage. - - "Restore world canvas under hands and their carried morphs" - handsToDraw do: [ :h | h restoreSavedPatchOn: canvas ].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4271-Morphic-VG-JuanVuletich-2020Jul21-10h41m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4268] on 22 July 2020 at 10:20:30 am'! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 7/21/2020 11:21:47' overrides: 50501541! - textComposition: aTextComposition bounds: boundsRect color: c selectionColor: sc - engine ifNil: [ ^nil ]. - -^super textComposition: aTextComposition bounds: boundsRect color: c selectionColor: sc! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 7/21/2020 11:47:47' overrides: 50531363! - clippingByCurrentMorphDo: aBlock -"si clippeamos, tenemos un problemon. -queremos bounds no afectados por el clipping debido a los rectangles a repara -pero si por el owner. OJO!! -Creo que lo que habria que hacer es en #displayBounds:, si clippingMorph no es nil, pedirle sus displayBounds y hacer interseccion. -Y aca, ejecutar normalmente" -" engine ifNil: [ ^self ]." - ^super clippingByCurrentMorphDo: aBlock! ! -!BitBltCanvas methodsFor: 'drawing' stamp: 'jmv 7/21/2020 11:25:28' prior: 50494702 overrides: 50463404! - line: pt1 to: pt2 width: wp color: c - | p1 p2 w | - - engine ifNil: [ ^nil ]. - - (wp > 0 and: [ c isTransparent not ]) ifTrue: [ - p1 _ (currentTransformation transform: pt1) rounded. - p2 _ (currentTransformation transform: pt2) rounded. - w _ currentTransformation externalizeScalar: wp. - self setPaintColor: c. - engine - width: w; - height: w; - drawFrom: p1 to: p2 ]! ! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 7/21/2020 11:24:36' prior: 16786569 overrides: 50463414! - image: aForm at: aPoint - "Draw a translucent image using the best available way of representing translucency." - - - engine ifNil: [ ^nil ]. - - self image: aForm - at: aPoint - sourceRect: aForm boundingBox! ! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 7/21/2020 11:24:40' prior: 50494716 overrides: 50463419! - image: aForm at: aPoint sourceRect: sourceRect - "Draw a translucent image using the best available way of representing translucency. - Note: This will be fixed in the future." - | r p | - - engine ifNil: [ ^nil ]. - - p _ (currentTransformation transform: aPoint) rounded. - r _ (self depth < 32 or: [ aForm mightBeTranslucent not ]) - ifTrue: [ - "Rule Form paint treats pixels with a value of zero as transparent" - Form paint ] - ifFalse: [ Form blend ]. - engine colorMap: (aForm colormapIfNeededFor: form); fillColor: nil. - engine image: aForm at: p sourceRect: sourceRect rule: r. - (self depth = 32 and: [ aForm depth < 32 ]) ifTrue: [ - "If we blit to 32bpp from one of smaller depth, - it will have zero in the alpha channel (until BitBlt is fixed!!) - This is the same workaround as in #asFormOfDepth:" - engine sourceForm: nil. - engine combinationRule: 40. "fixAlpha:with:" - engine copyBits ]! ! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 7/21/2020 11:24:43' prior: 16786616 overrides: 50463429! - stencil: stencilForm at: aPoint color: aColor - "Flood this canvas with aColor wherever stencilForm has non-zero pixels - - Display getCanvas stencil: (Form makeStar asFormOfDepth: 1) at: 20@20 color: Color red. Display forceToScreen - " - - engine ifNil: [ ^nil ]. - - ^self stencil: stencilForm - at: aPoint - sourceRect: stencilForm boundingBox - color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 7/21/2020 11:24:47' prior: 50494747 overrides: 50463434! - stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor - "Flood this canvas with aColor wherever stencilForm has non-zero pixels" - | p | - - engine ifNil: [ ^nil ]. - - p _ (currentTransformation transform: aPoint) rounded. - self setPaintColor: aColor. - engine colorMap: stencilForm maskingMap. - engine stencil: stencilForm - at: p - sourceRect: sourceRect! ! -!BitBltCanvas methodsFor: 'drawing-ovals' stamp: 'jmv 7/21/2020 11:24:27' prior: 50494761 overrides: 50463440! -ellipseCenterX: mcx y: mcy rx: mrx ry: mry borderWidth: mbw borderColor: mbc fillColor: morphFillColor - - | displayRectangle doBorder doFill | - - engine ifNil: [ ^nil ]. - - doBorder _ mbw > 0 and: [ mbc isTransparent not]. - doFill _ morphFillColor isTransparent not. - doBorder | doFill ifTrue: [ - displayRectangle _ (currentTransformation externalizeRectangle: (Rectangle center: mcx@mcy extent: mrx@mry * 2)) rounded. - "draw the border of the oval" - doBorder ifTrue: [ - self setPaintColor: mbc. - engine frameOval: displayRectangle borderWidth: mbw]. - "fill the inside" - doFill ifTrue: [ - self setPaintColor: morphFillColor. - engine fillOval: (displayRectangle insetBy: mbw) ]]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 7/21/2020 11:23:50' prior: 50388623 overrides: 50463447! - fillRectangle: aRectangle color: aColor - "Fill the given rectangle." - - - engine ifNil: [ ^nil ]. - - aColor isTransparent ifFalse: [ - self - frameAndFillRectangle: aRectangle - fillColor: aColor - borderWidth: 0 - borderColor: `Color transparent` ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 7/21/2020 11:23:54' prior: 16786676 overrides: 50463452! - fillRectangle: aRectangle color: aColor borderWidth: borderWidth borderStyleSymbol: aSymbol baseColorForBorder: baseColorForBorder - - - engine ifNil: [ ^nil ]. - - self fillRectangle: (aRectangle insetBy: borderWidth) color: aColor. - self frameRectangle: aRectangle color: baseColorForBorder borderWidth: borderWidth borderStyleSymbol: aSymbol! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 7/21/2020 11:23:59' prior: 16786689 overrides: 50463460! - fillRectangle: aRectangle tilingWith: aForm multipliedBy: aColor - "Fill aRectangle with the equivalent of aForm multiplied by aColor - aForm is a kind of advanced stencil, supplying brightness and opacity at each pixel - Similar to #image:multipliedBy:at: - - - Display getCanvas fillRectangle: (10@10 extent: 100@100) tilingWith: (BitBltCanvas verticalGrayGradient: 30 gradientTop: 0.8 gradientBottom: 0.5) multipliedBy: Color red. Display forceToScreen. - " - - - engine ifNil: [ ^nil ]. - - self class accessProtect critical: [ - self buildAuxWith: aForm multipliedWith: aColor. - "Warning: aForm boundingBox is most likely different from AuxForm boundingBox!!" - self fillRectangle: aRectangle tilingWith: AuxForm sourceRect: aForm boundingBox rule: Form paint ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 7/21/2020 11:24:04' prior: 50494785 overrides: 50463466! - frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor - | rect bw | - - - engine ifNil: [ ^nil ]. - - r area = 0 ifTrue: [ ^self ]. - rect _ (currentTransformation externalizeRectangle: r) rounded. - bw _ currentTransformation externalizeScalar: borderWidth. - - "draw the border of the rectangle" - borderColor isTransparent ifFalse: [ - self setPaintColor: borderColor. - engine frameRect: rect borderWidth: bw ]. - - "fill the inside" - fillColor isTransparent ifFalse: [ - self setPaintColor: fillColor. - engine fillRect: (rect insetBy: bw) ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 7/21/2020 11:24:08' prior: 50494806 overrides: 50463473! - frameRectangle: r borderWidth: borderWidth color: borderColor - " - Display getCanvas - frameRectangle: (10@10 extent: 300@200) - borderWidth: 20 - color: Color red. - Display forceToScreen - " - | rect bw | - - engine ifNil: [ ^nil ]. - - (borderWidth > 0 and: [ borderColor isTransparent not ]) ifTrue: [ - rect _ (currentTransformation externalizeRectangle: r) rounded. - bw _ currentTransformation externalizeScalar: borderWidth. - self setPaintColor: borderColor. - engine - frameRect: rect - borderWidth: bw ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 7/21/2020 11:24:17' prior: 50459991 overrides: 50463479! - frameRectangle: r color: aColor borderWidth: borderWidth borderStyleSymbol: aSymbol - " - Display getCanvas fillRectangle: (10@10 extent: 300@200) color: Color white. Display forceToScreen. - Display getCanvas - frameRectangle: (10@10 extent: 300@200) - color: Color green - borderWidth: 10 - borderStyleSymbol: #raised. - Display forceToScreen. - " - - | displayRectangle bw | - - engine ifNil: [ ^nil ]. - - bw _ (currentTransformation externalizeScalar: borderWidth) rounded. - aSymbol == #raised ifTrue: [ - displayRectangle _ (currentTransformation externalizeRectangle: r) rounded. - ^ self - frameRectangle: displayRectangle - borderWidth: bw - topLeftColor: aColor quiteWhiter - bottomRightColor: aColor quiteBlacker ]. - - aSymbol == #inset ifTrue: [ - displayRectangle _ (currentTransformation externalizeRectangle: r) rounded. - ^ self - frameRectangle: displayRectangle - borderWidth: bw - topLeftColor: aColor quiteBlacker - bottomRightColor: aColor quiteWhiter ]. - - "Unrecognized border style. Draw some border..." - self frameRectangle: r borderWidth: bw color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 7/21/2020 11:24:21' prior: 50494825 overrides: 50463486! - reverseRectangleBorder: r borderWidth: borderWidth - " - Display getCanvas - reverseRectangleBorder: (10@10 extent: 300@200) - borderWidth: 20. - Display forceToScreen - " - | rect | - - engine ifNil: [ ^nil ]. - - rect _ (currentTransformation externalizeRectangle: r) rounded. - engine - sourceForm: nil; - fillColor: `Color gray`; - combinationRule: Form reverse; - frameRect: rect borderWidth: borderWidth! ! -!BitBltCanvas methodsFor: 'drawing-roundedRectangles' stamp: 'jmv 7/21/2020 11:23:29' prior: 16786804 overrides: 50463492! - roundRect: aRectangle color: aColor radius: r - " - Display getCanvas roundRect: (10@10 extent: 200@100) color: Color red radius: 10 - " - - engine ifNil: [ ^nil ]. - - "radious is not scaled properly..." - "top stripe" - self - image: (self class topLeftCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle topLeft. - self - image: (self class topRightCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle topRight - (r@0). - self fillRectangle: ((aRectangle withHeight: r) insetBy: r@0) color: aColor. - - "center stripe" - self fillRectangle: (aRectangle insetBy: (0 @ r corner: 0 @ r)) color: aColor. - - "bottom stripe" - self - image: (self class bottomLeftCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle bottomLeft - (0@r). - self - image: (self class bottomRightCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle bottomRight - (r@r) . - self fillRectangle: ((aRectangle bottomLeft + (r@r negated)) extent: (aRectangle width - r - r@r)) color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-roundedRectangles' stamp: 'jmv 7/21/2020 11:23:34' prior: 16786841 overrides: 50463498! - roundRect: displayRectangle color: aColor radius: r gradientTop: topFactor gradientBottom: bottomFactor gradientHeight: h - " - Display restore. - BitBltCanvas releaseClassCachedState. - Display getCanvas roundRect: (10@10 extent: 200@100) color: Color red radius: 10 gradientTop: 1.0 gradientBottom: 0.5 gradientHeight: 35 - " - | bottomColor | - - engine ifNil: [ ^nil ]. - - "top stripe" - self - image: (self class topLeftCorner: r height: h gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: displayRectangle topLeft. - self - image: (self class topRightCorner: r height: h gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: displayRectangle topRight - (r@0). - self - fillRectangle: ((displayRectangle withHeight: h) insetBy: r@0) - tilingWith: (self class verticalGrayGradient: h gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor. - - bottomColor _ aColor * bottomFactor. - "center stripe" - self fillRectangle: (displayRectangle insetBy: (0 @ h corner: 0 @ r)) color: bottomColor. - - "bottom stripe" - self - image: (self class bottomLeftCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: bottomColor - at: displayRectangle bottomLeft - (0@r). - self - image: (self class bottomRightCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: bottomColor - at: displayRectangle bottomRight - (r@r) . - self fillRectangle: ((displayRectangle bottomLeft + (r@r negated)) extent: (displayRectangle width - r - r@r)) color: bottomColor! ! -!BitBltCanvas methodsFor: 'drawing-roundedRectangles' stamp: 'jmv 7/21/2020 11:23:38' prior: 16786891 overrides: 50463506! -roundRect: aRectangle color: aColor radius: r gradientTop: topFactor gradientCenter: centerFactor gradientBottom: bottomFactor gradient1Height: h1 - " - Display restore. - BitBltCanvas releaseClassCachedState. - Display getCanvas roundRect: (10@10 extent: 200@100) color: Color red radius: 10 gradientTop: 1.0 gradientCenter: 0.0 gradientBottom: 1.0 gradient1Height: 35 - " - | h2 | - - engine ifNil: [ ^nil ]. - - "top stripe" - self - image: (self class topLeftCorner: r height: h1 gradientTop: topFactor gradientBottom: centerFactor) - multipliedBy: aColor - at: aRectangle topLeft. - self - image: (self class topRightCorner: r height: h1 gradientTop: topFactor gradientBottom: centerFactor) - multipliedBy: aColor - at: aRectangle topRight - (r@0). - self - fillRectangle: ((aRectangle withHeight: h1) insetBy: r@0) - tilingWith: (self class verticalGrayGradient: h1 gradientTop: topFactor gradientBottom: centerFactor) - multipliedBy: aColor. - - "bottom stripe" - h2 _ aRectangle height - h1. - self - image: (self class bottomLeftCorner: r height: h2 gradientTop: centerFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: aRectangle topLeft + (0@h1). - self - image: (self class bottomRightCorner: r height: h2 gradientTop: centerFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: aRectangle topRight + (r negated@h1). - self - fillRectangle: ((aRectangle topLeft + (r@h1)) extent: (aRectangle width-r-r@h2)) - tilingWith: (self class verticalGrayGradient: h2 gradientTop: centerFactor gradientBottom: bottomFactor) - multipliedBy: aColor.! ! -!BitBltCanvas methodsFor: 'drawing-roundedRectangles' stamp: 'jmv 7/21/2020 11:23:43' prior: 50376977 overrides: 50463515! - windowFrame: aRectangle color: aColor radius: r border: bw labelHeight: lh gradientTop: topFactor gradientBottom: bottomFactor insideColor: insideColor - " - BitBltCanvas releaseClassCachedState. - Display getCanvas windowFrame: (10@10 extent: 200@100) color: Color red radius: 10 border: 5 labelHeight: 25 gradientTop: 1.0 gradientBottom: 0.5 insideColor: Color green. - Display forceToScreen - " - "top stripe" - | bottomColor he tl tr | - - engine ifNil: [ ^nil ]. - - self - image: (self class topLeftCorner: r height: lh gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: aRectangle topLeft. - self - image: (self class topRightCorner: r height: lh gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: aRectangle topRight - (r@0). - self - fillRectangle: ((aRectangle withHeight: lh) insetBy: r@0) - tilingWith: (self class verticalGrayGradient: lh gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor. - - bottomColor _ aColor * bottomFactor. - - "left and right borders" - tl _ aRectangle topLeft + (0@lh). - tr _ aRectangle topRight + (bw negated@lh). - he _ bw@(aRectangle height - lh - r). - self fillRectangle: (tl extent: he) color: bottomColor. - self fillRectangle: (tr extent: he) color: bottomColor. - - "bottom stripe" - self - image: (self class bottomLeftCorner: r height: r gradientTop: 1 gradientBottom: 1 borderWidth: bw) - multipliedBy: bottomColor - at: aRectangle bottomLeft - (0@r). - self - image: (self class bottomRightCorner: r height: r gradientTop: 1 gradientBottom: 1 borderWidth: bw) - multipliedBy: bottomColor - at: aRectangle bottomRight - (r@r) . - self fillRectangle: ((aRectangle bottomLeft + (r@bw negated)) extent: (aRectangle width - r - r@bw)) color: bottomColor. - - "inside" - self fillRectangle: (aRectangle insetBy: (bw@lh corner: bw@bw)) color: insideColor! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 7/21/2020 11:18:45' prior: 50523140 overrides: 50463524! - drawString: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | p1 font | - engine ifNil: [ ^nil ]. - - "Don't waste any time if NOP" - lastIndex = 0 ifTrue: [ - ^nil ]. - - p1 _ (currentTransformation transform: aPoint rounded) rounded. - engine colorMap: nil. - font _ fontOrNil ifNil: [ FontFamily defaultFamilyAndPointSize ]. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 7/21/2020 11:22:10' prior: 50524881 overrides: 50388595! - drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - | p1 font | - - engine ifNil: [ ^nil ]. - - p1 _ (currentTransformation transform: aPoint rounded) rounded. - engine colorMap: nil. - font _ fontOrNil ifNil: [ FontFamily defaultFamilyAndPointSize ]. - - aColor = `Color black` ifFalse: [ | topColor | - topColor _ aColor alphaMixed: 0.25 with: `Color black`. - font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: topColor ]. - aColor = `Color white` ifFalse: [ | bottomColor | - bottomColor _ aColor alphaMixed: 0.22 with: `Color white`. - font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + `0@2` - color: bottomColor ]. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + `0@1` - color: aColor.! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 7/21/2020 11:28:05' prior: 50495223 overrides: 50501575! - setClipRect: aRectangle - "In targetForm coordinates" - - super setClipRect: aRectangle. - - engine ifNil: [ ^nil ]. - - engine clipRect: aRectangle! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4272-Morphic-VG-JuanVuletich-2020Jul22-10h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4269] on 22 July 2020 at 11:39:02 am'! -!HaloMorph methodsFor: 'geometry testing' stamp: 'jmv 7/22/2020 10:48:50' overrides: 50532188! - submorphsMightProtrude - "Handles and label are usually outside our bounds." - - ^true! ! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 7/21/2020 11:32:17'! - updatingMorphBoundsDo: aBlock - - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/22/2020 11:31:29'! - fullAddRedrawRect: aMorph to: aDamageRecorder - | addMyBounds trySubmorphs | - aMorph visible ifTrue: [ - addMyBounds _ aMorph valueOfProperty: #needsRedraw ifAbsent: [ false ]. - trySubmorphs _ aMorph valueOfProperty: #submorphNeedsRedraw ifAbsent: [ false ]. - (trySubmorphs or: [addMyBounds]) ifTrue: [ - self into: aMorph. - addMyBounds ifTrue: [ - currentMorph setProperty: #needsRedraw toValue: false. - "find bounds. - agregar mi rect" - currentMorph drawOn: self. - world notNil ifTrue: [ -"ATENCION: Este rectangulo deberia tomarse interseccion con el del clipping morph si lo hay. -Registrar el clippingMorph, o al menos su rect, en otra ivar." - aDamageRecorder recordInvalidRect: self boundingRectOfCurrentMorphAfterDraw ]. - ]. - trySubmorphs ifTrue: [ - "llamar recursivo a mis submorphs" - currentMorph setProperty: #submorphNeedsRedraw toValue: false. - currentMorph clippedSubmorph ifNotNil: [ :clipped | - self clippingByCurrentMorphDo: [ self fullAddRedrawRect: clipped to: aDamageRecorder ]]. - currentMorph unclippedSubmorphsReverseDo: [ :m | - self fullAddRedrawRect: m to: aDamageRecorder ] - ]. - self outOfMorph - ]]! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 7/21/2020 11:33:43' overrides: 50533254! - updatingMorphBoundsDo: aBlock - - | prevEngine | - prevEngine _ engine. - [ - engine _ nil. - aBlock value. - ] ensure: [ engine _ prevEngine ]! ! -!Morph methodsFor: 'submorphs-accessing' stamp: 'jmv 7/22/2020 10:49:44' prior: 16876743! - submorphsDrawingOutsideReverseDo: aBlock - "Might be redefined in subclasses that know that its submorphs are never outside itself" - - self submorphsMightProtrude ifTrue: [ - self unclippedSubmorphsReverseDo: aBlock ].! ! -!Morph methodsFor: 'updating' stamp: 'jmv 7/22/2020 11:07:35' prior: 50532395! - isRedrawNeeded - "Report that the area occupied by this morph should be redrawn." -"Creo que es mejor transformarlo en una coleccion. Ver." - - self visible ifFalse: [ ^false ]. - ^ self valueOfProperty: #needsRedraw ifAbsent: [ false ]! ! -!Morph methodsFor: 'updating' stamp: 'jmv 7/22/2020 11:38:50' prior: 50532527! - redrawNeeded - "Report that the area occupied by this morph should be redrawn." - - self flag: #jmvVer2. -"BTW, no method should call #redrawNeeded twice. Just once, before any updates." - "these properties... better store flags in 'id' " - self isRedrawNeeded ifFalse: [ - self setProperty: #needsRedraw toValue: true. - self allOwnersDo: [ :m | m setProperty: #submorphNeedsRedraw toValue: true ]. - self displayFullBounds - ifNil: [ - "Dummy, so #updateIsNeeded answers true if some morph dirty" - "Check if this is really needed. If so, find a cleaner way." - self invalidateDisplayRect: (10@10 extent: 2@2) from: nil ] - ifNotNil: [ :r | - self invalidateDisplayRect: r from: nil ]]. - -"hacer esto en todos los casos? o solo si invalido r?" - self submorphsDrawingOutsideReverseDo: [ :m | m redrawNeeded ]! ! -!HaloMorph methodsFor: 'event handling' stamp: 'jmv 7/22/2020 11:00:46' prior: 50531520 overrides: 50533327! - redrawNeeded - "Report that the area occupied by this morph should be redrawn." -"No debería alcanzar?" -true not ifTrue: [ ^super redrawNeeded ]. - self - invalidateDisplayRect: - ((self morphBoundsInWorld - outsetBy: self class handleSize*2) - extendBy: 0@(FontFamily defaultLineSpacing+self class handleSize)) - from: nil. - "Label could be wider than us..." - self submorphsDrawingOutsideReverseDo: [ :m | m redrawNeeded ]! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/22/2020 11:22:38' prior: 50532356! - drawCurrentAndSubmorphs - - self isCurrentMorphVisible ifTrue: [ - currentMorph drawOn: self. - world notNil ifTrue: [ - currentMorph displayBounds: self boundingRectOfCurrentMorphAfterDraw ]. - "Display submorphs back to front" - "coordinate system stack already set up for aMorph - ('ivars transformations' and 'currentTransformation')" - currentMorph clippedSubmorph ifNotNil: [ :clipped | - self clippingByCurrentMorphDo: [ self fullDraw: clipped ]]. - currentMorph unclippedSubmorphsReverseDo: [ :m | - self fullDraw: m ]].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/22/2020 11:36:38' prior: 50532450! - drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rectsToRepair previousRectsToRepair reuse previousCount morphBounds | - -false -ifFalse: [ -"Add dirty rectangles for all dirty morphs" -aPasteUpMorph allMorphsDo: [ :morph | - morph isRedrawNeeded ifTrue: [ - morph setProperty: #needsRedraw toValue: false. - morph displayFullBounds ifNotNil: [ :r | - aDamageRecorder recordInvalidRect: r ]]]. - -"Aca agregar el seoudodibujado para actualizar los bounds que sean necesarios" - -"Add dirty rectangles for all dirty morphs" -aPasteUpMorph allMorphsDo: [ :morph | - morph isRedrawNeeded ifTrue: [ - morph displayFullBounds ifNotNil: [ :r | - aDamageRecorder recordInvalidRect: r ]]]. -] -ifTrue: [ -"quizas llamarlo #findBoundsDo: o algo asi" - self updatingMorphBoundsDo: [ - aPasteUpMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - ]. -]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ aDamageRecorder invalidRectsFullBounds: aPasteUpMorph viewBox. - - rectsToRepair size > 1 ifTrue: [ "Or there is no point in attempting to merge them!!" - previousRectsToRepair _ OrderedCollection new. - - "Until no more rectangles are merged, i.e. each morph intersects at most one rectangle." - previousCount _ 0. - [rectsToRepair size = previousCount] whileFalse: [ - previousCount _ rectsToRepair size. - aPasteUpMorph submorphsReverseDo: [ :morph | | thisMorphRectangle thisMorphBounds | - morph visible ifTrue: [ - reuse _ previousRectsToRepair. - previousRectsToRepair _ rectsToRepair. - rectsToRepair _ reuse removeAll. - thisMorphRectangle _ nil. - thisMorphBounds _ morph morphFullBoundsInWorld. - previousRectsToRepair do: [ :r | - (thisMorphBounds intersects: r) - ifTrue: [ thisMorphRectangle _ r quickMerge: thisMorphRectangle ] - ifFalse: [ rectsToRepair add: r ]]. - thisMorphRectangle - ifNotNil: [rectsToRepair add: thisMorphRectangle]]]]. - ]. - - "Draw World" - rectsToRepair do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - "Draw morphs" - aPasteUpMorph submorphsReverseDo: [ :morph | - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - rectsToRepair do: [ :r | - (morphBounds intersects: r) ifTrue: [ - (self newClipRect: r) fullDraw: morph ]]]]. - - ^ rectsToRepair! ! - -MorphicCanvas removeSelector: #fullAddRectsToRepair:! - -SystemWindow removeSelector: #submorphsDrawingOutsideReverseDo:! - -!methodRemoval: SystemWindow #submorphsDrawingOutsideReverseDo: stamp: 'Install-4273-Morphic-VG-JuanVuletich-2020Jul22-10h48m-jmv.004.cs.st 8/5/2020 22:22:45'! -submorphsDrawingOutsideReverseDo: aBlock - "All our submorphs are inside us"! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4273-Morphic-VG-JuanVuletich-2020Jul22-10h48m-jmv.004.cs.st----! - -'From Cuis 5.0 [latest update: #4270] on 22 July 2020 at 11:47:36 am'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/22/2020 11:44:39' prior: 50533393! - drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rectsToRepair previousRectsToRepair reuse previousCount morphBounds | - -"quizas llamarlo #findBoundsDo: o algo asi" - self updatingMorphBoundsDo: [ - aPasteUpMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ aDamageRecorder invalidRectsFullBounds: aPasteUpMorph viewBox. - - rectsToRepair size > 1 ifTrue: [ "Or there is no point in attempting to merge them!!" - previousRectsToRepair _ OrderedCollection new. - - "Until no more rectangles are merged, i.e. each morph intersects at most one rectangle." - previousCount _ 0. - [rectsToRepair size = previousCount] whileFalse: [ - previousCount _ rectsToRepair size. - aPasteUpMorph submorphsReverseDo: [ :morph | | thisMorphRectangle thisMorphBounds | - morph visible ifTrue: [ - reuse _ previousRectsToRepair. - previousRectsToRepair _ rectsToRepair. - rectsToRepair _ reuse removeAll. - thisMorphRectangle _ nil. - thisMorphBounds _ morph morphFullBoundsInWorld. - previousRectsToRepair do: [ :r | - (thisMorphBounds intersects: r) - ifTrue: [ thisMorphRectangle _ r quickMerge: thisMorphRectangle ] - ifFalse: [ rectsToRepair add: r ]]. - thisMorphRectangle - ifNotNil: [rectsToRepair add: thisMorphRectangle]]]]. - ]. - - "Draw World" - rectsToRepair do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - "Draw morphs" - aPasteUpMorph submorphsReverseDo: [ :morph | - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - rectsToRepair do: [ :r | - (morphBounds intersects: r) ifTrue: [ - (self newClipRect: r) fullDraw: morph ]]]]. - - ^ rectsToRepair! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4274-Morphic-VG-JuanVuletich-2020Jul22-11h43m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4271] on 22 July 2020 at 12:17:10 pm'! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 7/22/2020 12:11:55' overrides: 16875420! - morphFullBoundsInWorld -"Usando los nombres viejos que estoy por hacer pelota. Repasar. -Ahora es displayFullBounds" - | fullBounds | - fullBounds _ self morphBoundsInWorld. - self submorphsFullBoundsInWorld ifNotNil: [ :b | - fullBounds _ b quickMerge: fullBounds ]. - ^fullBounds! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 7/22/2020 11:53:37'! - submorphsFullBoundsInWorld -"Usando los nombres viejos que estoy por hacer pelota. Repasar." - "Current full bounds of submorphs carried by the hand. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around)." - | fullBounds | - submorphs isEmpty ifTrue: [ ^nil ]. - fullBounds _ nil. - (self valueOfProperty:#lastPos) - ifNil: [ "Just once when a new morph (not in the world) is attached to the hand." - self submorphsDo: [ :m | - m morphFullBoundsInWorld ifNotNil: [ :b | - fullBounds _ fullBounds ifNil: [b] ifNotNil: [ fullBounds merge: b ]]]] - ifNotNil: [ :lastPos | "When carrying morphs around." - self submorphsDo: [ :m | - m displayFullBounds ifNotNil: [ :b | - fullBounds _ fullBounds ifNil: [b] ifNotNil: [ fullBounds merge: b ]]]. - fullBounds ifNil: [ ^nil ]. "bueeeenoooo" - fullBounds _ fullBounds translatedBy: self morphPosition-lastPos ]. - ^fullBounds! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 7/13/2020 09:50:36' prior: 16851618! - fullDrawHandOn: aCanvas - "A HandMorph has an unusual drawing requirement: - The hand itself (i.e., the cursor) appears in front of its submorphs - The illusion is that the hand plucks up morphs and carries them above the world." - - submorphs reverseDo: [ :m | aCanvas fullDraw: m ]. - self drawOn: aCanvas. "draw the hand itself in front of morphs" - self setProperty: #lastPos toValue: (submorphs notEmpty ifTrue: [self morphPosition] ifFalse: [nil])! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 7/22/2020 12:03:21' prior: 50532306 overrides: 50532285! - displayFullBounds -"ver lo que habia hecho. #lastPos, reusar cuando se mueve. -Done. -Por ahora esta en #morphFullBoundsInWorld" - ^super displayFullBounds! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 7/13/2020 10:31:49' prior: 16852062! - grabMorph: aMorph delta: delta - "Grab the given morph (i.e., add it to this hand and remove it from its current owner)." - - | formerOwner | - self releaseMouseFocus. "Break focus" - - "Grab the halo if present" - self halo ifNotNil: [ :h | - h target == aMorph ifTrue: [ - self addMorphBack: h position: h morphPositionInWorld - self morphPositionInWorld ]]. - - "Remember previous owner and position, in case the drop is later rejected" - formerOwner _ aMorph owner. - formerOwner ifNotNil: [ - grabMorphData - at: aMorph - put: { formerOwner. aMorph morphPositionInWorld. } ]. - self addMorphBack: aMorph position: delta. - aMorph justGrabbedFrom: formerOwner. - formerOwner ifNotNil: [ - self setProperty: #lastPos toValue: self morphPosition ].! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 7/22/2020 11:56:13' prior: 16852085! - grabMorph: aMorph moveUnderHand: moveUnderHand - "Grab the given morph (i.e., add it to this hand and remove it from its current owner). - If moveUnderHand is requested or it seems neccesary anyway, move the grabbed morph under the hand." - - | grabbed delta | - "#aboutToGrab: and #aboutToBeGrabbedBy: might mess wildly with our morphs. - If we need it, prepare delta before that happens" - moveUnderHand ifFalse: [ - delta _ aMorph morphPositionInWorld - self morphPositionInWorld ]. - self releaseMouseFocus. "Break focus" - grabbed _ aMorph. - aMorph owner ifNotNil: [ :o | - grabbed _ o aboutToGrab: aMorph ]. - grabbed ifNil: [ ^ self ]. - grabbed _ grabbed aboutToBeGrabbedBy: self. - grabbed ifNil: [ ^ self ]. - (moveUnderHand or: [ (grabbed == aMorph) not ]) - ifTrue: [ - grabbed displayBounds ifNotNil: [ :r | - delta _ (r extent // 2) negated ]]. - ^ self - grabMorph: grabbed - delta: delta! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4275-Morphic-VG-JuanVuletich-2020Jul22-12h16m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4272] on 22 July 2020 at 2:05:09 pm'! -!DisplayScreen methodsFor: 'displaying' stamp: 'jmv 7/22/2020 12:38:36' prior: 16835146! - forceDamageToScreen: allDamage - "Force all the damage rects to the screen." - - "allDamage do: [ :r | - self forceToScreen: r ]." - "Do it at once. Otherwise, some flicking with 'broken' morphs was visible." - (Rectangle merging: allDamage) ifNotNil: [ :r | - self forceToScreen: r ]! ! -!WorldState methodsFor: 'hands' stamp: 'jmv 7/22/2020 12:42:15' prior: 16945757! - selectHandsToDrawForDamage: damageList - "Select the set of hands that must be redrawn because either (a) the hand itself has changed or (b) the hand intersects some damage rectangle." - - | result | - result _ OrderedCollection new. - hands do: [:hand | - hand needsToBeDrawn ifTrue: [ - hand hasChanged - ifTrue: [result add: hand] - ifFalse: [ - hand morphFullBoundsInWorld ifNotNil: [ :handBounds | - (damageList anySatisfy: [ :r | r intersects: handBounds]) ifTrue: [ - result add: hand]]]]]. - ^ result -! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/22/2020 12:36:25' prior: 50533494! - drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rectsToRepair previousRectsToRepair reuse previousCount morphBounds | - -"quizas llamarlo #findBoundsDo: o algo asi" - self updatingMorphBoundsDo: [ - aPasteUpMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ aDamageRecorder invalidRectsFullBounds: aPasteUpMorph viewBox. - - rectsToRepair size = 0 ifTrue: [ - ^rectsToRepair]. - - rectsToRepair size > 1 ifTrue: [ "Or there is no point in attempting to merge them!!" - previousRectsToRepair _ OrderedCollection new. - - "Until no more rectangles are merged, i.e. each morph intersects at most one rectangle." - previousCount _ 0. - [rectsToRepair size = previousCount] whileFalse: [ - previousCount _ rectsToRepair size. - aPasteUpMorph submorphsReverseDo: [ :morph | | thisMorphRectangle thisMorphBounds | - morph visible ifTrue: [ - reuse _ previousRectsToRepair. - previousRectsToRepair _ rectsToRepair. - rectsToRepair _ reuse removeAll. - thisMorphRectangle _ nil. - thisMorphBounds _ morph morphFullBoundsInWorld. - previousRectsToRepair do: [ :r | - (thisMorphBounds intersects: r) - ifTrue: [ thisMorphRectangle _ r quickMerge: thisMorphRectangle ] - ifFalse: [ rectsToRepair add: r ]]. - thisMorphRectangle - ifNotNil: [rectsToRepair add: thisMorphRectangle]]]]. - ]. - - "Draw World" - rectsToRepair do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - "Draw morphs" - aPasteUpMorph submorphsReverseDo: [ :morph | - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - rectsToRepair do: [ :r | - (morphBounds intersects: r) ifTrue: [ - (self newClipRect: r) fullDraw: morph ]]]]. - - ^ rectsToRepair! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4276-Morphic-VG-JuanVuletich-2020Jul22-14h03m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4272] on 22 July 2020 at 2:57:43 pm'! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'world form clipRect transformations currentTransformation cti currentMorph drawingMorphStack engine clippingMorphDisplayBounds ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support' stamp: 'Install-4277-Morphic-VG-JuanVuletich-2020Jul22-14h05m-jmv.001.cs.st 8/5/2020 22:22:45'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'world form clipRect transformations currentTransformation cti currentMorph drawingMorphStack engine clippingMorphDisplayBounds' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! -!MorphicCanvas methodsFor: 'accessing' stamp: 'jmv 7/22/2020 14:51:50' prior: 50385857! - newClipRect: aRectangleOrNil - "aRectangle is in world coordinates. - But ivar clipRect is relative to the form, - For example, if we had previously been built like - aCanvas on: someForm over: (100@100 extent 200@100) - then our origin would be -100 @ -100. - Then, a clipRect argument like (120@120 extent: 40@30) would mean affecting - only (20@20 extent: 40@30) in our form" - - self setClipRect: (aRectangleOrNil - ifNil: [ `0@0` corner: form extent ] - ifNotNil: [ aRectangleOrNil translatedBy: self canvasOrigin ]). - clippingMorphDisplayBounds _ nil.! ! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 7/22/2020 14:47:35' prior: 50531363! - clippingByCurrentMorphDo: aBlock - | prevClipRect prevClippingMorphRect | - - prevClipRect _ self clipRect. - prevClippingMorphRect _ clippingMorphDisplayBounds. - "Might use the fact that currentMorph has just been drawn." - clippingMorphDisplayBounds _ self boundingRectOfCurrentMorphAfterDraw. - self setClipRect: (prevClipRect intersect: clippingMorphDisplayBounds). - self clippingMorph: currentMorph. - aBlock ensure: [ - self clippingMorph: nil. - self setClipRect: prevClipRect. - clippingMorphDisplayBounds _ prevClippingMorphRect ]! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/22/2020 14:51:24' prior: 50533733! - drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rectsToRepair previousRectsToRepair reuse previousCount morphBounds | - -"quizas llamarlo #findBoundsDo: o algo asi" - self updatingMorphBoundsDo: [ - aPasteUpMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ aDamageRecorder invalidRectsFullBounds: aPasteUpMorph viewBox. - - rectsToRepair size = 0 ifTrue: [ - ^rectsToRepair]. - - rectsToRepair size > 1 ifTrue: [ "Or there is no point in attempting to merge them!!" - previousRectsToRepair _ OrderedCollection new. - - "Until no more rectangles are merged, i.e. each morph intersects at most one rectangle." - previousCount _ 0. - [rectsToRepair size = previousCount] whileFalse: [ - previousCount _ rectsToRepair size. - aPasteUpMorph submorphsReverseDo: [ :morph | | thisMorphRectangle thisMorphBounds | - morph visible ifTrue: [ - reuse _ previousRectsToRepair. - previousRectsToRepair _ rectsToRepair. - rectsToRepair _ reuse removeAll. - thisMorphRectangle _ nil. - thisMorphBounds _ morph morphFullBoundsInWorld. - previousRectsToRepair do: [ :r | - (thisMorphBounds intersects: r) - ifTrue: [ thisMorphRectangle _ r quickMerge: thisMorphRectangle ] - ifFalse: [ rectsToRepair add: r ]]. - thisMorphRectangle - ifNotNil: [rectsToRepair add: thisMorphRectangle]]]]. - ]. - - "Draw World" - rectsToRepair do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - "Draw morphs" - aPasteUpMorph submorphsReverseDo: [ :morph | - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - rectsToRepair do: [ :r | - (morphBounds intersects: r) ifTrue: [ - (self newClipRect: r) fullDraw: morph ]]]]. - - ^ rectsToRepair! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/22/2020 14:56:35' prior: 50533259! - fullAddRedrawRect: aMorph to: aDamageRecorder - | addMyBounds trySubmorphs | - aMorph visible ifTrue: [ - addMyBounds _ aMorph valueOfProperty: #needsRedraw ifAbsent: [ false ]. - trySubmorphs _ aMorph valueOfProperty: #submorphNeedsRedraw ifAbsent: [ false ]. - (trySubmorphs or: [addMyBounds]) ifTrue: [ - self into: aMorph. - addMyBounds ifTrue: [ - currentMorph setProperty: #needsRedraw toValue: false. - "find bounds. - agregar mi rect" - currentMorph drawOn: self. - world notNil ifTrue: [ - aDamageRecorder recordInvalidRect: self boundingRectOfCurrentMorphAfterDraw ]. - ]. - trySubmorphs ifTrue: [ - "llamar recursivo a mis submorphs" - currentMorph setProperty: #submorphNeedsRedraw toValue: false. - currentMorph clippedSubmorph ifNotNil: [ :clipped | - self clippingByCurrentMorphDo: [ self fullAddRedrawRect: clipped to: aDamageRecorder ]]. - currentMorph unclippedSubmorphsReverseDo: [ :m | - self fullAddRedrawRect: m to: aDamageRecorder ] - ]. - self outOfMorph - ]]! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 7/22/2020 14:55:26' prior: 50531356 overrides: 50532377! - boundingRectOfCurrentMorphAfterDraw - "In targetForm coordinates" - - ^ clippingMorphDisplayBounds - ifNotNil: [ :ownerClips | self boundingRectOfCurrentMorph intersect: ownerClips ] - ifNil: [ self boundingRectOfCurrentMorph ]! ! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'world form clipRect transformations currentTransformation cti currentMorph drawingMorphStack engine clippingMorphDisplayBounds' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support' stamp: 'Install-4277-Morphic-VG-JuanVuletich-2020Jul22-14h05m-jmv.001.cs.st 8/5/2020 22:22:45'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'world form clipRect transformations currentTransformation cti currentMorph drawingMorphStack engine clippingMorphDisplayBounds' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4277-Morphic-VG-JuanVuletich-2020Jul22-14h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4272] on 22 July 2020 at 3:10:31 pm'! -!SystemWindow methodsFor: 'top window' stamp: 'jmv 7/22/2020 15:07:10' prior: 16926823! - activateAndSendTopToBack: aBoolean - "Bring me to the front and make me able to respond to mouse and keyboard" - - | oldTop | - owner - ifNil: [^self "avoid spurious activate when drop in trash"]. - oldTop _ TopWindow. - TopWindow _ self. - - oldTop ifNotNil: [ - aBoolean ifTrue: [ - | bottomWindow | - bottomWindow _ oldTop owner submorphs reverse detect: [:one | one is: #SystemWindow]. - oldTop owner addMorph: oldTop behind: bottomWindow]]. - - owner firstSubmorph == self - ifFalse: [ - "Bring me to the top if not already" - owner addMorphFront: self]. - - "Set keyboard focus" - self world ifNotNil: [ :w | - w activeHand newKeyboardFocus: self submorphToFocusKeyboard ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4278-Morphic-VG-JuanVuletich-2020Jul22-14h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4275] on 22 July 2020 at 3:53:04 pm'! -!Morph methodsFor: 'updating' stamp: 'jmv 7/22/2020 15:51:59' prior: 50533327! - redrawNeeded - "Report that the area occupied by this morph should be redrawn." - - self flag: #jmvVer2. -"BTW, no method should call #redrawNeeded twice. Just once, before any updates." - "these properties... better store flags in 'id' " - self setProperty: #needsRedraw toValue: true. - self allOwnersDo: [ :m | m setProperty: #submorphNeedsRedraw toValue: true ]. - self displayFullBounds - ifNil: [ - "Dummy, so #updateIsNeeded answers true if some morph dirty" - "Check if this is really needed. If so, find a cleaner way." - self invalidateDisplayRect: (10@10 extent: 2@2) from: nil ] - ifNotNil: [ :r | - self invalidateDisplayRect: r from: nil ]. - -"hacer esto en todos los casos? o solo si invalido r?" - self submorphsDrawingOutsideReverseDo: [ :m | m redrawNeeded ]! ! - -Morph removeSelector: #isRedrawNeeded! - -!methodRemoval: Morph #isRedrawNeeded stamp: 'Install-4279-Morphic-VG-JuanVuletich-2020Jul22-15h51m-jmv.001.cs.st 8/5/2020 22:22:45'! -isRedrawNeeded - "Report that the area occupied by this morph should be redrawn." -"Creo que es mejor transformarlo en una coleccion. Ver." - - self visible ifFalse: [ ^false ]. - ^ self valueOfProperty: #needsRedraw ifAbsent: [ false ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4279-Morphic-VG-JuanVuletich-2020Jul22-15h51m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4276] on 22 July 2020 at 8:03:20 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/22/2020 19:06:16' prior: 16875556! - worldBoundsForHalo - "Answer the rectangle to be used as the inner dimension of my halos. - Allow for showing either bounds or fullBounds, and compensate for the optional bounds rectangle." - - ^ Preferences haloEnclosesFullBounds - ifFalse: [ self displayBounds ] - ifTrue: [ self displayFullBounds ]! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/22/2020 19:56:15' prior: 50533373! - drawCurrentAndSubmorphs - - self isCurrentMorphVisible ifTrue: [ - currentMorph drawOn: self. - world notNil ifTrue: [ "Only if we are drawing the world" - currentMorph displayBounds: self boundingRectOfCurrentMorphAfterDraw ]. - "Display submorphs back to front" - "coordinate system stack already set up for aMorph - ('ivars transformations' and 'currentTransformation')" - currentMorph clippedSubmorph ifNotNil: [ :clipped | - self clippingByCurrentMorphDo: [ self fullDraw: clipped ]]. - currentMorph unclippedSubmorphsReverseDo: [ :m | - self fullDraw: m ]].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/22/2020 20:02:11' prior: 50533868! - drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rectsToRepair previousRectsToRepair reuse previousCount | - -"quizas llamarlo #findBoundsDo: o algo asi" - self updatingMorphBoundsDo: [ - aPasteUpMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ aDamageRecorder invalidRectsFullBounds: aPasteUpMorph viewBox. - - rectsToRepair size = 0 ifTrue: [ - ^rectsToRepair]. - - rectsToRepair size > 1 ifTrue: [ "Or there is no point in attempting to merge them!!" - previousRectsToRepair _ OrderedCollection new. - - "Until no more rectangles are merged, i.e. each morph intersects at most one rectangle." - previousCount _ 0. - [rectsToRepair size = previousCount] whileFalse: [ - previousCount _ rectsToRepair size. - aPasteUpMorph submorphsReverseDo: [ :morph | | thisMorphRectangle thisMorphBounds | - morph visible ifTrue: [ - reuse _ previousRectsToRepair. - previousRectsToRepair _ rectsToRepair. - rectsToRepair _ reuse removeAll. - thisMorphRectangle _ nil. - thisMorphBounds _ morph displayFullBounds ifNil: [10@10 extent: 10@10]. - previousRectsToRepair do: [ :r | - (thisMorphBounds intersects: r) - ifTrue: [ thisMorphRectangle _ r quickMerge: thisMorphRectangle ] - ifFalse: [ rectsToRepair add: r ]]. - thisMorphRectangle - ifNotNil: [rectsToRepair add: thisMorphRectangle]]]]. - ]. - - "Draw World" - rectsToRepair do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - "Draw morphs" - aPasteUpMorph submorphsReverseDo: [ :morph | | morphBounds | - morph visible ifTrue: [ - morphBounds _ morph displayFullBounds ifNil: [10@10 extent: 10@10]. - rectsToRepair do: [ :r | - (morphBounds intersects: r) ifTrue: [ - (self newClipRect: r) fullDraw: morph ]]]]. - - ^ rectsToRepair! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/22/2020 19:58:44' prior: 50533935! - fullAddRedrawRect: aMorph to: aDamageRecorder - | addMyBounds trySubmorphs currentMorphBounds | - aMorph visible ifTrue: [ - addMyBounds _ aMorph valueOfProperty: #needsRedraw ifAbsent: [ false ]. - trySubmorphs _ aMorph valueOfProperty: #submorphNeedsRedraw ifAbsent: [ false ]. - (trySubmorphs or: [addMyBounds]) ifTrue: [ - self into: aMorph. - addMyBounds ifTrue: [ - currentMorph setProperty: #needsRedraw toValue: false. - currentMorph drawOn: self. - currentMorphBounds _ self boundingRectOfCurrentMorphAfterDraw. - currentMorph displayBounds: currentMorphBounds. - aDamageRecorder recordInvalidRect: currentMorphBounds. - ]. - trySubmorphs ifTrue: [ - currentMorph setProperty: #submorphNeedsRedraw toValue: false. - currentMorph clippedSubmorph ifNotNil: [ :clipped | - self clippingByCurrentMorphDo: [ self fullAddRedrawRect: clipped to: aDamageRecorder ]]. - currentMorph unclippedSubmorphsReverseDo: [ :m | - self fullAddRedrawRect: m to: aDamageRecorder ] - ]. - self outOfMorph - ]]! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Preferences enable: #logDebuggerStackToFile. -Morph allSubInstancesDo: [ :m | m redrawNeeded ]. -self runningWorld restoreDisplay; displayWorldSafely! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4280-Morphic-VG-JuanVuletich-2020Jul22-19h47m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4276] on 22 July 2020 at 8:45:12 pm'! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 7/22/2020 20:41:16' overrides: 50532257! - displayBounds - ^self morphPosition extent: self morphExtent ! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 7/22/2020 20:12:48'! - submorphsDisplayFullBounds -"Usando los nombres viejos que estoy por hacer pelota. Repasar." - "Current full bounds of submorphs carried by the hand. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around)." - | fullBounds | - submorphs isEmpty ifTrue: [ ^nil ]. - fullBounds _ nil. - (self valueOfProperty: #lastPos) - ifNil: [ "Just once when a new morph (not in the world) is attached to the hand." - self submorphsDo: [ :m | - m displayFullBounds ifNotNil: [ :b | - fullBounds _ fullBounds ifNil: [b] ifNotNil: [ fullBounds merge: b ]]]] - ifNotNil: [ :lastPos | "When carrying morphs around." - self submorphsDo: [ :m | - m displayFullBounds ifNotNil: [ :b | - fullBounds _ fullBounds ifNil: [b] ifNotNil: [ fullBounds merge: b ]]]. - fullBounds ifNil: [ ^nil ]. "bueeeenoooo" - fullBounds _ fullBounds translatedBy: self morphPosition-lastPos ]. - ^fullBounds! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 7/22/2020 20:16:07' prior: 50531732! - savePatchFrom: aCanvas appendDamageTo: aStream - "Save the part of the given canvas under this hand as a Form and return its bounding rectangle." - - "Details: The previously used patch Form is recycled when possible to reduce the burden on storage management." - - | fullBounds | - fullBounds _ self displayFullBounds. - fullBounds ifNil: [ ^self ]. - - fullBounds _ fullBounds intersect: (`0@0` extent: aCanvas extent). - (savedPatch isNil or: [savedPatch extent ~= fullBounds extent]) - ifTrue: [ - "allocate new patch form if needed" - savedPatch _ Form extent: fullBounds extent depth: aCanvas depth ]. - aCanvas - contentsOfArea: fullBounds - into: savedPatch. - savedPatch offset: fullBounds topLeft. - prevFullBounds - ifNil: [ aStream nextPut: fullBounds ] - ifNotNil: [ aStream nextPut: (fullBounds quickMerge: prevFullBounds)]. - prevFullBounds _ fullBounds! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 7/22/2020 20:13:51' prior: 50533628 overrides: 50532285! - displayFullBounds - | fullBounds | - fullBounds _ self displayBounds. - self submorphsDisplayFullBounds ifNotNil: [ :b | - fullBounds _ b quickMerge: fullBounds ]. - ^fullBounds! ! -!WorldState methodsFor: 'hands' stamp: 'jmv 7/22/2020 20:42:49' prior: 50533713! - selectHandsToDrawForDamage: damageList - "Select the set of hands that must be redrawn because either (a) the hand itself has changed or (b) the hand intersects some damage rectangle." - - | result | - result _ OrderedCollection new. - hands do: [:hand | - hand needsToBeDrawn ifTrue: [ - hand hasChanged - ifTrue: [result add: hand] - ifFalse: [ - hand displayFullBounds ifNotNil: [ :handBounds | - (damageList anySatisfy: [ :r | r intersects: handBounds]) ifTrue: [ - result add: hand]]]]]. - ^ result! ! - -HandMorph removeSelector: #morphFullBoundsInWorld! - -!methodRemoval: HandMorph #morphFullBoundsInWorld stamp: 'Install-4281-Morphic-VG-JuanVuletich-2020Jul22-20h03m-jmv.004.cs.st 8/5/2020 22:22:46'! -morphFullBoundsInWorld -"Usando los nombres viejos que estoy por hacer pelota. Repasar. -Ahora es displayFullBounds" - | fullBounds | - fullBounds _ self morphBoundsInWorld. - self submorphsFullBoundsInWorld ifNotNil: [ :b | - fullBounds _ b quickMerge: fullBounds ]. - ^fullBounds! - -HandMorph removeSelector: #submorphsFullBoundsInWorld! - -!methodRemoval: HandMorph #submorphsFullBoundsInWorld stamp: 'Install-4281-Morphic-VG-JuanVuletich-2020Jul22-20h03m-jmv.004.cs.st 8/5/2020 22:22:46'! -submorphsFullBoundsInWorld -"Usando los nombres viejos que estoy por hacer pelota. Repasar." - "Current full bounds of submorphs carried by the hand. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around)." - | fullBounds | - submorphs isEmpty ifTrue: [ ^nil ]. - fullBounds _ nil. - (self valueOfProperty:#lastPos) - ifNil: [ "Just once when a new morph (not in the world) is attached to the hand." - self submorphsDo: [ :m | - m morphFullBoundsInWorld ifNotNil: [ :b | - fullBounds _ fullBounds ifNil: [b] ifNotNil: [ fullBounds merge: b ]]]] - ifNotNil: [ :lastPos | "When carrying morphs around." - self submorphsDo: [ :m | - m displayFullBounds ifNotNil: [ :b | - fullBounds _ fullBounds ifNil: [b] ifNotNil: [ fullBounds merge: b ]]]. - fullBounds ifNil: [ ^nil ]. "bueeeenoooo" - fullBounds _ fullBounds translatedBy: self morphPosition-lastPos ]. - ^fullBounds! - -Morph removeSelector: #morphFullBoundsInWorld! - -!methodRemoval: Morph #morphFullBoundsInWorld stamp: 'Install-4281-Morphic-VG-JuanVuletich-2020Jul22-20h03m-jmv.004.cs.st 8/5/2020 22:22:46'! -morphFullBoundsInWorld - "Morphs should know nothing about absolute coordinates..." - - self flag: #jmvVer2. - self visible ifFalse: [ ^nil ]. - ^self world ifNotNil: [ :w | w canvas displayFullBoundsInWorldOf: self ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4281-Morphic-VG-JuanVuletich-2020Jul22-20h03m-jmv.004.cs.st----! - -'From Cuis 5.0 [latest update: #4278] on 22 July 2020 at 10:57:40 pm'! - -MorphicCanvas removeSelector: #displayFullBoundsInWorldOf:! - -!methodRemoval: MorphicCanvas #displayFullBoundsInWorldOf: stamp: 'Install-4282-Morphic-VG-JuanVuletich-2020Jul22-22h57m-jmv.001.cs.st 8/5/2020 22:22:46'! -displayFullBoundsInWorldOf: aMorph - "Answer a rectangle that completely bounds aMorph and submorphs when drawn - (if the world was to be fully drawn, i.e. only to be used on a Canvas on the full world). - Might be larger than strictly required. See comment at #displayBoundsInWorldOf:" - - | r | - "Think about doing a BoundsFinderCanvas even for Morphic 2" -"borrar?" - self flag: #jmvVer2. - - r _ self displayBoundsInWorldOf: aMorph. - aMorph submorphsDrawingOutsideReverseDo: [ :m | - m visible ifTrue: [ - r _ r quickMerge: (self displayFullBoundsInWorldOf: m) ]]. - - ^r! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4282-Morphic-VG-JuanVuletich-2020Jul22-22h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4278] on 22 July 2020 at 11:05:50 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/22/2020 23:05:38' prior: 50532285! - displayFullBounds - "Answer a rectangle that completely bounds receiver and submorphs when last drawn - (if the world was to be fully drawn, i.e. only to be used on a Canvas on the full world)." - - | answer | - answer _ self displayBounds. - self submorphsDrawingOutsideReverseDo: [ :m | - m displayFullBounds ifNotNil: [ :mb | - answer _ answer ifNil: [ mb ] ifNotNil: [ answer quickMerge: mb ]]]. - ^answer! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/22/2020 20:02:11' prior: 50534122! - drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rectsToRepair previousRectsToRepair reuse previousCount | - -"quizas llamarlo #findBoundsDo: o algo asi" - self updatingMorphBoundsDo: [ - aPasteUpMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ aDamageRecorder invalidRectsFullBounds: aPasteUpMorph viewBox. - - rectsToRepair size = 0 ifTrue: [ - ^rectsToRepair]. - - rectsToRepair size > 1 ifTrue: [ "Or there is no point in attempting to merge them!!" - previousRectsToRepair _ OrderedCollection new. - - "Until no more rectangles are merged, i.e. each morph intersects at most one rectangle." - previousCount _ 0. - [rectsToRepair size = previousCount] whileFalse: [ - previousCount _ rectsToRepair size. - aPasteUpMorph submorphsReverseDo: [ :morph | | thisMorphRectangle thisMorphBounds | - morph visible ifTrue: [ - reuse _ previousRectsToRepair. - previousRectsToRepair _ rectsToRepair. - rectsToRepair _ reuse removeAll. - thisMorphRectangle _ nil. - thisMorphBounds _ morph displayFullBounds ifNil: [10@10 extent: 10@10]. - previousRectsToRepair do: [ :r | - (thisMorphBounds intersects: r) - ifTrue: [ thisMorphRectangle _ r quickMerge: thisMorphRectangle ] - ifFalse: [ rectsToRepair add: r ]]. - thisMorphRectangle - ifNotNil: [rectsToRepair add: thisMorphRectangle]]]]. - ]. - - "Draw World" - rectsToRepair do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - "Draw morphs" - aPasteUpMorph submorphsReverseDo: [ :morph | | morphBounds | - morph visible ifTrue: [ - morphBounds _ morph displayFullBounds ifNil: [10@10 extent: 10@10]. - rectsToRepair do: [ :r | - (morphBounds intersects: r) ifTrue: [ - (self newClipRect: r) fullDraw: morph ]]]]. - - ^ rectsToRepair! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4283-Morphic-VG-JuanVuletich-2020Jul22-22h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4280] on 22 July 2020 at 11:10:21 pm'! -!HandleMorph methodsFor: 'stepping and presenter' stamp: 'jmv 7/22/2020 23:08:01' prior: 16852452 overrides: 16876536! - stepAt: millisecondSinceLast - - pointBlock value: self displayBounds center! ! -!MenuItemMorph methodsFor: 'selecting' stamp: 'jmv 7/22/2020 23:08:37' prior: 50385296! - select - self isSelected: true. - owner activeSubmenu: subMenu. - subMenu ifNotNil: [ - subMenu delete. - subMenu - popUpAdjacentTo: (Array with: self displayBounds topRight + `10@0` - with: self displayBounds topLeft) - from: self. - subMenu selectItem: nil ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4284-Morphic-VG-JuanVuletich-2020Jul22-23h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4280] on 22 July 2020 at 11:17:45 pm'! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 7/22/2020 23:13:46' prior: 50341305! - maximumUsableAreaInWorld: aWorldOrNil - - | allowedArea | - allowedArea _ Display boundingBox. - aWorldOrNil ifNotNil: [ - allowedArea _ allowedArea intersect: aWorldOrNil viewBox. - aWorldOrNil taskbar ifNotNil: [ :tb | - tb displayBounds ifNotNil: [ :r | - allowedArea _ (allowedArea areasOutside: r) first ]]]. - ^allowedArea -! ! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 7/22/2020 23:13:55' prior: 50383240! - strictlyStaggeredInitialFrameFor: aStandardSystemView initialExtent: initialExtent world: aWorld - "This method implements a staggered window placement policy that I (di) like. - Basically it provides for up to 4 windows, staggered from each of the 4 corners. - The windows are staggered so that there will always be a corner visible." - - | allowedArea grid initialFrame otherFrames cornerSel corner delta putativeCorner free maxLevel | - allowedArea := (self maximumUsableAreaInWorld: aWorld) - insetBy: (self scrollBarSetback @ self screenTopSetback extent: `0 @ 0`). - "Number to be staggered at each corner (less on small screens)" - maxLevel := allowedArea area > 300000 ifTrue: [3] ifFalse: [2]. - "Amount by which to stagger (less on small screens)" - grid := allowedArea area > 500000 ifTrue: [40] ifFalse: [20]. - initialFrame := `0 @ 0` extent: initialExtent. - "min: (allowedArea extent - (grid*(maxLevel+1*2) + (grid//2)))) - min: 600@400" - otherFrames := (SystemWindow windowsIn: aWorld satisfying: [ :w | w visible and: [w isCollapsed not]]) - collect: [:w | w displayBounds]. - otherFrames _ otherFrames reject: [ :f | f isNil ]. - 0 to: maxLevel do: [ :level | - 1 to: 4 do: [:ci | - cornerSel := #(#topLeft #topRight #bottomRight #bottomLeft) at: ci. - corner := allowedArea perform: cornerSel. - "The extra grid//2 in delta helps to keep title tabs distinct" - delta := ((maxLevel - level) * grid + (grid // 2)) @ (level * grid). - 1 to: ci - 1 do: [ :i | delta _ delta y negated @ delta x ]. "slow way" - putativeCorner := corner + delta. - free := true. - otherFrames do: [ :w | - free := free & ((w perform: cornerSel) ~= putativeCorner)]. - free - ifTrue: [ - ^(initialFrame aligned: (initialFrame perform: cornerSel) - with: putativeCorner) translatedAndSquishedToBeWithin: allowedArea]]]. - "If all else fails..." - ^(self scrollBarSetback @ self screenTopSetback - extent: initialFrame extent) translatedAndSquishedToBeWithin: allowedArea! ! -!Morph methodsFor: 'macpal' stamp: 'jmv 7/22/2020 23:12:08' prior: 16876092 overrides: 16881798! - flash - - self displayBounds ifNotNil: [ :r | - Display flash: r ]! ! -!Morph methodsFor: 'macpal' stamp: 'jmv 7/22/2020 23:12:24' prior: 50336168! - flashWith: aColor - - self displayBounds ifNotNil: [ :r | Display flash: r with: aColor ]! ! -!Morph methodsFor: 'meta-actions' stamp: 'jmv 7/22/2020 23:13:02' prior: 50460225! - potentialEmbeddingTargets - "Return the potential targets for embedding the receiver" - | myRect myWorld | - owner ifNil:[^#()]. - myWorld := owner world ifNil:[^#()]. - myRect := self displayBounds. - ^myWorld submorphs select: [ :m | - m isReallyVisible - and: [ m isLocked not - and: [(m displayBounds intersects: myRect) - and: [(m ~= self) - and: [(m isKindOf: HaloMorph) not]]]] - ]! ! -!SystemWindow methodsFor: 'menu' stamp: 'jmv 7/22/2020 23:15:08' prior: 16926478! - fullScreen - "Zoom Window to Full World size with possible DeskMargins" - - "SystemWindow fullScreen" - - | left right possibleBounds | - (self hasProperty: #originalBounds) - ifFalse: [ "Expand" - self setProperty: #originalBounds toValue: self displayBounds. - left := right := 0. - possibleBounds := (RealEstateAgent maximumUsableAreaInWorld: self world) - insetBy: (left @ 0 corner: right @ 0). - possibleBounds := possibleBounds insetBy: Theme current fullScreenDeskMargin - ] - ifTrue: [ "Contract" - possibleBounds := self valueOfProperty: #originalBounds. - self removeProperty: #originalBounds. - ]. - self morphPosition: possibleBounds topLeft extent: possibleBounds extent! ! -!SystemWindow methodsFor: 'resize/collapse' stamp: 'jmv 7/22/2020 23:15:18' prior: 16926614! - resize: boundingBox - (self hasProperty: #originalBounds) ifFalse: [ - self setProperty: #originalBounds toValue: self displayBounds]. - self morphPosition: boundingBox origin extent: boundingBox extent! ! -!TranscriptMorph methodsFor: 'drawing' stamp: 'jmv 7/22/2020 23:17:11' prior: 50503700 overrides: 16899205! - drawOn: aCanvas - Transcript - showOnDisplay: true; - displayOn: form in: self morphLocalBounds. - aCanvas image: form at: self morphTopLeft. - Transcript - bounds: self displayBounds; - showOnDisplay: doImmediateUpdates. - self updateWorkspace! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4285-Morphic-VG-JuanVuletich-2020Jul22-23h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4282] on 23 July 2020 at 10:29:47 am'! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'jmv 7/23/2020 10:19:48' overrides: 16875373! - morphBoundsInWorld: newBounds - | oldExtent newExtent | - - "remove senders and implementors" - self flag: #jmvVer2. - - oldExtent _ self morphExtentInWorld. - newExtent _ newBounds extent. - "Moving stuff around is most likely the most common operation. - Optimize it" - oldExtent = newExtent ifTrue: [ - ^self morphPositionInWorld: newBounds topLeft ]. - (oldExtent dotProduct: oldExtent) <= (newExtent dotProduct: newExtent) ifTrue:[ - "We're growing. First move then resize." - self morphPositionInWorld: newBounds topLeft; morphExtent: newExtent. - ] ifFalse: [ - "We're shrinking. First resize then move." - self morphExtent: newExtent; morphPositionInWorld: newBounds topLeft. - ].! ! -!Transcripter methodsFor: 'command line' stamp: 'jmv 7/23/2020 10:04:22' prior: 16938877! - readEvalPrint - | line | - [ #('quit' 'exit' 'done' ) includes: (line _ self request: '>') ] whileFalse: [ - line caseOf: { - [ 'revert' ] -> []. - } - otherwise: [ - self - newLine; - show: - ([ Compiler evaluate: line ] ifError: [ :err :ex | err ]) ]]! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 7/23/2020 10:29:28' prior: 50533663! - grabMorph: aMorph moveUnderHand: moveUnderHand - "Grab the given morph (i.e., add it to this hand and remove it from its current owner). - If moveUnderHand is requested or it seems neccesary anyway, move the grabbed morph under the hand." - - | grabbed delta | - "#aboutToGrab: and #aboutToBeGrabbedBy: might mess wildly with our morphs. - If we need it, prepare delta before that happens" - moveUnderHand ifFalse: [ - delta _ aMorph morphPositionInWorld - self morphPositionInWorld ]. - self releaseMouseFocus. "Break focus" - grabbed _ aMorph. - aMorph owner ifNotNil: [ :o | - grabbed _ o aboutToGrab: aMorph ]. - grabbed ifNil: [ ^ self ]. - grabbed _ grabbed aboutToBeGrabbedBy: self. - grabbed ifNil: [ ^ self ]. - (moveUnderHand or: [ (grabbed == aMorph) not ]) - ifTrue: [ - delta _ (grabbed morphExtent // 2) negated ]. - ^ self - grabMorph: grabbed - delta: delta! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/23/2020 10:20:27' prior: 50530896! - basicBox - | aBox minSide anExtent w hs | - hs _ self class handleSize. - minSide _ 4 * hs. - anExtent _ extent + (hs*2) max: minSide@minSide. - aBox _ Rectangle center: target displayBounds center extent: anExtent. - w _ self world ifNil: [ target world ]. - ^ w - ifNil: - [ aBox ] - ifNotNil: - [ aBox intersect: (w viewBox insetBy: hs@hs) ]! ! - -HaloMorph removeSelector: #redrawNeeded! - -!methodRemoval: HaloMorph #redrawNeeded stamp: 'Install-4286-Morphic-VG-JuanVuletich-2020Jul23-10h02m-jmv.001.cs.st 8/5/2020 22:22:46'! -redrawNeeded - "Report that the area occupied by this morph should be redrawn." -"No debería alcanzar?" -true not ifTrue: [ ^super redrawNeeded ]. - self - invalidateDisplayRect: - ((self morphBoundsInWorld - outsetBy: self class handleSize*2) - extendBy: 0@(FontFamily defaultLineSpacing+self class handleSize)) - from: nil. - "Label could be wider than us..." - self submorphsDrawingOutsideReverseDo: [ :m | m redrawNeeded ]! - -Morph removeSelector: #morphBoundsInWorld:! - -!methodRemoval: Morph #morphBoundsInWorld: stamp: 'Install-4286-Morphic-VG-JuanVuletich-2020Jul23-10h02m-jmv.001.cs.st 8/5/2020 22:22:46'! -morphBoundsInWorld: newBounds - | oldExtent newExtent | - - "remove senders and implementors" - self flag: #jmvVer2. - - oldExtent _ self morphExtentInWorld. - newExtent _ newBounds extent. - "Moving stuff around is most likely the most common operation. - Optimize it" - oldExtent = newExtent ifTrue: [ - ^self morphPositionInWorld: newBounds topLeft ]. - (oldExtent dotProduct: oldExtent) <= (newExtent dotProduct: newExtent) ifTrue:[ - "We're growing. First move then resize." - self morphPositionInWorld: newBounds topLeft; morphExtent: newExtent. - ] ifFalse: [ - "We're shrinking. First resize then move." - self morphExtent: newExtent; morphPositionInWorld: newBounds topLeft. - ].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4286-Morphic-VG-JuanVuletich-2020Jul23-10h02m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4283] on 23 July 2020 at 11:32:30 am'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/23/2020 11:17:01'! - updateDisplayBounds: aMorph - "Update displayBounds for if never set. - Useful for new morph, that are created and attached to the hand." - - aMorph visible ifTrue: [ - aMorph displayBounds ifNil: [ - self into: aMorph. - currentMorph drawOn: self. - currentMorph displayBounds: self boundingRectOfCurrentMorphAfterDraw. - currentMorph clippedSubmorph ifNotNil: [ :clipped | - self clippingByCurrentMorphDo: [ self updateDisplayBounds: clipped ]]. - currentMorph unclippedSubmorphsReverseDo: [ :m | - self updateDisplayBounds: m ]. - self outOfMorph - ]]! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/23/2020 11:26:42'! - updateHandsDisplayBounds: aPasteUpMorph - "Update displayBounds for carried morphs if never set. - Useful for new morph, that are created and attached to the hand." - - aPasteUpMorph handsDo: [ :hand | - self into: hand. - hand submorphsDo: [ :morph | - self updateDisplayBounds: morph ]. - self outOfMorph ]! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/20/2020 17:10:46' prior: 50534447! - displayFullBounds - "Answer a rectangle that completely bounds receiver and submorphs when last drawn - (if the world was to be fully drawn, i.e. only to be used on a Canvas on the full world)." - - | answer | - answer _ self displayBounds. - answer isNil ifTrue: [ ^nil ]. - self submorphsDrawingOutsideReverseDo: [ :m | - answer _ answer quickMerge: m displayFullBounds ]. - ^answer! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 7/23/2020 11:32:11' prior: 50534252! - submorphsDisplayFullBounds - "Current full bounds of submorphs carried by the hand. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around)." - | fullBounds | - submorphs isEmpty ifTrue: [ ^nil ]. - fullBounds _ nil. - (self valueOfProperty: #lastPos) - ifNil: [ "Just once when a new morph (not in the world) is attached to the hand." - self submorphsDo: [ :m | - m displayFullBounds ifNotNil: [ :b | - fullBounds _ fullBounds ifNil: [b] ifNotNil: [ fullBounds merge: b ]]]] - ifNotNil: [ :lastPos | "When carrying morphs around." - self submorphsDo: [ :m | - m displayFullBounds ifNotNil: [ :b | - fullBounds _ fullBounds ifNil: [b] ifNotNil: [ fullBounds merge: b ]]]. - fullBounds _ fullBounds translatedBy: self morphPosition-lastPos ]. - ^fullBounds! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/23/2020 11:26:59' prior: 50534463! -drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rectsToRepair previousRectsToRepair reuse previousCount | - -"quizas llamarlo #findBoundsDo: o algo asi" - self updatingMorphBoundsDo: [ - aPasteUpMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - self updateHandsDisplayBounds: aPasteUpMorph. - ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ aDamageRecorder invalidRectsFullBounds: aPasteUpMorph viewBox. - - rectsToRepair size = 0 ifTrue: [ - ^rectsToRepair]. - - rectsToRepair size > 1 ifTrue: [ "Or there is no point in attempting to merge them!!" - previousRectsToRepair _ OrderedCollection new. - - "Until no more rectangles are merged, i.e. each morph intersects at most one rectangle." - previousCount _ 0. - [rectsToRepair size = previousCount] whileFalse: [ - previousCount _ rectsToRepair size. - aPasteUpMorph submorphsReverseDo: [ :morph | | thisMorphRectangle thisMorphBounds | - morph visible ifTrue: [ - reuse _ previousRectsToRepair. - previousRectsToRepair _ rectsToRepair. - rectsToRepair _ reuse removeAll. - thisMorphRectangle _ nil. - thisMorphBounds _ morph displayFullBounds ifNil: [10@10 extent: 10@10]. - previousRectsToRepair do: [ :r | - (thisMorphBounds intersects: r) - ifTrue: [ thisMorphRectangle _ r quickMerge: thisMorphRectangle ] - ifFalse: [ rectsToRepair add: r ]]. - thisMorphRectangle - ifNotNil: [rectsToRepair add: thisMorphRectangle]]]]. - ]. - - "Draw World" - rectsToRepair do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - "Draw morphs" - aPasteUpMorph submorphsReverseDo: [ :morph | | morphBounds | - morph visible ifTrue: [ - morphBounds _ morph displayFullBounds ifNil: [10@10 extent: 10@10]. - rectsToRepair do: [ :r | - (morphBounds intersects: r) ifTrue: [ - (self newClipRect: r) fullDraw: morph ]]]]. - - ^ rectsToRepair! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4287-Morphic-VG-JuanVuletich-2020Jul23-11h31m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4284] on 23 July 2020 at 11:43:33 am'! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 7/23/2020 11:43:17' prior: 50534316 overrides: 50534892! - displayFullBounds - "Current full bounds of hand and carried submorphs. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around)." - | fullBounds | - fullBounds _ self displayBounds. - self submorphsDo: [ :m | - fullBounds _ fullBounds quickMerge: m displayFullBounds]. - (self valueOfProperty: #lastPos) - ifNotNil: [ :lastPos | "When already carrying morphs around." - fullBounds _ fullBounds translatedBy: self morphPosition-lastPos. - fullBounds _ fullBounds quickMerge: self displayBounds ]. - ^fullBounds! ! - -HandMorph removeSelector: #submorphsDisplayFullBounds! - -!methodRemoval: HandMorph #submorphsDisplayFullBounds stamp: 'Install-4288-Morphic-VG-JuanVuletich-2020Jul23-11h39m-jmv.001.cs.st 8/5/2020 22:22:46'! -submorphsDisplayFullBounds - "Current full bounds of submorphs carried by the hand. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around)." - | fullBounds | - submorphs isEmpty ifTrue: [ ^nil ]. - fullBounds _ nil. - (self valueOfProperty: #lastPos) - ifNil: [ "Just once when a new morph (not in the world) is attached to the hand." - self submorphsDo: [ :m | - m displayFullBounds ifNotNil: [ :b | - fullBounds _ fullBounds ifNil: [b] ifNotNil: [ fullBounds merge: b ]]]] - ifNotNil: [ :lastPos | "When carrying morphs around." - self submorphsDo: [ :m | - m displayFullBounds ifNotNil: [ :b | - fullBounds _ fullBounds ifNil: [b] ifNotNil: [ fullBounds merge: b ]]]. - fullBounds _ fullBounds translatedBy: self morphPosition-lastPos ]. - ^fullBounds! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4288-Morphic-VG-JuanVuletich-2020Jul23-11h39m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4284] on 23 July 2020 at 11:58:52 am'! -!Morph methodsFor: 'change reporting' stamp: 'jmv 7/23/2020 11:56:45' prior: 16874147! - invalidateDisplayRect: damageRect from: aMorph - - | clippedRect b | - - "warning. Senders are using global coordinates. Redesign!!" - "local now!!!!!!!!!!" - self flag: #jmvVer2. "ok?" - - self visible ifFalse: [ ^self]. - - clippedRect _ damageRect. - aMorph ifNotNil: [ - aMorph == self clippedSubmorph - ifTrue: [ - b _ self displayBounds. - b ifNil: [ ^self ]. - clippedRect _ damageRect intersect: b ]]. - owner ifNotNil: [ - owner invalidateDisplayRect: clippedRect from: self ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4289-Morphic-VG-JuanVuletich-2020Jul23-11h43m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4286] on 23 July 2020 at 3:34:20 pm'! -!PasteUpMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 7/23/2020 14:47:46' prior: 16887726! - addMorph: aMorph centeredNear: aPoint - "Add the given morph to this world, attempting to keep its center as close to the given point possible while also keeping the it entirely within the bounds of this world." - - | trialRect delta | - trialRect _ Rectangle center: aPoint extent: aMorph morphExtent. - delta _ trialRect amountToTranslateWithin: self displayBounds. - self addMorph: aMorph. - aMorph morphPositionInWorld: trialRect origin + delta.! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 7/23/2020 15:25:53' prior: 50530799! - popUpAdjacentTo: rightOrLeftPointInWorld from: sourceItem - "Present this menu at the given point under control of the given hand. - Used mostly for submenus." - - | trialRect e | - popUpOwner _ sourceItem. - sourceItem world addMorphFront: self position: rightOrLeftPointInWorld first. - e _ self morphExtent. - trialRect _ rightOrLeftPointInWorld first extent: e. - trialRect right > sourceItem world morphWidth ifTrue: [ - self morphPosition: rightOrLeftPointInWorld second - (e x@0)]. - self fitInWorld.! ! -!MenuMorph methodsFor: 'private' stamp: 'jmv 7/23/2020 15:01:17' prior: 50385011! - fitInWorld - - | delta trialRect | - trialRect _ Rectangle origin: self morphPosition extent: self morphExtent. - delta _ trialRect amountToTranslateWithin: owner displayBounds. - self morphPosition: trialRect origin + delta.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4290-Morphic-VG-JuanVuletich-2020Jul23-15h33m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4286] on 23 July 2020 at 3:43:50 pm'! -!TextDoIt class methodsFor: 'as yet unclassified' stamp: 'jmv 7/23/2020 15:42:42' prior: 16931228! - evalString: str - " - ('Some text. ', - (Text string: '' attribute: (TextDoIt evalString: '123456 print')), - ' more regular text') edit - " - ^ self new evalString: str! ! -!TranscriptMorph methodsFor: 'drawing' stamp: 'jmv 7/23/2020 15:42:02' prior: 50534706 overrides: 16899205! -drawOn: aCanvas - Transcript - showOnDisplay: true; - displayOn: form in: self morphLocalBounds. - aCanvas image: form at: self morphTopLeft. - self displayBounds ifNotNil: [ :r | - Transcript bounds:r ]. - Transcript - showOnDisplay: doImmediateUpdates. - self updateWorkspace! ! -!TextComposition methodsFor: 'editing' stamp: 'jmv 7/23/2020 15:43:30' prior: 16930965! - clickAt: clickPoint - "Give sensitive text a chance to fire. Display flash: (100@100 extent: 100@100)." - | startBlock action target range boxes box t | - action _ false. - startBlock _ self characterBlockAtPoint: clickPoint. - t _ model actualContents. - (t attributesAt: startBlock stringIndex) do: [ :att | - att mayActOnClick ifTrue: [ - (target _ model) ifNil: [ target _ editor morph]. - range _ t rangeOf: att startingAt: startBlock stringIndex. - boxes _ self selectionRectsFrom: (self characterBlockForIndex: range first) - to: (self characterBlockForIndex: range last+1). - box _ boxes detect: [ :each | each containsPoint: clickPoint] ifNone: nil. - box ifNotNil: [ - box _ editor morph displayBounds. - editor morph allOwnersDo: [ :m | box _ box intersect: (m displayBounds) ]. - Utilities - awaitMouseUpIn: box - repeating: nil - ifSucceed: [(att actOnClickFor: target in: self at: clickPoint editor: editor) ifTrue: [action _ true]]. - ]]]. - ^ action! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4291-Morphic-VG-JuanVuletich-2020Jul23-15h34m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4288] on 23 July 2020 at 3:48:31 pm'! -!LayoutAdjustingMorph methodsFor: 'stepping' stamp: 'jmv 7/23/2020 15:48:18' prior: 50500441 overrides: 16876536! - stepAt: millisecondSinceLast - "got the #mouseLeave: message" - | p | - hand ifNil: [ - Cursor currentCursor == self cursor ifTrue: [ Cursor defaultCursor activateCursor ]. - ^ self stopStepping ]. - "hasn't got the #mouseLeave: message (yet)" - p _ hand morphPosition. - hand lastMouseEvent mouseButton1Pressed - ifTrue: [ - self adjustOwnerAt: p. - (Preferences cheapWindowReframe or: [ millisecondSinceLast > 200]) ifTrue: [ - owner displayBounds newRectFrom: [ :f | - self adjustOwnerAt: Sensor mousePoint. - owner morphPosition extent: owner morphExtent ]]] - ifFalse: [ - self stopStepping. - "If the button was unpressed outside the morph (can happen if you try to go outside container), - we might not get the #mouseLeave: message" - (self morphContainsPoint: (self internalizeFromWorld: p)) ifFalse: [ - hand _ nil. - Cursor defaultCursor activateCursor ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4292-Morphic-VG-JuanVuletich-2020Jul23-15h46m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4288] on 23 July 2020 at 4:05:24 pm'! -!Morph methodsFor: 'drawing' stamp: 'jmv 7/23/2020 16:02:54' prior: 50432320! -visible: aBoolean - "set the 'visible' attribute of the receiver to aBoolean" - - self visible == aBoolean - ifTrue: [ ^ self ]. - self setProperty: #visible toValue: aBoolean. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/23/2020 15:59:54' prior: 50469768! - morphPosition: aPoint - "Change the position of this morph. Argument is in owner's coordinates." - (location isTranslation: aPoint) ifTrue: [ "Null change" - ^ self ]. - location _ location withTranslation: aPoint. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/23/2020 15:58:19' prior: 16875467! - morphPositionInWorld: newPositionInWorld - "Change the position of this morph." - "El tema es, que tipo de coordenadas tenemos? - En un mundo relativista, no hay un marco de referencia absoluto. - No tiene sentido hablar de coordenadas del mundo... El mundo podria estar escalado... - Que tienen de especial las coordenadas del mundo? - Coordenadas 'del hardware'? No deberia saber mucho sobre el... Puede haber multiples displays, hands de diverso tipo, remotas, virtuales... - - En ppio, un par de coordenadas pueden ser relativas a cualquier morph. Pareciera que necesito metodos de conversion de cualquier morph hacia mi, y de mi hacia cualquier morph... Como encontrar un marco de referencia comun???? - Dejar esto para despues. En realidad, para empezar, preciso menos: Solo preciso saber si las coordenadas estan en el morph o en su owner. Nada mas. Los eventos se iran transformando apropiadamente al moverse por el arbol, o al menos, llevaran consigo una transformacion (AffineTransformation) que se ira actualizando" - - | newPositionInOwner | - self flag: #jmvVer2. - "This method MUST die" - - newPositionInOwner _ owner - ifNotNil: [ owner internalizeFromWorld: newPositionInWorld ] - ifNil: [ newPositionInWorld ]. - - (location isTranslation: newPositionInOwner) ifTrue: [ - ^ self ]. "Null change". - - location _ location withTranslation: newPositionInOwner. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/23/2020 16:01:24' prior: 16875527! - rotateBy: radians - "Change the scale of this morph. Argument is an angle." - location _ location rotatedBy: radians. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/23/2020 16:01:33' prior: 16875536! - rotation: radians scale: scale - "Change the scale of this morph. Arguments are an angle and a scale." - location _ location withRotation: radians scale: scale. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/23/2020 16:01:42' prior: 16875547! - scaleBy: scaleFactor - "Change the scale of this morph. Argument is a factor." - location _ location scaledBy: scaleFactor. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'jmv 7/23/2020 16:00:57' prior: 16876922! - removeAllMorphs - | oldMorphs | - submorphs isEmpty ifTrue: [ ^self ]. - submorphs do: [ :m | - m privateOwner: nil ]. - oldMorphs _ submorphs. - submorphs _ #(). - oldMorphs do: [ :m | - self removedMorph: m ]. - self someSubmorphPositionOrExtentChanged. - self redrawNeeded.! ! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'jmv 7/23/2020 16:01:05' prior: 16876933! - removeAllMorphsIn: aCollection - "greatly speeds up the removal of *lots* of submorphs" - | set | - aCollection isEmpty ifTrue: [ ^self ]. - set _ IdentitySet new: aCollection size * 4 // 3. - aCollection do: [ :each | each owner == self ifTrue: [ set add: each ]]. - set isEmpty ifTrue: [ ^self ]. - set do: [ :m | m privateOwner: nil ]. - submorphs _ submorphs reject: [ :each | set includes: each]. - set do: [ :m | self removedMorph: m ]. - self someSubmorphPositionOrExtentChanged. - self redrawNeeded.! ! -!Morph methodsFor: 'updating' stamp: 'jmv 7/23/2020 16:00:42' prior: 50534041! - redrawNeeded - "Report that the area occupied by this morph should be redrawn." - - self flag: #jmvVer2. - "these properties... better store flags in 'id' " - self setProperty: #needsRedraw toValue: true. - self allOwnersDo: [ :m | m setProperty: #submorphNeedsRedraw toValue: true ]. - self displayFullBounds - ifNil: [ - "Dummy, so #updateIsNeeded answers true if some morph dirty" - "Check if this is really needed. If so, find a cleaner way." - self invalidateDisplayRect: (10@10 extent: 2@2) from: nil ] - ifNotNil: [ :r | - self invalidateDisplayRect: r from: nil ]. - - self submorphsDrawingOutsideReverseDo: [ :m | m redrawNeeded ]! ! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'jmv 7/23/2020 15:52:14' prior: 16899221 overrides: 16875404! - morphExtent: newExtent - "assume it is always in our coordinates!!" - - extent = newExtent ifFalse: [ - (self privateExtent: newExtent) ifTrue: [ - self someSubmorphPositionOrExtentChanged. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]]! ! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'jmv 7/23/2020 15:53:07' prior: 50367553! - morphPosition: newPos extent: newExtent - "Change the position of this morph. Argument is in owner's coordinates." - - | someChange | - someChange _ false. - (location isTranslation: newPos) ifFalse: [ - location _ location withTranslation: newPos. - someChange _ true ]. - - extent = newExtent ifFalse: [ - (self privateExtent: newExtent) ifTrue: [ - someChange _ true ]]. - - someChange ifTrue: [ - self someSubmorphPositionOrExtentChanged. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]! ! -!ImageMorph methodsFor: 'accessing' stamp: 'jmv 7/23/2020 15:59:02' prior: 16854113! - image: anImage - | newExtent | - image _ anImage depth = 1 - ifTrue: [ ColorForm mappingWhiteToTransparentFrom: anImage ] - ifFalse: [ anImage ]. - newExtent _ image extent. - extent = newExtent ifFalse: [ - extent _ newExtent. - self someSubmorphPositionOrExtentChanged. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]]. - self redrawNeeded.! ! -!InnerTextMorph methodsFor: 'accessing' stamp: 'jmv 7/23/2020 15:57:32' prior: 16855509! - model: aTextModel wrappedTo: width - "Accept new text contents. Lay it out, wrapping to width. - Then fit my height to the result." - | newExtent | - wrapFlag _ true. - newExtent _ width truncated@extent y. - extent = newExtent ifFalse: [ - extent _ newExtent. - self someSubmorphPositionOrExtentChanged. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]. - self model: aTextModel! ! -!InnerTextMorph methodsFor: 'private' stamp: 'jmv 7/23/2020 15:57:00' prior: 50523085! - fit - "Adjust my bounds to fit the text. - Required after the text changes, - or if wrapFlag is true and the user attempts to change the extent." - - | newExtent newHeight newWidth | - newWidth _ extent x. - "Adjust width only if we don't wrap text to own width!!" - wrapFlag ifFalse: [ - newWidth _ self textComposition usedWidth max: 9 ]. - newHeight _ self textComposition usedHeight max: FontFamily defaultLineSpacing + 2. - newExtent _ newWidth @ newHeight. - extent = newExtent - ifTrue: [ - self redrawNeeded. - "Too conservative: only text composition (because of changes in text or styles, etc) - should cause invalidation. - Try to avoid calling #fit unless needed." - ] - ifFalse: [ - extent = newExtent ifFalse: [ - extent _ newExtent. - self someSubmorphPositionOrExtentChanged. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]]. - - owner innerHeight: newExtent y! ! - -MorphicCanvas removeSelector: #displayBoundsInWorldOf:! - -!methodRemoval: MorphicCanvas #displayBoundsInWorldOf: stamp: 'Install-4293-Morphic-VG-JuanVuletich-2020Jul23-15h48m-jmv.001.cs.st 8/5/2020 22:22:46'! -displayBoundsInWorldOf: aMorph - "Answer a rectangle that completely bounds aMorph when drawn on our form. - Might be larger than strictly required. - - In Morphic 2, this could cause clipping artifacts. This doesn't usually happen because: - a) Morphic 2 doesn't use scaling and rotation - b) Most Morphic 2 morphs have rectangular shape. - - In Morphic 3, clipping also considers the real shape of the owner morph. This avoids those artifacts." -"borrar?" - "Think about doing a BoundsFinderCanvas even for Morphic 2" - self flag: #jmvVer2. - - ^self externalizeDisplayBounds: aMorph morphLocalBounds from: aMorph! - -Morph removeSelector: #morphBoundsInWorld! - -!methodRemoval: Morph #morphBoundsInWorld stamp: 'Install-4293-Morphic-VG-JuanVuletich-2020Jul23-15h48m-jmv.001.cs.st 8/5/2020 22:22:46'! -morphBoundsInWorld - "Morphs should know nothing about absolute coordinates..." - - self flag: #jmvVer2. - self visible ifFalse: [ ^nil ]. - ^self world ifNotNil: [ :w | w canvas ifNotNil: [ :c | c displayBoundsInWorldOf: self ]]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4293-Morphic-VG-JuanVuletich-2020Jul23-15h48m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4288] on 23 July 2020 at 4:08:26 pm'! -!Morph methodsFor: 'change reporting' stamp: 'jmv 7/23/2020 16:08:22' prior: 16874165! - invalidateLocalRect: localRectangle - - self invalidateDisplayRect: (self externalizeDisplayBounds: localRectangle) from: nil! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4294-Morphic-VG-JuanVuletich-2020Jul23-16h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4288] on 24 July 2020 at 10:43:56 am'! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/24/2020 10:21:33'! - displayBoundsForHalo - "Answer the rectangle to be used as the inner dimension of my halos. - Allow for showing either bounds or fullBounds, and compensate for the optional bounds rectangle." - - ^ Preferences haloEnclosesFullBounds - ifFalse: [ self displayBounds ] - ifTrue: [ self displayFullBounds ]! ! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'jmv 7/24/2020 10:22:57' overrides: 16875357! - morphBounds: aRectangle - self morphPosition: aRectangle topLeft. - self morphExtent: aRectangle extent! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 7/24/2020 10:23:24' prior: 16875638! - addHalo: evt - | halo | - halo _ HaloMorph new. - halo popUpFor: self event: evt. - halo morphBounds: self displayBoundsForHalo. - ^halo! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/24/2020 10:43:34' prior: 50385539! - addHandle: handleSpec - "Add a handle within the halo box as per the haloSpec, and set it up to respond to the given event by sending the given selector to the given recipient. Return the handle." - - | handle aPoint colorToUse form icon e | - aPoint _ self - positionIn: haloBox - horizontalPlacement: handleSpec horizontalPlacement - verticalPlacement: handleSpec verticalPlacement. - colorToUse _ Color colorFrom: handleSpec color. - handle _ HaloHandleMorph new color: colorToUse. - self addMorph: handle. - e _ self class handleSize asPoint. - handle morphPosition: aPoint-(e//2) extent: e. - handleSpec iconSymbol ifNotNil: [ :iconName | - form _ self class icons at: iconName ifAbsent: [self class perform: iconName]. - form ifNotNil: [ - icon _ ImageMorph new - image: form; - color: colorToUse makeForegroundColor; - lock. - handle addMorphFront: icon position: `0@0` ]]. - handle mouseUpSelector: #endInteraction. - handle setBalloonText: handleSpec hoverHelp. - ^ handle! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/24/2020 10:23:20' prior: 16850908! - addHandles - - self removeAllMorphs. "remove old handles, if any" - self morphBounds: target displayBoundsForHalo. "update my size" - haloBox _ self basicBox. - target addHandlesTo: self box: haloBox. - self addNameString: (target printStringLimitedTo: 40). - growingOrRotating _ false. - self redrawNeeded! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/24/2020 10:42:30' prior: 50521073! - addNameString: aString - "Add a name display centered beneath the bottom of the outer rectangle. Return the handle." - - | nameMorph verticalNamePosition namePosition nameBackground | - nameBackground _ RectangleLikeMorph new - color: ((target is: #SystemWindow) - ifTrue: [target windowColor] - ifFalse: [`Color lightBlue alpha: 0.9`]). - nameMorph _ StringMorph contents: aString. - nameMorph color: `Color black`. - nameBackground morphExtent: nameMorph morphExtent + 4. - verticalNamePosition _ haloBox bottom + self class handleSize. - namePosition _ haloBox width - nameMorph morphWidth // 2 + haloBox left @ verticalNamePosition. - self addMorph: nameBackground. - nameBackground morphPosition: namePosition - 2. - self addMorph: nameMorph. - nameMorph morphPosition: namePosition. - ^nameMorph! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/24/2020 10:42:12' prior: 50534791! - basicBox - "basicBox is in local coordinates" - | aBox minSide anExtent w hs targetBounds | - hs _ self class handleSize. - minSide _ 4 * hs. - anExtent _ extent + (hs*2) max: minSide@minSide. - targetBounds _ target displayBounds. - aBox _ Rectangle center: targetBounds center extent: anExtent. - w _ self world ifNil: [ target world ]. - aBox _ w - ifNil: - [ aBox ] - ifNotNil: - [ aBox intersect: (w viewBox insetBy: (hs@hs corner: hs@(hs*3))) ]. - ^aBox translatedBy: self morphPosition negated! ! - -RectangleLikeMorph removeSelector: #morphBoundsInWorld:! - -!methodRemoval: RectangleLikeMorph #morphBoundsInWorld: stamp: 'Install-4295-Morphic-VG-JuanVuletich-2020Jul23-16h08m-jmv.001.cs.st 8/5/2020 22:22:46'! -morphBoundsInWorld: newBounds - | oldExtent newExtent | - - "remove senders and implementors" - self flag: #jmvVer2. - - oldExtent _ self morphExtentInWorld. - newExtent _ newBounds extent. - "Moving stuff around is most likely the most common operation. - Optimize it" - oldExtent = newExtent ifTrue: [ - ^self morphPositionInWorld: newBounds topLeft ]. - (oldExtent dotProduct: oldExtent) <= (newExtent dotProduct: newExtent) ifTrue:[ - "We're growing. First move then resize." - self morphPositionInWorld: newBounds topLeft; morphExtent: newExtent. - ] ifFalse: [ - "We're shrinking. First resize then move." - self morphExtent: newExtent; morphPositionInWorld: newBounds topLeft. - ].! - -Morph removeSelector: #worldBoundsForHalo! - -!methodRemoval: Morph #worldBoundsForHalo stamp: 'Install-4295-Morphic-VG-JuanVuletich-2020Jul23-16h08m-jmv.001.cs.st 8/5/2020 22:22:46'! -worldBoundsForHalo - "Answer the rectangle to be used as the inner dimension of my halos. - Allow for showing either bounds or fullBounds, and compensate for the optional bounds rectangle." - - ^ Preferences haloEnclosesFullBounds - ifFalse: [ self displayBounds ] - ifTrue: [ self displayFullBounds ]! - -Morph removeSelector: #morphBounds:! - -!methodRemoval: Morph #morphBounds: stamp: 'Install-4295-Morphic-VG-JuanVuletich-2020Jul23-16h08m-jmv.001.cs.st 8/5/2020 22:22:46'! -morphBounds: aRectangle - self morphPosition: aRectangle topLeft. - self morphExtent: aRectangle extent! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4295-Morphic-VG-JuanVuletich-2020Jul23-16h08m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4292] on 24 July 2020 at 10:57:32 am'! -!MorphicCanvas methodsFor: 'testing' stamp: 'jmv 7/24/2020 10:56:35' prior: 50463630! - isCurrentMorphVisible - "Note: answer true if we are not sure." - | aRectangle myClipRect | - currentMorph visible ifFalse: [ ^false ]. - aRectangle := self boundingRectOfCurrentMorphAfterDraw. - aRectangle ifNil: [ ^true ]. - myClipRect := self clipRect. - aRectangle right < myClipRect left ifTrue: [^ false]. - aRectangle left > myClipRect right ifTrue: [^ false]. - aRectangle bottom < myClipRect top ifTrue: [^ false]. - aRectangle top > myClipRect bottom ifTrue: [^ false]. - ^ true -! ! - -BitBltCanvas removeSelector: #isCurrentMorphVisible! - -!methodRemoval: BitBltCanvas #isCurrentMorphVisible stamp: 'Install-4296-Morphic-VG-JuanVuletich-2020Jul24-10h53m-jmv.001.cs.st 8/5/2020 22:22:46'! -isCurrentMorphVisible - | aRectangle myClipRect | - currentMorph visible ifFalse: [ ^false ]. - aRectangle := self boundingRectOfCurrentMorph. - myClipRect := self clipRect. - aRectangle right < myClipRect left ifTrue: [^ false]. - aRectangle left > myClipRect right ifTrue: [^ false]. - aRectangle bottom < myClipRect top ifTrue: [^ false]. - aRectangle top > myClipRect bottom ifTrue: [^ false]. - ^ true -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4296-Morphic-VG-JuanVuletich-2020Jul24-10h53m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4292] on 24 July 2020 at 11:21:45 am'! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/24/2020 11:16:52' prior: 50532274! - displayBoundsOrBogus - "Never answer nil. A bogus value will trigger a draw operation, and bounds will later be corrected." - ^self displayBounds ifNil: [ - Rectangle center: (self externalizeToWorld: 0@0) extent: 2@2 ]! ! -!Morph methodsFor: 'updating' stamp: 'jmv 7/24/2020 11:17:30' prior: 50535386! - redrawNeeded - "Report that the area occupied by this morph should be redrawn." - - self setProperty: #needsRedraw toValue: true. - self allOwnersDo: [ :m | m setProperty: #submorphNeedsRedraw toValue: true ]. - self invalidateDisplayRect: self displayBoundsOrBogus from: nil. - self submorphsDrawingOutsideReverseDo: [ :m | m redrawNeeded ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4297-Morphic-VG-JuanVuletich-2020Jul24-10h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4292] on 24 July 2020 at 2:15:52 pm'! - -WindowEdgeAdjustingMorph removeSelector: #isOpaqueMorph! - -!methodRemoval: WindowEdgeAdjustingMorph #isOpaqueMorph stamp: 'Install-4298-Morphic-VG-JuanVuletich-2020Jul24-11h21m-jmv.001.cs.st 8/5/2020 22:22:46'! -isOpaqueMorph - "Not really needed, as we also answer false to #isOrthoRectangularMorph" - ^false! - -LayoutAdjustingMorph removeSelector: #isOpaqueMorph! - -!methodRemoval: LayoutAdjustingMorph #isOpaqueMorph stamp: 'Install-4298-Morphic-VG-JuanVuletich-2020Jul24-11h21m-jmv.001.cs.st 8/5/2020 22:22:46'! -isOpaqueMorph - "Any submorph that answers true to #isOrthoRectangularMorph (to optimize #morphContainsPoint:) - but is not an opaque rectangle covering bounds MUST answer false to this message" - color mightBeTranslucent ifTrue: [ - ^false ]. - ^true! - -SystemWindow removeSelector: #isOpaqueMorph! - -!methodRemoval: SystemWindow #isOpaqueMorph stamp: 'Install-4298-Morphic-VG-JuanVuletich-2020Jul24-11h21m-jmv.001.cs.st 8/5/2020 22:22:46'! -isOpaqueMorph - "Not really used, as we also reimplement #addPossiblyUncoveredAreasIn:to:" - ^(Theme current roundWindowCorners or: [ color mightBeTranslucent ]) not! - -BorderedRectMorph removeSelector: #isOpaqueMorph! - -!methodRemoval: BorderedRectMorph #isOpaqueMorph stamp: 'Install-4298-Morphic-VG-JuanVuletich-2020Jul24-11h21m-jmv.001.cs.st 8/5/2020 22:22:46'! -isOpaqueMorph - "Any submorph that answers true to #isOrthoRectangularMorph (to optimize #morphContainsPoint:) - but is not an opaque rectangle covering bounds MUST answer false to this message" - color mightBeTranslucent ifTrue: [ - ^false ]. - borderWidth > 0 ifTrue: [ - borderColor mightBeTranslucent ifTrue: [ - ^false ]]. - ^true! - -Morph removeSelector: #isOpaqueMorph! - -!methodRemoval: Morph #isOpaqueMorph stamp: 'Install-4298-Morphic-VG-JuanVuletich-2020Jul24-11h21m-jmv.001.cs.st 8/5/2020 22:22:46'! -isOpaqueMorph - "Just answer false in the general case, to simplify submorphs. - See the implementation and comment in BorderedMorph. and see also senders. - If the answer is true, there is an optimization in world draw" - ^false! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4298-Morphic-VG-JuanVuletich-2020Jul24-11h21m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4295] on 24 July 2020 at 3:03:15 pm'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/24/2020 15:00:40'! - fullAddCurrentRect: addCurrentBounds submorphs: trySubmorphs to: aDamageRecorder - | currentMorphBounds | - addCurrentBounds ifTrue: [ - currentMorph setProperty: #needsRedraw toValue: false. - currentMorph drawOn: self. - currentMorphBounds _ self boundingRectOfCurrentMorphAfterDraw. - currentMorph displayBounds: currentMorphBounds. - aDamageRecorder recordInvalidRect: currentMorphBounds. - ]. - trySubmorphs ifTrue: [ - currentMorph setProperty: #submorphNeedsRedraw toValue: false. - currentMorph clippedSubmorph ifNotNil: [ :clipped | - self clippingByCurrentMorphDo: [ self fullAddRedrawRect: clipped to: aDamageRecorder ]]. - currentMorph unclippedSubmorphsReverseDo: [ :m | - self fullAddRedrawRect: m to: aDamageRecorder ] - ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/24/2020 15:03:08' prior: 50534191! - fullAddRedrawRect: aMorph to: aDamageRecorder - | addCurrentBounds trySubmorphs | - aMorph visible ifTrue: [ - addCurrentBounds _ aMorph valueOfProperty: #needsRedraw ifAbsent: [ false ]. - trySubmorphs _ aMorph valueOfProperty: #submorphNeedsRedraw ifAbsent: [ false ]. - (trySubmorphs or: [addCurrentBounds]) ifTrue: [ - self into: aMorph. - self canvasToUse - fullAddCurrentRect: addCurrentBounds - submorphs: trySubmorphs - to: aDamageRecorder. - self outOfMorph - ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4299-Morphic-VG-JuanVuletich-2020Jul24-15h00m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4296] on 25 July 2020 at 9:31:11 am'! -!DamageRecorder methodsFor: 'recording' stamp: 'jmv 7/25/2020 09:07:22' prior: 50531809! - invalidRectsFullBounds: aRectangle - "Return a collection of damaged rectangles for the given canvas. - If a total repaint has been requested, return the given rectangle. - Forget about all damage." - | answer | - answer _ totalRepaint ifTrue: [ Array with: aRectangle ]. - self pvtAccessProtect critical: [ - answer ifNil: [ - answer _ OrderedCollection new. - invalidRects do: [ :r | - r ifNotNil: [ - (aRectangle containsRect: r) - ifTrue: [ answer add: r ] - ifFalse: [ answer add: (r intersect: aRectangle) ]. - ]]]. - self pvtReset ]. - ^ answer.! ! -!MorphicCanvas methodsFor: 'testing' stamp: 'jmv 7/25/2020 08:58:56' prior: 50535742! - isCurrentMorphVisible - "Note: answer true if we are not sure." - | aRectangle myClipRect | - currentMorph visible ifFalse: [ ^false ]. - aRectangle := currentMorph displayBounds. - aRectangle ifNil: [ ^true ]. - myClipRect := self clipRect. - aRectangle right < myClipRect left ifTrue: [^ false]. - aRectangle left > myClipRect right ifTrue: [^ false]. - aRectangle bottom < myClipRect top ifTrue: [^ false]. - aRectangle top > myClipRect bottom ifTrue: [^ false]. - ^ true -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4300-Morphic-VG-JuanVuletich-2020Jul25-09h25m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4297] on 25 July 2020 at 3:14:40 pm'! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 7/25/2020 15:10:59' prior: 50534578! - strictlyStaggeredInitialFrameFor: aStandardSystemView initialExtent: initialExtent world: aWorld - "This method implements a staggered window placement policy that I (di) like. - Basically it provides for up to 4 windows, staggered from each of the 4 corners. - The windows are staggered so that there will always be a corner visible." - - | allowedArea grid initialFrame otherFrames cornerSel corner delta putativeCorner free maxLevel | - allowedArea := (self maximumUsableAreaInWorld: aWorld) - insetBy: (self scrollBarSetback @ self screenTopSetback extent: `0 @ 0`). - "Number to be staggered at each corner (less on small screens)" - maxLevel := allowedArea area > 300000 ifTrue: [3] ifFalse: [2]. - "Amount by which to stagger (less on small screens)" - grid := allowedArea area > 500000 ifTrue: [40] ifFalse: [20]. - initialFrame := `0 @ 0` extent: initialExtent. - "min: (allowedArea extent - (grid*(maxLevel+1*2) + (grid//2)))) - min: 600@400" - otherFrames := (SystemWindow windowsIn: aWorld satisfying: [ :w | w visible and: [w isCollapsed not]]) - collect: [:w | w displayBounds]. - otherFrames _ otherFrames reject: [ :f | f isNil ]. - 0 to: maxLevel do: [ :level | - 1 to: 4 do: [ :ci | - cornerSel := #(#topLeft #topRight #bottomRight #bottomLeft) at: ci. - corner := allowedArea perform: cornerSel. - "The extra grid//2 in delta helps to keep title tabs distinct" - delta := ((maxLevel - level) * grid + (grid // 2)) @ (level * grid). - 1 to: ci - 1 do: [ :i | delta _ delta y negated @ delta x ]. "slow way" - putativeCorner := corner + delta. - free := true. - otherFrames do: [ :w | - free := free & ((w perform: cornerSel) ~= putativeCorner)]. - free - ifTrue: [ - ^(initialFrame aligned: (initialFrame perform: cornerSel) - with: putativeCorner) translatedAndSquishedToBeWithin: allowedArea]]]. - "If all else fails..." - ^(self scrollBarSetback @ self screenTopSetback - extent: initialFrame extent) translatedAndSquishedToBeWithin: allowedArea! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/25/2020 15:09:48' prior: 50532264! - displayBounds: aRectangle - - self displayBounds ~= aRectangle ifTrue: [ - self setProperty: #displayBounds toValue: aRectangle ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/25/2020 15:06:54' prior: 50534936! -drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rectsToRepair previousRectsToRepair reuse previousCount | - "Update #displayBounds for all dirty morphs (marked as such with #redrawNeeded). - Also add the updated bounds to aDamageRecorder." - self updatingMorphBoundsDo: [ - aPasteUpMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - self updateHandsDisplayBounds: aPasteUpMorph ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ aDamageRecorder invalidRectsFullBounds: aPasteUpMorph viewBox. - - rectsToRepair size = 0 ifTrue: [ - ^rectsToRepair]. - - rectsToRepair size > 1 ifTrue: [ "Or there is no point in attempting to merge them!!" - previousRectsToRepair _ OrderedCollection new. - - "Until no more rectangles are merged, i.e. each morph intersects at most one rectangle." - previousCount _ 0. - [rectsToRepair size = previousCount] whileFalse: [ - previousCount _ rectsToRepair size. - aPasteUpMorph submorphsReverseDo: [ :morph | | thisMorphRectangle thisMorphBounds | - morph visible ifTrue: [ - reuse _ previousRectsToRepair. - previousRectsToRepair _ rectsToRepair. - rectsToRepair _ reuse removeAll. - thisMorphRectangle _ nil. - thisMorphBounds _ morph displayFullBounds. - previousRectsToRepair do: [ :r | - (thisMorphBounds intersects: r) - ifTrue: [ thisMorphRectangle _ r quickMerge: thisMorphRectangle ] - ifFalse: [ rectsToRepair add: r ]]. - thisMorphRectangle - ifNotNil: [rectsToRepair add: thisMorphRectangle]]]]. - ]. - - "Draw World" - rectsToRepair do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - "Draw morphs" - aPasteUpMorph submorphsReverseDo: [ :morph | | morphBounds | - morph visible ifTrue: [ - morphBounds _ morph displayFullBounds. - rectsToRepair do: [ :r | - (morphBounds intersects: r) ifTrue: [ - (self newClipRect: r) fullDraw: morph ]]]]. - - ^ rectsToRepair! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 7/25/2020 15:08:35' prior: 50532680 overrides: 50501541! - textComposition: aTextComposition bounds: boundsRect color: c selectionColor: sc - - engine ifNil: [ ^nil ]. - ^super textComposition: aTextComposition bounds: boundsRect color: c selectionColor: sc! ! - -BitBltCanvas removeSelector: #clippingByCurrentMorphDo:! - -!methodRemoval: BitBltCanvas #clippingByCurrentMorphDo: stamp: 'Install-4301-Morphic-VG-JuanVuletich-2020Jul25-15h06m-jmv.001.cs.st 8/5/2020 22:22:46'! -clippingByCurrentMorphDo: aBlock -"si clippeamos, tenemos un problemon. -queremos bounds no afectados por el clipping debido a los rectangles a repara -pero si por el owner. OJO!! -Creo que lo que habria que hacer es en #displayBounds:, si clippingMorph no es nil, pedirle sus displayBounds y hacer interseccion. -Y aca, ejecutar normalmente" -" engine ifNil: [ ^self ]." - ^super clippingByCurrentMorphDo: aBlock! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4301-Morphic-VG-JuanVuletich-2020Jul25-15h06m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4298] on 27 July 2020 at 1:32:21 am'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/27/2020 00:28:46'! - fullUpdateBounds: aMorph - - aMorph visible ifTrue: [ - self into: aMorph. - self canvasToUse fullUpdateCurrentBounds. - self outOfMorph - ]! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/27/2020 00:28:33'! - fullUpdateCurrentBounds - | currentMorphBounds | - currentMorph drawOn: self. - currentMorphBounds _ self boundingRectOfCurrentMorphAfterDraw. - currentMorph displayBounds: currentMorphBounds. - currentMorph submorphsDo: [ :m | - self fullUpdateBounds: m ]! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/27/2020 01:31:46' prior: 50535887! - fullAddCurrentRect: addCurrentBounds submorphs: trySubmorphs to: aDamageRecorder - | currentMorphBounds | - addCurrentBounds ifTrue: [ - currentMorph setProperty: #needsRedraw toValue: false. - currentMorph drawOn: self. - currentMorphBounds _ self boundingRectOfCurrentMorphAfterDraw. - currentMorph displayBounds: currentMorphBounds. - aDamageRecorder recordInvalidRect: currentMorphBounds. - currentMorph submorphsDo: [ :m | self fullUpdateBounds: m ]. - ]. - trySubmorphs ifTrue: [ - currentMorph setProperty: #submorphNeedsRedraw toValue: false. - currentMorph clippedSubmorph ifNotNil: [ :clipped | - self clippingByCurrentMorphDo: [ self fullAddRedrawRect: clipped to: aDamageRecorder ]]. - currentMorph unclippedSubmorphsReverseDo: [ :m | - self fullAddRedrawRect: m to: aDamageRecorder ] - ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4302-Morphic-VG-JuanVuletich-2020Jul27-01h31m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4298] on 26 July 2020 at 7:51:01 pm'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/26/2020 19:46:44'! - restorePatch: savedPatch - "Argument must previously be obtained by calling #savePatch:bounds: - Senders should not assume anything about the returned object, except that it will not be nil." - - self - image: savedPatch - at: savedPatch offset.! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/26/2020 19:45:54'! - savePatch: prevSavedPatch bounds: aRectangle - "Senders don't need to know any details of what is answered, but just store it for further calls, and calls to restorePatch:" - "Details: The previously used patch Form is recycled when possible to reduce the burden on storage management." - | savedPatch bb | - savedPatch _ prevSavedPatch. - (savedPatch isNil or: [savedPatch extent ~= aRectangle extent]) - ifTrue: [ - "allocate new patch form if needed" - savedPatch _ Form extent: aRectangle extent depth: form depth ]. - bb _ BitBlt toForm: savedPatch. - bb sourceForm: form; combinationRule: Form over; - sourceX: aRectangle left; sourceY: aRectangle top; - width: aRectangle width; height: aRectangle height; - copyBits. - savedPatch offset: aRectangle topLeft. - ^savedPatch! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 7/26/2020 19:39:19' prior: 50471088! - restoreSavedPatchOn: aCanvas - "Clear the changed flag and restore the part of the given canvas under this hand from the previously saved patch. If necessary, handle the transition to using the hardware cursor." - hasChanged _ false. - savedPatch ifNotNil: [ - aCanvas restorePatch: savedPatch. - submorphs notEmpty ifTrue: [ ^ self ]. - "Make the transition to using hardware cursor. Clear savedPatch and - report one final damage rectangle to erase the image of the software cursor." - " owner invalidateDisplayRect: (savedPatch offset extent: savedPatch extent) from: nil." - self - invalidateDisplayRect: (self morphPosition extent: extent) - from: nil. - Cursor currentCursor == Cursor defaultCursor ifFalse: [ Cursor defaultCursor activateCursor ]. - "show hardware cursor" - savedPatch _ nil ].! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 7/26/2020 19:44:48' prior: 50534285! - savePatchFrom: aCanvas appendDamageTo: aStream - "Save the part of the given canvas under this hand as a Form and return its bounding rectangle." - - | fullBounds | - fullBounds _ self displayFullBounds ifNil: [ ^self ]. - fullBounds _ fullBounds intersect: (`0@0` extent: aCanvas extent). - savedPatch _ aCanvas savePatch: savedPatch bounds: fullBounds. - prevFullBounds - ifNil: [ aStream nextPut: fullBounds ] - ifNotNil: [ aStream nextPut: (fullBounds quickMerge: prevFullBounds)]. - prevFullBounds _ fullBounds! ! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 7/26/2020 19:40:48' prior: 50532732 overrides: 50463419! - image: aForm at: aPoint sourceRect: sourceRect - "Draw a translucent image using the best available way of representing translucency. - Note: This will be fixed in the future." - | r p | - - engine ifNil: [ ^nil ]. - - p _ (currentTransformation transform: aPoint) rounded. - r _ (form depth < 32 or: [ aForm mightBeTranslucent not ]) - ifTrue: [ - "Rule Form paint treats pixels with a value of zero as transparent" - Form paint ] - ifFalse: [ Form blend ]. - engine colorMap: (aForm colormapIfNeededFor: form); fillColor: nil. - engine image: aForm at: p sourceRect: sourceRect rule: r. - (form depth = 32 and: [ aForm depth < 32 ]) ifTrue: [ - "If we blit to 32bpp from one of smaller depth, - it will have zero in the alpha channel (until BitBlt is fixed!!) - This is the same workaround as in #asFormOfDepth:" - engine sourceForm: nil. - engine combinationRule: 40. "fixAlpha:with:" - engine copyBits ]! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 7/26/2020 19:40:38' prior: 50494940! - setPaintColor: aColor - "Install a new color used for filling." - | paintColor | - paintColor _ aColor ifNil: [ `Color transparent` ]. - (paintColor is: #Color) ifFalse: [ - ^ self error: 'Cannot install color' ]. - - "Okay, so paintColor really *is* a color" - engine sourceForm: nil. - (paintColor isOpaque or: [ form depth < 32]) ifTrue: [ - engine fillColor: paintColor. - engine combinationRule: Form paint. - ^ self ]. - - "BitBlt setup for alpha mapped transfer" - engine fillColor: paintColor. - engine combinationRule: Form blend! ! - -MorphicCanvas removeSelector: #depth! - -!methodRemoval: MorphicCanvas #depth stamp: 'Install-4303-Morphic-VG-JuanVuletich-2020Jul26-19h35m-jmv.001.cs.st 8/5/2020 22:22:46'! -depth - - ^ form depth! - -MorphicCanvas removeSelector: #contentsOfArea:into:! - -!methodRemoval: MorphicCanvas #contentsOfArea:into: stamp: 'Install-4303-Morphic-VG-JuanVuletich-2020Jul26-19h35m-jmv.001.cs.st 8/5/2020 22:22:46'! -contentsOfArea: aRectangle into: aForm - | bb | - bb _ BitBlt toForm: aForm. - bb sourceForm: form; combinationRule: Form over; - sourceX: aRectangle left; sourceY: aRectangle top; - width: aRectangle width; height: aRectangle height; - copyBits. - ^aForm! - -Form removeSelector: #contentsOfArea:into:! - -!methodRemoval: Form #contentsOfArea:into: stamp: 'Install-4303-Morphic-VG-JuanVuletich-2020Jul26-19h35m-jmv.001.cs.st 8/5/2020 22:22:46'! -contentsOfArea: aRect into: newForm - "Return a new form which derives from the portion of the original form delineated by aRect." - ^ newForm copyBits: aRect from: self at: `0@0` - clippingBox: newForm boundingBox rule: Form over! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4303-Morphic-VG-JuanVuletich-2020Jul26-19h35m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4300] on 27 July 2020 at 12:40:53 am'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/26/2020 20:47:43' prior: 50536215! - restorePatch: savedPatch - "Argument must previously be obtained by calling #savePatch:bounds: - Senders should not assume anything about the returned object, except that it will not be nil." - -self flag: #jmvHacks. -"Podriamos usar un BitBlt guardado. Este metodo termina haciendo demasiadas cosas... (innecesarias)" - self - image: savedPatch - at: savedPatch offset.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4304-Morphic-VG-JuanVuletich-2020Jul27-00h40m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4300] on 27 July 2020 at 1:26:06 am'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/27/2020 00:53:40' prior: 50536225! - savePatch: prevSavedPatch bounds: aRectangle - "Senders don't need to know any details of what is answered, but just store it for further calls, and calls to restorePatch:" - "Details: The previously used patch Form is recycled when possible to reduce the burden on storage management." - | savedPatch bb | - savedPatch _ prevSavedPatch. - (savedPatch isNil or: [savedPatch extent ~= aRectangle extent]) - ifTrue: [ - "allocate new patch form if needed" - savedPatch _ Form extent: aRectangle extent depth: form depth ]. - bb _ BitBlt toForm: savedPatch. - bb sourceForm: form; combinationRule: Form over; - sourceX: aRectangle left; sourceY: aRectangle top; - width: aRectangle width; height: aRectangle height; - copyBits. - savedPatch offset: aRectangle topLeft. - ^savedPatch! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/27/2020 01:24:01' prior: 50536056! - drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rectsToRepair previousRectsToRepair reuse previousCount | - "Update #displayBounds for all dirty morphs (marked as such with #redrawNeeded). - Also add the updated bounds to aDamageRecorder." - self updatingMorphBoundsDo: [ - aPasteUpMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - self updateHandsDisplayBounds: aPasteUpMorph ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ aDamageRecorder invalidRectsFullBounds: aPasteUpMorph viewBox. - - rectsToRepair size = 0 ifTrue: [ - ^rectsToRepair]. - - rectsToRepair size > 1 ifTrue: [ "Or there is no point in attempting to merge them!!" - previousRectsToRepair _ OrderedCollection new. - - "Until no more rectangles are merged, i.e. each morph intersects at most one rectangle." - previousCount _ 0. - [rectsToRepair size = previousCount] whileFalse: [ - previousCount _ rectsToRepair size. - aPasteUpMorph submorphsReverseDo: [ :morph | | thisMorphRectangle thisMorphBounds | - morph visible ifTrue: [ - reuse _ previousRectsToRepair. - previousRectsToRepair _ rectsToRepair. - rectsToRepair _ reuse removeAll. - thisMorphRectangle _ nil. - thisMorphBounds _ morph displayFullBounds ifNil: [0@0 extent: 10@10]. - previousRectsToRepair do: [ :r | - (thisMorphBounds intersects: r) - ifTrue: [ thisMorphRectangle _ r quickMerge: thisMorphRectangle ] - ifFalse: [ rectsToRepair add: r ]]. - thisMorphRectangle - ifNotNil: [rectsToRepair add: thisMorphRectangle]]]]. - ]. - - "Draw World" - rectsToRepair do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - "Repair rects. Draw morphs" - rectsToRepair do: [ :r | - self newClipRect: r. - aPasteUpMorph submorphsReverseDo: [ :morph | | morphBounds | - morph visible ifTrue: [ - morphBounds _ morph displayFullBounds ifNil: [0@0 extent: 10@10]. - (morphBounds intersects: r) ifTrue: [ - self fullDraw: morph ]]]]. - - ^ rectsToRepair! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Preferences enable: #logDebuggerStackToFile. -Morph allSubInstancesDo: [ :m | m redrawNeeded ]. -self runningWorld restoreDisplay; displayWorldSafely! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4305-Morphic-VG-JuanVuletich-2020Jul27-00h40m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4302] on 27 July 2020 at 10:25:14 am'! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 7/27/2020 10:22:15' prior: 50532377! - boundingRectOfCurrentMorphAfterDraw - "This rectangle is used for clipping submorphs in BitBltCanvas. - Clipped to owner if appropriate. - In VectorCanvas we support clipping by any shape, not just rectangles. Then, this rectangle is used as an optimization of the area to be redrawn." - - self subclassResponsibility! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 7/27/2020 10:21:41' prior: 50531348! - boundingRectOfCurrentMorph - "In targetForm coordinates. - Answer morph bounds, ignoring possible clipping by owner." - - ^currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 7/27/2020 10:21:10' prior: 50533971 overrides: 50536534! - boundingRectOfCurrentMorphAfterDraw - "In targetForm coordinates. - Clipped to owner if appropriate." - - ^ clippingMorphDisplayBounds - ifNotNil: [ :ownerClips | self boundingRectOfCurrentMorph intersect: ownerClips ] - ifNil: [ self boundingRectOfCurrentMorph ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4306-Morphic-VG-JuanVuletich-2020Jul27-10h19m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4302] on 27 July 2020 at 10:27:08 am'! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'jmv 7/27/2020 10:26:53' prior: 50530873! - goBehind - - owner privateMoveBackMorph: self. -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4307-Morphic-VG-JuanVuletich-2020Jul27-10h25m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4304] on 27 July 2020 at 10:32:55 am'! -!HandMorph methodsFor: 'geometry testing' stamp: 'jmv 7/27/2020 10:31:41' overrides: 50532188! - submorphsMightProtrude - "Morphs we carry are usually larger than us." - - ^true! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4308-Morphic-VG-JuanVuletich-2020Jul27-10h31m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4305] on 27 July 2020 at 1:42:34 pm'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/27/2020 13:17:46'! - updateCurrentDisplayBounds - "Update displayBounds for if never set. - Useful for new morph, that are created and attached to the hand." - - currentMorph drawOn: self. - currentMorph displayBounds: self boundingRectOfCurrentMorphAfterDraw. - currentMorph clippedSubmorph ifNotNil: [ :clipped | - self clippingByCurrentMorphDo: [ self updateDisplayBounds: clipped ]]. - currentMorph unclippedSubmorphsReverseDo: [ :m | - self updateDisplayBounds: m ].! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 7/27/2020 13:24:09' prior: 50534761! - grabMorph: aMorph moveUnderHand: moveUnderHand - "Grab the given morph (i.e., add it to this hand and remove it from its current owner). - If moveUnderHand is requested or it seems neccesary anyway, move the grabbed morph under the hand." - - | grabbed delta | - "#aboutToGrab: and #aboutToBeGrabbedBy: might mess wildly with our morphs. - If we need it, prepare delta before that happens. Use 0@0 if we don't know." - delta _ `0@0`. - moveUnderHand ifFalse: [ - delta _ aMorph morphPositionInWorld - self morphPositionInWorld ]. - self releaseMouseFocus. "Break focus" - grabbed _ aMorph. - aMorph owner ifNotNil: [ :o | - grabbed _ o aboutToGrab: aMorph ]. - grabbed ifNil: [ ^ self ]. - grabbed _ grabbed aboutToBeGrabbedBy: self. - grabbed ifNil: [ ^ self ]. - (moveUnderHand or: [ (grabbed == aMorph) not ]) - ifTrue: [ - grabbed displayBounds ifNotNil: [ :r | - delta _ (r extent // 2) negated ]]. - ^ self - grabMorph: grabbed - delta: delta! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/27/2020 13:18:09' prior: 50534858! - updateDisplayBounds: aMorph - "Update displayBounds for if never set. - Useful for new morph, that are created and attached to the hand." - - aMorph visible ifTrue: [ - aMorph displayBounds ifNil: [ - self into: aMorph. - self canvasToUse updateCurrentDisplayBounds. - self outOfMorph - ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4309-Morphic-VG-JuanVuletich-2020Jul27-13h41m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4306] on 27 July 2020 at 2:48:09 pm'! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'world form clipRect transformations currentTransformation cti currentMorph drawingMorphStack engine clippingMorphDisplayBounds ' - classVariableNames: 'ActiveSubclass ' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support' stamp: 'Install-4310-Morphic-VG-JuanVuletich-2020Jul27-14h44m-jmv.001.cs.st 8/5/2020 22:22:47'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'world form clipRect transformations currentTransformation cti currentMorph drawingMorphStack engine clippingMorphDisplayBounds' - classVariableNames: 'ActiveSubclass' - poolDictionaries: '' - category: 'Morphic-Support'! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 7/27/2020 14:45:07'! - activeSubclass - ActiveSubclass ifNil: [ - ActiveSubclass _ BitBltCanvas ]. - ^ActiveSubclass! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 7/27/2020 13:37:39'! - activeSubclass: aMorphicCanvasSubclass - ActiveSubclass _ aMorphicCanvasSubclass! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 7/27/2020 14:47:45'! - subclassToUse - "If asked to a specific subclass, use that." - - ^ self == MorphicCanvas - ifFalse: [ self ] - ifTrue: [ self activeSubclass ]! ! -!Form methodsFor: 'accessing' stamp: 'jmv 7/27/2020 13:39:10' prior: 16846769! - getCanvas - "Return a Canvas that can be used to draw onto the receiver" - ^MorphicCanvas onForm: self! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 7/27/2020 13:39:07' prior: 50520775! - imageForm: depth - | canvas | - canvas _ MorphicCanvas depth: depth over: (self morphPosition extent: self morphExtent). - canvas fullDraw: self. - ^ canvas form divideByAlpha! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 7/27/2020 13:39:04' prior: 50520783! - imageForm: extent depth: depth - | canvas | - canvas _ MorphicCanvas depth: depth over: (self morphPosition extent: (self morphExtent min: extent)). - canvas fullDraw: self. - ^ canvas form divideByAlpha! ! -!WorldState methodsFor: 'canvas' stamp: 'jmv 7/27/2020 13:39:01' prior: 50337500! - ensureNonDisplayCanvas - (canvas isNil or: [ - canvas drawsOnDisplay or: [ - (canvas extent ~= world morphExtent) or: [ - canvas form depth ~= Display depth]]]) ifTrue: [ - "allocate a new offscreen canvas the size of the window" - self setCanvas: (MorphicCanvas withExtent: world morphExtent depth: Display depth)]! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 7/27/2020 14:47:53' prior: 16877732! - on: aForm over: aRectangle - "Warning: aForm extent must equal aRectangle extent" - - ^ self subclassToUse basicNew - initializeWith: aForm origin: aRectangle topLeft negated! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 7/27/2020 14:47:56' prior: 50385956! - onForm: aForm - - ^ self subclassToUse basicNew - initializeWith: aForm origin: `0@0`! ! - -Object subclass: #MorphicCanvas - instanceVariableNames: 'world form clipRect transformations currentTransformation cti currentMorph drawingMorphStack engine clippingMorphDisplayBounds' - classVariableNames: 'ActiveSubclass' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #MorphicCanvas category: #'Morphic-Support' stamp: 'Install-4310-Morphic-VG-JuanVuletich-2020Jul27-14h44m-jmv.001.cs.st 8/5/2020 22:22:47'! -Object subclass: #MorphicCanvas - instanceVariableNames: 'world form clipRect transformations currentTransformation cti currentMorph drawingMorphStack engine clippingMorphDisplayBounds' - classVariableNames: 'ActiveSubclass' - poolDictionaries: '' - category: 'Morphic-Support'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4310-Morphic-VG-JuanVuletich-2020Jul27-14h44m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4307] on 27 July 2020 at 2:54:38 pm'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/27/2020 14:52:25' prior: 50536413! - savePatch: prevSavedPatch bounds: aRectangle - "Senders don't need to know any details of what is answered, but just store it for further calls, and calls to restorePatch:" - "Details: The previously used patch Form is recycled when possible to reduce the burden on storage management." - | savedPatch bb | - savedPatch _ prevSavedPatch. - ((savedPatch is: #Form) not or: [savedPatch extent ~= aRectangle extent]) - ifTrue: [ - "allocate new patch form if needed" - savedPatch _ Form extent: aRectangle extent depth: form depth ]. - bb _ BitBlt toForm: savedPatch. - bb sourceForm: form; combinationRule: Form over; - sourceX: aRectangle left; sourceY: aRectangle top; - width: aRectangle width; height: aRectangle height; - copyBits. - savedPatch offset: aRectangle topLeft. - ^savedPatch! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4311-Morphic-VG-JuanVuletich-2020Jul27-14h52m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4307] on 27 July 2020 at 2:58:50 pm'! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 7/27/2020 14:58:44' prior: 50536698! - activeSubclass: aMorphicCanvasSubclass - ActiveSubclass _ aMorphicCanvasSubclass. - PasteUpMorph allInstancesDo: [ :w | w clearCanvas ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4312-Morphic-VG-JuanVuletich-2020Jul27-14h54m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4309] on 27 July 2020 at 4:05:39 pm'! -!MorphicCanvas methodsFor: 'testing' stamp: 'jmv 7/27/2020 16:03:48' prior: 50535959! - isCurrentMorphVisible - "Note: answer true if we are not sure." - | aRectangle myClipRect | - currentMorph visible ifFalse: [ ^false ]. - aRectangle := currentMorph displayBounds. - aRectangle ifNil: [ ^true ]. - (currentMorph firstOwnerSuchThat: [ :m | m is: #HandMorph ]) notNil ifTrue: [ ^true ]. - myClipRect := self clipRect. - aRectangle right < myClipRect left ifTrue: [^ false]. - aRectangle left > myClipRect right ifTrue: [^ false]. - aRectangle bottom < myClipRect top ifTrue: [^ false]. - aRectangle top > myClipRect bottom ifTrue: [^ false]. - ^ true -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4313-Morphic-VG-JuanVuletich-2020Jul27-16h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4309] on 27 July 2020 at 4:50:50 pm'! - -RectangleLikeMorph subclass: #HaloMorph - instanceVariableNames: 'target positionOffset angleOffset growingOrRotating haloBox scaleOffset ' - classVariableNames: 'HandleSize Icons ' - poolDictionaries: '' - category: 'Morphic-Halos'! - -!classDefinition: #HaloMorph category: #'Morphic-Halos' stamp: 'Install-4314-Morphic-VG-JuanVuletich-2020Jul27-16h05m-jmv.001.cs.st 8/5/2020 22:22:47'! -RectangleLikeMorph subclass: #HaloMorph - instanceVariableNames: 'target positionOffset angleOffset growingOrRotating haloBox scaleOffset' - classVariableNames: 'HandleSize Icons' - poolDictionaries: '' - category: 'Morphic-Halos'! -!Preferences class methodsFor: 'halos' stamp: 'jmv 7/27/2020 16:34:43' prior: 50344310! - iconicHaloSpecifications - "Answer an array that characterizes the locations, colors, icons, and selectors of the halo handles that may be used in the iconic halo scheme" - - " - Preferences resetHaloSpecifications - " - -^ #( - "selector horiz vert color info icon key balloon help - --------- ------ ----------- -------------------------- -------------------------- ---------------" - (addCollapseHandle: left topCenter (tan) haloCollapseIcon 'Collapse') - (addDebugHandle: right topCenter (orange) haloDebugIcon 'Debug') - (addDismissHandle: left top (red) haloDismissIcon 'Remove') - (addRotateHandle: left bottom (blue) haloRotateIcon 'Rotate') - (addMenuHandle: leftCenter top (blue lighter) haloMenuIcon 'Menu') - (addGrabHandle: center top (black) haloGrabIcon 'Pick up') - (addDragHandle: rightCenter top (brown) haloDragIcon 'Move') - (addDupHandle: right top (green) haloDuplicateIcon 'Duplicate') - (addHelpHandle: center bottom (lightBlue) haloHelpIcon 'Help') - (addGrowHandle: right bottom (yellow) haloScaleIcon 'Change size') - (addFontSizeHandle: leftCenter bottom (lightGreen) haloFontSizeIcon 'Change font') - (addFontEmphHandle: rightCenter bottom (lightBrown darker) haloFontEmphasisIcon 'Emphasis & alignment') - "FIXME - Currently non-functional... - (addRecolorHandle: right bottomCenter (magenta darker) haloColorIcon 'Change color') - " -)! ! -!AffineTransformation methodsFor: 'modifying' stamp: 'jmv 7/27/2020 16:24:40' prior: 16778620! - rotatedBy: radians - "rotate the receiver by radians angle. - Answer the modified object. In this implementation is self, but some classes of transformations, - more restricted ones (like MorphicTranslation) could require the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself." - - | s c a11 a12 a21 a22 | - s _ radians sin. - c _ radians cos. - a11 _ self a11. - a12 _ self a12. - a21 _ self a21. - a22 _ self a22. - self a11: (c * a11) - (s * a21). - self a12: (c * a12) - (s * a22). - self a21: (s * a11) + (c * a21). - self a22: (s * a12) + (c * a22). - ^ self! ! -!AffineTransformation methodsFor: 'modifying' stamp: 'jmv 7/27/2020 16:28:09' prior: 16778671! - scaledByNumber: aNumber rotatedBy: radians - "rotate the receiver by radians angle. Also scale by aNumber. - Note: the scale factor is a number, not a point. Therefore, the same scale is applied in all directions. - This means that there is no difference between scaling then rotating and rotating then scaling. - - Answer the modified object. In this implementation is self, but some classes of transformations, - more restricted ones (like MorphicTranslation) could require the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself." - - | s c a11 a12 a21 a22 | - s _ radians sin. - c _ radians cos. - a11 _ self a11 * aNumber. - a12 _ self a12 * aNumber. - a21 _ self a21 * aNumber. - a22 _ self a22 * aNumber. - self a11: (c * a11) - (s * a21). - self a12: (c * a12) - (s * a22). - self a21: (s * a11) + (c * a21). - self a22: (s * a12) + (c * a22). - ^self! ! -!MorphicTranslation methodsFor: 'accessing' stamp: 'jmv 7/27/2020 16:49:10' prior: 16878289! - scale - "Answer the *scalar* scale applied by the receiver. Will not work correctly for shear (skew) transformations, or different scale in x and y. - Will work correctly for scaling (if equal in all directions, i.e. if scale is a scalar), for rotations, translations, and compositions of these." - - ^1.0! ! -!Morph methodsFor: 'as yet unclassified' stamp: 'jmv 7/27/2020 16:37:56' prior: 16874117! - rotationDegrees: degrees - location _ location rotatedBy: degrees degreesToRadians - location radians. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 7/27/2020 16:29:42' prior: 50344363! - wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph - "Answer whether the receiver would like to offer the halo handle with the given selector (e.g. #addCollapseHandle:)" - - (#(addRecolorHandle:) statePointsTo: aSelector) - ifTrue: ["FIXME - hack to disable for non-functional halo items" - ^ false]. - - Preferences selectiveHalos ifFalse: [ - ^true ]. - - (#(#addDismissHandle: ) includes: aSelector) - ifTrue: [ ^ self resistsRemoval not ]. - (#(#addDragHandle: ) includes: aSelector) - ifTrue: [ ^ self okayToBrownDragEasily ]. - (#(#addGrowHandle: ) includes: aSelector) - ifTrue: [ ^ self okayToResizeEasily ]. - (#(#addRotateHandle: ) includes: aSelector) - ifTrue: [ ^ self okayToRotateEasily ]. - (#(#addRecolorHandle: ) includes: aSelector) - ifTrue: [ ^ self wantsRecolorHandle ]. - ^ true! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/27/2020 16:50:25' prior: 50388452! - doRot: evt with: rotHandle - "Update the rotation of my target if it is rotatable. Keep the relevant command object up to date." - - | radians scale | -self revisar. - self flag: #jmvVer2. - evt hand obtainHalo: self. - radians _ (evt eventPosition - target referencePosition) theta. - radians _ radians - angleOffset theta. - "degrees _ degrees detentBy: 10.0 atMultiplesOf: 90.0 snap: false." - radians = 0.0 - ifTrue: [rotHandle color: `Color lightBlue`] - ifFalse: [rotHandle color: `Color blue`]. - rotHandle submorphsDo: - [:m | m color: rotHandle color makeForegroundColor]. - scale _ (evt eventPosition - target referencePosition) rho * scaleOffset. - self removeAllHandlesBut: rotHandle. - target rotation: radians scale: scale. - rotHandle morphPositionInWorld: evt eventPosition - (rotHandle morphExtent // 2)! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/27/2020 16:48:47' prior: 16851166! - startRot: evt with: rotHandle - "Initialize rotation of my target if it is rotatable. Launch a command object to represent the action" - - evt hand obtainHalo: self. "Make sure the event's hand correlates with the receiver" - growingOrRotating _ true. - - self removeAllHandlesBut: rotHandle. "remove all other handles" - angleOffset _ evt eventPosition - target referencePosition. - angleOffset _ Point - r: angleOffset r - degrees: angleOffset degrees - target rotationDegrees. - scaleOffset _ target location scale / (evt eventPosition - target referencePosition) rho. - -! ! - -RectangleLikeMorph subclass: #HaloMorph - instanceVariableNames: 'target positionOffset angleOffset growingOrRotating haloBox scaleOffset' - classVariableNames: 'HandleSize Icons' - poolDictionaries: '' - category: 'Morphic-Halos'! - -!classDefinition: #HaloMorph category: #'Morphic-Halos' stamp: 'Install-4314-Morphic-VG-JuanVuletich-2020Jul27-16h05m-jmv.001.cs.st 8/5/2020 22:22:47'! -RectangleLikeMorph subclass: #HaloMorph - instanceVariableNames: 'target positionOffset angleOffset growingOrRotating haloBox scaleOffset' - classVariableNames: 'HandleSize Icons' - poolDictionaries: '' - category: 'Morphic-Halos'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4314-Morphic-VG-JuanVuletich-2020Jul27-16h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4309] on 27 July 2020 at 5:10:43 pm'! -!Morph methodsFor: 'fileIn/out' stamp: 'jmv 7/27/2020 17:07:00' prior: 16875174 overrides: 16882034! - storeDataOn: aDataStream - "Let all Morphs be written out. All owners are weak references. They only go out if the owner is in the tree being written." - | cntInstVars cntIndexedVars ti instVarNames | - - "block my owner unless he is written out by someone else" - cntInstVars _ self class instSize. - cntIndexedVars _ self basicSize. - instVarNames _ self class allInstVarNames. - ti _ 1. - ((instVarNames at: ti) = 'owner') & (Morph superclass == Object) ifFalse: [ - self error: 'this method is out of date']. - aDataStream - beginInstance: self class - size: cntInstVars + cntIndexedVars. - 1 to: cntInstVars do: [ :i | - (instVarNames at: i) caseOf: { - ['owner'] -> [aDataStream nextPutWeak: owner]. "owner only written if in our tree" - ['id'] -> [ aDataStream nextPut: nil ]. - } - otherwise: [ aDataStream nextPut: (self instVarAt: i)]]. - 1 to: cntIndexedVars do: [ :i | - aDataStream nextPut: (self basicAt: i)]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4315-Morphic-VG-JuanVuletich-2020Jul27-16h50m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4312] on 27 July 2020 at 5:13:53 pm'! -!MorphicCanvas methodsFor: 'testing' stamp: 'jmv 7/27/2020 17:13:44' prior: 50536841! - isCurrentMorphVisible - "Note: answer true if we are not sure." - | aRectangle myClipRect | - currentMorph visible ifFalse: [ ^false ]. - aRectangle := currentMorph displayBounds. - aRectangle ifNil: [ ^true ]. - (currentMorph firstOwnerSuchThat: [ :m | m is: #HandMorph ]) notNil ifTrue: [ ^true ]. - -self flag: #jmvHacks. - true ifTrue: [ ^true ]. - myClipRect := self clipRect. - aRectangle right < myClipRect left ifTrue: [^ false]. - aRectangle left > myClipRect right ifTrue: [^ false]. - aRectangle bottom < myClipRect top ifTrue: [^ false]. - aRectangle top > myClipRect bottom ifTrue: [^ false]. - ^ true -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4316-Morphic-VG-JuanVuletich-2020Jul27-17h13m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4315] on 28 July 2020 at 12:03:43 pm'! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/28/2020 12:02:21' prior: 50531541! - fullContainsGlobalPoint: worldPoint - "Answer true even if aLocalPoint is in some submorph, regardless of being also inside our shape." - - "If not visible, won't contain any point at all." - | canvas | - self visible ifFalse: [ ^false ]. - - canvas _ self world canvas. - canvas isNil ifTrue: [ ^false ]. - (canvas morph: self isAtPoint: worldPoint) ifTrue: [ ^ true ]. - self submorphsDo: [ :m | - (m fullContainsGlobalPoint: worldPoint) ifTrue: [ ^ true ]]. - ^ false! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/28/2020 12:01:54' prior: 50531589! - fullContainsPoint: aLocalPoint - "Answer true even if aLocalPoint is in some submorph, regardless of being also inside our shape." - - "If not visible, won't contain any point at all." - self visible ifFalse: [ ^false ]. - - ^self fullContainsGlobalPoint: (self externalizeToWorld: aLocalPoint).! ! -!PasteUpMorph methodsFor: 'misc' stamp: 'jmv 7/28/2020 12:00:02' prior: 16887369! - buildMagnifiedBackgroundImage - | image old | - old _ backgroundImage. - backgroundImageData - ifNil: [ backgroundImage _ nil ] - ifNotNil: [ - [image _ Form fromBinaryStream: backgroundImageData readStream. - backgroundImage _ image magnifyTo: extent. - self canvas ifNotNil: [ :c | - (backgroundImage depth = 32 and: [ c form depth < 32 ]) ifTrue: [ - backgroundImage _ backgroundImage orderedDither32To16 ]] - ] on: Error do: [backgroundImage := nil]. "Can happen if JPEG plugin not built" - ]. - old == backgroundImage ifFalse: [ - self redrawNeeded ]! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -self runningWorld buildMagnifiedBackgroundImage; clearCanvas! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4317-Morphic-VG-JuanVuletich-2020Jul28-11h59m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4316] on 28 July 2020 at 12:19:29 pm'! -!RectangleLikeMorph methodsFor: 'geometry testing' stamp: 'jmv 7/28/2020 12:16:53' prior: 50531559! - morphContainsPoint: aLocalPoint - "Answer true even if aLocalPoint is in a submorph, as long as it is in our shape" - - "If not visible, won't contain any point at all." - self visible ifFalse: [ ^false ]. - - "Most morphs answer true to to #isOrthoRectangularMorph, or redefine this method..." - self isOrthoRectangularMorph ifTrue: [ - ^ self morphLocalBounds containsPoint: aLocalPoint ]. - - "...But for those who not, provide correct albeit expensive behavior." - "Can't do better. Please redefine in subclasses as appropriate!! (or finish Morphic 3!!)" - "Mhhh. Podria usar el #imageForm: y ver si es transparente... deberia andar" - ^ self morphLocalBounds containsPoint: aLocalPoint! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 7/28/2020 12:18:56' prior: 50531583! -morph: aMorph isAtPoint: aPoint - aMorph displayBounds ifNotNil: [ :r | - (r containsPoint: aPoint) ifFalse: [ - ^false ]]. - ^aMorph morphContainsPoint: - (aMorph internalizeFromWorld: aPoint)! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4318-Morphic-VG-JuanVuletich-2020Jul28-12h16m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4317] on 28 July 2020 at 12:23:29 pm'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/28/2020 12:23:22' prior: 50536441! - drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rectsToRepair previousRectsToRepair reuse previousCount | - "Update #displayBounds for all dirty morphs (marked as such with #redrawNeeded). - Also add the updated bounds to aDamageRecorder." - self updatingMorphBoundsDo: [ - aPasteUpMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - self updateHandsDisplayBounds: aPasteUpMorph ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ aDamageRecorder invalidRectsFullBounds: aPasteUpMorph viewBox. - - rectsToRepair size = 0 ifTrue: [ - ^rectsToRepair]. - - rectsToRepair size > 1 ifTrue: [ "Or there is no point in attempting to merge them!!" - previousRectsToRepair _ OrderedCollection new. - - "Until no more rectangles are merged, i.e. each morph intersects at most one rectangle." - previousCount _ 0. - [rectsToRepair size = previousCount] whileFalse: [ - previousCount _ rectsToRepair size. - aPasteUpMorph submorphsReverseDo: [ :morph | | thisMorphRectangle thisMorphBounds | - morph visible ifTrue: [ - reuse _ previousRectsToRepair. - previousRectsToRepair _ rectsToRepair. - rectsToRepair _ reuse removeAll. - thisMorphRectangle _ nil. - thisMorphBounds _ morph displayFullBounds. - previousRectsToRepair do: [ :r | - (thisMorphBounds intersects: r) - ifTrue: [ thisMorphRectangle _ r quickMerge: thisMorphRectangle ] - ifFalse: [ rectsToRepair add: r ]]. - thisMorphRectangle - ifNotNil: [rectsToRepair add: thisMorphRectangle]]]]. - ]. - - "Draw World" - rectsToRepair do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - "Repair rects. Draw morphs" - rectsToRepair do: [ :r | - self newClipRect: r. - aPasteUpMorph submorphsReverseDo: [ :morph | | morphBounds | - morph visible ifTrue: [ - morphBounds _ morph displayFullBounds. - (morphBounds intersects: r) ifTrue: [ - self fullDraw: morph ]]]]. - - ^ rectsToRepair! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4319-Morphic-VG-JuanVuletich-2020Jul28-12h23m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4319] on 31 July 2020 at 3:42:14 pm'! - -RectangleLikeMorph subclass: #HandMorph - instanceVariableNames: 'mouseFocus keyboardFocus mouseClickState mouseOverHandler lastMouseEvent damageRecorder hasChanged savedPatch lastEventBuffer lastKeyDownValue lastMouseEventTime prevFullBounds grabMorphData lastPosition ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -!classDefinition: #HandMorph category: #'Morphic-Kernel' stamp: 'Install-4320-lastPosition-Hand-ivar-JuanVuletich-2020Jul31-15h24m-jmv.001.cs.st 8/5/2020 22:22:47'! -RectangleLikeMorph subclass: #HandMorph - instanceVariableNames: 'mouseFocus keyboardFocus mouseClickState mouseOverHandler lastMouseEvent damageRecorder hasChanged savedPatch lastEventBuffer lastKeyDownValue lastMouseEventTime prevFullBounds grabMorphData lastPosition' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/31/2020 15:24:00' prior: 50535786! - displayBoundsOrBogus - "Never answer nil. A bogus value will trigger a draw operation, and bounds will later be corrected." - ^self displayBounds ifNil: [ - Rectangle center: (self externalizeToWorld: `0@0`) extent: `2@2` ]! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 7/31/2020 15:41:33' prior: 50533610! - fullDrawHandOn: aCanvas - "A HandMorph has an unusual drawing requirement: - The hand itself (i.e., the cursor) appears in front of its submorphs - The illusion is that the hand plucks up morphs and carries them above the world." - - submorphs reverseDo: [ :m | aCanvas fullDraw: m ]. - self drawOn: aCanvas. "draw the hand itself in front of morphs" - lastPosition _ submorphs notEmpty ifTrue: [self morphPosition].! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 7/31/2020 15:41:15' prior: 50535013 overrides: 50534892! - displayFullBounds - "Current full bounds of hand and carried submorphs. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around)." - | fullBounds | - fullBounds _ self displayBounds. - self submorphsDo: [ :m | - fullBounds _ fullBounds quickMerge: m displayFullBounds]. - lastPosition - ifNotNil: [ :lastPos | "When already carrying morphs around." - fullBounds _ fullBounds translatedBy: self morphPosition-lastPos. - fullBounds _ fullBounds quickMerge: self displayBounds ]. - ^fullBounds! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 7/31/2020 15:41:42' prior: 50533636! - grabMorph: aMorph delta: delta - "Grab the given morph (i.e., add it to this hand and remove it from its current owner)." - - | formerOwner | - self releaseMouseFocus. "Break focus" - - "Grab the halo if present" - self halo ifNotNil: [ :h | - h target == aMorph ifTrue: [ - self addMorphBack: h position: h morphPositionInWorld - self morphPositionInWorld ]]. - - "Remember previous owner and position, in case the drop is later rejected" - formerOwner _ aMorph owner. - formerOwner ifNotNil: [ - grabMorphData - at: aMorph - put: { formerOwner. aMorph morphPositionInWorld. } ]. - self addMorphBack: aMorph position: delta. - aMorph justGrabbedFrom: formerOwner. - formerOwner ifNotNil: [ - lastPosition _ self morphPosition ].! ! - -RectangleLikeMorph subclass: #HandMorph - instanceVariableNames: 'mouseFocus keyboardFocus mouseClickState mouseOverHandler lastMouseEvent damageRecorder hasChanged savedPatch lastEventBuffer lastKeyDownValue lastMouseEventTime prevFullBounds grabMorphData lastPosition' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -!classDefinition: #HandMorph category: #'Morphic-Kernel' stamp: 'Install-4320-lastPosition-Hand-ivar-JuanVuletich-2020Jul31-15h24m-jmv.001.cs.st 8/5/2020 22:22:47'! -RectangleLikeMorph subclass: #HandMorph - instanceVariableNames: 'mouseFocus keyboardFocus mouseClickState mouseOverHandler lastMouseEvent damageRecorder hasChanged savedPatch lastEventBuffer lastKeyDownValue lastMouseEventTime prevFullBounds grabMorphData lastPosition' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4320-lastPosition-Hand-ivar-JuanVuletich-2020Jul31-15h24m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4319] on 31 July 2020 at 4:13:32 pm'! -!Morph commentStamp: 'jmv 7/31/2020 16:05:32' prior: 50506282! - A Morph (from the Greek "shape" or "form") is an interactive graphical object. General information on the Morphic system can be found at http://wiki.squeak.org/squeak/morph. - -Morphs exist in a tree, rooted at a World (generally a PasteUpMorph). The morphs owned by a morph are its submorphs. Morphs are drawn recursively; if a Morph has no owner it never gets drawn. To hide a Morph and its submorphs, send the #visible: message. - -Structure: -instance var Type Description -owner Morph My parent Morph, or nil for the top-level Morph, which is a - or nil world, typically a PasteUpMorph. -submorphs Array My child Morphs. -location GeometryTransformation Specifies position (and possibly, angle of rotation and scale change) inside owner - See comment at GeometryTransformation -extension MorphExtension Allows extra properties to be stored without adding a - or nil storage burden to all morphs. -! -!Morph methodsFor: 'accessing - flags' stamp: 'jmv 7/31/2020 16:08:29'! - isLayoutNeeded - - ^ self privateFlagAt: 4! ! -!Morph methodsFor: 'accessing - flags' stamp: 'jmv 7/31/2020 16:08:33'! - isRedrawNeeded - - ^ self privateFlagAt: 1! ! -!Morph methodsFor: 'accessing - flags' stamp: 'jmv 7/31/2020 16:12:00'! - isSubmorphRedrawNeeded - - ^ self privateFlagAt: 2! ! -!Morph methodsFor: 'accessing - flags' stamp: 'jmv 7/31/2020 16:08:56'! - layoutNeeded: aBoolean - - ^self privateFlagAt: 4 put: aBoolean! ! -!Morph methodsFor: 'accessing - flags' stamp: 'jmv 7/31/2020 16:08:43'! - needsRedraw: aBoolean - - ^self privateFlagAt: 1 put: aBoolean! ! -!Morph methodsFor: 'accessing - flags' stamp: 'jmv 7/31/2020 16:11:49'! - submorphNeedsRedraw: aBoolean - - ^self privateFlagAt: 2 put: aBoolean! ! -!Morph methodsFor: 'private' stamp: 'jmv 7/31/2020 15:56:13'! - privateFlagAt: bitIndex - "We can hold up to 8 1-bit flags. - Initial value of all flags is false." - - id ifNil: [ self morphId ]. - ^(id bitAt: bitIndex) = 1! ! -!Morph methodsFor: 'private' stamp: 'jmv 7/31/2020 15:56:19'! - privateFlagAt: bitIndex put: aBoolean - "We can hold up to 8 1-bit flags. - Initial value of all flags is false." - - id ifNil: [ self morphId ]. - id _ id bitAt: bitIndex put: (aBoolean ifTrue: [1] ifFalse: [0])! ! -!Morph class methodsFor: 'initialize-release' stamp: 'jmv 7/31/2020 15:46:22'! - clearIds - - LastMorphId _ nil. - self allSubInstancesDo: [ :each | - each clearId ]! ! -!Morph methodsFor: 'accessing' stamp: 'jmv 7/31/2020 15:52:47' prior: 50505980! - morphId - "Non zero. Zero id means no Morph. - reserve lower 8 bits of numeric ivar for boolean flags." - " - Morph clearIds - " - id ifNil: [ - LastMorphId isNil ifTrue: [ LastMorphId _ 0 ]. - LastMorphId _ LastMorphId + 1. - id _ LastMorphId << 8 ]. - ^id >> 8! ! -!Morph methodsFor: 'accessing - flags' stamp: 'jmv 7/31/2020 16:09:44' prior: 16874339! - visible - "Answer if I am visible -- default is true. - Store value of 'hidden', because flags default to false." - - ^ (self privateFlagAt: 3) not! ! -!Morph methodsFor: 'caching' stamp: 'jmv 7/31/2020 15:56:42' prior: 50510031! - clearId - "Also clear flags (i.e. sets all flags to false)" - - id _ nil.! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 7/31/2020 16:05:51' prior: 50535254! - visible: aBoolean - "set the 'visible' attribute of the receiver to aBoolean - Store value of 'hidden', because flags default to false." - - self visible == aBoolean - ifTrue: [ ^ self ]. - self privateFlagAt: 3 put: aBoolean not. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded! ! -!Morph methodsFor: 'initialization' stamp: 'jmv 7/31/2020 16:00:26' prior: 16875910 overrides: 16896425! - initialize - "initialize the state of the receiver" - - owner _ nil. - submorphs _ #(). - location _ MorphicTranslation new.! ! -!Morph methodsFor: 'layout' stamp: 'jmv 7/31/2020 16:00:40' prior: 16876028! - layoutSubmorphs - "Compute a new layout of submorphs based on the given layout bounds." - "Only specific subclasses do layout. They redefine this method. - Remember to call super, or set layoutNeeded ivar to false!!" - - self layoutNeeded: false! ! -!Morph methodsFor: 'layout' stamp: 'jmv 7/31/2020 15:59:49' prior: 16876038! - layoutSubmorphsIfNeeded - "Return self. Recompute the layout if necessary." - - "Check senders. Many many not be needed. Others might be just to compute fullBounds, that we hope to elliminate!! Keep those that really need layout. of submorphs" - self flag: #jmvVer2. - - self isLayoutNeeded ifTrue: [ - self layoutSubmorphs ].! ! -!Morph methodsFor: 'layout' stamp: 'jmv 7/31/2020 15:59:02' prior: 16876053! - someSubmorphPositionOrExtentChanged - "Our extent, or some submorph changed. Must layout submorphs again." - - self layoutNeeded: true.! ! -!Morph methodsFor: 'updating' stamp: 'jmv 7/31/2020 16:13:02' prior: 50535796! - redrawNeeded - "Report that the area occupied by this morph should be redrawn." - - self needsRedraw: true. - self allOwnersDo: [ :m | m submorphNeedsRedraw: true ]. - self invalidateDisplayRect: self displayBoundsOrBogus from: nil. - self submorphsDrawingOutsideReverseDo: [ :m | m redrawNeeded ]! ! -!SystemWindow methodsFor: 'layout' stamp: 'jmv 7/31/2020 15:59:34' prior: 50384751 overrides: 50537644! - layoutSubmorphs - "Compute a new layout of submorphs based on the given layout bounds." - - | h thickness w cornerExtent wh ww pos | - thickness _ 4. - cornerExtent _ 20. - ww _ extent x. - wh _ extent y. - w _ ww - cornerExtent - cornerExtent. - h _ wh - cornerExtent - cornerExtent. - (adjusters at: #topAdjuster) morphPosition: cornerExtent@0 extent: w@thickness. - (adjusters at: #bottomAdjuster) morphPosition: cornerExtent@(wh-thickness) extent: w@thickness. - (adjusters at: #leftAdjuster) morphPosition: 0@cornerExtent extent: thickness@h. - (adjusters at: #rightAdjuster) morphPosition: ww-thickness@cornerExtent extent: thickness@h. - (adjusters at: #topLeftAdjuster) morphPosition: `0@0` extent: cornerExtent@cornerExtent. - (adjusters at: #bottomLeftAdjuster) morphPosition: 0@(wh-cornerExtent) extent: cornerExtent@cornerExtent. - (adjusters at: #topRightAdjuster) morphPosition: ww-cornerExtent@0 extent: cornerExtent@cornerExtent. - (adjusters at: #bottomRightAdjuster) morphPosition: ww@wh-cornerExtent extent: cornerExtent@cornerExtent. - - layoutMorph ifNotNil: [ - pos _ borderWidth @ (borderWidth + self labelHeight). - layoutMorph - morphPosition: pos - extent: extent - pos - borderWidth ]. - - self layoutNeeded: false.! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 7/31/2020 16:00:14' prior: 50520113 overrides: 50537644! - layoutSubmorphs - "Compute a new layout based on the given layout bounds." - - submorphs isEmpty ifTrue: [ - self layoutNeeded: false. - ^self]. - - "Invariant: morphExtent >= minimumLayoutExtent" - self refreshExtent. - - direction == #horizontal ifTrue: [ - self layoutSubmorphsHorizontallyIn: self layoutBounds ]. - - direction == #vertical ifTrue: [ - self layoutSubmorphsVerticallyIn: self layoutBounds ]. - - self layoutNeeded: false.! ! -!ProgressMorph methodsFor: 'initialization' stamp: 'jmv 7/31/2020 15:59:11' prior: 50444438 overrides: 50384218! - openInWorld: aWorld - "This msg and its callees result in the window being activeOnlyOnTop" - aWorld addMorph: self. - self updatePositionAndExtent. - labelMorph fitContents. - subLabelMorph fitContents. - self layoutNeeded: true.! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/31/2020 16:13:11' prior: 50536180! -fullAddCurrentRect: addCurrentBounds submorphs: trySubmorphs to: aDamageRecorder - | currentMorphBounds | - addCurrentBounds ifTrue: [ - currentMorph needsRedraw: false. - currentMorph drawOn: self. - currentMorphBounds _ self boundingRectOfCurrentMorphAfterDraw. - currentMorph displayBounds: currentMorphBounds. - aDamageRecorder recordInvalidRect: currentMorphBounds. - currentMorph submorphsDo: [ :m | self fullUpdateBounds: m ]. - ]. - trySubmorphs ifTrue: [ - currentMorph submorphNeedsRedraw: false. - currentMorph clippedSubmorph ifNotNil: [ :clipped | - self clippingByCurrentMorphDo: [ self fullAddRedrawRect: clipped to: aDamageRecorder ]]. - currentMorph unclippedSubmorphsReverseDo: [ :m | - self fullAddRedrawRect: m to: aDamageRecorder ] - ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/31/2020 16:12:51' prior: 50535913! - fullAddRedrawRect: aMorph to: aDamageRecorder - | addCurrentBounds trySubmorphs | - aMorph visible ifTrue: [ - addCurrentBounds _ aMorph isRedrawNeeded. - trySubmorphs _ aMorph isSubmorphRedrawNeeded. - (trySubmorphs or: [addCurrentBounds]) ifTrue: [ - self into: aMorph. - self canvasToUse - fullAddCurrentRect: addCurrentBounds - submorphs: trySubmorphs - to: aDamageRecorder. - self outOfMorph - ]]! ! - -Morph removeSelector: #privateFlag:! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Morph allSubInstancesDo: [ :m | (m valueOfProperty: #visible ifAbsent: [true]) ifFalse: [m privateFlagAt: 3 put: true]]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4321-Morph-flags-JuanVuletich-2020Jul31-15h42m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4319] on 31 July 2020 at 4:16:04 pm'! - -"Change Set: 4322-AddPrivateDisplayBoundsIvarToMorph-JuanVuletich-2020Jul31-16h13m -Date: 31 July 2020 -Author: Juan Vuletich - -Adding an instance variable to Morph is tricky. Hence this preamble." -| ui b cs | -Utilities authorInitialsPerSe ifNil: [ Utilities setAuthor ]. -(nil confirm: 'In order to add a new instance variable to Morph, -we need to restart the User Interface process. -You''ll need to re-start the image update to install later updates.') ifFalse: [ self halt ]. -[ - ui _ UISupervisor ui. - UISupervisor stopUIProcess. - b _ ClassBuilder isSilent. - ClassBuilder beSilent: true. - ClassBuilder new - superclass: Object - subclass: #Morph - instanceVariableNames: 'owner submorphs location layoutSpec properties id privateDisplayBounds' - classVariableNames: 'LastMorphId' - poolDictionaries: '' - category: 'Morphic-Kernel'. - ClassBuilder beSilent: b. - UISupervisor spawnNewMorphicProcessFor: ui. - ChangeSet installing: '4322-AddPrivateDisplayBoundsIvarToMorph-JuanVuletich-2020Jul31-16h13m-jmv.001.cs.st' do: []. - cs _ ChangeSet changeSetForBaseSystem. - (cs name beginsWith: '4322') ifTrue: [ - ChangeSet removeChangeSet: cs ]. - 'Done adding ivar ''privateDisplayBounds'' to Morph.' print. - 'Installed ChangeSet: 4322-AddPrivateDisplayBoundsIvarToMorph-JuanVuletich-2020Jul31-16h13m-jmv.001.cs.st' print. - 'Please restart [Install New Updates].' print. -] forkAt: 41! - -'From Cuis 5.0 [latest update: #4322] on 31 July 2020 at 4:52:46 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/31/2020 16:48:16' prior: 50536049! - displayBounds: aRectangle - - self displayBounds ~= aRectangle ifTrue: [ - privateDisplayBounds _ aRectangle. - self setProperty: #displayBounds toValue: aRectangle ].! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Morph allSubInstancesDo: [ :m | m displayBounds ifNotNil: [ :r | m instVarNamed: 'privateDisplayBounds' put: r ]]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4323-set-privateDisplayBounds-JuanVuletich-2020Jul31-16h48m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4322] on 31 July 2020 at 4:53:32 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/31/2020 16:53:06' prior: 50532257! - displayBounds - "At time of last draw. nil if unknown." - - self visible ifFalse: [ ^nil ]. - ^ privateDisplayBounds! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/31/2020 16:53:12' prior: 50537867! - displayBounds: aRectangle - - self displayBounds ~= aRectangle ifTrue: [ - privateDisplayBounds _ aRectangle ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4324-use-privateDisplayBounds-JuanVuletich-2020Jul31-16h52m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4324] on 31 July 2020 at 5:00:35 pm'! -!Morph methodsFor: 'fileIn/out' stamp: 'jmv 7/31/2020 16:59:49' prior: 50537126 overrides: 16882034! - storeDataOn: aDataStream - "Let all Morphs be written out. All owners are weak references. They only go out if the owner is in the tree being written." - | cntInstVars cntIndexedVars ti instVarNames | - - "block my owner unless he is written out by someone else" - cntInstVars _ self class instSize. - cntIndexedVars _ self basicSize. - instVarNames _ self class allInstVarNames. - ti _ 1. - ((instVarNames at: ti) = 'owner') & (Morph superclass == Object) ifFalse: [ - self error: 'this method is out of date']. - aDataStream - beginInstance: self class - size: cntInstVars + cntIndexedVars. - 1 to: cntInstVars do: [ :i | - (instVarNames at: i) caseOf: { - ['owner'] -> [aDataStream nextPutWeak: owner]. "owner only written if in our tree" - ['id'] -> [ aDataStream nextPut: (id bitAnd: 255) ]. "Clear id, but keep flags." - } - otherwise: [ aDataStream nextPut: (self instVarAt: i)]]. - 1 to: cntIndexedVars do: [ :i | - aDataStream nextPut: (self basicAt: i)]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4325-Morph-copy-keepFlags-JuanVuletich-2020Jul31-16h59m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4325] on 1 August 2020 at 6:09:38 pm'! -!SystemWindow methodsFor: 'top window' stamp: 'jmv 8/1/2020 18:08:13' prior: 50534010! - activateAndSendTopToBack: aBoolean - "Bring me to the front and make me able to respond to mouse and keyboard" - - | oldTop | - owner - ifNil: [^self "avoid spurious activate when drop in trash"]. - oldTop _ TopWindow. - TopWindow _ self. - self redrawNeeded. - - oldTop ifNotNil: [ - oldTop redrawNeeded. - aBoolean ifTrue: [ - | bottomWindow | - bottomWindow _ oldTop owner submorphs reverse detect: [:one | one is: #SystemWindow]. - oldTop owner addMorph: oldTop behind: bottomWindow]]. - - owner firstSubmorph == self - ifFalse: [ - "Bring me to the top if not already" - owner addMorphFront: self]. - - "Set keyboard focus" - self world ifNotNil: [ :w | - w activeHand newKeyboardFocus: self submorphToFocusKeyboard ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4326-WindowRedrawOnFocusChange-JuanVuletich-2020Aug01-18h07m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4326] on 1 August 2020 at 6:37:52 pm'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/1/2020 18:33:03'! - updateHandsDisplayBounds: aPasteUpMorph addDamageTo: aDamageRecorder - "Update displayBounds for carried morphs if never set. - Useful for new morph, that are created and attached to the hand." - - aPasteUpMorph handsDo: [ :hand | - self into: hand. - hand submorphsDo: [ :morph | - self updateDisplayBounds: morph ]. - aDamageRecorder recordInvalidRect: hand displayFullBounds. - self outOfMorph ]! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 8/1/2020 18:30:18' prior: 50537436 overrides: 50534892! - displayFullBounds - "Current full bounds of hand and carried submorphs. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around)." - | fullBounds | - fullBounds _ self displayBounds. - self submorphsDo: [ :m | - fullBounds _ fullBounds quickMerge: m displayFullBounds]. - lastPosition - ifNotNil: [ :lastPos | "When already carrying morphs around. Include also the rectangle updated to current hand position." - fullBounds _ fullBounds quickMerge: (fullBounds translatedBy: self morphPosition-lastPos) ]. - ^fullBounds! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/1/2020 18:34:10' prior: 50537304! - drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rectsToRepair previousRectsToRepair reuse previousCount | - "Update #displayBounds for all dirty morphs (marked as such with #redrawNeeded). - Also add the updated bounds to aDamageRecorder." - self updatingMorphBoundsDo: [ - aPasteUpMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - self updateHandsDisplayBounds: aPasteUpMorph addDamageTo: aDamageRecorder ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ aDamageRecorder invalidRectsFullBounds: aPasteUpMorph viewBox. - - rectsToRepair size = 0 ifTrue: [ - ^rectsToRepair]. - - rectsToRepair size > 1 ifTrue: [ "Or there is no point in attempting to merge them!!" - previousRectsToRepair _ OrderedCollection new. - - "Until no more rectangles are merged, i.e. each morph intersects at most one rectangle." - previousCount _ 0. - [rectsToRepair size = previousCount] whileFalse: [ - previousCount _ rectsToRepair size. - aPasteUpMorph submorphsReverseDo: [ :morph | | thisMorphRectangle thisMorphBounds | - morph visible ifTrue: [ - reuse _ previousRectsToRepair. - previousRectsToRepair _ rectsToRepair. - rectsToRepair _ reuse removeAll. - thisMorphRectangle _ nil. - thisMorphBounds _ morph displayFullBounds. - previousRectsToRepair do: [ :r | - (thisMorphBounds intersects: r) - ifTrue: [ thisMorphRectangle _ r quickMerge: thisMorphRectangle ] - ifFalse: [ rectsToRepair add: r ]]. - thisMorphRectangle - ifNotNil: [rectsToRepair add: thisMorphRectangle]]]]. - ]. - - "Draw World" - rectsToRepair do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - "Repair rects. Draw morphs" - rectsToRepair do: [ :r | - self newClipRect: r. - aPasteUpMorph submorphsReverseDo: [ :morph | | morphBounds | - morph visible ifTrue: [ - morphBounds _ morph displayFullBounds. - (morphBounds intersects: r) ifTrue: [ - self fullDraw: morph ]]]]. - - ^ rectsToRepair! ! - -MorphicCanvas removeSelector: #updateHandsDisplayBounds:! - -!methodRemoval: MorphicCanvas #updateHandsDisplayBounds: stamp: 'Install-4327-FixHandDamageRect-JuanVuletich-2020Aug01-18h17m-jmv.001.cs.st 8/5/2020 22:22:58'! -updateHandsDisplayBounds: aPasteUpMorph - "Update displayBounds for carried morphs if never set. - Useful for new morph, that are created and attached to the hand." - - aPasteUpMorph handsDo: [ :hand | - self into: hand. - hand submorphsDo: [ :morph | - self updateDisplayBounds: morph ]. - self outOfMorph ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4327-FixHandDamageRect-JuanVuletich-2020Aug01-18h17m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4327] on 3 August 2020 at 10:29:34 am'! -!StringRequestMorph methodsFor: 'initialization' stamp: 'jmv 7/31/2020 21:32:04' prior: 50522997! - addTextPane - | result lineCount | - result _ (TextModelMorph - textProvider: self - textGetter: #response - textSetter: #response: - selectionGetter: #selectionInterval) emptyTextDisplayMessage: 'Enter response'. - self - valueOfProperty: #emptyTextDisplayMessage - ifPresentDo: [ :msg | - result emptyTextDisplayMessage: msg ]. - result - hasUnacceptedEdits: true; - acceptOnCR: true; - escAction: [ self cancel ]. - "If the initial response is big or has multiple lines we make the text pane bigger and with scrollbars:" - lineCount _ response lineCount. - lineCount > 1 - ifTrue: [result morphExtent: 40 @ (lineCount*2) * FontFamily defaultLineSpacing] - ifFalse: - [result hideScrollBarsIndefinitely; - morphExtent: response size @ 1 * FontFamily defaultLineSpacing + (0@8).]. - self addMorphBack: result. - ^ result.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4328-StringRequestMorph-MoreRoom-JuanVuletich-2020Aug03-10h28m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4327] on 3 August 2020 at 10:31:05 am'! -!Morph methodsFor: 'previewing' stamp: 'jmv 8/3/2020 10:30:35' prior: 50518368! - endPreview - - self previewing ifTrue: [ - owner notNil ifTrue: [ - self redrawNeeded. - self visible: self visibleBeforePreview. - owner addMorph: self inFrontOf: self morphBehindBeforePreview ]. - self previewing: false. ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4329-MinimizedWindowPreviewFix-JuanVuletich-2020Aug03-10h29m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4329] on 3 August 2020 at 2:34:23 pm'! -!PluggableListMorph methodsFor: 'events' stamp: 'jmv 8/3/2020 14:31:56' prior: 50437020 overrides: 16874501! - dragEvent: aMouseEvent localPosition: localEventPosition - - | row dragged listItem sm | - self listMorph highlightedRow: nil. - row _ self rowAtLocation: localEventPosition ifNone: [ ^self ]. - listItem _ self getListItem: row. - - sm _ StringMorph contents: listItem. - dragged _ DraggingGuideMorph new. - dragged addMorph: sm. - dragged morphExtent: sm morphExtent. - dragged setProperty: #dragSource toValue: self. - dragged setProperty: #dropSelectorArgument toValue: listItem. - - aMouseEvent hand attachMorphBeside: dragged.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4330-DragAndDropFix-JuanVuletich-2020Aug03-14h22m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4330] on 3 August 2020 at 5:01:25 pm'! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'jmv 8/3/2020 16:59:07'! - canAdd: aMorph - self world ifNotNil: [ :w | - ^w canHandle: aMorph ]. - ^true! ! -!PasteUpMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 8/3/2020 16:58:11'! - canHandle: aMorph - ^self canvas canDraw: aMorph! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 8/3/2020 16:57:53'! - canDraw: aMorph - ^true! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 8/3/2020 16:58:06' overrides: 50538216! - canDraw: aMorph - ^aMorph requiresVectorCanvas not! ! -!Morph methodsFor: 'private' stamp: 'jmv 8/3/2020 17:01:17' prior: 16877049! - privateAddAllMorphs: aCollection atIndex: index - "Private. Add aCollection of morphs to the receiver" - | myWorld itsWorld otherSubmorphs | - (aCollection allSatisfy: [ :m | self canAdd: m]) ifFalse: [ - ^self error: 'We can''t add requested morph. Maybe install and activate VectorGraphics canvas.' ]. - myWorld _ self world. - otherSubmorphs _ submorphs copyWithoutAll: aCollection. - (index between: 0 and: otherSubmorphs size) - ifFalse: [^ self error: 'index out of range']. - index = 0 - ifTrue:[ submorphs _ aCollection asArray, otherSubmorphs] - ifFalse:[ index = otherSubmorphs size - ifTrue:[ submorphs _ otherSubmorphs, aCollection] - ifFalse:[ submorphs _ otherSubmorphs copyReplaceFrom: index + 1 to: index with: aCollection ]]. - aCollection do: [:m | | itsOwner | - itsOwner _ m owner. - itsOwner ifNotNil: [ - itsWorld _ m world. - (itsWorld == myWorld) ifFalse: [ - itsWorld ifNotNil: [m redrawNeeded]]. - (itsOwner ~~ self) ifTrue: [ - m owner privateRemove: m. - m owner removedMorph: m ]]. - m privateOwner: self. - myWorld ifNotNil: [m redrawNeeded]. - (myWorld == itsWorld) ifFalse: [m intoWorld: myWorld]. - itsOwner == self ifFalse: [ - self addedMorph: m. - m noteNewOwner: self ]. - ]. - self someSubmorphPositionOrExtentChanged! ! -!Morph methodsFor: 'private' stamp: 'jmv 8/3/2020 17:00:36' prior: 16877086! - privateAddMorph: aMorph atIndex: index - - | oldIndex myWorld itsWorld oldOwner | - (self canAdd: aMorph) ifFalse: [ - ^self error: 'We can''t add requested morph. Maybe install and activate VectorGraphics canvas.' ]. - ((index >= 1) and: [index <= (submorphs size + 1)]) - ifFalse: [^ self error: 'index out of range']. - myWorld _ self world. - oldOwner _ aMorph owner. - (oldOwner == self and: [(oldIndex _ submorphs indexOf: aMorph) > 0]) ifTrue:[ - "aMorph's position changes within in the submorph chain" - oldIndex < index ifTrue:[ - "moving aMorph to back" - submorphs replaceFrom: oldIndex to: index-2 with: submorphs startingAt: oldIndex+1. - submorphs at: index-1 put: aMorph. - ] ifFalse:[ - "moving aMorph to front" - oldIndex-1 to: index by: -1 do:[:i| - submorphs at: i+1 put: (submorphs at: i)]. - submorphs at: index put: aMorph. - ]. - ] ifFalse:[ - "adding a new morph" - oldOwner ifNotNil:[ - itsWorld _ aMorph world. - itsWorld ifNotNil: [aMorph redrawNeeded]. - oldOwner privateRemove: aMorph. - oldOwner removedMorph: aMorph. - ]. - aMorph privateOwner: self. - submorphs _ submorphs copyReplaceFrom: index to: index-1 with: (Array with: aMorph). - (itsWorld == myWorld) ifFalse: [aMorph intoWorld: myWorld]. - ]. - myWorld ifNotNil:[aMorph redrawNeeded]. - self someSubmorphPositionOrExtentChanged. - oldOwner == self ifFalse: [ - self addedMorph: aMorph. - aMorph noteNewOwner: self ]. -! ! -!Morph methodsFor: 'private' stamp: 'jmv 8/3/2020 17:00:40' prior: 16877128! - privateAddMorph: aMorph atIndex: index position: aPoint - - | oldIndex myWorld itsWorld oldOwner | - (self canAdd: aMorph) ifFalse: [ - ^self error: 'We can''t add requested morph. Maybe install and activate VectorGraphics canvas.' ]. - ((index >= 1) and: [index <= (submorphs size + 1)]) - ifFalse: [^ self error: 'index out of range']. - myWorld _ self world. - oldOwner _ aMorph owner. - (oldOwner == self and: [(oldIndex _ submorphs indexOf: aMorph) > 0]) ifTrue: [ - "aMorph's position changes within in the submorph chain" - oldIndex < index ifTrue:[ - "moving aMorph to back" - submorphs replaceFrom: oldIndex to: index-2 with: submorphs startingAt: oldIndex+1. - submorphs at: index-1 put: aMorph. - ] ifFalse:[ - "moving aMorph to front" - oldIndex-1 to: index by: -1 do:[:i| - submorphs at: i+1 put: (submorphs at: i)]. - submorphs at: index put: aMorph. - ]. - aMorph privatePosition: aPoint. - ] ifFalse: [ - "adding a new morph" - oldOwner ifNotNil: [ - itsWorld _ aMorph world. - itsWorld ifNotNil: [aMorph redrawNeeded]. - oldOwner privateRemove: aMorph. - oldOwner removedMorph: aMorph. - ]. - aMorph privateOwner: self. - submorphs _ submorphs copyReplaceFrom: index to: index-1 with: (Array with: aMorph). - aMorph privatePosition: aPoint. - (itsWorld == myWorld) ifFalse: [aMorph intoWorld: myWorld]. - ]. - myWorld ifNotNil: [aMorph redrawNeeded]. - self someSubmorphPositionOrExtentChanged. - oldOwner == self ifFalse: [ - self addedMorph: aMorph. - aMorph noteNewOwner: self ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4331-FailGracefullyIfNoVGSupport-JuanVuletich-2020Aug03-16h54m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4330] on 3 August 2020 at 5:30:57 pm'! -!Color class methodsFor: 'instance creation' stamp: 'jmv 8/3/2020 17:30:42' prior: 50389457! - fromHexString: aString - "For HTML color spec: #FFCCAA. - See http://www.w3schools.com/cssref/css_colors_legal.asp - Also handles 3 digit shorthand." - " - Color fromHexString: '#FFCCAA'. - " - (aString size = 7 and: [ aString first = $# ]) ifTrue: [ - | aColorHexU red green blue | - aColorHexU _ aString asUppercase. - red _ ('16r', (aColorHexU copyFrom: 2 to: 3)) asNumber/255. - green _ ('16r', (aColorHexU copyFrom: 4 to: 5)) asNumber/255. - blue _ ('16r', (aColorHexU copyFrom: 6 to: 7)) asNumber/255. - ^ self r: red g: green b: blue]. - (aString size = 4 and: [ aString first = $# ]) ifTrue: [ - | aColorHexU red green blue | - aColorHexU _ aString asUppercase. - red _ aColorHexU at: 2. - green _ aColorHexU at: 3. - blue _ aColorHexU at: 4. - red _ ('16r', (String with: red with: red)) asNumber/255. - green _ ('16r', (String with: green with: green)) asNumber/255. - blue _ ('16r', (String with: blue with: blue)) asNumber/255. - ^ self r: red g: green b: blue]. - ^ nil! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4332-Color-fromHex-enh-JuanVuletich-2020Aug03-17h30m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4332] on 3 August 2020 at 7:04:29 pm'! -!FontFamily methodsFor: 'testing' stamp: 'jmv 8/3/2020 19:00:28'! - isTrueTypeFontFamily - ^false! ! -!FontFamily class methodsFor: 'accessing fonts' stamp: 'jmv 8/3/2020 19:01:01'! - defaultOrTrueTypeFamilyAndPointSize - " - FontFamily defaultOrTrueTypeFamilyAndPointSize - " - | family | - family _ AvailableFamilies at: DefaultFamilyName. - family isTrueTypeFontFamily ifFalse: [ - family _ AvailableFamilies detect: [ :any | any isTrueTypeFontFamily ] ifNone: [ ^nil ]]. - ^family atPointSize: DefaultPointSize ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4333-DefaultTrueType-JuanVuletich-2020Aug03-19h00m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4333] on 4 August 2020 at 10:32:23 am'! - -Object subclass: #DamageRecorder - instanceVariableNames: 'invalidRects totalRepaint drSemaphore damageByRoot ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #DamageRecorder category: #'Morphic-Support' stamp: 'Install-4334-DamageRecorder-redesign-JuanVuletich-2020Aug04-09h10m-jmv.002.cs.st 8/5/2020 22:22:59'! -Object subclass: #DamageRecorder - instanceVariableNames: 'invalidRects totalRepaint drSemaphore damageByRoot' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! -!Morph methodsFor: 'change reporting' stamp: 'jmv 8/4/2020 10:04:10'! - invalidateDisplayRect: damageRect fromSubmorph: submorphOrNil for: aMorph - "If we clip aMorph, then we clip damageRect. - When calling from self, second argument should be nil, i.e. we are not reporting damage for some submorph." - - | clippedRect b | - - "warning. Senders are using global coordinates. Redesign!!" - "local now!!!!!!!!!!" - self flag: #jmvVer2. "ok?" - - self visible ifFalse: [ ^self]. - - clippedRect _ damageRect. - submorphOrNil ifNotNil: [ - submorphOrNil == self clippedSubmorph - ifTrue: [ - b _ self displayBounds. - b ifNil: [ ^self ]. - clippedRect _ damageRect intersect: b ]]. - owner ifNotNil: [ - owner invalidateDisplayRect: clippedRect fromSubmorph: self for: aMorph ]! ! -!PasteUpMorph methodsFor: 'change reporting' stamp: 'jmv 8/4/2020 10:05:54' overrides: 50538453! - invalidateDisplayRect: damageRect fromSubmorph: submorphOrNil for: aMorph - "Clip damage reports to my bounds, since drawing is _always_ clipped to my bounds." - - self == self world - ifTrue: [ worldState recordDamagedRect: (damageRect intersect: self morphLocalBounds ) for: aMorph ] - ifFalse: [ super invalidateDisplayRect: damageRect fromSubmorph: submorphOrNil for: aMorph ]! ! -!WorldState methodsFor: 'canvas' stamp: 'jmv 8/4/2020 10:02:25'! - recordDamagedRect: damageRect for: aMorph - - damageRecorder ifNotNil: [ - damageRecorder recordInvalidRect: damageRect for: aMorph ]! ! -!DamageRecorder methodsFor: 'recording' stamp: 'jmv 8/4/2020 10:29:51'! - recordInvalidRect: requestedRect for: aMorph - "aRootMorph should be #root" - - ^ self pvtAccessProtect critical: [ - self pvtInnerRecordInvalidRect: requestedRect for: (aMorph ifNotNil: [aMorph root]) ]! ! -!DamageRecorder methodsFor: 'private' stamp: 'jmv 8/4/2020 10:30:38'! - pvtInnerRecordInvalidRect: requestedRect for: aRootMorph - "Record the given rectangle in my damage list, a list of rectangular areas of the display that should be redraw on the next display cycle. - Rectangles are specified in world coordinates (might be not the same as Display coordinates if there is some origin set on some canvas. Usually there will be none, but we can't be sure) - aRootMorph is the top owner of the morph originally reporting requestedRect. It might be nil if irrelevant. - " - "Details: Damaged rectangles are often identical or overlap significantly. In these cases, we merge them to reduce the number of damage rectangles that must be processed when the display is updated. Moreover, above a certain threshold, we ignore the individual rectangles completely, and simply do a complete repaint on the next cycle. - jmv: Important. There should be no overlapping rectangles in the list. If there are, translucent morphs might be drawn several times, with visible defects. - WRT performance, the different paths for various intersections seem a bit complicated. I could not find strong evidence of the best way. - Leave it as it is right now." - | newRect mergeRect indexToReuse oc | - totalRepaint ifTrue: [ ^ self ]. - "planning full repaint; don't bother collecting damage" - indexToReuse _ nil. - newRect _ requestedRect encompassingIntegerRectangle. - aRootMorph ifNotNil: [ - oc _ damageByRoot at: aRootMorph ifAbsentPut: [OrderedCollection new]. - oc add: newRect ]. - invalidRects withIndexDo: [ :oldRect :index | - oldRect - ifNil: [ indexToReuse ifNil: [ indexToReuse _ index ]] - ifNotNil: [ - "No two rectangles should intersect" - (oldRect intersects: newRect) ifTrue: [ - "newRect already in. Nothing to do then." - (oldRect containsRect: newRect) ifTrue: [ ^ self ]. - "Some oldRect included in newRect. Remove it and continue, as newRect could still intersect others." - (newRect containsRect: oldRect) ifTrue: [ - invalidRects - at: index - put: nil. - "Effectively like 'invalidRects remove: rect', but without performance penalty." - indexToReuse ifNil: [ indexToReuse _ index ]]. - "Merge rectangles if they overlap significantly, i.e. if the merge is not much larger than separated rectangles." - mergeRect _ (oldRect origin min: newRect origin) corner: (oldRect corner max: newRect corner). - mergeRect area > (newRect area + oldRect area * 2) - ifTrue: [ - "Avoid intersections!!" - newRect - areasOutside: oldRect - do: [ :nonIntersection | - "We have brand new newRects. Start all over with each of them." - self pvtInnerRecordInvalidRect: nonIntersection for: nil ]. - "newRect no longer needed, then." - ^ self ] - ifFalse: [ - "Merge into newRect, as any overlap with forecoming rectangles in the iteration is detected and treated." - newRect _ mergeRect. - invalidRects - at: index - put: nil. - "Effectively like 'invalidRects remove: rect', but without performance penalty." - indexToReuse ifNil: [ indexToReuse _ index ]]]]]. - invalidRects size >= 10 ifTrue: [ - "if there are too many separate areas, merge them all" - mergeRect _ Rectangle merging: invalidRects. - invalidRects removeAll. - mergeRect ifNotNil: [ invalidRects addLast: mergeRect ]. - indexToReuse _ nil ]. - "Add the given rectangle to the damage list" - indexToReuse - ifNil: [ invalidRects addLast: newRect ] - ifNotNil: [ - invalidRects - at: indexToReuse - put: newRect ].! ! -!Morph methodsFor: 'change reporting' stamp: 'jmv 8/4/2020 10:07:09' prior: 50535550! - invalidateLocalRect: localRectangle - - self invalidateDisplayRect: (self externalizeDisplayBounds: localRectangle) fromSubmorph: nil for: self! ! -!Morph methodsFor: 'updating' stamp: 'jmv 8/4/2020 10:07:29' prior: 50537675! - redrawNeeded - "Report that the area occupied by this morph should be redrawn." - - self needsRedraw: true. - self allOwnersDo: [ :m | m submorphNeedsRedraw: true ]. - self invalidateDisplayRect: self displayBoundsOrBogus fromSubmorph: nil for: nil. - self submorphsDrawingOutsideReverseDo: [ :m | m redrawNeeded ]! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 8/4/2020 10:06:52' prior: 50536252! - restoreSavedPatchOn: aCanvas - "Clear the changed flag and restore the part of the given canvas under this hand from the previously saved patch. If necessary, handle the transition to using the hardware cursor." - hasChanged _ false. - savedPatch ifNotNil: [ - aCanvas restorePatch: savedPatch. - submorphs notEmpty ifTrue: [ ^ self ]. - "Make the transition to using hardware cursor. Clear savedPatch and - report one final damage rectangle to erase the image of the software cursor." - " owner invalidateDisplayRect: (savedPatch offset extent: savedPatch extent) from: nil." - self - invalidateDisplayRect: (self morphPosition extent: extent) - fromSubmorph: nil - for: nil. - Cursor currentCursor == Cursor defaultCursor ifFalse: [ Cursor defaultCursor activateCursor ]. - "show hardware cursor" - savedPatch _ nil ].! ! -!HandMorph methodsFor: 'initialization' stamp: 'jmv 8/4/2020 10:15:10' prior: 50471117 overrides: 50384228! - initialize - super initialize. - self initForEvents. - keyboardFocus _ nil. - mouseFocus _ nil. - extent _ CursorWithMask defaultCursor extent. - grabMorphData _ IdentityDictionary new. - self initForEvents.! ! -!DamageRecorder methodsFor: 'initialization' stamp: 'jmv 8/4/2020 10:21:05' prior: 50462499 overrides: 16896425! - initialize - super initialize . - invalidRects _ OrderedCollection new: 15. - totalRepaint _ false. - damageByRoot _ IdentityDictionary new! ! -!DamageRecorder methodsFor: 'recording' stamp: 'jmv 8/4/2020 09:10:22' prior: 50535938! - invalidRectsFullBounds: aRectangle - "Return a collection of damaged rectangles for the given canvas. Take only intersection with aRectangle. - If a total repaint has been requested, return the given rectangle. - Forget about all damage." - | answer | - answer _ totalRepaint ifTrue: [ Array with: aRectangle ]. - self pvtAccessProtect critical: [ - answer ifNil: [ - answer _ OrderedCollection new. - invalidRects do: [ :r | - r ifNotNil: [ - (aRectangle containsRect: r) - ifTrue: [ answer add: r ] - ifFalse: [ answer add: (r intersect: aRectangle) ]. - ]]]. - self pvtReset ]. - ^ answer.! ! -!DamageRecorder methodsFor: 'private' stamp: 'jmv 8/4/2020 10:21:17' prior: 50462614! - pvtReset - "Clear the damage list." - invalidRects removeAll. - totalRepaint _ false. - damageByRoot removeAll.! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/4/2020 10:01:36' prior: 50537758! - fullAddCurrentRect: addCurrentBounds submorphs: trySubmorphs to: aDamageRecorder - | currentMorphBounds | - addCurrentBounds ifTrue: [ - currentMorph needsRedraw: false. - currentMorph drawOn: self. - currentMorphBounds _ self boundingRectOfCurrentMorphAfterDraw. - currentMorph displayBounds: currentMorphBounds. - aDamageRecorder recordInvalidRect: currentMorphBounds for: currentMorph. - currentMorph submorphsDo: [ :m | self fullUpdateBounds: m ]. - ]. - trySubmorphs ifTrue: [ - currentMorph submorphNeedsRedraw: false. - currentMorph clippedSubmorph ifNotNil: [ :clipped | - self clippingByCurrentMorphDo: [ self fullAddRedrawRect: clipped to: aDamageRecorder ]]. - currentMorph unclippedSubmorphsReverseDo: [ :m | - self fullAddRedrawRect: m to: aDamageRecorder ] - ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/4/2020 09:55:53' prior: 50537991! - updateHandsDisplayBounds: aPasteUpMorph addDamageTo: aDamageRecorder - "Update displayBounds for carried morphs if never set. - Useful for new morph, that are created and attached to the hand." - - aPasteUpMorph handsDo: [ :hand | - self into: hand. - hand submorphsDo: [ :morph | - self updateDisplayBounds: morph ]. - aDamageRecorder recordInvalidRect: hand displayFullBounds for: nil. - self outOfMorph ]! ! - -DamageRecorder removeSelector: #recordInvalidRect:from:! - -DamageRecorder removeSelector: #pvtInnerRecordInvalidRect:! - -!methodRemoval: DamageRecorder #pvtInnerRecordInvalidRect: stamp: 'Install-4334-DamageRecorder-redesign-JuanVuletich-2020Aug04-09h10m-jmv.002.cs.st 8/5/2020 22:22:59'! -pvtInnerRecordInvalidRect: requestedRect - "Record the given rectangle in my damage list, a list of rectangular areas of the display that should be redraw on the next display cycle. - Rectangles are specified in world coordinates (might be not the same as Display coordinates if there is some origin set on some canvas. Usually there will be none, but we can't be sure) - " - "Details: Damaged rectangles are often identical or overlap significantly. In these cases, we merge them to reduce the number of damage rectangles that must be processed when the display is updated. Moreover, above a certain threshold, we ignore the individual rectangles completely, and simply do a complete repaint on the next cycle. - jmv: Important. There should be no overlapping rectangles in the list. If there are, translucent morphs might be drawn several times, with visible defects. - WRT performance, the different paths for various intersections seem a bit complicated. I could not find strong evidence of the best way. - Leave it as it is right now." - | newRect mergeRect indexToReuse | - totalRepaint ifTrue: [ ^ self ]. - "planning full repaint; don't bother collecting damage" - indexToReuse _ nil. - newRect _ requestedRect encompassingIntegerRectangle. - invalidRects withIndexDo: [ :oldRect :index | - oldRect - ifNil: [ indexToReuse ifNil: [ indexToReuse _ index ]] - ifNotNil: [ - "No two rectangles should intersect" - (oldRect intersects: newRect) ifTrue: [ - "newRect already in. Nothing to do then." - (oldRect containsRect: newRect) ifTrue: [ ^ self ]. - "Some oldRect included in newRect. Remove it and continue, as newRect could still intersect others." - (newRect containsRect: oldRect) ifTrue: [ - invalidRects - at: index - put: nil. - "Effectively like 'invalidRects remove: rect', but without performance penalty." - indexToReuse ifNil: [ indexToReuse _ index ]]. - "Merge rectangles if they overlap significantly, i.e. if the merge is not much larger than separated rectangles." - mergeRect _ (oldRect origin min: newRect origin) corner: (oldRect corner max: newRect corner). - mergeRect area > (newRect area + oldRect area * 2) - ifTrue: [ - "Avoid intersections!!" - newRect - areasOutside: oldRect - do: [ :nonIntersection | - "We have brand new newRects. Start all over with each of them." - self pvtInnerRecordInvalidRect: nonIntersection ]. - "newRect no longer needed, then." - ^ self ] - ifFalse: [ - "Merge into newRect, as any overlap with forecoming rectangles in the iteration is detected and treated." - newRect _ mergeRect. - invalidRects - at: index - put: nil. - "Effectively like 'invalidRects remove: rect', but without performance penalty." - indexToReuse ifNil: [ indexToReuse _ index ]]]]]. - invalidRects size >= 10 ifTrue: [ - "if there are too many separate areas, merge them all" - mergeRect _ Rectangle merging: invalidRects. - self pvtReset. - mergeRect ifNotNil: [ invalidRects addLast: mergeRect ]. - indexToReuse _ nil ]. - "Add the given rectangle to the damage list" - indexToReuse - ifNil: [ invalidRects addLast: newRect ] - ifNotNil: [ - invalidRects - at: indexToReuse - put: newRect ].! - -DamageRecorder removeSelector: #recordInvalidRect:! - -!methodRemoval: DamageRecorder #recordInvalidRect: stamp: 'Install-4334-DamageRecorder-redesign-JuanVuletich-2020Aug04-09h10m-jmv.002.cs.st 8/5/2020 22:22:59'! -recordInvalidRect: requestedRect - ^ self pvtAccessProtect critical: [ self pvtInnerRecordInvalidRect: requestedRect ]! - -DamageRecorder removeSelector: #pvtInnerRecordInvalidRect:from:! - -WorldState removeSelector: #recordDamagedRect:! - -!methodRemoval: WorldState #recordDamagedRect: stamp: 'Install-4334-DamageRecorder-redesign-JuanVuletich-2020Aug04-09h10m-jmv.002.cs.st 8/5/2020 22:22:59'! -recordDamagedRect: damageRect - - damageRecorder ifNotNil: [damageRecorder recordInvalidRect: damageRect] -! - -WorldState removeSelector: #recordDamagedRect:from:! - -PasteUpMorph removeSelector: #invalidateDisplayRect:from:! - -!methodRemoval: PasteUpMorph #invalidateDisplayRect:from: stamp: 'Install-4334-DamageRecorder-redesign-JuanVuletich-2020Aug04-09h10m-jmv.002.cs.st 8/5/2020 22:22:59'! -invalidateDisplayRect: damageRect from: aMorph - "Clip damage reports to my bounds, since drawing is clipped to my bounds." - - self == self world - ifTrue: [ worldState recordDamagedRect: (damageRect intersect: self morphLocalBounds ) ] - ifFalse: [ super invalidateDisplayRect: damageRect from: aMorph ]! - -PasteUpMorph removeSelector: #invalidateDisplayRect:fromSubmorph:! - -Morph removeSelector: #invalidateDisplayRect:from:! - -!methodRemoval: Morph #invalidateDisplayRect:from: stamp: 'Install-4334-DamageRecorder-redesign-JuanVuletich-2020Aug04-09h10m-jmv.002.cs.st 8/5/2020 22:22:59'! -invalidateDisplayRect: damageRect from: aMorph - - | clippedRect b | - - "warning. Senders are using global coordinates. Redesign!!" - "local now!!!!!!!!!!" - self flag: #jmvVer2. "ok?" - - self visible ifFalse: [ ^self]. - - clippedRect _ damageRect. - aMorph ifNotNil: [ - aMorph == self clippedSubmorph - ifTrue: [ - b _ self displayBounds. - b ifNil: [ ^self ]. - clippedRect _ damageRect intersect: b ]]. - owner ifNotNil: [ - owner invalidateDisplayRect: clippedRect from: self ]! - -Morph removeSelector: #invalidateDisplayRect:fromSubmorph:! - -Object subclass: #DamageRecorder - instanceVariableNames: 'invalidRects totalRepaint drSemaphore damageByRoot' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #DamageRecorder category: #'Morphic-Support' stamp: 'Install-4334-DamageRecorder-redesign-JuanVuletich-2020Aug04-09h10m-jmv.002.cs.st 8/5/2020 22:22:59'! -Object subclass: #DamageRecorder - instanceVariableNames: 'invalidRects totalRepaint drSemaphore damageByRoot' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -DamageRecorder allSubInstancesDo: [ :dr | dr instVarNamed: 'damageByRoot' put: IdentityDictionary new ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4334-DamageRecorder-redesign-JuanVuletich-2020Aug04-09h10m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4334] on 4 August 2020 at 7:30:06 pm'! -!DamageRecorder methodsFor: 'recording' stamp: 'jmv 8/4/2020 10:52:52'! - damageReportedFor: aMorph - ^ self pvtAccessProtect critical: [ damageByRoot at: aMorph ifAbsent: nil ]! ! -!DamageRecorder methodsFor: 'recording' stamp: 'jmv 8/4/2020 17:09:22'! - damageReportedNotVisibleMorphs - | answer | - answer _ OrderedCollection new. - self pvtAccessProtect critical: [ - damageByRoot keysAndValuesDo: [ :m :r | - (m visible not or: [m owner isNil]) ifTrue: [ - answer add: r]]]. - ^answer! ! -!Morph methodsFor: 'updating' stamp: 'jmv 8/4/2020 17:12:13' prior: 50538631! - redrawNeeded - "Report that the area occupied by this morph should be redrawn." - - self needsRedraw: true. - self allOwnersDo: [ :m | m submorphNeedsRedraw: true ]. - self invalidateDisplayRect: self displayBoundsOrBogus fromSubmorph: nil for: self. - self submorphsDrawingOutsideReverseDo: [ :m | m redrawNeeded ]! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 8/4/2020 15:13:36' prior: 50538644! - restoreSavedPatchOn: aCanvas - "Clear the changed flag and restore the part of the given canvas under this hand from the previously saved patch. If necessary, handle the transition to using the hardware cursor." - hasChanged _ false. - savedPatch ifNotNil: [ - aCanvas restorePatch: savedPatch. - submorphs notEmpty ifTrue: [ ^ self ]. - "Make the transition to using hardware cursor. Clear savedPatch and - report one final damage rectangle to erase the image of the software cursor." - " owner invalidateDisplayRect: (savedPatch offset extent: savedPatch extent) from: nil." - self - invalidateDisplayRect: (self morphPosition extent: extent) - fromSubmorph: nil - for: self. - Cursor currentCursor == Cursor defaultCursor ifFalse: [ Cursor defaultCursor activateCursor ]. - "show hardware cursor" - savedPatch _ nil ].! ! -!DamageRecorder methodsFor: 'testing' stamp: 'jmv 8/4/2020 15:10:59' prior: 50462802! - updateIsNeeded - "Return true if the display needs to be updated. - Note: This could give a false positive (i.e. answer true) if invalidRects is not empty but it only contains nils. - Senders should be aware of this." - ^ totalRepaint or: [ self pvtAccessProtect critical: [damageByRoot notEmpty or: [invalidRects notEmpty]] ].! ! -!DamageRecorder methodsFor: 'private' stamp: 'jmv 8/4/2020 15:17:45' prior: 50538510! - pvtInnerRecordInvalidRect: requestedRect for: aRootMorph - "Record the given rectangle in my damage list, a list of rectangular areas of the display that should be redraw on the next display cycle. - Rectangles are specified in world coordinates (might be not the same as Display coordinates if there is some origin set on some canvas. Usually there will be none, but we can't be sure) - aRootMorph is the top owner of the morph originally reporting requestedRect. It might be nil if irrelevant. - " - "Details: Damaged rectangles are often identical or overlap significantly. In these cases, we merge them to reduce the number of damage rectangles that must be processed when the display is updated. Moreover, above a certain threshold, we ignore the individual rectangles completely, and simply do a complete repaint on the next cycle. - jmv: Important. There should be no overlapping rectangles in the list. If there are, translucent morphs might be drawn several times, with visible defects. - WRT performance, the different paths for various intersections seem a bit complicated. I could not find strong evidence of the best way. - Leave it as it is right now." - | newRect mergeRect indexToReuse | - totalRepaint ifTrue: [ ^ self ]. - "planning full repaint; don't bother collecting damage" - indexToReuse _ nil. - newRect _ requestedRect encompassingIntegerRectangle. -"En el futuro no va a poder ser nil" - aRootMorph ifNotNil: [ - damageByRoot at: aRootMorph put: - (damageByRoot at: aRootMorph - ifPresent: [:r | r quickMerge: newRect] - ifAbsent:[newRect]) ]. - invalidRects withIndexDo: [ :oldRect :index | - oldRect - ifNil: [ indexToReuse ifNil: [ indexToReuse _ index ]] - ifNotNil: [ - "No two rectangles should intersect" - (oldRect intersects: newRect) ifTrue: [ - "newRect already in. Nothing to do then." - (oldRect containsRect: newRect) ifTrue: [ ^ self ]. - "Some oldRect included in newRect. Remove it and continue, as newRect could still intersect others." - (newRect containsRect: oldRect) ifTrue: [ - invalidRects - at: index - put: nil. - "Effectively like 'invalidRects remove: rect', but without performance penalty." - indexToReuse ifNil: [ indexToReuse _ index ]]. - "Merge rectangles if they overlap significantly, i.e. if the merge is not much larger than separated rectangles." - mergeRect _ (oldRect origin min: newRect origin) corner: (oldRect corner max: newRect corner). - mergeRect area > (newRect area + oldRect area * 2) - ifTrue: [ - "Avoid intersections!!" - newRect - areasOutside: oldRect - do: [ :nonIntersection | - "We have brand new newRects. Start all over with each of them." - self pvtInnerRecordInvalidRect: nonIntersection for: nil ]. - "newRect no longer needed, then." - ^ self ] - ifFalse: [ - "Merge into newRect, as any overlap with forecoming rectangles in the iteration is detected and treated." - newRect _ mergeRect. - invalidRects - at: index - put: nil. - "Effectively like 'invalidRects remove: rect', but without performance penalty." - indexToReuse ifNil: [ indexToReuse _ index ]]]]]. - invalidRects size >= 10 ifTrue: [ - "if there are too many separate areas, merge them all" - mergeRect _ Rectangle merging: invalidRects. - invalidRects removeAll. - mergeRect ifNotNil: [ invalidRects addLast: mergeRect ]. - indexToReuse _ nil ]. - "Add the given rectangle to the damage list" - indexToReuse - ifNil: [ invalidRects addLast: newRect ] - ifNotNil: [ - invalidRects - at: indexToReuse - put: newRect ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/4/2020 15:12:44' prior: 50538749! - updateHandsDisplayBounds: aPasteUpMorph addDamageTo: aDamageRecorder - "Update displayBounds for carried morphs if never set. - Useful for new morph, that are created and attached to the hand." - - aPasteUpMorph handsDo: [ :hand | - self into: hand. - hand submorphsDo: [ :morph | - self updateDisplayBounds: morph ]. - aDamageRecorder recordInvalidRect: hand displayFullBounds for: hand. - self outOfMorph ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4335-DamageRecorder-redesign-JuanVuletich-2020Aug04-19h27m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4335] on 5 August 2020 at 12:10:32 am'! -!Morph methodsFor: 'drawing' stamp: 'jmv 8/4/2020 11:10:14'! - addPossiblyUncoveredAreasIn: aRectangle to: aCollection - "Answer an array of rectangles encompassing those areas in aRectangle not completely - covered by self. - All areas that might possibly be uncovered must be included." - " CREO QUE NO, que me conformo con optimizar ventanas. O quizas RectangleLike. Ver."" - (self isOrthoRectangularMorph and: [ self isOpaqueMorph ]) ifTrue: [ - aRectangle areasOutside: self morphBoundsInWorld do: [ :r | aCollection add: r ]. - ^self ]. - " - aCollection add: aRectangle! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 8/4/2020 11:09:53' overrides: 50539190! - addPossiblyUncoveredAreasIn: aRectangle to: aCollection - "Answer an array of rectangles encompassing those areas in aRectangle not completely - covered by self. These are the areas that might require further drawing (of morphs below us) - All areas that might possibly be uncovered must be included." - | bounds radious | - color mightBeTranslucent ifTrue: [ - aCollection add: aRectangle. - ^self ]. - - bounds _ self displayBounds. - bounds ifNil: [ - aCollection add: aRectangle. - ^self ]. - - "Solid rectangle. - This will be the fastest in many cases. So, please disable rounded corners if on slow hardware!!" - Theme current roundWindowCorners ifFalse: [ - aRectangle areasOutside: bounds do: [ :rect | aCollection add: rect ]. - ^self ]. - - "The solid rectangle does not include the corners. - Report a couple of rows (top and bottom) or columns (left and right) as uncovered areas. - We could also try to be more careful and answer each rounded corner... - Right now, report top and bottom rows as uncovered areas" - radious _ Theme current roundedWindowRadius. - aRectangle areasOutside: (bounds insetBy: 0@radious) do: [ :rect | aCollection add: rect ]! ! -!DamageRecorder methodsFor: 'recording' stamp: 'jmv 8/4/2020 22:07:50'! - damageReportedNotVisibleAndCarriedByHand - | answer | - answer _ OrderedCollection new. - self pvtAccessProtect critical: [ - damageByRoot keysAndValuesDo: [ :m :r | - (m visible not or: [m owner isNil or: [m owner is: #HandMorph]]) ifTrue: [ - answer add: r]]]. - ^answer! ! -!DamageRecorder methodsFor: 'recording' stamp: 'jmv 8/4/2020 19:33:01'! - reset - self pvtAccessProtect critical: [ - self pvtReset ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/4/2020 21:40:28'! - updateHandsDisplayBounds: aPasteUpMorph - "Update displayBounds for carried morphs if never set. - Useful for new morph, that are created and attached to the hand." - - aPasteUpMorph handsDo: [ :hand | - hand hasSubmorphs ifTrue: [ - self into: hand. - hand submorphsDo: [ :morph | - self updateDisplayBounds: morph ]. - self outOfMorph ]]! ! -!DisplayScreen methodsFor: 'displaying' stamp: 'jmv 8/4/2020 21:44:28' prior: 16835136! - flash: aRectangle - "Flash the area of the screen defined by the given rectangle." - - self reverse: aRectangle. - self forceToScreen: aRectangle. - (Delay forMilliseconds: 100) wait. - self reverse: aRectangle. - self forceToScreen: aRectangle. - (Delay forMilliseconds: 100) wait.! ! -!TranscriptWindow class methodsFor: 'GUI building' stamp: 'jmv 8/4/2020 20:45:45' prior: 50470320! - openTranscript - " - TranscriptWindow openTranscript - " - | win m | - win _ TranscriptWindow new. - win - setLabel: 'Transcript'; - model: Transcript. - m _ TranscriptMorph new. - win layoutMorph addMorph: m proportionalHeight: 1. - win model when: #redraw send: #redrawNeeded to: m. - ^ win openInWorld. -! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/4/2020 22:07:58' prior: 50538029! - drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rootMorphs rootMorphsDamage allDamage | - "Update #displayBounds for all dirty morphs (marked as such with #redrawNeeded). - Also add the updated bounds to aDamageRecorder, and update bounds of morphs carried by hand." - self updatingMorphBoundsDo: [ - aPasteUpMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - self updateHandsDisplayBounds: aPasteUpMorph ]. - - rootMorphs _ aPasteUpMorph privateSubmorphs. - rootMorphsDamage _ Array new: rootMorphs size. - allDamage _ aDamageRecorder damageReportedNotVisibleAndCarriedByHand. - - "Iterate from front to back" - 1 to: rootMorphs size do: [ :i | | morph morphBounds morphDamage | - morph _ rootMorphs at: i. - morph visible ifTrue: [ - morphBounds _ morph displayFullBounds. - morphDamage _ OrderedCollection new. - (aDamageRecorder damageReportedFor: morph) ifNotNil: [ :r | - morphDamage add: r ]. - allDamage do: [ :r | | ri | - ri _ r intersect: morphBounds. - ri hasPositiveExtent ifTrue: [ - morphDamage add: ri ]]. - 1 to: i-1 do: [ :j | | morphBefore oldMorphDamage | - oldMorphDamage _ morphDamage. - morphDamage _ OrderedCollection new. - morphBefore _ rootMorphs at: j. - oldMorphDamage do: [ :r | - morphBefore addPossiblyUncoveredAreasIn: r to: morphDamage ]]. - (Rectangle merging: morphDamage) ifNotNil: [ :morphDamageRect | - rootMorphsDamage at: i put: morphDamageRect. - morph addPossiblyUncoveredAreasIn: morphDamageRect to: allDamage ]]]. - - "Draw World" - allDamage do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - "Iterate from back to front." - rootMorphs size to: 1 by: -1 do: [ :i | | morph morphBounds morphDamage | - morph _ rootMorphs at: i. - morphBounds _ morph displayFullBounds. - morphDamage _ rootMorphsDamage at: i. - allDamage do: [ :r | | intersection | - intersection _ r intersect: morphBounds. - intersection hasPositiveExtent ifTrue: [ - morphDamage _ intersection quickMerge: morphDamage ]]. - morphDamage ifNotNil: [ - self newClipRect: morphDamage. - self fullDraw: morph. - allDamage add: morphDamage ]]. - - aDamageRecorder reset. - ^ allDamage! ! - -MorphicCanvas removeSelector: #updateHandsDisplayBounds:addDamageTo:! - -!methodRemoval: MorphicCanvas #updateHandsDisplayBounds:addDamageTo: stamp: 'Install-4336-DamageRecorder-redesign-JuanVuletich-2020Aug05-00h08m-jmv.001.cs.st 8/5/2020 22:22:59'! -updateHandsDisplayBounds: aPasteUpMorph addDamageTo: aDamageRecorder - "Update displayBounds for carried morphs if never set. - Useful for new morph, that are created and attached to the hand." - - aPasteUpMorph handsDo: [ :hand | - self into: hand. - hand submorphsDo: [ :morph | - self updateDisplayBounds: morph ]. - aDamageRecorder recordInvalidRect: hand displayFullBounds for: hand. - self outOfMorph ]! - -DamageRecorder removeSelector: #damageReportedNotVisibleMorphs! - -!methodRemoval: DamageRecorder #damageReportedNotVisibleMorphs stamp: 'Install-4336-DamageRecorder-redesign-JuanVuletich-2020Aug05-00h08m-jmv.001.cs.st 8/5/2020 22:22:59'! -damageReportedNotVisibleMorphs - | answer | - answer _ OrderedCollection new. - self pvtAccessProtect critical: [ - damageByRoot keysAndValuesDo: [ :m :r | - (m visible not or: [m owner isNil]) ifTrue: [ - answer add: r]]]. - ^answer! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4336-DamageRecorder-redesign-JuanVuletich-2020Aug05-00h08m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4337] on 5 August 2020 at 12:40:43 am'! - -Object subclass: #DamageRecorder - instanceVariableNames: 'invalidRects totalRepaint drSemaphore damageByRoot ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #DamageRecorder category: #'Morphic-Support' stamp: 'Install-4337-DamageRecorder-redesign-JuanVuletich-2020Aug05-00h27m-jmv.001.cs.st 8/5/2020 22:22:59'! -Object subclass: #DamageRecorder - instanceVariableNames: 'invalidRects totalRepaint drSemaphore damageByRoot' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! -!WorldState methodsFor: 'canvas' stamp: 'jmv 8/5/2020 00:37:39' prior: 16945701! - clearCanvas - canvas _ nil. - damageRecorder _ DamageRecorder new.! ! -!WorldState methodsFor: 'canvas' stamp: 'jmv 8/5/2020 00:37:47' prior: 50531452! - setCanvas: aMorphicCanvas - canvas _ aMorphicCanvas. - canvas world: world. - damageRecorder - ifNil: [ damageRecorder _ DamageRecorder new].! ! -!DamageRecorder methodsFor: 'initialization' stamp: 'jmv 8/5/2020 00:37:05' prior: 50538684 overrides: 16896425! - initialize - super initialize. - damageByRoot _ IdentityDictionary new.! ! -!DamageRecorder methodsFor: 'recording' stamp: 'jmv 8/5/2020 00:39:27' prior: 50539259! - reset - "Clear the damage list." - self pvtAccessProtect critical: [ - damageByRoot removeAll ].! ! -!DamageRecorder methodsFor: 'testing' stamp: 'jmv 8/5/2020 00:36:52' prior: 50539038! - updateIsNeeded - "Return true if the display needs to be updated." - ^ self pvtAccessProtect critical: [damageByRoot notEmpty]! ! -!DamageRecorder methodsFor: 'private' stamp: 'jmv 8/5/2020 00:36:33' prior: 50539051! - pvtInnerRecordInvalidRect: requestedRect for: aRootMorph - "Record the given rectangle in my damage list, a list of rectangular areas of the display that should be redraw on the next display cycle." - | newRect | - newRect _ requestedRect encompassingIntegerRectangle. - damageByRoot at: aRootMorph put: - (damageByRoot at: aRootMorph - ifPresent: [:r | r quickMerge: newRect] - ifAbsent:[newRect])! ! - -DamageRecorder removeSelector: #pvtReset! - -!methodRemoval: DamageRecorder #pvtReset stamp: 'Install-4337-DamageRecorder-redesign-JuanVuletich-2020Aug05-00h27m-jmv.001.cs.st 8/5/2020 22:22:59'! -pvtReset - "Clear the damage list." - invalidRects removeAll. - totalRepaint _ false. - damageByRoot removeAll.! - -DamageRecorder removeSelector: #doFullRepaint! - -!methodRemoval: DamageRecorder #doFullRepaint stamp: 'Install-4337-DamageRecorder-redesign-JuanVuletich-2020Aug05-00h27m-jmv.001.cs.st 8/5/2020 22:22:59'! -doFullRepaint - "Record that a full redisplay is needed. No further damage rectangles will be recorded until after the next reset." - - ^ totalRepaint _ true. -! - -DamageRecorder removeSelector: #invalidRectsFullBounds:! - -!methodRemoval: DamageRecorder #invalidRectsFullBounds: stamp: 'Install-4337-DamageRecorder-redesign-JuanVuletich-2020Aug05-00h27m-jmv.001.cs.st 8/5/2020 22:22:59'! -invalidRectsFullBounds: aRectangle - "Return a collection of damaged rectangles for the given canvas. Take only intersection with aRectangle. - If a total repaint has been requested, return the given rectangle. - Forget about all damage." - | answer | - answer _ totalRepaint ifTrue: [ Array with: aRectangle ]. - self pvtAccessProtect critical: [ - answer ifNil: [ - answer _ OrderedCollection new. - invalidRects do: [ :r | - r ifNotNil: [ - (aRectangle containsRect: r) - ifTrue: [ answer add: r ] - ifFalse: [ answer add: (r intersect: aRectangle) ]. - ]]]. - self pvtReset ]. - ^ answer.! - -WorldState removeSelector: #doFullRepaint! - -!methodRemoval: WorldState #doFullRepaint stamp: 'Install-4337-DamageRecorder-redesign-JuanVuletich-2020Aug05-00h27m-jmv.001.cs.st 8/5/2020 22:22:59'! -doFullRepaint - - damageRecorder doFullRepaint -! - -PasteUpMorph removeSelector: #redrawNeeded! - -!methodRemoval: PasteUpMorph #redrawNeeded stamp: 'Install-4337-DamageRecorder-redesign-JuanVuletich-2020Aug05-00h27m-jmv.001.cs.st 8/5/2020 22:22:59'! -redrawNeeded - "Report that the area occupied by this morph should be redrawn." - - self == self world - ifTrue: [worldState doFullRepaint] - ifFalse: [super redrawNeeded] -! - -Object subclass: #DamageRecorder - instanceVariableNames: 'drSemaphore damageByRoot' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #DamageRecorder category: #'Morphic-Support' stamp: 'Install-4337-DamageRecorder-redesign-JuanVuletich-2020Aug05-00h27m-jmv.001.cs.st 8/5/2020 22:22:59'! -Object subclass: #DamageRecorder - instanceVariableNames: 'drSemaphore damageByRoot' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4337-DamageRecorder-redesign-JuanVuletich-2020Aug05-00h27m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4337] on 5 August 2020 at 11:37:36 am'! -!Morph methodsFor: 'drawing' stamp: 'jmv 8/5/2020 11:34:38' prior: 50537623! - visible: aBoolean - "set the 'visible' attribute of the receiver to aBoolean - Store value of 'hidden', because flags default to false." - - self visible == aBoolean - ifTrue: [ ^ self ]. - self redrawNeeded. - self privateFlagAt: 3 put: aBoolean not. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/5/2020 11:27:12' prior: 50539303! - drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rootMorphs rootMorphsDamage allDamage | - "Update #displayBounds for all dirty morphs (marked as such with #redrawNeeded). - Also add the updated bounds to aDamageRecorder, and update bounds of morphs carried by hand." - self updatingMorphBoundsDo: [ - aPasteUpMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - self updateHandsDisplayBounds: aPasteUpMorph ]. - - rootMorphs _ aPasteUpMorph privateSubmorphs. - rootMorphsDamage _ Array new: rootMorphs size. - allDamage _ aDamageRecorder damageReportedNotVisibleAndCarriedByHand. - - "Iterate from front to back" - 1 to: rootMorphs size do: [ :i | | morph morphBounds morphDamage | - morph _ rootMorphs at: i. - morph visible ifTrue: [ - morphBounds _ morph displayFullBounds. - morphDamage _ OrderedCollection new. - (aDamageRecorder damageReportedFor: morph) ifNotNil: [ :r | - morphDamage add: r ]. - allDamage do: [ :r | | ri | - ri _ r intersect: morphBounds. - ri hasPositiveExtent ifTrue: [ - morphDamage add: ri ]]. - 1 to: i-1 do: [ :j | | morphBefore oldMorphDamage | - oldMorphDamage _ morphDamage. - morphDamage _ OrderedCollection new. - morphBefore _ rootMorphs at: j. - oldMorphDamage do: [ :r | - morphBefore addPossiblyUncoveredAreasIn: r to: morphDamage ]]. - (Rectangle merging: morphDamage) ifNotNil: [ :morphDamageRect | - rootMorphsDamage at: i put: morphDamageRect. - morph addPossiblyUncoveredAreasIn: morphDamageRect to: allDamage ]]]. - - "Draw World" - allDamage do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - "Iterate from back to front." - rootMorphs size to: 1 by: -1 do: [ :i | | morph morphBounds morphDamage | - morph _ rootMorphs at: i. - morph visible ifTrue: [ - morphBounds _ morph displayFullBounds. - morphDamage _ rootMorphsDamage at: i. - allDamage do: [ :r | | intersection | - intersection _ r intersect: morphBounds. - intersection hasPositiveExtent ifTrue: [ - morphDamage _ intersection quickMerge: morphDamage ]]. - morphDamage ifNotNil: [ - self newClipRect: morphDamage. - self fullDraw: morph. - allDamage add: morphDamage ]]]. - - aDamageRecorder reset. - ^ allDamage! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4338-DamageRecorder-redesign-JuanVuletich-2020Aug05-11h37m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4338] on 5 August 2020 at 8:48:09 pm'! -!Morph methodsFor: 'updating' stamp: 'jmv 8/5/2020 12:17:02'! - invalidateBounds - "Report that the area occupied by this morph should be redrawn, - but most likely we are not going to be redrawn on it, or maybe we'll not be fully visible. See senders." - - self invalidateDisplayRect: self displayBoundsOrBogus fromSubmorph: nil for: owner.! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 8/5/2020 12:23:18' prior: 50539577! - visible: aBoolean - "set the 'visible' attribute of the receiver to aBoolean - Store value of 'hidden', because flags default to false." - - self visible == aBoolean - ifTrue: [ ^ self ]. - aBoolean - ifTrue: [ self redrawNeeded ] - ifFalse: [ self invalidateBounds ]. - self privateFlagAt: 3 put: aBoolean not. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ].! ! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'jmv 8/5/2020 12:04:47' prior: 16876951! - removeMorph: aMorph - "Remove the given morph from my submorphs" - - aMorph owner == self ifFalse: [^self]. - aMorph redrawNeeded. - self privateRemove: aMorph. - aMorph privateOwner: nil. - self removedMorph: aMorph. - self someSubmorphPositionOrExtentChanged.! ! -!Morph methodsFor: 'private' stamp: 'jmv 8/5/2020 14:53:22' prior: 50538225! - privateAddAllMorphs: aCollection atIndex: index - "Private. Add aCollection of morphs to the receiver" - | myWorld itsWorld otherSubmorphs | - (aCollection allSatisfy: [ :m | self canAdd: m]) ifFalse: [ - (self confirm: 'Some requested morph requires VectorGraphics support. Do you want to install and activate it?') - ifTrue: [ - Feature require: 'VectorGraphics'. - MorphicCanvas activeSubclass: (Smalltalk at: #HybridCanvas) ] - ifFalse: [ - ^self error: 'We can''t add requested morphs.' ]]. - myWorld _ self world. - otherSubmorphs _ submorphs copyWithoutAll: aCollection. - (index between: 0 and: otherSubmorphs size) - ifFalse: [^ self error: 'index out of range']. - index = 0 - ifTrue:[ submorphs _ aCollection asArray, otherSubmorphs] - ifFalse:[ index = otherSubmorphs size - ifTrue:[ submorphs _ otherSubmorphs, aCollection] - ifFalse:[ submorphs _ otherSubmorphs copyReplaceFrom: index + 1 to: index with: aCollection ]]. - aCollection do: [:m | | itsOwner | - itsOwner _ m owner. - itsOwner ifNotNil: [ - itsWorld _ m world. - (itsWorld == myWorld) ifFalse: [ - itsWorld ifNotNil: [m redrawNeeded]]. - (itsOwner ~~ self) ifTrue: [ - m owner privateRemove: m. - m owner removedMorph: m ]]. - m privateOwner: self. - myWorld ifNotNil: [m redrawNeeded]. - (myWorld == itsWorld) ifFalse: [m intoWorld: myWorld]. - itsOwner == self ifFalse: [ - self addedMorph: m. - m noteNewOwner: self ]. - ]. - self someSubmorphPositionOrExtentChanged! ! -!Morph methodsFor: 'private' stamp: 'jmv 8/5/2020 14:53:05' prior: 50538267! - privateAddMorph: aMorph atIndex: index - - | oldIndex myWorld itsWorld oldOwner | - (self canAdd: aMorph) ifFalse: [ - (self confirm: 'The requested morph requires VectorGraphics support. Do you want to install and activate it?') - ifTrue: [ - Feature require: 'VectorGraphics'. - MorphicCanvas activeSubclass: (Smalltalk at: #HybridCanvas) ] - ifFalse: [ - ^self error: 'We can''t add requested morph.' ]]. - ((index >= 1) and: [index <= (submorphs size + 1)]) - ifFalse: [^ self error: 'index out of range']. - myWorld _ self world. - oldOwner _ aMorph owner. - (oldOwner == self and: [(oldIndex _ submorphs indexOf: aMorph) > 0]) ifTrue:[ - "aMorph's position changes within in the submorph chain" - oldIndex < index ifTrue:[ - "moving aMorph to back" - submorphs replaceFrom: oldIndex to: index-2 with: submorphs startingAt: oldIndex+1. - submorphs at: index-1 put: aMorph. - ] ifFalse:[ - "moving aMorph to front" - oldIndex-1 to: index by: -1 do:[:i| - submorphs at: i+1 put: (submorphs at: i)]. - submorphs at: index put: aMorph. - ]. - ] ifFalse:[ - "adding a new morph" - oldOwner ifNotNil:[ - itsWorld _ aMorph world. - itsWorld ifNotNil: [aMorph invalidateBounds]. - oldOwner privateRemove: aMorph. - oldOwner removedMorph: aMorph. - ]. - aMorph privateOwner: self. - submorphs _ submorphs copyReplaceFrom: index to: index-1 with: (Array with: aMorph). - (itsWorld == myWorld) ifFalse: [aMorph intoWorld: myWorld]. - ]. - myWorld ifNotNil: [aMorph invalidateBounds]. - self someSubmorphPositionOrExtentChanged. - oldOwner == self ifFalse: [ - self addedMorph: aMorph. - aMorph noteNewOwner: self ]. -! ! -!Morph methodsFor: 'private' stamp: 'jmv 8/5/2020 14:53:11' prior: 50538314! - privateAddMorph: aMorph atIndex: index position: aPoint - - | oldIndex myWorld itsWorld oldOwner | - (self canAdd: aMorph) ifFalse: [ - (self confirm: 'The requested morph requires VectorGraphics support. Do you want to install and activate it?') - ifTrue: [ - Feature require: 'VectorGraphics'. - MorphicCanvas activeSubclass: (Smalltalk at: #HybridCanvas) ] - ifFalse: [ - ^self error: 'We can''t add requested morph.' ]]. - ((index >= 1) and: [index <= (submorphs size + 1)]) - ifFalse: [^ self error: 'index out of range']. - myWorld _ self world. - oldOwner _ aMorph owner. - (oldOwner == self and: [(oldIndex _ submorphs indexOf: aMorph) > 0]) ifTrue: [ - "aMorph's position changes within in the submorph chain" - oldIndex < index ifTrue:[ - "moving aMorph to back" - submorphs replaceFrom: oldIndex to: index-2 with: submorphs startingAt: oldIndex+1. - submorphs at: index-1 put: aMorph. - ] ifFalse:[ - "moving aMorph to front" - oldIndex-1 to: index by: -1 do:[:i| - submorphs at: i+1 put: (submorphs at: i)]. - submorphs at: index put: aMorph. - ]. - aMorph privatePosition: aPoint. - ] ifFalse: [ - "adding a new morph" - oldOwner ifNotNil: [ - itsWorld _ aMorph world. - itsWorld ifNotNil: [aMorph redrawNeeded]. - oldOwner privateRemove: aMorph. - oldOwner removedMorph: aMorph. - ]. - aMorph privateOwner: self. - submorphs _ submorphs copyReplaceFrom: index to: index-1 with: (Array with: aMorph). - aMorph privatePosition: aPoint. - (itsWorld == myWorld) ifFalse: [aMorph intoWorld: myWorld]. - ]. - myWorld ifNotNil: [aMorph redrawNeeded]. - self someSubmorphPositionOrExtentChanged. - oldOwner == self ifFalse: [ - self addedMorph: aMorph. - aMorph noteNewOwner: self ]! ! -!Morph methodsFor: 'previewing' stamp: 'jmv 8/5/2020 12:21:15' prior: 50538161! - endPreview - - self previewing ifTrue: [ - owner notNil ifTrue: [ - self visible: self visibleBeforePreview. - owner addMorph: self inFrontOf: self morphBehindBeforePreview ]. - self previewing: false. ]! ! -!PasteUpMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 8/5/2020 14:55:30' prior: 50538212! - canHandle: aMorph - self canvas ifNil: [^false]. - ^self canvas canDraw: aMorph! ! -!DamageRecorder methodsFor: 'recording' stamp: 'jmv 8/5/2020 11:44:26' prior: 50539248! - damageReportedNotVisibleAndCarriedByHand - | answer | - answer _ OrderedCollection new. - self pvtAccessProtect critical: [ - damageByRoot keysAndValuesDo: [ :m :r | - (m isNil or: [ - m visible not or: [m owner isNil or: [m owner is: #HandMorph]]]) ifTrue: [ - answer add: r]]]. - ^answer! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4339-DamageRecorder-redesign-JuanVuletich-2020Aug05-20h47m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4256] on 31 July 2020 at 2:29:03 pm'! -!SystemDictionary methodsFor: 'retrieving' stamp: 'tsl 7/31/2020 14:28:14' prior: 50525369! - allMethodsInCategory: category - | aCollection | - aCollection := SortedCollection new. - self allBehaviorsDo: [ :x | - (x organization listAtCategoryNamed: category) do: [ :sel | - aCollection add: (MethodReference class: x selector: sel)]]. - ^aCollection! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4340-allMethodsInCategory-fix-ThiagoLino-2020Jul31-14h28m-tsl.001.cs.st----! - -'From Cuis 5.0 [latest update: #4241] on 5 August 2020 at 3:18:32 pm'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 8/5/2020 15:15:39' prior: 50481221! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('AY' 'Angel Yan') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('bgs' 'Boris G. Shingarov') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('EB' 'Eric Brandwein') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('FGJ' 'Fernando Gasperi Jabalera') - #('FJG' 'Facundo Javier Gelatti') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hlsf' 'Hilaire Fernandes') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('KLG' 'Gerald Klix') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MM' 'Mariano Montone') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('pmon' 'Paolo Montrasi') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('sjd' 'Santiago Jose Dandois') - #('SLD' 'Steve Davies') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('ss' 'Sebastian Sujarchuk') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tsl' 'Thiago da Silva Lino') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4341-AddHilaireAndThiagoAsKnownUsers-JuanVuletich-2020Aug05-15h14m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4319] on 31 July 2020 at 4:16:04 pm'! - -"Change Set: 4342-RemoveUnusedIvarFromHandMorph-JuanVuletich-2020Jul31-16h13m -Date: 31 July 2020 -Author: Juan Vuletich - -Modifying instance variables definition of core to Morphs is tricky. Hence this preamble." -| ui b cs | -Utilities authorInitialsPerSe ifNil: [ Utilities setAuthor ]. -(nil confirm: 'In order to modify instance variables of HandMorph, -we need to restart the User Interface process. -You''ll need to re-start the image update to install later updates.') ifFalse: [ self halt ]. -[ - ui _ UISupervisor ui. - UISupervisor stopUIProcess. - b _ ClassBuilder isSilent. - ClassBuilder beSilent: true. - ClassBuilder new - superclass: RectangleLikeMorph - subclass: #HandMorph - instanceVariableNames: 'mouseFocus keyboardFocus mouseClickState mouseOverHandler lastMouseEvent hasChanged savedPatch lastEventBuffer lastKeyDownValue lastMouseEventTime prevFullBounds grabMorphData lastPosition' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'. - ClassBuilder beSilent: b. - UISupervisor spawnNewMorphicProcessFor: ui. - ChangeSet installing: '4342-RemoveUnusedIvarFromHandMorph-JuanVuletich-2020Jul31-16h13m-jmv.001.cs.st' do: []. - cs _ ChangeSet changeSetForBaseSystem. - (cs name beginsWith: '4342') ifTrue: [ - ChangeSet removeChangeSet: cs ]. - 'Done removing unused ivar damageRecorder from HandMorph.' print. - 'Installed ChangeSet: 4342-RemoveUnusedIvarFromHandMorph-JuanVuletich-2020Jul31-16h13m-jmv.001.cs.st' print. - 'Please restart [Install New Updates].' print. -] forkAt: 41! - -----SNAPSHOT----(5 August 2020 22:23:08) Cuis5.0-4342-v3.image priorSource: 6254795! - -----STARTUP---- (19 August 2020 10:24:44) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4342-v3.image! - - -'From Cuis 5.0 [latest update: #4342] on 6 August 2020 at 2:30:57 pm'! -!PasteUpMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 8/6/2020 14:30:22' prior: 50539882! - canHandle: aMorph - - ^self canvas canDraw: aMorph! ! -!WorldState methodsFor: 'canvas' stamp: 'jmv 8/6/2020 14:29:23' prior: 50539440! - clearCanvas - self setCanvas: Display getCanvas. - damageRecorder _ DamageRecorder new.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4343-Canvas-AlwaysHaveOne-JuanVuletich-2020Aug06-14h22m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4343] on 6 August 2020 at 3:29:00 pm'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/6/2020 15:22:52' prior: 50539590! - drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rootMorphs rootMorphsDamage allDamage | - "Update #displayBounds for all dirty morphs (marked as such with #redrawNeeded). - Also add the updated bounds to aDamageRecorder, and update bounds of morphs carried by hand." - self updatingMorphBoundsDo: [ - aPasteUpMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - self updateHandsDisplayBounds: aPasteUpMorph ]. - - rootMorphs _ aPasteUpMorph privateSubmorphs. - rootMorphsDamage _ Array new: rootMorphs size. - - allDamage _ self drawWorldComputeDamage: aPasteUpMorph repair: aDamageRecorder rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage. - - "Draw World" - allDamage do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ]. - - self drawWorld: aPasteUpMorph rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage allDamage: allDamage. - - aDamageRecorder reset. - ^ allDamage! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/6/2020 15:24:32'! - drawWorld: aPasteUpMorph rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage allDamage: allDamage - "Redraw the damaged areas. - Draw each morph just once, merging rectanges to be repaired as needed." - - | morph morphBounds morphDamage | - - "Iterate from back to front." - rootMorphs size to: 1 by: -1 do: [ :i | - morph _ rootMorphs at: i. - morph visible ifTrue: [ - morphBounds _ morph displayFullBounds. - morphDamage _ rootMorphsDamage at: i. - allDamage do: [ :r | | intersection | - intersection _ r intersect: morphBounds. - intersection hasPositiveExtent ifTrue: [ - morphDamage _ intersection quickMerge: morphDamage ]]. - morphDamage ifNotNil: [ - self newClipRect: morphDamage. - self fullDraw: morph. - allDamage add: morphDamage ]]].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/6/2020 15:28:40'! - drawWorldComputeDamage: aPasteUpMorph repair: aDamageRecorder rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage - "Iterate front to back while computing damage to actually repair for each morph, and for world background." - - | allDamage morph morphBounds morphDamage oldMorphDamage reuse ri morphBefore | - morphDamage _ OrderedCollection new. - oldMorphDamage _ OrderedCollection new. - allDamage _ aDamageRecorder damageReportedNotVisibleAndCarriedByHand. - "Iterate from front to back" - 1 to: rootMorphs size do: [ :i | - morph _ rootMorphs at: i. - morph visible ifTrue: [ - morphBounds _ morph displayFullBounds. - morphDamage removeAll. - (aDamageRecorder damageReportedFor: morph) ifNotNil: [ :r | - morphDamage add: r ]. - allDamage do: [ :r | - ri _ r intersect: morphBounds. - ri hasPositiveExtent ifTrue: [ - morphDamage add: ri ]]. - 1 to: i-1 do: [ :j | - reuse _ oldMorphDamage. - oldMorphDamage _ morphDamage. - morphDamage _ reuse removeAll. - morphBefore _ rootMorphs at: j. - oldMorphDamage do: [ :r | - morphBefore addPossiblyUncoveredAreasIn: r to: morphDamage ]]. - (Rectangle merging: morphDamage) ifNotNil: [ :morphDamageRect | - rootMorphsDamage at: i put: morphDamageRect. - morph addPossiblyUncoveredAreasIn: morphDamageRect to: allDamage ]]]. - - ^ allDamage! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4344-WorldDrawRefactor-JuanVuletich-2020Aug06-15h19m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4344] on 6 August 2020 at 5:47:04 pm'! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 8/6/2020 17:46:03' prior: 50539009! - restoreSavedPatchOn: aCanvas - "Clear the changed flag and restore the part of the given canvas under this hand from the previously saved patch. If necessary, handle the transition to using the hardware cursor." - hasChanged _ false. - savedPatch ifNotNil: [ - aCanvas restorePatch: savedPatch. - submorphs notEmpty ifTrue: [ ^ self ]. - "Make the transition to using hardware cursor. Clear savedPatch and - report one final damage rectangle to erase the image of the software cursor." - " owner invalidateDisplayRect: (savedPatch offset extent: savedPatch extent) from: nil." - self - invalidateDisplayRect: (self morphPosition extent: extent) - fromSubmorph: nil - for: nil. - Cursor currentCursor == Cursor defaultCursor ifFalse: [ Cursor defaultCursor activateCursor ]. - "show hardware cursor" - savedPatch _ nil ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4345-RemoveDragHandPointer-JuanVuletich-2020Aug06-17h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4344] on 6 August 2020 at 7:39:03 pm'! - -"Make all ids notNil" -Morph allSubInstances do: [ :m | (m instVarNamed: 'id') ifNil: [ m instVarNamed: 'id' put: 0 ]]! -!Morph methodsFor: 'accessing' stamp: 'jmv 8/6/2020 19:37:15' prior: 50537599! - morphId - "Non zero. Zero id means no Morph. - reserve lower 8 bits of numeric ivar for boolean flags." - " - Morph clearIds - " - | morphId | - morphId _ id >> 8. - morphId = 0 ifTrue: [ - LastMorphId isNil ifTrue: [ LastMorphId _ 0 ]. - LastMorphId _ LastMorphId + 1. - id _ LastMorphId << 8 + id. "Keep any flags" - morphId _ LastMorphId ]. - ^morphId! ! -!Morph methodsFor: 'caching' stamp: 'jmv 8/6/2020 19:36:23' prior: 50537618! - clearId - "But keep flags. - Morph clearIds - " - - id _ id bitAnd: 255.! ! -!Morph methodsFor: 'initialization' stamp: 'jmv 8/6/2020 19:31:28' prior: 50537637 overrides: 16896425! - initialize - "initialize the state of the receiver" - - owner _ nil. - submorphs _ #(). - location _ MorphicTranslation new. - id _ 0.! ! -!Morph methodsFor: 'private' stamp: 'jmv 8/6/2020 19:37:39' prior: 50537576! - privateFlagAt: bitIndex - "We can hold up to 8 1-bit flags. - Initial value of all flags is false." - - ^(id bitAt: bitIndex) = 1! ! -!Morph methodsFor: 'private' stamp: 'jmv 8/6/2020 19:37:46' prior: 50537583! - privateFlagAt: bitIndex put: aBoolean - "We can hold up to 8 1-bit flags. - Initial value of all flags is false." - - id _ id bitAt: bitIndex put: (aBoolean ifTrue: [1] ifFalse: [0])! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 8/6/2020 18:05:52' prior: 50536792! - savePatch: prevSavedPatch bounds: aRectangle - "Senders don't need to know any details of what is answered, but just store it for further calls, and calls to restorePatch:" - "Details: The previously used patch Form is recycled when possible to reduce the burden on storage management." - | savedPatch bb | - savedPatch _ prevSavedPatch. - ((savedPatch is: #Form) not or: [savedPatch extent ~= aRectangle extent]) - ifTrue: [ - "allocate new patch form if needed" - savedPatch _ Form extent: aRectangle extent depth: form depth ] - ifFalse: [ - savedPatch offset: 0@0 ]. - bb _ BitBlt toForm: savedPatch. - bb sourceForm: form; combinationRule: Form over; - sourceX: aRectangle left; sourceY: aRectangle top; - width: aRectangle width; height: aRectangle height; - copyBits. - savedPatch offset: aRectangle topLeft. - ^savedPatch! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Morph clearIds! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4346-MorphId-fix-JuanVuletich-2020Aug06-17h47m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4346] on 6 August 2020 at 9:43:13 pm'! -!Morph methodsFor: 'user interface' stamp: 'jmv 8/6/2020 21:41:56' prior: 16877042! - activateWindowAndSendTopToBack: aBoolean - - self owningWindow ifNotNil: [ :w | - w activateAndSendTopToBack: aBoolean]! ! -!SystemWindow methodsFor: 'top window' stamp: 'jmv 8/6/2020 21:40:32' prior: 50537958! - activateAndSendTopToBack: aBoolean - "Bring me to the front and make me able to respond to mouse and keyboard" - - | oldTop | - owner - ifNil: [^self "avoid spurious activate when drop in trash"]. - - self isTopWindow ifTrue: [ - self comeToFront. - ^self ]. - - oldTop _ TopWindow. - TopWindow _ self. - self redrawNeeded. - - oldTop ifNotNil: [ - oldTop redrawNeeded. - aBoolean ifTrue: [ - | bottomWindow | - bottomWindow _ oldTop owner submorphs reverse detect: [:one | one is: #SystemWindow]. - oldTop owner addMorph: oldTop behind: bottomWindow]]. - - self comeToFront. - - "Set keyboard focus" - self world ifNotNil: [ :w | - w activeHand newKeyboardFocus: self submorphToFocusKeyboard ]! ! -!HandMorph methodsFor: 'focus handling' stamp: 'jmv 8/6/2020 21:40:56' prior: 16851883! - activateNextWindow - - self nextFocusWindow ifNotNil: [ :w | - w activateAndSendTopToBack: true ]! ! -!HandMorph methodsFor: 'focus handling' stamp: 'jmv 8/6/2020 21:41:04' prior: 16851890! - activatePreviousWindow - - self previousFocusWindow ifNotNil: [ :w | - w activateAndSendTopToBack: false ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4347-ActivateWindow-JuanVuletich-2020Aug06-21h33m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4347] on 6 August 2020 at 10:10:41 pm'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/6/2020 22:08:50'! - drawWorld: aPasteUpMorph rects: allDamage - "Draw allDamage rects for aPasteUpMorph" - - allDamage do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/6/2020 22:09:08' prior: 50540222! - drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rootMorphs rootMorphsDamage allDamage | - "Update #displayBounds for all dirty morphs (marked as such with #redrawNeeded). - Also add the updated bounds to aDamageRecorder, and update bounds of morphs carried by hand." - self updatingMorphBoundsDo: [ - aPasteUpMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - self updateHandsDisplayBounds: aPasteUpMorph ]. - - rootMorphs _ aPasteUpMorph privateSubmorphs. - rootMorphsDamage _ Array new: rootMorphs size. - - allDamage _ self drawWorldComputeDamage: aPasteUpMorph repair: aDamageRecorder - rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage. - - self drawWorld: aPasteUpMorph rects: allDamage. - - self drawWorld: aPasteUpMorph rootMorphs: rootMorphs - rootMorphsDamage: rootMorphsDamage allDamage: allDamage. - - aDamageRecorder reset. - ^ allDamage! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4348-DrawWorld-refactor-JuanVuletich-2020Aug06-22h07m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4348] on 7 August 2020 at 4:23:03 pm'! -!LayoutMorph methodsFor: 'layout' stamp: 'KLG 8/7/2020 16:22:34' prior: 50521477! - layoutSubmorphsHorizontallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - - | visibleSubmorphs sumOfWidths theSeparation widthsArray - widthToAllocate leftOver nextX | - "Preconditions: self isRow & morphExtent >= minimumLayoutExtent" - (visibleSubmorphs := self submorphsToLayout reversed "Display Order") - ifEmpty: [ ^ self. " Nothing to layout, `sum` would fai" ]. - - theSeparation := self xSeparation. - - widthToAllocate := (boundsForLayout width - ((visibleSubmorphs size + 1) * theSeparation)). - widthsArray := self widthsFor: visibleSubmorphs within: widthToAllocate. - sumOfWidths := widthsArray sum: [ :w | w ] . - leftOver := widthToAllocate - sumOfWidths. - nextX := boundsForLayout origin x - + theSeparation - + (leftOver * (self axisEdgeWeight ifNil: [0.0])). "first X, edge shifted" -"Transcript log: 'first X=', nextX asString, ' leftOver=', leftOver asString; cr. -" 1 to: visibleSubmorphs size do: [ :index | | sm smX smWidth heightAndY newExtent | - sm := visibleSubmorphs at: index. - smX := nextX. - smWidth := widthsArray at: index. - nextX := smX + smWidth + theSeparation. - heightAndY := self offHorizontalMetricFor: sm withinExtent: boundsForLayout. - sm morphPosition: smX @ (heightAndY y). - newExtent := smWidth @ (heightAndY x). - (sm morphExtent = newExtent) ifFalse: [ sm morphExtent: newExtent ]. - ] -! ! -!LayoutMorph methodsFor: 'layout' stamp: 'KLG 8/7/2020 16:17:20' prior: 50521521! - layoutSubmorphsVerticallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - - | visibleSubmorphs sumOfHeights theSeparation heightsArray - heightToAllocate leftOver nextY | - "Preconditions: self isRow & morphExtent >= minimumLayoutExtent" - (visibleSubmorphs := self submorphsToLayout reversed "Display Order") - ifEmpty: [ ^ self. "Nothing to layout, besides `sum` below, would fail" ]. - - theSeparation := self ySeparation. - heightToAllocate := (boundsForLayout height - ((visibleSubmorphs size + 1) * theSeparation)). - heightsArray := self heightsFor: visibleSubmorphs within: heightToAllocate. - sumOfHeights := heightsArray sum: [ :w | w ] . - leftOver := heightToAllocate - sumOfHeights. - nextY := boundsForLayout origin y - + theSeparation - + (leftOver * (self axisEdgeWeight ifNil: [0.5])). "first Y, edge shifted" -"Transcript log: 'first Y=', nextY asString, ' leftOver=', leftOver asString; cr. -" 1 to: visibleSubmorphs size do: [ :index | | sm smY smHeight xAndWidth newExtent | - sm := visibleSubmorphs at: index. - smY := nextY. - smHeight := heightsArray at: index. - nextY := smY + smHeight + theSeparation. - xAndWidth := self offVerticalMetricFor: sm withinExtent: boundsForLayout. - sm morphPosition: (xAndWidth x) @ smY. - newExtent := (xAndWidth y) @ smHeight. - (sm morphExtent = newExtent) ifFalse: [ sm morphExtent: newExtent ]. - ] -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4349-LayoutMorphNoVisibleSubMorphs-GeraldKlix-2020Aug07-KLG.002.cs.st----! - -'From Cuis 5.0 [latest update: #4349] on 17 August 2020 at 1:45:32 pm'! -!PasteUpMorph methodsFor: 'initialization' stamp: 'jmv 8/17/2020 13:41:01'! - setCanvas - worldState setCanvas! ! -!WorldState methodsFor: 'canvas' stamp: 'jmv 8/17/2020 13:41:08'! - setCanvas - self setCanvas: Display getCanvas. - damageRecorder _ DamageRecorder new.! ! -!StrikeFont class methodsFor: 'class cached access' stamp: 'jmv 8/17/2020 12:48:37' prior: 50417603 overrides: 50510056! - releaseClassState - "Do not remove them in every image save (#releaseClassCachedState) to save startup time." - " - StrikeFont releaseClassState - " - "Deallocate synthetically derived copies of base fonts to save space" - self allInstancesDo: [ :sf | sf reset ]! ! -!Morph class methodsFor: 'initialize-release' stamp: 'jmv 8/17/2020 13:22:58' prior: 50510035 overrides: 50510056! - releaseClassState - - self allInstancesDo: [ :each | - each releaseCachedState. - each clearId ]. - LastMorphId _ nil.! ! -!PasteUpMorph methodsFor: 'geometry' stamp: 'jmv 8/17/2020 13:41:41' prior: 50337715 overrides: 16899309! - privateExtent: newExtent - - ^ (super privateExtent: newExtent) - ifTrue: [ - self buildMagnifiedBackgroundImage. - worldState ifNotNil: [ - worldState setCanvas ]]; - yourself! ! -!PasteUpMorph methodsFor: 'interaction loop' stamp: 'jmv 8/17/2020 13:41:37' prior: 50378672! - mainLoop - - - self clearWaitDelay. - self setCanvas. - [ - self doOneCycle. - Processor yield. - true ] - whileTrue: []! ! -!WorldState methodsFor: 'canvas' stamp: 'jmv 8/17/2020 13:42:46' prior: 50540209! - clearCanvas - canvas _ nil. - damageRecorder _ nil.! ! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 8/17/2020 13:41:43' prior: 50339474! - displayWorldSafely - "Update this world's display and keep track of errors during draw methods." - - [world displayWorld] ifError: [:err :rcvr | - "Handle a drawing error" - | errCtx errMorph | - errCtx _ thisContext. - [ - errCtx _ errCtx sender. - "Search the sender chain to find the morph causing the problem" - [errCtx notNil and: [ (errCtx receiver is: #Morph) not ]] - whileTrue:[errCtx _ errCtx sender]. - "If we're at the root of the context chain then we have a fatal drawing problem" - errCtx ifNil:[^self handleFatalDrawingError: err]. - errMorph _ errCtx receiver. - "If the morph causing the problem has already the #drawError flag set, - then search for the next morph above in the caller chain." - errMorph isKnownFailing - ] whileTrue. - errMorph drawingFails. - self setCanvas. - "Install the old error handler, so we can re-raise the error" - rcvr error: err. - ]! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/17/2020 13:41:33' prior: 50536827! - activeSubclass: aMorphicCanvasSubclass - ActiveSubclass _ aMorphicCanvasSubclass. - PasteUpMorph allInstancesDo: [ :w | w setCanvas ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4350-WorldStateFix-JuanVuletich-2020Aug17-13h44m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4349] on 16 August 2020 at 9:01:34 am'! -!Feature methodsFor: 'testing' stamp: 'jmv 8/16/2020 08:49:11'! - isLaterThan: aFeature - ^self version > aFeature version or: [ - self version = aFeature version and: [ - self revision > aFeature revision ]]! ! -!CodePackageList methodsFor: 'accessing' stamp: 'jmv 8/9/2020 19:02:18' prior: 16811249! - packageFullNames - - ^ packages collect: [ :each | each fullFileName ifNil: '---Never saved yet' ]! ! -!CodePackage methodsFor: 'accessing' stamp: 'jmv 8/9/2020 19:02:15' prior: 16810682! - fullFileName - - ^fullFileName! ! -!ChangeSet class methodsFor: 'services' stamp: 'jmv 8/16/2020 09:00:39' prior: 16799313! - installNewUpdates: updatesFileDirectory - - | warnUser | - (self newUpdates: updatesFileDirectory) do: [ :each | - self install: each ]. - - warnUser _ false. - CodePackage installedPackages keysAndValuesDo: [ :pckName :package | - package fullFileName ifNotNil: [ :fullFileName | | codePackageFile | - codePackageFile _ CodePackageFile onFileEntry: fullFileName asFileEntry. - (codePackageFile provides isLaterThan: package provides) ifTrue: [ - warnUser _ true. - package hasUnsavedChanges - ifTrue: [ 'Package: ', pckName, '. Package has unsaved changes, but there is a newer version of the file.' print ] - ifFalse: [ 'Package: ', pckName, '. There is a newer version than the currently loaded.' print ]]]]. - warnUser - ifTrue: [ - self inform: SystemVersion current version, ' - ', Smalltalk lastUpdateString, String newLineString, -'Some package(s) loaded in the image -have updated package file on disk. -Please see Transcript.' ] - ifFalse: [ - Smalltalk aboutThisSystem ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4351-WarnAboutUpdatedPackages-JuanVuletich-2020Aug16-08h45m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4351] on 18 August 2020 at 4:23:23 pm'! -!WorldState methodsFor: 'canvas' stamp: 'jmv 8/18/2020 16:13:52' prior: 50540673! -setCanvas - self setCanvas: Display getCanvas. - damageRecorder _ DamageRecorder new. - world redrawNeeded! ! -!Preferences class methodsFor: 'start up' stamp: 'jmv 8/18/2020 16:22:58' prior: 50370741! - checkLostChangesOnStartUp - ^ "self - valueOfFlag: #checkLostChangesOnStartUp - ifAbsent: [ true ]." false! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -(nil confirm: 'After this update, -we need to restart the User Interface process. -Please do World / Changes... / [Install New Updates] again.') ifFalse: [ self halt ]. -[ - ChangeSet installing: '4352-WorldStateCleanup-JuanVuletich-2020Jul31-16h13m-jmv.001.cs.st' do: []. - cs _ ChangeSet changeSetForBaseSystem. - (cs name beginsWith: '4352') ifTrue: [ - ChangeSet removeChangeSet: cs ]. - 'Installed ChangeSet: 4352-WorldStateCleanup-JuanVuletich-2020Jul31-16h13m-jmv.001.cs.st' print. - 'Please do World / Changes... / [Install New Updates] again.' print. -] forkAt: 39. -Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true.! - -----NOP----(19 August 2020 10:24:49) Cuis5.0-4342-v3.image priorSource: 6673391! - -'From Cuis 5.0 [latest update: #4351] on 18 August 2020 at 4:34:06 pm'! -!Preferences class methodsFor: 'start up' stamp: 'HAW 9/9/2017 12:07:37' prior: 50540833! - checkLostChangesOnStartUp - ^ self - valueOfFlag: #checkLostChangesOnStartUp - ifAbsent: [ true ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4353-enableBackLostChangesOnStartup-JuanVuletich-2020Aug18-16h33m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4353] on 19 August 2020 at 9:30:04 am'! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/19/2020 09:25:26' prior: 50534892! - displayFullBounds - "Answer a rectangle that completely bounds receiver and submorphs when last drawn - (if the world was to be fully drawn, i.e. only to be used on a Canvas on the full world)." - - | answer | - answer _ self displayBounds. - answer ifNil: [ ^nil ]. - self submorphsDrawingOutsideReverseDo: [ :m | - answer _ answer quickMerge: m displayFullBounds ]. - ^answer! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/19/2020 09:27:55' prior: 50540286! - drawWorldComputeDamage: aPasteUpMorph repair: aDamageRecorder rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage - "Iterate front to back while computing damage to actually repair for each morph, and for world background." - - | allDamage morph morphDamage oldMorphDamage reuse ri morphBefore | - morphDamage _ OrderedCollection new. - oldMorphDamage _ OrderedCollection new. - allDamage _ aDamageRecorder damageReportedNotVisibleAndCarriedByHand. - "Iterate from front to back" - 1 to: rootMorphs size do: [ :i | - morph _ rootMorphs at: i. - morph displayFullBounds ifNotNil: [ :morphBounds | - morphDamage removeAll. - (aDamageRecorder damageReportedFor: morph) ifNotNil: [ :r | - morphDamage add: r ]. - allDamage do: [ :r | - ri _ r intersect: morphBounds. - ri hasPositiveExtent ifTrue: [ - morphDamage add: ri ]]. - 1 to: i-1 do: [ :j | - reuse _ oldMorphDamage. - oldMorphDamage _ morphDamage. - morphDamage _ reuse removeAll. - morphBefore _ rootMorphs at: j. - oldMorphDamage do: [ :r | - morphBefore addPossiblyUncoveredAreasIn: r to: morphDamage ]]. - (Rectangle merging: morphDamage) ifNotNil: [ :morphDamageRect | - rootMorphsDamage at: i put: morphDamageRect. - morph addPossiblyUncoveredAreasIn: morphDamageRect to: allDamage ]]]. - - ^ allDamage! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4354-avoidUnlikelyDrawWorldBreakage-JuanVuletich-2020Aug19-09h17m-jmv.001.cs.st----! - -----SNAPSHOT----(19 August 2020 10:24:59) Cuis5.0-4354-v3.image priorSource: 6673391! - -----STARTUP---- (22 August 2020 11:13:27) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4354-v3.image! - - -'From Cuis 5.0 [latest update: #4354] on 21 August 2020 at 10:39:26 am'! - -RectangleLikeMorph subclass: #HaloMorph - instanceVariableNames: 'target positionOffset angleOffset growingOrRotating haloBox scaleOffset ' - classVariableNames: 'HandleSize Icons ' - poolDictionaries: '' - category: 'Morphic-Halos'! - -!classDefinition: #HaloMorph category: #'Morphic-Halos' stamp: 'Install-4355-AutomaticallyScaleHalos-JuanVuletich-2020Aug21-10h36m-jmv.001.cs.st 8/22/2020 11:13:31'! -RectangleLikeMorph subclass: #HaloMorph - instanceVariableNames: 'target positionOffset angleOffset growingOrRotating haloBox scaleOffset' - classVariableNames: 'HandleSize Icons' - poolDictionaries: '' - category: 'Morphic-Halos'! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/21/2020 10:34:45'! - haloHandleSize - ^ Preferences standardListFont pointSize * 3 // 2 max: 16! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 8/21/2020 10:38:31' prior: 50535590! - addHandle: handleSpec - "Add a handle within the halo box as per the haloSpec, and set it up to respond to the given event by sending the given selector to the given recipient. Return the handle." - - | handle aPoint colorToUse form icon e | - aPoint _ self - positionIn: haloBox - horizontalPlacement: handleSpec horizontalPlacement - verticalPlacement: handleSpec verticalPlacement. - colorToUse _ Color colorFrom: handleSpec color. - handle _ HaloHandleMorph new color: colorToUse. - self addMorph: handle. - e _ Preferences haloHandleSize asPoint. - handle morphPosition: aPoint-(e//2) extent: e. - handleSpec iconSymbol ifNotNil: [ :iconName | - form _ self class icons at: iconName ifAbsent: [self class perform: iconName]. - form ifNotNil: [ - form extent = e ifFalse: [ - ": Non default size, scale that bugger!!" - form _ form ": Be as smooth as possible, these images are small." - magnify: form boundingBox - to: e - smoothing: 1 ]. - icon _ ImageMorph new - image: form; - color: colorToUse makeForegroundColor; - lock. - handle addMorphFront: icon position: `0@0` ]]. - handle mouseUpSelector: #endInteraction. - handle setBalloonText: handleSpec hoverHelp. - ^ handle! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 8/21/2020 10:38:43' prior: 50535637! - addNameString: aString - "Add a name display centered beneath the bottom of the outer rectangle. Return the handle." - - | nameMorph verticalNamePosition namePosition nameBackground | - nameBackground _ RectangleLikeMorph new - color: ((target is: #SystemWindow) - ifTrue: [target windowColor] - ifFalse: [`Color lightBlue alpha: 0.9`]). - nameMorph _ StringMorph contents: aString. - nameMorph color: `Color black`. - nameBackground morphExtent: nameMorph morphExtent + 4. - verticalNamePosition _ haloBox bottom + Preferences haloHandleSize. - namePosition _ haloBox width - nameMorph morphWidth // 2 + haloBox left @ verticalNamePosition. - self addMorph: nameBackground. - nameBackground morphPosition: namePosition - 2. - self addMorph: nameMorph. - nameMorph morphPosition: namePosition. - ^nameMorph! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 8/21/2020 10:38:51' prior: 50535665! - basicBox - "basicBox is in local coordinates" - | aBox minSide anExtent w hs targetBounds | - hs _ Preferences haloHandleSize. - minSide _ 4 * hs. - anExtent _ extent + (hs*2) max: minSide@minSide. - targetBounds _ target displayBounds. - aBox _ Rectangle center: targetBounds center extent: anExtent. - w _ self world ifNil: [ target world ]. - aBox _ w - ifNil: - [ aBox ] - ifNotNil: - [ aBox intersect: (w viewBox insetBy: (hs@hs corner: hs@(hs*3))) ]. - ^aBox translatedBy: self morphPosition negated! ! -!HaloMorph class methodsFor: 'cached state access' stamp: 'jmv 8/21/2020 10:29:20' prior: 16851310 overrides: 50510042! - releaseClassCachedState - - Icons _ nil! ! - -HaloMorph class removeSelector: #handleSize! - -!methodRemoval: HaloMorph class #handleSize stamp: 'Install-4355-AutomaticallyScaleHalos-JuanVuletich-2020Aug21-10h36m-jmv.001.cs.st 8/22/2020 11:13:31'! -handleSize - HandleSize ifNil: [ - HandleSize _ 16 ]. - ^ HandleSize! - -RectangleLikeMorph subclass: #HaloMorph - instanceVariableNames: 'target positionOffset angleOffset growingOrRotating haloBox scaleOffset' - classVariableNames: 'Icons' - poolDictionaries: '' - category: 'Morphic-Halos'! - -!classDefinition: #HaloMorph category: #'Morphic-Halos' stamp: 'Install-4355-AutomaticallyScaleHalos-JuanVuletich-2020Aug21-10h36m-jmv.001.cs.st 8/22/2020 11:13:31'! -RectangleLikeMorph subclass: #HaloMorph - instanceVariableNames: 'target positionOffset angleOffset growingOrRotating haloBox scaleOffset' - classVariableNames: 'Icons' - poolDictionaries: '' - category: 'Morphic-Halos'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4355-AutomaticallyScaleHalos-JuanVuletich-2020Aug21-10h36m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4355] on 21 August 2020 at 12:03:13 pm'! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/21/2020 11:23:13'! - systemWindowBorderSize - | w | - w _ Preferences standardListFont pointSize / 11. - Theme current minimalWindows ifFalse: [ - w _ w * (Theme current roundWindowCorners ifTrue: [ 4 ] ifFalse: [ 2 ])]. - ^w rounded max: 1! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 8/21/2020 11:57:29' prior: 50471930! - drawLabelOn: aCanvas - - | x0 y0 f w availableW l | - f _ Preferences windowTitleFont. - x0 _ f lineSpacing * 5 + borderWidth. - y0 _ borderWidth * 6 // 10. - availableW _ extent x - x0. - l _ labelString. - w _ f widthOfString: l. - [ w > availableW ] whileTrue: [ - l _ l squeezedTo: (1.0 * l size * availableW / w) truncated. - l isEmpty ifTrue: [ ^self ]. - w _ f widthOfString: l ]. - aCanvas - drawString: l - at: x0@y0 - font: f - color: Theme current windowLabel - embossed: Theme current embossedTitles! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 8/21/2020 10:53:52' prior: 16926261 overrides: 16889446! - defaultBorderWidth - "answer the default border width for the receiver" - ^Preferences systemWindowBorderSize! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 8/21/2020 12:02:19' prior: 50471967! - initializeLabelArea - "Initialize the label area (titlebar) for the window." - - | topLeft spacing | - topLeft _ (self labelHeight + borderWidth - self titleBarButtonsExtent / 2) ceiling asPoint. - spacing _ self titleBarButtonsExtent x *14//10. - self addMorph: self createCloseButton position: topLeft. - self addMorph: self createCollapseButton position: spacing@0 + topLeft. - self addMorph: self createExpandButton position: spacing*2@0 + topLeft. - self addMorph: self createMenuButton position: spacing*3@0 + topLeft! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 8/21/2020 11:59:53' prior: 50471903! - titleBarButtonsExtent - "answer the extent to use for close & other title bar buttons. - - the label height is used to be proportional to the fonts preferences" - | e | - Theme current minimalWindows ifTrue: [^`0@0`]. - e _ Preferences windowTitleFont pointSize * 13 // 10. - ^e@e! ! -!SystemWindow methodsFor: 'label' stamp: 'len 5/1/2020 06:34:51' prior: 50509397! - labelHeight - "Answer the height for the window label." - Theme current minimalWindows ifTrue: [^ 0]. - ^ Preferences windowTitleFont lineSpacing+1! ! -!SystemWindow methodsFor: 'layout' stamp: 'jmv 8/21/2020 11:07:07' prior: 50537688 overrides: 50537644! - layoutSubmorphs - "Compute a new layout of submorphs based on the given layout bounds." - - | h thickness w cornerExtent wh ww pos | - thickness _ self defaultBorderWidth. - cornerExtent _ thickness * 5. - ww _ extent x. - wh _ extent y. - w _ ww - cornerExtent - cornerExtent. - h _ wh - cornerExtent - cornerExtent. - (adjusters at: #topAdjuster) morphPosition: cornerExtent@0 extent: w@thickness. - (adjusters at: #bottomAdjuster) morphPosition: cornerExtent@(wh-thickness) extent: w@thickness. - (adjusters at: #leftAdjuster) morphPosition: 0@cornerExtent extent: thickness@h. - (adjusters at: #rightAdjuster) morphPosition: ww-thickness@cornerExtent extent: thickness@h. - (adjusters at: #topLeftAdjuster) morphPosition: `0@0` extent: cornerExtent@cornerExtent. - (adjusters at: #bottomLeftAdjuster) morphPosition: 0@(wh-cornerExtent) extent: cornerExtent@cornerExtent. - (adjusters at: #topRightAdjuster) morphPosition: ww-cornerExtent@0 extent: cornerExtent@cornerExtent. - (adjusters at: #bottomRightAdjuster) morphPosition: ww@wh-cornerExtent extent: cornerExtent@cornerExtent. - - layoutMorph ifNotNil: [ - pos _ borderWidth @ (borderWidth + self labelHeight). - layoutMorph - morphPosition: pos - extent: extent - pos - borderWidth ]. - - self layoutNeeded: false.! ! -!WindowEdgeAdjustingMorph methodsFor: 'geometry testing' stamp: 'jmv 8/21/2020 11:23:01' prior: 16945124 overrides: 50537263! - morphContainsPoint: aLocalPoint - | sensitiveBorder | - ( self morphLocalBounds containsPoint: aLocalPoint) ifFalse: [ ^false ]. - sensitiveBorder _ owner borderWidth. - selector caseOf: { - [ #windowTopLeft: ] -> [ ^ aLocalPoint x < sensitiveBorder or: [ aLocalPoint y < sensitiveBorder ]]. - [ #windowTopRight: ] -> [ ^ extent x - aLocalPoint x <= sensitiveBorder or: [ aLocalPoint y < sensitiveBorder ]]. - [ #windowBottomLeft: ] -> [ ^ aLocalPoint x < sensitiveBorder or: [ extent y- aLocalPoint y <= sensitiveBorder ]]. - [ #windowBottomRight: ] -> [ ^ extent x - aLocalPoint x <= sensitiveBorder or: [ extent y - aLocalPoint y <= sensitiveBorder ]]. - } - otherwise: [ - "all the morph is sensitive for horizontal and vertical (i.e. non corner) instances." - ^true ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4356-AutomaticallyScaleWindowResizers-JuanVuletich-2020Aug21-11h52m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4356] on 21 August 2020 at 12:34:31 pm'! -!Morph methodsFor: 'updating' stamp: 'jmv 8/21/2020 12:31:46' prior: 50539675! - invalidateBounds - "Report that the area occupied by this morph should be redrawn, - but most likely we are not going to be redrawn on it, or maybe we'll not be fully visible. See senders." - - self invalidateDisplayRect: self displayBoundsOrBogus fromSubmorph: nil for: nil.! ! -!TranscriptWindow class methodsFor: 'GUI building' stamp: 'jmv 8/21/2020 12:28:48' prior: 50539290! - openTranscript - " - TranscriptWindow openTranscript - " - | win m | - win _ TranscriptWindow new. - win - setLabel: 'Transcript'; - model: Transcript. - m _ TranscriptMorph new. - win layoutMorph addMorph: m proportionalHeight: 1. - win model when: #redraw send: #invalidateBounds to: m. - ^ win openInWorld.! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -TranscriptWindow allInstancesDo: [ :t | t delete ]. -TranscriptWindow openTranscript.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4357-TranscriptGlitchFix-JuanVuletich-2020Aug21-12h34m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4357] on 21 August 2020 at 4:34:48 pm'! -!Morph methodsFor: 'change reporting' stamp: 'jmv 8/21/2020 16:14:59' prior: 50538453! - invalidateDisplayRect: damageRect fromSubmorph: submorphOrNil for: aMorph - " - If we clip submorphOrNil, then we clip damageRect. - When calling from self, submorphOrNil should be nil, i.e. we are not reporting damage for some submorph. - - aMorph is the morph that changed and therefore should be redrawn. In some cases, damage reporting is done by no longer occupying some area, and requesting whatever appropriate morph to be drawn there. In such cases, aMorph should be nil. See senders." - - | clippedRect b | - - "warning. Senders are using global coordinates. Redesign!!" - "local now!!!!!!!!!!" - self flag: #jmvVer2. "ok?" - - self visible ifFalse: [ ^self]. - - clippedRect _ damageRect. - submorphOrNil ifNotNil: [ - submorphOrNil == self clippedSubmorph - ifTrue: [ - b _ self displayBounds. - b ifNil: [ ^self ]. - clippedRect _ damageRect intersect: b ]]. - owner ifNotNil: [ - owner invalidateDisplayRect: clippedRect fromSubmorph: self for: aMorph ]! ! -!Morph methodsFor: 'updating' stamp: 'jmv 8/21/2020 16:15:38' prior: 50538996! - redrawNeeded - "Report that the area occupied by this morph should be redrawn. - Usually because we changed in some way." - - self needsRedraw: true. - self allOwnersDo: [ :m | m submorphNeedsRedraw: true ]. - self invalidateDisplayRect: self displayBoundsOrBogus fromSubmorph: nil for: self. - self submorphsDrawingOutsideReverseDo: [ :m | m redrawNeeded ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4358-Comments-JuanVuletich-2020Aug21-16h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4354] on 21 August 2020 at 7:28:31 pm'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 8/21/2020 19:28:21' prior: 50518201! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag - "WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " - | activeProc | - activeProc _ Processor activeProcess. - [ | isARealStartup guiRootObject guiRootObjectClass | - save not & quit - ifTrue: [ - (SourceFiles at: 2) ifNotNil: [ :changes | - ChangesInitialFileSize ifNotNil: [ changes truncate: ChangesInitialFileSize ]]] - ifFalse: [ - self - logSnapshot: save - andQuit: quit ]. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | - each isInWorld ifTrue: [ - each delete.]]. - UISupervisor ui tearDownDesktop. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - "Cosas que levanto explicitamente abajo" - guiRootObjectClass _ UISupervisor ui class. - guiRootObject _ UISupervisor ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "guiRootObject _ clearAllStateFlag ifFalse: [ UISupervisor ui ]." - UISupervisor stopUIProcess. - activeProc isTerminated ifFalse: [ activeProc terminate ]. - "Clean Globals" - Smalltalk - at: #Sensor - put: nil. - Smalltalk - at: #Display - put: nil. - Smalltalk closeSourceFiles. - Smalltalk - at: #SourceFiles - put: nil. - Smalltalk allClassesDo: [ :cls | - cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | - cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ - Smalltalk printStuffToCleanOnImageSave. - "Remove this call to actually see the image clean report." - Transcript clear. - ]. - "Do image save & quit as apropriate" - (Cursor cursorAt: #writeCursor) activateCursor. - save - ifTrue: [ - "The snapshot primitive answers false if it was just called to do the snapshot. - But image startup is resumed by returning (again) from the primitive, but this time answering true." - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk - at: #Sensor - put: nil. - Smalltalk - at: #Display - put: DisplayScreen new. - Smalltalk - at: #SourceFiles - put: (Array new: 2). - Smalltalk openSourceFiles. - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | - cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - UISupervisor spawnNewMorphicProcessFor: (guiRootObject ifNil: [ guiRootObject _ guiRootObjectClass newWorld ]). - self restoreLostChangesIfNecessary. - clearAllStateFlag ifTrue: [ - UISupervisor whenUIinSafeState: [ - guiRootObject recreateDefaultDesktop; restoreDisplay. - Display triggerEvent: #screenSizeChanged ]] - ifFalse: [ - UISupervisor whenUIinSafeState: [ - guiRootObject restoreDisplay. - Display triggerEvent: #screenSizeChanged ]]. - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - UISupervisor whenUIinSafeState: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]] - forkAt: Processor timingPriority - 1 - named: 'Startup process'.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4359-FixStartupGlitches-JuanVuletich-2020Aug21-19h24m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4359] on 21 August 2020 at 9:08:32 pm'! - -Transcript class - instanceVariableNames: 'entries firstIndex lastIndex accessSemaphore unfinishedEntry logToFile showOnDisplay lastDisplayPosition bounds logToStdout displayCanvas '! - -!classDefinition: 'Transcript class' category: #'System-Support' stamp: 'Install-4360-TranscriptEnhancements-JuanVuletich-2020Aug21-20h58m-jmv.001.cs.st 8/22/2020 11:13:31'! -Transcript class - instanceVariableNames: 'entries firstIndex lastIndex accessSemaphore unfinishedEntry logToFile showOnDisplay lastDisplayPosition bounds logToStdout displayCanvas'! - -RectangleLikeMorph subclass: #TranscriptMorph - instanceVariableNames: 'form workspace lastIncludedIndex workspaceWindow lastUnfinishedEntrySize doImmediateUpdates ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #TranscriptMorph category: #'Morphic-Widgets' stamp: 'Install-4360-TranscriptEnhancements-JuanVuletich-2020Aug21-20h58m-jmv.001.cs.st 8/22/2020 11:13:31'! -RectangleLikeMorph subclass: #TranscriptMorph - instanceVariableNames: 'form workspace lastIncludedIndex workspaceWindow lastUnfinishedEntrySize doImmediateUpdates' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! -!Transcript class methodsFor: 'private' stamp: 'jmv 8/21/2020 21:08:10'! - canvas - - (displayCanvas isNil or: [ - displayCanvas class ~= MorphicCanvas activeSubclass]) ifTrue: [ - displayCanvas _ Display getCanvas ]. - ^ displayCanvas! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 8/21/2020 19:51:49'! - displayOnCanvas: aCanvas - " - 1 to: 2000 do: [ :i | i print ]. - 1 to: 750 do: [ :i | i print ]. - Transcript displayOn: Display in: bounds - " - | font count string x y fh innerR index | - "aCanvas form fill: aRectangle fillColor: `Color white`." - font _ FontFamily defaultFamilyAndPointSize. - - "innerR _ aRectangle insetBy: self padding." - innerR _ 0@0 extent: 100@100. - aCanvas newClipRect: innerR. - x _ innerR left. - y _ innerR top. - fh _ font lineSpacing. - count _ lastIndex - firstIndex \\ self maxEntries + 1 min: innerR height // fh - 1. - index _ lastIndex - count \\ self maxEntries + 1. - count timesRepeat: [ - string _ entries at: index. - aCanvas drawString: string at: x@y font: font color: `Color veryDarkGray`. - y _ y + fh. - index _ index \\ self maxEntries + 1 ]. - string _ unfinishedEntry contents. - aCanvas drawString: string at: x@y font: font color: `Color veryDarkGray`! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 8/21/2020 19:59:46'! - displayOnCanvas: aCanvas in: aRectangle - " - 1 to: 2000 do: [ :i | i print ]. - 1 to: 750 do: [ :i | i print ]. - Transcript displayOn: Display in: bounds - " - | font count string x y fh innerR index | - aCanvas - fillRectangle: aRectangle - color: `Color white`. - font _ FontFamily defaultFamilyAndPointSize. - innerR _ aRectangle insetBy: self padding. - x _ innerR left. - y _ innerR top. - fh _ font lineSpacing. - count _ lastIndex - firstIndex \\ self maxEntries + 1 min: innerR height // fh - 1. - index _ lastIndex - count \\ self maxEntries + 1. - count timesRepeat: [ - string _ entries at: index. - aCanvas drawString: string at: x@y font: font color: `Color veryDarkGray`. - y _ y + fh. - index _ index \\ self maxEntries + 1 ]. - string _ unfinishedEntry contents. - aCanvas drawString: string at: x@y font: font color: `Color veryDarkGray`! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 8/21/2020 19:48:07'! - displayUnfinishedEntryOnCanvas: aCanvas - - | font count string x y fh r innerR | - innerR _ bounds insetBy: self padding. - lastDisplayPosition < innerR right ifTrue: [ - font _ FontFamily defaultFamilyAndPointSize. - fh _ font lineSpacing. - count _ innerR height // fh-1. - x _ innerR left. - string _ unfinishedEntry contents. - y _ ((lastIndex - firstIndex \\ self maxEntries) min: count-1) + 1 * font lineSpacing + innerR top. - r _ innerR left: lastDisplayPosition. - aCanvas newClipRect: r. - (aCanvas drawString: string at: x@y font: font color: `Color veryDarkGray`) ifNotNil: [ :lastPoint | - lastDisplayPosition _ lastPoint x. - ^r ]]. - ^nil! ! -!Transcript class methodsFor: 'system startup' stamp: 'jmv 8/21/2020 21:06:26' overrides: 50510042! - releaseClassCachedState - displayCanvas _ nil! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 8/21/2020 20:13:23' prior: 16938463! - display - | c innerR | - showOnDisplay ifTrue: [ - innerR _ bounds insetBy: self padding. - c _ self canvas. - c setClipRect: innerR. - self displayOnCanvas: c in: bounds. - DisplayScreen screenUpdateRequired: bounds ]. - "So any morph in front of us is repaired when Morphic cycles. - This includes, for instance, the TranscriptWindow that shows our contents if showOnDisplay is false" - self triggerEvent: #redraw! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 8/21/2020 20:13:32' prior: 16938504! - displayUnfinishedEntry - showOnDisplay ifTrue: [ - (self displayUnfinishedEntryOnCanvas: self canvas) ifNotNil: [ :damage | - DisplayScreen screenUpdateRequired: damage ]]! ! -!TranscriptMorph methodsFor: 'drawing' stamp: 'jmv 8/21/2020 20:08:05' prior: 50535163 overrides: 16899205! - drawOn: aCanvas - Transcript showOnDisplay: true. - aCanvas clippingByCurrentMorphDo: [ - Transcript displayOnCanvas: aCanvas in: self morphLocalBounds ]. - self displayBounds ifNotNil: [ :r | - Transcript bounds:r ]. - Transcript - showOnDisplay: doImmediateUpdates. - self updateWorkspace! ! - -TranscriptMorph removeSelector: #privateExtent:! - -!methodRemoval: TranscriptMorph #privateExtent: stamp: 'Install-4360-TranscriptEnhancements-JuanVuletich-2020Aug21-20h58m-jmv.001.cs.st 8/22/2020 11:13:31'! -privateExtent: aPoint - - ^ (super privateExtent: aPoint) - ifTrue: [ - (form isNil or: [ form extent ~= aPoint ]) ifTrue: [ - form _ Form extent: aPoint depth: Display depth ]]; yourself! - -Transcript class removeSelector: #displayOn:in:! - -!methodRemoval: Transcript class #displayOn:in: stamp: 'Install-4360-TranscriptEnhancements-JuanVuletich-2020Aug21-20h58m-jmv.001.cs.st 8/22/2020 11:13:31'! -displayOn: aForm in: aRectangle - " - 1 to: 2000 do: [ :i | i print ]. - 1 to: 750 do: [ :i | i print ]. - Transcript displayOn: Display in: bounds - " - | font count string x y fh canvas innerR index | - aForm fill: aRectangle fillColor: `Color white`. - font _ FontFamily defaultFamilyAndPointSize. - - innerR _ aRectangle insetBy: self padding. - canvas _ aForm getCanvas. - canvas newClipRect: innerR. - x _ innerR left. - y _ innerR top. - fh _ font lineSpacing. - count _ lastIndex - firstIndex \\ self maxEntries + 1 min: innerR height // fh - 1. - index _ lastIndex - count \\ self maxEntries + 1. - count timesRepeat: [ - string _ entries at: index. - canvas drawString: string at: x@y font: font color: `Color veryDarkGray`. - y _ y + fh. - index _ index \\ self maxEntries + 1 ]. - string _ unfinishedEntry contents. - canvas drawString: string at: x@y font: font color: `Color veryDarkGray`! - -Transcript class removeSelector: #displayUnfinishedEntryOn:! - -!methodRemoval: Transcript class #displayUnfinishedEntryOn: stamp: 'Install-4360-TranscriptEnhancements-JuanVuletich-2020Aug21-20h58m-jmv.001.cs.st 8/22/2020 11:13:31'! -displayUnfinishedEntryOn: aForm - - | font count string x y fh canvas r innerR | - innerR _ bounds insetBy: self padding. - lastDisplayPosition < innerR right ifTrue: [ - font _ FontFamily defaultFamilyAndPointSize. - fh _ font lineSpacing. - count _ innerR height // fh-1. - x _ innerR left. - string _ unfinishedEntry contents. - y _ ((lastIndex - firstIndex \\ self maxEntries) min: count-1) + 1 * font lineSpacing + innerR top. - canvas _ aForm getCanvas. - r _ innerR left: lastDisplayPosition. - canvas newClipRect: r. - (canvas drawString: string at: x@y font: font color: `Color veryDarkGray`) ifNotNil: [ :lastPoint | - lastDisplayPosition _ lastPoint x. - ^r ]]. - ^nil! - -Transcript class - instanceVariableNames: 'entries firstIndex lastIndex accessSemaphore unfinishedEntry logToFile showOnDisplay lastDisplayPosition bounds logToStdout displayCanvas'! - -!classDefinition: 'Transcript class' category: #'System-Support' stamp: 'Install-4360-TranscriptEnhancements-JuanVuletich-2020Aug21-20h58m-jmv.001.cs.st 8/22/2020 11:13:31'! -Transcript class - instanceVariableNames: 'entries firstIndex lastIndex accessSemaphore unfinishedEntry logToFile showOnDisplay lastDisplayPosition bounds logToStdout displayCanvas'! - -RectangleLikeMorph subclass: #TranscriptMorph - instanceVariableNames: 'workspace lastIncludedIndex workspaceWindow lastUnfinishedEntrySize doImmediateUpdates' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #TranscriptMorph category: #'Morphic-Widgets' stamp: 'Install-4360-TranscriptEnhancements-JuanVuletich-2020Aug21-20h58m-jmv.001.cs.st 8/22/2020 11:13:31'! -RectangleLikeMorph subclass: #TranscriptMorph - instanceVariableNames: 'workspace lastIncludedIndex workspaceWindow lastUnfinishedEntrySize doImmediateUpdates' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4360-TranscriptEnhancements-JuanVuletich-2020Aug21-20h58m-jmv.001.cs.st----! - -----SNAPSHOT----(22 August 2020 11:13:35) Cuis5.0-4360-v3.image priorSource: 6697626! - -----STARTUP---- (15 October 2020 19:34:04) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4360-v3.image! - - -'From Cuis 5.0 [latest update: #4360] on 22 August 2020 at 4:48:30 pm'! -!Morph methodsFor: 'dropping/grabbing' stamp: 'jmv 8/22/2020 16:40:53' prior: 16876016! -acceptDroppingMorph: aMorph event: evt - "This message is sent when a morph is dropped onto a morph that has agreed to accept the dropped morph by responding 'true' to the wantsDroppedMorph:event: message. This default implementation just adds the given morph to the receiver." - - self addMorph: aMorph! ! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'jmv 8/22/2020 16:35:34' prior: 16899214 overrides: 50384193! - morphExtent - "In our own coordinates!!" - - ^ extent! ! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'jmv 8/22/2020 16:36:56' prior: 16899258! - morphHeight: aNumber - - self morphExtent: extent x@aNumber! ! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'jmv 8/22/2020 16:37:29' prior: 16899302! - morphWidth: aNumber - - self morphExtent: aNumber@extent y! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4361-Morph-helper-methods-JuanVuletich-2020Aug22-16h35m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4361] on 23 August 2020 at 9:26:22 pm'! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 8/23/2020 21:26:07' prior: 50494859! - fillRectangle: aRectangle tilingWith: aForm sourceRect: patternBox rule: aCombinationRule - - | displayRectangle additionalOffset clippedEngine targetTopLeft clipOffset ex - targetBox savedMap top left | - - engine ifNil: [ ^nil ]. - - ex _ patternBox extent. - ex x = 0 ifTrue: [ ^self ]. - ex y = 0 ifTrue: [ ^self ]. - displayRectangle _ (currentTransformation externalizeRectangle: aRectangle) rounded. - - "this is a bit of a kludge to get the form to be aligned where I *think* it should be. - something better is needed, but not now" - - additionalOffset _ `0@0`. - clippedEngine _ engine clippedBy: displayRectangle. - targetTopLeft _ clippedEngine clipRect topLeft truncateTo: ex. - clipOffset _ displayRectangle topLeft - targetTopLeft. - additionalOffset _ (clipOffset \\ ex) - ex. - - "do it iteratively" - targetBox _ clippedEngine clipRect. - savedMap _ clippedEngine colorMap. - clippedEngine sourceForm: aForm; - fillColor: nil; - combinationRule: aCombinationRule; - sourceRect: patternBox; - colorMap: (aForm colormapIfNeededFor: clippedEngine destForm). - top _ (targetBox top truncateTo: patternBox height) + additionalOffset y. - left _ (targetBox left truncateTo: patternBox width) + additionalOffset x. - - left to: (targetBox right - 1) by: patternBox width do: [:x | - top to: (targetBox bottom - 1) by: patternBox height do: [:y | - clippedEngine destOrigin: x@y; copyBits]]. - clippedEngine colorMap: savedMap! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4362-BitBltEngine-fix-JuanVuletich-2020Aug23-21h25m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4362] on 28 August 2020 at 8:36:03 pm'! -!Editor methodsFor: 'new selection' stamp: 'jmv 8/28/2020 20:35:53' prior: 50467327! - wordRangeLeftDelimiters: leftDelimiters rightDelimiters: rightDelimiters - "Select delimited text or word--the result of double-clicking." - - ^ self - wordRangeLeftDelimiters: leftDelimiters - rightDelimiters: rightDelimiters - startingAt: self pointIndex + self markIndex // 2.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4363-fixSelectWordAnnoyance-JuanVuletich-2020Aug28-20h35m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4362] on 28 August 2020 at 8:58:47 pm'! - -MessageSetWindow removeSelector: #activateAndSendTopToBack:! - -!methodRemoval: MessageSetWindow #activateAndSendTopToBack: stamp: 'Install-4364-fixMessageSetClickOnFirstItemToFocusAndSelectAnnoyance-JuanVuletich-2020Aug28-20h36m-jmv.001.cs.st 10/15/2020 19:34:09'! -activateAndSendTopToBack: aBoolean - super activateAndSendTopToBack: aBoolean. - (model messageListIndex = 0 and: [ model messageList notEmpty ]) - ifTrue: [ - model messageListIndex: 1 ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4364-fixMessageSetClickOnFirstItemToFocusAndSelectAnnoyance-JuanVuletich-2020Aug28-20h36m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4364] on 30 August 2020 at 6:56:19 pm'! -!CodeWindow methodsFor: 'updating' stamp: 'HAW 8/30/2020 18:28:24'! - classAdded: addedClass - - "Keep default behavior. Subclasses like BrowserWindow, redefine it - Hernan" - self updateListsAndCode ! ! -!BrowserWindow methodsFor: 'updating' stamp: 'HAW 8/30/2020 18:31:12' overrides: 50541942! - classAdded: addedClass - - self model selectedSystemCategoryName = addedClass category - ifTrue: [ self model changed: #classList ]! ! -!Parser methodsFor: 'error correction' stamp: 'HAW 8/30/2020 18:33:15' prior: 50466457! - correctVariable: proposedVariable interval: aSpot - "Correct the proposedVariable to a known variable, or declare it as a new - variable if such action is requested. We support declaring lowercase - variables as temps or inst-vars, and uppercase variables as Globals or - ClassVars, depending on whether the context is nil (class=UndefinedObject). - Spot is the interval within the test stream of the variable. - rr 3/4/2004 10:26 : adds the option to define a new class. " - - "Check if this is an i-var, that has been corrected already (ugly)" - - "Display the pop-up menu" - - | userSelection action delta spot | - (encoder classEncoding instVarNames includes: proposedVariable) ifTrue: [ - ^InstanceVariableNode new - name: proposedVariable - index: (encoder classEncoding allInstVarNames indexOf: proposedVariable)]. - - "First check to see if the requestor knows anything about the variable" - (requestor bindingOf: proposedVariable) - ifNotNil: [ :binding | ^ encoder global: binding name: proposedVariable]. - - "If we can't ask the user for correction, make it undeclared" - self interactive ifFalse: [^encoder undeclared: proposedVariable]. - - userSelection _ requestor selectionInterval. - delta _ self sourceDelta. - spot _ aSpot first - delta to: aSpot last - delta. - requestor selectFrom: spot first to: spot last. - - "Build the menu with alternatives" - action _ UndeclaredVariable - signalFor: self - name: proposedVariable - inRange: spot. - action ifNil: [^self fail]. - - "Execute the selected action" - requestor selectInvisiblyFrom: userSelection first to: userSelection last. - ^action value ifNil: [self fail]. - ! ! -!Parser methodsFor: 'error correction' stamp: 'HAW 8/30/2020 18:54:32' prior: 50514611! - defineClass: className - "prompts the user to define a new class, - asks for it's category, and lets the users edit further - the definition" - | classNameAsSymbol classCategory classDefinition userClassDefinition newClass | - - classNameAsSymbol := className asSymbol. - classCategory := self - request: 'Enter class category:' - initialAnswer: self encoder classEncoding theNonMetaClass category - orCancel: [ ^nil ]. - classCategory ifEmpty: [classCategory := 'Unknown']. - - classDefinition := 'Object subclass: #' , classNameAsSymbol , ' - instanceVariableNames: '''' - classVariableNames: '''' - poolDictionaries: '''' - category: ''' , classCategory , ''''. - userClassDefinition := self - request: 'Edit class definition:' - initialAnswer: classDefinition - orCancel: [ ^nil ]. - userClassDefinition ifEmpty: [userClassDefinition := classDefinition]. - - ^[ newClass := Compiler evaluate: userClassDefinition. - (newClass isKindOf: Behavior) - ifTrue: [ - encoder - global: (Smalltalk associationAt: classNameAsSymbol) - name: classNameAsSymbol] - ifFalse: [ - self inform: - ('The provided class definition did not created a class but\the object: ', newClass printString) withNewLines. - nil ]] - on: Error - do: [ :anError | - self inform: ('There is an error in the provided class definition:\', anError description) withNewLines. - anError return: nil ]. - - ! ! -!CodeWindow methodsFor: 'notification actions' stamp: 'HAW 8/30/2020 18:27:15' prior: 50496032! - registerNotificationActions - - SystemChangeNotifier uniqueInstance - when: #classAdded send: #classAdded: to: self; - when: #classCommented send: #updateListsAndCode to: self; - when: #classDefinitionChanged send: #updateListsAndCode to: self; - when: #classRecategorized send: #updateListsAndCode to: self; - when: #classRemoved send: #updateListsAndCode to: self; - when: #classRenamed send: #classRenamed:from:to:inCategory: to: self; - when: #classReorganized send: #updateListsAndCode to: self; - when: #methodAddedInProtocol send: #updateListsAndCode to: self; - when: #methodChanged send: #updateListsAndCode to: self; - when: #methodRemoved send: #updateListsAndCode to: self; - when: #selectorRecategorized send: #updateListsAndCode to: self ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4365-BetterClassCreationFeedback-HernanWilkinson-2020Aug29-18h09m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4365] on 3 September 2020 at 5:18:06 pm'! - -Smalltalk renameClassNamed: #FloatArray as: #Float32Array! - -!classRenamed: #FloatArray as: #Float32Array stamp: 'Install-4366-RenameFloatArrayAsFloat32Array-JuanVuletich-2020Sep03-17h12m-jmv.001.cs.st 10/15/2020 19:34:09'! -Smalltalk renameClassNamed: #FloatArray as: #Float32Array! -!Float32Array commentStamp: '' prior: 16846402! - Float32Arrays store 32bit IEEE floating point numbers.! -!Float64Array commentStamp: '' prior: 50376949! - Float64Arrays store 64bit IEEE floating point numbers, i.e. instances of the Float class. -Some support is included for subclasses in the style of Balloon3D-Math. - -Uses the same internal representation as Float. I.e. a Float and a Float64Array of size 1 hold the same bits. See #floatAt: and #floatAt:put:! -!Float methodsFor: 'converting' stamp: 'jmv 9/3/2020 17:15:41' prior: 50418615! - asIEEE32BitWord - "Convert the receiver into a 32 bit Integer value representing the same number in IEEE 32 bit format. - Used for conversion in Float32Arrays only." - - | word1 word2 sign mantissa exponent destWord truncatedBits mask roundToUpper | - - "quickly skip positive and negative zero" - self isZero ifTrue: [^self basicAt: 1]. - - "retrieve 64 bits of IEEE 754 double" - word1 := self basicAt: 1. - word2 := self basicAt: 2. - - "prepare sign exponent and mantissa of 32 bits float" - sign := word1 bitAnd: 16r80000000. - exponent := ((word1 bitShift: -20) bitAnd: 16r7FF) - 1023 + 127. - mantissa := (word2 bitShift: -29) + ((word1 bitAnd: 16rFFFFF) bitShift: 3). - truncatedBits := (word2 bitAnd: 16r1FFFFFFF). - - "We must now honour default IEEE rounding mode (round to nearest even)" - - "we are below gradual underflow, even if rounded to upper mantissa" - exponent < -24 ifTrue: [^sign "this can be negative zero"]. - - "BEWARE: rounding occurs on less than 23bits when gradual underflow" - exponent <= 0 - ifTrue: - [mask := 1 bitShift: exponent negated. - mantissa := mantissa bitOr: 16r800000. - roundToUpper := (mantissa bitAnd: mask) isZero not - and: [truncatedBits isZero not - or: [(mantissa bitAnd: mask - 1) isZero not - or: [(mantissa bitAnd: mask*2) isZero not]]]. - mantissa := mantissa bitShift: exponent - 1. - "exponent := exponent + 1"] - ifFalse: - [roundToUpper := (truncatedBits bitAnd: 16r10000000) isZero not - and: [(mantissa bitAnd: 16r1) isZero not - or: [(truncatedBits bitAnd: 16r0FFFFFFF) isZero not]] - ]. - - "adjust mantissa and exponent due to IEEE rounding mode" - roundToUpper - ifTrue: - [mantissa := mantissa + 1. - mantissa > 16r7FFFFF - ifTrue: - [mantissa := 0. - exponent := exponent+1]]. - - exponent > 254 ifTrue: ["Overflow" - exponent := 255. - self isNaN - ifTrue: [mantissa isZero - ifTrue: ["BEWARE: do not convert a NaN to infinity due to truncatedBits" - mantissa := 1]] - ifFalse: [mantissa := 0]]. - - "Encode the word" - destWord := (sign bitOr: ((exponent max: 0) bitShift: 23)) bitOr: mantissa. - ^ destWord! ! -!Float class methodsFor: 'instance creation' stamp: 'jmv 9/3/2020 17:15:47' prior: 50451374! - fromIEEE32Bit: word - "Convert the given 32 bit word (which is supposed to be a positive 32bit value) from - a 32bit IEEE floating point representation into an actual Float object (being - 64bit wide). Should only be used for conversion in Float32Arrays or likewise objects." - - | sign exponent mantissa exponentBits fractionBits answerFractionBits delta signBit answerExponent | - word negative ifTrue: [ ^ self error: 'Cannot deal with negative numbers' ]. - word = 0 ifTrue: [ ^ Float zero ]. - word = 16r80000000 ifTrue: [ ^Float negativeZero ]. - - signBit _ word bitAnd: 16r80000000. - sign _ (word bitShift: -31) = 0 ifTrue: [1] ifFalse: [-1]. - exponentBits _ (word bitShift: -23) bitAnd: 16rFF. - fractionBits _ word bitAnd: 16r7FFFFF. - - " Special cases: infinites and NaN" - exponentBits = 16rFF ifTrue: [ - fractionBits = 0 ifFalse: [ ^ Float nan ]. - ^ sign positive - ifTrue: [ Float infinity ] - ifFalse: [ Float negativeInfinity ]]. - - " Unbias exponent: 16r3FF is bias" - exponent _ exponentBits - 16r7F. - -"Older version." -false ifTrue: [ - " Replace omitted leading 1 in fraction if appropriate" - "If expPart = 0, I am +/-zero or a denormal value. In such cases, no implicit leading bit in mantissa" - exponentBits = 0 - ifTrue: [ - "gradual underflow (denormalized number) - There is no implied one, but the exponent is -126" - mantissa _ fractionBits. - answerExponent _ exponent + 1 ] - ifFalse: [ - mantissa _ fractionBits + 16r800000. - answerExponent _ exponent ]. - ^ (sign * mantissa) asFloat timesTwoPower: answerExponent - 23 ]. - - "Newer version" - exponentBits = 0 - ifTrue: [ - "gradual underflow (denormalized number) - Remove first bit of mantissa and adjust exponent" - delta := fractionBits highBit. - answerFractionBits := (fractionBits bitAnd: (1 bitShift: delta - 1) - 1) bitShift: 24 - delta. - answerExponent := exponent + delta - 23] - ifFalse: [ - answerFractionBits _ fractionBits. - answerExponent _ exponent ]. - - "Create new float" - ^ (self basicNew: 2) - basicAt: 1 put: ((signBit bitOr: (1023 + answerExponent bitShift: 20)) bitOr: (answerFractionBits bitShift: -3)); - basicAt: 2 put: ((answerFractionBits bitAnd: 7) bitShift: 29); - * 1.0. "reduce to SmallFloat64 if possible" - -" -Float fromIEEE32Bit: Float pi asIEEE32BitWord -(Float fromIEEE32Bit: Float pi asIEEE32BitWord ) = Float pi -(Float fromIEEE32Bit: Float pi asIEEE32BitWord ) - Float pi - -Float fromIEEE32Bit: (Float pi / 1e40) asIEEE32BitWord -(Float fromIEEE32Bit: (Float pi / 1e40) asIEEE32BitWord) = (Float pi / 1e40) -(Float fromIEEE32Bit: (Float pi / 1e40) asIEEE32BitWord) - (Float pi / 1e40) -"! ! -!Collection methodsFor: 'converting' stamp: 'jmv 9/3/2020 17:12:45' prior: 16814057! - asFloatArray - "Answer a FloatArray whose elements are the elements of the receiver" - - ^self as: Float32Array! ! -!Float32Array methodsFor: 'testing' stamp: 'jmv 9/3/2020 17:12:44' prior: 16846657 overrides: 50468400! - is: aSymbol - ^ aSymbol == #Float32Array or: [ super is: aSymbol ]! ! -!Float64Array methodsFor: 'converting' stamp: 'jmv 9/3/2020 17:12:45' prior: 16846338! - asIEEE32BitPrecisionFloat - | answer s | - self class == Float64Array ifFalse: [ - self error: 'please implement' ]. - s _ self size. - answer _ Float32Array new: s. - 1 to: s do: [ :i | answer at: i put: (self at: i) ]. - ^answer! ! -!DataStream class methodsFor: 'as yet unclassified' stamp: 'jmv 9/3/2020 17:12:45' prior: 16827969! - initCachedState - "TypeMap maps Smalltalk classes to type ID numbers which identify the data stream primitive formats. nextPut: writes these IDs to the data stream. NOTE: Changing these type ID numbers will invalidate all extant data stream files. Adding new ones is OK. - Classes named here have special formats in the file. If such a class has a subclass, it will use type 9 and write correctly. It will just be slow. (Later write the class name in the special format, then subclasses can use the type also.) - See nextPut:, next, typeIDFor:, & ReferenceStream>>isAReferenceType:" - " - DataStream initCachedState - " - - | refTypes t | - refTypes _ OrderedCollection new. - t _ TypeMap _ Dictionary new: 80. "sparse for fast hashing" - - t at: UndefinedObject put: 1. refTypes add: 0. - t at: True put: 2. refTypes add: 0. - t at: False put: 3. refTypes add: 0. - t at: SmallInteger put: 4. refTypes add: 0. - t at: String put: 5. refTypes add: 1. - t at: Symbol put: 6. refTypes add: 1. - t at: ByteArray put: 7. refTypes add: 1. - t at: Array put: 8. refTypes add: 1. - "(type ID 9 is for arbitrary instances of any class, cf. typeIDFor:)" - refTypes add: 1. - "(type ID 10 is for references, cf. ReferenceStream>>tryToPutReference:)" - refTypes add: 0. - t at: Bitmap put: 11. refTypes add: 1. - - t at: Metaclass put: 12. refTypes add: 0. - "Type ID 13 is used for HyperSqueak User classes that must be reconstructed." - refTypes add: 1. - - t at: Float put: 14. refTypes add: 1. - t at: BoxedFloat64 put: 14. - t at: SmallFloat64 put: 14. - - "15: Deprecated compact Rects." - refTypes add: 1. - - "type ID 16 is an instance with short header. See beginInstance:size:" - refTypes add: 1. - - t at: String put: 17. refTypes add: 1. "new String format, 1 or 4 bytes of length" - t at: WordArray put: 18. refTypes add: 1. "bitmap-like" - "t at: WordArrayForSegment put: 19." refTypes add: 1. "bitmap-like" - t at: Float32Array put: 20. refTypes add: 1. "And all other word arrays, both 16-bit and 32-bit. See methods in ArrayedCollection. Overridden in SoundBuffer." - "For all classes that are like WordArrays, store them the way ColorArray is stored. As bits, and able to change endianness." - Smalltalk do: [:cls | - cls isInMemory ifTrue: [ - cls isBehavior ifTrue: [ - cls isPointers not & cls isVariable & cls isWords ifTrue: [ - (t includesKey: cls) ifFalse: [t at: cls put: 20]]]]]. - - t at: CompiledMethod put: 21. refTypes add: 1. "special creation method" - - t at: Character put: 22. refTypes add: 0. - - "t at: put: 23. refTypes add: 0." - ReferenceTypes _ refTypes. "save it"! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4366-RenameFloatArrayAsFloat32Array-JuanVuletich-2020Sep03-17h12m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4365] on 3 September 2020 at 5:22:26 pm'! - -ArrayedCollection subclass: #FloatArray - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Collections-Arrayed'! - -!classDefinition: #FloatArray category: #'Collections-Arrayed' stamp: 'Install-4367-CreateAbstractFloatArrayClass-JuanVuletich-2020Sep03-17h18m-jmv.001.cs.st 10/15/2020 19:34:09'! -ArrayedCollection subclass: #FloatArray - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Collections-Arrayed'! -!FloatArray commentStamp: '' prior: 0! - Common behavior of Float32Array and Float64Array! - -FloatArray variableWordSubclass: #Float32Array - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Collections-Arrayed'! - -!classDefinition: #Float32Array category: #'Collections-Arrayed' stamp: 'Install-4367-CreateAbstractFloatArrayClass-JuanVuletich-2020Sep03-17h18m-jmv.001.cs.st 10/15/2020 19:34:09'! -FloatArray variableWordSubclass: #Float32Array - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Collections-Arrayed'! -!Float32Array commentStamp: '' prior: 50542100! - Common behavior of Float32Array and Float64Array.! - -FloatArray variableWordSubclass: #Float64Array - instanceVariableNames: '' - classVariableNames: 'LastSaveOrder ' - poolDictionaries: '' - category: 'Collections-Arrayed'! - -!classDefinition: #Float64Array category: #'Collections-Arrayed' stamp: 'Install-4367-CreateAbstractFloatArrayClass-JuanVuletich-2020Sep03-17h18m-jmv.001.cs.st 10/15/2020 19:34:09'! -FloatArray variableWordSubclass: #Float64Array - instanceVariableNames: '' - classVariableNames: 'LastSaveOrder' - poolDictionaries: '' - category: 'Collections-Arrayed'! - -FloatArray variableWordSubclass: #Float64Array - instanceVariableNames: '' - classVariableNames: 'LastSaveOrder' - poolDictionaries: '' - category: 'Collections-Arrayed'! - -!classDefinition: #Float64Array category: #'Collections-Arrayed' stamp: 'Install-4367-CreateAbstractFloatArrayClass-JuanVuletich-2020Sep03-17h18m-jmv.001.cs.st 10/15/2020 19:34:09'! -FloatArray variableWordSubclass: #Float64Array - instanceVariableNames: '' - classVariableNames: 'LastSaveOrder' - poolDictionaries: '' - category: 'Collections-Arrayed'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4367-CreateAbstractFloatArrayClass-JuanVuletich-2020Sep03-17h18m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4367] on 3 September 2020 at 5:47:35 pm'! -!FloatArray methodsFor: 'arithmetic' stamp: 'jmv 5/14/2015 09:52' overrides: 16813985! - * anObject - - ^self copy *= anObject! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:49'! - *= anObject - ^anObject isNumber - ifTrue:[self primMulScalar: anObject asFloat] - ifFalse:[self primMulArray: anObject]! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'jmv 5/14/2015 09:52' overrides: 16813989! - + anObject - - ^self copy += anObject! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:48' overrides: 50332829! - += anObject - ^anObject isNumber - ifTrue:[self primAddScalar: anObject asFloat] - ifFalse:[self primAddArray: anObject]! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'jmv 5/14/2015 09:52' overrides: 16813993! - - anObject - - ^self copy -= anObject! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:49' overrides: 50332838! - -= anObject - ^anObject isNumber - ifTrue:[self primSubScalar: anObject asFloat] - ifFalse:[self primSubArray: anObject]! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'jmv 5/14/2015 09:52' overrides: 16813997! - / anObject - - ^self copy /= anObject! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'jmv 6/25/2019 17:43:52'! - /= anObject - - ^self divideBy: anObject - ifDivisorZero: [ZeroDivide new signalReceiver: self selector: #/= argument: anObject] - ifBothZero: [ZeroDivide new signalReceiver: self selector: #/= argument: anObject]! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'yo 9/14/2004 17:12'! - \\= 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). - ]. - -! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'nice 11/24/2007 00:10' overrides: 16813942! - 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:[ - "DO NOT USE TRIVIAL CODE - ^self reciprocal * rcvr - BECAUSE OF GRADUAL UNDERFLOW - self should: (1.0e-39 / (FloatArray with: 1.0e-39)) first < 2." - ^(self class new: self size withAll: rcvr) / self - ]. - ^super adaptToNumber: rcvr andSend: selector! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'jmv 7/9/2018 09:41:43'! - divideBy: aFloatArrayOrNumber ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue - ^aFloatArrayOrNumber isNumber - ifTrue:[self divideByScalar: aFloatArrayOrNumber asFloat ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue] - ifFalse:[self divideByArray: aFloatArrayOrNumber ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue]! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'jmv 5/14/2015 09:52' overrides: 16814551! - negated - - ^self copy *= -1! ! -!FloatArray methodsFor: 'accessing' stamp: 'jmv 2/28/2020 12:11:02' overrides: 16880774! - at: index - ^self floatAt: index! ! -!FloatArray methodsFor: 'accessing' stamp: 'jmv 2/28/2020 12:10:34' overrides: 16880792! - at: index put: value - ^self floatAt: index put: value! ! -!FloatArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:19' overrides: 16780286! - defaultElement - "Return the default element of the receiver" - ^0.0! ! -!FloatArray methodsFor: 'accessing' stamp: 'laza 3/24/2000 13:08'! - length - "Return the length of the receiver" - ^self squaredLength sqrt! ! -!FloatArray methodsFor: 'accessing' stamp: 'laza 3/24/2000 13:08'! - squaredLength - "Return the squared length of the receiver" - ^self dot: self! ! -!FloatArray methodsFor: 'interpolating' stamp: 'jmv 9/28/2017 13:36:31'! - interpolateValues: valuesArray at: x - "Interpret self as a domain and valuesArray as a function samples." - - ^self - findBinaryIndex: [ :arg | x - arg ] - do: [ :i | valuesArray at: i ] - ifNone: [ :i :j | - ((valuesArray at: i) interpolateTo: (valuesArray at: j) at: (x - (self at: i)) / ((self at: j) - (self at: i)))]! ! -!FloatArray methodsFor: 'interpolating' stamp: 'jmv 5/6/2015 15:02'! - interpolatedValueAt: floatIndex - "Do a linear interpolation. - Gives usual error if argument outside bounds: - #[ 4 5 ] asFloatArray interpolatedValueAt: 0.999 - #[ 4 5 ] asFloatArray interpolatedValueAt: 1.0 - #[ 4 5 ] asFloatArray interpolatedValueAt: 1.5 - #[ 4 5 ] asFloatArray interpolatedValueAt: 2.0 - #[ 4 5 ] asFloatArray interpolatedValueAt: 2.000001 - #[ 4 5 ] asFloatArray interpolatedValueAt: 3 - " - | size index0 index1 weight0 weight1 | - - size _ self size. - index0 _ floatIndex truncated. "Could be #floor. But as we only care for values >=1, it is the same. But faster." - - weight1 _ floatIndex - index0. - weight0 _ 1.0 - weight1. - - index1 _ (index0 = size and: [ weight1 = 0.0 ]) "Avoid the invalid access if this was true, but don't make it slower the most common, general case." - ifFalse: [ index0 + 1 ] - ifTrue: [ index0 ]. - - "/* perform interpolation */" - ^ (weight0 * (self at: index0)) + (weight1 * (self at: index1))! ! -!FloatArray methodsFor: 'inspecting' stamp: 'sqr 5/22/2020 19:53:21' overrides: 16881790! - inspectorClass - "Answer the class of the inspector to be used on the receiver. Called by inspect; - use basicInspect to get a normal (less useful) type of inspector." - - ^SequenceableCollectionInspector! ! - -Float64Array removeSelector: #interpolatedValueAt:! - -!methodRemoval: Float64Array #interpolatedValueAt: stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -interpolatedValueAt: floatIndex - "Do a linear interpolation. - Gives usual error if argument outside bounds: - #[ 4 5 ] asFloatArray interpolatedValueAt: 0.999 - #[ 4 5 ] asFloatArray interpolatedValueAt: 1.0 - #[ 4 5 ] asFloatArray interpolatedValueAt: 1.5 - #[ 4 5 ] asFloatArray interpolatedValueAt: 2.0 - #[ 4 5 ] asFloatArray interpolatedValueAt: 2.000001 - #[ 4 5 ] asFloatArray interpolatedValueAt: 3 - " - | size index0 index1 weight0 weight1 | - - size _ self size. - index0 _ floatIndex truncated. "Could be #floor. But as we only care for values >=1, it is the same. But faster." - - weight1 _ floatIndex - index0. - weight0 _ 1.0 - weight1. - - index1 _ (index0 = size and: [ weight1 = 0.0 ]) "Avoid the invalid access if this was true, but don't make it slower the most common, general case." - ifFalse: [ index0 + 1 ] - ifTrue: [ index0 ]. - - "/* perform interpolation */" - ^ (weight0 * (self at: index0)) + (weight1 * (self at: index1))! - -Float64Array removeSelector: #squaredLength! - -!methodRemoval: Float64Array #squaredLength stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -squaredLength - "Return the squared length of the receiver" - ^self dot: self! - -Float64Array removeSelector: #*! - -!methodRemoval: Float64Array #* stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -* anObject - - ^self copy *= anObject! - -Float64Array removeSelector: #*=! - -!methodRemoval: Float64Array #*= stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -*= anObject - ^anObject isNumber - ifTrue:[self primMulScalar: anObject asFloat] - ifFalse:[self primMulArray: anObject]! - -Float64Array removeSelector: #-=! - -!methodRemoval: Float64Array #-= stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! --= anObject - ^anObject isNumber - ifTrue:[self primSubScalar: anObject asFloat] - ifFalse:[self primSubArray: anObject]! - -Float64Array removeSelector: #+=! - -!methodRemoval: Float64Array #+= stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -+= anObject - ^anObject isNumber - ifTrue:[self primAddScalar: anObject asFloat] - ifFalse:[self primAddArray: anObject]! - -Float64Array removeSelector: #-! - -!methodRemoval: Float64Array #- stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -- anObject - - ^self copy -= anObject! - -Float64Array removeSelector: #at:! - -!methodRemoval: Float64Array #at: stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -at: index - "Return the element (e.g., 64 bit Float) at the given index" - ^self floatAt: index! - -Float64Array removeSelector: #negated! - -!methodRemoval: Float64Array #negated stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -negated - - ^self copy *= -1! - -Float64Array removeSelector: #inspectorClass! - -!methodRemoval: Float64Array #inspectorClass stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -inspectorClass - "Answer the class of the inspector to be used on the receiver. Called by inspect; - use basicInspect to get a normal (less useful) type of inspector." - - ^SequenceableCollectionInspector! - -Float64Array removeSelector: #+! - -!methodRemoval: Float64Array #+ stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -+ anObject - - ^self copy += anObject! - -Float64Array removeSelector: #/=! - -!methodRemoval: Float64Array #/= stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -/= anObject - - ^self divideBy: anObject - ifDivisorZero: [ZeroDivide new signalReceiver: self selector: #/= argument: anObject] - ifBothZero: [ZeroDivide new signalReceiver: self selector: #/= argument: anObject]! - -Float64Array removeSelector: #interpolateValues:at:! - -!methodRemoval: Float64Array #interpolateValues:at: stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -interpolateValues: valuesArray at: x - "Interpret self as a domain and valuesArray as a function samples." - - ^self - findBinaryIndex: [ :arg | x - arg ] - do: [ :i | valuesArray at: i ] - ifNone: [ :i :j | - ((valuesArray at: i) interpolateTo: (valuesArray at: j) at: (x - (self at: i)) / ((self at: j) - (self at: i)))]! - -Float64Array removeSelector: #length! - -!methodRemoval: Float64Array #length stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -length - "Return the length of the receiver" - ^self squaredLength sqrt! - -Float64Array removeSelector: #divideBy:ifDivisorZero:ifBothZero:! - -!methodRemoval: Float64Array #divideBy:ifDivisorZero:ifBothZero: stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -divideBy: aFloatArrayOrNumber ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue - ^aFloatArrayOrNumber isNumber - ifTrue:[self divideByScalar: aFloatArrayOrNumber asFloat ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue] - ifFalse:[self divideByArray: aFloatArrayOrNumber ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue]! - -Float64Array removeSelector: #at:put:! - -!methodRemoval: Float64Array #at:put: stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -at: index put: aFloat - "Store the argument (e.g., 64 bit Float) at the given index" - ^self floatAt: index put: aFloat! - -Float64Array removeSelector: #defaultElement! - -!methodRemoval: Float64Array #defaultElement stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -defaultElement - "Return the default element of the receiver" - ^0.0! - -Float64Array removeSelector: #/! - -!methodRemoval: Float64Array #/ stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -/ anObject - - ^self copy /= anObject! - -Float32Array removeSelector: #interpolatedValueAt:! - -!methodRemoval: Float32Array #interpolatedValueAt: stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -interpolatedValueAt: floatIndex - "Do a linear interpolation. - Gives usual error if argument outside bounds: - #[ 4 5 ] asFloatArray interpolatedValueAt: 0.999 - #[ 4 5 ] asFloatArray interpolatedValueAt: 1.0 - #[ 4 5 ] asFloatArray interpolatedValueAt: 1.5 - #[ 4 5 ] asFloatArray interpolatedValueAt: 2.0 - #[ 4 5 ] asFloatArray interpolatedValueAt: 2.000001 - #[ 4 5 ] asFloatArray interpolatedValueAt: 3 - " - | size index0 index1 weight0 weight1 | - - size _ self size. - index0 _ floatIndex truncated. "Could be #floor. But as we only care for values >=1, it is the same. But faster." - - weight1 _ floatIndex - index0. - weight0 _ 1.0 - weight1. - - index1 _ (index0 = size and: [ weight1 = 0.0 ]) "Avoid the invalid access if this was true, but don't make it slower the most common, general case." - ifFalse: [ index0 + 1 ] - ifTrue: [ index0 ]. - - "/* perform interpolation */" - ^ (weight0 * (self at: index0)) + (weight1 * (self at: index1))! - -Float32Array removeSelector: #squaredLength! - -!methodRemoval: Float32Array #squaredLength stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -squaredLength - "Return the squared length of the receiver" - ^self dot: self! - -Float32Array removeSelector: #+=! - -!methodRemoval: Float32Array #+= stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -+= anObject - ^anObject isNumber - ifTrue:[self primAddScalar: anObject asFloat] - ifFalse:[self primAddArray: anObject]! - -Float32Array removeSelector: #-=! - -!methodRemoval: Float32Array #-= stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! --= anObject - ^anObject isNumber - ifTrue:[self primSubScalar: anObject asFloat] - ifFalse:[self primSubArray: anObject]! - -Float32Array removeSelector: #-! - -!methodRemoval: Float32Array #- stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -- anObject - - ^self copy -= anObject! - -Float32Array removeSelector: #/=! - -!methodRemoval: Float32Array #/= stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -/= anObject - - ^self divideBy: anObject - ifDivisorZero: [ZeroDivide new signalReceiver: self selector: #/= argument: anObject] - ifBothZero: [ZeroDivide new signalReceiver: self selector: #/= argument: anObject]! - -Float32Array removeSelector: #interpolateValues:at:! - -!methodRemoval: Float32Array #interpolateValues:at: stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -interpolateValues: valuesArray at: x - "Interpret self as a domain and valuesArray as a function samples." - - ^self - findBinaryIndex: [ :arg | x - arg ] - do: [ :i | valuesArray at: i ] - ifNone: [ :i :j | - ((valuesArray at: i) interpolateTo: (valuesArray at: j) at: (x - (self at: i)) / ((self at: j) - (self at: i)))]! - -Float32Array removeSelector: #'\\='! - -!methodRemoval: Float32Array #'\\=' stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -\\= 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). - ]. - -! - -Float32Array removeSelector: #at:put:! - -!methodRemoval: Float32Array #at:put: stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -at: index put: value - ^self floatAt: index put: value! - -Float32Array removeSelector: #defaultElement! - -!methodRemoval: Float32Array #defaultElement stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -defaultElement - "Return the default element of the receiver" - ^0.0! - -Float32Array removeSelector: #negated! - -!methodRemoval: Float32Array #negated stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -negated - - ^self copy *= -1! - -Float32Array removeSelector: #*! - -!methodRemoval: Float32Array #* stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -* anObject - - ^self copy *= anObject! - -Float32Array removeSelector: #*=! - -!methodRemoval: Float32Array #*= stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -*= anObject - ^anObject isNumber - ifTrue:[self primMulScalar: anObject asFloat] - ifFalse:[self primMulArray: anObject]! - -Float32Array removeSelector: #at:! - -!methodRemoval: Float32Array #at: stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -at: index - ^self floatAt: index! - -Float32Array removeSelector: #inspectorClass! - -!methodRemoval: Float32Array #inspectorClass stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -inspectorClass - "Answer the class of the inspector to be used on the receiver. Called by inspect; - use basicInspect to get a normal (less useful) type of inspector." - - ^SequenceableCollectionInspector! - -Float32Array removeSelector: #+! - -!methodRemoval: Float32Array #+ stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -+ anObject - - ^self copy += anObject! - -Float32Array removeSelector: #length! - -!methodRemoval: Float32Array #length stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -length - "Return the length of the receiver" - ^self squaredLength sqrt! - -Float32Array removeSelector: #divideBy:ifDivisorZero:ifBothZero:! - -!methodRemoval: Float32Array #divideBy:ifDivisorZero:ifBothZero: stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -divideBy: aFloatArrayOrNumber ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue - ^aFloatArrayOrNumber isNumber - ifTrue:[self divideByScalar: aFloatArrayOrNumber asFloat ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue] - ifFalse:[self divideByArray: aFloatArrayOrNumber ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue]! - -Float32Array removeSelector: #/! - -!methodRemoval: Float32Array #/ stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -/ anObject - - ^self copy /= anObject! - -Float32Array removeSelector: #adaptToNumber:andSend:! - -!methodRemoval: Float32Array #adaptToNumber:andSend: stamp: 'Install-4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -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:[ - "DO NOT USE TRIVIAL CODE - ^self reciprocal * rcvr - BECAUSE OF GRADUAL UNDERFLOW - self should: (1.0e-39 / (FloatArray with: 1.0e-39)) first < 2." - ^(self class new: self size withAll: rcvr) / self - ]. - ^super adaptToNumber: rcvr andSend: selector! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4368-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h28m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4367] on 3 September 2020 at 6:23:25 pm'! -!FloatArray methodsFor: 'arithmetic' stamp: 'jmv 9/3/2020 18:10:25'! - divideByArray: floatArray ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue - - 1 to: self size do: [ :i | | dividend divisor quotient | - dividend _ self at: i. - divisor _ floatArray at: i. - quotient _ - divisor isZero - ifTrue: [ - dividend isZero - ifTrue: indeterminateBlockOrValue - ifFalse: zeroDivisionBlockOrValue ] - ifFalse: [dividend / divisor]. - self at: i put: quotient]! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'jmv 9/3/2020 18:19:30'! - divideByScalar: scalarValue ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue - - "This primitive doesn't fail if argument is zeros, just fills with infinity or nan" - scalarValue isZero ifFalse: [ - ^ self primDivScalar: scalarValue ]. - 1 to: self size do:[:i| | dividend quotient | - dividend _ self at: i. - quotient _ dividend isZero - ifTrue: indeterminateBlockOrValue - ifFalse: zeroDivisionBlockOrValue. - self at: i put: quotient]! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'jmv 9/3/2020 18:20:04'! - dot: aFloatVector - "Return the dot product of the receiver and the argument. - Fail if the argument is not of the same size as the receiver." - - | result | - 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! ! -!FloatArray methodsFor: 'arithmetic' stamp: 'jmv 9/3/2020 18:21:43'! - normalize - "Unsafely normalize the receiver in-place (become a unit vector). - Div-by-Zero raised if len 0." - - self /= self length.! ! -!FloatArray methodsFor: 'comparing' stamp: 'jmv 6/11/2019 16:22:31' overrides: 16905999! - = another - self == another ifTrue: [ ^ true ]. - self class == another class ifFalse: [ ^ false ]. - self size > 256 ifTrue: [ - self hashQuick = another hashQuick ifFalse: [ ^false ]]. - ^self primitiveEqual: another! ! -!FloatArray methodsFor: 'comparing' stamp: 'jmv 6/11/2019 16:10:44' overrides: 50464103! - hash - self size > 256 ifTrue: [ ^ self hashQuick ]. - ^ self hashFull! ! -!FloatArray methodsFor: 'comparing' stamp: 'jmv 9/3/2020 17:59:40'! - hashFull - | hash | - hash _ (self species hash + self size hash) hashMultiply. - 1 to: self size do: [:i | hash _ (hash + (self basicAt: i)) hashMultiply]. - ^hash! ! -!FloatArray methodsFor: 'comparing' stamp: 'jmv 9/3/2020 18:02:29'! - primitiveEqual: aFloatArray - | length | - aFloatArray class == self class ifFalse: [^ false]. - length _ self size. - length = aFloatArray size ifFalse: [^ false]. - 1 to: self size do: [:i | (self at: i) - = (aFloatArray at: i) ifFalse: [^ false]]. - ^ true! ! -!FloatArray methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:20:40'! - primAddArray: floatArray - - 1 to: self size do: [ :i | self at: i put: (self at: i) + (floatArray at: i) ].! ! -!FloatArray methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:20:36'! - primAddScalar: scalarValue - - 1 to: self size do: [ :i | self at: i put: (self at: i) + scalarValue ].! ! -!FloatArray methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:17:07'! - primDivArray: floatArray - "Actually only called for Float32Array that redefines this method. - Just a placeholder." - - ^#primitiveFailure! ! -!FloatArray methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:19:24'! - primDivScalar: scalarValue - "This primitive doesn't fail if argument is zero. It fills result with infinity or nan. - For consistency with division with arrays, and general practice, an exception block or value might be used in public protocol. If needed, call directly this method instead. - - #[1.0 2.0 3.141592 0.0] asFloatArray primDivScalar: 0.0. - #[1.0 2.0 3.141592 0.0] asFloatArray / 0.0. - #[1.0 2.0 3.141592 0.0] asFloatArray divideBy: 0.0 ifDivisorZero: -100 ifBothZero: -200 - " - 1 to: self size do: [ :i | self at: i put: (self at: i) / scalarValue].! ! -!FloatArray methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:20:33'! - primMulArray: floatArray - - 1 to: self size do: [ :i | self at: i put: (self at: i) * (floatArray at: i) ].! ! -!FloatArray methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:20:30'! - primMulScalar: scalarValue - - 1 to: self size do: [ :i | self at: i put: (self at: i) * scalarValue ].! ! -!FloatArray methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:20:27'! - primSubArray: floatArray - - 1 to: self size do: [ :i | self at: i put: (self at: i) - (floatArray at: i) ].! ! -!FloatArray methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:20:23'! - primSubScalar: scalarValue - - 1 to: self size do: [ :i | self at: i put: (self at: i) - scalarValue ].! ! -!Float32Array methodsFor: 'arithmetic' stamp: 'jmv 9/3/2020 18:11:02' prior: 50404448 overrides: 50543096! - divideByArray: floatArray ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue - - (self primDivArray: floatArray) == #primitiveFailure ifTrue: [ - super - divideByArray: floatArray - ifDivisorZero: zeroDivisionBlockOrValue - ifBothZero: indeterminateBlockOrValue ]! ! -!Float32Array methodsFor: 'arithmetic' stamp: 'jmv 9/3/2020 18:18:38' prior: 16846498 overrides: 50543129! - 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." - - - ^super dot: aFloatVector! ! -!Float32Array methodsFor: 'arithmetic' stamp: 'jmv 9/3/2020 18:22:00' prior: 16846518 overrides: 50543143! -normalize - "Unsafely normalize the receiver in-place (become a unit vector). - Div-by-Zero raised if len 0." - - - ^super normalize! ! -!Float32Array methodsFor: 'comparing' stamp: 'jmv 9/3/2020 17:59:54' prior: 50464070 overrides: 50543166! - hashFull - - ^super hashFull! ! -!Float32Array methodsFor: 'comparing' stamp: 'jmv 9/3/2020 18:00:15' prior: 16846555 overrides: 50543174! - primitiveEqual: aFloatArray - - - ^super primitiveEqual: aFloatArray! ! -!Float32Array methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:03:03' prior: 16846568 overrides: 50543185! - primAddArray: floatArray - - - ^super primAddArray: floatArray! ! -!Float32Array methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:03:25' prior: 16846576 overrides: 50543191! - primAddScalar: scalarValue - - - ^super primAddScalar: scalarValue! ! -!Float32Array methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:08:15' prior: 50404508 overrides: 50543204! - primDivScalar: scalarValue - "This primitive doesn't fail if argument is zero. It fills result with infinity or nan. - For consistency with division with arrays, and general practice, an exception block or value might be used in public protocol. If needed, call directly this method instead. - - #[1.0 2.0 3.141592 0.0] asFloatArray primDivScalar: 0.0. - #[1.0 2.0 3.141592 0.0] asFloatArray / 0.0. - #[1.0 2.0 3.141592 0.0] asFloatArray divideBy: 0.0 ifDivisorZero: -100 ifBothZero: -200 - " - - ^super primDivScalar: scalarValue! ! -!Float32Array methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:03:54' prior: 16846600 overrides: 50543224! - primMulArray: floatArray - - - ^super primMulArray: floatArray! ! -!Float32Array methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:04:14' prior: 16846608 overrides: 50543230! - primMulScalar: scalarValue - - - ^super primMulScalar: scalarValue! ! -!Float32Array methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:04:35' prior: 16846616 overrides: 50543236! - primSubArray: floatArray - - - ^super primSubArray: floatArray! ! -!Float32Array methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:04:53' prior: 16846624 overrides: 50543242! - primSubScalar: scalarValue - - - ^super primSubScalar: scalarValue! ! - -Float64Array removeSelector: #primSubScalar:! - -!methodRemoval: Float64Array #primSubScalar: stamp: 'Install-4369-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h47m-jmv.001.cs.st 10/15/2020 19:34:10'! -primSubScalar: scalarValue - - "It would be nice to have FloatArrayPlugin or equivalent for Float64Array... - " - 1 to: self size do:[:i| self at: i put: (self at: i) - scalarValue].! - -Float64Array removeSelector: #primAddArray:! - -!methodRemoval: Float64Array #primAddArray: stamp: 'Install-4369-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h47m-jmv.001.cs.st 10/15/2020 19:34:10'! -primAddArray: floatArray - - "It would be nice to have FloatArrayPlugin or equivalent for Float64Array... - " - 1 to: self size do:[:i| self at: i put: (self at: i) + (floatArray at: i)].! - -Float64Array removeSelector: #primMulScalar:! - -!methodRemoval: Float64Array #primMulScalar: stamp: 'Install-4369-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h47m-jmv.001.cs.st 10/15/2020 19:34:10'! -primMulScalar: scalarValue - - "It would be nice to have FloatArrayPlugin or equivalent for Float64Array... - " - 1 to: self size do:[:i| self at: i put: (self at: i) * scalarValue].! - -Float64Array removeSelector: #primAddScalar:! - -!methodRemoval: Float64Array #primAddScalar: stamp: 'Install-4369-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h47m-jmv.001.cs.st 10/15/2020 19:34:10'! -primAddScalar: scalarValue - - "It would be nice to have FloatArrayPlugin or equivalent for Float64Array... - " - 1 to: self size do:[:i| self at: i put: (self at: i) + scalarValue].! - -Float64Array removeSelector: #dot:! - -!methodRemoval: Float64Array #dot: stamp: 'Install-4369-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h47m-jmv.001.cs.st 10/15/2020 19:34:10'! -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 | - "It would be nice to have FloatArrayPlugin or equivalent for Float64Array... - " - self flag: #Float64Primitive. - - 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! - -Float64Array removeSelector: #divideByScalar:ifDivisorZero:ifBothZero:! - -!methodRemoval: Float64Array #divideByScalar:ifDivisorZero:ifBothZero: stamp: 'Install-4369-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h47m-jmv.001.cs.st 10/15/2020 19:34:10'! -divideByScalar: scalarValue ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue - - "It would be nice to have FloatArrayPlugin or equivalent for Float64Array..." - 1 to: self size do:[:i| | dividend quotient | - dividend _ self at: i. - quotient _ - scalarValue isZero - ifTrue: [ - dividend isZero - ifTrue: indeterminateBlockOrValue - ifFalse: zeroDivisionBlockOrValue ] - ifFalse: [dividend / scalarValue]. - self at: i put: quotient]! - -Float64Array removeSelector: #primSubArray:! - -!methodRemoval: Float64Array #primSubArray: stamp: 'Install-4369-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h47m-jmv.001.cs.st 10/15/2020 19:34:10'! -primSubArray: floatArray - - "It would be nice to have FloatArrayPlugin or equivalent for Float64Array... - " - 1 to: self size do:[:i| self at: i put: (self at: i) - (floatArray at: i)].! - -Float64Array removeSelector: #divideByArray:ifDivisorZero:ifBothZero:! - -!methodRemoval: Float64Array #divideByArray:ifDivisorZero:ifBothZero: stamp: 'Install-4369-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h47m-jmv.001.cs.st 10/15/2020 19:34:10'! -divideByArray: floatArray ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue - - "It would be nice to have FloatArrayPlugin or equivalent for Float64Array..." - 1 to: self size do:[:i| | dividend divisor quotient | - dividend _ self at: i. - divisor _ floatArray at: i. - quotient _ - divisor isZero - ifTrue: [ - dividend isZero - ifTrue: indeterminateBlockOrValue - ifFalse: zeroDivisionBlockOrValue ] - ifFalse: [dividend / divisor]. - self at: i put: quotient]! - -Float64Array removeSelector: #normalize! - -!methodRemoval: Float64Array #normalize stamp: 'Install-4369-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h47m-jmv.001.cs.st 10/15/2020 19:34:10'! -normalize - "Unsafely normalize the receiver in-place (become a unit vector). - Div-by-Zero raised if len 0." - "It would be nice to have FloatArrayPlugin or equivalent for Float64Array... - " - self /= self length.! - -Float64Array removeSelector: #primMulArray:! - -!methodRemoval: Float64Array #primMulArray: stamp: 'Install-4369-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h47m-jmv.001.cs.st 10/15/2020 19:34:10'! -primMulArray: floatArray - - "It would be nice to have FloatArrayPlugin or equivalent for Float64Array... - " - 1 to: self size do:[:i| self at: i put: (self at: i) * (floatArray at: i)].! - -Float32Array removeSelector: #=! - -!methodRemoval: Float32Array #= stamp: 'Install-4369-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h47m-jmv.001.cs.st 10/15/2020 19:34:10'! -= another - self == another ifTrue: [ ^ true ]. - self class == another class ifFalse: [ ^ false ]. - self size > 256 ifTrue: [ - self hashQuick = another hashQuick ifFalse: [ ^false ]]. - ^self primitiveEqual: another! - -Float32Array removeSelector: #divideByScalar:ifDivisorZero:ifBothZero:! - -!methodRemoval: Float32Array #divideByScalar:ifDivisorZero:ifBothZero: stamp: 'Install-4369-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h47m-jmv.001.cs.st 10/15/2020 19:34:10'! -divideByScalar: scalarValue ifDivisorZero: zeroDivisionBlockOrValue ifBothZero: indeterminateBlockOrValue - - "This primitive doesn't fail if argument is zeros, just fills with infinity or nan" - scalarValue isZero ifFalse: [ - ^self primDivScalar: scalarValue ]. - 1 to: self size do:[:i| | dividend quotient | - dividend _ self at: i. - quotient _ dividend isZero - ifTrue: indeterminateBlockOrValue - ifFalse: zeroDivisionBlockOrValue. - self at: i put: quotient]! - -Float32Array removeSelector: #hash! - -!methodRemoval: Float32Array #hash stamp: 'Install-4369-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h47m-jmv.001.cs.st 10/15/2020 19:34:10'! -hash - self size > 256 ifTrue: [ ^ self hashQuick ]. - ^ self hashFull! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4369-FloatArrayHierarchyRefactor-JuanVuletich-2020Sep03-17h47m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4369] on 3 September 2020 at 6:44:44 pm'! -!Collection methodsFor: 'converting' stamp: 'jmv 9/3/2020 18:37:44'! - asFloat32Array - "Answer a FloatArray whose elements are the elements of the receiver" - - ^self as: Float32Array! ! -!FloatArray methodsFor: 'initialization' stamp: 'jmv 9/3/2020 18:43:04'! - loadFrom: srcObject - - self == srcObject ifTrue: [ ^self ]. - self class == srcObject class - ifTrue: [ self replaceFrom: 1 to: self size with: srcObject startingAt: 1 ] - ifFalse: [ self privateLoadFrom: srcObject ]! ! -!FloatArray methodsFor: 'initialization' stamp: 'jmv 9/3/2020 18:43:51'! - privateLoadFrom: srcObject - "Load the receiver from the given source object. - See inheritance." - self error: 'Cannot load a ', srcObject class name,' into a ', self class name! ! -!FloatArray methodsFor: 'interpolating' stamp: 'jmv 9/3/2020 18:40:49' prior: 50542599! - interpolatedValueAt: floatIndex - "Do a linear interpolation. - Gives usual error if argument outside bounds: - #[ 4 5 ] asFloat32Array interpolatedValueAt: 0.999 - #[ 4 5 ] asFloat32Array interpolatedValueAt: 1.0 - #[ 4 5 ] asFloat32Array interpolatedValueAt: 1.5 - #[ 4 5 ] asFloat32Array interpolatedValueAt: 2.0 - #[ 4 5 ] asFloat32Array interpolatedValueAt: 2.000001 - #[ 4 5 ] asFloat32Array interpolatedValueAt: 3 - " - | size index0 index1 weight0 weight1 | - - size _ self size. - index0 _ floatIndex truncated. "Could be #floor. But as we only care for values >=1, it is the same. But faster." - - weight1 _ floatIndex - index0. - weight0 _ 1.0 - weight1. - - index1 _ (index0 = size and: [ weight1 = 0.0 ]) "Avoid the invalid access if this was true, but don't make it slower the most common, general case." - ifFalse: [ index0 + 1 ] - ifTrue: [ index0 ]. - - "/* perform interpolation */" - ^ (weight0 * (self at: index0)) + (weight1 * (self at: index1))! ! -!FloatArray methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:40:55' prior: 50543204! - primDivScalar: scalarValue - "This primitive doesn't fail if argument is zero. It fills result with infinity or nan. - For consistency with division with arrays, and general practice, an exception block or value might be used in public protocol. If needed, call directly this method instead. - - #[1.0 2.0 3.141592 0.0] asFloat32Array primDivScalar: 0.0. - #[1.0 2.0 3.141592 0.0] asFloat32Array / 0.0. - #[1.0 2.0 3.141592 0.0] asFloat32Array divideBy: 0.0 ifDivisorZero: -100 ifBothZero: -200 - " - 1 to: self size do: [ :i | self at: i put: (self at: i) / scalarValue].! ! -!Float32Array methodsFor: 'primitives-plugin' stamp: 'jmv 9/3/2020 18:40:33' prior: 50543314 overrides: 50543644! - primDivScalar: scalarValue - "This primitive doesn't fail if argument is zero. It fills result with infinity or nan. - For consistency with division with arrays, and general practice, an exception block or value might be used in public protocol. If needed, call directly this method instead. - - #[1.0 2.0 3.141592 0.0] asFloat32Array primDivScalar: 0.0. - #[1.0 2.0 3.141592 0.0] asFloat32Array / 0.0. - #[1.0 2.0 3.141592 0.0] asFloat32Array divideBy: 0.0 ifDivisorZero: -100 ifBothZero: -200 - " - - ^super primDivScalar: scalarValue! ! - -Float64Array removeSelector: #loadFrom:! - -!methodRemoval: Float64Array #loadFrom: stamp: 'Install-4370-FloatArrayCleanup-JuanVuletich-2020Sep03-18h37m-jmv.001.cs.st 10/15/2020 19:34:10'! -loadFrom: srcObject - - self == srcObject ifTrue: [ ^self ]. - self class == srcObject class - ifTrue: [ self replaceFrom: 1 to: self size with: srcObject startingAt: 1 ] - ifFalse: [ self privateLoadFrom: srcObject ]! - -Float64Array removeSelector: #privateLoadFrom:! - -!methodRemoval: Float64Array #privateLoadFrom: stamp: 'Install-4370-FloatArrayCleanup-JuanVuletich-2020Sep03-18h37m-jmv.001.cs.st 10/15/2020 19:34:10'! -privateLoadFrom: srcObject - "Load the receiver from the given source object." - self error:'Cannot load a ', srcObject class name,' into a ', self class name! - -Collection removeSelector: #asFloatArray! - -!methodRemoval: Collection #asFloatArray stamp: 'Install-4370-FloatArrayCleanup-JuanVuletich-2020Sep03-18h37m-jmv.001.cs.st 10/15/2020 19:34:10'! -asFloatArray - "Answer a FloatArray whose elements are the elements of the receiver" - - ^self as: Float32Array! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4370-FloatArrayCleanup-JuanVuletich-2020Sep03-18h37m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4365] on 2 September 2020 at 9:48:47 pm'! -!Integer methodsFor: 'benchmarks' stamp: 'jmv 9/2/2020 21:46:29' prior: 50526944! - tinyBenchmarks - "Report the results of running the two tiny Squeak benchmarks. - ar 9/10/1999: Adjusted to run at least 1 sec to get more stable results - - Measurements or estimations from - https://smalltalkzoo.computerhistory.org/papers/EvolutionOfSmalltalk.pdf - ('The evolution of Smalltalk: from Smalltalk-72 through Squeak' by Dan Ingalls, p.98) - http://wiki.c2.com/?GreenBook - http://www.wirfs-brock.com/allen/things/smalltalk-things/tektronix-smalltalk-document-archive/1982-qtr4-magnolia-perf-graph.pdf - http://www.wirfs-brock.com/allen/things/smalltalk-things/tektronix-smalltalk-document-archive/1983-Magnolia-st-perf.pdf - - Xerox PARC systems - Alto Smalltalk-72 5MHz µcode 694 bytecodes/sec 54 sends/sec 7200 µclocks/bytecode - Alto Smalltalk-74 5MHz µcode 607 bytecodes/sec 46 sends/sec 8200 µclocks/bytecode - Alto Smalltalk-76 5MHz µcode 16k bytecodes/sec 118 sends/sec 310 µclocks/bytecode - NoteTaker Smalltalk-78 5MHz 8086 30k bytecodes/sec 250 sends/sec 166.67 clocks/bytecode - Dorado Smalltalk-76 16.67MHz µcode 1M bytecodes/sec 50k sends/sec 16.67 µClocks/bytecode - - Green Book systems - DEC PDP-11/23 5k bytecodes/sec (Green Book, p.128) - Apple 5MHz 68000 11k bytecodes/sec (Green Book, p.187, awb) 5000 clocks/bytecode - VAX-11/780 5MHz C HP Smalltalk 10k bytecodes/sec (Green Book, p.235) 450 clocks/bytecode - VAX-11/780 5MHz C Berkeley St 17k bytecodes/sec (Green Book, p.203, awb) 300 clocks/bytecode - DEC VAX-11/780 5MHz assembly 20k bytecodes/sec (Green Book, p.149, awb) 250 clocks/bytecode - TEK Magnolia 10MHz 68000 50k bytecodes/sec (awb) 200 clocks/bytecode - - Squeak & Cuis - 110 MHz PowerPC Mac 8100 4.1M bytecodes/sec; 175k sends/sec 26.8 clocks/bytecode - 292 MHz G3 Mac: 23M bytecodes/sec; 984k sends/sec 12.8 clocks/bytecode - 400 MHz PII/Win98: 18M bytecodes/sec; 1.08M sends/sec 22.2 clocks/bytecode - - 900MHz RasPi2 - StackVM: 38M bytecodes/sec; 2.41M sends/sec 16.2 clocks/bytecode - 900MHz RasPi2- CogSSpur: 157M bytecodes/sec; 10.95M sends/sec 5.7 clocks/bytecode - - 1GHz C.H.I.P. (*1) - StackVM: 55M bytecodes/sec; 3.35M sends/sec 18.1 clocks/bytecode - 1GHz C.H.I.P. (*1) - CogSpur: 254M bytecodes/sec; 16.85M sends/sec 3.9 clocks/bytecode - - 1.2GHz RasPi3B - StackSpur: 44M bytecodes/sec; 2.77M sends/sec 27.2 clocks/bytecode - 1.2GHz RasPi3B - CogSpur: 282M bytecodes/sec; 16.40M sends/sec 6.6 clocks/bytecode - - 1.66GHz Atom N450 - Cog: 244M bytecodes/sec; 28.80M sends/sec 6.8 clocks/bytecode - 1.66GHz Atom N450 - CogSpur: 470M bytecodes/sec; 30.75M sends/sec 3.5 clocks/bytecode - - 1.33GHz Atom 3735G - Cog: 326M bytecodes/sec; 34.99M sends/sec 4.1 clocks/bytecode - 1.33GHz Atom 3735G - CogSpur: 632M bytecodes/sec; 33.69M sends/sec 2.1 clocks/bytecode - - 1.5GHz AMD A4-5000 - Cog: 390M bytecodes/sec; 47.51M sends/sec 3.8 clocks/bytecode - 1.5GHz AMD A4-5000 - CogSpur: 676M bytecodes/sec; 40.67M sends/sec 2.2 clocks/bytecode - 1.5GHz AMD A4-5000 - CogSpur64: 659M bytecodes/sec; 50.34M sends/sec 2.2 clocks/bytecode - - 2.3GHz Tegra (*2) - StackVM: 259M bytecodes/sec; 13.01M sends/sec 8.9 clocks/bytecode - 2.3GHz Tegra (*2) - CogSpur: 1.08G bytecodes/sec; 64.29M sends/sec 2.1 clocks/bytecode - - 3.1GHz Core i3-2100 - Cog: 1.20G bytecodes/sec; 165.72M sends/sec 2.6 clocks/bytecode - 3.1GHz Core i3-2100 - CogSpur: 2.04G bytecodes/sec; 127.84M sends/sec 1.5 clocks/bytecode - - 2.70GHz Core i5-6400 -CogSpur64 3.16G bytecodes/sec; 243.32M sends/sec 0.85 clocks/bytecode - - (*1) C.H.I.P. $9 Computer [Next Thing Co], Allwinner R8 Single-Core ARM Cortex-A8 - 1 GHz - (*2) ACER Chromebook CB5-311 - NVIDIA Tegra K1 Quad-Core ARM Cortex-A15 'r3' - 2.3 GHz - - It is interesting to note that Cog for the first time brings ARM hardware (RasPi and C.H.I.P.) into a 'Morphic is confortable and nice to use' level of performance, - i.e. around 100 Dorados. - " - | t1 t2 r n1 n2 | - n1 _ 1. - [ - t1 _ Time millisecondsToRun: [n1 benchmark]. - t1 < 1000] - whileTrue: [n1 _ n1 * 2]. "Note: #benchmark's runtime is about O(n)" - - n2 _ 28. - [ - t2 _ Time millisecondsToRun: [r _ n2 benchFib]. - t2 < 1000] - whileTrue: [n2 _ n2 + 1]. - "Note: #benchFib's runtime is about O(k^n), - where k is the golden number = (1 + 5 sqrt) / 2 = 1.618...." - - ^String streamContents: [ :strm | - (n1 * 500000 * 1000) // t1 withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixName; - nextPutAll: 'Bytecodes/second; ' ]. - (r * 1000) // t2 withDecimalUnitPrefixAndValue: [ :value :unitPrefixSymbol :unitPrefixName | - value printOn: strm fractionDigits: 2. - strm - space; - nextPutAll: unitPrefixName; - nextPutAll: 'Sends/second' ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4371-HistoricalPerformance-JuanVuletich-2020Sep02-21h46m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4365] on 1 September 2020 at 4:50:43 pm'! -!BlockClosure methodsFor: 'exceptions' stamp: 'ar 12/4/2009 18:41' prior: 16788208! - ifCurtailed: aBlock - "Evaluate the receiver with an abnormal termination action. - Evaluate aBlock only if execution is unwound during execution - of the receiver. If execution of the receiver finishes normally do - not evaluate aBlock. N.B. This method is *not* implemented as a - primitive. Primitive 198 always fails. The VM uses prim 198 in a - context's method as the mark for an ensure:/ifCurtailed: activation." - "The abnormal termination is detected by the vm and signalled as an #aboutToReturn:to: message - sent to a reified current context, with the context of the #ifCurtailed: invocation as an argument. - The current context then walks the stack to unwind and execute any unwind blocks (including the - one protected by the #ifCurtailed: invocation) - see Context>>#resume:through" - | complete result | - - result := self valueNoContextSwitch. - complete := true. - ^result! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4372-ifCurtailed-comment-JuanVuletich-2020Sep01-16h49m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4372] on 7 September 2020 at 1:10:40 pm'! -!MessageNames methodsFor: 'class list' stamp: 'KLG 9/1/2020 21:48:42' overrides: 16869966! - selectedClassOrMetaClass - "Answer the currently selected class (or metaclass). - - If no method is selected, try to interpret the selected message name - as a class" - - ^ super selectedClassOrMetaClass ifNil: [ - self selectedMessageName ifNotNil: [ :className | | mayBeClass | - (mayBeClass _ Smalltalk - at: className ifAbsent: [^ nil ]) isBehavior - ifTrue: [ mayBeClass ] - ifFalse: [ mayBeClass class ] ] ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4373-MessageNames-fix-GeraldKlix-2020Sep07-13h08m-KLG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4373] on 11 September 2020 at 5:35:59 pm'! -!DamageRecorder methodsFor: 'recording' stamp: 'jmv 9/11/2020 17:30:25'! - damageReportedOther - "Answer damage reported for no specific morph, for morphs that are not visible, and for morphs that are carried by the Hand." - | answer | - answer _ OrderedCollection new. - self pvtAccessProtect critical: [ - damageByRoot keysAndValuesDo: [ :m :r | - (m isNil or: [ - m visible not or: [m owner isNil or: [m owner is: #HandMorph]]]) ifTrue: [ - answer add: r]]]. - ^answer! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 9/11/2020 17:34:47'! - computeDamage: aPasteUpMorph repair: aDamageRecorder rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage - "Iterate front to back while computing damage to actually repair for each morph, and for world background." - - | uncoveredDamage morph morphDamage prevMorphDamage reuseInstance ri morphBefore | - morphDamage _ OrderedCollection new. - prevMorphDamage _ OrderedCollection new. - uncoveredDamage _ aDamageRecorder damageReportedOther. - "Iterate from front to back" - 1 to: rootMorphs size do: [ :i | - morph _ rootMorphs at: i. - morph displayFullBounds ifNotNil: [ :morphBounds | - morphDamage removeAll. - (aDamageRecorder damageReportedFor: morph) ifNotNil: [ :r | - morphDamage add: r ]. - uncoveredDamage do: [ :r | - ri _ r intersect: morphBounds. - ri hasPositiveExtent ifTrue: [ - morphDamage add: ri ]]. - 1 to: i-1 do: [ :j | - reuseInstance _ prevMorphDamage. - prevMorphDamage _ morphDamage. - morphDamage _ reuseInstance removeAll. - morphBefore _ rootMorphs at: j. - prevMorphDamage do: [ :r | - morphBefore addPossiblyUncoveredAreasIn: r to: morphDamage ]]. - (Rectangle merging: morphDamage) ifNotNil: [ :morphDamageRect | - rootMorphsDamage at: i put: morphDamageRect. - morph addPossiblyUncoveredAreasIn: morphDamageRect to: uncoveredDamage ]]]. - - ^ uncoveredDamage! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 9/11/2020 16:37:58'! - drawWorldBackground: aPasteUpMorph rects: worldBackgroundDamage - "Draw worldBackgroundDamage rects for aPasteUpMorph. - Do not include submorphs." - - worldBackgroundDamage do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 9/11/2020 17:24:04' prior: 50540525! - drawWorld: aPasteUpMorph repair: aDamageRecorder - "Redraw the damaged areas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rootMorphs rootMorphsDamage worldDamage | - "Update #displayBounds for all dirty morphs (marked as such with #redrawNeeded). - Also add the updated bounds to aDamageRecorder, and update bounds of morphs carried by hand." - self updatingMorphBoundsDo: [ - aPasteUpMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - self updateHandsDisplayBounds: aPasteUpMorph ]. - - rootMorphs _ aPasteUpMorph privateSubmorphs. - rootMorphsDamage _ Array new: rootMorphs size. - - worldDamage _ self computeDamage: aPasteUpMorph repair: aDamageRecorder - rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage. - - self drawWorldBackground: aPasteUpMorph rects: worldDamage. - - self drawWorld: aPasteUpMorph - rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage - allDamage: worldDamage. - - aDamageRecorder reset. - ^ worldDamage! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 9/11/2020 17:32:32' prior: 50540259! - drawWorld: aPasteUpMorph rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage allDamage: worldDamage - "Redraw the damaged areas. - Draw each morph just once, merging rectanges to be repaired as needed." - - | morph morphBounds morphDamage | - - "Iterate from back to front." - rootMorphs size to: 1 by: -1 do: [ :i | - morph _ rootMorphs at: i. - morph visible ifTrue: [ - morphBounds _ morph displayFullBounds. - morphDamage _ rootMorphsDamage at: i. - worldDamage do: [ :r | | intersection | - intersection _ r intersect: morphBounds. - intersection hasPositiveExtent ifTrue: [ - morphDamage _ intersection quickMerge: morphDamage ]]. - morphDamage ifNotNil: [ - self newClipRect: morphDamage. - self fullDraw: morph. - worldDamage add: morphDamage ]]].! ! - -MorphicCanvas removeSelector: #drawWorld:rects:! - -!methodRemoval: MorphicCanvas #drawWorld:rects: stamp: 'Install-4374-cleanup-JuanVuletich-2020Sep11-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -drawWorld: aPasteUpMorph rects: allDamage - "Draw allDamage rects for aPasteUpMorph" - - allDamage do: [ :r | - aPasteUpMorph drawOn: (self newClipRect: r) ].! - -MorphicCanvas removeSelector: #drawWorldComputeDamage:repair:rootMorphs:rootMorphsDamage:! - -!methodRemoval: MorphicCanvas #drawWorldComputeDamage:repair:rootMorphs:rootMorphsDamage: stamp: 'Install-4374-cleanup-JuanVuletich-2020Sep11-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -drawWorldComputeDamage: aPasteUpMorph repair: aDamageRecorder rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage - "Iterate front to back while computing damage to actually repair for each morph, and for world background." - - | allDamage morph morphDamage oldMorphDamage reuse ri morphBefore | - morphDamage _ OrderedCollection new. - oldMorphDamage _ OrderedCollection new. - allDamage _ aDamageRecorder damageReportedNotVisibleAndCarriedByHand. - "Iterate from front to back" - 1 to: rootMorphs size do: [ :i | - morph _ rootMorphs at: i. - morph displayFullBounds ifNotNil: [ :morphBounds | - morphDamage removeAll. - (aDamageRecorder damageReportedFor: morph) ifNotNil: [ :r | - morphDamage add: r ]. - allDamage do: [ :r | - ri _ r intersect: morphBounds. - ri hasPositiveExtent ifTrue: [ - morphDamage add: ri ]]. - 1 to: i-1 do: [ :j | - reuse _ oldMorphDamage. - oldMorphDamage _ morphDamage. - morphDamage _ reuse removeAll. - morphBefore _ rootMorphs at: j. - oldMorphDamage do: [ :r | - morphBefore addPossiblyUncoveredAreasIn: r to: morphDamage ]]. - (Rectangle merging: morphDamage) ifNotNil: [ :morphDamageRect | - rootMorphsDamage at: i put: morphDamageRect. - morph addPossiblyUncoveredAreasIn: morphDamageRect to: allDamage ]]]. - - ^ allDamage! - -DamageRecorder removeSelector: #damageReportedNotVisibleAndCarriedByHand! - -!methodRemoval: DamageRecorder #damageReportedNotVisibleAndCarriedByHand stamp: 'Install-4374-cleanup-JuanVuletich-2020Sep11-17h28m-jmv.001.cs.st 10/15/2020 19:34:10'! -damageReportedNotVisibleAndCarriedByHand - | answer | - answer _ OrderedCollection new. - self pvtAccessProtect critical: [ - damageByRoot keysAndValuesDo: [ :m :r | - (m isNil or: [ - m visible not or: [m owner isNil or: [m owner is: #HandMorph]]]) ifTrue: [ - answer add: r]]]. - ^answer! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4374-cleanup-JuanVuletich-2020Sep11-17h28m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4373] on 11 September 2020 at 5:39:28 pm'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 9/11/2020 17:38:48' prior: 50543979! - computeDamage: aPasteUpMorph repair: aDamageRecorder rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage - "Iterate front to back while computing damage to actually repair for each morph, and for world background. - Answer uncoveredDamage, the areas where World background needs to be redrawn." - - | uncoveredDamage morph morphDamage prevMorphDamage reuseInstance morphBefore | - morphDamage _ OrderedCollection new. - prevMorphDamage _ OrderedCollection new. - uncoveredDamage _ aDamageRecorder damageReportedOther. - "Iterate from front to back" - 1 to: rootMorphs size do: [ :i | - morph _ rootMorphs at: i. - morphDamage removeAll. - (aDamageRecorder damageReportedFor: morph) ifNotNil: [ :r | - morphDamage add: r ]. - 1 to: i-1 do: [ :j | - reuseInstance _ prevMorphDamage. - prevMorphDamage _ morphDamage. - morphDamage _ reuseInstance removeAll. - morphBefore _ rootMorphs at: j. - prevMorphDamage do: [ :r | - morphBefore addPossiblyUncoveredAreasIn: r to: morphDamage ]]. - (Rectangle merging: morphDamage) ifNotNil: [ :morphDamageRect | - rootMorphsDamage at: i put: morphDamageRect. - morph addPossiblyUncoveredAreasIn: morphDamageRect to: uncoveredDamage ]]. - - ^ uncoveredDamage! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 9/11/2020 17:37:15' prior: 50544071! - drawWorld: aPasteUpMorph rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage allDamage: worldDamage - "Redraw the damaged areas. - Draw each morph just once, merging rectanges to be repaired as needed." - - | morph morphDamage | - - "Iterate from back to front." - rootMorphs size to: 1 by: -1 do: [ :i | - morph _ rootMorphs at: i. - morph visible ifTrue: [ - morphDamage _ rootMorphsDamage at: i. - morph displayFullBounds ifNotNil: [ :morphFullBounds | - worldDamage do: [ :r | | intersection | - intersection _ r intersect: morphFullBounds. - intersection hasPositiveExtent ifTrue: [ - morphDamage _ intersection quickMerge: morphDamage ]]]. - morphDamage ifNotNil: [ - self newClipRect: morphDamage. - self fullDraw: morph. - worldDamage add: morphDamage ]]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4375-WorldDrawFix-JuanVuletich-2020Sep11-17h35m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4375] on 14 September 2020 at 11:19:51 am'! -!Morph methodsFor: 'events' stamp: 'jmv 9/14/2020 10:56:37' prior: 16874588! - mouseButton3Down: aMouseButtonEvent localPosition: localEventPosition - "Special gestures (cmd-mouse on the Macintosh; Alt-mouse on Windows and Unix) allow a mouse-sensitive morph to be moved or bring up a halo for the morph." - | h doNotDrag | - h _ aMouseButtonEvent hand halo. - "Prevent wrap around halo transfers originating from throwing the event back in" - doNotDrag _ false. - h ifNotNil: [ - (h target == self) ifTrue: [ doNotDrag _ true]. - (h target hasOwner: self) ifTrue: [ doNotDrag _ true]. - (self hasOwner: h target) ifTrue: [ doNotDrag _ true]]. - - "cmd-drag on flexed morphs works better this way" - h _ self addHalo: aMouseButtonEvent. - doNotDrag ifTrue: [ ^self ]. - h ifNotNil: [ - "Initiate drag transition if requested" - "good gesture. implement it" - aMouseButtonEvent hand - waitForClicksOrDrag: h - event: aMouseButtonEvent - clkSel: nil - dblClkSel: nil. - "Pass focus explicitly here" - aMouseButtonEvent hand newMouseFocus: h ]! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 9/14/2020 10:54:31' prior: 50535583! - addHalo: evt - | halo | - self displayBoundsForHalo ifNotNil: [ :r | - halo _ HaloMorph new. - halo popUpFor: self event: evt. - halo morphBounds: r ]. - ^halo! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 9/14/2020 10:52:56' prior: 16875831! - transferHalo: event from: formerHaloOwner - "Progressively transfer the halo to the next likely recipient" - | eventLocalPos | - - formerHaloOwner == self - ifFalse: [ ^self addHalo: event ]. - - eventLocalPos _ self internalizeFromWorld: event eventPosition. - event shiftPressed ifTrue: [ - "Pass it outwards" - owner ifNotNil: [ ^owner transferHalo: event from: formerHaloOwner ]. - "We're at the top level; just keep it on ourselves" - ^self ]. - - self submorphsDo: [ :m | - (m wantsHalo and: [ m fullContainsPoint: (m internalize: eventLocalPos) ]) - ifTrue: [ ^m transferHalo: event from: formerHaloOwner ]]. - "We're at the bottom most level; just keep halo on ourselves"! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 9/14/2020 10:59:33' prior: 50535624! - addHandles - - self removeAllMorphs. "remove old handles, if any" - target displayBoundsForHalo ifNotNil: [ :r | - self morphBounds: r. "update my size" - haloBox _ self basicBox. - target addHandlesTo: self box: haloBox. - self addNameString: (target printStringLimitedTo: 40). - growingOrRotating _ false. - self redrawNeeded ].! ! - -Morph removeSelector: #addHalo:from:! - -!methodRemoval: Morph #addHalo:from: stamp: 'Install-4376-Halo-fix-JuanVuletich-2020Sep14-11h19m-jmv.001.cs.st 10/15/2020 19:34:10'! -addHalo: evt from: formerHaloOwner - "Transfer a halo from the former halo owner to the receiver" - ^self addHalo: evt! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4376-Halo-fix-JuanVuletich-2020Sep14-11h19m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4375] on 14 September 2020 at 11:36:44 am'! -!TextEditor methodsFor: 'private' stamp: 'jmv 9/14/2020 11:34:18' prior: 16932861! - storeSelectionInComposition - "for proper display of selected text" - - pointBlock ifNil: [ ^self ]. - textComposition - selectionStartBlocks: (selectionStartBlocks copyWith: self startBlock) - selectionStopBlocks: (selectionStopBlocks copyWith: self stopBlock)! ! -!TextEditor methodsFor: 'initialization' stamp: 'jmv 9/14/2020 11:35:52' prior: 16933061! - resetState - "Establish the initial conditions for editing the paragraph: place text cursor - before first character and set the emphasis to that of the first character" - - markBlock _ textComposition defaultCharacterBlock. - pointBlock _ markBlock. - selectionStartBlocks _ #(). - selectionStopBlocks _ #()! ! -!InnerTextMorph methodsFor: 'private' stamp: 'jmv 9/14/2020 11:27:57' prior: 16856003! - installEditorAndTextComposition - "Install an editor for my textComposition. Install also the textComposition." - | e tc | - - "Editor and TextComposition are assigned here atomically." - e _ model editorClass new morph: self. - e model: model. - tc _ TextComposition new. - "Keep critical section short" - self mutex critical: [ - editor _ e. - textComposition _ tc. - tc - setModel: model; - extentForComposing: self extentForComposing. - e textComposition: tc. - tc editor: e ]. - e setEmphasisHereFromText. - tc composeAll. - e resetState. - self fit. - self selectionChanged. - - "Add extras. Text Styler and Autocompleter" - self stylerClass: - (Preferences syntaxHighlightingAsYouType ifTrue: [ - model textStylerClass ]). - self autoCompleterClass: - model autoCompleterClass! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4377-TextEditorFix-JuanVuletich-2020Sep14-11h19m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4377] on 24 September 2020 at 10:54:34 am'! -!TheWorldMenu class methodsFor: 'menu building' stamp: 'jmv 9/24/2020 10:53:18' prior: 50411911! - worldMenuOptions - - ^`{{ - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Open...'. - #selector -> #openOpenMenu. - #icon -> #openIcon. - #balloonText -> 'Submenu to open various system tools'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'New morph...'. - #selector -> #newMorph. - #icon -> #morphsIcon. - #balloonText -> 'Offers a variety of ways to create new objects'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Preferences...'. - #selector -> #openPreferencesMenu. - #icon -> #preferencesIcon. - #balloonText -> 'Opens a menu offering many controls over appearance and system preferences.'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'Windows...'. - #selector -> #openWindowsMenu. - #icon -> #windowIcon. - #balloonText -> 'Manage open windows'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 50. - #label -> 'Help...'. - #selector -> #openHelpMenu. - #icon -> #helpIcon. - #balloonText -> 'Opens a menu of useful items for updating the system, determining what version you are running, and much else'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Changes...'. - #selector -> #openChangesMenu. - #icon -> #changesIcon. - #balloonText -> 'Opens a menu of useful tools for dealing with changes'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Debug...'. - #selector -> #openDebugMenu. - #icon -> #debugIcon. - #balloonText -> 'a menu of debugging items'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'Restore Display (r)'. - #object -> #myWorld. - #selector -> #restoreDisplay. - #icon -> #displayIcon. - #balloonText -> 'Repaint the screen -- useful for removing unwanted display artifacts, lingering cursors, etc.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Save'. - #object -> Smalltalk. - #selector -> #saveSession. - #icon -> #saveIcon. - #balloonText -> 'Save the current version of the image on disk'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Save as...'. - #object -> Smalltalk. - #selector -> #saveAs. - #icon -> #saveAsIcon. - #balloonText -> 'Save the current version of the image on disk under a new name.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'Save new Cuis Release'. - #object -> Smalltalk. - #selector -> #saveAsNewVersion. - #icon -> #saveAsNewVersionIcon. - #balloonText -> ('Save as a new release of Cuis.\Use an updated version-stamped name\and save it under that name on disk.\', - 'Clear all user preferences and user state (class vars).') withNewLines. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 40. - #label -> 'Save and Quit'. - #selector -> #saveAndQuit. - #icon -> #saveAndQuitIcon. - #balloonText -> 'Save the image and quit out of Cuis.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 50. - #label -> 'Quit'. - #selector -> #quitSession. - #icon -> #quitIcon. - #balloonText -> 'Quit out of Cuis.'. - } asDictionary. -}`! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4378-BetterWordingOfSaveAsNewVersion-JuanVuletich-2020Sep24-10h44m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4365] on 23 September 2020 at 7:26:03 pm'! -!StringRequestMorph class methodsFor: 'instance creation' stamp: 'HAW 9/23/2020 18:49:48'! - defaultInitialAnswer - - ^''! ! -!StringRequestMorph class methodsFor: 'instance creation' stamp: 'HAW 9/23/2020 18:49:25'! - request: queryString orCancel: cancelBlock - - ^self request: queryString initialAnswer: self defaultInitialAnswer orCancel: cancelBlock ! ! -!StringRequestMorph class methodsFor: 'instance creation' stamp: 'HAW 9/23/2020 18:47:29' prior: 50513877 overrides: 50513615! - request: queryString initialAnswer: defaultAnswer do: acceptBlock - - ^ self - request: queryString - centeredAt: self runningWorld activeHand morphPosition - initialAnswer: defaultAnswer - validationBlock: [:aString| true] - acceptBlock: acceptBlock - cancelBlock: []! ! -!StringRequestMorph class methodsFor: 'instance creation' stamp: 'HAW 9/23/2020 18:47:57' prior: 50513889 overrides: 50515284! - request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock - - | morph world | - - morph _ self new - setQuery: queryString - initialAnswer: defaultAnswer. - (world _ self runningWorld) addMorph: morph centeredNear: world activeHand morphPosition - self deltaToTextPane. - - ^ morph getUserResponseOrCancel: cancelBlock! ! -!StringRequestMorph class methodsFor: 'instance creation' stamp: 'HAW 9/23/2020 18:48:44' prior: 50513903 overrides: 50515297! - request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock - - ^ self - request: queryString - centeredAt: self runningWorld activeHand morphPosition - initialAnswer: defaultAnswer - validationBlock: validationBlock - acceptBlock: acceptBlock - cancelBlock: cancelBlock! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4379-requestOrCancel-HernanWilkinson-2020Sep23-18h39m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4379] on 24 September 2020 at 11:22:55 am'! -!MenuMorph methodsFor: 'accessing' stamp: 'KLG 9/22/2020 20:59:54' overrides: 16876446! - label - "Answer a nice label. - - Pinned menus in the taskbar are easier to identify on big screens." - - titleMorph ifNil: [ ^ super label ]. - titleMorph submorphsDo: [ :stringMorph | - "Be careful" - [ ^ stringMorph contents ] onDNU: #contents do: [] ]. - ^ super label ":] One never knows"! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4380-MenuMorph-label-GeraldKlix-2020Sep24-11h19m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4373] on 18 September 2020 at 1:40:56 pm'! -!ProtocolBrowser methodsFor: 'class list' stamp: 'KenD 9/18/2020 13:21:11' overrides: 16869956! - selectedClass - "Answer the class that is currently selected. - Answer base if no selection exists." - | className | - className := (self selectiveClassListIndex = 0) - ifTrue: [self selectiveClassList last] - ifFalse: [self selectiveClassList at: self selectiveClassListIndex]. - ^ Smalltalk at: ((className findTokens: ' ') first asSymbol)! ! -!ProtocolBrowser methodsFor: 'class list' stamp: 'KenD 9/18/2020 12:40:47' overrides: 16869966! - selectedClassOrMetaClass - "I ignore metaClass, so.." - ^ self selectedClass! ! -!ProtocolBrowserWindow methodsFor: 'menu building' stamp: 'KenD 9/18/2020 12:37:51'! - protocolClassListMenu - "Fill aMenu with items appropriate for the class list" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Class List'. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - - }`. - ^ aMenu! ! -!ProtocolBrowserWindow methodsFor: 'keyboard shortcuts' stamp: 'KenD 9/18/2020 13:39:04'! - protocolClassListKey: aChar from: view - "Respond to a Command key. I am a model with a list of - classes and a list of methods. The - view knows how to get the list and selection." - - aChar == $b ifTrue: [^ self browseMethodFull ]. - aChar == $h ifTrue: [^ self browseHierarchy]. - - ^ nil! ! -!ProtocolBrowserWindow methodsFor: 'GUI building' stamp: 'KenD 9/18/2020 13:37:59' prior: 50374685! - buildSelectiveClassList - "Define the class hierarchy list pane" - - ^PluggableListMorph - model: model - listGetter: #selectiveClassList - indexGetter: #selectiveClassListIndex - indexSetter: #selectiveClassListIndex: - mainView: self - menuGetter: #protocolClassListMenu - keystrokeAction: #protocolClassListKey:from: ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4381-ProtocolClassMenu-KenDickey-2020Aug28-11h56m-KenD.002.cs.st----! - -'From Cuis 5.0 [latest update: #4381] on 24 September 2020 at 3:51:28 pm'! -!Dictionary methodsFor: 'printing' stamp: 'jmv 9/24/2020 15:49:52' prior: 16833727 overrides: 16814619! - storeOn: aStream - | noneYet | - aStream nextPutAll: '(('. - aStream nextPutAll: self class name. - aStream nextPutAll: ' new)'. - noneYet _ true. - self keysSortedSafely do: [ :key | - noneYet - ifTrue: [noneYet _ false] - ifFalse: [aStream nextPut: $;]. - aStream nextPutAll: ' add: '. - aStream store: (self associationAt: key)]. - noneYet ifFalse: [aStream nextPutAll: '; yourself']. - aStream nextPut: $)! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4382-Dictionary-deterministic-storeOn-ifPossible-JuanVuletich-2020Sep24-15h49m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4382] on 24 September 2020 at 8:08:04 pm'! -!Categorizer methodsFor: 'accessing' stamp: 'HAW 9/24/2020 19:59:20' prior: 50493613! - addCategory: catString before: nextCategory - "Add a new category named heading. - If default category exists and is empty, remove it. - If nextCategory is nil, then add the new one at the end, - otherwise, insert it before nextCategory." - - | index newCategory | - - newCategory _ catString withBlanksTrimmed. - - "heading already exists, so done" - (categoryArray indexOf: newCategory) > 0 ifTrue: [^self]. - - index _ categoryArray indexOf: nextCategory ifAbsent: [categoryArray size + 1]. - categoryArray _ categoryArray - copyReplaceFrom: index - to: index-1 - with: (Array with: newCategory). - categoryStops _ categoryStops - copyReplaceFrom: index - to: index-1 - with: (Array with: (index = 1 - ifTrue: [0] - ifFalse: [categoryStops at: index-1])). - - "remove empty default category" - (newCategory ~= Default and: [(self listAtCategoryNamed: Default) isEmpty]) - ifTrue: [self removeCategory: Default]! ! -!Categorizer methodsFor: 'accessing' stamp: 'HAW 9/24/2020 20:02:50' prior: 50493644! - classify: element under: heading suppressIfDefault: aBoolean - "Store the argument, element, in the category named heading. If aBoolean is true, then invoke special logic such that the classification is NOT done if the new heading is the Default and the element already had a non-Default classification -- useful for filein" - - | catName catIndex elemIndex realHeading | - - ((heading = NullCategory) or: [heading == nil]) - ifTrue: [realHeading _ Default] - ifFalse: [realHeading _ heading withBlanksTrimmed ]. - - "done if already under that category" - (catName _ self categoryOfElement: element) = realHeading ifTrue: [^ self]. - - catName ifNotNil: [ - "return if non-Default category already assigned in memory" - (aBoolean and: [realHeading = Default]) ifTrue: [^ self]. - "remove if in another category" - self removeElement: element]. - - (categoryArray indexOf: realHeading) = 0 ifTrue: [self addCategory: realHeading]. - - catIndex _ categoryArray indexOf: realHeading. - elemIndex _ catIndex > 1 - ifTrue: [categoryStops at: catIndex - 1] - ifFalse: [0]. - [(elemIndex _ elemIndex + 1) <= (categoryStops at: catIndex) - and: [element >= (elementArray at: elemIndex)]] whileTrue. - - "elemIndex is now the index for inserting the element. Do the insertion before it." - elementArray _ elementArray copyReplaceFrom: elemIndex to: elemIndex-1 with: (Array with: element). - - "add one to stops for this and later categories" - catIndex to: categoryArray size do: - [:i | categoryStops at: i put: (categoryStops at: i) + 1]. - - (self listAtCategoryNamed: Default) size = 0 ifTrue: [self removeCategory: Default]! ! -!Categorizer methodsFor: 'accessing' stamp: 'HAW 9/24/2020 20:04:28' prior: 16795704! - renameCategory: oldCatString toBe: newCatString - "Rename a category. No action if new name already exists, or if old name does not exist." - - | index newCategory | - - newCategory _ newCatString withBlanksTrimmed. - "new name exists, so no action" - (categoryArray indexOf: newCategory) > 0 ifTrue: [^ self]. - - "old name not found, so no action" - (index _ categoryArray indexOf: oldCatString) = 0 ifTrue: [^ self]. - - "need to change identity so smart list update will notice the change" - categoryArray _ categoryArray copy. - categoryArray at: index put: newCategory! ! -!ClassOrganizer methodsFor: 'accessing' stamp: 'HAW 9/24/2020 20:05:51' prior: 16807592 overrides: 50544799! - renameCategory: oldCatString toBe: newCatString - - | newCategory oldElementsBefore oldElementsAfter | - - newCategory _ newCatString withBlanksTrimmed. - oldElementsBefore _ self listAtCategoryNamed: oldCatString. - SystemChangeNotifier uniqueInstance doSilently: [ - super renameCategory: oldCatString toBe: newCatString]. - - oldElementsAfter _ (self listAtCategoryNamed: oldCatString) asSet. - oldElementsBefore do: [:each | (oldElementsAfter includes: each) - ifFalse: [self notifyOfChangedSelector: each from: oldCatString to: newCategory]]. - - self notifyOfChangedCategoryFrom: oldCatString to: newCategory.! ! -!ClassBuilder methodsFor: 'class definition' stamp: 'HAW 9/24/2020 16:24:14' prior: 50430800! - name: className subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category unsafe: unsafe - "Define a new class. - If unsafe is true do not run any validation checks. - This facility is provided to implement important system changes." - - | oldClass newClass organization instVars classVars force needNew oldCategory copyOfOldClass newCategory | - - instVars _ Scanner new scanFieldNames: instVarString. - classVars _ (Scanner new scanFieldNames: classVarString) collect: [:x | x asSymbol]. - - "Validate the proposed name" - unsafe ifFalse:[(self validateClassName: className) ifFalse:[^nil]]. - oldClass _ Smalltalk at: className ifAbsent: nil. - oldClass isBehavior - ifFalse:[oldClass _ nil]. "Already checked in #validateClassName:" - copyOfOldClass _ oldClass copy. - - unsafe ifFalse:[ - "Run validation checks so we know that we have a good chance for recompilation" - (self validateSuperclass: newSuper forSubclass: oldClass) ifFalse:[^nil]. - (self validateInstvars: instVars from: oldClass forSuper: newSuper) ifFalse:[^nil]. - (self validateClassvars: classVars from: oldClass forSuper: newSuper) ifFalse:[^nil]. - (self validateSubclassFormat: type from: oldClass forSuper: newSuper extra: instVars size) ifFalse:[^nil]]. - - "See if we need a new subclass" - needNew _ self needsSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass. - needNew ifNil: [^nil]. "some error" - - (needNew and:[unsafe not]) ifTrue:[ - "Make sure we don't redefine any dangerous classes" - (self tooDangerousClasses includes: oldClass name) ifTrue:[ - self error: oldClass name, ' cannot be changed'. - ]. - "Check if the receiver should not be redefined" - (oldClass notNil and:[oldClass shouldNotBeRedefined]) ifTrue:[ - self notify: oldClass name asText allBold, - ' should not be redefined!! \Proceed to store over it.' withNewLines]]. - - needNew ifTrue:[ - "Create the new class" - newClass _ self - newSubclassOf: newSuper - type: type - instanceVariables: instVars - from: oldClass. - newClass ifNil: [ ^nil]. "Some error" - newClass setName: className. - ] ifFalse:[ - "Reuse the old class" - newClass _ oldClass. - ]. - - "Install the class variables and pool dictionaries... " - force _ (newClass declare: classVarString) | (newClass sharing: poolString). - - "... classify ..." - newCategory _ category withBlanksTrimmed. - organization _ Smalltalk organization. - oldClass ifNotNil: [oldCategory := (organization categoryOfElement: oldClass name) asSymbol]. - organization classify: newClass name under: newCategory. - - "... recompile ..." - newClass _ self recompile: force from: oldClass to: newClass mutate: false. - - "... export if not yet done ..." - (Smalltalk at: newClass name ifAbsent: nil) == newClass ifFalse:[ - [Smalltalk at: newClass name put: newClass] - on: AttemptToWriteReadOnlyGlobal do:[:ex| ex resume: true]. - Smalltalk flushClassNameCache. - ]. - - self doneCompiling: newClass. - - "... notify interested clients ..." - oldClass ifNil: [ - SystemChangeNotifier uniqueInstance classAdded: newClass inCategory: newCategory. - ^ newClass]. - SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass. - newCategory ~= oldCategory - ifTrue: [SystemChangeNotifier uniqueInstance classRecategorized: newClass from: oldCategory to: newCategory ]. - ^newClass! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4383-CategoriesWithoutBlanks-HernanWilkinson-2020Sep24-16h22m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4382] on 27 September 2020 at 10:30:51 pm'! - -"Change Set: 4383-CuisCore-AuthorName-2020Sep27-22h11m -Date: 27 September 2020 -Author: Nahuel Garbezza - -Add missing visitor protocol (temporaries declaration) for ParseNodeEnumerator"! -!ParseNodeEnumerator methodsFor: 'visiting' stamp: 'RNG 9/27/2020 22:25:46' overrides: 50502565! - visitTemporariesDeclarationNode: aTemporariesDeclarationNode - - (theSelectBlock isNil or: [theSelectBlock value: aTemporariesDeclarationNode]) ifFalse: - [^nil]. - theBlock value: aTemporariesDeclarationNode. - ^ super visitTemporariesDeclarationNode: aTemporariesDeclarationNode! ! -!ParseNodeEnumerator methodsFor: 'visiting' stamp: 'RNG 9/27/2020 22:28:33' overrides: 50502574! - visitTemporaryDeclarationNode: aTemporaryDeclarationNode - - (theSelectBlock isNil or: [theSelectBlock value: aTemporaryDeclarationNode]) ifFalse: - [^nil]. - theBlock value: aTemporaryDeclarationNode. - ^ super visitTemporaryDeclarationNode: aTemporaryDeclarationNode! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4384-ParseNodeEnumerator-NahuelGarbezza-2020Sep27-22h11m-RNG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4384] on 29 September 2020 at 10:52:57 am'! -!SmartRefStream methodsFor: 'read write' stamp: 'jmv 9/29/2020 10:52:42' overrides: 16827608! - readWordLike - | refPosn className newName newClass anObject | - "Can be used by any class that is bits and not bytes (WordArray, Bitmap, SoundBuffer, etc)." - - refPosn _ self getCurrentReference. - className _ self next asSymbol. - newName _ renamed at: className ifAbsent: [className]. - newClass _ Smalltalk at: newName. - anObject _ newClass newFromStream: byteStream. - "Size is number of long words." - self setCurrentReference: refPosn. "before returning to next" - ^ anObject -! ! -!SmartRefStream methodsFor: 'read write' stamp: 'jmv 9/29/2020 10:39:04' prior: 16911003! - initKnownRenames - "Stuff like" - " - renamed - at: #FlasherMorph put: #Flasher; - yourself - " - renamed - at: #FloatArray put: #Float32Array; - yourself! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4385-SmartRefStream-FloatArray-Float32Array-JuanVuletich-2020Sep29-10h39m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4382] on 28 September 2020 at 11:22:59 am'! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 9/28/2020 11:03:19'! - morphContainsPoint: aLocalPoint - "Not very good. False positives for non-rectangular morphs. - Only useful as a backstop if the Canvas can't do better." - - ^ self morphLocalBounds containsPoint: aLocalPoint! ! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'jmv 9/28/2020 11:19:35' overrides: 50384211! - morphTopLeft - "Our hierarchy occupies a rectangle specified by #morphTopLef and #morphExtent" - ^`0@0`! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 9/28/2020 10:57:58' prior: 50503283! - morphPositionInWorld - - self flag: #jmvVer2. - "Most likely we don't want to use global coordinates... - In fact, we could be in many frames of reference at the same time... - This method makes no sense at all!!" - - ^self externalizeToWorld: `0@0`! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 9/28/2020 11:20:07' prior: 50384211! - morphTopLeft - "By default, morphs occupy a rectangle specified by #morphExtent" - ^self morphExtent // 2 negated! ! - -Morph removeSelector: #morphBounds! - -!methodRemoval: Morph #morphBounds stamp: 'Install-4386-Morph-topLeftMightNotBeOrigin-JuanVuletich-2020Sep28-10h33m-jmv.001.cs.st 10/15/2020 19:34:10'! -morphBounds - ^ self morphPosition extent: self morphExtent! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4386-Morph-topLeftMightNotBeOrigin-JuanVuletich-2020Sep28-10h33m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4384] on 28 September 2020 at 12:05:40 pm'! -!StepMessage methodsFor: 'evaluating' stamp: 'jmv 9/28/2020 12:05:32' prior: 50340399 overrides: 16877275! - valueAtTime: millisecondClock - - | nArgs millisecondsSinceLast answer | - numArgs ifNil: [numArgs _ selector numArgs]. - nArgs _ arguments ifNil: [0] ifNotNil: [arguments size]. - lastEvaluationTime ifNil: [ lastEvaluationTime _ millisecondClock ]. - millisecondsSinceLast _ millisecondClock - lastEvaluationTime. - lastEvaluationTime _ millisecondClock. - nArgs = numArgs ifTrue: [ - "Ignore extra argument" - ^self value ]. - [ - arguments - ifNil: [ answer _ receiver perform: selector with: millisecondsSinceLast] - ifNotNil: [ answer _ receiver perform: selector withArguments: (arguments copyWith: millisecondsSinceLast) ] - ] ifError: [ :err :rcvr | - receiver stopStepping. - { 'Error while stepping: '. self. rcvr. err } print. - "Install the old error handler, so we can re-raise the error" - rcvr error: err. - ]. - ^answer! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4387-stepping-ErrorHandling-JuanVuletich-2020Sep28-12h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4388] on 29 September 2020 at 11:08:32 am'! -!HaloMorph methodsFor: 'private' stamp: 'jmv 9/29/2020 11:08:03' prior: 50537050! - doRot: evt with: rotHandle - "Update the rotation of my target if it is rotatable. Keep the relevant command object up to date." - - | radians scale | -self revisar. - self flag: #jmvVer2. - evt hand obtainHalo: self. - radians _ (evt eventPosition - target referencePosition) theta. - radians _ radians - angleOffset theta. - "degrees _ degrees detentBy: 10.0 atMultiplesOf: 90.0 snap: false." - radians = 0.0 - ifTrue: [rotHandle color: `Color lightBlue`] - ifFalse: [rotHandle color: `Color blue`]. - rotHandle submorphsDo: - [:m | m color: rotHandle color makeForegroundColor]. - scale _ (evt eventPosition - target referencePosition) rho * scaleOffset. - self removeAllHandlesBut: rotHandle. - target rotation: radians scale: "scale" 1. "Please use another handle for scale!!" - rotHandle morphPositionInWorld: evt eventPosition - (rotHandle morphExtent // 2)! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4388-RotateHandle-doNotScales-JuanVuletich-2020Sep29-11h08m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4388] on 28 September 2020 at 3:59:52 pm'! -!BitBltCanvas methodsFor: 'drawing' stamp: 'jmv 9/28/2020 15:57:04' prior: 50532706 overrides: 50463404! - line: pt1 to: pt2 width: wp color: c - | p1 p2 w | - - engine ifNil: [ ^nil ]. - - (wp > 0 and: [ c isTransparent not ]) ifTrue: [ - p1 _ (currentTransformation transform: pt1) rounded. - p2 _ (currentTransformation transform: pt2) rounded. - w _ (currentTransformation externalizeScalar: wp) rounded. - self setPaintColor: c. - engine - width: w; - height: w; - drawFrom: p1 to: p2 ]! ! -!BitBltCanvas methodsFor: 'drawing-ovals' stamp: 'jmv 9/28/2020 15:58:00' prior: 50532794 overrides: 50463440! - ellipseCenterX: mcx y: mcy rx: mrx ry: mry borderWidth: mbw borderColor: mbc fillColor: morphFillColor - - | displayRectangle doBorder doFill | - - engine ifNil: [ ^nil ]. - - doBorder _ mbw > 0 and: [ mbc isTransparent not]. - doFill _ morphFillColor isTransparent not. - doBorder | doFill ifTrue: [ - displayRectangle _ (currentTransformation externalizeRectangle: (Rectangle center: mcx@mcy extent: mrx@mry * 2)) rounded. - "draw the border of the oval" - doBorder ifTrue: [ - self setPaintColor: mbc. - engine frameOval: displayRectangle borderWidth: mbw rounded]. - "fill the inside" - doFill ifTrue: [ - self setPaintColor: morphFillColor. - engine fillOval: (displayRectangle insetBy: mbw rounded) ]]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 9/28/2020 15:58:21' prior: 50532875 overrides: 50463466! - frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor - | rect bw | - - - engine ifNil: [ ^nil ]. - - r area = 0 ifTrue: [ ^self ]. - rect _ (currentTransformation externalizeRectangle: r) rounded. - bw _ (currentTransformation externalizeScalar: borderWidth) rounded. - - "draw the border of the rectangle" - borderColor isTransparent ifFalse: [ - self setPaintColor: borderColor. - engine frameRect: rect borderWidth: bw ]. - - "fill the inside" - fillColor isTransparent ifFalse: [ - self setPaintColor: fillColor. - engine fillRect: (rect insetBy: bw) ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 9/28/2020 15:58:33' prior: 50532897 overrides: 50463473! - frameRectangle: r borderWidth: borderWidth color: borderColor - " - Display getCanvas - frameRectangle: (10@10 extent: 300@200) - borderWidth: 20 - color: Color red. - Display forceToScreen - " - | rect bw | - - engine ifNil: [ ^nil ]. - - (borderWidth > 0 and: [ borderColor isTransparent not ]) ifTrue: [ - rect _ (currentTransformation externalizeRectangle: r) rounded. - bw _ (currentTransformation externalizeScalar: borderWidth) rounded. - self setPaintColor: borderColor. - engine - frameRect: rect - borderWidth: bw ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4389-BitBltCanvas-roundLineWidth-JuanVuletich-2020Sep28-14h36m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4389] on 28 September 2020 at 4:33:47 pm'! -!HaloMorph methodsFor: 'private' stamp: 'jmv 9/28/2020 16:32:38' prior: 16850976! - doDrag: evt with: dragHandle - | thePoint | - evt hand obtainHalo: self. - thePoint _ evt eventPosition - positionOffset. - target morphPositionInWorld: thePoint. - self morphPositionInWorld: thePoint + target morphTopLeft! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4390-HaloMorph-fix-JuanVuletich-2020Sep28-16h20m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4391] on 4 October 2020 at 8:20:56 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/4/2020 20:20:33'! - rotation: radians - "Change the rotation of this morph. Argument is an angle to be taken as the new rotation." - - self rotation: radians scale: 1.! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/4/2020 20:20:39' prior: 50535325! - rotateBy: radians - "Change the rotation of this morph. Argument is an angle (possibly negative), to be added to current rotation." - - location _ location rotatedBy: radians. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4391-Morph-rotation-JuanVuletich-2020Oct04-20h19m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4360] on 5 October 2020 at 10:52:58 am'! -!SystemDictionary methodsFor: 'system attributes' stamp: 'jmv 10/5/2020 10:52:42' prior: 16925057! - maxIdentityHash - "Answer the maximum identityHash value supported by the VM. - Usually the VM is able to answer. It seems that SqueakJS (as of October 5, 2020) isn't. - On primitive failure, still give a correct answer." - - - ^self isSpur - ifTrue: [ 16r3FFFFF ] "22 bits in Spur" - ifFalse: [ 16rFFF ] "12 bits in V3 images"! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4392-MakeCuisRunAgainOnSqueakJSvm-JuanVuletich-2020Oct05-10h52m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4384] on 4 October 2020 at 6:54:26 pm'! -!SHTextStylerST80 class methodsFor: 'preferences' stamp: 'HAW 10/4/2020 18:53:16'! - initializeSyntaxHighlightingAsYouType - - (Preferences preferenceAt: #syntaxHighlightingAsYouType) ifNil:[ - Preferences - disable: #browseWithPrettyPrint. - Preferences - addPreference: #syntaxHighlightingAsYouType - categories: #(browsing) - default: true - balloonHelp: 'Enable, or disable, Shout - Syntax Highlighting As You Type. When enabled, code in Browsers and Workspaces is styled to reveal its syntactic structure. When the code is changed (by typing some characters, for example), the styling is changed so that it remains in sync with the modified code']! ! -!SHTextStylerST80 class methodsFor: 'preferences' stamp: 'HAW 10/4/2020 18:53:26'! - initializeSyntaxHighlightingAsYouTypeAnsiAssignment - - (Preferences preferenceAt: #syntaxHighlightingAsYouTypeAnsiAssignment) ifNil:[ - Preferences - addPreference: #syntaxHighlightingAsYouTypeAnsiAssignment - categories: #(browsing) - default: false - balloonHelp: 'If true, and syntaxHighlightingAsYouType is enabled, all left arrow assignments ( _ ) will be converted to the ANSI format ( := ) when a method is selected in a Browser. Whilst editing a method, this setting has no effect - both the left arrow and the ansi format may be used'. - - (Preferences preferenceAt: #syntaxHighlightingAsYouTypeAnsiAssignment) - changeInformee: self - changeSelector: #ansiAssignmentPreferenceChanged]! ! -!SHTextStylerST80 class methodsFor: 'preferences' stamp: 'HAW 10/4/2020 18:53:30'! - initializeSyntaxHighlightingAsYouTypeLeftArrowAssignment - - ^ (Preferences preferenceAt: #syntaxHighlightingAsYouTypeLeftArrowAssignment) ifNil:[ - Preferences - addPreference: #syntaxHighlightingAsYouTypeLeftArrowAssignment - categories: #(browsing) - default: false - balloonHelp: 'If true, and syntaxHighlightingAsYouType is enabled, all ANSI format assignments ( := ) will be converted to left arrows ( _ ) when a method is selected in a Browser. Whilst editing a method, this setting has no effect - both the left arrow and the ansi format may be used'. - - (Preferences preferenceAt: #syntaxHighlightingAsYouTypeLeftArrowAssignment) - changeInformee: self - changeSelector: #leftArrowAssignmentPreferenceChanged ]! ! -!SHTextStylerST80 class methodsFor: 'preferences' stamp: 'HAW 10/4/2020 18:51:43' prior: 16903434! - initializePreferences - - self - initializeSyntaxHighlightingAsYouType; - initializeSyntaxHighlightingAsYouTypeAnsiAssignment; - initializeSyntaxHighlightingAsYouTypeLeftArrowAssignment.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4393-StylerPreferenceInitialization-HernanWilkinson-2020Oct04-18h50m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4384] on 5 October 2020 at 12:24:21 pm'! - -Object subclass: #SHST80RangeType - instanceVariableNames: 'sourceCode messageRange receiverRange messageRangeType receiverRangeType classOrMetaClass' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -!classDefinition: #SHST80RangeType category: #'Tools-Syntax Highlighting' stamp: 'Install-4394-SyntaxHighlightImprovement-HernanWilkinson-2020Oct04-18h54m-HAW.002.cs.st 10/15/2020 19:34:10'! -Object subclass: #SHST80RangeType - instanceVariableNames: 'sourceCode messageRange receiverRange messageRangeType receiverRangeType classOrMetaClass' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -SHST80RangeType class - instanceVariableNames: ''! - -!classDefinition: 'SHST80RangeType class' category: #'Tools-Syntax Highlighting' stamp: 'Install-4394-SyntaxHighlightImprovement-HernanWilkinson-2020Oct04-18h54m-HAW.002.cs.st 10/15/2020 19:34:10'! -SHST80RangeType class - instanceVariableNames: ''! -!Class methodsFor: 'class variables' stamp: 'HAW 10/5/2020 08:09:51'! - classVarBindingOf: varNameSymbol - - ^self classPool bindingOf: varNameSymbol! ! -!Class methodsFor: 'class variables' stamp: 'HAW 10/5/2020 08:09:57'! - classVarValueOf: varNameSymbol - - ^(self classPool bindingOf: varNameSymbol) ifNotNil: [:binding | binding value ]! ! -!SHRange methodsFor: 'printing' stamp: 'HAW 10/4/2020 19:12:52' overrides: 50508084! - printOn: aStream - - aStream - nextPutAll: type; - space; - nextPut: $(; - print: start; - nextPutAll: ' to: '; - print: end; - nextPut: $)! ! -!SHST80RangeType methodsFor: 'initialize' stamp: 'HAW 10/5/2020 09:19:59'! - initializeFor: aSourceCode in: aClassOrMetaclass - - sourceCode := aSourceCode. - classOrMetaClass := aClassOrMetaclass ! ! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'HAW 10/5/2020 08:36:53'! - doesReceiverRespondsToMessageIn: aReceiver - - ^aReceiver respondsTo: self messageName! ! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'HAW 10/5/2020 09:22:07'! - messageName - - ^ (self sourceCodeIn: messageRange) asSymbol! ! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'HAW 10/5/2020 08:35:06'! - messageUndefinedType - - messageRangeType = #unary ifTrue: [ ^#undefinedUnary ]. - messageRangeType = #binary ifTrue: [ ^#undefinedBinary ]. - - ^#invalid - ! ! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'HAW 10/5/2020 09:22:07'! - receiverAsNumber - - ^ (self sourceCodeIn: receiverRange) asNumber! ! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'HAW 10/5/2020 09:22:07'! - receiverAsSymbol - - ^ (self sourceCodeIn: receiverRange) asSymbol! ! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'HAW 10/5/2020 09:22:07'! - sourceCodeIn: aRange - - ^ sourceCode copyFrom: aRange start to: aRange end! ! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'HAW 10/5/2020 09:55:09'! - typeWhenSendTo: receiver - - ^(self doesReceiverRespondsToMessageIn: receiver) - ifTrue: [ messageRangeType ] - ifFalse: [ self messageUndefinedType ] - - -! ! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'HAW 10/5/2020 09:55:09'! - typeWhenSendToClassVar - - | classVarValue | - - ^ classOrMetaClass - ifNil: [ messageRangeType ] - ifNotNil: [ - classVarValue := classOrMetaClass theNonMetaClass classVarValueOf: (self sourceCodeIn: receiverRange). - self typeWhenSendTo: classVarValue ]! ! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'HAW 10/5/2020 09:55:09'! - typeWhenSendToGlobal - - ^ Smalltalk - at: self receiverAsSymbol - ifPresent: [ :globalValue | self typeWhenSendTo: globalValue ] - ifAbsent: [ messageRangeType ]! ! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'HAW 10/5/2020 09:53:59'! - typeWhenSendToInstanceOf: aClass - - ^ (aClass canUnderstand: self messageName) - ifTrue: [ messageRangeType ] - ifFalse: [ self messageUndefinedType ]! ! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'HAW 10/5/2020 09:55:09'! - typeWhenSendToNumber - - ^self typeWhenSendTo: self receiverAsNumber - ! ! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'HAW 10/5/2020 09:54:17'! - typeWhenSendToSelf - - ^ classOrMetaClass - ifNil: [ messageRangeType ] - ifNotNil: [ self typeWhenSendToInstanceOf: classOrMetaClass ]! ! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'HAW 10/5/2020 09:54:28'! - typeWhenSendToSuper - - ^ classOrMetaClass - ifNil: [ messageRangeType ] - ifNotNil: [ - classOrMetaClass theNonMetaClass superclass isNil - ifTrue: [ self messageUndefinedType ] - ifFalse: [ self typeWhenSendToInstanceOf: classOrMetaClass superclass]]! ! -!SHST80RangeType methodsFor: 'range type' stamp: 'HAW 10/5/2020 09:35:07'! - lastRange: aRange - - receiverRange := aRange ! ! -!SHST80RangeType methodsFor: 'range type' stamp: 'HAW 10/5/2020 09:59:50'! - ofCurrentRangeOrMessageSendIn: aPotentialMessageRange - - | potentialMessageRangeType | - - potentialMessageRangeType := aPotentialMessageRange rangeType. - - (#(unary binary) includes: potentialMessageRangeType) ifFalse: [ ^potentialMessageRangeType ]. - receiverRange ifNil: [ ^potentialMessageRangeType ]. - - messageRange := aPotentialMessageRange. - messageRangeType := potentialMessageRangeType. - receiverRangeType := receiverRange rangeType. - - receiverRangeType = #number ifTrue: [ ^self typeWhenSendToNumber ]. - receiverRangeType = #string ifTrue: [ ^self typeWhenSendToInstanceOf: String ]. - receiverRangeType = #symbol ifTrue: [ ^self typeWhenSendToInstanceOf: Symbol ]. - receiverRangeType = #arrayEnd ifTrue: [ ^self typeWhenSendToInstanceOf: Array ]. - receiverRangeType = #rightBrace ifTrue: [ ^self typeWhenSendToInstanceOf: Array ]. - receiverRangeType = #blockEnd ifTrue: [ ^self typeWhenSendToInstanceOf: BlockClosure ]. - receiverRangeType = #character ifTrue: [ ^self typeWhenSendToInstanceOf: Character ]. - receiverRangeType = #nil ifTrue: [ ^self typeWhenSendToInstanceOf: nil class ]. - receiverRangeType = #true ifTrue: [ ^self typeWhenSendToInstanceOf: true class ]. - receiverRangeType = #false ifTrue: [ ^self typeWhenSendToInstanceOf: false class ]. - receiverRangeType = #self ifTrue: [^self typeWhenSendToSelf ]. - receiverRangeType = #super ifTrue: [^self typeWhenSendToSuper ]. - receiverRangeType = #globalVar ifTrue: [^self typeWhenSendToGlobal ]. - receiverRangeType = #classVar ifTrue: [^self typeWhenSendToClassVar ]. - - ^messageRangeType ! ! -!SHST80RangeType class methodsFor: 'instance creation' stamp: 'HAW 10/5/2020 09:20:06'! - for: aSourceCode in: aClassOrMetaclass - - ^self new initializeFor: aSourceCode in: aClassOrMetaclass! ! -!SHTextStylerST80 methodsFor: 'private - show subscript' stamp: 'HAW 10/4/2020 19:23:15'! - formatAsSubscript: range - - ^ formattedText lastIndexOf: $_ startingAt: range end endingAt: range start do: [ :i | - formattedText addAttribute: ShoutTextEmphasis subscript from: i to: range end ]! ! -!SHTextStylerST80 methodsFor: 'private - show subscript' stamp: 'HAW 10/4/2020 19:22:30'! - hasToShowSubscriptOf: range - - ^ #(instVar classVar globalVar workspaceVar poolConstant - patternArg methodArg patternTempVar tempVar - blockPatternArg blockArg blockPatternTempVar blockTempVar - incompleteIdentifier undefinedIdentifier) pointsTo: range rangeType! ! -!SHTextStylerST80 methodsFor: 'private - show subscript' stamp: 'HAW 10/4/2020 19:22:08'! - showAsSubscriptIfAppropriate: range - - classOrMetaClass ifNotNil: [ - classOrMetaClass theNonMetaClass lastUnderscoreMeansSubscript ifTrue: [ - (self hasToShowSubscriptOf: range ) ifTrue: [ self formatAsSubscript: range ]]]! ! -!SHTextStylerST80 methodsFor: 'private' stamp: 'HAW 10/5/2020 10:00:44'! - applySmalltalkStylingIn: range using: st80RangeType - - | rangeType | - - rangeType := st80RangeType ofCurrentRangeOrMessageSendIn: range. - (self attributesFor: rangeType) ifNotNil: [ :attributes | - attributes do: [ :each | formattedText addAttribute: each from: range start to: range end ]]. -! ! -!SHTextStylerST80 methodsFor: 'private' stamp: 'HAW 10/5/2020 09:17:13'! - optimizeForMutationSpeed: ranges - - "Optimize for mutation speed unless method is really large but with very few distict elements: - Source code that includes just big literals is better served by conventional Text+RunArray" - "Do it only if we are not breaking textModel!! (for instance, StyledTextEditor asks for formatting just sections, not whole #actualContents)." - formattedText == textModel actualContents ifTrue: [ - (formattedText size > 2000 and: [ ranges size < 50 ]) ifFalse: [ - formattedText _ formattedText optimizedForMutationSpeed. - textModel basicActualContents: formattedText ]]. - -! ! -!Class methodsFor: 'compiling' stamp: 'HAW 10/5/2020 08:08:59' prior: 16802636 overrides: 50450040! -localBindingOf: varNameSymbol - "Answer the binding of some variable resolved in the scope of the receiver." - - "First look in classVar dictionary." - (self classVarBindingOf: varNameSymbol) ifNotNil: [ :binding | ^binding ]. - - "Next look in shared pools." - self sharedPools do: [ :pool | - (pool bindingOf: varNameSymbol) ifNotNil: [ :binding | ^binding ]. - ]. - - "Finally look higher up the superclass chain and fail at the end." - ^superclass ifNotNil: [ superclass localBindingOf: varNameSymbol ]! ! -!SHTextStylerST80 methodsFor: 'private' stamp: 'HAW 10/5/2020 09:59:08' prior: 50371039! - setAttributesFromRanges: ranges - - | st80RangeType | - - formattedText removeAttributesThat: [ :attribute | attribute isForShout ]. - self optimizeForMutationSpeed: ranges. - st80RangeType := SHST80RangeType for: formattedText string in: classOrMetaClass. - - ranges do: [ :currentRange | - self - applySmalltalkStylingIn: currentRange using: st80RangeType; - showAsSubscriptIfAppropriate: currentRange. - st80RangeType lastRange: currentRange ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4394-SyntaxHighlightImprovement-HernanWilkinson-2020Oct04-18h54m-HAW.002.cs.st----! - -'From Cuis 5.0 [latest update: #4392] on 12 October 2020 at 7:18:56 pm'! -!MenuItemMorph methodsFor: 'selecting' stamp: 'jmv 10/12/2020 19:17:55' prior: 50534545! - select - self isSelected: true. - owner activeSubmenu: subMenu. - subMenu ifNotNil: [ - self displayBounds ifNotNil: [ :r | - subMenu delete. - subMenu - popUpAdjacentTo: (Array with: r topRight + `10@0` with: r topLeft) - from: self ]. - subMenu selectItem: nil ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4395-MenuFix-JuanVuletich-2020Oct12-19h11m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4402] on 12 October 2020 at 9:31:21 pm'! -!Morph methodsFor: 'menus' stamp: 'jmv 10/12/2020 21:29:49' prior: 50393386! - addHaloActionsTo: aMenu - "Add items to aMenu representing actions requestable via halo" - - | subMenu | - subMenu := MenuMorph new defaultTarget: self. - subMenu addTitle: (self printStringLimitedTo: 40). - subMenu addStayUpIcons. - subMenu addLine. - (subMenu add: 'delete' action: #dismissViaHalo) - setBalloonText: 'Delete this object -- warning -- can be destructive!!' . - self maybeAddCollapseItemTo: subMenu. - (subMenu add: 'grab' action: #openInHand) - setBalloonText: 'Pick this object up -- warning, since this removes it from its container, it can have adverse effects.' . - subMenu addLine. - (subMenu add: 'duplicate' action: #maybeDuplicateMorph) - setBalloonText: 'Hand me a copy of this object'. - (subMenu - add: 'set color' - target: self - action: #changeColor) - setBalloonText: 'Change the color of this object'. - (subMenu - add: 'inspect' - target: self - action: #inspect) - setBalloonText: 'Open an Inspector on this object'. - aMenu add: 'halo actions...' subMenu: subMenu! ! - -Morph removeSelector: #resizeFromMenu! - -!methodRemoval: Morph #resizeFromMenu stamp: 'Install-4396-ResizeFromMenu-removal-JuanVuletich-2020Oct12-21h29m-jmv.001.cs.st 10/15/2020 19:34:11'! -resizeFromMenu - "Commence an interaction that will resize the receiver" - - self resizeMorph! - -Morph removeSelector: #resizeMorph! - -!methodRemoval: Morph #resizeMorph stamp: 'Install-4396-ResizeFromMenu-removal-JuanVuletich-2020Oct12-21h29m-jmv.001.cs.st 10/15/2020 19:34:11'! -resizeMorph - | handle | - handle _ HandleMorph new - forEachPointDo: [ :newPoint | self morphExtent: newPoint - self morphPositionInWorld]. - self runningWorld activeHand attachMorph: handle. - handle startStepping! - -Smalltalk removeClassNamed: #HandleMorph! - -!classRemoval: #HandleMorph stamp: 'Install-4396-ResizeFromMenu-removal-JuanVuletich-2020Oct12-21h29m-jmv.001.cs.st 10/15/2020 19:34:11'! -EllipseMorph subclass: #HandleMorph - instanceVariableNames: 'pointBlock' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4396-ResizeFromMenu-removal-JuanVuletich-2020Oct12-21h29m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4392] on 12 October 2020 at 8:38:23 pm'! - -SystemOrganization removeSystemCategory: 'Tools-GUI'.! - -SystemOrganization renameCategory: 'Morphic-Widgets' toBe: 'Morphic-Composite Widgets'.! - -SystemOrganization renameCategory: 'Morphic-Views' toBe: 'Morphic-Widgets'.! - -SystemOrganization renameCategory: 'Morphic-Tools' toBe: 'Morphic-Tool Windows'.! - -Morph subclass: #WidgetMorph - instanceVariableNames: 'extent color borderWidth borderColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #WidgetMorph category: 'Morphic-Widgets' stamp: 'Install-4397-WidgetMorph-JuanVuletich-2020Oct12-19h11m-jmv.003.cs.st 10/15/2020 19:34:11'! -Morph subclass: #WidgetMorph - instanceVariableNames: 'extent color borderWidth borderColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! -!WidgetMorph commentStamp: '' prior: 0! - Hierarchy for morphs that are rectangle like, and that occupy an area that can be specified as a Rectangle. This means that, besides being of rectangular shape, sides are aligned with local coordinate axes. Including rectangles with rounded corners and such. The idea is that the 'extent' ivar is all that's needed to establish our dimensions and shape. Subclasses can add things like 'roundedCornerRadious' or such.! -!WidgetMorph methodsFor: 'accessing' stamp: 'jmv 8/21/2012 16:12'! - borderColor - ^ borderColor! ! -!WidgetMorph methodsFor: 'accessing' stamp: 'jmv 8/21/2012 16:12'! - borderColor: aColor - borderColor = aColor ifFalse: [ - borderColor _ aColor. - self redrawNeeded]! ! -!WidgetMorph methodsFor: 'accessing' stamp: 'gsa 12/28/2013 15:25'! - borderWidth - ^ borderWidth! ! -!WidgetMorph methodsFor: 'accessing' stamp: 'jmv 7/30/2014 09:24'! - borderWidth: anInteger - borderWidth = anInteger ifFalse: [ - borderWidth _ anInteger max: 0. - self redrawNeeded ]! ! -!WidgetMorph methodsFor: 'accessing' stamp: 'jmv 8/21/2012 21:54' overrides: 50387660! - color - - ^ color! ! -!WidgetMorph methodsFor: 'accessing' stamp: 'jmv 8/21/2012 21:59'! - color: aColor - "Set the receiver's color. " - color = aColor ifFalse: [ - color _ aColor. - self redrawNeeded ]! ! -!WidgetMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 21:45:32'! - defaultBorderColor - "answer the default border color/fill style for the receiver" - ^ `Color gray`! ! -!WidgetMorph methodsFor: 'initialization' stamp: 'jmv 8/21/2012 16:12'! - defaultBorderWidth - "answer the default border width for the receiver" - ^ 2! ! -!WidgetMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 21:56:39'! - defaultColor - ^ `Color orange`! ! -!WidgetMorph methodsFor: 'initialization' stamp: 'jmv 10/12/2020 20:38:00' overrides: 50540398! - initialize - super initialize. - extent _ `50@40`. - color _ self defaultColor. - borderColor _ self defaultBorderColor. - borderWidth _ self defaultBorderWidth.! ! -!WidgetMorph methodsFor: 'drawing' stamp: 'jmv 12/20/2014 14:58' overrides: 50387664! - drawOn: aCanvas - "A canvas is already set with a proper transformation from our coordinates to those of the Canvas target." - "If you redefine this method in a subclass, please take a look at the comment at #isOpaqueMorph" - aCanvas - fillRectangle: self morphLocalBounds - color: color - borderWidth: borderWidth - borderStyleSymbol: #simple - baseColorForBorder: borderColor! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 7/24/2020 10:22:57'! - morphBounds: aRectangle - self morphPosition: aRectangle topLeft. - self morphExtent: aRectangle extent! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/22/2020 16:35:34' overrides: 50384193! - morphExtent - "In our own coordinates!!" - - ^ extent! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 7/23/2020 15:52:14' overrides: 16875404! - morphExtent: newExtent - "assume it is always in our coordinates!!" - - extent = newExtent ifFalse: [ - (self privateExtent: newExtent) ifTrue: [ - self someSubmorphPositionOrExtentChanged. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]]! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 7/8/2014 11:41' overrides: 16875415! - morphExtentInWorld: newExtent - "world coordinates" - self flag: #jmvVer2. - self morphExtent: (self internalizeDistanceFromWorld: newExtent)! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 9/22/2012 14:56' overrides: 16875429! - morphHeight - -"Ensure everybody wants our coordinates!!" - self flag: #jmvVer2. - ^ extent y! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/22/2020 16:36:56'! - morphHeight: aNumber - - self morphExtent: extent x@aNumber! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 7/23/2020 15:53:07'! - morphPosition: newPos extent: newExtent - "Change the position of this morph. Argument is in owner's coordinates." - - | someChange | - someChange _ false. - (location isTranslation: newPos) ifFalse: [ - location _ location withTranslation: newPos. - someChange _ true ]. - - extent = newExtent ifFalse: [ - (self privateExtent: newExtent) ifTrue: [ - someChange _ true ]]. - - someChange ifTrue: [ - self someSubmorphPositionOrExtentChanged. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 9/28/2020 11:19:35' overrides: 50545060! - morphTopLeft - "Our hierarchy occupies a rectangle specified by #morphTopLef and #morphExtent" - ^`0@0`! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 9/22/2012 14:57' overrides: 16875521! - morphWidth - -"Ensure everybody wants our coordinates!!" - self flag: #jmvVer2. - ^ extent x! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/22/2020 16:37:29'! - morphWidth: aNumber - - self morphExtent: aNumber@extent y! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 7/20/2014 09:59'! - privateExtent: aPoint - "Answer whether extent was actually changed. - If some subclass may reject the update, answer false in those cases." - - | newExtent | - newExtent _ aPoint max: self minimumExtent. - ^extent = newExtent - ifFalse: [ extent _ newExtent ]; not! ! -!WidgetMorph methodsFor: 'geometry testing' stamp: 'jmv 7/18/2020 21:35:50' overrides: 50532209! - isOrthoRectangularMorph - "True if we are of rectangular shape, aligned with local coordinate axes. - Doesn't take into account possible rotation of our or some owner's local coordinates. - Note: SystemWindow answers true, but implements #addPossiblyUncoveredAreasIn:to: to take care of rounded corners." - - ^true! ! -!WidgetMorph methodsFor: 'geometry testing' stamp: 'jmv 7/28/2020 12:16:53' overrides: 50545033! - morphContainsPoint: aLocalPoint - "Answer true even if aLocalPoint is in a submorph, as long as it is in our shape" - - "If not visible, won't contain any point at all." - self visible ifFalse: [ ^false ]. - - "Most morphs answer true to to #isOrthoRectangularMorph, or redefine this method..." - self isOrthoRectangularMorph ifTrue: [ - ^ self morphLocalBounds containsPoint: aLocalPoint ]. - - "...But for those who not, provide correct albeit expensive behavior." - "Can't do better. Please redefine in subclasses as appropriate!! (or finish Morphic 3!!)" - "Mhhh. Podria usar el #imageForm: y ver si es transparente... deberia andar" - ^ self morphLocalBounds containsPoint: aLocalPoint! ! -!WidgetMorph methodsFor: 'geometry testing' stamp: 'jmv 7/18/2020 21:35:08' overrides: 50532141! - requiresVectorCanvas - "True if we use VectorCanvas protocol, or we are rotated or zoomed. - If false, we occupy a Rectangle in local coordinates. Allows for many optimizations to be done. - Note: If answer is false, but some owner requiresVectorCanvas, then we also do. Canvas takes care of this. - Note: SystemWindow answers false, but implements #addPossiblyUncoveredAreasIn:to: to take care of rounded corners." - - ^location isPureTranslation not! ! -!WidgetMorph methodsFor: 'geometry testing' stamp: 'jmv 7/18/2020 21:38:44' overrides: 50532157! - submorphsMightProtrude - "Answered false by morphs that can guarantee that submorphs, and all morphs in their submorphs tree, will lie inside their bounds, - either 'naturally' (by construction) or by being clipped by their owner (#clipsLastSubmorph). Allows for many optimizations to be done." - - ^false! ! -!WidgetMorph methodsFor: 'layout-properties' stamp: 'jmv 2/16/2016 13:05' overrides: 16876070! - layoutSpec: aLayoutSpec - "Layout specific. Set the layout spec describing where the receiver should appear in a proportional layout" - self layoutSpec == aLayoutSpec ifTrue: [ ^self ]. - aLayoutSpec morph: self. - layoutSpec := aLayoutSpec. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]! ! -!WidgetMorph methodsFor: 'testing' stamp: 'jmv 3/17/2013 22:54' overrides: 16876981! - is: aSymbol - ^ aSymbol == #WidgetMorph or: [ super is: aSymbol ]! ! -!WidgetMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:47:05'! - categoryInNewMorphMenu - ^ 'Kernel'! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4397-WidgetMorph-JuanVuletich-2020Oct12-19h11m-jmv.003.cs.st----! - -'From Cuis 5.0 [latest update: #4392] on 12 October 2020 at 8:42:06 pm'! - -WidgetMorph subclass: #PluggableMorph - instanceVariableNames: 'model' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #PluggableMorph category: 'Morphic-Widgets' stamp: 'Install-4398-MakeBorderedRectMorphSubclassesBeWidgets-JuanVuletich-2020Oct12-20h38m-jmv.001.cs.st 10/15/2020 19:34:12'! -WidgetMorph subclass: #PluggableMorph - instanceVariableNames: 'model' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -WidgetMorph subclass: #TileResizeMorph - instanceVariableNames: 'selectedResize selectionColor action' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #TileResizeMorph category: 'Morphic-Widgets' stamp: 'Install-4398-MakeBorderedRectMorphSubclassesBeWidgets-JuanVuletich-2020Oct12-20h38m-jmv.001.cs.st 10/15/2020 19:34:12'! -WidgetMorph subclass: #TileResizeMorph - instanceVariableNames: 'selectedResize selectionColor action' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -WidgetMorph subclass: #ProgressBarMorph - instanceVariableNames: 'value progressColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Composite Widgets'! - -!classDefinition: #ProgressBarMorph category: 'Morphic-Composite Widgets' stamp: 'Install-4398-MakeBorderedRectMorphSubclassesBeWidgets-JuanVuletich-2020Oct12-20h38m-jmv.001.cs.st 10/15/2020 19:34:12'! -WidgetMorph subclass: #ProgressBarMorph - instanceVariableNames: 'value progressColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Composite Widgets'! - -WidgetMorph subclass: #StringRequestMorph - instanceVariableNames: 'response acceptBlock cancelBlock validationBlock' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Composite Widgets'! - -!classDefinition: #StringRequestMorph category: 'Morphic-Composite Widgets' stamp: 'Install-4398-MakeBorderedRectMorphSubclassesBeWidgets-JuanVuletich-2020Oct12-20h38m-jmv.001.cs.st 10/15/2020 19:34:12'! -WidgetMorph subclass: #StringRequestMorph - instanceVariableNames: 'response acceptBlock cancelBlock validationBlock' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Composite Widgets'! - -WidgetMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp titleMorph activeSubMenu popUpOwner' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #MenuMorph category: #'Morphic-Menus' stamp: 'Install-4398-MakeBorderedRectMorphSubclassesBeWidgets-JuanVuletich-2020Oct12-20h38m-jmv.001.cs.st 10/15/2020 19:34:12'! -WidgetMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp titleMorph activeSubMenu popUpOwner' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -WidgetMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity originalPosition showUp itemsPerPage' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #AutoCompleterMorph category: #'Tools-Autocompletion' stamp: 'Install-4398-MakeBorderedRectMorphSubclassesBeWidgets-JuanVuletich-2020Oct12-20h38m-jmv.001.cs.st 10/15/2020 19:34:12'! -WidgetMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity originalPosition showUp itemsPerPage' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4398-MakeBorderedRectMorphSubclassesBeWidgets-JuanVuletich-2020Oct12-20h38m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4395] on 12 October 2020 at 8:55:55 pm'! - -WidgetMorph subclass: #DraggingGuideMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #DraggingGuideMorph category: 'Morphic-Widgets' stamp: 'Install-4399-MakeRectangleLikeMorphSubclassesBeWidgets-JuanVuletich-2020Oct12-20h53m-jmv.001.cs.st 10/15/2020 19:34:12'! -WidgetMorph subclass: #DraggingGuideMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -WidgetMorph subclass: #LayoutAdjustingMorph - instanceVariableNames: 'hand' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -!classDefinition: #LayoutAdjustingMorph category: #'Morphic-Layouts' stamp: 'Install-4399-MakeRectangleLikeMorphSubclassesBeWidgets-JuanVuletich-2020Oct12-20h53m-jmv.001.cs.st 10/15/2020 19:34:12'! -WidgetMorph subclass: #LayoutAdjustingMorph - instanceVariableNames: 'hand' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -WidgetMorph subclass: #FillInTheBlankMorph - instanceVariableNames: 'response done textPane responseUponCancel' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Composite Widgets'! - -!classDefinition: #FillInTheBlankMorph category: 'Morphic-Composite Widgets' stamp: 'Install-4399-MakeRectangleLikeMorphSubclassesBeWidgets-JuanVuletich-2020Oct12-20h53m-jmv.001.cs.st 10/15/2020 19:34:12'! -WidgetMorph subclass: #FillInTheBlankMorph - instanceVariableNames: 'response done textPane responseUponCancel' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Composite Widgets'! - -WidgetMorph subclass: #HoverHelpMorph - instanceVariableNames: 'contents textComposition' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Composite Widgets'! - -!classDefinition: #HoverHelpMorph category: 'Morphic-Composite Widgets' stamp: 'Install-4399-MakeRectangleLikeMorphSubclassesBeWidgets-JuanVuletich-2020Oct12-20h53m-jmv.001.cs.st 10/15/2020 19:34:12'! -WidgetMorph subclass: #HoverHelpMorph - instanceVariableNames: 'contents textComposition' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Composite Widgets'! -!DraggingGuideMorph methodsFor: 'initialization' stamp: 'jmv 10/12/2020 20:43:42' overrides: 50545895! - defaultBorderWidth - "answer the default border width for the receiver" - ^ 0! ! -!LayoutAdjustingMorph methodsFor: 'initialization' stamp: 'jmv 10/12/2020 20:47:51' overrides: 50545895! - defaultBorderWidth - "answer the default border width for the receiver" - ^ 0! ! -!HoverHelpMorph methodsFor: 'initialization' stamp: 'jmv 10/12/2020 20:46:53' overrides: 50545895! - defaultBorderWidth - "answer the default border width for the receiver" - ^ 0! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4399-MakeRectangleLikeMorphSubclassesBeWidgets-JuanVuletich-2020Oct12-20h53m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4396] on 12 October 2020 at 9:01:52 pm'! - -WidgetMorph subclass: #ResizeMorph - instanceVariableNames: 'gridLineWidth gridColor selectionColor outlineMorph grid from to action' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #ResizeMorph category: 'Morphic-Widgets' stamp: 'Install-4400-MakeRectangleLikeMorphSubclassesBeWidgets-JuanVuletich-2020Oct12-20h58m-jmv.001.cs.st 10/15/2020 19:34:12'! -WidgetMorph subclass: #ResizeMorph - instanceVariableNames: 'gridLineWidth gridColor selectionColor outlineMorph grid from to action' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -WidgetMorph subclass: #TranscriptMorph - instanceVariableNames: 'workspace lastIncludedIndex workspaceWindow lastUnfinishedEntrySize doImmediateUpdates' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Composite Widgets'! - -!classDefinition: #TranscriptMorph category: 'Morphic-Composite Widgets' stamp: 'Install-4400-MakeRectangleLikeMorphSubclassesBeWidgets-JuanVuletich-2020Oct12-20h58m-jmv.001.cs.st 10/15/2020 19:34:12'! -WidgetMorph subclass: #TranscriptMorph - instanceVariableNames: 'workspace lastIncludedIndex workspaceWindow lastUnfinishedEntrySize doImmediateUpdates' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Composite Widgets'! - -WidgetMorph subclass: #MenuLineMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #MenuLineMorph category: #'Morphic-Menus' stamp: 'Install-4400-MakeRectangleLikeMorphSubclassesBeWidgets-JuanVuletich-2020Oct12-20h58m-jmv.001.cs.st 10/15/2020 19:34:12'! -WidgetMorph subclass: #MenuLineMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! -!ResizeMorph methodsFor: 'initialization' stamp: 'jmv 10/12/2020 21:00:28' overrides: 50545895! - defaultBorderWidth - "answer the default border width for the receiver" - ^ 0! ! -!TranscriptMorph methodsFor: 'initialization' stamp: 'jmv 10/12/2020 21:00:55' overrides: 50545895! - defaultBorderWidth - "answer the default border width for the receiver" - ^ 0! ! -!MenuLineMorph methodsFor: 'initialization' stamp: 'jmv 10/12/2020 20:59:41' overrides: 50545895! - defaultBorderWidth - "answer the default border width for the receiver" - ^ 2! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4400-MakeRectangleLikeMorphSubclassesBeWidgets-JuanVuletich-2020Oct12-20h58m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4396] on 12 October 2020 at 9:05:07 pm'! - -Smalltalk renameClassNamed: #StringMorph as: #LabelMorph! - -!classRenamed: #StringMorph as: #LabelMorph stamp: 'Install-4401-RenameStringMorphAsLabelMorph-JuanVuletich-2020Oct12-21h01m-jmv.001.cs.st 10/15/2020 19:34:13'! -Smalltalk renameClassNamed: #StringMorph as: #LabelMorph! -!LabelMorph commentStamp: 'jmv 10/12/2020 21:03:15' prior: 50528611! - LabelMorph is a "lightweight" Morph to display a String. It supports only a single font, color, and emphasis combination. For multiple text styles, use TextModelMorph. - -Structure: -instance var Type Description -font StrikeFont (normally nil; then the accessor #font gives back a Font or nil #defaultFont) -emphasis SmallInteger bitmask determining character attributes (underline, bold, italics, struckThrough) -contents String The text that will be displayed. -! -!IndentingListItemMorph commentStamp: 'jmv 10/12/2020 21:03:00' prior: 16854563! -An IndentingListItemMorph is a LabelMorph that draws itself with an optional toggle at its left, as part of the display of the SimpleHierarchicalListMorph. - -It will also display lines around the toggle if the #showLinesInHierarchyViews Preference is set. - -Instance variables: - -indentLevel the indent level, from 0 at the root and increasing by 1 at each level of the hierarchy. - -isExpanded true if this item is expanded (showing its children) - -complexContents an adapter wrapping my represented item that can answer its children, etc. - -firstChild my first child, or nil if none - -container my container - -nextSibling the next item in the linked list of siblings, or nil if none. - -icon a 16 x 16 form or nil - -Contributed by Bob Arning as part of the ObjectExplorer package. -Don't blame him if it's not perfect. We wanted to get it out for people to play with.! - -Smalltalk renameClassNamed: #UpdatingStringMorph as: #UpdatingLabelMorph! - -!classRenamed: #UpdatingStringMorph as: #UpdatingLabelMorph stamp: 'Install-4401-RenameStringMorphAsLabelMorph-JuanVuletich-2020Oct12-21h01m-jmv.001.cs.st 10/15/2020 19:34:13'! -Smalltalk renameClassNamed: #UpdatingStringMorph as: #UpdatingLabelMorph! -!UpdatingLabelMorph commentStamp: '' prior: 50337062! - UpdatingLabelMorph new - target: [self runningWorld activeHand morphPosition asString]; - getSelector: #value; - stepTime: 10; - openInWorld! -!LabelMorph methodsFor: 'initialization' stamp: 'jmv 10/12/2020 21:06:00'! - defaultBorderWidth - "answer the default border width for the receiver" - ^ 0! ! -!LabelMorph class methodsFor: 'instance creation' stamp: 'jmv 10/12/2020 21:04:02' prior: 16918283! - contents: aString - - ^ self contents: aString font: nil! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 10/12/2020 21:02:19' prior: 50520388! - example6 - " - Useful example contributed by Ken Dickey - All these should look the same, right? (mmmh this should be a test...) - self example6 - " -| pane rect1 rect2 | -pane _ LayoutMorph newRow separation: 5. "1" -pane addMorph: (LabelMorph contents: '1'). - -rect1 := BorderedRectMorph new color: (Color lightOrange); - morphExtent: 20 @ 30. -pane addMorphFront: rect1. -rect2 := BorderedRectMorph new color: (Color cyan); - morphExtent: 20 @ 30. -pane addMorphFront: rect2. -pane - color: Color lightGreen; - morphPosition: 120 @ 50 extent: 180 @ 100; - openInWorld. - -pane _ LayoutMorph newRow separation: 5. "2" -pane addMorph: (LabelMorph contents: '2'). - -rect1 := BorderedRectMorph new color: (Color lightOrange); - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 offAxisEdgeWeight: #center). -pane addMorph: rect1. -rect2 := BorderedRectMorph new color: (Color cyan). -pane addMorph: rect2 - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 offAxisEdgeWeight: #center). -pane - color: Color lightGreen; - morphPosition: 320 @ 50 extent: 180 @ 100; - openInWorld. - - -pane _ LayoutMorph newRow separation: 5. "3" -pane addMorph: (LabelMorph contents: '3'). - -rect1 := BorderedRectMorph new color: (Color lightOrange). -pane addMorph: rect1 - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 offAxisEdgeWeight: #center). -rect2 := BorderedRectMorph new color: (Color cyan); - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 offAxisEdgeWeight: #center). -pane addMorph: rect2. -pane - color: Color lightGreen; - morphPosition: 520 @ 50 extent: 180 @ 100; - openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 10/12/2020 21:02:19' prior: 16864083! - example7 - " - Useful example contributed by Ken Dickey - All these should look the same, right? (mmmh this should be a test...) - self example7 - " - "============================================" - | c colorHexValue colorName r w | - w := SystemWindow new. - r := LayoutMorph newRow separation: 30 @ 10. - c := LayoutMorph newColumn separation: 20 @ 10. - colorHexValue := LabelMorph contents: 'F97306'. - colorName := LabelMorph contents: 'cornSilk'. - - r addMorph: colorHexValue. - r addMorph: colorName. - c addMorph: RectangleLikeMorph new. - c addMorph: r. - w addMorph: c . - w openInWorld. - "============================================"! ! -!ProgressMorph methodsFor: 'initialization' stamp: 'jmv 10/12/2020 21:02:19' prior: 50523056 overrides: 50521471! - initialize - super initialize. - self separation: 0. - labelMorph _ LabelMorph contents: '' font: FontFamily defaultFamilyAndPointSize. - subLabelMorph _ LabelMorph contents: '' font: FontFamily defaultFamilyAndPointSize. - progress _ ProgressBarMorph new. - progress morphExtent: 200 @ FontFamily defaultLineSpacing. - self addMorphFront: labelMorph. - self addMorphFront: subLabelMorph. - self addMorph: progress fixedHeight: FontFamily defaultLineSpacing! ! -!TaskbarMorph methodsFor: 'initialization' stamp: 'jmv 10/12/2020 21:02:38' prior: 50520441 overrides: 50521471! - initialize - super initialize. - viewBox _ LayoutMorph newRow color: self defaultColor. - self - addMorph: UpdatingLabelMorph initializedInstance - layoutSpec: (LayoutSpec morphWidthProportionalHeight: 0.5). - self - addMorph: viewBox - layoutSpec: (LayoutSpec - proportionalWidth: 1.0 - proportionalHeight: 1.0 - offAxisEdgeWeight: #rightOrBottom). - viewBox separation: self defaultHeight // 8 -! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 10/12/2020 21:02:19' prior: 50541027! - addNameString: aString - "Add a name display centered beneath the bottom of the outer rectangle. Return the handle." - - | nameMorph verticalNamePosition namePosition nameBackground | - nameBackground _ RectangleLikeMorph new - color: ((target is: #SystemWindow) - ifTrue: [target windowColor] - ifFalse: [`Color lightBlue alpha: 0.9`]). - nameMorph _ LabelMorph contents: aString. - nameMorph color: `Color black`. - nameBackground morphExtent: nameMorph morphExtent + 4. - verticalNamePosition _ haloBox bottom + Preferences haloHandleSize. - namePosition _ haloBox width - nameMorph morphWidth // 2 + haloBox left @ verticalNamePosition. - self addMorph: nameBackground. - nameBackground morphPosition: namePosition - 2. - self addMorph: nameMorph. - nameMorph morphPosition: namePosition. - ^nameMorph! ! -!PluggableListMorph methodsFor: 'events' stamp: 'jmv 10/12/2020 21:02:19' prior: 50538180 overrides: 16874501! - dragEvent: aMouseEvent localPosition: localEventPosition - - | row dragged listItem sm | - self listMorph highlightedRow: nil. - row _ self rowAtLocation: localEventPosition ifNone: [ ^self ]. - listItem _ self getListItem: row. - - sm _ LabelMorph contents: listItem. - dragged _ DraggingGuideMorph new. - dragged addMorph: sm. - dragged morphExtent: sm morphExtent. - dragged setProperty: #dragSource toValue: self. - dragged setProperty: #dropSelectorArgument toValue: listItem. - - aMouseEvent hand attachMorphBeside: dragged.! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'jmv 10/12/2020 21:02:19' prior: 50455543! - buildMorphicWindow - " - CodePackageListWindow open: CodePackageList new - " - | dirtyFlags names fileNames upperRow description summary backColor labelBackground | - backColor := self textBackgroundColor. - labelBackground := Theme current background. - - dirtyFlags := PluggableListMorph - model: model - listGetter: #packageDirtyFlags - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - dirtyFlags color: backColor. - dirtyFlags := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: ' Unsaved?'); - addMorphUseAll: dirtyFlags. - - names := PluggableListMorph - model: model - listGetter: #packageNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - names color: backColor. - names := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: ' Package Name'); - addMorphUseAll: names. - - fileNames := PluggableListMorph - model: model - listGetter: #packageFullNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - fileNames color: backColor. - fileNames := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: ' File Name'); - addMorphUseAll: fileNames. - - upperRow := LayoutMorph newRow. - upperRow - addMorph: dirtyFlags proportionalWidth: 0.13; - addAdjusterAndMorph: names proportionalWidth: 0.27; - addAdjusterAndMorph: fileNames proportionalWidth: 0.6. - - description := (TextModelMorph - textProvider: model - textGetter: #description - textSetter: #description:) emptyTextDisplayMessage: 'Please enter a description for this package'. - - summary := (TextModelMorph - textProvider: model - textGetter: #summary) emptyTextDisplayMessage: 'Package summary (No package selected?)'. - - self layoutMorph - addMorph: upperRow proportionalHeight: 0.6; - addAdjusterAndMorph: self buildButtonPane fixedHeight: Theme current buttonPaneHeight; - addAdjusterAndMorph: summary fixedHeight: 60; - addAdjusterAndMorph: description proportionalHeight: 0.25; - addAdjusterAndMorph: self buildRequirementsPane proportionalHeight: 0.15. - self setLabel: 'Installed Packages'! ! -!ChangeSorterWindow methodsFor: 'GUI building' stamp: 'jmv 10/12/2020 21:02:19' prior: 50388035! - buildMorphicWindow - "Add a set of change sorter views to the given top view offset by the given amount. To create a single change sorter, call this once with an offset of 0@0. To create a dual change sorter, call it twice with offsets of 0@0 and 0.5@0." - - | dirtyFlags changeSetList classList messageList upperPanes backColor labelBackground | - backColor _ self textBackgroundColor. - labelBackground _ Theme current background. - model myChangeSet ifNil: [ - self flag: #ojo. "Or whatever was last changed, or is top of list, or whatever" - model myChangeSet: ChangeSet changeSetForBaseSystem ]. - - dirtyFlags _ PluggableListMorph - model: model - listGetter: #changeSetDirtyFlags - indexGetter: nil - indexSetter: nil. - dirtyFlags color: backColor. - dirtyFlags _ LayoutMorph newColumn - color: Theme current background; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: ' Unsaved?'); - addMorphUseAll: dirtyFlags. - - changeSetList _ (PluggableListMorphByItem - model: model - listGetter: #changeSetList - indexGetter: #currentCngSet - indexSetter: #showChangeSetNamed: - mainView: self - menuGetter: #changeSetMenu - keystrokeAction: #changeSetListKey:from:) - autoDeselect: false. - changeSetList color: backColor. - changeSetList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: 'Change Set name'); - addMorphUseAll: changeSetList. - - classList _ PluggableListMorphByItem - model: model - listGetter: #classList - indexGetter: #currentClassName - indexSetter: #currentClassName: - mainView: self - menuGetter: #classListMenu - keystrokeAction: #classListKey:from:. - classList color: backColor. - classList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: 'Classes'); - addMorphUseAll: classList. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: dirtyFlags proportionalWidth: 0.13; - addAdjusterAndMorph: changeSetList proportionalWidth: 0.47; - addAdjusterAndMorph: classList proportionalWidth: 0.4. - - messageList _ PluggableListMorphByItem - model: model - listGetter: #messageList - indexGetter: #currentSelector - indexSetter: #currentSelector: - mainView: self - menuGetter: #messageMenu - keystrokeAction: #messageListKey:from:. - messageList color: backColor. - messageList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: 'Methods'); - addMorphUseAll: messageList. - - self layoutMorph - addMorph: upperPanes proportionalHeight: 0.25; - addAdjusterAndMorph: messageList proportionalHeight: 0.2; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.55. - - self setLabel: model labelString! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jmv 10/12/2020 21:02:19' prior: 50385740! - createQueryTextMorph: queryString - "create the queryTextMorph" - | result | - result _ LabelMorph new contents: queryString. - result lock. - result morphExtent: `24@2` * self sizeUnit. - self addMorph: result position: `2@0.5` * self sizeUnit // 1. - ^ result! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'jmv 10/12/2020 21:02:19' prior: 50513734! - addTitle: aString - | titleMorph s pp w | - titleMorph _ RectangleLikeMorph new. - titleMorph color: Theme current menuTitleBar. - pp _ `8@2`. - aString asString linesDo: [ :line | - s _ LabelMorph new - contents: line; - font: Preferences standardMenuFont bold. - titleMorph addMorphBack: s position: pp. - pp _ pp + (0@(s morphHeight+2)) ]. - w _ titleMorph submorphs inject: 0 into: [ :prev :each | - prev max: each morphWidth ]. - titleMorph morphExtent: (w + 16) @ (pp y). - self addMorphFront: titleMorph.! ! -!MenuMorph methodsFor: 'accessing' stamp: 'jmv 10/12/2020 21:04:14' prior: 50544596 overrides: 16876446! - label - "Answer a nice label. - - Pinned menus in the taskbar are easier to identify on big screens." - - titleMorph ifNil: [ ^ super label ]. - titleMorph submorphsDo: [ :labelMorph | - "Be careful" - [ ^ labelMorph contents ] onDNU: #contents do: [] ]. - ^ super label ":] One never knows"! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 10/12/2020 21:02:19' prior: 50384856! - addTitle: aString - "Add a title line at the top of this menu Make aString its initial - contents. - If aSelector is not nil, then periodically obtain fresh values for its - contents by sending aSelector to aTarget.." - - | s pp w | - - titleMorph _ RectangleLikeMorph new. - titleMorph color: Theme current menuTitleBar. - pp _ `8@2`. - aString asString linesDo: [ :line | - s _ LabelMorph new - contents: line; - font: Preferences standardMenuFont bold. - titleMorph addMorphBack: s position: pp. - pp _ pp + (0@(s morphHeight+2)) ]. - w _ titleMorph submorphs inject: 0 into: [ :prev :each | - prev max: each morphWidth ]. - titleMorph morphExtent: (w + 16) @ (pp y). - self addMorphFront: titleMorph. - - (self hasProperty: #needsStayUpIcons) ifTrue: [ self addStayUpIcons ]! ! -!MenuMorph methodsFor: 'keyboard control' stamp: 'jmv 10/12/2020 21:02:19' prior: 50388215! - displayFiltered: evt - | matchStr allItems isMatch matches feedbackMorph | - matchStr _ self valueOfProperty: #matchString. - allItems _ self submorphs select: [ :m | - m is: #MenuItemMorph ]. - matches _ allItems select: [ :m | - isMatch _ matchStr isEmpty or: [ - m contents - includesSubstring: matchStr - caseSensitive: false ]. - m isEnabled: isMatch. - isMatch ]. - feedbackMorph _ self valueOfProperty: #feedbackMorph. - feedbackMorph ifNil: [ - feedbackMorph _ LabelMorph new color: `Color veryDarkGray`. - self addMorphBack: feedbackMorph lock position: `0@ -20`. - self - setProperty: #feedbackMorph - toValue: feedbackMorph ]. - feedbackMorph contents: '<' , matchStr , '>'. - matchStr isEmpty ifTrue: [ - feedbackMorph delete. - self removeProperty: #feedbackMorph ]. - matches notEmpty ifTrue: [ - self selectItem: matches first ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4401-RenameStringMorphAsLabelMorph-JuanVuletich-2020Oct12-21h01m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4411] on 15 October 2020 at 9:20:32 am'! - -"Change Set: 4402-MakeLabelMorphAWidget-JuanVuletich-2020Oct15-19h03m-jmv.001.cs.st -Date: 15 October 2020 -Author: Juan Vuletich - -Modifying class definition of core to Morphs is tricky. Hence this preamble." -| ui b cs | -Utilities authorInitialsPerSe ifNil: [ Utilities setAuthor ]. -(nil confirm: 'In order to modify instance definition of LabelMorph, -we need to restart the User Interface process. -You''ll need to do [Install New Updates] again, to install later updates.') ifFalse: [ self halt ]. -[ - ui _ UISupervisor ui. - UISupervisor stopUIProcess. - b _ ClassBuilder isSilent. - ClassBuilder beSilent: true. - ClassBuilder new - superclass: WidgetMorph - subclass: #LabelMorph - instanceVariableNames: 'font emphasis contents' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'. - ClassBuilder new - superclass: LabelMorph - subclass: #UpdatingLabelMorph - instanceVariableNames: 'target getSelector stepTime' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'. - ClassBuilder beSilent: b. - UISupervisor spawnNewMorphicProcessFor: ui. - (Delay forSeconds: 1) wait. - ChangeSet installing: '4402-MakeLabelMorphAWidget-JuanVuletich-2020Oct15-19h03m-jmv.001.cs.st' do: []. - cs _ ChangeSet changeSetForBaseSystem. - (cs name beginsWith: '4402') ifTrue: [ - ChangeSet removeChangeSet: cs ]. - 'Done updating definition of LabelMorph.' print. - 'Installed ChangeSet: 4402-MakeLabelMorphAWidget-JuanVuletich-2020Oct15-19h03m-jmv.001.cs.st' print. - 'Please do [Install New Updates] again.' print. -] forkAt: 41! - -'From Cuis 5.0 [latest update: #4396] on 12 October 2020 at 9:09:20 pm'! -!LayoutMorph methodsFor: 'initialization' stamp: 'jmv 10/12/2020 21:09:06' overrides: 16899205! - drawOn: aCanvas - "A canvas is already set with a proper transformation from our coordinates to those of the Canvas target." - "If you redefine this method in a subclass, please take a look at the comment at #isOpaqueMorph" - aCanvas - fillRectangle: self morphLocalBounds - color: color - borderWidth: 0 - borderStyleSymbol: #simple - baseColorForBorder: Color white! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4403-LayoutMorphBeWidget-01-JuanVuletich-2020Oct12-21h07m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4396] on 12 October 2020 at 9:10:58 pm'! - -WidgetMorph subclass: #LayoutMorph - instanceVariableNames: 'direction separation axisEdgeWeight doAdoptWidgetsColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -!classDefinition: #LayoutMorph category: #'Morphic-Layouts' stamp: 'Install-4404-LayoutMorphBeWidget-02-JuanVuletich-2020Oct12-21h09m-jmv.001.cs.st 10/15/2020 19:34:21'! -WidgetMorph subclass: #LayoutMorph - instanceVariableNames: 'direction separation axisEdgeWeight doAdoptWidgetsColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! -!LayoutMorph methodsFor: 'initialization' stamp: 'jmv 10/12/2020 21:00:28' overrides: 50545895! - defaultBorderWidth - "answer the default border width for the receiver" - ^ 0! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -LayoutMorph allSubInstancesDo: [ :each | each instVarNamed: 'borderWidth' put: 0; instVarNamed: 'borderColor' put: Color white ].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4404-LayoutMorphBeWidget-02-JuanVuletich-2020Oct12-21h09m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4396] on 12 October 2020 at 9:11:28 pm'! - -LayoutMorph removeSelector: #drawOn:! - -!methodRemoval: LayoutMorph #drawOn: stamp: 'Install-4405-LayoutMorphBeWidget-03-JuanVuletich-2020Oct12-21h10m-jmv.001.cs.st 10/15/2020 19:34:21'! -drawOn: aCanvas - "A canvas is already set with a proper transformation from our coordinates to those of the Canvas target." - "If you redefine this method in a subclass, please take a look at the comment at #isOpaqueMorph" - aCanvas - fillRectangle: self morphLocalBounds - color: color - borderWidth: 0 - borderStyleSymbol: #simple - baseColorForBorder: Color white! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4405-LayoutMorphBeWidget-03-JuanVuletich-2020Oct12-21h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4403] on 12 October 2020 at 9:31:21 pm'! - -WidgetMorph subclass: #InnerPluggableMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #InnerPluggableMorph category: 'Morphic-Widgets' stamp: 'Install-4406-InnerPluggableMorphBeWidget-JuanVuletich-2020Jul31-16h13m-jmv.001.cs.st 10/15/2020 19:34:21'! -WidgetMorph subclass: #InnerPluggableMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4406-InnerPluggableMorphBeWidget-JuanVuletich-2020Jul31-16h13m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4404] on 12 October 2020 at 9:46:07 pm'! - -WidgetMorph subclass: #ImageMorph - instanceVariableNames: 'image' - classVariableNames: 'DefaultForm ' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #ImageMorph category: 'Morphic-Widgets' stamp: 'Install-4407-ImageMorphBeWidget-JuanVuletich-2020Oct12-21h45m-jmv.001.cs.st 10/15/2020 19:34:21'! -WidgetMorph subclass: #ImageMorph - instanceVariableNames: 'image' - classVariableNames: 'DefaultForm' - poolDictionaries: '' - category: 'Morphic-Widgets'! -!ImageMorph methodsFor: 'initialization' stamp: 'jmv 10/12/2020 21:45:40' overrides: 50545895! - defaultBorderWidth - "answer the default border width for the receiver" - ^ 0! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4407-ImageMorphBeWidget-JuanVuletich-2020Oct12-21h45m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4407] on 14 October 2020 at 9:50:53 pm'! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 3/6/2020 16:06:23' prior: 50499923! - example1 -" - self example1 -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example1. -pane color: Color red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Color red; - addMorph: (WidgetMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addMorph: (WidgetMorph new color: (Color blue); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addMorph: (WidgetMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 200 fixedHeight: 200). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Color red; - addMorph: (WidgetMorph new color: (Color blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #G) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Color red; - addMorph: (WidgetMorph new color: (Color h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8); - addMorph: (WidgetMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (WidgetMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -pane morphPosition: 150@130 extent: 400@300. -pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/12/2015 16:42' prior: 50359986! - example10 -" - self example10 openInWorld -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example10. -pane color: Color red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Color red; - addMorph: (WidgetMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addAdjusterMorph; - addMorph: (WidgetMorph new color: (Color blue); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addAdjusterMorph; - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addAdjusterMorph; - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addAdjusterMorph; - addMorph: (WidgetMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 20). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Color red; - addMorph: (WidgetMorph new color: (Color blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #G) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Color red; - addMorph: (WidgetMorph new color: (Color h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8); - addMorph: (WidgetMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (WidgetMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -^ pane! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/5/2015 10:55' prior: 50360054! - example11 -" - self example11 -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example11. -pane color: Color red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Color red; - addMorph: (WidgetMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addAdjusterMorph; - addMorph: (WidgetMorph new color: (Color blue); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addAdjusterMorph; - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addAdjusterMorph; - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addAdjusterMorph; - addMorph: (WidgetMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 20). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Color red; - addMorph: (WidgetMorph new color: (Color blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #G) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Color red; - addMorph: (WidgetMorph new color: (Color h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8); - addMorph: (WidgetMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (WidgetMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -pane morphPosition: 150@130 extent: 400@300. -pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'KenD 5/22/2020 13:57:31' prior: 50520267! - example13 - " - self example13 - " - | pane row innerRow | -pane _ (LayoutMorph newColumn separation: 5) name: #example13. - pane color: Color red. - row _ (LayoutMorph newRow separation: 5) name: #Row. - innerRow _ (LayoutMorph newRow separation: 5) name: #InnerRow; - color: Color red. - innerRow - addMorph: (WidgetMorph new name: #Box1) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (WidgetMorph new name: #Box2) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (WidgetMorph new name: #Bar) - layoutSpec: (LayoutSpec proportionalWidth: 1.0 fixedHeight: 10). - row - color: (Color h: 270 s: 0.2 v: 0.6); - addMorph: innerRow - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 30 offAxisEdgeWeight: #center); - addMorph: LayoutAdjustingMorph new layoutSpec: (LayoutSpec fixedWidth: 5); - addMorph: (WidgetMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #Rect1) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40 offAxisEdgeWeight: #leftOrTop); - addMorph: LayoutAdjustingMorph new layoutSpec: (LayoutSpec fixedWidth: 5); - addMorph: (WidgetMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #Rect2) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). - pane addMorph: row layoutSpec: (LayoutSpec proportionalHeight: 0.9). - pane morphPosition: 250@130 extent: 400@300. - pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 2/16/2016 13:27' prior: 50360171! - example1b -" -Based on #example1, but using some Morph instead of RectangleLikeMorph -> extent is not adjustable - self example1b -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example1. -pane color: Color red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Color red; - addMorph: (WidgetMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addMorph: (Morph new name: #B); - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addMorph: (WidgetMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 20). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Color red; - addMorph: (WidgetMorph new color: (Color blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (Morph new name: #G); - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Color red; - addMorph: (Morph new name: #J); - addMorph: (WidgetMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (WidgetMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -pane morphPosition: 150@130 extent: 400@300. -pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'KenD 5/22/2020 13:55:23' prior: 50520314! - example2 - " - self example2 - " - | pane row | - pane _ (LayoutMorph newColumn separation: 5) name: #example2. - pane color: Color red. - row _ (LayoutMorph newRow separation: 5) name: #Row. - row - color: (Color h: 270 s: 0.2 v: 0.6); - addMorph: (WidgetMorph new color: (Color h: 120 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8 offAxisEdgeWeight: #rightOrBottom); - addMorph: (WidgetMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8 fixedHeight: 40 offAxisEdgeWeight: #leftOrTop); - addMorph: (WidgetMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 0.7 offAxisEdgeWeight: #center). - pane addMorph: row layoutSpec: (LayoutSpec proportionalHeight: 0.9). - pane morphPosition: 200@180 extent: 400@300. - pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 11/18/2015 09:45' prior: 50360264! - example20 -" - self example20 -" -| column | - -column _ (LayoutMorph newColumn separation: 5) name: #Column. -column - color: Color red; - addMorph: (WidgetMorph new color: (Color h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec proportionalWidth: 0.8 fixedHeight: 20); - addMorph: (WidgetMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec fixedWidth: 40 proportionalHeight: 0.5); - addMorph: (WidgetMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec proportionalWidth: 1.0 fixedHeight: 30). -column morphPosition: 150@130 extent: 400@300. -column openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'KenD 5/22/2020 13:58:02' prior: 50520346! - example3 - " - self example3 - " - | pane row innerRow | -pane _ (LayoutMorph newColumn separation: 5) name: #example3. - pane color: Color red. - row _ (LayoutMorph newRow separation: 5) name: #Row. - innerRow _ (LayoutMorph newRow separation: 5) name: #InnerRow; - color: Color red. - innerRow - addMorph: (WidgetMorph new name: #Box1) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (WidgetMorph new name: #Box2) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (WidgetMorph new name: #Bar) - layoutSpec: (LayoutSpec proportionalWidth: 1.0 fixedHeight: 10). - row - color: (Color h: 270 s: 0.2 v: 0.6); - addMorph: innerRow - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 30 offAxisEdgeWeight: #center); - addMorph: (WidgetMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #Rect1) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40 offAxisEdgeWeight: #leftOrTop); - addMorph: (WidgetMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #Rect2) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). - pane addMorph: row layoutSpec: (LayoutSpec proportionalHeight: 0.9). - pane morphPosition: 250@130 extent: 400@300. - pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 10/12/2020 21:02:19' prior: 50546497! - example6 - " - Useful example contributed by Ken Dickey - All these should look the same, right? (mmmh this should be a test...) - self example6 - " -| pane rect1 rect2 | -pane _ LayoutMorph newRow separation: 5. "1" -pane addMorph: (LabelMorph contents: '1'). - -rect1 := WidgetMorph new color: (Color lightOrange); - morphExtent: 20 @ 30. -pane addMorphFront: rect1. -rect2 := WidgetMorph new color: (Color cyan); - morphExtent: 20 @ 30. -pane addMorphFront: rect2. -pane - color: Color lightGreen; - morphPosition: 120 @ 50 extent: 180 @ 100; - openInWorld. - -pane _ LayoutMorph newRow separation: 5. "2" -pane addMorph: (LabelMorph contents: '2'). - -rect1 := WidgetMorph new color: (Color lightOrange); - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 offAxisEdgeWeight: #center). -pane addMorph: rect1. -rect2 := WidgetMorph new color: (Color cyan). -pane addMorph: rect2 - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 offAxisEdgeWeight: #center). -pane - color: Color lightGreen; - morphPosition: 320 @ 50 extent: 180 @ 100; - openInWorld. - - -pane _ LayoutMorph newRow separation: 5. "3" -pane addMorph: (LabelMorph contents: '3'). - -rect1 := WidgetMorph new color: (Color lightOrange). -pane addMorph: rect1 - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 offAxisEdgeWeight: #center). -rect2 := WidgetMorph new color: (Color cyan); - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 offAxisEdgeWeight: #center). -pane addMorph: rect2. -pane - color: Color lightGreen; - morphPosition: 520 @ 50 extent: 180 @ 100; - openInWorld! ! -!ResizeMorph methodsFor: 'events' stamp: 'jmv 3/10/2018 21:31:55' prior: 50388519 overrides: 16874541! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - from _ self toGridPoint: localEventPosition. - outlineMorph _ WidgetMorph new - borderColor: `Color black`; - color: `Color transparent`; - openInWorld; - hide. - self selectTo: localEventPosition! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4408-FixReferencesToBorderedRectMorph-JuanVuletich-2020Oct14-21h46m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4407] on 14 October 2020 at 10:01:55 pm'! -!WidgetMorph methodsFor: 'initialization' stamp: 'jmv 10/14/2020 21:55:52'! - noBorder - borderWidth _ 0.! ! -!ClassDescription methodsFor: 'instance variables' stamp: 'jmv 8/21/2012 16:53' prior: 16805859! - allInstVarNamesEverywhere - "Answer the set of inst var names used by the receiver, all superclasses, and all subclasses" - - | aList | - aList _ OrderedCollection new. - (self allSuperclasses , self withAllSubclasses asOrderedCollection) do: - [:cls | aList addAll: cls instVarNames]. - ^ aList asSet - - "WidgetMorph allInstVarNamesEverywhere"! ! -!Morph methodsFor: 'stepping' stamp: 'jmv 10/14/2020 21:57:23' prior: 16876536 overrides: 16882488! - stepAt: millisecondSinceLast - "Do some periodic activity. Use startStepping/stopStepping to start and stop getting sent this message. - The desired time between steps is specified by this morph's answer to the stepTime message. - The millisecondSinceLast parameter gives the time elapsed since the previous step." - " - m _ WidgetMorph new. - m color: Color random. - m openInWorld. - m morphPosition: 10@10. - t _ 0. - m when: #morphicStep evaluate: [ :delta | - t _ t + delta. - t < 10000 - ifTrue: [ - (m owner is: #HandMorph) ifFalse: [ - m morphPosition: 3@2 * t // 100 ]] - ifFalse: [ m stopStepping ]]. - m startSteppingStepTime: 20. - " - self step. - self triggerEvent: #morphicStep with: millisecondSinceLast! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 10/14/2020 21:59:31' prior: 50546608! -addNameString: aString - "Add a name display centered beneath the bottom of the outer rectangle. Return the handle." - - | nameMorph verticalNamePosition namePosition nameBackground | - nameBackground _ WidgetMorph new noBorder - color: ((target is: #SystemWindow) - ifTrue: [target windowColor] - ifFalse: [`Color lightBlue alpha: 0.9`]). - nameMorph _ LabelMorph contents: aString. - nameMorph color: `Color black`. - nameBackground morphExtent: nameMorph morphExtent + 4. - verticalNamePosition _ haloBox bottom + Preferences haloHandleSize. - namePosition _ haloBox width - nameMorph morphWidth // 2 + haloBox left @ verticalNamePosition. - self addMorph: nameBackground. - nameBackground morphPosition: namePosition - 2. - self addMorph: nameMorph. - nameMorph morphPosition: namePosition. - ^nameMorph! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 10/14/2020 21:59:16' prior: 50546550! - example7 - " - Useful example contributed by Ken Dickey - All these should look the same, right? (mmmh this should be a test...) - self example7 - " - "============================================" - | c colorHexValue colorName r w | - w := SystemWindow new. - r := LayoutMorph newRow separation: 30 @ 10. - c := LayoutMorph newColumn separation: 20 @ 10. - colorHexValue := LabelMorph contents: 'F97306'. - colorName := LabelMorph contents: 'cornSilk'. - - r addMorph: colorHexValue. - r addMorph: colorName. - c addMorph: WidgetMorph new. - c addMorph: r. - w addMorph: c . - w openInWorld. - "============================================"! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'jmv 10/14/2020 21:59:49' prior: 50546657! - buildMorphicWindow - " - CodePackageListWindow open: CodePackageList new - " - | dirtyFlags names fileNames upperRow description summary backColor labelBackground | - backColor := self textBackgroundColor. - labelBackground := Theme current background. - - dirtyFlags := PluggableListMorph - model: model - listGetter: #packageDirtyFlags - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - dirtyFlags color: backColor. - dirtyFlags := LayoutMorph newColumn - color: labelBackground; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: ' Unsaved?'); - addMorphUseAll: dirtyFlags. - - names := PluggableListMorph - model: model - listGetter: #packageNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - names color: backColor. - names := LayoutMorph newColumn - color: labelBackground; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: ' Package Name'); - addMorphUseAll: names. - - fileNames := PluggableListMorph - model: model - listGetter: #packageFullNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - fileNames color: backColor. - fileNames := LayoutMorph newColumn - color: labelBackground; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: ' File Name'); - addMorphUseAll: fileNames. - - upperRow := LayoutMorph newRow. - upperRow - addMorph: dirtyFlags proportionalWidth: 0.13; - addAdjusterAndMorph: names proportionalWidth: 0.27; - addAdjusterAndMorph: fileNames proportionalWidth: 0.6. - - description := (TextModelMorph - textProvider: model - textGetter: #description - textSetter: #description:) emptyTextDisplayMessage: 'Please enter a description for this package'. - - summary := (TextModelMorph - textProvider: model - textGetter: #summary) emptyTextDisplayMessage: 'Package summary (No package selected?)'. - - self layoutMorph - addMorph: upperRow proportionalHeight: 0.6; - addAdjusterAndMorph: self buildButtonPane fixedHeight: Theme current buttonPaneHeight; - addAdjusterAndMorph: summary fixedHeight: 60; - addAdjusterAndMorph: description proportionalHeight: 0.25; - addAdjusterAndMorph: self buildRequirementsPane proportionalHeight: 0.15. - self setLabel: 'Installed Packages'! ! -!ChangeSorterWindow methodsFor: 'GUI building' stamp: 'jmv 10/14/2020 21:59:56' prior: 50546735! - buildMorphicWindow - "Add a set of change sorter views to the given top view offset by the given amount. To create a single change sorter, call this once with an offset of 0@0. To create a dual change sorter, call it twice with offsets of 0@0 and 0.5@0." - - | dirtyFlags changeSetList classList messageList upperPanes backColor labelBackground | - backColor _ self textBackgroundColor. - labelBackground _ Theme current background. - model myChangeSet ifNil: [ - self flag: #ojo. "Or whatever was last changed, or is top of list, or whatever" - model myChangeSet: ChangeSet changeSetForBaseSystem ]. - - dirtyFlags _ PluggableListMorph - model: model - listGetter: #changeSetDirtyFlags - indexGetter: nil - indexSetter: nil. - dirtyFlags color: backColor. - dirtyFlags _ LayoutMorph newColumn - color: Theme current background; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: ' Unsaved?'); - addMorphUseAll: dirtyFlags. - - changeSetList _ (PluggableListMorphByItem - model: model - listGetter: #changeSetList - indexGetter: #currentCngSet - indexSetter: #showChangeSetNamed: - mainView: self - menuGetter: #changeSetMenu - keystrokeAction: #changeSetListKey:from:) - autoDeselect: false. - changeSetList color: backColor. - changeSetList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: 'Change Set name'); - addMorphUseAll: changeSetList. - - classList _ PluggableListMorphByItem - model: model - listGetter: #classList - indexGetter: #currentClassName - indexSetter: #currentClassName: - mainView: self - menuGetter: #classListMenu - keystrokeAction: #classListKey:from:. - classList color: backColor. - classList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: 'Classes'); - addMorphUseAll: classList. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: dirtyFlags proportionalWidth: 0.13; - addAdjusterAndMorph: changeSetList proportionalWidth: 0.47; - addAdjusterAndMorph: classList proportionalWidth: 0.4. - - messageList _ PluggableListMorphByItem - model: model - listGetter: #messageList - indexGetter: #currentSelector - indexSetter: #currentSelector: - mainView: self - menuGetter: #messageMenu - keystrokeAction: #messageListKey:from:. - messageList color: backColor. - messageList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: 'Methods'); - addMorphUseAll: messageList. - - self layoutMorph - addMorph: upperPanes proportionalHeight: 0.25; - addAdjusterAndMorph: messageList proportionalHeight: 0.2; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.55. - - self setLabel: model labelString! ! -!ScrollBar methodsFor: 'initialization' stamp: 'jmv 10/14/2020 21:58:16' prior: 16904663! - initializeSlider - "initialize the receiver's slider" - - sliderShadow _ WidgetMorph new noBorder. - self addMorph: sliderShadow. - sliderShadow hide. - - slider _ self sliderClass new. - slider model: self. - slider grabSelector: #sliderGrabbedAt:. - slider dragSelector: #scrollTo:. - slider action: #sliderReleased. - self addMorph: slider. - - self computeSlider! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'jmv 10/14/2020 21:58:39' prior: 50546846! - addTitle: aString - | titleMorph s pp w | - titleMorph _ WidgetMorph new noBorder. - titleMorph color: Theme current menuTitleBar. - pp _ `8@2`. - aString asString linesDo: [ :line | - s _ LabelMorph new - contents: line; - font: Preferences standardMenuFont bold. - titleMorph addMorphBack: s position: pp. - pp _ pp + (0@(s morphHeight+2)) ]. - w _ titleMorph submorphs inject: 0 into: [ :prev :each | - prev max: each morphWidth ]. - titleMorph morphExtent: (w + 16) @ (pp y). - self addMorphFront: titleMorph.! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 10/14/2020 22:00:03' prior: 50471992! - addStayUpIcons - | closeButton pinButton w buttonHW | - Preferences optionalButtons ifFalse: [ ^self ]. - (self valueOfProperty: #hasStayUpIcons ifAbsent: [ false ]) - ifTrue: [ - self removeProperty: #needsStayUpIcons. - ^self ]. - titleMorph ifNil: [ - "Title not yet there. Flag ourself, so this method is called again when adding title." - self setProperty: #needsStayUpIcons toValue: true. - ^ self]. - buttonHW _ Preferences windowTitleFont pointSize. - closeButton _ PluggableButtonMorph model: self action: #delete. - closeButton icon: Theme current closeIcon; color: `Color transparent`. - pinButton _ PluggableButtonMorph model: self action: #stayUp. - pinButton icon: Theme current pushPinIcon; color: `Color transparent`. - w _ (titleMorph hasSubmorphs ifTrue: [ titleMorph firstSubmorph morphWidth ] ifFalse: [ 0 ]) + 60. - self addMorphFront: - (LayoutMorph newRow - "Make room for buttons" - morphExtent: w @ (titleMorph morphHeight max: buttonHW); - color: `Color transparent`; - addMorph: closeButton fixedWidth: buttonHW; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedWidth: buttonHW//3; - addMorph: titleMorph proportionalWidth: 1; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedWidth: buttonHW//3; - addMorph: pinButton fixedWidth: buttonHW). - - self setProperty: #hasStayUpIcons toValue: true. - self removeProperty: #needsStayUpIcons! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 10/14/2020 21:58:47' prior: 50546878! - addTitle: aString - "Add a title line at the top of this menu Make aString its initial - contents. - If aSelector is not nil, then periodically obtain fresh values for its - contents by sending aSelector to aTarget.." - - | s pp w | - - titleMorph _ WidgetMorph new noBorder. - titleMorph color: Theme current menuTitleBar. - pp _ `8@2`. - aString asString linesDo: [ :line | - s _ LabelMorph new - contents: line; - font: Preferences standardMenuFont bold. - titleMorph addMorphBack: s position: pp. - pp _ pp + (0@(s morphHeight+2)) ]. - w _ titleMorph submorphs inject: 0 into: [ :prev :each | - prev max: each morphWidth ]. - titleMorph morphExtent: (w + 16) @ (pp y). - self addMorphFront: titleMorph. - - (self hasProperty: #needsStayUpIcons) ifTrue: [ self addStayUpIcons ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4409-FixReferencesToRectangleLikeMorph-JuanVuletich-2020Oct14-21h50m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4396] on 14 October 2020 at 10:13:30 pm'! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 10/14/2020 22:13:15' prior: 50547380! - example1b -" -Based on #example1, but using some ImageMorph instead of RectangleLikeMorph, so extent is not adjustable - self example1b -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example1. -pane color: Color red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Color red; - addMorph: (WidgetMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addMorph: (ImageMorph new name: #B); - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addMorph: (WidgetMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 20). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Color red; - addMorph: (WidgetMorph new color: (Color blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (ImageMorph new name: #G); - addMorph: (WidgetMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Color red; - addMorph: (ImageMorph new name: #J); - addMorph: (WidgetMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (WidgetMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -pane morphPosition: 150@130 extent: 400@300. -pane openInWorld! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4410-LayoutExampleFix-JuanVuletich-2020Oct14-22h12m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4410] on 15 October 2020 at 9:10:32 am'! - -Smalltalk renameClassNamed: #RectangleLikeMorph as: #KernelMorph! - -!classRenamed: #RectangleLikeMorph as: #KernelMorph stamp: 'Install-4411-KernelMorphsReorganization-JuanVuletich-2020Oct15-09h03m-jmv.001.cs.st 10/15/2020 19:34:22'! -Smalltalk renameClassNamed: #RectangleLikeMorph as: #KernelMorph! -!WidgetMorph commentStamp: '' prior: 50545843! - Hierarchy for morphs that are rectangle like, and that occupy an area that can be specified as a Rectangle. This means that, besides being of rectangular shape, sides are aligned with local coordinate axes. Including rectangles with rounded corners and such. The idea is that the 'extent' ivar is all that's needed to establish our dimensions and shape. Instances may have a border, see instanceVariables borderWidth and borderColor. Subclasses can use a variety of border styles: simple, inset, raised -Subclasses can add things like 'roundedCornerRadious' or such.! -!KernelMorph methodsFor: 'geometry testing' stamp: 'jmv 10/15/2020 09:09:42' prior: 50532170 overrides: 50532141! - requiresVectorCanvas - "Kernel morphs can run with the older BitBltCanvas" - - ^false! ! - -KernelMorph removeSelector: #layoutSpec:! - -!methodRemoval: KernelMorph #layoutSpec: stamp: 'Install-4411-KernelMorphsReorganization-JuanVuletich-2020Oct15-09h03m-jmv.001.cs.st 10/15/2020 19:34:22'! -layoutSpec: aLayoutSpec - "Layout specific. Set the layout spec describing where the receiver should appear in a proportional layout" - self layoutSpec == aLayoutSpec ifTrue: [ ^self ]. - aLayoutSpec morph: self. - layoutSpec := aLayoutSpec. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]! - -Smalltalk removeClassNamed: #EllipseMorph! - -!classRemoval: #EllipseMorph stamp: 'Install-4411-KernelMorphsReorganization-JuanVuletich-2020Oct15-09h03m-jmv.001.cs.st 10/15/2020 19:34:22'! -BorderedRectMorph subclass: #EllipseMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Basic'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4411-KernelMorphsReorganization-JuanVuletich-2020Oct15-09h03m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4411] on 15 October 2020 at 9:20:32 am'! - -"Change Set: 4412-ChangePastUpMorphSuperclass-JuanVuletich-2020Oct15-19h03m-jmv.001.cs.st -Date: 15 October 2020 -Author: Juan Vuletich - -Modifying class definition of core to Morphs is tricky. Hence this preamble." -| ui b cs | -Utilities authorInitialsPerSe ifNil: [ Utilities setAuthor ]. -(nil confirm: 'In order to modify instance definition of PasteUpMorph, -we need to restart the User Interface process. -You''ll need to do [Install New Updates] again, to install later updates.') ifFalse: [ self halt ]. -[ - ui _ UISupervisor ui. - UISupervisor stopUIProcess. - b _ ClassBuilder isSilent. - ClassBuilder beSilent: true. - ClassBuilder new - superclass: KernelMorph - subclass: #PasteUpMorph - instanceVariableNames: 'worldState backgroundImage backgroundImageData taskbar' - classVariableNames: 'WindowEventHandler' - poolDictionaries: '' - category: 'Morphic-Kernel'. - ClassBuilder beSilent: b. - UISupervisor spawnNewMorphicProcessFor: ui. - (Delay forSeconds: 1) wait. - ChangeSet installing: '4412-ChangePastUpMorphSuperclass-JuanVuletich-2020Oct15-19h03m-jmv.001.cs.st' do: []. - cs _ ChangeSet changeSetForBaseSystem. - (cs name beginsWith: '4412') ifTrue: [ - ChangeSet removeChangeSet: cs ]. - 'Done updating superclass of PasteUpMorph.' print. - 'Installed ChangeSet: 4412-ChangePastUpMorphSuperclass-JuanVuletich-2020Oct15-19h03m-jmv.001.cs.st' print. - 'Please do [Install New Updates] again.' print. -] forkAt: 41! - -'From Cuis 5.0 [latest update: #4412] on 15 October 2020 at 9:31:49 am'! - -Object subclass: #DropFilesAction - instanceVariableNames: 'dropFilesEvent selectedFileEntry shouldAskToStop stopHereBlock' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -!classDefinition: #DropFilesAction category: #'Morphic-Kernel' stamp: 'Install-4413-AdditionalMorphReorganization-JuanVuletich-2020Oct15-09h30m-jmv.001.cs.st 10/15/2020 19:34:28'! -Object subclass: #DropFilesAction - instanceVariableNames: 'dropFilesEvent selectedFileEntry shouldAskToStop stopHereBlock' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -Object subclass: #WorldState - instanceVariableNames: 'hands viewBox canvas damageRecorder stepList lastStepTime lastStepMessage lastCycleTime alarms lastAlarmTime remoteServer drawingFailingMorphs waitDelay pause lastCycleHadAnyEvent activeHand world' - classVariableNames: 'DeferredUIMessages' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -!classDefinition: #WorldState category: #'Morphic-Kernel' stamp: 'Install-4413-AdditionalMorphReorganization-JuanVuletich-2020Oct15-09h30m-jmv.001.cs.st 10/15/2020 19:34:28'! -Object subclass: #WorldState - instanceVariableNames: 'hands viewBox canvas damageRecorder stepList lastStepTime lastStepMessage lastCycleTime alarms lastAlarmTime remoteServer drawingFailingMorphs waitDelay pause lastCycleHadAnyEvent activeHand world' - classVariableNames: 'DeferredUIMessages' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -Smalltalk removeClassNamed: #BorderedRectMorph! - -!classRemoval: #BorderedRectMorph stamp: 'Install-4413-AdditionalMorphReorganization-JuanVuletich-2020Oct15-09h30m-jmv.001.cs.st 10/15/2020 19:34:28'! -KernelMorph subclass: #BorderedRectMorph - instanceVariableNames: 'borderWidth borderColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - -SystemOrganization removeSystemCategory: 'Morphic-Basic'. -SystemOrganization removeSystemCategory: 'Morphic-Worlds'.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4413-AdditionalMorphReorganization-JuanVuletich-2020Oct15-09h30m-jmv.001.cs.st----! - -----SNAPSHOT----(15 October 2020 19:34:32) Cuis5.0-4413-v3.image priorSource: 6724807! - -----STARTUP---- (24 October 2020 17:30:02) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4413-v3.image! - - -'From Cuis 5.0 [latest update: #4360] on 15 October 2020 at 10:24:51 am'! -!ReturnNode methodsFor: 'testing' stamp: 'FGJ 10/15/2020 10:19:23' prior: 50443682! - isImplicitSelfReturnIn: aMethodNode - - self isReturnSelf ifFalse: [^false]. - aMethodNode encoder rangeForNode: self ifAbsent: [^true]. - - ^false! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4414-CuisCore-FernandoGasperiJabalera-2020Oct15-10h19m-FGJ.001.cs.st----! - -'From Cuis 5.0 [latest update: #4414] on 22 October 2020 at 3:50:04 pm'! -!SystemDictionary methodsFor: 'code authors' stamp: 'db 10/22/2020 15:49:32' prior: 50539927! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('AY' 'Angel Yan') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('bgs' 'Boris G. Shingarov') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('db' 'Douglas Brebner') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('EB' 'Eric Brandwein') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('FGJ' 'Fernando Gasperi Jabalera') - #('FJG' 'Facundo Javier Gelatti') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hlsf' 'Hilaire Fernandes') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('KLG' 'Gerald Klix') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MM' 'Mariano Montone') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('pmon' 'Paolo Montrasi') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('sjd' 'Santiago Jose Dandois') - #('SLD' 'Steve Davies') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('ss' 'Sebastian Sujarchuk') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tsl' 'Thiago da Silva Lino') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4415-AddDouglasBrebnerAsKnownAuthor-DouglasBrebner-2020Oct22-15h49m-db.001.cs.st----! - -'From Cuis 5.0 [latest update: #4415] on 23 October 2020 at 12:44:10 pm'! -!LabelMorph methodsFor: 'font' stamp: 'KenD 10/23/2020 08:09:09' prior: 16918193! - emphasis: aNumber - "Set the receiver's emphasis as indicated. aNumber is a bitmask with the following format: - - bit attribute - 1 bold - 2 italic - 4 underlined - 8 struckThrough - 16 withUnderscoreGlyphs - " - - "examples: 0 -> plain. - 1 -> bold. 2 -> italic. 3 -> bold italic. 4 -> underlined - 5 -> bold underlined. 6 -> italic underlined. 7 -> bold italic underlined - etc... - - Prefer AbstractFont method category: 'derivatives - emphasis' - to raw numbers: - self emphasis: AbstractFont boldItalic. - etc." - - emphasis _ aNumber. - ^ self font: font emphasis: emphasis! ! -!LabelMorph methodsFor: 'geometry' stamp: 'KenD 10/16/2020 14:43:51' prior: 16918273 overrides: 50499537! - minimumExtent - - ^ self measureContents + (2 * self borderWidth)! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4416-LabelMorph-Tweaks-KenDickey-2020Oct23-12h42m-KenD.001.cs.st----! - -'From Cuis 5.0 [latest update: #4416] on 23 October 2020 at 4:14:51 pm'! - -LayoutMorph subclass: #StringRequestMorph - instanceVariableNames: 'response acceptBlock cancelBlock validationBlock ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Composite Widgets'! - -!classDefinition: #StringRequestMorph category: 'Morphic-Composite Widgets' stamp: 'Install-4417-StringRequestMorph-Resizeable-JuanVuletich-2020Oct23-16h05m-jmv.001.cs.st 10/24/2020 17:30:07'! -LayoutMorph subclass: #StringRequestMorph - instanceVariableNames: 'response acceptBlock cancelBlock validationBlock' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Composite Widgets'! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 10/23/2020 15:37:44' prior: 50520106! - layoutBounds - "Return the bounds for laying out children of the receiver" - - ^ self morphLocalBounds insetBy: borderWidth! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'jmv 10/23/2020 16:06:31' prior: 50538125! - addTextPane - | result | - result _ (TextModelMorph - textProvider: self - textGetter: #response - textSetter: #response: - selectionGetter: #selectionInterval) emptyTextDisplayMessage: 'Enter response'. - self - valueOfProperty: #emptyTextDisplayMessage - ifPresentDo: [ :msg | - result emptyTextDisplayMessage: msg ]. - result - hasUnacceptedEdits: true; - acceptOnCR: true; - escAction: [ self cancel ]. - self addMorph: result layoutSpec: LayoutSpec useAll.! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'jmv 10/23/2020 16:14:23' prior: 50547892! - addTitle: aString - | titleMorph s pp w | - titleMorph _ WidgetMorph new noBorder. - titleMorph color: Theme current menuTitleBar. - pp _ `8@2`. - aString asString linesDo: [ :line | - s _ LabelMorph new - contents: line; - font: Preferences standardMenuFont bold. - titleMorph addMorphBack: s position: pp. - pp _ pp + (0@(s morphHeight+2)) ]. - w _ titleMorph submorphs inject: 0 into: [ :prev :each | - prev max: each morphWidth ]. - titleMorph morphExtent: (w + 24) @ (pp y). - self addMorphKeepMorphHeight: titleMorph. - ^titleMorph morphWidth! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'jmv 10/23/2020 15:45:59' prior: 50513758 overrides: 50547035! - defaultBorderWidth - "answer the default border width for the receiver" - ^ 5! ! -!StringRequestMorph methodsFor: 'initialization' stamp: 'jmv 10/23/2020 16:14:08' prior: 50513793! - setQuery: queryString initialAnswer: initialAnswer - | lineCount newExtent w | - response _ initialAnswer. - w _ self addTitle: queryString. - self addTextPane. - "If the initial response is big or has multiple lines we make the text pane bigger and with scrollbars:" - lineCount _ response lineCount. - newExtent _ lineCount > 1 - ifTrue: [ 40 @ (lineCount*2) * FontFamily defaultLineSpacing ] - ifFalse: [ (response size max: 12) @ 3.2 * FontFamily defaultLineSpacing ]. - self morphExtent: (newExtent max: w@0)! ! -!StringRequestMorph class methodsFor: 'instance creation' stamp: 'jmv 10/23/2020 15:32:25' prior: 50513860! - request: queryString centeredAt: aPoint initialAnswer: defaultAnswer validationBlock: validationBlock acceptBlock: acceptBlock cancelBlock: cancelBlock - | answer | - answer _ self newColumn - setQuery: queryString - initialAnswer: defaultAnswer; - validationBlock: validationBlock; - acceptBlock: acceptBlock; - cancelBlock: cancelBlock. - self runningWorld addMorph: answer centeredNear: aPoint - self deltaToTextPane. - ^ answer! ! -!StringRequestMorph class methodsFor: 'instance creation' stamp: 'jmv 10/23/2020 15:32:30' prior: 50544560 overrides: 50515284! - request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock - - | morph world | - - morph _ self newColumn - setQuery: queryString - initialAnswer: defaultAnswer. - (world _ self runningWorld) addMorph: morph centeredNear: world activeHand morphPosition - self deltaToTextPane. - - ^ morph getUserResponseOrCancel: cancelBlock! ! -!StringRequestMorph class methodsFor: 'private' stamp: 'jmv 10/23/2020 15:54:06' prior: 50519925! - deltaToTextPane - "Answer a distance to translate an instance of the receiver by when it is opened in the world in order to have the hand be over the text pane (so the text pane has focus). - Distance is relative to font size" - | e | - e _ Preferences windowTitleFont lineSpacing. - ^ (0)@(0.5 * e)! ! - -StringRequestMorph removeSelector: #intoWorld:! - -!methodRemoval: StringRequestMorph #intoWorld: stamp: 'Install-4417-StringRequestMorph-Resizeable-JuanVuletich-2020Oct23-16h05m-jmv.001.cs.st 10/24/2020 17:30:07'! -intoWorld: aWorld - "The receiver has just appeared in a new world. Note: - * aWorld can be nil (due to optimizations in other places) - * owner is already set - * owner's submorphs may not include receiver yet. - Important: Keep this method fast - it is run whenever morphs are added." - super intoWorld: aWorld. - self adjustSubmorphsLayout. -"this doesnt work: aWorld ifNotNil: [aWorld activeHand newKeyboardFocus: textPane]"! - -StringRequestMorph removeSelector: #adjustSubmorphsLayout! - -!methodRemoval: StringRequestMorph #adjustSubmorphsLayout stamp: 'Install-4417-StringRequestMorph-Resizeable-JuanVuletich-2020Oct23-16h05m-jmv.001.cs.st 10/24/2020 17:30:07'! -adjustSubmorphsLayout - "Enlarge the width of submorphs as needed - so all of them are have the same width, and no less than #minWidth. - Also adjust their vertical position. - Finally, set our own extent." - - | w p h | - - submorphs isEmpty ifTrue: [ ^self ]. - w _ submorphs inject: 0 into: [ :prev :each | - prev max: each minItemWidth]. - - w _ w + 1. - p _ `5 @ 5`. - submorphs do: [ :m | - h _ m morphHeight. - m morphPosition: p extent: w@h. - p _ p + (0@(h + 1)) ]. - - self morphExtent: w+4 @ p y + 5! - -LayoutMorph subclass: #StringRequestMorph - instanceVariableNames: 'response acceptBlock cancelBlock validationBlock' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Composite Widgets'! - -!classDefinition: #StringRequestMorph category: 'Morphic-Composite Widgets' stamp: 'Install-4417-StringRequestMorph-Resizeable-JuanVuletich-2020Oct23-16h05m-jmv.001.cs.st 10/24/2020 17:30:07'! -LayoutMorph subclass: #StringRequestMorph - instanceVariableNames: 'response acceptBlock cancelBlock validationBlock' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Composite Widgets'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4417-StringRequestMorph-Resizeable-JuanVuletich-2020Oct23-16h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4414] on 21 October 2020 at 3:03:43 pm'! -!Morph commentStamp: 'jmv 10/21/2020 14:49:13' prior: 50537516! - A Morph (from the Greek "shape" or "form") is an interactive graphical object. General information on the Morphic system can be found at http://wiki.squeak.org/squeak/morph. - -Morphs exist in a tree, rooted at a World (a WorldMorph). The morphs owned by a morph are its submorphs. Morphs are drawn recursively; if a Morph has no owner it never gets -drawn. To hide a Morph and its submorphs, send the #visible: message. - -Every morph has a local coordinate system to interpret positions. -Local coordinates are used in the #drawOn: method (the Canvas understands positions in the local coordinate system), for the positions of submorphs (for example #morphPosition and #morphPosition:) and for positions carried by mouse events. - -Events are delivered to morphs in Z-order, i.e. if a morph occludes another the event is only delivered to the foremost (just like physical objects). Events received by a morph carry positions in the local coordinate system. - -Morphs can be translated by an offset, rotated around their center, orbited (rotated around the owner center), and zoomed (i.e. scaled). - -Every morph has an associated transformation that defines the inner space where the morph is drawn and where the submorphs live. These transformations don't change anything from the internal point of view of the morph. - -Structure: -instance var Type Description -owner Morph My parent Morph, or nil for the top-level Morph, which is a - or nil world, typically a PasteUpMorph. -submorphs Array My child Morphs. -location GeometryTransformation Specifies position (and possibly, angle of rotation and scale change) inside owner - See comment at GeometryTransformation! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 15:01:06'! - orbitBy: radians - "Change the scale of this morph. Arguments are an angle and a scale." - location _ (AffineTransformation withRadians: radians) composedWith: location. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 14:56:59' prior: 50545267! - rotation: radians - "Change the rotation of this morph. Argument is an angle to be taken as the new rotation." - - self rotation: radians scale: location scale.! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 14:56:28' prior: 50535334! - rotation: radians scale: scale - "Change the rotation and scale of this morph. Arguments are an angle and a scale." - location _ location withRotation: radians scale: scale. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4418-MorphTweaks-JuanVuletich-2020Oct21-14h49m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4414] on 21 October 2020 at 4:20:37 pm'! - -Smalltalk renameClassNamed: #PasteUpMorph as: #OldPasteUpMorph! - -!classRenamed: #PasteUpMorph as: #OldPasteUpMorph stamp: 'Install-4419-RenamePasteUpMorphAsOldPasteUpMorph-JuanVuletich-2020Oct21-16h20m-jmv.001.cs.st 10/24/2020 17:30:07'! -Smalltalk renameClassNamed: #PasteUpMorph as: #OldPasteUpMorph! -!SystemDictionary methodsFor: 'shrinking' stamp: 'jmv 10/21/2020 16:20:05' prior: 50476063! - reduceCuis - " - Smalltalk reduceCuis - " - | keep n unused newDicts oldDicts | - - self nominallyUnsent: #reduceCuis. - - "Remove icons" - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - OldPasteUpMorph allInstancesDo: [ :w | - w backgroundImageData: nil. - w submorphsDo: [ :a | a delete ]]. - Preferences useNoMenuIcons. - Theme current initialize. - Theme content: nil. - Color shutDown. - BitBltCanvas releaseClassCachedState. - - Transcript clear. - Clipboard default initialize. - - - "Remove some methods, even if they have senders." - Utilities removeSelector: #vmStatisticsReportString. - SystemDictionary removeSelector: #recreateSpecialObjectsArray. - - StrikeFont saveSpace. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - - keep := OrderedCollection new. - keep addAll: #(SpaceTally DynamicTypingSmalltalkCompleter). - AppLauncher appGlobalName ifNotNil: [ :any | - keep add: any ]. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - [ - #hereWeGo print. - unused do: [:c | - c print. - (Smalltalk at: c) removeFromSystem]. - n := Smalltalk removeAllUnSentMessages. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - n > 0 or: [ - unused notEmpty ]] whileTrue. - ChangeSet zapAllChangeSets. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - Symbol rehash. - - "Shrink method dictionaries." - Smalltalk garbageCollect. - oldDicts _ MethodDictionary allInstances. - newDicts _ Array new: oldDicts size. - oldDicts withIndexDo: [:d :index | - newDicts at: index put: d rehashWithoutBecome ]. - oldDicts elementsExchangeIdentityWith: newDicts. - oldDicts _ newDicts _ nil. - - SmalltalkCompleter initialize . - - "Sanity checks" -" Undeclared - Smalltalk cleanOutUndeclared - Smalltalk browseUndeclaredReferences - Smalltalk obsoleteClasses - Smalltalk obsoleteBehaviors - Smalltalk browseObsoleteMethodReferences - SmalltalkImage current fixObsoleteReferences - Smalltalk browseAllUnimplementedCalls"! ! -!Morph methodsFor: 'testing' stamp: 'jmv 10/21/2020 16:20:05' prior: 50500235! - isOwnedByWorld - ^owner is: #OldPasteUpMorph! ! -!OldPasteUpMorph methodsFor: 'testing' stamp: 'jmv 10/21/2020 16:20:05' prior: 50500239 overrides: 16876981! - is: aSymbol - ^ aSymbol == #OldPasteUpMorph or: [ super is: aSymbol ]! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 10/21/2020 16:20:05' prior: 50540753! - activeSubclass: aMorphicCanvasSubclass - ActiveSubclass _ aMorphicCanvasSubclass. - OldPasteUpMorph allInstancesDo: [ :w | w setCanvas ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4419-RenamePasteUpMorphAsOldPasteUpMorph-JuanVuletich-2020Oct21-16h20m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4416] on 21 October 2020 at 5:18:31 pm'! - -KernelMorph subclass: #PasteUpMorph - instanceVariableNames: 'backgroundImage backgroundImageData' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -!classDefinition: #PasteUpMorph category: #'Morphic-Kernel' stamp: 'Install-4420-NewPasteUpMorphAndWorldMorph-JuanVuletich-2020Oct21-17h15m-jmv.001.cs.st 10/24/2020 17:30:07'! -KernelMorph subclass: #PasteUpMorph - instanceVariableNames: 'backgroundImage backgroundImageData' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! -!PasteUpMorph commentStamp: 'jmv 2/21/2016 18:32' prior: 0! - A World, the entire Smalltalk screen, is a PasteUpMorph. A World responds true to isWorld. A PasteUpMorph that is a world, builds its menu in HandMorph buildWorldMenu. - -worldState If I am also a World, keeps the hands, damageRecorder, stepList etc. -! - -PasteUpMorph subclass: #WorldMorph - instanceVariableNames: 'activeHand hands canvas damageRecorder stepList lastCycleTime alarms lastAlarmTime deferredUIMessages drawingFailingMorphs waitDelay pause lastCycleHadAnyEvent taskbar' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -!classDefinition: #WorldMorph category: #'Morphic-Kernel' stamp: 'Install-4420-NewPasteUpMorphAndWorldMorph-JuanVuletich-2020Oct21-17h15m-jmv.001.cs.st 10/24/2020 17:30:07'! -PasteUpMorph subclass: #WorldMorph - instanceVariableNames: 'activeHand hands canvas damageRecorder stepList lastCycleTime alarms lastAlarmTime deferredUIMessages drawingFailingMorphs waitDelay pause lastCycleHadAnyEvent taskbar' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! -!WorldMorph commentStamp: '' prior: 0! - A WorldMorph is a kind of PasteUpMorph that can act as the root morph of a Morphic system. Usually uses the whole Display. - -activeHand -- a HandMorph -hands -- Array of HandMorphs (typically only one) representing the Cursor and its event queue. -canvas -- BitBlitCanvas on the DisplayScreen. (Display getCanvas) -damageRecorder -- the DamageRecorder for the Display -stepList -- a Heap of StepMessage. Each morph which wants stepping has a StepMessage here. - See comment in #Morph>>stepAt: -lastStepTime -- 'now' as last sampled at step. (Time localMillisecondClock) -lastStepMessage -- nil or a selector -lastCycleTime -- 'now' as last sampled (Time localMillisecondClock) -alarms -- a Heap of MorphicAlarm. See comment in #Morph>>addAlarm:after: - An _alarm_ is an action to be done once, vs a _step_ which is cycled. -lastAlarm -- 'now' as sampled at last alarm (Time localMillisecondClock). -drawingFailureMorphs -- a WeakIdentitySet of Morphs with drawing failures -waitDelay -- a Delay (set in #WorldState>>doOneCycleFor:) -pause -- A 'phase-locked loop' style value to help regularise the step/alarm/event service rate. - (set in #WorldState>>doOneCycleFor:) -lastCycleHadAnyEvent -- a boolean (set in #WorldState>>doOneCycleFor:) -world -- a PasteUpMorph -! -!PasteUpMorph methodsFor: 'accessing' stamp: 'jmv 10/21/2020 16:24:51' overrides: 16882824! - activeHand - "Answer the currently active hand, if any..." - ^self world ifNotNil: [ :w | w activeHand ]! ! -!PasteUpMorph methodsFor: 'accessing' stamp: 'jmv 11/19/2010 13:56' overrides: 16899189! - color: aColor - super color: aColor. - self backgroundImageData: nil! ! -!PasteUpMorph methodsFor: 'accessing' stamp: 'GC 3/17/2019 08:16:08' overrides: 16874712! -handlesKeyboard - - ^ true ! ! -!PasteUpMorph methodsFor: 'caching' stamp: 'jmv 10/21/2020 16:44:28' overrides: 50510072! - releaseCachedState - super releaseCachedState. - backgroundImage _ nil.! ! -!PasteUpMorph methodsFor: 'change reporting' stamp: 'jmv 1/16/2017 09:56:14' overrides: 16874142! - addedMorph: aMorph - "Notify the receiver that the given morph was just added." - super addedMorph: aMorph. - self taskbar ifNotNil: [ :tb | - tb wasOpened: aMorph ]! ! -!PasteUpMorph methodsFor: 'change reporting' stamp: 'jmv 1/16/2017 09:56:07' overrides: 16876964! - removedMorph: aMorph - "Notify the receiver that aMorph was just removed from its children" - super removedMorph: aMorph. - self taskbar ifNotNil: [ :tb | - tb wasDeleted: aMorph ]! ! -!PasteUpMorph methodsFor: 'drawing' stamp: 'jmv 10/21/2020 16:40:25' overrides: 16899205! - drawOn: aCanvas - - "draw background image." - backgroundImage - ifNotNil: [ - aCanvas image: backgroundImage at: `0@0` ] - ifNil: [ - super drawOn: aCanvas ]! ! -!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'HAW 12/24/2018 07:13:56' overrides: 50424794! - allowsFilesDrop - - ^ true! ! -!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'jmv 1/19/2013 15:24' overrides: 16874692! - allowsMorphDrop - "Answer whether we accept dropping morphs. By default answer false." - - ^ true! ! -!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'jmv 1/19/2013 15:25' overrides: 16874701! - allowsSubmorphDrag - "Answer whether our morphs can just be grabbed with the hand, instead of requiring the use of the halo. By default answer false. - Both 'aMorph allowsGrabWithHand' and 'aMorph owner allowsSubmorphDrag' must be true for aMorph to be grabbed by the hand. It is also required that 'aMorph handlesMouseDown:' be false." - - ^ true! ! -!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'HAW 12/24/2018 10:27:39' overrides: 50424788! - dropFiles: aDropFilesEvent - - (DropFilesAction for: aDropFilesEvent) value! ! -!PasteUpMorph methodsFor: 'events' stamp: 'jmv 10/28/2019 18:13:11' overrides: 50449234! - keyStroke: aKeyboardEvent - "Handle a keystroke event." - (aKeyboardEvent commandAltKeyPressed or: [ aKeyboardEvent controlKeyPressed ]) - ifTrue: [ - aKeyboardEvent keyCharacter = $b ifTrue: [ BrowserWindow openBrowser ]. - aKeyboardEvent keyCharacter = $f ifTrue: [ BrowserWindow findClass ]. - aKeyboardEvent keyCharacter = $F ifTrue: [ MessageSetWindow findInSourceCode ]. - ]. - "aKeyboardEvent keyCharacter print." - ^ super keyStroke: aKeyboardEvent! ! -!PasteUpMorph methodsFor: 'events' stamp: 'jmv 1/18/2013 12:38' overrides: 16874541! -mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - "Handle a mouse down event." - - super mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition. - - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: #click:localPosition: - clkNHalf: nil - dblClkSel: #doubleClick:localPosition: - dblClkNHalfSel: nil - tripleClkSel: nil! ! -!PasteUpMorph methodsFor: 'events' stamp: 'jmv 10/21/2020 15:41:41' overrides: 16874682! - windowEvent: aMorphicEvent - - aMorphicEvent windowEventType == #windowClose - ifTrue: [ - ^TheWorldMenu basicNew quitSession] -! ! -!PasteUpMorph methodsFor: 'event handling testing' stamp: 'jmv 8/20/2012 18:56' overrides: 16874721! - handlesMouseDown: aMouseButtonEvent - ^true! ! -!PasteUpMorph methodsFor: 'event handling' stamp: 'jmv 3/10/2011 16:02' overrides: 16874769! - mouseButton2Activity - - ^self invokeWorldMenu! ! -!PasteUpMorph methodsFor: 'event handling' stamp: 'jmv 10/21/2020 16:48:08'! - wantsWindowEvent: anEvent - ^false! ! -!PasteUpMorph methodsFor: 'geometry' stamp: 'jmv 5/24/2020 10:07:38' overrides: 16875287! - fontPreferenceChanged - self submorphsDo: [ :m | - m morphExtent: (m morphExtent max: m minimumExtent). - m fontPreferenceChanged ]! ! -!PasteUpMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 16:33:43' overrides: 16899309! - privateExtent: newExtent - - ^ (super privateExtent: newExtent) - ifTrue: [ self buildMagnifiedBackgroundImage ]; - yourself! ! -!PasteUpMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 20:58:35'! - defaultBorderColor - "answer the default border color/fill style for the receiver" - ^ `Color - r: 0.861 - g: 1.0 - b: 0.722`! ! -!PasteUpMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:38'! - defaultBorderWidth - "answer the default border width for the receiver" - ^ 1! ! -!PasteUpMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 20:58:44' overrides: 50387674! - defaultColor - "answer the default color/fill style for the receiver" - ^ `Color - r: 0.8 - g: 1.0 - b: 0.6`! ! -!PasteUpMorph methodsFor: 'interaction loop' stamp: 'jmv 8/17/2020 13:41:37'! - mainLoop - - - self clearWaitDelay. - self setCanvas. - [ - self doOneCycle. - Processor yield. - true ] - whileTrue: []! ! -!PasteUpMorph methodsFor: 'interaction loop' stamp: 'HAW 12/26/2019 10:05:45'! - runProcess - - | process | - - process _ [ self mainLoop ] newProcess. - process - priority: Processor userSchedulingPriority; - name: 'Morphic UI'; - animatedUI: self. - - ^ process! ! -!PasteUpMorph methodsFor: 'menu & halo' stamp: 'jmv 1/19/2013 15:14'! - addWorldHaloMenuItemsTo: aMenu hand: aHandMorph - "Add standard halo items to the menu, given that the receiver is a World" - - | unlockables | - self addColorMenuItems: aMenu hand: aHandMorph. - -" aMenu addLine. - self addWorldToggleItemsToHaloMenu: aMenu." - aMenu addLine. - self addCopyItemsTo: aMenu. - self addExportMenuItems: aMenu hand: aHandMorph. - - self addDebuggingItemsTo: aMenu hand: aHandMorph. - - aMenu addLine. - aMenu defaultTarget: self. - - aMenu addLine. - - unlockables _ self submorphs select: - [ :m | m isLocked]. - unlockables size = 1 ifTrue: [ - aMenu add: ('unlock "{1}"' format:{unlockables first printStringLimitedTo: 40})action: #unlockContents]. - unlockables size > 1 ifTrue: [ - aMenu add: 'unlock all contents' action: #unlockContents. - aMenu add: 'unlock...' action: #unlockOneSubpart]. - - aMenu defaultTarget: aHandMorph. -! ! -!PasteUpMorph methodsFor: 'misc' stamp: 'jmv 3/2/2011 11:10'! - backgroundImage - ^backgroundImage! ! -!PasteUpMorph methodsFor: 'misc' stamp: 'jmv 12/8/2013 15:11'! - backgroundImageData: aByteArray - " - | filename | - filename _ 'bg/free-3d-art-pictures-gallery-wallpaper-desktop-18.jpg'. - filename _ 'bg/free-desktop-wallpaper.jpg'. - filename _ 'bg/jellyfish-thumb.jpg'. - filename _ 'bg/splash_by_beefpepsi.jpg'. - filename _ 'bg/gray ocean and pier.jpg'. - filename _ 'bg/newyork.jpg'. - filename _ 'bg/download-free-desktop-wallpaper-nature-conquestofparadise-marirs-pic.jpg'. - filename _ 'bg/desktop-wallpaper-tropical-1280x1024.jpg'. - - filename _ 'bg/free-3d-art-pictures-gallery-wallpaper-desktop-18.jpg'. - self runningWorld backgroundImageData: (FileStream readOnlyFileNamed: filename) binary contentsOfEntireFile. - " - backgroundImageData _ aByteArray. - self buildMagnifiedBackgroundImage! ! -!PasteUpMorph methodsFor: 'misc' stamp: 'jmv 10/21/2020 16:30:09'! - buildMagnifiedBackgroundImage - | image old | - old _ backgroundImage. - backgroundImageData - ifNil: [ backgroundImage _ nil ] - ifNotNil: [ - [image _ Form fromBinaryStream: backgroundImageData readStream. - backgroundImage _ image magnifyTo: extent. - ] on: Error do: [backgroundImage := nil]. "Can happen if JPEG plugin not built" - ]. - old == backgroundImage ifFalse: [ - self redrawNeeded ]! ! -!PasteUpMorph methodsFor: 'stepping and presenter' stamp: 'jmv 6/11/2012 09:59' overrides: 16876574! - wantsSteps - "Return true if the receiver wants to its #step or #stepAt: methods be run ALL THE TIME. - Morphs that send #startStepping and #stopStepping at appropriate times (i.e. when they are already in the world!!) don't need to answer true to this message. - jmv: Not really sure. Sub-world stepping needs some review." - - ^true! ! -!PasteUpMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 7/23/2020 14:47:46'! - addMorph: aMorph centeredNear: aPoint - "Add the given morph to this world, attempting to keep its center as close to the given point possible while also keeping the it entirely within the bounds of this world." - - | trialRect delta | - trialRect _ Rectangle center: aPoint extent: aMorph morphExtent. - delta _ trialRect amountToTranslateWithin: self displayBounds. - self addMorph: aMorph. - aMorph morphPositionInWorld: trialRect origin + delta.! ! -!PasteUpMorph methodsFor: 'testing' stamp: 'jmv 3/9/2020 10:13:47' overrides: 16876981! - is: aSymbol - ^ aSymbol == #PasteUpMorph or: [ super is: aSymbol ]! ! -!PasteUpMorph methodsFor: 'testing' stamp: 'jmv 10/21/2020 16:42:59' overrides: 16877003! - isReallyVisible - "Answer true only if all the owner chain is visible (i.e. if we are really visible!!)" - ^self visible and: [owner isReallyVisible ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 8/13/2013 09:17'! - bringWindowsFullOnscreen - "Make ever SystemWindow on the desktop be totally on-screen, whenever possible." - (SystemWindow - windowsIn: self - satisfying: [ :w | - w visible ]) do: [ :each | - each makeMeFullyVisible ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 8/13/2013 09:18'! - closeUnchangedWindows - "Present a menu of window titles for all windows with changes, - and activate the one that gets chosen." - (SelectionMenu confirm: 'Do you really want to close all windows -except those with unaccepted edits?') ifFalse: [ ^ self ]. - (SystemWindow - windowsIn: self - satisfying: [ :w | - w visible and: [ w canDiscardEdits ]]) do: [ :w | - w delete ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 1/24/2016 21:58'! - collapseNonWindows - self allNonWindowRelatedSubmorphs do: [ :m | - m collapse]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 1/24/2016 21:58'! - deleteNonWindows - (SelectionMenu confirm: -'Do you really want to discard all objects -that are not in windows?') - ifFalse: [^ self]. - - self allNonWindowRelatedSubmorphs do: [:m | - m delete ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 3/21/2012 17:23'! - findAChangeSorter: evt - "Locate a change sorter, open it, and bring it to the front. Create one if necessary" - self - findAWindowSatisfying: [ :aWindow | - aWindow model isMemberOf: ChangeSorter] - orMakeOneUsing: [ ChangeSorterWindow open: ChangeSorter new label: nil ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 7/4/2016 22:20'! - findAFileList: evt - "Locate a file list, open it, and bring it to the front. - Create one if necessary, respecting the Preference." - self - findAWindowSatisfying: [ :aWindow | - aWindow model class == FileList ] - orMakeOneUsing: [ - FileListWindow openFileList ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 7/4/2016 22:21'! - findAMessageNamesWindow: evt - "Locate a MessageNames tool, open it, and bring it to the front. Create one if necessary" - self - findAWindowSatisfying: [ :aWindow | - aWindow model class == MessageNames ] - orMakeOneUsing: [ - MessageNamesWindow open: MessageNames new label: 'Message Names' ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 7/30/2014 09:01'! - findATranscript: evt - "Locate a transcript, open it, and bring it to the front. Create one if necessary" - - self findATranscript! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 10/25/2010 21:29'! - findAWindowSatisfying: qualifyingBlock orMakeOneUsing: makeBlock - "Locate a window satisfying a block, open it, and bring it to the front. Create one if necessary, by using the makeBlock" - | aWindow | - submorphs do: [ :aMorph | - (((aWindow _ aMorph) is: #SystemWindow) and: [ qualifyingBlock value: aWindow ]) ifTrue: [ - aWindow isCollapsed ifTrue: [ aWindow expand ]. - aWindow activateAndForceLabelToShow. - ^ self ]]. - "None found, so create one" - makeBlock value.! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 7/5/2016 09:42'! - findDirtyBrowsers: evt - "Present a menu of window titles for browsers with changes, - and activate the one that gets chosen." - | menu | - menu _ MenuMorph new. - (SystemWindow - windowsIn: self - satisfying: [ :w | - w visible and: [ - (w model is: #CodeProvider) and: [ w canDiscardEdits not ]]]) do: [ :w | - menu - add: w label - target: w - action: #activate ]. - menu submorphs notEmpty ifTrue: [ menu popUpInWorld: self ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 8/13/2013 09:20'! - findDirtyWindows: evt - "Present a menu of window titles for all windows with changes, - and activate the one that gets chosen." - | menu | - menu _ MenuMorph new. - (SystemWindow - windowsIn: self - satisfying: [ :w | - w visible and: [ w canDiscardEdits not ]]) do: [ :w | - menu - add: w label - target: w - action: #activate ]. - menu submorphs notEmpty ifTrue: [ menu popUpInWorld: self ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 3/10/2018 22:02:53'! - findWindow: evt - "Present a menu names of windows and naked morphs, and activate the one that gets chosen. Collapsed windows appear below line, expand if chosen; naked morphs appear below second line; if any of them has been given an explicit name, that is what's shown, else the class-name of the morph shows; if a naked morph is chosen, bring it to front and have it don a halo." - | menu expanded collapsed nakedMorphs | - menu _ MenuMorph new. - expanded _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed not ]. - collapsed _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed ]. - nakedMorphs _ self submorphsSatisfying: [ :m | - (m is: #SystemWindow) not ]. - expanded isEmpty & (collapsed isEmpty & nakedMorphs isEmpty) ifTrue: [ ^ Smalltalk beep ]. - (expanded asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #activateAndForceLabelToShow. - w canDiscardEdits ifFalse: [ menu lastItem color: `Color red` ]]. - expanded isEmpty | (collapsed isEmpty & nakedMorphs isEmpty) ifFalse: [ menu addLine ]. - (collapsed asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #expand. - w canDiscardEdits ifFalse: [ menu lastItem color: `Color red` ]]. - nakedMorphs isEmpty ifFalse: [ menu addLine ]. - (nakedMorphs asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #comeToFrontAndAddHalo ]. - menu addTitle: 'find window'. - menu popUpInWorld: self! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'HAW 7/5/2018 18:24:37'! - invokeWorldMenu - "Put up the world menu, triggered by the passed-in event. - Perhaps a good place to disable it if needed" - - | menu | - menu _ (TheWorldMenu new - world: self - hand: self activeHand) buildWorldMenu. - menu addTitle: Preferences desktopMenuTitle. - menu popUpInWorld: self! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 1/8/2017 16:44:57'! - allNonWindowRelatedSubmorphs - "Answer all non-window submorphs that are not flap-related" - - ^submorphs - reject: [ :m | (m is: #SystemWindow) or: [ m is: #TaskbarMorph ] ]! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 2/28/2011 15:16'! - deleteAllHalos - self haloMorphs do: - [ :m | m delete]! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 9/13/2013 09:18'! -fullRepaintNeeded - self redrawNeeded. - SystemWindow - windowsIn: self - satisfying: [ :w | - w visible ifTrue: [ w makeMeVisible ]. - false ]! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'ar 9/28/2000 18:00'! - haloMorphs - ^ self hands collect:[:h| h halo] thenSelect:[:halo| halo notNil]! ! -!PasteUpMorph methodsFor: 'halos and balloon help' stamp: 'jmv 10/21/2020 16:46:33' overrides: 50537022! - wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph - "Answer whether the receiver would like to offer the halo handle with the given selector (e.g. #addCollapseHandle:)" - (#(addHelpHandle: addRotateHandle: addRecolorHandle:) statePointsTo: aSelector) - ifTrue: ["FIXME - hack to disable for non-functional halo items" - ^ false]. - - ^super wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph! ! -!PasteUpMorph methodsFor: 'object serialization' stamp: 'jmv 6/8/2014 18:28' overrides: 16876452! - objectForDataStream: refStrm - "I am about to be written on an object file. Write a path to me in the other system instead." - - | dp | - dp _ DiskProxy global: #Smalltalk selector: #runningWorld args: #(). - refStrm replace: self with: dp. - ^ dp! ! -!PasteUpMorph methodsFor: 'windows' stamp: 'jmv 7/30/2014 09:00'! - findATranscript - "Locate a transcript, open it, and bring it to the front. Create one if necessary" - - self - findAWindowSatisfying: [ :aWindow | aWindow model == Transcript] - orMakeOneUsing: [ TranscriptWindow openTranscript ]! ! -!PasteUpMorph methodsFor: 'ui services' stamp: 'jmv 5/23/2020 21:00:01' overrides: 50515284! - request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock - "This is deprecated because using it requires blocking the user interface until the user provides a response. Please use the variants that are not modal." - ^ StringRequestMorph request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock! ! -!PasteUpMorph methodsFor: 'ui services' stamp: 'jmv 5/23/2020 21:00:05' overrides: 50515297! - request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock - ^ StringRequestMorph request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock! ! -!PasteUpMorph class methodsFor: 'system startup' stamp: 'jmv 10/21/2020 16:49:47' overrides: 16784996! - initClassCachedState - "Should use some other way to find relevant instances" - self flag: #jmvVer2. - self allInstancesDo: [ :each | - each buildMagnifiedBackgroundImage ]. - Cursor defaultCursor activateCursor.! ! -!PasteUpMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:51:39' overrides: 50344172! - categoryInNewMorphMenu - ^ 'Worlds'! ! -!WorldMorph methodsFor: 'alarms' stamp: 'jmv 3/3/2017 09:33:59'! - addAlarm: aSelector withArguments: argArray for: aTarget at: scheduledTime - "Add a new alarm with the given set of parameters" - - alarms add: - (MorphicAlarm - receiver: aTarget - selector: aSelector - arguments: argArray - at: scheduledTime)! ! -!WorldMorph methodsFor: 'alarms' stamp: 'jmv 3/3/2017 09:34:03'! - adjustAlarmTimes: nowTime - "Adjust the alarm times after some clock weirdness (such as image-startup etc)" - | deltaTime | - deltaTime _ nowTime - lastAlarmTime. - alarms do: [ :alarm | - alarm scheduledTime: alarm scheduledTime + deltaTime ]! ! -!WorldMorph methodsFor: 'alarms' stamp: 'jmv 5/11/2016 09:53'! - alarmSortBlock - - ^[ :alarm1 :alarm2 | alarm1 scheduledTime < alarm2 scheduledTime ]! ! -!WorldMorph methodsFor: 'alarms' stamp: 'jmv 3/3/2017 11:54:00'! - removeAlarm: aSelector for: aTarget - "Remove the alarm with the given selector" - - | alarm | - alarm _ alarms - detect: [ :any | any receiver == aTarget and: [any selector == aSelector]] - ifNone: nil. - alarm ifNotNil: [ alarms remove: alarm ]! ! -!WorldMorph methodsFor: 'alarms' stamp: 'jmv 3/3/2017 09:35:03'! - triggerAlarmsBefore: nowTime - "Trigger all pending alarms that are to be executed before nowTime." - - nowTime - lastAlarmTime > 10000 - ifTrue: [ self adjustAlarmTimes: nowTime ]. - [ alarms notEmpty and: [ alarms first scheduledTime < nowTime ]] - whileTrue: [ alarms removeFirst valueAtTime: nowTime ]. - lastAlarmTime _ nowTime! ! -!WorldMorph methodsFor: 'canvas' stamp: 'di 6/7/1999 17:44'! - canvas - - ^ canvas! ! -!WorldMorph methodsFor: 'canvas' stamp: 'jmv 8/17/2020 13:42:46'! - clearCanvas - canvas _ nil. - damageRecorder _ nil.! ! -!WorldMorph methodsFor: 'canvas' stamp: 'jmv 10/21/2020 15:17:06'! - ensureNonDisplayCanvas - (canvas isNil or: [ - canvas drawsOnDisplay or: [ - (canvas extent ~= self morphExtent) or: [ - canvas form depth ~= Display depth]]]) ifTrue: [ - "allocate a new offscreen canvas the size of the window" - self setCanvas: (MorphicCanvas withExtent: self morphExtent depth: Display depth)]! ! -!WorldMorph methodsFor: 'canvas' stamp: 'jmv 8/4/2020 10:02:25'! - recordDamagedRect: damageRect for: aMorph - - damageRecorder ifNotNil: [ - damageRecorder recordInvalidRect: damageRect for: aMorph ]! ! -!WorldMorph methodsFor: 'canvas' stamp: 'jmv 10/21/2020 15:17:17'! - setCanvas - self setCanvas: Display getCanvas. - damageRecorder _ DamageRecorder new. - self redrawNeeded! ! -!WorldMorph methodsFor: 'canvas' stamp: 'jmv 10/21/2020 15:17:24'! - setCanvas: aMorphicCanvas - canvas _ aMorphicCanvas. - canvas world: self. - damageRecorder - ifNil: [ damageRecorder _ DamageRecorder new].! ! -!WorldMorph methodsFor: 'hands' stamp: 'jmv 9/25/2012 22:39' overrides: 50549029! - activeHand - ^activeHand! ! -!WorldMorph methodsFor: 'hands' stamp: 'di 6/7/1999 17:40'! - hands - - ^ hands! ! -!WorldMorph methodsFor: 'hands' stamp: 'RAA 5/24/2000 10:13'! - handsDo: aBlock - - ^ hands do: aBlock! ! -!WorldMorph methodsFor: 'hands' stamp: 'RAA 5/24/2000 12:09'! - handsReverseDo: aBlock - - ^ hands reverseDo: aBlock! ! -!WorldMorph methodsFor: 'hands' stamp: 'jmv 7/22/2020 20:42:49'! - selectHandsToDrawForDamage: damageList - "Select the set of hands that must be redrawn because either (a) the hand itself has changed or (b) the hand intersects some damage rectangle." - - | result | - result _ OrderedCollection new. - hands do: [:hand | - hand needsToBeDrawn ifTrue: [ - hand hasChanged - ifTrue: [result add: hand] - ifFalse: [ - hand displayFullBounds ifNotNil: [ :handBounds | - (damageList anySatisfy: [ :r | r intersects: handBounds]) ifTrue: [ - result add: hand]]]]]. - ^ result! ! -!WorldMorph methodsFor: 'initialization' stamp: 'jmv 6/20/2014 20:24:55'! - clearWaitDelay - waitDelay ifNotNil: [ - waitDelay unschedule. - waitDelay _ nil ]. - "Needed if for some reason Cuis is started with an earlier DateTime than the image was saved. - Might happen, especially on RasPi or other systems without an RTC" - lastCycleTime _ Time localMillisecondClock. - lastAlarmTime _ 0.! ! -!WorldMorph methodsFor: 'initialization' stamp: 'jmv 10/21/2020 16:05:30' overrides: 50384228! - initialize - - super initialize. - activeHand _ HandMorph new. - hands _ { activeHand }. - damageRecorder _ DamageRecorder new. - stepList _ Heap sortBlock: self stepListSortBlock. - alarms _ Heap sortBlock: self alarmSortBlock. - lastAlarmTime _ 0. - deferredUIMessages _ SharedQueue new. - drawingFailingMorphs _ WeakIdentitySet new. - pause _ 20. - lastCycleTime _ Time localMillisecondClock. - lastCycleHadAnyEvent _ false! ! -!WorldMorph methodsFor: 'initialization' stamp: 'jmv 2/2/2014 21:05'! - stepListSortBlock - - ^ [ :stepMsg1 :stepMsg2 | - stepMsg1 scheduledTime <= stepMsg2 scheduledTime ]! ! -!WorldMorph methodsFor: 'stepping' stamp: 'jmv 10/21/2020 15:16:15'! - cleanseStepList - "Remove morphs from the step list that are not in this World." - - | deletions | - deletions _ OrderedCollection new. - stepList do: [ :entry | - entry receiver world == self ifFalse: [ - deletions add: entry]]. - deletions do: [ :entry| - stepList remove: entry ]. - - deletions _ OrderedCollection new. - alarms do: [ :entry | - ((entry receiver is: #Morph) and: [ entry receiver world == self ]) ifFalse: [ - deletions add: entry]]. - deletions do: [ :entry| - alarms remove: entry ]! ! -!WorldMorph methodsFor: 'stepping' stamp: 'jmv 10/21/2020 15:35:50'! - runLocalStepMethods: nowTime - "Run morph 'step' methods (LOCAL TO THIS WORLD) whose time has come. Purge any morphs that are no longer in this world." - - | stepMessage | - [ stepList notEmpty and: [ stepList first scheduledTime <= nowTime ]] - whileTrue: [ - stepMessage _ stepList first. - (stepMessage receiver shouldGetStepsFrom: self) - ifFalse: [ stepList removeFirst ] - ifTrue: [ - stepMessage valueAtTime: nowTime. - stepMessage rescheduleAfter: nowTime. - "We've just updated the scheduled time for stepMessage. - It might have been that stepMessage was removed altogether from stepList. - It also may be the case that stepList got added or removed other elements while on #valueAtTime: - Just reSort. It will be ok in any case." - stepList reSort. - ] - ]! ! -!WorldMorph methodsFor: 'stepping' stamp: 'jmv 10/21/2020 15:34:17'! - runStepMethods - "Perform periodic activity inbetween event cycles" - | readyToProcess | - - "Processing the queue until empty is wrong if a block in it calls #addDeferredUIMessage: itself, because this loop will never end. - Instead, process no more than entries already in queue befor we start iterating!!" - readyToProcess _ deferredUIMessages size. - readyToProcess timesRepeat: [ - deferredUIMessages nextOrNil ifNotNil: [ :block | - block value - ] - ]. - self triggerAlarmsBefore: lastCycleTime. - self runLocalStepMethods: lastCycleTime. - - "we are using a normal #step for these now" - "aWorld allLowerWorldsDo: [ :each | each runLocalStepMethods ]." -! ! -!WorldMorph methodsFor: 'stepping' stamp: 'jmv 2/3/2014 21:15'! - startStepping: aMorph at: scheduledTime selector: aSelector stepTime: stepTimeOrNil - "Add the given morph to the step list" - - self stopStepping: aMorph selector: aSelector. - stepList add: ( - StepMessage - receiver: aMorph - selector: aSelector - at: scheduledTime - stepTime: stepTimeOrNil)! ! -!WorldMorph methodsFor: 'stepping' stamp: 'jmv 3/3/2017 11:39:34'! - stopStepping: aMorph selector: aSelector - "Remove the given morph from the step list." - stepList removeAll: (stepList select:[:stepMsg| stepMsg receiver == aMorph and: [ stepMsg selector == aSelector ]])! ! -!WorldMorph methodsFor: 'stepping' stamp: 'jmv 3/3/2017 11:39:22'! - stopSteppingMorph: aMorph - "Remove the given morph from the step list." - stepList removeAll: (stepList select: [ :stepMsg | stepMsg receiver == aMorph])! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'RAA 5/24/2000 13:13'! - checkIfUpdateNeeded - - damageRecorder updateIsNeeded ifTrue: [^true]. - hands do: [:h | (h hasChanged and: [h needsToBeDrawn]) ifTrue: [^true]]. - ^false "display is already up-to-date" -! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 10/21/2020 15:16:56'! - displayWorldSafely - "Update this world's display and keep track of errors during draw methods." - - [self displayWorld] ifError: [:err :rcvr | - "Handle a drawing error" - | errCtx errMorph | - errCtx _ thisContext. - [ - errCtx _ errCtx sender. - "Search the sender chain to find the morph causing the problem" - [errCtx notNil and: [ (errCtx receiver is: #Morph) not ]] - whileTrue:[errCtx _ errCtx sender]. - "If we're at the root of the context chain then we have a fatal drawing problem" - errCtx ifNil:[^self handleFatalDrawingError: err]. - errMorph _ errCtx receiver. - "If the morph causing the problem has already the #drawError flag set, - then search for the next morph above in the caller chain." - errMorph isKnownFailing - ] whileTrue. - errMorph drawingFails. - self setCanvas. - "Install the old error handler, so we can re-raise the error" - rcvr error: err. - ]! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 10/21/2020 15:33:56'! - doOneCycle - "Do one cycle of the interaction loop. This method is called repeatedly when the world is running. - - Make for low cpu usage if the ui is inactive, but quick response when ui is in use. - However, after some inactivity, there will be a larger delay before the ui gets responsive again." - - | wait waitUntil | - waitDelay ifNil: [ waitDelay _ Delay forMilliseconds: 50 ]. - lastCycleHadAnyEvent | deferredUIMessages isEmpty not - ifTrue: [ - pause _ 20. "This value will only be used when there are no more events to serve." - wait _ 0 ] "Don't wait" - ifFalse: [ - pause < 200 "No events processed? Start saving CPU!! But never make the user wait more than 200ms for being responsive again." - ifTrue: [ pause _ pause * 21//20 ]. - waitUntil _ lastCycleTime + pause. - "Earlier if steps" - stepList isEmpty not ifTrue: [ - waitUntil _ waitUntil min: stepList first scheduledTime ]. - "Earlier if alarms" - alarms ifNotNil: [ - alarms isEmpty not ifTrue: [ - waitUntil _ waitUntil min: alarms first scheduledTime ]]. - - wait _ waitUntil - Time localMillisecondClock ]. - Preferences serverMode - ifTrue: [ wait _ wait max: 50 ]. "Always wait at least a bit on servers, even if this makes the UI slow." - wait > 0 - ifFalse: [ Processor yield ] - ifTrue: [ - waitDelay beingWaitedOn - ifFalse: [ waitDelay setDelay: wait; wait ] - ifTrue: [ - "If we are called from a different process than that of the main UI, we might be called in the main - interCyclePause. In such case, use a new Delay to avoid 'This Delay has already been scheduled' errors" - (Delay forMilliseconds: wait) wait ]]. - - "Record start time of this cycle, and do cycle" - lastCycleTime _ Time localMillisecondClock. - lastCycleHadAnyEvent _ self doOneCycleNow! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 10/21/2020 16:04:46'! - doOneCycleNow - "Immediately do one cycle of the interaction loop. - Only used for a few tests." - "See #eventTickler" - | hadAnyEvent | - Cursor currentCursor = (Cursor cursorAt: #waitCursor) ifTrue: [ Cursor defaultCursor activateCursor ]. - "Repair visual damage." - DisplayScreen checkForNewScreenSize. - self displayWorldSafely. - "Run steps, alarms and deferred UI messages" - self runStepMethods. - "Process user input events. Run all event triggered code." - hadAnyEvent _ false. - self handsDo: [ :h | - activeHand _ h. - hadAnyEvent _ hadAnyEvent | h processEventQueue. - activeHand _ nil ]. - "The default is the primary hand" - activeHand _ self hands first. - ^ hadAnyEvent.! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 3/2/2017 20:06:48'! - doOneMinimalCycleNow - "Immediately do one cycle of the interaction loop. - Only repair display and process events. For modal menus and such." - - "Repair visual damage." - self displayWorldSafely. - - "Process user input events. Run all event triggered code." - ^activeHand processEventQueue! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 6/26/2015 14:36'! - handleFatalDrawingError: errMsg - "Handle a fatal drawing error." - - self primitiveError: - 'Fatal Morphic drawing error', String newLineString, - errMsg. - - "Hm... we should jump into a 'safe' WorldMorph here, but how do we find it?!!"! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 10/21/2020 15:17:28'! - tryDeferredUpdatingAndSetCanvas - "If this platform supports deferred updates, then make my canvas be the Display (or a rectangular portion of it), set the Display to deferred update mode, and answer true. Otherwise, set a non-Disply canvas and answer false.." - | properDisplay | - - "As this is the only sender of #deferUpdates: , this could be done in Morphic or image startup, and never efterwards..." - (Display deferUpdates: true) ifNil: [ - "deferred updates not supported by the VM, do them in the image!!" - self ensureNonDisplayCanvas. - ^ false]. - - "if no canvas, or canvas was offscreen, from a platform that didnt support defers, then fix it" - properDisplay _ canvas notNil and: [canvas drawsOnDisplay]. - properDisplay ifFalse: [ - self morphPosition: `0@0` extent: Display extent. - self setCanvas: Display getCanvas. - ]. - ^ true! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 10/21/2020 15:34:22' overrides: 50444400! - whenUIinSafeState: evaluableObject - "Please call - UISupervisor whenUIinSafeState: evaluableObject - " - deferredUIMessages nextPut: evaluableObject! ! -!WorldMorph methodsFor: 'errors on draw' stamp: 'jmv 11/5/2007 22:59'! - addKnownFailing: aMorph - drawingFailingMorphs add: aMorph! ! -!WorldMorph methodsFor: 'errors on draw' stamp: 'jmv 11/5/2007 22:59'! - isKnownFailing: aMorph - ^drawingFailingMorphs includes: aMorph! ! -!WorldMorph methodsFor: 'errors on draw' stamp: 'jmv 10/21/2020 15:54:35'! - removeAllKnownFailing - drawingFailingMorphs _ WeakIdentitySet new. - self redrawNeeded! ! -!WorldMorph methodsFor: 'errors on draw' stamp: 'jmv 11/5/2007 22:59'! -removeKnownFailing: aMorph - drawingFailingMorphs remove: aMorph! ! -!WorldMorph methodsFor: 'drawing' stamp: 'jmv 10/21/2020 17:06:37'! - displayWorld - "Update this world's display." - - | deferredUpdateVMMode worldDamageRects handsToDraw allDamage | - self checkIfUpdateNeeded ifFalse: [ ^ self ]. "display is already up-to-date" - "I (jmv) removed the call to 'deferUpdates: false' below. No more need to call this every time." - deferredUpdateVMMode _ self tryDeferredUpdatingAndSetCanvas. - - "repair world's damage on canvas" - worldDamageRects _ canvas drawWorld: self repair: damageRecorder. - - "Check which hands need to be drawn (they are not the hardware mouse pointer)" - handsToDraw _ self selectHandsToDrawForDamage: worldDamageRects. - allDamage _ Array streamContents: [ :strm | - strm nextPutAll: worldDamageRects. - handsToDraw do: [ :h | - h savePatchFrom: canvas appendDamageTo: strm ]]. - - "Draw hands (usually carying morphs) onto world canvas" - canvas newClipRect: nil. - handsToDraw reverseDo: [ :h | canvas fullDrawHand: h ]. - - "quickly copy altered rects of canvas to Display:" - deferredUpdateVMMode ifFalse: [ - "Drawing was done to off-Display canvas. Copy content to Display" - canvas showAt: self viewBox origin invalidRects: allDamage ]. - - "Display deferUpdates: false." - "Display forceDisplayUpdate" - Display forceDamageToScreen: allDamage. - - "Restore world canvas under hands and their carried morphs" - handsToDraw do: [ :h | h restoreSavedPatchOn: canvas ].! ! -!WorldMorph methodsFor: 'drawing' stamp: 'jmv 10/21/2020 16:41:02' overrides: 50549069! - drawOn: aCanvas - - "draw background image." - backgroundImage - ifNotNil: [ - aCanvas image: backgroundImage at: `0@0` ] - ifNil: [ - "draw background fill" - (aCanvas drawsOnDisplay and: [ color mightBeTranslucent ]) - ifTrue: [ - "Special case so a translucent background on the Display allows you to see through the main Cuis Window. - Requires proper handling of translucent Display in the VM. - Seems to work only on Linux when using a composing window manager." - (BitBlt toForm: Display) clipRect: aCanvas clipRect; - copy: Display boundingBox - from: `0@0` in: nil - fillColor: color rule: Form over. - Display forceToScreen] - ifFalse: [ super drawOn: aCanvas ]]! ! -!WorldMorph methodsFor: 'event handling' stamp: 'jmv 10/21/2020 16:48:04' overrides: 50549159! - wantsWindowEvent: anEvent - ^true! ! -!WorldMorph methodsFor: 'classification' stamp: 'jmv 10/21/2020 15:47:06' overrides: 16874177! - isWorldMorph - - ^ true! ! -!WorldMorph methodsFor: 'submorphs-accessing' stamp: 'jmv 10/21/2020 16:26:04' overrides: 16876668! - allMorphsDo: aBlock - "Enumerate all morphs in the world, including those held in hands." - - super allMorphsDo: aBlock. - self handsReverseDo: [:h | h allMorphsDo: aBlock].! ! -!WorldMorph methodsFor: 'submorphs-accessing' stamp: 'jmv 10/21/2020 16:31:21'! - canHandle: aMorph - - ^ canvas canDraw: aMorph! ! -!WorldMorph methodsFor: 'submorphs-accessing' stamp: 'jmv 10/21/2020 15:49:31'! -firstHand - - ^ hands first! ! -!WorldMorph methodsFor: 'change reporting' stamp: 'jmv 10/21/2020 15:50:52' overrides: 50541313! - invalidateDisplayRect: damageRect fromSubmorph: submorphOrNil for: aMorph - "Clip damage reports to my bounds, since drawing is _always_ clipped to my bounds." - - self recordDamagedRect: (damageRect intersect: self morphLocalBounds ) for: aMorph! ! -!WorldMorph methodsFor: 'testing' stamp: 'jmv 10/21/2020 16:43:17' overrides: 50549321! - isReallyVisible - "Answer true only if all the owner chain is visible (i.e. if we are really visible!!)" - ^self visible! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 16:39:39' overrides: 50537895! - displayBounds - ^0@0 extent: extent! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 16:41:28' overrides: 50463602! - externalizeDisplayBounds: r - - ^ r! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 16:41:55' overrides: 16875276! - externalizeToWorld: aPoint - "aPoint is in own coordinates. Answer is in world coordinates." - ^ aPoint! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 16:42:23' overrides: 16875326! - internalizeFromWorld: aPoint - "aPoint is in World coordinates. Answer is in own coordinates." - ^ aPoint! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 16:43:37' overrides: 50545049! - morphPositionInWorld - - self flag: #jmvVer2. "Solo para evitar los warning por falta de owner... pensar despues este caso" - ^ `0@0`! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 15:52:21' overrides: 50549171! - privateExtent: newExtent - - ^ (super privateExtent: newExtent) - ifTrue: [ - self setCanvas ]; - yourself! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 15:55:32'! - viewBox - - ^ self morphLocalBounds! ! -!WorldMorph methodsFor: 'caching' stamp: 'jmv 10/21/2020 15:54:07' overrides: 50549045! - releaseCachedState - super releaseCachedState. - self cleanseStepList. - self clearCanvas! ! -!WorldMorph methodsFor: 'structure' stamp: 'jmv 10/21/2020 15:56:00' overrides: 16876664! - world - ^self! ! -!WorldMorph methodsFor: 'misc' stamp: 'jmv 10/21/2020 16:29:57' overrides: 50549270! - buildMagnifiedBackgroundImage - super buildMagnifiedBackgroundImage. - - canvas ifNotNil: [ :c | - (backgroundImage depth = 32 and: [ c form depth < 32 ]) ifTrue: [ - backgroundImage _ backgroundImage orderedDither32To16 ]]! ! -!WorldMorph methodsFor: 'misc' stamp: 'jmv 10/21/2020 16:52:25'! - fillRects: rectangleList - "For testing. Flashes the given list of rectangles on the Display so you can watch incremental redisplay at work." - - - | blt screenRect | - blt _ (BitBlt toForm: Display) - sourceForm: nil; - sourceOrigin: `0@0`; - clipRect: self viewBox; - combinationRule: Form over. - - rectangleList do: [:r | - screenRect _ r translatedBy: self viewBox origin. - blt fillColor: Color random. - blt destRect: screenRect; copyBits. - Display forceToScreen: screenRect ]. - - (Delay forMilliseconds: 50) wait! ! -!WorldMorph methodsFor: 'misc' stamp: 'jmv 10/21/2020 16:36:53'! - restoreDisplay - self - morphExtent: Display extent; - handsDo: [ :h | h visible: true ]; - fullRepaintNeeded! ! -!WorldMorph methodsFor: 'menu & halo' stamp: 'jmv 10/21/2020 16:39:09' overrides: 16876144! - addCustomMenuItems: menu hand: aHandMorph - "Add morph-specific menu itemns to the menu for the hand" - - super addCustomMenuItems: menu hand: aHandMorph. - menu - add: 'desktop menu...' - target: self - action: #invokeWorldMenu. - menu addLine! ! -!WorldMorph methodsFor: 'printing' stamp: 'jmv 10/21/2020 16:44:07' overrides: 50500309! - printOn: aStream - "Reimplemented to add a tag showing that the receiver is currently functioning as a 'world', if it is" - - aStream nextPutAll: ' [world]'! ! -!WorldMorph methodsFor: 'halos and balloon help' stamp: 'jmv 10/21/2020 16:46:19'! - deleteBalloonTarget: aMorph - "Delete the balloon help targeting the given morph" - self handsDo:[:h| h deleteBalloonTarget: aMorph].! ! -!WorldMorph methodsFor: 'halos and balloon help' stamp: 'jmv 10/21/2020 16:47:14' overrides: 50549546! - wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph - "Answer whether the receiver would like to offer the halo handle with the given selector (e.g. #addCollapseHandle:)" - - ^#(addDebugHandle: addMenuHandle: addHelpHandle:) - statePointsTo: aSelector! ! -!WorldMorph methodsFor: 'taskbar' stamp: 'jmv 10/21/2020 17:00:39'! - hideTaskbar - taskbar ifNotNil: [ - taskbar delete. - taskbar _ nil ]! ! -!WorldMorph methodsFor: 'taskbar' stamp: 'jmv 10/21/2020 17:00:47'! - showTaskbar - - taskbar ifNil: [ - taskbar _ TaskbarMorph newRow. - taskbar openInWorld: self ]! ! -!WorldMorph methodsFor: 'taskbar' stamp: 'jmv 10/21/2020 17:00:30' overrides: 50337098! - taskbar - ^taskbar! ! -!WorldMorph methodsFor: 'taskbar' stamp: 'jmv 10/21/2020 17:01:03'! - taskbarDeleted - taskbar _ nil! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/21/2020 17:04:22'! - collapseAll - "Collapse all windows" - (SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed not ]) - reverseDo: [ :w | w collapse. self displayWorld]. - self collapseNonWindows! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/21/2020 17:00:27'! - restoreAll - "Expand all windows to their previous state" - taskbar - ifNotNil: [ :tb | tb restoreAll ]! ! -!WorldMorph methodsFor: 'defaul desktop' stamp: 'jmv 10/21/2020 17:08:07'! - recreateDefaultDesktop - | editor | - self whenUIinSafeState: [ - self hideTaskbar. - (submorphs - select: [ :ea | ea class == SystemWindow or: [ea class == TranscriptWindow]]) - do: [ :ea | ea delete ]. - TranscriptWindow openTranscript - morphPosition: 5 @ 283; - morphExtent: 990 @ 400. - editor _ TextEditor openTextEditor - morphPosition: 456 @ 3; - morphExtent: 900 @ 680. - editor setLabel: 'About Cuis'. - editor model actualContents: Utilities defaultTextEditorContents. - Theme current useTaskbar ifTrue: [self showTaskbar]. - ].! ! -!WorldMorph methodsFor: 'defaul desktop' stamp: 'jmv 10/21/2020 17:08:22'! - tearDownDesktop - self whenUIinSafeState: [ - self hideTaskbar. - submorphs - do: [ :ea | (ea is: #SystemWindow) ifTrue: [ ea delete ]]].! ! -!WorldMorph methodsFor: 'events' stamp: 'jmv 10/21/2020 17:11:53' overrides: 16874466! - click: aMouseButtonEvent localPosition: localEventPosition - ^self whenUIinSafeState: [self mouseButton2Activity]! ! -!WorldMorph class methodsFor: 'instance creation' stamp: 'jmv 10/21/2020 15:38:59'! - newWorld - " -[ - UISupervisor stopUIProcess. - UISupervisor spawnNewMorphicProcessFor: WorldMorph newWorld -] fork. - " - | w | - w _ self new. - w morphPosition: `0@0` extent: Display extent. - w setCanvas: Display getCanvas. - w handsDo: [ :h | - h privateOwner: w ]. - ^w! ! -!WorldMorph class methodsFor: 'system startup' stamp: 'jmv 10/21/2020 16:49:42' overrides: 50549609! - initClassCachedState - "Should use some other way to find relevant instances" - self flag: #jmvVer2. - self allInstancesDo: [ :each | - each buildMagnifiedBackgroundImage. - each redrawNeeded ]. - Cursor defaultCursor activateCursor.! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 10/21/2020 17:02:09' prior: 50524666! - preferencesMenu - "Build the preferences menu for the world." - - ^ (self menu: 'Preferences...') - addItemsFromDictionaries: { - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Font Sizes...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Set System Font...'. - #object -> FontFamily. - #selector -> #promptUserAndSetDefault. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'change the current system font family.' - } asDictionary. - { - #label -> 'Load all TrueType Fonts'. - #object -> FontFamily. - #selector -> #readAdditionalTrueTypeFonts. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'Load additional TrueType fonts included with Cuis.' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }! ! -!TheWorldMenu methodsFor: 'windows & flaps menu' stamp: 'jmv 10/21/2020 16:56:57' prior: 50413319! - windowsMenu - "Build the windows menu for the world." - - ^ (self menu: 'Windows') - addItemsFromDictionaries: `{ - { - #label -> 'Find Window'. - #object -> #myWorld. - #selector -> #findWindow:. - #icon -> #windowIcon. - #balloonText -> 'Presents a list of all windows; if you choose one from the list, it becomes the active window.' - } asDictionary. - { - #label -> 'Find changed Browsers...'. - #object -> #myWorld. - #selector -> #findDirtyBrowsers:. - #icon -> #editFindReplaceIcon. - #balloonText -> 'Presents a list of browsers that have unsubmitted changes; if you choose one from the list, it becomes the active window.' - } asDictionary. - { - #label -> 'Find changed Windows...'. - #object -> #myWorld. - #selector -> #findDirtyWindows:. - #icon -> #newWindowIcon. - #balloonText -> 'Presents a list of all windows that have unsubmitted changes; if you choose one from the list, it becomes the active window.' - } asDictionary. - nil. - { - #label -> 'Find a Transcript'. - #object -> #myWorld. - #selector -> #findATranscript:. - #icon -> #printerIcon. - #balloonText -> 'Brings an open Transcript to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find a FileList'. - #object -> #myWorld. - #selector -> #findAFileList:. - #icon -> #systemFileManagerIcon. - #balloonText -> 'Brings an open fileList to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find a Change Sorter'. - #object -> #myWorld. - #selector -> #findAChangeSorter:. - #icon -> #changesIcon. - #balloonText -> 'Brings an open change sorter to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find Message Names'. - #object -> #myWorld. - #selector -> #findAMessageNamesWindow:. - #icon -> #inspectIcon. - #balloonText -> 'Brings an open MessageNames window to the front, creating one if necessary, and makes it the active window' - } asDictionary. - nil. - { - #label -> 'Tile open windows'. - #object -> TileResizeMorph. - #selector -> #tileOpenWindows. - #icon -> #windowIcon. - #balloonText -> 'Tile open windows'. - } asDictionary. - { - #label -> 'Collapse all Windows'. - #object -> #myWorld. - #selector -> #collapseAll. - #icon -> #collapseIcon. - #balloonText -> 'Reduce all open windows to collapsed forms that only show titles.' - } asDictionary. - { - #label -> 'Restore all Windows'. - #object -> #myWorld. - #selector -> #restoreAll. - #icon -> #expandIcon. - #balloonText -> 'Restore all collapsed windows back to their previous forms.' - } asDictionary. - { - #label -> 'Close top Window'. - #object -> SystemWindow. - #selector -> #closeTopWindow. - #icon -> #closeIcon. - #balloonText -> 'Close the topmost window if possible.' - } asDictionary. - { - #label -> 'Send top Window to back'. - #object -> SystemWindow. - #selector -> #sendTopWindowToBack. - #icon -> #goBottomIcon. - #balloonText -> 'Make the topmost window become the backmost one, and activate the window just beneath it.' - } asDictionary. - { - #label -> 'Move Windows onscreen'. - #object -> #myWorld. - #selector -> #bringWindowsFullOnscreen. - #icon -> #displayIcon. - #balloonText -> 'Make all windows fully visible on the screen' - } asDictionary. - nil. - { - #label -> 'Delete unchanged Windows'. - #object -> #myWorld. - #selector -> #closeUnchangedWindows. - #icon -> #warningIcon. - #balloonText -> 'Deletes all windows that do not have unsaved text edits.' - } asDictionary. - { - #label -> 'Delete non Windows'. - #object -> #myWorld. - #selector -> #deleteNonWindows. - #icon -> #warningIcon. - #balloonText -> 'Deletes all non-window morphs lying on the world.' - } asDictionary. - { - #label -> 'Delete Both of the Above'. - #selector -> #cleanUpWorld. - #icon -> #warningIcon. - #balloonText -> 'Deletes all unchanged windows and also all non-window morphs lying on the world, other than flaps.' - } asDictionary. - }`! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -[ - | oldWorld ba roots w | - oldWorld _ UISupervisor ui. - ba _ oldWorld instVarNamed: 'backgroundImageData'. - roots _ oldWorld instVarNamed: 'submorphs'. - roots _ roots reject: [ :m | m is: #TaskbarMorph ]. - oldWorld _ nil. - UISupervisor stopUIProcess. - w _ WorldMorph newWorld. - w - "recreateDefaultDesktop;" - backgroundImageData: ba; - addAllMorphs: roots; - showTaskbar. - UISupervisor spawnNewMorphicProcessFor: w. - 'Please do [Install New Updates] again.' print. -] fork. -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4420-NewPasteUpMorphAndWorldMorph-JuanVuletich-2020Oct21-17h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4416] on 21 October 2020 at 5:18:31 pm'! - -KernelMorph subclass: #PasteUpMorph - instanceVariableNames: 'backgroundImage backgroundImageData' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -!classDefinition: #PasteUpMorph category: #'Morphic-Kernel' stamp: 'Install-4420-NewPasteUpMorphAndWorldMorph-JuanVuletich-2020Oct21-17h15m-jmv.001.cs.st 10/24/2020 17:30:11'! -KernelMorph subclass: #PasteUpMorph - instanceVariableNames: 'backgroundImage backgroundImageData' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! -!PasteUpMorph commentStamp: 'jmv 2/21/2016 18:32' prior: 50548948! - A World, the entire Smalltalk screen, is a PasteUpMorph. A World responds true to isWorld. A PasteUpMorph that is a world, builds its menu in HandMorph buildWorldMenu. - -worldState If I am also a World, keeps the hands, damageRecorder, stepList etc. -! - -PasteUpMorph subclass: #WorldMorph - instanceVariableNames: 'activeHand hands canvas damageRecorder stepList lastCycleTime alarms lastAlarmTime deferredUIMessages drawingFailingMorphs waitDelay pause lastCycleHadAnyEvent taskbar' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -!classDefinition: #WorldMorph category: #'Morphic-Kernel' stamp: 'Install-4420-NewPasteUpMorphAndWorldMorph-JuanVuletich-2020Oct21-17h15m-jmv.001.cs.st 10/24/2020 17:30:11'! -PasteUpMorph subclass: #WorldMorph - instanceVariableNames: 'activeHand hands canvas damageRecorder stepList lastCycleTime alarms lastAlarmTime deferredUIMessages drawingFailingMorphs waitDelay pause lastCycleHadAnyEvent taskbar' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! -!WorldMorph commentStamp: '' prior: 50548983! - A WorldMorph is a kind of PasteUpMorph that can act as the root morph of a Morphic system. Usually uses the whole Display. - -activeHand -- a HandMorph -hands -- Array of HandMorphs (typically only one) representing the Cursor and its event queue. -canvas -- BitBlitCanvas on the DisplayScreen. (Display getCanvas) -damageRecorder -- the DamageRecorder for the Display -stepList -- a Heap of StepMessage. Each morph which wants stepping has a StepMessage here. - See comment in #Morph>>stepAt: -lastStepTime -- 'now' as last sampled at step. (Time localMillisecondClock) -lastStepMessage -- nil or a selector -lastCycleTime -- 'now' as last sampled (Time localMillisecondClock) -alarms -- a Heap of MorphicAlarm. See comment in #Morph>>addAlarm:after: - An _alarm_ is an action to be done once, vs a _step_ which is cycled. -lastAlarm -- 'now' as sampled at last alarm (Time localMillisecondClock). -drawingFailureMorphs -- a WeakIdentitySet of Morphs with drawing failures -waitDelay -- a Delay (set in #WorldState>>doOneCycleFor:) -pause -- A 'phase-locked loop' style value to help regularise the step/alarm/event service rate. - (set in #WorldState>>doOneCycleFor:) -lastCycleHadAnyEvent -- a boolean (set in #WorldState>>doOneCycleFor:) -world -- a PasteUpMorph -! -!PasteUpMorph methodsFor: 'accessing' stamp: 'jmv 10/21/2020 16:24:51' prior: 50549029 overrides: 16882824! - activeHand - "Answer the currently active hand, if any..." - ^self world ifNotNil: [ :w | w activeHand ]! ! -!PasteUpMorph methodsFor: 'accessing' stamp: 'jmv 11/19/2010 13:56' prior: 50549036 overrides: 16899189! - color: aColor - super color: aColor. - self backgroundImageData: nil! ! -!PasteUpMorph methodsFor: 'accessing' stamp: 'GC 3/17/2019 08:16:08' prior: 50549041 overrides: 16874712! - handlesKeyboard - - ^ true ! ! -!PasteUpMorph methodsFor: 'caching' stamp: 'jmv 10/21/2020 16:44:28' prior: 50549045 overrides: 50510072! - releaseCachedState - super releaseCachedState. - backgroundImage _ nil.! ! -!PasteUpMorph methodsFor: 'change reporting' stamp: 'jmv 1/16/2017 09:56:14' prior: 50549051 overrides: 16874142! - addedMorph: aMorph - "Notify the receiver that the given morph was just added." - super addedMorph: aMorph. - self taskbar ifNotNil: [ :tb | - tb wasOpened: aMorph ]! ! -!PasteUpMorph methodsFor: 'change reporting' stamp: 'jmv 1/16/2017 09:56:07' prior: 50549060 overrides: 16876964! - removedMorph: aMorph - "Notify the receiver that aMorph was just removed from its children" - super removedMorph: aMorph. - self taskbar ifNotNil: [ :tb | - tb wasDeleted: aMorph ]! ! -!PasteUpMorph methodsFor: 'drawing' stamp: 'jmv 10/21/2020 16:40:25' prior: 50549069 overrides: 16899205! - drawOn: aCanvas - - "draw background image." - backgroundImage - ifNotNil: [ - aCanvas image: backgroundImage at: `0@0` ] - ifNil: [ - super drawOn: aCanvas ]! ! -!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'HAW 12/24/2018 07:13:56' prior: 50549078 overrides: 50424794! - allowsFilesDrop - - ^ true! ! -!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'jmv 1/19/2013 15:24' prior: 50549082 overrides: 16874692! - allowsMorphDrop - "Answer whether we accept dropping morphs. By default answer false." - - ^ true! ! -!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'jmv 1/19/2013 15:25' prior: 50549089 overrides: 16874701! - allowsSubmorphDrag - "Answer whether our morphs can just be grabbed with the hand, instead of requiring the use of the halo. By default answer false. - Both 'aMorph allowsGrabWithHand' and 'aMorph owner allowsSubmorphDrag' must be true for aMorph to be grabbed by the hand. It is also required that 'aMorph handlesMouseDown:' be false." - - ^ true! ! -!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'HAW 12/24/2018 10:27:39' prior: 50549103 overrides: 50424788! - dropFiles: aDropFilesEvent - - (DropFilesAction for: aDropFilesEvent) value! ! -!PasteUpMorph methodsFor: 'events' stamp: 'jmv 10/28/2019 18:13:11' prior: 50549109 overrides: 50449234! - keyStroke: aKeyboardEvent - "Handle a keystroke event." - (aKeyboardEvent commandAltKeyPressed or: [ aKeyboardEvent controlKeyPressed ]) - ifTrue: [ - aKeyboardEvent keyCharacter = $b ifTrue: [ BrowserWindow openBrowser ]. - aKeyboardEvent keyCharacter = $f ifTrue: [ BrowserWindow findClass ]. - aKeyboardEvent keyCharacter = $F ifTrue: [ MessageSetWindow findInSourceCode ]. - ]. - "aKeyboardEvent keyCharacter print." - ^ super keyStroke: aKeyboardEvent! ! -!PasteUpMorph methodsFor: 'events' stamp: 'jmv 1/18/2013 12:38' prior: 50549126 overrides: 16874541! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - "Handle a mouse down event." - - super mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition. - - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: #click:localPosition: - clkNHalf: nil - dblClkSel: #doubleClick:localPosition: - dblClkNHalfSel: nil - tripleClkSel: nil! ! -!PasteUpMorph methodsFor: 'events' stamp: 'jmv 10/21/2020 15:41:41' prior: 50549142 overrides: 16874682! - windowEvent: aMorphicEvent - - aMorphicEvent windowEventType == #windowClose - ifTrue: [ - ^TheWorldMenu basicNew quitSession] -! ! -!PasteUpMorph methodsFor: 'event handling testing' stamp: 'jmv 8/20/2012 18:56' prior: 50549150 overrides: 16874721! - handlesMouseDown: aMouseButtonEvent - ^true! ! -!PasteUpMorph methodsFor: 'event handling' stamp: 'jmv 3/10/2011 16:02' prior: 50549155 overrides: 16874769! - mouseButton2Activity - - ^self invokeWorldMenu! ! -!PasteUpMorph methodsFor: 'event handling' stamp: 'jmv 10/21/2020 16:48:08' prior: 50549159! - wantsWindowEvent: anEvent - ^false! ! -!PasteUpMorph methodsFor: 'geometry' stamp: 'jmv 5/24/2020 10:07:38' prior: 50549163 overrides: 16875287! - fontPreferenceChanged - self submorphsDo: [ :m | - m morphExtent: (m morphExtent max: m minimumExtent). - m fontPreferenceChanged ]! ! -!PasteUpMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 16:33:43' prior: 50549171 overrides: 16899309! - privateExtent: newExtent - - ^ (super privateExtent: newExtent) - ifTrue: [ self buildMagnifiedBackgroundImage ]; - yourself! ! -!PasteUpMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 20:58:35' prior: 50549178! - defaultBorderColor - "answer the default border color/fill style for the receiver" - ^ `Color - r: 0.861 - g: 1.0 - b: 0.722`! ! -!PasteUpMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:38' prior: 50549185! - defaultBorderWidth - "answer the default border width for the receiver" - ^ 1! ! -!PasteUpMorph methodsFor: 'initialization' stamp: 'jmv 3/10/2018 20:58:44' prior: 50549191 overrides: 50387674! - defaultColor - "answer the default color/fill style for the receiver" - ^ `Color - r: 0.8 - g: 1.0 - b: 0.6`! ! -!PasteUpMorph methodsFor: 'interaction loop' stamp: 'jmv 8/17/2020 13:41:37' prior: 50549197! - mainLoop - - - self clearWaitDelay. - self setCanvas. - [ - self doOneCycle. - Processor yield. - true ] - whileTrue: []! ! -!PasteUpMorph methodsFor: 'interaction loop' stamp: 'HAW 12/26/2019 10:05:45' prior: 50549204! - runProcess - - | process | - - process _ [ self mainLoop ] newProcess. - process - priority: Processor userSchedulingPriority; - name: 'Morphic UI'; - animatedUI: self. - - ^ process! ! -!PasteUpMorph methodsFor: 'menu & halo' stamp: 'jmv 1/19/2013 15:14' prior: 50549212! - addWorldHaloMenuItemsTo: aMenu hand: aHandMorph - "Add standard halo items to the menu, given that the receiver is a World" - - | unlockables | - self addColorMenuItems: aMenu hand: aHandMorph. - -" aMenu addLine. - self addWorldToggleItemsToHaloMenu: aMenu." - aMenu addLine. - self addCopyItemsTo: aMenu. - self addExportMenuItems: aMenu hand: aHandMorph. - - self addDebuggingItemsTo: aMenu hand: aHandMorph. - - aMenu addLine. - aMenu defaultTarget: self. - - aMenu addLine. - - unlockables _ self submorphs select: - [ :m | m isLocked]. - unlockables size = 1 ifTrue: [ - aMenu add: ('unlock "{1}"' format:{unlockables first printStringLimitedTo: 40})action: #unlockContents]. - unlockables size > 1 ifTrue: [ - aMenu add: 'unlock all contents' action: #unlockContents. - aMenu add: 'unlock...' action: #unlockOneSubpart]. - - aMenu defaultTarget: aHandMorph. -! ! -!PasteUpMorph methodsFor: 'misc' stamp: 'jmv 3/2/2011 11:10' prior: 50549241! - backgroundImage - ^backgroundImage! ! -!PasteUpMorph methodsFor: 'misc' stamp: 'jmv 12/8/2013 15:11' prior: 50549245! - backgroundImageData: aByteArray - " - | filename | - filename _ 'bg/free-3d-art-pictures-gallery-wallpaper-desktop-18.jpg'. - filename _ 'bg/free-desktop-wallpaper.jpg'. - filename _ 'bg/jellyfish-thumb.jpg'. - filename _ 'bg/splash_by_beefpepsi.jpg'. - filename _ 'bg/gray ocean and pier.jpg'. - filename _ 'bg/newyork.jpg'. - filename _ 'bg/download-free-desktop-wallpaper-nature-conquestofparadise-marirs-pic.jpg'. - filename _ 'bg/desktop-wallpaper-tropical-1280x1024.jpg'. - - filename _ 'bg/free-3d-art-pictures-gallery-wallpaper-desktop-18.jpg'. - self runningWorld backgroundImageData: (FileStream readOnlyFileNamed: filename) binary contentsOfEntireFile. - " - backgroundImageData _ aByteArray. - self buildMagnifiedBackgroundImage! ! -!PasteUpMorph methodsFor: 'misc' stamp: 'jmv 10/21/2020 16:30:09' prior: 50549270! - buildMagnifiedBackgroundImage - | image old | - old _ backgroundImage. - backgroundImageData - ifNil: [ backgroundImage _ nil ] - ifNotNil: [ - [image _ Form fromBinaryStream: backgroundImageData readStream. - backgroundImage _ image magnifyTo: extent. - ] on: Error do: [backgroundImage := nil]. "Can happen if JPEG plugin not built" - ]. - old == backgroundImage ifFalse: [ - self redrawNeeded ]! ! -!PasteUpMorph methodsFor: 'stepping and presenter' stamp: 'jmv 6/11/2012 09:59' prior: 50549286 overrides: 16876574! - wantsSteps - "Return true if the receiver wants to its #step or #stepAt: methods be run ALL THE TIME. - Morphs that send #startStepping and #stopStepping at appropriate times (i.e. when they are already in the world!!) don't need to answer true to this message. - jmv: Not really sure. Sub-world stepping needs some review." - - ^true! ! -!PasteUpMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 7/23/2020 14:47:46' prior: 50549299! - addMorph: aMorph centeredNear: aPoint - "Add the given morph to this world, attempting to keep its center as close to the given point possible while also keeping the it entirely within the bounds of this world." - - | trialRect delta | - trialRect _ Rectangle center: aPoint extent: aMorph morphExtent. - delta _ trialRect amountToTranslateWithin: self displayBounds. - self addMorph: aMorph. - aMorph morphPositionInWorld: trialRect origin + delta.! ! -!PasteUpMorph methodsFor: 'testing' stamp: 'jmv 3/9/2020 10:13:47' prior: 50549316 overrides: 16876981! - is: aSymbol - ^ aSymbol == #PasteUpMorph or: [ super is: aSymbol ]! ! -!PasteUpMorph methodsFor: 'testing' stamp: 'jmv 10/21/2020 16:42:59' prior: 50549321 overrides: 16877003! - isReallyVisible - "Answer true only if all the owner chain is visible (i.e. if we are really visible!!)" - ^self visible and: [owner isReallyVisible ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 8/13/2013 09:17' prior: 50549328! - bringWindowsFullOnscreen - "Make ever SystemWindow on the desktop be totally on-screen, whenever possible." - (SystemWindow - windowsIn: self - satisfying: [ :w | - w visible ]) do: [ :each | - each makeMeFullyVisible ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 8/13/2013 09:18' prior: 50549338! - closeUnchangedWindows - "Present a menu of window titles for all windows with changes, - and activate the one that gets chosen." - (SelectionMenu confirm: 'Do you really want to close all windows -except those with unaccepted edits?') ifFalse: [ ^ self ]. - (SystemWindow - windowsIn: self - satisfying: [ :w | - w visible and: [ w canDiscardEdits ]]) do: [ :w | - w delete ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 1/24/2016 21:58' prior: 50549352! - collapseNonWindows - self allNonWindowRelatedSubmorphs do: [ :m | - m collapse]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 1/24/2016 21:58' prior: 50549357! - deleteNonWindows - (SelectionMenu confirm: -'Do you really want to discard all objects -that are not in windows?') - ifFalse: [^ self]. - - self allNonWindowRelatedSubmorphs do: [:m | - m delete ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 3/21/2012 17:23' prior: 50549366! - findAChangeSorter: evt - "Locate a change sorter, open it, and bring it to the front. Create one if necessary" - self - findAWindowSatisfying: [ :aWindow | - aWindow model isMemberOf: ChangeSorter] - orMakeOneUsing: [ ChangeSorterWindow open: ChangeSorter new label: nil ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 7/4/2016 22:20' prior: 50549377! - findAFileList: evt - "Locate a file list, open it, and bring it to the front. - Create one if necessary, respecting the Preference." - self - findAWindowSatisfying: [ :aWindow | - aWindow model class == FileList ] - orMakeOneUsing: [ - FileListWindow openFileList ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 7/4/2016 22:21' prior: 50549388! -findAMessageNamesWindow: evt - "Locate a MessageNames tool, open it, and bring it to the front. Create one if necessary" - self - findAWindowSatisfying: [ :aWindow | - aWindow model class == MessageNames ] - orMakeOneUsing: [ - MessageNamesWindow open: MessageNames new label: 'Message Names' ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 7/30/2014 09:01' prior: 50549400! -findATranscript: evt - "Locate a transcript, open it, and bring it to the front. Create one if necessary" - - self findATranscript! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 10/25/2010 21:29' prior: 50549407! - findAWindowSatisfying: qualifyingBlock orMakeOneUsing: makeBlock - "Locate a window satisfying a block, open it, and bring it to the front. Create one if necessary, by using the makeBlock" - | aWindow | - submorphs do: [ :aMorph | - (((aWindow _ aMorph) is: #SystemWindow) and: [ qualifyingBlock value: aWindow ]) ifTrue: [ - aWindow isCollapsed ifTrue: [ aWindow expand ]. - aWindow activateAndForceLabelToShow. - ^ self ]]. - "None found, so create one" - makeBlock value.! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 7/5/2016 09:42' prior: 50549425! - findDirtyBrowsers: evt - "Present a menu of window titles for browsers with changes, - and activate the one that gets chosen." - | menu | - menu _ MenuMorph new. - (SystemWindow - windowsIn: self - satisfying: [ :w | - w visible and: [ - (w model is: #CodeProvider) and: [ w canDiscardEdits not ]]]) do: [ :w | - menu - add: w label - target: w - action: #activate ]. - menu submorphs notEmpty ifTrue: [ menu popUpInWorld: self ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 8/13/2013 09:20' prior: 50549441! - findDirtyWindows: evt - "Present a menu of window titles for all windows with changes, - and activate the one that gets chosen." - | menu | - menu _ MenuMorph new. - (SystemWindow - windowsIn: self - satisfying: [ :w | - w visible and: [ w canDiscardEdits not ]]) do: [ :w | - menu - add: w label - target: w - action: #activate ]. - menu submorphs notEmpty ifTrue: [ menu popUpInWorld: self ]! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 3/10/2018 22:02:53' prior: 50549456! - findWindow: evt - "Present a menu names of windows and naked morphs, and activate the one that gets chosen. Collapsed windows appear below line, expand if chosen; naked morphs appear below second line; if any of them has been given an explicit name, that is what's shown, else the class-name of the morph shows; if a naked morph is chosen, bring it to front and have it don a halo." - | menu expanded collapsed nakedMorphs | - menu _ MenuMorph new. - expanded _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed not ]. - collapsed _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed ]. - nakedMorphs _ self submorphsSatisfying: [ :m | - (m is: #SystemWindow) not ]. - expanded isEmpty & (collapsed isEmpty & nakedMorphs isEmpty) ifTrue: [ ^ Smalltalk beep ]. - (expanded asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #activateAndForceLabelToShow. - w canDiscardEdits ifFalse: [ menu lastItem color: `Color red` ]]. - expanded isEmpty | (collapsed isEmpty & nakedMorphs isEmpty) ifFalse: [ menu addLine ]. - (collapsed asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #expand. - w canDiscardEdits ifFalse: [ menu lastItem color: `Color red` ]]. - nakedMorphs isEmpty ifFalse: [ menu addLine ]. - (nakedMorphs asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #comeToFrontAndAddHalo ]. - menu addTitle: 'find window'. - menu popUpInWorld: self! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'HAW 7/5/2018 18:24:37' prior: 50549509! - invokeWorldMenu - "Put up the world menu, triggered by the passed-in event. - Perhaps a good place to disable it if needed" - - | menu | - menu _ (TheWorldMenu new - world: self - hand: self activeHand) buildWorldMenu. - menu addTitle: Preferences desktopMenuTitle. - menu popUpInWorld: self! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 1/8/2017 16:44:57' prior: 50549521! - allNonWindowRelatedSubmorphs - "Answer all non-window submorphs that are not flap-related" - - ^submorphs - reject: [ :m | (m is: #SystemWindow) or: [ m is: #TaskbarMorph ] ]! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 2/28/2011 15:16' prior: 50549529! - deleteAllHalos - self haloMorphs do: - [ :m | m delete]! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 9/13/2013 09:18' prior: 50549533! - fullRepaintNeeded - self redrawNeeded. - SystemWindow - windowsIn: self - satisfying: [ :w | - w visible ifTrue: [ w makeMeVisible ]. - false ]! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'ar 9/28/2000 18:00' prior: 50549540! - haloMorphs - ^ self hands collect:[:h| h halo] thenSelect:[:halo| halo notNil]! ! -!PasteUpMorph methodsFor: 'halos and balloon help' stamp: 'jmv 10/21/2020 16:46:33' prior: 50549546 overrides: 50537022! - wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph - "Answer whether the receiver would like to offer the halo handle with the given selector (e.g. #addCollapseHandle:)" - (#(addHelpHandle: addRotateHandle: addRecolorHandle:) statePointsTo: aSelector) - ifTrue: ["FIXME - hack to disable for non-functional halo items" - ^ false]. - - ^super wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph! ! -!PasteUpMorph methodsFor: 'object serialization' stamp: 'jmv 6/8/2014 18:28' prior: 50549562 overrides: 16876452! - objectForDataStream: refStrm - "I am about to be written on an object file. Write a path to me in the other system instead." - - | dp | - dp _ DiskProxy global: #Smalltalk selector: #runningWorld args: #(). - refStrm replace: self with: dp. - ^ dp! ! -!PasteUpMorph methodsFor: 'windows' stamp: 'jmv 7/30/2014 09:00' prior: 50549572! - findATranscript - "Locate a transcript, open it, and bring it to the front. Create one if necessary" - - self - findAWindowSatisfying: [ :aWindow | aWindow model == Transcript] - orMakeOneUsing: [ TranscriptWindow openTranscript ]! ! -!PasteUpMorph methodsFor: 'ui services' stamp: 'jmv 5/23/2020 21:00:01' prior: 50549583 overrides: 50515284! - request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock - "This is deprecated because using it requires blocking the user interface until the user provides a response. Please use the variants that are not modal." - ^ StringRequestMorph request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock! ! -!PasteUpMorph methodsFor: 'ui services' stamp: 'jmv 5/23/2020 21:00:05' prior: 50549597 overrides: 50515297! - request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock - ^ StringRequestMorph request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock! ! -!PasteUpMorph class methodsFor: 'system startup' stamp: 'jmv 10/21/2020 16:49:47' prior: 50549609 overrides: 16784996! - initClassCachedState - "Should use some other way to find relevant instances" - self flag: #jmvVer2. - self allInstancesDo: [ :each | - each buildMagnifiedBackgroundImage ]. - Cursor defaultCursor activateCursor.! ! -!PasteUpMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:51:39' prior: 50549620 overrides: 50344172! - categoryInNewMorphMenu - ^ 'Worlds'! ! -!WorldMorph methodsFor: 'alarms' stamp: 'jmv 3/3/2017 09:33:59' prior: 50549624! - addAlarm: aSelector withArguments: argArray for: aTarget at: scheduledTime - "Add a new alarm with the given set of parameters" - - alarms add: - (MorphicAlarm - receiver: aTarget - selector: aSelector - arguments: argArray - at: scheduledTime)! ! -!WorldMorph methodsFor: 'alarms' stamp: 'jmv 3/3/2017 09:34:03' prior: 50549634! - adjustAlarmTimes: nowTime - "Adjust the alarm times after some clock weirdness (such as image-startup etc)" - | deltaTime | - deltaTime _ nowTime - lastAlarmTime. - alarms do: [ :alarm | - alarm scheduledTime: alarm scheduledTime + deltaTime ]! ! -!WorldMorph methodsFor: 'alarms' stamp: 'jmv 5/11/2016 09:53' prior: 50549644! - alarmSortBlock - - ^[ :alarm1 :alarm2 | alarm1 scheduledTime < alarm2 scheduledTime ]! ! -!WorldMorph methodsFor: 'alarms' stamp: 'jmv 3/3/2017 11:54:00' prior: 50549649! - removeAlarm: aSelector for: aTarget - "Remove the alarm with the given selector" - - | alarm | - alarm _ alarms - detect: [ :any | any receiver == aTarget and: [any selector == aSelector]] - ifNone: nil. - alarm ifNotNil: [ alarms remove: alarm ]! ! -!WorldMorph methodsFor: 'alarms' stamp: 'jmv 3/3/2017 09:35:03' prior: 50549659! - triggerAlarmsBefore: nowTime - "Trigger all pending alarms that are to be executed before nowTime." - - nowTime - lastAlarmTime > 10000 - ifTrue: [ self adjustAlarmTimes: nowTime ]. - [ alarms notEmpty and: [ alarms first scheduledTime < nowTime ]] - whileTrue: [ alarms removeFirst valueAtTime: nowTime ]. - lastAlarmTime _ nowTime! ! -!WorldMorph methodsFor: 'canvas' stamp: 'di 6/7/1999 17:44' prior: 50549672! - canvas - - ^ canvas! ! -!WorldMorph methodsFor: 'canvas' stamp: 'jmv 8/17/2020 13:42:46' prior: 50549675! - clearCanvas - canvas _ nil. - damageRecorder _ nil.! ! -!WorldMorph methodsFor: 'canvas' stamp: 'jmv 10/21/2020 15:17:06' prior: 50549679! - ensureNonDisplayCanvas - (canvas isNil or: [ - canvas drawsOnDisplay or: [ - (canvas extent ~= self morphExtent) or: [ - canvas form depth ~= Display depth]]]) ifTrue: [ - "allocate a new offscreen canvas the size of the window" - self setCanvas: (MorphicCanvas withExtent: self morphExtent depth: Display depth)]! ! -!WorldMorph methodsFor: 'canvas' stamp: 'jmv 8/4/2020 10:02:25' prior: 50549691! - recordDamagedRect: damageRect for: aMorph - - damageRecorder ifNotNil: [ - damageRecorder recordInvalidRect: damageRect for: aMorph ]! ! -!WorldMorph methodsFor: 'canvas' stamp: 'jmv 10/21/2020 15:17:17' prior: 50549698! - setCanvas - self setCanvas: Display getCanvas. - damageRecorder _ DamageRecorder new. - self redrawNeeded! ! -!WorldMorph methodsFor: 'canvas' stamp: 'jmv 10/21/2020 15:17:24' prior: 50549704! - setCanvas: aMorphicCanvas - canvas _ aMorphicCanvas. - canvas world: self. - damageRecorder - ifNil: [ damageRecorder _ DamageRecorder new].! ! -!WorldMorph methodsFor: 'hands' stamp: 'jmv 9/25/2012 22:39' prior: 50549711 overrides: 50550783! - activeHand - ^activeHand! ! -!WorldMorph methodsFor: 'hands' stamp: 'di 6/7/1999 17:40' prior: 50549714! - hands - - ^ hands! ! -!WorldMorph methodsFor: 'hands' stamp: 'RAA 5/24/2000 10:13' prior: 50549717! - handsDo: aBlock - - ^ hands do: aBlock! ! -!WorldMorph methodsFor: 'hands' stamp: 'RAA 5/24/2000 12:09' prior: 50549721! - handsReverseDo: aBlock - - ^ hands reverseDo: aBlock! ! -!WorldMorph methodsFor: 'hands' stamp: 'jmv 7/22/2020 20:42:49' prior: 50549725! - selectHandsToDrawForDamage: damageList - "Select the set of hands that must be redrawn because either (a) the hand itself has changed or (b) the hand intersects some damage rectangle." - - | result | - result _ OrderedCollection new. - hands do: [:hand | - hand needsToBeDrawn ifTrue: [ - hand hasChanged - ifTrue: [result add: hand] - ifFalse: [ - hand displayFullBounds ifNotNil: [ :handBounds | - (damageList anySatisfy: [ :r | r intersects: handBounds]) ifTrue: [ - result add: hand]]]]]. - ^ result! ! -!WorldMorph methodsFor: 'initialization' stamp: 'jmv 6/20/2014 20:24:55' prior: 50549744! -clearWaitDelay - waitDelay ifNotNil: [ - waitDelay unschedule. - waitDelay _ nil ]. - "Needed if for some reason Cuis is started with an earlier DateTime than the image was saved. - Might happen, especially on RasPi or other systems without an RTC" - lastCycleTime _ Time localMillisecondClock. - lastAlarmTime _ 0.! ! -!WorldMorph methodsFor: 'initialization' stamp: 'jmv 10/21/2020 16:05:30' prior: 50549757 overrides: 50384228! - initialize - - super initialize. - activeHand _ HandMorph new. - hands _ { activeHand }. - damageRecorder _ DamageRecorder new. - stepList _ Heap sortBlock: self stepListSortBlock. - alarms _ Heap sortBlock: self alarmSortBlock. - lastAlarmTime _ 0. - deferredUIMessages _ SharedQueue new. - drawingFailingMorphs _ WeakIdentitySet new. - pause _ 20. - lastCycleTime _ Time localMillisecondClock. - lastCycleHadAnyEvent _ false! ! -!WorldMorph methodsFor: 'initialization' stamp: 'jmv 2/2/2014 21:05' prior: 50549773! - stepListSortBlock - - ^ [ :stepMsg1 :stepMsg2 | - stepMsg1 scheduledTime <= stepMsg2 scheduledTime ]! ! -!WorldMorph methodsFor: 'stepping' stamp: 'jmv 10/21/2020 15:16:15' prior: 50549779! - cleanseStepList - "Remove morphs from the step list that are not in this World." - - | deletions | - deletions _ OrderedCollection new. - stepList do: [ :entry | - entry receiver world == self ifFalse: [ - deletions add: entry]]. - deletions do: [ :entry| - stepList remove: entry ]. - - deletions _ OrderedCollection new. - alarms do: [ :entry | - ((entry receiver is: #Morph) and: [ entry receiver world == self ]) ifFalse: [ - deletions add: entry]]. - deletions do: [ :entry| - alarms remove: entry ]! ! -!WorldMorph methodsFor: 'stepping' stamp: 'jmv 10/21/2020 15:35:50' prior: 50549797! - runLocalStepMethods: nowTime - "Run morph 'step' methods (LOCAL TO THIS WORLD) whose time has come. Purge any morphs that are no longer in this world." - - | stepMessage | - [ stepList notEmpty and: [ stepList first scheduledTime <= nowTime ]] - whileTrue: [ - stepMessage _ stepList first. - (stepMessage receiver shouldGetStepsFrom: self) - ifFalse: [ stepList removeFirst ] - ifTrue: [ - stepMessage valueAtTime: nowTime. - stepMessage rescheduleAfter: nowTime. - "We've just updated the scheduled time for stepMessage. - It might have been that stepMessage was removed altogether from stepList. - It also may be the case that stepList got added or removed other elements while on #valueAtTime: - Just reSort. It will be ok in any case." - stepList reSort. - ] - ]! ! -!WorldMorph methodsFor: 'stepping' stamp: 'jmv 10/21/2020 15:34:17' prior: 50549825! - runStepMethods - "Perform periodic activity inbetween event cycles" - | readyToProcess | - - "Processing the queue until empty is wrong if a block in it calls #addDeferredUIMessage: itself, because this loop will never end. - Instead, process no more than entries already in queue befor we start iterating!!" - readyToProcess _ deferredUIMessages size. - readyToProcess timesRepeat: [ - deferredUIMessages nextOrNil ifNotNil: [ :block | - block value - ] - ]. - self triggerAlarmsBefore: lastCycleTime. - self runLocalStepMethods: lastCycleTime. - - "we are using a normal #step for these now" - "aWorld allLowerWorldsDo: [ :each | each runLocalStepMethods ]." -! ! -!WorldMorph methodsFor: 'stepping' stamp: 'jmv 2/3/2014 21:15' prior: 50549848! - startStepping: aMorph at: scheduledTime selector: aSelector stepTime: stepTimeOrNil - "Add the given morph to the step list" - - self stopStepping: aMorph selector: aSelector. - stepList add: ( - StepMessage - receiver: aMorph - selector: aSelector - at: scheduledTime - stepTime: stepTimeOrNil)! ! -!WorldMorph methodsFor: 'stepping' stamp: 'jmv 3/3/2017 11:39:34' prior: 50549860! - stopStepping: aMorph selector: aSelector - "Remove the given morph from the step list." - stepList removeAll: (stepList select:[:stepMsg| stepMsg receiver == aMorph and: [ stepMsg selector == aSelector ]])! ! -!WorldMorph methodsFor: 'stepping' stamp: 'jmv 3/3/2017 11:39:22' prior: 50549869! - stopSteppingMorph: aMorph - "Remove the given morph from the step list." - stepList removeAll: (stepList select: [ :stepMsg | stepMsg receiver == aMorph])! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'RAA 5/24/2000 13:13' prior: 50549877! - checkIfUpdateNeeded - - damageRecorder updateIsNeeded ifTrue: [^true]. - hands do: [:h | (h hasChanged and: [h needsToBeDrawn]) ifTrue: [^true]]. - ^false "display is already up-to-date" -! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 10/21/2020 15:16:56' prior: 50549886! - displayWorldSafely - "Update this world's display and keep track of errors during draw methods." - - [self displayWorld] ifError: [:err :rcvr | - "Handle a drawing error" - | errCtx errMorph | - errCtx _ thisContext. - [ - errCtx _ errCtx sender. - "Search the sender chain to find the morph causing the problem" - [errCtx notNil and: [ (errCtx receiver is: #Morph) not ]] - whileTrue:[errCtx _ errCtx sender]. - "If we're at the root of the context chain then we have a fatal drawing problem" - errCtx ifNil:[^self handleFatalDrawingError: err]. - errMorph _ errCtx receiver. - "If the morph causing the problem has already the #drawError flag set, - then search for the next morph above in the caller chain." - errMorph isKnownFailing - ] whileTrue. - errMorph drawingFails. - self setCanvas. - "Install the old error handler, so we can re-raise the error" - rcvr error: err. - ]! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 10/21/2020 15:33:56' prior: 50549917! - doOneCycle - "Do one cycle of the interaction loop. This method is called repeatedly when the world is running. - - Make for low cpu usage if the ui is inactive, but quick response when ui is in use. - However, after some inactivity, there will be a larger delay before the ui gets responsive again." - - | wait waitUntil | - waitDelay ifNil: [ waitDelay _ Delay forMilliseconds: 50 ]. - lastCycleHadAnyEvent | deferredUIMessages isEmpty not - ifTrue: [ - pause _ 20. "This value will only be used when there are no more events to serve." - wait _ 0 ] "Don't wait" - ifFalse: [ - pause < 200 "No events processed? Start saving CPU!! But never make the user wait more than 200ms for being responsive again." - ifTrue: [ pause _ pause * 21//20 ]. - waitUntil _ lastCycleTime + pause. - "Earlier if steps" - stepList isEmpty not ifTrue: [ - waitUntil _ waitUntil min: stepList first scheduledTime ]. - "Earlier if alarms" - alarms ifNotNil: [ - alarms isEmpty not ifTrue: [ - waitUntil _ waitUntil min: alarms first scheduledTime ]]. - - wait _ waitUntil - Time localMillisecondClock ]. - Preferences serverMode - ifTrue: [ wait _ wait max: 50 ]. "Always wait at least a bit on servers, even if this makes the UI slow." - wait > 0 - ifFalse: [ Processor yield ] - ifTrue: [ - waitDelay beingWaitedOn - ifFalse: [ waitDelay setDelay: wait; wait ] - ifTrue: [ - "If we are called from a different process than that of the main UI, we might be called in the main - interCyclePause. In such case, use a new Delay to avoid 'This Delay has already been scheduled' errors" - (Delay forMilliseconds: wait) wait ]]. - - "Record start time of this cycle, and do cycle" - lastCycleTime _ Time localMillisecondClock. - lastCycleHadAnyEvent _ self doOneCycleNow! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 10/21/2020 16:04:46' prior: 50549975! - doOneCycleNow - "Immediately do one cycle of the interaction loop. - Only used for a few tests." - "See #eventTickler" - | hadAnyEvent | - Cursor currentCursor = (Cursor cursorAt: #waitCursor) ifTrue: [ Cursor defaultCursor activateCursor ]. - "Repair visual damage." - DisplayScreen checkForNewScreenSize. - self displayWorldSafely. - "Run steps, alarms and deferred UI messages" - self runStepMethods. - "Process user input events. Run all event triggered code." - hadAnyEvent _ false. - self handsDo: [ :h | - activeHand _ h. - hadAnyEvent _ hadAnyEvent | h processEventQueue. - activeHand _ nil ]. - "The default is the primary hand" - activeHand _ self hands first. - ^ hadAnyEvent.! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 3/2/2017 20:06:48' prior: 50549999! - doOneMinimalCycleNow - "Immediately do one cycle of the interaction loop. - Only repair display and process events. For modal menus and such." - - "Repair visual damage." - self displayWorldSafely. - - "Process user input events. Run all event triggered code." - ^activeHand processEventQueue! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 6/26/2015 14:36' prior: 50550011! - handleFatalDrawingError: errMsg - "Handle a fatal drawing error." - - self primitiveError: - 'Fatal Morphic drawing error', String newLineString, - errMsg. - - "Hm... we should jump into a 'safe' WorldMorph here, but how do we find it?!!"! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 10/21/2020 15:17:28' prior: 50550021! - tryDeferredUpdatingAndSetCanvas - "If this platform supports deferred updates, then make my canvas be the Display (or a rectangular portion of it), set the Display to deferred update mode, and answer true. Otherwise, set a non-Disply canvas and answer false.." - | properDisplay | - - "As this is the only sender of #deferUpdates: , this could be done in Morphic or image startup, and never efterwards..." - (Display deferUpdates: true) ifNil: [ - "deferred updates not supported by the VM, do them in the image!!" - self ensureNonDisplayCanvas. - ^ false]. - - "if no canvas, or canvas was offscreen, from a platform that didnt support defers, then fix it" - properDisplay _ canvas notNil and: [canvas drawsOnDisplay]. - properDisplay ifFalse: [ - self morphPosition: `0@0` extent: Display extent. - self setCanvas: Display getCanvas. - ]. - ^ true! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 10/21/2020 15:34:22' prior: 50550051 overrides: 50444400! -whenUIinSafeState: evaluableObject - "Please call - UISupervisor whenUIinSafeState: evaluableObject - " - deferredUIMessages nextPut: evaluableObject! ! -!WorldMorph methodsFor: 'errors on draw' stamp: 'jmv 11/5/2007 22:59' prior: 50550058! - addKnownFailing: aMorph - drawingFailingMorphs add: aMorph! ! -!WorldMorph methodsFor: 'errors on draw' stamp: 'jmv 11/5/2007 22:59' prior: 50550063! - isKnownFailing: aMorph - ^drawingFailingMorphs includes: aMorph! ! -!WorldMorph methodsFor: 'errors on draw' stamp: 'jmv 10/21/2020 15:54:35' prior: 50550068! - removeAllKnownFailing - drawingFailingMorphs _ WeakIdentitySet new. - self redrawNeeded! ! -!WorldMorph methodsFor: 'errors on draw' stamp: 'jmv 11/5/2007 22:59' prior: 50550073! - removeKnownFailing: aMorph - drawingFailingMorphs remove: aMorph! ! -!WorldMorph methodsFor: 'drawing' stamp: 'jmv 10/21/2020 17:06:37' prior: 50550078! - displayWorld - "Update this world's display." - - | deferredUpdateVMMode worldDamageRects handsToDraw allDamage | - self checkIfUpdateNeeded ifFalse: [ ^ self ]. "display is already up-to-date" - "I (jmv) removed the call to 'deferUpdates: false' below. No more need to call this every time." - deferredUpdateVMMode _ self tryDeferredUpdatingAndSetCanvas. - - "repair world's damage on canvas" - worldDamageRects _ canvas drawWorld: self repair: damageRecorder. - - "Check which hands need to be drawn (they are not the hardware mouse pointer)" - handsToDraw _ self selectHandsToDrawForDamage: worldDamageRects. - allDamage _ Array streamContents: [ :strm | - strm nextPutAll: worldDamageRects. - handsToDraw do: [ :h | - h savePatchFrom: canvas appendDamageTo: strm ]]. - - "Draw hands (usually carying morphs) onto world canvas" - canvas newClipRect: nil. - handsToDraw reverseDo: [ :h | canvas fullDrawHand: h ]. - - "quickly copy altered rects of canvas to Display:" - deferredUpdateVMMode ifFalse: [ - "Drawing was done to off-Display canvas. Copy content to Display" - canvas showAt: self viewBox origin invalidRects: allDamage ]. - - "Display deferUpdates: false." - "Display forceDisplayUpdate" - Display forceDamageToScreen: allDamage. - - "Restore world canvas under hands and their carried morphs" - handsToDraw do: [ :h | h restoreSavedPatchOn: canvas ].! ! -!WorldMorph methodsFor: 'drawing' stamp: 'jmv 10/21/2020 16:41:02' prior: 50550123 overrides: 50550825! - drawOn: aCanvas - - "draw background image." - backgroundImage - ifNotNil: [ - aCanvas image: backgroundImage at: `0@0` ] - ifNil: [ - "draw background fill" - (aCanvas drawsOnDisplay and: [ color mightBeTranslucent ]) - ifTrue: [ - "Special case so a translucent background on the Display allows you to see through the main Cuis Window. - Requires proper handling of translucent Display in the VM. - Seems to work only on Linux when using a composing window manager." - (BitBlt toForm: Display) clipRect: aCanvas clipRect; - copy: Display boundingBox - from: `0@0` in: nil - fillColor: color rule: Form over. - Display forceToScreen] - ifFalse: [ super drawOn: aCanvas ]]! ! -!WorldMorph methodsFor: 'event handling' stamp: 'jmv 10/21/2020 16:48:04' prior: 50550149 overrides: 50550920! - wantsWindowEvent: anEvent - ^true! ! -!WorldMorph methodsFor: 'classification' stamp: 'jmv 10/21/2020 15:47:06' prior: 50550154 overrides: 16874177! - isWorldMorph - - ^ true! ! -!WorldMorph methodsFor: 'submorphs-accessing' stamp: 'jmv 10/21/2020 16:26:04' prior: 50550158 overrides: 16876668! - allMorphsDo: aBlock - "Enumerate all morphs in the world, including those held in hands." - - super allMorphsDo: aBlock. - self handsReverseDo: [:h | h allMorphsDo: aBlock].! ! -!WorldMorph methodsFor: 'submorphs-accessing' stamp: 'jmv 10/21/2020 16:31:21' prior: 50550166! - canHandle: aMorph - - ^ canvas canDraw: aMorph! ! -!WorldMorph methodsFor: 'submorphs-accessing' stamp: 'jmv 10/21/2020 15:49:31' prior: 50550170! - firstHand - - ^ hands first! ! -!WorldMorph methodsFor: 'change reporting' stamp: 'jmv 10/21/2020 15:50:52' prior: 50550174 overrides: 50541313! - invalidateDisplayRect: damageRect fromSubmorph: submorphOrNil for: aMorph - "Clip damage reports to my bounds, since drawing is _always_ clipped to my bounds." - - self recordDamagedRect: (damageRect intersect: self morphLocalBounds ) for: aMorph! ! -!WorldMorph methodsFor: 'testing' stamp: 'jmv 10/21/2020 16:43:17' prior: 50550185 overrides: 50551090! - isReallyVisible - "Answer true only if all the owner chain is visible (i.e. if we are really visible!!)" - ^self visible! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 16:39:39' prior: 50550192 overrides: 50537895! - displayBounds - ^0@0 extent: extent! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 16:41:28' prior: 50550196 overrides: 50463602! - externalizeDisplayBounds: r - - ^ r! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 16:41:55' prior: 50550200 overrides: 16875276! - externalizeToWorld: aPoint - "aPoint is in own coordinates. Answer is in world coordinates." - ^ aPoint! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 16:42:23' prior: 50550207 overrides: 16875326! - internalizeFromWorld: aPoint - "aPoint is in World coordinates. Answer is in own coordinates." - ^ aPoint! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 16:43:37' prior: 50550214 overrides: 50545049! - morphPositionInWorld - - self flag: #jmvVer2. "Solo para evitar los warning por falta de owner... pensar despues este caso" - ^ `0@0`! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 15:52:21' prior: 50550221 overrides: 50550933! - privateExtent: newExtent - - ^ (super privateExtent: newExtent) - ifTrue: [ - self setCanvas ]; - yourself! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 15:55:32' prior: 50550227! - viewBox - - ^ self morphLocalBounds! ! -!WorldMorph methodsFor: 'caching' stamp: 'jmv 10/21/2020 15:54:07' prior: 50550231 overrides: 50550801! - releaseCachedState - super releaseCachedState. - self cleanseStepList. - self clearCanvas! ! -!WorldMorph methodsFor: 'structure' stamp: 'jmv 10/21/2020 15:56:00' prior: 50550237 overrides: 16876664! - world - ^self! ! -!WorldMorph methodsFor: 'misc' stamp: 'jmv 10/21/2020 16:29:57' prior: 50550241 overrides: 50551035! - buildMagnifiedBackgroundImage - super buildMagnifiedBackgroundImage. - - canvas ifNotNil: [ :c | - (backgroundImage depth = 32 and: [ c form depth < 32 ]) ifTrue: [ - backgroundImage _ backgroundImage orderedDither32To16 ]]! ! -!WorldMorph methodsFor: 'misc' stamp: 'jmv 10/21/2020 16:52:25' prior: 50550251! - fillRects: rectangleList - "For testing. Flashes the given list of rectangles on the Display so you can watch incremental redisplay at work." - - - | blt screenRect | - blt _ (BitBlt toForm: Display) - sourceForm: nil; - sourceOrigin: `0@0`; - clipRect: self viewBox; - combinationRule: Form over. - - rectangleList do: [:r | - screenRect _ r translatedBy: self viewBox origin. - blt fillColor: Color random. - blt destRect: screenRect; copyBits. - Display forceToScreen: screenRect ]. - - (Delay forMilliseconds: 50) wait! ! -!WorldMorph methodsFor: 'misc' stamp: 'jmv 10/21/2020 16:36:53' prior: 50550270! - restoreDisplay - self - morphExtent: Display extent; - handsDo: [ :h | h visible: true ]; - fullRepaintNeeded! ! -!WorldMorph methodsFor: 'menu & halo' stamp: 'jmv 10/21/2020 16:39:09' prior: 50550277 overrides: 16876144! - addCustomMenuItems: menu hand: aHandMorph - "Add morph-specific menu itemns to the menu for the hand" - - super addCustomMenuItems: menu hand: aHandMorph. - menu - add: 'desktop menu...' - target: self - action: #invokeWorldMenu. - menu addLine! ! -!WorldMorph methodsFor: 'printing' stamp: 'jmv 10/21/2020 16:44:07' prior: 50550288 overrides: 50500309! - printOn: aStream - "Reimplemented to add a tag showing that the receiver is currently functioning as a 'world', if it is" - - aStream nextPutAll: ' [world]'! ! -!WorldMorph methodsFor: 'halos and balloon help' stamp: 'jmv 10/21/2020 16:46:19' prior: 50550296! -deleteBalloonTarget: aMorph - "Delete the balloon help targeting the given morph" - self handsDo:[:h| h deleteBalloonTarget: aMorph].! ! -!WorldMorph methodsFor: 'halos and balloon help' stamp: 'jmv 10/21/2020 16:47:14' prior: 50550304 overrides: 50551326! - wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph - "Answer whether the receiver would like to offer the halo handle with the given selector (e.g. #addCollapseHandle:)" - - ^#(addDebugHandle: addMenuHandle: addHelpHandle:) - statePointsTo: aSelector! ! -!WorldMorph methodsFor: 'taskbar' stamp: 'jmv 10/21/2020 17:00:39' prior: 50550315! - hideTaskbar - taskbar ifNotNil: [ - taskbar delete. - taskbar _ nil ]! ! -!WorldMorph methodsFor: 'taskbar' stamp: 'jmv 10/21/2020 17:00:47' prior: 50550320! - showTaskbar - - taskbar ifNil: [ - taskbar _ TaskbarMorph newRow. - taskbar openInWorld: self ]! ! -!WorldMorph methodsFor: 'taskbar' stamp: 'jmv 10/21/2020 17:00:30' prior: 50550326 overrides: 50337098! - taskbar - ^taskbar! ! -!WorldMorph methodsFor: 'taskbar' stamp: 'jmv 10/21/2020 17:01:03' prior: 50550329! - taskbarDeleted - taskbar _ nil! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/21/2020 17:04:22' prior: 50550333! - collapseAll - "Collapse all windows" - (SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed not ]) - reverseDo: [ :w | w collapse. self displayWorld]. - self collapseNonWindows! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/21/2020 17:00:27' prior: 50550342! - restoreAll - "Expand all windows to their previous state" - taskbar - ifNotNil: [ :tb | tb restoreAll ]! ! -!WorldMorph methodsFor: 'defaul desktop' stamp: 'jmv 10/21/2020 17:08:07' prior: 50550348! - recreateDefaultDesktop - | editor | - self whenUIinSafeState: [ - self hideTaskbar. - (submorphs - select: [ :ea | ea class == SystemWindow or: [ea class == TranscriptWindow]]) - do: [ :ea | ea delete ]. - TranscriptWindow openTranscript - morphPosition: 5 @ 283; - morphExtent: 990 @ 400. - editor _ TextEditor openTextEditor - morphPosition: 456 @ 3; - morphExtent: 900 @ 680. - editor setLabel: 'About Cuis'. - editor model actualContents: Utilities defaultTextEditorContents. - Theme current useTaskbar ifTrue: [self showTaskbar]. - ].! ! -!WorldMorph methodsFor: 'defaul desktop' stamp: 'jmv 10/21/2020 17:08:22' prior: 50550368! - tearDownDesktop - self whenUIinSafeState: [ - self hideTaskbar. - submorphs - do: [ :ea | (ea is: #SystemWindow) ifTrue: [ ea delete ]]].! ! -!WorldMorph methodsFor: 'events' stamp: 'jmv 10/21/2020 17:11:53' prior: 50550376 overrides: 16874466! - click: aMouseButtonEvent localPosition: localEventPosition - ^self whenUIinSafeState: [self mouseButton2Activity]! ! -!WorldMorph class methodsFor: 'instance creation' stamp: 'jmv 10/21/2020 15:38:59' prior: 50550383! - newWorld - " -[ - UISupervisor stopUIProcess. - UISupervisor spawnNewMorphicProcessFor: WorldMorph newWorld -] fork. - " - | w | - w _ self new. - w morphPosition: `0@0` extent: Display extent. - w setCanvas: Display getCanvas. - w handsDo: [ :h | - h privateOwner: w ]. - ^w! ! -!WorldMorph class methodsFor: 'system startup' stamp: 'jmv 10/21/2020 16:49:42' prior: 50550395 overrides: 50551391! -initClassCachedState - "Should use some other way to find relevant instances" - self flag: #jmvVer2. - self allInstancesDo: [ :each | - each buildMagnifiedBackgroundImage. - each redrawNeeded ]. - Cursor defaultCursor activateCursor.! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 10/21/2020 17:02:09' prior: 50550406! - preferencesMenu - "Build the preferences menu for the world." - - ^ (self menu: 'Preferences...') - addItemsFromDictionaries: { - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Font Sizes...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Set System Font...'. - #object -> FontFamily. - #selector -> #promptUserAndSetDefault. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'change the current system font family.' - } asDictionary. - { - #label -> 'Load all TrueType Fonts'. - #object -> FontFamily. - #selector -> #readAdditionalTrueTypeFonts. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'Load additional TrueType fonts included with Cuis.' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }! ! -!TheWorldMenu methodsFor: 'windows & flaps menu' stamp: 'jmv 10/21/2020 16:56:57' prior: 50550510! - windowsMenu - "Build the windows menu for the world." - - ^ (self menu: 'Windows') - addItemsFromDictionaries: `{ - { - #label -> 'Find Window'. - #object -> #myWorld. - #selector -> #findWindow:. - #icon -> #windowIcon. - #balloonText -> 'Presents a list of all windows; if you choose one from the list, it becomes the active window.' - } asDictionary. - { - #label -> 'Find changed Browsers...'. - #object -> #myWorld. - #selector -> #findDirtyBrowsers:. - #icon -> #editFindReplaceIcon. - #balloonText -> 'Presents a list of browsers that have unsubmitted changes; if you choose one from the list, it becomes the active window.' - } asDictionary. - { - #label -> 'Find changed Windows...'. - #object -> #myWorld. - #selector -> #findDirtyWindows:. - #icon -> #newWindowIcon. - #balloonText -> 'Presents a list of all windows that have unsubmitted changes; if you choose one from the list, it becomes the active window.' - } asDictionary. - nil. - { - #label -> 'Find a Transcript'. - #object -> #myWorld. - #selector -> #findATranscript:. - #icon -> #printerIcon. - #balloonText -> 'Brings an open Transcript to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find a FileList'. - #object -> #myWorld. - #selector -> #findAFileList:. - #icon -> #systemFileManagerIcon. - #balloonText -> 'Brings an open fileList to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find a Change Sorter'. - #object -> #myWorld. - #selector -> #findAChangeSorter:. - #icon -> #changesIcon. - #balloonText -> 'Brings an open change sorter to the front, creating one if necessary, and makes it the active window' - } asDictionary. - { - #label -> 'Find Message Names'. - #object -> #myWorld. - #selector -> #findAMessageNamesWindow:. - #icon -> #inspectIcon. - #balloonText -> 'Brings an open MessageNames window to the front, creating one if necessary, and makes it the active window' - } asDictionary. - nil. - { - #label -> 'Tile open windows'. - #object -> TileResizeMorph. - #selector -> #tileOpenWindows. - #icon -> #windowIcon. - #balloonText -> 'Tile open windows'. - } asDictionary. - { - #label -> 'Collapse all Windows'. - #object -> #myWorld. - #selector -> #collapseAll. - #icon -> #collapseIcon. - #balloonText -> 'Reduce all open windows to collapsed forms that only show titles.' - } asDictionary. - { - #label -> 'Restore all Windows'. - #object -> #myWorld. - #selector -> #restoreAll. - #icon -> #expandIcon. - #balloonText -> 'Restore all collapsed windows back to their previous forms.' - } asDictionary. - { - #label -> 'Close top Window'. - #object -> SystemWindow. - #selector -> #closeTopWindow. - #icon -> #closeIcon. - #balloonText -> 'Close the topmost window if possible.' - } asDictionary. - { - #label -> 'Send top Window to back'. - #object -> SystemWindow. - #selector -> #sendTopWindowToBack. - #icon -> #goBottomIcon. - #balloonText -> 'Make the topmost window become the backmost one, and activate the window just beneath it.' - } asDictionary. - { - #label -> 'Move Windows onscreen'. - #object -> #myWorld. - #selector -> #bringWindowsFullOnscreen. - #icon -> #displayIcon. - #balloonText -> 'Make all windows fully visible on the screen' - } asDictionary. - nil. - { - #label -> 'Delete unchanged Windows'. - #object -> #myWorld. - #selector -> #closeUnchangedWindows. - #icon -> #warningIcon. - #balloonText -> 'Deletes all windows that do not have unsaved text edits.' - } asDictionary. - { - #label -> 'Delete non Windows'. - #object -> #myWorld. - #selector -> #deleteNonWindows. - #icon -> #warningIcon. - #balloonText -> 'Deletes all non-window morphs lying on the world.' - } asDictionary. - { - #label -> 'Delete Both of the Above'. - #selector -> #cleanUpWorld. - #icon -> #warningIcon. - #balloonText -> 'Deletes all unchanged windows and also all non-window morphs lying on the world, other than flaps.' - } asDictionary. - }`! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -[ - | oldWorld ba roots w | - oldWorld _ UISupervisor ui. - ba _ oldWorld instVarNamed: 'backgroundImageData'. - roots _ oldWorld instVarNamed: 'submorphs'. - roots _ roots reject: [ :m | m is: #TaskbarMorph ]. - oldWorld _ nil. - UISupervisor stopUIProcess. - w _ WorldMorph newWorld. - w - "recreateDefaultDesktop;" - backgroundImageData: ba; - addAllMorphs: roots; - showTaskbar. - UISupervisor spawnNewMorphicProcessFor: w. - 'Please do [Install New Updates] again.' print. -] fork. -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4420-NewPasteUpMorphAndWorldMorph-JuanVuletich-2020Oct21-17h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4417] on 21 October 2020 at 5:50:56 pm'! -!Morph commentStamp: 'jmv 10/21/2020 17:46:54' prior: 50548735! - A Morph (from the Greek "shape" or "form") is an interactive graphical object. General information on the Morphic system can be found at http://wiki.squeak.org/squeak/morph. - -Morphs exist in a tree, rooted at a World (a WorldMorph). The morphs owned by a morph are its submorphs. Morphs are drawn recursively; if a Morph has no owner it never gets -drawn. To hide a Morph and its submorphs, send the #visible: message. - -Every morph has a local coordinate system to interpret positions. -Local coordinates are used in the #drawOn: method (the Canvas understands positions in the local coordinate system), for the positions of submorphs (for example #morphPosition and #morphPosition:) and for positions carried by mouse events. - -Events are delivered to morphs in Z-order, i.e. if a morph occludes another the event is only delivered to the foremost (just like physical objects). Events received by a morph carry positions in the local coordinate system. - -Morphs can be translated by an offset, rotated around their center, orbited (rotated around the owner center), and zoomed (i.e. scaled). - -Every morph has an associated transformation that defines the inner space where the morph is drawn and where the submorphs live. These transformations don't change anything from the internal point of view of the morph. - -Structure: -instance var Type Description -owner Morph or nil My parent Morph, or nil for the top-level Morph, which is a WorldMorph -submorphs Array My child Morphs. -location GeometryTransformation Specifies position (and possibly, angle of rotation and scale change) inside owner - See comment at GeometryTransformation! -!PasteUpMorph commentStamp: '' prior: 50550702! - My instances are free areas where you can play with Morphs. Most important, the World is an instance of my subclass WorldMorph.! -!WorldMorph commentStamp: '' prior: 50550737! - A WorldMorph is a kind of PasteUpMorph that can act as the root morph of a Morphic system. Usually uses the whole Display. - -activeHand -- a HandMorph -hands -- Array of HandMorphs (typically only one) representing the Cursor and its event queue. -canvas -- BitBlitCanvas on the DisplayScreen. (Display getCanvas) -damageRecorder -- the DamageRecorder for the Display -stepList -- a Heap of StepMessage. Each morph which wants stepping has a StepMessage here. - See comment in #Morph>>stepAt: -lastStepTime -- 'now' as last sampled at step. (Time localMillisecondClock) -lastStepMessage -- nil or a selector -lastCycleTime -- 'now' as last sampled (Time localMillisecondClock) -alarms -- a Heap of MorphicAlarm. See comment in #Morph>>addAlarm:after: - An _alarm_ is an action to be done once, vs a _step_ which is cycled. -lastAlarm -- 'now' as sampled at last alarm (Time localMillisecondClock). -drawingFailureMorphs -- a WeakIdentitySet of Morphs with drawing failures -waitDelay -- a Delay -pause -- A 'phase-locked loop' style value to help regularise the step/alarm/event service rate. -lastCycleHadAnyEvent -- a boolean -! -!SystemDictionary methodsFor: 'shrinking' stamp: 'jmv 10/21/2020 17:40:03' prior: 50548838! - reduceCuis - " - Smalltalk reduceCuis - " - | keep n unused newDicts oldDicts | - - self nominallyUnsent: #reduceCuis. - - "Remove icons" - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - WorldMorph allInstancesDo: [ :w | - w backgroundImageData: nil. - w submorphsDo: [ :a | a delete ]]. - Preferences useNoMenuIcons. - Theme current initialize. - Theme content: nil. - Color shutDown. - BitBltCanvas releaseClassCachedState. - - Transcript clear. - Clipboard default initialize. - - - "Remove some methods, even if they have senders." - Utilities removeSelector: #vmStatisticsReportString. - SystemDictionary removeSelector: #recreateSpecialObjectsArray. - - StrikeFont saveSpace. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - - keep := OrderedCollection new. - keep addAll: #(SpaceTally DynamicTypingSmalltalkCompleter). - AppLauncher appGlobalName ifNotNil: [ :any | - keep add: any ]. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - [ - #hereWeGo print. - unused do: [:c | - c print. - (Smalltalk at: c) removeFromSystem]. - n := Smalltalk removeAllUnSentMessages. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - n > 0 or: [ - unused notEmpty ]] whileTrue. - ChangeSet zapAllChangeSets. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - Symbol rehash. - - "Shrink method dictionaries." - Smalltalk garbageCollect. - oldDicts _ MethodDictionary allInstances. - newDicts _ Array new: oldDicts size. - oldDicts withIndexDo: [:d :index | - newDicts at: index put: d rehashWithoutBecome ]. - oldDicts elementsExchangeIdentityWith: newDicts. - oldDicts _ newDicts _ nil. - - SmalltalkCompleter initialize . - - "Sanity checks" -" Undeclared - Smalltalk cleanOutUndeclared - Smalltalk browseUndeclaredReferences - Smalltalk obsoleteClasses - Smalltalk obsoleteBehaviors - Smalltalk browseObsoleteMethodReferences - SmalltalkImage current fixObsoleteReferences - Smalltalk browseAllUnimplementedCalls"! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 17:47:25' prior: 16875287! - fontPreferenceChanged - "Preferred fonts scale a number of window relations. - Let morphs which rely on this updte themselves. - - Note that the fontPreferenceChanged message is typically - sent to the current world. As WorldMorph inherits from me - the code below works fine for this." - - "I do nothing myself but my submorphs may." - - self submorphsDo: [ :m | m fontPreferenceChanged. ]! ! -!Morph methodsFor: 'testing' stamp: 'jmv 10/21/2020 17:38:51' prior: 50548906! - isOwnedByWorld - ^owner isWorldMorph! ! -!MorphicCanvas methodsFor: 'initialization' stamp: 'jmv 10/21/2020 17:49:39' prior: 50531447! - world: aWorldMorph - world _ aWorldMorph. - self into: world! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/21/2020 17:48:51' prior: 50544182! - computeDamage: aWorldMorph repair: aDamageRecorder rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage - "Iterate front to back while computing damage to actually repair for each morph, and for world background. - Answer uncoveredDamage, the areas where World background needs to be redrawn." - - | uncoveredDamage morph morphDamage prevMorphDamage reuseInstance morphBefore | - morphDamage _ OrderedCollection new. - prevMorphDamage _ OrderedCollection new. - uncoveredDamage _ aDamageRecorder damageReportedOther. - "Iterate from front to back" - 1 to: rootMorphs size do: [ :i | - morph _ rootMorphs at: i. - morphDamage removeAll. - (aDamageRecorder damageReportedFor: morph) ifNotNil: [ :r | - morphDamage add: r ]. - 1 to: i-1 do: [ :j | - reuseInstance _ prevMorphDamage. - prevMorphDamage _ morphDamage. - morphDamage _ reuseInstance removeAll. - morphBefore _ rootMorphs at: j. - prevMorphDamage do: [ :r | - morphBefore addPossiblyUncoveredAreasIn: r to: morphDamage ]]. - (Rectangle merging: morphDamage) ifNotNil: [ :morphDamageRect | - rootMorphsDamage at: i put: morphDamageRect. - morph addPossiblyUncoveredAreasIn: morphDamageRect to: uncoveredDamage ]]. - - ^ uncoveredDamage! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/21/2020 17:48:42' prior: 50544034! - drawWorld: aWorldMorph repair: aDamageRecorder - "Redraw the damaged areas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rootMorphs rootMorphsDamage worldDamage | - "Update #displayBounds for all dirty morphs (marked as such with #redrawNeeded). - Also add the updated bounds to aDamageRecorder, and update bounds of morphs carried by hand." - self updatingMorphBoundsDo: [ - aWorldMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - self updateHandsDisplayBounds: aWorldMorph ]. - - rootMorphs _ aWorldMorph privateSubmorphs. - rootMorphsDamage _ Array new: rootMorphs size. - - worldDamage _ self computeDamage: aWorldMorph repair: aDamageRecorder - rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage. - - self drawWorldBackground: aWorldMorph rects: worldDamage. - - self drawWorld: aWorldMorph - rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage - allDamage: worldDamage. - - aDamageRecorder reset. - ^ worldDamage! ! - -'From Cuis 5.0 [latest update: #4417] on 21 October 2020 at 5:50:56 pm'! -!Morph commentStamp: 'jmv 10/21/2020 17:46:54' prior: 50552502! - A Morph (from the Greek "shape" or "form") is an interactive graphical object. General information on the Morphic system can be found at http://wiki.squeak.org/squeak/morph. - -Morphs exist in a tree, rooted at a World (a WorldMorph). The morphs owned by a morph are its submorphs. Morphs are drawn recursively; if a Morph has no owner it never gets -drawn. To hide a Morph and its submorphs, send the #visible: message. - -Every morph has a local coordinate system to interpret positions. -Local coordinates are used in the #drawOn: method (the Canvas understands positions in the local coordinate system), for the positions of submorphs (for example #morphPosition and #morphPosition:) and for positions carried by mouse events. - -Events are delivered to morphs in Z-order, i.e. if a morph occludes another the event is only delivered to the foremost (just like physical objects). Events received by a morph carry positions in the local coordinate system. - -Morphs can be translated by an offset, rotated around their center, orbited (rotated around the owner center), and zoomed (i.e. scaled). - -Every morph has an associated transformation that defines the inner space where the morph is drawn and where the submorphs live. These transformations don't change anything from the internal point of view of the morph. - -Structure: -instance var Type Description -owner Morph or nil My parent Morph, or nil for the top-level Morph, which is a WorldMorph -submorphs Array My child Morphs. -location GeometryTransformation Specifies position (and possibly, angle of rotation and scale change) inside owner - See comment at GeometryTransformation! -!PasteUpMorph commentStamp: '' prior: 50552557! - My instances are free areas where you can play with Morphs. Most important, the World is an instance of my subclass WorldMorph.! -!WorldMorph commentStamp: '' prior: 50552563! - A WorldMorph is a kind of PasteUpMorph that can act as the root morph of a Morphic system. Usually uses the whole Display. - -activeHand -- a HandMorph -hands -- Array of HandMorphs (typically only one) representing the Cursor and its event queue. -canvas -- BitBlitCanvas on the DisplayScreen. (Display getCanvas) -damageRecorder -- the DamageRecorder for the Display -stepList -- a Heap of StepMessage. Each morph which wants stepping has a StepMessage here. - See comment in #Morph>>stepAt: -lastStepTime -- 'now' as last sampled at step. (Time localMillisecondClock) -lastStepMessage -- nil or a selector -lastCycleTime -- 'now' as last sampled (Time localMillisecondClock) -alarms -- a Heap of MorphicAlarm. See comment in #Morph>>addAlarm:after: - An _alarm_ is an action to be done once, vs a _step_ which is cycled. -lastAlarm -- 'now' as sampled at last alarm (Time localMillisecondClock). -drawingFailureMorphs -- a WeakIdentitySet of Morphs with drawing failures -waitDelay -- a Delay -pause -- A 'phase-locked loop' style value to help regularise the step/alarm/event service rate. -lastCycleHadAnyEvent -- a boolean -! -!SystemDictionary methodsFor: 'shrinking' stamp: 'jmv 10/21/2020 17:40:03' prior: 50552604! - reduceCuis - " - Smalltalk reduceCuis - " - | keep n unused newDicts oldDicts | - - self nominallyUnsent: #reduceCuis. - - "Remove icons" - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - WorldMorph allInstancesDo: [ :w | - w backgroundImageData: nil. - w submorphsDo: [ :a | a delete ]]. - Preferences useNoMenuIcons. - Theme current initialize. - Theme content: nil. - Color shutDown. - BitBltCanvas releaseClassCachedState. - - Transcript clear. - Clipboard default initialize. - - - "Remove some methods, even if they have senders." - Utilities removeSelector: #vmStatisticsReportString. - SystemDictionary removeSelector: #recreateSpecialObjectsArray. - - StrikeFont saveSpace. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - - keep := OrderedCollection new. - keep addAll: #(SpaceTally DynamicTypingSmalltalkCompleter). - AppLauncher appGlobalName ifNotNil: [ :any | - keep add: any ]. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - [ - #hereWeGo print. - unused do: [:c | - c print. - (Smalltalk at: c) removeFromSystem]. - n := Smalltalk removeAllUnSentMessages. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - n > 0 or: [ - unused notEmpty ]] whileTrue. - ChangeSet zapAllChangeSets. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - Symbol rehash. - - "Shrink method dictionaries." - Smalltalk garbageCollect. - oldDicts _ MethodDictionary allInstances. - newDicts _ Array new: oldDicts size. - oldDicts withIndexDo: [:d :index | - newDicts at: index put: d rehashWithoutBecome ]. - oldDicts elementsExchangeIdentityWith: newDicts. - oldDicts _ newDicts _ nil. - - SmalltalkCompleter initialize . - - "Sanity checks" -" Undeclared - Smalltalk cleanOutUndeclared - Smalltalk browseUndeclaredReferences - Smalltalk obsoleteClasses - Smalltalk obsoleteBehaviors - Smalltalk browseObsoleteMethodReferences - SmalltalkImage current fixObsoleteReferences - Smalltalk browseAllUnimplementedCalls"! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/21/2020 17:47:25' prior: 50552671! - fontPreferenceChanged - "Preferred fonts scale a number of window relations. - Let morphs which rely on this updte themselves. - - Note that the fontPreferenceChanged message is typically - sent to the current world. As WorldMorph inherits from me - the code below works fine for this." - - "I do nothing myself but my submorphs may." - - self submorphsDo: [ :m | m fontPreferenceChanged. ]! ! -!Morph methodsFor: 'testing' stamp: 'jmv 10/21/2020 17:38:51' prior: 50552686! - isOwnedByWorld - ^owner isWorldMorph! ! -!MorphicCanvas methodsFor: 'initialization' stamp: 'jmv 10/21/2020 17:49:39' prior: 50552691! - world: aWorldMorph - world _ aWorldMorph. - self into: world! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/21/2020 17:48:51' prior: 50552696! - computeDamage: aWorldMorph repair: aDamageRecorder rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage - "Iterate front to back while computing damage to actually repair for each morph, and for world background. - Answer uncoveredDamage, the areas where World background needs to be redrawn." - - | uncoveredDamage morph morphDamage prevMorphDamage reuseInstance morphBefore | - morphDamage _ OrderedCollection new. - prevMorphDamage _ OrderedCollection new. - uncoveredDamage _ aDamageRecorder damageReportedOther. - "Iterate from front to back" - 1 to: rootMorphs size do: [ :i | - morph _ rootMorphs at: i. - morphDamage removeAll. - (aDamageRecorder damageReportedFor: morph) ifNotNil: [ :r | - morphDamage add: r ]. - 1 to: i-1 do: [ :j | - reuseInstance _ prevMorphDamage. - prevMorphDamage _ morphDamage. - morphDamage _ reuseInstance removeAll. - morphBefore _ rootMorphs at: j. - prevMorphDamage do: [ :r | - morphBefore addPossiblyUncoveredAreasIn: r to: morphDamage ]]. - (Rectangle merging: morphDamage) ifNotNil: [ :morphDamageRect | - rootMorphsDamage at: i put: morphDamageRect. - morph addPossiblyUncoveredAreasIn: morphDamageRect to: uncoveredDamage ]]. - - ^ uncoveredDamage! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/21/2020 17:48:42' prior: 50552737! - drawWorld: aWorldMorph repair: aDamageRecorder - "Redraw the damaged areas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | rootMorphs rootMorphsDamage worldDamage | - "Update #displayBounds for all dirty morphs (marked as such with #redrawNeeded). - Also add the updated bounds to aDamageRecorder, and update bounds of morphs carried by hand." - self updatingMorphBoundsDo: [ - aWorldMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - self updateHandsDisplayBounds: aWorldMorph ]. - - rootMorphs _ aWorldMorph privateSubmorphs. - rootMorphsDamage _ Array new: rootMorphs size. - - worldDamage _ self computeDamage: aWorldMorph repair: aDamageRecorder - rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage. - - self drawWorldBackground: aWorldMorph rects: worldDamage. - - self drawWorld: aWorldMorph - rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage - allDamage: worldDamage. - - aDamageRecorder reset. - ^ worldDamage! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/21/2020 17:49:10' prior: 50544223! - drawWorld: aWorldMorph rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage allDamage: worldDamage - "Redraw the damaged areas. - Draw each morph just once, merging rectanges to be repaired as needed." - - | morph morphDamage | - - "Iterate from back to front." - rootMorphs size to: 1 by: -1 do: [ :i | - morph _ rootMorphs at: i. - morph visible ifTrue: [ - morphDamage _ rootMorphsDamage at: i. - morph displayFullBounds ifNotNil: [ :morphFullBounds | - worldDamage do: [ :r | | intersection | - intersection _ r intersect: morphFullBounds. - intersection hasPositiveExtent ifTrue: [ - morphDamage _ intersection quickMerge: morphDamage ]]]. - morphDamage ifNotNil: [ - self newClipRect: morphDamage. - self fullDraw: morph. - worldDamage add: morphDamage ]]].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/21/2020 17:49:27' prior: 50544023! - drawWorldBackground: aWorldMorph rects: worldBackgroundDamage - "Draw worldBackgroundDamage rects for aWorldMorph. - Do not include submorphs." - - worldBackgroundDamage do: [ :r | - aWorldMorph drawOn: (self newClipRect: r) ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/21/2020 17:49:33' prior: 50539264! -updateHandsDisplayBounds: aWorldMorph - "Update displayBounds for carried morphs if never set. - Useful for new morph, that are created and attached to the hand." - - aWorldMorph handsDo: [ :hand | - hand hasSubmorphs ifTrue: [ - self into: hand. - hand submorphsDo: [ :morph | - self updateDisplayBounds: morph ]. - self outOfMorph ]]! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 10/21/2020 17:39:15' prior: 50548917! - activeSubclass: aMorphicCanvasSubclass - ActiveSubclass _ aMorphicCanvasSubclass. - WorldMorph allInstancesDo: [ :w | w setCanvas ]! ! - -PasteUpMorph removeSelector: #is:! - -!methodRemoval: PasteUpMorph #is: stamp: 'Install-4421-RemoveOldPasteUpMorphAndWorldState-JuanVuletich-2020Oct21-17h35m-jmv.001.cs.st 10/24/2020 17:30:15'! -is: aSymbol - ^ aSymbol == #PasteUpMorph or: [ super is: aSymbol ]! - -Smalltalk removeClassNamed: #OldPasteUpMorph! - -!classRemoval: #OldPasteUpMorph stamp: 'Install-4421-RemoveOldPasteUpMorphAndWorldState-JuanVuletich-2020Oct21-17h35m-jmv.001.cs.st 10/24/2020 17:30:15'! -KernelMorph subclass: #OldPasteUpMorph - instanceVariableNames: 'worldState backgroundImage backgroundImageData taskbar' - classVariableNames: 'WindowEventHandler' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -Smalltalk removeClassNamed: #WorldState! - -!classRemoval: #WorldState stamp: 'Install-4421-RemoveOldPasteUpMorphAndWorldState-JuanVuletich-2020Oct21-17h35m-jmv.001.cs.st 10/24/2020 17:30:15'! -Object subclass: #WorldState - instanceVariableNames: 'hands viewBox canvas damageRecorder stepList lastStepTime lastStepMessage lastCycleTime alarms lastAlarmTime remoteServer drawingFailingMorphs waitDelay pause lastCycleHadAnyEvent activeHand world' - classVariableNames: 'DeferredUIMessages' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4421-RemoveOldPasteUpMorphAndWorldState-JuanVuletich-2020Oct21-17h35m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4418] on 22 October 2020 at 12:37:46 pm'! -!WorldMorph methodsFor: 'accessing' stamp: 'jmv 10/22/2020 12:31:25' overrides: 50550796! - handlesKeyboard - - ^ true ! ! -!WorldMorph methodsFor: 'change reporting' stamp: 'jmv 10/22/2020 12:23:07' overrides: 50550807! - addedMorph: aMorph - "Notify the receiver that the given morph was just added." - super addedMorph: aMorph. - self taskbar ifNotNil: [ :tb | - tb wasOpened: aMorph ]! ! -!WorldMorph methodsFor: 'change reporting' stamp: 'jmv 10/22/2020 12:33:24' overrides: 50550816! - removedMorph: aMorph - "Notify the receiver that aMorph was just removed from its children" - super removedMorph: aMorph. - self taskbar ifNotNil: [ :tb | - tb wasDeleted: aMorph ]! ! -!WorldMorph methodsFor: 'dropping/grabbing' stamp: 'jmv 10/22/2020 12:25:35' overrides: 50550834! - allowsFilesDrop - - ^ true! ! -!WorldMorph methodsFor: 'dropping/grabbing' stamp: 'jmv 10/22/2020 12:25:43' overrides: 50550861! - dropFiles: aDropFilesEvent - - (DropFilesAction for: aDropFilesEvent) value! ! -!WorldMorph methodsFor: 'event handling' stamp: 'jmv 10/22/2020 12:20:47' overrides: 50550915! - mouseButton2Activity - - ^self invokeWorldMenu! ! -!WorldMorph methodsFor: 'events' stamp: 'jmv 10/22/2020 12:32:01' overrides: 50550867! - keyStroke: aKeyboardEvent - "Handle a keystroke event." - (aKeyboardEvent commandAltKeyPressed or: [ aKeyboardEvent controlKeyPressed ]) - ifTrue: [ - aKeyboardEvent keyCharacter = $b ifTrue: [ BrowserWindow openBrowser ]. - aKeyboardEvent keyCharacter = $f ifTrue: [ BrowserWindow findClass ]. - aKeyboardEvent keyCharacter = $F ifTrue: [ MessageSetWindow findInSourceCode ]. - ]. - "aKeyboardEvent keyCharacter print." - ^ super keyStroke: aKeyboardEvent! ! -!WorldMorph methodsFor: 'events' stamp: 'jmv 10/22/2020 12:35:57' overrides: 50550902! - windowEvent: aMorphicEvent - - aMorphicEvent windowEventType == #windowClose - ifTrue: [ - ^TheWorldMenu basicNew quitSession] -! ! -!WorldMorph methodsFor: 'interaction loop' stamp: 'jmv 10/22/2020 12:32:35' overrides: 50550960! - mainLoop - - - self clearWaitDelay. - self setCanvas. - [ - self doOneCycle. - Processor yield. - true ] - whileTrue: []! ! -!WorldMorph methodsFor: 'interaction loop' stamp: 'jmv 10/22/2020 12:37:28' overrides: 50550967! - runProcess - - | process | - - process _ [ self mainLoop ] newProcess. - process - priority: Processor userSchedulingPriority; - name: 'Morphic UI'; - animatedUI: self. - - ^ process! ! -!WorldMorph methodsFor: 'menu & halo' stamp: 'jmv 10/22/2020 12:22:45' overrides: 50550976! - addWorldHaloMenuItemsTo: aMenu hand: aHandMorph - "Add standard halo items to the menu, given that the receiver is a World" - - | unlockables | - self addColorMenuItems: aMenu hand: aHandMorph. - -" aMenu addLine. - self addWorldToggleItemsToHaloMenu: aMenu." - aMenu addLine. - self addCopyItemsTo: aMenu. - self addExportMenuItems: aMenu hand: aHandMorph. - - self addDebuggingItemsTo: aMenu hand: aHandMorph. - - aMenu addLine. - aMenu defaultTarget: self. - - aMenu addLine. - - unlockables _ self submorphs select: - [ :m | m isLocked]. - unlockables size = 1 ifTrue: [ - aMenu add: ('unlock "{1}"' format:{unlockables first printStringLimitedTo: 40})action: #unlockContents]. - unlockables size > 1 ifTrue: [ - aMenu add: 'unlock all contents' action: #unlockContents. - aMenu add: 'unlock...' action: #unlockOneSubpart]. - - aMenu defaultTarget: aHandMorph. -! ! -!WorldMorph methodsFor: 'object serialization' stamp: 'jmv 10/22/2020 12:32:58' overrides: 50551343! - objectForDataStream: refStrm - "I am about to be written on an object file. Write a path to me in the other system instead." - - | dp | - dp _ DiskProxy global: #Smalltalk selector: #runningWorld args: #(). - refStrm replace: self with: dp. - ^ dp! ! -!WorldMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 10/22/2020 12:22:24' overrides: 50551066! - addMorph: aMorph centeredNear: aPoint - "Add the given morph to this world, attempting to keep its center as close to the given point possible while also keeping the it entirely within the bounds of this world." - - | trialRect delta | - trialRect _ Rectangle center: aPoint extent: aMorph morphExtent. - delta _ trialRect amountToTranslateWithin: self displayBounds. - self addMorph: aMorph. - aMorph morphPositionInWorld: trialRect origin + delta.! ! -!WorldMorph methodsFor: 'ui services' stamp: 'jmv 10/22/2020 12:34:19' overrides: 50551365! - request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock - "This is deprecated because using it requires blocking the user interface until the user provides a response. Please use the variants that are not modal." - ^ StringRequestMorph request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock! ! -!WorldMorph methodsFor: 'ui services' stamp: 'jmv 10/22/2020 12:34:32' overrides: 50551379! - request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock - ^ StringRequestMorph request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock! ! -!WorldMorph methodsFor: 'windows' stamp: 'jmv 10/22/2020 12:28:19' overrides: 50551354! - findATranscript - "Locate a transcript, open it, and bring it to the front. Create one if necessary" - - self - findAWindowSatisfying: [ :aWindow | aWindow model == Transcript] - orMakeOneUsing: [ TranscriptWindow openTranscript ]! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:26:09' overrides: 50551098! - bringWindowsFullOnscreen - "Make ever SystemWindow on the desktop be totally on-screen, whenever possible." - (SystemWindow - windowsIn: self - satisfying: [ :w | - w visible ]) do: [ :each | - each makeMeFullyVisible ]! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:26:30' overrides: 50551108! - closeUnchangedWindows - "Present a menu of window titles for all windows with changes, - and activate the one that gets chosen." - (SelectionMenu confirm: 'Do you really want to close all windows -except those with unaccepted edits?') ifFalse: [ ^ self ]. - (SystemWindow - windowsIn: self - satisfying: [ :w | - w visible and: [ w canDiscardEdits ]]) do: [ :w | - w delete ]! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:23:43' overrides: 50551123! - collapseNonWindows - self allNonWindowRelatedSubmorphs do: [ :m | - m collapse]! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:23:50' overrides: 50551129! - deleteNonWindows - (SelectionMenu confirm: -'Do you really want to discard all objects -that are not in windows?') - ifFalse: [^ self]. - - self allNonWindowRelatedSubmorphs do: [:m | - m delete ]! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:27:41' overrides: 50551138! - findAChangeSorter: evt - "Locate a change sorter, open it, and bring it to the front. Create one if necessary" - self - findAWindowSatisfying: [ :aWindow | - aWindow model isMemberOf: ChangeSorter] - orMakeOneUsing: [ ChangeSorterWindow open: ChangeSorter new label: nil ]! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:27:48' overrides: 50551150! - findAFileList: evt - "Locate a file list, open it, and bring it to the front. - Create one if necessary, respecting the Preference." - self - findAWindowSatisfying: [ :aWindow | - aWindow model class == FileList ] - orMakeOneUsing: [ - FileListWindow openFileList ]! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:27:57' overrides: 50551161! - findAMessageNamesWindow: evt - "Locate a MessageNames tool, open it, and bring it to the front. Create one if necessary" - self - findAWindowSatisfying: [ :aWindow | - aWindow model class == MessageNames ] - orMakeOneUsing: [ - MessageNamesWindow open: MessageNames new label: 'Message Names' ]! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:28:13' overrides: 50551173! - findATranscript: evt - "Locate a transcript, open it, and bring it to the front. Create one if necessary" - - self findATranscript! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:28:35' overrides: 50551180! - findAWindowSatisfying: qualifyingBlock orMakeOneUsing: makeBlock - "Locate a window satisfying a block, open it, and bring it to the front. Create one if necessary, by using the makeBlock" - | aWindow | - submorphs do: [ :aMorph | - (((aWindow _ aMorph) is: #SystemWindow) and: [ qualifyingBlock value: aWindow ]) ifTrue: [ - aWindow isCollapsed ifTrue: [ aWindow expand ]. - aWindow activateAndForceLabelToShow. - ^ self ]]. - "None found, so create one" - makeBlock value.! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:28:49' overrides: 50551198! - findDirtyBrowsers: evt - "Present a menu of window titles for browsers with changes, - and activate the one that gets chosen." - | menu | - menu _ MenuMorph new. - (SystemWindow - windowsIn: self - satisfying: [ :w | - w visible and: [ - (w model is: #CodeProvider) and: [ w canDiscardEdits not ]]]) do: [ :w | - menu - add: w label - target: w - action: #activate ]. - menu submorphs notEmpty ifTrue: [ menu popUpInWorld: self ]! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:28:59' overrides: 50551215! - findDirtyWindows: evt - "Present a menu of window titles for all windows with changes, - and activate the one that gets chosen." - | menu | - menu _ MenuMorph new. - (SystemWindow - windowsIn: self - satisfying: [ :w | - w visible and: [ w canDiscardEdits not ]]) do: [ :w | - menu - add: w label - target: w - action: #activate ]. - menu submorphs notEmpty ifTrue: [ menu popUpInWorld: self ]! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:29:06' overrides: 50551231! - findWindow: evt - "Present a menu names of windows and naked morphs, and activate the one that gets chosen. Collapsed windows appear below line, expand if chosen; naked morphs appear below second line; if any of them has been given an explicit name, that is what's shown, else the class-name of the morph shows; if a naked morph is chosen, bring it to front and have it don a halo." - | menu expanded collapsed nakedMorphs | - menu _ MenuMorph new. - expanded _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed not ]. - collapsed _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed ]. - nakedMorphs _ self submorphsSatisfying: [ :m | - (m is: #SystemWindow) not ]. - expanded isEmpty & (collapsed isEmpty & nakedMorphs isEmpty) ifTrue: [ ^ Smalltalk beep ]. - (expanded asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #activateAndForceLabelToShow. - w canDiscardEdits ifFalse: [ menu lastItem color: `Color red` ]]. - expanded isEmpty | (collapsed isEmpty & nakedMorphs isEmpty) ifFalse: [ menu addLine ]. - (collapsed asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #expand. - w canDiscardEdits ifFalse: [ menu lastItem color: `Color red` ]]. - nakedMorphs isEmpty ifFalse: [ menu addLine ]. - (nakedMorphs asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #comeToFrontAndAddHalo ]. - menu addTitle: 'find window'. - menu popUpInWorld: self! ! -!WorldMorph methodsFor: 'world menu' stamp: 'jmv 10/22/2020 12:20:57' overrides: 50551285! - invokeWorldMenu - "Put up the world menu, triggered by the passed-in event. - Perhaps a good place to disable it if needed" - - | menu | - menu _ (TheWorldMenu new - world: self - hand: self activeHand) buildWorldMenu. - menu addTitle: Preferences desktopMenuTitle. - menu popUpInWorld: self! ! -!WorldMorph methodsFor: 'world state' stamp: 'jmv 10/22/2020 12:24:00' overrides: 50551297! - allNonWindowRelatedSubmorphs - "Answer all non-window submorphs that are not flap-related" - - ^submorphs - reject: [ :m | (m is: #SystemWindow) or: [ m is: #TaskbarMorph ] ]! ! -!WorldMorph methodsFor: 'world state' stamp: 'jmv 10/22/2020 12:27:17' overrides: 50551306! - deleteAllHalos - self haloMorphs do: - [ :m | m delete]! ! -!WorldMorph methodsFor: 'world state' stamp: 'jmv 10/22/2020 12:30:43' overrides: 50551311! - fullRepaintNeeded - self redrawNeeded. - SystemWindow - windowsIn: self - satisfying: [ :w | - w visible ifTrue: [ w makeMeVisible ]. - false ]! ! -!WorldMorph methodsFor: 'world state' stamp: 'jmv 10/22/2020 12:27:23' overrides: 50551319! - haloMorphs - ^ self hands collect:[:h| h halo] thenSelect:[:halo| halo notNil]! ! - -PasteUpMorph removeSelector: #findWindow:! - -!methodRemoval: PasteUpMorph #findWindow: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:15'! -findWindow: evt - "Present a menu names of windows and naked morphs, and activate the one that gets chosen. Collapsed windows appear below line, expand if chosen; naked morphs appear below second line; if any of them has been given an explicit name, that is what's shown, else the class-name of the morph shows; if a naked morph is chosen, bring it to front and have it don a halo." - | menu expanded collapsed nakedMorphs | - menu _ MenuMorph new. - expanded _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed not ]. - collapsed _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed ]. - nakedMorphs _ self submorphsSatisfying: [ :m | - (m is: #SystemWindow) not ]. - expanded isEmpty & (collapsed isEmpty & nakedMorphs isEmpty) ifTrue: [ ^ Smalltalk beep ]. - (expanded asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #activateAndForceLabelToShow. - w canDiscardEdits ifFalse: [ menu lastItem color: `Color red` ]]. - expanded isEmpty | (collapsed isEmpty & nakedMorphs isEmpty) ifFalse: [ menu addLine ]. - (collapsed asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #expand. - w canDiscardEdits ifFalse: [ menu lastItem color: `Color red` ]]. - nakedMorphs isEmpty ifFalse: [ menu addLine ]. - (nakedMorphs asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #comeToFrontAndAddHalo ]. - menu addTitle: 'find window'. - menu popUpInWorld: self! - -PasteUpMorph removeSelector: #closeUnchangedWindows! - -!methodRemoval: PasteUpMorph #closeUnchangedWindows stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:15'! -closeUnchangedWindows - "Present a menu of window titles for all windows with changes, - and activate the one that gets chosen." - (SelectionMenu confirm: 'Do you really want to close all windows -except those with unaccepted edits?') ifFalse: [ ^ self ]. - (SystemWindow - windowsIn: self - satisfying: [ :w | - w visible and: [ w canDiscardEdits ]]) do: [ :w | - w delete ]! - -PasteUpMorph removeSelector: #findATranscript:! - -!methodRemoval: PasteUpMorph #findATranscript: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:15'! -findATranscript: evt - "Locate a transcript, open it, and bring it to the front. Create one if necessary" - - self findATranscript! - -PasteUpMorph removeSelector: #keyStroke:! - -!methodRemoval: PasteUpMorph #keyStroke: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:15'! -keyStroke: aKeyboardEvent - "Handle a keystroke event." - (aKeyboardEvent commandAltKeyPressed or: [ aKeyboardEvent controlKeyPressed ]) - ifTrue: [ - aKeyboardEvent keyCharacter = $b ifTrue: [ BrowserWindow openBrowser ]. - aKeyboardEvent keyCharacter = $f ifTrue: [ BrowserWindow findClass ]. - aKeyboardEvent keyCharacter = $F ifTrue: [ MessageSetWindow findInSourceCode ]. - ]. - "aKeyboardEvent keyCharacter print." - ^ super keyStroke: aKeyboardEvent! - -PasteUpMorph removeSelector: #addedMorph:! - -!methodRemoval: PasteUpMorph #addedMorph: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:15'! -addedMorph: aMorph - "Notify the receiver that the given morph was just added." - super addedMorph: aMorph. - self taskbar ifNotNil: [ :tb | - tb wasOpened: aMorph ]! - -PasteUpMorph removeSelector: #mouseButton2Activity! - -!methodRemoval: PasteUpMorph #mouseButton2Activity stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:15'! -mouseButton2Activity - - ^self invokeWorldMenu! - -PasteUpMorph removeSelector: #findATranscript! - -!methodRemoval: PasteUpMorph #findATranscript stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:15'! -findATranscript - "Locate a transcript, open it, and bring it to the front. Create one if necessary" - - self - findAWindowSatisfying: [ :aWindow | aWindow model == Transcript] - orMakeOneUsing: [ TranscriptWindow openTranscript ]! - -PasteUpMorph removeSelector: #fullRepaintNeeded! - -!methodRemoval: PasteUpMorph #fullRepaintNeeded stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:15'! -fullRepaintNeeded - self redrawNeeded. - SystemWindow - windowsIn: self - satisfying: [ :w | - w visible ifTrue: [ w makeMeVisible ]. - false ]! - -PasteUpMorph removeSelector: #request:initialAnswer:orCancel:! - -!methodRemoval: PasteUpMorph #request:initialAnswer:orCancel: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:15'! -request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock - "This is deprecated because using it requires blocking the user interface until the user provides a response. Please use the variants that are not modal." - ^ StringRequestMorph request: queryString initialAnswer: defaultAnswer orCancel: cancelBlock! - -PasteUpMorph removeSelector: #windowEvent:! - -!methodRemoval: PasteUpMorph #windowEvent: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:15'! -windowEvent: aMorphicEvent - - aMorphicEvent windowEventType == #windowClose - ifTrue: [ - ^TheWorldMenu basicNew quitSession] -! - -PasteUpMorph removeSelector: #deleteAllHalos! - -!methodRemoval: PasteUpMorph #deleteAllHalos stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:15'! -deleteAllHalos - self haloMorphs do: - [ :m | m delete]! - -PasteUpMorph removeSelector: #request:initialAnswer:verifying:do:orCancel:! - -!methodRemoval: PasteUpMorph #request:initialAnswer:verifying:do:orCancel: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:15'! -request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock - ^ StringRequestMorph request: queryString initialAnswer: defaultAnswer verifying: validationBlock do: acceptBlock orCancel: cancelBlock! - -PasteUpMorph removeSelector: #findDirtyWindows:! - -!methodRemoval: PasteUpMorph #findDirtyWindows: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:16'! -findDirtyWindows: evt - "Present a menu of window titles for all windows with changes, - and activate the one that gets chosen." - | menu | - menu _ MenuMorph new. - (SystemWindow - windowsIn: self - satisfying: [ :w | - w visible and: [ w canDiscardEdits not ]]) do: [ :w | - menu - add: w label - target: w - action: #activate ]. - menu submorphs notEmpty ifTrue: [ menu popUpInWorld: self ]! - -PasteUpMorph removeSelector: #mainLoop! - -!methodRemoval: PasteUpMorph #mainLoop stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:16'! -mainLoop - - - self clearWaitDelay. - self setCanvas. - [ - self doOneCycle. - Processor yield. - true ] - whileTrue: []! - -PasteUpMorph removeSelector: #dropFiles:! - -!methodRemoval: PasteUpMorph #dropFiles: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:16'! -dropFiles: aDropFilesEvent - - (DropFilesAction for: aDropFilesEvent) value! - -PasteUpMorph removeSelector: #handlesKeyboard! - -!methodRemoval: PasteUpMorph #handlesKeyboard stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:16'! -handlesKeyboard - - ^ true ! - -PasteUpMorph removeSelector: #findAMessageNamesWindow:! - -!methodRemoval: PasteUpMorph #findAMessageNamesWindow: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:16'! -findAMessageNamesWindow: evt - "Locate a MessageNames tool, open it, and bring it to the front. Create one if necessary" - self - findAWindowSatisfying: [ :aWindow | - aWindow model class == MessageNames ] - orMakeOneUsing: [ - MessageNamesWindow open: MessageNames new label: 'Message Names' ]! - -PasteUpMorph removeSelector: #collapseNonWindows! - -!methodRemoval: PasteUpMorph #collapseNonWindows stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:16'! -collapseNonWindows - self allNonWindowRelatedSubmorphs do: [ :m | - m collapse]! - -PasteUpMorph removeSelector: #findAChangeSorter:! - -!methodRemoval: PasteUpMorph #findAChangeSorter: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:16'! -findAChangeSorter: evt - "Locate a change sorter, open it, and bring it to the front. Create one if necessary" - self - findAWindowSatisfying: [ :aWindow | - aWindow model isMemberOf: ChangeSorter] - orMakeOneUsing: [ ChangeSorterWindow open: ChangeSorter new label: nil ]! - -PasteUpMorph removeSelector: #findAWindowSatisfying:orMakeOneUsing:! - -!methodRemoval: PasteUpMorph #findAWindowSatisfying:orMakeOneUsing: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:16'! -findAWindowSatisfying: qualifyingBlock orMakeOneUsing: makeBlock - "Locate a window satisfying a block, open it, and bring it to the front. Create one if necessary, by using the makeBlock" - | aWindow | - submorphs do: [ :aMorph | - (((aWindow _ aMorph) is: #SystemWindow) and: [ qualifyingBlock value: aWindow ]) ifTrue: [ - aWindow isCollapsed ifTrue: [ aWindow expand ]. - aWindow activateAndForceLabelToShow. - ^ self ]]. - "None found, so create one" - makeBlock value.! - -PasteUpMorph removeSelector: #findAFileList:! - -!methodRemoval: PasteUpMorph #findAFileList: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:16'! -findAFileList: evt - "Locate a file list, open it, and bring it to the front. - Create one if necessary, respecting the Preference." - self - findAWindowSatisfying: [ :aWindow | - aWindow model class == FileList ] - orMakeOneUsing: [ - FileListWindow openFileList ]! - -PasteUpMorph removeSelector: #findDirtyBrowsers:! - -!methodRemoval: PasteUpMorph #findDirtyBrowsers: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:16'! -findDirtyBrowsers: evt - "Present a menu of window titles for browsers with changes, - and activate the one that gets chosen." - | menu | - menu _ MenuMorph new. - (SystemWindow - windowsIn: self - satisfying: [ :w | - w visible and: [ - (w model is: #CodeProvider) and: [ w canDiscardEdits not ]]]) do: [ :w | - menu - add: w label - target: w - action: #activate ]. - menu submorphs notEmpty ifTrue: [ menu popUpInWorld: self ]! - -PasteUpMorph removeSelector: #activeHand! - -!methodRemoval: PasteUpMorph #activeHand stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:16'! -activeHand - "Answer the currently active hand, if any..." - ^self world ifNotNil: [ :w | w activeHand ]! - -PasteUpMorph removeSelector: #haloMorphs! - -!methodRemoval: PasteUpMorph #haloMorphs stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:16'! -haloMorphs - ^ self hands collect:[:h| h halo] thenSelect:[:halo| halo notNil]! - -PasteUpMorph removeSelector: #deleteNonWindows! - -!methodRemoval: PasteUpMorph #deleteNonWindows stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:16'! -deleteNonWindows - (SelectionMenu confirm: -'Do you really want to discard all objects -that are not in windows?') - ifFalse: [^ self]. - - self allNonWindowRelatedSubmorphs do: [:m | - m delete ]! - -PasteUpMorph removeSelector: #invokeWorldMenu! - -!methodRemoval: PasteUpMorph #invokeWorldMenu stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:16'! -invokeWorldMenu - "Put up the world menu, triggered by the passed-in event. - Perhaps a good place to disable it if needed" - - | menu | - menu _ (TheWorldMenu new - world: self - hand: self activeHand) buildWorldMenu. - menu addTitle: Preferences desktopMenuTitle. - menu popUpInWorld: self! - -PasteUpMorph removeSelector: #addMorph:centeredNear:! - -!methodRemoval: PasteUpMorph #addMorph:centeredNear: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:16'! -addMorph: aMorph centeredNear: aPoint - "Add the given morph to this world, attempting to keep its center as close to the given point possible while also keeping the it entirely within the bounds of this world." - - | trialRect delta | - trialRect _ Rectangle center: aPoint extent: aMorph morphExtent. - delta _ trialRect amountToTranslateWithin: self displayBounds. - self addMorph: aMorph. - aMorph morphPositionInWorld: trialRect origin + delta.! - -PasteUpMorph removeSelector: #objectForDataStream:! - -!methodRemoval: PasteUpMorph #objectForDataStream: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:16'! -objectForDataStream: refStrm - "I am about to be written on an object file. Write a path to me in the other system instead." - - | dp | - dp _ DiskProxy global: #Smalltalk selector: #runningWorld args: #(). - refStrm replace: self with: dp. - ^ dp! - -PasteUpMorph removeSelector: #runProcess! - -!methodRemoval: PasteUpMorph #runProcess stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:16'! -runProcess - - | process | - - process _ [ self mainLoop ] newProcess. - process - priority: Processor userSchedulingPriority; - name: 'Morphic UI'; - animatedUI: self. - - ^ process! - -PasteUpMorph removeSelector: #bringWindowsFullOnscreen! - -!methodRemoval: PasteUpMorph #bringWindowsFullOnscreen stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:16'! -bringWindowsFullOnscreen - "Make ever SystemWindow on the desktop be totally on-screen, whenever possible." - (SystemWindow - windowsIn: self - satisfying: [ :w | - w visible ]) do: [ :each | - each makeMeFullyVisible ]! - -PasteUpMorph removeSelector: #allowsFilesDrop! - -!methodRemoval: PasteUpMorph #allowsFilesDrop stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:16'! -allowsFilesDrop - - ^ true! - -PasteUpMorph removeSelector: #allNonWindowRelatedSubmorphs! - -!methodRemoval: PasteUpMorph #allNonWindowRelatedSubmorphs stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:16'! -allNonWindowRelatedSubmorphs - "Answer all non-window submorphs that are not flap-related" - - ^submorphs - reject: [ :m | (m is: #SystemWindow) or: [ m is: #TaskbarMorph ] ]! - -PasteUpMorph removeSelector: #addWorldHaloMenuItemsTo:hand:! - -!methodRemoval: PasteUpMorph #addWorldHaloMenuItemsTo:hand: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:16'! -addWorldHaloMenuItemsTo: aMenu hand: aHandMorph - "Add standard halo items to the menu, given that the receiver is a World" - - | unlockables | - self addColorMenuItems: aMenu hand: aHandMorph. - -" aMenu addLine. - self addWorldToggleItemsToHaloMenu: aMenu." - aMenu addLine. - self addCopyItemsTo: aMenu. - self addExportMenuItems: aMenu hand: aHandMorph. - - self addDebuggingItemsTo: aMenu hand: aHandMorph. - - aMenu addLine. - aMenu defaultTarget: self. - - aMenu addLine. - - unlockables _ self submorphs select: - [ :m | m isLocked]. - unlockables size = 1 ifTrue: [ - aMenu add: ('unlock "{1}"' format:{unlockables first printStringLimitedTo: 40})action: #unlockContents]. - unlockables size > 1 ifTrue: [ - aMenu add: 'unlock all contents' action: #unlockContents. - aMenu add: 'unlock...' action: #unlockOneSubpart]. - - aMenu defaultTarget: aHandMorph. -! - -PasteUpMorph removeSelector: #removedMorph:! - -!methodRemoval: PasteUpMorph #removedMorph: stamp: 'Install-4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st 10/24/2020 17:30:16'! -removedMorph: aMorph - "Notify the receiver that aMorph was just removed from its children" - super removedMorph: aMorph. - self taskbar ifNotNil: [ :tb | - tb wasDeleted: aMorph ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4422-PushDownStuffToWorldMorph-JuanVuletich-2020Oct22-12h20m-jmv.003.cs.st----! - -'From Cuis 5.0 [latest update: #4422] on 23 October 2020 at 8:32:07 pm'! - -Morph subclass: #MovableMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -!classDefinition: #MovableMorph category: #'Morphic-Kernel' stamp: 'Install-4423-MovableMorph-JuanVuletich-2020Oct23-19h51m-jmv.001.cs.st 10/24/2020 17:30:16'! -Morph subclass: #MovableMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -MovableMorph subclass: #KernelMorph - instanceVariableNames: 'extent color' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -!classDefinition: #KernelMorph category: #'Morphic-Kernel' stamp: 'Install-4423-MovableMorph-JuanVuletich-2020Oct23-19h51m-jmv.001.cs.st 10/24/2020 17:30:16'! -MovableMorph subclass: #KernelMorph - instanceVariableNames: 'extent color' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'! - -MovableMorph subclass: #WidgetMorph - instanceVariableNames: 'extent color borderWidth borderColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #WidgetMorph category: 'Morphic-Widgets' stamp: 'Install-4423-MovableMorph-JuanVuletich-2020Oct23-19h51m-jmv.001.cs.st 10/24/2020 17:30:18'! -MovableMorph subclass: #WidgetMorph - instanceVariableNames: 'extent color borderWidth borderColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4423-MovableMorph-JuanVuletich-2020Oct23-19h51m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4423] on 23 October 2020 at 11:01:16 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:52:00'! - scale - ^1! ! -!MovableMorph methodsFor: 'accessing' stamp: 'jmv 10/23/2020 20:34:55' overrides: 16873949! - location - ^location! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 21:51:57' overrides: 50519162! - allocHeightForFactor: aFactor - - "Morphs with LayoutSpecs may specify propottional layouts and minimum extents - amountToAlloc * proportion * factor >= minHeight - so breakeven is when - amountToAlloc = minHeight / proportion * factor" - | minHeight | - minHeight := self minimumLayoutHeight. - ^(self isProportionalHeight) - ifFalse: [ minHeight ] - ifTrue: [ minHeight / (aFactor * self layoutSpec privateProportionalHeight) ]! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 21:52:01' overrides: 50519178! - allocWidthForFactor: aFactor - - "Morphs with LayoutSpecs may specify propottional layouts and minimum extents - amountToAlloc * proportion * factor >= minWidth - so breakeven is when - amountToAlloc = minWidth / proportion * factor" - | minWidth | - minWidth := self minimumLayoutWidth. - ^(self isProportionalWidth) - ifFalse: [ minWidth ] - ifTrue: [ minWidth / (aFactor * self layoutSpec privateProportionalWidth) ]! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:35:29' overrides: 16875240! - externalize: aPoint - "aPoint is in own coordinates. Answer is in owner's coordinates." - "Must include scale and rotation!!" - self flag: #jmvVer2. - ^ location externalizePosition: aPoint! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:36:02' overrides: 50463602! - externalizeDisplayBounds: r - - | inOwners | - "All senders of #displayBoundsOfTransformOf: should be rethought..." - self flag: #jmvVer2. - - inOwners _ location displayBoundsOfTransformOf: r. - ^owner - ifNotNil: [ owner externalizeDisplayBounds: inOwners ] - ifNil: [ inOwners ]! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:36:07' overrides: 16875257! - externalizeDistance: aPoint - "aPoint is in own coordinates. Answer is in owner's coordinates." - ^ location externalizeDelta: aPoint! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:36:17' overrides: 16875302! - internalize: aPoint - "aPoint is in owner's coordinates. Answer is in own coordinates." - ^ location internalizePosition: aPoint! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:36:22' overrides: 16875308! - internalizeDistance: aPoint - "aPoint is in owner's coordinates. Answer is in own coordinates." - ^ location internalizeDelta: aPoint! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:38:46' overrides: 50519823! - minimumLayoutExtent - "This returns the minimum extent that the morph may be shrunk to, - when resizing LayoutMorphs. - It is expressed in the morph own coordinates, like morphExtent." - - "This method combines the information from a Morph and its optional LayoutSpec" - | minExtent | - minExtent _ self minimumExtent. - ^ layoutSpec - ifNil: [ minExtent ] - ifNotNil: [ minExtent max: ( layoutSpec minimumSpecWidth @ layoutSpec minimumSpecHeight ) ]! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 21:59:39' overrides: 16875347! - morphAlign: aPoint with: anotherPoint - ^ self morphPosition: self morphPosition + anotherPoint - aPoint! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:36:27' overrides: 16875439! - morphPosition - "Answer our position inside our owner, in owner's coordinates." - - ^ location translation! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:36:47' overrides: 50535265! - morphPosition: aPoint - "Change the position of this morph. Argument is in owner's coordinates." - (location isTranslation: aPoint) ifTrue: [ "Null change" - ^ self ]. - location _ location withTranslation: aPoint. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:36:52' overrides: 50535277! - morphPositionInWorld: newPositionInWorld - "Change the position of this morph." - "El tema es, que tipo de coordenadas tenemos? - En un mundo relativista, no hay un marco de referencia absoluto. - No tiene sentido hablar de coordenadas del mundo... El mundo podria estar escalado... - Que tienen de especial las coordenadas del mundo? - Coordenadas 'del hardware'? No deberia saber mucho sobre el... Puede haber multiples displays, hands de diverso tipo, remotas, virtuales... - - En ppio, un par de coordenadas pueden ser relativas a cualquier morph. Pareciera que necesito metodos de conversion de cualquier morph hacia mi, y de mi hacia cualquier morph... Como encontrar un marco de referencia comun???? - Dejar esto para despues. En realidad, para empezar, preciso menos: Solo preciso saber si las coordenadas estan en el morph o en su owner. Nada mas. Los eventos se iran transformando apropiadamente al moverse por el arbol, o al menos, llevaran consigo una transformacion (AffineTransformation) que se ira actualizando" - - | newPositionInOwner | - self flag: #jmvVer2. - "This method MUST die" - - newPositionInOwner _ owner - ifNotNil: [ owner internalizeFromWorld: newPositionInWorld ] - ifNil: [ newPositionInWorld ]. - - (location isTranslation: newPositionInOwner) ifTrue: [ - ^ self ]. "Null change". - - location _ location withTranslation: newPositionInOwner. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:36:56' overrides: 50548791! - orbitBy: radians - "Change the scale of this morph. Arguments are an angle and a scale." - location _ (AffineTransformation withRadians: radians) composedWith: location. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 22:12:43' overrides: 16875568! - referencePosition - "Return the current reference position of the receiver" - "a rather ugly way to say #center . At least, we avoid false polymorphism" - "remove some day" - self flag: #jmvVer2. - ^self morphExtentInWorld // 2 + self morphPositionInWorld! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 22:12:37' overrides: 16875578! - referencePosition: aPoint - "a rather ugly way to say #center: . Just for consistency with #referencePosition" - "remove some day" - self flag: #jmvVer2. - self morphPositionInWorld: aPoint - (self morphExtentInWorld // 2)! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:37:10' overrides: 50545275! - rotateBy: radians - "Change the rotation of this morph. Argument is an angle (possibly negative), to be added to current rotation." - - location _ location rotatedBy: radians. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:36:39' overrides: 50548802! - rotation: radians - "Change the rotation of this morph. Argument is an angle to be taken as the new rotation." - - self rotation: radians scale: location scale.! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:37:14' overrides: 50548810! - rotation: radians scale: scale - "Change the rotation and scale of this morph. Arguments are an angle and a scale." - location _ location withRotation: radians scale: scale. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:49:21' overrides: 50537013! - rotationDegrees: degrees - location _ location rotatedBy: degrees degreesToRadians - location radians. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:51:47' overrides: 50554130! - scale - ^location scale! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 20:37:22' overrides: 50535345! - scaleBy: scaleFactor - "Change the scale of this morph. Argument is a factor." - location _ location scaledBy: scaleFactor. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!MovableMorph methodsFor: 'initialization' stamp: 'jmv 10/23/2020 20:38:03' overrides: 50540398! - initialize - "initialize the state of the receiver" - - super initialize. - location _ MorphicTranslation new.! ! -!MovableMorph methodsFor: 'initialization' stamp: 'jmv 10/23/2020 21:41:33' overrides: 50384218! - openInWorld: aWorld - "Add this morph to the requested World." - location isIdentity - ifTrue: [ aWorld addMorph: self position: `50@50` ] - ifFalse: [ aWorld addMorph: self ]! ! -!MovableMorph methodsFor: 'layout' stamp: 'jmv 10/23/2020 21:54:32' overrides: 50519208! - minimumLayoutHeight - "I combine information from a Morph and its optional LayoutSpec" - | minHeight | - - minHeight _ self minimumExtent y. "from morph (me)." - ^ layoutSpec - ifNil: [ minHeight ] - ifNotNil: [ :ls | minHeight max: (ls minimumSpecHeight )] -! ! -!MovableMorph methodsFor: 'layout' stamp: 'jmv 10/23/2020 21:54:35' overrides: 50519219! - minimumLayoutWidth - "I combine information from a Morph and its optional LayoutSpec" - | minWidth | - - minWidth _ self minimumExtent x. "from morph (me)." - ^ layoutSpec - ifNil: [ minWidth ] - ifNotNil: [ :ls | minWidth max: (ls minimumSpecWidth )] -! ! -!MovableMorph methodsFor: 'layout' stamp: 'jmv 10/23/2020 20:38:51' overrides: 50519230! - minimumShrinkExtent - "This returns the minimum extent that the morph may be shrunk to. - It is expressed in the morph own coordinates, like morphExtent." - - | minExtent | - minExtent _ self minimumExtent. - ^ layoutSpec - ifNil: [ minExtent ] - ifNotNil: [ minExtent max: layoutSpec minimumShrinkWidth @ layoutSpec minimumShrinkHeight ]! ! -!MovableMorph methodsFor: 'layout' stamp: 'jmv 10/23/2020 20:38:57' overrides: 50519243! - minimumShrinkHeight - "This returns the minimum height that the morph may be shrunk to by a LayoutAdjustingMorph. - It is expressed in the morph own coordinates, like morphExtent." - - | minShrinkHeight | - minShrinkHeight _ self minimumExtent y. - ^ layoutSpec - ifNil: [ minShrinkHeight ] - ifNotNil: [ minShrinkHeight max: layoutSpec minimumShrinkHeight ]! ! -!MovableMorph methodsFor: 'layout' stamp: 'jmv 10/23/2020 20:39:01' overrides: 50519257! - minimumShrinkWidth - "This returns the minimum width that the morph may be shrunk to by a LayoutAdjustingMorph. - It is expressed in the morph own coordinates, like morphExtent." - - | minShrinkWidth | - minShrinkWidth _ self minimumExtent x. - ^ layoutSpec - ifNil: [ minShrinkWidth ] - ifNotNil: [ minShrinkWidth max: layoutSpec minimumShrinkWidth ]! ! -!MovableMorph methodsFor: 'private' stamp: 'jmv 10/23/2020 20:37:02' overrides: 16877173! - privateOwner: aMorph - "Private!! Should only be used by methods that maintain the ower/submorph invariant." - - | oldGlobalPosition prevOwner | - - self flag: #jmvVer2. - "Is this the best behavior???" - prevOwner _ owner. - prevOwner - ifNotNil: [ - "Had an owner. Maintain my global position..." - oldGlobalPosition _ self morphPositionInWorld ]. - owner _ aMorph. - owner - ifNil: [ - "Won't have any owner. Keep local position, as it will be maintained in my new owner later" - ] - ifNotNil: [ - prevOwner - ifNil: [ - "Didn't have any owner. Assume my local position is to be maintained in my new owner" - ] - ifNotNil: [ - "Had an owner. Maintain my global position..." - location _ location withTranslation: (owner internalizeFromWorld: oldGlobalPosition). - self flag: #jmvVer2. - "extent _ owner internalizeDistanceFromWorld: oldGlobalExtent" "or something like this!!" - ]]! ! -!MovableMorph methodsFor: 'private' stamp: 'jmv 10/23/2020 20:37:06' overrides: 16877204! - privatePosition: aPoint - "Change the position of this morph. Argument is in owner's coordinates." - - (location isTranslation: aPoint) ifTrue: [ - ^ self ]. "Null change" - - location _ location withTranslation: aPoint! ! -!MovableMorph methodsFor: 'layout-properties' stamp: 'jmv 10/23/2020 20:39:08' overrides: 16876060! - layoutSpec - "Layout specific. Return the layout spec describing where the - receiver should appear in a proportional layout" - - layoutSpec ifNotNil: [ :ls | ^ ls ]. - layoutSpec := LayoutSpec keepMorphExtent. - layoutSpec morph: self. - - ^ layoutSpec ! ! -!MovableMorph methodsFor: 'layout-properties' stamp: 'jmv 10/23/2020 20:39:14' overrides: 16876070! - layoutSpec: aLayoutSpec - "Layout specific. Set the layout spec describing where the receiver should appear in a proportional layout" - aLayoutSpec - useMorphWidth; - useMorphHeight. - self layoutSpec == aLayoutSpec ifTrue: [ ^self ]. - aLayoutSpec morph: self. - layoutSpec := aLayoutSpec. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]! ! -!MovableMorph methodsFor: 'testing' stamp: 'jmv 10/23/2020 21:54:25' overrides: 50519270! - isProportionalHeight - "Answer true if I have a layoutSpec which specifies a proportional layout" - - ^ layoutSpec - ifNil: [ false ] - ifNotNil: [ :ls | ls isProportionalHeight ]! ! -!MovableMorph methodsFor: 'testing' stamp: 'jmv 10/23/2020 21:54:29' overrides: 50519278! - isProportionalWidth - "Answer true if I have a layoutSpec which specifies a proportional layout" - - ^ layoutSpec - ifNil: [ false ] - ifNotNil: [ :ls | ls isProportionalWidth ]! ! -!Morph methodsFor: 'accessing' stamp: 'jmv 10/23/2020 21:16:48' prior: 16873949! - location - ^nil! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 21:18:12' prior: 16875240! - externalize: aPoint - "aPoint is in own coordinates. Answer is in owner's coordinates." - "Must include scale and rotation!!" - ^ aPoint! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 21:20:39' prior: 50463602! - externalizeDisplayBounds: r - - "All senders of #displayBoundsOfTransformOf: should be rethought..." - self flag: #jmvVer2. - - ^owner - ifNotNil: [ owner externalizeDisplayBounds: r ] - ifNil: [ r encompassingIntegerRectangle ]! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 21:22:26' prior: 16875257! - externalizeDistance: aPoint - "aPoint is in own coordinates. Answer is in owner's coordinates." - ^ aPoint! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 21:22:46' prior: 16875302! - internalize: aPoint - "aPoint is in owner's coordinates. Answer is in own coordinates." - ^ aPoint! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 21:23:01' prior: 16875308! - internalizeDistance: aPoint - "aPoint is in owner's coordinates. Answer is in own coordinates." - ^ aPoint! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 21:21:42' prior: 16875409! - morphExtentInWorld - "eventually, remove." - self flag: #jmvVer2. - ^(self externalizeDistanceToWorld: self morphExtent) ceiling! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 22:00:55' prior: 16875439! - morphPosition - "Answer our position inside our owner, in owner's coordinates." - self flag: #jmvVer2. self revisar. "useless" - ^ 0@0! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 22:59:44' prior: 50535265! - morphPosition: aPoint - "Change the position of this morph. Argument is in owner's coordinates. - Ignored by morphs that are not resizeable"! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 23:00:38' prior: 50535277! - morphPositionInWorld: newPositionInWorld - "Change the position of this morph. Argument is in world coordinates. - Ignored by morphs that are not movable"! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 22:15:39' prior: 16875568! - referencePosition - "Return the current reference position of the receiver" - "a rather ugly way to say #center . At least, we avoid false polymorphism" - "remove some day" - self flag: #jmvVer2. self revisar. "useless" - ^0@0! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/23/2020 22:04:37' prior: 50548810! - rotation: radians scale: scale - "Change the rotation and scale of this morph. Arguments are an angle and a scale. - Ignored by us. Redefined in some subclasses." - self flag: #jmvVer2. self revisar. "useless?"! ! -!Morph methodsFor: 'initialization' stamp: 'jmv 10/23/2020 20:38:06' prior: 50540398 overrides: 16896425! - initialize - "initialize the state of the receiver" - - owner _ nil. - submorphs _ #(). - id _ 0.! ! -!Morph methodsFor: 'initialization' stamp: 'jmv 10/23/2020 21:41:47' prior: 50384218! - openInWorld: aWorld - "Add this morph to the requested World." - aWorld addMorph: self! ! -!Morph methodsFor: 'layout' stamp: 'jmv 10/23/2020 21:28:05' prior: 50519208! - minimumLayoutHeight - "I combine information from a Morph and its optional LayoutSpec" - - ^self minimumExtent y.! ! -!Morph methodsFor: 'layout' stamp: 'jmv 10/23/2020 21:27:56' prior: 50519219! -minimumLayoutWidth - "I combine information from a Morph and its optional LayoutSpec" - - ^self minimumExtent x.! ! -!Morph methodsFor: 'layout' stamp: 'jmv 10/23/2020 21:46:12' prior: 50519230! - minimumShrinkExtent - "This returns the minimum extent that the morph may be shrunk to. - It is expressed in the morph own coordinates, like morphExtent." - - ^ self minimumExtent.! ! -!Morph methodsFor: 'layout' stamp: 'jmv 10/23/2020 21:46:40' prior: 50519243! - minimumShrinkHeight - "This returns the minimum height that the morph may be shrunk to by a LayoutAdjustingMorph. - It is expressed in the morph own coordinates, like morphExtent." - - ^ self minimumExtent y.! ! -!Morph methodsFor: 'layout' stamp: 'jmv 10/23/2020 21:46:53' prior: 50519257! - minimumShrinkWidth - "This returns the minimum width that the morph may be shrunk to by a LayoutAdjustingMorph. - It is expressed in the morph own coordinates, like morphExtent." - - ^ self minimumExtent x.! ! -!Morph methodsFor: 'testing' stamp: 'jmv 10/23/2020 21:26:45' prior: 50519270! - isProportionalHeight - "Answer true if I have a layoutSpec which specifies a proportional layout" - - ^false! ! -!Morph methodsFor: 'testing' stamp: 'jmv 10/23/2020 21:49:21' prior: 50519278! - isProportionalWidth - "Answer true if I have a layoutSpec which specifies a proportional layout" - - ^ false! ! -!Morph methodsFor: 'private' stamp: 'jmv 10/23/2020 21:48:13' prior: 16877173! - privateOwner: aMorph - "Private!! Should only be used by methods that maintain the ower/submorph invariant." - - owner _ aMorph.! ! -!Morph methodsFor: 'private' stamp: 'jmv 10/23/2020 23:00:44' prior: 16877204! - privatePosition: aPoint - "Change the position of this morph. Argument is in owner's coordinates. - Ignored by morphs that are not movable"! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 10/23/2020 20:52:06' prior: 50537078! -startRot: evt with: rotHandle - "Initialize rotation of my target if it is rotatable. Launch a command object to represent the action" - - evt hand obtainHalo: self. "Make sure the event's hand correlates with the receiver" - growingOrRotating _ true. - - self removeAllHandlesBut: rotHandle. "remove all other handles" - angleOffset _ evt eventPosition - target referencePosition. - angleOffset _ Point - r: angleOffset r - degrees: angleOffset degrees - target rotationDegrees. - scaleOffset _ target scale / (evt eventPosition - target referencePosition) rho. - -! ! -!LayoutMorph methodsFor: 'accessing' stamp: 'jmv 10/23/2020 21:56:12' prior: 50519938 overrides: 16876867! - addMorphFrontFromWorldPosition: aMorph - - aMorph layoutSpec. - self addMorphFront: aMorph. - self layoutSubmorphs. -! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 10/23/2020 21:16:03' prior: 50408037! - into: aMorph - | locationOrNil previousLast | - locationOrNil _ aMorph location. - currentMorph _ aMorph. - cti _ cti + 1. - transformations size < cti - ifTrue: [ - drawingMorphStack add: aMorph. - currentTransformation _ locationOrNil - ifNotNil: [ currentTransformation composedWith: locationOrNil] - ifNil: [ currentTransformation copy ]. - transformations add: currentTransformation ] - ifFalse: [ - drawingMorphStack at: cti put: aMorph. - previousLast _ currentTransformation. - locationOrNil - ifNil: [ - "Podriamos reusar la instancia si nos sirve." - currentTransformation _ previousLast copy. - transformations at: cti put: currentTransformation ] - ifNotNil: [ :location | - currentTransformation _ transformations at: cti. - "reuse the instance if possible" - (previousLast class == location class and: [ previousLast class == currentTransformation class ]) - ifTrue: [ - previousLast composedWith: location into: currentTransformation ] - ifFalse: [ - currentTransformation _ previousLast composedWith: location. - transformations at: cti put: currentTransformation ] - ] - ]! ! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 10/23/2020 21:19:51' prior: 16877337! - externalizeDisplayBounds: r from: aMorph - "r is a Rectangle, expressed in aMorph's coordinate system. - Answer another rectangle, that bounds r when translated to World coordinates" - - "Should translate only to whatever world or PasteUp we are displaying. - Fix when implementing multiple Canvases (Displays) showing different - (potentially nested Worlds)" - | inOwners owner | - self flag: #jmvVer2. - - inOwners _ aMorph location - ifNil: [ r ] - ifNotNil: [ :tx | tx displayBoundsOfTransformOf: r ]. - owner _ aMorph owner. - ^owner - ifNotNil: [ self externalizeDisplayBounds: inOwners from: owner] - ifNil: [ inOwners encompassingIntegerRectangle ]! ! - -MovableMorph removeSelector: #addMorphFrontFromWorldPosition:! - -Morph removeSelector: #layoutSpec:! - -!methodRemoval: Morph #layoutSpec: stamp: 'Install-4424-PushDownStuffToMovableMorph-JuanVuletich-2020Oct23-22h41m-jmv.002.cs.st 10/24/2020 17:30:18'! -layoutSpec: aLayoutSpec - "Layout specific. Set the layout spec describing where the receiver should appear in a proportional layout" - aLayoutSpec - useMorphWidth; - useMorphHeight. - self layoutSpec == aLayoutSpec ifTrue: [ ^self ]. - aLayoutSpec morph: self. - layoutSpec := aLayoutSpec. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]! - -Morph removeSelector: #referencePosition:! - -!methodRemoval: Morph #referencePosition: stamp: 'Install-4424-PushDownStuffToMovableMorph-JuanVuletich-2020Oct23-22h41m-jmv.002.cs.st 10/24/2020 17:30:18'! -referencePosition: aPoint - "a rather ugly way to say #center: . Just for consistency with #referencePosition" - "remove some day" - self flag: #jmvVer2. - self morphPositionInWorld: aPoint - (self morphExtentInWorld // 2)! - -Morph removeSelector: #morphAlign:with:! - -!methodRemoval: Morph #morphAlign:with: stamp: 'Install-4424-PushDownStuffToMovableMorph-JuanVuletich-2020Oct23-22h41m-jmv.002.cs.st 10/24/2020 17:30:18'! -morphAlign: aPoint with: anotherPoint - ^ self morphPosition: self morphPosition + anotherPoint - aPoint! - -Morph removeSelector: #rotation:! - -!methodRemoval: Morph #rotation: stamp: 'Install-4424-PushDownStuffToMovableMorph-JuanVuletich-2020Oct23-22h41m-jmv.002.cs.st 10/24/2020 17:30:18'! -rotation: radians - "Change the rotation of this morph. Argument is an angle to be taken as the new rotation." - - self rotation: radians scale: location scale.! - -Morph removeSelector: #rotationDegrees:! - -!methodRemoval: Morph #rotationDegrees: stamp: 'Install-4424-PushDownStuffToMovableMorph-JuanVuletich-2020Oct23-22h41m-jmv.002.cs.st 10/24/2020 17:30:18'! -rotationDegrees: degrees - location _ location rotatedBy: degrees degreesToRadians - location radians. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! - -Morph removeSelector: #orbitBy:! - -!methodRemoval: Morph #orbitBy: stamp: 'Install-4424-PushDownStuffToMovableMorph-JuanVuletich-2020Oct23-22h41m-jmv.002.cs.st 10/24/2020 17:30:18'! -orbitBy: radians - "Change the scale of this morph. Arguments are an angle and a scale." - location _ (AffineTransformation withRadians: radians) composedWith: location. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! - -Morph removeSelector: #rotateBy:! - -!methodRemoval: Morph #rotateBy: stamp: 'Install-4424-PushDownStuffToMovableMorph-JuanVuletich-2020Oct23-22h41m-jmv.002.cs.st 10/24/2020 17:30:18'! -rotateBy: radians - "Change the rotation of this morph. Argument is an angle (possibly negative), to be added to current rotation." - - location _ location rotatedBy: radians. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! - -Morph removeSelector: #minimumLayoutExtent! - -!methodRemoval: Morph #minimumLayoutExtent stamp: 'Install-4424-PushDownStuffToMovableMorph-JuanVuletich-2020Oct23-22h41m-jmv.002.cs.st 10/24/2020 17:30:18'! -minimumLayoutExtent - "This returns the minimum extent that the morph may be shrunk to, - when resizing LayoutMorphs. - It is expressed in the morph own coordinates, like morphExtent." - - "This method combines the information from a Morph and its optional LayoutSpec" - | minExtent | - minExtent _ self minimumExtent. - ^ layoutSpec - ifNil: [ minExtent ] - ifNotNil: [ minExtent max: ( layoutSpec minimumSpecWidth @ layoutSpec minimumSpecHeight ) ]! - -Morph removeSelector: #scaleBy:! - -!methodRemoval: Morph #scaleBy: stamp: 'Install-4424-PushDownStuffToMovableMorph-JuanVuletich-2020Oct23-22h41m-jmv.002.cs.st 10/24/2020 17:30:18'! -scaleBy: scaleFactor - "Change the scale of this morph. Argument is a factor." - location _ location scaledBy: scaleFactor. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! - -Morph removeSelector: #layoutSpec! - -!methodRemoval: Morph #layoutSpec stamp: 'Install-4424-PushDownStuffToMovableMorph-JuanVuletich-2020Oct23-22h41m-jmv.002.cs.st 10/24/2020 17:30:18'! -layoutSpec - "Layout specific. Return the layout spec describing where the - receiver should appear in a proportional layout" - - layoutSpec ifNotNil: [ :ls | ^ ls ]. - layoutSpec := LayoutSpec keepMorphExtent. - layoutSpec morph: self. - - ^ layoutSpec ! - -Morph removeSelector: #allocHeightForFactor:! - -!methodRemoval: Morph #allocHeightForFactor: stamp: 'Install-4424-PushDownStuffToMovableMorph-JuanVuletich-2020Oct23-22h41m-jmv.002.cs.st 10/24/2020 17:30:18'! -allocHeightForFactor: aFactor - - "Morphs with LayoutSpecs may specify propottional layouts and minimum extents - amountToAlloc * proportion * factor >= minHeight - so breakeven is when - amountToAlloc = minHeight / proportion * factor" - | minHeight | - minHeight := self minimumLayoutHeight. - ^(self isProportionalHeight) - ifFalse: [ minHeight ] - ifTrue: [ minHeight / (aFactor * self layoutSpec privateProportionalHeight) ]! - -Morph removeSelector: #allocWidthForFactor:! - -!methodRemoval: Morph #allocWidthForFactor: stamp: 'Install-4424-PushDownStuffToMovableMorph-JuanVuletich-2020Oct23-22h41m-jmv.002.cs.st 10/24/2020 17:30:18'! -allocWidthForFactor: aFactor - - "Morphs with LayoutSpecs may specify propottional layouts and minimum extents - amountToAlloc * proportion * factor >= minWidth - so breakeven is when - amountToAlloc = minWidth / proportion * factor" - | minWidth | - minWidth := self minimumLayoutWidth. - ^(self isProportionalWidth) - ifFalse: [ minWidth ] - ifTrue: [ minWidth / (aFactor * self layoutSpec privateProportionalWidth) ]! - -Morph removeSelector: #layoutSpecOrNil! - -!methodRemoval: Morph #layoutSpecOrNil stamp: 'Install-4424-PushDownStuffToMovableMorph-JuanVuletich-2020Oct23-22h41m-jmv.002.cs.st 10/24/2020 17:30:18'! -layoutSpecOrNil - "Layout specific. Return the layout spec describing where the - receiver should appear in a proportional layout. - Answer nil if none!!" - - ^ layoutSpec ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4424-PushDownStuffToMovableMorph-JuanVuletich-2020Oct23-22h41m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4424] on 23 October 2020 at 11:02:34 pm'! - -"Change Set: 4425-MovableMorphShape-JuanVuletich-2020Oct23-23h01m-jmv.001.cs.st -Date: 23 October 2020 -Author: Juan Vuletich - -Modifying class definition of core to Morphs is tricky. Hence this preamble." -| ui b cs d1 d2 | -Utilities authorInitialsPerSe ifNil: [ Utilities setAuthor ]. -(nil confirm: 'In order to modify instance definition of Morph and MovableMorph, -we need to restart the User Interface process. -You''ll need to do [Install New Updates] again, to install later updates.') ifFalse: [ self halt ]. -[ - ui _ UISupervisor ui. - UISupervisor stopUIProcess. - d1 _ IdentityDictionary new. - MovableMorph allSubInstancesDo: [ :m | - d2 _ Dictionary new. - d1 at: m put: d2. - d2 at: #location put: (m instVarNamed: 'location'). - d2 at: #layoutSpec put: (m instVarNamed: 'layoutSpec'). - d2 at: #properties put: (m instVarNamed: 'properties'). - d2 at: #id put: (m instVarNamed: 'id'). - d2 at: #privateDisplayBounds put: (m instVarNamed: 'privateDisplayBounds'). ]. - b _ ClassBuilder isSilent. - ClassBuilder beSilent: true. - [ - ClassBuilder new - superclass: Object - subclass: #Morph - instanceVariableNames: 'owner submorphs properties id privateDisplayBounds' - classVariableNames: 'LastMorphId' - poolDictionaries: '' - category: 'Morphic-Kernel'. - ] - on: InMidstOfFileinNotification, UndeclaredVariableWarning, PoolDefinitionNotification - do: [ :ex | ex resume: true ]. - ClassBuilder new - superclass: Morph - subclass: #MovableMorph - instanceVariableNames: 'location layoutSpec' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Kernel'. - ClassBuilder beSilent: b. - MovableMorph allSubInstancesDo: [ :m | - d2 _ d1 at: m. - m instVarNamed: 'properties' put: (d2 at: #properties). - m instVarNamed: 'id' put: (d2 at: #id). - m instVarNamed: 'privateDisplayBounds' put: (d2 at: #privateDisplayBounds). - m instVarNamed: 'location' put: (d2 at: #location). - m instVarNamed: 'layoutSpec' put: (d2 at: #layoutSpec). ]. - d1 _ nil. d2 _ nil. - UISupervisor spawnNewMorphicProcessFor: ui. - (Delay forSeconds: 1) wait. - ChangeSet installing: '4425-MovableMorphShape-JuanVuletich-2020Oct23-23h01m-jmv.001.cs.st' do: []. - cs _ ChangeSet changeSetForBaseSystem. - (cs name beginsWith: '4425') ifTrue: [ - ChangeSet removeChangeSet: cs ]. - 'Done updating definition of LabelMorph.' print. - 'Installed ChangeSet: 4425-MovableMorphShape-JuanVuletich-2020Oct23-23h01m-jmv.001.cs.st' print. - 'Please do [Install New Updates] again.' print. -] forkAt: 41! - -----SNAPSHOT----(24 October 2020 17:30:35) Cuis5.0-4425-v3.image priorSource: 6931212! - -----STARTUP---- (24 October 2020 23:08:34) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4425-v3.image! - - -'From Cuis 5.0 [latest update: #4425] on 24 October 2020 at 11:01:52 pm'! -!ChangeSet class methodsFor: 'services' stamp: 'jmv 10/24/2020 23:01:03' prior: 50540785! -installNewUpdates: updatesFileDirectory - - | warnUser | - (self newUpdates: updatesFileDirectory) do: [ :each | - self install: each ]. - - warnUser _ false. - CodePackage installedPackages keysAndValuesDo: [ :pckName :package | - package fullFileName ifNotNil: [ :fullFileName | | codePackageFile | - codePackageFile _ CodePackageFile onFileEntry: fullFileName asFileEntry. - (codePackageFile provides isLaterThan: package provides) ifTrue: [ - warnUser _ true. - package hasUnsavedChanges - ifTrue: [ 'Package: ', pckName, '. Package has unsaved changes, but there is a newer version of the file.' print ] - ifFalse: [ 'Package: ', pckName, '. There is a newer version than the currently loaded.' print ]]]]. - warnUser - ifTrue: [ - self inform: SystemVersion current version, ' - ', Smalltalk lastUpdateString, String newLineString, -'Some package(s) loaded in the image -have updated package file on disk. -Please see Transcript.' ] - ifFalse: [ - Smalltalk systemInformationString print ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4426-RemovePopUpAfterInstallUpdates-JuanVuletich-2020Oct24-23h01m-jmv.001.cs.st----! - -----SNAPSHOT----(24 October 2020 23:08:42) Cuis5.0-4426-v3.image priorSource: 7149954! - -----STARTUP---- (30 December 2020 14:48:14) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4426-v3.image! - - -'From Cuis 5.0 [latest update: #4426] on 25 October 2020 at 8:34:32 pm'! -!CodePackage methodsFor: 'accessing' stamp: 'jmv 10/25/2020 20:33:45' prior: 50400988! - codePackageClass - "Answer the specific CodePackage subclass to use." - - self class == CodePackage ifFalse: [ - ^ self class ]. - self classesDo: [ :cls | - (cls inheritsFrom: CodePackage) - ifTrue: [ - ((self packageName asIdentifier: true), 'Package') = cls name ifTrue: [ - ^ cls ]]]. - ^ nil! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4427-BeMoreCarefulAboutCodePackageSubclasses-JuanVuletich-2020Oct25-20h29m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4427] on 26 October 2020 at 10:05:48 am'! -!CodePackageFile methodsFor: 'services' stamp: 'jmv 10/26/2020 10:05:36' prior: 50504796! - install - "Create, install and answer a (sub)instance of CodePackage - Replace all existing code in the possibly existing CodePackage, removing any code that is not included in us." - | localName newCodePackage pckClass currentCS | - - localName _ fullName asFileEntry name. - ChangeSet installing: packageName do: [ - "This change set will capture a possible class definition for a subclass of CodePackage. - If it only has that, then remove it after package install. - One example needing this is 'Color-Extras.pck.st'" - currentCS _ ChangeSet changeSetForBaseSystem. - currentCS isEmpty ifFalse: [ currentCS _ nil ]. - pckClass _ CodePackage. - classes do: [ :ee | - (ee hasDefinition and: [ee superclassName = 'CodePackage']) ifTrue: [ - ((self packageName asIdentifier: true), 'Package') = ee name ifTrue: [ - ee fileInDefinitionAndMetaclass. - pckClass _ Smalltalk at: ee name ]]]. - newCodePackage _ pckClass - named: packageName - createIfAbsent: true - registerIfNew: true. - newCodePackage - fullFileName: fullName; - sourceSystem: sourceSystem; - description: description; - featureSpec: featureSpec. - - fullName asFileEntry readStreamDo: [ :stream | stream fileInAnnouncing: 'Installing ', localName, '...' ]. - methodsToRemove do: [ :methodReference | methodReference actualClass removeSelector: methodReference selector ]. - classesToRemove do: [ :className | (Smalltalk at: className) removeFromSystem ]. - currentCS ifNotNil: [ ChangeSet removeChangeSet: currentCS ]]. - - newCodePackage hasUnsavedChanges: false; triggerEvent: #dirtyFlagChanged. - DataStream initialize. "Just in case" - "If we are installing an already installed package, zap the change set with possible changes done, - as they are irrelevant now: we have the package from disk" - ChangeSet removeChangeSet: (ChangeSet existingOrNewChangeSetForPackage: newCodePackage). - Preferences transcriptLogVerbose ifTrue: [ - Transcript newLine; show: 'Package ', packageName, ' successfully installed'; newLine. - Smalltalk cleanOutUndeclared. - Undeclared notEmpty ifTrue: [ - ('Undeclared: ', Undeclared printString) print ]]. - ^newCodePackage! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4428-BeMoreCarefulAboutCodePackageSubclasses-part2-JuanVuletich-2020Oct26-10h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4428] on 26 October 2020 at 11:30:04 am'! -!LabelMorph methodsFor: 'drawing' stamp: 'KenD 10/23/2020 13:37:36' prior: 50503485 overrides: 50545913! - drawOn: aCanvas - aCanvas - drawString: (contents ifNil: [ '' ]) - at: self morphTopLeft + borderWidth - font: self fontToUse - color: color. - (borderWidth > 0) ifTrue: [ - aCanvas - frameRectangle: (0@0 extent: extent) - color: borderColor - borderWidth: borderWidth - borderStyleSymbol: #simple ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4429-LabelMorph-HonorPossibleBorderWidth-KenDickey-2020Oct26-11h27m-KenD.001.cs.st----! - -'From Cuis 5.0 [latest update: #4426] on 26 October 2020 at 11:56:27 am'! -!InputSensor methodsFor: 'keyboard' stamp: 'jmv 10/26/2020 11:55:46' prior: 50386165! - kbdTest - " - Sensor kbdTest - " - "This test routine will print the unmodified character, its keycode, - and the OR of all its modifier bits, until the character x is typed - -Also useful: - Sensor test - " - | char | - char _ nil. - [ char = $x ] whileFalse: [ - [ self keyboardPressed ] whileFalse. - char _ self keyboard. - Display fill: `5@5 extent: 400@50` fillColor: `Color white`. - (String streamContents: [ :s | - s - nextPut: $-; - nextPut: char; - nextPut: $-; - space; - print: char numericValue; - space. - self isMouseButton3Pressed ifTrue: [ s nextPutAll: ' mouseButton3/blue/tertiary/halo ' ]. - self isMouseButton2Pressed ifTrue: [ s nextPutAll: ' mouseButton2/yellow/secondary/menu ' ]. - self isMouseButton1Pressed ifTrue: [ s nextPutAll: ' mouseButton1/red/primary ' ]. - self shiftPressed ifTrue: [ s nextPutAll: ' shift ' ]. - self controlKeyPressed ifTrue: [ s nextPutAll: ' control/ctrl ' ]. - (self primMouseButtons anyMask: 32) ifTrue: [ s nextPutAll: ' macOption ' ]. - self commandAltKeyPressed ifTrue: [ s nextPutAll: ' macCommand/winAlt ' ]. - Time primMillisecondClock printOn: s - ]) - displayAt: 10 @ 10 ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4430-kbdTestTweak-JuanVuletich-2020Oct26-11h44m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4428] on 26 October 2020 at 4:06:09 pm'! -!WorldMorph methodsFor: 'misc' stamp: 'KLG 10/26/2020 16:05:08' prior: 50552054 overrides: 50551035! - buildMagnifiedBackgroundImage - super buildMagnifiedBackgroundImage. - backgroundImage ifNil: [ ^ self ]. - - canvas ifNotNil: [ :c | - (backgroundImage depth = 32 and: [ c form depth < 32 ]) ifTrue: [ - backgroundImage _ backgroundImage orderedDither32To16 ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4431-WorldMorphFix-GeraldKlix-2020Oct26-16h03m-KLG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4431] on 26 October 2020 at 4:42:31 pm'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 10/26/2020 16:18:31'! - currentMorphDrawingFails - currentMorph drawingFails! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 10/26/2020 16:19:30' prior: 50551682! - displayWorldSafely - "Update this world's display and keep track of errors during draw methods." - - [self displayWorld] ifError: [ :err :rcvr | - "Handle a drawing error" - canvas currentMorphDrawingFails. - self setCanvas. - "Install the old error handler, so we can re-raise the error" - rcvr error: err. - ]! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/26/2020 16:34:26' prior: 50538721! - fullAddCurrentRect: addCurrentBounds submorphs: trySubmorphs to: aDamageRecorder - - addCurrentBounds ifTrue: [ - currentMorph needsRedraw: false. - self fullUpdateCurrentBounds. - aDamageRecorder recordInvalidRect: currentMorph displayBounds for: currentMorph. - ]. - trySubmorphs ifTrue: [ - currentMorph submorphNeedsRedraw: false. - currentMorph clippedSubmorph ifNotNil: [ :clipped | - self clippingByCurrentMorphDo: [ self fullAddRedrawRect: clipped to: aDamageRecorder ]]. - currentMorph unclippedSubmorphsReverseDo: [ :m | - self fullAddRedrawRect: m to: aDamageRecorder ] - ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/26/2020 16:28:23' prior: 50536169! - fullUpdateCurrentBounds - | currentMorphBounds isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph drawOn: self ]. - currentMorphBounds _ self boundingRectOfCurrentMorphAfterDraw. - currentMorph displayBounds: currentMorphBounds. - isKnownFailing ifFalse: [ - currentMorph submorphsDo: [ :m | - self fullUpdateBounds: m ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4432-MorphicDrawingErrorFixes-JuanVuletich-2020Oct26-16h41m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4432] on 26 October 2020 at 4:48:09 pm'! -!WidgetMorph methodsFor: 'geometry' stamp: 'KenD 10/26/2020 12:16:38' overrides: 16875232! - extentBorder - "This is the number of pixels to add to internal minimum to calculate - my minimumExtent. " - - ^ 2 * borderWidth ! ! - -Morph removeSelector: #extentBorder! - -!methodRemoval: Morph #extentBorder stamp: 'Install-4433-MoveExtentBorderToWidget-KenDickey-2020Oct26-16h47m-KenD.001.cs.st 12/30/2020 14:48:19'! -extentBorder - "This is the number of pixels to add to internal minimum to calculate - my minimumExtent. I don;t have to do anything here. - This is the default for my subclasses" - - ^ 0 - -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4433-MoveExtentBorderToWidget-KenDickey-2020Oct26-16h47m-KenD.001.cs.st----! - -'From Cuis 5.0 [latest update: #4433] on 26 October 2020 at 6:59:40 pm'! -!Morph methodsFor: 'private' stamp: 'jmv 10/26/2020 18:32:03' prior: 50539762! - privateAddMorph: aMorph atIndex: index - - self privateAddMorph: aMorph atIndex: index position: nil! ! -!Morph methodsFor: 'private' stamp: 'jmv 10/26/2020 18:29:17' prior: 50539816! - privateAddMorph: aMorph atIndex: index position: aPointOrNil - - | oldIndex myWorld itsWorld oldOwner | - (self canAdd: aMorph) ifFalse: [ - (self confirm: 'The requested morph requires VectorGraphics support. Do you want to install and activate it?') - ifTrue: [ - Feature require: 'VectorGraphics'. - MorphicCanvas activeSubclass: (Smalltalk at: #HybridCanvas) ] - ifFalse: [ - ^self error: 'We can''t add requested morph.' ]]. - ((index >= 1) and: [index <= (submorphs size + 1)]) - ifFalse: [^ self error: 'index out of range']. - myWorld _ self world. - oldOwner _ aMorph owner. - (oldOwner == self and: [(oldIndex _ submorphs indexOf: aMorph) > 0]) ifTrue: [ - "aMorph's position changes within in the submorph chain" - oldIndex < index ifTrue:[ - "moving aMorph to back" - submorphs replaceFrom: oldIndex to: index-2 with: submorphs startingAt: oldIndex+1. - submorphs at: index-1 put: aMorph. - ] ifFalse:[ - "moving aMorph to front" - oldIndex-1 to: index by: -1 do:[:i| - submorphs at: i+1 put: (submorphs at: i)]. - submorphs at: index put: aMorph. - ]. - aPointOrNil ifNotNil: [aMorph privatePosition: aPointOrNil]. - ] ifFalse: [ - "adding a new morph" - oldOwner ifNotNil: [ - itsWorld _ aMorph world. - itsWorld ifNotNil: [aMorph invalidateBounds]. - oldOwner privateRemove: aMorph. - oldOwner removedMorph: aMorph. - ]. - aMorph privateOwner: self. - submorphs _ submorphs copyReplaceFrom: index to: index-1 with: (Array with: aMorph). - aPointOrNil ifNotNil: [aMorph privatePosition: aPointOrNil]. - (itsWorld == myWorld) ifFalse: [aMorph intoWorld: myWorld]. - ]. - myWorld ifNotNil: [aMorph redrawNeeded]. - self someSubmorphPositionOrExtentChanged. - oldOwner == self ifFalse: [ - self addedMorph: aMorph. - aMorph noteNewOwner: self ]! ! -!TheWorldMenu class methodsFor: 'menu building' stamp: 'jmv 10/26/2020 17:22:51' prior: 50544412! - worldMenuOptions - - ^`{{ - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Open...'. - #selector -> #openOpenMenu. - #icon -> #openIcon. - #balloonText -> 'Submenu to open various system tools'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'New morph...'. - #selector -> #newMorph. - #icon -> #morphsIcon. - #balloonText -> 'Offers a variety of ways to create new objects'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Preferences...'. - #selector -> #openPreferencesMenu. - #icon -> #preferencesIcon. - #balloonText -> 'Opens a menu offering many controls over appearance and system preferences.'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'Windows...'. - #selector -> #openWindowsMenu. - #icon -> #windowIcon. - #balloonText -> 'Manage open windows'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 50. - #label -> 'Help...'. - #selector -> #openHelpMenu. - #icon -> #helpIcon. - #balloonText -> 'Opens a menu of useful items for updating the system, determining what version you are running, and much else'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Changes...'. - #selector -> #openChangesMenu. - #icon -> #changesIcon. - #balloonText -> 'Opens a menu of useful tools for dealing with changes'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Debug...'. - #selector -> #openDebugMenu. - #icon -> #debugIcon. - #balloonText -> 'a menu of debugging items'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'Restore Display'. - #object -> #myWorld. - #selector -> #restoreDisplay. - #icon -> #displayIcon. - #balloonText -> 'Repaint the screen -- useful for removing unwanted display artifacts, lingering cursors, etc.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Save'. - #object -> Smalltalk. - #selector -> #saveSession. - #icon -> #saveIcon. - #balloonText -> 'Save the current version of the image on disk'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Save as...'. - #object -> Smalltalk. - #selector -> #saveAs. - #icon -> #saveAsIcon. - #balloonText -> 'Save the current version of the image on disk under a new name.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'Save new Cuis Release'. - #object -> Smalltalk. - #selector -> #saveAsNewVersion. - #icon -> #saveAsNewVersionIcon. - #balloonText -> ('Save as a new release of Cuis.\Use an updated version-stamped name\and save it under that name on disk.\', - 'Clear all user preferences and user state (class vars).') withNewLines. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 40. - #label -> 'Save and Quit'. - #selector -> #saveAndQuit. - #icon -> #saveAndQuitIcon. - #balloonText -> 'Save the image and quit out of Cuis.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 50. - #label -> 'Quit'. - #selector -> #quitSession. - #icon -> #quitIcon. - #balloonText -> 'Quit out of Cuis.'. - } asDictionary. -}`! ! - -LayoutMorph removeSelector: #privateAddMorph:atIndex:! - -!methodRemoval: LayoutMorph #privateAddMorph:atIndex: stamp: 'Install-4434-AddMorphInvalidationFix-JuanVuletich-2020Oct26-18h54m-jmv.001.cs.st 12/30/2020 14:48:19'! -privateAddMorph: aMorph atIndex: index - aMorph layoutSpec. - ^super privateAddMorph: aMorph atIndex: index! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4434-AddMorphInvalidationFix-JuanVuletich-2020Oct26-18h54m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4426] on 27 October 2020 at 10:40:23 am'! -!BlockClosure methodsFor: 'printing' stamp: 'jmv 10/27/2020 10:40:01' overrides: 16882265! - storeOn: aStream - " - [] storeString - " - aStream nextPut: $(. - self asSerializable storeOn: aStream. - aStream nextPutAll: ' asEvaluable)'! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4435-BlockClosure-storeOn-JuanVuletich-2020Oct27-10h33m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4426] on 27 October 2020 at 10:41:33 am'! -!Preferences class methodsFor: 'exception handling' stamp: 'jmv 10/27/2020 10:41:23' prior: 50478075! -warnAboutNonLocalReturnsInExceptionHandlers - ^ self - valueOfFlag: #warnAboutNonLocalReturnsInExceptionHandlers - ifAbsent: [ false ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4436-NLSinExceptionsWarning-disableByDefault-JuanVuletich-2020Oct27-10h40m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4434] on 27 October 2020 at 12:05:52 pm'! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 10/27/2020 12:05:33' prior: 50536617! - grabMorph: aMorph moveUnderHand: moveUnderHand - "Grab the given morph (i.e., add it to this hand and remove it from its current owner). - If moveUnderHand is requested or it seems neccesary anyway, move the grabbed morph under the hand." - - | grabbed delta | - self releaseMouseFocus. "Break focus" - grabbed _ aMorph. - aMorph owner ifNotNil: [ :o | - grabbed _ o aboutToGrab: aMorph ]. - grabbed ifNil: [ ^ self ]. - grabbed _ grabbed aboutToBeGrabbedBy: self. - grabbed ifNil: [ ^ self ]. - "If we find a case where this doesn't work, asking the position to aMorph instead of grabbed is possible." - delta _ grabbed morphPositionInWorld - self morphPositionInWorld. - grabbed displayBounds ifNotNil: [ :r | - (moveUnderHand or: [ (r containsPoint: self morphPositionInWorld) not ]) - ifTrue: [ - delta _ (r extent // 2) negated ]]. - ^ self - grabMorph: grabbed - delta: delta print! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4437-GrabMorphWithHandFix-JuanVuletich-2020Oct27-11h39m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4437] on 31 October 2020 at 9:03:58 am'! -!Workspace methodsFor: 'binding' stamp: 'KLG 10/30/2020 16:59:30' prior: 16945389! - initializeBindings - - bindings _ Dictionary new. - self changed: #actualContents. -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4438-WorkspaceInitializeBindings-GeraldKlix-2020Oct31-09h02m-KLG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4437] on 28 October 2020 at 10:16:36 am'! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 10/28/2020 10:16:27' prior: 50555649! - grabMorph: aMorph moveUnderHand: moveUnderHand - "Grab the given morph (i.e., add it to this hand and remove it from its current owner). - If moveUnderHand is requested or it seems neccesary anyway, move the grabbed morph under the hand." - - | grabbed positionInHandCoordinates | - self releaseMouseFocus. "Break focus" - grabbed _ aMorph. - aMorph owner ifNotNil: [ :o | grabbed _ o aboutToGrab: aMorph ]. - grabbed ifNil: [ ^ self ]. - grabbed _ grabbed aboutToBeGrabbedBy: self. - grabbed ifNil: [ ^ self ]. - moveUnderHand - ifFalse: [ - positionInHandCoordinates _ (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) - morphPositionInWorld - self morphPositionInWorld ] - ifTrue: [ - "We can possibly do better, especially for non WidgetMorphs" - positionInHandCoordinates _ -30 @ -10. - grabbed isInWorld ifTrue: [ - grabbed displayBounds ifNotNil: [ :r | - positionInHandCoordinates _ (r extent // 2) negated ]]]. - ^ self - grabMorph: grabbed - delta: positionInHandCoordinates! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4439-GrabMorphFix-JuanVuletich-2020Oct28-08h49m-jmv.003.cs.st----! - -'From Cuis 5.0 [latest update: #4438] on 6 November 2020 at 12:43:41 pm'! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 11/6/2020 12:38:36' prior: 50537457! - grabMorph: aMorph delta: delta - "Grab the given morph (i.e., add it to this hand and remove it from its current owner)." - - | formerOwner formerPositionInWorld | - self releaseMouseFocus. "Break focus" - - "Grab the halo if present" - self halo ifNotNil: [ :h | - h target == aMorph ifTrue: [ - self addMorphBack: h position: h morphPositionInWorld - self morphPositionInWorld ]]. - - "Remember previous owner and position, in case the drop is later rejected" - formerOwner _ aMorph owner. - formerOwner ifNotNil: [ - formerPositionInWorld _ aMorph morphPositionInWorld. - grabMorphData - at: aMorph - put: { formerOwner. formerPositionInWorld. } ]. - self addMorphBack: aMorph position: delta. - aMorph displayBounds ifNotNil: [ :r | | d | - d _ aMorph morphPositionInWorld - formerPositionInWorld. - d isZero ifFalse: [ - aMorph displayBounds: (r translatedBy: d)]]. - aMorph justGrabbedFrom: formerOwner. - formerOwner ifNotNil: [ - lastPosition _ self morphPosition ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4440-GrabMorphFix-JuanVuletich-2020Nov06-12h43m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4438] on 6 November 2020 at 9:58:08 am'! -!PseudoClass methodsFor: 'methods' stamp: 'jmv 11/6/2020 09:57:50' prior: 50493792! - removeSelector: aSelector - | catName | - catName := self class removedCategoryName asString. - self organization addCategory: catName before: self organization categories first. - self organization classify: aSelector under: catName. - self sourceCodeAt: aSelector put:'methodWasRemoved' asText.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4441-PseudoClass-removeSelector-fix-JuanVuletich-2020Nov06-09h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4433] on 26 October 2020 at 1:18:49 pm'! -!WidgetMorph methodsFor: 'geometry' stamp: 'KenD 10/26/2020 13:16:01'! - ensureMinimimExtent - - self privateExtent: extent! ! -!WidgetMorph methodsFor: 'accessing' stamp: 'KenD 10/26/2020 13:16:39' prior: 50545873! - borderWidth: anInteger - borderWidth = anInteger ifFalse: [ - borderWidth _ anInteger max: 0. - self ensureMinimimExtent; - redrawNeeded ]! ! -!LabelMorph methodsFor: 'geometry' stamp: 'KenD 10/26/2020 13:02:40' prior: 50548519 overrides: 50499537! - minimumExtent - - ^ self measureContents + self extentBorder! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4442-CuisCore-EnsureMinExt-2020Oct26-13h02m-KenD.001.cs.st----! - -'From Cuis 5.0 [latest update: #4442] on 9 November 2020 at 12:12:47 pm'! -!ImageMorph methodsFor: 'drawing' stamp: 'KenD 10/29/2020 13:33:06' prior: 50503479 overrides: 50545913! - drawOn: aCanvas - - aCanvas image: image at: self morphTopLeft + self borderWidth. - (borderWidth > 0) ifTrue: [ - aCanvas - frameRectangle: (0@0 extent: self morphExtent) - color: borderColor - borderWidth: borderWidth - borderStyleSymbol: #simple ]! ! -!ImageMorph methodsFor: 'drawing' stamp: 'KenD 10/29/2020 13:21:26' prior: 16854132 overrides: 50499537! - minimumExtent - ^image extent + self extentBorder ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4443-ImageMorphFix-KenDickey-2020Nov09-12h11m-KenD.001.cs.st----! - -'From Cuis 5.0 [latest update: #4443] on 9 November 2020 at 3:30:17 pm'! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 11/9/2020 15:25:35'! - frameRectangle: aRectangle topLeftColor: tlColor bottomRightColor: brColor borderWidth: borderWidth - " - (BitBltCanvas onForm: Display) - frameRectangle: (10@10 extent: 300@200) - color: Color green - borderWidth: 10 - borderStyleSymbol: #raised. - Display forceToScreen. - " - - | displayRectangle bw | - - engine ifNil: [ ^nil ]. - - bw _ (currentTransformation externalizeScalar: borderWidth) rounded. - displayRectangle _ (currentTransformation externalizeRectangle: aRectangle) rounded. - self - frameRectangle: displayRectangle - borderWidth: bw - topLeftColor: tlColor - bottomRightColor: brColor.! ! -!MorphicCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 11/9/2020 15:28:39' prior: 50463452! - fillRectangle: aRectangle color: aColor borderWidth: borderWidth borderStyleSymbol: aSymbol baseColorForBorder: baseColorForBorder - " - (BitBltCanvas onForm: Display) - fillRectangle: (10@10 extent: 300@200) - color: Color green - borderWidth: 10 - borderStyleSymbol: #raised - baseColorForBorder: Color red. - Display forceToScreen. - " - - self fillRectangle: (aRectangle insetBy: borderWidth) color: aColor. - self frameRectangle: aRectangle color: baseColorForBorder borderWidth: borderWidth borderStyleSymbol: aSymbol! ! -!MorphicCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 11/9/2020 15:26:49' prior: 50463479! - frameRectangle: aRectangle color: aColor borderWidth: borderWidth borderStyleSymbol: aSymbol - " - (BitBltCanvas onForm: Display) - frameRectangle: (10@10 extent: 300@200) - color: Color green - borderWidth: 10 - borderStyleSymbol: #raised. - Display forceToScreen. - " - - | tlColor brColor | - - engine ifNil: [ ^nil ]. - - tlColor _ aColor. - brColor _ aColor. - aSymbol == #raised ifTrue: [ - tlColor _ aColor quiteWhiter. - brColor _ aColor quiteBlacker ]. - - aSymbol == #inset ifTrue: [ - tlColor _ aColor quiteBlacker. - brColor _ aColor quiteWhiter ]. - - self frameRectangle: aRectangle topLeftColor: tlColor bottomRightColor: brColor borderWidth: borderWidth! ! - -BitBltCanvas removeSelector: #fillRectangle:color:borderWidth:borderStyleSymbol:baseColorForBorder:! - -!methodRemoval: BitBltCanvas #fillRectangle:color:borderWidth:borderStyleSymbol:baseColorForBorder: stamp: 'Install-4444-MorphicCanvas-borderStyleTweaks-JuanVuletich-2020Nov09-15h03m-jmv.001.cs.st 12/30/2020 14:48:19'! -fillRectangle: aRectangle color: aColor borderWidth: borderWidth borderStyleSymbol: aSymbol baseColorForBorder: baseColorForBorder - - - engine ifNil: [ ^nil ]. - - self fillRectangle: (aRectangle insetBy: borderWidth) color: aColor. - self frameRectangle: aRectangle color: baseColorForBorder borderWidth: borderWidth borderStyleSymbol: aSymbol! - -BitBltCanvas removeSelector: #frameRectangle:color:borderWidth:borderStyleSymbol:! - -!methodRemoval: BitBltCanvas #frameRectangle:color:borderWidth:borderStyleSymbol: stamp: 'Install-4444-MorphicCanvas-borderStyleTweaks-JuanVuletich-2020Nov09-15h03m-jmv.001.cs.st 12/30/2020 14:48:19'! -frameRectangle: r color: aColor borderWidth: borderWidth borderStyleSymbol: aSymbol - " - Display getCanvas fillRectangle: (10@10 extent: 300@200) color: Color white. Display forceToScreen. - Display getCanvas - frameRectangle: (10@10 extent: 300@200) - color: Color green - borderWidth: 10 - borderStyleSymbol: #raised. - Display forceToScreen. - " - - | displayRectangle bw | - - engine ifNil: [ ^nil ]. - - bw _ (currentTransformation externalizeScalar: borderWidth) rounded. - aSymbol == #raised ifTrue: [ - displayRectangle _ (currentTransformation externalizeRectangle: r) rounded. - ^ self - frameRectangle: displayRectangle - borderWidth: bw - topLeftColor: aColor quiteWhiter - bottomRightColor: aColor quiteBlacker ]. - - aSymbol == #inset ifTrue: [ - displayRectangle _ (currentTransformation externalizeRectangle: r) rounded. - ^ self - frameRectangle: displayRectangle - borderWidth: bw - topLeftColor: aColor quiteBlacker - bottomRightColor: aColor quiteWhiter ]. - - "Unrecognized border style. Draw some border..." - self frameRectangle: r borderWidth: bw color: aColor! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4444-MorphicCanvas-borderStyleTweaks-JuanVuletich-2020Nov09-15h03m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4444] on 10 November 2020 at 2:20:59 pm'! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 11/10/2020 14:20:44' prior: 50555743! - grabMorph: aMorph delta: delta - "Grab the given morph (i.e., add it to this hand and remove it from its current owner)." - - | formerOwner formerPositionInWorld | - self releaseMouseFocus. "Break focus" - - "Grab the halo if present" - self halo ifNotNil: [ :h | - h target == aMorph ifTrue: [ - self addMorphBack: h position: h morphPositionInWorld - self morphPositionInWorld ]]. - - "Remember previous owner and position, in case the drop is later rejected" - formerOwner _ aMorph owner. - formerOwner ifNotNil: [ - formerPositionInWorld _ aMorph morphPositionInWorld. - grabMorphData - at: aMorph - put: { formerOwner. formerPositionInWorld. } ]. - self addMorphBack: aMorph position: delta. - aMorph displayBounds ifNotNil: [ :r | | d | - formerPositionInWorld ifNotNil: [ - d _ aMorph morphPositionInWorld - formerPositionInWorld. - d isZero ifFalse: [ - aMorph displayBounds: (r translatedBy: d)]]]. - aMorph justGrabbedFrom: formerOwner. - formerOwner ifNotNil: [ - lastPosition _ self morphPosition ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4445-HandMorphFix-JuanVuletich-2020Nov10-14h20m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4444] on 10 November 2020 at 2:37:36 pm'! -!GeometryTransformation class methodsFor: 'instance creation' stamp: 'jmv 10/23/2020 19:44:01'! - identity - ^MorphicTranslation withTranslation: 0@0! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 11/10/2020 14:29:48' prior: 50554308! - orbitBy: radians - "Rotate the receiver around the origin (0@0) in owner coordinates. - Argument is an angle (possibly negative), to be added to current rotation." - - location _ (AffineTransformation withRadians: radians) composedWith: location. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 11/10/2020 14:32:19' prior: 50554370! - rotationDegrees: degrees - "Change the rotation of this morph. Argument is an angle to be taken as the new rotation." - - self rotation: degrees degreesToRadians! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4446-Morphic-tweaks-JuanVuletich-2020Nov10-14h20m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4446] on 10 November 2020 at 3:42:56 pm'! -!Morph methodsFor: 'private' stamp: 'jmv 11/10/2020 15:40:44' prior: 50555427! - privateAddMorph: aMorph atIndex: index position: aPointOrNil - - | oldIndex myWorld itsWorld oldOwner | - (self canAdd: aMorph) ifFalse: [ - (self confirm: 'The requested morph requires VectorGraphics support. Do you want to install and activate it?') - ifTrue: [ - Feature require: 'VectorGraphics'. - MorphicCanvas activeSubclass: (Smalltalk at: #HybridCanvas) ] - ifFalse: [ - ^self error: 'We can''t add requested morph.' ]]. - ((index >= 1) and: [index <= (submorphs size + 1)]) - ifFalse: [^ self error: 'index out of range']. - myWorld _ self world. - oldOwner _ aMorph owner. - (oldOwner == self and: [(oldIndex _ submorphs indexOf: aMorph) > 0]) ifTrue: [ - "aMorph's position changes within in the submorph chain" - oldIndex < index ifTrue:[ - "moving aMorph to back" - submorphs replaceFrom: oldIndex to: index-2 with: submorphs startingAt: oldIndex+1. - submorphs at: index-1 put: aMorph. - ] ifFalse:[ - "moving aMorph to front" - oldIndex-1 to: index by: -1 do:[:i| - submorphs at: i+1 put: (submorphs at: i)]. - submorphs at: index put: aMorph. - ]. - aPointOrNil ifNotNil: [aMorph privatePosition: aPointOrNil]. - ] ifFalse: [ - "adding a new morph" - oldOwner ifNotNil: [ - itsWorld _ aMorph world. - itsWorld ifNotNil: [aMorph invalidateBounds]. - oldOwner privateRemove: aMorph. - oldOwner removedMorph: aMorph. - ]. - aMorph privateOwner: self. - submorphs _ submorphs copyReplaceFrom: index to: index-1 with: (Array with: aMorph). - aPointOrNil ifNotNil: [aMorph privatePosition: aPointOrNil]. - (itsWorld == myWorld) ifFalse: [aMorph intoWorld: myWorld]. - ]. - myWorld ifNotNil: [ - index = 1 - ifTrue: [aMorph redrawNeeded ] - ifFalse: [aMorph invalidateBounds]]. - self someSubmorphPositionOrExtentChanged. - oldOwner == self ifFalse: [ - self addedMorph: aMorph. - aMorph noteNewOwner: self ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4447-MorphInvalidationFix-JuanVuletich-2020Nov10-15h42m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4447] on 10 November 2020 at 4:31:24 pm'! -!MovableMorph methodsFor: 'dropping/grabbing' stamp: 'jmv 11/10/2020 16:14:40' overrides: 16874358! - aboutToBeGrabbedBy: aHand - "The receiver is being grabbed by a hand. - Perform necessary adjustments (if any) and return the actual morph - that should be added to the hand. - Answer nil to reject the drag." - - ^self "Grab me"! ! -!Morph methodsFor: 'dropping/grabbing' stamp: 'jmv 11/10/2020 16:15:25' prior: 16874358! - aboutToBeGrabbedBy: aHand - "The receiver is being grabbed by a hand. - Perform necessary adjustments (if any) and return the actual morph - that should be added to the hand. - Answer nil to reject the drag." - - ^nil "MovableMorphs can be grabbed and moved around with the hand"! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 11/10/2020 16:09:55' prior: 50388577! - drawCurrentAsError - "The morph (or one of its submorphs) had an error in its drawing method." - | r w | - r _ currentMorph morphLocalBounds intersect: clipRect. - r hasPositiveExtent ifFalse: [r _ clipRect ]. - w _ r extent > `50@50` - ifTrue: [ 6 ] - ifFalse: [ 2 ]. - self - frameAndFillRectangle: r - fillColor: `Color red` - borderWidth: w - borderColor: `Color yellow`. - self line: r topLeft to: r bottomRight-w width: w color: `Color yellow`. - self line: r topRight -(w@0) to: r bottomLeft -(0@w)width: w color: `Color yellow`! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4448-NonMovableMorphFixes-JuanVuletich-2020Nov10-16h30m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4448] on 11 November 2020 at 11:59:15 am'! -!LabelMorph methodsFor: 'initialization' stamp: 'jmv 11/11/2020 11:58:43' prior: 50333120 overrides: 50545905! - initialize - super initialize. - font _ nil. - emphasis _ 0. - self contents: 'Label Morph' -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4449-ItsLabelMorphNotStringMorph-JuanVuletich-2020Nov11-11h58m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4449] on 11 November 2020 at 1:03:24 pm'! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 11/11/2020 12:58:43' prior: 50494624 overrides: 50463557! - setForm: aForm - super setForm: aForm. - engine _ BitBltCanvasEngine toForm: form. - "Init BitBlt so that the first call to the 'primitiveDisplayString' primitive will not fail" - engine sourceX: 0; width: 0. - self newClipRect: nil.! ! - -BitBltCanvas removeSelector: #initializeWith:origin:! - -!methodRemoval: BitBltCanvas #initializeWith:origin: stamp: 'Install-4450-BitBltCanvasFix-JuanVuletich-2020Nov11-12h55m-jmv.001.cs.st 12/30/2020 14:48:19'! -initializeWith: aForm origin: aPoint - - super initializeWith: aForm origin: aPoint. - self resetEngine! - -BitBltCanvas removeSelector: #resetEngine! - -!methodRemoval: BitBltCanvas #resetEngine stamp: 'Install-4450-BitBltCanvasFix-JuanVuletich-2020Nov11-12h55m-jmv.001.cs.st 12/30/2020 14:48:19'! -resetEngine - "Private!! Create a new BitBltCanvasEngine for a new copy." - - engine _ BitBltCanvasEngine toForm: form. - "Init BitBlt so that the first call to the 'primitiveDisplayString' primitive will not fail" - engine sourceX: 0; width: 0! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4450-BitBltCanvasFix-JuanVuletich-2020Nov11-12h55m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4450] on 12 November 2020 at 10:50:18 am'! -!Morph methodsFor: 'accessing' stamp: 'jmv 11/12/2020 09:51:47' prior: 50540378! - morphId - "Non zero. A zero id in, for example, VectorEngine, means no Morph. - reserve lower 8 bits of numeric ivar for boolean flags." - " - Morph clearIds - " - | morphId | - morphId _ id >> 8. - morphId = 0 ifTrue: [ - LastMorphId isNil ifTrue: [ LastMorphId _ 0 ]. - LastMorphId _ LastMorphId + 1. - id _ LastMorphId << 8 + id. "Keep any flags" - morphId _ LastMorphId ]. - ^morphId! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4451-morphIdComment-JuanVuletich-2020Nov12-09h51m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4451] on 15 November 2020 at 10:26:39 am'! -!PluggableScrollPane methodsFor: 'access options' stamp: 'jmv 11/15/2020 09:30:29'! - alwaysShowVerticalScrollbar - - hideScrollBars _ #alwaysShowVertical. - self vShowScrollBar.! ! -!SystemWindow class methodsFor: 'instance creation' stamp: 'jmv 11/15/2020 10:25:36'! - editWordWrapText: aTextModel label: labelString - | textMorph window | - textMorph _ TextModelMorph withModel: aTextModel. - textMorph wrapFlag: true. - textMorph alwaysShowVerticalScrollbar. - window _ self new model: aTextModel. - window setLabel: labelString. - window layoutMorph - addMorph: textMorph - proportionalHeight: 1. - ^ window openInWorld! ! -!Workspace methodsFor: 'gui' stamp: 'jmv 11/15/2020 10:25:48' prior: 16945408 overrides: 16933891! -openLabel: aString - "Create a standard system view of the model, me, and open it." - | win | - win _ WorkspaceWindow editWordWrapText: self label: aString. - self changed: #actualContents. - ^win! ! -!PluggableScrollPane methodsFor: 'access options' stamp: 'jmv 11/15/2020 09:28:38' prior: 16889522! - hideScrollBarsIndefinitely - - hideScrollBars _ #hide. - self vHideScrollBar. - self hHideScrollBar.! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 11/15/2020 09:28:06' prior: 16889776! - updateScrollBarsBounds - - | t | - hideScrollBars = #hide ifTrue: [^self]. - t _ self scrollBarClass scrollbarThickness. - scrollBar - morphPosition: extent x - t - borderWidth @ borderWidth - extent: t @ self vScrollBarHeight. - hScrollBar - morphPosition: borderWidth @ (extent y - t - borderWidth) - extent: self hScrollBarWidth@t! ! -!PluggableScrollPane methodsFor: 'initialization' stamp: 'jmv 11/15/2020 09:28:59' prior: 50384492 overrides: 50384371! - initialize - - "initialize the state of the receiver" - super initialize. - hideScrollBars _ #showIfNeeded. - - "initialize the receiver's scrollBars" - scrollBar _ self scrollBarClass new model: self setValueSelector: #vScrollBarValue:. - hScrollBar _ self scrollBarClass new model: self setValueSelector: #hScrollBarValue:. - drawKeyboardFocusIndicator _ true. - - scroller _ self innerMorphClass new. - self addMorph: scroller. - self scrollerOffset: `0@ 0`. - self addMorph: scrollBar. - self addMorph: hScrollBar! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'jmv 11/15/2020 09:28:22' prior: 16889904! - hIsScrollbarNeeded - "Return whether the horz scrollbar is needed" - - self mightNeedHorizontalScrollBar ifFalse: [ ^false ]. - - "Don't show it if we were told not to." - hideScrollBars = #hide ifTrue: [ ^false ]. - - ^self hLeftoverScrollRange > 0! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'jmv 11/15/2020 09:31:36' prior: 16890016! - vIsScrollbarNeeded - "Return whether the vertical scrollbar is needed" - - "Don't show it if we were told not to." - hideScrollBars = #hide ifTrue: [ ^false ]. - - hideScrollBars = #alwaysShowVertical ifTrue: [ ^true ]. - - ^self vLeftoverScrollRange > 0! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4452-WorkspacesWithScrollBar-JuanVuletich-2020Nov15-10h23m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4451] on 15 November 2020 at 10:30:55 am'! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'jmv 11/15/2020 08:26:13' prior: 50516768! - doItProfiling: aBoolean - "Set the context to include pool vars of the model. Then evaluate. - Print the result on the Transcript" - | answer | - answer _ self - evaluateSelectionAndDo: [ :result | - Transcript finishEntry. - [result print] - on: UnhandledError - do: [:ex | 'printing doIt result failed' print]] - ifFail: nil - profiled: aBoolean. - morph formatAndStyleIfNeeded. "Needed to re-shout workspaces, that might have new variables binded." - ^answer! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'jmv 11/15/2020 08:25:28' prior: 50445244! - evaluateSelectionAndDo: aBlock ifFail: failBlock profiled: doProfile - "Treat the current selection as an expression; evaluate it and return the result - 3 +4 - " - | provider result receiver context methodAndCompiler | - - self lineSelectAndEmptyCheck: [^ '']. - - provider _ self codeProvider. - (provider respondsTo: #doItReceiver) - ifTrue: [ - receiver _ provider doItReceiver. - context _ provider doItContext] - ifFalse: [receiver _ context _ nil]. - - methodAndCompiler _ self compileSelectionFor: receiver in: context ifFail: [^ failBlock value]. - - result _ (methodAndCompiler at: #compiler) - evaluateMethod: (methodAndCompiler at: #method) - to: receiver - logged: true - profiled: doProfile. - - ^ aBlock value: result! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'jmv 11/15/2020 08:27:53' prior: 16909726! - exploreIt - - self - evaluateSelectionAndDo: [ :result | result explore ] - ifFail: [ morph flash ] - profiled: false. - morph formatAndStyleIfNeeded. "Needed to re-shout workspaces, that might have new variables binded."! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'jmv 11/15/2020 08:26:35' prior: 50452860! - inspectSelectionOrLine - - self - evaluateSelectionAndDo: [ :result | result inspect ] - ifFail: [ morph flash ] - profiled: false. - morph formatAndStyleIfNeeded. "Needed to re-shout workspaces, that might have new variables binded."! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4453-AvoidUnnededRestyles-JuanVuletich-2020Nov15-10h26m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4453] on 15 November 2020 at 2:07:57 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 11/15/2020 14:04:05'! - extentChanged: oldExtent - "Our extent changed. Must layout submorphs again." - - self layoutNeeded: true.! ! -!PasteUpMorph methodsFor: 'geometry' stamp: 'jmv 11/15/2020 11:32:36' overrides: 50556435! - extentChanged: oldExtent - "Our extent changed. Must layout submorphs again." - - super extentChanged: oldExtent. - self buildMagnifiedBackgroundImage.! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 11/15/2020 11:33:14' overrides: 50556442! - extentChanged: oldExtent - "Our extent changed. Must layout submorphs again." - - super extentChanged: oldExtent. - self setCanvas! ! -!InnerTextMorph methodsFor: 'geometry' stamp: 'jmv 11/15/2020 14:05:15' overrides: 50556435! - extentChanged: oldExtent - "Our extent changed. Reflow text." - super extentChanged: oldExtent. - wrapFlag ifTrue: [ - extent x = oldExtent x ifFalse: [ - self resetTextComposition. - self editor recomputeSelection. - owner - updateScrollBarsBounds; - setScrollDeltas ]]! ! -!PluggableButtonMorph methodsFor: 'geometry' stamp: 'jmv 11/15/2020 11:34:23' overrides: 50556435! - extentChanged: oldExtent - "Our extent changed. Must layout submorphs again." - - super extentChanged: oldExtent. - magnifiedIcon _ nil! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 11/15/2020 11:34:59' overrides: 50556435! - extentChanged: oldExtent - "Our extent changed. Must layout submorphs again." - - super extentChanged: oldExtent. - "Now reset widget sizes" - scroller adjustExtent. - self updateScrollBarsBounds. - self setScrollDeltas. - self scrollSelectionIntoView ! ! -!ScrollBar methodsFor: 'geometry' stamp: 'jmv 11/15/2020 11:36:06' overrides: 50556435! - extentChanged: oldExtent - "Our extent changed. Must layout submorphs again." - | isH wasH | - - super extentChanged: oldExtent. - wasH _ self isHorizontal. - "Doesn't move!!" - "upButton morphPosition: borderWidth@borderWidth." - downButton morphPosition: extent - borderWidth - downButton morphExtent. - isH _ self isHorizontal. - isH = wasH ifFalse: [ - isH - ifTrue: [ - upButton updateLeftButtonImage. - downButton updateRightButtonImage ] - ifFalse: [ - upButton updateUpButtonImage. - downButton updateDownButtonImage ]].! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 11/15/2020 10:59:42' prior: 50535410 overrides: 16875404! - morphExtent: newExtent - "assume it is always in our coordinates!!" - - | oldExtent | - extent = newExtent ifFalse: [ - oldExtent _ extent. - (self privateExtent: newExtent) ifTrue: [ - self extentChanged: oldExtent. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]]! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 11/15/2020 11:00:00' prior: 50535422! - morphPosition: newPos extent: newExtent - "Change the position of this morph. Argument is in owner's coordinates." - - | someChange oldExtent | - someChange _ false. - (location isTranslation: newPos) ifFalse: [ - location _ location withTranslation: newPos. - someChange _ true ]. - - extent = newExtent ifFalse: [ - oldExtent _ extent. - (self privateExtent: newExtent) ifTrue: [ - someChange _ true ]]. - - someChange ifTrue: [ - self extentChanged: oldExtent. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 11/15/2020 11:15:33' prior: 50555804! - ensureMinimimExtent - - | oldExtent | - oldExtent _ extent. - (self privateExtent: extent) ifTrue: [ - self extentChanged: oldExtent ].! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 11/15/2020 11:00:16' prior: 50545939 overrides: 16875404! - morphExtent: newExtent - "assume it is always in our coordinates!!" - - | oldExtent | - extent = newExtent ifFalse: [ - oldExtent _ extent. - (self privateExtent: newExtent) ifTrue: [ - self extentChanged: oldExtent. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]]! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 11/15/2020 11:00:31' prior: 50545970! - morphPosition: newPos extent: newExtent - "Change the position of this morph. Argument is in owner's coordinates." - - | someChange oldExtent | - someChange _ false. - (location isTranslation: newPos) ifFalse: [ - location _ location withTranslation: newPos. - someChange _ true ]. - - extent = newExtent ifFalse: [ - oldExtent _ extent. - (self privateExtent: newExtent) ifTrue: [ - someChange _ true ]]. - - someChange ifTrue: [ - self extentChanged: oldExtent. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]! ! -!ImageMorph methodsFor: 'accessing' stamp: 'jmv 11/15/2020 10:58:37' prior: 50535442! - image: anImage - | newExtent oldExtent | - image _ anImage depth = 1 - ifTrue: [ ColorForm mappingWhiteToTransparentFrom: anImage ] - ifFalse: [ anImage ]. - newExtent _ image extent. - extent = newExtent ifFalse: [ - oldExtent _ extent. - extent _ newExtent. - self extentChanged: oldExtent. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]]. - self redrawNeeded.! ! -!InnerTextMorph methodsFor: 'accessing' stamp: 'jmv 11/15/2020 11:30:31' prior: 50535457! - model: aTextModel wrappedTo: width - "Accept new text contents. Lay it out, wrapping to width. - Then fit my height to the result." - | newExtent | - wrapFlag _ true. - model _ aTextModel. - newExtent _ width truncated@extent y. - extent = newExtent ifFalse: [ - extent _ newExtent. - self someSubmorphPositionOrExtentChanged. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]. - self model: aTextModel! ! -!InnerTextMorph methodsFor: 'geometry' stamp: 'jmv 11/15/2020 11:16:56' prior: 16855887 overrides: 50546006! - privateExtent: aPoint - | newExtent | - - "Resist changing the extent if no wordwrap. this should be checked." - wrapFlag ifFalse: [ ^ false ]. - - "Just update width. Height is set by ourselves. See #fit" - newExtent _ aPoint x truncated @ extent y. - - ^ super privateExtent: newExtent! ! -!InnerTextMorph methodsFor: 'private' stamp: 'jmv 11/15/2020 10:59:06' prior: 50535473! - fit - "Adjust my bounds to fit the text. - Required after the text changes, - or if wrapFlag is true and the user attempts to change the extent." - - | newExtent newHeight newWidth oldExtent | - newWidth _ extent x. - "Adjust width only if we don't wrap text to own width!!" - wrapFlag ifFalse: [ - newWidth _ self textComposition usedWidth max: 9 ]. - newHeight _ self textComposition usedHeight max: FontFamily defaultLineSpacing + 2. - newExtent _ newWidth @ newHeight. - extent = newExtent - ifTrue: [ - self redrawNeeded. - "Too conservative: only text composition (because of changes in text or styles, etc) - should cause invalidation. - Try to avoid calling #fit unless needed." - ] - ifFalse: [ - extent = newExtent ifFalse: [ - oldExtent _ extent. - extent _ newExtent. - self extentChanged: oldExtent. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]]. - - owner innerHeight: newExtent y! ! - -ScrollBar removeSelector: #privateExtent:! - -!methodRemoval: ScrollBar #privateExtent: stamp: 'Install-4454-extentChanged-JuanVuletich-2020Nov15-14h03m-jmv.001.cs.st 12/30/2020 14:48:19'! -privateExtent: aPoint - | isH wasH | - wasH _ self isHorizontal. - ^ (super privateExtent: aPoint) - ifTrue: [ - "Doesn't move!!" - "upButton morphPosition: borderWidth@borderWidth." - downButton morphPosition: extent - borderWidth - downButton morphExtent. - isH _ self isHorizontal. - isH = wasH ifFalse: [ - isH - ifTrue: [ - upButton updateLeftButtonImage. - downButton updateRightButtonImage ] - ifFalse: [ - upButton updateUpButtonImage. - downButton updateDownButtonImage ]]. - ]; yourself! - -PluggableScrollPane removeSelector: #privateExtent:! - -!methodRemoval: PluggableScrollPane #privateExtent: stamp: 'Install-4454-extentChanged-JuanVuletich-2020Nov15-14h03m-jmv.001.cs.st 12/30/2020 14:48:19'! -privateExtent: aPoint - - ^ (super privateExtent: aPoint) - ifTrue: [ - "Now reset widget sizes" - scroller adjustExtent. - self updateScrollBarsBounds. - self setScrollDeltas. - self scrollSelectionIntoView ]; yourself! - -PluggableButtonMorph removeSelector: #privateExtent:! - -!methodRemoval: PluggableButtonMorph #privateExtent: stamp: 'Install-4454-extentChanged-JuanVuletich-2020Nov15-14h03m-jmv.001.cs.st 12/30/2020 14:48:19'! -privateExtent: aPoint - - ^ (super privateExtent: aPoint) - ifTrue: [ - magnifiedIcon _ nil ]; yourself! - -WorldMorph removeSelector: #privateExtent:! - -!methodRemoval: WorldMorph #privateExtent: stamp: 'Install-4454-extentChanged-JuanVuletich-2020Nov15-14h03m-jmv.001.cs.st 12/30/2020 14:48:19'! -privateExtent: newExtent - - ^ (super privateExtent: newExtent) - ifTrue: [ - self setCanvas ]; - yourself! - -PasteUpMorph removeSelector: #privateExtent:! - -!methodRemoval: PasteUpMorph #privateExtent: stamp: 'Install-4454-extentChanged-JuanVuletich-2020Nov15-14h03m-jmv.001.cs.st 12/30/2020 14:48:19'! -privateExtent: newExtent - - ^ (super privateExtent: newExtent) - ifTrue: [ self buildMagnifiedBackgroundImage ]; - yourself! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4454-extentChanged-JuanVuletich-2020Nov15-14h03m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4453] on 15 November 2020 at 2:26:04 pm'! -!TextModel methodsFor: 'accessing' stamp: 'jmv 11/15/2020 14:25:21' prior: 16933710! - textSize - actualContents ifNil: [ ^0 ]. - ^actualContents size! ! -!InnerTextMorph methodsFor: 'accessing' stamp: 'jmv 11/15/2020 14:25:48' prior: 50556597! - model: aTextModel wrappedTo: width - "Accept new text contents. Lay it out, wrapping to width. - Then fit my height to the result." - | newExtent oldExtent | - wrapFlag _ true. - model _ aTextModel. - newExtent _ width truncated@extent y. - extent = newExtent ifFalse: [ - oldExtent _ extent. - extent _ newExtent. - self extentChanged: oldExtent. - self someSubmorphPositionOrExtentChanged. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]. - self model: aTextModel! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4455-extentChangedCoda-JuanVuletich-2020Nov15-14h07m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4453] on 15 November 2020 at 2:54:41 pm'! -!TextEmphasis commentStamp: '' prior: 16933273! - A TextEmphasis, encodes a characteristic applicable to all fonts. The encoding is as follows: - 1 bold - 2 italic - 4 underlined - 8 struck out - 16 Superscript - 32 Subscript - 64 with ST-80 Glyphs! -!TextModel methodsFor: 'user interface support' stamp: 'jmv 11/15/2020 14:54:14'! - allowStylingWithEmphasis - "Default for Smalltalk methods" - - ^true! ! -!Workspace methodsFor: 'user interface support' stamp: 'jmv 11/15/2020 14:53:54' overrides: 50556771! - allowStylingWithEmphasis - "Faster styling of large contents, as text metrics are not affected." - - ^false! ! -!SHTextStylerST80 methodsFor: 'styling' stamp: 'jmv 11/15/2020 14:51:24'! - styleWorkspaceFrom: start to: end allowEmphasis: aBoolean - "Style a copy of part of the model text. Then apply attributes to model text. Useful for Workspaces. - Call #formatWorkspace: becore calling us. - Note: classOrMetaClass is assumed to be nil. - Note: after last call, do `textModel changed: #shoutStyled`" - - parser - source: (formattedText asString copyFrom: start to: end). - parser parse. - parser ranges ifNotNil: [ :ranges | - ranges do: [ :range | - (self attributesFor: range rangeType) ifNotNil: [ :attributes | - attributes do: [ :each | - "For Workspaces, avoid attributes that affect text layout: very large contents would be slow." - (aBoolean or: [each emphasisCode noMask: 3]) ifTrue: [ - formattedText - addAttribute: each - from: range start +start-1 - to: range end +start-1 ]]]]].! ! -!Workspace methodsFor: 'user interface support' stamp: 'jmv 11/15/2020 14:47:17' prior: 50519079 overrides: 50368780! - formatAndStyleIfNeededWith: anSHTextStyler - | separator fragmentStart fragmentEnd done| - (anSHTextStyler notNil and: [self shouldStyle: self actualContents with: anSHTextStyler]) - ifFalse: [^ self]. - - self styleByParagraphs ifFalse: [ - ^super formatAndStyleIfNeededWith: anSHTextStyler ]. - - actualContents _ actualContents optimizedForMutationSpeed. - anSHTextStyler formatWorkspace: actualContents. - separator _ String newLineString, String newLineString. - fragmentStart _ 1. - done _ false. - [done] whileFalse: [ - fragmentEnd _ actualContents - indexOfSubCollection: separator - startingAt: fragmentStart - ifAbsent: [done _ true. actualContents size]. - anSHTextStyler styleWorkspaceFrom: fragmentStart to: fragmentEnd allowEmphasis: self allowStylingWithEmphasis. - fragmentStart _ fragmentEnd+separator size ]. - self changed: #shoutStyled! ! -!InnerTextMorph methodsFor: 'shout' stamp: 'jmv 11/15/2020 14:47:31' prior: 16856215! - stylerStyled - - model allowStylingWithEmphasis ifTrue: [ - self textComposition composeAll ]. - self editor recomputeSelection. - self updateFromTextComposition. - self editor blinkParen. - self scrollSelectionIntoView! ! -!SHTextStylerST80 methodsFor: 'styling' stamp: 'jmv 11/15/2020 09:51:23' prior: 50518137! - formatWorkspace: text - "Do first stage of styling. - Afterwards, call #styleWorkspaceFrom:to: as needed. - Note: classOrMetaClass is assumed to be nil" - - self terminateBackgroundStylingProcess. - formattedText _ text. - self privateFormatAndConvert. - formattedText removeAttributesThat: [ :attribute | attribute isForShout ]. - - parser ifNil: [ parser := SHParserST80 new ]. - parser - workspace: workspace; - classOrMetaClass: nil! ! - -SHTextStylerST80 removeSelector: #styleWorkspaceFrom:to:! - -!methodRemoval: SHTextStylerST80 #styleWorkspaceFrom:to: stamp: 'Install-4456-DisableWorkspaceShoutBoldItalic-JuanVuletich-2020Nov15-14h26m-jmv.001.cs.st 12/30/2020 14:48:19'! -styleWorkspaceFrom: start to: end - "Style a copy of part of the model text. Then apply attributes to model text. Useful for Workspaces. - Call #formatWorkspace: becore calling us. - Note: classOrMetaClass is assumed to be nil. - Note: after last call, do `textModel changed: #shoutStyled`" - - parser - source: (formattedText asString copyFrom: start to: end). - parser parse. - parser ranges ifNotNil: [ :ranges | - ranges do: [ :range | - (self attributesFor: range rangeType) ifNotNil: [ :attributes | - attributes do: [ :each | - formattedText - addAttribute: each - from: range start +start-1 - to: range end +start-1 ]]]].! - -Workspace removeSelector: #allowEmphasis! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4456-DisableWorkspaceShoutBoldItalic-JuanVuletich-2020Nov15-14h26m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4456] on 16 November 2020 at 10:59:06 am'! - -TextModel subclass: #Workspace - instanceVariableNames: 'bindings mustDeclareVariables shouldStyle fullPrintIt ' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Text'! - -!classDefinition: #Workspace category: #'System-Text' stamp: 'Install-4457-Workspace-fullPrintIt-option-JuanVuletich-2020Nov16-10h41m-jmv.001.cs.st 12/30/2020 14:48:19'! -TextModel subclass: #Workspace - instanceVariableNames: 'bindings mustDeclareVariables shouldStyle fullPrintIt' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Text'! -!TextModel methodsFor: 'user interface support' stamp: 'jmv 11/16/2020 10:57:17'! - fullPrintIt - ^true! ! -!Workspace methodsFor: 'user interface support' stamp: 'jmv 11/16/2020 10:48:58' overrides: 50556923! - fullPrintIt - - ^fullPrintIt ifNil: [ Preferences fullPrintItInWorkspaces]! ! -!Workspace methodsFor: 'user interface support' stamp: 'jmv 11/16/2020 10:51:34'! - toggleFullPrintIt - - fullPrintIt _ self fullPrintIt not.! ! -!Workspace methodsFor: 'user interface support' stamp: 'jmv 11/16/2020 10:50:46'! - toggleFullPrintItLabel - - ^self fullPrintIt - ifTrue: [ ' full printIt' ] - ifFalse: [ ' full printIt' ]! ! -!Preferences class methodsFor: 'personalization' stamp: 'jmv 11/16/2020 10:48:24'! - fullPrintItInWorkspaces - ^ self - valueOfFlag: #fullPrintItInWorkspaces - ifAbsent: [false]! ! -!Workspace methodsFor: 'initialization' stamp: 'jmv 11/16/2020 10:41:49' prior: 16945446 overrides: 16933882! - initialize - - super initialize. - self initializeBindings. - mustDeclareVariables _ false. - fullPrintIt _ false.! ! -!SmalltalkEditor methodsFor: 'do-its' stamp: 'jmv 11/16/2020 10:58:25' prior: 16909738! - printIt - "Treat the current text selection as an expression; evaluate it. Insert the - description of the result of evaluation after the selection and then make - this description the new text selection." - | rpt | - self - evaluateSelectionAndDo: [ :result | - rpt _ model fullPrintIt - ifTrue: [result printText] - ifFalse: [result printTextLimitedTo: 10000]. - self afterSelectionInsertAndSelect: - ((' ', rpt, ' ') initialFontFrom: emphasisHere)] - ifFail: [ morph flash ] - profiled: false.! ! -!WorkspaceWindow methodsFor: 'menu' stamp: 'jmv 11/16/2020 10:50:55' prior: 50375065 overrides: 16926415! - addCustomMenuItems: aCustomMenu hand: aHandMorph - super addCustomMenuItems: aCustomMenu hand: aHandMorph. - aCustomMenu addLine. - aCustomMenu - add: 'reset variables' - target: model - action: #initializeBindings. - aCustomMenu - addUpdating: #mustDeclareVariableWording - target: model - action: #toggleVariableDeclarationMode. - aCustomMenu - addUpdating: #toggleStylingLabel - target: model - action: #toggleStyling. - aCustomMenu - addUpdating: #toggleFullPrintItLabel - target: model - action: #toggleFullPrintIt.! ! -!WorkspaceWindow methodsFor: 'menu' stamp: 'jmv 11/16/2020 10:53:20' prior: 50400079 overrides: 16926510! - offerWindowMenu - | aMenu | - aMenu _ self buildWindowMenu. - aMenu addLine. - aMenu - add: 'reset variables' - target: model - action: #initializeBindings - icon: #warningIcon. - aMenu - addUpdating: #mustDeclareVariableWording - target: model - action: #toggleVariableDeclarationMode. - aMenu - addUpdating: #toggleStylingLabel - target: model - action: #toggleStyling. - aMenu - addUpdating: #toggleFullPrintItLabel - target: model - action: #toggleFullPrintIt. - aMenu popUpInWorld: self world! ! - -TextModel subclass: #Workspace - instanceVariableNames: 'bindings mustDeclareVariables shouldStyle fullPrintIt' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Text'! - -!classDefinition: #Workspace category: #'System-Text' stamp: 'Install-4457-Workspace-fullPrintIt-option-JuanVuletich-2020Nov16-10h41m-jmv.001.cs.st 12/30/2020 14:48:19'! -TextModel subclass: #Workspace - instanceVariableNames: 'bindings mustDeclareVariables shouldStyle fullPrintIt' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Text'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4457-Workspace-fullPrintIt-option-JuanVuletich-2020Nov16-10h41m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4451] on 17 November 2020 at 9:25:23 am'! -!Morph methodsFor: 'change reporting' stamp: 'jmv 11/16/2020 23:00:04'! - invalidateDisplayRect: damageRect for: aMorph - " - If we clip submorphs, then we clip damageRect. - - aMorph is the morph that changed and therefore should be redrawn. In some cases, damage reporting is done by no longer occupying some area, and requesting whatever appropriate morph to be drawn there. In such cases, aMorph should be nil. See senders." - - | clippedRect b | - - "warning. Senders are using global coordinates. Redesign!!" - "local now!!!!!!!!!!" - self flag: #jmvVer2. "ok?" - - self visible ifFalse: [ ^self]. - - clippedRect _ damageRect. - self clipsSubmorphs ifTrue: [ - b _ self displayBounds. - b ifNil: [ ^self ]. - clippedRect _ damageRect intersect: b ]. - owner ifNotNil: [ - owner invalidateDisplayRect: clippedRect for: aMorph ]! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 11/16/2020 22:40:52'! - clipsSubmorphs - "Answer true if we clip the shape of our submorphs to our own. - Answer true only when clipping by the canvas is needed. - Morphs that can guarantee that submorphs don't protrude and answer false to - #submorphsMightProtrude should answer false for better performance" - - ^ false! ! -!WorldMorph methodsFor: 'change reporting' stamp: 'jmv 11/16/2020 22:55:54' overrides: 50557041! - invalidateDisplayRect: damageRect for: aMorph - "Clip damage reports to my bounds, since drawing is _always_ clipped to my bounds." - - self recordDamagedRect: (damageRect intersect: self morphLocalBounds ) for: aMorph! ! -!PluggableScrollPane methodsFor: 'geometry testing' stamp: 'jmv 11/16/2020 22:41:33' overrides: 50557067! - clipsSubmorphs - "Answer true if we clip the shape of our submorphs to our own. - Answer true only when clipping by the canvas is needed. - Morphs that can guarantee that submorphs don't protrude and answer false to - #submorphsMightProtrude should answer false for better performance" - - ^ true! ! -!Morph methodsFor: 'change reporting' stamp: 'jmv 11/16/2020 23:00:45' prior: 50538624! - invalidateLocalRect: localRectangle - - self invalidateDisplayRect: (self externalizeDisplayBounds: localRectangle) for: self! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 11/16/2020 23:07:15' prior: 50540888! - displayFullBounds - "Answer a rectangle that completely bounds receiver and submorphs when last drawn - (if the world was to be fully drawn, i.e. only to be used on a Canvas on the full world)." - - | answer | - answer _ self displayBounds. - answer ifNil: [ ^nil ]. - (self submorphsMightProtrude and: [self clipsSubmorphs not]) ifTrue: [ - self submorphsReverseDo: [ :m | - answer _ answer quickMerge: m displayFullBounds ]]. - ^answer! ! -!Morph methodsFor: 'updating' stamp: 'jmv 11/16/2020 23:00:32' prior: 50541270! - invalidateBounds - "Report that the area occupied by this morph should be redrawn, - but most likely we are not going to be redrawn on it, or maybe we'll not be fully visible. See senders." - - self invalidateDisplayRect: self displayBoundsOrBogus for: nil.! ! -!Morph methodsFor: 'updating' stamp: 'jmv 11/16/2020 23:07:38' prior: 50541346! - redrawNeeded - "Report that the area occupied by this morph should be redrawn. - Usually because we changed in some way." - - self needsRedraw: true. - self allOwnersDo: [ :m | m submorphNeedsRedraw: true ]. - self invalidateDisplayRect: self displayBoundsOrBogus for: self. - (self submorphsMightProtrude and: [self clipsSubmorphs not]) ifTrue: [ - self submorphsReverseDo: [ :m | m redrawNeeded ]].! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 11/16/2020 23:00:22' prior: 50540338! -restoreSavedPatchOn: aCanvas - "Clear the changed flag and restore the part of the given canvas under this hand from the previously saved patch. If necessary, handle the transition to using the hardware cursor." - hasChanged _ false. - savedPatch ifNotNil: [ - aCanvas restorePatch: savedPatch. - submorphs notEmpty ifTrue: [ ^ self ]. - "Make the transition to using hardware cursor. Clear savedPatch and - report one final damage rectangle to erase the image of the software cursor." - " owner invalidateDisplayRect: (savedPatch offset extent: savedPatch extent) from: nil." - self invalidateDisplayRect: (self morphPosition extent: extent) for: nil. - Cursor currentCursor == Cursor defaultCursor ifFalse: [ Cursor defaultCursor activateCursor ]. - "show hardware cursor" - savedPatch _ nil ].! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 11/16/2020 23:04:23' prior: 50534101! - drawCurrentAndSubmorphs - - self isCurrentMorphVisible ifTrue: [ - currentMorph drawOn: self. - world notNil ifTrue: [ "Only if we are drawing the world" - currentMorph displayBounds: self boundingRectOfCurrentMorphAfterDraw ]. - "Display submorphs back to front" - "coordinate system stack already set up for aMorph - ('ivars transformations' and 'currentTransformation')" - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | self fullDraw: m ]]].! ! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 11/16/2020 23:03:34' prior: 50533848! - clippingByCurrentMorphDo: aBlock - "Do clipping only if currentMorph says so" - - | prevClipRect prevClippingMorphRect | - - currentMorph clipsSubmorphs ifFalse: [ ^aBlock value ]. - - prevClipRect _ self clipRect. - prevClippingMorphRect _ clippingMorphDisplayBounds. - "Might use the fact that currentMorph has just been drawn." - clippingMorphDisplayBounds _ self boundingRectOfCurrentMorphAfterDraw. - self setClipRect: (prevClipRect intersect: clippingMorphDisplayBounds). - self clippingMorph: currentMorph. - aBlock ensure: [ - self clippingMorph: nil. - self setClipRect: prevClipRect. - clippingMorphDisplayBounds _ prevClippingMorphRect ]! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 11/16/2020 23:04:52' prior: 50555349! - fullAddCurrentRect: addCurrentBounds submorphs: trySubmorphs to: aDamageRecorder - - addCurrentBounds ifTrue: [ - currentMorph needsRedraw: false. - self fullUpdateCurrentBounds. - aDamageRecorder recordInvalidRect: currentMorph displayBounds for: currentMorph ]. - trySubmorphs ifTrue: [ - currentMorph submorphNeedsRedraw: false. - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | - self fullAddRedrawRect: m to: aDamageRecorder ]]].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 11/16/2020 23:05:08' prior: 50536600! - updateCurrentDisplayBounds - "Update displayBounds for if never set. - Useful for new morph, that are created and attached to the hand." - - currentMorph drawOn: self. - currentMorph displayBounds: self boundingRectOfCurrentMorphAfterDraw. - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | self updateDisplayBounds: m ]].! ! - -PluggableScrollPane removeSelector: #clipsLastSubmorph! - -!methodRemoval: PluggableScrollPane #clipsLastSubmorph stamp: 'Install-4458-ClipAllSubmorphsNotJustLast-JuanVuletich-2020Nov17-09h24m-jmv.001.cs.st 12/30/2020 14:48:19'! -clipsLastSubmorph - "Answer true if we clip the shape of our last submorph to ours. - Answer true only when clipping by the canvas is needed." - - ^ true! - -WorldMorph removeSelector: #invalidateDisplayRect:fromSubmorph:for:! - -!methodRemoval: WorldMorph #invalidateDisplayRect:fromSubmorph:for: stamp: 'Install-4458-ClipAllSubmorphsNotJustLast-JuanVuletich-2020Nov17-09h24m-jmv.001.cs.st 12/30/2020 14:48:19'! -invalidateDisplayRect: damageRect fromSubmorph: submorphOrNil for: aMorph - "Clip damage reports to my bounds, since drawing is _always_ clipped to my bounds." - - self recordDamagedRect: (damageRect intersect: self morphLocalBounds ) for: aMorph! - -Morph removeSelector: #clippedSubmorph! - -!methodRemoval: Morph #clippedSubmorph stamp: 'Install-4458-ClipAllSubmorphsNotJustLast-JuanVuletich-2020Nov17-09h24m-jmv.001.cs.st 12/30/2020 14:48:19'! -clippedSubmorph - | i | - ^(self clipsLastSubmorph and: [ - i _ submorphs size. - i ~= 0]) ifTrue: [ - submorphs at: i ]! - -Morph removeSelector: #unclippedSubmorphsReverseDo:! - -!methodRemoval: Morph #unclippedSubmorphsReverseDo: stamp: 'Install-4458-ClipAllSubmorphsNotJustLast-JuanVuletich-2020Nov17-09h24m-jmv.001.cs.st 12/30/2020 14:48:19'! -unclippedSubmorphsReverseDo: aBlock - | lastClippedIndex | - lastClippedIndex _ submorphs size. - self clipsLastSubmorph ifTrue: [ - lastClippedIndex _ lastClippedIndex - 1 ]. - lastClippedIndex to: 1 by: -1 do: [ :index | - aBlock value: (submorphs at: index) ]! - -Morph removeSelector: #clipsLastSubmorph! - -!methodRemoval: Morph #clipsLastSubmorph stamp: 'Install-4458-ClipAllSubmorphsNotJustLast-JuanVuletich-2020Nov17-09h24m-jmv.001.cs.st 12/30/2020 14:48:19'! -clipsLastSubmorph - "Answer true if we clip the shape of our last submorph to ours. - Answer true only when clipping by the canvas is needed." - - ^ false! - -Morph removeSelector: #submorphsDrawingOutsideReverseDo:! - -!methodRemoval: Morph #submorphsDrawingOutsideReverseDo: stamp: 'Install-4458-ClipAllSubmorphsNotJustLast-JuanVuletich-2020Nov17-09h24m-jmv.001.cs.st 12/30/2020 14:48:19'! -submorphsDrawingOutsideReverseDo: aBlock - "Might be redefined in subclasses that know that its submorphs are never outside itself" - - self submorphsMightProtrude ifTrue: [ - self unclippedSubmorphsReverseDo: aBlock ].! - -Morph removeSelector: #invalidateDisplayRect:fromSubmorph:for:! - -!methodRemoval: Morph #invalidateDisplayRect:fromSubmorph:for: stamp: 'Install-4458-ClipAllSubmorphsNotJustLast-JuanVuletich-2020Nov17-09h24m-jmv.001.cs.st 12/30/2020 14:48:19'! -invalidateDisplayRect: damageRect fromSubmorph: submorphOrNil for: aMorph - " - If we clip submorphOrNil, then we clip damageRect. - When calling from self, submorphOrNil should be nil, i.e. we are not reporting damage for some submorph. - - aMorph is the morph that changed and therefore should be redrawn. In some cases, damage reporting is done by no longer occupying some area, and requesting whatever appropriate morph to be drawn there. In such cases, aMorph should be nil. See senders." - - | clippedRect b | - - "warning. Senders are using global coordinates. Redesign!!" - "local now!!!!!!!!!!" - self flag: #jmvVer2. "ok?" - - self visible ifFalse: [ ^self]. - - clippedRect _ damageRect. - submorphOrNil ifNotNil: [ - submorphOrNil == self clippedSubmorph - ifTrue: [ - b _ self displayBounds. - b ifNil: [ ^self ]. - clippedRect _ damageRect intersect: b ]]. - owner ifNotNil: [ - owner invalidateDisplayRect: clippedRect fromSubmorph: self for: aMorph ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4458-ClipAllSubmorphsNotJustLast-JuanVuletich-2020Nov17-09h24m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4453] on 17 November 2020 at 2:53:21 pm'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 11/17/2020 14:51:05'! - clipCurrentMorph: aBoolean! ! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 11/17/2020 14:51:56' prior: 50557199! - clippingByCurrentMorphDo: aBlock - "Do clipping only if currentMorph says so" - - | prevClipRect prevClippingMorphRect | - - currentMorph clipsSubmorphs ifFalse: [ ^aBlock value ]. - - prevClipRect _ self clipRect. - prevClippingMorphRect _ clippingMorphDisplayBounds. - "Might use the fact that currentMorph has just been drawn." - clippingMorphDisplayBounds _ self boundingRectOfCurrentMorphAfterDraw. - self setClipRect: (prevClipRect intersect: clippingMorphDisplayBounds). - self clipCurrentMorph: true. - aBlock ensure: [ - self clipCurrentMorph: false. - self setClipRect: prevClipRect. - clippingMorphDisplayBounds _ prevClippingMorphRect ]! ! - -MorphicCanvas removeSelector: #clippingMorph:! - -!methodRemoval: MorphicCanvas #clippingMorph: stamp: 'Install-4459-clipCurrentMorph-JuanVuletich-2020Nov17-14h51m-jmv.001.cs.st 12/30/2020 14:48:19'! -clippingMorph: aMorph! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4459-clipCurrentMorph-JuanVuletich-2020Nov17-14h51m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4459] on 17 November 2020 at 4:06:36 pm'! -!TranscriptMorph methodsFor: 'geometry testing' stamp: 'jmv 11/17/2020 16:06:01' overrides: 50557067! - clipsSubmorphs - "Answer true if we clip the shape of our submorphs to our own. - Answer true only when clipping by the canvas is needed. - Morphs that can guarantee that submorphs don't protrude and answer false to - #submorphsMightProtrude should answer false for better performance" - - ^ true! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4460-Transcript-fix-JuanVuletich-2020Nov17-16h03m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4460] on 19 November 2020 at 1:16:10 pm'! -!Color class methodsFor: 'color from user' stamp: 'jmv 11/19/2020 11:13:32' prior: 50498336! - colorPaletteForDepth: depth extent: chartExtent - "Display a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." - "Note: It is slow to build this palette, so it should be cached for quick access." - "(Color colorPaletteForDepth: 16 extent: 190@60) display" - - | basicHue x y startHue palette transHt vSteps grayWidth hSteps | - palette _ Form extent: chartExtent depth: depth. - transHt _ FontFamily defaultPointSize * 3//2. - palette fillWhite: (`0@0` extent: palette width@transHt). - palette fillBlack: (0@transHt extent: palette width@1). - 'no color' displayOn: palette at: palette boundingBox topCenter - ((transHt * 2)@0). - grayWidth _ 10. - startHue _ 338.0. - vSteps _ palette height - transHt // 2. - hSteps _ palette width - grayWidth. - x _ 0. - startHue to: startHue + 360.0 by: 360.0/hSteps do: [ :h | - basicHue _ Color h: h asFloat s: 1.0 v: 1.0. - y _ transHt+1. - 0 to: vSteps do: [ :n | | c | - c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Color white. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - 1 to: vSteps do: [ :n | | c | - c _ Color black mixed: (n asFloat / vSteps asFloat) with: basicHue. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - x _ x + 1]. - y _ transHt + 1. - 1 to: vSteps * 2 do: [ :n | | c | - c _ Color black mixed: (n asFloat / (vSteps*2) asFloat) with: Color white. - palette fill: (x@y extent: 10@1) fillColor: c. - y _ y + 1]. - ^ palette -! ! -!Color class methodsFor: 'color from user' stamp: 'jmv 11/19/2020 11:13:56' prior: 50357397! - colorTest: depth extent: chartExtent colorMapper: colorMapper - "Create a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." - "Note: It is slow to build this palette, so it should be cached for quick access." - "(Color colorTest: 32 extent: 570@180 colorMapper: [:c | c]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 7) asInteger / 7 - g: (c green * 7) asInteger / 7 - b: (c blue * 3) asInteger / 3]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 5) asInteger / 5 - g: (c green * 5) asInteger / 5 - b: (c blue * 5) asInteger / 5]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 15) asInteger / 15 - g: (c green * 15) asInteger / 15 - b: (c blue * 15) asInteger / 15]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 31) asInteger / 31 - g: (c green * 31) asInteger / 31 - b: (c blue * 31) asInteger / 31]) display" - - | basicHue x y c startHue palette transHt vSteps grayWidth hSteps | - palette _ Form extent: chartExtent depth: depth. - transHt _ FontFamily defaultPointSize * 3//2. - palette fillWhite: (0@0 extent: palette width@transHt). - palette fillBlack: (0@transHt extent: palette width@1). - 'no color' displayOn: palette at: palette boundingBox topCenter - ((transHt * 2)@0). - grayWidth _ 10. - startHue _ 338.0. - vSteps _ palette height - transHt // 2. - hSteps _ palette width - grayWidth. - x _ 0. - startHue to: startHue + 360.0 by: 360.0/hSteps do: [:h | - basicHue _ Color h: h asFloat s: 1.0 v: 1.0. - y _ transHt+1. - 0 to: vSteps do: [:n | - c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Color white. - c _ colorMapper value: c. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - 1 to: vSteps do: [:n | - c _ Color black mixed: (n asFloat / vSteps asFloat) with: basicHue. - c _ colorMapper value: c. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - x _ x + 1]. - y _ transHt + 1. - 1 to: vSteps * 2 do: [:n | - c _ Color black mixed: (n asFloat / (vSteps*2) asFloat) with: Color white. - c _ colorMapper value: c. - palette fill: (x@y extent: 10@1) fillColor: c. - y _ y + 1]. - ^ palette -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4461-ColorPalette-titleHackRemoval-JuanVuletich-2020Nov19-13h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4460] on 19 November 2020 at 1:17:25 pm'! -!Form methodsFor: 'fileIn/Out' stamp: 'jmv 11/19/2020 11:42:10'! - storeSmall1BitBitsOn: aStream - "Only valid for 1 bit narrow Forms." - - | shift | - shift _ 32 - width. - bits do: [ :word | - "Print binary with radix, but padded, so the bit pattern is easy to see." - aStream newLineTab: 2. - aStream nextPut: $2. - aStream nextPut: $r. - word >> shift printOn: aStream base: 2 length: width padded: true ]! ! -!Form methodsFor: 'fileIn/Out' stamp: 'jmv 11/19/2020 11:40:21'! - storeSmall1BitOn: aStream - "Store the receiver out as an expression that can be evaluated to recreate a Form with the same contents as the original." - aStream nextPut: $(. - aStream nextPutAll: self species name. - aStream newLineTab: 1. - aStream nextPutAll: 'small1BitExtent: '. - self extent printOn: aStream. - aStream newLineTab: 1. - aStream nextPutAll: 'pixelBits: #('. - self storeSmall1BitBitsOn: aStream. - aStream nextPut: $). - aStream newLineTab: 1. - aStream nextPutAll: 'offset: '. - self offset printOn: aStream. - aStream nextPut: $). -! ! -!Form methodsFor: 'private' stamp: 'jmv 11/19/2020 11:03:44'! - fillSmall1BitWith: pixelBits - "Fill a narrow 1 bit Form. - Each value in argument holds pixels (i.e. bits) for one line. - Useful for Cursors and small icons." - - | shift | - self assert: depth = 1. - self assert: width <= 32. "meaning self wordsPerLine = 1." - shift _ 32 - width. - 1 to: (height min: pixelBits size) do: [ :i | - bits at: i put: (pixelBits at: i) << shift ].! ! -!Form class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:53:49'! - small1BitExtent: extentPoint pixelBits: pixelBits - "Answer an instance of me of depth 1 with bitmap initialized from pixelBits. - Requested width can be no more than 32. Result has one 32 bit word per line." - - ^ (self extent: extentPoint depth: 1) - fillSmall1BitWith: pixelBits! ! -!Form class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 11:21:04'! - small1BitExtent: extentPoint pixelBits: pixelBits offset: offsetPoint - "Answer an instance of me of depth 1 with bitmap initialized from pixelBits. - Requested width can be no more than 32. Result has one 32 bit word per line." - - ^ (self extent: extentPoint depth: 1) - offset: offsetPoint; - fillSmall1BitWith: pixelBits! ! -!Form methodsFor: 'fileIn/Out' stamp: 'jmv 11/19/2020 12:34:21' prior: 50521343! - storeOn: aStream base: anInteger - "Store the receiver out as an expression that can be evaluated to recreate a Form with the same contents as the original." - - (depth = 1 and: [ width <= 32 ]) ifTrue: [ - ^self storeSmall1BitOn: aStream ]. - - aStream nextPut: $(. - aStream nextPutAll: self species name. - aStream newLineTab: 1. - aStream nextPutAll: 'extent: '. - self extent printOn: aStream. - aStream newLineTab: 1. - aStream nextPutAll: 'depth: '. - self nativeDepth printOn: aStream. - aStream newLineTab: 1. - aStream nextPutAll: 'fromArray: #('. - self storeBitsOn: aStream base: anInteger. - aStream nextPut: $). - aStream newLineTab: 1. - aStream nextPutAll: 'offset: '. - self offset printOn: aStream. - aStream nextPut: $). -! ! -!CursorWithMask methodsFor: 'mask' stamp: 'jmv 11/19/2020 11:45:59' prior: 16826678 overrides: 50557647! - storeOn: aStream base: anInteger - - aStream nextPut: $(. - super storeOn: aStream base: anInteger. - aStream newLine; nextPutAll: ' setMaskForm: '. - maskForm storeOn: aStream base: anInteger. - aStream nextPut: $)! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4462-OneBPPsmallFormsCreation-JuanVuletich-2020Nov19-13h16m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4460] on 19 November 2020 at 1:23:00 pm'! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:42:18' prior: 50498394! - bottomLeftCursor - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1111111111111100 - 2r1111111111111100 - 2r0000000000000000 - 2r0000000000000000) - offset: `0@-16`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:42:23' prior: 50498403! - bottomRightCursor - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r1111111111111100 - 2r1111111111111100 - 2r0000000000000000 - 2r0000000000000000) - offset: `-16@-16`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:42:28' prior: 50498411! - cornerCursor - "Answer the instance of me that is the shape of the bottom right corner - of a rectangle." - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r1111111111111100 - 2r1111111111111100 - 2r0000000000000000 - 2r0000000000000000) - offset: `-16@-16`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:42:11' prior: 50498422! - crossHairCursor - "Answer the instance of me that is the shape of a cross." - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0000000000000000 - 2r0000000100000000 - 2r0000000100000000 - 2r0000000100000000 - 2r0000000100000000 - 2r0000000100000000 - 2r0000000100000000 - 2r0111111111111100 - 2r0000000100000000 - 2r0000000100000000 - 2r0000000100000000 - 2r0000000100000000 - 2r0000000100000000 - 2r0000000100000000 - 2r0000000000000000 - 2r0000000000000000) - offset: `-7@-7`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:42:48' prior: 50498432! - downCursor - "Answer the instance of me that is the shape of an arrow facing - downward." - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0011000000000000 - 2r0011000000000000 - 2r0011000000000000 - 2r0011000000000000 - 2r0011000000000000 - 2r0011000000000000 - 2r0011000000000000 - 2r1111110000000000 - 2r0111100000000000 - 2r0011000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000) - offset: `0@0`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:43:03' prior: 50498443! - executeCursor - "Answer the instance of me that is the shape of an arrow slanted left - with a star next to it." - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r1000000000100000 - 2r1100000000100000 - 2r1110000001110000 - 2r1111001111111110 - 2r1111100110001100 - 2r1111110010001000 - 2r1111111011111000 - 2r1111000011011000 - 2r1101100110001100 - 2r1001100100000100 - 2r0000110000000000 - 2r0000110000000000 - 2r0000011000000000 - 2r0000011000000000 - 2r0000000000000000 - 2r0000000000000000) - offset: `0@0`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:43:25' prior: 50498475! - markerCursor - "Answer the instance of me that is the shape of a small ball." - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0111000000000000 - 2r1111100000000000 - 2r1111100000000000 - 2r0111000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000) - offset: `0@0`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:43:43' prior: 50498484! - menuCursor - "Answer the instance of me that is the shape of a menu." - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r1111111111100000 - 2r1000000000100000 - 2r1010011000100000 - 2r1000000000100000 - 2r1101001101100000 - 2r1111111111100000 - 2r1000000000100000 - 2r1011001010100000 - 2r1000000000100000 - 2r1010110010100000 - 2r1000000000100000 - 2r1010010100100000 - 2r1000000000100000 - 2r1111111111100000 - 2r0000000000000000 - 2r1111111111100000) - offset: `0@0`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:44:13' prior: 50498494! - moveCursor - "Answer the instance of me that is the shape of a cross inside a square." - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r1111111111111100 - 2r1111111111111100 - 2r1100001100001100 - 2r1100001100001100 - 2r1100001100001100 - 2r1100001100001100 - 2r1111111111111100 - 2r1111111111111100 - 2r1100001100001100 - 2r1100001100001100 - 2r1100001100001100 - 2r1100001100001100 - 2r1111111111111100 - 2r1111111111111100 - 2r0000000000000000 - 2r0000000000000000) - offset: `0@0`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:45:16' prior: 50498505 overrides: 16783533! -new - - ^ self extent: `16 @ 16`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:45:39' prior: 50498512! - normalCursor - "Answer the instance of me that is the shape of an arrow slanted left." - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r1000000000000000 - 2r1100000000000000 - 2r1110000000000000 - 2r1111000000000000 - 2r1111100000000000 - 2r1111110000000000 - 2r1111111000000000 - 2r1111100000000000 - 2r1111100000000000 - 2r1001100000000000 - 2r0000110000000000 - 2r0000110000000000 - 2r0000011000000000 - 2r0000011000000000 - 2r0000001100000000 - 2r0000001100000000) - offset: `0@0`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:38:05' prior: 50498523! - normalCursorWithMask - "Cursor initNormalWithMask. Cursor normal show" - "Next two lines work simply for any cursor..." - " - self initNormal. - NormalCursor _ CursorWithMask derivedFrom: NormalCursor. - " - "But for a good looking cursor, you have to tweak things..." - ^ ((CursorWithMask - small1BitExtent: `16@16` - pixelBits: #( - 2r0000000000000000 - 2r0100000000000000 - 2r0110000000000000 - 2r0111000000000000 - 2r0111100000000000 - 2r0111110000000000 - 2r0111111000000000 - 2r0111111100000000 - 2r0111111110000000 - 2r0111110000000000 - 2r0110110000000000 - 2r0100011000000000 - 2r0000011000000000 - 2r0000001100000000 - 2r0000001100000000 - 2r0000000000000000) - offset: `-1@-1`) - setMaskForm: - (Form - small1BitExtent: `16@16` - pixelBits: #( - 2r1100000000000000 - 2r1110000000000000 - 2r1111000000000000 - 2r1111100000000000 - 2r1111110000000000 - 2r1111111000000000 - 2r1111111100000000 - 2r1111111110000000 - 2r1111111111000000 - 2r1111111111100000 - 2r1111111000000000 - 2r1110111100000000 - 2r1100111100000000 - 2r1000011110000000 - 2r0000011110000000 - 2r0000001110000000) - offset: `0@0`))! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:46:00' prior: 50498550! - originCursor - "Answer the instance of me that is the shape of the top left corner of a rectangle." - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r1111111111111100 - 2r1111111111111100 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r0000000000000000 - 2r0000000000000000) - offset: `0@0`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:46:26' prior: 50498561! - readCursor - "Answer the instance of me that is the shape of eyeglasses." - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0000000000000000 - 2r0000000000000000 - 2r0001000000001000 - 2r0010100000010100 - 2r0100000000100000 - 2r1111101111100000 - 2r1000010000100000 - 2r1000010000100000 - 2r1011010110100000 - 2r0111101111000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000) - offset: `0@0`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:48:25' prior: 50498571! - resizeLeftCursor - ^ (Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0000000000000000 - 2r0000010010000000 - 2r0000010010000000 - 2r0000010010000000 - 2r0001010010100000 - 2r0011010010110000 - 2r0111010010111000 - 2r1111110011111100 - 2r0111010010111000 - 2r0011010010110000 - 2r0001010010100000 - 2r0000010010000000 - 2r0000010010000000 - 2r0000010010000000 - 2r0000000000000000 - 2r0000000000000000) - offset: `-7@-7`) withMask.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:48:48' prior: 50498580! - resizeTopCursor - ^ (Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0000000100000000 - 2r0000001110000000 - 2r0000011111000000 - 2r0000111111100000 - 2r0000000100000000 - 2r0111111111111100 - 2r0000000000000000 - 2r0000000000000000 - 2r0111111111111100 - 2r0000000100000000 - 2r0000111111100000 - 2r0000011111000000 - 2r0000001110000000 - 2r0000000100000000 - 2r0000000000000000 - 2r0000000100000000) - offset: `-7@-7`) withMask.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:49:16' prior: 50498588! - resizeTopLeftCursor - ^ (Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0000000000000000 - 2r0111110000010000 - 2r0111100000100000 - 2r0111000001000100 - 2r0110100010001000 - 2r0100010100010000 - 2r0000001000100000 - 2r0000010001000000 - 2r0000100010000000 - 2r0001000101000100 - 2r0010001000101100 - 2r0000010000011100 - 2r0000100000111100 - 2r0000000001111100 - 2r0000000000000000 - 2r0000000000000000) - offset: `-7@-7`) withMask.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:49:34' prior: 50498597! - resizeTopRightCursor - ^ (Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0000000000000000 - 2r0001000001111100 - 2r0000100000111100 - 2r0100010000011100 - 2r0010001000101100 - 2r0001000101000100 - 2r0000100010000000 - 2r0000010001000000 - 2r0000001000100000 - 2r0100010100010000 - 2r0110100010001000 - 2r0111000001000000 - 2r0111100000100000 - 2r0111110000000000 - 2r0000000000000000 - 2r0000000000000000) - offset: `-7@-7`) withMask.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:49:59' prior: 50498606! - rightArrowCursor - "Answer the instance of me that is the shape of an arrow pointing to the right." - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0000011000000000 - 2r0000011110000000 - 2r0000011111100000 - 2r1111111111111000 - 2r0000011111100000 - 2r0000011110000000 - 2r0000011000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000) - offset: `0@0`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:50:16' prior: 50498616! - squareCursor - "Answer the instance of me that is the shape of a square." - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000001111000000 - 2r0000001111000000 - 2r0000001111000000 - 2r0000001111000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000) - offset: `-8@-8`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:50:33' prior: 50498625! - targetCursor - "Answer the instance of me that is the shape of a gunsight." - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0000011111000000 - 2r0001100100110000 - 2r0010000100001000 - 2r0100000100000100 - 2r0100001110000100 - 2r1000000100000010 - 2r1000100100100010 - 2r1111111011111110 - 2r1000100100100010 - 2r1000000100000010 - 2r0100001110000100 - 2r0100000100000100 - 2r0010000100001000 - 2r0001100100110000 - 2r0000011111000000 - 2r0000000000000000) - offset: `-7@-7`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:50:50' prior: 50498636! - topLeftCursor - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r1111111111111100 - 2r1111111111111100 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r1100000000000000 - 2r0000000000000000 - 2r0000000000000000) - offset: `0@0`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:51:05' prior: 50498645! - topRightCursor - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r1111111111111100 - 2r1111111111111100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000001100 - 2r0000000000000000 - 2r0000000000000000) - offset: `-16@0`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:51:20' prior: 50498653! - upCursor - "Answer the instance of me that is the shape of an arrow facing upward." - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0011000000000000 - 2r0111100000000000 - 2r1111110000000000 - 2r0011000000000000 - 2r0011000000000000 - 2r0011000000000000 - 2r0011000000000000 - 2r0011000000000000 - 2r0011000000000000 - 2r0011000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000) - offset: `0@0`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:51:35' prior: 50498663! - waitCursor - "Answer the instance of me that is the shape of an Hourglass (was in the - shape of three small balls)." - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r1111111111111100 - 2r1000000000000100 - 2r0100000000001000 - 2r0010000000010000 - 2r0001110011100000 - 2r0000111111000000 - 2r0000011110000000 - 2r0000011110000000 - 2r0000100101000000 - 2r0001000100100000 - 2r0010000110010000 - 2r0100001111001000 - 2r1000111111110100 - 2r1111111111111100 - 2r0000000000000000 - 2r1111111111111100) - offset: `0@0`! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:52:17' prior: 50498675! - webLinkCursor - "Return a cursor that can be used for emphasizing web links" - ^ (CursorWithMask - small1BitExtent: `16@16` - pixelBits: #( - 2r0000110000000000 - 2r0001001000000000 - 2r0001001000000000 - 2r0001001000000000 - 2r0001001000000000 - 2r0001001110110110 - 2r0001001001001001 - 2r0111001001001001 - 2r1001001001001001 - 2r1001001001001001 - 2r1000000000000001 - 2r1000000000000001 - 2r1100000000000011 - 2r0100000000000010 - 2r0110000000000110 - 2r0011111111111100) - offset: `-5@0`) - setMaskForm: (Form - small1BitExtent: `16@16` - pixelBits: #( - 2r0000110000000000 - 2r0001111000000000 - 2r0001111000000000 - 2r0001111000000000 - 2r0001111000000000 - 2r0001111110110110 - 2r0001111111111111 - 2r0111111111111111 - 2r1111111111111111 - 2r1111111111111111 - 2r1111111111111111 - 2r1111111111111111 - 2r1111111111111111 - 2r0111111111111110 - 2r0111111111111110 - 2r0011111111111100) - offset: `0@0`)! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:52:33' prior: 50498693! - writeCursor - "Answer the instance of me that is the shape of a pen writing." - ^ Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0000000000011000 - 2r0000000000111100 - 2r0000000001001000 - 2r0000000010010000 - 2r0000000100100000 - 2r0000001001000100 - 2r0000010010000100 - 2r0000100100001100 - 2r0001001000010000 - 2r0010010000010000 - 2r0111100000001000 - 2r0101000011111000 - 2r1110000110000000 - 2r0111111100000000 - 2r0000000000000000 - 2r0000000000000000) - offset: `0@0`! ! -!MenuItemMorph class methodsFor: 'cached state access' stamp: 'jmv 11/19/2020 12:54:04' prior: 50385309! - subMenuMarker - - | f | - SubMenuMarker ifNotNil: [ ^SubMenuMarker ]. - f _ Form - small1BitExtent: `5@9` - pixelBits: #( - 2r10000 - 2r11000 - 2r11100 - 2r11110 - 2r11111 - 2r11110 - 2r11100 - 2r11000 - 2r10000). - SubMenuMarker _ ColorForm mappingWhiteToTransparentFrom: f. - ^SubMenuMarker! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4463-CursorAndSmallFormsCreation-JuanVuletich-2020Nov19-13h17m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4463] on 19 November 2020 at 1:56:46 pm'! -!Form methodsFor: 'private' stamp: 'jmv 11/19/2020 13:55:50' prior: 16848775! - initFromArray: array - "Fill the bitmap from array. If the array is shorter, - then cycle around in its contents until the bitmap is filled." - | ax aSize | - ax _ 0. - aSize _ array size. - 1 to: bits size do: [ :index | - (ax _ ax + 1) > aSize ifTrue: [ax _ 1]. - bits at: index put: (array at: ax)]! ! -!Form class methodsFor: 'instance creation' stamp: 'jmv 11/19/2020 12:57:50' prior: 16848949! - extent: extentPoint depth: bitsPerPixel fromArray: anArray offset: offsetPoint - "Answer an instance of me with a pixmap of the given depth initialized from anArray." - "See Form >> storeOn:base:" - - ^ (self extent: extentPoint depth: bitsPerPixel) - offset: offsetPoint; - initFromArray: anArray -! ! - -Cursor class removeSelector: #extent:fromArray:offset:! - -!methodRemoval: Cursor class #extent:fromArray:offset: stamp: 'Install-4464-FormCreationCleanup-JuanVuletich-2020Nov19-13h37m-jmv.001.cs.st 12/30/2020 14:48:19'! -extent: extentPoint fromArray: anArray offset: offsetPoint - "Answer a new instance of me with width and height specified by - extentPoint, offset by offsetPoint, and bits from anArray. - NOTE: This has been kluged to take an array of 16-bit constants, - and shift them over so they are left-justified in a 32-bit bitmap" - - extentPoint = (`16 @ 16`) - ifTrue: - [^ super - extent: extentPoint - fromArray: (anArray collect: [:bits | bits bitShift: 16]) - offset: offsetPoint] - ifFalse: [self error: 'cursors must be 16@16']! - -Form class removeSelector: #extent:fromArray:offset:! - -!methodRemoval: Form class #extent:fromArray:offset: stamp: 'Install-4464-FormCreationCleanup-JuanVuletich-2020Nov19-13h37m-jmv.001.cs.st 12/30/2020 14:48:19'! -extent: extentPoint fromArray: anArray offset: offsetPoint - "Answer an instance of me of depth 1 with bitmap initialized from anArray." - - ^ (self extent: extentPoint depth: 1) - offset: offsetPoint; - initFromArray: anArray -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4464-FormCreationCleanup-JuanVuletich-2020Nov19-13h37m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4464] on 19 November 2020 at 4:53:48 pm'! -!HaloMorph methodsFor: 'handles' stamp: 'jmv 11/19/2020 16:39:17'! - addResizeHandle: haloSpec - - (self addHandle: haloSpec) - mouseDownSelector: #startResize:with:; - mouseMoveSelector: #doResize:with:! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/19/2020 16:44:22'! - doResize: evt with: resizeHandle - "Called while the mouse is down in the grow handle" - - | newExtent | -self revisar. - self flag: #jmvVer2. - evt hand obtainHalo: self. -"Como podria andar el resize de un morph embebido en otro? andara ahora?" -newExtent _ evt eventPosition - positionOffset - target morphPositionInWorld. - evt shiftPressed ifTrue: [newExtent _ (newExtent x max: newExtent y) asPoint]. - (newExtent x = 0 or: [newExtent y = 0]) ifTrue: [^ self]. - target morphExtentInWorld: newExtent. - resizeHandle morphPositionInWorld: evt eventPosition - (resizeHandle morphExtent // 2)! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/19/2020 16:47:00'! - startResize: evt with: resizeHandle - "Initialize resizing of my target." - - | botRt | - evt hand obtainHalo: self. "Make sure the event's hand correlates with the receiver" - self removeAllHandlesBut: resizeHandle. "remove all other handles" - botRt _ target morphPositionInWorld + target morphExtentInWorld. - positionOffset _ (self world viewBox containsPoint: botRt) - ifTrue: [evt eventPosition - botRt] - ifFalse: [`0@0`]! ! -!HaloMorph class methodsFor: 'accessing - icons' stamp: 'jmv 11/19/2020 16:40:22'! - haloResizeIcon - - ^ self icons - at: #haloResizeIcon - ifAbsentPut: [ Theme current haloResizeIcon ]! ! -!Theme methodsFor: 'icons' stamp: 'jmv 11/19/2020 16:49:17'! - haloResizeIcon - - ^ Form - small1BitExtent: 16@16 - pixelBits: #( - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000111111010000 - 2r0000100001010000 - 2r0000100001010000 - 2r0000100001010000 - 2r0000100001010000 - 2r0000111111010000 - 2r0000000000010000 - 2r0000111111110000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000 - 2r0000000000000000) - offset: 0@0! ! -!Preferences class methodsFor: 'halos' stamp: 'jmv 11/19/2020 16:40:31' prior: 50536888! - iconicHaloSpecifications - "Answer an array that characterizes the locations, colors, icons, and selectors of the halo handles that may be used in the iconic halo scheme" - - " - Preferences resetHaloSpecifications - " - -^ #( - "selector horiz vert color info icon key balloon help - --------- ------ ----------- -------------------------- -------------------------- ---------------" - (addCollapseHandle: left topCenter (tan) haloCollapseIcon 'Collapse') - (addDebugHandle: right topCenter (orange) haloDebugIcon 'Debug') - (addDismissHandle: left top (red) haloDismissIcon 'Remove') - (addRotateHandle: left bottom (blue) haloRotateIcon 'Rotate') - (addMenuHandle: leftCenter top (blue lighter) haloMenuIcon 'Menu') - (addGrabHandle: center top (black) haloGrabIcon 'Pick up') - (addDragHandle: rightCenter top (brown) haloDragIcon 'Move') - (addDupHandle: right top (green) haloDuplicateIcon 'Duplicate') - (addHelpHandle: center bottom (lightBlue) haloHelpIcon 'Help') - (addResizeHandle: right bottom (yellow) haloResizeIcon 'Change size') - (addFontSizeHandle: leftCenter bottom (lightGreen) haloFontSizeIcon 'Change font') - (addFontEmphHandle: rightCenter bottom (lightBrown darker) haloFontEmphasisIcon 'Emphasis & alignment') - "FIXME - Currently non-functional... - (addRecolorHandle: right bottomCenter (magenta darker) haloColorIcon 'Change color') - " -)! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 11/19/2020 16:39:54' prior: 50537022! - wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph - "Answer whether the receiver would like to offer the halo handle with the given selector (e.g. #addCollapseHandle:)" - - (#(addRecolorHandle:) statePointsTo: aSelector) - ifTrue: ["FIXME - hack to disable for non-functional halo items" - ^ false]. - - Preferences selectiveHalos ifFalse: [ - ^true ]. - - (#(#addDismissHandle: ) includes: aSelector) - ifTrue: [ ^ self resistsRemoval not ]. - (#(#addDragHandle: ) includes: aSelector) - ifTrue: [ ^ self okayToBrownDragEasily ]. - (#(#addResizeHandle: ) includes: aSelector) - ifTrue: [ ^ self okayToResizeEasily ]. - (#(#addRotateHandle: ) includes: aSelector) - ifTrue: [ ^ self okayToRotateEasily ]. - (#(#addRecolorHandle: ) includes: aSelector) - ifTrue: [ ^ self wantsRecolorHandle ]. - ^ true! ! - -Theme removeSelector: #haloScaleIcon! - -!methodRemoval: Theme #haloScaleIcon stamp: 'Install-4465-ResizeNotGrowOrScale-JuanVuletich-2020Nov19-16h38m-jmv.001.cs.st 12/30/2020 14:48:19'! -haloScaleIcon - - ^ self fetch: #( '16x16' 'smalltalk' 'halo-scale' ) -! - -HaloMorph class removeSelector: #haloScaleIcon! - -!methodRemoval: HaloMorph class #haloScaleIcon stamp: 'Install-4465-ResizeNotGrowOrScale-JuanVuletich-2020Nov19-16h38m-jmv.001.cs.st 12/30/2020 14:48:19'! -haloScaleIcon - - ^ self icons - at: #haloScaleIcon - ifAbsentPut: [ Theme current haloScaleIcon ]! - -HaloMorph removeSelector: #doGrow:with:! - -!methodRemoval: HaloMorph #doGrow:with: stamp: 'Install-4465-ResizeNotGrowOrScale-JuanVuletich-2020Nov19-16h38m-jmv.001.cs.st 12/30/2020 14:48:19'! -doGrow: evt with: growHandle - "Called while the mouse is down in the grow handle" - - | newExtent | -self revisar. - self flag: #jmvVer2. - evt hand obtainHalo: self. -"Como podria andar el grow de un morph embebido en otro? andara ahora?" -newExtent _ evt eventPosition - positionOffset - target morphPositionInWorld. - evt shiftPressed ifTrue: [newExtent _ (newExtent x max: newExtent y) asPoint]. - (newExtent x = 0 or: [newExtent y = 0]) ifTrue: [^ self]. - target morphExtentInWorld: newExtent. - growHandle morphPositionInWorld: evt eventPosition - (growHandle morphExtent // 2)! - -HaloMorph removeSelector: #addGrowHandle:! - -!methodRemoval: HaloMorph #addGrowHandle: stamp: 'Install-4465-ResizeNotGrowOrScale-JuanVuletich-2020Nov19-16h38m-jmv.001.cs.st 12/30/2020 14:48:19'! -addGrowHandle: haloSpec - - (self addHandle: haloSpec) - mouseDownSelector: #startGrow:with:; - mouseMoveSelector: #doGrow:with:! - -HaloMorph removeSelector: #startGrow:with:! - -!methodRemoval: HaloMorph #startGrow:with: stamp: 'Install-4465-ResizeNotGrowOrScale-JuanVuletich-2020Nov19-16h38m-jmv.001.cs.st 12/30/2020 14:48:19'! -startGrow: evt with: growHandle - "Initialize resizing of my target. Launch a command representing it, to support Undo" - - | botRt | - evt hand obtainHalo: self. "Make sure the event's hand correlates with the receiver" - self removeAllHandlesBut: growHandle. "remove all other handles" - botRt _ target morphPositionInWorld + target morphExtentInWorld. - positionOffset _ (self world viewBox containsPoint: botRt) - ifTrue: [evt eventPosition - botRt] - ifFalse: [`0@0`]! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - -Preferences resetHaloSpecifications! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4465-ResizeNotGrowOrScale-JuanVuletich-2020Nov19-16h38m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4464] on 19 November 2020 at 4:57:02 pm'! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/18/2020 16:41:51' prior: 50545120! - doRot: evt with: rotHandle - "Update the rotation of my target if it is rotatable." - - | radians | - evt hand obtainHalo: self. - radians _ (evt eventPosition - target referencePosition) theta. - radians _ radians - angleOffset theta. - "degrees _ degrees detentBy: 10.0 atMultiplesOf: 90.0 snap: false." - radians = 0.0 - ifTrue: [rotHandle color: `Color lightBlue`] - ifFalse: [rotHandle color: `Color blue`]. - rotHandle submorphsDo: - [:m | m color: rotHandle color makeForegroundColor]. - self removeAllHandlesBut: rotHandle. - target rotation: radians. - rotHandle morphPositionInWorld: evt eventPosition - (rotHandle morphExtent // 2)! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/18/2020 16:45:01' prior: 50554723! - startRot: evt with: rotHandle - "Initialize rotation of my target if it is rotatable." - - evt hand obtainHalo: self. "Make sure the event's hand correlates with the receiver" - growingOrRotating _ true. - - self removeAllHandlesBut: rotHandle. "remove all other handles" - angleOffset _ evt eventPosition - target referencePosition. - angleOffset _ Point - r: angleOffset r - degrees: angleOffset degrees - target rotationDegrees.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4466-RotationHandleCleanup-JuanVuletich-2020Nov19-16h53m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4466] on 19 November 2020 at 5:26:30 pm'! -!AffineTransformation methodsFor: 'modifying' stamp: 'jmv 11/18/2020 16:51:10'! - withScale: scale - "Set scaling according to parameters. - Answer the modified object. In this implementation this requires the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself, - as if the receiver is already an AffineTransformation." - - self scaledBy: scale / self scale! ! -!MorphicTranslation methodsFor: 'modifying' stamp: 'jmv 11/18/2020 17:00:28'! - withScale: scale - "Set scaling according to parameters. - Answer the modified object. In this implementation this requires the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself, - as if the receiver is already an AffineTransformation." - - ^self scaledBy: scale! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 11/18/2020 16:54:07'! - scale: scale - "Change the scale of this morph. Arguments are an angle and a scale." - location _ location withScale: scale. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!HaloMorph methodsFor: 'handles' stamp: 'jmv 11/19/2020 17:06:08'! - addScaleHandle: haloSpec - - (self addHandle: haloSpec) - mouseDownSelector: #startScale:with:; - mouseMoveSelector: #doScale:with:! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/19/2020 17:10:02'! - doScale: evt with: scaleHandle - "Update the scale of my target if it is scalable." - - | scale | - evt hand obtainHalo: self. - scale _ (evt eventPosition - target referencePosition) rho * scaleOffset. - scale = 1.0 - ifTrue: [scaleHandle color: `Color lightBlue`] - ifFalse: [scaleHandle color: `Color blue`]. - scaleHandle submorphsDo: - [:m | m color: scaleHandle color makeForegroundColor]. - self removeAllHandlesBut: scaleHandle. - target scale: scale. - scaleHandle morphPositionInWorld: evt eventPosition - (scaleHandle morphExtent // 2)! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/19/2020 17:10:27'! - startScale: evt with: scaleHandle - "Initialize scale of my target if it is scalable." - - evt hand obtainHalo: self. "Make sure the event's hand correlates with the receiver" - growingOrRotating _ true. - - self removeAllHandlesBut: scaleHandle. "remove all other handles" - scaleOffset _ target scale / (evt eventPosition - target referencePosition) rho. - -! ! -!HaloMorph class methodsFor: 'accessing - icons' stamp: 'jmv 11/19/2020 17:10:59'! - haloScaleIcon - - ^ self icons - at: #haloScaleIcon - ifAbsentPut: [ Theme current haloScaleIcon ]! ! -!Theme methodsFor: 'icons' stamp: 'jmv 11/19/2020 17:21:02'! - haloScaleIcon - - ^ Form - small1BitExtent: 16@16 - pixelBits: #( - 2r0000000000000000 - 2r0000000000000000 - 2r0000111110000000 - 2r0001000001000000 - 2r0010001000100000 - 2r0010001000100000 - 2r0010111110100000 - 2r0010001000100000 - 2r0010001000100000 - 2r0001000001100000 - 2r0000111110010000 - 2r0000000000001000 - 2r0000000000000100 - 2r0000000000000010 - 2r0000000000000000 - 2r0000000000000000) - offset: 0@0! ! -!Preferences class methodsFor: 'halos' stamp: 'jmv 11/19/2020 17:13:26' prior: 50558367! - iconicHaloSpecifications - "Answer an array that characterizes the locations, colors, icons, and selectors of the halo handles that may be used in the iconic halo scheme" - - " - Preferences resetHaloSpecifications - " - -^ #( - "selector horiz vert color info icon key balloon help - --------- ------ ----------- -------------------------- -------------------------- ---------------" - (addCollapseHandle: left topCenter (tan) haloCollapseIcon 'Collapse') - (addDebugHandle: right topCenter (orange) haloDebugIcon 'Debug') - (addDismissHandle: left top (red) haloDismissIcon 'Remove') - (addRotateHandle: left bottom (blue) haloRotateIcon 'Rotate') - (addMenuHandle: leftCenter top (blue lighter) haloMenuIcon 'Menu') - (addGrabHandle: center top (black) haloGrabIcon 'Pick up') - (addDragHandle: rightCenter top (brown) haloDragIcon 'Move') - (addDupHandle: right top (green) haloDuplicateIcon 'Duplicate') - (addHelpHandle: center bottom (lightBlue) haloHelpIcon 'Help') - (addResizeHandle: right bottom (yellow) haloResizeIcon 'Change size') - (addScaleHandle: right center (blue) haloScaleIcon 'Change scale') - (addFontSizeHandle: leftCenter bottom (lightGreen) haloFontSizeIcon 'Change font') - (addFontEmphHandle: rightCenter bottom (lightBrown darker) haloFontEmphasisIcon 'Emphasis & alignment') - "FIXME - Currently non-functional... - (addRecolorHandle: right bottomCenter (magenta darker) haloColorIcon 'Change color') - " -)! ! -!AffineTransformation methodsFor: 'modifying' stamp: 'jmv 11/18/2020 16:47:32' prior: 16778647! - scaledBy: aPointOrNumber - "Multiply by a scale. - Argument can be a point, applying different scaling in x and in y directions. - Keep the transformed position of 0@0, i.e. don't change offset. - - Answer the modified object. In this implementation is self, but some classes of transformations, - more restricted ones (like MorphicTranslation) could require the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself." - - | pt sx sy | - pt _ aPointOrNumber asPoint. - sx _ pt x. - sy _ pt y. - self a11: self a11 * sx. - self a12: self a12 * sx. - self a21: self a21 * sy. - self a22: self a22 * sy. - ^ self! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - -Preferences resetHaloSpecifications! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4467-ScaleHandle-JuanVuletich-2020Nov19-17h19m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4466] on 19 November 2020 at 5:27:20 pm'! - -KernelMorph subclass: #HaloMorph - instanceVariableNames: 'target positionOffset angleOffset growingOrRotating haloBox scaleOffset ' - classVariableNames: 'Icons ' - poolDictionaries: '' - category: 'Morphic-Halos'! - -!classDefinition: #HaloMorph category: #'Morphic-Halos' stamp: 'Install-4468-HaloMorph-cleanup-JuanVuletich-2020Nov19-17h26m-jmv.001.cs.st 12/30/2020 14:48:20'! -KernelMorph subclass: #HaloMorph - instanceVariableNames: 'target positionOffset angleOffset growingOrRotating haloBox scaleOffset' - classVariableNames: 'Icons' - poolDictionaries: '' - category: 'Morphic-Halos'! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/19/2020 17:26:35' prior: 50544323! - addHandles - - self removeAllMorphs. "remove old handles, if any" - target displayBoundsForHalo ifNotNil: [ :r | - self morphBounds: r. "update my size" - haloBox _ self basicBox. - target addHandlesTo: self box: haloBox. - self addNameString: (target printStringLimitedTo: 40). - self redrawNeeded ].! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/19/2020 17:26:45' prior: 50558563! - startRot: evt with: rotHandle - "Initialize rotation of my target if it is rotatable." - - evt hand obtainHalo: self. "Make sure the event's hand correlates with the receiver" - - self removeAllHandlesBut: rotHandle. "remove all other handles" - angleOffset _ evt eventPosition - target referencePosition. - angleOffset _ Point - r: angleOffset r - degrees: angleOffset degrees - target rotationDegrees.! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/19/2020 17:26:50' prior: 50558651! - startScale: evt with: scaleHandle - "Initialize scale of my target if it is scalable." - - evt hand obtainHalo: self. "Make sure the event's hand correlates with the receiver" - - self removeAllHandlesBut: scaleHandle. "remove all other handles" - scaleOffset _ target scale / (evt eventPosition - target referencePosition) rho. - -! ! - -HaloMorph removeSelector: #initialize! - -!methodRemoval: HaloMorph #initialize stamp: 'Install-4468-HaloMorph-cleanup-JuanVuletich-2020Nov19-17h26m-jmv.001.cs.st 12/30/2020 14:48:20'! -initialize - "initialize the state of the receiver" - super initialize. - "" - growingOrRotating _ false! - -KernelMorph subclass: #HaloMorph - instanceVariableNames: 'target positionOffset angleOffset scaleOffset haloBox' - classVariableNames: 'Icons' - poolDictionaries: '' - category: 'Morphic-Halos'! - -!classDefinition: #HaloMorph category: #'Morphic-Halos' stamp: 'Install-4468-HaloMorph-cleanup-JuanVuletich-2020Nov19-17h26m-jmv.001.cs.st 12/30/2020 14:48:20'! -KernelMorph subclass: #HaloMorph - instanceVariableNames: 'target positionOffset angleOffset scaleOffset haloBox' - classVariableNames: 'Icons' - poolDictionaries: '' - category: 'Morphic-Halos'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4468-HaloMorph-cleanup-JuanVuletich-2020Nov19-17h26m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4468] on 20 November 2020 at 10:22:22 am'! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 11/20/2020 09:53:28'! - hasOwnLocation - ^false! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 11/20/2020 09:54:41'! - hasVariableExtent - ^false! ! -!MovableMorph methodsFor: 'geometry testing' stamp: 'jmv 11/20/2020 09:53:46' overrides: 50558882! -hasOwnLocation - ^true! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 11/20/2020 10:20:34' overrides: 50554319! - referencePosition - "Return the current reference position of the receiver" - "a rather ugly way to say #center . At least, we avoid false polymorphism" - "remove some day" - self flag: #jmvVer2. - ^self morphExtentInWorld // 2 + self morphPositionInWorld! ! -!WidgetMorph methodsFor: 'geometry testing' stamp: 'jmv 11/20/2020 09:54:52' overrides: 50558886! -hasVariableExtent - ^true! ! -!Preferences class methodsFor: 'halos' stamp: 'jmv 11/20/2020 10:02:58' prior: 50558688! - iconicHaloSpecifications - "Answer an array that characterizes the locations, colors, icons, and selectors of the halo handles that may be used in the iconic halo scheme" - - " - Preferences resetHaloSpecifications - " - -^ #( - "selector horiz vert color info icon key balloon help - --------- ------ ----------- -------------------------- -------------------------- ---------------" - (addCollapseHandle: left topCenter (tan) haloCollapseIcon 'Collapse') - (addDebugHandle: right topCenter (orange) haloDebugIcon 'Debug') - (addDismissHandle: left top (red) haloDismissIcon 'Remove') - (addRotateHandle: left bottom (blue) haloRotateIcon 'Rotate') - (addMenuHandle: leftCenter top (blue lighter) haloMenuIcon 'Menu') - (addGrabHandle: center top (black) haloGrabIcon 'Pick up') - (addDragHandle: rightCenter top (brown) haloDragIcon 'Move') - (addDupHandle: right top (green) haloDuplicateIcon 'Duplicate') - (addHelpHandle: center bottom (lightBlue) haloHelpIcon 'Help') - (addResizeHandle: right bottom (yellow) haloResizeIcon 'Change size') - (addScaleHandle: right bottom (blue) haloScaleIcon 'Change scale') - (addFontSizeHandle: leftCenter bottom (lightGreen) haloFontSizeIcon 'Change font') - (addFontEmphHandle: rightCenter bottom (lightBrown darker) haloFontEmphasisIcon 'Emphasis & alignment') - "FIXME - Currently non-functional... - (addRecolorHandle: right bottomCenter (magenta darker) haloColorIcon 'Change color') - " -)! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 11/20/2020 09:57:32' prior: 50384193! - morphExtent - "In our own coordinates!!" -"Quizas eventualmente borrar este tambien? (no se usa mucho...)" - self flag: #jmvVer2. - ^`150 @ 140`! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 11/20/2020 10:20:45' prior: 50554319 overrides: 50554626! - referencePosition - "Return the current reference position of the receiver" - "a rather ugly way to say #center . At least, we avoid false polymorphism" - "remove some day" - self flag: #jmvVer2. - ^self morphPositionInWorld! ! -!HaloMorph methodsFor: 'handles' stamp: 'jmv 11/20/2020 09:56:12' prior: 50558300! - addResizeHandle: haloSpec - - target hasVariableExtent ifTrue: [ - (self addHandle: haloSpec) - mouseDownSelector: #startResize:with:; - mouseMoveSelector: #doResize:with: ]! ! -!HaloMorph methodsFor: 'handles' stamp: 'jmv 11/20/2020 10:02:21' prior: 16850820! - addRotateHandle: haloSpec - -target hasVariableExtent ifFalse: [ - target hasOwnLocation ifTrue: [ - (self addHandle: haloSpec) - mouseDownSelector: #startRot:with:; - mouseMoveSelector: #doRot:with: ] -]! ! -!HaloMorph methodsFor: 'handles' stamp: 'jmv 11/20/2020 10:02:32' prior: 50558625! - addScaleHandle: haloSpec - -target hasVariableExtent ifFalse: [ - target hasOwnLocation ifTrue: [ - (self addHandle: haloSpec) - mouseDownSelector: #startScale:with:; - mouseMoveSelector: #doScale:with: ] -]! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/19/2020 17:10:02' prior: 50558632! - doScale: evt with: scaleHandle - "Update the scale of my target if it is scalable." - - | scale | - evt hand obtainHalo: self. - scale _ (evt eventPosition - target referencePosition) rho * scaleOffset. - scale = 1.0 - ifTrue: [scaleHandle color: `Color lightBlue`] - ifFalse: [scaleHandle color: `Color blue`]. - scaleHandle submorphsDo: - [:m | m color: scaleHandle color makeForegroundColor]. - self removeAllHandlesBut: scaleHandle. - target scale: scale. - scaleHandle morphPositionInWorld: evt eventPosition - (scaleHandle morphExtent // 2)! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/20/2020 10:12:35' prior: 50558819! - startRot: evt with: rotHandle - "Initialize rotation of my target if it is rotatable." - - evt hand obtainHalo: self. "Make sure the event's hand correlates with the receiver" - - self removeAllHandlesBut: rotHandle. "remove all other handles" - angleOffset _ evt eventPosition - target referencePosition. - angleOffset _ Point - r: 1.0 - degrees: angleOffset degrees - target rotationDegrees.! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/20/2020 10:09:48' prior: 50558835! - startScale: evt with: scaleHandle - "Initialize scale of my target if it is scalable." - - evt hand obtainHalo: self. "Make sure the event's hand correlates with the receiver" - - self removeAllHandlesBut: scaleHandle. "remove all other handles" - scaleOffset _ target scale / (evt eventPosition - target referencePosition) rho.! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Preferences resetHaloSpecifications! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4469-HaloMorphScaleAndRotateNotForWidgets-JuanVuletich-2020Nov20-09h51m-jmv.003.cs.st----! - -'From Cuis 5.0 [latest update: #4469] on 20 November 2020 at 10:50:38 am'! -!MouseClickState class methodsFor: 'cached state access' stamp: 'jmv 11/20/2020 10:49:00' prior: 16879030! - doubleClickTimeout - DoubleClickTimeout ifNil: [ - DoubleClickTimeout _ 500 ]. - ^DoubleClickTimeout! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -MouseClickState releaseClassCachedState! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4470-LargerDoubleClickTimeout-JuanVuletich-2020Nov20-10h48m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4469] on 20 November 2020 at 10:58:54 am'! -!Debugger methodsFor: 'class list' stamp: 'jmv 11/20/2020 10:56:52' prior: 16830015 overrides: 16812883! - selectedClass - "Answer the class in which the currently selected context's method was found." - - ^self selectedContext ifNotNil: [ :ctx | - (#(doesNotUnderstand: halt halt:) statePointsTo: ctx selector) - ifTrue: [ctx receiver class] - ifFalse: [ctx methodClass ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4471-haltOrDNUselectedClassIsReceivers-JuanVuletich-2020Nov20-10h50m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4471] on 20 November 2020 at 3:35:54 pm'! -!Object methodsFor: 'object serialization' stamp: 'jmv 11/20/2020 15:34:27'! - releaseCachedState - "Some subclasses might"! ! -!PluggableTextModel methodsFor: 'misc' stamp: 'jmv 11/20/2020 15:26:17' overrides: 50559125! - releaseCachedState - textProvider releaseCachedState! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4472-TextMorph-duplication-fix-JuanVuletich-2020Nov20-15h35m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4472] on 20 November 2020 at 3:47:57 pm'! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/20/2020 15:47:38' prior: 16850985! - doDup: evt with: dupHandle - "Ask hand to duplicate my target." - - | hand positionInHandCoordinates | - hand _ evt hand. - positionInHandCoordinates _ target morphPositionInWorld - hand morphPositionInWorld. - "Duplicate has no meaningful position, as it is not in the world. Grab position from original!!" - target _ target duplicateMorph: evt. - self addNameString: (target printStringLimitedTo: 40). - hand - obtainHalo: self; - grabMorph: target delta: positionInHandCoordinates! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4473-MorphDuplicationPositionFix-JuanVuletich-2020Nov20-15h47m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4473] on 20 November 2020 at 3:43:54 pm'! -!InnerTextMorph methodsFor: 'copying' stamp: 'jmv 11/20/2020 14:59:51' overrides: 16876458! - okayToDuplicate - "Answered false by morphs that can't simply be duplicated" - - ^ false! ! -!Morph methodsFor: 'copying' stamp: 'jmv 11/20/2020 14:59:43' prior: 16876458! - okayToDuplicate - "Answered false by morphs that can't simply be duplicated" - - ^ true! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/20/2020 15:42:13' prior: 50559142! - doDup: evt with: dupHandle - "Ask hand to duplicate my target." - - | hand positionInHandCoordinates | - target okayToDuplicate ifFalse: [^ self]. - hand _ evt hand. - positionInHandCoordinates _ target morphPositionInWorld - hand morphPositionInWorld. - "Duplicate has no meaningful position, as it is not in the world. Grab position from original!!" - target _ target duplicateMorph: evt. - self addNameString: (target printStringLimitedTo: 40). - hand - obtainHalo: self; - grabMorph: target delta: positionInHandCoordinates! ! - -HaloMorph removeSelector: #maybeDoDup:with:! - -!methodRemoval: HaloMorph #maybeDoDup:with: stamp: 'Install-4474-ForbidInnerTextMorphDuplication-JuanVuletich-2020Nov20-15h38m-jmv.001.cs.st 12/30/2020 14:48:20'! -maybeDoDup: evt with: dupHandle - evt hand obtainHalo: self. - ^ target okayToDuplicate ifTrue: - [self doDup: evt with: dupHandle]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4474-ForbidInnerTextMorphDuplication-JuanVuletich-2020Nov20-15h38m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4438] on 5 November 2020 at 12:32:31 pm'! -!Browser methodsFor: 'system category functions' stamp: 'KLG 11/5/2020 12:23:10'! - newSystemCategoryNameInitialAnswer - "Make a suggestion for a new sytems category. - - Can be redefined in subclasses to provide something meore meaningfull." - - ^ 'Category-Name'. -! ! -!SinglePackageBrowser methodsFor: 'system category functions' stamp: 'KLG 11/5/2020 12:28:53' overrides: 50559218! - newSystemCategoryNameInitialAnswer - "Make a suggestion for a new sytems category. - - Provide something more usefull, e.g. the package name or a sensible derivate of it." - - | packageName | - ^ self systemCategoryList includes: (packageName _ package packageName) :: - ifTrue: [ packageName, ' - Sub-Category-Name' ] - ifFalse: [ packageName ] -! ! -!Browser methodsFor: 'system category functions' stamp: 'KLG 11/5/2020 12:23:23' prior: 50514066! - newSystemCategoryNameIfNone: aNoneBlock - - | newName | - - newName _ self - request: 'New category name?' - initialAnswer: self newSystemCategoryNameInitialAnswer. - - ^newName isEmpty - ifTrue: aNoneBlock - ifFalse: [newName asSymbol].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4475-InitialSystemCategoryAnswer-GeraldKlix-2020Oct31-20h05m-KLG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4475] on 24 November 2020 at 12:18:10 pm'! - -KernelMorph subclass: #HaloMorph - instanceVariableNames: 'target positionOffset angleOffset scaleOffset haloBox haloDelta ' - classVariableNames: 'Icons ' - poolDictionaries: '' - category: 'Morphic-Halos'! - -!classDefinition: #HaloMorph category: #'Morphic-Halos' stamp: 'Install-4476-HaloFixes-JuanVuletich-2020Nov24-12h11m-jmv.001.cs.st 12/30/2020 14:48:20'! -KernelMorph subclass: #HaloMorph - instanceVariableNames: 'target positionOffset angleOffset scaleOffset haloBox haloDelta' - classVariableNames: 'Icons' - poolDictionaries: '' - category: 'Morphic-Halos'! -!Morph methodsFor: 'geometry' stamp: 'jmv 11/24/2020 11:40:08'! - rotation - ^0! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 11/24/2020 11:39:08'! - rotationDegrees: degrees - "Change the rotation of this morph. Argument is an angle to be taken as the new rotation." - - self rotation: degrees degreesToRadians! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 11/24/2020 11:41:25' overrides: 50559277! - rotation - ^location radians! ! -!Number methodsFor: 'truncation and round off' stamp: 'di 2/19/98 21:58' prior: 16880499! - detentBy: detent atMultiplesOf: grid snap: snap - "Map all values that are within detent/2 of any multiple of grid to that multiple. Otherwise, if snap is true, return self, meaning that the values in the dead zone will never be returned. If snap is false, then expand the range between dead zones so that it covers the range between multiples of the grid, and scale the value by that factor." - | r1 r2 | - r1 _ self roundTo: grid. "Nearest multiple of grid" - (self - r1) abs <= detent ifTrue: [^ r1]. "Snap to that multiple..." - snap ifTrue: [^ self]. "...or return self" - - r2 _ self < r1 "Nearest end of dead zone" - ifTrue: [r1 - (detent asFloat/2)] - ifFalse: [r1 + (detent asFloat/2)]. - "Scale values between dead zones to fill range between multiples" - ^ r1 + ((self - r2) * grid asFloat / (grid - detent)) -" - (170 to: 190 by: 2) collect: [:a | a detentBy: 10 atMultiplesOf: 90 snap: true] (170 to: 190 by: 2) collect: [:a | a detentBy: 10 atMultiplesOf: 90 snap: false] - (3.9 to: 4.1 by: 0.02) collect: [:a | a detentBy: 0.1 atMultiplesOf: 1.0 snap: true] (-3.9 to: -4.1 by: -0.02) collect: [:a | a detentBy: 0.1 atMultiplesOf: 1.0 snap: false] -"! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 11/24/2020 10:33:48' prior: 50554626! - referencePosition - "Return the current reference position of the receiver" - "a rather ugly way to say #center . At least, we avoid false polymorphism" - "remove some day" - - self displayBounds ifNotNil: [ :r | r center ]. - ^0@0! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 11/24/2020 11:40:19' prior: 16876483! - rotationDegrees - - self rotation radiansToDegrees! ! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'jmv 11/24/2020 12:17:21' prior: 50535355! - removeAllMorphs - | oldMorphs | - submorphs isEmpty ifTrue: [ ^self ]. - submorphs do: [ :m | - m invalidateBounds. - m privateOwner: nil ]. - oldMorphs _ submorphs. - submorphs _ #(). - oldMorphs do: [ :m | - self removedMorph: m ]. - self someSubmorphPositionOrExtentChanged. -! ! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'jmv 11/24/2020 11:31:31' prior: 50539702! - removeMorph: aMorph - "Remove the given morph from my submorphs" - - aMorph owner == self ifFalse: [^self]. - aMorph invalidateBounds. - self privateRemove: aMorph. - aMorph privateOwner: nil. - self removedMorph: aMorph. - self someSubmorphPositionOrExtentChanged. -! ! -!Morph methodsFor: 'updating' stamp: 'jmv 11/24/2020 12:16:24' prior: 50557127! - invalidateBounds - "Report that the area occupied by this morph and submorphs should be redrawn, - but most likely we are not going to be redrawn on it, or maybe we'll not be fully visible. See senders." - - self displayFullBounds ifNotNil: [ :r | self invalidateDisplayRect: r for: nil ]. -! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 11/24/2020 10:33:58' prior: 50558974 overrides: 50559331! - referencePosition - "Return the current reference position of the receiver" - "a rather ugly way to say #center . At least, we avoid false polymorphism" - "remove some day" - self flag: #jmvVer2. - self displayBounds ifNotNil: [ :r | r center ]. - ^self morphPositionInWorld! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 11/24/2020 10:34:03' prior: 50558894 overrides: 50559382! - referencePosition - "Return the current reference position of the receiver" - "a rather ugly way to say #center . At least, we avoid false polymorphism" - "remove some day" - self flag: #jmvVer2. - self displayBounds ifNotNil: [ :r | r center ]. - ^self morphExtentInWorld // 2 + self morphPositionInWorld! ! -!HaloMorph methodsFor: 'dropping/grabbing' stamp: 'jmv 11/24/2020 11:17:47' prior: 16850627! - startDrag: evt with: dragHandle - "Drag my target without removing it from its owner." - - | p | - evt hand obtainHalo: self. "Make sure the event's hand correlates with the receiver" - p _ target morphPositionInWorld. - positionOffset _ dragHandle referencePosition - p. - haloDelta _ self morphPositionInWorld - p. -! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/24/2020 11:31:40' prior: 50558806! - addHandles - - self removeAllMorphs. "remove old handles, if any" - target displayBoundsForHalo ifNotNil: [ :r | - self morphBounds: r. "update my size" - haloBox _ self basicBox. - target addHandlesTo: self box: haloBox. - self addNameString: (target printStringLimitedTo: 40). - self redrawNeeded ]. -! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/24/2020 11:17:51' prior: 50545250! - doDrag: evt with: dragHandle - | thePoint | - evt hand obtainHalo: self. - thePoint _ evt eventPosition - positionOffset. - target morphPositionInWorld: thePoint. - self morphPositionInWorld: thePoint + haloDelta. -! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/24/2020 11:55:32' prior: 50558540! - doRot: evt with: rotHandle - "Update the rotation of my target if it is rotatable." - - | radians | - evt hand obtainHalo: self. - radians _ (evt eventPosition - target referencePosition) theta + angleOffset. - radians _ radians detentBy: 0.05 atMultiplesOf: Float pi / 4 snap: false. - radians = 0.0 - ifTrue: [rotHandle color: `Color lightBlue`] - ifFalse: [rotHandle color: `Color blue`]. - rotHandle submorphsDo: - [:m | m color: rotHandle color makeForegroundColor]. - target rotation: radians. - rotHandle morphPositionInWorld: evt eventPosition - (rotHandle morphExtent // 2)! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/24/2020 11:19:54' prior: 50559013! - doScale: evt with: scaleHandle - "Update the scale of my target if it is scalable." - - | scale | - evt hand obtainHalo: self. - scale _ (evt eventPosition - target referencePosition) rho * scaleOffset. - scale = 1.0 - ifTrue: [scaleHandle color: `Color lightBlue`] - ifFalse: [scaleHandle color: `Color blue`]. - scaleHandle submorphsDo: - [:m | m color: scaleHandle color makeForegroundColor]. - target scale: scale. - scaleHandle morphPositionInWorld: evt eventPosition - (scaleHandle morphExtent // 2)! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/24/2020 11:44:08' prior: 50559033! - startRot: evt with: rotHandle - "Initialize rotation of my target if it is rotatable." - - evt hand obtainHalo: self. "Make sure the event's hand correlates with the receiver" - - self removeAllHandlesBut: rotHandle. "remove all other handles" - angleOffset _ target rotation - (evt eventPosition - target referencePosition) theta.! ! - -MovableMorph removeSelector: #rotationDegrees:! - -!methodRemoval: MovableMorph #rotationDegrees: stamp: 'Install-4476-HaloFixes-JuanVuletich-2020Nov24-12h11m-jmv.001.cs.st 12/30/2020 14:48:20'! -rotationDegrees: degrees - "Change the rotation of this morph. Argument is an angle to be taken as the new rotation." - - self rotation: degrees degreesToRadians! - -KernelMorph subclass: #HaloMorph - instanceVariableNames: 'target positionOffset angleOffset scaleOffset haloBox haloDelta' - classVariableNames: 'Icons' - poolDictionaries: '' - category: 'Morphic-Halos'! - -!classDefinition: #HaloMorph category: #'Morphic-Halos' stamp: 'Install-4476-HaloFixes-JuanVuletich-2020Nov24-12h11m-jmv.001.cs.st 12/30/2020 14:48:20'! -KernelMorph subclass: #HaloMorph - instanceVariableNames: 'target positionOffset angleOffset scaleOffset haloBox haloDelta' - classVariableNames: 'Icons' - poolDictionaries: '' - category: 'Morphic-Halos'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4476-HaloFixes-JuanVuletich-2020Nov24-12h11m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4476] on 24 November 2020 at 3:39:52 pm'! -!TextEditor methodsFor: 'menu messages' stamp: 'jmv 11/24/2020 15:39:08' prior: 50514636! - find - "Prompt the user for a string to search for, and search the receiver from the current selection onward for it. 1/26/96 sw" - - self - request: 'Find what?' - initialAnswer: self class findText - do: [:aString| - aString isEmpty ifFalse: - ["Set focus on our text morph, so that cmd-g does the search again" - morph world activeHand newKeyboardFocus: morph. - self setSearch: aString. - ChangeText _ self class findText. "Implies no replacement to againOnce: method" - (self findAndReplaceMany: false) - ifFalse: [ self flash ]. - morph scrollSelectionIntoView ]]. - -" morph installEditorToReplace: self"! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4477-find-scrollSelectionIntoView-JuanVuletich-2020Nov24-15h38m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4477] on 24 November 2020 at 5:12:33 pm'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 11/24/2020 17:12:19' prior: 50552969! - computeDamage: aWorldMorph repair: aDamageRecorder rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage - "Iterate front to back while computing damage to actually repair for each morph, and for world background. - Answer uncoveredDamage, the areas where World background needs to be redrawn." - - | uncoveredDamage morph morphDamage prevMorphDamage reuseInstance morphBefore | - morphDamage _ OrderedCollection new. - prevMorphDamage _ OrderedCollection new. - uncoveredDamage _ aDamageRecorder damageReportedOther. - "Iterate from front to back" - 1 to: rootMorphs size do: [ :i | - morph _ rootMorphs at: i. - morphDamage removeAll. - (aDamageRecorder damageReportedFor: morph) ifNotNil: [ :r | - morphDamage add: r ]. - morph displayFullBounds ifNotNil: [ :morphFullBounds | - uncoveredDamage do: [ :r | | intersection | - intersection _ r intersect: morphFullBounds. - intersection hasPositiveExtent ifTrue: [ - morphDamage add: intersection ]]]. - 1 to: i-1 do: [ :j | - reuseInstance _ prevMorphDamage. - prevMorphDamage _ morphDamage. - morphDamage _ reuseInstance removeAll. - morphBefore _ rootMorphs at: j. - prevMorphDamage do: [ :r | - morphBefore addPossiblyUncoveredAreasIn: r to: morphDamage ]]. - (Rectangle merging: morphDamage) ifNotNil: [ :morphDamageRect | - rootMorphsDamage at: i put: morphDamageRect. - morph addPossiblyUncoveredAreasIn: morphDamageRect to: uncoveredDamage ]]. - - ^ uncoveredDamage! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 11/24/2020 17:12:08' prior: 50553047! - drawWorld: aWorldMorph rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage allDamage: worldDamage - "Redraw the damaged areas. - Draw each morph just once, merging rectanges to be repaired as needed." - - | morph morphDamage | - - "Iterate from back to front." - rootMorphs size to: 1 by: -1 do: [ :i | - morph _ rootMorphs at: i. - morph visible ifTrue: [ - morphDamage _ rootMorphsDamage at: i. - morph displayFullBounds ifNotNil: [ :morphFullBounds | - worldDamage do: [ :r | | intersection | - intersection _ r intersect: morphFullBounds. - intersection hasPositiveExtent ifTrue: [ - morphDamage _ intersection quickMerge: morphDamage ]]]. - morphDamage ifNotNil: [ - self newClipRect: morphDamage. - self fullDraw: morph. - worldDamage add: morphDamage ]]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4478-MorphicRepairFix-JuanVuletich-2020Nov24-16h50m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4478] on 25 November 2020 at 3:59:41 pm'! -!Morph methodsFor: 'drawing' stamp: 'jmv 11/25/2020 13:10:56' prior: 16874306! - drawingFails - self world addKnownFailing: self. - self redrawNeeded. -! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 11/25/2020 13:10:51' prior: 16874310! - drawingFailsNot - self world removeKnownFailing: self. - self redrawNeeded. -! ! -!WorldMorph methodsFor: 'errors on draw' stamp: 'jmv 11/25/2020 13:10:47' prior: 50551867! - removeAllKnownFailing - drawingFailingMorphs do: [ :m | m redrawNeeded ]. - drawingFailingMorphs _ WeakIdentitySet new. -! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 11/25/2020 12:53:08' prior: 50556157! - drawCurrentAsError - "The morph (or one of its submorphs) had an error in its drawing method." - | r w | - r _ currentMorph morphLocalBounds. - w _ r extent > `50@50` - ifTrue: [ 6 ] - ifFalse: [ 2 ]. - self - frameAndFillRectangle: r - fillColor: `Color red` - borderWidth: w - borderColor: `Color yellow`. - self line: r topLeft to: r bottomRight width: w color: `Color yellow`. - self line: r topRight to: r bottomLeft width: w color: `Color yellow`. - world notNil ifTrue: [ "Only if we are drawing the world" - currentMorph displayBounds: self boundingRectOfCurrentMorphAfterDraw ].! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 11/25/2020 12:34:48' prior: 50530703! - fullDraw: aMorph - "Draw the full Morphic structure on us" - - "We are already set with a proper transformation from aMorph owner's coordinates to those of our target form." - - self flag: #jmvVer3. - aMorph visible ifFalse: [^ self]. - self into: aMorph. - - currentMorph layoutSubmorphsIfNeeded. - - currentMorph isKnownFailing ifTrue: [ - self canvasToUse drawCurrentAsError. - self outOfMorph. - ^ self]. - - (currentMorph isOwnedByHand and: [ Preferences cheapWindowReframe ]) ifTrue: [ - self drawCurrentAsOutline. - self outOfMorph. - ^ self]. - - "Draw current Morph and submorphs" - self canvasToUse drawCurrentAndSubmorphs. - - self outOfMorph! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4479-Morph-drawAsError-fixes-JuanVuletich-2020Nov25-15h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4479] on 26 November 2020 at 3:03:59 pm'! -!Preferences class methodsFor: 'standard queries' stamp: 'jmv 11/26/2020 15:03:12' prior: 0! - haloEnclosesFullBounds - ^ self - valueOfFlag: #haloEnclosesFullBounds - ifAbsent: [ true ].! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 11/26/2020 13:05:43' prior: 50541055! - basicBox - "basicBox is in local coordinates" - - | minSide e hs box | - hs _ Preferences haloHandleSize. - minSide _ 4 * hs. - e _ extent + (hs*2) max: minSide@minSide. - box _ target displayBoundsForHalo. - box _ Rectangle center: box center extent: e. - self world ifNotNil: [ :w | box _ box intersect: (w viewBox insetBy: (hs@hs corner: hs@(hs*3))) ]. - ^box translatedBy: self morphPosition negated. -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4480-haloBoundsFix-JuanVuletich-2020Nov26-15h03m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4479] on 26 November 2020 at 3:07:55 pm'! -!Morph methodsFor: 'accessing' stamp: 'jmv 11/26/2020 15:05:00'! - location: aGeometryTransformation! ! -!Morph methodsFor: 'submorphs-accessing' stamp: 'jmv 11/26/2020 14:34:52'! - allMorphsBut: aMorph do: aBlock - "Evaluate the given block for all morphs in this composite morph (including the receiver), - but avoid aMorph and all its submorphs." - - self == aMorph ifFalse: [ - submorphs do: [:m | m allMorphsBut: aMorph do: aBlock ]. - aBlock value: self ].! ! -!MovableMorph methodsFor: 'accessing' stamp: 'jmv 11/26/2020 13:27:14' overrides: 50559745! - location: aGeometryTransformation - location _ aGeometryTransformation! ! -!WorldMorph methodsFor: 'submorphs-accessing' stamp: 'jmv 11/26/2020 14:34:48' overrides: 50559749! - allMorphsBut: aMorph do: aBlock - "Evaluate the given block for all morphs in this composite morph (including the receiver), - but avoid aMorph and all its submorphs." - - self == aMorph ifFalse: [ - submorphs do: [:m | m allMorphsBut: aMorph do: aBlock ]. - aBlock value: self. - self handsReverseDo: [:h | h allMorphsBut: aMorph do: aBlock ]].! ! -!Morph methodsFor: 'meta-actions' stamp: 'jmv 11/26/2020 15:05:27' prior: 50534656! - potentialEmbeddingTargets - "Return the potential targets for embedding the receiver" - | myRect myWorld | - owner ifNil:[^#()]. - myWorld := owner world ifNil: [^#()]. - myRect := self displayBounds. - ^Array streamContents: [ :strm | - myWorld allMorphsBut: self do: [ :m | - (m isReallyVisible - and: [ m isLocked not - and: [(m displayBounds intersects: myRect) - and: [(m ~= self) - and: [(m isKindOf: HaloMorph) not]]]]) ifTrue: [ strm nextPut: m ]]]! ! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'jmv 11/26/2020 15:06:40' prior: 16876867! - addMorphFrontFromWorldPosition: aMorph - - | tx | - tx _ GeometryTransformation identity. - aMorph withAllOwnersDo: [ :o | - tx _ o location composedWith: tx ]. - self withAllOwnersReverseDo: [ :o | - tx _ o location inverseTransformation composedWith: tx ]. - self addMorphFront: aMorph. - aMorph location: tx! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 11/26/2020 15:06:03' prior: 50426104! - attachMorphBeside: aMorph - - "Position the given morph beside this hand, then grab it." - - aMorph aboutToBeGrabbedBy: self. - self grabMorph: aMorph delta: (self morphWidth)@0. -! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 11/26/2020 15:00:56' prior: 50555701! - grabMorph: aMorph moveUnderHand: moveUnderHand - "Grab the given morph (i.e., add it to this hand and remove it from its current owner). - If moveUnderHand is requested or it seems neccesary anyway, move the grabbed morph under the hand." - - | grabbed positionInHandCoordinates tx | - self releaseMouseFocus. "Break focus" - grabbed _ aMorph. - aMorph owner ifNotNil: [ :o | grabbed _ o aboutToGrab: aMorph ]. - grabbed ifNil: [ ^ self ]. - grabbed _ grabbed aboutToBeGrabbedBy: self. - grabbed ifNil: [ ^ self ]. - - moveUnderHand - ifTrue: [ - "We can possibly do better, especially for non WidgetMorphs" - positionInHandCoordinates _ -30 @ -10. - grabbed isInWorld ifTrue: [ - grabbed displayBounds ifNotNil: [ :r | - positionInHandCoordinates _ (r extent // 2) negated ]]. - self - grabMorph: grabbed - delta: positionInHandCoordinates. - ^self ]. - - positionInHandCoordinates _ (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) - morphPositionInWorld - self morphPositionInWorld. - - tx _ GeometryTransformation identity. - aMorph withAllOwnersDo: [ :o | - tx _ o location composedWith: tx ]. - self withAllOwnersReverseDo: [ :o | - tx _ o location inverseTransformation composedWith: tx ]. - - self - grabMorph: grabbed - delta: positionInHandCoordinates. - - aMorph location: tx.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4481-correctLocationWhenEmbeddingMorphs-JuanVuletich-2020Nov26-15h03m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4481] on 26 November 2020 at 3:18:46 pm'! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 11/26/2020 15:17:14' prior: 50555991! - grabMorph: aMorph delta: delta - "Grab the given morph (i.e., add it to this hand and remove it from its current owner)." - - | formerOwner formerPositionInWorld | - self releaseMouseFocus. "Break focus" - - "Grab the halo if present" - self halo ifNotNil: [ :h | - (h target == aMorph or: [h target hasOwner: aMorph]) ifTrue: [ - self addMorphBack: h position: h morphPositionInWorld - self morphPositionInWorld ]]. - - "Remember previous owner and position, in case the drop is later rejected" - formerOwner _ aMorph owner. - formerOwner ifNotNil: [ - formerPositionInWorld _ aMorph morphPositionInWorld. - grabMorphData - at: aMorph - put: { formerOwner. formerPositionInWorld. } ]. - self addMorphBack: aMorph position: delta. - aMorph displayBounds ifNotNil: [ :r | | d | - formerPositionInWorld ifNotNil: [ - d _ aMorph morphPositionInWorld - formerPositionInWorld. - d isZero ifFalse: [ - aMorph displayBounds: (r translatedBy: d)]]]. - aMorph justGrabbedFrom: formerOwner. - formerOwner ifNotNil: [ - lastPosition _ self morphPosition ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4482-grabWithHaloFix-JuanVuletich-2020Nov26-15h18m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4482] on 30 November 2020 at 12:38:38 pm'! -!Morph methodsFor: 'meta-actions' stamp: 'jmv 11/27/2020 17:58:00' prior: 50559781! - potentialEmbeddingTargets - "Return the potential targets for embedding the receiver" - | myRect myWorld | - owner ifNil:[^#()]. - myWorld := owner world ifNil: [^#()]. - myRect := self displayBounds. - ^Array streamContents: [ :strm | - myWorld allMorphsBut: self do: [ :m | - (m isReallyVisible - and: [ m isLocked not - and: [(m displayBounds intersects: myRect) - and: [(m ~= self) - and: [(#(HaloMorph HaloHandleMorph) statePointsTo: m class name) not]]]]) - ifTrue: [ strm nextPut: m ]]].! ! -!Morph methodsFor: 'submorphs-accessing' stamp: 'jmv 11/27/2020 18:04:44' prior: 50559749! - allMorphsBut: aMorph do: aBlock - "Evaluate the given block for all morphs in this composite morph (including the receiver), - but avoid aMorph and all its submorphs. - Also avoid halos (might happen when called on the World) and Hands" - - self == aMorph ifTrue: [ ^self ]. - (self is: #HaloMorph) ifTrue: [ ^self ]. - submorphs do: [:m | m allMorphsBut: aMorph do: aBlock ]. - aBlock value: self.! ! - -WorldMorph removeSelector: #allMorphsBut:do:! - -!methodRemoval: WorldMorph #allMorphsBut:do: stamp: 'Install-4483-EmbeddingTargetsFix-JuanVuletich-2020Nov30-12h37m-jmv.001.cs.st 12/30/2020 14:48:20'! -allMorphsBut: aMorph do: aBlock - "Evaluate the given block for all morphs in this composite morph (including the receiver), - but avoid aMorph and all its submorphs." - - self == aMorph ifFalse: [ - submorphs do: [:m | m allMorphsBut: aMorph do: aBlock ]. - aBlock value: self. - self handsReverseDo: [:h | h allMorphsBut: aMorph do: aBlock ]].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4483-EmbeddingTargetsFix-JuanVuletich-2020Nov30-12h37m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4483] on 1 December 2020 at 10:45:05 am'! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 12/1/2020 10:39:59'! - clipsSubmorphsReally - "Currently only one level of clipping is supported. - This means that if a morph clipsSubmorphs, then no submorph in its tree can't do it. - This is a current limitation of VectorCanvas" - - self clipsSubmorphs ifFalse: [ ^false ]. - self allOwnersDo: [ :o | o clipsSubmorphs ifTrue: [ ^false ]]. - ^true! ! -!Morph methodsFor: 'change reporting' stamp: 'jmv 12/1/2020 10:40:16' prior: 50557041! - invalidateDisplayRect: damageRect for: aMorph - " - If we clip submorphs, then we clip damageRect. - - aMorph is the morph that changed and therefore should be redrawn. In some cases, damage reporting is done by no longer occupying some area, and requesting whatever appropriate morph to be drawn there. In such cases, aMorph should be nil. See senders." - - | clippedRect b | - - "warning. Senders are using global coordinates. Redesign!!" - "local now!!!!!!!!!!" - self flag: #jmvVer2. "ok?" - - self visible ifFalse: [ ^self]. - - clippedRect _ damageRect. - self clipsSubmorphsReally ifTrue: [ - b _ self displayBounds. - b ifNil: [ ^self ]. - clippedRect _ damageRect intersect: b ]. - owner ifNotNil: [ - owner invalidateDisplayRect: clippedRect for: aMorph ]! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 12/1/2020 10:40:08' prior: 50557110! - displayFullBounds - "Answer a rectangle that completely bounds receiver and submorphs when last drawn - (if the world was to be fully drawn, i.e. only to be used on a Canvas on the full world)." - - | answer | - answer _ self displayBounds. - answer ifNil: [ ^nil ]. - (self submorphsMightProtrude and: [self clipsSubmorphsReally not]) ifTrue: [ - self submorphsReverseDo: [ :m | - answer _ answer quickMerge: m displayFullBounds ]]. - ^answer! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 12/1/2020 10:42:27' prior: 50557067! - clipsSubmorphs - "Answer true if we clip the shape of our submorphs to our own. - Answer true only when clipping by the canvas is needed. - Morphs that can guarantee that submorphs don't protrude and answer false to - #submorphsMightProtrude should answer false for better performance. - Note: Currently we are limited to only one clipping morph in an owner / submorph chain. - See #clipsSubmorphsReally" - - ^ false! ! -!Morph methodsFor: 'updating' stamp: 'jmv 12/1/2020 10:40:19' prior: 50557138! - redrawNeeded - "Report that the area occupied by this morph should be redrawn. - Usually because we changed in some way." - - self needsRedraw: true. - self allOwnersDo: [ :m | m submorphNeedsRedraw: true ]. - self invalidateDisplayRect: self displayBoundsOrBogus for: self. - (self submorphsMightProtrude and: [self clipsSubmorphsReally not]) ifTrue: [ - self submorphsReverseDo: [ :m | m redrawNeeded ]].! ! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 12/1/2020 10:40:22' prior: 50557381! - clippingByCurrentMorphDo: aBlock - "Do clipping only if currentMorph says so" - - | prevClipRect prevClippingMorphRect | - - currentMorph clipsSubmorphsReally ifFalse: [ ^aBlock value ]. - - prevClipRect _ self clipRect. - prevClippingMorphRect _ clippingMorphDisplayBounds. - "Might use the fact that currentMorph has just been drawn." - clippingMorphDisplayBounds _ self boundingRectOfCurrentMorphAfterDraw. - self setClipRect: (prevClipRect intersect: clippingMorphDisplayBounds). - self clipCurrentMorph: true. - aBlock ensure: [ - self clipCurrentMorph: false. - self setClipRect: prevClipRect. - clippingMorphDisplayBounds _ prevClippingMorphRect ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4484-ClippingMorphsCantContainClippingMorphs-JuanVuletich-2020Dec01-10h44m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4484] on 8 December 2020 at 8:56:57 am'! -!ColorForm methodsFor: 'private' stamp: 'jmv 12/8/2020 08:44:09' prior: 50358620! - ensureColorArrayExists - "Return my color palette." - - | colorsToUse | - colors ifNil: [ - self depth > 8 ifTrue: [^ self error: 'ColorForms only support depths up to 8 bits']. - colorsToUse _ Color indexedColors copyFrom: 1 to: (1 bitShift: self depth). - "Note: zero is transparent except when depth is one-bit deep" - self depth > 1 ifTrue: [ - colorsToUse at: 1 put: Color transparent ]. - self colors: colorsToUse]. -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4485-ColorForm-fix-JuanVuletich-2020Dec08-08h47m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4484] on 8 December 2020 at 9:11:10 am'! -!Color class methodsFor: 'class initialization' stamp: 'jmv 12/8/2020 09:02:12'! - oneBitColors - "Answer the colors available for 1 bit Forms. - Note: For depths 2 to 8, first entry is Color transparent, not white. See #initializeIndexedColors" - - ^ `{ Color white. Color black }`! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 12/8/2020 09:04:11' prior: 50386254! - colorFromPixelValue: p depth: d - "Convert a pixel value for the given display depth into a color." - "Details: For depths of 8 or less, the pixel value is simply looked up in a table. For greater depths, the color components are extracted and converted into a color." - "Warning: In BitBlt, a pixel with pixelValue = 0 is transparent. - Squeak usually assumes that r=g=b=0 => transparent. But this is false if we have alpha (opacity). - A color with r=g=b=0 and opacity = 255 is BLACK, not TRANSPARENT. - Squeak also answers darkest possible blue when asked for black. Again, this is not needed in 32 bits (with alpha). It is also not really needed for 16 bits as we have an extra, unused bit: 16r8000 is not zero, but rgb=0, and hence, black. - The real rule is that pixelValue=0 means transparent. - And that darkest blue must be used instead of black, but only for depths >8 and < 16 (no indexed colors, no alpha) - This method is updated to reflect that." - - | r g b alpha | - - d = 1 ifTrue: [^ self oneBitColors at: (p bitAnd: 16r01) + 1]. - - d = 8 ifTrue: [^ self indexedColors at: (p bitAnd: 16rFF) + 1]. - d = 4 ifTrue: [^ self indexedColors at: (p bitAnd: 16r0F) + 1]. - d = 2 ifTrue: [^ self indexedColors at: (p bitAnd: 16r03) + 1]. - - d = 32 ifTrue: [ - "eight bits per component; 8 bits of alpha" - alpha _ p bitShift: -24. - alpha = 0 ifTrue: [ ^`Color transparent` ]. - r _ (p bitShift: -16) bitAnd: 16rFF. - g _ (p bitShift: -8) bitAnd: 16rFF. - b _ p bitAnd: 16rFF. - ^alpha < 255 - ifTrue: [ (Color r: r g: g b: b range: 255) alpha: alpha asFloat / 255.0 ] - ifFalse: [ Color r: r g: g b: b range: 255 ]]. - - d = 16 ifTrue: [ - "five bits per component. The most significant bit, unused, allows having real black, without p being zero" - r _ (p bitShift: -10) bitAnd: 16r1F. - g _ (p bitShift: -5) bitAnd: 16r1F. - b _ p bitAnd: 16r1F. - ^ Color r: r g: g b: b range: 31]. - - d = 15 ifTrue: [ - "five bits per component" - r _ (p bitShift: -10) bitAnd: 16r1F. - g _ (p bitShift: -5) bitAnd: 16r1F. - b _ p bitAnd: 16r1F. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^`Color black` ]. - ^ Color r: r g: g b: b range: 31]. - - d = 12 ifTrue: [ - "four bits per component" - r _ (p bitShift: -8) bitAnd: 16rF. - g _ (p bitShift: -4) bitAnd: 16rF. - b _ p bitAnd: 16rF. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^`Color black` ]. - ^ Color r: r g: g b: b range: 15]. - - d = 9 ifTrue: [ - "three bits per component" - r _ (p bitShift: -6) bitAnd: 16r7. - g _ (p bitShift: -3) bitAnd: 16r7. - b _ p bitAnd: 16r7. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^`Color black` ]. - ^ Color r: r g: g b: b range: 7]. - - self error: 'unknown pixel depth: ', d printString! ! -!Color class methodsFor: 'class initialization' stamp: 'jmv 12/8/2020 09:03:11' prior: 50398110! - initializeIndexedColors - "Build an array of colors corresponding to the fixed colormap used - for depths of 2, 4, or 8 bits." - " - Color initializeIndexedColors - " - " -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: (Color r: 1 g: 0 b: 0); display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: (Color r: 0 g: 1 b: 0); display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: (Color r: 0 g: 0 b: 1); display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: (Color r: 0.5 g: 0.5 b: 0.5); display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: Color blue; display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: Color green; display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: Color red; display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: Color cyan; display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: Color yellow; display. -ColorForm extent: 128@128 :: fillColor: Color black :: colorAt: 10@10 put: Color magenta; display. - " - - | a index grayVal | - a _ Array new: 256. - - "1-bit colors (monochrome)" - a at: 1 put: `Color transparent`. "Note: For 1bpp forms, it is white" - a at: 2 put: `Color r: 0.0 g: 0.0 b: 0.0`. "black" - - "additional colors for 2-bit color" - a at: 3 put: `Color r: 1.0 g: 1.0 b: 1.0`. "opaque white" - a at: 4 put: `Color r: 0.5 g: 0.5 b: 0.5`. "1/2 gray" - - "additional colors for 4-bit color" - a at: 5 put: Color red. - a at: 6 put: Color green. - a at: 7 put: Color blue. - a at: 8 put: Color cyan. - a at: 9 put: Color yellow. - a at: 10 put: Color magenta. - - a at: 11 put: `Color r: 0.125 g: 0.125 b: 0.125`. "1/8 gray" - a at: 12 put: `Color r: 0.25 g: 0.25 b: 0.25`. "2/8 gray" - a at: 13 put: `Color r: 0.375 g: 0.375 b: 0.375`. "3/8 gray" - a at: 14 put: `Color r: 0.625 g: 0.625 b: 0.625`. "5/8 gray" - a at: 15 put: `Color r: 0.75 g: 0.75 b: 0.75`. "6/8 gray" - a at: 16 put: `Color r: 0.875 g: 0.875 b: 0.875`. "7/8 gray" - - "additional colors for 8-bit color" - "24 more shades of gray (1/32 increments but not repeating 1/8 increments)" - index _ 17. - 1 to: 31 do: [:v | - (v \\ 4) = 0 ifFalse: [ - grayVal _ v / 32.0. - a at: index put: (Color r: grayVal g: grayVal b: grayVal). - index _ index + 1]]. - - "The remainder of color table defines a color cube with six steps - for each primary color. Note that the corners of this cube may repeat - previous colors, but this simplifies the mapping between RGB colors - and color map indices. This color cube spans indices 40 through 255 - (indices 41-256 in this 1-based array)." - 0 to: 5 do: [:r | - 0 to: 5 do: [:g | - 0 to: 5 do: [:b | - index _ 41 + ((36 * r) + (6 * b) + g). - index > 256 ifTrue: [ - self error: 'index out of range in color table compuation']. - a at: index put: (Color r: r g: g b: b range: 5)]]]. - - IndexedColors _ a. -! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 12/8/2020 09:07:06' prior: 50355392! - computeColormapForGray8bppFrom: sourceDepth - "Compute a colorMap for translatingfrom the given depth to the 8bpp grays" - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | map | - sourceDepth < 16 ifTrue: [ - "source is 1-, 2-, 4-, or 8-bit indexed color" - map _ sourceDepth = 1 ifTrue: [ self oneBitColors ] ifFalse: [ self indexedColors ]. - map _ (map copyFrom: 1 to: (1 bitShift: sourceDepth)) - collect: [ :c | (c luminance * 255) rounded]. - map _ map as: Bitmap. - ^ map ]. - ^ self computeRGBColormapForGray8! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 12/8/2020 09:08:06' prior: 50355422! - computeColormapFrom: sourceDepth to: destDepth - "Compute a colorMap for translating between the given depths. A colormap is a Bitmap whose entries contain the pixel values for the destination depth. Typical clients use cachedColormapFrom:to: instead." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | map bitsPerColor | - sourceDepth < 16 ifTrue: [ - "source is 1-, 2-, 4-, or 8-bit indexed color" - map _ sourceDepth = 1 ifTrue: [ self oneBitColors ] ifFalse: [ self indexedColors ]. - map _ (map copyFrom: 1 to: (1 bitShift: sourceDepth)) - collect: [:c | c pixelValueForDepth: destDepth]. - ^map as: Bitmap ]. - "source is 16-bit or 32-bit RGB" - destDepth > 8 - ifTrue: [bitsPerColor _ 5] "retain maximum color resolution" - ifFalse: [bitsPerColor _ 4]. - ^self computeRGBColormapFor: destDepth bitsPerColor: bitsPerColor! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 12/8/2020 09:08:57' prior: 50386430! - computeIndexedColorConvertingMap: targetColor from: sourceDepth to: destDepth - | map | - - map _ sourceDepth = 1 ifTrue: [ self oneBitColors ] ifFalse: [ self indexedColors ]. - map _ (map copyFrom: 1 to: (1 bitShift: sourceDepth)) collect: [ :cc | | f c | - f _ 1.0 - (cc red + cc green + cc blue / 3.0 ). - c _ targetColor - ifNotNil: [ - destDepth = 32 - ifTrue: [ targetColor * f alpha: f] - ifFalse: [ targetColor alphaMixed: f*1.5 with: `Color white` ]] - ifNil: [ cc ]. - destDepth = 32 - ifTrue: [ c pixelValueForDepth: destDepth] - ifFalse: [ - f = 0.0 - ifTrue: [ 0 ] - ifFalse: [ c pixelValueForDepth: destDepth ]]]. - ^map as: Bitmap! ! -!Form methodsFor: 'converting' stamp: 'jmv 12/8/2020 09:10:47' prior: 50386942! - as8BitColorForm - "Simple conversion of zero pixels to transparent. Force it to 8 bits." - - | f | - f _ ColorForm extent: self extent depth: 8. - self displayOn: f at: self offset negated. - f colors: Color indexedColors copy. - f offset: self offset. - ^ f! ! -!ColorForm methodsFor: 'private' stamp: 'jmv 12/8/2020 09:09:50' prior: 50560094! - ensureColorArrayExists - "Return my color palette." - - colors ifNil: [ - self depth > 8 ifTrue: [^ self error: 'ColorForms only support depths up to 8 bits']. - self colors: (Color indexedColors copyFrom: 1 to: (1 bitShift: self depth)) ].! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Color initializeIndexedColors! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4486-IndexedColors-firstEntryTransparent-JuanVuletich-2020Dec08-08h56m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4484] on 3 December 2020 at 8:14:04 pm'! -!ChangeList methodsFor: 'scanning' stamp: 'KLG 12/3/2020 20:05:53' prior: 50501203! - scanSpecificChangeRecordType - "Scan anything that involves more than one chunk" - - | itemPosition item tokens firstToken secondToken | - - itemPosition _ file position. - item _ file nextChunk. - - (self itemIsRecognized: item) ifFalse: [ - "Maybe a preamble, but not one we recognize; bail out with the preamble trick" - ^ self scanAndIgnore: item in: itemPosition ]. - - tokens _ Scanner new scanTokens: item. - tokens size >= 2 ifTrue: [ - firstToken _ tokens first. - secondToken _ tokens second. - - firstToken == #classDefinition: - ifTrue: [ ^ self scanClassDefinition: tokens ]. - (firstToken == #classRemoval: or: [ firstToken == #classMoveToSomePackage: ]) - ifTrue: [ ^ self scanClassRemoval: tokens ]. - (firstToken == #methodRemoval: or: [ firstToken == #methodMoveToSomePackage: ]) - ifTrue: [ ^ self scanMethodRemoval: tokens ]. - (secondToken == #methodsFor: or: [ - tokens size > 2 and: [ tokens third == #methodsFor: ] ]) - ifTrue: [ ^ self scanMethodDefinition: tokens ]. - secondToken == #commentStamp: - ifTrue: [ ^ self scanClassComment: tokens ]. - firstToken == #provides: - ifTrue: [ ^ self scanFeatureProvision: tokens ]. - firstToken == #requires: - ifTrue: [ ^ self scanFeatureRequirement: tokens ]. - firstToken == #classRenamed: - ifTrue: [ ^ self scanClassRenamed: tokens ]. - ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4487-ChangeList-scanSpecificChangeRecordType-GeraldKlix-2020Dec03-12h01m-KLG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4384] on 7 December 2020 at 4:30:41 pm'! -!StringRequestMorph methodsFor: 'private' stamp: 'MJR 12/7/2020 16:29:34'! - textBox - - ^submorphs at: 2! ! -!StringRequestMorph methodsFor: 'private' stamp: 'MJR 12/7/2020 16:30:05' prior: 50513827! - getUserResponseOrCancel: aBlock - "Wait for the user to accept or cancel, and answer the result string. Answers the empty string if the user cancels." - "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop." - | w delay done canceled | - w _ self world. - w isNil ifTrue: [^ response asString]. - done _ false. - canceled _ false. - Preferences focusFollowsMouse ifFalse: [self textBox focusText]. - acceptBlock _ [:aString| done _ true]. - cancelBlock _ [done _ true. canceled _ true]. - delay _ Delay forMilliseconds: 10. - [done not and: [self isInWorld]] whileTrue: [ w doOneMinimalCycleNow. delay wait ]. - self delete. - w doOneMinimalCycleNow. - canceled ifTrue: [^ aBlock value]. - ^ response asString! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4488-StringRequestMorphFix-MauroRizzi-2020Dec07-16h29m-MJR.001.cs.st----! - -'From Cuis 5.0 [latest update: #4384] on 9 December 2020 at 9:23:41 pm'! -!StringRequestMorph class methodsFor: 'instance creation' stamp: 'MJR 12/9/2020 21:23:01' prior: 50548622! - request: queryString centeredAt: aPoint initialAnswer: defaultAnswer validationBlock: validationBlock acceptBlock: acceptBlock cancelBlock: cancelBlock - | answer | - answer _ self newColumn - setQuery: queryString - initialAnswer: defaultAnswer; - validationBlock: validationBlock; - acceptBlock: acceptBlock; - cancelBlock: cancelBlock. - self runningWorld addMorph: answer centeredNear: aPoint - self deltaToTextPane. - Preferences focusFollowsMouse ifFalse: [answer textBox focusText]. - ^ answer! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4489-StringRequestMorphFix-II-MauroJulianRizzi-2020Dec09-21h23m-MJR.001.cs.st----! - -'From Cuis 5.0 [latest update: #4489] on 18 December 2020 at 3:54:30 pm'! -!CodePackage methodsFor: 'naming' stamp: 'KenD 12/16/2020 13:04:33'! - packageDirectoryName - - ^self fullFileName withoutSuffix: self packageFileName! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4490-CodePackage-packageDirectoryName-KenDickey-2020Dec18-15h53m-KenD.001.cs.st----! - -'From Cuis 5.0 [latest update: #4490] on 18 December 2020 at 9:22:56 pm'! -!StringRequestMorph methodsFor: 'private' stamp: 'MJR 12/18/2020 21:19:20' prior: 50560500! - textBox - - ^submorphs detect: [:aSubmorph | aSubmorph isKindOf: TextModelMorph]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4491-StringRequestMorphFix-III-MauroJulianRizzi-2020Dec18-20h52m-MJR.001.cs.st----! - -'From Cuis 5.0 [latest update: #4490] on 20 December 2020 at 11:30:12 am'! -!Morph methodsFor: 'halos and balloon help' stamp: 'KLG 12/19/2020 13:17:06' prior: 50468593! - setBalloonText: stringTextOrSymbol - "Set receiver's balloon help text. Pass nil to remove the help." - - stringTextOrSymbol - ifNil: [ self removeProperty: #balloonText ] - ifNotNil: [ - self - setProperty: #balloonText - toValue: stringTextOrSymbol ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4492-AllowTextInHoverHelp-GeraldKlix-2020Dec20-11h25m-KLG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4384] on 18 December 2020 at 12:16:51 pm'! -!SystemWindow methodsFor: 'resize/collapse' stamp: 'MJR 12/18/2020 12:14:43'! - allowedArea - ^(RealEstateAgent maximumUsableAreaInWorld: self world) insetBy: Theme current fullScreenDeskMargin! ! -!SystemWindow methodsFor: 'resize/collapse' stamp: 'MJR 12/18/2020 12:14:00' prior: 16926623! - resizeBottom - self resize: (self allowedArea top: self allowedArea height // 2)! ! -!SystemWindow methodsFor: 'resize/collapse' stamp: 'MJR 12/18/2020 12:14:00' prior: 16926628! - resizeBottomLeft - self resize: (self allowedArea leftCenter corner: self allowedArea bottomCenter)! ! -!SystemWindow methodsFor: 'resize/collapse' stamp: 'MJR 12/18/2020 12:14:00' prior: 16926634! - resizeBottomRight - self resize: (self allowedArea center corner: self allowedArea corner)! ! -!SystemWindow methodsFor: 'resize/collapse' stamp: 'MJR 12/18/2020 12:14:00' prior: 16926640! - resizeFull - self resize: self allowedArea! ! -!SystemWindow methodsFor: 'resize/collapse' stamp: 'MJR 12/18/2020 12:14:00' prior: 16926644! - resizeLeft - self resize: (self allowedArea right: self allowedArea width // 2)! ! -!SystemWindow methodsFor: 'resize/collapse' stamp: 'MJR 12/18/2020 12:14:00' prior: 16926649! - resizeRight - self resize: (self allowedArea left: self allowedArea width // 2)! ! -!SystemWindow methodsFor: 'resize/collapse' stamp: 'MJR 12/18/2020 12:14:00' prior: 16926654! - resizeTop - self resize: (self allowedArea bottom: self allowedArea height // 2)! ! -!SystemWindow methodsFor: 'resize/collapse' stamp: 'MJR 12/18/2020 12:14:00' prior: 16926659! - resizeTopLeft - self resize: (self allowedArea origin corner: self allowedArea center)! ! -!SystemWindow methodsFor: 'resize/collapse' stamp: 'MJR 12/18/2020 12:14:00' prior: 16926665! - resizeTopRight - self resize: (self allowedArea topCenter corner: self allowedArea rightCenter)! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4493-WindowResizeEnhancements-MauroJulianRizzi-2020Dec18-12h03m-MJR.001.cs.st----! - -'From Cuis 5.0 [latest update: #4488] on 18 December 2020 at 11:16:52 am'! -!IndentingListItemMorph methodsFor: 'initialization' stamp: 'KLG 12/18/2020 11:13:07' prior: 50451881! -initWithContents: anObject prior: priorMorph forList: hostList indentLevel: newLevel - - | o | - container _ hostList. - complexContents _ anObject. - self initWithContents: anObject asString font: Preferences standardListFont emphasis: nil. - indentLevel _ 0. - isExpanded _ false. - nextSibling _ firstChild _ nil. - priorMorph ifNotNil: [ - priorMorph nextSibling: self. - ]. - o _ anObject withoutListWrapper. - icon _ o ifNotNil: [ (o respondsTo: #icon) ifTrue: [ o icon ] ]. - icon isSymbol ifTrue: [ icon _ Theme current perform: icon ]. - indentLevel _ newLevel. -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4494-IndentingListItemMorph-icon-GeraldKlix-2020Dec18-11h10m-KLG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4498] on 23 December 2020 at 12:45:45 pm'! -!HandMorph methodsFor: 'double click support' stamp: 'jmv 12/23/2020 12:35:37'! - waitingForMoreClicks - "Answer true " - - ^mouseClickState notNil! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 12/23/2020 12:45:06' prior: 50551713! - doOneCycle - "Do one cycle of the interaction loop. This method is called repeatedly when the world is running. - - Make for low cpu usage if the ui is inactive, but quick response when ui is in use. - However, after some inactivity, there will be a larger delay before the ui gets responsive again." - - | wait waitUntil | - waitDelay ifNil: [ waitDelay _ Delay forMilliseconds: 50 ]. - (lastCycleHadAnyEvent or: [ - deferredUIMessages isEmpty not or: [ - hands anySatisfy: [ :h | - h waitingForMoreClicks ]]]) - ifTrue: [ - pause _ 20. "This value will only be used when there are no more events to serve." - wait _ 0 ] "Don't wait" - ifFalse: [ - pause < 200 "No events processed? Start saving CPU!! But never make the user wait more than 200ms for being responsive again." - ifTrue: [ pause _ pause * 21//20 ]. - waitUntil _ lastCycleTime + pause. - "Earlier if steps" - stepList isEmpty not ifTrue: [ - waitUntil _ waitUntil min: stepList first scheduledTime ]. - "Earlier if alarms" - alarms ifNotNil: [ - alarms isEmpty not ifTrue: [ - waitUntil _ waitUntil min: alarms first scheduledTime ]]. - - wait _ waitUntil - Time localMillisecondClock ]. - Preferences serverMode - ifTrue: [ wait _ wait max: 50 ]. "Always wait at least a bit on servers, even if this makes the UI slow." - wait > 0 - ifFalse: [ Processor yield ] - ifTrue: [ - waitDelay beingWaitedOn - ifFalse: [ waitDelay setDelay: wait; wait ] - ifTrue: [ - "If we are called from a different process than that of the main UI, we might be called in the main - interCyclePause. In such case, use a new Delay to avoid 'This Delay has already been scheduled' errors" - (Delay forMilliseconds: wait) wait ]]. - - "Record start time of this cycle, and do cycle" - lastCycleTime _ Time localMillisecondClock. - lastCycleHadAnyEvent _ self doOneCycleNow! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4495-FixOccasionalSlowdown-JuanVuletich-2020Dec23-12h43m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4494] on 23 December 2020 at 10:11:41 am'! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'jmv 12/22/2020 11:41:26'! - withPreviousCyclicDo: twoArgBlock - "Evaluate the block with each element and the one before it. - For the first element, previous is the last one. i.e. each object is at some point the first of the pair, and at some other point the second of the pair - (1 to: 10) asArray withPreviousCyclicDo: [ :each :previous | {previous. each} print ] - #(1 2 3) asArray withPreviousCyclicDo: [ :each :previous | {previous. each} print ] - #(1 2) asArray withPreviousCyclicDo: [ :each :previous | {previous. each} print ] - #(1) asArray withPreviousCyclicDo: [ :each :previous | {previous. each} print ] - #() withPreviousCyclicDo: [ :a :b | {a. b} print ] - " - | previous | - self size < 2 ifTrue: [^self ]. - previous _ self last. - self do: [ :each | - twoArgBlock value: each value: previous. - previous _ each ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4496-SequenceableCollection-withPreviousCyclicDo-JuanVuletich-2020Dec23-10h11m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4494] on 23 December 2020 at 10:12:26 am'! -!GeometryTransformation methodsFor: 'testing' stamp: 'jmv 12/17/2020 14:43:53'! - doesMirror - "Return true if the receiver mirrors points around some rect." - - ^false! ! -!AffineTransformation methodsFor: 'testing' stamp: 'jmv 12/21/2020 17:06:08' overrides: 50560820! - doesMirror - "Return true if the receiver mirrors points around some rect." - - | f | - f _ self a11 * self a22. - ^ f = 0.0 - ifTrue: [ self a12 * self a21 > 0.0] - ifFalse: [ f < 0.0 ]! ! -!AffineTransformation methodsFor: 'transforming rects' stamp: 'jmv 12/21/2020 18:31:50'! - boundsOfInverseTransformOf: aRectangle - "Internalize aRectangle, and find a bounding rectangle with horizontal - and vertical bounds" - - ^Rectangle encompassing: (aRectangle corners collect: [ :pt | - self inverseTransform: pt ])! ! -!MorphicTranslation methodsFor: 'transforming rects' stamp: 'jmv 12/21/2020 18:35:37'! -boundsOfInverseTransformOf: aRectangle - "Externalize aRectangle, and find a bounding rectangle with horizontal - and vertical bounds and integer coordinates (i.e. adisplayBounds)." - - ^aRectangle translatedBy: self translation negated! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4497-GeometryTransformation-enh-JuanVuletich-2020Dec23-10h11m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4494] on 23 December 2020 at 10:14:31 am'! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 12/21/2020 17:47:59'! - drawString: s atBaseline: pt font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - ^self drawString: s from: 1 to: s size atBaseline: pt font: fontOrNil color: aColor! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 12/21/2020 17:58:56'! - drawString: s atCenterX: pt font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | font | - font _ self fontToUse: fontOrNil. - ^font - ifNil: [ pt ] - ifNotNil: [ - self - drawString: s - from: 1 to: s size - at: pt - ((font widthOfString: s) / 2 @ 0) - font: fontOrNil color: aColor ]! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 12/21/2020 17:47:24'! - drawString: s atWaist: pt font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - ^self drawString: s from: 1 to: s size atWaist: pt font: fontOrNil color: aColor! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 12/21/2020 17:52:31'! - drawString: s atWaistRight: pt font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | font | - font _ self fontToUse: fontOrNil. - ^font - ifNil: [ pt ] - ifNotNil: [ - self - drawString: s - from: 1 to: s size - atWaist: pt - ((font widthOfString: s) @ 0) - font: fontOrNil color: aColor ]! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 12/21/2020 17:26:18'! - drawString: aString from: firstIndex to: lastIndex atBaseline: aPoint font: fontOrNil color: aColor - self subclassResponsibility ! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 12/21/2020 17:32:21'! - drawString: aString from: firstIndex to: lastIndex atWaist: aPoint font: fontOrNil color: aColor - self subclassResponsibility ! ! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 12/21/2020 17:36:19'! - fontToUse: fontOrNil - "Answer a suitable font, aFont if possible." - - self subclassResponsibility ! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 12/21/2020 17:38:00' overrides: 50560911! - drawString: aString from: firstIndex to: lastIndex atBaseline: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | p1 font | - engine ifNil: [ ^nil ]. - - "Don't waste any time if NOP" - lastIndex = 0 ifTrue: [ - ^nil ]. - - p1 _ (currentTransformation transform: aPoint rounded) rounded. - engine colorMap: nil. - font _ self fontToUse: fontOrNil. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + (0@(0 - (font ascent + font lineGap-1))) - color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 12/21/2020 17:46:18' overrides: 50560918! - drawString: aString from: firstIndex to: lastIndex atWaist: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | p1 font | - engine ifNil: [ ^nil ]. - - "Don't waste any time if NOP" - lastIndex = 0 ifTrue: [ - ^nil ]. - - p1 _ (currentTransformation transform: aPoint rounded) rounded. - engine colorMap: nil. - font _ self fontToUse: fontOrNil. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + (0@(0 - (font ascent * 2 // 3 + font lineGap-1))) - color: aColor! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 12/21/2020 17:36:15' overrides: 50560925! - fontToUse: fontOrNil - "Answer a suitable font, aFont if possible." - - ^fontOrNil ifNil: [ FontFamily defaultFamilyAndPointSize ].! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 12/21/2020 17:37:33' prior: 50533178 overrides: 50463524! - drawString: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | p1 | - engine ifNil: [ ^nil ]. - - "Don't waste any time if NOP" - lastIndex = 0 ifTrue: [ - ^nil ]. - - p1 _ (currentTransformation transform: aPoint rounded) rounded. - engine colorMap: nil. - ^(self fontToUse: fontOrNil) - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 12/21/2020 17:38:13' prior: 50533199 overrides: 50388595! - drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - | p1 font | - - engine ifNil: [ ^nil ]. - - p1 _ (currentTransformation transform: aPoint rounded) rounded. - engine colorMap: nil. - font _ self fontToUse: fontOrNil. - - aColor = `Color black` ifFalse: [ | topColor | - topColor _ aColor alphaMixed: 0.25 with: `Color black`. - font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: topColor ]. - aColor = `Color white` ifFalse: [ | bottomColor | - bottomColor _ aColor alphaMixed: 0.22 with: `Color white`. - font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + `0@2` - color: bottomColor ]. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + `0@1` - color: aColor.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4498-MorphicCanvas-additional-drawString-protocol-JuanVuletich-2020Dec23-10h12m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4494] on 23 December 2020 at 10:12:54 am'! -!HaloMorph methodsFor: 'initialization' stamp: 'jmv 12/22/2020 16:57:41' overrides: 16876882! - delete - - super delete. - target ifNotNil: [ target redrawNeeded ].! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 12/22/2020 16:59:58' prior: 50544291! - addHalo: evt - | halo | - self displayBoundsForHalo ifNotNil: [ :r | - halo _ HaloMorph new. - halo popUpFor: self event: evt. - halo morphBounds: r ]. - self whenUIinSafeState: [self redrawNeeded]. - ^halo! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4499-HaloMorph-tweak-JuanVuletich-2020Dec23-10h12m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4499] on 23 December 2020 at 1:18:50 pm'! -!StrikeFont methodsFor: 'accessing' stamp: 'jmv 12/23/2020 13:11:47'! - lineGap - "Leading of the font." - ^0! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 12/22/2020 14:59:45'! - postDrawOn: aCanvas - "A canvas is already set with a proper transformation from our coordinates to those of the Canvas target. - Possible second stage of drawing, after drawing submorphs, and on top of them"! ! -!BitBltCanvas methodsFor: 'drawing' stamp: 'jmv 12/23/2020 13:15:20'! - drawCoordinateSystem: aRectangle - | c stepX stepY x0 x1 y0 y1 | - stepX _ 100. - stepY _ 50. - - self fillRectangle: aRectangle color: `Color lightGray alpha: 0.4`. - - x0 _ aRectangle left. - x1 _ aRectangle right-1. - y0 _ aRectangle top. - y1 _ aRectangle bottom-1. - - c _ `Color white alpha: 0.6`. - self line: x0@0 to: x1@0 width: 2 color: c. - self line: 0@y0 to: 0@y1 width: 2 color: c. - - (x0 truncateTo: stepX) to: (x1 - stepX truncateTo: stepX) by: stepX do: [ :x | - self line: x @ -5 to: x @ 5 width: 2 color: c. - self drawString: x printString atCenterX: x @ 5 font: nil color: c ]. - self drawString: 'x' atCenterX: x1 - 15 @ 0 font: nil color: c. - - (y0 truncateTo: stepY) to: (y1 - stepY truncateTo: stepY) by: stepY do: [ :y | - self line: -5 @ y to: 5 @ y width: 2 color: c. - self drawString: y printString, ' ' atWaist: 5 @ y font: nil color: c ]. - self drawString: 'y' atWaist: 0 @ (y1 - 20) font: nil color: c.! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 12/23/2020 13:15:32' overrides: 50557181! - drawCurrentAndSubmorphs - | b | - self isCurrentMorphVisible ifTrue: [ - currentMorph drawOn: self. - world notNil ifTrue: [ "Only if we are drawing the world" - currentMorph halo ifNotNil: [ b _ currentMorph morphLocalBounds ]. - currentMorph displayBounds: self boundingRectOfCurrentMorphAfterDraw ]. - "Display submorphs back to front" - "coordinate system stack already set up for aMorph - ('ivars transformations' and 'currentTransformation')" - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | self fullDraw: m ]]. - currentMorph postDrawOn: self. - b ifNotNil: [ - self drawCoordinateSystem: b ]. - world notNil ifTrue: [ "Only if we are drawing the world" - currentMorph displayBounds: - (currentMorph displayBounds quickMerge: self boundingRectOfCurrentMorphAfterDraw) ]].! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 12/23/2020 12:52:05' prior: 50557181! - drawCurrentAndSubmorphs - - self isCurrentMorphVisible ifTrue: [ - currentMorph drawOn: self. - world notNil ifTrue: [ "Only if we are drawing the world" - currentMorph displayBounds: self boundingRectOfCurrentMorphAfterDraw ]. - "Display submorphs back to front" - "coordinate system stack already set up for aMorph - ('ivars transformations' and 'currentTransformation')" - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | self fullDraw: m ]]. - currentMorph postDrawOn: self. - world notNil ifTrue: [ "Only if we are drawing the world" - currentMorph displayBounds: - (currentMorph displayBounds quickMerge: self boundingRectOfCurrentMorphAfterDraw) ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4500-HaloDrawsCoordinateSystem-JuanVuletich-2020Dec23-13h17m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4500] on 23 December 2020 at 3:41:35 pm'! -!EventSensor methodsFor: 'mouse' stamp: 'jmv 12/23/2020 15:40:29' prior: 16839399! - createMouseEvent - "create and return a new mouse event from the current mouse - position; this is useful for restarting normal event queue - processing after manual polling" - - | buttons modifiers pos mapped eventBuffer | - eventBuffer _ Array new: 8. - buttons _ self primMouseButtons. - pos _ self primMousePt. - modifiers _ buttons bitShift: -3. - buttons _ buttons bitAnd: 7. - mapped _ self mapButtons: buttons modifiers: modifiers. - eventBuffer - at: 1 put: EventSensor eventTypeMouse; - at: 2 put: Time millisecondClockValue; "VMs report events using #millisecondClockValue" - at: 3 put: pos x; - at: 4 put: pos y; - at: 5 put: mapped; - at: 6 put: modifiers. - ^ eventBuffer! ! -!EventSensor methodsFor: 'private-I/O' stamp: 'jmv 12/23/2020 15:40:15' prior: 16839601! - primGetNextEvent: array - "Store the next OS event available into the provided array. - Essential. If the VM is not event driven the ST code will fall - back to the old-style mechanism and use the state based - primitives instead." - | kbd buttons modifiers pos mapped | - - "Simulate the events" - array at: 1 put: EventSensor eventTypeNone. "assume no more events" - - "First check for keyboard" - kbd _ super primKbdNext. - kbd ifNotNil: [ - "simulate keyboard event" - array at: 1 put: EventSensor eventTypeKeyboard. "evt type" - array at: 2 put: Time millisecondClockValue. "VMs report events using #millisecondClockValue" - array at: 3 put: (kbd bitAnd: 255). "char code" - array at: 4 put: EventSensor eventKeyChar. "key press/release" - array at: 5 put: (kbd bitShift: -8). "modifier keys" - ^self]. - - "Then check for mouse" - buttons _ super primMouseButtons. - pos _ super primMousePt. - modifiers _ buttons bitShift: -3. - buttons _ buttons bitAnd: 7. - mapped _ self mapButtons: buttons modifiers: modifiers. - (pos = mousePosition and:[(mapped bitOr: (modifiers bitShift: 3)) = mouseButtons]) - ifTrue:[^self]. - array - at: 1 put: EventSensor eventTypeMouse; - at: 2 put: Time millisecondClockValue; "VMs report events using #millisecondClockValue" - at: 3 put: pos x; - at: 4 put: pos y; - at: 5 put: mapped; - at: 6 put: modifiers. -! ! -!EventSensor methodsFor: 'test' stamp: 'jmv 12/23/2020 15:39:38' prior: 16839733! - printEventBuffer: evtBuf - - | type buttons macRomanCode modifiers position pressType stamp unicodeCodePoint | - type _ evtBuf first. - stamp _ evtBuf second. - stamp = 0 ifTrue: [ stamp := Time millisecondClockValue ]. "VMs report events using #millisecondClockValue" - type = EventSensor eventTypeMouse - ifTrue: [ - position _ evtBuf third @ evtBuf fourth. - buttons _ evtBuf fifth. - modifiers _ evtBuf sixth. - Transcript - newLine; - show: 'Mouse'; - show: ' position:', position printString; - show: ' buttons:', buttons printString; - show: ' modifiers:', modifiers printString. - ]. - type = EventSensor eventTypeKeyboard - ifTrue: [ - macRomanCode _ evtBuf third. - unicodeCodePoint _ evtBuf sixth. - pressType _ evtBuf fourth. - modifiers _ evtBuf fifth. - pressType = EventSensor eventKeyDown ifTrue: [ - type _ #keyDown]. - pressType = EventSensor eventKeyUp ifTrue: [ - type _ #keyUp]. - pressType = EventSensor eventKeyChar ifTrue: [ - type _ #keystroke]. - Transcript - newLine; - show: type; - show: ' macRomanCode:', macRomanCode printString, '-', - (Character numericValue: (Character macRomanToLatin1: macRomanCode)) asString, '-'; - show: ' unicodeCodePoint:', unicodeCodePoint printString. - (Character iso8859s15CodeForUnicodeCodePoint: unicodeCodePoint) ifNotNil: [ :latin15 | - Transcript show: '-', (Character numericValue: latin15) asString, '-' ]. - Transcript - show: ' modifiers:', modifiers printString. - (modifiers anyMask: 8) ifTrue: [ Transcript show: ' [commandWinAlt]' ]. - (modifiers anyMask: 4) ifTrue: [ Transcript show: ' [macOption]' ]. - (modifiers anyMask: 2) ifTrue: [ Transcript show: ' [control]' ]. - (modifiers anyMask: 1) ifTrue: [ Transcript show: ' [shift]' ]. - ].! ! -!HandMorph methodsFor: 'private events' stamp: 'jmv 12/23/2020 15:38:50' prior: 50424831! - generateDropFilesEvent: evtBuf - "Generate the appropriate mouse event for the given raw event buffer" - - | position stamp numberOfFiles dragType | - - stamp := evtBuf second. - stamp = 0 ifTrue: [stamp := Time millisecondClockValue]. "VMs report events using #millisecondClockValue" - dragType := evtBuf third. - position := evtBuf fourth @ evtBuf fifth. - numberOfFiles := evtBuf seventh. - - ^ dragType = 4 ifTrue: [ DropFilesEvent at: position with: numberOfFiles from: self]. -! ! -!HandMorph methodsFor: 'private events' stamp: 'jmv 12/23/2020 15:38:47' prior: 50466190! - generateKeyboardEvent: evtBuf - "Generate the appropriate mouse event for the given raw event buffer" - | buttons modifiers type keyValue pressType stamp mouseScrollDirection | - stamp _ evtBuf second. - stamp = 0 ifTrue: [ stamp _ Time millisecondClockValue ]. "VMs report events using #millisecondClockValue" - (evtBuf sixth <= 0 or: [ (keyValue _ Character iso8859s15CodeForUnicodeCodePoint: evtBuf sixth) isNil ]) ifTrue: [ keyValue _ Character macRomanToLatin1: evtBuf third ]. - Sensor peekEvent ifNotNil: [ :nxt | - "start: Combining diacritical marks (i.e. accents in the Linux VM)" - (nxt fourth = EventSensor eventKeyDown and: [ nxt third > 255 ]) ifTrue: [ - keyValue _ ((Character numericValue: keyValue) withDiacriticalMark: nxt third) iso8859s15Code. - Sensor - nextEvent; - nextEvent; - nextEvent ]. - "end: Combining diacritical marks (i.e. accents in the Linux VM)" - "start: Spurious LF after CR on Ctrl-Enter on Windows VM" - ((evtBuf fourth = EventSensor eventKeyChar and: [ evtBuf third = 13 ]) and: [ - nxt fourth = EventSensor eventKeyChar and: [ nxt third = 10 ]]) ifTrue: [ Sensor nextEvent - "print " ]]. - modifiers _ evtBuf fifth. - pressType _ evtBuf fourth. - pressType = EventSensor eventKeyDown ifTrue: [ - type _ #keyDown. - lastKeyDownValue _ keyValue ]. - pressType = EventSensor eventKeyUp ifTrue: [ - (keyValue = 9 and: [(modifiers anyMask: 1) and: [Smalltalk platformName = 'unix']]) - ifTrue: [ - "Linux VMs don't generate shift-tab keystroke. Turn #keyUp into #keystroke" - pressType _ EventSensor eventKeyChar ] - ifFalse: [type _ #keyUp ]]. - pressType = EventSensor eventKeyChar ifTrue: [ - type _ #keystroke. - "If Control key pressed, and the VM answers a code below 27, - it means it did the translation, convert it back to regular character: - We want to handle the meaning of ctrl ourselves." - (modifiers anyMask: 2) ifTrue: [ - "Control key pressed" - keyValue < 27 ifTrue: [ - "But we don't want to do it for Home/End/PgUp/PgDn, just for alphabetic keys" - lastKeyDownValue = keyValue ifFalse: [ - "If equal, real Home/End/PgUp/PgDn in Windows => don't translate" - (keyValue + 64 = lastKeyDownValue or: [ "If Equal, Ctrl-alphabetic in Windows => do translate" - lastKeyDownValue < 47 ]) ifTrue: [ - "Not on windows. If less (not sure about the bound, but do not translate 48: tab on Mac), alphabetic on Mac => do translate" - keyValue _ (modifiers anyMask: 1) - ifTrue: [ keyValue + 64 ] - ifFalse: [ keyValue + 96 - "shift not pressed: conver to lowercase letter" ]]]]. - "On Windows, ctrl-backSpace is reported as ctrl-forwardDelete. But keyDown is ok, so we can know and fix." - (keyValue = 127 and: [ lastKeyDownValue = 8 ]) - ifTrue: [ keyValue _ 8 ]. - "Act as if command/alt was pressed for some usual Windows ctrl-key combinations" - (self shouldControlEmulateAltFor: keyValue) ifTrue: [ modifiers _ modifiers bitOr: 8 ]]]. - buttons _ modifiers bitShift: 3. - "Linux and Windows VM send keyboard ctrl-upArrow and ctrl-downArrow when the user tries to scroll using the mouse wheel - Mac VM sends cmd-option-ctrl-shift-upArrow and cmd-option-ctrl-shift-downArrow for trackpad vertical scroll gestures, - and cmd-option-ctrl-shift-leftArrow and cmd-option-ctrl-shift-rightArrow for horizontal scroll gestures. - This way of reporting scroll events by the VM also enables scrolling using the keyboard (actually, we can't tell if user gesture was on Mouse, Trackpad or Keyboard). - But ctrl-shift and cmdAlt-shift are needed used for selecting while moving by word, line, etc. - Additionally, #ctrlArrowsScrollHorizontally allows chosing between keyboard horizontal scroll and moving word by word in text editors." - mouseScrollDirection _ nil. - "Ctrl for Keyboard or Mouse wheel gestures. All modifiers for Trackpad gestures." - (buttons = InputSensor controlKey or: [buttons = InputSensor cmdAltOptionCtrlShiftModifierKeys]) ifTrue: [ - keyValue = 30 - ifTrue: [mouseScrollDirection _ #up] - ifFalse: [keyValue = 31 - ifTrue: [mouseScrollDirection _ #down]]]. - "Ctrl for Keyboard or Mouse wheel gestures, only if preference is set. All modifiers for Trackpad gestures." - ((buttons = InputSensor controlKey and: [Preferences ctrlArrowsScrollHorizontally]) or: [buttons = InputSensor cmdAltOptionCtrlShiftModifierKeys]) ifTrue: [ - keyValue = 28 - ifTrue: [mouseScrollDirection _ #left] - ifFalse: [keyValue = 29 - ifTrue: [mouseScrollDirection _ #right]]]. - mouseScrollDirection ifNotNil: [ - ^ MouseScrollEvent new - setType: #mouseScroll - position: self morphPosition - direction: mouseScrollDirection - buttons: buttons - hand: self - stamp: stamp ]. - ^ KeyboardEvent new - setType: type - buttons: buttons - position: self morphPosition - keyValue: keyValue - hand: self - stamp: stamp! ! -!HandMorph methodsFor: 'private events' stamp: 'jmv 12/23/2020 15:38:43' prior: 16852308! - generateMouseEvent: evtBuf - "Generate the appropriate mouse event for the given raw event buffer" - - | pos buttons modifiers type trail stamp oldButtons | - stamp := evtBuf second. - stamp = 0 ifTrue: [ stamp := Time millisecondClockValue ]. "VMs report events using #millisecondClockValue" - pos := evtBuf third @ evtBuf fourth. - buttons := evtBuf fifth. - modifiers := evtBuf sixth. - type := buttons = 0 - ifTrue: [ - lastEventBuffer fifth = 0 ifTrue: [#mouseMove] ifFalse: [#mouseUp]] - ifFalse: [ - lastEventBuffer fifth = 0 - ifTrue: [#mouseDown] - ifFalse: [#mouseMove]]. - buttons := buttons bitOr: (modifiers bitShift: 3). - oldButtons := lastEventBuffer fifth - bitOr: (lastEventBuffer sixth bitShift: 3). - lastEventBuffer := evtBuf. - type == #mouseMove - ifTrue: [ - trail := self mouseTrailFrom: evtBuf. - ^MouseMoveEvent new - setType: type - position: trail last - buttons: buttons - hand: self - stamp: stamp]. - ^MouseButtonEvent new - setType: type - position: pos - which: (oldButtons bitXor: buttons) - buttons: buttons - hand: self - stamp: stamp! ! -!HandMorph methodsFor: 'private events' stamp: 'jmv 12/23/2020 15:38:39' prior: 16852343! - generateWindowEvent: evtBuf - "Generate the appropriate window event for the given raw event buffer" - - | evt | - evt := WindowEvent new. - evt setTimeStamp: evtBuf second. - evt timeStamp = 0 ifTrue: [evt setTimeStamp: Time millisecondClockValue]. "VMs report events using #millisecondClockValue" - evt windowAction: evtBuf third. - evt rectangle: (Rectangle origin: evtBuf fourth @ evtBuf fifth corner: evtBuf sixth @ evtBuf seventh ). - - ^evt! ! -!MorphicEvent methodsFor: 'accessing' stamp: 'jmv 12/23/2020 15:39:20' prior: 16877771! - timeStamp - "Return the millisecond clock value at which the event was generated" - ^timeStamp ifNil:[timeStamp _ Time millisecondClockValue ]. "VMs report events using #millisecondClockValue"! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4501-SyntheticEventsUseSameTimerAsVMevents-JuanVuletich-2020Dec23-15h21m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4501] on 28 December 2020 at 2:58:24 pm'! -!NegativePowerError methodsFor: 'exceptionDescription' stamp: 'jmv 12/28/2020 14:58:01' overrides: 50466123! - defaultAction - - "Disable this preference to have Float nan answer (if Float receiver or argument) or Error message" - | answer | - Preferences askToInstallComplexPackage ifTrue: [ - answer _ PopUpMenu - withCaption: -'Square (or even) Root of a negative Number: -Complex number support is not loaded -Would you like me to load it for you now?' - chooseFrom: #( - 'Load Complex package' - 'Do not load Complex package' - 'Do not load Complex package and don''t ask again'). - answer = 1 ifTrue: [ - Feature require: #'Complex'. - Smalltalk at: #Complex ifPresent: [ :cplx | - ^ (cplx basicReal: receiver imaginary: 0) perform: selector withArguments: arguments ]]. - answer = 3 ifTrue: [ - Preferences disable: #askToInstallComplexPackage ]]. - ^ super defaultAction! ! -!Preferences class methodsFor: 'personalization' stamp: 'jmv 12/26/2020 14:14:32'! - askToInstallComplexPackage - ^ self - valueOfFlag: #askToInstallComplexPackage - ifAbsent: [ true ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4502-AskToInstallComplexPackage-JuanVuletich-2020Dec28-14h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4502] on 28 December 2020 at 3:49:26 pm'! -!CompiledMethod methodsFor: 'copying' stamp: 'KLG 12/23/2020 18:11:13' overrides: 50459175! - flattenTo: flattenedStream - "No senese in flattening the method's bytes." - - flattenedStream nextPut: self! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4503-CompiledMethod-flattenTo-GeraldKlix-2020Dec28-15h49m-KLG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4503] on 29 December 2020 at 2:43:10 pm'! -!Character class methodsFor: 'instance creation' stamp: 'jmv 12/29/2020 14:32:32'! - codePoint: codePoint trySimilar: aBoolean - " - Answer an appropriante Character. - If we don't have a suitable Character for codePoint, answer nil. - But if aBoolean, answer a similar Character if possible. - - self assert: (Character codePoint: 16r41 convertToASCII: false) = $A. - self assert: (Character codePoint: 16r20AC convertToASCII: false) = $¤. - " - | codePoints similarCharacters | - aBoolean ifTrue: [ - (codePoint between: 16r2018 and: 16r201B) ifTrue: [ - ^$' ]. - (codePoint between: 16r201C and: 16r201F) ifTrue: [ - ^$" ]. - (codePoint between: 16r2000 and: 16r200D) ifTrue: [ - ^$ ]. - (codePoint between: 16r2010 and: 16r2015) ifTrue: [ - ^$- ]. - (codePoint between: 16r2024 and: 16r2026) ifTrue: [ - ^$- ]. - codePoints _ #(16r2190 16r2191 16r2022 16r2023 16r2027 16r2032 16r2033 16r2035 16r2036 16r2039 16r203A). - similarCharacters _ #($_ $^ $° $° $- $' $" $` $" $< $>). - (codePoints statePointsTo: codePoint) ifTrue: [ - ^ similarCharacters at: (codePoints indexOf: codePoint) ]]. - - ^ (self iso8859s15CodeForUnicodeCodePoint: codePoint) - ifNotNil: [ :code | Character numericValue: code ]! ! -!Character class methodsFor: 'instance creation' stamp: 'jmv 12/29/2020 14:04:54' prior: 16800965! - codePoint: codePoint - " - Answer nil if the Unicode codePoint is not a valid ISO 8859-15 character - - self assert: (Character codePoint: 16r41) = $A. - self assert: (Character codePoint: 16r20AC) = $¤. - " - ^ self codePoint: codePoint trySimilar: false! ! -!String class methodsFor: 'instance creation' stamp: 'jmv 12/29/2020 13:03:32' prior: 16917779! - addUnicodeCodePoint: codePoint to: strm hex: useHexForNCRs - "Convert the given Unicode codePoint to the internal encoding: ISO Latin 9 (ISO 8859-15)" - "For unicode chars not in ISO Latin 9 (ISO 8859-15), embed Decimal NCRs or Hexadecimal NCRs according to useHex. - - See http://en.wikipedia.org/wiki/Numeric_character_reference - See http://rishida.net/tools/conversion/. Tests prepared there. - - Note: The conversion of NCRs is reversible. See #asUtf8: - This allows handling the full Unicode in Cuis tools, that can only display the Latin alphabet, by editing the NCRs. - The conversions can be done when reading / saving files, or when pasting from Clipboard and storing back on it." - - (Character codePoint: codePoint trySimilar: true) - ifNotNil: [ :char | strm nextPut: char] - ifNil: [ - useHexForNCRs - ifTrue: [ - strm nextPutAll: '&#x'. - codePoint printOn: strm base: 16 length: 4 padded: true. - strm nextPut: $; ] - ifFalse: [ - strm nextPutAll: '&#'. - codePoint printOn: strm base: 10. - strm nextPut: $; ]]! ! - -Character class removeSelector: #safeCodePoint:! - -!methodRemoval: Character class #safeCodePoint: stamp: 'Install-4504-AutoConvertSomeUnicode-JuanVuletich-2020Dec29-14h42m-jmv.001.cs.st 12/30/2020 14:48:21'! -safeCodePoint: asciiCodeOrCodePoint - "Answer the Character whose value is anInteger. - Handle unicode code points > 255 without errors, trying to answer something reasonable" - - "Note: senders of #value:or: in '1002-RTFParser.cs' has many automatic conversion to ISO-8859-15 characters, that would be valuable here." - (#(16r2019 16r201B) includes: asciiCodeOrCodePoint) ifTrue: [ - ^$' ]. - (#(16r201C 16r201D 16r201F) includes: asciiCodeOrCodePoint) ifTrue: [ - ^$" ]. - ^(self codePoint: asciiCodeOrCodePoint) - ifNil: [Character numericValue: 255 ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4504-AutoConvertSomeUnicode-JuanVuletich-2020Dec29-14h42m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4503] on 29 December 2020 at 12:16:28 pm'! -!Debugger methodsFor: 'private' stamp: 'HAW 12/29/2020 12:15:11' prior: 16830205! - selectedContext - contextStackIndex = 0 - ifTrue: [^contextStackTop] - ifFalse: [^contextStack ifNotNil: [ :aContextStack | aContextStack at: contextStackIndex]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4505-contextStackCanBeNilFix-HernanWilkinson-2020Dec29-12h15m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4505] on 29 December 2020 at 4:43:13 pm'! -!Scanner class methodsFor: 'error descriptions' stamp: 'HAW 12/29/2020 13:17:59'! - unmatechedCommentQuoteErrorDescription - - ^'Unmatched comment quote'! ! -!String methodsFor: 'converting' stamp: 'jmv 12/29/2020 16:46:01' prior: 16916985! - withoutEnclosing: aCharacter - " - '*Hello*' withoutEnclosing: $* - " - | s | - s _ self size. - s = 0 ifTrue: [ ^ self ]. - ^((self at: 1) = aCharacter and: [ (self at: s) = aCharacter ]) - ifTrue: [ self copyFrom: 2 to: s-1 ] - ifFalse: [ self ]! ! -!String methodsFor: 'converting' stamp: 'jmv 12/29/2020 16:42:03' prior: 50422528! - findSelector - "Revised to use scanner for better removal of extraneous stuff" - | potentialSelector colonIndex | - potentialSelector _ self withBlanksTrimmed withoutEnclosing: $". - colonIndex _ potentialSelector indexOf: $:. - "possible keyword selector" - (colonIndex > 1 and: [ (potentialSelector at: colonIndex - 1) isLetter ]) ifTrue: [ - potentialSelector _ [ Scanner findSelectorIn: potentialSelector ] on: Error do: [ :anError | - anError messageText = Scanner unmatechedCommentQuoteErrorDescription - ifTrue: [ - potentialSelector _ potentialSelector copyWithout: $". - anError retry ] - ifFalse: [ anError return: '']]]. - - potentialSelector isEmpty ifTrue: [ ^ nil ]. - Symbol - hasInterned: potentialSelector - ifTrue: [ :aSymbol | ^ aSymbol ]. - - ^ nil.! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'HAW 12/29/2020 13:18:18' prior: 50427993! - xDoubleQuote - "Collect a comment." - "wod 1/10/98: Allow 'empty' comments by testing the first character -for $"" rather than blindly adding it to the comment being collected." - | aStream stopChar | - stopChar := DoItCharacter. - aStream := WriteStream on: (String new: 200). - self step. - [hereChar == $"] - whileFalse: - [(hereChar == stopChar and: [source atEnd]) - ifTrue: [^self offEnd: self class unmatechedCommentQuoteErrorDescription]. - aStream nextPut: self step.]. - self step. - currentComment == nil - ifTrue: [currentComment := OrderedCollection with: aStream contents] - ifFalse: [currentComment add: aStream contents]. - self scanToken! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4506-findSelectorFix-HernanWilkinson-2020Dec29-16h36m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4506] on 30 December 2020 at 2:38:52 pm'! -!String methodsFor: 'converting' stamp: 'jmv 12/30/2020 14:38:23' prior: 50561747! - findSelector - "Revised to use scanner for better removal of extraneous stuff" - | potentialSelector colonIndex | - potentialSelector _ self withBlanksTrimmed withoutEnclosing: $". - colonIndex _ potentialSelector indexOf: $:. - "possible keyword selector" - (colonIndex > 1 and: [ (potentialSelector at: colonIndex - 1) isValidInIdentifiers ]) ifTrue: [ - potentialSelector _ [ Scanner findSelectorIn: potentialSelector ] on: Error do: [ :anError | - anError messageText = Scanner unmatechedCommentQuoteErrorDescription - ifTrue: [ - potentialSelector _ potentialSelector copyWithout: $". - anError retry ] - ifFalse: [ anError return: '']]]. - - potentialSelector isEmpty ifTrue: [ ^ nil ]. - Symbol - hasInterned: potentialSelector - ifTrue: [ :aSymbol | ^ aSymbol ]. - - ^ nil.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4507-findSelectorFix-JuanVuletich-2020Dec30-14h38m-jmv.001.cs.st----! - -----SNAPSHOT----(30 December 2020 14:48:23) Cuis5.0-4507-v3.image priorSource: 7151512! - -----STARTUP---- (7 January 2021 16:18:25) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4507-v3.image! - - -'From Cuis 5.0 [latest update: #4506] on 29 December 2020 at 7:19:51 pm'! -!MethodContext methodsFor: 'instruction decoding (closures)' stamp: 'HAW 12/29/2020 19:19:31'! - callPrimitive: primNumber - "Evaluate the primitive, either normal or inlined, and answer the new context resulting from that - (either the sender if a successful non-inlined primitive, or the current context, if not)." - "Copied from Squeak, Context>>#callPrimitive: - The message callInlinedPrimitive: is not implemented in Squeak also - Hernan" - - | maybePrimFailToken | - primNumber >= (1 << 15) ifTrue: "Inlined primitive, cannot fail" - [^self callInlinedPrimitive: primNumber]. - maybePrimFailToken := self doPrimitive: primNumber - method: method - receiver: receiver - args: self arguments. - "Normal primitive. Always at the beginning of methods." - (self isPrimFailToken: maybePrimFailToken) ifFalse: "On success return the result" - [^self methodReturnTop]. - "On failure, store the error code if appropriate and keep interpreting the method" - (method encoderClass isStoreAt: pc in: method) ifTrue: - [self at: stackp put: maybePrimFailToken last]. - ^self! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4508-callPrimitive-HernanWilkinson-2020Dec29-19h19m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4384] on 30 December 2020 at 7:32:37 pm'! -!ContextPart methodsFor: 'closure support' stamp: 'HAW 12/30/2020 19:31:45'! - contextTag - "Context tags may be used for referring to contexts instead of contexts themselves as they can be copied and will continue to work in other processes (continuations). By default, we use the context itself to as its tag." - ^self! ! - -MethodContext removeSelector: #contextTag! - -!methodRemoval: MethodContext #contextTag stamp: 'Install-4509-contextTagMovedToSuper-HernanWilkinson-2020Dec30-19h30m-HAW.001.cs.st 1/7/2021 16:18:30'! -contextTag - "Context tags may be used for referring to contexts instead of contexts themselves as they can be copied and will continue to work in other processes (continuations). By default, we use the context itself to as its tag." - ^self! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4509-contextTagMovedToSuper-HernanWilkinson-2020Dec30-19h30m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4384] on 30 December 2020 at 7:34:30 pm'! -!TestCase methodsFor: 'assertions' stamp: 'HAW 12/30/2020 19:33:44' prior: 16927604! - assert: expected equals: actual - ^ self - assert: expected = actual - description: [ self comparingStringBetween: expected and: actual ] -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4510-assertEqualsDescriptionsDelayedUntilNeccesary-HernanWilkinson-2020Dec30-19h32m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4494] on 1 January 2021 at 3:56:49 pm'! - -PluggableScrollPane subclass: #PluggableListMorph - instanceVariableNames: 'list getListSelector getIndexSelector setIndexSelector keystrokeActionSelector autoDeselect lastKeystrokeTime lastKeystrokes doubleClickSelector menuGetter mainView leftSibling rightSibling scrollSiblings ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #PluggableListMorph category: 'Morphic-Widgets' stamp: 'Install-4511-MultiListScroll-KenDickey-2020Dec31-11h39m-KenD.002.cs.st 1/7/2021 16:18:30'! -PluggableScrollPane subclass: #PluggableListMorph - instanceVariableNames: 'list getListSelector getIndexSelector setIndexSelector keystrokeActionSelector autoDeselect lastKeystrokeTime lastKeystrokes doubleClickSelector menuGetter mainView leftSibling rightSibling scrollSiblings' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! -!PluggableListMorph commentStamp: '' prior: 16888551! - ... - -When a PluggableListMorph is in focus, type in a letter (or several -letters quickly) to go to the next item that begins with that letter. -Special keys (up, down, home, etc.) are also supported. - -leftSibling and rightSibling have two uses. - [A] One can use left and right arrow keys to shift focus to a sibling - [B] When scrollSiblings is true, one can do "multiscrolling" -- vertical scroll siblings with self - -For [B] Sample usage see: CodePackageListWindow >>buildMorphicWindow! -!PluggableScrollPane methodsFor: 'access options' stamp: 'KenD 12/31/2020 13:05:54'! - alwaysHideVerticalScrollbar - - hideScrollBars _ #alwaysHideVertical. - self vHideScrollBar.! ! -!PluggableListMorph methodsFor: 'siblings' stamp: 'KenD 1/1/2021 13:10:42'! - scrollSiblings - "Do I scroll my siblings with myself?" - ^ scrollSiblings! ! -!PluggableListMorph methodsFor: 'siblings' stamp: 'KenD 1/1/2021 13:11:00'! - scrollSiblings: aBoolean - "Do I scroll my siblings with myself?" - scrollSiblings := aBoolean! ! -!PluggableListMorph methodsFor: 'scrolling' stamp: 'KenD 1/1/2021 13:14:57' overrides: 50406125! - scrollBy: delta - "Scroll self and any siblings" - super scrollBy: delta. - self scrollMySiblings! ! -!PluggableListMorph methodsFor: 'scrolling' stamp: 'KenD 1/1/2021 15:34:25'! - scrollMySiblings - "vertical scroll my siblings along with my self" - | yOffset | - yOffset := self scrollerOffset y. - scrollSiblings ifTrue: [ - self vScrollLeftSibling: yOffset; - vScrollRightSibling: yOffset - ]! ! -!PluggableListMorph methodsFor: 'scrolling' stamp: 'KenD 1/1/2021 13:14:49' prior: 50365043 overrides: 16889986! - scrollSelectionIntoView - "make sure that the current selection is visible" - | row r | - row _ self getCurrentSelectionIndex. - row = 0 - ifTrue: [ - "Value is 0, but we need to propagate it to model" - scrollBar internalScrollValue: scrollBar scrollValue ] - ifFalse: [ - self flag: #jmvVer2. - r _ self listMorph drawBoundsForRow: row. - r _ ((self listMorph externalize: r origin) extent: r extent). - self scrollToShow: r ]. - self scrollMySiblings -! ! -!PluggableListMorph methodsFor: 'scrolling' stamp: 'KenD 1/1/2021 13:14:29' overrides: 50455272! - scrollToShow: aRectangle - - super scrollToShow: aRectangle. - self scrollMySiblings ! ! -!PluggableListMorph methodsFor: 'scrolling' stamp: 'KenD 1/1/2021 15:41:31'! - vPrivateScrollTo: scrollValue - - self scrollerOffset: (self scrollerOffset x @ scrollValue)! ! -!PluggableListMorph methodsFor: 'scrolling' stamp: 'KenD 1/1/2021 15:43:22' overrides: 16890025! - vScrollBarValue: scrollValue - - super vScrollBarValue: scrollValue. - self scrollMySiblings! ! -!PluggableListMorph methodsFor: 'scrolling' stamp: 'KenD 1/1/2021 15:32:18'! - vScrollLeftSibling: yOffset - "vertical scroll my LEFT siblings along with my self" - self vPrivateScrollTo: yOffset. - scrollSiblings ifTrue: [ - leftSibling ifNotNil: [ :left | - left vScrollLeftSibling: yOffset ] - ]! ! -!PluggableListMorph methodsFor: 'scrolling' stamp: 'KenD 1/1/2021 15:32:25'! - vScrollRightSibling: yOffset - "vertical scroll my RIGHT siblings along with my self" - self vPrivateScrollTo: yOffset. - scrollSiblings ifTrue: [ - rightSibling ifNotNil: [ :left | - left vScrollRightSibling: yOffset ] - ]! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'KenD 12/31/2020 13:09:16' prior: 50556300! - updateScrollBarsBounds - - | t | - hideScrollBars = #hide ifTrue: [^self]. - t _ self scrollBarClass scrollbarThickness. - (hideScrollBars = #hideVertical) - ifFalse: [ - scrollBar - morphPosition: extent x - t - borderWidth @ borderWidth - extent: t @ self vScrollBarHeight. - ]. - hScrollBar - morphPosition: borderWidth @ (extent y - t - borderWidth) - extent: self hScrollBarWidth@t! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'KenD 12/31/2020 13:18:18' prior: 50556345! - vIsScrollbarNeeded - "Return whether the vertical scrollbar is needed" - - "Don't show it if we were told not to." - hideScrollBars = #hide ifTrue: [ ^false ]. - - hideScrollBars = #alwaysHideVertical ifTrue: [ ^false ]. - - hideScrollBars = #alwaysShowVertical ifTrue: [ ^true ]. - - ^self vLeftoverScrollRange > 0! ! -!PluggableListMorph methodsFor: 'initialization' stamp: 'KenD 1/1/2021 13:11:40' prior: 50492522 overrides: 50556315! - initialize - super initialize. - scroller morphWidth: extent x. - scrollSiblings := false. "user must override"! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'KenD 1/1/2021 15:49:40' prior: 50547700! - buildMorphicWindow - " - CodePackageListWindow open: CodePackageList new - " - | dirtyFlags names fileNames dirtyFlagsPane namesPane fileNamesPane - upperRow description summary backColor labelBackground | - backColor := self textBackgroundColor. - labelBackground := Theme current background. - - dirtyFlags := PluggableListMorph - model: model - listGetter: #packageDirtyFlags - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - dirtyFlags color: backColor; - hideScrollBarsIndefinitely. - dirtyFlagsPane := LayoutMorph newColumn - color: labelBackground; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: ' Unsaved?'); - addMorphUseAll: dirtyFlags. - - names := PluggableListMorph - model: model - listGetter: #packageNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - names color: backColor. - namesPane := LayoutMorph newColumn - color: labelBackground; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: ' Package Name'); - addMorphUseAll: names. - - fileNames := PluggableListMorph - model: model - listGetter: #packageFullNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - fileNames color: backColor; - alwaysHideVerticalScrollbar. - fileNamesPane := LayoutMorph newColumn - color: labelBackground; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: ' File Name'); - addMorphUseAll: fileNames. - - upperRow := LayoutMorph newRow. - upperRow - addMorph: dirtyFlagsPane proportionalWidth: 0.13; - addAdjusterAndMorph: namesPane proportionalWidth: 0.27; - addAdjusterAndMorph: fileNamesPane proportionalWidth: 0.6. - - description := (TextModelMorph - textProvider: model - textGetter: #description - textSetter: #description:) emptyTextDisplayMessage: 'Please enter a description for this package'. - - summary := (TextModelMorph - textProvider: model - textGetter: #summary) emptyTextDisplayMessage: 'Package summary (No package selected?)'. - - names leftSibling: dirtyFlags rightSibling: fileNames; scrollSiblings: true. - dirtyFlags rightSibling: names; scrollSiblings: true. - fileNames leftSibling: names; scrollSiblings: true. - - self layoutMorph - addMorph: upperRow proportionalHeight: 0.6; - addAdjusterAndMorph: self buildButtonPane fixedHeight: Theme current buttonPaneHeight; - addAdjusterAndMorph: summary fixedHeight: 60; - addAdjusterAndMorph: description proportionalHeight: 0.25; - addAdjusterAndMorph: self buildRequirementsPane proportionalHeight: 0.15. - self setLabel: 'Installed Packages'! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'KenD 12/31/2020 11:40:22' prior: 50519861! - buildRequirementsPane - - | requirements deleteReqButton "editReqButton" reqLayout buttonLayout updateReqButton | - requirements := PluggableListMorph - model: (PackageRequirementsList fromCodePackageList: model) - listGetter: #requirementsStrings - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - requirements color: Theme current textPane. - - deleteReqButton := PluggableButtonMorph - model: requirements model - action: #deleteSelectedRequirement - label: 'delete':: - setBalloonText: 'Remove selected Feature requirement'. - deleteReqButton color: self widgetsColor. - updateReqButton _ PluggableButtonMorph - model: requirements model - action: #updateSelectedRequirement - label: 'update':: - setBalloonText: 'Update requirement to current Feature revision'. - updateReqButton color: self widgetsColor. - - buttonLayout := LayoutMorph newRow. - buttonLayout - addMorph: deleteReqButton - layoutSpec: (LayoutSpec - proportionalWidth: 1.0 - proportionalHeight: 1.0 - offAxisEdgeWeight: #leftOrTop); - color: self widgetsColor quiteWhiter; - addMorph: updateReqButton - layoutSpec: (LayoutSpec - proportionalWidth: 1.0 - proportionalHeight: 1.0 - offAxisEdgeWeight: #leftOrTop); - color: self widgetsColor quiteWhiter. - - model when: #changed: send: #updateRequirementsFromPackageList to: requirements model. - self when: #changed: send: #updateRequirementsFromPackageList to: requirements model. - requirements model when: #changed: send: #verifyContents to: requirements. - self when: #changed: send: #verifyContents to: requirements. - - reqLayout := LayoutMorph newRow. - ^ reqLayout - doAdoptWidgetsColor; - addMorph: requirements - layoutSpec: (LayoutSpec - proportionalWidth: 0.8 - proportionalHeight: 1.0 - offAxisEdgeWeight: #leftOrTop); - addMorph: buttonLayout - layoutSpec: (LayoutSpec - proportionalWidth: 0.2 - proportionalHeight: 1.0 - offAxisEdgeWeight: #rightOrBottom); - color: `Color transparent`; - yourself - ! ! -!ChangeSorterWindow methodsFor: 'GUI building' stamp: 'KenD 1/1/2021 15:54:53' prior: 50547778! - buildMorphicWindow - "Add a set of change sorter views to the given top view offset by the given amount. To create a single change sorter, call this once with an offset of 0@0. To create a dual change sorter, call it twice with offsets of 0@0 and 0.5@0." - - | dirtyFlags changeSetList classList dirtyFlagsPane changeSetListPane classListPane - messageList upperPanes backColor labelBackground | - backColor _ self textBackgroundColor. - labelBackground _ Theme current background. - model myChangeSet ifNil: [ - self flag: #ojo. "Or whatever was last changed, or is top of list, or whatever" - model myChangeSet: ChangeSet changeSetForBaseSystem ]. - - dirtyFlags _ PluggableListMorph - model: model - listGetter: #changeSetDirtyFlags - indexGetter: nil - indexSetter: nil. - dirtyFlags color: backColor. - dirtyFlagsPane _ LayoutMorph newColumn - color: Theme current background; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: ' Unsaved?'); - addMorphUseAll: dirtyFlags. - - changeSetList _ (PluggableListMorphByItem - model: model - listGetter: #changeSetList - indexGetter: #currentCngSet - indexSetter: #showChangeSetNamed: - mainView: self - menuGetter: #changeSetMenu - keystrokeAction: #changeSetListKey:from:) - autoDeselect: false. - changeSetList color: backColor. - changeSetListPane _ LayoutMorph newColumn - color: labelBackground; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: 'Change Set name'); - addMorphUseAll: changeSetList. - - classList _ PluggableListMorphByItem - model: model - listGetter: #classList - indexGetter: #currentClassName - indexSetter: #currentClassName: - mainView: self - menuGetter: #classListMenu - keystrokeAction: #classListKey:from:. - classList color: backColor. - classListPane _ LayoutMorph newColumn - color: labelBackground; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: 'Classes'); - addMorphUseAll: classList. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: dirtyFlagsPane proportionalWidth: 0.13; - addAdjusterAndMorph: changeSetListPane proportionalWidth: 0.47; - addAdjusterAndMorph: classListPane proportionalWidth: 0.4. - - "Scroll Sibling Panes together." - changeSetList leftSibling: dirtyFlags; scrollSiblings: true. - dirtyFlags rightSibling: changeSetList; scrollSiblings: true. - - messageList _ PluggableListMorphByItem - model: model - listGetter: #messageList - indexGetter: #currentSelector - indexSetter: #currentSelector: - mainView: self - menuGetter: #messageMenu - keystrokeAction: #messageListKey:from:. - messageList color: backColor. - messageList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedHeight: 4; - addMorphKeepMorphHeight: (LabelMorph new contents: 'Methods'); - addMorphUseAll: messageList. - - - self layoutMorph - addMorph: upperPanes proportionalHeight: 0.25; - addAdjusterAndMorph: messageList proportionalHeight: 0.2; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.55. - - self setLabel: model labelString! ! - -PluggableScrollPane subclass: #PluggableListMorph - instanceVariableNames: 'list getListSelector getIndexSelector setIndexSelector keystrokeActionSelector autoDeselect lastKeystrokeTime lastKeystrokes doubleClickSelector menuGetter mainView leftSibling rightSibling scrollSiblings' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #PluggableListMorph category: 'Morphic-Widgets' stamp: 'Install-4511-MultiListScroll-KenDickey-2020Dec31-11h39m-KenD.002.cs.st 1/7/2021 16:18:30'! -PluggableScrollPane subclass: #PluggableListMorph - instanceVariableNames: 'list getListSelector getIndexSelector setIndexSelector keystrokeActionSelector autoDeselect lastKeystrokeTime lastKeystrokes doubleClickSelector menuGetter mainView leftSibling rightSibling scrollSiblings' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4511-MultiListScroll-KenDickey-2020Dec31-11h39m-KenD.002.cs.st----! - -'From Cuis 5.0 [latest update: #4511] on 5 January 2021 at 10:59:27 am'! -!HandMorph methodsFor: 'events-processing' stamp: 'KenD 1/4/2021 11:09:49' prior: 50373832! - startMouseDispatch: aMouseEvent - - aMouseEvent isMouseOver ifTrue: [ - ^self mouseFocus - ifNotNil: [ mouseFocus handleFocusEvent: aMouseEvent ] - ifNil: [ owner dispatchEvent: aMouseEvent localPosition: aMouseEvent eventPosition ]]. - - "any mouse event but mouseOver" - lastMouseEvent _ aMouseEvent. - lastMouseEventTime _ Time localMillisecondClock. - - "Check for pending drag or double click operations." - mouseClickState ifNotNil: [ - (mouseClickState handleEvent: aMouseEvent from: self) ifTrue: [ - "Possibly dispatched #click: or something. Do not further process this event." - ^self mouseOverHandler processMouseOver: lastMouseEvent ]]. - - aMouseEvent isMove - ifTrue: [ - self morphPosition: aMouseEvent eventPosition. - self mouseFocus - ifNotNil: [ mouseFocus handleFocusEvent: aMouseEvent ] - ifNil: [ owner dispatchEvent: aMouseEvent localPosition: aMouseEvent eventPosition ] - ] ifFalse: [ - aMouseEvent isMouseScroll ifTrue: [ - owner dispatchEvent: aMouseEvent localPosition: aMouseEvent eventPosition - ] ifFalse: [ - "Issue a synthetic move event if we're not at the position of the event" - aMouseEvent eventPosition = self morphPosition ifFalse: [ - "Issue a mouse move event to make the receiver appear at the given position" - self startMouseDispatch: (MouseMoveEvent new - setType: #mouseMove - position: aMouseEvent eventPosition - buttons: aMouseEvent buttons - hand: self - stamp: aMouseEvent timeStamp) ]. - "Drop submorphs on button events" - self hasSubmorphs - ifTrue: [ - "Not if we are grabbing them" - mouseClickState ifNil: [ - "Want to drop on mouseUp, NOT mouseDown" - aMouseEvent isMouseUp ifTrue: [ - self dropMorphs: aMouseEvent ] - ] - ] ifFalse: [ - self mouseFocus - ifNotNil: [ mouseFocus handleFocusEvent: aMouseEvent ] - ifNil: [ owner dispatchEvent: aMouseEvent localPosition: aMouseEvent eventPosition ]]]]. - self mouseOverHandler processMouseOver: self lastMouseEvent! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'KenD 1/3/2021 13:44:18' prior: 50559821! - grabMorph: aMorph moveUnderHand: moveUnderHand - "Grab the given morph (i.e., add it to this hand and remove it from its current owner). - If moveUnderHand is requested or it seems neccesary anyway, move the grabbed morph under the hand." - - | grabbed positionInHandCoordinates tx | - self releaseMouseFocus. "Break focus" - grabbed _ aMorph. - aMorph owner ifNotNil: [ :o | grabbed _ o aboutToGrab: aMorph ]. - grabbed ifNil: [ ^ self ]. - grabbed _ grabbed aboutToBeGrabbedBy: self. - grabbed ifNil: [ ^ self ]. - - moveUnderHand - ifTrue: [ - "We can possibly do better, especially for non WidgetMorphs" - positionInHandCoordinates _ -30 @ -10. - grabbed isInWorld ifTrue: [ - grabbed displayBounds ifNotNil: [ :r | - positionInHandCoordinates _ (r extent // 2) negated ]]. - self - grabMorph: grabbed - delta: positionInHandCoordinates. - ^self ]. - - positionInHandCoordinates _ (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) - morphPositionInWorld - self morphPositionInWorld. - - tx _ GeometryTransformation identity. - aMorph withAllOwnersDo: [ :o | - tx _ o location composedWith: tx ]. - self withAllOwnersReverseDo: [ :o | - tx _ o location inverseTransformation composedWith: tx ]. - - self - grabMorph: grabbed - delta: positionInHandCoordinates. - - grabbed location: tx.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4512-HandMorph-fixes-KenDickey-2021Jan05-10h58m-KenD.001.cs.st----! - -'From Cuis 5.0 [latest update: #4512] on 5 January 2021 at 11:26:28 am'! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 1/5/2021 11:20:58'! - containsGlobalPoint: worldPoint - - "If not visible, won't contain any point at all." - | canvas | - self visible ifFalse: [ ^false ]. - - canvas _ self world canvas. - canvas isNil ifTrue: [ ^false ]. - (canvas morph: self isAtPoint: worldPoint) ifTrue: [ ^ true ]. - ^ false! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 1/5/2021 11:21:34' prior: 50537194! - fullContainsGlobalPoint: worldPoint - "Answer true if worldPoint is in some submorph, even if not inside our shape." - - "If not visible, won't contain any point at all." - | canvas | - self visible ifFalse: [ ^false ]. - - canvas _ self world canvas. - canvas isNil ifTrue: [ ^false ]. - (canvas morph: self isAtPoint: worldPoint) ifTrue: [ ^ true ]. - self submorphsDo: [ :m | - (m fullContainsGlobalPoint: worldPoint) ifTrue: [ ^ true ]]. - ^ false! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 1/5/2021 11:22:11' prior: 16851032! - doRecolor: event with: aHandle - "The mouse went down in the 'recolor' halo handle. Allow the user to change the color of the innerTarget" - - event hand obtainHalo: self. - (aHandle containsGlobalPoint: event eventPosition) - ifFalse: [ "only do it if mouse still in handle on mouse up" - self delete. - target addHalo: event] - ifTrue: [ - target changeColor]! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 1/5/2021 11:22:14' prior: 16851082! - maybeCollapse: event with: aHandle - "Ask hand to collapse my target if mouse comes up in it." - - event hand obtainHalo: self. - self delete. - (aHandle containsGlobalPoint: event eventPosition) - ifFalse: [ - target addHalo: event ] - ifTrue: [ - target collapse ]! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 1/5/2021 11:22:19' prior: 16851094! - maybeDismiss: event with: aHandle - "Ask hand to dismiss my target if mouse comes up in it." - - event hand obtainHalo: self. - (aHandle containsGlobalPoint: event eventPosition) - ifFalse: [ - self delete. - target addHalo: event] - ifTrue: [ - target resistsRemoval ifTrue: [ - (PopUpMenu - confirm: 'Really throw this away' - trueChoice: 'Yes' - falseChoice: 'Um, no, let me reconsider') ifFalse: [^ self]]. - - self delete. - target dismissViaHalo]! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 1/5/2021 11:22:25' prior: 50388478! - setDismissColor: event with: aHandle - "Called on mouseStillDown in the dismiss handle; set the color appropriately." - - | colorToUse | - event hand obtainHalo: self. - colorToUse _ (aHandle containsGlobalPoint: event eventPosition) - ifFalse: [ `Color red muchLighter` ] - ifTrue: [ `Color lightGray` ]. - aHandle color: colorToUse! ! -!LayoutAdjustingMorph methodsFor: 'stepping' stamp: 'jmv 1/5/2021 11:24:34' prior: 50535217 overrides: 50547624! - stepAt: millisecondSinceLast - "got the #mouseLeave: message" - | p | - hand ifNil: [ - Cursor currentCursor == self cursor ifTrue: [ Cursor defaultCursor activateCursor ]. - ^ self stopStepping ]. - "hasn't got the #mouseLeave: message (yet)" - p _ hand morphPosition. - hand lastMouseEvent mouseButton1Pressed - ifTrue: [ - self adjustOwnerAt: p. - (Preferences cheapWindowReframe or: [ millisecondSinceLast > 200]) ifTrue: [ - owner displayBounds newRectFrom: [ :f | - self adjustOwnerAt: Sensor mousePoint. - owner morphPosition extent: owner morphExtent ]]] - ifFalse: [ - self stopStepping. - "If the button was unpressed outside the morph (can happen if you try to go outside container), - we might not get the #mouseLeave: message" - (self containsGlobalPoint: p) ifFalse: [ - hand _ nil. - Cursor defaultCursor activateCursor ]].! ! -!MenuItemMorph methodsFor: 'events' stamp: 'jmv 1/5/2021 11:24:48' prior: 50341030! - activateOwnerMenu: evt - "Activate our owner menu; e.g., pass control to it" - owner ifNil: [ ^false ]. "not applicable" - (owner containsGlobalPoint: evt eventPosition) - ifFalse: [ ^false ]. - owner activate: evt. - ^true! ! -!MenuItemMorph methodsFor: 'events' stamp: 'jmv 1/5/2021 11:25:19' prior: 50408559! - activateSubmenu: event - "Activate our submenu; e.g., pass control to it" - - subMenu ifNil: [ ^false ]. "not applicable" - (subMenu containsGlobalPoint: event eventPosition) ifFalse: [^false]. - subMenu activate: event. - ^true! ! -!PluggableButtonMorph methodsFor: 'events' stamp: 'jmv 1/5/2021 11:22:49' prior: 16888243 overrides: 16874556! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - - isPressed _ false. - mouseIsOver _ false. - (actWhen == #buttonUp and: [ - self containsGlobalPoint: aMouseButtonEvent eventPosition ]) - ifTrue: [ self performAction ]. - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'events' stamp: 'jmv 1/5/2021 11:24:01' prior: 50436625 overrides: 16874556! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - - (self containsGlobalPoint: aMouseButtonEvent eventPosition) - ifTrue: [ - ((self upButtonPosition extent: ScrollBar scrollbarThickness) containsPoint: localEventPosition) - ifTrue: [ ^self stillActive; goUp ]. - ((self downButtonPosition extent: ScrollBar scrollbarThickness) containsPoint: localEventPosition) - ifTrue: [ ^self stillActive; goDown ]. - self selected: (localEventPosition y // self itemHeight) + self firstVisible. - completer insertSelected ] - ifFalse: [ self delete. completer menuClosed ]! ! -!KeyboardEvent methodsFor: 'actions' stamp: 'jmv 1/5/2021 11:23:35' prior: 50455363! - closeCurrentWindowOf: aMorph - - aMorph owningWindow ifNotNil: [ :w | - (w containsGlobalPoint: self eventPosition) - ifTrue: [ w delete ] ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4513-avoid-morphContainsPoint-JuanVuletich-2021Jan05-11h12m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4513] on 5 January 2021 at 11:35:12 am'! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 1/5/2021 11:33:43' prior: 50544299! - transferHalo: event from: formerHaloOwner - "Progressively transfer the halo to the next likely recipient" - - formerHaloOwner == self - ifFalse: [ ^self addHalo: event ]. - - event shiftPressed ifTrue: [ - "Pass it outwards" - owner ifNotNil: [ ^owner transferHalo: event from: formerHaloOwner ]. - "We're at the top level; just keep it on ourselves" - ^self ]. - - self submorphsDo: [ :m | - (m wantsHalo and: [ m fullContainsGlobalPoint: event eventPosition ]) - ifTrue: [ ^m transferHalo: event from: formerHaloOwner ]]. - "We're at the bottom most level; just keep halo on ourselves"! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4514-avoid-fullContainsPoint-JuanVuletich-2021Jan05-11h33m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4513] on 5 January 2021 at 11:46:24 am'! -!MorphicEvent methodsFor: 'accessing' stamp: 'jmv 1/5/2021 11:42:09'! - eventPosition - self subclassResponsibility! ! -!Morph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 11:44:31' prior: 50530977! - processMouseOver: aMouseEvent localPosition: localEventPosition - "System level event handling." - self hasMouseFocus ifTrue: [ - "Got this directly through #handleFocusEvent: so check explicitly" - ((self rejectsEvent: aMouseEvent) not and: [self fullContainsGlobalPoint: aMouseEvent eventPosition]) ifFalse: [ - ^self ]]. - aMouseEvent hand noticeMouseOver: self event: aMouseEvent. - "Open question: should any unhandled mouse move events be filtered out? (i.e. should mouseHover:localPosition: be called when a mouse button is pressed but the morph doesn't have mouse button handlers? Essentially, what are the limits of what is considered 'hovering'?" - (self handlesMouseHover and: [aMouseEvent wasHandled not]) ifTrue: [ - self - mouseHover: aMouseEvent - localPosition: localEventPosition ].! ! -!MenuMorph methodsFor: 'events' stamp: 'jmv 1/5/2021 11:43:53' prior: 16866892 overrides: 16874541! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - "Handle a mouse down event." - (stayUp or: [ self fullContainsGlobalPoint: aMouseButtonEvent eventPosition ]) - ifFalse: [ ^self deleteIfPopUp: aMouseButtonEvent ]. "click outside" - - "Grab the menu and drag it to some other place - This is reimplemented here because we handle the event, and if the following lines are commented, a menu can't be grabbed with the hand. This is not nice and shouldn't be needed" - self isSticky ifTrue: [ ^self ]. - aMouseButtonEvent hand grabMorph: self! ! -!MenuMorph methodsFor: 'events' stamp: 'jmv 1/5/2021 11:44:12' prior: 16866911 overrides: 16874556! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - "Handle a mouse up event. - Note: This might be sent from a modal shell." - (self fullContainsGlobalPoint: aMouseButtonEvent eventPosition) ifFalse:[ - "Mouse up outside. Release eventual focus and delete if pop up." - aMouseButtonEvent hand ifNotNil: [ :h | h releaseMouseFocus: self ]. - ^ self deleteIfPopUp: aMouseButtonEvent ]. - stayUp ifFalse: [ - "Still in pop-up transition; keep focus" - aMouseButtonEvent hand newMouseFocus: self ]! ! -!MorphicEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 11:44:50' prior: 50531019! - dispatchWith: aMorph localPosition: positionInAMorph - "Dispatch me. The event will be passed to the front-most visible submorph that contains the position wrt. to the event." - | handledByInner eventPositionInChild | - - "Try to get out quickly" - (aMorph fullContainsGlobalPoint: self eventPosition) - ifFalse: [ ^#rejected ]. - - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - - "Check for being inside the receiver" - (handledByInner or: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: self eventPosition] ]) - ifTrue: [ ^ self sentTo: aMorph localPosition: positionInAMorph ]. - - ^ #rejected! ! -!DropEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 11:39:39' prior: 50531053 overrides: 50562815! - dispatchWith: aMorph localPosition: positionInAMorph - "Drop is done on the innermost target that accepts it." - | eventPositionInChild dropped | - - "Try to get out quickly" - (aMorph fullContainsGlobalPoint: position) - ifFalse: [ ^#rejected ]. - - "Go looking if any of our submorphs wants it" - aMorph submorphsDo: [ :eachChild | - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ - ^self ]]. - - (aMorph allowsMorphDrop and: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position] ]) - ifTrue: [ - "Do a symmetric check if both morphs like each other" - dropped _ self contents. - ((aMorph wantsDroppedMorph: dropped event: self) "I want her" - and: [dropped wantsToBeDroppedInto: aMorph]) "she wants me" - ifTrue: [ - ^ self sentTo: aMorph localPosition: positionInAMorph ]]. - ^#rejected! ! -!DropFilesEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 11:40:08' prior: 50531086 overrides: 50562815! - dispatchWith: aMorph localPosition: positionInAMorph - "Drop is done on the innermost target that accepts it." - - | eventPositionInChild | - - "Try to get out quickly" - (aMorph fullContainsGlobalPoint: position) ifFalse: [ ^#rejected ]. - - "Go looking if any of our submorphs wants it" - aMorph submorphsDo: [ :eachChild | - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ ^self ]]. - - (aMorph allowsFilesDrop and: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position] ]) - ifTrue: [^ self sentTo: aMorph localPosition: positionInAMorph ]. - - ^#rejected! ! -!KeyboardEvent methodsFor: 'actions' stamp: 'jmv 1/5/2021 11:39:47' prior: 50562698! - closeCurrentWindowOf: aMorph - - aMorph owningWindow ifNotNil: [ :w | - (w containsGlobalPoint: position) - ifTrue: [ w delete ] ].! ! -!MouseButtonEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 11:45:08' prior: 50531112 overrides: 50562815! - dispatchWith: aMorph localPosition: positionInAMorph - "Find the appropriate receiver for the event and let it handle it. Default rules: - * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. - * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. - * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. - * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. - " - | aMorphHandlesIt grabAMorph handledByInner eventPositionInChild | - "Only for MouseDown" - self isMouseDown ifFalse: [ - ^super dispatchWith: aMorph localPosition: positionInAMorph ]. - - "Try to get out quickly" - (aMorph fullContainsGlobalPoint: position) - ifFalse: [ ^#rejected ]. - - "Install the prospective handler for the receiver" - aMorphHandlesIt _ false. - grabAMorph _ false. - self mouseButton3Pressed - ifTrue: [ - (eventHandler isNil or: [ eventHandler isWorldMorph or: [ - self shiftPressed or: [ aMorph is: #HaloMorph ]]]) - ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]] - ifFalse: [ - (aMorph handlesMouseDown: self) ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]. - "If button 1, and both aMorph and the owner allows grabbing with the hand (to initiate drag & drop), so be it." - self mouseButton1Pressed ifTrue: [ - aMorph owner ifNotNil: [ :o | - (o allowsSubmorphDrag and: [ aMorph isSticky not ]) ifTrue: [ - grabAMorph _ true ]]]]. - - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - - (handledByInner or: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position] ]) ifTrue: [ - "aMorph is in the top-most unlocked, visible morph in the chain." - aMorphHandlesIt - ifTrue: [ ^self sentTo: aMorph localPosition: positionInAMorph ] - ifFalse: [ - (grabAMorph and: [ handledByInner not ]) ifTrue: [ - self hand - waitForClicksOrDrag: aMorph event: self - dragSel: (Preferences clickGrabsMorphs ifFalse: [#dragEvent:localPosition:]) - clkSel: (Preferences clickGrabsMorphs ifTrue: [#dragEvent:localPosition:]). - "false ifTrue: [ self hand grabMorph: aMorph ]." - Preferences clickGrabsMorphs ifFalse: [aMorph activateWindow]. - self wasHandled: true. - ^self ]]]. - - handledByInner ifTrue: [ ^self ]. - "Mouse was not on aMorph nor any of its children" - ^ #rejected! ! -!MouseScrollEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 11:45:22' prior: 50531212 overrides: 50562815! - dispatchWith: aMorph localPosition: positionInAMorph - "Find the appropriate receiver for the event and let it handle it. Default rules: - * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. - * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. - * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. - * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. - " - "Try to get out quickly" - | aMorphHandlesIt handledByInner eventPositionInChild focus| - focus := self hand keyboardFocus. - "FIXME - this works in all tested cases but one: when the window directly under the mouse doesn't have keyboard focus (i.e. a Transcript window)" - ((aMorph fullContainsGlobalPoint: position) and: [(aMorph = focus) or: [focus notNil and: [aMorph notNil and: [focus hasOwner: aMorph]]]]) ifFalse: [ ^ #rejected ]. - "Install the prospective handler for the receiver" - aMorphHandlesIt _ false. - (aMorph handlesMouseScroll: self) ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]. - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild - dispatchEvent: self - localPosition: eventPositionInChild) == #rejected ifFalse: [ "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - (handledByInner or: [ - (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position]]) ifTrue: [ - "aMorph is in the top-most unlocked, visible morph in the chain." - aMorphHandlesIt ifTrue: [ ^ self - sentTo: aMorph - localPosition: positionInAMorph ]]. - handledByInner ifTrue: [ ^ self ]. - "Mouse was not on aMorph nor any of its children" - ^ #rejected.! ! - -Morph removeSelector: #fullContainsPoint:! - -!methodRemoval: Morph #fullContainsPoint: stamp: 'Install-4515-remove-fullContainsPoint-JuanVuletich-2021Jan05-11h35m-jmv.001.cs.st 1/7/2021 16:18:30'! -fullContainsPoint: aLocalPoint - "Answer true even if aLocalPoint is in some submorph, regardless of being also inside our shape." - - "If not visible, won't contain any point at all." - self visible ifFalse: [ ^false ]. - - ^self fullContainsGlobalPoint: (self externalizeToWorld: aLocalPoint).! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4515-remove-fullContainsPoint-JuanVuletich-2021Jan05-11h35m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4515] on 5 January 2021 at 12:53:31 pm'! -!Morph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 11:51:09'! - processDropFiles: aDropFilesEvent - "Handle a dropping file." - - aDropFilesEvent wasHandled ifTrue: [ ^self ]. - - aDropFilesEvent wasHandled: true. - self dropFiles: aDropFilesEvent! ! -!Morph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 11:50:19'! - processDropMorph: aDropEvent - "Handle a dropping morph." - | aMorph | - - aDropEvent wasHandled ifTrue: [ ^self ]. "Do it just once, for one drop destination" - - aMorph _ aDropEvent contents. - aDropEvent wasHandled: true. - self acceptDroppingMorph: aMorph event: aDropEvent. - aMorph justDroppedInto: self event: aDropEvent! ! -!Morph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 11:52:40'! - processKeyDown: aKeyboardEvent - "System level event handling." - - aKeyboardEvent wasHandled ifTrue: [^self]. - self handlesKeyboard ifFalse: [^self]. - aKeyboardEvent wasHandled: true. - ^self keyDown: aKeyboardEvent! ! -!Morph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 11:52:57'! - processKeyUp: aKeyboardEvent - "System level event handling." - - aKeyboardEvent wasHandled ifTrue: [^self]. - self handlesKeyboard ifFalse: [^self]. - aKeyboardEvent wasHandled: true. - ^self keyUp: aKeyboardEvent! ! -!Morph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 11:51:54'! - processKeystroke: aKeyboardEvent - "System level event handling." - - aKeyboardEvent wasHandled ifTrue: [^self]. - self handlesKeyboard ifFalse: [^self]. - aKeyboardEvent wasHandled: true. - ^self keyStroke: aKeyboardEvent! ! -!Morph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 11:53:33'! - processUnknownEvent: aMorphicEvent - "An event of an unknown type was sent to the receiver. What shall we do?!!" - - Smalltalk beep. - aMorphicEvent printString displayAt: `0@0`. - aMorphicEvent wasHandled: true! ! -!Morph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 12:03:21'! - processWindowEvent: aWindowEvent - "Handle an event concerning our host window" - - aWindowEvent wasHandled ifTrue: [^self]. "not interested" - (self wantsWindowEvent: aWindowEvent) ifFalse: [^self]. - aWindowEvent wasHandled: true. - self windowEvent: aWindowEvent. -! ! -!InnerTextMorph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 11:51:44' overrides: 50563149! - processKeystroke: aKeyboardEvent - "System level event handling." - - aKeyboardEvent wasHandled ifTrue:[^self]. - self handlesKeyboard ifFalse: [^ self]. - aKeyboardEvent wasHandled: true. - self keyStroke: aKeyboardEvent! ! -!MorphicEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 11:53:47'! - sendEventTo: aMorph - "Dispatch the receiver into aMorph" - - ^ aMorph processUnknownEvent: self! ! -!DropEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 11:50:38' overrides: 50563190! - sendEventTo: aMorph - "Dispatch the receiver into aMorph" - - ^aMorph processDropMorph: self! ! -!DropFilesEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 11:51:15' overrides: 50563190! - sendEventTo: aMorph - "Dispatch the receiver into aMorph" - - ^aMorph processDropFiles: self! ! -!KeyboardEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 11:53:19' overrides: 50563190! - sendEventTo: aMorph - "Dispatch the receiver into anObject" - type == #keystroke ifTrue: [ - self isFindClassShortcut - ifTrue: [ ^ BrowserWindow findClass]. - self isCloseWindowShortcut - ifTrue: [ ^ self closeCurrentWindowOf: aMorph ]. - ^ aMorph processKeystroke: self ]. - type == #keyDown ifTrue: [ - ^ aMorph processKeyDown: self ]. - type == #keyUp ifTrue: [ - ^ aMorph processKeyUp: self ]. - ^ super sendEventTo: aMorph.! ! -!MouseEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:02:08' overrides: 50563190! - sendEventTo: aMorph - "Dispatch the receiver into aMorph" - - type == #mouseOver ifTrue: [ - ^aMorph processMouseOver: self localPosition: (aMorph internalizeFromWorld: position) ]. - type == #mouseEnter ifTrue: [ - ^ aMorph processMouseEnter: self localPosition: (aMorph internalizeFromWorld: position) ]. - type == #mouseLeave ifTrue: [ - ^aMorph processMouseLeave: self localPosition: (aMorph internalizeFromWorld: position) ]. - ^ super sendEventTo: aMorph! ! -!MouseButtonEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:00:01' overrides: 50563225! - sendEventTo: aMorph - "Dispatch the receiver into anObject" - - type == #mouseDown ifTrue: [ - ^aMorph processMouseDown: self localPosition: (aMorph internalizeFromWorld: position) ]. - type == #mouseUp ifTrue: [ - ^aMorph processMouseUp: self localPosition: (aMorph internalizeFromWorld: position) ]. - ^super sendEventTo: aMorph! ! -!MouseMoveEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:02:43' overrides: 50563225! - sendEventTo: aMorph - "Dispatch the receiver into anObject" - - type == #mouseMove ifTrue: [ - ^aMorph processMouseMove: self localPosition: (aMorph internalizeFromWorld: position) ]. - ^ super sendEventTo: aMorph! ! -!MouseScrollEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:03:02' overrides: 50563225! - sendEventTo: aMorph - "Dispatch the receiver into anObject" - ^ aMorph - processMouseScroll: self - localPosition: (aMorph internalizeFromWorld: position).! ! -!WindowEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:03:28' overrides: 50563190! - sendEventTo: aMorph - "Dispatch the receiver into anObject" - - ^ aMorph processWindowEvent: self! ! -!Morph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 12:04:44' prior: 16874935! - handleFocusEvent: aMorphicEvent - "Handle the given event. This message is sent if the receiver currently has the focus and is therefore receiving events directly from some hand." - - ^aMorphicEvent sendEventTo: self! ! -!MenuMorph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 12:04:29' prior: 50341083 overrides: 50563281! - handleFocusEvent: aMorphicEvent - "Handle focus events. Valid menu transitions are determined based on the menu currently holding the focus after the mouse went down on one of its children." - | eventPositionInOurCoordinates | - eventPositionInOurCoordinates _ self internalizeFromWorld: aMorphicEvent eventPosition. - - self dispatchEvent: aMorphicEvent localPosition: eventPositionInOurCoordinates. - - "Need to handle keyboard input if we have the focus." - aMorphicEvent isKeyboard ifTrue: [ ^ aMorphicEvent sendEventTo: self ]. - - "We need to handle button clicks outside and transitions to local popUps so throw away everything else" - (aMorphicEvent isMouseOver or: [aMorphicEvent isMouse not]) ifTrue: [ ^self ]. - "What remains are mouse buttons and moves" - aMorphicEvent isMove ifFalse: [ ^ aMorphicEvent sendEventTo: self ]. "handle clicks outside by regular means" - "Now it's getting tricky. On #mouseMove we might transfer control to *either* the currently active submenu or the pop up owner, if any. Since the active sub menu is always displayed upfront check it first." - selectedItem ifNotNil:[(selectedItem activateSubmenu: aMorphicEvent) ifTrue: [^self]]. - "Note: The following does not traverse upwards but it's the best I can do for now" - popUpOwner ifNotNil:[(popUpOwner activateOwnerMenu: aMorphicEvent) ifTrue: [^self]].! ! -!MorphicEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:04:55' prior: 50562815! - dispatchWith: aMorph localPosition: positionInAMorph - "Dispatch me. The event will be passed to the front-most visible submorph that contains the position wrt. to the event." - | handledByInner eventPositionInChild | - - "Try to get out quickly" - (aMorph fullContainsGlobalPoint: self eventPosition) - ifFalse: [ ^#rejected ]. - - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - - "Check for being inside the receiver" - (handledByInner or: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: self eventPosition] ]) - ifTrue: [ ^ self sendEventTo: aMorph ]. - - ^ #rejected! ! -!DropEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:03:56' prior: 50562849 overrides: 50563337! - dispatchWith: aMorph localPosition: positionInAMorph - "Drop is done on the innermost target that accepts it." - | eventPositionInChild dropped | - - "Try to get out quickly" - (aMorph fullContainsGlobalPoint: position) - ifFalse: [ ^#rejected ]. - - "Go looking if any of our submorphs wants it" - aMorph submorphsDo: [ :eachChild | - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ - ^self ]]. - - (aMorph allowsMorphDrop and: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position] ]) - ifTrue: [ - "Do a symmetric check if both morphs like each other" - dropped _ self contents. - ((aMorph wantsDroppedMorph: dropped event: self) "I want her" - and: [dropped wantsToBeDroppedInto: aMorph]) "she wants me" - ifTrue: [ - ^ self sendEventTo: aMorph ]]. - ^#rejected! ! -!DropFilesEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:04:05' prior: 50562882 overrides: 50563337! - dispatchWith: aMorph localPosition: positionInAMorph - "Drop is done on the innermost target that accepts it." - - | eventPositionInChild | - - "Try to get out quickly" - (aMorph fullContainsGlobalPoint: position) ifFalse: [ ^#rejected ]. - - "Go looking if any of our submorphs wants it" - aMorph submorphsDo: [ :eachChild | - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ ^self ]]. - - (aMorph allowsFilesDrop and: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position] ]) - ifTrue: [^ self sendEventTo: aMorph ]. - - ^#rejected! ! -!MouseButtonEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:05:04' prior: 50562915 overrides: 50563337! - dispatchWith: aMorph localPosition: positionInAMorph - "Find the appropriate receiver for the event and let it handle it. Default rules: - * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. - * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. - * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. - * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. - " - | aMorphHandlesIt grabAMorph handledByInner eventPositionInChild | - "Only for MouseDown" - self isMouseDown ifFalse: [ - ^super dispatchWith: aMorph localPosition: positionInAMorph ]. - - "Try to get out quickly" - (aMorph fullContainsGlobalPoint: position) - ifFalse: [ ^#rejected ]. - - "Install the prospective handler for the receiver" - aMorphHandlesIt _ false. - grabAMorph _ false. - self mouseButton3Pressed - ifTrue: [ - (eventHandler isNil or: [ eventHandler isWorldMorph or: [ - self shiftPressed or: [ aMorph is: #HaloMorph ]]]) - ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]] - ifFalse: [ - (aMorph handlesMouseDown: self) ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]. - "If button 1, and both aMorph and the owner allows grabbing with the hand (to initiate drag & drop), so be it." - self mouseButton1Pressed ifTrue: [ - aMorph owner ifNotNil: [ :o | - (o allowsSubmorphDrag and: [ aMorph isSticky not ]) ifTrue: [ - grabAMorph _ true ]]]]. - - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - - (handledByInner or: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position] ]) ifTrue: [ - "aMorph is in the top-most unlocked, visible morph in the chain." - aMorphHandlesIt - ifTrue: [ ^self sendEventTo: aMorph ] - ifFalse: [ - (grabAMorph and: [ handledByInner not ]) ifTrue: [ - self hand - waitForClicksOrDrag: aMorph event: self - dragSel: (Preferences clickGrabsMorphs ifFalse: [#dragEvent:localPosition:]) - clkSel: (Preferences clickGrabsMorphs ifTrue: [#dragEvent:localPosition:]). - "false ifTrue: [ self hand grabMorph: aMorph ]." - Preferences clickGrabsMorphs ifFalse: [aMorph activateWindow]. - self wasHandled: true. - ^self ]]]. - - handledByInner ifTrue: [ ^self ]. - "Mouse was not on aMorph nor any of its children" - ^ #rejected! ! -!MouseScrollEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:06:25' prior: 50563015 overrides: 50563337! - dispatchWith: aMorph localPosition: positionInAMorph - "Find the appropriate receiver for the event and let it handle it. Default rules: - * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. - * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. - * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. - * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. - " - "Try to get out quickly" - | aMorphHandlesIt handledByInner eventPositionInChild focus| - focus := self hand keyboardFocus. - "FIXME - this works in all tested cases but one: when the window directly under the mouse doesn't have keyboard focus (i.e. a Transcript window)" - ((aMorph fullContainsGlobalPoint: position) and: [(aMorph = focus) or: [focus notNil and: [aMorph notNil and: [focus hasOwner: aMorph]]]]) ifFalse: [ ^ #rejected ]. - "Install the prospective handler for the receiver" - aMorphHandlesIt _ false. - (aMorph handlesMouseScroll: self) ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]. - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild - dispatchEvent: self - localPosition: eventPositionInChild) == #rejected ifFalse: [ "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - (handledByInner or: [ - (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position]]) ifTrue: [ - "aMorph is in the top-most unlocked, visible morph in the chain." - aMorphHandlesIt ifTrue: [ ^ self sendEventTo: aMorph ]]. - handledByInner ifTrue: [ ^ self ]. - "Mouse was not on aMorph nor any of its children" - ^ #rejected.! ! -!WindowEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:06:35' prior: 16945210 overrides: 50563337! - dispatchWith: aMorph localPosition: positionInAMorph - "Host window events do not have a position and are only dispatched to the World" - - aMorph isWorldMorph ifFalse: [ ^#rejected ]. - self wasHandled ifTrue: [ ^self ]. - ^ self sendEventTo: aMorph! ! -!MouseOverHandler methodsFor: 'event handling' stamp: 'jmv 1/5/2021 12:06:07' prior: 16879290! - processMouseOver: aMouseEvent - "Re-establish the z-order for all morphs wrt the given event" - - | hand focus evt | - hand := aMouseEvent hand. - leftMorphs := mouseOverMorphs asIdentitySet. - "Assume some coherence for the number of objects in over list" - overMorphs := WriteStream on: (Array new: leftMorphs size). - enteredMorphs := WriteStream on: #(). - "Now go looking for eventual mouse overs" - hand startEventDispatch: aMouseEvent asMouseOver. - "Get out early if there's no change" - (leftMorphs isNil or: [ "Should never happen, but it could if you halt during layout." - (leftMorphs isEmpty and: [enteredMorphs position = 0])]) - ifTrue: [^leftMorphs := enteredMorphs := overMorphs := nil]. - focus := hand mouseFocus. - "Send #mouseLeave as appropriate" - evt := aMouseEvent asMouseLeave. - "Keep the order of the left morphs by recreating it from the mouseOverMorphs" - leftMorphs size > 1 - ifTrue: [leftMorphs := mouseOverMorphs select: [:m | leftMorphs includes: m]]. - leftMorphs do: [ :m | - (m == focus or: [m hasOwner: focus]) - ifTrue: [ - evt sendEventTo: m ] - ifFalse: [overMorphs nextPut: m]]. - "Send #mouseEnter as appropriate" - evt := aMouseEvent asMouseEnter. - enteredMorphs ifNil: [ - "inform: was called in handleEvent:" - ^ leftMorphs := enteredMorphs := overMorphs := nil]. - enteredMorphs := enteredMorphs contents. - enteredMorphs reverseDo: [ :m | - (m == focus or: [m hasOwner: focus]) - ifTrue: [ - evt sendEventTo: m ]]. - "And remember the over list" - overMorphs ifNil: [ - "inform: was called in handleEvent:" - ^leftMorphs := enteredMorphs := overMorphs := nil]. - mouseOverMorphs := overMorphs contents. - leftMorphs := enteredMorphs := overMorphs := nil! ! - -WindowEvent removeSelector: #sentTo:localPosition:! - -!methodRemoval: WindowEvent #sentTo:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:18:30'! -sentTo: aMorph localPosition: positionInAMorph - "Dispatch the receiver into anObject" - - ^ aMorph processWindowEvent: self localPosition: positionInAMorph! - -MouseScrollEvent removeSelector: #sentTo:localPosition:! - -!methodRemoval: MouseScrollEvent #sentTo:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:18:30'! -sentTo: aMorph localPosition: positionInAMorph - "Dispatch the receiver into anObject" - ^ aMorph - processMouseScroll: self - localPosition: positionInAMorph.! - -MouseMoveEvent removeSelector: #sentTo:localPosition:! - -!methodRemoval: MouseMoveEvent #sentTo:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:18:30'! -sentTo: aMorph localPosition: positionInAMorph - "Dispatch the receiver into anObject" - - type == #mouseMove ifTrue: [ - ^aMorph processMouseMove: self localPosition: positionInAMorph ]. - ^ super sentTo: aMorph localPosition: positionInAMorph! - -MouseButtonEvent removeSelector: #sentTo:localPosition:! - -!methodRemoval: MouseButtonEvent #sentTo:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:18:30'! -sentTo: aMorph localPosition: positionInAMorph - "Dispatch the receiver into anObject" - - type == #mouseDown ifTrue: [ - ^aMorph processMouseDown: self localPosition: positionInAMorph ]. - type == #mouseUp ifTrue: [ - ^aMorph processMouseUp: self localPosition: positionInAMorph ]. - ^super sentTo: aMorph localPosition: positionInAMorph! - -MouseEvent removeSelector: #sentTo:localPosition:! - -!methodRemoval: MouseEvent #sentTo:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:18:30'! -sentTo: aMorph localPosition: positionInAMorph - "Dispatch the receiver into aMorph" - - type == #mouseOver ifTrue: [ - ^aMorph processMouseOver: self localPosition: positionInAMorph ]. - type == #mouseEnter ifTrue: [ - ^ aMorph processMouseEnter: self localPosition: positionInAMorph ]. - type == #mouseLeave ifTrue: [ - ^aMorph processMouseLeave: self localPosition: positionInAMorph ]. - ^ super sentTo: aMorph localPosition: positionInAMorph! - -KeyboardEvent removeSelector: #sentTo:localPosition:! - -!methodRemoval: KeyboardEvent #sentTo:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:18:30'! -sentTo: aMorph localPosition: positionInAMorph - "Dispatch the receiver into anObject" - type == #keystroke ifTrue: [ - self isFindClassShortcut - ifTrue: [ ^ BrowserWindow findClass]. - self isCloseWindowShortcut - ifTrue: [ ^ self closeCurrentWindowOf: aMorph ]. - ^ aMorph - processKeystroke: self - localPosition: positionInAMorph ]. - type == #keyDown ifTrue: [ - ^ aMorph - processKeyDown: self - localPosition: positionInAMorph ]. - type == #keyUp ifTrue: [ - ^ aMorph - processKeyUp: self - localPosition: positionInAMorph ]. - ^ super - sentTo: aMorph - localPosition: positionInAMorph.! - -DropFilesEvent removeSelector: #sentTo:localPosition:! - -!methodRemoval: DropFilesEvent #sentTo:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:18:30'! -sentTo: aMorph localPosition: positionInAMorph - "Dispatch the receiver into aMorph" - - ^aMorph processDropFiles: self localPosition: positionInAMorph! - -DropEvent removeSelector: #sentTo:localPosition:! - -!methodRemoval: DropEvent #sentTo:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:18:30'! -sentTo: aMorph localPosition: positionInAMorph - "Dispatch the receiver into aMorph" - - ^aMorph processDropMorph: self localPosition: positionInAMorph! - -MorphicEvent removeSelector: #sentTo:localPosition:! - -!methodRemoval: MorphicEvent #sentTo:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:18:30'! -sentTo: aMorph localPosition: positionInAMorph - "Dispatch the receiver into aMorph" - - ^ aMorph processUnknownEvent: self localPosition: positionInAMorph! - -InnerTextMorph removeSelector: #processKeystroke:localPosition:! - -!methodRemoval: InnerTextMorph #processKeystroke:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:18:30'! -processKeystroke: aKeyboardEvent localPosition: localEventPosition - "System level event handling." - "localEventPosition?????" - - aKeyboardEvent wasHandled ifTrue:[^self]. - self handlesKeyboard ifFalse: [^ self]. - aKeyboardEvent wasHandled: true. - self keyStroke: aKeyboardEvent! - -Morph removeSelector: #processWindowEvent:localPosition:! - -!methodRemoval: Morph #processWindowEvent:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:18:30'! -processWindowEvent: aWindowEvent localPosition: localEventPosition - "Handle an event concerning our host window" - - aWindowEvent wasHandled ifTrue: [^self]. "not interested" - (self wantsWindowEvent: aWindowEvent) ifFalse: [^self]. - aWindowEvent wasHandled: true. - self windowEvent: aWindowEvent. -! - -Morph removeSelector: #processKeyDown:localPosition:! - -!methodRemoval: Morph #processKeyDown:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:18:30'! -processKeyDown: aKeyboardEvent localPosition: localEventPosition - "System level event handling." - "localEventPosition?????" - - aKeyboardEvent wasHandled ifTrue: [^self]. - self handlesKeyboard ifFalse: [^self]. - aKeyboardEvent wasHandled: true. - ^self keyDown: aKeyboardEvent! - -Morph removeSelector: #processDropFiles:localPosition:! - -!methodRemoval: Morph #processDropFiles:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:18:30'! -processDropFiles: aDropFilesEvent localPosition: localEventPosition - "Handle a dropping file." - - aDropFilesEvent wasHandled ifTrue: [ ^self ]. - - aDropFilesEvent wasHandled: true. - self dropFiles: aDropFilesEvent! - -Morph removeSelector: #processDropMorph:localPosition:! - -!methodRemoval: Morph #processDropMorph:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:18:30'! -processDropMorph: aDropEvent localPosition: localEventPosition - "Handle a dropping morph." - | aMorph | - - aDropEvent wasHandled ifTrue: [ ^self ]. "Do it just once, for one drop destination" - - aMorph _ aDropEvent contents. - aDropEvent wasHandled: true. - self acceptDroppingMorph: aMorph event: aDropEvent. - aMorph justDroppedInto: self event: aDropEvent! - -Morph removeSelector: #processKeystroke:localPosition:! - -!methodRemoval: Morph #processKeystroke:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:18:30'! -processKeystroke: aKeyboardEvent localPosition: localEventPosition - "System level event handling." - "localEventPosition?????" - - aKeyboardEvent wasHandled ifTrue: [^self]. - self handlesKeyboard ifFalse: [^self]. - aKeyboardEvent wasHandled: true. - ^self keyStroke: aKeyboardEvent! - -Morph removeSelector: #processKeyUp:localPosition:! - -!methodRemoval: Morph #processKeyUp:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:18:30'! -processKeyUp: aKeyboardEvent localPosition: localEventPosition - "System level event handling." - "localEventPosition?????" - - aKeyboardEvent wasHandled ifTrue: [^self]. - self handlesKeyboard ifFalse: [^self]. - aKeyboardEvent wasHandled: true. - ^self keyUp: aKeyboardEvent! - -Morph removeSelector: #processUnknownEvent:localPosition:! - -!methodRemoval: Morph #processUnknownEvent:localPosition: stamp: 'Install-4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st 1/7/2021 16:18:30'! -processUnknownEvent: aMorphicEvent localPosition: localEventPosition - "An event of an unknown type was sent to the receiver. What shall we do?!!" - - Smalltalk beep. - aMorphicEvent printString displayAt: `0@0`. - aMorphicEvent wasHandled: true! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4516-remove-sentTolocalPosition-JuanVuletich-2021Jan05-12h47m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4513] on 5 January 2021 at 12:15:13 pm'! -!Morph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 12:08:39'! - dispatchEvent: aMorphicEvent - "This is the central entry for dispatching events in morphic. Given some event, find the right receiver and let him handle it." - - ^ (self rejectsEventFully: aMorphicEvent) - ifTrue: [ #rejected ] - ifFalse: [ aMorphicEvent dispatchWith: self ]! ! -!MorphicEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:09:46'! - dispatchWith: aMorph - "Dispatch me. The event will be passed to the front-most visible submorph that contains the position wrt. to the event." - | handledByInner | - - "Try to get out quickly" - (aMorph fullContainsGlobalPoint: self eventPosition) - ifFalse: [ ^#rejected ]. - - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - (eachChild dispatchEvent: self) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - - "Check for being inside the receiver" - (handledByInner or: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: self eventPosition] ]) - ifTrue: [ ^ self sendEventTo: aMorph ]. - - ^ #rejected! ! -!DropEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:08:46' overrides: 50563947! - dispatchWith: aMorph - "Drop is done on the innermost target that accepts it." - | dropped | - - "Try to get out quickly" - (aMorph fullContainsGlobalPoint: position) - ifFalse: [ ^#rejected ]. - - "Go looking if any of our submorphs wants it" - aMorph submorphsDo: [ :eachChild | - (eachChild dispatchEvent: self) == #rejected ifFalse: [ - ^self ]]. - - (aMorph allowsMorphDrop and: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position] ]) - ifTrue: [ - "Do a symmetric check if both morphs like each other" - dropped _ self contents. - ((aMorph wantsDroppedMorph: dropped event: self) "I want her" - and: [dropped wantsToBeDroppedInto: aMorph]) "she wants me" - ifTrue: [ - ^ self sendEventTo: aMorph ]]. - ^#rejected! ! -!DropFilesEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:09:18' overrides: 50563947! - dispatchWith: aMorph - "Drop is done on the innermost target that accepts it." - - "Try to get out quickly" - (aMorph fullContainsGlobalPoint: position) ifFalse: [ ^#rejected ]. - - "Go looking if any of our submorphs wants it" - aMorph submorphsDo: [ :eachChild | - (eachChild dispatchEvent: self) == #rejected ifFalse: [ ^self ]]. - - (aMorph allowsFilesDrop and: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position] ]) - ifTrue: [^ self sendEventTo: aMorph ]. - - ^#rejected! ! -!MouseButtonEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:10:27' overrides: 50563947! - dispatchWith: aMorph - "Find the appropriate receiver for the event and let it handle it. Default rules: - * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. - * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. - * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. - * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. - " - | aMorphHandlesIt grabAMorph handledByInner | - "Only for MouseDown" - self isMouseDown ifFalse: [ - ^super dispatchWith: aMorph ]. - - "Try to get out quickly" - (aMorph fullContainsGlobalPoint: position) - ifFalse: [ ^#rejected ]. - - "Install the prospective handler for the receiver" - aMorphHandlesIt _ false. - grabAMorph _ false. - self mouseButton3Pressed - ifTrue: [ - (eventHandler isNil or: [ eventHandler isWorldMorph or: [ - self shiftPressed or: [ aMorph is: #HaloMorph ]]]) - ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]] - ifFalse: [ - (aMorph handlesMouseDown: self) ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]. - "If button 1, and both aMorph and the owner allows grabbing with the hand (to initiate drag & drop), so be it." - self mouseButton1Pressed ifTrue: [ - aMorph owner ifNotNil: [ :o | - (o allowsSubmorphDrag and: [ aMorph isSticky not ]) ifTrue: [ - grabAMorph _ true ]]]]. - - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - (eachChild dispatchEvent: self) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - - (handledByInner or: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position] ]) ifTrue: [ - "aMorph is in the top-most unlocked, visible morph in the chain." - aMorphHandlesIt - ifTrue: [ ^self sendEventTo: aMorph ] - ifFalse: [ - (grabAMorph and: [ handledByInner not ]) ifTrue: [ - self hand - waitForClicksOrDrag: aMorph event: self - dragSel: (Preferences clickGrabsMorphs ifFalse: [#dragEvent:localPosition:]) - clkSel: (Preferences clickGrabsMorphs ifTrue: [#dragEvent:localPosition:]). - "false ifTrue: [ self hand grabMorph: aMorph ]." - Preferences clickGrabsMorphs ifFalse: [aMorph activateWindow]. - self wasHandled: true. - ^self ]]]. - - handledByInner ifTrue: [ ^self ]. - "Mouse was not on aMorph nor any of its children" - ^ #rejected! ! -!MouseScrollEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:10:57' overrides: 50563947! - dispatchWith: aMorph - "Find the appropriate receiver for the event and let it handle it. Default rules: - * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. - * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. - * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. - * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. - " - "Try to get out quickly" - | aMorphHandlesIt handledByInner focus| - focus := self hand keyboardFocus. - "FIXME - this works in all tested cases but one: when the window directly under the mouse doesn't have keyboard focus (i.e. a Transcript window)" - ((aMorph fullContainsGlobalPoint: position) and: [(aMorph = focus) or: [focus notNil and: [aMorph notNil and: [focus hasOwner: aMorph]]]]) ifFalse: [ ^ #rejected ]. - "Install the prospective handler for the receiver" - aMorphHandlesIt _ false. - (aMorph handlesMouseScroll: self) ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]. - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - (eachChild dispatchEvent: self) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - (handledByInner or: [ - (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position]]) ifTrue: [ - "aMorph is in the top-most unlocked, visible morph in the chain." - aMorphHandlesIt ifTrue: [ ^ self sendEventTo: aMorph ]]. - handledByInner ifTrue: [ ^ self ]. - "Mouse was not on aMorph nor any of its children" - ^ #rejected.! ! -!WindowEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 12:11:04' overrides: 50563947! - dispatchWith: aMorph - "Host window events do not have a position and are only dispatched to the World" - - aMorph isWorldMorph ifFalse: [ ^#rejected ]. - self wasHandled ifTrue: [ ^self ]. - ^ self sendEventTo: aMorph! ! -!HandMorph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 12:12:30' prior: 16851794! - startDropEventDispatch: aDropEvent - - owner dispatchEvent: aDropEvent. - self mouseOverHandler processMouseOver: lastMouseEvent! ! -!HandMorph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 12:12:36' prior: 50424822! - startDropFilesEventDispatch: aDropFilesEvent - - owner dispatchEvent: aDropFilesEvent. - self mouseOverHandler processMouseOver: lastMouseEvent! ! -!HandMorph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 12:13:52' prior: 50562411! - startMouseDispatch: aMouseEvent - - aMouseEvent isMouseOver ifTrue: [ - ^self mouseFocus - ifNotNil: [ mouseFocus handleFocusEvent: aMouseEvent ] - ifNil: [ owner dispatchEvent: aMouseEvent ]]. - - "any mouse event but mouseOver" - lastMouseEvent _ aMouseEvent. - lastMouseEventTime _ Time localMillisecondClock. - - "Check for pending drag or double click operations." - mouseClickState ifNotNil: [ - (mouseClickState handleEvent: aMouseEvent from: self) ifTrue: [ - "Possibly dispatched #click: or something. Do not further process this event." - ^self mouseOverHandler processMouseOver: lastMouseEvent ]]. - - aMouseEvent isMove - ifTrue: [ - self morphPosition: aMouseEvent eventPosition. - self mouseFocus - ifNotNil: [ mouseFocus handleFocusEvent: aMouseEvent ] - ifNil: [ owner dispatchEvent: aMouseEvent ] - ] ifFalse: [ - aMouseEvent isMouseScroll ifTrue: [ - owner dispatchEvent: aMouseEvent - ] ifFalse: [ - "Issue a synthetic move event if we're not at the position of the event" - aMouseEvent eventPosition = self morphPosition ifFalse: [ - "Issue a mouse move event to make the receiver appear at the given position" - self startMouseDispatch: (MouseMoveEvent new - setType: #mouseMove - position: aMouseEvent eventPosition - buttons: aMouseEvent buttons - hand: self - stamp: aMouseEvent timeStamp) ]. - "Drop submorphs on button events" - self hasSubmorphs - ifTrue: [ - "Not if we are grabbing them" - mouseClickState ifNil: [ - "Want to drop on mouseUp, NOT mouseDown" - aMouseEvent isMouseUp ifTrue: [ - self dropMorphs: aMouseEvent ] - ] - ] ifFalse: [ - self mouseFocus - ifNotNil: [ mouseFocus handleFocusEvent: aMouseEvent ] - ifNil: [ owner dispatchEvent: aMouseEvent ]]]]. - self mouseOverHandler processMouseOver: self lastMouseEvent! ! -!HandMorph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 12:12:53' prior: 16851875! - startWindowEventDispatch: aWindowEvent - - owner dispatchEvent: aWindowEvent. - self mouseOverHandler processMouseOver: lastMouseEvent! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 1/5/2021 12:12:23' prior: 16852020! - dropMorph: aMorph event: aMouseEvent - "Drop the given morph which was carried by the hand" - | morphData dropEvent | - morphData := self grabMorphDataFor: aMorph. - dropEvent _ DropEvent new - setPosition: self morphPosition - contents: aMorph - hand: self - formerOwner: (morphData at: 1) - formerPosition: (morphData at: 2). - owner dispatchEvent: dropEvent. - dropEvent wasHandled ifFalse: [ aMorph rejectDropMorphEvent: dropEvent ]. - self forgetGrabMorphDataFor: aMorph. - self mouseOverHandler processMouseOver: aMouseEvent! ! -!MenuMorph methodsFor: 'events-processing' stamp: 'jmv 1/5/2021 12:13:16' prior: 50563292 overrides: 50563281! - handleFocusEvent: aMorphicEvent - "Handle focus events. Valid menu transitions are determined based on the menu currently holding the focus after the mouse went down on one of its children." - - self dispatchEvent: aMorphicEvent. - - "Need to handle keyboard input if we have the focus." - aMorphicEvent isKeyboard ifTrue: [ ^ aMorphicEvent sendEventTo: self ]. - - "We need to handle button clicks outside and transitions to local popUps so throw away everything else" - (aMorphicEvent isMouseOver or: [aMorphicEvent isMouse not]) ifTrue: [ ^self ]. - "What remains are mouse buttons and moves" - aMorphicEvent isMove ifFalse: [ ^ aMorphicEvent sendEventTo: self ]. "handle clicks outside by regular means" - "Now it's getting tricky. On #mouseMove we might transfer control to *either* the currently active submenu or the pop up owner, if any. Since the active sub menu is always displayed upfront check it first." - selectedItem ifNotNil:[(selectedItem activateSubmenu: aMorphicEvent) ifTrue: [^self]]. - "Note: The following does not traverse upwards but it's the best I can do for now" - popUpOwner ifNotNil:[(popUpOwner activateOwnerMenu: aMorphicEvent) ifTrue: [^self]].! ! - -WindowEvent removeSelector: #dispatchWith:localPosition:! - -!methodRemoval: WindowEvent #dispatchWith:localPosition: stamp: 'Install-4517-remove-dispatchWithlocalPosition-JuanVuletich-2021Jan05-12h08m-jmv.001.cs.st 1/7/2021 16:18:30'! -dispatchWith: aMorph localPosition: positionInAMorph - "Host window events do not have a position and are only dispatched to the World" - - aMorph isWorldMorph ifFalse: [ ^#rejected ]. - self wasHandled ifTrue: [ ^self ]. - ^ self sendEventTo: aMorph! - -MouseScrollEvent removeSelector: #dispatchWith:localPosition:! - -!methodRemoval: MouseScrollEvent #dispatchWith:localPosition: stamp: 'Install-4517-remove-dispatchWithlocalPosition-JuanVuletich-2021Jan05-12h08m-jmv.001.cs.st 1/7/2021 16:18:30'! -dispatchWith: aMorph localPosition: positionInAMorph - "Find the appropriate receiver for the event and let it handle it. Default rules: - * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. - * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. - * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. - * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. - " - "Try to get out quickly" - | aMorphHandlesIt handledByInner eventPositionInChild focus| - focus := self hand keyboardFocus. - "FIXME - this works in all tested cases but one: when the window directly under the mouse doesn't have keyboard focus (i.e. a Transcript window)" - ((aMorph fullContainsGlobalPoint: position) and: [(aMorph = focus) or: [focus notNil and: [aMorph notNil and: [focus hasOwner: aMorph]]]]) ifFalse: [ ^ #rejected ]. - "Install the prospective handler for the receiver" - aMorphHandlesIt _ false. - (aMorph handlesMouseScroll: self) ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]. - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild - dispatchEvent: self - localPosition: eventPositionInChild) == #rejected ifFalse: [ "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - (handledByInner or: [ - (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position]]) ifTrue: [ - "aMorph is in the top-most unlocked, visible morph in the chain." - aMorphHandlesIt ifTrue: [ ^ self sendEventTo: aMorph ]]. - handledByInner ifTrue: [ ^ self ]. - "Mouse was not on aMorph nor any of its children" - ^ #rejected.! - -MouseButtonEvent removeSelector: #dispatchWith:localPosition:! - -!methodRemoval: MouseButtonEvent #dispatchWith:localPosition: stamp: 'Install-4517-remove-dispatchWithlocalPosition-JuanVuletich-2021Jan05-12h08m-jmv.001.cs.st 1/7/2021 16:18:30'! -dispatchWith: aMorph localPosition: positionInAMorph - "Find the appropriate receiver for the event and let it handle it. Default rules: - * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. - * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. - * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. - * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. - " - | aMorphHandlesIt grabAMorph handledByInner eventPositionInChild | - "Only for MouseDown" - self isMouseDown ifFalse: [ - ^super dispatchWith: aMorph localPosition: positionInAMorph ]. - - "Try to get out quickly" - (aMorph fullContainsGlobalPoint: position) - ifFalse: [ ^#rejected ]. - - "Install the prospective handler for the receiver" - aMorphHandlesIt _ false. - grabAMorph _ false. - self mouseButton3Pressed - ifTrue: [ - (eventHandler isNil or: [ eventHandler isWorldMorph or: [ - self shiftPressed or: [ aMorph is: #HaloMorph ]]]) - ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]] - ifFalse: [ - (aMorph handlesMouseDown: self) ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]. - "If button 1, and both aMorph and the owner allows grabbing with the hand (to initiate drag & drop), so be it." - self mouseButton1Pressed ifTrue: [ - aMorph owner ifNotNil: [ :o | - (o allowsSubmorphDrag and: [ aMorph isSticky not ]) ifTrue: [ - grabAMorph _ true ]]]]. - - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - - (handledByInner or: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position] ]) ifTrue: [ - "aMorph is in the top-most unlocked, visible morph in the chain." - aMorphHandlesIt - ifTrue: [ ^self sendEventTo: aMorph ] - ifFalse: [ - (grabAMorph and: [ handledByInner not ]) ifTrue: [ - self hand - waitForClicksOrDrag: aMorph event: self - dragSel: (Preferences clickGrabsMorphs ifFalse: [#dragEvent:localPosition:]) - clkSel: (Preferences clickGrabsMorphs ifTrue: [#dragEvent:localPosition:]). - "false ifTrue: [ self hand grabMorph: aMorph ]." - Preferences clickGrabsMorphs ifFalse: [aMorph activateWindow]. - self wasHandled: true. - ^self ]]]. - - handledByInner ifTrue: [ ^self ]. - "Mouse was not on aMorph nor any of its children" - ^ #rejected! - -DropFilesEvent removeSelector: #dispatchWith:localPosition:! - -!methodRemoval: DropFilesEvent #dispatchWith:localPosition: stamp: 'Install-4517-remove-dispatchWithlocalPosition-JuanVuletich-2021Jan05-12h08m-jmv.001.cs.st 1/7/2021 16:18:30'! -dispatchWith: aMorph localPosition: positionInAMorph - "Drop is done on the innermost target that accepts it." - - | eventPositionInChild | - - "Try to get out quickly" - (aMorph fullContainsGlobalPoint: position) ifFalse: [ ^#rejected ]. - - "Go looking if any of our submorphs wants it" - aMorph submorphsDo: [ :eachChild | - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ ^self ]]. - - (aMorph allowsFilesDrop and: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position] ]) - ifTrue: [^ self sendEventTo: aMorph ]. - - ^#rejected! - -DropEvent removeSelector: #dispatchWith:localPosition:! - -!methodRemoval: DropEvent #dispatchWith:localPosition: stamp: 'Install-4517-remove-dispatchWithlocalPosition-JuanVuletich-2021Jan05-12h08m-jmv.001.cs.st 1/7/2021 16:18:30'! -dispatchWith: aMorph localPosition: positionInAMorph - "Drop is done on the innermost target that accepts it." - | eventPositionInChild dropped | - - "Try to get out quickly" - (aMorph fullContainsGlobalPoint: position) - ifFalse: [ ^#rejected ]. - - "Go looking if any of our submorphs wants it" - aMorph submorphsDo: [ :eachChild | - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ - ^self ]]. - - (aMorph allowsMorphDrop and: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position] ]) - ifTrue: [ - "Do a symmetric check if both morphs like each other" - dropped _ self contents. - ((aMorph wantsDroppedMorph: dropped event: self) "I want her" - and: [dropped wantsToBeDroppedInto: aMorph]) "she wants me" - ifTrue: [ - ^ self sendEventTo: aMorph ]]. - ^#rejected! - -MorphicEvent removeSelector: #dispatchWith:localPosition:! - -!methodRemoval: MorphicEvent #dispatchWith:localPosition: stamp: 'Install-4517-remove-dispatchWithlocalPosition-JuanVuletich-2021Jan05-12h08m-jmv.001.cs.st 1/7/2021 16:18:30'! -dispatchWith: aMorph localPosition: positionInAMorph - "Dispatch me. The event will be passed to the front-most visible submorph that contains the position wrt. to the event." - | handledByInner eventPositionInChild | - - "Try to get out quickly" - (aMorph fullContainsGlobalPoint: self eventPosition) - ifFalse: [ ^#rejected ]. - - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - eventPositionInChild _ eachChild internalize: positionInAMorph. - (eachChild dispatchEvent: self localPosition: eventPositionInChild) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - - "Check for being inside the receiver" - (handledByInner or: [ (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: self eventPosition] ]) - ifTrue: [ ^ self sendEventTo: aMorph ]. - - ^ #rejected! - -Morph removeSelector: #dispatchEvent:localPosition:! - -!methodRemoval: Morph #dispatchEvent:localPosition: stamp: 'Install-4517-remove-dispatchWithlocalPosition-JuanVuletich-2021Jan05-12h08m-jmv.001.cs.st 1/7/2021 16:18:30'! -dispatchEvent: aMorphicEvent localPosition: localPosition - "This is the central entry for dispatching events in morphic. Given some event, find the right receiver and let him handle it. - localPosition is in our coordinates." - - ^ (self rejectsEventFully: aMorphicEvent) - ifTrue: [ #rejected ] - ifFalse: [ aMorphicEvent dispatchWith: self localPosition: localPosition ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4517-remove-dispatchWithlocalPosition-JuanVuletich-2021Jan05-12h08m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4517] on 5 January 2021 at 1:15:41 pm'! -!TextEditor methodsFor: 'typing support' stamp: 'jmv 1/5/2021 13:14:39'! - processKeystrokeEvent: aKeyboardEvent - "Key struck on the keyboard. Find out which one and, if special, carry - out the associated special action. Otherwise, add the character to the - stream of characters." - - (self dispatchOn: aKeyboardEvent) ifTrue: [ - self storeSelectionInComposition. - ^self]. - - markBlock _ pointBlock. - self storeSelectionInComposition! ! -!InnerTextMorph methodsFor: 'event handling' stamp: 'jmv 1/5/2021 13:14:54'! - processKeystrokeEvent: evt - | action | - - (acceptOnCR and: [evt isReturnKey]) ifTrue: [^ self acceptContents]. - - self pauseBlinking. - - "Return - check for special action" - evt isReturnKey ifTrue: [ - action _ self crAction. - action ifNotNil: [ ^action value]]. - - "Esc - check for special action" - evt isEsc ifTrue: [ - action _ self escAction. - action ifNotNil: [ ^action value]]. - - self handleInteraction: [ editor processKeystrokeEvent: evt ]. - self scrollSelectionIntoView! ! -!InnerTextMorph methodsFor: 'events' stamp: 'jmv 1/5/2021 13:14:49' prior: 50466042 overrides: 50449234! - keyStroke: aKeyboardEvent - - (self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - - autoCompleter - ifNil: [ self processKeystrokeEvent: aKeyboardEvent ] - ifNotNil: [ - autoCompleter - autoCompletionAround: [ self processKeystrokeEvent: aKeyboardEvent ] - keyStroke: aKeyboardEvent ]. - - super keyStroke: aKeyboardEvent! ! - -InnerTextMorph removeSelector: #processKeyStroke:! - -!methodRemoval: InnerTextMorph #processKeyStroke: stamp: 'Install-4518-AvoidConfusingSelector-JuanVuletich-2021Jan05-13h08m-jmv.001.cs.st 1/7/2021 16:18:30'! -processKeyStroke: evt - | action | - - (acceptOnCR and: [evt isReturnKey]) ifTrue: [^ self acceptContents]. - - self pauseBlinking. - - "Return - check for special action" - evt isReturnKey ifTrue: [ - action _ self crAction. - action ifNotNil: [ ^action value]]. - - "Esc - check for special action" - evt isEsc ifTrue: [ - action _ self escAction. - action ifNotNil: [ ^action value]]. - - self handleInteraction: [ editor processKeyStroke: evt ]. - self scrollSelectionIntoView! - -TextEditor removeSelector: #processKeyStroke:! - -!methodRemoval: TextEditor #processKeyStroke: stamp: 'Install-4518-AvoidConfusingSelector-JuanVuletich-2021Jan05-13h08m-jmv.001.cs.st 1/7/2021 16:18:30'! -processKeyStroke: aKeyboardEvent - "Key struck on the keyboard. Find out which one and, if special, carry - out the associated special action. Otherwise, add the character to the - stream of characters." - - (self dispatchOn: aKeyboardEvent) ifTrue: [ - self storeSelectionInComposition. - ^self]. - - markBlock _ pointBlock. - self storeSelectionInComposition! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4518-AvoidConfusingSelector-JuanVuletich-2021Jan05-13h08m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4518] on 5 January 2021 at 2:48:26 pm'! -!MorphicEvent methodsFor: 'dispatching' stamp: 'jmv 1/5/2021 14:47:51'! - sentTo: aMorph localPosition: positionInAMorph - "Dispatch the receiver into aMorph" - - ^ self wasHandled: true! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -[ - (Delay forSeconds: 1) wait. - SystemChangeNotifier uniqueInstance doSilently: [ - MorphicEvent removeSelector: #sentTo:localPosition:. - SmalltalkCompleter initialize] -] fork! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4519-AvoidWalkback-JuanVuletich-2021Jan05-14h47m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4519] on 6 January 2021 at 12:01:26 pm'! -!String methodsFor: 'converting' stamp: 'jmv 1/6/2021 11:51:13'! - findPositiveInteger - "Answer the Integer created by interpreting the receiver as the string representation of an integer. - Answer nil if no digits, else find the first digit and then all consecutive digits after that" - - | startPosition tail endPosition | - startPosition _ self findFirst: [:ch | ch isDigit]. - startPosition = 0 ifTrue: [^ nil]. - tail _ self copyFrom: startPosition to: self size. - endPosition _ tail findFirst: [:ch | ch isDigit not]. - endPosition = 0 ifTrue: [endPosition _ tail size + 1]. - ^ Number readFrom: (tail copyFrom: 1 to: endPosition - 1) readStream - -" -'1796exportFixes-tkMX' findPositiveInteger -'1848recentLogFile-sw' findPositiveInteger -'donald' findPositiveInteger -'abc234def567' findPositiveInteger -"! ! - -String removeSelector: #asInteger! - -!methodRemoval: String #asInteger stamp: 'Install-4520-Rename-String-asInteger-to-findPositiveInteger-JuanVuletich-2021Jan06-11h51m-jmv.001.cs.st 1/7/2021 16:18:30'! -asInteger - "Answer the Integer created by interpreting the receiver as the string representation of an integer. Answer nil if no digits, else find the first digit and then all consecutive digits after that" - - | startPosition tail endPosition | - startPosition _ self findFirst: [:ch | ch isDigit]. - startPosition = 0 ifTrue: [^ nil]. - tail _ self copyFrom: startPosition to: self size. - endPosition _ tail findFirst: [:ch | ch isDigit not]. - endPosition = 0 ifTrue: [endPosition _ tail size + 1]. - ^ Number readFrom: (tail copyFrom: 1 to: endPosition - 1) readStream - -" -'1796exportFixes-tkMX' asInteger -'1848recentLogFile-sw' asInteger -'donald' asInteger -'abc234def567' asInteger -"! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4520-Rename-String-asInteger-to-findPositiveInteger-JuanVuletich-2021Jan06-11h51m-jmv.001.cs.st----! - -----SNAPSHOT----(7 January 2021 16:18:45) Cuis5.0-4520-v3.image priorSource: 7366069! - -----STARTUP---- (16 January 2021 19:17:21) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4520-v3.image! - - -'From Cuis 5.0 [latest update: #4520] on 13 January 2021 at 12:03:37 pm'! - -MenuItemMorph subclass: #HighlightingMenuItemMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #HighlightingMenuItemMorph category: #'Morphic-Menus' stamp: 'Install-4521-HighlightEmbeddingTargetWhenHoveringMenu-JuanVuletich-2021Jan13-12h02m-jmv.001.cs.st 1/16/2021 19:17:26'! -MenuItemMorph subclass: #HighlightingMenuItemMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! -!HighlightingMenuItemMorph commentStamp: '' prior: 0! - Highlights the target when hovered.! -!Morph methodsFor: 'accessing - flags' stamp: 'jmv 1/13/2021 11:03:38'! - highlighted: aBoolean - - self privateFlagAt: 5 put: aBoolean. - self redrawNeeded! ! -!Morph methodsFor: 'accessing - flags' stamp: 'jmv 1/13/2021 09:54:34'! - isHighlighted - - ^ self privateFlagAt: 5! ! -!HighlightingMenuItemMorph methodsFor: 'selecting' stamp: 'jmv 1/13/2021 10:41:50' overrides: 16866146! - isSelected: aBoolean - - super isSelected: aBoolean. - target highlighted: aBoolean.! ! -!MenuMorph methodsFor: 'accessing' stamp: 'jmv 1/13/2021 10:57:10'! - itemsDo: aBlock - - submorphs do: [ :m | - (m is: #MenuItemMorph) ifTrue: [ - aBlock value: m ]].! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 1/13/2021 10:44:39'! - add: aString targetHighlight: target action: aSymbol argumentList: argList - "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument. - Highlight target when hovering over item. - Answer the appended menu item." - - | item | - item _ HighlightingMenuItemMorph new - contents: aString; - target: target selector: aSymbol arguments: argList asArray. - self addMorphBack: item. - ^ item! ! -!BitBltCanvas methodsFor: 'drawing' stamp: 'jmv 1/13/2021 11:57:47'! - drawCurrentMorphHighlight - - currentMorph displayBounds ifNotNil: [ :r | - engine - sourceForm: nil; - colorMap: nil; - combinationRule: Form blend; - fillColor: `Color black`; - frameRect: r borderWidth: 4; - fillColor: `Color pink alpha: 0.2`; - fillRect: (r insetBy: 4). - ]! ! -!Morph methodsFor: 'meta-actions' stamp: 'jmv 1/13/2021 10:43:33' prior: 50393077! - addEmbeddingMenuItemsTo: aMenu hand: aHandMorph - | menu | - menu _ MenuMorph new defaultTarget: self. - self potentialEmbeddingTargets reverseDo: [:m | - menu - add: m class name asString - targetHighlight: m - action: #addMorphFrontFromWorldPosition: - argumentList: {self}]. - aMenu ifNotNil:[ - menu submorphCount > 0 - ifTrue:[aMenu add:'embed into' subMenu: menu]. - ]. - ^menu! ! -!MenuMorph methodsFor: 'initialization' stamp: 'jmv 1/13/2021 10:58:22' prior: 50341025 overrides: 16876882! - delete - activeSubMenu ifNotNil: [activeSubMenu delete]. - self itemsDo: [ :i | i deselect ]. - ^super delete! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 1/13/2021 11:12:00' prior: 50561111 overrides: 50561140! - drawCurrentAndSubmorphs - | b | - self isCurrentMorphVisible ifTrue: [ - currentMorph drawOn: self. - world notNil ifTrue: [ "Only if we are drawing the world" - currentMorph halo ifNotNil: [ b _ currentMorph morphLocalBounds ]. - currentMorph displayBounds: self boundingRectOfCurrentMorphAfterDraw ]. - "Display submorphs back to front" - "coordinate system stack already set up for aMorph - ('ivars transformations' and 'currentTransformation')" - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | self fullDraw: m ]]. - currentMorph postDrawOn: self. - b ifNotNil: [ - self drawCoordinateSystem: b ]. - world notNil ifTrue: [ "Only if we are drawing the world" - currentMorph displayBounds: - (currentMorph displayBounds quickMerge: self boundingRectOfCurrentMorphAfterDraw) ]. - - currentMorph isHighlighted ifTrue: [ - self drawCurrentMorphHighlight ]. - ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4521-HighlightEmbeddingTargetWhenHoveringMenu-JuanVuletich-2021Jan13-12h02m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4520] on 13 January 2021 at 10:30:53 am'! -!Morph methodsFor: 'accessing - flags' stamp: 'jmv 1/13/2021 09:59:07' prior: 50537561! - layoutNeeded: aBoolean - - self privateFlagAt: 4 put: aBoolean! ! -!Morph methodsFor: 'accessing - flags' stamp: 'jmv 1/13/2021 09:59:11' prior: 50537566! - needsRedraw: aBoolean - - self privateFlagAt: 1 put: aBoolean! ! -!Morph methodsFor: 'accessing - flags' stamp: 'jmv 1/13/2021 09:59:15' prior: 50537571! - submorphNeedsRedraw: aBoolean - - self privateFlagAt: 2 put: aBoolean! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4522-SmallCleanup-JuanVuletich-2021Jan13-10h30m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4522] on 14 January 2021 at 6:08:02 pm'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 1/14/2021 18:07:38' prior: 50561140! - drawCurrentAndSubmorphs - - self subclassResponsibility! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4523-Cleanup-JuanVuletich-2021Jan14-18h07m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4523] on 15 January 2021 at 5:05:05 pm'! -!HandMorph methodsFor: 'double click support' stamp: 'jmv 1/14/2021 18:49:09' prior: 16851481! - dontWaitForMoreClicks - "Reset the double-click detection state to normal (i.e., not waiting for a double-click). - This happens after timeout, regardless of multiple clicks having been detected or not." - - mouseClickState _ nil.! ! -!HandMorph methodsFor: 'event handling' stamp: 'jmv 1/15/2021 16:51:21' prior: 50426478! - processEventQueue - "Process user input events from the local input devices. - Answer true if any event was handled (but ignore MouseMove)" - - | evt evtBuf type hadAny mcs hadAnyMouseEvent | - mcs _ mouseClickState. - hadAny := false. - hadAnyMouseEvent := false. - [ (evtBuf := Sensor nextEvent) isNil ] whileFalse: [ - type := evtBuf first. - evt := self createEventFrom: evtBuf ofType: type. - evt ifNotNil: [ - "Finally, handle it" - self startEventDispatch: evt. - hadAny := true. - evt isMouse ifTrue: [ - hadAnyMouseEvent := true ]]]. - hadAnyMouseEvent ifFalse: [ - mcs - ifNotNil: [ - "No mouse events during this cycle. Make sure click states time out accordingly" - mcs - handleEvent: (self lastMouseEvent asMouseMove: (Time localMillisecondClock - self lastMouseEventTime max: 0)) - from: self ]]. - ^hadAny! ! -!WorldMorph methodsFor: 'interaction loop' stamp: 'jmv 1/15/2021 16:14:27' prior: 50553215! - mainLoop - - - self clearWaitDelay. - self setCanvas. - [ - self doOneCycle. - true ] - whileTrue: []! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 1/15/2021 17:04:27' prior: 50560716! - doOneCycle - "Do one cycle of the interaction loop. This method is called repeatedly when the world is running. - - Make for low cpu usage if the ui is inactive, but quick response when ui is in use. - However, after some inactivity, there will be a larger delay before the ui gets responsive again." - - | wait waitUntil a | - waitDelay ifNil: [ waitDelay _ Delay forMilliseconds: 50 ]. - (lastCycleHadAnyEvent or: [ deferredUIMessages isEmpty not ]) - ifTrue: [ - pause _ 20. "This value will only be used later, when there are no more events to serve or deferred UI messages to process." - wait _ 0. "Don't wait this time"] - ifFalse: [ - "wait between 20 and 200 milliseconds" - (hands anySatisfy: [ :h | h waitingForMoreClicks ]) - ifTrue: [ pause _ 20 ] - ifFalse: [ pause < 200 ifTrue: [ pause _ pause * 21//20 ] ]. - waitUntil _ lastCycleTime + pause. - "Earlier if steps" - stepList isEmpty not ifTrue: [ - waitUntil _ waitUntil min: stepList first scheduledTime ]. - "Earlier if alarms" - alarms ifNotNil: [ - alarms isEmpty not ifTrue: [ - waitUntil _ waitUntil min: alarms first scheduledTime ]]. - wait _ waitUntil - Time localMillisecondClock max: 0 ]. - Preferences serverMode - ifTrue: [ wait _ wait max: 50 ]. "Always wait at least a bit on servers, even if this makes the UI slow." - wait = 0 - ifTrue: [ Processor yield ] - ifFalse: [ - waitDelay beingWaitedOn - ifFalse: [ waitDelay setDelay: wait; wait ] - ifTrue: [ - "If we are called from a different process than that of the main UI, we might be called in the main - interCyclePause. In such case, use a new Delay to avoid 'This Delay has already been scheduled' errors" - (Delay forMilliseconds: wait) wait ]]. - - "Record start time of this cycle, and do cycle" - lastCycleTime _ Time localMillisecondClock. - lastCycleHadAnyEvent _ self doOneCycleNow.! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 1/15/2021 16:51:48' prior: 50551772! - doOneCycleNow - "Immediately do one cycle of the interaction loop. - Only used for a few tests." - "See #eventTickler" - | hadAny | - Cursor currentCursor = (Cursor cursorAt: #waitCursor) ifTrue: [ Cursor defaultCursor activateCursor ]. - "Repair visual damage." - DisplayScreen checkForNewScreenSize. - self displayWorldSafely. - "Run steps, alarms and deferred UI messages" - self runStepMethods. - "Process user input events. Run all event triggered code." - hadAny _ false. - self handsDo: [ :h | - activeHand _ h. - hadAny _ hadAny | h processEventQueue. - activeHand _ nil ]. - "The default is the primary hand" - activeHand _ self hands first. - ^ hadAny.! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -| guiRootObject | -Utilities authorInitialsPerSe ifNil: [ Utilities setAuthor ]. -(nil confirm: 'We need to restart the User Interface process. -You''ll need to do [Install New Updates] again, to install later updates.') ifFalse: [ self halt ]. -[ - guiRootObject _ UISupervisor ui. - UISupervisor stopUIProcess. - UISupervisor spawnNewMorphicProcessFor: guiRootObject. - (Delay forSeconds: 1) wait. - ChangeSet installing: '4524-MorphicEventsCleanup-JuanVuletich-2021Jan15-16h08m-jmv.003.cs.st' do: []. - cs _ ChangeSet changeSetForBaseSystem. - (cs name beginsWith: '4524') ifTrue: [ - ChangeSet removeChangeSet: cs ]. - 'Done updating Morphic ui process code.' print. - 'Installed ChangeSet: 4524-MorphicEventsCleanup-JuanVuletich-2021Jan15-16h08m-jmv.003.cs.st' print. - 'Please do [Install New Updates] again.' print. -] forkAt: 41! - -'From Cuis 5.0 [latest update: #4523] on 15 January 2021 at 5:36:41 pm'! -!MouseEvent methodsFor: 'converting' stamp: 'jmv 1/14/2021 21:22:43'! - asMouseMove - - ^ MouseMoveEvent new - setType: #mouseMove - position: position - buttons: buttons - hand: source - stamp: Time millisecondClockValue "VMs report events using #millisecondClockValue"! ! -!HandMorph methodsFor: 'event handling' stamp: 'jmv 1/15/2021 17:35:56' prior: 50565024! - processEventQueue - "Process user input events from the local input devices. - Answer true if any event was handled (but ignore MouseMove)" - - | evt evtBuf type hadAny mcs hadAnyMouseEvent | - mcs _ mouseClickState. - hadAny := false. - hadAnyMouseEvent := false. - [ (evtBuf := Sensor nextEvent) isNil ] whileFalse: [ - type := evtBuf first. - evt := self createEventFrom: evtBuf ofType: type. - evt ifNotNil: [ - "Finally, handle it" - self startEventDispatch: evt. - hadAny := true. - evt isMouse ifTrue: [ - hadAnyMouseEvent := true ]]]. - hadAnyMouseEvent ifFalse: [ - mcs - ifNotNil: [ - "No mouse events during this cycle. Make sure click states time out accordingly" - mcs - handleEvent: lastMouseEvent asMouseMove - from: self ]]. - ^hadAny! ! -!HandMorph methodsFor: 'events-processing' stamp: 'jmv 1/15/2021 17:15:12' prior: 50447146! - startKeyboardDispatch: aKeyboardEvent - - | focusedElement | - - focusedElement _ self keyboardFocus ifNil: [ self world ]. - focusedElement handleFocusEvent: aKeyboardEvent. - - self mouseOverHandler processMouseOver: lastMouseEvent! ! -!HandMorph methodsFor: 'events-processing' stamp: 'jmv 1/15/2021 17:15:17' prior: 50564204! - startMouseDispatch: aMouseEvent - - aMouseEvent isMouseOver ifTrue: [ - ^self mouseFocus - ifNotNil: [ mouseFocus handleFocusEvent: aMouseEvent ] - ifNil: [ owner dispatchEvent: aMouseEvent ]]. - - "any mouse event but mouseOver" - lastMouseEvent _ aMouseEvent. - lastMouseEventTime _ Time localMillisecondClock. - - "Check for pending drag or double click operations." - mouseClickState ifNotNil: [ - (mouseClickState handleEvent: aMouseEvent from: self) ifTrue: [ - "Possibly dispatched #click: or something. Do not further process this event." - ^self mouseOverHandler processMouseOver: lastMouseEvent ]]. - - aMouseEvent isMove - ifTrue: [ - self morphPosition: aMouseEvent eventPosition. - self mouseFocus - ifNotNil: [ mouseFocus handleFocusEvent: aMouseEvent ] - ifNil: [ owner dispatchEvent: aMouseEvent ] - ] ifFalse: [ - aMouseEvent isMouseScroll ifTrue: [ - owner dispatchEvent: aMouseEvent - ] ifFalse: [ - "Issue a synthetic move event if we're not at the position of the event" - aMouseEvent eventPosition = self morphPosition ifFalse: [ - "Issue a mouse move event to make the receiver appear at the given position" - self startMouseDispatch: (MouseMoveEvent new - setType: #mouseMove - position: aMouseEvent eventPosition - buttons: aMouseEvent buttons - hand: self - stamp: aMouseEvent timeStamp) ]. - "Drop submorphs on button events" - self hasSubmorphs - ifTrue: [ - "Not if we are grabbing them" - mouseClickState ifNil: [ - "Want to drop on mouseUp, NOT mouseDown" - aMouseEvent isMouseUp ifTrue: [ - self dropMorphs: aMouseEvent ] - ] - ] ifFalse: [ - self mouseFocus - ifNotNil: [ mouseFocus handleFocusEvent: aMouseEvent ] - ifNil: [ owner dispatchEvent: aMouseEvent ]]]]. - self mouseOverHandler processMouseOver: lastMouseEvent! ! - -MouseEvent removeSelector: #asMouseMove:! - -!methodRemoval: MouseEvent #asMouseMove: stamp: 'Install-4525-MorphicEventsCleanup-JuanVuletich-2021Jan15-17h35m-jmv.001.cs.st 1/16/2021 19:17:33'! -asMouseMove: deltaTime - "Convert the receiver into a mouse move. adjust timestamp by the provided delta" - - ^ MouseMoveEvent new - setType: #mouseMove - position: position - buttons: buttons - hand: source - stamp: timeStamp + deltaTime! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4525-MorphicEventsCleanup-JuanVuletich-2021Jan15-17h35m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4524] on 14 January 2021 at 9:26:43 pm'! -!MouseClickState methodsFor: 'actions' stamp: 'jmv 1/14/2021 21:23:34' prior: 16878916! - handleEvent: aMouseEvent from: aHand - "Process the given mouse event to detect a click, double-click, or drag. - Return true if the event should be processed by the sender, false if it shouldn't. - NOTE: This method heavily relies on getting *all* mouse button events." - - | timedOut distance | - timedOut _ (aMouseEvent timeStamp - lastClickDown timeStamp) > self class doubleClickTimeout. - timedOut ifTrue: [ aHand dontWaitForMoreClicks ]. - distance _ (aMouseEvent eventPosition - lastClickDown eventPosition) r. - "Real action dispatch might be done after the triggering event, for example, because of waiting for timeout. - So, count the button downs and ups(clicks), to be processed, maybe later, maybe in a mouseMove..." - aMouseEvent isMouseDown ifTrue: [ - lastClickDown _ aMouseEvent. - buttonDownCount _ buttonDownCount + 1 ]. - aMouseEvent isMouseUp ifTrue: [ - buttonUpCount _ buttonUpCount + 1 ]. - - "Simulate button 2 if timeout during first click (i.e. tap & hold). Useful for opening menus on pen computers." - (buttonDownCount = 1 and: [ buttonUpCount = 0]) ifTrue: [ - (timedOut and: [ sendMouseButton2Activity and: [ distance = 0]]) ifTrue: [ - aHand dontWaitForMoreClicks. - clickClient mouseButton2Activity. - ^ false ]. - "If we have already moved, then it won't be a double or triple click... why wait?" - (timedOut or: [distance > 0]) ifTrue: [ - aHand dontWaitForMoreClicks. - dragSelector - ifNotNil: [ self didDrag ] - ifNil: [ self didClick ]. - ^ false ]]. - - "If we're over triple click, or timed out, or mouse moved, don't allow more clicks." - (buttonDownCount = 4 or: [ timedOut or: [ distance > 0 ]]) ifTrue: [ - aHand dontWaitForMoreClicks. - ^ false ]. - - "Simple click." - (buttonDownCount = 1 and: [ buttonUpCount = 1 ]) ifTrue: [ - self didClick ]. - - "Click & hold" - (buttonDownCount = 2 and: [ buttonUpCount = 1]) ifTrue: [ - self didClickAndHalf ]. - - "Double click." - (buttonDownCount = 2 and: [ buttonUpCount = 2]) ifTrue: [ - self didDoubleClick ]. - - "Double click & hold." - (buttonDownCount = 3 and: [ buttonUpCount = 2]) ifTrue: [ - self didDoubleClickAndHalf ]. - - "Triple click" - (buttonDownCount = 3 and: [ buttonUpCount = 3]) ifTrue: [ - self didTripleClick ]. - - "This means: if a mouseDown, then don't further process this event (so we can turn it into a double or triple click on next buttonUp)" - ^ aMouseEvent isMouseDown! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4526-MorphicEventsCleanup-JuanVuletich-2021Jan14-21h23m-jmv.001.cs.st----! - -----SNAPSHOT----(16 January 2021 19:17:38) Cuis5.0-4526-v3.image priorSource: 7461813! - -----STARTUP---- (9 April 2021 16:04:39) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4526-v3.image! - - -'From Cuis 5.0 [latest update: #4526] on 20 January 2021 at 5:24:31 pm'! -!BacktickNode methodsFor: 'visiting' stamp: 'NPM 1/20/2021 17:23:50' prior: 50525723 overrides: 16884650! - accept: aVisitor - - ^ aVisitor visitBacktickNode: self. - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4527-CuisCore-NicolasPapagnaMaldonado-2021Jan20-17h23m-NPM.001.cs.st----! - -'From Cuis 5.0 [latest update: #4526] on 29 January 2021 at 5:03:31 pm'! -!Preferences class methodsFor: 'class finder' stamp: 'NPM 1/29/2021 17:00:27'! - classFinder - - ^ self - valueOfFlag: #classFinder - ifAbsent: [ self restoreDefaultClassFinder ]! ! -!Preferences class methodsFor: 'class finder' stamp: 'NPM 1/29/2021 16:55:13'! - classFinder: aBlock - - self - setPreference: #classFinder - toValue: aBlock! ! -!Preferences class methodsFor: 'class finder' stamp: 'NPM 1/29/2021 17:02:24'! - restoreDefaultClassFinder - - | defaultClassFinder | - defaultClassFinder _ [ BrowserWindow findClass ]. - - self classFinder: defaultClassFinder. - - ^ defaultClassFinder! ! -!KeyboardEvent methodsFor: 'dispatching' stamp: 'NPM 1/29/2021 16:56:56' prior: 50563208 overrides: 50563190! - sendEventTo: aMorph - "Dispatch the receiver into anObject" - type == #keystroke ifTrue: [ - self isFindClassShortcut - ifTrue: [ ^ Preferences classFinder value ]. - self isCloseWindowShortcut - ifTrue: [ ^ self closeCurrentWindowOf: aMorph ]. - ^ aMorph processKeystroke: self ]. - type == #keyDown ifTrue: [ - ^ aMorph processKeyDown: self ]. - type == #keyUp ifTrue: [ - ^ aMorph processKeyUp: self ]. - ^ super sendEventTo: aMorph.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4528-CuisCore-NicolasPapagnaMaldonado-2021Jan29-16h51m-NPM.001.cs.st----! - -'From Cuis 5.0 [latest update: #4528] on 8 February 2021 at 5:52:57 pm'! -!ScrollBar methodsFor: 'initialization' stamp: 'jmv 2/8/2021 17:17:37'! - updateDownButton: aPluggableButtonMorph - "update the argument as a downButton. put a new image inside" - - aPluggableButtonMorph - icon: (BitBltCanvas arrowOfDirection: #down size: ScrollBar scrollbarThickness); - iconName: #drawDownIcon; - action: #scrollDown; - roundButtonStyle: false; - redrawNeeded! ! -!ScrollBar methodsFor: 'initialization' stamp: 'jmv 2/8/2021 17:36:03'! - updateLeftButton: aPluggableButtonMorph - "update the argument as a leftButton. put a new image inside" - - aPluggableButtonMorph - icon: (BitBltCanvas arrowOfDirection: #left size: ScrollBar scrollbarThickness); - iconName: #drawLeftIcon; - action: #scrollUp; - roundButtonStyle: false; - redrawNeeded! ! -!ScrollBar methodsFor: 'initialization' stamp: 'jmv 2/8/2021 17:19:03'! - updateRightButton: aPluggableButtonMorph - "update the argument as a rightButton. put a new image inside" - - aPluggableButtonMorph - icon: (BitBltCanvas arrowOfDirection: #right size: ScrollBar scrollbarThickness); - iconName: #drawRightIcon; - action: #scrollDown; - roundButtonStyle: false; - redrawNeeded! ! -!ScrollBar methodsFor: 'initialization' stamp: 'jmv 2/8/2021 17:19:41'! - updateUpButton: aPluggableButtonMorph - "update the argument as a rightButton. put a new image inside" - - aPluggableButtonMorph - icon: (BitBltCanvas arrowOfDirection: #up size: ScrollBar scrollbarThickness); - iconName: #drawUpIcon; - action: #scrollUp; - roundButtonStyle: false; - redrawNeeded! ! -!ScrollBar methodsFor: 'geometry' stamp: 'jmv 2/8/2021 17:51:52' prior: 50556488 overrides: 50556435! - extentChanged: oldExtent - "Our extent changed. Must layout submorphs again." - | isH wasH | - - super extentChanged: oldExtent. - "Doesn't move!!" - "upButton morphPosition: borderWidth@borderWidth." - downButton morphPosition: extent - borderWidth - downButton morphExtent. - wasH _ oldExtent notNil and: [oldExtent x > oldExtent y]. - isH _ self isHorizontal. - isH = wasH ifFalse: [ - isH - ifTrue: [ - self updateLeftButton: upButton. - self updateRightButton: downButton ] - ifFalse: [ - self updateUpButton: upButton. - self updateDownButton: downButton ]].! ! -!ScrollBar methodsFor: 'initialization' stamp: 'jmv 2/8/2021 17:21:07' prior: 16904645! - initializeDownButton - "initialize the receiver's downButton" - - | e | - e _ self buttonExtent. - downButton _ self buttonClass new. - downButton model: self. - downButton morphExtent: e@e. - Theme current minimalWindows ifTrue: [^ self]. - self addMorph: downButton position: extent - borderWidth - e. - downButton - actWhen: #buttonStillDown. "to enable multiple action if held down". - self isHorizontal - ifTrue: [ self updateRightButton: downButton ] - ifFalse: [ self updateDownButton: downButton ]! ! -!ScrollBar methodsFor: 'initialization' stamp: 'jmv 2/8/2021 17:35:47' prior: 16904677! - initializeUpButton - "initialize the receiver's upButton" - - | e | - e _ self buttonExtent. - upButton _ self buttonClass new. - upButton model: self. - upButton morphExtent: e@e. - Theme current minimalWindows ifTrue: [^ self]. - self addMorph: upButton position: borderWidth@borderWidth. - upButton - actWhen: #buttonStillDown. "to enable multiple action if held down" - self isHorizontal - ifTrue: [ self updateLeftButton: upButton ] - ifFalse: [ self updateUpButton: upButton ]. -! ! - -PluggableButtonMorph removeSelector: #updateDownButtonImage! - -!methodRemoval: PluggableButtonMorph #updateDownButtonImage stamp: 'Install-4529-ScrollbarFix-JuanVuletich-2021Feb08-17h50m-jmv.001.cs.st 4/9/2021 16:04:43'! -updateDownButtonImage - "update the receiver's as a downButton. put a new image inside" - - icon _ BitBltCanvas arrowOfDirection: #down size: ScrollBar scrollbarThickness. - self iconName: #drawDownIcon. - actionSelector _ #scrollDown. - self - roundButtonStyle: false; - redrawNeeded! - -PluggableButtonMorph removeSelector: #updateUpButtonImage! - -!methodRemoval: PluggableButtonMorph #updateUpButtonImage stamp: 'Install-4529-ScrollbarFix-JuanVuletich-2021Feb08-17h50m-jmv.001.cs.st 4/9/2021 16:04:43'! -updateUpButtonImage - "update the receiver's as a upButton. put a new image inside" - - icon _ BitBltCanvas arrowOfDirection: #up size: ScrollBar scrollbarThickness. - self iconName: #drawUpIcon. - actionSelector _ #scrollUp. - self - roundButtonStyle: false; - redrawNeeded! - -PluggableButtonMorph removeSelector: #updateLeftButtonImage! - -!methodRemoval: PluggableButtonMorph #updateLeftButtonImage stamp: 'Install-4529-ScrollbarFix-JuanVuletich-2021Feb08-17h50m-jmv.001.cs.st 4/9/2021 16:04:43'! -updateLeftButtonImage - "update the receiver's as a downButton. put a new image inside" - - icon _ BitBltCanvas arrowOfDirection: #left size: ScrollBar scrollbarThickness. - self iconName: #drawLeftIcon. - actionSelector _ #scrollUp. - self - roundButtonStyle: false; - redrawNeeded! - -PluggableButtonMorph removeSelector: #updateRightButtonImage! - -!methodRemoval: PluggableButtonMorph #updateRightButtonImage stamp: 'Install-4529-ScrollbarFix-JuanVuletich-2021Feb08-17h50m-jmv.001.cs.st 4/9/2021 16:04:43'! -updateRightButtonImage - "update the receiver's as a downButton. put a new image inside" - - icon _ BitBltCanvas arrowOfDirection: #right size: ScrollBar scrollbarThickness. - self iconName: #drawRightIcon. - actionSelector _ #scrollDown. - self - roundButtonStyle: false; - redrawNeeded! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4529-ScrollbarFix-JuanVuletich-2021Feb08-17h50m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4529] on 9 February 2021 at 11:59:05 am'! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 2/8/2021 19:08:52'! - exponent - "Usually run as a primitive in specific subclass. - Consider the receiver to be represented as a power of two - multiplied by a mantissa between one and two or between -1 and -2 (#significand). - Answer with the SmallInteger to whose power two is raised. - Note: invalid for infinities, NaN and zero. - See also #signPart, #significandAsInteger and #exponentPart - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. f significand . f exponent. f significand * (2 raisedToInteger: f exponent) = f } print ]. - " - - self = 0.0 ifTrue: [^MinValLogBase2-1]. - self isFinite ifFalse: [^Float emax+1]. - self isDenormalized ifTrue: [^MinValLogBase2 + self mantissaPart asFloat exponent]. - ^self exponentPart! ! -!BoxedFloat64 methodsFor: 'truncation and round off' stamp: 'jmv 2/8/2021 18:54:45' prior: 50467738 overrides: 50565633! - exponent - "Primitive. Consider the receiver to be represented as a power of two - multiplied by a mantissa between one and two or between -1 and -2 (#significand). - Answer with the SmallInteger to whose power two is raised. - Optional. See Object documentation whatIsAPrimitive. - Note: invalid for infinities, NaN and zero. - See also #signPart, #significandAsInteger and #exponentPart - " - " - {Float pi. Float fminNormalized. Float fminDenormalized. 2.0. -2.0} do: [ :f | - {f. f significand . f exponent. f significand * (2 raisedToInteger: f exponent) = f } print ]. - " - - - ^super exponent! ! -!SmallFloat64 methodsFor: 'truncation and round off' stamp: 'jmv 2/8/2021 18:54:52' prior: 50467769 overrides: 50565633! - exponent - "Primitive. Consider the receiver to be represented as a power of two - multiplied by a mantissa between one and two (#significand). - Answer with the SmallInteger to whose power two is raised. - Optional. See Object documentation whatIsAPrimitive. - Note: invalid for infinities, NaN and zero. - See comment at BoxedFloat64" - - - ^super exponent! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4530-Float-exponent-nonPrimitive-Fix-JuanVuletich-2021Feb09-11h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4530] on 9 February 2021 at 3:15:43 pm'! -!MenuItemMorph methodsFor: 'events' stamp: 'jmv 1/30/2021 15:59:33' prior: 50562653! -activateSubmenu: event - "Activate our submenu; e.g., pass control to it" - - subMenu ifNil: [ ^false ]. "not applicable" - subMenu isInWorld ifFalse: [ ^false ]. - (subMenu containsGlobalPoint: event eventPosition) ifFalse: [^false]. - subMenu activate: event. - ^true! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4531-MenuFix-JuanVuletich-2021Feb09-15h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4531] on 2 March 2021 at 2:59:41 pm'! -!SystemDictionary class methodsFor: 'copyright' stamp: 'jmv 3/2/2021 14:58:54' prior: 50381630! - copyright - "The Cuis Smalltalk copyright. - Parts are copyright of many contributors to Squeak and Cuis projects." - - ^ -'Portions of Cuis are: -Copyright (c) Xerox Corp. 1981, 1982. -Copyright (c) Apple Computer, Inc. 1985-1996. -Copyright (c) Contributors to Squeak project. 1997-2021. -Copyright (c) Contributors to Cuis Smalltalk project. 2009-2021.'! ! -!Utilities class methodsFor: 'default desktop' stamp: 'jmv 3/2/2021 14:57:29' prior: 50491155! - defaultTextEditorContents - ^ (' -', -('Cuis Smalltalk - -' centered blue pointSize: FontFamily defaultPointSize * 3), -(' -"Yay, Juan. You GO, guy!! ...a great example of malleable software (and a clever mind) at work." -' rightFlush pointSize: FontFamily defaultPointSize * 0.6), -('Dan Ingalls -' italic rightFlush pointSize: FontFamily defaultPointSize * 0.6), -(' -"I like it... It''s nice and clean and simple and pretty. Nice stuff!!" -' rightFlush pointSize: FontFamily defaultPointSize * 0.6), -('Alan Kay -' italic rightFlush pointSize: FontFamily defaultPointSize * 0.6), -(' -"I think you have a very elegant design aesthetic." -' rightFlush pointSize: FontFamily defaultPointSize * 0.6), -('John Maloney -'italic rightFlush pointSize: FontFamily defaultPointSize * 0.6), -' - -', -'Cuis is a modern, Open Source, multiplatform, Smalltalk-80 system. - - -', -'Cuis is: - -' bold, -' - Small - - Clean - - Appropriable -' blue, -' - -Additionally, Cuis is: - -' bold, -' - Open Source - - Multiplatform -' blue, -' - -Like other Smalltalk systems, Cuis is also: - -' bold, -' - A complete development environment written in itself - - A pure, dynamic Object Oriented language -' blue, -' - -Cuis assumes very little on the underlying platform, and this lets it run out-of-the-box on Windows, MacOS, Linux, ChromeOS and WebBrowsers. Cuis shares the [OpenSmalltalk Virtual Machine] (http://www.opensmalltalk.org) with Squeak, Pharo and Newspeak. - -What sets Cuis apart from the other members of the Squeak family is the focus on Smalltalk-80 and an active attitude towards system complexity: - -Unbound complexity growth, together with development strategies focused only in the short term, are the worst long term enemies of all software systems. As systems grow older, they usually become more complex. New features are added as layers on top of whatever is below, sometimes without really understanding it, and almost always without modifying it. Complexity and size grow without control. Evolution slows down. Understanding the system becomes harder every day. Bugs are harder to fix. Codebases become huge for no clear reason. At some point, the system can''t evolve anymore and becomes "legacy code". - -Complexity puts a limit to the level of understanding of the system a person might reach, and therefore limits the things that can be done with it. Dan Ingalls says all this in ["Design Principles Behind Smalltalk"] (http://www.cs.virginia.edu/~evans/cs655/readings/smalltalk.html). Even if you have already done so, please go and read it again!! - -Cuis Smalltalk is our attempt at this challenge. Furthermore, we believe we are doing something else that no other Smalltalk, commercial or open source, does. We attempt to give the true Smalltalk-80 experience, and keep Smalltalk-80 not as legacy software historic significance, but as a live, evolving system. We feel we are the keepers of the Smalltalk-80 heritage, and enablers of the Dynabook experience. - -As Cuis evolves, we keep on these values. Every update, be it a bug fix or a feature enhancement, is reviewed carefully to avoid adding unneded complexity to the system. Every opportunity to remove unneded complexity is followed. As we go, features are enhanced, and any reported bugs fixed. We also adopt selected enhancements from Squeak and Pharo, and share our work with the wider Smalltalk community. - - -' justified, -'License -' bold, -' -Cuis is distributed subject to the MIT License, as in http://www.opensource.org/licenses/mit-license.php . Any contribution submitted for incorporation into or for distribution with Cuis shall be presumed subject to the same license. - -Portions of Cuis are: -Copyright (c) Xerox Corp. 1981, 1982 -Copyright (c) Apple Computer, Inc. 1985-1996 -Copyright (c) Contributors to Squeak project. 1997-2021 -Copyright (c) Contributors to Cuis Smalltalk project. 2009-2021')! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4532-CopyrightUpdate-JuanVuletich-2021Mar02-14h34m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4532] on 13 March 2021 at 9:52:08 am'! -!Preferences class methodsFor: 'standard queries' stamp: 'jmv 3/13/2021 09:50:37' prior: 0! - tapAndHoldEmulatesButton2 - ^ self - valueOfFlag: #tapAndHoldEmulatesButton2 - ifAbsent: [ false ].! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Preferences disable: #tapAndHoldEmulatesButton2! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4533-AvoidUnintendedTapAndHoldEvents-JuanVuletich-2021Mar13-09h50m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4533] on 15 March 2021 at 4:33:30 pm'! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 3/15/2021 16:33:03' prior: 50564939 overrides: 50565002! - drawCurrentAndSubmorphs - - self isCurrentMorphVisible ifTrue: [ - - currentMorph drawOn: self. - world notNil ifTrue: [ "Only if we are drawing the world" - currentMorph displayBounds: self boundingRectOfCurrentMorphAfterDraw ]. - - "Display submorphs back to front" - "coordinate system stack already set up for aMorph - ('ivars transformations' and 'currentTransformation')" - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | self fullDraw: m ]]. - - currentMorph postDrawOn: self. - world notNil ifTrue: [ "Only if we are drawing the world" - currentMorph displayBounds: - (currentMorph displayBounds quickMerge: self boundingRectOfCurrentMorphAfterDraw) ]. - - currentMorph isHighlighted ifTrue: [ - self drawCurrentMorphHighlight ]. - world notNil ifTrue: [ - currentMorph halo ifNotNil: [ - self drawCoordinateSystem: currentMorph morphLocalBounds ]]. - - world notNil ifTrue: [ "Only if we are drawing the world" - currentMorph displayBounds: - (currentMorph displayBounds quickMerge: self boundingRectOfCurrentMorphAfterDraw) ]. - ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4534-BitBltCanvasTweaks-JuanVuletich-2021Mar15-16h33m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4534] on 16 March 2021 at 9:05:21 am'! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/16/2021 08:47:32' prior: 16877608! - drawString: s at: pt font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - ^self drawString: s from: 1 to: s size at: pt font: (self fontToUse: fontOrNil) color: aColor! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/16/2021 08:47:48' prior: 16877617! - drawString: s at: pt font: fontOrNil color: aColor embossed: aBoolean - "Answer last affected pixel position - Answer nil if nothing was done" - - ^aBoolean - ifTrue: [ self drawStringEmbossed: s from: 1 to: s size at: pt font: (self fontToUse: fontOrNil) color: aColor ] - ifFalse: [ self drawString: s from: 1 to: s size at: pt font: (self fontToUse: fontOrNil) color: aColor ]! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/16/2021 08:40:05' prior: 50560863! - drawString: s atBaseline: pt font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | font | - font _ self fontToUse: fontOrNil. - ^self drawString: s from: 1 to: s size atBaseline: pt font: font color: aColor! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/16/2021 08:49:16' prior: 50560873! - drawString: s atCenterX: pt font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | font | - font _ self fontToUse: fontOrNil. - ^self - drawString: s - from: 1 to: s size - at: pt - ((font widthOfString: s) / 2 @ 0) - font: font color: aColor! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/16/2021 08:42:31' prior: 50560887! - drawString: s atWaist: pt font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | font | - font _ self fontToUse: fontOrNil. - ^self drawString: s from: 1 to: s size atWaist: pt font: font color: aColor! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/16/2021 08:43:49' prior: 50560897! - drawString: s atWaistRight: pt font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | font | - font _ self fontToUse: fontOrNil. - ^self - drawString: s - from: 1 to: s size - atWaist: pt - ((font widthOfString: s) @ 0) - font: font color: aColor! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/16/2021 08:57:07' prior: 50463524! - drawString: aString from: firstIndex to: lastIndex at: aPoint font: font color: aColor - "Eventually, convert all senders to the 'Baseline' protocol" - - ^self drawString: aString from: firstIndex to: lastIndex - atBaseline: aPoint + (0@(font ascent + font lineGap-1)) - font: font color: aColor! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/16/2021 08:34:31' prior: 50560911! - drawString: aString from: firstIndex to: lastIndex atBaseline: aPoint font: font color: aColor - self subclassResponsibility ! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/16/2021 08:59:54' prior: 50560918! - drawString: aString from: firstIndex to: lastIndex atWaist: aPoint font: font color: aColor - - ^self drawString: aString from: firstIndex to: lastIndex - atBaseline: aPoint + (0@(font ascent / 3)) - font: font color: aColor! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/16/2021 08:50:14' prior: 50388595! - drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint font: font color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - aColor = `Color black` ifFalse: [ | topColor | - topColor _ aColor alphaMixed: 0.25 with: `Color black`. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint - font: font - color: topColor ]. - aColor = `Color white` ifFalse: [ | bottomColor | - bottomColor _ aColor alphaMixed: 0.22 with: `Color white`. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + `0@2` - font: font - color: bottomColor ]. - ^self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + `0@1` - font: font - color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/16/2021 08:56:16' prior: 50560932 overrides: 50566026! - drawString: aString from: firstIndex to: lastIndex atBaseline: aPoint font: font color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | p1 | - engine ifNil: [ ^nil ]. - - "Don't waste any time if NOP" - lastIndex = 0 ifTrue: [ - ^nil ]. - - p1 _ currentTransformation transform: aPoint rounded. - p1 _ p1 + (0@(0 - (font ascent + font lineGap-1))). - p1 _ p1 rounded. - engine colorMap: nil. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/16/2021 08:50:44' prior: 50561002 overrides: 50566043! - drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint font: font color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - | p1 | - - engine ifNil: [ ^nil ]. - - p1 _ (currentTransformation transform: aPoint rounded) rounded. - engine colorMap: nil. - - aColor = `Color black` ifFalse: [ | topColor | - topColor _ aColor alphaMixed: 0.25 with: `Color black`. - font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: topColor ]. - aColor = `Color white` ifFalse: [ | bottomColor | - bottomColor _ aColor alphaMixed: 0.22 with: `Color white`. - font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + `0@2` - color: bottomColor ]. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + `0@1` - color: aColor.! ! - -BitBltCanvas removeSelector: #drawString:from:to:atWaist:font:color:! - -!methodRemoval: BitBltCanvas #drawString:from:to:atWaist:font:color: stamp: 'Install-4535-Canvas-String-Protocol-Cleanup-JuanVuletich-2021Mar16-08h29m-jmv.001.cs.st 4/9/2021 16:04:43'! -drawString: aString from: firstIndex to: lastIndex atWaist: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | p1 font | - engine ifNil: [ ^nil ]. - - "Don't waste any time if NOP" - lastIndex = 0 ifTrue: [ - ^nil ]. - - p1 _ (currentTransformation transform: aPoint rounded) rounded. - engine colorMap: nil. - font _ self fontToUse: fontOrNil. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + (0@(0 - (font ascent * 2 // 3 + font lineGap-1))) - color: aColor! - -BitBltCanvas removeSelector: #drawString:from:to:at:font:color:! - -!methodRemoval: BitBltCanvas #drawString:from:to:at:font:color: stamp: 'Install-4535-Canvas-String-Protocol-Cleanup-JuanVuletich-2021Mar16-08h29m-jmv.001.cs.st 4/9/2021 16:04:43'! -drawString: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | p1 | - engine ifNil: [ ^nil ]. - - "Don't waste any time if NOP" - lastIndex = 0 ifTrue: [ - ^nil ]. - - p1 _ (currentTransformation transform: aPoint rounded) rounded. - engine colorMap: nil. - ^(self fontToUse: fontOrNil) - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: aColor! - -BitBltCanvas removeSelector: #drawString:from:to:atTop:font:color:! - -MorphicCanvas removeSelector: #drawString:from:to:atTop:font:color:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4535-Canvas-String-Protocol-Cleanup-JuanVuletich-2021Mar16-08h29m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4532] on 5 March 2021 at 3:39:13 pm'! -!MorphicTranslation methodsFor: 'polymorphism with AffineTransformation' stamp: 'jmv 3/5/2021 15:38:04'! - a11 - ^1.0! ! -!MorphicTranslation methodsFor: 'polymorphism with AffineTransformation' stamp: 'jmv 3/5/2021 15:38:11'! - a12 - ^0.0! ! -!MorphicTranslation methodsFor: 'polymorphism with AffineTransformation' stamp: 'jmv 3/5/2021 15:38:27'! - a13 - ^deltaX! ! -!MorphicTranslation methodsFor: 'polymorphism with AffineTransformation' stamp: 'jmv 3/5/2021 15:38:41'! - a21 - ^0.0! ! -!MorphicTranslation methodsFor: 'polymorphism with AffineTransformation' stamp: 'jmv 3/5/2021 15:38:49'! - a22 - ^1.0! ! -!MorphicTranslation methodsFor: 'polymorphism with AffineTransformation' stamp: 'jmv 3/5/2021 15:39:00'! - a23 - ^deltaY! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4536-MorphicTranslationAffineElements-CuisCore-JuanVuletich-2021Mar05-15h08m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4536] on 17 March 2021 at 9:53:17 am'! -!PluggableListMorphOfMany methodsFor: 'events' stamp: 'jmv 3/17/2021 09:53:05' prior: 16889271 overrides: 50391332! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - - dragOnOrOff _ false. "So improperly started drags will have not effect" - dragStartRow _ nil! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4537-PluggableListMorphOfMany-fix-JuanVuletich-2021Mar17-09h53m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4537] on 21 March 2021 at 5:16:51 pm'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 3/21/2021 13:05:45'! - restorePatch: savedPatch bounds: savedBounds - "Argument must previously be obtained by calling #savePatch:bounds: - Senders should not assume anything about the returned object, except that it will not be nil." - -self flag: #jmvHacks. -"Podriamos usar un BitBlt guardado. Este metodo termina haciendo demasiadas cosas... (innecesarias)" - self - image: savedPatch - at: savedBounds origin - sourceRect: (0@0 extent: savedBounds extent)! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 3/21/2021 12:44:53' prior: 50536725! - imageForm: extent depth: depth - | canvas | - canvas _ MorphicCanvas depth: depth over: (self morphPosition extent: (self morphExtent min: extent)) encompassingIntegerRectangle. - canvas fullDraw: self. - ^ canvas form divideByAlpha! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 3/21/2021 07:20:22' prior: 50560014! - displayFullBounds - "Answer a rectangle that completely bounds receiver and submorphs when last drawn - (if the world was to be fully drawn, i.e. only to be used on a Canvas on the full world)." - - | answer | - answer _ self displayBounds. - answer ifNil: [ ^nil ]. - (self submorphsMightProtrude and: [self clipsSubmorphsReally not]) ifTrue: [ - self submorphsReverseDo: [ :m | - answer _ answer quickMerge: m displayFullBounds ]]. - ^answer encompassingIntegerRectangle! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 3/21/2021 17:07:13' prior: 50471041! - needsToBeDrawn - "Return true if this hand must be drawn explicitely instead of being drawn via the hardware cursor. This is the case if it (a) it is a remote hand, (b) it is showing a temporary cursor, or (c) it is not empty and there are any visible submorphs. If using the software cursor, ensure that the hardware cursor is hidden." - "Details: Return true if this hand has a saved patch to ensure that is is processed by the world. This saved patch will be deleted after one final display pass when it becomes possible to start using the hardware cursor again. This trick gives us one last display cycle to allow us to remove the software cursor from the display." - "Note. We draw the hand as a regular morph (using #drawOn:), disabling the hardware cursor, when we carry submorphs. The reason is to lock the mouse pointer and the carried morph together. Otherwhise the carried morph would lag behind the mouse pointer. - This method answers whether the regular #drawOn: drawing mechanism is used for us. - - Check senders. Hand drawing is handled explicitly by the world, because the Hand is not a submorph of the world!!" - | blankCursor | - (prevFullBounds notNil or: [ - submorphs anySatisfy: [ :ea | - ea visible ]]) ifTrue: [ - "using the software cursor; hide the hardware one" - blankCursor _ Cursor cursorAt: #blankCursor. - Cursor currentCursor == blankCursor ifFalse: [ blankCursor activateCursor ]. - ^ true ]. - ^ false.! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 3/21/2021 17:06:17' prior: 50557153! - restoreSavedPatchOn: aCanvas - "Clear the changed flag and restore the part of the given canvas under this hand from the previously saved patch. If necessary, handle the transition to using the hardware cursor." - hasChanged _ false. - prevFullBounds ifNotNil: [ - aCanvas restorePatch: savedPatch bounds: prevFullBounds. - submorphs notEmpty ifTrue: [ ^ self ]. - "Make the transition to using hardware cursor. Clear savedPatch and - report one final damage rectangle to erase the image of the software cursor." - " owner invalidateDisplayRect: (savedPatch offset extent: savedPatch extent) from: nil." - self invalidateDisplayRect: (self morphPosition extent: extent) for: nil. - Cursor currentCursor == Cursor defaultCursor ifFalse: [ Cursor defaultCursor activateCursor ]. - "show hardware cursor" - prevFullBounds _ nil ].! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 3/21/2021 07:20:15' prior: 50538007 overrides: 50566260! - displayFullBounds - "Current full bounds of hand and carried submorphs. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around)." - | fullBounds | - fullBounds _ self displayBounds. - self submorphsDo: [ :m | - fullBounds _ fullBounds quickMerge: m displayFullBounds]. - lastPosition - ifNotNil: [ :lastPos | "When already carrying morphs around. Include also the rectangle updated to current hand position." - fullBounds _ fullBounds quickMerge: (fullBounds translatedBy: self morphPosition-lastPos) ]. - ^fullBounds encompassingIntegerRectangle! ! -!WorldMorph methodsFor: 'interaction loop' stamp: 'jmv 3/21/2021 07:27:48' prior: 50565053! - mainLoop - - - self clearWaitDelay. - [ - self doOneCycle. - true ] - whileTrue: []! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 3/21/2021 07:28:10' prior: 50555336! - displayWorldSafely - "Update this world's display and keep track of errors during draw methods." - - [self displayWorld] ifError: [ :err :rcvr | - "Handle a drawing error" - canvas currentMorphDrawingFails. - "Install the old error handler, so we can re-raise the error" - rcvr error: err. - ]! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 3/21/2021 17:16:08' prior: 50540421! - savePatch: prevSavedPatch bounds: aRectangle - "Senders don't need to know any details of what is answered, but just store it for further calls, and calls to restorePatch:" - "Details: The previously used patch Form is recycled when possible to reduce the burden on storage management." - | savedPatch bb prevExtent extent | - savedPatch _ prevSavedPatch. - prevExtent _ 0@0. - ((savedPatch is: #Form) and: [ - prevExtent _ savedPatch extent. - prevExtent >= aRectangle extent]) - ifTrue: [ - savedPatch offset: 0@0 ] - ifFalse: [ - "allocate new patch form if needed" - extent _ aRectangle extent max: prevExtent. - extent _ (extent x // 64 + 2 * 64) @ (extent y + 64). "Make it slightly larger, and even width." - savedPatch _ Form extent: extent depth: form depth ]. - bb _ BitBlt toForm: savedPatch. - bb sourceForm: form; combinationRule: Form over; - sourceX: aRectangle left; sourceY: aRectangle top; - width: aRectangle width; height: aRectangle height; - copyBits. - ^savedPatch! ! - -MorphicCanvas removeSelector: #restorePatch:! - -!methodRemoval: MorphicCanvas #restorePatch: stamp: 'Install-4538-MorphicFrameworkTweaks-JuanVuletich-2021Mar21-16h57m-jmv.001.cs.st 4/9/2021 16:04:43'! -restorePatch: savedPatch - "Argument must previously be obtained by calling #savePatch:bounds: - Senders should not assume anything about the returned object, except that it will not be nil." - -self flag: #jmvHacks. -"Podriamos usar un BitBlt guardado. Este metodo termina haciendo demasiadas cosas... (innecesarias)" - self - image: savedPatch - at: savedPatch offset.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4538-MorphicFrameworkTweaks-JuanVuletich-2021Mar21-16h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4538] on 22 March 2021 at 4:36:29 pm'! -!SetInspector methodsFor: 'selecting' stamp: 'jmv 3/22/2021 16:35:54' prior: 16907452! - arrayIndexForSelection - ^ (self fieldList at: selectionIndex) asNumber! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4539-SetInspectorFix-JuanVuletich-2021Mar22-16h00m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4526] on 14 February 2021 at 10:27:09 am'! -!Inspector methodsFor: 'contents' stamp: 'jpb 2/14/2021 09:59:32' prior: 50369349 overrides: 16934336! - acceptedStringOrText - "We need our cache not to be modified by user changes" - ^(acceptedContentsCache ifNil: '') copy! ! -!Inspector methodsFor: 'selecting' stamp: 'jpb 2/14/2021 10:24:54' prior: 50515816! - selectionPrintString - "Returns the current selection as a string" - ^self safelyPrintWith: [ - | selectedValue | - selectedValue _ self selection. - (selectedValue is: #String) - ifTrue: [ selectedValue ] - ifFalse: [ selectedValue printTextLimitedTo: self printStringLimit]]! ! - -Inspector removeSelector: #stringSelectionIndices! - -!methodRemoval: Inspector #stringSelectionIndices stamp: 'Install-4540-InspectorFix-JosefPhilipBernhart-2021Feb14-09h30m-jpb.001.cs.st 4/9/2021 16:04:43'! -stringSelectionIndices - - ^#(0 2)! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4540-InspectorFix-JosefPhilipBernhart-2021Feb14-09h30m-jpb.001.cs.st----! - -'From Cuis 5.0 [latest update: #4540] on 22 March 2021 at 5:11:12 pm'! - -DictionaryInspector removeSelector: #stringSelectionIndices! - -!methodRemoval: DictionaryInspector #stringSelectionIndices stamp: 'Install-4541-Cleanup-JuanVuletich-2021Mar22-17h10m-jmv.001.cs.st 4/9/2021 16:04:43'! -stringSelectionIndices - - ^#(0)! - -CompiledMethodInspector removeSelector: #stringSelectionIndices! - -!methodRemoval: CompiledMethodInspector #stringSelectionIndices stamp: 'Install-4541-Cleanup-JuanVuletich-2021Mar22-17h10m-jmv.001.cs.st 4/9/2021 16:04:43'! -stringSelectionIndices - - ^#(0 2 3)! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4541-Cleanup-JuanVuletich-2021Mar22-17h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4541] on 22 March 2021 at 5:18:56 pm'! -!Preferences class methodsFor: 'personalization' stamp: 'jmv 3/22/2021 17:18:15'! -stylingWithEmphasisInWorkspaces - ^ self - valueOfFlag: #stylingWithEmphasisInWorkspaces - ifAbsent: [false]! ! -!Workspace methodsFor: 'user interface support' stamp: 'jmv 3/22/2021 17:17:29' prior: 50556777 overrides: 50556771! - allowStylingWithEmphasis - "Disabled by default for faster styling of large contents, as text metrics are not affected by styling." - - ^ Preferences stylingWithEmphasisInWorkspaces! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4542-StylingWithEmphasisInWorkspacesPreference-JuanVuletich-2021Mar22-17h16m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4542] on 23 March 2021 at 1:03:48 pm'! -!BitBltCanvasEngine methodsFor: 'text' stamp: 'jmv 3/23/2021 13:02:51' prior: 50453510! - basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font - "Answer position to place next glyph" - - destY _ aPoint y. - destX _ aPoint x. - - "the following are not really needed, but theBitBlt primitive will fail if not set" - sourceX ifNil: [sourceX _ 100]. - width ifNil: [width _ 100]. - - self primDisplayString: aString from: startIndex to: stopIndex - map: font characterToGlyphMap xTable: font xTable - kern: font baseKern. - ^ destX@(destY+font lineSpacing)! ! -!BitBltCanvasEngine methodsFor: 'text' stamp: 'jmv 3/23/2021 13:03:01' prior: 50453528! - displayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: aStrikeFont color: foregroundColor - "If required, do a second pass with new rule and colorMap. - Answer position to place next glyph - Answer nil if nothing was done - " - - | answer prevRule secondPassMap sourceDepth destDepth | - - "Slight optimization when there's nothing to do." - clipHeight = 0 ifTrue: [^nil]. - clipWidth = 0 ifTrue: [^nil]. - - self installStrikeFont: aStrikeFont foregroundColor: (foregroundColor alpha: 1). - - "If combinationRule is rgbMul, we might need the special two-pass technique for component alpha blending. - If not, do it simply" - combinationRule = 37 "rgbMul" ifFalse: [ - ^self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: aStrikeFont ]. - - "We need to do a second pass. The colormap set is for use in the second pass." - secondPassMap _ colorMap. - sourceDepth _ sourceForm depth. - destDepth _ destForm depth. - colorMap _ sourceDepth ~= destDepth - ifTrue: [ Color cachedColormapFrom: sourceDepth to: destDepth ]. - answer := self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: aStrikeFont. - colorMap := secondPassMap. - secondPassMap ifNotNil: [ - prevRule := combinationRule. - combinationRule := 20. "rgbAdd" - self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: aStrikeFont. - combinationRule := prevRule ]. - ^answer! ! -!AbstractFont methodsFor: 'BitBltCanvas support' stamp: 'jmv 3/23/2021 13:02:41' prior: 50495019! - onBitBltCanvasEngine: engine displayString: aString from: firstIndex to: lastIndex at: p color: color - "Answer position to place next glyph - Answer nil if nothing was done" - - self subclassResponsibility! ! -!StrikeFont methodsFor: 'BitBltCanvas support' stamp: 'jmv 3/23/2021 13:03:31' prior: 50495029 overrides: 50566617! - onBitBltCanvasEngine: engine displayString: aString from: firstIndex to: lastIndex at: p color: color - "Answer position to place next glyph. - Answer nil if nothing was done." - - ^ engine - displayString: aString - from: firstIndex - to: lastIndex - at: p - strikeFont: self - color: color! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/23/2021 13:03:09' prior: 50565940! - drawString: s at: pt font: fontOrNil color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - - ^self drawString: s from: 1 to: s size at: pt font: (self fontToUse: fontOrNil) color: aColor! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/23/2021 13:03:12' prior: 50565950! - drawString: s at: pt font: fontOrNil color: aColor embossed: aBoolean - "Answer position to place next glyph - Answer nil if nothing was done" - - ^aBoolean - ifTrue: [ self drawStringEmbossed: s from: 1 to: s size at: pt font: (self fontToUse: fontOrNil) color: aColor ] - ifFalse: [ self drawString: s from: 1 to: s size at: pt font: (self fontToUse: fontOrNil) color: aColor ]! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/23/2021 13:03:19' prior: 50565965! - drawString: s atBaseline: pt font: fontOrNil color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - - | font | - font _ self fontToUse: fontOrNil. - ^self drawString: s from: 1 to: s size atBaseline: pt font: font color: aColor! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/23/2021 13:03:21' prior: 50565976! - drawString: s atCenterX: pt font: fontOrNil color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - - | font | - font _ self fontToUse: fontOrNil. - ^self - drawString: s - from: 1 to: s size - at: pt - ((font widthOfString: s) / 2 @ 0) - font: font color: aColor! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/23/2021 13:03:23' prior: 50565989! - drawString: s atWaist: pt font: fontOrNil color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - - | font | - font _ self fontToUse: fontOrNil. - ^self drawString: s from: 1 to: s size atWaist: pt font: font color: aColor! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/23/2021 13:03:25' prior: 50566000! - drawString: s atWaistRight: pt font: fontOrNil color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - - | font | - font _ self fontToUse: fontOrNil. - ^self - drawString: s - from: 1 to: s size - atWaist: pt - ((font widthOfString: s) @ 0) - font: font color: aColor! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/23/2021 13:03:27' prior: 50566043! - drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint font: font color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - - aColor = `Color black` ifFalse: [ | topColor | - topColor _ aColor alphaMixed: 0.25 with: `Color black`. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint - font: font - color: topColor ]. - aColor = `Color white` ifFalse: [ | bottomColor | - bottomColor _ aColor alphaMixed: 0.22 with: `Color white`. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + `0@2` - font: font - color: bottomColor ]. - ^self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + `0@1` - font: font - color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/23/2021 13:02:43' prior: 50566070 overrides: 50566026! - drawString: aString from: firstIndex to: lastIndex atBaseline: aPoint font: font color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - - | p1 | - engine ifNil: [ ^nil ]. - - "Don't waste any time if NOP" - lastIndex = 0 ifTrue: [ - ^nil ]. - - p1 _ currentTransformation transform: aPoint rounded. - p1 _ p1 + (0@(0 - (font ascent + font lineGap-1))). - p1 _ p1 rounded. - engine colorMap: nil. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 3/23/2021 13:02:45' prior: 50566091 overrides: 50566713! - drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint font: font color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - | p1 | - - engine ifNil: [ ^nil ]. - - p1 _ (currentTransformation transform: aPoint rounded) rounded. - engine colorMap: nil. - - aColor = `Color black` ifFalse: [ | topColor | - topColor _ aColor alphaMixed: 0.25 with: `Color black`. - font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: topColor ]. - aColor = `Color white` ifFalse: [ | bottomColor | - bottomColor _ aColor alphaMixed: 0.22 with: `Color white`. - font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + `0@2` - color: bottomColor ]. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + `0@1` - color: aColor.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4543-CommentFixes-JuanVuletich-2021Mar23-13h02m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4543] on 25 March 2021 at 4:34:25 pm'! -!String class methodsFor: 'instance creation' stamp: 'jmv 3/25/2021 16:33:56' prior: 50504067! - utf32FromUtf8: aByteArray - "Convert the given string from UTF-8 to UTF-32" - - ^WordArray streamContents: [ :strm | | bytes codePoint | - bytes _ aByteArray readStream. - [ bytes atEnd ] whileFalse: [ - codePoint _ (Character nextUnicodeCodePointFromUtf8: bytes). - codePoint ifNotNil: [ - strm nextPut: codePoint ]]]! ! -!String class methodsFor: 'instance creation' stamp: 'jmv 3/25/2021 16:33:31' prior: 50504080! - utf8FromUtf32: aWordArray - "Convert the given string from UTF-8 to UTF-32" - - ^ByteArray streamContents: [ :strm | - aWordArray do: [ :codePoint | - Character - evaluate: [ :byte | strm nextPut: byte ] - withUtf8BytesOfUnicodeCodePoint: codePoint ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4544-WordArrayForUtf32-JuanVuletich-2021Mar25-15h55m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4542] on 25 March 2021 at 7:24:40 pm'! -!BitBltCanvas methodsFor: 'drawing' stamp: 'jmv 3/25/2021 19:23:57' prior: 50561079! - drawCoordinateSystem: aRectangle - | c stepX stepY x0 x1 y0 y1 | - stepX _ 100. - stepY _ 50. - - self frameRectangle: aRectangle borderWidth: 4 color: `Color lightGray alpha: 0.4`. - - x0 _ aRectangle left. - x1 _ aRectangle right-1. - y0 _ aRectangle top. - y1 _ aRectangle bottom-1. - - c _ `Color lightGray alpha: 0.6`. - self line: x0@0 to: x1@0 width: 2 color: c. - self line: 0@y0 to: 0@y1 width: 2 color: c. - - (x0 truncateTo: stepX) to: (x1 - stepX truncateTo: stepX) by: stepX do: [ :x | - self line: x @ -5 to: x @ 5 width: 2 color: c. - self drawString: x printString atCenterX: x @ 5 font: nil color: c ]. - self drawString: 'x' atCenterX: x1 - 15 @ 0 font: nil color: c. - - (y0 truncateTo: stepY) to: (y1 - stepY truncateTo: stepY) by: stepY do: [ :y | - self line: -5 @ y to: 5 @ y width: 2 color: c. - self drawString: y printString, ' ' atWaist: 5 @ y font: nil color: c ]. - self drawString: 'y' atWaist: 0 @ (y1 - 20) font: nil color: c.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4545-LessInvasiveCoordinateAxes-JuanVuletich-2021Mar25-19h23m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4545] on 26 March 2021 at 10:12:37 am'! - -StrikeFont removeSelector: #useRightArrow! - -!methodRemoval: StrikeFont #useRightArrow stamp: 'Install-4546-RemoveSupportForRightArrowAssignment-JuanVuletich-2021Mar26-09h35m-jmv.001.cs.st 4/9/2021 16:04:43'! -useRightArrow - "Use right arrow glyph instead of underscore, and up arrow glyph instead of caret" - self characterToGlyphMap. - characterToGlyphMap at: 96 put: 29. - characterToGlyphMap at: 95 put: 30! - -Preferences class removeSelector: #useAssignmentGlyphRightArrow! - -!methodRemoval: Preferences class #useAssignmentGlyphRightArrow stamp: 'Install-4546-RemoveSupportForRightArrowAssignment-JuanVuletich-2021Mar26-09h35m-jmv.001.cs.st 4/9/2021 16:04:43'! -useAssignmentGlyphRightArrow - " - Preferences useAssignmentGlyphRightArrow - " - Preferences setPreference: #assignmentGlyphSelector toValue: #useRightArrow. - AbstractFont withAllSubclassesDo: [ :fontClass | fontClass assignmentGlyphSelectorPreferenceChanged ].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4546-RemoveSupportForRightArrowAssignment-JuanVuletich-2021Mar26-09h35m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4546] on 26 March 2021 at 3:52:33 pm'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 3/26/2021 15:52:10' prior: 16877475! - drawCurrentAsOutline - - self isCurrentMorphVisible ifTrue: [ - self - reverseRectangleBorder: currentMorph morphLocalBounds - borderWidth: 2. - world notNil ifTrue: [ "Only if we are drawing the world" - currentMorph displayBounds: self boundingRectOfCurrentMorphAfterDraw ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4547-CheapWindowReframe-fix-JuanVuletich-2021Mar26-15h51m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4547] on 26 March 2021 at 4:09:31 pm'! -!Morph methodsFor: 'halos and balloon help' stamp: 'ar 11/7/1999 18:57' prior: 16875632! - addHalo - "Invoke a halo programatically (e.g., not from a meta gesture)" - ^self addHalo: nil! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 3/26/2021 16:09:26' prior: 50561050! - addHalo: evt - "Defer execution until next cycle, so if you evaluate - BrowserWindow openBrowser addHalo - the window is in the world and with proper bounds, before adding the halo. - " - | halo | - self whenUIinSafeState: [ - self displayBoundsForHalo ifNotNil: [ :r | - halo _ HaloMorph new. - halo popUpFor: self event: evt. - halo morphBounds: r ]. - self redrawNeeded]. - ^halo! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4548-AddHaloFix-JuanVuletich-2021Mar26-16h06m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4547] on 26 March 2021 at 4:19:22 pm'! -!Preferences class methodsFor: 'standard queries' stamp: 'jmv 3/26/2021 16:16:18'! - halosShowCoordinateSystem - ^ self - valueOfFlag: #halosShowCoordinateSystem - ifAbsent: [ true ]! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 3/26/2021 16:16:00' prior: 50565895 overrides: 50565002! - drawCurrentAndSubmorphs - - self isCurrentMorphVisible ifTrue: [ - - currentMorph drawOn: self. - world notNil ifTrue: [ "Only if we are drawing the world" - currentMorph displayBounds: self boundingRectOfCurrentMorphAfterDraw ]. - - "Display submorphs back to front" - "coordinate system stack already set up for aMorph - ('ivars transformations' and 'currentTransformation')" - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | self fullDraw: m ]]. - - currentMorph postDrawOn: self. - world notNil ifTrue: [ "Only if we are drawing the world" - currentMorph displayBounds: - (currentMorph displayBounds quickMerge: self boundingRectOfCurrentMorphAfterDraw) ]. - - currentMorph isHighlighted ifTrue: [ - self drawCurrentMorphHighlight ]. - world notNil ifTrue: [ - currentMorph halo ifNotNil: [ - Preferences halosShowCoordinateSystem ifTrue: [ - self drawCoordinateSystem: currentMorph morphLocalBounds ]]]. - - world notNil ifTrue: [ "Only if we are drawing the world" - currentMorph displayBounds: - (currentMorph displayBounds quickMerge: self boundingRectOfCurrentMorphAfterDraw) ]. - ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4549-halosShowCoordinateSystem-preference-JuanVuletich-2021Mar26-16h09m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4549] on 29 March 2021 at 3:26:32 am'! -!WorldMorph methodsFor: 'interaction loop' stamp: 'jmv 3/29/2021 03:26:19' prior: 50566378! - mainLoop - - - self clearWaitDelay. - canvas isNil ifTrue: [ - self setCanvas: Display getCanvas. - damageRecorder _ DamageRecorder new ]. - self redrawNeeded. - [ - self doOneCycle. - true ] - whileTrue: []! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4550-NewReleaseStartupFix-JuanVuletich-2021Mar29-03h26m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4550] on 29 March 2021 at 10:28:21 am'! -!Compiler class methodsFor: 'evaluating' stamp: 'HAW 3/29/2021 10:26:03' prior: 16822115! - evaluate: textOrString - "See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs, - a Syntax Error view is created rather than notifying any requestor. - Compilation is carried out with respect to nil, i.e., no object, and the - invocation is not logged." - - "See SHST80RangeType>>#receiverAsNumber - Hernan" - ^[ self evaluate: textOrString for: nil logged: false ] - on: SyntaxErrorNotification - do: [ :anError | anError return: nil ]! ! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'HAW 3/29/2021 10:16:33' prior: 50545481! - receiverAsNumber - - "if the user typed 1xe for example, asNumber will throw an exception because it is not a valid number - even though the SHParser recognized it as such. I return nil because it is not really a number. - Thank you Luciano for reporting the bug - Hernan" - ^[ (self sourceCodeIn: receiverRange) asNumber ] - on: Error - do: [ :anError | anError return: nil ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4551-InvalidNumberOnSyntaxHL-HernanWilkinson-2021Mar29-10h16m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4551] on 30 March 2021 at 6:33:01 am'! - -Object subclass: #Random - instanceVariableNames: '' - classVariableNames: 'ConcreteSubclass DefaultInstance MutexForDefaultInstance ' - poolDictionaries: '' - category: 'Kernel-Numbers'! - -!classDefinition: #Random category: #'Kernel-Numbers' stamp: 'Install-4552-RandomDoubleInitializationFix-LucianoEstebanNotarfrancesco-2021Mar30-06h22m-len.001.cs.st 4/9/2021 16:04:43'! -Object subclass: #Random - instanceVariableNames: '' - classVariableNames: 'ConcreteSubclass DefaultInstance MutexForDefaultInstance' - poolDictionaries: '' - category: 'Kernel-Numbers'! -!Random class methodsFor: 'instance creation' stamp: 'len 3/30/2021 06:24:49' prior: 16897870 overrides: 16783533! - new - ^ self seed: Time millisecondClockValue! ! -!Random class methodsFor: 'instance creation' stamp: 'len 3/30/2021 06:26:50' prior: 16897880! - seed: anInteger - ^ (self = Random ifTrue: [ParkMiller93Random] ifFalse: [self]) basicNew seed: anInteger! ! -!Random class methodsFor: 'cached state access' stamp: 'len 3/30/2021 06:27:11' prior: 16897895 overrides: 50510042! - releaseClassCachedState - DefaultInstance _ nil. - MutexForDefaultInstance _ nil! ! -!LaggedFibonacciRandom methodsFor: 'private' stamp: 'len 3/30/2021 06:31:16' prior: 50462924 overrides: 16897855! - seed: anInteger - ring isNil ifTrue: [ring _ self newRing]. - self last: 1. - self initializeRingWith: (ParkMiller93Random seed: anInteger)! ! - -ParkMiller88Random removeSelector: #initialize! - -!methodRemoval: ParkMiller88Random #initialize stamp: 'Install-4552-RandomDoubleInitializationFix-LucianoEstebanNotarfrancesco-2021Mar30-06h22m-len.001.cs.st 4/9/2021 16:04:43'! -initialize - "Output stabilization is the user's responsibility" - - [ - seed _ (Time localMillisecondClock + self identityHash) hashMultiply \\ self m. - seed = 0 "zero seeds are unacceptable" - ] whileTrue. - seed _ seed asFloat! - -LaggedFibonacciRandom removeSelector: #initialize! - -!methodRemoval: LaggedFibonacciRandom #initialize stamp: 'Install-4552-RandomDoubleInitializationFix-LucianoEstebanNotarfrancesco-2021Mar30-06h22m-len.001.cs.st 4/9/2021 16:04:43'! -initialize - - self ring: self newRing. - self last: 1. - self initializeRingWith: ParkMiller93Random new! - -Random class removeSelector: #concreteRandomClass! - -!methodRemoval: Random class #concreteRandomClass stamp: 'Install-4552-RandomDoubleInitializationFix-LucianoEstebanNotarfrancesco-2021Mar30-06h22m-len.001.cs.st 4/9/2021 16:04:43'! -concreteRandomClass - - ConcreteSubclass ifNil: [ - ConcreteSubclass _ ParkMiller93Random ]. - ^ConcreteSubclass! - -Random class removeSelector: #newDefault! - -!methodRemoval: Random class #newDefault stamp: 'Install-4552-RandomDoubleInitializationFix-LucianoEstebanNotarfrancesco-2021Mar30-06h22m-len.001.cs.st 4/9/2021 16:04:43'! -newDefault - - ^self concreteRandomClass new! - -Object subclass: #Random - instanceVariableNames: '' - classVariableNames: 'DefaultInstance MutexForDefaultInstance' - poolDictionaries: '' - category: 'Kernel-Numbers'! - -!classDefinition: #Random category: #'Kernel-Numbers' stamp: 'Install-4552-RandomDoubleInitializationFix-LucianoEstebanNotarfrancesco-2021Mar30-06h22m-len.001.cs.st 4/9/2021 16:04:43'! -Object subclass: #Random - instanceVariableNames: '' - classVariableNames: 'DefaultInstance MutexForDefaultInstance' - poolDictionaries: '' - category: 'Kernel-Numbers'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4552-RandomDoubleInitializationFix-LucianoEstebanNotarfrancesco-2021Mar30-06h22m-len.001.cs.st----! - -'From Cuis 5.0 [latest update: #4552] on 5 April 2021 at 12:31:08 pm'! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 4/5/2021 12:26:36' prior: 50566929! - addHalo - "Invoke a halo programatically (e.g., not from a meta gesture)" - self addHalo: nil! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 4/5/2021 12:29:16' prior: 50562713! - transferHalo: event from: formerHaloOwner - "Progressively transfer the halo to the next likely recipient" - - formerHaloOwner == self - ifFalse: [ - self addHalo: event. - ^self ]. - - event shiftPressed ifTrue: [ - "Pass it outwards" - owner ifNotNil: [ - owner transferHalo: event from: formerHaloOwner. - ^self ]. - "We're at the top level; just keep it on ourselves" - ^self ]. - - self submorphsDo: [ :m | - (m wantsHalo and: [ m fullContainsGlobalPoint: event eventPosition ]) - ifTrue: [ - m transferHalo: event from: formerHaloOwner. - ^self ]]. - "We're at the bottom most level; just keep halo on ourselves"! ! -!HaloMorph methodsFor: 'event handling' stamp: 'jmv 4/5/2021 12:28:21' prior: 16850681! - transferHalo: event localPosition: localEventPosition - "Transfer the halo to the next likely recipient" - target ifNil: [ - self delete. - ^ self ]. - target transferHalo: event from: target.! ! -!MenuMorph methodsFor: 'initialization' stamp: 'jmv 4/5/2021 12:27:42' prior: 50564932 overrides: 16876882! - delete - activeSubMenu ifNotNil: [activeSubMenu delete]. - self itemsDo: [ :i | i deselect ]. - super delete! ! -!SmalltalkCompleterMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 4/5/2021 12:27:30' prior: 50528886 overrides: 16876882! - delete - - selectorDocumentation ifNotNil: [ - selectorDocumentation delete. - selectorDocumentation := nil ]. - - super delete ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4553-RemoveUnnededReturns-JuanVuletich-2021Apr05-12h26m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4552] on 5 April 2021 at 12:32:57 pm'! -!HaloMorph methodsFor: 'events' stamp: 'jmv 4/5/2021 12:32:51' prior: 16850637 overrides: 50544258! - mouseButton3Down: aMouseButtonEvent localPosition: localEventPosition - "Transfer the halo to the next likely recipient" - target ifNil: [ - self delete. - ^self]. - aMouseButtonEvent hand obtainHalo: self. - positionOffset _ aMouseButtonEvent eventPosition - target morphPositionInWorld. - "wait for click to transfer halo" - aMouseButtonEvent hand - waitForClicksOrDrag: self - event: aMouseButtonEvent - clkSel: #transferHalo:localPosition: - dblClkSel: nil! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4554-RemoveUnnededReturn-JuanVuletich-2021Apr05-12h31m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4552] on 5 April 2021 at 12:40:13 pm'! -!Morph methodsFor: 'events' stamp: 'jmv 4/5/2021 12:39:04' prior: 50544258! - mouseButton3Down: aMouseButtonEvent localPosition: localEventPosition - - self addHalo: aMouseButtonEvent.! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 4/5/2021 12:39:28' prior: 50566935! - addHalo: evt - "Defer execution until next cycle, so if you evaluate - BrowserWindow openBrowser addHalo - the window is in the world and with proper bounds, before adding the halo. - " - | halo | - self whenUIinSafeState: [ - self displayBoundsForHalo ifNotNil: [ :r | - halo _ HaloMorph new. - halo popUpFor: self event: evt. - halo morphBounds: r ]. - self redrawNeeded].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4555-RemoveMiddleButtonDrag-JuanVuletich-2021Apr05-12h32m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4552] on 5 April 2021 at 12:43:44 pm'! -!MenuMorph methodsFor: 'as yet unclassified' stamp: 'jmv 4/5/2021 12:42:02' overrides: 50567277! - addHalo: evt - self stayUp. - super addHalo: evt! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4556-MenusStayUpIfHalo-JuanVuletich-2021Apr05-12h40m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4552] on 5 April 2021 at 12:47:10 pm'! -!HaloMorph methodsFor: 'private' stamp: 'jmv 4/5/2021 12:46:44' prior: 50562570! - maybeCollapse: event with: aHandle - "Ask hand to collapse my target if mouse comes up in it." - - event hand obtainHalo: self. - (aHandle containsGlobalPoint: event eventPosition) - ifTrue: [ - target collapse ]. - self delete.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4557-FixCollapseBug-JuanVuletich-2021Apr05-12h43m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4552] on 5 April 2021 at 1:02:00 pm'! -!HaloMorph methodsFor: 'event handling' stamp: 'jmv 4/5/2021 12:56:17'! - popUpFor: aMorph handPosition: handPosition hand: hand - - hand halo: self. - hand world addMorphFront: self. - self target: aMorph. - positionOffset _ handPosition - aMorph morphPositionInWorld! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 4/5/2021 12:59:49' prior: 50567277! - addHalo: aMorphicEvent - "Defer execution until next cycle, so if you evaluate - BrowserWindow openBrowser addHalo - the window is in the world and with proper bounds, before adding the halo. - " - - | hand position | - aMorphicEvent - ifNil: [ - hand _ self world activeHand. - hand ifNil: [ hand _ self world firstHand ]. - position _ hand lastMouseEvent eventPosition ] - ifNotNil: [ - hand _ aMorphicEvent hand. - position _ aMorphicEvent eventPosition ]. - - self whenUIinSafeState: [ - HaloMorph new popUpFor: self handPosition: position hand: hand - ]! ! - -HaloMorph removeSelector: #popUpFor:event:! - -!methodRemoval: HaloMorph #popUpFor:event: stamp: 'Install-4558-AddHaloRefactor-JuanVuletich-2021Apr05-12h47m-jmv.001.cs.st 4/9/2021 16:04:43'! -popUpFor: aMorph event: aMorphicEvent - "This message is sent by morphs that explicitly request the halo on a button click. Note: anEvent is in aMorphs coordinate frame." - - | hand anEvent | - self flag: #workAround. "We should really have some event/hand here..." - anEvent _ aMorphicEvent - ifNil: [ - hand _ aMorph world activeHand. - hand ifNil: [ hand _ aMorph world firstHand ]. - hand lastMouseEvent ] - ifNotNil: [ - hand _ aMorphicEvent hand. - aMorphicEvent ]. - hand halo: self. - hand world addMorphFront: self. - self target: aMorph. - positionOffset _ anEvent eventPosition - aMorph morphPositionInWorld! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4558-AddHaloRefactor-JuanVuletich-2021Apr05-12h47m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4558] on 5 April 2021 at 3:39:29 pm'! -!UISupervisor class methodsFor: 'gui process' stamp: 'jmv 4/5/2021 15:37:00'! - userInterrupt: aProcess - "Create a Notifier on the active scheduling process with the given label." - | process | - process _ aProcess. - - "Only debug aProcess if its priority is >= UIProcess' priority" - UIProcess ifNotNil: [ - process priority < UIProcess priority ifTrue: [ - process _ UIProcess ]]. - - Debugger interruptProcess: process label: 'User Interrupt'! ! -!ProcessBrowser class methodsFor: 'CPU utilization' stamp: 'jmv 4/5/2021 15:30:04' prior: 50379399! - dumpPigStackOn: aStream - "Must run forked on its own process, so the monitored behavior is not affected too much" - - | promise tally process depth stack suspendedContext | - promise := Processor tallyCPUUsageFor: 1 every: 10. - tally := promise value. - "UISupervisor whenUIinSafeState: [self dumpTallyOnTranscript: tally]." - aStream nextPutAll: '====Al processes===='; newLine. - self dumpTally: tally on: aStream. - aStream newLine; nextPutAll: '====Process using most CPU===='; newLine. - process _ tally sortedCounts first value. - (100.0 * (tally occurrencesOf: process) / tally size) rounded printOn: aStream. - aStream - nextPutAll: ' % '; - nextPutAll: (process browserPrintStringFull: false); - newLine. - depth _ 20. - stack _ process == Processor activeProcess - ifTrue: [thisContext stackOfSize: depth] - ifFalse: [suspendedContext _ process suspendedContext. - suspendedContext - ifNotNil: [suspendedContext stackOfSize: depth]]. - stack - ifNil: [ aStream nextPutAll: 'No context'; newLine] - ifNotNil: [ - stack do: [ :c | - c printOn: aStream. - aStream newLine ]]. - ^process! ! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jmv 4/5/2021 15:37:58' prior: 50526385! - handleUserInterrupt - | p | - p _ Utilities reportCPUandRAM. - Preferences cmdDotEnabled ifTrue: [ - [ UISupervisor userInterrupt: p ] fork]! ! -!Utilities class methodsFor: 'vm statistics' stamp: 'jmv 4/5/2021 15:39:00' prior: 16941529! - reportCPUandRAM - "Write several text files with useful analysis for profiling purposes. - Overwrites any existing report. - Utilities reportCPUandRAM - " - - | profiler pig | - - "VM statistics (Memory use and GC, mainly)" - 'MemoryStats.txt' asFileEntry forceWriteStreamDo: [ :stream | - stream nextPutAll: self vmStatisticsReportString ]. - - "Process list" - 'ProcessList.txt' asFileEntry forceWriteStreamDo: [ :stream | - ProcessBrowser new processNameList - do: [ :each | - stream nextPutAll: each; newLine ]]. - - "Process taking most CPU" - 'ThePig.txt' asFileEntry forceWriteStreamDo: [ :stream | - pig _ ProcessBrowser dumpPigStackOn: stream ]. - - "Tally of all processes" - AndreasSystemProfiler canWork ifTrue: [ - 'FullTally.txt' asFileEntry forceWriteStreamDo: [ :stream | - profiler _ AndreasSystemProfiler new. - profiler spyOn: [ (Delay forMilliseconds: 1000) wait ]. - profiler - reportTextOn: stream - linesOn: (DummyStream on: nil) - talliesOn: (DummyStream on: nil) ]]. - - "Memory Analysis" - 'MemoryAnalysis.txt' asFileEntry forceWriteStreamDo: [ :stream | - SpaceTally new printSpaceAnalysis: 1 on: stream ]. - - ^pig! ! - -UISupervisor class removeSelector: #userInterrupt! - -!methodRemoval: UISupervisor class #userInterrupt stamp: 'Install-4559-UserInterruptFix-JuanVuletich-2021Apr05-15h37m-jmv.001.cs.st 4/9/2021 16:04:43'! -userInterrupt - "Create a Notifier on the active scheduling process with the given label." - | preemptedProcess | - preemptedProcess _ Processor preemptedProcess. - - "Only debug preempted process if its priority is >= UIProcess' priority" - UIProcess ifNotNil: [ - preemptedProcess priority < UIProcess priority ifTrue: [ - preemptedProcess _ UIProcess ]]. - - Debugger interruptProcess: preemptedProcess label: 'User Interrupt'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4559-UserInterruptFix-JuanVuletich-2021Apr05-15h37m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4558] on 5 April 2021 at 3:50:39 pm'! -!HaloMorph methodsFor: 'private' stamp: 'jmv 4/5/2021 14:52:12'! - addHandles: aDisplayRectangle - "update my size. owner is world, therefore owner coordinates are Display coordinates." - - self morphBounds: aDisplayRectangle. - haloBox _ self handlesBox. - target addHandlesTo: self box: haloBox. - self addNameString: (target printStringLimitedTo: 40). - self redrawNeeded.! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 4/5/2021 14:40:52'! - handlesBox - "handlesBox is in local coordinates. - We assume we are direct submorph of the world, without any scaling or rotation." - - | minSide hs c e box | - hs _ Preferences haloHandleSize. - minSide _ 4 * hs. - e _ extent + (hs*2) max: minSide@minSide. - c _ extent // 2 + self morphPosition. - box _ Rectangle center: c extent: e. - self world ifNotNil: [ :w | box _ box intersect: (w viewBox insetBy: (hs@hs corner: hs@(hs*3))) ]. - "Make it local" - ^box translatedBy: self morphPosition negated. -! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 4/5/2021 14:50:49' prior: 50567338! - addHalo: aMorphicEventOrNil - - | hand position | - aMorphicEventOrNil - ifNil: [ - hand _ self world activeHand. - hand ifNil: [ hand _ self world firstHand ]. - position _ hand lastMouseEvent eventPosition ] - ifNotNil: [ - hand _ aMorphicEventOrNil hand. - position _ aMorphicEventOrNil eventPosition ]. - - HaloMorph new popUpFor: self handPosition: position hand: hand! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 4/5/2021 15:50:34' prior: 50559420! - addHandles - - self removeAllMorphs. "remove old handles, if any" - target isInWorld ifTrue: [ "If not in world, not even bother" - target displayBoundsForHalo - ifNotNil: [ :r | self addHandles: r] "If target has already been drawn and has bounds, go ahead" - ifNil: [ - self whenUIinSafeState: [ "Otherwise, see if in next cycle target gets drawn and its bounds known" - target displayBoundsForHalo - ifNotNil: [ :r | self addHandles: r]]] - ]! ! - -HaloMorph removeSelector: #basicBox! - -!methodRemoval: HaloMorph #basicBox stamp: 'Install-4560-AddHaloFix-JuanVuletich-2021Apr05-15h39m-jmv.001.cs.st 4/9/2021 16:04:44'! -basicBox - "basicBox is in local coordinates" - - | minSide e hs box | - hs _ Preferences haloHandleSize. - minSide _ 4 * hs. - e _ extent + (hs*2) max: minSide@minSide. - box _ target displayBoundsForHalo. - box _ Rectangle center: box center extent: e. - self world ifNotNil: [ :w | box _ box intersect: (w viewBox insetBy: (hs@hs corner: hs@(hs*3))) ]. - ^box translatedBy: self morphPosition negated. -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4560-AddHaloFix-JuanVuletich-2021Apr05-15h39m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4558] on 5 April 2021 at 4:14:24 pm'! -!BitBltCanvas methodsFor: 'drawing' stamp: 'jmv 4/5/2021 16:14:13' prior: 50566832! - drawCoordinateSystem: aRectangle - | c stepX stepY x0 x1 y0 y1 prevClipRect | - stepX _ 100. - stepY _ 50. - - prevClipRect _ self clipRect. - self setClipRect: (prevClipRect intersect:currentMorph displayBounds). - - self frameRectangle: aRectangle borderWidth: 4 color: `Color lightGray alpha: 0.4`. - - x0 _ aRectangle left. - x1 _ aRectangle right-1. - y0 _ aRectangle top. - y1 _ aRectangle bottom-1. - - c _ `Color lightGray alpha: 0.6`. - self line: x0@0 to: x1@0 width: 2 color: c. - self line: 0@y0 to: 0@y1 width: 2 color: c. - - (x0 truncateTo: stepX) to: (x1 - stepX truncateTo: stepX) by: stepX do: [ :x | - self line: x @ -5 to: x @ 5 width: 2 color: c. - self drawString: x printString atCenterX: x @ 5 font: nil color: c ]. - self drawString: 'x' atCenterX: x1 - 15 @ 0 font: nil color: c. - - (y0 truncateTo: stepY) to: (y1 - stepY truncateTo: stepY) by: stepY do: [ :y | - self line: -5 @ y to: 5 @ y width: 2 color: c. - self drawString: y printString, ' ' atWaist: 5 @ y font: nil color: c ]. - self drawString: 'y' atWaist: 0 @ (y1 - 20) font: nil color: c. - - self setClipRect: prevClipRect.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4561-BitBltCanvas-CoordinateSystem-fix-JuanVuletich-2021Apr05-15h51m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4561] on 8 April 2021 at 11:10:49 am'! -!Morph methodsFor: 'change reporting' stamp: 'jmv 4/8/2021 10:57:19' prior: 50559987! - invalidateDisplayRect: damageRect for: aMorph - " - If we clip submorphs, then we clip damageRect. - - aMorph is the morph that changed and therefore should be redrawn. In some cases, damage reporting is done by no longer occupying some area, and requesting whatever appropriate morph to be drawn there. In such cases, aMorph should be nil. See senders." - - | clippedRect b | - self visible ifFalse: [ ^self]. - - clippedRect _ damageRect. - self clipsSubmorphsReally ifTrue: [ - b _ self displayBounds. - b ifNil: [ ^self ]. - clippedRect _ damageRect intersect: b ]. - owner ifNotNil: [ - owner invalidateDisplayRect: clippedRect for: aMorph ].! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 4/8/2021 10:53:31' prior: 50559394 overrides: 50559382! - referencePosition - "Return the current reference position of the receiver" - "a rather ugly way to say #center . At least, we avoid false polymorphism" - "remove some day" - self flag: #jmvVer2. - self displayBounds ifNotNil: [ :r | r center ]. - ^ self morphExtentInWorld // 2 + self morphPositionInWorld! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 4/8/2021 10:59:15' prior: 50534247 overrides: 50537895! - displayBounds - ^ self morphPosition extent: self morphExtent ! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 4/8/2021 10:59:19' prior: 50551999 overrides: 50537895! - displayBounds - ^ 0@0 extent: extent! ! -!BitBltCanvas methodsFor: 'drawing' stamp: 'jmv 4/8/2021 10:52:51' prior: 50567606! - drawCoordinateSystem: aRectangle - | c stepX stepY x0 x1 y0 y1 prevClipRect | - stepX _ 100. - stepY _ 50. - - prevClipRect _ self clipRect. - self setClipRect: (prevClipRect intersect: currentMorph displayBounds). - - self frameRectangle: aRectangle borderWidth: 4 color: `Color lightGray alpha: 0.4`. - - x0 _ aRectangle left. - x1 _ aRectangle right-1. - y0 _ aRectangle top. - y1 _ aRectangle bottom-1. - - c _ `Color lightGray alpha: 0.6`. - self line: x0@0 to: x1@0 width: 2 color: c. - self line: 0@y0 to: 0@y1 width: 2 color: c. - - (x0 truncateTo: stepX) to: (x1 - stepX truncateTo: stepX) by: stepX do: [ :x | - self line: x @ -5 to: x @ 5 width: 2 color: c. - self drawString: x printString atCenterX: x @ 5 font: nil color: c ]. - self drawString: 'x' atCenterX: x1 - 15 @ 0 font: nil color: c. - - (y0 truncateTo: stepY) to: (y1 - stepY truncateTo: stepY) by: stepY do: [ :y | - self line: -5 @ y to: 5 @ y width: 2 color: c. - self drawString: y printString, ' ' atWaist: 5 @ y font: nil color: c ]. - self drawString: 'y' atWaist: 0 @ (y1 - 20) font: nil color: c. - - self setClipRect: prevClipRect.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4562-minorTweaks-JuanVuletich-2021Apr08-11h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4562] on 8 April 2021 at 4:07:46 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 4/8/2021 15:14:43'! - adjustDisplayBoundsBy: delta - "Private for framework use. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - aRectangle is clipped appropiately if some owner clips us." - - privateDisplayBounds ifNotNil: [ - privateDisplayBounds _ privateDisplayBounds translatedBy: delta ]. - self allMorphsDo: [ :m | m adjustDisplayBoundsBy: delta ].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 4/8/2021 15:54:04'! - displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - aRectangle is clipped appropiately if some owner clips us." - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphAfterDraw ]]].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 4/8/2021 15:27:31'! - displayBoundsUpdateFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - aRectangle is clipped appropiately if some owner clips us." - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c == aCanvas ifTrue: [ - privateDisplayBounds _ privateDisplayBounds - quickMerge: aCanvas boundingRectOfCurrentMorphAfterDraw ]]].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 4/8/2021 15:15:10' prior: 50537895! - displayBounds - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - aRectangle is clipped appropiately if some owner clips us." - - self visible ifFalse: [ ^nil ]. - ^ privateDisplayBounds! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 4/8/2021 15:09:29' prior: 50559873! - grabMorph: aMorph delta: delta - "Grab the given morph (i.e., add it to this hand and remove it from its current owner)." - - | formerOwner formerPositionInWorld | - self releaseMouseFocus. "Break focus" - - "Grab the halo if present" - self halo ifNotNil: [ :h | - (h target == aMorph or: [h target hasOwner: aMorph]) ifTrue: [ - self addMorphBack: h position: h morphPositionInWorld - self morphPositionInWorld ]]. - - "Remember previous owner and position, in case the drop is later rejected" - formerOwner _ aMorph owner. - formerOwner ifNotNil: [ - formerPositionInWorld _ aMorph morphPositionInWorld. - grabMorphData - at: aMorph - put: { formerOwner. formerPositionInWorld. } ]. - self addMorphBack: aMorph position: delta. - - aMorph displayBounds ifNotNil: [ :r | | d | - formerPositionInWorld ifNotNil: [ - d _ aMorph morphPositionInWorld - formerPositionInWorld. - d isZero ifFalse: [ - aMorph adjustDisplayBoundsBy: d ]]]. - - aMorph justGrabbedFrom: formerOwner. - formerOwner ifNotNil: [ - lastPosition _ self morphPosition ].! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 4/8/2021 15:32:07' prior: 50559664! -drawCurrentAsError - "The morph (or one of its submorphs) had an error in its drawing method." - | r w | - r _ currentMorph morphLocalBounds. - w _ r extent > `50@50` - ifTrue: [ 6 ] - ifFalse: [ 2 ]. - self - frameAndFillRectangle: r - fillColor: `Color red` - borderWidth: w - borderColor: `Color yellow`. - self line: r topLeft to: r bottomRight width: w color: `Color yellow`. - self line: r topRight to: r bottomLeft width: w color: `Color yellow`. - currentMorph displayBoundsSetFrom: self.! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 4/8/2021 15:32:21' prior: 50566909! - drawCurrentAsOutline - - self isCurrentMorphVisible ifTrue: [ - self - reverseRectangleBorder: currentMorph morphLocalBounds - borderWidth: 2. - currentMorph displayBoundsSetFrom: self ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 4/8/2021 15:45:16' prior: 50555371! - fullUpdateCurrentBounds - | isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph drawOn: self ]. - currentMorph displayBoundsSetFrom: self. - isKnownFailing ifFalse: [ - currentMorph submorphsDo: [ :m | - self fullUpdateBounds: m ]]! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 4/8/2021 15:56:00' prior: 50557240! - updateCurrentDisplayBounds - "Update displayBounds for if never set. - Useful for new morph, that are created and attached to the hand." - - currentMorph drawOn: self. - currentMorph displayBoundsSetFrom: self. - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | self updateDisplayBounds: m ]].! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 4/8/2021 15:29:15' prior: 50566964 overrides: 50565002! - drawCurrentAndSubmorphs - - self isCurrentMorphVisible ifTrue: [ - - currentMorph drawOn: self. - currentMorph displayBoundsSetFrom: self. - - "Display submorphs back to front" - "coordinate system stack already set up for aMorph - ('ivars transformations' and 'currentTransformation')" - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | self fullDraw: m ]]. - - currentMorph postDrawOn: self. - currentMorph displayBoundsUpdateFrom: self. - - currentMorph isHighlighted ifTrue: [ - self drawCurrentMorphHighlight ]. - world notNil ifTrue: [ - currentMorph halo ifNotNil: [ - Preferences halosShowCoordinateSystem ifTrue: [ - self drawCoordinateSystem: currentMorph morphLocalBounds ]]]. - - currentMorph displayBoundsUpdateFrom: self. - ].! ! - -Morph removeSelector: #displayBounds:! - -!methodRemoval: Morph #displayBounds: stamp: 'Install-4563-displayBounds-refactor-JuanVuletich-2021Apr08-16h06m-jmv.001.cs.st 4/9/2021 16:04:44'! -displayBounds: aRectangle - - self displayBounds ~= aRectangle ifTrue: [ - privateDisplayBounds _ aRectangle ].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4563-displayBounds-refactor-JuanVuletich-2021Apr08-16h06m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4562] on 8 April 2021 at 5:14:06 pm'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 4/8/2021 16:56:40'! - updateCurrentDisplayBoundsAndMerge: aRectangle - "Update displayBounds for if never set. - Useful for new morph, that are created and attached to the hand." - - | r | - currentMorph drawOn: self. - currentMorph displayBoundsSetFrom: self. - r _ self boundingRectOfCurrentMorphAfterDraw. - r _ r quickMerge: aRectangle. - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | - r _ self updateDisplayBounds: m andMerge: r ]]. - ^r! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 4/8/2021 16:56:43'! - updateDisplayBounds: aMorph andMerge: aRectangle - "Update displayBounds for if never set. - Useful for new morph, that are created and attached to the hand." - - | r | - r _ aRectangle. - aMorph visible ifTrue: [ - self into: aMorph. - r _ self canvasToUse updateCurrentDisplayBoundsAndMerge: r. - self outOfMorph - ]. - ^r! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 4/8/2021 17:13:57' prior: 50553085! - updateHandsDisplayBounds: aWorldMorph - "Update displayBounds for carried morphs if never set. - Useful for new morph, that are created and attached to the hand." - - aWorldMorph handsDo: [ :hand | - hand hasSubmorphs ifTrue: [ - self into: hand. - hand submorphsDo: [ :morph | - morph displayBounds ifNil: [ - self updateDisplayBounds: morph andMerge: nil ]]. - self outOfMorph ]]! ! - -MorphicCanvas removeSelector: #updateCurrentDisplayBounds! - -!methodRemoval: MorphicCanvas #updateCurrentDisplayBounds stamp: 'Install-4564-displayBounds-refactor-JuanVuletich-2021Apr08-16h15m-jmv.003.cs.st 4/9/2021 16:04:44'! -updateCurrentDisplayBounds - "Update displayBounds for if never set. - Useful for new morph, that are created and attached to the hand." - - currentMorph drawOn: self. - currentMorph displayBoundsSetFrom: self. - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | self updateDisplayBounds: m ]].! - -MorphicCanvas removeSelector: #updateDisplayBounds:! - -!methodRemoval: MorphicCanvas #updateDisplayBounds: stamp: 'Install-4564-displayBounds-refactor-JuanVuletich-2021Apr08-16h15m-jmv.003.cs.st 4/9/2021 16:04:44'! -updateDisplayBounds: aMorph - "Update displayBounds for if never set. - Useful for new morph, that are created and attached to the hand." - - aMorph visible ifTrue: [ - aMorph displayBounds ifNil: [ - self into: aMorph. - self canvasToUse updateCurrentDisplayBounds. - self outOfMorph - ]]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4564-displayBounds-refactor-JuanVuletich-2021Apr08-16h15m-jmv.003.cs.st----! - -'From Cuis 5.0 [latest update: #4564] on 9 April 2021 at 2:13:37 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 4/9/2021 14:13:23' prior: 50567774! - displayBoundsUpdateFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - aRectangle is clipped appropiately if some owner clips us." - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - privateDisplayBounds _ privateDisplayBounds - quickMerge: aCanvas boundingRectOfCurrentMorphAfterDraw ]]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4565-displayBounds-fix-JuanVuletich-2021Apr09-14h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4564] on 9 April 2021 at 11:56:16 am'! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jmv 4/9/2021 11:54:27'! - detectBuiltInModule: aBlock - " - Smalltalk detectBuiltInModule: [ :n | n beginsWith: 'BitBltPlugin' ] - Smalltalk detectBuiltInModule: [ :n | n beginsWith: 'Nope' ] - " - "Look for a matching builtin module (e.g., plugins). Builtin plugins are those that are compiled with the VM directly, as opposed to plugins residing in an external shared library. - Answer nil if none." - | index name | - index _ 1. - [ (name _ self listBuiltinModule: index) notNil ] whileTrue: [ - (aBlock value: name) ifTrue: [ ^name ]. - index _ index + 1. - ]. - ^nil! ! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jmv 4/9/2021 11:52:53'! - isModuleAvailable: moduleNamePrefix - " - Smalltalk isModuleAvailable: 'BitBltPlugin' - Smalltalk isModuleAvailable: 'WrongName' - " - "Look for a matching builtin module (e.g., plugins). Builtin plugins are those that are compiled with the VM directly, as opposed to plugins residing in an external shared library." - - ^ (self detectBuiltInModule: [ :n | n beginsWith: moduleNamePrefix ]) notNil! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4566-QueryVMplugins-JuanVuletich-2021Apr09-11h39m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4566] on 9 April 2021 at 2:41:58 pm'! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 4/9/2021 14:41:51' prior: 50524435! - setDefaultFont: aFontName - "Change the font on the whole system without changing point sizes." - FontFamily defaultFamilyName: aFontName. - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: { - {#setListFontTo:. Preferences standardListFont pointSize.}. - {#setMenuFontTo:. Preferences standardMenuFont pointSize.}. - {#setWindowTitleFontTo:. Preferences windowTitleFont pointSize.}. - {#setCodeFontTo:. Preferences standardCodeFont pointSize.}. - {#setButtonFontTo:. Preferences standardButtonFont pointSize.}. - }. - UISupervisor ui ifNotNil: [ :w | w fontPreferenceChanged ] - -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4567-BetterAccessorToWorld-JuanVuletich-2021Apr09-14h41m-jmv.001.cs.st----! - -----SNAPSHOT----(9 April 2021 16:04:46) Cuis5.0-4567-v3.image priorSource: 7479686! - -----STARTUP---- (20 May 2021 10:28:51) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4567-v3.image! - - -'From Cuis 5.0 [latest update: #4550] on 29 March 2021 at 10:53:54 am'! -!Theme methodsFor: 'other options' stamp: 'len 3/29/2021 10:36:18'! - buttonBorderWidth - ^ 1! ! -!Theme methodsFor: 'other options' stamp: 'len 3/29/2021 10:34:25'! - menuBorderWidth - ^ self roundWindowCorners ifTrue: [0] ifFalse: [1]! ! -!Theme methodsFor: 'other options' stamp: 'len 3/29/2021 10:46:06'! - scrollbarShowButtons - ^ true! ! -!Theme methodsFor: 'other options' stamp: 'len 3/29/2021 10:39:24'! - windowBorderWidth - | w | - w _ Preferences standardListFont pointSize / 11. - w _ w * (self roundWindowCorners ifTrue: [4] ifFalse: [2]). - ^ w rounded max: 1! ! -!PluggableButtonMorph methodsFor: 'initialization' stamp: 'len 3/29/2021 10:36:35' prior: 16888310 overrides: 16889446! - defaultBorderWidth - ^ Theme current buttonBorderWidth! ! -!SystemWindow methodsFor: 'drawing' stamp: 'len 3/29/2021 10:41:37' prior: 50337724 overrides: 50545913! - drawOn: aCanvas - | titleColor roundCorners | - titleColor _ self widgetsColor. - self isTopWindow - ifTrue: [ titleColor _ titleColor lighter ]. - roundCorners _ Theme current roundWindowCorners. - roundCorners - ifTrue: [ - "Round corners. Optional title gradient." - self drawRoundedFrameOn: aCanvas color: titleColor ] - ifFalse: [ - "No round corners. No title gradient." - self drawClassicFrameOn: aCanvas color: titleColor ]. - labelString ifNotNil: [ self drawLabelOn: aCanvas ]! ! -!SystemWindow methodsFor: 'initialization' stamp: 'len 3/29/2021 10:39:47' prior: 50541144 overrides: 16889446! - defaultBorderWidth - "Answer the default border width for the receiver." - ^ Theme current windowBorderWidth! ! -!SystemWindow methodsFor: 'initialization' stamp: 'len 3/29/2021 10:42:48' prior: 50541171! - titleBarButtonsExtent - "Answer the extent to use for close & other title bar buttons. - The label height is used to be proportional to the fonts preferences." - | e | - e _ Preferences windowTitleFont pointSize * 13 // 10. - ^e@e! ! -!SystemWindow methodsFor: 'label' stamp: 'len 3/29/2021 10:42:01' prior: 50541183! - labelHeight - "Answer the height for the window label." - ^ Preferences windowTitleFont lineSpacing+1! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'len 3/29/2021 10:52:17' prior: 50522983! - buildMorphicClassColumnWith: classList - | column | - column _ LayoutMorph newColumn. - column - addMorphUseAll: classList; - addAdjusterAndMorph: self buildMorphicSwitches fixedHeight: Theme current buttonPaneHeight. - ^column! ! -!ScrollBar methodsFor: 'geometry' stamp: 'len 3/29/2021 10:46:54' prior: 16904557! - computeSlider - - | delta | - delta _ (Theme current scrollbarShowButtons ifTrue: [self buttonExtent] ifFalse: [0]) + (self freeSliderRoom * value) asInteger. - self isHorizontal - ifTrue: [ - slider morphPosition: borderWidth + delta @ borderWidth ] - ifFalse: [ - slider morphPosition: borderWidth @ (borderWidth + delta) ] ! ! -!ScrollBar methodsFor: 'geometry' stamp: 'len 3/29/2021 10:47:46' prior: 50371508! - freeSliderRoom - "Answer the length or height of the free slider area, i.e. subtract the slider itself. - If we are really too short of room, lie a little bit. Answering at least 4, even when the - free space might be actually negative, makes the scrollbar somewhat usable." - | buttonsRoom | - buttonsRoom _ Theme current scrollbarShowButtons ifTrue: [self buttonExtent * 2] ifFalse: [0]. - ^ ((self isHorizontal - ifTrue: [extent x - slider morphWidth] - ifFalse: [extent y - slider morphHeight]) - - (borderWidth * 2) - buttonsRoom) max: 4! ! -!ScrollBar methodsFor: 'initialization' stamp: 'len 3/29/2021 10:48:07' prior: 50565527! - initializeDownButton - "initialize the receiver's downButton" - - | e | - e _ self buttonExtent. - downButton _ self buttonClass new. - downButton model: self. - downButton morphExtent: e@e. - Theme current scrollbarShowButtons ifFalse: [^ self]. - self addMorph: downButton position: extent - borderWidth - e. - downButton - actWhen: #buttonStillDown. "to enable multiple action if held down". - self isHorizontal - ifTrue: [ self updateRightButton: downButton ] - ifFalse: [ self updateDownButton: downButton ]! ! -!ScrollBar methodsFor: 'initialization' stamp: 'len 3/29/2021 10:48:16' prior: 50565546! - initializeUpButton - "initialize the receiver's upButton" - - | e | - e _ self buttonExtent. - upButton _ self buttonClass new. - upButton model: self. - upButton morphExtent: e@e. - Theme current scrollbarShowButtons ifTrue: [^ self]. - self addMorph: upButton position: borderWidth@borderWidth. - upButton - actWhen: #buttonStillDown. "to enable multiple action if held down" - self isHorizontal - ifTrue: [ self updateLeftButton: upButton ] - ifFalse: [ self updateUpButton: upButton ]. -! ! -!MenuMorph methodsFor: 'initialization' stamp: 'len 3/29/2021 10:35:08' prior: 16866999 overrides: 50545895! - defaultBorderWidth - ^ Theme current menuBorderWidth! ! - -Theme removeSelector: #minimalWindows! - -!methodRemoval: Theme #minimalWindows stamp: 'Install-4568-MinimalWindowsCleanup-LucianoEstebanNotarfrancesco-2021Mar29-10h32m-len.001.cs.st 5/20/2021 10:28:56'! -minimalWindows - ^ false! - -Theme removeSelector: #showScrollbarButtons! - -Theme removeSelector: #steButtons! - -!methodRemoval: Theme #steButtons stamp: 'Install-4568-MinimalWindowsCleanup-LucianoEstebanNotarfrancesco-2021Mar29-10h32m-len.001.cs.st 5/20/2021 10:28:56'! -steButtons - ^false! - -Preferences class removeSelector: #menuBorderWidth! - -!methodRemoval: Preferences class #menuBorderWidth stamp: 'Install-4568-MinimalWindowsCleanup-LucianoEstebanNotarfrancesco-2021Mar29-10h32m-len.001.cs.st 5/20/2021 10:28:56'! -menuBorderWidth - - ^self parameters at: #menuBorderWidth ifAbsentPut: [ 1 ]! - -Preferences class removeSelector: #systemWindowBorderSize! - -!methodRemoval: Preferences class #systemWindowBorderSize stamp: 'Install-4568-MinimalWindowsCleanup-LucianoEstebanNotarfrancesco-2021Mar29-10h32m-len.001.cs.st 5/20/2021 10:28:57'! -systemWindowBorderSize - | w | - w _ Preferences standardListFont pointSize / 11. - Theme current minimalWindows ifFalse: [ - w _ w * (Theme current roundWindowCorners ifTrue: [ 4 ] ifFalse: [ 2 ])]. - ^w rounded max: 1! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4568-MinimalWindowsCleanup-LucianoEstebanNotarfrancesco-2021Mar29-10h32m-len.001.cs.st----! - -'From Cuis 5.0 [latest update: #4568] on 17 April 2021 at 7:46:45 pm'! -!ScrollBar methodsFor: 'initialization' stamp: 'jmv 4/17/2021 19:44:08' prior: 50568263! - initializeUpButton - "initialize the receiver's upButton" - - | e | - e _ self buttonExtent. - upButton _ self buttonClass new. - upButton model: self. - upButton morphExtent: e@e. - Theme current scrollbarShowButtons ifFalse: [^ self]. - self addMorph: upButton position: borderWidth@borderWidth. - upButton - actWhen: #buttonStillDown. "to enable multiple action if held down" - self isHorizontal - ifTrue: [ self updateLeftButton: upButton ] - ifFalse: [ self updateUpButton: upButton ]. -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4569-ScrollbarFix-JuanVuletich-2021Apr17-19h46m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4569] on 19 April 2021 at 12:34:32 pm'! -!ChangeSet class methodsFor: 'services' stamp: 'jmv 4/19/2021 12:33:55' prior: 50555096! - installNewUpdates: updatesFileDirectory - - | warnUser | - (self newUpdates: updatesFileDirectory) do: [ :each | - self install: each ]. - - warnUser _ false. - CodePackage installedPackages keysAndValuesDo: [ :pckName :package | - package fullFileName ifNotNil: [ :fullFileName | | codePackageFile | - codePackageFile _ CodePackageFile onFileEntry: fullFileName asFileEntry. - (codePackageFile provides isLaterThan: package provides) ifTrue: [ - warnUser _ true. - package hasUnsavedChanges - ifTrue: [ ('Package: ', pckName, '. Package has unsaved changes, but there is a newer version of the file.') print ] - ifFalse: [ ('Package: ', pckName, '. There is a newer version than the currently loaded.') print ]]]]. - warnUser - ifTrue: [ - self inform: SystemVersion current version, ' - ', Smalltalk lastUpdateString, String newLineString, -'Some package(s) loaded in the image -have updated package file on disk. -Please see Transcript.' ] - ifFalse: [ - Smalltalk systemInformationString print ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4570-NewerPackagesWarning-fix-JuanVuletich-2021Apr19-12h33m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4570] on 27 April 2021 at 3:20:35 pm'! -!Number class methodsFor: 'instance creation' stamp: 'jmv 4/27/2021 15:20:21' prior: 50454609 overrides: 16882927! - readFrom: stringOrStream - "Answer a number as described on aStream. The number may - include a leading radix specification, as in 16rFADE" - | value base aStream sign | - aStream _ (stringOrStream isMemberOf: String) - ifTrue: [ReadStream on: stringOrStream] - ifFalse: [stringOrStream]. - (aStream nextMatchAll: 'NaN') ifTrue: [^ Float nan]. - sign _ (aStream peekFor: $-) ifTrue: [-1] ifFalse: [aStream peekFor: $+. 1]. - (aStream nextMatchAll: 'Infinity') ifTrue: [^ Float infinity * sign]. - base _ 10. - aStream peek = $. - ifTrue: [ value _ 0 ] - ifFalse: [ - value _ Integer readFrom: aStream base: base. - (aStream peekFor: $r) - ifTrue: [ - "r" - (base _ value) < 2 ifTrue: [ - base = 1 ifTrue: [ ^Integer readBaseOneFrom: aStream ]. - ^self error: 'Invalid radix']. - (aStream peekFor: $-) ifTrue: [sign _ sign negated]. - value _ Integer readFrom: aStream base: base]. - (aStream peekFor: $x) - ifTrue: [ - "0x" "Hexadecimal" - base _ 16. - (aStream peekFor: $-) ifTrue: [sign _ sign negated]. - value _ Integer readFrom: aStream base: base]]. - ^ self readRemainderOf: value from: aStream base: base withSign: sign.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4571-AllowMissingLeadingZeroForFloatNumberFromString-JuanVuletich-2021Apr27-15h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4571] on 28 April 2021 at 11:51:28 am'! -!FontFamily class methodsFor: 'ui' stamp: 'jmv 4/28/2021 11:38:29'! - promptUserFolders - "Present a menu of font folders, answer selection. - FontFamily promptUserFolders - " - | menu familyName current | - current _ (FontFamily familyNamed: FontFamily defaultFamilyName) folderName. - menu _ MenuMorph new. - ((DirectoryEntry smalltalkImageDirectory / 'TrueTypeFonts') - directories sorted: [ :a :b | a name < b name ]) do: [ :dir | | subDirs | - subDirs _ dir directories sorted: [ :a :b | a name < b name ]. - subDirs isEmpty - ifTrue: [ | this | - this _ dir name. - menu - add: (this=current ifTrue: [''] ifFalse: ['']), this - target: menu - action: #modalSelection: - argument: dir ] - ifFalse: [ | submenu this | - submenu _ MenuMorph new. - subDirs do: [ :subdir | - this _ subdir name. - submenu - add: (this=current ifTrue: [''] ifFalse: ['']), this - target: menu - action: #modalSelection: - argument: subdir ]. - menu add: dir name, '... ' subMenu: submenu - ]]. - FontFamily availableFamilies values do: [ :family | - family folderName isNil ifTrue: [ - familyName _ family familyName. - menu - add: (familyName = FontFamily defaultFamilyName ifTrue: [''] ifFalse: ['']), familyName - target: menu - action: #modalSelection: - argument: familyName ]]. - ^menu invokeModal! ! -!FontFamily class methodsFor: 'file read write' stamp: 'jmv 4/28/2021 11:25:43' prior: 50457958! - readAdditionalTrueTypeFonts - Feature require: 'VectorGraphics'. - UISupervisor whenUIinSafeState: [ - Smalltalk at: #TrueTypeFontFamily ifPresent: [ :cls | cls readAdditionalFonts ]]! ! -!FontFamily class methodsFor: 'ui' stamp: 'jmv 4/28/2021 11:41:10' prior: 50525012! - promptUser - "Present a menu of font families, answer selection. - FontFamily promptUser - " - | selectedNameOrDirectory | - selectedNameOrDirectory _ self promptUserFolders. - selectedNameOrDirectory isNil ifTrue: [ ^nil ]. - (FontFamily familyNamed: selectedNameOrDirectory) - ifNotNil: [ :it | ^it ]. - ^FontFamily availableFamilies values - detect: [ :any | any folderName = selectedNameOrDirectory name ] - ifNone: [ - FontFamily familyNamed: ((Smalltalk at: #TrueTypeFontFamily) read: selectedNameOrDirectory) anyOne ]! ! -!FontFamily class methodsFor: 'ui' stamp: 'jmv 4/28/2021 11:51:19' prior: 50524862! - promptUserAndSetDefault - "Present a menu of available font families, and if one is chosen, change to it. - FontFamily promptUserAndSetDefault - " - | selectedNameOrDirectory fontFamily | - selectedNameOrDirectory _ self promptUserFolders. - selectedNameOrDirectory isNil ifTrue: [ ^nil ]. - (FontFamily familyNamed: selectedNameOrDirectory) - ifNotNil: [ :it | ^Preferences setDefaultFont: it familyName ]. - Feature require: 'VectorGraphics'. - UISupervisor whenUIinSafeState: [ - fontFamily _ FontFamily availableFamilies values - detect: [ :any | any folderName = selectedNameOrDirectory name ] - ifNone: [ - FontFamily familyNamed: ((Smalltalk at: #TrueTypeFontFamily) read: selectedNameOrDirectory) anyOne ]. - Preferences setDefaultFont: fontFamily familyName ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4572-FontLoadFix-JuanVuletich-2021Apr28-11h50m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4570] on 26 April 2021 at 3:43:21 pm'! -!Scanner methodsFor: 'multi-character scans' stamp: 'jmv 4/26/2021 15:26:05' prior: 50410266! - xSingleQuote - - "String." - - self readUpToNext: $' ifNotFound: [ - ^self notify: 'Unmatched string quote' at: mark + 1]. - tokenType := #string! ! -!Parser methodsFor: 'public access' stamp: 'jmv 4/26/2021 15:12:23' prior: 50512983! - parse: sourceStream class: class category: aCategory noPattern: noPattern doIt: doIt context: aContext notifying: aRequestor ifFail: aBlock - - "Answer a MethodNode for the argument, sourceStream, that is the root of - a parse tree. Parsing is done with respect to the argument, class, to find - instance, class, and pool variables; and with respect to the argument, - ctxt, to find temporary variables. Errors in parsing are reported to the - argument, req, if not nil; otherwise aBlock is evaluated. The argument - noPattern is a Boolean that is true if the the sourceStream does not - contain a method header (i.e., for DoIts)." - - | methNode repeatNeeded myStream sourceCode startPosition | - - category _ aCategory. - myStream _ sourceStream. - [ - repeatNeeded _ false. - startPosition _ myStream position. - sourceCode _ myStream upToEnd. - myStream position: startPosition. - self encoder init: class context: aContext notifying: self. - "Protect against possible parsing failure" - doIt ifTrue: [ - (sourceCode beginsWith: Scanner doItInSelector) - ifTrue: [encoder selector: Scanner doItInSelector] - ifFalse: [ - (sourceCode beginsWith: Scanner doItSelector) - ifTrue: [encoder selector: Scanner doItSelector]]]. - self init: myStream notifying: aRequestor failBlock: [^ aBlock value ]. - doitFlag _ noPattern. - failBlock _ aBlock. - [ methNode _ self method: noPattern doIt: doIt context: aContext ] - on: ReparseAfterSourceEditing - do: [ :ex | - repeatNeeded _ true. - myStream _ ReadStream on: requestor text string ]. - repeatNeeded - ] whileTrue: [ encoder _ self encoder class new ]. - - methNode sourceText: sourceCode. - "See #xBacktick" - sentInLiterals do: [ :sym | encoder noteOptimizedSelector: sym ]. - - ^ methNode! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4573-NotificationPositionFixes-JuanVuletich-2021Apr26-15h41m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4571] on 26 April 2021 at 7:33:07 pm'! -!SmalltalkCompleter methodsFor: 'accessing' stamp: 'jmv 4/26/2021 19:28:15'! - allSource - ^model actualContents string! ! -!SmalltalkCompleter methodsFor: 'entries' stamp: 'jmv 4/26/2021 19:31:49' prior: 50509634 overrides: 16781250! - computeEntries - - | allSource source contextClass specificModel range - separator fragmentStart fragmentEnd done | - - allSource _ self allSource. - separator _ String newLineString, String newLineString. - fragmentStart _ 1. - done _ false. - [done] whileFalse: [ - fragmentEnd _ allSource - indexOfSubCollection: separator - startingAt: fragmentStart - ifAbsent: [allSource size]. - fragmentEnd >= position ifTrue: [ - source _ allSource copyFrom: fragmentStart to: position. - done _ true ]. - fragmentStart _ fragmentEnd+separator size ]. - - specificModel _ self textProviderOrModel. - contextClass _ self selectedClassOrMetaClassIn: specificModel. - allRanges _ self parse: source in: contextClass and: specificModel. - range _ allRanges lastIfEmpty: [ ^entries _ #() ]. - possibleInvalidSelectors _ #(). - - range end = source size - ifTrue: [ self computeEntriesOfMessageOrIdentifiersFor: source at: range in: contextClass and: specificModel ] - ifFalse: [ self computeMessageEntriesWithEmptyPrefixFor: source at: range in: contextClass and: specificModel ]. - - ! ! -!SmalltalkCompleter methodsFor: 'entries - private' stamp: 'jmv 4/26/2021 19:32:47' prior: 50509213! - parse: source in: contextClass and: specificModel - - | isMethod | - parser _ SHParserST80 new. - parser - workspace: ((specificModel is: #providesBindings) ifTrue: [specificModel]); - classOrMetaClass: contextClass; - source: source. - - isMethod := (specificModel is: #Browser) - ifTrue: [ specificModel isEditingClass not ] - ifFalse: [ specificModel is: #CodeProvider ]. - parser parse: isMethod. - - ^ parser rangesWithoutExcessCode.! ! - -SHParserST80 removeSelector: #allSource! - -!methodRemoval: SHParserST80 #allSource stamp: 'Install-4574-AutoCompletebyParagraphsInWorkspaces-JuanVuletich-2021Apr26-19h11m-jmv.003.cs.st 5/20/2021 10:28:57'! -allSource - - ^allSource! - -SHParserST80 removeSelector: #allSource:! - -!methodRemoval: SHParserST80 #allSource: stamp: 'Install-4574-AutoCompletebyParagraphsInWorkspaces-JuanVuletich-2021Apr26-19h11m-jmv.003.cs.st 5/20/2021 10:28:57'! -allSource: aSourceCode - - allSource _ aSourceCode! - -SmalltalkCompleter removeSelector: #changePositionTo:! - -!methodRemoval: SmalltalkCompleter #changePositionTo: stamp: 'Install-4574-AutoCompletebyParagraphsInWorkspaces-JuanVuletich-2021Apr26-19h11m-jmv.003.cs.st 5/20/2021 10:28:57'! -changePositionTo: newPosition - - position _ newPosition! - -Object subclass: #SHParserST80 - instanceVariableNames: 'classOrMetaClass source workspace arguments sourcePosition currentToken currentTokenFirst temporaries instanceVariables errorBlock currentTokenSourcePosition blockDepth bracketDepth ranges blockDepths blockDepthsStartIndexes braceDepth' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -!classDefinition: #SHParserST80 category: #'Tools-Syntax Highlighting' stamp: 'Install-4574-AutoCompletebyParagraphsInWorkspaces-JuanVuletich-2021Apr26-19h11m-jmv.003.cs.st 5/20/2021 10:28:57'! -Object subclass: #SHParserST80 - instanceVariableNames: 'classOrMetaClass source workspace arguments sourcePosition currentToken currentTokenFirst temporaries instanceVariables errorBlock currentTokenSourcePosition blockDepth bracketDepth ranges blockDepths blockDepthsStartIndexes braceDepth' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4574-AutoCompletebyParagraphsInWorkspaces-JuanVuletich-2021Apr26-19h11m-jmv.003.cs.st----! - -'From Cuis 5.0 [latest update: #4567] on 13 April 2021 at 2:15:10 pm'! -!BlockClosure methodsFor: 'private' stamp: 'jmv 4/13/2021 13:50:00'! - valueEnsured - "Protect against process termination. - Suggested by Esteban Maringolo at Martin McClure's 'Threads, Critical Sections, and Termination' (Smalltalks 2019 conference)" - [] ensure: self! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4575-valueEnsured-JuanVuletich-2021Apr13-13h50m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4568] on 13 April 2021 at 2:30:43 pm'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 4/13/2021 14:22:47' prior: 50548276! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('AY' 'Angel Yan') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('bgs' 'Boris G. Shingarov') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('db' 'Douglas Brebner') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('EB' 'Eric Brandwein') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('FGJ' 'Fernando Gasperi Jabalera') - #('FJG' 'Facundo Javier Gelatti') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hlsf' 'Hilaire Fernandes') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('jar' 'Jaromir Matas') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('KLG' 'Gerald Klix') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MM' 'Mariano Montone') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('pmon' 'Paolo Montrasi') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('sjd' 'Santiago Jose Dandois') - #('SLD' 'Steve Davies') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('ss' 'Sebastian Sujarchuk') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tsl' 'Thiago da Silva Lino') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4576-AddJaromirAsKnownAuthor-JuanVuletich-2021Apr13-14h30m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4567] on 29 April 2021 at 2:52:18 pm'! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 4/29/2021 14:52:10' prior: 50566384! - displayWorldSafely - "Update this world's display and keep track of errors during draw methods." - - [self displayWorld] ifError: [ :err :rcvr | - "Handle a drawing error" - canvas currentMorphDrawingFails. - self setCanvas. - "Install the old error handler, so we can re-raise the error" - rcvr error: err. - ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4577-MorphicDrawingErrorFix-JuanVuletich-2021Apr29-14h52m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4579] on 29 April 2021 at 3:43:12 pm'! -!DirectoryEntry methodsFor: 'actions-directory' stamp: 'jmv 4/29/2021 15:42:46' prior: 16834552! - rename: newName - - | fileEntry directoryEntry | - fileEntry _ self parent // newName. - fileEntry exists - ifTrue: [ Error signal: 'There already exists a file named: ', fileEntry printString ]. - directoryEntry _ self parent / newName. - directoryEntry exists - ifTrue: [ Error signal: 'There already exists a directory named: ', fileEntry printString ]. - self fileAccessor renameDirectory: self pathName to: directoryEntry pathName. - self name: newName! ! -!FileEntry methodsFor: 'actions-file' stamp: 'jmv 4/29/2021 15:42:52' prior: 16841325! - rename: newName - - | fileEntry directoryEntry | - fileEntry _ self parent // newName. - fileEntry exists - ifTrue: [ Error signal: 'There already exists a file named: ', fileEntry printString ]. - directoryEntry _ self parent / newName. - directoryEntry exists - ifTrue: [ Error signal: 'There already exists a directory named: ', fileEntry printString ]. - self fileAccessor rename: self pathName to: fileEntry pathName. - self name: newName.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4578-FileRename-avoid-overwrite-JuanVuletich-2021Apr29-15h38m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4574] on 29 April 2021 at 4:13:04 pm'! -!SmalltalkCompleter methodsFor: 'entries' stamp: 'jmv 4/29/2021 16:12:50' prior: 50568636 overrides: 16781250! - computeEntries - - | allSource source contextClass specificModel range - separator fragmentStart fragmentEnd done | - - specificModel _ self textProviderOrModel. - contextClass _ self selectedClassOrMetaClassIn: specificModel. - - allSource _ self allSource. - (specificModel is: #CodeProvider) - ifTrue: [source _ allSource copyFrom: 1 to: position] - ifFalse: [ - separator _ String newLineString, String newLineString. - fragmentStart _ 1. - done _ false. - [done] whileFalse: [ - fragmentEnd _ allSource - indexOfSubCollection: separator - startingAt: fragmentStart - ifAbsent: [allSource size]. - fragmentEnd >= position ifTrue: [ - source _ allSource copyFrom: fragmentStart to: position. - done _ true ]. - fragmentStart _ fragmentEnd+separator size ]]. - - allRanges _ self parse: source in: contextClass and: specificModel. - range _ allRanges lastIfEmpty: [ ^entries _ #() ]. - possibleInvalidSelectors _ #(). - - range end = source size - ifTrue: [ self computeEntriesOfMessageOrIdentifiersFor: source at: range in: contextClass and: specificModel ] - ifFalse: [ self computeMessageEntriesWithEmptyPrefixFor: source at: range in: contextClass and: specificModel ]. - - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4579-AutocompleteByParagraphsONLYinWorkspaces-JuanVuletich-2021Apr29-16h06m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4527] on 12 April 2021 at 10:16:03 pm'! -!BlockClosure methodsFor: 'scheduling' stamp: 'jar 4/8/2021 19:59:08' prior: 16788378! -newProcess - "Answer a Process running the code in the receiver. The process is not - scheduled." - "Simulation guard" - ^Process - forContext: - [self value. - Processor activeProcess suspend] asContext - priority: Processor activePriority! ! -!BlockClosure methodsFor: 'scheduling' stamp: 'jar 4/8/2021 19:59:28' prior: 16788389! - newProcessWith: anArray - "Answer a Process running the code in the receiver. The receiver's block - arguments are bound to the contents of the argument, anArray. The - process is not scheduled." - "Simulation guard" - ^Process - forContext: - [self valueWithArguments: anArray. - Processor activeProcess suspend] asContext - priority: Processor activePriority! ! -!Process methodsFor: 'changing process state' stamp: 'jar 4/12/2021 20:42:03' prior: 16894147! - terminate - "Stop the process that the receiver represents forever. Unwind to execute pending ensure:/ifCurtailed: blocks before terminating." - - | ctxt unwindBlock oldList outerMost | - self isRunning ifTrue: [ - "If terminating the active process, suspend it first and terminate it as a suspended process." - [self terminate] fork. - ^self suspend]. - - "Always suspend the process first so it doesn't accidentally get woken up" - oldList _ self suspend. - suspendedContext ifNotNil:[ - "Figure out if we are terminating the process while waiting in Semaphore>>critical: - In this case, pop the suspendedContext so that we leave the ensure: block inside - Semaphore>>critical: without signaling the semaphore." - (oldList class == Semaphore and:[ - suspendedContext method == (Semaphore compiledMethodAt: #critical:)]) ifTrue: [ - suspendedContext _ suspendedContext home. - ]. - - "If terminating a process halfways through an unwind, try to complete that unwind block first; - if there are multiple such nested unwind blocks, try to complete the outer-most one; the inner - blocks will be completed in the process." - ctxt _ suspendedContext. - [(ctxt _ ctxt findNextUnwindContextUpTo: nil) isNil] whileFalse: - "Contexts under evaluation have already set their complete (tempAt: 2) to true." - [(ctxt tempAt:2) ifNotNil: [outerMost _ ctxt]]. - outerMost ifNotNil: [ - "This is the outer-most unwind context currently under evaluation; - let's find an inner context executing outerMost's argument block (tempAt: 1)" - (suspendedContext findContextSuchThat: [:ctx | - ctx closure == (outerMost tempAt: 1)]) ifNotNil: [:inner | - "Let's finish the unfinished unwind context only (i.e. up to inner) and return here" - suspendedContext runUntilErrorOrReturnFrom: inner. - "Update the receiver's suspendedContext (the previous step reset its sender to nil); - return, if the execution stack reached its bottom (e.g. in case of non-local returns)." - (suspendedContext _ outerMost sender) ifNil: [^self]]]. - - "Now all unwind blocks caught halfway through have been completed; - let's execute the ones still pending. Note: #findNextUnwindContextUpTo: starts - searching from the receiver's sender but the receiver itself may be an unwind context." - ctxt _ suspendedContext. - ctxt isUnwindContext ifFalse: [ctxt _ ctxt findNextUnwindContextUpTo: nil]. - [ctxt isNil] whileFalse: [ - (ctxt tempAt: 2) ifNil: [ - ctxt tempAt: 2 put: true. - unwindBlock _ ctxt tempAt: 1. - "Create a context for the unwind block and execute it on the unwind block's stack. - Note: using #value instead of #runUntilErrorOrReturnFrom: would lead to executing - the unwind on the wrong stack preventing the correct execution of non-local returns." - suspendedContext _ unwindBlock asContextWithSender: ctxt. - suspendedContext runUntilErrorOrReturnFrom: suspendedContext]. - ctxt _ ctxt findNextUnwindContextUpTo: nil]. - - "Reset the context's pc and sender to nil for the benefit of isTerminated." - suspendedContext terminate]! ! -!Process methodsFor: 'testing' stamp: 'jar 4/8/2021 23:39:52' prior: 16894723! - isTerminated - "Answer if the receiver is terminated. A process is considered terminated - if the suspendedContext is the bottomContext and the pc is at the endPC" - - self isRunning ifTrue: [^ false]. - ^suspendedContext isNil or: [ - suspendedContext isBottomContext and: [ - suspendedContext isDead or: [suspendedContext atEnd]]] -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4580-terminate-fixes-JaromirMatas-2021Apr08-21h20m-jar.002.cs.st----! - -'From Cuis 5.0 [latest update: #4577] on 29 April 2021 at 12:45:09 pm'! -!Process methodsFor: 'changing process state' stamp: 'jmv 4/29/2021 12:44:59' prior: 50569127! - terminate - "Stop the process that the receiver represents forever. Unwind to execute pending ensure:/ifCurtailed: blocks before terminating." - - | ctxt unwindBlock oldList outerMost | - self isRunning ifTrue: [ - "If terminating the active process, suspend it first and terminate it as a suspended process." - [self terminate] fork. - ^self suspend]. - - "Always suspend the process first so it doesn't accidentally get woken up" - oldList _ self suspend. - suspendedContext ifNotNil:[ - "Figure out if we are terminating the process while waiting in Semaphore>>critical: - In this case, pop the suspendedContext so that we leave the ensure: block inside - Semaphore>>critical: without signaling the semaphore." - (oldList class == Semaphore and:[ - suspendedContext method == (Semaphore compiledMethodAt: #critical:)]) ifTrue: [ - suspendedContext _ suspendedContext home. - ]. - - "If terminating a process halfways through an unwind, try to complete that unwind block first; - if there are multiple such nested unwind blocks, try to complete the outer-most one; the inner - blocks will be completed in the process." - ctxt _ suspendedContext. - [(ctxt _ ctxt findNextUnwindContextUpTo: nil) isNil] whileFalse: - "Contexts under evaluation have already set their complete (tempAt: 2) to true." - [(ctxt tempAt:2) ifNotNil: [outerMost _ ctxt]]. - outerMost ifNotNil: [ - "This is the outer-most unwind context currently under evaluation; - let's find an inner context executing outerMost's argument block (tempAt: 1)" - (suspendedContext findContextSuchThat: [:ctx | - ctx closure == (outerMost tempAt: 1)]) ifNotNil: [:inner | - "Let's finish the unfinished unwind context only (i.e. up to inner) and return here" - outerMost _ (suspendedContext runUntilErrorOrReturnFrom: inner) first. - "Update the receiver's suspendedContext (the previous step reset its sender to nil); - return, if the execution stack reached its bottom (e.g. in case of non-local returns)." - (suspendedContext _ outerMost sender) ifNil: [^self]]]. - - "Now all unwind blocks caught halfway through have been completed; - let's execute the ones still pending. Note: #findNextUnwindContextUpTo: starts - searching from the receiver's sender but the receiver itself may be an unwind context." - ctxt _ suspendedContext. - ctxt isUnwindContext ifFalse: [ctxt _ ctxt findNextUnwindContextUpTo: nil]. - [ctxt isNil] whileFalse: [ - (ctxt tempAt: 2) ifNil: [ - ctxt tempAt: 2 put: true. - unwindBlock _ ctxt tempAt: 1. - "Create a context for the unwind block and execute it on the unwind block's stack. - Note: using #value instead of #runUntilErrorOrReturnFrom: would lead to executing - the unwind on the wrong stack preventing the correct execution of non-local returns." - suspendedContext _ unwindBlock asContextWithSender: ctxt. - suspendedContext runUntilErrorOrReturnFrom: suspendedContext]. - ctxt _ ctxt findNextUnwindContextUpTo: nil]. - - "Reset the context's pc and sender to nil for the benefit of isTerminated." - suspendedContext terminate]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4581-terminate-fix-JuanVuletich-2021Apr29-12h43m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4579] on 1 May 2021 at 11:38:01 pm'! -!ProgressInitiationException methodsFor: 'exceptionDescription' stamp: 'nice 5/1/2021 23:36:25' prior: 16896161! - sendNotificationsTo: aNewBlock - - signalContext resumeEvaluating: [ - workBlock value: [ :barVal | - aNewBlock value: minVal value: maxVal value: barVal - ] - ] -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4582-ProgressInitiationException-nice-2021May01-23h24m-nice.002.cs.st----! - -'From Cuis 5.0 [latest update: #4582] on 3 May 2021 at 10:59:54 am'! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 5/3/2021 10:57:05' prior: 50562477! - grabMorph: aMorph moveUnderHand: moveUnderHand - "Grab the given morph (i.e., add it to this hand and remove it from its current owner). - If moveUnderHand is requested or it seems neccesary anyway, move the grabbed morph under the hand." - - | grabbed positionInHandCoordinates tx | - self releaseMouseFocus. "Break focus" - grabbed _ aMorph. - aMorph owner ifNotNil: [ :o | grabbed _ o aboutToGrab: aMorph ]. - grabbed ifNil: [ ^ self ]. - grabbed _ grabbed aboutToBeGrabbedBy: self. - grabbed ifNil: [ ^ self ]. - - moveUnderHand - ifTrue: [ - "We can possibly do better, especially for non WidgetMorphs" - positionInHandCoordinates _ -30 @ -10. - grabbed isInWorld ifTrue: [ - grabbed displayBounds ifNotNil: [ :r | - positionInHandCoordinates _ (r extent // 2) negated ]]. - self - grabMorph: grabbed - delta: positionInHandCoordinates. - ^self ]. - - positionInHandCoordinates _ (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) - morphPositionInWorld - self morphPositionInWorld. - - tx _ GeometryTransformation identity. - grabbed withAllOwnersDo: [ :o | - tx _ o location composedWith: tx ]. - self withAllOwnersReverseDo: [ :o | - tx _ o location inverseTransformation composedWith: tx ]. - - self - grabMorph: grabbed - delta: positionInHandCoordinates. - - grabbed location: tx.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4583-MorphGrabFix-JuanVuletich-2021May03-10h59m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4583] on 3 May 2021 at 5:40:42 pm'! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 5/3/2021 17:39:58' prior: 50569367! - grabMorph: aMorph moveUnderHand: moveUnderHand - "Grab the given morph (i.e., add it to this hand and remove it from its current owner). - If moveUnderHand is requested or it seems neccesary anyway, move the grabbed morph under the hand." - - | grabbed positionInHandCoordinates tx | - self releaseMouseFocus. "Break focus" - grabbed _ aMorph. - aMorph owner ifNotNil: [ :o | grabbed _ o aboutToGrab: aMorph ]. - grabbed ifNil: [ ^ self ]. - grabbed _ grabbed aboutToBeGrabbedBy: self. - grabbed ifNil: [ ^ self ]. - - moveUnderHand - ifTrue: [ - "We can possibly do better, especially for non WidgetMorphs" - positionInHandCoordinates _ -30 @ -10. - grabbed isInWorld ifTrue: [ - grabbed displayBounds ifNotNil: [ :r | - positionInHandCoordinates _ (r extent // 2) negated ]]. - self - grabMorph: grabbed - delta: positionInHandCoordinates. - ^self ]. - - positionInHandCoordinates _ (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) - morphPositionInWorld - self morphPositionInWorld. - - tx _ GeometryTransformation identity. - (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) withAllOwnersDo: [ :o | - tx _ o location composedWith: tx ]. - self withAllOwnersReverseDo: [ :o | - tx _ o location inverseTransformation composedWith: tx ]. - self - grabMorph: grabbed - delta: positionInHandCoordinates. - - grabbed location: tx.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4584-MorphGrabFix-retry-JuanVuletich-2021May03-17h36m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4581] on 1 May 2021 at 7:42:39 pm'! -!Morph methodsFor: 'structure' stamp: 'jmv 5/1/2021 19:34:50'! -topmostWorld - "Answer the last morph in the owner chain (i.e. the morph without owner) if it is a WorldMorph, or nil." - ^owner - ifNotNil: [ owner topmostWorld ]! ! -!WorldMorph methodsFor: 'structure' stamp: 'jmv 5/1/2021 19:34:53' overrides: 50569469! - topmostWorld - "Answer the last morph in the owner chain (i.e. the morph without owner) if it is a WorldMorph, or nil." - owner - ifNotNil: [ ^owner topmostWorld ]. - ^self! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 5/1/2021 19:41:56' prior: 50562527! - containsGlobalPoint: worldPoint - - self visible ifTrue: [ - self topmostWorld ifNotNil: [ :w | - w canvas ifNotNil: [ :canvas | - ^ canvas morph: self isAtPoint: worldPoint ]]]. - ^ false! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 5/1/2021 19:40:01' prior: 50562539! - fullContainsGlobalPoint: worldPoint - "Answer true if worldPoint is in some submorph, even if not inside our shape." - - self visible ifTrue: [ - self topmostWorld ifNotNil: [ :w | - w canvas ifNotNil: [ :canvas | - (canvas morph: self isAtPoint: worldPoint) ifTrue: [ ^ true ]. - self submorphsDo: [ :m | - (m fullContainsGlobalPoint: worldPoint) ifTrue: [ ^ true ]]]]]. - ^ false! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4585-containsGlobalPoint-fix-JuanVuletich-2021May01-19h39m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4585] on 5 May 2021 at 3:29:14 pm'! - -TextModelMorph subclass: #BrowserCommentTextMorph - instanceVariableNames: 'separator proportionalHeight code ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #BrowserCommentTextMorph category: 'Morphic-Widgets' stamp: 'Install-4586-BrowserCommentAdjusterFix-JuanVuletich-2021May05-15h12m-jmv.001.cs.st 5/20/2021 10:28:57'! -TextModelMorph subclass: #BrowserCommentTextMorph - instanceVariableNames: 'separator proportionalHeight code' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! -!BrowserCommentTextMorph methodsFor: 'accessing' stamp: 'jmv 5/5/2021 14:56:15'! - separator: adjusterMorph code: codeMorph - separator _ adjusterMorph. - code _ codeMorph.! ! -!BrowserCommentTextMorph methodsFor: 'displaying' stamp: 'jmv 5/5/2021 15:06:08' prior: 50522123! - hidePane - - self hide. - separator visible ifTrue: [ - proportionalHeight _ self layoutSpec proportionalLayoutHeight ]. - separator layoutSpec fixedHeight: 0. - self layoutSpec proportionalHeight: 0. - code layoutSpec proportionalHeight: 1.0. - separator ifNotNil: [ separator hide ]! ! -!BrowserCommentTextMorph methodsFor: 'displaying' stamp: 'jmv 5/5/2021 15:03:35' prior: 50522134! - showPane - - self show. - proportionalHeight ifNotNil: [ - self layoutSpec proportionalHeight: proportionalHeight. - code layoutSpec proportionalHeight: 1.0 - proportionalHeight ]. - separator ifNotNil: [ - separator layoutSpec fixedHeight: Theme current layoutAdjusterThickness. - separator show ]! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'jmv 5/5/2021 14:59:00' prior: 50522145 overrides: 50518659! - buildLowerPanes - | codeAndButtons codeButtonsAndAnnotations code comment separator | - code _ self buildMorphicCodePane. - comment _ self buildMorphicCommentPane. - separator _ LayoutAdjustingMorph new. - comment separator: separator code: code. - codeAndButtons _ LayoutMorph newColumn. - Preferences optionalButtons ifTrue: [ - codeAndButtons - addMorph: self optionalButtonRow fixedHeight: self defaultButtonPaneHeight; - addAdjusterMorph ]. - codeAndButtons - addMorph: code proportionalHeight: 0.5; - addMorph: separator fixedHeight: Theme current layoutAdjusterThickness; - addMorph: comment proportionalHeight: 0.5. - Preferences showAnnotations ifFalse: [ - ^codeAndButtons ]. - codeButtonsAndAnnotations _ LayoutMorph newColumn. - codeButtonsAndAnnotations - addMorph: self buildMorphicAnnotationsPane fixedHeight: self defaultAnnotationPaneHeight; - addAdjusterMorph; - addMorph: codeAndButtons proportionalHeight: 1.0. - ^codeButtonsAndAnnotations! ! - -BrowserCommentTextMorph removeSelector: #separator:! - -!methodRemoval: BrowserCommentTextMorph #separator: stamp: 'Install-4586-BrowserCommentAdjusterFix-JuanVuletich-2021May05-15h12m-jmv.001.cs.st 5/20/2021 10:28:57'! -separator: aMorph - separator _ aMorph! - -TextModelMorph subclass: #BrowserCommentTextMorph - instanceVariableNames: 'separator code proportionalHeight' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #BrowserCommentTextMorph category: 'Morphic-Widgets' stamp: 'Install-4586-BrowserCommentAdjusterFix-JuanVuletich-2021May05-15h12m-jmv.001.cs.st 5/20/2021 10:28:57'! -TextModelMorph subclass: #BrowserCommentTextMorph - instanceVariableNames: 'separator code proportionalHeight' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4586-BrowserCommentAdjusterFix-JuanVuletich-2021May05-15h12m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4586] on 5 May 2021 at 3:49:52 pm'! -!LayoutAdjustingMorph methodsFor: 'stepping' stamp: 'jmv 5/5/2021 15:46:30' prior: 50562613 overrides: 50547624! - stepAt: millisecondSinceLast - "got the #mouseLeave: message" - | p | - hand ifNil: [ - Cursor currentCursor == self cursor ifTrue: [ Cursor defaultCursor activateCursor ]. - ^ self stopStepping ]. - "hasn't got the #mouseLeave: message (yet)" - p _ hand morphPosition. - hand lastMouseEvent mouseButton1Pressed - ifTrue: [ - self adjustOwnerAt: p. - (Preferences cheapWindowReframe or: [ millisecondSinceLast > 200]) ifTrue: [ - owner displayBounds newRectFrom: [ :f | - self adjustOwnerAt: Sensor mousePoint. - owner morphPosition extent: owner morphExtent ]]] - ifFalse: [ - self stopStepping. - hand _ nil. - Cursor defaultCursor activateCursor ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4587-ReturnToDefaultCursor-JuanVuletich-2021May05-15h48m-jmv.001.cs.st----! - -'From Haver 5.0 [latest update: #4587] on 6 May 2021 at 3:57:03 pm'! -!MenuMorph methodsFor: 'construction' stamp: 'KLG 5/6/2021 15:45:51' prior: 50547958! - addTitle: aString - "Add a title line at the top of this menu Make aString its initial - contents. - If aSelector is not nil, then periodically obtain fresh values for its - contents by sending aSelector to aTarget.." - - | s pp w newMorph | - - newMorph _ WidgetMorph new noBorder. - newMorph color: Theme current menuTitleBar. - pp _ `8@2`. - aString asString linesDo: [ :line | - s _ LabelMorph new - contents: line; - font: Preferences standardMenuFont bold. - newMorph addMorphBack: s position: pp. - pp _ pp + (0@(s morphHeight+2)) ]. - w _ newMorph submorphs inject: 0 into: [ :prev :each | - prev max: each morphWidth ]. - newMorph morphExtent: (w + 16) @ (pp y). - titleMorph - ifNil: [ - titleMorph _ newMorph. - self addMorphFront: titleMorph ] - ifNotNil: [ self addMorphBack: newMorph ]. - - (self hasProperty: #needsStayUpIcons) ifTrue: [ self addStayUpIcons ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4588-AllowSubtitlesInMenus-GeraldKlix-2021May06-13h10m-KLG.001.cs.st----! - -'From Haver 5.0 [latest update: #4587] on 6 May 2021 at 4:36:32 pm'! -!MenuMorph methodsFor: 'construction' stamp: 'KLG 5/6/2021 16:35:55' prior: 50569664! - addTitle: aString - "Add a title line at the top of this menu Make aString its initial - contents. - If aSelector is not nil, then periodically obtain fresh values for its - contents by sending aSelector to aTarget.." - - | s pp w newMorph | - - newMorph _ WidgetMorph new noBorder. - newMorph color: Theme current menuTitleBar. - pp _ `8@2`. - aString asString linesDo: [ :line | | font | - font _ Preferences standardMenuFont. - s _ LabelMorph new - contents: line; - font: (titleMorph - ifNil: [ font bold ] - ifNotNil: [ font italic ]).. - newMorph addMorphBack: s position: pp. - pp _ pp + (0@(s morphHeight+2)) ]. - w _ newMorph submorphs inject: 0 into: [ :prev :each | - prev max: each morphWidth ]. - newMorph morphExtent: (w + 16) @ (pp y). - titleMorph - ifNil: [ - titleMorph _ newMorph. - self addMorphFront: titleMorph ] - ifNotNil: [ self addMorphBack: newMorph ]. - - (self hasProperty: #needsStayUpIcons) ifTrue: [ self addStayUpIcons ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4589-NicerSubtitlesInMenus-GeraldKlix-2021May06-15h57m-KLG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4589] on 10 May 2021 at 12:24:06 pm'! -!BrowserCommentTextMorph methodsFor: 'displaying' stamp: 'jmv 5/10/2021 12:20:29' prior: 50569541! - hidePane - - self hide. - separator visible ifTrue: [ - proportionalHeight _ self layoutSpec proportionalLayoutHeight ]. - separator layoutSpec fixedHeight: 0. - self layoutSpec proportionalHeight: 0. - code layoutSpec proportionalHeight: 1.0. - separator hide.! ! -!BrowserCommentTextMorph methodsFor: 'displaying' stamp: 'jmv 5/10/2021 12:20:45' prior: 50569553! - showPane - - self show. - proportionalHeight ifNotNil: [ - self layoutSpec proportionalHeight: proportionalHeight. - code layoutSpec proportionalHeight: 1.0 - proportionalHeight ]. - separator layoutSpec fixedHeight: Theme current layoutAdjusterThickness. - separator show! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4590-BrowserCommentTextMorph-tweaks-JuanVuletich-2021May10-12h20m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4589] on 10 May 2021 at 12:33:22 pm'! -!MorphicCanvas methodsFor: 'drawing-ovals' stamp: 'jmv 5/10/2021 10:54:20'! - ellipseCenter: center radius: radiusPointOrNumber borderWidth: mbw borderColor: mbc fillColor: morphFillColor - self subclassResponsibility ! ! -!BitBltCanvas methodsFor: 'drawing-ovals' stamp: 'jmv 5/10/2021 10:53:57' overrides: 50569774! - ellipseCenter: center radius: radiusPointOrNumber borderWidth: mbw borderColor: mbc fillColor: morphFillColor - - | displayRectangle doBorder doFill | - - engine ifNil: [ ^nil ]. - - doBorder _ mbw > 0 and: [ mbc isTransparent not]. - doFill _ morphFillColor isTransparent not. - doBorder | doFill ifTrue: [ - displayRectangle _ (currentTransformation externalizeRectangle: (Rectangle center: center extent: radiusPointOrNumber asPoint * 2)) rounded. - "draw the border of the oval" - doBorder ifTrue: [ - self setPaintColor: mbc. - engine frameOval: displayRectangle borderWidth: mbw rounded]. - "fill the inside" - doFill ifTrue: [ - self setPaintColor: morphFillColor. - engine fillOval: (displayRectangle insetBy: mbw rounded) ]]! ! -!MorphicCanvas methodsFor: 'drawing-ovals' stamp: 'jmv 5/10/2021 12:32:42' prior: 50463440! - ellipseCenterX: mcx y: mcy rx: mrx ry: mry borderWidth: mbw borderColor: mbc fillColor: morphFillColor - "Prefer #ellipseCenter:radius:borderWidth:borderColor:fillColor:" - - self ellipseCenter: mcx@mcy radius: mrx@mry borderWidth: mbw borderColor: mbc fillColor: morphFillColor! ! - -BitBltCanvas removeSelector: #ellipseCenterX:y:rx:ry:borderWidth:borderColor:fillColor:! - -!methodRemoval: BitBltCanvas #ellipseCenterX:y:rx:ry:borderWidth:borderColor:fillColor: stamp: 'Install-4591-PreferPointOrientedProtocol-JuanVuletich-2021May10-12h30m-jmv.001.cs.st 5/20/2021 10:28:58'! -ellipseCenterX: mcx y: mcy rx: mrx ry: mry borderWidth: mbw borderColor: mbc fillColor: morphFillColor - - | displayRectangle doBorder doFill | - - engine ifNil: [ ^nil ]. - - doBorder _ mbw > 0 and: [ mbc isTransparent not]. - doFill _ morphFillColor isTransparent not. - doBorder | doFill ifTrue: [ - displayRectangle _ (currentTransformation externalizeRectangle: (Rectangle center: mcx@mcy extent: mrx@mry * 2)) rounded. - "draw the border of the oval" - doBorder ifTrue: [ - self setPaintColor: mbc. - engine frameOval: displayRectangle borderWidth: mbw rounded]. - "fill the inside" - doFill ifTrue: [ - self setPaintColor: morphFillColor. - engine fillOval: (displayRectangle insetBy: mbw rounded) ]]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4591-PreferPointOrientedProtocol-JuanVuletich-2021May10-12h30m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4589] on 10 May 2021 at 1:55:42 pm'! -!KernelMorph commentStamp: '' prior: 50532125! - Hierarchy for morphs that are rectangle like, and that occupy an area that can be specified as a Rectangle. This means that, besides being of rectangular shape, sides are aligned with local coordinate axes. Including rectangles with rounded corners and such. The idea is that the 'extent' ivar is all that's needed to establish our dimensions and shape. Subclasses can add things like 'roundedCornerRadius' or such.! -!WidgetMorph commentStamp: '' prior: 50548069! - Hierarchy for morphs that are rectangle like, and that occupy an area that can be specified as a Rectangle. This means that, besides being of rectangular shape, sides are aligned with local coordinate axes. Including rectangles with rounded corners and such. The idea is that the 'extent' ivar is all that's needed to establish our dimensions and shape. Instances may have a border, see instanceVariables borderWidth and borderColor. Subclasses can use a variety of border styles: simple, inset, raised -Subclasses can add things like 'roundedCornerRadius' or such.! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 5/10/2021 13:29:02' prior: 50539209 overrides: 50539190! - addPossiblyUncoveredAreasIn: aRectangle to: aCollection - "Answer an array of rectangles encompassing those areas in aRectangle not completely - covered by self. These are the areas that might require further drawing (of morphs below us) - All areas that might possibly be uncovered must be included." - | bounds radius | - color mightBeTranslucent ifTrue: [ - aCollection add: aRectangle. - ^self ]. - - bounds _ self displayBounds. - bounds ifNil: [ - aCollection add: aRectangle. - ^self ]. - - "Solid rectangle. - This will be the fastest in many cases. So, please disable rounded corners if on slow hardware!!" - Theme current roundWindowCorners ifFalse: [ - aRectangle areasOutside: bounds do: [ :rect | aCollection add: rect ]. - ^self ]. - - "The solid rectangle does not include the corners. - Report a couple of rows (top and bottom) or columns (left and right) as uncovered areas. - We could also try to be more careful and answer each rounded corner... - Right now, report top and bottom rows as uncovered areas" - radius _ Theme current roundedWindowRadius. - aRectangle areasOutside: (bounds insetBy: 0@radius) do: [ :rect | aCollection add: rect ]! ! -!BitBltCanvas methodsFor: 'drawing-roundedRectangles' stamp: 'jmv 5/10/2021 13:27:52' prior: 50532972 overrides: 50463492! - roundRect: aRectangle color: aColor radius: r - " - Display getCanvas roundRect: (10@10 extent: 200@100) color: Color red radius: 10 - " - - engine ifNil: [ ^nil ]. - - "radius is not scaled properly..." - "top stripe" - self - image: (self class topLeftCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle topLeft. - self - image: (self class topRightCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle topRight - (r@0). - self fillRectangle: ((aRectangle withHeight: r) insetBy: r@0) color: aColor. - - "center stripe" - self fillRectangle: (aRectangle insetBy: (0 @ r corner: 0 @ r)) color: aColor. - - "bottom stripe" - self - image: (self class bottomLeftCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle bottomLeft - (0@r). - self - image: (self class bottomRightCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle bottomRight - (r@r) . - self fillRectangle: ((aRectangle bottomLeft + (r@r negated)) extent: (aRectangle width - r - r@r)) color: aColor! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4592-fixAFewTypos-JuanVuletich-2021May10-12h33m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4589] on 10 May 2021 at 2:22:25 pm'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 5/10/2021 14:22:14' prior: 50567941! - updateCurrentDisplayBoundsAndMerge: aRectangle - "Update displayBounds for if never set. - Useful for new morph, that are created and attached to the hand." - - | isKnownFailing r | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph drawOn: self ]. - currentMorph displayBoundsSetFrom: self. - r _ self boundingRectOfCurrentMorphAfterDraw. - r _ r quickMerge: aRectangle. - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | - r _ self updateDisplayBounds: m andMerge: r ]]. - ^r! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4593-MorphicDrawFix-JuanVuletich-2021May10-14h22m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4593] on 10 May 2021 at 3:29:06 pm'! -!Mutex methodsFor: 'mutual exclusion' stamp: 'jmv 5/10/2021 15:26:17'! - releaseIfOwnerNotReadyToRun - "If process owning us is not ready to run, release. - This means that the critical section might be already running, and suspended or blocked, for example, because of an open Debugger. - If so, critical section will be reentered for next requester without any wait. - Use with care!! - " - (owner notNil and: [ owner isReady not ]) - ifTrue: [ - owner _ nil. - semaphore _ Semaphore forMutualExclusion ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4594-Mutex-releaseIfOwnerNotReadyToRun-JuanVuletich-2021May10-15h28m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4594] on 11 May 2021 at 10:28:42 am'! -!AffineTransformation class methodsFor: 'instance creation' stamp: 'jmv 5/11/2021 09:51:57'! - withScale: aNumber position: otherPoint - " - (AffineTransformation withScale: 4 position: 0.2@0.7) transform: 1@1 - " - ^self new - setPointScale: aNumber@aNumber; - setTranslation: otherPoint! ! -!AffineTransformation class methodsFor: 'instance creation' stamp: 'jmv 5/11/2021 09:51:35' prior: 50497890! - withPointScale: aPoint position: otherPoint - " - (AffineTransformation withPointScale: 4@3 position: 0.2@0.7) transform: 1@1 - " - ^self new - setPointScale: aPoint; - setTranslation: otherPoint! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4595-AffineTransformationTweaks-JuanVuletich-2021May11-09h51m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4595] on 12 May 2021 at 1:06:30 pm'! -!MorphicCanvas methodsFor: 'initialization' stamp: 'jmv 5/12/2021 11:10:35' prior: 50407966! - initializeWith: aForm origin: aPoint - self initialize. - self setForm: aForm. - - "Set up these only on initialization. - This is safe (wrt walkbacks during world redraw) because a new instance is created - on draw error. See #displayWorldSafely" - currentTransformation _ MorphicTranslation withTranslation: aPoint. - cti _ 1. - transformations - ifNil: [ transformations _ OrderedCollection with: currentTransformation ] - ifNotNil: [ transformations at: cti put: currentTransformation ]. - drawingMorphStack - ifNil: [ drawingMorphStack _ OrderedCollection with: nil ] - ifNotNil: [ drawingMorphStack at: cti put: nil ].! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 5/12/2021 11:11:22' prior: 50554751! -into: aMorph - | locationOrNil previousLast | - locationOrNil _ aMorph location. - currentMorph _ aMorph. - cti _ cti + 1. - transformations size < cti - ifTrue: [ - drawingMorphStack add: aMorph. - currentTransformation _ locationOrNil - ifNotNil: [ currentTransformation composedWith: locationOrNil] - ifNil: [ currentTransformation copy ]. - transformations add: currentTransformation ] - ifFalse: [ - drawingMorphStack at: cti put: aMorph. - previousLast _ currentTransformation. - locationOrNil - ifNil: [ - currentTransformation _ previousLast copy. - transformations at: cti put: currentTransformation ] - ifNotNil: [ :location | - currentTransformation _ transformations at: cti. - "reuse the instance if possible" - (previousLast class == location class and: [ previousLast class == currentTransformation class ]) - ifTrue: [ - previousLast composedWith: location into: currentTransformation ] - ifFalse: [ - currentTransformation _ previousLast composedWith: location. - transformations at: cti put: currentTransformation ] - ] - ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4596-CommentsTweaks-JuanVuletich-2021May12-13h06m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4596] on 13 May 2021 at 6:24:06 pm'! -!Float32Array commentStamp: 'jmv 5/13/2021 17:12:39' prior: 50542420! - Float32rrays store 32bit IEEE floating point numbers, i.e. what usually called float in the C world. - -A possible way to create literal Float32Arrays is by using backticks: -`#[ 1.0 2.0 3.0 ] asFloat32Array`! -!Float64Array commentStamp: 'jmv 5/13/2021 17:11:37' prior: 50542104! - Float64Arrays store 64bit IEEE floating point numbers, i.e. instances of the Float class. -Some support is included for subclasses in the style of Balloon3D-Math. - -Uses the same internal representation as Float. I.e. a Float and a Float64Array of size 1 hold the same bits. See #floatAt: and #floatAt:put: - -Can be created as literals like: -#[ 1.0 2.0 3.0 ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4597-FloatArray-comments-JuanVuletich-2021May13-18h23m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4597] on 16 May 2021 at 10:08:16 am'! -!Inspector methodsFor: 'user interface support' stamp: 'jmv 5/14/2021 11:38:18' prior: 50516531! - displayLabel - - | label | - object isObject ifFalse: [^ 'Inspect: ', self objectClass name]. - label := [object printStringLimitedTo: 64] - on: UnhandledError - do: [:ex | ex return: self objectClass printString, ' (printing failed)']. - "Note this is ambiguous: what happens with (Array with: Array)?" - (label includesSubString: self objectClass name) ifTrue: [^'Inspect: ', label]. - ^ 'Inspect: ', self objectClass name, ': ', label! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4598-InspectorLabelTweak-JuanVuletich-2021May16-10h07m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4597] on 16 May 2021 at 10:17:29 am'! -!Morph methodsFor: 'geometry' stamp: 'jmv 5/16/2021 10:16:34' prior: 50567742! - adjustDisplayBoundsBy: delta - "Private for framework use. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us." - - privateDisplayBounds ifNotNil: [ - privateDisplayBounds _ privateDisplayBounds translatedBy: delta ]. - self allMorphsDo: [ :m | m adjustDisplayBoundsBy: delta ].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 5/16/2021 10:16:38' prior: 50567792! - displayBounds - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us." - - self visible ifFalse: [ ^nil ]. - ^ privateDisplayBounds! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 5/16/2021 10:16:42' prior: 50567757! - displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us." - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphAfterDraw ]]].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 5/16/2021 10:16:46' prior: 50568026! - displayBoundsUpdateFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us." - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - privateDisplayBounds _ privateDisplayBounds - quickMerge: aCanvas boundingRectOfCurrentMorphAfterDraw ]]].! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 5/14/2021 11:44:08' prior: 50501541! - textComposition: aTextComposition bounds: boundsRect color: c selectionColor: sc - | displayScanner leftInRun line possibleVisibleLocalRect textTopLeft | - - textTopLeft _ boundsRect topLeft. - possibleVisibleLocalRect _ currentTransformation boundsOfInverseTransformOf: self clipRect. - - displayScanner _ MorphicScanner new - defaultFont: aTextComposition defaultFont; - text: aTextComposition textComposed - foreground: c. - displayScanner canvas: self. - - leftInRun _ 0. - "Take clipRect into account. Extrememly fast scrolls and redraws of huge files (like .sources)" - (aTextComposition lineIndexForPoint: (possibleVisibleLocalRect topLeft - textTopLeft max: `0@0`) ) - to: (aTextComposition lineIndexForPoint: possibleVisibleLocalRect bottomRight - textTopLeft) - do: [ :i | - line _ aTextComposition lines at: i. - aTextComposition - displaySelectionInLine: line - on: self - textTopLeft: textTopLeft - selectionColor: sc. - leftInRun _ displayScanner displayLine: line textTopLeft: textTopLeft leftInRun: leftInRun ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4599-Comments-JuanVuletich-2021May16-10h08m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4597] on 15 May 2021 at 8:27:04 pm'! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 5/15/2021 19:44:30' prior: 50566326! - restoreSavedPatchOn: aCanvas - "Clear the changed flag and restore the part of the given canvas under this hand from the previously saved patch. If necessary, handle the transition to using the hardware cursor." - - self needsRedraw: false. - prevFullBounds ifNotNil: [ - aCanvas restorePatch: savedPatch bounds: prevFullBounds. - submorphs notEmpty ifTrue: [ ^ self ]. - "Make the transition to using hardware cursor. Clear savedPatch and - report one final damage rectangle to erase the image of the software cursor." - " owner invalidateDisplayRect: (savedPatch offset extent: savedPatch extent) from: nil." - self invalidateDisplayRect: (self morphPosition extent: extent) for: nil. - Cursor currentCursor == Cursor defaultCursor ifFalse: [ Cursor defaultCursor activateCursor ]. - "show hardware cursor" - prevFullBounds _ nil ].! ! -!WorldMorph methodsFor: 'hands' stamp: 'jmv 5/15/2021 20:26:17' prior: 50551518! - selectHandsToDrawForDamage: damageList - "Select the set of hands that must be redrawn because either (a) the hand itself has changed or (b) the hand intersects some damage rectangle." - - | result | - result _ OrderedCollection new. - hands do: [:hand | - hand needsToBeDrawn ifTrue: [ - hand isRedrawNeeded - ifTrue: [result add: hand] - ifFalse: [ - hand displayFullBounds ifNotNil: [ :handBounds | - (damageList anySatisfy: [ :r | r intersects: handBounds]) ifTrue: [ - result add: hand]]]]]. - ^ result! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 5/15/2021 20:26:07' prior: 50551673! - checkIfUpdateNeeded - - damageRecorder updateIsNeeded ifTrue: [^true]. - hands do: [:h | (h isRedrawNeeded and: [h needsToBeDrawn]) ifTrue: [^true]]. - ^false "display is already up-to-date" -! ! - -HandMorph removeSelector: #hasChanged! - -!methodRemoval: HandMorph #hasChanged stamp: 'Install-4600-HandMorphCleanup-JuanVuletich-2021May15-20h25m-jmv.001.cs.st 5/20/2021 10:28:58'! -hasChanged - "Return true if this hand has changed, either because it has moved or because some morph it is holding has changed." - - ^ hasChanged ifNil: [ true ] -! - -HandMorph removeSelector: #redrawNeeded! - -!methodRemoval: HandMorph #redrawNeeded stamp: 'Install-4600-HandMorphCleanup-JuanVuletich-2021May15-20h25m-jmv.001.cs.st 5/20/2021 10:28:58'! -redrawNeeded - - hasChanged _ true! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4600-HandMorphCleanup-JuanVuletich-2021May15-20h25m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4597] on 15 May 2021 at 8:32:28 pm'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 5/15/2021 18:45:04' prior: 50567869! - fullUpdateCurrentBounds - | isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph drawOn: self. - currentMorph postDrawOn: self. ]. - currentMorph displayBoundsSetFrom: self. - isKnownFailing ifFalse: [ - currentMorph submorphsDo: [ :m | - self fullUpdateBounds: m ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4601-UpdateBoundsFix-JuanVuletich-2021May15-20h27m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4601] on 16 May 2021 at 10:30:50 am'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 5/15/2021 20:34:13' prior: 50570369! - fullUpdateCurrentBounds - | isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph drawOn: self. - currentMorph postDrawOn: self ]. - currentMorph displayBoundsSetFrom: self. - isKnownFailing ifFalse: [ - currentMorph submorphsDo: [ :m | - self fullUpdateBounds: m ]]! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 5/15/2021 20:46:17' prior: 50567971! - updateHandsDisplayBounds: aWorldMorph - "Update displayBounds for carried morphs if never set. - Useful for new morph, that are created and attached to the hand." - - aWorldMorph handsDo: [ :hand | - hand hasSubmorphs ifTrue: [ - self into: hand. - hand submorphsDo: [ :morph | - morph displayBounds ifNil: [ - self fullUpdateBounds: morph ]]. - self outOfMorph ]]! ! - -MorphicCanvas removeSelector: #updateCurrentDisplayBoundsAndMerge:! - -!methodRemoval: MorphicCanvas #updateCurrentDisplayBoundsAndMerge: stamp: 'Install-4602-Cleanup-JuanVuletich-2021May16-10h27m-jmv.001.cs.st 5/20/2021 10:28:58'! -updateCurrentDisplayBoundsAndMerge: aRectangle - "Update displayBounds for if never set. - Useful for new morph, that are created and attached to the hand." - - | isKnownFailing r | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph drawOn: self ]. - currentMorph displayBoundsSetFrom: self. - r _ self boundingRectOfCurrentMorphAfterDraw. - r _ r quickMerge: aRectangle. - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | - r _ self updateDisplayBounds: m andMerge: r ]]. - ^r! - -MorphicCanvas removeSelector: #updateDisplayBounds:andMerge:! - -!methodRemoval: MorphicCanvas #updateDisplayBounds:andMerge: stamp: 'Install-4602-Cleanup-JuanVuletich-2021May16-10h27m-jmv.001.cs.st 5/20/2021 10:28:58'! -updateDisplayBounds: aMorph andMerge: aRectangle - "Update displayBounds for if never set. - Useful for new morph, that are created and attached to the hand." - - | r | - r _ aRectangle. - aMorph visible ifTrue: [ - self into: aMorph. - r _ self canvasToUse updateCurrentDisplayBoundsAndMerge: r. - self outOfMorph - ]. - ^r! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4602-Cleanup-JuanVuletich-2021May16-10h27m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4601] on 16 May 2021 at 10:56:12 am'! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 5/15/2021 22:25:32'! - boundingRectOfCurrentMorphFromLocalBounds - "In targetForm coordinates. - Clipped to owner if appropriate." - - | boundingRect | - boundingRect _ currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds. - ^ clippingMorphDisplayBounds - ifNotNil: [ :ownerClips | boundingRect intersect: ownerClips ] - ifNil: [ boundingRect ]! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 5/16/2021 10:54:52' prior: 50570208! - displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - aRectangle is clipped appropiately if some owner clips us." - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - privateDisplayBounds _ self isOrthoRectangularMorph - ifTrue: [ - "In these cases, #drawOn: might not be able to find bounds (InnerTextMorph, for example), - but it is OK to compute them from #morphLocalBounds. This is not true for non-orthoRectangular morphs!!" - aCanvas boundingRectOfCurrentMorphFromLocalBounds] - ifFalse: [aCanvas boundingRectOfCurrentMorphAfterDraw]]]].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 5/16/2021 10:54:57' prior: 50570391! - fullUpdateCurrentBounds - - | isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph isOrthoRectangularMorph ifFalse: [ - "In these cases, #drawOn: is required to find bounds. - #displayBoundsSetFrom: will use the bounds found by us in these case. - See #displayBoundsSetFrom:" - currentMorph drawOn: self. - currentMorph postDrawOn: self ]. - currentMorph displayBoundsSetFrom: self. - currentMorph submorphsDo: [ :m | - self fullUpdateBounds: m ]]! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 5/16/2021 10:41:36' prior: 50536557 overrides: 50536534! - boundingRectOfCurrentMorphAfterDraw - "In targetForm coordinates. - Clipped to owner if appropriate. - BitBltCanvas doesn't keep track of Morph bounds as it draws them. But it is limited to drawing bounds where - #morphLocalBounds is known. Use it, then." - - | boundingRect | - boundingRect _ currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds. - ^ clippingMorphDisplayBounds - ifNotNil: [ :ownerClips | boundingRect intersect: ownerClips ] - ifNil: [ boundingRect ]! ! - -BitBltCanvas removeSelector: #boundingRectOfCurrentMorph! - -!methodRemoval: BitBltCanvas #boundingRectOfCurrentMorph stamp: 'Install-4603-BoundsUpdatesFixes-JuanVuletich-2021May16-10h30m-jmv.001.cs.st 5/20/2021 10:28:58'! -boundingRectOfCurrentMorph - "In targetForm coordinates. - Answer morph bounds, ignoring possible clipping by owner." - - ^currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4603-BoundsUpdatesFixes-JuanVuletich-2021May16-10h30m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4603] on 18 May 2021 at 5:32:21 pm'! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 5/18/2021 17:27:09' overrides: 50418010! - rounded - "Answer the integer nearest the receiver." - "See https://en.wikipedia.org/wiki/Rounding#Round_half_to_even" - - | truncated fractionPart | - truncated _ self truncated. - fractionPart _ self - truncated. - (fractionPart > -0.5 and: [fractionPart < 0.5]) - ifTrue: [^truncated]. - fractionPart > 0.5 - ifTrue: [ ^truncated + 1 ]. - fractionPart < -0.5 - ifTrue: [ ^truncated - 1 ]. - truncated even ifTrue: [^truncated]. - self > 0 - ifTrue: [ ^truncated + 1 ] - ifFalse: [ ^truncated - 1 ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4604-FastFloatRounded-JuanVuletich-2021May18-17h14m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4603] on 18 May 2021 at 2:37:49 pm'! -!BitBlt methodsFor: 'copying' stamp: 'jmv 5/18/2021 14:37:40' prior: 16785666! - copyBits - "Primitive. Perform the movement of bits from the source form to the - destination form. Fail if any variables are not of the right type (Integer, - Float, or Form) or if the combination rule is not implemented. - In addition to the original 16 combination rules, this BitBlt supports - 16 fail (to simulate paint) - 17 fail (to simulate mask) - 18 sourceWord + destinationWord - 19 sourceWord - destinationWord - 20 rgbAdd: sourceWord with: destinationWord - 21 rgbSub: sourceWord with: destinationWord - 22 rgbDiff: sourceWord with: destinationWord - 23 tallyIntoMap: destinationWord - 24 alphaBlend: sourceWord with: destinationWord - 25 pixPaint: sourceWord with: destinationWord - 26 pixMask: sourceWord with: destinationWord - 27 rgbMax: sourceWord with: destinationWord - 28 rgbMin: sourceWord with: destinationWord - 29 rgbMin: sourceWord bitInvert32 with: destinationWord -" - - - "No alpha specified -- re-run with alpha = 1.0" - (combinationRule >= 30 and: [combinationRule <= 31]) ifTrue: [ - ^ self copyBitsTranslucent: 255]. - - "Check for unimplmented rules" - combinationRule = Form oldPaint ifTrue: [^ self oldPaintBits]. - combinationRule = Form oldErase1bitShape ifTrue: [^ self oldErase1bitShapeBits]. - - "Check if BitBlt doesn't support full color maps" - (colorMap notNil and:[colorMap isColormap]) ifTrue:[ - colorMap _ colorMap colors. - ^self copyBits]. - "Check if clipping gots us way out of range" - self clipRange ifTrue:[self roundVariables. ^self copyBitsAgain]. - - 'Bad BitBlt argument (Maybe a Float or Fraction?); will retry rounding.' print. - "Convert all numeric parameters to integers and try again." - self roundVariables. - ^ self copyBitsAgain! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4605-DontErrorOnBatBitBltArg-JuanVuletich-2021May18-14h34m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4605] on 19 May 2021 at 10:56:14 am'! -!Random class methodsFor: 'services' stamp: 'jmv 5/19/2021 10:19:03'! - next - "Answer a Float in [0.0 .. 1.0) - Random next - " - - ^self withDefaultDo: [ :random | random next ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4606-Random-next-JuanVuletich-2021May19-10h56m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4605] on 19 May 2021 at 5:14:29 pm'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 5/19/2021 17:11:36' prior: 50553010! - drawWorld: aWorldMorph repair: aDamageRecorder - "Redraw the damaged areas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | visibleRootMorphs visibleRootsDamage worldDamage | - "Update #displayBounds for all dirty morphs (marked as such with #redrawNeeded). - Also add the updated bounds to aDamageRecorder, and update bounds of morphs carried by hand." - self updatingMorphBoundsDo: [ - aWorldMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - self updateHandsDisplayBounds: aWorldMorph ]. - - visibleRootMorphs _ aWorldMorph privateSubmorphs select: [ :m | m visible ]. - visibleRootsDamage _ Array new: visibleRootMorphs size. - - worldDamage _ self computeDamage: aWorldMorph repair: aDamageRecorder - rootMorphs: visibleRootMorphs rootMorphsDamage: visibleRootsDamage. - - self drawWorldBackground: aWorldMorph rects: worldDamage. - - self drawWorld: aWorldMorph - rootMorphs: visibleRootMorphs rootMorphsDamage: visibleRootsDamage - allDamage: worldDamage. - - aDamageRecorder reset. - ^ worldDamage! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 5/19/2021 17:10:47' prior: 50559611! - drawWorld: aWorldMorph rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage allDamage: worldDamage - "Redraw the damaged areas. - Draw each morph just once, merging rectanges to be repaired as needed." - - | morph morphDamage | - - "Iterate from back to front." - rootMorphs size to: 1 by: -1 do: [ :i | - morph _ rootMorphs at: i. - morphDamage _ rootMorphsDamage at: i. - morph displayFullBounds ifNotNil: [ :morphFullBounds | - worldDamage do: [ :r | | intersection | - intersection _ r intersect: morphFullBounds. - intersection hasPositiveExtent ifTrue: [ - morphDamage _ intersection quickMerge: morphDamage ]]]. - morphDamage ifNotNil: [ - self newClipRect: morphDamage. - self fullDraw: morph. - worldDamage add: morphDamage ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4607-MorphicWorldDrawFix-JuanVuletich-2021May19-17h13m-jmv.001.cs.st----! - -----SNAPSHOT----(20 May 2021 10:29:02) Cuis5.0-4607-v3.image priorSource: 7567077! - -----STARTUP---- (29 May 2021 17:28:43) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4607-v3.image! - - -'From Haver 5.0 [latest update: #4589] on 8 May 2021 at 3:33:56 pm'! -!Theme methodsFor: 'tool colors' stamp: 'KLG 5/8/2021 15:12:47'! - autoCompleter - "Answer the autocompleter's color for entries." - - ^ self text! ! -!Theme methodsFor: 'tool colors' stamp: 'KLG 5/8/2021 15:26:51'! - autoCompleterDefaultBorderColor - "Answer the auto comleters default border color." - - ^ `Color gray`! ! -!Theme methodsFor: 'tool colors' stamp: 'KLG 5/8/2021 15:09:00'! - autoCompleterMaybeInvalid - "Answer the autocompleter's color for possible invalid entries." - - ^ `Color blue`! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'KLG 5/8/2021 15:10:07' prior: 50433540! - colorOf: entry - - ^(completer isPossibleInvalidEntry: entry) - ifTrue: [ Theme current autoCompleterMaybeInvalid ] - ifFalse: [ Theme current autoCompleter ] - ! ! -!AutoCompleterMorph methodsFor: 'initialization' stamp: 'KLG 5/8/2021 15:27:47' prior: 50388296 overrides: 50545889! - defaultBorderColor - "My default border color. - - Note: My background color is derived from this color." - ^ Theme current autoCompleterDefaultBorderColor ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4608-AutoCompleterThemeSupport-GeraldKlix-2021May08-15h06m-KLG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4608] on 24 May 2021 at 9:47:26 am'! -!WorldMorph methodsFor: 'world state' stamp: 'jmv 5/24/2021 09:45:48'! - haloMorphsDo: aBlock - self handsDo: [ :hand | hand halo ifNotNil: [ :halo | aBlock value: halo ]].! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 5/24/2021 09:44:42' prior: 16875728! - halo - self world ifNotNil: [ :w | - w haloMorphsDo: [ :h | - h target == self ifTrue: [^ h]]]. - ^ nil! ! -!WorldMorph methodsFor: 'world state' stamp: 'jmv 5/24/2021 09:45:30' prior: 50553535! - deleteAllHalos - | c | - c _ OrderedCollection new. - self haloMorphsDo: [ :halo | c add: halo ]. - self removeAllMorphsIn: c! ! - -WorldMorph removeSelector: #haloMorphs! - -!methodRemoval: WorldMorph #haloMorphs stamp: 'Install-4609-HaloSmallRefactor-JuanVuletich-2021May24-09h42m-jmv.001.cs.st 5/29/2021 17:28:47'! -haloMorphs - ^ self hands collect:[:h| h halo] thenSelect:[:halo| halo notNil]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4609-HaloSmallRefactor-JuanVuletich-2021May24-09h42m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4610] on 24 May 2021 at 12:12:48 pm'! -!MethodReference methodsFor: 'comparisons' stamp: 'jmv 5/24/2021 10:02:56' prior: 16873130! - <= anotherMethodReference - - methodSymbol < anotherMethodReference methodSymbol ifTrue: [^true]. - methodSymbol > anotherMethodReference methodSymbol ifTrue: [^false]. - classSymbol < anotherMethodReference classSymbol ifTrue: [^true]. - classSymbol > anotherMethodReference classSymbol ifTrue: [^false]. - classIsMeta == anotherMethodReference classIsMeta ifFalse: [^classIsMeta not]. - ^true! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4610-SortSendersBySelector-JuanVuletich-2021May24-12h12m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4610] on 26 May 2021 at 12:04:38 pm'! -!HaloMorph methodsFor: 'drawing' stamp: 'jmv 5/26/2021 11:17:25'! - drawCoordinateSystemOn: aCanvas - - | x0 x1 y0 y1 c stepX stepY haloTargetTx prevTx | - haloTargetTx _ MorphicTranslation identity. - target allOwnersReverseDo: [ :o | haloTargetTx _ haloTargetTx composedWith: o location ]. - haloTargetTx _ haloTargetTx composedWith: target location. - - x0 _ x1 _ y0 _ y1 _ 0. - target displayFullBounds corners collect: [ :pt | | p | - p _ haloTargetTx inverseTransform: pt . - x0 _ x0 min: p x. - x1 _ x1 max: p x. - y0 _ y0 min: p y. - y1 _ y1 max: p y.]. - x1-x0 < 1000 ifTrue: [ - stepX _ 50. - stepY _ 20 ] - ifFalse: [ - stepX _ 100. - stepY _ 50 ]. - - prevTx _ aCanvas currentTransformation. - aCanvas geometryTransformation: haloTargetTx. - - c _ `Color black alpha: 0.6`. - aCanvas line: x0@0 to: x1@0 width: 2 color: c. - aCanvas line: 0@y0 to: 0@y1 width: 2 color: c. - - (x0 truncateTo: stepX) to: (x1 - stepX truncateTo: stepX) by: stepX do: [ :x | - aCanvas line: x @ -5 to: x @ 5 width: 2 color: c. - aCanvas drawString: x printString atCenterXBaselineY: x @ -10 font: nil color: c ]. - aCanvas drawString: 'x' atCenterX: x1 - 15 @ 0 font: nil color: c. - - (y0 truncateTo: stepY) to: (y1 - stepY truncateTo: stepY) by: stepY do: [ :y | - aCanvas line: -5 @ y to: 5 @ y width: 2 color: c. - aCanvas drawString: y printString, ' ' atWaistRight: -5 @ y font: nil color: c ]. - aCanvas drawString: 'y' atWaistRight: -5 @ (y1 - 20) font: nil color: c. - - aCanvas geometryTransformation: prevTx.! ! -!HaloMorph methodsFor: 'geometry testing' stamp: 'jmv 5/26/2021 09:02:31' overrides: 50569486! - containsGlobalPoint: worldPoint - - self visible ifTrue: [ - self topmostWorld ifNotNil: [ :w | - ^self morphLocalBounds containsPoint: - (self internalizeFromWorld: worldPoint) ]]. - ^ false! ! -!HaloMorph methodsFor: 'geometry testing' stamp: 'jmv 5/26/2021 09:03:21' overrides: 50548091! - requiresVectorCanvas - - target ifNotNil: [ - ^target requiresVectorCanvas ]. - ^false! ! -!MorphicCanvas methodsFor: 'accessing' stamp: 'jmv 5/26/2021 08:44:50'! - geometryTransformation: aGeometryTransformation - "Only used for testing. Usually, transformations are handled as we traverse the Morphs tree." - - currentTransformation _ aGeometryTransformation.! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 5/26/2021 11:00:07'! - drawString: s atCenterXBaselineY: pt font: fontOrNil color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - - | font | - font _ self fontToUse: fontOrNil. - ^self - drawString: s - from: 1 to: s size - atBaseline: pt - ((font widthOfString: s) / 2 @ 0) - font: font color: aColor! ! -!MorphicCanvas methodsFor: 'drawing - Global Coordinates' stamp: 'jmv 5/26/2021 11:25:46'! - frameAndFillGlobalRect: rect fillColor: fillColor borderWidth: borderWidth color: borderColor - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing - Global Coordinates' stamp: 'jmv 5/26/2021 10:15:12'! - frameGlobalRect: rect borderWidth: borderWidth color: borderColor - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing - Global Coordinates' stamp: 'jmv 5/26/2021 09:54:36'! - reverseGlobalRectangleBorder: r borderWidth: borderWidth - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 5/26/2021 11:31:02'! -drawHighlight: aMorph - - aMorph displayBounds ifNotNil: [ :r | - self - frameAndFillGlobalRect: r - fillColor: `Color pink alpha: 0.2` - borderWidth: 4 - color: `Color black` ].! ! -!BitBltCanvas methodsFor: 'drawing - Global Coordinates' stamp: 'jmv 5/26/2021 11:26:23' overrides: 50570940! - frameAndFillGlobalRect: rect fillColor: fillColor borderWidth: borderWidth color: borderColor - " - (BitBltCanvas onForm: Display) - frameAndFillGlobalRect: (10@10 extent: 300@200) - fillColor: Color green - borderWidth: 20 - color: Color red. - Display forceToScreen - " - engine ifNil: [ ^nil ]. - engine - combinationRule: (borderColor isOpaque ifTrue: [Form paint] ifFalse: [Form blend]); - fillColor: borderColor; - frameRect: rect borderWidth: borderWidth; - combinationRule: (fillColor isOpaque ifTrue: [Form paint] ifFalse: [Form blend]); - fillColor: fillColor; - fillRect: (rect insetBy: borderWidth). - ! ! -!BitBltCanvas methodsFor: 'drawing - Global Coordinates' stamp: 'jmv 5/26/2021 10:25:18' overrides: 50570947! - frameGlobalRect: rect borderWidth: borderWidth color: borderColor - " - (BitBltCanvas onForm: Display) - frameGlobalRect: (10@10 extent: 300@200) - borderWidth: 20 - color: Color red. - Display forceToScreen - " - engine ifNil: [ ^nil ]. - engine - combinationRule: (borderColor isOpaque ifTrue: [Form paint] ifFalse: [Form blend]); - fillColor: borderColor; - frameRect: rect borderWidth: borderWidth.! ! -!BitBltCanvas methodsFor: 'drawing - Global Coordinates' stamp: 'jmv 5/26/2021 10:18:16' overrides: 50570953! - reverseGlobalRectangleBorder: rect borderWidth: borderWidth - " - (BitBltCanvas onForm: Display) - reverseGlobalRectangleBorder: (10@10 extent: 300@200) - borderWidth: 20. - Display forceToScreen - " - engine ifNil: [ ^nil ]. - engine - sourceForm: nil; - fillColor: `Color gray`; - combinationRule: Form reverse; - frameRect: rect borderWidth: borderWidth! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 5/25/2021 20:24:49' prior: 50569495! - fullContainsGlobalPoint: worldPoint - "Answer true if worldPoint is in some submorph, even if not inside our shape." - - self visible ifTrue: [ - self topmostWorld ifNotNil: [ :w | - (self containsGlobalPoint: worldPoint) ifTrue: [ ^ true ]. - self submorphsDo: [ :m | - (m fullContainsGlobalPoint: worldPoint) ifTrue: [ ^ true ]]]]. - ^ false! ! -!HaloMorph methodsFor: 'drawing' stamp: 'jmv 5/26/2021 10:43:15' prior: 16850621 overrides: 16899205! - drawOn: aCanvas - - | b | - target ifNil: [^super drawOn: aCanvas]. - - Preferences halosShowCoordinateSystem ifTrue: [ - target displayFullBounds ifNotNil: [ :fb | - aCanvas frameGlobalRect: fb borderWidth: 3 color: `Color black alpha: 0.2`. - b _ target displayBounds. - b area > 0 ifTrue: [ - aCanvas frameGlobalRect: b borderWidth: 3 color: `Color black alpha: 0.4` ]. - self drawCoordinateSystemOn: aCanvas ]].! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 5/26/2021 11:09:15' prior: 50567517! - addHandles: aDisplayRectangle - "update my size. owner is world, therefore owner coordinates are Display coordinates." - - self morphBounds: (aDisplayRectangle outsetBy: 30@30). - haloBox _ self handlesBox. - target addHandlesTo: self box: haloBox. - self addNameString: (target printStringLimitedTo: 40). - self redrawNeeded.! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 5/26/2021 10:55:19' prior: 50558307! - doResize: evt with: resizeHandle - "Called while the mouse is down in the grow handle" - - | newExtent | -self revisar. - self flag: #jmvVer2. - evt hand obtainHalo: self. -"MUST fix resize / rescale / rotation of embedded morphs!!!!!!" -newExtent _ evt eventPosition - positionOffset - target morphPositionInWorld. - evt shiftPressed ifTrue: [newExtent _ (newExtent x max: newExtent y) asPoint]. - (newExtent x = 0 or: [newExtent y = 0]) ifTrue: [^ self]. - target morphExtentInWorld: newExtent. - resizeHandle morphPositionInWorld: evt eventPosition - (resizeHandle morphExtent // 2). - self redrawNeeded.! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 5/26/2021 10:55:23' prior: 50559443! - doRot: evt with: rotHandle - "Update the rotation of my target if it is rotatable." - - | radians | -"MUST fix resize / rescale / rotation of embedded morphs!!!!!!" - evt hand obtainHalo: self. - radians _ (evt eventPosition - target referencePosition) theta + angleOffset. - radians _ radians detentBy: 0.05 atMultiplesOf: Float pi / 4 snap: false. - radians = 0.0 - ifTrue: [rotHandle color: `Color lightBlue`] - ifFalse: [rotHandle color: `Color blue`]. - rotHandle submorphsDo: - [:m | m color: rotHandle color makeForegroundColor]. - target rotation: radians. - rotHandle morphPositionInWorld: evt eventPosition - (rotHandle morphExtent // 2). - self redrawNeeded.! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 5/26/2021 10:55:25' prior: 50559464! - doScale: evt with: scaleHandle - "Update the scale of my target if it is scalable." - - | scale | -"MUST fix resize / rescale / rotation of embedded morphs!!!!!!" - evt hand obtainHalo: self. - scale _ (evt eventPosition - target referencePosition) rho * scaleOffset. - scale = 1.0 - ifTrue: [scaleHandle color: `Color lightBlue`] - ifFalse: [scaleHandle color: `Color blue`]. - scaleHandle submorphsDo: - [:m | m color: scaleHandle color makeForegroundColor]. - target scale: scale. - scaleHandle morphPositionInWorld: evt eventPosition - (scaleHandle morphExtent // 2). - self redrawNeeded.! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 5/26/2021 09:30:19' prior: 50567897 overrides: 50565002! - drawCurrentAndSubmorphs - - self isCurrentMorphVisible ifTrue: [ - - currentMorph drawOn: self. - currentMorph displayBoundsSetFrom: self. - - "Display submorphs back to front" - "coordinate system stack already set up for aMorph - ('ivars transformations' and 'currentTransformation')" - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | self fullDraw: m ]]. - - currentMorph postDrawOn: self. - currentMorph displayBoundsUpdateFrom: self. - - currentMorph isHighlighted ifTrue: [ - self drawHighlight: currentMorph ]. - ].! ! - -BitBltCanvas removeSelector: #drawCoordinateSystem:! - -!methodRemoval: BitBltCanvas #drawCoordinateSystem: stamp: 'Install-4611-CoordinateSystemsRefactor-JuanVuletich-2021May26-11h54m-jmv.001.cs.st 5/29/2021 17:28:47'! -drawCoordinateSystem: aRectangle - | c stepX stepY x0 x1 y0 y1 prevClipRect | - stepX _ 100. - stepY _ 50. - - prevClipRect _ self clipRect. - self setClipRect: (prevClipRect intersect: currentMorph displayBounds). - - self frameRectangle: aRectangle borderWidth: 4 color: `Color lightGray alpha: 0.4`. - - x0 _ aRectangle left. - x1 _ aRectangle right-1. - y0 _ aRectangle top. - y1 _ aRectangle bottom-1. - - c _ `Color lightGray alpha: 0.6`. - self line: x0@0 to: x1@0 width: 2 color: c. - self line: 0@y0 to: 0@y1 width: 2 color: c. - - (x0 truncateTo: stepX) to: (x1 - stepX truncateTo: stepX) by: stepX do: [ :x | - self line: x @ -5 to: x @ 5 width: 2 color: c. - self drawString: x printString atCenterX: x @ 5 font: nil color: c ]. - self drawString: 'x' atCenterX: x1 - 15 @ 0 font: nil color: c. - - (y0 truncateTo: stepY) to: (y1 - stepY truncateTo: stepY) by: stepY do: [ :y | - self line: -5 @ y to: 5 @ y width: 2 color: c. - self drawString: y printString, ' ' atWaist: 5 @ y font: nil color: c ]. - self drawString: 'y' atWaist: 0 @ (y1 - 20) font: nil color: c. - - self setClipRect: prevClipRect.! - -BitBltCanvas removeSelector: #drawCurrentMorphHighlight! - -!methodRemoval: BitBltCanvas #drawCurrentMorphHighlight stamp: 'Install-4611-CoordinateSystemsRefactor-JuanVuletich-2021May26-11h54m-jmv.001.cs.st 5/29/2021 17:28:47'! -drawCurrentMorphHighlight - - currentMorph displayBounds ifNotNil: [ :r | - engine - sourceForm: nil; - colorMap: nil; - combinationRule: Form blend; - fillColor: `Color black`; - frameRect: r borderWidth: 4; - fillColor: `Color pink alpha: 0.2`; - fillRect: (r insetBy: 4). - ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4611-CoordinateSystemsRefactor-JuanVuletich-2021May26-11h54m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4611] on 26 May 2021 at 12:26:45 pm'! -!MorphicCanvas methodsFor: 'drawing - Global Coordinates' stamp: 'jmv 5/26/2021 12:12:14'! - frameReverseGlobalRect: r borderWidth: borderWidth - self subclassResponsibility.! ! -!BitBltCanvas methodsFor: 'drawing - Global Coordinates' stamp: 'jmv 5/26/2021 12:12:48' overrides: 50571218! - frameReverseGlobalRect: rect borderWidth: borderWidth - " - (BitBltCanvas onForm: Display) - frameReverseGlobalRect: (10@10 extent: 300@200) - borderWidth: 20. - Display forceToScreen - " - engine ifNil: [ ^nil ]. - engine - sourceForm: nil; - fillColor: `Color gray`; - combinationRule: Form reverse; - frameRect: rect borderWidth: borderWidth! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 5/26/2021 12:12:26' prior: 50567860! - drawCurrentAsOutline - - self isCurrentMorphVisible ifTrue: [ - self frameReverseGlobalRect: currentMorph displayBounds borderWidth: 2. - currentMorph displayBoundsSetFrom: self ].! ! - -BitBltCanvas removeSelector: #reverseRectangleBorder:borderWidth:! - -!methodRemoval: BitBltCanvas #reverseRectangleBorder:borderWidth: stamp: 'Install-4612-BetterNaming-JuanVuletich-2021May26-12h26m-jmv.001.cs.st 5/29/2021 17:28:47'! -reverseRectangleBorder: r borderWidth: borderWidth - " - Display getCanvas - reverseRectangleBorder: (10@10 extent: 300@200) - borderWidth: 20. - Display forceToScreen - " - | rect | - - engine ifNil: [ ^nil ]. - - rect _ (currentTransformation externalizeRectangle: r) rounded. - engine - sourceForm: nil; - fillColor: `Color gray`; - combinationRule: Form reverse; - frameRect: rect borderWidth: borderWidth! - -BitBltCanvas removeSelector: #reverseGlobalRectangleBorder:borderWidth:! - -!methodRemoval: BitBltCanvas #reverseGlobalRectangleBorder:borderWidth: stamp: 'Install-4612-BetterNaming-JuanVuletich-2021May26-12h26m-jmv.001.cs.st 5/29/2021 17:28:47'! -reverseGlobalRectangleBorder: rect borderWidth: borderWidth - " - (BitBltCanvas onForm: Display) - reverseGlobalRectangleBorder: (10@10 extent: 300@200) - borderWidth: 20. - Display forceToScreen - " - engine ifNil: [ ^nil ]. - engine - sourceForm: nil; - fillColor: `Color gray`; - combinationRule: Form reverse; - frameRect: rect borderWidth: borderWidth! - -MorphicCanvas removeSelector: #reverseRectangleBorder:borderWidth:! - -!methodRemoval: MorphicCanvas #reverseRectangleBorder:borderWidth: stamp: 'Install-4612-BetterNaming-JuanVuletich-2021May26-12h26m-jmv.001.cs.st 5/29/2021 17:28:47'! -reverseRectangleBorder: r borderWidth: borderWidth - self subclassResponsibility.! - -MorphicCanvas removeSelector: #reverseGlobalRectangleBorder:borderWidth:! - -!methodRemoval: MorphicCanvas #reverseGlobalRectangleBorder:borderWidth: stamp: 'Install-4612-BetterNaming-JuanVuletich-2021May26-12h26m-jmv.001.cs.st 5/29/2021 17:28:47'! -reverseGlobalRectangleBorder: r borderWidth: borderWidth - self subclassResponsibility.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4612-BetterNaming-JuanVuletich-2021May26-12h26m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4612] on 26 May 2021 at 2:48:21 pm'! -!Morph methodsFor: 'submorphs-accessing' stamp: 'jmv 5/26/2021 14:45:18'! -allSubmorphsDo: aBlock - "Evaluate the given block for all morphs in this composite morph (including the receiver)." - - submorphs do: [ :m | - aBlock value: m. - m allSubmorphsDo: aBlock].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 5/26/2021 14:45:29' prior: 50570180! - adjustDisplayBoundsBy: delta - "Private for framework use. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us." - - privateDisplayBounds ifNotNil: [ - privateDisplayBounds _ privateDisplayBounds translatedBy: delta ]. - self allSubmorphsDo: [ :m | m adjustDisplayBoundsBy: delta ].! ! -!Morph methodsFor: 'submorphs-accessing' stamp: 'jmv 5/26/2021 14:46:46' prior: 16876668! - allMorphsDo: aBlock - "Evaluate the given block for all morphs in this composite morph (including the receiver)." - - aBlock value: self. - self allSubmorphsDo: aBlock! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4613-allSubmorphsDo-JuanVuletich-2021May26-14h44m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4613] on 28 May 2021 at 1:10:02 pm'! - -LabelMorph subclass: #MenuItemMorph - instanceVariableNames: 'isEnabled subMenu isSelected target selector arguments icon contentString ' - classVariableNames: 'SubMenuMarker OnImage OffImage ' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #MenuItemMorph category: #'Morphic-Menus' stamp: 'Install-4614-MenuItemMorph-form-caching-JuanVuletich-2021May28-13h09m-jmv.001.cs.st 5/29/2021 17:28:47'! -LabelMorph subclass: #MenuItemMorph - instanceVariableNames: 'isEnabled subMenu isSelected target selector arguments icon contentString' - classVariableNames: 'OffImage OnImage SubMenuMarker' - poolDictionaries: '' - category: 'Morphic-Menus'! -!MenuItemMorph methodsFor: 'private' stamp: 'jmv 5/28/2021 10:21:25' prior: 50506111! - offImage - "Return the form to be used for indicating an '' marker" - | e | - e _ (self fontToUse ascent-2) rounded asPoint. - (OffImage isNil or: [ OffImage extent ~= e ]) ifTrue: [ - OffImage _ Form extent: e depth: 32. - OffImage getCanvas - frameAndFillRectangle: OffImage boundingBox fillColor: `(Color gray: 0.9)` - borderWidth: 1 borderColor: `Color black` ]. - ^OffImage! ! -!MenuItemMorph methodsFor: 'private' stamp: 'jmv 5/28/2021 10:21:32' prior: 50506123! - onImage - "Return the form to be used for indicating an '' marker" - | e | - e _ (self fontToUse ascent-2) rounded asPoint. - (OnImage isNil or: [ OnImage extent ~= e ]) ifTrue: [ - OnImage _ Form extent: e depth: 32. - OnImage getCanvas - frameAndFillRectangle: OnImage boundingBox fillColor: `Color gray: 0.8` - borderWidth: 1 borderColor: `Color black`; - fillRectangle: (OnImage boundingBox insetBy: 2) color: `Color black` ]. - ^OnImage! ! - -LabelMorph subclass: #MenuItemMorph - instanceVariableNames: 'isEnabled subMenu isSelected target selector arguments icon contentString' - classVariableNames: 'OffImage OnImage SubMenuMarker' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #MenuItemMorph category: #'Morphic-Menus' stamp: 'Install-4614-MenuItemMorph-form-caching-JuanVuletich-2021May28-13h09m-jmv.001.cs.st 5/29/2021 17:28:47'! -LabelMorph subclass: #MenuItemMorph - instanceVariableNames: 'isEnabled subMenu isSelected target selector arguments icon contentString' - classVariableNames: 'OffImage OnImage SubMenuMarker' - poolDictionaries: '' - category: 'Morphic-Menus'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4614-MenuItemMorph-form-caching-JuanVuletich-2021May28-13h09m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4613] on 28 May 2021 at 1:11:15 pm'! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 5/28/2021 10:41:02' prior: 50557960! - resizeLeftCursor - ^ `(Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0000000000000000 - 2r0000010010000000 - 2r0000010010000000 - 2r0000010010000000 - 2r0001010010100000 - 2r0011010010110000 - 2r0111010010111000 - 2r1111110011111100 - 2r0111010010111000 - 2r0011010010110000 - 2r0001010010100000 - 2r0000010010000000 - 2r0000010010000000 - 2r0000010010000000 - 2r0000000000000000 - 2r0000000000000000) - offset: `-7@-7`) withMask`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 5/28/2021 10:41:13' prior: 50557977! - resizeTopCursor - ^ `(Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0000000100000000 - 2r0000001110000000 - 2r0000011111000000 - 2r0000111111100000 - 2r0000000100000000 - 2r0111111111111100 - 2r0000000000000000 - 2r0000000000000000 - 2r0111111111111100 - 2r0000000100000000 - 2r0000111111100000 - 2r0000011111000000 - 2r0000001110000000 - 2r0000000100000000 - 2r0000000000000000 - 2r0000000100000000) - offset: `-7@-7`) withMask`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 5/28/2021 10:41:21' prior: 50557994! - resizeTopLeftCursor - ^ `(Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0000000000000000 - 2r0111110000010000 - 2r0111100000100000 - 2r0111000001000100 - 2r0110100010001000 - 2r0100010100010000 - 2r0000001000100000 - 2r0000010001000000 - 2r0000100010000000 - 2r0001000101000100 - 2r0010001000101100 - 2r0000010000011100 - 2r0000100000111100 - 2r0000000001111100 - 2r0000000000000000 - 2r0000000000000000) - offset: `-7@-7`) withMask`.! ! -!Cursor class methodsFor: 'instance creation' stamp: 'jmv 5/28/2021 10:41:28' prior: 50558011! - resizeTopRightCursor - ^ `(Cursor - small1BitExtent: `16@16` - pixelBits: #( - 2r0000000000000000 - 2r0001000001111100 - 2r0000100000111100 - 2r0100010000011100 - 2r0010001000101100 - 2r0001000101000100 - 2r0000100010000000 - 2r0000010001000000 - 2r0000001000100000 - 2r0100010100010000 - 2r0110100010001000 - 2r0111000001000000 - 2r0111100000100000 - 2r0111110000000000 - 2r0000000000000000 - 2r0000000000000000) - offset: `-7@-7`) withMask`.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4615-Cursor-makeInstancesLiteral-JuanVuletich-2021May28-13h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4613] on 28 May 2021 at 1:11:50 pm'! -!AutoCompleterMorph methodsFor: 'testing' stamp: 'jmv 5/28/2021 11:16:16' prior: 50433812! - isXOutOfScreen: aLocation with: anExtent - - ^aLocation x + anExtent x > Display width! ! -!AutoCompleterMorph methodsFor: 'testing' stamp: 'jmv 5/28/2021 11:16:23' prior: 50433818! - isYOutOfScreen: aLocation with: anExtent - - ^aLocation y + anExtent y > Display height! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4616-Cleanup-JuanVuletich-2021May28-13h11m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4613] on 28 May 2021 at 1:20:12 pm'! -!DisplayScreen class methodsFor: 'display box access' stamp: 'jmv 5/28/2021 11:13:51'! - isDisplayExtentOk - "False if Cuis main window size has changed, but Display hasn't been updated yet." - - ^Display extent = DisplayScreen actualScreenSize! ! -!DisplayScreen class methodsFor: 'screen update' stamp: 'jmv 5/28/2021 11:38:25'! - terminateScreenUpdater - - ScreenUpdaterProcess ifNotNil: [ - ScreenUpdaterProcess terminate. - ScreenUpdaterProcess _ nil ]! ! -!Transcripter methodsFor: 'accessing' stamp: 'jmv 5/28/2021 11:14:54' prior: 50522664! - endEntry - | c d cb | - c _ self contents. - DisplayScreen isDisplayExtentOk ifFalse: [ - "Handle case of user resizing physical window" - DisplayScreen startUp. - frame _ frame intersect: Display boundingBox. - ^ self clear; show: c]. - textComposition - setModel: (TextModel withText: c asText); - extentForComposing: frame width-8 @9999. - textComposition composeAll. - d _ textComposition usedHeight - frame height. - d > 0 ifTrue: [ - "Scroll up to keep all contents visible" - cb _ textComposition characterBlockAtPoint: - `0@0` + (0@(d+FontFamily defaultLineSpacing)). - self on: (c copyFrom: cb stringIndex to: c size). - readLimit _ position _ collection size. - ^ self endEntry]. - Display fill: (frame insetBy: -2) fillColor: self black; - fill: frame fillColor: self white. - Display getCanvas - textComposition: textComposition - bounds: (`4@4` + frame topLeft extent: Display extent) - color: `Color black` - selectionColor: `Color blue`. - DisplayScreen screenUpdateRequired: nil! ! -!UISupervisor class methodsFor: 'services' stamp: 'jmv 5/28/2021 13:17:39' prior: 50470940! - restoreDisplay - self ui ifNotNil: [ :guiRootObject | - DisplayScreen isDisplayExtentOk ifFalse: [ - "Deallocate before allocating could mean less memory stress." - guiRootObject clearCanvas ]]. - DisplayScreen startUp. - self ui ifNotNil: [ :guiRootObject | - guiRootObject restoreDisplay ]. - self whenUIinSafeState: [ Cursor defaultCursor activateCursor ].! ! -!DisplayScreen class methodsFor: 'display box access' stamp: 'jmv 5/28/2021 11:14:20' prior: 50379642! - checkForNewScreenSize - "Check whether the screen size has changed and if so take appropriate actions" - - self isDisplayExtentOk ifFalse: [ - UISupervisor restoreDisplay ]! ! -!DisplayScreen class methodsFor: 'snapshots' stamp: 'jmv 5/28/2021 11:38:55' prior: 50383989 overrides: 16785023! - shutDown - "Minimize Display memory saved in image" - Display setExtent: `240@120` depth: Display nativeDepth. - self terminateScreenUpdater! ! -!DisplayScreen class methodsFor: 'snapshots' stamp: 'jmv 5/28/2021 11:39:19' prior: 16835532 overrides: 50335342! -startUp - " - DisplayScreen startUp - " - self terminateScreenUpdater. - Display setExtent: self actualScreenSize depth: Display nativeDepth. - Display beDisplay. - self installScreenUpdater! ! -!DisplayScreen class methodsFor: 'screen update' stamp: 'jmv 5/28/2021 11:39:06' prior: 16835540! - installScreenUpdater - "Initialize the event tickler process. Terminate the old process if any." - " - DisplayScreen installScreenUpdater - " - - self terminateScreenUpdater. - ScreenUpdaterProcess _ [ self screenUpdater ] newProcess. - ScreenUpdaterProcess priority: Processor lowIOPriority. - ScreenUpdaterProcess name: 'Background Screen updater'. - ScreenUpdaterProcess resume! ! -!DisplayScreen class methodsFor: 'screen update' stamp: 'jmv 5/28/2021 11:33:49' prior: 16835564! - screenUpdater - | delay | - delay _ Delay forMilliseconds: 50. - ScreenUpdaterSemaphore _ Semaphore new. - Damage _ nil. - [ - delay wait. - ScreenUpdaterSemaphore wait. - Display forceToScreen: Damage. - ScreenUpdaterSemaphore initSignals. - Damage _ nil. - ] repeat! ! -!WorldMorph methodsFor: 'canvas' stamp: 'jmv 5/28/2021 13:16:50' prior: 50551487! - setCanvas - self clearCanvas. "Deallocate before allocating could mean less memory stress." - self setCanvas: Display getCanvas. - damageRecorder _ DamageRecorder new. - self redrawNeeded! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - DisplayScreen installScreenUpdater! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4617-FixOccasionalCrashOnMainWindowResize-JuanVuletich-2021May28-13h11m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4613] on 28 May 2021 at 2:14:09 pm'! -!MorphicCanvas methodsFor: 'initialization' stamp: 'jmv 5/28/2021 10:08:06'! - initializeWith: aForm origin: aPoint preferSubPixelAntiAliasing: aBoolean - self initialize. - self setForm: aForm preferSubPixelAntiAliasing: aBoolean. - - "Set up these only on initialization. - This is safe (wrt walkbacks during world redraw) because a new instance is created - on draw error. See #displayWorldSafely" - currentTransformation _ MorphicTranslation withTranslation: aPoint. - cti _ 1. - transformations - ifNil: [ transformations _ OrderedCollection with: currentTransformation ] - ifNotNil: [ transformations at: cti put: currentTransformation ]. - drawingMorphStack - ifNil: [ drawingMorphStack _ OrderedCollection with: nil ] - ifNotNil: [ drawingMorphStack at: cti put: nil ].! ! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 5/28/2021 10:03:45'! - setForm: aForm preferSubPixelAntiAliasing: aBoolean - form _ aForm.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 5/28/2021 10:06:37'! - onFormWithSubPixelAntiAliasing: aForm - - ^ self subclassToUse basicNew - initializeWith: aForm origin: `0@0` preferSubPixelAntiAliasing: true! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 5/28/2021 10:08:10' overrides: 50571696! - setForm: aForm preferSubPixelAntiAliasing: aBoolean - super setForm: aForm preferSubPixelAntiAliasing: aBoolean. - engine _ BitBltCanvasEngine toForm: form. - "Init BitBlt so that the first call to the 'primitiveDisplayString' primitive will not fail" - engine sourceX: 0; width: 0. - self newClipRect: nil.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 5/28/2021 10:05:53' prior: 50536748! - on: aForm over: aRectangle - "Warning: aForm extent must equal aRectangle extent" - - ^ self subclassToUse basicNew - initializeWith: aForm origin: aRectangle topLeft negated preferSubPixelAntiAliasing: false! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 5/28/2021 10:06:00' prior: 50536757! - onForm: aForm - - ^ self subclassToUse basicNew - initializeWith: aForm origin: `0@0` preferSubPixelAntiAliasing: false! ! - -BitBltCanvas removeSelector: #setForm:! - -!methodRemoval: BitBltCanvas #setForm: stamp: 'Install-4618-OptimizeInstanceCreation-JuanVuletich-2021May28-13h20m-jmv.001.cs.st 5/29/2021 17:28:47'! -setForm: aForm - super setForm: aForm. - engine _ BitBltCanvasEngine toForm: form. - "Init BitBlt so that the first call to the 'primitiveDisplayString' primitive will not fail" - engine sourceX: 0; width: 0. - self newClipRect: nil.! - -MorphicCanvas removeSelector: #setForm:! - -!methodRemoval: MorphicCanvas #setForm: stamp: 'Install-4618-OptimizeInstanceCreation-JuanVuletich-2021May28-13h20m-jmv.001.cs.st 5/29/2021 17:28:47'! -setForm: aForm - form _ aForm.! - -MorphicCanvas removeSelector: #initializeWith:origin:! - -!methodRemoval: MorphicCanvas #initializeWith:origin: stamp: 'Install-4618-OptimizeInstanceCreation-JuanVuletich-2021May28-13h20m-jmv.001.cs.st 5/29/2021 17:28:47'! -initializeWith: aForm origin: aPoint - self initialize. - self setForm: aForm. - - "Set up these only on initialization. - This is safe (wrt walkbacks during world redraw) because a new instance is created - on draw error. See #displayWorldSafely" - currentTransformation _ MorphicTranslation withTranslation: aPoint. - cti _ 1. - transformations - ifNil: [ transformations _ OrderedCollection with: currentTransformation ] - ifNotNil: [ transformations at: cti put: currentTransformation ]. - drawingMorphStack - ifNil: [ drawingMorphStack _ OrderedCollection with: nil ] - ifNotNil: [ drawingMorphStack at: cti put: nil ].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4618-OptimizeInstanceCreation-JuanVuletich-2021May28-13h20m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4618] on 29 May 2021 at 5:24:45 pm'! -!Utilities class methodsFor: 'default desktop' stamp: 'jmv 5/29/2021 17:24:04' prior: 50565739! - defaultTextEditorContents - ^ (' -', -('Cuis Smalltalk - -' centered blue pointSize: FontFamily defaultPointSize * 3), -(' -"Yay, Juan. You GO, guy!! ...a great example of malleable software (and a clever mind) at work." -' rightFlush pointSize: FontFamily defaultPointSize * 0.6), -('Dan Ingalls -' italic rightFlush pointSize: FontFamily defaultPointSize * 0.6), -(' -"I like it... It''s nice and clean and simple and pretty. Nice stuff!!" -' rightFlush pointSize: FontFamily defaultPointSize * 0.6), -('Alan Kay -' italic rightFlush pointSize: FontFamily defaultPointSize * 0.6), -(' -"I think you have a very elegant design aesthetic." -' rightFlush pointSize: FontFamily defaultPointSize * 0.6), -('John Maloney -'italic rightFlush pointSize: FontFamily defaultPointSize * 0.6), -' - -', -'Cuis is a modern, Open Source, multiplatform, Smalltalk-80 system. - - -', -'Cuis is: - -' bold, -' - Small - - Clean - - Appropriable -' blue, -' - -Additionally, Cuis is: - -' bold, -' - Open Source - - Multiplatform -' blue, -' - -Like other Smalltalk systems, Cuis is also: - -' bold, -' - A complete development environment written in itself - - A pure, dynamic Object Oriented language -' blue, -' - -Cuis assumes very little on the underlying platform, and this lets it run out-of-the-box on Windows, MacOS, Linux, ChromeOS and WebBrowsers. Cuis shares the [OpenSmalltalk Virtual Machine] (http://www.opensmalltalk.org) with Squeak, Pharo and Newspeak. - -What sets Cuis apart from the other members of the Squeak family is the focus on Smalltalk-80 and an active attitude towards system complexity: - -Unbound complexity growth, together with development strategies focused only in the short term, are the worst long term enemies of all software systems. As systems grow older, they usually become more complex. New features are added as layers on top of whatever is below, sometimes without really understanding it, and almost always without modifying it. Complexity and size grow without control. Evolution slows down. Understanding the system becomes harder every day. Bugs are harder to fix. Codebases become huge for no clear reason. At some point, the system can''t evolve anymore and becomes "legacy code". - -Complexity puts a limit to the level of understanding of the system a person might reach, and therefore limits the things that can be done with it. Dan Ingalls says all this in ["Design Principles Behind Smalltalk"] (http://www.cs.virginia.edu/~evans/cs655/readings/smalltalk.html). Even if you have already done so, please go and read it again!! - -Cuis Smalltalk is our attempt at this challenge. Furthermore, we believe we are doing something else that no other Smalltalk, commercial or open source, does. We attempt to give the true Smalltalk-80 experience, and keep Smalltalk-80 not as legacy software of historic significance, but as a live, evolving system. We feel we are the keepers of the Smalltalk-80 heritage, and enablers of the Dynabook experience. - -As Cuis evolves, we keep on these values. Every update, be it a bug fix or a feature enhancement, is reviewed carefully to avoid adding unneded complexity to the system. Every opportunity to remove unneded complexity is followed. As we go, features are enhanced, and any reported bugs fixed. We also adopt selected enhancements from Squeak and Pharo, and share our work with the wider Smalltalk community. - - -' justified, -'License -' bold, -' -Cuis is distributed subject to the MIT License, as in http://www.opensource.org/licenses/mit-license.php . Any contribution submitted for incorporation into or for distribution with Cuis shall be presumed subject to the same license. - -Portions of Cuis are: -Copyright (c) Xerox Corp. 1981, 1982 -Copyright (c) Apple Computer, Inc. 1985-1996 -Copyright (c) Contributors to Squeak project. 1997-2021 -Copyright (c) Contributors to Cuis Smalltalk project. 2009-2021')! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4619-AboutCuisCorrection-JuanVuletich-2021May29-17h24m-jmv.001.cs.st----! - -----SNAPSHOT----(29 May 2021 17:28:50) Cuis5.0-4619-v3.image priorSource: 7651022! - -----STARTUP---- (20 July 2021 16:52:43) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4619-v3.image! - - -'From Cuis 5.0 [latest update: #4619] on 31 May 2021 at 4:25:47 pm'! -!Color methodsFor: 'access' stamp: 'jmv 6/18/2017 20:31:54' prior: 50418783! - hue - "Return the hue of this color, an angle in the range [0.0..360.0]. - Color orange hue - " - - | r g b max min span h | - r _ self red. - g _ self green. - b _ self blue. - max _ (r max: g) max: b. - min _ (r min: g) min: b. - span _ (max - min) asFloat. - span = 0.0 ifTrue: [ ^ 0.0 ]. - - r = max ifTrue: [ - h _ ((g - b) asFloat / span) * 60.0. - ] ifFalse: [ - g = max - ifTrue: [ h _ 120.0 + (((b - r) asFloat / span) * 60.0). ] - ifFalse: [ h _ 240.0 + (((r - g) asFloat / span) * 60.0). ]. - ]. - - ^h mod: 360.0! ! -!Color methodsFor: 'access' stamp: 'jmv 6/18/2017 20:34:08' prior: 50418802! - saturation - "Return the saturation of this color, a value between 0.0 and 1.0. - Color red saturation - Color gray saturation - " - - | r g b max min | - r _ self red. - g _ self green. - b _ self blue. - max _ (r max: g) max: b. - min _ (r min: g) min: b. - max = 0.0 ifTrue: [ ^0.0 ]. - ^max - min / max! ! -!Color methodsFor: 'conversions' stamp: 'jmv 5/31/2021 10:13:33' prior: 50353397! - closestPixelValue8 - "Return the nearest approximation to this color for an 8-bit deep Form. - Note: Answer values in the standard Color indexedColors. - Not useful for ColorForms with custom palettes!!" - - "fast special cases" - self isBlack ifTrue: [^ 1]. "black" - self isWhite ifTrue: [^ 255]. "white" - - ^self saturation < 0.2 - ifTrue: [ - ^ self class grayToIndexMap at:(self green * 255) rounded + 1. "nearest gray" - ] - ifFalse: [ - "compute nearest entry in the color cube" - 40 + - ((self red * 5) rounded * 36) + - ((self blue * 5) rounded * 6) + - (self green * 5) rounded ]! ! -!Color class methodsFor: 'class initialization' stamp: 'jmv 4/17/2015 15:06' prior: 50418815! - initializeGrayToIndexMap - "Build an array of gray values available in the 8-bit colormap. This array is indexed by a gray level between black (1) and white (256) and returns the pixel value for the corresponding gray level." - "Note: This method must be called after initializeIndexedColors, since it uses IndexedColors." - " - Color initializeGrayToIndexMap - " - - | grayLevels grayIndices c distToClosest dist indexOfClosest indexedColors | - "record the level and index of each gray in the 8-bit color table" - grayLevels _ OrderedCollection new. - grayIndices _ OrderedCollection new. - indexedColors _ self indexedColors. - "Note: skip the first entry, which is reserved for transparent" - 2 to: indexedColors size do: [:i | - c _ indexedColors at: i. - c saturation = 0.0 ifTrue: [ "c is a gray" - grayLevels add: (c green * 255) rounded. "0 to 255; R, G, and B are the same" - grayIndices add: i - 1]]. "pixel values are zero-based" - grayLevels _ grayLevels asArray. - grayIndices _ grayIndices asArray. - - "for each gray level in [0..255], select the closest match" - GrayToIndexMap _ ByteArray new: 256. - 0 to: 255 do: [ :level | - distToClosest _ 10000. "greater than distance to any real gray" - 1 to: grayLevels size do: [:i | - dist _ (level - (grayLevels at: i)) abs. - dist < distToClosest ifTrue: [ - distToClosest _ dist. - indexOfClosest _ grayIndices at: i]]. - GrayToIndexMap at: (level + 1) put: indexOfClosest]! ! -!TranslucentColor methodsFor: 'queries' stamp: 'jmv 6/18/2017 20:41:54' prior: 50418863 overrides: 50353823! - isTransparent - ^ self alpha = 0.0! ! -!Float methodsFor: 'converting' stamp: 'nice 4/23/2011 02:24' prior: 50418684 overrides: 16879954! - withNegativeSign - "Same as super, but handle the subtle case of Float negativeZero" - - self = 0.0 ifTrue: [^self class negativeZero]. - ^super withNegativeSign! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 5/31/2021 07:43:09' prior: 50421970! - ulp - "Answer the unit of least precision of the receiver. - Follow John Harrison's definition as described at - https://en.wikipedia.org/wiki/Unit_in_the_last_place" - - self isFinite ifFalse: [^self abs]. - self = 0.0 ifTrue: [^0.0 nextAwayFromZero]. - ^ (self - self nextTowardsZero) abs! ! -!Float methodsFor: 'printing' stamp: 'jmv 7/11/2018 17:45:59' prior: 50418724! - printAsIEEE32BitPrecisionFloatOn: aStream base: base - "Handle sign, zero, and NaNs; all other values passed to absPrintOn:base:mantissaSignificantBits: - Print as a 32 bit Float" - - self isNaN ifTrue: [aStream nextPutAll: 'NaN'. ^ self]. "check for NaN before sign" - self > 0.0 - ifTrue: [self absPrintOn: aStream base: base mantissaSignificantBits: 24] - ifFalse: - [self sign = -1 - ifTrue: [aStream nextPutAll: '-']. - self = 0.0 - ifTrue: [aStream nextPutAll: '0.0'. ^ self] - ifFalse: [self negated absPrintOn: aStream base: base mantissaSignificantBits: 24]]! ! -!Float methodsFor: 'printing' stamp: 'jmv 5/31/2021 07:37:11' prior: 50421389 overrides: 16880278! - printOn: aStream base: base - "Handle sign, zero, and NaNs; all other values passed to absPrintOn:base:" - - self isNaN ifTrue: [aStream nextPutAll: 'NaN'. ^ self]. "check for NaN before sign" - self > 0.0 - ifTrue: [self absPrintOn: aStream base: base] - ifFalse: - [self sign = -1 - ifTrue: [aStream nextPutAll: '-']. - self = 0.0 - ifTrue: [aStream nextPutAll: '0.0'] - ifFalse: [self negated absPrintOn: aStream base: base]]! ! -!Float methodsFor: 'printing' stamp: 'jmv 5/31/2021 07:41:56' prior: 50509426 overrides: 16880428! - storeOn: aStream base: base - - "Print the Number exactly so it can be interpreted back unchanged" - - self sign = -1 ifTrue: [aStream nextPutAll: '-']. - base = 10 ifFalse: [aStream print: base; nextPut: $r]. - self = 0.0 - ifTrue: [aStream nextPutAll: '0.0'] - ifFalse: [self abs absPrintExactlyOn: aStream base: base]! ! -!Form methodsFor: 'converting' stamp: 'jmv 5/31/2021 07:19:06' prior: 50383481! - asGrayForm - | answer map | - - "For lower bit depths, the 15 bit ColorMap loses no information, - and answers the real #luminance of each pixel." - self depth < 32 ifTrue: [ - answer _ GrayForm extent: width@height. - map _ self colormapIfNeededForGray8bpp. - (BitBlt toForm: answer) - colorMap: map; - copy: self boundingBox - from: `0@0` in: self - fillColor: nil rule: Form over. - answer offset: self offset. - ^ answer ]. - - "For 32bpp, the approach above would use just 5bits per component. - Generally it is best to extract a component in full 8bpp and keep full dynamic range. - Green usually is a good choice." - ^ self asGrayForm: 3! ! -!Form methodsFor: 'converting' stamp: 'jmv 5/31/2021 07:20:06' prior: 16847530! - orderedDither32To16 - "Do an ordered dithering for converting from 32 to 16 bit depth." - | ditherMatrix ii out inBits outBits index pv dmv r di dmi dmo g b pvOut outIndex | - self depth = 32 ifFalse:[^self error:'Must be 32bit for this']. - ditherMatrix _ #( - 0 8 2 10 - 12 4 14 6 - 3 11 1 9 - 15 7 13 5). - ii _ (0 to: 31) collect:[:i| i]. - out _ Form extent: self extent depth: 16. - inBits _ self bits. - outBits _ out bits. - index _ outIndex _ 0. - pvOut _ 0. - 0 to: self height-1 do:[:y| - 0 to: self width-1 do:[:x| - pv _ inBits at: (index _ index + 1). - dmv _ ditherMatrix at: (y bitAnd: 3) * 4 + (x bitAnd: 3) + 1. - r _ pv bitAnd: 255. di _ r * 496 bitShift: -8. - dmi _ di bitAnd: 15. dmo _ di bitShift: -4. - r _ dmv < dmi ifTrue:[ii at: 2+dmo] ifFalse:[ii at: 1+dmo]. - g _ (pv bitShift: -8) bitAnd: 255. di _ g * 496 bitShift: -8. - dmi _ di bitAnd: 15. dmo _ di bitShift: -4. - g _ dmv < dmi ifTrue:[ii at: 2+dmo] ifFalse:[ii at: 1+dmo]. - b _ (pv bitShift: -16) bitAnd: 255. di _ b * 496 bitShift: -8. - dmi _ di bitAnd: 15. dmo _ di bitShift: -4. - b _ dmv < dmi ifTrue:[ii at: 2+dmo] ifFalse:[ii at: 1+dmo]. - pvOut _ (pvOut bitShift: 16) + - (b bitShift: 10) + (g bitShift: 5) + r. - (x bitAnd: 1) = 1 ifTrue:[ - outBits at: (outIndex _ outIndex+1) put: pvOut. - pvOut _ 0]. - ]. - (self width bitAnd: 1) = 1 ifTrue:[ - outBits at: (outIndex _ outIndex+1) put: (pvOut bitShift: -16). - pvOut _ 0]. - ]. - ^out! ! -!Form methodsFor: 'displaying-generic' stamp: 'jmv 5/31/2021 09:14:11' prior: 16847738! - displayOn: aForm at: aDisplayPoint - "Display the receiver located at aDisplayPoint with default settings for - rule and halftone." - - | toBeDrawn rule | - "Rule Form paint treats pixels with a value of zero as transparent" - toBeDrawn _ self. - (aForm depth = 32 and: [ self depth = 32 ]) - ifTrue: [ rule _ Form blend ] "Handle translucent pixels correctly. Requires both source and dest of 32bpp" - ifFalse: [ - "Warning. Using 'Form paint' with a 32bpp source that includes - traslucent or transparent alphas will give incorrect results (alpha values will be ignored). - Doing what follows might be terribly slow. It is best to convert to lower depth on image load." - "self depth = 32 ifTrue: [ - toBeDrawn _ self asFormOfDepth: aForm depth ]." - rule _ Form paint ]. - toBeDrawn displayOn: aForm - at: aDisplayPoint - clippingBox: aForm boundingBox - rule: rule! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4620-Cleanup-JuanVuletich-2021May31-16h23m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4620] on 31 May 2021 at 4:40:37 pm'! -!Form methodsFor: 'converting' stamp: 'jmv 5/31/2021 11:07:39'! - as8BitStandardPaletteColorForm - "Simple conversion of zero pixels to transparent. Force it to 8 bits." - - | f | - f _ ColorForm extent: self extent depth: 8. - f colors: Color indexedColors copy. - self displayOn: f at: self offset negated. - f offset: self offset. - ^ f! ! -!Form methodsFor: 'converting' stamp: 'jmv 5/31/2021 16:28:18'! - asColorFormOfDepth: destDepth - " - Answer a ColorForm with a custom optimized palette of up to 256, 16 or 4 entries. - self runningWorld backgroundImage asColorFormOfDepth: 8 :: display - self runningWorld backgroundImage orderedDither32To16 asColorFormOfDepth: 8 :: display - self runningWorld backgroundImage orderedDither32To16 asColorFormOfDepth: 4 :: display - " - | answer bitsPerColor clusterIndexToSplit clusterToSplit clusters colors desiredNumberOfClusters errors firstCluster map metricToSplitOn tally valueToSplitOn box hueWeightFactor brightnessWeightFactor saturationWeightFactor | - self depth > 8 ifFalse: [ - ^self error: 'Only for 16 bit and 32 bit Forms' ]. - desiredNumberOfClusters _ 1 bitShift: destDepth. - - "Wheights to balance error on each color metric" - hueWeightFactor _ 8.0 / 360.0. - saturationWeightFactor _ 1.0. - brightnessWeightFactor _ 3.0. - destDepth < 8 ifTrue: [ - brightnessWeightFactor _ 13.0. - destDepth < 4 ifTrue: [ - hueWeightFactor _ 0.0. - saturationWeightFactor _ 0.0. ]]. - "Assign all pixels to a single cluster" - tally _ self tallyPixelValues. - firstCluster _ OrderedCollection new. - tally withIndexDo: [ :pixelCount :pixelValuePlusOne | - pixelCount = 0 ifFalse: [ |c| - c _ Color colorFromPixelValue: pixelValuePlusOne -1 depth: 16. - firstCluster add: {c hue. c saturation. c brightness. pixelCount. pixelValuePlusOne } ]]. - clusters _ OrderedCollection with: firstCluster. - - "Pick the existing cluster with the largest error, and split it." - [clusters size < desiredNumberOfClusters and: [ clusters anySatisfy: [:eachCluster | eachCluster size > 1]]] whileTrue: [ | cluster1 cluster2 | - "Detect cluster with largest error, and split it" - errors _ clusters collect: [ :eachCluster | | sum average error | - sum _ (eachCluster sum: [ :e | {e first * e fourth. e second * e fourth. e third * e fourth. e fourth }]). - average _ {sum first. sum second. sum third} / sum fourth. - error _ eachCluster sum: [ :e | | hueError | - hueError _ (e first - average first) abs. hueError > (360/2) ifTrue: [hueError _ 360 - hueError]. - {hueError * hueWeightFactor. (e second-average second) abs * saturationWeightFactor. (e third-average third) abs * brightnessWeightFactor} * e fourth ]. - {error max. error indexOfMax. average at: error indexOfMax} ]. - clusterIndexToSplit _ (errors collect: [ :e | e first]) indexOfMax. - metricToSplitOn _ (errors at: clusterIndexToSplit) second. - valueToSplitOn _ (errors at: clusterIndexToSplit) third. - clusterToSplit _ clusters at: clusterIndexToSplit. - cluster1 _ OrderedCollection new. - cluster2 _ OrderedCollection new. - clusterToSplit do: [ :pixelMetricsAndCount | - (pixelMetricsAndCount at: metricToSplitOn) < valueToSplitOn - ifTrue: [cluster1 add: pixelMetricsAndCount] - ifFalse: [cluster2 add: pixelMetricsAndCount]]. - clusters at: clusterIndexToSplit put: cluster1. - clusters add: cluster2. - ]. - - colors _ clusters collect: [ :eachCluster | | sum average | - average _ eachCluster average. - sum _ (eachCluster sum: [ :a | {a first * a fourth. a second * a fourth. a third * a fourth. a fourth }]). - average _ {sum first. sum second. sum third} / sum fourth. - Color hue: average first saturation: average second brightness: average third ]. - answer _ ColorForm extent: self extent depth: destDepth. - answer colors: colors. - - "Build colormap for displaying self on answer" - bitsPerColor _ 5. "To read 16bpp source" - map _ Bitmap new: (1 bitShift: 3*bitsPerColor). - clusters withIndexDo: [ :eachCluster :clusterIndex | - eachCluster do: [ :pixMetrixsAndCount | - map at: pixMetrixsAndCount fifth put: clusterIndex-1 ]]. - - box _ self boundingBox. - answer copyBits: box from: self at: 0@0 clippingBox: box rule: Form over map: map. - ^answer -! ! -!Form methodsFor: 'converting' stamp: 'jmv 5/31/2021 16:27:21' prior: 50560409! - as8BitColorForm - "Answer an 8 bit ColorForm with an optimized palette with up to 256 entries." - - ^self asColorFormOfDepth: 8! ! -!PasteUpMorph methodsFor: 'misc' stamp: 'jmv 5/31/2021 16:36:26' prior: 50551035! - buildMagnifiedBackgroundImage - | image | - backgroundImageData - ifNil: [ backgroundImage _ nil ] - ifNotNil: [ - [image _ Form fromBinaryStream: backgroundImageData readStream. - backgroundImage _ image magnifyTo: extent. - backgroundImage _ backgroundImage orderedDither32To16 asColorFormOfDepth: 8. - ] on: Error do: [backgroundImage := nil]. "Can happen if JPEG plugin not built" - self redrawNeeded - ]! ! - -WorldMorph removeSelector: #buildMagnifiedBackgroundImage! - -!methodRemoval: WorldMorph #buildMagnifiedBackgroundImage stamp: 'Install-4621-8bppBackground-JuanVuletich-2021May31-16h39m-jmv.001.cs.st 7/20/2021 16:52:48'! -buildMagnifiedBackgroundImage - super buildMagnifiedBackgroundImage. - backgroundImage ifNil: [ ^ self ]. - - canvas ifNotNil: [ :c | - (backgroundImage depth = 32 and: [ c form depth < 32 ]) ifTrue: [ - backgroundImage _ backgroundImage orderedDither32To16 ]]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4621-8bppBackground-JuanVuletich-2021May31-16h39m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4621] on 1 June 2021 at 1:56:23 pm'! -!Decompiler methodsFor: 'control' stamp: 'jmv 6/1/2021 13:55:50' prior: 16831460! - doClosureCopyCopiedValues: blockCopiedValues numArgs: numArgs blockSize: blockSize - | startpc savedTemps savedTempVarCount savedNumLocalTemps - jump blockArgs blockTemps blockTempsOffset block tmpNumberBase | - tmpNumberBase := statements size. - savedTemps := tempVars. - savedTempVarCount := tempVarCount. - savedNumLocalTemps := numLocalTemps. - jump := blockSize + (startpc := pc). - numLocalTemps := BlockLocalTempCounter tempCountForBlockStartingAt: pc in: method. - blockTempsOffset := numArgs + blockCopiedValues size. - (blockStartsToTempVars notNil "implies we were intialized with temp names." - and: [blockStartsToTempVars includesKey: pc]) - ifTrue: - [tempVars := blockStartsToTempVars at: pc] - ifFalse: - [blockArgs := (1 to: numArgs) collect: - [:i| (constructor - codeTemp: i - 1 - named: 'argm', tmpNumberBase printString, '_', (tempVarCount + i) printString) - beBlockArg]. - blockTemps := (1 to: numLocalTemps) collect: - [:i| constructor - codeTemp: i + blockTempsOffset - 1 - named: 'temp', tmpNumberBase printString, '_', (tempVarCount + i + numArgs) printString]. - tempVars := blockArgs, blockCopiedValues, blockTemps]. - numLocalTemps timesRepeat: - [self interpretNextInstructionFor: self. - stack removeLast]. - tempVarCount := tempVarCount + numArgs + numLocalTemps. - block := self blockTo: jump. - stack addLast: ((constructor - codeArguments: (tempVars copyFrom: 1 to: numArgs) - temps: (tempVars copyFrom: blockTempsOffset + 1 to: blockTempsOffset + numLocalTemps) - block: block) - pc: startpc; - yourself). - tempVars := savedTemps. - tempVarCount := savedTempVarCount. - numLocalTemps := savedNumLocalTemps! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4622-DecompilerTweak-toEaseDecompilerTests-JuanVuletich-2021Jun01-12h01m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4622] on 1 June 2021 at 2:37:09 pm'! -!CodePackage methodsFor: 'saving' stamp: 'jmv 6/1/2021 14:36:41' prior: 50389785! - write: classes initializersOn: aStream - "Write the call to #initialize method of classes defined in us." - - classes do: [ :class | - (class class includesSelector: #initialize) ifTrue: [ - aStream nextChunkPut: class name, ' initialize'; newLine ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4623-WriteInitializersInSafeOrder-JuanVuletich-2021Jun01-14h36m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4607] on 24 May 2021 at 2:20:35 pm'! -!Float class methodsFor: 'testing' stamp: 'dtl 5/24/2021 14:17:21'! - nativeWordOrdering - "True if this image stores float objects internally in native word order. - If false, double word floats are stored in big-endian order regardless - of the machine native word order." - - ^ Smalltalk imageFormatVersion anyMask: 1 -! ! -!Float64Array methodsFor: 'accessing' stamp: 'dtl 5/24/2021 14:17:31' prior: 50334211! - floatAt: index put: aNumber - "Store the argument (e.g., 64 bit Float) at the given index - Use the same internal representation as BoxedFloat64. I.e. a BoxedFloat64 and a Float64Array of size 1 hold the same bits. - Allow subclasses to redefine #at:put:" - - "This breaks with SmallFloat64" - "self replaceWordsFrom: index * 2 - 1 to: index * 2 with: aFloat asFloat startingAt: 1." - - "Float >>basicAt: acts as if Floats were stored in big endian format. Our instances are in platform endianess." - | aFloat | - aFloat _ aNumber asFloat. - (Smalltalk isLittleEndian and: [Float nativeWordOrdering]) - ifTrue: [ - self basicAt: index * 2 - 1 put: (aFloat basicAt: 2). - self basicAt: index * 2 put: (aFloat basicAt: 1) ] - ifFalse: [ - self basicAt: index * 2 - 1 put: (aFloat basicAt: 1). - self basicAt: index * 2 put: (aFloat basicAt: 2) ]. - ^aFloat! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4624-Float64Array-fixForBigEndianFloatImageFormats-DaveLewis-2021May24-00h02m-dtl.001.cs.st----! - -'From Cuis 5.0 [latest update: #4624] on 2 June 2021 at 9:15:33 am'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 6/2/2021 09:08:33' prior: 50567841! - drawCurrentAsError - "The morph (or one of its submorphs) had an error in its drawing method." - | r r2 w | - r _ currentMorph morphLocalBounds. - w _ r extent > `50@50` - ifTrue: [ 6 ] - ifFalse: [ 2 ]. - r2 _ r origin corner: r corner-w. - self - frameAndFillRectangle: r - fillColor: `Color red` - borderWidth: w - borderColor: `Color yellow`. - self line: r2 topLeft to: r2 bottomRight width: w color: `Color yellow`. - self line: r2 topRight to: r2 bottomLeft width: w color: `Color yellow`. - currentMorph displayBoundsSetFrom: self.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4625-Nicer-drawCurrentAsError-JuanVuletich-2021Jun02-09h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4587] on 1 June 2021 at 1:31:25 pm'! - -Warning subclass: #ProceedBlockCannotReturn - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #ProceedBlockCannotReturn category: #'Exceptions Kernel' stamp: 'Install-4626-terminate-exceptions-JaromirMatas-2021May09-20h43m-jar.004.cs.st 7/20/2021 16:52:48'! -Warning subclass: #ProceedBlockCannotReturn - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! -!ContextPart methodsFor: 'private' stamp: 'jar 6/1/2021 10:06:30'! - runUnwindUntilErrorOrReturnFrom: aSender - "ASSUMES aSender is a sender of self. Execute self's stack until aSender returns or an unhandled exception is raised. Return a pair containing the new top context and a possibly nil exception. The exception is not nil if it was raised before aSender returned and it was not handled. The exception is returned rather than openning the debugger, giving the caller the choice of how to handle it." - "Self is run by jumping directly to it (the active process abandons thisContext and executes self). However, before jumping to self we insert an ensure block under aSender that jumps back to thisContext when evaluated. We also insert an exception handler under aSender that jumps back to thisContext when an unhandled exception is raised. In either case, the inserted ensure and exception handler are removed once control jumps back to thisContext." - "This method is used by Process>>#complete:to: for unwinding during termination." - - | error ctxt here topContext | - here _ thisContext. - - "Insert ensure and exception handler contexts under aSender" - error _ nil. - ctxt _ aSender insertSender: (ContextPart - contextOn: UnhandledError do: [:ex | - error ifNil: [ - error _ ex exception. - topContext _ thisContext. - here jump. - ex signalerContext restart] "re-signal the error if jumped back" - ifNotNil: [ex pass] - ]). - ctxt _ ctxt insertSender: (ContextPart - contextEnsure: [error ifNil: [ - topContext _ thisContext. - here jump] - ]). - self jump. "Control jumps to self" - - "Control resumes here once above ensure block or exception handler is executed" - ^ error ifNil: [ "No error was raised, return the sender of the above ensure context (see Note 1)" - {ctxt sender. nil} - - ] ifNotNil: [ "Error was raised, remove inserted above contexts then return signaler context" - aSender terminateTo: ctxt sender. "remove above ensure and handler contexts" - {topContext. error} - ] - -"Note 1: It doesn't matter 'ctxt sender' is not a proper top context because #terminate will use it only as a starting point in the search for the next unwind context and the computation will never return here. Removing the inserted ensure context (i.e. ctxt) by stepping until popped (as in #runUntilErrorOrReturnFrom:) when executing non-local returns is not applicable here and would fail testTerminationDuringNestedUnwindWithReturn1 through 4." -! ! -!Process methodsFor: 'private' stamp: 'jar 6/1/2021 10:14:38'! - complete: topContext to: aContext - "Run topContext on behalf of self on topContext's stack until aContext is popped or an unhandled - error is raised. Return self's new top context. Note: topContext must be a stack top context. - Note: This method is meant to be called primarily by Process>>#terminate." - - | pair top error | - pair _ topContext runUnwindUntilErrorOrReturnFrom: aContext. - top _ pair first. - error _ pair second. - "If an error was detected jump back to the debugged process and re-signal the error; - some errors may require a special care - see notes below." - error ifNotNil: [ - error class == ProceedBlockCannotReturn ifTrue: [^top]. "do not jump back" - error class == MessageNotUnderstood ifTrue: [error initialize]. "reset reachedDefaultHandler" - top jump]. - ^top - -"Note 1: To prevent an infinite recursion of the MessageNotUnderstood error, reset reachedDefaultHandler before jumping back; this will prevent #doesNotUnderstand: from resending the unknown message. -Note 2; To prevent returning from the BlockCannotReturn error, do not jump back when ProceedBlockCannotReturn warning has been raised."! ! -!ContextPart methodsFor: 'instruction decoding' stamp: 'jar 6/1/2021 12:14:16' prior: 16823895! - return: value from: aSender - "For simulation. Roll back self to aSender and return value from it. Execute any unwind blocks on the way. ASSUMES aSender is a sender of self" - - | newTop | - aSender isDead ifTrue: [ - ^ self send: #cannotReturn: to: self with: {value} super: false]. - newTop _ aSender sender. - (self findNextUnwindContextUpTo: newTop) ifNotNil: [ - ^ self send: #aboutToReturn:through: to: self with: {value. nil} super: false]. - self releaseTo: newTop. - newTop ifNotNil: [newTop push: value]. - ^ newTop -! ! -!ContextPart methodsFor: 'controlling' stamp: 'jar 6/1/2021 12:16:39' prior: 16824364! - resume: value through: firstUnwindCtxt - "Unwind thisContext to self and resume with value as result of last send. - Execute any unwind blocks while unwinding. - ASSUMES self is a sender of thisContext." - - | ctxt unwindBlock | - self isDead ifTrue: [self cannotReturn: value to: self]. - ctxt _ firstUnwindCtxt ifNil: [thisContext findNextUnwindContextUpTo: self]. - [ctxt isNil] whileFalse: - [(ctxt tempAt: 2) ifNil: - [ctxt tempAt: 2 put: true. - unwindBlock _ ctxt tempAt: 1. - thisContext terminateTo: ctxt. - unwindBlock value]. - ctxt _ ctxt findNextUnwindContextUpTo: self]. - thisContext terminateTo: self. - ^value -! ! -!MethodContext methodsFor: 'private' stamp: 'jar 6/1/2021 13:22:36' prior: 16871756! - cannotReturn: result - closureOrNil ifNotNil: [ - self cannotReturn: result to: self home sender. - ProceedBlockCannotReturn new signal: 'This block has ended, continue with sender?'. - ^thisContext privSender: self sender]. - Debugger - openContext: thisContext - label: 'computation has been terminated' - contents: nil! ! -!Process methodsFor: 'test support' stamp: 'jar 6/1/2021 11:57:00' prior: 50569245! - terminate - "Stop the process that the receiver represents forever. Unwind to execute pending ensure:/ifCurtailed: blocks before terminating. - Process termination and exception handling in border cases has been the subject of a deep overhaul in the first months of 2021, by Jaromir Matas. - See, for instance - https://lists.cuis.st/mailman/archives/cuis-dev/2021-May/003171.html - https://lists.cuis.st/mailman/archives/cuis-dev/2021-June/003187.html - You can also look for other related mail threads in the Cuis mail list. - Many new tests were added to BaseImageTests.pck.st - Thank you Jaromir for this important contribution!!" - - | ctxt unwindBlock oldList outerMost top newTop | - self isRunning ifTrue: [ - "If terminating the active process, suspend it first and terminate it as a suspended process." - [self terminate] fork. - ^self suspend]. - - [ "run the whole termination wrapped in #valueEnsured to ensure unwind is completed even if - the process terminating another process gets terminated - see #testTerminateInTerminate" - "Always suspend the process first so it doesn't accidentally get woken up" - oldList _ self suspend. - suspendedContext ifNil: [^self]. "self is already terminated" - "Figure out if we are terminating the process while waiting in Semaphore>>critical: - In this case, pop the suspendedContext so that we leave the ensure: block inside - Semaphore>>critical: without signaling the semaphore." - (oldList class == Semaphore and:[ - suspendedContext method == (Semaphore compiledMethodAt: #critical:)]) ifTrue: [ - suspendedContext _ suspendedContext home. - ]. - - top _ suspendedContext. - suspendedContext _ nil. "disable this process while running its stack in active process below" - "If terminating a process halfways through an unwind, try to complete that unwind block first; - if there are multiple such nested unwind blocks, try to complete the outer-most one; nested - unwind blocks will be completed in the process. Halfway-through blocks have already set the - complete variable (tempAt: 2) in their defining #ensure:/#ifCurtailed contexts from nil to true. - Note: #findNextUnwindContextUpTo: starts searching from the receiver's sender but the receiver - itself may be an unwind context." - ctxt _ top. - ctxt isUnwindContext ifFalse: [ctxt _ ctxt findNextUnwindContextUpTo: nil]. - [ctxt isNil] whileFalse: [ - (ctxt tempAt:2) ifNotNil: [ - outerMost _ ctxt]. - ctxt _ ctxt findNextUnwindContextUpTo: nil]. - outerMost ifNotNil: [newTop _ self complete: top to: outerMost]. - - "By now no halfway-through unwind blocks are on the stack. Create a new top context for each - pending unwind block (tempAt: 1) and execute it on the unwind block's stack. - Note: using #value instead of #complete:to: would lead to incorrect evaluation of non-local returns. - Note: newTop sender points to the former outerMost sender, i.e. the next unexplored context." - ctxt _ newTop ifNil: [top] ifNotNil: [newTop sender]. - ctxt isUnwindContext ifFalse: [ctxt _ ctxt findNextUnwindContextUpTo: nil]. - [ctxt isNil] whileFalse: [ - (ctxt tempAt: 2) ifNil: [ - ctxt tempAt: 2 put: true. - unwindBlock _ ctxt tempAt: 1. - top _ unwindBlock asContextWithSender: ctxt. - self complete: top to: top]. - ctxt _ ctxt findNextUnwindContextUpTo: nil] - ] valueEnsured! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4626-terminate-exceptions-JaromirMatas-2021May09-20h43m-jar.004.cs.st----! - -'From Cuis 5.0 [latest update: #4627] on 4 June 2021 at 10:08:56 am'! -!Process class methodsFor: 'documentation' stamp: 'jmv 6/4/2021 10:07:54'! - terminateExamples -" -This is the contents of the examples posted by Jaromir to exercise his worn on process termination and exceptions. -It was posted to the Cuis mail list at https://lists.cuis.st/mailman/archives/cuis-dev/2021-May/003171.html -(or maybe, it is a later version of edition of it if this comment is not up to date!!) - -Thanks Jaromir for this great contribution!! - -Workspace new - contents: Process terminateExamples; - openLabel: 'Jaromir Mata''s Process - terminate examples Cuis'. -" -^ - - - 'Process - Cuis terminate examples - -Some examples to illustrate the termination bugs and test the proposed rewrite of #terminate - -========================================== -terminate suspended: - -| p | -p := [ - [ - [ ] ensure: [ - [Processor activeProcess suspend] ensure: [ - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] - ] ensure: [ - Transcript show: ''''x3'''']. - Transcript show: ''''x4'''' -] newProcess. -p resume. -Processor yield. -p terminate. -Transcript show: p isTerminated printString - -"prints x1 x2 x3" - -| p | -p := [ - [ - [ ] ensure: [ - [ ] ensure: [ - Processor activeProcess suspend. - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] - ] ensure: [ - Transcript show: ''''x3'''']. - Transcript show: ''''x4'''' -] newProcess. -p resume. -Processor yield. -p terminate. -Transcript show: p isTerminated printString - -"prints x1 x2 x3" - -....................................... -terminate runnable: - -| p | -p := [ - [ - [ ] ensure: [ - [Processor yield] ensure: [ - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] - ] ensure: [ - Transcript show: ''''x3'''']. - Transcript show: ''''x4'''' -] newProcess. -p resume. -Processor yield. -p terminate. -Transcript show: p isTerminated printString - -"prints x1 x2 x3" - -| p | -p := [ - [ - [ ] ensure: [ - [ ] ensure: [ - Processor yield. - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] - ] ensure: [ - Transcript show: ''''x3'''']. - Transcript show: ''''x4'''' -] newProcess. -p resume. -Processor yield. -p terminate. -Transcript show: p isTerminated printString - -"prints x1 x2 x3" -....................................... -terminate blocked: - -| p s | -s := Semaphore new. -p := [ - [ - [ ] ensure: [ - [s wait] ensure: [ - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] - ] ensure: [ - Transcript show: ''''x3'''']. - Transcript show: ''''x4'''' -] newProcess. -p resume. -Processor yield. -p terminate. -Transcript show: p isTerminated printString - -"prints x1 x2 x3" - - -| p s | -s := Semaphore new. -p := [ - [ - [ ] ensure: [ - [ ] ensure: [ - s wait. - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] - ] ensure: [ - Transcript show: ''''x3'''']. - Transcript show: ''''x4'''' -] newProcess. -p resume. -Processor yield. -p terminate. -Transcript show: p isTerminated printString - -"prints x1 x2 x3" - -....................................... -terminate active: - -| p | -p := [ - [ - [ ] ensure: [ - [Processor activeProcess terminate] ensure: [ - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] - ] ensure: [ - Transcript show: ''''x3'''']. - Transcript show: ''''x4'''' -] newProcess. -p resume. -"Two yields necessary: terminate active is a two-step procedure" -Processor yield. Processor yield. -Transcript show: p isTerminated printString - -"prints x1 x2 x3" - - -| p | -p := [ - [ - [ ] ensure: [ - [ ] ensure: [ - Processor activeProcess terminate. - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] - ] ensure: [ - Transcript show: ''''x3'''']. - Transcript show: ''''x4'''' -] newProcess. -p resume. -"Two yields necessary: terminate active is a two-step procedure" -Processor yield. Processor yield. -Transcript show: p isTerminated printString - -"prints x1 x2 x3" - - - -========================================== -unhandled error: - -Termination happens when the user hits Abandon on the Debugger window. -"cf.: prints x1 x2 x3 x4 when hit Proceed" - -[ - [ ] ensure: [ - [self error: ''''unwind test''''] ensure: [ - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] -] ensure: [ - Transcript show: ''''x3'''']. -Transcript show: ''''x4'''' - -"prints x1 x2 x3" - - -[ - [ ] ensure: [ - [ ] ensure: [ - self error: ''''unwind test''''. - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] -] ensure: [ - Transcript show: ''''x3'''']. -Transcript show: ''''x4'''' - -"prints x1 x2 x3" - -........................ -nested unhandled errors: - -| p | -p := [ - [ - [ ] ensure: [ - [self error: ''''unwind test outer''''] ensure: [ - self error: ''''unwind test inner''''. - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] - ] ensure: [ - Transcript show: ''''x3'''']. - Transcript show: ''''x4'''' -] newProcess. -p resume. -Processor yield. -"prints x1 x2 x3" - - -triple nested errors: - -[self error: ''''outer error''''] ensure: [ - [self error: ''''middle error''''] ensure: [ - [self error: ''''inner error''''] ensure: [ - Transcript show: ''''x1'''']. - Transcript show: ''''x2'''']. - Transcript show: ''''x3'''']. -Transcript show: ''''x4'''' -"prints x1 x2 x3" -"same result when wrapped in fork" - - -[] ensure: [ -[self error: ''''outer error''''] ensure: [ - [self error: ''''middle error''''] ensure: [ - [self error: ''''inner error''''] ensure: [ - Transcript show: ''''x1'''']. - Transcript show: ''''x2'''']. - Transcript show: ''''x3'''']. -Transcript show: ''''x4''''] -"prints x1 x2 x3 x4" -"same result when wrapped in fork" - - - -========================================= -error and non-local return combined: - -Termination happens when the user hits Abandon on the Debugger window. - -........................ -non-local return inside inner-most halfway thru unwind block: - -[ - [ ] ensure: [ - [self error: ''''unwind test''''] ensure: [ - ^Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] -] ensure: [ - Transcript show: ''''x3'''']. -Transcript show: ''''x4'''' - -"prints x1 x3" - - -[ - [ ] ensure: [ - [ ] ensure: [ - self error: ''''unwind test''''. - ^Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] -] ensure: [ - Transcript show: ''''x3'''']. -Transcript show: ''''x4'''' - -"prints x1 x3" - -........................ -non-local return inside outer-most halfway thru unwind block: - -[ - [ ] ensure: [ - [self error: ''''unwind test''''] ensure: [ - Transcript show: ''''x1'''']. - ^Transcript show: ''''x2''''] -] ensure: [ - Transcript show: ''''x3'''']. -Transcript show: ''''x4'''' - -"prints x1 x2 x3" - - -[ - [ ] ensure: [ - [ ] ensure: [ - self error: ''''unwind test''''. - Transcript show: ''''x1'''']. - ^Transcript show: ''''x2''''] -] ensure: [ - Transcript show: ''''x3'''']. -Transcript show: ''''x4'''' - - -"prints x1 x2 x3" - - -"one more level..." -[ - [ - [ ] ensure: [ - [ ] ensure: [ - self error: ''''unwind test''''. - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] - ] ensure: [ - ^Transcript show: ''''x3''''] -] ensure: [ - Transcript show: ''''x4''''] - -"prints x1 x2 x3 x4 (even if wrapped in #fork)" - - - -............................. -non-local return outside halfway thru unwind blocks: - -[ - [ ] ensure: [ - [self error: ''''unwind test''''] ensure: [ - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] -] ensure: [ - ^Transcript show: ''''x3'''']. -Transcript show: ''''x4'''' - -"prints x1 x2 x3" - - -[ - [ ] ensure: [ - [ ] ensure: [ - self error: ''''unwind test''''. - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] -] ensure: [ - ^Transcript show: ''''x3'''']. -Transcript show: ''''x4'''' - - -"prints x1 x2 x3" - - -============================================================ -For comparison only: - -The tests presented here are not affected by the new #terminate. - -(A) an unhandled error unwind in the preceding examples followed the new termination logic completing all unwind blocks halfway through their execution -(B) a handled error unwind follows the traditional ''''direct'''' unwind path using simpler semantics - it doesn''''t complete unwind blocks halfway through their execution - -......................................... -handled error: - - -[ - [ - [ ] ensure: [ - [self error: ''''unwind test''''] ensure: [ - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] - ] ensure: [ - Transcript show: ''''x3''''] -] on: Error do: []. -Transcript show: ''''x4'''' - -"prints x1 x3 x4, skips x2" - -[ - [ - [ ] ensure: [ - [] ensure: [ - self error: ''''unwind test''''. - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] - ] ensure: [ - Transcript show: ''''x3''''] -] on: Error do: []. -Transcript show: ''''x4'''' - -"prints x3 x4, skips x1 x2" - -............................................ -nested handled errors: - -| p | -p := [ - [ - [ - [ ] ensure: [ - [self error: ''''unwind test outer''''] ensure: [ - self error: ''''unwind test inner''''. - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] - ] ensure: [ - Transcript show: ''''x3''''] - ] on: Error do: []. - Transcript show: ''''x4'''' -] newProcess. -p resume. -Processor yield. Processor yield. - -"prints x3 x4, skips x1 x2" - - - -............................................ -non-local return: - -Similarly a simple non-local return execution follows a ''''direct'''' unwind path logic in #resume[:through:] using simpler semantics. - -[ - [ ] ensure: [ - [^1] ensure: [ - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] -] ensure: [ - Transcript show: ''''x3'''']. -Transcript show: ''''x4'''' - -"prints x1 x3, skips x2" - - -[ - [ ] ensure: [ - [] ensure: [ - ^Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] -] ensure: [ - Transcript show: ''''x3'''']. -Transcript show: ''''x4'''' - -"prints x1 x3, skips x2" - - - -========================================== -Crazies: - -These tests explore new #teminate behavior under more extreme circumstances. - -Unwind after active process termination - -[ ] ensure: [ - [Processor activeProcess terminate] ensure: [Transcript show: ''''x1'''']. - Transcript show: ''''x2'''' - ] -"prints x1 x2 and terminates UI - recoverable via Alt+. or cmd+." - - -Unwind after active process suspension during termination: - -| p | -p := [ - [ - [ ] ensure: [ - [Processor activeProcess suspend] ensure: [ - Processor activeProcess suspend. - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] - ] ensure: [ - Transcript show: ''''x3''''] -] newProcess. -p resume. -Processor yield. -p terminate -"suspends UI and prints x1 x2 x3 after Alt+. recovery" - - -Unwind after double active process termination: - -| p | -p := [ - [ - [ ] ensure: [ - [Processor activeProcess terminate] ensure: [ - Processor activeProcess terminate. - Transcript show: ''''x1'''']. - Transcript show: ''''x2''''] - ] ensure: [ - Transcript show: ''''x3'''']. - Transcript show: ''''x4'''' -] newProcess. -p resume. -Processor yield. Processor yield. Processor yield. Processor yield. -Transcript show: p isTerminated printString -"lets UI live and prints x1 x2 x3" - - -| p | -p := [ - [] ensure: [ - Processor activeProcess terminate. Transcript show: ''''x1''''. - Processor activeProcess terminate. Transcript show: ''''x2'''']. -] newProcess. -p resume. -Processor yield. Processor yield. Processor yield. Processor yield. -Transcript show: p isTerminated printString -"lets current UI live and prints x1 x2" - - -| p ap | -p := [ - [ ap := Processor activeProcess. ap terminate. Transcript show: ''''x1'''' ] - ensure: [ ap terminate. Transcript show: ''''x2'''' ]. -] newProcess. -p resume. -Processor yield. Processor yield. Processor yield. -Transcript show: p isTerminated printString -"lets current UI live and prints x2" - - -| p | -p := [ - [ Processor activeProcess terminate ] - ensure: [ Processor activeProcess terminate ]. -] newProcess. -p resume. -Processor yield. Processor yield. Processor yield. -Transcript show: p isTerminated printString -"answers true, no error" - - - -Unwind after active process termination combined with non-local return: - -| p | -p := [ - [] ensure: [ - Processor activeProcess terminate. Transcript show: ''''x1''''. - true ifTrue: [^2]. - Processor activeProcess terminate. Transcript show: ''''x2''''] -] newProcess. -p resume. -Processor yield. Processor yield. -Transcript show: p isTerminated printString -"prints x1 and correctly raises BlockCannotReturn error" - - -Unwind after BlockCannotReturn error: - -| p a | - -a := Array new: 4 withAll: false. -p := [ - [ - [ ] ensure: [ - [Processor activeProcess suspend] ensure: [ - ^a at: 1 put: true]. - a at: 2 put: true] - ] ensure: [a at: 3 put: true]. - a at: 4 put: true - ] newProcess. -p resume. -Processor yield. -"make sure p is suspended and none of the unwind blocks has finished yet" -self assert: p isSuspended. -a noneSatisfy: [ :b | b ]. -"now terminate the process and make sure all unwind blocks have finished" -p terminate. -self assert: p isTerminated. -self assert: a first & a third. -self assert: (a second | a fourth) not. -"---> #(true false true false) ...OK" - - -Triple nested active process terminate: - -[ x := ''''''''. - [Processor activeProcess terminate] ensure: [ - [Processor activeProcess terminate] ensure: [ - [Processor activeProcess terminate] ensure: [ - x:=x,''''3'''']. - x:=x,''''2'''']. - x:=x,''''1'''']. - x:=x,''''0'''' -] fork -x -"---> ''''321'''' ...OK" - -Same as before but without fork: - -x := ''''''''. -[Processor activeProcess terminate] ensure: [ - [Processor activeProcess terminate] ensure: [ - [Processor activeProcess terminate] ensure: [ - x:=x,''''3'''']. - x:=x,''''2'''']. - x:=x,''''1'''']. -x:=x,''''0'''' -x -"terminates UI and answers ---> ''''321'''' after Alt+. recovery" -(Squeak crashes irrecoverably)" - - -Triple nested active process terminate: - -p := -[ x := ''''''''. - [] ensure: [ - [Processor activeProcess suspend] ensure: [ - [Processor activeProcess suspend] ensure: [ - [Processor activeProcess suspend] ensure: [ - x:=x,''''3'''']. - x:=x,''''2'''']. - x:=x,''''1'''']. - x:=x,''''0''''] -] newProcess resume. -Processor yield. -p terminate -x -"Cuis suspends UI repeatedly but answers ---> ''''3210'''' after repeated Alt+. recovery -Squeak answers ---> ''''3210'''' without suspending UI - why the difference? -Without fork Squeak suspends UI just once but Cuis 3 times, both answer x correctly" - - -These behave as expected and won''''t crash the image even after proceeding the BlockCannotReturn error: - -[^2] fork - -[[self error: ''''error''''] ensure: [^2]] fork - -do-it: -"Both statements need to be executed separately in a Workspace" -a := [true ifTrue: [^ 1] yourself] -[a value] on: BlockCannotReturn do: [:ex | ex resume] - -do-it: -"Both statements need to be executed separately in a Workspace" -a := [true ifTrue: [^ 1]. 2] -a value - -These will deal with MessageNotUnderstood correctly and won''''t crash the image or loop infinitely - -[] ensure: [self gotcha. Transcript show: ''''0''''] - -[] ensure: [[self gotcha] ensure: [self halt. Transcript show: ''''0'''']] - -[self error: ''''error''''] ensure: [[self gotcha] ensure: [Transcript show: ''''0'''']] - -[self error: ''''error''''] ensure: [self gotcha. Transcript show: ''''0''''] - -This one freezes UI after Halt -> Proceed but recoverable via Alt+. -[[] ensure: [[self gotcha] ensure: [self halt. Transcript show: ''''0'''']]] fork. - - - -=============== -Some additional unsorted examples: - -"This example should show both ZeroDivide and MessageNotUnderstood errors" - -x1 := x2 := x3 := nil. -p:=[ - [ - [ ] ensure: [ "halfway through completion when suspended" - [ ] ensure: [ "halfway through completion when suspended" - Processor activeProcess suspend. - x1 := (2 / 0 "error!!") > 0]. - x2 := true] - ] ensure: [ "not started yet when suspended" - x3 := true] -] newProcess resume. -Processor yield. -p terminate -{x1 . x2 . x3} ---> #(MessageNotUnderstood: ZeroDivide>>> true true) - - -'! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4627-Jaromir-s-Process-terminate-examples-JuanVuletich-2021Jun04-10h00m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4627] on 4 June 2021 at 3:38:24 pm'! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'jmv 6/4/2021 15:35:46' prior: 50486389! - withMethodNodeAndClassDo: aBlock ifErrorsParsing: anErrorBlock - - | selectedClass methodNode | - - "I have to do this because some codeProviders do no answer selectedClassOrMetaClass like the Workspace - Hernan" - selectedClass := [ self codeProvider selectedClassOrMetaClass ] on: Error do: [ :anError | anError return: UndefinedObject ]. - [ - [ methodNode := selectedClass methodNodeFor: model actualContents asString ] - on: UndeclaredVariableWarning do: [ :ex | ex resume ] - ] on: Error do: [ :anError | ^ anErrorBlock value: anError ]. - - ^aBlock value: methodNode value: selectedClass.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4628-AvoidSuperfluousNotification-JuanVuletich-2021Jun04-15h37m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4532] on 5 June 2021 at 8:38:51 pm'! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 6/5/2021 20:32:51'! - implementorsIsOnlyOneTestMethod - - ^ implementors size = 1 and: [ implementors anyOne isTestMethod ]! ! -!ChangeSelectorApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 6/5/2021 20:32:58' prior: 50441611! - startWizard - - self implementorsIsOnlyOneTestMethod - ifTrue: [ self doNotShowChanges; wizardEnded ] - ifFalse: [ ChangeSelectorImplementorsStepWindow openFrom: self ]! ! -!ChangeSelectorApplier methodsFor: 'refactoring - changes' stamp: 'HAW 6/5/2021 20:27:47' prior: 50441645! - closeBrowser - - wizardStepWindow ifNotNil: [ wizardStepWindow delete ] ! ! -!ChangeSelectorApplier methodsFor: 'evaluation' stamp: 'HAW 6/5/2021 20:12:33' prior: 50441743 overrides: 50441449! - value - - requestExitBlock := [ ^self ]. - - self requestRefactoringParametersHandlingRefactoringExceptions. - - self - ifHasNoSendersAndOneImplementor: [ :anImplementor | - self createAndApplyRefactoringWhenNoSendersAndOneImplementor: anImplementor ] - ifNot: [ self askForImplementosAndSenders ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4629-RenameTestUIAcceleration-HernanWilkinson-2021Apr30-19h32m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4532] on 5 June 2021 at 8:39:29 pm'! -!PluggableListMorphOfMany methodsFor: 'events' stamp: 'HAW 6/5/2021 20:39:06' prior: 50380547 overrides: 50426132! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - - | oldIndex oldVal row w | - self hasKeyboardFocus ifFalse: [ - aMouseButtonEvent hand newKeyboardFocus: self ]. - - row _ self rowAtLocation: localEventPosition. - - row = 0 ifTrue: [ - ^super mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition ]. - - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - self listMorph highlightedRow: row. - - w _ self owningWindow. - (w isNil or: [ w okToChange ]) ifTrue: [ "No change if model is locked" - - "Set meaning for subsequent dragging of selection" - dragOnOrOff _ (self listSelectionAt: row) not. - dragStartRow _ row. - oldIndex _ self getCurrentSelectionIndex. - oldIndex ~= 0 ifTrue: [oldVal _ self listSelectionAt: oldIndex]. - - "Different from PluggableListMorph. There, we highlight on mouse down, and act on mouse up. - Here, we act on mouse down, because we support dragging of selection, so mouse up will - only happen after user is finished dragging. In order to get the highlight visible for the user, - update the model on next world cycle." - UISupervisor whenUIinSafeState: [ - "Set or clear new primary selection (listIndex)" - dragOnOrOff == true - ifTrue: [self setSelectionIndex: row] - ifFalse: [self setSelectionIndex: 0]. - "Need to restore the old one, due to how model works, and set new one." - oldIndex ~= 0 ifTrue: [self listSelectionAt: oldIndex put: oldVal]. - self listSelectionAt: row put: dragOnOrOff ]. - ]. - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: nil - clkNHalf: nil - dblClkSel: #doubleClick:localPosition: - dblClkNHalfSel: nil - tripleClkSel: nil! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4630-PluggableListMorphOfMany-HernanWilkinson-2021Jun05-20h38m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4630] on 6 June 2021 at 7:13:11 pm'! -!Editor methodsFor: 'new selection' stamp: 'jmnv 6/6/2021 19:12:36' prior: 50541901! - wordRangeLeftDelimiters: leftDelimiters rightDelimiters: rightDelimiters - "Select delimited text or word--the result of double-clicking." - ^ self - wordRangeLeftDelimiters: leftDelimiters - rightDelimiters: rightDelimiters - startingAt: self pointIndex.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4631-WordSelectionFix-YourName-2021Jun06-18h59m-jmnv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4631] on 6 June 2021 at 7:50:16 pm'! -!TextModelMorph methodsFor: 'events' stamp: 'jmnv 6/6/2021 19:23:59' prior: 50458722 overrides: 50458663! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - - | eventPositionLocalToScroller | - eventPositionLocalToScroller _ localEventPosition - scroller morphPosition. - scroller mouseButton1Down: aMouseButtonEvent localPosition: eventPositionLocalToScroller. - - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: nil - clkNHalf: #clickAndHalf:localPosition: - dblClkSel: nil - dblClkNHalfSel: #doubleClickAndHalf:localPosition: - tripleClkSel: nil! ! - -TextModelMorph removeSelector: #doubleClick:localPosition:! - -!methodRemoval: TextModelMorph #doubleClick:localPosition: stamp: 'Install-4632-TextModelMorph-cleanup-JuanVuletich-2021Jun06-19h49m-jmv.001.cs.st 7/20/2021 16:52:49'! -doubleClick: aMouseButtonEvent localPosition: localEventPosition - - self textMorph doubleClick: aMouseButtonEvent localPosition: localEventPosition! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4632-TextModelMorph-cleanup-JuanVuletich-2021Jun06-19h49m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4630] on 6 June 2021 at 7:32:25 pm'! -!TextEditor methodsFor: 'events' stamp: 'jmnv 6/6/2021 19:30:28' prior: 16931964! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - | b | - - initialSelectionStart _ nil. - initialSelectionStop _ nil. - doWordSelection _ false. - doParagraphSelection _ false. - - "Multiple selection of text. - Windows uses Control, Mac uses Command (i.e. commandAlt) - On the Mac, command-button1 is translated to command-button3 by the VM. do: - Preferences disable: #commandClickOpensHalo - to disable this behavior and make command-button1 work for multiple selection. " - (aMouseButtonEvent controlKeyPressed or: [ aMouseButtonEvent commandAltKeyPressed ]) ifTrue: [ - self selectionInterval size > 0 ifTrue: [ - selectionStartBlocks _ selectionStartBlocks copyWith: self startBlock. - selectionStopBlocks _ selectionStopBlocks copyWith: self stopBlock ]] - ifFalse: [ - selectionStartBlocks _ #(). - selectionStopBlocks _ #() ]. - - b _ textComposition characterBlockAtPoint: localEventPosition. - - (textComposition clickAt: localEventPosition) ifTrue: [ - markBlock _ b. - pointBlock _ b. - aMouseButtonEvent hand releaseKeyboardFocus: self. - ^ self ]. - - aMouseButtonEvent shiftPressed - ifFalse: [ - markBlock _ b. - pointBlock _ b. - self setEmphasisHereFromText ]! ! -!MouseClickState methodsFor: 'actions' stamp: 'jmnv 6/6/2021 19:32:17' prior: 50565309! - handleEvent: aMouseEvent from: aHand - "Process the given mouse event to detect a click, double-click, or drag. - Return true if the event should be processed by the sender, false if it shouldn't. - NOTE: This method heavily relies on getting *all* mouse button events." - - | timedOut distance | - timedOut _ (aMouseEvent timeStamp - lastClickDown timeStamp) > self class doubleClickTimeout. - timedOut ifTrue: [ aHand dontWaitForMoreClicks ]. - distance _ (aMouseEvent eventPosition - lastClickDown eventPosition) r. - "Real action dispatch might be done after the triggering event, for example, because of waiting for timeout. - So, count the button downs and ups(clicks), to be processed, maybe later, maybe in a mouseMove..." - aMouseEvent isMouseDown ifTrue: [ - lastClickDown _ aMouseEvent. - buttonDownCount _ buttonDownCount + 1 ]. - aMouseEvent isMouseUp ifTrue: [ - buttonUpCount _ buttonUpCount + 1 ]. - - "Simulate button 2 if timeout during first click (i.e. tap & hold). Useful for opening menus on pen computers." - (buttonDownCount = 1 and: [ buttonUpCount = 0]) ifTrue: [ - (timedOut and: [ sendMouseButton2Activity and: [ distance = 0]]) ifTrue: [ - aHand dontWaitForMoreClicks. - clickClient mouseButton2Activity. - ^ false ]. - "If we have already moved, then it won't be a double or triple click... why wait?" - (timedOut or: [distance > 0]) ifTrue: [ - aHand dontWaitForMoreClicks. - dragSelector - ifNotNil: [ self didDrag ]. - ^ false ]]. - - "If we're over triple click, or timed out, or mouse moved, don't allow more clicks." - (buttonDownCount = 4 or: [ timedOut or: [ distance > 0 ]]) ifTrue: [ - aHand dontWaitForMoreClicks. - ^ false ]. - - "Simple click." - (buttonDownCount = 1 and: [ buttonUpCount = 1 ]) ifTrue: [ - self didClick ]. - - "Click & hold" - (buttonDownCount = 2 and: [ buttonUpCount = 1]) ifTrue: [ - self didClickAndHalf ]. - - "Double click." - (buttonDownCount = 2 and: [ buttonUpCount = 2]) ifTrue: [ - self didDoubleClick ]. - - "Double click & hold." - (buttonDownCount = 3 and: [ buttonUpCount = 2]) ifTrue: [ - self didDoubleClickAndHalf ]. - - "Triple click" - (buttonDownCount = 3 and: [ buttonUpCount = 3]) ifTrue: [ - self didTripleClick ]. - - "This means: if a mouseDown, then don't further process this event (so we can turn it into a double or triple click on next buttonUp)" - ^ aMouseEvent isMouseDown! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4633-TextEditorFix-YourName-2021Jun06-19h25m-jmnv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4630] on 6 June 2021 at 7:13:11 pm'! -!Editor methodsFor: 'new selection' stamp: 'jmv 6/6/2021 19:12:36' prior: 50573496! - wordRangeLeftDelimiters: leftDelimiters rightDelimiters: rightDelimiters - "Select delimited text or word--the result of double-clicking." - ^ self - wordRangeLeftDelimiters: leftDelimiters - rightDelimiters: rightDelimiters - startingAt: self pointIndex.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4634-WordSelectionFix-JuanVuletich-2021Jun06-18h59m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4630] on 6 June 2021 at 7:32:25 pm'! -!TextEditor methodsFor: 'events' stamp: 'jmv 6/6/2021 19:30:28' prior: 50573554! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - | b | - - initialSelectionStart _ nil. - initialSelectionStop _ nil. - doWordSelection _ false. - doParagraphSelection _ false. - - "Multiple selection of text. - Windows uses Control, Mac uses Command (i.e. commandAlt) - On the Mac, command-button1 is translated to command-button3 by the VM. do: - Preferences disable: #commandClickOpensHalo - to disable this behavior and make command-button1 work for multiple selection. " - (aMouseButtonEvent controlKeyPressed or: [ aMouseButtonEvent commandAltKeyPressed ]) ifTrue: [ - self selectionInterval size > 0 ifTrue: [ - selectionStartBlocks _ selectionStartBlocks copyWith: self startBlock. - selectionStopBlocks _ selectionStopBlocks copyWith: self stopBlock ]] - ifFalse: [ - selectionStartBlocks _ #(). - selectionStopBlocks _ #() ]. - - b _ textComposition characterBlockAtPoint: localEventPosition. - - (textComposition clickAt: localEventPosition) ifTrue: [ - markBlock _ b. - pointBlock _ b. - aMouseButtonEvent hand releaseKeyboardFocus: self. - ^ self ]. - - aMouseButtonEvent shiftPressed - ifFalse: [ - markBlock _ b. - pointBlock _ b. - self setEmphasisHereFromText ]! ! -!MouseClickState methodsFor: 'actions' stamp: 'jmv 6/6/2021 19:32:17' prior: 50573595! -handleEvent: aMouseEvent from: aHand - "Process the given mouse event to detect a click, double-click, or drag. - Return true if the event should be processed by the sender, false if it shouldn't. - NOTE: This method heavily relies on getting *all* mouse button events." - - | timedOut distance | - timedOut _ (aMouseEvent timeStamp - lastClickDown timeStamp) > self class doubleClickTimeout. - timedOut ifTrue: [ aHand dontWaitForMoreClicks ]. - distance _ (aMouseEvent eventPosition - lastClickDown eventPosition) r. - "Real action dispatch might be done after the triggering event, for example, because of waiting for timeout. - So, count the button downs and ups(clicks), to be processed, maybe later, maybe in a mouseMove..." - aMouseEvent isMouseDown ifTrue: [ - lastClickDown _ aMouseEvent. - buttonDownCount _ buttonDownCount + 1 ]. - aMouseEvent isMouseUp ifTrue: [ - buttonUpCount _ buttonUpCount + 1 ]. - - "Simulate button 2 if timeout during first click (i.e. tap & hold). Useful for opening menus on pen computers." - (buttonDownCount = 1 and: [ buttonUpCount = 0]) ifTrue: [ - (timedOut and: [ sendMouseButton2Activity and: [ distance = 0]]) ifTrue: [ - aHand dontWaitForMoreClicks. - clickClient mouseButton2Activity. - ^ false ]. - "If we have already moved, then it won't be a double or triple click... why wait?" - (timedOut or: [distance > 0]) ifTrue: [ - aHand dontWaitForMoreClicks. - dragSelector - ifNotNil: [ self didDrag ]. - ^ false ]]. - - "If we're over triple click, or timed out, or mouse moved, don't allow more clicks." - (buttonDownCount = 4 or: [ timedOut or: [ distance > 0 ]]) ifTrue: [ - aHand dontWaitForMoreClicks. - ^ false ]. - - "Simple click." - (buttonDownCount = 1 and: [ buttonUpCount = 1 ]) ifTrue: [ - self didClick ]. - - "Click & hold" - (buttonDownCount = 2 and: [ buttonUpCount = 1]) ifTrue: [ - self didClickAndHalf ]. - - "Double click." - (buttonDownCount = 2 and: [ buttonUpCount = 2]) ifTrue: [ - self didDoubleClick ]. - - "Double click & hold." - (buttonDownCount = 3 and: [ buttonUpCount = 2]) ifTrue: [ - self didDoubleClickAndHalf ]. - - "Triple click" - (buttonDownCount = 3 and: [ buttonUpCount = 3]) ifTrue: [ - self didTripleClick ]. - - "This means: if a mouseDown, then don't further process this event (so we can turn it into a double or triple click on next buttonUp)" - ^ aMouseEvent isMouseDown! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4635-TextEditorFix-JuanVuletich-2021Jun06-19h25m-jmnv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4635] on 9 June 2021 at 12:46:01 pm'! -!FileIOAccessor methodsFor: 'primitives' stamp: 'jmv 6/9/2021 12:37:54'! - primFixedNameLookupEntryIn: fullPathAsUTF8 index: index - "Fix the malformed String answered by the primitive. See comment at #primLookupEntryIn:index:" - - | answer | - answer _ self primLookupEntryIn: fullPathAsUTF8 index: index. - answer isArray ifTrue: [ - answer at: 1 put: (String fromUtf8: answer first asByteArray) ]. - ^answer! ! -!FileList methodsFor: 'private' stamp: 'jmv 6/9/2021 12:38:46' prior: 16843033! - readContentsBrief: brevityFlag - "Read the contents of the receiver's selected file, unless it is too long, in which case show just the first 5000 characters. Don't create a file if it doesn't already exist." - | fileSize first50000 | - -directory // fileName readStreamDo: [ :f | - f ifNil: [^ 'For some reason, this file cannot be read' halt]. - (brevityFlag not or: [(fileSize := f size) <= 2000000]) ifTrue: [ - acceptedContentsCache _ f contentsOfEntireFile. - brevityState := #fullFile. "don't change till actually read" - ^ acceptedContentsCache ]. - - "if brevityFlag is true, don't display long files when first selected" - first50000 := f next: 50000. -]. - acceptedContentsCache _ -'File ''{1}'' is {2} bytes long. -You may use the ''get'' command to read the entire file. - -Here are the first 50000 characters... ------------------------------------------- -{3} ------------------------------------------- -... end of the first 50000 characters.' format: {fileName. fileSize. first50000}. - brevityState := #briefFile. "don't change till actually read" - ^ acceptedContentsCache! ! -!StandardFileStream methodsFor: 'open/close' stamp: 'jmv 6/9/2021 12:43:48' prior: 16912957! - open: fileName forWrite: writeMode - "Open the file with the given name. If writeMode is true, allow writing, otherwise open the file in read-only mode." - "Changed to do a GC and retry before failing ar 3/21/98 17:25" - fileID _ StandardFileStream retryWithGC: [ self primOpen: (fileName asUtf8: true) writable: writeMode ] - until: [ :id | id notNil ] - forFileNamed: fileName. - fileID ifNil: [^ nil]. "allows sender to detect failure" - name _ fileName. - "jmv: Register after setting name. Name is assumed to be defined for registered objects." - self register. - rwmode _ writeMode. - buffer1 _ String new: 1. - self enableReadBuffering -! ! -!StandardFileStream methodsFor: 'primitives' stamp: 'jmv 6/9/2021 12:42:59' prior: 16913551! - primOpen: fileNameAsUTF8 writable: writableFlag - "Open a file of the given name, and return the file ID obtained. - If writableFlag is true, then - if there is none with this name, then create one - else prepare to overwrite the existing from the beginning - otherwise - if the file exists, open it read-only - else return nil" - - - ^ nil -! ! -!FileIOAccessor methodsFor: 'actions' stamp: 'jmv 6/9/2021 12:19:11' prior: 16841682! - createDirectory: fullPathName - self primCreateDirectory: (fullPathName asUtf8: true)! ! -!FileIOAccessor methodsFor: 'actions' stamp: 'jmv 6/9/2021 12:19:31' prior: 16841687! - deleteDirectory: fullPathName - self primDeleteDirectory: (fullPathName asUtf8: true)! ! -!FileIOAccessor methodsFor: 'actions' stamp: 'jmv 6/9/2021 12:12:22' prior: 16841697! - deleteFile: fullPathName ifAbsent: failBlock - ^(self - try: [self primDeleteFileNamed: (fullPathName asUtf8: true)] - forFileNamed: fullPathName) - ifFalse: [^ failBlock value]! ! -!FileIOAccessor methodsFor: 'actions' stamp: 'jmv 6/9/2021 12:16:29' prior: 16841716! - rename: oldFileFullName to: newFileFullName - | selection | - (self try: [self primRename: (oldFileFullName asUtf8: true) to: (newFileFullName asUtf8: true) ] - forFileNamed: oldFileFullName) ifTrue: [^ self]. - - oldFileFullName asFileEntry exists ifFalse: [^ self error: 'Attempt to rename a non-existent file']. - (newFileFullName asFileEntry exists or: [ newFileFullName asDirectoryEntry exists ]) - ifTrue: [ - selection := (PopUpMenu labels: 'delete old version -cancel') - startUpWithCaption: 'Trying to rename a file to be -' , newFileFullName , ' -and it already exists.'. - selection = 1 - ifTrue: [self deleteFile: newFileFullName. - ^ self rename: oldFileFullName to: newFileFullName]]. - ^ self error: 'Failed to rename file'! ! -!FileIOAccessor methodsFor: 'actions' stamp: 'jmv 6/9/2021 12:16:54' prior: 16841741! -renameDirectory: oldFileFullName to: newFileFullName - | selection | - (self try: [self primRename: (oldFileFullName asUtf8: true) to: (newFileFullName asUtf8: true) ] - forFileNamed: oldFileFullName) ifTrue: [^ self]. - - oldFileFullName asDirectoryEntry exists ifFalse: [^ self error: 'Attempt to rename a non-existent file']. - newFileFullName asDirectoryEntry exists - ifTrue: [selection := (PopUpMenu labels: 'delete old version -cancel') - startUpWithCaption: 'Trying to rename a directory to be -' , newFileFullName , ' -and it already exists.'. - selection = 1 - ifTrue: [newFileFullName asDirectoryEntry recursiveDelete. - ^ self renameDirectory: oldFileFullName to: newFileFullName]]. - ^ self error: 'Failed to rename file'! ! -!FileIOAccessor methodsFor: 'private' stamp: 'jmv 6/9/2021 12:36:06' prior: 50422952! - basicDirectoryExists: fullPathName - - ^( - (self primLookupEntryIn: (fullPathName asUtf8: true) index: 1) - == #badDirectoryPath - ) not! ! -!FileIOAccessor methodsFor: 'private' stamp: 'jmv 6/9/2021 12:33:47' prior: 50406483! - entriesIn: parentEntryOrNil - " - Warning: Private. Only to be called from within FileMan. - Accepts nil as argument, but behavior depends on platform. - -Windows (nil means root) -FileIOAccessor default entriesIn: nil #(C:\ D:\) -(FileIOAccessor default entriesIn: '' asDirectoryEntry) = (FileIOAccessor default entriesIn: '.' asDirectoryEntry) true -FileIOAccessor default entriesIn: '/' asDirectoryEntry #(\$Recycle.Bin \Config.Msi \Documents and Settings \gratMusic \hiberfil.sys \Intel \pagefile.sys \PerfLogs \Program Files \Program Files (x86) \ProgramData \Python27 \Recovery \SimuloHoy \System Volume Information \totalcmd \Users \Windows) - -Linux (nil means current dir, like '' and '.') -FileIOAccessor default entriesIn: nil #(Lots of stuff in current directory) -(FileIOAccessor default entriesIn: nil) = (FileIOAccessor default entriesIn: '.' asDirectoryEntry) true -(FileIOAccessor default entriesIn: '' asDirectoryEntry) = (FileIOAccessor default entriesIn: '.' asDirectoryEntry) true -FileIOAccessor default entriesIn: '/' asDirectoryEntry #(/vmlinuz /boot /sbin /srv /lib /lib32 /tmp /sys /home /etc /initrd.img /bin /dev /opt /proc /lost+found /var /root /lib64 /mnt /usr /run /media) - -MacOsX (nil means current dir, like '' and '.') -FileIOAccessor default entriesIn: nil #(/Volumes/SanDisk32-NTFS/CuisTest/2554-REVISAR-JuanVuletich-2015Oct21-16h40m-jmv.1.cs.st /Volumes/SanDisk32-NTFS/CuisTest/Cog.app /Volumes/SanDisk32-NTFS/CuisTest/Cog.app.tgz /Volumes/SanDisk32-NTFS/CuisTest/Cuis4.2-2553.changes /Volumes/SanDisk32-NTFS/CuisTest/Cuis4.2-2553.image /Volumes/SanDisk32-NTFS/CuisTest/CuisV4.sources) -(FileIOAccessor default entriesIn: '' asDirectoryEntry) = (FileIOAccessor default entriesIn: '.' asDirectoryEntry) true -FileIOAccessor default entriesIn: '/' asDirectoryEntry #(/.dbfseventsd /.DocumentRevisions-V100 /.DS_Store /.file /.fseventsd /.hotfiles.btree /.Spotlight-V100 /.Trashes /.vol /Applications /bin /cores /dev /etc /home /installer.failurerequests /Library /net /Network /opt /private /sbin /System /tmp /Users /usr /var /Volumes) - - " - | entries index done entryArray entry isDirectory lookIn | - entries _ OrderedCollection new: 200. - index _ 1. - done _ false. - lookIn _ parentEntryOrNil ifNil: [''] ifNotNil: [parentEntryOrNil pathName]. - [done] whileFalse: [ - entryArray _ self primFixedNameLookupEntryIn: (lookIn asUtf8: true) index: index. - #badDirectoryPath == entryArray ifTrue: [ - ^#()]. - entryArray == nil - ifTrue: [done _ true] - ifFalse: [ - isDirectory _ entryArray at: 4. - entry _ isDirectory ifTrue: [DirectoryEntry new] ifFalse: [FileEntry new]. - entry name: (entryArray at: 1) parent: parentEntryOrNil. - entry updateFrom: entryArray entryInParent: index. - entries addLast: entry ]. - index _ index + 1]. - - ^entries asArray! ! -!FileIOAccessor methodsFor: 'private' stamp: 'jmv 6/9/2021 12:34:06' prior: 50406739! - updateEntry: aFileSystemEntry - | entryArray index lookIn isDirectory | - - "If the index in aFileSystemEntry is valid, use it. No need to iterate over all entries." - aFileSystemEntry primEntryInParent ifNotNil: [ :tentativeIndex | - (self primFixedNameLookupEntryIn: (aFileSystemEntry parent pathName asUtf8: true) index: tentativeIndex) ifNotNil: [ :found | - found == #badDirectoryPath ifFalse: [ - aFileSystemEntry name = (found at: 1) ifTrue: [ - aFileSystemEntry updateFrom: found entryInParent: tentativeIndex. - ^ self ]]]]. - - "Otherwise, do a full iteration" - lookIn _ aFileSystemEntry parent pathName. - index _ 1. - [ - entryArray _ self primFixedNameLookupEntryIn: (lookIn asUtf8: true) index: index. - #badDirectoryPath == entryArray ifTrue: [ - ^ self]. - entryArray == nil ifTrue: [ - ^ self]. - isDirectory _ entryArray at: 4. - aFileSystemEntry name = (entryArray at: 1) ifTrue: [ - isDirectory == aFileSystemEntry isDirectory ifTrue: [ - aFileSystemEntry updateFrom: entryArray entryInParent: index ]. - "If found, exit even if invalid. No point to keep iterating." - ^ self ]. - index _ index + 1] repeat! ! -!FileIOAccessor methodsFor: 'primitives' stamp: 'jmv 6/9/2021 12:42:23' prior: 16842189! - primCreateDirectory: fullPathAsUTF8 - "Create a directory named by the given path. Fail if the path is bad or if a file or directory by that name already exists." - - - self primitiveFailed -! ! -!FileIOAccessor methodsFor: 'primitives' stamp: 'jmv 6/9/2021 12:42:19' prior: 16842199! - primDeleteDirectory: fullPathAsUTF8 - "Delete the directory named by the given path. Fail if the path is bad or if a directory by that name does not exist." - - - self primitiveFailed -! ! -!FileIOAccessor methodsFor: 'primitives' stamp: 'jmv 6/9/2021 12:42:14' prior: 16842209! - primDeleteFileNamed: aFileNameAsUTF8 - "Delete the file of the given name. Return self if the primitive succeeds, nil otherwise." - - - ^ nil -! ! -!FileIOAccessor methodsFor: 'primitives' stamp: 'jmv 6/9/2021 12:31:59' prior: 16842218! - primLookupEntryIn: fullPathAsUTF8 index: index - "Look up the index-th entry of the directory with the given fully-qualified path (i.e., starting from the root of the file hierarchy) and return an array containing: - - - - On MacOS and Windows, the empty string enumerates the mounted volumes/drives. - - On Linux, it is equivalent to '.', and lists the contents of DirectoryEntry currentDirectory. - - The creation and modification times are in seconds since the start of the Smalltalk time epoch. DirFlag is true if the entry is a directory. FileSize the file size in bytes or zero for directories. The primitive returns nil when index is past the end of the directory. It fails if the given path is bad. - - Warning: The 'name' field is an instance of String, but in reality it contains the bytes for its UTF-8 representation. - For instance, if the real name is 'puño' we'll get 'puño', as - (String withAll: ('puño' asUtf8 asArray collect: [ :n | Character numericValue: n ])) = 'puño' - Senders MUST do appropriate conversion. - - Consider calling #primFixedNameLookupEntryIn:index: instead. - " - - - ^ #badDirectoryPath - -! ! -!FileIOAccessor methodsFor: 'primitives' stamp: 'jmv 6/9/2021 12:15:55' prior: 16842256! - primRename: oldFileFullNameAsUTF8 to: newFileFullNameAsUTF8 - "Rename the file of the given name to the new name. Fail if there is no file of the old name or if there is an existing file with the new name. - Changed to return nil instead of failing ar 3/21/98 18:04" - - - ^nil! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4636-UnicodeInFilenames-JuanVuletich-2021Jun09-12h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4636] on 16 June 2021 at 11:26:02 am'! -!DebuggerWindow methodsFor: 'context stack menu' stamp: 'jmv 6/16/2021 11:25:26'! - peelToFirst - - ^ self ifOkToChangeCodePaneDo: [ model peelToFirst ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4637-DebuggerWindowPeelToFirst-JuanVuletich-2021Jun16-11h25m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4637] on 17 June 2021 at 1:03:07 pm'! -!Preferences class methodsFor: 'standard queries' stamp: 'jmv 6/17/2021 13:02:51' prior: 0! - tapAndHoldEmulatesButton2 - " - Preferences preferencesDictionary removeKey: #tapAndHoldEmulatesButton2 - " - ^ self - valueOfFlag: #tapAndHoldEmulatesButton2 - ifAbsent: [ false ].! ! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'jmv 6/17/2021 12:07:59' prior: 16876882! - delete - "Remove the receiver as a submorph of its owner and make its - new owner be nil." - - | aWorld | - aWorld _ self world ifNil: [ self runningWorld ]. - aWorld ifNotNil: [ - aWorld activeHand ifNotNil: [ :h | h - releaseKeyboardFocus: self; - releaseMouseFocus: self ]]. - owner ifNotNil:[ self privateDelete].! ! -!HandMorph methodsFor: 'double click support' stamp: 'jmv 6/17/2021 12:54:54' prior: 16851566! - waitForClicksOrDragOrSimulatedMouseButton2: aMorph event: evt clkSel: clkSel clkNHalf: clkNHalfSel dblClkSel: dblClkSel dblClkNHalfSel: dblClkNHalfSel tripleClkSel: tripleClkSel - - "Wait until the difference between click, double-click, or drag gesture is known, then inform the given morph what transpired. This message is sent when the given morph first receives a mouse-down event. If the mouse button goes up, then down again within DoubleClickTime, then 'doubleClick: evt' is sent to the morph. If the mouse button goes up but not down again within DoubleClickTime, then the message 'click: evt' is sent to the morph. Finally, if the button does not go up within DoubleClickTime, then 'drag: evt' is sent to the morph. In all cases, the event supplied is the original mouseDown event that initiated the gesture. mouseMove: and mouseUp: events are not sent to the morph until it becomes the mouse focus, which is typically done by the client in its click:, doubleClick:, or drag: methods." - - mouseClickState _ - MouseClickState new - client: aMorph - drag: nil - click: clkSel - clickAndHalf: clkNHalfSel - dblClick: dblClkSel - dblClickAndHalf: dblClkNHalfSel - tripleClick: tripleClkSel - event: evt - sendMouseButton2Activity: Preferences tapAndHoldEmulatesButton2. - - "It seems the Mac VM may occasionally lose button up events triggering bogus activations. - Hence Preferences tapAndHoldEmulatesButton2"! ! -!HandMorph methodsFor: 'double click support' stamp: 'jmv 6/17/2021 12:54:58' prior: 50426086! - waitForClicksOrDragOrSimulatedMouseButton2: aMorph event: evt clkSel: clkSel clkNHalf: clkNHalfSel dblClkSel: dblClkSel dblClkNHalfSel: dblClkNHalfSel tripleClkSel: tripleClkSel dragSel: dragSel - - mouseClickState _ - MouseClickState new - client: aMorph - drag: dragSel - click: clkSel - clickAndHalf: clkNHalfSel - dblClick: dblClkSel - dblClickAndHalf: dblClkNHalfSel - tripleClick: tripleClkSel - event: evt - sendMouseButton2Activity: Preferences tapAndHoldEmulatesButton2. - - "It seems the Mac VM may occasionally lose button up events triggering bogus activations. - Hence Preferences tapAndHoldEmulatesButton2"! ! -!MouseClickState methodsFor: 'actions' stamp: 'jmv 6/17/2021 13:01:32' prior: 50573736! - handleEvent: aMouseEvent from: aHand - "Process the given mouse event to detect a click, double-click, or drag. - Return true if the event should be processed by the sender, false if it shouldn't. - NOTE: This method heavily relies on getting *all* mouse button events." - - | timedOut distance | - timedOut _ (aMouseEvent timeStamp - lastClickDown timeStamp) > self class doubleClickTimeout. - timedOut ifTrue: [ aHand dontWaitForMoreClicks ]. - distance _ (aMouseEvent eventPosition - lastClickDown eventPosition) r. - "Real action dispatch might be done after the triggering event, for example, because of waiting for timeout. - So, count the button downs and ups(clicks), to be processed, maybe later, maybe in a mouseMove..." - aMouseEvent isMouseDown ifTrue: [ - lastClickDown _ aMouseEvent. - buttonDownCount _ buttonDownCount + 1 ]. - aMouseEvent isMouseUp ifTrue: [ - buttonUpCount _ buttonUpCount + 1 ]. - - "Drag, or tap & hold" - (buttonDownCount = 1 and: [ buttonUpCount = 0]) ifTrue: [ - distance > 0 ifTrue: [ - aHand dontWaitForMoreClicks. - dragSelector - ifNotNil: [ self didDrag ] - "If we have already moved, then it won't be a double or triple click... why wait?" - ifNil: [ self didClick ]. - ^ false ]. - timedOut ifTrue: [ - aHand dontWaitForMoreClicks. - "Simulate button 2 via tap & hold. Useful for opening menus on pen computers." - sendMouseButton2Activity ifTrue: [ - clickClient mouseButton2Activity ]. - ^ false ]]. - - "If we're over triple click, or timed out, or mouse moved, don't allow more clicks." - (buttonDownCount = 4 or: [ timedOut or: [ distance > 0 ]]) ifTrue: [ - aHand dontWaitForMoreClicks. - ^ false ]. - - "Simple click." - (buttonDownCount = 1 and: [ buttonUpCount = 1 ]) ifTrue: [ - self didClick ]. - - "Click & hold" - (buttonDownCount = 2 and: [ buttonUpCount = 1]) ifTrue: [ - self didClickAndHalf ]. - - "Double click." - (buttonDownCount = 2 and: [ buttonUpCount = 2]) ifTrue: [ - self didDoubleClick ]. - - "Double click & hold." - (buttonDownCount = 3 and: [ buttonUpCount = 2]) ifTrue: [ - self didDoubleClickAndHalf ]. - - "Triple click" - (buttonDownCount = 3 and: [ buttonUpCount = 3]) ifTrue: [ - self didTripleClick ]. - - "This means: if a mouseDown, then don't further process this event (so we can turn it into a double or triple click on next buttonUp)" - ^ aMouseEvent isMouseDown! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - Preferences preferencesDictionary removeKey: #tapAndHoldEmulatesButton2! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4638-tapNholdTweaks-JuanVuletich-2021Jun17-12h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4638] on 18 June 2021 at 11:52:40 am'! -!Stream methodsFor: 'nonhomogeneous accessing' stamp: 'jmv 6/18/2021 11:51:28' prior: 50413472! - nextNumber - "Answer a number from the (text) stream." - - |element| - [(element := self next) isNil or: [element isDigit or: [element = $- or: [element = $. or: [element = $)]]]]] whileFalse. - element ifNil: [^nil]. - self skip: -1. - element = $) ifTrue: [^nil]. - ^Number readFrom: self! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4639-AllowMissingLeadingZeroForStreamnextNumber-JuanVuletich-2021Jun18-11h51m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4639] on 18 June 2021 at 3:42:08 pm'! -!Form methodsFor: 'displaying-generic' stamp: 'jmv 6/18/2021 15:21:59' prior: 16847720! - displayAt: aDisplayPoint - "Display the receiver located at aDisplayPoint with default settings for - the displayMedium, rule and halftone." - - self displayOn: Display at: aDisplayPoint.! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 6/18/2021 14:48:15' prior: 50570483! - displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - aRectangle is clipped appropiately if some owner clips us." - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - privateDisplayBounds _ self isOrthoRectangularMorph - ifTrue: [ - "In these cases, #drawOn: might not be able to find bounds (InnerTextMorph, for example), - but it is OK to compute them from #morphLocalBounds. This is not true for non-orthoRectangular morphs!!" - aCanvas boundingRectOfCurrentMorphFromLocalBounds] - ifFalse: [ - "In this cases, we use the bounds bound by #drawOn. This method must therefore be called after calling - #drawOn: and #postDrawOn: . See senders." - aCanvas boundingRectOfCurrentMorphAfterDraw]]]].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 6/18/2021 14:49:16' prior: 50536162! - fullUpdateBounds: aMorph - - aMorph visible ifTrue: [ - self into: aMorph. - self canvasToUse fullUpdateCurrentBounds. - self outOfMorph ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 6/18/2021 14:49:49' prior: 50570511! - fullUpdateCurrentBounds - - | isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph isOrthoRectangularMorph ifFalse: [ - "In these cases, #drawOn: is required to find bounds. - #displayBoundsSetFrom: will use the bounds found by us in these case. - See #displayBoundsSetFrom:" - currentMorph drawOn: self. - currentMorph postDrawOn: self ]. - currentMorph displayBoundsSetFrom: self. - currentMorph submorphsDo: [ :m | - self fullUpdateBounds: m ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4640-Form-displayAt-fix-JuanVuletich-2021Jun18-14h48m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4639] on 18 June 2021 at 4:58:09 pm'! - -Point removeSelector: #enclosingRectangleWith:! - -!methodRemoval: Point #enclosingRectangleWith: stamp: 'Install-4641-Cleanup-JuanVuletich-2021Jun18-16h04m-jmv.001.cs.st 7/20/2021 16:52:49'! -enclosingRectangleWith: aPoint - "Answer a Rectangle with integer coordinates that includes self and aPoint." - - self flag: #revisarM3. - ^Rectangle - origin: (x min: aPoint x) floor @ (y min: aPoint y) floor - corner: (x max: aPoint x) ceiling @ (y max: aPoint y ceiling) +1! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4641-Cleanup-JuanVuletich-2021Jun18-16h04m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4641] on 24 June 2021 at 10:24:59 am'! -!Duration class methodsFor: 'squeak protocol' stamp: 'jmv 6/24/2021 10:19:10' prior: 16836156! - fromString: aString - " - Extended to accept non-ANSI formats, such as: - Duration fromString: '1:50:00' - Duration fromString: '5:30.5' - Duration fromString: '1:6:50:00' - Duration fromString: '3.5h' - Duration fromString: '2.5min' - Duration fromString: '1.5s' - Duration fromString: '200s' - Duration fromString: '200ms' - " - | colons s | - - "If aString includes at least one $:, complete ANSI format" - colons _ aString occurrencesOf: $:. - colons > 0 ifTrue: [ - s _ aString. - [colons < 3] whileTrue: [ - s _ '00:', s. - colons _ colons + 1 ]. - ^ self readFrom: (ReadStream on: s) ]. - - "'3.5h' means 3.5 hours" - (aString endsWith: 'h') ifTrue: [ - ^self hours: aString asNumber ]. - - "'3.5min' means 3.5 minutes" - (aString endsWith: 'min') ifTrue: [ - ^self minutes: aString asNumber ]. - - "'3ms' means 3 milliseconds" - (aString endsWith: 'ms') ifTrue: [ - ^self milliSeconds: aString asNumber ]. - - "'3.5s' means 3.5 seconds" - (aString endsWith: 's') ifTrue: [ - ^self seconds: aString asNumber ]. - - ^nil! ! -!Duration class methodsFor: 'squeak protocol' stamp: 'jmv 6/24/2021 10:17:17' prior: 50467792 overrides: 16882927! - readFrom: aStream - "Formatted as per ANSI 5.8.2.16: [-]D:HH:MM:SS[.S]" - - | sign days hours minutes seconds nanos nanosBuffer | - sign := (aStream peekFor: $-) ifTrue: [-1] ifFalse: [1]. - days := (aStream upTo: $:) findPositiveInteger * sign. - hours := (aStream upTo: $:) findPositiveInteger * sign. - minutes := (aStream upTo: $:) findPositiveInteger * sign. - seconds := (aStream upTo: $.) findPositiveInteger * sign. - nanosBuffer := '000000000' copy. - nanos := WriteStream on: nanosBuffer. - [aStream atEnd not and: [aStream peek isDigit]] - whileTrue: [nanos nextPut: aStream next]. - - ^ self - days: days - hours: hours - minutes: minutes - seconds: seconds - nanoSeconds: (nanosBuffer findPositiveInteger * sign) - - " - Duration readFrom: '0:00:00:00' readStream - Duration readFrom: '0:00:00:00.000000001' readStream - Duration readFrom: '0:00:00:00.9' readStream - Duration readFrom: '0:00:00:00.99' readStream - Duration readFrom: '0:00:00:00.99999999' readStream - Duration readFrom: '0:00:00:00.999999999' readStream - Duration readFrom: '0:00:00:00.100000000' readStream - Duration readFrom: '0:00:00:00.001 ' readStream - Duration readFrom: '0:00:00:00.1' readStream - Duration readFrom: '0:00:00:01 ' readStream - Duration readFrom: '0:12:45:45' readStream - Duration readFrom: '1:00:00:00' readStream - Duration readFrom: '365:00:00:00' readStream - Duration readFrom: '-7:09:12:06.10' readStream - Duration readFrom: '+0:01:02:3' readStream - "! ! -!String methodsFor: 'converting' stamp: 'jmv 6/24/2021 10:20:25' prior: 16916433! - 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 inString | - - "Hack in some minimal workaround for Unicode stuff" - inString _ self copyReplaceAll: '’' with: $' asString. - "Check if we can handle this in #safeValue: in some way..." - inString = self ifFalse: [ self halt ]. - - in _ ReadStream on: inString. - 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: $"]. - rest first = $# ifTrue: [ out nextPut: (Character numericValue: rest findPositiveInteger) ]. - did = out position ifTrue: [ - out nextPut: $&; nextPutAll: rest. - "self error: 'unknown encoded HTML char'." - "Please add it to this method"]] - ifFalse: [out nextPut: char]]. - ]. - ^ out contents! ! -!RemoteString methodsFor: 'private' stamp: 'jmv 6/24/2021 10:22:10' prior: 16900641! - checkSum: aString - "Construct a checksum of the string. A three byte number represented as Base64 characters." - | sum shift bytes | - sum := aString size. - shift := 0. - aString do: [:char | - (shift := shift + 7) > 16 ifTrue: [shift := shift - 17]. - "shift by 7 to keep a change of adjacent chars from xoring to same value" - sum := sum bitXor: (char numericValue bitShift: shift) - ]. - bytes := ByteArray new: 3. - sum := sum + 16r10000000000. - 1 to: 3 do: [:ind | bytes at: ind put: (sum digitAt: ind)]. - ^bytes base64Encoded! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4642-fixSendersOfStringasInteger-JuanVuletich-2021Jun24-10h08m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4636] on 19 June 2021 at 11:08:05 pm'! - -WidgetMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp titleMorph activeSubMenu popUpOwner prevMouseFocus prevKbdFocus ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #MenuMorph category: #'Morphic-Menus' stamp: 'Install-4643-RestoreFocusOnMenuExit-HilaireFernandes-2021Jun19-22h28m-hlsf.002.cs.st 7/20/2021 16:52:49'! -WidgetMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp titleMorph activeSubMenu popUpOwner prevMouseFocus prevKbdFocus' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! -!MenuMorph methodsFor: 'control' stamp: 'hlsf 6/19/2021 22:50:33' prior: 50399783! - popUpAt: aPoint forHand: hand allowKeyboard: aBoolean - "Present this menu at the given point under control of the given hand." - - | evt | - self items isEmpty ifTrue: [^self]. - self addBlankIconsIfNecessary. - (self submorphs select: [ :m | m is: #UpdatingMenuItemMorph ]) - do: [ :m | m updateContents]. - self runningWorld addMorphFront: self position: aPoint - `2 @ 8`. - self fitInWorld. - "Acquire focus for valid pop up behavior" - prevKbdFocus _ hand keyboardFocus. - prevMouseFocus _ hand mouseFocus. - hand newMouseFocus: self. - aBoolean ifTrue: [ hand newKeyboardFocus: self ]. - evt _ hand lastMouseEvent. - (evt isKeyboard or: [ evt isMouse and: [ evt anyButtonPressed not ]]) - ifTrue: [ - "Select first item if button not down" - self moveSelectionDown: 1 event: evt ]! ! -!MenuMorph methodsFor: 'control' stamp: 'hlsf 6/19/2021 22:50:09' prior: 50399808! - popUpAt: aPoint forHand: hand in: aWorld allowKeyboard: aBoolean - "Present this menu at the given point under control of the given hand." - - self items isEmpty ifTrue: [ ^self ]. - self addBlankIconsIfNecessary. - (self submorphs select: [ :m | m is: #UpdatingMenuItemMorph]) - do: [ :m | m updateContents]. - aWorld addMorphFront: self position: aPoint - `2 @ 8`. - self fitInWorld. - "Acquire focus for valid pop up behavior" - prevKbdFocus _ hand keyboardFocus. - prevMouseFocus _ hand mouseFocus. - hand newMouseFocus: self. - aBoolean ifTrue: [ hand newKeyboardFocus: self ]! ! -!MenuMorph methodsFor: 'events' stamp: 'hlsf 6/19/2021 23:05:11' prior: 50562775 overrides: 16874541! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - "Handle a mouse down event." - (stayUp or: [ self fullContainsGlobalPoint: aMouseButtonEvent eventPosition ]) - ifFalse: [ - self deleteIfPopUp: aMouseButtonEvent. - self activeHand - newKeyboardFocus: prevKbdFocus; - newMouseFocus: prevMouseFocus. - ^ self ]. "click outside" - - "Grab the menu and drag it to some other place - This is reimplemented here because we handle the event, and if the following lines are commented, a menu can't be grabbed with the hand. This is not nice and shouldn't be needed" - self isSticky ifTrue: [ ^self ]. - aMouseButtonEvent hand grabMorph: self! ! -!MenuMorph methodsFor: 'events' stamp: 'hlsf 6/19/2021 23:05:34' prior: 50562796 overrides: 16874556! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - "Handle a mouse up event. - Note: This might be sent from a modal shell." - (self fullContainsGlobalPoint: aMouseButtonEvent eventPosition) ifFalse:[ - "Mouse up outside. Release eventual focus and delete if pop up." - aMouseButtonEvent hand ifNotNil: [ :h | h releaseMouseFocus: self ]. - self deleteIfPopUp: aMouseButtonEvent. - self activeHand - newKeyboardFocus: prevKbdFocus; - newMouseFocus: prevMouseFocus. - ^ self]. - stayUp ifFalse: [ - "Still in pop-up transition; keep focus" - aMouseButtonEvent hand newMouseFocus: self ]! ! -!MenuMorph methodsFor: 'initialization' stamp: 'hlsf 6/19/2021 23:01:58' prior: 50567222 overrides: 50574235! - delete - activeSubMenu ifNotNil: [activeSubMenu delete]. - self itemsDo: [ :i | i deselect ]. - super delete.! ! - -WidgetMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp titleMorph activeSubMenu popUpOwner prevKbdFocus prevMouseFocus' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #MenuMorph category: #'Morphic-Menus' stamp: 'Install-4643-RestoreFocusOnMenuExit-HilaireFernandes-2021Jun19-22h28m-hlsf.002.cs.st 7/20/2021 16:52:49'! -WidgetMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp titleMorph activeSubMenu popUpOwner prevKbdFocus prevMouseFocus' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4643-RestoreFocusOnMenuExit-HilaireFernandes-2021Jun19-22h28m-hlsf.002.cs.st----! - -'From Cuis 5.0 [latest update: #4642] on 25 June 2021 at 10:10:12 am'! -!MenuMorph methodsFor: 'events' stamp: 'jmv 6/25/2021 10:09:08' prior: 50431715 overrides: 50449234! - keyStroke: aKeyboardEvent - | matchString char asc selectable | - char := aKeyboardEvent keyCharacter. - asc := char numericValue. - aKeyboardEvent isReturnKey - ifTrue: [ - selectedItem ifNotNil: [ - selectedItem hasSubMenu - ifTrue: [ - aKeyboardEvent hand newMouseFocus: selectedItem subMenu. - ^aKeyboardEvent hand newKeyboardFocus: selectedItem subMenu] - ifFalse: [ - "self delete." - ^selectedItem invokeWithEvent: aKeyboardEvent]]. - (selectable := self items) size = 1 - ifTrue: [^selectable first invokeWithEvent: aKeyboardEvent]. - ^self]. - asc = 27 - ifTrue: [ - "escape key" - self - valueOfProperty: #matchString - ifPresentDo: [ :str | - str isEmpty - ifFalse: [ - "If filtered, first ESC removes filter" - self setProperty: #matchString toValue: String new. - self selectItem: nil. - ^self displayFiltered: aKeyboardEvent]]. - "If a stand-alone menu, just delete it" - self delete. - self activeHand - newKeyboardFocus: prevKbdFocus; - newMouseFocus: prevMouseFocus. - ^self]. - (asc = 28 or: [asc = 29]) - ifTrue: [ - "left or right arrow key" - (selectedItem notNil and: [selectedItem hasSubMenu]) - ifTrue: [ - aKeyboardEvent hand newMouseFocus: selectedItem subMenu. - selectedItem subMenu moveSelectionDown: 1 event: aKeyboardEvent. - ^aKeyboardEvent hand newKeyboardFocus: selectedItem subMenu] - ifFalse: [^ self]]. - asc = 30 ifTrue: [^self moveSelectionDown: -1 event: aKeyboardEvent]. "up arrow key" - asc = 31 ifTrue: [^self moveSelectionDown: 1 event: aKeyboardEvent]. "down arrow key" - asc = 11 ifTrue: [^self moveSelectionDown: -5 event: aKeyboardEvent]. "page up key" - asc = 12 ifTrue: [^self moveSelectionDown: 5 event: aKeyboardEvent]. "page down key" - matchString := self valueOfProperty: #matchString ifAbsent: [String new]. - matchString := char = Character backspace - ifTrue: [ - matchString isEmpty ifTrue: [matchString] ifFalse: [matchString allButLast]] - ifFalse: [matchString copyWith: aKeyboardEvent keyCharacter]. - self setProperty: #matchString toValue: matchString. - self displayFiltered: aKeyboardEvent! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4644-AlsoOnEsc-JuanVuletich-2021Jun25-10h09m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4644] on 25 June 2021 at 12:07:37 pm'! -!MenuItemMorph methodsFor: 'initialization' stamp: 'jmv 6/25/2021 12:02:54' prior: 50385278 overrides: 50556185! - initialize - "initialize the state of the receiver" - super initialize. - isEnabled _ true. - subMenu _ nil. - isSelected _ false. - target _ nil. - selector _ nil. - arguments _ nil. - font _ Preferences standardMenuFont. - self contents: ''.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4645-MenuItemCreationFix-JuanVuletich-2021Jun25-12h07m-jmv.001.cs.st----! - -'From Haver 5.0 [latest update: #4638] on 18 June 2021 at 8:49:05 am'! -!TestRunner methodsFor: 'processing' stamp: 'KLG 6/18/2021 08:42:36' prior: 50379353! - runSuiteProfiled: suite - running ifNotNil: [ ^self inform: 'already running' ]. - suite addDependent: self. - totalTests _ suite tests size. - completedTests _ 0. - running _ [ - [ result _ TimeProfileBrowser onBlock: [suite run] ] - ensure: [ - running _ nil. - suite removeDependent: self. - runSemaphore signal. - UISupervisor whenUIinSafeState: [ - self updateWindow: result. - self changed: #runTests. - self changed: #runOneTest. - ]. - ]. - ] newProcess. - self runWindow. - self changed: #runTests. - self changed: #runOneTest. - running - name: 'TestRunner'; -" priority: Processor userBackgroundPriority;" - resume. -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4646-TimeProfileBrowser_in_TestRrunner-GeraldKlix-2021Jun17-12h54m-KLG.001.cs.st----! - -'From Haver 5.0 [latest update: #4641] on 19 June 2021 at 3:50:44 pm'! -!Compiler methodsFor: 'public access' stamp: 'KLG 6/19/2021 15:45:45' prior: 50444923! - evaluateMethod: method to: receiver logged: doLog profiled: doProfile - - "See evaluate:in:to:notifying:ifFail:logged:profiled: - It does the same but without compiling because it recevies the result of the compilation - as the parameter method. - self should have compile method" - - | value toLog itsSelection itsSelectionString | - - "(jmv) Log before evaluating. This way, if the evaluation is halted by whatever reason, it is logged anyway" - doLog ifTrue: [ - toLog _ ((requestor respondsTo: #selection) - and: [ (itsSelection _ requestor selection) notNil - and: [ (itsSelectionString _ itsSelection asString) isEmptyOrNil not ]]) - ifTrue: [ itsSelectionString ] - ifFalse: [ sourceStream contents ]. - SystemChangeNotifier uniqueInstance evaluated: toLog context: context ]. - - "Evaluate now." - doProfile - ifTrue: [ - TimeProfileBrowser onBlock: [ - value _ receiver - withArgs: (context ifNil: [#()] ifNotNil: [{context}]) - executeMethod: method ]] - ifFalse: [ - value _ receiver - withArgs: (context ifNil: [#()] ifNotNil: [{context}]) - executeMethod: method ]. - - ^ value! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4647-TimeProfileBrowser_in_Compiler-GeraldKlix-2021Jun19-12h27m-KLG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4647] on 25 June 2021 at 12:34:07 pm'! -!Encoder methodsFor: 'private' stamp: 'MM 6/25/2021 11:55:34' prior: 50476774! - warnAboutShadowed: name - - | msg transcriptMsg | - - msg _ 'There already exists a variable named ', name, ' '. - requestor addWarning: msg. - - transcriptMsg _ msg, ' (', class className, '>>', selector printString,')'. - Transcript newLine; show: transcriptMsg. - - InMidstOfFileinNotification signal - ifFalse: [ - requestor interactive - ifTrue: [ - self notify: msg] - ifFalse: [ - (RecompilationFailure - class: class - messageText: msg, String newLineString, 'Please use a different name') signal ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4648-BetterTranscriptWarnAboutShadowed-MarianoMontone-2021Jun25-12h33m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4648] on 29 June 2021 at 10:53:04 am'! -!SystemDictionary methodsFor: 'startup' stamp: 'MM 6/28/2021 23:26:17' prior: 16925412! - processCommandLineArgument: rawArgStream storeStartUpScriptArgsOn: startUpScriptArgs - " - Smalltalk processCommandLineArguments - - A possible example (duplicated single quotes: '' should be double quotes, but not allowed in a Smalltalk comment): - Squeak.exe Cuis4.2-2211x.image -r RequiredFeature1 -rRequiredFeature2 -d ''Transcript show: 'popo1'; newLine'' -d''Transcript show: 'popo2'; newLine'' -s smalltalkScript.st paramAlScript1 paramAlSCript2 ''parametro al script ->>>--// 3'' - " - | p data entry | - p _ rawArgStream next. - - (p first = $- and: [ p size > 1 ]) ifTrue: [ - "If the command is not included in p, it is next argument" - p size = 2 - ifTrue: [ - "as in -r RequiredFeature1" - data _ rawArgStream next ] - ifFalse: [ - "as in -rRequiredFeature2" - data _ p copyFrom: 3 to: p size ]. - p second caseOf: { - [ $r ] -> [ "as in -rRequiredFeature2" - { 'Feature require: '. data } print. - [ Feature require: data ] on: UnhandledError do: [:ex | ex return] ]. - [ $d ] -> [ "as in -d ''Transcript show: 'popo1'; newLine'' -d''Transcript show: 'popo2'; newLine'' (duplicated singleQuotes should read doubleQuote)" - { 'Compiler evaluate: '. data } print. - [ Compiler evaluate: data ] on: UnhandledError do: [:ex | ex return] ]. - [$l ] -> ["file in the file" - { 'File in: '. data} print. - [(CodeFile newFromFile: data asFileEntry) fileIn] on: UnhandledError do: [:ex | ex return]]. - [ $s ] -> [ "as in -s smalltalkScript.st paramAlScript1 paramAlSCript2 ''parametro al script ->>>--// 3'' (duplicated singleQuotes should read doubleQuote)" - [ rawArgStream atEnd ] whileFalse: [ - startUpScriptArgs nextPut: rawArgStream next ]. - "Can use 'Smalltalk startUpScriptArguments' inside the startUp script - { 'Compiler evaluate contents of file named: '. data. ' arguments: '. Smalltalk startUpScriptArguments } print." - entry _ data asFileEntry. - entry exists ifTrue: [ - entry readStreamDo: [ :stream | - [ Compiler evaluate: stream contentsOfEntireFile ] on: UnhandledError do: [:ex | ex return]]]. - "Maybe we decide to clear them after startup script execution - startUpScriptArguments _ nil" ] - } - otherwise: [] - ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4649-fileInStartUpOption-MarianoMontone-2021Jun29-10h52m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4649] on 29 June 2021 at 11:26:31 am'! -!Editor methodsFor: 'new selection' stamp: 'jmv 6/29/2021 11:23:28'! - selectWordOrDelimitedText - "Select delimited text or word--the result of double-clicking." - - ^self selectWordLeftDelimiters: self wordLeftDelimiters rightDelimiters: self wordRightDelimiters ! ! -!Editor methodsFor: 'new selection' stamp: 'jmv 6/29/2021 11:21:01' prior: 50452482! - selectWord - "Select exactly one word. - See also #selectWordOrDelimitedText" - - ^self selectWordLeftDelimiters: '' rightDelimiters: ''! ! -!TextEditor methodsFor: 'events' stamp: 'jmv 6/29/2021 11:23:47' prior: 16931943! - clickAndHalf - - self selectWordOrDelimitedText. - - doWordSelection _ true. - doParagraphSelection _ false. - initialSelectionStart _ self startBlock. - initialSelectionStop _ self stopBlock! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4650-WordSelectionFix-JuanVuletich-2021Jun29-11h23m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4649] on 29 June 2021 at 11:30:08 am'! -!ObjectExplorerWindow methodsFor: 'building menus' stamp: 'MM 6/29/2021 09:56:27' prior: 50399351! - genericMenu - "Borrow a menu from my inspector" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - model getCurrentSelection - ifNil: [ - aMenu - add: '*nothing selected*' - target: self - action: #yourself] - ifNotNil: [ - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'inspect (i)'. - #selector -> #inspectSelection. - #icon -> #inspectIcon - } asDictionary. - { - #label -> 'explore (I)'. - #selector -> #exploreSelection. - #icon -> #exploreIcon - } asDictionary. - { - #label -> 'copy to clipboard (c)'. - #selector -> #copySelectionToClipboard. - #icon -> #copyIcon - } asDictionary. - { - #label -> 'basic inspect'. - #selector -> #inspectBasic. - #icon -> #inspectIcon - } asDictionary. - { - #label -> 'references finder'. - #selector -> #openReferencesFinder. - #icon -> #exploreIcon - } asDictionary. - { - #label -> 'weight explorer'. - #selector -> #openWeightExplorer. - #icon -> #exploreIcon - } asDictionary. - nil. - { - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - }`. - model getCurrentSelection ifNotNil: [ :currSel | - (currSel item is: #Morph) ifTrue: [ - aMenu addLine. - aMenu add: 'show morph halo' target: currSel item action: #addHalo]]. - aMenu addLine; - add: 'monitor changes' - target: self - action: #monitor: - argument: model getCurrentSelection. - model class == ReferencesExplorer ifTrue: [ - aMenu addLine; - add: 'rescan' - target: self - action: #rescan ]]. - model basicMonitorList isEmptyOrNil - ifFalse: [ - aMenu addLine; - add: 'stop monitoring all' - target: self - action: #stopMonitoring ]. - ^ aMenu! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4651-ShowMorphHalo-optionInExplorers-MarianoMontone-2021Jun29-11h26m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4651] on 5 July 2021 at 2:36:45 pm'! -!Debugger class methodsFor: 'constants' stamp: 'jmv 7/5/2021 14:31:30'! - defaultDebugStackSize - ^50! ! -!Debugger methodsFor: 'context stack (message list)' stamp: 'jmv 7/5/2021 14:32:39' prior: 16829722! - expandStack - "A Notifier is being turned into a full debugger. Show a substantial amount of stack in the context pane." - - self newStack: (contextStackTop stackOfSize: Debugger defaultDebugStackSize). - contextStackIndex _ 0. - receiverInspector _ Inspector inspect: nil. - contextVariablesInspector _ ContextVariablesInspector inspect: nil. - proceedValue _ nil! ! -!ProcessBrowser methodsFor: 'stack list' stamp: 'jmv 7/5/2021 14:34:21' prior: 16895044! - updateStackList - self updateStackList: Debugger defaultDebugStackSize! ! -!ProcessBrowser class methodsFor: 'CPU utilization' stamp: 'jmv 7/5/2021 14:32:32' prior: 50567406! - dumpPigStackOn: aStream - "Must run forked on its own process, so the monitored behavior is not affected too much" - - | promise tally process stack suspendedContext | - promise := Processor tallyCPUUsageFor: 1 every: 10. - tally := promise value. - "UISupervisor whenUIinSafeState: [self dumpTallyOnTranscript: tally]." - aStream nextPutAll: '====Al processes===='; newLine. - self dumpTally: tally on: aStream. - aStream newLine; nextPutAll: '====Process using most CPU===='; newLine. - process _ tally sortedCounts first value. - (100.0 * (tally occurrencesOf: process) / tally size) rounded printOn: aStream. - aStream - nextPutAll: ' % '; - nextPutAll: (process browserPrintStringFull: false); - newLine. - stack _ process == Processor activeProcess - ifTrue: [thisContext stackOfSize: Debugger defaultDebugStackSize] - ifFalse: [ - suspendedContext _ process suspendedContext. - suspendedContext - ifNotNil: [suspendedContext stackOfSize: Debugger defaultDebugStackSize]]. - stack - ifNil: [ aStream nextPutAll: 'No context'; newLine] - ifNotNil: [ - stack do: [ :c | - c printOn: aStream. - aStream newLine ]]. - ^process! ! -!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'jmv 7/5/2021 14:33:38' prior: 16806209 overrides: 50527905! - recoverFromMDFaultWithTrace - "This method handles emthodDict faults to support, eg, discoverActiveClasses (qv)." - self recoverFromMDFault. - Smalltalk at: #MDFaultDict ifPresent: - [:faultDict | faultDict at: self name put: - (String streamContents: [ :strm | - (thisContext stackOfSize: Debugger defaultDebugStackSize) do: [ :item | - strm print: item; newLine]])] - -"Execute the following statement to induce MD fault tracing. This means that, not only will all active classes be recorded but, after a test run, MDFaultDict will contain, for every class used, a stack trace showing how it came to be used. This statement should be executed just prior to any such text, in order to clear the traces. - - Smalltalk at: #MDFaultDict put: Dictionary new. - -"! ! -!ContextPart methodsFor: 'debugger access' stamp: 'jmv 7/5/2021 14:35:18' prior: 16823996! - errorReportOn: strm - "Write a detailed error report on the stack (above me) on a stream. For both the error file, and emailing a bug report. Suppress any errors while getting printStrings. Limit the length." - - | cnt aContext startPos | - strm print: Date today; space; print: Time now; newLine. - strm newLine. - strm nextPutAll: 'VM: '; - nextPutAll: Smalltalk platformName asString; - nextPutAll: ' - '; - nextPutAll: Smalltalk vmVersion asString; - newLine. - strm nextPutAll: 'Image: '; - nextPutAll: Smalltalk version asString; - nextPutAll: ' ['; - nextPutAll: Smalltalk lastUpdateString asString; - nextPutAll: ']'; - newLine. - strm newLine. - - "Note: The following is an open-coded version of ContextPart>>stackOfSize: since this method may be called during a low space condition and we might run out of space for allocating the full stack." - cnt _ 0. startPos _ strm position. - aContext _ self. - [aContext notNil and: [(cnt _ cnt + 1) < Debugger defaultDebugStackSize]] whileTrue: [ - aContext printDetails: strm. "variable values" - strm newLine. - aContext _ aContext sender]. - - strm newLine; nextPutAll: '--- The full stack ---'; newLine. - aContext _ self. - cnt _ 0. - [aContext == nil] whileFalse: [ - cnt _ cnt + 1. - cnt = Debugger defaultDebugStackSize ifTrue: [strm nextPutAll: ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -'; newLine ]. - strm print: aContext; newLine. "just class>>selector" - - strm position > (startPos+40000) ifTrue: [strm nextPutAll: '...etc...'. - ^ self]. "exit early" - cnt > 100 ifTrue: [strm nextPutAll: '-- and more not shown --'. ^ self]. - aContext _ aContext sender]. -! ! -!ContextPart methodsFor: 'debugger access' stamp: 'jmv 7/5/2021 14:35:26' prior: 50373279! - shortErrorReportOn: strm - "Write a short error report on the stack (above me) on a stream. For both the error file, and emailing a bug report. " - - | cnt aContext | - strm print: Date today; space; print: Time now; newLine. - aContext _ self. - cnt _ 0. - [aContext notNil and: [(cnt _ cnt + 1) < Debugger defaultDebugStackSize]] whileTrue: [ - strm print: aContext; newLine. "just class>>selector" - aContext _ aContext sender]! ! -!ContextPart methodsFor: 'debugger access' stamp: 'jmv 7/5/2021 14:33:53' prior: 16824120! - shortStack - "Answer a String showing the top ten contexts on my sender chain." - - ^ String streamContents: [ :strm | - (self stackOfSize: Debugger defaultDebugStackSize) - do: [:item | strm print: item; newLine]]! ! - -ContextPart removeSelector: #longStack! - -!methodRemoval: ContextPart #longStack stamp: 'Install-4652-LargerStackDumpsByDefault-JuanVuletich-2021Jul05-14h31m-jmv.001.cs.st 7/20/2021 16:52:49'! -longStack - "Answer a String showing the top 100 contexts on my sender chain." - - ^ String streamContents: [ :strm | - (self stackOfSize: 100) - do: [:item | strm print: item; newLine]]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4652-LargerStackDumpsByDefault-JuanVuletich-2021Jul05-14h31m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4651] on 5 July 2021 at 2:38:05 pm'! -!ArrayedCollection methodsFor: 'printing' stamp: 'jmv 7/5/2021 13:26:23' overrides: 16814609! - printNameOn: aStream - - aStream - nextPutAll: self class name withArticle; - nextPut: $:; - print: self size! ! -!Collection methodsFor: 'printing' stamp: 'jmv 7/5/2021 13:24:54' prior: 16814609! - printNameOn: aStream - - aStream - nextPutAll: self class name withArticle! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4653-ArraySizeInPrintString-JuanVuletich-2021Jul05-14h36m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4651] on 5 July 2021 at 2:42:08 pm'! -!Morph methodsFor: 'drawing' stamp: 'jmv 7/5/2021 14:03:10' prior: 50561070! - postDrawOn: aCanvas - "A canvas is already set with a proper transformation from our coordinates to those of the Canvas target. - Possible second stage of drawing, after drawing submorphs, and on top of them. - Answer true if anything was drawn." - - ^false! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/5/2021 14:05:34' prior: 50574484! - fullUpdateCurrentBounds - - | isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph isOrthoRectangularMorph - ifTrue: [currentMorph displayBoundsSetFrom: self] - ifFalse: [ - "In these cases, #drawOn: is required to find bounds. - #displayBoundsSetFrom: will use the bounds found by us in these case. - See #displayBoundsSetFrom:" - currentMorph - drawOn: self; - displayBoundsSetFrom: self. - (currentMorph postDrawOn: self) ifTrue: [ - currentMorph displayBoundsUpdateFrom: self ]]. - currentMorph submorphsDo: [ :m | - self fullUpdateBounds: m ]].! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 7/5/2021 14:03:57' prior: 50571133 overrides: 50565002! - drawCurrentAndSubmorphs - - self isCurrentMorphVisible ifTrue: [ - - currentMorph drawOn: self. - currentMorph displayBoundsSetFrom: self. - - "Display submorphs back to front" - "coordinate system stack already set up for aMorph - ('ivars transformations' and 'currentTransformation')" - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | self fullDraw: m ]]. - - (currentMorph postDrawOn: self) ifTrue: [ - currentMorph displayBoundsUpdateFrom: self ]. - - currentMorph isHighlighted ifTrue: [ - self drawHighlight: currentMorph ]. - ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4654-postDrawOn-optimization-JuanVuletich-2021Jul05-14h38m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4651] on 5 July 2021 at 2:45:39 pm'! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/5/2021 10:20:27'! - knowsContour - "True if a morph requires the Canvas to update a #morphContour property on us. - Any subclass might answer true, if it #requiresVectorCanvas." - - ^false! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/5/2021 10:43:23' prior: 50574443! - displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - aRectangle is clipped appropiately if some owner clips us. - See also #displayBoundsUpdateFrom:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - self isOrthoRectangularMorph - ifTrue: [ - "In these cases, #drawOn: might not be able to find bounds (InnerTextMorph, for example), - but it is OK to compute them from #morphLocalBounds. This is not true for non-orthoRectangular morphs!!" - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphFromLocalBounds ] - ifFalse: [ - "In this cases, we use the bounds bound by #drawOn. This method must therefore be called after calling #drawOn:." - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphAfterDraw. - self knowsContour ifTrue: [ - self setProperty: #contour - toValue: (aCanvas contourOfCurrentMorphAfterDrawInto: (self valueOfProperty: #contour)). - ] - ]]]].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/5/2021 14:01:16' prior: 50570225! - displayBoundsUpdateFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us. - To be called after #postDrawOn:. See also #displayBoundsSetFrom:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - self isOrthoRectangularMorph ifFalse: [ "Like in #displayBoundsSetFrom:" - | oldTop oldBottom | - oldTop _ privateDisplayBounds top. - oldBottom _ privateDisplayBounds bottom-1. - privateDisplayBounds _ privateDisplayBounds - quickMerge: aCanvas boundingRectOfCurrentMorphAfterDraw. - self knowsContour ifTrue: [ - self setProperty: #contour - toValue: (aCanvas - contourOfCurrentMorphAfterDrawUpdate: (self valueOfProperty: #contour) - oldTop: oldTop - oldBottom: oldBottom) ]]]]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4655-knowsContour-JuanVuletich-2021Jul05-14h42m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4656] on 6 July 2021 at 5:21:09 pm'! -!HandMorph methodsFor: 'focus handling' stamp: 'jmv 7/6/2021 17:18:31' prior: 16851917! - mouseFocus - - mouseFocus ifNotNil: [ - (mouseFocus isWorldMorph or: [mouseFocus isInWorld not]) - ifTrue: [ mouseFocus _ nil ]]. - ^mouseFocus! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4656-WorldCantTakeMouseFocus-JuanVuletich-2021Jul06-17h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4656] on 7 July 2021 at 4:07:27 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/7/2021 15:56:26' prior: 16875404! - morphExtent: aPoint - "In our own coordinates!! - Ignored by morphs that are not resizeable."! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/7/2021 15:56:17' prior: 16875415! - morphExtentInWorld: newExtent - "Argument is in world coordinates. - Ignored by morphs that are not resizeable."! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/7/2021 15:55:29' prior: 50554611! -morphPosition: aPoint - "Change the position of this morph. Argument is in owner's coordinates. - Ignored by morphs that are not movable."! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/7/2021 15:55:58' prior: 50554618! - morphPositionInWorld: newPositionInWorld - "Change the position of this morph. Argument is in world coordinates. - Ignored by morphs that are not movable."! ! -!Morph methodsFor: 'private' stamp: 'jmv 7/7/2021 15:56:03' prior: 50554716! - privatePosition: aPoint - "Change the position of this morph. Argument is in owner's coordinates. - Ignored by morphs that are not movable."! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4657-comments-JuanVuletich-2021Jul07-16h06m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4656] on 7 July 2021 at 4:07:59 pm'! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/7/2021 15:27:25'! - collides: aMorph - "Answer whether the pixels used by morphs touch at least at one place." - - privateDisplayBounds ifNil: [ - ^false ]. - - "Quick check with display bounds" - (aMorph displayBoundsIntersects: (privateDisplayBounds outsetBy: 1)) ifFalse: [ - ^false ]. - - "Precise check with contour, if available" - (self valueOfProperty: #contour) ifNotNil: [ :contour | | contourTop contourBottom | - contourTop _ privateDisplayBounds top max: 0. - contourBottom _ privateDisplayBounds bottom-1. - ^ aMorph contourIntersects: contour top: contourTop bottom: contourBottom ]. - - "If contour is not available, and both displayBounds overlap, answer true, as it is the best we can know." - ^ true! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/7/2021 15:50:00'! - contourIntersects: aContourArray top: aContourTop bottom: aContourBottom - "Precise check with contour, if available. - If contour is not available, use displayBounds" - - | contour contourTop contourBottom x0Own x1Own x0Arg x1Arg | - contour _ self valueOfProperty: #contour. - contourTop _ privateDisplayBounds top max: 0. - contourBottom _ privateDisplayBounds bottom-1. - - "Check if contours intersect, or touch horizontally" - (contourTop max: aContourTop) to: (contourBottom min: aContourBottom) do: [ :y | - x0Own _ contour ifNil:[privateDisplayBounds left] ifNotNil: [ contour at: (y - contourTop) * 2 + 1 ]. - x1Own _ contour ifNil:[privateDisplayBounds right-1] ifNotNil: [ contour at: (y - contourTop) * 2 + 2 ]. - x0Arg _ aContourArray at: (y - aContourTop) * 2 + 1. - x1Arg _ aContourArray at: (y - aContourTop) * 2 + 2. - (x0Own <= x1Arg and: [ x0Arg <= x1Own ]) - ifTrue: [ ^true ]]. - - "Check if aContour bottom touches our top and is above us" - contourTop-1 = aContourBottom ifTrue: [ - x0Own _ contour ifNil:[privateDisplayBounds left] ifNotNil: [ contour at: 1 ]. - x1Own _ contour ifNil:[privateDisplayBounds right-1] ifNotNil: [ contour at: 2 ]. - x0Arg _ aContourArray at: (aContourBottom - aContourTop) * 2 + 1. - x1Arg _ aContourArray at: (aContourBottom - aContourTop) * 2 + 2. - (x0Own < x1Arg and: [ x0Arg < x1Own ]) - ifTrue: [ ^true ]]. - - "Check if aContour top touches our bottom and is below us" - aContourTop-1 = contourBottom ifTrue: [ - x0Own _ contour ifNil:[privateDisplayBounds left] ifNotNil: [ contour at: (contourBottom - contourTop) * 2 + 1 ]. - x1Own _ contour ifNil:[privateDisplayBounds right-1] ifNotNil: [ contour at: (contourBottom - contourTop) * 2 + 2 ]. - x0Arg _ aContourArray at: 1. - x1Arg _ aContourArray at: 2. - (x0Own < x1Arg and: [ x0Arg < x1Own ]) - ifTrue: [ ^true ]]. - - ^false! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/7/2021 15:22:13'! - displayBoundsIntersects: aRectangle - - privateDisplayBounds ifNil: [ - ^false ]. - ^privateDisplayBounds intersects: aRectangle! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/7/2021 14:56:58'! - isCloserThan: aNumber toPoint: aPoint - "Answer true if our closest point to aPoint is less than aNumber pixels away. - In target surface (i.e. Display) coordinates. - Uses precise testing of the morph contour if available. See #knowsContour." - - | center contourTop contourBottom | - privateDisplayBounds ifNil: [ - ^false ]. - center _ privateDisplayBounds center. - "Quick checks: If not even within aNumber distance to display bounds, fail" - (center y - aPoint y) abs < (privateDisplayBounds height // 2 + aNumber) ifFalse: [ - ^false ]. - (center x - aPoint x) abs < (privateDisplayBounds width // 2 + aNumber) ifFalse: [ - ^false ]. - contourTop _ privateDisplayBounds top max: 0. - contourBottom _ privateDisplayBounds bottom-1. - "Precise check with contour, if available" - (self valueOfProperty: #contour) ifNotNil: [ :contour | | y0 y1 x0 x1 | - "Contour rows to consider are those within requested distance." - y0 _ aPoint y - aNumber max: contourTop. - y1 _ aPoint y + aNumber min: contourBottom. - y0 to: y1 do: [ :y | - x0 _ (contour at: (y - contourTop) * 2 + 1) - aNumber. - x1 _ (contour at: (y - contourTop) * 2 + 2) + aNumber. - "If a vertical line of 2*aNumber height centered on aPoint is inside the contour, quick exit" - (aPoint x between: x0 and: x1) ifTrue: [ ^true ]. - "Check if aPoint is close enough to contour" - (x0@y - aPoint) r < aNumber ifTrue: [ ^true ]. - (x1@y - aPoint) r < aNumber ifTrue: [ ^true ]]. - "Not inside, not close enough to contour" - ^ false ]. - "If contour is not available, and aPoint is close enough to displayBounds, answer true, as it is the best we can know." - ^ true! ! -!Morph methodsFor: 'testing' stamp: 'jmv 7/7/2021 11:56:01'! - isOwnedByWorldOrHand - "I.e. are we a top morph?" - - ^ self isOwnedByWorld or: [ self isOwnedByHand ]! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/7/2021 11:53:35' prior: 50575518! - displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - aRectangle is clipped appropiately if some owner clips us. - See also #displayBoundsUpdateFrom:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - self isOrthoRectangularMorph - ifTrue: [ - "In these cases, #drawOn: might not be able to find bounds (InnerTextMorph, for example), - but it is OK to compute them from #morphLocalBounds. This is not true for non-orthoRectangular morphs!!" - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphFromLocalBounds ] - ifFalse: [ - "In this cases, we use the bounds bound by #drawOn. This method must therefore be called after calling #drawOn:." - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphAfterDraw. - self setProperty: #contour toValue: ( - self knowsContour ifTrue: [ aCanvas contourOfCurrentMorphAfterDrawInto: (self valueOfProperty: #contour) ])]]]].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/7/2021 14:57:23' prior: 50575557! - displayBoundsUpdateFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us. - To be called after #postDrawOn:. See also #displayBoundsSetFrom:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - self isOrthoRectangularMorph ifFalse: [ "Like in #displayBoundsSetFrom:" - | oldTop oldBottom | - oldTop _ privateDisplayBounds top max: 0. - oldBottom _ privateDisplayBounds bottom-1. - privateDisplayBounds _ privateDisplayBounds - quickMerge: aCanvas boundingRectOfCurrentMorphAfterDraw. - self setProperty: #contour toValue: - (self knowsContour ifTrue: [ - aCanvas - contourOfCurrentMorphAfterDrawUpdate: (self valueOfProperty: #contour) - oldTop: oldTop - oldBottom: oldBottom ])]]]].! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/7/2021 11:56:38' prior: 50575510! - knowsContour - "True if a morph requires the Canvas to update a #morphContour property on us. - Any subclass might answer true, if it #requiresVectorCanvas. - By default, any top morph that is drawn by VectorCanvas." - - ^self requiresVectorCanvas and: [ self isOwnedByWorldOrHand ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4658-collisionDetection-JuanVuletich-2021Jul07-16h07m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4658] on 8 July 2021 at 10:50:45 am'! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/8/2021 10:48:34' prior: 50575842! - displayBoundsUpdateFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us. - To be called after #postDrawOn:. See also #displayBoundsSetFrom: - This more complicated update is needed because the contour information from #drawOn: was possibly - when drawing submorphs. So, the controur from #drawOn: needs to be retrieved, and updated with the - new contour information from #postDrawOn:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - self isOrthoRectangularMorph ifFalse: [ "Like in #displayBoundsSetFrom:" - | oldTop oldBottom | - oldTop _ privateDisplayBounds top max: 0. - oldBottom _ privateDisplayBounds bottom-1. - privateDisplayBounds _ privateDisplayBounds - quickMerge: aCanvas boundingRectOfCurrentMorphAfterDraw. - self setProperty: #contour toValue: - (self knowsContour ifTrue: [ - aCanvas - contourOfCurrentMorphAfterDrawUpdate: (self valueOfProperty: #contour) - oldTop: oldTop - oldBottom: oldBottom ])]]]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4659-comment-JuanVuletich-2021Jul08-10h48m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4659] on 8 July 2021 at 12:16:12 pm'! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/8/2021 12:09:56' prior: 50575678! - contourIntersects: aContourArray top: aContourTop bottom: aContourBottom - "Check if contours intersect. - If contour is not available, use displayBounds" - - | contour contourTop contourBottom x0Own x1Own x0Arg x1Arg | - contour _ self valueOfProperty: #contour. - contourTop _ privateDisplayBounds top max: 0. - contourBottom _ privateDisplayBounds bottom-1. - - (contourTop max: aContourTop) to: (contourBottom min: aContourBottom) do: [ :y | - x0Own _ contour ifNil:[privateDisplayBounds left] ifNotNil: [ contour at: (y - contourTop) * 2 + 1 ]. - x1Own _ contour ifNil:[privateDisplayBounds right-1] ifNotNil: [ contour at: (y - contourTop) * 2 + 2 ]. - x0Arg _ aContourArray at: (y - aContourTop) * 2 + 1. - x1Arg _ aContourArray at: (y - aContourTop) * 2 + 2. - (x0Own <= x1Arg and: [ x0Arg <= x1Own ]) - ifTrue: [ ^true ]]. - - ^false! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4660-simplify-JuanVuletich-2021Jul08-11h38m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4660] on 13 July 2021 at 9:59:40 am'! -!AffineTransformation class methodsFor: 'instance creation' stamp: 'jmv 7/12/2021 17:06:17'! -withRadians: radians around: rotationCenter - - ^(AffineTransformation withTranslation: rotationCenter) composedWith: - ((AffineTransformation withRadians: radians) composedWith: - (AffineTransformation withTranslation: rotationCenter negated)).! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 7/13/2021 09:58:42'! - wantsContour - "True if a morph requires the Canvas to update a #morphContour property on us. - Any subclass might answer true, if it #requiresVectorCanvas. - By default, any top morph that is drawn by VectorCanvas." - - ^self requiresVectorCanvas and: [ self isOwnedByWorldOrHand ]! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 7/13/2021 09:40:08' prior: 50559382 overrides: 50559331! - referencePosition - ^self externalizeToWorld: self rotationCenter! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 7/13/2021 09:52:20'! - rotationCenter - "In own coordinates. - Subclasses might redefine if desired." - - self valueOfProperty: #rotationCenter ifPresentDo: [ :p | ^p ]. - self displayFullBounds ifNotNil: [ :r | - ^self setProperty: #rotationCenter toValue: (self internalizeFromWorld: r center) ]. - ^`0@0`.! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 7/12/2021 16:02:51' overrides: 50576008! - rotationCenter - "In own coordinates." - - ^ extent / 2.0.! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 7/12/2021 16:02:56' overrides: 50576008! - rotationCenter - "In own coordinates." - - ^ extent / 2.0.! ! -!AffineTransformation methodsFor: 'composing' stamp: 'jmv 7/12/2021 16:26:13' prior: 16778310! - composedWith: innerTransformation - "Return the composition of the receiver and the transformation passed in. - The result is a transformation whose application (transform:) is equivalent - to first applying innerTransformation and then self. - In other words - self externalize: (innerTransformation externalize: aPoint) - innerTransformation internalize: (self internalize: aPoint)." - - ^innerTransformation innerComposedWithAffineTransformation: self! ! -!MorphicTranslation methodsFor: 'composing' stamp: 'jmv 7/12/2021 16:26:33' prior: 16878326! - composedWith: innerTransformation - "Return the composition of the receiver and the transformation passed in. - The result is a transformation whose application (transform:) is equivalent - to first applying innerTransformation and then self. - In other words - self externalize: (innerTransformation externalize: aPoint) - innerTransformation internalize: (self internalize: aPoint)." - - ^innerTransformation innerComposedWithTranslation: self! ! -!Morph methodsFor: 'accessing - properties' stamp: 'jmv 7/13/2021 09:51:15' prior: 16874042! - setProperty: aSymbol toValue: anObject - "change the receiver's property named aSymbol to anObject" - - "the properties dictionary never has nil as value. - Asking for a nil value is the same as removing the property." - - anObject ifNil: [ - self removeProperty: aSymbol. - ^nil]. - properties ifNil: [ properties _ IdentityDictionary new ]. - properties at: aSymbol put: anObject. - ^anObject! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/13/2021 09:58:46' prior: 50575804! - displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - aRectangle is clipped appropiately if some owner clips us. - See also #displayBoundsUpdateFrom:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - self isOrthoRectangularMorph - ifTrue: [ - "In these cases, #drawOn: might not be able to find bounds (InnerTextMorph, for example), - but it is OK to compute them from #morphLocalBounds. This is not true for non-orthoRectangular morphs!!" - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphFromLocalBounds ] - ifFalse: [ - "In this cases, we use the bounds bound by #drawOn. This method must therefore be called after calling #drawOn:." - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphAfterDraw. - self setProperty: #contour toValue: ( - self wantsContour ifTrue: [ aCanvas contourOfCurrentMorphAfterDrawInto: (self valueOfProperty: #contour) ])]]]].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/13/2021 09:58:48' prior: 50575895! - displayBoundsUpdateFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us. - To be called after #postDrawOn:. See also #displayBoundsSetFrom: - This more complicated update is needed because the contour information from #drawOn: was possibly - when drawing submorphs. So, the controur from #drawOn: needs to be retrieved, and updated with the - new contour information from #postDrawOn:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - self isOrthoRectangularMorph ifFalse: [ "Like in #displayBoundsSetFrom:" - | oldTop oldBottom | - oldTop _ privateDisplayBounds top max: 0. - oldBottom _ privateDisplayBounds bottom-1. - privateDisplayBounds _ privateDisplayBounds - quickMerge: aCanvas boundingRectOfCurrentMorphAfterDraw. - self setProperty: #contour toValue: - (self wantsContour ifTrue: [ - aCanvas - contourOfCurrentMorphAfterDrawUpdate: (self valueOfProperty: #contour) - oldTop: oldTop - oldBottom: oldBottom ])]]]].! ! -!Morph methodsFor: 'meta-actions' stamp: 'jmv 7/12/2021 17:37:54' prior: 50559916! - potentialEmbeddingTargets - "Return the potential targets for embedding the receiver" - | myRect myWorld | - owner ifNil:[^#()]. - myWorld := owner world ifNil: [^#()]. - myRect := self displayFullBounds. - ^Array streamContents: [ :strm | - myWorld allMorphsBut: self do: [ :m | - (m isReallyVisible - and: [ m isLocked not - and: [(m displayFullBounds intersects: myRect) - and: [(m ~= self) - and: [(#(HaloMorph HaloHandleMorph) statePointsTo: m class name) not]]]]) - ifTrue: [ strm nextPut: m ]]].! ! -!MovableMorph methodsFor: 'accessing' stamp: 'jmv 7/8/2021 19:01:42' prior: 50559761 overrides: 50559745! - location: aGeometryTransformation - location _ aGeometryTransformation. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/13/2021 09:43:07' prior: 50571087! - doRot: evt with: rotHandle - "Update the rotation of my target if it is rotatable." - - | radians prevLocation | - evt hand obtainHalo: self. - radians _ (evt eventPosition - target referencePosition) theta + angleOffset. - radians _ radians detentBy: 0.05 atMultiplesOf: Float pi / 4 snap: false. - rotHandle color: (radians = 0.0 - ifTrue: [`Color lightBlue`] - ifFalse: [`Color blue`]). - rotHandle submorphsDo: [ :m | - m color: rotHandle color makeForegroundColor]. - prevLocation _ target location. - target location: (prevLocation composedWith: ( - AffineTransformation withRadians: radians-prevLocation radians around: target rotationCenter)). - rotHandle morphPositionInWorld: evt eventPosition - (rotHandle morphExtent // 2). - self redrawNeeded.! ! -!InnerTextMorph methodsFor: 'accessing' stamp: 'jmv 7/13/2021 09:48:52' prior: 50433824! - crAction: aBlock - "Sets the action to perform when user presses key" - self setProperty: #crAction toValue: aBlock! ! -!InnerTextMorph methodsFor: 'accessing' stamp: 'jmv 7/13/2021 09:49:29' prior: 50432744! - escAction: aBlock - "Sets the action to perform when user presses key" - - self setProperty: #escAction toValue: aBlock.! ! - -KernelMorph removeSelector: #referencePosition! - -!methodRemoval: KernelMorph #referencePosition stamp: 'Install-4661-RotationCenter-JuanVuletich-2021Jul13-09h35m-jmv.002.cs.st 7/20/2021 16:52:50'! -referencePosition - "Return the current reference position of the receiver" - "a rather ugly way to say #center . At least, we avoid false polymorphism" - "remove some day" - self flag: #jmvVer2. - self displayBounds ifNotNil: [ :r | r center ]. - ^ self morphExtentInWorld // 2 + self morphPositionInWorld! - -MovableMorph removeSelector: #referencePosition:! - -!methodRemoval: MovableMorph #referencePosition: stamp: 'Install-4661-RotationCenter-JuanVuletich-2021Jul13-09h35m-jmv.002.cs.st 7/20/2021 16:52:50'! -referencePosition: aPoint - "a rather ugly way to say #center: . Just for consistency with #referencePosition" - "remove some day" - self flag: #jmvVer2. - self morphPositionInWorld: aPoint - (self morphExtentInWorld // 2)! - -Morph removeSelector: #knowsContour! - -!methodRemoval: Morph #knowsContour stamp: 'Install-4661-RotationCenter-JuanVuletich-2021Jul13-09h35m-jmv.002.cs.st 7/20/2021 16:52:50'! -knowsContour - "True if a morph requires the Canvas to update a #morphContour property on us. - Any subclass might answer true, if it #requiresVectorCanvas. - By default, any top morph that is drawn by VectorCanvas." - - ^self requiresVectorCanvas and: [ self isOwnedByWorldOrHand ]! - -Morph removeSelector: #rotationCenter! - -Morph removeSelector: #referencePosition! - -!methodRemoval: Morph #referencePosition stamp: 'Install-4661-RotationCenter-JuanVuletich-2021Jul13-09h35m-jmv.002.cs.st 7/20/2021 16:52:50'! -referencePosition - "Return the current reference position of the receiver" - "a rather ugly way to say #center . At least, we avoid false polymorphism" - "remove some day" - - self displayBounds ifNotNil: [ :r | r center ]. - ^0@0! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4661-RotationCenter-JuanVuletich-2021Jul13-09h35m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4661] on 13 July 2021 at 11:16:45 am'! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/13/2021 11:16:25' prior: 50571111! - doScale: evt with: scaleHandle - "Update the scale of my target if it is scalable." - - | scale | -"MUST fix resize / rescale / rotation of embedded morphs!!!!!!" - evt hand obtainHalo: self. - scale _ (evt eventPosition - target morphPositionInWorld) rho * scaleOffset. - scale = 1.0 - ifTrue: [scaleHandle color: `Color lightBlue`] - ifFalse: [scaleHandle color: `Color blue`]. - scaleHandle submorphsDo: - [:m | m color: scaleHandle color makeForegroundColor]. - target scale: scale. - scaleHandle morphPositionInWorld: evt eventPosition - (scaleHandle morphExtent // 2). - self redrawNeeded.! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/13/2021 11:16:31' prior: 50559049! - startScale: evt with: scaleHandle - "Initialize scale of my target if it is scalable." - - evt hand obtainHalo: self. "Make sure the event's hand correlates with the receiver" - - self removeAllHandlesBut: scaleHandle. "remove all other handles" - scaleOffset _ target scale / (evt eventPosition - target morphPositionInWorld) rho.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4662-ScalingFix-JuanVuletich-2021Jul13-11h16m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4662] on 13 July 2021 at 11:29:20 am'! -!Morph methodsFor: 'drawing' stamp: 'jmv 7/13/2021 10:20:27' prior: 50500302! - icon - ^ (self imageForm: 16@16 depth: 32) - ifNil: [ Theme current morphsIcon ]! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 7/13/2021 11:25:11' prior: 50566250! - imageForm: extent depth: depth - - ^(self imageForm: depth) magnifyTo: extent! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 7/13/2021 11:28:28' prior: 50516964! - addButtonFor: aMorph - - | button | - aMorph == self ifFalse: [ - button _ HoverableButtonMorph - model: aMorph - stateGetter: nil - action: #endPreviewAndToggleCollapseOrShow - onMouseEnterSend: #beginPreview - onMouseLeaveSend: #endPreview. - (aMorph is: #SystemWindow) ifTrue: [ - button - secondaryActionSelector: #offerWindowMenu ]. - button - color: self color; - icon: (aMorph imageForm: self defaultHeight*5//4 @ self defaultHeight depth: 32); - setBalloonText: #label. - viewBox - addMorph: button - fixedWidth: self defaultHeight ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4663-TaskbarButtonTweak-JuanVuletich-2021Jul13-11h23m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4663] on 13 July 2021 at 4:16:54 pm'! - -Object subclass: #SHST80RangeType - instanceVariableNames: 'sourceCode messageRange receiverRange messageRangeType receiverRangeType classOrMetaClass lastRange ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -!classDefinition: #SHST80RangeType category: #'Tools-Syntax Highlighting' stamp: 'Install-4664-ShoutRangeTypeFix-JuanVuletich-2021Jul13-16h10m-jmv.001.cs.st 7/20/2021 16:52:50'! -Object subclass: #SHST80RangeType - instanceVariableNames: 'sourceCode messageRange receiverRange messageRangeType receiverRangeType classOrMetaClass lastRange' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'jmv 7/13/2021 16:11:41' prior: 50567046! - receiverAsNumber - - "if the user typed 1xe for example, asNumber will throw an exception because it is not a valid number - even though the SHParser recognized it as such. I return nil because it is not really a number. - Thank you Luciano for reporting the bug - Hernan" - ^[ (self sourceCodeIn: lastRange) asNumber ] - on: Error - do: [ :anError | anError return: nil ]! ! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'jmv 7/13/2021 16:11:41' prior: 50545486! - receiverAsSymbol - - ^ (self sourceCodeIn: lastRange) asSymbol! ! -!SHST80RangeType methodsFor: 'range type - private' stamp: 'jmv 7/13/2021 16:11:41' prior: 50545505! - typeWhenSendToClassVar - - | classVarValue | - - ^ classOrMetaClass - ifNil: [ messageRangeType ] - ifNotNil: [ - classVarValue := classOrMetaClass theNonMetaClass classVarValueOf: (self sourceCodeIn: lastRange). - self typeWhenSendTo: classVarValue ]! ! -!SHST80RangeType methodsFor: 'range type' stamp: 'jmv 7/13/2021 16:11:41' prior: 50545555! - lastRange: aRange - - lastRange := aRange ! ! -!SHST80RangeType methodsFor: 'range type' stamp: 'jmv 7/13/2021 16:15:55' prior: 50545559! - ofCurrentRangeOrMessageSendIn: aPotentialMessageRange - - | potentialMessageRangeType lastRangeType | - - potentialMessageRangeType := aPotentialMessageRange rangeType. - - potentialMessageRangeType = #unary ifFalse: [ ^potentialMessageRangeType ]. - lastRange ifNil: [ ^potentialMessageRangeType ]. - - messageRange := aPotentialMessageRange. - messageRangeType := potentialMessageRangeType. - lastRangeType := lastRange rangeType. - - lastRangeType = #number ifTrue: [ ^self typeWhenSendToNumber ]. - lastRangeType = #string ifTrue: [ ^self typeWhenSendToInstanceOf: String ]. - lastRangeType = #symbol ifTrue: [ ^self typeWhenSendToInstanceOf: Symbol ]. - lastRangeType = #arrayEnd ifTrue: [ ^self typeWhenSendToInstanceOf: Array ]. - lastRangeType = #rightBrace ifTrue: [ ^self typeWhenSendToInstanceOf: Array ]. - lastRangeType = #blockEnd ifTrue: [ ^self typeWhenSendToInstanceOf: BlockClosure ]. - lastRangeType = #character ifTrue: [ ^self typeWhenSendToInstanceOf: Character ]. - lastRangeType = #nil ifTrue: [ ^self typeWhenSendToInstanceOf: nil class ]. - lastRangeType = #true ifTrue: [ ^self typeWhenSendToInstanceOf: true class ]. - lastRangeType = #false ifTrue: [ ^self typeWhenSendToInstanceOf: false class ]. - lastRangeType = #self ifTrue: [^self typeWhenSendToSelf ]. - lastRangeType = #super ifTrue: [^self typeWhenSendToSuper ]. - lastRangeType = #globalVar ifTrue: [^self typeWhenSendToGlobal ]. - lastRangeType = #classVar ifTrue: [^self typeWhenSendToClassVar ]. - - ^messageRangeType.! ! - -Object subclass: #SHST80RangeType - instanceVariableNames: 'sourceCode messageRange messageRangeType lastRange classOrMetaClass' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -!classDefinition: #SHST80RangeType category: #'Tools-Syntax Highlighting' stamp: 'Install-4664-ShoutRangeTypeFix-JuanVuletich-2021Jul13-16h10m-jmv.001.cs.st 7/20/2021 16:52:50'! -Object subclass: #SHST80RangeType - instanceVariableNames: 'sourceCode messageRange messageRangeType lastRange classOrMetaClass' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4664-ShoutRangeTypeFix-JuanVuletich-2021Jul13-16h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4664] on 13 July 2021 at 4:40:17 pm'! -!FileSystemEntry methodsFor: 'testing' stamp: 'jmv 7/13/2021 16:40:01'! - updateExists - - self subclassResponsibility! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4665-cleanup-JuanVuletich-2021Jul13-16h39m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4665] on 15 July 2021 at 10:48:24 am'! -!Debugger methodsFor: 'context stack menu' stamp: 'HAW 7/15/2021 10:09:27'! - addCategoriesOf: aClass to: categories separatingWith: lines - - | classCategories reject | - - classCategories := aClass methodCategoriesAsSortedCollection. - reject := classCategories asSet. - aClass isMeta ifTrue: [ - categories add: Categorizer instanceCreation. - classCategories remove: Categorizer instanceCreation ifAbsent: []. - reject add: Categorizer instanceCreation]. - reject - add: ClassOrganizer nullCategory; - add: ClassOrganizer default. - categories addAll: classCategories. - - aClass allSuperclasses do: [ :superclass | | superclassCategories | - superclassCategories := superclass methodCategoriesAsSortedCollection reject: [ :cat | reject includes: cat]. - superclassCategories isEmpty ifFalse: [ - lines add: categories size. - categories addAll: superclassCategories. - reject addAll: superclassCategories]]. - -! ! -!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'HAW 7/15/2021 09:58:10'! - methodCategories - - | categories | - - categories := OrderedCollection withAll: self organization categories. - categories remove: ClassOrganizer nullCategory asSymbol ifAbsent: nil. - - ^categories ! ! -!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'HAW 7/15/2021 09:54:49'! - methodCategoriesAsSortedCollection - - ^self methodCategories asSortedCollection: [ :leftCategory :rightCategory | leftCategory asLowercase < rightCategory asLowercase ] -! ! -!Debugger methodsFor: 'context stack menu' stamp: 'HAW 7/15/2021 10:09:20' prior: 50514251! - askForCategoryIn: aClass default: aDefaultCategory - - | categories index category lines | - - categories := OrderedCollection with: 'new ...'. - lines := OrderedCollection with: 1. - self addCategoriesOf: aClass to: categories separatingWith: lines. - - index := (PopUpMenu labelArray: categories lines: lines) - startUpWithCaption: 'Please provide a good category for the new method!!'. - index = 0 ifTrue: [^ aDefaultCategory]. - category := index = 1 - ifTrue: [self request: 'Enter category name:' initialAnswer: ''] - ifFalse: [categories at: index]. - - ^ category isEmpty ifTrue: [aDefaultCategory] ifFalse: [category]! ! -!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'HAW 7/15/2021 09:59:16' prior: 50476501! - allMethodCategoriesIntegratedThrough: mostGenericClass - "Answer a list of all the method categories of the receiver and all its superclasses, up through mostGenericClass" - - | aColl | - aColl _ OrderedCollection new. - self withAllSuperclasses do: [ :aClass | - (aClass includesBehavior: mostGenericClass) - ifTrue: [ aColl addAll: aClass methodCategories ]]. - - ^ aColl asSet asSortedCollection: [ :a :b | a asLowercase < b asLowercase ] - -"ColorTileMorph allMethodCategoriesIntegratedThrough: TileMorph"! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4666-CuisCore-JoaquinSinguerHernanWilkinson-2021Jul15-09h37m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4666] on 15 July 2021 at 2:30:43 pm'! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/15/2021 14:30:32' prior: 50571065! - doResize: evt with: resizeHandle - "Called while the mouse is down in the grow handle" - - | newExtent | - evt hand obtainHalo: self. - newExtent _ (evt eventPosition - target morphPositionInWorld) - positionOffset. - (newExtent x = 0 or: [newExtent y = 0]) ifTrue: [^ self]. - target morphExtentInWorld: newExtent. - resizeHandle morphPositionInWorld: evt eventPosition - (resizeHandle morphExtent // 2). - self redrawNeeded.! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/15/2021 14:28:28' prior: 50576293! - doScale: evt with: scaleHandle - "Update the scale of my target if it is scalable." - - | scale | - evt hand obtainHalo: self. - scale _ (evt eventPosition - target morphPositionInWorld) rho * scaleOffset. - scale = 1.0 - ifTrue: [scaleHandle color: `Color lightBlue`] - ifFalse: [scaleHandle color: `Color blue`]. - scaleHandle submorphsDo: - [:m | m color: scaleHandle color makeForegroundColor]. - target scale: scale. - scaleHandle morphPositionInWorld: evt eventPosition - (scaleHandle morphExtent // 2). - self redrawNeeded.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4667-Halo-cleanup-JuanVuletich-2021Jul15-14h28m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4666] on 15 July 2021 at 3:09:36 pm'! -!TextEditor methodsFor: 'attributes' stamp: 'jmv 7/15/2021 15:05:21'! - offerFontStyleMenu - "This is a user command, and generates undo" - - | emphases menuStrings entries reply code startIndex attribute | - startIndex _ self startIndex. - code _ model actualContents emphasisAt: startIndex. - emphases _ #(bold italic underlined struckThrough superscript subscript withST80Glyphs). - menuStrings _ Array streamContents: [ :strm | - strm nextPut:(code isZero ifTrue: [''] ifFalse: ['']), 'normal'. - emphases do: [ :emph | - strm nextPut: - ((code anyMask: (TextEmphasis perform: emph) emphasisCode) - ifTrue: [''] ifFalse: ['']), - emph asString ]]. - entries _ `#(normal)`, emphases. - reply _ (SelectionMenu labelList: menuStrings lines: #(1) selections: entries) startUpMenu. - reply ifNotNil: [ - attribute _ TextEmphasis perform: reply. - ((menuStrings at: (entries indexOf: reply)) beginsWith: '') - ifTrue: [ self unapplyAttributes: {attribute} ] - ifFalse: [ self applyAttribute: attribute ]]. - morph updateFromTextComposition.! ! -!TextEditor methodsFor: 'menu' stamp: 'jmv 7/15/2021 15:03:50' prior: 50474131! - addStyleMenuSectionTo: aMenu - "Adds to the given menu text styiling related operations" - - aMenu - addItemsFromDictionaries: - `{ - { - #label -> 'Toggle WordWrap'. - #selector -> #wrapOnOff. - #icon -> #genericTextIcon - } asDictionary. - { - #label -> 'Set Font... (k)'. - #selector -> #offerFontMenu. - #icon -> #preferencesDesktopFontIcon - } asDictionary. - { - #label -> 'Clear Font'. - #selector -> #clearFont. - #icon -> #newIcon - } asDictionary. - { - #label -> 'Set Font Style'. - #selector -> #offerFontStyleMenu. - #icon -> #preferencesDesktopFontIcon - } asDictionary. - { - #label -> 'Set Default Font...'. - #selector -> #offerDefaultFontMenu. - #icon -> #fontXGenericIcon - } asDictionary. - { - #label -> 'Set Alignment...'. - #selector -> #chooseAlignment. - #icon -> #formatJustifyLeftIcon - } asDictionary. - }`. - ^aMenu! ! -!Preferences class methodsFor: 'halos' stamp: 'jmv 7/15/2021 15:07:49' prior: 50558909! - iconicHaloSpecifications - "Answer an array that characterizes the locations, colors, icons, and selectors of the halo handles that may be used in the iconic halo scheme" - - " - Preferences resetHaloSpecifications - " - -^ #( - "selector horiz vert color info icon key balloon help - --------- ------ ----------- -------------------------- -------------------------- ---------------" - (addCollapseHandle: left topCenter (tan) haloCollapseIcon 'Collapse') - (addDebugHandle: right topCenter (orange) haloDebugIcon 'Debug') - (addDismissHandle: left top (red) haloDismissIcon 'Remove') - (addRotateHandle: left bottom (blue) haloRotateIcon 'Rotate') - (addMenuHandle: leftCenter top (blue lighter) haloMenuIcon 'Menu') - (addGrabHandle: center top (black) haloGrabIcon 'Pick up') - (addDragHandle: rightCenter top (brown) haloDragIcon 'Move') - (addDupHandle: right top (green) haloDuplicateIcon 'Duplicate') - (addHelpHandle: center bottom (lightBlue) haloHelpIcon 'Help') - (addResizeHandle: right bottom (yellow) haloResizeIcon 'Change size') - (addScaleHandle: right bottom (blue) haloScaleIcon 'Change scale') - "FIXME - Currently non-functional... - (addRecolorHandle: right bottomCenter (magenta darker) haloColorIcon 'Change color') - " -)! ! - -InnerTextMorph removeSelector: #chooseFont! - -!methodRemoval: InnerTextMorph #chooseFont stamp: 'Install-4668-FontStyleMenu-JuanVuletich-2021Jul15-14h30m-jmv.001.cs.st 7/20/2021 16:52:50'! -chooseFont - self editor offerFontMenu. - self updateFromTextComposition.! - -InnerTextMorph removeSelector: #chooseEmphasisOrAlignment! - -!methodRemoval: InnerTextMorph #chooseEmphasisOrAlignment stamp: 'Install-4668-FontStyleMenu-JuanVuletich-2021Jul15-14h30m-jmv.001.cs.st 7/20/2021 16:52:50'! -chooseEmphasisOrAlignment - self editor changeEmphasisOrAlignment. - self updateFromTextComposition! - -InnerTextMorph removeSelector: #chooseEmphasis! - -HaloMorph removeSelector: #chooseEmphasisOrAlignment! - -!methodRemoval: HaloMorph #chooseEmphasisOrAlignment stamp: 'Install-4668-FontStyleMenu-JuanVuletich-2021Jul15-14h30m-jmv.001.cs.st 7/20/2021 16:52:50'! -chooseEmphasisOrAlignment - target chooseEmphasisOrAlignment! - -HaloMorph removeSelector: #chooseFont! - -!methodRemoval: HaloMorph #chooseFont stamp: 'Install-4668-FontStyleMenu-JuanVuletich-2021Jul15-14h30m-jmv.001.cs.st 7/20/2021 16:52:50'! -chooseFont - target chooseFont! - -HaloMorph removeSelector: #addFontEmphHandle:! - -!methodRemoval: HaloMorph #addFontEmphHandle: stamp: 'Install-4668-FontStyleMenu-JuanVuletich-2021Jul15-14h30m-jmv.001.cs.st 7/20/2021 16:52:50'! -addFontEmphHandle: haloSpec - - (target is: #InnerTextMorph) ifTrue: [ - (self addHandle: haloSpec) mouseDownSelector: #chooseEmphasisOrAlignment ]! - -HaloMorph removeSelector: #addFontSizeHandle:! - -!methodRemoval: HaloMorph #addFontSizeHandle: stamp: 'Install-4668-FontStyleMenu-JuanVuletich-2021Jul15-14h30m-jmv.001.cs.st 7/20/2021 16:52:50'! -addFontSizeHandle: haloSpec - - (target is: #InnerTextMorph) ifTrue: [ - (self addHandle: haloSpec) mouseDownSelector: #chooseFont]! - -TextEditor removeSelector: #changeEmphasis! - -TextEditor removeSelector: #changeEmphasisOrAlignment! - -!methodRemoval: TextEditor #changeEmphasisOrAlignment stamp: 'Install-4668-FontStyleMenu-JuanVuletich-2021Jul15-14h30m-jmv.001.cs.st 7/20/2021 16:52:50'! -changeEmphasisOrAlignment - "This is a user command, and generates undo" - - | menuStrings aList reply code align menuList startIndex attribute | - startIndex _ self startIndex. - aList _ #(normal bold italic underlined struckThrough leftFlush centered rightFlush justified). - align _ model actualContents alignmentAt: startIndex. - code _ model actualContents emphasisAt: startIndex. - menuList _ WriteStream on: Array new. - menuList nextPut: (code isZero ifTrue:[''] ifFalse:['']), 'normal'. - menuList nextPutAll: (#(bold italic underlined struckThrough superscript subscript withST80Glyphs) collect: [ :emph | - (code anyMask: (TextEmphasis perform: emph) emphasisCode) - ifTrue: [ '', emph asString ] - ifFalse: [ '', emph asString ]]). - menuList nextPutAll: (#(leftFlush centered rightFlush justified) withIndexCollect: [ :type :i | - align = (i-1) - ifTrue: [ '', type asString ] - ifFalse: [ '', type asString ]]). - menuStrings _ menuList contents. - aList _ #(normal bold italic underlined struckThrough superscript subscript withST80Glyphs leftFlush centered rightFlush justified). - reply _ (SelectionMenu labelList: menuStrings lines: #(1 8) selections: aList) startUpMenu. - reply ifNotNil: [ - (#(leftFlush centered rightFlush justified) includes: reply) - ifTrue: [ - attribute _ TextAlignment perform: reply] - ifFalse: [ - attribute _ TextEmphasis perform: reply]. - ((menuStrings at: (aList indexOf: reply)) beginsWith: '') - ifTrue: [ self unapplyAttributes: {attribute} ] - ifFalse: [ self applyAttribute: attribute ]]. - ^ true! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4668-FontStyleMenu-JuanVuletich-2021Jul15-14h30m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4666] on 15 July 2021 at 3:29:59 pm'! -!TextEditor methodsFor: 'attributes' stamp: 'jmv 7/15/2021 15:23:41' prior: 50357860! - offerColorMenu - "Present a menu of available colors, and if one is chosen, apply it to the current selection." - "This is a user command, and generates undo" - - | attribute colors index thisSel | - thisSel _ self selection. - colors _ #(#black #magenta #red #yellow #green #blue #cyan #white ). - index _ (PopUpMenu - labelArray: colors , #('choose color...' ) - lines: (Array with: colors size + 1)) startUpMenu. - index = 0 ifTrue: [ ^ true ]. - index <= colors size - ifTrue: [ attribute _ TextColor color: (Color perform: (colors at: index)) ] - ifFalse: [ - index _ index - colors size - 1. - "Re-number!!!!!!" - index = 0 ifTrue: [ attribute _ self chooseColor ]. - thisSel ifNil: [ ^ true ]]. - attribute ifNotNil: [ self applyAttribute: attribute ]. - morph updateFromTextComposition. - ^ true.! ! -!TextEditor methodsFor: 'menu' stamp: 'jmv 7/15/2021 15:29:16' prior: 50576692! - addStyleMenuSectionTo: aMenu - "Adds to the given menu text styiling related operations" - - aMenu - addItemsFromDictionaries: - `{ - { - #label -> 'Toggle WordWrap'. - #selector -> #wrapOnOff. - #icon -> #genericTextIcon - } asDictionary. - { - #label -> 'Set Font... (k)'. - #selector -> #offerFontMenu. - #icon -> #preferencesDesktopFontIcon - } asDictionary. - { - #label -> 'Clear Font'. - #selector -> #clearFont. - #icon -> #newIcon - } asDictionary. - { - #label -> 'Set Font Style'. - #selector -> #offerFontStyleMenu. - #icon -> #preferencesDesktopFontIcon - } asDictionary. - { - #label -> 'Set Text Color'. - #selector -> #offerColorMenu. - #icon -> #graphicsIcon - } asDictionary. - { - #label -> 'Set Default Font...'. - #selector -> #offerDefaultFontMenu. - #icon -> #fontXGenericIcon - } asDictionary. - { - #label -> 'Set Alignment...'. - #selector -> #chooseAlignment. - #icon -> #formatJustifyLeftIcon - } asDictionary. - }`. - ^aMenu! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4669-TextColorMenu-JuanVuletich-2021Jul15-15h09m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4669] on 15 July 2021 at 4:20:55 pm'! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 7/15/2021 16:20:29'! - okayToScaleEasily - "Answer whether it is appropriate for a scale handle to be shown for the receiver." - - ^ self hasOwnLocation and: [MorphicCanvas activeSubclass ~~ BitBltCanvas ]! ! -!HaloMorph methodsFor: 'handles' stamp: 'jmv 7/15/2021 15:35:39'! - addExploreHandle: handleSpec - - Preferences debugHaloHandle ifTrue: [ - (self addHandle: handleSpec) - mouseDownSelector: #doExplore:with: ] -! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/15/2021 15:41:53'! - doExplore: evt with: aHandle - - evt hand obtainHalo: self. - ^ target explore! ! -!Preferences class methodsFor: 'halos' stamp: 'jmv 7/15/2021 15:35:00' prior: 50576726! - iconicHaloSpecifications - "Answer an array that characterizes the locations, colors, icons, and selectors of the halo handles that may be used in the iconic halo scheme" - - " - Preferences resetHaloSpecifications - " - -^ #( - "selector horiz vert color info icon key balloon help - --------- ------ ------- --------- ------------ ----------" - (addDismissHandle: left top (red) haloDismissIcon 'Remove') - (addMenuHandle: leftCenter top (blue lighter) haloMenuIcon 'Menu') - (addGrabHandle: center top (black) haloGrabIcon 'Pick up') - (addDragHandle: rightCenter top (brown) haloDragIcon 'Move') - (addDupHandle: right top (green) haloDuplicateIcon 'Duplicate') - - (addExploreHandle: left topCenter (orange) haloDebugIcon 'Explore') - (addDebugHandle: right topCenter (orange) haloDebugIcon 'Debug') - (addCollapseHandle: left center (tan) haloCollapseIcon 'Collapse') - (addScaleHandle: right center (blue) haloScaleIcon 'Change scale') - - (addRotateHandle: left bottom (blue) haloRotateIcon 'Rotate') - (addHelpHandle: center bottom (lightBlue) haloHelpIcon 'Help') - (addResizeHandle: right bottom (yellow) haloResizeIcon 'Change size') - - "FIXME - Currently non-functional... - (addRecolorHandle: right bottomCenter (magenta darker) haloColorIcon 'Change color') - " -)! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 7/15/2021 15:50:50' prior: 16875762! - okayToResizeEasily - "Answer whether it is appropriate to have the receiver be easily resized by the user from the halo" - - ^ self hasVariableExtent! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 7/15/2021 16:20:37' prior: 16875779! - okayToRotateEasily - "Answer whether it is appropriate for a rotation handle to be shown for the receiver." - - ^ self hasOwnLocation and: [MorphicCanvas activeSubclass ~~ BitBltCanvas ]! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 7/15/2021 15:56:06' prior: 50558422! - wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph - "Answer whether the receiver would like to offer the halo handle with the given selector (e.g. #addCollapseHandle:)" - - (#(addRecolorHandle:) statePointsTo: aSelector) - ifTrue: ["FIXME - hack to disable for non-functional halo items" - ^ false]. - - Preferences selectiveHalos ifFalse: [ - ^true ]. - - (#(#addDismissHandle: ) includes: aSelector) - ifTrue: [ ^ self resistsRemoval not ]. - (#(#addDragHandle: ) includes: aSelector) - ifTrue: [ ^ self okayToBrownDragEasily ]. - (#(#addResizeHandle: ) includes: aSelector) - ifTrue: [ ^ self okayToResizeEasily | self okayToScaleEasily ]. - (#(#addRotateHandle: ) includes: aSelector) - ifTrue: [ ^ self okayToRotateEasily ]. - (#(#addScaleHandle: ) includes: aSelector) - ifTrue: [ ^ self okayToScaleEasily ]. - (#(#addRecolorHandle: ) includes: aSelector) - ifTrue: [ ^ self wantsRecolorHandle ]. - ^ true! ! -!HaloMorph methodsFor: 'handles' stamp: 'jmv 7/15/2021 15:57:34' prior: 50558984! - addResizeHandle: haloSpec - - target okayToResizeEasily ifTrue: [ - ^(self addHandle: haloSpec) - mouseDownSelector: #startResize:with:; - mouseMoveSelector: #doResize:with: ]. - - target okayToScaleEasily ifTrue: [ - ^(self addHandle: haloSpec) - mouseDownSelector: #startScale:with:; - mouseMoveSelector: #doScale:with: ].! ! -!HaloMorph methodsFor: 'handles' stamp: 'jmv 7/15/2021 15:52:54' prior: 50558993! - addRotateHandle: haloSpec - - (self addHandle: haloSpec) - mouseDownSelector: #startRot:with:; - mouseMoveSelector: #doRot:with:! ! -!HaloMorph methodsFor: 'handles' stamp: 'jmv 7/15/2021 15:54:51' prior: 50559003! - addScaleHandle: haloSpec - - (self addHandle: haloSpec) - mouseDownSelector: #startScale:with:; - mouseMoveSelector: #doScale:with:! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/15/2021 15:41:47' prior: 16850958! - doDebug: evt with: menuHandle - "Ask hand to invoke the a debugging menu for my inner target. If shift key is down, immediately put up an inspector on the inner target" - - | menu | - evt hand obtainHalo: self. - evt shiftPressed ifTrue: [ - ^ target inspect]. - - menu _ target buildDebugMenu: evt hand. - menu addTitle: (target printStringLimitedTo: 40). - menu popUpInWorld: self world! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/15/2021 15:42:00' prior: 16851019! - doMenu: evt with: menuHandle - "Ask hand to invoke the halo menu for my inner target." - - | menu | - evt hand obtainHalo: self. - menu _ target buildHandleMenu: evt hand. - target addTitleForHaloMenu: menu. - menu popUpInWorld: self world. -! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - Preferences resetHaloSpecifications! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4670-ExploreScaleAndRotateHalos-JuanVuletich-2021Jul15-16h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4670] on 16 July 2021 at 6:24:47 pm'! -!Morph methodsFor: 'accessing - properties' stamp: 'jmv 7/16/2021 17:42:29'! - valueOfProperty: aSymbol ifAbsentPut: aBlock - "if the receiver possesses a property of the given name, answer - its value. If not then evaluate aBlock to obtain the value to be - stored and answered." - - ^ self valueOfProperty: aSymbol ifAbsent: [ - self setProperty: aSymbol toValue: aBlock value ]! ! -!TaskbarMorph methodsFor: 'initialization' stamp: 'jmv 7/16/2021 16:57:24' prior: 50453848! - defaultHeight - - ^ (Preferences windowTitleFont lineSpacing * 2 * self scale) asInteger! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 7/16/2021 17:44:19' prior: 50576346! - addButtonFor: aMorph - - | button taskbarButtonIcon | - aMorph == self ifFalse: [ - button _ HoverableButtonMorph - model: aMorph - stateGetter: nil - action: #endPreviewAndToggleCollapseOrShow - onMouseEnterSend: #beginPreview - onMouseLeaveSend: #endPreview. - (aMorph is: #SystemWindow) ifTrue: [ - button - secondaryActionSelector: #offerWindowMenu ]. - taskbarButtonIcon _ aMorph - valueOfProperty: #taskbarButtonIcon - ifAbsentPut: [aMorph imageForm: self defaultHeight*5//4 @ self defaultHeight depth: 32]. - button - color: self color; - icon: taskbarButtonIcon; - setBalloonText: #label. - viewBox - addMorph: button - fixedWidth: self defaultHeight ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4671-TaskbarButtonOptimization-JuanVuletich-2021Jul16-18h23m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4670] on 16 July 2021 at 6:27:13 pm'! -!Morph methodsFor: 'testing' stamp: 'jmv 7/16/2021 17:50:02'! - isIncludedInTaskbar - "Answer true a button for us should be added to any TaskbarMorph." - - ^ true! ! -!HandMorph methodsFor: 'testing' stamp: 'jmv 7/16/2021 18:19:02' overrides: 50577211! - isIncludedInTaskbar - "Answer true a button for us should be added to any TaskbarMorph." - - ^ false! ! -!HaloHandleMorph methodsFor: 'testing' stamp: 'jmv 7/16/2021 18:18:32' overrides: 50577211! - isIncludedInTaskbar - "Answer true a button for us should be added to any TaskbarMorph." - - ^ false! ! -!HaloMorph methodsFor: 'testing' stamp: 'jmv 7/16/2021 18:18:39' overrides: 50577211! - isIncludedInTaskbar - "Answer true a button for us should be added to any TaskbarMorph." - - ^ false! ! -!HoverHelpMorph methodsFor: 'testing' stamp: 'jmv 7/16/2021 18:19:17' overrides: 50577211! -isIncludedInTaskbar - "Answer true a button for us should be added to any TaskbarMorph." - - ^ false! ! -!MenuMorph methodsFor: 'testing' stamp: 'jmv 7/16/2021 18:20:02' overrides: 50577211! - isIncludedInTaskbar - "Answer true a button for us should be added to any TaskbarMorph." - - ^ false! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 7/16/2021 18:17:58' prior: 50432333! - wasOpened: aMorph - "aMorph was added to the world. Add button for aMorph if appropriate." - - aMorph isIncludedInTaskbar ifTrue: [ - self addButtonFor: aMorph ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4672-HalosHoverAndMenusNotInTaskbar-JuanVuletich-2021Jul16-18h24m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4672] on 16 July 2021 at 6:35:31 pm'! -!Morph methodsFor: 'drawing' stamp: 'jmv 7/16/2021 18:35:07' prior: 50536717! - imageForm: depth - - ^self imageForm: nil depth: depth.! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 7/16/2021 18:34:40' prior: 50576340! - imageForm: extentOrNil depth: depth - - | extent answer auxCanvas | - extent _ self morphExtent. - extentOrNil ifNotNil: [ extent _ extent min: extentOrNil * 4 ]. - auxCanvas _ BitBltCanvas depth: depth over: (self morphPosition floor extent: extent ceiling). - auxCanvas fullDraw: self. - answer _ auxCanvas form divideByAlpha. - extentOrNil ifNotNil: [ answer _ answer magnifyTo: extent ]. - ^answer.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4673-imageForm-JuanVuletich-2021Jul16-18h34m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4673] on 16 July 2021 at 7:47:04 pm'! -!WidgetMorph methodsFor: 'geometry testing' stamp: 'jmv 7/16/2021 19:44:54' prior: 50546056 overrides: 50532141! - requiresVectorCanvas - "True if we use VectorCanvas protocol, or we are rotated or zoomed. - If false, we occupy a Rectangle in local coordinates. Allows for many optimizations to be done. - Note: If answer is false, but some owner requiresVectorCanvas, then we also do. Canvas takes care of this. - Note: SystemWindow answers false, but implements #addPossiblyUncoveredAreasIn:to: to take care of rounded corners." - - ^location isPureTranslation not or: [ owner notNil and: [ owner requiresVectorCanvas ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4674-requiresVectorCanvas-fix-JuanVuletich-2021Jul16-19h44m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4674] on 17 July 2021 at 8:34:32 pm'! -!BitBlt methodsFor: 'private' stamp: 'jmv 7/17/2021 20:31:38' prior: 16785963! - copyBitsAgain - "Primitive. See BitBlt|copyBits, also a Primitive. Essential. See Object - documentation whatIsAPrimitive." - - - '#copyBitsAgain failed. Requested BitBlt operation not performed.' print! ! -!BitBlt methodsFor: 'private' stamp: 'jmv 7/17/2021 20:34:09' prior: 16786050! - roundVariables - - | maxVal minVal | - 'BitBlt >> copyBits failed. Will retry with parameters rounded. Requested parameters are:' print. - {'dest, source, halftone, rule:' . destForm . sourceForm . halftoneForm . combinationRule } print. - {'dest, extent, source, clipOrigin, clipExtent'. destX@destY. width@height. sourceX@sourceY. clipX@clipY. clipWidth@clipHeight } print. - {'colorMap'. colorMap } print. - maxVal _ SmallInteger maxVal. - minVal _ SmallInteger minVal. - destX _ destX asInteger min: maxVal max: minVal. - destY _ destY asInteger min: maxVal max: minVal. - width _ width asInteger min: maxVal max: minVal. - height _ height asInteger min: maxVal max: minVal. - sourceX _ sourceX asInteger min: maxVal max: minVal. - sourceY _ sourceY asInteger min: maxVal max: minVal. - clipX _ clipX asInteger min: maxVal max: minVal. - clipY _ clipY asInteger min: maxVal max: minVal. - clipWidth _ clipWidth asInteger min: maxVal max: minVal. - clipHeight _ clipHeight asInteger min: maxVal max: minVal. -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4675-BitBltFailureEnh-JuanVuletich-2021Jul17-20h30m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4675] on 18 July 2021 at 7:06:37 pm'! - -PluggableMorph subclass: #ScrollBar - instanceVariableNames: 'slider value setValueSelector sliderShadow upButton downButton scrollDelta pageDelta interval nextPageDirection grabPosition' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #ScrollBar category: 'Morphic-Widgets' stamp: 'Install-4676-Scrollbar-is-a-widget-JuanVuletich-2021Jul18-19h05m-jmv.001.cs.st 7/20/2021 16:52:50'! -PluggableMorph subclass: #ScrollBar - instanceVariableNames: 'slider value setValueSelector sliderShadow upButton downButton scrollDelta pageDelta interval nextPageDirection grabPosition' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4676-Scrollbar-is-a-widget-JuanVuletich-2021Jul18-19h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4677] on 19 July 2021 at 10:14:17 am'! -!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jmv 7/18/2021 19:23:08' overrides: 16876446! - label - ^label! ! -!MorphicCanvas methodsFor: 'drawing-widgets' stamp: 'jmv 7/18/2021 19:39:56'! - drawButton3D: aPluggableButtonMorph - - | borderStyleSymbol c | - borderStyleSymbol _ aPluggableButtonMorph isPressed ifFalse: [ #raised ] ifTrue: [ #inset ]. - c _ aPluggableButtonMorph color. - aPluggableButtonMorph mouseIsOver ifTrue: [ c _ c lighter ]. - self - fillRectangle: aPluggableButtonMorph morphLocalBounds - color: c - borderWidth: aPluggableButtonMorph borderWidth - borderStyleSymbol: borderStyleSymbol - baseColorForBorder: c. - - self drawButtonRegularLabel: aPluggableButtonMorph.! ! -!MorphicCanvas methodsFor: 'drawing-widgets' stamp: 'jmv 7/18/2021 19:33:54'! - drawButton: aPluggableButtonMorph - aPluggableButtonMorph isRoundButton - ifTrue: [ - (self drawButtonIcon: aPluggableButtonMorph) ifFalse: [ - self drawButtonRoundGradient: aPluggableButtonMorph ]] - ifFalse: [ - self drawButton3D: aPluggableButtonMorph. - self drawButtonIcon: aPluggableButtonMorph ]! ! -!MorphicCanvas methodsFor: 'drawing-widgets' stamp: 'jmv 7/18/2021 19:34:08'! - drawButtonEmbossedLabel: aPluggableButtonMorph - - | availableW center colorForLabel f l labelMargin targetSize w x y label | - label _ aPluggableButtonMorph label. - label ifNotNil: [ - colorForLabel _ Theme current buttonLabel. - aPluggableButtonMorph isPressed - ifFalse: [ - aPluggableButtonMorph mouseIsOver - ifFalse: [ colorForLabel _ colorForLabel adjustSaturation: -0.10 brightness: 0.10 ]] - ifTrue: [ colorForLabel _ colorForLabel adjustSaturation: 0.0 brightness: -0.07 ]. - f _ aPluggableButtonMorph fontToUse. - center _ aPluggableButtonMorph morphExtent // 2. - labelMargin _ 3. - w _ f widthOfString: label. - availableW _ aPluggableButtonMorph morphExtent x - labelMargin - labelMargin. - availableW >= w - ifTrue: [ - l _ label ] - ifFalse: [ - x _ labelMargin. - targetSize _ label size * availableW // w. - l _ label squeezedTo: targetSize. - (f widthOfString: l) > availableW ifTrue: [ - targetSize _ targetSize - 1. - l _ label squeezedTo: targetSize ]]. - - w _ f widthOfString: l. - x _ center x - (w // 2). - y _ center y - (f lineSpacing // 2). - self - drawString: l - at: x@y - font: f - color: colorForLabel - embossed: true ]! ! -!MorphicCanvas methodsFor: 'drawing-widgets' stamp: 'jmv 7/18/2021 19:34:59'! - drawButtonIcon: aPluggableButtonMorph - "We assume that we are drawing a PluggableButtonMorph, - or some morph that conforms the required protocol. - Answer true if we were able to draw it." - - self subclassResponsibility! ! -!MorphicCanvas methodsFor: 'drawing-widgets' stamp: 'jmv 7/18/2021 19:34:29'! - drawButtonRegularLabel: aPluggableButtonMorph - - | w f center x y availableW l labelMargin label | - - label _ aPluggableButtonMorph label. - f _ aPluggableButtonMorph fontToUse. - center _ aPluggableButtonMorph morphExtent // 2. - - label ifNotNil: [ - labelMargin _ 4. - w _ f widthOfString: label. - availableW _ aPluggableButtonMorph morphExtent x - labelMargin - labelMargin - 1. - availableW >= w - ifTrue: [ - x _ center x - (w // 2). - l _ label ] - ifFalse: [ - x _ labelMargin. - l _ label squeezedTo: (label size * availableW / w) rounded ]. - y _ center y - (f lineSpacing // 2). - aPluggableButtonMorph isPressed ifTrue: [ - x _ x + 1. - y _ y + 1 ]. - self - drawString: l - at: x@y - font: f - color: Theme current buttonLabel ]! ! -!MorphicCanvas methodsFor: 'drawing-widgets' stamp: 'jmv 7/18/2021 19:34:36'! - drawButtonRoundGradient: aPluggableButtonMorph - | r colorForButton rect bottomFactor topFactor color | - color _ aPluggableButtonMorph color. - aPluggableButtonMorph isPressed - ifFalse: [ - topFactor _ Theme current buttonGradientTopFactor. - bottomFactor _ Theme current buttonGradientBottomFactor. - aPluggableButtonMorph mouseIsOver - ifTrue: [ - colorForButton _ Color h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ - colorForButton _ color ]] - ifTrue: [ - topFactor _ Theme current buttonGradientBottomFactor. - bottomFactor _ Theme current buttonGradientTopFactor. - colorForButton _ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - Theme current useButtonGradient - ifTrue: [ - rect _ aPluggableButtonMorph morphLocalBounds insetBy: `1@3`. - self - roundRect: rect - color: colorForButton - radius: r - gradientTop: topFactor - gradientBottom: bottomFactor - gradientHeight: Theme current buttonGradientHeight ] - ifFalse: [ - rect _ aPluggableButtonMorph morphLocalBounds insetBy: `1@3`. - self roundRect: rect color: colorForButton radius: r ] - ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawButtonEmbossedLabel: aPluggableButtonMorph ] - ifFalse: [ self drawButtonRegularLabel: aPluggableButtonMorph ].! ! -!BitBltCanvas methodsFor: 'drawing-widgets' stamp: 'jmv 7/18/2021 19:29:05' overrides: 50577474! - drawButtonIcon: aPluggableButtonMorph - "We assume that we are drawing a PluggableButtonMorph, - or some morph that conforms the required protocol. - Answer true if we were able to draw it." - - aPluggableButtonMorph magnifiedIcon ifNotNil: [ :theIcon | | iconColor | - iconColor _ aPluggableButtonMorph isPressed - ifTrue: [ `Color gray: 0.75` ] - ifFalse: [ - aPluggableButtonMorph mouseIsOver - ifTrue: [ `Color gray: 0.75` ] - ifFalse: [ `Color white` ]]. - self - image: theIcon - multipliedBy: iconColor - at: (aPluggableButtonMorph morphExtent - theIcon extent //2). - ^true ]. - ^false! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 7/18/2021 19:09:00' prior: 16888132 overrides: 50545913! - drawOn: aCanvas - - aCanvas drawButton: self! ! - -BitBltCanvas removeSelector: #drawButtonIconFromCurrentMorph! - -!methodRemoval: BitBltCanvas #drawButtonIconFromCurrentMorph stamp: 'Install-4677-buttonDrawingInCanvas-JuanVuletich-2021Jul19-10h09m-jmv.001.cs.st 7/20/2021 16:52:50'! -drawButtonIconFromCurrentMorph - "We assume that we are drawing a PluggableButtonMorph, - or some morph that conforms the required protocol. - Answer true if we were able to draw it." - - currentMorph magnifiedIcon ifNotNil: [ :theIcon | - self - image: theIcon - multipliedBy: currentMorph iconColor - at: (currentMorph morphExtent - theIcon extent //2). - ^true ]. - ^false! - -MorphicCanvas removeSelector: #drawButtonIconFromCurrentMorph! - -!methodRemoval: MorphicCanvas #drawButtonIconFromCurrentMorph stamp: 'Install-4677-buttonDrawingInCanvas-JuanVuletich-2021Jul19-10h09m-jmv.001.cs.st 7/20/2021 16:52:50'! -drawButtonIconFromCurrentMorph - self subclassResponsibility ! - -PluggableButtonMorph removeSelector: #draw3DLookOn:! - -!methodRemoval: PluggableButtonMorph #draw3DLookOn: stamp: 'Install-4677-buttonDrawingInCanvas-JuanVuletich-2021Jul19-10h09m-jmv.001.cs.st 7/20/2021 16:52:50'! -draw3DLookOn: aCanvas - - | borderStyleSymbol c | - borderStyleSymbol _ self isPressed ifFalse: [ #raised ] ifTrue: [ #inset ]. - c _ color. - self mouseIsOver ifTrue: [ c _ c lighter ]. - aCanvas - fillRectangle: self morphLocalBounds - color: c - borderWidth: borderWidth - borderStyleSymbol: borderStyleSymbol - baseColorForBorder: c. - - self drawRegularLabelOn: aCanvas! - -PluggableButtonMorph removeSelector: #iconColor! - -!methodRemoval: PluggableButtonMorph #iconColor stamp: 'Install-4677-buttonDrawingInCanvas-JuanVuletich-2021Jul19-10h09m-jmv.001.cs.st 7/20/2021 16:52:50'! -iconColor - - ^ self isPressed - ifTrue: [ `Color gray: 0.75` ] - ifFalse: [ - self mouseIsOver - ifTrue: [ `Color gray: 0.75` ] - ifFalse: [ `Color white` ]].! - -PluggableButtonMorph removeSelector: #drawRoundGradientLookOn:! - -!methodRemoval: PluggableButtonMorph #drawRoundGradientLookOn: stamp: 'Install-4677-buttonDrawingInCanvas-JuanVuletich-2021Jul19-10h09m-jmv.001.cs.st 7/20/2021 16:52:50'! -drawRoundGradientLookOn: aCanvas - | r colorForButton rect bottomFactor topFactor | - - self isPressed - ifFalse: [ - topFactor _ Theme current buttonGradientTopFactor. - bottomFactor _ Theme current buttonGradientBottomFactor. - self mouseIsOver - ifTrue: [ - colorForButton _ Color h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ - colorForButton _ color ]] - ifTrue: [ - topFactor _ Theme current buttonGradientBottomFactor. - bottomFactor _ Theme current buttonGradientTopFactor. - colorForButton _ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - Theme current useButtonGradient - ifTrue: [ - rect _ self morphLocalBounds insetBy: `1@3`. - aCanvas - roundRect: rect - color: colorForButton - radius: r - gradientTop: topFactor - gradientBottom: bottomFactor - gradientHeight: Theme current buttonGradientHeight ] - ifFalse: [ - rect _ self morphLocalBounds insetBy: `1@3`. - aCanvas roundRect: rect color: colorForButton radius: r ] - ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawEmbossedLabelOn: aCanvas ] - ifFalse: [ self drawRegularLabelOn: aCanvas ]! - -PluggableButtonMorph removeSelector: #drawEmbossedLabelOn:! - -!methodRemoval: PluggableButtonMorph #drawEmbossedLabelOn: stamp: 'Install-4677-buttonDrawingInCanvas-JuanVuletich-2021Jul19-10h09m-jmv.001.cs.st 7/20/2021 16:52:50'! -drawEmbossedLabelOn: aCanvas - - | availableW center colorForLabel f l labelMargin targetSize w x y | - label ifNotNil: [ - colorForLabel _ Theme current buttonLabel. - self isPressed - ifFalse: [ - self mouseIsOver - ifFalse: [ colorForLabel _ colorForLabel adjustSaturation: -0.10 brightness: 0.10 ]] - ifTrue: [ colorForLabel _ colorForLabel adjustSaturation: 0.0 brightness: -0.07 ]. - f _ self fontToUse. - center _ extent // 2. - labelMargin _ 3. - w _ f widthOfString: label. - availableW _ extent x - labelMargin - labelMargin. - availableW >= w - ifTrue: [ - l _ label ] - ifFalse: [ - x _ labelMargin. - targetSize _ label size * availableW // w. - l _ label squeezedTo: targetSize. - (f widthOfString: l) > availableW ifTrue: [ - targetSize _ targetSize - 1. - l _ label squeezedTo: targetSize ]]. - - w _ f widthOfString: l. - x _ center x - (w // 2). - y _ center y - (f lineSpacing // 2). - aCanvas - drawString: l - at: x@y - font: f - color: colorForLabel - embossed: true ]! - -PluggableButtonMorph removeSelector: #drawRegularLabelOn:! - -!methodRemoval: PluggableButtonMorph #drawRegularLabelOn: stamp: 'Install-4677-buttonDrawingInCanvas-JuanVuletich-2021Jul19-10h09m-jmv.001.cs.st 7/20/2021 16:52:50'! -drawRegularLabelOn: aCanvas - - | w f center x y availableW l labelMargin | - - f _ self fontToUse. - center _ extent // 2. - - label ifNotNil: [ - labelMargin _ 4. - w _ f widthOfString: label. - availableW _ extent x - labelMargin - labelMargin - 1. - availableW >= w - ifTrue: [ - x _ center x - (w // 2). - l _ label ] - ifFalse: [ - x _ labelMargin. - l _ label squeezedTo: (label size * availableW / w) rounded ]. - y _ center y - (f lineSpacing // 2). - self isPressed ifTrue: [ - x _ x + 1. - y _ y + 1 ]. - aCanvas - drawString: l - at: x@y - font: f - color: Theme current buttonLabel ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4677-buttonDrawingInCanvas-JuanVuletich-2021Jul19-10h09m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4677] on 19 July 2021 at 10:48:28 am'! -!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jmv 7/19/2021 10:42:16'! - iconDrawSelector - "Must be understood by drawing canvas." - - ^iconName! ! -!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jmv 7/19/2021 10:41:45'! - iconDrawSelector: aSymbol - "aSymbol must be understood by drawing canvas." - - iconName _ aSymbol! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 10:34:59'! - drawCloseIcon - | icon | - icon _ self class windowButtonIcon: #closeIcon size: currentMorph morphWidth. - self pvtDrawButtonIcon: icon.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 10:35:03'! - drawCollapseIcon - | icon | - icon _ self class windowButtonIcon: #collapseIcon size: currentMorph morphWidth. - self pvtDrawButtonIcon: icon.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 10:35:07'! - drawDownIcon - | icon | - icon _ BitBltCanvas arrowOfDirection: #down size: ScrollBar scrollbarThickness. - self pvtDrawButtonIcon: icon.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 10:35:11'! - drawExpandIcon - | icon | - icon _ self class windowButtonIcon: #expandIcon size: currentMorph morphWidth. - self pvtDrawButtonIcon: icon.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 10:35:14'! - drawLeftIcon - | icon | - icon _ BitBltCanvas arrowOfDirection: #left size: ScrollBar scrollbarThickness. - self pvtDrawButtonIcon: icon.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 10:35:18'! - drawMenuIcon - | icon | - icon _ self class windowButtonIcon: #windowMenuIcon size: currentMorph morphWidth. - self pvtDrawButtonIcon: icon.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 10:35:22'! - drawPushPinIcon - | icon | - icon _ self class windowButtonIcon: #pushPinIcon size: currentMorph morphWidth. - self pvtDrawButtonIcon: icon.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 10:35:25'! - drawRightIcon - | icon | - icon _ BitBltCanvas arrowOfDirection: #right size: ScrollBar scrollbarThickness. - self pvtDrawButtonIcon: icon.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 10:35:29'! - drawUpIcon - | icon | - icon _ BitBltCanvas arrowOfDirection: #up size: ScrollBar scrollbarThickness. - self pvtDrawButtonIcon: icon.! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 7/19/2021 10:34:41'! - pvtDrawButtonIcon: icon - "We assume that we are drawing a PluggableButtonMorph, - or some morph that conforms the required protocol. - Answer true if we were able to draw it." - - | iconColor | - iconColor _ currentMorph isPressed - ifTrue: [ `Color gray: 0.75` ] - ifFalse: [ - currentMorph mouseIsOver - ifTrue: [ `Color gray: 0.75` ] - ifFalse: [ `Color white` ]]. - self - image: icon - multipliedBy: iconColor - at: (currentMorph morphExtent - icon extent //2).! ! -!BitBltCanvas class methodsFor: 'cached button forms' stamp: 'jmv 7/18/2021 19:57:10'! - windowButtonIcon: aSymbol size: finalSizeInteger - ^self cachedForms - at: { aSymbol . finalSizeInteger } - ifAbsentPut: [ - | icon w h factor magnifiedExtent magnifiedIcon | - icon _ Theme current perform: aSymbol. - magnifiedIcon _ icon. - w _ icon width. - h _ icon height. - w*h = 0 ifFalse: [ - factor _ 1.0 * finalSizeInteger / w min: 1.0 * finalSizeInteger / h. - factor = 1.0 ifFalse: [ - magnifiedExtent _ (icon extent * factor) rounded. - magnifiedIcon _ icon magnifyTo: magnifiedExtent ]]. - magnifiedIcon ]! ! -!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jmv 7/18/2021 20:25:15' prior: 16888050! - icon: aForm -"estos 2 lo quiero eliminar. Es todo mambo del canvas, no del boton." - icon _ aForm. - magnifiedIcon _ nil! ! -!PluggableButtonMorph methodsFor: 'private' stamp: 'jmv 7/18/2021 20:27:22' prior: 50471915! - magnifiedIcon -"que quede solo en MenuItemMorph, de donde debe volar tambien eventualmente." - | factor magnifiedExtent w h | - - icon ifNil: [ ^nil ]. - magnifiedIcon ifNil: [ - magnifiedIcon _ icon. - w _ icon width. - h _ icon height. - w*h = 0 ifFalse: [ - factor _ 1.0 * extent x / w min: 1.0 * extent y / h. - factor = 1.0 ifFalse: [ - magnifiedExtent _ (icon extent * factor) rounded. - magnifiedIcon _ icon magnifyTo: magnifiedExtent ]]]. - ^magnifiedIcon! ! -!PluggableButtonMorph methodsFor: 'geometry' stamp: 'jmv 7/18/2021 20:27:02' prior: 50556469 overrides: 50556435! - extentChanged: oldExtent - "Our extent changed. Must layout submorphs again." -"este vuela, claro." - super extentChanged: oldExtent. - magnifiedIcon _ nil! ! -!PluggableButtonMorph methodsFor: 'geometry testing' stamp: 'jmv 7/18/2021 20:26:09' prior: 50503392 overrides: 50546031! - morphContainsPoint: aLocalPoint - - | iconOrigin | - (self morphLocalBounds containsPoint: aLocalPoint) ifFalse: [ ^false ]. -"mhhhhhhh" - ^ self isOrthoRectangularMorph or: [ - magnifiedIcon isNil or: [ - iconOrigin _ extent - magnifiedIcon extent // 2. - (magnifiedIcon isTransparentAt: (aLocalPoint - iconOrigin) rounded) not ]]! ! -!ScrollBar methodsFor: 'initialization' stamp: 'jmv 7/19/2021 10:44:22' prior: 50565457! - updateDownButton: aPluggableButtonMorph - "Update the argument as a downButton." - - aPluggableButtonMorph - iconDrawSelector: #drawDownIcon; - action: #scrollDown; - roundButtonStyle: false; - redrawNeeded! ! -!ScrollBar methodsFor: 'initialization' stamp: 'jmv 7/19/2021 10:44:13' prior: 50565469! - updateLeftButton: aPluggableButtonMorph - "Update the argument as a leftButton." - - aPluggableButtonMorph - iconDrawSelector: #drawLeftIcon; - action: #scrollUp; - roundButtonStyle: false; - redrawNeeded! ! -!ScrollBar methodsFor: 'initialization' stamp: 'jmv 7/19/2021 10:44:04' prior: 50565481! - updateRightButton: aPluggableButtonMorph - "Update the argument as a rightButton." - - aPluggableButtonMorph - iconDrawSelector: #drawRightIcon; - action: #scrollDown; - roundButtonStyle: false; - redrawNeeded! ! -!ScrollBar methodsFor: 'initialization' stamp: 'jmv 7/19/2021 10:43:51' prior: 50565493! - updateUpButton: aPluggableButtonMorph - "Update the argument as an upButton." - - aPluggableButtonMorph - iconDrawSelector: #drawUpIcon; - action: #scrollUp; - roundButtonStyle: false; - redrawNeeded! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 7/19/2021 10:42:53' prior: 50471863! - createCloseButton - ^ (PluggableButtonMorph model: self action: #closeBoxHit) - iconDrawSelector: #drawCloseIcon; - setBalloonText: 'close this window'; - morphExtent: self titleBarButtonsExtent! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 7/19/2021 10:42:58' prior: 50471873! - createCollapseButton - ^(PluggableButtonMorph model: self action: #collapse) - iconDrawSelector: #drawCollapseIcon; - setBalloonText: 'collapse this window'; - morphExtent: self titleBarButtonsExtent! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 7/19/2021 10:43:02' prior: 50471883! - createExpandButton - ^ (PluggableButtonMorph model: self action: #expandBoxHit) - iconDrawSelector: #drawExpandIcon; - setBalloonText: 'expand to full screen'; - morphExtent: self titleBarButtonsExtent! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 7/19/2021 10:43:06' prior: 50471893! - createMenuButton - ^ (PluggableButtonMorph model: self action: #offerWindowMenu) - iconDrawSelector: #drawMenuIcon; - setBalloonText: 'window menu'; - morphExtent: self titleBarButtonsExtent! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 7/19/2021 10:42:49' prior: 50547911! - addStayUpIcons - | closeButton pinButton w buttonHW | - Preferences optionalButtons ifFalse: [ ^self ]. - (self valueOfProperty: #hasStayUpIcons ifAbsent: [ false ]) - ifTrue: [ - self removeProperty: #needsStayUpIcons. - ^self ]. - titleMorph ifNil: [ - "Title not yet there. Flag ourself, so this method is called again when adding title." - self setProperty: #needsStayUpIcons toValue: true. - ^ self]. - buttonHW _ Preferences windowTitleFont pointSize. - closeButton _ PluggableButtonMorph model: self action: #delete. - closeButton iconDrawSelector: #drawCloseIcon; color: `Color transparent`. - pinButton _ PluggableButtonMorph model: self action: #stayUp. - pinButton iconDrawSelector: #drawPushPinIcon; color: `Color transparent`. - w _ (titleMorph hasSubmorphs ifTrue: [ titleMorph firstSubmorph morphWidth ] ifFalse: [ 0 ]) + 60. - self addMorphFront: - (LayoutMorph newRow - "Make room for buttons" - morphExtent: w @ (titleMorph morphHeight max: buttonHW); - color: `Color transparent`; - addMorph: closeButton fixedWidth: buttonHW; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedWidth: buttonHW//3; - addMorph: titleMorph proportionalWidth: 1; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedWidth: buttonHW//3; - addMorph: pinButton fixedWidth: buttonHW). - - self setProperty: #hasStayUpIcons toValue: true. - self removeProperty: #needsStayUpIcons! ! -!BitBltCanvas methodsFor: 'drawing-widgets' stamp: 'jmv 7/19/2021 10:42:23' prior: 50577558 overrides: 50577474! - drawButtonIcon: aPluggableButtonMorph - "We assume that we are drawing a PluggableButtonMorph, - or some morph that conforms the required protocol. - Answer true if we were able to draw it." - - aPluggableButtonMorph iconDrawSelector ifNotNil: [ :selector | -(#(drawLeftIcon drawRightIcon drawUpIcon drawDownIcon drawCloseIcon drawCollapseIcon drawExpandIcon drawMenuIcon drawPushPinIcon) includes: selector) -ifTrue: [ - self perform: selector. - ^true ]. -]. - - aPluggableButtonMorph magnifiedIcon ifNotNil: [ :theIcon | | iconColor | - iconColor _ aPluggableButtonMorph isPressed - ifTrue: [ `Color gray: 0.75` ] - ifFalse: [ - aPluggableButtonMorph mouseIsOver - ifTrue: [ `Color gray: 0.75` ] - ifFalse: [ `Color white` ]]. - self - image: theIcon - multipliedBy: iconColor - at: (aPluggableButtonMorph morphExtent - theIcon extent //2). - ^true ]. - ^false! ! - -BitBltCanvas removeSelector: #drawIcon:for:! - -PluggableButtonMorph removeSelector: #iconName:! - -!methodRemoval: PluggableButtonMorph #iconName: stamp: 'Install-4678-buttonIconDrawingInCanvas-JuanVuletich-2021Jul19-10h14m-jmv.001.cs.st 7/20/2021 16:52:50'! -iconName: aSymbol - iconName _ aSymbol! - -PluggableButtonMorph removeSelector: #iconName! - -!methodRemoval: PluggableButtonMorph #iconName stamp: 'Install-4678-buttonIconDrawingInCanvas-JuanVuletich-2021Jul19-10h14m-jmv.001.cs.st 7/20/2021 16:52:50'! -iconName - ^iconName! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4678-buttonIconDrawingInCanvas-JuanVuletich-2021Jul19-10h14m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4675] on 18 July 2021 at 8:45:13 pm'! -!Theme methodsFor: 'icons' stamp: 'jmv 7/18/2021 20:39:39'! - fontIcon - ^(Theme content from: 'Theme' get: {'16x16'. 'mimetypes'}) at: 'font-x-generic.png'! ! -!Theme methodsFor: 'icons' stamp: 'jmv 7/18/2021 20:40:31'! - imageIcon - ^((Theme content from: 'Theme' get: {'16x16'. 'mimetypes'}) at: 'image-x-generic.png')! ! -!SimpleServiceEntry methodsFor: 'accessing' stamp: 'jmv 7/18/2021 20:42:47' prior: 50426960! - icon: iconSymbol - - icon := iconSymbol ! ! -!SimpleServiceEntry class methodsFor: 'instance creation' stamp: 'jmv 7/18/2021 20:41:32' prior: 50426964! - provider: anObject label: aString selector: aSymbol description: anotherString buttonLabel: aLabel icon: iconSymbol - - ^ (self provider: anObject label: aString selector: aSymbol description: anotherString buttonLabel: aLabel) - icon: iconSymbol; - yourself! ! -!SimpleServiceEntry class methodsFor: 'instance creation' stamp: 'jmv 7/18/2021 20:42:36' prior: 50426975! - provider: anObject label: aString selector: aSymbol description: anotherString icon: iconSymbol - - ^(self provider: anObject label: aString selector: aSymbol description: anotherString) - icon: iconSymbol; - yourself! ! -!ImageReadWriter class methodsFor: 'instance creation' stamp: 'jmv 7/18/2021 20:40:40' prior: 50507857! - serviceReadImage - "Answer the service of importing an image" - - ^ (SimpleServiceEntry - provider: self - label: 'import as ImageMorph' - selector: #imageMorphFromFileEntry: - description: 'import image as ImageMorph' - buttonLabel: 'import image' - icon: #imageIcon - ) argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4679-Cleanup-JuanVuletich-2021Jul18-20h33m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4675] on 18 July 2021 at 7:05:16 pm'! -!Morph methodsFor: 'drawing' stamp: 'jmv 7/18/2021 19:05:09' prior: 50577269! - imageForm: extentOrNil depth: depth - - | extent answer auxCanvas | - extent _ self morphExtent. - extentOrNil ifNotNil: [ extent _ extent min: extentOrNil * 4 ]. - auxCanvas _ MorphicCanvas depth: depth over: (self morphPosition floor extent: extent ceiling). - auxCanvas fullDraw: self. - answer _ auxCanvas form divideByAlpha. - extentOrNil ifNotNil: [ answer _ answer magnifyTo: extentOrNil ]. - ^answer.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4680-imageForm-again-JuanVuletich-2021Jul18-19h00m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4680] on 19 July 2021 at 5:08:58 pm'! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 7/19/2021 11:33:16'! - pvtDrawButtonFaceForm: aForm - "We assume that we are drawing a PluggableButtonMorph, - or some morph that conforms the required protocol. - Answer true if we were able to draw it." - - | color | - color _ currentMorph isPressed - ifTrue: [ `Color gray: 0.75` ] - ifFalse: [ - currentMorph mouseIsOver - ifTrue: [ `Color gray: 0.75` ] - ifFalse: [ `Color white` ]]. - self - image: aForm - multipliedBy: color - at: (currentMorph morphExtent - aForm extent //2).! ! -!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jmv 7/19/2021 17:06:53' prior: 50577874! - icon: aForm - icon _ aForm. - magnifiedIcon _ nil! ! -!PluggableButtonMorph methodsFor: 'private' stamp: 'jmv 7/19/2021 17:06:35' prior: 50577881! - magnifiedIcon - | factor magnifiedExtent w h | - - icon ifNil: [ ^nil ]. - magnifiedIcon ifNil: [ - magnifiedIcon _ icon. - w _ icon width. - h _ icon height. - w*h = 0 ifFalse: [ - factor _ 1.0 * extent x / w min: 1.0 * extent y / h. - factor = 1.0 ifFalse: [ - magnifiedExtent _ (icon extent * factor) rounded. - magnifiedIcon _ icon magnifyTo: magnifiedExtent ]]]. - ^magnifiedIcon! ! -!PluggableButtonMorph methodsFor: 'geometry' stamp: 'jmv 11/15/2020 11:34:23' prior: 50577900 overrides: 50556435! - extentChanged: oldExtent - "Our extent changed. Must layout submorphs again." - - super extentChanged: oldExtent. - magnifiedIcon _ nil! ! -!MorphicCanvas methodsFor: 'drawing-widgets' stamp: 'jmv 7/19/2021 17:07:46' prior: 50577474! - drawButtonIcon: aPluggableButtonMorph - "We assume that we are drawing a PluggableButtonMorph, - or some morph that conforms the required protocol. - Answer true if we were able to draw it." - - aPluggableButtonMorph iconDrawSelector ifNotNil: [ :selector | - self perform: selector. - ^true ]. - - aPluggableButtonMorph magnifiedIcon ifNotNil: [ :theIcon | - self pvtDrawButtonFaceForm: theIcon. - ^true ]. - - ^false! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 11:33:25' prior: 50577773! - drawCloseIcon - | icon | - icon _ self class windowButtonIcon: #closeIcon size: currentMorph morphWidth. - self pvtDrawButtonFaceForm: icon.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 11:33:29' prior: 50577780! - drawCollapseIcon - | icon | - icon _ self class windowButtonIcon: #collapseIcon size: currentMorph morphWidth. - self pvtDrawButtonFaceForm: icon.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 11:33:32' prior: 50577787! - drawDownIcon - | icon | - icon _ BitBltCanvas arrowOfDirection: #down size: ScrollBar scrollbarThickness. - self pvtDrawButtonFaceForm: icon.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 11:33:36' prior: 50577794! - drawExpandIcon - | icon | - icon _ self class windowButtonIcon: #expandIcon size: currentMorph morphWidth. - self pvtDrawButtonFaceForm: icon.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 11:33:40' prior: 50577801! - drawLeftIcon - | icon | - icon _ BitBltCanvas arrowOfDirection: #left size: ScrollBar scrollbarThickness. - self pvtDrawButtonFaceForm: icon.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 11:33:43' prior: 50577808! - drawMenuIcon - | icon | - icon _ self class windowButtonIcon: #windowMenuIcon size: currentMorph morphWidth. - self pvtDrawButtonFaceForm: icon.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 11:33:47' prior: 50577815! - drawPushPinIcon - | icon | - icon _ self class windowButtonIcon: #pushPinIcon size: currentMorph morphWidth. - self pvtDrawButtonFaceForm: icon.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 11:33:50' prior: 50577822! - drawRightIcon - | icon | - icon _ BitBltCanvas arrowOfDirection: #right size: ScrollBar scrollbarThickness. - self pvtDrawButtonFaceForm: icon.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/19/2021 11:33:53' prior: 50577829! - drawUpIcon - | icon | - icon _ BitBltCanvas arrowOfDirection: #up size: ScrollBar scrollbarThickness. - self pvtDrawButtonFaceForm: icon.! ! - -BitBltCanvas removeSelector: #drawButtonIcon:! - -!methodRemoval: BitBltCanvas #drawButtonIcon: stamp: 'Install-4681-PluggableButtonMorph-tweaks-JuanVuletich-2021Jul19-16h59m-jmv.001.cs.st 7/20/2021 16:52:50'! -drawButtonIcon: aPluggableButtonMorph - "We assume that we are drawing a PluggableButtonMorph, - or some morph that conforms the required protocol. - Answer true if we were able to draw it." - - aPluggableButtonMorph iconDrawSelector ifNotNil: [ :selector | -(#(drawLeftIcon drawRightIcon drawUpIcon drawDownIcon drawCloseIcon drawCollapseIcon drawExpandIcon drawMenuIcon drawPushPinIcon) includes: selector) -ifTrue: [ - self perform: selector. - ^true ]. -]. - - aPluggableButtonMorph magnifiedIcon ifNotNil: [ :theIcon | | iconColor | - iconColor _ aPluggableButtonMorph isPressed - ifTrue: [ `Color gray: 0.75` ] - ifFalse: [ - aPluggableButtonMorph mouseIsOver - ifTrue: [ `Color gray: 0.75` ] - ifFalse: [ `Color white` ]]. - self - image: theIcon - multipliedBy: iconColor - at: (aPluggableButtonMorph morphExtent - theIcon extent //2). - ^true ]. - ^false! - -BitBltCanvas removeSelector: #drawButtonForm:! - -BitBltCanvas removeSelector: #pvtDrawButtonIcon:! - -!methodRemoval: BitBltCanvas #pvtDrawButtonIcon: stamp: 'Install-4681-PluggableButtonMorph-tweaks-JuanVuletich-2021Jul19-16h59m-jmv.001.cs.st 7/20/2021 16:52:50'! -pvtDrawButtonIcon: icon - "We assume that we are drawing a PluggableButtonMorph, - or some morph that conforms the required protocol. - Answer true if we were able to draw it." - - | iconColor | - iconColor _ currentMorph isPressed - ifTrue: [ `Color gray: 0.75` ] - ifFalse: [ - currentMorph mouseIsOver - ifTrue: [ `Color gray: 0.75` ] - ifFalse: [ `Color white` ]]. - self - image: icon - multipliedBy: iconColor - at: (currentMorph morphExtent - icon extent //2).! - -MorphicCanvas removeSelector: #drawButtonForm:! - -PluggableButtonMorph removeSelector: #morphContainsPoint:! - -!methodRemoval: PluggableButtonMorph #morphContainsPoint: stamp: 'Install-4681-PluggableButtonMorph-tweaks-JuanVuletich-2021Jul19-16h59m-jmv.001.cs.st 7/20/2021 16:52:50'! -morphContainsPoint: aLocalPoint - - | iconOrigin | - (self morphLocalBounds containsPoint: aLocalPoint) ifFalse: [ ^false ]. -"mhhhhhhh" - ^ self isOrthoRectangularMorph or: [ - magnifiedIcon isNil or: [ - iconOrigin _ extent - magnifiedIcon extent // 2. - (magnifiedIcon isTransparentAt: (aLocalPoint - iconOrigin) rounded) not ]]! - -PluggableButtonMorph removeSelector: #scaledForm! - -PluggableButtonMorph removeSelector: #form:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4681-PluggableButtonMorph-tweaks-JuanVuletich-2021Jul19-16h59m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4681] on 19 July 2021 at 5:31:24 pm'! -!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jmv 7/19/2021 17:30:51'! - iconName - self valueOfProperty: #iconName! ! -!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jmv 7/19/2021 17:30:25'! - iconName: name - self setProperty: #iconName toValue: name! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4682-PluggableButtonMorph-iconName-JuanVuletich-2021Jul19-17h30m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4681] on 19 July 2021 at 5:44:30 pm'! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 7/19/2021 16:09:05' prior: 50461040! - focusIndicatorBottom - ^ self hIsScrollbarShowing - ifTrue: [ extent y - borderWidth - ScrollBar scrollbarThickness ] - ifFalse: [ extent y - borderWidth ]! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 7/19/2021 16:09:11' prior: 50461052! - focusIndicatorRight - ^ self vIsScrollbarShowing - ifTrue: [ extent x - borderWidth - ScrollBar scrollbarThickness ] - ifFalse: [ extent x - borderWidth ]! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 7/19/2021 16:09:41' prior: 50499545 overrides: 50499537! - minimumExtent - | minW minH | - "Figure out the minimum extent for this pane so that either content, or at least required scrollbars, will fit" - minW _ self xtraBorder * 2 + scroller morphWidth min: ScrollBar scrollbarThickness * 2. - self vIsScrollbarShowing - ifTrue: [ - minW _ minW + ScrollBar scrollbarThickness]. - minH _ self xtraBorder * 2 + scroller morphHeight. - self hIsScrollbarShowing - ifTrue: [ - minH _ minH + ScrollBar scrollbarThickness]. - minH _ minH min: ScrollBar scrollbarThickness * 2. - ^ (minW + (borderWidth * 2)) @ (minH + (borderWidth * 2))! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 7/19/2021 16:09:54' prior: 50562076! - updateScrollBarsBounds - - | t | - hideScrollBars = #hide ifTrue: [^self]. - t _ ScrollBar scrollbarThickness. - (hideScrollBars = #hideVertical) - ifFalse: [ - scrollBar - morphPosition: extent x - t - borderWidth @ borderWidth - extent: t @ self vScrollBarHeight. - ]. - hScrollBar - morphPosition: borderWidth @ (extent y - t - borderWidth) - extent: self hScrollBarWidth@t! ! -!PluggableScrollPane methodsFor: 'initialization' stamp: 'jmv 7/19/2021 16:09:22' prior: 50556315 overrides: 50384371! - initialize - - "initialize the state of the receiver" - super initialize. - hideScrollBars _ #showIfNeeded. - - "initialize the receiver's scrollBars" - scrollBar _ ScrollBar new model: self setValueSelector: #vScrollBarValue:. - hScrollBar _ ScrollBar new model: self setValueSelector: #hScrollBarValue:. - drawKeyboardFocusIndicator _ true. - - scroller _ self innerMorphClass new. - self addMorph: scroller. - self scrollerOffset: `0@ 0`. - self addMorph: scrollBar. - self addMorph: hScrollBar! ! -!ScrollBar methodsFor: 'initialization' stamp: 'jmv 7/19/2021 16:06:58' prior: 50568244! -initializeDownButton - "initialize the receiver's downButton" - - | e | - e _ self buttonExtent. - downButton _ PluggableButtonMorph new. - downButton model: self. - downButton morphExtent: e@e. - Theme current scrollbarShowButtons ifFalse: [^ self]. - self addMorph: downButton position: extent - borderWidth - e. - downButton - actWhen: #buttonStillDown. "to enable multiple action if held down". - self isHorizontal - ifTrue: [ self updateRightButton: downButton ] - ifFalse: [ self updateDownButton: downButton ]! ! -!ScrollBar methodsFor: 'initialization' stamp: 'jmv 7/19/2021 16:08:11' prior: 50547877! - initializeSlider - "initialize the receiver's slider" - - sliderShadow _ WidgetMorph new noBorder. - self addMorph: sliderShadow. - sliderShadow hide. - - slider _ DraggeableButtonMorph new. - slider model: self. - slider grabSelector: #sliderGrabbedAt:. - slider dragSelector: #scrollTo:. - slider action: #sliderReleased. - self addMorph: slider. - - self computeSlider! ! -!ScrollBar methodsFor: 'initialization' stamp: 'jmv 7/19/2021 16:07:05' prior: 50568334! - initializeUpButton - "initialize the receiver's upButton" - - | e | - e _ self buttonExtent. - upButton _ PluggableButtonMorph new. - upButton model: self. - upButton morphExtent: e@e. - Theme current scrollbarShowButtons ifFalse: [^ self]. - self addMorph: upButton position: borderWidth@borderWidth. - upButton - actWhen: #buttonStillDown. "to enable multiple action if held down" - self isHorizontal - ifTrue: [ self updateLeftButton: upButton ] - ifFalse: [ self updateUpButton: upButton ]. -! ! - -ScrollBar removeSelector: #sliderClass! - -!methodRemoval: ScrollBar #sliderClass stamp: 'Install-4683-ScrollbarCleanup-JuanVuletich-2021Jul19-17h40m-jmv.001.cs.st 7/20/2021 16:52:50'! -sliderClass - ^DraggeableButtonMorph! - -ScrollBar removeSelector: #buttonClass! - -!methodRemoval: ScrollBar #buttonClass stamp: 'Install-4683-ScrollbarCleanup-JuanVuletich-2021Jul19-17h40m-jmv.001.cs.st 7/20/2021 16:52:50'! -buttonClass - ^PluggableButtonMorph! - -PluggableScrollPane removeSelector: #scrollBarClass! - -!methodRemoval: PluggableScrollPane #scrollBarClass stamp: 'Install-4683-ScrollbarCleanup-JuanVuletich-2021Jul19-17h40m-jmv.001.cs.st 7/20/2021 16:52:51'! -scrollBarClass - ^ScrollBar! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4683-ScrollbarCleanup-JuanVuletich-2021Jul19-17h40m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4683] on 20 July 2021 at 12:50:59 pm'! -!SystemWindow methodsFor: 'panes' stamp: 'jmv 7/20/2021 11:17:26'! - windowFrameColor - - | windowFrameColor | - windowFrameColor _ self borderColor. - self isTopWindow - ifTrue: [ windowFrameColor _ windowFrameColor lighter ]. - ^windowFrameColor! ! -!MorphicCanvas methodsFor: 'drawing-widgets' stamp: 'jmv 7/20/2021 10:24:23'! - drawButtonRound: aPluggableButtonMorph - | r colorForButton rect color | - color _ aPluggableButtonMorph color. - colorForButton _ aPluggableButtonMorph isPressed - ifFalse: [ - aPluggableButtonMorph mouseIsOver - ifTrue: [ Color h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ color ]] - ifTrue: [ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - rect _ aPluggableButtonMorph morphLocalBounds insetBy: `1@3`. - self roundRect: rect color: colorForButton radius: r ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawButtonEmbossedLabel: aPluggableButtonMorph ] - ifFalse: [ self drawButtonRegularLabel: aPluggableButtonMorph ].! ! -!MorphicCanvas methodsFor: 'drawing-windows' stamp: 'jmv 7/20/2021 09:40:57'! - drawRoundedFrame: aRectangle border: borderWidth color: borderColor insideColor: insideColor labelHeight: labelHeight - - self subclassResponsibility.! ! -!BitBltCanvas methodsFor: 'drawing-windows' stamp: 'jmv 7/20/2021 09:40:38' overrides: 50578608! - drawRoundedFrame: aRectangle border: borderWidth color: borderColor insideColor: insideColor labelHeight: labelHeight - "Title area is not inside window borders" - | bottomFactor topFactor | - Theme current useWindowTitleGradient - ifTrue: [ - topFactor _ Theme current titleGradientTopFactor. - bottomFactor _ Theme current titleGradientBottomFactor ] - ifFalse: [ - topFactor _ 1. - bottomFactor _ 1 ]. - self - windowFrame: aRectangle - color: borderColor * Theme current titleGradientExtraLightness - radius: Theme current roundedWindowRadius - border: borderWidth - labelHeight: labelHeight + borderWidth - gradientTop: topFactor - gradientBottom: bottomFactor - insideColor: insideColor! ! -!BitBltCanvas methodsFor: 'drawing-windows' stamp: 'jmv 7/20/2021 10:57:33'! - roundBottomLeftCornerX: cornerX y: cornerY length: l border: borderWidth color: borderColor - "NOP here"! ! -!BitBltCanvas methodsFor: 'drawing-windows' stamp: 'jmv 7/20/2021 10:57:40'! - roundBottomRightCornerX: cornerX y: cornerY length: l border: borderWidth color: borderColor - "NOP here"! ! -!BitBltCanvas methodsFor: 'drawing-windows' stamp: 'jmv 7/20/2021 11:22:31'! - roundEdge: aRectangle color: aColor - "NOP here"! ! -!BitBltCanvas methodsFor: 'drawing-windows' stamp: 'jmv 7/20/2021 10:45:30'! -roundTopLeftCornerX: cornerX y: cornerY length: l border: borderWidth color: borderColor - "NOP here"! ! -!BitBltCanvas methodsFor: 'drawing-windows' stamp: 'jmv 7/20/2021 10:51:07'! - roundTopRightCornerX: cornerX y: cornerY length: l border: borderWidth color: borderColor - "NOP here"! ! -!WindowEdgeAdjustingMorph methodsFor: 'drawing' stamp: 'jmv 7/20/2021 11:23:14' prior: 16945110 overrides: 50503570! - drawOn: aCanvas - - | c | - c _ owner windowFrameColor. - selector caseOf: { - [ #windowTopLeft: ] -> [ - aCanvas roundTopLeftCornerX: 0 y: 0 length: extent x border: owner borderWidth color: c. - ]. - [ #windowTopRight: ] -> [ - aCanvas roundTopRightCornerX: 0 y: 0 length: extent x border: owner borderWidth color: c. - ]. - [ #windowBottomLeft: ] -> [ - aCanvas roundBottomLeftCornerX: 0 y: 0 length: extent x border: owner borderWidth color: c. - ]. - [ #windowBottomRight: ] -> [ - aCanvas roundBottomRightCornerX: 0 y: 0 length: extent x border: owner borderWidth color: c. - ]. - } - otherwise: [ - "all the morph is sensitive for horizontal and vertical (i.e. non corner) instances." - aCanvas roundEdge: self morphLocalBounds color: c ].! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 7/20/2021 11:18:36' prior: 50503417! - drawClassicFrameOn: aCanvas color: windowFrameColor - "Window border encompasses title area. No round corners. No title gradient." - - aCanvas fillRectangle: self morphLocalBounds color: color borderWidth: borderWidth borderStyleSymbol: #simple baseColorForBorder: self widgetsColor. - - "A border was drawn at the left, top and right of the title area. - The look is that the title area is inside the window" - aCanvas fillRectangle: (borderWidth@borderWidth extent: extent x - (2*borderWidth)@ self labelHeight) color: windowFrameColor! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 7/20/2021 11:24:42' prior: 50568158 overrides: 50545913! - drawOn: aCanvas - | windowFrameColor roundCorners | - windowFrameColor _ self windowFrameColor. - roundCorners _ Theme current roundWindowCorners. - roundCorners - ifTrue: [ - "Round corners. Optional title gradient." - self drawRoundedFrameOn: aCanvas color: windowFrameColor ] - ifFalse: [ - "No round corners. No title gradient." - self drawClassicFrameOn: aCanvas color: windowFrameColor ]. - labelString ifNotNil: [ self drawLabelOn: aCanvas ]! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 7/20/2021 09:50:55' prior: 50503436! - drawRoundedFrameOn: aCanvas color: widgetsColor - - aCanvas - drawRoundedFrame: self morphLocalBounds - border: borderWidth - color: widgetsColor - insideColor: color - labelHeight: self labelHeight.! ! -!MorphicCanvas methodsFor: 'drawing-widgets' stamp: 'jmv 7/20/2021 10:24:29' prior: 50577421! - drawButton: aPluggableButtonMorph - aPluggableButtonMorph isRoundButton - ifTrue: [ - (self drawButtonIcon: aPluggableButtonMorph) ifFalse: [ - self drawButtonRound: aPluggableButtonMorph ]] - ifFalse: [ - self drawButton3D: aPluggableButtonMorph. - self drawButtonIcon: aPluggableButtonMorph ]! ! -!BitBltCanvas methodsFor: 'drawing-windows' stamp: 'jmv 7/20/2021 12:49:42' prior: 50533116 overrides: 50463515! - windowFrame: aRectangle color: aColor radius: r border: bw labelHeight: lh gradientTop: topFactor gradientBottom: bottomFactor insideColor: insideColor - " - BitBltCanvas releaseClassCachedState. - Display getCanvas windowFrame: (10@10 extent: 200@100) color: Color red radius: 10 border: 5 labelHeight: 25 gradientTop: 1.0 gradientBottom: 0.5 insideColor: Color green. - Display forceToScreen - " - "top stripe" - | bottomColor he tl tr | - - engine ifNil: [ ^nil ]. - - self - image: (self class topLeftCorner: r height: lh gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: aRectangle topLeft. - self - image: (self class topRightCorner: r height: lh gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: aRectangle topRight - (r@0). - self - fillRectangle: ((aRectangle withHeight: lh) insetBy: r@0) - tilingWith: (self class verticalGrayGradient: lh gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor. - - bottomColor _ aColor * bottomFactor. - - "left and right borders" - tl _ aRectangle topLeft + (0@lh). - tr _ aRectangle topRight + (bw negated@lh). - he _ bw@(aRectangle height - lh - r). - self fillRectangle: (tl extent: he) color: bottomColor. - self fillRectangle: (tr extent: he) color: bottomColor. - - "bottom stripe" - self - image: (self class bottomLeftCorner: r height: r gradientTop: 1 gradientBottom: 1 borderWidth: bw) - multipliedBy: bottomColor - at: aRectangle bottomLeft - (0@r). - self - image: (self class bottomRightCorner: r height: r gradientTop: 1 gradientBottom: 1 borderWidth: bw) - multipliedBy: bottomColor - at: aRectangle bottomRight - (r@r) . - self fillRectangle: ((aRectangle bottomLeft + (r@bw negated)) extent: (aRectangle width - r - r@bw)) color: bottomColor. - - "inside" - self fillRectangle: (aRectangle insetBy: (bw@lh corner: bw@bw)) color: insideColor! ! -!Theme methodsFor: 'other options' stamp: 'jmv 7/20/2021 11:12:18' prior: 16935707! - roundedWindowRadius - "Only effective if #roundWindowCorners answers true. - Provide a reasonable default for subclasses." - ^14! ! - -Theme removeSelector: #buttonGradientHeight! - -!methodRemoval: Theme #buttonGradientHeight stamp: 'Install-4684-WindowBitBltStuffToBitBltCanvas-JuanVuletich-2021Jul20-12h41m-jmv.001.cs.st 7/20/2021 16:52:51'! -buttonGradientHeight - "Only effective if #roundButtons answers true. - Provide a reasonable default for subclasses." - ^14! - -Theme removeSelector: #buttonGradientBottomFactor! - -!methodRemoval: Theme #buttonGradientBottomFactor stamp: 'Install-4684-WindowBitBltStuffToBitBltCanvas-JuanVuletich-2021Jul20-12h41m-jmv.001.cs.st 7/20/2021 16:52:51'! -buttonGradientBottomFactor - "Will only be used for color themes that answer true to #roundButtons" - ^0.92! - -Theme removeSelector: #buttonGradientTopFactor! - -!methodRemoval: Theme #buttonGradientTopFactor stamp: 'Install-4684-WindowBitBltStuffToBitBltCanvas-JuanVuletich-2021Jul20-12h41m-jmv.001.cs.st 7/20/2021 16:52:51'! -buttonGradientTopFactor - "Will only be used for color themes that answer true to #roundButtons" - ^1.0! - -Theme removeSelector: #useButtonGradient! - -!methodRemoval: Theme #useButtonGradient stamp: 'Install-4684-WindowBitBltStuffToBitBltCanvas-JuanVuletich-2021Jul20-12h41m-jmv.001.cs.st 7/20/2021 16:52:51'! -useButtonGradient - ^false! - -BitBltCanvas class removeSelector: #steButtonForm:! - -!methodRemoval: BitBltCanvas class #steButtonForm: stamp: 'Install-4684-WindowBitBltStuffToBitBltCanvas-JuanVuletich-2021Jul20-12h41m-jmv.001.cs.st 7/20/2021 16:52:51'! -steButtonForm: extent - ^self cachedForms - at: { #steButton . extent } - ifAbsentPut: [ - | form canvas | - form _ Form extent: extent depth: 32. - canvas _ form getCanvas. - canvas - roundRect: (`0@0` extent: extent) - color: `Color gray: 0.4` - radius: 4. - canvas - roundRect: (`1@1` extent: extent-2) - color: `Color white` - radius: 4 - gradientTop: 1.0 - gradientCenter: 0.73 - gradientBottom: 0.94 - gradient1Height: (extent y-8+1 max: extent y//2). - form]! - -BitBltCanvas removeSelector: #roundRect:color:radius:gradientTop:gradientCenter:gradientBottom:gradient1Height:! - -!methodRemoval: BitBltCanvas #roundRect:color:radius:gradientTop:gradientCenter:gradientBottom:gradient1Height: stamp: 'Install-4684-WindowBitBltStuffToBitBltCanvas-JuanVuletich-2021Jul20-12h41m-jmv.001.cs.st 7/20/2021 16:52:51'! -roundRect: aRectangle color: aColor radius: r gradientTop: topFactor gradientCenter: centerFactor gradientBottom: bottomFactor gradient1Height: h1 - " - Display restore. - BitBltCanvas releaseClassCachedState. - Display getCanvas roundRect: (10@10 extent: 200@100) color: Color red radius: 10 gradientTop: 1.0 gradientCenter: 0.0 gradientBottom: 1.0 gradient1Height: 35 - " - | h2 | - - engine ifNil: [ ^nil ]. - - "top stripe" - self - image: (self class topLeftCorner: r height: h1 gradientTop: topFactor gradientBottom: centerFactor) - multipliedBy: aColor - at: aRectangle topLeft. - self - image: (self class topRightCorner: r height: h1 gradientTop: topFactor gradientBottom: centerFactor) - multipliedBy: aColor - at: aRectangle topRight - (r@0). - self - fillRectangle: ((aRectangle withHeight: h1) insetBy: r@0) - tilingWith: (self class verticalGrayGradient: h1 gradientTop: topFactor gradientBottom: centerFactor) - multipliedBy: aColor. - - "bottom stripe" - h2 _ aRectangle height - h1. - self - image: (self class bottomLeftCorner: r height: h2 gradientTop: centerFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: aRectangle topLeft + (0@h1). - self - image: (self class bottomRightCorner: r height: h2 gradientTop: centerFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: aRectangle topRight + (r negated@h1). - self - fillRectangle: ((aRectangle topLeft + (r@h1)) extent: (aRectangle width-r-r@h2)) - tilingWith: (self class verticalGrayGradient: h2 gradientTop: centerFactor gradientBottom: bottomFactor) - multipliedBy: aColor.! - -BitBltCanvas removeSelector: #roundRect:color:radius:gradientTop:gradientBottom:gradientHeight:! - -!methodRemoval: BitBltCanvas #roundRect:color:radius:gradientTop:gradientBottom:gradientHeight: stamp: 'Install-4684-WindowBitBltStuffToBitBltCanvas-JuanVuletich-2021Jul20-12h41m-jmv.001.cs.st 7/20/2021 16:52:51'! -roundRect: displayRectangle color: aColor radius: r gradientTop: topFactor gradientBottom: bottomFactor gradientHeight: h - " - Display restore. - BitBltCanvas releaseClassCachedState. - Display getCanvas roundRect: (10@10 extent: 200@100) color: Color red radius: 10 gradientTop: 1.0 gradientBottom: 0.5 gradientHeight: 35 - " - | bottomColor | - - engine ifNil: [ ^nil ]. - - "top stripe" - self - image: (self class topLeftCorner: r height: h gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: displayRectangle topLeft. - self - image: (self class topRightCorner: r height: h gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: displayRectangle topRight - (r@0). - self - fillRectangle: ((displayRectangle withHeight: h) insetBy: r@0) - tilingWith: (self class verticalGrayGradient: h gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor. - - bottomColor _ aColor * bottomFactor. - "center stripe" - self fillRectangle: (displayRectangle insetBy: (0 @ h corner: 0 @ r)) color: bottomColor. - - "bottom stripe" - self - image: (self class bottomLeftCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: bottomColor - at: displayRectangle bottomLeft - (0@r). - self - image: (self class bottomRightCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: bottomColor - at: displayRectangle bottomRight - (r@r) . - self fillRectangle: ((displayRectangle bottomLeft + (r@r negated)) extent: (displayRectangle width - r - r@r)) color: bottomColor! - -MorphicCanvas removeSelector: #roundRect:color:radius:gradientTop:gradientCenter:gradientBottom:gradient1Height:! - -!methodRemoval: MorphicCanvas #roundRect:color:radius:gradientTop:gradientCenter:gradientBottom:gradient1Height: stamp: 'Install-4684-WindowBitBltStuffToBitBltCanvas-JuanVuletich-2021Jul20-12h41m-jmv.001.cs.st 7/20/2021 16:52:51'! -roundRect: aRectangle color: aColor radius: r gradientTop: topFactor gradientCenter: centerFactor gradientBottom: bottomFactor gradient1Height: h1 - self subclassResponsibility.! - -MorphicCanvas removeSelector: #roundRect:color:radius:gradientTop:gradientBottom:gradientHeight:! - -!methodRemoval: MorphicCanvas #roundRect:color:radius:gradientTop:gradientBottom:gradientHeight: stamp: 'Install-4684-WindowBitBltStuffToBitBltCanvas-JuanVuletich-2021Jul20-12h41m-jmv.001.cs.st 7/20/2021 16:52:51'! -roundRect: displayRectangle color: aColor radius: r gradientTop: topFactor gradientBottom: bottomFactor gradientHeight: h - self subclassResponsibility.! - -MorphicCanvas removeSelector: #windowFrame:color:radius:border:labelHeight:gradientTop:gradientBottom:insideColor:! - -!methodRemoval: MorphicCanvas #windowFrame:color:radius:border:labelHeight:gradientTop:gradientBottom:insideColor: stamp: 'Install-4684-WindowBitBltStuffToBitBltCanvas-JuanVuletich-2021Jul20-12h41m-jmv.001.cs.st 7/20/2021 16:52:51'! -windowFrame: aRectangle color: aColor radius: r border: bw labelHeight: lh gradientTop: topFactor gradientBottom: bottomFactor insideColor: insideColor - self subclassResponsibility.! - -MorphicCanvas removeSelector: #drawButtonRoundGradient:! - -!methodRemoval: MorphicCanvas #drawButtonRoundGradient: stamp: 'Install-4684-WindowBitBltStuffToBitBltCanvas-JuanVuletich-2021Jul20-12h41m-jmv.001.cs.st 7/20/2021 16:52:51'! -drawButtonRoundGradient: aPluggableButtonMorph - | r colorForButton rect bottomFactor topFactor color | - color _ aPluggableButtonMorph color. - aPluggableButtonMorph isPressed - ifFalse: [ - topFactor _ Theme current buttonGradientTopFactor. - bottomFactor _ Theme current buttonGradientBottomFactor. - aPluggableButtonMorph mouseIsOver - ifTrue: [ - colorForButton _ Color h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ - colorForButton _ color ]] - ifTrue: [ - topFactor _ Theme current buttonGradientBottomFactor. - bottomFactor _ Theme current buttonGradientTopFactor. - colorForButton _ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - Theme current useButtonGradient - ifTrue: [ - rect _ aPluggableButtonMorph morphLocalBounds insetBy: `1@3`. - self - roundRect: rect - color: colorForButton - radius: r - gradientTop: topFactor - gradientBottom: bottomFactor - gradientHeight: Theme current buttonGradientHeight ] - ifFalse: [ - rect _ aPluggableButtonMorph morphLocalBounds insetBy: `1@3`. - self roundRect: rect color: colorForButton radius: r ] - ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawButtonEmbossedLabel: aPluggableButtonMorph ] - ifFalse: [ self drawButtonRegularLabel: aPluggableButtonMorph ].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4684-WindowBitBltStuffToBitBltCanvas-JuanVuletich-2021Jul20-12h41m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4683] on 20 July 2021 at 1:48:24 pm'! - -KernelMorph subclass: #HaloHandleMorph - instanceVariableNames: 'mouseDownSelector mouseUpSelector mouseMoveSelector ' - classVariableNames: 'CircleForm ' - poolDictionaries: '' - category: 'Morphic-Halos'! - -!classDefinition: #HaloHandleMorph category: #'Morphic-Halos' stamp: 'Install-4685-HaloTweaks-JuanVuletich-2021Jul20-12h50m-jmv.001.cs.st 7/20/2021 16:52:51'! -KernelMorph subclass: #HaloHandleMorph - instanceVariableNames: 'mouseDownSelector mouseUpSelector mouseMoveSelector' - classVariableNames: 'CircleForm' - poolDictionaries: '' - category: 'Morphic-Halos'! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 7/20/2021 12:14:54' prior: 50540981! - haloHandleSize - ^ Preferences standardListFont pointSize * 5 // 3 max: 16! ! -!HaloHandleMorph methodsFor: 'drawing' stamp: 'jmv 7/20/2021 12:11:58' prior: 50503583 overrides: 16899205! - drawOn: aCanvas - - aCanvas - ellipseCenter: extent // 2 radius: extent // 2 borderWidth: 0 borderColor: nil fillColor: color! ! -!HaloMorph methodsFor: 'drawing' stamp: 'jmv 7/20/2021 12:30:56' prior: 50570855! - drawCoordinateSystemOn: aCanvas - - | x0 x1 y0 y1 c stepX stepY haloTargetTx prevTx | - haloTargetTx _ MorphicTranslation identity. - target allOwnersReverseDo: [ :o | haloTargetTx _ haloTargetTx composedWith: o location ]. - haloTargetTx _ haloTargetTx composedWith: target location. - - x0 _ x1 _ y0 _ y1 _ 0. - target displayFullBounds corners collect: [ :pt | | p | - p _ haloTargetTx inverseTransform: pt . - x0 _ x0 min: p x. - x1 _ x1 max: p x. - y0 _ y0 min: p y. - y1 _ y1 max: p y.]. - x1-x0 < 1000 ifTrue: [ - stepX _ 50. - stepY _ 20 ] - ifFalse: [ - stepX _ 100. - stepY _ 50 ]. - - prevTx _ aCanvas currentTransformation. - aCanvas geometryTransformation: haloTargetTx. - - c _ `Color black alpha: 0.4`. - aCanvas line: x0@0 to: x1@0 width: 2 color: c. - aCanvas line: 0@y0 to: 0@y1 width: 2 color: c. - - (x0 truncateTo: stepX) to: (x1 - stepX truncateTo: stepX) by: stepX do: [ :x | - aCanvas line: x @ -5 to: x @ 5 width: 2 color: c. - aCanvas drawString: x printString atCenterXBaselineY: x @ -10 font: nil color: c ]. - aCanvas drawString: 'x' atCenterX: x1 - 15 @ 0 font: nil color: c. - - (y0 truncateTo: stepY) to: (y1 - stepY truncateTo: stepY) by: stepY do: [ :y | - aCanvas line: -5 @ y to: 5 @ y width: 2 color: c. - aCanvas drawString: y printString, ' ' atWaistRight: -5 @ y font: nil color: c ]. - aCanvas drawString: 'y' atWaistRight: -5 @ (y1 - 20) font: nil color: c. - - aCanvas geometryTransformation: prevTx.! ! -!HaloMorph methodsFor: 'drawing' stamp: 'jmv 7/20/2021 12:36:34' prior: 50571036 overrides: 16899205! - drawOn: aCanvas - - | b | - target ifNil: [^super drawOn: aCanvas]. - - Preferences halosShowCoordinateSystem ifTrue: [ - target displayFullBounds ifNotNil: [ :fb | - aCanvas frameGlobalRect: fb borderWidth: 3 color: `Color black alpha: 0.3`. - b _ target displayBounds. - b = fb ifFalse: [ - b area > 0 ifTrue: [ - aCanvas frameGlobalRect: b borderWidth: 3 color: `Color black alpha: 0.3` ]]. - self drawCoordinateSystemOn: aCanvas ]].! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/20/2021 12:17:13' prior: 50540986! - addHandle: handleSpec - "Add a handle within the halo box as per the haloSpec, and set it up to respond to the given event by sending the given selector to the given recipient. Return the handle." - - | handle aPoint colorToUse form icon e | - aPoint _ self - positionIn: haloBox - horizontalPlacement: handleSpec horizontalPlacement - verticalPlacement: handleSpec verticalPlacement. - colorToUse _ Color colorFrom: handleSpec color. - handle _ HaloHandleMorph new color: colorToUse. - self addMorph: handle. - e _ Preferences haloHandleSize asPoint. - handle morphPosition: aPoint-(e//2) extent: e. - handleSpec iconSymbol ifNotNil: [ :iconName | - form _ self class icons at: iconName ifAbsent: [self class perform: iconName]. - form ifNotNil: [ - form extent = e ifFalse: [ - ": Non default size, scale that bugger!!" - form _ form ": Be as smooth as possible, these images are small." - magnify: form boundingBox - to: e - smoothing: 2 ]. - icon _ ImageMorph new - image: form; - color: colorToUse makeForegroundColor; - lock. - handle addMorphFront: icon position: `0@0` ]]. - handle mouseUpSelector: #endInteraction. - handle setBalloonText: handleSpec hoverHelp. - ^ handle! ! - -HaloHandleMorph class removeSelector: #circleForm:! - -!methodRemoval: HaloHandleMorph class #circleForm: stamp: 'Install-4685-HaloTweaks-JuanVuletich-2021Jul20-12h50m-jmv.001.cs.st 7/20/2021 16:52:51'! -circleForm: extent - " - CircleForm _ nil - " - | r d l bw center | - (CircleForm isNil or: [ CircleForm extent ~= extent ]) ifTrue: [ - center _ extent -1 * 0.5. - r _ center r * 0.75. - bw _ 1.3. - CircleForm _ Form extent: extent depth: 32. - 0 to: extent y - 1 do: [ :y | - 0 to: extent x - 1 do: [ :x | - d _ (x@y - center) r. - l _ (r - d max: 0.0) min: bw. - CircleForm - colorAt: x @ y - put: (`Color white` alpha: (l / bw)) - ]]. - ]. - ^CircleForm! - -HaloHandleMorph class removeSelector: #releaseClassCachedState! - -!methodRemoval: HaloHandleMorph class #releaseClassCachedState stamp: 'Install-4685-HaloTweaks-JuanVuletich-2021Jul20-12h50m-jmv.001.cs.st 7/20/2021 16:52:51'! -releaseClassCachedState - - CircleForm _ nil! - -KernelMorph subclass: #HaloHandleMorph - instanceVariableNames: 'mouseDownSelector mouseUpSelector mouseMoveSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Halos'! - -!classDefinition: #HaloHandleMorph category: #'Morphic-Halos' stamp: 'Install-4685-HaloTweaks-JuanVuletich-2021Jul20-12h50m-jmv.001.cs.st 7/20/2021 16:52:51'! -KernelMorph subclass: #HaloHandleMorph - instanceVariableNames: 'mouseDownSelector mouseUpSelector mouseMoveSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Halos'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4685-HaloTweaks-JuanVuletich-2021Jul20-12h50m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4683] on 20 July 2021 at 1:50:30 pm'! -!MorphicCanvas class methodsFor: 'services' stamp: 'jmv 7/20/2021 12:20:34'! - isVectorGraphicsActive - " - MorphicCanvas isVectorGraphicsActive - " - ^MorphicCanvas activeSubclass ~~ BitBltCanvas ! ! -!MorphicCanvas class methodsFor: 'services' stamp: 'jmv 7/20/2021 12:28:17'! - isVectorGraphicsPluginActive - " - MorphicCanvas isVectorGraphicsPluginActive - " - ^self isVectorGraphicsActive and: [ - (Smalltalk at: #VectorEngineWithPlugin) isPluginAvailable ]! ! -!MorphicCanvas class methodsFor: 'services' stamp: 'jmv 7/20/2021 12:21:10'! - isVectorGraphicsUsedForAllRendering - " - MorphicCanvas isVectorGraphicsUsedForAllRendering - " - ^MorphicCanvas activeSubclass name == #VectorCanvas! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 7/20/2021 12:28:28' prior: 50577050! - okayToRotateEasily - "Answer whether it is appropriate for a rotation handle to be shown for the receiver." - - ^ self hasOwnLocation and: [MorphicCanvas isVectorGraphicsPluginActive]! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 7/20/2021 12:28:33' prior: 50576969! - okayToScaleEasily - "Answer whether it is appropriate for a scale handle to be shown for the receiver." - - ^ self hasOwnLocation and: [MorphicCanvas isVectorGraphicsPluginActive]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4686-RotateZoomHandlesOnlyIfPluginVectorGraphics-JuanVuletich-2021Jul20-13h48m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4619] on 20 July 2021 at 2:33:16 pm'! -!FeatureRequirement methodsFor: 'requires' stamp: 'jmv 7/20/2021 14:32:53' prior: 50477283! - requireUnlessIn: toLoad main: mainFeatureOrNil requiringFeature: requiringFeatureOrNil - "See if all the requirements can be met and answer the load order" - - self isAlreadySatisfied ifFalse: [ - (toLoad anySatisfy: [ :featReq | featReq sameNameAs: self]) ifFalse: [ - (self findPackageFileAsReqOf: mainFeatureOrNil) - ifTrue: [ | otherRequirements | - otherRequirements := self requirements. - otherRequirements ifNotNil: [ - otherRequirements do: [ :requires | - requires requireUnlessIn: toLoad main: (mainFeatureOrNil ifNil: [self]) requiringFeature: self ]]. - self == mainFeatureOrNil ifFalse: [ - self addToLoad: toLoad withMyRequirements: otherRequirements ]. - ] - ifFalse: [ - | failureMessage | - failureMessage _ name = #'Cuis-Base' ifTrue: [ - 'Installing ', requiringFeatureOrNil name, String newLineString, - 'requires base system updated to #', self minRevision printString, String newLineString, - 'But this system is updated to #', SystemVersion current versionRevision second printString, String newLineString, - 'Please install Cuis base system updates' ] - ifFalse: [ - 'Installing', requiringFeatureOrNil name, String newLineString, - 'Requires: ', self printString ]. - FeatureRequirementUnsatisfied signal: failureMessage. - ]]]. - - ^ toLoad! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4687-BetterRequirementFailureMessage-JuanVuletich-2021Jul20-14h06m-jmv.001.cs.st----! - -----SNAPSHOT----(20 July 2021 16:52:54) Cuis5.0-4687-v3.image priorSource: 7688654! - -----STARTUP---- (21 July 2021 20:11:53) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4687-v3.image! - - -'From Cuis 5.0 [latest update: #4687] on 20 July 2021 at 11:02:51 pm'! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'pb 3/17/2020 13:42:18'! - draw3DLookOn: aCanvas - - | borderStyleSymbol c | - borderStyleSymbol _ self isPressed ifFalse: [ #raised ] ifTrue: [ #inset ]. - c _ color. - self mouseIsOver ifTrue: [ c _ c lighter ]. - aCanvas - fillRectangle: self morphLocalBounds - color: c - borderWidth: borderWidth - borderStyleSymbol: borderStyleSymbol - baseColorForBorder: c. - - self drawRegularLabelOn: aCanvas! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 4/24/2019 20:58:58'! -drawEmbossedLabelOn: aCanvas - - | availableW center colorForLabel f l labelMargin targetSize w x y | - label ifNotNil: [ - colorForLabel _ Theme current buttonLabel. - self isPressed - ifFalse: [ - self mouseIsOver - ifFalse: [ colorForLabel _ colorForLabel adjustSaturation: -0.10 brightness: 0.10 ]] - ifTrue: [ colorForLabel _ colorForLabel adjustSaturation: 0.0 brightness: -0.07 ]. - f _ self fontToUse. - center _ extent // 2. - labelMargin _ 3. - w _ f widthOfString: label. - availableW _ extent x - labelMargin - labelMargin. - availableW >= w - ifTrue: [ - l _ label ] - ifFalse: [ - x _ labelMargin. - targetSize _ label size * availableW // w. - l _ label squeezedTo: targetSize. - (f widthOfString: l) > availableW ifTrue: [ - targetSize _ targetSize - 1. - l _ label squeezedTo: targetSize ]]. - - w _ f widthOfString: l. - x _ center x - (w // 2). - y _ center y - (f lineSpacing // 2). - aCanvas - drawString: l - at: x@y - font: f - color: colorForLabel - embossed: true ]! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 4/24/2019 20:59:05'! - drawRegularLabelOn: aCanvas - - | w f center x y availableW l labelMargin | - - f _ self fontToUse. - center _ extent // 2. - - label ifNotNil: [ - labelMargin _ 4. - w _ f widthOfString: label. - availableW _ extent x - labelMargin - labelMargin - 1. - availableW >= w - ifTrue: [ - x _ center x - (w // 2). - l _ label ] - ifFalse: [ - x _ labelMargin. - l _ label squeezedTo: (label size * availableW / w) rounded ]. - y _ center y - (f lineSpacing // 2). - self isPressed ifTrue: [ - x _ x + 1. - y _ y + 1 ]. - aCanvas - drawString: l - at: x@y - font: f - color: Theme current buttonLabel ]! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 7/20/2021 22:47:56'! - drawRoundLookOn: aCanvas - | r colorForButton rect | - colorForButton _ self isPressed - ifFalse: [ - self mouseIsOver - ifTrue: [ Color h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ color ]] - ifTrue: [ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - rect _ self morphLocalBounds insetBy: `1@3`. - aCanvas roundRect: rect color: colorForButton radius: r ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawEmbossedLabelOn: aCanvas ] - ifFalse: [ self drawRegularLabelOn: aCanvas ].! ! -!MorphicCanvas methodsFor: 'drawing-widgets' stamp: 'jmv 7/20/2021 22:51:58'! - drawButtonIconFromCurrentMorph - "We assume that we are drawing a PluggableButtonMorph, - or some morph that conforms the required protocol. - Answer true if we were able to draw it." - - currentMorph iconDrawSelector ifNotNil: [ :selector | - self perform: selector. - ^true ]. - - currentMorph magnifiedIcon ifNotNil: [ :theIcon | - self pvtDrawButtonFaceForm: theIcon. - ^true ]. - - ^false! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 7/20/2021 22:52:40' prior: 50577581 overrides: 50545913! - drawOn: aCanvas - - self isRoundButton - ifTrue: [ - aCanvas drawButtonIconFromCurrentMorph ifFalse: [ - self drawRoundLookOn: aCanvas ]] - ifFalse: [ - self draw3DLookOn: aCanvas. - aCanvas drawButtonIconFromCurrentMorph ].! ! - -MorphicCanvas removeSelector: #drawButtonRegularLabel:! - -!methodRemoval: MorphicCanvas #drawButtonRegularLabel: stamp: 'Install-4688-moveSomeBackToPluggableButtonMorph-JuanVuletich-2021Jul20-22h31m-jmv.003.cs.st 7/21/2021 20:11:57'! -drawButtonRegularLabel: aPluggableButtonMorph - - | w f center x y availableW l labelMargin label | - - label _ aPluggableButtonMorph label. - f _ aPluggableButtonMorph fontToUse. - center _ aPluggableButtonMorph morphExtent // 2. - - label ifNotNil: [ - labelMargin _ 4. - w _ f widthOfString: label. - availableW _ aPluggableButtonMorph morphExtent x - labelMargin - labelMargin - 1. - availableW >= w - ifTrue: [ - x _ center x - (w // 2). - l _ label ] - ifFalse: [ - x _ labelMargin. - l _ label squeezedTo: (label size * availableW / w) rounded ]. - y _ center y - (f lineSpacing // 2). - aPluggableButtonMorph isPressed ifTrue: [ - x _ x + 1. - y _ y + 1 ]. - self - drawString: l - at: x@y - font: f - color: Theme current buttonLabel ]! - -MorphicCanvas removeSelector: #drawButtonIcon:! - -!methodRemoval: MorphicCanvas #drawButtonIcon: stamp: 'Install-4688-moveSomeBackToPluggableButtonMorph-JuanVuletich-2021Jul20-22h31m-jmv.003.cs.st 7/21/2021 20:11:57'! -drawButtonIcon: aPluggableButtonMorph - "We assume that we are drawing a PluggableButtonMorph, - or some morph that conforms the required protocol. - Answer true if we were able to draw it." - - aPluggableButtonMorph iconDrawSelector ifNotNil: [ :selector | - self perform: selector. - ^true ]. - - aPluggableButtonMorph magnifiedIcon ifNotNil: [ :theIcon | - self pvtDrawButtonFaceForm: theIcon. - ^true ]. - - ^false! - -MorphicCanvas removeSelector: #drawButton3D:! - -!methodRemoval: MorphicCanvas #drawButton3D: stamp: 'Install-4688-moveSomeBackToPluggableButtonMorph-JuanVuletich-2021Jul20-22h31m-jmv.003.cs.st 7/21/2021 20:11:57'! -drawButton3D: aPluggableButtonMorph - - | borderStyleSymbol c | - borderStyleSymbol _ aPluggableButtonMorph isPressed ifFalse: [ #raised ] ifTrue: [ #inset ]. - c _ aPluggableButtonMorph color. - aPluggableButtonMorph mouseIsOver ifTrue: [ c _ c lighter ]. - self - fillRectangle: aPluggableButtonMorph morphLocalBounds - color: c - borderWidth: aPluggableButtonMorph borderWidth - borderStyleSymbol: borderStyleSymbol - baseColorForBorder: c. - - self drawButtonRegularLabel: aPluggableButtonMorph.! - -MorphicCanvas removeSelector: #drawButton:! - -!methodRemoval: MorphicCanvas #drawButton: stamp: 'Install-4688-moveSomeBackToPluggableButtonMorph-JuanVuletich-2021Jul20-22h31m-jmv.003.cs.st 7/21/2021 20:11:57'! -drawButton: aPluggableButtonMorph - aPluggableButtonMorph isRoundButton - ifTrue: [ - (self drawButtonIcon: aPluggableButtonMorph) ifFalse: [ - self drawButtonRound: aPluggableButtonMorph ]] - ifFalse: [ - self drawButton3D: aPluggableButtonMorph. - self drawButtonIcon: aPluggableButtonMorph ]! - -MorphicCanvas removeSelector: #drawButtonEmbossedLabel:! - -!methodRemoval: MorphicCanvas #drawButtonEmbossedLabel: stamp: 'Install-4688-moveSomeBackToPluggableButtonMorph-JuanVuletich-2021Jul20-22h31m-jmv.003.cs.st 7/21/2021 20:11:57'! -drawButtonEmbossedLabel: aPluggableButtonMorph - - | availableW center colorForLabel f l labelMargin targetSize w x y label | - label _ aPluggableButtonMorph label. - label ifNotNil: [ - colorForLabel _ Theme current buttonLabel. - aPluggableButtonMorph isPressed - ifFalse: [ - aPluggableButtonMorph mouseIsOver - ifFalse: [ colorForLabel _ colorForLabel adjustSaturation: -0.10 brightness: 0.10 ]] - ifTrue: [ colorForLabel _ colorForLabel adjustSaturation: 0.0 brightness: -0.07 ]. - f _ aPluggableButtonMorph fontToUse. - center _ aPluggableButtonMorph morphExtent // 2. - labelMargin _ 3. - w _ f widthOfString: label. - availableW _ aPluggableButtonMorph morphExtent x - labelMargin - labelMargin. - availableW >= w - ifTrue: [ - l _ label ] - ifFalse: [ - x _ labelMargin. - targetSize _ label size * availableW // w. - l _ label squeezedTo: targetSize. - (f widthOfString: l) > availableW ifTrue: [ - targetSize _ targetSize - 1. - l _ label squeezedTo: targetSize ]]. - - w _ f widthOfString: l. - x _ center x - (w // 2). - y _ center y - (f lineSpacing // 2). - self - drawString: l - at: x@y - font: f - color: colorForLabel - embossed: true ]! - -MorphicCanvas removeSelector: #drawButtonRound:! - -!methodRemoval: MorphicCanvas #drawButtonRound: stamp: 'Install-4688-moveSomeBackToPluggableButtonMorph-JuanVuletich-2021Jul20-22h31m-jmv.003.cs.st 7/21/2021 20:11:57'! -drawButtonRound: aPluggableButtonMorph - | r colorForButton rect color | - color _ aPluggableButtonMorph color. - colorForButton _ aPluggableButtonMorph isPressed - ifFalse: [ - aPluggableButtonMorph mouseIsOver - ifTrue: [ Color h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ color ]] - ifTrue: [ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - rect _ aPluggableButtonMorph morphLocalBounds insetBy: `1@3`. - self roundRect: rect color: colorForButton radius: r ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawButtonEmbossedLabel: aPluggableButtonMorph ] - ifFalse: [ self drawButtonRegularLabel: aPluggableButtonMorph ].! - -PluggableButtonMorph removeSelector: #drawButtonRoundOn:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4688-moveSomeBackToPluggableButtonMorph-JuanVuletich-2021Jul20-22h31m-jmv.003.cs.st----! - -'From Cuis 5.0 [latest update: #4688] on 21 July 2021 at 12:09:48 pm'! - -LayoutAdjustingMorph subclass: #WindowEdgeAdjustingMorph - instanceVariableNames: 'selector coordinateGetter cursorKey ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -!classDefinition: #WindowEdgeAdjustingMorph category: #'Morphic-Layouts' stamp: 'Install-4689-LayoutAdjustingWithScalingAndRotation-JuanVuletich-2021Jul21-10h30m-jmv.005.cs.st 7/21/2021 20:11:57'! -LayoutAdjustingMorph subclass: #WindowEdgeAdjustingMorph - instanceVariableNames: 'selector coordinateGetter cursorKey' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 7/21/2021 10:40:53'! - referencePositionInOwner - ^self externalize: self rotationCenter! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 7/21/2021 11:38:57'! - morphBottomLeft - "Local coordinates - Must be consistent with #morphTopLef and #morphExtent" - - ^0 @ extent y.! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 7/21/2021 11:28:32'! - morphBottomRight - "Local coordinates - Must be consistent with #morphTopLef and #morphExtent" - - ^extent.! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 7/21/2021 11:28:51'! - morphTopRight - "Local coordinates - Must be consistent with #morphTopLef and #morphExtent" - - ^extent x @ 0.! ! -!Morph methodsFor: 'events' stamp: 'jmv 7/21/2021 12:08:56' prior: 16874501! - dragEvent: aMouseEvent localPosition: aPoint - - aMouseEvent hand halo: nil. - aMouseEvent hand grabMorph: self! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 4/8/2021 15:09:29' prior: 50567806! - grabMorph: aMorph delta: delta - "Grab the given morph (i.e., add it to this hand and remove it from its current owner)." - - | formerOwner formerPositionInWorld | - self releaseMouseFocus. "Break focus" - - "Grab the halo if present" - self halo ifNotNil: [ :h | - (h target == aMorph or: [h target hasOwner: aMorph]) ifTrue: [ - self addMorphBack: h position: h morphPositionInWorld - self morphPositionInWorld ]]. - - "Remember previous owner and position, in case the drop is later rejected" - formerOwner _ aMorph owner. - formerOwner ifNotNil: [ - formerPositionInWorld _ aMorph morphPositionInWorld. - grabMorphData - at: aMorph - put: { formerOwner. formerPositionInWorld. } ]. - self addMorphBack: aMorph position: delta. - - aMorph displayBounds ifNotNil: [ :r | | d | - formerPositionInWorld ifNotNil: [ - d _ aMorph morphPositionInWorld - formerPositionInWorld. - d isZero ifFalse: [ - aMorph adjustDisplayBoundsBy: d ]]]. - - aMorph justGrabbedFrom: formerOwner. - formerOwner ifNotNil: [ - lastPosition _ self morphPosition ].! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 7/21/2021 11:29:26' prior: 50545990 overrides: 50545060! - morphTopLeft - "Local coordinates. - Our hierarchy occupies a rectangle specified by #morphTopLef and #morphExtent" - - ^`0@0`.! ! -!WidgetMorph methodsFor: 'geometry testing' stamp: 'jmv 7/21/2021 11:57:06' prior: 50546018 overrides: 50532209! - isOrthoRectangularMorph - "True if we are of rectangular shape, aligned with local coordinate axes. - Doesn't take into account possible rotation of our or some owner's local coordinates. - Note: SystemWindow answers true, but implements #addPossiblyUncoveredAreasIn:to: to take care of rounded corners." - - ^self requiresVectorCanvas not! ! -!LayoutAdjustingMorph methodsFor: 'adjusting' stamp: 'jmv 7/21/2021 10:49:13' prior: 16862879! - adjustOwnerAt: aGlobalPoint - - owner - adjustBy: self - at: aGlobalPoint! ! -!LayoutAdjustingMorph methodsFor: 'stepping' stamp: 'jmv 7/21/2021 11:59:05' prior: 50569633 overrides: 50547624! - stepAt: millisecondSinceLast - "got the #mouseLeave: message" - | p | - hand ifNil: [ - Cursor currentCursor == self cursor ifTrue: [ Cursor defaultCursor activateCursor ]. - ^ self stopStepping ]. - "hasn't got the #mouseLeave: message (yet)" - p _ hand morphPosition. - hand lastMouseEvent mouseButton1Pressed - ifTrue: [ - self adjustOwnerAt: p. - (owner isOrthoRectangularMorph and: [ - Preferences cheapWindowReframe or: [ - millisecondSinceLast > 200]]) ifTrue: [ - owner displayBounds newRectFrom: [ :f | - self adjustOwnerAt: Sensor mousePoint. - owner morphPosition extent: owner morphExtent ]]] - ifFalse: [ - self stopStepping. - hand _ nil. - Cursor defaultCursor activateCursor ].! ! -!WindowEdgeAdjustingMorph methodsFor: 'initialization' stamp: 'jmv 7/21/2021 10:58:37' prior: 50471173! - initializeBottom - selector _ #windowBottom:. - cursorKey _ #resizeBottomCursor! ! -!WindowEdgeAdjustingMorph methodsFor: 'initialization' stamp: 'jmv 7/21/2021 10:58:42' prior: 50471180! - initializeBottomLeft - selector _ #windowBottomLeft:. - cursorKey _ #resizeBottomLeftCursor! ! -!WindowEdgeAdjustingMorph methodsFor: 'initialization' stamp: 'jmv 7/21/2021 10:59:29' prior: 50471188! - initializeBottomRight - selector _ #windowBottomRight:. - cursorKey _ #resizeBottomRightCursor! ! -!WindowEdgeAdjustingMorph methodsFor: 'initialization' stamp: 'jmv 7/21/2021 10:59:35' prior: 50471196! - initializeLeft - selector _ #windowLeft:. - cursorKey _ #resizeLeftCursor! ! -!WindowEdgeAdjustingMorph methodsFor: 'initialization' stamp: 'jmv 7/21/2021 10:59:39' prior: 50471203! - initializeRight - selector _ #windowRight:. - cursorKey _ #resizeRightCursor! ! -!WindowEdgeAdjustingMorph methodsFor: 'initialization' stamp: 'jmv 7/21/2021 10:59:44' prior: 50471210! - initializeTop - selector _ #windowTop:. - cursorKey _ #resizeTopCursor! ! -!WindowEdgeAdjustingMorph methodsFor: 'initialization' stamp: 'jmv 7/21/2021 10:59:54' prior: 50471217! - initializeTopLeft - selector _ #windowTopLeft:. - cursorKey _ #resizeTopLeftCursor! ! -!WindowEdgeAdjustingMorph methodsFor: 'initialization' stamp: 'jmv 7/21/2021 10:59:58' prior: 50471224! - initializeTopRight - selector _ #windowTopRight:. - cursorKey _ #resizeTopRightCursor! ! -!WindowEdgeAdjustingMorph methodsFor: 'adjusting' stamp: 'jmv 7/21/2021 10:58:28' prior: 16945096 overrides: 50579806! - adjustOwnerAt: aGlobalPoint - | pointInTargetOwners | - - owner ifNotNil: [ - pointInTargetOwners _ aGlobalPoint + 1. - owner owner ifNotNil: [ :parent | - pointInTargetOwners _ parent internalizeFromWorld: pointInTargetOwners ]. - owner perform: selector with: pointInTargetOwners ]! ! -!WindowEdgeAdjustingMorph methodsFor: 'drawing' stamp: 'jmv 7/21/2021 10:30:19' prior: 50578670 overrides: 50503570! - drawOn: aCanvas - - | c | - c _ owner windowFrameColor. - selector caseOf: { - [ #windowTopLeft: ] -> [ - aCanvas roundTopLeftCornerX: 0 y: 0 length: extent x border: owner borderWidth color: c ]. - [ #windowTopRight: ] -> [ - aCanvas roundTopRightCornerX: 0 y: 0 length: extent x border: owner borderWidth color: c ]. - [ #windowBottomLeft: ] -> [ - aCanvas roundBottomLeftCornerX: 0 y: 0 length: extent x border: owner borderWidth color: c ]. - [ #windowBottomRight: ] -> [ - aCanvas roundBottomRightCornerX: 0 y: 0 length: extent x border: owner borderWidth color: c ]. - } - otherwise: [ - "all the morph is sensitive for horizontal and vertical (i.e. non corner) instances." - aCanvas roundEdge: self morphLocalBounds color: c ].! ! -!LayoutMorph methodsFor: 'adjust' stamp: 'jmv 7/21/2021 10:42:59' prior: 50519947! - adjustBy: aLayoutAdjustMorph at: aGlobalPoint - "See Class Comment of LayoutAdjustingMorph" - - | localPoint | - localPoint _ self internalizeFromWorld: aGlobalPoint. - direction == #horizontal ifTrue: [ - self adjustHorizontallyBy: aLayoutAdjustMorph at: localPoint ]. - - direction == #vertical ifTrue: [ - self adjustVerticallyBy: aLayoutAdjustMorph at: localPoint ].! ! -!LayoutMorph methodsFor: 'adjust' stamp: 'jmv 7/21/2021 10:44:12' prior: 50520648! - adjustHorizontallyBy: aLayoutAdjustMorph at: localPoint - | delta l ls r rs lNewWidth rNewWidth i lCurrentWidth rCurrentWidth | - i _ submorphs indexOf: aLayoutAdjustMorph. - ((i = 1) or: [i = self submorphs size]) ifTrue: [ - self inform: 'LayoutAdjustingMorphs require morphs before and after'. - ^self - ]. - l _ self submorphs at: i +1. - ls _ l layoutSpec. - lCurrentWidth _ l morphWidth max: 1. "avoid division by zero" - r _ self submorphs at: i - 1. - rs _ r layoutSpec. - rCurrentWidth _ r morphWidth max: 1. "avoid division by zero" - delta _ localPoint x - aLayoutAdjustMorph referencePositionInOwner x. - delta _ delta max: l minimumShrinkWidth - lCurrentWidth. - delta _ delta min: rCurrentWidth - r minimumShrinkWidth. - delta = 0 ifTrue: [ ^self ]. - rNewWidth _ rCurrentWidth - delta. - lNewWidth _ lCurrentWidth + delta. - (ls isProportionalWidth and: [ rs isProportionalWidth ]) - ifTrue: [ | leftNewProportion rightNewProportion toDistribute | "If both proportional, update them" - leftNewProportion _ lNewWidth / (lNewWidth + rNewWidth). - rightNewProportion _ 1.0 - leftNewProportion. - toDistribute _ ls proportionalLayoutWidth + rs proportionalLayoutWidth. - ls setProportionalWidth: leftNewProportion * toDistribute. - rs setProportionalWidth: rightNewProportion * toDistribute ] - ifFalse: ["If at least one is fixed, update only the fixed" - ls isProportionalWidth ifFalse: [ - ls fixedOrMorphWidth: lNewWidth ]. - rs isProportionalWidth ifFalse: [ - rs fixedOrMorphWidth: rNewWidth ]]. - self layoutSubmorphs.! ! -!LayoutMorph methodsFor: 'adjust' stamp: 'jmv 7/21/2021 10:41:44' prior: 50520699! - adjustVerticallyBy: aLayoutAdjustMorph at: localPoint - | delta t ts b bs tNewHeight bNewHeight i tCurrentHeight bCurrentHeight | - i _ submorphs indexOf: aLayoutAdjustMorph. - ((i = 1) or: [i = self submorphs size]) ifTrue: [ - self inform: 'LayoutAdjustingMorphs require morphs above and below'. - ^self - ]. t _ self submorphs at: i +1. - ts _ t layoutSpec. - tCurrentHeight _ t morphHeight max: 1. "avoid division by zero" - b _ self submorphs at: i - 1. - bs _ b layoutSpec. - bCurrentHeight _ b morphHeight max: 1. "avoid division by zero" - delta _ localPoint y - aLayoutAdjustMorph referencePositionInOwner y. - delta _ delta max: t minimumShrinkHeight - tCurrentHeight. - delta _ delta min: bCurrentHeight - b minimumShrinkHeight. - delta = 0 ifTrue: [ ^self ]. - tNewHeight _ tCurrentHeight + delta. - bNewHeight _ bCurrentHeight - delta. - (ts isProportionalHeight and: [ bs isProportionalHeight ]) - ifTrue: [ | bottomNewProportion toDistribute topNewProportion | "If both proportional, update them" - topNewProportion _ tNewHeight / (tNewHeight + bNewHeight). - bottomNewProportion _ 1.0 - topNewProportion. - toDistribute _ ts proportionalLayoutHeight + bs proportionalLayoutHeight. - ts setProportionalHeight: topNewProportion * toDistribute. - bs setProportionalHeight: bottomNewProportion * toDistribute ] - ifFalse: ["If at least one is fixed, update only the fixed" - ts isProportionalHeight ifFalse: [ - ts fixedOrMorphHeight: tNewHeight ]. - bs isProportionalHeight ifFalse: [ - bs fixedOrMorphHeight: bNewHeight ]]. - self layoutSubmorphs! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 7/21/2021 12:01:11' prior: 50569894 overrides: 50539190! - addPossiblyUncoveredAreasIn: aRectangle to: aCollection - "Answer an array of rectangles encompassing those areas in aRectangle not completely - covered by self. These are the areas that might require further drawing (of morphs below us) - All areas that might possibly be uncovered must be included." - - | bounds radius | - self isOrthoRectangularMorph ifFalse: [ - aCollection add: aRectangle. - ^self ]. - - color mightBeTranslucent ifTrue: [ - aCollection add: aRectangle. - ^self ]. - - bounds _ self displayBounds. - bounds ifNil: [ - aCollection add: aRectangle. - ^self ]. - - "Solid rectangle. - This will be the fastest in many cases. So, please disable rounded corners if on slow hardware!!" - Theme current roundWindowCorners ifFalse: [ - aRectangle areasOutside: bounds do: [ :rect | aCollection add: rect ]. - ^self ]. - - "The solid rectangle does not include the corners. - Report a couple of rows (top and bottom) or columns (left and right) as uncovered areas. - We could also try to be more careful and answer each rounded corner... - Right now, report top and bottom rows as uncovered areas" - radius _ Theme current roundedWindowRadius. - aRectangle areasOutside: (bounds insetBy: 0@radius) do: [ :rect | aCollection add: rect ]! ! -!SystemWindow methodsFor: 'resizing' stamp: 'jmv 7/21/2021 11:43:49' prior: 16926671! - windowBottom: aPointInOwner - "aPointInOwner is in the owner's coordinate system" - - self morphHeight: (self internalize: aPointInOwner) y.! ! -!SystemWindow methodsFor: 'resizing' stamp: 'jmv 7/21/2021 11:39:10' prior: 16926678! - windowBottomLeft: aPointInOwner - "aPointInOwner is in the owner's coordinate system" - - | delta | - delta _ (self internalize: aPointInOwner) - self morphBottomLeft. - self morphExtent: self morphExtent + (delta x negated @ delta y). - self morphPosition: self morphPosition + aPointInOwner - (self externalize: self morphBottomLeft).! ! -!SystemWindow methodsFor: 'resizing' stamp: 'jmv 7/21/2021 11:12:57' prior: 16926689! - windowBottomRight: aPointInOwner - "aPointInOwner is in the owner's coordinate system" - - self morphExtent: (self internalize: aPointInOwner).! ! -!SystemWindow methodsFor: 'resizing' stamp: 'jmv 7/21/2021 11:52:58' prior: 16926696! - windowLeft: aPointInOwner - "aPointInOwner is in the owner's coordinate system" - - | cornerInOwner newPositionInOwnCoordinates | - cornerInOwner _ self externalize: extent. - newPositionInOwnCoordinates _ (self internalize: aPointInOwner) x @ 0. - self morphPosition: (self externalize: newPositionInOwnCoordinates). - self morphExtent: (self internalize: cornerInOwner).! ! -!SystemWindow methodsFor: 'resizing' stamp: 'jmv 7/21/2021 11:44:22' prior: 16926706! - windowRight: aPointInOwner - "aPointInOwner is in the owner's coordinate system" - - self morphWidth: (self internalize: aPointInOwner) x.! ! -!SystemWindow methodsFor: 'resizing' stamp: 'jmv 7/21/2021 11:53:56' prior: 16926713! - windowTop: aPointInOwner - "aPointInOwner is in the owner's coordinate system" - - | cornerInOwner newPositionInOwnCoordinates | - cornerInOwner _ self externalize: extent. - newPositionInOwnCoordinates _ 0 @ (self internalize: aPointInOwner) y. - self morphPosition: (self externalize: newPositionInOwnCoordinates). - self morphExtent: (self internalize: cornerInOwner).! ! -!SystemWindow methodsFor: 'resizing' stamp: 'jmv 7/21/2021 11:18:31' prior: 16926723! - windowTopLeft: aPointInOwner - "aPointInOwner is in the owner's coordinate system" - - | cornerInOwner | - cornerInOwner _ self externalize: extent. - self morphPosition: aPointInOwner. - self morphExtent: (self internalize: cornerInOwner).! ! -!SystemWindow methodsFor: 'resizing' stamp: 'jmv 7/21/2021 11:35:50' prior: 16926732! - windowTopRight: aPointInOwner - "aPointInOwner is in the owner's coordinate system" - - | delta | - delta _ (self internalize: aPointInOwner) - self morphTopRight. - self morphExtent: self morphExtent + (delta x @ delta y negated). - self morphPosition: self morphPosition + aPointInOwner - (self externalize: self morphTopRight).! ! - -LayoutAdjustingMorph subclass: #WindowEdgeAdjustingMorph - instanceVariableNames: 'selector cursorKey' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -!classDefinition: #WindowEdgeAdjustingMorph category: #'Morphic-Layouts' stamp: 'Install-4689-LayoutAdjustingWithScalingAndRotation-JuanVuletich-2021Jul21-10h30m-jmv.005.cs.st 7/21/2021 20:11:57'! -LayoutAdjustingMorph subclass: #WindowEdgeAdjustingMorph - instanceVariableNames: 'selector cursorKey' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Layouts'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4689-LayoutAdjustingWithScalingAndRotation-JuanVuletich-2021Jul21-10h30m-jmv.005.cs.st----! - -----SNAPSHOT----(21 July 2021 20:11:59) Cuis5.0-4689-v3.image priorSource: 7927953! - -----STARTUP---- (6 August 2021 11:45:08) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4689-v3.image! - - -'From Cuis 5.0 [latest update: #4689] on 22 July 2021 at 6:36:33 pm'! - -Object subclass: #MethodCategoriesPrompter - instanceVariableNames: 'startClass rejectingFirst prompt categories lines reject' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Text'! - -!classDefinition: #MethodCategoriesPrompter category: #'System-Text' stamp: 'Install-4690-CuisCore-JoaquinSingerHernanWilkinson-2021Jul22-15h23m-HAW.001.cs.st 8/6/2021 11:45:13'! -Object subclass: #MethodCategoriesPrompter - instanceVariableNames: 'startClass rejectingFirst prompt categories lines reject' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Text'! -!MethodCategoriesPrompter methodsFor: 'initialization' stamp: 'HAW 7/22/2021 17:12:06'! - initializeStaringFrom: aClass rejectingFirst: aRejectingFirst prompting: aPrompt - - startClass := aClass. - rejectingFirst := aRejectingFirst. - prompt := aPrompt ! ! -!MethodCategoriesPrompter methodsFor: 'value' stamp: 'HAW 7/22/2021 18:31:08'! - valueIfNone: aNoneBlock - - | selectedCategoryIndex categoryName | - - self initializeCategories. - - selectedCategoryIndex := self promptCategory. - selectedCategoryIndex = 0 ifTrue: [^ aNoneBlock value]. - - categoryName := selectedCategoryIndex = 1 ifTrue: [ self requestNewCategory ] ifFalse: [ categories at: selectedCategoryIndex ]. - categoryName isEmpty ifTrue: [ ^aNoneBlock value ]. - - ^categoryName - ! ! -!MethodCategoriesPrompter methodsFor: 'categories initialization - private' stamp: 'HAW 7/22/2021 18:16:53'! - addCategories - - startClass allSuperclasses do: [ :superclass | self addCategoriesOf: superclass ]! ! -!MethodCategoriesPrompter methodsFor: 'categories initialization - private' stamp: 'HAW 7/22/2021 18:20:44'! - addCategoriesOf: aSuperclass - - | superclassCategories | - - superclassCategories := aSuperclass methodCategoriesAsSortedCollection reject: [ :category | reject includes: category]. - - superclassCategories isEmpty ifFalse: [ - lines add: categories size. - categories addAll: superclassCategories. - reject addAll: superclassCategories]! ! -!MethodCategoriesPrompter methodsFor: 'categories initialization - private' stamp: 'HAW 7/22/2021 18:30:11'! - createCategories - - | classCategories | - - categories := OrderedCollection with: 'new ...'. - lines := OrderedCollection with: 1. - classCategories := startClass methodCategoriesAsSortedCollection. - - reject := classCategories asSet. - reject - add: ClassOrganizer nullCategory; - add: ClassOrganizer default. - - startClass isMeta ifTrue: [ self initializeCategoriesWhenMeta: classCategories]. - rejectingFirst ifFalse: [ categories addAll: classCategories ]! ! -!MethodCategoriesPrompter methodsFor: 'categories initialization - private' stamp: 'HAW 7/22/2021 18:30:11'! - initializeCategories - - self - createCategories; - addCategories! ! -!MethodCategoriesPrompter methodsFor: 'categories initialization - private' stamp: 'HAW 7/22/2021 18:21:19'! - initializeCategoriesWhenMeta: classCategories - - categories add: Categorizer instanceCreation. - classCategories remove: Categorizer instanceCreation ifAbsent: []. - reject add: Categorizer instanceCreation! ! -!MethodCategoriesPrompter methodsFor: 'prompting - private' stamp: 'HAW 7/22/2021 18:21:47'! - promptCategory - - | selectedLabelIndex | - - selectedLabelIndex := categories size = 1 - ifTrue: [ 1 ] - ifFalse: [ (PopUpMenu labelArray: categories lines: lines) startUpWithCaption: prompt ]. - - ^selectedLabelIndex! ! -!MethodCategoriesPrompter methodsFor: 'prompting - private' stamp: 'HAW 7/22/2021 17:18:46'! - requestNewCategory - - ^self request: 'New category name?' initialAnswer: 'category-name'! ! -!MethodCategoriesPrompter class methodsFor: 'instance creation' stamp: 'HAW 7/22/2021 17:10:52'! - staringFrom: aClass rejectingFirst: rejectingFirst prompting: aPrompt - - ^self new initializeStaringFrom: aClass rejectingFirst: rejectingFirst prompting: aPrompt -! ! -!CodeProvider methodsFor: 'categories' stamp: 'HAW 7/22/2021 17:09:38' prior: 50518884! - categoryFromUserWithPrompt: aPrompt for: aClass - "self new categoryFromUserWithPrompt: 'testing' for: SystemDictionary" - - ^(MethodCategoriesPrompter - staringFrom: aClass - rejectingFirst: false - prompting: aPrompt) valueIfNone: [ nil ]! ! -!Browser methodsFor: 'message category functions' stamp: 'HAW 7/22/2021 17:09:55' prior: 50518925! - newMethodCategoryNameIfNone: aNoneBlock - - ^(MethodCategoriesPrompter - staringFrom: self selectedClassOrMetaClass - rejectingFirst: true - prompting: 'Add Category') valueIfNone: aNoneBlock! ! -!Debugger methodsFor: 'context stack menu' stamp: 'HAW 7/22/2021 18:24:24' prior: 50576567! -askForCategoryIn: aClass default: aDefaultCategory - - ^(MethodCategoriesPrompter - staringFrom: aClass - rejectingFirst: false - prompting: 'Select category for the new method' ) valueIfNone: [ aDefaultCategory ]! ! - -MethodCategoriesPrompter removeSelector: #initializeCategoriesAndLines! - -MethodCategoriesPrompter removeSelector: #createCategoriesAndLines! - -MethodCategoriesPrompter removeSelector: #calculateCategoriesAndLines! - -MethodCategoriesPrompter removeSelector: #addMethodCategories! - -MethodCategoriesPrompter removeSelector: #selectedIndexFrom:separatedWith:propting:! - -MethodCategoriesPrompter removeSelector: #selectCategory! - -MethodCategoriesPrompter removeSelector: #addMethodCategoriesOf:! - -MethodCategoriesPrompter removeSelector: #initializeLabelsAndLines! - -MethodCategoriesPrompter removeSelector: #initializeLabelsWhenClassIsMeta:! - -Debugger removeSelector: #addCategoriesStartingFrom:to:separatingWith:! - -Debugger removeSelector: #addCategoriesStartingFrom:to:separatingWith:rejectingStartingCategories:! - -Debugger removeSelector: #addCategoriesOf:to:separatingWith:! - -!methodRemoval: Debugger #addCategoriesOf:to:separatingWith: stamp: 'Install-4690-CuisCore-JoaquinSingerHernanWilkinson-2021Jul22-15h23m-HAW.001.cs.st 8/6/2021 11:45:13'! -addCategoriesOf: aClass to: categories separatingWith: lines - - | classCategories reject | - - classCategories := aClass methodCategoriesAsSortedCollection. - reject := classCategories asSet. - aClass isMeta ifTrue: [ - categories add: Categorizer instanceCreation. - classCategories remove: Categorizer instanceCreation ifAbsent: []. - reject add: Categorizer instanceCreation]. - reject - add: ClassOrganizer nullCategory; - add: ClassOrganizer default. - categories addAll: classCategories. - - aClass allSuperclasses do: [ :superclass | | superclassCategories | - superclassCategories := superclass methodCategoriesAsSortedCollection reject: [ :cat | reject includes: cat]. - superclassCategories isEmpty ifFalse: [ - lines add: categories size. - categories addAll: superclassCategories. - reject addAll: superclassCategories]]. - -! - -CodeProvider removeSelector: #requestNewCategory! - -CodeProvider removeSelector: #addMethodCategoriesStartingFrom:to:separatingWith:rejecting:! - -CodeProvider removeSelector: #addCategoriesStartingFrom:rejectingStartingCategories:! - -CodeProvider removeSelector: #selectCategoryFrom:propting:ifNone:! - -CodeProvider removeSelector: #selectedIndexFrom:separatedWith:propting:! - -CodeProvider removeSelector: #methodCategoriesStartingFrom:rejectingFirst:! - -CodeProvider removeSelector: #addCategoriesOf:to:separatingWith:! - -CodeProvider removeSelector: #addCategoriesStartingFrom:to:separatingWith:! - -CodeProvider removeSelector: #addCategoriesStartingFrom:to:separatingWith:rejectingStartingCategories:! - -CodeProvider removeSelector: #addCategoriesStartingFrom:separatingWith:rejectingStartingCategories:! - -CodeProvider removeSelector: #selectCategoryFrom:separatedWith:propting:ifNone:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4690-CuisCore-JoaquinSingerHernanWilkinson-2021Jul22-15h23m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4690] on 25 July 2021 at 8:01:51 pm'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 7/25/2021 19:37:31' prior: 50568768! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('AY' 'Angel Yan') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('bgs' 'Boris G. Shingarov') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('db' 'Douglas Brebner') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('EB' 'Eric Brandwein') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('FGJ' 'Fernando Gasperi Jabalera') - #('FJG' 'Facundo Javier Gelatti') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hlsf' 'Hilaire Fernandes') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('jar' 'Jaromir Matas') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('KLG' 'Gerald Klix') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MM' 'Mariano Montone') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('pmon' 'Paolo Montrasi') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('sjd' 'Santiago Jose Dandois') - #('SLD' 'Steve Davies') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('ss' 'Sebastian Sujarchuk') - #('SSS' 'Samuel S. Shuster') - #('ST-80' 'Smalltalk-80, version 2, of April 1, 1983') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tsl' 'Thiago da Silva Lino') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4691-Add-ST-80-asKnownAuthor-JuanVuletich-2021Jul25-20h00m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4691] on 26 July 2021 at 9:05:09 am'! -!Object methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16880937! - yourself - "Answer self."! ! -!Object methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16882689! - errorImproperStore - "Create an error notification that an improper store was attempted." - - self error: 'Improper store into indexable object'! ! -!Object methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16882695! - errorNonIntegerIndex - "Create an error notification that an improper object was used as an index." - - self error: 'only integers should be used as indices'! ! -!Object methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16882747! - species - "Answer the preferred class for reconstructing the receiver. For example, - collections create new collections whenever enumeration messages such as - collect: or select: are invoked. The new kind of collection is determined by - the species of the original collection. Species and class are not always the - same. For example, the species of Interval is Array." - - ^self class! ! -!Object class methodsFor: 'documentation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16883027! - whatIsAPrimitive - "Some messages in the system are responded to primitively. A primitive - response is performed directly by the interpreter rather than by evaluating - expressions in a method. The methods for these messages indicate the - presence of a primitive response by including before the - first expression in the method. - - Primitives exist for several reasons. Certain basic or 'primitive' - operations cannot be performed in any other way. Smalltalk without - primitives can move values from one variable to another, but cannot add two - SmallIntegers together. Many methods for arithmetic and comparison - between numbers are primitives. Some primitives allow Smalltalk to - communicate with I/O devices such as the disk, the display, and the keyboard. - Some primitives exist only to make the system run faster; each does the same - thing as a certain Smalltalk method, and its implementation as a primitive is - optional. - - When the Smalltalk interpreter begins to execute a method which specifies a - primitive response, it tries to perform the primitive action and to return a - result. If the routine in the interpreter for this primitive is successful, - it will return a value and the expressions in the method will not be evaluated. - If the primitive routine is not successful, the primitive 'fails', and the - Smalltalk expressions in the method are executed instead. These - expressions are evaluated as though the primitive routine had not been - called. - - The Smalltalk code that is evaluated when a primitive fails usually - anticipates why that primitive might fail. If the primitive is optional, the - expressions in the method do exactly what the primitive would have done (See - Number @). If the primitive only works on certain classes of arguments, the - Smalltalk code tries to coerce the argument or appeals to a superclass to find - a more general way of doing the operation (see SmallInteger +). If the - primitive is never supposed to fail, the expressions signal an error (see - SmallInteger asFloat). - - Each method that specifies a primitive has a comment in it. If the primitive is - optional, the comment will say 'Optional'. An optional primitive that is not - implemented always fails, and the Smalltalk expressions do the work - instead. - - If a primitive is not optional, the comment will say, 'Essential'. Some - methods will have the comment, 'No Lookup'. See Object - howToModifyPrimitives for an explanation of special selectors which are - not looked up. - - For the primitives for +, -, *, and bitShift: in SmallInteger, and truncated - in Float, the primitive constructs and returns a 16-bit - LargePositiveInteger when the result warrants it. Returning 16-bit - LargePositiveIntegers from these primitives instead of failing is - optional in the same sense that the LargePositiveInteger arithmetic - primitives are optional. The comments in the SmallInteger primitives say, - 'Fails if result is not a SmallInteger', even though the implementor has the - option to construct a LargePositiveInteger. For further information on - primitives, see the 'Primitive Methods' part of the chapter on the formal - specification of the interpreter in the Smalltalk book." - - self error: 'comment only'! ! -!Switch methodsFor: 'state' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16918345! - switch - "Change the state of the receiver from 'on' to 'off' or from 'off' to 'on' (see - Switch|turnOn, Switch|turnOff)." - - self isOn - ifTrue: [self turnOff] - ifFalse: [self turnOn]! ! -!Switch class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16918403 overrides: 16783533! - new - "Answer an instance of me such that the on and off actions are set to nil - ('no action'), and the state is set to 'off'." - - ^self newOff! ! -!Boolean methodsFor: 'logical operations' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16790147! - eqv: aBoolean - "Answer true if the receiver is equivalent to aBoolean." - - ^self == aBoolean! ! -!Boolean methodsFor: 'copying' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16790326 overrides: 16881231! - shallowCopy - "Receiver has two concrete subclasses, True and False. - Only one instance of each should be made, so return self."! ! -!Boolean class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16790349 overrides: 16783533! - new - self error: 'You may not create any more Booleans - this is two-valued logic'! ! -!False methodsFor: 'logical operations' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16840417 overrides: 16790140! - & alternativeObject - "Evaluating conjunction -- answer false since receiver is false." - - ^self! ! -!False methodsFor: 'logical operations' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16840422 overrides: 16790152! - not - "Negation -- answer true since the receiver is false." - - ^true! ! -!False methodsFor: 'logical operations' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16840431 overrides: 16790158! - | aBoolean - "Evaluating disjunction (OR) -- answer with the argument, aBoolean." - - ^aBoolean! ! -!False methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16840436 overrides: 16790165! - and: alternativeBlock - "Nonevaluating conjunction -- answer with false since the receiver is false." - - ^self! ! -!False methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16840441 overrides: 16790222! - ifFalse: alternativeBlock - "Answer the value of alternativeBlock. Execution does not actually - reach here because the expression is compiled in-line." - - ^alternativeBlock value! ! -!False methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16840448 overrides: 16790236! - ifFalse: falseAlternativeBlock ifTrue: trueAlternativeBlock - "Answer the value of falseAlternativeBlock. Execution does not - actually reach here because the expression is compiled in-line." - - ^falseAlternativeBlock value! ! -!False methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16840457 overrides: 16790241! - ifTrue: alternativeBlock - "Since the condition is false, answer the value of the false alternative, - which is nil. Execution does not actually reach here because the - expression is compiled in-line." - - ^nil! ! -!False methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16840465 overrides: 16790255! - ifTrue: trueAlternativeBlock ifFalse: falseAlternativeBlock - "Answer the value of falseAlternativeBlock. Execution does not - actually reach here because the expression is compiled in-line." - - ^falseAlternativeBlock value! ! -!False methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16840474 overrides: 16790271! - or: alternativeBlock - "Nonevaluating disjunction -- answer value of alternativeBlock." - - ^alternativeBlock value! ! -!True methodsFor: 'logical operations' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16939769 overrides: 16790140! - & alternativeObject - "Evaluating conjunction -- answer alternativeObject since receiver is true." - - ^alternativeObject! ! -!True methodsFor: 'logical operations' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16939775 overrides: 16790152! - not - "Negation--answer false since the receiver is true." - - ^false! ! -!True methodsFor: 'logical operations' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16939785 overrides: 16790158! - | aBoolean - "Evaluating disjunction (OR) -- answer true since the receiver is true." - - ^self! ! -!True methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16939790 overrides: 16790165! - and: alternativeBlock - "Nonevaluating conjunction -- answer the value of alternativeBlock since - the receiver is true." - - ^alternativeBlock value! ! -!True methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16939796 overrides: 16790222! - ifFalse: alternativeBlock - "Since the condition is true, the value is the true alternative, which is nil. - Execution does not actually reach here because the expression is compiled - in-line." - - ^nil! ! -!True methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16939804 overrides: 16790236! - ifFalse: falseAlternativeBlock ifTrue: trueAlternativeBlock - "Answer the value of trueAlternativeBlock. Execution does not - actually reach here because the expression is compiled in-line." - - ^trueAlternativeBlock value! ! -!True methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16939813 overrides: 16790241! - ifTrue: alternativeBlock - "Answer the value of alternativeBlock. Execution does not actually - reach here because the expression is compiled in-line." - - ^alternativeBlock value! ! -!True methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16939820 overrides: 16790255! - ifTrue: trueAlternativeBlock ifFalse: falseAlternativeBlock - "Answer with the value of trueAlternativeBlock. Execution does not - actually reach here because the expression is compiled in-line." - - ^trueAlternativeBlock value! ! -!True methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16939829 overrides: 16790271! - or: alternativeBlock - "Nonevaluating disjunction -- answer true since the receiver is true." - - ^self! ! -!UndefinedObject methodsFor: 'copying' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16940070 overrides: 16881231! - shallowCopy - "Only one instance of UndefinedObject should ever be made, so answer - with self."! ! -!UndefinedObject class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16940236 overrides: 16783533! -new - self error: 'You may not create any more undefined objects--use nil'! ! -!Behavior methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16783027! - isFixed - "Answer whether the receiver does not have a variable (indexable) part." - - ^self isVariable not! ! -!Behavior methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16783057! - isPointers - "Answer whether the receiver contains just pointers (not bits)." - - ^self isBits not! ! -!Behavior methodsFor: 'compiling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16783323! - compileAll - ^ self compileAllFrom: self! ! -!Behavior methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16784815! - flushCache - "Tell the interpreter to remove the contents of its method lookup cache, if it has - one. Essential. See Object documentation whatIsAPrimitive." - - - self primitiveFailed! ! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16806753! - fileOutOn: aFileStream - "File a description of the receiver on aFileStream." - - self fileOutOn: aFileStream - moveSource: false - toFile: 0! ! -!ClassDescription methodsFor: 'instance variables' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16805852! - addInstVarName: aString - "Add the argument, aString, as one of the receiver's instance variables." - - self subclassResponsibility! ! -!ClassDescription methodsFor: 'organization' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16806301! - category - "Answer the system organization category for the receiver." - - ^SystemOrganization categoryOfElement: self name! ! -!ClassDescription methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16807052! - errorCategoryName - self error: 'Category name must be a String'! ! -!Metaclass methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16870966 overrides: 16783050! - isMeta - ^ true! ! -!Metaclass methodsFor: 'instance variables' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16871007 overrides: 50581065! - addInstVarName: aString - "Add the argument, aString, as one of the receiver's instance variables." - - | fullString | - fullString _ aString. - self instVarNames do: [:aString2 | fullString _ aString2 , ' ' , fullString]. - self instanceVariableNames: fullString! ! -!Metaclass methodsFor: 'pool variables' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16871032 overrides: 50527978! - classPool - "Answer the dictionary of class variables." - - ^thisClass classPool! ! -!Magnitude methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16865581 overrides: 16881029! - = aMagnitude - "Compare the receiver with the argument and answer with true if the - receiver is equal to the argument. Otherwise answer false." - - ^self subclassResponsibility! ! -!Magnitude methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16865606 overrides: 16881052! - hash - "Hash must be redefined whenever = is redefined." - - ^self subclassResponsibility! ! -!Number methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16880440! - even - "Answer whether the receiver is an even number." - - ^self \\ 2 = 0! ! -!Number methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16880476! - sign - "Answer 1 if the receiver is greater than 0, -1 if less than 0, else 0." - - self > 0 ifTrue: [^1]. - self < 0 ifTrue: [^-1]. - ^0! ! -!Number methodsFor: 'truncation and round off' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16880537! - floor - "Answer the integer nearest the receiver toward negative infinity." - - | truncation | - truncation _ self truncated. - self >= 0 ifTrue: [^truncation]. - self = truncation - ifTrue: [^truncation] - ifFalse: [^truncation - 1]! ! -!Float class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16845853 overrides: 50568403! - readFrom: aStream - "Answer a new Float as described on the stream, aStream." - - ^(super readFrom: aStream) asFloat! ! -!LargePositiveInteger methodsFor: 'arithmetic' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16862367 overrides: 16879678! - abs! ! -!Association methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16780903! - key: aKey value: anObject - "Store the arguments as the variables of the receiver." - - key _ aKey. - value _ anObject! ! -!Character class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16800996 overrides: 16783533! - new - "Creating new characters is not allowed." - - self error: 'cannot create new characters'! ! -!InstructionStream methodsFor: 'scanning' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16858216! - method - "Answer the compiled method that supplies the receiver's bytecodes." - - ^sender "method access when used alone (not as part of a context)"! ! -!InstructionStream methodsFor: 'scanning' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16858237! - pc - "Answer the index of the next bytecode." - - ^pc! ! -!ContextPart methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16823651! - home - "Answer the context in which the receiver was defined." - - self subclassResponsibility! ! -!ContextPart methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16823670! - receiver - "Answer the receiver of the message that created this context." - - self subclassResponsibility! ! -!ContextPart methodsFor: 'debugger access' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16824114! - sender - "Answer the context that sent the message that created the receiver." - - ^sender! ! -!ContextPart methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16824575! - top - "Answer the top of the receiver's stack." - - ^self at: stackp! ! -!Decompiler methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16831571! - blockReturnTop - "No action needed"! ! -!Message class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16867470! - selector: aSymbol - "Answer an instance of me with unary selector, aSymbol." - - ^self new setSelector: aSymbol arguments: (Array new: 0)! ! -!InputSensor methodsFor: 'keyboard' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16856301! -flushKeyboard - "Remove all characters from the keyboard buffer." - - [self keyboardPressed] - whileTrue: [self keyboard]! ! -!ProcessorScheduler methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16895607! - activePriority - "Answer the priority level of the currently running Process." - - ^activeProcess priority! ! -!ProcessorScheduler methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16895612! - activeProcess - "Answer the currently running Process." - - ^activeProcess! ! -!ProcessorScheduler methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16895621! - highestPriority - "Answer the number of priority levels currently available for use." - - ^quiescentProcessLists size! ! -!ProcessorScheduler methodsFor: 'process state change' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16895684! - suspendFirstAt: aPriority - "Suspend the first Process that is waiting to run with priority aPriority." - - ^self suspendFirstAt: aPriority - ifNone: [self error: 'No Process to suspend']! ! -!ProcessorScheduler methodsFor: 'process state change' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16895704! - terminateActive - "Terminate the process that is currently running." - - activeProcess terminate! ! -!ProcessorScheduler class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16895845 overrides: 16783533! - new - "New instances of ProcessorScheduler should not be created." - - self error: -'New ProcessSchedulers should not be created since -the integrity of the system depends on a unique scheduler'! ! -!Collection methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16813919 overrides: 16880927! - size - "Answer how many elements the receiver contains." - - | tally | - tally _ 0. - self do: [:each | tally _ tally + 1]. - ^tally! ! -!Collection methodsFor: 'enumerating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16814339! - do: aBlock - "Evaluate aBlock with each of the receiver's elements as the argument." - - self subclassResponsibility! ! -!Collection methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16814946! - 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! ! -!SequenceableCollection methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16905982! - 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! ! -!SequenceableCollection methodsFor: 'copying' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16906251 overrides: 16814138! - 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! ! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16906561! - 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! ! -!SequenceableCollection methodsFor: 'removing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16906950 overrides: 16814694! - remove: oldObject ifAbsent: anExceptionBlock - "SequencableCollections cannot implement removing." - - self shouldNotImplement! ! -!ArrayedCollection class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16780639 overrides: 16815113! - with: anObject - "Answer a new instance of me, containing only anObject." - - | newCollection | - newCollection _ self new: 1. - newCollection at: 1 put: anObject. - ^newCollection! ! -!ArrayedCollection class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16780647 overrides: 16815119! - 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! ! -!Array methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16779841 overrides: 16780275! - 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]! ! -!CompiledMethod methodsFor: 'literals' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16820102! - literalAt: index - "Answer the literal indexed by the argument." - - ^self objectAt: index + 1! ! -!CompiledMethod methodsFor: 'scanning' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16820193! - messages - "Answer a Set of all the message selectors sent by this method." - - | scanner aSet | - aSet _ Set new. - scanner _ InstructionStream on: self. - scanner - scanFor: - [:x | - scanner addSelectorTo: aSet. - false "keep scanning"]. - ^aSet! ! -!Interval methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16861170 overrides: 16880792! - at: anInteger put: anObject - "Storing into an Interval is not allowed." - - self error: 'you can not store into an interval'! ! -!Interval methodsFor: 'removing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16861230 overrides: 16814683! - remove: newObject - "Removing from an Interval is not allowed." - - self error: 'elements cannot be removed from an Interval'! ! -!Semaphore class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16905283 overrides: 16783533! - new - "Answer a new instance of Semaphore that contains no signals." - - ^self basicNew initSignals! ! -!OrderedCollection methodsFor: 'copying' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16883953 overrides: 50581313! - 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! ! -!Text methodsFor: 'emphasis' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16929479! - runLengthFor: characterIndex - "Answer the count of characters remaining in run beginning with - characterIndex." - - ^runs runLengthAt: characterIndex! ! -!Dictionary methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16833518 overrides: 16907352! - 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! ! -!Dictionary methodsFor: 'enumerating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16833694! - keysDo: aBlock - "Evaluate aBlock for each of the receiver's keys." - - self associationsDo: [:association | aBlock value: association key]! ! -!SharedQueue methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16907712 overrides: 16880927! - size - "Answer the number of objects that have been sent through the - receiver and not yet received by anyone." - - ^writePosition - readPosition! ! -!SharedQueue class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16907787 overrides: 16783533! - new - "Answer a new instance of SharedQueue that has 10 elements." - - ^self new: 10! ! -!PositionableStream methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16891203 overrides: 16914001! - contents - "Answer with a copy of my collection from 1 to readLimit." - - ^collection copyFrom: 1 to: readLimit! ! -!PositionableStream methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16891873! - 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'! ! -!ReadStream class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898063 overrides: 16892260! - 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! ! -!WriteStream methodsFor: 'character writing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16946501! - space - "Append a space character to the receiver." - - self nextPut: Character space! ! -!WriteStream methodsFor: 'character writing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16946512! - tab - "Append a tab character to the receiver." - - self nextPut: Character tab! ! -!ReadWriteStream methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898084 overrides: 16946360! - contents - "Answer with a copy of my collection from 1 to readLimit." - - readLimit _ readLimit max: position. - ^collection copyFrom: 1 to: readLimit! ! -!FileStream methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16843528 overrides: 16891209! -contentsOfEntireFile - "Read all of the contents of the receiver." - - | s | - self readOnly. - self reset. - s _ self next: self size. - self close. - ^s! ! -!Process methodsFor: 'changing suspended state' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16894253! - install: aContext - "Replace the suspendedContext with aContext." - - self == Processor activeProcess - ifTrue: [^self error: 'The active process cannot install contexts']. - suspendedContext _ aContext! ! -!Scanner methodsFor: 'error handling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16903866! - offEnd: aString - "Parser overrides this" - - ^self notify: aString! ! -!ReturnNode methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16901054 overrides: 16884669! - asReturnNode! ! -!Form methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16846749! -bits: aBitmap - "Reset the Bitmap containing the receiver's bits." - - bits _ aBitmap! ! -!Point methodsFor: 'point functions' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16890503! - dist: aPoint - "Answer the distance between aPoint and the receiver." - - ^(aPoint - self) r! ! -!Point methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16890716 overrides: 50508084! - printOn: aStream - "The receiver prints on aStream in terms of infix notation." - - x printOn: aStream. - aStream nextPut: $@. - y printOn: aStream! ! -!Rectangle methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898870! - containsPoint: aPoint - "Answer whether aPoint is within the receiver." - - ^origin <= aPoint and: [aPoint < corner]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4692-ST-80-timestamps-JuanVuletich-2021Jul26-09h01m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4691] on 26 July 2021 at 9:08:22 am'! -!Boolean methodsFor: 'logical operations' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16790140! - & aBoolean - "Evaluating conjunction -- Evaluate the argument. Then answer true if both the - receiver and the argument are true." - self subclassResponsibility! ! -!Boolean methodsFor: 'logical operations' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16790158! - | aBoolean - "Evaluating disjunction (OR) -- Evaluate the argument. Then answer true if - either the receiver or the argument is true." - self subclassResponsibility! ! -!Boolean methodsFor: 'logical operations' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16790152! - not - "Negation-- answer true if the receiver is false, answer false if the receiver is true." - self subclassResponsibility! ! -!Boolean methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16790165! - and: alternativeBlock - "Nonevaluating conjunction -- if the receiver is true, answer the value of - the argument, alternativeBlock; otherwise answer false without evaluating the - argument." - self subclassResponsibility! ! -!Boolean methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16790222! - ifFalse: alternativeBlock - "If the receiver is true (i.e., the condition is true), then the value is the true - alternative, which is nil. Otherwise answer the result of evaluating the argument, - alternativeBlock. Create an error if the receiver is nonBoolean. Execution does not - actually reach here because the expression is compiled in-line." - self subclassResponsibility! ! -!Boolean methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16790236! - ifFalse: falseAlternativeBlock ifTrue: trueAlternativeBlock - "Same as ifTrue:ifFalse:" - self subclassResponsibility! ! -!Boolean methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16790241! - ifTrue: alternativeBlock - "If the receiver is false (i.e., the condition is false), then the value is the false - alternative, which is nil. Otherwise answer the result of evaluating the argument, - alternativeBlock. Create an error if the receiver is nonBoolean. Execution does not - actually reach here because the expression is compiled in-line." - self subclassResponsibility! ! -!Boolean methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16790255! - ifTrue: trueAlternativeBlock ifFalse: falseAlternativeBlock - "If the receiver is true (i.e., the condition is true), then answer the value of the - argument trueAlternativeBlock. If the receiver is false, answer the result of - evaluating the argument falseAlternativeBlock. If the receiver is a nonBoolean - then create an error message. Execution does not actually reach here because the - expression is compiled in-line." - self subclassResponsibility! ! -!Boolean methodsFor: 'controlling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16790271! - or: alternativeBlock - "Nonevaluating disjunction -- if the receiver is false, answer the value of - the argument, alternativeBlock; otherwise answer true without evaluating the - argument." - self subclassResponsibility! ! -!Boolean methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16790335 overrides: 16882265! - storeOn: aStream - self printOn: aStream! ! -!False methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16840479 overrides: 50508084! - printOn: aStream - "Print false." - aStream nextPutAll: 'false'! ! -!True methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16939834 overrides: 50508084! - printOn: aStream - aStream nextPutAll: 'true'! ! -!UndefinedObject methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16940075 overrides: 50508084! - printOn: aStream - aStream nextPutAll: 'nil'! ! -!UndefinedObject methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16940080 overrides: 16882265! - storeOn: aStream - aStream nextPutAll: 'nil'! ! -!UndefinedObject methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16940117 overrides: 16896461! - isNil - ^true! ! -!UndefinedObject methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16940121 overrides: 16896466! - notNil - ^false! ! -!UndefinedObject methodsFor: 'dependents access' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16940125 overrides: 16881272! - addDependent: ignored - self error: 'Nil should not have dependents'! ! -!Number methodsFor: 'arithmetic' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16879621! - * aNumber - "Answer the result of multiplying the receiver by aNumber." - self subclassResponsibility! ! -!Number methodsFor: 'arithmetic' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16879626! - + aNumber - "Answer the sum of the receiver and aNumber." - self subclassResponsibility! ! -!Number methodsFor: 'arithmetic' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16879630! - - aNumber - "Answer the difference between the receiver and aNumber." - self subclassResponsibility! ! -!Number methodsFor: 'arithmetic' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16879635! - / aNumber - "Answer the result of dividing receiver by aNumber." - self subclassResponsibility! ! -!Number methodsFor: 'arithmetic' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16879678! - abs - "Answer a Number that is the absolute value (positive magnitude) of the receiver." - - self < 0 - ifTrue: [^self negated] - ifFalse: [^self]! ! -!Number methodsFor: 'arithmetic' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16879743! - negated - "Answer a Number that is the negation of the receiver." - ^0 - self! ! -!Number methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16879804! - @ y - "Answer a new Point whose x value is the receiver and whose y value is the - argument. Optional. No Lookup. See Object documentation whatIsAPrimitive." - - - ^Point x: self y: y! ! -!Number methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16879864! - asInteger - "Answer an integer nearest the receiver toward zero." - ^self truncated! ! -!Number methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16879876! - asPoint - "Answer a new Point with the receiver as both coordinates; - often used to supply the same value in two dimensions, as with - symmetrical gridding or scaling." - - ^self @ self! ! -!Number methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16879903! - degreesToRadians - "The receiver is assumed to represent degrees. Answer the - conversion to radians." - ^self asFloat degreesToRadians! ! -!Number methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16879939! - radiansToDegrees - "The receiver is assumed to represent radians. Answer the - conversion to degrees." - ^self asFloat radiansToDegrees! ! -!Number methodsFor: 'intervals' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16879959! - to: stop - "Answer an Interval from the receiver up to the argument, stop, - incrementing by 1." - - ^Interval from: self to: stop by: 1! ! -!Number methodsFor: 'intervals' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16879965! - to: stop by: step - "Answer an Interval from the receiver up to the argument, stop, - incrementing by step." - - ^Interval from: self to: stop by: step! ! -!Number methodsFor: 'mathematical functions' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16880099! - exp - "Answer the exponential of the receiver as a floating point number." - ^self asFloat exp! ! -!Number methodsFor: 'mathematical functions' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16880244! - squared - "Answer the receiver multipled by itself." - ^self * self! ! -!Number methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16880465! - odd - "Answer whether the receiver is an odd number." - ^self even == false! ! -!Number methodsFor: 'truncation and round off' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16880628! - truncated - "Answer an integer nearest the receiver toward zero." - ^self quo: 1! ! -!Float methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16844904 overrides: 50581785! - degreesToRadians - ^self * RadiansPerDegree! ! -!Float methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16844968 overrides: 50581792! - radiansToDegrees - ^self / RadiansPerDegree! ! -!Float class methodsFor: 'constants' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16845948! - pi - "Answer the constant, Pi." - ^Pi! ! -!Fraction methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16849619! - asFraction - "Answer with the receiver itself." - ^self! ! -!Fraction methodsFor: 'truncation and round off' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16849879 overrides: 50581831! - truncated - ^numerator quo: denominator! ! -!Fraction methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16849883! - denominator - ^denominator! ! -!Fraction methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16849885! - numerator - ^numerator! ! -!Fraction methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16849887! - reduced - | gcd numer denom | - numerator = 0 ifTrue: [^0]. - gcd _ numerator gcd: denominator. - numer _ numerator // gcd. - denom _ denominator // gcd. - denom = 1 ifTrue: [^numer]. - ^Fraction numerator: numer denominator: denom! ! -!Integer methodsFor: 'bit manipulation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16859110! - allMask: mask - "Treat the argument as a bit mask. Answer true if all of the - bits that are 1 in the argument are 1 in the receiver." - - ^mask = (self bitAnd: mask)! ! -!Integer methodsFor: 'bit manipulation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16859158! - anyMask: mask - "Treat the argument as a bit mask. Answer true if any of the - bits that are 1 in the argument are 1 in the receiver." - - ^0 ~= (self bitAnd: mask)! ! -!Integer methodsFor: 'bit manipulation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16859383! -noMask: mask - "Treat the argument as a bit mask. Answer true if none of the bits - that are 1 in the argument are 1 in the receiver." - - ^0 = (self bitAnd: mask)! ! -!Integer methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16859479! - asFraction - "Answer with a Fraction that represents the receiver." - - ^Fraction numerator: self denominator: 1! ! -!Integer methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16859488 overrides: 50581770! - asInteger - "Answer with the receiver itself." - - ^self! ! -!Integer methodsFor: 'enumerating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 50481639! - timesRepeat: aBlock - "Evaluate the argument, aBlock, the number of times represented by - the receiver." - - | count | - count _ 1. - [count <= self] - whileTrue: - [aBlock value. - count _ count + 1]! ! -!Integer methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16859936 overrides: 16882096! - isLiteral - ^true! ! -!Integer methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16860583! - growby: n - ^self growto: self digitLength + n! ! -!Integer methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16860586! - growto: n - ^self copyto: (self species new: n)! ! -!Integer class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16860824! - new: length neg: neg - "Answer an instance of a large integer whose size is length. neg is a flag determining - whether the integer is negative or not." - - neg - ifTrue: [^LargeNegativeInteger new: length] - ifFalse: [^LargePositiveInteger new: length]! ! -!LargeNegativeInteger methodsFor: 'arithmetic' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16862104 overrides: 50581156! - abs - ^self negated! ! -!LargeNegativeInteger methodsFor: 'arithmetic' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16862107 overrides: 16862369! - negated - ^self copyto: (LargePositiveInteger new: self digitLength)! ! -!SmallInteger methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16908840 overrides: 16860202! - even - ^(self bitAnd: 1) = 0! ! -!SmallInteger methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16908843 overrides: 50581825! - odd - ^(self bitAnd: 1) = 1! ! -!SmallInteger methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16908846 overrides: 16859391! - < aNumber - "Compare the receiver with the argument and answer with true if the receiver is less - than the argument. Otherwise answer false. Fail if the argument is not a - SmallInteger. Essential. No Lookup. See Object documentation whatIsAPrimitive." - - - ^super < aNumber! ! -!SmallInteger methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16908857 overrides: 16859402! - <= aNumber - "Compare the receiver with the argument and answer true if the receiver is less - than or equal to the argument. Otherwise answer false. Fail if the argument is - not a SmallInteger. Optional. No Lookup. See Object documentation - whatIsAPrimitive. " - - - ^super <= aNumber! ! -!SmallInteger methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16908868 overrides: 16859413! -= aNumber - "Compare the receiver with the argument and answer true if the receiver is - equal to the argument. Otherwise answer false. Fail if the argument is not a - SmallInteger. Essential. No Lookup. See Object documentation - whatIsAPrimitive. " - - - ^super = aNumber! ! -!SmallInteger methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16908879 overrides: 16859424! - > aNumber - "Compare the receiver with the argument and answer true if the receiver is - greater than the argument. Otherwise answer false. Fail if the argument is not a - SmallInteger. Essential. No Lookup. See Object documentation whatIsAPrimitive." - - - ^super > aNumber! ! -!SmallInteger methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16908890 overrides: 16859435! - >= aNumber - "Compare the receiver with the argument and answer true if the receiver is - greater than or equal to the argument. Otherwise answer false. Fail if the - argument is not a SmallInteger. Optional. No Lookup. See Object - documentation whatIsAPrimitive." - - - ^super >= aNumber! ! -!SmallInteger methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16908902 overrides: 16881037! - ~= aNumber - "Compare the receiver with the argument and answer true if the receiver is not - equal to the argument. Otherwise answer false. Fail if the argument is not a - SmallInteger. Essential. No Lookup. See Object documentation - whatIsAPrimitive. " - - - ^super ~= aNumber! ! -!LookupKey methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16865294! - key - "Answer the lookup key of the receiver." - ^key! ! -!LookupKey methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16865297! - key: anObject - "Store the argument, anObject, as the lookup key of the receiver." - key _ anObject! ! -!LookupKey methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16865307 overrides: 16865571! - < aLookupKey - ^key < aLookupKey key! ! -!LookupKey class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16865409! - key: aKey - "Answer a new instance of me with the argument as the lookup up." - ^self new key: aKey! ! -!Association methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16780908 overrides: 16881508! - value - "Answer the value of the receiver." - ^value! ! -!Association methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16780911! - value: anObject - "Store the argument, anObject, as the value of the receiver." - value _ anObject! ! -!Association class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16781010! - key: newKey value: newValue - "Answer a new instance of me with the arguments as the key and - value of the association." - ^(super key: newKey) value: newValue! ! -!MessageTally methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16870680 overrides: 16865571! - < aMessageTally - ^tally > aMessageTally tally! ! -!MessageTally methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16870693 overrides: 16865588! - > aMessageTally - ^tally < aMessageTally tally! ! -!MessageTally methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16870838! - class: aClass method: aMethod - class _ aClass. - method _ aMethod. - tally _ 0. - receivers _ Array new: 0! ! -!MessageTally methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16870849! - method - ^method! ! -!MessageTally methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16870851! - primitives: anInteger - tally _ anInteger. - receivers _ nil! ! -!MessageTally methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16870799! - tally - ^tally! ! -!Character methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16800477! - isAlphaNumeric - "Answer whether the receiver is a letter or a digit." - ^self isLetter or: [self isDigit]! ! -!Character methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16800581 overrides: 16882096! - isLiteral - ^true! ! -!Character methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16800583 overrides: 50508084! - printOn: aStream - aStream nextPut: $$. - aStream nextPut: self! ! -!Character methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16800587 overrides: 16882265! - storeOn: aStream - "Character literals are preceded by '$'." - aStream nextPut: $$; nextPut: self! ! -!Character methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16800592! - asCharacter - "Answer the receiver itself." - ^self! ! -!Character class methodsFor: 'constants' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16801187! - characterTable - "Answer the class variable in which unique Characters are stored." - ^CharacterTable! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4693-ST-80-timestamps-JuanVuletich-2021Jul26-09h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4690] on 25 July 2021 at 8:28:11 pm'! -!LargePositiveInteger methodsFor: 'system primitives' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16862772! - digitAt: index put: value - "Store the second argument (value) in the indexable field of the receiver - indicated by index. Fail if the value is negative or is larger than 255. Fail if the - index is not an Integer or is out of bounds. Answer with the value that was - stored. Essential. See Object documentation whatIsAPrimitive." - - - ^super at: index put: value! ! -!LargePositiveInteger methodsFor: 'system primitives' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16862786! - digitLength - "Answer with the number of indexable fields in the receiver. This value is the - same as the largest legal subscript. Essential. See Object documentation - whatIsAPrimitive." - - - self primitiveFailed! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4694-ST-80-timestamps-JuanVuletich-2021Jul25-20h22m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4690] on 25 July 2021 at 8:34:18 pm'! -!LargePositiveInteger commentStamp: 'jmv 7/25/2021 20:34:03' prior: 16862260! - I represent positive integers beyond the range of SmallInteger. They and are encoded here as an array of 8-bit digits. Care must be taken, when new values are computed, that any result that COULD BE a SmallInteger MUST BE a SmallInteger (see normalize). - -Note that the bit manipulation primitives, bitAnd:, bitShift:, etc., = and ~= run without failure (and therefore fast) if the value fits in 32 bits. This is a great help to the simulator.! -!LargePositiveInteger methodsFor: 'arithmetic' stamp: 'jmv 7/25/2021 20:29:54' prior: 16862278 overrides: 16858857! - * anInteger - "Primitive is optional. - See Object class >> #whatIsAPrimitive. " - - - ^super * anInteger.! ! -!LargePositiveInteger methodsFor: 'arithmetic' stamp: 'jmv 7/25/2021 20:30:04' prior: 16862290 overrides: 16858866! - + anInteger - "Primitive is optional. - See Object class >> #whatIsAPrimitive. " - - - ^super + anInteger.! ! -!LargePositiveInteger methodsFor: 'arithmetic' stamp: 'jmv 7/25/2021 20:30:14' prior: 16862302 overrides: 16858876! - - anInteger - "Primitive is optional. - See Object class >> #whatIsAPrimitive. " - - - ^super - anInteger.! ! -!LargePositiveInteger methodsFor: 'arithmetic' stamp: 'jmv 7/25/2021 20:30:39' prior: 16862314 overrides: 16858886! - / anInteger - "Primitive is optional. - See Object class >> #whatIsAPrimitive. " - - - ^super / anInteger.! ! -!LargePositiveInteger methodsFor: 'arithmetic' stamp: 'jmv 7/25/2021 20:30:54' prior: 16862329 overrides: 50468201! - // anInteger - "Primitive is optional. - See Object class >> #whatIsAPrimitive. " - - - ^super // anInteger.! ! -!LargePositiveInteger methodsFor: 'arithmetic' stamp: 'jmv 7/25/2021 20:32:41' prior: 16862344 overrides: 50510860! - \\ anInteger - "Primitive is optional. - See Object class >> #whatIsAPrimitive. " - - - ^super \\ anInteger.! ! -!LargePositiveInteger methodsFor: 'arithmetic' stamp: 'jmv 7/25/2021 20:32:54' prior: 16862375 overrides: 16858942! - quo: anInteger - "Primitive is optional. - See Object class >> #whatIsAPrimitive. " - - - ^super quo: anInteger.! ! -!LargePositiveInteger methodsFor: 'comparing' stamp: 'jmv 7/25/2021 20:31:02' prior: 16862460 overrides: 16859391! - < anInteger - "Primitive is optional. - See Object class >> #whatIsAPrimitive. " - - - ^super < anInteger.! ! -!LargePositiveInteger methodsFor: 'comparing' stamp: 'jmv 7/25/2021 20:31:21' prior: 16862473 overrides: 16859402! - <= anInteger - "Primitive is optional. - See Object class >> #whatIsAPrimitive. " - - - ^super <= anInteger.! ! -!LargePositiveInteger methodsFor: 'comparing' stamp: 'jmv 7/25/2021 20:31:57' prior: 16862486 overrides: 16859424! - > anInteger - "Primitive is optional. - See Object class >> #whatIsAPrimitive. " - - - ^super > anInteger.! ! -!LargePositiveInteger methodsFor: 'comparing' stamp: 'jmv 7/25/2021 20:32:06' prior: 16862499 overrides: 16859435! - >= anInteger - "Primitive is optional. - See Object class >> #whatIsAPrimitive. " - - - ^super >= anInteger.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4695-LargeInteger-fixComments-JuanVuletich-2021Jul25-20h28m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4695] on 26 July 2021 at 9:13:32 am'! -!Object methodsFor: 'updating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16881286! - changed - "Receiver changed in a general way; inform all the dependents by sending - each dependent an update: message." - - self changed: self! ! -!Object methodsFor: 'updating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16881312! - update: aParameter - "Receive a change notice from an object of whom the receiver is a dependent. - The default behavior is to do nothing; a subclass might want to change - itself in some way." - - ^self! ! -!FileList methodsFor: 'file name list' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16842398! - fileName - ^ fileName! ! -!Inspector methodsFor: 'doIt/accept/explain' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857076! - doItReceiver - "Answer the object that should be informed of the result of evaluating a - text selection." - ^object! ! -!Behavior methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16782773! - format - "Answer an Integer that encodes the kinds and numbers of variables of instances - of the receiver." - - ^format! ! -!Behavior methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16783243 overrides: 50508084! - printOn: aStream - aStream nextPutAll: 'a descendent of '. - superclass printOn: aStream! ! -!Behavior methodsFor: 'compiling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16782761! - compilerClass - "Return a compiler class appropriate for source methods of this class." - - ^Compiler! ! -!Behavior methodsFor: 'compiling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16783339! - decompile: selector - "Find the compiled code associated with the argument, selector, as a message selector - in the receiver's method dictionary and decompile it. Answer the resulting source - code as a string. Create an error if the selector is not in the receiver's method - dictionary." - - ^self decompilerClass new decompile: selector in: self! ! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16784142! - classVarNames - "Answer a Set of the receiver's class variable names. Since the receiver does - not retain knowledge of class variables, the method fakes it by creating an empty set." - - ^Set new! ! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16784233! - instanceCount - "Answer the number of instances of the receiver that are currently in use." - - | count | - count _ 0. - self allInstancesDo: [:x | count _ count + 1]. - ^count! ! -!Behavior methodsFor: 'creating method dictionary' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16783851! - methodDictionary: aDictionary - "Store the argument, aDictionary, as the method dictionary of the receiver." - - methodDict _ aDictionary! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4696-ST-80-timestamps-JuanVuletich-2021Jul26-09h11m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4695] on 26 July 2021 at 9:18:13 am'! -!Date class methodsFor: 'general inquiries' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16828497! - dateAndTimeNow - "Answer an array with first element Date today and second element Time now." - - ^Time dateAndTimeNow! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857689 overrides: 16857466! - blockReturnTop - "Print the ReturnTopOfStack bytecode." - self print: 'blockReturn'! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857701 overrides: 16857486! - doDup - "Print the Duplicate Top of Stack bytecode." - self print: 'dup'! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857706 overrides: 16857491! - doPop - "Print the Remove Top of Stack bytecode." - self print: 'pop'! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857732 overrides: 16857505! - methodReturnConstant: value - "Print the Return Constant bytecode." - self print: 'return: ' , value printString! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857738 overrides: 16857510! - methodReturnReceiver - "Print the Return Self bytecode." - self print: 'returnSelf'! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857743 overrides: 16857515! - methodReturnTop - "Print the Return Top of Stack bytecode." - self print: 'returnTop'! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857748 overrides: 16857520! - popIntoLiteralVariable: anAssociation - "Print the Removes the Top of the Stack and Stores it into a Literal Variable - bytecode." - self print: 'popIntoLit: ' , anAssociation key! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857755 overrides: 16857526! - popIntoReceiverVariable: offset - "Print the Removes the Top of the Stack and Stores it into an Instance Variable - bytecode." - self print: 'popIntoRcvr: ' , offset printString! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857771 overrides: 16857539! - popIntoTemporaryVariable: offset - "Print the Removes the Top of the Stack and Stores it into a Temporary Variable - bytecode." - self print: 'popIntoTemp: ' , offset printString! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857778 overrides: 16857545! - pushActiveContext - "Print the Push the Active Context on the Top of its Own Stack bytecode." - self print: 'pushThisContext: '! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857825 overrides: 16857571! - pushLiteralVariable: anAssociation - "Print the Push the Contents of anAssociation on the Top of the Stack bytecode." - self print: 'pushLit: ' , anAssociation key! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857838 overrides: 16857583! - pushReceiver - "Print the Push the Active Context's Receiver on the Top of the Stack bytecode." - self print: 'self'! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857844 overrides: 16857588! - pushReceiverVariable: offset - "Print the Push the Contents of the Receiver's Instance Variable whose Index - is the argument, offset, on the Top of the Stack bytecode." - self print: 'pushRcvr: ' , offset printString! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857861 overrides: 16857603! - pushTemporaryVariable: offset - "Print the Push the Contents of the Temporary Variable whose Index is the - argument, offset, on the Top of the Stack bytecode." - self print: 'pushTemp: ' , offset printString! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857888 overrides: 16857624! - storeIntoLiteralVariable: anAssociation - "Print the Store the Top of the Stack into a Literal Variable of the Method bytecode." - self print: 'storeIntoLit: ' , anAssociation key! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857896 overrides: 16857630! - storeIntoReceiverVariable: offset - "Print the Store the Top of the Stack into an Instance Variable of the Method - bytecode." - self print: 'storeIntoRcvr: ' , offset printString! ! -!InstructionPrinter methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16857912 overrides: 16857643! - storeIntoTemporaryVariable: offset - "Print the Store the Top of the Stack into a Temporary Variable of the Method - bytecode." - self print: 'storeIntoTemp: ' , offset printString! ! -!InstructionStream methodsFor: 'scanning' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16858191! - followingByte - "Answer the following bytecode." - ^self method at: pc + 1! ! -!InstructionStream methodsFor: 'scanning' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16858223! - nextByte - "Answer the next bytecode." - ^self method at: pc! ! -!InstructionStream methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16858417! - method: method pc: startpc - sender _ method. - "allows this class to stand alone as a method scanner" - pc _ startpc! ! -!InstructionStream class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16858774! - on: method - "Answer a new InstructionStream on the argument, method." - - ^self new method: method pc: method initialPC! ! -!ContextPart methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16823703! - doDup - "Simulates the action of a 'duplicate top of stack' bytecode." - - self push: self top! ! -!ContextPart methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16823708! - doPop - "Simulates the action of a 'remove top of stack' bytecode." - - self pop! ! -!ContextPart methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16823713! - jump: distance - "Simulates the action of a 'unconditional jump' bytecode whose - offset is the argument, distance." - - pc _ pc + distance! ! -!ContextPart methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16823805! - pushActiveContext - "Simulates the action of bytecode that pushes the the active - context on the top of its own stack." - - self push: self! ! -!ContextPart methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16823831! - pushConstant: value - "Simulates the action of bytecode that pushes the constant, value, on - the top of the stack." - - self push: value! ! -!ContextPart methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16823853! - pushReceiver - "Simulates the action of bytecode that pushes the the active - context's receiver on the top of the stack." - - self push: self receiver! ! -!ContextPart methodsFor: 'debugger access' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16823986! - depthBelow: aContext - "Answer how many calls between this and aContext." - | this depth | - this _ self. - depth _ 0. - [this == aContext or: [this == nil]] - whileFalse: - [this _ this sender. - depth _ depth + 1]. - ^depth! ! -!ContextPart methodsFor: 'debugger access' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16824230! - hasSender: context - "Answer true if the receiver is strictly above context on the stack." - - | s | - self == context ifTrue: [^false]. - s _ sender. - [s == nil] - whileFalse: - [s == context ifTrue: [^true]. - s _ s sender]. - ^false! ! -!ContextPart methodsFor: 'debugger access' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16824097! - releaseTo: caller - "Remove information from the receiver and the contexts on its - sender chain up to caller in order to break circularities." - - | c s | - c _ self. - [c == nil or: [c == caller]] - whileFalse: - [s _ c sender. - c singleRelease. - c _ s]! ! -!ContextPart methodsFor: 'debugger access' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16824150! - stack - "Answer an array of the contexts on the receiver's sender chain." - ^self stackOfSize: 9999! ! -!ContextPart methodsFor: 'debugger access' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16824167! - swapSender: coroutine - "Replace the receiver's sender with coroutine and answer the receiver's previous sender. - For use in coroutining." - - | oldSender | - oldSender _ sender. - sender _ coroutine. - ^oldSender! ! -!ContextPart methodsFor: 'system simulation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16824662! - step - "Simulate the execution of the receiver's next bytecode. - Answer the context that would be the active context - after this bytecode." - - ^self interpretNextInstructionFor: self! ! -!ContextPart methodsFor: 'temporaries' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16823690! - tempAt: index - "Answer the value of the temporary variable whose index is the argument, index." - self subclassResponsibility! ! -!ContextPart methodsFor: 'temporaries' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16823696! - tempAt: index put: value - "Store the argument, value, as the temporary variable whose - index is the argument, index." - self subclassResponsibility! ! -!ContextPart class methodsFor: 'examples' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16825445! - runSimulated: aBlock - "The simulator is a group of methods in class ContextPart which do what the - Smalltalk interpreter does. They execute Smalltalk bytecodes. By adding code - to the simulator, you could take statistics on the running of Smalltalk methods. - See also trace: callStatistics: and instructionStatistics: for sample uses" - - ^ thisContext sender - runSimulated: aBlock - contextAtEachStep: [:ignored] - - "ContextPart runSimulated: [Pen new defaultNib: 5; go: 100]"! ! -!MethodContext methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16871511 overrides: 16823656! - method - ^method! ! -!MethodContext methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16871528 overrides: 50581192! -receiver - ^receiver! ! -!MethodContext methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16871532! - removeSelf - "Nil the receiver pointer and answer the former value." - - | tempSelf | - tempSelf _ receiver. - receiver _ nil. - ^tempSelf! ! -!Decompiler methodsFor: 'control' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16831545! - statementsTo: end - | blockPos stackPos t | - "Decompile the method from pc up to end and return an array of - expressions. If at run time this block will leave a value on - the stack, set hasValue to true. If the block ends with a jump or return, - set exit to the destination of the jump, or the end of the method; - otherwise, set exit = end. Leave pc = end." - blockPos _ statements size. - stackPos _ stack size. - [pc < end] - whileTrue: - [lastPc _ pc. limit _ end. "for performs" - self interpretNextInstructionFor: self]. - "If there is an additional item on the stack, it will be the value - of this block." - (hasValue _ stack size > stackPos) - ifTrue: - [statements addLast: stack removeLast]. - lastJumpPc = lastPc ifFalse: [exit _ pc]. - ^self popTo: blockPos! ! -!Decompiler methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16831782! - methodReturnConstant: value - self pushConstant: value; methodReturnTop! ! -!Decompiler methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16831786! - methodReturnReceiver - self pushReceiver; methodReturnTop! ! -!Decompiler methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16831802! - popIntoLiteralVariable: value - self pushLiteralVariable: value; doStore: statements! ! -!Decompiler methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16831807! - popIntoReceiverVariable: offset - self pushReceiverVariable: offset; doStore: statements! ! -!Decompiler methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16831864! - pushActiveContext - stack addLast: constructor codeThisContext! ! -!Decompiler methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16831889! - pushConstant: value - | node | - node _ value == true ifTrue: [constTable at: 2] - ifFalse: [value == false ifTrue: [constTable at: 3] - ifFalse: [value == nil ifTrue: [constTable at: 4] - ifFalse: [constructor codeAnyLiteral: value]]]. - stack addLast: node! ! -!Decompiler methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16831899! - pushLiteralVariable: assoc - stack addLast: (constructor codeAnyLitInd: assoc)! ! -!Decompiler methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16831910! - pushReceiver - stack addLast: (constTable at: 1)! ! -!Decompiler methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16832012! - storeIntoLiteralVariable: assoc - self pushLiteralVariable: assoc; doStore: stack! ! -!Decompiler methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16832017! - storeIntoReceiverVariable: offset - self pushReceiverVariable: offset; doStore: stack! ! -!Decompiler methodsFor: 'instruction decoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16832030! - storeIntoTemporaryVariable: offset - self pushTemporaryVariable: offset; doStore: stack! ! -!Decompiler methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16832154! - popTo: oldPos - | t | - t _ Array new: statements size - oldPos. - (t size to: 1 by: -1) do: - [:i | t at: i put: statements removeLast]. - ^t! ! -!Message methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16867355! - arguments - "Answer the arguments of the receiver." - ^args! ! -!Message methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16867366! - selector - "Answer the selector of the receiver." - ^selector! ! -!Message methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16867403! - setSelector: aSymbol arguments: anArray - selector _ aSymbol. - args _ anArray! ! -!Message class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16867476! - selector: aSymbol argument: anObject - "Answer an instance of me whose selector is aSymbol and single argument - is anObject." - - ^self new setSelector: aSymbol arguments: (Array with: anObject)! ! -!Message class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16867484! - selector: aSymbol arguments: anArray - "Answer an instance of me with selector, aSymbol, and arguments, - anArray." - - ^self new setSelector: aSymbol arguments: anArray! ! -!Delay methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16832768! - resumptionTime - "Answer the value of the system's millisecondClock at which the receiver's - suspended Process will resume." - - ^resumptionTime! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4697-ST-80-timestamps-JuanVuletich-2021Jul26-09h13m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4695] on 26 July 2021 at 9:24:54 am'! -!InputSensor methodsFor: 'mouse' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16856457! - mousePoint - "Answer a Point indicating the coordinates of the current mouse location." - ^self primMousePt! ! -!InputSensor methodsFor: 'mouse' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16856505! -waitClickButton - "Wait for the user to click (press and then release) any mouse button and then - answer with the current location of the cursor." - self waitButton. - ^self waitNoButton! ! -!ProcessorScheduler methodsFor: 'removing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16895673! - remove: aProcess ifAbsent: aBlock - "Remove aProcess from the list on which it is waiting for the processor. If - it is not waiting, evaluate aBlock." - - (quiescentProcessLists at: aProcess priority) - remove: aProcess ifAbsent: aBlock. - ^aProcess! ! -!ProcessorScheduler methodsFor: 'process state change' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16895692! - suspendFirstAt: aPriority ifNone: noneBlock - "Suspend the first Process that is waiting to run with priority aPriority. - If no Process is waiting, evaluate noneBlock" - - | aList | - aList _ quiescentProcessLists at: aPriority. - aList isEmpty - ifTrue: [^noneBlock value] - ifFalse: [^aList first suspend]! ! -!Collection methodsFor: 'adding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16813962! - add: newObject - "Include newObject as one of the receiver's elements. Answer newObject. - This message should not be sent to instances of subclasses of ArrayedCollection." - - self subclassResponsibility! ! -!Collection methodsFor: 'adding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16813977! - addAll: aCollection - "Include all the elements of aCollection as the receiver's elements. Answer - aCollection." - - aCollection do: [:each | self add: each]. - ^aCollection! ! -!Collection methodsFor: 'enumerating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16814191! - collect: aBlock - "Evaluate aBlock with each of the receiver's elements as the argument. Collect the - resulting values into a collection that is like the receiver. Answer the new - collection. " - - | newCollection | - newCollection _ self species new. - self do: [:each | newCollection add: (aBlock value: each)]. - ^newCollection! ! -!Collection methodsFor: 'enumerating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16814267! - 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." - - self do: [:each | (aBlock value: each) ifTrue: [^each]]. - ^exceptionBlock value! ! -!Collection methodsFor: 'enumerating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16814413! - inject: thisValue into: binaryBlock - "Accumulate a running value associated with evaluating the argument, - binaryBlock, with the current value and the receiver as block arguments. - The initial value is the value of the argument, thisValue. - For instance, to sum a collection, use: - collection inject: 0 into: [:subTotal :next | subTotal + next]." - - | nextValue | - nextValue _ thisValue. - self do: [:each | nextValue _ binaryBlock value: nextValue value: each]. - ^nextValue! ! -!Collection methodsFor: 'enumerating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16814457! - 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]! ! -!Collection methodsFor: 'enumerating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16814468! - 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! ! -!Collection methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16814619 overrides: 16882265! -storeOn: aStream - | 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: $)! ! -!Collection methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16814634! - emptyCheck - self isEmpty ifTrue: [self errorEmptyCollection]! ! -!Collection methodsFor: 'removing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16814694! - remove: oldObject ifAbsent: anExceptionBlock - "Remove oldObject as one of the receiver's elements. If several of the - elements are equal to oldObject, only one is removed. If no element is equal to - oldObject, answer the result of evaluating anExceptionBlock. Otherwise, - answer the argument, oldObject. - - SequenceableCollections can not respond to this message." - - self subclassResponsibility! ! -!Collection methodsFor: 'removing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16814709! - removeAll: aCollection - "Remove each element of aCollection from the receiver. If successful for each, - answer aCollection." - - aCollection do: [:each | self remove: each]. - ^aCollection! ! -!SequenceableCollection methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16905706! - indexOf: anElement - "Answer the index of anElement within the receiver. If the receiver does - not contain anElement, answer 0." - - ^self indexOf: anElement ifAbsent: [0]! ! -!SequenceableCollection methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16905758! - 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]! ! -!SequenceableCollection methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16905930! - 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! ! -!SequenceableCollection methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16905945! - 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 collection, replacement. Answer the - receiver. No range checks are performed - this may be primitively implemented." - - | index repOff | - repOff _ repStart - start. - index _ start - 1. - [(index _ index + 1) <= stop] - whileTrue: [self at: index put: (replacement at: repOff + index)]! ! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16906725! - 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 in do:." - - self size to: 1 by: -1 do: [:index | aBlock value: (self at: index)]! ! -!SequenceableCollection methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16906931! -errorOutOfBounds - self error: 'indices are out of bounds'! ! -!ArrayedCollection methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16780261 overrides: 50581278! - size - "Answer the number of indexable fields in the receiver. This value is the - same as the largest legal subscript. Primitive is specified here to override - SequenceableCollection size. Essential. See Object documentation - whatIsAPrimitive. " - - - ^self basicSize! ! -!ArrayedCollection methodsFor: 'adding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16780272 overrides: 50582943! - add: newObject - self shouldNotImplement! ! -!ArrayedCollection methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16780275 overrides: 50583032! - storeOn: aStream - aStream nextPutAll: '(('. - aStream nextPutAll: self class name. - aStream nextPutAll: ' new: '. - aStream store: self size. - aStream nextPut: $). - (self storeElementsFrom: 1 to: self size on: aStream) - ifFalse: [aStream nextPutAll: '; yourself']. - aStream nextPut: $)! ! -!ArrayedCollection methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16780286! - defaultElement - ^nil! ! -!ArrayedCollection methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16780289! - storeElementsFrom: firstIndex to: lastIndex on: aStream - | noneYet defaultElement arrayElement | - noneYet _ true. - defaultElement _ self defaultElement. - firstIndex to: lastIndex do: - [:index | - arrayElement _ self at: index. - arrayElement = defaultElement - ifFalse: - [noneYet - ifTrue: [noneYet _ false] - ifFalse: [aStream nextPut: $;]. - aStream nextPutAll: ' at: '. - aStream store: index. - aStream nextPutAll: ' put: '. - aStream store: arrayElement]]. - ^noneYet! ! -!ArrayedCollection class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16780595! - new: size withAll: value - "Answer a new instance of me, whose every element is equal to the argument, - value." - - ^(self new: size) atAllPut: value! ! -!ArrayedCollection class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16780657 overrides: 16815127! - with: firstObject with: secondObject with: thirdObject - "Answer a new instance of me, containing only these three objects." - - | newCollection | - newCollection _ self new: 3. - newCollection at: 1 put: firstObject. - newCollection at: 2 put: secondObject. - newCollection at: 3 put: thirdObject. - ^newCollection! ! -!ArrayedCollection class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16780669 overrides: 16815137! - with: firstObject with: secondObject with: thirdObject with: fourthObject - "Answer a new instance of me, containing the four arguments as the 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! ! -!String methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16915802! - string - "Answer the receiver itself. This is for compatibility with other text classes." - ^self! ! -!String methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16916420 overrides: 16881101! - asString - "Answer the receiver itself." - ^self! ! -!String methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16916423! - asSymbol - "Answer the unique symbol whose characters are the characters of the string." - ^Symbol intern: self! ! -!String methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16916428! - asText - "Answer a Text whose string is the receiver." - ^Text fromString: self! ! -!String methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16917109 overrides: 16882096! - isLiteral - ^true! ! -!String class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16917898 overrides: 16882927! - readFrom: inStream - "Answer a new String that is determined by reading the stream, inStream. Embedded - double quotes become the quote Character." - - | outStream char done | - outStream _ WriteStream on: (String new: 16). - "go to first quote" - inStream skipTo: $'. - done _ false. - [done or: [inStream atEnd]] - whileFalse: - [char _ inStream next. - char = $' - ifTrue: - [char _ inStream next. - char = $' - ifTrue: [outStream nextPut: char] - ifFalse: [done _ true]] - ifFalse: [outStream nextPut: char]]. - ^outStream contents! ! -!Symbol methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16918436 overrides: 50463986! - at: anInteger put: anObject - "you can not modify the receiver." - - self errorNoModification! ! -!Symbol methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16918457 overrides: 50335638! - replaceFrom: start to: stop with: replacement startingAt: repStart - self errorNoModification! ! -!Symbol methodsFor: 'copying' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16918471 overrides: 16881231! - shallowCopy - "Answer with me, because Symbols are unique."! ! -!Symbol methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16918475 overrides: 50583256! - asString - | newString | - newString _ String new: self size. - 1 to: self size do: [:index | newString at: index put: (self at: index)]. - ^newString! ! -!Symbol methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16918483 overrides: 50583261! - asSymbol! ! -!Symbol methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16918536! - errorNoModification - self error: 'symbols can not be modified.'! ! -!Symbol methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16918540 overrides: 50463965! - species - ^String! ! -!Symbol methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16918542! - string: aString - 1 to: aString size do: [:j | super at: j put: (aString at: j)]. - ^self! ! -!ByteArray methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16793798 overrides: 50583188! - defaultElement - ^0! ! -!CompiledMethod methodsFor: 'literals' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16820061! - header - "Answer the word containing the information about the form of the - receiver and the form of the context needed to run the receiver." - - ^self objectAt: 1! ! -!CompiledMethod methodsFor: 'literals' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16820107! - literalAt: index put: value - "Replace the literal indexed by the first argument with the - second argument." - - ^self objectAt: index + 1 put: value! ! -!CompiledMethod methodsFor: 'literals' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16820144! - objectAt: index - "Answer with the method header (if index=1) or a literal (if index >1) from the - receiver. Essential. See Object documentation whatIsAPrimitive." - - - self primitiveFailed! ! -!CompiledMethod methodsFor: 'literals' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16820153! - objectAt: index put: value - "Store the value argument into a literal in the receiver. An index of 2 - corresponds to the first literal. Fails if the index is less than 2 or greater than - the number of literals. Answer the value as the result. Normally only the - compiler sends this message, because only the compiler stores values in - CompiledMethods. Essential. See Object documentation whatIsAPrimitive." - - - self primitiveFailed! ! -!CompiledMethod methodsFor: 'scanning' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16820284! - scanLongLoad: extension - "Answer whether the receiver contains a long load whose extension is the - argument." - - | scanner | - scanner _ InstructionStream on: self. - ^scanner scanFor: [:instr | instr = 128 and: [scanner followingByte = extension]]! ! -!Interval methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16861181 overrides: 16905641! - first - ^start! ! -!Interval methodsFor: 'adding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16861226 overrides: 50582943! - add: newObject - "Adding to an Interval is not allowed." - self shouldNotImplement! ! -!Interval methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16861269 overrides: 50583032! - storeOn: aStream - "This is possible because we know numbers store and print the same" - - self printOn: aStream! ! -!Interval methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16861285 overrides: 50463965! - species - ^Array! ! -!LinkedList methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16864798 overrides: 16905641! - first - "Answer the first link; create an error if the receiver is empty." - - self emptyCheck. - ^firstLink! ! -!LinkedList methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16864804 overrides: 16905811! - last - "Answer the last link; create an error if the receiver is empty." - - self emptyCheck. - ^lastLink! ! -!LinkedList methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16864809 overrides: 16814924! - isEmpty - ^firstLink == nil! ! -!LinkedList methodsFor: 'adding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16864812 overrides: 50582943! - add: aLink - "Add aLink to the end of the receiver's list." - - ^self addLast: aLink! ! -!LinkedList methodsFor: 'adding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16864830! - addFirst: aLink - "Add aLink to the beginning of the receiver's list." - - self isEmpty ifTrue: [lastLink _ aLink]. - aLink nextLink: firstLink. - firstLink _ aLink. - ^aLink! ! -!LinkedList methodsFor: 'adding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16864837! -addLast: aLink - "Add aLink to the end of the receiver's list." - - self isEmpty - ifTrue: [firstLink _ aLink] - ifFalse: [lastLink nextLink: aLink]. - lastLink _ aLink. - ^aLink! ! -!LinkedList methodsFor: 'removing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16864865! - removeFirst - "Remove the first element. If the receiver is empty, cause an error; - otherwise answer the removed element. Using the sequence addFirst:/removeFirst - causes the receiver to behave as a stack; using addLast:/removeFirst causes the - receiver to behave as a queue." - - | oldLink | - self emptyCheck. - oldLink _ firstLink. - firstLink == lastLink - ifTrue: [firstLink _ nil. lastLink _ nil] - ifFalse: [firstLink _ oldLink nextLink]. - oldLink nextLink: nil. - ^oldLink! ! -!LinkedList methodsFor: 'removing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16864876! - removeLast - "Remove the receiver's last element. If the receiver is empty, cause an error; - otherwise answer the removed element. Using addLast:/removeLast causes the - receiver to behave as a stack; using addFirst:/removeLast causes the receiver to - behave as a queue." - - | 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! ! -!LinkedList methodsFor: 'enumerating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16864892 overrides: 16906383! - do: aBlock - | aLink | - aLink _ firstLink. - [aLink == nil] whileFalse: - [aBlock value: aLink. - aLink _ aLink nextLink]! ! -!Semaphore methodsFor: 'communication' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16905087! - signal - "Send a signal through the receiver. If one or more processes have been - suspended trying to receive a signal, allow the first one to proceed. If no - process is waiting, remember the excess signal. Essential. See Object documentation - whatIsAPrimitive. " - - - self primitiveFailed - - "self isEmpty - ifTrue: [excessSignals _ excessSignals+1] - ifFalse: [Processor resume: self removeFirstLink]"! ! -!Semaphore methodsFor: 'communication' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16905103! - wait - "The active Process must receive a signal through the receiver before - proceeding. If no signal has been sent, the active Process will be suspended - until one is sent. Essential. See - Object whatIsAPrimitive." - - - self primitiveFailed - - "excessSignals>0 - ifTrue: [excessSignals _ excessSignals-1] - ifFalse: [self addLastLink: Processor activeProcess suspend]"! ! -!Semaphore methodsFor: 'initialize-release' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16905258! - initSignals - "Consume any excess signals the receiver may have accumulated." - - excessSignals _ 0! ! -!Semaphore class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16905275! - forMutualExclusion - "Answer a new instance of me that contains a single signal. - This new instance can now be used for mutual exclusion (see the - critical: message to Semaphore)." - - ^self new signal! ! -!OrderedCollection methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16883785 overrides: 50581278! - size - ^lastIndex - firstIndex + 1! ! -!OrderedCollection methodsFor: 'adding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16883788 overrides: 50582943! - add: newObject - ^self addLast: newObject! ! -!OrderedCollection methodsFor: 'adding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16883791! - add: newObject after: oldObject - "Add the argument, newObject, as an element of the receiver. Put it - in the position just succeeding oldObject. Answer newObject." - - | index | - index _ self find: oldObject. - self insert: newObject before: index + 1. - ^newObject! ! -!OrderedCollection methodsFor: 'adding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16883813! - add: newObject before: oldObject - "Add the argument, newObject, as an element of the receiver. Put it - in the position just preceding oldObject. Answer newObject." - - | index | - index _ self find: oldObject. - self insert: newObject before: index. - ^newObject! ! -!OrderedCollection methodsFor: 'adding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16883836! - addAllFirst: anOrderedCollection - "Add each element of anOrderedCollection at the beginning of the receiver. - Answer anOrderedCollection." - - anOrderedCollection reverseDo: [:each | self addFirst: each]. - ^anOrderedCollection! ! -!OrderedCollection methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16884171! - errorNoSuchElement - self error: 'attempt to index non-existent element in an ordered collection'! ! -!OrderedCollection class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16884315 overrides: 16783533! - new - ^self new: 10! ! -!RunArray methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16901467! - values - "Answer the values in the receiver." - ^values! ! -!RunArray methodsFor: 'copying' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16901359 overrides: 50332597! - copyReplaceFrom: start to: stop with: replacement - ^(self copyFrom: 1 to: start - 1) - , replacement - , (self copyFrom: stop + 1 to: self size)! ! -!RunArray methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16901372 overrides: 50583032! - storeOn: aStream - aStream nextPut: $(. - aStream nextPutAll: self class name. - aStream nextPutAll: ' runs: '. - runs storeOn: aStream. - aStream nextPutAll: ' values: '. - values storeOn: aStream. - aStream nextPut: $)! ! -!RunArray methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16901458! - runs - ^runs! ! -!RunArray class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16901509 overrides: 16783533! - new - ^self runs: Array new values: Array new! ! -!RunArray class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16901513! - 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)! ! -!RunArray class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16901549! - runs: newRuns values: newValues - "Answer a new instance of RunArray with runs and values specified - by the arguments." - - | instance | - instance _ self basicNew. - instance setRuns: newRuns setValues: newValues. - ^instance! ! -!Text methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16928921 overrides: 16880774! - at: index - ^string at: index! ! -!Text methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16928966! - findString: aString startingAt: start - "Answer the index of subString within the receiver, starting at position start. - If the receiver does not contain subString, answer 0." - - ^string findString: aString asString startingAt: start! ! -!Text methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16929024 overrides: 50581278! - size - ^string size! ! -!Text methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16929026! - string - "Answer the string representation of the receiver." - ^string! ! -!Text methodsFor: 'copying' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16929088 overrides: 16906162! - copyFrom: start to: stop - "Answer with a copied subrange of this text" - - | 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)! ! -!Text methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16929127! - asNumber - "Answer the number created by interpreting the receiver as the textual - representation of a number." - - ^string asNumber! ! -!Text methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16929133 overrides: 16881101! - asString - "Answer a String representation of the textual receiver." - ^string! ! -!Text methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16929137! - asText - "Answer the receiver itself." - ^self! ! -!Text methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16929554 overrides: 50583032! - storeOn: aStream - aStream nextPutAll: '(Text string: '; - store: string; - nextPutAll: ' runs: '; - store: runs; - nextPut: $)! ! -!Text methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16929649! - runs - ^runs! ! -!Text class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16929843 overrides: 16783541! - new: stringSize - ^self fromString: (String new: stringSize)! ! -!Text class methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16929918! - string: aString runs: anArray - ^self basicNew setString: aString setRuns: anArray! ! -!Bag methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16782029 overrides: 16880774! - at: index - self errorNotKeyed! ! -!Bag methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16782032 overrides: 16880792! - at: index put: anObject - self errorNotKeyed! ! -!Bag methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16782050! - sortedCounts - "Answer with a collection of counts with elements, sorted by decreasing count." - | counts | - counts _ SortedCollection sortBlock: [:x :y | x >= y]. - contents associationsDo: - [:assn | - counts add: (Association key: assn value value: assn key)]. - ^ counts! ! -!Bag methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16782060! - sortedElements - "Answer with a collection of elements with counts, sorted by element." - | elements | - elements _ SortedCollection new. - contents associationsDo: [:assn | elements add: assn]. - ^ elements! ! -!Bag methodsFor: 'adding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16782068 overrides: 50582943! - add: newObject - ^self add: newObject withOccurrences: 1! ! -!Bag methodsFor: 'enumerating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16782111 overrides: 50581285! - do: aBlock - contents associationsDo: [:assoc | assoc value timesRepeat: [aBlock value: assoc key]]! ! -!Bag methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16782146 overrides: 16814878! - includes: anObject - ^contents includesKey: anObject! ! -!Bag methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16782155 overrides: 50581292! - occurrencesOf: anObject - (self includes: anObject) - ifTrue: [^contents at: anObject] - ifFalse: [^0]! ! -!Set methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16907135 overrides: 50581278! - size - ^tally! ! -!Dictionary methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16833284! - associationAt: key - "Answer the association at key. If key is not found, create an error message." - - ^self associationAt: key ifAbsent: [self errorKeyNotFound]! ! -!Dictionary methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16833307 overrides: 16880774! - at: key - "Answer the value at key. If key is not found, create an error message." - - ^self at: key ifAbsent: [self errorKeyNotFound]! ! -!Dictionary methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16833420! - keyAtValue: value - "Answer the key whose value equals the argument, value. If there is none, - cause an error." - - ^self keyAtValue: value ifAbsent: [self errorValueNotFound]! ! -!Dictionary methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16833490 overrides: 16907343! - includes: anObject - self do: [:each | anObject = each ifTrue: [^true]]. - ^false! ! -!Dictionary methodsFor: 'removing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16833600 overrides: 16814683! - remove: anObject - self shouldNotImplement! ! -!Dictionary methodsFor: 'removing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16833603 overrides: 16907321! - remove: anObject ifAbsent: exceptionBlock - self shouldNotImplement! ! -!Dictionary methodsFor: 'removing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16833607! - removeKey: key - "Remove key from the receiver. If key is not in the receiver, create an error - message. Otherwise, answer the value associated with key." - - ^self removeKey: key ifAbsent: [self errorKeyNotFound]! ! -!Dictionary methodsFor: 'enumerating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16833664 overrides: 16814182! - associationsDo: aBlock - "Evaluate aBlock for each of the receiver's key/value associations." - - super do: aBlock! ! -!Dictionary methodsFor: 'enumerating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16833684 overrides: 16907172! -do: aBlock - super do: [:assoc | aBlock value: assoc value]! ! -!Dictionary methodsFor: 'enumerating' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16833700 overrides: 50583017! - 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! ! -!Dictionary methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16833744! - errorValueNotFound - self error: 'value not found'! ! -!SystemDictionary methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16920794! - exitToDebugger - "Enter the machine language debugger, if one exists. Essential. See Object - documentation whatIsAPrimitive. " - - - self primitiveFailed! ! -!SystemDictionary methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16922694! - quitPrimitive - "Exit to another operating system on the host machine, if one exists. All - state changes in the object space since the last snapshot are lost. Essential. - See Object documentation whatIsAPrimitive." - - - self primitiveFailed! ! -!SystemDictionary methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16923729! - specialSelectors - "Used by SystemTracer only" - - ^SpecialSelectors! ! -!SystemDictionary methodsFor: 'special selectors' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16923470! - hasSpecialSelector: aLiteral ifTrueSetByte: aBlock - 1 to: self specialSelectorSize do: - [:index | - (self specialSelectorAt: index) == aLiteral - ifTrue: [aBlock value: index + 16rAF. ^true]]. - ^false! ! -!SharedQueue methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16907683! - 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! ! -!SharedQueue methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16907718! - isEmpty - "Answer whether any objects have been sent through the receiver - and not yet received by anyone." - - ^readPosition = writePosition! ! -!Stream methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16914001! -contents - "Answer the contents of the receiver." - self subclassResponsibility! ! -!Stream class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16914138 overrides: 16783533! - new - self error: 'Streams are created with on: and with:'! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4698-ST-80-timestamps-JuanVuletich-2021Jul26-09h18m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4695] on 26 July 2021 at 9:34:59 am'! -!PositionableStream methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16891443! - peekFor: anObject - "Answer false and do not move the position if self next ~= anObject or if the - receiver is at the end. Answer true and increment position if self next = 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! ! -!PositionableStream methodsFor: 'positioning' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16891646! -position - "Answer the current position of accessing the stream." - ^position! ! -!PositionableStream methodsFor: 'positioning' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16891651! - position: anInteger - "Set position to anInteger as long as anInteger is within the bounds of the - receiver's contents. If it is not, cause an error." - - anInteger >= 0 & (anInteger <= readLimit) - ifTrue: [position _ anInteger] - ifFalse: [self positionError]! ! -!PositionableStream methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16891868! - on: aCollection - collection _ aCollection. - readLimit _ aCollection size. - position _ 0. - self reset! ! -!PositionableStream class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16892254! - on: aCollection - "Answer a new instance of me, streaming over aCollection." - - ^self basicNew on: aCollection! ! -!PositionableStream class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16892260! - on: aCollection from: firstIndex to: lastIndex - "Answer a new instance of me, streaming over a copy of aCollection from - firstIndex to lastIndex." - - ^self basicNew on: (aCollection copyFrom: firstIndex to: lastIndex)! ! -!ReadStream methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898008 overrides: 16914044! - nextPut: anObject - self shouldNotImplement! ! -!ReadStream methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898041! - 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]! ! -!WriteStream methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16946360 overrides: 50581473! - contents - readLimit _ readLimit max: position. - ^collection copyFrom: 1 to: position! ! -!WriteStream methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16946364 overrides: 16914011! - next - self shouldNotImplement! ! -!WriteStream methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16946418 overrides: 16880927! - size - ^readLimit _ readLimit max: position! ! -!WriteStream methodsFor: 'positioning' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16946421 overrides: 50584007! - position: anInteger - readLimit _ readLimit max: position. - super position: anInteger! ! -!WriteStream methodsFor: 'positioning' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16946427 overrides: 16891663! - reset - readLimit _ readLimit max: position. - position _ 0! ! -!FileStream methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16843534 overrides: 50332180! - next - (position >= readLimit and: [self atEnd]) - ifTrue: [^nil] - ifFalse: [^collection at: (position _ position + 1)]! ! -!Link methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16864746! - nextLink - "Answer the Link to which the receiver points." - ^nextLink! ! -!Link methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16864750! - nextLink: aLink - "Store the argument, as the Link to which the receiver refers." - ^nextLink _ aLink! ! -!Process methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16894413! - priority - "Answer the priority of the receiver." - ^priority! ! -!Process methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16894496! - suspendedContext: aContext - suspendedContext _ aContext! ! -!Process class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16894754! - forContext: aContext priority: anInteger - "Answer an instance of me that has suspended aContext at priority anInteger." - - | newProcess | - newProcess _ self new. - newProcess suspendedContext: aContext. - newProcess priority: anInteger. - ^newProcess! ! -!Compiler methodsFor: 'public access' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16821978! - format: textOrStream in: aClass notifying: aRequestor - "Compile a parse tree from the incoming text, and then print the parse tree to yield the answer, a string containing the original code in standard format." - - | aNode | - self from: textOrStream - class: aClass - context: nil - notifying: aRequestor. - aNode _ self format: sourceStream noPattern: false ifFail: [^nil]. - ^aNode decompileString! ! -!Scanner methodsFor: 'error handling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16903857 overrides: 16882681! - notify: string - self error: string! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16904046! - xDelimiter - "ignore blanks etc." - - self scanToken! ! -!Scanner methodsFor: 'multi-character scans' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16904065! - xDollar - "form a Character literal" - - self step. "pass over $" - token _ self step. - tokenType _ #number "really should be Char, but rest of compiler doesn't know"! ! -!Parser methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16885491! - addComment - parseNode ~~ nil - ifTrue: - [parseNode comment: currentComment. - currentComment _ nil]! ! -!Parser methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16885506! - initPattern: aString notifying: req return: aBlock - | result | - self - init: (ReadStream on: aString asString) - notifying: req - failBlock: [^nil]. - encoder _ self. - result _ aBlock value: (self pattern: false inContext: nil). - encoder _ failBlock _ nil. "break cycles" - ^result! ! -!Parser methodsFor: 'expression types' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16885948 overrides: 50508079! - argumentName - hereType == #word - ifFalse: [^self expected: 'Argument name']. - ^self advance! ! -!Parser methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16885762! - match: type - "Answer with true if next tokens type matches" - - hereType == type - ifTrue: - [self advance. - ^true]. - ^false! ! -!Parser methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16885771! - matchToken: thing - "matches the token, not its type" - - here = thing ifTrue: [self advance. ^true]. - ^false! ! -!Parser methodsFor: 'temporaries' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16886425! - bindTemp: name - ^name! ! -!ParseNode methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16884669! - asReturnNode - ^ReturnNode new expr: self! ! -!ParseNode methodsFor: 'encoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16884864! -encodeSelector: selector - ^nil! ! -!ParseNode methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16884940! - printOn: aStream indent: anInteger - "If control gets here, avoid recursion loop" - - super printOn: aStream! ! -!ParseNode methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16884945! - printOn: aStream indent: level precedence: p - self printOn: aStream indent: level! ! -!ParseNode methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16884680! - canCascade - ^false! ! -!ParseNode methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16884685! - isArg - ^false! ! -!ParseNode methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16884737! - isReturnSelf - ^false! ! -!ParseNode methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16884739! - isReturningIf - ^false! ! -!ParseNode methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16884758! - isVariableReference - ^false! ! -!ParseNode methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16884778! - comment - ^comment! ! -!ParseNode methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16884780! - comment: newComment - "self halt." - - comment _ newComment! ! -!Encoder methodsFor: 'encoding' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16837438! - cantStoreInto: varName - ^ StdVariables includesKey: varName! ! -!Encoder methodsFor: 'error handling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16837688 overrides: 16882681! - notify: string - | req | - requestor == nil - ifFalse: - [req _ requestor. - self release. - req notify: string]. - ^false! ! -!Encoder methodsFor: 'initialize-release' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16837770! - noteSuper - supered _ true! ! -!Encoder methodsFor: 'initialize-release' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16837786! - release - requestor _ nil! ! -!Encoder methodsFor: 'temporaries' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16837426! - maxTemp - ^nTemps! ! -!AssignmentNode methodsFor: 'initialize-release' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16780825! - variable: aVariable value: expression - variable _ aVariable. - value _ expression! ! -!BlockNode methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 50488062 overrides: 50488043! - arguments: argNodes - "decompile" - - arguments _ argNodes! ! -!BlockNode methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16789615! - numberOfArguments - ^arguments size! ! -!BlockNode methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16789621! - returnLast - self returns - ifFalse: - [returns _ true. - statements at: statements size put: statements last asReturnNode]! ! -!BlockNode methodsFor: 'code generation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16789714! - code - ^statements first code! ! -!BlockNode methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16789686 overrides: 16884701! - isJust: node - returns ifTrue: [^false]. - ^statements size = 1 and: [statements first == node]! ! -!BlockNode methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16789710! - returns - ^returns or: [statements last isReturningIf]! ! -!MethodNode methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16872877! - tempNames - ^encoder tempNames! ! -!LeafNode methodsFor: 'code generation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16864602! - code - ^code! ! -!LeafNode methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16864647! - key - ^key! ! -!LeafNode methodsFor: 'initialize-release' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16864650! - key: object code: byte - key _ object. - code _ byte! ! -!LeafNode methodsFor: 'initialize-release' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16864660! - name: ignored key: object code: byte - key _ object. - code _ byte! ! -!VariableNode methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16941869 overrides: 50584244! - isVariableReference - ^true! ! -!VariableNode methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16942023 overrides: 50584215! - printOn: aStream indent: level - aStream nextPutAll: name! ! -!MessageNode methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16868020! - precedence - ^precedence! ! -!MessageNode methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16869137! - transform: encoder - special = 0 ifTrue: [^false]. - (self perform: (MacroTransformers at: special) with: encoder) - ifTrue: - [^true] - ifFalse: - [special _ 0. ^false]! ! -!MessageNode methodsFor: 'initialize-release' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16869491! - receiver: rcvr selector: selName arguments: args precedence: p from: encoder sourceRange: range - "compile" - - encoder noteSourceRange: range forNode: self. - ^self - receiver: rcvr - selector: selName - arguments: args - precedence: p - from: encoder! ! -!MessageNode methodsFor: 'expression types' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16868566! - cascadeReceiver - "nil out rcvr (to indicate cascade) and return what it had been" - - | rcvr | - rcvr _ receiver. - receiver _ nil. - ^rcvr! ! -!ReturnNode methodsFor: 'code generation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16901056! - code - ^expr code! ! -!ReturnNode methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16901103 overrides: 50584236! - isReturnSelf - ^expr == NodeSelf! ! -!ReturnNode methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16901109 overrides: 50584244! - isVariableReference - ^expr isVariableReference! ! -!ReturnNode methodsFor: 'initialize-release' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16901112! - expr: e - expr _ e! ! -!ReturnNode methodsFor: 'initialize-release' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16901115! - expr: e encoder: encoder sourceRange: range - expr _ e. - encoder noteSourceRange: range forNode: self! ! -!DecompilerConstructor methodsFor: 'constructor' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16832467! - codeAnyLitInd: association - ^VariableNode new - name: association key - key: association - index: 0 - type: LdLitIndType! ! -!DecompilerConstructor methodsFor: 'constructor' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16832473! - codeAnyLiteral: value - ^LiteralNode new - key: value - index: 0 - type: LdLitType! ! -!DecompilerConstructor methodsFor: 'constructor' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16832478! - codeAnySelector: selector - ^SelectorNode new - key: selector - index: 0 - type: SendType! ! -!DecompilerConstructor methodsFor: 'constructor' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16832483! - codeArguments: args block: block - ^block arguments: args! ! -!DecompilerConstructor methodsFor: 'constructor' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16832493! - codeAssignTo: variable value: expression - ^AssignmentNode new variable: variable value: expression! ! -!DecompilerConstructor methodsFor: 'constructor' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16832517! - codeCascadedMessage: selector arguments: arguments - ^self - codeMessage: nil - selector: selector - arguments: arguments! ! -!DecompilerConstructor methodsFor: 'constructor' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16832619! - codeSelector: sel code: code - ^SelectorNode new key: sel code: code! ! -!DecompilerConstructor methodsFor: 'constructor' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16832623! - codeSuper - ^NodeSuper! ! -!DecompilerConstructor methodsFor: 'constructor' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16832639! - codeThisContext - ^NodeThisContext! ! -!DecompilerConstructor methodsFor: 'initialize-release' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16832676! - method: aMethod class: aClass literals: literals - method _ aMethod. - instVars _ aClass allInstVarNames. - nArgs _ method numArgs. - literalValues _ literals! ! -!ParseStack methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16885449! - pop: n - (position _ position - n) < 0 - ifTrue: [self error: 'Parse stack underflow']! ! -!ParseStack methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16885458! - push: n - (position _ position + n) > length - ifTrue: [length _ position]! ! -!ParseStack methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16885462 overrides: 16880927! - size - ^length! ! -!ParseStack methodsFor: 'results' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16885464! - position - ^position! ! -!ParseStack methodsFor: 'initialize-release' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16885472! - init - length _ position _ 0! ! -!RemoteString methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16900612! - sourceFileNumber - "Answer the index of the file on which the string is stored." - ^sourceFileNumber! ! -!RemoteString class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16900698! - newFileNumber: sourceIndex position: anInteger - "Answer a new instance of RemoteString for file indexed by sourceIndex, - at the position anInteger. Assumes that the string is already stored - on the file and the instance will be used to access it." - - ^self new fileNumber: sourceIndex position: anInteger! ! -!RemoteString class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16900710! - newString: aString onFileNumber: sourceIndex - "Answer a new instance of RemoteString for string, aString, on file indexed by - sourceIndex. Puts the string on the file and creates the remote reference." - - ^self new string: aString onFileNumber: sourceIndex! ! -!RemoteString class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16900720! - newString: aString onFileNumber: sourceIndex toFile: aFileStream - "Answer a new instance of RemoteString for string, aString, on file indexed by - sourceIndex. Puts the string on the file, aFileStream, and creates the remote - reference. Assumes that the index corresponds properly to aFileStream." - - ^self new string: aString onFileNumber: sourceIndex toFile: aFileStream! ! -!Form methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16846745! - bits - "Answer the receiver's Bitmap containing its bits." - ^bits! ! -!Form methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16846784! - offset: aPoint - offset _ aPoint! ! -!Form class methodsFor: 'mode constants' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16849119! - and - "Answer the integer denoting the logical 'and' combination rule." - ^1! ! -!Form class methodsFor: 'mode constants' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16849133! - erase - "Answer the integer denoting mode erase." - ^4! ! -!Form class methodsFor: 'mode constants' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16849149! - over - "Answer the integer denoting mode over." - ^3! ! -!Form class methodsFor: 'mode constants' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16849163! - reverse - "Answer the integer denoting mode reverse." - ^6! ! -!Form class methodsFor: 'mode constants' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16849174! - under - "Answer the integer denoting mode under." - ^7! ! -!Cursor methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16825837 overrides: 50333000! - printOn: aStream - self storeOn: aStream base: 2! ! -!Cursor class methodsFor: 'current cursor' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16826408! - currentCursor - "Answer the instance of Cursor that is the one currently displayed." - ^CurrentCursor! ! -!DisplayScreen methodsFor: 'displaying' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16835301! - beDisplay - "Tell the interpreter to use the receiver as the current display image. Fail if the - form is too wide to fit on the physical display. Essential. See Object - documentation whatIsAPrimitive." - - - self primitiveFailed! ! -!BitBlt methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16785524! - destOrigin: aPoint - "Set the destination coordinates to be those of aPoint." - destX _ aPoint x. - destY _ aPoint y! ! -!BitBlt methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16785530! - destRect: aRectangle - "Set the destination coordinates to be those of aRectangle top left and - the width and height of the receiver to be the width and height of aRectangle." - destX _ aRectangle left. - destY _ aRectangle top. - width _ aRectangle width. - height _ aRectangle height! ! -!Point methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16890219! - x - "Answer the x coordinate." - ^x! ! -!Point methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16890222! - y - "Answer the y coordinate." - ^y! ! -!Point methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16890277! - < aPoint - "Answer whether the receiver is 'above and to the left' of aPoint." - ^x < aPoint x and: [y < aPoint y]! ! -!Point methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16890282! - <= aPoint - "Answer whether the receiver is 'neither below nor to the right' of aPoint." - - ^x <= aPoint x and: [y <= aPoint y]! ! -!Point methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16890294! - > aPoint - "Answer whether the receiver is 'below and to the right' of aPoint." - - ^x > aPoint x and: [y > aPoint y]! ! -!Point methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16890299! - >= aPoint - "Answer whether the receiver is 'neither above nor to the left' of aPoint." - - ^x >= aPoint x and: [y >= aPoint y]! ! -!Point methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16890358! - asPoint - "Answer the receiver itself." - ^self! ! -!Point methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16890361! - corner: aPoint - "Answer a new Rectangle whose origin is the receiver and whose corner is aPoint. - This is one of the infix ways of expressing the creation of a rectangle." - - ^Rectangle origin: self corner: aPoint! ! -!Point methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16890380! - extent: aPoint - "Answer a new Rectangle whose origin is the receiver and whose extent is aPoint. - This is one of the infix ways of expressing the creation of a rectangle." - - ^Rectangle origin: self extent: aPoint! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898507! - bottom - "Answer the position of the receiver's bottom horizontal line." - ^corner y! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898515! - bottomCenter - "Answer the point at the center of the bottom horizontal line of the receiver." - ^self center x @ self bottom! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898521! - bottomLeft - "Answer the point at the left edge of the bottom horizontal line of the receiver." - ^origin x @ corner y! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898526! - bottomRight - "Answer the point at the right edge of the bottom horizontal line of the receiver." - ^corner! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898533! - center - "Answer the point at the center of the receiver." - ^self topLeft + self bottomRight // 2! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898538! - corner - "Answer the point at the bottom right corner of the receiver." - ^corner! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898550! - extent - "Answer with a rectangle with origin 0@0 and corner the receiver's - width @ the receiver's height." - ^corner - origin! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898556! - height - "Answer the height of the receiver." - ^corner y - origin y! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898571! - left - "Answer the position of the receiver's left vertical line." - ^origin x! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898579! - leftCenter - "Answer the point at the center of the receiver's left vertical line." - ^self left @ self center y! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898584! - origin - "Answer the point at the top left corner of the receiver." - ^origin! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898588! - right - "Answer the position of the receiver's right vertical line." - ^corner x! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898596! - rightCenter - "Answer the point at the center of the receiver's right vertical line." - ^self right @ self center y! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898601! - top - "Answer the position of the receiver's top horizontal line." - ^origin y! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898609! - topCenter - "Answer the point at the center of the receiver's top horizontal line." - ^self center x @ self top! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898614! - topLeft - "Answer the point at the top left corner of the receiver's top horizontal line." - ^origin! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898619! - topRight - "Answer the point at the top right corner of the receiver's top horizontal line." - ^corner x @ origin y! ! -!Rectangle methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898624! - width - "Answer the width of the receiver." - ^corner x - origin x! ! -!Rectangle methodsFor: 'rectangle functions' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16898753! - insetOriginBy: originDeltaPoint cornerBy: cornerDeltaPoint - "Answer a Rectangle that is inset from the receiver by a given amount in the - origin and corner." - - ^Rectangle - origin: origin + originDeltaPoint - corner: corner - cornerDeltaPoint! ! -!Rectangle methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16899045 overrides: 50508084! -printOn: aStream - origin printOn: aStream. - aStream nextPutAll: ' corner: '. - corner printOn: aStream! ! -!CharacterBlock methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16801540! - stringIndex - "Answer the position of the receiver in the string it indexes." - ^stringIndex! ! -!CharacterBlock methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16801549! - < aCharacterBlock - "Answer whether the string index of the receiver precedes that of aCharacterBlock." - ^stringIndex < aCharacterBlock stringIndex! ! -!CharacterBlock methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16801556! - <= aCharacterBlock - "Answer whether the string index of the receiver does not come after that of - aCharacterBlock." - ^(self > aCharacterBlock) not! ! -!CharacterBlock methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16801571! - > aCharacterBlock - "Answer whether the string index of the receiver comes after that of - aCharacterBlock." - ^aCharacterBlock < self! ! -!CharacterBlock methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16801577! - >= aCharacterBlock - "Answer whether the string index of the receiver does not precede that of - aCharacterBlock." - ^(self < aCharacterBlock) not! ! -!StrikeFont methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16914273! - glyphs - "Answer a Form containing the bits representing the characters of the receiver." - ^glyphs! ! -!StrikeFont methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16914298! - name: aString - "Set the receiver's name." - name _ aString.! ! -!StrikeFont methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16914314! - subscript - "Answer an integer that is the further vertical offset relative to the - baseline for positioning characters as subscripts." - ^subscript! ! -!StrikeFont methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16914320! - superscript - "Answer an integer that is the further vertical offset relative to the - baseline for positioning characters as superscripts." - ^superscript! ! -!StrikeFont methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16914342 overrides: 16777261! - xTable - "Answer an array of the left x-coordinate of characters in glyphs." - ^xTable! ! -!CompositionScanner methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16823103! - rightX - "Meaningful only when a line has just been composed -- refers to the line most recently composed. This is a subtrefuge to allow for easy resizing of a composition rectangle to the width of the maximum line. Useful only when there is only one line in the form or when each line is terminated by a carriage return. Handy for sizing menus and lists." - - ^spaceX! ! -!PopUpMenu class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16891083! - labels: aString - "Answer an instance of me whose items are in aString." - ^self labels: aString lines: nil! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4699-ST-80-timestamps-JuanVuletich-2021Jul26-09h24m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4695] on 26 July 2021 at 9:38:32 am'! -!Object methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16881029! - = anObject - "Answer true if the receiver and the argument represent the same object - and false otherwise. If = is redefined in any subclass, consider also - redefining the message hash." - - ^self == anObject! ! -!Object methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16881037! - ~= anObject - "Answer true if the receiver and the argument do not represent the same - object and false otherwise." - - ^self = anObject == false! ! -!Object methodsFor: 'error handling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16881489! - shouldNotImplement - "Announce that although the receiver inherits this message, it - should not implement it." - - self error: 'This message is not appropriate for this object'! ! -!Object methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16882265! - storeOn: aStream - "Append to the argument aStream a sequence of characters that is an expression - whose evaluation creates an object similar to the receiver." - - aStream nextPut: $(. - self class isVariable - ifTrue: [aStream nextPutAll: '(', self class name, ' basicNew: '; - store: self basicSize; - nextPutAll: ') '] - ifFalse: [aStream nextPutAll: self class name, ' basicNew']. - 1 to: self class instSize do: - [:i | - aStream nextPutAll: ' instVarAt: '; - store: i; - nextPutAll: ' put: '; - store: (self instVarAt: i); - nextPut: $;]. - 1 to: self basicSize do: - [:i | - aStream nextPutAll: ' basicAt: '; - store: i; - nextPutAll: ' put: '; - store: (self basicAt: i); - nextPut: $;]. - aStream nextPutAll: ' yourself)'! ! -!Switch methodsFor: 'state' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16918328! - isOff - "Answer whether the receiver is set off or not." - ^on not! ! -!Switch methodsFor: 'state' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16918332! - isOn - "Answer whether the receiver is set on or not." - ^on! ! -!Switch methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16918390! - initializeOff - on _ false. - onAction _ nil. - offAction _ nil! ! -!Switch methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16918394! - initializeOn - on _ true. - onAction _ nil. - offAction _ nil! ! -!Switch class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16918410! - newOff - "Answer an instance of me such that the on and off actions are set to nil - ('no action'), and the state is set to 'off'." - - ^super new initializeOff! ! -!Switch class methodsFor: 'instance creation' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16918417! -newOn - "Answer an instance of me such that the on and off actions are set to nil - ('no action'), and the state is set to 'on'." - - ^super new initializeOn! ! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16784249! - someInstance - "Answer the first instance of this receiver. See Object nextInstance. Fails - if there are none. Essential. See Object documentation whatIsAPrimitive." - - - ^nil! ! -!ClassDescription methodsFor: 'compiling' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16806381! -compile: code classified: heading - "Compile the argument, code, as source code in the context of the receiver and - install the result in the receiver's method dictionary under the classification - indicated by the second argument, heading. nil is to be notified if an error occurs. - The argument code is either a string or an object that converts to a string or a - PositionableStream on an object that converts to a string." - - ^self - compile: code - classified: heading - notifying: nil! ! -!ClassDescription methodsFor: 'copying' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16805742! - copyAll: selArray from: class - "Install all the methods found in the method dictionary of the second argument, class, - as the receiver's methods. Classify the messages under -as yet not classified-" - - self copyAll: selArray - from: class - classified: nil! ! -!ClassDescription methodsFor: 'copying' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16805752! - copyAll: selArray from: class classified: cat - "Install all the methods found in the method dictionary of the second argument, class, - as the receiver's methods. Classify the messages under the third argument, cat." - - selArray do: - [:s | self copy: s - from: class - classified: cat]! ! -!ClassDescription methodsFor: 'copying' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16805763! - copyAllCategoriesFrom: aClass - "Specify that the categories of messages for the receiver include all of those found - in the class, aClass. Install each of the messages found in these categories into the - method dictionary of the receiver, classified under the appropriate categories." - - aClass organization categories do: [:cat | self copyCategory: cat from: aClass]! ! -!ClassDescription methodsFor: 'copying' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16805786! - copyCategory: cat from: aClass classified: newCat - "Specify that one of the categories of messages for the receiver is the third argument, - newCat. Copy each message found in the category cat in class aClass into this - new category." - - self copyAll: (aClass organization listAtCategoryNamed: cat) - from: aClass - classified: newCat! ! -!ClassDescription methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16805827 overrides: 50582350! - printOn: aStream - aStream nextPutAll: self name! ! -!Metaclass methodsFor: 'accessing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16870978! - soleInstance - "The receiver has only one instance. Answer it." - - ^thisClass! ! -!Metaclass methodsFor: 'instance variables' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16871017 overrides: 16806072! - removeInstVarName: aString - "Remove the argument, aString, as one of the receiver's instance variables." - - - | newArray newString | - (self instVarNames includes: aString) - ifFalse: [self error: aString , ' is not one of my instance variables']. - newArray _ self instVarNames copyWithout: aString. - newString _ ''. - newArray do: [:aString2 | newString _ aString2 , ' ' , newString]. - self instanceVariableNames: newString! ! -!Magnitude methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16865571! - < aMagnitude - "Compare the receiver with the argument and answer with true if the - receiver is less than the argument. Otherwise answer false." - - ^self subclassResponsibility! ! -!Magnitude methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16865576! - <= aMagnitude - "Compare the receiver with the argument and answer with true if the - receiver is less than or equal to the argument. Otherwise answer false." - - ^(self > aMagnitude) not! ! -!Magnitude methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16865588! - > aMagnitude - "Compare the receiver with the argument and answer with true if the - receiver is greater than the argument. Otherwise answer false." - - ^aMagnitude < self! ! -!Magnitude methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16865599! - between: min and: max - "Answer whether the receiver is less than or equal to the argument, max, - and greater than or equal to the argument, min." - - ^self >= min and: [self <= max]! ! -!Magnitude methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16865610! - max: aMagnitude - "Answer the receiver or the argument, whichever has the greater magnitude." - - self > aMagnitude - ifTrue: [^self] - ifFalse: [^aMagnitude]! ! -!Magnitude methodsFor: 'comparing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16865617! - min: aMagnitude - "Answer the receiver or the argument, whichever has the lesser magnitude." - - self < aMagnitude - ifTrue: [^self] - ifFalse: [^aMagnitude]! ! -!Float methodsFor: 'mathematical functions' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16844579 overrides: 16880035! - arcCos - "Answers with the angle in radians." - - ^Halfpi - self arcSin! ! -!Float methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16844776! - asFloat - "Answer with the receiver itself." - ^self! ! -!Float methodsFor: 'truncation and round off' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16844988 overrides: 16880554! - integerPart - "Answer with a new Float whose value is the receiver's truncated value." - - ^self - self fractionPart! ! -!Fraction methodsFor: 'arithmetic' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16849493 overrides: 50581755! - negated - ^Fraction numerator: numerator negated denominator: denominator! ! -!Integer methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16860202 overrides: 50581124! - even - ^((self digitAt: 1) bitAnd: 1) = 0! ! -!Integer methodsFor: 'testing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16860206 overrides: 16882573! - isInteger - ^true! ! -!Character methodsFor: 'converting' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16800606! - asSymbol - ^Symbol internCharacter: self! ! -!WriteStream methodsFor: 'printing' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16946547! - store: anObject - "Have anObject print on me for rereading." - - anObject storeOn: self! ! -!WriteStream methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16946581 overrides: 50584019! - on: aCollection - super on: aCollection. - readLimit _ 0. - writeLimit _ aCollection size! ! -!WriteStream methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16946585! - 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]! ! -!WriteStream methodsFor: 'private' stamp: 'ST-80 5/31/1983 9:10:35' prior: 16946616! - with: aCollection - super on: aCollection. - position _ readLimit _ writeLimit _ aCollection size! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4700-ST-80-timestamps-JuanVuletich-2021Jul26-09h34m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4695] on 26 July 2021 at 10:42:52 am'! -!MessageSet methodsFor: 'message list' stamp: 'jmv 7/26/2021 10:39:19'! - sortByClass - "Sort the message-list by class / selector" - - messageList _ messageList sort: [ :a :b | - a classSymbol = b classSymbol - ifTrue: [ - a methodSymbol == #Comment - ifTrue: [ true ] - ifFalse: [ - b methodSymbol == #Comment - ifTrue: [ false ] - ifFalse: [ - a classIsMeta = b classIsMeta - ifTrue: [ a methodSymbol < b methodSymbol ] - ifFalse: [ a classIsMeta ] ]]] - ifFalse: [ a classSymbol < b classSymbol ] - ]. - messageList do: [ :each | each removeStringVersionPrefix ]. - self changed: #messageList! ! -!MessageSet methodsFor: 'message list' stamp: 'jmv 7/26/2021 10:38:30'! - sortBySelector - "Sort the message-list by selector / class" - - messageList _ messageList sort: [ :a :b | - a methodSymbol == #Comment - ifTrue: [ true ] - ifFalse: [ - b methodSymbol == #Comment - ifTrue: [ false ] - ifFalse: [ - a methodSymbol = b methodSymbol - ifTrue: [ - a classSymbol = b classSymbol - ifTrue: [ a classIsMeta ] - ifFalse: [ a classSymbol < b classSymbol ]] - ifFalse: [ a methodSymbol < b methodSymbol ]]] - ]. - messageList do: [ :each | each prefixStringVersionWith: each methodSymbol ]. - self changed: #messageList! ! -!MethodReference methodsFor: 'setting' stamp: 'jmv 7/26/2021 10:36:08'! - removeStringVersionPrefix - - | i prefixCoda | - prefixCoda _ '] - '. - i _ stringVersion findString: prefixCoda. - i = 0 ifFalse: [ - stringVersion _ stringVersion copyFrom: i + prefixCoda size to: stringVersion size ].! ! -!MessageSet methodsFor: 'message list' stamp: 'jmv 7/26/2021 10:41:18' prior: 16869875! - sortByDate - "Sort the message-list by date of time-stamp" - - | assocs aCompiledMethod aDate inOrder | - assocs _ messageList collect: [ :aRef | - aDate _ aRef methodSymbol == #Comment - ifTrue: [ - aRef actualClass organization dateCommentLastSubmitted] - ifFalse: [ - aCompiledMethod _ aRef actualClass compiledMethodAt: aRef methodSymbol ifAbsent: nil. - aCompiledMethod ifNotNil: [aCompiledMethod dateMethodLastSubmitted]]. - aRef -> (aDate ifNil: [Date fromString: '01/01/1996'])]. "The dawn of Squeak history" - inOrder _ assocs asArray sort: [ :a :b | a value < b value]. - - inOrder do: [ :each | each key prefixStringVersionWith: each value yyyymmdd ]. - messageList _ inOrder collect: [ :assoc | assoc key ]. - self changed: #messageList! ! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'jmv 7/26/2021 10:33:47' prior: 50505750! - addReferencesOf: anInstVarName at: anInstVarIndex to: references - - | reference | - - self methodsDo: [ :aMethod | - (aMethod accessorDescriptionOf: anInstVarName at: anInstVarIndex) ifNotEmpty: [ :description | - reference := MethodReference method: aMethod. - reference prefixStringVersionWith: description. - references add: reference ]]. - ! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'jmv 7/26/2021 09:52:12' prior: 50411206! - messageListMenu2 - "Fill aMenu with the items appropriate when the shift key is held down" - - ^DynamicMenuBuilder - buildTitled: 'Message List' - targeting: self - collectingMenuOptionsWith: #messageListMenu2Options - changingThemWith: [ :options | - self addExtraMenu2ItemsTo: options. - model canShowMultipleMessageCategories ifTrue: [ - options add: `{ - #itemGroup -> 40. - #itemOrder -> 45. - #label -> 'show category (C)'. - #object -> #model. - #selector -> #showHomeCategory. - #icon -> #packageIcon - } asDictionary` ]]. - - ! ! -!MessageSetWindow methodsFor: 'menu building' stamp: 'jmv 7/26/2021 09:58:13' prior: 50411882 overrides: 50403930! - addExtraMenu2ItemsTo: options - "The shifted selector-list menu is being built. Add items specific to MessageSet" - - model growable ifTrue: [ - options add: `{ - #itemGroup -> 40. - #itemOrder -> 31. - #label -> 'remove from this browser'. - #object -> #model. - #selector -> #removeMessageFromBrowser. - #icon -> #listRemoveIcon - } asDictionary`. - options add:`{ - #itemGroup -> 40. - #itemOrder -> 32. - #label -> 'filter message list...'. - #selector -> #filterMessageList. - #icon -> #findIcon - } asDictionary` ]. - - options add: `{ - #itemGroup -> 41. - #itemOrder -> 33. - #label -> 'sort by class'. - #object -> #model. - #selector -> #sortByClass. - #icon -> #dateIcon - } asDictionary`. - options add: `{ - #itemGroup -> 41. - #itemOrder -> 34. - #label -> 'sort by selector'. - #object -> #model. - #selector -> #sortBySelector. - #icon -> #dateIcon - } asDictionary`. - options add: `{ - #itemGroup -> 41. - #itemOrder -> 35. - #label -> 'sort by date'. - #object -> #model. - #selector -> #sortByDate. - #icon -> #dateIcon - } asDictionary`. - -! ! -!MethodReference methodsFor: 'setting' stamp: 'jmv 7/26/2021 10:36:43' prior: 50505850! - prefixStringVersionWith: aString - - self removeStringVersionPrefix. - stringVersion _ '[', aString, '] - ', stringVersion.! ! -!MethodReference methodsFor: 'comparisons' stamp: 'jmv 7/26/2021 10:26:17' prior: 50570833! - <= anotherMethodReference - "By default, sort by class" - - ^self classSymbol = anotherMethodReference classSymbol - ifTrue: [ - self methodSymbol == #Comment - ifTrue: [ true ] - ifFalse: [ - anotherMethodReference methodSymbol == #Comment - ifTrue: [ false ] - ifFalse: [ - self classIsMeta = anotherMethodReference classIsMeta - ifTrue: [ self methodSymbol < anotherMethodReference methodSymbol ] - ifFalse: [ self classIsMeta ] ]]] - ifFalse: [ self classSymbol < anotherMethodReference classSymbol ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4701-AddSortBy-toImplementorsAndSenders-JuanVuletich-2021Jul26-09h38m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4701] on 27 July 2021 at 4:44:30 pm'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 7/27/2021 16:13:35' prior: 50580460! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('AY' 'Angel Yan') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('bgs' 'Boris G. Shingarov') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('db' 'Douglas Brebner') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('EB' 'Eric Brandwein') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('FGJ' 'Fernando Gasperi Jabalera') - #('FJG' 'Facundo Javier Gelatti') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hlsf' 'Hilaire Fernandes') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('jar' 'Jaromir Matas') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('KLG' 'Gerald Klix') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MM' 'Mariano Montone') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('pmon' 'Paolo Montrasi') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('sjd' 'Santiago Jose Dandois') - #('SLD' 'Steve Davies') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('Squeak1.0' 'Squeak 1.0, September 20, 1996') - #('Squeak1.1' 'Squeak 1.1, September 23, 1996') - #('Squeak1.2' 'Squeak 1.2, June 29, 1997') - #('Squeak1.3' 'Squeak 1.3, January 16, 1998') - #('sr' 'Stephan Rudlof') - #('ss' 'Sebastian Sujarchuk') - #('SSS' 'Samuel S. Shuster') - #('ST-80' 'Smalltalk-80, version 2, of April 1, 1983') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tsl' 'Thiago da Silva Lino') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4702-Add-Squeak-asCodeAuthors-JuanVuletich-2021Jul27-16h44m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4702] on 27 July 2021 at 7:23:32 pm'! -!Object methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16880817! - basicAt: index - "Primitive. Assumes receiver is indexable. Answer the value of an - indexable element in the receiver. Fail if the argument index is not an - Integer or is out of bounds. Essential. Do not override in a subclass. See - Object documentation whatIsAPrimitive." - - - index isInteger ifTrue: [self errorSubscriptBounds: index]. - index isNumber - ifTrue: [^self basicAt: index asInteger] - ifFalse: [self errorNonIntegerIndex]! ! -!Object methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16880833! - basicAt: index put: value - "Primitive. Assumes receiver is indexable. Store the second argument - value in the indexable element of the receiver indicated by index. Fail - if the index is not an Integer or is out of bounds. Or fail if the value is - not of the right type for this kind of collection. Answer the value that - was stored. Essential. Do not override in a subclass. See Object - documentation whatIsAPrimitive." - - - index isInteger - ifTrue: [(index >= 1 and: [index <= self size]) - ifTrue: [self errorImproperStore] - ifFalse: [self errorSubscriptBounds: index]]. - index isNumber - ifTrue: [^self basicAt: index asInteger put: value] - ifFalse: [self errorNonIntegerIndex]! ! -!Object methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16880857! -basicSize - "Primitive. Answer the number of indexable variables in the receiver. - This value is the same as the largest legal subscript. Essential. Do not - override in any subclass. See Object documentation whatIsAPrimitive." - - - "The number of indexable fields of fixed-length objects is 0" - ^0 ! ! -!Object methodsFor: 'binding' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16880949! - bindingOf: aString - ^nil! ! -!Object methodsFor: 'casing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16880951! - caseOf: aBlockAssociationCollection - "The elements of aBlockAssociationCollection are associations between blocks. - Answer the evaluated value of the first association in aBlockAssociationCollection - whose evaluated key equals the receiver. If no match is found, report an error." - - ^ self caseOf: aBlockAssociationCollection otherwise: [self caseError] - -"| z | z _ {[#a]->[1+1]. ['b' asSymbol]->[2+2]. [#c]->[3+3]}. #b caseOf: z" -"| z | z _ {[#a]->[1+1]. ['d' asSymbol]->[2+2]. [#c]->[3+3]}. #b caseOf: z" -"The following are compiled in-line:" -"#b caseOf: {[#a]->[1+1]. ['b' asSymbol]->[2+2]. [#c]->[3+3]}" -"#b caseOf: {[#a]->[1+1]. ['d' asSymbol]->[2+2]. [#c]->[3+3]}"! ! -!Object methodsFor: 'casing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16880974! - caseOf: aBlockAssociationCollection otherwise: aBlock - "The elements of aBlockAssociationCollection are associations between blocks. - Answer the evaluated value of the first association in aBlockAssociationCollection - whose evaluated key equals the receiver. If no match is found, answer the result - of evaluating aBlock." - - aBlockAssociationCollection associationsDo: - [:assoc | (assoc key value = self) ifTrue: [^assoc value value]]. - ^ aBlock value - -"| z | z _ {[#a]->[1+1]. ['b' asSymbol]->[2+2]. [#c]->[3+3]}. #b caseOf: z otherwise: [0]" -"| z | z _ {[#a]->[1+1]. ['d' asSymbol]->[2+2]. [#c]->[3+3]}. #b caseOf: z otherwise: [0]" -"The following are compiled in-line:" -"#b caseOf: {[#a]->[1+1]. ['b' asSymbol]->[2+2]. [#c]->[3+3]} otherwise: [0]" -"#b caseOf: {[#a]->[1+1]. ['d' asSymbol]->[2+2]. [#c]->[3+3]} otherwise: [0]"! ! -!Object methodsFor: 'class membership' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16881002! - class - "Primitive. Answer the object which is the receiver's class. Essential. See - Object documentation whatIsAPrimitive." - - - self primitiveFailed! ! -!Object methodsFor: 'class membership' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16881009! - isKindOf: aClass - "Answer whether the class, aClass, is a superclass or class of the receiver." - - self class == aClass - ifTrue: [^true] - ifFalse: [^self class inheritsFrom: aClass]! ! -!Object methodsFor: 'class membership' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16881017! - isMemberOf: aClass - "Answer whether the receiver is an instance of the class, aClass." - - ^self class == aClass! ! -!Object methodsFor: 'class membership' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16881022! - respondsTo: aSymbol - "Answer whether the method dictionary of the receiver's class contains - aSymbol as a message selector." - - ^self class canUnderstand: aSymbol! ! -!Object methodsFor: 'error handling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16881336! - caseError - "Report an error from an in-line or explicit case statement." - - self error: 'Case not found, and no otherwise clause'! ! -!Object methodsFor: 'error handling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16881441! -notify: aString at: location - "Create and schedule a Notifier with the argument as the message in - order to request confirmation before a process can proceed. Subclasses can - override this and insert an error message at location within aString." - - self notify: aString - - "nil notify: 'confirmation message' at: 12"! ! -!Object methodsFor: 'system primitives' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16882467! - someObject - "Primitive. Answer the first object in the enumeration of all - objects." - - - self primitiveFailed.! ! -!Object methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16882573! - isInteger - "Overridden to return true in Integer." - - ^ false! ! -!Object methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16882582! - isNumber - "Overridden to return true in Number, natch" - ^ false! ! -!Object methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16882761! - storeAt: offset inTempFrame: aContext - "This message had to get sent to an expression already on the stack - as a Block argument being accessed by the debugger. - Just re-route it to the temp frame." - ^ aContext tempAt: offset put: self! ! -!Browser methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16791445! - editSelection - ^editSelection! ! -!Browser methodsFor: 'metaclass' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16792487! - indicateClassMessages - "Indicate that the message selection should come from the metaclass - messages." - - self metaClassIndicated: true! ! -!Browser methodsFor: 'metaclass' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16792493! - indicateInstanceMessages - "Indicate that the message selection should come from the class (instance) - messages." - - self metaClassIndicated: false! ! -!Browser methodsFor: 'metaclass' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16792507! - metaClassIndicated - "Answer the boolean flag that indicates which of the method dictionaries, - class or metaclass." - - ^metaClassIndicated! ! -!Browser methodsFor: 'system category list' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16792771! - systemCategoryList - "Answer the class categories modelled by the receiver." - - ^systemOrganizer categories! ! -!MessageSet methodsFor: 'message list' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16869850 overrides: 50492554! - messageList - "Answer the current list of messages." - - ^messageList! ! -!MessageSet methodsFor: 'class list' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16869949 overrides: 50585881! - metaClassIndicated - "Answer the boolean flag that indicates whether - this is a class method." - - ^ self selectedClassOrMetaClass isMeta! ! -!MessageSet methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16870031! - autoSelectString - "Return the string to be highlighted when making new selections" - ^ autoSelectString! ! -!MessageSet methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16870036! - autoSelectString: aString - "Set the string to be highlighted when making new selections" - autoSelectString _ aString! ! -!MessageSet class methodsFor: 'instance creation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16870388! - messageList: anArray - "Answer an instance of me with message list anArray." - - ^self new initializeMessageList: anArray! ! -!ChangeList methodsFor: 'viewing access' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16796709! - list - ^ list! ! -!ChangeList methodsFor: 'viewing access' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16796711! - listIndex - ^ listIndex! ! -!ChangeList methodsFor: 'viewing access' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16796714! - listSelectionAt: index - ^ listSelections at: index! ! -!ChangeList methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16796754! - changeList - ^ changeList! ! -!ChangeList methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16796770! - file - ^file! ! -!Debugger methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16829629! - contextVariablesInspector - "Answer the instance of Inspector that is providing a view of the - variables of the selected context." - - ^contextVariablesInspector! ! -!Debugger methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16829640! - interruptedContext - "Answer the suspended context of the interrupted process." - - ^contextStackTop! ! -!Debugger methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16829645! - interruptedProcess - "Answer the interrupted process." - - ^interruptedProcess! ! -!Debugger methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16829667! - proceedValue - "Answer the value to return to the selected context when the interrupted - process proceeds." - - ^proceedValue! ! -!Debugger methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16829673! - proceedValue: anObject - "Set the value to be returned to the selected context when the interrupted - process proceeds." - - proceedValue _ anObject! ! -!Debugger methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16829679! - receiver - "Answer the receiver of the selected context, if any. Answer nil - otherwise." - - contextStackIndex = 0 - ifTrue: [^nil] - ifFalse: [^self selectedContext receiver]! ! -!Debugger methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16829686! - receiverInspector - "Answer the instance of Inspector that is providing a view of the - variables of the selected context's receiver." - - ^receiverInspector! ! -!Debugger methodsFor: 'code pane' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16829974 overrides: 16812895! - doItContext - "Answer the context in which a text selection can be evaluated." - - contextStackIndex = 0 - ifTrue: [^super doItContext] - ifFalse: [^self selectedContext]! ! -!Debugger methodsFor: 'code pane' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16829981! - doItReceiver - "Answer the object that should be informed of the result of evaluating a - text selection." - - ^self receiver! ! -!Debugger methodsFor: 'context stack (message list)' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16829712! - contextStackIndex - "Answer the index of the selected context." - - ^contextStackIndex! ! -!Debugger methodsFor: 'context stack (message list)' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16829717! - contextStackList - "Answer the array of contexts." - - ^contextStackList! ! -!Debugger methodsFor: 'context stack (message list)' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16829744! - messageListIndex - "Answer the index of the currently selected context." - - ^contextStackIndex! ! -!Debugger methodsFor: 'context stack (message list)' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16829772! - toggleContextStackIndex: anInteger - "If anInteger is the same as the index of the selected context, deselect it. - Otherwise, the context whose index is anInteger becomes the selected - context." - - self contextStackIndex: - (contextStackIndex = anInteger - ifTrue: [0] - ifFalse: [anInteger]) - oldContextWas: - (contextStackIndex = 0 - ifTrue: [nil] - ifFalse: [contextStack at: contextStackIndex])! ! -!Debugger methodsFor: 'context stack menu' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16829925! - selectPC - "Toggle the flag telling whether to automatically select the expression - currently being executed by the selected context." - - selectingPC _ selectingPC not! ! -!Debugger methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16830079! - externalInterrupt: aBoolean - - externalInterrupt _ aBoolean ! ! -!Debugger methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16830124! - newStack: stack - | oldStack diff | - oldStack _ contextStack. - contextStack _ stack. - (oldStack == nil or: [oldStack last ~~ stack last]) - ifTrue: [contextStackList _ contextStack collect: [:ctx | ctx printString]. - ^ self]. - "May be able to re-use some of previous list" - diff _ stack size - oldStack size. - contextStackList _ diff <= 0 - ifTrue: [contextStackList copyFrom: 1-diff to: oldStack size] - ifFalse: [diff > 1 - ifTrue: [contextStack collect: [:ctx | ctx printString]] - ifFalse: [(Array with: stack first printString) , contextStackList]]! ! -!FileList methodsFor: 'file list' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16842375! - fileList - "Answer the list of files in the current volume." - - ^ list! ! -!FileList methodsFor: 'file list' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16842379! - fileListIndex - "Answer the index of the currently selected file." - - ^ listIndex! ! -!FileList methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16842981! - folderString - ^ ' [...]'! ! -!Inspector methodsFor: 'selecting' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16857022! - selectionIndex - "The receiver has a list of variables of its inspected object. One of these - is selected. Answer the index into the list of the selected variable." - - ^selectionIndex! ! -!ContextVariablesInspector methodsFor: 'code' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16825635 overrides: 16857072! - doItContext - - ^object! ! -!ContextVariablesInspector methodsFor: 'code' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16825638 overrides: 50582336! - doItReceiver - - ^object receiver! ! -!Color class methodsFor: 'instance creation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 50354609! - r: r g: g b: b alpha: alpha - ^ (self r: r g: g b: b) alpha: alpha! ! -!UndefinedObject methodsFor: 'dependents access' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16940131! - suspend - "Kills off processes that didn't terminate properly" - "Display reverse; reverse." "<-- So we can catch the suspend bug" - Processor terminateActive! ! -!Behavior methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16782789! - parserClass - "Answer a parser class to use for parsing method headers." - - ^self compilerClass parserClass! ! -!Behavior methodsFor: 'compiling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16783282! - compile: code - "Compile the argument, code, as source code in the context of the - receiver. Create an error notification if the code can not be compiled. - The argument is either a string or an object that converts to a string or a - PositionableStream on an object that converts to a string." - - ^self compile: code notifying: nil! ! -!Behavior methodsFor: 'compiling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16783402! - recompileChanges - "Compile all the methods that are in the changes file. - This validates sourceCode and variable references and forces - methods to use the current bytecode set" - - self selectorsDo: - [:sel | (self compiledMethodAt: sel) fileIndex > 1 ifTrue: - [self recompile: sel from: self]]! ! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16783625! - superclass - "Answer the receiver's superclass, a Class." - - ^superclass! ! -!Behavior methodsFor: 'accessing instances and variables' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16784241! - sharedPools - "Answer a Set of the names of the pools (Dictionaries) that the receiver - shares. - 9/12/96 tk sharedPools have an order now" - - ^ OrderedCollection new! ! -!Behavior methodsFor: 'testing class hierarchy' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16784263! - inheritsFrom: aClass - "Answer whether the argument, aClass, is on the receiver's superclass - chain." - - | aSuperclass | - aSuperclass _ superclass. - [aSuperclass == nil] - whileFalse: - [aSuperclass == aClass ifTrue: [^true]. - aSuperclass _ aSuperclass superclass]. - ^false! ! -!Behavior methodsFor: 'testing method dictionary' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16784336! - allUnsentMessages - "Answer an array of all the messages defined by the receiver that are not sent anywhere in the system. 5/8/96 sw" - - ^ Smalltalk allUnSentMessagesIn: self selectors! ! -!Behavior methodsFor: 'enumerating' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16784542! - allSubclassesDo: aBlock - "Evaluate the argument, aBlock, for each of the receiver's subclasses." - - self subclassesDo: - [:cl | - aBlock value: cl. - cl allSubclassesDo: aBlock]! ! -!Behavior methodsFor: 'enumerating' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16784568! - selectSuperclasses: aBlock - "Evaluate the argument, aBlock, with the receiver's superclasses as the - argument. Collect into an OrderedCollection only those superclasses for - which aBlock evaluates to true. In addition, evaluate aBlock for the - superclasses of each of these successful superclasses and collect into the - OrderedCollection ones for which aBlock evaluates to true. Answer the - resulting OrderedCollection." - - | aSet | - aSet _ Set new. - self allSuperclasses do: - [:aSuperclass | - (aBlock value: aSuperclass) ifTrue: [aSet add: aSuperclass]]. - ^aSet! ! -!Behavior methodsFor: 'enumerating' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16784588! - withAllSubclassesDo: aBlock - "Evaluate the argument, aBlock, for the receiver and each of its - subclasses." - - aBlock value: self. - self allSubclassesDo: aBlock! ! -!ClassDescription methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16805702 overrides: 50527862! - theNonMetaClass - "Sent to a class or metaclass, always return the class" - - ^self! ! -!ClassDescription methodsFor: 'accessing method dictionary' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16806234! - removeCategory: aString - "Remove each of the messages categorized under aString in the method - dictionary of the receiver. Then remove the category aString." - | categoryName | - categoryName _ aString asSymbol. - (self organization listAtCategoryNamed: categoryName) do: - [:sel | self removeSelector: sel]. - self organization removeCategory: categoryName! ! -!ClassDescription methodsFor: 'compiling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16806373! - acceptsLoggingOfCompilation - "weird name is so that it will come lexically before #compile, so that a clean build can make it through. 7/7/96 sw" - - ^ true! ! -!ClassDescription methodsFor: 'compiling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16806440 overrides: 50495979! - compile: code notifying: requestor - "Refer to the comment in Behavior|compile:notifying:." - - ^self compile: code - classified: ClassOrganizer default - notifying: requestor! ! -!ClassDescription methodsFor: 'compiling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16806529! - wantsChangeSetLogging - "Answer whether code submitted for the receiver should be remembered by the changeSet mechanism. 7/12/96 sw" - - - ^ true! ! -!ClassDescription methodsFor: 'copying' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16805706! - copy: sel from: class - "Install the method associated with the first argument, sel, a message - selector, found in the method dictionary of the second argument, class, - as one of the receiver's methods. Classify the message under -As yet not - classified-." - - self copy: sel - from: class - classified: nil! ! -!ClassDescription methodsFor: 'copying' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16805777! - copyCategory: cat from: class - "Specify that one of the categories of messages for the receiver is cat, as - found in the class, class. Copy each message found in this category." - - self copyCategory: cat - from: class - classified: cat! ! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16806694! - fileOutChangedMessages: aSet on: aFileStream - "File a description of the messages of the receiver that have been - changed (i.e., are entered into the argument, aSet) onto aFileStream." - - self fileOutChangedMessages: aSet - on: aFileStream - moveSource: false - toFile: 0! ! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16806814! - methodsFor: aString priorSource: sourcePosition inFile: fileIndex - "Prior source pointer ignored when filing in." - ^ self methodsFor: aString! ! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16807021! - reformatAll - "Reformat all methods in this class. - Leaves old code accessible to version browsing" - self selectorsDo: [:sel | self reformatMethodAt: sel]! ! -!ClassDescription methodsFor: 'instance variables' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16806072! - removeInstVarName: aString - "Remove the argument, aString, as one of the receiver's instance - variables. Create an error notification if the argument is not found." - - self subclassResponsibility! ! -!ClassDescription methodsFor: 'printing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16805847 overrides: 50584941! - storeOn: aStream - "Classes and Metaclasses have global names." - - aStream nextPutAll: self name! ! -!Class methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16802332 overrides: 16784373! - hasMethods - "Answer a Boolean according to whether any methods are defined for the - receiver (includes whether there are methods defined in the receiver's - metaclass)." - - ^super hasMethods or: [self class hasMethods]! ! -!Class methodsFor: 'compiling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16802626 overrides: 16783327! - compileAllFrom: oldClass - "Recompile all the methods in the receiver's method dictionary (not the - subclasses). Also recompile the methods in the metaclass." - - super compileAllFrom: oldClass. - self class compileAllFrom: oldClass class! ! -!Class methodsFor: 'fileIn/Out' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16802908 overrides: 50586346! - reformatAll - "Reformat all methods in this class. - Leaves old code accessible to version browsing" - super reformatAll. "me..." - self class reformatAll "...and my metaclass"! ! -!Class methodsFor: 'fileIn/Out' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16802915! - shouldFileOutPool: aPoolName - "respond with true if the user wants to file out aPoolName" - ^self confirm: ('FileOut the sharedPool ', aPoolName, '?')! ! -!Class methodsFor: 'fileIn/Out' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16802921! - shouldFileOutPools - "respond with true if the user wants to file out the shared pools" - ^self confirm: 'FileOut selected sharedPools?'! ! -!Metaclass methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16870987 overrides: 50586254! - theNonMetaClass - "Sent to a class or metaclass, always return the class" - - ^thisClass! ! -!Metaclass methodsFor: 'compiling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16871101 overrides: 50586276! - acceptsLoggingOfCompilation - "Answer whether the receiver's method submisions and class defintions should be logged to the changes file and to the current change set. The metaclass follows the rule of the class itself. 6/18/96 sw" - - ^ thisClass acceptsLoggingOfCompilation! ! -!Metaclass methodsFor: 'compiling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16871115! - possibleVariablesFor: misspelled continuedFrom: oldResults - - ^ thisClass possibleVariablesFor: misspelled continuedFrom: oldResults -! ! -!Metaclass methodsFor: 'compiling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16871121 overrides: 50586294! - wantsChangeSetLogging - "Answer whether code submitted for the receiver should be remembered by the changeSet mechanism.The metaclass follows the rule of the class itself. 7/12/96 sw" - - ^ thisClass wantsChangeSetLogging! ! -!Magnitude methodsFor: 'comparing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16865624! - min: aMin max: aMax - - ^ (self min: aMin) max: aMax! ! -!Number methodsFor: 'intervals' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16880004! - to: stop do: aBlock - "Normally compiled in-line, and therefore not overridable. - Evaluate aBlock for each element of the interval (self to: stop by: 1)." - | nextValue | - nextValue _ self. - [nextValue <= stop] - whileTrue: - [aBlock value: nextValue. - nextValue _ nextValue + 1]! ! -!Number methodsFor: 'mathematical functions' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16880035! - arcCos - "The receiver is the cosine of an angle. Answer the angle measured in - radians." - - ^self asFloat arcCos! ! -!Number methodsFor: 'mathematical functions' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16880041! - arcSin - "The receiver is the sine of an angle. Answer the angle measured in - radians." - - ^self asFloat arcSin! ! -!Number methodsFor: 'mathematical functions' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16880071! - cos - "The receiver represents an angle measured in radians. Answer its cosine." - - ^self asFloat cos! ! -!Number methodsFor: 'mathematical functions' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16880229! - sin - "The receiver represents an angle measured in radians. Answer its sine." - - ^self asFloat sin! ! -!Number methodsFor: 'mathematical functions' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16880248! - tan - "The receiver represents an angle measured in radians. Answer its - tangent." - - ^self asFloat tan! ! -!Number methodsFor: 'printing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16880407! -printStringBase: base - ^ String streamContents: - [:strm | self printOn: strm base: base]! ! -!Number methodsFor: 'printing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16880436! - storeStringBase: base - ^ String streamContents: [:strm | self storeOn: strm base: base]! ! -!Number methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16880456 overrides: 50585845! - isNumber - ^ true! ! -!Integer methodsFor: 'arithmetic' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16858919! - alignedTo: anInteger - "Answer the smallest number not less than receiver that is a multiple of anInteger." - - ^(self+anInteger-1//anInteger)*anInteger - -"5 alignedTo: 2" -"12 alignedTo: 3"! ! -!Integer methodsFor: 'bit manipulation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16859098! - << shiftAmount "left shift" - shiftAmount < 0 ifTrue: [self error: 'negative arg']. - ^ self bitShift: shiftAmount! ! -!Integer methodsFor: 'bit manipulation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16859233! - bitInvert32 - "Answer the 32-bit complement of the receiver." - - ^ self bitXor: 16rFFFFFFFF! ! -!Integer methodsFor: 'system primitives' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16860193! - replaceFrom: start to: stop with: replacement startingAt: repStart - | j | "Catches failure if LgInt replace primitive fails" - j _ repStart. - start to: stop do: - [:i | - self digitAt: i put: (replacement digitAt: j). - j _ j+1]! ! -!Integer methodsFor: 'truncation and round off' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16860281! - normalize - "SmallInts OK; LgInts override" - ^ self! ! -!Integer methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16860295! - copyto: x - | stop | - stop _ self digitLength min: x digitLength. - ^ x replaceFrom: 1 to: stop with: self startingAt: 1! ! -!Integer class methodsFor: 'instance creation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16860870 overrides: 50568403! - readFrom: aStream - "Answer a new Integer as described on the stream, aStream. - Embedded radix specifiers not allowed - use Number readFrom: for that." - ^self readFrom: aStream base: 10! ! -!LargePositiveInteger methodsFor: 'arithmetic' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16862369 overrides: 50581755! - negated - ^ (self copyto: (LargeNegativeInteger new: self digitLength)) - normalize "Need to normalize to catch SmallInteger minVal"! ! -!SmallInteger methodsFor: 'arithmetic' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16908626 overrides: 16858876! - - aNumber - "Primitive. Subtract the argument from the receiver and answer with the - result if it is a SmallInteger. Fail if the argument or the result is not a - SmallInteger. Essential. No Lookup. See Object documentation - whatIsAPrimitive." - - - ^super - aNumber! ! -!SmallInteger methodsFor: 'converting' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16908919 overrides: 16859473! - asFloat - "Primitive. Answer a Float that represents the value of the receiver. - Essential. See Object documentation whatIsAPrimitive." - - - self primitiveFailed! ! -!LookupKey methodsFor: 'comparing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16865318 overrides: 50581118! -hash - "Hash is reimplemented because = is implemented." - - ^key hash! ! -!Association methodsFor: 'printing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16780922 overrides: 50584941! - storeOn: aStream - "Store in the format (key->value)" - aStream nextPut: $(. - key storeOn: aStream. - aStream nextPutAll: '->'. - value storeOn: aStream. - aStream nextPut: $)! ! -!MessageTally methodsFor: 'collecting leaves' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16870641! - bump: hitCount - tally _ tally + hitCount! ! -!MessageTally methodsFor: 'comparing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16870702! - isPrimitives - "Detect pseudo node used to carry tally of local hits" - ^ receivers == nil! ! -!Date methodsFor: 'printing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16828135! - printFormat: formatArray - "Answer a String describing the receiver using the format denoted by the - argument, formatArray." - - | aStream | - aStream _ WriteStream on: (String new: 16). - self printOn: aStream format: formatArray. - ^aStream contents! ! -!Date methodsFor: 'printing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16828144 overrides: 16938074! - printOn: aStream - - self printOn: aStream format: #(1 2 3 $ 3 1 )! ! -!ContextPart methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16823639! - client - "Answer the client, that is, the object that sent the message that created this context." - - ^sender receiver! ! -!ContextPart methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16823656 overrides: 50581173! - method - "Answer the method of this context." - - self subclassResponsibility! ! -!ContextPart methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16824909! - stackPtr "For use only by the SystemTracer" - ^ stackp! ! -!Decompiler methodsFor: 'control' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16831421! - blockTo: end - "Decompile a range of code as in statementsTo:, but return a block node." - | exprs block oldBase | - oldBase _ blockStackBase. - blockStackBase _ stack size. - exprs _ self statementsTo: end. - block _ constructor codeBlock: exprs returns: lastReturnPc = lastPc. - blockStackBase _ oldBase. - lastReturnPc _ -1. "So as not to mislead outer calls" - ^block! ! -!Decompiler methodsFor: 'public access' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16832302! - tempAt: offset - "Needed by BraceConstructor - ^ self primCursorLocPutAgain: aPoint rounded! ! -!InputSensor methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16856647! - primCursorLocPutAgain: aPoint - "Do nothing if primitive is not implemented." - - - ^ self! ! -!InputSensor methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16856652! - primKbdNext - - ^ nil! ! -!InputSensor methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16856655! - primKbdPeek - - ^ nil! ! -!InputSensor methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16856658! - primMouseButtons - - ^ 0! ! -!ProcessorScheduler methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16895627! - highestPriority: newHighestPriority - "Change the number of priority levels currently available for use." - - | continue newProcessLists | - (quiescentProcessLists size > newHighestPriority - and: [self anyProcessesAbove: newHighestPriority]) - ifTrue: [self error: 'There are processes with priority higher than ' - ,newHighestPriority printString]. - newProcessLists _ Array new: newHighestPriority. - 1 to: ((quiescentProcessLists size) min: (newProcessLists size)) do: - [:priority | newProcessLists at: priority put: (quiescentProcessLists at: priority)]. - quiescentProcessLists size to: newProcessLists size do: - [:priority | newProcessLists at: priority put: LinkedList new]. - quiescentProcessLists _ newProcessLists! ! -!Collection methodsFor: 'enumerating' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16814182! - 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! ! -!Collection methodsFor: 'enumerating' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16814233! - collect: collectBlock thenSelect: selectBlock - ^ (self collect: collectBlock) select: selectBlock! ! -!Collection methodsFor: 'enumerating' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16814481! - select: selectBlock thenCollect: collectBlock - ^ (self select: selectBlock) collect: collectBlock! ! -!Collection methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16814884! - includesAllOf: aCollection - "Answer whether all the elements of aCollection are in the receiver." - aCollection do: [:elem | (self includes: elem) ifFalse: [^ false]]. - ^ true! ! -!Collection methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16814891! - includesAnyOf: aCollection - "Answer whether any element of aCollection is one of the receiver's elements." - aCollection do: [:elem | (self includes: elem) ifTrue: [^ true]]. - ^ false! ! -!SequenceableCollection methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16905774! - 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! ! -!SequenceableCollection methodsFor: 'copying' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16906173! - 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'"! ! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16906342 overrides: 50582962! - collect: aBlock - "Refer to the comment in Collection|collect:." - | result | - result _ self species new: self size. - 1 to: self size do: - [:index | result at: index put: (aBlock value: (self at: index))]. - ^ result! ! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16906737! - 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)]! ! -!String methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16915489! - 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! ! -!String methodsFor: 'copying' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16916211! - 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'"! ! -!String methodsFor: 'converting' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16916618! - 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! ! -!String methodsFor: 'converting' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16916848 overrides: 16814592! - 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]! ! -!String methodsFor: 'printing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16917121 overrides: 50583176! -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: $'! ! -!Symbol class methodsFor: 'instance creation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16918799 overrides: 16780604! - 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 -"! ! -!CompiledMethod methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16819501! - numTemps - "Answer the number of temporary variables used by the receiver." - - ^ (self header bitShift: -18) bitAnd: 16r3F! ! -!CompiledMethod methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16819555! - returnField - "Answer the index of the instance variable returned by a quick return - method." - | prim | - prim _ self primitive. - prim < 264 - ifTrue: [self error: 'only meaningful for quick-return'] - ifFalse: [^ prim - 264]! ! -!CompiledMethod methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16819788! - isReturnSelf - "Answer whether the receiver is a quick return of self." - - ^ self primitive = 256! ! -!CompiledMethod methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16819793! -isReturnSpecial - "Answer whether the receiver is a quick return of self or constant." - - ^ self primitive between: 256 and: 263! ! -!CompiledMethod methodsFor: 'printing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16819929! -storeLiteralsOn: aStream forClass: aBehavior - "Store the literals referenced by the receiver on aStream, each terminated by a space." - - | literal | - 2 to: self numLiterals + 1 do: - [:index | - aBehavior storeLiteral: (self objectAt: index) on: aStream. - aStream space]! ! -!CompiledMethod methodsFor: 'literals' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16820126! - literals - "Answer an Array of the literals referenced by the receiver." - | literals numberLiterals | - literals _ Array new: (numberLiterals _ self numLiterals). - 1 to: numberLiterals do: - [:index | - literals at: index put: (self objectAt: index + 1)]. - ^literals! ! -!Bitmap methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16787462! - bitPatternForDepth: depth - "The raw call on BitBlt needs a Bitmap to represent this color. I already am Bitmap like. I am already adjusted for a specific depth. Interpret me as an array of (32/depth) Color pixelValues. BitBlt aligns the first element of this array with the top scanline of the destinationForm, the second with the second, and so on, cycling through the color array as necessary. 6/18/96 tk" - - ^ self! ! -!Semaphore methodsFor: 'initialization' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16905263! - terminateProcess - "Terminate the process waiting on this semaphore, if any." - - self isEmpty ifFalse: [ self removeFirst terminate ].! ! -!OrderedCollection methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16883759 overrides: 16880774! - 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]! ! -!OrderedCollection methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16883770 overrides: 16880792! - 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]! ! -!OrderedCollection methodsFor: 'adding' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16883853! - 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! ! -!OrderedCollection methodsFor: 'adding' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16883862! - 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! ! -!OrderedCollection methodsFor: 'adding' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16883886! - growSize - ^ array size max: 2! ! -!OrderedCollection methodsFor: 'removing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16884110! - 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! ! -!OrderedCollection methodsFor: 'removing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16884129! - 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! ! -!OrderedCollection class methodsFor: 'instance creation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16884318 overrides: 16783541! - new: anInteger - "If a subclass adds fields, then it is necessary for that subclass to - reimplement new:." - - ^ super new setCollection: (Array new: anInteger)! ! -!RunArray methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16901186 overrides: 50581278! - size - | size | - size _ 0. - 1 to: runs size do: [:i | size _ size + (runs at: i)]. - ^size! ! -!RunArray methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16901390! - 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"! ! -!RunArray class methodsFor: 'instance creation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16901522 overrides: 16815105! - 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 -"! ! -!Set methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16907193! - array - ^ array! ! -!Set methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16907255! - growSize - ^ array size max: 2! ! -!Set methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16907257! - init: n - "Initialize array to an array size of n" - array _ Array new: n. - tally _ 0! ! -!Set methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16907266! - noCheckAdd: anObject - array at: (self findElementOrNil: anObject) put: anObject. - tally _ tally + 1! ! -!Set methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16907271 overrides: 16896594! - rehash - | newSelf | - newSelf _ self species new: self size. - self do: [:each | newSelf noCheckAdd: each]. - array _ newSelf array! ! -!Set methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16907308! - withArray: anArray - "private -- for use only in copy" - array _ anArray! ! -!Set class methodsFor: 'instance creation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16907374 overrides: 16783533! -new - ^ self new: 4! ! -!Set class methodsFor: 'instance creation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16907377 overrides: 16783541! - new: nElements - "Create a Set large enough to hold nElements without growing" - ^ super new init: (self sizeFor: nElements)! ! -!Set class methodsFor: 'instance creation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16907383! -sizeFor: nElements - "Large enough size to hold nElements with some slop (see fullCheck)" - nElements <= 0 ifTrue: [^ 1]. - ^ nElements+1*4//3! ! -!Dictionary methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16833288! - 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! ! -!Dictionary methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16833754 overrides: 50587209! - 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! ! -!Dictionary methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16833770 overrides: 50587216! - rehash - "Smalltalk rehash." - | newSelf | - newSelf _ self species new: self size. - self associationsDo: [:each | newSelf noCheckAdd: each]. - array _ newSelf array! ! -!Dictionary methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16833803! - 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)]! ! -!MethodDictionary methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16872013 overrides: 16833527! - add: anAssociation - ^ self at: anAssociation key put: anAssociation value! ! -!MethodDictionary methodsFor: 'removing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16872084 overrides: 16833614! - removeKey: key ifAbsent: errorBlock - "The interpreter might be using this MethodDict while - this method is running!! Therefore we perform the removal - in a copy, and then atomically become that copy" - | copy | - copy _ self copy. - copy removeDangerouslyKey: key ifAbsent: [^ errorBlock value]. - self become: copy! ! -!MethodDictionary methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16872156 overrides: 50496996! - keyAt: index - - ^ self basicAt: index! ! -!MethodDictionary methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16872159! - methodArray - ^ array! ! -!MethodDictionary methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16872230 overrides: 50496988! - swap: oneIndex with: otherIndex - | element | - element _ self basicAt: oneIndex. - self basicAt: oneIndex put: (self basicAt: otherIndex). - self basicAt: otherIndex put: element. - super swap: oneIndex with: otherIndex. -! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16920119! - verifyChanges "Smalltalk verifyChanges" - "Recompile all methods in the changes file." - Smalltalk allBehaviorsDo: [:class | class recompileChanges]. -! ! -!SystemDictionary methodsFor: 'image, changes name' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16920232! - imageName: newName - "Set the the full path name for the current image. All further snapshots will use this." - - - ^ self primitiveFailed! ! -!SystemDictionary methodsFor: 'memory space' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16920288! -bytesLeft - "Answer the number of bytes of space available. Does a full garbage collection." - - ^ self garbageCollect -! ! -!SystemDictionary methodsFor: 'memory space' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16920332! - createStackOverflow - "For testing the low space handler..." - "Smalltalk installLowSpaceWatcher; createStackOverflow" - - self createStackOverflow. "infinite recursion"! ! -!SystemDictionary methodsFor: 'memory space' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16920347! - garbageCollectMost - "Primitive. Reclaims recently created garbage (which is usually most of it) fairly quickly and answers the number of bytes of available space." - - - ^ self primBytesLeft! ! -!SystemDictionary methodsFor: 'memory space' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16920460! - primBytesLeft - "Primitive. Answer the number of bytes available for new object data. - Not accurate unless preceded by - Smalltalk garbageCollectMost (for reasonable accuracy), or - Smalltalk garbageCollect (for real accuracy). - See Object documentation whatIsAPrimitive." - - - ^ 0! ! -!SystemDictionary methodsFor: 'memory space' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16920471! - primLowSpaceSemaphore: aSemaphore - "Primitive. Register the given Semaphore to be signalled when the - number of free bytes drops below some threshold. Disable low-space - interrupts if the argument is nil." - - - self primitiveFailed! ! -!SystemDictionary methodsFor: 'memory space' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16920481! - primSignalAtBytesLeft: numBytes - "Tell the interpreter the low-space threshold in bytes. When the free - space falls below this threshold, the interpreter will signal the low-space - semaphore, if one has been registered. Disable low-space interrupts if the - argument is zero. Fail if numBytes is not an Integer." - - - self primitiveFailed! ! -!SystemDictionary methodsFor: 'memory space' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16920502! - signalLowSpace - "Signal the low-space semaphore to alert the user that space is running low." - - LowSpaceSemaphore signal.! ! -!SystemDictionary methodsFor: 'profiling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16921399! - clearProfile - "Clear the profile database." - - -! ! -!SystemDictionary methodsFor: 'profiling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16921403! - dumpProfile - "Dump the profile database to a file." - - -! ! -!SystemDictionary methodsFor: 'profiling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16921407! - profile: aBlock - "Make a virtual machine profile of the given block." - "Note: Profiling support is provided so that VM implementors - can better understand and improve the efficiency of the virtual - machine. To use it, you must be running a version of the - virtual machine compiled with profiling enabled (which - makes it much slower than normal even when not profiling). - You will also need the CodeWarrior profile reader application." - - self stopProfiling. - self clearProfile. - self startProfiling. - aBlock value. - self stopProfiling. - self dumpProfile.! ! -!SystemDictionary methodsFor: 'profiling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16921426! - startProfiling - "Start profiling the virtual machine." - - -! ! -!SystemDictionary methodsFor: 'profiling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16921430! - stopProfiling - "Stop profiling the virtual machine." - - -! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16922539! - lastQuitLogPosition - ^ LastQuitLogPosition! ! -!SystemDictionary methodsFor: 'special objects' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16923432! - compactClassesArray "Smalltalk compactClassesArray" - "Return the array of 31 classes whose instances may be - represented compactly" - ^ Smalltalk specialObjectsArray at: 29! ! -!SystemDictionary methodsFor: 'special objects' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16923710! - specialObjectsArray "Smalltalk specialObjectsArray at: 1" - - ^ self primitiveFailed! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16923867! - browseAllCallsOn: literal1 and: literal2 - "Create and schedule a message browser on each method that calls on the - two Symbols, literal1 and literal2. For example, Smalltalk - browseAllCallsOn: #at: and: #at:put:." - - ^self - browseMessageList: (self allCallsOn: literal1 and: literal2) - name: literal1 printString , ' -and- ' , literal2 printString! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16923917! - browseAllImplementorsOf: selector - "Create and schedule a message browser on each method that implements - the message whose selector is the argument, selector. For example, - Smalltalk browseAllImplementorsOf: #at:put:." - - ^self browseMessageList: (self allImplementorsOf: selector) name: 'Implementors of ' , selector! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16923947! - browseAllImplementorsOfList: selectorList - "Create and schedule a message browser on each method that implements - the message whose selector is in the argument selectorList. For example, - Smalltalk browseAllImplementorsOf: #(at:put: size). - 1/16/96 sw: defer to the titled version" - - self browseAllImplementorsOfList: selectorList title: 'Implementors of all'! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16923987! - browseAllSelect: aBlock - "Create and schedule a message browser on each method that, when used - as the block argument to aBlock gives a true result. For example, - Smalltalk browseAllSelect: [:method | method numLiterals > 10]." - - ^self browseMessageList: (self allSelect: aBlock) name: 'selected messages'! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16924163! - browseMessageList: messageList name: label - "Create and schedule a MessageSet browser on messageList." - ^ self browseMessageList: messageList name: label autoSelect: nil! ! -!Stream methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16914011! - next - "Answer the next object accessible by the receiver." - - self subclassResponsibility! ! -!Stream methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16914015! - next: anInteger - "Answer the next anInteger number of objects accessible by the receiver." - - | aCollection | - aCollection _ OrderedCollection new. - anInteger timesRepeat: [aCollection addLast: self next]. - ^aCollection! ! -!Stream methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16914024! - 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! ! -!Stream methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16914032! - 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! ! -!Stream methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16914044! - nextPut: anObject - "Insert the argument, anObject, as the next object accessible by the - receiver. Answer anObject." - - self subclassResponsibility! ! -!Stream methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16914050! - 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! ! -!Stream methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16914077! - atEnd - "Answer whether the receiver can access any more objects." - - self subclassResponsibility! ! -!Stream methodsFor: 'enumerating' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16914117! - do: aBlock - "Evaluate aBlock for each of the objects accessible by receiver." - - [self atEnd] - whileFalse: [aBlock value: self next]! ! -!PositionableStream methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16891420! - originalContents - "Answer the receiver's actual contents collection, NOT a copy. 1/29/96 sw" - - ^ collection! ! -!PositionableStream methodsFor: 'positioning' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16891663! - reset - "Set the receiver's position to the beginning of the sequence of objects." - - position _ 0! ! -!PositionableStream methodsFor: 'positioning' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16891674! - setToEnd - "Set the position of the receiver to the end of the sequence of objects." - - position _ readLimit! ! -!PositionableStream methodsFor: 'positioning' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16891687! - 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! ! -!PositionableStream methodsFor: 'fileIn/Out' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16891852! - 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" - ]. - ! ! -!PositionableStream methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16891883! - setFrom: newStart to: newStop - - position _ newStart - 1. - readLimit _ newStop! ! -!WriteStream methodsFor: 'fileIn/Out' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16946522! - 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; nextPut: terminator! ! -!WriteStream class methodsFor: 'instance creation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16946643 overrides: 50584033! - 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! ! -!WriteStream class methodsFor: 'instance creation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16946655! - with: aCollection - "Answer an instance of me on the argument, aCollection, positioned to - store objects at the end of aCollection." - - ^self basicNew with: aCollection! ! -!WriteStream class methodsFor: 'instance creation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16946663! - 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)! ! -!ReadWriteStream methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16898091 overrides: 16882612! - name - ^ 'a stream' "for fileIn compatibility"! ! -!ReadWriteStream methodsFor: 'fileIn/Out' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16898134! - fileNameEndsWith: aString - "See comment in FileStream fileNameEndsWith:" - - ^false! ! -!FileStream methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16843561 overrides: 50332169! - nextPut: aByte - "1/31/96 sw: subclassResponsibility" - - self subclassResponsibility! ! -!FileStream methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16843565 overrides: 50335228! - nextPutAll: aCollection - "1/31/96 sw: made subclass responsibility" - - self subclassResponsibility! ! -!FileStream methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16843570 overrides: 50584073! - size - "Answer the size of the file in characters. - 1/31/96 sw: made subclass responsibility" - - self subclassResponsibility! ! -!FileStream methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16843576 overrides: 50332155! - atEnd - "Answer true if the current position is >= the end of file position. - 1/31/96 sw: subclassResponsibility" - - self subclassResponsibility! ! -!FileStream methodsFor: 'positioning' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16843585 overrides: 50584001! - position - "Answer the current character position in the file. - 1/31/96 sw: subclassResponsibility" - - self subclassResponsibility! ! -!FileStream methodsFor: 'positioning' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16843591 overrides: 50584078! - position: pos - "Set the current character position in the file to pos. - 1/31/96 sw: made subclassResponsibility" - - self subclassResponsibility! ! -!FileStream methodsFor: 'positioning' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16843597 overrides: 50584085! - reset - "Set the current character position to the beginning of the file. - 1/31/96 sw: subclassResponsibility" - - self subclassResponsibility! ! -!FileStream methodsFor: 'positioning' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16843603 overrides: 16946437! - setToEnd - "Set the current character position to the end of the File. The same as - self position: self size. 1/31/96 sw: made subclassResponsibility" - - self subclassResponsibility! ! -!FileStream methodsFor: 'positioning' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16843610 overrides: 16891680! - skip: n - "Set the character position to n characters from the current position. - Error if not enough characters left in the file - 1/31/96 sw: made subclassResponsibility." - - self subclassResponsibility! ! -!FileStream methodsFor: 'file accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16843700 overrides: 50587737! - name - "Answer the name of the file for the page the receiver is streaming over. 1/31/96 sw: made subclassResponsibility" - - self subclassResponsibility! ! -!StandardFileStream methodsFor: 'open/close' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16912978 overrides: 16914059! - openReadOnly - "Open the receiver as a read-only file. 1/31/96 sw" - - ^ self open: name forWrite: false! ! -!StandardFileStream methodsFor: 'properties-setting' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16913001 overrides: 16891544! - isBinary - ^ buffer1 class == ByteArray! ! -!StandardFileStream methodsFor: 'access' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16913045! - isDirectory - "Answer whether the receiver represents a directory. For the post-transition case, uncertain what to do. 2/14/96 sw" - ^ false! ! -!StandardFileStream methodsFor: 'access' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16913073 overrides: 16914062! - printOn: aStream - "Put a printed version of the receiver onto aStream. 1/31/96 sw" - - aStream nextPutAll: self class name; nextPutAll: ': '; print: name! ! -!StandardFileStream methodsFor: 'access' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16913084 overrides: 50587763! - size - "Answer the size of the file in characters. 2/12/96 sw" - - ^ self primSize: fileID! ! -!StandardFileStream methodsFor: 'read, write, position' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16913445 overrides: 50587806! - setToEnd - "Set the position of the receiver to the end of file. 1/31/96 sw" - - self position: self size! ! -!DataStream methodsFor: 'write and read' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827175! - beginReference: anObject - "WeÕre starting to read anObject. Remember it and its reference - position (if we care; ReferenceStream cares). Answer the - reference position." - - ^ 0! ! -!DataStream methodsFor: 'write and read' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827183! - getCurrentReference - "PRIVATE -- Return the currentReference posn. - Overridden by ReferenceStream." - - ^ 0! ! -!DataStream methodsFor: 'write and read' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827305! - noteCurrentReference: typeID - "PRIVATE -- If we support references for type typeID, remember - the current byteStream position so we can add the next object to - the ÔobjectsÕ dictionary, and return true. Else return false. - This method is here to be overridden by ReferenceStream" - - ^ false! ! -!DataStream methodsFor: 'write and read' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827375! - readBitmap - "PRIVATE -- Read the contents of a Bitmap." - - ^ Bitmap newFromStream: byteStream - "Note that the reader knows that the size is in long words, but the data is in bytes."! ! -!DataStream methodsFor: 'write and read' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827405! - readFalse - "PRIVATE -- Read the contents of a False." - - ^ false! ! -!DataStream methodsFor: 'write and read' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827504! - readNil - "PRIVATE -- Read the contents of an UndefinedObject." - - ^ nil! ! -!DataStream methodsFor: 'write and read' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827574! - readSymbol - "PRIVATE -- Read the contents of a Symbol." - - ^ self readString asSymbol! ! -!DataStream methodsFor: 'write and read' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827579! - readTrue - "PRIVATE -- Read the contents of a True." - - ^ true! ! -!DataStream methodsFor: 'write and read' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827636! - setCurrentReference: refPosn - "PRIVATE -- Set currentReference to refPosn. - Noop here. Cf. ReferenceStream."! ! -!DataStream methodsFor: 'write and read' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827642! - tryToPutReference: anObject typeID: typeID - "PRIVATE -- If we support references for type typeID, and if - anObject already appears in my output stream, then put a - reference to the place where anObject already appears. If we - support references for typeID but didnÕt already put anObject, - then associate the current stream position with anObject in - case one wants to nextPut: it again. - Return true after putting a reference; false if the object still - needs to be put. - For DataStream this is trivial. ReferenceStream overrides this." - - ^ false! ! -!DataStream methodsFor: 'write and read' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827743! - writeFalse: aFalse - "PRIVATE -- Write the contents of a False."! ! -!DataStream methodsFor: 'write and read' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827756! - writeInstance: anObject - "PRIVATE -- Write the contents of an arbitrary instance." - - ^ anObject storeDataOn: self! ! -!DataStream methodsFor: 'write and read' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827770! - writeNil: anUndefinedObject - "PRIVATE -- Write the contents of an UndefinedObject."! ! -!DataStream methodsFor: 'write and read' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827796! - writeSymbol: aSymbol - "PRIVATE -- Write the contents of a Symbol." - - self writeString: aSymbol! ! -!DataStream methodsFor: 'write and read' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827801! - writeTrue: aTrue - "PRIVATE -- Write the contents of a True."! ! -!DataStream methodsFor: 'write and read' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827805! - writeUser: anObject - "Write the contents of an arbitrary User instance (and its devoted class)." - " 7/29/96 tk" - - "If anObject is an instance of a unique user class, will lie and say it has a generic class" - ^ anObject storeDataOn: self! ! -!DataStream methodsFor: 'other' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827827 overrides: 50587619! - atEnd - "Answer true if the stream is at the end." - - ^ byteStream atEnd! ! -!DataStream methodsFor: 'other' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827853 overrides: 16914006! - flush - "Guarantee that any writes to me are actually recorded on disk. -- 11/17/92 jhm" - - ^ byteStream flush! ! -!DataStream methodsFor: 'other' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827858 overrides: 50587570! - next: anInteger - "Answer an Array of the next anInteger objects in the stream." - | array | - - array _ Array new: anInteger. - 1 to: anInteger do: [:i | - array at: i put: self next]. - ^ array! ! -!DataStream methodsFor: 'other' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827866! - reset - "Reset the stream." - - byteStream reset! ! -!DataStream methodsFor: 'other' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16827903 overrides: 16880927! - size - "Answer the stream's size." - - ^ byteStream size! ! -!DummyStream methodsFor: 'error handling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16835845 overrides: 16881497! - subclassResponsibility - "Do nothing. Most messages to class Stream are defined as subclassResponsibility. Just accept them. 8/17/96 tk" - - "No error. Just go on."! ! -!DummyStream methodsFor: 'positioning' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16835830! - position - "Return any random number. Here is where the real lying begins. We are a DummyStream afterall. 8/17/96 tk" - - ^ 47 ! ! -!Compiler methodsFor: 'error handling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16822073 overrides: 16882681! - notify: aString - "Refer to the comment in Object|notify:." - - ^self notify: aString at: sourceStream position + 1! ! -!Compiler class methodsFor: 'evaluating' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16822127! - evaluate: textOrString for: anObject logged: logFlag - "See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs, - a Syntax Error view is created rather than notifying any requestor." - - ^self evaluate: textOrString for: anObject notifying: nil logged: logFlag! ! -!Compiler class methodsFor: 'evaluating' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16822158! - evaluate: textOrString logged: logFlag - "See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs, - a Syntax Error view is created rather than notifying any requestor. - Compilation is carried out with respect to nil, i.e., no object." - - ^self evaluate: textOrString for: nil logged: logFlag! ! -!Scanner methodsFor: 'expression types' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16903674! - advance - - | prevToken | - prevToken _ token. - self scanToken. - ^prevToken! ! -!Scanner methodsFor: 'initialization' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16904207! - scan: inputStream - "Bind the input stream, fill the character buffers and first token buffer." - - source _ inputStream. - self step. - self step. - self scanToken! ! -!Parser methodsFor: 'error handling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16885707 overrides: 50584146! - notify: aString - "Notify problem at token before 'here'." - - ^self notify: aString at: prevMark + requestorOffset! ! -!Parser methodsFor: 'scanning' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16885776! - startOfNextToken - "Return starting position in source of next token." - - hereType == #doIt ifTrue: [^source position + 1]. - ^hereMark! ! -!Parser methodsFor: 'primitives' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16885813! -allocateLiteral: lit - encoder litIndex: lit! ! -!Parser methodsFor: 'error correction' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16886751! - substituteSelector: selectorParts wordIntervals: spots - "Substitute the correctSelector into the (presuamed interactive) receiver." - | offset | - offset _ 0. - selectorParts with: spots do: - [ :word :interval | - offset _ self substituteWord: word wordInterval: interval offset: offset ] -! ! -!ParseNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16884672! - assignmentCheck: encoder at: location - "For messageNodes masquerading as variables for the debugger. - For now we let this through - ie we allow stores ev - into args. Should check against numArgs, though." - ^ -1! ! -!ParseNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16884693 overrides: 16882560! - isComplex - "Used for pretty printing to determine whether to start a new line" - - ^false! ! -!ParseNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16884697! - isConstantNumber "Overridden in LiteralNode" - ^false! ! -!ParseNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16884709! - isMessage: selSymbol receiver: rcvrPred arguments: argsPred - "See comment in MessageNode." - - ^false! ! -!ParseNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16884746! - isSpecialConstant - ^ false! ! -!ParseNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16884773! - toDoIncrement: ignored - "Only meant for Messages or Assignments - else return nil" - ^ nil! ! -!Encoder methodsFor: 'results' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16837214! - literals - "Should only be used for decompiling primitives" - ^ literalStream contents! ! -!Encoder methodsFor: 'encoding' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16837445! - encodeLiteral: object - - ^self - name: object - key: (class literalScannedAs: object notifying: self) - class: LiteralNode - type: LdLitType - set: litSet! ! -!Encoder methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16837571! - classEncoding - "This is a hack so that the parser may findout what class it was parsing for when it wants to create a syntax error view." - ^ class! ! -!Encoder methodsFor: 'private' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16837627! - reallyBind: name - - | node | - node _ self newTemp: name. - scopeTable at: name put: node. - ^node! ! -!Encoder methodsFor: 'error handling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16837696 overrides: 50585820! - notify: string at: location - - | req | - requestor == nil - ifFalse: - [req _ requestor. - self release. - req notify: string at: location]. - ^false! ! -!AssignmentNode methodsFor: 'equation translation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16780812! - variable - ^variable! ! -!AssignmentNode methodsFor: 'initialization' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16780815 overrides: 50588180! - toDoIncrement: var - var = variable ifFalse: [^ nil]. - (value isMemberOf: MessageNode) - ifTrue: [^ value toDoIncrement: var] - ifFalse: [^ nil]! ! -!AssignmentNode methodsFor: 'initialization' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16780822 overrides: 16881508! - value - ^ value! ! -!BraceNode methodsFor: 'enumerating' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16790981! - casesForwardDo: aBlock - "For each case in forward order, evaluate aBlock with three arguments: - the key block, the value block, and whether it is the last case." - - | numCases case | - 1 to: (numCases _ elements size) do: - [:i | - case _ elements at: i. - aBlock value: case receiver value: case arguments first value: i=numCases]! ! -!BraceNode methodsFor: 'enumerating' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16790993! - casesReverseDo: aBlock - "For each case in reverse order, evaluate aBlock with three arguments: - the key block, the value block, and whether it is the last case." - - | numCases case | - (numCases _ elements size) to: 1 by: -1 do: - [:i | - case _ elements at: i. - aBlock value: case receiver value: case arguments first value: i=numCases]! ! -!BraceNode methodsFor: 'initialization' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16791107! - elements: collection - "Decompile." - - elements _ collection! ! -!BraceNode methodsFor: 'initialization' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16791111! - elements: collection sourceLocations: locations - "Compile." - - elements _ collection. - sourceLocations _ locations! ! -!BraceNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16790978! - numElements - - ^ elements size! ! -!CascadeNode methodsFor: 'printing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16795225 overrides: 50584215! - printOn: aStream indent: level - self printOn: aStream indent: level precedence: 0! ! -!CascadeNode methodsFor: 'initialization' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16795271! - receiver: receivingObject messages: msgs - " Transcript show: 'abc'; cr; show: 'def' " - - receiver _ receivingObject. - messages _ msgs! ! -!BlockNode methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16789601! - firstArgument - ^ arguments first! ! -!BlockNode methodsFor: 'equation translation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16790009! - statements - ^statements! ! -!BlockNode methodsFor: 'equation translation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16790012! -statements: val - statements _ val! ! -!BlockNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16789691! - isJustCaseError - - ^ statements size = 1 and: - [statements first - isMessage: #caseError - receiver: [:r | r==NodeSelf] - arguments: nil]! ! -!BlockNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16789697! - isQuick - ^ statements size = 1 - and: [statements first isVariableReference - or: [statements first isSpecialConstant]]! ! -!MethodNode methodsFor: 'code generation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16872469! - encoder - ^ encoder! ! -!LiteralNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16865085 overrides: 50588165! - isConstantNumber - ^ key isNumber! ! -!LiteralNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16865091 overrides: 50588176! - isSpecialConstant - ^ code between: LdTrue and: LdMinus1+3! ! -!LiteralNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16865095! - literalValue - - ^key! ! -!SelectorNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16905022! - isPvtSelector - "Answer if this selector node is a private message selector." - - ^key isPvtSelector! ! -!VariableNode methodsFor: 'initialization' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16942032! - asStorableNode: encoder - ^ self! ! -!MessageNode methodsFor: 'equation translation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16867985! - arguments - ^arguments! ! -!MessageNode methodsFor: 'equation translation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16868005! -receiver - ^receiver! ! -!MessageNode methodsFor: 'equation translation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16868013! - selector - ^selector! ! -!MessageNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16868504 overrides: 50588170! - isMessage: selSymbol receiver: rcvrPred arguments: argsPred - "Answer whether selector is selSymbol, and the predicates rcvrPred and argsPred - evaluate to true with respect to receiver and the list of arguments. If selSymbol or - either predicate is nil, it means 'don't care'. Note that argsPred takes numArgs - arguments. All block arguments are ParseNodes." - - ^(selSymbol isNil or: [selSymbol==selector key]) and: - [(rcvrPred isNil or: [rcvrPred value: receiver]) and: - [(argsPred isNil or: [argsPred valueWithArguments: arguments])]]! ! -!MessageNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16868553 overrides: 50588180! - toDoIncrement: variable - (receiver = variable and: [selector key = #+]) - ifFalse: [^ nil]. - arguments first isConstantNumber - ifTrue: [^ arguments first] - ifFalse: [^ nil]! ! -!MessageNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16868560! - toDoLimit: variable - (receiver = variable and: [selector key = #<= or: [selector key = #>=]]) - ifTrue: [^ arguments first] - ifFalse: [^ nil]! ! -!ReturnNode methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16901106 overrides: 50588176! -isSpecialConstant - - ^expr isSpecialConstant! ! -!DecompilerConstructor methodsFor: 'constructor' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16832504! - codeBrace: elements - - ^BraceNode new elements: elements! ! -!ParseStack methodsFor: 'printing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16885466 overrides: 50508084! - printOn: aStream - - super printOn: aStream. - aStream nextPutAll: ' at '; print: position; nextPutAll: ' of '; print: length! ! -!DiskProxy class methodsFor: 'as yet unclassified' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16835074! - global: globalNameSymbol selector: selectorSymbol args: argArray - "Create a new DiskProxy constructor with the given - globalNameSymbol, selectorSymbol, and argument Array. - It will internalize itself by looking up the global object name - in the SystemDictionary (Smalltalk) and sending it this message - with these arguments." - - ^ self new global: globalNameSymbol - selector: selectorSymbol - args: argArray! ! -!Form methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16846766! -extent - ^ width @ height! ! -!Form methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16846774! - height - ^ height! ! -!Form methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16846795! - width - ^ width! ! -!Form methodsFor: 'analyzing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16846848! - innerPixelRectFor: pv orNot: not - "Return a rectangle describing the smallest part of me that includes - all pixels of value pv. - Note: If orNot is true, then produce a copy that includes all pixels - that are DIFFERENT from the supplied (background) value" - - | xTally yTally | - xTally _ self xTallyPixelValue: pv orNot: not. - yTally _ self yTallyPixelValue: pv orNot: not. - ^ ((xTally findFirst: [:t | t>0]) - 1) @ ((yTally findFirst: [:t | t>0]) - 1) - corner: - (xTally findLast: [:t | t>0])@(yTally findLast: [:t | t>0])! ! -!Form methodsFor: 'fileIn/Out' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16847837 overrides: 50584941! - storeOn: aStream - - self storeOn: aStream base: 10! ! -!Form methodsFor: 'filling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16847961! - fillFromXColorBlock: colorBlock - "Horizontal Gradient Fill. - Supply relative x in [0.0 ... 1.0] to colorBlock, - and paint each pixel with the color that comes back" - | xRel | - 0 to: width-1 do: - [:x | xRel _ x asFloat / (width-1) asFloat. - self fill: (x@0 extent: 1@height) - fillColor: (colorBlock value: xRel)] -" -((Form extent: 100@100 depth: Display depth) - fillFromXColorBlock: [:x | Color r: x g: 0.0 b: 0.5]) display -"! ! -!Form methodsFor: 'filling' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16847998! - fillFromYColorBlock: colorBlock - "Vertical Gradient Fill. - Supply relative y in [0.0 ... 1.0] to colorBlock, - and paint each pixel with the color that comes back" - | yRel | - 0 to: height-1 do: - [:y | yRel _ y asFloat / (height-1) asFloat. - self fill: (0@y extent: width@1) - fillColor: (colorBlock value: yRel)] -" -((Form extent: 100@100 depth: Display depth) - fillFromYColorBlock: [:y | Color r: y g: 0.0 b: 0.5]) display -"! ! -!Form class methodsFor: 'instance creation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16849047! - fromDisplay: aRectangle - "Answer an instance of me with bitmap initialized from the area of the - display screen defined by aRectangle." - - ^ (self extent: aRectangle extent depth: Display depth) - fromDisplay: aRectangle! ! -!Form class methodsFor: 'mode constants' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16849123! - blend - "Answer the integer denoting BitBlt's alpha blend combination rule." - ^24! ! -!Cursor class methodsFor: 'class initialization' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16826361 overrides: 50335342! - startUp - self currentCursor: self currentCursor! ! -!BitBlt methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16785492! - clipRect - "Answer the receiver's clipping area rectangle." - - ^clipX @ clipY extent: clipWidth @ clipHeight! ! -!BitBlt methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16785515! - combinationRule: anInteger - "Set the receiver's combination rule to be the argument, anInteger, a - number in the range 0-15." - - combinationRule _ anInteger! ! -!BitBlt methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16785522! - destForm - ^ destForm! ! -!BitBlt methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16785542! - destX: anInteger - "Set the top left x coordinate of the receiver's destination form to be the - argument, anInteger." - - destX _ anInteger! ! -!BitBlt methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16785554! - destY: anInteger - "Set the top left y coordinate of the receiver's destination form to be the - argument, anInteger." - - destY _ anInteger! ! -!BitBlt methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16785590! - height: anInteger - "Set the receiver's destination form height to be the argument, anInteger." - - height _ anInteger! ! -!BitBlt methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16785597! - sourceForm: aForm - "Set the receiver's source form to be the argument, aForm." - - sourceForm _ aForm! ! -!BitBlt methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16785602! - sourceOrigin: aPoint - "Set the receiver's source form coordinates to be those of the argument, - aPoint." - - sourceX _ aPoint x. - sourceY _ aPoint y! ! -!BitBlt methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16785608! - sourceRect: aRectangle - "Set the receiver's source form top left x and y, width and height to be - the top left coordinate and extent of the argument, aRectangle." - - sourceX _ aRectangle left. - sourceY _ aRectangle top. - width _ aRectangle width. - height _ aRectangle height! ! -!BitBlt methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16785618! - sourceX: anInteger - "Set the receiver's source form top left x to be the argument, anInteger." - - sourceX _ anInteger! ! -!BitBlt methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16785623! - sourceY: anInteger - "Set the receiver's source form top left y to be the argument, anInteger." - - sourceY _ anInteger! ! -!BitBlt methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16785628! - width: anInteger - "Set the receiver's destination form width to be the argument, anInteger." - - width _ anInteger! ! -!BitBlt methodsFor: 'copying' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16785755! - copyForm: srcForm to: destPt rule: rule fillColor: color - sourceForm _ srcForm. - self fillColor: color. "sets halftoneForm" - combinationRule _ rule. - destX _ destPt x + sourceForm offset x. - destY _ destPt y + sourceForm offset y. - sourceX _ 0. - sourceY _ 0. - width _ sourceForm width. - height _ sourceForm height. - self copyBits! ! -!BitBlt methodsFor: 'copying' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16785783! - fill: destRect fillColor: grayForm rule: rule - "Fill with a Color, not a Form. 6/18/96 tk" - sourceForm _ nil. - self fillColor: grayForm. "sets halftoneForm" - combinationRule _ rule. - destX _ destRect left. - destY _ destRect top. - sourceX _ 0. - sourceY _ 0. - width _ destRect width. - height _ destRect height. - self copyBits! ! -!BitBlt class methodsFor: 'instance creation' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16786233! - toForm: aForm - ^ self new setDestForm: aForm! ! -!Point methodsFor: 'arithmetic' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16890272! - abs - "Answer a Point whose x and y are the absolute values of the receiver's x - and y." - - ^ x abs @ y abs! ! -!Point methodsFor: 'comparing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16890318! - max: aPoint - "Answer the lower right corner of the rectangle uniquely defined by the - receiver and the argument, aPoint." - - ^ (x max: aPoint x) @ (y max: aPoint y)! ! -!Point methodsFor: 'comparing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16890325! - min: aPoint - "Answer the upper left corner of the rectangle uniquely defined by the - receiver and the argument, aPoint." - - ^ (x min: aPoint x) @ (y min: aPoint y)! ! -!Point methodsFor: 'comparing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16890332! - min: aMin max: aMax - - ^ (self min: aMin) max: aMax! ! -!Point methodsFor: 'converting' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16890355! - asIntegerPoint - ^ x asInteger @ y asInteger! ! -!Point methodsFor: 'point functions' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16890595! - normal - "Answer a Point representing the unit vector rotated 90 deg clockwise." - - | n | - n _ y negated @ x. - ^n / (n x * n x + (n y * n y)) sqrt! ! -!Point methodsFor: 'printing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16890722 overrides: 50584941! - storeOn: aStream - "x@y printed form is good for storing too" - self printOn: aStream! ! -!Point methodsFor: 'truncation and round off' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16890822! - truncateTo: grid - "Answer a Point that is the receiver's x and y truncated to grid x and - grid y." - | gridPoint | - gridPoint _ grid asPoint. - ^(x truncateTo: gridPoint x) @ (y truncateTo: gridPoint y)! ! -!Rectangle methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16898531! - boundingBox - ^ self! ! -!Rectangle methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16898542! - corners - "Return an array of corner points in the order of a quadrilateral spec for WarpBlt" - ^ Array with: self topLeft with: self bottomLeft with: self bottomRight with: self topRight! ! -!Rectangle methodsFor: 'comparing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16898639 overrides: 16881052! - hash - "Hash is reimplemented because = is implemented." - - ^origin hash bitXor: corner hash! ! -!Rectangle methodsFor: 'rectangle functions' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16898644! - amountToTranslateWithin: aRectangle - "Answer a Point, delta, such that self + delta is forced within aRectangle." - "Altered so as to prefer to keep self topLeft inside when all of self - cannot be made to fit 7/27/96 di" - | dx dy | - dx _ 0. dy _ 0. - self right > aRectangle right ifTrue: [dx _ aRectangle right - self right]. - self bottom > aRectangle bottom ifTrue: [dy _ aRectangle bottom - self bottom]. - (self left + dx) < aRectangle left ifTrue: [dx _ aRectangle left - self left]. - (self top + dy) < aRectangle top ifTrue: [dy _ aRectangle top - self top]. - ^ dx@dy! ! -!Rectangle methodsFor: 'rectangle functions' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16898707! - encompass: aPoint - "Answer a Rectangle that contains both the receiver and aPoint. 5/30/96 sw" - - ^ Rectangle - origin: (origin min: aPoint) - corner: (corner max: aPoint)! ! -!Rectangle methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16898881! - hasPositiveExtent - ^ (corner x > origin x) and: [corner y > origin y]! ! -!Rectangle methodsFor: 'truncation and round off' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16898926! - truncateTo: grid - "Answer a Rectangle whose origin and corner are truncated to grid x and grid y." - - ^Rectangle origin: (origin truncateTo: grid) - corner: (corner truncateTo: grid)! ! -!StrikeFont methodsFor: 'emphasis' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16914427! - emphasis - "Answer the integer code for synthetic bold, italic, underline, and - strike-out." - - ^emphasis! ! -!ChangeSet methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16797742! - name: anObject - name _ anObject! ! -!ChangeSet methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16797745 overrides: 50508084! - printOn: aStream - "2/7/96 sw: provide the receiver's name in the printout" - super printOn: aStream. - aStream nextPutAll: ' named ', self name! ! -!ChangeSet methodsFor: 'testing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16797770! - isMoribund - "Answer whether the receiver is obsolete and about to die; part of an effort to get such guys cleared out from the change sorter. 2/7/96 sw" - - ^ name == nil ! ! -!PopUpMenu methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16890913! - labelString - - ^ labelString! ! -!PopUpMenu methodsFor: 'accessing' stamp: 'Squeak1.0 9/20/1996 10:50:05' prior: 16890916! - lineArray - - ^ lineArray! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4703-Squeak1.0-stamps-JuanVuletich-2021Jul27-19h21m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4702] on 27 July 2021 at 7:24:05 pm'! -!Object methodsFor: 'translation support' stamp: 'Squeak1.1 9/23/1996 20:34:59' prior: 16882640! - var: varSymbol declareC: declString - "For translation only; noop when running in Smalltalk."! ! -!SequenceableCollection methodsFor: 'accessing' stamp: 'Squeak1.1 9/23/1996 20:34:59' prior: 16905736! - indexOf: anElement startingAt: start 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." - start to: self size do: - [:i | (self at: i) = anElement ifTrue: [^ i]]. - ^ exceptionBlock value! ! -!FileStream class methodsFor: 'concrete classes' stamp: 'Squeak1.1 9/23/1996 20:34:59' prior: 16843725! - concreteStream - "Who should we really direct class queries to? 9/21/96 tk" - ^ StandardFileStream! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4704-Squeak1.1-stamps-JuanVuletich-2021Jul27-19h23m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4702] on 27 July 2021 at 7:25:19 pm'! -!Object methodsFor: 'comparing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16881052! - hash - "Answer a SmallInteger whose value is related to the receiver's identity. - May be overridden, and should be overridden in any classes that define = " - - ^ self identityHash! ! -!Object methodsFor: 'translation support' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16882631! - inline: inlineFlag - "For translation only; noop when running in Smalltalk."! ! -!Browser methodsFor: 'metaclass' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16792478! - classOrMetaClassOrganizer - "Answer the class organizer for the metaclass or class, depending on - which (instance or class) is indicated." - - self metaClassIndicated - ifTrue: [^metaClassOrganizer] - ifFalse: [^classOrganizer]! ! -!HierarchyBrowser methodsFor: 'initialization' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16853552! - initAlphabeticListing - | tab stab index | - self systemOrganizer: SystemOrganization. - metaClassIndicated _ false. - classList _ Smalltalk classNames.! ! -!Color methodsFor: 'conversions' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50353560! - pixelWordForDepth: depth - "Return to a 32-bit word that concatenates enough copies of the receiver's pixel value to fill the word (i.e., 32/depth copies). Depth should be one of 1, 2, 4, 8, 16, or 32. The pixel value should be an integer in 0..2^depth-1." - - | pixelValue | - pixelValue _ self pixelValueForDepth: depth. - ^ self pixelWordFor: depth filledWith: pixelValue -! ! -!Color methodsFor: 'queries' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50353823! - isTransparent - - ^ false -! ! -!Color methodsFor: 'private' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50354192! - attemptToMutateError - "A color is immutable. Once a color's red, green, and blue have been initialized, you cannot change them. Instead, create a new Color and use it." - - self error: 'Color objects are immutable once created' -! ! -!Color class methodsFor: 'examples' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50357092! - showColorCube - "Show a 12x12x12 color cube." - "Color showColorCube" - - 0 to: 11 do: [:r | - 0 to: 11 do: [:g | - 0 to: 11 do: [:b | - Display fill: (((r*60) + (b*5)) @ (g*5) extent: 5@5) - fillColor: (Color r: r g: g b: b range: 11)]]]. -! ! -!Color class methodsFor: 'examples' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50357102! - showHSVPalettes - "Shows a palette of hues, varying the saturation and brightness for each one. Best results are with depths 16 and 32." - "Color showHSVPalettes" - - | left top c | - left _ top _ 0. - 0 to: 179 by: 15 do: [:h | - 0 to: 10 do: [:s | - left _ (h * 4) + (s * 4). - 0 to: 10 do: [:v | - c _ Color h: h s: s asFloat / 10.0 v: v asFloat / 10.0. - top _ (v * 4). - Display fill: (left@top extent: 4@4) fillColor: c. - - c _ Color h: h + 180 s: s asFloat / 10.0 v: v asFloat / 10.0. - top _ (v * 4) + 50. - Display fill: (left@top extent: 4@4) fillColor: c]]]. -! ! -!Color class methodsFor: 'examples' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50357123! - wheel: thisMany - "Return a collection of thisMany colors evenly spaced around the color wheel." - "Color showColors: (Color wheel: 12)" - - ^ Color wheel: thisMany saturation: 0.9 brightness: 0.7 -! ! -!Color class methodsFor: 'examples' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50357132! -wheel: thisMany saturation: s brightness: v - "Return a collection of thisMany colors evenly spaced around the color wheel, all of the given saturation and brightness." - "Color showColors: (Color wheel: 12 saturation: 0.4 brightness: 1.0)" - "Color showColors: (Color wheel: 12 saturation: 0.8 brightness: 0.5)" - - ^ (Color h: 0.0 s: s v: v) wheel: thisMany -! ! -!Color class methodsFor: 'colormaps' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50357146! - colorMapIfNeededFrom: sourceDepth to: destDepth - "Return a colormap for mapping between the given depths, or nil if no colormap is needed." - "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" - - sourceDepth = destDepth ifTrue: [^ nil]. "not needed if depths are the same" - - (sourceDepth >= 16) & (destDepth >= 16) ifTrue: [ - "mapping is done in BitBlt by zero-filling or truncating each color component" - ^ nil]. - - ^ Color cachedColormapFrom: sourceDepth to: destDepth -! ! -!UndefinedObject methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16940085 overrides: 16896431! - ifNil: aBlock - "A convenient test, in conjunction with Object ifNil:" - - ^ aBlock value! ! -!UndefinedObject methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16940090 overrides: 16896436! - ifNil: nilBlock ifNotNil: ifNotNilBlock - "Evaluate the block for nil because I'm == nil" - - ^ nilBlock value! ! -!UndefinedObject methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16940095 overrides: 16896443! - ifNotNil: aBlock - "A convenient test, in conjunction with Object ifNotNil:" - - ^ self! ! -!UndefinedObject methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16940100 overrides: 16896449! - ifNotNil: ifNotNilBlock ifNil: nilBlock - "If I got here, I am nil, so evaluate the block nilBlock" - - ^ nilBlock value! ! -!Float methodsFor: 'mathematical functions' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16844629 overrides: 50586488! - cos - "Answer the cosine of the receiver taken as an angle in radians." - - ^ (self + Halfpi) sin! ! -!Float methodsFor: 'mathematical functions' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16844660 overrides: 16880129! - log - "Answer the base 10 logarithm of the receiver." - - ^ self ln / Ln10! ! -!Float methodsFor: 'mathematical functions' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16844743 overrides: 50586502! - tan - "Answer the tangent of the receiver taken as an angle in radians." - - ^ self sin / self cos! ! -!Float methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16845080 overrides: 16882565! - isFloat - ^ true! ! -!Fraction methodsFor: 'converting' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16849622 overrides: 16882569! - isFraction - ^ true! ! -!Integer methodsFor: 'private' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16860530! - digitRshift: anInteger bytes: b lookfirst: a - "Shift right 8*b+anInteger bits, 0<=n<8. - Discard all digits beyond a, and all zeroes at or below a." - | n x r f m digit count i | - n _ 0 - anInteger. - x _ 0. - f _ n + 8. - i _ a. - m _ 255 bitShift: 0 - f. - digit _ self digitAt: i. - [((digit bitShift: n) bitOr: x) = 0 and: [i ~= 1]] whileTrue: - [x _ digit bitShift: f "Can't exceed 8 bits". - i _ i - 1. - digit _ self digitAt: i]. - i <= b ifTrue: [^Integer new: 0 neg: self negative]. "All bits lost" - r _ Integer new: i - b neg: self negative. - count _ i. - x _ (self digitAt: b + 1) bitShift: n. - b + 1 to: count do: - [:j | digit _ self digitAt: j + 1. - r digitAt: j - b put: (((digit bitAnd: m) bitShift: f) bitOr: x) - "Avoid values > 8 bits". - x _ digit bitShift: n]. - ^r! ! -!SmallInteger methodsFor: 'comparing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16908913 overrides: 50496967! - identityHash - - ^self! ! -!MessageTally methodsFor: 'tallying' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16870803! - bumpBy: count - - tally _ tally + count! ! -!ContextPart class methodsFor: 'examples' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16825361! - tallyInstructions: aBlock - "This method uses the simulator to count the number of occurrences of - each of the Smalltalk instructions executed during evaluation of aBlock. - Results appear in order of the byteCode set." - | tallies | - tallies _ Bag new. - thisContext sender - runSimulated: aBlock - contextAtEachStep: - [:current | tallies add: current nextByte]. - ^tallies sortedElements - - "ContextPart tallyInstructions: [3.14159 printString]"! ! -!InputSensor methodsFor: 'joystick' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16856269! - joystickButtons: index - - ^ ((self primReadJoystick: index) bitShift: -22) bitAnd: 16r71F - ! ! -!InputSensor methodsFor: 'joystick' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16856274! - joystickOn: index - - ^ (((self primReadJoystick: index) bitShift: -27) bitAnd: 1) ~= 0 - ! ! -!InputSensor methodsFor: 'joystick' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16856279! - joystickXY: index - - | inputWord x y | - inputWord _ self primReadJoystick: index. - x _ (inputWord bitAnd: 16r7FF) - 16r400. - y _ ((inputWord bitShift: -11) bitAnd: 16r7FF) - 16r400. - ^ x@y - ! ! -!String methodsFor: 'accessing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16915787! - 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! ! -!ByteArray methodsFor: 'converting' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16793767 overrides: 16881101! - 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! ! -!CompiledMethod methodsFor: 'printing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16819939 overrides: 16793841! - storeOn: aStream - | noneYet | - aStream nextPutAll: '(('. - aStream nextPutAll: self class name. - aStream nextPutAll: ' newMethod: '. - aStream store: self size - self initialPC + 1. - aStream nextPutAll: ' header: '. - aStream store: self header. - aStream nextPut: $). - noneYet _ self storeElementsFrom: self initialPC to: self endPC on: aStream. - 1 to: self numLiterals do: - [:index | - noneYet - ifTrue: [noneYet _ false] - ifFalse: [aStream nextPut: $;]. - aStream nextPutAll: ' literalAt: '. - aStream store: index. - aStream nextPutAll: ' put: '. - aStream store: (self literalAt: index)]. - noneYet ifFalse: [aStream nextPutAll: '; yourself']. - aStream nextPut: $)! ! -!CompiledMethod methodsFor: 'scanning' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16820294! - scanLongStore: extension - "Answer whether the receiver contains a long store whose extension is - the argument." - | scanner | - scanner _ InstructionStream on: self. - ^scanner scanFor: - [:instr | (instr = 129 or: [instr = 130]) and: [scanner followingByte = extension]]! ! -!CompiledMethod methodsFor: 'scanning' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16820304! - scanVeryLongLoad: extension offset: offset - "Answer whether the receiver contains a long load whose extension is the - argument." - | scanner | - scanner _ InstructionStream on: self. - ^ scanner scanFor: [:instr | (instr = 132 and: [scanner followingByte = extension]) - and: [scanner thirdByte = offset]]! ! -!CompiledMethod methodsFor: 'scanning' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16820337! - sendsToSuper - "Answer whether the receiver sends any message to super." - | scanner | - scanner _ InstructionStream on: self. - ^ scanner scanFor: - [:instr | instr = 16r85 or: [instr = 16r84 - and: [scanner followingByte between: 16r20 and: 16r3F]]]! ! -!CompiledMethod class methodsFor: 'instance creation' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16821370 overrides: 50474854! - new - "This will not make a meaningful method, but it could be used - to invoke some otherwise useful method in this class." - ^ self newMethod: 0 header: 0! ! -!Bitmap methodsFor: 'accessing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16787561! - 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." - - - self errorImproperStore.! ! -!OrderedCollection methodsFor: 'copying' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16883908 overrides: 50332597! - 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! ! -!RunArray methodsFor: 'accessing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16901164 overrides: 16880774! - at: index - - self at: index setRunOffsetAndValue: [:run :offset :value | ^value]! ! -!RunArray methodsFor: 'accessing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16901179! - runLengthAt: index - "Answer the length remaining in run beginning at index." - - self at: index - setRunOffsetAndValue: [:run :offset :value | ^(runs at: run) - offset]! ! -!Set methodsFor: 'private' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16907201! - 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!!'.! ! -!Set methodsFor: 'private' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16907277! - 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 | - 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) == 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"! ! -!Dictionary methodsFor: 'removing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16833629! - removeUnreferencedKeys "Undeclared removeUnreferencedKeys" - - ^ self unreferencedKeys do: [:key | self removeKey: key].! ! -!Dictionary methodsFor: 'private' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16833777 overrides: 50589336! - 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 | - 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) == 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"! ! -!MethodDictionary methodsFor: 'private' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16872204 overrides: 50589371! - 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 | - start _ (anObject identityHash \\ array size) + 1. - finish _ array size. - - "Search from (hash mod size) to the end." - start to: finish do: - [:index | ((element _ self basicAt: index) == nil or: [element == anObject]) - ifTrue: [^ index ]]. - - "Search from 1 to where we started." - 1 to: start-1 do: - [:index | ((element _ self basicAt: index) == nil or: [element == anObject]) - ifTrue: [^ index ]]. - - ^ 0 "No match AND no empty slot"! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16919596! - cleanOutUndeclared - Undeclared removeUnreferencedKeys! ! -!SystemDictionary methodsFor: 'memory space' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16920436! - okayToProceedEvenIfSpaceIsLow - "Return true if either there is enough memory to do so safely or if the user gives permission after being given fair warning." - - self garbageCollectMost > self lowSpaceThreshold ifTrue: [^ true]. "quick" - self garbageCollect > self lowSpaceThreshold ifTrue: [^ true]. "work harder" - - ^ self confirm: -'WARNING: There is not enough space to start the low space watcher. -If you proceed, you will not be warned again, and the system may -run out of memory and crash. If you do proceed, you can start the -low space notifier when more space becomes available simply by -opening and then closing a debugger (e.g., by hitting Cmd-period.) -Do you want to proceed?' -! ! -!SystemDictionary methodsFor: 'retrieving' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16922107! - pointersTo: anObject - "Find all occurrences in the system of pointers to the argument anObject." - "(Smalltalk pointersTo: Browser) inspect." - - ^ self pointersTo: anObject except: #() -! ! -!SystemDictionary methodsFor: 'special objects' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16923703! - specialNargsAt: anInteger - "Answer the number of arguments for the special selector at: anInteger." - - ^ (self specialObjectsArray at: 24) at: anInteger * 2! ! -!SystemDictionary methodsFor: 'special objects' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16923715! - specialSelectorAt: anInteger - "Answer the special message selector from the interleaved specialSelectors array." - - ^ (self specialObjectsArray at: 24) at: anInteger * 2 - 1! ! -!SystemDictionary methodsFor: 'special objects' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16923723! - specialSelectorSize - "Answer the number of special selectors in the system." - - ^ (self specialObjectsArray at: 24) size // 2! ! -!DataStream methodsFor: 'other' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16827831! - byteStream - ^ byteStream! ! -!SmartRefStream methodsFor: 'read write' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16911414! - structures - ^ structures! ! -!Parser methodsFor: 'temps' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16886422! - bindArg: name - - ^ self bindTemp: name! ! -!ParseNode methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16884751! - isUndefTemp - ^ false! ! -!ParseNode methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16884753! - isUnusedTemp - ^ false! ! -!ParseNode methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16884761! - nowHasDef "Ignored in all but VariableNode"! ! -!ParseNode methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16884764! - nowHasRef "Ignored in all but VariableNode"! ! -!Encoder methodsFor: 'temps' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16837428! - newTemp: name - - nTemps _ nTemps + 1. - ^ TempVariableNode new - name: name - index: nTemps - 1 - type: LdTempType - scope: 0! ! -!Encoder methodsFor: 'source mapping' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16837652! - sourceMap - "Answer with a sorted set of associations (pc range)." - - ^ (sourceRanges keys collect: - [:key | Association key: key pc value: (sourceRanges at: key)]) - asSortedCollection! ! -!Encoder methodsFor: 'initialization' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16837706! - fillDict: dict with: nodeClass mapping: keys to: codeArray - | codeStream | - codeStream _ ReadStream on: codeArray. - keys do: - [:key | dict - at: key - put: (nodeClass new name: key key: key code: codeStream next)]! ! -!TempVariableNode methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16927173 overrides: 16884749! - isTemp - ^ true! ! -!TempVariableNode methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16927175 overrides: 50589505! - isUndefTemp - ^ hasDefs not! ! -!TempVariableNode methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16927178 overrides: 50589509! - isUnusedTemp - ^ hasRefs not! ! -!TempVariableNode methodsFor: 'initialization' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16927317 overrides: 50589513! - nowHasDef - hasDefs _ true! ! -!TempVariableNode methodsFor: 'initialization' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16927320 overrides: 50589518! - nowHasRef - hasRefs _ true! ! -!TempVariableNode methodsFor: 'initialization' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16927323! - scope: level - "Note scope of temporary variables. - Currently only the following distinctions are made: - 0 outer level: args and user-declared temps - 1 block args and doLimiT temps - -1 a block temp that is no longer active - -2 a block temp that held limit of to:do:" - scope _ level! ! -!DecompilerConstructor methodsFor: 'constructor' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16832523! - codeConstants - "Answer with an array of the objects representing self, true, false, nil, - -1, 0, 1, 2." - - ^(Array with: NodeSelf with: NodeTrue with: NodeFalse with: NodeNil) - , ((-1 to: 2) collect: [:i | LiteralNode new key: i code: LdMinus1 + i + 1])! ! -!DecompilerConstructor methodsFor: 'constructor' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16832633! - codeTemp: index named: tempName - - ^ TempVariableNode new - name: tempName - index: index - type: LdTempType - scope: 0! ! -!TextAttribute methodsFor: 'as yet unclassified' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16930191! - actOnClickFor: model - "Subclasses may override to provide, eg, hot-spot actions" - ^ false! ! -!TextAttribute methodsFor: 'as yet unclassified' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16930219! - dominates: another - "Subclasses may override condense multiple attributes" - ^ false! ! -!TextAttribute methodsFor: 'as yet unclassified' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16930229! - mayActOnClick - "Subclasses may override to provide, eg, hot-spot actions" - ^ false! ! -!TextAction methodsFor: 'as yet unclassified' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16929976 overrides: 50589621! - mayActOnClick - - ^ true! ! -!TextColor methodsFor: 'accessing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16930335! - color - ^ color! ! -!TextColor methodsFor: 'accessing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16930337! - color: aColor - color _ aColor! ! -!TextColor methodsFor: 'printing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16930349 overrides: 50508084! - printOn: strm - super printOn: strm. - strm nextPutAll: ' code: '; print: color! ! -!TextColor class methodsFor: 'instance creation' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16930401! - color: aColor - ^ self new color: aColor! ! -!TextEmphasis methodsFor: 'as yet unclassified' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16933297 overrides: 16930225! - emphasisCode - ^ emphasisCode! ! -!TextEmphasis methodsFor: 'printing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16933310 overrides: 50508084! - printOn: strm - super printOn: strm. - strm nextPutAll: ' code: '; print: emphasisCode! ! -!RemoteString methodsFor: 'accessing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16900599! - position - "Answer the location of the string on a file." - - ^ filePositionHi! ! -!RemoteString methodsFor: 'private' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16900659! - fileNumber: fileNumber position: position - - sourceFileNumber _ fileNumber. - filePositionHi _ position! ! -!Form methodsFor: 'accessing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16846790 overrides: 16880927! - size - "Should no longer be used -- use bitsSize instead. length of variable part of instance." - ^ super size! ! -!Form methodsFor: 'copying' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16847613! - copy: sourceRectangle from: sourceForm to: destPt rule: rule - ^ self copy: (destPt extent: sourceRectangle extent) - from: sourceRectangle topLeft in: sourceForm rule: rule! ! -!Form methodsFor: 'scaling, rotation' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16848476! - shrink: aRectangle by: scale - | scalePt | - scalePt _ scale asPoint. - ^ self magnify: aRectangle by: (1.0 / scalePt x asFloat) @ (1.0 / scalePt y asFloat)! ! -!Form class methodsFor: 'mode constants' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16849137! - erase1bitShape - "Answer the integer denoting mode erase." - - ^ 26! ! -!Form class methodsFor: 'mode constants' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16849141! - oldErase1bitShape - "Answer the integer denoting mode erase." - - ^ 17! ! -!Form class methodsFor: 'mode constants' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16849145! - oldPaint - "Answer the integer denoting the 'paint' combination rule." - - ^16! ! -!Form class methodsFor: 'mode constants' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16849153! - paint - "Answer the integer denoting the 'paint' combination rule." - - ^25! ! -!ImageReadWriter methodsFor: 'accessing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16854293! - nextImage - "Dencoding an image on stream and answer the image." - - ^self subclassResponsibility! ! -!ImageReadWriter methodsFor: 'accessing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16854298! - nextPutImage: anImage - "Encoding anImage on stream." - - ^self subclassResponsibility! ! -!ImageReadWriter methodsFor: 'stream access' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16854303! - atEnd - - ^stream atEnd! ! -!ImageReadWriter methodsFor: 'stream access' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16854306! - contents - - ^stream contents! ! -!ImageReadWriter methodsFor: 'stream access' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16854309! - next - - ^stream next! ! -!ImageReadWriter methodsFor: 'stream access' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16854312! - next: size - - ^stream next: size! ! -!ImageReadWriter methodsFor: 'stream access' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16854315! - nextPut: aByte - - ^stream nextPut: aByte! ! -!ImageReadWriter methodsFor: 'stream access' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16854318! - nextPutAll: aByteArray - - ^stream nextPutAll: aByteArray! ! -!ImageReadWriter methodsFor: 'stream access' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16854341! - position - - ^stream position! ! -!ImageReadWriter methodsFor: 'stream access' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16854344! - position: anInteger - - ^stream position: anInteger! ! -!ImageReadWriter methodsFor: 'stream access' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16854348 overrides: 16880927! - size - - ^stream size! ! -!ImageReadWriter methodsFor: 'stream access' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16854351! - skip: anInteger - - ^stream skip: anInteger! ! -!ImageReadWriter methodsFor: 'private' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16854366! - changePadOfBits: bits width: width height: height depth: depth from: oldPad -to: newPad - "Change padding size of bits." - - | srcRowByteSize dstRowByteSize newBits srcRowBase rowEndOffset | - (#(8 16 32) includes: oldPad) - ifFalse: [^self error: 'Invalid pad: ', oldPad printString]. - (#(8 16 32) includes: newPad) - ifFalse: [^self error: 'Invalid pad: ', newPad printString]. - srcRowByteSize _ width * depth + oldPad - 1 // oldPad * (oldPad / 8). - srcRowByteSize * height = bits size - ifFalse: [^self error: 'Incorrect bitmap array size.']. - dstRowByteSize _ width * depth + newPad - 1 // newPad * (newPad / 8). - newBits _ ByteArray new: dstRowByteSize * height. - srcRowBase _ 1. - rowEndOffset _ dstRowByteSize - 1. - 1 to: newBits size by: dstRowByteSize do: - [:dstRowBase | - newBits replaceFrom: dstRowBase - to: dstRowBase + rowEndOffset - with: bits - startingAt: srcRowBase. - srcRowBase _ srcRowBase + srcRowByteSize]. - ^newBits! ! -!ImageReadWriter methodsFor: 'private' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16854397! - hasMagicNumber: aByteArray - | position | - position _ stream position. - ((stream size - position) >= aByteArray size and: - [(stream next: aByteArray size) = aByteArray]) - ifTrue: [^true]. - stream position: position. - ^false! ! -!BitBlt methodsFor: 'accessing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16785508! - colorMap - ^ colorMap! ! -!BitBlt methodsFor: 'accessing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16785595! - sourceForm - - ^ sourceForm! ! -!BitBlt methodsFor: 'line drawing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16785822! - drawFrom: startPoint to: stopPoint - - ^ self drawFrom: startPoint to: stopPoint withFirstPoint: true! ! -!WarpBlt methodsFor: 'setup' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16942974! - cellSize - ^ cellSize! ! -!WarpBlt methodsFor: 'primitives' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16943089! - copyQuad: pts toRect: destRect - self sourceQuad: pts destRect: destRect. - self warpBits! ! -!WarpBlt methodsFor: 'primitives' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16943093! - deltaFrom: x1 to: x2 nSteps: n - "Utility routine for computing Warp increments. - x1 is starting pixel, x2 is ending pixel; assumes n >= 1" - | fixedPtOne | - fixedPtOne _ 16384. "1.0 in fixed-pt representation" - x2 > x1 - ifTrue: [^ x2 - x1 + fixedPtOne // (n+1) + 1] - ifFalse: [x2 = x1 ifTrue: [^ 0]. - ^ 0 - (x1 - x2 + fixedPtOne // (n+1) + 1)]! ! -!WarpBlt methodsFor: 'primitives' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16943124! - sourceQuad: pts destRect: aRectangle - | fixedPt1 | - sourceX _ sourceY _ 0. - self destRect: aRectangle. - fixedPt1 _ (pts at: 1) x isInteger ifTrue: [16384] ifFalse: [16384.0]. - p1x _ (pts at: 1) x * fixedPt1. - p2x _ (pts at: 2) x * fixedPt1. - p3x _ (pts at: 3) x * fixedPt1. - p4x _ (pts at: 4) x * fixedPt1. - p1y _ (pts at: 1) y * fixedPt1. - p2y _ (pts at: 2) y * fixedPt1. - p3y _ (pts at: 3) y * fixedPt1. - p4y _ (pts at: 4) y * fixedPt1. - p1z _ p2z _ p3z _ p4z _ 16384. "z-warp ignored for now" -! ! -!WarpBlt methodsFor: 'primitives' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16943141! - startFrom: x1 to: x2 offset: sumOfDeltas - "Utility routine for computing Warp increments." - x2 >= x1 - ifTrue: [^ x1] - ifFalse: [^ x2 - sumOfDeltas]! ! -!WarpBlt class methodsFor: 'initialization' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16943221 overrides: 50588658! - toForm: destinationForm - "Default cell size is 1 (no pixel smoothing)" - ^ (super toForm: destinationForm) cellSize: 1! ! -!Point methodsFor: 'converting' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16890352! - asFloatPoint - ^ x asFloat @ y asFloat! ! -!Rectangle methodsFor: 'rectangle functions' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16898854! - withHeight: height - "Return a copy of me with a different height" - ^ origin corner: corner x @ (origin y + height)! ! -!Rectangle methodsFor: 'rectangle functions' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16898860! - withLeft: x - "Return a copy of me with a different left x" - ^ x @ origin y corner: corner x @ corner y! ! -!Rectangle methodsFor: 'rectangle functions' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16898865! - withRight: x - "Return a copy of me with a different right x" - ^ origin x @ origin y corner: x @ corner y! ! -!Rectangle methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16898875! - containsRect: aRect - "Answer whether aRect is within the receiver (OK to coincide)." - - ^ aRect origin >= origin and: [aRect corner <= corner] -! ! -!Rectangle methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16898913! - isTall - ^ self height > self width! ! -!Rectangle methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16898916! - isWide - ^ self width > self height! ! -!Rectangle methodsFor: 'private' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16899058! - setOrigin: topLeft corner: bottomRight - origin _ topLeft. - corner _ bottomRight! ! -!Morph methodsFor: 'classification' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16874177! - isWorldMorph - - ^ false! ! -!Morph methodsFor: 'structure' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16876616! - owner - "Returns the owner of this morph, which may be nil." - - ^ owner! ! -!Morph methodsFor: 'submorphs-accessing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16876720! - submorphCount - - ^ submorphs size! ! -!Morph methodsFor: 'submorphs-accessing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16876728! - submorphs - - ^ submorphs copy! ! -!Morph methodsFor: 'submorphs-accessing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16876739! -submorphsDo: aBlock - - submorphs do: aBlock.! ! -!Morph methodsFor: 'submorphs-accessing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16876759! - submorphsReverseDo: aBlock - - submorphs reverseDo: aBlock.! ! -!ImageMorph methodsFor: 'menu commands' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16854148! - grabFromScreen - self image: Form fromUser! ! -!ScrollBar methodsFor: 'access' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16904495! - scrollDelta: d1 pageDelta: d2 - "Supply optional increments for better scrolling of, eg, text" - scrollDelta _ d1. - pageDelta _ d2.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4705-Squeak1.2-stamps-JuanVuletich-2021Jul27-19h24m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4702] on 27 July 2021 at 7:25:56 pm'! -!Object methodsFor: 'printing' stamp: 'di 6/20/97 08:57' prior: 16882089! - fullPrintString - "Answer a String whose characters are a description of the receiver." - - ^ String streamContents: [:s | self printOn: s]! ! -!ClassDescription methodsFor: 'fileIn/Out' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16807029! - reformatMethodAt: selector - | newCodeString method | - newCodeString _ (self compilerClass new) - format: (self sourceCodeAt: selector) - in: self - notifying: nil. - method _ self compiledMethodAt: selector. - method - putSource: newCodeString - fromParseNode: nil - class: self - category: (self organization categoryOfElement: selector) - inFile: 2 priorMethod: method! ! -!Float methodsFor: 'mathematical functions' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50585167 overrides: 50586474! - arcCos - "Answer the angle in radians." - - ^ Halfpi - self arcSin! ! -!Float methodsFor: 'mathematical functions' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50589041 overrides: 50586488! - cos - "Answer the cosine of the receiver taken as an angle in radians." - - ^ (self + Halfpi) sin! ! -!Float methodsFor: 'mathematical functions' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50589048 overrides: 16880129! - log - "Answer the base 10 logarithm of the receiver." - - ^ self ln / Ln10! ! -!Float methodsFor: 'mathematical functions' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50410395 overrides: 16879757! - reciprocal - ^ 1.0 / self! ! -!Float methodsFor: 'mathematical functions' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50589055 overrides: 50586502! - tan - "Answer the tangent of the receiver taken as an angle in radians." - - ^ self sin / self cos! ! -!Float methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50589062 overrides: 16882565! - isFloat - ^ true! ! -!CompiledMethod methodsFor: 'initialization' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16821243! - copyWithTrailerBytes: bytes -"Testing: - (CompiledMethod compiledMethodAt: #copyWithTrailerBytes:) - tempNamesPut: 'copy end ' -" - | copy end start | - start _ self initialPC. - end _ self endPC. - copy _ CompiledMethod newMethod: end - start + 1 + bytes size - header: self header. - 1 to: self numLiterals do: [:i | copy literalAt: i put: (self literalAt: i)]. - start to: end do: [:i | copy at: i put: (self at: i)]. - 1 to: bytes size do: [:i | copy at: end + i put: (bytes at: i)]. - ^ copy! ! -!Text class methodsFor: 'instance creation' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16929861! - string: aString attribute: att - "Answer an instance of me whose characters are aString. - att is a TextAttribute." - - ^self string: aString attributes: (Array with: att)! ! -!Text class methodsFor: 'instance creation' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16929869! - 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)! ! -!DataStream methodsFor: 'write and read' stamp: 'jmv 6/30/2011 09:33' prior: 16827317! - objectAt: anInteger - "PRIVATE -- Read & return the object at a given stream position. 08:18 tk anInteger is a relative file position. " - | savedPosn anObject refPosn | - - savedPosn _ byteStream position. "absolute" - refPosn _ self getCurrentReference. "relative position" - - byteStream position: anInteger + basePos. "was relative" - anObject _ self next. - - self setCurrentReference: refPosn. "relative position" - byteStream position: savedPosn. "absolute" - ^ anObject! ! -!VariableNode methodsFor: 'initialization' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16942047 overrides: 50584337! - name: string key: object code: byte - "Only used for initting std variables, nil, true, false, self, etc." - name _ string. - key _ object. - code _ byte! ! -!Form methodsFor: 'pixel access' stamp: 'tk 6/20/96' prior: 16848260! - pixelValueAt: aPoint put: pixelValue - "Store the given raw pixel value at the given point. Typical clients use colorAt:put: to store a color. " - - (BitBlt bitPokerToForm: self) pixelAt: aPoint put: pixelValue. -! ! -!StrikeFont methodsFor: 'emphasis' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16914386! - bonk: glyphForm with: bonkForm - "Bonking means to run through the glyphs clearing out black pixels - between characters to prevent them from straying into an adjacent - character as a result of, eg, bolding or italicizing" - "Uses the bonkForm to erase at every character boundary in glyphs." - | bb offset | - offset _ bonkForm offset x. - bb _ BitBlt toForm: glyphForm. - bb sourceForm: bonkForm; sourceRect: bonkForm boundingBox; - combinationRule: Form erase; destY: 0. - 1 to: xTable size-1 do: [:i | bb destX: (xTable at: i) + offset; copyBits]. -! ! -!CharacterScanner methodsFor: 'private' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16801948! - setActualFont: aFont - "Set the basal font to an isolated font reference." - - font _ aFont! ! -!Morph methodsFor: 'testing' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16877010! - stepTime - "Answer the desired time between steps in milliseconds. This default implementation requests that the 'step' method be called once every second." - - ^ 1000! ! -!Morph methodsFor: 'private' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50554709! - privateOwner: aMorph - "Private!! Should only be used by methods that maintain the ower/submorph invariant." - - owner _ aMorph.! ! -!Morph methodsFor: 'private' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 16877220! - privateSubmorphs - "Private!! Use 'submorphs' instead." - - ^ submorphs! ! -!WorldMorph methodsFor: 'classification' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50551955 overrides: 50589950! - isWorldMorph - - ^ true! ! -!WorldMorph methodsFor: 'structure' stamp: 'Squeak1.2 6/29/1997 10:40:55' prior: 50552050 overrides: 16876664! - world - - ^ self! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4706-Squeak1.2-stamps-JuanVuletich-2021Jul27-19h25m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4701] on 27 July 2021 at 4:15:04 pm'! -!TextLine methodsFor: 'accessing' stamp: 'Squeak1.3 1/16/1998 17:55:27' prior: 16933475! - baseline - ^ baseline! ! -!TextLine methodsFor: 'accessing' stamp: 'Squeak1.3 1/16/1998 17:55:27' prior: 16933486! - internalSpaces - "Answer the number of spaces in the line." - - ^internalSpaces! ! -!TextLine methodsFor: 'accessing' stamp: 'Squeak1.3 1/16/1998 17:55:27' prior: 16933490! - internalSpaces: spacesInteger - "Set the number of spaces in the line to be spacesInteger." - - internalSpaces _ spacesInteger! ! -!TextLine methodsFor: 'accessing' stamp: 'Squeak1.3 1/16/1998 17:55:27' prior: 16933532! - paddingWidth - "Answer the amount of space to be added to the font." - - ^paddingWidth! ! -!TextLine methodsFor: 'accessing' stamp: 'Squeak1.3 1/16/1998 17:55:27' prior: 16933536! - paddingWidth: padWidthInteger - "Set the amount of space to be added to the font to be padWidthInteger." - - paddingWidth _ padWidthInteger! ! -!TextLine methodsFor: 'scanning' stamp: 'Squeak1.3 1/16/1998 17:55:27' prior: 16933598! - justifiedPadFor: spaceIndex - "Compute the width of pad for a given space in a line of justified text." - - | pad | - internalSpaces = 0 ifTrue: [^0]. - pad _ paddingWidth // internalSpaces. - spaceIndex <= (paddingWidth \\ internalSpaces) - ifTrue: [^pad + 1] - ifFalse: [^pad]! ! -!TextLine methodsFor: 'private' stamp: 'Squeak1.3 1/16/1998 17:55:27' prior: 16933625! - internalSpaces: spacesInteger paddingWidth: padWidthInteger - - internalSpaces _ spacesInteger. - paddingWidth _ padWidthInteger! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4707-Squeak1.3-stamps-JuanVuletich-2021Jul27-16h13m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4707] on 27 July 2021 at 8:09:28 pm'! -!String class methodsFor: 'instance creation' stamp: 'sw 8/5/97 13:55' prior: 16917814! - crString - ^ self with: Character cr! ! -!Base64MimeConverter methodsFor: 'accessing' stamp: 'tk 12/9/97 13:55' prior: 16782361! - dataStream - ^dataStream! ! -!Base64MimeConverter methodsFor: 'accessing' stamp: 'tk 12/9/97 13:53' prior: 16782371! - mimeStream - ^mimeStream! ! -!Encoder methodsFor: 'temps' stamp: 'jm 9/18/97 21:06' prior: 16837306! - bindArg: name - "Declare an argument." - | node | - nTemps >= 15 - ifTrue: [^self notify: 'Too many arguments']. - node _ self bindTemp: name. - ^ node nowHasDef nowHasRef! ! -!TextDoIt methodsFor: 'as yet unclassified' stamp: 'tk 12/5/97 17:01' prior: 16931191 overrides: 50589608! - 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 ! ! -!TextAnchor methodsFor: 'testing' stamp: 'di 11/10/97 14:08' prior: 16930152 overrides: 16930235! - mayBeExtended - "A textAnchor is designed to modify only a single character, and therefore must not be extended by the ParagraphEditor's emphasisHere facility" - ^ false! ! -!BitBlt methodsFor: 'copying' stamp: 'di 7/17/97 10:04' prior: 16785742! - copyForm: srcForm to: destPt rule: rule colorMap: map - sourceForm _ srcForm. - halftoneForm _ nil. - combinationRule _ rule. - destX _ destPt x + sourceForm offset x. - destY _ destPt y + sourceForm offset y. - sourceX _ 0. - sourceY _ 0. - width _ sourceForm width. - height _ sourceForm height. - colorMap _ map. - self copyBits! ! -!CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'di 11/11/97 08:50' prior: 16801819 overrides: 50526596! - setFont - specialWidth _ nil. - super setFont! ! -!CompositionScanner methodsFor: 'stop conditions' stamp: 'di 11/5/97 07:46' prior: 16823068! - space - "Record left x and character index of the space character just encounted. - Used for wrap-around. Answer whether the character has crossed the - right edge of the composition rectangle of the paragraph." - - spaceX _ destX. - destX _ spaceX + spaceWidth. - spaceIndex _ lastIndex. - lineHeightAtSpace _ lineHeight. - baselineAtSpace _ baseline. - lastIndex _ lastIndex + 1. - spaceCount _ spaceCount + 1. - destX > rightMargin ifTrue: [^self crossedX]. - ^false -! ! -!Morph methodsFor: 'accessing - properties' stamp: 'sw 8/4/97 12:05' prior: 16874000! - lock: aBoolean - self setProperty: #locked toValue: aBoolean! ! -!Morph methodsFor: 'caching' stamp: 'jm 11/13/97 16:33' prior: 50510072 overrides: 50559125! - releaseCachedState - "Release any state that can be recomputed on demand, such as the pixel values for a color gradient or the editor state for a TextMorph. This method may be called to save space when a morph becomes inaccessible. Implementations of this method should do 'super releaseCachedState'. This default implementation does nothing." -! ! -!Morph methodsFor: 'focus handling' stamp: 'Squeak1.3 1/16/1998 17:55:27' prior: 16875216! - keyboardFocusChange: aBoolean - "The message is sent to a morph when its keyboard focus change. The given argument indicates that the receiver is gaining keyboard focus (versus losing) the keyboard focus. Morphs that accept keystrokes should change their appearance in some way when they are the current keyboard focus. This default implementation does nothing."! ! -!HandMorph methodsFor: 'focus handling' stamp: 'jm 11/13/97 15:12' prior: 16851923! - newKeyboardFocus: aMorphOrNil - "Make the given morph the new keyboard focus, canceling the previous keyboard focus if any. If the argument is nil, the current keyboard focus is cancelled." - | oldFocus | - oldFocus _ keyboardFocus. - keyboardFocus _ aMorphOrNil. - oldFocus ifNotNil: [oldFocus == aMorphOrNil ifFalse: [oldFocus keyboardFocusChange: false]]. - aMorphOrNil ifNotNil: [aMorphOrNil keyboardFocusChange: true]. -! ! -!HaloMorph methodsFor: 'accessing' stamp: 'jm 7/30/97 15:52' prior: 16850616! - target: aMorph - - target _ aMorph. - target ifNotNil: [self addHandles]. -! ! -!MenuItemMorph methodsFor: 'event handling testing' stamp: 'jm 11/4/97 07:15' prior: 16865920 overrides: 16874721! - handlesMouseDown: evt - - ^ true -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4708-HistoricalAppreciation-JuanVuletich-2021Jul27-19h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4708] on 27 July 2021 at 9:11:16 pm'! -!DifferenceFinder methodsFor: 'accessing' stamp: 'LC 1/24/2010 15:18' prior: 16834033! - base: aCollection case: anotherCollection - base := aCollection. - case := anotherCollection. - x := aCollection. - y := anotherCollection -! ! -!DifferenceFinder methodsFor: 'private' stamp: 'jmv 8/23/2014 23:23' prior: 16834040! - initializeMap - map _ Array2D height: x size width: y size! ! -!DifferenceFinder methodsFor: 'private' stamp: 'jmv 8/23/2014 23:23' prior: 16834045! - initializeMatrix - matrix _ Array2D height: x size width: y size! ! -!DifferenceFinder methodsFor: 'private' stamp: 'jmv 11/16/2015 14:51' prior: 16834050! - keywordsAndBlanksFrom: aString - ^Array streamContents: [:strm | | read keyword tail | - read := aString readStream. - [read atEnd] whileFalse: [ - keyword := read nextKeyword. - keyword notEmpty ifTrue: [ - strm nextPut: keyword ]. - tail := read untilAnySatisfying: [:ch | ch isValidInIdentifiers]. - tail notEmpty ifTrue: [strm nextPut: tail]]] -! ! -!DifferenceFinder methodsFor: 'private' stamp: 'LC 1/24/2010 15:18' prior: 16834063! - linesIn: aString - " - LongestCommonSequenceFinder linesIn: 'x y' - " - ^Array streamContents: [:strm | | cr read | - cr := ' -'. - read := aString readStream. - [read atEnd] whileFalse: [| line | - line := read nextLine. - read skip: -1. - read peek = cr last ifTrue: [line := line , cr]. - read skip: 1. - strm nextPut: line]] -! ! -!DifferenceFinder methodsFor: 'private' stamp: 'jmv 2/22/2010 11:36' prior: 16834076! - maxLength - - (tally width = 0 or: [ tally height = 0 ]) ifTrue: [ ^0 ]. - ^tally i: x size j: y size! ! -!DifferenceFinder methodsFor: 'private' stamp: 'jmv 3/12/2018 15:48:12' prior: 50386128! - maxLengthPoints - | max points | - max := self maxLength. - max = 0 ifTrue: [^Array with: `0 @ 0`]. - points := OrderedCollection new. - tally withIndexesDo: [:i :j :t | t = max ifTrue: [points add: i @ j]]. - ^ points! ! -!DifferenceFinder methodsFor: 'private' stamp: 'LC 1/26/2010 10:21' prior: 16834091! - similitudeProportion - ^self maxLength / (x size + y size / 2)! ! -!DifferenceFinder methodsFor: 'private' stamp: 'LC 1/24/2010 15:18' prior: 16834095! - unfold - | points | - points := OrderedCollection with: x size @ y size. - ^self unfold: points -! ! -!DifferenceFinder methodsFor: 'private' stamp: 'LC 1/24/2010 15:18' prior: 16834100! - unfold: pointCollection - | pending visited point | - pending := OrderedCollection withAll: pointCollection. - visited := OrderedCollection new. - [pending notEmpty] whileTrue: [ - point := pending removeFirst. - (visited includes: point) ifFalse: [ - self unfold: point on: pending. - visited add: point]]. - ^visited -! ! -!DifferenceFinder methodsFor: 'private' stamp: 'jmv 4/17/2015 16:00' prior: 16834113! - unfold: aPoint on: pending - | i j mij | - i := aPoint x. - j := aPoint y. - (i = 0 or: [j = 0]) ifTrue: [^self]. - mij := map i: i j: j. - mij = self class d ifTrue: [ - pending add: i - 1 @ (j - 1). - ^self]. - mij = self class u ifTrue: [ - pending add: i - 1 @ j. - ^self]. - mij = self class l ifTrue: [ - pending add: i @ (j - 1). - ^self]. - mij = self class ul ifTrue: [ - pending add: i - 1 @ j; add: i @ (j - 1). - ^self]. - self assert: false! ! -!DifferenceFinder methodsFor: 'configuration' stamp: 'LC 1/24/2010 15:18' prior: 16834129! - compareCharacters - x := base. - y := case -! ! -!DifferenceFinder methodsFor: 'configuration' stamp: 'LC 1/24/2010 15:18' prior: 16834132! - compareLines - x := self linesIn: base. - y := self linesIn: case -! ! -!DifferenceFinder methodsFor: 'configuration' stamp: 'LC 1/24/2010 15:18' prior: 16834136! - compareWords - x := self keywordsAndBlanksFrom: base. - y := self keywordsAndBlanksFrom: case -! ! -!DifferenceFinder methodsFor: 'computing' stamp: 'jmv 12/21/2012 13:51' prior: 16834142! - compute - ^self compute: false! ! -!DifferenceFinder methodsFor: 'computing' stamp: 'jmv 12/21/2012 13:53' prior: 16834146! - compute: abortIfTooExpensive - "If abortIfTooExpensive, we might abort, and then differences could be nil." - | longestSequences | - self initializeMap; initializeMatrix; computeMap. - longestSequences _ self longestSequences: abortIfTooExpensive. - "If decided computation was too expensive..." - longestSequences ifNil: [ - differences _ nil. - ^self ]. - differences _ longestSequences asArray collect: [ :lcs | - SequenceDifference x: x y: y lcs: lcs]. - differences sort! ! -!DifferenceFinder methodsFor: 'computing' stamp: 'jmv 4/17/2015 16:00' prior: 16834163! - computeLcsAt: i at: j - | mij cij pair left up | - mij := map i: i j: j. - mij = self class d ifTrue: [ - cij := self lcsAt: i - 1 at: j - 1. - pair := Array with: i with: j. - ^cij collect: [:s | s copyWith: pair]]. - mij = self class u ifTrue: [^self lcsAt: i - 1 at: j]. - mij = self class l ifTrue: [^self lcsAt: i at: j - 1]. - mij = self class ul ifTrue: [ - left := self lcsAt: i at: j - 1. - up := self lcsAt: i - 1 at: j. - ^left copy addAll: up; yourself]. - self assert: false! ! -!DifferenceFinder methodsFor: 'computing' stamp: 'jmv 8/23/2014 23:23' prior: 16834181! - computeMap - | m | - tally _ Array2D height: x size width: y size. - 1 to: x size do: [ :i | - 1 to: y size do: [ :j | - m _ self computeMapAt: i at: j. - map i: i j: j put: m ]]! ! -!DifferenceFinder methodsFor: 'computing' stamp: 'jmv 4/17/2015 16:00' prior: 16834189! - computeMapAt: i at: j - | xi yj left up t | - xi := x at: i. - yj := y at: j. - xi = yj ifTrue: [ - t := ((j = 1 or: [i = 1]) - ifTrue: [0] - ifFalse: [tally i: i - 1 j: j - 1]) - + 1. - tally i: i j: j put: t. - ^self class d]. - left := j = 1 ifTrue: [0] ifFalse: [tally i: i j: j - 1]. - up := i = 1 ifTrue: [0] ifFalse: [tally i: i - 1 j: j]. - left < up ifTrue: [ - tally i: i j: j put: up. - ^self class u]. - tally i: i j: j put: left. - ^up < left ifTrue: [self class l] ifFalse: [self class ul] -! ! -!DifferenceFinder methodsFor: 'computing' stamp: 'jmv 4/17/2015 16:35' prior: 16834207! - lcsAt: i at: j - | lcs | - (i = 0 or: [j = 0]) ifTrue: [^Set with: #() "EmptyLCS"]. - lcs := matrix i: i j: j. - lcs ifNil: [ - lcs := self computeLcsAt: i at: j. - matrix i: i j: j put: lcs]. - ^lcs -! ! -!DifferenceFinder methodsFor: 'computing' stamp: 'jmv 12/21/2012 13:50' prior: 16834216! -longestSequences: abortIfTooExpensive - | maxs points answer | - maxs _ self maxLengthPoints. - points _ self unfold: maxs. - abortIfTooExpensive ifTrue: [ - points size > 500 ifTrue: [ ^nil ]. "maybe a bit too much..." - ]. - points - sort: [:p :q | p x < q x or: [p x = q x and: [p y <= q y]]]; - do: [:p | self lcsAt: p x at: p y]. - answer _ Set new. - maxs do: [ :p | | lcs | - lcs _ self lcsAt: p x at: p y. - lcs do: [ :s | - answer add: s]]. - ^answer! ! -!DifferenceFinder methodsFor: 'outputs' stamp: 'LC 1/24/2010 15:18' prior: 16834232! - differences - ^differences -! ! -!DifferenceFinder class methodsFor: 'instance creation' stamp: 'LC 1/24/2010 15:18' prior: 16834241! - base: aCollection case: anotherCollection - ^self new base: aCollection case: anotherCollection -! ! -!DifferenceFinder class methodsFor: 'instance creation' stamp: 'LC 1/24/2010 15:18' prior: 16834246! - charactersOf: aString and: anotherString - | finder | - finder := self base: aString case: anotherString. - finder compareCharacters. - ^finder -! ! -!DifferenceFinder class methodsFor: 'instance creation' stamp: 'LC 1/24/2010 15:18' prior: 16834253! - linesOf: aString and: anotherString - | finder | - finder := self base: aString case: anotherString. - finder compareLines. - ^finder -! ! -!DifferenceFinder class methodsFor: 'instance creation' stamp: 'LC 1/24/2010 15:18' prior: 16834259! - wordsOf: aString and: anotherString - | finder | - finder := self base: aString case: anotherString. - finder compareWords. - ^finder -! ! -!DifferenceFinder class methodsFor: 'compatibility' stamp: 'jmv 2/22/2010 13:08' prior: 16834266! - displayPatchFrom: srcString to: dstString tryWords: aBoolean - | finder | - - aBoolean ifTrue: [ - (self wordsDisplayPatchFrom: srcString to: dstString) - ifNotNil: [ :answer | ^answer ] ]. - - finder _ self base: srcString case: dstString. - finder compareLines; compute. - ^finder differences anyOne asText! ! -!DifferenceFinder class methodsFor: 'compatibility' stamp: 'jmv 8/2/2016 16:45:19' prior: 16834279! - displayPatchFrom: srcString to: dstString tryWords: aBoolean prettyPrintedIn: aClass - | formattedSrcString formattedDstString | - formattedSrcString _ aClass - ifNil: [ srcString ] - ifNotNil: [ - [ - aClass compilerClass new - format: srcString - in: aClass - notifying: nil ] - on: Error - do: [ :ex | - srcString ]]. - formattedDstString _ aClass - ifNil: [ dstString ] - ifNotNil: [ - [ - aClass compilerClass new - format: dstString - in: aClass - notifying: nil ] - on: Error - do: [ :ex | - dstString ]]. - ^ self - displayPatchFrom: formattedSrcString - to: formattedDstString - tryWords: aBoolean! ! -!DifferenceFinder class methodsFor: 'compatibility' stamp: 'jmv 9/13/2016 17:28:22' prior: 16834302! - wordsDisplayPatchFrom: srcString to: dstString - | finder answer src1 dst1 changedCount | - finder _ self base: srcString case: dstString. - finder compareLines; compute. - answer _ '' asText. - src1 _ String new writeStream. - dst1 _ String new writeStream. - changedCount _ 0. - finder differences sort first do: [:item :condition | - condition caseOf: { - [ #unchanged ] -> [ - changedCount > 0 ifTrue: [ - "If the sequence of changed lines is large, comparing words gets too slow and less useful" - changedCount > 30 ifTrue: [ - ^nil ]. - "Compare the just ended sequence of changed lines" - finder base: src1 contents case: dst1 contents. - finder compareWords; compute: true. - finder differences ifNil: [ ^nil ]. - answer _ answer append: finder differences anyOne asText. - src1 resetToStart. - dst1 resetToStart. - changedCount _ 0. - ]. - "This line hasn't changed. Just add it to the result in plain text." - answer append: item ]. - [ #removed ] -> [ - "A removed line belongs in the source" - src1 nextPutAll: item. - changedCount _ changedCount + 1 ]. - [ #inserted ] -> [ - "An added line belongs in the destination" - dst1 nextPutAll: item. - changedCount _ changedCount + 1 ]. - }. - ]. - "If the sequence of changed lines is large, comparing words gets too slow and less useful" - changedCount > 30 ifTrue: [ - ^nil ]. - finder base: src1 contents case: dst1 contents. - finder compareWords; compute: true. - finder differences ifNil: [ ^nil ]. - answer _ answer append: finder differences anyOne asText. - - ^answer! ! -!DifferenceFinder class methodsFor: 'bibliography' stamp: 'LC 1/24/2010 16:30' prior: 16834354! - references - ^'http://en.wikipedia.org/wiki/Longest_common_subsequence' -! ! -!DifferenceFinder class methodsFor: 'constants' stamp: 'jmv 4/17/2015 16:39' prior: 16834359! - d - ^1! ! -!DifferenceFinder class methodsFor: 'constants' stamp: 'jmv 4/17/2015 16:39' prior: 16834362! - l - ^3! ! -!DifferenceFinder class methodsFor: 'constants' stamp: 'jmv 4/17/2015 16:39' prior: 16834365! - u - ^2! ! -!DifferenceFinder class methodsFor: 'constants' stamp: 'jmv 4/17/2015 16:39' prior: 16834368! - ul - ^4! ! -!SequenceDifference methodsFor: 'accessing' stamp: 'jmv 12/21/2012 12:32' prior: 16905296! - lcsSize - ^lcs size! ! -!SequenceDifference methodsFor: 'accessing' stamp: 'LC 1/24/2010 15:18' prior: 16905299! - partsSize - | count last | - count := 0. - self do: [:item :condition | - last = condition ifFalse: [ - count := count + 1. - last := condition]]. - ^count -! ! -!SequenceDifference methodsFor: 'accessing' stamp: 'jmv 8/23/2010 10:31' prior: 16905307! - x: aCollection y: anotherCollection lcs: pairCollection - x := aCollection. - y := anotherCollection. - lcs := pairCollection sort: [ :a :b | a first < b first ]! ! -!SequenceDifference methodsFor: 'printing' stamp: 'LC 1/24/2010 15:18' prior: 16905315! - asText - ^Text streamContents: [:rtf | self printTextOn: rtf]! ! -!SequenceDifference methodsFor: 'printing' stamp: 'pb 1/9/2020 23:51:15' prior: 50493804! - attributesFor: condition - condition == #unchanged - ifTrue: [ - ^ {TextEmphasis normal} ]. - condition == #removed - ifTrue: [ - ^ {TextEmphasis struckThrough. TextColor red} ]. - condition == #inserted - ifTrue: [ - ^ {TextColor green} ]! ! -!SequenceDifference methodsFor: 'printing' stamp: 'LC 1/24/2010 15:13' prior: 16905330! - printTextOn: rtf - self do: [:item :condition | | attributes | - attributes := self attributesFor: condition. - rtf withAttributes: attributes do: [rtf nextPutAll: item asString]]! ! -!SequenceDifference methodsFor: 'enumerating' stamp: 'LC 1/24/2010 15:18' prior: 16905338! - do: aBlock - | j i item | - i := j := 1. - lcs do: [:pair | - [i < pair first] whileTrue: [ - item := x at: i. - aBlock value: item value: #removed. - i := i + 1]. - [j < pair second] whileTrue: [ - item := y at: j. - aBlock value: item value: #inserted. - j := j + 1]. - item := x at: i. - aBlock value: item value: #unchanged. - i := i + 1. - j := j + 1]. - i to: x size do: [:k | - item := x at: k. - aBlock value: item value: #removed]. - j to: y size do: [:k | - item := y at: k. - aBlock value: item value: #inserted] -! ! -!SequenceDifference methodsFor: 'services' stamp: 'LC 1/24/2010 15:18' prior: 16905357! - invert - | swap | - swap := x. - x := y. - y := swap. - lcs := lcs collect: [:pair | pair copy swap: 1 with: 2] -! ! -!SequenceDifference methodsFor: 'services' stamp: 'LC 1/24/2010 15:18' prior: 16905362 overrides: 16880927! - size - ^lcs sum: [:pair | (x at: pair first) size] -! ! -!SequenceDifference methodsFor: 'testing' stamp: 'jmv 12/21/2012 12:38' prior: 16905367! - <= sequence - ^lcs size <= sequence lcsSize -! ! -!SequenceDifference class methodsFor: 'instance creation' stamp: 'LC 1/24/2010 15:18' prior: 16905377! - x: x y: y lcs: sequence - ^self new x: x y: y lcs: sequence -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4709-AddSomeMissingMethodAuthors-JuanVuletich-2021Jul27-21h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4709] on 29 July 2021 at 9:28:28 am'! -!BitBlt methodsFor: 'private' stamp: 'jmv 7/29/2021 09:27:58' prior: 50577318! - copyBitsAgain - "Primitive. See BitBlt|copyBits, also a Primitive. Essential. See Object - documentation whatIsAPrimitive." - - - '#copyBitsAgain failed. Requested BitBlt operation not performed. Call stack follows:' print. - thisContext printStack: 10.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4710-CallStackOnBitBltFailure-JuanVuletich-2021Jul29-09h27m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4710] on 29 July 2021 at 10:09:16 am'! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 7/29/2021 10:01:46' prior: 50498924 overrides: 16899205! - drawOn: aCanvas - "Draw the hand itself (i.e., the cursor)." - "This method is only called when we are carrying morphs around..." - aCanvas - stencil: (Cursor cursorAt: #moveCursor) - at: `-8 @ -8` - color: Color black.! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 7/29/2021 10:08:07' prior: 50570286! - restoreSavedPatchOn: aCanvas - "Clear the changed flag and restore the part of the given canvas under this hand from the previously saved patch. If necessary, handle the transition to using the hardware cursor." - - self needsRedraw: false. - prevFullBounds ifNotNil: [ - aCanvas restorePatch: savedPatch bounds: prevFullBounds. - submorphs notEmpty ifTrue: [ ^ self ]. - "Make the transition to using hardware cursor. Clear savedPatch and - report one final damage rectangle to erase the image of the software cursor." - " owner invalidateDisplayRect: (savedPatch offset extent: savedPatch extent) from: nil." - self invalidateDisplayRect: self displayBounds for: nil. - Cursor currentCursor == Cursor defaultCursor ifFalse: [ Cursor defaultCursor activateCursor ]. - "show hardware cursor" - prevFullBounds _ nil ].! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 7/29/2021 10:09:03' prior: 50567688 overrides: 50570195! - displayBounds - - ^ self morphPosition-8 extent: self morphExtent.! ! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 7/29/2021 09:47:11' prior: 50532764 overrides: 50463429! - stencil: stencilForm at: aPoint color: aColor - "Flood this canvas with aColor wherever stencilForm has non-zero pixels" - " - | dot | - dot := ((Form dotOfSize: 32) asFormOfDepth: 1) offset: 0@0. - dot displayAt: 20@20. - Display getCanvas stencil: dot at: 60@20 color: Color red. - Display forceToScreen - " - ^self stencil: stencilForm - at: aPoint - sourceRect: stencilForm boundingBox - color: aColor! ! - -MorphicCanvas removeSelector: #stencil:at:color:! - -!methodRemoval: MorphicCanvas #stencil:at:color: stamp: 'Install-4711-HandMorph-cleanup-JuanVuletich-2021Jul29-09h57m-jmv.001.cs.st 8/6/2021 11:45:14'! -stencil: stencilForm at: aPoint color: aColor - self subclassResponsibility.! - -MorphicCanvas removeSelector: #stencil:at:sourceRect:color:! - -!methodRemoval: MorphicCanvas #stencil:at:sourceRect:color: stamp: 'Install-4711-HandMorph-cleanup-JuanVuletich-2021Jul29-09h57m-jmv.001.cs.st 8/6/2021 11:45:14'! -stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor - self subclassResponsibility.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4711-HandMorph-cleanup-JuanVuletich-2021Jul29-09h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4711] on 29 July 2021 at 12:09:37 pm'! -!MorphicCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/29/2021 10:32:34'! - drawCloseIcon - "For Window control buttons" - - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/29/2021 10:32:37'! - drawCollapseIcon - "For Window control buttons" - - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/29/2021 10:32:17'! - drawDownIcon - "For Scrollbars" - - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/29/2021 10:32:42'! - drawExpandIcon - "For Window control buttons" - - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/29/2021 10:37:03'! - drawHand - "For the user Hand. Especially when carrying morphs around." - - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/29/2021 10:32:14'! - drawLeftIcon - "For Scrollbars" - - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/29/2021 10:32:46'! - drawMenuIcon - "For Window control buttons" - - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/29/2021 10:33:11'! - drawPushPinIcon - "For Menu stay-up button" - - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/29/2021 10:32:10'! - drawRightIcon - "For Scrollbars" - - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/29/2021 10:32:05'! - drawUpIcon - "For Scrollbars" - - self subclassResponsibility.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 7/29/2021 10:36:51' overrides: 50590980! - drawHand - self - stencil: (Cursor cursorAt: #moveCursor) - at: `-8 @ -8` - color: `Color black` .! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 7/29/2021 10:37:10' prior: 50590873 overrides: 16899205! - drawOn: aCanvas - "Draw the hand itself (i.e., the cursor)." - "This method is only called when we are carrying morphs around..." - - aCanvas drawHand! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4712-HandMorph-canvas-cleanup-JuanVuletich-2021Jul29-12h08m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4712] on 29 July 2021 at 12:26:42 pm'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/29/2021 12:20:08'! - displayBoundsForHand: aHand - - self subclassResponsibility.! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 7/29/2021 12:21:09' overrides: 50591033! - displayBoundsForHand: aHand - - ^ aHand morphPosition-8 extent: aHand morphExtent.! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 7/29/2021 12:22:05' prior: 50590883! - restoreSavedPatchOn: aCanvas - "Clear the changed flag and restore the part of the given canvas under this hand from the previously saved patch. If necessary, handle the transition to using the hardware cursor." - - self needsRedraw: false. - prevFullBounds ifNotNil: [ - aCanvas restorePatch: savedPatch bounds: prevFullBounds. - submorphs notEmpty ifTrue: [ ^ self ]. - "Make the transition to using hardware cursor. Clear savedPatch and - report one final damage rectangle to erase the image of the software cursor." - " owner invalidateDisplayRect: (savedPatch offset extent: savedPatch extent) from: nil." - self invalidateDisplayRect: (aCanvas displayBoundsForHand: self) for: nil. - Cursor currentCursor == Cursor defaultCursor ifFalse: [ Cursor defaultCursor activateCursor ]. - "show hardware cursor" - prevFullBounds _ nil ].! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 7/29/2021 12:18:09' prior: 50590980! - drawHand - "For the user Hand. Especially when carrying morphs around." - - self subclassResponsibility.! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 7/29/2021 12:18:20' prior: 50591011 overrides: 50591073! - drawHand - self - stencil: (Cursor cursorAt: #moveCursor) - at: `-8 @ -8` - color: `Color black` .! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4713-MoveHandBoundsToCanvas-JuanVuletich-2021Jul29-12h24m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4713] on 29 July 2021 at 1:05:53 pm'! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 7/29/2021 13:05:24' prior: 50590912 overrides: 50570195! - displayBounds - - ^ self world canvas displayBoundsForHand: self! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4714-MoveHandBoundsToCanvas-JuanVuletich-2021Jul29-12h53m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4714] on 30 July 2021 at 10:12:42 am'! - -LayoutMorph subclass: #TaskbarMorph - instanceVariableNames: 'viewBox scale clock ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Taskbar'! - -!classDefinition: #TaskbarMorph category: #'Tools-Taskbar' stamp: 'Install-4715-TaskbarMorph-HonorDefaultFontChange-JuanVuletich-2021Jul30-10h09m-jmv.001.cs.st 8/6/2021 11:45:14'! -LayoutMorph subclass: #TaskbarMorph - instanceVariableNames: 'viewBox scale clock' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Taskbar'! -!TaskbarMorph methodsFor: 'notifications' stamp: 'jmv 7/29/2021 18:42:06' overrides: 50552944! - fontPreferenceChanged - clock font: nil! ! -!TaskbarMorph methodsFor: 'initialization' stamp: 'jmv 7/29/2021 18:40:36' prior: 50546592 overrides: 50521471! - initialize - super initialize. - viewBox _ LayoutMorph newRow color: self defaultColor. - self - addMorph: (clock _ UpdatingLabelMorph initializedInstance) - layoutSpec: (LayoutSpec morphWidthProportionalHeight: 0.5). - self - addMorph: viewBox - layoutSpec: (LayoutSpec - proportionalWidth: 1.0 - proportionalHeight: 1.0 - offAxisEdgeWeight: #rightOrBottom). - viewBox separation: self defaultHeight // 8 -! ! - -LayoutMorph subclass: #TaskbarMorph - instanceVariableNames: 'viewBox scale clock' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Taskbar'! - -!classDefinition: #TaskbarMorph category: #'Tools-Taskbar' stamp: 'Install-4715-TaskbarMorph-HonorDefaultFontChange-JuanVuletich-2021Jul30-10h09m-jmv.001.cs.st 8/6/2021 11:45:14'! -LayoutMorph subclass: #TaskbarMorph - instanceVariableNames: 'viewBox scale clock' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Taskbar'! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -TaskbarMorph allInstancesDo: [ :tb | tb submorphsDo: [ :m | m class == UpdatingLabelMorph ifTrue: [ tb instVarNamed: 'clock' put: m ]]]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4715-TaskbarMorph-HonorDefaultFontChange-JuanVuletich-2021Jul30-10h09m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4715] on 30 July 2021 at 10:29:05 am'! -!GeometryTransformation methodsFor: 'testing' stamp: 'jmv 7/30/2021 10:24:34'! - doesNotRotate - "Return true if the receiver specifies no rotation." - ^false! ! -!WidgetMorph methodsFor: 'geometry testing' stamp: 'jmv 7/30/2021 10:25:56' prior: 50579792 overrides: 50532209! -isOrthoRectangularMorph - "True if we are of rectangular shape, aligned with local coordinate axes. - Doesn't take into account possible rotation of our or some owner's local coordinates. - Note: SystemWindow answers true, but implements #addPossiblyUncoveredAreasIn:to: to take care of rounded corners." - - ^location doesNotRotate and: [ owner isNil or: [ owner isOrthoRectangularMorph ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4716-ZoomedWindowsStillOrthoRectangular-JuanVuletich-2021Jul30-10h20m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4716] on 30 July 2021 at 3:34:45 pm'! -!KernelMorph methodsFor: 'geometry testing' stamp: 'jmv 7/30/2021 10:53:34' overrides: 50575990! - wantsContour - "Kernel morphs don't usually need contour" - - ^false! ! -!WidgetMorph methodsFor: 'geometry testing' stamp: 'jmv 7/30/2021 10:54:19' overrides: 50575990! - wantsContour - "Widget morphs don't usually need contour" - - ^false! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/30/2021 11:00:12' prior: 50570195! - displayBounds - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us. - Integer pixel coordinates!!" - - self visible ifFalse: [ ^nil ]. - ^ privateDisplayBounds! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/30/2021 11:00:34' prior: 50537409! - displayBoundsOrBogus - "Never answer nil. A bogus value will trigger a draw operation, and bounds will later be corrected. - Integer pixel coordinates!!" - - ^self displayBounds ifNil: [ - Rectangle center: (self externalizeToWorld: `0@0`) extent: `2@2` ]! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/30/2021 15:34:05' prior: 50566260! - displayFullBounds - "Answer a rectangle that completely bounds receiver and submorphs when last drawn - (if the world was to be fully drawn, i.e. only to be used on a Canvas on the full world). - Integer pixel coordinates!!" - - | answer | - answer _ self displayBounds. - answer ifNil: [ ^nil ]. - (self submorphsMightProtrude and: [self clipsSubmorphsReally not]) ifTrue: [ - self submorphsReverseDo: [ :m | - answer _ answer quickMerge: m displayFullBounds ]]. - ^answer encompassingIntegerRectangle! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 7/30/2021 15:34:19' prior: 50566356 overrides: 50591244! - displayFullBounds - "Current full bounds of hand and carried submorphs. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around). - Integer pixel coordinates!!" - - | fullBounds | - fullBounds _ self displayBounds. - self submorphsDo: [ :m | - fullBounds _ fullBounds quickMerge: m displayFullBounds]. - lastPosition - ifNotNil: [ :lastPos | "When already carrying morphs around. Include also the rectangle updated to current hand position." - fullBounds _ fullBounds quickMerge: (fullBounds translatedBy: self morphPosition-lastPos) ]. - ^fullBounds encompassingIntegerRectangle! ! -!InnerPluggableMorph methodsFor: 'geometry' stamp: 'jmv 7/30/2021 10:49:50' prior: 16855347! - adjustExtent - "Morphs intended to be included in PluggableScrollPanes as scrolled content might need to adjust their extent." - - self subclassResponsibility! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4717-Morphic-tweaks-JuanVuletich-2021Jul30-15h32m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4716] on 30 July 2021 at 3:38:36 pm'! -!Morph methodsFor: 'accessing - flags' stamp: 'jmv 7/30/2021 12:11:02'! - fullRedrawNotNeeded - "Clear redraw flags for receiver and all submorphs (but only if set!!)" - - self isSubmorphRedrawNeeded ifTrue: [ - self submorphsDo: [ :m | - m fullRedrawNotNeeded ]]. - - "Equivalent to - self needsRedraw: false. - self submorphNeedsRedraw: false. - " - id _ id bitAnd: `3 bitInvert`! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/30/2021 11:38:26'! - fullUpdateCurrentProtrudingBounds - "Recursively update display bounds, for currentMorph and all submorphs, - but only for those whose bounds may go outside owner bounds." - - | isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph isOrthoRectangularMorph - ifTrue: [currentMorph displayBoundsSetFrom: self] - ifFalse: [ - "In these cases, #drawOn: is required to find bounds. - #displayBoundsSetFrom: will use the bounds found by us in these case. - See #displayBoundsSetFrom:" - currentMorph - drawOn: self; - displayBoundsSetFrom: self. - (currentMorph postDrawOn: self) ifTrue: [ - currentMorph displayBoundsUpdateFrom: self ]]. - (currentMorph submorphsMightProtrude and: [currentMorph clipsSubmorphsReally not]) ifTrue: [ - currentMorph submorphsDo: [ :m | - self fullUpdateProtrudingBounds: m ]]].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/30/2021 11:35:01'! - fullUpdateProtrudingBounds: aMorph - "Recursively update display bounds, for aMorph and all submorphs, - but only for those whose bounds may go outside owner bounds." - - aMorph visible ifTrue: [ - self into: aMorph. - self canvasToUse fullUpdateCurrentProtrudingBounds. - self outOfMorph ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/30/2021 12:22:21'! - updateCurrentBounds - "RUpdate display bounds, for currentMorph only." - - | isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph isOrthoRectangularMorph - ifTrue: [currentMorph displayBoundsSetFrom: self] - ifFalse: [ - "In these cases, #drawOn: is required to find bounds. - #displayBoundsSetFrom: will use the bounds found by us in these case. - See #displayBoundsSetFrom:" - currentMorph - drawOn: self; - displayBoundsSetFrom: self. - (currentMorph postDrawOn: self) ifTrue: [ - currentMorph displayBoundsUpdateFrom: self ]]].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/30/2021 12:22:33' prior: 50557222! - fullAddCurrentRect: addCurrentBounds submorphs: trySubmorphs to: aDamageRecorder - - addCurrentBounds ifTrue: [ - currentMorph needsRedraw: false. - self updateCurrentBounds. - aDamageRecorder recordInvalidRect: currentMorph displayBounds for: currentMorph ]. - trySubmorphs ifTrue: [ - (currentMorph submorphsMightProtrude and: [currentMorph clipsSubmorphsReally not]) - ifTrue: [ - currentMorph submorphNeedsRedraw: false. - currentMorph submorphsReverseDo: [ :m | - self fullAddRedrawRect: m to: aDamageRecorder ]] - ifFalse: [ currentMorph fullRedrawNotNeeded ]].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 7/30/2021 11:40:17' prior: 50570406! - updateHandsDisplayBounds: aWorldMorph - "Update displayBounds for carried morphs if never set. - Useful for new morph, that are created and attached to the hand." - - aWorldMorph handsDo: [ :hand | - hand hasSubmorphs ifTrue: [ - self into: hand. - hand submorphsDo: [ :morph | - morph displayBounds ifNil: [ - self fullUpdateProtrudingBounds: morph ]]. - self outOfMorph ]]! ! - -MorphicCanvas removeSelector: #fullUpdateCurrentBounds! - -!methodRemoval: MorphicCanvas #fullUpdateCurrentBounds stamp: 'Install-4718-Morphic-Optimization-JuanVuletich-2021Jul30-15h34m-jmv.001.cs.st 8/6/2021 11:45:14'! -fullUpdateCurrentBounds - - | isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph isOrthoRectangularMorph - ifTrue: [currentMorph displayBoundsSetFrom: self] - ifFalse: [ - "In these cases, #drawOn: is required to find bounds. - #displayBoundsSetFrom: will use the bounds found by us in these case. - See #displayBoundsSetFrom:" - currentMorph - drawOn: self; - displayBoundsSetFrom: self. - (currentMorph postDrawOn: self) ifTrue: [ - currentMorph displayBoundsUpdateFrom: self ]]. - currentMorph submorphsDo: [ :m | - self fullUpdateBounds: m ]].! - -MorphicCanvas removeSelector: #fullUpdateBounds:! - -!methodRemoval: MorphicCanvas #fullUpdateBounds: stamp: 'Install-4718-Morphic-Optimization-JuanVuletich-2021Jul30-15h34m-jmv.001.cs.st 8/6/2021 11:45:14'! -fullUpdateBounds: aMorph - - aMorph visible ifTrue: [ - self into: aMorph. - self canvasToUse fullUpdateCurrentBounds. - self outOfMorph ].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4718-Morphic-Optimization-JuanVuletich-2021Jul30-15h34m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4716] on 30 July 2021 at 3:44:24 pm'! -!LayoutAdjustingMorph methodsFor: 'adjusting' stamp: 'jmv 7/30/2021 15:20:27'! - adjustOwnerAt: aGlobalPoint millisecondSinceLast: millisecondSinceLast - - owner - adjustBy: self - at: aGlobalPoint! ! -!WindowEdgeAdjustingMorph methodsFor: 'adjusting' stamp: 'jmv 7/30/2021 15:22:03' overrides: 50591463! - adjustOwnerAt: aGlobalPoint millisecondSinceLast: millisecondSinceLast - - self basicAdjustOwnerAt: aGlobalPoint. - (owner isOrthoRectangularMorph and: [ - Preferences cheapWindowReframe or: [ - millisecondSinceLast > 200]]) ifTrue: [ - owner displayBounds newRectFrom: [ :f | - self basicAdjustOwnerAt: Sensor mousePoint. - owner morphPosition extent: owner morphExtent ]]! ! -!WindowEdgeAdjustingMorph methodsFor: 'adjusting' stamp: 'jmv 7/30/2021 15:18:57'! - basicAdjustOwnerAt: aGlobalPoint - | pointInTargetOwners | - - owner ifNotNil: [ - pointInTargetOwners _ aGlobalPoint + 1. - owner owner ifNotNil: [ :parent | - pointInTargetOwners _ parent internalizeFromWorld: pointInTargetOwners ]. - owner perform: selector with: pointInTargetOwners ]! ! -!LayoutAdjustingMorph methodsFor: 'stepping' stamp: 'jmv 7/30/2021 15:21:34' prior: 50579812 overrides: 50547624! - stepAt: millisecondSinceLast - "got the #mouseLeave: message" - | p | - hand ifNil: [ - Cursor currentCursor == self cursor ifTrue: [ Cursor defaultCursor activateCursor ]. - ^ self stopStepping ]. - "hasn't got the #mouseLeave: message (yet)" - p _ hand morphPosition. - hand lastMouseEvent mouseButton1Pressed - ifTrue: [ - self adjustOwnerAt: p millisecondSinceLast: millisecondSinceLast ] - ifFalse: [ - self stopStepping. - hand _ nil. - Cursor defaultCursor activateCursor ].! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 7/30/2021 15:41:46' prior: 50580047 overrides: 50539190! - addPossiblyUncoveredAreasIn: aRectangle to: aCollection - "Answer an array of rectangles encompassing those areas in aRectangle not completely - covered by self. These are the areas that might require further drawing (of morphs below us) - All areas that might possibly be uncovered must be included." - - | bounds radius | - self isOrthoRectangularMorph ifFalse: [ - aCollection add: aRectangle. - ^self ]. - - color mightBeTranslucent ifTrue: [ - aCollection add: aRectangle. - ^self ]. - - bounds _ self displayBounds. - bounds ifNil: [ - aCollection add: aRectangle. - ^self ]. - - "Solid rectangle. - This will be the fastest in many cases. So, please disable rounded corners if on slow hardware!!" - Theme current roundWindowCorners ifFalse: [ - aRectangle areasOutside: bounds do: [ :rect | aCollection add: rect ]. - ^self ]. - - "The solid rectangle does not include the corners. - Report a couple of rows (top and bottom) or columns (left and right) as uncovered areas. - We could also try to be more careful and answer each rounded corner... - Right now, report left and right columns as uncovered areas" - radius _ Theme current roundedWindowRadius. - aRectangle areasOutside: (bounds insetBy: radius@0) do: [ :rect | aCollection add: rect ].! ! - -WindowEdgeAdjustingMorph removeSelector: #adjustOwnerAt:! - -!methodRemoval: WindowEdgeAdjustingMorph #adjustOwnerAt: stamp: 'Install-4719-LayoutAdjusterFix-JuanVuletich-2021Jul30-15h38m-jmv.001.cs.st 8/6/2021 11:45:14'! -adjustOwnerAt: aGlobalPoint - | pointInTargetOwners | - - owner ifNotNil: [ - pointInTargetOwners _ aGlobalPoint + 1. - owner owner ifNotNil: [ :parent | - pointInTargetOwners _ parent internalizeFromWorld: pointInTargetOwners ]. - owner perform: selector with: pointInTargetOwners ]! - -LayoutAdjustingMorph removeSelector: #adjustOwnerAt:! - -!methodRemoval: LayoutAdjustingMorph #adjustOwnerAt: stamp: 'Install-4719-LayoutAdjusterFix-JuanVuletich-2021Jul30-15h38m-jmv.001.cs.st 8/6/2021 11:45:14'! -adjustOwnerAt: aGlobalPoint - - owner - adjustBy: self - at: aGlobalPoint! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4719-LayoutAdjusterFix-JuanVuletich-2021Jul30-15h38m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4719] on 30 July 2021 at 5:30:29 pm'! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 7/30/2021 17:29:15'! - displayFullBoundsForPatch - "Current full bounds of hand and carried submorphs. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around). - Integer pixel coordinates!!" - - | fullBounds | - fullBounds _ self displayBounds. - self submorphsDo: [ :m | - fullBounds _ fullBounds quickMerge: m displayFullBounds]. - lastPosition - ifNotNil: [ :lastPos | "When already carrying morphs around. Update rectangle to current hand position." - ^(fullBounds translatedBy: self morphPosition-lastPos) encompassingIntegerRectangle ]. - ^fullBounds encompassingIntegerRectangle! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 7/30/2021 17:24:48' prior: 50536280! - savePatchFrom: aCanvas appendDamageTo: aStream - "Save the part of the given canvas under this hand as a Form and return its bounding rectangle." - - | fullBounds | - fullBounds _ self displayFullBoundsForPatch intersect: (`0@0` extent: aCanvas extent). - savedPatch _ aCanvas savePatch: savedPatch bounds: fullBounds. - prevFullBounds _ fullBounds. - aStream nextPut: fullBounds.! ! - -HandMorph removeSelector: #displayFullBounds! - -!methodRemoval: HandMorph #displayFullBounds stamp: 'Install-4720-HandMorph-optimization-JuanVuletich-2021Jul30-17h15m-jmv.001.cs.st 8/6/2021 11:45:14'! -displayFullBounds - "Current full bounds of hand and carried submorphs. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around). - Integer pixel coordinates!!" - - | fullBounds | - fullBounds _ self displayBounds. - self submorphsDo: [ :m | - fullBounds _ fullBounds quickMerge: m displayFullBounds]. - lastPosition - ifNotNil: [ :lastPos | "When already carrying morphs around. Include also the rectangle updated to current hand position." - fullBounds _ fullBounds quickMerge: (fullBounds translatedBy: self morphPosition-lastPos) ]. - ^fullBounds encompassingIntegerRectangle! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4720-HandMorph-optimization-JuanVuletich-2021Jul30-17h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4720] on 31 July 2021 at 9:20:21 am'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 7/31/2021 09:19:37' prior: 50585435! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('AY' 'Angel Yan') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('bgs' 'Boris G. Shingarov') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('db' 'Douglas Brebner') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('EB' 'Eric Brandwein') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('FGJ' 'Fernando Gasperi Jabalera') - #('FJG' 'Facundo Javier Gelatti') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('GC' 'Gastón Caruso') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hlsf' 'Hilaire Fernandes') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('jar' 'Jaromir Matas') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('JO' 'Javier Olaechea') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('KLG' 'Gerald Klix') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MM' 'Mariano Montone') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('NM' 'Nicola Mingotti') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('pmon' 'Paolo Montrasi') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('RNG' 'Nahuel Garbezza') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('sjd' 'Santiago Jose Dandois') - #('SLD' 'Steve Davies') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('Squeak1.0' 'Squeak 1.0, September 20, 1996') - #('Squeak1.1' 'Squeak 1.1, September 23, 1996') - #('Squeak1.2' 'Squeak 1.2, June 29, 1997') - #('Squeak1.3' 'Squeak 1.3, January 16, 1998') - #('sr' 'Stephan Rudlof') - #('ss' 'Sebastian Sujarchuk') - #('SSS' 'Samuel S. Shuster') - #('ST-80' 'Smalltalk-80, version 2, of April 1, 1983') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tsl' 'Thiago da Silva Lino') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4721-AddNicolaAsKnownAuthor-JuanVuletich-2021Jul31-09h19m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4689] on 31 July 2021 at 8:35:26 pm'! -!FeatureRequirementUnsatisfied methodsFor: 'exceptionDescription' stamp: 'jmv 7/31/2021 20:26:38' prior: 50476010 overrides: 16839230! - defaultAction - "The default action taken if the exception is signaled." - - self messageText print. - PopUpMenu inform: self messageText.! ! -!FeatureRequirement methodsFor: 'requires' stamp: 'jmv 7/31/2021 20:34:40' prior: 50579349! - requireUnlessIn: toLoad main: mainFeatureOrNil requiringFeature: requiringFeatureOrNil - "See if all the requirements can be met and answer the load order" - - - self isAlreadySatisfied ifFalse: [ - (toLoad anySatisfy: [ :featReq | featReq sameNameAs: self]) ifFalse: [ - (self findPackageFileAsReqOf: mainFeatureOrNil) - ifTrue: [ | otherRequirements | - otherRequirements := self requirements. - otherRequirements ifNotNil: [ - otherRequirements do: [ :requires | - requires requireUnlessIn: toLoad main: (mainFeatureOrNil ifNil: [self]) requiringFeature: self ]]. - self == mainFeatureOrNil ifFalse: [ - self addToLoad: toLoad withMyRequirements: otherRequirements ]. - ] - ifFalse: [ - | failureMessage | - failureMessage _ name = #'Cuis-Base' - ifTrue: [ - 'Installing [', requiringFeatureOrNil name, - '] requires base system updated to #', self minRevision printString, String newLineString, - 'But this system is updated to #', SystemVersion current versionRevision second printString, String newLineString, - 'Please install Cuis base system updates and retry.' ] - ifFalse: [ - requiringFeatureOrNil notNil - ifTrue: [ - 'Could not find code package file for [', name, '].', String newLineString, - 'Installation of [', requiringFeatureOrNil name, '] failed.'] - ifFalse: [ - 'Could not find code package file for [', name, '].', String newLineString, - 'Installation failed.']]. - FeatureRequirementUnsatisfied signal: failureMessage. - ]]]. - - ^ toLoad! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4722-PackageInstallFailureErrorMessage-JuanVuletich-2021Jul31-18h11m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4722] on 1 August 2021 at 7:18:57 pm'! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 8/1/2021 19:05:12' prior: 50591044! - restoreSavedPatchOn: aCanvas - "Clear the changed flag and restore the part of the given canvas under this hand from the previously saved patch. If necessary, handle the transition to using the hardware cursor." - - self needsRedraw: false. - prevFullBounds ifNotNil: [ - aCanvas restorePatch: savedPatch bounds: prevFullBounds. - self invalidateDisplayRect: prevFullBounds for: nil. - submorphs isEmpty ifTrue: [ - "Dropped carried morph. - Make the transition to using hardware cursor. Clear savedPatch and - report one final damage rectangle to erase the image of the software cursor." - Cursor currentCursor == Cursor defaultCursor ifFalse: [ Cursor defaultCursor activateCursor ]. - "show hardware cursor" - prevFullBounds _ nil ]].! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 7/30/2021 17:24:48' prior: 50591613! - savePatchFrom: aCanvas appendDamageTo: aStream - "Save the part of the given canvas under this hand as a Form and return its bounding rectangle." - - | fullBounds | - fullBounds _ self displayFullBoundsForPatch intersect: (`0@0` extent: aCanvas extent). - savedPatch _ aCanvas savePatch: savedPatch bounds: fullBounds. - prevFullBounds _ fullBounds. - aStream nextPut: fullBounds.! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 8/1/2021 19:14:29' prior: 50591590! - displayFullBoundsForPatch - "Current full bounds of hand and carried submorphs. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around). - Integer pixel coordinates!!" - - | handBounds fullBounds | - handBounds _ self displayBounds. - fullBounds _ handBounds. - self submorphsDo: [ :m | - fullBounds _ fullBounds quickMerge: m displayFullBounds]. - lastPosition - ifNotNil: [ :lastPos | "When already carrying morphs around. Update rectangle to current hand position." - fullBounds _ (fullBounds translatedBy: self morphPosition-lastPos) quickMerge: handBounds ]. - ^fullBounds encompassingIntegerRectangle! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4723-HandMorph-Fixes-JuanVuletich-2021Aug01-19h12m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4723] on 1 August 2021 at 8:11:49 pm'! -!Transcript class methodsFor: 'private' stamp: 'jmv 8/1/2021 20:01:46' prior: 50541550! - canvas - "VectorCanvas is not safe WRT changes in Display extent. - Besides, it is expensive in memory. - The alternative of using (UISupervisor ui canvas) is not safe. We don't know in which state it is (currentMorph, geometry, etc), or it is in midst of state change, and inconsistent. Waiting for a safe stat is not an option: we want immeiate updates. - The only way to no longer need BitBltCanvas is to use BitBlt directly, possibly with a special StrikeFont. - That, of course, would mean that the Morphic version has no hope of ever matching it. - More thought is needed to find a simple and general solution. - " - (displayCanvas isNil or: [ - displayCanvas class ~= BitBltCanvas]) ifTrue: [ - displayCanvas _ BitBltCanvas onForm: Display ]. - ^ displayCanvas! ! -!TranscriptWindow class methodsFor: 'menu-world' stamp: 'jmv 8/1/2021 19:26:46' prior: 50410957! - worldMenuForOpenGroup - ^ `{{ - #itemGroup -> 10. - #itemOrder -> 50. - #label -> 'Transcript'. - #object -> TranscriptWindow. - #selector -> #openTranscript. - #icon -> #printerIcon. - #balloonText -> 'A window showing contents of the System Transcript'. - } asDictionary}`! ! -!TranscriptMorph methodsFor: 'drawing' stamp: 'jmv 8/1/2021 20:09:40' prior: 50541672 overrides: 50545913! - drawOn: aCanvas - "If we don't call super, clipping fails if zoomed / rotated, and nothing is shown." - super drawOn: aCanvas. - aCanvas clippingByCurrentMorphDo: [ - Transcript displayOnCanvas: aCanvas in: self morphLocalBounds ]. - self displayBounds ifNotNil: [ :r | - Transcript bounds:r ]. - self updateWorkspace! ! - -Transcript class removeSelector: #displayOnCanvas:! - -!methodRemoval: Transcript class #displayOnCanvas: stamp: 'Install-4724-Transcript-fixes-JuanVuletich-2021Aug01-20h04m-jmv.001.cs.st 8/6/2021 11:45:14'! -displayOnCanvas: aCanvas - " - 1 to: 2000 do: [ :i | i print ]. - 1 to: 750 do: [ :i | i print ]. - Transcript displayOn: Display in: bounds - " - | font count string x y fh innerR index | - "aCanvas form fill: aRectangle fillColor: `Color white`." - font _ FontFamily defaultFamilyAndPointSize. - - "innerR _ aRectangle insetBy: self padding." - innerR _ 0@0 extent: 100@100. - aCanvas newClipRect: innerR. - x _ innerR left. - y _ innerR top. - fh _ font lineSpacing. - count _ lastIndex - firstIndex \\ self maxEntries + 1 min: innerR height // fh - 1. - index _ lastIndex - count \\ self maxEntries + 1. - count timesRepeat: [ - string _ entries at: index. - aCanvas drawString: string at: x@y font: font color: `Color veryDarkGray`. - y _ y + fh. - index _ index \\ self maxEntries + 1 ]. - string _ unfinishedEntry contents. - aCanvas drawString: string at: x@y font: font color: `Color veryDarkGray`! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4724-Transcript-fixes-JuanVuletich-2021Aug01-20h04m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4724] on 2 August 2021 at 9:28:20 am'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/2/2021 09:25:35' prior: 50591381! - fullAddCurrentRect: addCurrentBounds submorphs: trySubmorphs to: aDamageRecorder - - | invalidateOwns | - invalidateOwns _ false. - addCurrentBounds ifTrue: [ - currentMorph needsRedraw: false. - self updateCurrentBounds. - invalidateOwns _ true ]. - trySubmorphs ifTrue: [ - (currentMorph submorphsMightProtrude and: [currentMorph clipsSubmorphsReally not]) - ifTrue: [ - currentMorph submorphNeedsRedraw: false. - currentMorph submorphsReverseDo: [ :m | - self fullAddRedrawRect: m to: aDamageRecorder ]] - ifFalse: [ - currentMorph fullRedrawNotNeeded. - invalidateOwns _ true ]]. - invalidateOwns ifTrue: [ - aDamageRecorder recordInvalidRect: currentMorph displayBounds for: currentMorph ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4725-MorphicInvalidationFix-JuanVuletich-2021Aug02-09h27m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4725] on 2 August 2021 at 11:05:07 am'! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/2/2021 11:04:42' prior: 50576080! - displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - aRectangle is clipped appropiately if some owner clips us. - See also #displayBoundsUpdateFrom:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - self isOrthoRectangularMorph - ifTrue: [ - "In these cases, #drawOn: might not be able to find bounds (InnerTextMorph, for example), - but it is OK to compute them from #morphLocalBounds. This is not true for non-orthoRectangular morphs!!" - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphFromLocalBounds ] - ifFalse: [ - "In this cases, we use the bounds bound by #drawOn. This method must therefore be called after calling #drawOn:." - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphAfterDraw. - self setProperty: #contour toValue: ( - self wantsContour ifTrue: [ aCanvas contourOfCurrentMorphAfterDrawInto: (self valueOfProperty: #contour) ]). - privateDisplayBounds hasPositiveExtent ifFalse: [ "This might happen for morphs with empty #drawOn: like, for example, LahoutMorphs." - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphFromLocalBounds ] - ]]]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4726-LayoutMorph-halo-fix-JuanVuletich-2021Aug02-11h03m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4726] on 2 August 2021 at 11:32:01 am'! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 8/2/2021 11:19:09' prior: 16786597 overrides: 50463424! - image: aForm multipliedBy: aColor at: aPoint - "Multiply aForm and aColor, then blend over destination. - aForm is a kind of advanced stencil, supplying brightness and opacity at each pixel - - (BitBltCanvas onForm: Display) image: ((Form dotOfSize: 50) asFormOfDepth: 32) multipliedBy: Color red at: 20@20. Display forceToScreen - " - aColor isTransparent ifFalse: [ - self class accessProtect critical: [ - self buildAuxWith: aForm multipliedWith: aColor. - self image: AuxForm at: aPoint sourceRect: aForm boundingBox ]]! ! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 8/2/2021 11:19:23' prior: 50590918! - stencil: stencilForm at: aPoint color: aColor - "Flood this canvas with aColor wherever stencilForm has non-zero pixels" - " - | dot | - dot := ((Form dotOfSize: 32) asFormOfDepth: 1) offset: 0@0. - dot displayAt: 20@20. - (BitBltCanvas onForm: Display) stencil: dot at: 60@20 color: Color red. - Display forceToScreen - " - ^self stencil: stencilForm - at: aPoint - sourceRect: stencilForm boundingBox - color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 8/2/2021 11:16:46' prior: 50532847 overrides: 50463460! - fillRectangle: aRectangle tilingWith: aForm multipliedBy: aColor - "Fill aRectangle with the equivalent of aForm multiplied by aColor - aForm is a kind of advanced stencil, supplying brightness and opacity at each pixel - Similar to #image:multipliedBy:at: - - - (BitBltCanvas onForm: Display) fillRectangle: (10@10 extent: 100@100) tilingWith: (BitBltCanvas verticalGrayGradient: 30 gradientTop: 0.8 gradientBottom: 0.5) multipliedBy: Color red. Display forceToScreen. - " - - - engine ifNil: [ ^nil ]. - - self class accessProtect critical: [ - self buildAuxWith: aForm multipliedWith: aColor. - "Warning: aForm boundingBox is most likely different from AuxForm boundingBox!!" - self fillRectangle: aRectangle tilingWith: AuxForm sourceRect: aForm boundingBox rule: Form paint ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 8/2/2021 11:16:59' prior: 50545223 overrides: 50463473! - frameRectangle: r borderWidth: borderWidth color: borderColor - " - (BitBltCanvas onForm: Display) - frameRectangle: (10@10 extent: 300@200) - borderWidth: 20 - color: Color red. - Display forceToScreen - " - | rect bw | - - engine ifNil: [ ^nil ]. - - (borderWidth > 0 and: [ borderColor isTransparent not ]) ifTrue: [ - rect _ (currentTransformation externalizeRectangle: r) rounded. - bw _ (currentTransformation externalizeScalar: borderWidth) rounded. - self setPaintColor: borderColor. - engine - frameRect: rect - borderWidth: bw ]! ! -!BitBltCanvas methodsFor: 'drawing-roundedRectangles' stamp: 'jmv 8/2/2021 11:15:28' prior: 50569934 overrides: 50463492! - roundRect: aRectangle color: aColor radius: r - " - (BitBltCanvas onForm: Display) roundRect: (10@10 extent: 200@100) color: Color red radius: 10.5. Display forceToScreen. - " - - engine ifNil: [ ^nil ]. - - "radius is not scaled properly..." - "top stripe" - self - image: (self class topLeftCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle topLeft. - self - image: (self class topRightCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle topRight - (r@0). - self fillRectangle: ((aRectangle withHeight: r) insetBy: r@0) color: aColor. - - "center stripe" - self fillRectangle: (aRectangle insetBy: (0 @ r corner: 0 @ r)) color: aColor. - - "bottom stripe" - self - image: (self class bottomLeftCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle bottomLeft - (0@r). - self - image: (self class bottomRightCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle bottomRight - (r@r) . - self fillRectangle: ((aRectangle bottomLeft + (r@r negated)) extent: (aRectangle width - r - r@r)) color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-windows' stamp: 'jmv 8/2/2021 11:20:54' prior: 50578757! - windowFrame: aRectangle color: aColor radius: r border: bw labelHeight: lh gradientTop: topFactor gradientBottom: bottomFactor insideColor: insideColor - " - BitBltCanvas releaseClassCachedState; releaseClassState. - (BitBltCanvas onForm: Display) windowFrame: (10@10 extent: 200@100) color: Color red radius: 10 border: 5 labelHeight: 25 gradientTop: 1.0 gradientBottom: 0.5 insideColor: Color green. - Display forceToScreen - " - "top stripe" - | bottomColor he tl tr | - - engine ifNil: [ ^nil ]. - - self - image: (self class topLeftCorner: r height: lh gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: aRectangle topLeft. - self - image: (self class topRightCorner: r height: lh gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: aRectangle topRight - (r@0). - self - fillRectangle: ((aRectangle withHeight: lh) insetBy: r@0) - tilingWith: (self class verticalGrayGradient: lh gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor. - - bottomColor _ aColor * bottomFactor. - - "left and right borders" - tl _ aRectangle topLeft + (0@lh). - tr _ aRectangle topRight + (bw negated@lh). - he _ bw@(aRectangle height - lh - r). - self fillRectangle: (tl extent: he) color: bottomColor. - self fillRectangle: (tr extent: he) color: bottomColor. - - "bottom stripe" - self - image: (self class bottomLeftCorner: r height: r gradientTop: 1 gradientBottom: 1 borderWidth: bw) - multipliedBy: bottomColor - at: aRectangle bottomLeft - (0@r). - self - image: (self class bottomRightCorner: r height: r gradientTop: 1 gradientBottom: 1 borderWidth: bw) - multipliedBy: bottomColor - at: aRectangle bottomRight - (r@r) . - self fillRectangle: ((aRectangle bottomLeft + (r@bw negated)) extent: (aRectangle width - r - r@bw)) color: bottomColor. - - "inside" - self fillRectangle: (aRectangle insetBy: (bw@lh corner: bw@bw)) color: insideColor! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 8/2/2021 11:18:01' prior: 50495196! - frameRectangle: rect borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor - "rect and borderWidth are in targetForm coordinates. No transformation is done." - " - (BitBltCanvas onForm: Display) - frameRectangle: (10@10 extent: 300@200) - borderWidth: 20 - topLeftColor: Color green - bottomRightColor: Color red. - (BitBltCanvas onForm: Display) fillRectangle: (100@100 extent: 300@200) color: Color white. - Display forceToScreen. - " - | w h | - - rect area = 0 ifTrue: [^ self]. - - self setPaintColor: topLeftColor. - - engine frameRectTopLeft: rect borderWidth: borderWidth. - - borderWidth isNumber - ifTrue: [w _ h _ borderWidth] - ifFalse: [w _ borderWidth x. h _ borderWidth y]. - self setPaintColor: bottomRightColor. - engine - frameRectRight: rect width: w; - frameRectBottom: rect height: h! ! -!BitBltCanvas class methodsFor: 'cached forms' stamp: 'jmv 8/2/2021 11:29:15' prior: 16787202! - bottomLeftCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - ^self cachedForms - at: { #bottomLeft. r asInteger. height asInteger. (gradientTopFactor*100) asInteger. (gradientBottomFactor*100) asInteger} - ifAbsentPut: [ - Form - bottomLeftCorner: r - height: height - gradientTop: gradientTopFactor - gradientBottom: gradientBottomFactor ]! ! -!BitBltCanvas class methodsFor: 'cached forms' stamp: 'jmv 8/2/2021 11:28:51' prior: 16787216! - bottomLeftCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor borderWidth: bw - ^self cachedForms - at: { #bottomLeft. r asInteger. height asInteger. (gradientTopFactor*100) asInteger. (gradientBottomFactor*100) asInteger. bw asInteger} - ifAbsentPut: [ - Form - bottomLeftCorner: r - height: height - gradientTop: gradientTopFactor - gradientBottom: gradientBottomFactor - borderWidth: bw ]! ! -!BitBltCanvas class methodsFor: 'cached forms' stamp: 'jmv 8/2/2021 11:28:58' prior: 16787231! - bottomRightCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - ^self cachedForms - at: { #bottomRight. r asInteger. height asInteger. (gradientTopFactor*100) asInteger. (gradientBottomFactor*100) asInteger} - ifAbsentPut: [ - Form - bottomRightCorner: r - height: height - gradientTop: gradientTopFactor - gradientBottom: gradientBottomFactor ]! ! -!BitBltCanvas class methodsFor: 'cached forms' stamp: 'jmv 8/2/2021 11:29:31' prior: 16787245! - bottomRightCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor borderWidth: bw - ^self cachedForms - at: { #bottomRight. r asInteger. height asInteger. (gradientTopFactor*100) asInteger. (gradientBottomFactor*100) asInteger. bw asInteger} - ifAbsentPut: [ - Form - bottomRightCorner: r - height: height - gradientTop: gradientTopFactor - gradientBottom: gradientBottomFactor - borderWidth: bw ]! ! -!BitBltCanvas class methodsFor: 'cached forms' stamp: 'jmv 8/2/2021 11:29:37' prior: 16787278! -topLeftCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - ^self cachedForms - at: { #topLeft. r asInteger. height asInteger. (gradientTopFactor*100) asInteger. (gradientBottomFactor*100) asInteger} - ifAbsentPut: [ - Form - topLeftCorner: r - height: height - gradientTop: gradientTopFactor - gradientBottom: gradientBottomFactor ]! ! -!BitBltCanvas class methodsFor: 'cached forms' stamp: 'jmv 8/2/2021 11:29:41' prior: 16787291! - topRightCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - ^self cachedForms - at: { #topRight. r asInteger. height asInteger. (gradientTopFactor*100) asInteger. (gradientBottomFactor*100) asInteger} - ifAbsentPut: [ - Form - topRightCorner: r - height: height - gradientTop: gradientTopFactor - gradientBottom: gradientBottomFactor ]! ! -!BitBltCanvas class methodsFor: 'cached forms' stamp: 'jmv 8/2/2021 11:29:59' prior: 50360852! - verticalGrayGradient: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - ^self cachedForms - at: { #vertical. height asInteger. (gradientTopFactor*100) asInteger. (gradientBottomFactor*100) asInteger} - ifAbsentPut: [ - Form - verticalGradient: height - topColor: (Color gray: gradientTopFactor) - bottomColor: (Color gray: gradientBottomFactor) ]! ! -!BitBltCanvas class methodsFor: 'cached button forms' stamp: 'jmv 8/2/2021 11:26:03' prior: 16787319! - arrowOfDirection: aSymbol size: finalSizeInteger - ^self cachedForms - at: { aSymbol . finalSizeInteger asInteger} - ifAbsentPut: [ - self buildArrowOfDirection: aSymbol size: finalSizeInteger ]! ! -!BitBltCanvas class methodsFor: 'cached button forms' stamp: 'jmv 8/2/2021 11:31:13' prior: 50577854! - windowButtonIcon: aSymbol size: finalSizeInteger - ^self cachedForms - at: { aSymbol . finalSizeInteger asInteger} - ifAbsentPut: [ - | icon w h factor magnifiedExtent magnifiedIcon | - icon _ Theme current perform: aSymbol. - magnifiedIcon _ icon. - w _ icon width. - h _ icon height. - w*h = 0 ifFalse: [ - factor _ 1.0 * finalSizeInteger / w min: 1.0 * finalSizeInteger / h. - factor = 1.0 ifFalse: [ - magnifiedExtent _ (icon extent * factor) rounded. - magnifiedIcon _ icon magnifyTo: magnifiedExtent ]]. - magnifiedIcon ]! ! - -BitBltCanvas class removeSelector: #buildArrowWith:borderForm:! - -!methodRemoval: BitBltCanvas class #buildArrowWith:borderForm: stamp: 'Install-4727-AvoidFloatsAsDictionaryKeys-JuanVuletich-2021Aug02-11h14m-jmv.002.cs.st 8/6/2021 11:45:14'! -buildArrowWith: insideForm borderForm: borderForm - | extent translucentForm color insideSpec borderSpec border background alpha| - " - Display getCanvas - image: (BitBltCanvas buildArrowWith: BitBltCanvas downInsideForm borderForm: BitBltCanvas downBorderForm) - at: 20@20 - Display getCanvas - image: (BitBltCanvas buildArrowWith:BitBltCanvas upInsideForm borderForm: BitBltCanvas upBorderForm) - at: 40@20 - " - extent _ insideForm extent - `1@2`. - translucentForm _ Form extent: insideForm extent depth: 32. - 0 to: extent x-1 do: [ :x | - 0 to: extent y-1 do: [ :y | - insideSpec _ insideForm colorAt: x@(y+1). - borderSpec _ borderForm colorAt: x@(y+1). - insideSpec = `Color r: 0.0 g: 0.0 b: 1.0` - ifTrue: [ color _ `Color transparent` ] - ifFalse: [ - borderSpec = `Color r: 1.0 g: 0.0 b: 0.0` - ifTrue: [ color _ insideSpec ] - ifFalse: [ - border _ x < (extent x//2) - ifTrue: [`Color white`] - ifFalse: [`Color black`]. - background _ borderForm colorAt: extent x@(y+1). - alpha _ borderSpec red asFloat - background red / (border red - background red). - color _ border alpha: (alpha min: 1 max: 0) ]]. - translucentForm colorAt: x@y put: color ]]. - ^translucentForm! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -BitBltCanvas releaseClassCachedState; releaseClassState.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4727-AvoidFloatsAsDictionaryKeys-JuanVuletich-2021Aug02-11h14m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4727] on 2 August 2021 at 2:53:12 pm'! -!MorphicCanvas methodsFor: 'drawing-icons' stamp: 'jmv 8/2/2021 14:21:31'! - drawExpandedAt: aPoint - "For Tree View (IndentingListItemMorph)" - - self subclassResponsibility.! ! -!MorphicCanvas methodsFor: 'drawing-icons' stamp: 'jmv 8/2/2021 14:21:53'! - drawNotExpandedAt: aPoint - "For Tree View (IndentingListItemMorph)" - - self subclassResponsibility.! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 8/2/2021 14:50:23' overrides: 50592641! - drawExpandedAt: aPoint - "For Tree View (IndentingListItemMorph)" - - | f | - f _ BitBltCanvas arrowOfDirection: #down size: 17. - self - image: f - at: aPoint x-3 @ (aPoint y - (f height // 2)).! ! -!BitBltCanvas methodsFor: 'drawing-icons' stamp: 'jmv 8/2/2021 14:50:32' overrides: 50592647! - drawNotExpandedAt: aPoint - "For Tree View (IndentingListItemMorph)" - - | f | - f _ BitBltCanvas arrowOfDirection: #right size: 17. - self - image: f - at: aPoint x-1 @ (aPoint y - (f height // 2)).! ! -!InnerHierarchicalListMorph methodsFor: 'drawing' stamp: 'jmv 8/2/2021 14:45:19' prior: 16854911! - drawLineToggleToTextFor: anIndentingListItemMorph on: aCanvas lineColor: lineColor hasToggle: hasToggle - "If I am not the only item in my container, draw the line between: - - my left edge - - and my text left edge" - - | aMorphCenter hLineY hLineLeft rect right | - anIndentingListItemMorph isSoleItem ifTrue: [ ^ self ]. - hasToggle ifFalse: [ - rect _ anIndentingListItemMorph toggleRectangle. - aMorphCenter _ anIndentingListItemMorph externalize: rect center. - right _ (anIndentingListItemMorph externalize: rect rightCenter) x. - hLineY _ aMorphCenter y. - hLineLeft _ aMorphCenter x - 1. - aCanvas - line: hLineLeft @ hLineY - to: right @ hLineY - width: 1 - color: lineColor ]! ! -!IndentingListItemMorph methodsFor: 'drawing' stamp: 'jmv 8/2/2021 14:18:46' prior: 50503493 overrides: 50555245! - drawOn: aCanvas - - | x colorToUse centeringOffset | - isHighlighted ifTrue: [ - aCanvas - fillRectangle: self morphLocalBounds - color: ((Theme current - listHighlightFocused: owner owner hasKeyboardFocus) alpha: 0.3) ]. - - isSelected ifTrue: [ - aCanvas - fillRectangle: self morphLocalBounds - color: (Theme current - listHighlightFocused: owner owner hasKeyboardFocus) ]. - - x _ 12 * indentLevel. - - complexContents hasContents ifTrue: [ - isExpanded - ifTrue: [ aCanvas drawExpandedAt: x@(extent y//2)] - ifFalse: [ aCanvas drawNotExpandedAt: x@(extent y//2) ]]. - x _ x + 18. - - icon isNil ifFalse: [ - centeringOffset _ ((extent y - icon height) / 2.0) rounded. - aCanvas - image: icon - at: (x @ centeringOffset). - x _ x + 20 ]. - - colorToUse _ complexContents preferredColor ifNil: [ color ]. - aCanvas - drawString: contents asString - at: x@0 - font: self fontToUse - color: colorToUse! ! - -HierarchicalListMorph removeSelector: #notExpandedForm! - -!methodRemoval: HierarchicalListMorph #notExpandedForm stamp: 'Install-4728-TreeMorphEnh-JuanVuletich-2021Aug02-14h09m-jmv.005.cs.st 8/6/2021 11:45:14'! -notExpandedForm - - ^BitBltCanvas arrowOfDirection: #right size: 13! - -HierarchicalListMorph removeSelector: #expandedForm! - -!methodRemoval: HierarchicalListMorph #expandedForm stamp: 'Install-4728-TreeMorphEnh-JuanVuletich-2021Aug02-14h09m-jmv.005.cs.st 8/6/2021 11:45:14'! -expandedForm - - ^BitBltCanvas arrowOfDirection: #down size: 13! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4728-TreeMorphEnh-JuanVuletich-2021Aug02-14h09m-jmv.005.cs.st----! - -'From Cuis 5.0 [latest update: #4728] on 2 August 2021 at 3:53:59 pm'! -!MessageSet methodsFor: 'message list' stamp: 'pb 8/1/2021 18:28:53'! - sortReverse - "Reverse the current sort order" - messageList _ messageList reversed . - self changed: #messageList! ! -!MessageSetWindow methodsFor: 'menu building' stamp: 'jmv 8/2/2021 15:52:15' prior: 50585358 overrides: 50403930! - addExtraMenu2ItemsTo: options - "The shifted selector-list menu is being built. Add items specific to MessageSet" - - model growable ifTrue: [ - options add: `{ - #itemGroup -> 40. - #itemOrder -> 31. - #label -> 'remove from this browser'. - #object -> #model. - #selector -> #removeMessageFromBrowser. - #icon -> #listRemoveIcon - } asDictionary`. - options add:`{ - #itemGroup -> 40. - #itemOrder -> 32. - #label -> 'filter message list...'. - #selector -> #filterMessageList. - #icon -> #findIcon - } asDictionary` ]. - - options add: `{ - #itemGroup -> 41. - #itemOrder -> 33. - #label -> 'sort by class'. - #object -> #model. - #selector -> #sortByClass. - #icon -> #classIcon - } asDictionary`. - options add: `{ - #itemGroup -> 41. - #itemOrder -> 34. - #label -> 'sort by selector'. - #object -> #model. - #selector -> #sortBySelector. - #icon -> #scriptIcon - } asDictionary`. - options add: `{ - #itemGroup -> 41. - #itemOrder -> 35. - #label -> 'sort by date'. - #object -> #model. - #selector -> #sortByDate. - #icon -> #dateIcon - } asDictionary`. - options add: `{ - #itemGroup -> 41. - #itemOrder -> 36. - #label -> 'reverse sort'. - #object -> #model. - #selector -> #sortReverse. - #icon -> #redoIcon - } asDictionary`. - -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4729-MessageSet-sorting-PhilBellalouna-2021Aug02-15h50m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4729] on 2 August 2021 at 9:26:39 pm'! -!Rectangle methodsFor: 'transforming' stamp: 'jmv 8/2/2021 21:22:04' prior: 16899039! - translatedBy: delta - "Answer a Rectangle translated by delta, a Point or a scalar." - - ^Rectangle origin: origin + delta corner: corner + delta! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 8/2/2021 21:25:52' prior: 50569418! - grabMorph: aMorph moveUnderHand: moveUnderHand - "Grab the given morph (i.e., add it to this hand and remove it from its current owner). - If moveUnderHand is requested or it seems neccesary anyway, move the grabbed morph under the hand." - - | grabbed positionInHandCoordinates tx bounds | - self releaseMouseFocus. "Break focus" - grabbed _ aMorph. - aMorph owner ifNotNil: [ :o | grabbed _ o aboutToGrab: aMorph ]. - grabbed ifNil: [ ^ self ]. - grabbed _ grabbed aboutToBeGrabbedBy: self. - grabbed ifNil: [ ^ self ]. - - moveUnderHand ifTrue: [ - bounds _ nil. - grabbed isInWorld ifTrue: [ - grabbed displayBounds ifNotNil: [ :r | - bounds _ r translatedBy: grabbed morphPositionInWorld negated ]]. - bounds ifNil: [ bounds _ grabbed findBounds ]. - positionInHandCoordinates _ (bounds center *2 + bounds bottomRight //3) negated. - self grabMorph: grabbed delta: positionInHandCoordinates. - ^self ]. - - positionInHandCoordinates _ (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) - morphPositionInWorld - self morphPositionInWorld. - - tx _ GeometryTransformation identity. - (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) withAllOwnersDo: [ :o | - tx _ o location composedWith: tx ]. - self withAllOwnersReverseDo: [ :o | - tx _ o location inverseTransformation composedWith: tx ]. - self grabMorph: grabbed delta: positionInHandCoordinates. - - grabbed location: tx.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4730-BetterMoveUnderHand-JuanVuletich-2021Aug02-20h44m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4730] on 3 August 2021 at 11:12:20 am'! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/3/2021 10:00:10'! - basicDisplayBounds - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us. - Integer pixel coordinates!!" - - self visible ifFalse: [ ^nil ]. - ^ privateDisplayBounds! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 8/3/2021 11:04:36' overrides: 50592880! - basicDisplayBounds - - ^ self world canvas displayBoundsForHand: self! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 8/3/2021 11:04:44' overrides: 50592880! - basicDisplayBounds - ^ 0@0 extent: extent! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/3/2021 09:33:14' overrides: 50592163! - displayBoundsSetFrom: aCanvas - "Private for framework use. See super implementation." - - "Widgets don't need contour. Additionally, for InnerTextMorph and LayoutMorph, the bounds - can not be deduced from #drawOn: and should be computed from the 'extent' instance variable." - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - "In these cases, #drawOn: might not be able to find bounds (InnerTextMorph and LayoutMorph, for example), - but it is OK to compute them from #morphLocalBounds. This is not true for non-orthoRectangular morphs!!" - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphFromLocalBounds ]]].! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/3/2021 09:35:25' overrides: 50576118! - displayBoundsUpdateFrom: aCanvas - "Private for framework use. NOP here. See super implementation."! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/3/2021 11:06:31' prior: 50591219! - displayBounds - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us. - Integer pixel coordinates!!" - - | answer | - answer _ self basicDisplayBounds. - answer ifNil: [ ^nil ]. - answer hasPositiveExtent ifTrue: [ ^answer ]. - ^self displayFullBounds.! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 7/24/2020 10:21:33' prior: 50535563! - displayBoundsForHalo - "Answer the rectangle to be used as the inner dimension of my halos. - Allow for showing either bounds or fullBounds, and compensate for the optional bounds rectangle." - - ^ Preferences haloEnclosesFullBounds - ifFalse: [ self displayBounds ] - ifTrue: [ self displayFullBounds ]! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/3/2021 10:52:38' prior: 50591233! - displayBoundsOrBogus - "Never answer nil. A bogus value will trigger a draw operation, and bounds will later be corrected. - Integer pixel coordinates!!" - - ^self basicDisplayBounds ifNil: [ - Rectangle center: (self externalizeToWorld: `0@0`) extent: `2@2` ]! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/3/2021 09:34:43' prior: 50592163! - displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - aRectangle is clipped appropiately if some owner clips us. - See also #displayBoundsUpdateFrom:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - "Use the bounds bound by #drawOn. This method must therefore be called after calling #drawOn:." - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphAfterDraw. - self setProperty: #contour toValue: ( - self wantsContour ifTrue: [ aCanvas contourOfCurrentMorphAfterDrawInto: (self valueOfProperty: #contour) ])]]].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/3/2021 09:37:16' prior: 50576118! - displayBoundsUpdateFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us. - To be called after #postDrawOn:. See also #displayBoundsSetFrom: - This more complicated update is needed because the contour information from #drawOn: was possibly - when drawing submorphs. So, the controur from #drawOn: needs to be retrieved, and updated with the - new contour information from #postDrawOn:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - | oldTop oldBottom | - oldTop _ privateDisplayBounds top max: 0. - oldBottom _ privateDisplayBounds bottom-1. - privateDisplayBounds _ privateDisplayBounds - quickMerge: aCanvas boundingRectOfCurrentMorphAfterDraw. - self wantsContour ifTrue: [ - self setProperty: #contour toValue: - (aCanvas - contourOfCurrentMorphAfterDrawUpdate: (self valueOfProperty: #contour) - oldTop: oldTop - oldBottom: oldBottom)]]]].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/3/2021 10:52:51' prior: 50591244! - displayFullBounds - "Answer a rectangle that completely bounds receiver and submorphs when last drawn - (if the world was to be fully drawn, i.e. only to be used on a Canvas on the full world). - Integer pixel coordinates!!" - - | answer | - answer _ self basicDisplayBounds. - answer ifNil: [ ^nil ]. - (self submorphsMightProtrude and: [self clipsSubmorphsReally not]) ifTrue: [ - self submorphsReverseDo: [ :m | - answer _ answer quickMerge: m displayFullBounds ]]. - ^answer encompassingIntegerRectangle! ! -!KernelMorph methodsFor: 'geometry testing' stamp: 'jmv 8/3/2021 09:30:04' prior: 50591208 overrides: 50575990! - wantsContour - "Kernel morphs don't need contour" - - ^false! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 8/3/2021 11:09:33' prior: 50592827! - grabMorph: aMorph moveUnderHand: moveUnderHand - "Grab the given morph (i.e., add it to this hand and remove it from its current owner). - If moveUnderHand is requested or it seems neccesary anyway, move the grabbed morph under the hand." - - | grabbed positionInHandCoordinates tx bounds | - self releaseMouseFocus. "Break focus" - grabbed _ aMorph. - aMorph owner ifNotNil: [ :o | grabbed _ o aboutToGrab: aMorph ]. - grabbed ifNil: [ ^ self ]. - grabbed _ grabbed aboutToBeGrabbedBy: self. - grabbed ifNil: [ ^ self ]. - - moveUnderHand ifTrue: [ - bounds _ nil. - grabbed isInWorld ifTrue: [ - grabbed displayBounds ifNotNil: [ :r | - bounds _ r translatedBy: grabbed morphPositionInWorld negated ]]. - bounds ifNil: [ bounds _ grabbed findBounds ]. - positionInHandCoordinates _ (bounds center + bounds bottomRight //2) negated. - self grabMorph: grabbed delta: positionInHandCoordinates. - ^self ]. - - positionInHandCoordinates _ (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) - morphPositionInWorld - self morphPositionInWorld. - - tx _ GeometryTransformation identity. - (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) withAllOwnersDo: [ :o | - tx _ o location composedWith: tx ]. - self withAllOwnersReverseDo: [ :o | - tx _ o location inverseTransformation composedWith: tx ]. - self grabMorph: grabbed delta: positionInHandCoordinates. - - grabbed location: tx.! ! -!HaloMorph methodsFor: 'drawing' stamp: 'jmv 8/3/2021 09:59:35' prior: 50579188 overrides: 16899205! - drawOn: aCanvas - - | b | - target ifNil: [^super drawOn: aCanvas]. - - Preferences halosShowCoordinateSystem ifTrue: [ - target displayFullBounds ifNotNil: [ :fb | - aCanvas frameGlobalRect: fb borderWidth: 3 color: `Color black alpha: 0.3`. - b _ target displayBounds. - b = fb ifFalse: [ - aCanvas frameGlobalRect: b borderWidth: 3 color: `Color black alpha: 0.3` ]. - self drawCoordinateSystemOn: aCanvas ]].! ! -!WidgetMorph methodsFor: 'geometry testing' stamp: 'jmv 8/3/2021 09:29:54' prior: 50591214 overrides: 50575990! - wantsContour - "Widget morphs don't need contour" - - ^false! ! -!WindowEdgeAdjustingMorph methodsFor: 'drawing' stamp: 'jmv 8/3/2021 09:54:38' prior: 50579902 overrides: 50503570! - drawOn: aCanvas - - | c | - (owner is: #SystemWindow) ifFalse: [ - ^super drawOn: aCanvas ]. - - c _ owner windowFrameColor. - selector caseOf: { - [ #windowTopLeft: ] -> [ - aCanvas roundTopLeftCornerX: 0 y: 0 length: extent x border: owner borderWidth color: c ]. - [ #windowTopRight: ] -> [ - aCanvas roundTopRightCornerX: 0 y: 0 length: extent x border: owner borderWidth color: c ]. - [ #windowBottomLeft: ] -> [ - aCanvas roundBottomLeftCornerX: 0 y: 0 length: extent x border: owner borderWidth color: c ]. - [ #windowBottomRight: ] -> [ - aCanvas roundBottomRightCornerX: 0 y: 0 length: extent x border: owner borderWidth color: c ]. - } - otherwise: [ - "all the morph is sensitive for horizontal and vertical (i.e. non corner) instances." - aCanvas roundEdge: self morphLocalBounds color: c ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/3/2021 09:48:56' prior: 50591313! - fullUpdateCurrentProtrudingBounds - "Recursively update display bounds, for currentMorph and all submorphs, - but only for those whose bounds may go outside owner bounds." - - | isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - (currentMorph is: #WidgetMorph) - ifTrue: [currentMorph displayBoundsSetFrom: self] - ifFalse: [ - "In these cases, #drawOn: is required to find bounds. - #displayBoundsSetFrom: will use the bounds found by us in these case. - See #displayBoundsSetFrom:" - currentMorph - drawOn: self; - displayBoundsSetFrom: self. - (currentMorph postDrawOn: self) ifTrue: [ - currentMorph displayBoundsUpdateFrom: self ]]. - (currentMorph submorphsMightProtrude and: [currentMorph clipsSubmorphsReally not]) ifTrue: [ - currentMorph submorphsDo: [ :m | - self fullUpdateProtrudingBounds: m ]]].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/3/2021 09:50:14' prior: 50591357! - updateCurrentBounds - "Update display bounds, for currentMorph only." - - | isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - (currentMorph is: #WidgetMorph) - ifTrue: [currentMorph displayBoundsSetFrom: self] - ifFalse: [ - "In these cases, #drawOn: is required to find bounds. - #displayBoundsSetFrom: will use the bounds found by us in these case. - See #displayBoundsSetFrom:" - currentMorph - drawOn: self; - displayBoundsSetFrom: self. - (currentMorph postDrawOn: self) ifTrue: [ - currentMorph displayBoundsUpdateFrom: self ]]].! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 8/3/2021 10:00:12' prior: 50537287! - morph: aMorph isAtPoint: aPoint - aMorph basicDisplayBounds ifNotNil: [ :r | - (r containsPoint: aPoint) ifFalse: [ - ^false ]]. - ^aMorph morphContainsPoint: - (aMorph internalizeFromWorld: aPoint)! ! - -WorldMorph removeSelector: #displayBounds! - -!methodRemoval: WorldMorph #displayBounds stamp: 'Install-4731-MoveUnderHand-displayBounds-displayFullBounds-JuanVuletich-2021Aug03-10h59m-jmv.003.cs.st 8/6/2021 11:45:15'! -displayBounds - ^ 0@0 extent: extent! - -HandMorph removeSelector: #displayBounds! - -!methodRemoval: HandMorph #displayBounds stamp: 'Install-4731-MoveUnderHand-displayBounds-displayFullBounds-JuanVuletich-2021Aug03-10h59m-jmv.003.cs.st 8/6/2021 11:45:15'! -displayBounds - - ^ self world canvas displayBoundsForHand: self! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4731-MoveUnderHand-displayBounds-displayFullBounds-JuanVuletich-2021Aug03-10h59m-jmv.003.cs.st----! - -'From Cuis 5.0 [latest update: #4731] on 4 August 2021 at 9:37:48 am'! -!Morph methodsFor: 'events' stamp: 'jmv 8/4/2021 09:37:23' prior: 16874629! - mouseEnter: evt - "Handle a mouseEnter event, meaning the mouse just entered my bounds with no button pressed. - Note: a Morph must answer true to #handlesMouseOver: in order to receive this message." - - "Allow instances to dynamically use properties for handling common events." - self - valueOfProperty: #mouseEnter: - ifPresentDo: [ :handler | handler value: evt ]! ! -!Morph methodsFor: 'events' stamp: 'jmv 8/4/2021 09:37:07' prior: 50451013! - mouseLeave: evt - "Handle a mouseLeave event, meaning the mouse just left my bounds with no button pressed. - Note: a Morph must answer true to #handlesMouseOver: in order to receive this message." - - Preferences focusFollowsMouse - ifTrue: [evt hand releaseKeyboardFocus: self]. - "Allow instances to dynamically use properties for handling common events." - self - valueOfProperty: #mouseLeave: - ifPresentDo: [ :handler | handler value: evt ].! ! -!IndentingListItemMorph methodsFor: 'events' stamp: 'jmv 8/4/2021 09:35:18' prior: 50463648 overrides: 50593266! - mouseLeave: event - isHighlighted _ false. - self redrawNeeded. - ^super mouseLeave: event! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4732-mouseEnter-mouseLeave-fixAndComments-JuanVuletich-2021Aug04-09h35m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4732] on 4 August 2021 at 5:11:38 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/4/2021 17:02:09' prior: 50592974! - displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - aRectangle is clipped appropiately if some owner clips us. - See also #displayBoundsUpdateFrom:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - "Use the bounds bound by #drawOn. This method must therefore be called after calling #drawOn:." - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphAfterDraw. - self wantsContour ifTrue: [ - (aCanvas - contourOfCurrentMorphAfterDrawInto: (self valueOfProperty: #contour) - into: [ :contourArray :contourY0 :contourY1 | - self setProperty: #contour toValue: contourArray. - self setProperty: #contourY0 toValue: contourY0. - self setProperty: #contourY1 toValue: contourY1. - ]). - ] ifFalse: [ - self setProperty: #contour toValue: nil. - self setProperty: #contourY0 toValue: nil. - self setProperty: #contourY1 toValue: nil. - ]]]].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/4/2021 17:06:52' prior: 50593000! - displayBoundsUpdateFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us. - To be called after #postDrawOn:. See also #displayBoundsSetFrom: - This more complicated update is needed because the contour information from #drawOn: was possibly - when drawing submorphs. So, the controur from #drawOn: needs to be retrieved, and updated with the - new contour information from #postDrawOn:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - | oldContour oldTop oldBottom | - oldContour _ self valueOfProperty: #contour. - oldTop _ self valueOfProperty: #contourY0. - oldBottom _ self valueOfProperty: #contourY1. - privateDisplayBounds _ privateDisplayBounds - quickMerge: aCanvas boundingRectOfCurrentMorphAfterDraw. - self wantsContour ifTrue: [ - (aCanvas - contourOfCurrentMorphAfterDrawUpdate: oldContour - oldTop: oldTop - oldBottom: oldBottom - into: [ :contourArray :contourY0 :contourY1 | - self setProperty: #contour toValue: contourArray. - self setProperty: #contourY0 toValue: contourY0. - self setProperty: #contourY1 toValue: contourY1. - ])]]]].! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 8/4/2021 17:04:08' prior: 50575654! - collides: aMorph - "Answer whether the pixels used by morphs touch at least at one place." - - privateDisplayBounds ifNil: [ - ^false ]. - - "Quick check with display bounds" - (aMorph displayBoundsIntersects: (privateDisplayBounds outsetBy: 1)) ifFalse: [ - ^false ]. - - "Precise check with contour, if available" - (self valueOfProperty: #contour) ifNotNil: [ :contour | | contourTop contourBottom | - contourTop _ self valueOfProperty: #contourY0. - contourBottom _ self valueOfProperty: #contourY1. - ^ aMorph contourIntersects: contour top: contourTop bottom: contourBottom ]. - - "If contour is not available, and both displayBounds overlap, answer true, as it is the best we can know." - ^ true! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 8/4/2021 17:11:18' prior: 50575944! - contourIntersects: aContourArray top: aContourTop bottom: aContourBottom - "Check if contours intersect. - If contour is not available, use displayBounds" - - | contour contourTop contourBottom x0Own x1Own x0Arg x1Arg | - contour _ self valueOfProperty: #contour. - contourTop _ (self valueOfProperty: #contourY0) ifNil: [aContourTop]. - contourBottom _ (self valueOfProperty: #contourY1) ifNil: [aContourBottom]. - - (contourTop max: aContourTop) to: (contourBottom min: aContourBottom) do: [ :y | - x0Own _ contour ifNil: [privateDisplayBounds left] ifNotNil: [ contour at: (y - contourTop) * 2 + 1 ]. - x1Own _ contour ifNil: [privateDisplayBounds right-1] ifNotNil: [ contour at: (y - contourTop) * 2 + 2 ]. - x0Arg _ aContourArray at: (y - aContourTop) * 2 + 1. - x1Arg _ aContourArray at: (y - aContourTop) * 2 + 2. - (x0Own <= x1Arg and: [ x0Arg <= x1Own ]) - ifTrue: [ ^true ]]. - - ^false! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 8/4/2021 17:06:14' prior: 50575745! - isCloserThan: aNumber toPoint: aPoint - "Answer true if our closest point to aPoint is less than aNumber pixels away. - In target surface (i.e. Display) coordinates. - Uses precise testing of the morph contour if available. See #knowsContour." - - | center contourTop contourBottom | - privateDisplayBounds ifNil: [ - ^false ]. - center _ privateDisplayBounds center. - "Quick checks: If not even within aNumber distance to display bounds, fail" - (center y - aPoint y) abs < (privateDisplayBounds height // 2 + aNumber) ifFalse: [ - ^false ]. - (center x - aPoint x) abs < (privateDisplayBounds width // 2 + aNumber) ifFalse: [ - ^false ]. - "Precise check with contour, if available" - (self valueOfProperty: #contour) ifNotNil: [ :contour | | y0 y1 x0 x1 | - contourTop _ self valueOfProperty: #contourY0. - contourBottom _ self valueOfProperty: #contourY1. - "Contour rows to consider are those within requested distance." - y0 _ aPoint y - aNumber max: contourTop. - y1 _ aPoint y + aNumber min: contourBottom. - y0 to: y1 do: [ :y | - x0 _ (contour at: (y - contourTop) * 2 + 1) - aNumber. - x1 _ (contour at: (y - contourTop) * 2 + 2) + aNumber. - "If a vertical line of 2*aNumber height centered on aPoint is inside the contour, quick exit" - (aPoint x between: x0 and: x1) ifTrue: [ ^true ]. - "Check if aPoint is close enough to contour" - (x0@y - aPoint) r < aNumber ifTrue: [ ^true ]. - (x1@y - aPoint) r < aNumber ifTrue: [ ^true ]]. - "Not inside, not close enough to contour" - ^ false ]. - "If contour is not available, and aPoint is close enough to displayBounds, answer true, as it is the best we can know." - ^ true! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4733-ContourAndBoundsFix-JuanVuletich-2021Aug04-16h40m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4733] on 4 August 2021 at 7:01:09 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/4/2021 18:31:09'! - externalizeBoundsToWorld: r - - ^owner - ifNotNil: [ owner externalizeBoundsToWorld: r ] - ifNil: [ r encompassingIntegerRectangle ]! ! -!MovableMorph methodsFor: 'dropping/grabbing' stamp: 'jmv 8/4/2021 18:31:20' overrides: 50593499! - externalizeBoundsToWorld: r - - | inOwners | - inOwners _ location displayBoundsOfTransformOf: r. - ^owner - ifNotNil: [ owner externalizeBoundsToWorld: inOwners ] - ifNil: [ inOwners ]! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 8/4/2021 18:30:34' overrides: 50593507! - externalizeBoundsToWorld: r - - ^ r! ! -!Morph methodsFor: 'change reporting' stamp: 'jmv 8/4/2021 19:00:12' prior: 50557103! - invalidateLocalRect: localRectangle - - self invalidateDisplayRect: (self externalizeBoundsToWorld: localRectangle) for: self.! ! -!PluggableListMorph methodsFor: 'dropping/grabbing' stamp: 'jmv 8/4/2021 18:28:20' prior: 50426278! - acceptDroppingMorph: aMorph atRow: row withEvent: dropEvent - - | args dropActionSelector | - - dropActionSelector _ self valueOfProperty: #dropActionSelector. - args _ dropActionSelector numArgs. - args = 1 ifTrue: [ ^model perform: dropActionSelector with: row]. - args = 2 ifTrue: [ | dropSelectorArgument | - dropSelectorArgument _ aMorph - valueOfProperty: #dropSelectorArgument - ifAbsent: [self error: 'aMorph is missing dropSelectorArgument property']. - ^model perform: dropActionSelector with: row with: dropSelectorArgument ]. - - self error: 'dropActionSelector must be a 1- or 2-keyword symbol' - - ! ! - -MorphicCanvas removeSelector: #externalizeDisplayBounds:from:! - -!methodRemoval: MorphicCanvas #externalizeDisplayBounds:from: stamp: 'Install-4734-Morphic-Cleanup-JuanVuletich-2021Aug04-18h58m-jmv.001.cs.st 8/6/2021 11:45:15'! -externalizeDisplayBounds: r from: aMorph - "r is a Rectangle, expressed in aMorph's coordinate system. - Answer another rectangle, that bounds r when translated to World coordinates" - - "Should translate only to whatever world or PasteUp we are displaying. - Fix when implementing multiple Canvases (Displays) showing different - (potentially nested Worlds)" - | inOwners owner | - self flag: #jmvVer2. - - inOwners _ aMorph location - ifNil: [ r ] - ifNotNil: [ :tx | tx displayBoundsOfTransformOf: r ]. - owner _ aMorph owner. - ^owner - ifNotNil: [ self externalizeDisplayBounds: inOwners from: owner] - ifNil: [ inOwners encompassingIntegerRectangle ]! - -PluggableListMorph removeSelector: #flashRow:! - -!methodRemoval: PluggableListMorph #flashRow: stamp: 'Install-4734-Morphic-Cleanup-JuanVuletich-2021Aug04-18h58m-jmv.001.cs.st 8/6/2021 11:45:15'! -flashRow: aRow - - ^self listMorph flashRow: aRow.! - -InnerListMorph removeSelector: #flashRow:! - -!methodRemoval: InnerListMorph #flashRow: stamp: 'Install-4734-Morphic-Cleanup-JuanVuletich-2021Aug04-18h58m-jmv.001.cs.st 8/6/2021 11:45:15'! -flashRow: aRow - - self world ifNotNil: [ :world | world canvas ifNotNil: [ :canvas | - Display flash: (canvas externalizeDisplayBounds: (self drawBoundsForRow: aRow) from: self) ]]. - -! - -WorldMorph removeSelector: #externalizeDisplayBounds:! - -!methodRemoval: WorldMorph #externalizeDisplayBounds: stamp: 'Install-4734-Morphic-Cleanup-JuanVuletich-2021Aug04-18h58m-jmv.001.cs.st 8/6/2021 11:45:15'! -externalizeDisplayBounds: r - - ^ r! - -MovableMorph removeSelector: #externalizeDisplayBounds:! - -!methodRemoval: MovableMorph #externalizeDisplayBounds: stamp: 'Install-4734-Morphic-Cleanup-JuanVuletich-2021Aug04-18h58m-jmv.001.cs.st 8/6/2021 11:45:15'! -externalizeDisplayBounds: r - - | inOwners | - "All senders of #displayBoundsOfTransformOf: should be rethought..." - self flag: #jmvVer2. - - inOwners _ location displayBoundsOfTransformOf: r. - ^owner - ifNotNil: [ owner externalizeDisplayBounds: inOwners ] - ifNil: [ inOwners ]! - -Morph removeSelector: #externalizeDisplayBounds:! - -!methodRemoval: Morph #externalizeDisplayBounds: stamp: 'Install-4734-Morphic-Cleanup-JuanVuletich-2021Aug04-18h58m-jmv.001.cs.st 8/6/2021 11:45:15'! -externalizeDisplayBounds: r - - "All senders of #displayBoundsOfTransformOf: should be rethought..." - self flag: #jmvVer2. - - ^owner - ifNotNil: [ owner externalizeDisplayBounds: r ] - ifNil: [ r encompassingIntegerRectangle ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4734-Morphic-Cleanup-JuanVuletich-2021Aug04-18h58m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4733] on 4 August 2021 at 7:02:29 pm'! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 8/4/2021 18:35:22' prior: 50556508 overrides: 50575613! - morphExtent: newExtent - "In our own coordinates!!" - - | oldExtent | - extent = newExtent ifFalse: [ - oldExtent _ extent. - (self privateExtent: newExtent) ifTrue: [ - self extentChanged: oldExtent. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]]! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 8/4/2021 18:36:04' prior: 50541829! - morphHeight: aNumber - "In our own coordinates!!" - - self morphExtent: extent x@aNumber! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 8/4/2021 18:35:59' prior: 50541834! - morphWidth: aNumber - "In our own coordinates!!" - - self morphExtent: aNumber@extent y! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/4/2021 18:35:27' prior: 50556549 overrides: 50575613! -morphExtent: newExtent - "In our own coordinates!!" - - | oldExtent | - extent = newExtent ifFalse: [ - oldExtent _ extent. - (self privateExtent: newExtent) ifTrue: [ - self extentChanged: oldExtent. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]]! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/4/2021 18:36:07' prior: 50545965! - morphHeight: aNumber - "In our own coordinates!!" - - self morphExtent: extent x@aNumber! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/4/2021 18:36:01' prior: 50546002! - morphWidth: aNumber - "In our own coordinates!!" - - self morphExtent: aNumber@extent y! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4735-Comments-JuanVuletich-2021Aug04-19h01m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4733] on 4 August 2021 at 7:06:13 pm'! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 8/4/2021 18:46:45' prior: 50554246 overrides: 50575625! -morphPosition: aPoint - "Change the position of this morph. Argument is in owner's coordinates." - - (location isTranslation: aPoint) ifFalse: [ - location _ location withTranslation: aPoint. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ].! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 8/4/2021 18:53:36' prior: 50556521! - morphPosition: newPos extent: newExtent - "Change the position and extent of this morph. Arguments are owner's coordinates." - - self morphPosition: newPos. - self morphExtent: (self internalizeDistance: newExtent).! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 8/4/2021 19:05:09' prior: 50571052! - addHandles: aDisplayRectangle - "update my size. owner is world, therefore owner coordinates are Display coordinates." - - | b | - b _ aDisplayRectangle outsetBy: 30@30. - self morphPosition: b topLeft extent: b extent. - haloBox _ self handlesBox. - target addHandlesTo: self box: haloBox. - self addNameString: (target printStringLimitedTo: 40). - self redrawNeeded.! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/4/2021 18:53:31' prior: 50556562! - morphPosition: newPos extent: newExtent - "Change the position and extent of this morph. Arguments are owner's coordinates." - - self morphPosition: newPos. - self morphExtent: (self internalizeDistance: newExtent).! ! - -WidgetMorph removeSelector: #morphBounds:! - -!methodRemoval: WidgetMorph #morphBounds: stamp: 'Install-4736-Morphic-Cleanup-JuanVuletich-2021Aug04-19h02m-jmv.001.cs.st 8/6/2021 11:45:15'! -morphBounds: aRectangle - self morphPosition: aRectangle topLeft. - self morphExtent: aRectangle extent! - -KernelMorph removeSelector: #morphBounds:! - -!methodRemoval: KernelMorph #morphBounds: stamp: 'Install-4736-Morphic-Cleanup-JuanVuletich-2021Aug04-19h02m-jmv.001.cs.st 8/6/2021 11:45:15'! -morphBounds: aRectangle - self morphPosition: aRectangle topLeft. - self morphExtent: aRectangle extent! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4736-Morphic-Cleanup-JuanVuletich-2021Aug04-19h02m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4736] on 5 August 2021 at 10:36:30 am'! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/5/2021 10:33:19'! - findFullBoundsInOwner - "Find and answer full bounds in whatever owner. - These might not equal #displayFullBounds at all!!" - - "#morphExtent also valid in owner, because no VectorCanvas => no scaling." - ^(self morphPosition extent: self morphExtent) encompassingIntegerRectangle.! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 8/5/2021 09:51:40' prior: 50593064! - grabMorph: aMorph moveUnderHand: moveUnderHand - "Grab the given morph (i.e., add it to this hand and remove it from its current owner). - If moveUnderHand is requested or it seems neccesary anyway, move the grabbed morph under the hand." - - | grabbed positionInHandCoordinates tx bounds | - self releaseMouseFocus. "Break focus" - grabbed _ aMorph. - aMorph owner ifNotNil: [ :o | grabbed _ o aboutToGrab: aMorph ]. - grabbed ifNil: [ ^ self ]. - grabbed _ grabbed aboutToBeGrabbedBy: self. - grabbed ifNil: [ ^ self ]. - - moveUnderHand ifTrue: [ - bounds _ nil. - grabbed isInWorld ifTrue: [ - grabbed displayBounds ifNotNil: [ :r | - bounds _ r translatedBy: grabbed morphPositionInWorld negated ]]. - bounds ifNil: [ bounds _ grabbed findFullBoundsInOwner ]. - positionInHandCoordinates _ (bounds center + bounds bottomRight //2) negated. - self grabMorph: grabbed delta: positionInHandCoordinates. - ^self ]. - - positionInHandCoordinates _ (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) - morphPositionInWorld - self morphPositionInWorld. - - tx _ GeometryTransformation identity. - (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) withAllOwnersDo: [ :o | - tx _ o location composedWith: tx ]. - self withAllOwnersReverseDo: [ :o | - tx _ o location inverseTransformation composedWith: tx ]. - self grabMorph: grabbed delta: positionInHandCoordinates. - - grabbed location: tx.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4737-findFullBoundsInOwner-JuanVuletich-2021Aug05-10h31m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4737] on 5 August 2021 at 12:51:24 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/5/2021 12:26:43'! - morphLocalBoundsForError - "Only to be used for drawing in an error condition. See senders." - - ^`0@0 corner: 75@70`.! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 8/5/2021 12:33:56' overrides: 50554597! - morphExtentInWorld - "World coordinates" - - ^(self externalizeDistanceToWorld: extent) ceiling! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 8/5/2021 12:21:05' overrides: 16875435! - morphLocalBounds - - ^`0@0` extent: extent.! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 8/5/2021 12:26:40' overrides: 50593832! - morphLocalBoundsForError - "Only to be used for drawing in an error condition. See senders." - - ^self morphLocalBounds.! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/5/2021 12:33:59' overrides: 50554597! - morphExtentInWorld - "World coordinates" - - ^(self externalizeDistanceToWorld: extent) ceiling! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/5/2021 12:21:10' overrides: 16875435! - morphLocalBounds - - ^`0@0` extent: extent.! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/5/2021 12:26:47' overrides: 50593832! - morphLocalBoundsForError - "Only to be used for drawing in an error condition. See senders." - - ^self morphLocalBounds.! ! -!WidgetMorph methodsFor: 'layout' stamp: 'jmv 8/5/2021 12:06:55' overrides: 16876050! - minItemWidth - - ^extent x! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 8/5/2021 12:26:13' prior: 50387664! - drawOn: aCanvas - "A canvas is already set with a proper transformation from our coordinates to those of the Canvas target." - - aCanvas - fillRectangle: `-75@-70 corner: 75@70` - color: `Color blue`! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 8/5/2021 12:33:16' prior: 16899245 overrides: 50575619! - morphExtentInWorld: newExtent - "world coordinates" - - self morphExtent: (self internalizeDistanceFromWorld: newExtent).! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 8/5/2021 12:10:08' prior: 50367547 overrides: 16875429! - morphHeight - "In own's coordinates" - - ^ extent y! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 8/5/2021 12:07:26' prior: 50367585 overrides: 16875521! - morphWidth - "In own's coordinates" - - ^ extent x! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 8/5/2021 12:01:46' prior: 50559812! - attachMorphBeside: aMorph - - "Position the given morph beside this hand, then grab it." - - aMorph aboutToBeGrabbedBy: self. - self grabMorph: aMorph delta: extent x@0. -! ! -!WorldMorph methodsFor: 'canvas' stamp: 'jmv 8/5/2021 11:49:46' prior: 50551467! - ensureNonDisplayCanvas - (canvas isNil or: [ - canvas drawsOnDisplay or: [ - (canvas extent ~= extent) or: [ - canvas form depth ~= Display depth]]]) ifTrue: [ - "allocate a new offscreen canvas the size of the window" - self setCanvas: (MorphicCanvas withExtent: extent depth: Display depth)]! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/5/2021 12:33:12' prior: 50545951 overrides: 50575619! - morphExtentInWorld: newExtent - "world coordinates" - - self morphExtent: (self internalizeDistanceFromWorld: newExtent).! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/5/2021 12:10:12' prior: 50545959 overrides: 16875429! - morphHeight - "In own's coordinates" - - ^ extent y! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/5/2021 12:07:31' prior: 50545996 overrides: 16875521! - morphWidth - "In own's coordinates" - - ^ extent x! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 8/5/2021 11:43:29' prior: 50520216! - refreshExtent - "Invariant: my morphExtent >= my minimumExtent" - - self morphExtent: (extent max: self minimumExtent)! ! -!ProgressMorph methodsFor: 'accessing' stamp: 'jmv 8/5/2021 12:02:29' prior: 50523035! - label: aString subLabel: otherString - | label subLabel n | - label _ aString. - subLabel _ otherString. - layoutSpec notNil ifTrue: [ - n _ label size * extent x * 0.95 // (FontFamily defaultFamilyAndPointSize widthOfString: label). - label _ label squeezedTo: n. - n _ subLabel size * extent x * 0.95 // (FontFamily defaultFamilyAndPointSize widthOfString: subLabel). - subLabel _ subLabel squeezedTo: n ]. - self whenUIinSafeState: [ - labelMorph contents: label. - subLabelMorph contents: subLabel. - self updatePositionAndExtent. ]! ! -!ImageMorph methodsFor: 'drawing' stamp: 'jmv 8/5/2021 12:50:40' prior: 50555830 overrides: 50545913! - drawOn: aCanvas - - aCanvas image: image at: borderWidth@borderWidth. - (borderWidth > 0) ifTrue: [ - aCanvas - frameRectangle: (`0@0` extent: extent) - color: borderColor - borderWidth: borderWidth - borderStyleSymbol: #simple ]! ! -!InnerHierarchicalListMorph methodsFor: 'geometry' stamp: 'jmv 8/5/2021 12:12:41' prior: 50503590! - itemFromPoint: aPoint - "Return the list element (morph) at the given point or nil if outside" - | ptY last | - self hasSubmorphs ifFalse: [ ^nil ]. - (aPoint > `0@0` and: [ aPoint < extent ]) ifFalse: [ ^nil ]. - ptY _ aPoint y. - "note: following assumes that submorphs are vertical, non-overlapping, and ordered" - self firstSubmorph morphPosition y > ptY ifTrue: [ ^nil ]. - last _ self lastSubmorph. - last morphPosition y + last morphHeight < ptY ifTrue: [ ^nil ]. - "now use binary search" - ^self - findSubmorphBinary: [ :m | - (m morphPosition y <= ptY and: [ m morphPosition y + m morphHeight >= ptY ]) - ifTrue: [ 0 ] "found" - ifFalse: [ m morphPosition y + (m morphHeight // 2) > ptY ifTrue: [-1] ifFalse: [1]]]! ! -!InnerTextMorph methodsFor: 'drawing' stamp: 'jmv 8/5/2021 12:13:33' prior: 50530771 overrides: 50545913! - drawOn: aCanvas - "Draw the receiver on a canvas" - - false ifTrue: [ self debugDrawLineRectsOn: aCanvas ]. "show line rects for debugging" - - aCanvas - textComposition: self textComposition - bounds: self morphLocalBounds - color: color - selectionColor: (Theme current textHighlightFocused: self hasKeyboardFocus). - - model actualContents isEmpty ifTrue: [ - owner - valueOfProperty: #emptyTextDisplayMessage - ifPresentDo: [ :msg | - aCanvas - drawString: msg - at: `0@0` - font: nil - color: Theme current textEmptyDisplayMessage ]].! ! -!LabelMorph methodsFor: 'drawing' stamp: 'jmv 8/5/2021 12:14:09' prior: 50555245 overrides: 50545913! - drawOn: aCanvas - aCanvas - drawString: (contents ifNil: [ '' ]) - at: borderWidth@borderWidth - font: self fontToUse - color: color. - (borderWidth > 0) ifTrue: [ - aCanvas - frameRectangle: (`0@0` extent: extent) - color: borderColor - borderWidth: borderWidth - borderStyleSymbol: #simple ]! ! -!SystemWindow methodsFor: 'change reporting' stamp: 'jmv 8/5/2021 12:14:44' prior: 50503405! - invalidateTitleArea - - "not really pretty... also invalidating the top border, regardless of it being above or below the title area - (Different themes use various looks, this covers them all)" - self invalidateLocalRect: (`0@0` extent: extent x @ (self labelHeight + borderWidth))! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 8/5/2021 11:48:18' prior: 50384644! - makeMeFullyVisible - - self world morphExtent > `0@0` ifFalse: [^ self]. - - (self morphPosition >= `0@0` and: [ self morphPosition < (self world morphExtent-extent)]) ifTrue: [ - ^ self "OK -- visible"]. - - self morphPosition: (RealEstateAgent initialFrameFor: self initialExtent: self morphExtentInWorld world: self world) topLeft! ! -!SystemWindow methodsFor: 'resizing' stamp: 'jmv 8/5/2021 11:48:34' prior: 50580097! - windowBottomLeft: aPointInOwner - "aPointInOwner is in the owner's coordinate system" - - | delta | - delta _ (self internalize: aPointInOwner) - self morphBottomLeft. - self morphExtent: extent + (delta x negated @ delta y). - self morphPosition: self morphPosition + aPointInOwner - (self externalize: self morphBottomLeft).! ! -!SystemWindow methodsFor: 'resizing' stamp: 'jmv 8/5/2021 11:48:41' prior: 50580168! - windowTopRight: aPointInOwner - "aPointInOwner is in the owner's coordinate system" - - | delta | - delta _ (self internalize: aPointInOwner) - self morphTopRight. - self morphExtent: extent + (delta x @ delta y negated). - self morphPosition: self morphPosition + aPointInOwner - (self externalize: self morphTopRight).! ! -!HoverHelpMorph methodsFor: 'initialization' stamp: 'jmv 8/5/2021 12:08:28' prior: 16853835! - popUpForHand: aHand - "Pop up the receiver as balloon help for the given hand" - - | newPos x y | - (contents isNil or: [ contents isEmpty ]) ifTrue: [ ^self ]. - x _ aHand morphPosition x - 20. - y _ aHand morphPosition y + 20. - x + extent x > aHand world morphWidth ifTrue: [ - x _ aHand world morphWidth - extent x ]. - y + extent y > aHand world morphHeight ifTrue: [ - y _ aHand morphPosition y - extent y - 12 ]. - newPos _ x@y. - aHand world addMorphFront: self position: newPos. - aHand balloonHelp: self! ! -!MenuLineMorph methodsFor: 'drawing' stamp: 'jmv 8/5/2021 12:14:26' prior: 50503712 overrides: 50545913! - drawOn: aCanvas - | baseColor | - baseColor _ owner color. - aCanvas - fillRectangle: (`0@0` corner: extent x @ (extent y / 2)) - color: baseColor twiceDarker. - - aCanvas - fillRectangle: (0 @ (extent y / 2) corner: extent) - color: baseColor twiceLighter! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 8/5/2021 11:44:30' prior: 50535117! - popUpAdjacentTo: rightOrLeftPointInWorld from: sourceItem - "Present this menu at the given point under control of the given hand. - Used mostly for submenus." - - | trialRect | - popUpOwner _ sourceItem. - sourceItem world addMorphFront: self position: rightOrLeftPointInWorld first. - trialRect _ rightOrLeftPointInWorld first extent: extent. - trialRect right > sourceItem world morphWidth ifTrue: [ - self morphPosition: rightOrLeftPointInWorld second - (extent x@0)]. - self fitInWorld.! ! -!MenuMorph methodsFor: 'private' stamp: 'jmv 8/5/2021 11:43:50' prior: 50535136! - fitInWorld - - | delta trialRect | - trialRect _ Rectangle origin: self morphPosition extent: extent. - delta _ trialRect amountToTranslateWithin: owner displayBounds. - self morphPosition: trialRect origin + delta.! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 8/5/2021 12:27:03' prior: 50572526! - drawCurrentAsError - "The morph (or one of its submorphs) had an error in its drawing method." - | r r2 w | - r _ currentMorph morphLocalBoundsForError. - w _ r extent > `50@50` - ifTrue: [ 6 ] - ifFalse: [ 2 ]. - r2 _ r origin corner: r corner-w. - self - frameAndFillRectangle: r - fillColor: `Color red` - borderWidth: w - borderColor: `Color yellow`. - self line: r2 topLeft to: r2 bottomRight width: w color: `Color yellow`. - self line: r2 topRight to: r2 bottomLeft width: w color: `Color yellow`. - currentMorph displayBoundsSetFrom: self.! ! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 8/5/2021 12:18:57' prior: 50570469! - boundingRectOfCurrentMorphFromLocalBounds - "In targetForm coordinates. - Clipped to owner if appropriate. - Only valid for morphs where #morphLocalBounds is known" - - | boundingRect | - boundingRect _ currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds. - ^ clippingMorphDisplayBounds - ifNotNil: [ :ownerClips | boundingRect intersect: ownerClips ] - ifNil: [ boundingRect ]! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 8/5/2021 12:17:34' prior: 50570532 overrides: 50536534! - boundingRectOfCurrentMorphAfterDraw - "In targetForm coordinates. - Clipped to owner if appropriate. - BitBltCanvas doesn't keep track of Morph bounds as it draws them. But it is limited to drawing morphs where - #morphLocalBounds is known. Use it, then." - - | boundingRect | - boundingRect _ currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds. - ^ clippingMorphDisplayBounds - ifNotNil: [ :ownerClips | boundingRect intersect: ownerClips ] - ifNil: [ boundingRect ]! ! - -PasteUpMorph removeSelector: #fontPreferenceChanged! - -!methodRemoval: PasteUpMorph #fontPreferenceChanged stamp: 'Install-4738-Cleanup-JuanVuletich-2021Aug05-12h50m-jmv.001.cs.st 8/6/2021 11:45:15'! -fontPreferenceChanged - self submorphsDo: [ :m | - m morphExtent: (m morphExtent max: m minimumExtent). - m fontPreferenceChanged ]! - -KernelMorph removeSelector: #morphTopLeft! - -!methodRemoval: KernelMorph #morphTopLeft stamp: 'Install-4738-Cleanup-JuanVuletich-2021Aug05-12h50m-jmv.001.cs.st 8/6/2021 11:45:15'! -morphTopLeft - "Our hierarchy occupies a rectangle specified by #morphTopLef and #morphExtent" - ^`0@0`! - -Morph removeSelector: #morphHeight! - -!methodRemoval: Morph #morphHeight stamp: 'Install-4738-Cleanup-JuanVuletich-2021Aug05-12h50m-jmv.001.cs.st 8/6/2021 11:45:15'! -morphHeight - -"Ensure everybody wants owner's coordinates!!" - self flag: #jmvVer2. - ^ self morphExtent y! - -Morph removeSelector: #morphLocalBounds! - -!methodRemoval: Morph #morphLocalBounds stamp: 'Install-4738-Cleanup-JuanVuletich-2021Aug05-12h50m-jmv.001.cs.st 8/6/2021 11:45:15'! -morphLocalBounds - - ^self morphTopLeft extent: self morphExtent! - -Morph removeSelector: #morphContainsPoint:! - -!methodRemoval: Morph #morphContainsPoint: stamp: 'Install-4738-Cleanup-JuanVuletich-2021Aug05-12h50m-jmv.001.cs.st 8/6/2021 11:45:15'! -morphContainsPoint: aLocalPoint - "Not very good. False positives for non-rectangular morphs. - Only useful as a backstop if the Canvas can't do better." - - ^ self morphLocalBounds containsPoint: aLocalPoint! - -Morph removeSelector: #morphExtentInWorld! - -!methodRemoval: Morph #morphExtentInWorld stamp: 'Install-4738-Cleanup-JuanVuletich-2021Aug05-12h50m-jmv.001.cs.st 8/6/2021 11:45:15'! -morphExtentInWorld - "eventually, remove." - self flag: #jmvVer2. - ^(self externalizeDistanceToWorld: self morphExtent) ceiling! - -Morph removeSelector: #inATwoWayScrollPane! - -!methodRemoval: Morph #inATwoWayScrollPane stamp: 'Install-4738-Cleanup-JuanVuletich-2021Aug05-12h50m-jmv.001.cs.st 8/6/2021 11:45:15'! -inATwoWayScrollPane - "Answer a two-way scroll pane that allows the user to scroll the receiver in either direction. It will have permanent scroll bars unless you take some special action." - " - (EllipseMorph new morphExtent: 500@270) inATwoWayScrollPane openInHand - " - - | widget | - self flag: #jmvVer2. - widget _ PluggableScrollPane new. - widget addToScroller: self. - widget morphExtent: (self morphWidth min: 300 max: 100) @ (self morphHeight min: 150 max: 100). - widget setScrollDeltas. - ^widget! - -Morph removeSelector: #morphExtent! - -!methodRemoval: Morph #morphExtent stamp: 'Install-4738-Cleanup-JuanVuletich-2021Aug05-12h50m-jmv.001.cs.st 8/6/2021 11:45:15'! -morphExtent - "In our own coordinates!!" -"Quizas eventualmente borrar este tambien? (no se usa mucho...)" - self flag: #jmvVer2. - ^`150 @ 140`! - -Morph removeSelector: #morphTopLeft! - -!methodRemoval: Morph #morphTopLeft stamp: 'Install-4738-Cleanup-JuanVuletich-2021Aug05-12h50m-jmv.001.cs.st 8/6/2021 11:45:15'! -morphTopLeft - "By default, morphs occupy a rectangle specified by #morphExtent" - ^self morphExtent // 2 negated! - -Morph removeSelector: #morphExtent:! - -!methodRemoval: Morph #morphExtent: stamp: 'Install-4738-Cleanup-JuanVuletich-2021Aug05-12h50m-jmv.001.cs.st 8/6/2021 11:45:15'! -morphExtent: aPoint - "In our own coordinates!! - Ignored by morphs that are not resizeable."! - -Morph removeSelector: #morphExtentInWorld:! - -!methodRemoval: Morph #morphExtentInWorld: stamp: 'Install-4738-Cleanup-JuanVuletich-2021Aug05-12h50m-jmv.001.cs.st 8/6/2021 11:45:15'! -morphExtentInWorld: newExtent - "Argument is in world coordinates. - Ignored by morphs that are not resizeable."! - -Morph removeSelector: #morphWidth! - -!methodRemoval: Morph #morphWidth stamp: 'Install-4738-Cleanup-JuanVuletich-2021Aug05-12h50m-jmv.001.cs.st 8/6/2021 11:45:15'! -morphWidth - -"Ensure everybody wants owner's coordinates!!" - self flag: #jmvVer2. - ^ self morphExtent x! - -Morph removeSelector: #minItemWidth! - -!methodRemoval: Morph #minItemWidth stamp: 'Install-4738-Cleanup-JuanVuletich-2021Aug05-12h50m-jmv.001.cs.st 8/6/2021 11:45:15'! -minItemWidth - ^self morphWidth! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4738-Cleanup-JuanVuletich-2021Aug05-12h50m-jmv.001.cs.st----! - -----SNAPSHOT----(6 August 2021 11:45:18) Cuis5.0-4738-v3.image priorSource: 7953702! - -----STARTUP---- (20 August 2021 16:04:07) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4738-v3.image! - - -'From Cuis 5.0 [latest update: #4738] on 6 August 2021 at 5:47:36 pm'! -!Workspace class methodsFor: 'instance creation' stamp: 'jmv 8/6/2021 17:46:59' prior: 16945486! - openWorkspace - ^self new - contents: ''; - openLabel: 'Workspace'. -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4739-openWorkspace-returnsTheWorkspace-JuanVuletich-2021Aug06-17h17m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4738] on 7 August 2021 at 3:13:42 pm'! -!Utilities class methodsFor: 'identification' stamp: 'NM 8/7/2021 15:12:44'! - setAuthorName: aStringName initials: aStringInitials - "Set author name and initials programatically." - - AuthorName _ aStringName. - AuthorInitials _ aStringInitials. - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4740-SetAuthorProgramatically-NicolaMingotti-2021Aug07-15h12m-NM.001.cs.st----! - -'From Cuis 5.0 [latest update: #4740] on 7 August 2021 at 5:06:56 pm'! -!Preferences class methodsFor: 'standard queries' stamp: 'NM 8/7/2021 16:46:25'! - askForSaveOnQuit - ^ self - valueOfFlag: #askForSaveOnQuit - ifAbsent: [ true ].! ! -!Preferences class methodsFor: 'themes' stamp: 'NM 8/7/2021 16:37:36' prior: 50449634! - cuisDefaults - self setPreferencesFrom: #( - #(#askForSaveOnQuit true) - #(#balloonHelpEnabled true ) - #(#biggerCursors false ) - #(#browseWithPrettyPrint false ) - #(#caseSensitiveFinds false ) - #(#checkForSlips true ) - #(#cmdDotEnabled true ) - #(#diffsInChangeList true ) - #(#diffsWithPrettyPrint false ) - #(#menuKeyboardControl true ) - #(#optionalButtons true ) - #(#extraDebuggerButtons true ) - #(#subPixelRenderFonts true ) - #(#thoroughSenders true ) - #(#cheapWindowReframe false ) - #(#syntaxHighlightingAsYouType true ) - #(#tapAndHoldEmulatesButton2 true ) - #(#clickGrabsMorphs false ) - #(#syntaxHighlightingAsYouTypeAnsiAssignment false ) - #(#syntaxHighlightingAsYouTypeLeftArrowAssignment false ) - ). - self useMenuIcons.! ! -!TheWorldMenu methodsFor: 'commands' stamp: 'jmv 8/7/2021 17:06:20' prior: 16934631! -quitSession - - | doSaveImage | - doSaveImage _ Preferences askForSaveOnQuit and: [ - self confirm: 'Save the current image before quitting?' orCancel: [^ self]]. - Smalltalk - snapshot: doSaveImage - andQuit: true - clearAllClassState: false! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4741-askForSaveOnQuitPreference-NicolaMingotti-JuanVuletich-2021Aug07-17h04m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4741] on 8 August 2021 at 2:44:21 pm'! -!Number methodsFor: 'converting' stamp: 'jmv 8/8/2021 14:37:24'! - asFloat - ^ self subclassResponsibility.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4742-Number-asFloat-JuanVuletich-2021Aug08-14h37m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4741] on 8 August 2021 at 2:47:31 pm'! -!Inspector methodsFor: 'selecting' stamp: 'jmv 8/8/2021 14:46:53' prior: 50566476! - selectionPrintString - "Returns the current selection as a string" - ^self safelyPrintWith: [ - self selection printTextLimitedTo: self printStringLimit ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4743-StringInspectorFix-JuanVuletich-2021Aug08-14h44m-jmv.001.cs.st----! - -'From Haver 5.0 [latest update: #4743] on 10 August 2021 at 10:32:48 am'! -!TaskbarMorph methodsFor: 'submorphs-add/remove' stamp: 'KLG 8/10/2021 10:29:46' prior: 50432341 overrides: 16876712! - noteNewOwner: aMorph - "I have just been added as a submorph of aMorph" - - super noteNewOwner: aMorph. - aMorph submorphsDo: [ :subMorph | - subMorph isIncludedInTaskbar ifTrue: [ - self addButtonFor: subMorph ] ]. - self notifyDisplayResize! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4744-MakeTaskbarHonorIsIncludedInTaskbarOnCreation-GeraldKlix-2021Aug09-18h30m-KLG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4744] on 10 August 2021 at 10:14:28 am'! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 8/10/2021 10:13:48'! - refreshTaskbarFor: aMorph - - aMorph isIncludedInTaskbar - ifTrue: [ - (self buttonFor: aMorph) ifNil: [self addButtonFor: aMorph ]] - ifFalse: [ self removeButtonFor: aMorph ].! ! -!MenuMorph methodsFor: 'accessing' stamp: 'jmv 8/10/2021 10:10:57' prior: 16866317! - stayUp: aBoolean - - stayUp _ aBoolean. - aBoolean ifTrue: [ self removeStayUpBox ]. - self taskbar ifNotNil: [ :tb | tb refreshTaskbarFor: self ].! ! -!MenuMorph methodsFor: 'testing' stamp: 'jmv 8/10/2021 10:00:57' prior: 50577242 overrides: 50577211! - isIncludedInTaskbar - "Answer true a button for us should be added to any TaskbarMorph." - - ^ stayUp! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4745-IncludePinnedMenusInTaskbar-JuanVuletich-2021Aug10-10h12m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4745] on 10 August 2021 at 10:36:39 am'! -!SystemDictionary methodsFor: 'sources, change log' stamp: 'jmv 8/10/2021 10:35:47' prior: 16923395! - systemInformationString - "Identify software version" - ^ SystemVersion current version, String newLineString, - self lastUpdateString, String newLineString, - 'Running at :', self imageName.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4746-AddImageFullPathTo-AboutThisSystem-JuanVuletich-2021Aug10-10h34m-jmv.001.cs.st----! - -'From Haver 5.0 [latest update: #4743] on 9 August 2021 at 1:42:55 pm'! -!Theme methodsFor: 'widget colors' stamp: 'KLG 8/9/2021 13:39:35'! - hoverHelp - "Answer the hover help morph's background color." - - ^ `Color r: 1.0 g: 1.0 b: 0.7`! ! -!HoverHelpMorph methodsFor: 'initialization' stamp: 'KLG 8/9/2021 13:40:01' prior: 50388531 overrides: 50545900! - defaultColor - - ^ Theme current hoverHelp! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4747-ThemeableHoverHelpBackgroundColor-GeraldKlix-2021Aug09-13h36m-KLG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4746] on 10 August 2021 at 11:01:18 am'! -!BrowserWindow methodsFor: 'keyboard shortcuts' stamp: 'jmv 8/10/2021 11:00:03' overrides: 50469179! - messageListKey: aChar from: view - "Respond to a Command key. I am a model with a code pane, and I also - have a listView that has a list of methods. The view knows how to get - the list and selection." - - | sel | - sel _ model selectedMessageName. - sel - ifNotNil: [ - "The following require a method selection" - aChar == $R ifTrue: [^ self renameSelector]. - aChar == $U ifTrue: [^ self addParameter ]. - aChar == $I ifTrue: [^ self removeParameter ]]. - super messageListKey: aChar from: view! ! -!CodeWindow methodsFor: 'keyboard shortcuts' stamp: 'jmv 8/10/2021 11:00:35' prior: 50469179! - messageListKey: aChar from: view - "Respond to a Command key. I am a model with a code pane, and I also - have a listView that has a list of methods. The view knows how to get - the list and selection." - - | sel class | - aChar == $D ifTrue: [^ model toggleDiffing]. - - sel _ model selectedMessageName. - aChar == $m ifTrue: [ "These next two put up a type in if no message selected" - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllImplementorsOf: to: Smalltalk]. - aChar == $n ifTrue: [ - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllCallsOn: to: Smalltalk]. - - "The following require a class selection" - (class _ model selectedClassOrMetaClass) ifNil: [^ self ]. - aChar == $b ifTrue: [^ BrowserWindow fullOnClass: class selector: sel]. - aChar == $N ifTrue: [^ self browseClassRefs]. - aChar == $i ifTrue: [^ self methodHierarchy]. - aChar == $h ifTrue: [^ self browseHierarchy]. - aChar == $p ifTrue: [^ self browseFullProtocol]. - - sel - ifNotNil: [ - "The following require a method selection" - aChar == $o ifTrue: [^ model fileOutMessage]. - aChar == $c ifTrue: [^ model copySelector]. - aChar == $v ifTrue: [^ self browseVersions]. - aChar == $C ifTrue: [^ model showHomeCategory]. - aChar == $O ifTrue: [^ self openSingleMessageBrowser]. - aChar == $x ifTrue: [^ model removeMessage]. - aChar == $t ifTrue: [^ model runMethodTest]. - aChar == $r ifTrue: [^ model debugMethodTest]] - ifNil: [ - aChar == $R ifTrue: [^ model renameClass]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4748-NoRefactoringsInChangeSorter-JuanVuletich-2021Aug10-11h00m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4748] on 10 August 2021 at 1:47:40 pm'! -!TaskbarMorph methodsFor: 'notifications' stamp: 'jmv 8/10/2021 13:47:11' prior: 50591122 overrides: 50552944! - fontPreferenceChanged - clock font: nil. - self scale: self scale.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4749-TaskbarHeightAdjust-JuanVuletich-2021Aug10-12h35m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4749] on 13 August 2021 at 11:45:30 am'! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 8/13/2021 11:09:34'! - isOrAnyOwnerIsRotated - "True if we or any owner is rotated." - - ^ false! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 8/13/2021 11:26:48'! - knowsOwnLocalBounds - "Meaning that it doesn't need running #drawOn: and #postDrawOn: to explore affected pixels to deduce actual morph bounds. See senders." - - ^false! ! -!MovableMorph methodsFor: 'geometry testing' stamp: 'jmv 8/13/2021 11:17:24' overrides: 50594634! - isOrAnyOwnerIsRotated - "True if we or any owner is rotated. - A zoomed widget will answer false, but a rotated one will answer true (even if only - some owner is rotated). - Note: unrotated SystemWindow answer true, but they implements - #addPossiblyUncoveredAreasIn:to: to take care of rounded corners." - - ^ location doesNotRotate not or: [ owner notNil and: [ owner isOrAnyOwnerIsRotated ]].! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 8/13/2021 11:44:24' overrides: 50593336! - displayBoundsUpdateFrom: aCanvas - "Private for framework use. NOP here. See super implementation. - See also #knowsOwnLocalBounds and #wantsContour."! ! -!KernelMorph methodsFor: 'geometry testing' stamp: 'jmv 8/13/2021 11:26:52' overrides: 50594639! - knowsOwnLocalBounds - "Meaning that it doesn't need running #drawOn: and #postDrawOn: to explore affected pixels to deduce actual morph bounds. See senders." - - ^true! ! -!WidgetMorph methodsFor: 'geometry testing' stamp: 'jmv 8/13/2021 11:26:58' overrides: 50594639! - knowsOwnLocalBounds - "Meaning that it doesn't need running #drawOn: and #postDrawOn: to explore affected pixels to deduce actual morph bounds. See senders." - - ^true! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 8/13/2021 11:14:36' prior: 50539190! - addPossiblyUncoveredAreasIn: aRectangle to: aCollection - "Answer an array of rectangles encompassing those areas in aRectangle not completely - covered by self. - All areas that might possibly be uncovered must be included." - - aCollection add: aRectangle.! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/13/2021 11:41:56' prior: 50593298! - displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - aRectangle is clipped appropiately if some owner clips us. - See also #displayBoundsUpdateFrom:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - self knowsOwnLocalBounds - ifTrue: [ - "A good optimization in many cases. - But for morphs where #drawOn: might not be able to find bounds (InnerTextMorph and LayoutMorph, - for example) this is essential." - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphFromLocalBounds] - ifFalse: [ - "Use the bounds bound by #drawOn. This method must therefore be called after calling #drawOn:." - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphAfterDraw. - self wantsContour - ifTrue: [ - (aCanvas - contourOfCurrentMorphAfterDrawInto: (self valueOfProperty: #contour) - into: [ :contourArray :contourY0 :contourY1 | - self setProperty: #contour toValue: contourArray. - self setProperty: #contourY0 toValue: contourY0. - self setProperty: #contourY1 toValue: contourY1. - ])] - ifFalse: [ - self setProperty: #contour toValue: nil. - self setProperty: #contourY0 toValue: nil. - self setProperty: #contourY1 toValue: nil ]]]]].! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 8/13/2021 10:35:01' prior: 50532141! - requiresVectorCanvas - "True if we use VectorCanvas protocol, or we are rotated or zoomed. - If False, we can be drawn by BitBltCanvas." - - ^true! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 8/13/2021 10:37:25' prior: 50532157! - submorphsMightProtrude - "Answered false by morphs that can guarantee that submorphs, and all morphs in their - submorphs tree, will lie inside their bounds, either 'naturally' (by construction) or by - being clipped by their owner. See #clipsSubmorphs and clipsSubmorphsReally. - Allows for many optimizations to be done." - - ^ true! ! -!KernelMorph methodsFor: 'geometry services' stamp: 'jmv 8/13/2021 10:59:28' prior: 50537263! - morphContainsPoint: aLocalPoint - "Answer true even if aLocalPoint is in a submorph in front of us, as long as it is inside our shape." - - "If not visible, won't contain any point at all." - self visible ifFalse: [ ^false ]. - - "We know our local bounds, and completely fill them." - ^ self morphLocalBounds containsPoint: aLocalPoint! ! -!KernelMorph methodsFor: 'geometry testing' stamp: 'jmv 8/13/2021 10:31:43' prior: 50548091 overrides: 50594749! - requiresVectorCanvas - "Kernel morphs can run with any kind of Canvas" - - ^false! ! -!KernelMorph methodsFor: 'geometry testing' stamp: 'jmv 8/13/2021 10:37:43' prior: 50532188 overrides: 50594757! - submorphsMightProtrude - "Answered false by morphs that can guarantee that submorphs, and all morphs in their - submorphs tree, will lie inside their bounds, either 'naturally' (by construction) or by - being clipped by their owner. See #clipsSubmorphs and clipsSubmorphsReally. - Allows for many optimizations to be done." - - ^ false! ! -!KernelMorph methodsFor: 'geometry testing' stamp: 'jmv 8/13/2021 11:43:48' prior: 50593059 overrides: 50575990! - wantsContour - "Kernel morphs don't need contour. - See also #knowsOwnLocalBounds and senders." - - ^false! ! -!HaloMorph methodsFor: 'geometry testing' stamp: 'jmv 8/13/2021 10:34:48' prior: 50570913 overrides: 50594785! - requiresVectorCanvas - "Prefer VectorGraphics halos and handled for morphs drawn with VectorCanvas." - - target ifNotNil: [ - ^target requiresVectorCanvas ]. - ^false! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/13/2021 11:44:27' prior: 50592928 overrides: 50593336! - displayBoundsUpdateFrom: aCanvas - "Private for framework use. NOP here. See super implementation. - See also #knowsOwnLocalBounds and #wantsContour."! ! -!WidgetMorph methodsFor: 'geometry services' stamp: 'jmv 8/13/2021 10:59:33' prior: 50546031! - morphContainsPoint: aLocalPoint - "Answer true even if aLocalPoint is in a submorph in front of us, as long as it is inside our shape." - - "If not visible, won't contain any point at all." - self visible ifFalse: [ ^false ]. - - "We know our local bounds, and completely fill them." - ^ self morphLocalBounds containsPoint: aLocalPoint! ! -!WidgetMorph methodsFor: 'geometry testing' stamp: 'jmv 8/13/2021 10:34:13' prior: 50577292 overrides: 50594749! - requiresVectorCanvas - "Widgets can usually run with any kind of Canvas, but not if zoomed or rotated. - Note: Subclasses that use VectorGraphics for their drawing should answer true." - - ^ location isPureTranslation not or: [ owner notNil and: [ owner requiresVectorCanvas ]].! ! -!WidgetMorph methodsFor: 'geometry testing' stamp: 'jmv 8/13/2021 10:37:56' prior: 50546074 overrides: 50594757! - submorphsMightProtrude - "Answered false by morphs that can guarantee that submorphs, and all morphs in their - submorphs tree, will lie inside their bounds, either 'naturally' (by construction) or by - being clipped by their owner. See #clipsSubmorphs and clipsSubmorphsReally. - Allows for many optimizations to be done." - - ^ false! ! -!WidgetMorph methodsFor: 'geometry testing' stamp: 'jmv 8/13/2021 11:43:56' prior: 50593128 overrides: 50575990! - wantsContour - "Widget morphs don't need contour. - See also #knowsOwnLocalBounds and senders." - - ^false! ! -!WindowEdgeAdjustingMorph methodsFor: 'adjusting' stamp: 'jmv 8/13/2021 11:13:41' prior: 50591470 overrides: 50591463! - adjustOwnerAt: aGlobalPoint millisecondSinceLast: millisecondSinceLast - - self basicAdjustOwnerAt: aGlobalPoint. - - "If UI is becoming slow or is optimized for slow systems, resize without - showing window contents, but only edges. But don't do it for rotated Windows!!" - (owner isOrAnyOwnerIsRotated not and: [ - Preferences cheapWindowReframe or: [millisecondSinceLast > 200]]) ifTrue: [ - owner displayBounds newRectFrom: [ :f | - self basicAdjustOwnerAt: Sensor mousePoint. - owner morphPosition extent: owner morphExtent ]].! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 8/13/2021 11:13:25' prior: 50591517 overrides: 50594689! -addPossiblyUncoveredAreasIn: aRectangle to: aCollection - "Answer an array of rectangles encompassing those areas in aRectangle not completely - covered by self. These are the areas that might require further drawing (of morphs below us) - All areas that might possibly be uncovered must be included." - - | bounds radius | - self isOrAnyOwnerIsRotated ifTrue: [ - aCollection add: aRectangle. - ^self ]. - - color mightBeTranslucent ifTrue: [ - aCollection add: aRectangle. - ^self ]. - - bounds _ self displayBounds. - bounds ifNil: [ - aCollection add: aRectangle. - ^self ]. - - "Solid rectangle. - This will be the fastest in many cases. So, please disable rounded corners if on slow hardware!!" - Theme current roundWindowCorners ifFalse: [ - aRectangle areasOutside: bounds do: [ :rect | aCollection add: rect ]. - ^self ]. - - "The solid rectangle does not include the corners. - Report a couple of rows (top and bottom) or columns (left and right) as uncovered areas. - We could also try to be more careful and answer each rounded corner... - Right now, report left and right columns as uncovered areas" - radius _ Theme current roundedWindowRadius. - aRectangle areasOutside: (bounds insetBy: radius@0) do: [ :rect | aCollection add: rect ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/13/2021 11:27:25' prior: 50593162! - fullUpdateCurrentProtrudingBounds - "Recursively update display bounds, for currentMorph and all submorphs, - but only for those whose bounds may go outside owner bounds." - - | isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph knowsOwnLocalBounds - ifTrue: [currentMorph displayBoundsSetFrom: self] - ifFalse: [ - "In these cases, #drawOn: is required to find bounds. - #displayBoundsSetFrom: will use the bounds found by us in these case. - See #displayBoundsSetFrom:" - currentMorph - drawOn: self; - displayBoundsSetFrom: self. - (currentMorph postDrawOn: self) ifTrue: [ - currentMorph displayBoundsUpdateFrom: self ]]. - (currentMorph submorphsMightProtrude and: [currentMorph clipsSubmorphsReally not]) ifTrue: [ - currentMorph submorphsDo: [ :m | - self fullUpdateProtrudingBounds: m ]]].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/13/2021 11:27:37' prior: 50593194! - updateCurrentBounds - "Update display bounds, for currentMorph only." - - | isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph knowsOwnLocalBounds - ifTrue: [currentMorph displayBoundsSetFrom: self] - ifFalse: [ - "In these cases, #drawOn: is required to find bounds. - #displayBoundsSetFrom: will use the bounds found by us in these case. - See #displayBoundsSetFrom:" - currentMorph - drawOn: self; - displayBoundsSetFrom: self. - (currentMorph postDrawOn: self) ifTrue: [ - currentMorph displayBoundsUpdateFrom: self ]]].! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 8/13/2021 11:01:03' prior: 50593218! - morph: aMorph isAtPoint: aPoint - - aMorph basicDisplayBounds ifNotNil: [ :r | - (r containsPoint: aPoint) ifFalse: [ - ^false ]]. - "Give morphs with a non-rectangular shape (corner WindowEdgeAdjustingMorphs) - a chance to have a say." - ^ aMorph morphContainsPoint: - (aMorph internalizeFromWorld: aPoint)! ! - -PluggableButtonMorph removeSelector: #isOrthoRectangularMorph! - -!methodRemoval: PluggableButtonMorph #isOrthoRectangularMorph stamp: 'Install-4750-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h32m-jmv.001.cs.st 8/20/2021 16:04:12'! -isOrthoRectangularMorph - "Answer true if I fill my bounds. I.e. I am a rectangle aligned with Display borders and - specified by my #morphExtent. - If true, #morphContainsPoint: can simply check #morphExtent." - ^self isRoundButton not! - -WindowEdgeAdjustingMorph removeSelector: #isOrthoRectangularMorph! - -!methodRemoval: WindowEdgeAdjustingMorph #isOrthoRectangularMorph stamp: 'Install-4750-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h32m-jmv.001.cs.st 8/20/2021 16:04:12'! -isOrthoRectangularMorph - ^false! - -WidgetMorph removeSelector: #displayBoundsSetFrom:! - -!methodRemoval: WidgetMorph #displayBoundsSetFrom: stamp: 'Install-4750-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h32m-jmv.001.cs.st 8/20/2021 16:04:12'! -displayBoundsSetFrom: aCanvas - "Private for framework use. See super implementation." - - "Widgets don't need contour. Additionally, for InnerTextMorph and LayoutMorph, the bounds - can not be deduced from #drawOn: and should be computed from the 'extent' instance variable." - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - c canvasToUse == aCanvas ifTrue: [ - "In these cases, #drawOn: might not be able to find bounds (InnerTextMorph and LayoutMorph, for example), - but it is OK to compute them from #morphLocalBounds. This is not true for non-orthoRectangular morphs!!" - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphFromLocalBounds ]]].! - -WidgetMorph removeSelector: #isOrthoRectangularMorph! - -!methodRemoval: WidgetMorph #isOrthoRectangularMorph stamp: 'Install-4750-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h32m-jmv.001.cs.st 8/20/2021 16:04:12'! -isOrthoRectangularMorph - "True if we are of rectangular shape, aligned with local coordinate axes. - Doesn't take into account possible rotation of our or some owner's local coordinates. - Note: SystemWindow answers true, but implements #addPossiblyUncoveredAreasIn:to: to take care of rounded corners." - - ^location doesNotRotate and: [ owner isNil or: [ owner isOrthoRectangularMorph ]].! - -HaloMorph removeSelector: #isOrthoRectangularMorph! - -!methodRemoval: HaloMorph #isOrthoRectangularMorph stamp: 'Install-4750-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h32m-jmv.001.cs.st 8/20/2021 16:04:12'! -isOrthoRectangularMorph - ^false! - -HaloMorph removeSelector: #morphContainsPoint:! - -!methodRemoval: HaloMorph #morphContainsPoint: stamp: 'Install-4750-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h32m-jmv.001.cs.st 8/20/2021 16:04:12'! -morphContainsPoint: aLocalPoint - - "If not visible, won't contain any point at all." - self visible ifFalse: [ ^false ]. - - "We behave as if we were a rectangle. I.e., we want (specifically mouse button) events that happen inside our bounds" - ^ self morphLocalBounds containsPoint: aLocalPoint! - -KernelMorph removeSelector: #isOrthoRectangularMorph! - -!methodRemoval: KernelMorph #isOrthoRectangularMorph stamp: 'Install-4750-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h32m-jmv.001.cs.st 8/20/2021 16:04:12'! -isOrthoRectangularMorph - "True if we are of rectangular shape, aligned with local coordinate axes. - Doesn't take into account possible rotation of our or some owner's local coordinates. - Note: SystemWindow answers true, but implements #addPossiblyUncoveredAreasIn:to: to take care of rounded corners." - - ^true! - -Morph removeSelector: #isOrthoRectangularMorph! - -!methodRemoval: Morph #isOrthoRectangularMorph stamp: 'Install-4750-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h32m-jmv.001.cs.st 8/20/2021 16:04:12'! -isOrthoRectangularMorph - "True if we are of rectangular shape, aligned with local coordinate axes. - Doesn't take into account possible rotation of our or some owner's local coordinates. - Note: SystemWindow answers true, but implements #addPossiblyUncoveredAreasIn:to: to take care of rounded corners." - - ^false! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4750-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h32m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4749] on 11 August 2021 at 8:02:30 pm'! -!MorphicCanvas methodsFor: 'initialization' stamp: 'jmv 8/11/2021 19:55:39'! - initializeWithOrigin: aPoint - - "Set up these only on initialization. - This is safe (wrt walkbacks during world redraw) because a new instance is created - on draw error. See #displayWorldSafely" - currentTransformation _ MorphicTranslation withTranslation: aPoint. - cti _ 1. - transformations - ifNil: [ transformations _ OrderedCollection with: currentTransformation ] - ifNotNil: [ transformations at: cti put: currentTransformation ]. - drawingMorphStack - ifNil: [ drawingMorphStack _ OrderedCollection with: nil ] - ifNotNil: [ drawingMorphStack at: cti put: nil ].! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/11/2021 19:56:00' prior: 50571722! -on: aForm over: aRectangle - "Warning: aForm extent must equal aRectangle extent" - - ^ self subclassToUse basicNew - setForm: aForm preferSubPixelAntiAliasing: false; - initializeWithOrigin: aRectangle topLeft negated.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/11/2021 19:56:06' prior: 50571732! - onForm: aForm - - ^ self subclassToUse basicNew - setForm: aForm preferSubPixelAntiAliasing: false; - initializeWithOrigin: `0@0`.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/11/2021 19:56:12' prior: 50571701! - onFormWithSubPixelAntiAliasing: aForm - - ^ self subclassToUse basicNew - setForm: aForm preferSubPixelAntiAliasing: true; - initializeWithOrigin: `0@0`.! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 8/11/2021 19:58:00' prior: 50571709 overrides: 50571696! - setForm: aForm preferSubPixelAntiAliasing: aBoolean - form _ aForm. - engine _ BitBltCanvasEngine toForm: form. - "Init BitBlt so that the first call to the 'primitiveDisplayString' primitive will not fail" - engine sourceX: 0; width: 0. - self newClipRect: nil.! ! - -MorphicCanvas removeSelector: #initialize! - -MorphicCanvas removeSelector: #setForm:preferSubPixelAntiAliasing:! - -!methodRemoval: MorphicCanvas #setForm:preferSubPixelAntiAliasing: stamp: 'Install-4751-Morphic-refactorAndCleanup-JuanVuletich-2021Aug11-19h29m-jmv.002.cs.st 8/20/2021 16:04:12'! -setForm: aForm preferSubPixelAntiAliasing: aBoolean - form _ aForm.! - -MorphicCanvas removeSelector: #initializeWith:origin:preferSubPixelAntiAliasing:! - -!methodRemoval: MorphicCanvas #initializeWith:origin:preferSubPixelAntiAliasing: stamp: 'Install-4751-Morphic-refactorAndCleanup-JuanVuletich-2021Aug11-19h29m-jmv.002.cs.st 8/20/2021 16:04:12'! -initializeWith: aForm origin: aPoint preferSubPixelAntiAliasing: aBoolean - self initialize. - self setForm: aForm preferSubPixelAntiAliasing: aBoolean. - - "Set up these only on initialization. - This is safe (wrt walkbacks during world redraw) because a new instance is created - on draw error. See #displayWorldSafely" - currentTransformation _ MorphicTranslation withTranslation: aPoint. - cti _ 1. - transformations - ifNil: [ transformations _ OrderedCollection with: currentTransformation ] - ifNotNil: [ transformations at: cti put: currentTransformation ]. - drawingMorphStack - ifNil: [ drawingMorphStack _ OrderedCollection with: nil ] - ifNotNil: [ drawingMorphStack at: cti put: nil ].! - -MorphicCanvas removeSelector: #initializeWith:origin:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4751-Morphic-refactorAndCleanup-JuanVuletich-2021Aug11-19h29m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4750] on 12 August 2021 at 10:36:24 am'! -!MorphicCanvas methodsFor: 'accessing' stamp: 'jmv 8/12/2021 10:35:37'! - boundsFinderCanvas - ^self! ! -!MorphicCanvas class methodsFor: 'services' stamp: 'jmv 8/12/2021 09:46:30' prior: 50579315! - isVectorGraphicsUsedForAllRendering - " - MorphicCanvas isVectorGraphicsUsedForAllRendering - " - ^MorphicCanvas activeSubclass name == #VectorDrawingCanvas! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4752-Morphic-refactorAndCleanup-JuanVuletich-2021Aug12-10h08m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4752] on 13 August 2021 at 12:13:06 pm'! - -MorphicCanvas subclass: #BitBltBoundsFinderCanvas - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #BitBltBoundsFinderCanvas category: #'Morphic-Support' stamp: 'Install-4753-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h49m-jmv.001.cs.st 8/20/2021 16:04:12'! -MorphicCanvas subclass: #BitBltBoundsFinderCanvas - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -MorphicCanvas subclass: #BitBltCanvas - instanceVariableNames: 'boundsFinderCanvas ' - classVariableNames: 'AccessProtect AuxBlitter AuxForm CachedForms ' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #BitBltCanvas category: #'Morphic-Support' stamp: 'Install-4753-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h49m-jmv.001.cs.st 8/20/2021 16:04:12'! -MorphicCanvas subclass: #BitBltCanvas - instanceVariableNames: 'boundsFinderCanvas' - classVariableNames: 'AccessProtect AuxBlitter AuxForm CachedForms' - poolDictionaries: '' - category: 'Morphic-Support'! -!KernelMorph methodsFor: 'testing' stamp: 'jmv 8/12/2021 15:43:53' overrides: 16876981! - is: aSymbol - ^ aSymbol == #KernelMorph or: [ super is: aSymbol ]! ! -!MorphicCanvas methodsFor: 'testing' stamp: 'jmv 8/12/2021 14:47:25'! - isBoundsFinderCanvas - ^false! ! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 8/12/2021 15:46:21' overrides: 50536534! - boundingRectOfCurrentMorphAfterDraw - "In targetForm coordinates. - Clipped to owner if appropriate. - BitBltCanvas doesn't keep track of Morph bounds as it draws them. But it is limited to drawing morphs where - #morphLocalBounds is known. Use it, then." - - | boundingRect | - boundingRect _ currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds. - ^ clippingMorphDisplayBounds - ifNotNil: [ :ownerClips | boundingRect intersect: ownerClips ] - ifNil: [ boundingRect ]! ! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 8/12/2021 15:47:52' overrides: 50591033! - displayBoundsForHand: aHand - - ^ aHand morphPosition-8 extent: aHand morphExtent.! ! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 8/12/2021 15:03:41' overrides: 50592131! - fullAddCurrentRect: addCurrentBounds submorphs: trySubmorphs to: aDamageRecorder - - | invalidateOwns | - invalidateOwns _ false. - addCurrentBounds ifTrue: [ - currentMorph needsRedraw: false. - self updateCurrentBounds. - invalidateOwns _ true ]. - trySubmorphs ifTrue: [ - (currentMorph submorphsMightProtrude and: [currentMorph clipsSubmorphsReally not]) - ifTrue: [ - currentMorph submorphNeedsRedraw: false. - currentMorph submorphsReverseDo: [ :m | - self fullAddRedrawRect: m to: aDamageRecorder ]] - ifFalse: [ - currentMorph fullRedrawNotNeeded. - invalidateOwns _ true ]]. - invalidateOwns ifTrue: [ - aDamageRecorder recordInvalidRect: currentMorph displayBounds for: currentMorph ]! ! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 8/12/2021 15:07:13' overrides: 50537785! - fullAddRedrawRect: aMorph to: aDamageRecorder - | addCurrentBounds trySubmorphs | - aMorph visible ifTrue: [ - addCurrentBounds _ aMorph isRedrawNeeded. - trySubmorphs _ aMorph isSubmorphRedrawNeeded. - (trySubmorphs or: [addCurrentBounds]) ifTrue: [ - self into: aMorph. - self - fullAddCurrentRect: addCurrentBounds - submorphs: trySubmorphs - to: aDamageRecorder. - self outOfMorph - ]]! ! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 8/12/2021 14:38:59' overrides: 50594941! - fullUpdateCurrentProtrudingBounds - "Recursively update display bounds, for currentMorph and all submorphs, - but only for those whose bounds may go outside owner bounds." - - currentMorph displayBoundsSetFrom: self.! ! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 8/12/2021 15:10:54' overrides: 50591345! - fullUpdateProtrudingBounds: aMorph - "Recursively update display bounds, for aMorph and all submorphs, - but only for those whose bounds may go outside owner bounds." - - aMorph visible ifTrue: [ - self into: aMorph. - self fullUpdateCurrentProtrudingBounds. - self outOfMorph ].! ! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 8/12/2021 15:15:58'! - updateBoundsIn: aWorldMorph addDamageTo: aDamageRecorder - - aWorldMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - self updateHandsDisplayBounds: aWorldMorph.! ! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 8/12/2021 15:16:04' overrides: 50591402! - updateHandsDisplayBounds: aWorldMorph - "Update displayBounds for carried morphs if never set. - Useful for new morph, that are created and attached to the hand." - - aWorldMorph handsDo: [ :hand | - hand hasSubmorphs ifTrue: [ - self into: hand. - hand submorphsDo: [ :morph | - morph displayBounds ifNil: [ - self fullUpdateProtrudingBounds: morph ]]. - self outOfMorph ]].! ! -!BitBltBoundsFinderCanvas methodsFor: 'testing' stamp: 'jmv 8/12/2021 14:47:42' overrides: 50595314! - isBoundsFinderCanvas - ^true! ! -!BitBltCanvas methodsFor: 'accessing' stamp: 'jmv 8/12/2021 14:25:05' overrides: 50595256! - boundsFinderCanvas - ^boundsFinderCanvas! ! -!BitBltCanvas methodsFor: 'initialization' stamp: 'jmv 8/12/2021 14:26:28' overrides: 50595145! - initializeWithOrigin: aPoint - - super initializeWithOrigin: aPoint. - boundsFinderCanvas _ BitBltBoundsFinderCanvas new initializeWithOrigin: aPoint.! ! -!BitBltCanvas methodsFor: 'initialization' stamp: 'jmv 8/12/2021 15:26:38' overrides: 50552964! - world: aWorldMorph - super world: aWorldMorph. - boundsFinderCanvas world: aWorldMorph! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/13/2021 11:58:42' prior: 50594700! - displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - aRectangle is clipped appropiately if some owner clips us. - See also #displayBoundsUpdateFrom:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - (aCanvas isBoundsFinderCanvas or: [c canvasToUse == aCanvas]) ifTrue: [ - self knowsOwnLocalBounds - ifTrue: [ - "A good optimization in many cases. - But for morphs where #drawOn: might not be able to find bounds (InnerTextMorph and LayoutMorph, - for example) this is essential." - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphFromLocalBounds] - ifFalse: [ - "Use the bounds bound by #drawOn. This method must therefore be called after calling #drawOn:." - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphAfterDraw. - self wantsContour - ifTrue: [ - (aCanvas - contourOfCurrentMorphAfterDrawInto: (self valueOfProperty: #contour) - into: [ :contourArray :contourY0 :contourY1 | - self setProperty: #contour toValue: contourArray. - self setProperty: #contourY0 toValue: contourY0. - self setProperty: #contourY1 toValue: contourY1. - ])] - ifFalse: [ - self setProperty: #contour toValue: nil. - self setProperty: #contourY0 toValue: nil. - self setProperty: #contourY1 toValue: nil ]]]]].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/12/2021 14:48:41' prior: 50593336! - displayBoundsUpdateFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us. - To be called after #postDrawOn:. See also #displayBoundsSetFrom: - This more complicated update is needed because the contour information from #drawOn: was possibly - when drawing submorphs. So, the controur from #drawOn: needs to be retrieved, and updated with the - new contour information from #postDrawOn:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - (aCanvas isBoundsFinderCanvas or: [c canvasToUse == aCanvas]) ifTrue: [ - | oldContour oldTop oldBottom | - oldContour _ self valueOfProperty: #contour. - oldTop _ self valueOfProperty: #contourY0. - oldBottom _ self valueOfProperty: #contourY1. - privateDisplayBounds _ privateDisplayBounds - quickMerge: aCanvas boundingRectOfCurrentMorphAfterDraw. - self wantsContour ifTrue: [ - (aCanvas - contourOfCurrentMorphAfterDrawUpdate: oldContour - oldTop: oldTop - oldBottom: oldBottom - into: [ :contourArray :contourY0 :contourY1 | - self setProperty: #contour toValue: contourArray. - self setProperty: #contourY0 toValue: contourY0. - self setProperty: #contourY1 toValue: contourY1. - ])]]]].! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 8/12/2021 15:48:36' prior: 50592894 overrides: 50592880! - basicDisplayBounds - - ^ self world canvas boundsFinderCanvas displayBoundsForHand: self! ! -!MorphicCanvas methodsFor: 'accessing' stamp: 'jmv 8/12/2021 15:01:55' prior: 50595256! - boundsFinderCanvas - ^self subclassResponsibility! ! -!MorphicCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 8/12/2021 16:33:24' prior: 50555896! - frameRectangle: aRectangle color: aColor borderWidth: borderWidth borderStyleSymbol: aSymbol - " - (BitBltCanvas onForm: Display) - frameRectangle: (10@10 extent: 300@200) - color: Color green - borderWidth: 10 - borderStyleSymbol: #raised. - Display forceToScreen. - " - - | tlColor brColor | - tlColor _ aColor. - brColor _ aColor. - aSymbol == #raised ifTrue: [ - tlColor _ aColor quiteWhiter. - brColor _ aColor quiteBlacker ]. - - aSymbol == #inset ifTrue: [ - tlColor _ aColor quiteBlacker. - brColor _ aColor quiteWhiter ]. - - self frameRectangle: aRectangle topLeftColor: tlColor bottomRightColor: brColor borderWidth: borderWidth! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/12/2021 15:12:09' prior: 50570675! - drawWorld: aWorldMorph repair: aDamageRecorder - "Redraw the damaged areas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | visibleRootMorphs visibleRootsDamage worldDamage | - "Update #displayBounds for all dirty morphs (marked as such with #redrawNeeded). - Also add the updated bounds to aDamageRecorder, and update bounds of morphs carried by hand." - self boundsFinderCanvas updateBoundsIn: aWorldMorph addDamageTo: aDamageRecorder. - - visibleRootMorphs _ aWorldMorph privateSubmorphs select: [ :m | m visible ]. - visibleRootsDamage _ Array new: visibleRootMorphs size. - - worldDamage _ self computeDamage: aWorldMorph repair: aDamageRecorder - rootMorphs: visibleRootMorphs rootMorphsDamage: visibleRootsDamage. - - self drawWorldBackground: aWorldMorph rects: worldDamage. - - self drawWorld: aWorldMorph - rootMorphs: visibleRootMorphs rootMorphsDamage: visibleRootsDamage - allDamage: worldDamage. - - aDamageRecorder reset. - ^ worldDamage! ! -!BitBltCanvas methodsFor: 'drawing' stamp: 'jmv 8/12/2021 16:30:30' prior: 50545158 overrides: 50463404! - line: pt1 to: pt2 width: wp color: c - - | p1 p2 w | - (wp > 0 and: [ c isTransparent not ]) ifTrue: [ - p1 _ (currentTransformation transform: pt1) rounded. - p2 _ (currentTransformation transform: pt2) rounded. - w _ (currentTransformation externalizeScalar: wp) rounded. - self setPaintColor: c. - engine - width: w; - height: w; - drawFrom: p1 to: p2 ]! ! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 9/30/2014 19:58' prior: 50532722 overrides: 50463414! - image: aForm at: aPoint - "Draw a translucent image using the best available way of representing translucency." - - self image: aForm - at: aPoint - sourceRect: aForm boundingBox! ! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 8/12/2021 16:30:14' prior: 50536300 overrides: 50463419! - image: aForm at: aPoint sourceRect: sourceRect - "Draw a translucent image using the best available way of representing translucency. - Note: This will be fixed in the future." - - | r p | - p _ (currentTransformation transform: aPoint) rounded. - r _ (form depth < 32 or: [ aForm mightBeTranslucent not ]) - ifTrue: [ - "Rule Form paint treats pixels with a value of zero as transparent" - Form paint ] - ifFalse: [ Form blend ]. - engine colorMap: (aForm colormapIfNeededFor: form); fillColor: nil. - engine image: aForm at: p sourceRect: sourceRect rule: r. - (form depth = 32 and: [ aForm depth < 32 ]) ifTrue: [ - "If we blit to 32bpp from one of smaller depth, - it will have zero in the alpha channel (until BitBlt is fixed!!) - This is the same workaround as in #asFormOfDepth:" - engine sourceForm: nil. - engine combinationRule: 40. "fixAlpha:with:" - engine copyBits ]! ! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 1/11/2020 15:19:17' prior: 50532779! - stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor - "Flood this canvas with aColor wherever stencilForm has non-zero pixels" - | p | - p _ (currentTransformation transform: aPoint) rounded. - self setPaintColor: aColor. - engine colorMap: stencilForm maskingMap. - engine stencil: stencilForm - at: p - sourceRect: sourceRect! ! -!BitBltCanvas methodsFor: 'drawing-ovals' stamp: 'jmv 8/12/2021 16:25:55' prior: 50569782 overrides: 50569774! - ellipseCenter: center radius: radiusPointOrNumber borderWidth: mbw borderColor: mbc fillColor: morphFillColor - - | displayRectangle doBorder doFill | - doBorder _ mbw > 0 and: [ mbc isTransparent not]. - doFill _ morphFillColor isTransparent not. - doBorder | doFill ifTrue: [ - displayRectangle _ (currentTransformation externalizeRectangle: (Rectangle center: center extent: radiusPointOrNumber asPoint * 2)) rounded. - "draw the border of the oval" - doBorder ifTrue: [ - self setPaintColor: mbc. - engine frameOval: displayRectangle borderWidth: mbw rounded]. - "fill the inside" - doFill ifTrue: [ - self setPaintColor: morphFillColor. - engine fillOval: (displayRectangle insetBy: mbw rounded) ]]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 3/10/2018 22:06:13' prior: 50532820 overrides: 50463447! - fillRectangle: aRectangle color: aColor - "Fill the given rectangle." - - aColor isTransparent ifFalse: [ - self - frameAndFillRectangle: aRectangle - fillColor: aColor - borderWidth: 0 - borderColor: `Color transparent` ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 8/12/2021 16:28:24' prior: 50592254 overrides: 50463460! - fillRectangle: aRectangle tilingWith: aForm multipliedBy: aColor - "Fill aRectangle with the equivalent of aForm multiplied by aColor - aForm is a kind of advanced stencil, supplying brightness and opacity at each pixel - Similar to #image:multipliedBy:at: - - - (BitBltCanvas onForm: Display) fillRectangle: (10@10 extent: 100@100) tilingWith: (BitBltCanvas verticalGrayGradient: 30 gradientTop: 0.8 gradientBottom: 0.5) multipliedBy: Color red. Display forceToScreen. - " - self class accessProtect critical: [ - self buildAuxWith: aForm multipliedWith: aColor. - "Warning: aForm boundingBox is most likely different from AuxForm boundingBox!!" - self fillRectangle: aRectangle tilingWith: AuxForm sourceRect: aForm boundingBox rule: Form paint ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 8/12/2021 16:29:04' prior: 50545200 overrides: 50463466! - frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor - - | rect bw | - r area = 0 ifTrue: [ ^self ]. - rect _ (currentTransformation externalizeRectangle: r) rounded. - bw _ (currentTransformation externalizeScalar: borderWidth) rounded. - - "draw the border of the rectangle" - borderColor isTransparent ifFalse: [ - self setPaintColor: borderColor. - engine frameRect: rect borderWidth: bw ]. - - "fill the inside" - fillColor isTransparent ifFalse: [ - self setPaintColor: fillColor. - engine fillRect: (rect insetBy: bw) ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 8/12/2021 16:29:27' prior: 50592282 overrides: 50463473! - frameRectangle: r borderWidth: borderWidth color: borderColor - " - (BitBltCanvas onForm: Display) - frameRectangle: (10@10 extent: 300@200) - borderWidth: 20 - color: Color red. - Display forceToScreen - " - | rect bw | - (borderWidth > 0 and: [ borderColor isTransparent not ]) ifTrue: [ - rect _ (currentTransformation externalizeRectangle: r) rounded. - bw _ (currentTransformation externalizeScalar: borderWidth) rounded. - self setPaintColor: borderColor. - engine - frameRect: rect - borderWidth: bw ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 8/12/2021 16:29:33' prior: 50555854! - frameRectangle: aRectangle topLeftColor: tlColor bottomRightColor: brColor borderWidth: borderWidth - " - (BitBltCanvas onForm: Display) - frameRectangle: (10@10 extent: 300@200) - color: Color green - borderWidth: 10 - borderStyleSymbol: #raised. - Display forceToScreen. - " - - | displayRectangle bw | - bw _ (currentTransformation externalizeScalar: borderWidth) rounded. - displayRectangle _ (currentTransformation externalizeRectangle: aRectangle) rounded. - self - frameRectangle: displayRectangle - borderWidth: bw - topLeftColor: tlColor - bottomRightColor: brColor.! ! -!BitBltCanvas methodsFor: 'drawing-roundedRectangles' stamp: 'jmv 8/12/2021 16:30:58' prior: 50592303 overrides: 50463492! - roundRect: aRectangle color: aColor radius: r - " - (BitBltCanvas onForm: Display) roundRect: (10@10 extent: 200@100) color: Color red radius: 10.5. Display forceToScreen. - " - "radius is not scaled properly..." - - "top stripe" - self - image: (self class topLeftCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle topLeft. - self - image: (self class topRightCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle topRight - (r@0). - self fillRectangle: ((aRectangle withHeight: r) insetBy: r@0) color: aColor. - - "center stripe" - self fillRectangle: (aRectangle insetBy: (0 @ r corner: 0 @ r)) color: aColor. - - "bottom stripe" - self - image: (self class bottomLeftCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle bottomLeft - (0@r). - self - image: (self class bottomRightCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle bottomRight - (r@r) . - self fillRectangle: ((aRectangle bottomLeft + (r@r negated)) extent: (aRectangle width - r - r@r)) color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 8/12/2021 16:25:23' prior: 50566740 overrides: 50566026! - drawString: aString from: firstIndex to: lastIndex atBaseline: aPoint font: font color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - - | p1 | - "Don't waste any time if NOP" - lastIndex = 0 ifTrue: [ - ^nil ]. - - p1 _ currentTransformation transform: aPoint rounded. - p1 _ p1 + (0@(0 - (font ascent + font lineGap-1))). - p1 _ p1 rounded. - engine colorMap: nil. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 8/12/2021 16:25:31' prior: 50566761 overrides: 50566713! - drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint font: font color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - | p1 | - p1 _ (currentTransformation transform: aPoint rounded) rounded. - engine colorMap: nil. - - aColor = `Color black` ifFalse: [ | topColor | - topColor _ aColor alphaMixed: 0.25 with: `Color black`. - font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: topColor ]. - aColor = `Color white` ifFalse: [ | bottomColor | - bottomColor _ aColor alphaMixed: 0.22 with: `Color white`. - font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + `0@2` - color: bottomColor ]. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + `0@1` - color: aColor.! ! -!BitBltCanvas methodsFor: 'drawing-windows' stamp: 'jmv 8/12/2021 16:32:25' prior: 50592342! - windowFrame: aRectangle color: aColor radius: r border: bw labelHeight: lh gradientTop: topFactor gradientBottom: bottomFactor insideColor: insideColor - " - BitBltCanvas releaseClassCachedState; releaseClassState. - (BitBltCanvas onForm: Display) windowFrame: (10@10 extent: 200@100) color: Color red radius: 10 border: 5 labelHeight: 25 gradientTop: 1.0 gradientBottom: 0.5 insideColor: Color green. - Display forceToScreen - " - - | bottomColor he tl tr | - "top stripe" - self - image: (self class topLeftCorner: r height: lh gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: aRectangle topLeft. - self - image: (self class topRightCorner: r height: lh gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor - at: aRectangle topRight - (r@0). - self - fillRectangle: ((aRectangle withHeight: lh) insetBy: r@0) - tilingWith: (self class verticalGrayGradient: lh gradientTop: topFactor gradientBottom: bottomFactor) - multipliedBy: aColor. - - bottomColor _ aColor * bottomFactor. - - "left and right borders" - tl _ aRectangle topLeft + (0@lh). - tr _ aRectangle topRight + (bw negated@lh). - he _ bw@(aRectangle height - lh - r). - self fillRectangle: (tl extent: he) color: bottomColor. - self fillRectangle: (tr extent: he) color: bottomColor. - - "bottom stripe" - self - image: (self class bottomLeftCorner: r height: r gradientTop: 1 gradientBottom: 1 borderWidth: bw) - multipliedBy: bottomColor - at: aRectangle bottomLeft - (0@r). - self - image: (self class bottomRightCorner: r height: r gradientTop: 1 gradientBottom: 1 borderWidth: bw) - multipliedBy: bottomColor - at: aRectangle bottomRight - (r@r) . - self fillRectangle: ((aRectangle bottomLeft + (r@bw negated)) extent: (aRectangle width - r - r@bw)) color: bottomColor. - - "inside" - self fillRectangle: (aRectangle insetBy: (bw@lh corner: bw@bw)) color: insideColor! ! -!BitBltCanvas methodsFor: 'drawing - Global Coordinates' stamp: 'jmv 8/12/2021 16:28:47' prior: 50570968 overrides: 50570940! - frameAndFillGlobalRect: rect fillColor: fillColor borderWidth: borderWidth color: borderColor - " - (BitBltCanvas onForm: Display) - frameAndFillGlobalRect: (10@10 extent: 300@200) - fillColor: Color green - borderWidth: 20 - color: Color red. - Display forceToScreen - " - engine - combinationRule: (borderColor isOpaque ifTrue: [Form paint] ifFalse: [Form blend]); - fillColor: borderColor; - frameRect: rect borderWidth: borderWidth; - combinationRule: (fillColor isOpaque ifTrue: [Form paint] ifFalse: [Form blend]); - fillColor: fillColor; - fillRect: (rect insetBy: borderWidth). - ! ! -!BitBltCanvas methodsFor: 'drawing - Global Coordinates' stamp: 'jmv 8/12/2021 16:29:13' prior: 50570991 overrides: 50570947! - frameGlobalRect: rect borderWidth: borderWidth color: borderColor - " - (BitBltCanvas onForm: Display) - frameGlobalRect: (10@10 extent: 300@200) - borderWidth: 20 - color: Color red. - Display forceToScreen - " - - engine - combinationRule: (borderColor isOpaque ifTrue: [Form paint] ifFalse: [Form blend]); - fillColor: borderColor; - frameRect: rect borderWidth: borderWidth.! ! -!BitBltCanvas methodsFor: 'drawing - Global Coordinates' stamp: 'jmv 8/12/2021 16:29:43' prior: 50571225 overrides: 50571218! - frameReverseGlobalRect: rect borderWidth: borderWidth - " - (BitBltCanvas onForm: Display) - frameReverseGlobalRect: (10@10 extent: 300@200) - borderWidth: 20. - Display forceToScreen - " - engine - sourceForm: nil; - fillColor: `Color gray`; - combinationRule: Form reverse; - frameRect: rect borderWidth: borderWidth! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 1/11/2020 15:19:54' prior: 50541846! - fillRectangle: aRectangle tilingWith: aForm sourceRect: patternBox rule: aCombinationRule - - | displayRectangle additionalOffset clippedEngine targetTopLeft clipOffset ex - targetBox savedMap top left | - - ex _ patternBox extent. - ex x = 0 ifTrue: [ ^self ]. - ex y = 0 ifTrue: [ ^self ]. - displayRectangle _ (currentTransformation externalizeRectangle: aRectangle) rounded. - - "this is a bit of a kludge to get the form to be aligned where I *think* it should be. - something better is needed, but not now" - - additionalOffset _ `0@0`. - clippedEngine _ engine clippedBy: displayRectangle. - targetTopLeft _ clippedEngine clipRect topLeft truncateTo: ex. - clipOffset _ displayRectangle topLeft - targetTopLeft. - additionalOffset _ (clipOffset \\ ex) - ex. - - "do it iteratively" - targetBox _ clippedEngine clipRect. - savedMap _ clippedEngine colorMap. - clippedEngine sourceForm: aForm; - fillColor: nil; - combinationRule: aCombinationRule; - sourceRect: patternBox; - colorMap: (aForm colormapIfNeededFor: clippedEngine destForm). - top _ (targetBox top truncateTo: patternBox height) + additionalOffset y. - left _ (targetBox left truncateTo: patternBox width) + additionalOffset x. - - left to: (targetBox right - 1) by: patternBox width do: [:x | - top to: (targetBox bottom - 1) by: patternBox height do: [:y | - clippedEngine destOrigin: x@y; copyBits]]. - clippedEngine colorMap: savedMap! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 1/14/2020 09:32:10' prior: 50533234 overrides: 50501575! - setClipRect: aRectangle - "In targetForm coordinates" - - super setClipRect: aRectangle. - engine clipRect: aRectangle! ! - -BitBltCanvas removeSelector: #textComposition:bounds:color:selectionColor:! - -!methodRemoval: BitBltCanvas #textComposition:bounds:color:selectionColor: stamp: 'Install-4753-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h49m-jmv.001.cs.st 8/20/2021 16:04:12'! -textComposition: aTextComposition bounds: boundsRect color: c selectionColor: sc - - engine ifNil: [ ^nil ]. - ^super textComposition: aTextComposition bounds: boundsRect color: c selectionColor: sc! - -BitBltCanvas removeSelector: #updatingMorphBoundsDo:! - -!methodRemoval: BitBltCanvas #updatingMorphBoundsDo: stamp: 'Install-4753-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h49m-jmv.001.cs.st 8/20/2021 16:04:12'! -updatingMorphBoundsDo: aBlock - - | prevEngine | - prevEngine _ engine. - [ - engine _ nil. - aBlock value. - ] ensure: [ engine _ prevEngine ]! - -BitBltCanvas removeSelector: #displayBoundsForHand:! - -!methodRemoval: BitBltCanvas #displayBoundsForHand: stamp: 'Install-4753-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h49m-jmv.001.cs.st 8/20/2021 16:04:12'! -displayBoundsForHand: aHand - - ^ aHand morphPosition-8 extent: aHand morphExtent.! - -MorphicCanvas removeSelector: #fullAddRedrawRect:to:! - -!methodRemoval: MorphicCanvas #fullAddRedrawRect:to: stamp: 'Install-4753-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h49m-jmv.001.cs.st 8/20/2021 16:04:12'! -fullAddRedrawRect: aMorph to: aDamageRecorder - | addCurrentBounds trySubmorphs | - aMorph visible ifTrue: [ - addCurrentBounds _ aMorph isRedrawNeeded. - trySubmorphs _ aMorph isSubmorphRedrawNeeded. - (trySubmorphs or: [addCurrentBounds]) ifTrue: [ - self into: aMorph. - self canvasToUse - fullAddCurrentRect: addCurrentBounds - submorphs: trySubmorphs - to: aDamageRecorder. - self outOfMorph - ]]! - -MorphicCanvas removeSelector: #fullUpdateCurrentProtrudingBounds! - -!methodRemoval: MorphicCanvas #fullUpdateCurrentProtrudingBounds stamp: 'Install-4753-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h49m-jmv.001.cs.st 8/20/2021 16:04:12'! -fullUpdateCurrentProtrudingBounds - "Recursively update display bounds, for currentMorph and all submorphs, - but only for those whose bounds may go outside owner bounds." - - | isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph knowsOwnLocalBounds - ifTrue: [currentMorph displayBoundsSetFrom: self] - ifFalse: [ - "In these cases, #drawOn: is required to find bounds. - #displayBoundsSetFrom: will use the bounds found by us in these case. - See #displayBoundsSetFrom:" - currentMorph - drawOn: self; - displayBoundsSetFrom: self. - (currentMorph postDrawOn: self) ifTrue: [ - currentMorph displayBoundsUpdateFrom: self ]]. - (currentMorph submorphsMightProtrude and: [currentMorph clipsSubmorphsReally not]) ifTrue: [ - currentMorph submorphsDo: [ :m | - self fullUpdateProtrudingBounds: m ]]].! - -MorphicCanvas removeSelector: #displayBoundsForHand:! - -!methodRemoval: MorphicCanvas #displayBoundsForHand: stamp: 'Install-4753-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h49m-jmv.001.cs.st 8/20/2021 16:04:12'! -displayBoundsForHand: aHand - - self subclassResponsibility.! - -MorphicCanvas removeSelector: #updatingMorphBoundsDo:! - -!methodRemoval: MorphicCanvas #updatingMorphBoundsDo: stamp: 'Install-4753-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h49m-jmv.001.cs.st 8/20/2021 16:04:12'! -updatingMorphBoundsDo: aBlock - - self subclassResponsibility.! - -MorphicCanvas removeSelector: #updateHandsDisplayBounds:! - -!methodRemoval: MorphicCanvas #updateHandsDisplayBounds: stamp: 'Install-4753-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h49m-jmv.001.cs.st 8/20/2021 16:04:12'! -updateHandsDisplayBounds: aWorldMorph - "Update displayBounds for carried morphs if never set. - Useful for new morph, that are created and attached to the hand." - - aWorldMorph handsDo: [ :hand | - hand hasSubmorphs ifTrue: [ - self into: hand. - hand submorphsDo: [ :morph | - morph displayBounds ifNil: [ - self fullUpdateProtrudingBounds: morph ]]. - self outOfMorph ]]! - -MorphicCanvas removeSelector: #fullAddCurrentRect:submorphs:to:! - -!methodRemoval: MorphicCanvas #fullAddCurrentRect:submorphs:to: stamp: 'Install-4753-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h49m-jmv.001.cs.st 8/20/2021 16:04:12'! -fullAddCurrentRect: addCurrentBounds submorphs: trySubmorphs to: aDamageRecorder - - | invalidateOwns | - invalidateOwns _ false. - addCurrentBounds ifTrue: [ - currentMorph needsRedraw: false. - self updateCurrentBounds. - invalidateOwns _ true ]. - trySubmorphs ifTrue: [ - (currentMorph submorphsMightProtrude and: [currentMorph clipsSubmorphsReally not]) - ifTrue: [ - currentMorph submorphNeedsRedraw: false. - currentMorph submorphsReverseDo: [ :m | - self fullAddRedrawRect: m to: aDamageRecorder ]] - ifFalse: [ - currentMorph fullRedrawNotNeeded. - invalidateOwns _ true ]]. - invalidateOwns ifTrue: [ - aDamageRecorder recordInvalidRect: currentMorph displayBounds for: currentMorph ]! - -MorphicCanvas removeSelector: #fullUpdateProtrudingBounds:! - -!methodRemoval: MorphicCanvas #fullUpdateProtrudingBounds: stamp: 'Install-4753-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h49m-jmv.001.cs.st 8/20/2021 16:04:12'! -fullUpdateProtrudingBounds: aMorph - "Recursively update display bounds, for aMorph and all submorphs, - but only for those whose bounds may go outside owner bounds." - - aMorph visible ifTrue: [ - self into: aMorph. - self canvasToUse fullUpdateCurrentProtrudingBounds. - self outOfMorph ].! - -MorphicCanvas subclass: #BitBltCanvas - instanceVariableNames: 'boundsFinderCanvas' - classVariableNames: 'AccessProtect AuxBlitter AuxForm CachedForms' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #BitBltCanvas category: #'Morphic-Support' stamp: 'Install-4753-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h49m-jmv.001.cs.st 8/20/2021 16:04:12'! -MorphicCanvas subclass: #BitBltCanvas - instanceVariableNames: 'boundsFinderCanvas' - classVariableNames: 'AccessProtect AuxBlitter AuxForm CachedForms' - poolDictionaries: '' - category: 'Morphic-Support'! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -BitBltCanvas allInstancesDo: [ :c | c instVarNamed: 'boundsFinderCanvas' put: (BitBltBoundsFinderCanvas new initializeWithOrigin: 0@0) ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4753-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-11h49m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4753] on 13 August 2021 at 4:08:28 pm'! -!HaloMorph methodsFor: 'geometry testing' stamp: 'jmv 8/13/2021 16:07:35' overrides: 50594672! -knowsOwnLocalBounds - "HaloMorph is a bit special because of the drawing of the coordinate systems. - In VectorCanvas, with possible rotation, we must answer false, so #drawOn: is taking into accoung in computing bounds. - In BitBltCanvas, #morphLocalBounds (that leaves extra room for coordinate syste) is enough, especially because there is no rotation. - In this case, #morphLocalBounds will be used. BitBltCanvas cannot do anything else!!" - - ^false! ! -!HaloMorph methodsFor: 'geometry' stamp: 'jmv 8/13/2021 15:51:20' overrides: 50593845! - morphLocalBounds - - "Leave some room for coordinate system labels (in BitBltCanvas)" - ^`-65 @ -30` corner: extent! ! -!HaloMorph methodsFor: 'drawing' stamp: 'jmv 8/13/2021 15:51:43' prior: 50593111 overrides: 16899205! - drawOn: aCanvas - - | b | - target ifNil: [^super drawOn: aCanvas]. - "Debugging aid" - "aCanvas - fillRectangle: haloBox - color: (Color red alpha: 0.2). - aCanvas - fillRectangle: self morphLocalBounds - color: (Color gray alpha: 0.4)." - Preferences halosShowCoordinateSystem ifTrue: [ - target displayFullBounds ifNotNil: [ :fb | - aCanvas frameGlobalRect: fb borderWidth: 3 color: `Color black alpha: 0.3`. - b _ target displayBounds. - b = fb ifFalse: [ - aCanvas frameGlobalRect: b borderWidth: 3 color: `Color black alpha: 0.3` ]. - self drawCoordinateSystemOn: aCanvas ]].! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 8/13/2021 15:56:25' prior: 50593718! - addHandles: aDisplayRectangle - "update my size. owner is world, therefore owner coordinates are Display coordinates." - - self morphPosition: aDisplayRectangle topLeft extent: aDisplayRectangle extent. - haloBox _ self handlesBox. - target addHandlesTo: self box: haloBox. - self addNameString: (target printStringLimitedTo: 40). - self redrawNeeded.! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/13/2021 16:06:55' prior: 50594974! - updateCurrentBounds - "Update display bounds, for currentMorph only." - - | isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph displayBoundsSetFrom: self].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4754-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-15h53m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4754] on 13 August 2021 at 5:35:54 pm'! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 8/13/2021 17:13:59' overrides: 50596355! - updateCurrentBounds - "Update display bounds, for currentMorph only." - - currentMorph displayBoundsSetFrom: self.! ! -!Morph methodsFor: 'updating' stamp: 'jmv 8/13/2021 16:54:28' prior: 50560047! - redrawNeeded - "Report that the area occupied by this morph should be redrawn. - Usually because we changed in some way." - - self needsRedraw: true. - self allOwnersDo: [ :m | m submorphNeedsRedraw: true ]. - self invalidateDisplayRect: (self displayBoundsOrBogus outsetBy: 1) for: self. "Due to anti aliasing in VectorCanvas" - (self submorphsMightProtrude and: [self clipsSubmorphsReally not]) ifTrue: [ - self submorphsReverseDo: [ :m | m redrawNeeded ]].! ! -!HaloMorph methodsFor: 'drawing' stamp: 'jmv 8/13/2021 17:29:23' prior: 50579140! - drawCoordinateSystemOn: aCanvas - - | x0 x1 y0 y1 c stepX stepY haloTargetTx prevTx | - haloTargetTx _ MorphicTranslation identity. - target allOwnersReverseDo: [ :o | haloTargetTx _ haloTargetTx composedWith: o location ]. - haloTargetTx _ haloTargetTx composedWith: target location. - - target knowsOwnLocalBounds - ifTrue: [ | r | - r _ target morphLocalBounds. - x0 _ r left. - x1 _ r right. - y0 _ r top. - y1 _ r bottom ] - ifFalse: [ - x0 _ x1 _ y0 _ y1 _ 0. - target displayFullBounds corners collect: [ :pt | | p | - p _ haloTargetTx inverseTransform: pt. - x0 _ x0 min: p x. - x1 _ x1 max: p x. - y0 _ y0 min: p y. - y1 _ y1 max: p y.]]. - x1-x0 < 1000 ifTrue: [ - stepX _ 50. - stepY _ 20 ] - ifFalse: [ - stepX _ 100. - stepY _ 50 ]. - - prevTx _ aCanvas currentTransformation. - aCanvas geometryTransformation: haloTargetTx. - - c _ `Color black alpha: 0.4`. - aCanvas line: x0@0 to: x1@0 width: 2 color: c. - aCanvas line: 0@y0 to: 0@y1 width: 2 color: c. - - (x0 truncateTo: stepX) to: (x1 - stepX truncateTo: stepX) by: stepX do: [ :x | - aCanvas line: x @ -5 to: x @ 5 width: 2 color: c. - aCanvas drawString: x printString atCenterXBaselineY: x @ -10 font: nil color: c ]. - aCanvas drawString: 'x' atCenterX: x1 - 15 @ 0 font: nil color: c. - - (y0 truncateTo: stepY) to: (y1 - stepY truncateTo: stepY) by: stepY do: [ :y | - aCanvas line: -5 @ y to: 5 @ y width: 2 color: c. - aCanvas drawString: y printString, ' ' atWaistRight: -5 @ y font: nil color: c ]. - aCanvas drawString: 'y' atWaistRight: -5 @ (y1 - 20) font: nil color: c. - - aCanvas geometryTransformation: prevTx.! ! -!HaloMorph methodsFor: 'drawing' stamp: 'jmv 8/13/2021 17:29:49' prior: 50596320 overrides: 16899205! - drawOn: aCanvas - - | b | - target ifNil: [^super drawOn: aCanvas]. - "Debugging aid" - "aCanvas - fillRectangle: haloBox - color: (Color red alpha: 0.2). - aCanvas - fillRectangle: self morphLocalBounds - color: (Color gray alpha: 0.4)." - Preferences halosShowCoordinateSystem ifTrue: [ - target displayFullBounds ifNotNil: [ :fb | - aCanvas frameGlobalRect: fb borderWidth: 3 color: `Color black alpha: 0.1`. - b _ target displayBounds. - b = fb ifFalse: [ - aCanvas frameGlobalRect: b borderWidth: 3 color: `Color black alpha: 0.1` ]. - self drawCoordinateSystemOn: aCanvas ]].! ! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 8/13/2021 16:35:14' prior: 50595319 overrides: 50536534! - boundingRectOfCurrentMorphAfterDraw - "In targetForm coordinates. - Clipped to owner if appropriate. - BitBltCanvas doesn't keep track of Morph bounds as it draws them. But it is limited to drawing morphs where - #morphLocalBounds is known. Use it, then." - - ^self boundingRectOfCurrentMorphFromLocalBounds! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 8/13/2021 16:35:23' prior: 50594191 overrides: 50536534! - boundingRectOfCurrentMorphAfterDraw - "In targetForm coordinates. - Clipped to owner if appropriate. - BitBltCanvas doesn't keep track of Morph bounds as it draws them. But it is limited to drawing morphs where - #morphLocalBounds is known. Use it, then." - - ^self boundingRectOfCurrentMorphFromLocalBounds! ! - -MorphicCanvas removeSelector: #updateCurrentBounds! - -!methodRemoval: MorphicCanvas #updateCurrentBounds stamp: 'Install-4755-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-16h54m-jmv.004.cs.st 8/20/2021 16:04:12'! -updateCurrentBounds - "Update display bounds, for currentMorph only." - - | isKnownFailing | - isKnownFailing _ currentMorph isKnownFailing. - isKnownFailing - ifTrue: [ - self drawCurrentAsError ] - ifFalse: [ - currentMorph displayBoundsSetFrom: self].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4755-Morphic-refactorAndCleanup-JuanVuletich-2021Aug13-16h54m-jmv.004.cs.st----! - -'From Cuis 5.0 [latest update: #4755] on 14 August 2021 at 7:06:16 pm'! -!PluggableListMorphOfMany methodsFor: 'events' stamp: 'jmv 8/14/2021 19:06:08' prior: 50384531 overrides: 50458697! - mouseMove: aMouseMoveEvent localPosition: localEventPosition - "The mouse has moved, as characterized by the event provided. Adjust the scrollbar, and alter the selection as appropriate" - - | oldIndex oldVal row | - row _ (localEventPosition y < 0 and: [ scrollBar scrollValue > 0.0 ]) - ifTrue: [ - scrollBar scrollUp: 1. - "Leave at least one visible item unaffected, for better visual feedback to the user." - (self rowAtLocation: `0@0`) + 2 ] - ifFalse: [ - (localEventPosition y > extent y and: [ scrollBar scrollValue < 1.0 ]) - ifTrue: [ - scrollBar scrollDown: 1. - "Leave at least one visible item unaffected, for better visual feedback to the user." - (self rowAtLocation: 0@extent y) - 3 ] - ifFalse: [ self rowAtLocation: localEventPosition ]]. - row = 0 ifTrue: [ ^ self ]. - - "No change if model is locked" - self owningWindow ifNotNil: [ :w | - w okToChange ifFalse: [^ self]]. - - dragOnOrOff ifNil: [ - "Was not set at mouse down, which means the mouse must have gone down in an area where there was no list item" - dragOnOrOff _ (self listSelectionAt: row) not. - dragStartRow _ row ]. - - "Set meaning for subsequent dragging of selection" - oldIndex _ self getCurrentSelectionIndex. - oldIndex ~= 0 ifTrue: [ oldVal _ self listSelectionAt: oldIndex ]. - - "Set or clear new primary selection (listIndex)" - dragOnOrOff - ifTrue: [ self setSelectionIndex: row ] - ifFalse: [ self setSelectionIndex: 0 ]. - - "Need to restore the old one, due to how model works, and set new one." - oldIndex ~= 0 ifTrue: [ self listSelectionAt: oldIndex put: oldVal ]. - - "Select all in between if drag was too fast" - "self listSelectionAt: row put: dragOnOrOff." - dragStartRow ifNotNil: [ - (row min: dragStartRow) to: (row max: dragStartRow) do: [ :r | - self listSelectionAt: r put: dragOnOrOff ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4756-PluggableListMorphOfMany-fixAgainstMissingMouseDownEvent-JuanVuletich-2021Aug14-19h06m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4756] on 15 August 2021 at 10:20:46 am'! - -MorphicCanvas removeSelector: #image:multipliedBy:at:! - -!methodRemoval: MorphicCanvas #image:multipliedBy:at: stamp: 'Install-4757-cleanup-JuanVuletich-2021Aug15-10h14m-jmv.001.cs.st 8/20/2021 16:04:12'! -image: aForm multipliedBy: aColor at: aPoint - self subclassResponsibility.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4757-cleanup-JuanVuletich-2021Aug15-10h14m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4757] on 15 August 2021 at 6:37:12 pm'! -!BlockClosure methodsFor: 'evaluating' stamp: 'jmv 8/15/2021 18:36:43'! - ifErrorOrHalt: errorHandlerBlock - "Evaluate the block represented by the receiver, and normally return it's value. If an error occurs, the errorHandlerBlock is evaluated, and it's value is instead returned. The errorHandlerBlock must accept zero, one, or two parameters (the error message and the receiver)." - "Examples: - [1 halt] ifErrorOrHalt: [:err :rcvr | 'huh?']. - [1 whatsUpDoc] ifErrorOrHalt: [:err :rcvr | 'huh?']. - [1 / 0] ifErrorOrHalt: [:err :rcvr | - 'ZeroDivide' = err - ifTrue: [Float infinity] - ifFalse: [self error: err]] -" - - ^ self on: Error, Halt do: [ :ex | - errorHandlerBlock valueWithPossibleArgument: ex description and: ex receiver ]! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 8/15/2021 17:30:09' prior: 50568990! - displayWorldSafely - "Update this world's display and keep track of errors during draw methods." - - [self displayWorld] ifErrorOrHalt: [ :err :rcvr | - "Handle a drawing error" - canvas currentMorphDrawingFails. - self setCanvas. - "Install the old error handler, so we can re-raise the error" - rcvr error: err. - ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4758-Handle-halt-in-drawOn-JuanVuletich-2021Aug15-18h35m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4758] on 16 August 2021 at 3:21:11 pm'! -!WidgetMorph methodsFor: 'drawing' stamp: 'jmv 8/16/2021 15:20:50' prior: 50545913 overrides: 50593879! - drawOn: aCanvas - "A canvas is already set with a proper transformation from our coordinates to those of the Canvas target." - - aCanvas - fillRectangle: self morphLocalBounds - color: color - borderWidth: borderWidth - borderStyleSymbol: #simple - baseColorForBorder: borderColor.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4759-commentTweak-JuanVuletich-2021Aug16-15h20m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4759] on 16 August 2021 at 7:59:21 pm'! -!BitBlt methodsFor: 'private' stamp: 'jmv 8/16/2021 19:54:48' prior: 50590852! - copyBitsAgain - "Primitive. See BitBlt|copyBits, also a Primitive. Essential. See Object - documentation whatIsAPrimitive." - - - '#copyBitsAgain failed. Requested BitBlt operation not performed. Call stack follows:' print. - thisContext printStack: 15.! ! -!BitBlt methodsFor: 'private' stamp: 'jmv 8/16/2021 19:55:03' prior: 50577329! - roundVariables - - | maxVal minVal | - '-----------' print. - 'BitBlt >> copyBits failed. Will retry with parameters rounded. Requested parameters are:' print. - {'dest, source, halftone, rule:' . destForm . sourceForm . halftoneForm . combinationRule } print. - {'dest, extent, source, clipOrigin, clipExtent'. destX@destY. width@height. sourceX@sourceY. clipX@clipY. clipWidth@clipHeight } print. - {'colorMap'. colorMap } print. - maxVal _ SmallInteger maxVal. - minVal _ SmallInteger minVal. - destX _ destX asInteger min: maxVal max: minVal. - destY _ destY asInteger min: maxVal max: minVal. - width _ width asInteger min: maxVal max: minVal. - height _ height asInteger min: maxVal max: minVal. - sourceX _ sourceX asInteger min: maxVal max: minVal. - sourceY _ sourceY asInteger min: maxVal max: minVal. - clipX _ clipX asInteger min: maxVal max: minVal. - clipY _ clipY asInteger min: maxVal max: minVal. - clipWidth _ clipWidth asInteger min: maxVal max: minVal. - clipHeight _ clipHeight asInteger min: maxVal max: minVal. -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4760-BitBlt-roundingArgs-tweaks-JuanVuletich-2021Aug16-19h50m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4760] on 17 August 2021 at 10:30:58 am'! -!Morph methodsFor: 'updating' stamp: 'jmv 8/17/2021 09:16:29' prior: 50559369! - invalidateBounds - "Report that the area occupied by this morph and submorphs should be redrawn, - but most likely we are not going to be redrawn on it, or maybe we'll not be fully visible. See senders." - - self displayFullBounds ifNotNil: [ :r | - "outsetBy: 1 due to anti aliasing in VectorCanvas" - self invalidateDisplayRect: (r outsetBy: 1) for: nil ]. -! ! -!Morph methodsFor: 'updating' stamp: 'jmv 8/17/2021 09:16:15' prior: 50596381! - redrawNeeded - "Report that the area occupied by this morph should be redrawn. - Usually because we changed in some way." - - self needsRedraw: true. - self allOwnersDo: [ :m | m submorphNeedsRedraw: true ]. - "outsetBy: 1 due to anti aliasing in VectorCanvas" - self invalidateDisplayRect: (self displayBoundsOrBogus outsetBy: 1) for: self. - (self submorphsMightProtrude and: [self clipsSubmorphsReally not]) ifTrue: [ - self submorphsReverseDo: [ :m | m redrawNeeded ]].! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 8/17/2021 10:06:42' prior: 50594155! - drawCurrentAsError - "The morph (or one of its submorphs) had an error in its drawing method." - | r w | - r _ currentMorph morphLocalBoundsForError. - w _ r extent > `50@50` - ifTrue: [ 6 ] - ifFalse: [ 2 ]. - self - frameAndFillRectangle: r - fillColor: `Color red` - borderWidth: w - borderColor: `Color yellow`. - self line: r topLeft-0.5 to: r bottomRight-0.5 width: w color: `Color yellow`. - self line: r topRight-0.5 to: r bottomLeft-0.5 width: w color: `Color yellow`. - currentMorph displayBoundsSetFrom: self.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4761-MorphicInvalidationTweaks-JuanVuletich-2021Aug17-10h30m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4761] on 17 August 2021 at 3:53:26 pm'! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/17/2021 14:44:25'! - onFormWithWholePixelAntiAliasing: aForm - - ^ self subclassToUse basicNew - setForm: aForm subPixelAntiAliasing: false; - initializeWithOrigin: `0@0`.! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 8/17/2021 14:43:35'! - setForm: aForm subPixelAntiAliasing: aBooleanOrNil - "nil means use default kind of anti aliasing" - - form _ aForm. - engine _ BitBltCanvasEngine toForm: form. - "Init BitBlt so that the first call to the 'primitiveDisplayString' primitive will not fail" - engine sourceX: 0; width: 0. - self newClipRect: nil.! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/17/2021 14:31:13' prior: 50595457! - displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Clipped appropiately if some owner clips us. - See also #displayBoundsUpdateFrom:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - (aCanvas isBoundsFinderCanvas or: [c canvasToUse == aCanvas]) ifTrue: [ - self knowsOwnLocalBounds - ifTrue: [ - "A good optimization in many cases. - But for morphs where #drawOn: might not be able to find bounds (InnerTextMorph and LayoutMorph, - for example) this is essential." - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphFromLocalBounds] - ifFalse: [ - "Use the bounds bound by #drawOn. This method must therefore be called after calling #drawOn:." - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphAfterDraw. - self wantsContour - ifTrue: [ - (aCanvas - contourOfCurrentMorphAfterDrawInto: (self valueOfProperty: #contour) - into: [ :contourArray :contourY0 :contourY1 | - self setProperty: #contour toValue: contourArray. - self setProperty: #contourY0 toValue: contourY0. - self setProperty: #contourY1 toValue: contourY1. - ])] - ifFalse: [ - self setProperty: #contour toValue: nil. - self setProperty: #contourY0 toValue: nil. - self setProperty: #contourY1 toValue: nil ]]]]].! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 8/17/2021 15:03:24' prior: 50569486! - containsGlobalPoint: worldPoint - "Answer true if pixel worldPoint is covered by us, and we are visible a it. - No other morph above us also covers it." - - self visible ifTrue: [ - self topmostWorld ifNotNil: [ :w | - w canvas ifNotNil: [ :canvas | - ^ canvas morph: self isAtPoint: worldPoint ]]]. - ^ false! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/17/2021 14:43:50' prior: 50595166! - on: aForm over: aRectangle - "Warning: aForm extent must equal aRectangle extent" - - ^ self subclassToUse basicNew - setForm: aForm subPixelAntiAliasing: nil; - initializeWithOrigin: aRectangle topLeft negated.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/17/2021 14:43:57' prior: 50595177! - onForm: aForm - - ^ self subclassToUse basicNew - setForm: aForm subPixelAntiAliasing: nil; - initializeWithOrigin: `0@0`.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/17/2021 14:44:02' prior: 50595185! - onFormWithSubPixelAntiAliasing: aForm - - ^ self subclassToUse basicNew - setForm: aForm subPixelAntiAliasing: true; - initializeWithOrigin: `0@0`.! ! - -BitBltCanvas removeSelector: #setForm:preferSubPixelAntiAliasing:! - -!methodRemoval: BitBltCanvas #setForm:preferSubPixelAntiAliasing: stamp: 'Install-4762-Morphic-refactor-JuanVuletich-2021Aug17-15h51m-jmv.001.cs.st 8/20/2021 16:04:12'! -setForm: aForm preferSubPixelAntiAliasing: aBoolean - form _ aForm. - engine _ BitBltCanvasEngine toForm: form. - "Init BitBlt so that the first call to the 'primitiveDisplayString' primitive will not fail" - engine sourceX: 0; width: 0. - self newClipRect: nil.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4762-Morphic-refactor-JuanVuletich-2021Aug17-15h51m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4762] on 17 August 2021 at 4:09:44 pm'! -!Morph methodsFor: 'updating' stamp: 'jmv 8/17/2021 16:08:53' prior: 50596740! - redrawNeeded - "Report that the area occupied by this morph should be redrawn. - Usually because we changed in some way." - - self needsRedraw: true. - self allOwnersDo: [ :m | m submorphNeedsRedraw: true ]. - "outsetBy: 1 due to anti aliasing in VectorCanvas" - self invalidateDisplayRect: (self displayBoundsOrBogus outsetBy: 1) for: self. - (self submorphsMightProtrude and: [self clipsSubmorphsReally not]) ifTrue: [ - self submorphsReverseDo: [ :m | m redrawNeeded ]]. - self removeProperty: #shadow.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4763-ClearShadowIfAppropriate-JuanVuletich-2021Aug17-15h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4763] on 18 August 2021 at 11:56:50 am'! -!Morph methodsFor: 'private' stamp: 'jmv 8/18/2021 10:21:10'! - privateLocation: aGeometryTransformation! ! -!MovableMorph methodsFor: 'private' stamp: 'jmv 8/18/2021 10:21:31' overrides: 50596942! - privateLocation: aGeometryTransformation - location _ aGeometryTransformation.! ! -!MorphicCanvas methodsFor: 'initialization' stamp: 'jmv 8/18/2021 11:42:50'! - initializeWithTranslation: aPoint - - "Set up these only on initialization. - This is safe (wrt walkbacks during world redraw) because a new instance is created - on draw error. See #displayWorldSafely" - currentTransformation _ MorphicTranslation withTranslation: aPoint. - cti _ 1. - transformations - ifNil: [ transformations _ OrderedCollection with: currentTransformation ] - ifNotNil: [ transformations at: cti put: currentTransformation ]. - drawingMorphStack - ifNil: [ drawingMorphStack _ OrderedCollection with: nil ] - ifNotNil: [ drawingMorphStack at: cti put: nil ].! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/18/2021 11:43:12'! - onForm: aForm over: aRectangle - "Warning: aForm extent must equal aRectangle extent" - - ^ self subclassToUse basicNew - setForm: aForm subPixelAntiAliasing: nil; - initializeWithTranslation: aRectangle topLeft negated.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/18/2021 11:45:55'! - onForm: aForm translation: aPoint - - ^ self subclassToUse basicNew - setForm: aForm subPixelAntiAliasing: nil; - initializeWithTranslation: aPoint.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/18/2021 11:47:19'! - onFormWithSubPixelAntiAliasing: aForm translation: aPoint - - ^ self subclassToUse basicNew - setForm: aForm subPixelAntiAliasing: true; - initializeWithTranslation: aPoint.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/18/2021 11:47:27'! - onFormWithWholePixelAntiAliasing: aForm translation: aPoint - - ^ self subclassToUse basicNew - setForm: aForm subPixelAntiAliasing: false; - initializeWithTranslation: aPoint.! ! -!BitBltCanvas methodsFor: 'initialization' stamp: 'jmv 8/18/2021 11:42:39' overrides: 50596952! - initializeWithTranslation: aPoint - - super initializeWithTranslation: aPoint. - boundsFinderCanvas _ BitBltBoundsFinderCanvas new initializeWithTranslation: aPoint.! ! -!CharacterScanner methodsFor: 'scanning' stamp: 'jmv 8/18/2021 11:18:46' prior: 16802000! -placeEmbeddedObject: anchoredFormOrMorph - "Place the anchoredMorph or return false if it cannot be placed. - In any event, advance destX by its width." - - | w | - w _ (anchoredFormOrMorph is: #Morph) - ifTrue: [ anchoredFormOrMorph fullBoundsInOwner width ] - ifFalse: [ anchoredFormOrMorph width ]. - destX _ destX + w. - (destX > rightMargin and: [ lastIndex ~= line first ]) - "Won't fit, but not at start of a line. Start a new line with it" - ifTrue: [ ^ false]. - lastIndex _ lastIndex + 1. - ^ true! ! -!CharacterBlockScanner methodsFor: 'scanning' stamp: 'jmv 8/18/2021 11:18:52' prior: 16801911 overrides: 50597017! - placeEmbeddedObject: anchoredFormOrMorph - - (super placeEmbeddedObject: anchoredFormOrMorph) ifFalse: [^ false]. - specialWidth _ (anchoredFormOrMorph is: #Morph) - ifTrue: [ anchoredFormOrMorph fullBoundsInOwner width ] - ifFalse: [ anchoredFormOrMorph width ]. - ^ true! ! -!CompositionScanner methodsFor: 'stop conditions' stamp: 'jmv 8/18/2021 11:18:58' prior: 16823045 overrides: 50597017! - placeEmbeddedObject: anchoredFormOrMorph - | descent h | - - (super placeEmbeddedObject: anchoredFormOrMorph) ifFalse: [ - line stop: lastIndex-1. - ^ false]. - descent _ lineHeight - baseline. - h _ (anchoredFormOrMorph is: #Morph) - ifTrue: [ anchoredFormOrMorph fullBoundsInOwner height ] - ifFalse: [ anchoredFormOrMorph height ]. - baseline _ baseline max: h. - lineHeight _ baseline + descent. - line stop: lastIndex. - ^ true! ! -!MorphicScanner methodsFor: 'scanning' stamp: 'jmv 8/18/2021 11:19:24' prior: 50449783 overrides: 50597017! - placeEmbeddedObject: anchoredFormOrMorph - - (super placeEmbeddedObject: anchoredFormOrMorph) ifFalse: [^ false]. - (anchoredFormOrMorph is: #Morph) - ifTrue: [ - anchoredFormOrMorph morphPosition: - (destX@ (lineY+line baseline)) + (anchoredFormOrMorph morphPosition-anchoredFormOrMorph fullBoundsInOwner corner) rounded. - anchoredFormOrMorph show. - canvas fullDraw: anchoredFormOrMorph ] - ifFalse: [ - destY _ lineY. - canvas - image: anchoredFormOrMorph - at: destX - anchoredFormOrMorph width @ (destY + line baseline - anchoredFormOrMorph height) ]. - ^ true! ! -!Morph methodsFor: 'updating' stamp: 'jmv 8/18/2021 11:35:21' prior: 50596916! - redrawNeeded - "Report that the area occupied by this morph should be redrawn. - Usually because we changed in some way." - - self needsRedraw: true. - self allOwnersDo: [ :m | m submorphNeedsRedraw: true ]. - "outsetBy: 1 due to anti aliasing in VectorCanvas" - self invalidateDisplayRect: (self displayBoundsOrBogus outsetBy: 1) for: self. - (self submorphsMightProtrude and: [self clipsSubmorphsReally not]) ifTrue: [ - self submorphsReverseDo: [ :m | m redrawNeeded ]]. - self removeProperty: #bitMask. - self removeProperty: #fullBoundsInOwner.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/18/2021 11:45:10' prior: 16877726! - depth: depth over: aRectangle - - ^self onForm: (Form extent: aRectangle extent depth: depth) translation: aRectangle topLeft negated.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/18/2021 11:48:01' prior: 50596878! - onForm: aForm - - ^ self onForm: aForm translation: `0@0`.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/18/2021 11:48:27' prior: 50596886! - onFormWithSubPixelAntiAliasing: aForm - - ^ self onFormWithSubPixelAntiAliasing: aForm translation: `0@0`.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/18/2021 11:48:09' prior: 50596785! - onFormWithWholePixelAntiAliasing: aForm - - ^ self onFormWithWholePixelAntiAliasing: aForm translation: `0@0`.! ! - -BitBltCanvas removeSelector: #initializeWithOrigin:! - -!methodRemoval: BitBltCanvas #initializeWithOrigin: stamp: 'Install-4764-Morphic-Refactor-JuanVuletich-2021Aug18-11h54m-jmv.001.cs.st 8/20/2021 16:04:12'! -initializeWithOrigin: aPoint - - super initializeWithOrigin: aPoint. - boundsFinderCanvas _ BitBltBoundsFinderCanvas new initializeWithOrigin: aPoint.! - -MorphicCanvas class removeSelector: #on:over:! - -!methodRemoval: MorphicCanvas class #on:over: stamp: 'Install-4764-Morphic-Refactor-JuanVuletich-2021Aug18-11h54m-jmv.001.cs.st 8/20/2021 16:04:12'! -on: aForm over: aRectangle - "Warning: aForm extent must equal aRectangle extent" - - ^ self subclassToUse basicNew - setForm: aForm subPixelAntiAliasing: nil; - initializeWithOrigin: aRectangle topLeft negated.! - -MorphicCanvas removeSelector: #initializeWithOrigin:! - -!methodRemoval: MorphicCanvas #initializeWithOrigin: stamp: 'Install-4764-Morphic-Refactor-JuanVuletich-2021Aug18-11h54m-jmv.001.cs.st 8/20/2021 16:04:12'! -initializeWithOrigin: aPoint - - "Set up these only on initialization. - This is safe (wrt walkbacks during world redraw) because a new instance is created - on draw error. See #displayWorldSafely" - currentTransformation _ MorphicTranslation withTranslation: aPoint. - cti _ 1. - transformations - ifNil: [ transformations _ OrderedCollection with: currentTransformation ] - ifNotNil: [ transformations at: cti put: currentTransformation ]. - drawingMorphStack - ifNil: [ drawingMorphStack _ OrderedCollection with: nil ] - ifNotNil: [ drawingMorphStack at: cti put: nil ].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4764-Morphic-Refactor-JuanVuletich-2021Aug18-11h54m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4764] on 18 August 2021 at 12:12:53 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/18/2021 12:12:18'! - fullBoundsInOwner - "Answer fullBoundsInOwner. Cache the found bounds." - - (self valueOfProperty: #fullBoundsInOwner) ifNotNil: [ :fullBoundsInOwner | - ^fullBoundsInOwner ]. - - ^self setProperty: #fullBoundsInOwner toValue: self findFullBoundsInOwner.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4765-cached-fullBoundsInOwner-JuanVuletich-2021Aug18-12h12m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4765] on 18 August 2021 at 12:19:30 pm'! -!PseudoClass methodsFor: 'testing method dictionary' stamp: 'jmv 8/18/2021 10:11:36'! - canUnderstand: selector - "Answer whether the receiver can respond to the message whose selector - is the argument. The selector can be in the method dictionary of the - receiver's class or any of its superclasses." - - (self includesSelector: selector) ifTrue: [^true]. - self exists ifTrue: [ - ^self realClass canUnderstand: selector ]. - ^false! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4766-CodeFileBrowser-fix-JuanVuletich-2021Aug18-12h18m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4766] on 18 August 2021 at 12:29:42 pm'! -!MessageSet methodsFor: 'message list' stamp: 'jmv 8/18/2021 10:00:10'! - sortByClassHierarchy - "Sort the message-list by class / selector. List classes in hierarchical order." - - | aClass bClass classes classesAndPositions i | - - classes _ Set new. - messageList do: [ :methodReference | - methodReference actualClass ifNotNil: [ :actualClass | classes add: actualClass ]]. - classesAndPositions _ Dictionary new. - i _ 1. - Smalltalk hierarchySorted: classes do: [ :each | - classesAndPositions at: each put: i. - i _ i + 1 ]. - - messageList _ messageList sort: [ :a :b | - (a classSymbol = b classSymbol and: [ b classIsMeta = b classIsMeta ]) - ifTrue: [ - a methodSymbol == #Comment - ifTrue: [ true ] - ifFalse: [ - b methodSymbol == #Comment - ifTrue: [ false ] - ifFalse: [ a methodSymbol < b methodSymbol ]]] - ifFalse: [ - aClass _ a actualClass. - bClass _ b actualClass. - aClass isNil == bClass isNil - ifTrue: [ - aClass isNil - ifTrue: [a classSymbol < b classSymbol] - ifFalse: [(classesAndPositions at: aClass) < (classesAndPositions at: bClass)]] - ifFalse: [aClass isNil]]]. - messageList do: [ :each | each removeStringVersionPrefix ]. - self changed: #messageList.! ! -!MessageSet methodsFor: 'message list' stamp: 'jmv 8/18/2021 10:00:04'! - sortByClassName - "Sort the message-list by class / selector" - - messageList _ messageList sort: [ :a :b | - a classSymbol = b classSymbol - ifTrue: [ - a methodSymbol == #Comment - ifTrue: [ true ] - ifFalse: [ - b methodSymbol == #Comment - ifTrue: [ false ] - ifFalse: [ - a classIsMeta = b classIsMeta - ifTrue: [ a methodSymbol < b methodSymbol ] - ifFalse: [ a classIsMeta ] ]]] - ifFalse: [ a classSymbol < b classSymbol ] - ]. - messageList do: [ :each | each removeStringVersionPrefix ]. - self changed: #messageList! ! -!MessageSetWindow methodsFor: 'menu building' stamp: 'jmv 8/18/2021 10:01:05' prior: 50592763 overrides: 50403930! - addExtraMenu2ItemsTo: options - "The shifted selector-list menu is being built. Add items specific to MessageSet" - - model growable ifTrue: [ - options add: `{ - #itemGroup -> 40. - #itemOrder -> 31. - #label -> 'remove from this browser'. - #object -> #model. - #selector -> #removeMessageFromBrowser. - #icon -> #listRemoveIcon - } asDictionary`. - options add:`{ - #itemGroup -> 40. - #itemOrder -> 32. - #label -> 'filter message list...'. - #selector -> #filterMessageList. - #icon -> #findIcon - } asDictionary` ]. - - options add: `{ - #itemGroup -> 41. - #itemOrder -> 33. - #label -> 'sort by class hierarchy'. - #object -> #model. - #selector -> #sortByClassHierarchy. - #icon -> #classIcon - } asDictionary`. - options add: `{ - #itemGroup -> 41. - #itemOrder -> 34. - #label -> 'sort by class name'. - #object -> #model. - #selector -> #sortByClassName. - #icon -> #classIcon - } asDictionary`. - options add: `{ - #itemGroup -> 41. - #itemOrder -> 35. - #label -> 'sort by selector'. - #object -> #model. - #selector -> #sortBySelector. - #icon -> #scriptIcon - } asDictionary`. - options add: `{ - #itemGroup -> 41. - #itemOrder -> 36. - #label -> 'sort by date'. - #object -> #model. - #selector -> #sortByDate. - #icon -> #dateIcon - } asDictionary`. - options add: `{ - #itemGroup -> 41. - #itemOrder -> 37. - #label -> 'reverse sort'. - #object -> #model. - #selector -> #sortReverse. - #icon -> #redoIcon - } asDictionary`. - -! ! - -MessageSet removeSelector: #sortByClass! - -!methodRemoval: MessageSet #sortByClass stamp: 'Install-4767-MessageSet-sortBy-Enh-JuanVuletich-2021Aug18-12h24m-jmv.001.cs.st 8/20/2021 16:04:13'! -sortByClass - "Sort the message-list by class / selector" - - messageList _ messageList sort: [ :a :b | - a classSymbol = b classSymbol - ifTrue: [ - a methodSymbol == #Comment - ifTrue: [ true ] - ifFalse: [ - b methodSymbol == #Comment - ifTrue: [ false ] - ifFalse: [ - a classIsMeta = b classIsMeta - ifTrue: [ a methodSymbol < b methodSymbol ] - ifFalse: [ a classIsMeta ] ]]] - ifFalse: [ a classSymbol < b classSymbol ] - ]. - messageList do: [ :each | each removeStringVersionPrefix ]. - self changed: #messageList! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4767-MessageSet-sortBy-Enh-JuanVuletich-2021Aug18-12h24m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4767] on 18 August 2021 at 1:45:58 pm'! -!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 8/18/2021 13:45:29'! - browseMessageListUnsorted: methodReferences name: labelString autoSelect: autoSelectString - "Create and schedule a MessageSet browser on the message list. - Don't sort entries by default." - - | messageListSize title | - - messageListSize _ methodReferences size. - messageListSize = 0 ifTrue: [^ PopUpMenu inform: ('There are no\' , labelString) withNewLines ]. - - title _ messageListSize > 1 - ifFalse: [ labelString ] - ifTrue: [ '[', messageListSize printString, '] ', labelString]. - - MessageSetWindow - openMessageListUnsorted: methodReferences - label: title - autoSelect: autoSelectString! ! -!CodeWindow methodsFor: 'menu commands' stamp: 'jmv 8/18/2021 13:35:02'! - methodInheritance - "Create and schedule a method browser on the inheritance of implementors." - - | list aClassNonMeta isMeta theClassOrMeta aClass sel | - aClass _ model selectedClassOrMetaClass. - sel _ model selectedMessageName. - aClass ifNil: [ ^ self ]. - sel ifNil: [ ^ self ]. - aClassNonMeta _ aClass theNonMetaClass. - isMeta _ aClassNonMeta ~~ aClass. - list _ OrderedCollection new. - aClass allSuperclasses reverseDo: [ :cl | - (cl includesSelector: sel) ifTrue: [ - list addLast: (MethodReference class: cl selector: sel) ]]. - aClassNonMeta - allSubclassesWithLevelDo: [ :cl :level | - theClassOrMeta _ isMeta - ifTrue: [ cl class ] - ifFalse: [ cl ]. - (theClassOrMeta includesSelector: sel) ifTrue: [ - list addLast: (MethodReference class: theClassOrMeta selector: sel) ]] - startingLevel: 0. - Smalltalk - browseMessageList: list - name: 'Inheritance of ' , sel.! ! -!CodeFileBrowserWindow methodsFor: 'menu commands' stamp: 'jmv 8/18/2021 13:35:08' overrides: 50597401! - methodInheritance - (model selectedClassOrMetaClass isNil or: - [model selectedClassOrMetaClass hasDefinition]) - ifFalse: [super methodInheritance]! ! -!MessageSetWindow class methodsFor: 'opening' stamp: 'jmv 8/18/2021 13:44:33'! - openMessageListUnsorted: methodReferences label: labelString autoSelect: autoSelectString - "Open a system view for a MessageSet on messageList. - Don't sort entries by default." - - | messageSet | - - messageSet _ MessageSet messageList: methodReferences asArray. - messageSet autoSelectString: autoSelectString. - - ^self open: messageSet label: labelString ! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 8/18/2021 13:33:06' prior: 50365988! - testDecompiler - " - Smalltalk testDecompiler - " - "Decompiles the source for every method in the system, and then compiles that source and verifies that it generates (and decompiles to) identical code. This currently fails in a number of places because some different patterns (esp involving conditionals where the first branch returns) decompile the same." - | methodNode oldMethod newMethod badOnes oldCodeString n | - badOnes _ OrderedCollection new. - 'Decompiling all classes...' - displayProgressAt: Sensor mousePoint - from: 0 - to: CompiledMethod instanceCount - during: [ :barBlock | - n _ 0. - Smalltalk allBehaviorsDo: [ :cls | - "Transcript cr; show: cls name." - cls selectors do: [ :selector | - (n _ n + 1) \\ 100 = 0 ifTrue: [ barBlock value: n ]. - oldMethod _ cls compiledMethodAt: selector. - oldCodeString _ (cls decompilerClass new - decompile: selector - in: cls - method: oldMethod) decompileString. - methodNode _ cls compilerClass new - compile: oldCodeString - in: cls - notifying: nil - ifFail: nil. - newMethod _ methodNode generate: #(0 0 0 0 ). - oldCodeString = - (cls decompilerClass new - decompile: selector - in: cls - method: newMethod) decompileString ifFalse: [ - Transcript - newLine; - show: '***' , cls name , ' ' , selector. - badOnes add: (MethodReference class: cls selector: selector) ]]]]. - Smalltalk - browseMessageList: badOnes - name: 'Decompiler Discrepancies'.! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 8/18/2021 13:33:12' prior: 50366039! - testFormatter - "Smalltalk testFormatter" - "Reformats the source for every method in the system, and then compiles that source and verifies that it generates identical code. - The formatting used will be classic monochrome." - | newCodeString methodNode oldMethod newMethod badOnes n | - badOnes _ OrderedCollection new. - 'Formatting all classes...' - displayProgressAt: Sensor mousePoint - from: 0 - to: CompiledMethod instanceCount - during: [ :barBlock | - n _ 0. - Smalltalk allBehaviorsDo: [ :cls | - "Transcript cr; show: cls name." - cls selectors do: [ :selector | - (n _ n + 1) \\ 100 = 0 ifTrue: [ barBlock value: n ]. - newCodeString _ cls compilerClass new - format: (cls sourceCodeAt: selector) - in: cls - notifying: nil. - methodNode _ cls compilerClass new - compile: newCodeString - in: cls - notifying: nil - ifFail: nil. - newMethod _ methodNode generate: #(0 0 0 0 ). - oldMethod _ cls compiledMethodAt: selector. - oldMethod = newMethod ifFalse: [ - Transcript - newLine; - show: '***' , cls name , ' ' , selector. - badOnes add: cls name , ' ' , selector ]]]]. - Smalltalk - browseMessageList: badOnes - name: 'Formatter Discrepancies'.! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 8/18/2021 13:33:19' prior: 50366081! - testFormatter2 - "Smalltalk testFormatter2" - "Reformats the source for every method in the system, and then verifies that the order of source tokens is unchanged. - The formatting used will be classic monochrome" - | newCodeString badOnes n oldCodeString oldTokens newTokens | - badOnes _ OrderedCollection new. - 'Formatting all classes...' - displayProgressAt: Sensor mousePoint - from: 0 - to: CompiledMethod instanceCount - during: [ :barBlock | - n _ 0. - Smalltalk allBehaviorsDo: [ :cls | - "Transcript cr; show: cls name." - cls selectors do: [ :selector | - (n _ n + 1) \\ 100 = 0 ifTrue: [ barBlock value: n ]. - oldCodeString _ (cls sourceCodeAt: selector) asString. - newCodeString _ cls compilerClass new - format: oldCodeString - in: cls - notifying: nil. - oldTokens _ oldCodeString findTokens: Character separators. - newTokens _ newCodeString findTokens: Character separators. - oldTokens = newTokens ifFalse: [ - Transcript - newLine; - show: '***' , cls name , ' ' , selector. - badOnes add: cls name , ' ' , selector ]]]]. - Smalltalk - browseMessageList: badOnes - name: 'Formatter Discrepancies'.! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 8/18/2021 13:45:39' prior: 50505900! - browseAllAccessesTo: instVarName from: aClass - "Create and schedule a Message Set browser for all the receiver's methods - or any methods of a subclass/superclass that refer to the instance variable name." - - "self new browseAllAccessesTo: 'contents' from: Collection." - - ^ self - browseMessageListUnsorted: (aClass allAccessesTo: instVarName) - name: 'Accesses to ' , instVarName - autoSelect: instVarName! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 8/18/2021 13:25:24' prior: 50452712! - browseAllCallsOn: aLiteral - "Create and schedule a message browser on each method that refers to - aLiteral. For example, Smalltalk browseAllCallsOn: #open:label:." - (aLiteral isKindOf: LookupKey) - ifTrue: [ - self - browseMessageList: (self allCallsOn: aLiteral) - name: 'Users of ' , aLiteral key - autoSelect: aLiteral key ] - ifFalse: [ - self - browseMessageList: (self allCallsOn: aLiteral) - name: 'Senders of ' , aLiteral - autoSelect: aLiteral ].! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 8/18/2021 13:25:36' prior: 50452731! - browseAllCallsOn: aLiteral localTo: aClass - "Create and schedule a message browser on each method in or below the given class that refers to - aLiteral. For example, Smalltalk browseAllCallsOn: #open:label:." - aClass ifNil: [ ^ self inform: 'no selected class' ]. - (aLiteral isKindOf: LookupKey) - ifTrue: [ - self - browseMessageList: (aClass allLocalCallsOn: aLiteral) - name: 'Users of ' , aLiteral key , ' local to ' , aClass name - autoSelect: aLiteral key ] - ifFalse: [ - self - browseMessageList: (aClass allLocalCallsOn: aLiteral) - name: 'Senders of ' , aLiteral , ' local to ' , aClass name - autoSelect: aLiteral ].! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 8/18/2021 13:25:43' prior: 50338409! - browseAllCallsOnClass: aClass - "Create and schedule a message browser on each method that refers to - aClass. For example, Smalltalk browseAllCallsOnClass: Object." - self - browseMessageList: aClass allCallsOn - name: 'Users of class ' , aClass theNonMetaClass name - autoSelect: aClass theNonMetaClass name.! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 8/18/2021 13:30:38' prior: 16923961! - browseAllImplementorsOfList: selectorList title: aTitle - "Create and schedule a message browser on each method that implements the message whose selector is in the argument selectorList. For example, Smalltalk browseAllImplementorsOfList: #(at:put: size) title: 'stuff'." - - | flattenedList | - flattenedList _ Array streamContents: [ :stream | - selectorList do: [ :sel | - stream nextPutAll: (self allImplementorsOf: sel)]]. - ^ self browseMessageList: flattenedList name: aTitle! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 8/18/2021 13:31:29' prior: 50496547! - browseAllReferencesToLiteral: aLiteral - "Create and schedule a message browser on each method that references aLiteral. For example, - Smalltalk browseAllReferencesToLiteral: 47. - Smalltalk browseAllReferencesToLiteral: 0@0. - " - ^ self - browseMessageList: (self allReferencesToLiteral: aLiteral) - name: 'References to literal ' , aLiteral asString.! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 8/18/2021 13:26:04' prior: 50525518! - browseClassCommentsWithString: aString - "Smalltalk browseClassCommentsWithString: 'my instances' " - "Launch a message list browser on all class comments containing aString as a substring." - | caseSensitive suffix list | - suffix _ (caseSensitive _ Sensor shiftPressed) - ifTrue: [ ' (case-sensitive)' ] - ifFalse: [ ' (use shift for case-sensitive)' ]. - list _ Set new. - Smalltalk allClassesDo: [ :class | - (class organization classComment asString - findString: aString - startingAt: 1 - caseSensitive: caseSensitive) > 0 ifTrue: [ - list add: (MethodReference class: class selector: #Comment) ]]. - ^ self - browseMessageList: list - name: 'Class comments containing ', aString printString, suffix - autoSelect: aString.! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 8/18/2021 13:04:28' prior: 50450168! - browseMessageList: methodReferences name: labelString autoSelect: autoSelectString - "Create and schedule a MessageSet browser on the message list." - - | messageListSize title | - - messageListSize _ methodReferences size. - messageListSize = 0 ifTrue: [^ PopUpMenu inform: ('There are no\' , labelString) withNewLines ]. - - title _ messageListSize > 1 - ifFalse: [ labelString ] - ifTrue: [ '[', messageListSize printString, '] ', labelString]. - - MessageSetWindow - openMessageList: methodReferences - label: title - autoSelect: autoSelectString! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 8/18/2021 13:40:57' prior: 50419008! - browseViewReferencesFromNonViews - " - Smalltalk browseViewReferencesFromNonViews - " - | aLiteral aCollection | - - aCollection _ OrderedCollection new. - - "Tweak to look just for pluggables or also for menus (or maybe for all morphs)" -" PopUpMenu withAllSubclasses , MenuMorph withAllSubclasses , PluggableMorph withAllSubclasses do: [ :view |" - PluggableMorph withAllSubclassesDo: [ :view | -" MenuMorph withAllSubclassesDo: [ :view |" - - aLiteral _ view name. - - "tweak to linclude refs to SysWindow subhierarchy or not" - (view includesBehavior: SystemWindow) & false ifFalse: [ - Smalltalk allBehaviorsDo: [ :class | - ((class includesBehavior: Morph) or: [ class includesBehavior: Morph class ]) ifFalse: [ - class addMethodsTo: aCollection thatReferenceTo: aLiteral special: false byte: nil ]]]]. - - Smalltalk - browseMessageList: aCollection asSet - name: 'References to Views from non-Views' - autoSelect: ''.! ! -!SmalltalkEditor methodsFor: 'menu messages' stamp: 'jmv 8/18/2021 13:41:52' prior: 50496571! - referencesToSelectedLiteral - "Evaluate the selected text and browse methods that reference the same literal" - [ - self - evaluateSelectionAndDo: [ :result | - Smalltalk - browseMessageList: (Smalltalk allReferencesToLiteral: result) - name: 'Users of literal: ' , result asString - autoSelect: self selection ] - ifFail: nil - profiled: false ] - on: UndeclaredVariableReference , UnknownSelector - do: [ :ex | - morph flash ]! ! -!CodeWindow methodsFor: 'GUI building' stamp: 'jmv 8/18/2021 13:35:46' prior: 16813052! - optionalButtonTuples - "Answer a tuple buttons, in the format: - button label - selector to send - help message" - - | aList | - - aList _ #( - (10 'browse' browseMethodFull 'view this method in a browser') - (11 'senders' browseSendersOfMessages 'browse senders of...') - (16 'implementors' browseMessages 'browse implementors of...') - (12 'versions' browseVersions 'browse versions')), - - (Preferences decorateBrowserButtons - ifTrue: - [{#(13 'inheritance' methodInheritance 'browse method inheritance -green: sends to super -tan: has override(s) -mauve: both of the above -pink: is an override but doesn''t call super -pinkish tan: has override(s), also is an override but doesn''t call super' )}] - ifFalse: - [{#(13 'inheritance' methodInheritance 'browse method inheritance')}]), - - #( - (12 'hierarchy' browseHierarchy 'browse class hierarchy') - (10 'inst vars' browseInstVarRefs 'inst var refs...') - (11 'class vars' browseClassVarRefs 'class var refs...') - (10 'show...' offerWhatToShowMenu 'menu of what to show in lower pane')). - - ^ aList! ! -!CodeWindow methodsFor: 'accessing' stamp: 'jmv 8/18/2021 13:35:17' prior: 16813155! - inheritanceButton - "If receiver has an Inheritance button, answer it, else answer nil. morphic only at this point" - - ^ self buttonWithSelector: #methodInheritance! ! -!CodeWindow methodsFor: 'keyboard shortcuts' stamp: 'jmv 8/18/2021 13:35:25' prior: 50594564! - messageListKey: aChar from: view - "Respond to a Command key. I am a model with a code pane, and I also - have a listView that has a list of methods. The view knows how to get - the list and selection." - - | sel class | - aChar == $D ifTrue: [^ model toggleDiffing]. - - sel _ model selectedMessageName. - aChar == $m ifTrue: [ "These next two put up a type in if no message selected" - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllImplementorsOf: to: Smalltalk]. - aChar == $n ifTrue: [ - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllCallsOn: to: Smalltalk]. - - "The following require a class selection" - (class _ model selectedClassOrMetaClass) ifNil: [^ self ]. - aChar == $b ifTrue: [^ BrowserWindow fullOnClass: class selector: sel]. - aChar == $N ifTrue: [^ self browseClassRefs]. - aChar == $i ifTrue: [^ self methodInheritance]. - aChar == $h ifTrue: [^ self browseHierarchy]. - aChar == $p ifTrue: [^ self browseFullProtocol]. - - sel - ifNotNil: [ - "The following require a method selection" - aChar == $o ifTrue: [^ model fileOutMessage]. - aChar == $c ifTrue: [^ model copySelector]. - aChar == $v ifTrue: [^ self browseVersions]. - aChar == $C ifTrue: [^ model showHomeCategory]. - aChar == $O ifTrue: [^ self openSingleMessageBrowser]. - aChar == $x ifTrue: [^ model removeMessage]. - aChar == $t ifTrue: [^ model runMethodTest]. - aChar == $r ifTrue: [^ model debugMethodTest]] - ifNil: [ - aChar == $R ifTrue: [^ model renameClass]]! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'jmv 8/18/2021 13:38:26' prior: 50411592! - messageListMenuOptions - - ^`{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'what to show...'. - #selector -> #offerWhatToShowMenu. - #icon -> #preferencesIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'toggle break on entry'. - #object -> #model. - #selector -> #toggleBreakOnEntry. - #icon -> #debugIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'browse method (O)'. - #selector -> #openSingleMessageBrowser. - #icon -> #scriptIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 40. - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutMessage. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'inspect CompiledMethod'. - #object -> #model. - #selector -> #inspectCompiledMethod. - #icon -> #exploreIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'senders of... (n)'. - #selector -> #browseSendersOfMessages. - #icon -> #mailForwardIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'implementors of... (m)'. - #selector -> #browseMessages. - #icon -> #developmentIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 30. - #label -> 'inheritance (i)'. - #selector -> #methodInheritance. - #icon -> #goDownIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 40. - #label -> 'versions (v)'. - #selector -> #browseVersions. - #icon -> #clockIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'inst var refs...'. - #selector -> #browseInstVarRefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 20. - #label -> 'inst var defs...'. - #selector -> #browseInstVarDefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'class var refs...'. - #selector -> #browseClassVarRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 40. - #label -> 'class variables'. - #selector -> #browseClassVariables. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 50. - #label -> 'class refs (N)'. - #selector -> #browseClassRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'remove method (x)'. - #object -> #model. - #selector -> #removeMessage. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 20. - #label -> 'run test (t)'. - #object -> #model. - #selector -> #runMethodTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 30. - #label -> 'debug test (r)'. - #object -> #model. - #selector -> #debugMethodTest. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 10. - #label -> 'more...'. - #selector -> #openMessageListMenu2. - #icon -> #listAddIcon - } asDictionary. - }`. - ! ! -!CodeFileBrowserWindow methodsFor: 'menu building' stamp: 'jmv 8/18/2021 13:38:36' prior: 50493220 overrides: 50403971! - messageListMenu - | aMenu itemColl | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'Message List'. - itemColl _ OrderedCollection new. - self model baseCodeSource isLiveSmalltalkImage ifTrue: [ - itemColl add: - {#label -> 'fileIn'. #object -> #model. #selector -> #fileInMessage. #icon -> #updateIcon} asDictionary ]. - itemColl addAll: - { - {#label -> 'fileOut'. #object -> #model. #selector -> #fileOutMessage. #icon -> #fileOutIcon} asDictionary. - nil - }. - self model baseCodeSource isLiveSmalltalkImage ifTrue: [ - itemColl addAll: - { - {#label -> 'senders (n)'. #selector -> #browseSenders. #icon -> #mailForwardIcon} asDictionary. - {#label -> 'implementors (m)'. #selector -> #browseImplementors. #icon -> #developmentIcon} asDictionary. - {#label -> 'method inheritance (h)'. #selector -> #methodInheritance. #icon -> #goDownIcon} asDictionary. - {#label -> 'versions (v)'. #selector -> #browseVersions. #icon -> #clockIcon} asDictionary - } ]. - itemColl addAll: - { - nil. - {#label -> 'remove method (x)'. #object -> #model. #selector -> #removeMessage. #icon -> #deleteIcon} asDictionary - }. - aMenu addItemsFromDictionaries: itemColl. - ^ aMenu.! ! -!MessageSetWindow class methodsFor: 'opening' stamp: 'jmv 8/18/2021 13:03:57' prior: 50443929! - openMessageList: methodReferences label: aString - "Create a standard system view for the message set on the list, anArray. - The label of the view is aString." - - | messageSet | - messageSet _ MessageSet messageList: methodReferences asArray. - messageSet sortByClassHierarchy. - ^self open: messageSet label: aString.! ! -!MessageSetWindow class methodsFor: 'opening' stamp: 'jmv 8/18/2021 13:45:03' prior: 50443939! - openMessageList: methodReferences label: labelString autoSelect: autoSelectString - "Open a system view for a MessageSet on messageList." - - | messageSet | - - messageSet _ MessageSet messageList: methodReferences asArray. - messageSet sortByClassHierarchy. - messageSet autoSelectString: autoSelectString. - - ^self open: messageSet label: labelString ! ! -!ChangeSorterWindow methodsFor: 'menu building' stamp: 'jmv 8/18/2021 13:39:15' prior: 50397473! - messageMenu - "Fill aMenu with items appropriate for the message list; could be for a single or double changeSorter" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'message list'. - aMenu addStayUpIcons. - aMenu - addItemsFromDictionaries: `{ - { - #label -> 'delete method from changeSet (d)'. - #object -> #model. - #selector -> #forget. - #icon -> #warningIcon - } asDictionary. - nil. - { - #label -> 'remove method from system (x)'. - #object -> #model. - #selector -> #removeMessage. - #icon -> #deleteIcon - } asDictionary. - nil. - { - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #label -> 'browse method (O)'. - #selector -> #openSingleMessageBrowser. - #icon -> #scriptIcon - } asDictionary. - { - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - nil. - { - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutMessage. - #icon -> #fileOutIcon - } asDictionary. - nil. - { - #label -> 'senders of... (n)'. - #selector -> #browseSendersOfMessages. - #icon -> #mailForwardIcon - } asDictionary. - { - #label -> 'implementors of... (m)'. - #selector -> #browseMessages. - #icon -> #developmentIcon - } asDictionary. - { - #label -> 'inheritance (i)'. - #selector -> #methodInheritance. - #icon -> #goDownIcon - } asDictionary. - { - #label -> 'versions (v)'. - #selector -> #browseVersions. - #icon -> #clockIcon - } asDictionary. - }`. - ^ aMenu! ! - -CodeFileBrowserWindow removeSelector: #methodHierarchy! - -!methodRemoval: CodeFileBrowserWindow #methodHierarchy stamp: 'Install-4768-MessageSet-SortByClassHierarchyByDefault-JuanVuletich-2021Aug18-13h00m-jmv.001.cs.st 8/20/2021 16:04:13'! -methodHierarchy - (model selectedClassOrMetaClass isNil or: - [model selectedClassOrMetaClass hasDefinition]) - ifFalse: [super methodHierarchy]! - -CodeWindow removeSelector: #methodHierarchy! - -!methodRemoval: CodeWindow #methodHierarchy stamp: 'Install-4768-MessageSet-SortByClassHierarchyByDefault-JuanVuletich-2021Aug18-13h00m-jmv.001.cs.st 8/20/2021 16:04:13'! -methodHierarchy - "Create and schedule a method browser on the hierarchy of implementors." - - | list aClassNonMeta isMeta theClassOrMeta aClass sel | - aClass _ model selectedClassOrMetaClass. - sel _ model selectedMessageName. - aClass ifNil: [ ^ self ]. - sel ifNil: [ ^ self ]. - aClassNonMeta _ aClass theNonMetaClass. - isMeta _ aClassNonMeta ~~ aClass. - list _ OrderedCollection new. - aClass allSuperclasses reverseDo: [ :cl | - (cl includesSelector: sel) ifTrue: [ - list addLast: (MethodReference class: cl selector: sel) ]]. - aClassNonMeta - allSubclassesWithLevelDo: [ :cl :level | - theClassOrMeta _ isMeta - ifTrue: [ cl class ] - ifFalse: [ cl ]. - (theClassOrMeta includesSelector: sel) ifTrue: [ - list addLast: (MethodReference class: theClassOrMeta selector: sel) ]] - startingLevel: 0. - Smalltalk - browseMessageList: list - name: 'Inheritance of ' , sel.! - -SystemDictionary removeSelector: #browseMessageList:ofSize:name:autoSelect:! - -!methodRemoval: SystemDictionary #browseMessageList:ofSize:name:autoSelect: stamp: 'Install-4768-MessageSet-SortByClassHierarchyByDefault-JuanVuletich-2021Aug18-13h00m-jmv.001.cs.st 8/20/2021 16:04:13'! -browseMessageList: messageList ofSize: messageListSize name: labelString autoSelect: autoSelectString - - | title | - - "Create and schedule a MessageSet browser on the message list." - - messageListSize = 0 ifTrue: [^ PopUpMenu inform: ('There are no\' , labelString) withNewLines ]. - - title _ messageListSize > 1 - ifFalse: [ labelString ] - ifTrue: [ '[', messageListSize printString, '] ', labelString]. - - MessageSetWindow - openMessageList: messageList - label: title - autoSelect: autoSelectString! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4768-MessageSet-SortByClassHierarchyByDefault-JuanVuletich-2021Aug18-13h00m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4768] on 19 August 2021 at 10:40:15 am'! -!Form methodsFor: 'coloring' stamp: 'jmv 8/19/2021 10:35:00' prior: 50386923! - reverse - "Change all the bits in the receiver that are white to black, and the ones - that are black to white. - Display reverse. Display forceToScreen. - " - - (BitBlt toForm: self) - combinationRule: `Form reverse`; - copyBits.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4769-Fix-reverse-for1bpp-JuanVuletich-2021Aug19-10h08m-jmv.001.cs.st----! - -'From Haver 5.0 [latest update: #4768] on 18 August 2021 at 9:24:57 pm'! - -"Change Set: 4770-MouseWheelSupport-GeraldKlix-2021Aug18-21h24m -Date: 18 August 2021 -Author: Gerald Klix - -I provide native support for mice with wheels"! -!EventSensor methodsFor: 'private-I/O' stamp: 'KLG 8/12/2021 20:23:55'! - processMouseSensorWheelEvent: evt - "Process a mouse wheel event, updating EventSensor state. - - Ported from Squeak 5.3." - - | modifiers buttons mapped | - "Only used by #peekWheelDelta in Squeak, which has no senders. - Can be added in the future." - "F: mouseWheelDelta := (evt at: 3) @ (evt at: 4)." - buttons _ evt at: 5. - modifiers _ evt at: 6. - mapped _ self mapButtons: buttons modifiers: modifiers. - mouseButtons _ mapped bitOr: (modifiers bitShift: 3).! ! -!EventSensor methodsFor: 'private-I/O' stamp: 'KLG 8/12/2021 21:58:09' prior: 50509336! - processSensorEvent: evt discardingMouseEvents: discardMouseEvents - "Process a single event. This method is run at high priority." - | type | - type _ evt at: 1. - - "Check if the event is a user interrupt" - (type = EventSensor eventTypeKeyboard and: [ (evt at: 4) = 0 and: [ - ((evt at: 3) bitOr: (((evt at: 5) bitAnd: 8) bitShift: 8)) = interruptKey]]) - ifTrue: [ - "interrupt key is meta - not reported as event" - ^interruptSemaphore signal]. - - "Store the event in the queue if there's any" - type = EventSensor eventTypeMouse ifTrue: [ - "Only swap secondary and tertiary buttons if there is no command or option modifier keys. - This swap is done so a 3-button mouse is - left -> mouseButton1 (select) - center -> mouseButton3 (halo) - right -> mouseButton2 (menu). - This is only needed on the Mac, Window VM does this mapping by default. - We avoid ding the swap if there are modifier keys, because in that case the buttons were generated by the VM as follows: - left -> mouseButton1 - macOption + left -> mouseButton3 - command + left -> mouseButton2, - but Mac users are already used to - macOption + left -> menu - command + left -> halo. - See #installMouseDecodeTable" - ((evt at: 6) anyMask: 12) ifFalse: [ - evt at: 5 put: (ButtonDecodeTable at: (evt at: 5) + 1)]]. - - (discardMouseEvents and: [ type = EventSensor eventTypeMouse ]) ifFalse: [ - self queueEvent: evt ]. - - "Update state for InputSensor." - "KLG: Why not `self class` instead of `EventSensor`?" - type = EventSensor eventTypeMouse ifTrue: [ - self processMouseSensorEvent: evt ]. - type = EventSensor eventTypeKeyboard ifTrue: [ - self processKeyboardSensorEvent: evt ]. - type = EventSensor eventTypeMouseScroll ifTrue: [ - self processMouseSensorWheelEvent: evt ]! ! -!EventSensor methodsFor: 'test' stamp: 'KLG 8/14/2021 19:42:35' prior: 50561241! - printEventBuffer: evtBuf - "Print the event buffer, currently only used by the method `test`." - - | type buttons macRomanCode modifiers pressType stamp unicodeCodePoint | - type _ evtBuf first. - stamp _ evtBuf second. - stamp = 0 ifTrue: [ stamp := Time millisecondClockValue ]. "VMs report events using #millisecondClockValue" - type = EventSensor eventTypeMouse - ifTrue: [ | position | - position _ evtBuf third @ evtBuf fourth. - buttons _ evtBuf fifth. - modifiers _ evtBuf sixth. - Transcript - newLine; - show: 'Mouse'; - show: ' position:', position printString; - show: ' buttons:', buttons printString; - show: ' modifiers:', modifiers printString. - ]. - type = EventSensor eventTypeMouseScroll - ifTrue: [ | delta | - delta _ evtBuf third @ evtBuf fourth. - buttons _ evtBuf fifth. - modifiers _ evtBuf sixth. - Transcript - newLine; - show: 'Scroll'; - show: ' delta:', delta printString; - show: ' buttons:', buttons printString; - show: ' modifiers:', modifiers printString. - ]. - type = EventSensor eventTypeKeyboard - ifTrue: [ - macRomanCode _ evtBuf third. - unicodeCodePoint _ evtBuf sixth. - pressType _ evtBuf fourth. - modifiers _ evtBuf fifth. - pressType = EventSensor eventKeyDown ifTrue: [ - type _ #keyDown]. - pressType = EventSensor eventKeyUp ifTrue: [ - type _ #keyUp]. - pressType = EventSensor eventKeyChar ifTrue: [ - type _ #keystroke]. - Transcript - newLine; - show: type; - show: ' macRomanCode:', macRomanCode printString, '-', - (Character numericValue: (Character macRomanToLatin1: macRomanCode)) asString, '-'; - show: ' unicodeCodePoint:', unicodeCodePoint printString. - (Character iso8859s15CodeForUnicodeCodePoint: unicodeCodePoint) ifNotNil: [ :latin15 | - Transcript show: '-', (Character numericValue: latin15) asString, '-' ]. - Transcript - show: ' modifiers:', modifiers printString. - (modifiers anyMask: 8) ifTrue: [ Transcript show: ' [commandWinAlt]' ]. - (modifiers anyMask: 4) ifTrue: [ Transcript show: ' [macOption]' ]. - (modifiers anyMask: 2) ifTrue: [ Transcript show: ' [control]' ]. - (modifiers anyMask: 1) ifTrue: [ Transcript show: ' [shift]' ]. - ].! ! -!EventSensor class methodsFor: 'constants' stamp: 'KLG 8/12/2021 21:58:09'! - eventTypeMouseScroll - "Types of events, - - I am a mouse wheel event." - ^7! ! -!SystemDictionary methodsFor: 'vm parameters' stamp: 'jmv 8/19/2021 11:57:26'! - sendMouseWheelEvents - "The Cog VM can be instructed to deliver mouse wheel events as mouse wheel events. - By default mouse wheel events are mapped to arrow events. - This flag persists across snapshots, stored in the image header. - - This implementation was copied from Squeak 5.3 and modified: - Non-Cog VMs might not support this flag. If this is the case, just answer false." - - ^ (self vmParameterAt: 48) - ifNil: [ false ] - ifNotNil: [ :properties | properties allMask: 32 ].! ! -!SystemDictionary methodsFor: 'vm parameters' stamp: 'jmv 8/19/2021 11:57:12'! - sendMouseWheelEvents: aBoolean - "The Cog VM can be instructed to deliver mouse wheel events as mouse wheel events. - By default mouse wheel events are mapped to arrow events. - This flag persists across snapshots, stored in the image header. - - This implementation was copied from Squeak 5.3 and modified: - Non-Cog VMs might not support this flag. If this is the case, just ignore it." - - (self vmParameterAt: 48) ifNotNil: [ :properties | - self vmParameterAt: 48 put: (properties bitClear: 32) + (aBoolean ifTrue: [32] ifFalse: [0]) ].! ! -!HandMorph methodsFor: 'event handling' stamp: 'KLG 8/12/2021 21:58:09' prior: 50426461! - createEventFrom: eventBuffer ofType: type - - type = EventSensor eventTypeMouse ifTrue: [ ^self generateMouseEvent: eventBuffer ]. - type = EventSensor eventTypeMouseScroll ifTrue: [ ^self generateMouseScrollEvent: eventBuffer ]. - type = EventSensor eventTypeKeyboard ifTrue: [ ^self generateKeyboardEvent: eventBuffer ]. - type = EventSensor eventTypeWindow ifTrue: [ ^self generateWindowEvent: eventBuffer ]. - type = EventSensor eventTypeDragDropFiles ifTrue: [ ^self generateDropFilesEvent: eventBuffer ]. - - "All other events are ignored" - ^nil ! ! -!HandMorph methodsFor: 'private events' stamp: 'KLG 8/14/2021 21:44:15'! - generateMouseScrollEvent: evtBuf - "Generate the appropriate mouse wheel event for the given raw event buffer - - Copied from Sqeak 5.3 and modifed." - - | buttons modifiers stamp deltaX deltaY direction oldButtons | - stamp _ evtBuf second. - stamp = 0 ifTrue: [stamp := Time millisecondClockValue ]. - deltaX _ evtBuf third. - deltaY _ evtBuf fourth. - "This implementation deliberatly ignores movements in both dimensions:" - direction _ - deltaY negative - ifTrue: [ #down ] - ifFalse: [ deltaY strictlyPositive - ifTrue: [ #up ] - ifFalse: [ deltaX negative - ifTrue: [ #left ] - ifFalse: [ deltaX strictlyPositive - ifTrue: [ #right ] - ifFalse: [ ^ nil "No movement, bailing out" ] ] ] ]. - modifiers _ evtBuf fifth. - buttons _ (modifiers bitShift: 3) bitOr: (lastMouseEvent buttons bitAnd: 7). - oldButtons _ lastEventBuffer fifth - bitOr: (lastEventBuffer sixth bitShift: 3). - lastEventBuffer := evtBuf. - ^ MouseScrollEvent new - setType: #mouseScroll - position: self morphPosition - direction: direction - buttons: (oldButtons bitXor: buttons) - hand: self - stamp: stamp! ! -!MouseScrollEvent methodsFor: 'dispatching' stamp: 'KLG 8/16/2021 21:27:23' prior: 50564113 overrides: 50563947! - dispatchWith: aMorph - "Find the appropriate receiver for the event and let it handle it. Default rules: - * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. - * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. - * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. - * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. - " - "Try to get out quickly" - | aMorphHandlesIt handledByInner | - "FIXME - this works in all tested cases but one: when the window directly under the mouse doesn't have keyboard focus (i.e. a Transcript window)" - aMorph fullContainsGlobalPoint: position :: ifFalse: [ ^ #rejected ]. - "Install the prospective handler for the receiver" - aMorphHandlesIt _ false. - (aMorph handlesMouseScroll: self) ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]. - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - (eachChild dispatchEvent: self) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - (handledByInner or: [ - (aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position]]) ifTrue: [ - "aMorph is in the top-most unlocked, visible morph in the chain." - aMorphHandlesIt ifTrue: [ ^ self sendEventTo: aMorph ]]. - handledByInner ifTrue: [ ^ self ]. - "Mouse was not on aMorph nor any of its children" - ^ #rejected.! ! - -"PostScript: - -Initialization code follows:" -Smalltalk sendMouseWheelEvents: true! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4770-MouseWheelSupport-GeraldKlix-2021Aug18-21h24m-KLG.002.cs.st----! - -'From Cuis 5.0 [latest update: #4768] on 18 August 2021 at 10:08:36 pm'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 8/18/2021 19:52:01'! - quit - "Just quit. No questions asked. No validations done. - Smalltalk quit. - " - self snapshot: false andQuit: true embedded: false clearAllClassState: false! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 8/18/2021 21:03:40'! - saveAndQuit - "Save image and quit. No questions asked. - Smalltalk saveAndQuit. - " - ChangeSet zapAllChangeSets. - ^ self - snapshot: true - andQuit: true - embedded: false - clearAllClassState: false.! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 8/18/2021 21:03:59'! - saveAs: newName clearAllClassState: clearAllStateFlag - "Save the image under a new name. Don't quit. - See senders." - - | newChangesName | - self currentChangesName ifNotNil: [ :oldChangesName | - self closeSourceFiles. "so copying the changes file will always work" - newChangesName _ self fullNameForChangesNamed: newName. - FileIOAccessor default copy: oldChangesName asFileEntry to: newChangesName asFileEntry. - ChangesInitialFileSize ifNotNil: [ - oldChangesName asFileEntry appendStreamDo: [ :strm | strm truncate: ChangesInitialFileSize ]]]. - - ChangeSet zapAllChangeSets. - self - changeImageNameTo: (self fullNameForImageNamed: newName); - closeSourceFiles; openSourceFiles; "so SNAPSHOT appears in new changes file" - snapshot: true andQuit: false embedded: false clearAllClassState: clearAllStateFlag.! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 8/18/2021 21:05:18'! - saveImage - "Save image. Don't quit. No questions asked. - Smalltalk saveImage. - " - ChangeSet zapAllChangeSets. - ^ self - snapshot: true - andQuit: false - embedded: false - clearAllClassState: false.! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 8/18/2021 20:26:01' prior: 16922570! - okayToDiscardUnsavedCode - "Answer true unless the user cancels quitting because of some warning given. - Smalltalk okayToDiscardUnsavedCode - " - | baseCSdirty dirtyPackages | - baseCSdirty _ ChangeSet allChangeSets anySatisfy: [ :any | any isForBaseSystem and: [ any hasUnsavedChanges ]]. - "dirtyPackages _ CodePackage installedPackages anySatisfy: [ :pck | pck hasUnsavedChanges ]." - dirtyPackages _ ChangeSet allChangeSets anySatisfy: [ :any | any codePackage notNil and: [ any hasUnsavedChanges ]]. - baseCSdirty & dirtyPackages ifTrue: [ - ^self confirm: 'There are both unsaved Packages', String newLineString, - 'and unsaved Changes to Cuis core.', String newLineString, - 'If you continue, all unsaved changes will be lost.', String newLineString, - 'Continue?' ]. - baseCSdirty ifTrue: [ - ^self confirm: 'Some ChangeSet for Cuis core have unsaved changes.', String newLineString, - 'If you continue, they would be lost.', String newLineString, - 'Continue?' ]. - dirtyPackages ifTrue: [ - ^self confirm: 'There are unsaved Packages.', String newLineString, - 'If you continue, their changes will be lost.', String newLineString, - 'Continue?' ]. - ^true! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 8/18/2021 20:47:51' prior: 50514414! - saveAs - "Put up the 'saveAs' prompt, obtain a name, and save the image under that new name." - - self request: 'New file name?' initialAnswer: self imageName asFileEntry name do: [:newName| - ((((self fullNameForImageNamed: newName) asFileEntry exists not - and: [(self fullNameForChangesNamed: newName) asFileEntry exists not]) - or: [self confirm: ('{1} already exists. Overwrite?' format: {newName})])) - ifTrue: [ - self saveAs: newName clearAllClassState: false]]! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 8/18/2021 21:04:40' prior: 50454953! - saveAsNewVersion - "Save the image/changes using the next available version number. - This is usually only used to prepare updated Cuis images for distribution." - " - Smalltalk saveAsNewVersion - " - | fileName newName changesName systemVersion | - systemVersion _ SystemVersion current. - fileName _ String streamContents: [ :strm | - strm - nextPutAll: 'Cuis'; - print: systemVersion versionMajor; - nextPut: $.; - print: systemVersion versionMinor; - nextPut: $-; - print: systemVersion highestUpdate. - Smalltalk isSpur - ifTrue: [ - Smalltalk wordSize = 4 ifTrue: [ - strm nextPutAll: '-32' ]] - ifFalse: [ - strm nextPutAll: '-v3' ]]. - newName _ fileName, '.image'. - (DirectoryEntry smalltalkImageDirectory // newName) exists ifTrue: [ - newName _ DirectoryEntry smalltalkImageDirectory - nextNameFor: fileName - extension: 'image' ]. - changesName _ self fullNameForChangesNamed: newName. - "Check to see if there is a .changes file that would cause a problem if we saved a new .image file with the new version number" - changesName asFileEntry exists ifTrue: [ - ^ self inform: -'There is already .changes file of the desired name, -', changesName, ' -curiously already present, even though there is no -corresponding .image file. -Please remedy manually and then repeat your request.' ]. - "Try to clear all user state, including all class vars, preferences, etc" - self saveAs: newName clearAllClassState: true! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 8/18/2021 21:54:21' prior: 50541368! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag - "This is the main method for image save and / or quit. - See senders." - "WARNING: Current process will be killed. UI Process will be restarted" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic - checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " - | activeProc | - activeProc _ Processor activeProcess. - [ | isARealStartup guiRootObject guiRootObjectClass | - save not & quit - ifTrue: [ - (SourceFiles at: 2) ifNotNil: [ :changes | - ChangesInitialFileSize ifNotNil: [ changes truncate: ChangesInitialFileSize ]]] - ifFalse: [ - self - logSnapshot: save - andQuit: quit ]. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | - each isInWorld ifTrue: [ - each delete.]]. - UISupervisor ui tearDownDesktop. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - "Cosas que levanto explicitamente abajo" - guiRootObjectClass _ UISupervisor ui class. - guiRootObject _ UISupervisor ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "guiRootObject _ clearAllStateFlag ifFalse: [ UISupervisor ui ]." - UISupervisor stopUIProcess. - activeProc isTerminated ifFalse: [ activeProc terminate ]. - "Clean Globals" - Smalltalk - at: #Sensor - put: nil. - Smalltalk - at: #Display - put: nil. - Smalltalk closeSourceFiles. - Smalltalk - at: #SourceFiles - put: nil. - Smalltalk allClassesDo: [ :cls | - cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | - cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ - Smalltalk printStuffToCleanOnImageSave. - "Remove this call to actually see the image clean report." - Transcript clear. - ]. - "Do image save & quit as apropriate" - (Cursor cursorAt: #writeCursor) activateCursor. - save - ifTrue: [ - "The snapshot primitive answers false if it was just called to do the snapshot. - But image startup is resumed by returning (again) from the primitive, but this time answering true." - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk - at: #Sensor - put: nil. - Smalltalk - at: #Display - put: DisplayScreen new. - Smalltalk - at: #SourceFiles - put: (Array new: 2). - Smalltalk openSourceFiles. - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | - cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - UISupervisor spawnNewMorphicProcessFor: (guiRootObject ifNil: [ guiRootObject _ guiRootObjectClass newWorld ]). - self restoreLostChangesIfNecessary. - clearAllStateFlag ifTrue: [ - UISupervisor whenUIinSafeState: [ - guiRootObject recreateDefaultDesktop; restoreDisplay. - Display triggerEvent: #screenSizeChanged ]] - ifFalse: [ - UISupervisor whenUIinSafeState: [ - guiRootObject restoreDisplay. - Display triggerEvent: #screenSizeChanged ]]. - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - UISupervisor whenUIinSafeState: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]] - forkAt: Processor timingPriority - 1 - named: 'Startup process'.! ! -!Preferences class methodsFor: 'themes' stamp: 'jmv 8/18/2021 20:51:39' prior: 50594387! - cuisDefaults - self setPreferencesFrom: #( - #(#balloonHelpEnabled true ) - #(#biggerCursors false ) - #(#browseWithPrettyPrint false ) - #(#caseSensitiveFinds false ) - #(#checkForSlips true ) - #(#cmdDotEnabled true ) - #(#diffsInChangeList true ) - #(#diffsWithPrettyPrint false ) - #(#menuKeyboardControl true ) - #(#optionalButtons true ) - #(#extraDebuggerButtons true ) - #(#subPixelRenderFonts true ) - #(#thoroughSenders true ) - #(#cheapWindowReframe false ) - #(#syntaxHighlightingAsYouType true ) - #(#tapAndHoldEmulatesButton2 true ) - #(#clickGrabsMorphs false ) - #(#syntaxHighlightingAsYouTypeAnsiAssignment false ) - #(#syntaxHighlightingAsYouTypeLeftArrowAssignment false ) - ). - self useMenuIcons.! ! -!TheWorldMenu methodsFor: 'commands' stamp: 'jmv 8/18/2021 20:15:28' prior: 50594414! - quitSession - - Smalltalk okayToDiscardUnsavedCode ifFalse: [ ^ self ]. - Smalltalk quit! ! -!TheWorldMenu class methodsFor: 'menu building' stamp: 'jmv 8/18/2021 22:04:22' prior: 50555486! - worldMenuOptions - - ^`{{ - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Open...'. - #selector -> #openOpenMenu. - #icon -> #openIcon. - #balloonText -> 'Submenu to open various system tools'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'New morph...'. - #selector -> #newMorph. - #icon -> #morphsIcon. - #balloonText -> 'Offers a variety of ways to create new objects'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Preferences...'. - #selector -> #openPreferencesMenu. - #icon -> #preferencesIcon. - #balloonText -> 'Opens a menu offering many controls over appearance and system preferences.'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'Windows...'. - #selector -> #openWindowsMenu. - #icon -> #windowIcon. - #balloonText -> 'Manage open windows'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 50. - #label -> 'Help...'. - #selector -> #openHelpMenu. - #icon -> #helpIcon. - #balloonText -> 'Opens a menu of useful items for updating the system, determining what version you are running, and much else'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Changes...'. - #selector -> #openChangesMenu. - #icon -> #changesIcon. - #balloonText -> 'Opens a menu of useful tools for dealing with changes'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Debug...'. - #selector -> #openDebugMenu. - #icon -> #debugIcon. - #balloonText -> 'a menu of debugging items'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'Restore Display'. - #object -> #myWorld. - #selector -> #restoreDisplay. - #icon -> #displayIcon. - #balloonText -> 'Repaint the screen -- useful for removing unwanted display artifacts, lingering cursors, etc.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Save Image'. - #object -> Smalltalk. - #selector -> #saveImage. - #icon -> #saveIcon. - #balloonText -> 'Save the current version of the image on disk. Overwrite existing file.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Save as...'. - #object -> Smalltalk. - #selector -> #saveAs. - #icon -> #saveAsIcon. - #balloonText -> 'Save the current version of the image on disk under a new name.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'Save new Cuis Release'. - #object -> Smalltalk. - #selector -> #saveAsNewVersion. - #icon -> #saveAsNewVersionIcon. - #balloonText -> ('Save as a new release of Cuis.\', - 'Use an updated version-stamped name\', - 'and save it under that name on disk.\', - 'Clear all user preferences and user state (class vars).') withNewLines. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 40. - #label -> 'Save and Quit'. - #object -> Smalltalk. - #selector -> #saveAndQuit. - #icon -> #saveAndQuitIcon. - #balloonText -> 'Save the image and quit out of Cuis. Overwrite existing file.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 50. - #label -> 'Quit'. - #selector -> #quitSession. - #icon -> #quitIcon. - #balloonText -> ('Quit out of Cuis without saving the image.\', - 'Ask for confirmation if there are unsaved changes.') withNewLines. - } asDictionary. -}`! ! - -TheWorldMenu removeSelector: #saveAndQuit! - -!methodRemoval: TheWorldMenu #saveAndQuit stamp: 'Install-4771-QuitAndSaveOptions-JuanVuletich-2021Aug18-21h53m-jmv.001.cs.st 8/20/2021 16:04:13'! -saveAndQuit - - Smalltalk snapshot: true andQuit: true clearAllClassState: false! - -Preferences class removeSelector: #askForSaveOnQuit! - -!methodRemoval: Preferences class #askForSaveOnQuit stamp: 'Install-4771-QuitAndSaveOptions-JuanVuletich-2021Aug18-21h53m-jmv.001.cs.st 8/20/2021 16:04:13'! -askForSaveOnQuit - ^ self - valueOfFlag: #askForSaveOnQuit - ifAbsent: [ true ].! - -SystemDictionary removeSelector: #saveAs:andQuit:clearAllClassState:! - -!methodRemoval: SystemDictionary #saveAs:andQuit:clearAllClassState: stamp: 'Install-4771-QuitAndSaveOptions-JuanVuletich-2021Aug18-21h53m-jmv.001.cs.st 8/20/2021 16:04:13'! -saveAs: newName andQuit: aBoolean clearAllClassState: clearAllStateFlag - "Save the image under a new name." - - | newChangesName | - self currentChangesName ifNotNil: [ :oldChangesName | - self closeSourceFiles. "so copying the changes file will always work" - newChangesName _ self fullNameForChangesNamed: newName. - FileIOAccessor default copy: oldChangesName asFileEntry to: newChangesName asFileEntry. - ChangesInitialFileSize ifNotNil: [ - oldChangesName asFileEntry appendStreamDo: [ :strm | strm truncate: ChangesInitialFileSize ]]]. - - self - changeImageNameTo: (self fullNameForImageNamed: newName); - closeSourceFiles; openSourceFiles; "so SNAPSHOT appears in new changes file" - snapshot: true andQuit: aBoolean - clearAllClassState: clearAllStateFlag! - -SystemDictionary removeSelector: #okayToSave! - -!methodRemoval: SystemDictionary #okayToSave stamp: 'Install-4771-QuitAndSaveOptions-JuanVuletich-2021Aug18-21h53m-jmv.001.cs.st 8/20/2021 16:04:13'! -okayToSave - "Answer true unless the user cancels saving because of some warning given." - - | wasCog isCog | - isCog _ Smalltalk isRunningCog. - [ wasCog _ self imageFormatVersionFromFile allMask: 1 ] - on: Error - do: [ :ignore | - "probably save-as to non-existing file" - ^ true ]. - - (isCog and: [wasCog not]) ifTrue: [ - (self confirm: 'You''re running with a Cog VM.', String newLineString, - 'Non-Cog VMs might not be able to open images saved under Cog!!', String newLineString, - '(If you choose "YES", you might only use this image under Cog VMs.)', String newLineString, - '(If you choose "NO", you might save your work in some other way, and later exit Cuis without saving).', String newLineString, - 'Really save?') - ifFalse: [ ^false ]]. - - ^ true! - -SystemDictionary removeSelector: #saveSession! - -!methodRemoval: SystemDictionary #saveSession stamp: 'Install-4771-QuitAndSaveOptions-JuanVuletich-2021Aug18-21h53m-jmv.001.cs.st 8/20/2021 16:04:13'! -saveSession - self snapshot: true andQuit: false clearAllClassState: false! - -SystemDictionary removeSelector: #snapshot:andQuit:clearAllClassState:! - -!methodRemoval: SystemDictionary #snapshot:andQuit:clearAllClassState: stamp: 'Install-4771-QuitAndSaveOptions-JuanVuletich-2021Aug18-21h53m-jmv.001.cs.st 8/20/2021 16:04:13'! -snapshot: save andQuit: quit clearAllClassState: clearAllStateFlag - save - ifTrue: [ - self okayToSave ifFalse: [ ^ self ]. - ChangeSet zapAllChangeSets ] - ifFalse: [ - quit ifTrue: [ - self okayToDiscardUnsavedCode ifFalse: [ ^ self ]]]. - ^ self - snapshot: save - andQuit: quit - embedded: false - clearAllClassState: clearAllStateFlag! - -SystemDictionary removeSelector: #snapshot:andQuit:embedded:! - -!methodRemoval: SystemDictionary #snapshot:andQuit:embedded: stamp: 'Install-4771-QuitAndSaveOptions-JuanVuletich-2021Aug18-21h53m-jmv.001.cs.st 8/20/2021 16:04:13'! -snapshot: save andQuit: quit embedded: embeddedFlag - - self snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: false! - -SystemDictionary removeSelector: #snapshot:andQuit:! - -!methodRemoval: SystemDictionary #snapshot:andQuit: stamp: 'Install-4771-QuitAndSaveOptions-JuanVuletich-2021Aug18-21h53m-jmv.001.cs.st 8/20/2021 16:04:13'! -snapshot: save andQuit: quit - - self snapshot: save andQuit: quit embedded: false clearAllClassState: false! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4771-QuitAndSaveOptions-JuanVuletich-2021Aug18-21h53m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4771] on 19 August 2021 at 12:55:04 pm'! -!ReferenceStream commentStamp: 'jmv 8/19/2021 12:54:08' prior: 16899450! - This is a way of serializing a tree of objects into disk file. A ReferenceStream can store -one or more objects in a persistent form, including sharing and cycles. - -Here is the way to use ReferenceStream: - ReferenceStream dumpOnFile: ('test1.obj' asFileEntry) object: myObj . - -To get it back: - myObj _ ReferenceStream restoreFromFile: ('test1.obj' asFileEntry ). - -ReferenceStreams can now write "weak" references. nextPutWeak: -writes a "weak" reference to an object, which refers to that object -*if* it also gets written to the stream by a normal nextPut:. - -A ReferenceStream should be treated as a read-stream *or* as a write-stream, *not* as a read/write-stream. The reference-remembering mechanism would probably do bad things if you tried to read and write from the same ReferenceStream. - -Instance variables - references -- an IdentityDictionary mapping objects already written - to their byteStream positions. If asked to write any object a - second time, we just write a reference to its stream position. - This handles shared objects and reference cycles between objects. - To implement "weak references" (for Aliases), the references - dictionary also maps objects not (yet?) written to a Collection - of byteStream positions with hopeful weak-references to it. If - asked to definitely write one of these objects, we'll fixup those - weak references. - objects -- an IdentityDictionary mapping relative byte stream positions to - objects already read in. If asked to follow a reference, we - return the object already read. - This handles shared objects and reference cycles between objects. - currentReference -- the current reference position. Positon relative to the - start of object data in this file. (Allows user to cut and paste smalltalk - code from the front of the file without effecting the reference values.) - This variable is used to help install each new object in "objects" as soon - as it's created, **before** we start reading its contents, in - case any of its content objects reference it. - fwdRefEnds -- A weak reference can be a forward reference, which - requires advance-reading the referrent. When we later come to the - object, we must get its value from "objects" and not re-read it so - refs to it don't become refs to copies. fwdRefEnds remembers the - ending byte stream position of advance-read objects. - skipping -- true if - -If the object is referenced before it is done being created, it might get created twice. Just store the object the moment it is created in the 'objects' dictionary. If at the end, comeFullyUpOnReload returns a different object, some refs will have the temporary object (this is an unlikely case). At the moment, no implementor of comeFullyUpOnReload returns a different object except DiskProxy, and that is OK. -! -!ReferenceStream class methodsFor: 'as yet unclassified' stamp: 'jmv 8/19/2021 12:50:34'! - dumpOnFile: aFileEntry object: anObject - "Warning. if the file named aString existis it will be lost. " - - aFileEntry forceWriteStreamDo: [ :stream | - (self on: stream) nextPut: anObject ].! ! -!ReferenceStream class methodsFor: 'as yet unclassified' stamp: 'jmv 8/19/2021 12:52:54'! - restoreFromFile: aFileEntry - - | answer | - aFileEntry readStreamDo: [ :stream | - answer _ (self on: stream) next ]. - ^answer! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4772-ReferenceStream-Comment-helpers-NicolaMingotti-2021Aug19-12h47m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4768] on 19 August 2021 at 3:37:26 pm'! - -Object subclass: #MethodCategoriesPrompter - instanceVariableNames: 'startClass rejectingFirst prompt categories lines reject ' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Text'! - -!classDefinition: #MethodCategoriesPrompter category: #'System-Text' stamp: 'Install-4773-DebuggerTests-HernanWilkinson-2021Aug19-15h15m-HAW.001.cs.st 8/20/2021 16:04:13'! -Object subclass: #MethodCategoriesPrompter - instanceVariableNames: 'startClass rejectingFirst prompt categories lines reject' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Text'! -!MethodCategoriesPrompter methodsFor: 'initialization' stamp: 'HAW 8/19/2021 15:16:33'! - initializeStaringFrom: aClass rejectingFirst: aRejectingFirst - - startClass := aClass. - rejectingFirst := aRejectingFirst. - - self initializeCategories ! ! -!MethodCategoriesPrompter methodsFor: 'prompting' stamp: 'HAW 8/19/2021 15:17:29'! - prompt: aPrompt ifNone: aNoneBlock - - | selectedCategoryIndex categoryName | - - selectedCategoryIndex := self promptCategory: aPrompt. - selectedCategoryIndex = 0 ifTrue: [^ aNoneBlock value]. - - categoryName := selectedCategoryIndex = 1 ifTrue: [ self requestNewCategory ] ifFalse: [ categories at: selectedCategoryIndex ]. - categoryName isEmpty ifTrue: [ ^aNoneBlock value ]. - - ^categoryName - ! ! -!MethodCategoriesPrompter methodsFor: 'prompting - private' stamp: 'HAW 8/19/2021 15:17:44'! - promptCategory: aPrompt - - | selectedLabelIndex | - - selectedLabelIndex := categories size = 1 - ifTrue: [ 1 ] - ifFalse: [ (PopUpMenu labelArray: categories lines: lines) startUpWithCaption: aPrompt ]. - - ^selectedLabelIndex! ! -!MethodCategoriesPrompter methodsFor: 'accessing' stamp: 'HAW 8/19/2021 15:18:46'! - categories - - ^categories! ! -!MethodCategoriesPrompter methodsFor: 'accessing' stamp: 'HAW 8/19/2021 15:19:53'! - lines - - ^lines ! ! -!MethodCategoriesPrompter class methodsFor: 'instance creation' stamp: 'HAW 8/19/2021 15:16:16'! - staringFrom: aClass rejectingFirst: rejectingFirst - - ^self new initializeStaringFrom: aClass rejectingFirst: rejectingFirst -! ! -!CodeProvider methodsFor: 'categories' stamp: 'HAW 8/19/2021 15:15:23' prior: 50580336! - categoryFromUserWithPrompt: aPrompt for: aClass - "self new categoryFromUserWithPrompt: 'testing' for: SystemDictionary" - - ^(MethodCategoriesPrompter - staringFrom: aClass - rejectingFirst: false) prompt: aPrompt ifNone: [ nil ]! ! -!Browser methodsFor: 'message category functions' stamp: 'HAW 8/19/2021 15:15:47' prior: 50580347! - newMethodCategoryNameIfNone: aNoneBlock - - ^(MethodCategoriesPrompter - staringFrom: self selectedClassOrMetaClass - rejectingFirst: true) prompt: 'Add Category' ifNone: aNoneBlock! ! -!Debugger methodsFor: 'context stack menu' stamp: 'HAW 8/19/2021 15:16:05' prior: 50580356! - askForCategoryIn: aClass default: aDefaultCategory - - ^(MethodCategoriesPrompter - staringFrom: aClass - rejectingFirst: false) prompt: 'Select category for the new method' ifNone: [ aDefaultCategory ]! ! - -MethodCategoriesPrompter class removeSelector: #staringFrom:rejectingFirst:prompting:! - -!methodRemoval: MethodCategoriesPrompter class #staringFrom:rejectingFirst:prompting: stamp: 'Install-4773-DebuggerTests-HernanWilkinson-2021Aug19-15h15m-HAW.001.cs.st 8/20/2021 16:04:13'! -staringFrom: aClass rejectingFirst: rejectingFirst prompting: aPrompt - - ^self new initializeStaringFrom: aClass rejectingFirst: rejectingFirst prompting: aPrompt -! - -MethodCategoriesPrompter removeSelector: #promptCategory! - -!methodRemoval: MethodCategoriesPrompter #promptCategory stamp: 'Install-4773-DebuggerTests-HernanWilkinson-2021Aug19-15h15m-HAW.001.cs.st 8/20/2021 16:04:13'! -promptCategory - - | selectedLabelIndex | - - selectedLabelIndex := categories size = 1 - ifTrue: [ 1 ] - ifFalse: [ (PopUpMenu labelArray: categories lines: lines) startUpWithCaption: prompt ]. - - ^selectedLabelIndex! - -MethodCategoriesPrompter removeSelector: #initializeStaringFrom:rejectingFirst:prompting:! - -!methodRemoval: MethodCategoriesPrompter #initializeStaringFrom:rejectingFirst:prompting: stamp: 'Install-4773-DebuggerTests-HernanWilkinson-2021Aug19-15h15m-HAW.001.cs.st 8/20/2021 16:04:13'! -initializeStaringFrom: aClass rejectingFirst: aRejectingFirst prompting: aPrompt - - startClass := aClass. - rejectingFirst := aRejectingFirst. - prompt := aPrompt ! - -MethodCategoriesPrompter removeSelector: #valueIfNone:! - -!methodRemoval: MethodCategoriesPrompter #valueIfNone: stamp: 'Install-4773-DebuggerTests-HernanWilkinson-2021Aug19-15h15m-HAW.001.cs.st 8/20/2021 16:04:13'! -valueIfNone: aNoneBlock - - | selectedCategoryIndex categoryName | - - self initializeCategories. - - selectedCategoryIndex := self promptCategory. - selectedCategoryIndex = 0 ifTrue: [^ aNoneBlock value]. - - categoryName := selectedCategoryIndex = 1 ifTrue: [ self requestNewCategory ] ifFalse: [ categories at: selectedCategoryIndex ]. - categoryName isEmpty ifTrue: [ ^aNoneBlock value ]. - - ^categoryName - ! - -Object subclass: #MethodCategoriesPrompter - instanceVariableNames: 'startClass rejectingFirst categories lines reject' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Text'! - -!classDefinition: #MethodCategoriesPrompter category: #'System-Text' stamp: 'Install-4773-DebuggerTests-HernanWilkinson-2021Aug19-15h15m-HAW.001.cs.st 8/20/2021 16:04:13'! -Object subclass: #MethodCategoriesPrompter - instanceVariableNames: 'startClass rejectingFirst categories lines reject' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Text'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4773-DebuggerTests-HernanWilkinson-2021Aug19-15h15m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4773] on 19 August 2021 at 10:52:53 pm'! -!TranscriptMorph methodsFor: 'initialization' stamp: 'jmv 8/19/2021 22:52:02' prior: 16938595 overrides: 50545905! - initialize - super initialize. - doImmediateUpdates _ true. - Transcript showOnDisplay: doImmediateUpdates! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4774-Transcript-immediateUpdates-fix-JuanVuletich-2021Aug19-22h52m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4774] on 20 August 2021 at 10:09:12 am'! -!Object methodsFor: 'printing' stamp: 'jmv 8/20/2021 09:47:29' prior: 16882216! - printString - "Answer a String whose characters are a description of the receiver. - If you want to print without a character limit, use fullPrintString. - - This description is to be meaningful for a Smalltalk programmer and usually includes - a hint on the class of the object. - - Usually you should not reimplement this method in subclasses, but #printOn: - - See the comments at: - #printString - #displayStringOrText - #asString - #storeString" - - ^ self printStringLimitedTo: 200! ! -!Inspector methodsFor: 'constants' stamp: 'jmv 8/20/2021 09:46:52' prior: 50515580! - printStringLimit - - ^1200! ! -!HierarchicalListMorph methodsFor: 'private' stamp: 'jmv 8/20/2021 09:54:01' prior: 16853456! - addSubmorphsAfter: parentMorph fromCollection: aCollection allowSorting: sortBoolean - - | priorMorph morphList newCollection limit warning | - priorMorph _ nil. - newCollection _ (sortBoolean and: [sortingSelector notNil]) ifTrue: [ - aCollection asOrderedCollection sort: [ :a :b | - (a perform: sortingSelector) <= (b perform: sortingSelector)] - ] ifFalse: [ - aCollection - ]. - "Limit the number of entries shown." - limit _ 51. - newCollection size > limit ifTrue: [ - warning _ 'Only the first ', (limit-1) printString, ' elements included.'. - newCollection _ newCollection copyFrom: 1 to: limit. - newCollection at: limit put: (ListItemWrapper with: warning) ]. - morphList _ OrderedCollection new. - newCollection do: [ :item | - priorMorph _ self indentingItemClass basicNew - initWithContents: item - prior: priorMorph - forList: self - indentLevel: parentMorph indentLevel + 1. - morphList add: priorMorph. - ]. - scroller addAllMorphs: morphList after: parentMorph. - ^morphList - -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4775-LimitStuffShownInInspectorsAndExplorers-JuanVuletich-2021Aug20-10h08m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4775] on 20 August 2021 at 11:41:07 am'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 8/20/2021 11:40:27'! - saveAndQuitAs: newName clearAllClassState: clearAllStateFlag - "Save the image under a new name. Don't quit. - See senders." - - | newChangesName | - self currentChangesName ifNotNil: [ :oldChangesName | - self closeSourceFiles. "so copying the changes file will always work" - newChangesName _ self fullNameForChangesNamed: newName. - FileIOAccessor default copy: oldChangesName asFileEntry to: newChangesName asFileEntry. - ChangesInitialFileSize ifNotNil: [ - oldChangesName asFileEntry appendStreamDo: [ :strm | strm truncate: ChangesInitialFileSize ]]]. - - ChangeSet zapAllChangeSets. - self - changeImageNameTo: (self fullNameForImageNamed: newName); - closeSourceFiles; openSourceFiles; "so SNAPSHOT appears in new changes file" - snapshot: true andQuit: true embedded: false clearAllClassState: clearAllStateFlag.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4776-saveAndQuitAs-clearAllClassState-JuanVuletich-2021Aug20-11h40m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4775] on 20 August 2021 at 11:58:40 am'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 8/20/2021 11:56:37'! - askConfirmationOnQuit - "Answer true unless the user cancels quitting because of some warning given. - Smalltalk askConfirmationOnQuit - " - | baseCSdirty dirtyPackages | - baseCSdirty _ ChangeSet allChangeSets anySatisfy: [ :any | any isForBaseSystem and: [ any hasUnsavedChanges ]]. - "dirtyPackages _ CodePackage installedPackages anySatisfy: [ :pck | pck hasUnsavedChanges ]." - dirtyPackages _ ChangeSet allChangeSets anySatisfy: [ :any | any codePackage notNil and: [ any hasUnsavedChanges ]]. - baseCSdirty & dirtyPackages ifTrue: [ - ^self confirm: 'There are both unsaved Packages', String newLineString, - 'and unsaved Changes to Cuis core.', String newLineString, - 'If you continue, all unsaved changes will be lost.', String newLineString, - 'Do you really want to exit Cuis without saving the image?' ]. - baseCSdirty ifTrue: [ - ^self confirm: 'Some ChangeSet for Cuis core have unsaved changes.', String newLineString, - 'If you continue, they would be lost.', String newLineString, - 'Do you really want to exit Cuis without saving the image?' ]. - dirtyPackages ifTrue: [ - ^self confirm: 'There are unsaved Packages.', String newLineString, - 'If you continue, their changes will be lost.', String newLineString, - 'Do you really want to exit Cuis without saving the image?' ]. - Preferences askConfirmationOnQuit ifTrue: [ - ^self confirm: 'Do you really want to exit Cuis without saving the image?' ]. - ^true! ! -!Preferences class methodsFor: 'personalization' stamp: 'jmv 8/20/2021 11:57:15'! - askConfirmationOnQuit - ^ self - valueOfFlag: #askConfirmationOnQuit - ifAbsent: [ true ].! ! -!TheWorldMenu methodsFor: 'commands' stamp: 'jmv 8/20/2021 11:57:53' prior: 50598897! - quitSession - Smalltalk askConfirmationOnQuit ifFalse: [ ^ self ]. - Smalltalk quit! ! - -SystemDictionary removeSelector: #okayToDiscardUnsavedCode! - -!methodRemoval: SystemDictionary #okayToDiscardUnsavedCode stamp: 'Install-4777-askConfirmationOnQuit-preference-JuanVuletich-2021Aug20-11h41m-jmv.001.cs.st 8/20/2021 16:04:13'! -okayToDiscardUnsavedCode - "Answer true unless the user cancels quitting because of some warning given. - Smalltalk okayToDiscardUnsavedCode - " - | baseCSdirty dirtyPackages | - baseCSdirty _ ChangeSet allChangeSets anySatisfy: [ :any | any isForBaseSystem and: [ any hasUnsavedChanges ]]. - "dirtyPackages _ CodePackage installedPackages anySatisfy: [ :pck | pck hasUnsavedChanges ]." - dirtyPackages _ ChangeSet allChangeSets anySatisfy: [ :any | any codePackage notNil and: [ any hasUnsavedChanges ]]. - baseCSdirty & dirtyPackages ifTrue: [ - ^self confirm: 'There are both unsaved Packages', String newLineString, - 'and unsaved Changes to Cuis core.', String newLineString, - 'If you continue, all unsaved changes will be lost.', String newLineString, - 'Continue?' ]. - baseCSdirty ifTrue: [ - ^self confirm: 'Some ChangeSet for Cuis core have unsaved changes.', String newLineString, - 'If you continue, they would be lost.', String newLineString, - 'Continue?' ]. - dirtyPackages ifTrue: [ - ^self confirm: 'There are unsaved Packages.', String newLineString, - 'If you continue, their changes will be lost.', String newLineString, - 'Continue?' ]. - ^true! - -SystemDictionary removeSelector: #askConfirmationOnQuitDiscardingUnsavedCode! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4777-askConfirmationOnQuit-preference-JuanVuletich-2021Aug20-11h41m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4775] on 20 August 2021 at 12:00:08 pm'! -!Preferences class methodsFor: 'start up' stamp: 'jmv 8/20/2021 11:59:35' prior: 50540874! - checkLostChangesOnStartUp - ^ self - valueOfFlag: #checkLostChangesOnStartUp - ifAbsent: [ false ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4778-checkLostChangesOnStartUp-preference-defaultToFalse-JuanVuletich-2021Aug20-11h58m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4778] on 20 August 2021 at 12:33:23 pm'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 8/20/2021 12:23:03'! - saveAsNewReleaseAndQuit - "Save the image/changes using the next available version number. - This is usually only used to prepare updated Cuis images for distribution." - " - Smalltalk saveAsNewReleaseAndQuit - " - | fileName newName changesName systemVersion | - systemVersion _ SystemVersion current. - fileName _ String streamContents: [ :strm | - strm - nextPutAll: 'Cuis'; - print: systemVersion versionMajor; - nextPut: $.; - print: systemVersion versionMinor; - nextPut: $-; - print: systemVersion highestUpdate. - Smalltalk isSpur - ifTrue: [ - Smalltalk wordSize = 4 ifTrue: [ - strm nextPutAll: '-32' ]] - ifFalse: [ - strm nextPutAll: '-v3' ]]. - newName _ fileName, '.image'. - (DirectoryEntry smalltalkImageDirectory // newName) exists ifTrue: [ - newName _ DirectoryEntry smalltalkImageDirectory - nextNameFor: fileName - extension: 'image' ]. - changesName _ self fullNameForChangesNamed: newName. - "Check to see if there is a .changes file that would cause a problem if we saved a new .image file with the new version number" - changesName asFileEntry exists ifTrue: [ - ^ self inform: -'There is already .changes file of the desired name, -', changesName, ' -curiously already present, even though there is no -corresponding .image file. -Please remedy manually and then repeat your request.' ]. - "Try to clear all user state, including all class vars, preferences, etc" - self saveAndQuitAs: newName clearAllClassState: true! ! -!TheWorldMenu class methodsFor: 'menu building' stamp: 'jmv 8/20/2021 12:32:32' prior: 50598903! - worldMenuOptions - - ^`{{ - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Open...'. - #selector -> #openOpenMenu. - #icon -> #openIcon. - #balloonText -> 'Submenu to open various system tools'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'New morph...'. - #selector -> #newMorph. - #icon -> #morphsIcon. - #balloonText -> 'Offers a variety of ways to create new objects'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Preferences...'. - #selector -> #openPreferencesMenu. - #icon -> #preferencesIcon. - #balloonText -> 'Opens a menu offering many controls over appearance and system preferences.'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'Windows...'. - #selector -> #openWindowsMenu. - #icon -> #windowIcon. - #balloonText -> 'Manage open windows'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 50. - #label -> 'Help...'. - #selector -> #openHelpMenu. - #icon -> #helpIcon. - #balloonText -> 'Opens a menu of useful items for updating the system, determining what version you are running, and much else'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Changes...'. - #selector -> #openChangesMenu. - #icon -> #changesIcon. - #balloonText -> 'Opens a menu of useful tools for dealing with changes'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Debug...'. - #selector -> #openDebugMenu. - #icon -> #debugIcon. - #balloonText -> 'a menu of debugging items'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'Restore Display'. - #object -> #myWorld. - #selector -> #restoreDisplay. - #icon -> #displayIcon. - #balloonText -> 'Repaint the screen -- useful for removing unwanted display artifacts, lingering cursors, etc.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Save Image'. - #object -> Smalltalk. - #selector -> #saveImage. - #icon -> #saveIcon. - #balloonText -> 'Save the current version of the image on disk. Overwrite existing file.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Save as...'. - #object -> Smalltalk. - #selector -> #saveAs. - #icon -> #saveAsIcon. - #balloonText -> 'Save the current version of the image on disk under a new name.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'Save Release and Quit'. - #object -> Smalltalk. - #selector -> #saveAsNewReleaseAndQuit. - #icon -> #saveAsNewVersionIcon. - #balloonText -> ('Save as a new release of Cuis.\', - 'Clear all user preferences and user state (class vars).\', - 'Use an updated version-stamped name\', - 'and save the image with that name on disk.\', - 'Quit Cuis.') withNewLines. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 40. - #label -> 'Save and Quit'. - #object -> Smalltalk. - #selector -> #saveAndQuit. - #icon -> #saveAndQuitIcon. - #balloonText -> 'Save the image and quit out of Cuis. Overwrite existing file.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 50. - #label -> 'Quit without saving'. - #selector -> #quitSession. - #icon -> #quitIcon. - #balloonText -> ('Quit out of Cuis without saving the image.\', - 'Ask for confirmation if there are unsaved changes.') withNewLines. - } asDictionary. -}`! ! - -SystemDictionary removeSelector: #saveAsNewVersion! - -!methodRemoval: SystemDictionary #saveAsNewVersion stamp: 'Install-4779-saveReleaseAndQuit-JuanVuletich-2021Aug20-12h29m-jmv.001.cs.st 8/20/2021 16:04:13'! -saveAsNewVersion - "Save the image/changes using the next available version number. - This is usually only used to prepare updated Cuis images for distribution." - " - Smalltalk saveAsNewVersion - " - | fileName newName changesName systemVersion | - systemVersion _ SystemVersion current. - fileName _ String streamContents: [ :strm | - strm - nextPutAll: 'Cuis'; - print: systemVersion versionMajor; - nextPut: $.; - print: systemVersion versionMinor; - nextPut: $-; - print: systemVersion highestUpdate. - Smalltalk isSpur - ifTrue: [ - Smalltalk wordSize = 4 ifTrue: [ - strm nextPutAll: '-32' ]] - ifFalse: [ - strm nextPutAll: '-v3' ]]. - newName _ fileName, '.image'. - (DirectoryEntry smalltalkImageDirectory // newName) exists ifTrue: [ - newName _ DirectoryEntry smalltalkImageDirectory - nextNameFor: fileName - extension: 'image' ]. - changesName _ self fullNameForChangesNamed: newName. - "Check to see if there is a .changes file that would cause a problem if we saved a new .image file with the new version number" - changesName asFileEntry exists ifTrue: [ - ^ self inform: -'There is already .changes file of the desired name, -', changesName, ' -curiously already present, even though there is no -corresponding .image file. -Please remedy manually and then repeat your request.' ]. - "Try to clear all user state, including all class vars, preferences, etc" - self saveAs: newName clearAllClassState: true! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4779-saveReleaseAndQuit-JuanVuletich-2021Aug20-12h29m-jmv.001.cs.st----! - -----QUIT----(20 August 2021 16:04:17) Cuis5.0-4779-v3.image priorSource: 8406131! - -----STARTUP---- (24 August 2021 17:32:49) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4779-v3.image! - - -'From Cuis 5.0 [latest update: #4779] on 20 August 2021 at 8:06:06 pm'! -!AffineTransformation methodsFor: 'modifying' stamp: 'jmv 8/20/2021 20:03:28' prior: 16778588! - italizing - "a little shear - Answer the modified object. In this implementation it is self, but some classes of transformations, - more restricted ones (like MorphicTranslation) could require the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself." - - self a12: self a12 + (self scale*0.2). - ^self! ! -!AffineTransformation methodsFor: 'modifying' stamp: 'jmv 8/20/2021 20:03:33' prior: 16778603! - italizing2 - "a little shear - Answer the modified object. In this implementation it is self, but some classes of transformations, - more restricted ones (like MorphicTranslation) could require the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself." - - self a12: self a12 - (self scale*0.2). - self setTranslation: (self scale*0.2)@0 + self translation. - ^self! ! -!AffineTransformation methodsFor: 'modifying' stamp: 'jmv 8/20/2021 20:03:39' prior: 50536943! - rotatedBy: radians - "rotate the receiver by radians angle. - Answer the modified object. In this implementation it is self, but some classes of transformations, - more restricted ones (like MorphicTranslation) could require the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself." - - | s c a11 a12 a21 a22 | - s _ radians sin. - c _ radians cos. - a11 _ self a11. - a12 _ self a12. - a21 _ self a21. - a22 _ self a22. - self a11: (c * a11) - (s * a21). - self a12: (c * a12) - (s * a22). - self a21: (s * a11) + (c * a21). - self a22: (s * a12) + (c * a22). - ^ self! ! -!AffineTransformation methodsFor: 'modifying' stamp: 'jmv 8/20/2021 20:03:48' prior: 50558746! - scaledBy: aPointOrNumber - "Multiply by a scale. - Argument can be a point, applying different scaling in x and in y directions. - Keep the transformed position of 0@0, i.e. don't change offset. - - Answer the modified object. In this implementation it is self, but some classes of transformations, - more restricted ones (like MorphicTranslation) could require the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself." - - | pt sx sy | - pt _ aPointOrNumber asPoint. - sx _ pt x. - sy _ pt y. - self a11: self a11 * sx. - self a12: self a12 * sx. - self a21: self a21 * sy. - self a22: self a22 * sy. - ^ self! ! -!AffineTransformation methodsFor: 'modifying' stamp: 'jmv 8/20/2021 20:04:07' prior: 50536967! -scaledByNumber: aNumber rotatedBy: radians - "rotate the receiver by radians angle. Also scale by aNumber. - Note: the scale factor is a number, not a point. Therefore, the same scale is applied in all directions. - This means that there is no difference between scaling then rotating and rotating then scaling. - - Answer the modified object. In this implementation it is self, but some classes of transformations, - more restricted ones (like MorphicTranslation) could require the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself." - - | s c a11 a12 a21 a22 | - s _ radians sin. - c _ radians cos. - a11 _ self a11 * aNumber. - a12 _ self a12 * aNumber. - a21 _ self a21 * aNumber. - a22 _ self a22 * aNumber. - self a11: (c * a11) - (s * a21). - self a12: (c * a12) - (s * a22). - self a21: (s * a11) + (c * a21). - self a22: (s * a12) + (c * a22). - ^self! ! -!AffineTransformation methodsFor: 'modifying' stamp: 'jmv 8/20/2021 20:04:12' prior: 16778708! - translatedBy: aPoint - "add an offset in the receiver - - Answer the modified object. In this implementation it is self, but some classes of transformations, - more restricted ones (like MorphicTranslation) could require the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself." - - | pt | - pt _ aPoint asPoint. - self a13: self a13 + pt x. - self a23: self a23 + pt y. - ^ self! ! -!AffineTransformation methodsFor: 'modifying' stamp: 'jmv 8/20/2021 20:05:10' prior: 16778726! - withRotation: radians scale: scale - "Set rotation and scaling according to parameters. - Answer the modified object. In this implementation it is self, but some classes of transformations, - more restricted ones (like MorphicTranslation) could require the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself." - - self setRadians: radians scale: scale. - ^self! ! -!AffineTransformation methodsFor: 'modifying' stamp: 'jmv 8/20/2021 20:05:26' prior: 50558587! - withScale: scale - "Set scaling according to parameters. - Answer the modified object. In this implementation it is self, but some classes of transformations, - more restricted ones (like MorphicTranslation) could require the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself." - - self scaledBy: scale / self scale. - ^self! ! -!AffineTransformation methodsFor: 'modifying' stamp: 'jmv 8/20/2021 20:04:16' prior: 16778742! - withTranslation: aPoint - "set an offset in the receiver - - Answer the modified object. In this implementation it is self, but some classes of transformations, - more restricted ones (like a possible NullTransformation or sch) could require the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself." - - | pt | - pt _ aPoint asPoint. - self a13: pt x. - self a23: pt y. - ^ self! ! -!AffineTransformation methodsFor: 'modifying' stamp: 'jmv 8/20/2021 20:05:41' prior: 16778760! - withYAxisNegated - "Swap inneer point Y sign. - Make y increment upwards. - This makes the any matrix transform from standard mathematical coordinates - to standard display coordinates (in addition to the transform it was already doing) - - Answer the modified object. In this implementation it is self, but some classes of transformations, - more restricted ones (like MorphicTranslation) could require the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself." - - self a12: self a12 negated. - self a22: self a22 negated. - ^self! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4780-SomeMethodComments-JuanVuletich-2021Aug20-20h03m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4780] on 20 August 2021 at 8:45:36 pm'! -!MorphicEvent methodsFor: 'testing' stamp: 'jmv 8/20/2021 20:44:30'! - isMouseMove - ^false! ! -!HandMorph methodsFor: 'event handling' stamp: 'jmv 8/20/2021 20:33:25' prior: 50565190! - processEventQueue - "Process user input events from the local input devices. - Answer true if any event was handled (but ignore MouseMove)" - - | evt evtBuf type hadAny mcs hadAnyMouseEvent hadAnyMouseMoveEvent | - mcs _ mouseClickState. - hadAny _ false. - hadAnyMouseEvent _ false. - hadAnyMouseMoveEvent _ false. - [ (evtBuf := Sensor nextEvent) isNil ] whileFalse: [ - type _ evtBuf first. - evt _ self createEventFrom: evtBuf ofType: type. - evt ifNotNil: [ - "Finally, handle it. But process only up to one mouseMove per cycle. Discard the rest." - (evt isMouseMove and: [ hadAnyMouseMoveEvent ]) ifFalse: [ - self startEventDispatch: evt. - hadAny _ true. - evt isMouse ifTrue: [ - hadAnyMouseEvent _ true. - evt isMouseMove ifTrue: [ - hadAnyMouseMoveEvent _ true ]]]]]. - hadAnyMouseEvent ifFalse: [ - mcs - ifNotNil: [ - "No mouse events during this cycle. Make sure click states time out accordingly" - mcs - handleEvent: lastMouseEvent asMouseMove - from: self ]]. - ^hadAny! ! - -KeyboardEvent removeSelector: #isMouseMove! - -!methodRemoval: KeyboardEvent #isMouseMove stamp: 'Install-4781-JustOneMouseMovePerCycle-JuanVuletich-2021Aug20-20h44m-jmv.001.cs.st 8/24/2021 17:32:54'! -isMouseMove - ^false! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4781-JustOneMouseMovePerCycle-JuanVuletich-2021Aug20-20h44m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4781] on 20 August 2021 at 10:51:59 pm'! -!ClassDescription methodsFor: 'initialization' stamp: 'jmv 8/20/2021 22:47:36' prior: 50431384! -updateInstancesFrom: oldClass - "Recreate any existing instances of the argument, oldClass, as instances of - the receiver, which is a newly changed class. Permute variables as necessary, - and forward old instances to new instances.. Answer nil to defeat any clients - that expected the old behaviour of answering the array of old instances." - "ar 7/15/1999: The updating below is possibly dangerous. If there are any - contexts having an old instance as receiver it might crash the system if - the new receiver in which the context is executed has a different layout. - See bottom below for a simple example:" - | allInstances newMethod oldMethod selector | - allInstances _ oldClass allInstances. - allInstances notEmpty ifTrue: [ - Processor - processesDo: [ :p | ] - withStackFramestDo: [ :process :context | - (context receiver isKindOf: oldClass) ifTrue: [ - selector _ context method selector. - oldMethod _ oldClass lookupSelector: selector. - newMethod _ self lookupSelector: selector. - oldMethod = newMethod ifFalse: [ - MethodInCallStackToBecomeInvalid - signal: self class name, ' has some instance running #', selector, ' that would become invalid.' ]]] - runningProcessSearchStart: nil. - self updateInstances: allInstances asArray from: oldClass isMeta: self isMeta ]. - ^nil - -"This attempts to crash the VM by stepping off the end of an instance. - As the doctor says, do not do this." -" | crashingBlock class | - class := Object subclass: #CrashTestDummy - instanceVariableNames: 'instVar' - classVariableNames: '' - poolDictionaries: '' - category: 'Crash-Test'. - class compile:'instVar: value instVar := value'. - class compile:'crashingBlock ^[instVar]'. - crashingBlock := (class new) instVar: 42; crashingBlock. - Object subclass: #CrashTestDummy - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Crash-Test'. - crashingBlock value"! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4782-UpdateInstancesOptimization-JuanVuletich-2021Aug20-22h47m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4782] on 21 August 2021 at 2:35:24 pm'! -!WorldMorph methodsFor: 'stepping' stamp: 'jmv 8/21/2021 14:33:52' prior: 50551592! -runLocalStepMethods: nowTime - "Run morph 'step' methods whose time has come. Purge any morphs that are no longer in this world." - - | stepMessage | - [ stepList notEmpty and: [ (stepMessage _ stepList first) scheduledTime <= nowTime ]] - whileTrue: [ - (stepMessage receiver shouldGetStepsFrom: self) - ifFalse: [ - stepList remove: stepMessage ifAbsent: []] - ifTrue: [ - stepMessage valueAtTime: nowTime. - stepMessage rescheduleAfter: nowTime. - "We've just updated the scheduled time for stepMessage. - It might have been that stepMessage was removed altogether from stepList. - It also may be the case that stepList got added or removed other elements while on #valueAtTime: - Just reSort. It will be ok in any case." - stepList reSort ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4783-runLocalStepMethods-GeraldKilx-JuanVuletich-2021Aug21-14h32m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4782] on 21 August 2021 at 6:41:34 pm'! -!Inspector methodsFor: 'testing' stamp: 'HAW 8/21/2021 18:38:30'! - shouldPrintSelectionAsString - - ^ self selectionIndex = 0 or: [ self selectionIndex = 2 ]! ! -!Inspector methodsFor: 'selecting' stamp: 'HAW 8/21/2021 18:39:53' prior: 50594444! - selectionPrintString - "Returns the current selection as a string" - - ^self shouldPrintSelectionAsString - ifTrue: [ self selection ] - ifFalse: [ self safelyPrintWith: [ self selection printTextLimitedTo: self printStringLimit ] ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4784-InspectorFix-HernanWilkinson-2021Aug21-18h12m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4784] on 21 August 2021 at 8:10:52 pm'! -!HierarchicalListMorph methodsFor: 'private' stamp: 'jmv 11/14/2011 10:40' prior: 50599492! - addSubmorphsAfter: parentMorph fromCollection: aCollection allowSorting: sortBoolean - - | priorMorph morphList newCollection | - priorMorph _ nil. - newCollection _ (sortBoolean and: [sortingSelector notNil]) ifTrue: [ - aCollection asOrderedCollection sort: [ :a :b | - (a perform: sortingSelector) <= (b perform: sortingSelector)] - ] ifFalse: [ - aCollection - ]. - morphList _ OrderedCollection new. - newCollection do: [:item | - priorMorph _ self indentingItemClass basicNew - initWithContents: item - prior: priorMorph - forList: self - indentLevel: parentMorph indentLevel + 1. - morphList add: priorMorph. - ]. - scroller addAllMorphs: morphList after: parentMorph. - ^morphList - -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4785-RollbackFileListBreakageIn4775-JuanVuletich-2021Aug21-20h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4785] on 22 August 2021 at 12:26:01 pm'! -!Object methodsFor: 'printing' stamp: 'jmv 1/10/2014 22:53' prior: 50599470! - printString - "Answer a String whose characters are a description of the receiver. - If you want to print without a character limit, use fullPrintString. - - This description is to be meaningful for a Smalltalk programmer and usually includes - a hint on the class of the object. - - Usually you should not reimplement this method in subclasses, but #printOn: - - See the comments at: - #printString - #displayStringOrText - #asString - #storeString" - - ^ self printStringLimitedTo: 50000! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4786-Rollback-Object-printString-JuanVuletich-2021Aug22-12h25m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4786] on 22 August 2021 at 1:47:52 pm'! -!Object methodsFor: 'printing' stamp: 'jmv 8/22/2021 12:47:48'! - shortPrintString - "Answer a String whose characters are a description of the receiver. - This is a short one, good for showing users (for example, in ObjectExplorers). - If you want to print without a character limit, use fullPrintString. - - This description is to be meaningful for a Smalltalk programmer and usually includes - a hint on the class of the object. - - Usually you should not reimplement this method in subclasses, but #printOn: - - See the comments at: - #printString - #displayStringOrText - #asString - #storeString" - - ^ self printStringLimitedTo: 64.! ! -!Inspector methodsFor: 'user interface support' stamp: 'jmv 8/22/2021 12:47:43' prior: 50570156! - displayLabel - - | label | - object isObject ifFalse: [^ 'Inspect: ', self objectClass name]. - label := [object shortPrintString] - on: UnhandledError - do: [:ex | ex return: self objectClass printString, ' (printing failed)']. - "Note this is ambiguous: what happens with (Array with: Array)?" - (label includesSubString: self objectClass name) ifTrue: [^'Inspect: ', label]. - ^ 'Inspect: ', self objectClass name, ': ', label! ! -!MethodContext methodsFor: 'printing' stamp: 'jmv 8/22/2021 13:25:20' prior: 16871650 overrides: 16824580! - printDetails: strm - "Put my class>>selector and instance variables and arguments and temporaries on the stream. Protect against errors during printing." - - | pe str pos | - self printOn: strm. - strm newLine. - strm tab; nextPutAll: 'Receiver: '. - pe _ '<>'. - strm nextPutAll: ([receiver shortPrintString] ifError: [:err :rcvr | pe]). - - strm newLine; tab; nextPutAll: 'Arguments and temporary variables: '; newLine. - str _ [(self tempsAndValuesLimitedTo: 80 indent: 2) - padded: #right to: 1 with: $x] ifError: [:err :rcvr | pe]. - strm nextPutAll: (str allButLast). - - strm newLine; tab; nextPutAll: 'Receiver''s instance variables: '; newLine. - pos _ strm position. - [receiver longPrintOn: strm limitedTo: 80 indent: 2] ifError: [:err :rcvr | - strm nextPutAll: pe]. - pos = strm position ifTrue: ["normal printString for an Array (it has no inst vars)" - strm nextPutAll: ([receiver shortPrintString] ifError: [:err :rcvr | pe])]. - strm peekLast isLineSeparator ifFalse: [strm newLine].! ! -!Morph methodsFor: 'e-toy support' stamp: 'jmv 8/22/2021 13:23:01' prior: 16874440! - unlockOneSubpart - | unlockables aMenu reply | - unlockables _ self submorphs select: - [ :m | m isLocked]. - unlockables size <= 1 ifTrue: [^ self unlockContents]. - aMenu _ SelectionMenu labelList: (unlockables collect: [:m | m shortPrintString]) selections: unlockables. - reply _ aMenu startUpWithCaption: 'Who should be be unlocked?'. - reply ifNil: [^ self]. - reply unlock.! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 8/22/2021 13:22:30' prior: 50514683! - editBalloonHelpContent: aString - self - request: 'Edit the balloon help text for ' , self shortPrintString - initialAnswer: (aString ifNil: [self noHelpString] ifNotNil: [aString]) - do: [:reply| - (reply isEmpty or: [reply asString = self noHelpString]) - ifTrue: [self setBalloonText: nil] - ifFalse: [self setBalloonText: reply]]! ! -!Morph methodsFor: 'menus' stamp: 'jmv 8/22/2021 13:25:37' prior: 50545746! - addHaloActionsTo: aMenu - "Add items to aMenu representing actions requestable via halo" - - | subMenu | - subMenu := MenuMorph new defaultTarget: self. - subMenu addTitle: self shortPrintString. - subMenu addStayUpIcons. - subMenu addLine. - (subMenu add: 'delete' action: #dismissViaHalo) - setBalloonText: 'Delete this object -- warning -- can be destructive!!' . - self maybeAddCollapseItemTo: subMenu. - (subMenu add: 'grab' action: #openInHand) - setBalloonText: 'Pick this object up -- warning, since this removes it from its container, it can have adverse effects.' . - subMenu addLine. - (subMenu add: 'duplicate' action: #maybeDuplicateMorph) - setBalloonText: 'Hand me a copy of this object'. - (subMenu - add: 'set color' - target: self - action: #changeColor) - setBalloonText: 'Change the color of this object'. - (subMenu - add: 'inspect' - target: self - action: #inspect) - setBalloonText: 'Open an Inspector on this object'. - aMenu add: 'halo actions...' subMenu: subMenu! ! -!Morph methodsFor: 'menus' stamp: 'jmv 8/22/2021 13:26:12' prior: 16876204! - addStandardHaloMenuItemsTo: aMenu hand: aHandMorph - "Add standard halo items to the menu" - - | unlockables | - - self isWorldMorph ifTrue: - [^ self addWorldHaloMenuItemsTo: aMenu hand: aHandMorph]. - - aMenu add: 'send to back' action: #goBehind. - aMenu add: 'bring to front' action: #comeToFront. - self addEmbeddingMenuItemsTo: aMenu hand: aHandMorph. - aMenu addLine. - - self addColorMenuItems: aMenu hand: aHandMorph. - self addHaloActionsTo: aMenu. - aMenu addLine. - self addToggleItemsToHaloMenu: aMenu. - aMenu addLine. - self addCopyItemsTo: aMenu. - self addExportMenuItems: aMenu hand: aHandMorph. - self addDebuggingItemsTo: aMenu hand: aHandMorph. - - aMenu addLine. - aMenu defaultTarget: self. - - aMenu addLine. - - unlockables _ self submorphs select: - [:m | m isLocked]. - unlockables size = 1 ifTrue: - [aMenu - add: ('unlock "{1}"' format: unlockables first shortPrintString) - action: #unlockContents]. - unlockables size > 1 ifTrue: - [aMenu add: 'unlock all contents' action: #unlockContents. - aMenu add: 'unlock...' action: #unlockOneSubpart]. - - aMenu defaultTarget: aHandMorph. -! ! -!Morph methodsFor: 'menus' stamp: 'jmv 8/22/2021 13:22:15' prior: 16876241! - addTitleForHaloMenu: aMenu - aMenu addTitle: self shortPrintString.! ! -!WorldMorph methodsFor: 'menu & halo' stamp: 'jmv 8/22/2021 13:23:11' prior: 50553231! - addWorldHaloMenuItemsTo: aMenu hand: aHandMorph - "Add standard halo items to the menu, given that the receiver is a World" - - | unlockables | - self addColorMenuItems: aMenu hand: aHandMorph. - -" aMenu addLine. - self addWorldToggleItemsToHaloMenu: aMenu." - aMenu addLine. - self addCopyItemsTo: aMenu. - self addExportMenuItems: aMenu hand: aHandMorph. - - self addDebuggingItemsTo: aMenu hand: aHandMorph. - - aMenu addLine. - aMenu defaultTarget: self. - - aMenu addLine. - - unlockables _ self submorphs select: - [ :m | m isLocked]. - unlockables size = 1 ifTrue: [ - aMenu add: ('unlock "{1}"' format:{unlockables first shortPrintString})action: #unlockContents]. - unlockables size > 1 ifTrue: [ - aMenu add: 'unlock all contents' action: #unlockContents. - aMenu add: 'unlock...' action: #unlockOneSubpart]. - - aMenu defaultTarget: aHandMorph. -! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 8/22/2021 13:23:24' prior: 50596341! - addHandles: aDisplayRectangle - "update my size. owner is world, therefore owner coordinates are Display coordinates." - - self morphPosition: aDisplayRectangle topLeft extent: aDisplayRectangle extent. - haloBox _ self handlesBox. - target addHandlesTo: self box: haloBox. - self addNameString: target shortPrintString. - self redrawNeeded.! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 8/22/2021 13:23:56' prior: 50577118! - doDebug: evt with: menuHandle - "Ask hand to invoke the a debugging menu for my inner target. If shift key is down, immediately put up an inspector on the inner target" - - | menu | - evt hand obtainHalo: self. - evt shiftPressed ifTrue: [ - ^ target inspect]. - - menu _ target buildDebugMenu: evt hand. - menu addTitle: target shortPrintString. - menu popUpInWorld: self world! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 8/22/2021 13:24:15' prior: 50559180! - doDup: evt with: dupHandle - "Ask hand to duplicate my target." - - | hand positionInHandCoordinates | - target okayToDuplicate ifFalse: [^ self]. - hand _ evt hand. - positionInHandCoordinates _ target morphPositionInWorld - hand morphPositionInWorld. - "Duplicate has no meaningful position, as it is not in the world. Grab position from original!!" - target _ target duplicateMorph: evt. - self addNameString: target shortPrintString. - hand - obtainHalo: self; - grabMorph: target delta: positionInHandCoordinates! ! -!ObjectExplorerWindow methodsFor: 'GUI building' stamp: 'jmv 8/22/2021 12:48:02' prior: 50455848! - buildMorphicWindow - - | textMorph | - listMorph _ HierarchicalListMorph - model: model - listGetter: #getList - indexGetter: #getCurrentSelection - indexSetter: #noteNewSelection: - mainView: self - menuGetter: #genericMenu - keystrokeAction: #explorerKey:from:. - listMorph autoDeselect: false. - listMorph doubleClickSelector: #inspectSelection. - textMorph _ ((TextModelMorph textProvider: model) - askBeforeDiscardingEdits: false; - emptyTextDisplayMessage: 'Smalltalk expression (self is selected item)'). - self layoutMorph - addMorph: listMorph proportionalHeight: 0.8; - addAdjusterAndMorph: textMorph proportionalHeight: 0.2. - self setLabel: model rootObject shortPrintString.! ! -!ObjectExplorerWrapper methodsFor: 'converting' stamp: 'jmv 8/22/2021 12:33:32' prior: 16883557 overrides: 16864919! - asString - | explorerString | - explorerString _ [ item shortPrintString ] - on: UnhandledError - do: [:ex | ex return: '']. - ^itemName , ': ' , explorerString :: withBlanksCondensed! ! -!TestCase methodsFor: 'assertions' stamp: 'jmv 8/22/2021 13:26:49' prior: 16927611! - comparingStringBetween: expected and: actual - ^ String streamContents: [:stream | - stream - nextPutAll: 'Expected '; - nextPutAll: expected shortPrintString; - nextPutAll: ' but was '; - nextPutAll: actual shortPrintString; - nextPutAll: '.' - ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4787-shortPrintString-InInspectosAndExplorers-JuanVuletich-2021Aug22-13h47m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4787] on 22 August 2021 at 1:51:43 pm'! -!LargePositiveInteger methodsFor: 'testing' stamp: 'jmv 8/22/2021 13:50:42' overrides: 16859514! -hasContentsInExplorer - ^true! ! -!Collection methodsFor: 'testing' stamp: 'jmv 8/22/2021 13:42:46' overrides: 16882664! - hasContentsInExplorer - - ^self class isPointers and: [ self size between: 1 and: 100 ]! ! - -Dictionary removeSelector: #hasContentsInExplorer! - -!methodRemoval: Dictionary #hasContentsInExplorer stamp: 'Install-4788-Explorers-DontExpandLargeCollections-JuanVuletich-2021Aug22-13h49m-jmv.001.cs.st 8/24/2021 17:32:54'! -hasContentsInExplorer - - ^self isEmpty not! - -Set removeSelector: #hasContentsInExplorer! - -!methodRemoval: Set #hasContentsInExplorer stamp: 'Install-4788-Explorers-DontExpandLargeCollections-JuanVuletich-2021Aug22-13h49m-jmv.001.cs.st 8/24/2021 17:32:54'! -hasContentsInExplorer - - ^self notEmpty! - -OrderedCollection removeSelector: #hasContentsInExplorer! - -!methodRemoval: OrderedCollection #hasContentsInExplorer stamp: 'Install-4788-Explorers-DontExpandLargeCollections-JuanVuletich-2021Aug22-13h49m-jmv.001.cs.st 8/24/2021 17:32:54'! -hasContentsInExplorer - - ^self isEmpty not! - -Integer removeSelector: #hasContentsInExplorer! - -!methodRemoval: Integer #hasContentsInExplorer stamp: 'Install-4788-Explorers-DontExpandLargeCollections-JuanVuletich-2021Aug22-13h49m-jmv.001.cs.st 8/24/2021 17:32:54'! -hasContentsInExplorer - ^true! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4788-Explorers-DontExpandLargeCollections-JuanVuletich-2021Aug22-13h49m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4788] on 22 August 2021 at 2:12:35 pm'! -!TextModel methodsFor: 'object serialization' stamp: 'jmv 8/22/2021 13:55:14' prior: 16933867 overrides: 16881985! - convertToCurrentVersion: varDict refStream: smartRefStrm - - "Maybe old instances won't have this variable set." - undoRedoCommands ifNil: [ - undoRedoCommands _ ReadWriteStream on: #() ]! ! -!TextModel methodsFor: 'initialization' stamp: 'jmv 8/22/2021 13:55:23' prior: 16933876! - flushUndoRedoCommands - - undoRedoCommands _ ReadWriteStream on: #(). - lastEditTimeStamp _ nil! ! -!TextModel methodsFor: 'initialization' stamp: 'jmv 8/22/2021 13:55:29' prior: 16933882 overrides: 16896425! - initialize - "Initialize the state of the receiver with its default contents." - - actualContents _ '' asText. - undoRedoCommands _ ReadWriteStream on: #(). - lastEditTimeStamp _ nil! ! -!TextModel methodsFor: 'copying' stamp: 'jmv 8/22/2021 13:55:34' prior: 16933898 overrides: 16777570! - postCopy - super postCopy. - actualContents _ actualContents copy. - undoRedoCommands _ ReadWriteStream on: #(). - lastEditTimeStamp _ nil! ! -!PluggableTextModel methodsFor: 'initialization' stamp: 'jmv 8/22/2021 13:55:38' prior: 16890154! - initWith: aTextProvider - "aTextProvider can be a kind of TextProvider, or perhaps a more exotic object, like an ObjectExplorer or a TranscriptStream." - - textProvider _ aTextProvider. - undoRedoCommands _ ReadWriteStream on: #(). - lastEditTimeStamp _ nil! ! -!TimeProfileBrowser methodsFor: 'private' stamp: 'jmv 8/22/2021 13:56:25' prior: 16937804! - runBlock: aBlock -" - TimeProfileBrowser spyOn: [20 timesRepeat: - [Transcript show: 100 factorial printString]] -" - | result linesStream talliesStream textStream | - - tally := AndreasSystemProfiler new. - tally observedProcess: Processor activeProcess. - result := tally spyOn: aBlock. - - textStream _ DummyStream on: nil. - linesStream _ WriteStream on: #(). - talliesStream _ WriteStream on: #(). - - tally reportTextOn: textStream linesOn: linesStream talliesOn: talliesStream. - self initializeMessageList: linesStream contents talliesList: talliesStream contents. - - self changed: #messageList. - self changed: #messageListIndex. - self triggerEvent: #decorateButtons. - ^result! ! -!UndefinedObject methodsFor: 'class hierarchy' stamp: 'jmv 8/22/2021 14:07:11' prior: 16940179! - subclasses - "Return all the subclasses of nil" - - ^Array streamContents: [ :classList | - self subclassesDo: [ :class | classList nextPut: class ]].! ! -!Categorizer methodsFor: 'accessing' stamp: 'jmv 8/22/2021 13:57:47' prior: 16795624! - removeCategory: cat - "Remove the category named, cat. Create an error notificiation if the - category has any elements in it." - - | index lastStop | - index _ categoryArray indexOf: cat ifAbsent: [^self]. - lastStop _ - index = 1 - ifTrue: [0] - ifFalse: [categoryStops at: index - 1]. - (categoryStops at: index) - lastStop > 0 - ifTrue: [^self error: 'cannot remove non-empty category']. - categoryArray _ categoryArray copyReplaceFrom: index to: index with: #(). - categoryStops _ categoryStops copyReplaceFrom: index to: index with: #(). - categoryArray size = 0 - ifTrue: - [categoryArray _ Array with: Default. - categoryStops _ Array with: 0] -! ! -!WordArray class methodsFor: 'as yet unclassified' stamp: 'jmv 8/22/2021 13:58:10' prior: 16945304! - 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 _ ReadWriteStream on: #[]. - - 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 _ ReadWriteStream 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 printStringBase: 16] - } - ]. - ]. - ^answer explore! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 8/22/2021 14:01:34' prior: 50365955! - obsoleteMethodReferences - " - Smalltalk obsoleteMethodReferences - Smalltalk browseObsoleteMethodReferences - Open a browser on all referenced behaviors that are obsolete" - - | obsClasses obsRefs | - ^Array streamContents: [ :references | - obsClasses _ self obsoleteBehaviors. - 'Scanning for methods referencing obsolete classes' displayProgressAt: Sensor mousePoint - from: 1 to: obsClasses size during: [ :barBlock | - obsClasses keysAndValuesDo: [ :index :each | - barBlock value: index. - obsRefs _ self pointersTo: each except: obsClasses. - obsRefs do: [ :ref | - "Figure out if it may be a global" - (ref isVariableBinding and: [ ref key isString "or Symbol" ]) ifTrue: [ - (self pointersTo: ref) do: [ :meth | - (meth is: #CompiledMethod) ifTrue: [ - meth methodReference ifNotNil: [ :mref | - (mref isValid and: [ mref compiledMethod == meth]) ifTrue: [ - references nextPut: mref ]]]]]]]]].! ! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jmv 8/22/2021 13:56:35' prior: 16921000! - listBuiltinModules - "Smalltalk listBuiltinModules" - "Return a list of all builtin modules (e.g., plugins). Builtin plugins are those that are compiled with the VM directly, as opposed to plugins residing in an external shared library. The list will include all builtin plugins regardless of whether they are currently loaded or not. Note that the list returned is not sorted!!" - | modules index name | - modules _ WriteStream on: #(). - index _ 1. - [true] whileTrue:[ - name _ self listBuiltinModule: index. - name ifNil:[^modules contents]. - modules nextPut: name. - index _ index + 1. - ].! ! -!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jmv 8/22/2021 13:56:40' prior: 16921029! - listLoadedModules - "Smalltalk listLoadedModules" - "Return a list of all currently loaded modules (e.g., plugins). Loaded modules are those that currently in use (e.g., active). The list returned will contain all currently active modules regardless of whether they're builtin (that is compiled with the VM) or external (e.g., residing in some external shared library). Note that the returned list is not sorted!!" - | modules index name | - modules _ WriteStream on: #(). - index _ 1. - [true] whileTrue:[ - name _ self listLoadedModule: index. - name ifNil:[^modules contents]. - modules nextPut: name. - index _ index + 1. - ].! ! -!ReadWriteStream methodsFor: 'accessing' stamp: 'jmv 8/22/2021 13:55:58' prior: 16898123! - truncateAtPosition - "Truncate the receiver at current position. - For example, this should evaluate to true: - | s | - s _ ReadWriteStream on: #(). - s nextPutAll: 'abcdefg'. - s reset. - s next; next. - s nextPut: $z. - s truncateAtPosition. - s atEnd - " - readLimit _ position! ! -!Parser methodsFor: 'primitives' stamp: 'jmv 8/22/2021 14:01:58' prior: 50333454! - externalFunctionDeclaration - "Parse the function declaration for a call to an external library." - | descriptorClass callType modifier retType externalName args argType module fn | - descriptorClass := Smalltalk at: #ExternalFunction ifAbsent: [ ^ false ]. - callType := descriptorClass callingConventionFor: here. - callType == nil ifTrue:[^false]. - [modifier := descriptorClass callingConventionModifierFor: token. - modifier notNil] whileTrue: - [self advance. - callType := callType bitOr: modifier]. - "Parse return type" - self advance. - retType := self externalType: descriptorClass. - retType == nil ifTrue: [^self expected:'return type']. - "Parse function name or index" - externalName := here. - (self match: #string) - ifTrue:[externalName := externalName asSymbol] - ifFalse:[(self match:#number) ifFalse:[^self expected:'function name or index']]. - (self match: #leftParenthesis) ifFalse:[^self expected:'argument list']. - args := WriteStream on: #(). - [self match: #rightParenthesis] whileFalse:[ - argType := self externalType: descriptorClass. - argType == nil ifTrue:[^self expected:'argument']. - argType isVoid & argType isPointerType not ifFalse:[args nextPut: argType]]. - (self matchToken: 'module:') ifTrue:[ - module := here. - (self match: #string) ifFalse:[^self expected: 'String']. - module := module asSymbol]. - Smalltalk at: #ExternalLibraryFunction ifPresent:[:xfn| - fn := xfn name: externalName - module: module - callType: callType - returnType: retType - argumentTypes: args contents. - self allocateLiteral: fn]. - (self matchToken: 'error:') - ifTrue: - [| errorCodeVariable | - errorCodeVariable := here. - (hereType == #string - or: [hereType == #word]) ifFalse:[^self expected: 'error code (a variable or string)']. - self advance. - self addPragma: (Pragma keyword: #primitive:error: arguments: (Array with: 120 with: errorCodeVariable)). - fn ifNotNil: [fn setErrorCodeName: errorCodeVariable]] - ifFalse: - [self addPragma: (Pragma keyword: #primitive: arguments: #(120))]. - ^true! ! -!SmalltalkEditor methodsFor: 'explain' stamp: 'jmv 8/22/2021 14:10:26' prior: 16910169! - explainClass: symbol - "Is symbol a class variable or a pool variable?" - | provider class reply classes | - provider _ self codeProvider. - (provider respondsTo: #selectedClassOrMetaClass) - ifFalse: [^ nil]. - (class _ provider selectedClassOrMetaClass) ifNil: [^ nil]. - "no class is selected" - (class isKindOf: Metaclass) - ifTrue: [class _ class soleInstance]. - classes _ (Array with: class) - , class allSuperclasses. - "class variables" - reply _ classes detect: [:each | (each classVarNames detect: [:name | symbol = name] - ifNone: nil) - notNil] - ifNone: nil. - reply ifNotNil: [ - ^ String streamContents: [:str | - str - nextPutAll: symbol; - nextPutAll: ' is a class variable, defined in class '; - nextPutAll: reply printString, '\' withNewLines; - nextPutAll: 'Smalltalk browseAllCallsOn: ('; - nextPutAll: reply printString; - nextPutAll: ' classPool associationAt: #'; - nextPutAll: symbol; - nextPutAll: ').']]. - "pool variables" - classes do: [:each | (each sharedPools - detect: [:pool | (pool includesKey: symbol) - and: - [reply _ pool. - true]] - ifNone: nil) - notNil]. - reply - ifNil: [(Undeclared includesKey: symbol) - ifTrue: [ - ^ String streamContents: [:str | - str - nextPutAll: symbol; - nextPutAll: ' is an undeclared variable.'; - nextPutAll: 'Smalltalk browseAllCallsOn: (Undeclared associationAt: #'; - nextPutAll: symbol; - nextPutAll: ').']]] - ifNotNil: - [classes _ Array streamContents: [ :strm | - Smalltalk - allBehaviorsDo: [:each | (each sharedPools - detect: - [:pool | - pool == reply] - ifNone: nil) - notNil ifTrue: [strm nextPut: each]]]. - "Perhaps not print whole list of classes if too long. (unlikely)" - ^ String streamContents: [:str | - str - nextPutAll: symbol; - nextPutAll: ' is a pool variable from the pool '; - nextPutAll: (Smalltalk keyAtIdentityValue: reply) asString; - nextPutAll: ', which is used by the following classes '; - nextPutAll: classes printString , '\' withNewLines; - nextPutAll: 'Smalltalk browseAllCallsOn: ('; - nextPutAll: (Smalltalk keyAtIdentityValue: reply) asString; - nextPutAll: ' bindingOf: #'; - nextPutAll: symbol; - nextPutAll: ').']]. - ^ nil! ! -!TheWorldMenu methodsFor: 'commands' stamp: 'jmv 8/22/2021 14:12:10' prior: 50343932! - splitNewMorphList: list depth: d - | middle c prev next | - d <= 0 ifTrue: [ ^ Array with: list ]. - middle := list size // 2 + 1. - c := (list at: middle) name first: 3. - prev := middle - 1. - [ - prev > 0 and: [ ((list at: prev) name first: 3) = c ]] whileTrue: [ prev := prev - 1 ]. - next := middle + 1. - [ - next <= list size and: [ ((list at: next) name first: 3) = c ]] whileTrue: [ next := next + 1 ]. - "Choose the better cluster" - middle := middle - prev < (next - middle) - ifTrue: [ prev + 1 ] - ifFalse: [ next ]. - middle = 1 ifTrue: [ middle := next ]. - middle >= list size ifTrue: [ middle := prev + 1 ]. - (middle = 1 or: [ middle >= list size ]) ifTrue: [ ^ Array with: list ]. - ^ Array streamContents: [ :out | - out nextPutAll: - (self - splitNewMorphList: - (list - copyFrom: 1 - to: middle - 1) - depth: d - 1). - out nextPutAll: - (self - splitNewMorphList: - (list - copyFrom: middle - to: list size) - depth: d - 1) ].! ! -!CodeFile methodsFor: 'accessing' stamp: 'jmv 8/22/2021 13:58:32' prior: 50492846! - organization - ^ SystemOrganizer defaultList: #().! ! -!WeightTracer methodsFor: 'weight' stamp: 'jmv 8/22/2021 13:58:40' prior: 16944984 overrides: 16808241! - scanClosureSkipping: anArray - - self prepareToScanClosure. - self skipInternalNodesAnd: #(). - self basicScanClosure. - self prepareToWeighClosure. - self skipInternalNodesAnd: anArray. - self basicScanClosure. - self cleanUpAfterScan! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4789-Cleanup-JuanVuletich-2021Aug22-14h06m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4789] on 23 August 2021 at 12:15:23 pm'! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 8/23/2021 11:15:37'! - fullAddCurrentMorphTo: aDamageRecorder - - currentMorph isRedrawNeeded ifTrue: [ - currentMorph needsRedraw: false. - self updateCurrentBounds. - aDamageRecorder recordInvalidRect: currentMorph displayBounds for: currentMorph ]. - currentMorph isSubmorphRedrawNeeded ifTrue: [ - currentMorph submorphNeedsRedraw: false. - currentMorph submorphsReverseDo: [ :m | - self fullAddRedrawRect: m to: aDamageRecorder ]].! ! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 8/23/2021 11:21:37' prior: 50595370! -fullAddRedrawRect: aMorph to: aDamageRecorder - - aMorph visible ifTrue: [ - (aMorph isRedrawNeeded or: [aMorph isSubmorphRedrawNeeded]) ifTrue: [ - self into: aMorph. - self fullAddCurrentMorphTo: aDamageRecorder. - self outOfMorph - ]]! ! - -BitBltBoundsFinderCanvas removeSelector: #fullAddCurrentRect:submorphs:to:! - -!methodRemoval: BitBltBoundsFinderCanvas #fullAddCurrentRect:submorphs:to: stamp: 'Install-4790-BoundsFInderFix-JuanVuletich-2021Aug23-12h13m-jmv.001.cs.st 8/24/2021 17:32:54'! -fullAddCurrentRect: addCurrentBounds submorphs: trySubmorphs to: aDamageRecorder - - | invalidateOwns | - invalidateOwns _ false. - addCurrentBounds ifTrue: [ - currentMorph needsRedraw: false. - self updateCurrentBounds. - invalidateOwns _ true ]. - trySubmorphs ifTrue: [ - (currentMorph submorphsMightProtrude and: [currentMorph clipsSubmorphsReally not]) - ifTrue: [ - currentMorph submorphNeedsRedraw: false. - currentMorph submorphsReverseDo: [ :m | - self fullAddRedrawRect: m to: aDamageRecorder ]] - ifFalse: [ - currentMorph fullRedrawNotNeeded. - invalidateOwns _ true ]]. - invalidateOwns ifTrue: [ - aDamageRecorder recordInvalidRect: currentMorph displayBounds for: currentMorph ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4790-BoundsFInderFix-JuanVuletich-2021Aug23-12h13m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4789] on 23 August 2021 at 12:15:48 pm'! -!InnerListMorph methodsFor: 'list management' stamp: 'jmv 8/22/2021 19:02:22' prior: 16855331! - highlightedRow: n - highlightedRow = n ifFalse: [ - highlightedRow ifNotNil: [ - self invalidateLocalRect: (self drawBoundsForRow: highlightedRow) ]. - highlightedRow _ n. - highlightedRow ifNotNil: [ - self invalidateLocalRect: (self drawBoundsForRow: highlightedRow) ]. - ].! ! -!InnerListMorph methodsFor: 'list management' stamp: 'jmv 8/22/2021 19:03:57' prior: 16855112! - selectedRow: index - "select the index-th row. if nil, remove the current selection" - selectedRow = index ifFalse: [ - selectedRow ifNotNil: [ - self invalidateLocalRect: (self drawBoundsForRow: selectedRow) ]. - highlightedRow ifNotNil: [ - self invalidateLocalRect: (self drawBoundsForRow: highlightedRow) ]. - selectedRow _ index. - highlightedRow _ nil. - selectedRow ifNotNil: [ - self invalidateLocalRect: (self drawBoundsForRow: selectedRow) ]. - ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4791-ListMorphInvalidation-speedup-JuanVuletich-2021Aug23-12h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4789] on 23 August 2021 at 12:17:59 pm'! -!TheWorldMenu class methodsFor: 'menu building' stamp: 'jmv 8/23/2021 10:15:43' prior: 50599749! - worldMenuOptions - - ^`{{ - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'Open...'. - #selector -> #openOpenMenu. - #icon -> #openIcon. - #balloonText -> 'Submenu to open various system tools'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'New morph...'. - #selector -> #newMorph. - #icon -> #morphsIcon. - #balloonText -> 'Offers a variety of ways to create new objects'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'Preferences...'. - #selector -> #openPreferencesMenu. - #icon -> #preferencesIcon. - #balloonText -> 'Opens a menu offering many controls over appearance and system preferences.'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 40. - #label -> 'Windows...'. - #selector -> #openWindowsMenu. - #icon -> #windowIcon. - #balloonText -> 'Manage open windows'. - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 50. - #label -> 'Help...'. - #selector -> #openHelpMenu. - #icon -> #helpIcon. - #balloonText -> 'Opens a menu of useful items for updating the system, determining what version you are running, and much else'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'Changes...'. - #selector -> #openChangesMenu. - #icon -> #changesIcon. - #balloonText -> 'Opens a menu of useful tools for dealing with changes'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 20. - #label -> 'Debug...'. - #selector -> #openDebugMenu. - #icon -> #debugIcon. - #balloonText -> 'a menu of debugging items'. - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 30. - #label -> 'Restore Display'. - #object -> #myWorld. - #selector -> #restoreDisplay. - #icon -> #displayIcon. - #balloonText -> 'Repaint the screen -- useful for cleaning unwanted display artifacts.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 10. - #label -> 'Save Image'. - #object -> Smalltalk. - #selector -> #saveImage. - #icon -> #saveIcon. - #balloonText -> 'Save the current state of the image on disk. Overwrite existing file.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'Save Image as...'. - #object -> Smalltalk. - #selector -> #saveAs. - #icon -> #saveAsIcon. - #balloonText -> 'Save the current state of the image on disk under a new name.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'Save Release and Quit'. - #object -> Smalltalk. - #selector -> #saveAsNewReleaseAndQuit. - #icon -> #saveAsNewVersionIcon. - #balloonText -> ('Save as a new release of Cuis.\', - 'Clear all user preferences and user state (class vars).\', - 'Use an updated version-stamped name\', - 'and save the image with that name on disk.\', - 'Quit Cuis.') withNewLines. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 40. - #label -> 'Save Image and Quit'. - #object -> Smalltalk. - #selector -> #saveAndQuit. - #icon -> #saveAndQuitIcon. - #balloonText -> 'Save the image and quit out of Cuis. Overwrite existing file.'. - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 50. - #label -> 'Quit without saving'. - #selector -> #quitSession. - #icon -> #quitIcon. - #balloonText -> ('Quit out of Cuis without saving the image.\', - 'Ask for confirmation if there are unsaved changes.') withNewLines. - } asDictionary. -}`! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4792-WorldMenu-tweaks-HernanWilkinson-JuanVuletich-2021Aug23-12h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4789] on 23 August 2021 at 12:19:38 pm'! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 8/23/2021 10:31:06'! - haloShowsCoordinateSystem - - ^Preferences halosShowCoordinateSystem! ! -!WidgetMorph methodsFor: 'halos and balloon help' stamp: 'jmv 8/23/2021 10:33:53' overrides: 50601400! - haloShowsCoordinateSystem - "We are usually not concerned with this level of detail for Widgets, as they prefer using automatic Layout." - - ^false! ! -!HaloMorph methodsFor: 'drawing' stamp: 'jmv 8/23/2021 10:34:32' prior: 50596452 overrides: 16899205! - drawOn: aCanvas - - | b | - target ifNil: [^super drawOn: aCanvas]. - "Debugging aid" - "aCanvas - fillRectangle: haloBox - color: (Color red alpha: 0.2). - aCanvas - fillRectangle: self morphLocalBounds - color: (Color gray alpha: 0.4)." - target haloShowsCoordinateSystem ifTrue: [ - target displayFullBounds ifNotNil: [ :fb | - aCanvas frameGlobalRect: fb borderWidth: 3 color: `Color black alpha: 0.1`. - b _ target displayBounds. - b = fb ifFalse: [ - aCanvas frameGlobalRect: b borderWidth: 3 color: `Color black alpha: 0.1` ]. - self drawCoordinateSystemOn: aCanvas ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4793-DontShowCoordinateSystemForWidgets-HernanWilkinson-JuanVuletich-2021Aug23-12h17m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4793] on 23 August 2021 at 1:58:19 pm'! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 8/23/2021 13:55:11' overrides: 50593767! - findFullBoundsInOwner - "Find and answer full bounds in whatever owner. - These might not equal #displayFullBounds at all!!" - - self requiresVectorCanvas ifTrue: [ - ^super findFullBoundsInOwner ]. - - "#morphExtent exists, and it is also valid in owner, because #requiresVectorCanvas is false." - ^(self morphPosition extent: self morphExtent) encompassingIntegerRectangle.! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 8/23/2021 13:55:25' overrides: 50593767! - findFullBoundsInOwner - "Find and answer full bounds in whatever owner. - These might not equal #displayFullBounds at all!!" - - self requiresVectorCanvas ifTrue: [ - ^super findFullBoundsInOwner ]. - - "#morphExtent exists, and it is also valid in owner, because #requiresVectorCanvas is false." - ^(self morphPosition extent: self morphExtent) encompassingIntegerRectangle.! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/23/2021 13:57:28' prior: 50593767! - findFullBoundsInOwner - "Find and answer full bounds in whatever owner. - These might not equal #displayFullBounds at all!! - Subclasses need to redefine this method. - Alternatively, VectorGraphics provides a working implementation as an override." - - self subclassResponsibility.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4794-findFullBoundsInOwner-refactor-JuanVuletich-2021Aug23-13h55m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4794] on 23 August 2021 at 2:35:05 pm'! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 8/23/2021 14:33:25' prior: 50601169! - fullAddCurrentMorphTo: aDamageRecorder - - currentMorph isRedrawNeeded ifTrue: [ - currentMorph needsRedraw: false. - self updateCurrentBounds. - aDamageRecorder recordInvalidRect: currentMorph displayBounds for: currentMorph ]. - currentMorph isSubmorphRedrawNeeded ifTrue: [ - currentMorph submorphNeedsRedraw: false. - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | - self fullAddRedrawRect: m to: aDamageRecorder ]]].! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 8/23/2021 14:31:43' prior: 50596076 overrides: 50501575! - setClipRect: aRectangle - "In targetForm coordinates" - - super setClipRect: aRectangle. - engine clipRect: aRectangle. - boundsFinderCanvas ifNotNil: [ - boundsFinderCanvas setClipRect: aRectangle ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4795-clipRectInBoundsFinder-JuanVuletich-2021Aug23-14h29m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4795] on 23 August 2021 at 5:41:13 pm'! -!Preferences class methodsFor: 'standard queries' stamp: 'jmv 8/23/2021 15:24:10'! - drawKeyboardFocusIndicator - ^ self - valueOfFlag: #drawKeyboardFocusIndicator - ifAbsent: [ true ]! ! -!TextModelMorph methodsFor: 'accessing' stamp: 'jmv 8/23/2021 15:04:09'! - drawKeyboardFocusIndicator - "For InnerTextMorph" - - ^drawKeyboardFocusIndicator! ! -!Preferences class methodsFor: 'themes' stamp: 'jmv 8/23/2021 15:24:54' prior: 50598871! - cuisDefaults - self setPreferencesFrom: #( - #(#drawKeyboardFocusIndicator true ) - #(#balloonHelpEnabled true ) - #(#biggerCursors false ) - #(#browseWithPrettyPrint false ) - #(#caseSensitiveFinds false ) - #(#checkForSlips true ) - #(#cmdDotEnabled true ) - #(#diffsInChangeList true ) - #(#diffsWithPrettyPrint false ) - #(#menuKeyboardControl true ) - #(#optionalButtons true ) - #(#extraDebuggerButtons true ) - #(#subPixelRenderFonts true ) - #(#thoroughSenders true ) - #(#cheapWindowReframe false ) - #(#syntaxHighlightingAsYouType true ) - #(#tapAndHoldEmulatesButton2 true ) - #(#clickGrabsMorphs false ) - #(#syntaxHighlightingAsYouTypeAnsiAssignment false ) - #(#syntaxHighlightingAsYouTypeLeftArrowAssignment false ) - ). - self useMenuIcons.! ! -!Preferences class methodsFor: 'themes' stamp: 'jmv 8/23/2021 15:25:08' prior: 50391990! - slowMachine - " - Preferences slowMachine - " - self setPreferencesFrom: #( - #(#drawKeyboardFocusIndicator false ) - (balloonHelpEnabled false) - (browseWithPrettyPrint false) - (caseSensitiveFinds true) - (checkForSlips false) - (cmdDotEnabled true) - (diffsInChangeList true) - (diffsWithPrettyPrint false) - (menuKeyboardControl false) - (optionalButtons false) - (subPixelRenderFonts true) - (thoroughSenders true) - (cheapWindowReframe true) - (syntaxHighlightingAsYouType false) - (tapAndHoldEmulatesButton2 false) - (clickGrabsMorphs true) - ). - self useNoMenuIcons. - self runningWorld backgroundImageData: nil. - " - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - Taskbar hideTaskbar - "! ! -!Preferences class methodsFor: 'themes' stamp: 'jmv 8/23/2021 15:25:36' prior: 50392014! -smalltalk80 - "A traditional monochrome Smalltalk-80 look and feel, clean and austere, and lacking many features added to Squeak and Cuis in recent years. Caution: turns off the 'smartUpdating' feature that keeps multiple browsers in synch, and much more. - - Preferences smalltalk80 - " - - self setPreferencesFrom: - - #( - (drawKeyboardFocusIndicator false ) - (balloonHelpEnabled false) - (browseWithPrettyPrint false) - (caseSensitiveFinds true) - (checkForSlips false) - (cmdDotEnabled true) - (diffsInChangeList false) - (diffsWithPrettyPrint false) - (menuKeyboardControl false) - (optionalButtons false) - (subPixelRenderFonts true) - (thoroughSenders false) - (cheapWindowReframe true) - (syntaxHighlightingAsYouType false) - (tapAndHoldEmulatesButton2 false) - (clickGrabsMorphs true) - ). - self useNoMenuIcons. - " - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - Taskbar hideTaskbar - "! ! -!InnerTextMorph methodsFor: 'event handling' stamp: 'jmv 8/23/2021 15:05:27' prior: 50381248 overrides: 50590348! -keyboardFocusChange: aBoolean - - "The message is sent to a morph when its keyboard focus changes. - The given argument indicates that the receiver is gaining (versus losing) the keyboard focus. - In this case, all we need to do is to redraw border feedback" - aBoolean - ifTrue: [ - "A hand is wanting to send us characters..." - editor ifNil: [ self editor storeSelectionInComposition ]. "Forces install" - self showsBlinkingCursor ifTrue: [ - editor hasSelection ifFalse: [ - self startBlinking ]]] - ifFalse: [ self stopBlinking ]. - - (owner notNil and: [ owner drawKeyboardFocusIndicator ]) - ifTrue: [ owner redrawNeeded ] - ifFalse: [ - "Selection might be shown differently when focused" - self textComposition selectionRects do: [ :r | self invalidateLocalRect: r ]] .! ! -!PluggableScrollPane methodsFor: 'initialization' stamp: 'jmv 8/23/2021 15:23:44' prior: 50578476 overrides: 50384371! - initialize - - "initialize the state of the receiver" - super initialize. - hideScrollBars _ #showIfNeeded. - - "initialize the receiver's scrollBars" - scrollBar _ ScrollBar new model: self setValueSelector: #vScrollBarValue:. - hScrollBar _ ScrollBar new model: self setValueSelector: #hScrollBarValue:. - drawKeyboardFocusIndicator _ Preferences drawKeyboardFocusIndicator. - - scroller _ self innerMorphClass new. - self addMorph: scroller. - self scrollerOffset: `0@ 0`. - self addMorph: scrollBar. - self addMorph: hScrollBar! ! -!HierarchicalListMorph methodsFor: 'event handling' stamp: 'jmv 8/23/2021 15:20:44' prior: 16853032 overrides: 50590348! - keyboardFocusChange: aBoolean - "The message is sent to a morph when its keyboard focus changes. - The given argument indicates that the receiver is gaining (versus losing) the keyboard focus. - In this case, all we need to do is to redraw focus feedback" - - - drawKeyboardFocusIndicator - ifTrue: [self redrawNeeded] - ifFalse: [ - selectedMorph ifNotNil: [ selectedMorph redrawNeeded ]]! ! -!PluggableListMorph methodsFor: 'event handling' stamp: 'jmv 8/23/2021 15:33:41' prior: 16888689 overrides: 50590348! - keyboardFocusChange: aBoolean - "The message is sent to a morph when its keyboard focus changes. - The given argument indicates that the receiver is gaining (versus losing) the keyboard focus. - In this case, all we need to do is to redraw focus feedback" - - drawKeyboardFocusIndicator - ifTrue: [self redrawNeeded] - ifFalse: [ - scroller selectedRow - ifNotNil: [ :i | - scroller selectedRow: nil; selectedRow: i ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4796-drawKeyboardFocusChange-Preference-JuanVuletich-2021Aug23-17h39m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4796] on 23 August 2021 at 6:55:39 pm'! - -InnerPluggableMorph subclass: #InnerTextMorph - instanceVariableNames: 'model wrapFlag textComposition editor pauseBlinking acceptOnCR hasUnacceptedEdits hasEditingConflicts askBeforeDiscardingEdits styler autoCompleter mutex needsFit ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #InnerTextMorph category: 'Morphic-Widgets' stamp: 'Install-4797-DontRefreshIfTextHasntChanged-JuanVuletich-2021Aug23-18h53m-jmv.001.cs.st 8/24/2021 17:32:55'! -InnerPluggableMorph subclass: #InnerTextMorph - instanceVariableNames: 'model wrapFlag textComposition editor pauseBlinking acceptOnCR hasUnacceptedEdits hasEditingConflicts askBeforeDiscardingEdits styler autoCompleter mutex needsFit' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! -!InnerTextMorph methodsFor: 'editing' stamp: 'jmv 8/23/2021 16:47:31' prior: 50368954! - hasUnacceptedEdits: aBoolean - "Set the hasUnacceptedEdits flag to the given value. " - aBoolean == hasUnacceptedEdits ifFalse: [ - hasUnacceptedEdits _ aBoolean]. - aBoolean ifFalse: [ hasEditingConflicts _ false]. - - "shout: re-style the text iff aBoolean is true - Do not apply any formatting (i.e. changes to the characters in the text), - just styling (i.e. TextAttributes)" - aBoolean ifTrue: [ - self formatAndStyleIfNeeded ]. - needsFit _ aBoolean.! ! -!InnerTextMorph methodsFor: 'initialization' stamp: 'jmv 8/23/2021 16:47:24' prior: 16855909 overrides: 50545905! - initialize - super initialize. - wrapFlag _ true. - acceptOnCR _ false. - hasUnacceptedEdits _ false. - hasEditingConflicts _ false. - askBeforeDiscardingEdits _ true. - needsFit _ false.! ! -!InnerTextMorph methodsFor: 'private' stamp: 'jmv 8/23/2021 18:54:55' prior: 16856088! - updateFromTextComposition - "A change has taken place in my textComposition, as a result of editing and I must be updated. " - - textComposition ifNotNil: [ - editor storeSelectionInComposition. - needsFit ifTrue: [ - self fit. - needsFit _ false ]]. - - owner - updateScrollBarsBounds; - setScrollDeltas.! ! - -InnerPluggableMorph subclass: #InnerTextMorph - instanceVariableNames: 'model wrapFlag textComposition editor pauseBlinking acceptOnCR hasUnacceptedEdits hasEditingConflicts askBeforeDiscardingEdits styler autoCompleter mutex needsFit' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #InnerTextMorph category: 'Morphic-Widgets' stamp: 'Install-4797-DontRefreshIfTextHasntChanged-JuanVuletich-2021Aug23-18h53m-jmv.001.cs.st 8/24/2021 17:32:55'! -InnerPluggableMorph subclass: #InnerTextMorph - instanceVariableNames: 'model wrapFlag textComposition editor pauseBlinking acceptOnCR hasUnacceptedEdits hasEditingConflicts askBeforeDiscardingEdits styler autoCompleter mutex needsFit' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -InnerTextMorph allInstancesDo: [ :it | it instVarNamed: 'needsFit' put: false ].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4797-DontRefreshIfTextHasntChanged-JuanVuletich-2021Aug23-18h53m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4779] on 23 August 2021 at 7:37:18 pm'! - -Object subclass: #DamageRecorder - instanceVariableNames: 'drSemaphore damageByRoot otherDamage ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #DamageRecorder category: #'Morphic-Support' stamp: 'Install-4798-DamageRecorderEnhancements-JuanVuletich-2021Aug23-19h35m-jmv.001.cs.st 8/24/2021 17:32:55'! -Object subclass: #DamageRecorder - instanceVariableNames: 'drSemaphore damageByRoot otherDamage' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! -!DamageRecorder methodsFor: 'initialization' stamp: 'jmv 8/23/2021 18:44:22' prior: 50539453 overrides: 16896425! - initialize - damageByRoot _ IdentityDictionary new. - otherDamage _ OrderedCollection new.! ! -!DamageRecorder methodsFor: 'recording' stamp: 'jmv 8/23/2021 18:51:09' prior: 50543964! - damageReportedOther - "Answer damage reported for no specific morph, for morphs that are not visible, and for morphs that are carried by the Hand." - | answer | - answer _ OrderedCollection new. - self pvtAccessProtect critical: [ - damageByRoot keysAndValuesDo: [ :m :r | - (m visible not or: [m owner isNil or: [m owner is: #HandMorph]]) ifTrue: [ - answer add: r]]. - otherDamage do: [ :r | answer add: r ]. - ]. - ^answer! ! -!DamageRecorder methodsFor: 'recording' stamp: 'jmv 8/23/2021 19:01:20' prior: 50539459! - reset - "Clear the damage list." - self pvtAccessProtect critical: [ - damageByRoot removeAll. - otherDamage removeAll. ].! ! -!DamageRecorder methodsFor: 'testing' stamp: 'jmv 8/23/2021 18:48:47' prior: 50539465! - updateIsNeeded - "Return true if the display needs to be updated." - ^ self pvtAccessProtect critical: [damageByRoot notEmpty or: [otherDamage notEmpty]]! ! -!DamageRecorder methodsFor: 'private' stamp: 'jmv 8/23/2021 18:49:49' prior: 50539472! - pvtInnerRecordInvalidRect: requestedRect for: aRootMorph - "Record the given rectangle in my damage list, a list of rectangular areas of the display that should be redraw on the next display cycle." - | newRect | - newRect _ requestedRect encompassingIntegerRectangle. - aRootMorph ifNotNil: [ - damageByRoot at: aRootMorph put: - (damageByRoot at: aRootMorph - ifPresent: [:r | r quickMerge: newRect] - ifAbsent: [newRect]) ] - ifNil: [otherDamage add: newRect].! ! - -Object subclass: #DamageRecorder - instanceVariableNames: 'drSemaphore damageByRoot otherDamage' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -!classDefinition: #DamageRecorder category: #'Morphic-Support' stamp: 'Install-4798-DamageRecorderEnhancements-JuanVuletich-2021Aug23-19h35m-jmv.001.cs.st 8/24/2021 17:32:55'! -Object subclass: #DamageRecorder - instanceVariableNames: 'drSemaphore damageByRoot otherDamage' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Support'! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -DamageRecorder allInstancesDo: [ :dr | dr instVarNamed: 'otherDamage' put: OrderedCollection new ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4798-DamageRecorderEnhancements-JuanVuletich-2021Aug23-19h35m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4797] on 23 August 2021 at 7:19:56 pm'! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 8/23/2021 19:16:24' prior: 50594899 overrides: 50594689! - addPossiblyUncoveredAreasIn: aRectangle to: aCollection - "Answer an array of rectangles encompassing those areas in aRectangle not completely - covered by self. These are the areas that might require further drawing (of morphs below us) - All areas that might possibly be uncovered must be included." - - | bounds r e | - self isOrAnyOwnerIsRotated ifTrue: [ - aCollection add: aRectangle. - ^self ]. - - color mightBeTranslucent ifTrue: [ - aCollection add: aRectangle. - ^self ]. - - bounds _ self displayBounds. - bounds ifNil: [ - aCollection add: aRectangle. - ^self ]. - - "Solid rectangle. - This will be the fastest in many cases. So, please disable rounded corners if on slow hardware!!" - aRectangle areasOutside: bounds do: [ :rect | aCollection add: rect ]. - - "Add area around rounded corners if needed." - Theme current roundWindowCorners ifTrue: [ - r _ Theme current roundedWindowRadius. - e _ r@r. - aCollection add: (aRectangle intersect: (bounds topLeft extent: e)). - aCollection add: (aRectangle intersect: (bounds topRight - (r@0) extent: e)). - aCollection add: (aRectangle intersect: (bounds bottomLeft - (0@r)extent: e)). - aCollection add: (aRectangle intersect: (bounds bottomRight - (r@r) extent: e)). - ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 8/23/2021 19:19:51' prior: 50595589! - drawWorld: aWorldMorph repair: aDamageRecorder - "Redraw the damaged areas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | visibleRootMorphs visibleRootsDamage worldDamage | - "Update #displayBounds for all dirty morphs (marked as such with #redrawNeeded). - Also add the updated bounds to aDamageRecorder, and update bounds of morphs carried by hand." - self boundsFinderCanvas updateBoundsIn: aWorldMorph addDamageTo: aDamageRecorder. - - visibleRootMorphs _ aWorldMorph privateSubmorphs select: [ :m | m visible ]. - visibleRootsDamage _ Array new: visibleRootMorphs size. - - worldDamage _ self computeDamage: aWorldMorph repair: aDamageRecorder - rootMorphs: visibleRootMorphs rootMorphsDamage: visibleRootsDamage. - - self drawWorldBackground: aWorldMorph rects: worldDamage. - "Debugging aids." - " - worldDamage do: [ :r | Display fill: r fillColor: Color random . Display forceToScreen. (Delay forSeconds: 0.005) wait]. - "" - visibleRootsDamage do: [ :r | r ifNotNil: [ Display fill: r fillColor: Color random . Display forceToScreen. (Delay forSeconds: 0.05) wait]]. - " - self drawWorld: aWorldMorph - rootMorphs: visibleRootMorphs rootMorphsDamage: visibleRootsDamage - allDamage: worldDamage. - - aDamageRecorder reset. - ^ worldDamage! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4799-Morphic-Invalidation-tweaks-JuanVuletich-2021Aug23-19h02m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4799] on 24 August 2021 at 12:00:58 pm'! -!DamageRecorder methodsFor: 'recording' stamp: 'jmv 8/24/2021 11:03:44' prior: 50601848! - damageReportedOther - "Answer damage reported for no specific morph, for morphs that are not visible, and for morphs that are carried by the Hand." - | answer possiblyMoreRectsToMerge | - answer _ OrderedCollection new. - self pvtAccessProtect critical: [ - damageByRoot keysAndValuesDo: [ :m :r | - (m visible not or: [m owner isNil or: [m owner is: #HandMorph]]) ifTrue: [ - answer add: r]]. - otherDamage do: [ :r | answer add: r ]. - ]. - possiblyMoreRectsToMerge _ true. - [possiblyMoreRectsToMerge] whileTrue: [ - possiblyMoreRectsToMerge _ false. - answer withIndexDo: [ :r1 :i | - r1 ifNotNil: [ - i+1 to: answer size do: [ :j | | r2 | - r2 _ answer at: j. - r2 ifNotNil: [ - (r1 intersects: r2) ifTrue: [ - answer at: i put: (r1 quickMerge: r2). - answer at: j put: nil. - possiblyMoreRectsToMerge _ true ]]]]]]. - answer _ answer select: [ :r | r notNil ]. - ^answer! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4800-DamageReporter-mergeOverlappingRects-JuanVuletich-2021Aug24-12h00m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4799] on 24 August 2021 at 11:59:48 am'! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 8/24/2021 10:58:39' prior: 50601934 overrides: 50594689! - addPossiblyUncoveredAreasIn: aRectangle to: aCollection - "Answer an array of rectangles encompassing those areas in aRectangle not completely - covered by self. These are the areas that might require further drawing (of morphs below us) - All areas that might possibly be uncovered must be included." - - | bounds | - self isOrAnyOwnerIsRotated ifTrue: [ - aCollection add: aRectangle. - ^self ]. - - color mightBeTranslucent ifTrue: [ - aCollection add: aRectangle. - ^self ]. - - bounds _ self displayBounds. - bounds ifNil: [ - aCollection add: aRectangle. - ^self ]. - - "Solid rectangle. - This will be the fastest in many cases. So, please disable rounded corners if on slow hardware!!" - Theme current roundWindowCorners ifFalse: [ - aRectangle areasOutside: bounds do: [ :rect | aCollection add: rect ]. - ^self ]. - - "The solid rectangle does not include the corners. - Report a couple of rows (top and bottom) or columns (left and right) as uncovered areas. - We could also try to be more careful and answer each rounded corner... - Right now, report top and bottom rows as uncovered areas: - - Rows are contiguous in Display memory - - Redrawing title area wont trigger redrawing all windows contents." - " - radius _ Theme current roundedWindowRadius. - aRectangle areasOutside: (bounds insetBy: 0@radius) do: [ :rect | aCollection add: rect ]. - " - "Alternative: just include window borders. Almost correct, and cheaper." - aRectangle areasOutside: (bounds insetBy: Theme current windowBorderWidth) do: [ :rect | aCollection add: rect ]. - -"Note: Doing this after the non-rounded-corner case gave bad results. Not letting the size of aCollection grow without bounds is more important than not answering extra areas. - Theme current roundWindowCorners ifTrue: [ - r _ Theme current roundedWindowRadius. - e _ r@r. - aCollection add: (aRectangle intersect: (bounds topLeft extent: e)). - aCollection add: (aRectangle intersect: (bounds topRight - (r@0) extent: e)). - aCollection add: (aRectangle intersect: (bounds bottomLeft - (0@r)extent: e)). - aCollection add: (aRectangle intersect: (bounds bottomRight - (r@r) extent: e)). - ]."! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4801-WindowDamageReportingFix-JuanVuletich-2021Aug24-11h58m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4799] on 24 August 2021 at 12:00:18 pm'! -!CodeWindow methodsFor: 'updating' stamp: 'jmv 8/24/2021 11:42:18' prior: 16813226! - updateListsAndCode - "All code windows receive this message on any code change in the system" - - model ifNotNil: [ - self canDiscardEdits ifTrue: [ - self allMorphsDo: [ :m | (m is: #PluggableListMorph) ifTrue: [ m verifyContents ]]. - model updateIfNeeded ]]! ! -!VersionsBrowserWindow methodsFor: 'updating' stamp: 'jmv 8/24/2021 11:42:36' prior: 16942863 overrides: 50602146! - updateListsAndCode - "All code windows receive this message on any code change in the system" - - model ifNotNil: [ - model updateIfNeeded ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4802-updateListsAndCode-fix-JuanVuletich-2021Aug24-11h59m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4799] on 24 August 2021 at 12:01:35 pm'! -!ChangeSet class methodsFor: 'change set to use' stamp: 'jmv 8/24/2021 11:41:19' prior: 50422654! - installing: aCodePackageOrChangeSetName do: aBlock - - | currentCS currentCSNumber newHighestUpdate | - SystemChangeNotifier uniqueInstance - doSilently: [ - Installing _ 'Install-', aCodePackageOrChangeSetName. - aBlock ensure: [ Installing _ nil ]]. - CodeWindow allSubInstancesDo: [ :w | w updateListsAndCode ]. - Smalltalk forceChangesToDisk. - - SystemVersion current registerUpdate: aCodePackageOrChangeSetName. - newHighestUpdate _ SystemVersion current highestUpdate. - - currentCSNumber _ self currentBaseCSNumber. - currentCS _ self changeSetForBaseSystem. - currentCS isEmpty ifTrue: [ - ChangeSet removeChangeSet: currentCS. - currentCSNumber > newHighestUpdate ifFalse: [ - CurrentBaseCSNumber _ newHighestUpdate + 1 ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4803-FasterPackageAndChangeSetInstall-JuanVuletich-2021Aug24-12h00m-jmv.001.cs.st----! -!FileList methodsFor: 'user interface' stamp: 'KLG 8/23/2021 20:51:44'! - toggleInitialDirectory - "Toggle the initial directory setting of the currently selected directory." - - | directoryEntry | - Preferences isInitialFileListDirectory: (directoryEntry _ currentDirectorySelected item):: - ifTrue: [ - Preferences removeInitialFileListDirectory: directoryEntry ] - ifFalse: [ - Preferences addInitialFileListDirectory: directoryEntry ]! ! -!Preferences class methodsFor: 'file list' stamp: 'KLG 8/23/2021 20:33:08'! - addInitialFileListDirectory: aDirectoryEntry - "Add an initial directory entry to the collection of initial directories." - - | currentValue | - (currentValue _ self initialFileListDirectories) isSymbol - ifTrue: [ - self initialFileListDirectories: (Set with: aDirectoryEntry) ] - ifFalse: [ - currentValue add: aDirectoryEntry ] - ! ! -!Preferences class methodsFor: 'file list' stamp: 'KLG 8/23/2021 20:01:01'! - initialFileListDirectories - "Answer the initial collection of file list directory entries. - - Special values: - - #root: Use the usual roots - #image: Use the image directory - #vm: Use the vm directory - #current: Use the current directory " - - ^ self - valueOfFlag: #initialFileListDirectories - ifAbsent: [ #roots ].! ! -!Preferences class methodsFor: 'file list' stamp: 'KLG 8/23/2021 19:53:28'! - initialFileListDirectories: aValue - "Set the initial fileList directories. - - See #initialFileListDirectories " - ^ self setPreference: #initialFileListDirectories toValue: aValue! ! -!Preferences class methodsFor: 'file list' stamp: 'KLG 8/23/2021 20:40:48'! - isInitialFileListDirectory: aDirectoryEntry - "Answer true if aDirectoryEntry is an initial directory entry." - - | currentValue | - (currentValue _ self initialFileListDirectories) isSymbol ifTrue: [ ^ false ]. - ^ currentValue includes: aDirectoryEntry! ! -!Preferences class methodsFor: 'file list' stamp: 'KLG 8/23/2021 20:35:42'! - removeInitialFileListDirectory: aDirectoryEntry - "Add an initial directory entry to the collection of initial directories." - - | currentValue | - (currentValue _ self initialFileListDirectories) isSymbol ifTrue: [ ^ self ]. - currentValue remove: aDirectoryEntry ifAbsent: [] . - currentValue ifEmpty: [ self initialFileListDirectories: #roots ]! ! -!Preferences class methodsFor: 'system startup' stamp: 'KLG 8/23/2021 21:33:24' overrides: 16784996! -initClassCachedState - "Check the initial file list directories for existence." - - | initialDirectories | - (initialDirectories _ self initialFileListDirectories) isSymbol ifTrue: [ ^ self ]. - initialDirectories copy do: [ :directoryEntry | - directoryEntry exists ifFalse: - [ self removeInitialFileListDirectory: directoryEntry ] ]! ! -!FileList methodsFor: 'initialization' stamp: 'KLG 8/23/2021 20:24:48' prior: 16842599! - initialDirectoryList - - | initialDirectoryListFromPreferences wrapperCreator | - wrapperCreator _ [ :directoryEntry | - FileDirectoryWrapper - with: directoryEntry - name: (directoryEntry name ifNil: [ '/' ]) - model: self ]. - (initialDirectoryListFromPreferences _ Preferences initialFileListDirectories) - caseOf: { - [ #roots ] -> [ | dirList | - dirList _ DirectoryEntry roots collect: wrapperCreator. - dirList isEmpty ifTrue: [ - dirList _ Array with: (FileDirectoryWrapper - with: directory - name: directory localName - model: self) ]. - ^ dirList ]. - [ #image ] -> [ - ^ { wrapperCreator value: DirectoryEntry smalltalkImageDirectory } ]. - [ #vm ] -> [ - ^ { wrapperCreator value: DirectoryEntry vmDirectory } ]. - [ #current ] -> [ - ^ { wrapperCreator value: DirectoryEntry currentDirectory } ] } - otherwise: [ ^ initialDirectoryListFromPreferences collect: wrapperCreator ]! ! -!FileListWindow methodsFor: 'menu building' stamp: 'KLG 8/23/2021 21:39:39' prior: 50400036! -volumeMenu - | aMenu initialDirectoriesMenu | - aMenu _ MenuMorph new defaultTarget: model. - aMenu - add: 'delete directory...' - action: #deleteDirectory - icon: #warningIcon :: setBalloonText: 'Delete the selected directory'. - model currentDirectorySelected - ifNil: [ aMenu add: 'initial directory' action: #yourself :: isEnabled: false ] - ifNotNil: [ :selectedWrapper | - aMenu - add: (Preferences isInitialFileListDirectory: selectedWrapper item :: - ifTrue: [ '' ] - ifFalse: [ '' ]), 'initial directory' - action: #toggleInitialDirectory :: - setBalloonText: 'The selected directory is an initial director for new file list windows' ]. - initialDirectoriesMenu _ MenuMorph new. - #( - (roots 'default roots' 'Use the usual root directories. Drives on Windows; "/" on Unix') - (image 'image directory' 'Use the directory with Smalltalk image') - (vm 'VM directory' 'Use the virtual machine directory') - (current 'current directory' 'Use the current directory; usually the directory the VM was started in') - ) - do: [ :entry | - initialDirectoriesMenu - add: entry second - target: Preferences - action: #initialFileListDirectories: - argument: entry first :: - setBalloonText: entry third ]. - aMenu add: 'default initial directories' subMenu: initialDirectoriesMenu. - ^ aMenu! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4804-ConfigurableInitialDirectoriesInFileList-GeraldKlix-2021Aug23-19h22m-KLG.001.cs.st----! -!Rectangle methodsFor: 'rectangle functions' stamp: 'jmv 8/24/2021 16:36:44'! - updateMerging: aRectangle - "Modify receiver" - - origin _ origin min: aRectangle origin. - corner _ corner max: aRectangle corner.! ! -!DamageRecorder methodsFor: 'recording' stamp: 'jmv 8/24/2021 16:37:48' prior: 50602029! - damageReportedOther - "Answer damage reported for no specific morph, for morphs that are not visible, and for morphs that are carried by the Hand." - | answer possiblyMoreRectsToMerge | - answer _ OrderedCollection new. - self pvtAccessProtect critical: [ - damageByRoot keysAndValuesDo: [ :m :r | - (m visible not or: [m owner isNil or: [m owner is: #HandMorph]]) ifTrue: [ - answer add: r]]. - otherDamage do: [ :r | answer add: r ]. - ]. - possiblyMoreRectsToMerge _ true. - [possiblyMoreRectsToMerge] whileTrue: [ - possiblyMoreRectsToMerge _ false. - answer withIndexDo: [ :r1 :i | - r1 ifNotNil: [ - i+1 to: answer size do: [ :j | | r2 | - r2 _ answer at: j. - r2 ifNotNil: [ - (r1 intersects: r2) ifTrue: [ - r1 updateMerging: r2. - answer at: j put: nil. - possiblyMoreRectsToMerge _ true ]]]]]]. - answer _ answer select: [ :r | r notNil ]. - ^answer! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4805-DamageRecorder-fix-JuanVuletich-2021Aug24-16h28m-jmv.001.cs.st----! - -----QUIT----(24 August 2021 17:32:58) Cuis5.0-4805-v3.image priorSource: 8584834! - -----STARTUP---- (24 August 2021 20:36:22) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4805-v3.image! - -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 8/24/2021 18:32:57'! - saveAndStayAs: newName clearAllClassState: clearAllStateFlag - "Save the image under a new name. Don't quit. - See senders." - - | newChangesName | - self currentChangesName ifNotNil: [ :oldChangesName | - self closeSourceFiles. "so copying the changes file will always work" - newChangesName _ self fullNameForChangesNamed: newName. - FileIOAccessor default copy: oldChangesName asFileEntry to: newChangesName asFileEntry. - ChangesInitialFileSize ifNotNil: [ - oldChangesName asFileEntry appendStreamDo: [ :strm | strm truncate: ChangesInitialFileSize ]]]. - - ChangeSet zapAllChangeSets. - self - changeImageNameTo: (self fullNameForImageNamed: newName); - closeSourceFiles; openSourceFiles; "so SNAPSHOT appears in new changes file" - snapshot: true andQuit: false embedded: false clearAllClassState: clearAllStateFlag.! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 8/24/2021 18:33:03'! - saveAsNewReleaseAndStay - "Save the image/changes using the next available version number. - This is usually only used to prepare updated Cuis images for distribution." - " - Smalltalk saveAsNewReleaseAndStay - " - | fileName newName changesName systemVersion | - systemVersion _ SystemVersion current. - fileName _ String streamContents: [ :strm | - strm - nextPutAll: 'Cuis'; - print: systemVersion versionMajor; - nextPut: $.; - print: systemVersion versionMinor; - nextPut: $-; - print: systemVersion highestUpdate. - Smalltalk isSpur - ifTrue: [ - Smalltalk wordSize = 4 ifTrue: [ - strm nextPutAll: '-32' ]] - ifFalse: [ - strm nextPutAll: '-v3' ]]. - newName _ fileName, '.image'. - (DirectoryEntry smalltalkImageDirectory // newName) exists ifTrue: [ - newName _ DirectoryEntry smalltalkImageDirectory - nextNameFor: fileName - extension: 'image' ]. - changesName _ self fullNameForChangesNamed: newName. - "Check to see if there is a .changes file that would cause a problem if we saved a new .image file with the new version number" - changesName asFileEntry exists ifTrue: [ - ^ self inform: -'There is already .changes file of the desired name, -', changesName, ' -curiously already present, even though there is no -corresponding .image file. -Please remedy manually and then repeat your request.' ]. - "Try to clear all user state, including all class vars, preferences, etc" - self saveAndStayAs: newName clearAllClassState: true! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4806-saveAsNewReleaseAndStay-JuanVuletich-2021Aug24-18h32m-jmv.001.cs.st----! -!ChangeSet class methodsFor: 'change set to use' stamp: 'jmv 12/17/2018 10:05:42' prior: 50602173! - installing: aCodePackageOrChangeSetName do: aBlock - - | currentCS currentCSNumber newHighestUpdate | - Installing _ 'Install-', aCodePackageOrChangeSetName. - aBlock ensure: [ Installing _ nil ]. - Smalltalk forceChangesToDisk. - - SystemVersion current registerUpdate: aCodePackageOrChangeSetName. - newHighestUpdate _ SystemVersion current highestUpdate. - - currentCSNumber _ self currentBaseCSNumber. - currentCS _ self changeSetForBaseSystem. - currentCS isEmpty ifTrue: [ - ChangeSet removeChangeSet: currentCS. - currentCSNumber > newHighestUpdate ifFalse: [ - CurrentBaseCSNumber _ newHighestUpdate + 1 ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4807-MomentarilyRollBack-4803-JuanVuletich-2021Aug24-19h32m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4806] on 24 August 2021 at 7:37:30 pm'! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 8/24/2021 19:36:56' prior: 50560063! - clippingByCurrentMorphDo: aBlock - "Do clipping only if currentMorph says so" - - | prevClipRect prevClippingMorphRect | - - currentMorph clipsSubmorphsReally ifFalse: [ ^aBlock value ]. - - prevClipRect _ self clipRect. - prevClippingMorphRect _ clippingMorphDisplayBounds. - "Might use the fact that currentMorph has just been drawn." - clippingMorphDisplayBounds _ self boundingRectOfCurrentMorphAfterDraw. - self setClipRect: (prevClipRect - ifNil: [clippingMorphDisplayBounds] - ifNotNil: [prevClipRect intersect: clippingMorphDisplayBounds]). - self clipCurrentMorph: true. - aBlock ensure: [ - self clipCurrentMorph: false. - self setClipRect: prevClipRect. - clippingMorphDisplayBounds _ prevClippingMorphRect ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4808-clippingByCurrentMorphDo-fix-JuanVuletich-2021Aug24-19h36m-jmv.001.cs.st----! - -SmalltalkCompleter initialize ! - -----QUIT----(24 August 2021 20:36:46) Cuis5.0-4808-v3.image priorSource: 8664501! - -----STARTUP---- (26 August 2021 17:21:57) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4808-v3.image! - - -'From Cuis 5.0 [latest update: #4808] on 25 August 2021 at 9:23:13 am'! -!CodeWindow methodsFor: 'updating' stamp: 'jmv 8/25/2021 09:13:01'! - updateListsAndCodeNow - "All code windows receive this message on any code change in the system" - self canDiscardEdits ifTrue: [ - self allMorphsDo: [ :m | (m is: #PluggableListMorph) ifTrue: [ m verifyContents ]]. - model updateIfNeeded ]! ! -!VersionsBrowserWindow methodsFor: 'updating' stamp: 'jmv 8/25/2021 09:13:05' overrides: 50602576! - updateListsAndCodeNow - "All code windows receive this message on any code change in the system" - model updateIfNeeded! ! -!CodeWindow methodsFor: 'updating' stamp: 'jmv 8/25/2021 09:21:47' prior: 50602146! - updateListsAndCode - "All code windows receive this message on any code change in the system. - Process it only once, for the benefit of installing large packages!!" - - (self hasProperty: #updateListsAndCode) ifFalse: [ - self setProperty: #updateListsAndCode toValue: true. - self whenUIinSafeState: [ - self removeProperty: #updateListsAndCode. - self updateListsAndCodeNow ]].! ! - -VersionsBrowserWindow removeSelector: #updateListsAndCode! - -!methodRemoval: VersionsBrowserWindow #updateListsAndCode stamp: 'Install-4809-FasterPackageLoading-SmarterApproach-JuanVuletich-2021Aug25-09h10m-jmv.002.cs.st 8/26/2021 17:22:02'! -updateListsAndCode - "All code windows receive this message on any code change in the system" - - model ifNotNil: [ - model updateIfNeeded ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4809-FasterPackageLoading-SmarterApproach-JuanVuletich-2021Aug25-09h10m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4809] on 26 August 2021 at 4:59:09 pm'! -!Preferences class methodsFor: 'bigger and smaller GUI element sizes' stamp: 'jmv 8/26/2021 12:05:02'! - roundedButtonRadius - "Only effective if #roundButtons answers true. - Provide a reasonable default for subclasses." - - ^Preferences standardListFont pointSize * 8 // 14! ! -!Preferences class methodsFor: 'bigger and smaller GUI element sizes' stamp: 'jmv 8/26/2021 12:05:21'! - roundedWindowRadius - "Only effective if #roundWindowCorners answers true. - Provide a reasonable default for subclasses." - - ^Preferences standardListFont pointSize! ! -!MorphicCanvas class methodsFor: 'services' stamp: 'jmv 8/26/2021 11:29:32'! - guiSizePreferenceChanged - "Some preference related to size of gui elements may have changed."! ! -!Theme methodsFor: 'other options' stamp: 'jmv 8/26/2021 16:32:33'! - titleBarButtonsExtent - "Answer the extent to use for close & other title bar buttons. - The label height is used to be proportional to the fonts preferences." - | e | - e _ Preferences windowTitleFont pointSize * 13 // 10. - ^e@e! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/26/2021 11:34:11' prior: 50473252! - defaultFont05 - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences defaultFont05 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 5) - (setMenuFontTo: 6) - (setWindowTitleFontTo: 7) - (setCodeFontTo: 5) - (setButtonFontTo: 5) - (setSystemFontTo: 6)). - Preferences disable: #biggerCursors.! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/26/2021 16:10:08' prior: 50473271! - defaultFont06 - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences defaultFont06 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 6) - (setMenuFontTo: 7) - (setWindowTitleFontTo: 8) - (setCodeFontTo: 6) - (setButtonFontTo: 6) - (setSystemFontTo: 7)). - Preferences disable: #biggerCursors.! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/26/2021 16:10:24' prior: 50473290! - defaultFont07 - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences defaultFont07 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 7) - (setMenuFontTo: 8) - (setWindowTitleFontTo: 9) - (setCodeFontTo: 7) - (setButtonFontTo: 7) - (setSystemFontTo: 8)). - Preferences disable: #biggerCursors.! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/26/2021 11:44:48' prior: 50473309! - defaultFont08 - "Sets not only fonts but other GUI elements - to fit low resolution or small screens - Preferences defaultFont08 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 8) - (setMenuFontTo: 9) - (setWindowTitleFontTo: 10) - (setCodeFontTo: 8) - (setButtonFontTo: 8) - (setSystemFontTo: 8)). - Preferences disable: #biggerCursors.! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/26/2021 16:11:11' prior: 50473327! - defaultFont09 - "Sets not only fonts but other GUI elements - to fit low resolution or small screens - Preferences defaultFont09 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 9) - (setMenuFontTo: 10) - (setWindowTitleFontTo: 11) - (setCodeFontTo: 9) - (setButtonFontTo: 9) - (setSystemFontTo: 9)). - Preferences disable: #biggerCursors.! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/26/2021 16:11:25' prior: 50472595! - defaultFont10 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont10 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 10) - (setMenuFontTo: 11) - (setWindowTitleFontTo: 12) - (setCodeFontTo: 10) - (setButtonFontTo: 10) - (setSystemFontTo: 10)). - Preferences disable: #biggerCursors.! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/26/2021 16:11:39' prior: 50472614! - defaultFont11 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont11 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 11) - (setMenuFontTo: 12) - (setWindowTitleFontTo: 14) - (setCodeFontTo: 11) - (setButtonFontTo: 11) - (setSystemFontTo: 11)). - Preferences disable: #biggerCursors.! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/26/2021 16:11:56' prior: 50472633! - defaultFont12 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont12 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 12) - (setMenuFontTo: 12) - (setWindowTitleFontTo: 14) - (setCodeFontTo: 12) - (setButtonFontTo: 12) - (setSystemFontTo: 12)). - Preferences disable: #biggerCursors.! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/26/2021 11:34:32' prior: 50472652! - defaultFont14 - "Sets not only fonts but other GUI elements - to fit medium resolution or medium size screens - Preferences defaultFont14 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 14) - (setMenuFontTo: 14) - (setWindowTitleFontTo: 17) - (setCodeFontTo: 14) - (setButtonFontTo: 14) - (setSystemFontTo: 14)). - Preferences disable: #biggerCursors.! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/26/2021 16:12:19' prior: 50472671! - defaultFont17 - "Sets not only fonts but other GUI elements - to fit high resolution or large screens - Preferences defaultFont17 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 17) - (setMenuFontTo: 17) - (setWindowTitleFontTo: 22) - (setCodeFontTo: 17) - (setButtonFontTo: 17) - (setSystemFontTo: 17)). - Preferences enable: #biggerCursors.! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/26/2021 16:12:27' prior: 50472689! - defaultFont22 - "Sets not only fonts but other GUI elements - to fit high resolution or large screens - Preferences defaultFont22 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 22) - (setMenuFontTo: 22) - (setWindowTitleFontTo: 28) - (setCodeFontTo: 22) - (setButtonFontTo: 22) - (setSystemFontTo: 22)). - Preferences enable: #biggerCursors.! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/26/2021 16:13:01' prior: 50472707! - defaultFont28 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont28 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 28) - (setMenuFontTo: 28) - (setWindowTitleFontTo: 36) - (setCodeFontTo: 28) - (setButtonFontTo: 28) - (setSystemFontTo: 28)). - Preferences enable: #biggerCursors.! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/26/2021 16:13:18' prior: 50472726! - defaultFont36 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont36 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 36) - (setMenuFontTo: 36) - (setWindowTitleFontTo: 46) - (setCodeFontTo: 36) - (setButtonFontTo: 36) - (setSystemFontTo: 36)). - Preferences enable: #biggerCursors.! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/26/2021 16:13:39' prior: 50472745! - defaultFont46 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont46 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 46) - (setMenuFontTo: 46) - (setWindowTitleFontTo: 60) - (setCodeFontTo: 46) - (setButtonFontTo: 46) - (setSystemFontTo: 46)). - Preferences enable: #biggerCursors.! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/26/2021 16:14:03' prior: 50472764! - defaultFont60 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont60 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 60) - (setMenuFontTo: 60) - (setWindowTitleFontTo: 80) - (setCodeFontTo: 60) - (setButtonFontTo: 60) - (setSystemFontTo: 60)). - Preferences enable: #biggerCursors.! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/26/2021 16:14:44' prior: 50472783! - defaultFont80 - "Sets not only fonts but other GUI elements - to fit very high resolution or very large screens - Preferences defaultFont80 - " - - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: #( - (setListFontTo: 80) - (setMenuFontTo: 80) - (setWindowTitleFontTo: 80) - (setCodeFontTo: 80) - (setButtonFontTo: 80) - (setSystemFontTo: 80)). - Preferences enable: #biggerCursors.! ! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 8/26/2021 16:51:21' prior: 50523180! - setDefaultFont: fontFamilyName spec: defaultFontsSpec - - | font | - defaultFontsSpec do: [ :triplet | - font _ FontFamily familyName: fontFamilyName pointSize: triplet second. - font ifNil: [ font _ FontFamily defaultFamilyAndPointSize ]. - triplet size > 2 ifTrue: [ - font _ font emphasized: triplet third ]. - self - perform: triplet first - with: font ]. - UISupervisor ui ifNotNil: [ :w | w fontPreferenceChanged ]. - MorphicCanvas allSubclassesDo: [ :c| c guiSizePreferenceChanged ].! ! -!Preferences class methodsFor: 'bigger and smaller GUI element sizes' stamp: 'jmv 8/26/2021 11:56:07' prior: 16893484! - scrollbarThickness - "Includes border" - ^Preferences standardListFont pointSize * 9 // 7! ! -!SystemWindow methodsFor: 'geometry' stamp: 'jmv 8/26/2021 16:33:48' prior: 50500259 overrides: 50499537! - minimumExtent - - ^layoutMorph minimumExtent + (borderWidth * 2) + (0@self labelHeight) - max: Theme current titleBarButtonsExtent x * 6 @ 0! ! -!SystemWindow methodsFor: 'geometry' stamp: 'jmv 8/26/2021 16:33:53' prior: 50471949! - rescaleButtons - "boxExtent changed. Update my buttons." - | buttonPos buttonExtent buttonDelta| - buttonExtent := Theme current titleBarButtonsExtent. - buttonPos _ self labelHeight + borderWidth - buttonExtent // 2 * (1@1). - buttonDelta _ buttonExtent x *14//10. - self submorphsReverseDo: [ :aMorph | - (aMorph is: #PluggableButtonMorph) - ifTrue: [ - aMorph morphExtent: buttonExtent. - aMorph morphPosition: buttonPos. - buttonPos _ buttonPos + (buttonDelta@0). - ]. - ]! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 8/26/2021 16:33:15' prior: 50577963! - createCloseButton - ^ (PluggableButtonMorph model: self action: #closeBoxHit) - iconDrawSelector: #drawCloseIcon; - setBalloonText: 'close this window'; - morphExtent: Theme current titleBarButtonsExtent! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 8/26/2021 16:33:20' prior: 50577973! - createCollapseButton - ^(PluggableButtonMorph model: self action: #collapse) - iconDrawSelector: #drawCollapseIcon; - setBalloonText: 'collapse this window'; - morphExtent: Theme current titleBarButtonsExtent! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 8/26/2021 16:33:24' prior: 50577983! - createExpandButton - ^ (PluggableButtonMorph model: self action: #expandBoxHit) - iconDrawSelector: #drawExpandIcon; - setBalloonText: 'expand to full screen'; - morphExtent: Theme current titleBarButtonsExtent! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 8/26/2021 16:33:28' prior: 50577993! - createMenuButton - ^ (PluggableButtonMorph model: self action: #offerWindowMenu) - iconDrawSelector: #drawMenuIcon; - setBalloonText: 'window menu'; - morphExtent: Theme current titleBarButtonsExtent! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 8/26/2021 16:33:37' prior: 50541151! - initializeLabelArea - "Initialize the label area (titlebar) for the window." - - | topLeft spacing | - topLeft _ (self labelHeight + borderWidth - Theme current titleBarButtonsExtent / 2) ceiling asPoint. - spacing _ Theme current titleBarButtonsExtent x *14//10. - self addMorph: self createCloseButton position: topLeft. - self addMorph: self createCollapseButton position: spacing@0 + topLeft. - self addMorph: self createExpandButton position: spacing*2@0 + topLeft. - self addMorph: self createMenuButton position: spacing*3@0 + topLeft! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 8/26/2021 16:58:52' prior: 50578002! - addStayUpIcons - | closeButton pinButton w buttonHW | - Preferences optionalButtons ifFalse: [ ^self ]. - (self valueOfProperty: #hasStayUpIcons ifAbsent: [ false ]) - ifTrue: [ - self removeProperty: #needsStayUpIcons. - ^self ]. - titleMorph ifNil: [ - "Title not yet there. Flag ourself, so this method is called again when adding title." - self setProperty: #needsStayUpIcons toValue: true. - ^ self]. - buttonHW _ Theme current titleBarButtonsExtent x. - closeButton _ PluggableButtonMorph model: self action: #delete. - closeButton iconDrawSelector: #drawCloseIcon; color: `Color transparent`. - pinButton _ PluggableButtonMorph model: self action: #stayUp. - pinButton iconDrawSelector: #drawPushPinIcon; color: `Color transparent`. - w _ (titleMorph hasSubmorphs ifTrue: [ titleMorph firstSubmorph morphWidth ] ifFalse: [ 0 ]) + 60. - self addMorphFront: - (LayoutMorph newRow - "Make room for buttons" - morphExtent: w @ (titleMorph morphHeight max: buttonHW); - color: `Color transparent`; - addMorph: closeButton fixedWidth: buttonHW; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedWidth: buttonHW//7; - addMorph: titleMorph proportionalWidth: 1; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedWidth: buttonHW//7; - addMorph: pinButton fixedWidth: buttonHW; - addMorph: (WidgetMorph new noBorder color: `Color transparent`) fixedWidth: buttonHW//3). - - self setProperty: #hasStayUpIcons toValue: true. - self removeProperty: #needsStayUpIcons! ! -!MenuMorph methodsFor: 'menu' stamp: 'jmv 8/26/2021 16:46:43' prior: 16867119! - removeStayUpBox - | box | - submorphs isEmpty ifTrue: [^self]. - (submorphs first is: #LayoutMorph) ifFalse: [^self]. - box _ submorphs first submorphs second. - (box is: #PluggableButtonMorph) - ifTrue: [ box hide ]! ! -!Theme methodsFor: 'other options' stamp: 'jmv 8/26/2021 11:55:18' prior: 16935701! - roundedButtonRadius - "Only effective if #roundButtons answers true. - Provide a reasonable default for subclasses." - ^ Preferences roundedButtonRadius! ! -!Theme methodsFor: 'other options' stamp: 'jmv 8/26/2021 11:55:29' prior: 50578818! - roundedWindowRadius - "Only effective if #roundWindowCorners answers true. - Provide a reasonable default for subclasses." - ^Preferences roundedWindowRadius! ! - -SystemWindow removeSelector: #titleBarButtonsExtent! - -!methodRemoval: SystemWindow #titleBarButtonsExtent stamp: 'Install-4810-GUIPreferencesTweaks-JuanVuletich-2021Aug26-16h35m-jmv.004.cs.st 8/26/2021 17:22:02'! -titleBarButtonsExtent - "Answer the extent to use for close & other title bar buttons. - The label height is used to be proportional to the fonts preferences." - | e | - e _ Preferences windowTitleFont pointSize * 13 // 10. - ^e@e! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4810-GUIPreferencesTweaks-JuanVuletich-2021Aug26-16h35m-jmv.004.cs.st----! - -----QUIT----(26 August 2021 17:22:06) Cuis5.0-4810-v3.image priorSource: 8669329! - -----STARTUP---- (28 August 2021 20:07:41) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4810-v3.image! - - -'From Cuis 5.0 [latest update: #4810] on 27 August 2021 at 5:41:38 pm'! -!DisplayScreen methodsFor: 'accessing' stamp: 'jmv 8/27/2021 17:20:52'! - getMainCanvas - "Return a Canvas that can be used to draw onto the receiver" - ^MorphicCanvas withVectorEnginePluginOnForm: self! ! -!WorldMorph methodsFor: 'canvas' stamp: 'jmv 8/27/2021 17:26:47'! - setMainCanvas - self clearCanvas. "Deallocate before allocating could mean less memory stress." - self setCanvas: Display getMainCanvas. - damageRecorder _ DamageRecorder new. - self redrawNeeded! ! -!MorphicCanvas methodsFor: 'testing' stamp: 'jmv 8/27/2021 16:04:07'! - usesVectorEnginePlugin - ^false! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/27/2021 17:20:46'! - withVectorEnginePluginOnForm: aForm - "Note: Only one instance using VectorEnginePlugin should be acive at a time: - the plugin holds numeric parameters that are not passed again on every call." - - ^ self subclassToUse basicNew - setPluginAndForm: aForm; - initializeWithTranslation: `0@0`.! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 8/27/2021 17:17:56'! - setPluginAndForm: aForm - "nil means use default kind of anti aliasing" - - form _ aForm. - engine _ BitBltCanvasEngine toForm: form. - "Init BitBlt so that the first call to the 'primitiveDisplayString' primitive will not fail" - engine sourceX: 0; width: 0. - self newClipRect: nil.! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 8/27/2021 16:06:32' prior: 50579323! - okayToRotateEasily - "Answer whether it is appropriate for a rotation handle to be shown for the receiver." - - ^ self hasOwnLocation and: [self world canvas usesVectorEnginePlugin]! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 8/27/2021 16:06:44' prior: 50579332! - okayToScaleEasily - "Answer whether it is appropriate for a scale handle to be shown for the receiver." - - ^ self hasOwnLocation and: [self world canvas usesVectorEnginePlugin]! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 8/27/2021 17:27:32' prior: 50556450 overrides: 50556442! - extentChanged: oldExtent - "Our extent changed. Must layout submorphs again." - - super extentChanged: oldExtent. - self setMainCanvas! ! -!WorldMorph methodsFor: 'interaction loop' stamp: 'jmv 8/27/2021 17:23:17' prior: 50567011! - mainLoop - - - self clearWaitDelay. - canvas isNil ifTrue: [ - self setCanvas: Display getMainCanvas. - damageRecorder _ DamageRecorder new ]. - self redrawNeeded. - [ - self doOneCycle. - true ] - whileTrue: []! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 8/27/2021 17:27:28' prior: 50596631! - displayWorldSafely - "Update this world's display and keep track of errors during draw methods." - - [self displayWorld] ifErrorOrHalt: [ :err :rcvr | - "Handle a drawing error" - canvas currentMorphDrawingFails. - self setMainCanvas. - "Install the old error handler, so we can re-raise the error" - rcvr error: err. - ]! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 8/27/2021 17:25:41' prior: 50551819! - tryDeferredUpdatingAndSetCanvas - "If this platform supports deferred updates, then make my canvas be the Display (or a rectangular portion of it), set the Display to deferred update mode, and answer true. Otherwise, set a non-Disply canvas and answer false.." - | properDisplay | - - "As this is the only sender of #deferUpdates: , this could be done in Morphic or image startup, and never efterwards..." - (Display deferUpdates: true) ifNil: [ - "deferred updates not supported by the VM, do them in the image!!" - self ensureNonDisplayCanvas. - ^ false]. - - "if no canvas, or canvas was offscreen, from a platform that didnt support defers, then fix it" - properDisplay _ canvas notNil and: [canvas drawsOnDisplay]. - properDisplay ifFalse: [ - self morphPosition: `0@0` extent: Display extent. - self setCanvas: Display getMainCanvas. - ]. - ^ true! ! -!WorldMorph class methodsFor: 'instance creation' stamp: 'jmv 8/27/2021 17:23:29' prior: 50552199! - newWorld - " -[ - UISupervisor stopUIProcess. - UISupervisor spawnNewMorphicProcessFor: WorldMorph newWorld -] fork. - " - | w | - w _ self new. - w morphPosition: `0@0` extent: Display extent. - w setCanvas: Display getMainCanvas. - w handsDo: [ :h | - h privateOwner: w ]. - ^w! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/27/2021 17:38:53' prior: 50553099! - activeSubclass: aMorphicCanvasSubclass - ActiveSubclass _ aMorphicCanvasSubclass. - UISupervisor ui setMainCanvas.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/27/2021 17:07:00' prior: 50596973! - onForm: aForm over: aRectangle - "Warning: aForm extent must equal aRectangle extent" - - ^ self subclassToUse basicNew - setForm: aForm subPixelAntiAliasing: false; - initializeWithTranslation: aRectangle topLeft negated.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 8/27/2021 17:06:54' prior: 50596983! - onForm: aForm translation: aPoint - - ^ self subclassToUse basicNew - setForm: aForm subPixelAntiAliasing: false; - initializeWithTranslation: aPoint.! ! - -MorphicCanvas class removeSelector: #isVectorGraphicsUsedForAllRendering! - -!methodRemoval: MorphicCanvas class #isVectorGraphicsUsedForAllRendering stamp: 'Install-4811-supportForAPriviledgedMainCanvas-JuanVuletich-2021Aug27-17h31m-jmv.003.cs.st 8/28/2021 20:07:45'! -isVectorGraphicsUsedForAllRendering - " - MorphicCanvas isVectorGraphicsUsedForAllRendering - " - ^MorphicCanvas activeSubclass name == #VectorDrawingCanvas! - -MorphicCanvas class removeSelector: #onFormWithWholePixelAntiAliasing:! - -!methodRemoval: MorphicCanvas class #onFormWithWholePixelAntiAliasing: stamp: 'Install-4811-supportForAPriviledgedMainCanvas-JuanVuletich-2021Aug27-17h31m-jmv.003.cs.st 8/28/2021 20:07:45'! -onFormWithWholePixelAntiAliasing: aForm - - ^ self onFormWithWholePixelAntiAliasing: aForm translation: `0@0`.! - -MorphicCanvas class removeSelector: #isVectorGraphicsActive! - -!methodRemoval: MorphicCanvas class #isVectorGraphicsActive stamp: 'Install-4811-supportForAPriviledgedMainCanvas-JuanVuletich-2021Aug27-17h31m-jmv.003.cs.st 8/28/2021 20:07:45'! -isVectorGraphicsActive - " - MorphicCanvas isVectorGraphicsActive - " - ^MorphicCanvas activeSubclass ~~ BitBltCanvas ! - -MorphicCanvas class removeSelector: #isVectorGraphicsPluginActive! - -!methodRemoval: MorphicCanvas class #isVectorGraphicsPluginActive stamp: 'Install-4811-supportForAPriviledgedMainCanvas-JuanVuletich-2021Aug27-17h31m-jmv.003.cs.st 8/28/2021 20:07:45'! -isVectorGraphicsPluginActive - " - MorphicCanvas isVectorGraphicsPluginActive - " - ^self isVectorGraphicsActive and: [ - (Smalltalk at: #VectorEngineWithPlugin) isPluginAvailable ]! - -MorphicCanvas class removeSelector: #onFormWithWholePixelAntiAliasing:translation:! - -!methodRemoval: MorphicCanvas class #onFormWithWholePixelAntiAliasing:translation: stamp: 'Install-4811-supportForAPriviledgedMainCanvas-JuanVuletich-2021Aug27-17h31m-jmv.003.cs.st 8/28/2021 20:07:45'! -onFormWithWholePixelAntiAliasing: aForm translation: aPoint - - ^ self subclassToUse basicNew - setForm: aForm subPixelAntiAliasing: false; - initializeWithTranslation: aPoint.! - -WorldMorph removeSelector: #setCanvas! - -!methodRemoval: WorldMorph #setCanvas stamp: 'Install-4811-supportForAPriviledgedMainCanvas-JuanVuletich-2021Aug27-17h31m-jmv.003.cs.st 8/28/2021 20:07:45'! -setCanvas - self clearCanvas. "Deallocate before allocating could mean less memory stress." - self setCanvas: Display getCanvas. - damageRecorder _ DamageRecorder new. - self redrawNeeded! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4811-supportForAPriviledgedMainCanvas-JuanVuletich-2021Aug27-17h31m-jmv.003.cs.st----! - -'From Cuis 5.0 [latest update: #4811] on 27 August 2021 at 7:56:57 pm'! -!Morph methodsFor: 'geometry services' stamp: 'jmv 8/27/2021 14:06:57' prior: 50593382! - collides: aMorph - "Answer whether the pixels used by morphs touch at least at one place. - Morphs not in the WidgetMorph hierarchy should answer #true to wantsContour." - - privateDisplayBounds ifNil: [ - ^false ]. - - "Quick check with display bounds" - (aMorph displayBoundsIntersects: (privateDisplayBounds outsetBy: 1)) ifFalse: [ - ^false ]. - - "Precise check with contour, if available" - (self valueOfProperty: #contour) ifNotNil: [ :contour | | contourTop contourBottom | - contourTop _ self valueOfProperty: #contourY0. - contourBottom _ self valueOfProperty: #contourY1. - ^ aMorph contourIntersects: contour top: contourTop bottom: contourBottom ]. - - "If contour is not available, and both displayBounds overlap, answer true, as it is the best we can know." - ^ true! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 8/26/2021 17:38:12' prior: 50596758! - drawCurrentAsError - "The morph (or one of its submorphs) had an error in its drawing method." - | r w | - r _ currentMorph morphLocalBoundsForError. - w _ r extent > `50@50` - ifTrue: [ 6 ] - ifFalse: [ 2 ]. - self - frameAndFillRectangle: r - fillColor: `Color red` - borderWidth: w - borderColor: `Color yellow`. - self line: r topLeft+1 to: r bottomRight-7 width: w color: `Color yellow`. - self line: r topRight + (-7@1) to: r bottomLeft + (1@ -7) width: w color: `Color yellow`. - currentMorph displayBoundsSetFrom: self.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4812-tweaks-JuanVuletich-2021Aug27-19h49m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4812] on 28 August 2021 at 7:16:28 pm'! -!ObjectExplorerWrapper methodsFor: 'monitoring' stamp: 'jmv 8/28/2021 19:13:11' prior: 16883572! - refresh - "Refresh item given an object and a string that is either an index or an instance variable name." - | index | - (model class allInstVarNames includes: itemName) - ifTrue: [ - item _ model instVarNamed: itemName ] - ifFalse: [ - item _ nil. - index _ itemName findPositiveInteger. - (index notNil and: [index between: 1 and: model basicSize]) ifTrue: [ - item _ model basicAt: index]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4813-FixObjectExplorerRootMonitoring-JuanVuletich-2021Aug28-19h16m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4812] on 28 August 2021 at 7:17:31 pm'! -!ContextPart methodsFor: 'debugger access' stamp: 'jmv 8/28/2021 19:05:56' prior: 16824192! - tempsAndValuesLimitedTo: sizeLimit indent: indent - "Return a string of the temporary variabls and their current values" - - | aStream tempNames title | - aStream _ WriteStream on: (String new: 100). - tempNames _ self tempNames. - 1 to: self size do: [ :index | - title _ tempNames size = self size ifTrue: [tempNames at: index] ifFalse: [ 'argOrTemp', index printString ]. - indent timesRepeat: [aStream tab]. - aStream nextPutAll: title; nextPut: $:; space; tab. - aStream nextPutAll: - ((self tempAt: index) printStringLimitedTo: (sizeLimit -3 -title size max: 1)). - aStream newLine]. - ^aStream contents! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4814-ErrorLoggingFix-JuanVuletich-2021Aug28-19h16m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4814] on 28 August 2021 at 7:29:54 pm'! -!ImageMorph methodsFor: 'accessing' stamp: 'jmv 8/28/2021 19:27:55' prior: 50556582! - image: anImage - - image _ anImage depth = 1 - ifTrue: [ ColorForm mappingWhiteToTransparentFrom: anImage ] - ifFalse: [ anImage ]. - self morphExtent: self minimumExtent. - self redrawNeeded.! ! - -ImageMorph removeSelector: #morphExtent:! - -!methodRemoval: ImageMorph #morphExtent: stamp: 'Install-4815-ImageMorph-fix-JuanVuletich-2021Aug28-19h20m-jmv.001.cs.st 8/28/2021 20:07:45'! -morphExtent: aPoint - "Do nothing; my extent is determined by my image Form." - - "A clear case of a morph that shouldn't have an 'extent' ivar..." - self flag: #jmvVer2.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4815-ImageMorph-fix-JuanVuletich-2021Aug28-19h20m-jmv.001.cs.st----! - -----QUIT----(28 August 2021 20:07:48) Cuis5.0-4815-v3.image priorSource: 8687259! - -----STARTUP---- (3 September 2021 15:02:46) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4815-v3.image! - - -'From Cuis 5.0 [latest update: #4815] on 30 August 2021 at 11:41:50 am'! -!WidgetMorph methodsFor: 'halos and balloon help' stamp: 'jmv 8/30/2021 11:41:09' overrides: 50577042! - okayToResizeEasily - "Answer whether it is appropriate to have the receiver be easily resized by the user from the halo" - - ^ true.! ! -!WidgetMorph methodsFor: 'halos and balloon help' stamp: 'jmv 8/30/2021 11:40:56' overrides: 50603180! - okayToRotateEasily - "Answer whether it is appropriate for a rotation handle to be shown for the receiver." - - ^ self world canvas usesVectorEnginePlugin.! ! -!WidgetMorph methodsFor: 'halos and balloon help' stamp: 'jmv 8/30/2021 11:41:05' overrides: 50603189! - okayToScaleEasily - "Answer whether it is appropriate for a scale handle to be shown for the receiver." - - ^ self world canvas usesVectorEnginePlugin.! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 8/30/2021 11:41:24' prior: 50603180! - okayToRotateEasily - "Answer whether it is appropriate for a rotation handle to be shown for the receiver." - - ^ self hasOwnLocation! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 8/30/2021 11:41:30' prior: 50603189! - okayToScaleEasily - "Answer whether it is appropriate for a scale handle to be shown for the receiver." - - ^ self hasOwnLocation! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4816-AlwaysEnableZoomRotateForNonWidgets-JuanVuletich-2021Aug30-11h40m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4815] on 30 August 2021 at 11:52:44 am'! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/30/2021 11:48:44' prior: 50473244! - bigFonts - "Sets not only fonts but other GUI elements - to fit regular resolution and size screens - Preferences bigFonts - " - - self defaultFont22! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/30/2021 11:51:19' prior: 50473345! - hugeFonts - "Sets not only fonts but other GUI elements - to fit regular resolution and size screens - Preferences hugeFonts - " - - self defaultFont60! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/30/2021 11:47:04' prior: 50473353! - smallFonts - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences smallFonts - " - - self defaultFont12! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/30/2021 11:50:41' prior: 50473380! - veryBigFonts - "Sets not only fonts but other GUI elements - to fit regular resolution and size screens - Preferences veryBigFonts - " - - self defaultFont36! ! -!Preferences class methodsFor: 'bigger and smaller GUI' stamp: 'jmv 8/30/2021 11:47:10' prior: 50473389! - verySmallFonts - "Sets not only fonts but other GUI elements - to fit very low resolution or very small screens - Preferences verySmallFonts - " - - self defaultFont10! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 8/30/2021 11:44:13' prior: 50552222! -preferencesMenu - "Build the preferences menu for the world." - - ^ (self menu: 'Preferences...') - addItemsFromDictionaries: { - { - #label -> 'Focus follows mouse'. - #object -> Preferences. - #selector -> #enableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one on which the mouse is located.' - } asDictionary. - { - #label -> 'Click to focus'. - #object -> Preferences. - #selector -> #disableFocusFollowsMouse. - #icon -> #windowIcon. - #balloonText -> 'At all times, make the active window and widget the one where the mouse was clicked.' - } asDictionary. - { - #label -> 'Size of GUI elements...'. - #object -> Theme. - #selector -> #changeFontSizes. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'use larger or smaller text and widgets' - } asDictionary. - { - #label -> 'Set System Font...'. - #object -> FontFamily. - #selector -> #promptUserAndSetDefault. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'change the current system font family.' - } asDictionary. - { - #label -> 'Load all TrueType Fonts'. - #object -> FontFamily. - #selector -> #readAdditionalTrueTypeFonts. - #icon -> #preferencesDesktopFontIcon. - #balloonText -> 'Load additional TrueType fonts included with Cuis.' - } asDictionary. - { - #label -> 'Icons...'. - #object -> Theme. - #selector -> #changeIcons. - #icon -> #worldIcon. - #balloonText -> 'show more or less icons.' - } asDictionary. - { - #label -> 'Themes...'. - #object -> Theme. - #selector -> #changeTheme. - #icon -> #appearanceIcon. - #balloonText -> 'switch to another theme.' - } asDictionary. - nil. - { - #label -> 'Show taskbar'. - #object -> #myWorld. - #selector -> #showTaskbar. - #icon -> #expandIcon. - #balloonText -> 'show the taskbar' - } asDictionary. - { - #label -> 'Hide taskbar'. - #object -> #myWorld. - #selector -> #hideTaskbar. - #icon -> #collapseIcon. - #balloonText -> 'hide the taskbar' - } asDictionary. - nil. - { - #label -> 'Full screen on'. - #selector -> #fullScreenOn. - #icon -> #viewFullscreenIcon. - #balloonText -> 'puts you in full-screen mode, if not already there.' - } asDictionary. - { - #label -> 'Full screen off'. - #selector -> #fullScreenOff. - #icon -> #exitFullscreenIcon. - #balloonText -> 'if in full-screen mode, takes you out of it.' - } asDictionary. - nil. - { - #label -> 'Set Code Author...'. - #object -> Utilities. - #selector -> #setAuthor. - #icon -> #usersIcon. - #balloonText -> 'supply initials to be used to identify the author of code and other content.' - } asDictionary. - { - #label -> 'All preferences...'. - #object -> Preferences. - #selector -> #openPreferencesInspector. - #icon -> #preferencesIcon. - #balloonText -> 'view and change various options.' - } asDictionary. - }! ! -!Theme class methodsFor: 'user interface' stamp: 'jmv 8/30/2021 11:43:38' prior: 50437270! - changeFontSizes - - (MenuMorph new defaultTarget: Preferences) - addTitle: 'Make GUI elements'; - addStayUpIcons; - add: 'Huge' action: #hugeFonts; - add: 'Very Big' action: #veryBigFonts; - add: 'Big' action: #bigFonts; - add: 'Standard Size' action: #standardFonts; - add: 'Small' action: #smallFonts; - add: 'Very Small'action: #verySmallFonts; - add: 'Tiny'action: #tinyFonts; - popUpInWorld: self runningWorld! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4817-GUISizingOptionsTweaks-JuanVuletich-2021Aug30-11h41m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4815] on 30 August 2021 at 12:04:28 pm'! -!StringRequestMorph methodsFor: 'initialization' stamp: 'jmv 8/30/2021 11:58:02' prior: 50548596 overrides: 50547035! - defaultBorderWidth - "Answer the default border width for the receiver." - ^ Theme current windowBorderWidth! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4818-StringRequestMorph-fix-JuanVuletich-2021Aug30-11h52m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4818] on 30 August 2021 at 12:44:30 pm'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 8/30/2021 12:43:22' prior: 50598731! -snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag - "This is the main method for image save and / or quit. - See senders." - "WARNING: Current process will be killed. UI Process will be restarted" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic - checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " - | activeProc | - activeProc _ Processor activeProcess. - [ | isARealStartup guiRootObject guiRootObjectClass | - save not & quit - ifTrue: [ - (SourceFiles at: 2) ifNotNil: [ :changes | - ChangesInitialFileSize ifNotNil: [ changes truncate: ChangesInitialFileSize ]]] - ifFalse: [ - self - logSnapshot: save - andQuit: quit ]. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | - each isInWorld ifTrue: [ - each delete.]]. - UISupervisor ui tearDownDesktop. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - "Cosas que levanto explicitamente abajo" - guiRootObjectClass _ UISupervisor ui class. - guiRootObject _ UISupervisor ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "guiRootObject _ clearAllStateFlag ifFalse: [ UISupervisor ui ]." - UISupervisor stopUIProcess. - activeProc isTerminated ifFalse: [ activeProc terminate ]. - guiRootObject ifNotNil: [ guiRootObject releaseCachedState ]. - "Clean Globals" - Smalltalk - at: #Sensor - put: nil. - Smalltalk - at: #Display - put: nil. - Smalltalk closeSourceFiles. - Smalltalk - at: #SourceFiles - put: nil. - Smalltalk allClassesDo: [ :cls | - cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | - cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ - Smalltalk printStuffToCleanOnImageSave. - "Remove this call to actually see the image clean report." - Transcript clear. - ]. - "Do image save & quit as apropriate" - (Cursor cursorAt: #writeCursor) activateCursor. - save - ifTrue: [ - "The snapshot primitive answers false if it was just called to do the snapshot. - But image startup is resumed by returning (again) from the primitive, but this time answering true." - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk - at: #Sensor - put: nil. - Smalltalk - at: #Display - put: DisplayScreen new. - Smalltalk - at: #SourceFiles - put: (Array new: 2). - Smalltalk openSourceFiles. - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | - cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - UISupervisor spawnNewMorphicProcessFor: (guiRootObject ifNil: [ guiRootObject _ guiRootObjectClass newWorld ]). - self restoreLostChangesIfNecessary. - clearAllStateFlag ifTrue: [ - UISupervisor whenUIinSafeState: [ - guiRootObject recreateDefaultDesktop; restoreDisplay. - Display triggerEvent: #screenSizeChanged ]] - ifFalse: [ - UISupervisor whenUIinSafeState: [ - guiRootObject restoreDisplay. - Display triggerEvent: #screenSizeChanged ]]. - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - UISupervisor whenUIinSafeState: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]] - forkAt: Processor timingPriority - 1 - named: 'Startup process'.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4819-ClearMorphicCanvasOnImageSave-JuanVuletich-2021Aug30-12h43m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4819] on 30 August 2021 at 4:25:57 pm'! -!TranscriptWindow methodsFor: 'geometry testing' stamp: 'jmv 8/30/2021 16:25:26' overrides: 50560031! - clipsSubmorphs - "Our contents are not inside a PluggableScrollPane like in other SystemWindows, - so we do the clipping ourselves." - - ^ true! ! - -TranscriptMorph removeSelector: #clipsSubmorphs! - -!methodRemoval: TranscriptMorph #clipsSubmorphs stamp: 'Install-4820-TranscriptWindow-fix-JuanVuletich-2021Aug30-16h24m-jmv.001.cs.st 9/3/2021 15:02:51'! -clipsSubmorphs - "Answer true if we clip the shape of our submorphs to our own. - Answer true only when clipping by the canvas is needed. - Morphs that can guarantee that submorphs don't protrude and answer false to - #submorphsMightProtrude should answer false for better performance" - - ^ true! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4820-TranscriptWindow-fix-JuanVuletich-2021Aug30-16h24m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4820] on 30 August 2021 at 5:45:18 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 8/30/2021 17:42:48' prior: 50596805! - displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Clipped appropiately if some owner clips us. - See also #displayBoundsUpdateFrom:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - (aCanvas isBoundsFinderCanvas or: [c canvasToUse == aCanvas canvasToUse]) ifTrue: [ - self knowsOwnLocalBounds - ifTrue: [ - "A good optimization in many cases. - But for morphs where #drawOn: might not be able to find bounds (InnerTextMorph and LayoutMorph, - for example) this is essential." - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphFromLocalBounds] - ifFalse: [ - "Use the bounds bound by #drawOn. This method must therefore be called after calling #drawOn:." - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphAfterDraw. - self wantsContour - ifTrue: [ - (aCanvas - contourOfCurrentMorphAfterDrawInto: (self valueOfProperty: #contour) - into: [ :contourArray :contourY0 :contourY1 | - self setProperty: #contour toValue: contourArray. - self setProperty: #contourY0 toValue: contourY0. - self setProperty: #contourY1 toValue: contourY1. - ])] - ifFalse: [ - self setProperty: #contour toValue: nil. - self setProperty: #contourY0 toValue: nil. - self setProperty: #contourY1 toValue: nil ]]]]].! ! -!WindowEdgeAdjustingMorph methodsFor: 'adjusting' stamp: 'jmv 8/30/2021 17:43:48' prior: 50594879 overrides: 50591463! - adjustOwnerAt: aGlobalPoint millisecondSinceLast: millisecondSinceLast - - self basicAdjustOwnerAt: aGlobalPoint. - - "If UI is becoming slow or is optimized for slow systems, resize without - showing window contents, but only edges. But don't do it for rotated Windows!!" - (owner isOrAnyOwnerIsRotated not and: [ - Preferences cheapWindowReframe or: [millisecondSinceLast > 200]]) ifTrue: [ - Preferences cheapWindowReframe ifFalse: [ Preferences enable: #cheapWindowReframe ]. - owner displayBounds newRectFrom: [ :f | - self basicAdjustOwnerAt: Sensor mousePoint. - owner morphPosition extent: owner morphExtentInWorld ]].! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 8/30/2021 17:44:18' prior: 50571239! - drawCurrentAsOutline - - self isCurrentMorphVisible ifTrue: [ - currentMorph displayBoundsSetFrom: self. - self frameReverseGlobalRect: currentMorph displayBounds borderWidth: 2 ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4821-CheapWindowRefeame-fixes-JuanVuletich-2021Aug30-17h42m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4821] on 31 August 2021 at 12:39:07 pm'! -!CodeWindow methodsFor: 'GUI building' stamp: 'KLG 8/31/2021 12:53:05' prior: 50597784! - optionalButtonTuples - "Answer a tuple buttons, in the format: - button label - selector to send - help message" - - | aList textConstructor | - textConstructor _ [ :string :backgroundColor | - string asText addAttribute: (TextBackgroundColor color: backgroundColor) ]. - - aList _ #( - (10 'browse' browseMethodFull 'view this method in a browser') - (11 'senders' browseSendersOfMessages 'browse senders of...') - (16 'implementors' browseMessages 'browse implementors of...') - (12 'versions' browseVersions 'browse versions')), - - (Preferences decorateBrowserButtons - ifTrue: - [{{13 . 'inheritance'. #methodInheritance. 'browse method inheritance - -', (textConstructor value:'green' value: `Color green muchLighter`),': sends to super -', (textConstructor value: 'tan' value: `Color tan`), ': has override(s) -', (textConstructor value: 'mauve' value: `Color blue muchLighter`), ': both of the above -', (textConstructor value: 'pink' value: `Color red muchLighter`), ': is an override but doesn''t call super -', (textConstructor value: 'pinkish tan' value: `Color r: 0.94 g: 0.823 b: 0.673`), ': has override(s), also is an override but doesn''t call super'}}] - ifFalse: - [{#(13 'inheritance' methodInheritance 'browse method inheritance')}]), - - #( - (12 'hierarchy' browseHierarchy 'browse class hierarchy') - (10 'inst vars' browseInstVarRefs 'inst var refs...') - (11 'class vars' browseClassVarRefs 'class var refs...') - (10 'show...' offerWhatToShowMenu 'menu of what to show in lower pane')). - - ^ aList! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4822-InheritanceButtonBalloon-GeraldKlix-2021Aug31-12h36m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4822] on 31 August 2021 at 5:33:26 pm'! -!WorldMorph methodsFor: 'canvas' stamp: 'jmv 8/31/2021 17:05:43'! - resetCanvas - "To be called in case of possible inconsistency due to an exception during drawing. - See #displayWorldSafely" - - canvas resetCanvas. - damageRecorder _ DamageRecorder new. - self redrawNeeded! ! -!MorphicCanvas methodsFor: 'initialization' stamp: 'jmv 8/31/2021 17:05:32'! - resetCanvas - "To be called in case of possible inconsistency due to an exception during drawing. - See #displayWorldSafely" - - cti _ 1. - currentTransformation _ transformations at: 1.! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 8/31/2021 17:06:38' prior: 50603216! - displayWorldSafely - "Update this world's display and keep track of errors during draw methods." - - [self displayWorld] on: Error, Halt do: [ :err :rcvr | - "Handle a drawing error" - canvas currentMorphDrawingFails. - "Creating a new canvas here could be dangerous, as code signaling the exception will be resumed." - self resetCanvas. - "Install the old error handler, so we can re-raise the error" - rcvr error: err. - ]! ! -!MorphicCanvas methodsFor: 'initialization' stamp: 'jmv 8/31/2021 17:04:10' prior: 50596952! - initializeWithTranslation: aPoint - "Set up these only on initialization." - - currentTransformation _ MorphicTranslation withTranslation: aPoint. - cti _ 1. - transformations - ifNil: [ transformations _ OrderedCollection with: currentTransformation ] - ifNotNil: [ transformations at: cti put: currentTransformation ]. - drawingMorphStack - ifNil: [ drawingMorphStack _ OrderedCollection with: nil ] - ifNotNil: [ drawingMorphStack at: cti put: nil ].! ! - -BlockClosure removeSelector: #ifErrorOrHalt:! - -!methodRemoval: BlockClosure #ifErrorOrHalt: stamp: 'Install-4823-resetCanvas-JuanVuletich-2021Aug31-17h31m-jmv.001.cs.st 9/3/2021 15:02:51'! -ifErrorOrHalt: errorHandlerBlock - "Evaluate the block represented by the receiver, and normally return it's value. If an error occurs, the errorHandlerBlock is evaluated, and it's value is instead returned. The errorHandlerBlock must accept zero, one, or two parameters (the error message and the receiver)." - "Examples: - [1 halt] ifErrorOrHalt: [:err :rcvr | 'huh?']. - [1 whatsUpDoc] ifErrorOrHalt: [:err :rcvr | 'huh?']. - [1 / 0] ifErrorOrHalt: [:err :rcvr | - 'ZeroDivide' = err - ifTrue: [Float infinity] - ifFalse: [self error: err]] -" - - ^ self on: Error, Halt do: [ :ex | - errorHandlerBlock valueWithPossibleArgument: ex description and: ex receiver ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4823-resetCanvas-JuanVuletich-2021Aug31-17h31m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4822] on 31 August 2021 at 5:36:52 pm'! -!MovableMorph methodsFor: 'initialization' stamp: 'jmv 8/31/2021 17:11:29' prior: 50554400 overrides: 50554652! - openInWorld: aWorld - "Add this morph to the requested World." - location isIdentity - ifTrue: [ - aWorld - addMorph: self - position: (Display width*8//10) atRandom@(Display height*8//10) atRandom + (Display extent //10) ] - ifFalse: [ aWorld addMorph: self ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4824-NewMorphsAtRandomPositions-JuanVuletich-2021Aug31-17h33m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4822] on 1 September 2021 at 11:34:10 am'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 9/1/2021 11:26:37'! - contourOfCurrentMorphAfterDrawInto: anArray into: aBlock - "We don't compute contours. See other implementors."! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 9/1/2021 11:33:22' prior: 50603937! -displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Clipped appropiately if some owner clips us. - See also #displayBoundsUpdateFrom:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - (aCanvas isBoundsFinderCanvas or: [c canvasToUse == aCanvas canvasToUse]) ifTrue: [ - privateDisplayBounds _ aCanvas boundingRectOfCurrentMorphAfterDraw. - self wantsContour - ifTrue: [ - (aCanvas - contourOfCurrentMorphAfterDrawInto: (self valueOfProperty: #contour) - into: [ :contourArray :contourY0 :contourY1 | - self setProperty: #contour toValue: contourArray. - self setProperty: #contourY0 toValue: contourY0. - self setProperty: #contourY1 toValue: contourY1 ])] - ifFalse: [ - self setProperty: #contour toValue: nil. - self setProperty: #contourY0 toValue: nil. - self setProperty: #contourY1 toValue: nil ]]]].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 9/1/2021 11:33:11' prior: 50595507! - displayBoundsUpdateFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us. - To be called after #postDrawOn:. See also #displayBoundsSetFrom: - This more complicated update is needed because the contour information from #drawOn: was possibly - when drawing submorphs. So, the controur from #drawOn: needs to be retrieved, and updated with the - new contour information from #postDrawOn:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - (aCanvas isBoundsFinderCanvas or: [c canvasToUse == aCanvas]) ifTrue: [ - privateDisplayBounds _ privateDisplayBounds - quickMerge: aCanvas boundingRectOfCurrentMorphAfterDraw. - self wantsContour ifTrue: [ - (aCanvas - contourOfCurrentMorphAfterDrawUpdate: (self valueOfProperty: #contour) - oldTop: (self valueOfProperty: #contourY0) - oldBottom: (self valueOfProperty: #contourY1) - into: [ :contourArray :contourY0 :contourY1 | - self setProperty: #contour toValue: contourArray. - self setProperty: #contourY0 toValue: contourY0. - self setProperty: #contourY1 toValue: contourY1 ])]]]].! ! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 9/1/2021 11:14:29' prior: 50536534! -boundingRectOfCurrentMorphAfterDraw - "In targetForm coordinates. - Clipped to owner if appropriate. - Only valid for morphs where #morphLocalBounds is known. - Subclasses may raise this restrinction. See inherintance, with VectorGraphics package loaded." - - | boundingRect | - boundingRect _ currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds. - ^ clippingMorphDisplayBounds - ifNotNil: [ :ownerClips | boundingRect intersect: ownerClips ] - ifNil: [ boundingRect ]! ! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 9/1/2021 11:27:45' prior: 50602536! - clippingByCurrentMorphDo: aBlock - "Do clipping only if currentMorph says so" - - | prevClipRect prevClippingMorphRect | - - currentMorph clipsSubmorphsReally ifFalse: [ ^aBlock value ]. - - prevClipRect _ self clipRect. - prevClippingMorphRect _ clippingMorphDisplayBounds. - clippingMorphDisplayBounds _ self boundingRectOfCurrentMorphAfterDraw. - self setClipRect: (prevClipRect - ifNil: [clippingMorphDisplayBounds] - ifNotNil: [prevClipRect intersect: clippingMorphDisplayBounds]). - self clipCurrentMorph: true. - aBlock ensure: [ - self clipCurrentMorph: false. - self setClipRect: prevClipRect. - clippingMorphDisplayBounds _ prevClippingMorphRect ]! ! - -BitBltCanvas removeSelector: #boundingRectOfCurrentMorphAfterDraw! - -!methodRemoval: BitBltCanvas #boundingRectOfCurrentMorphAfterDraw stamp: 'Install-4825-MorphicRefactor-JuanVuletich-2021Sep01-11h05m-jmv.001.cs.st 9/3/2021 15:02:51'! -boundingRectOfCurrentMorphAfterDraw - "In targetForm coordinates. - Clipped to owner if appropriate. - BitBltCanvas doesn't keep track of Morph bounds as it draws them. But it is limited to drawing morphs where - #morphLocalBounds is known. Use it, then." - - ^self boundingRectOfCurrentMorphFromLocalBounds! - -BitBltBoundsFinderCanvas removeSelector: #boundingRectOfCurrentMorphAfterDraw! - -!methodRemoval: BitBltBoundsFinderCanvas #boundingRectOfCurrentMorphAfterDraw stamp: 'Install-4825-MorphicRefactor-JuanVuletich-2021Sep01-11h05m-jmv.001.cs.st 9/3/2021 15:02:51'! -boundingRectOfCurrentMorphAfterDraw - "In targetForm coordinates. - Clipped to owner if appropriate. - BitBltCanvas doesn't keep track of Morph bounds as it draws them. But it is limited to drawing morphs where - #morphLocalBounds is known. Use it, then." - - ^self boundingRectOfCurrentMorphFromLocalBounds! - -MorphicCanvas removeSelector: #boundingRectOfCurrentMorphFromLocalBounds! - -!methodRemoval: MorphicCanvas #boundingRectOfCurrentMorphFromLocalBounds stamp: 'Install-4825-MorphicRefactor-JuanVuletich-2021Sep01-11h05m-jmv.001.cs.st 9/3/2021 15:02:51'! -boundingRectOfCurrentMorphFromLocalBounds - "In targetForm coordinates. - Clipped to owner if appropriate. - Only valid for morphs where #morphLocalBounds is known" - - | boundingRect | - boundingRect _ currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds. - ^ clippingMorphDisplayBounds - ifNotNil: [ :ownerClips | boundingRect intersect: ownerClips ] - ifNil: [ boundingRect ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4825-MorphicRefactor-JuanVuletich-2021Sep01-11h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4822] on 1 September 2021 at 11:41:53 am'! -!Morph methodsFor: 'updating' stamp: 'jmv 9/1/2021 11:41:29' prior: 50597088! - redrawNeeded - "Report that the area occupied by this morph should be redrawn. - Usually because we changed in some way. - Notes: - Area used before any change is reported here. - Area used after any changes is reported when displayBounds are updated. - See updateBoundsIn:addDamageTo: and senders. - " - - self needsRedraw: true. - self allOwnersDo: [ :m | m submorphNeedsRedraw: true ]. - self basicDisplayBounds ifNotNil: [ :b | - "outsetBy: 1 due to anti aliasing in VectorCanvas" - self invalidateDisplayRect: (b outsetBy: 1) for: self ]. - (self submorphsMightProtrude and: [self clipsSubmorphsReally not]) ifTrue: [ - self submorphsReverseDo: [ :m | m redrawNeeded ]]. - self removeProperty: #bitMask. - self removeProperty: #fullBoundsInOwner.! ! - -Morph removeSelector: #displayBoundsOrBogus! - -!methodRemoval: Morph #displayBoundsOrBogus stamp: 'Install-4826-Morphic-Refactor-JuanVuletich-2021Sep01-11h34m-jmv.001.cs.st 9/3/2021 15:02:51'! -displayBoundsOrBogus - "Never answer nil. A bogus value will trigger a draw operation, and bounds will later be corrected. - Integer pixel coordinates!!" - - ^self basicDisplayBounds ifNil: [ - Rectangle center: (self externalizeToWorld: `0@0`) extent: `2@2` ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4826-Morphic-Refactor-JuanVuletich-2021Sep01-11h34m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4825] on 1 September 2021 at 12:19:43 pm'! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'jmv 9/1/2021 12:19:27' prior: 50446699! - calculateItemsPerPage - - | itemsThatCanFit | - - itemsThatCanFit _ (Display height - originalPosition y - 2) // self itemHeight. - itemsPerPage _ (itemsThatCanFit min: self maxItemsPerPage) min: self entryCount. - -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4827-Tweak-JuanVuletich-2021Sep01-12h14m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4827] on 1 September 2021 at 12:41:09 pm'! -!DisplayScreen methodsFor: 'private' stamp: 'jmv 9/1/2021 12:40:52' prior: 16835386 overrides: 16848801! - setExtent: aPoint depth: bitsPerPixel - "DisplayScreen startUp" - "This method is critical. If the setExtent fails, there will be no - proper display on which to show the error condition..." - - | bitsPerPixelToUse | - (depth = bitsPerPixel and: [aPoint = self extent and: [ - self supportsDisplayDepth: bitsPerPixel]]) ifFalse: [ - bits _ nil. "Free up old bitmap in case space is low" - bitsPerPixelToUse _ (self supportsDisplayDepth: bitsPerPixel) - ifTrue: [ bitsPerPixel ] - ifFalse: [ - (self supportsDisplayDepth: bitsPerPixel negated) - ifTrue: [ bitsPerPixel negated ] - ifFalse: [ self findAnyDisplayDepth ]]. - super setExtent: aPoint depth: bitsPerPixelToUse. - ]. - - "Let the world know" - self triggerEvent: #screenSizeChanged.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4828-Display-tweak-JuanVuletich-2021Sep01-12h40m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4828] on 1 September 2021 at 4:09:49 pm'! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 9/1/2021 15:44:52'! - checkForNewScreenSize - "Check whether the screen size has changed and if so take appropriate actions" - - DisplayScreen isDisplayExtentOk ifFalse: [ - self clearCanvas. - DisplayScreen startUp. - self setMainCanvas. - self restoreDisplay. - self whenUIinSafeState: [ Cursor defaultCursor activateCursor ]].! ! -!WorldMorph methodsFor: 'interaction loop' stamp: 'jmv 9/1/2021 15:46:02' prior: 50603206! - mainLoop - - - self clearWaitDelay. - canvas isNil ifTrue: [ - self setMainCanvas ]. - self redrawNeeded. - [ - self doOneCycle. - true ] - whileTrue: []! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 9/1/2021 15:39:30' prior: 50565120! - doOneCycleNow - "Immediately do one cycle of the interaction loop. - Only used for a few tests." - "See #eventTickler" - | hadAny | - Cursor currentCursor = (Cursor cursorAt: #waitCursor) ifTrue: [ Cursor defaultCursor activateCursor ]. - "Repair visual damage." - self checkForNewScreenSize. - self displayWorldSafely. - "Run steps, alarms and deferred UI messages" - self runStepMethods. - "Process user input events. Run all event triggered code." - hadAny _ false. - self handsDo: [ :h | - activeHand _ h. - hadAny _ hadAny | h processEventQueue. - activeHand _ nil ]. - "The default is the primary hand" - activeHand _ self hands first. - ^ hadAny.! ! -!WorldMorph class methodsFor: 'instance creation' stamp: 'jmv 9/1/2021 15:46:58' prior: 50603259! - newWorld - " -[ - UISupervisor stopUIProcess. - UISupervisor spawnNewMorphicProcessFor: WorldMorph newWorld -] fork. - " - | w | - w _ self new. - w morphPosition: `0@0` extent: Display extent. - w handsDo: [ :h | - h privateOwner: w ]. - ^w! ! -!TheWorldMenu methodsFor: 'commands' stamp: 'jmv 9/1/2021 15:33:22' prior: 50379961! - fullScreenOff - - Display fullScreenMode: false.! ! -!TheWorldMenu methodsFor: 'commands' stamp: 'jmv 9/1/2021 15:33:17' prior: 50379968! - fullScreenOn - - Display fullScreenMode: true.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 9/1/2021 15:55:46' prior: 50603271! - activeSubclass: aMorphicCanvasSubclass - ActiveSubclass _ aMorphicCanvasSubclass. - UISupervisor ui ifNotNil: [ :world | - world whenUIinSafeState: [ - world setMainCanvas ]].! ! - -WorldMorph removeSelector: #extentChanged:! - -!methodRemoval: WorldMorph #extentChanged: stamp: 'Install-4829-Morphic-Refactor-JuanVuletich-2021Sep01-16h05m-jmv.001.cs.st 9/3/2021 15:02:51'! -extentChanged: oldExtent - "Our extent changed. Must layout submorphs again." - - super extentChanged: oldExtent. - self setMainCanvas! - -DisplayScreen class removeSelector: #checkForNewScreenSize! - -!methodRemoval: DisplayScreen class #checkForNewScreenSize stamp: 'Install-4829-Morphic-Refactor-JuanVuletich-2021Sep01-16h05m-jmv.001.cs.st 9/3/2021 15:02:51'! -checkForNewScreenSize - "Check whether the screen size has changed and if so take appropriate actions" - - self isDisplayExtentOk ifFalse: [ - UISupervisor restoreDisplay ]! - -UISupervisor class removeSelector: #restoreDisplay! - -!methodRemoval: UISupervisor class #restoreDisplay stamp: 'Install-4829-Morphic-Refactor-JuanVuletich-2021Sep01-16h05m-jmv.001.cs.st 9/3/2021 15:02:51'! -restoreDisplay - self ui ifNotNil: [ :guiRootObject | - DisplayScreen isDisplayExtentOk ifFalse: [ - "Deallocate before allocating could mean less memory stress." - guiRootObject clearCanvas ]]. - DisplayScreen startUp. - self ui ifNotNil: [ :guiRootObject | - guiRootObject restoreDisplay ]. - self whenUIinSafeState: [ Cursor defaultCursor activateCursor ].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4829-Morphic-Refactor-JuanVuletich-2021Sep01-16h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4829] on 1 September 2021 at 6:18:08 pm'! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 9/1/2021 18:14:16' prior: 50596792! - setForm: aForm subPixelAntiAliasing: aBooleanOrNil - "nil means use default kind of anti aliasing. Ignored in BitBltCanvas." - - form _ aForm. - engine _ BitBltCanvasEngine toForm: form. - "Init BitBlt so that the first call to the 'primitiveDisplayString' primitive will not fail" - engine sourceX: 0; width: 0. - self newClipRect: nil.! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 9/1/2021 18:15:37' prior: 50603168! - setPluginAndForm: aForm - "No VectorEnginePlugin in BitBltCanvas." - - self setForm: aForm subPixelAntiAliasing: nil.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4830-Tweaks-JuanVuletich-2021Sep01-18h13m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4830] on 2 September 2021 at 8:52:39 am'! -!DisplayScreen methodsFor: 'accessing' stamp: 'jmv 9/2/2021 08:52:10' prior: 50603136! - getMainCanvas - "Return a Canvas that can be used to draw onto the receiver. - Being the sole 'main' canvas means a priviledge: Can use VectorEnginePlugin if available." - - | answer | - answer _ [ MorphicCanvas withVectorEnginePluginOnForm: self ] - on: OutOfMemory - do: [ - 'Not enough memory to run VectorEngine. Using BitBltCanvas instead.' print. - MorphicCanvas activeSubclass: BitBltCanvas. - MorphicCanvas withVectorEnginePluginOnForm: self ]. - ^answer! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4831-CanvasCreation-HandleOutOfMemory-JuanVuletich-2021Sep02-08h45m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4831] on 2 September 2021 at 4:31:06 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 9/2/2021 16:25:56' prior: 50604197! - displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Clipped appropiately if some owner clips us. - See also #displayBoundsUpdateFrom:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - (aCanvas isBoundsFinderCanvas or: [c canvasToUse == aCanvas canvasToUse]) ifTrue: [ - privateDisplayBounds _ aCanvas canvasToUse boundingRectOfCurrentMorphAfterDraw. - self wantsContour - ifTrue: [ - (aCanvas canvasToUse - contourOfCurrentMorphAfterDrawInto: (self valueOfProperty: #contour) - into: [ :contourArray :contourY0 :contourY1 | - self setProperty: #contour toValue: contourArray. - self setProperty: #contourY0 toValue: contourY0. - self setProperty: #contourY1 toValue: contourY1 ])] - ifFalse: [ - self setProperty: #contour toValue: nil. - self setProperty: #contourY0 toValue: nil. - self setProperty: #contourY1 toValue: nil ]]]].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 9/2/2021 16:27:13' prior: 50604233! - displayBoundsUpdateFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us. - To be called after #postDrawOn:. See also #displayBoundsSetFrom: - This more complicated update is needed because the contour information from #drawOn: was possibly - when drawing submorphs. So, the controur from #drawOn: needs to be retrieved, and updated with the - new contour information from #postDrawOn:" - - self world ifNotNil: [ :w | - w canvas ifNotNil: [ :c | - (aCanvas isBoundsFinderCanvas or: [c canvasToUse == aCanvas canvasToUse]) ifTrue: [ - privateDisplayBounds _ privateDisplayBounds - quickMerge: aCanvas canvasToUse boundingRectOfCurrentMorphAfterDraw. - self wantsContour ifTrue: [ - (aCanvas canvasToUse - contourOfCurrentMorphAfterDrawUpdate: (self valueOfProperty: #contour) - oldTop: (self valueOfProperty: #contourY0) - oldBottom: (self valueOfProperty: #contourY1) - into: [ :contourArray :contourY0 :contourY1 | - self setProperty: #contour toValue: contourArray. - self setProperty: #contourY0 toValue: contourY0. - self setProperty: #contourY1 toValue: contourY1 ])]]]].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 9/2/2021 16:15:12' prior: 50604276! - boundingRectOfCurrentMorphAfterDraw - "In targetForm coordinates. - Clipped to owner if appropriate. - Only valid for morphs where #morphLocalBounds is known. - Subclasses may raise this restriction. See inherintance, with VectorGraphics package loaded." - - | boundingRect | - boundingRect _ currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds. - ^ clippingMorphDisplayBounds - ifNotNil: [ :ownerClips | boundingRect intersect: ownerClips ] - ifNil: [ boundingRect ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4832-Morphic-boundsSetFix-JuanVuletich-2021Sep02-16h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4832] on 3 September 2021 at 11:27:46 am'! -!SpaceTally commentStamp: 'jmv 9/3/2021 10:57:56' prior: 16912391! - I'm responsible to help getting information about system space usage. The information I compute is represented by a spaceTallyItem - -try something like: - -((SpaceTally new spaceTally: (Array with: Morph with: Point)) - asSortedCollection: [:a :b | a spaceForInstances > b spaceForInstances]) - -SpaceTally new systemWideSpaceTally - -Also try: -'MemoryAnalysis.txt' asFileEntry forceWriteStreamDo: [ :stream | - SpaceTally new printSpaceAnalysis: 1 on: stream ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4833-SpaceTally-tweak-JuanVuletich-2021Sep03-10h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4832] on 3 September 2021 at 12:43:37 pm'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 9/3/2021 12:43:27'! - setDefaultGCParameters - "Adjust the VM's default GC parameters to avoid premature tenuring, and too frequent scavenging. - Parameters set here persist in saved images, so we set them image save for release. - See #setGCParameters" - - "Desired Eden size: " - Smalltalk vmParameterAt: 45 put: `16*1024*1024`.! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 9/3/2021 12:28:41' prior: 50599700! - saveAsNewReleaseAndQuit - "Save the image/changes using the next available version number. - This is usually only used to prepare updated Cuis images for distribution." - " - Smalltalk saveAsNewReleaseAndQuit - " - | fileName newName changesName systemVersion | - systemVersion _ SystemVersion current. - fileName _ String streamContents: [ :strm | - strm - nextPutAll: 'Cuis'; - print: systemVersion versionMajor; - nextPut: $.; - print: systemVersion versionMinor; - nextPut: $-; - print: systemVersion highestUpdate. - Smalltalk isSpur - ifTrue: [ - Smalltalk wordSize = 4 ifTrue: [ - strm nextPutAll: '-32' ]] - ifFalse: [ - strm nextPutAll: '-v3' ]]. - newName _ fileName, '.image'. - (DirectoryEntry smalltalkImageDirectory // newName) exists ifTrue: [ - newName _ DirectoryEntry smalltalkImageDirectory - nextNameFor: fileName - extension: 'image' ]. - changesName _ self fullNameForChangesNamed: newName. - "Check to see if there is a .changes file that would cause a problem if we saved a new .image file with the new version number" - changesName asFileEntry exists ifTrue: [ - ^ self inform: -'There is already .changes file of the desired name, -', changesName, ' -curiously already present, even though there is no -corresponding .image file. -Please remedy manually and then repeat your request.' ]. - self setDefaultGCParameters. - "Try to clear all user state, including all class vars, preferences, etc" - self saveAndQuitAs: newName clearAllClassState: true! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 9/3/2021 12:28:53' prior: 50602452! - saveAsNewReleaseAndStay - "Save the image/changes using the next available version number. - This is usually only used to prepare updated Cuis images for distribution." - " - Smalltalk saveAsNewReleaseAndStay - " - | fileName newName changesName systemVersion | - systemVersion _ SystemVersion current. - fileName _ String streamContents: [ :strm | - strm - nextPutAll: 'Cuis'; - print: systemVersion versionMajor; - nextPut: $.; - print: systemVersion versionMinor; - nextPut: $-; - print: systemVersion highestUpdate. - Smalltalk isSpur - ifTrue: [ - Smalltalk wordSize = 4 ifTrue: [ - strm nextPutAll: '-32' ]] - ifFalse: [ - strm nextPutAll: '-v3' ]]. - newName _ fileName, '.image'. - (DirectoryEntry smalltalkImageDirectory // newName) exists ifTrue: [ - newName _ DirectoryEntry smalltalkImageDirectory - nextNameFor: fileName - extension: 'image' ]. - changesName _ self fullNameForChangesNamed: newName. - "Check to see if there is a .changes file that would cause a problem if we saved a new .image file with the new version number" - changesName asFileEntry exists ifTrue: [ - ^ self inform: -'There is already .changes file of the desired name, -', changesName, ' -curiously already present, even though there is no -corresponding .image file. -Please remedy manually and then repeat your request.' ]. - self setDefaultGCParameters. - "Try to clear all user state, including all class vars, preferences, etc" - self saveAndStayAs: newName clearAllClassState: true! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 9/3/2021 12:43:22' prior: 16922843! - setGCParameters - "Adjust the VM's default GC parameters to avoid premature tenuring, and too frequent scavenging. - Parameters set here don't persist, so we set them on startup. - See #setDefaultGCParameters" - - "Grow old memory in chunks of: " - Smalltalk vmParameterAt: 25 put: `32*1024*1024`. - "Shrink heap when unused memory is at least: " - Smalltalk vmParameterAt: 24 put: `64*1024*1024`. - - Smalltalk isSpur - ifTrue: [ - "Note: (jmv, 9/2021) It seems modern Spur VMs ignore parameter 6. This all seems to be bogus." - | proportion edenSize survivorSize averageObjectSize numObjects | - proportion := 0.9. "tenure when 90% of pastSpace is full" - edenSize := self vmParameterAt: 44. - survivorSize := edenSize / 5.0. "David's paper uses 140Kb eden + 2 x 28kb survivor spaces; Spur uses the same ratios :-)" - averageObjectSize := 8 * self wordSize. "a good approximation" - numObjects := (proportion * survivorSize / averageObjectSize) rounded. - self vmParameterAt: 6 put: numObjects. "tenure when more than this many objects survive the GC" - "/Note: (jmv, 9/2021)" - - "Do a full GC when used memory grows by this factor. Fails on non-Spur VMs. - Default is 0.333. - 2.0 means gull GC when heap size triples." - Smalltalk vmParameterAt: 55 put: 2.0. - ] - ifFalse: [ - Smalltalk vmParameterAt: 5 put: 4000. "do an incremental GC after this many allocations" - Smalltalk vmParameterAt: 6 put: 2000. "tenure when more than this many objects survive the GC" - ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4834-Enlarge-GCParameters-JuanVuletich-2021Sep03-11h27m-jmv.001.cs.st----! - -----QUIT----(3 September 2021 15:02:55) Cuis5.0-4834-v3.image priorSource: 8699584! - -----STARTUP---- (21 September 2021 12:54:32) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4834-v3.image! - - -'From Haver 5.0 [latest update: #4821] on 1 September 2021 at 5:39:26 pm'! -!Boolean methodsFor: 'user interface support' stamp: 'KLG 9/1/2021 17:33:22'! - asMenuItemTextPrefix - "Answer '' or '' to prefix a menu item text with a check box. " - - ^ self subclassResponsibility! ! -!False methodsFor: 'user interface support' stamp: 'KLG 9/1/2021 17:33:51' overrides: 50604961! - asMenuItemTextPrefix - "Answer '' or '' to prefix a menu item text with a check box. " - - ^ ''! ! -!True methodsFor: 'user interface support' stamp: 'KLG 9/1/2021 17:34:02' overrides: 50604961! - asMenuItemTextPrefix - "Answer '' or '' to prefix a menu item text with a check box. " - - ^ ''! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4835-asMenuItemTextPrefix-GeraldKlix-2021Sep01-17h30m-KLG.001.cs.st----! - -'From Haver 5.0 [latest update: #4821] on 1 September 2021 at 7:00:13 pm'! -!TaskbarMorph class methodsFor: 'as yet unclassified' stamp: 'KLG 9/1/2021 18:58:39' overrides: 16877245! - includeInNewMorphMenu - "Return true for all classes that can be instantiated from the menu - - More than one taskbar confuses the running wolrd!!" - - ^ false! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4836-NoAdditionalTaskbarMorphs-GeraldKlix-2021Sep01-17h39m-KLG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4836] on 5 September 2021 at 1:59:07 pm'! -!CodeProvider methodsFor: 'diffs' stamp: 'jmv 9/5/2021 13:54:43' prior: 16812346! - showingLineDiffsString - "Answer a string representing whether I'm showing regular diffs" - - ^ self showingLineDiffs asMenuItemTextPrefix, - 'lineDiffs'! ! -!CodeProvider methodsFor: 'diffs' stamp: 'jmv 9/5/2021 13:55:59' prior: 16812361! - showingPrettyLineDiffsString - "Answer a string representing whether I'm showing pretty diffs" - - ^ self showingPrettyLineDiffs asMenuItemTextPrefix, - 'linePrettyDiffs'! ! -!CodeProvider methodsFor: 'diffs' stamp: 'jmv 9/5/2021 13:56:14' prior: 16812377! - showingPrettyWordDiffsString - "Answer a string representing whether I'm showing pretty diffs" - - ^ self showingPrettyWordDiffs asMenuItemTextPrefix, - 'wordPrettyDiffs'! ! -!CodeProvider methodsFor: 'diffs' stamp: 'jmv 9/5/2021 13:56:25' prior: 16812393! - showingWordDiffsString - "Answer a string representing whether I'm showing regular diffs" - - ^ self showingWordDiffs asMenuItemTextPrefix, - 'wordDiffs'! ! -!CodeProvider methodsFor: 'what to show' stamp: 'jmv 9/5/2021 13:55:22' prior: 16812559! - prettyPrintString - "Answer whether the receiver is showing pretty-print" - - ^ self showingPrettyPrint asMenuItemTextPrefix, - 'prettyPrint'! ! -!CodeProvider methodsFor: 'what to show' stamp: 'jmv 9/5/2021 13:53:44' prior: 16812605! - showingByteCodesString - "Answer whether the receiver is showing bytecodes" - - ^ self showingByteCodes asMenuItemTextPrefix, - 'byteCodes'! ! -!CodeProvider methodsFor: 'what to show' stamp: 'jmv 9/5/2021 13:54:04' prior: 16812620! - showingDecompileString - "Answer a string characerizing whether decompilation is showing" - - ^ self showingDecompile asMenuItemTextPrefix, - 'decompile'! ! -!CodeProvider methodsFor: 'what to show' stamp: 'jmv 9/5/2021 13:54:20' prior: 16812636! - showingDocumentationString - "Answer a string characerizing whether documentation is showing" - - ^ self showingDocumentation asMenuItemTextPrefix, - 'documentation'! ! -!CodeProvider methodsFor: 'what to show' stamp: 'jmv 9/5/2021 13:55:44' prior: 16812651! - showingPlainSourceString - "Answer a string telling whether the receiver is showing plain source" - - ^ self showingPlainSource asMenuItemTextPrefix, - 'source'! ! -!Morph methodsFor: 'menus' stamp: 'jmv 9/5/2021 13:57:02' prior: 16876328! - stickinessString - "Answer the string to be shown in a menu to represent the - stickiness status" - - ^ self isSticky asMenuItemTextPrefix, - 'resist being picked up'! ! -!InnerTextMorph methodsFor: 'menu' stamp: 'jmv 9/5/2021 13:57:19' prior: 16855935! - wrapString - "Answer the string to put in a menu that will invite the user to - switch word wrap mode" - ^ wrapFlag asMenuItemTextPrefix, - 'text wrap to bounds'! ! -!FileListWindow methodsFor: 'menu building' stamp: 'jmv 9/5/2021 13:58:00' prior: 50602324! - volumeMenu - | aMenu initialDirectoriesMenu | - aMenu _ MenuMorph new defaultTarget: model. - aMenu - add: 'delete directory...' - action: #deleteDirectory - icon: #warningIcon :: setBalloonText: 'Delete the selected directory'. - model currentDirectorySelected - ifNil: [ aMenu add: 'initial directory' action: #yourself :: isEnabled: false ] - ifNotNil: [ :selectedWrapper | - aMenu - add: (Preferences isInitialFileListDirectory: selectedWrapper item) - asMenuItemTextPrefix, 'initial directory' - action: #toggleInitialDirectory :: - setBalloonText: 'The selected directory is an initial director for new file list windows' ]. - initialDirectoriesMenu _ MenuMorph new. - #( - (roots 'default roots' 'Use the usual root directories. Drives on Windows; "/" on Unix') - (image 'image directory' 'Use the directory with Smalltalk image') - (vm 'VM directory' 'Use the virtual machine directory') - (current 'current directory' 'Use the current directory; usually the directory the VM was started in') - ) - do: [ :entry | - initialDirectoriesMenu - add: entry second - target: Preferences - action: #initialFileListDirectories: - argument: entry first :: - setBalloonText: entry third ]. - aMenu add: 'default initial directories' subMenu: initialDirectoriesMenu. - ^ aMenu! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4837-MakeGoodUseOf4835-JuanVuletich-2021Sep05-13h52m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4837] on 5 September 2021 at 7:51:29 pm'! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 9/5/2021 18:38:10' overrides: 50552944! - fontPreferenceChanged - - super fontPreferenceChanged. - scrollBar recreateSubmorphs. - hScrollBar recreateSubmorphs. - self setScrollDeltas.! ! - -ScrollBar removeSelector: #fontPreferenceChanged! - -!methodRemoval: ScrollBar #fontPreferenceChanged stamp: 'Install-4838-GUIelementsSizeChangeFix-JuanVuletich-2021Sep05-19h50m-jmv.001.cs.st 9/21/2021 12:54:38'! -fontPreferenceChanged - "Rescale" - - self recreateSubmorphs! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4838-GUIelementsSizeChangeFix-JuanVuletich-2021Sep05-19h50m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4837] on 5 September 2021 at 7:52:31 pm'! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 9/5/2021 19:52:05' prior: 50568095! - setDefaultFont: aFontName - "Change the font on the whole system without changing point sizes." - FontFamily defaultFamilyName: aFontName. - Preferences - setDefaultFont: FontFamily defaultFamilyName - spec: { - {#setListFontTo:. Preferences standardListFont pointSize.}. - {#setMenuFontTo:. Preferences standardMenuFont pointSize.}. - {#setWindowTitleFontTo:. Preferences windowTitleFont pointSize.}. - {#setCodeFontTo:. Preferences standardCodeFont pointSize.}. - {#setButtonFontTo:. Preferences standardButtonFont pointSize.}. - }. - MorphicCanvas allSubclassesDo: [ :c| c guiSizePreferenceChanged ]. - UISupervisor ui ifNotNil: [ :w | w fontPreferenceChanged ].! ! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 9/5/2021 19:51:58' prior: 50602919! - setDefaultFont: fontFamilyName spec: defaultFontsSpec - - | font | - defaultFontsSpec do: [ :triplet | - font _ FontFamily familyName: fontFamilyName pointSize: triplet second. - font ifNil: [ font _ FontFamily defaultFamilyAndPointSize ]. - triplet size > 2 ifTrue: [ - font _ font emphasized: triplet third ]. - self - perform: triplet first - with: font ]. - MorphicCanvas allSubclassesDo: [ :c| c guiSizePreferenceChanged ]. - UISupervisor ui ifNotNil: [ :w | w fontPreferenceChanged ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4839-GUISizePreferenceChanged-JuanVuletich-2021Sep05-19h51m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4839] on 6 September 2021 at 10:24:41 am'! -!HaloMorph methodsFor: 'drawing' stamp: 'jmv 9/6/2021 10:21:10' prior: 50596398! - drawCoordinateSystemOn: aCanvas - - | x0 x1 y0 y1 c stepX stepY haloTargetTx prevTx | - haloTargetTx _ MorphicTranslation identity. - target allOwnersReverseDo: [ :o | haloTargetTx _ haloTargetTx composedWith: o location ]. - haloTargetTx _ haloTargetTx composedWith: target location. - - target knowsOwnLocalBounds - ifTrue: [ | r | - r _ target morphLocalBounds. - x0 _ r left. - x1 _ r right. - y0 _ r top. - y1 _ r bottom ] - ifFalse: [ - x0 _ x1 _ y0 _ y1 _ 0. - target displayFullBounds corners collect: [ :pt | | p | - p _ haloTargetTx inverseTransform: pt. - x0 _ x0 min: p x. - x1 _ x1 max: p x. - y0 _ y0 min: p y. - y1 _ y1 max: p y.]]. - stepX _ FontFamily defaultPointSize * 4 //10 * 10. - stepY _ FontFamily defaultPointSize * 2 //10 * 10. - - prevTx _ aCanvas currentTransformation. - aCanvas geometryTransformation: haloTargetTx. - - c _ `Color black alpha: 0.4`. - aCanvas line: x0@0 to: x1@0 width: 2 color: c. - aCanvas line: 0@y0 to: 0@y1 width: 2 color: c. - - (x0 truncateTo: stepX) to: (x1 - stepX truncateTo: stepX) by: stepX do: [ :x | - aCanvas line: x @ -5 to: x @ 5 width: 2 color: c. - aCanvas drawString: x printString atCenterXBaselineY: x @ -10 font: nil color: c ]. - aCanvas drawString: 'x' atCenterX: x1 - 15 @ 0 font: nil color: c. - - (y0 truncateTo: stepY) to: (y1 - stepY truncateTo: stepY) by: stepY do: [ :y | - aCanvas line: -5 @ y to: 5 @ y width: 2 color: c. - aCanvas drawString: y printString, ' ' atWaistRight: -5 @ y font: nil color: c ]. - aCanvas drawString: 'y' atWaistRight: -5 @ (y1 - 20) font: nil color: c. - - aCanvas geometryTransformation: prevTx.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4840-drawCoordinateSystem-tweak-JuanVuletich-2021Sep05-20h14m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4839] on 6 September 2021 at 11:07:34 am'! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 9/6/2021 11:07:11' prior: 50604103! - displayWorldSafely - "Update this world's display and keep track of errors during draw methods." - - [self displayWorld] on: Error, Halt do: [ :ex | - "Handle a drawing error" - canvas currentMorphDrawingFails. - "Creating a new canvas here could be dangerous, as code signaling the exception will be resumed." - self resetCanvas. - "Install the old error handler, so we can re-raise the error" - ex receiver error: ex description. - ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4841-Morphic-ErrorHandling-fix-JuanVuletich-2021Sep06-11h07m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4841] on 6 September 2021 at 12:08:56 pm'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 9/6/2021 12:08:14' prior: 50559686! - fullDraw: aMorph - "Draw the full Morphic structure on us" - - "We are already set with a proper transformation from aMorph owner's coordinates to those of our target form." - - self flag: #jmvVer3. - aMorph visible ifFalse: [^ self]. - self into: aMorph. - - currentMorph layoutSubmorphsIfNeeded. - - currentMorph isKnownFailing ifTrue: [ - self canvasToUse drawCurrentAsError. - self outOfMorph. - ^ self]. - - (currentMorph isOwnedByHand and: [ - Preferences cheapWindowReframe and: [currentMorph is: #SystemWindow]]) ifTrue: [ - self drawCurrentAsOutline. - self outOfMorph. - ^ self]. - - "Draw current Morph and submorphs" - self canvasToUse drawCurrentAndSubmorphs. - - self outOfMorph! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4842-cheapWindowReframe-onlyForWindows-JuanVuletich-2021Sep06-12h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4841] on 6 September 2021 at 12:47:09 pm'! -!CodePackage methodsFor: 'naming' stamp: 'jmv 9/6/2021 12:17:27'! - packageDirectory - - ^self packageDirectoryName asDirectoryEntry! ! - -CodePackage removeSelector: #pagkageDirectory! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4843-packageDirectory-JuanVuletich-2021Sep06-12h08m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4843] on 6 September 2021 at 3:12:10 pm'! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 9/6/2021 15:06:24'! - isDrawnBySoftware - "Return true if this hand must be drawn explicitely instead of being drawn via the hardware cursor. This is the case if it (a) it is a remote hand, (b) it is showing a temporary cursor, or (c) it is not empty and there are any visible submorphs. If using the software cursor, ensure that the hardware cursor is hidden." - "Details: Return true if this hand has a saved patch to ensure that is is processed by the world. This saved patch will be deleted after one final display pass when it becomes possible to start using the hardware cursor again. This trick gives us one last display cycle to allow us to remove the software cursor from the display." - "Note. We draw the hand as a regular morph (using #drawOn:), disabling the hardware cursor, when we carry submorphs. The reason is to lock the mouse pointer and the carried morph together. Otherwhise the carried morph would lag behind the mouse pointer. - This method answers whether the regular #drawOn: drawing mechanism is used for us. - - Check senders. Hand drawing is handled explicitly by the world, because the Hand is not a submorph of the world!!" - | blankCursor | - (prevFullBounds notNil or: [ - submorphs anySatisfy: [ :ea | - ea visible ]]) ifTrue: [ - "using the software cursor; hide the hardware one" - blankCursor _ Cursor cursorAt: #blankCursor. - Cursor currentCursor == blankCursor ifFalse: [ blankCursor activateCursor ]. - ^ true ]. - ^ false.! ! -!WorldMorph methodsFor: 'hands' stamp: 'jmv 9/6/2021 15:06:31' prior: 50570315! - selectHandsToDrawForDamage: damageList - "Select the set of hands that must be redrawn because either (a) the hand itself has changed or (b) the hand intersects some damage rectangle." - - | result | - result _ OrderedCollection new. - hands do: [:hand | - hand isDrawnBySoftware ifTrue: [ - hand isRedrawNeeded - ifTrue: [result add: hand] - ifFalse: [ - hand displayFullBounds ifNotNil: [ :handBounds | - (damageList anySatisfy: [ :r | r intersects: handBounds]) ifTrue: [ - result add: hand]]]]]. - ^ result! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 9/6/2021 15:06:36' prior: 50570335! - checkIfUpdateNeeded - - self isSubmorphRedrawNeeded ifTrue: [ ^true ]. - damageRecorder updateIsNeeded ifTrue: [^true]. - hands do: [:h | (h isRedrawNeeded | h isSubmorphRedrawNeeded and: [h isDrawnBySoftware]) ifTrue: [^true]]. - ^false "display is already up-to-date" -! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 9/6/2021 15:10:14' prior: 50565059! - doOneCycle - "Do one cycle of the interaction loop. This method is called repeatedly when the world is running. - - Make for low cpu usage if the ui is inactive, but quick response when ui is in use. - However, after some inactivity, there will be a larger delay before the ui gets responsive again." - - | wait waitUntil | - waitDelay ifNil: [ waitDelay _ Delay forMilliseconds: 50 ]. - (lastCycleHadAnyEvent or: [ deferredUIMessages isEmpty not ]) - ifTrue: [ - pause _ 20. "This value will only be used later, when there are no more events to serve or deferred UI messages to process." - wait _ 0. "Don't wait this time"] - ifFalse: [ - "wait between 20 and 200 milliseconds" - (hands anySatisfy: [ :h | h waitingForMoreClicks ]) - ifTrue: [ pause _ 20 ] - ifFalse: [ pause < 200 ifTrue: [ pause _ pause * 21//20 ] ]. - waitUntil _ lastCycleTime + pause. - "Earlier if steps" - stepList isEmpty not ifTrue: [ - waitUntil _ waitUntil min: stepList first scheduledTime ]. - "Earlier if alarms" - alarms ifNotNil: [ - alarms isEmpty not ifTrue: [ - waitUntil _ waitUntil min: alarms first scheduledTime ]]. - wait _ waitUntil - Time localMillisecondClock max: 0 ]. - Preferences serverMode - ifTrue: [ wait _ wait max: 50 ]. "Always wait at least a bit on servers, even if this makes the UI slow." - wait = 0 - ifTrue: [ Processor yield ] - ifFalse: [ - waitDelay beingWaitedOn - ifFalse: [ waitDelay setDelay: wait; wait ] - ifTrue: [ - "If we are called from a different process than that of the main UI, we might be called in the main - interCyclePause. In such case, use a new Delay to avoid 'This Delay has already been scheduled' errors" - (Delay forMilliseconds: wait) wait ]]. - - "Record start time of this cycle, and do cycle" - lastCycleTime _ Time localMillisecondClock. - lastCycleHadAnyEvent _ self doOneCycleNow.! ! - -HandMorph removeSelector: #needsToBeDrawn! - -!methodRemoval: HandMorph #needsToBeDrawn stamp: 'Install-4844-DelayInMenuOpenBug-Fix-JuanVuletich-2021Sep06-15h09m-jmv.001.cs.st 9/21/2021 12:54:38'! -needsToBeDrawn - "Return true if this hand must be drawn explicitely instead of being drawn via the hardware cursor. This is the case if it (a) it is a remote hand, (b) it is showing a temporary cursor, or (c) it is not empty and there are any visible submorphs. If using the software cursor, ensure that the hardware cursor is hidden." - "Details: Return true if this hand has a saved patch to ensure that is is processed by the world. This saved patch will be deleted after one final display pass when it becomes possible to start using the hardware cursor again. This trick gives us one last display cycle to allow us to remove the software cursor from the display." - "Note. We draw the hand as a regular morph (using #drawOn:), disabling the hardware cursor, when we carry submorphs. The reason is to lock the mouse pointer and the carried morph together. Otherwhise the carried morph would lag behind the mouse pointer. - This method answers whether the regular #drawOn: drawing mechanism is used for us. - - Check senders. Hand drawing is handled explicitly by the world, because the Hand is not a submorph of the world!!" - | blankCursor | - (prevFullBounds notNil or: [ - submorphs anySatisfy: [ :ea | - ea visible ]]) ifTrue: [ - "using the software cursor; hide the hardware one" - blankCursor _ Cursor cursorAt: #blankCursor. - Cursor currentCursor == blankCursor ifFalse: [ blankCursor activateCursor ]. - ^ true ]. - ^ false.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4844-DelayInMenuOpenBug-Fix-JuanVuletich-2021Sep06-15h09m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4844] on 6 September 2021 at 3:36:59 pm'! -!Morph methodsFor: 'initialization' stamp: 'jmv 9/6/2021 15:21:29' prior: 16875917! - intoWorld: aWorld - "The receiver has just appeared in a new world. Note: - * aWorld can be nil (due to optimizations in other places) - * owner is already set - * owner's submorphs may not include receiver yet. - Important: Keep this method fast - it is run whenever morphs are added." - - aWorld ifNil: [ ^self ]. - self needsRedraw: true. - self wantsSteps ifTrue: [ self startStepping ]. - self submorphsDo: [ :m | m intoWorld: aWorld ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4845-AlwaysRefreshNewMorphs-JuanVuletich-2021Sep06-15h36m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4844] on 6 September 2021 at 3:37:39 pm'! -!WorldMorph methodsFor: 'events' stamp: 'jmv 9/6/2021 15:20:19' prior: 50552192 overrides: 16874466! - click: aMouseButtonEvent localPosition: localEventPosition - - ^self mouseButton2Activity.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4846-DontWaitToOpenWorldMenu-JuanVuletich-2021Sep06-15h36m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4844] on 6 September 2021 at 3:38:16 pm'! -!HandMorph methodsFor: 'double click support' stamp: 'jmv 9/6/2021 15:30:21'! - waitForClicksOrDragOrSimulatedMouseButton2: aMorph event: evt clkSel: clkSel - - "Wait until the difference between click, or drag gesture is known, then inform the given morph what transpired." - - mouseClickState _ - MouseClickState new - client: aMorph - drag: nil - click: clkSel - clickAndHalf: nil - dblClick: nil - dblClickAndHalf: nil - tripleClick: nil - event: evt - sendMouseButton2Activity: Preferences tapAndHoldEmulatesButton2. - - "It seems the Mac VM may occasionally lose button up events triggering bogus activations. - Hence Preferences tapAndHoldEmulatesButton2"! ! -!MouseClickState methodsFor: 'private' stamp: 'jmv 9/6/2021 15:33:13'! - notWaitingForMultipleClicks - - ^ clickAndHalfSelector isNil and: [ - dblClickSelector isNil and: [ - dblClickAndHalfSelector isNil and: [ - tripleClickSelector isNil ]]]! ! -!PasteUpMorph methodsFor: 'events' stamp: 'jmv 9/6/2021 15:30:26' prior: 50550885 overrides: 16874541! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - "Handle a mouse down event." - - super mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition. - - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: #click:localPosition:.! ! -!MouseClickState methodsFor: 'actions' stamp: 'jmv 9/6/2021 15:33:53' prior: 50574319! - handleEvent: aMouseEvent from: aHand - "Process the given mouse event to detect a click, double-click, or drag. - Return true if the event should be processed by the sender, false if it shouldn't. - NOTE: This method heavily relies on getting *all* mouse button events." - - | timedOut distance | - timedOut _ (aMouseEvent timeStamp - lastClickDown timeStamp) > self class doubleClickTimeout. - timedOut ifTrue: [ aHand dontWaitForMoreClicks ]. - distance _ (aMouseEvent eventPosition - lastClickDown eventPosition) r. - "Real action dispatch might be done after the triggering event, for example, because of waiting for timeout. - So, count the button downs and ups(clicks), to be processed, maybe later, maybe in a mouseMove..." - aMouseEvent isMouseDown ifTrue: [ - lastClickDown _ aMouseEvent. - buttonDownCount _ buttonDownCount + 1 ]. - aMouseEvent isMouseUp ifTrue: [ - buttonUpCount _ buttonUpCount + 1 ]. - - "Drag, or tap & hold" - (buttonDownCount = 1 and: [ buttonUpCount = 0]) ifTrue: [ - (self notWaitingForMultipleClicks or: [ distance > 0 ]) ifTrue: [ - "If we have already moved, then it won't be a double or triple click... why wait?" - aHand dontWaitForMoreClicks. - dragSelector - ifNotNil: [ self didDrag ] - ifNil: [ self didClick ]. - ^ false ]. - timedOut ifTrue: [ - aHand dontWaitForMoreClicks. - "Simulate button 2 via tap & hold. Useful for opening menus on pen computers." - sendMouseButton2Activity ifTrue: [ - clickClient mouseButton2Activity ]. - ^ false ]]. - - "If we're over triple click, or timed out, or mouse moved, don't allow more clicks." - (buttonDownCount = 4 or: [ timedOut or: [ distance > 0 ]]) ifTrue: [ - aHand dontWaitForMoreClicks. - ^ false ]. - - "Simple click." - (buttonDownCount = 1 and: [ buttonUpCount = 1 ]) ifTrue: [ - self didClick ]. - - "Click & hold" - (buttonDownCount = 2 and: [ buttonUpCount = 1]) ifTrue: [ - self didClickAndHalf ]. - - "Double click." - (buttonDownCount = 2 and: [ buttonUpCount = 2]) ifTrue: [ - self didDoubleClick ]. - - "Double click & hold." - (buttonDownCount = 3 and: [ buttonUpCount = 2]) ifTrue: [ - self didDoubleClickAndHalf ]. - - "Triple click" - (buttonDownCount = 3 and: [ buttonUpCount = 3]) ifTrue: [ - self didTripleClick ]. - - "This means: if a mouseDown, then don't further process this event (so we can turn it into a double or triple click on next buttonUp)" - ^ aMouseEvent isMouseDown! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4847-MouseClickState-tweaks-JuanVuletich-2021Sep06-15h37m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4847] on 6 September 2021 at 7:55:36 pm'! -!MouseClickState methodsFor: 'actions' stamp: 'jmv 6/17/2021 13:01:32' prior: 50605631! - handleEvent: aMouseEvent from: aHand - "Process the given mouse event to detect a click, double-click, or drag. - Return true if the event should be processed by the sender, false if it shouldn't. - NOTE: This method heavily relies on getting *all* mouse button events." - - | timedOut distance | - timedOut _ (aMouseEvent timeStamp - lastClickDown timeStamp) > self class doubleClickTimeout. - timedOut ifTrue: [ aHand dontWaitForMoreClicks ]. - distance _ (aMouseEvent eventPosition - lastClickDown eventPosition) r. - "Real action dispatch might be done after the triggering event, for example, because of waiting for timeout. - So, count the button downs and ups(clicks), to be processed, maybe later, maybe in a mouseMove..." - aMouseEvent isMouseDown ifTrue: [ - lastClickDown _ aMouseEvent. - buttonDownCount _ buttonDownCount + 1 ]. - aMouseEvent isMouseUp ifTrue: [ - buttonUpCount _ buttonUpCount + 1 ]. - - "Drag, or tap & hold" - (buttonDownCount = 1 and: [ buttonUpCount = 0]) ifTrue: [ - distance > 0 ifTrue: [ - aHand dontWaitForMoreClicks. - dragSelector - ifNotNil: [ self didDrag ] - "If we have already moved, then it won't be a double or triple click... why wait?" - ifNil: [ self didClick ]. - ^ false ]. - timedOut ifTrue: [ - aHand dontWaitForMoreClicks. - "Simulate button 2 via tap & hold. Useful for opening menus on pen computers." - sendMouseButton2Activity ifTrue: [ - clickClient mouseButton2Activity ]. - ^ false ]]. - - "If we're over triple click, or timed out, or mouse moved, don't allow more clicks." - (buttonDownCount = 4 or: [ timedOut or: [ distance > 0 ]]) ifTrue: [ - aHand dontWaitForMoreClicks. - ^ false ]. - - "Simple click." - (buttonDownCount = 1 and: [ buttonUpCount = 1 ]) ifTrue: [ - self didClick ]. - - "Click & hold" - (buttonDownCount = 2 and: [ buttonUpCount = 1]) ifTrue: [ - self didClickAndHalf ]. - - "Double click." - (buttonDownCount = 2 and: [ buttonUpCount = 2]) ifTrue: [ - self didDoubleClick ]. - - "Double click & hold." - (buttonDownCount = 3 and: [ buttonUpCount = 2]) ifTrue: [ - self didDoubleClickAndHalf ]. - - "Triple click" - (buttonDownCount = 3 and: [ buttonUpCount = 3]) ifTrue: [ - self didTripleClick ]. - - "This means: if a mouseDown, then don't further process this event (so we can turn it into a double or triple click on next buttonUp)" - ^ aMouseEvent isMouseDown! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4848-fixBugIn4847-JuanVuletich-2021Sep06-19h55m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4848] on 7 September 2021 at 11:05:59 am'! -!BitBltCanvas methodsFor: 'initialization' stamp: 'jmv 9/7/2021 09:41:09' overrides: 50604094! - resetCanvas - "To be called in case of possible inconsistency due to an exception during drawing. - See #displayWorldSafely" - - super resetCanvas. - boundsFinderCanvas resetCanvas.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4849-resetCanvas-fix-JuanVuletich-2021Sep07-11h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4849] on 7 September 2021 at 11:17:08 am'! -!Number methodsFor: 'truncation and round off' stamp: 'jmv 9/7/2021 10:54:01'! - round4perMagnitudeOrder - "Round receiver to 1 or two significant digits. - Answer is 1, 2, 2.5, 5, 10, 20, 25, 50, 100, 200, 250, 500, 1000, etc. - better name?" - - | excess firstDigitPosition | - firstDigitPosition _ self log floor. - excess _ self log - firstDigitPosition. - excess < 2 log ifTrue: [ ^10 raisedTo: firstDigitPosition ]. - excess < 2.5 log ifTrue: [ ^(10 raisedTo: firstDigitPosition) * 2 ]. - excess < 5 log ifTrue: [ ^(10 raisedTo: firstDigitPosition-1) * 25 ]. - ^(10 raisedTo: firstDigitPosition) * 5! ! -!HaloMorph methodsFor: 'drawing' stamp: 'jmv 9/7/2021 11:13:25' prior: 50605220! - drawCoordinateSystemOn: aCanvas - - | x0 x1 y0 y1 c stepX stepY haloTargetTx prevTx font strokeWidth tickLength stepXDecimals stepYDecimals | - haloTargetTx _ MorphicTranslation identity. - target allOwnersReverseDo: [ :o | haloTargetTx _ haloTargetTx composedWith: o location ]. - haloTargetTx _ haloTargetTx composedWith: target location. - - target knowsOwnLocalBounds - ifTrue: [ | r | - r _ target morphLocalBounds. - x0 _ r left. - x1 _ r right. - y0 _ r top. - y1 _ r bottom ] - ifFalse: [ - x0 _ x1 _ y0 _ y1 _ 0. - target displayFullBounds corners collect: [ :pt | | p | - p _ haloTargetTx inverseTransform: pt. - x0 _ x0 min: p x. - x1 _ x1 max: p x. - y0 _ y0 min: p y. - y1 _ y1 max: p y.]]. - - font _ FontFamily defaultFamilyPointSize: FontFamily defaultPointSize * 1.5 / haloTargetTx scale. - stepX _ (font pointSize * 10) round4perMagnitudeOrder asFloat. - stepXDecimals _ stepX log rounded negated + 1. - stepY _ (font pointSize * 5) round4perMagnitudeOrder asFloat. - stepYDecimals _ stepY log rounded negated + 1. - strokeWidth _ 3/ haloTargetTx scale. - tickLength _ 5 / haloTargetTx scale. - - prevTx _ aCanvas currentTransformation. - aCanvas geometryTransformation: haloTargetTx. - - c _ `Color black alpha: 0.4`. - aCanvas line: x0@0 to: x1@0 width: strokeWidth color: c. - aCanvas line: 0@y0 to: 0@y1 width: strokeWidth color: c. - - (x0 truncateTo: stepX) to: x1-(stepX*0.2) by: stepX do: [ :x | - aCanvas line: x @ tickLength negated to: x @ tickLength width: strokeWidth color: c. - aCanvas drawString: (x printStringFractionDigits: stepXDecimals) atCenterXBaselineY: x @ (tickLength*2) negated font: font color: c ]. - aCanvas drawString: 'x' atCenterX: x1 - (tickLength*3) @ 0 font: font color: c. - - (y0 truncateTo: stepY) to: y1-(stepY*0.5) by: stepY do: [ :y | - aCanvas line: tickLength negated @ y to: tickLength @ y width: strokeWidth color: c. - aCanvas drawString: (y printStringFractionDigits: stepYDecimals), ' ' atWaistRight: tickLength negated @ y font: font color: c ]. - aCanvas drawString: 'y' atWaistRight: tickLength negated @ (y1 - (tickLength*4)) font: font color: c. - - aCanvas geometryTransformation: prevTx.! ! -!WidgetMorph methodsFor: 'halos and balloon help' stamp: 'jmv 9/7/2021 09:26:23' prior: 50601406 overrides: 50601400! - haloShowsCoordinateSystem - "We are usually not concerned with this level of detail for Widgets, as they prefer using automatic Layout." - - ^self requiresVectorCanvas! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4850-drawCoordinateSystem-enhancements-JuanVuletich-2021Sep07-11h16m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4849] on 7 September 2021 at 11:21:43 am'! -!WindowEdgeAdjustingMorph methodsFor: 'adjusting' stamp: 'jmv 9/7/2021 11:21:14' prior: 50603988 overrides: 50591463! - adjustOwnerAt: aGlobalPoint millisecondSinceLast: millisecondSinceLast - - self basicAdjustOwnerAt: aGlobalPoint. - - "If UI is becoming slow or is optimized for slow systems, resize without - showing window contents, but only edges. But don't do it for rotated Windows!!" - (owner isOrAnyOwnerIsRotated not and: [ - Preferences cheapWindowReframe or: [millisecondSinceLast > 200]]) ifTrue: [ - owner displayBounds newRectFrom: [ :f | - self basicAdjustOwnerAt: Sensor mousePoint. - owner morphPosition extent: owner morphExtentInWorld ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4851-cheapWindowReframe-lessAgressive-JuanVuletich-2021Sep07-11h17m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4851] on 7 September 2021 at 12:04:13 pm'! -!CodeWindow methodsFor: 'updating' stamp: 'jmv 9/7/2021 12:02:33' prior: 50602594! - updateListsAndCode - "All code windows receive this message on any code change in the system. - Process it only once, for the benefit of installing large packages!!" - - (self hasProperty: #updateListsAndCode) ifFalse: [ - self setProperty: #updateListsAndCode toValue: true. - self whenUIinSafeState: [ - self removeProperty: #updateListsAndCode. - owner ifNotNil: [ self updateListsAndCodeNow ]]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4852-CodeWindow-updateListsAndCode-afterClose-fix-JuanVuletich-2021Sep07-12h02m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4809] on 5 September 2021 at 10:49:47 pm'! - -Smalltalk removeClassNamed: #ExtractMethodApplier! - -!classRemoval: #ExtractMethodApplier stamp: 'Install-4853-ExtractMethodEnhancement-HernanWilkinson-2021Aug25-15h32m-HAW.001.cs.st 9/21/2021 12:54:38'! -RefactoringApplier subclass: #ExtractMethodApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newSelector newMessageArguments codeProvider' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Smalltalk removeClassNamed: #ExtractMethod! - -!classRemoval: #ExtractMethod stamp: 'Install-4853-ExtractMethodEnhancement-HernanWilkinson-2021Aug25-15h32m-HAW.001.cs.st 9/21/2021 12:54:38'! -Refactoring subclass: #ExtractMethod - instanceVariableNames: 'intervalToExtract categoryOfNewSelector newMessage extractedSourceCode existingMethod' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MessageSet subclass: #ExtractMethodMessageSet - instanceVariableNames: 'finder selectedIndex' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractMethodMessageSet category: #'Tools-Refactoring' stamp: 'Install-4853-ExtractMethodEnhancement-HernanWilkinson-2021Aug25-15h32m-HAW.001.cs.st 9/21/2021 12:54:38'! -MessageSet subclass: #ExtractMethodMessageSet - instanceVariableNames: 'finder selectedIndex' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -MessageSetWindow subclass: #ExtractMethodReplacementsWindow - instanceVariableNames: 'applier finder' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractMethodReplacementsWindow category: #'Tools-Refactoring' stamp: 'Install-4853-ExtractMethodEnhancement-HernanWilkinson-2021Aug25-15h32m-HAW.001.cs.st 9/21/2021 12:54:38'! -MessageSetWindow subclass: #ExtractMethodReplacementsWindow - instanceVariableNames: 'applier finder' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Object subclass: #ExtractMethodReplacementsFinder - instanceVariableNames: 'intervalToExtract sourceMethod replacements newMessage sourceCodeToExtract sizeToExtract' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractMethodReplacementsFinder category: #'Tools-Refactoring' stamp: 'Install-4853-ExtractMethodEnhancement-HernanWilkinson-2021Aug25-15h32m-HAW.001.cs.st 9/21/2021 12:54:38'! -Object subclass: #ExtractMethodReplacementsFinder - instanceVariableNames: 'intervalToExtract sourceMethod replacements newMessage sourceCodeToExtract sizeToExtract' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Refactoring subclass: #ExtractMethod - instanceVariableNames: 'extractMethodNewMethod collectionOfReplacements' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractMethod category: #'Tools-Refactoring' stamp: 'Install-4853-ExtractMethodEnhancement-HernanWilkinson-2021Aug25-15h32m-HAW.001.cs.st 9/21/2021 12:54:38'! -Refactoring subclass: #ExtractMethod - instanceVariableNames: 'extractMethodNewMethod collectionOfReplacements' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!ExtractMethod commentStamp: '' prior: 0! - I am a refactoring that extracts a selected piece of code to a separate method. The input is the following: - -* interval of code to extract (from index - to index) -* the CompiledMethod where this change applies -* the new method selector + argument names (instance of Message) -* the category name for the new method - -Many conditions have to be satisfied for this refactoring to be made, I delegate into SourceCodeOfMethodToBeExtractedPrecondition and NewSelectorPrecondition most of these checks. Refer to those classes' comments for more information.! - -Refactoring subclass: #ExtractMethodNewMethod - instanceVariableNames: 'intervalToExtract categoryOfNewSelector newMessage extractedSourceCode existingMethod' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractMethodNewMethod category: #'Tools-Refactoring' stamp: 'Install-4853-ExtractMethodEnhancement-HernanWilkinson-2021Aug25-15h32m-HAW.001.cs.st 9/21/2021 12:54:38'! -Refactoring subclass: #ExtractMethodNewMethod - instanceVariableNames: 'intervalToExtract categoryOfNewSelector newMessage extractedSourceCode existingMethod' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!ExtractMethodNewMethod commentStamp: '' prior: 0! - I am a refactoring that extracts a selected piece of code to a separate method. The input is the following: - -* interval of code to extract (from index - to index) -* the CompiledMethod where this change applies -* the new method selector + argument names (instance of Message) -* the category name for the new method - -Many conditions have to be satisfied for this refactoring to be made, I delegate into SourceCodeOfMethodToBeExtractedPrecondition and NewSelectorPrecondition most of these checks. Refer to those classes' comments for more information.! - -Refactoring subclass: #ExtractMethodReplacement - instanceVariableNames: 'intervalToExtract newMessage methodToExtractFrom callingExpression' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractMethodReplacement category: #'Tools-Refactoring' stamp: 'Install-4853-ExtractMethodEnhancement-HernanWilkinson-2021Aug25-15h32m-HAW.001.cs.st 9/21/2021 12:54:38'! -Refactoring subclass: #ExtractMethodReplacement - instanceVariableNames: 'intervalToExtract newMessage methodToExtractFrom callingExpression' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!ExtractMethodReplacement commentStamp: '' prior: 0! - I am a refactoring that extracts a selected piece of code to a separate method. The input is the following: - -* interval of code to extract (from index - to index) -* the CompiledMethod where this change applies -* the new method selector + argument names (instance of Message) -* the category name for the new method - -Many conditions have to be satisfied for this refactoring to be made, I delegate into SourceCodeOfMethodToBeExtractedPrecondition and NewSelectorPrecondition most of these checks. Refer to those classes' comments for more information.! - -RefactoringApplier subclass: #ExtractMethodApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newSelector newMessageArguments codeProvider sourceCodeToExtract newMethodRefactoring finder' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractMethodApplier category: #'Tools-Refactoring' stamp: 'Install-4853-ExtractMethodEnhancement-HernanWilkinson-2021Aug25-15h32m-HAW.001.cs.st 9/21/2021 12:54:38'! -RefactoringApplier subclass: #ExtractMethodApplier - instanceVariableNames: 'intervalToExtract methodToExtractCodeFrom newSelector newMessageArguments codeProvider sourceCodeToExtract newMethodRefactoring finder' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!ExtractMethodMessageSet methodsFor: 'initialization' stamp: 'HAW 9/5/2021 07:15:36' overrides: 50407630! - initialize - - selectedIndex := 0. - super initialize ! ! -!ExtractMethodMessageSet methodsFor: 'initialization' stamp: 'HAW 9/5/2021 00:12:23'! - initializeFinder: aFinder - - finder := aFinder.! ! -!ExtractMethodMessageSet methodsFor: 'message list' stamp: 'HAW 9/5/2021 07:15:16' overrides: 16792396! - messageListIndex - - ^selectedIndex ! ! -!ExtractMethodMessageSet methodsFor: 'message list' stamp: 'HAW 9/5/2021 07:14:51' overrides: 50390571! - messageListIndex: anIndex - - selectedIndex := anIndex. - ^super messageListIndex: anIndex ! ! -!ExtractMethodMessageSet methodsFor: 'message list' stamp: 'HAW 9/5/2021 21:52:26' overrides: 50442967! - removeMessageFromBrowserKeepingLabel - - | newIndex | - - selectedMessage ifNil: [ ^nil ]. - messageList removeIndex: selectedIndex. - finder removeReplacementAt: selectedIndex. - self changed: #messageList. - - newIndex := selectedIndex > messageList size - ifTrue: [ selectedIndex - 1 ] - ifFalse: [ selectedIndex ]. - self messageListIndex: newIndex.! ! -!ExtractMethodMessageSet methodsFor: 'source code ranges' stamp: 'HAW 9/5/2021 21:46:48' overrides: 50452605! - messageSendsRangesOf: aSelector - - | replacement | - - replacement := finder replacementsAt: self messageListIndex ifAbsent: [ ^#() ]. - - ^Array with: replacement intervalToExtract - ! ! -!ExtractMethodMessageSet class methodsFor: 'instance creation' stamp: 'HAW 9/5/2021 00:11:22'! - finder: aFinder - - ^(self messageList: aFinder methodsToReplace) initializeFinder: aFinder! ! -!MethodNode methodsFor: 'source ranges' stamp: 'HAW 8/26/2021 15:57:14'! - definitionStartPosition - - "It does not includes temp definition because the extract can include temps - Hernan" - ^self selectorLastPosition + 1! ! -!ExtractMethodReplacementsWindow methodsFor: 'actions' stamp: 'HAW 9/5/2021 20:41:28'! - closeAfter: aBlock - - aBlock value. - self whenUIinSafeState: [ self delete ]. - ! ! -!ExtractMethodReplacementsWindow methodsFor: 'actions' stamp: 'HAW 9/5/2021 20:41:16'! - extractAllInClass - - self closeAfter: [ applier valueWithMethodsInClass ]. - ! ! -!ExtractMethodReplacementsWindow methodsFor: 'actions' stamp: 'HAW 9/5/2021 20:41:43'! - extractInMethodOnly - - self closeAfter: [ applier valueWithSourceMethod ]. - ! ! -!ExtractMethodReplacementsWindow methodsFor: 'actions' stamp: 'HAW 9/5/2021 20:41:52'! - extractSelectionOnly - - self closeAfter: [ applier valueWithOriginalSelection ]. - ! ! -!ExtractMethodReplacementsWindow methodsFor: 'actions' stamp: 'HAW 9/5/2021 20:42:00'! - refactor - - self closeAfter: [ applier valueWithAllReplacements ]. - ! ! -!ExtractMethodReplacementsWindow methodsFor: 'actions' stamp: 'HAW 8/25/2021 22:07:31'! -remove - - model removeMessageFromBrowserKeepingLabel! ! -!ExtractMethodReplacementsWindow methodsFor: 'GUI building' stamp: 'HAW 8/25/2021 22:07:31'! - addButton: button to: row color: buttonColor - - button color: buttonColor. - row addMorph: button proportionalWidth: 10! ! -!ExtractMethodReplacementsWindow methodsFor: 'GUI building' stamp: 'HAW 9/5/2021 20:02:21'! - addButtonsTo: row color: buttonColor - - self - addButton: self createRemoveButton to: row color: buttonColor; - addButton: self createRefactorButton to: row color: buttonColor; - addButton: self createExtractSelectionOnlyButton to: row color: buttonColor; - addButton: self createExtractInMethodOnlyButton to: row color: buttonColor; - addButton: self createExtractAllInClassButton to: row color: buttonColor; - addButton: self createCancelButton to: row color: buttonColor. -! ! -!ExtractMethodReplacementsWindow methodsFor: 'GUI building' stamp: 'HAW 8/25/2021 22:07:31' overrides: 50518716! - buildLowerPanes - - | codeAndButtons | - - codeAndButtons _ LayoutMorph newColumn. - codeAndButtons - addMorph: self buttonsRow fixedHeight: self defaultButtonPaneHeight; - addAdjusterMorph; - addMorph: self buildMorphicCodePane proportionalHeight: 1.0. - - ^codeAndButtons ! ! -!ExtractMethodReplacementsWindow methodsFor: 'GUI building' stamp: 'HAW 8/25/2021 22:07:31'! - buttonsRow - - | buttonColor row | - - buttonColor := self buttonColor. - row := LayoutMorph newRow. - row doAdoptWidgetsColor. - row color: buttonColor. - - self addButtonsTo: row color: buttonColor. - - ^row - - ! ! -!ExtractMethodReplacementsWindow methodsFor: 'button creation' stamp: 'HAW 8/25/2021 22:07:31'! - createCancelButton - - ^PluggableButtonMorph - model: self - stateGetter: nil - action: #delete - label: 'Cancel'. -! ! -!ExtractMethodReplacementsWindow methodsFor: 'button creation' stamp: 'HAW 9/5/2021 19:55:47'! - createExtractAllInClassButton - - ^PluggableButtonMorph - model: self - stateGetter: nil - action: #extractAllInClass - label: 'In Class'! ! -!ExtractMethodReplacementsWindow methodsFor: 'button creation' stamp: 'HAW 9/5/2021 19:55:57'! - createExtractInMethodOnlyButton - - ^PluggableButtonMorph - model: self - stateGetter: nil - action: #extractInMethodOnly - label: 'In Method'! ! -!ExtractMethodReplacementsWindow methodsFor: 'button creation' stamp: 'HAW 9/5/2021 19:43:25'! - createExtractSelectionOnlyButton - - ^PluggableButtonMorph - model: self - stateGetter: nil - action: #extractSelectionOnly - label: 'Selection Only'! ! -!ExtractMethodReplacementsWindow methodsFor: 'button creation' stamp: 'HAW 9/5/2021 19:56:07'! - createRefactorButton - - ^PluggableButtonMorph - model: self - stateGetter: nil - action: #refactor - label: 'Refactor'! ! -!ExtractMethodReplacementsWindow methodsFor: 'button creation' stamp: 'HAW 9/5/2021 20:07:00'! - createRemoveButton - - ^PluggableButtonMorph - model: self - stateGetter: nil - action: #remove - label: 'Remove'. -! ! -!ExtractMethodReplacementsWindow methodsFor: 'initialization' stamp: 'HAW 9/4/2021 23:30:56'! - initializeFrom: anExtractMethodApplier with: aFinder - - applier := anExtractMethodApplier. - finder := aFinder ! ! -!ExtractMethodReplacementsWindow class methodsFor: 'instance creation' stamp: 'HAW 9/5/2021 20:31:15'! - openFrom: anExtractMethodApplier with: aFinder - - | window messageSet | - - messageSet := ExtractMethodMessageSet finder: aFinder. - "I have to set a autoSelectString even if I do not use it because if not the - autoSelect event is not triggered - Hernan" - messageSet autoSelectString: aFinder sourceCodeToExtract. - - window := self open: messageSet label: 'Select replacements'. - window initializeFrom: anExtractMethodApplier with: aFinder. - - ^window - -! ! -!ExtractMethodReplacementsFinder methodsFor: 'initialization' stamp: 'HAW 9/2/2021 17:31:19'! - initializeOfCodeIn: anIntervalToExtract at: aMethod to: aNewMessage - - intervalToExtract := anIntervalToExtract. - sourceMethod := aMethod. - newMessage := aNewMessage ! ! -!ExtractMethodReplacementsFinder methodsFor: 'private-replacement finding' stamp: 'HAW 9/5/2021 22:05:15'! - addReplacementAt: foundIntervalToExtract in: aMethod - - "If ther is an error creating the refactoring, then the found text is not extractable and - therefore should not be replaced - Hernan" - [ replacements add: (self createReplacementAt: foundIntervalToExtract in: aMethod) ] - on: RefactoringError - do: [ :anError | ].! ! -!ExtractMethodReplacementsFinder methodsFor: 'private-replacement finding' stamp: 'HAW 9/4/2021 21:03:06'! - createReplacementAt: foundIntervalToExtract in: aMethod - - ^ExtractMethodReplacement - fromInterval: foundIntervalToExtract asSourceCodeInterval - of: aMethod - to: newMessage! ! -!ExtractMethodReplacementsFinder methodsFor: 'private-replacement finding' stamp: 'HAW 9/4/2021 21:01:06'! - findReplacementsAt: aClass - - aClass methodsDo: [ :aMethod | self findReplacementsIn: aMethod asMethodReference ]! ! -!ExtractMethodReplacementsFinder methodsFor: 'private-replacement finding' stamp: 'HAW 9/4/2021 21:04:49'! - findReplacementsIn: aMethod - - | sourceCode foundIntervalToExtract sourceCodeToExtractStart | - - sourceCode := aMethod sourceCode. - sourceCodeToExtractStart := 1. - - [ sourceCodeToExtractStart := sourceCode indexOfSubCollection: sourceCodeToExtract startingAt: sourceCodeToExtractStart. - sourceCodeToExtractStart ~= 0 ] whileTrue: [ - foundIntervalToExtract := sourceCodeToExtractStart to: sourceCodeToExtractStart + sizeToExtract. - self addReplacementAt: foundIntervalToExtract in: aMethod. - sourceCodeToExtractStart := foundIntervalToExtract last + 1 ] - - ! ! -!ExtractMethodReplacementsFinder methodsFor: 'testing' stamp: 'HAW 9/4/2021 23:25:35'! - hasOneReplacement - - ^replacements size = 1! ! -!ExtractMethodReplacementsFinder methodsFor: 'replacements' stamp: 'HAW 9/5/2021 20:18:47'! - inClassReplacements - - ^replacements select: [ :aReplacement | aReplacement isAt: sourceMethod methodClass ]! ! -!ExtractMethodReplacementsFinder methodsFor: 'replacements' stamp: 'HAW 9/5/2021 00:12:03'! - methodsToReplace - - ^replacements collect: [ :aReplacement | aReplacement methodToExtractFrom ]! ! -!ExtractMethodReplacementsFinder methodsFor: 'replacements' stamp: 'HAW 9/5/2021 20:14:49'! - originalSelectionReplacement - - ^ExtractMethodReplacement fromInterval: intervalToExtract of: sourceMethod to: newMessage ! ! -!ExtractMethodReplacementsFinder methodsFor: 'replacements' stamp: 'HAW 9/5/2021 21:51:40'! - removeReplacementAt: anIndex - - ^replacements removeAt: anIndex ! ! -!ExtractMethodReplacementsFinder methodsFor: 'replacements' stamp: 'HAW 9/2/2021 17:41:27'! - replacements - - ^replacements ! ! -!ExtractMethodReplacementsFinder methodsFor: 'replacements' stamp: 'HAW 9/5/2021 07:24:58'! - replacementsAt: anIndex ifAbsent: ifAbsentBlock - - ^replacements at: anIndex ifAbsent: ifAbsentBlock ! ! -!ExtractMethodReplacementsFinder methodsFor: 'replacements' stamp: 'HAW 9/5/2021 20:17:31'! - sourceMethodReplacements - - ^replacements select: [:aReplacement | aReplacement isOf: sourceMethod ]! ! -!ExtractMethodReplacementsFinder methodsFor: 'evaluating' stamp: 'HAW 9/4/2021 21:00:59' overrides: 16881508! - value - - sourceCodeToExtract := sourceMethod sourceCode copyFrom: intervalToExtract first to: intervalToExtract last. - sizeToExtract := intervalToExtract size - 1. - replacements := OrderedCollection new. - - sourceMethod methodClass withAllSubclassesDo: [ :aClass | self findReplacementsAt: aClass] - ! ! -!ExtractMethodReplacementsFinder methodsFor: 'source code' stamp: 'HAW 9/5/2021 00:14:54'! - sourceCodeToExtract - - ^sourceCodeToExtract! ! -!ExtractMethodReplacementsFinder class methodsFor: 'instance creation' stamp: 'HAW 9/2/2021 17:31:33'! - ofCodeIn: anIntervalToExtract at: aMethod to: aNewMessage - - ^self new initializeOfCodeIn: anIntervalToExtract at: aMethod to: aNewMessage ! ! -!ExtractMethod methodsFor: 'initialization' stamp: 'HAW 9/5/2021 22:46:43'! - initializeNewDefinition: anExtractMethodNewMethod replacements: aCollectionOfReplacements - - extractMethodNewMethod := anExtractMethodNewMethod. - collectionOfReplacements := aCollectionOfReplacements.! ! -!ExtractMethod methodsFor: 'private - applying' stamp: 'HAW 9/5/2021 22:46:48'! - applyMethodReplacements: aMethodReplacements - - | adjustment sortedReplacements | - - adjustment := 0. - "This is not really necesary because the groupBy: keeps the order, but I do it just in case that is changed - Hernan" - sortedReplacements := aMethodReplacements sorted: [ :leftReplacement :rightReplacement | leftReplacement isBefore: rightReplacement ]. - sortedReplacements do: [ :aReplacement | - aReplacement applyAdjusting: adjustment. - adjustment := adjustment + aReplacement adjustmentForNextReplacement ]! ! -!ExtractMethod methodsFor: 'private - applying' stamp: 'HAW 9/5/2021 22:46:51'! - applyReplacements - - | replacementsByMethod | - - replacementsByMethod := collectionOfReplacements groupBy: [ :aReplacement | aReplacement methodToExtractFrom ]. - replacementsByMethod valuesDo: [ :aMethodReplacements | self applyMethodReplacements: aMethodReplacements ]. - ! ! -!ExtractMethod methodsFor: 'private - applying' stamp: 'HAW 9/5/2021 22:46:54'! - createNewMethod - - extractMethodNewMethod apply. -! ! -!ExtractMethod methodsFor: 'applying' stamp: 'HAW 9/5/2021 22:46:38' overrides: 50438485! - apply - - self - createNewMethod; - applyReplacements ! ! -!ExtractMethod class methodsFor: 'instance creation' stamp: 'HAW 9/5/2021 22:46:15'! - fromInterval: anIntervalToExtract of: aMethodToExtractCodeFrom to: newMessage categorizedAs: aCategory - - ^self - newDefinition: (ExtractMethodNewMethod - fromInterval: anIntervalToExtract - of: aMethodToExtractCodeFrom - to: newMessage - categorizedAs: aCategory ) - replacements: (Array with: (ExtractMethodReplacement - fromInterval: anIntervalToExtract - of: aMethodToExtractCodeFrom - to: newMessage)) - -! ! -!ExtractMethod class methodsFor: 'instance creation' stamp: 'HAW 9/5/2021 22:46:32'! - newDefinition: anExtractMethodNewMethod replacements: aCollectionOfReplacements - - ^self new initializeNewDefinition: anExtractMethodNewMethod replacements: aCollectionOfReplacements ! ! -!ExtractMethodNewMethod methodsFor: 'applying' stamp: 'HAW 9/4/2021 15:55:33' overrides: 50438485! - apply - - self sourceClass - compile: self newMethodSourceCode - classified: categoryOfNewSelector! ! -!ExtractMethodNewMethod methodsFor: 'initialization' stamp: 'HAW 9/2/2021 18:09:20'! - initializeExtractedSourceCode - - extractedSourceCode := existingMethod sourceCode - copyFrom: intervalToExtract first - to: intervalToExtract last! ! -!ExtractMethodNewMethod methodsFor: 'initialization' stamp: 'HAW 9/2/2021 18:09:20'! - initializeFrom: anIntervalToExtract of: aMethodToExtractCodeFrom to: aNewMessage in: aCategory - - intervalToExtract := anIntervalToExtract. - existingMethod := aMethodToExtractCodeFrom. - newMessage := aNewMessage. - categoryOfNewSelector := aCategory. - self initializeExtractedSourceCode.! ! -!ExtractMethodNewMethod methodsFor: 'private - source code' stamp: 'HAW 9/2/2021 18:09:20'! - newMessageString - - ^ newMessage fullName! ! -!ExtractMethodNewMethod methodsFor: 'private - source code' stamp: 'HAW 9/2/2021 18:09:20'! - newMethodSourceCode - - ^ String streamContents: [ :stream | - stream - nextPutAll: self newMessageString; - nextPutAll: self startingMethodIdentation; - nextPutAll: self returnCharacterIfNeeded; - nextPutAll: extractedSourceCode ]! ! -!ExtractMethodNewMethod methodsFor: 'private - source code' stamp: 'HAW 9/2/2021 18:09:20'! - returnCharacterIfNeeded - - | extractedMethodNode | - - extractedMethodNode := Parser parse: extractedSourceCode class: self sourceClass noPattern: true. - - ^ (extractedMethodNode numberOfStatements > 1 or: [ extractedMethodNode hasTemporaryVariables ]) - ifTrue: [ '' ] ifFalse: [ '^ ' ]! ! -!ExtractMethodNewMethod methodsFor: 'private - source code' stamp: 'HAW 9/2/2021 18:09:20'! - sourceClass - - ^ existingMethod methodClass! ! -!ExtractMethodNewMethod methodsFor: 'private - source code' stamp: 'HAW 9/2/2021 18:09:20'! - startingMethodIdentation - - ^ String lfString , String lfString , String tab! ! -!ExtractMethodNewMethod class methodsFor: 'error messages' stamp: 'HAW 9/2/2021 18:09:20'! - noSelectionErrorMessage - - ^ 'Please select some code for extraction'! ! -!ExtractMethodNewMethod class methodsFor: 'error messages' stamp: 'HAW 9/2/2021 18:09:20'! - outOfBoundsSelectionErrorMessage - - ^ 'The requested source code selection interval is out of bounds'! ! -!ExtractMethodNewMethod class methodsFor: 'error messages' stamp: 'HAW 9/2/2021 18:09:20'! - wrongNumberOfArgumentsGivenErrorMessage - - ^ 'The number of arguments in the given selector is not correct'! ! -!ExtractMethodNewMethod class methodsFor: 'exceptions' stamp: 'HAW 9/2/2021 18:09:20'! - signalExtractMethodWithWrongNumberOfArgumentsError - - self refactoringError: self wrongNumberOfArgumentsGivenErrorMessage! ! -!ExtractMethodNewMethod class methodsFor: 'exceptions' stamp: 'HAW 9/2/2021 18:09:20'! - signalNoSelectedCodeError - - self refactoringError: self noSelectionErrorMessage! ! -!ExtractMethodNewMethod class methodsFor: 'exceptions' stamp: 'HAW 9/2/2021 18:09:20'! - signalOutOfBoundsIntervalError - - self refactoringError: self outOfBoundsSelectionErrorMessage! ! -!ExtractMethodNewMethod class methodsFor: 'instance creation' stamp: 'HAW 9/2/2021 18:09:20'! - fromInterval: anIntervalToExtract of: aMethodToExtractCodeFrom to: newMessage categorizedAs: aCategory - - | trimmedIntervalToExtract | - - trimmedIntervalToExtract := anIntervalToExtract trimToMatchExpressionOn: aMethodToExtractCodeFrom sourceCode. - self - assert: newMessage selector canBeDefinedIn: aMethodToExtractCodeFrom methodClass; - assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: trimmedIntervalToExtract; - assert: newMessage hasValidParametersForExtracting: anIntervalToExtract from: aMethodToExtractCodeFrom methodNode. - - ^ self new - initializeFrom: trimmedIntervalToExtract - of: aMethodToExtractCodeFrom - to: newMessage - in: aCategory! ! -!ExtractMethodNewMethod class methodsFor: 'pre-conditions' stamp: 'HAW 9/2/2021 18:09:20'! - assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: anIntervalToExtract - - self - assertIntervalToExtractIsNotEmpty: anIntervalToExtract; - assert: anIntervalToExtract isWithinBoundsOf: aMethodToExtractCodeFrom sourceCode; - assert: aMethodToExtractCodeFrom containsValidCodeToBeExtractedAt: anIntervalToExtract! ! -!ExtractMethodNewMethod class methodsFor: 'private - pre-conditions' stamp: 'HAW 9/2/2021 18:09:20'! - assert: aSelector canBeDefinedIn: aClass - - NewSelectorPrecondition valueFor: aSelector on: aClass! ! -!ExtractMethodNewMethod class methodsFor: 'private - pre-conditions' stamp: 'HAW 9/2/2021 18:09:20'! - assert: aMethodToRefactor containsValidCodeToBeExtractedAt: anIntervalToExtract - - SourceCodeOfMethodToBeExtractedPrecondition valueFor: anIntervalToExtract of: aMethodToRefactor! ! -!ExtractMethodNewMethod class methodsFor: 'private - pre-conditions' stamp: 'HAW 9/2/2021 18:09:20'! - assert: newMessage hasValidParametersForExtracting: anIntervalToExtract from: aMethodNodeToRefactor - - | parseNodesToParameterize | - parseNodesToParameterize := ExtractMethodParametersDetector - valueFor: aMethodNodeToRefactor - at: anIntervalToExtract. - newMessage arguments size = parseNodesToParameterize size - ifFalse: [ self signalExtractMethodWithWrongNumberOfArgumentsError ]! ! -!ExtractMethodNewMethod class methodsFor: 'private - pre-conditions' stamp: 'HAW 9/2/2021 18:09:20'! - assert: anIntervalToExtract isWithinBoundsOf: sourceCode - - (self is: anIntervalToExtract withinBoundsOf: sourceCode) - ifFalse: [ self signalOutOfBoundsIntervalError ]! ! -!ExtractMethodNewMethod class methodsFor: 'private - pre-conditions' stamp: 'HAW 9/2/2021 18:09:20'! - assertIntervalToExtractIsNotEmpty: anIntervalToExtract - - (self isNotEmpty: anIntervalToExtract) - ifFalse: [ self signalNoSelectedCodeError ]! ! -!ExtractMethodNewMethod class methodsFor: 'private - pre-conditions' stamp: 'HAW 9/2/2021 18:09:20'! - is: anIntervalToExtract withinBoundsOf: aSourceCode - - ^ anIntervalToExtract first >= 1 and: [ anIntervalToExtract last <= aSourceCode size ]! ! -!ExtractMethodNewMethod class methodsFor: 'private - pre-conditions' stamp: 'HAW 9/2/2021 18:09:20'! - isNotEmpty: anInterval - - ^ anInterval first <= anInterval last! ! -!ExtractMethodReplacement methodsFor: 'applying' stamp: 'HAW 9/2/2021 17:38:51' overrides: 50438485! - apply - - self sourceClass - compile: self updatedSourceCodeOfExistingMethod - classified: methodToExtractFrom category! ! -!ExtractMethodReplacement methodsFor: 'applying' stamp: 'HAW 9/4/2021 20:59:16'! - applyAdjusting: anAdjustment - - intervalToExtract := (intervalToExtract + anAdjustment) asSourceCodeInterval. - self apply ! ! -!ExtractMethodReplacement methodsFor: 'initialization' stamp: 'HAW 9/4/2021 16:53:14'! - initializeFrom: anIntervalToExtract of: aMethodToExtractCodeFrom to: aNewMessage - - intervalToExtract := anIntervalToExtract. - methodToExtractFrom := aMethodToExtractCodeFrom. - newMessage := aNewMessage. - self initializeCallingExpression ! ! -!ExtractMethodReplacement methodsFor: 'private - source code' stamp: 'HAW 9/4/2021 16:31:47'! - initializeCallingExpression - - callingExpression := 'self ', self newMessageString. - self shouldBeEnclosedWithParens ifTrue: [ callingExpression := '(' , callingExpression , ')' ] - ! ! -!ExtractMethodReplacement methodsFor: 'private - source code' stamp: 'HAW 9/2/2021 17:06:21'! - newMessageString - - ^ newMessage fullName! ! -!ExtractMethodReplacement methodsFor: 'private - source code' stamp: 'HAW 9/2/2021 17:38:51'! - shouldBeEnclosedWithParens - - | initialNode finalNode parseNodesInCommon methodNode initialNodeAncestors finalNodeAncestors insideMessageNodeExpressions | - - methodNode _ methodToExtractFrom methodNode. - initialNodeAncestors _ methodNode parseNodesPathAt: intervalToExtract first ifAbsent: [ ^ false]. - finalNodeAncestors _ methodNode parseNodesPathAt: intervalToExtract last ifAbsent: [ ^ false ]. - parseNodesInCommon _ initialNodeAncestors intersection: finalNodeAncestors. - - initialNode _ (parseNodesInCommon at: 1 ifAbsent: [ ^ false ]) key. - finalNode _ (parseNodesInCommon at: 2 ifAbsent: [ ^ false ]) key. - insideMessageNodeExpressions _ initialNode isMessageNode and: [ finalNode isMessageNode ]. - - ^ insideMessageNodeExpressions - and: [ initialNode precedence < newMessage selector precedence ] - and: [ initialNode precedence <= finalNode precedence ]! ! -!ExtractMethodReplacement methodsFor: 'private - source code' stamp: 'HAW 9/2/2021 17:38:51'! -sourceClass - - ^ methodToExtractFrom methodClass! ! -!ExtractMethodReplacement methodsFor: 'private - source code' stamp: 'HAW 9/4/2021 16:37:55'! - updatedSourceCodeOfExistingMethod - - ^ methodToExtractFrom sourceCode - copyReplaceFrom: intervalToExtract first - to: intervalToExtract last - with: callingExpression! ! -!ExtractMethodReplacement methodsFor: 'accessing' stamp: 'HAW 9/2/2021 17:36:44'! - intervalToExtract - - ^intervalToExtract! ! -!ExtractMethodReplacement methodsFor: 'accessing' stamp: 'HAW 9/2/2021 17:38:51'! - methodToExtractFrom - - ^methodToExtractFrom ! ! -!ExtractMethodReplacement methodsFor: 'testing' stamp: 'HAW 9/4/2021 20:28:45'! -isAt: aClass - - ^methodToExtractFrom methodClass = aClass ! ! -!ExtractMethodReplacement methodsFor: 'testing' stamp: 'HAW 9/4/2021 17:02:06'! - isBefore: anExtractMethodReplacement - - ^anExtractMethodReplacement startsAfter: intervalToExtract first! ! -!ExtractMethodReplacement methodsFor: 'testing' stamp: 'HAW 9/2/2021 18:06:56'! - isOf: aMethod - - ^methodToExtractFrom = aMethod ! ! -!ExtractMethodReplacement methodsFor: 'testing' stamp: 'HAW 9/4/2021 17:02:34'! - startsAfter: aPosition - - ^intervalToExtract first > aPosition ! ! -!ExtractMethodReplacement methodsFor: 'adjustment' stamp: 'HAW 9/4/2021 16:50:17'! - adjustmentForNextReplacement - - ^callingExpression size - intervalToExtract size! ! -!ExtractMethodReplacement class methodsFor: 'instance creation' stamp: 'HAW 9/2/2021 17:26:03'! - fromInterval: anIntervalToExtract of: aMethodToExtractCodeFrom to: newMessage - - | trimmedIntervalToExtract | - - trimmedIntervalToExtract := anIntervalToExtract trimToMatchExpressionOn: aMethodToExtractCodeFrom sourceCode. - self assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: trimmedIntervalToExtract. - - ^ self new - initializeFrom: trimmedIntervalToExtract - of: aMethodToExtractCodeFrom - to: newMessage - ! ! -!ExtractMethodReplacement class methodsFor: 'pre-conditions' stamp: 'HAW 9/5/2021 22:07:25'! - assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: anIntervalToExtract - - ExtractMethodNewMethod assertCanApplyRefactoringOn: aMethodToExtractCodeFrom at: anIntervalToExtract -! ! -!RefactoringApplier methodsFor: 'refactoring - creation' stamp: 'HAW 8/26/2021 16:06:07'! - createAndSetRefactoringHandlingRefactoringExceptions: aCreatorBlock - - self valueHandlingRefactoringExceptions: [ refactoring := aCreatorBlock value] - ! ! -!ExtractMethodApplier methodsFor: 'initialization' stamp: 'HAW 9/5/2021 22:47:39'! - initializeOn: aCodeProvider for: anIntervalToExtract of: aMethodToExtractCodeFrom - - codeProvider := aCodeProvider. - intervalToExtract := anIntervalToExtract. - methodToExtractCodeFrom := MethodReference method: aMethodToExtractCodeFrom. - newMessageArguments := Dictionary new! ! -!ExtractMethodApplier methodsFor: 'refactoring - changes' stamp: 'HAW 9/5/2021 22:47:43' overrides: 50441445! - showChanges - - codeProvider currentMethodRefactored! ! -!ExtractMethodApplier methodsFor: 'refactoring - creation' stamp: 'HAW 9/5/2021 22:47:49' overrides: 50441322! - createRefactoring - - ^ self shouldNotImplement! ! -!ExtractMethodApplier methodsFor: 'refactoring - creation' stamp: 'HAW 9/5/2021 22:47:53'! - createRefactoringForMethodsInClass - - ^ self refactoringClass newDefinition: newMethodRefactoring replacements: finder inClassReplacements ! ! -!ExtractMethodApplier methodsFor: 'refactoring - creation' stamp: 'HAW 9/5/2021 22:47:57'! - createRefactoringForOriginalSelection - - ^ self refactoringClass newDefinition: newMethodRefactoring replacements: { finder originalSelectionReplacement }! ! -!ExtractMethodApplier methodsFor: 'refactoring - creation' stamp: 'HAW 9/5/2021 22:48:02'! - createRefactoringForSourceMethod - - ^ self refactoringClass newDefinition: newMethodRefactoring replacements: finder sourceMethodReplacements ! ! -!ExtractMethodApplier methodsFor: 'refactoring - creation' stamp: 'HAW 9/5/2021 22:48:06'! - createRefactoringWithAllReplacements - - ^ self refactoringClass newDefinition: newMethodRefactoring replacements: finder replacements ! ! -!ExtractMethodApplier methodsFor: 'refactoring - creation' stamp: 'HAW 9/5/2021 22:48:10'! - refactoringClass - - ^ ExtractMethod! ! -!ExtractMethodApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 9/5/2021 22:48:14'! - createExtractMethodNewMethodFor: newMessage - - ^ newMethodRefactoring := ExtractMethodNewMethod - fromInterval: intervalToExtract - of: methodToExtractCodeFrom - to: newMessage - categorizedAs: methodToExtractCodeFrom category! ! -!ExtractMethodApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 9/5/2021 22:48:17'! - findReplacementsWith: newMessage - - finder := ExtractMethodReplacementsFinder ofCodeIn: intervalToExtract at: methodToExtractCodeFrom to: newMessage. - finder value! ! -!ExtractMethodApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 9/5/2021 22:48:20'! - requestNewMessage - - | parseNodesToParameterize initialAnswer userAnswer | - - parseNodesToParameterize := self parseNodesToParameterize. - initialAnswer := self buildInitialSelectorAnswer: parseNodesToParameterize. - userAnswer := self request: 'New method name:' initialAnswer: initialAnswer. - - parseNodesToParameterize - ifEmpty: [ self saveUnarySelector: userAnswer ] - ifNotEmpty: [ self saveBinaryOrKeywordSelector: userAnswer withArguments: parseNodesToParameterize ]. - - ^self buildNewMessage. - ! ! -!ExtractMethodApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 9/5/2021 22:48:24' overrides: 50441340! - requestRefactoringParameters - - | newMessage | - - newMessage := self requestNewMessage. - self createExtractMethodNewMethodFor: newMessage. - self findReplacementsWith: newMessage. - - finder hasOneReplacement - ifTrue: [ self valueWithAllReplacements ] - ifFalse: [ ExtractMethodReplacementsWindow openFrom: self with: finder ] - ! ! -!ExtractMethodApplier methodsFor: 'private - new message' stamp: 'HAW 9/5/2021 22:48:29'! - buildNewMessage - - ^ Message - selector: newSelector - arguments: self newMessageArgumentNames! ! -!ExtractMethodApplier methodsFor: 'private - new message' stamp: 'HAW 9/5/2021 22:48:32'! - newMessageArgumentNames - - ^ newMessageArguments values collect: [ :parseNode | parseNode name ]! ! -!ExtractMethodApplier methodsFor: 'private - new message' stamp: 'HAW 9/5/2021 22:48:36'! - saveUnarySelector: userAnswer - - ^ newSelector := userAnswer asSymbol! ! -!ExtractMethodApplier methodsFor: 'value' stamp: 'HAW 9/5/2021 22:48:40' overrides: 50441449! - value - - requestExitBlock := [ ^self ]. - - self requestRefactoringParametersHandlingRefactoringExceptions -! ! -!ExtractMethodApplier methodsFor: 'value' stamp: 'HAW 9/5/2021 22:48:45'! - valueCreatingWith: aRefactoringCreationBlock - - self - createAndSetRefactoringHandlingRefactoringExceptions: aRefactoringCreationBlock; - applyRefactoring; - showChanges - - ! ! -!ExtractMethodApplier methodsFor: 'value' stamp: 'HAW 9/5/2021 22:48:48'! - valueWithAllReplacements - - self valueCreatingWith: [ self createRefactoringWithAllReplacements ] - ! ! -!ExtractMethodApplier methodsFor: 'value' stamp: 'HAW 9/5/2021 22:48:51'! - valueWithMethodsInClass - - self valueCreatingWith: [ self createRefactoringForMethodsInClass ]! ! -!ExtractMethodApplier methodsFor: 'value' stamp: 'HAW 9/5/2021 22:48:54'! - valueWithOriginalSelection - - self valueCreatingWith: [ self createRefactoringForOriginalSelection ]! ! -!ExtractMethodApplier methodsFor: 'value' stamp: 'HAW 9/5/2021 22:48:58'! - valueWithSourceMethod - - self valueCreatingWith: [ self createRefactoringForSourceMethod ]! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'HAW 9/5/2021 22:49:03'! - buildInitialSelectorAnswer: parseNodesToParameterize - "builds a selector with the shape of #m1 if unary, or #m1: something m2: else if it has args" - - ^ parseNodesToParameterize - ifEmpty: [ self formatAsKeyword: 'm1' ] - ifNotEmpty: [ parseNodesToParameterize - inject: '' - into: [ :partialSelector :parseNode | - | currentKeyword | - currentKeyword _ 'm' , (parseNodesToParameterize indexOf: parseNode) asString , ': '. - partialSelector - , (self formatAsKeyword: currentKeyword) - , (self formatAsMethodArgument: parseNode name) - , String newLineString ] ]! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'HAW 9/5/2021 22:49:06'! -formatAsKeyword: aKeyword - - ^ Text - string: aKeyword - attributes: (SHTextStylerST80 attributesFor: #patternKeyword)! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'HAW 9/5/2021 22:49:10'! - formatAsMethodArgument: aMethodArgumentName - - ^ Text - string: aMethodArgumentName - attributes: (SHTextStylerST80 attributesFor: #methodArg)! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'HAW 9/5/2021 22:49:13'! - parseNodesToParameterize - - ^ ExtractMethodParametersDetector - valueFor: methodToExtractCodeFrom methodNode - at: intervalToExtract! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'HAW 9/5/2021 22:49:16'! - saveBinaryOrKeywordSelector: userAnswer withArguments: parseNodesToParameterize - - self saveMessageArgumentsForEach: parseNodesToParameterize using: userAnswer. - newSelector := ('' join: (self selectorTokensOf: userAnswer)) asSymbol.! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'HAW 9/5/2021 22:49:20'! - saveMessageArgumentsForEach: parseNodesToParameterize using: userAnswer - - | newSelectorKeywords | - newSelectorKeywords _ self selectorTokensOf: userAnswer. - self validateRequiredParameters: parseNodesToParameterize haveACorrespondingKeywordIn: newSelectorKeywords. - parseNodesToParameterize withIndexDo: [ :parseNode :index | - newMessageArguments at: (newSelectorKeywords at: index) put: parseNode ]! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'HAW 9/5/2021 22:49:23'! - selectorTokensOf: userAnswer - "this selects the pieces of strings before each $:" - - ^ (userAnswer findTokens: ':') allButLast - collect: [ :tok | (tok findTokens: Character separators) last , ':' ]! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'HAW 9/5/2021 22:49:26'! - sourceCodeToExtract - - ^sourceCodeToExtract! ! -!ExtractMethodApplier methodsFor: 'private - parameterizing' stamp: 'HAW 9/5/2021 22:49:29'! - validateRequiredParameters: parseNodesToParameterize haveACorrespondingKeywordIn: newSelectorKeywords - - newSelectorKeywords size = parseNodesToParameterize size - ifFalse: [ ExtractMethodNewMethod signalExtractMethodWithWrongNumberOfArgumentsError ]! ! -!ExtractMethodApplier class methodsFor: 'instance creation' stamp: 'HAW 9/5/2021 22:47:32'! - on: aCodeProvider for: anIntervalToExtract of: aMethodToRefactor - - | trimmedIntervalToExtract sourceCode | - - sourceCode := aMethodToRefactor sourceCode. - trimmedIntervalToExtract := anIntervalToExtract trimToMatchExpressionOn: sourceCode.. - - self assertCanApplyRefactoringOn: aMethodToRefactor at: trimmedIntervalToExtract. - - ^ self new initializeOn: aCodeProvider for: trimmedIntervalToExtract of: aMethodToRefactor! ! -!ExtractMethodApplier class methodsFor: 'pre-conditions' stamp: 'HAW 9/5/2021 22:47:27'! - assertCanApplyRefactoringOn: aMethodToRefactor at: anIntervalToExtract - - ExtractMethodNewMethod - assertCanApplyRefactoringOn: aMethodToRefactor - at: anIntervalToExtract! ! -!SmalltalkEditor methodsFor: 'extract method' stamp: 'HAW 9/5/2021 20:36:00' prior: 50517565! - extractMethod - - self performCodeExtractionRefactoringWith: ExtractMethodApplier! ! -!ChangeSelectorWizardStepWindow methodsFor: 'button creation' stamp: 'HAW 9/5/2021 20:07:07' prior: 50438284! - createRemoveButton - - ^PluggableButtonMorph - model: self - stateGetter: nil - action: #remove - label: 'Remove'. -! ! -!AddInstanceVariable methodsFor: 'initialization' stamp: 'HAW 8/28/2021 17:44:36' prior: 50438535! - initializeNamed: aNewVariable to: aClassToRefactor - - newVariable := aNewVariable. - classToRefactor := aClassToRefactor ! ! -!RefactoringApplier methodsFor: 'refactoring - creation' stamp: 'HAW 8/26/2021 16:04:27' prior: 50441327! - createRefactoringHandlingRefactoringExceptions - - self createAndSetRefactoringHandlingRefactoringExceptions: [ self createRefactoring ] - ! ! -!SourceCodeIntervalPrecondition methodsFor: 'pre-conditions' stamp: 'HAW 8/26/2021 15:57:31' prior: 50529606! - assertSourceCodeIsNotPartOfMethodSignature - - self intervalToExtractIncludesPartOfMethodSignature - ifTrue: [ self signalExtractingPartOfMethodSignatureError ]! ! -!SourceCodeIntervalPrecondition methodsFor: 'private' stamp: 'HAW 8/26/2021 15:56:33' prior: 50529660! - methodDefinitionStartPosition - - ^methodNode definitionStartPosition! ! -!MethodReference methodsFor: 'decompiling' stamp: 'HAW 9/5/2021 23:06:10'! - methodNode - - ^self compiledMethod methodNode! ! -!CompiledMethod methodsFor: 'converting' stamp: 'HAW 9/5/2021 23:06:10'! - asMethodReference - - ^MethodReference method: self! ! - -SourceCodeIntervalPrecondition removeSelector: #firstParseNodeOfMethodDefinition! - -!methodRemoval: SourceCodeIntervalPrecondition #firstParseNodeOfMethodDefinition stamp: 'Install-4853-ExtractMethodEnhancement-HernanWilkinson-2021Aug25-15h32m-HAW.001.cs.st 9/21/2021 12:54:38'! -firstParseNodeOfMethodDefinition - - ^ methodNode hasTemporaryVariables - ifTrue: [ methodNode temporariesDeclaration ] - ifFalse: [ methodNode block statements first - ifNotNil: [ :statement | statement ] - ifNil: [ methodNode ] ]! - -ChangeSelectorWizardStepWindow removeSelector: #isMessageSelected! - -!methodRemoval: ChangeSelectorWizardStepWindow #isMessageSelected stamp: 'Install-4853-ExtractMethodEnhancement-HernanWilkinson-2021Aug25-15h32m-HAW.001.cs.st 9/21/2021 12:54:38'! -isMessageSelected - - ^model isNil ifTrue: [ false ] ifFalse: [ model selection notNil ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4853-ExtractMethodEnhancement-HernanWilkinson-2021Aug25-15h32m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4853] on 7 September 2021 at 12:53:40 pm'! -!HaloMorph methodsFor: 'drawing' stamp: 'jmv 9/7/2021 12:52:43' prior: 50605835! - drawCoordinateSystemOn: aCanvas - - | x0 x1 y0 y1 c stepX stepY haloTargetTx prevTx font strokeWidth tickLength stepXDecimals stepYDecimals | - haloTargetTx _ MorphicTranslation identity. - target allOwnersReverseDo: [ :o | haloTargetTx _ haloTargetTx composedWith: o location ]. - haloTargetTx _ haloTargetTx composedWith: target location. - - target knowsOwnLocalBounds - ifTrue: [ | r | - r _ target morphLocalBounds. - x0 _ r left. - x1 _ r right. - y0 _ r top. - y1 _ r bottom ] - ifFalse: [ - x0 _ x1 _ y0 _ y1 _ 0. - target displayFullBounds corners collect: [ :pt | | p | - p _ haloTargetTx inverseTransform: pt. - x0 _ x0 min: p x. - x1 _ x1 max: p x. - y0 _ y0 min: p y. - y1 _ y1 max: p y.]]. - - font _ FontFamily defaultFamilyPointSize: FontFamily defaultPointSize * 1.5 / haloTargetTx scale. - stepX _ (font pointSize * 9) round4perMagnitudeOrder asFloat. - stepXDecimals _ stepX log rounded negated + 1. - stepY _ (font pointSize * 5) round4perMagnitudeOrder asFloat. - stepYDecimals _ stepY log rounded negated + 1. - strokeWidth _ 3/ haloTargetTx scale. - tickLength _ 5 / haloTargetTx scale. - - prevTx _ aCanvas currentTransformation. - aCanvas geometryTransformation: haloTargetTx. - - c _ `Color black alpha: 0.4`. - aCanvas line: x0@0 to: x1@0 width: strokeWidth color: c. - aCanvas line: 0@y0 to: 0@y1 width: strokeWidth color: c. - - (x0 truncateTo: stepX) to: x1 by: stepX do: [ :x | - aCanvas line: x @ tickLength negated to: x @ tickLength width: strokeWidth color: c. - aCanvas drawString: (x printStringFractionDigits: stepXDecimals) atCenterXBaselineY: x @ (tickLength*2) negated font: font color: c ]. - aCanvas drawString: 'x' atCenterX: x1 - (tickLength*3) @ 0 font: font color: c. - - (y0 truncateTo: stepY) to: y1 by: stepY do: [ :y | - aCanvas line: tickLength negated @ y to: tickLength @ y width: strokeWidth color: c. - aCanvas drawString: (y printStringFractionDigits: stepYDecimals), ' ' atWaistRight: tickLength negated @ y font: font color: c ]. - aCanvas drawString: 'y' atWaist: tickLength @ (y1 - (tickLength*4)) font: font color: c. - - aCanvas geometryTransformation: prevTx.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4854-drawCoordinates-tweak-JuanVuletich-2021Sep07-12h50m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4854] on 9 September 2021 at 2:05:28 pm'! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 9/9/2021 14:05:20' prior: 50595408! - updateBoundsIn: aWorldMorph addDamageTo: aDamageRecorder - - aWorldMorph haloMorphsDo: [ :halo | - (halo target isRedrawNeeded or: [halo target isSubmorphRedrawNeeded]) ifTrue: [ - "Invalidation of halos requires this specific sequence:" - halo redrawNeeded. "invalidate old halo bounds" - self fullAddRedrawRect: halo target to: aDamageRecorder. "recompute & invalidate target bounds" - self fullAddRedrawRect: halo to: aDamageRecorder ]]. "recompute & invalidate halo bounds" - "bogus iteration on halos and targets below is harmless: - Both now marked as neither #isRedrawNeeded nor #isSubmorphRedrawNeeded." - - aWorldMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - self updateHandsDisplayBounds: aWorldMorph.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4855-BoundsFinder-fix-JuanVuletich-2021Sep09-14h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4855] on 10 September 2021 at 4:10:30 pm'! -!MouseEvent methodsFor: 'button state' stamp: 'jmv 9/10/2021 16:02:58'! - turnMouseButton2Into3 - "Answer true if modifier keys are such that button 2 should be considered as button 3. - ctrl - click right -> center click - " - - self controlKeyPressed ifTrue: [ ^ true ]. - ^ false! ! -!MouseEvent methodsFor: 'button state' stamp: 'jmv 9/10/2021 16:08:01' prior: 50467588! - mouseButton2Pressed - "Answer true if the mouseButton2 is being pressed. - Reported by the VM for right mouse button or option+click on the Mac, ctrl-click on Windows, or ctrl-click or alt-click on Linux. - It is also emulated here with ctrl-click on any platform." - - (self turnMouseButton1Into2 and: [ buttons anyMask: InputSensor mouseButton1 ]) - ifTrue: [ ^ true ]. - self turnMouseButton2Into3 ifTrue: [ ^ false ]. - ^ buttons anyMask: InputSensor mouseButton2! ! -!MouseEvent methodsFor: 'button state' stamp: 'jmv 9/10/2021 16:06:43' prior: 50467604! - mouseButton3Pressed - "Answer true if the mouseButton3 is being pressed. - Reported by the VM for center (wheel) mouse button or cmd+click on the Mac or win/meta+click on Windows and Linux. - It is also emulated here with on any platform with: - shift - ctrl - click - ctrl - rightClick" - - (self turnMouseButton1Into3 and: [ buttons anyMask: InputSensor mouseButton1 ]) - ifTrue: [ ^ true ]. - (self turnMouseButton2Into3 and: [ buttons anyMask: InputSensor mouseButton2 ]) - ifTrue: [ ^ true ]. - ^ buttons anyMask: InputSensor mouseButton3! ! -!MouseButtonEvent methodsFor: 'accessing' stamp: 'jmv 9/10/2021 16:09:10' prior: 50467641! - mouseButton2Changed - "Answer true if the mouseButton2 has changed. - Reported by the VM for right mouse button or option+click on the Mac. - It is also emulated here with ctrl-click on any platform. - The check for button change (instead of button press) is specially useful on buttonUp events." - - (self turnMouseButton1Into2 and: [ whichButton anyMask: InputSensor mouseButton1 ]) - ifTrue: [ ^ true ]. - self turnMouseButton2Into3 ifTrue: [ ^ false ]. - ^ whichButton anyMask: InputSensor mouseButton2! ! -!MouseButtonEvent methodsFor: 'accessing' stamp: 'jmv 9/10/2021 16:07:19' prior: 50467658! - mouseButton3Changed - "Answer true if the mouseButton3 has changed. - Reported by the VM for center (wheel) mouse button or cmd+click on the Mac or meta+click on Linux. - It is also emulated here with shift-ctrl-click or ctrl-rightClick on any platform. - The check for button change (instead of button press) is specially useful on buttonUp events." - - (self turnMouseButton1Into3 and: [ whichButton anyMask: InputSensor mouseButton1 ]) - ifTrue: [ ^ true ]. - (self turnMouseButton2Into3 and: [ whichButton anyMask: InputSensor mouseButton2 ]) - ifTrue: [ ^ true ]. - ^ whichButton anyMask: InputSensor mouseButton3! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4856-ctrl-rightClick-emulatesCenterClick-JuanVuletich-2021Sep10-16h02m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4856] on 13 September 2021 at 3:51:30 pm'! -!ScrollBar methodsFor: 'events' stamp: 'jmv 9/13/2021 15:51:20' prior: 16904535 overrides: 16874668! - mouseStillDown - - nextPageDirection notNil ifTrue: [ - self scrollByPage ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4857-AvoidWalkbackOnLost-mouseDown-JuanVuletich-2021Sep13-15h51m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4856] on 13 September 2021 at 4:08:19 pm'! -!WorldMorph methodsFor: 'canvas' stamp: 'jmv 9/13/2021 16:07:58' prior: 50603143! - setMainCanvas - "Deallocate before allocating could mean less memory stress." - - self clearCanvas. - self setCanvas: Display getMainCanvas. - self restoreDisplay.! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 9/13/2021 16:03:02' prior: 50604478! - checkForNewScreenSize - "Check whether the screen size has changed and if so take appropriate actions" - - DisplayScreen isDisplayExtentOk ifFalse: [ - self clearCanvas. - DisplayScreen startUp. - self setMainCanvas. - self whenUIinSafeState: [ Cursor defaultCursor activateCursor ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4858-MainWindowResizeCleanup-JuanVuletich-2021Sep13-15h51m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4858] on 14 September 2021 at 3:57:49 pm'! -!WidgetMorph methodsFor: 'drawing' stamp: 'jmv 9/13/2021 17:26:04' overrides: 50578163! - imageForm: extentOrNil depth: depth - - | answerExtent answer auxCanvas | - self requiresVectorCanvas ifFalse: [ - answerExtent _ extent. - extentOrNil ifNotNil: [ answerExtent _ answerExtent min: extentOrNil * 4 ]. - auxCanvas _ MorphicCanvas depth: depth over: (self morphPosition floor extent: answerExtent ceiling). - auxCanvas fullDraw: self. - answer _ auxCanvas form divideByAlpha. - extentOrNil ifNotNil: [ answer _ answer magnifyTo: extentOrNil ]. - ^answer ]. - ^super imageForm: extentOrNil depth: depth.! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 9/13/2021 17:26:23' prior: 50578163! - imageForm: extentOrNil depth: depth - - self subclassResponsibility! ! - -MovableMorph removeSelector: #privateLocation:! - -!methodRemoval: MovableMorph #privateLocation: stamp: 'Install-4859-imageFormdepth-refactor-JuanVuletich-2021Sep14-15h55m-jmv.001.cs.st 9/21/2021 12:54:38'! -privateLocation: aGeometryTransformation - location _ aGeometryTransformation.! - -Morph removeSelector: #privateLocation:! - -!methodRemoval: Morph #privateLocation: stamp: 'Install-4859-imageFormdepth-refactor-JuanVuletich-2021Sep14-15h55m-jmv.001.cs.st 9/21/2021 12:54:38'! -privateLocation: aGeometryTransformation! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4859-imageFormdepth-refactor-JuanVuletich-2021Sep14-15h55m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4859] on 14 September 2021 at 4:21:17 pm'! -!DisplayScreen methodsFor: 'other' stamp: 'jmv 9/14/2021 16:20:04' prior: 16835206! - forceToScreen: aRectangle - "Force the given rectangular section of the Display to be copied to the screen. The primitive call does nothing if the primitive is not implemented. Used when the deferUpdates flag in the virtual machine is on; see #deferUpdates:. - - If for whatever reason, actual OS or hardware Display is smaller than us, don't go outside its bounds. - This can sometimes happen, at least on MacOS, when frantically resizing the main OS Cuis window, - while Morphic is busy drawing many heavy morphs: it could be observed than apparently in #displayWorld, - after we were updated in #checkForNewScreenSize, MacOS window could be made smaller than aRectangle, - and a hard crash due to an invalid memory access happened in this primitive." - - | platformDisplayExtent | - platformDisplayExtent _ DisplayScreen actualScreenSize. - self primShowRectLeft: (aRectangle left max: 0) - right: (aRectangle right min: platformDisplayExtent x) - top: (aRectangle top max: 0) - bottom: (aRectangle bottom min: platformDisplayExtent y). -! ! -!WorldMorph methodsFor: 'drawing' stamp: 'jmv 9/14/2021 16:20:41' prior: 50551878! - displayWorld - "Update this world's display." - - | deferredUpdateVMMode worldDamageRects handsToDraw allDamage | - self checkIfUpdateNeeded ifFalse: [ ^ self ]. "display is already up-to-date" - "I (jmv) removed the call to 'deferUpdates: false' below. No more need to call this every time." - deferredUpdateVMMode _ self tryDeferredUpdatingAndSetCanvas. - - "repair world's damage on canvas" - worldDamageRects _ canvas drawWorld: self repair: damageRecorder. - - "Check which hands need to be drawn (they are not the hardware mouse pointer)" - handsToDraw _ self selectHandsToDrawForDamage: worldDamageRects. - allDamage _ Array streamContents: [ :strm | - strm nextPutAll: worldDamageRects. - handsToDraw do: [ :h | - h savePatchFrom: canvas appendDamageTo: strm ]]. - - "Draw hands (usually carying morphs) onto world canvas" - canvas newClipRect: nil. - handsToDraw reverseDo: [ :h | canvas fullDrawHand: h ]. - - "quickly copy altered rects of canvas to Display:" - deferredUpdateVMMode ifFalse: [ - "Drawing was done to off-Display canvas. Copy content to Display" - canvas showAt: self viewBox origin invalidRects: allDamage ]. - - "Display deferUpdates: false." - "Display forceDisplayUpdate" - DisplayScreen isDisplayExtentOk ifTrue: [ - Display forceDamageToScreen: allDamage ]. - - "Restore world canvas under hands and their carried morphs" - handsToDraw do: [ :h | h restoreSavedPatchOn: canvas ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4860-fixUnlikelyCrashOnMainWindowResize-JuanVuletich-2021Sep14-16h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4860] on 15 September 2021 at 9:48:57 am'! -!GeometryTransformation methodsFor: 'modifying' stamp: 'jmv 9/14/2021 18:16:54'! - invertingYAxis: mustInvertYAxis - "Answer an instance (either the receiver or a new one) with the prescribed behavior on the Y axis: - - If mustInvertYAxis, the Y axis in inner and outer space point in opposite directions. - - If mustInvertYAxis is false, the Y axis in inner and outer space point in the same direction (either up or down). - Senders should always use the returned object, but not assume it is a new one: - it could also be the receiver itself." - - self doesMirror = mustInvertYAxis ifFalse: [ - ^self withCurrentYAxisInverted ]. - ^self! ! -!GeometryTransformation methodsFor: 'modifying' stamp: 'jmv 9/14/2021 18:15:52'! - withCurrentYAxisInverted - "Answer an instance (either the receiver or a new one) that flips the current direction of the Y axis. - This means that whatever we answer when externalizing x@y, it will answer when externalizing x @ -y. - Senders should always use the returned object, but not assume it is a new one: - it could also be the receiver itself." - - self subclassResponsibility! ! -!AffineTransformation methodsFor: 'modifying' stamp: 'jmv 9/14/2021 18:15:58' overrides: 50607765! - withCurrentYAxisInverted - "Answer an instance (either the receiver or a new one) that flips the current direction of the Y axis. - This means that whatever we answer when externalizing x@y, it will answer when externalizing x @ -y. - Senders should always use the returned object, but not assume it is a new one (like for MorphicTranslation): - it could also be the receiver itself, like when the receiver is already a AffineTransformation." - - self a12: self a12 negated. - self a22: self a22 negated. - ^self! ! -!MorphicTranslation methodsFor: 'modifying' stamp: 'jmv 9/14/2021 18:16:01' overrides: 50607765! -withCurrentYAxisInverted - "Answer an instance (either the receiver or a new one) that flips the current direction of the Y axis. - This means that whatever we answer when externalizing x@y, it will answer when externalizing x @ -y. - Senders should always use the returned object, but not assume it is a new one (like here): - it could also be the receiver itself, like when the receiver is already a AffineTransformation." - - ^(AffineTransformation withTranslation: self translation) withCurrentYAxisInverted! ! -!MovableMorph methodsFor: 'geometry testing' stamp: 'jmv 9/14/2021 18:21:50'! - yAxisPointsUp - "By default, most morphs assume the usual convention in 2d computer graphics: - - x points to the right (i.e. increasing x values move from left to right) - - y points down (i.e. increasing y values move from top to bottom) - Subclasses wanting to follow the standard math convention, making increasing y values move upwards - should redefine this method to answer true." - - ^false! ! -!MovableMorph methodsFor: 'private' stamp: 'jmv 9/14/2021 18:24:55'! - fixYAxisDirection - "Ensure the direction of the Y axis used by our location for coordinate transformations matches our #yAxisPointsUp." - - | ownersYAxisPointsUp | - ownersYAxisPointsUp _ owner ifNil: [false] ifNotNil: [owner yAxisPointsUp]. - location _ location invertingYAxis: (self yAxisPointsUp = ownersYAxisPointsUp) not! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 9/14/2021 18:58:27'! - drawString: s atWaistCenter: pt font: fontOrNil color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - - | font dy | - font _ self fontToUse: fontOrNil. - dy _ currentTransformation doesMirror - ifFalse: [ font ascent * 0.4 ] - ifTrue: [ font ascent * -0.4 ]. - ^self - drawString: s - from: 1 to: s size - atBaseline: pt + ((font widthOfString: s) negated / 2 @ dy) - font: font color: aColor! ! -!GeometryTransformation methodsFor: 'testing' stamp: 'jmv 9/13/2021 17:01:20' prior: 50560820! - doesMirror - "Return true if the receiver mirrors points around some rect. - Usually this is interpreted as (and used for) inverting the direction of the Y axis between the inner and the outer coordinates systems." - - ^false! ! -!AffineTransformation methodsFor: 'testing' stamp: 'jmv 9/13/2021 17:01:13' prior: 50560826 overrides: 50607864! - doesMirror - "Return true if the receiver mirrors points around some rect. - Usually this is interpreted as (and used for) inverting the direction of the Y axis between the inner and the outer coordinates systems." - - | f | - f _ self a11 * self a22. - ^ f = 0.0 - ifTrue: [ self a12 * self a21 > 0.0] - ifFalse: [ f < 0.0 ]! ! -!MovableMorph methodsFor: 'accessing' stamp: 'jmv 9/14/2021 18:27:26' prior: 50576180 overrides: 50559745! - location: aGeometryTransformation - location _ aGeometryTransformation. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self fixYAxisDirection. - self redrawNeeded.! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 9/15/2021 09:45:04' prior: 50554340! - rotateBy: radians - "Change the rotation of this morph. Argument is an angle (possibly negative), to be added to current rotation." - - | r | - r _ self yAxisPointsUp ifTrue: [ radians negated ] ifFalse: [ radians ]. - location _ location rotatedBy: r. - self fixYAxisDirection. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 9/15/2021 09:44:18' prior: 50554359 overrides: 50554636! - rotation: radians scale: scale - "Change the rotation and scale of this morph. Arguments are an angle and a scale." - - | r | - r _ self yAxisPointsUp ifTrue: [ radians negated ] ifFalse: [ radians ]. - location _ location withRotation: r scale: scale. - self fixYAxisDirection. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded.! ! -!MovableMorph methodsFor: 'private' stamp: 'jmv 9/14/2021 18:26:53' prior: 50554473 overrides: 50590167! - privateOwner: aMorph - "Private!! Should only be used by methods that maintain the ower/submorph invariant." - - | oldGlobalPosition prevOwner | - - self flag: #jmvVer2. - "Is this the best behavior???" - prevOwner _ owner. - prevOwner - ifNotNil: [ - "Had an owner. Maintain my global position..." - oldGlobalPosition _ self morphPositionInWorld ]. - owner _ aMorph. - owner - ifNil: [ - "Won't have any owner. Keep local position, as it will be maintained in my new owner later" - ] - ifNotNil: [ - prevOwner - ifNil: [ - "Didn't have any owner. Assume my local position is to be maintained in my new owner" - ] - ifNotNil: [ - "Had an owner. Maintain my global position..." - location _ location withTranslation: (owner internalizeFromWorld: oldGlobalPosition). - self flag: #jmvVer2. - "extent _ owner internalizeDistanceFromWorld: oldGlobalExtent" "or something like this!!" - ]]. - self fixYAxisDirection.! ! -!HaloMorph methodsFor: 'drawing' stamp: 'jmv 9/14/2021 18:59:01' prior: 50607357! - drawCoordinateSystemOn: aCanvas - - | x0 x1 y0 y1 c stepX stepY haloTargetTx prevTx font strokeWidth tickLength stepXDecimals stepYDecimals | - haloTargetTx _ MorphicTranslation identity. - target allOwnersReverseDo: [ :o | haloTargetTx _ haloTargetTx composedWith: o location ]. - haloTargetTx _ haloTargetTx composedWith: target location. - - target knowsOwnLocalBounds - ifTrue: [ | r | - r _ target morphLocalBounds. - x0 _ r left. - x1 _ r right. - y0 _ r top. - y1 _ r bottom ] - ifFalse: [ - x0 _ x1 _ y0 _ y1 _ 0. - target displayFullBounds corners collect: [ :pt | | p | - p _ haloTargetTx inverseTransform: pt. - x0 _ x0 min: p x. - x1 _ x1 max: p x. - y0 _ y0 min: p y. - y1 _ y1 max: p y.]]. - - font _ FontFamily defaultFamilyPointSize: FontFamily defaultPointSize * 1.5 / haloTargetTx scale. - stepX _ (font pointSize * 9) round4perMagnitudeOrder asFloat. - stepXDecimals _ stepX log rounded negated + 1. - stepY _ (font pointSize * 5) round4perMagnitudeOrder asFloat. - stepYDecimals _ stepY log rounded negated + 1. - strokeWidth _ 3/ haloTargetTx scale. - tickLength _ 5 / haloTargetTx scale. - - prevTx _ aCanvas currentTransformation. - aCanvas geometryTransformation: haloTargetTx. - - c _ `Color black alpha: 0.4`. - aCanvas line: x0@0 to: x1@0 width: strokeWidth color: c. - aCanvas line: 0@y0 to: 0@y1 width: strokeWidth color: c. - - (x0 truncateTo: stepX) to: x1 by: stepX do: [ :x | - aCanvas line: x @ tickLength negated to: x @ tickLength width: strokeWidth color: c. - aCanvas drawString: (x printStringFractionDigits: stepXDecimals) atWaistCenter: x @ (tickLength*4) negated font: font color: c ]. - aCanvas drawString: 'x' atCenterX: x1 - (tickLength*3) @ 0 font: font color: c. - - (y0 truncateTo: stepY) to: y1 by: stepY do: [ :y | - aCanvas line: tickLength negated @ y to: tickLength @ y width: strokeWidth color: c. - aCanvas drawString: (y printStringFractionDigits: stepYDecimals), ' ' atWaistRight: tickLength negated @ y font: font color: c ]. - aCanvas drawString: 'y' atWaist: tickLength @ (y1 - (tickLength*4)) font: font color: c. - - aCanvas geometryTransformation: prevTx.! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 9/15/2021 09:46:28' prior: 50576188! - doRot: evt with: rotHandle - "Update the rotation of my target if it is rotatable." - - | radians prevLocation deltaRadians | - evt hand obtainHalo: self. - radians _ (evt eventPosition - target referencePosition) theta + angleOffset. - radians _ radians detentBy: 0.05 atMultiplesOf: Float pi / 4 snap: false. - rotHandle color: (radians = 0.0 - ifTrue: [`Color lightBlue`] - ifFalse: [`Color blue`]). - rotHandle submorphsDo: [ :m | - m color: rotHandle color makeForegroundColor]. - prevLocation _ target location. - deltaRadians _ radians-prevLocation radians. - target yAxisPointsUp ifTrue: [ deltaRadians _ deltaRadians negated ]. - target location: (prevLocation composedWith: ( - AffineTransformation withRadians: deltaRadians around: target rotationCenter)). - rotHandle morphPositionInWorld: evt eventPosition - (rotHandle morphExtent // 2). - self redrawNeeded.! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 9/14/2021 19:00:41' prior: 50566033! - drawString: aString from: firstIndex to: lastIndex atWaist: aPoint font: font color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - - | dy | - dy _ currentTransformation doesMirror - ifFalse: [ font ascent * 0.4 ] - ifTrue: [ font ascent * -0.4 ]. - ^self drawString: aString from: firstIndex to: lastIndex - atBaseline: aPoint + (0 @ dy) - font: font color: aColor! ! - -MorphicTranslation removeSelector: #withYAxisNegated! - -!methodRemoval: MorphicTranslation #withYAxisNegated stamp: 'Install-4861-YaxisUpwardsSupport-JuanVuletich-2021Sep15-09h37m-jmv.001.cs.st 9/21/2021 12:54:39'! -withYAxisNegated - "Swap inneer point Y sign. - Make y increment upwards. - This makes the any matrix transform from standard mathematical coordinates - to standard display coordinates (in addition to the transform it was already doing) - - Answer the modified object. In this implementation this requires the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself, - as if the receiver is already a AffineTransformation." - - ^(AffineTransformation withTranslation: self translation) withYAxisNegated! - -AffineTransformation removeSelector: #withYAxisNegated! - -!methodRemoval: AffineTransformation #withYAxisNegated stamp: 'Install-4861-YaxisUpwardsSupport-JuanVuletich-2021Sep15-09h37m-jmv.001.cs.st 9/21/2021 12:54:39'! -withYAxisNegated - "Swap inneer point Y sign. - Make y increment upwards. - This makes the any matrix transform from standard mathematical coordinates - to standard display coordinates (in addition to the transform it was already doing) - - Answer the modified object. In this implementation it is self, but some classes of transformations, - more restricted ones (like MorphicTranslation) could require the creation of a new, more general instance. - Senders should always use the returned object, but not assume it is a new one: it could also be the receiver itself." - - self a12: self a12 negated. - self a22: self a22 negated. - ^self! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4861-YaxisUpwardsSupport-JuanVuletich-2021Sep15-09h37m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4861] on 15 September 2021 at 9:07:29 am'! -!WidgetMorph methodsFor: 'drawing' stamp: 'jmv 9/15/2021 08:48:04' prior: 50607608 overrides: 50607627! - imageForm: extentOrNil depth: depth - - | answerExtent answer auxCanvas | - self requiresVectorCanvas ifFalse: [ - answerExtent _ extent. - extentOrNil ifNotNil: [ answerExtent _ answerExtent min: extentOrNil * 4 ]. - "To avoid slower Smalltalk VG engine just because of window decorations" - auxCanvas _ BitBltCanvas depth: depth over: (self morphPosition floor extent: answerExtent ceiling). - auxCanvas fullDraw: self. - answer _ auxCanvas form divideByAlpha. - extentOrNil ifNotNil: [ answer _ answer magnifyTo: extentOrNil ]. - ^answer ]. - ^super imageForm: extentOrNil depth: depth.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4862-imageForm-use-BitBltCanvas-JuanVuletich-2021Sep15-09h07m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4862] on 16 September 2021 at 11:30:30 am'! -!DisplayScreen class methodsFor: 'snapshots' stamp: 'jmv 9/16/2021 11:22:16'! - setupDisplay: doGarbageCollection - " - DisplayScreen setupDisplay: true. - Display forceToScreen. - " - - self terminateScreenUpdater. - doGarbageCollection ifTrue: [ - Display setExtent: 0@0 depth: 0 bits: nil. - Smalltalk garbageCollect ]. - Display setExtent: self actualScreenSize depth: Display nativeDepth. - Display beDisplay. - self installScreenUpdater.! ! -!DisplayScreen methodsFor: 'other' stamp: 'jmv 9/16/2021 10:58:07' prior: 50607656! - forceToScreen: aRectangle - "Force the given rectangular section of the Display to be copied to the screen. The primitive call does nothing if the primitive is not implemented. Used when the deferUpdates flag in the virtual machine is on; see #deferUpdates:. - - If for whatever reason, actual OS or hardware Display is smaller than us, don't go outside its bounds. - This can sometimes happen, at least on MacOS, when frantically resizing the main OS Cuis window, - while Morphic is busy drawing many heavy morphs: it could be observed than apparently in #displayWorld, - after we were updated in #checkForNewScreenSize, MacOS window could be made smaller than aRectangle, - and a hard crash due to an invalid memory access happened in this primitive. - - Protecting against our bounds being smaller than aRectangle is done in the primitive. No need to do it here." - - | platformDisplayExtent | - platformDisplayExtent _ DisplayScreen actualScreenSize. - self primShowRectLeft: (aRectangle left max: 0) - right: (aRectangle right min: platformDisplayExtent x) - top: (aRectangle top max: 0) - bottom: (aRectangle bottom min: platformDisplayExtent y). -! ! -!DisplayScreen class methodsFor: 'snapshots' stamp: 'jmv 9/16/2021 11:22:01' prior: 50571610 overrides: 50335342! - startUp - " - DisplayScreen startUp. - Display forceToScreen. - " - self setupDisplay: false.! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 9/16/2021 11:25:32' prior: 50607588! - checkForNewScreenSize - "Check whether the screen size has changed and if so take appropriate actions" - - DisplayScreen isDisplayExtentOk ifFalse: [ - "Minimize the risk of going out of memory: - - First clear existing canvas, to free the memory it uses. - - Then, setup the display, with a GarbageCollection prior to allocating new display memory. - - Then set up new canvas." - self clearCanvas. - DisplayScreen setupDisplay: true. - self setMainCanvas. - self whenUIinSafeState: [ Cursor defaultCursor activateCursor ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4863-GarbabeCollectDuringDisplayResize-JuanVuletich-2021Sep16-11h28m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4863] on 16 September 2021 at 2:28:36 pm'! -!LargeNegativeInteger methodsFor: 'printing' stamp: 'jmv 9/16/2021 14:27:54' overrides: 16862727! - printOn: aStream base: b nDigits: n - "See comment at LargePositiveInteger." - - self shouldNotImplement.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4864-printOnbasenDigits-notAppropriateFor-LargeNegativeInteger-JuanVuletich-2021Sep16-14h27m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4863] on 16 September 2021 at 2:33:13 pm'! -!BlockClosure methodsFor: 'evaluating' stamp: 'jmv 9/16/2021 14:32:50'! - millisecondsToRun - "Answer the number of milliseconds taken to execute this block." - - ^ Time millisecondsToRun: self -! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4865-millisecondsToRun-JuanVuletich-2021Sep16-14h28m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4863] on 16 September 2021 at 2:36:00 pm'! -!BlockClosure methodsFor: 'evaluating' stamp: 'jmv 9/16/2021 14:34:45'! - millisecondsToRunWithoutGC - "Answer the number of milliseconds taken to execute this block without GC time." - - ^(Smalltalk vmParameterAt: 8) + - (Smalltalk vmParameterAt: 10) + - self millisecondsToRun - - (Smalltalk vmParameterAt: 8) - - (Smalltalk vmParameterAt: 10) -! ! -!BlockClosure methodsFor: 'evaluating' stamp: 'jmv 9/16/2021 14:34:26' prior: 16787872! - durationToRun - "Answer the duration taken to execute this block." - - ^ Duration milliSeconds: self millisecondsToRun.! ! -!TestCase methodsFor: 'assertions' stamp: 'jmv 9/16/2021 14:35:21' prior: 50458973! - should: aClosure notTakeMoreThan: aLimit - - | millisecondsLimit | - - millisecondsLimit := aLimit totalMilliseconds. - self assert: aClosure millisecondsToRun <= millisecondsLimit - description: [ 'Took more than ', millisecondsLimit printString, ' milliseconds' ].! ! - -BlockClosure removeSelector: #timeToRunWithoutGC! - -!methodRemoval: BlockClosure #timeToRunWithoutGC stamp: 'Install-4866-prefer-millisecondsToRun-over-timeToRun-JuanVuletich-2021Sep16-14h33m-jmv.001.cs.st 9/21/2021 12:54:39'! -timeToRunWithoutGC - "Answer the number of milliseconds taken to execute this block without GC time." - - ^(Smalltalk vmParameterAt: 8) + - (Smalltalk vmParameterAt: 10) + - self timeToRun - - (Smalltalk vmParameterAt: 8) - - (Smalltalk vmParameterAt: 10) -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4866-prefer-millisecondsToRun-over-timeToRun-JuanVuletich-2021Sep16-14h33m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4866] on 17 September 2021 at 10:22:21 am'! -!DisplayScreen class methodsFor: 'snapshots' stamp: 'jmv 9/17/2021 10:21:57' prior: 50608164! - setupDisplay: doGarbageCollection - " - DisplayScreen setupDisplay: true. - Display forceToScreen. - " - - self terminateScreenUpdater. - doGarbageCollection ifTrue: [ - Display setExtent: 0@0 depth: 0 bits: nil. - Smalltalk primitiveGarbageCollect. ]. - Display setExtent: self actualScreenSize depth: Display nativeDepth. - Display beDisplay. - self installScreenUpdater.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4867-just-primitiveGarbageCollect-onDisplaySetup-JuanVuletich-2021Sep17-10h21m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4866] on 17 September 2021 at 10:58:32 am'! -!PasteUpMorph methodsFor: 'misc' stamp: 'jmv 9/17/2021 10:58:19' prior: 50572357! - buildMagnifiedBackgroundImage - | image | - backgroundImageData - ifNil: [ backgroundImage _ nil ] - ifNotNil: [ - [ - backgroundImage _ nil. - Smalltalk primitiveGarbageCollect. - image _ Form fromBinaryStream: backgroundImageData readStream. - backgroundImage _ image magnifyTo: extent. - backgroundImage _ backgroundImage orderedDither32To16 asColorFormOfDepth: 8. - image _ nil. - Smalltalk primitiveGarbageCollect. - backgroundImage bits pin. - ] on: Error do: [backgroundImage := nil]. "Can happen if JPEG plugin not built" - self redrawNeeded - ]! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -self runningWorld color: (Color fromHexString: '#214A8C') lighter.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4868-disableDesktopBackground-JuanVuletich-2021Sep17-10h39m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4868] on 20 September 2021 at 3:34:52 pm'! -!Morph methodsFor: 'change reporting' stamp: 'jmv 9/20/2021 12:32:14' prior: 50567651! - invalidateDisplayRect: damageRect for: aMorph - " - If we clip submorphs, then we clip damageRect. - - aMorph is the morph that changed and therefore should be redrawn. In some cases, damage reporting is done by no longer occupying some area, and requesting whatever appropriate morph to be drawn there. In such cases, aMorph should be nil. See senders." - - | clippedRect b | - self visible ifFalse: [ ^self]. - - clippedRect _ damageRect. - aMorph == self ifFalse: [ - self clipsSubmorphsReally ifTrue: [ - b _ self displayBounds. - b ifNil: [ ^self ]. - clippedRect _ damageRect intersect: b ]]. - owner ifNotNil: [ - owner invalidateDisplayRect: clippedRect for: aMorph ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4869-Transcript-artifactsInVG-fix-JuanVuletich-2021Sep20-15h34m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4869] on 21 September 2021 at 9:53:48 am'! -!Morph methodsFor: 'geometry services' stamp: 'jmv 9/21/2021 09:31:32'! -fullOwnsOrCoversPixel: worldPoint - "Answer true if worldPoint is in some submorph, even if not inside our shape. - See comment at #ownsOrCoversPixel: for important notes on behavior." - - (self ownsOrCoversPixel: worldPoint) ifTrue: [ ^true ]. - self submorphsDo: [ :m | - (m fullOwnsOrCoversPixel: worldPoint) ifTrue: [ ^true ]]. - ^ false.! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 9/21/2021 09:50:59'! - isCloserThan: maxDistance toPixel: worldPoint - "Answer true if our closest point to aPoint is less than aNumber pixels away. - In target surface (i.e. Display) coordinates. - Uses precise testing of the morph contour if available: - Morphs not in the WidgetMorph hierarchy should answer #true to wantsContour. - Note: Considers only the external border. Any inner pixel is considered 'inside' regardless of us being transparent there. - Note: Cheaper than #coversAnyPixelCloserThan:to: . Doesn't use #bitMask. Doesn't require maintenance." - - | center contourTop contourBottom | - privateDisplayBounds ifNil: [ - ^false ]. - center _ privateDisplayBounds center. - "Quick checks: If not even within aNumber distance to display bounds, fail" - (center y - worldPoint y) abs < (privateDisplayBounds height // 2 + maxDistance) ifFalse: [ - ^false ]. - (center x - worldPoint x) abs < (privateDisplayBounds width // 2 + maxDistance) ifFalse: [ - ^false ]. - "Precise check with contour, if available" - (self valueOfProperty: #contour) ifNotNil: [ :contour | | y0 y1 x0 x1 | - contourTop _ self valueOfProperty: #contourY0. - contourBottom _ self valueOfProperty: #contourY1. - "Contour rows to consider are those within requested distance." - y0 _ worldPoint y - maxDistance max: contourTop. - y1 _ worldPoint y + maxDistance min: contourBottom. - y0 to: y1 do: [ :y | - x0 _ (contour at: (y - contourTop) * 2 + 1) - maxDistance. - x1 _ (contour at: (y - contourTop) * 2 + 2) + maxDistance. - "If a vertical line of 2*aNumber height centered on aPoint is inside the contour, quick exit" - (worldPoint x between: x0 and: x1) ifTrue: [ ^true ]. - "Check if aPoint is close enough to contour" - (x0@y - worldPoint) r < maxDistance ifTrue: [ ^true ]. - (x1@y - worldPoint) r < maxDistance ifTrue: [ ^true ]]. - "Not inside, not close enough to contour" - ^ false ]. - "If contour is not available, and aPoint is close enough to displayBounds, answer true, as it is the best we can know." - ^ true! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 9/21/2021 09:33:07'! - ownsOrCoversPixel: worldPoint - "Answer true if we own the pixel, i.e. we are the last morph drawn at worldPoint. - Some implementations (KernelMorph and WidgetMorph) may also answer true if we cover but don't own the pixel, - meaning that some other morph was drawn later, covering us. - Therefore, senders need to be aware that the answer is meaningful only when it is known that no other morph covers us. - Note: This implementation is only used for VectorGraphics based morphs (i.e. morphs that answer true to #requiresVectorCanvas). - (See other implementors) - Note: Also see #ownsPixel: and #coversPixel:" - - ^ self ownsPixel: worldPoint.! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 9/21/2021 09:12:00'! - ownsPixel: worldPoint - "Answer true if we own the pixel, i.e. we are the last morph drawn at worldPoint. - Requires VectorGraphics. - Only valid for morphs that answer true to #requiresVectorCanvas" - - self topmostWorld ifNotNil: [ :w | - w canvas ifNotNil: [ :canvas | - ^ (canvas morphIdAt: worldPoint) = self morphId ]]. - ^ false.! ! -!KernelMorph methodsFor: 'geometry services' stamp: 'jmv 9/20/2021 11:25:55'! - coversLocalPoint: aLocalPoint - "Answer true as long as aLocalPoint is inside our shape even if: - - a submorph (above us) also covers it - - a sibling that is above us or one of their submorphs also covers it." - - "If not visible, won't cover any point at all." - self visible ifFalse: [ ^false ]. - - "We know our local bounds, and completely fill them." - ^ self morphLocalBounds containsPoint: aLocalPoint! ! -!KernelMorph methodsFor: 'geometry services' stamp: 'jmv 9/21/2021 09:36:45'! - coversPixel: worldPoint - "Answer true as long as worldPoint is inside our shape even if: - - a submorph (above us) also covers it - - a sibling that is above us or one of their submorphs also covers it. - This implementation is cheap, we are a rectangular shape." - - ^ self coversLocalPoint: - (self internalizeFromWorld: worldPoint)! ! -!KernelMorph methodsFor: 'geometry services' stamp: 'jmv 9/21/2021 09:31:36' overrides: 50608429! - fullOwnsOrCoversPixel: worldPoint - "Answer true if worldPoint is in some submorph, even if not inside our shape. - See comment at #ownsOrCoversPixel: for important notes on behavior." - - (self ownsOrCoversPixel: worldPoint) ifTrue: [ ^ true ]. - self submorphsMightProtrude ifTrue: [ - self submorphsDo: [ :m | - (m fullOwnsOrCoversPixel: worldPoint) ifTrue: [ ^ true ]]]. - ^ false.! ! -!KernelMorph methodsFor: 'geometry services' stamp: 'jmv 9/21/2021 09:35:38' overrides: 50608507! - ownsOrCoversPixel: worldPoint - "Answer true if we own the pixel, i.e. we are the last morph drawn at worldPoint. - This implementation also answer true if we cover but don't own the pixel, - meaning that some other morph was drawn later, covering us. - Therefore, senders need to be aware that the answer is meaningful only when it is known that no other morph covers us. - Note: This implementation is only used for morphs with a cheap #coversPixel:. - (See other implementors) - Note: Also see #ownsPixel: and #coversPixel:" - - ^ self visible and: [self coversPixel: worldPoint].! ! -!WidgetMorph methodsFor: 'geometry services' stamp: 'jmv 9/20/2021 11:26:19'! - coversLocalPoint: aLocalPoint - "Answer true as long as aLocalPoint is inside our shape even if: - - a submorph (above us) also covers it - - a sibling that is above us or one of their submorphs also covers it." - - "If not visible, won't cover any point at all." - self visible ifFalse: [ ^false ]. - - "We know our local bounds, and completely fill them." - ^ self morphLocalBounds containsPoint: aLocalPoint! ! -!WidgetMorph methodsFor: 'geometry services' stamp: 'jmv 9/21/2021 09:36:52'! - coversPixel: worldPoint - "Answer true as long as worldPoint is inside our shape even if: - - a submorph (above us) also covers it - - a sibling that is above us or one of their submorphs also covers it. - This implementation is cheap, we are a rectangular shape." - - ^ self coversLocalPoint: - (self internalizeFromWorld: worldPoint)! ! -!WidgetMorph methodsFor: 'geometry services' stamp: 'jmv 9/21/2021 09:31:41' overrides: 50608429! - fullOwnsOrCoversPixel: worldPoint - "Answer true if worldPoint is in some submorph, even if not inside our shape. - See comment at #ownsOrCoversPixel: for important notes on behavior." - - (self ownsOrCoversPixel: worldPoint) ifTrue: [ ^ true ]. - self submorphsMightProtrude ifTrue: [ - self submorphsDo: [ :m | - (m fullOwnsOrCoversPixel: worldPoint) ifTrue: [ ^ true ]]]. - ^ false.! ! -!WidgetMorph methodsFor: 'geometry services' stamp: 'jmv 9/21/2021 09:35:48' overrides: 50608507! - ownsOrCoversPixel: worldPoint - "Answer true if we own the pixel, i.e. we are the last morph drawn at worldPoint. - This implementation also answer true if we cover but don't own the pixel, - meaning that some other morph was drawn later, covering us. - Therefore, senders need to be aware that the answer is meaningful only when it is known that no other morph covers us. - Note: This implementation is only used for morphs with a cheap #coversPixel:. - (See other implementors) - Note: Also see #ownsPixel: and #coversPixel:" - - ^ self visible and: [self coversPixel: worldPoint].! ! -!WindowEdgeAdjustingMorph methodsFor: 'geometry services' stamp: 'jmv 9/20/2021 11:30:16' overrides: 50608610! - coversLocalPoint: aLocalPoint - "We don't completely cover our bounds. Account for that." - - | sensitiveBorder | - ( self morphLocalBounds containsPoint: aLocalPoint) ifFalse: [ ^false ]. - sensitiveBorder _ owner borderWidth. - selector caseOf: { - [ #windowTopLeft: ] -> [ ^ aLocalPoint x < sensitiveBorder or: [ aLocalPoint y < sensitiveBorder ]]. - [ #windowTopRight: ] -> [ ^ extent x - aLocalPoint x <= sensitiveBorder or: [ aLocalPoint y < sensitiveBorder ]]. - [ #windowBottomLeft: ] -> [ ^ aLocalPoint x < sensitiveBorder or: [ extent y- aLocalPoint y <= sensitiveBorder ]]. - [ #windowBottomRight: ] -> [ ^ extent x - aLocalPoint x <= sensitiveBorder or: [ extent y - aLocalPoint y <= sensitiveBorder ]]. - } - otherwise: [ - "all the morph is sensitive for horizontal and vertical (i.e. non corner) instances." - ^true ]! ! -!Morph methodsFor: 'events-processing' stamp: 'jmv 9/20/2021 12:13:48' prior: 50562746! - processMouseOver: aMouseEvent localPosition: localEventPosition - "System level event handling." - self hasMouseFocus ifTrue: [ - "Got this directly through #handleFocusEvent: so check explicitly" - ((self rejectsEvent: aMouseEvent) not and: [self fullOwnsOrCoversPixel: aMouseEvent eventPosition]) ifFalse: [ - ^self ]]. - aMouseEvent hand noticeMouseOver: self event: aMouseEvent. - "Open question: should any unhandled mouse move events be filtered out? (i.e. should mouseHover:localPosition: be called when a mouse button is pressed but the morph doesn't have mouse button handlers? Essentially, what are the limits of what is considered 'hovering'?" - (self handlesMouseHover and: [aMouseEvent wasHandled not]) ifTrue: [ - self - mouseHover: aMouseEvent - localPosition: localEventPosition ].! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 9/21/2021 09:53:20' prior: 50593407! - contourIntersects: aContourArray top: aContourTop bottom: aContourBottom - "Check if contours intersect. - If contour is not available, use displayBounds. - Not to be called directly. Pefer a higher level service. See senders." - - | contour contourTop contourBottom x0Own x1Own x0Arg x1Arg | - contour _ self valueOfProperty: #contour. - contourTop _ (self valueOfProperty: #contourY0) ifNil: [aContourTop]. - contourBottom _ (self valueOfProperty: #contourY1) ifNil: [aContourBottom]. - - (contourTop max: aContourTop) to: (contourBottom min: aContourBottom) do: [ :y | - x0Own _ contour ifNil: [privateDisplayBounds left] ifNotNil: [ contour at: (y - contourTop) * 2 + 1 ]. - x1Own _ contour ifNil: [privateDisplayBounds right-1] ifNotNil: [ contour at: (y - contourTop) * 2 + 2 ]. - x0Arg _ aContourArray at: (y - aContourTop) * 2 + 1. - x1Arg _ aContourArray at: (y - aContourTop) * 2 + 2. - (x0Own <= x1Arg and: [ x0Arg <= x1Own ]) - ifTrue: [ ^true ]]. - - ^false! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 9/21/2021 09:51:06'! - coversAnyPixelCloserThan: maxDistance to: worldPoint - "Answer true if our closest point to worldPoint is less than aNumber pixels away. - In target surface (i.e. Display) coordinates. - See #bitMask. - Remember to do - self removeProperty: #bitMask. - when appropriate!! (i.e. when we change in such a way to make the bitMask invalid). - - Note: Requires VectorGraphics. Meant to be used only when needed. - Note: Prefer #isCloserThan:toPixel:, that doesn't use #bitMask, and doesn't require maintenance." - - | center maxDistanceSquared | - privateDisplayBounds ifNil: [ - ^false ]. - center _ privateDisplayBounds center. - "Quick checks: If not even within aNumber distance to display bounds, fail" - (center y - worldPoint y) abs < (privateDisplayBounds height // 2 + maxDistance) ifFalse: [ - ^false ]. - (center x - worldPoint x) abs < (privateDisplayBounds width // 2 + maxDistance) ifFalse: [ - ^false ]. - "Precise check with bitMask" - (self coversPixel: worldPoint) ifTrue: [ ^true ]. - maxDistanceSquared _ maxDistance squared. - maxDistance negated to: maxDistance do: [ :dy | - maxDistance negated to: maxDistance do: [ :dx | - dx squared + dy squared <= maxDistanceSquared ifTrue: [ - (self coversPixel: worldPoint + (dx@dy)) ifTrue: [ ^true ]]]]. - ^false.! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 9/21/2021 09:38:06'! - coversPixel: worldPoint - "Answer true if pixel worldPoint is covered by us, even if we are not visible a it because of some - other morph above us also covers it. - See #bitMask. - Remember to do - self removeProperty: #bitMask. - when appropriate!! (i.e. when we change in such a way to make the bitMask invalid). - - Note: Subclasses such as KernelMorph and WidgetMorph redefine this method with an optimized - implementation that doesn't require computing and invalidating the #bitMask. Senders in the base image - and framework actually only use this optimized implementation. That's why general morphs don't care about - invalidting #bitMask. - - Note: If your morph #requiresVectorCanvas, and depends on this general implementation, remember to - `removeProperty: #bitMask` whenever it becomes invalid due to changes in your morphs. You may consider - using #ownsPixel: if appropriate, that doesn't require any maintenance and is cheaper (in cpu and memory). - - Note: This implementation requires VectorGraphics." - - self visible ifTrue: [ - ^(self bitMask pixelValueAt: worldPoint - self displayFullBounds topLeft) = 1 ]. - ^ false! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 9/20/2021 12:13:54' prior: 50567189! - transferHalo: event from: formerHaloOwner - "Progressively transfer the halo to the next likely recipient" - - formerHaloOwner == self - ifFalse: [ - self addHalo: event. - ^self ]. - - event shiftPressed ifTrue: [ - "Pass it outwards" - owner ifNotNil: [ - owner transferHalo: event from: formerHaloOwner. - ^self ]. - "We're at the top level; just keep it on ourselves" - ^self ]. - - self submorphsDo: [ :m | - (m wantsHalo and: [ m fullOwnsOrCoversPixel: event eventPosition ]) - ifTrue: [ - m transferHalo: event from: formerHaloOwner. - ^self ]]. - "We're at the bottom most level; just keep halo on ourselves"! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 9/20/2021 11:32:25' prior: 50562556! - doRecolor: event with: aHandle - "The mouse went down in the 'recolor' halo handle. Allow the user to change the color of the innerTarget" - - event hand obtainHalo: self. - (aHandle coversPixel: event eventPosition) - ifFalse: [ "only do it if mouse still in handle on mouse up" - self delete. - target addHalo: event] - ifTrue: [ - target changeColor]! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 9/20/2021 11:32:30' prior: 50567312! - maybeCollapse: event with: aHandle - "Ask hand to collapse my target if mouse comes up in it." - - event hand obtainHalo: self. - (aHandle coversPixel: event eventPosition) - ifTrue: [ - target collapse ]. - self delete.! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 9/20/2021 11:32:34' prior: 50562581! - maybeDismiss: event with: aHandle - "Ask hand to dismiss my target if mouse comes up in it." - - event hand obtainHalo: self. - (aHandle coversPixel: event eventPosition) - ifFalse: [ - self delete. - target addHalo: event] - ifTrue: [ - target resistsRemoval ifTrue: [ - (PopUpMenu - confirm: 'Really throw this away' - trueChoice: 'Yes' - falseChoice: 'Um, no, let me reconsider') ifFalse: [^ self]]. - - self delete. - target dismissViaHalo]! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 9/20/2021 11:32:38' prior: 50562599! - setDismissColor: event with: aHandle - "Called on mouseStillDown in the dismiss handle; set the color appropriately." - - | colorToUse | - event hand obtainHalo: self. - colorToUse _ (aHandle coversPixel: event eventPosition) - ifFalse: [ `Color red muchLighter` ] - ifTrue: [ `Color lightGray` ]. - aHandle color: colorToUse! ! -!MenuItemMorph methodsFor: 'events' stamp: 'jmv 9/20/2021 11:32:44' prior: 50562643! - activateOwnerMenu: evt - "Activate our owner menu; e.g., pass control to it" - owner ifNil: [ ^false ]. "not applicable" - (owner coversPixel: evt eventPosition) - ifFalse: [ ^false ]. - owner activate: evt. - ^true! ! -!MenuItemMorph methodsFor: 'events' stamp: 'jmv 9/20/2021 11:32:47' prior: 50565706! - activateSubmenu: event - "Activate our submenu; e.g., pass control to it" - - subMenu ifNil: [ ^false ]. "not applicable" - subMenu isInWorld ifFalse: [ ^false ]. - (subMenu coversPixel: event eventPosition) ifFalse: [^false]. - subMenu activate: event. - ^true! ! -!PluggableButtonMorph methodsFor: 'events' stamp: 'jmv 9/20/2021 11:32:53' prior: 50562664 overrides: 16874556! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - - isPressed _ false. - mouseIsOver _ false. - (actWhen == #buttonUp and: [ - self coversPixel: aMouseButtonEvent eventPosition ]) - ifTrue: [ self performAction ]. - self redrawNeeded! ! -!MenuMorph methodsFor: 'events' stamp: 'jmv 9/20/2021 11:36:05' prior: 50574758 overrides: 16874541! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - "Handle a mouse down event." - (stayUp or: [ self coversPixel: aMouseButtonEvent eventPosition ]) - ifFalse: [ - self deleteIfPopUp: aMouseButtonEvent. - self activeHand - newKeyboardFocus: prevKbdFocus; - newMouseFocus: prevMouseFocus. - ^ self ]. "click outside" - - "Grab the menu and drag it to some other place - This is reimplemented here because we handle the event, and if the following lines are commented, a menu can't be grabbed with the hand. This is not nice and shouldn't be needed" - self isSticky ifTrue: [ ^self ]. - aMouseButtonEvent hand grabMorph: self.! ! -!MenuMorph methodsFor: 'events' stamp: 'jmv 9/20/2021 11:36:32' prior: 50574782 overrides: 16874556! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - "Handle a mouse up event. - Note: This might be sent from a modal shell." - (self coversPixel: aMouseButtonEvent eventPosition) ifFalse:[ - "Mouse up outside. Release eventual focus and delete if pop up." - aMouseButtonEvent hand ifNotNil: [ :h | h releaseMouseFocus: self ]. - self deleteIfPopUp: aMouseButtonEvent. - self activeHand - newKeyboardFocus: prevKbdFocus; - newMouseFocus: prevMouseFocus. - ^ self]. - stayUp ifFalse: [ - "Still in pop-up transition; keep focus" - aMouseButtonEvent hand newMouseFocus: self ].! ! -!AutoCompleterMorph methodsFor: 'events' stamp: 'jmv 9/20/2021 11:32:58' prior: 50562676 overrides: 16874556! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - - (self coversPixel: aMouseButtonEvent eventPosition) - ifTrue: [ - ((self upButtonPosition extent: ScrollBar scrollbarThickness) containsPoint: localEventPosition) - ifTrue: [ ^self stillActive; goUp ]. - ((self downButtonPosition extent: ScrollBar scrollbarThickness) containsPoint: localEventPosition) - ifTrue: [ ^self stillActive; goDown ]. - self selected: (localEventPosition y // self itemHeight) + self firstVisible. - completer insertSelected ] - ifFalse: [ self delete. completer menuClosed ]! ! -!MorphicEvent methodsFor: 'dispatching' stamp: 'jmv 9/20/2021 12:14:09' prior: 50563947! - dispatchWith: aMorph - "Dispatch me. The event will be passed to the front-most visible submorph that contains the position wrt. to the event." - | handledByInner | - - "Try to get out quickly" - (aMorph fullOwnsOrCoversPixel: self eventPosition) - ifFalse: [ ^#rejected ]. - - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - (eachChild dispatchEvent: self) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - - "Check for being inside the receiver" - (handledByInner or: [ (aMorph rejectsEvent: self) not and: [aMorph fullOwnsOrCoversPixel: self eventPosition] ]) - ifTrue: [ ^ self sendEventTo: aMorph ]. - - ^ #rejected! ! -!DropEvent methodsFor: 'dispatching' stamp: 'jmv 9/20/2021 12:14:16' prior: 50563975 overrides: 50609028! - dispatchWith: aMorph - "Drop is done on the innermost target that accepts it." - | dropped | - - "Try to get out quickly" - (aMorph fullOwnsOrCoversPixel: position) - ifFalse: [ ^#rejected ]. - - "Go looking if any of our submorphs wants it" - aMorph submorphsDo: [ :eachChild | - (eachChild dispatchEvent: self) == #rejected ifFalse: [ - ^self ]]. - - (aMorph allowsMorphDrop and: [ (aMorph rejectsEvent: self) not and: [aMorph fullOwnsOrCoversPixel: position] ]) - ifTrue: [ - "Do a symmetric check if both morphs like each other" - dropped _ self contents. - ((aMorph wantsDroppedMorph: dropped event: self) "I want her" - and: [dropped wantsToBeDroppedInto: aMorph]) "she wants me" - ifTrue: [ - ^ self sendEventTo: aMorph ]]. - ^#rejected! ! -!DropFilesEvent methodsFor: 'dispatching' stamp: 'jmv 9/20/2021 12:14:23' prior: 50564002 overrides: 50609028! - dispatchWith: aMorph - "Drop is done on the innermost target that accepts it." - - "Try to get out quickly" - (aMorph fullOwnsOrCoversPixel: position) ifFalse: [ ^#rejected ]. - - "Go looking if any of our submorphs wants it" - aMorph submorphsDo: [ :eachChild | - (eachChild dispatchEvent: self) == #rejected ifFalse: [ ^self ]]. - - (aMorph allowsFilesDrop and: [ (aMorph rejectsEvent: self) not and: [aMorph fullOwnsOrCoversPixel: position] ]) - ifTrue: [^ self sendEventTo: aMorph ]. - - ^#rejected! ! -!KeyboardEvent methodsFor: 'actions' stamp: 'jmv 9/20/2021 11:33:02' prior: 50562907! - closeCurrentWindowOf: aMorph - - aMorph owningWindow ifNotNil: [ :w | - (w coversPixel: position) - ifTrue: [ w delete ] ].! ! -!MouseButtonEvent methodsFor: 'dispatching' stamp: 'jmv 9/20/2021 12:14:44' prior: 50564021 overrides: 50609028! - dispatchWith: aMorph - "Find the appropriate receiver for the event and let it handle it. Default rules: - * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. - * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. - * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. - * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. - " - | aMorphHandlesIt grabAMorph handledByInner | - "Only for MouseDown" - self isMouseDown ifFalse: [ - ^super dispatchWith: aMorph ]. - - "Try to get out quickly" - (aMorph fullOwnsOrCoversPixel: position) - ifFalse: [ ^#rejected ]. - - "Install the prospective handler for the receiver" - aMorphHandlesIt _ false. - grabAMorph _ false. - self mouseButton3Pressed - ifTrue: [ - (eventHandler isNil or: [ eventHandler isWorldMorph or: [ - self shiftPressed or: [ aMorph is: #HaloMorph ]]]) - ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]] - ifFalse: [ - (aMorph handlesMouseDown: self) ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]. - "If button 1, and both aMorph and the owner allows grabbing with the hand (to initiate drag & drop), so be it." - self mouseButton1Pressed ifTrue: [ - aMorph owner ifNotNil: [ :o | - (o allowsSubmorphDrag and: [ aMorph isSticky not ]) ifTrue: [ - grabAMorph _ true ]]]]. - - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - (eachChild dispatchEvent: self) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - - (handledByInner or: [ (aMorph rejectsEvent: self) not and: [aMorph fullOwnsOrCoversPixel: position] ]) ifTrue: [ - "aMorph is in the top-most unlocked, visible morph in the chain." - aMorphHandlesIt - ifTrue: [ ^self sendEventTo: aMorph ] - ifFalse: [ - (grabAMorph and: [ handledByInner not ]) ifTrue: [ - self hand - waitForClicksOrDrag: aMorph event: self - dragSel: (Preferences clickGrabsMorphs ifFalse: [#dragEvent:localPosition:]) - clkSel: (Preferences clickGrabsMorphs ifTrue: [#dragEvent:localPosition:]). - "false ifTrue: [ self hand grabMorph: aMorph ]." - Preferences clickGrabsMorphs ifFalse: [aMorph activateWindow]. - self wasHandled: true. - ^self ]]]. - - handledByInner ifTrue: [ ^self ]. - "Mouse was not on aMorph nor any of its children" - ^ #rejected! ! -!MouseScrollEvent methodsFor: 'dispatching' stamp: 'jmv 9/20/2021 12:14:35' prior: 50598496 overrides: 50609028! - dispatchWith: aMorph - "Find the appropriate receiver for the event and let it handle it. Default rules: - * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. - * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. - * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. - * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. - " - "Try to get out quickly" - | aMorphHandlesIt handledByInner | - "FIXME - this works in all tested cases but one: when the window directly under the mouse doesn't have keyboard focus (i.e. a Transcript window)" - aMorph fullOwnsOrCoversPixel: position :: ifFalse: [ ^ #rejected ]. - "Install the prospective handler for the receiver" - aMorphHandlesIt _ false. - (aMorph handlesMouseScroll: self) ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]. - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - (eachChild dispatchEvent: self) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - (handledByInner or: [ - (aMorph rejectsEvent: self) not and: [aMorph fullOwnsOrCoversPixel: position]]) ifTrue: [ - "aMorph is in the top-most unlocked, visible morph in the chain." - aMorphHandlesIt ifTrue: [ ^ self sendEventTo: aMorph ]]. - handledByInner ifTrue: [ ^ self ]. - "Mouse was not on aMorph nor any of its children" - ^ #rejected.! ! - -BitBltCanvas removeSelector: #morph:isAtPoint:! - -!methodRemoval: BitBltCanvas #morph:isAtPoint: stamp: 'Install-4870-Morphic-Geometry-Tweaks-JuanVuletich-2021Sep21-08h34m-jmv.002.cs.st 9/21/2021 12:54:39'! -morph: aMorph isAtPoint: aPoint - - aMorph basicDisplayBounds ifNotNil: [ :r | - (r containsPoint: aPoint) ifFalse: [ - ^false ]]. - "Give morphs with a non-rectangular shape (corner WindowEdgeAdjustingMorphs) - a chance to have a say." - ^ aMorph morphContainsPoint: - (aMorph internalizeFromWorld: aPoint)! - -WindowEdgeAdjustingMorph removeSelector: #morphContainsPoint:! - -!methodRemoval: WindowEdgeAdjustingMorph #morphContainsPoint: stamp: 'Install-4870-Morphic-Geometry-Tweaks-JuanVuletich-2021Sep21-08h34m-jmv.002.cs.st 9/21/2021 12:54:39'! -morphContainsPoint: aLocalPoint - | sensitiveBorder | - ( self morphLocalBounds containsPoint: aLocalPoint) ifFalse: [ ^false ]. - sensitiveBorder _ owner borderWidth. - selector caseOf: { - [ #windowTopLeft: ] -> [ ^ aLocalPoint x < sensitiveBorder or: [ aLocalPoint y < sensitiveBorder ]]. - [ #windowTopRight: ] -> [ ^ extent x - aLocalPoint x <= sensitiveBorder or: [ aLocalPoint y < sensitiveBorder ]]. - [ #windowBottomLeft: ] -> [ ^ aLocalPoint x < sensitiveBorder or: [ extent y- aLocalPoint y <= sensitiveBorder ]]. - [ #windowBottomRight: ] -> [ ^ extent x - aLocalPoint x <= sensitiveBorder or: [ extent y - aLocalPoint y <= sensitiveBorder ]]. - } - otherwise: [ - "all the morph is sensitive for horizontal and vertical (i.e. non corner) instances." - ^true ]! - -WidgetMorph removeSelector: #morphContainsPoint:! - -!methodRemoval: WidgetMorph #morphContainsPoint: stamp: 'Install-4870-Morphic-Geometry-Tweaks-JuanVuletich-2021Sep21-08h34m-jmv.002.cs.st 9/21/2021 12:54:39'! -morphContainsPoint: aLocalPoint - "Answer true even if aLocalPoint is in a submorph in front of us, as long as it is inside our shape." - - "If not visible, won't contain any point at all." - self visible ifFalse: [ ^false ]. - - "We know our local bounds, and completely fill them." - ^ self morphLocalBounds containsPoint: aLocalPoint! - -HaloMorph removeSelector: #containsGlobalPoint:! - -!methodRemoval: HaloMorph #containsGlobalPoint: stamp: 'Install-4870-Morphic-Geometry-Tweaks-JuanVuletich-2021Sep21-08h34m-jmv.002.cs.st 9/21/2021 12:54:39'! -containsGlobalPoint: worldPoint - - self visible ifTrue: [ - self topmostWorld ifNotNil: [ :w | - ^self morphLocalBounds containsPoint: - (self internalizeFromWorld: worldPoint) ]]. - ^ false! - -KernelMorph removeSelector: #morphContainsPoint:! - -!methodRemoval: KernelMorph #morphContainsPoint: stamp: 'Install-4870-Morphic-Geometry-Tweaks-JuanVuletich-2021Sep21-08h34m-jmv.002.cs.st 9/21/2021 12:54:39'! -morphContainsPoint: aLocalPoint - "Answer true even if aLocalPoint is in a submorph in front of us, as long as it is inside our shape." - - "If not visible, won't contain any point at all." - self visible ifFalse: [ ^false ]. - - "We know our local bounds, and completely fill them." - ^ self morphLocalBounds containsPoint: aLocalPoint! - -Morph removeSelector: #containsGlobalPoint:! - -!methodRemoval: Morph #containsGlobalPoint: stamp: 'Install-4870-Morphic-Geometry-Tweaks-JuanVuletich-2021Sep21-08h34m-jmv.002.cs.st 9/21/2021 12:54:39'! -containsGlobalPoint: worldPoint - "Answer true if pixel worldPoint is covered by us, and we are visible a it. - No other morph above us also covers it." - - self visible ifTrue: [ - self topmostWorld ifNotNil: [ :w | - w canvas ifNotNil: [ :canvas | - ^ canvas morph: self isAtPoint: worldPoint ]]]. - ^ false! - -Morph removeSelector: #isCloserThan:to:! - -Morph removeSelector: #fullContainsGlobalPoint:! - -!methodRemoval: Morph #fullContainsGlobalPoint: stamp: 'Install-4870-Morphic-Geometry-Tweaks-JuanVuletich-2021Sep21-08h34m-jmv.002.cs.st 9/21/2021 12:54:39'! -fullContainsGlobalPoint: worldPoint - "Answer true if worldPoint is in some submorph, even if not inside our shape." - - self visible ifTrue: [ - self topmostWorld ifNotNil: [ :w | - (self containsGlobalPoint: worldPoint) ifTrue: [ ^ true ]. - self submorphsDo: [ :m | - (m fullContainsGlobalPoint: worldPoint) ifTrue: [ ^ true ]]]]. - ^ false! - -Morph removeSelector: #isCloserThan:toPoint:! - -!methodRemoval: Morph #isCloserThan:toPoint: stamp: 'Install-4870-Morphic-Geometry-Tweaks-JuanVuletich-2021Sep21-08h34m-jmv.002.cs.st 9/21/2021 12:54:39'! -isCloserThan: aNumber toPoint: aPoint - "Answer true if our closest point to aPoint is less than aNumber pixels away. - In target surface (i.e. Display) coordinates. - Uses precise testing of the morph contour if available. See #knowsContour." - - | center contourTop contourBottom | - privateDisplayBounds ifNil: [ - ^false ]. - center _ privateDisplayBounds center. - "Quick checks: If not even within aNumber distance to display bounds, fail" - (center y - aPoint y) abs < (privateDisplayBounds height // 2 + aNumber) ifFalse: [ - ^false ]. - (center x - aPoint x) abs < (privateDisplayBounds width // 2 + aNumber) ifFalse: [ - ^false ]. - "Precise check with contour, if available" - (self valueOfProperty: #contour) ifNotNil: [ :contour | | y0 y1 x0 x1 | - contourTop _ self valueOfProperty: #contourY0. - contourBottom _ self valueOfProperty: #contourY1. - "Contour rows to consider are those within requested distance." - y0 _ aPoint y - aNumber max: contourTop. - y1 _ aPoint y + aNumber min: contourBottom. - y0 to: y1 do: [ :y | - x0 _ (contour at: (y - contourTop) * 2 + 1) - aNumber. - x1 _ (contour at: (y - contourTop) * 2 + 2) + aNumber. - "If a vertical line of 2*aNumber height centered on aPoint is inside the contour, quick exit" - (aPoint x between: x0 and: x1) ifTrue: [ ^true ]. - "Check if aPoint is close enough to contour" - (x0@y - aPoint) r < aNumber ifTrue: [ ^true ]. - (x1@y - aPoint) r < aNumber ifTrue: [ ^true ]]. - "Not inside, not close enough to contour" - ^ false ]. - "If contour is not available, and aPoint is close enough to displayBounds, answer true, as it is the best we can know." - ^ true! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4870-Morphic-Geometry-Tweaks-JuanVuletich-2021Sep21-08h34m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4870] on 21 September 2021 at 10:47:45 am'! -!KernelMorph methodsFor: 'drawing' stamp: 'jmv 9/21/2021 10:47:14' overrides: 50607627! - imageForm: extentOrNil depth: depth - - | answerExtent answer auxCanvas | - self requiresVectorCanvas ifFalse: [ - answerExtent _ extent. - extentOrNil ifNotNil: [ answerExtent _ answerExtent min: extentOrNil * 4 ]. - auxCanvas _ BitBltCanvas depth: depth over: (self morphPosition floor extent: answerExtent ceiling). - auxCanvas fullDraw: self. - answer _ auxCanvas form divideByAlpha. - extentOrNil ifNotNil: [ answer _ answer magnifyTo: extentOrNil ]. - ^answer ]. - ^super imageForm: extentOrNil depth: depth.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4871-imageFormdepth-KernelMorph-JuanVuletich-2021Sep21-10h46m-jmv.001.cs.st----! - -----QUIT----(21 September 2021 12:54:43) Cuis5.0-4871-v3.image priorSource: 8745619! - -----STARTUP---- (24 September 2021 10:40:14) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4871-v3.image! - - -'From Cuis 5.0 [latest update: #4862] on 21 September 2021 at 5:57:37 pm'! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 9/21/2021 17:50:48' overrides: 50556442! - extentChanged: oldExtent - "Our extent changed. Must layout submorphs again." - - super extentChanged: oldExtent. - taskbar ifNotNil: [ taskbar screenSizeChanged ].! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 9/21/2021 17:53:08' prior: 50603757! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag - "This is the main method for image save and / or quit. - See senders." - "WARNING: Current process will be killed. UI Process will be restarted" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic - checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " - | activeProc | - activeProc _ Processor activeProcess. - [ | isARealStartup guiRootObject guiRootObjectClass | - save not & quit - ifTrue: [ - (SourceFiles at: 2) ifNotNil: [ :changes | - ChangesInitialFileSize ifNotNil: [ changes truncate: ChangesInitialFileSize ]]] - ifFalse: [ - self - logSnapshot: save - andQuit: quit ]. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | - each isInWorld ifTrue: [ - each delete.]]. - UISupervisor ui tearDownDesktop. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - "Cosas que levanto explicitamente abajo" - guiRootObjectClass _ UISupervisor ui class. - guiRootObject _ UISupervisor ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "guiRootObject _ clearAllStateFlag ifFalse: [ UISupervisor ui ]." - UISupervisor stopUIProcess. - activeProc isTerminated ifFalse: [ activeProc terminate ]. - guiRootObject ifNotNil: [ guiRootObject releaseCachedState ]. - "Clean Globals" - Smalltalk - at: #Sensor - put: nil. - Smalltalk - at: #Display - put: nil. - Smalltalk closeSourceFiles. - Smalltalk - at: #SourceFiles - put: nil. - Smalltalk allClassesDo: [ :cls | - cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | - cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ - Smalltalk printStuffToCleanOnImageSave. - "Remove this call to actually see the image clean report." - Transcript clear. - ]. - "Do image save & quit as apropriate" - (Cursor cursorAt: #writeCursor) activateCursor. - save - ifTrue: [ - "The snapshot primitive answers false if it was just called to do the snapshot. - But image startup is resumed by returning (again) from the primitive, but this time answering true." - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk - at: #Sensor - put: nil. - Smalltalk - at: #Display - put: DisplayScreen new. - Smalltalk - at: #SourceFiles - put: (Array new: 2). - Smalltalk openSourceFiles. - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | - cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - UISupervisor spawnNewMorphicProcessFor: (guiRootObject ifNil: [ guiRootObject _ guiRootObjectClass newWorld ]). - self restoreLostChangesIfNecessary. - clearAllStateFlag ifTrue: [ - UISupervisor whenUIinSafeState: [ - guiRootObject recreateDefaultDesktop; restoreDisplay ]] - ifFalse: [ - UISupervisor whenUIinSafeState: [ - guiRootObject restoreDisplay ]]. - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - UISupervisor whenUIinSafeState: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]] - forkAt: Processor timingPriority - 1 - named: 'Startup process'.! ! -!DisplayScreen methodsFor: 'private' stamp: 'jmv 9/21/2021 17:53:28' prior: 50604445 overrides: 16848801! - setExtent: aPoint depth: bitsPerPixel - "DisplayScreen startUp" - "This method is critical. If the setExtent fails, there will be no - proper display on which to show the error condition." - - | bitsPerPixelToUse | - (depth = bitsPerPixel and: [aPoint = self extent and: [ - self supportsDisplayDepth: bitsPerPixel]]) ifFalse: [ - bits _ nil. "Free up old bitmap in case space is low" - bitsPerPixelToUse _ (self supportsDisplayDepth: bitsPerPixel) - ifTrue: [ bitsPerPixel ] - ifFalse: [ - (self supportsDisplayDepth: bitsPerPixel negated) - ifTrue: [ bitsPerPixel negated ] - ifFalse: [ self findAnyDisplayDepth ]]. - super setExtent: aPoint depth: bitsPerPixelToUse. - ].! ! -!TaskbarMorph methodsFor: 'events' stamp: 'jmv 9/21/2021 17:50:39' prior: 50379886! - screenSizeChanged - "Respond to change in screen size by repositioning self to bottom of screen" - -" Transcript newLine; print: 'Taskbar screenSizeChanged'. -" - | y e | - self world ifNotNil: [ :w | - y _ w morphExtent y - self defaultHeight. - e _ (self internalizeDistance: w morphExtent x @ self defaultHeight) asIntegerPoint. - self morphPosition: 0@y extent: e ].! ! -!TaskbarMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 9/21/2021 17:55:51' prior: 50337302 overrides: 50574235! - delete - - | w | - self restoreAll. - super delete. - w _ self world ifNil: [ self runningWorld ]. - w ifNotNil: [ w taskbarDeleted ]! ! -!TaskbarMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 9/21/2021 17:52:27' prior: 50594460 overrides: 16876712! - noteNewOwner: aMorph - "I have just been added as a submorph of aMorph" - - super noteNewOwner: aMorph. - aMorph submorphsDo: [ :subMorph | - self refreshTaskbarFor: aMorph ].! ! - -TaskbarMorph class removeSelector: #releaseClassCachedState! - -TaskbarMorph class removeSelector: #initClassCachedState! - -!methodRemoval: TaskbarMorph class #initClassCachedState stamp: 'Install-4872-Taskbar-fixesAndCleanup-JuanVuletich-2021Sep21-17h40m-jmv.001.cs.st 9/24/2021 10:40:19'! -initClassCachedState - - "Should use some other way to find relevant instances" - self flag: #jmvVer2. - self allInstancesDo: [ :each | - each notifyDisplayResize ]! - -TaskbarMorph removeSelector: #notifyDisplayResize! - -!methodRemoval: TaskbarMorph #notifyDisplayResize stamp: 'Install-4872-Taskbar-fixesAndCleanup-JuanVuletich-2021Sep21-17h40m-jmv.001.cs.st 9/24/2021 10:40:19'! -notifyDisplayResize - Display - when: #screenSizeChanged - send: #screenSizeChanged - to: self. - self screenSizeChanged! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -TaskbarMorph allInstancesDo: [ :each | - Display removeActionsWithReceiver: each ].! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4872-Taskbar-fixesAndCleanup-JuanVuletich-2021Sep21-17h40m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4871] on 22 September 2021 at 9:35:25 am'! -!DisplayScreen methodsFor: 'other' stamp: 'jmv 4/1/2013 20:12' prior: 50608178! - forceToScreen: aRectangle - "Force the given rectangular section of the Display to be copied to the screen. The primitive call does nothing if the primitive is not implemented. Used when the deferUpdates flag in the virtual machine is on; see #deferUpdates:." - - self primShowRectLeft: aRectangle left - right: aRectangle right - top: aRectangle top - bottom: aRectangle bottom. -! ! -!DisplayScreen class methodsFor: 'screen update' stamp: 'jmv 9/22/2021 09:31:18' prior: 50571634! - screenUpdater - | delay | - delay _ Delay forMilliseconds: 50. - ScreenUpdaterSemaphore _ Semaphore new. - Damage _ nil. - [ - delay wait. - ScreenUpdaterSemaphore wait. - DisplayScreen isDisplayExtentOk ifTrue: [ - Display forceToScreen: Damage. - ScreenUpdaterSemaphore initSignals. - Damage _ nil ]. - ] repeat! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - DisplayScreen installScreenUpdater! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4873-screenUpdater-fix-JuanVuletich-2021Sep22-09h31m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4871] on 22 September 2021 at 9:39:51 am'! -!DisplayScreen class methodsFor: 'snapshots' stamp: 'jmv 9/22/2021 09:37:38'! - setupDisplay - " - DisplayScreen setupDisplay. - Display forceToScreen. - " - - self terminateScreenUpdater. - Display setExtent: self actualScreenSize depth: Display nativeDepth. - Display beDisplay. - self installScreenUpdater.! ! -!DisplayScreen class methodsFor: 'snapshots' stamp: 'jmv 9/22/2021 09:37:45' prior: 50608218 overrides: 50335342! - startUp - " - DisplayScreen startUp. - Display forceToScreen. - " - self setupDisplay.! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 9/22/2021 09:38:22' prior: 50608224! - checkForNewScreenSize - "Check whether the screen size has changed and if so take appropriate actions" - - DisplayScreen isDisplayExtentOk ifFalse: [ - "Minimize the risk of going out of memory: - - First clear existing canvas, to free the memory it uses. - - Then, setup the display. - - Then set up new canvas." - self clearCanvas. - DisplayScreen setupDisplay. - self setMainCanvas. - self whenUIinSafeState: [ Cursor defaultCursor activateCursor ]].! ! - -DisplayScreen class removeSelector: #setupDisplay:! - -!methodRemoval: DisplayScreen class #setupDisplay: stamp: 'Install-4874-setupDisplay-removeSuperfluousPedantry-JuanVuletich-2021Sep22-09h35m-jmv.001.cs.st 9/24/2021 10:40:19'! -setupDisplay: doGarbageCollection - " - DisplayScreen setupDisplay: true. - Display forceToScreen. - " - - self terminateScreenUpdater. - doGarbageCollection ifTrue: [ - Display setExtent: 0@0 depth: 0 bits: nil. - Smalltalk primitiveGarbageCollect. ]. - Display setExtent: self actualScreenSize depth: Display nativeDepth. - Display beDisplay. - self installScreenUpdater.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4874-setupDisplay-removeSuperfluousPedantry-JuanVuletich-2021Sep22-09h35m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4874] on 22 September 2021 at 3:03:14 pm'! -!TaskbarMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 9/22/2021 15:02:43' prior: 50609691 overrides: 16876712! - noteNewOwner: aMorph - "I have just been added as a submorph of aMorph" - - super noteNewOwner: aMorph. - aMorph submorphsDo: [ :subMorph | - self refreshTaskbarFor: subMorph ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4875-Taskbar-fix-JuanVuletich-2021Sep22-15h02m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4875] on 22 September 2021 at 3:09:47 pm'! -!TaskbarMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 9/22/2021 15:09:15' prior: 50609850 overrides: 16876712! - noteNewOwner: aMorph - "I have just been added as a submorph of aMorph" - - super noteNewOwner: aMorph. - aMorph submorphsDo: [ :subMorph | - self refreshTaskbarFor: subMorph ]. - self screenSizeChanged.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4876-Taskbar-fix-JuanVuletich-2021Sep22-15h09m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4876] on 22 September 2021 at 4:08:55 pm'! -!Theme methodsFor: 'colors' stamp: 'jmv 9/22/2021 16:08:06' prior: 50388773! - background - - "^ `Color r: 0.7 g: 0.72 b: 0.83`." - ^ `Color r: 0.167 g: 0.344 b: 0.629`! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -self runningWorld color: Theme current background.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4877-defaultBackgroundColor-JuanVuletich-2021Sep22-16h07m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4877] on 22 September 2021 at 4:22:12 pm'! -!MessageSetWindow class methodsFor: 'opening' stamp: 'jmv 9/22/2021 16:20:42'! - openMessageListUnsorted: methodReferences label: labelString - "Open a system view for a MessageSet on messageList. - Don't sort entries by default." - - | messageSet | - - messageSet _ MessageSet messageList: methodReferences asArray. - - ^self open: messageSet label: labelString ! ! -!ChangeListWindow methodsFor: 'menu commands' stamp: 'jmv 9/22/2021 16:20:50' prior: 16797146! - browseCurrentVersionsOfSelections - "Opens a message-list browser on the current in-memory versions of all methods that are currently seleted" - | aList | - - aList _ model currentVersionsOfSelections. - - aList size = 0 ifTrue: [^ self inform: 'no selected methods have in-memory counterparts']. - MessageSetWindow - openMessageListUnsorted: aList - label: 'Current versions of selected methods in ', model file localName! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4878-browseCurrentVersions-unsortedByDefault-JuanVuletich-2021Sep22-16h20m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4876] on 22 September 2021 at 9:15:23 pm'! - -ChangeSelector subclass: #AddParameter - instanceVariableNames: 'newParameter newParameterValue implementorTrailingString senderTrailingString index isAddingLast' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #AddParameter category: #'Tools-Refactoring' stamp: 'Install-4879-ExtractAsParameter-HernanWilkinson-2021Sep22-15h23m-HAW.001.cs.st 9/24/2021 10:40:20'! -ChangeSelector subclass: #AddParameter - instanceVariableNames: 'newParameter newParameterValue implementorTrailingString senderTrailingString index isAddingLast' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -Refactoring subclass: #ExtractAsParameter - instanceVariableNames: 'intervalToExtract sourceMethod addParameter intervalToReplace' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractAsParameter category: #'Tools-Refactoring' stamp: 'Install-4879-ExtractAsParameter-HernanWilkinson-2021Sep22-15h23m-HAW.001.cs.st 9/24/2021 10:40:20'! -Refactoring subclass: #ExtractAsParameter - instanceVariableNames: 'intervalToExtract sourceMethod addParameter intervalToReplace' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -AddParameterApplier subclass: #ExtractAsParameterApplier - instanceVariableNames: 'interval' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractAsParameterApplier category: #'Tools-Refactoring' stamp: 'Install-4879-ExtractAsParameter-HernanWilkinson-2021Sep22-15h23m-HAW.001.cs.st 9/24/2021 10:40:20'! -AddParameterApplier subclass: #ExtractAsParameterApplier - instanceVariableNames: 'interval' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!SmalltalkEditor methodsFor: 'contextual add/remove parameter' stamp: 'HAW 9/22/2021 20:24:46'! - contextualExtractAsParameter - - self isEditingClassDefinition - ifTrue: [ morph flash ] - ifFalse: [ self ifSourceCodeRefactoringCanBeAppliedDo: [ self extractAsParameter ]]! ! -!SmalltalkEditor methodsFor: 'contextual add/remove parameter' stamp: 'HAW 9/22/2021 16:36:12'! - contextualExtractAsParameter: aKeyboardEvent - - self contextualExtractAsParameter. - ^true! ! -!SmalltalkEditor methodsFor: 'contextual add/remove parameter' stamp: 'HAW 9/22/2021 20:24:56'! - extractAsParameter - - ^ RefactoringApplier extractAsParameterApplier createAndValueHandlingExceptions: [ - RefactoringApplier extractAsParameterApplier - from: self selectionInterval - on: model textProvider - for: self codeProvider selectedMessageName - in: self selectedClassOrMetaClassOrUndefinedObject ]! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 9/22/2021 19:41:21'! - selectedClassOrMetaClassOrUndefinedObject - - "I have to do this because some codeProviders do not answer selectedClassOrMetaClass like the Workspace - Hernan" - - ^ [ self codeProvider selectedClassOrMetaClass ] - on: Error - do: [ :anError | anError return: UndefinedObject ]! ! -!ChangeSelector methodsFor: 'changes' stamp: 'HAW 9/22/2021 20:18:57'! - changes - - ^changes! ! -!AddParameter methodsFor: 'parameter' stamp: 'HAW 9/8/2021 22:37:02'! - newParameter - - ^newParameter! ! -!ExtractAsParameter methodsFor: 'applying' stamp: 'HAW 9/22/2021 20:19:25' overrides: 50438485! - apply - - self - applyAddParameter; - useNewParameter. - - ^addParameter changes - - ! ! -!ExtractAsParameter methodsFor: 'applying - private' stamp: 'HAW 9/22/2021 20:19:25'! - applyAddParameter - - ^ addParameter apply! ! -!ExtractAsParameter methodsFor: 'applying - private' stamp: 'HAW 9/22/2021 20:17:24'! - newSourceCode - - | intermediateSourceCode newInterval newSourceCode originalSourceCodeSize intermediateMethod | - - originalSourceCodeSize := sourceMethod sourceCode size. - intermediateMethod := sourceMethod methodClass >> self newSelector. - intermediateSourceCode := intermediateMethod sourceCode. - newInterval := intervalToReplace + (intermediateSourceCode size - originalSourceCodeSize). - newSourceCode := intermediateSourceCode copyReplaceFrom: newInterval first to: newInterval last with: addParameter newParameter. - - ^newSourceCode ! ! -!ExtractAsParameter methodsFor: 'applying - private' stamp: 'HAW 9/22/2021 20:17:33'! - useNewParameter - - sourceMethod methodClass compile: self newSourceCode. - - ! ! -!ExtractAsParameter methodsFor: 'initialization' stamp: 'HAW 9/21/2021 19:13:59'! - initializeExtractedFrom: anIntervalToExtract replacing: anIntervalToReplace at: aSourceMethod addingParameterWith: anAddParameter - - intervalToExtract := anIntervalToExtract. - intervalToReplace := anIntervalToReplace. - sourceMethod := aSourceMethod. - addParameter := anAddParameter.! ! -!ExtractAsParameter methodsFor: 'selectors' stamp: 'HAW 9/22/2021 19:56:45'! - newSelector - - ^addParameter newSelector ! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/22/2021 15:39:26'! - assert: aSourceMethod isInImplementors: implementorsCollection - - ^ (implementorsCollection includes: aSourceMethod) ifFalse: [ self signalOrigialMethodMustBeInImplementorsToChange ]! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/22/2021 20:07:25'! - assertAndCreateNamed: aNewParameter - extractedFrom: anInterval - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - creatingAddParameterWith: addParameterCreator - - | addParameter sourceCodeToExtract trimmedIntervalToReplace intervalToReplace intervals | - - self assert: aSourceMethod isInImplementors: implementorsCollection. - intervals := self assertCanExtractedFrom: anInterval for: aSourceMethod. - - intervalToReplace := intervals first. - trimmedIntervalToReplace := intervals second. - sourceCodeToExtract := aSourceMethod sourceCode copyFrom: trimmedIntervalToReplace first to: trimmedIntervalToReplace last. - - addParameter := addParameterCreator value: sourceCodeToExtract. - - ^self new - initializeExtractedFrom: trimmedIntervalToReplace - replacing: intervalToReplace - at: aSourceMethod - addingParameterWith: addParameter! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/22/2021 19:01:23'! - assertCanExtractedFrom: anInterval for: aSourceMethod - - | trimmedIntervalToReplace sourceCode node intervalToReplace | - - sourceCode := aSourceMethod sourceCode. - - ExtractMethodNewMethod assertIntervalToExtractIsNotEmpty: anInterval. - ExtractMethodNewMethod assert: anInterval isWithinBoundsOf: sourceCode. - - intervalToReplace := self removeDotsAt: anInterval in: sourceCode. - trimmedIntervalToReplace := intervalToReplace asSourceCodeInterval trimToMatchExpressionOn: sourceCode. - node := self nodeToExtractFrom: aSourceMethod at: trimmedIntervalToReplace or: intervalToReplace. - self assertIsValidToExtract: node. - - ^{ intervalToReplace. trimmedIntervalToReplace } - - ! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/22/2021 14:26:11'! - assertIsValidAssigmentToExtract: anAssignmentNode - - self assertIsValidToExtract: anAssignmentNode variable. - self assertIsValidToExtract: anAssignmentNode value ! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/22/2021 09:40:26'! - assertIsValidBlockNodeToExtract: aBlockNode - - aBlockNode block statementsDo: [ :aStatement | self assertIsValidToExtract: aStatement ]! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/22/2021 20:05:10'! - assertIsValidKeywordForNewParameter: aNewKeyword - - AddParameter assertIsValidKeywordForNewParameter: aNewKeyword! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/22/2021 15:09:49'! - assertIsValidLiteralNodeToExtract: aNode - - ^ (aNode isLiteralNode - or: [ aNode isTruePseudoVariable - or: [ aNode isFalsePseudoVariable - or: [ aNode isNilPseudoVariable ]]]) ifFalse: [ self signalInvalidExpressionToExtractAsParameter ]! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/22/2021 15:04:00'! - assertIsValidMessageNodeToExtract: aNode - - self assertIsValidToExtract: aNode receiver. - aNode arguments do: [ :anArgument | self assertIsValidToExtract: anArgument ]! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/22/2021 19:56:21'! - assertIsValidParameterName: aName - - AddParameter assertIsValidParameterName: aName ! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/22/2021 15:09:49'! - assertIsValidTempOrArgNodeToExtract: aTempVariableNode - - aTempVariableNode isDeclaredAtMethodLevel ifTrue: [ self signalInvalidExpressionToExtractAsParameter ]! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/22/2021 15:03:50'! - assertIsValidToExtract: aNode - - aNode isMessageNode ifTrue: [ ^self assertIsValidMessageNodeToExtract: aNode]. - aNode isBlockNode ifTrue: [ ^self assertIsValidBlockNodeToExtract: aNode ]. - aNode isTempOrArg ifTrue: [ ^self assertIsValidTempOrArgNodeToExtract: aNode ]. - aNode isAssignmentToTemporary ifTrue: [ ^self assertIsValidAssigmentToExtract: aNode ]. - self assertIsValidLiteralNodeToExtract: aNode! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/22/2021 09:28:16'! - is: aRange equalTo: sourceInterval or: intervalToReplace - - "When selecting literals like 1, the range first is one less than the initial character of the literal - Hernan" - - ^aRange = sourceInterval - or: [ aRange = intervalToReplace - or: [ aRange first + 1 = sourceInterval first and: [ aRange value last = sourceInterval last]]]! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/22/2021 15:45:11'! - nodeToExtractFrom: aSourceMethod at: trimmedIntervalToReplace or: intervalToReplace - - | nodeWithRangeToExtract nodesWithFirstPosition | - - nodesWithFirstPosition := aSourceMethod methodNode parseNodesPathAt: trimmedIntervalToReplace first ifAbsent: [ self signalInvalidSelection ]. - nodeWithRangeToExtract := nodesWithFirstPosition - detect: [ :nodeAndRange | self is: nodeAndRange value equalTo: trimmedIntervalToReplace or: intervalToReplace ] - ifNone: [ self signalInvalidSelection ]. - - ^nodeWithRangeToExtract key. - ! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/22/2021 15:42:21'! - removeDotsAt: anInterval in: sourceCode - - | lastToReplace | - - lastToReplace := anInterval last. - [(sourceCode at: lastToReplace) = $. ] whileTrue: [ lastToReplace := lastToReplace - 1]. - - ^anInterval first to: lastToReplace! ! -!ExtractAsParameter class methodsFor: 'instance creation' stamp: 'HAW 9/22/2021 15:55:37'! - named: aNewParameter - extractedFrom: anInterval - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - - ^self - assertAndCreateNamed: aNewParameter - extractedFrom: anInterval - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - creatingAddParameterWith: [ :sourceCodeToExtract | - AddParameter - named: aNewParameter - initializedWith: sourceCodeToExtract - toUnarySelector: aSourceMethod selector - implementors: implementorsCollection - senders: sendersCollection ]! ! -!ExtractAsParameter class methodsFor: 'instance creation' stamp: 'HAW 9/22/2021 15:56:38'! - named: aNewParameter - extractedFrom: anInterval - at: aNewKeywordIndex - newKeyword: newKeyword - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - - ^self - assertAndCreateNamed: aNewParameter - extractedFrom: anInterval - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - creatingAddParameterWith: [ :sourceCodeToExtract | - AddParameter - named: aNewParameter - at: aNewKeywordIndex - initializedWith: sourceCodeToExtract - using: newKeyword - toKeywordSelector: aSourceMethod selector - implementors: implementorsCollection - senders: sendersCollection ]! ! -!ExtractAsParameter class methodsFor: 'error messages' stamp: 'HAW 9/22/2021 15:10:01'! - errorMessageForInvalidExpressionToExtractAsParameter - - ^'Only literals, message sends to literals with literal parameters and -blocks with the previous conditions can be extracted as parameters'! ! -!ExtractAsParameter class methodsFor: 'error messages' stamp: 'HAW 9/21/2021 17:31:17'! - errorMessageForInvalidSelection - - ^'The selected source code is invalid for extraction as parameter'! ! -!ExtractAsParameter class methodsFor: 'error messages' stamp: 'HAW 9/22/2021 15:36:27'! - errorMessageForOrigialMethodMustBeInImplementorsToChange - - ^'Method with code to extract must be as implementor to change'! ! -!ExtractAsParameter class methodsFor: 'exceptions' stamp: 'HAW 9/22/2021 15:10:01'! - signalInvalidExpressionToExtractAsParameter - - self refactoringError: self errorMessageForInvalidExpressionToExtractAsParameter ! ! -!ExtractAsParameter class methodsFor: 'exceptions' stamp: 'HAW 9/21/2021 17:30:33'! - signalInvalidSelection - - self refactoringError: self errorMessageForInvalidSelection! ! -!ExtractAsParameter class methodsFor: 'exceptions' stamp: 'HAW 9/22/2021 15:37:55'! - signalOrigialMethodMustBeInImplementorsToChange - - self refactoringError: self errorMessageForOrigialMethodMustBeInImplementorsToChange! ! -!ExtractAsParameter class methodsFor: 'implementors and senders' stamp: 'HAW 9/22/2021 19:57:44'! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders forClassAndMetaOf: aPotentialClassToRefactor - - ^AddParameter addImplementorsOf: anOldSelector to: implementors andSendersTo: senders forClassAndMetaOf: aPotentialClassToRefactor! ! -!ExtractAsParameter class methodsFor: 'implementors and senders' stamp: 'HAW 9/22/2021 19:59:56'! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategoriesAndHierarchyOf: aClass organizedBy: anOrganization - - ^AddParameter addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategoriesAndHierarchyOf: aClass organizedBy: anOrganization! ! -!ExtractAsParameter class methodsFor: 'implementors and senders' stamp: 'HAW 9/22/2021 19:59:25'! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategory: aCategory organizedBy: anOrganization - - ^AddParameter addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategory: aCategory organizedBy: anOrganization! ! -!ExtractAsParameter class methodsFor: 'implementors and senders' stamp: 'HAW 9/22/2021 19:58:31'! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inHierarchyOf: aClass - - ^AddParameter addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inHierarchyOf: aClass -! ! -!ExtractAsParameter class methodsFor: 'implementors and senders' stamp: 'HAW 9/22/2021 20:00:22'! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inSystem: aSystem - - ^AddParameter addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inSystem: aSystem -! ! -!RefactoringApplier class methodsFor: 'appliers - registering' stamp: 'HAW 9/22/2021 18:38:54'! - registerExtractAsParameterApplier: anExtractAsParameterApplierClass - - self registerApplierAt: self extractAsParameterApplierId with: anExtractAsParameterApplierClass ! ! -!RefactoringApplier class methodsFor: 'appliers - getting' stamp: 'HAW 9/22/2021 16:35:35'! - extractAsParameterApplier - - ^self applierAt: self extractAsParameterApplierId ifAbsent: [ ExtractAsParameterApplier ]! ! -!RefactoringApplier class methodsFor: 'appliers - id' stamp: 'HAW 9/22/2021 16:35:22'! - extractAsParameterApplierId - - ^#extractAsParameterApplier! ! -!RefactoringApplier class methodsFor: 'appliers - resetting' stamp: 'HAW 9/22/2021 18:39:16'! - resetExtractAsParameterApplier - - self resetApplierAt: self extractAsParameterApplierId! ! -!ExtractAsParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 9/22/2021 16:30:27' overrides: 50441865! - askNewParameterValue! ! -!ExtractAsParameterApplier methodsFor: 'refactoring - creation' stamp: 'HAW 9/22/2021 20:06:39' overrides: 50441788! - createRefactoringForKeywordSelector - - ^self refactoringClass - named: newParameter - extractedFrom: interval - at: parameterIndex - newKeyword: newKeyword - at: selectedClass >> oldSelector - implementors: implementors - senders: senders ! ! -!ExtractAsParameterApplier methodsFor: 'refactoring - creation' stamp: 'HAW 9/22/2021 19:36:15' overrides: 50441799! - createRefactoringForUnarySelector - - ^self refactoringClass - named: newParameter - extractedFrom: interval - at: selectedClass >> oldSelector - implementors: implementors - senders: senders ! ! -!ExtractAsParameterApplier methodsFor: 'refactoring - creation' stamp: 'HAW 9/22/2021 16:30:58' overrides: 50441809! - refactoringClass - - ^ExtractAsParameter ! ! -!ExtractAsParameterApplier methodsFor: 'initialization' stamp: 'HAW 9/22/2021 19:05:46'! - initializeInterval: anInterval - - interval := anInterval.! ! -!ExtractAsParameterApplier class methodsFor: 'instance creation' stamp: 'HAW 9/22/2021 19:03:29'! -from: anInterval on: aModel for: anOldSelector in: aClassToRefactor - - ExtractAsParameter assertCanExtractedFrom: anInterval for: aClassToRefactor >> anOldSelector. - - ^(super on: aModel for: anOldSelector in: aClassToRefactor) initializeInterval: anInterval ! ! -!SmalltalkEditor methodsFor: 'contextual rename' stamp: 'HAW 9/22/2021 19:41:05' prior: 50573357! - withMethodNodeAndClassDo: aBlock ifErrorsParsing: anErrorBlock - - | selectedClass methodNode | - - selectedClass := self selectedClassOrMetaClassOrUndefinedObject. - [ - [ methodNode := selectedClass methodNodeFor: model actualContents asString ] - on: UndeclaredVariableWarning do: [ :ex | ex resume ] - ] on: Error do: [ :anError | ^ anErrorBlock value: anError ]. - - ^aBlock value: methodNode value: selectedClass.! ! -!AddParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 9/22/2021 16:27:52' prior: 50441865! - askNewParameterValue - - | enteredString | - - enteredString := self request: 'Enter parameter value for senders'. - newParameterValue := enteredString withBlanksTrimmed. - self refactoringClass assertNewParameterValueIsValid: newParameterValue. -! ! -!RefactoringMenues class methodsFor: 'editor menus' stamp: 'HAW 9/22/2021 16:41:33' prior: 50491929! - smalltalkEditorRefactoringMenuOptions - - ^`{ - { - #itemGroup -> 35. - #itemOrder -> 30. - #label -> 'Add Parameter... (A)'. - #selector -> #contextualAddParameter. - #icon -> #listAddIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 35. - #label -> 'Extract as Parameter... (1)'. - #selector -> #contextualExtractAsParameter. - #icon -> #listAddIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 40. - #label -> 'Remove Parameter... (S)'. - #selector -> #contextualRemoveParameter. - #icon -> #listRemoveIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 50. - #label -> 'Temporary to Instance Variable (O)'. - #selector -> #temporaryToInstanceVariable. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 60. - #label -> 'Push Up Instance Variable'. - #selector -> #contextualPushUpInClassDefinition. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 35. - #itemOrder -> 70. - #label -> 'Push Down Instance Variable'. - #selector -> #contextualPushDownInClassDefinition. - #icon -> #goBottomIcon - } asDictionary. - }`! ! -!RefactoringMenues class methodsFor: 'shortcuts' stamp: 'HAW 9/22/2021 19:34:01' prior: 50507328! - smalltalkEditorCmdShortcutsSpec - - " - SmalltalkEditor initializeCmdShortcuts - " - ^#( - #($R #contextualRename: 'Renames what is under cursor') - #($A #contextualAddParameter: 'Adds parameter to message that is under cursor') - #($S #contextualRemoveParameter: 'Removes parameter to message that is under cursor') - #($O #temporaryToInstanceVariable: 'Extracts temporary variable to instance variable') - #($J #extractToTemporary: 'Extracts the selected code into a temporary variable') - #($K #extractMethod: 'Extracts the selected code into a separate method') - #($1 #contextualExtractAsParameter: 'Extracts the selected code as parameter') - )! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'pre-conditions' stamp: 'HAW 9/22/2021 14:33:51' prior: 50517379! - assertSourceCodeContainsAValidExpression - - (self intervalCoversCompleteAstNodes - and: [ self startAndEndNodesShareAParentNode - or: [ self intervalMatchesBeginningOfStatement - and: [ self intervalMatchesEndOfStatement ]]]) - ifFalse: [ self signalSourceCodeContainsAnInvalidExpressionError ]! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'private' stamp: 'HAW 9/22/2021 14:55:22' prior: 50508772! - intervalMatchesEndOfStatement - - | closerStatementLastPosition | - - closerStatementLastPosition := (self findSourceRangeOfCloserStatementIn: finalNodeAncestors) last. - ^ closerStatementLastPosition = intervalToExtract last or: [ closerStatementLastPosition - 1 = intervalToExtract last ].! ! - -ExtractAsParameterApplier class removeSelector: #on:for:in:! - -ExtractAsParameter class removeSelector: #assertNamed:extractedFrom:at:implementors:senders:creatingAddParameterWith:! - -ExtractAsParameter class removeSelector: #assertNamed:extractedFrom:at:implementors:senders:! - -ExtractAsParameter removeSelector: #addParameter! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4879-ExtractAsParameter-HernanWilkinson-2021Sep22-15h23m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4879] on 23 September 2021 at 10:21:47 am'! -!CodeProvider methodsFor: 'annotation' stamp: 'jmv 9/22/2021 18:29:08'! - annotationForSystemCategory: aCategory - "Provide a line of content for an annotation pane, given that the receiver is pointing at the class definition of the given class." - - | separator | - separator _ self annotationSeparator. - ^ String streamContents: [ :strm | - strm - nextPutAll: 'System Category'; - nextPutAll: aCategory; - nextPutAll: separator; - print: (SystemOrganization listAtCategoryNamed: aCategory) size; - nextPutAll: ' classes'; - nextPutAll: separator; - print: (SystemOrganization instanceMethodCountOf: aCategory); - nextPutAll: ' instance methods'; - nextPutAll: separator; - print: (SystemOrganization classMethodCountOf: aCategory); - nextPutAll: ' class methods'; - nextPutAll: separator; - print: (SystemOrganization linesOfCodeOf: aCategory); - nextPutAll: ' total lines of code' ]! ! -!SystemOrganizer methodsFor: 'source code management' stamp: 'jmv 9/23/2021 10:18:03'! - classMethodCountOf: category - - ^ (self superclassOrderIn: category) sum: [ :cl | cl class selectors size ] ifEmpty: 0.! ! -!SystemOrganizer methodsFor: 'source code management' stamp: 'jmv 9/23/2021 10:18:08'! - instanceMethodCountOf: category - - ^ (self superclassOrderIn: category) sum: [ :cl | cl selectors size ] ifEmpty: 0.! ! -!SystemOrganizer methodsFor: 'source code management' stamp: 'jmv 9/23/2021 10:16:49'! - linesOfCodeOf: category -" -SystemOrganization linesOfCodeOf: #'System-Files' -" - "An approximate measure of lines of. - Includes comments, but excludes blank lines." - - ^ (self superclassOrderIn: category) sum: [ :cl | cl linesOfCode ] ifEmpty: 0.! ! -!CodeProvider methodsFor: 'annotation' stamp: 'jmv 9/22/2021 18:45:23' prior: 50518432! - annotationForSelector: aSelector ofClass: aClass - "Provide a line of content for an annotation pane, representing - information about the given selector and class" - - | stamp sendersCount implementorsCount aCategory separator aString aList aComment stream requestList | - aSelector == #Comment - ifTrue: [^ self annotationForClassCommentFor: aClass]. - aSelector == #Definition - ifTrue: [^ self annotationForClassDefinitionFor: aClass]. - aSelector == #Hierarchy - ifTrue: [^ self annotationForHierarchyFor: aClass]. - stream _ WriteStream on: String new. - requestList _ self annotationRequests. - separator _ self annotationSeparator. - requestList - do: [:aRequest | - aRequest == #firstComment - ifTrue: [ - aComment _ aClass firstCommentAt: aSelector. - aComment isEmptyOrNil - ifFalse: [stream position = 0 ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: aComment]]. - aRequest == #masterComment - ifTrue: [ - aComment _ aClass supermostPrecodeCommentFor: aSelector. - aComment isEmptyOrNil - ifFalse: [stream position = 0 ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: aComment]]. - aRequest == #documentation - ifTrue: [ - aComment _ aClass precodeCommentOrInheritedCommentFor: aSelector. - aComment isEmptyOrNil - ifFalse: [stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: aComment]]. - aRequest == #timeStamp - ifTrue: [ - stamp _ self timeStamp. - stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: (stamp size > 0 ifTrue: [stamp] ifFalse: ['no timestamp'])]. - aRequest == #linesOfCode - ifTrue: [ - stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: ((aClass compiledMethodAt: aSelector ifAbsent: nil) - ifNotNil: [ :cm | cm linesOfCode]) printString, ' lines of code']. - aRequest == #messageCategory - ifTrue: [ - aCategory _ aClass organization categoryOfElement: aSelector. - aCategory - ifNotNil: ["woud be nil for a method no longer present, - e.g. in a recent-submissions browser" - stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: aCategory]]. - aRequest == #sendersCount - ifTrue: [ - sendersCount _ Smalltalk numberOfSendersOf: aSelector. - sendersCount _ sendersCount = 1 - ifTrue: ['1 sender'] - ifFalse: [sendersCount printString , ' senders']. - stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: sendersCount]. - aRequest == #implementorsCount - ifTrue: [ - implementorsCount _ Smalltalk numberOfImplementorsOf: aSelector. - implementorsCount _ implementorsCount = 1 - ifTrue: ['1 implementor'] - ifFalse: [implementorsCount printString , ' implementors']. - stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: implementorsCount]. - aRequest == #priorVersionsCount - ifTrue: [ - stream isEmpty ifFalse: [stream nextPutAll: separator]. - self - addPriorVersionsCountForSelector: aSelector - ofClass: aClass - to: stream]. - aRequest == #priorTimeStamp - ifTrue: [ - stamp _ VersionsBrowser - timeStampFor: aSelector - class: aClass - reverseOrdinal: 2. - stamp - ifNotNil: [stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: 'prior timestamp: ' , stamp]]. - aRequest == #packages - ifTrue: [ - (aClass compiledMethodAt: aSelector ifAbsent: nil) ifNotNil: [ :cm | - stream isEmpty ifFalse: [stream nextPutAll: separator]. - (CodePackage packageOfMethod: cm methodReference ifNone: nil) - ifNil: [ stream nextPutAll: 'in no package' ] - ifNotNil: [ :codePackage | - stream nextPutAll: 'in package '; nextPutAll: codePackage packageName ]]]. - aRequest == #changeSets - ifTrue: [ - stream isEmpty ifFalse: [stream nextPutAll: separator]. - aList _ ChangeSet allChangeSetsWithClass: aClass selector: aSelector. - aList size > 0 - ifTrue: [aList size = 1 - ifTrue: [stream nextPutAll: 'only in change set'] - ifFalse: [stream nextPutAll: 'in change sets:']. - aList - do: [:aChangeSet | stream nextPut: Character space; nextPutAll: aChangeSet name ] - separatedBy: [ stream nextPut: $, ]] - ifFalse: [stream nextPutAll: 'in no change set']]. - aRequest == #allChangeSets - ifTrue: [ - stream isEmpty ifFalse: [stream nextPutAll: separator]. - aList _ ChangeSet allChangeSetsWithClass: aClass selector: aSelector. - aList size > 0 - ifTrue: [aList size = 1 - ifTrue: [stream nextPutAll: 'only in change set'] - ifFalse: [stream nextPutAll: 'in change sets:']. - aList - do: [:aChangeSet | stream nextPut: Character space; nextPutAll: aChangeSet name ] - separatedBy: [ stream nextPut: $, ]] - ifFalse: [stream nextPutAll: 'in no change set']]. - aRequest == #allBaseSystemChangeSets - ifTrue: [ - stream isEmpty ifFalse: [stream nextPutAll: separator]. - aList _ (ChangeSet allChangeSetsWithClass: aClass selector: aSelector) select: [ :it | it isForBaseSystem ]. - aList size > 0 - ifTrue: [ - aList size = 1 - ifTrue: [stream nextPutAll: 'only in base system change set'] - ifFalse: [stream nextPutAll: 'in base system change sets:']. - aList - do: [:aChangeSet | stream nextPut: Character space; nextPutAll: aChangeSet name ] - separatedBy: [ stream nextPut: $, ]] - ifFalse: [stream nextPutAll: 'in no base system change set']]. - aRequest == #closuresInfo - ifTrue: [ - aString _ aClass closuresInfoAt: aSelector. - aString size > 0 - ifTrue: [stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: aString]]. - ]. - ^ stream contents! ! -!Browser methodsFor: 'annotation' stamp: 'jmv 9/23/2021 10:08:33' prior: 50485529 overrides: 50455411! - annotation - "Provide a line of content for an annotation pane, representing information about the method associated with the selected class and selector in the receiver." - - | aSelector aClass | - (aClass _ self selectedClassOrMetaClass) - ifNil: [ - self selectedSystemCategoryName ifNotNil: [ :sysCat | - ^self annotationForSystemCategory: sysCat ]. - ^ '']. - self editSelection == #editComment - ifTrue: [^ self annotationForSelector: #Comment ofClass: aClass]. - self isEditingExistingClass - ifTrue: [^ self annotationForSelector: #Definition ofClass: aClass]. - (aSelector _ self selectedMessageName) - ifNil: [^ '']. - ^ self annotationForSelector: aSelector ofClass: aClass! ! -!ClassDescription methodsFor: 'source code management' stamp: 'jmv 9/23/2021 10:05:44' prior: 16807069! - linesOfCode -" -Object linesOfCode -" - "An approximate measure of lines of. - Includes comments, but excludes blank lines. - If asked to a class, also include its metaclass (i.e. the class side). - If asked to a metaclass (the class side), don't include the class (the instance side)." - - | lines | - lines _ 0. - self selectorsDo: [ :sel | - lines _ lines + (self compiledMethodAt: sel) linesOfCode ]. - ^self isMeta - ifTrue: [ lines] - ifFalse: [ lines + self class linesOfCode]. -" -(SystemOrganization categories select: [:c | 'Kernel*' match: c]) sum: [:c | - (SystemOrganization superclassOrderIn: c) sum: [:cl | cl linesOfCode]] -" -" -Smalltalk allClasses sum: [:cl | cl linesOfCode] -"! ! -!CompiledMethod methodsFor: 'source code management' stamp: 'jmv 9/23/2021 10:03:40' prior: 16820495! - linesOfCode - "An approximate measure of lines of code. - Use decompiled source code. In this way, the measure: - - Doesn't include comments - - Doesn't include blank lines - - Is not sensitive to code formatting - The motivation is to consider LOC as an expense, not an asset. Minimizing LOC is good. - But it is not like that for comments!!" - - | lines | - lines _ 0. - self decompileString lineIndicesDo: [ :start :endWithoutDelimiters :end | - endWithoutDelimiters - start > 0 ifTrue: [ - lines _ lines+1 ]]. - ^lines! ! -!Preferences class methodsFor: 'parameters' stamp: 'jmv 9/22/2021 18:41:13' prior: 16893315! -annotationInfo - "Answer a list of pairs characterizing all the available kinds of annotations; in each pair, the first element is a symbol representing the info type, and the second element is a string providing the corresponding balloon help" - - ^ #( - (timeStamp 'The time stamp of the last submission of the method.') - (firstComment 'The first comment in the method, if any.') - (masterComment 'The comment at the beginning of the supermost implementor of the method if any.') - (documentation 'Comment at beginning of the method or, if it has none, comment at the beginning of a superclass''s implementation of the method.') - (messageCategory 'Which method category the method lies in.') - (sendersCount 'A report of how many senders there of the message.') - (implementorsCount 'A report of how many implementors there are of the message.') - (allChangeSets 'A list of all change sets bearing the method.') - (priorVersionsCount 'A report of how many previous versions there are of the method.') - (priorTimeStamp 'The time stamp of the penultimate submission of the method, if any.') - (closuresInfo 'Details about BlockClosures in the method.') - (packages 'Details about CodePackages including the method.') - (linesOfCode 'Number of lines of code, including comments but not blank lines.') - )! ! -!CodePackage methodsFor: 'source code management' stamp: 'jmv 9/23/2021 10:27:42' prior: 16810500! - linesOfCode - "An approximate measure of lines of code. - Does not includes comments, or excludes blank lines. - See comment at CompiledMethod >> #linesOfCode" - - ^self methods inject: 0 into: [ :sum :each | - sum + each compiledMethod linesOfCode ].! ! -!Preferences class methodsFor: 'parameters' stamp: 'jmv 9/22/2021 18:42:21' prior: 50419247! - setDefaultAnnotationInfo - " - Preferences setDefaultAnnotationInfo - " - ^ self parameters at: #MethodAnnotations put: #(timeStamp linesOfCode messageCategory implementorsCount sendersCount packages changeSets)! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - Preferences setDefaultAnnotationInfo! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4880-LinesOfCode-Enhancements-JuanVuletich-2021Sep23-09h57m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4880] on 23 September 2021 at 11:31:18 am'! -!Preferences class methodsFor: 'parameters' stamp: 'jmv 9/23/2021 11:30:01'! - setCheapAnnotationInfo - " - Preferences setCheapAnnotationInfo - " - ^ self parameters at: #MethodAnnotations put: #(timeStamp messageCategory packages changeSets)! ! -!Preferences class methodsFor: 'themes' stamp: 'jmv 9/23/2021 11:30:57' prior: 50601569! - slowMachine - " - Preferences slowMachine - " - self setPreferencesFrom: #( - #(#drawKeyboardFocusIndicator false ) - (balloonHelpEnabled false) - (browseWithPrettyPrint false) - (caseSensitiveFinds true) - (checkForSlips false) - (cmdDotEnabled true) - (diffsInChangeList true) - (diffsWithPrettyPrint false) - (menuKeyboardControl false) - (optionalButtons false) - (subPixelRenderFonts true) - (thoroughSenders true) - (cheapWindowReframe true) - (syntaxHighlightingAsYouType false) - (tapAndHoldEmulatesButton2 false) - (clickGrabsMorphs true) - ). - self useNoMenuIcons. - self runningWorld backgroundImageData: nil. - Preferences setCheapAnnotationInfo. - " - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - Taskbar hideTaskbar - "! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4881-Preferences-slowMachine-tweaks-JuanVuletich-2021Sep23-11h29m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4881] on 23 September 2021 at 4:06:09 pm'! -!PluggableButtonMorph methodsFor: 'accessing' stamp: 'KenD 9/17/2021 16:05:19' prior: 50578405! - iconName - - ^ self valueOfProperty: #iconName! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4882-iconName-fix-KenDickey-2021Sep23-16h05m-KenD.001.cs.st----! - -'From Cuis 5.0 [latest update: #4882] on 24 September 2021 at 10:19:33 am'! -!FontFamily class methodsFor: 'accessing fonts' stamp: 'jmv 9/24/2021 10:03:42'! - enableTrueTypeFontsOnly - - AvailableFamilies _ AvailableFamilies select: [ :f | f isTrueTypeFontFamily ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4883-EnableOnlyTrueTypeFonts-JuanVuletich-2021Sep24-10h19m-jmv.001.cs.st----! - -----QUIT----(24 September 2021 10:40:26) Cuis5.0-4883-v3.image priorSource: 8890635! - -----STARTUP---- (24 September 2021 11:25:03) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4883-v3.image! - - -'From Cuis 5.0 [latest update: #4883] on 24 September 2021 at 11:18:01 am'! -!MovableMorph methodsFor: 'initialization' stamp: 'jmv 9/24/2021 11:16:19' prior: 50554393 overrides: 50554646! - initialize - "initialize the state of the receiver" - - super initialize. - location _ MorphicTranslation new. - self fixYAxisDirection.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4884-fixYDirection-atCreation-JuanVuletich-2021Sep24-11h16m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4884] on 24 September 2021 at 11:22:34 am'! -!Base64MimeConverter class methodsFor: 'services' stamp: 'NM 9/24/2021 15:05:45' prior: 16782442! - mimeEncode: aCollectionOrStream to: outStream - self new - dataStream: ((aCollectionOrStream is: #Stream) - ifTrue: [aCollectionOrStream] - ifFalse: [ReadStream on: aCollectionOrStream]); - mimeStream: outStream; - multiLine: true; - mimeEncode! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4885-Base64MimeConverter-NicolaMingotti-2021Sep24-11h21m-NM.001.cs.st----! - -----QUIT----(24 September 2021 11:25:10) Cuis5.0-4885-v3.image priorSource: 8942513! - -----STARTUP---- (14 October 2021 14:32:36) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4885-v3.image! - - -'From Cuis 5.0 [latest update: #4879] on 24 September 2021 at 8:40:55 pm'! - -Refactoring subclass: #ExtractAsParameter - instanceVariableNames: 'intervalToExtract sourceMethod addParameter intervalToReplace intervals ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractAsParameter category: #'Tools-Refactoring' stamp: 'Install-4886-ExtractAsParameterMultiOcurrences-HernanWilkinson-2021Sep24-17h18m-HAW.001.cs.st 10/14/2021 14:32:40'! -Refactoring subclass: #ExtractAsParameter - instanceVariableNames: 'intervalToExtract sourceMethod addParameter intervalToReplace intervals' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -AddParameterApplier subclass: #ExtractAsParameterApplier - instanceVariableNames: 'interval intervals ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractAsParameterApplier category: #'Tools-Refactoring' stamp: 'Install-4886-ExtractAsParameterMultiOcurrences-HernanWilkinson-2021Sep24-17h18m-HAW.001.cs.st 10/14/2021 14:32:40'! -AddParameterApplier subclass: #ExtractAsParameterApplier - instanceVariableNames: 'interval intervals' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! -!ExtractAsParameter methodsFor: 'applying - private' stamp: 'HAW 9/24/2021 17:52:51'! - newSourceCode: anIntervalToReplace from: sourceCode originalSize: originalSourceCodeSize - - | newInterval newSourceCode | - - newInterval := anIntervalToReplace + (sourceCode size - originalSourceCodeSize). - newSourceCode := sourceCode copyReplaceFrom: newInterval first to: newInterval last with: addParameter newParameter. - - ^newSourceCode ! ! -!ExtractAsParameter methodsFor: 'initialization' stamp: 'HAW 9/24/2021 17:31:51'! - initializeReplacingAll: allIntervals at: aSourceMethod addingParameterWith: anAddParameter - - intervals := allIntervals. - sourceMethod := aSourceMethod. - addParameter := anAddParameter.! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/24/2021 20:18:37'! - assertAndCreateNamed: aNewParameter - extractedFromAll: allIntervals - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - creatingAddParameterWith: addParameterCreator - - | addParameter sourceCodeToExtract trimmedIntervalToReplace intervals | - - self assert: aSourceMethod isInImplementors: implementorsCollection. - intervals := self assertCanExtractedFromAll: allIntervals for: aSourceMethod. - - trimmedIntervalToReplace := intervals first second. - sourceCodeToExtract := aSourceMethod sourceCode copyFrom: trimmedIntervalToReplace first to: trimmedIntervalToReplace last. - - addParameter := addParameterCreator value: sourceCodeToExtract. - - ^self new - initializeReplacingAll: (intervals collect: [ :both | both first ]) - at: aSourceMethod - addingParameterWith: addParameter! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/24/2021 18:07:32'! - assertCanExtractFrom: anInterval for: sourceCode methodNode: methodNode last: lastIntervalsAndNode - - | trimmedIntervalToReplace node intervalToReplace | - - ExtractMethodNewMethod assertIntervalToExtractIsNotEmpty: anInterval. - ExtractMethodNewMethod assert: anInterval isWithinBoundsOf: sourceCode. - - intervalToReplace := self removeDotsAt: anInterval in: sourceCode. - trimmedIntervalToReplace := intervalToReplace asSourceCodeInterval trimToMatchExpressionOn: sourceCode. - node := self nodeToExtractFrom: methodNode at: trimmedIntervalToReplace or: intervalToReplace. - self assertIsValidToExtract: node. - lastIntervalsAndNode ifNotNil: [ self assertIsSameExpressionToExtractFrom: node to: lastIntervalsAndNode third ]. - - ^{ intervalToReplace. trimmedIntervalToReplace. node }! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/24/2021 18:17:03'! - assertCanExtractedFromAll: allIntervals for: aSourceMethod - - | sourceCode methodNode lastIntervalsAndNode | - - allIntervals isEmpty ifTrue: [ self signalNoExpressionToExtract ]. - - sourceCode := aSourceMethod sourceCode. - methodNode := aSourceMethod methodNode. - lastIntervalsAndNode := nil. - - ^allIntervals collect: [ :anInterval | - lastIntervalsAndNode := self - assertCanExtractFrom: anInterval - for: sourceCode - methodNode: methodNode - last: lastIntervalsAndNode ] ! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/24/2021 20:19:16'! - assertIsSameExpressionToExtractFrom: node to: lastNode - - (node = lastNode or: [ node equivalentTo: lastNode ]) ifFalse: [ - self signalNotAllExpressionsToExtractAreEqual ]! ! -!ExtractAsParameter class methodsFor: 'instance creation' stamp: 'HAW 9/24/2021 17:23:26'! - named: aNewParameter - extractedFromAll: intervals - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - - ^self - assertAndCreateNamed: aNewParameter - extractedFromAll: intervals - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - creatingAddParameterWith: [ :sourceCodeToExtract | - AddParameter - named: aNewParameter - initializedWith: sourceCodeToExtract - toUnarySelector: aSourceMethod selector - implementors: implementorsCollection - senders: sendersCollection ]! ! -!ExtractAsParameter class methodsFor: 'instance creation' stamp: 'HAW 9/24/2021 17:23:26'! - named: aNewParameter - extractedFromAll: intervals - at: aNewKeywordIndex - newKeyword: newKeyword - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - - ^self - assertAndCreateNamed: aNewParameter - extractedFromAll: intervals - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - creatingAddParameterWith: [ :sourceCodeToExtract | - AddParameter - named: aNewParameter - at: aNewKeywordIndex - initializedWith: sourceCodeToExtract - using: newKeyword - toKeywordSelector: aSourceMethod selector - implementors: implementorsCollection - senders: sendersCollection ]! ! -!ExtractAsParameter class methodsFor: 'error messages' stamp: 'HAW 9/24/2021 18:15:58'! - errorMessageForNoExpressionToExtract - - ^'No expression to extract'! ! -!ExtractAsParameter class methodsFor: 'error messages' stamp: 'HAW 9/24/2021 17:58:54'! - errorMessageNotAllExpressionsToExtractAreEqual - - ^'Expressions to extract are not equal'! ! -!ExtractAsParameter class methodsFor: 'exceptions' stamp: 'HAW 9/24/2021 18:17:30'! - signalNoExpressionToExtract - - self refactoringError: self errorMessageForNoExpressionToExtract ! ! -!ExtractAsParameter class methodsFor: 'exceptions' stamp: 'HAW 9/24/2021 18:07:12'! - signalNotAllExpressionsToExtractAreEqual - - self refactoringError: self errorMessageNotAllExpressionsToExtractAreEqual! ! -!ExtractAsParameter class methodsFor: 'intervals' stamp: 'HAW 9/24/2021 20:23:08'! - intervalsForEquivalentExpressionIn: method at: interval - - | methodNode node sourceCode trimmedIntervalToReplace rangeOrRanges | - - sourceCode := method sourceCode. - methodNode := method methodNode. - trimmedIntervalToReplace := interval asSourceCodeInterval trimToMatchExpressionOn: sourceCode. - node := self nodeToExtractFrom: methodNode at: trimmedIntervalToReplace or: interval. - - rangeOrRanges := methodNode rangeForNode: node ifAbsent: [ self shouldNotHappenBecause: 'node already exist' ]. - ^(methodNode isMultipleRanges: rangeOrRanges) - ifTrue: [ rangeOrRanges ] - ifFalse: [ self intervalsForEquivalentNodesTo: node in: methodNode ] - ! ! -!ExtractAsParameter class methodsFor: 'intervals' stamp: 'HAW 9/24/2021 20:24:05'! -intervalsForEquivalentNodesTo: node in: methodNode - - | completeSourceRanges intervalsForEquivalentNodes | - - intervalsForEquivalentNodes := OrderedCollection new. - completeSourceRanges := methodNode completeSourceRanges. - - methodNode nodesDo: [ :aNode | - (aNode equivalentTo: node) ifTrue: [ - "There can not be more than one range because of the is not a multi range node. See senders - Hernan" - intervalsForEquivalentNodes add: (completeSourceRanges at: aNode) first ]]. - - ^intervalsForEquivalentNodes! ! -!ExtractAsParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 9/24/2021 18:51:07'! - askToReplaceAll - - | extractAll | - - extractAll := PopUpMenu - confirm: 'Do you want to extract all ocurrences?' - trueChoice: 'Yes, extract all ocurrences' - falseChoice: 'No, extract only the selected one'. - - extractAll ifFalse: [ intervals := { interval } ].! ! -!ExtractAsParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 9/24/2021 18:47:00' overrides: 50441879! - requestRefactoringParameters - - intervals size > 1 ifTrue: [ self askToReplaceAll ]. - - super requestRefactoringParameters.! ! -!ExtractAsParameterApplier methodsFor: 'initialization' stamp: 'HAW 9/24/2021 20:22:13'! - initializeIntervals - - intervals := self refactoringClass intervalsForEquivalentExpressionIn: selectedClass >> oldSelector at: interval.! ! -!CodeNode methodsFor: 'private' stamp: 'HAW 9/24/2021 20:01:42' prior: 50506489! - hasEquivalentTemporariesDeclarationWith: aCodeNode - - (self temporariesDeclaration isNil and: [ aCodeNode temporariesDeclaration isNil ]) ifTrue: [ ^true ]. - (self temporariesDeclaration isNil and: [ aCodeNode temporariesDeclaration notNil ]) ifTrue: [ ^false ]. - (self temporariesDeclaration notNil and: [ aCodeNode temporariesDeclaration isNil ]) ifTrue: [ ^false ]. - - ^self temporariesDeclaration equivalentTo: aCodeNode temporariesDeclaration ! ! -!ExtractAsParameter methodsFor: 'applying - private' stamp: 'HAW 9/24/2021 17:54:19' prior: 50610077! - useNewParameter - - | newSourceCodeWithAllReplacements originalSourceCodeSize | - - originalSourceCodeSize := sourceMethod sourceCode size. - newSourceCodeWithAllReplacements := intervals - inject: (sourceMethod methodClass >> self newSelector) sourceCode - into: [ :newSourceCode :intervalToReplace | self newSourceCode: intervalToReplace from: newSourceCode originalSize: originalSourceCodeSize ]. - - sourceMethod methodClass compile: newSourceCodeWithAllReplacements! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 9/24/2021 17:42:58' prior: 50610251! -nodeToExtractFrom: methodNode at: trimmedIntervalToReplace or: intervalToReplace - - | nodeWithRangeToExtract nodesWithFirstPosition | - - nodesWithFirstPosition := methodNode parseNodesPathAt: trimmedIntervalToReplace first ifAbsent: [ self signalInvalidSelection ]. - nodeWithRangeToExtract := nodesWithFirstPosition - detect: [ :nodeAndRange | self is: nodeAndRange value equalTo: trimmedIntervalToReplace or: intervalToReplace ] - ifNone: [ self signalInvalidSelection ]. - - ^nodeWithRangeToExtract key. - ! ! -!ExtractAsParameter class methodsFor: 'instance creation' stamp: 'HAW 9/24/2021 17:22:20' prior: 50610282! - named: aNewParameter - extractedFrom: anInterval - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - - ^self - named: aNewParameter - extractedFromAll: { anInterval } - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection ! ! -!ExtractAsParameter class methodsFor: 'instance creation' stamp: 'HAW 9/24/2021 17:24:05' prior: 50610303! - named: aNewParameter - extractedFrom: anInterval - at: aNewKeywordIndex - newKeyword: newKeyword - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - - ^self - named: aNewParameter - extractedFromAll: { anInterval } - at: aNewKeywordIndex - newKeyword: newKeyword - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection ! ! -!ExtractAsParameterApplier methodsFor: 'refactoring - creation' stamp: 'HAW 9/24/2021 18:51:16' prior: 50610460 overrides: 50441788! - createRefactoringForKeywordSelector - - ^self refactoringClass - named: newParameter - extractedFromAll: intervals - at: parameterIndex - newKeyword: newKeyword - at: selectedClass >> oldSelector - implementors: implementors - senders: senders ! ! -!ExtractAsParameterApplier methodsFor: 'refactoring - creation' stamp: 'HAW 9/24/2021 18:51:25' prior: 50610472 overrides: 50441799! - createRefactoringForUnarySelector - - ^self refactoringClass - named: newParameter - extractedFromAll: intervals - at: selectedClass >> oldSelector - implementors: implementors - senders: senders ! ! -!ExtractAsParameterApplier methodsFor: 'initialization' stamp: 'HAW 9/24/2021 18:27:27' prior: 50610487! - initializeInterval: anInterval - - interval := anInterval. - - self initializeIntervals.! ! -!ExtractAsParameterApplier class methodsFor: 'instance creation' stamp: 'HAW 9/24/2021 17:40:01' prior: 50610492! - from: anInterval on: aModel for: anOldSelector in: aClassToRefactor - - ExtractAsParameter assertCanExtractedFromAll: { anInterval } for: aClassToRefactor >> anOldSelector. - - ^(super on: aModel for: anOldSelector in: aClassToRefactor) initializeInterval: anInterval ! ! - -ExtractAsParameterApplier removeSelector: #intervalsForEquivalentNodesTo:in:! - -ExtractAsParameterApplier removeSelector: #initializeIntervalsLookingForSameExpressionAt:to:! - -ExtractAsParameter class removeSelector: #assertCanExtractedFrom:for:! - -!methodRemoval: ExtractAsParameter class #assertCanExtractedFrom:for: stamp: 'Install-4886-ExtractAsParameterMultiOcurrences-HernanWilkinson-2021Sep24-17h18m-HAW.001.cs.st 10/14/2021 14:32:40'! -assertCanExtractedFrom: anInterval for: aSourceMethod - - | trimmedIntervalToReplace sourceCode node intervalToReplace | - - sourceCode := aSourceMethod sourceCode. - - ExtractMethodNewMethod assertIntervalToExtractIsNotEmpty: anInterval. - ExtractMethodNewMethod assert: anInterval isWithinBoundsOf: sourceCode. - - intervalToReplace := self removeDotsAt: anInterval in: sourceCode. - trimmedIntervalToReplace := intervalToReplace asSourceCodeInterval trimToMatchExpressionOn: sourceCode. - node := self nodeToExtractFrom: aSourceMethod at: trimmedIntervalToReplace or: intervalToReplace. - self assertIsValidToExtract: node. - - ^{ intervalToReplace. trimmedIntervalToReplace } - - ! - -ExtractAsParameter class removeSelector: #assertAndCreateNamed:extractedFrom:at:implementors:senders:creatingAddParameterWith:! - -!methodRemoval: ExtractAsParameter class #assertAndCreateNamed:extractedFrom:at:implementors:senders:creatingAddParameterWith: stamp: 'Install-4886-ExtractAsParameterMultiOcurrences-HernanWilkinson-2021Sep24-17h18m-HAW.001.cs.st 10/14/2021 14:32:40'! -assertAndCreateNamed: aNewParameter - extractedFrom: anInterval - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - creatingAddParameterWith: addParameterCreator - - | addParameter sourceCodeToExtract trimmedIntervalToReplace intervalToReplace intervals | - - self assert: aSourceMethod isInImplementors: implementorsCollection. - intervals := self assertCanExtractedFrom: anInterval for: aSourceMethod. - - intervalToReplace := intervals first. - trimmedIntervalToReplace := intervals second. - sourceCodeToExtract := aSourceMethod sourceCode copyFrom: trimmedIntervalToReplace first to: trimmedIntervalToReplace last. - - addParameter := addParameterCreator value: sourceCodeToExtract. - - ^self new - initializeExtractedFrom: trimmedIntervalToReplace - replacing: intervalToReplace - at: aSourceMethod - addingParameterWith: addParameter! - -ExtractAsParameter class removeSelector: #assertCanExtractFrom:for:methodNode:! - -ExtractAsParameter removeSelector: #newSourceCode:! - -ExtractAsParameter removeSelector: #initializeExtractedFrom:replacingAll:at:addingParameterWith:! - -ExtractAsParameter removeSelector: #newSourceCode! - -!methodRemoval: ExtractAsParameter #newSourceCode stamp: 'Install-4886-ExtractAsParameterMultiOcurrences-HernanWilkinson-2021Sep24-17h18m-HAW.001.cs.st 10/14/2021 14:32:40'! -newSourceCode - - | intermediateSourceCode newInterval newSourceCode originalSourceCodeSize intermediateMethod | - - originalSourceCodeSize := sourceMethod sourceCode size. - intermediateMethod := sourceMethod methodClass >> self newSelector. - intermediateSourceCode := intermediateMethod sourceCode. - newInterval := intervalToReplace + (intermediateSourceCode size - originalSourceCodeSize). - newSourceCode := intermediateSourceCode copyReplaceFrom: newInterval first to: newInterval last with: addParameter newParameter. - - ^newSourceCode ! - -ExtractAsParameter removeSelector: #initializeExtractedFrom:replacing:at:addingParameterWith:! - -!methodRemoval: ExtractAsParameter #initializeExtractedFrom:replacing:at:addingParameterWith: stamp: 'Install-4886-ExtractAsParameterMultiOcurrences-HernanWilkinson-2021Sep24-17h18m-HAW.001.cs.st 10/14/2021 14:32:40'! -initializeExtractedFrom: anIntervalToExtract replacing: anIntervalToReplace at: aSourceMethod addingParameterWith: anAddParameter - - intervalToExtract := anIntervalToExtract. - intervalToReplace := anIntervalToReplace. - sourceMethod := aSourceMethod. - addParameter := anAddParameter.! - -Refactoring subclass: #ExtractAsParameter - instanceVariableNames: 'sourceMethod addParameter intervals' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractAsParameter category: #'Tools-Refactoring' stamp: 'Install-4886-ExtractAsParameterMultiOcurrences-HernanWilkinson-2021Sep24-17h18m-HAW.001.cs.st 10/14/2021 14:32:40'! -Refactoring subclass: #ExtractAsParameter - instanceVariableNames: 'sourceMethod addParameter intervals' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -AddParameterApplier subclass: #ExtractAsParameterApplier - instanceVariableNames: 'interval intervals' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -!classDefinition: #ExtractAsParameterApplier category: #'Tools-Refactoring' stamp: 'Install-4886-ExtractAsParameterMultiOcurrences-HernanWilkinson-2021Sep24-17h18m-HAW.001.cs.st 10/14/2021 14:32:40'! -AddParameterApplier subclass: #ExtractAsParameterApplier - instanceVariableNames: 'interval intervals' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Refactoring'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4886-ExtractAsParameterMultiOcurrences-HernanWilkinson-2021Sep24-17h18m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4879] on 25 September 2021 at 3:39:39 pm'! -!ExtractAsParameterApplier methodsFor: 'refactoring - parameters request' stamp: 'HAW 9/25/2021 15:39:23' prior: 50611412! - askToReplaceAll - - | extractAll | - - extractAll := PopUpMenu - confirm: 'Do you want to extract all occurrences?' - trueChoice: 'Yes, extract all occurrences' - falseChoice: 'No, extract only the selected one'. - - extractAll ifFalse: [ intervals := { interval } ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4887-ExtractAsParameterTypo-HernanWilkinson-2021Sep24-20h40m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4887] on 27 September 2021 at 9:55:42 am'! -!GeometryTransformation methodsFor: 'testing' stamp: 'jmv 9/27/2021 09:52:51'! - isPureMirroring - "Return true if the receiver specifies no translation, rotation or scaling, and just mirrors the Y axis." - - ^ false! ! -!AffineTransformation methodsFor: 'testing' stamp: 'jmv 9/27/2021 09:52:19' overrides: 50611754! - isPureMirroring - "Return true if the receiver specifies no translation, rotation or scaling, and just mirrors the Y axis." - - ^self a11 = 1.0 and: [ self a12 = 0.0 and: [ - self a21 = 0.0 and: [ self a22 = -1.0 and: [ - self a13 = 0.0 and: [ self a23 = 0.0 ]]]]]! ! -!AffineTransformation methodsFor: 'testing' stamp: 'jmv 9/27/2021 09:51:11' prior: 16778544 overrides: 50408213! - isPureTranslation - "Return true if the receiver specifies no rotation or scaling." - - - ^self a11 = 1.0 and: [ self a12 = 0.0 and: [ - self a21 = 0.0 and: [ self a22 = 1.0 ]]]! ! -!MovableMorph methodsFor: 'initialization' stamp: 'jmv 9/27/2021 09:53:27' prior: 50604172 overrides: 50554652! - openInWorld: aWorld - "Add this morph to the requested World." - - location isIdentity - ifTrue: [ "Identity means default location on creation. Not an actual position to honor." - aWorld - addMorph: self - position: (Display width*7//10) atRandom@(Display height*8//10) atRandom ] - ifFalse: [ - location isPureMirroring - ifTrue: [ "But not the identity. Default location on creation if #yAxisPointsUp" - aWorld - addMorph: self - position: (Display width*7//10) atRandom@(Display height*6//10) atRandom + ((Display width //4)@ Display height //3) ] - ifFalse: [ - aWorld addMorph: self ]]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4888-BetterDefaultPositionsForNewMorphs-JuanVuletich-2021Sep27-09h55m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4888] on 27 September 2021 at 11:37:25 am'! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 9/27/2021 11:30:21' prior: 50593696 overrides: 50575625! - morphPosition: aPoint - "Change the position of this morph. Argument is in owner's coordinates." - - | prevTranslation | - prevTranslation _ location translation. - location _ location withTranslation: aPoint. - "Ask if translation effectively changed, after possible conversion to 32 bit Float in AffineTransformation. " - location translation = prevTranslation ifFalse: [ - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ].! ! -!WorldMorph methodsFor: 'drawing' stamp: 'jmv 9/27/2021 11:37:17' prior: 50607691! - displayWorld - "Update this world's display." - - | deferredUpdateVMMode worldDamageRects handsToDraw allDamage | - self checkIfUpdateNeeded ifFalse: [ ^ self ]. "display is already up-to-date" - "I (jmv) removed the call to 'deferUpdates: false' below. No more need to call this every time." - deferredUpdateVMMode _ self tryDeferredUpdatingAndSetCanvas. - - "repair world's damage on canvas" - worldDamageRects _ canvas drawWorld: self repair: damageRecorder. - " - worldDamageRects do: [ :r | Display border: r width: 3 fillColor: Color random ]. 'Debugging Aid'. - " - - "Check which hands need to be drawn (they are not the hardware mouse pointer)" - handsToDraw _ self selectHandsToDrawForDamage: worldDamageRects. - allDamage _ Array streamContents: [ :strm | - strm nextPutAll: worldDamageRects. - handsToDraw do: [ :h | - h savePatchFrom: canvas appendDamageTo: strm ]]. - - "Draw hands (usually carying morphs) onto world canvas" - canvas newClipRect: nil. - handsToDraw reverseDo: [ :h | canvas fullDrawHand: h ]. - - "quickly copy altered rects of canvas to Display:" - deferredUpdateVMMode ifFalse: [ - "Drawing was done to off-Display canvas. Copy content to Display" - canvas showAt: self viewBox origin invalidRects: allDamage ]. - - "Display deferUpdates: false." - "Display forceDisplayUpdate" - DisplayScreen isDisplayExtentOk ifTrue: [ - Display forceDamageToScreen: allDamage ]. - - "Restore world canvas under hands and their carried morphs" - handsToDraw do: [ :h | h restoreSavedPatchOn: canvas ].! ! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 9/27/2021 11:37:03' prior: 50605430! - doOneCycle - "Do one cycle of the interaction loop. This method is called repeatedly when the world is running. - - Make for low cpu usage if the ui is inactive, but quick response when ui is in use. - However, after some inactivity, there will be a larger delay before the ui gets responsive again." - - | wait waitUntil | - " - 'Debugging Aid'. - Display fill: (15@1515 extent: 200@30) fillColor: Color white. - (Time localMillisecondClock - lastCycleTime) printString displayAt: 20@1520. - Display forceToScreen. - " - waitDelay ifNil: [ waitDelay _ Delay forMilliseconds: 50 ]. - (lastCycleHadAnyEvent or: [ deferredUIMessages isEmpty not ]) - ifTrue: [ - pause _ 20. "This value will only be used later, when there are no more events to serve or deferred UI messages to process." - wait _ 0. "Don't wait this time"] - ifFalse: [ - "wait between 20 and 200 milliseconds" - (hands anySatisfy: [ :h | h waitingForMoreClicks ]) - ifTrue: [ pause _ 20 ] - ifFalse: [ pause < 200 ifTrue: [ pause _ pause * 21//20 ] ]. - waitUntil _ lastCycleTime + pause. - "Earlier if steps" - stepList isEmpty not ifTrue: [ - waitUntil _ waitUntil min: stepList first scheduledTime ]. - "Earlier if alarms" - alarms ifNotNil: [ - alarms isEmpty not ifTrue: [ - waitUntil _ waitUntil min: alarms first scheduledTime ]]. - wait _ waitUntil - Time localMillisecondClock max: 0 ]. - Preferences serverMode - ifTrue: [ wait _ wait max: 50 ]. "Always wait at least a bit on servers, even if this makes the UI slow." - wait = 0 - ifTrue: [ Processor yield ] - ifFalse: [ - waitDelay beingWaitedOn - ifFalse: [ waitDelay setDelay: wait; wait ] - ifTrue: [ - "If we are called from a different process than that of the main UI, we might be called in the main - interCyclePause. In such case, use a new Delay to avoid 'This Delay has already been scheduled' errors" - (Delay forMilliseconds: wait) wait ]]. - - "Record start time of this cycle, and do cycle" - lastCycleTime _ Time localMillisecondClock. - lastCycleHadAnyEvent _ self doOneCycleNow.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4889-AvoidSuperfluousInvalidation-JuanVuletich-2021Sep27-11h32m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4889] on 27 September 2021 at 5:22:48 pm'! -!KernelMorph methodsFor: 'drawing' stamp: 'jmv 9/27/2021 17:20:50' prior: 50609459 overrides: 50607627! -imageForm: extentOrNil depth: depth - - | answerExtent answer auxCanvas | - self requiresVectorCanvas ifFalse: [ - answerExtent _ extent. - extentOrNil ifNotNil: [ answerExtent _ answerExtent min: extentOrNil * 4 ]. - auxCanvas _ MorphicCanvas depth: depth over: (self morphPosition floor extent: answerExtent ceiling). - auxCanvas fullDraw: self. - answer _ auxCanvas form divideByAlpha. - extentOrNil ifNotNil: [ answer _ answer magnifyTo: extentOrNil ]. - ^answer ]. - ^super imageForm: extentOrNil depth: depth.! ! -!WidgetMorph methodsFor: 'drawing' stamp: 'jmv 9/27/2021 17:20:55' prior: 50608135 overrides: 50607627! - imageForm: extentOrNil depth: depth - - | answerExtent answer auxCanvas | - self requiresVectorCanvas ifFalse: [ - answerExtent _ extent. - extentOrNil ifNotNil: [ answerExtent _ answerExtent min: extentOrNil * 4 ]. - auxCanvas _ MorphicCanvas depth: depth over: (self morphPosition floor extent: answerExtent ceiling). - auxCanvas fullDraw: self. - answer _ auxCanvas form divideByAlpha. - extentOrNil ifNotNil: [ answer _ answer magnifyTo: extentOrNil ]. - ^answer ]. - ^super imageForm: extentOrNil depth: depth.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4890-defaultCanvas-for-imageForm-JuanVuletich-2021Sep27-16h48m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4890] on 28 September 2021 at 2:40:47 pm'! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 9/28/2021 12:35:45'! - offAxisHeightFor: aMorph within: availableHeight - "Answer height for a single morph -- offAxis calculation for a Row" - - | availableForPropHeight actualPropHeight | - availableForPropHeight := availableHeight - (2 * self ySeparation). - actualPropHeight := (availableForPropHeight * aMorph layoutSpec proportionalLayoutHeight) - max: aMorph minimumLayoutHeight. - ^ actualPropHeight! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 9/28/2021 12:35:50'! - offAxisWidthFor: aMorph within: availableWidth - "Answer width for a single morph -- offAxis calculation for a Column" - - | availableForPropWidth actualPropWidth | - availableForPropWidth := availableWidth - (2 * self xSeparation). - actualPropWidth := (availableForPropWidth * aMorph layoutSpec proportionalLayoutWidth) - max: aMorph minimumLayoutWidth. - ^ actualPropWidth! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 9/28/2021 12:37:54'! - offAxisXOffsetFor: aMorph within: availableWidth - "Answer x offset for a single morph -- offAxis calculation for a Column" - - | leftOver | - leftOver := availableWidth - (2 * self xSeparation). - ^ self xSeparation - + (leftOver * aMorph layoutSpec offAxisEdgeWeight). "first X, edge shifted"! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 9/28/2021 12:37:57'! - offAxisYOffsetFor: aMorph within: availableHeight - "Answer y offset for a single morph -- offAxis calculation for a Row" - - | leftOver | - leftOver := availableHeight - (2 * self ySeparation). - ^ self ySeparation - + (leftOver * aMorph layoutSpec offAxisEdgeWeight). "first Y, edge shifted"! ! -!LayoutMorph methodsFor: 'accessing' stamp: 'jmv 9/28/2021 12:30:37' prior: 50521411! - axisEdgeWeight - - ^ axisEdgeWeight ifNil: [ - direction == #horizontal - ifTrue: [0.0] - ifFalse: [0.5]]! ! -!LayoutMorph methodsFor: 'initialization' stamp: 'jmv 9/28/2021 12:29:22' prior: 50520088! - beColumn - "Establish the major layout axis, with default edge weight" - - direction _ #vertical. - axisEdgeWeight ifNil: [self axisEdgeWeight: #center]. - self layoutSubmorphs.! ! -!LayoutMorph methodsFor: 'initialization' stamp: 'jmv 9/28/2021 12:29:27' prior: 50520097! - beRow - "Establish the major layout axis, with default edge weight" - - direction _ #horizontal. - axisEdgeWeight ifNil: [self axisEdgeWeight: #rowLeft]. - self layoutSubmorphs.! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 9/28/2021 12:34:38' prior: 50540569! - layoutSubmorphsHorizontallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - - | visibleSubmorphs gap widths - widthToAllocate leftOver x height y | - "Preconditions: self isRow & morphExtent >= minimumLayoutExtent" - (visibleSubmorphs := self submorphsToLayout reversed "Display Order") - ifEmpty: [ ^ self. "Nothing to layout, besides `sum` below, would fail" ]. - - gap := self xSeparation. - widthToAllocate := (boundsForLayout width - ((visibleSubmorphs size + 1) * gap)). - widths := self widthsFor: visibleSubmorphs within: widthToAllocate. - leftOver := widthToAllocate - widths sum. - x := boundsForLayout left - + gap - + (leftOver * self axisEdgeWeight). "first X, edge shifted" - - visibleSubmorphs with: widths do: [ :sm :smWidth | - height := self offAxisHeightFor: sm within: boundsForLayout height. - y _ self offAxisYOffsetFor: sm within: boundsForLayout height - height. - sm morphPosition: x @ (boundsForLayout top + y). - sm morphExtent: smWidth @ height. - x := x + smWidth + gap. - ]! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 9/28/2021 12:34:53' prior: 50540615! - layoutSubmorphsVerticallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - - | visibleSubmorphs gap heights - heightToAllocate leftOver y width x | - "Preconditions: self isRow & morphExtent >= minimumLayoutExtent" - (visibleSubmorphs := self submorphsToLayout reversed "Display Order") - ifEmpty: [ ^ self. "Nothing to layout, besides `sum` below, would fail" ]. - - gap := self ySeparation. - heightToAllocate := (boundsForLayout height - ((visibleSubmorphs size + 1) * gap)). - heights := self heightsFor: visibleSubmorphs within: heightToAllocate. - leftOver := heightToAllocate - heights sum. - y := boundsForLayout top - + gap - + (leftOver * self axisEdgeWeight). "first Y, edge shifted" - - visibleSubmorphs with: heights do: [ :sm :smHeight | - width := self offAxisWidthFor: sm within: boundsForLayout width. - x _ self offAxisXOffsetFor: sm within: boundsForLayout width - width. - sm morphPosition: boundsForLayout left + x @ y. - sm morphExtent: width @ smHeight. - y := y + smHeight + gap. - ]! ! -!LayoutSpec methodsFor: 'accessing' stamp: 'jmv 9/28/2021 12:37:14' prior: 50521669! - offAxisEdgeWeight - ^offAxisEdgeWeight ifNil: [ 0.5 ]! ! - -LayoutMorph removeSelector: #offVerticalMetricFor:withinExtent:! - -!methodRemoval: LayoutMorph #offVerticalMetricFor:withinExtent: stamp: 'Install-4891-Layouts-refactor-JuanVuletich-2021Sep28-14h38m-jmv.002.cs.st 10/14/2021 14:32:40'! -offVerticalMetricFor: aMorph withinExtent: boundsForLayout - "Answer a point: x@width for a single morph -- offAxis calculation for a Column" - - | spec minMorphWidth theSeparation proportionalWidth - availableForPropWidth actualPropWidth - leftOver xPos | - spec := aMorph layoutSpec. - theSeparation := self xSeparation. - minMorphWidth := aMorph minimumLayoutWidth. - availableForPropWidth := (boundsForLayout width) - (2 * theSeparation). - proportionalWidth := spec proportionalLayoutWidth min: 1.0. - actualPropWidth := (availableForPropWidth * proportionalWidth) - max: minMorphWidth. - leftOver := availableForPropWidth - actualPropWidth. - - xPos := boundsForLayout origin x - + theSeparation - + (leftOver * (spec offAxisEdgeWeight ifNil: [0.5])). "first X, edge shifted" - - ^ xPos @ actualPropWidth - ! - -LayoutMorph removeSelector: #offHorizontalMetricFor:withinExtent:! - -!methodRemoval: LayoutMorph #offHorizontalMetricFor:withinExtent: stamp: 'Install-4891-Layouts-refactor-JuanVuletich-2021Sep28-14h38m-jmv.002.cs.st 10/14/2021 14:32:40'! -offHorizontalMetricFor: aMorph withinExtent: boundsForLayout - "Answer a point: height@y for a single morph -- offAxis calculation for a Row" - - | spec minMorphHeight theSeparation proportionalHeight - availableForPropHeight actualPropHeight - leftOver yPos | - spec := aMorph layoutSpec. - theSeparation := self ySeparation. - minMorphHeight := aMorph minimumLayoutHeight. - availableForPropHeight := (boundsForLayout height) - (2 * theSeparation).. - proportionalHeight := spec proportionalLayoutHeight min: 1.0. - actualPropHeight := (availableForPropHeight * proportionalHeight) - max: minMorphHeight. - leftOver := availableForPropHeight - actualPropHeight. - - yPos := boundsForLayout origin y - + theSeparation - + (leftOver * (spec offAxisEdgeWeight ifNil: [0.5])). "first Y, edge shifted" - - ^ actualPropHeight @ yPos - - ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4891-Layouts-refactor-JuanVuletich-2021Sep28-14h38m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4891] on 28 September 2021 at 3:55:27 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 9/28/2021 15:52:47'! - morphExtentInOwner - - ^self fullBoundsInOwner extent! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 9/28/2021 15:31:59'! - fitInto: aRectangle - "Change the position and extent of this morph. Arguments are owner's coordinates. - See inheritance: For general, non resizeable morphs, adjust position and scale." - - self morphPosition: aRectangle origin. - self morphExtentInOwner: aRectangle extent.! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 9/28/2021 15:17:52' overrides: 50612231! - morphExtentInOwner - - ^self externalizeDistance: extent! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 9/28/2021 15:17:17'! - morphExtentInOwner: newExtent - - self morphExtent: (self internalizeDistance: newExtent).! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 9/28/2021 15:21:10'! - morphHeightInOwner: newHeight - - self morphExtentInOwner: self morphExtentInOwner x @ newHeight! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 9/28/2021 15:21:31'! - morphWidthInOwner: newWidth - - self morphExtentInOwner: newWidth @ self morphExtentInOwner y! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 9/28/2021 15:32:02'! - fitInto: aRectangle - "Change the position and extent of this morph. Arguments are owner's coordinates. - See inheritance: For general, non resizeable morphs, adjust position and scale." - - self morphPosition: aRectangle origin. - self morphExtentInOwner: aRectangle extent.! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 9/28/2021 15:25:52' overrides: 50612231! - morphExtentInOwner - - ^self externalizeDistance: extent! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 9/28/2021 15:25:58'! - morphExtentInOwner: newExtent - - self morphExtent: (self internalizeDistance: newExtent).! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 9/28/2021 15:26:21'! - morphHeightInOwner: newHeight - - self morphExtentInOwner: self morphExtentInOwner x @ newHeight! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 9/28/2021 15:26:31'! - morphWidthInOwner: newWidth - - self morphExtentInOwner: newWidth @ self morphExtentInOwner y! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 9/28/2021 15:27:35' prior: 50593708! - morphPosition: newPos extent: newExtent - "Change the position and extent of this morph. Arguments are owner's coordinates." - - self morphPosition: newPos. - self morphExtentInOwner: newExtent.! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 9/28/2021 15:27:28' prior: 50593732! - morphPosition: newPos extent: newExtent - "Change the position and extent of this morph. Arguments are owner's coordinates." - - self morphPosition: newPos. - self morphExtentInOwner: newExtent.! ! -!LayoutMorph methodsFor: 'adjust' stamp: 'jmv 9/28/2021 15:23:25' prior: 50579943! - adjustHorizontallyBy: aLayoutAdjustMorph at: localPoint - | delta l ls r rs lNewWidth rNewWidth i lCurrentWidth rCurrentWidth | - i _ submorphs indexOf: aLayoutAdjustMorph. - ((i = 1) or: [i = self submorphs size]) ifTrue: [ - self inform: 'LayoutAdjustingMorphs require morphs before and after'. - ^self - ]. - l _ self submorphs at: i +1. - ls _ l layoutSpec. - lCurrentWidth _ l morphExtentInOwner x max: 1. "avoid division by zero" - r _ self submorphs at: i - 1. - rs _ r layoutSpec. - rCurrentWidth _ r morphExtentInOwner x max: 1. "avoid division by zero" - delta _ localPoint x - aLayoutAdjustMorph referencePositionInOwner x. - delta _ delta max: l minimumShrinkWidth - lCurrentWidth. - delta _ delta min: rCurrentWidth - r minimumShrinkWidth. - delta = 0 ifTrue: [ ^self ]. - rNewWidth _ rCurrentWidth - delta. - lNewWidth _ lCurrentWidth + delta. - (ls isProportionalWidth and: [ rs isProportionalWidth ]) - ifTrue: [ | leftNewProportion rightNewProportion toDistribute | "If both proportional, update them" - leftNewProportion _ lNewWidth / (lNewWidth + rNewWidth). - rightNewProportion _ 1.0 - leftNewProportion. - toDistribute _ ls proportionalLayoutWidth + rs proportionalLayoutWidth. - ls setProportionalWidth: leftNewProportion * toDistribute. - rs setProportionalWidth: rightNewProportion * toDistribute ] - ifFalse: ["If at least one is fixed, update only the fixed" - ls isProportionalWidth ifFalse: [ - ls fixedOrMorphWidth: lNewWidth ]. - rs isProportionalWidth ifFalse: [ - rs fixedOrMorphWidth: rNewWidth ]]. - self layoutSubmorphs.! ! -!LayoutMorph methodsFor: 'adjust' stamp: 'jmv 9/28/2021 15:23:58' prior: 50579994! - adjustVerticallyBy: aLayoutAdjustMorph at: localPoint - | delta t ts b bs tNewHeight bNewHeight i tCurrentHeight bCurrentHeight | - i _ submorphs indexOf: aLayoutAdjustMorph. - ((i = 1) or: [i = self submorphs size]) ifTrue: [ - self inform: 'LayoutAdjustingMorphs require morphs above and below'. - ^self - ]. t _ self submorphs at: i +1. - ts _ t layoutSpec. - tCurrentHeight _ t morphExtentInOwner y max: 1. "avoid division by zero" - b _ self submorphs at: i - 1. - bs _ b layoutSpec. - bCurrentHeight _ b morphExtentInOwner y max: 1. "avoid division by zero" - delta _ localPoint y - aLayoutAdjustMorph referencePositionInOwner y. - delta _ delta max: t minimumShrinkHeight - tCurrentHeight. - delta _ delta min: bCurrentHeight - b minimumShrinkHeight. - delta = 0 ifTrue: [ ^self ]. - tNewHeight _ tCurrentHeight + delta. - bNewHeight _ bCurrentHeight - delta. - (ts isProportionalHeight and: [ bs isProportionalHeight ]) - ifTrue: [ | bottomNewProportion toDistribute topNewProportion | "If both proportional, update them" - topNewProportion _ tNewHeight / (tNewHeight + bNewHeight). - bottomNewProportion _ 1.0 - topNewProportion. - toDistribute _ ts proportionalLayoutHeight + bs proportionalLayoutHeight. - ts setProportionalHeight: topNewProportion * toDistribute. - bs setProportionalHeight: bottomNewProportion * toDistribute ] - ifFalse: ["If at least one is fixed, update only the fixed" - ts isProportionalHeight ifFalse: [ - ts fixedOrMorphHeight: tNewHeight ]. - bs isProportionalHeight ifFalse: [ - bs fixedOrMorphHeight: bNewHeight ]]. - self layoutSubmorphs! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 9/28/2021 15:43:44' prior: 50612083! - layoutSubmorphsHorizontallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - - | visibleSubmorphs gap widths - widthToAllocate leftOver x height y | - "Preconditions: self isRow & morphExtent >= minimumLayoutExtent" - (visibleSubmorphs := self submorphsToLayout reversed "Display Order") - ifEmpty: [ ^ self. "Nothing to layout, besides `sum` below, would fail" ]. - - gap := self xSeparation. - widthToAllocate := (boundsForLayout width - ((visibleSubmorphs size + 1) * gap)). - widths := self widthsFor: visibleSubmorphs within: widthToAllocate. - leftOver := widthToAllocate - widths sum. - x := boundsForLayout left - + gap - + (leftOver * self axisEdgeWeight). "first X, edge shifted" - - visibleSubmorphs with: widths do: [ :sm :smWidth | - height := self offAxisHeightFor: sm within: boundsForLayout height. - y _ self offAxisYOffsetFor: sm within: boundsForLayout height - height. - sm fitInto: (x @ (boundsForLayout top + y) extent: smWidth @ height). - x := x + smWidth + gap. - ]! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 9/28/2021 15:41:41' prior: 50612118! - layoutSubmorphsVerticallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - - | visibleSubmorphs gap heights - heightToAllocate leftOver y width x | - "Preconditions: self isRow & morphExtent >= minimumLayoutExtent" - (visibleSubmorphs := self submorphsToLayout reversed "Display Order") - ifEmpty: [ ^ self. "Nothing to layout, besides `sum` below, would fail" ]. - - gap := self ySeparation. - heightToAllocate := (boundsForLayout height - ((visibleSubmorphs size + 1) * gap)). - heights := self heightsFor: visibleSubmorphs within: heightToAllocate. - leftOver := heightToAllocate - heights sum. - y := boundsForLayout top - + gap - + (leftOver * self axisEdgeWeight). "first Y, edge shifted" - - visibleSubmorphs with: heights do: [ :sm :smHeight | - width := self offAxisWidthFor: sm within: boundsForLayout width. - x _ self offAxisXOffsetFor: sm within: boundsForLayout width - width. - sm fitInto: (boundsForLayout left + x @ y extent: width @ smHeight). - y := y + smHeight + gap. - ]! ! -!LayoutSpec methodsFor: 'accessing' stamp: 'jmv 9/28/2021 15:19:43' prior: 50513176! - fixedHeight - ^proportionalHeight isNil ifTrue: [fixedHeight ifNil: [morph morphExtentInOwner y]] ifFalse: [ 0 ]! ! -!LayoutSpec methodsFor: 'accessing' stamp: 'jmv 9/28/2021 15:22:19' prior: 50520457! - fixedOrMorphHeight: aNumber - "aNumber is taken as the fixed height to use. - No proportional part." - fixedHeight - ifNotNil: [ fixedHeight _ aNumber ] - ifNil: [ fixedHeight _ aNumber. - morph morphHeightInOwner: aNumber - ]. - proportionalHeight _ nil! ! -!LayoutSpec methodsFor: 'accessing' stamp: 'jmv 9/28/2021 15:22:31' prior: 50520468! - fixedOrMorphWidth: aNumber - "aNumber is taken as the fixed width to use. - No proportional part." - fixedWidth - ifNotNil: [ fixedWidth _ aNumber ] - ifNil: [ fixedWidth _ aNumber. - morph morphWidthInOwner: aNumber ]. - proportionalWidth _ nil! ! -!LayoutSpec methodsFor: 'accessing' stamp: 'jmv 9/28/2021 15:20:04' prior: 50513520! - fixedWidth - ^proportionalWidth isNil ifTrue: [fixedWidth ifNil: [morph morphExtentInOwner x]] ifFalse: [ 0 ]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 9/28/2021 15:19:48' prior: 50500207! - fixedOrMinimumLayoutHeight - ^fixedHeight ifNil: [ morph morphExtentInOwner y ]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 9/28/2021 15:20:00' prior: 50500212! - fixedOrMinimumLayoutWidth - ^fixedWidth ifNil: [ morph morphExtentInOwner x ]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 9/28/2021 15:19:55' prior: 50519743! - minimumSpecHeight - "If fixedHeight is not nil, use it. - If fixdHeight and propostionlHeight are nil, use morphHeight" - - ^ fixedHeight ifNil: [ proportionalHeight ifNotNil: [ 0 ] ifNil: [ morph morphExtentInOwner y ] ]! ! -!LayoutSpec methodsFor: 'layout' stamp: 'jmv 9/28/2021 15:20:08' prior: 50519752! - minimumSpecWidth - "If fixedWidth is not nil, use it. - If fixdWidth and propostionlWidth are nil, use morphWidth" - - ^ fixedWidth ifNil: [ proportionalWidth ifNotNil: [ 0 ] ifNil: [ morph morphExtentInOwner x ] ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4892-Layouts-refactor-JuanVuletich-2021Sep28-15h39m-jmv.003.cs.st----! - -'From Cuis 5.0 [latest update: #4892] on 28 September 2021 at 4:26:44 pm'! -!MovableMorph methodsFor: 'layout-properties' stamp: 'jmv 9/28/2021 16:08:01' prior: 50554526! - layoutSpec: aLayoutSpec - "Layout specific. Set the layout spec describing where the receiver should appear in a proportional layout" - self layoutSpec == aLayoutSpec ifTrue: [ ^self ]. - aLayoutSpec morph: self. - layoutSpec := aLayoutSpec. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]! ! - -WidgetMorph removeSelector: #layoutSpec:! - -!methodRemoval: WidgetMorph #layoutSpec: stamp: 'Install-4893-LayoutSpec-fix-JuanVuletich-2021Sep28-16h08m-jmv.001.cs.st 10/14/2021 14:32:40'! -layoutSpec: aLayoutSpec - "Layout specific. Set the layout spec describing where the receiver should appear in a proportional layout" - self layoutSpec == aLayoutSpec ifTrue: [ ^self ]. - aLayoutSpec morph: self. - layoutSpec := aLayoutSpec. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4893-LayoutSpec-fix-JuanVuletich-2021Sep28-16h08m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4893] on 28 September 2021 at 4:49:34 pm'! -!KernelMorph methodsFor: 'layout-properties' stamp: 'jmv 9/28/2021 16:47:56' overrides: 50554515! - layoutSpec - "Layout specific. Return the layout spec describing where the - receiver should appear in a proportional layout" - - layoutSpec ifNotNil: [ :ls | ^ ls ]. - layoutSpec := LayoutSpec keepMorphExtent. - layoutSpec morph: self. - - ^ layoutSpec! ! -!WidgetMorph methodsFor: 'layout-properties' stamp: 'jmv 9/28/2021 16:48:09' overrides: 50554515! - layoutSpec - "Layout specific. Return the layout spec describing where the - receiver should appear in a proportional layout" - - layoutSpec ifNotNil: [ :ls | ^ ls ]. - layoutSpec := LayoutSpec keepMorphExtent. - layoutSpec morph: self. - - ^ layoutSpec! ! -!MovableMorph methodsFor: 'layout-properties' stamp: 'jmv 9/28/2021 16:48:18' prior: 50554515! - layoutSpec - "Layout specific. Return the layout spec describing where the - receiver should appear in a proportional layout" - - layoutSpec ifNotNil: [ :ls | ^ ls ]. - layoutSpec _ LayoutSpec useAll. - layoutSpec morph: self. - - ^ layoutSpec ! ! - -LayoutMorph removeSelector: #layoutSpec! - -!methodRemoval: LayoutMorph #layoutSpec stamp: 'Install-4894-defaultLayoutSpec-enhancement-JuanVuletich-2021Sep28-16h47m-jmv.001.cs.st 10/14/2021 14:32:40'! -layoutSpec - "Layout specific. Return the layout spec describing where the - receiver should appear in a proportional layout" - - layoutSpec ifNotNil: [ :ls | ^ ls ]. - layoutSpec _ LayoutSpec useAll. - layoutSpec morph: self. - - ^ layoutSpec ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4894-defaultLayoutSpec-enhancement-JuanVuletich-2021Sep28-16h47m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4894] on 29 September 2021 at 5:05:07 pm'! -!LayoutMorph methodsFor: 'layout in owner' stamp: 'jmv 3/3/2016 09:43' overrides: 50612618! - layoutSpec - "Layout specific. Return the layout spec describing where the - receiver should appear in a proportional layout" - - layoutSpec ifNotNil: [ :ls | ^ ls ]. - layoutSpec _ LayoutSpec useAll. - layoutSpec morph: self. - - ^ layoutSpec ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4895-FixBreakageIn4894-JuanVuletich-2021Sep29-17h03m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4895] on 3 October 2021 at 9:16:42 pm'! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 10/3/2021 19:51:20'! - hideHardwareCursor - - | blankCursor | - blankCursor _ Cursor cursorAt: #blankCursor. - Cursor currentCursor == blankCursor ifFalse: [ - blankCursor activateCursor ].! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 10/3/2021 20:58:03'! - savePatchFrom: aCanvas - "Save the part of the given canvas under this hand as a Form and return its bounding rectangle." - - | fullBounds answer | - fullBounds _ self displayFullBoundsForPatch intersect: (`0@0` extent: aCanvas extent). - savedPatch _ aCanvas savePatch: savedPatch bounds: fullBounds. - answer _ fullBounds. - prevFullBounds ifNotNil: [ answer _ answer quickMerge: prevFullBounds ]. - prevFullBounds _ fullBounds. - ^answer! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 10/3/2021 20:22:25'! - showHardwareCursor - - "Make the transition to using hardware cursor. - Report one final damage rectangle to erase the image of the software cursor." - Cursor currentCursor == (Cursor cursorAt: #blankCursor) ifTrue: [ - "show hardware cursor" - Cursor defaultCursor activateCursor. - self invalidateDisplayRect: self basicDisplayBounds for: nil ].! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 10/3/2021 20:42:10' overrides: 50611817! - morphPosition: aPoint - "Change the position of this morph. Argument is in owner's coordinates." - - | prevTranslation | - prevTranslation _ location translation. - location _ location withTranslation: aPoint. - "Ask if translation effectively changed, after possible conversion to 32 bit Float in AffineTransformation. " - location translation = prevTranslation ifFalse: [ - self isDrawnBySoftware ifTrue: [ - self needsRedraw: true ]].! ! -!WorldMorph methodsFor: 'hands' stamp: 'jmv 10/3/2021 21:09:56'! - handsToDrawForDamage: damageList do: aBlock - "Select the set of hands that must be redrawn because either (a) the hand itself has changed or (b) the hand intersects some damage rectangle." - - hands do: [: hand | - hand isDrawnBySoftware ifTrue: [ - hand isRedrawNeeded - ifTrue: [aBlock value: hand] - ifFalse: [ - hand displayFullBounds ifNotNil: [ :handBounds | - (damageList anySatisfy: [ :r | r intersects: handBounds]) ifTrue: [ - aBlock value: hand]]]]].! ! -!MorphicCanvas methodsFor: 'other' stamp: 'jmv 10/3/2021 21:03:48'! - showAt: pt invalidRect: updateRect - | blt | - blt _ (BitBlt toForm: Display) - sourceForm: form; - combinationRule: Form over. - blt sourceRect: updateRect; - destOrigin: updateRect topLeft + pt; - copyBits! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 10/3/2021 20:21:06' prior: 50605350! - isDrawnBySoftware - "Return true if this hand must be drawn explicitely instead of being drawn via the hardware cursor. - Note. We draw the hand as a regular morph (using #drawOn:), disabling the hardware cursor, when we carry submorphs. The reason is to lock the mouse pointer and the carried morph together. Otherwhise the carried morph would lag behind the mouse pointer. - This method answers whether the regular #drawOn: drawing mechanism is used for us. - - Check senders. Hand drawing is handled explicitly by the world, because the Hand is not a submorph of the world!!" - - ^ submorphs anySatisfy: [ :ea | ea visible ]! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 10/3/2021 20:28:53' prior: 50591963! - restoreSavedPatchOn: aCanvas - "Clear the changed flag and restore the part of the given canvas under this hand from the previously saved patch." - - prevFullBounds ifNotNil: [ - aCanvas restorePatch: savedPatch bounds: prevFullBounds. - submorphs isEmpty ifTrue: [ - prevFullBounds _ nil ]].! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 10/3/2021 20:22:19' prior: 16852041! - dropMorphs: anEvent - "Drop the morphs at the hands position" - - self submorphsReverseDo: [ :m | - "Drop back to front to maintain z-order" - self dropMorph: m event: anEvent ]. - self showHardwareCursor.! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 10/3/2021 19:50:49' prior: 50593779! - grabMorph: aMorph moveUnderHand: moveUnderHand - "Grab the given morph (i.e., add it to this hand and remove it from its current owner). - If moveUnderHand is requested or it seems neccesary anyway, move the grabbed morph under the hand." - - | grabbed positionInHandCoordinates tx bounds | - self hideHardwareCursor. - self releaseMouseFocus. "Break focus" - grabbed _ aMorph. - aMorph owner ifNotNil: [ :o | grabbed _ o aboutToGrab: aMorph ]. - grabbed ifNil: [ ^ self ]. - grabbed _ grabbed aboutToBeGrabbedBy: self. - grabbed ifNil: [ ^ self ]. - - moveUnderHand ifTrue: [ - bounds _ nil. - grabbed isInWorld ifTrue: [ - grabbed displayBounds ifNotNil: [ :r | - bounds _ r translatedBy: grabbed morphPositionInWorld negated ]]. - bounds ifNil: [ bounds _ grabbed findFullBoundsInOwner ]. - positionInHandCoordinates _ (bounds center + bounds bottomRight //2) negated. - self grabMorph: grabbed delta: positionInHandCoordinates. - ^self ]. - - positionInHandCoordinates _ (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) - morphPositionInWorld - self morphPositionInWorld. - - tx _ GeometryTransformation identity. - (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) withAllOwnersDo: [ :o | - tx _ o location composedWith: tx ]. - self withAllOwnersReverseDo: [ :o | - tx _ o location inverseTransformation composedWith: tx ]. - self grabMorph: grabbed delta: positionInHandCoordinates. - - grabbed location: tx.! ! -!WorldMorph methodsFor: 'drawing' stamp: 'jmv 10/3/2021 21:12:11' prior: 50611834! - displayWorld - "Update this world's display." - - | deferredUpdateVMMode worldDamageRects allDamage | - self checkIfUpdateNeeded ifFalse: [ ^ self ]. "display is already up-to-date" - - "I (jmv) removed the call to 'deferUpdates: false' below. No more need to call this every time. ?? revisar." - deferredUpdateVMMode _ self tryDeferredUpdatingAndSetCanvas. - - "Restore world canvas under hands and their carried morphs" - hands do: [ :h | h restoreSavedPatchOn: canvas ]. - - "repair world's damage on canvas" - worldDamageRects _ canvas drawWorld: self repair: damageRecorder. - "worldDamageRects do: [ :r | Display border: r width: 3 fillColor: Color random ]. 'Debugging Aid'." - allDamage _ Rectangle merging: worldDamageRects. - canvas newClipRect: nil. - - "Check which hands need to be drawn. - (they are not the hardware mouse pointer and carry morphs)" - self handsToDrawForDamage: worldDamageRects do: [ :h | - allDamage _ (h savePatchFrom: canvas) quickMerge: allDamage. - canvas fullDrawHand: h . - h needsRedraw: false ]. - - "quickly copy altered rects of canvas to Display:" - deferredUpdateVMMode ifFalse: [ - "Drawing was done to off-Display canvas. Copy content to Display" - canvas showAt: self viewBox origin invalidRect: allDamage ]. - - "Display deferUpdates: false." - "Display forceDisplayUpdate" - allDamage ifNotNil: [ - DisplayScreen isDisplayExtentOk ifTrue: [ - Display forceToScreen: allDamage ]].! ! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 10/3/2021 19:28:36' prior: 50595338! - displayBoundsForHand: aHand - - ^ aHand morphPosition asIntegerPoint - 8 extent: aHand morphExtent.! ! - -MorphicCanvas removeSelector: #showAt:invalidRects:! - -!methodRemoval: MorphicCanvas #showAt:invalidRects: stamp: 'Install-4896-HandWithMorph-invalidation-Fixes-JuanVuletich-2021Oct03-21h14m-jmv.001.cs.st 10/14/2021 14:32:40'! -showAt: pt invalidRects: updateRects - | blt | - blt _ (BitBlt toForm: Display) - sourceForm: form; - combinationRule: Form over. - updateRects do: - [:rect | - blt sourceRect: rect; - destOrigin: rect topLeft + pt; - copyBits]! - -WorldMorph removeSelector: #selectHandsToDrawForDamage:! - -!methodRemoval: WorldMorph #selectHandsToDrawForDamage: stamp: 'Install-4896-HandWithMorph-invalidation-Fixes-JuanVuletich-2021Oct03-21h14m-jmv.001.cs.st 10/14/2021 14:32:40'! -selectHandsToDrawForDamage: damageList - "Select the set of hands that must be redrawn because either (a) the hand itself has changed or (b) the hand intersects some damage rectangle." - - | result | - result _ OrderedCollection new. - hands do: [:hand | - hand isDrawnBySoftware ifTrue: [ - hand isRedrawNeeded - ifTrue: [result add: hand] - ifFalse: [ - hand displayFullBounds ifNotNil: [ :handBounds | - (damageList anySatisfy: [ :r | r intersects: handBounds]) ifTrue: [ - result add: hand]]]]]. - ^ result! - -HandMorph removeSelector: #savePatchFrom:appendDamageTo:! - -!methodRemoval: HandMorph #savePatchFrom:appendDamageTo: stamp: 'Install-4896-HandWithMorph-invalidation-Fixes-JuanVuletich-2021Oct03-21h14m-jmv.001.cs.st 10/14/2021 14:32:40'! -savePatchFrom: aCanvas appendDamageTo: aStream - "Save the part of the given canvas under this hand as a Form and return its bounding rectangle." - - | fullBounds | - fullBounds _ self displayFullBoundsForPatch intersect: (`0@0` extent: aCanvas extent). - savedPatch _ aCanvas savePatch: savedPatch bounds: fullBounds. - prevFullBounds _ fullBounds. - aStream nextPut: fullBounds.! - -DisplayScreen removeSelector: #forceDamageToScreen:! - -!methodRemoval: DisplayScreen #forceDamageToScreen: stamp: 'Install-4896-HandWithMorph-invalidation-Fixes-JuanVuletich-2021Oct03-21h14m-jmv.001.cs.st 10/14/2021 14:32:40'! -forceDamageToScreen: allDamage - "Force all the damage rects to the screen." - - "allDamage do: [ :r | - self forceToScreen: r ]." - "Do it at once. Otherwise, some flicking with 'broken' morphs was visible." - (Rectangle merging: allDamage) ifNotNil: [ :r | - self forceToScreen: r ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4896-HandWithMorph-invalidation-Fixes-JuanVuletich-2021Oct03-21h14m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4896] on 4 October 2021 at 9:41:13 am'! -!Preferences class methodsFor: 'misc' stamp: 'jmv 10/4/2021 09:35:45'! - cacheDisplayContentWhenMovingMorphs - "Set to false to save buffer memory, at the cost of redrawing morphs belo hand each time." - - ^ self - valueOfFlag: #cacheDisplayContentWhenMovingMorphs - ifAbsent: [ true ].! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 10/4/2021 09:27:57' prior: 50612716 overrides: 50611817! - morphPosition: aPoint - "Change the position of this morph. Argument is in owner's coordinates." - - | prevTranslation | - prevTranslation _ location translation. - location _ location withTranslation: aPoint. - "Ask if translation effectively changed, after possible conversion to 32 bit Float in AffineTransformation. " - location translation = prevTranslation ifFalse: [ - self isDrawnBySoftware ifTrue: [ - Preferences cacheDisplayContentWhenMovingMorphs - ifTrue: [ self needsRedraw: true ] - ifFalse: [self redrawNeeded ]]].! ! -!WorldMorph methodsFor: 'drawing' stamp: 'jmv 10/4/2021 09:40:33' prior: 50612853! - displayWorld - "Update this world's display." - - | deferredUpdateVMMode worldDamageRects allDamage | - self checkIfUpdateNeeded ifFalse: [ ^ self ]. "display is already up-to-date" - - "I (jmv) removed the call to 'deferUpdates: false' below. No more need to call this every time. ?? revisar." - deferredUpdateVMMode _ self tryDeferredUpdatingAndSetCanvas. - - "Restore world canvas under hands and their carried morphs" - Preferences cacheDisplayContentWhenMovingMorphs ifTrue: [ - hands do: [ :h | h restoreSavedPatchOn: canvas ]]. - - "repair world's damage on canvas" - worldDamageRects _ canvas drawWorld: self repair: damageRecorder. - "worldDamageRects do: [ :r | Display border: r width: 3 fillColor: Color random ]. 'Debugging Aid'." - allDamage _ Rectangle merging: worldDamageRects. - canvas newClipRect: nil. - - "Check which hands need to be drawn. - (they are not the hardware mouse pointer and carry morphs)" - self handsToDrawForDamage: worldDamageRects do: [ :h | - Preferences cacheDisplayContentWhenMovingMorphs - ifTrue: [ allDamage _ (h savePatchFrom: canvas) quickMerge: allDamage ] - ifFalse: [ allDamage _ h displayFullBoundsForPatch quickMerge: allDamage ]. - canvas fullDrawHand: h . - h needsRedraw: false ]. - - "quickly copy altered rects of canvas to Display:" - deferredUpdateVMMode ifFalse: [ - "Drawing was done to off-Display canvas. Copy content to Display" - canvas showAt: self viewBox origin invalidRect: allDamage ]. - - "Display deferUpdates: false." - "Display forceDisplayUpdate" - allDamage ifNotNil: [ - DisplayScreen isDisplayExtentOk ifTrue: [ - Display forceToScreen: allDamage ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4897-Preference-cacheDisplayContentWhenMovingMorphs-JuanVuletich-2021Oct04-09h39m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4897] on 6 October 2021 at 4:54:10 pm'! -!Morph methodsFor: 'drawing' stamp: 'jmv 10/4/2021 16:05:27'! - fullyCovers: aRectangle - "Answer whether our drawing completely covers aRectangle. Answer true only if we are certain" - - | answer | - answer _ true. - self on: aRectangle - ifCovered: [] - uncoveredPartsDo: [ :r | answer _ false ] - else: [ answer _ false ]. - ^answer! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 10/4/2021 11:17:41'! - on: aRectangle ifCovered: partiallyOrTotallyCoveredBlock uncoveredPartsDo: uncoveredPartBlock else: notCoveredAtAllBlock - "Find rectangles encompassing those areas in aRectangle not completely - covered by self. These are the areas that might require further drawing (of morphs below us) - All areas that might possibly be uncovered must be included. - - If aRectangle is not covered at all, or for whatever reason we don't know, evaluate notCoveredAtAllBlock. - Othewise evaluate partiallyOrTotallyCoveredBlock once, and also evaluate uncoveredPartBlock for each part in aRectangle we don't cover." - - ^ notCoveredAtAllBlock value! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 10/4/2021 14:34:32' overrides: 50613090! - on: aRectangle ifCovered: partiallyOrTotallyCoveredBlock uncoveredPartsDo: uncoveredPartBlock else: notCoveredAtAllBlock - "Find rectangles encompassing those areas in aRectangle not completely - covered by self. These are the areas that might require further drawing (of morphs below us) - All areas that might possibly be uncovered must be included. - - If aRectangle is not covered at all, or for whatever reason we don't know, evaluate notCoveredAtAllBlock. - Othewise evaluate partiallyOrTotallyCoveredBlock once, and also evaluate uncoveredPartBlock for each part in aRectangle we don't cover." - -" -ver si hacer como -addPossiblyUncoveredAreasIn: aRectangle to: aCollection -que ademas vuela." - - | bounds r e r2 | - self isOrAnyOwnerIsRotated ifTrue: [ - ^ notCoveredAtAllBlock value ]. - - color mightBeTranslucent ifTrue: [ - ^ notCoveredAtAllBlock value ]. - - bounds _ self displayBounds. - bounds ifNil: [ - ^ notCoveredAtAllBlock value ]. - - (aRectangle intersects: bounds) ifFalse: [ - ^ notCoveredAtAllBlock value ]. - - "Solid rectangle. - This will be the fastest in many cases. So, please disable rounded corners if on slow hardware!!" - partiallyOrTotallyCoveredBlock value. - aRectangle areasOutside: bounds do: [ :rect | uncoveredPartBlock value: rect ]. - - Theme current roundWindowCorners ifTrue: [ - r _ Theme current roundedWindowRadius. - e _ r@r. - r2 _ aRectangle intersect: (bounds topLeft extent: e). - r2 hasPositiveExtent ifTrue: [ uncoveredPartBlock value: r2 ]. - r2 _ aRectangle intersect: (bounds topRight - (r@0) extent: e). - r2 hasPositiveExtent ifTrue: [ uncoveredPartBlock value: r2 ]. - r2 _ aRectangle intersect: (bounds bottomLeft - (0@r)extent: e). - r2 hasPositiveExtent ifTrue: [ uncoveredPartBlock value: r2 ]. - r2 _ aRectangle intersect: (bounds bottomRight - (r@r) extent: e). - r2 hasPositiveExtent ifTrue: [ uncoveredPartBlock value: r2 ]. - ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/6/2021 16:50:48'! - drawWorld: aWorldMorph rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage backgroundDamage: newDamageFromMorphsBelow - "Redraw the damaged areas. - Draw each morph just once, merging rectanges to be repaired as needed." - - | morph morphDamage allDamage | - "Iterate from back to front." - allDamage _ Rectangle merging: newDamageFromMorphsBelow. - rootMorphs size to: 1 by: -1 do: [ :i | - morph _ rootMorphs at: i. - morphDamage _ rootMorphsDamage at: i. - morph displayFullBounds ifNotNil: [ :morphFullBounds | - newDamageFromMorphsBelow do: [ :r | | intersection | - intersection _ r intersect: morphFullBounds. - intersection hasPositiveExtent ifTrue: [ - morphDamage - ifNil: [ morphDamage _ intersection ] - ifNotNil: [ morphDamage updateMerging: intersection ]]]]. - morphDamage ifNotNil: [ - self newClipRect: morphDamage. - self fullDraw: morph. - newDamageFromMorphsBelow add: morphDamage. - allDamage _ allDamage - ifNil: [ morphDamage ] - ifNotNil: [ morphDamage updateMerging: allDamage ]]]. - ^allDamage! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 10/4/2021 19:56:07' prior: 50592004! - displayFullBoundsForPatch - "Current full bounds of hand and carried submorphs. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around). - Integer pixel coordinates!!" - - | handBounds fullBounds | - handBounds _ self displayBounds. - fullBounds _ handBounds copy. - self submorphsDo: [ :m | - fullBounds updateMerging: m displayFullBounds]. - lastPosition - ifNotNil: [ :lastPos | "When already carrying morphs around. Update rectangle to current hand position." - fullBounds _ (fullBounds translatedBy: self morphPosition-lastPos) updateMerging: handBounds ]. - ^fullBounds encompassingIntegerRectangle outsetBy: 1! ! -!WorldMorph methodsFor: 'drawing' stamp: 'jmv 10/4/2021 16:25:37' prior: 50613018! - displayWorld - "Update this world's display." - - | deferredUpdateVMMode allDamage | - self checkIfUpdateNeeded ifFalse: [ ^ self ]. "display is already up-to-date" - - "I (jmv) removed the call to 'deferUpdates: false' below. No more need to call this every time. ?? revisar." - deferredUpdateVMMode _ self tryDeferredUpdatingAndSetCanvas. - - "Restore world canvas under hands and their carried morphs" - Preferences cacheDisplayContentWhenMovingMorphs ifTrue: [ - hands do: [ :h | h restoreSavedPatchOn: canvas ]]. - - "repair world's damage on canvas" - allDamage _ canvas drawWorld: self repair: damageRecorder. - "allDamage ifNotNil: [Display border: allDamage width: 3 fillColor: Color random]. 'Debugging Aid'." - canvas newClipRect: nil. - - "Check which hands need to be drawn. - (they are not the hardware mouse pointer and carry morphs)" - self handsToDrawForDamage: allDamage do: [ :h | - Preferences cacheDisplayContentWhenMovingMorphs - ifTrue: [ allDamage _ (h savePatchFrom: canvas) quickMerge: allDamage ] - ifFalse: [ allDamage _ h displayFullBoundsForPatch quickMerge: allDamage ]. - canvas fullDrawHand: h . - h needsRedraw: false ]. - - "quickly copy altered rects of canvas to Display:" - deferredUpdateVMMode ifFalse: [ - allDamage ifNotNil: [ - "Drawing was done to off-Display canvas. Copy content to Display" - canvas showAt: self viewBox origin invalidRect: allDamage ]]. - - "Display deferUpdates: false." - "Display forceDisplayUpdate" - allDamage ifNotNil: [ - DisplayScreen isDisplayExtentOk ifTrue: [ - Display forceToScreen: allDamage ]].! ! -!WorldMorph methodsFor: 'hands' stamp: 'jmv 10/4/2021 15:29:27' prior: 50612732! - handsToDrawForDamage: aRectangle do: aBlock - "Select the set of hands that must be redrawn because either (a) the hand itself has changed or (b) the hand intersects some damage rectangle." - - hands do: [: hand | - hand isDrawnBySoftware ifTrue: [ - hand isRedrawNeeded - ifTrue: [aBlock value: hand] - ifFalse: [ - aRectangle ifNotNil: [ - hand displayFullBounds ifNotNil: [ :handBounds | - (aRectangle intersects: handBounds) ifTrue: [ - aBlock value: hand ]]]]]].! ! -!DamageRecorder methodsFor: 'recording' stamp: 'jmv 10/4/2021 10:15:45' prior: 50602381! - damageReportedOther - "Answer damage reported for no specific morph, for morphs that are not visible, and for morphs that are carried by the Hand. - Answer might include nils. Skip them." - | answer possiblyMoreRectsToMerge | - answer _ OrderedCollection new. - self pvtAccessProtect critical: [ - damageByRoot keysAndValuesDo: [ :m :r | - (m visible not or: [m owner isNil or: [m owner is: #HandMorph]]) ifTrue: [ - answer add: r]]. - otherDamage do: [ :r | answer add: r ]. - ]. - possiblyMoreRectsToMerge _ true. - [possiblyMoreRectsToMerge] whileTrue: [ - possiblyMoreRectsToMerge _ false. - answer withIndexDo: [ :r1 :i | - r1 ifNotNil: [ - i+1 to: answer size do: [ :j | | r2 | - r2 _ answer at: j. - r2 ifNotNil: [ - (r1 intersects: r2) ifTrue: [ - r1 updateMerging: r2. - answer at: j put: nil. - possiblyMoreRectsToMerge _ true ]]]]]]. - ^answer! ! -!DamageRecorder methodsFor: 'private' stamp: 'jmv 10/6/2021 16:36:18' prior: 50601880! - pvtInnerRecordInvalidRect: requestedRect for: aRootMorph - "Record the given rectangle in my damage list, a list of rectangular areas of the display that should be redraw on the next display cycle." - | newRect | - newRect _ requestedRect encompassingIntegerRectangle. - newRect == requestedRect ifTrue: [ newRect _ newRect copy ]. - aRootMorph ifNotNil: [ - (damageByRoot at: aRootMorph - ifPresent: [ :r | r updateMerging: newRect] - ifAbsent: [ damageByRoot at: aRootMorph put: newRect ]) ] - ifNil: [otherDamage add: newRect].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/6/2021 16:52:49' prior: 50559563! - computeDamage: aWorldMorph repair: aDamageRecorder rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage - "Iterate front to back while computing damage to actually repair for each morph, and for world background. - Answer uncoveredDamage, the areas where World background needs to be redrawn." - - | uncoveredDamage additionalUncoveredDamage morph morphDamage morphFullBounds | - uncoveredDamage _ aDamageRecorder damageReportedOther. - additionalUncoveredDamage _ OrderedCollection new. - - "Iterate from front to back" - 1 to: rootMorphs size do: [ :i | - morph _ rootMorphs at: i. - morphFullBounds _ morph displayFullBounds. - morphDamage _ nil. - "Reported damage can be ignored if the area fully covered by another morph above us." - (aDamageRecorder damageReportedFor: morph) ifNotNil: [ :r | | wasFullyCovered | - wasFullyCovered _ false. - 1 to: i-1 do: [ :j | - wasFullyCovered _ wasFullyCovered or: [ (rootMorphs at: j) fullyCovers: r ]]. - wasFullyCovered ifFalse: [ - uncoveredDamage add: r ]]. - "Any uncovered damage this morph may overlap must be redrawn by it." - uncoveredDamage do: [ :r | | intersection | - r ifNotNil: [ - intersection _ r intersect: morphFullBounds. - intersection hasPositiveExtent ifTrue: [ - morphDamage - ifNil: [ morphDamage _ intersection ] - ifNotNil: [ morphDamage updateMerging: intersection ]]]]. - rootMorphsDamage at: i put: morphDamage. - "Whatever we cover completely is no longer uncoveredDamage" - uncoveredDamage withIndexDo: [ :r :ri | - r ifNotNil: [ - morph - on: r - ifCovered: [uncoveredDamage at: ri put: nil] - uncoveredPartsDo: [ :r2 | additionalUncoveredDamage add: r2 ] - else: []]]. - uncoveredDamage addAll: additionalUncoveredDamage. - additionalUncoveredDamage removeAll. - ]. - - "Remove redundant rectangles" - 1 to: uncoveredDamage size do: [ :i1 | - (uncoveredDamage at: i1) ifNotNil: [ :r1 | - 1 to: uncoveredDamage size do: [ :i2 | - i1 = i2 ifFalse: [ - (uncoveredDamage at: i2) ifNotNil: [ :r2 | - (r1 containsRect: r2) - ifTrue: [ uncoveredDamage at: i2 put: nil ]]]]]]. - - "Answer any yet uncovered areas. World background should be drawn on them." - ^ uncoveredDamage select: [ :r | r notNil ].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/4/2021 16:29:10' prior: 50601976! - drawWorld: aWorldMorph repair: aDamageRecorder - "Redraw the damaged areas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | visibleRootMorphs visibleRootsDamage worldBackgroundRects | - "Update #displayBounds for all dirty morphs (marked as such with #redrawNeeded). - Also add the updated bounds to aDamageRecorder, and update bounds of morphs carried by hand." - self boundsFinderCanvas updateBoundsIn: aWorldMorph addDamageTo: aDamageRecorder. - - visibleRootMorphs _ aWorldMorph privateSubmorphs select: [ :m | m visible ]. - visibleRootsDamage _ Array new: visibleRootMorphs size. - - worldBackgroundRects _ self computeDamage: aWorldMorph repair: aDamageRecorder - rootMorphs: visibleRootMorphs rootMorphsDamage: visibleRootsDamage. - aDamageRecorder reset. - - self drawWorldBackground: aWorldMorph rects: worldBackgroundRects. - "Debugging aids." - " - worldBackgroundRects do: [ :r | Display fill: r fillColor: Color random . Display forceToScreen. (Delay forSeconds: 0.005) wait]. - "" - visibleRootsDamage do: [ :r | r ifNotNil: [ Display fill: r fillColor: Color random . Display forceToScreen. (Delay forSeconds: 0.05) wait]]. - " - - ^ self drawWorld: aWorldMorph - rootMorphs: visibleRootMorphs rootMorphsDamage: visibleRootsDamage - backgroundDamage: worldBackgroundRects.! ! - -MorphicCanvas removeSelector: #drawWorld:rootMorphs:rootMorphsDamage:allDamage:! - -!methodRemoval: MorphicCanvas #drawWorld:rootMorphs:rootMorphsDamage:allDamage: stamp: 'Install-4898-Morphic-DamageByMorph-Optimization-JuanVuletich-2021Oct06-16h46m-jmv.001.cs.st 10/14/2021 14:32:40'! -drawWorld: aWorldMorph rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage allDamage: worldDamage - "Redraw the damaged areas. - Draw each morph just once, merging rectanges to be repaired as needed." - - | morph morphDamage | - - "Iterate from back to front." - rootMorphs size to: 1 by: -1 do: [ :i | - morph _ rootMorphs at: i. - morphDamage _ rootMorphsDamage at: i. - morph displayFullBounds ifNotNil: [ :morphFullBounds | - worldDamage do: [ :r | | intersection | - intersection _ r intersect: morphFullBounds. - intersection hasPositiveExtent ifTrue: [ - morphDamage _ intersection quickMerge: morphDamage ]]]. - morphDamage ifNotNil: [ - self newClipRect: morphDamage. - self fullDraw: morph. - worldDamage add: morphDamage ]].! - -SystemWindow removeSelector: #addPossiblyUncoveredAreasIn:to:! - -!methodRemoval: SystemWindow #addPossiblyUncoveredAreasIn:to: stamp: 'Install-4898-Morphic-DamageByMorph-Optimization-JuanVuletich-2021Oct06-16h46m-jmv.001.cs.st 10/14/2021 14:32:40'! -addPossiblyUncoveredAreasIn: aRectangle to: aCollection - "Answer an array of rectangles encompassing those areas in aRectangle not completely - covered by self. These are the areas that might require further drawing (of morphs below us) - All areas that might possibly be uncovered must be included." - - | bounds | - self isOrAnyOwnerIsRotated ifTrue: [ - aCollection add: aRectangle. - ^self ]. - - color mightBeTranslucent ifTrue: [ - aCollection add: aRectangle. - ^self ]. - - bounds _ self displayBounds. - bounds ifNil: [ - aCollection add: aRectangle. - ^self ]. - - "Solid rectangle. - This will be the fastest in many cases. So, please disable rounded corners if on slow hardware!!" - Theme current roundWindowCorners ifFalse: [ - aRectangle areasOutside: bounds do: [ :rect | aCollection add: rect ]. - ^self ]. - - "The solid rectangle does not include the corners. - Report a couple of rows (top and bottom) or columns (left and right) as uncovered areas. - We could also try to be more careful and answer each rounded corner... - Right now, report top and bottom rows as uncovered areas: - - Rows are contiguous in Display memory - - Redrawing title area wont trigger redrawing all windows contents." - " - radius _ Theme current roundedWindowRadius. - aRectangle areasOutside: (bounds insetBy: 0@radius) do: [ :rect | aCollection add: rect ]. - " - "Alternative: just include window borders. Almost correct, and cheaper." - aRectangle areasOutside: (bounds insetBy: Theme current windowBorderWidth) do: [ :rect | aCollection add: rect ]. - -"Note: Doing this after the non-rounded-corner case gave bad results. Not letting the size of aCollection grow without bounds is more important than not answering extra areas. - Theme current roundWindowCorners ifTrue: [ - r _ Theme current roundedWindowRadius. - e _ r@r. - aCollection add: (aRectangle intersect: (bounds topLeft extent: e)). - aCollection add: (aRectangle intersect: (bounds topRight - (r@0) extent: e)). - aCollection add: (aRectangle intersect: (bounds bottomLeft - (0@r)extent: e)). - aCollection add: (aRectangle intersect: (bounds bottomRight - (r@r) extent: e)). - ]."! - -Morph removeSelector: #addPossiblyUncoveredAreasIn:to:! - -!methodRemoval: Morph #addPossiblyUncoveredAreasIn:to: stamp: 'Install-4898-Morphic-DamageByMorph-Optimization-JuanVuletich-2021Oct06-16h46m-jmv.001.cs.st 10/14/2021 14:32:40'! -addPossiblyUncoveredAreasIn: aRectangle to: aCollection - "Answer an array of rectangles encompassing those areas in aRectangle not completely - covered by self. - All areas that might possibly be uncovered must be included." - - aCollection add: aRectangle.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4898-Morphic-DamageByMorph-Optimization-JuanVuletich-2021Oct06-16h46m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4898] on 4 October 2021 at 5:26:12 pm'! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 10/4/2021 17:22:34' prior: 50607434! - updateBoundsIn: aWorldMorph addDamageTo: aDamageRecorder - - aWorldMorph haloMorphsDo: [ :halo | - (halo target isRedrawNeeded or: [halo target isSubmorphRedrawNeeded]) ifTrue: [ - "Invalidation of halos requires this specific sequence:" - halo redrawNeeded. "invalidate old halo bounds" - "self fullAddRedrawRect: halo target to: aDamageRecorder." "recompute & invalidate target bounds" - self fullAddRedrawRect: halo to: aDamageRecorder ]]. "recompute & invalidate halo bounds" - "bogus iteration on halos and targets below is harmless: - Both now marked as neither #isRedrawNeeded nor #isSubmorphRedrawNeeded." - - aWorldMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - self updateHandsDisplayBounds: aWorldMorph.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4899-HaloTargetBoundsUpdateFix-JuanVuletich-2021Oct04-17h25m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4895] on 6 October 2021 at 4:02:52 pm'! -!WorldMorph methodsFor: 'update cycle' stamp: 'jmv 10/6/2021 16:02:03' prior: 50611884! - doOneCycle - "Do one cycle of the interaction loop. This method is called repeatedly when the world is running. - - Make for low cpu usage if the ui is inactive, but quick response when ui is in use. - However, after some inactivity, there will be a larger delay before the ui gets responsive again." - - | wait waitUntil | - " - 'Debugging Aid. Declare Delta either as a class variable or as a global variable. Declare delta and r as locals'. - delta _ Time localMillisecondClock - lastCycleTime. - r _ 15@1515 extent: 60@30. - Delta _ Delta ifNil: [ delta ] ifNotNil: [ Delta * 0.9 + (delta * 0.1) ]. - Random next > 0.9 ifTrue: [ - Display fill: r fillColor: Color white. - (Delta printStringFractionDigits: 1) displayAt: 20@1520. - Display forceToScreen: r ]. - " - waitDelay ifNil: [ waitDelay _ Delay forMilliseconds: 50 ]. - (lastCycleHadAnyEvent or: [ deferredUIMessages isEmpty not ]) - ifTrue: [ - pause _ 20. "This value will only be used later, when there are no more events to serve or deferred UI messages to process." - wait _ 0. "Don't wait this time"] - ifFalse: [ - "wait between 20 and 200 milliseconds" - (hands anySatisfy: [ :h | h waitingForMoreClicks ]) - ifTrue: [ pause _ 20 ] - ifFalse: [ pause < 200 ifTrue: [ pause _ pause * 21//20 ] ]. - waitUntil _ lastCycleTime + pause. - "Earlier if steps" - stepList isEmpty not ifTrue: [ - waitUntil _ waitUntil min: stepList first scheduledTime ]. - "Earlier if alarms" - alarms ifNotNil: [ - alarms isEmpty not ifTrue: [ - waitUntil _ waitUntil min: alarms first scheduledTime ]]. - wait _ waitUntil - Time localMillisecondClock max: 0 ]. - Preferences serverMode - ifTrue: [ wait _ wait max: 50 ]. "Always wait at least a bit on servers, even if this makes the UI slow." - wait = 0 - ifTrue: [ Processor yield ] - ifFalse: [ - waitDelay beingWaitedOn - ifFalse: [ waitDelay setDelay: wait; wait ] - ifTrue: [ - "If we are called from a different process than that of the main UI, we might be called in the main - interCyclePause. In such case, use a new Delay to avoid 'This Delay has already been scheduled' errors" - (Delay forMilliseconds: wait) wait ]]. - - "Record start time of this cycle, and do cycle" - lastCycleTime _ Time localMillisecondClock. - lastCycleHadAnyEvent _ self doOneCycleNow.! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 9/29/2021 10:39:57' prior: 50604543! - activeSubclass: aMorphicCanvasSubclass - " - self runningWorld canvas class - MorphicCanvas activeSubclass: BitBltCanvas - MorphicCanvas activeSubclass: HybridCanvas - MorphicCanvas activeSubclass: VectorDrawingCanvas - " - (#(BitBltCanvas HybridCanvas VectorDrawingCanvas) - includes: aMorphicCanvasSubclass name) ifFalse: [ - ^self error: 'Invalid Canvas class' ]. - ActiveSubclass _ aMorphicCanvasSubclass. - UISupervisor ui ifNotNil: [ :world | - world whenUIinSafeState: [ - world setMainCanvas ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4900-DebuggingAids-JuanVuletich-2021Oct06-15h58m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4900] on 8 October 2021 at 9:18:15 am'! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 10/7/2021 12:24:39' prior: 50613113 overrides: 50613090! - on: aRectangle ifCovered: partiallyOrTotallyCoveredBlock uncoveredPartsDo: uncoveredPartBlock else: notCoveredAtAllBlock - "Find rectangles encompassing those areas in aRectangle not completely - covered by self. These are the areas that might require further drawing (of morphs below us) - All areas that might possibly be uncovered must be included. - - If aRectangle is not covered at all, or for whatever reason we don't know, evaluate notCoveredAtAllBlock. - Othewise evaluate partiallyOrTotallyCoveredBlock once, and also evaluate uncoveredPartBlock for each part in aRectangle we don't cover." - - | bounds r e r2 | - self isOrAnyOwnerIsRotated ifTrue: [ - ^ notCoveredAtAllBlock value ]. - - color mightBeTranslucent ifTrue: [ - ^ notCoveredAtAllBlock value ]. - - bounds _ self displayBounds. - bounds ifNil: [ - ^ notCoveredAtAllBlock value ]. - - (aRectangle intersects: bounds) ifFalse: [ - ^ notCoveredAtAllBlock value ]. - - "Solid rectangle. - This will be the fastest in many cases. So, please disable rounded corners if on slow hardware!!" - partiallyOrTotallyCoveredBlock value. - aRectangle areasOutside: bounds do: [ :rect | uncoveredPartBlock value: rect ]. - - Theme current roundWindowCorners ifTrue: [ - r _ Theme current roundedWindowRadius. - e _ r@r. - r2 _ aRectangle intersect: (bounds topLeft extent: e). - r2 hasPositiveExtent ifTrue: [ uncoveredPartBlock value: r2 ]. - r2 _ aRectangle intersect: (bounds topRight - (r@0) extent: e). - r2 hasPositiveExtent ifTrue: [ uncoveredPartBlock value: r2 ]. - r2 _ aRectangle intersect: (bounds bottomLeft - (0@r)extent: e). - r2 hasPositiveExtent ifTrue: [ uncoveredPartBlock value: r2 ]. - r2 _ aRectangle intersect: (bounds bottomRight - (r@r) extent: e). - r2 hasPositiveExtent ifTrue: [ uncoveredPartBlock value: r2 ]. - ].! ! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 10/7/2021 12:23:35' prior: 50613606! - updateBoundsIn: aWorldMorph addDamageTo: aDamageRecorder - - aWorldMorph haloMorphsDo: [ :halo | - (halo target isRedrawNeeded or: [halo target isSubmorphRedrawNeeded]) ifTrue: [ - "Invalidation of halos requires this specific sequence:" - halo redrawNeeded. "invalidate old halo bounds" - self fullAddRedrawRect: halo to: aDamageRecorder ]]. "recompute & invalidate halo bounds" - "bogus iteration on halos below is harmless: - It is now marked as neither #isRedrawNeeded nor #isSubmorphRedrawNeeded." - - aWorldMorph submorphsDo: [ :morph | - self fullAddRedrawRect: morph to: aDamageRecorder ]. - self updateHandsDisplayBounds: aWorldMorph.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4901-tweaks-JuanVuletich-2021Oct08-09h17m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4901] on 7 October 2021 at 4:39:35 pm'! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 10/7/2021 15:41:39' overrides: 50566233! - restorePatch: savedPatch bounds: savedBounds - "Argument must previously be obtained by calling #savePatch:bounds:" - - self - image: savedPatch - at: savedBounds origin - sourceRect: (0@0 extent: savedBounds extent)! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 10/7/2021 15:42:14' overrides: 50566396! - savePatch: prevSavedPatch bounds: aRectangle - "Senders don't need to know any details of what is answered, but just store it for further calls, and calls to restorePatch:bounds:" - "Details: The previously used patch Form is recycled when possible to reduce the burden on storage management." - | savedPatch prevExtent extent | - savedPatch _ prevSavedPatch. - prevExtent _ 0@0. - ((savedPatch is: #Form) and: [ - prevExtent _ savedPatch extent. - prevExtent >= aRectangle extent]) - ifTrue: [ - savedPatch offset: 0@0 ] - ifFalse: [ - "allocate new patch form if needed" - extent _ aRectangle extent max: prevExtent. - extent _ (extent x // 64 + 2 * 64) @ (extent y + 64). "Make it slightly larger, and even width." - savedPatch _ Form extent: extent depth: form depth ]. - [ - engine sourceForm: form; combinationRule: Form over; - sourceX: aRectangle left; sourceY: aRectangle top; - width: aRectangle width; height: aRectangle height; - copyBits. - ] ensure: [ - engine setDestForm: form; sourceForm: nil ]. - ^savedPatch! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 10/7/2021 16:37:05' prior: 50604011! - drawCurrentAsOutline - - currentMorph visible ifTrue: [ - currentMorph displayBoundsSetFrom: self. - self frameReverseGlobalRect: currentMorph displayBounds borderWidth: 2 ].! ! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 10/7/2021 16:37:09' prior: 50575482 overrides: 50565002! - drawCurrentAndSubmorphs - - currentMorph visible ifTrue: [ - - currentMorph drawOn: self. - currentMorph displayBoundsSetFrom: self. - - "Display submorphs back to front" - "coordinate system stack already set up for aMorph - ('ivars transformations' and 'currentTransformation')" - self clippingByCurrentMorphDo: [ - currentMorph submorphsReverseDo: [ :m | self fullDraw: m ]]. - - (currentMorph postDrawOn: self) ifTrue: [ - currentMorph displayBoundsUpdateFrom: self ]. - - currentMorph isHighlighted ifTrue: [ - self drawHighlight: currentMorph ]. - ].! ! - -MorphicCanvas removeSelector: #savePatch:bounds:! - -!methodRemoval: MorphicCanvas #savePatch:bounds: stamp: 'Install-4902-cleanup-JuanVuletich-2021Oct07-16h35m-jmv.001.cs.st 10/14/2021 14:32:41'! -savePatch: prevSavedPatch bounds: aRectangle - "Senders don't need to know any details of what is answered, but just store it for further calls, and calls to restorePatch:" - "Details: The previously used patch Form is recycled when possible to reduce the burden on storage management." - | savedPatch bb prevExtent extent | - savedPatch _ prevSavedPatch. - prevExtent _ 0@0. - ((savedPatch is: #Form) and: [ - prevExtent _ savedPatch extent. - prevExtent >= aRectangle extent]) - ifTrue: [ - savedPatch offset: 0@0 ] - ifFalse: [ - "allocate new patch form if needed" - extent _ aRectangle extent max: prevExtent. - extent _ (extent x // 64 + 2 * 64) @ (extent y + 64). "Make it slightly larger, and even width." - savedPatch _ Form extent: extent depth: form depth ]. - bb _ BitBlt toForm: savedPatch. - bb sourceForm: form; combinationRule: Form over; - sourceX: aRectangle left; sourceY: aRectangle top; - width: aRectangle width; height: aRectangle height; - copyBits. - ^savedPatch! - -MorphicCanvas removeSelector: #restorePatch:bounds:! - -!methodRemoval: MorphicCanvas #restorePatch:bounds: stamp: 'Install-4902-cleanup-JuanVuletich-2021Oct07-16h35m-jmv.001.cs.st 10/14/2021 14:32:41'! -restorePatch: savedPatch bounds: savedBounds - "Argument must previously be obtained by calling #savePatch:bounds: - Senders should not assume anything about the returned object, except that it will not be nil." - -self flag: #jmvHacks. -"Podriamos usar un BitBlt guardado. Este metodo termina haciendo demasiadas cosas... (innecesarias)" - self - image: savedPatch - at: savedBounds origin - sourceRect: (0@0 extent: savedBounds extent)! - -MorphicCanvas removeSelector: #image:at:sourceRect:! - -!methodRemoval: MorphicCanvas #image:at:sourceRect: stamp: 'Install-4902-cleanup-JuanVuletich-2021Oct07-16h35m-jmv.001.cs.st 10/14/2021 14:32:41'! -image: aForm at: aPoint sourceRect: sourceRect - self subclassResponsibility.! - -MorphicCanvas removeSelector: #fillRectangle:tilingWith:multipliedBy:! - -!methodRemoval: MorphicCanvas #fillRectangle:tilingWith:multipliedBy: stamp: 'Install-4902-cleanup-JuanVuletich-2021Oct07-16h35m-jmv.001.cs.st 10/14/2021 14:32:41'! -fillRectangle: aRectangle tilingWith: aForm multipliedBy: aColor - self subclassResponsibility.! - -MorphicCanvas removeSelector: #isCurrentMorphVisible! - -!methodRemoval: MorphicCanvas #isCurrentMorphVisible stamp: 'Install-4902-cleanup-JuanVuletich-2021Oct07-16h35m-jmv.001.cs.st 10/14/2021 14:32:41'! -isCurrentMorphVisible - "Note: answer true if we are not sure." - | aRectangle myClipRect | - currentMorph visible ifFalse: [ ^false ]. - aRectangle := currentMorph displayBounds. - aRectangle ifNil: [ ^true ]. - (currentMorph firstOwnerSuchThat: [ :m | m is: #HandMorph ]) notNil ifTrue: [ ^true ]. - -self flag: #jmvHacks. - true ifTrue: [ ^true ]. - myClipRect := self clipRect. - aRectangle right < myClipRect left ifTrue: [^ false]. - aRectangle left > myClipRect right ifTrue: [^ false]. - aRectangle bottom < myClipRect top ifTrue: [^ false]. - aRectangle top > myClipRect bottom ifTrue: [^ false]. - ^ true -! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4902-cleanup-JuanVuletich-2021Oct07-16h35m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4902] on 7 October 2021 at 5:32:15 pm'! -!Preferences class methodsFor: 'fonts' stamp: 'jmv 10/7/2021 17:30:56'! - cacheTrueTypeGlyphs - "Provides significant performance improvements for text if not rotated or scaled. - Placement of each character is rounded to integer coordinates: text layout is not perfect." - - ^ self - valueOfFlag: #cacheTrueTypeGlyphs - ifAbsent: [ true ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4903-cacheTrueTypeGlyphs-JuanVuletich-2021Oct07-17h25m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4903] on 8 October 2021 at 9:38:53 am'! -!BitBltCanvas methodsFor: 'morphic' stamp: 'jmv 10/8/2021 09:36:16' prior: 50613843! - savePatch: prevSavedPatch bounds: aRectangle - "Senders don't need to know any details of what is answered, but just store it for further calls, and calls to restorePatch:" - "Details: The previously used patch Form is recycled when possible to reduce the burden on storage management." - | savedPatch bb prevExtent extent | - savedPatch _ prevSavedPatch. - prevExtent _ 0@0. - ((savedPatch is: #Form) and: [ - prevExtent _ savedPatch extent. - prevExtent >= aRectangle extent]) - ifTrue: [ - savedPatch offset: 0@0 ] - ifFalse: [ - "allocate new patch form if needed" - extent _ aRectangle extent max: prevExtent. - extent _ (extent x // 64 + 2 * 64) @ (extent y + 64). "Make it slightly larger, and even width." - savedPatch _ Form extent: extent depth: form depth ]. - bb _ BitBlt toForm: savedPatch. - bb sourceForm: form; combinationRule: Form over; - sourceX: aRectangle left; sourceY: aRectangle top; - width: aRectangle width; height: aRectangle height; - copyBits. - ^savedPatch! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4904-fixBugIn4902-JuanVuletich-2021Oct08-09h38m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4904] on 8 October 2021 at 9:54:33 am'! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 10/8/2021 09:46:17' prior: 50613716! - activeSubclass: aMorphicCanvasSubclass - " - self runningWorld canvas class - MorphicCanvas activeSubclass: BitBltCanvas - MorphicCanvas activeSubclass: HybridCanvas - MorphicCanvas activeSubclass: VectorCanvas - " - (#(BitBltCanvas HybridCanvas VectorCanvas) - includes: aMorphicCanvasSubclass name) ifFalse: [ - ^self error: 'Invalid Canvas class' ]. - ActiveSubclass _ aMorphicCanvasSubclass. - UISupervisor ui ifNotNil: [ :world | - world whenUIinSafeState: [ - world setMainCanvas ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4905-renamedVectorCanvasClasses-JuanVuletich-2021Oct08-09h54m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4905] on 8 October 2021 at 10:05:48 am'! -!Morph methodsFor: 'private' stamp: 'jmv 10/8/2021 10:05:28' prior: 50539713! - privateAddAllMorphs: aCollection atIndex: index - "Private. Add aCollection of morphs to the receiver" - | myWorld itsWorld otherSubmorphs | - (aCollection allSatisfy: [ :m | self canAdd: m]) ifFalse: [ - (self confirm: 'Some requested morph requires VectorGraphics support. Do you want to install and activate it?') - ifTrue: [ - Feature require: 'VectorGraphics'. - MorphicCanvas activeSubclass: (Smalltalk at: #VectorCanvas) ] - ifFalse: [ - ^self error: 'We can''t add requested morphs.' ]]. - myWorld _ self world. - otherSubmorphs _ submorphs copyWithoutAll: aCollection. - (index between: 0 and: otherSubmorphs size) - ifFalse: [^ self error: 'index out of range']. - index = 0 - ifTrue:[ submorphs _ aCollection asArray, otherSubmorphs] - ifFalse:[ index = otherSubmorphs size - ifTrue:[ submorphs _ otherSubmorphs, aCollection] - ifFalse:[ submorphs _ otherSubmorphs copyReplaceFrom: index + 1 to: index with: aCollection ]]. - aCollection do: [:m | | itsOwner | - itsOwner _ m owner. - itsOwner ifNotNil: [ - itsWorld _ m world. - (itsWorld == myWorld) ifFalse: [ - itsWorld ifNotNil: [m redrawNeeded]]. - (itsOwner ~~ self) ifTrue: [ - m owner privateRemove: m. - m owner removedMorph: m ]]. - m privateOwner: self. - myWorld ifNotNil: [m redrawNeeded]. - (myWorld == itsWorld) ifFalse: [m intoWorld: myWorld]. - itsOwner == self ifFalse: [ - self addedMorph: m. - m noteNewOwner: self ]. - ]. - self someSubmorphPositionOrExtentChanged! ! -!Morph methodsFor: 'private' stamp: 'jmv 10/8/2021 10:05:31' prior: 50556067! - privateAddMorph: aMorph atIndex: index position: aPointOrNil - - | oldIndex myWorld itsWorld oldOwner | - (self canAdd: aMorph) ifFalse: [ - (self confirm: 'The requested morph requires VectorGraphics support. Do you want to install and activate it?') - ifTrue: [ - Feature require: 'VectorGraphics'. - MorphicCanvas activeSubclass: (Smalltalk at: #VectorCanvas) ] - ifFalse: [ - ^self error: 'We can''t add requested morph.' ]]. - ((index >= 1) and: [index <= (submorphs size + 1)]) - ifFalse: [^ self error: 'index out of range']. - myWorld _ self world. - oldOwner _ aMorph owner. - (oldOwner == self and: [(oldIndex _ submorphs indexOf: aMorph) > 0]) ifTrue: [ - "aMorph's position changes within in the submorph chain" - oldIndex < index ifTrue:[ - "moving aMorph to back" - submorphs replaceFrom: oldIndex to: index-2 with: submorphs startingAt: oldIndex+1. - submorphs at: index-1 put: aMorph. - ] ifFalse:[ - "moving aMorph to front" - oldIndex-1 to: index by: -1 do:[:i| - submorphs at: i+1 put: (submorphs at: i)]. - submorphs at: index put: aMorph. - ]. - aPointOrNil ifNotNil: [aMorph privatePosition: aPointOrNil]. - ] ifFalse: [ - "adding a new morph" - oldOwner ifNotNil: [ - itsWorld _ aMorph world. - itsWorld ifNotNil: [aMorph invalidateBounds]. - oldOwner privateRemove: aMorph. - oldOwner removedMorph: aMorph. - ]. - aMorph privateOwner: self. - submorphs _ submorphs copyReplaceFrom: index to: index-1 with: (Array with: aMorph). - aPointOrNil ifNotNil: [aMorph privatePosition: aPointOrNil]. - (itsWorld == myWorld) ifFalse: [aMorph intoWorld: myWorld]. - ]. - myWorld ifNotNil: [ - index = 1 - ifTrue: [aMorph redrawNeeded ] - ifFalse: [aMorph invalidateBounds]]. - self someSubmorphPositionOrExtentChanged. - oldOwner == self ifFalse: [ - self addedMorph: aMorph. - aMorph noteNewOwner: self ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4906-StartDeprecatingHybridCanvas-JuanVuletich-2021Oct08-10h04m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4906] on 8 October 2021 at 8:12:40 pm'! - -Transcript class - instanceVariableNames: 'entries firstIndex lastIndex accessSemaphore unfinishedEntry logToFile showOnDisplay lastDisplayPosition bounds logToStdout displayCanvas displayEngine '! - -!classDefinition: 'Transcript class' category: #'System-Support' stamp: 'Install-4907-MakeTranscriptIndependentOfBitBltCanvas-JuanVuletich-2021Oct08-20h02m-jmv.001.cs.st 10/14/2021 14:32:41'! -Transcript class - instanceVariableNames: 'entries firstIndex lastIndex accessSemaphore unfinishedEntry logToFile showOnDisplay lastDisplayPosition bounds logToStdout displayCanvas displayEngine'! -!Transcript class methodsFor: 'private' stamp: 'jmv 10/8/2021 19:49:14'! - displayEngine - - (displayEngine isNil or: [ - displayEngine class ~= BitBltCanvasEngine]) ifTrue: [ - displayEngine _ BitBltCanvasEngine toForm: Display ]. - ^ displayEngine! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 10/8/2021 20:10:59'! - displayOnDisplay - "To be called directly, not from Morphic. - See #displayOnCanvas:in:" - " - 1 to: 2000 do: [ :i | i print ]. - 1 to: 750 do: [ :i | i print ]. - Transcript displayOnDisplay. - Display forceToScreen - " - | innerR | - self displayEngine. - innerR _ bounds insetBy: self padding. - displayEngine clipRect: innerR. - displayEngine - copy: innerR - from: `0@0` in: nil - fillColor: `Color white` rule: Form over. - self displayTextOn: self in: innerR.! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 10/8/2021 20:07:43'! - displayTextOn: aCanvasOrSelf in: aRectangle - "See senders" - | font count string x y fh innerR index | - font _ FontFamily defaultFamilyAndPointSize. - innerR _ aRectangle insetBy: self padding. - x _ innerR left. - y _ innerR top. - fh _ font lineSpacing. - count _ lastIndex - firstIndex \\ self maxEntries + 1 min: innerR height // fh - 1. - index _ lastIndex - count \\ self maxEntries + 1. - count timesRepeat: [ - string _ entries at: index. - aCanvasOrSelf drawString: string at: x@y font: font color: `Color veryDarkGray`. - y _ y + fh. - index _ index \\ self maxEntries + 1 ]. - string _ unfinishedEntry contents. - aCanvasOrSelf drawString: string at: x@y font: font color: `Color veryDarkGray`! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 10/8/2021 20:00:14'! - displayUnfinishedEntryOnDisplay - - | font count string x y fh r innerR | - self displayEngine. - innerR _ bounds insetBy: self padding. - lastDisplayPosition < innerR right ifTrue: [ - font _ FontFamily defaultFamilyAndPointSize. - fh _ font lineSpacing. - count _ innerR height // fh-1. - x _ innerR left. - string _ unfinishedEntry contents. - y _ ((lastIndex - firstIndex \\ self maxEntries) min: count-1) + 1 * font lineSpacing + innerR top. - r _ innerR left: lastDisplayPosition. - displayEngine clipRect: r. - (self drawString: string at: x@y font: font color: `Color veryDarkGray`) ifNotNil: [ :lastPoint | - lastDisplayPosition _ lastPoint x. - ^r ]]. - ^nil! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 10/8/2021 19:59:46'! - drawString: s at: pt font: font color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - - | p1 | - p1 _ pt rounded. - p1 _ p1 + (0@(0 - (font ascent + font lineGap-1))). - p1 _ p1 rounded. - displayEngine colorMap: nil. - ^font - onBitBltCanvasEngine: displayEngine - displayString: s - from: 1 - to: s size - at: p1 - color: aColor! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 10/8/2021 19:53:38' prior: 50541647! - display - showOnDisplay ifTrue: [ - self displayOnDisplay. - DisplayScreen screenUpdateRequired: bounds ]. - "So any morph in front of us is repaired when Morphic cycles. - This includes, for instance, the TranscriptWindow that shows our contents if showOnDisplay is false" - self triggerEvent: #redraw! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 10/8/2021 19:57:35' prior: 50541663! - displayUnfinishedEntry - showOnDisplay ifTrue: [ - self displayUnfinishedEntryOnDisplay ifNotNil: [ :damage | - DisplayScreen screenUpdateRequired: damage ]]! ! -!Transcript class methodsFor: 'system startup' stamp: 'jmv 10/8/2021 19:48:11' prior: 50541642 overrides: 50510042! - releaseClassCachedState - displayEngine _ nil! ! -!TranscriptMorph methodsFor: 'drawing' stamp: 'jmv 10/8/2021 20:10:01' prior: 50592076 overrides: 50596652! - drawOn: aCanvas - "If we don't call super, clipping fails if zoomed / rotated, and nothing is shown." - super drawOn: aCanvas. - aCanvas clippingByCurrentMorphDo: [ - aCanvas - fillRectangle: self morphLocalBounds - color: `Color white`. - Transcript displayTextOn: aCanvas in: self morphLocalBounds ]. - self displayBounds ifNotNil: [ :r | - Transcript bounds:r ]. - self updateWorkspace! ! - -Transcript class removeSelector: #canvas! - -!methodRemoval: Transcript class #canvas stamp: 'Install-4907-MakeTranscriptIndependentOfBitBltCanvas-JuanVuletich-2021Oct08-20h02m-jmv.001.cs.st 10/14/2021 14:32:41'! -canvas - "VectorCanvas is not safe WRT changes in Display extent. - Besides, it is expensive in memory. - The alternative of using (UISupervisor ui canvas) is not safe. We don't know in which state it is (currentMorph, geometry, etc), or it is in midst of state change, and inconsistent. Waiting for a safe stat is not an option: we want immeiate updates. - The only way to no longer need BitBltCanvas is to use BitBlt directly, possibly with a special StrikeFont. - That, of course, would mean that the Morphic version has no hope of ever matching it. - More thought is needed to find a simple and general solution. - " - (displayCanvas isNil or: [ - displayCanvas class ~= BitBltCanvas]) ifTrue: [ - displayCanvas _ BitBltCanvas onForm: Display ]. - ^ displayCanvas! - -Transcript class removeSelector: #displayUnfinishedEntryOnCanvas:! - -!methodRemoval: Transcript class #displayUnfinishedEntryOnCanvas: stamp: 'Install-4907-MakeTranscriptIndependentOfBitBltCanvas-JuanVuletich-2021Oct08-20h02m-jmv.001.cs.st 10/14/2021 14:32:41'! -displayUnfinishedEntryOnCanvas: aCanvas - - | font count string x y fh r innerR | - innerR _ bounds insetBy: self padding. - lastDisplayPosition < innerR right ifTrue: [ - font _ FontFamily defaultFamilyAndPointSize. - fh _ font lineSpacing. - count _ innerR height // fh-1. - x _ innerR left. - string _ unfinishedEntry contents. - y _ ((lastIndex - firstIndex \\ self maxEntries) min: count-1) + 1 * font lineSpacing + innerR top. - r _ innerR left: lastDisplayPosition. - aCanvas newClipRect: r. - (aCanvas drawString: string at: x@y font: font color: `Color veryDarkGray`) ifNotNil: [ :lastPoint | - lastDisplayPosition _ lastPoint x. - ^r ]]. - ^nil! - -Transcript class removeSelector: #displayOnCanvas:in:! - -!methodRemoval: Transcript class #displayOnCanvas:in: stamp: 'Install-4907-MakeTranscriptIndependentOfBitBltCanvas-JuanVuletich-2021Oct08-20h02m-jmv.001.cs.st 10/14/2021 14:32:41'! -displayOnCanvas: aCanvas in: aRectangle - " - 1 to: 2000 do: [ :i | i print ]. - 1 to: 750 do: [ :i | i print ]. - Transcript displayOn: Display in: bounds - " - | font count string x y fh innerR index | - aCanvas - fillRectangle: aRectangle - color: `Color white`. - font _ FontFamily defaultFamilyAndPointSize. - innerR _ aRectangle insetBy: self padding. - x _ innerR left. - y _ innerR top. - fh _ font lineSpacing. - count _ lastIndex - firstIndex \\ self maxEntries + 1 min: innerR height // fh - 1. - index _ lastIndex - count \\ self maxEntries + 1. - count timesRepeat: [ - string _ entries at: index. - aCanvas drawString: string at: x@y font: font color: `Color veryDarkGray`. - y _ y + fh. - index _ index \\ self maxEntries + 1 ]. - string _ unfinishedEntry contents. - aCanvas drawString: string at: x@y font: font color: `Color veryDarkGray`! - -Transcript class - instanceVariableNames: 'entries firstIndex lastIndex accessSemaphore unfinishedEntry logToFile showOnDisplay lastDisplayPosition bounds logToStdout displayEngine'! - -!classDefinition: 'Transcript class' category: #'System-Support' stamp: 'Install-4907-MakeTranscriptIndependentOfBitBltCanvas-JuanVuletich-2021Oct08-20h02m-jmv.001.cs.st 10/14/2021 14:32:41'! -Transcript class - instanceVariableNames: 'entries firstIndex lastIndex accessSemaphore unfinishedEntry logToFile showOnDisplay lastDisplayPosition bounds logToStdout displayEngine'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4907-MakeTranscriptIndependentOfBitBltCanvas-JuanVuletich-2021Oct08-20h02m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4907] on 8 October 2021 at 8:24:38 pm'! - -WidgetMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity originalPosition showUp itemsPerPage downButtonForm upButtonForm ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #AutoCompleterMorph category: #'Tools-Autocompletion' stamp: 'Install-4908-MakeAutoCompleterMorphIndependentOfBitBltCanvas-JuanVuletich-2021Oct08-20h20m-jmv.001.cs.st 10/14/2021 14:32:41'! -WidgetMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity originalPosition showUp itemsPerPage downButtonForm upButtonForm' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'jmv 10/8/2021 20:22:46' prior: 50433555! - drawDownArrowOn: aCanvas thickness: scrollbarThickness - - downButtonForm ifNil: [ - downButtonForm _ ScrollBar new instVarNamed: 'downButton' :: imageForm: 32 ]. - aCanvas - image: downButtonForm - at: self downButtonPosition. -! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'jmv 10/8/2021 20:21:15' prior: 50446723! -drawScrollBarMovementBarOn: aCanvas thickness: scrollbarThickness - - | height top bottom | - - height _ extent y - (2 * scrollbarThickness). - top _ (1.0 * self firstVisible-1 / self entryCount * height) ceiling + 1 + scrollbarThickness-1. - bottom _ (1.0 * self lastVisible / self entryCount * height) floor + 1 + scrollbarThickness -1. - aCanvas - fillRectangle: (extent x - scrollbarThickness+2@top corner: extent x-2 @ bottom) - color: `Color veryLightGray lighter`! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'jmv 10/8/2021 20:23:23' prior: 50433635! - drawUpArrowOn: aCanvas thickness: scrollbarThickness - - upButtonForm ifNil: [ - upButtonForm _ ScrollBar new instVarNamed: 'upButton' :: imageForm: 32 ]. - aCanvas - image: upButtonForm - at: self upButtonPosition. -! ! - -WidgetMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity originalPosition showUp itemsPerPage downButtonForm upButtonForm' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -!classDefinition: #AutoCompleterMorph category: #'Tools-Autocompletion' stamp: 'Install-4908-MakeAutoCompleterMorphIndependentOfBitBltCanvas-JuanVuletich-2021Oct08-20h20m-jmv.001.cs.st 10/14/2021 14:32:41'! -WidgetMorph subclass: #AutoCompleterMorph - instanceVariableNames: 'completer selected firstVisible itemHeight lastActivity originalPosition showUp itemsPerPage downButtonForm upButtonForm' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Autocompletion'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4908-MakeAutoCompleterMorphIndependentOfBitBltCanvas-JuanVuletich-2021Oct08-20h20m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4908] on 13 October 2021 at 9:32:22 am'! -!Categorizer methodsFor: 'tdd' stamp: 'HAW 10/13/2021 09:29:54' prior: 50338075! - classesAt: aCategoryName - - ^(self listAtCategoryNamed: aCategoryName) - collect: [:aClassName | Smalltalk classNamed: aClassName ] - thenSelect: [ :aClass | aClass notNil ] - ! ! -!SystemOrganizer methodsFor: 'source code management' stamp: 'HAW 10/13/2021 09:31:11' prior: 50610674! - classMethodCountOf: category - - ^ (self classesAt: category) sum: [ :cl | cl class selectors size ] ifEmpty: 0.! ! -!SystemOrganizer methodsFor: 'source code management' stamp: 'HAW 10/13/2021 09:31:23' prior: 50610681! - instanceMethodCountOf: category - - ^ (self classesAt: category) sum: [ :cl | cl selectors size ] ifEmpty: 0.! ! -!SystemOrganizer methodsFor: 'source code management' stamp: 'HAW 10/13/2021 09:31:30' prior: 50610688! - linesOfCodeOf: category -" -SystemOrganization linesOfCodeOf: #'System-Files' -" - "An approximate measure of lines of. - Includes comments, but excludes blank lines." - - ^ (self classesAt: category) sum: [ :cl | cl linesOfCode ] ifEmpty: 0.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4909-ClassCategoryAnnotationSpeedUp-HernanWilkinson-2021Oct13-09h06m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4909] on 13 October 2021 at 10:16:22 am'! -!Categorizer methodsFor: 'tdd' stamp: 'HAW 2/7/2017 09:06:13' prior: 50614581! - classesAt: aCategoryName - - ^(self listAtCategoryNamed: aCategoryName) collect: [:aClassName | Smalltalk classNamed: aClassName ] - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4910-Simplify-HernanWilkinson-2021Oct13-10h15m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4910] on 13 October 2021 at 11:00:17 am'! -!Array methodsFor: 'enumerating' stamp: 'jmv 10/13/2021 10:54:48' overrides: 50586802! - collect: collectBlock thenSelect: selectBlock - "Evaluate collectBlock with each my elements as the argument. Collect the - resulting values into a collection that is like me, but only those elements for which - selectBlock evaluates to true. Answer the new collection. - Overriden for performance." - - | newElement | - ^ self species streamContents: [ :strm | - 1 to: self size do: [ :index | - newElement _ collectBlock value: (self at: index). - (selectBlock value: newElement) - ifTrue: [ strm nextPut: newElement ]]]! ! -!Array methodsFor: 'enumerating' stamp: 'jmv 10/13/2021 10:58:21' overrides: 50586809! - select: selectBlock thenCollect: collectBlock - "Evaluate selectBlock with each my elements as the argument. For those who evaluate to true, - collect the result of evaluating collectBlock on them into a collection that is like me. - Answer the new collection. - Overriden for performance." - - | each | - ^ self species streamContents: [ :strm | - 1 to: self size do: [ :index | - each _ self at: index. - (selectBlock value: each) ifTrue: [ - strm nextPut: (collectBlock value: each) ]]]! ! -!OrderedCollection methodsFor: 'enumerating' stamp: 'jmv 10/13/2021 10:40:07' overrides: 50586802! - collect: collectBlock thenSelect: selectBlock - "Evaluate collectBlock with each my elements as the argument. Collect the - resulting values into a collection that is like me, but only those elements for which - selectBlock evaluates to true. Answer the new collection. - Overriden for performance." - - | newCollection newElement | - newCollection _ self species new. - newCollection resetTo: 1. - firstIndex to: lastIndex do: [ :index | - newElement _ collectBlock value: (array at: index). - (selectBlock value: newElement) - ifTrue: [ newCollection addLast: newElement ]]. - ^ newCollection! ! -!OrderedCollection methodsFor: 'enumerating' stamp: 'jmv 10/13/2021 10:42:23' overrides: 50586809! - select: selectBlock thenCollect: collectBlock - "Evaluate selectBlock with each my elements as the argument. For those who evaluate to true, - collect the result of evaluating collectBlock on them into a collection that is like me. - Answer the new collection. - Overriden for performance." - - | newCollection each | - newCollection _ self species new. - newCollection resetTo: 1. - firstIndex to: lastIndex do: [ :index | - each _ array at: index. - (selectBlock value: each) ifTrue: [ - newCollection addLast: (collectBlock value: each) ]]. - ^ newCollection! ! -!OrderedCollection methodsFor: 'enumerating' stamp: 'jmv 10/13/2021 10:36:49' prior: 16884016 overrides: 16906753! - 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 species new. - newCollection resetTo: 1. - firstIndex to: lastIndex do: [ :index | - (aBlock value: (element _ array at: index)) - ifTrue: [ newCollection addLast: element ]]. - ^ newCollection! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4911-Faster-selectThenCollect-collectThenSelect-JuanVuletich-2021Oct13-10h27m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4910] on 13 October 2021 at 11:30:24 am'! -!CodeProvider methodsFor: 'annotation' stamp: 'jmv 10/13/2021 11:28:09' prior: 50610699! - annotationForSelector: aSelector ofClass: aClass - "Provide a line of content for an annotation pane, representing - information about the given selector and class" - - | stamp sendersCount implementorsCount aCategory separator aString aList aComment stream requestList | - aSelector == #Comment - ifTrue: [^ self annotationForClassCommentFor: aClass]. - aSelector == #Definition - ifTrue: [^ self annotationForClassDefinitionFor: aClass]. - stream _ WriteStream on: String new. - requestList _ self annotationRequests. - separator _ self annotationSeparator. - requestList - do: [:aRequest | - aRequest == #firstComment - ifTrue: [ - aComment _ aClass firstCommentAt: aSelector. - aComment isEmptyOrNil - ifFalse: [stream position = 0 ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: aComment]]. - aRequest == #masterComment - ifTrue: [ - aComment _ aClass supermostPrecodeCommentFor: aSelector. - aComment isEmptyOrNil - ifFalse: [stream position = 0 ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: aComment]]. - aRequest == #documentation - ifTrue: [ - aComment _ aClass precodeCommentOrInheritedCommentFor: aSelector. - aComment isEmptyOrNil - ifFalse: [stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: aComment]]. - aRequest == #timeStamp - ifTrue: [ - stamp _ self timeStamp. - stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: (stamp size > 0 ifTrue: [stamp] ifFalse: ['no timestamp'])]. - aRequest == #linesOfCode - ifTrue: [ - stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: ((aClass compiledMethodAt: aSelector ifAbsent: nil) - ifNotNil: [ :cm | cm linesOfCode]) printString, ' lines of code']. - aRequest == #messageCategory - ifTrue: [ - aCategory _ aClass organization categoryOfElement: aSelector. - aCategory - ifNotNil: ["woud be nil for a method no longer present, - e.g. in a recent-submissions browser" - stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: aCategory]]. - aRequest == #sendersCount - ifTrue: [ - sendersCount _ Smalltalk numberOfSendersOf: aSelector. - sendersCount _ sendersCount = 1 - ifTrue: ['1 sender'] - ifFalse: [sendersCount printString , ' senders']. - stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: sendersCount]. - aRequest == #implementorsCount - ifTrue: [ - implementorsCount _ Smalltalk numberOfImplementorsOf: aSelector. - implementorsCount _ implementorsCount = 1 - ifTrue: ['1 implementor'] - ifFalse: [implementorsCount printString , ' implementors']. - stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: implementorsCount]. - aRequest == #priorVersionsCount - ifTrue: [ - stream isEmpty ifFalse: [stream nextPutAll: separator]. - self - addPriorVersionsCountForSelector: aSelector - ofClass: aClass - to: stream]. - aRequest == #priorTimeStamp - ifTrue: [ - stamp _ VersionsBrowser - timeStampFor: aSelector - class: aClass - reverseOrdinal: 2. - stamp - ifNotNil: [stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: 'prior timestamp: ' , stamp]]. - aRequest == #packages - ifTrue: [ - (aClass compiledMethodAt: aSelector ifAbsent: nil) ifNotNil: [ :cm | - stream isEmpty ifFalse: [stream nextPutAll: separator]. - (CodePackage packageOfMethod: cm methodReference ifNone: nil) - ifNil: [ stream nextPutAll: 'in no package' ] - ifNotNil: [ :codePackage | - stream nextPutAll: 'in package '; nextPutAll: codePackage packageName ]]]. - aRequest == #changeSets - ifTrue: [ - stream isEmpty ifFalse: [stream nextPutAll: separator]. - aList _ ChangeSet allChangeSetsWithClass: aClass selector: aSelector. - aList size > 0 - ifTrue: [aList size = 1 - ifTrue: [stream nextPutAll: 'only in change set'] - ifFalse: [stream nextPutAll: 'in change sets:']. - aList - do: [:aChangeSet | stream nextPut: Character space; nextPutAll: aChangeSet name ] - separatedBy: [ stream nextPut: $, ]] - ifFalse: [stream nextPutAll: 'in no change set']]. - aRequest == #allChangeSets - ifTrue: [ - stream isEmpty ifFalse: [stream nextPutAll: separator]. - aList _ ChangeSet allChangeSetsWithClass: aClass selector: aSelector. - aList size > 0 - ifTrue: [aList size = 1 - ifTrue: [stream nextPutAll: 'only in change set'] - ifFalse: [stream nextPutAll: 'in change sets:']. - aList - do: [:aChangeSet | stream nextPut: Character space; nextPutAll: aChangeSet name ] - separatedBy: [ stream nextPut: $, ]] - ifFalse: [stream nextPutAll: 'in no change set']]. - aRequest == #allBaseSystemChangeSets - ifTrue: [ - stream isEmpty ifFalse: [stream nextPutAll: separator]. - aList _ (ChangeSet allChangeSetsWithClass: aClass selector: aSelector) select: [ :it | it isForBaseSystem ]. - aList size > 0 - ifTrue: [ - aList size = 1 - ifTrue: [stream nextPutAll: 'only in base system change set'] - ifFalse: [stream nextPutAll: 'in base system change sets:']. - aList - do: [:aChangeSet | stream nextPut: Character space; nextPutAll: aChangeSet name ] - separatedBy: [ stream nextPut: $, ]] - ifFalse: [stream nextPutAll: 'in no base system change set']]. - aRequest == #closuresInfo - ifTrue: [ - aString _ aClass closuresInfoAt: aSelector. - aString size > 0 - ifTrue: [stream isEmpty ifFalse: [stream nextPutAll: separator]. - stream nextPutAll: aString]]. - ]. - ^ stream contents! ! -!Browser methodsFor: 'accessing' stamp: 'jmv 10/13/2021 11:19:23' prior: 50485422 overrides: 16812025! - acceptedStringOrText - "Depending on the current selection, different information is retrieved. - Answer a string description of that information. This information is the - method of the currently selected class and message." - - | comment theClass latestCompiledMethod | - latestCompiledMethod _ currentCompiledMethod. - currentCompiledMethod _ nil. - - editSelection == #none ifTrue: [^ '']. - editSelection == #editSystemCategories - ifTrue: [^ systemOrganizer printString]. - self isEditingNewClass - ifTrue: [^ (theClass _ self selectedClass) - ifNil: [ - Class template: selectedSystemCategory] - ifNotNil: [ - Class templateForSubclassOf: theClass category: selectedSystemCategory]]. - self isEditingExistingClass - ifTrue: [^ self classDefinitionText ]. - editSelection == #editComment - ifTrue: [ - (theClass _ self selectedClass) ifNil: [^ '']. - comment _ theClass comment. - currentCompiledMethod _ theClass organization commentRemoteStr. - ^ comment size = 0 - ifTrue: ['This class has not yet been commented.'] - ifFalse: [comment]]. - editSelection == #editMessageCategories - ifTrue: [^ self classOrMetaClassOrganizer printString]. - editSelection == #newMessage - ifTrue: [ - ^ (theClass _ self selectedClassOrMetaClass) - ifNil: [''] - ifNotNil: [theClass sourceCodeTemplate]]. - editSelection == #editMessage - ifTrue: [ - self showingByteCodes ifTrue: [^ self selectedBytecodes]. - currentCompiledMethod _ latestCompiledMethod. - ^ self selectedMessage]. - - self error: 'Browser internal error: unknown edit selection.'! ! -!Browser methodsFor: 'accessing' stamp: 'jmv 10/13/2021 11:23:02' prior: 50485476! - contents: input notifying: aRequestor - "The retrieved information has changed and its source must now be - updated. The information can be a variety of things, depending on - the list selections (such as templates for class or message definition, - methods) or the user menu commands (such as definition, comment). - Answer the result of updating the source." - - | aString aText theClass | - aString _ input asString. - aText _ input asText. - editSelection == #editSystemCategories ifTrue: [ ^ self changeSystemCategories: aString ]. - self isEditingClass ifTrue: [ - [ - self defineClass: aString notifying: aRequestor - ] on: RecompilationFailure do: [ :ex | - self inform: ex messageText. - ^ false]. - ^ true]. - editSelection == #editComment - ifTrue: [ - theClass _ self selectedClass. - theClass - ifNil: [ - self inform: 'You must select a class -before giving it a comment.'. - ^ false]. - theClass comment: aText stamp: Utilities changeStamp. - self changed: #classCommentText. - ^ true]. - editSelection == #editMessageCategories ifTrue: [ ^ self changeMessageCategories: aString ]. - editSelection == #editMessage | (editSelection == #newMessage) - ifTrue: [ - ^ self okayToAccept - ifFalse:[ false ] - ifTrue: [ - (self compileMessage: aText notifying: aRequestor) - ifTrue: [ self triggerEvent: #annotationChanged ]; - yourself ]]. - editSelection == #none - ifTrue: [ - self inform: 'This text cannot be accepted -in this part of the browser.'. - ^ false]. - self error: 'unacceptable accept'! ! -!Browser methodsFor: 'class functions' stamp: 'jmv 10/13/2021 11:23:55' prior: 50485550! - explainSpecial: string - "Answer a string explaining the code pane selection if it is displaying - one of the special edit functions." - - | classes whole lits reply | - self isEditingClass - ifTrue: - ["Selector parts in class definition" - string last == $: ifFalse: [^nil]. - lits _ Array with: - #subclass:instanceVariableNames:classVariableNames:poolDictionaries:category:. - (whole _ lits detect: [:each | (each keywords - detect: [:frag | frag = string] ifNone: nil) notNil] - ifNone: nil) notNil - ifTrue: [reply _ '"' , string , ' is one part of the message selector ' , whole , '.'] - ifFalse: [^nil]. - classes _ Smalltalk allClassesImplementing: whole. - classes _ 'these classes ' , classes printString. - ^reply , ' It is defined in ' , classes , '." -Smalltalk browseAllImplementorsOf: #' , whole]. - - editSelection == #editSystemCategories ifTrue: [^nil]. - editSelection == #editMessageCategories ifTrue: [^nil]. - ^nil! ! -!Browser methodsFor: 'class functions' stamp: 'jmv 10/13/2021 11:25:19' prior: 16791754! - plusButtonHit - "Cycle among definition and comment." - - editSelection == #editComment - ifTrue: [ - self editSelection: #editClass. - selectedClassName ifNil: [ ^self ]. - self changed: #editComment. - self acceptedContentsChanged. - ^ self]. - self editComment. - self changed: #instanceMessagesIndicated. - self changed: #classCommentIndicated. - self changed: #classMessagesIndicated.! ! -!MessageSet methodsFor: 'message list' stamp: 'jmv 10/13/2021 11:19:12' prior: 50504338 overrides: 16792430! - selectedMessage - "Answer the source method for the currently selected message." - - | class selector | - selectedMessage ifNil: [^ 'Class vanished']. - - class _ selectedMessage actualClass. - selector _ selectedMessage methodSymbol. - selector ifNil: [ ^'prims']. - - selector first isUppercase ifTrue: [ - selector == #Comment ifTrue: [ - currentCompiledMethod _ class organization commentRemoteStr. - ^ class comment ]. - selector == #Definition ifTrue: [ - ^ class definition ].]. - - (class notNil and: [ class includesSelector: selector]) ifFalse: [ - currentCompiledMethod _ nil. - ^ 'Missing']. - - self showingDecompile ifTrue: [ - ^ self decompiledSource ]. - - currentCompiledMethod _ class compiledMethodAt: selector ifAbsent: nil. - self showingDocumentation ifTrue: [ - ^ self commentContents ]. - - ^self sourceStringPrettifiedAndDiffed! ! -!MessageSet methodsFor: 'accessing' stamp: 'jmv 10/13/2021 11:28:31' prior: 16870042 overrides: 50614979! - contents: aString notifying: aRequestor - "Compile the code in aString. Notify aRequestor of any syntax errors. - Answer false if the compilation fails. Otherwise, if the compilation - created a new method, deselect the current selection. Then answer true." - - | category selector class oldSelector | - self okayToAccept ifFalse: [^ false]. - selectedMessage ifNil: [^ false]. - class _ selectedMessage actualClass. - oldSelector _ selectedMessage methodSymbol. - (oldSelector notNil and: [oldSelector first isUppercase]) ifTrue: - [oldSelector == #Comment ifTrue: - [class comment: aString stamp: Utilities changeStamp. - self triggerEvent: #annotationChanged. - self changed: #clearUserEdits. - ^ false]. - oldSelector == #Definition ifTrue: [ - Compiler - evaluate: aString - notifying: aRequestor - logged: true. - self changed: #clearUserEdits. - ^ false]]. - "Normal method accept" - category _ class organization categoryOfElement: oldSelector. - selector _ class compile: aString - classified: category - notifying: aRequestor. - selector - ifNil: [^ false]. - selector == oldSelector ifFalse: [ - self reformulateListNoting: selector]. - self triggerEvent: #annotationChanged. - ^ true! ! -!MessageSet class methodsFor: 'utilities' stamp: 'jmv 10/13/2021 11:29:12' prior: 16870395! - isPseudoSelector: aSelector - "Answer whether the given selector is a special marker" - - ^ #(Comment Definition) statePointsTo: aSelector! ! -!BrowserWindow class methodsFor: 'browser menues' stamp: 'jmv 10/13/2021 11:27:31' prior: 50445756! - classListMenuOptions - - ^ `{ - { - #itemGroup -> 10. - #itemOrder -> 10. - #label -> 'browse full (b)'. - #selector -> #browseMethodFull. - #icon -> #editFindReplaceIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 20. - #label -> 'browse hierarchy (h)'. - #selector -> #browseHierarchy. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 10. - #itemOrder -> 30. - #label -> 'browse protocol (p)'. - #selector -> #browseFullProtocol. - #icon -> #spreadsheetIcon - } asDictionary. - { - #itemGroup -> 20. - #itemOrder -> 10. - #label -> 'fileOut'. - #object -> #model. - #selector -> #fileOutClass. - #icon -> #fileOutIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 5. - #label -> 'show classes hierarchically'. - #object -> #model. - #selector -> #enableListClassesHierarchically. - #icon -> #goTopIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 6. - #label -> 'show classes alphabetically'. - #object -> #model. - #selector -> #enableListClassesAlphabetically. - #icon -> #sendReceiveIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 20. - #label -> 'show definition'. - #object -> #model. - #selector -> #editClass. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 30. - #itemOrder -> 30. - #label -> 'show comment'. - #object -> #model. - #selector -> #editComment. - #icon -> #findIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 10. - #label -> 'inst var refs...'. - #selector -> #browseInstVarRefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 40. - #itemOrder -> 20. - #label -> 'inst var defs...'. - #selector -> #browseInstVarDefs. - #icon -> #instanceIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 10. - #label -> 'class var refs...'. - #selector -> #browseClassVarRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 20. - #label -> 'class vars'. - #selector -> #browseClassVariables. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 50. - #itemOrder -> 30. - #label -> 'class refs (N)'. - #selector -> #browseClassRefs. - #icon -> #classIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 10. - #label -> 'rename class... (R)'. - #object -> #model. - #selector -> #renameClass. - #icon -> #saveAsIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 20. - #label -> 'copy class...'. - #object -> #model. - #selector -> #copyClass. - #icon -> #copyIcon - } asDictionary. - { - #itemGroup -> 60. - #itemOrder -> 30. - #label -> 'remove class (x)'. - #object -> #model. - #selector -> #removeClass. - #icon -> #deleteIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 10. - #label -> 'run tests (t)'. - #object -> #model. - #selector -> #runClassTests. - #icon -> #weatherFewCloudsIcon - } asDictionary. - { - #itemGroup -> 70. - #itemOrder -> 20. - #label -> 'more...'. - #selector -> #offerClassListMenu2. - #icon -> #listAddIcon - } asDictionary. - }`. - ! ! - -PseudoClass removeSelector: #printHierarchy! - -!methodRemoval: PseudoClass #printHierarchy stamp: 'Install-4912-Remove-showHierarchy-menuOption-JuanVuletich-2021Oct13-11h00m-jmv.001.cs.st 10/14/2021 14:32:41'! -printHierarchy - - ^'Hierarchy view not supported'! - -Behavior removeSelector: #printHierarchy! - -!methodRemoval: Behavior #printHierarchy stamp: 'Install-4912-Remove-showHierarchy-menuOption-JuanVuletich-2021Oct13-11h00m-jmv.001.cs.st 10/14/2021 14:32:41'! -printHierarchy - "Answer a description containing the names and instance variable names - of all of the subclasses and superclasses of the receiver." - - | aStream index | - index _ 0. - aStream _ WriteStream on: (String new: 16). - self allSuperclasses reverseDo: [ :aClass | - aStream newLineTab: index. - index _ index + 1. - aStream nextPutAll: aClass name. - aStream space. - aStream print: aClass instVarNames]. - aStream newLine. - self printSubclassesOn: aStream level: index. - ^aStream contents! - -Browser removeSelector: #hierarchy! - -!methodRemoval: Browser #hierarchy stamp: 'Install-4912-Remove-showHierarchy-menuOption-JuanVuletich-2021Oct13-11h00m-jmv.001.cs.st 10/14/2021 14:32:41'! -hierarchy - "Display the inheritance hierarchy of the receiver's selected class." - - selectedClassName ifNil: [^ self]. - self messageCategoryListIndex: 0. - self editSelection: #hierarchy. - self changed: #editComment. - self acceptedContentsChanged. - ^ self! - -CodeProvider removeSelector: #annotationForHierarchyFor:! - -!methodRemoval: CodeProvider #annotationForHierarchyFor: stamp: 'Install-4912-Remove-showHierarchy-menuOption-JuanVuletich-2021Oct13-11h00m-jmv.001.cs.st 10/14/2021 14:32:41'! -annotationForHierarchyFor: aClass - "Provide a line of content for an annotation pane, given that the receiver is pointing at the hierarchy of the given class." - - ^ 'Hierarchy for ', aClass name! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4912-Remove-showHierarchy-menuOption-JuanVuletich-2021Oct13-11h00m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4910] on 13 October 2021 at 12:31:56 pm'! -!Preferences class methodsFor: 'parameters' stamp: 'jmv 10/13/2021 11:41:15'! - classAnnotations - " - Preferences classAnnotations - " - (self parameters includesKey: #ClassAnnotations) ifFalse: [ - self setDefaultAnnotationsInBrowsers ]. - ^ self parameters at: #ClassAnnotations! ! -!Preferences class methodsFor: 'parameters' stamp: 'jmv 10/13/2021 11:39:36'! - methodAnnotations - " - Preferences methodAnnotations - " - (self parameters includesKey: #MethodAnnotations) ifFalse: [ - self setDefaultAnnotationsInBrowsers ]. - ^ self parameters at: #MethodAnnotations! ! -!Preferences class methodsFor: 'parameters' stamp: 'jmv 10/13/2021 11:45:41'! - setDefaultAnnotationsInBrowsers - " - Preferences setDefaultAnnotationsInBrowsers - " - self parameters - at: #MethodAnnotations - put: #(timeStamp linesOfCode messageCategory implementorsCount sendersCount packages changeSets); - at: #ClassAnnotations - put: #(instanceMethodsCount classMethodsCount linesOfCode); - at: #SystemCategoryAnnotations - put: #(classCount instanceMethodsCount classMethodsCount linesOfCode)! ! -!Preferences class methodsFor: 'parameters' stamp: 'jmv 10/13/2021 11:46:19'! - setQuickAnnotationsInBrowsers - " - Preferences setQuickAnnotationsInBrowsers - " - self parameters - at: #MethodAnnotations - put: #(timeStamp messageCategory packages changeSets); - at: #ClassAnnotations - put: #(instanceMethodsCount classMethodsCount); - at: #SystemCategoryAnnotations - put: #(classCount instanceMethodsCount classMethodsCount)! ! -!Preferences class methodsFor: 'parameters' stamp: 'jmv 10/13/2021 11:41:44'! - systemCategoryAnnotations - " - Preferences systemCategoryAnnotations - " - (self parameters includesKey: #SystemCategoryAnnotations) ifFalse: [ - self setDefaultAnnotationsInBrowsers ]. - ^ self parameters at: #SystemCategoryAnnotations! ! -!CodeProvider methodsFor: 'annotation' stamp: 'jmv 10/13/2021 11:59:42' prior: 50518408! - annotationForClassDefinitionFor: aClass - "Provide a line of content for an annotation pane, given that the receiver is pointing at the class definition of the given class." - - ^ String streamContents: [ :strm | - strm - nextPutAll: 'Class definition for '; - nextPutAll: aClass name. - Preferences classAnnotations do: [ :each | - strm nextPutAll: self annotationSeparator. - each caseOf: { - [#instanceMethodsCount] -> [ - strm - print: (aClass theNonMetaClass selectors size); - nextPutAll: ' instance methods' ]. - [#classMethodsCount] -> [ - strm - print: (aClass theMetaClass selectors size); - nextPutAll: ' class methods' ]. - [#linesOfCode] -> [ - strm - print: (aClass theNonMetaClass linesOfCode); - nextPutAll: ' total lines of code' ] - }]].! ! -!CodeProvider methodsFor: 'annotation' stamp: 'jmv 10/13/2021 12:30:45' prior: 50614744! - annotationForSelector: aSelector ofClass: aClass - "Provide a line of content for an annotation pane, representing - information about the given selector and class" - - aSelector == #Comment - ifTrue: [^ self annotationForClassCommentFor: aClass]. - aSelector == #Definition - ifTrue: [^ self annotationForClassDefinitionFor: aClass]. - - ^ String streamContents: [ :strm | - Preferences methodAnnotations - do: [ :each | - each caseOf: { - [#firstComment] -> [ - strm nextPutAll: (aClass firstCommentAt: aSelector) ]. - [#masterComment] -> [ - strm nextPutAll: ((aClass supermostPrecodeCommentFor: aSelector) ifNil: ['']) ]. - [#documentation] -> [ - strm nextPutAll: ((aClass precodeCommentOrInheritedCommentFor: aSelector) ifNil: ['']) ]. - [#timeStamp] -> [ | stamp | - stamp _ self timeStamp. - strm nextPutAll: (stamp size > 0 ifTrue: [stamp] ifFalse: ['no timestamp'])]. - [#linesOfCode] -> [ - strm - print: ((aClass compiledMethodAt: aSelector ifAbsent: nil) ifNotNil: [ :cm | cm linesOfCode]); - nextPutAll: ' lines of code' ]. - [#messageCategory] -> [ - strm nextPutAll: (( aClass organization categoryOfElement: aSelector) ifNil: ['']) ]. - [#sendersCount] -> [ | sendersCount | - sendersCount _ Smalltalk numberOfSendersOf: aSelector. - sendersCount _ sendersCount = 1 - ifTrue: ['1 sender'] - ifFalse: [sendersCount printString , ' senders']. - strm nextPutAll: sendersCount ]. - [#implementorsCount] -> [ | implementorsCount | - implementorsCount _ Smalltalk numberOfImplementorsOf: aSelector. - implementorsCount _ implementorsCount = 1 - ifTrue: ['1 implementor'] - ifFalse: [implementorsCount printString , ' implementors']. - strm nextPutAll: implementorsCount ]. - [#priorVersionsCount] -> [ - self addPriorVersionsCountForSelector: aSelector ofClass: aClass to: strm]. - [#priorTimeStamp] -> [ | stamp | - stamp _ VersionsBrowser - timeStampFor: aSelector - class: aClass - reverseOrdinal: 2. - strm nextPutAll: 'prior timestamp: '; nextPutAll: (stamp ifNil: ['None']) ]. - [#packages] -> [ - (aClass compiledMethodAt: aSelector ifAbsent: nil) ifNotNil: [ :cm | - (CodePackage packageOfMethod: cm methodReference ifNone: nil) - ifNil: [ strm nextPutAll: 'in no package' ] - ifNotNil: [ :codePackage | - strm nextPutAll: 'in package '; nextPutAll: codePackage packageName ]]]. - [#changeSets] -> [ | aList | - aList _ ChangeSet allChangeSetsWithClass: aClass selector: aSelector. - aList size > 0 - ifTrue: [ aList size = 1 - ifTrue: [strm nextPutAll: 'only in change set'] - ifFalse: [strm nextPutAll: 'in change sets:']. - aList - do: [:aChangeSet | strm nextPut: Character space; nextPutAll: aChangeSet name ] - separatedBy: [ strm nextPut: $, ]] - ifFalse: [strm nextPutAll: 'in no change set']]. - [#allChangeSets] -> [ | aList | - aList _ ChangeSet allChangeSetsWithClass: aClass selector: aSelector. - aList size > 0 - ifTrue: [ aList size = 1 - ifTrue: [strm nextPutAll: 'only in change set'] - ifFalse: [strm nextPutAll: 'in change sets:']. - aList - do: [:aChangeSet | strm nextPut: Character space; nextPutAll: aChangeSet name ] - separatedBy: [ strm nextPut: $, ]] - ifFalse: [strm nextPutAll: 'in no change set']]. - [#allBaseSystemChangeSets] -> [ | aList | - aList _ (ChangeSet allChangeSetsWithClass: aClass selector: aSelector) select: [ :it | it isForBaseSystem ]. - aList size > 0 - ifTrue: [ aList size = 1 - ifTrue: [strm nextPutAll: 'only in base system change set'] - ifFalse: [strm nextPutAll: 'in base system change sets:']. - aList - do: [:aChangeSet | strm nextPut: Character space; nextPutAll: aChangeSet name ] - separatedBy: [ strm nextPut: $, ]] - ifFalse: [strm nextPutAll: 'in no base system change set']]. - [#closuresInfo] -> [ - strm nextPutAll: (aClass closuresInfoAt: aSelector)]. - - }] - separatedBy: [ strm nextPutAll: self annotationSeparator ] ].! ! -!CodeProvider methodsFor: 'annotation' stamp: 'jmv 10/13/2021 12:03:08' prior: 50610645! - annotationForSystemCategory: aCategory - "Provide a line of content for an annotation pane, given that the receiver is pointing at a System Category (i.e. a group of classes)." - - ^ String streamContents: [ :strm | - strm - nextPutAll: 'System Category: '; - nextPutAll: aCategory. - Preferences systemCategoryAnnotations do: [ :each | - strm nextPutAll: self annotationSeparator. - each caseOf: { - [#classCount] -> [ - strm - print: (SystemOrganization listAtCategoryNamed: aCategory) size; - nextPutAll: ' classes' ]. - [#instanceMethodsCount] -> [ - strm - print: (SystemOrganization instanceMethodCountOf: aCategory); - nextPutAll: ' instance methods' ]. - [#classMethodsCount] -> [ - strm - print: (SystemOrganization classMethodCountOf: aCategory); - nextPutAll: ' class methods' ]. - [#linesOfCode] -> [ - strm - print: (SystemOrganization linesOfCodeOf: aCategory); - nextPutAll: ' total lines of code' ] - }]].! ! -!Preferences class methodsFor: 'themes' stamp: 'jmv 10/13/2021 11:40:06' prior: 50611046! - slowMachine - " - Preferences slowMachine - " - self setPreferencesFrom: #( - #(#drawKeyboardFocusIndicator false ) - (balloonHelpEnabled false) - (browseWithPrettyPrint false) - (caseSensitiveFinds true) - (checkForSlips false) - (cmdDotEnabled true) - (diffsInChangeList true) - (diffsWithPrettyPrint false) - (menuKeyboardControl false) - (optionalButtons false) - (subPixelRenderFonts true) - (thoroughSenders true) - (cheapWindowReframe true) - (syntaxHighlightingAsYouType false) - (tapAndHoldEmulatesButton2 false) - (clickGrabsMorphs true) - ). - self useNoMenuIcons. - self runningWorld backgroundImageData: nil. - Preferences setQuickAnnotationsInBrowsers. - " - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - Taskbar hideTaskbar - "! ! - -Preferences class removeSelector: #setDefaultMethodAnnotations! - -Preferences class removeSelector: #setCheapAnnotationInfo! - -!methodRemoval: Preferences class #setCheapAnnotationInfo stamp: 'Install-4913-EnhancementsToBrowserAnnotations-JuanVuletich-2021Oct13-11h30m-jmv.001.cs.st 10/14/2021 14:32:41'! -setCheapAnnotationInfo - " - Preferences setCheapAnnotationInfo - " - ^ self parameters at: #MethodAnnotations put: #(timeStamp messageCategory packages changeSets)! - -Preferences class removeSelector: #setQuickMethodAnnotations! - -Preferences class removeSelector: #defaultAnnotationRequests! - -!methodRemoval: Preferences class #defaultAnnotationRequests stamp: 'Install-4913-EnhancementsToBrowserAnnotations-JuanVuletich-2021Oct13-11h30m-jmv.001.cs.st 10/14/2021 14:32:41'! -defaultAnnotationRequests - ^ self parameters at: #MethodAnnotations ifAbsent: - [self setDefaultAnnotationInfo] - "Preferences annotationInfo"! - -Preferences class removeSelector: #setDefaultAnnotationInfo! - -!methodRemoval: Preferences class #setDefaultAnnotationInfo stamp: 'Install-4913-EnhancementsToBrowserAnnotations-JuanVuletich-2021Oct13-11h30m-jmv.001.cs.st 10/14/2021 14:32:41'! -setDefaultAnnotationInfo - " - Preferences setDefaultAnnotationInfo - " - ^ self parameters at: #MethodAnnotations put: #(timeStamp linesOfCode messageCategory implementorsCount sendersCount packages changeSets)! - -CodeProvider removeSelector: #xannotationForSelector:ofClass:! - -CodeProvider removeSelector: #annotationRequests! - -!methodRemoval: CodeProvider #annotationRequests stamp: 'Install-4913-EnhancementsToBrowserAnnotations-JuanVuletich-2021Oct13-11h30m-jmv.001.cs.st 10/14/2021 14:32:41'! -annotationRequests - ^ Preferences defaultAnnotationRequests! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4913-EnhancementsToBrowserAnnotations-JuanVuletich-2021Oct13-11h30m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4908] on 10 October 2021 at 10:02:15 am'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 10/10/2021 09:40:22' prior: 50609502! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag - "This is the main method for image save and / or quit. - See senders." - "WARNING: Current process will be killed. UI Process will be restarted" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic - checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " - | activeProc | - activeProc _ Processor activeProcess. - [ | isARealStartup guiRootObject guiRootObjectClass | - save not & quit - ifTrue: [ - (SourceFiles at: 2) ifNotNil: [ :changes | - ChangesInitialFileSize ifNotNil: [ changes truncate: ChangesInitialFileSize ]]] - ifFalse: [ - self - logSnapshot: save - andQuit: quit ]. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | - each isInWorld ifTrue: [ - each delete.]]. - UISupervisor ui tearDownDesktop. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - "These could be moved to some #shutDown" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - "Stuff needed to relaunch UI on startup" - guiRootObjectClass _ UISupervisor ui class. - guiRootObject _ UISupervisor ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "guiRootObject _ clearAllStateFlag ifFalse: [ UISupervisor ui ]." - UISupervisor stopUIProcess. - activeProc isTerminated ifFalse: [ activeProc terminate ]. - guiRootObject ifNotNil: [ guiRootObject releaseCachedState ]. - "Clean Globals" - Smalltalk - at: #Sensor - put: nil. - Smalltalk - at: #Display - put: nil. - Smalltalk closeSourceFiles. - Smalltalk - at: #SourceFiles - put: nil. - Smalltalk allClassesDo: [ :cls | - cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | - cls releaseClassState ]]. - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ - Smalltalk printStuffToCleanOnImageSave. - "Remove this call to actually see the image clean report." - Transcript clear. - ]. - "Do image save & quit as apropriate" - (Cursor cursorAt: #writeCursor) activateCursor. - save - ifTrue: [ - "The snapshot primitive answers false if it was just called to do the snapshot. - But image startup is resumed by returning (again) from the primitive, but this time answering true." - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk - at: #Sensor - put: nil. - Smalltalk - at: #Display - put: DisplayScreen new. - Smalltalk - at: #SourceFiles - put: (Array new: 2). - Smalltalk openSourceFiles. - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | - cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - UISupervisor spawnNewMorphicProcessFor: (guiRootObject ifNil: [ guiRootObject _ guiRootObjectClass newWorld ]). - self restoreLostChangesIfNecessary. - clearAllStateFlag ifTrue: [ - UISupervisor whenUIinSafeState: [ - guiRootObject recreateDefaultDesktop; restoreDisplay ]] - ifFalse: [ - UISupervisor whenUIinSafeState: [ - guiRootObject restoreDisplay ]]. - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - UISupervisor whenUIinSafeState: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]] - forkAt: Processor timingPriority - 1 - named: 'Startup process'.! ! -!HandMorph methodsFor: 'caching' stamp: 'jmv 10/9/2021 20:21:34' prior: 16851468 overrides: 50590334! - releaseCachedState - | oo | - super releaseCachedState. - oo _ owner. - self removeAllMorphs. - self initialize. "nuke everything" - self privateOwner: oo. - self releaseAllFoci. - savedPatch _ nil.! ! -!WorldMorph methodsFor: 'caching' stamp: 'jmv 10/10/2021 09:41:57' prior: 50552043 overrides: 50550801! - releaseCachedState - super releaseCachedState. - self cleanseStepList. - self clearCanvas. - hands do: [ :h | h releaseCachedState ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4914-ReleaseHandSavedPatch-onImageSave-JuanVuletich-2021Oct10-10h01m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4908] on 11 October 2021 at 7:04:32 pm'! -!WindowEdgeAdjustingMorph methodsFor: 'geometry' stamp: 'jmv 10/11/2021 18:36:56' overrides: 50499537! - minimumExtent - "This returns the minimum extent that the morph may be shrunk to. - It is expressed in the morph own coordinates, like morphExtent." - - ^ `0@0`! ! -!BitBltCanvas methodsFor: 'drawing-windows' stamp: 'jmv 10/11/2021 18:11:33'! - roundEdge: aRectangle border: borderWidth color: borderColor - "NOP here"! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 10/11/2021 18:18:53' prior: 50603381! - collides: aMorph - "Answer whether the pixels used by morphs touch at least at one place. - Morphs not in the WidgetMorph hierarchy should answer #true to wantsContour." - - privateDisplayBounds ifNil: [ - ^false ]. - - "Quick check with display bounds" - (aMorph displayBoundsIntersects: privateDisplayBounds) ifFalse: [ - ^false ]. - - "Precise check with contour, if available" - (self valueOfProperty: #contour) ifNotNil: [ :contour | | contourTop contourBottom | - contourTop _ self valueOfProperty: #contourY0. - contourBottom _ self valueOfProperty: #contourY1. - ^ aMorph contourIntersects: contour top: contourTop bottom: contourBottom ]. - - "If contour is not available, and both displayBounds overlap, answer true, as it is the best we can know." - ^ true! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 10/11/2021 18:16:43' prior: 50613090! - on: aRectangle ifCovered: partiallyOrTotallyCoveredBlock uncoveredPartsDo: uncoveredPartBlock else: notCoveredAtAllBlock - "Find rectangles encompassing those areas in aRectangle not completely - covered by self. These are the areas that might require further drawing (of morphs below us) - All areas that might possibly be uncovered must be included. - - If aRectangle is not covered at all, or for whatever reason we don't know, evaluate notCoveredAtAllBlock. - Othewise evaluate partiallyOrTotallyCoveredBlock once, and also evaluate uncoveredPartBlock for each part in aRectangle we don't cover." - - ^ notCoveredAtAllBlock value! ! -!Morph methodsFor: 'updating' stamp: 'jmv 10/11/2021 18:19:02' prior: 50596726! - invalidateBounds - "Report that the area occupied by this morph and submorphs should be redrawn, - but most likely we are not going to be redrawn on it, or maybe we'll not be fully visible. See senders." - - self displayFullBounds ifNotNil: [ :r | - "outsetBy: 1 due to anti aliasing in VectorCanvas" - self invalidateDisplayRect: r for: nil ]. -! ! -!Morph methodsFor: 'updating' stamp: 'jmv 10/11/2021 18:19:08' prior: 50604380! - redrawNeeded - "Report that the area occupied by this morph should be redrawn. - Usually because we changed in some way. - Notes: - Area used before any change is reported here. - Area used after any changes is reported when displayBounds are updated. - See updateBoundsIn:addDamageTo: and senders. - " - - self needsRedraw: true. - self allOwnersDo: [ :m | m submorphNeedsRedraw: true ]. - self basicDisplayBounds ifNotNil: [ :b | - "outsetBy: 1 due to anti aliasing in VectorCanvas" - self invalidateDisplayRect: b for: self ]. - (self submorphsMightProtrude and: [self clipsSubmorphsReally not]) ifTrue: [ - self submorphsReverseDo: [ :m | m redrawNeeded ]]. - self removeProperty: #bitMask. - self removeProperty: #fullBoundsInOwner.! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 10/11/2021 18:19:14' prior: 50613211! - displayFullBoundsForPatch - "Current full bounds of hand and carried submorphs. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around). - Integer pixel coordinates!!" - - | handBounds fullBounds | - handBounds _ self displayBounds. - fullBounds _ handBounds copy. - self submorphsDo: [ :m | - fullBounds updateMerging: m displayFullBounds]. - lastPosition - ifNotNil: [ :lastPos | "When already carrying morphs around. Update rectangle to current hand position." - fullBounds _ (fullBounds translatedBy: self morphPosition-lastPos) updateMerging: handBounds ]. - ^fullBounds encompassingIntegerRectangle! ! -!WindowEdgeAdjustingMorph methodsFor: 'drawing' stamp: 'jmv 10/11/2021 19:02:52' prior: 50593134 overrides: 50503570! - drawOn: aCanvas - - | c | - (owner is: #SystemWindow) ifFalse: [ - ^super drawOn: aCanvas ]. - - "Use almost transparent, so effect on antialiasing for drawing exactly on top of Window is kept to a minimum." - c _ owner windowFrameColor alpha: 0.1. - selector caseOf: { - [ #windowTopLeft: ] -> [ - aCanvas roundTopLeftCornerX: 0 y: 0 length: extent x border: owner borderWidth color: c ]. - [ #windowTopRight: ] -> [ - aCanvas roundTopRightCornerX: 0 y: 0 length: extent x border: owner borderWidth color: c ]. - [ #windowBottomLeft: ] -> [ - aCanvas roundBottomLeftCornerX: 0 y: 0 length: extent x border: owner borderWidth color: c ]. - [ #windowBottomRight: ] -> [ - aCanvas roundBottomRightCornerX: 0 y: 0 length: extent x border: owner borderWidth color: c ]. - } - otherwise: [ - "all the morph is sensitive for horizontal and vertical (i.e. non corner) instances." - aCanvas roundEdge: self morphLocalBounds border: owner borderWidth color: c ].! ! -!WindowEdgeAdjustingMorph methodsFor: 'geometry services' stamp: 'jmv 10/11/2021 18:46:51' prior: 50608678 overrides: 50608610! - coversLocalPoint: aLocalPoint - "We don't completely cover our bounds. Account for that." - - | sensitiveBorder | - sensitiveBorder _ owner borderWidth. - ((self morphLocalBounds outsetBy: sensitiveBorder) containsPoint: aLocalPoint) ifFalse: [ ^false ]. - selector caseOf: { - [ #windowTopLeft: ] -> [ ^ aLocalPoint x < sensitiveBorder or: [ aLocalPoint y < sensitiveBorder ]]. - [ #windowTopRight: ] -> [ ^ extent x - aLocalPoint x <= sensitiveBorder or: [ aLocalPoint y < sensitiveBorder ]]. - [ #windowBottomLeft: ] -> [ ^ aLocalPoint x < sensitiveBorder or: [ extent y- aLocalPoint y <= sensitiveBorder ]]. - [ #windowBottomRight: ] -> [ ^ extent x - aLocalPoint x <= sensitiveBorder or: [ extent y - aLocalPoint y <= sensitiveBorder ]]. - } - otherwise: [ - "all the morph is sensitive for horizontal and vertical (i.e. non corner) instances." - ^true ]! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 10/11/2021 18:35:41' prior: 50578697! - drawClassicFrameOn: aCanvas color: windowFrameColor - "Window border encompasses title area. No round corners. No title gradient." - - aCanvas fillRectangle: (self morphLocalBounds insetBy: 1.5) color: color borderWidth: borderWidth borderStyleSymbol: #simple baseColorForBorder: self widgetsColor. - - "A border was drawn at the left, top and right of the title area. - The look is that the title area is inside the window" - aCanvas fillRectangle: (borderWidth@borderWidth extent: extent x - (2*borderWidth)@ self labelHeight) color: windowFrameColor! ! -!SystemWindow methodsFor: 'geometry services' stamp: 'jmv 10/11/2021 18:20:52' prior: 50613743 overrides: 50615890! - on: aRectangle ifCovered: partiallyOrTotallyCoveredBlock uncoveredPartsDo: uncoveredPartBlock else: notCoveredAtAllBlock - "Find rectangles encompassing those areas in aRectangle not completely - covered by self. These are the areas that might require further drawing (of morphs below us) - All areas that might possibly be uncovered must be included. - - If aRectangle is not covered at all, or for whatever reason we don't know, evaluate notCoveredAtAllBlock. - Othewise evaluate partiallyOrTotallyCoveredBlock once, and also evaluate uncoveredPartBlock for each part in aRectangle we don't cover." - - | bounds r e r2 | - self isOrAnyOwnerIsRotated ifTrue: [ - ^ notCoveredAtAllBlock value ]. - - color mightBeTranslucent ifTrue: [ - ^ notCoveredAtAllBlock value ]. - - "Due to possible anti aliasing, and possible conversion to integer, we can't be really sure - about the 2 outer pixels at each edge." - bounds _ self displayBounds insetBy: 2. - bounds ifNil: [ - ^ notCoveredAtAllBlock value ]. - - (aRectangle intersects: bounds) ifFalse: [ - ^ notCoveredAtAllBlock value ]. - - "Solid rectangle. - This will be the fastest in many cases. So, please disable rounded corners if on slow hardware!!" - partiallyOrTotallyCoveredBlock value. - aRectangle areasOutside: bounds do: [ :rect | uncoveredPartBlock value: rect ]. - - Theme current roundWindowCorners ifTrue: [ - r _ Theme current roundedWindowRadius * 1.1. "A bit more than actual radius because we use Bezier, not arc." - e _ self externalizeDistanceToWorld: r@r. - r2 _ aRectangle intersect: (bounds topLeft extent: e). - r2 hasPositiveExtent ifTrue: [ uncoveredPartBlock value: r2 ]. - r2 _ aRectangle intersect: (bounds topRight - (e x@0) extent: e). - r2 hasPositiveExtent ifTrue: [ uncoveredPartBlock value: r2 ]. - r2 _ aRectangle intersect: (bounds bottomLeft - (0@ e y)extent: e). - r2 hasPositiveExtent ifTrue: [ uncoveredPartBlock value: r2 ]. - r2 _ aRectangle intersect: (bounds bottomRight - e extent: e). - r2 hasPositiveExtent ifTrue: [ uncoveredPartBlock value: r2 ]. - ].! ! -!SystemWindow methodsFor: 'layout' stamp: 'jmv 10/11/2021 19:02:41' prior: 50541191 overrides: 50537644! - layoutSubmorphs - "Compute a new layout of submorphs based on the given layout bounds." - - | h thickness w cornerExtent wh ww pos halfThickness | - thickness _ self borderWidth. - halfThickness _ thickness * 0.5. - cornerExtent _ thickness * 5. - ww _ extent x. - wh _ extent y. - w _ ww - cornerExtent - cornerExtent. - h _ wh - cornerExtent - cornerExtent. - (adjusters at: #topAdjuster) morphPosition: cornerExtent@halfThickness extent: w@0. - (adjusters at: #bottomAdjuster) morphPosition: cornerExtent@(wh-halfThickness) extent: w@0. - (adjusters at: #leftAdjuster) morphPosition: halfThickness@cornerExtent extent: 0@h. - (adjusters at: #rightAdjuster) morphPosition: ww-halfThickness@cornerExtent extent: 0@h. - (adjusters at: #topLeftAdjuster) morphPosition: `0@0` extent: cornerExtent@cornerExtent. - (adjusters at: #topRightAdjuster) morphPosition: ww-cornerExtent@0 extent: cornerExtent@cornerExtent. - (adjusters at: #bottomLeftAdjuster) morphPosition: 0@(wh-cornerExtent) extent: cornerExtent@cornerExtent. - (adjusters at: #bottomRightAdjuster) morphPosition: ww@wh-cornerExtent extent: cornerExtent@cornerExtent. - - layoutMorph ifNotNil: [ - pos _ borderWidth @ (borderWidth + self labelHeight). - layoutMorph - morphPosition: pos - extent: extent - pos - borderWidth ]. - - self layoutNeeded: false.! ! -!MorphicCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 11/9/2020 15:28:39' prior: 50555876! - fillRectangle: aRectangle color: aColor borderWidth: borderWidth borderStyleSymbol: aSymbol baseColorForBorder: baseColorForBorder - " - (BitBltCanvas onForm: Display) - fillRectangle: (10@10 extent: 300@200) - color: Color green - borderWidth: 10 - borderStyleSymbol: #raised - baseColorForBorder: Color red. - Display forceToScreen. - " - - self fillRectangle: (aRectangle insetBy: borderWidth) color: aColor. - self frameRectangle: aRectangle color: baseColorForBorder borderWidth: borderWidth borderStyleSymbol: aSymbol! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/11/2021 18:18:35' prior: 50604734! - boundingRectOfCurrentMorphAfterDraw - "In targetForm coordinates. - Clipped to owner if appropriate. - Only valid for morphs where #morphLocalBounds is known. - Subclasses may raise this restriction. See inherintance, with VectorGraphics package loaded." - - | boundingRect | - boundingRect _ currentTransformation displayBoundsOfTransformOf: currentMorph morphLocalBounds. - "Include an extra pixel to cover possible anti aliasing." - boundingRect _ boundingRect outsetBy: 1. - ^ clippingMorphDisplayBounds - ifNotNil: [ :ownerClips | boundingRect intersect: ownerClips ] - ifNil: [ boundingRect ]! ! -!Theme methodsFor: 'other options' stamp: 'jmv 12/7/2010 14:32' prior: 16935698! - roundWindowCorners - ^true! ! - -BitBltCanvas removeSelector: #roundEdge:color:! - -!methodRemoval: BitBltCanvas #roundEdge:color: stamp: 'Install-4915-WindowEdgeAdjustersTweaks-JuanVuletich-2021Oct11-18h11m-jmv.001.cs.st 10/14/2021 14:32:41'! -roundEdge: aRectangle color: aColor - "NOP here"! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4915-WindowEdgeAdjustersTweaks-JuanVuletich-2021Oct11-18h11m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4910] on 12 October 2021 at 10:22:15 am'! -!MethodNode methodsFor: 'printing' stamp: 'jmv 10/12/2021 09:48:02' prior: 16872784! - printPrimitiveOn: aStream - "Print the primitive on aStream" - | primDecl | - primitive = 0 ifTrue: - [^self]. - primitive = 120 ifTrue: "External call spec" - [^aStream print: encoder literals first]. - aStream nextPutAll: '. - ((Smalltalk classNamed: #StackInterpreter) ifNil: [Smalltalk classNamed: #Interpreter]) ifNotNil: - [:interpreterClass| - aStream nextPutAll: ' "', ((interpreterClass primitiveTable) at: primitive + 1), '" ']! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4916-MethodNode-fix-JuanVuletich-2021Oct12-09h48m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4911] on 12 October 2021 at 11:15:05 am'! -!MorphicCanvas methodsFor: 'private' stamp: 'jmv 10/12/2021 11:06:35' prior: 50604295! - clippingByCurrentMorphDo: aBlock - "Do clipping only if currentMorph says so" - - | prevClipRect prevClippingMorphRect | - - currentMorph clipsSubmorphsReally ifFalse: [ ^aBlock value ]. - - prevClipRect _ self clipRect. - prevClippingMorphRect _ clippingMorphDisplayBounds. - clippingMorphDisplayBounds _ self boundingRectOfCurrentMorphAfterDraw insetBy: 1. - self setClipRect: (prevClipRect - ifNil: [clippingMorphDisplayBounds] - ifNotNil: [prevClipRect intersect: clippingMorphDisplayBounds]). - self clipCurrentMorph: true. - aBlock ensure: [ - self clipCurrentMorph: false. - self setClipRect: prevClipRect. - clippingMorphDisplayBounds _ prevClippingMorphRect ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4917-Morphic-smallFix-JuanVuletich-2021Oct12-11h14m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4912] on 12 October 2021 at 6:34:24 pm'! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 10/12/2021 18:29:15' prior: 50537419! - fullDrawHandOn: aCanvas - "A HandMorph has an unusual drawing requirement: - The hand itself (i.e., the cursor) appears in front of its submorphs - The illusion is that the hand plucks up morphs and carries them above the world." - - submorphs reverseDo: [ :m | aCanvas fullDraw: m ]. - self drawOn: aCanvas. "draw the hand itself in front of morphs" - lastPosition _ self morphPosition. "We already know we are carrying morphs."! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 10/12/2021 18:34:03' prior: 50615953! -displayFullBoundsForPatch - "Current full bounds of hand and carried submorphs. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around). - Integer pixel coordinates!!" - - | handBounds fullBounds submorphBounds | - handBounds _ self displayBounds. - submorphBounds _ nil. - self submorphsDo: [ :m | - submorphBounds _ m displayFullBounds quickMerge: submorphBounds ]. - fullBounds _ handBounds quickMerge: submorphBounds. - lastPosition - ifNotNil: [ :lastPos | "When already carrying morphs around. Update rectangle to current hand position." - fullBounds _ fullBounds quickMerge: (submorphBounds translatedBy: self morphPosition-lastPos) ]. - ^fullBounds encompassingIntegerRectangle! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 10/12/2021 18:30:46' prior: 50612998 overrides: 50611817! - morphPosition: aPoint - "Change the position of this morph. Argument is in owner's coordinates." - - | prevTranslation | - prevTranslation _ location translation. - location _ location withTranslation: aPoint. - "Ask if translation effectively changed, after possible conversion to 32 bit Float in AffineTransformation. " - location translation = prevTranslation ifFalse: [ - self isDrawnBySoftware - ifTrue: [ - Preferences cacheDisplayContentWhenMovingMorphs - ifTrue: [ - "We are caching whatever is in the Display below us. Thefore, there's no need - to do an invalidation that would trigger the redraw of everything below us." - self needsRedraw: true ] - ifFalse: [ - "No caching of stuff below us. Just invalidate and redraw." - self redrawNeeded ]] - ifFalse: [ - lastPosition _ nil. "Not nil if carrying morphs at that moment" - prevFullBounds _ nil "Any saved patch is no longer relevant"]].! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 10/12/2021 18:28:52' prior: 50579748! - grabMorph: aMorph delta: delta - "Grab the given morph (i.e., add it to this hand and remove it from its current owner)." - - | formerOwner formerPositionInWorld | - self releaseMouseFocus. "Break focus" - - "Grab the halo if present" - self halo ifNotNil: [ :h | - (h target == aMorph or: [h target hasOwner: aMorph]) ifTrue: [ - self addMorphBack: h position: h morphPositionInWorld - self morphPositionInWorld ]]. - - "Remember previous owner and position, in case the drop is later rejected" - formerOwner _ aMorph owner. - formerOwner ifNotNil: [ - formerPositionInWorld _ aMorph morphPositionInWorld. - grabMorphData - at: aMorph - put: { formerOwner. formerPositionInWorld. } ]. - self addMorphBack: aMorph position: delta. - - aMorph displayBounds ifNotNil: [ :r | | d | - formerPositionInWorld ifNotNil: [ - d _ aMorph morphPositionInWorld - formerPositionInWorld. - d isZero ifFalse: [ - aMorph adjustDisplayBoundsBy: d ]]]. - - aMorph justGrabbedFrom: formerOwner. - formerOwner ifNotNil: [ - "Morph was in the world" - lastPosition _ self morphPosition ].! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 10/12/2021 18:10:26' prior: 50612806! - grabMorph: aMorph moveUnderHand: moveUnderHand - "Grab the given morph (i.e., add it to this hand and remove it from its current owner). - If moveUnderHand is requested or it seems neccesary anyway, move the grabbed morph under the hand." - - | grabbed positionInHandCoordinates tx bounds | - self releaseMouseFocus. "Break focus" - grabbed _ aMorph. - aMorph owner ifNotNil: [ :o | grabbed _ o aboutToGrab: aMorph ]. - grabbed ifNil: [ ^ self ]. - grabbed _ grabbed aboutToBeGrabbedBy: self. - grabbed ifNil: [ ^ self ]. - self hideHardwareCursor. - self redrawNeeded. - - moveUnderHand ifTrue: [ - bounds _ nil. - grabbed isInWorld ifTrue: [ - grabbed displayBounds ifNotNil: [ :r | - bounds _ r translatedBy: grabbed morphPositionInWorld negated ]]. - bounds ifNil: [ bounds _ grabbed findFullBoundsInOwner ]. - positionInHandCoordinates _ (bounds center + bounds bottomRight //2) negated. - self grabMorph: grabbed delta: positionInHandCoordinates. - ^self ]. - - positionInHandCoordinates _ (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) - morphPositionInWorld - self morphPositionInWorld. - - tx _ GeometryTransformation identity. - (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) withAllOwnersDo: [ :o | - tx _ o location composedWith: tx ]. - self withAllOwnersReverseDo: [ :o | - tx _ o location inverseTransformation composedWith: tx ]. - self grabMorph: grabbed delta: positionInHandCoordinates. - - grabbed location: tx.! ! -!WorldMorph methodsFor: 'drawing' stamp: 'jmv 10/12/2021 16:41:47' prior: 50613235! - displayWorld - "Update this world's display." - - | deferredUpdateVMMode allDamage | - self checkIfUpdateNeeded ifFalse: [ ^ self ]. "display is already up-to-date" - - "I (jmv) removed the call to 'deferUpdates: false' below. No more need to call this every time. ?? revisar." - deferredUpdateVMMode _ self tryDeferredUpdatingAndSetCanvas. - - "Restore world canvas under hands and their carried morphs" - Preferences cacheDisplayContentWhenMovingMorphs ifTrue: [ - hands do: [ :h | h restoreSavedPatchOn: canvas ]]. - - "Update #displayBounds for all dirty morphs (marked as such with #redrawNeeded). - Also add the updated bounds to aDamageRecorder, and update bounds of morphs carried by hand." - canvas boundsFinderCanvas updateBoundsIn: self addDamageTo: damageRecorder. - - "repair world's damage on canvas" - allDamage _ canvas drawWorld: self repair: damageRecorder. - "allDamage ifNotNil: [Display border: allDamage width: 3 fillColor: Color random]. 'Debugging Aid'." - canvas newClipRect: nil. - - "Check which hands need to be drawn. - (they are not the hardware mouse pointer and carry morphs)" - self handsToDrawForDamage: allDamage do: [ :h | - Preferences cacheDisplayContentWhenMovingMorphs - ifTrue: [ allDamage _ (h savePatchFrom: canvas) quickMerge: allDamage ] - ifFalse: [ allDamage _ h displayFullBoundsForPatch quickMerge: allDamage ]. - canvas fullDrawHand: h . - h needsRedraw: false ]. - - "quickly copy altered rects of canvas to Display:" - deferredUpdateVMMode ifFalse: [ - allDamage ifNotNil: [ - "Drawing was done to off-Display canvas. Copy content to Display" - canvas showAt: self viewBox origin invalidRect: allDamage ]]. - - "Display deferUpdates: false." - "Display forceDisplayUpdate" - allDamage ifNotNil: [ - DisplayScreen isDisplayExtentOk ifTrue: [ - Display forceToScreen: allDamage ]].! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/12/2021 16:41:53' prior: 50613430! - drawWorld: aWorldMorph repair: aDamageRecorder - "Redraw the damaged areas and clear the damage list. - Return a collection of the areas that were redrawn. - Draw each morph just once, merging rectanges to be repaired as needed." - - | visibleRootMorphs visibleRootsDamage worldBackgroundRects | - visibleRootMorphs _ aWorldMorph privateSubmorphs select: [ :m | m visible ]. - visibleRootsDamage _ Array new: visibleRootMorphs size. - - worldBackgroundRects _ self computeDamage: aWorldMorph repair: aDamageRecorder - rootMorphs: visibleRootMorphs rootMorphsDamage: visibleRootsDamage. - aDamageRecorder reset. - - self drawWorldBackground: aWorldMorph rects: worldBackgroundRects. - "Debugging aids." - " - worldBackgroundRects do: [ :r | Display fill: r fillColor: Color random . Display forceToScreen. (Delay forSeconds: 0.005) wait]. - "" - visibleRootsDamage do: [ :r | r ifNotNil: [ Display fill: r fillColor: Color random . Display forceToScreen. (Delay forSeconds: 0.05) wait]]. - " - - ^ self drawWorld: aWorldMorph - rootMorphs: visibleRootMorphs rootMorphsDamage: visibleRootsDamage - backgroundDamage: worldBackgroundRects.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4918-HandInvalidationFixes-JuanVuletich-2021Oct12-18h18m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4913] on 12 October 2021 at 7:11:31 pm'! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 10/12/2021 19:10:33' prior: 50603408! - drawCurrentAsError - "The morph (or one of its submorphs) had an error in its drawing method." - | r w | - r _ currentMorph morphLocalBoundsForError. - w _ r extent > `50@50` - ifTrue: [ 6 ] - ifFalse: [ 2 ]. - self - frameAndFillRectangle: r - fillColor: `Color red` - borderWidth: w - borderColor: `Color yellow`. - self line: r topLeft+1 to: r bottomRight-w width: w color: `Color yellow`. - self line: r topRight + (w negated@1) to: r bottomLeft + (1@ w negated) width: w color: `Color yellow`. - currentMorph displayBoundsSetFrom: self.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4919-DrawCurrentAsError-tweak-JuanVuletich-2021Oct12-19h02m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4919] on 13 October 2021 at 2:18:53 pm'! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 10/13/2021 14:18:16' prior: 50535984! - strictlyStaggeredInitialFrameFor: aStandardSystemView initialExtent: initialExtent world: aWorld - "This method implements a staggered window placement policy that I (di) like. - Basically it provides for up to 4 windows, staggered from each of the 4 corners. - The windows are staggered so that there will always be a corner visible." - - | allowedArea grid initialFrame otherFrames cornerSel corner delta putativeCorner free maxLevel | - allowedArea := (self maximumUsableAreaInWorld: aWorld) - insetBy: (self scrollBarSetback @ self screenTopSetback extent: `0 @ 0`). - "Number to be staggered at each corner (less on small screens)" - maxLevel := allowedArea area > 300000 ifTrue: [3] ifFalse: [2]. - "Amount by which to stagger (less on small screens)" - grid := allowedArea area > 500000 ifTrue: [40] ifFalse: [20]. - initialFrame := `0 @ 0` extent: initialExtent. - "min: (allowedArea extent - (grid*(maxLevel+1*2) + (grid//2)))) - min: 600@400" - otherFrames := (SystemWindow windowsIn: aWorld satisfying: [ :w | w visible and: [w isCollapsed not]]) - collect: [:w | w displayBounds]. - otherFrames _ otherFrames reject: [ :f | f isNil ]. - 0 to: maxLevel do: [ :level | - 1 to: 4 do: [ :ci | - cornerSel := #(#topLeft #topRight #bottomRight #bottomLeft) at: ci. - corner := allowedArea perform: cornerSel. - "The extra grid//2 in delta helps to keep title tabs distinct" - delta := ((maxLevel - level) * grid + (grid // 2)) @ (level * grid). - 1 to: ci - 1 do: [ :i | delta _ delta y negated @ delta x ]. "slow way" - putativeCorner := corner + delta. - free := true. - otherFrames do: [ :w | - free := free & (((w perform: cornerSel) - putativeCorner)r > 5)]. - free - ifTrue: [ - ^(initialFrame aligned: (initialFrame perform: cornerSel) - with: putativeCorner) translatedAndSquishedToBeWithin: allowedArea]]]. - "If all else fails..." - ^(self scrollBarSetback @ self screenTopSetback - extent: initialFrame extent) translatedAndSquishedToBeWithin: allowedArea! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4920-NewWindowPositionFix-JuanVuletich-2021Oct13-14h15m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4920] on 13 October 2021 at 2:55:43 pm'! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 10/13/2021 14:55:36' prior: 50579479! - drawRoundLookOn: aCanvas - | r colorForButton rect | - colorForButton _ self isPressed - ifFalse: [ - self mouseIsOver - ifTrue: [ Color h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ color ]] - ifTrue: [ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - rect _ self morphLocalBounds insetBy: `3@3`. - aCanvas roundRect: rect color: colorForButton radius: r ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawEmbossedLabelOn: aCanvas ] - ifFalse: [ self drawRegularLabelOn: aCanvas ].! ! - -DraggeableButtonMorph removeSelector: #isRoundButton! - -!methodRemoval: DraggeableButtonMorph #isRoundButton stamp: 'Install-4921-ModernizeScrollbars-JuanVuletich-2021Oct13-14h47m-jmv.001.cs.st 10/14/2021 14:32:41'! -isRoundButton - ^false! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4921-ModernizeScrollbars-JuanVuletich-2021Oct13-14h47m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4895] on 10 October 2021 at 12:58:06 pm'! -!HoverHelpMorph methodsFor: 'accessing' stamp: 'hlsf 10/10/2021 12:55:12' prior: 16853855! - contents: aString - | width | - contents _ aString. - width _ (contents includes: Character lf) - ifTrue: [9999999] ifFalse: [300]. - textComposition _ TextComposition new. - textComposition - setModel: (TextModel withText: contents asText); - extentForComposing: width@9999999. - textComposition composeAll. - self morphExtent: textComposition usedExtent + 8! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4922-HoverHelpMorph-CuisCore-HilaireFernandes-2021Oct10-12h47m-hlsf.001.cs.st----! - -'From Cuis 5.0 [latest update: #4922] on 13 October 2021 at 8:21:22 pm'! -!Integer methodsFor: 'mathematical functions' stamp: 'sqr 10/11/2021 21:24:29' prior: 16859572! - ifMultipleOf2And5Do: aBlock otherwise: anotherBlock - "If our prime factorization consists only of 2's and 5's, evaluate aBlock with the exponents. - Otherwise evaluate anotherBlock. - Be fast!!" - - | exponent2 exponent5 without2Factors | - exponent2 _ self lowBit-1. - without2Factors _ self bitShift: exponent2 negated. - exponent5 _ ( 0.430676558073393 "2 ln / 5 ln" * without2Factors highBit) truncated. - (5 raisedToInteger: exponent5) = without2Factors - ifTrue: [ - aBlock value: exponent2 value: exponent5 ] - ifFalse: [ - anotherBlock value ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4923-TypoFix-AndresValloud-2021Oct13-20h19m-sqr.001.cs.st----! - -'From Cuis 5.0 [latest update: #4923] on 14 October 2021 at 12:15:40 pm'! -!Morph methodsFor: 'structure' stamp: 'jmv 10/14/2021 10:27:31'! - wantsToBeOnTop: aBoolean - "If true, will be above all siblings who don't." - - self privateFlagAt: 6 put: aBoolean.! ! -!Morph methodsFor: 'testing' stamp: 'jmv 10/14/2021 10:27:38'! - wantsToBeOnTop - "If true, will be above all siblings who don't." - - ^ self privateFlagAt: 6.! ! -!Morph methodsFor: 'private' stamp: 'jmv 10/14/2021 10:36:00'! - privateArrangeWantsToBeOnTop - "Ensure that all morphs who #wantsToBeOnTop (i.e. toppers) are above all morphs who not #wantsToBeOnTop. - Do it without reordering these two subsets. - Do it in a single pass, and exit as soon as possible." - - | firstMisplacedTopperIndex firstNonTopperIndex topper nonTopper | - submorphs size < 2 ifTrue: [ ^self ]. - firstMisplacedTopperIndex _ 0. - firstNonTopperIndex _ 1. - [ - "Look for next." - [ (submorphs at: firstNonTopperIndex) wantsToBeOnTop ] whileTrue: [ - firstNonTopperIndex _ firstNonTopperIndex + 1. - firstNonTopperIndex = submorphs size ifTrue: [ - "All toppers until the end (at most, one non topper as last). Nothing else to do." - ^self ]]. - firstMisplacedTopperIndex _ firstMisplacedTopperIndex max: firstNonTopperIndex+1. - [ (submorphs at: firstMisplacedTopperIndex) wantsToBeOnTop not ] whileTrue: [ - firstMisplacedTopperIndex _ firstMisplacedTopperIndex + 1. - firstMisplacedTopperIndex > submorphs size ifTrue: [ - "No more toppers until the end. Nothing else to do." - ^self ]]. - - "We have actually found a misplaced topper. Fix it!!" - nonTopper _ submorphs at: firstNonTopperIndex. - topper _ submorphs at: firstMisplacedTopperIndex. - submorphs at: firstNonTopperIndex put: topper invalidateBounds. - submorphs at: firstMisplacedTopperIndex put: nonTopper invalidateBounds. - ] repeat.! ! -!StringRequestMorph methodsFor: 'testing' stamp: 'jmv 10/14/2021 10:31:13' overrides: 50616767! - wantsToBeOnTop - "If true, will be above all siblings who don't." - - ^ true! ! -!FillInTheBlankMorph methodsFor: 'testing' stamp: 'jmv 10/14/2021 10:28:52' overrides: 50616767! - wantsToBeOnTop - "If true, will be above all siblings who don't." - - ^ true! ! -!HoverHelpMorph methodsFor: 'testing' stamp: 'jmv 10/14/2021 10:27:49' overrides: 50616767! - wantsToBeOnTop - "If true, will be above all siblings who don't." - - ^ true! ! -!MenuMorph methodsFor: 'testing' stamp: 'jmv 10/14/2021 12:15:06' overrides: 50616767! - wantsToBeOnTop - "If true, will be above all siblings who don't." - - ^ true! ! -!AutoCompleterMorph methodsFor: 'testing' stamp: 'jmv 10/14/2021 10:29:00' overrides: 50616767! - wantsToBeOnTop - "If true, will be above all siblings who don't." - - ^ true! ! -!Morph methodsFor: 'private' stamp: 'jmv 10/14/2021 10:25:16' prior: 50614104! - privateAddAllMorphs: aCollection atIndex: index - "Private. Add aCollection of morphs to the receiver" - | myWorld itsWorld otherSubmorphs | - (aCollection allSatisfy: [ :m | self canAdd: m]) ifFalse: [ - (self confirm: 'Some requested morph requires VectorGraphics support. Do you want to install and activate it?') - ifTrue: [ - Feature require: 'VectorGraphics'. - MorphicCanvas activeSubclass: (Smalltalk at: #VectorCanvas) ] - ifFalse: [ - ^self error: 'We can''t add requested morphs.' ]]. - myWorld _ self world. - otherSubmorphs _ submorphs copyWithoutAll: aCollection. - (index between: 0 and: otherSubmorphs size) - ifFalse: [^ self error: 'index out of range']. - index = 0 - ifTrue:[ submorphs _ aCollection asArray, otherSubmorphs] - ifFalse:[ index = otherSubmorphs size - ifTrue:[ submorphs _ otherSubmorphs, aCollection] - ifFalse:[ submorphs _ otherSubmorphs copyReplaceFrom: index + 1 to: index with: aCollection ]]. - aCollection do: [:m | | itsOwner | - itsOwner _ m owner. - itsOwner ifNotNil: [ - itsWorld _ m world. - (itsWorld == myWorld) ifFalse: [ - itsWorld ifNotNil: [m redrawNeeded]]. - (itsOwner ~~ self) ifTrue: [ - m owner privateRemove: m. - m owner removedMorph: m ]]. - m privateOwner: self. - myWorld ifNotNil: [m redrawNeeded]. - (myWorld == itsWorld) ifFalse: [m intoWorld: myWorld]. - itsOwner == self ifFalse: [ - self addedMorph: m. - m noteNewOwner: self ]. - ]. - self privateArrangeWantsToBeOnTop. - self someSubmorphPositionOrExtentChanged! ! -!Morph methodsFor: 'private' stamp: 'jmv 10/14/2021 10:25:22' prior: 50614153! - privateAddMorph: aMorph atIndex: index position: aPointOrNil - - | oldIndex myWorld itsWorld oldOwner | - (self canAdd: aMorph) ifFalse: [ - (self confirm: 'The requested morph requires VectorGraphics support. Do you want to install and activate it?') - ifTrue: [ - Feature require: 'VectorGraphics'. - MorphicCanvas activeSubclass: (Smalltalk at: #VectorCanvas) ] - ifFalse: [ - ^self error: 'We can''t add requested morph.' ]]. - ((index >= 1) and: [index <= (submorphs size + 1)]) - ifFalse: [^ self error: 'index out of range']. - myWorld _ self world. - oldOwner _ aMorph owner. - (oldOwner == self and: [(oldIndex _ submorphs indexOf: aMorph) > 0]) ifTrue: [ - "aMorph's position changes within in the submorph chain" - oldIndex < index ifTrue:[ - "moving aMorph to back" - submorphs replaceFrom: oldIndex to: index-2 with: submorphs startingAt: oldIndex+1. - submorphs at: index-1 put: aMorph. - ] ifFalse:[ - "moving aMorph to front" - oldIndex-1 to: index by: -1 do:[:i| - submorphs at: i+1 put: (submorphs at: i)]. - submorphs at: index put: aMorph. - ]. - aPointOrNil ifNotNil: [aMorph privatePosition: aPointOrNil]. - ] ifFalse: [ - "adding a new morph" - oldOwner ifNotNil: [ - itsWorld _ aMorph world. - itsWorld ifNotNil: [aMorph invalidateBounds]. - oldOwner privateRemove: aMorph. - oldOwner removedMorph: aMorph. - ]. - aMorph privateOwner: self. - submorphs _ submorphs copyReplaceFrom: index to: index-1 with: (Array with: aMorph). - aPointOrNil ifNotNil: [aMorph privatePosition: aPointOrNil]. - (itsWorld == myWorld) ifFalse: [aMorph intoWorld: myWorld]. - ]. - myWorld ifNotNil: [ - index = 1 - ifTrue: [aMorph redrawNeeded ] - ifFalse: [aMorph invalidateBounds]]. - self privateArrangeWantsToBeOnTop. - self someSubmorphPositionOrExtentChanged. - oldOwner == self ifFalse: [ - self addedMorph: aMorph. - aMorph noteNewOwner: self ]! ! -!Morph methodsFor: 'private' stamp: 'jmv 10/14/2021 10:25:26' prior: 50530834! - privateMoveBackMorph: aMorph - - | oldIndex myWorld index | - myWorld _ self world. - "aMorph's position changes within in the submorph chain" - "moving aMorph to front" - oldIndex _ submorphs indexOf: aMorph. - "moving aMorph to back" - index _ submorphs size. - submorphs replaceFrom: oldIndex to: index-1 with: submorphs startingAt: oldIndex+1. - submorphs at: index put: aMorph. - myWorld ifNotNil: [aMorph redrawNeeded]. - self privateArrangeWantsToBeOnTop. - self someSubmorphPositionOrExtentChanged.! ! -!Morph methodsFor: 'private' stamp: 'jmv 10/14/2021 10:25:30' prior: 50530851! -privateMoveFrontMorph: aMorph - - | oldIndex myWorld | - myWorld _ self world. - "aMorph's position changes within in the submorph chain" - "moving aMorph to front" - oldIndex _ submorphs indexOf: aMorph. - oldIndex-1 to: 1 by: -1 do: [ :i | - submorphs at: i+1 put: (submorphs at: i)]. - submorphs at: 1 put: aMorph. - myWorld ifNotNil: [aMorph redrawNeeded]. - self privateArrangeWantsToBeOnTop. - self someSubmorphPositionOrExtentChanged.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4924-wantsToBeOnTop-JuanVuletich-2021Oct14-12h13m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4923] on 14 October 2021 at 10:59:24 am'! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 10/14/2021 10:56:28' prior: 50612702! - showHardwareCursor - - "Make the transition to using hardware cursor. - Report one final damage rectangle to erase the image of the software cursor." - self invalidateDisplayRect: self displayFullBoundsForPatch for: nil. - Cursor currentCursor == (Cursor cursorAt: #blankCursor) ifTrue: [ - "show hardware cursor" - Cursor defaultCursor activateCursor ].! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 10/14/2021 10:51:49' prior: 50612796! - dropMorphs: anEvent - "Drop the morphs at the hands position" - - self showHardwareCursor. - self submorphsReverseDo: [ :m | - "Drop back to front to maintain z-order" - self dropMorph: m event: anEvent ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4925-HandMorph-invalidationFix-JuanVuletich-2021Oct14-10h42m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4923] on 14 October 2021 at 11:12:23 am'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/14/2021 11:12:04' prior: 50613357! - computeDamage: aWorldMorph repair: aDamageRecorder rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage - "Iterate front to back while computing damage to actually repair for each morph, and for world background. - Answer uncoveredDamage, the areas where World background needs to be redrawn." - - | uncoveredDamage additionalUncoveredDamage morph morphDamage morphFullBounds | - uncoveredDamage _ aDamageRecorder damageReportedOther. - additionalUncoveredDamage _ OrderedCollection new. - - "Iterate from front to back" - 1 to: rootMorphs size do: [ :i | - morph _ rootMorphs at: i. - morphFullBounds _ morph displayFullBounds. - morphDamage _ nil. - "Reported damage can be ignored if the area fully covered by another morph above us." - (aDamageRecorder damageReportedFor: morph) ifNotNil: [ :r | | wasFullyCovered | - wasFullyCovered _ false. - 1 to: i-1 do: [ :j | - wasFullyCovered _ wasFullyCovered or: [ (rootMorphs at: j) fullyCovers: r ]]. - wasFullyCovered ifFalse: [ - uncoveredDamage add: r ]]. - "Any uncovered damage this morph may overlap must be redrawn by it." - uncoveredDamage withIndexDo: [ :r :j | | intersection | - r ifNotNil: [ - intersection _ r intersect: morphFullBounds. - intersection hasPositiveExtent ifTrue: [ - r = intersection ifTrue: [ uncoveredDamage at: j put: nil ]. - morphDamage - ifNil: [ morphDamage _ intersection ] - ifNotNil: [ morphDamage updateMerging: intersection ]]]]. - rootMorphsDamage at: i put: morphDamage. - uncoveredDamage add: morphDamage. - "Whatever we cover completely is no longer uncoveredDamage" - uncoveredDamage withIndexDo: [ :r :ri | - r ifNotNil: [ - morph - on: r - ifCovered: [uncoveredDamage at: ri put: nil] - uncoveredPartsDo: [ :r2 | additionalUncoveredDamage add: r2 ] - else: []]]. - uncoveredDamage addAll: additionalUncoveredDamage. - additionalUncoveredDamage removeAll. - ]. - - "Remove redundant rectangles" - 1 to: uncoveredDamage size do: [ :i1 | - (uncoveredDamage at: i1) ifNotNil: [ :r1 | - 1 to: uncoveredDamage size do: [ :i2 | - i1 = i2 ifFalse: [ - (uncoveredDamage at: i2) ifNotNil: [ :r2 | - (r1 containsRect: r2) - ifTrue: [ uncoveredDamage at: i2 put: nil ]]]]]]. - - "Answer any yet uncovered areas. World background should be drawn on them." - ^ uncoveredDamage select: [ :r | r notNil ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4926-InvalidationFix-JuanVuletich-2021Oct14-11h11m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4926] on 14 October 2021 at 12:11:46 pm'! -!FileList methodsFor: 'volume list and pattern' stamp: 'jmv 10/14/2021 12:11:31' prior: 50406380! - fileNameFormattedFrom: entry namePad: namePad sizePad: sizePad sizeWithCommasPad: sizeWithCommasPad - "entry is a 5-element array of the form: - (name creationTime modificationTime dirFlag fileSize)" - | sizeStr nameStr paddedNameStr dateStr someSpaces sizeDigits sizeDigitsAndCommas spacesToAdd font spaceWidth | - font _ Preferences standardListFont. - spaceWidth _ font widthOf: $ . - nameStr _ entry isDirectory - ifTrue: [ entry name , self folderString ] - ifFalse: [ entry name ]. - spacesToAdd _ namePad - (font widthOfString: nameStr) // spaceWidth. - paddedNameStr _ nameStr , - (String - new: spacesToAdd - withAll: $ ). - dateStr _ (entry modificationTime date printFormat: #(3 2 1 $/ 1 1 2 )) , ' ' , - (String streamContents: [ :s | - entry modificationTime time - print24: true - showSeconds: true - on: s ]). - sizeDigits _ entry fileSize printString size. - sizeStr _ entry fileSize printStringWithCommas. - sizeDigitsAndCommas _ sizeStr size. - spacesToAdd _ sizeWithCommasPad - sizeDigitsAndCommas. - "Usually a space takes the same space as a comma, and half the space of a digit. - Pad with 2 spaces for each missing digit and 1 space for each missing comma" - (font widthOf: Character space) ~= (font widthOf: $, ) - ifTrue: [spacesToAdd _ spacesToAdd + sizePad - sizeDigits max: 0]. - sizeStr _ (String new: spacesToAdd withAll: $ ) , sizeStr. - someSpaces _ String new: 6 withAll: $ . - " - sortMode = #name ifTrue: [ ^ paddedNameStr , someSpaces , '( ' , dateStr , someSpaces , sizeStr , ' )' ]. - sortMode = #date ifTrue: [ ^ '( ' , dateStr , someSpaces , sizeStr , ' )' , someSpaces , nameStr ]. - sortMode = #size ifTrue: [ ^ '( ' , sizeStr , someSpaces , dateStr , ' )' , someSpaces , nameStr ]. - " - ^ paddedNameStr , someSpaces , '( ' , dateStr , someSpaces , sizeStr , ' )' .! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4927-FileListFormatting-JuanVuletich-2021Oct14-12h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4923] on 14 October 2021 at 12:28:03 pm'! -!FileListWindow methodsFor: 'GUI building' stamp: 'hlsf 10/14/2021 12:27:46' prior: 16843354! - morphicPatternPane - - ^ (TextModelMorph - textProvider: model - textGetter: #pattern - textSetter: #pattern:) - acceptOnCR: true; - yourself.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4928-FileListPattern-acceptOnCR-HilaireFernandes-2021Oct14-12h26m-hlsf.001.cs.st----! - -----QUIT----(14 October 2021 14:32:44) Cuis5.0-4928-v3.image priorSource: 8943835! - -----STARTUP---- (2 November 2021 10:28:00) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4928-v3.image! - - -'From Cuis 5.0 [latest update: #4928] on 15 October 2021 at 1:09:52 pm'! -!MenuMorph methodsFor: 'testing' stamp: 'KLG 10/14/2021 23:47:37' prior: 50616836 overrides: 50616767! - wantsToBeOnTop - "If true, will be above all siblings who don't." - - ^ stayUp not! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4929-Menu-wantsToBeOnTop-Enhancement-GeraldKlix-2021Oct15-12h42m-KLG.001.cs.st----! - -'From Cuis 5.0 [latest update: #4933] on 18 October 2021 at 2:46:00 pm'! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 10/18/2021 11:58:24' prior: 50616675! - drawRoundLookOn: aCanvas - | r colorForButton rect | - colorForButton _ self isPressed - ifFalse: [ - self mouseIsOver - ifTrue: [ Color h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ color ]] - ifTrue: [ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - rect _ self morphLocalBounds insetBy: `3@3`. - r _ r min: (rect width min: rect height) * 0.5. - aCanvas roundRect: rect color: colorForButton radius: r ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawEmbossedLabelOn: aCanvas ] - ifFalse: [ self drawRegularLabelOn: aCanvas ].! ! -!BitBltCanvas methodsFor: 'drawing-roundedRectangles' stamp: 'jmv 10/18/2021 14:45:01' prior: 50595824 overrides: 50463492! - roundRect: aRectangle color: aColor radius: aNumber - " - (BitBltCanvas onForm: Display) roundRect: (10@10 extent: 200@100) color: Color red radius: 10.5. Display forceToScreen. - " - | r | - r _ (currentTransformation externalizeScalar: aNumber) rounded. - - "top stripe" - self - image: (self class topLeftCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle topLeft. - self - image: (self class topRightCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle topRight - (r@0). - self fillRectangle: ((aRectangle withHeight: r) insetBy: r@0) color: aColor. - - "center stripe" - self fillRectangle: (aRectangle insetBy: (0 @ r corner: 0 @ r)) color: aColor. - - "bottom stripe" - self - image: (self class bottomLeftCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle bottomLeft - (0@r). - self - image: (self class bottomRightCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle bottomRight - (r@r) . - self fillRectangle: ((aRectangle bottomLeft + (r@r negated)) extent: (aRectangle width - r - r@r)) color: aColor! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4930-RoundedButtons-fix-JuanVuletich-2021Oct18-14h37m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4930] on 18 October 2021 at 4:59:38 pm'! -!Preferences class methodsFor: 'bigger and smaller GUI element sizes' stamp: 'jmv 10/18/2021 11:46:02' prior: 50602939! - scrollbarThickness - "Includes border. - No less than PluggableButtonMorph >> #minimumExtent." - ^Preferences windowTitleFont pointSize + 2! ! -!MorphicCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 10/18/2021 11:54:41' prior: 50595566! - frameRectangle: aRectangle color: aColor borderWidth: borderWidth borderStyleSymbol: aSymbol - " - (BitBltCanvas onForm: Display) - frameRectangle: (10@10 extent: 300@200) - color: Color green - borderWidth: 10 - borderStyleSymbol: #raised. - Display forceToScreen. - " - - | tlColor brColor | - tlColor _ aColor. - brColor _ aColor. - aSymbol == #raised ifTrue: [ - tlColor _ aColor lighter. - brColor _ aColor darker ]. - - aSymbol == #inset ifTrue: [ - tlColor _ aColor darker. - brColor _ aColor lighter ]. - - self frameRectangle: aRectangle topLeftColor: tlColor bottomRightColor: brColor borderWidth: borderWidth! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4931-ScrollbarButtons-tweaks-JuanVuletich-2021Oct18-16h59m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4934] on 18 October 2021 at 5:42:54 pm'! -!PluggableListMorph methodsFor: 'initialization' stamp: 'jmv 10/18/2021 17:18:08' prior: 50562106 overrides: 50601655! - initialize - scrollSiblings := false. "user must override" - super initialize. - scroller morphWidth: extent x.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4932-PluggableListMorph-fix-JuanVuletich-2021Oct18-17h42m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4932] on 18 October 2021 at 7:09:32 pm'! -!PluggableScrollPane commentStamp: '' prior: 16889491! - Allows viewing just part of a larger Morph. The scroll values vary from 0.0 to 1.0.! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/18/2021 11:24:30'! - adjustExtent - "Morphs intended to be included in PluggableScrollPanes as scrolled content might need to adjust their extent. - NOP by default."! ! -!PluggableScrollPane methodsFor: 'initialization' stamp: 'jmv 10/18/2021 11:23:18'! - scroller: contents - - scroller ifNotNil: [ scroller delete ]. - scroller _ contents. - self addMorphBack: scroller. - self scrollerOffset: `0@ 0`.! ! -!PluggableScrollPane methodsFor: 'events' stamp: 'jmv 10/18/2021 14:10:08' prior: 50449247 overrides: 50449234! - keyStroke: aKeyboardEvent - - ( self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - super keyStroke: aKeyboardEvent. - scroller ifNotNil: [ - scroller keyStroke: aKeyboardEvent ].! ! -!PluggableScrollPane methodsFor: 'events' stamp: 'jmv 10/18/2021 14:10:42' prior: 50458663 overrides: 16874541! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - - | eventPositionLocalToScroller | - scroller ifNotNil: [ - eventPositionLocalToScroller _ localEventPosition - scroller morphPosition. - scroller mouseButton1Down: aMouseButtonEvent localPosition: eventPositionLocalToScroller ]. - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: nil - clkNHalf: nil - dblClkSel: #doubleClick:localPosition: - dblClkNHalfSel: #doubleClickAndHalf:localPosition: - tripleClkSel: nil! ! -!PluggableScrollPane methodsFor: 'events' stamp: 'jmv 10/18/2021 14:10:57' prior: 50458683 overrides: 16874556! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - - | eventPositionLocalToScroller | - super mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition. - scroller ifNotNil: [ - eventPositionLocalToScroller _ localEventPosition - scroller morphPosition. - scroller mouseButton1Up: aMouseButtonEvent localPosition: eventPositionLocalToScroller ].! ! -!PluggableScrollPane methodsFor: 'events' stamp: 'jmv 10/18/2021 14:11:19' prior: 50458697 overrides: 16874651! - mouseMove: aMouseMoveEvent localPosition: localEventPosition - - | eventPositionLocalToScroller | - scroller ifNotNil: [ - eventPositionLocalToScroller _ localEventPosition - scroller morphPosition. - scroller mouseMove: aMouseMoveEvent localPosition: eventPositionLocalToScroller ].! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 10/18/2021 14:08:49' prior: 50556477 overrides: 50556435! - extentChanged: oldExtent - "Our extent changed. Must layout submorphs again." - - super extentChanged: oldExtent. - "Now reset widget sizes" - scroller ifNotNil: [ - scroller adjustExtent ]. - self updateScrollBarsBounds. - self setScrollDeltas. - self scrollSelectionIntoView ! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 10/18/2021 13:02:17' prior: 16889683! - hTotalScrollRange - "Return the width extent of the receiver's scrollable area" - scroller ifNil: [ ^0 ]. - ^scroller morphExtentInOwner x! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 10/18/2021 13:02:44' prior: 50578439 overrides: 50499537! - minimumExtent - | minW minH scrollerExtent | - scrollerExtent _ scroller ifNil: [ 0@0 ] ifNotNil: [ scroller morphExtentInOwner ]. - "Figure out the minimum extent for this pane so that either content, or at least required scrollbars, will fit" - minW _ self xtraBorder * 2 + scrollerExtent x min: ScrollBar scrollbarThickness * 2. - self vIsScrollbarShowing - ifTrue: [ - minW _ minW + ScrollBar scrollbarThickness]. - minH _ self xtraBorder * 2 + scrollerExtent y. - self hIsScrollbarShowing - ifTrue: [ - minH _ minH + ScrollBar scrollbarThickness]. - minH _ minH min: ScrollBar scrollbarThickness * 2. - ^ (minW + (borderWidth * 2)) @ (minH + (borderWidth * 2))! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 10/18/2021 13:02:01' prior: 16889824! - vTotalScrollRange - "Return the height extent of the receiver's scrollable area" - scroller ifNil: [ ^0 ]. - ^scroller morphExtentInOwner y! ! -!PluggableScrollPane methodsFor: 'initialization' stamp: 'jmv 10/18/2021 19:06:12' prior: 50601655 overrides: 50384371! - initialize - - "initialize the state of the receiver" - super initialize. - hideScrollBars _ #showIfNeeded. - - "initialize the receiver's scrollBars" - scrollBar _ ScrollBar new model: self setValueSelector: #vScrollBarValue:. - hScrollBar _ ScrollBar new model: self setValueSelector: #hScrollBarValue:. - drawKeyboardFocusIndicator _ Preferences drawKeyboardFocusIndicator. - - self innerMorphClass ifNotNil: [ :contentsClass | - self scroller: contentsClass new ]. - self addMorph: scrollBar. - self addMorph: hScrollBar.! ! -!PluggableScrollPane methodsFor: 'initialization' stamp: 'jmv 10/18/2021 11:18:31' prior: 16889884! - innerMorphClass - ^nil! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'jmv 10/18/2021 19:07:42' prior: 16889899! - hHideScrollBar - hScrollBar hide. - scroller ifNotNil: [ - scroller adjustExtent ].! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'jmv 10/18/2021 19:08:19' prior: 16889914! - hScrollBarValue: scrollValue - - | x | - scroller ifNotNil: [ - self hIsScrollbarShowing ifFalse: [ - ^self scrollerOffset: 0@self scrollerOffset y ]. - (x _ self hLeftoverScrollRange * scrollValue) <= 0 - ifTrue: [ x _ 0 ]. - self scrollerOffset: x@self scrollerOffset y ].! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'jmv 10/18/2021 19:09:01' prior: 16889925! - hShowScrollBar - - hScrollBar show. - scroller ifNotNil: [ - scroller adjustExtent ].! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'jmv 10/18/2021 14:12:38' prior: 50406125! - scrollBy: delta - "Move the contents in the direction delta." - - | newYoffset yRange xRange newXoffset | - - "Set the offset on the scroller" - yRange _ self vLeftoverScrollRange. - xRange _ self hLeftoverScrollRange. - - scroller ifNotNil: [ - newYoffset _ self scrollerOffset y - delta y min: yRange max: 0. - newXoffset _ self scrollerOffset x - delta x min: xRange max: 0. - self scrollerOffset: newXoffset@newYoffset ]. - - "Update the scrollBars" - scrollBar scrollValue: (yRange ifNotZero: [newYoffset asFloat / yRange]). - hScrollBar scrollValue: (xRange ifNotZero: [newXoffset asFloat / xRange]).! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'jmv 10/18/2021 19:07:48' prior: 16890011! - vHideScrollBar - scrollBar hide. - scroller ifNotNil: [ - scroller adjustExtent ].! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'jmv 10/18/2021 19:08:44' prior: 16890025! - vScrollBarValue: scrollValue - - scroller ifNotNil: [ - self scrollerOffset: - (self scrollerOffset x @ - (self vLeftoverScrollRange * scrollValue) rounded) ].! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'jmv 10/18/2021 19:09:04' prior: 16890032! - vShowScrollBar - - scrollBar show. - scroller ifNotNil: [ - scroller adjustExtent ].! ! - -InnerPluggableMorph removeSelector: #adjustExtent! - -!methodRemoval: InnerPluggableMorph #adjustExtent stamp: 'Install-4933-AllowArbitraryScroller-JuanVuletich-2021Oct18-19h03m-jmv.001.cs.st 11/2/2021 10:28:04'! -adjustExtent - "Morphs intended to be included in PluggableScrollPanes as scrolled content might need to adjust their extent." - - self subclassResponsibility! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4933-AllowArbitraryScroller-JuanVuletich-2021Oct18-19h03m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4933] on 18 October 2021 at 8:07:24 pm'! - -PluggableMorph subclass: #PluggableScrollPane - instanceVariableNames: 'scrollBar scroller hScrollBar hideScrollBars drawKeyboardFocusIndicator scrollerRadians scrollerScale theScrollerExtent ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #PluggableScrollPane category: 'Morphic-Widgets' stamp: 'Install-4934-AllowNonWidgetsInScrollPanes-JuanVuletich-2021Oct18-19h55m-jmv.002.cs.st 11/2/2021 10:28:05'! -PluggableMorph subclass: #PluggableScrollPane - instanceVariableNames: 'scrollBar scroller hScrollBar hideScrollBars drawKeyboardFocusIndicator scrollerRadians scrollerScale theScrollerExtent' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! -!PluggableScrollPane commentStamp: 'jmv 10/18/2021 19:56:27' prior: 50617345! - Allows viewing just part of a larger Morph. The scroll values vary from 0.0 to 1.0. - -| p | -p := PluggableScrollPane new. -p scroller: WidgetMorph new. -p openInWorld. - -| p | -p := PluggableScrollPane new. -p scroller: Sample01Star new. -p openInWorld.! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/18/2021 14:52:24'! - topLeftInOwner - - ^self fullBoundsInOwner origin! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 10/18/2021 14:53:02' overrides: 50617622! - topLeftInOwner - - ^self morphPosition! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 10/18/2021 14:53:07' overrides: 50617622! - topLeftInOwner - - ^self morphPosition! ! -!InnerTextMorph methodsFor: 'geometry' stamp: 'jmv 10/18/2021 19:50:20' prior: 50556457 overrides: 50556435! - extentChanged: oldExtent - "Our extent changed. Reflow text." - super extentChanged: oldExtent. - model ifNotNil: [ - wrapFlag ifTrue: [ - extent x = oldExtent x ifFalse: [ - self resetTextComposition. - self editor recomputeSelection. - owner - updateScrollBarsBounds; - setScrollDeltas ]]]! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 10/18/2021 20:02:53' prior: 50617447 overrides: 50499537! - minimumExtent - | minW minH h w | - w _ theScrollerExtent ifNotNil: [ theScrollerExtent x ] ifNil: [ 0 ]. - h _ theScrollerExtent ifNotNil: [ theScrollerExtent y ] ifNil: [ 0 ]. - "Figure out the minimum extent for this pane so that either content, or at least required scrollbars, will fit" - minW _ self xtraBorder * 2 + w min: ScrollBar scrollbarThickness * 2. - self vIsScrollbarShowing - ifTrue: [ - minW _ minW + ScrollBar scrollbarThickness]. - minH _ self xtraBorder * 2 + h. - self hIsScrollbarShowing - ifTrue: [ - minH _ minH + ScrollBar scrollbarThickness]. - minH _ minH min: ScrollBar scrollbarThickness * 2. - ^ (minW + (borderWidth * 2)) @ (minH + (borderWidth * 2))! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 10/18/2021 14:53:34' prior: 50461116! - scrollerOffset - - ^ scroller topLeftInOwner negated + self viewableAreaTopLeft! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 10/18/2021 15:07:28' prior: 50461122! - scrollerOffset: newOffset - - | delta | - delta _ scroller topLeftInOwner - scroller morphPosition. - scroller morphPosition: self viewableAreaTopLeft - newOffset - delta! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 10/18/2021 20:07:16' prior: 16889767 overrides: 50537668! - someSubmorphPositionOrExtentChanged - "Our extent, or some submorph changed. Must layout submorphs again." - - super someSubmorphPositionOrExtentChanged. - scroller ifNotNil: [ | scrollerLocation doIt | - doIt _ false. - scroller hasVariableExtent ifTrue: [ - theScrollerExtent = scroller morphExtentInOwner ifFalse: [ - theScrollerExtent _ scroller morphExtentInOwner. - doIt _ true ]]. - scrollerLocation _ scroller location. - scrollerScale = scrollerLocation scale ifFalse: [ - scrollerScale _ scrollerLocation scale. - doIt _ true ]. - scrollerRadians = scrollerLocation radians ifFalse: [ - scrollerRadians _ scrollerLocation radians. - doIt _ true ]. - doIt ifTrue: [ self setScrollDeltas ]].! ! -!PluggableScrollPane methodsFor: 'initialization' stamp: 'jmv 10/18/2021 19:47:13' prior: 50617480 overrides: 50384371! - initialize - - "initialize the state of the receiver" - super initialize. - hideScrollBars _ #showIfNeeded. - - "initialize the receiver's scrollBars" - scrollBar _ ScrollBar new model: self setValueSelector: #vScrollBarValue:. - hScrollBar _ ScrollBar new model: self setValueSelector: #hScrollBarValue:. - drawKeyboardFocusIndicator _ Preferences drawKeyboardFocusIndicator. - self addMorph: scrollBar. - self addMorph: hScrollBar. - self updateScrollBarsBounds. - self innerMorphClass ifNotNil: [ :contentsClass | - self scroller: contentsClass new ].! ! - -PluggableMorph subclass: #PluggableScrollPane - instanceVariableNames: 'scrollBar scroller hScrollBar hideScrollBars drawKeyboardFocusIndicator scrollerScale scrollerRadians theScrollerExtent' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #PluggableScrollPane category: 'Morphic-Widgets' stamp: 'Install-4934-AllowNonWidgetsInScrollPanes-JuanVuletich-2021Oct18-19h55m-jmv.002.cs.st 11/2/2021 10:28:05'! -PluggableMorph subclass: #PluggableScrollPane - instanceVariableNames: 'scrollBar scroller hScrollBar hideScrollBars drawKeyboardFocusIndicator scrollerScale scrollerRadians theScrollerExtent' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4934-AllowNonWidgetsInScrollPanes-JuanVuletich-2021Oct18-19h55m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4913] on 18 October 2021 at 6:47:02 pm'! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'private' stamp: 'HAW 10/18/2021 18:33:35'! - findSourceRangeOfCloserStatementIn: listOfAncestors ifNone: noneBlock - - ^ (listOfAncestors - detect: [ :assoc | assoc key isBlockNode ] - ifFound: [ :assoc | listOfAncestors before: assoc ifNone: noneBlock ] - ifNone: noneBlock) value! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'private' stamp: 'HAW 10/18/2021 18:33:59' prior: 50508763! - intervalMatchesBeginningOfStatement - - ^ (self findSourceRangeOfCloserStatementIn: initialNodeAncestors ifNone: [ initialNodeAncestors last ]) first = intervalToExtract first! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'private' stamp: 'HAW 10/18/2021 18:34:28' prior: 50610615! - intervalMatchesEndOfStatement - - | closerStatementLastPosition | - - closerStatementLastPosition := (self findSourceRangeOfCloserStatementIn: finalNodeAncestors ifNone: [ finalNodeAncestors first ]) last. - ^ closerStatementLastPosition = intervalToExtract last or: [ closerStatementLastPosition - 1 = intervalToExtract last ].! ! -!SourceCodeOfMethodToBeExtractedPrecondition methodsFor: 'private' stamp: 'HAW 10/18/2021 17:49:29' prior: 50517672! - isLeftSideOfAssignment - - ^ initialNodeAncestors size > 1 - and: [ self startAndEndParseNodesAreTheSame ] - and: [ initialNodeAncestors second key isAssignmentNode ] - and: [ initialNodeAncestors second key variable = initialNode key ] - and: [ initialNodeAncestors second key variable isInstanceVariableNode not ]! ! - -SourceCodeOfMethodToBeExtractedPrecondition removeSelector: #findSourceRangeOfCloserStatementIn:! - -!methodRemoval: SourceCodeOfMethodToBeExtractedPrecondition #findSourceRangeOfCloserStatementIn: stamp: 'Install-4935-ExtractMethodFixWhenManyBlocksInsideABlock-HernanWilkinson-2021Oct18-12h39m-HAW.001.cs.st 11/2/2021 10:28:05'! -findSourceRangeOfCloserStatementIn: listOfAncestors - - ^ (listOfAncestors - detect: [ :assoc | assoc key isBlockNode ] - ifFound: [ :assoc | listOfAncestors before: assoc ifNone: [ listOfAncestors last ] ] - ifNone: [ listOfAncestors last ]) value! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4935-ExtractMethodFixWhenManyBlocksInsideABlock-HernanWilkinson-2021Oct18-12h39m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4935] on 22 October 2021 at 12:23:16 pm'! -!PluggableListMorph methodsFor: 'accessing' stamp: 'jmv 10/22/2021 11:57:37' prior: 16888560! - rowAtLocation: aPoint - "Return the row at the given point or 0 if outside" - - ^scroller rowAtLocation: (scroller internalize: aPoint)! ! -!PluggableListMorph methodsFor: 'accessing' stamp: 'jmv 10/22/2021 11:57:48' prior: 50425964! - rowAtLocation: aPoint ifNone: aNoneBlock - - ^scroller rowAtLocation: (scroller internalize: aPoint) ifNone: aNoneBlock! ! -!PluggableListMorph methodsFor: 'event handling' stamp: 'jmv 10/22/2021 11:57:11' prior: 16888701 overrides: 16889892! - mouseButton2Activity - scroller highlightedRow: nil. - super mouseButton2Activity! ! -!PluggableListMorph methodsFor: 'events' stamp: 'jmv 10/22/2021 11:56:47' prior: 50546637 overrides: 50579741! - dragEvent: aMouseEvent localPosition: localEventPosition - - | row dragged listItem sm | - scroller highlightedRow: nil. - row _ self rowAtLocation: localEventPosition ifNone: [ ^self ]. - listItem _ self getListItem: row. - - sm _ LabelMorph contents: listItem. - dragged _ DraggingGuideMorph new. - dragged addMorph: sm. - dragged morphExtent: sm morphExtent. - dragged setProperty: #dragSource toValue: self. - dragged setProperty: #dropSelectorArgument toValue: listItem. - - aMouseEvent hand attachMorphBeside: dragged.! ! -!PluggableListMorph methodsFor: 'events' stamp: 'jmv 10/22/2021 11:56:57' prior: 50426132 overrides: 50617377! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - - | row | - - self hasKeyboardFocus ifFalse: [ - aMouseButtonEvent hand newKeyboardFocus: self. - "If we are focusing, deselect, so that later selection doesn't result in deselect." - scroller noSelection]. - row _ self - rowAtLocation: localEventPosition - ifNone: [^super mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition ]. - - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view. - Model update will be done on mouse button up, so this feedback will be visible before that." - scroller highlightedRow: row. - - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: #click:localPosition: - clkNHalf: nil - dblClkSel: (doubleClickSelector ifNotNil: [ #doubleClick:localPosition: ]) - dblClkNHalfSel: nil - tripleClkSel: nil - dragSel: (self itemsAreDraggable ifTrue: [ #dragEvent:localPosition: ] ifFalse: [ nil ])! ! -!PluggableListMorph methodsFor: 'events' stamp: 'jmv 10/22/2021 11:57:13' prior: 50461003 overrides: 50593266! - mouseLeave: event - super mouseLeave: event. - scroller highlightedRow: nil! ! -!PluggableListMorph methodsFor: 'events-processing' stamp: 'jmv 10/22/2021 11:57:19' prior: 50461149 overrides: 16875055! - processMouseMove: aMouseMoveEvent localPosition: localEventPosition - "Reimplemented because we really want #mouseMove when a morph is dragged around" - - aMouseMoveEvent wasHandled ifTrue: [ ^self ]. "not interested" - scroller highlightedRow: ( - (self viewableArea containsPoint: localEventPosition) ifTrue: [ - self rowAtLocation: localEventPosition ifNone: []]). - (aMouseMoveEvent anyButtonPressed and: [ self hasMouseFocus ]) ifFalse: [ ^self ]. - aMouseMoveEvent wasHandled: true. - self mouseMove: aMouseMoveEvent localPosition: localEventPosition. - (self handlesMouseStillDown: aMouseMoveEvent) ifTrue:[ - "Step at the new location" - self startStepping: #processMouseStillDown stepTime: 1 ]! ! -!PluggableListMorph methodsFor: 'initialization' stamp: 'jmv 10/22/2021 11:56:49' prior: 16888752! - font - - ^ scroller font -! ! -!PluggableListMorph methodsFor: 'initialization' stamp: 'jmv 10/22/2021 11:56:52' prior: 16888756! - font: aFontOrNil - scroller font: aFontOrNil. -! ! -!PluggableListMorph methodsFor: 'selection' stamp: 'jmv 10/22/2021 11:57:16' prior: 50380184! - privateVisualSelectionIndex: index - "Called internally to select the index-th item. - Does not update model" - | row | - row _ index ifNil: [ 0 ]. - row _ row min: self getListSize. "make sure we don't select past the end" - scroller selectedRow: row. - self scrollSelectionIntoView! ! -!PluggableListMorph methodsFor: 'selection' stamp: 'jmv 10/22/2021 12:10:55' prior: 50380204! - visualSelectionIndex - "return the index we have currently selected, or 0 if none" - ^scroller selectedRow ifNil: [ 0 ]! ! -!PluggableListMorph methodsFor: 'updating' stamp: 'jmv 10/22/2021 12:10:51' prior: 50380537! - updateList - | index | - "the list has changed -- update from the model" - self getList. - scroller listChanged. - self setScrollDeltas. - index _ self getCurrentSelectionIndex. - self privateVisualSelectionIndex: index! ! -!PluggableListMorph methodsFor: 'private' stamp: 'jmv 10/22/2021 11:56:44' prior: 50455213! - changeSelectionTo: nextSelection - - nextSelection = self getCurrentSelectionIndex ifFalse: [ - | window | - window _ self owningWindow. - (window isNil or: [ window okToChangeDueTo: self ]) ifTrue: [ - "No change if model is locked" - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - scroller highlightedRow: nextSelection. - "Update the model in next world cycle, so user gets the immediate feedback." - UISupervisor whenUIinSafeState: [ self setSelectionIndex: nextSelection ]. - ] - ]! ! -!PluggableListMorph methodsFor: 'scrolling' stamp: 'jmv 10/22/2021 12:22:50' prior: 50562019 overrides: 16889986! - scrollSelectionIntoView - "make sure that the current selection is visible" - | row r | - row _ self getCurrentSelectionIndex. - row = 0 - ifTrue: [ - "Value is 0, but we need to propagate it to model" - scrollBar internalScrollValue: scrollBar scrollValue ] - ifFalse: [ - self flag: #jmvVer2. - r _ scroller drawBoundsForRow: row. - r _ ((scroller externalize: r origin) extent: r extent). - self scrollToShow: r ]. - self scrollMySiblings -! ! -!PluggableListMorphOfMany methodsFor: 'events' stamp: 'jmv 10/22/2021 12:11:06' prior: 50573430 overrides: 50617887! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - - | oldIndex oldVal row w | - self hasKeyboardFocus ifFalse: [ - aMouseButtonEvent hand newKeyboardFocus: self ]. - - row _ self rowAtLocation: localEventPosition. - - row = 0 ifTrue: [ - ^super mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition ]. - - "Highlight the row to be selected, for immediate user feedback in case the model takes a while to update the view." - scroller highlightedRow: row. - - w _ self owningWindow. - (w isNil or: [ w okToChange ]) ifTrue: [ "No change if model is locked" - - "Set meaning for subsequent dragging of selection" - dragOnOrOff _ (self listSelectionAt: row) not. - dragStartRow _ row. - oldIndex _ self getCurrentSelectionIndex. - oldIndex ~= 0 ifTrue: [oldVal _ self listSelectionAt: oldIndex]. - - "Different from PluggableListMorph. There, we highlight on mouse down, and act on mouse up. - Here, we act on mouse down, because we support dragging of selection, so mouse up will - only happen after user is finished dragging. In order to get the highlight visible for the user, - update the model on next world cycle." - UISupervisor whenUIinSafeState: [ - "Set or clear new primary selection (listIndex)" - dragOnOrOff == true - ifTrue: [self setSelectionIndex: row] - ifFalse: [self setSelectionIndex: 0]. - "Need to restore the old one, due to how model works, and set new one." - oldIndex ~= 0 ifTrue: [self listSelectionAt: oldIndex put: oldVal]. - self listSelectionAt: row put: dragOnOrOff ]. - ]. - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: nil - clkNHalf: nil - dblClkSel: #doubleClick:localPosition: - dblClkNHalfSel: nil - tripleClkSel: nil! ! - -PluggableListMorph removeSelector: #listMorph! - -!methodRemoval: PluggableListMorph #listMorph stamp: 'Install-4936-Cleanup-JuanVuletich-2021Oct22-12h22m-jmv.001.cs.st 11/2/2021 10:28:05'! -listMorph -self flag: #jmvVer. -"Podemos reemplazar los senders locales por accesos directos (el doble encapsulamiento es tonto) una vez que quede definido el shape de la clase!!" - ^scroller! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4936-Cleanup-JuanVuletich-2021Oct22-12h22m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4935] on 22 October 2021 at 12:27:13 pm'! -!TextModelMorph methodsFor: 'accessing' stamp: 'jmv 10/22/2021 12:14:38'! - innerTextMorph - ^ scroller! ! -!TextModelMorph methodsFor: 'accessing' stamp: 'jmv 10/22/2021 11:53:17' prior: 50369316! - disableEditing - scroller disableEditing! ! -!TextModelMorph methodsFor: 'accessing' stamp: 'jmv 10/22/2021 11:53:38' prior: 16933959! - editor - ^scroller editor! ! -!TextModelMorph methodsFor: 'accessing' stamp: 'jmv 10/22/2021 11:53:41' prior: 50369320! - enableEditing - - scroller enableEditing! ! -!TextModelMorph methodsFor: 'accessing' stamp: 'jmv 10/22/2021 11:54:30' prior: 16933975! - wrapFlag: aBoolean - scroller wrapFlag: aBoolean! ! -!TextModelMorph methodsFor: 'dependents access' stamp: 'jmv 10/22/2021 11:53:12' prior: 16933980 overrides: 16874095! - canDiscardEdits - "Return true if this view either has no text changes or does not care." - - ^ scroller canDiscardEdits! ! -!TextModelMorph methodsFor: 'drawing' stamp: 'jmv 10/22/2021 11:53:33' prior: 50530734 overrides: 50596652! - drawOn: aCanvas - "Include a thin red inset border for unaccepted edits, or, if the unaccepted edits are known to conflict with a change made somewhere else to the same method (typically), put a thick red frame" - | bw bc | - self flag: #todo. - "Integrate this method with the Theme system. --cbr" - super drawOn: aCanvas. - bw _ Preferences focusIndicatorWidth. - bc _ nil. - self wantsFrameAdornments ifTrue: [ - model refusesToAccept - ifTrue: [ "Put up feedback showing that code cannot be submitted in this state" - bc _ Color tan ] - ifFalse: [ - scroller hasEditingConflicts - ifTrue: [ - bw _ 3. - bc _ Color red ] - ifFalse: [ - scroller hasUnacceptedEdits ifTrue: [ bc _ Color red ]]]]. - (drawKeyboardFocusIndicator and: [ scroller hasKeyboardFocus ]) - ifTrue: [ bc ifNil: [ bc _ Theme current focusIndicator ]] - ifFalse: [ - bc ifNotNil: [ - bc _ bc - alphaMixed: 0.4 - with: Color white ]]. - bc ifNotNil: [ - aCanvas - frameRectangle: self focusIndicatorRectangle - borderWidth: bw - color: bc ].! ! -!TextModelMorph methodsFor: 'editor access' stamp: 'jmv 10/22/2021 11:54:07' prior: 50458708 overrides: 16889986! - scrollSelectionIntoView - "Scroll my text into view if necessary and return true, else return false" - - | delta | - delta _ scroller morphPosition. - self editor pointIndex > 1 - ifTrue: [ - self scrollToShow: (self editor pointBlock translatedBy: delta) ] - ifFalse: [ - self scrollToShow: (self editor selectionRectangle translatedBy: delta) ]! ! -!TextModelMorph methodsFor: 'editor access' stamp: 'jmv 10/22/2021 11:54:10' prior: 16934037! - selectAll - "Tell my textMorph's editor to select all" - - scroller selectAll! ! -!TextModelMorph methodsFor: 'events' stamp: 'jmv 10/22/2021 11:53:15' prior: 50381728! - clickAndHalf: aMouseButtonEvent localPosition: localEventPosition - - scroller clickAndHalf: aMouseButtonEvent localPosition: localEventPosition! ! -!TextModelMorph methodsFor: 'events' stamp: 'jmv 10/22/2021 11:53:20' prior: 16934049 overrides: 16889535! - doubleClickAndHalf: aMouseButtonEvent localPosition: localEventPosition - - scroller doubleClickAndHalf: aMouseButtonEvent localPosition: localEventPosition! ! -!TextModelMorph methodsFor: 'events' stamp: 'jmv 10/22/2021 11:53:52' prior: 50449295 overrides: 50617367! - keyStroke: aKeyboardEvent - "A keystroke was hit while the receiver had keyboard focus. Pass the keywtroke on to my textMorph, and and also, if I have an event handler, pass it on to that handler" - - (self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - scroller keyStroke: aKeyboardEvent! ! -!TextModelMorph methodsFor: 'events' stamp: 'jmv 10/22/2021 11:54:04' prior: 16934072 overrides: 50593252! - mouseEnter: event - super mouseEnter: event. - Preferences focusFollowsMouse - ifTrue: [ event hand newKeyboardFocus: scroller ]! ! -!TextModelMorph methodsFor: 'event handling' stamp: 'jmv 10/22/2021 11:54:02' prior: 16934079 overrides: 16889892! - mouseButton2Activity - scroller mouseButton2Activity! ! -!TextModelMorph methodsFor: 'focus handling' stamp: 'jmv 10/22/2021 11:53:47' prior: 16934084! - focusText - - self world activeHand newKeyboardFocus: scroller! ! -!TextModelMorph methodsFor: 'initialization' stamp: 'jmv 10/22/2021 11:53:05' prior: 16934104! - acceptOnCR: aBoolean - scroller acceptOnCR: aBoolean! ! -!TextModelMorph methodsFor: 'initialization' stamp: 'jmv 10/22/2021 11:53:43' prior: 50432733! - escAction: aBlock - - scroller escAction: aBlock! ! -!TextModelMorph methodsFor: 'initialization' stamp: 'jmv 10/22/2021 11:53:59' prior: 16934119 overrides: 16889461! - model: aTextModel - - super model: aTextModel. - scroller model: model wrappedTo: self viewableWidth. - model refetch. - self setScrollDeltas! ! -!TextModelMorph methodsFor: 'model access' stamp: 'jmv 10/22/2021 11:54:13' prior: 16934171! - setTextColor: aColor - "Set the color of my text to the given color" - - scroller color: aColor! ! -!TextModelMorph methodsFor: 'scrolling' stamp: 'jmv 10/22/2021 11:53:55' prior: 16934189 overrides: 16889689! - mightNeedHorizontalScrollBar - - scroller isWrapped ifTrue: [ ^false ]. - - ^super mightNeedHorizontalScrollBar -! ! -!TextModelMorph methodsFor: 'unaccepted edits' stamp: 'jmv 10/22/2021 11:53:09' prior: 16934196! - askBeforeDiscardingEdits: aBoolean - "Set the flag that determines whether the user should be asked before discarding unaccepted edits." - - scroller askBeforeDiscardingEdits: aBoolean! ! -!TextModelMorph methodsFor: 'unaccepted edits' stamp: 'jmv 10/22/2021 11:53:50' prior: 16934205! - hasUnacceptedEdits: aBoolean - "Set the hasUnacceptedEdits flag in my morph." - scroller hasUnacceptedEdits: aBoolean! ! -!TextModelMorph methodsFor: 'updating' stamp: 'jmv 10/22/2021 11:54:19' prior: 50452639! - updateAcceptedContents - - scroller hasUnacceptedEdits ifTrue: [ - scroller hasEditingConflicts: true. - ^self redrawNeeded ]. - model refetch. - "#actualContents also signalled in #refetch. No need to repeat what's done there." - ^self ! ! -!TextModelMorph methodsFor: 'updating' stamp: 'jmv 10/22/2021 11:54:22' prior: 50452649! - updateActualContents - - "Some day, it would be nice to keep objects and update them - instead of throwing them away all the time for no good reason..." - scroller - releaseEditorAndTextComposition; - installEditorAndTextComposition; - formatAndStyleIfNeeded. - self setScrollDeltas. - self redrawNeeded. - ^self ! ! -!TextModelMorph methodsFor: 'updating' stamp: 'jmv 10/22/2021 11:54:24' prior: 50474003! - updateAutoSelect - - TextEditor abandonChangeText. "no replacement!!" - self selectMessage - ifFalse: [ self selectString ]. - - scroller updateFromTextComposition. - ^self scrollSelectionIntoView! ! -!TextModelMorph methodsFor: 'updating' stamp: 'jmv 10/22/2021 11:54:26' prior: 50452692! - updateShoutStyled - - scroller stylerStyled. - ^self redrawNeeded ! ! -!MessageNamesWindow methodsFor: 'GUI building' stamp: 'jmv 10/22/2021 12:14:51' prior: 50495728 overrides: 50518741! - buildMorphicWindow - "Answer a morphic window with the given initial search string, nil if none" - "MessageNames openMessageNames" - | selectorListView firstRow searchButton secondRow | - textMorph _ (TextModelMorph - textProvider: model - textGetter: #searchString - textSetter: #searchString: - selectionGetter: #contentsSelection) - setBalloonText: 'See MessageNames class comment for search string options'; - emptyTextDisplayMessage: 'Type here, then hit Search'. - textMorph askBeforeDiscardingEdits: false. - textMorph acceptOnCR: true. - textMorph hideScrollBarsIndefinitely. - searchButton _ PluggableButtonMorph new - model: textMorph innerTextMorph; - label: 'Search'; - action: #acceptContents. - searchButton setBalloonText: 'Type some letters into the pane at right, and then press this Search button (or hit RETURN) and all method selectors that match what you typed will appear in the list pane below. Click on any one of them, and all the implementors of that selector will be shown in the right-hand pane, and you can view and edit their code without leaving this tool.'. - firstRow _ LayoutMorph newRow. - firstRow color: self windowColor. - firstRow - doAdoptWidgetsColor; - - addMorph: searchButton - proportionalWidth: 0.25; - - addMorph: textMorph - proportionalWidth: 0.75. - selectorListView _ PluggableListMorph - model: model - listGetter: #selectorList - indexGetter: #selectorListIndex - indexSetter: #selectorListIndex: - mainView: self - menuGetter: #selectorListMenu - keystrokeAction: #selectorListKey:from:. - secondRow _ LayoutMorph newRow. - secondRow - - addMorph: selectorListView - proportionalWidth: 0.5; - - addAdjusterAndMorph: self buildMorphicMessageList - proportionalWidth: 0.5. - self layoutMorph - - addMorph: firstRow - fixedHeight: self defaultButtonPaneHeight + 4; - - addAdjusterAndMorph: secondRow - proportionalHeight: 0.5; - - addAdjusterAndMorph: self buildLowerPanes - proportionalHeight: 0.5. - model changed: #editSelection.! ! -!MessageNamesWindow methodsFor: 'GUI building' stamp: 'jmv 10/22/2021 12:14:54' prior: 16867816 overrides: 16926852! - submorphToFocusKeyboard - ^textMorph innerTextMorph! ! -!FillInTheBlankMorph methodsFor: 'menu' stamp: 'jmv 10/22/2021 12:15:00' prior: 16844215! - acceptClicked - "Sent by the accept button." - - textPane innerTextMorph acceptContents! ! - -TextModelMorph removeSelector: #textMorph! - -!methodRemoval: TextModelMorph #textMorph stamp: 'Install-4937-Cleanup-JuanVuletich-2021Oct22-12h23m-jmv.001.cs.st 11/2/2021 10:28:05'! -textMorph -self flag: #jmvVer. -"Podemos reemplazar los senders locales por accesos directos (el doble encapsulamiento es tonto) una vez que quede definido el shape de la clase!! -Y la variable deberia ser innerMorph o algo asi... -Y el getter para callers externos tambien deberia ser #innerMorph" - ^ scroller! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4937-Cleanup-JuanVuletich-2021Oct22-12h23m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4937] on 22 October 2021 at 12:50:57 pm'! -!AffineTransformation methodsFor: 'transforming rects' stamp: 'jmv 10/22/2021 12:34:52'! - externalBoundingRectOf: aRectangle - "Externalize aRectangle, and find a bounding rectangle with horizontal and vertical bounds" - - ^Rectangle encompassing: - (aRectangle corners - collect: [ :pt | self transform: pt ])! ! -!MorphicTranslation methodsFor: 'transforming rects' stamp: 'jmv 10/22/2021 12:34:55'! - externalBoundingRectOf: aRectangle - "Externalize aRectangle, and find a bounding rectangle with horizontal and vertical bounds" - - ^ aRectangle translatedBy: self translation.! ! -!Morph methodsFor: 'change reporting' stamp: 'jmv 10/22/2021 12:47:37' prior: 50593520! - invalidateLocalRect: localRectangle - - self - invalidateDisplayRect: - (self externalizeBoundsToWorld: localRectangle) - encompassingIntegerRectangle - for: self.! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/22/2021 12:42:02' prior: 50554562! - externalize: aPoint - "aPoint is in own coordinates. Answer is in owner's coordinates." - - ^ aPoint.! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/22/2021 12:48:55' prior: 50593499! - externalizeBoundsToWorld: aRectangle - - ^owner - ifNotNil: [ owner externalizeBoundsToWorld: aRectangle ] - ifNil: [ aRectangle ]! ! -!MovableMorph methodsFor: 'geometry' stamp: 'jmv 10/22/2021 12:42:11' prior: 50554171 overrides: 50618460! - externalize: aPoint - "aPoint is in own coordinates. Answer is in owner's coordinates." - - ^ location externalizePosition: aPoint.! ! -!MovableMorph methodsFor: 'dropping/grabbing' stamp: 'jmv 10/22/2021 12:48:44' prior: 50593507 overrides: 50618466! - externalizeBoundsToWorld: aRectangle - - | inOwners | - inOwners _ location externalBoundingRectOf: aRectangle. - ^owner - ifNotNil: [ owner externalizeBoundsToWorld: inOwners ] - ifNil: [ inOwners ]! ! -!WorldMorph methodsFor: 'geometry' stamp: 'jmv 10/22/2021 12:48:24' prior: 50593516 overrides: 50618482! - externalizeBoundsToWorld: aRectangle - - ^ aRectangle! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/22/2021 12:37:52' prior: 50616195! - boundingRectOfCurrentMorphAfterDraw - "In targetForm coordinates. - Clipped to owner if appropriate. - Only valid for morphs where #morphLocalBounds is known. - Subclasses may raise this restriction. See inherintance, with VectorGraphics package loaded." - - | boundingRect | - boundingRect _ (currentTransformation externalBoundingRectOf: currentMorph morphLocalBounds) - encompassingIntegerRectangle. - "Include an extra pixel to cover possible anti aliasing." - boundingRect _ boundingRect outsetBy: 1. - ^ clippingMorphDisplayBounds - ifNotNil: [ :ownerClips | boundingRect intersect: ownerClips ] - ifNil: [ boundingRect ]! ! -!BitBltCanvas methodsFor: 'drawing-ovals' stamp: 'jmv 10/22/2021 12:39:38' prior: 50595697 overrides: 50569774! - ellipseCenter: center radius: radiusPointOrNumber borderWidth: mbw borderColor: mbc fillColor: morphFillColor - - | displayRectangle doBorder doFill | - doBorder _ mbw > 0 and: [ mbc isTransparent not]. - doFill _ morphFillColor isTransparent not. - doBorder | doFill ifTrue: [ - displayRectangle _ (currentTransformation externalBoundingRectOf: (Rectangle center: center extent: radiusPointOrNumber asPoint * 2)) rounded. - "draw the border of the oval" - doBorder ifTrue: [ - self setPaintColor: mbc. - engine frameOval: displayRectangle borderWidth: mbw rounded]. - "fill the inside" - doFill ifTrue: [ - self setPaintColor: morphFillColor. - engine fillOval: (displayRectangle insetBy: mbw rounded) ]]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 10/22/2021 12:40:06' prior: 50595761 overrides: 50463466! - frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor - - | rect bw | - r area = 0 ifTrue: [ ^self ]. - rect _ (currentTransformation externalBoundingRectOf: r) rounded. - bw _ (currentTransformation externalizeScalar: borderWidth) rounded. - - "draw the border of the rectangle" - borderColor isTransparent ifFalse: [ - self setPaintColor: borderColor. - engine frameRect: rect borderWidth: bw ]. - - "fill the inside" - fillColor isTransparent ifFalse: [ - self setPaintColor: fillColor. - engine fillRect: (rect insetBy: bw) ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 10/22/2021 12:40:47' prior: 50595783 overrides: 50463473! - frameRectangle: r borderWidth: borderWidth color: borderColor - " - (BitBltCanvas onForm: Display) - frameRectangle: (10@10 extent: 300@200) - borderWidth: 20 - color: Color red. - Display forceToScreen - " - | rect bw | - (borderWidth > 0 and: [ borderColor isTransparent not ]) ifTrue: [ - rect _ (currentTransformation externalBoundingRectOf: r) rounded. - bw _ (currentTransformation externalizeScalar: borderWidth) rounded. - self setPaintColor: borderColor. - engine - frameRect: rect - borderWidth: bw ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 10/22/2021 12:40:52' prior: 50595802! - frameRectangle: aRectangle topLeftColor: tlColor bottomRightColor: brColor borderWidth: borderWidth - " - (BitBltCanvas onForm: Display) - frameRectangle: (10@10 extent: 300@200) - color: Color green - borderWidth: 10 - borderStyleSymbol: #raised. - Display forceToScreen. - " - - | displayRectangle bw | - bw _ (currentTransformation externalizeScalar: borderWidth) rounded. - displayRectangle _ (currentTransformation externalBoundingRectOf: aRectangle) rounded. - self - frameRectangle: displayRectangle - borderWidth: bw - topLeftColor: tlColor - bottomRightColor: brColor.! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 10/22/2021 12:39:50' prior: 50596029! - fillRectangle: aRectangle tilingWith: aForm sourceRect: patternBox rule: aCombinationRule - - | displayRectangle additionalOffset clippedEngine targetTopLeft clipOffset ex - targetBox savedMap top left | - - ex _ patternBox extent. - ex x = 0 ifTrue: [ ^self ]. - ex y = 0 ifTrue: [ ^self ]. - displayRectangle _ (currentTransformation externalBoundingRectOf: aRectangle) rounded. - - "this is a bit of a kludge to get the form to be aligned where I *think* it should be. - something better is needed, but not now" - - additionalOffset _ `0@0`. - clippedEngine _ engine clippedBy: displayRectangle. - targetTopLeft _ clippedEngine clipRect topLeft truncateTo: ex. - clipOffset _ displayRectangle topLeft - targetTopLeft. - additionalOffset _ (clipOffset \\ ex) - ex. - - "do it iteratively" - targetBox _ clippedEngine clipRect. - savedMap _ clippedEngine colorMap. - clippedEngine sourceForm: aForm; - fillColor: nil; - combinationRule: aCombinationRule; - sourceRect: patternBox; - colorMap: (aForm colormapIfNeededFor: clippedEngine destForm). - top _ (targetBox top truncateTo: patternBox height) + additionalOffset y. - left _ (targetBox left truncateTo: patternBox width) + additionalOffset x. - - left to: (targetBox right - 1) by: patternBox width do: [:x | - top to: (targetBox bottom - 1) by: patternBox height do: [:y | - clippedEngine destOrigin: x@y; copyBits]]. - clippedEngine colorMap: savedMap! ! - -MorphicTranslation removeSelector: #displayBoundsOfTransformOf:! - -!methodRemoval: MorphicTranslation #displayBoundsOfTransformOf: stamp: 'Install-4938-Cleanup-JuanVuletich-2021Oct22-12h46m-jmv.001.cs.st 11/2/2021 10:28:05'! -displayBoundsOfTransformOf: aRectangle - "Externalize aRectangle, and find a bounding rectangle with horizontal - and vertical bounds and integer coordinates (i.e. adisplayBounds)." - - ^(aRectangle translatedBy: self translation) encompassingIntegerRectangle! - -AffineTransformation removeSelector: #displayBoundsOfTransformOf:! - -!methodRemoval: AffineTransformation #displayBoundsOfTransformOf: stamp: 'Install-4938-Cleanup-JuanVuletich-2021Oct22-12h46m-jmv.001.cs.st 11/2/2021 10:28:05'! -displayBoundsOfTransformOf: aRectangle - "Externalize aRectangle, and find a bounding rectangle with horizontal - and vertical bounds and integer coordinates (i.e. adisplayBounds)." - - ^Rectangle encompassingInteger: (aRectangle corners collect: [ :pt | - self transform: pt ])! - -GeometryTransformation removeSelector: #externalizeRectangle:! - -!methodRemoval: GeometryTransformation #externalizeRectangle: stamp: 'Install-4938-Cleanup-JuanVuletich-2021Oct22-12h46m-jmv.001.cs.st 11/2/2021 10:28:05'! -externalizeRectangle: aRectangle - ^ (self transform: aRectangle origin) corner: (self transform: aRectangle corner)! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4938-Cleanup-JuanVuletich-2021Oct22-12h46m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4938] on 22 October 2021 at 3:05:28 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/22/2021 14:49:20'! -externalizeBoundingRectOf: aRectangle - - ^aRectangle! ! -!MovableMorph methodsFor: 'dropping/grabbing' stamp: 'jmv 10/22/2021 14:49:26' overrides: 50618702! - externalizeBoundingRectOf: aRectangle - - ^location externalBoundingRectOf: aRectangle.! ! -!InnerListMorph methodsFor: 'list management' stamp: 'jmv 10/22/2021 14:42:22' prior: 50453854! - drawBoundsForRow: row - "calculate the bounds that row should be drawn at. This might be outside our bounds!!" - - ^ 0 @ (self drawYForRow: row) extent: extent x @ font lineSpacing! ! -!HierarchicalListMorph methodsFor: 'selection' stamp: 'jmv 10/22/2021 15:05:07' prior: 16853356 overrides: 16889986! - scrollSelectionIntoView - - | r | - selectedMorph ifNotNil: [ - r _ scroller externalizeBoundingRectOf: - (selectedMorph morphPosition extent: selectedMorph morphExtentInOwner). - self scrollToShow: r ]! ! -!PluggableListMorph methodsFor: 'scrolling' stamp: 'jmv 10/22/2021 14:59:44' prior: 50618015 overrides: 16889986! - scrollSelectionIntoView - "make sure that the current selection is visible" - | row r | - row _ self getCurrentSelectionIndex. - row = 0 - ifTrue: [ - "Value is 0, but we need to propagate it to model" - scrollBar internalScrollValue: scrollBar scrollValue ] - ifFalse: [ - r _ scroller externalizeBoundingRectOf: (scroller drawBoundsForRow: row). - self scrollToShow: r ]. - self scrollMySiblings -! ! - -MovableMorph removeSelector: #externalBoundingRectOf:! - -Morph removeSelector: #externalBoundingRectOf:! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4939-SmallRefactor-JuanVuletich-2021Oct22-14h42m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4939] on 22 October 2021 at 4:06:15 pm'! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 10/22/2021 16:05:10'! - scrollDeltaHeight: anInteger - "Set the increment in pixels which this pane should be scrolled." - self setProperty: #scrollDeltaHeight toValue: anInteger. - self vSetScrollDelta.! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 10/22/2021 16:05:00'! - scrollDeltaWidth: anInteger - "Set the increment in pixels which this pane should be scrolled." - self setProperty: #scrollDeltaWidth toValue: anInteger. - self hSetScrollDelta.! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 10/22/2021 16:02:19' prior: 16889728! - scrollDeltaHeight - "Return the increment in pixels which this pane should be scrolled." - ^ self valueOfProperty: #scrollDeltaHeight ifAbsent: [10]! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'jmv 10/22/2021 16:02:36' prior: 16889735! - scrollDeltaWidth - "Return the increment in pixels which this pane should be scrolled." - ^ self valueOfProperty: #scrollDeltaWidth ifAbsent: [10]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4940-TweakeableScrollDeltas-JuanVuletich-2021Oct22-16h02m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4940] on 25 October 2021 at 1:54:20 pm'! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/25/2021 13:53:34' prior: 50613175! -drawWorld: aWorldMorph rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage backgroundDamage: newDamageFromMorphsBelow - "Redraw the damaged areas. - Draw each morph just once, merging rectanges to be repaired as needed." - - | morph morphDamage allDamage | - "Iterate from back to front." - allDamage _ Rectangle merging: newDamageFromMorphsBelow. - rootMorphs size to: 1 by: -1 do: [ :i | - morph _ rootMorphs at: i. - morphDamage _ rootMorphsDamage at: i. - morph displayFullBounds ifNotNil: [ :morphFullBounds | - newDamageFromMorphsBelow do: [ :r | | intersection | - intersection _ r intersect: morphFullBounds. - intersection hasPositiveExtent ifTrue: [ - morphDamage - ifNil: [ morphDamage _ intersection ] - ifNotNil: [ morphDamage updateMerging: intersection ]]]]. - morphDamage ifNotNil: [ - self newClipRect: morphDamage. - self fullDraw: morph. - newDamageFromMorphsBelow add: morphDamage. - allDamage - ifNil: [ allDamage _ morphDamage copy ] - ifNotNil: [ allDamage updateMerging: morphDamage ]]]. - ^allDamage! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4941-InvalidationTweak-JuanVuletich-2021Oct25-13h53m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4940] on 25 October 2021 at 1:52:30 pm'! -!LayoutMorph class methodsFor: 'instance creation' stamp: 'jmv 10/25/2021 13:51:56' prior: 16863610 overrides: 16783533! - new - "Answer a row by default so the 'new morph' menu doesn't fail..." - ^self newRow color: `(Color red alpha: 0.2)`! ! - -LayoutMorph class removeSelector: #initializedInstance! - -!methodRemoval: LayoutMorph class #initializedInstance stamp: 'Install-4942-LayoutMorph-new-JuanVuletich-2021Oct25-13h50m-jmv.001.cs.st 11/2/2021 10:28:05'! -initializedInstance - "Answer a row by default so the 'new morph' menu doesn't fail..." - ^self newRow color: `(Color red alpha: 0.2)`! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4942-LayoutMorph-new-JuanVuletich-2021Oct25-13h50m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4942] on 25 October 2021 at 4:18:19 pm'! -!Morph methodsFor: 'accessing' stamp: 'jmv 10/25/2021 14:44:19' prior: 50554558! - location - ^ GeometryTransformation identity! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 10/25/2021 14:42:45' prior: 50607627! - imageForm: extentOrNil depth: depth - "Scale as needed. Draw unrotated." - - | prevNotVisibleFlag bounds extent location answer auxCanvas | - "Position and scale us in order to fill required extent, but disregard any rotation. - Do it without triggering any invalidation at all." - prevNotVisibleFlag _ self privateFlagAt: 3. - [ - bounds _ self findFullBoundsInOwner. - extentOrNil - ifNotNil: [ | scale | - extent _ extentOrNil. - scale _ extent x asFloat / bounds width min: extent y asFloat / bounds height. - location _ AffineTransformation withScale: scale position: bounds origin negated +1 * scale ] - ifNil: [ - extent _ bounds extent. - location _ MorphicTranslation withTranslation: bounds origin negated ]. - answer _ Form extent: extent depth: 32. - "Ask for a Canvas with subpixels so it can also handle translucent target" - auxCanvas _ VectorCanvas onFormWithSubPixelAntiAliasing: answer. - auxCanvas geometryTransformation: location. - "But disable subpixel anti aliasing, as we are answering a Form, and therefore can't assume a Display geometry." - auxCanvas engine disableSubPixelSampling. - depth = 32 ifFalse: [ - "Only 32 bpp can hold translucent anti aliasing over transparent background" - answer fillColor: Color veryLightGray ]. - self privateFlagAt: 3 put: false. - auxCanvas fullDraw: self. - ] ensure: [ - self privateFlagAt: 3 put: prevNotVisibleFlag ]. - ^answer asFormOfDepth: depth.! ! -!MorphicCanvas methodsFor: 'morphic world' stamp: 'jmv 10/25/2021 14:38:26' prior: 50617031! - computeDamage: aWorldMorph repair: aDamageRecorder rootMorphs: rootMorphs rootMorphsDamage: rootMorphsDamage - "Iterate front to back while computing damage to actually repair for each morph, and for world background. - Answer uncoveredDamage, the areas where World background needs to be redrawn." - - | uncoveredDamage additionalUncoveredDamage morph morphDamage morphFullBounds | - uncoveredDamage _ aDamageRecorder damageReportedOther. - additionalUncoveredDamage _ OrderedCollection new. - - "Iterate from front to back" - 1 to: rootMorphs size do: [ :i | - morph _ rootMorphs at: i. - morphFullBounds _ morph displayFullBounds. - morphDamage _ nil. - "Reported damage can be ignored if the area fully covered by another morph above us." - (aDamageRecorder damageReportedFor: morph) ifNotNil: [ :r | | wasFullyCovered | - wasFullyCovered _ false. - 1 to: i-1 do: [ :j | - wasFullyCovered _ wasFullyCovered or: [ (rootMorphs at: j) fullyCovers: r ]]. - wasFullyCovered ifFalse: [ - uncoveredDamage add: r ]]. - "Any uncovered damage this morph may overlap must be redrawn by it." - morphFullBounds ifNotNil: [ - uncoveredDamage withIndexDo: [ :r :j | | intersection | - r ifNotNil: [ - intersection _ r intersect: morphFullBounds. - intersection hasPositiveExtent ifTrue: [ - r = intersection ifTrue: [ uncoveredDamage at: j put: nil ]. - morphDamage - ifNil: [ morphDamage _ intersection ] - ifNotNil: [ morphDamage updateMerging: intersection ]]]]]. - rootMorphsDamage at: i put: morphDamage. - uncoveredDamage add: morphDamage. - "Whatever we cover completely is no longer uncoveredDamage" - uncoveredDamage withIndexDo: [ :r :ri | - r ifNotNil: [ - morph - on: r - ifCovered: [uncoveredDamage at: ri put: nil] - uncoveredPartsDo: [ :r2 | additionalUncoveredDamage add: r2 ] - else: []]]. - uncoveredDamage addAll: additionalUncoveredDamage. - additionalUncoveredDamage removeAll. - ]. - - "Remove redundant rectangles" - 1 to: uncoveredDamage size do: [ :i1 | - (uncoveredDamage at: i1) ifNotNil: [ :r1 | - 1 to: uncoveredDamage size do: [ :i2 | - i1 = i2 ifFalse: [ - (uncoveredDamage at: i2) ifNotNil: [ :r2 | - (r1 containsRect: r2) - ifTrue: [ uncoveredDamage at: i2 put: nil ]]]]]]. - - "Answer any yet uncovered areas. World background should be drawn on them." - ^ uncoveredDamage select: [ :r | r notNil ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4943-Morph-imageFormdepth-JuanVuletich-2021Oct25-16h17m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4943] on 25 October 2021 at 4:39:04 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/25/2021 16:24:56' prior: 50571322! - adjustDisplayBoundsBy: delta - "Private for framework use. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us." - - privateDisplayBounds ifNotNil: [ - privateDisplayBounds _ delta ifNil: [ nil ] ifNotNil: [privateDisplayBounds translatedBy: delta]]. - self allSubmorphsDo: [ :m | m adjustDisplayBoundsBy: delta ].! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 10/25/2021 16:35:33' prior: 50616383! - grabMorph: aMorph delta: delta - "Grab the given morph (i.e., add it to this hand and remove it from its current owner)." - - | formerOwner formerPositionInWorld | - self releaseMouseFocus. "Break focus" - - "Grab the halo if present" - self halo ifNotNil: [ :h | - (h target == aMorph or: [h target hasOwner: aMorph]) ifTrue: [ - self addMorphBack: h position: h morphPositionInWorld - self morphPositionInWorld ]]. - - "Remember previous owner and position, in case the drop is later rejected" - formerOwner _ aMorph owner. - formerOwner ifNotNil: [ - formerPositionInWorld _ aMorph morphPositionInWorld. - grabMorphData - at: aMorph - put: { formerOwner. formerPositionInWorld. } ]. - self addMorphBack: aMorph position: delta. - - aMorph displayBounds ifNotNil: [ :r | | d | - d _ formerPositionInWorld ifNotNil: [aMorph morphPositionInWorld - formerPositionInWorld]. - (d isNil or: [d isZero not]) ifTrue: [ - aMorph adjustDisplayBoundsBy: d ]]. - - aMorph justGrabbedFrom: formerOwner. - formerOwner ifNotNil: [ - "Morph was in the world" - lastPosition _ self morphPosition ].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4944-openInHand-invalidation-fix-JuanVuletich-2021Oct25-16h38m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4944] on 25 October 2021 at 4:49:05 pm'! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 10/25/2021 16:43:07' prior: 50616323! - displayFullBoundsForPatch - "Current full bounds of hand and carried submorphs. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around). - Integer pixel coordinates!!" - - | handBounds fullBounds submorphBounds | - handBounds _ self basicDisplayBounds. - submorphBounds _ nil. - self submorphsDo: [ :m | - submorphBounds _ m displayFullBounds quickMerge: submorphBounds ]. - fullBounds _ handBounds quickMerge: submorphBounds. - lastPosition - ifNotNil: [ :lastPos | "When already carrying morphs around. Update rectangle to current hand position." - fullBounds _ fullBounds quickMerge: (submorphBounds translatedBy: self morphPosition-lastPos) ]. - ^fullBounds encompassingIntegerRectangle! ! -!BitBltBoundsFinderCanvas methodsFor: 'morphic' stamp: 'jmv 10/25/2021 16:40:28' prior: 50595418! - updateHandsDisplayBounds: aWorldMorph - "Update displayBounds for carried morphs if never set. - Useful for new morph, that are created and attached to the hand." - - aWorldMorph handsDo: [ :hand | - hand hasSubmorphs ifTrue: [ - self into: hand. - hand submorphsDo: [ :morph | - morph basicDisplayBounds ifNil: [ - self fullUpdateProtrudingBounds: morph ]]. - self outOfMorph ]].! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4945-tweak-JuanVuletich-2021Oct25-16h47m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4945] on 25 October 2021 at 6:51:23 pm'! -!Morph methodsFor: 'drawing' stamp: 'jmv 9/13/2021 17:26:23' prior: 50618873! - imageForm: extentOrNil depth: depth - - self subclassResponsibility! ! -!Morph methodsFor: 'updating' stamp: 'jmv 10/25/2021 18:50:03' prior: 50615913! - invalidateBounds - "Report that the area occupied by this morph and submorphs should be redrawn, - but most likely we are not going to be redrawn on it, or maybe we'll not be fully visible. See senders." - - self displayFullBounds ifNotNil: [ :r | - self invalidateDisplayRect: r for: nil ]. -! ! -!Morph methodsFor: 'updating' stamp: 'jmv 10/25/2021 18:50:09' prior: 50615927! - redrawNeeded - "Report that the area occupied by this morph should be redrawn. - Usually because we changed in some way. - Notes: - Area used before any change is reported here. - Area used after any changes is reported when displayBounds are updated. - See updateBoundsIn:addDamageTo: and senders. - " - - self needsRedraw: true. - self allOwnersDo: [ :m | m submorphNeedsRedraw: true ]. - self basicDisplayBounds ifNotNil: [ :b | - self invalidateDisplayRect: b for: self ]. - (self submorphsMightProtrude and: [self clipsSubmorphsReally not]) ifTrue: [ - self submorphsReverseDo: [ :m | m redrawNeeded ]]. - self removeProperty: #bitMask. - self removeProperty: #fullBoundsInOwner.! ! -!Morph methodsFor: 'private' stamp: 'jmv 10/25/2021 18:49:29' prior: 50616847! - privateAddAllMorphs: aCollection atIndex: index - "Private. Add aCollection of morphs to the receiver" - | myWorld itsWorld otherSubmorphs | - (aCollection allSatisfy: [ :m | self canAdd: m]) ifFalse: [ - (self confirm: 'Some requested morph requires VectorGraphics support. Do you want to install and activate it?') - ifTrue: [ - Feature require: 'VectorGraphics'. - MorphicCanvas activeSubclass: (Smalltalk at: #HybridCanvas) ] - ifFalse: [ - ^self error: 'We can''t add requested morphs.' ]]. - myWorld _ self world. - otherSubmorphs _ submorphs copyWithoutAll: aCollection. - (index between: 0 and: otherSubmorphs size) - ifFalse: [^ self error: 'index out of range']. - index = 0 - ifTrue:[ submorphs _ aCollection asArray, otherSubmorphs] - ifFalse:[ index = otherSubmorphs size - ifTrue:[ submorphs _ otherSubmorphs, aCollection] - ifFalse:[ submorphs _ otherSubmorphs copyReplaceFrom: index + 1 to: index with: aCollection ]]. - aCollection do: [:m | | itsOwner | - itsOwner _ m owner. - itsOwner ifNotNil: [ - itsWorld _ m world. - (itsWorld == myWorld) ifFalse: [ - itsWorld ifNotNil: [m redrawNeeded]]. - (itsOwner ~~ self) ifTrue: [ - m owner privateRemove: m. - m owner removedMorph: m ]]. - m privateOwner: self. - myWorld ifNotNil: [m redrawNeeded]. - (myWorld == itsWorld) ifFalse: [m intoWorld: myWorld]. - itsOwner == self ifFalse: [ - self addedMorph: m. - m noteNewOwner: self ]. - ]. - self privateArrangeWantsToBeOnTop. - self someSubmorphPositionOrExtentChanged! ! -!Morph methodsFor: 'private' stamp: 'jmv 10/25/2021 18:49:39' prior: 50616897! - privateAddMorph: aMorph atIndex: index position: aPointOrNil - - | oldIndex myWorld itsWorld oldOwner | - (self canAdd: aMorph) ifFalse: [ - (self confirm: 'The requested morph requires VectorGraphics support. Do you want to install and activate it?') - ifTrue: [ - Feature require: 'VectorGraphics'. - MorphicCanvas activeSubclass: (Smalltalk at: #HybridCanvas) ] - ifFalse: [ - ^self error: 'We can''t add requested morph.' ]]. - ((index >= 1) and: [index <= (submorphs size + 1)]) - ifFalse: [^ self error: 'index out of range']. - myWorld _ self world. - oldOwner _ aMorph owner. - (oldOwner == self and: [(oldIndex _ submorphs indexOf: aMorph) > 0]) ifTrue: [ - "aMorph's position changes within in the submorph chain" - oldIndex < index ifTrue:[ - "moving aMorph to back" - submorphs replaceFrom: oldIndex to: index-2 with: submorphs startingAt: oldIndex+1. - submorphs at: index-1 put: aMorph. - ] ifFalse:[ - "moving aMorph to front" - oldIndex-1 to: index by: -1 do:[:i| - submorphs at: i+1 put: (submorphs at: i)]. - submorphs at: index put: aMorph. - ]. - aPointOrNil ifNotNil: [aMorph privatePosition: aPointOrNil]. - ] ifFalse: [ - "adding a new morph" - oldOwner ifNotNil: [ - itsWorld _ aMorph world. - itsWorld ifNotNil: [aMorph invalidateBounds]. - oldOwner privateRemove: aMorph. - oldOwner removedMorph: aMorph. - ]. - aMorph privateOwner: self. - submorphs _ submorphs copyReplaceFrom: index to: index-1 with: (Array with: aMorph). - aPointOrNil ifNotNil: [aMorph privatePosition: aPointOrNil]. - (itsWorld == myWorld) ifFalse: [aMorph intoWorld: myWorld]. - ]. - myWorld ifNotNil: [ - index = 1 - ifTrue: [aMorph redrawNeeded ] - ifFalse: [aMorph invalidateBounds]]. - self privateArrangeWantsToBeOnTop. - self someSubmorphPositionOrExtentChanged. - oldOwner == self ifFalse: [ - self addedMorph: aMorph. - aMorph noteNewOwner: self ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4946-Tweaks-JuanVuletich-2021Oct25-18h48m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4947] on 26 October 2021 at 3:26:57 pm'! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 10/26/2021 15:26:47' prior: 50619067! - displayFullBoundsForPatch - "Current full bounds of hand and carried submorphs. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around). - Integer pixel coordinates!!" - - | handBounds fullBounds submorphBounds | - handBounds _ self basicDisplayBounds. - submorphBounds _ nil. - self submorphsDo: [ :m | - m displayFullBounds ifNotNil: [ :b | - submorphBounds _ b quickMerge: submorphBounds ]]. - fullBounds _ handBounds quickMerge: submorphBounds. - lastPosition - ifNotNil: [ :lastPos | "When already carrying morphs around. Update rectangle to current hand position." - fullBounds _ fullBounds quickMerge: (submorphBounds translatedBy: self morphPosition-lastPos) ]. - ^fullBounds encompassingIntegerRectangle! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4947-Tweak-JuanVuletich-2021Oct26-15h26m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4940] on 25 October 2021 at 11:19:49 am'! -!PositionableStream methodsFor: 'accessing' stamp: 'jmv 10/25/2021 11:18:50'! - upTo: delimiter delimiterIsTerminator: delimiterIsTerminator - "Answer a subcollection from the current access position to the - occurrence of delimiter in the receiver. - - If delimiterIsTerminator is false, delimiter is considered a separator: - - Skip delimiter, but don't include it in the answer. - - If delimiter is not found, answer the entire rest of the receiver. - - If delimiterIsTerminator is true, answer will end with delimeter: - - Read delimiter, include it in the answer. - - If delimiter is not found, answer nil and don't advance receiver at all. - This is especially useful if we are appended new stuff while simultaneusly being read." - - | prevPosition element answer | - prevPosition _ self position. - answer _ self collectionSpecies streamContents: [ :newStream | - [self atEnd or: [(element _ self next) = delimiter]] - whileFalse: [newStream nextPut: element]. - delimiterIsTerminator ifTrue: [ - element = delimiter - ifTrue: [newStream nextPut: element] - ifFalse: [ - self position: prevPosition. - ^ nil ]]]. - ^answer.! ! -!ReadStream methodsFor: 'accessing' stamp: 'jmv 10/25/2021 09:58:29' overrides: 50619309! - upTo: delimiter delimiterIsTerminator: delimiterIsTerminator - "See comment at PositionableStream. - Fast version using indexOf:" - - | start end | - - start _ position+1. - end _ collection indexOf: delimiter startingAt: start ifAbsent: [0]. - - "not present" - end = 0 ifTrue: [ - ^ delimiterIsTerminator - ifTrue: [ - self position: start-1. - nil ] - ifFalse: [self upToEnd]]. - - "skip to the end and return the data passed over" - position _ end. - ^collection copyFrom: start to: (delimiterIsTerminator ifTrue: [end] ifFalse: [end-1])! ! -!StandardFileStream methodsFor: 'read, write, position' stamp: 'jmv 10/25/2021 10:00:18' overrides: 50619309! - upTo: delimiter delimiterIsTerminator: delimiterIsTerminator - "See comment at PositionableStream. - Fast version to speed up nextChunk" - - | pos buffer count skipSeparator tryAgain | - skipSeparator _ delimiterIsTerminator ifTrue: [0] ifFalse: [1]. - collection ifNotNil: [ - (position < readLimit and: [ - (pos _ collection indexOf: delimiter startingAt: position + 1) <= readLimit and: [ - pos > 0 ] ]) ifTrue: [ - ^ collection copyFrom: position + 1 to: (position _ pos) - skipSeparator ] ]. - - pos _ self position. - buffer _ self next: 2000. - (count _ buffer indexOf: delimiter) > 0 ifTrue: [ - "Found the delimiter part way into buffer" - self position: pos + count. - ^ buffer copyFrom: 1 to: count - skipSeparator]. - - self atEnd ifTrue: [ - "Never found it, and hit end of file" - ^ delimiterIsTerminator ifTrue: [self position: pos. nil] ifFalse: [buffer]]. - - "Never found it, but there's more..." - tryAgain _ self upTo: delimiter delimiterIsTerminator: delimiterIsTerminator. - tryAgain ifNil: [ - self position: pos. - ^ nil ]. - ^ buffer, tryAgain.! ! -!PositionableStream methodsFor: 'accessing' stamp: 'jmv 10/24/2021 20:57:46' prior: 16891470! - upTo: delimiter - "Answer a subcollection from the current access position to the - occurrence (if any, but not inclusive) of delimiter in the receiver. If - delimiter is not in the collection, answer the entire rest of the receiver." - - ^self upTo: delimiter delimiterIsTerminator: false.! ! - -StandardFileStream removeSelector: #upTo:! - -!methodRemoval: StandardFileStream #upTo: stamp: 'Install-4948-upTodelimiterIsTerminator-NicolaMingotti-JuanVuletich-2021Oct25-09h28m-jmv.001.cs.st 11/2/2021 10:28:05'! -upTo: delim - "Fast version to speed up nextChunk" - | pos buffer count | - collection ifNotNil: [ - (position < readLimit and: [ - (pos := collection indexOf: delim startingAt: position + 1) <= readLimit and: [ - pos > 0 ] ]) ifTrue: [ - ^collection copyFrom: position + 1 to: (position := pos) - 1 ] ]. - pos := self position. - buffer := self next: 2000. - (count := buffer indexOf: delim) > 0 ifTrue: - ["Found the delimiter part way into buffer" - self position: pos + count. - ^ buffer copyFrom: 1 to: count - 1]. - self atEnd ifTrue: - ["Never found it, and hit end of file" - ^ buffer]. - "Never found it, but there's more..." - ^ buffer , (self upTo: delim)! - -ReadStream removeSelector: #upTo:! - -!methodRemoval: ReadStream #upTo: stamp: 'Install-4948-upTodelimiterIsTerminator-NicolaMingotti-JuanVuletich-2021Oct25-09h28m-jmv.001.cs.st 11/2/2021 10:28:05'! -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)! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4948-upTodelimiterIsTerminator-NicolaMingotti-JuanVuletich-2021Oct25-09h28m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4948] on 26 October 2021 at 6:38:33 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/26/2021 18:36:22' prior: 50593039! - displayFullBounds - "Answer a rectangle that completely bounds receiver and submorphs when last drawn - (if the world was to be fully drawn, i.e. only to be used on a Canvas on the full world). - Integer pixel coordinates!!" - - | answer | - answer _ self basicDisplayBounds. - answer ifNil: [ ^nil ]. - (self submorphsMightProtrude and: [self clipsSubmorphsReally not]) ifTrue: [ - self submorphsReverseDo: [ :m | - answer _ answer quickMerge: m displayFullBounds ]]. - ^answer! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 10/26/2021 18:34:48' prior: 50619275! - displayFullBoundsForPatch - "Current full bounds of hand and carried submorphs. - Submorphs might have never been drawn at this hand position (this is usually the case when dragging morphs around). - Integer pixel coordinates!!" - - | handBounds fullBounds submorphBounds | - handBounds _ self basicDisplayBounds. - submorphBounds _ nil. - self submorphsDo: [ :m | - m displayFullBounds ifNotNil: [ :b | - submorphBounds _ b quickMerge: submorphBounds ]]. - fullBounds _ handBounds quickMerge: submorphBounds. - lastPosition - ifNotNil: [ :lastPos | "When already carrying morphs around. Update rectangle to current hand position." - fullBounds _ fullBounds quickMerge: (submorphBounds translatedBy: self morphPosition-lastPos) ]. - ^fullBounds encompassingIntegerRectangle! ! -!DamageRecorder methodsFor: 'private' stamp: 'jmv 10/26/2021 18:37:56' prior: 50613337! - pvtInnerRecordInvalidRect: requestedRect for: aRootMorph - "Record the given rectangle in my damage list, a list of rectangular areas of the display that should be redraw on the next display cycle." - - aRootMorph ifNotNil: [ - (damageByRoot at: aRootMorph - ifPresent: [ :r | r updateMerging: requestedRect] - ifAbsent: [ damageByRoot at: aRootMorph put: requestedRect copy ]) ] - ifNil: [otherDamage add: requestedRect copy].! ! - -Rectangle removeSelector: #encompassingIntegerRectangleX! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4949-DamageRectsAreAlwaysInteger-JuanVuletich-2021Oct26-18h28m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4948] on 26 October 2021 at 6:44:05 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/26/2021 18:41:50' prior: 50597192! - fullBoundsInOwner - "Answer fullBoundsInOwner. Cache the found bounds. - Note: Answers an integer rectangle" - - (self valueOfProperty: #fullBoundsInOwner) ifNotNil: [ :fullBoundsInOwner | - ^fullBoundsInOwner ]. - - ^self setProperty: #fullBoundsInOwner toValue: self findFullBoundsInOwner.! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/26/2021 18:42:22' prior: 50612231! - morphExtentInOwner - "Note: Answers an integer point" - - ^self fullBoundsInOwner extent! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/26/2021 18:43:05' prior: 50617622! - topLeftInOwner - "Note: Answers an integer rectangle" - - ^self fullBoundsInOwner origin! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 10/26/2021 18:41:42' prior: 50601444 overrides: 50601474! - findFullBoundsInOwner - "Find and answer full bounds in whatever owner. - These might not equal #displayFullBounds at all!! - Note: Answers an integer rectangle" - - self requiresVectorCanvas ifTrue: [ - ^super findFullBoundsInOwner ]. - - "#morphExtent exists, and it is also valid in owner, because #requiresVectorCanvas is false." - ^(self morphPosition extent: self morphExtent) encompassingIntegerRectangle.! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 10/26/2021 18:41:46' prior: 50601459 overrides: 50601474! - findFullBoundsInOwner - "Find and answer full bounds in whatever owner. - These might not equal #displayFullBounds at all!! - Note: Answers an integer rectangle" - - self requiresVectorCanvas ifTrue: [ - ^super findFullBoundsInOwner ]. - - "#morphExtent exists, and it is also valid in owner, because #requiresVectorCanvas is false." - ^(self morphPosition extent: self morphExtent) encompassingIntegerRectangle.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4950-StateThatInComments-JuanVuletich-2021Oct26-18h38m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4950] on 28 October 2021 at 11:22:39 am'! -!Morph methodsFor: 'accessing' stamp: 'jmv 10/28/2021 11:18:04'! - boundsFinderCanvas - "Might answer nil if not in a world!!" - - ^ self canvas ifNotNil: [ :c | c boundsFinderCanvas ]! ! -!Morph methodsFor: 'accessing' stamp: 'jmv 10/27/2021 16:06:26'! - canvas - "Might answer nil if not in a world!!" - - ^ self topmostWorld ifNotNil: [ :w | w canvas ].! ! -!MorphicCanvas methodsFor: 'testing' stamp: 'jmv 10/27/2021 16:10:26'! - canDoVectorGraphics - ^false! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/27/2021 16:07:00' prior: 50604653! - displayBoundsSetFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Clipped appropiately if some owner clips us. - See also #displayBoundsUpdateFrom:" - - self canvas ifNotNil: [ :c | - (aCanvas isBoundsFinderCanvas or: [c canvasToUse == aCanvas canvasToUse]) ifTrue: [ - privateDisplayBounds _ aCanvas canvasToUse boundingRectOfCurrentMorphAfterDraw. - self wantsContour - ifTrue: [ - (aCanvas canvasToUse - contourOfCurrentMorphAfterDrawInto: (self valueOfProperty: #contour) - into: [ :contourArray :contourY0 :contourY1 | - self setProperty: #contour toValue: contourArray. - self setProperty: #contourY0 toValue: contourY0. - self setProperty: #contourY1 toValue: contourY1 ])] - ifFalse: [ - self setProperty: #contour toValue: nil. - self setProperty: #contourY0 toValue: nil. - self setProperty: #contourY1 toValue: nil ]]].! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/27/2021 16:07:14' prior: 50604689! - displayBoundsUpdateFrom: aCanvas - "Private for framework use. - At time of last draw on world canvas. nil if unknown. - Only to be used for the world canvas (i.e. this ivar is not to represent our bounds in any other context). - Rectangle is clipped appropiately if some owner clips us. - To be called after #postDrawOn:. See also #displayBoundsSetFrom: - This more complicated update is needed because the contour information from #drawOn: was possibly - when drawing submorphs. So, the controur from #drawOn: needs to be retrieved, and updated with the - new contour information from #postDrawOn:" - - self canvas ifNotNil: [ :c | - (aCanvas isBoundsFinderCanvas or: [c canvasToUse == aCanvas canvasToUse]) ifTrue: [ - privateDisplayBounds _ privateDisplayBounds - quickMerge: aCanvas canvasToUse boundingRectOfCurrentMorphAfterDraw. - self wantsContour ifTrue: [ - (aCanvas canvasToUse - contourOfCurrentMorphAfterDrawUpdate: (self valueOfProperty: #contour) - oldTop: (self valueOfProperty: #contourY0) - oldBottom: (self valueOfProperty: #contourY1) - into: [ :contourArray :contourY0 :contourY1 | - self setProperty: #contour toValue: contourArray. - self setProperty: #contourY0 toValue: contourY0. - self setProperty: #contourY1 toValue: contourY1 ])]]].! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 10/27/2021 16:21:16' prior: 50608810! -coversPixel: worldPoint - "Answer true if pixel worldPoint is covered by us, even if we are not visible a it because of some - other morph above us also covers it. - See #bitMask. - Remember to do - self removeProperty: #bitMask. - when appropriate!! (i.e. when we change in such a way to make the bitMask invalid). - - Note: Subclasses such as KernelMorph and WidgetMorph redefine this method with an optimized - implementation that doesn't require computing and invalidating the #bitMask. Senders in the base image - and framework actually only use this optimized implementation. That's why general morphs don't care about - invalidting #bitMask. - - Note: If your morph #requiresVectorCanvas, and depends on this general implementation, remember to - `removeProperty: #bitMask` whenever it becomes invalid due to changes in your morphs. You may consider - using #ownsPixel: if appropriate, that doesn't require any maintenance and is cheaper (in cpu and memory). - - Note: This implementation requires VectorGraphics. - - See #ownsOrCoversPixel:" - - self visible ifTrue: [ - ^(self bitMask pixelValueAt: worldPoint - self displayFullBounds topLeft) = 1 ]. - ^ false! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 10/27/2021 16:04:46' prior: 50608507! - ownsOrCoversPixel: worldPoint - "Answer true if we own the pixel, i.e. we are the last morph drawn at worldPoint. - Some implementations (KernelMorph and WidgetMorph) may also answer true if we cover but don't own the pixel, - meaning that some other morph was drawn later, covering us. - - Therefore, senders need to be aware that the answer is meaningful only when it is known that no other morph - covers us. A common case is to find the topmost morph at some position. In that case, iterating front to back ensures - that if any other morph covers us, it is found first. - - Note: This implementation is only used for morphs drawn by VectorCanvas, either because the main canvas is a - VectorCanvas, or because it is a HybridCanvas and we answer true to #requiresVectorCanvas. - (See other implementors) - Note: Also see #ownsPixel: and #coversPixel:" - - ^ self ownsPixel: worldPoint.! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 10/27/2021 16:07:29' prior: 50608530! - ownsPixel: worldPoint - "Answer true if we own the pixel, i.e. we are the last morph drawn at worldPoint. - Requires VectorGraphics. - In case of running on HybridCanvas, this method is only valid for morphs that - are drawon by VectorCanvas (i.e. they answer true to #requiresVectorCanvas)." - - self canvas ifNotNil: [ :canvas | - ^ (canvas morphIdAt: worldPoint) = self morphId ]. - ^ false.! ! -!HandMorph methodsFor: 'geometry' stamp: 'jmv 10/28/2021 11:18:30' prior: 50595555 overrides: 50592880! - basicDisplayBounds - - ^ self boundsFinderCanvas displayBoundsForHand: self! ! -!WidgetMorph methodsFor: 'halos and balloon help' stamp: 'jmv 10/27/2021 16:07:44' prior: 50603531 overrides: 50603548! - okayToRotateEasily - "Answer whether it is appropriate for a rotation handle to be shown for the receiver." - - ^ self canvas usesVectorEnginePlugin.! ! -!WidgetMorph methodsFor: 'halos and balloon help' stamp: 'jmv 10/27/2021 16:07:55' prior: 50603540 overrides: 50603556! - okayToScaleEasily - "Answer whether it is appropriate for a scale handle to be shown for the receiver." - - ^ self canvas usesVectorEnginePlugin.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4951-Refactor-JuanVuletich-2021Oct28-11h14m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4928] on 27 October 2021 at 3:11:25 pm'! -!Morph methodsFor: 'geometry services' stamp: 'jmv 10/27/2021 15:10:52' prior: 50608429! - fullOwnsOrCoversPixel: worldPoint - "Answer true if worldPoint is in some submorph, even if not inside our shape. - See comment at #ownsOrCoversPixel: for important notes on behavior." - - (self ownsOrCoversPixel: worldPoint) ifTrue: [ ^ true ]. - self submorphsMightProtrude ifTrue: [ - self submorphsDo: [ :m | - (m fullOwnsOrCoversPixel: worldPoint) ifTrue: [ ^ true ]]]. - ^ false.! ! - -WidgetMorph removeSelector: #fullOwnsOrCoversPixel:! - -!methodRemoval: WidgetMorph #fullOwnsOrCoversPixel: stamp: 'Install-4952-fullOwnsOrCoversPixel-JuanVuletich-2021Oct27-15h10m-jmv.001.cs.st 11/2/2021 10:28:05'! -fullOwnsOrCoversPixel: worldPoint - "Answer true if worldPoint is in some submorph, even if not inside our shape. - See comment at #ownsOrCoversPixel: for important notes on behavior." - - (self ownsOrCoversPixel: worldPoint) ifTrue: [ ^ true ]. - self submorphsMightProtrude ifTrue: [ - self submorphsDo: [ :m | - (m fullOwnsOrCoversPixel: worldPoint) ifTrue: [ ^ true ]]]. - ^ false.! - -KernelMorph removeSelector: #fullOwnsOrCoversPixel:! - -!methodRemoval: KernelMorph #fullOwnsOrCoversPixel: stamp: 'Install-4952-fullOwnsOrCoversPixel-JuanVuletich-2021Oct27-15h10m-jmv.001.cs.st 11/2/2021 10:28:05'! -fullOwnsOrCoversPixel: worldPoint - "Answer true if worldPoint is in some submorph, even if not inside our shape. - See comment at #ownsOrCoversPixel: for important notes on behavior." - - (self ownsOrCoversPixel: worldPoint) ifTrue: [ ^ true ]. - self submorphsMightProtrude ifTrue: [ - self submorphsDo: [ :m | - (m fullOwnsOrCoversPixel: worldPoint) ifTrue: [ ^ true ]]]. - ^ false.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4952-fullOwnsOrCoversPixel-JuanVuletich-2021Oct27-15h10m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4952] on 28 October 2021 at 11:51:57 am'! -!Morph methodsFor: 'geometry services' stamp: 'jmv 10/28/2021 11:46:45' prior: 50619698! - coversPixel: worldPoint - "Answer true if pixel worldPoint is covered by us, even if we are not visible a it because of some - other morph above us also covers it. - - See #bitMask. - Remember to do - self removeProperty: #bitMask. - when appropriate!! (i.e. when we change in such a way to make the bitMask invalid). - - Note: Subclasses such as KernelMorph and WidgetMorph redefine this method with an optimized - implementation that doesn't require computing and invalidating the #bitMask. Senders in the base image - and framework actually only use this optimized implementation. That's why general morphs don't care about - invalidting #bitMask. - - Note: If your morph #requiresVectorCanvas, and depends on this general implementation, remember to - `removeProperty: #bitMask` whenever it becomes invalid due to changes in your morphs. You may consider - using #ownsPixel: if appropriate, that doesn't require any maintenance and is cheaper (in cpu and memory). - - Note: This implementation requires VectorGraphics. - - See #ownsPixel: - See #ownsOrCoversPixel:" - - self visible ifTrue: [ - "Expensive way for morphs with arbitrary shape in VectorGraphics. - The base Cuis System doesn't use this. - Use this in applications if the expense of maintaining #bitMask is worth it." - self canvas ifNotNil: [ :canvas | - canvas canDoVectorGraphics ifTrue: [ - ^(self bitMask pixelValueAt: worldPoint - self displayFullBounds topLeft) = 1 ]]. - - "This is cheap and OK for unrotated Morphs with a rectangular shape. - In general, the answer is not strictly correct. - WidgetMorph redefines this method with an equally cheap implementation that can also handle - rotated morphs (but assuming they are of rectangular shape)." - self basicDisplayBounds ifNotNil: [ :r | - ^ r containsPoint: worldPoint ]]. - - ^ false.! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 10/28/2021 11:50:48' prior: 50619737! - ownsOrCoversPixel: worldPoint - "Answer true if we own the pixel, i.e. we are the last morph drawn at worldPoint. - - Some implementations (KernelMorph and WidgetMorph) may also answer true if we cover but don't own the pixel, - meaning that some other morph was drawn later, covering us. - - For other morphs, not KernelMorph or WidgetMorph, (i.e. they run this implementation), if VectorGraphics is not active, - answer true for any point that lies within our bounds. If this is the case, consider using VectorGraphics: In addition to - many other advantages, this method will always answer a strictly correct answer. - - Therefore, senders need to be aware that the answer is meaningful only when it is known that no other morph - covers us. A common case is to find the topmost morph at some position. In that case, iterating front to back ensures - that if any other morph covers us, it is found first. - - Note: This implementation is only used for morphs drawn by VectorCanvas, either because the main canvas is a - VectorCanvas, or because it is a HybridCanvas and we answer true to #requiresVectorCanvas. - (See other implementors) - - Note: Also see #ownsPixel: and #coversPixel:" - - "Check if #ownsPixel:, if possible." - self canvas ifNotNil: [ :canvas | - canvas canDoVectorGraphics ifTrue: [ - ^ (canvas morphIdAt: worldPoint) = self morphId ]]. - - "This is cheap and OK for unrotated Morphs with a rectangular shape. - In general, the answer is not strictly correct. - WidgetMorph redefines this method with an equally cheap implementation that can also handle - rotated morphs (but assuming they are of rectangular shape)." - self visible ifTrue: [ - self basicDisplayBounds ifNotNil: [ :r | - ^r containsPoint: worldPoint ]]. - - ^ false.! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 10/28/2021 11:41:15' prior: 50619768! - ownsPixel: worldPoint - "Answer true if we own the pixel, i.e. we are the last morph drawn at worldPoint. - Requires VectorGraphics, as we need VectorCanvas' morphIdAt: service. - - Valid if running on VectorCanvas. - - In case of running on HybridCanvas, this method is only valid for morphs that - are drawn by VectorCanvas (i.e. they answer true to #requiresVectorCanvas). - - See #coversPixel: - See #ownsOrCoversPixel:" - - self canvas ifNotNil: [ :canvas | - canvas canDoVectorGraphics ifTrue: [ - ^ (canvas morphIdAt: worldPoint) = self morphId ]]. - ^ false.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4953-owns-covers-pixel-JuanVuletich-2021Oct28-11h32m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4953] on 28 October 2021 at 12:20:10 pm'! -!Morph methodsFor: 'geometry services' stamp: 'jmv 10/28/2021 12:00:05'! - fullIncludesPixel: worldPoint - "Answer true if worldPoint is in some submorph, even if not inside our shape. - See comment at #includesPixel: for important notes on behavior." - - (self includesPixel: worldPoint) ifTrue: [ ^ true ]. - self submorphsMightProtrude ifTrue: [ - self submorphsDo: [ :m | - (m fullIncludesPixel: worldPoint) ifTrue: [ ^ true ]]]. - ^ false.! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 10/28/2021 12:18:50'! - includesPixel: worldPoint - "Answer true if we own the pixel, i.e. we are the last morph drawn at worldPoint. - - Some implementations (KernelMorph and WidgetMorph) may also answer true if we cover but don't own the pixel, - meaning that some other morph was drawn later, covering us. - - For other morphs, not KernelMorph or WidgetMorph, (i.e. they run this implementation), if VectorGraphics is not active, - answer true for any point that lies within our bounds. If this is the case, consider using VectorGraphics: In addition to - many other advantages, this method will always answer a strictly correct answer. - - Therefore, senders need to be aware that the answer is meaningful only when it is known that no other morph - covers us. A common case is to find the topmost morph at some position. In that case, iterating front to back ensures - that if any other morph covers us, it is found first. - - Note: This method is redefined by some subclasses. This implementation is only used for morphs drawn by VectorCanvas, - either because the main canvas is a VectorCanvas, or because it is a HybridCanvas and we answer true to #requiresVectorCanvas. - (See other implementors) - - Note: Also see #ownsPixel: and #coversPixel:" - - "Check if #ownsPixel:, if possible." - self canvas ifNotNil: [ :canvas | - canvas canDoVectorGraphics ifTrue: [ - ^ (canvas morphIdAt: worldPoint) = self morphId ]]. - - "This is cheap and OK for unrotated Morphs with a rectangular shape. - In general, the answer is not strictly correct. (There are false positives). - WidgetMorph redefines this method with an equally cheap implementation that can also handle - rotated morphs (but assuming they are of rectangular shape)." - self visible ifTrue: [ - self basicDisplayBounds ifNotNil: [ :r | - ^r containsPoint: worldPoint ]]. - - ^ false.! ! -!KernelMorph methodsFor: 'geometry services' stamp: 'jmv 10/28/2021 11:57:23' overrides: 50620034! - includesPixel: worldPoint - "Answer true if we own the pixel, i.e. we are the last morph drawn at worldPoint. (See implementation at Morph). - This implementation also answer true if we cover but don't own the pixel, - meaning that some other morph was drawn later, covering us. - Therefore, senders need to be aware that the answer is meaningful only when it is known that no other morph covers us. - Note: This implementation is only used for morphs with a cheap #coversPixel:. - (See other implementors) - Note: Also see #ownsPixel: and #coversPixel:" - - ^ self visible and: [self coversPixel: worldPoint].! ! -!WidgetMorph methodsFor: 'geometry services' stamp: 'jmv 10/28/2021 11:57:27' overrides: 50620034! -includesPixel: worldPoint - "Answer true if we own the pixel, i.e. we are the last morph drawn at worldPoint. (See implementation at Morph). - This implementation also answer true if we cover but don't own the pixel, - meaning that some other morph was drawn later, covering us. - Therefore, senders need to be aware that the answer is meaningful only when it is known that no other morph covers us. - Note: This implementation is only used for morphs with a cheap #coversPixel:. - (See other implementors) - Note: Also see #ownsPixel: and #coversPixel:" - - ^ self visible and: [self coversPixel: worldPoint].! ! -!Morph methodsFor: 'events-processing' stamp: 'jmv 10/28/2021 11:58:38' prior: 50608707! - processMouseOver: aMouseEvent localPosition: localEventPosition - "System level event handling." - self hasMouseFocus ifTrue: [ - "Got this directly through #handleFocusEvent: so check explicitly" - ((self rejectsEvent: aMouseEvent) not and: [self fullIncludesPixel: aMouseEvent eventPosition]) ifFalse: [ - ^self ]]. - aMouseEvent hand noticeMouseOver: self event: aMouseEvent. - "Open question: should any unhandled mouse move events be filtered out? (i.e. should mouseHover:localPosition: be called when a mouse button is pressed but the morph doesn't have mouse button handlers? Essentially, what are the limits of what is considered 'hovering'?" - (self handlesMouseHover and: [aMouseEvent wasHandled not]) ifTrue: [ - self - mouseHover: aMouseEvent - localPosition: localEventPosition ].! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 10/28/2021 12:17:08' prior: 50608768! - coversAnyPixelCloserThan: maxDistance to: worldPoint - "Answer true if our closest point to worldPoint is less than aNumber pixels away. - In target surface (i.e. Display) coordinates. - See #bitMask. - Remember to do - self removeProperty: #bitMask. - when appropriate!! (i.e. when we change in such a way to make the bitMask invalid). - - Note: Requires VectorGraphics. Meant to be used only when needed. - Note: Prefer #isCloserThan:toPixel:, that doesn't use #bitMask, and doesn't require maintenance." - - | center maxDistanceSquared | - self visible ifFalse: [ - ^false ]. - privateDisplayBounds ifNil: [ - ^false ]. - center _ privateDisplayBounds center. - "Quick checks: If not even within aNumber distance to display bounds, fail" - (center y - worldPoint y) abs < (privateDisplayBounds height // 2 + maxDistance) ifFalse: [ - ^false ]. - (center x - worldPoint x) abs < (privateDisplayBounds width // 2 + maxDistance) ifFalse: [ - ^false ]. - "Precise check with bitMask. If unavailable, just answer false. See #coversPixel:" - (self coversPixel: worldPoint) - ifNil: [ ^false ] - ifNotNil: [ :coversIt | - coversIt ifTrue: [ ^true ]]. - maxDistanceSquared _ maxDistance squared. - maxDistance negated to: maxDistance do: [ :dy | - maxDistance negated to: maxDistance do: [ :dx | - dx squared + dy squared <= maxDistanceSquared ifTrue: [ - (self coversPixel: worldPoint + (dx@dy)) ifTrue: [ ^true ]]]]. - ^false.! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 10/28/2021 12:15:19' prior: 50619875! - coversPixel: worldPoint - "Answer true if pixel worldPoint is covered by us, even if we are not visible a it because of some - other morph above us also covers it. - - WARNING: Might answer nil when we simply don't know. It is generally advisable to call this method only for - morphs where the answer is not nil: - - WidgetMorphs. No sepecial care needed. (Senders in the base Cuis image are of this kind). - - KernelMorphs. No special care needed. (Senders in the base Cuis image are of this kind). - - Morphs drawn by VectorCanvas (i.e. they #requiresVectorCanvas). See notes below. - - Note: If your morph #requiresVectorCanvas, and depends on this general implementation, remember to - `removeProperty: #bitMask` whenever it becomes invalid due to changes in your morphs. You may consider - using #ownsPixel: if appropriate, that doesn't require any maintenance and is cheaper (in cpu and memory). - See #bitMask. - - See #ownsPixel: - See #includesPixel:" - - self visible ifTrue: [ - "Expensive way for morphs with arbitrary shape in VectorGraphics. - The base Cuis System doesn't use this. - Use this in applications if the expense of maintaining #bitMask is worth it." - self canvas ifNotNil: [ :canvas | - canvas canDoVectorGraphics ifTrue: [ - ^(self bitMask pixelValueAt: worldPoint - self displayFullBounds topLeft) = 1 ]]. - - "This is cheap and OK for unrotated Morphs with a rectangular shape. - In general, the answer is not strictly correct. - WidgetMorph redefines this method with an equally cheap implementation that can also handle - rotated morphs (but assuming they are of rectangular shape)." - self basicDisplayBounds ifNotNil: [ :r | - (r containsPoint: worldPoint) ifFalse: [ ^false ] ]]. - - "If we don't know." - ^ nil.! ! -!Morph methodsFor: 'geometry services' stamp: 'jmv 10/28/2021 12:00:12' prior: 50619992! - ownsPixel: worldPoint - "Answer true if we own the pixel, i.e. we are the last morph drawn at worldPoint. - Requires VectorGraphics, as we need VectorCanvas' morphIdAt: service. - - Valid if running on VectorCanvas. - - In case of running on HybridCanvas, this method is only valid for morphs that - are drawn by VectorCanvas (i.e. they answer true to #requiresVectorCanvas). - - See #coversPixel: - See #includesPixel:" - - self canvas ifNotNil: [ :canvas | - canvas canDoVectorGraphics ifTrue: [ - ^ (canvas morphIdAt: worldPoint) = self morphId ]]. - ^ false.! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 10/28/2021 11:58:42' prior: 50608849! - transferHalo: event from: formerHaloOwner - "Progressively transfer the halo to the next likely recipient" - - formerHaloOwner == self - ifFalse: [ - self addHalo: event. - ^self ]. - - event shiftPressed ifTrue: [ - "Pass it outwards" - owner ifNotNil: [ - owner transferHalo: event from: formerHaloOwner. - ^self ]. - "We're at the top level; just keep it on ourselves" - ^self ]. - - self submorphsDo: [ :m | - (m wantsHalo and: [ m fullIncludesPixel: event eventPosition ]) - ifTrue: [ - m transferHalo: event from: formerHaloOwner. - ^self ]]. - "We're at the bottom most level; just keep halo on ourselves"! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 10/28/2021 12:03:20' prior: 50608871! - doRecolor: event with: aHandle - "The mouse went down in the 'recolor' halo handle. Allow the user to change the color of the innerTarget" - - event hand obtainHalo: self. - (aHandle includesPixel: event eventPosition) - ifFalse: [ "only do it if mouse still in handle on mouse up" - self delete. - target addHalo: event] - ifTrue: [ - target changeColor]! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 10/28/2021 12:03:24' prior: 50608885! - maybeCollapse: event with: aHandle - "Ask hand to collapse my target if mouse comes up in it." - - event hand obtainHalo: self. - (aHandle includesPixel: event eventPosition) - ifTrue: [ - target collapse ]. - self delete.! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 10/28/2021 12:03:27' prior: 50608895! - maybeDismiss: event with: aHandle - "Ask hand to dismiss my target if mouse comes up in it." - - event hand obtainHalo: self. - (aHandle includesPixel: event eventPosition) - ifFalse: [ - self delete. - target addHalo: event] - ifTrue: [ - target resistsRemoval ifTrue: [ - (PopUpMenu - confirm: 'Really throw this away' - trueChoice: 'Yes' - falseChoice: 'Um, no, let me reconsider') ifFalse: [^ self]]. - - self delete. - target dismissViaHalo]! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 10/28/2021 12:03:31' prior: 50608912! -setDismissColor: event with: aHandle - "Called on mouseStillDown in the dismiss handle; set the color appropriately." - - | colorToUse | - event hand obtainHalo: self. - colorToUse _ (aHandle includesPixel: event eventPosition) - ifFalse: [ `Color red muchLighter` ] - ifTrue: [ `Color lightGray` ]. - aHandle color: colorToUse! ! -!MenuItemMorph methodsFor: 'events' stamp: 'jmv 10/28/2021 12:03:36' prior: 50608925! - activateOwnerMenu: evt - "Activate our owner menu; e.g., pass control to it" - owner ifNil: [ ^false ]. "not applicable" - (owner includesPixel: evt eventPosition) - ifFalse: [ ^false ]. - owner activate: evt. - ^true! ! -!MenuItemMorph methodsFor: 'events' stamp: 'jmv 10/28/2021 12:03:40' prior: 50608935! - activateSubmenu: event - "Activate our submenu; e.g., pass control to it" - - subMenu ifNil: [ ^false ]. "not applicable" - subMenu isInWorld ifFalse: [ ^false ]. - (subMenu includesPixel: event eventPosition) ifFalse: [^false]. - subMenu activate: event. - ^true! ! -!PluggableButtonMorph methodsFor: 'events' stamp: 'jmv 10/28/2021 12:02:45' prior: 50608947 overrides: 16874556! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - - isPressed _ false. - mouseIsOver _ false. - (actWhen == #buttonUp and: [ - self includesPixel: aMouseButtonEvent eventPosition ]) - ifTrue: [ self performAction ]. - self redrawNeeded! ! -!MenuMorph methodsFor: 'events' stamp: 'jmv 10/28/2021 12:02:50' prior: 50608959 overrides: 16874541! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - "Handle a mouse down event." - (stayUp or: [ self includesPixel: aMouseButtonEvent eventPosition ]) - ifFalse: [ - self deleteIfPopUp: aMouseButtonEvent. - self activeHand - newKeyboardFocus: prevKbdFocus; - newMouseFocus: prevMouseFocus. - ^ self ]. "click outside" - - "Grab the menu and drag it to some other place - This is reimplemented here because we handle the event, and if the following lines are commented, a menu can't be grabbed with the hand. This is not nice and shouldn't be needed" - self isSticky ifTrue: [ ^self ]. - aMouseButtonEvent hand grabMorph: self.! ! -!MenuMorph methodsFor: 'events' stamp: 'jmv 10/28/2021 12:02:53' prior: 50608983 overrides: 16874556! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - "Handle a mouse up event. - Note: This might be sent from a modal shell." - (self includesPixel: aMouseButtonEvent eventPosition) ifFalse:[ - "Mouse up outside. Release eventual focus and delete if pop up." - aMouseButtonEvent hand ifNotNil: [ :h | h releaseMouseFocus: self ]. - self deleteIfPopUp: aMouseButtonEvent. - self activeHand - newKeyboardFocus: prevKbdFocus; - newMouseFocus: prevMouseFocus. - ^ self]. - stayUp ifFalse: [ - "Still in pop-up transition; keep focus" - aMouseButtonEvent hand newMouseFocus: self ].! ! -!AutoCompleterMorph methodsFor: 'events' stamp: 'jmv 10/28/2021 12:02:56' prior: 50609006 overrides: 16874556! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - - (self includesPixel: aMouseButtonEvent eventPosition) - ifTrue: [ - ((self upButtonPosition extent: ScrollBar scrollbarThickness) containsPoint: localEventPosition) - ifTrue: [ ^self stillActive; goUp ]. - ((self downButtonPosition extent: ScrollBar scrollbarThickness) containsPoint: localEventPosition) - ifTrue: [ ^self stillActive; goDown ]. - self selected: (localEventPosition y // self itemHeight) + self firstVisible. - completer insertSelected ] - ifFalse: [ self delete. completer menuClosed ]! ! -!MorphicEvent methodsFor: 'dispatching' stamp: 'jmv 10/28/2021 11:58:51' prior: 50609028! - dispatchWith: aMorph - "Dispatch me. The event will be passed to the front-most visible submorph that contains the position wrt. to the event." - | handledByInner | - - "Try to get out quickly" - (aMorph fullIncludesPixel: self eventPosition) - ifFalse: [ ^#rejected ]. - - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - (eachChild dispatchEvent: self) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - - "Check for being inside the receiver" - (handledByInner or: [ (aMorph rejectsEvent: self) not and: [aMorph fullIncludesPixel: self eventPosition] ]) - ifTrue: [ ^ self sendEventTo: aMorph ]. - - ^ #rejected! ! -!DropEvent methodsFor: 'dispatching' stamp: 'jmv 10/28/2021 11:58:57' prior: 50609057 overrides: 50620471! - dispatchWith: aMorph - "Drop is done on the innermost target that accepts it." - | dropped | - - "Try to get out quickly" - (aMorph fullIncludesPixel: position) - ifFalse: [ ^#rejected ]. - - "Go looking if any of our submorphs wants it" - aMorph submorphsDo: [ :eachChild | - (eachChild dispatchEvent: self) == #rejected ifFalse: [ - ^self ]]. - - (aMorph allowsMorphDrop and: [ (aMorph rejectsEvent: self) not and: [aMorph fullIncludesPixel: position] ]) - ifTrue: [ - "Do a symmetric check if both morphs like each other" - dropped _ self contents. - ((aMorph wantsDroppedMorph: dropped event: self) "I want her" - and: [dropped wantsToBeDroppedInto: aMorph]) "she wants me" - ifTrue: [ - ^ self sendEventTo: aMorph ]]. - ^#rejected! ! -!DropFilesEvent methodsFor: 'dispatching' stamp: 'jmv 10/28/2021 11:59:02' prior: 50609084 overrides: 50620471! - dispatchWith: aMorph - "Drop is done on the innermost target that accepts it." - - "Try to get out quickly" - (aMorph fullIncludesPixel: position) ifFalse: [ ^#rejected ]. - - "Go looking if any of our submorphs wants it" - aMorph submorphsDo: [ :eachChild | - (eachChild dispatchEvent: self) == #rejected ifFalse: [ ^self ]]. - - (aMorph allowsFilesDrop and: [ (aMorph rejectsEvent: self) not and: [aMorph fullIncludesPixel: position] ]) - ifTrue: [^ self sendEventTo: aMorph ]. - - ^#rejected! ! -!KeyboardEvent methodsFor: 'actions' stamp: 'jmv 10/28/2021 12:03:50' prior: 50609103! - closeCurrentWindowOf: aMorph - - aMorph owningWindow ifNotNil: [ :w | - (w includesPixel: position) - ifTrue: [ w delete ] ].! ! -!MouseButtonEvent methodsFor: 'dispatching' stamp: 'jmv 10/28/2021 11:59:20' prior: 50609111 overrides: 50620471! - dispatchWith: aMorph - "Find the appropriate receiver for the event and let it handle it. Default rules: - * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. - * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. - * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. - * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. - " - | aMorphHandlesIt grabAMorph handledByInner | - "Only for MouseDown" - self isMouseDown ifFalse: [ - ^super dispatchWith: aMorph ]. - - "Try to get out quickly" - (aMorph fullIncludesPixel: position) - ifFalse: [ ^#rejected ]. - - "Install the prospective handler for the receiver" - aMorphHandlesIt _ false. - grabAMorph _ false. - self mouseButton3Pressed - ifTrue: [ - (eventHandler isNil or: [ eventHandler isWorldMorph or: [ - self shiftPressed or: [ aMorph is: #HaloMorph ]]]) - ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]] - ifFalse: [ - (aMorph handlesMouseDown: self) ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]. - "If button 1, and both aMorph and the owner allows grabbing with the hand (to initiate drag & drop), so be it." - self mouseButton1Pressed ifTrue: [ - aMorph owner ifNotNil: [ :o | - (o allowsSubmorphDrag and: [ aMorph isSticky not ]) ifTrue: [ - grabAMorph _ true ]]]]. - - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - (eachChild dispatchEvent: self) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - - (handledByInner or: [ (aMorph rejectsEvent: self) not and: [aMorph fullIncludesPixel: position] ]) ifTrue: [ - "aMorph is in the top-most unlocked, visible morph in the chain." - aMorphHandlesIt - ifTrue: [ ^self sendEventTo: aMorph ] - ifFalse: [ - (grabAMorph and: [ handledByInner not ]) ifTrue: [ - self hand - waitForClicksOrDrag: aMorph event: self - dragSel: (Preferences clickGrabsMorphs ifFalse: [#dragEvent:localPosition:]) - clkSel: (Preferences clickGrabsMorphs ifTrue: [#dragEvent:localPosition:]). - "false ifTrue: [ self hand grabMorph: aMorph ]." - Preferences clickGrabsMorphs ifFalse: [aMorph activateWindow]. - self wasHandled: true. - ^self ]]]. - - handledByInner ifTrue: [ ^self ]. - "Mouse was not on aMorph nor any of its children" - ^ #rejected! ! -!MouseScrollEvent methodsFor: 'dispatching' stamp: 'jmv 10/28/2021 11:59:12' prior: 50609204 overrides: 50620471! - dispatchWith: aMorph - "Find the appropriate receiver for the event and let it handle it. Default rules: - * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. - * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. - * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. - * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. - " - "Try to get out quickly" - | aMorphHandlesIt handledByInner | - "FIXME - this works in all tested cases but one: when the window directly under the mouse doesn't have keyboard focus (i.e. a Transcript window)" - aMorph fullIncludesPixel: position :: ifFalse: [ ^ #rejected ]. - "Install the prospective handler for the receiver" - aMorphHandlesIt _ false. - (aMorph handlesMouseScroll: self) ifTrue: [ - eventHandler _ aMorph. - aMorphHandlesIt _ true ]. - "Now give submorphs a chance to handle the event" - handledByInner _ false. - aMorph submorphsDo: [ :eachChild | - handledByInner ifFalse: [ - (eachChild dispatchEvent: self) == #rejected ifFalse: [ - "Some child did contain the point so aMorph is part of the top-most chain." - handledByInner _ true ]]]. - (handledByInner or: [ - (aMorph rejectsEvent: self) not and: [aMorph fullIncludesPixel: position]]) ifTrue: [ - "aMorph is in the top-most unlocked, visible morph in the chain." - aMorphHandlesIt ifTrue: [ ^ self sendEventTo: aMorph ]]. - handledByInner ifTrue: [ ^ self ]. - "Mouse was not on aMorph nor any of its children" - ^ #rejected.! ! - -WidgetMorph removeSelector: #ownsOrCoversPixel:! - -!methodRemoval: WidgetMorph #ownsOrCoversPixel: stamp: 'Install-4954-includesPixel-not-ownsOrCoversPixel-JuanVuletich-2021Oct28-11h55m-jmv.001.cs.st 11/2/2021 10:28:06'! -ownsOrCoversPixel: worldPoint - "Answer true if we own the pixel, i.e. we are the last morph drawn at worldPoint. - This implementation also answer true if we cover but don't own the pixel, - meaning that some other morph was drawn later, covering us. - Therefore, senders need to be aware that the answer is meaningful only when it is known that no other morph covers us. - Note: This implementation is only used for morphs with a cheap #coversPixel:. - (See other implementors) - Note: Also see #ownsPixel: and #coversPixel:" - - ^ self visible and: [self coversPixel: worldPoint].! - -KernelMorph removeSelector: #ownsOrCoversPixel:! - -!methodRemoval: KernelMorph #ownsOrCoversPixel: stamp: 'Install-4954-includesPixel-not-ownsOrCoversPixel-JuanVuletich-2021Oct28-11h55m-jmv.001.cs.st 11/2/2021 10:28:06'! -ownsOrCoversPixel: worldPoint - "Answer true if we own the pixel, i.e. we are the last morph drawn at worldPoint. - This implementation also answer true if we cover but don't own the pixel, - meaning that some other morph was drawn later, covering us. - Therefore, senders need to be aware that the answer is meaningful only when it is known that no other morph covers us. - Note: This implementation is only used for morphs with a cheap #coversPixel:. - (See other implementors) - Note: Also see #ownsPixel: and #coversPixel:" - - ^ self visible and: [self coversPixel: worldPoint].! - -Morph removeSelector: #ownsOrCoversPixel:! - -!methodRemoval: Morph #ownsOrCoversPixel: stamp: 'Install-4954-includesPixel-not-ownsOrCoversPixel-JuanVuletich-2021Oct28-11h55m-jmv.001.cs.st 11/2/2021 10:28:06'! -ownsOrCoversPixel: worldPoint - "Answer true if we own the pixel, i.e. we are the last morph drawn at worldPoint. - - Some implementations (KernelMorph and WidgetMorph) may also answer true if we cover but don't own the pixel, - meaning that some other morph was drawn later, covering us. - - For other morphs, not KernelMorph or WidgetMorph, (i.e. they run this implementation), if VectorGraphics is not active, - answer true for any point that lies within our bounds. If this is the case, consider using VectorGraphics: In addition to - many other advantages, this method will always answer a strictly correct answer. - - Therefore, senders need to be aware that the answer is meaningful only when it is known that no other morph - covers us. A common case is to find the topmost morph at some position. In that case, iterating front to back ensures - that if any other morph covers us, it is found first. - - Note: This implementation is only used for morphs drawn by VectorCanvas, either because the main canvas is a - VectorCanvas, or because it is a HybridCanvas and we answer true to #requiresVectorCanvas. - (See other implementors) - - Note: Also see #ownsPixel: and #coversPixel:" - - "Check if #ownsPixel:, if possible." - self canvas ifNotNil: [ :canvas | - canvas canDoVectorGraphics ifTrue: [ - ^ (canvas morphIdAt: worldPoint) = self morphId ]]. - - "This is cheap and OK for unrotated Morphs with a rectangular shape. - In general, the answer is not strictly correct. - WidgetMorph redefines this method with an equally cheap implementation that can also handle - rotated morphs (but assuming they are of rectangular shape)." - self visible ifTrue: [ - self basicDisplayBounds ifNotNil: [ :r | - ^r containsPoint: worldPoint ]]. - - ^ false.! - -Morph removeSelector: #fullOwnsOrCoversPixel:! - -!methodRemoval: Morph #fullOwnsOrCoversPixel: stamp: 'Install-4954-includesPixel-not-ownsOrCoversPixel-JuanVuletich-2021Oct28-11h55m-jmv.001.cs.st 11/2/2021 10:28:06'! -fullOwnsOrCoversPixel: worldPoint - "Answer true if worldPoint is in some submorph, even if not inside our shape. - See comment at #ownsOrCoversPixel: for important notes on behavior." - - (self ownsOrCoversPixel: worldPoint) ifTrue: [ ^ true ]. - self submorphsMightProtrude ifTrue: [ - self submorphsDo: [ :m | - (m fullOwnsOrCoversPixel: worldPoint) ifTrue: [ ^ true ]]]. - ^ false.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4954-includesPixel-not-ownsOrCoversPixel-JuanVuletich-2021Oct28-11h55m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4954] on 29 October 2021 at 11:13:41 am'! -!Number methodsFor: 'truncation and round off' stamp: 'jmv 10/29/2021 10:57:03'! - roundedHAFZ - "Answer the integer nearest the receiver. - Use the rounding rule commonly taught in school." - "See https://en.wikipedia.org/wiki/Rounding#Round_half_away_from_zero - See #rounded" - - ^(self + (self sign / 2)) truncated.! ! -!Float methodsFor: 'truncation and round off' stamp: 'jmv 10/29/2021 11:03:21' overrides: 50620844! - roundedHAFZ - "Answer the integer nearest the receiver." - "See https://en.wikipedia.org/wiki/Rounding#Round_half_away_from_zero - See #rounded" - - self fractionPart abs < 0.5 - ifTrue: [^self truncated] - ifFalse: [^self truncated + self sign].! ! -!Integer methodsFor: 'truncation and round off' stamp: 'jmv 10/29/2021 10:55:37' overrides: 50620844! - roundedHAFZ - "Refer to the comment in Number >> roundedHAFZ." - - ^self! ! -!Point methodsFor: 'truncation and round off' stamp: 'jmv 10/29/2021 10:52:04'! - roundedHAFZ - "Answer a Point that is the receiver's x and y rounded. Answer the receiver if its coordinates are already integral." - - (x isInteger and: [y isInteger]) ifTrue: [^ self]. - ^ x roundedHAFZ @ y roundedHAFZ! ! -!Rectangle methodsFor: 'truncation and round off' stamp: 'jmv 10/29/2021 10:52:11'! - roundedHAFZ - "Answer a Rectangle whose origin and corner are rounded." - - ^Rectangle origin: origin roundedHAFZ corner: self corner roundedHAFZ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4955-rounded-halfAwayFromZero-JuanVuletich-2021Oct29-11h05m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4955] on 29 October 2021 at 11:36:43 am'! -!Number methodsFor: 'truncation and round off' stamp: 'jmv 10/29/2021 09:53:30' prior: 50418010! - rounded - "Answer the integer nearest the receiver." - "See https://en.wikipedia.org/wiki/Rounding#Round_half_to_even" - - | truncated fractionPartAbs | - truncated _ self truncated. - fractionPartAbs _ (self-truncated) abs. - fractionPartAbs = `1/2` - ifTrue: [ truncated even ifTrue: [^truncated] ifFalse: [^truncated + self sign]]. - fractionPartAbs < `1/2` - ifTrue: [^ truncated] - ifFalse: [^ truncated + self sign]! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 10/29/2021 10:52:28' prior: 50614313! - drawString: s at: pt font: font color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - - | p1 | - p1 _ pt roundedHAFZ. - p1 _ p1 + (0@(0 - (font ascent + font lineGap-1))). - p1 _ p1 roundedHAFZ. - displayEngine colorMap: nil. - ^font - onBitBltCanvasEngine: displayEngine - displayString: s - from: 1 - to: s size - at: p1 - color: aColor! ! -!BitBlt methodsFor: 'line drawing' stamp: 'jmv 10/29/2021 10:52:36' prior: 16785828! - drawFrom: startPoint to: stopPoint withFirstPoint: drawFirstPoint - "Draw a line whose end points are startPoint and stopPoint. - The line is formed by repeatedly calling copyBits at every - point along the line. If drawFirstPoint is false, then omit - the first point so as not to overstrike at line junctions." - | offset point1 point2 forwards | - "Always draw down, or at least left-to-right" - forwards _ (startPoint y = stopPoint y and: [startPoint x < stopPoint x]) - or: [startPoint y < stopPoint y]. - forwards - ifTrue: [point1 _ startPoint. point2 _ stopPoint] - ifFalse: [point1 _ stopPoint. point2 _ startPoint]. - sourceForm - ifNil: [ - destX := point1 x. - destY := point1 y] - ifNotNil: [ - width := sourceForm width. - height := sourceForm height. - offset := sourceForm offset. - destX := (point1 x + offset x) roundedHAFZ. - destY := (point1 y + offset y) roundedHAFZ]. - - "Note that if not forwards, then the first point is the last and vice versa. - We agree to always paint stopPoint, and to optionally paint startPoint." - (drawFirstPoint or: [forwards == false "ie this is stopPoint"]) - ifTrue: [self copyBits]. - self drawLoopX: (point2 x - point1 x) roundedHAFZ - Y: (point2 y - point1 y) roundedHAFZ. - (drawFirstPoint or: [forwards "ie this is stopPoint"]) - ifTrue: [self copyBits]. -! ! -!WarpBlt class methodsFor: 'form rotation' stamp: 'jmv 10/29/2021 10:52:41' prior: 16943446! - rotate: srcForm degrees: angleInDegrees center: aPoint scaleBy: scalePoint smoothing: cellSize - "Rotate the given Form the given number of degrees about the given center and scale its width and height by x and y of the given scale point. Smooth using the given cell size, an integer between 1 and 3, where 1 means no smoothing. Return a pair where the first element is the rotated Form and the second is the position offset required to align the center of the rotated Form with that of the original. Note that the dimensions of the resulting Form generally differ from those of the original." - - | srcRect center radians dstOrigin dstCorner p dstRect inverseScale quad dstForm newCenter warpSrc | - srcRect _ srcForm boundingBox. - center _ srcRect center. - radians _ angleInDegrees degreesToRadians. - dstOrigin _ dstCorner _ center. - srcRect corners do: [:corner | - "find the limits of a rectangle that just encloses the rotated - original; in general, this rectangle will be larger than the - original (e.g., consider a square rotated by 45 degrees)" - p _ ((corner - center) scaledBy: scalePoint) + center. - p _ (p inverseRotatedBy: radians about: center) roundedHAFZ. - dstOrigin _ dstOrigin min: p. - dstCorner _ dstCorner max: p]. - - "rotate the enclosing rectangle back to get the source quadrilateral" - dstRect _ dstOrigin corner: dstCorner. - inverseScale _ (1.0 / scalePoint x)@(1.0 / scalePoint y). - quad _ dstRect innerCorners collect: [:corner | - p _ corner inverseRotatedBy: radians negated about: center. - ((p - center) scaledBy: inverseScale) + center]. - - "make a Form to hold the result and do the rotation" - warpSrc _ srcForm. - (srcForm is: #ColorForm) - ifTrue: [ - cellSize > 1 | true "ar 12/27/2001: Always enable - else sketches won't work" - ifTrue: [ - warpSrc _ Form extent: srcForm extent depth: 16. - srcForm displayOn: warpSrc. - dstForm _ Form extent: dstRect extent depth: 16] "use 16-bit depth to allow smoothing" - ifFalse: [ - dstForm _ srcForm class extent: dstRect extent depth: srcForm depth]] - ifFalse: [ - dstForm _ srcForm class extent: dstRect extent depth: srcForm depth]. - - (WarpBlt toForm: dstForm) - sourceForm: warpSrc; - colorMap: (warpSrc colormapIfNeededFor: dstForm); - cellSize: cellSize; "installs a new colormap if cellSize > 1" - combinationRule: Form paint; - copyQuad: quad toRect: dstForm boundingBox. - - (dstForm is: #ColorForm) ifTrue: [ dstForm colors: srcForm colors copy ]. - newCenter _ (center inverseRotatedBy: radians about: aPoint) truncated. - ^ Array with: dstForm with: dstRect origin + (newCenter - center) -! ! -!MorphicScanner methodsFor: 'scanning' stamp: 'jmv 10/29/2021 10:53:23' prior: 50597067 overrides: 50597017! - placeEmbeddedObject: anchoredFormOrMorph - - (super placeEmbeddedObject: anchoredFormOrMorph) ifFalse: [^ false]. - (anchoredFormOrMorph is: #Morph) - ifTrue: [ - anchoredFormOrMorph morphPosition: - (destX@ (lineY+line baseline)) + (anchoredFormOrMorph morphPosition-anchoredFormOrMorph fullBoundsInOwner corner) roundedHAFZ. - anchoredFormOrMorph show. - canvas fullDraw: anchoredFormOrMorph ] - ifFalse: [ - destY _ lineY. - canvas - image: anchoredFormOrMorph - at: destX - anchoredFormOrMorph width @ (destY + line baseline - anchoredFormOrMorph height) ]. - ^ true! ! -!IndentingListItemMorph methodsFor: 'drawing' stamp: 'jmv 10/29/2021 10:53:27' prior: 50592700 overrides: 50594031! - drawOn: aCanvas - - | x colorToUse centeringOffset | - isHighlighted ifTrue: [ - aCanvas - fillRectangle: self morphLocalBounds - color: ((Theme current - listHighlightFocused: owner owner hasKeyboardFocus) alpha: 0.3) ]. - - isSelected ifTrue: [ - aCanvas - fillRectangle: self morphLocalBounds - color: (Theme current - listHighlightFocused: owner owner hasKeyboardFocus) ]. - - x _ 12 * indentLevel. - - complexContents hasContents ifTrue: [ - isExpanded - ifTrue: [ aCanvas drawExpandedAt: x@(extent y//2)] - ifFalse: [ aCanvas drawNotExpandedAt: x@(extent y//2) ]]. - x _ x + 18. - - icon isNil ifFalse: [ - centeringOffset _ ((extent y - icon height) / 2.0) roundedHAFZ. - aCanvas - image: icon - at: (x @ centeringOffset). - x _ x + 20 ]. - - colorToUse _ complexContents preferredColor ifNil: [ color ]. - aCanvas - drawString: contents asString - at: x@0 - font: self fontToUse - color: colorToUse! ! -!BitBltCanvas methodsFor: 'drawing' stamp: 'jmv 10/29/2021 10:54:26' prior: 50595626 overrides: 50463404! - line: pt1 to: pt2 width: wp color: c - - | p1 p2 w | - (wp > 0 and: [ c isTransparent not ]) ifTrue: [ - p1 _ (currentTransformation transform: pt1) roundedHAFZ. - p2 _ (currentTransformation transform: pt2) roundedHAFZ. - w _ (currentTransformation externalizeScalar: wp) roundedHAFZ. - self setPaintColor: c. - engine - width: w; - height: w; - drawFrom: p1 to: p2 ]! ! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 10/29/2021 10:54:12' prior: 50595651! - image: aForm at: aPoint sourceRect: sourceRect - "Draw a translucent image using the best available way of representing translucency. - Note: This will be fixed in the future." - - | r p | - p _ (currentTransformation transform: aPoint) roundedHAFZ. - r _ (form depth < 32 or: [ aForm mightBeTranslucent not ]) - ifTrue: [ - "Rule Form paint treats pixels with a value of zero as transparent" - Form paint ] - ifFalse: [ Form blend ]. - engine colorMap: (aForm colormapIfNeededFor: form); fillColor: nil. - engine image: aForm at: p sourceRect: sourceRect rule: r. - (form depth = 32 and: [ aForm depth < 32 ]) ifTrue: [ - "If we blit to 32bpp from one of smaller depth, - it will have zero in the alpha channel (until BitBlt is fixed!!) - This is the same workaround as in #asFormOfDepth:" - engine sourceForm: nil. - engine combinationRule: 40. "fixAlpha:with:" - engine copyBits ]! ! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 10/29/2021 10:54:30' prior: 50595682! - stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor - "Flood this canvas with aColor wherever stencilForm has non-zero pixels" - | p | - p _ (currentTransformation transform: aPoint) roundedHAFZ. - self setPaintColor: aColor. - engine colorMap: stencilForm maskingMap. - engine stencil: stencilForm - at: p - sourceRect: sourceRect! ! -!BitBltCanvas methodsFor: 'drawing-ovals' stamp: 'jmv 10/29/2021 10:53:55' prior: 50618520 overrides: 50569774! - ellipseCenter: center radius: radiusPointOrNumber borderWidth: mbw borderColor: mbc fillColor: morphFillColor - - | displayRectangle doBorder doFill | - doBorder _ mbw > 0 and: [ mbc isTransparent not]. - doFill _ morphFillColor isTransparent not. - doBorder | doFill ifTrue: [ - displayRectangle _ (currentTransformation externalBoundingRectOf: (Rectangle center: center extent: radiusPointOrNumber asPoint * 2)) roundedHAFZ. - "draw the border of the oval" - doBorder ifTrue: [ - self setPaintColor: mbc. - engine frameOval: displayRectangle borderWidth: mbw roundedHAFZ]. - "fill the inside" - doFill ifTrue: [ - self setPaintColor: morphFillColor. - engine fillOval: (displayRectangle insetBy: mbw roundedHAFZ) ]]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 10/29/2021 10:54:03' prior: 50618546 overrides: 50463466! - frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor - - | rect bw | - r area = 0 ifTrue: [ ^self ]. - rect _ (currentTransformation externalBoundingRectOf: r) roundedHAFZ. - bw _ (currentTransformation externalizeScalar: borderWidth) roundedHAFZ. - - "draw the border of the rectangle" - borderColor isTransparent ifFalse: [ - self setPaintColor: borderColor. - engine frameRect: rect borderWidth: bw ]. - - "fill the inside" - fillColor isTransparent ifFalse: [ - self setPaintColor: fillColor. - engine fillRect: (rect insetBy: bw) ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 10/29/2021 10:54:06' prior: 50618568 overrides: 50463473! - frameRectangle: r borderWidth: borderWidth color: borderColor - " - (BitBltCanvas onForm: Display) - frameRectangle: (10@10 extent: 300@200) - borderWidth: 20 - color: Color red. - Display forceToScreen - " - | rect bw | - (borderWidth > 0 and: [ borderColor isTransparent not ]) ifTrue: [ - rect _ (currentTransformation externalBoundingRectOf: r) roundedHAFZ. - bw _ (currentTransformation externalizeScalar: borderWidth) roundedHAFZ. - self setPaintColor: borderColor. - engine - frameRect: rect - borderWidth: bw ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 10/29/2021 10:54:09' prior: 50618587! - frameRectangle: aRectangle topLeftColor: tlColor bottomRightColor: brColor borderWidth: borderWidth - " - (BitBltCanvas onForm: Display) - frameRectangle: (10@10 extent: 300@200) - color: Color green - borderWidth: 10 - borderStyleSymbol: #raised. - Display forceToScreen. - " - - | displayRectangle bw | - bw _ (currentTransformation externalizeScalar: borderWidth) roundedHAFZ. - displayRectangle _ (currentTransformation externalBoundingRectOf: aRectangle) roundedHAFZ. - self - frameRectangle: displayRectangle - borderWidth: bw - topLeftColor: tlColor - bottomRightColor: brColor.! ! -!BitBltCanvas methodsFor: 'drawing-roundedRectangles' stamp: 'jmv 10/29/2021 10:54:28' prior: 50617244 overrides: 50463492! - roundRect: aRectangle color: aColor radius: aNumber - " - (BitBltCanvas onForm: Display) roundRect: (10@10 extent: 200@100) color: Color red radius: 10.5. Display forceToScreen. - " - | r | - r _ (currentTransformation externalizeScalar: aNumber) roundedHAFZ. - - "top stripe" - self - image: (self class topLeftCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle topLeft. - self - image: (self class topRightCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle topRight - (r@0). - self fillRectangle: ((aRectangle withHeight: r) insetBy: r@0) color: aColor. - - "center stripe" - self fillRectangle: (aRectangle insetBy: (0 @ r corner: 0 @ r)) color: aColor. - - "bottom stripe" - self - image: (self class bottomLeftCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle bottomLeft - (0@r). - self - image: (self class bottomRightCorner: r height: r gradientTop: 1 gradientBottom: 1) - multipliedBy: aColor - at: aRectangle bottomRight - (r@r) . - self fillRectangle: ((aRectangle bottomLeft + (r@r negated)) extent: (aRectangle width - r - r@r)) color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 10/29/2021 10:53:34' prior: 50595863 overrides: 50566026! - drawString: aString from: firstIndex to: lastIndex atBaseline: aPoint font: font color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - - | p1 | - "Don't waste any time if NOP" - lastIndex = 0 ifTrue: [ - ^nil ]. - - p1 _ currentTransformation transform: aPoint roundedHAFZ. - p1 _ p1 + (0@(0 - (font ascent + font lineGap-1))). - p1 _ p1 roundedHAFZ. - engine colorMap: nil. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 10/29/2021 10:53:40' prior: 50595883 overrides: 50566713! - drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint font: font color: aColor - "Answer position to place next glyph - Answer nil if nothing was done" - | p1 | - p1 _ (currentTransformation transform: aPoint roundedHAFZ) roundedHAFZ. - engine colorMap: nil. - - aColor = `Color black` ifFalse: [ | topColor | - topColor _ aColor alphaMixed: 0.25 with: `Color black`. - font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: topColor ]. - aColor = `Color white` ifFalse: [ | bottomColor | - bottomColor _ aColor alphaMixed: 0.22 with: `Color white`. - font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + `0@2` - color: bottomColor ]. - ^font - onBitBltCanvasEngine: engine - displayString: aString - from: firstIndex - to: lastIndex - at: p1 + `0@1` - color: aColor.! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 10/29/2021 10:53:58' prior: 50618608! - fillRectangle: aRectangle tilingWith: aForm sourceRect: patternBox rule: aCombinationRule - - | displayRectangle additionalOffset clippedEngine targetTopLeft clipOffset ex - targetBox savedMap top left | - - ex _ patternBox extent. - ex x = 0 ifTrue: [ ^self ]. - ex y = 0 ifTrue: [ ^self ]. - displayRectangle _ (currentTransformation externalBoundingRectOf: aRectangle) roundedHAFZ. - - "this is a bit of a kludge to get the form to be aligned where I *think* it should be. - something better is needed, but not now" - - additionalOffset _ `0@0`. - clippedEngine _ engine clippedBy: displayRectangle. - targetTopLeft _ clippedEngine clipRect topLeft truncateTo: ex. - clipOffset _ displayRectangle topLeft - targetTopLeft. - additionalOffset _ (clipOffset \\ ex) - ex. - - "do it iteratively" - targetBox _ clippedEngine clipRect. - savedMap _ clippedEngine colorMap. - clippedEngine sourceForm: aForm; - fillColor: nil; - combinationRule: aCombinationRule; - sourceRect: patternBox; - colorMap: (aForm colormapIfNeededFor: clippedEngine destForm). - top _ (targetBox top truncateTo: patternBox height) + additionalOffset y. - left _ (targetBox left truncateTo: patternBox width) + additionalOffset x. - - left to: (targetBox right - 1) by: patternBox width do: [:x | - top to: (targetBox bottom - 1) by: patternBox height do: [:y | - clippedEngine destOrigin: x@y; copyBits]]. - clippedEngine colorMap: savedMap! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4956-Use-roundedHalfAwayFromZero-forPixelCoordinates-JuanVuletich-2021Oct29-11h34m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4956] on 29 October 2021 at 12:23:47 pm'! -!Morph methodsFor: 'drawing' stamp: 'jmv 10/29/2021 12:22:53' prior: 50619116! - imageForm: extentOrNil depth: depth - - | answerExtent answer auxCanvas | - self requiresVectorCanvas ifTrue: [ - ^ self imageFormVG: extentOrNil depth: depth ]. - - answerExtent _ self findFullBoundsInOwner extent. - extentOrNil ifNotNil: [ answerExtent _ answerExtent min: extentOrNil * 4 ]. - auxCanvas _ MorphicCanvas depth: depth over: (self morphPosition floor extent: answerExtent ceiling). - auxCanvas fullDraw: self. - answer _ auxCanvas form divideByAlpha. - extentOrNil ifNotNil: [ answer _ answer magnifyTo: extentOrNil ]. - ^answer! ! - -WidgetMorph removeSelector: #imageForm:depth:! - -!methodRemoval: WidgetMorph #imageForm:depth: stamp: 'Install-4957-imageFormdepth-simplify-JuanVuletich-2021Oct29-12h22m-jmv.001.cs.st 11/2/2021 10:28:06'! -imageForm: extentOrNil depth: depth - - | answerExtent answer auxCanvas | - self requiresVectorCanvas ifFalse: [ - answerExtent _ extent. - extentOrNil ifNotNil: [ answerExtent _ answerExtent min: extentOrNil * 4 ]. - auxCanvas _ MorphicCanvas depth: depth over: (self morphPosition floor extent: answerExtent ceiling). - auxCanvas fullDraw: self. - answer _ auxCanvas form divideByAlpha. - extentOrNil ifNotNil: [ answer _ answer magnifyTo: extentOrNil ]. - ^answer ]. - ^super imageForm: extentOrNil depth: depth.! - -KernelMorph removeSelector: #imageForm:depth:! - -!methodRemoval: KernelMorph #imageForm:depth: stamp: 'Install-4957-imageFormdepth-simplify-JuanVuletich-2021Oct29-12h22m-jmv.001.cs.st 11/2/2021 10:28:06'! -imageForm: extentOrNil depth: depth - - | answerExtent answer auxCanvas | - self requiresVectorCanvas ifFalse: [ - answerExtent _ extent. - extentOrNil ifNotNil: [ answerExtent _ answerExtent min: extentOrNil * 4 ]. - auxCanvas _ MorphicCanvas depth: depth over: (self morphPosition floor extent: answerExtent ceiling). - auxCanvas fullDraw: self. - answer _ auxCanvas form divideByAlpha. - extentOrNil ifNotNil: [ answer _ answer magnifyTo: extentOrNil ]. - ^answer ]. - ^super imageForm: extentOrNil depth: depth.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4957-imageFormdepth-simplify-JuanVuletich-2021Oct29-12h22m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4957] on 29 October 2021 at 5:45:19 pm'! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/29/2021 15:05:41'! - morphExtent - "In our own coordinates!! - nil if unknown." - - ^ nil! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 10/29/2021 16:54:11' overrides: 50619539! - fullBoundsInOwner - "Find and answer full bounds in whatever owner. - Note: Answers an integer rectangle" - - "Rethoric question. If it is ever true, call super." - "(self submorphsMightProtrude and: [self clipsSubmorphsReally not]) ifFalse: [" - ^ (self externalizeBoundingRectOf: self morphLocalBounds) encompassingIntegerRectangle! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 10/29/2021 16:54:07' overrides: 50619539! - fullBoundsInOwner - "Find and answer full bounds in whatever owner. - Note: Answers an integer rectangle" - - "Rethoric question. If it is ever true, call super." - "(self submorphsMightProtrude and: [self clipsSubmorphsReally not]) ifFalse: [" - ^ (self externalizeBoundingRectOf: self morphLocalBounds) encompassingIntegerRectangle! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 10/29/2021 15:59:23' prior: 50621412! - imageForm: extentOrNil depth: depth - - | answerExtent answer auxCanvas bounds | - self requiresVectorCanvas ifTrue: [ - ^ self imageFormVG: extentOrNil depth: depth ]. - - bounds _ self fullBoundsInOwner. - answerExtent _ bounds extent. - extentOrNil ifNotNil: [ answerExtent _ answerExtent min: extentOrNil * 4 ]. - auxCanvas _ MorphicCanvas depth: depth over: (bounds origin extent: answerExtent ceiling). - auxCanvas fullDraw: self. - answer _ auxCanvas form divideByAlpha. - extentOrNil ifNotNil: [ answer _ answer magnifyTo: extentOrNil ]. - ^answer! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/29/2021 15:49:22' prior: 50601474! - findFullBoundsInOwner - "Find and answer full bounds in whatever owner. - These might not equal #displayFullBounds at all!! - Subclasses that (re)define #requiresVectorCanvas and #morphExtent should redefine this methods. - See inheritance. - Note: Answers an integer rectangle" - - | prevNotVisibleFlag w c answer prevOwner | - (owner notNil and: [owner isWorldMorph]) ifTrue: [ - w _ owner ] - ifFalse: [ - w _ UISupervisor ui ]. - c _ w boundsFinderCanvas. - "Hack owner so #displayBoundsSetFrom: will update privateDisplayBounds" - prevOwner _ owner. - owner _ w. - prevNotVisibleFlag _ self privateFlagAt: 3. - self privateFlagAt: 3 put: false. - c fullUpdateProtrudingBounds: self. - answer _ self displayFullBounds. - "Reset owner and privateDisplayBounds (if needed) so no one finds out what we've just done!!" - prevOwner == owner ifFalse: [ - owner _ prevOwner. - self world = w ifTrue: [ - self privateFlagAt: 3 put: false. - self allOwnersReverseDo: [ :m | c into: m ]. - c fullUpdateProtrudingBounds: self. - self allOwnersDo: [ :m | c outOfMorph ]]]. - self privateFlagAt: 3 put: prevNotVisibleFlag. - ^answer! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/29/2021 15:34:45' prior: 50619539! - fullBoundsInOwner - "Answer fullBoundsInOwner. Cache the found bounds. - No special care needed for property #fullBoundsInOwner. Cache is invalidated when appropriate. - Note: Answers an integer rectangle" - - (self valueOfProperty: #fullBoundsInOwner) ifNotNil: [ :fullBoundsInOwner | - ^fullBoundsInOwner ]. - - ^self setProperty: #fullBoundsInOwner toValue: self findFullBoundsInOwner.! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/29/2021 17:39:50' prior: 50619551! - morphExtentInOwner - - self morphExtent ifNotNil: [ :e | - ^ self externalizeDistance: e ]. - ^self fullBoundsInOwner extent! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 10/29/2021 17:40:09' prior: 50619557! - topLeftInOwner - - ^self fullBoundsInOwner origin! ! -!Morph methodsFor: 'geometry testing' stamp: 'jmv 10/29/2021 15:23:44' prior: 50594749! - requiresVectorCanvas - "True if we use VectorCanvas protocol, or we are rotated or zoomed. - If False, we can be drawn by BitBltCanvas, and needs to implement: - #morphExtent and #topLeftInOwner" - - ^ true! ! -!MovableMorph methodsFor: 'geometry testing' stamp: 'jmv 10/29/2021 16:34:26' prior: 50594648 overrides: 50594634! - isOrAnyOwnerIsRotated - "True if we or any owner is rotated. - A zoomed widget will answer false, but a rotated one will answer true (even if only - some owner is rotated)." - - ^ location doesNotRotate not or: [ owner notNil and: [ owner isOrAnyOwnerIsRotated ]].! ! -!KernelMorph methodsFor: 'geometry' stamp: 'jmv 10/29/2021 15:05:53' prior: 50541824 overrides: 50621484! - morphExtent - "In our own coordinates!! - nil if unknown." - - ^ extent! ! -!HandMorph methodsFor: 'grabbing/dropping' stamp: 'jmv 10/29/2021 15:59:42' prior: 50616420! - grabMorph: aMorph moveUnderHand: moveUnderHand - "Grab the given morph (i.e., add it to this hand and remove it from its current owner). - If moveUnderHand is requested or it seems neccesary anyway, move the grabbed morph under the hand." - - | grabbed positionInHandCoordinates tx bounds | - self releaseMouseFocus. "Break focus" - grabbed _ aMorph. - aMorph owner ifNotNil: [ :o | grabbed _ o aboutToGrab: aMorph ]. - grabbed ifNil: [ ^ self ]. - grabbed _ grabbed aboutToBeGrabbedBy: self. - grabbed ifNil: [ ^ self ]. - self hideHardwareCursor. - self redrawNeeded. - - moveUnderHand ifTrue: [ - bounds _ nil. - grabbed isInWorld ifTrue: [ - grabbed displayBounds ifNotNil: [ :r | - bounds _ r translatedBy: grabbed morphPositionInWorld negated ]]. - bounds ifNil: [ bounds _ grabbed fullBoundsInOwner ]. - positionInHandCoordinates _ (bounds center + bounds bottomRight //2) negated. - self grabMorph: grabbed delta: positionInHandCoordinates. - ^self ]. - - positionInHandCoordinates _ (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) - morphPositionInWorld - self morphPositionInWorld. - - tx _ GeometryTransformation identity. - (grabbed isInWorld ifTrue: [grabbed] ifFalse: [aMorph]) withAllOwnersDo: [ :o | - tx _ o location composedWith: tx ]. - self withAllOwnersReverseDo: [ :o | - tx _ o location inverseTransformation composedWith: tx ]. - self grabMorph: grabbed delta: positionInHandCoordinates. - - grabbed location: tx.! ! -!WidgetMorph methodsFor: 'geometry' stamp: 'jmv 10/29/2021 15:05:28' prior: 50545934 overrides: 50621484! - morphExtent - "In our own coordinates!! - nil if unknown." - - ^ extent! ! -!HierarchicalListMorph methodsFor: 'selection' stamp: 'jmv 10/29/2021 17:38:15' prior: 50618723 overrides: 16889986! - scrollSelectionIntoView - - | r | - selectedMorph ifNotNil: [ - r _ scroller externalizeBoundingRectOf: selectedMorph fullBoundsInOwner. - self scrollToShow: r ]! ! - -WidgetMorph removeSelector: #morphExtentInOwner! - -!methodRemoval: WidgetMorph #morphExtentInOwner stamp: 'Install-4958-BoundsFindingRefactor-JuanVuletich-2021Oct29-17h44m-jmv.001.cs.st 11/2/2021 10:28:06'! -morphExtentInOwner - - ^self externalizeDistance: extent! - -WidgetMorph removeSelector: #findFullBoundsInOwner! - -!methodRemoval: WidgetMorph #findFullBoundsInOwner stamp: 'Install-4958-BoundsFindingRefactor-JuanVuletich-2021Oct29-17h44m-jmv.001.cs.st 11/2/2021 10:28:06'! -findFullBoundsInOwner - "Find and answer full bounds in whatever owner. - These might not equal #displayFullBounds at all!! - Note: Answers an integer rectangle" - - self requiresVectorCanvas ifTrue: [ - ^super findFullBoundsInOwner ]. - - "#morphExtent exists, and it is also valid in owner, because #requiresVectorCanvas is false." - ^(self morphPosition extent: self morphExtent) encompassingIntegerRectangle.! - -KernelMorph removeSelector: #morphExtentInOwner! - -!methodRemoval: KernelMorph #morphExtentInOwner stamp: 'Install-4958-BoundsFindingRefactor-JuanVuletich-2021Oct29-17h44m-jmv.001.cs.st 11/2/2021 10:28:06'! -morphExtentInOwner - - ^self externalizeDistance: extent! - -KernelMorph removeSelector: #findFullBoundsInOwner! - -!methodRemoval: KernelMorph #findFullBoundsInOwner stamp: 'Install-4958-BoundsFindingRefactor-JuanVuletich-2021Oct29-17h44m-jmv.001.cs.st 11/2/2021 10:28:06'! -findFullBoundsInOwner - "Find and answer full bounds in whatever owner. - These might not equal #displayFullBounds at all!! - Note: Answers an integer rectangle" - - self requiresVectorCanvas ifTrue: [ - ^super findFullBoundsInOwner ]. - - "#morphExtent exists, and it is also valid in owner, because #requiresVectorCanvas is false." - ^(self morphPosition extent: self morphExtent) encompassingIntegerRectangle.! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4958-BoundsFindingRefactor-JuanVuletich-2021Oct29-17h44m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4958] on 31 October 2021 at 7:13:13 pm'! -!InnerTextMorph commentStamp: '' prior: 16855377! - InnerTextMorphs support display of text with emphasis. They also support reasonable text-editing capabilities, as well as embedded hot links, and the ability to embed submorphs in the text. They are 'bare' in the sense that they can not clip contents to some window, or scroll it by themselves. - -Text display is clipped to the innerBounds of the rectangle, and text composition is normally performed within a rectangle which is innerBounds inset by the margins parameter. - -Comment about Shout specifics: ------------------------------------------ - -In order to colour the text, I use an instance of SHTextStylerST80, which I store in my 'styler' instance variable. - -When my setText: method is called, I use my styler to ... - a) optionally set all assignments to ansi or leftArrow. - b) Colour my text (immediately, if the text is less than 4096 chars in length, or in a backgroundProcess otherwise) - - When my text is changed, my hasUnacceptedEdits: method is called with true, and I ask my styler to re-colour my text. This is performed in a background process so that typing remains responsive regardless of the length of the text. - - Just before my styler is about to format/style the text, I send #stylerAboutToStyle: to my model. This gives my model a chance to veto the styling (by answering false), or to initialize the styler with information it needs in order to parse the text correctly (e.g. the class to which a method belongs, or the workspace in which I am contained). - - My styler informs me that it has finished styling by triggering the #shoutStyled event which I handle. I then update the textAttributes of my text and refresh the display. - - My 'unstyledAcceptText' instance variable is used in conjunction with my #acceptTextInModel and #correctFrom:to:with: methods to ensure that when my text is modified during a method compilation (removing unused vars etc), I do not lose those changes.! -!Morph methodsFor: 'testing' stamp: 'jmv 10/31/2021 19:06:51'! - drawsKeyboardFocusIndicator - - ^false! ! -!PluggableScrollPane methodsFor: 'testing' stamp: 'jmv 10/31/2021 19:05:16' overrides: 50621816! - drawsKeyboardFocusIndicator - - ^drawKeyboardFocusIndicator! ! -!InnerTextMorph methodsFor: 'editing' stamp: 'jmv 10/31/2021 19:07:57' prior: 50454559! - acceptContents - "The message is sent when the user hits return or Cmd-S. - Accept the current contents and end editing." - "Inform the model of text to be accepted, and return true if OK." - - | accepted prevSelection prevScrollValue | - - prevSelection _ self editor selectionInterval copy. - prevScrollValue _ owner verticalScrollBar scrollValue. - - hasUnacceptedEdits ifFalse: [ self flash. ^true ]. - hasEditingConflicts ifTrue: [ - self confirmAcceptAnyway ifFalse: [self flash. ^false]]. - - accepted _ model acceptContentsFrom: owner. - "During the step for the browser, updatePaneIfNeeded is called, and - invariably resets the contents of the code-holding PluggableTextMorph - at that time, resetting the cursor position and scroller in the process. - The following line forces that update without waiting for the step, - then restores the cursor and scrollbar" - - "some implementors of acceptContentsFrom: answer self :(" - ^accepted == true - ifTrue: [ - model refetch. - self editor selectFrom: prevSelection first to: prevSelection last. - UISupervisor whenUIinSafeState: [ - self world ifNotNil: [ :w | w activeHand newKeyboardFocus: self ]. - (owner is: #ScrollPane) ifTrue: [ - owner verticalScrollBar internalScrollValue: prevScrollValue]]. - true] - ifFalse: [ false ]! ! -!InnerTextMorph methodsFor: 'events' stamp: 'jmv 10/31/2021 18:16:36' prior: 16855688! - clickAndHalf: aMouseButtonEvent localPosition: localEventPosition - - self handleInteraction: [ - editor clickAndHalf ]. - (owner is: #ScrollPane) ifTrue: [ - owner scrollSelectionIntoView ].! ! -!InnerTextMorph methodsFor: 'events' stamp: 'jmv 10/31/2021 18:16:42' prior: 16855695! - doubleClickAndHalf: aMouseButtonEvent localPosition: localEventPosition - - self handleInteraction: [ - editor doubleClickAndHalf ]. - (owner is: #ScrollPane) ifTrue: [ - owner scrollSelectionIntoView ].! ! -!InnerTextMorph methodsFor: 'events' stamp: 'jmv 10/31/2021 18:17:07' prior: 16855756 overrides: 16874556! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - - super mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition. - self pauseBlinking. - self handleInteraction: [ editor mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition ]. - (owner is: #ScrollPane) ifTrue: [ - owner scrollSelectionIntoView ]! ! -!InnerTextMorph methodsFor: 'events' stamp: 'jmv 10/31/2021 18:17:20' prior: 16855768 overrides: 16874651! - mouseMove: aMouseMoveEvent localPosition: localEventPosition - - aMouseMoveEvent mouseButton1Pressed ifFalse: [ - ^ self enterClickableRegion: aMouseMoveEvent localPosition: localEventPosition ]. - self handleInteraction: [ - editor mouseMove: aMouseMoveEvent localPosition: localEventPosition]. - (owner is: #ScrollPane) ifTrue: [ - owner scrollSelectionIntoView ].! ! -!InnerTextMorph methodsFor: 'event handling' stamp: 'jmv 10/31/2021 19:04:30' prior: 50601626 overrides: 50590348! - keyboardFocusChange: aBoolean - - "The message is sent to a morph when its keyboard focus changes. - The given argument indicates that the receiver is gaining (versus losing) the keyboard focus. - In this case, all we need to do is to redraw border feedback" - aBoolean - ifTrue: [ - "A hand is wanting to send us characters..." - editor ifNil: [ self editor storeSelectionInComposition ]. "Forces install" - self showsBlinkingCursor ifTrue: [ - editor hasSelection ifFalse: [ - self startBlinking ]]] - ifFalse: [ self stopBlinking ]. - - (owner notNil and: [ owner drawsKeyboardFocusIndicator ]) - ifTrue: [ owner redrawNeeded ] - ifFalse: [ - "Selection might be shown differently when focused" - self textComposition selectionRects do: [ :r | self invalidateLocalRect: r ]] .! ! -!InnerTextMorph methodsFor: 'event handling' stamp: 'jmv 10/31/2021 18:18:44' prior: 50564666! - processKeystrokeEvent: evt - | action | - - (acceptOnCR and: [evt isReturnKey]) ifTrue: [^ self acceptContents]. - - self pauseBlinking. - - "Return - check for special action" - evt isReturnKey ifTrue: [ - action _ self crAction. - action ifNotNil: [ ^action value]]. - - "Esc - check for special action" - evt isEsc ifTrue: [ - action _ self escAction. - action ifNotNil: [ ^action value]]. - - self handleInteraction: [ editor processKeystrokeEvent: evt ]. - (owner is: #ScrollPane) ifTrue: [ - owner scrollSelectionIntoView ].! ! -!InnerTextMorph methodsFor: 'geometry' stamp: 'jmv 10/31/2021 18:15:57' prior: 50617637 overrides: 50556435! - extentChanged: oldExtent - "Our extent changed. Reflow text." - super extentChanged: oldExtent. - model ifNotNil: [ - wrapFlag ifTrue: [ - extent x = oldExtent x ifFalse: [ - self resetTextComposition. - self editor recomputeSelection. - (owner is: #ScrollPane) ifTrue: [ - owner - updateScrollBarsBounds; - setScrollDeltas ]]]].! ! -!InnerTextMorph methodsFor: 'private' stamp: 'jmv 10/31/2021 19:09:04' prior: 50556627! - fit - "Adjust my bounds to fit the text. - Required after the text changes, - or if wrapFlag is true and the user attempts to change the extent." - - | newExtent newHeight newWidth oldExtent | - newWidth _ extent x. - "Adjust width only if we don't wrap text to own width!!" - wrapFlag ifFalse: [ - newWidth _ self textComposition usedWidth max: 9 ]. - newHeight _ self textComposition usedHeight max: FontFamily defaultLineSpacing + 2. - newExtent _ newWidth @ newHeight. - extent = newExtent - ifTrue: [ - self redrawNeeded. - "Too conservative: only text composition (because of changes in text or styles, etc) - should cause invalidation. - Try to avoid calling #fit unless needed." - ] - ifFalse: [ - extent = newExtent ifFalse: [ - oldExtent _ extent. - extent _ newExtent. - self extentChanged: oldExtent. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]]. - - (owner is: #ScrollPane) ifTrue: [ - owner innerHeight: newExtent y ].! ! -!InnerTextMorph methodsFor: 'private' stamp: 'jmv 10/31/2021 17:52:28' prior: 50420044! - selectionChanged - - self textComposition selectionRects do: [ :r | self invalidateLocalRect: r ]. - (self showsBlinkingCursor and: [ editor hasSelection not ]) - ifTrue: [ self hasKeyboardFocus ifTrue: [self startBlinking ]] - ifFalse: [ self stopBlinking ]! ! -!InnerTextMorph methodsFor: 'private' stamp: 'jmv 10/31/2021 18:16:05' prior: 50601768! - updateFromTextComposition - "A change has taken place in my textComposition, as a result of editing and I must be updated. " - - textComposition ifNotNil: [ - editor storeSelectionInComposition. - needsFit ifTrue: [ - self fit. - needsFit _ false ]]. - - (owner is: #ScrollPane) ifTrue: [ - owner - updateScrollBarsBounds; - setScrollDeltas ].! ! -!InnerTextMorph methodsFor: 'notifications' stamp: 'jmv 10/31/2021 19:07:36' prior: 50449804! - possiblyChanged - | embeddedMorphs | - embeddedMorphs _ model actualContents embeddedMorphs. - self submorphsDo: [:each| - (embeddedMorphs includes: each) ifFalse: [ - self privateRemove: each. - each privateOwner: nil ]]. - embeddedMorphs do: [ :each| - each owner == self ifFalse: [ - self addMorphFront: each. - each hide "Show it only when properly located"]]. - (owner is: #ScrollPane) ifTrue: [ - owner possiblyChanged ]! ! -!InnerTextMorph methodsFor: 'shout' stamp: 'jmv 10/31/2021 18:18:53' prior: 50556843! - stylerStyled - - model allowStylingWithEmphasis ifTrue: [ - self textComposition composeAll ]. - self editor recomputeSelection. - self updateFromTextComposition. - self editor blinkParen. - (owner is: #ScrollPane) ifTrue: [ - owner scrollSelectionIntoView ].! ! - -TextModelMorph removeSelector: #drawKeyboardFocusIndicator! - -!methodRemoval: TextModelMorph #drawKeyboardFocusIndicator stamp: 'Install-4959-InnerTextMorph-tweaks-JuanVuletich-2021Oct31-19h12m-jmv.001.cs.st 11/2/2021 10:28:06'! -drawKeyboardFocusIndicator - "For InnerTextMorph" - - ^drawKeyboardFocusIndicator! - -InnerTextMorph removeSelector: #scrollSelectionIntoView! - -!methodRemoval: InnerTextMorph #scrollSelectionIntoView stamp: 'Install-4959-InnerTextMorph-tweaks-JuanVuletich-2021Oct31-19h12m-jmv.001.cs.st 11/2/2021 10:28:06'! -scrollSelectionIntoView - - (owner is: #ScrollPane) ifTrue: [ - owner scrollSelectionIntoView ]! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4959-InnerTextMorph-tweaks-JuanVuletich-2021Oct31-19h12m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4958] on 31 October 2021 at 7:16:14 pm'! - -WidgetMorph subclass: #ReadOnlyTextMorph - instanceVariableNames: 'contents wrapFlag textComposition editor mutex needsFit' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #ReadOnlyTextMorph category: 'Morphic-Widgets' stamp: 'Install-4960-ReadOnlyTextMorph-JuanVuletich-2021Oct31-19h13m-jmv.001.cs.st 11/2/2021 10:28:06'! -WidgetMorph subclass: #ReadOnlyTextMorph - instanceVariableNames: 'contents wrapFlag textComposition editor mutex needsFit' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! -!ReadOnlyTextMorph commentStamp: 'jmv 10/31/2021 18:56:35' prior: 0! - ReadOnlyTextMorph support display of text with emphasis. Very much like InnerTextMorph, but doesn't allow editing. Doesn't have a model. Contents can be set directly. It can be used on its own, no need to include them in some kind of TextModelMorph / ScrollPane. - -Clipping to extent is done, and word wrap is optional. Support all features of Text, including fonts, sizes, emphasis and embedded morphs. - -Text display is clipped to the innerBounds of the rectangle, and text composition is normally performed within a rectangle which is innerBounds inset by the margins parameter. - - -(ReadOnlyTextMorph contents: 'Hello -World!!') openInWorld. - - -(ReadOnlyTextMorph contents: Utilities defaultTextEditorContents) openInWorld. - - -t := ReadOnlyTextMorph contents: Utilities defaultTextEditorContents. -s := PluggableScrollPane new. -s scroller: t. -s openInWorld.! -!Text methodsFor: 'TextModel compatibility' stamp: 'jmv 10/31/2021 18:33:45'! - actualContents - ^self! ! -!Text methodsFor: 'TextModel compatibility' stamp: 'jmv 10/31/2021 18:33:52'! - textSize - ^self size! ! -!ReadOnlyTextMorph methodsFor: 'accessing' stamp: 'jmv 10/31/2021 18:45:21'! - contents: aTextOrString - contents _ aTextOrString asText. - self releaseEditorAndTextComposition. "So the model is properly set on the editor and the text composition"! ! -!ReadOnlyTextMorph methodsFor: 'accessing' stamp: 'jmv 10/31/2021 18:45:36'! - contents: aTextOrString wrappedTo: width - "Accept new text contents. Lay it out, wrapping to width. - Then fit my height to the result." - | newExtent oldExtent | - wrapFlag _ true. - contents _ aTextOrString asText. - newExtent _ width truncated@extent y. - extent = newExtent ifFalse: [ - oldExtent _ extent. - extent _ newExtent. - self extentChanged: oldExtent. - self someSubmorphPositionOrExtentChanged. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]. - self contents: aTextOrString! ! -!ReadOnlyTextMorph methodsFor: 'accessing' stamp: 'jmv 10/31/2021 18:45:10'! - contentsAsIs: aTextOrString - "Accept new text contents with line breaks only as in the text. - Fit my width and height to the result." - wrapFlag _ false. - contents _ aTextOrString asText.! ! -!ReadOnlyTextMorph methodsFor: 'accessing' stamp: 'jmv 10/31/2021 17:33:03'! - editor - "Return my current editor, or install a new one." - editor ifNil: [ self installEditorAndTextComposition ]. - ^editor! ! -!ReadOnlyTextMorph methodsFor: 'accessing' stamp: 'jmv 10/31/2021 17:33:03'! - isWrapped - - ^wrapFlag! ! -!ReadOnlyTextMorph methodsFor: 'accessing' stamp: 'jmv 10/31/2021 17:33:03'! - textColor - - ^ color! ! -!ReadOnlyTextMorph methodsFor: 'accessing' stamp: 'jmv 10/31/2021 17:33:03'! - textColor: aColor - - color = aColor ifTrue: [^ self]. - color _ aColor. - self redrawNeeded! ! -!ReadOnlyTextMorph methodsFor: 'accessing' stamp: 'jmv 10/31/2021 17:33:03'! - wrapFlag: aBoolean - "Change whether contents are wrapped to the container." - - aBoolean == wrapFlag ifTrue: [^ self]. - wrapFlag _ aBoolean. - - "Compose my text to fit my bounds." - self resetTextComposition. - self editor recomputeSelection. - self updateFromTextComposition ! ! -!ReadOnlyTextMorph methodsFor: 'caching' stamp: 'jmv 10/31/2021 17:33:03' overrides: 50590334! - releaseCachedState - - super releaseCachedState. - self releaseEditorAndTextComposition. -! ! -!ReadOnlyTextMorph methodsFor: 'drawing' stamp: 'jmv 10/31/2021 17:33:03'! - debugDrawLineRectsOn: aCanvas - "Shows where text line rectangles are" - - self textComposition lines do: [ :line | - aCanvas - frameRectangle: line rectangle - borderWidth: 1 - color: `Color brown` ] -! ! -!ReadOnlyTextMorph methodsFor: 'drawing' stamp: 'jmv 10/31/2021 18:11:09' overrides: 50596652! - drawOn: aCanvas - "Draw the receiver on a canvas" - - false ifTrue: [ self debugDrawLineRectsOn: aCanvas ]. "show line rects for debugging" - - aCanvas - textComposition: self textComposition - bounds: self morphLocalBounds - color: color - selectionColor: (Theme current textHighlightFocused: self hasKeyboardFocus).! ! -!ReadOnlyTextMorph methodsFor: 'editing' stamp: 'jmv 10/31/2021 18:00:39'! - acceptOnCR - "Answer whether the receiver wants to accept when the Return key is hit" - - ^ false! ! -!ReadOnlyTextMorph methodsFor: 'editing' stamp: 'jmv 10/31/2021 17:33:03'! - enterClickableRegion: aMorphicEvent localPosition: localEventPosition -! ! -!ReadOnlyTextMorph methodsFor: 'editing' stamp: 'jmv 10/31/2021 17:33:03'! - handleInteraction: interactionBlock - "Perform the changes in interactionBlock, noting any change in selection - and possibly a change in the composition" - - self selectionChanged. "Note old selection" - - interactionBlock value. - - self selectionChanged. "Note new selection" - self updateFromTextComposition! ! -!ReadOnlyTextMorph methodsFor: 'events' stamp: 'jmv 10/31/2021 18:11:31'! - clickAndHalf: aMouseButtonEvent localPosition: localEventPosition - - self handleInteraction: [ - editor clickAndHalf ]. - (owner is: #ScrollPane) ifTrue: [ - owner scrollSelectionIntoView ].! ! -!ReadOnlyTextMorph methodsFor: 'events' stamp: 'jmv 10/31/2021 18:11:22'! - doubleClickAndHalf: aMouseButtonEvent localPosition: localEventPosition - - self handleInteraction: [ - editor doubleClickAndHalf ]. - (owner is: #ScrollPane) ifTrue: [ - owner scrollSelectionIntoView ].! ! -!ReadOnlyTextMorph methodsFor: 'events' stamp: 'jmv 10/31/2021 17:38:05' overrides: 50449234! - keyStroke: aKeyboardEvent - - (self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - - self processKeystrokeEvent: aKeyboardEvent. - - super keyStroke: aKeyboardEvent! ! -!ReadOnlyTextMorph methodsFor: 'events' stamp: 'jmv 10/31/2021 17:33:03' overrides: 16874541! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - "Make this TextMorph be the keyboard input focus, if it isn't already, - and repond to the text selection gesture." - - "If we don't focus, Get focus, and do nothing else (the user will need to click again to do further interaction)" - self hasKeyboardFocus ifFalse: [ - ^aMouseButtonEvent hand newKeyboardFocus: self]. - - super mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition. - - self handleInteraction: [ editor mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition ]. - - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: nil - clkNHalf: #clickAndHalf:localPosition: - dblClkSel: nil - dblClkNHalfSel: #doubleClickAndHalf:localPosition: - tripleClkSel: nil! ! -!ReadOnlyTextMorph methodsFor: 'events' stamp: 'jmv 10/31/2021 18:09:10' overrides: 16874556! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - - super mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition. - self handleInteraction: [ editor mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition ]. - (owner is: #ScrollPane) ifTrue: [ - owner scrollSelectionIntoView ]! ! -!ReadOnlyTextMorph methodsFor: 'events' stamp: 'jmv 10/31/2021 18:17:17' overrides: 16874651! - mouseMove: aMouseMoveEvent localPosition: localEventPosition - - aMouseMoveEvent mouseButton1Pressed ifFalse: [ - ^ self enterClickableRegion: aMouseMoveEvent localPosition: localEventPosition ]. - self handleInteraction: [ - editor mouseMove: aMouseMoveEvent localPosition: localEventPosition]. - (owner is: #ScrollPane) ifTrue: [ - owner scrollSelectionIntoView ].! ! -!ReadOnlyTextMorph methodsFor: 'event handling testing' stamp: 'jmv 10/31/2021 18:58:59'! - disablesEditing - ^ true! ! -!ReadOnlyTextMorph methodsFor: 'event handling testing' stamp: 'jmv 10/31/2021 17:33:03' overrides: 16874712! - handlesKeyboard - - ^self visible! ! -!ReadOnlyTextMorph methodsFor: 'event handling testing' stamp: 'jmv 10/31/2021 17:33:03' overrides: 16874721! - handlesMouseDown: aMouseButtonEvent - ^ true! ! -!ReadOnlyTextMorph methodsFor: 'event handling' stamp: 'jmv 10/31/2021 18:09:56' overrides: 50590348! - keyboardFocusChange: aBoolean - - "The message is sent to a morph when its keyboard focus changes. - The given argument indicates that the receiver is gaining (versus losing) the keyboard focus. - In this case, all we need to do is to redraw border feedback" - aBoolean - ifTrue: [ - "A hand is wanting to send us characters..." - editor ifNil: [ self editor storeSelectionInComposition ]. "Forces install" - ]. - - "Selection might be shown differently when focused" - self textComposition selectionRects do: [ :r | self invalidateLocalRect: r ].! ! -!ReadOnlyTextMorph methodsFor: 'event handling' stamp: 'jmv 10/31/2021 18:18:48'! - processKeystrokeEvent: evt - - self handleInteraction: [ editor processKeystrokeEvent: evt ]. - (owner is: #ScrollPane) ifTrue: [ - owner scrollSelectionIntoView ].! ! -!ReadOnlyTextMorph methodsFor: 'events-processing' stamp: 'jmv 10/31/2021 17:33:03' overrides: 50563149! - processKeystroke: aKeyboardEvent - "System level event handling." - - aKeyboardEvent wasHandled ifTrue:[^self]. - self handlesKeyboard ifFalse: [^ self]. - aKeyboardEvent wasHandled: true. - self keyStroke: aKeyboardEvent! ! -!ReadOnlyTextMorph methodsFor: 'events-processing' stamp: 'jmv 10/31/2021 17:33:03' overrides: 16875055! - processMouseMove: aMouseMoveEvent localPosition: localEventPosition - "Re-implemented to allow for mouse-up move events" - - aMouseMoveEvent wasHandled ifTrue: [ ^self ]. "not interested" - aMouseMoveEvent hand hasSubmorphs ifTrue: [ ^self ]. - aMouseMoveEvent wasHandled: true. - self mouseMove: aMouseMoveEvent localPosition: localEventPosition. - (aMouseMoveEvent anyButtonPressed and: [ self hasMouseFocus ]) ifFalse: [ ^self ]. - (self handlesMouseStillDown: aMouseMoveEvent) ifTrue:[ - "Step at the new location" - self startStepping: #processMouseStillDown stepTime: 1]! ! -!ReadOnlyTextMorph methodsFor: 'geometry' stamp: 'jmv 10/31/2021 18:55:58' overrides: 50617350! - adjustExtent -"So far, copied verbatim from InnerTextMorph." - "This is just a suggestion. If we do wordwrap, the width will be honored. - But the height is whatever is appropriate for the contents!! See #fit" - self morphExtent: owner viewableExtent! ! -!ReadOnlyTextMorph methodsFor: 'geometry' stamp: 'jmv 10/31/2021 18:38:13' overrides: 50556435! - extentChanged: oldExtent - "Our extent changed. Reflow text." - super extentChanged: oldExtent. - contents ifNotNil: [ - wrapFlag ifTrue: [ - extent x = oldExtent x ifFalse: [ - self resetTextComposition. - self editor recomputeSelection. - (owner is: #ScrollPane) ifTrue: [ - owner - updateScrollBarsBounds; - setScrollDeltas ]]]].! ! -!ReadOnlyTextMorph methodsFor: 'geometry' stamp: 'jmv 10/31/2021 17:33:03' overrides: 50499537! -minimumExtent - - ^(9@(FontFamily defaultLineSpacing+2))! ! -!ReadOnlyTextMorph methodsFor: 'geometry' stamp: 'jmv 10/31/2021 18:55:43' overrides: 50546006! - privateExtent: aPoint - | newExtent | -"So far, copied verbatim from InnerTextMorph." - "Resist changing the extent if no wordwrap. this should be checked." - wrapFlag ifFalse: [ ^ false ]. - - "Just update width. Height is set by ourselves. See #fit" - newExtent _ aPoint x truncated @ extent y. - - ^ super privateExtent: newExtent! ! -!ReadOnlyTextMorph methodsFor: 'initialization' stamp: 'jmv 10/31/2021 17:33:03' overrides: 50545900! - defaultColor - "Return the default fill style for the receiver" - ^ Theme current text! ! -!ReadOnlyTextMorph methodsFor: 'initialization' stamp: 'jmv 10/31/2021 18:22:11' overrides: 50545905! - initialize - super initialize. - wrapFlag _ true. - needsFit _ false.! ! -!ReadOnlyTextMorph methodsFor: 'menu' stamp: 'jmv 10/31/2021 17:33:03' overrides: 16876144! - addCustomMenuItems: aCustomMenu hand: aHandMorph - "Add text-related menu items to the menu" - - super addCustomMenuItems: aCustomMenu hand: aHandMorph. - aCustomMenu - addUpdating: #wrapString - target: self - action: #wrapOnOff! ! -!ReadOnlyTextMorph methodsFor: 'menu' stamp: 'jmv 10/31/2021 17:33:03'! - wrapOnOff - self wrapFlag: wrapFlag not! ! -!ReadOnlyTextMorph methodsFor: 'menu' stamp: 'jmv 10/31/2021 17:33:03'! - wrapString - "Answer the string to put in a menu that will invite the user to - switch word wrap mode" - ^ wrapFlag asMenuItemTextPrefix, - 'text wrap to bounds'! ! -!ReadOnlyTextMorph methodsFor: 'private' stamp: 'jmv 10/31/2021 17:33:03'! - extentForComposing - self flag: #jmvVer2. "like #extent ..." - ^wrapFlag - ifTrue: [ extent x @ 9999999 ] - ifFalse: [ 9999999@9999999 ]! ! -!ReadOnlyTextMorph methodsFor: 'private' stamp: 'jmv 10/31/2021 18:10:34'! - fit - "Adjust my bounds to fit the text. - Required after the text changes, - or if wrapFlag is true and the user attempts to change the extent." - - | newExtent newHeight newWidth oldExtent | - newWidth _ extent x. - "Adjust width only if we don't wrap text to own width!!" - wrapFlag ifFalse: [ - newWidth _ self textComposition usedWidth max: 9 ]. - newHeight _ self textComposition usedHeight max: FontFamily defaultLineSpacing + 2. - newExtent _ newWidth @ newHeight. - extent = newExtent - ifTrue: [ - self redrawNeeded. - "Too conservative: only text composition (because of changes in text or styles, etc) - should cause invalidation. - Try to avoid calling #fit unless needed." - ] - ifFalse: [ - extent = newExtent ifFalse: [ - oldExtent _ extent. - extent _ newExtent. - self extentChanged: oldExtent. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]].! ! -!ReadOnlyTextMorph methodsFor: 'private' stamp: 'jmv 10/31/2021 18:43:02'! - installEditorAndTextComposition - "Install an editor for my textComposition. Install also the textComposition." - | e tc | - - "Editor and TextComposition are assigned here atomically." - e _ TextEditor new morph: self. - e model: contents. - tc _ TextComposition new. - tc showTextCursor: false. - "Keep critical section short" - self mutex critical: [ - editor _ e. - textComposition _ tc. - tc - setModel: contents; - extentForComposing: self extentForComposing. - e textComposition: tc. - tc editor: e ]. - e setEmphasisHereFromText. - tc composeAll. - e resetState. - self fit. - self selectionChanged.! ! -!ReadOnlyTextMorph methodsFor: 'private' stamp: 'jmv 10/31/2021 17:33:03'! - mutex - mutex - ifNil: [ mutex := Mutex new ]. - ^mutex! ! -!ReadOnlyTextMorph methodsFor: 'private' stamp: 'jmv 10/31/2021 17:33:03'! - releaseEditorAndTextComposition - "Editor and TextComposition instantiation is lazy -- they will be created only when needed" - - editor _ nil. - textComposition _ nil! ! -!ReadOnlyTextMorph methodsFor: 'private' stamp: 'jmv 10/31/2021 17:33:03'! - resetTextComposition - textComposition ifNotNil: [ - textComposition - initialize; - extentForComposing: self extentForComposing; - composeAll. - editor storeSelectionInComposition ]. - self fit. - self selectionChanged.! ! -!ReadOnlyTextMorph methodsFor: 'private' stamp: 'jmv 10/31/2021 17:58:57'! - selectionChanged - - self textComposition selectionRects do: [ :r | self invalidateLocalRect: r ].! ! -!ReadOnlyTextMorph methodsFor: 'private' stamp: 'jmv 10/31/2021 17:33:03'! - textComposition - "textComposition instantiation is lazy -- create it only when needed" - textComposition ifNil: [ self installEditorAndTextComposition ]. - ^textComposition! ! -!ReadOnlyTextMorph methodsFor: 'private' stamp: 'jmv 10/31/2021 18:07:27'! - updateFromTextComposition - "A change has taken place in my textComposition, as a result of editing and I must be updated. " - - textComposition ifNotNil: [ - editor storeSelectionInComposition. - needsFit ifTrue: [ - self fit. - needsFit _ false ]]. - - (owner is: #ScrollPane) ifTrue: [ - owner - updateScrollBarsBounds; - setScrollDeltas ].! ! -!ReadOnlyTextMorph methodsFor: 'notifications' stamp: 'jmv 10/31/2021 18:36:09' overrides: 50552944! - fontPreferenceChanged - - super fontPreferenceChanged. - self updateFromTextComposition.! ! -!ReadOnlyTextMorph methodsFor: 'notifications' stamp: 'jmv 10/31/2021 18:49:53'! - possiblyChanged! ! -!ReadOnlyTextMorph methodsFor: 'notifications' stamp: 'jmv 10/31/2021 17:33:03' overrides: 50537668! - someSubmorphPositionOrExtentChanged - "Our extent, or some submorph changed. Must layout submorphs again." - - super someSubmorphPositionOrExtentChanged. - textComposition ifNotNil: [ - textComposition composeAll. - self fit. - self selectionChanged ]! ! -!ReadOnlyTextMorph methodsFor: 'testing' stamp: 'jmv 10/31/2021 18:04:06'! - hasUnacceptedEdits - "No editing supported." - ^false! ! -!ReadOnlyTextMorph methodsFor: 'miscellaneous' stamp: 'jmv 10/31/2021 17:33:03'! - selectAll - "Tell my editor to select all the text" - - self editor selectAll. - self redrawNeeded! ! -!ReadOnlyTextMorph class methodsFor: 'instance creation' stamp: 'jmv 10/31/2021 19:16:08'! - contents: aTextOrString - "See a few more examples in class comment" -" -(ReadOnlyTextMorph contents: 'Hello -World!!') openInWorld -" - - ^ self new contents: aTextOrString.! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4960-ReadOnlyTextMorph-JuanVuletich-2021Oct31-19h13m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4960] on 31 October 2021 at 7:42:03 pm'! -!InnerTextMorph methodsFor: 'geometry' stamp: 'jmv 10/31/2021 19:37:38' prior: 50556615 overrides: 50546006! - privateExtent: aPoint - | newExtent | - - newExtent _ aPoint. - (owner is: #ScrollPane) ifTrue: [ - "Resist changing the extent if no wordwrap. this should be checked." - wrapFlag ifFalse: [ ^ false ]. - - "Just update width. Height is set by ourselves. See #fit" - newExtent _ aPoint x truncated @ extent y ]. - - ^ super privateExtent: newExtent! ! -!InnerTextMorph methodsFor: 'private' stamp: 'jmv 10/31/2021 19:41:54' prior: 50621982! - fit - "Adjust my bounds to fit the text. - Required after the text changes, - or if wrapFlag is true and the user attempts to change the extent." - - | newExtent newHeight newWidth oldExtent | - (owner is: #ScrollPane) ifFalse: [ - ^self ]. - - newWidth _ extent x. - "Adjust width only if we don't wrap text to own width!!" - wrapFlag ifFalse: [ - newWidth _ self textComposition usedWidth max: 9 ]. - newHeight _ self textComposition usedHeight max: FontFamily defaultLineSpacing + 2. - newExtent _ newWidth @ newHeight. - extent = newExtent - ifTrue: [ - self redrawNeeded. - "Too conservative: only text composition (because of changes in text or styles, etc) - should cause invalidation. - Try to avoid calling #fit unless needed." - ] - ifFalse: [ - extent = newExtent ifFalse: [ - oldExtent _ extent. - extent _ newExtent. - self extentChanged: oldExtent. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]]. - - (owner is: #ScrollPane) ifTrue: [ - owner innerHeight: newExtent y ].! ! -!ReadOnlyTextMorph methodsFor: 'geometry' stamp: 'jmv 10/31/2021 18:55:58' prior: 50622435 overrides: 50617350! - adjustExtent -"So far, copied verbatim from InnerTextMorph." - "This is just a suggestion. If we do wordwrap, the width will be honored. - But the height is whatever is appropriate for the contents!! See #fit" - self morphExtent: owner viewableExtent! ! -!ReadOnlyTextMorph methodsFor: 'geometry' stamp: 'jmv 10/31/2021 19:37:21' prior: 50622465 overrides: 50546006! - privateExtent: aPoint - | newExtent | -"So far, copied verbatim from InnerTextMorph." - - newExtent _ aPoint. - (owner is: #ScrollPane) ifTrue: [ - "Resist changing the extent if no wordwrap. this should be checked." - wrapFlag ifFalse: [ ^ false ]. - - "Just update width. Height is set by ourselves. See #fit" - newExtent _ aPoint x truncated @ extent y ]. - - ^ super privateExtent: newExtent! ! -!ReadOnlyTextMorph methodsFor: 'private' stamp: 'jmv 10/31/2021 19:41:51' prior: 50622520! - fit - "Adjust my bounds to fit the text. - Required after the text changes, - or if wrapFlag is true and the user attempts to change the extent." - - | newExtent newHeight newWidth oldExtent | - (owner is: #ScrollPane) ifFalse: [ - ^self ]. - - newWidth _ extent x. - "Adjust width only if we don't wrap text to own width!!" - wrapFlag ifFalse: [ - newWidth _ self textComposition usedWidth max: 9 ]. - newHeight _ self textComposition usedHeight max: FontFamily defaultLineSpacing + 2. - newExtent _ newWidth @ newHeight. - extent = newExtent - ifTrue: [ - self redrawNeeded. - "Too conservative: only text composition (because of changes in text or styles, etc) - should cause invalidation. - Try to avoid calling #fit unless needed." - ] - ifFalse: [ - extent = newExtent ifFalse: [ - oldExtent _ extent. - extent _ newExtent. - self extentChanged: oldExtent. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]].! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 10/31/2021 19:34:05' prior: 50570244! - textComposition: aTextComposition bounds: boundsRect color: c selectionColor: sc - | displayScanner leftInRun line possibleVisibleLocalRect textTopLeft | - - textTopLeft _ boundsRect topLeft. - possibleVisibleLocalRect _ currentTransformation boundsOfInverseTransformOf: self clipRect. - - displayScanner _ MorphicScanner new - defaultFont: aTextComposition defaultFont; - text: aTextComposition textComposed - foreground: c. - displayScanner canvas: self. - - leftInRun _ 0. - "Take clipRect into account. Extrememly fast scrolls and redraws of huge files (like .sources)" - (aTextComposition lineIndexForPoint: (possibleVisibleLocalRect topLeft - textTopLeft max: `0@0`) ) - to: (aTextComposition lineIndexForPoint: (possibleVisibleLocalRect bottomRight - textTopLeft min: boundsRect bottomRight)) - do: [ :i | - line _ aTextComposition lines at: i. - aTextComposition - displaySelectionInLine: line - on: self - textTopLeft: textTopLeft - selectionColor: sc. - leftInRun _ displayScanner displayLine: line textTopLeft: textTopLeft leftInRun: leftInRun ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4961-ReadOnlyTextMorph-tweaks-JuanVuletich-2021Oct31-19h34m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4961] on 1 November 2021 at 9:52:29 am'! -!InnerTextMorph methodsFor: 'selection' stamp: 'jmv 7/29/2012 15:12'! - scrollSelectionIntoView - - (owner is: #ScrollPane) ifTrue: [ - owner scrollSelectionIntoView ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4962-FixASlip-JuanVuletich-2021Nov01-09h52m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4962] on 1 November 2021 at 11:42:37 am'! - -WidgetMorph subclass: #TextParagraphMorph - instanceVariableNames: 'textComposition' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #TextParagraphMorph category: 'Morphic-Widgets' stamp: 'Install-4963-TextParagraphMorph-HilaireFernandes-JuanVuletich-2021Nov01-11h39m-jmv.001.cs.st 11/2/2021 10:28:06'! -WidgetMorph subclass: #TextParagraphMorph - instanceVariableNames: 'textComposition' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! -!TextParagraphMorph commentStamp: 'jmv 11/1/2021 09:58:10' prior: 0! - TextParagraphMorph support display of text with emphasis. It can be used on its own, no need to include them in some kind of TextModelMorph / ScrollPane. - -Clipping to extent is done, and word wrap is optional. Support all features of Text, including fonts, sizes, emphasis and embedded morphs. - -Text display is clipped to the innerBounds of the rectangle, and text composition is normally performed within a rectangle which is innerBounds inset by the margins parameter. - - -(TextParagraphMorph contents: 'Hello -World!!') openInWorld. - - -(TextParagraphMorph contents: Utilities defaultTextEditorContents) openInWorld. - - -| t s | -t := TextParagraphMorph contents: Utilities defaultTextEditorContents. -s := PluggableScrollPane new. -s scroller: t. -s openInWorld.! -!TextParagraphMorph methodsFor: 'accessing' stamp: 'hlsf 10/31/2021 19:52:05'! - contents: aStringOrText - textComposition textComposed ~= aStringOrText ifTrue: [ - textComposition - setModel: (TextModel withText: aStringOrText); - composeAll. - extent _ textComposition usedExtent + 8]! ! -!TextParagraphMorph methodsFor: 'initialization' stamp: 'jmv 11/1/2021 10:08:39' overrides: 50545905! - initialize - super initialize. - textComposition _ TextComposition new. - textComposition - setModel: (TextModel withText: ''); - extentForComposing: extent x @ 9999999; - composeAll.! ! -!TextParagraphMorph methodsFor: 'drawing' stamp: 'hlsf 10/31/2021 20:06:11' overrides: 50596652! - drawOn: aCanvas - aCanvas - textComposition: textComposition - bounds: self morphLocalBounds - color: Theme current text - selectionColor: `Color red`.! ! -!TextParagraphMorph methodsFor: 'geometry' stamp: 'hlsf 11/1/2021 11:25:27' overrides: 50617350! - adjustExtent - "This is just a suggestion. If we do wordwrap, the width will be honored. - But the height is whatever is appropriate for the contents!! See #fit" - self morphExtent: owner viewableExtent! ! -!TextParagraphMorph methodsFor: 'geometry' stamp: 'hlsf 11/1/2021 11:29:52' overrides: 50556435! - extentChanged: oldExtent - "Our extent changed. Reflow text." - super extentChanged: oldExtent. - extent x = oldExtent x ifFalse: [ - textComposition - initialize; - extentForComposing: extent x @ 9999999; - composeAll. - self fit. - (owner is: #ScrollPane) ifTrue: [ - owner - updateScrollBarsBounds; - setScrollDeltas ]].! ! -!TextParagraphMorph methodsFor: 'geometry' stamp: 'hlsf 11/1/2021 11:33:19' overrides: 50546006! - privateExtent: aPoint - | newExtent | - - newExtent _ aPoint. - (owner is: #ScrollPane) ifTrue: [ - "We decide our own height" - newExtent _ aPoint x truncated @ extent y ]. - ^ super privateExtent: newExtent! ! -!TextParagraphMorph methodsFor: 'private' stamp: 'hlsf 11/1/2021 11:29:40'! - fit - "Adjust my bounds to fit the text." - - | newExtent oldExtent | - (owner is: #ScrollPane) ifFalse: [ - ^self ]. - - newExtent _ extent x @ (textComposition usedHeight max: FontFamily defaultLineSpacing + 2). - extent = newExtent ifFalse: [ - oldExtent _ extent. - extent _ newExtent. - self extentChanged: oldExtent. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ].! ! -!TextParagraphMorph class methodsFor: 'instance creation' stamp: 'hlsf 10/31/2021 19:58:58'! - contents: aStringOrText - ^ self new - contents: aStringOrText ; - yourself ! ! -!InnerTextMorph methodsFor: 'private' stamp: 'jmv 11/1/2021 11:39:40' prior: 50622687! - fit - "Adjust my bounds to fit the text. - Required after the text changes, - or if wrapFlag is true and the user attempts to change the extent." - - | newExtent newHeight newWidth oldExtent | - (owner is: #ScrollPane) ifFalse: [ - ^self ]. - - newWidth _ extent x. - "Adjust width only if we don't wrap text to own width!!" - wrapFlag ifFalse: [ - newWidth _ self textComposition usedWidth max: 9 ]. - newHeight _ self textComposition usedHeight max: FontFamily defaultLineSpacing + 2. - newExtent _ newWidth @ newHeight. - extent = newExtent - ifTrue: [ - "Too conservative: only text composition (because of changes in text or styles, etc) - should cause invalidation. - Try to avoid calling #fit unless needed." - self redrawNeeded ] - ifFalse: [ - oldExtent _ extent. - extent _ newExtent. - self extentChanged: oldExtent. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]. - - (owner is: #ScrollPane) ifTrue: [ - owner innerHeight: newExtent y ].! ! - -Text removeSelector: #textSize! - -!methodRemoval: Text #textSize stamp: 'Install-4963-TextParagraphMorph-HilaireFernandes-JuanVuletich-2021Nov01-11h39m-jmv.001.cs.st 11/2/2021 10:28:06'! -textSize - ^self size! - -Text removeSelector: #actualContents! - -!methodRemoval: Text #actualContents stamp: 'Install-4963-TextParagraphMorph-HilaireFernandes-JuanVuletich-2021Nov01-11h39m-jmv.001.cs.st 11/2/2021 10:28:06'! -actualContents - ^self! - -Smalltalk removeClassNamed: #ReadOnlyTextMorph! - -!classRemoval: #ReadOnlyTextMorph stamp: 'Install-4963-TextParagraphMorph-HilaireFernandes-JuanVuletich-2021Nov01-11h39m-jmv.001.cs.st 11/2/2021 10:28:06'! -WidgetMorph subclass: #ReadOnlyTextMorph - instanceVariableNames: 'contents wrapFlag textComposition editor mutex needsFit' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4963-TextParagraphMorph-HilaireFernandes-JuanVuletich-2021Nov01-11h39m-jmv.001.cs.st----! - -----QUIT----(2 November 2021 10:28:09) Cuis5.0-4963-v3.image priorSource: 9137405! - -----STARTUP---- (23 November 2021 10:54:22) as C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\Cuis5.0-4963-v3.image! - - -'From Cuis 5.0 [latest update: #4913] on 3 November 2021 at 7:32:45 pm'! -!ExtractAsParameter class methodsFor: 'instance creation' stamp: 'HAW 11/3/2021 19:11:04'! - addParameterClass - - "This method is important for LiveTyping parameterization. Do not remove - Hernan" - ^ AddParameter! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 11/3/2021 19:09:24' prior: 50610180! - assertIsValidKeywordForNewParameter: aNewKeyword - - self addParameterClass assertIsValidKeywordForNewParameter: aNewKeyword! ! -!ExtractAsParameter class methodsFor: 'pre-conditions' stamp: 'HAW 11/3/2021 19:09:24' prior: 50610207! - assertIsValidParameterName: aName - - self addParameterClass assertIsValidParameterName: aName ! ! -!ExtractAsParameter class methodsFor: 'instance creation' stamp: 'HAW 11/3/2021 19:09:24' prior: 50611300! - named: aNewParameter - extractedFromAll: intervals - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - - ^self - assertAndCreateNamed: aNewParameter - extractedFromAll: intervals - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - creatingAddParameterWith: [ :sourceCodeToExtract | - self addParameterClass - named: aNewParameter - initializedWith: sourceCodeToExtract - toUnarySelector: aSourceMethod selector - implementors: implementorsCollection - senders: sendersCollection ]! ! -!ExtractAsParameter class methodsFor: 'instance creation' stamp: 'HAW 11/3/2021 19:09:24' prior: 50611321! - named: aNewParameter - extractedFromAll: intervals - at: aNewKeywordIndex - newKeyword: newKeyword - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - - ^self - assertAndCreateNamed: aNewParameter - extractedFromAll: intervals - at: aSourceMethod - implementors: implementorsCollection - senders: sendersCollection - creatingAddParameterWith: [ :sourceCodeToExtract | - self addParameterClass - named: aNewParameter - at: aNewKeywordIndex - initializedWith: sourceCodeToExtract - using: newKeyword - toKeywordSelector: aSourceMethod selector - implementors: implementorsCollection - senders: sendersCollection ]! ! -!ExtractAsParameter class methodsFor: 'implementors and senders' stamp: 'HAW 11/3/2021 19:09:24' prior: 50610371! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders forClassAndMetaOf: aPotentialClassToRefactor - - ^self addParameterClass addImplementorsOf: anOldSelector to: implementors andSendersTo: senders forClassAndMetaOf: aPotentialClassToRefactor! ! -!ExtractAsParameter class methodsFor: 'implementors and senders' stamp: 'HAW 11/3/2021 19:09:24' prior: 50610382! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategoriesAndHierarchyOf: aClass organizedBy: anOrganization - - ^self addParameterClass addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategoriesAndHierarchyOf: aClass organizedBy: anOrganization! ! -!ExtractAsParameter class methodsFor: 'implementors and senders' stamp: 'HAW 11/3/2021 19:09:24' prior: 50610395! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategory: aCategory organizedBy: anOrganization - - ^self addParameterClass addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inCategory: aCategory organizedBy: anOrganization! ! -!ExtractAsParameter class methodsFor: 'implementors and senders' stamp: 'HAW 11/3/2021 19:09:24' prior: 50610407! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inHierarchyOf: aClass - - ^self addParameterClass addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inHierarchyOf: aClass -! ! -!ExtractAsParameter class methodsFor: 'implementors and senders' stamp: 'HAW 11/3/2021 19:09:24' prior: 50610417! - addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inSystem: aSystem - - ^self addParameterClass addImplementorsOf: anOldSelector to: implementors andSendersTo: senders inSystem: aSystem -! ! -!ChangeSelectorApplier class methodsFor: 'instance creation' stamp: 'HAW 1/1/2020 21:54:30' prior: 50491653! - on: aBrowser for: aSelector in: aSelectedClass - - self assertCanApplyRefactoringFor: aSelector in: aSelectedClass. - - ^self new initializeOn: aBrowser for: aSelector in: aSelectedClass - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4964-ExtractAsParameterLiveTypingSupport-HernanWilkinson-2021Nov03-18h17m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4964] on 4 November 2021 at 10:18:21 am'! -!SmalltalkCompleterMorph methodsFor: 'selector documentation' stamp: 'HAW 11/4/2021 10:17:50' prior: 50528738! - initializeSelectorDocumentation - - selectorDocumentation := TextModelMorph withText: ''. - selectorDocumentation innerTextMorph - acceptOnCR: false; - crAction: [ self crPressedOnSelectorDocumentation ]. - - selectorDocumentation - wrapFlag: true; - borderColor: Color black; - borderWidth: 1; - disableEditing; - openInWorld - ! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4965-SmalltalkCompleterMorphDocumentationFix-HernanWilkinson-2021Nov04-10h17m-HAW.001.cs.st----! - -'From Cuis 5.0 [latest update: #4965] on 4 November 2021 at 4:49:32 pm'! -!HierarchicalListMorph methodsFor: 'geometry' stamp: 'jmv 11/4/2021 15:52:51' overrides: 50617691! - someSubmorphPositionOrExtentChanged - "Our extent, or some submorph changed. Must layout submorphs again." - - self layoutNeeded: true. - self updateScrollBarsBounds! ! -!PluggableListMorph methodsFor: 'geometry' stamp: 'jmv 11/4/2021 15:52:17' overrides: 50617691! - someSubmorphPositionOrExtentChanged - "Our extent, or some submorph changed. Must layout submorphs again." - - self layoutNeeded: true. - self updateScrollBarsBounds! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4966-FixRecentSlowdownInListMorphs-JuanVuletich-2021Nov04-16h48m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4965] on 4 November 2021 at 5:14:49 pm'! -!HoverHelpMorph methodsFor: 'accessing' stamp: 'jmv 11/4/2021 17:11:01'! - contents: aString wrappedTo: wordWrapWidthOrNil - "If wordWrapWidthOrNil is nil, don't do wordwrap, and make the morph as wide as needed" - - | width | - contents _ aString. - width _ wordWrapWidthOrNil ifNil: [9999999]. -wordWrapWidthOrNil print. - textComposition _ TextComposition new. - textComposition - setModel: (TextModel withText: contents asText); - extentForComposing: width@9999999. - textComposition composeAll. - self morphExtent: textComposition usedExtent + 8.! ! -!HoverHelpMorph methodsFor: 'accessing' stamp: 'jmv 11/4/2021 17:07:51'! -contentsWrapped: aString - - self contents: aString wrappedTo: FontFamily defaultLineSpacing * 13! ! -!HoverHelpMorph class methodsFor: 'instance creation' stamp: 'jmv 11/4/2021 17:12:39'! - contents: aString wrappedTo: wordWrapWidthOrNil - "Make up and return a HoverHelp for morph. - (HoverHelpMorph contents: 'This is a HoverHelpMorph with a rather long contents to see how it gets wrapped. Is this long enough? Maybe a few more words are in order.' - wrappedTo: 150) openInHand - " - - ^self new contents: aString wrappedTo: wordWrapWidthOrNil! ! -!HoverHelpMorph class methodsFor: 'instance creation' stamp: 'jmv 11/4/2021 17:11:35'! - contentsWrapped: aString - "Make up and return a HoverHelp for morph. - (HoverHelpMorph contentsWrapped: 'This is a HoverHelpMorph with a rather long contents to see how it gets wrapped. Is this long enough? Maybe a few more words are in order.') openInHand - " - - ^self new contentsWrapped: aString! ! -!HoverHelpMorph methodsFor: 'accessing' stamp: 'jmv 11/4/2021 17:13:39' prior: 50616712! - contents: aString - - self contents: aString wrappedTo: nil! ! -!HoverHelpMorph class methodsFor: 'instance creation' stamp: 'jmv 11/4/2021 17:08:47' prior: 16853883! - contents: aString - "Make up and return a HoverHelp for morph. - (HoverHelpMorph contents: 'This is a HoverHelpMorph') openInHand - " - - ^self new contents: aString! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4967-HoverHelpMorph-contents-contentsWrapped-JuanVuletich-2021Nov04-16h49m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4967] on 9 November 2021 at 4:02:16 pm'! -!DateAndTime methodsFor: 'public protocol' stamp: 'jmv 11/9/2021 15:06:18'! - truncateToSeconds - nanos _ 0! ! -!Time class methodsFor: 'primitives' stamp: 'jmv 11/9/2021 14:26:36'! - primUtcWithOffset: arrayOrObjectWithTwoSlots - "The parameter may be a two element array, or an object whose first two instance - variables are expected to be UTC microseconds and seconds offset from GMT. - - First element is set to the number of microseconds since the UTC Posix (Unix) epoch, - i.e. 00:00 on the morning of January 1, 1970, in UTC time. - It might be a LargePositiveInteger (very likely on 32-bit images, very unlikely on 64-bit images). - - Second element is set to current seconds offset from GMT in the local time zone. - - Recent VMs implement this. Older Interpreters might not. - Time primUtcWithOffset: {0. 0} - " - - - ^nil! ! -!DateAndTime class methodsFor: 'ansi protocol' stamp: 'jmv 11/9/2021 15:28:56' prior: 16829159! - now - "Use highest resolution possible. - If called several times, always answer different, increasing values. This means that they can used as TimeStamps - DateAndTime now - " - - | days nanoseconds remainingNanoseconds remainingSeconds utcMicroSsecondsAndOffset | - utcMicroSsecondsAndOffset _ Time primUtcWithOffset: `{ 0. 0}`. - nanoseconds _ (utcMicroSsecondsAndOffset first + (utcMicroSsecondsAndOffset second * 1000000)) * 1000. - (LastTick = nanoseconds) - ifFalse: [ - LastTick _ nanoseconds] - ifTrue: [ - LastTickSemaphore critical: [ - LastTick _ LastTick + 1. - nanoseconds _ LastTick ]]. - - days _ nanoseconds // Time nanosecondsInDay. - remainingNanoseconds _ nanoseconds \\ Time nanosecondsInDay. - remainingSeconds _ remainingNanoseconds // 1000000000. - remainingNanoseconds _ remainingNanoseconds \\ 1000000000. - - ^ self basicNew - setJdn: `DateAndTime unixEpoch julianDayNumber` + days - seconds: remainingSeconds - nano: remainingNanoseconds - offset: (Duration seconds: utcMicroSsecondsAndOffset second)! ! -!DateAndTime class methodsFor: 'instance creation' stamp: 'jmv 11/9/2021 15:06:44' prior: 16829444! - nowUpToSeconds - "Resolution is up to one second. Don't use as a TimeStamp!! - DateAndTime nowUpToSeconds - " - - ^self now truncateToSeconds! ! -!Time class methodsFor: 'ansi protocol' stamp: 'jmv 11/9/2021 15:28:41' prior: 16937541! - now - "Answer a Time representing the time right now - this is a 24 hour clock. - Precision is microsecond." - - | microseconds utcMicroSsecondsAndOffset | - utcMicroSsecondsAndOffset _ Time primUtcWithOffset: `{ 0. 0}`. - microseconds _ (utcMicroSsecondsAndOffset first + (utcMicroSsecondsAndOffset second * 1000000)). - ^ self seconds: (microseconds // 1000000) nanoSeconds: (microseconds \\ 1000000) * 1000.! ! -!Time class methodsFor: 'private' stamp: 'jmv 11/9/2021 15:32:45' prior: 16937705! - currentUtcOffset - " - Time currentUtcOffset - " - ^ DateAndTime now offset! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4968-UseUTCtimePrimitives-JuanVuletich-2021Nov09-15h59m-jmv.002.cs.st----! - -'From Cuis 5.0 [latest update: #4967] on 9 November 2021 at 4:30:30 pm'! -!Time class methodsFor: 'primitives' stamp: 'jmv 11/9/2021 15:35:03' prior: 50445608! - primUtcWithOffset - "Answer a two element array. - Prefer #primUtcWithOffset: - - First element is the number of microseconds since the UTC Posix (Unix) epoch, - i.e. 00:00 on the morning of January 1, 1970, in UTC time. - It might be a LargePositiveInteger (very likely on 32-bit images, very unlikely on 64-bit images). - - Second element is the current seconds offset from GMT in the local time zone. - - Recent VMs implement this. Older Interpreters might not. - " - " - Time primUtcWithOffset - Time primUtcWithOffset first / 1000 / 1000 / 60 / 60 / 24 / 365.25 - Time primUtcWithOffset second / 60 / 60.0 - - (Time primUtcWithOffset first / 1000 / 1000 + Time primUtcWithOffset second) / 60 / 60 / 24 / 365.25 - (DateAndTime now - (DateAndTime year: 1970 month: 1 day: 1)) totalSeconds / 60 / 60 / 24 / 365.25 - " - - ^nil! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4969-Tweak-JuanVuletich-2021Nov09-16h29m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4969] on 9 November 2021 at 4:44:26 pm'! -!Time class methodsFor: 'general inquiries' stamp: 'jmv 11/9/2021 16:20:51' prior: 50445429! - localMillisecondClock - "Answer the number of milliseconds since the Smalltalk epoch, - i.e. 00:00 on the morning of January 1, 1901, in the local host time zone. - In other words, the number of microseconds since it was that time in this time zone." - - ^self primLocalMicrosecondClock // 1000! ! -!InputSensor methodsFor: 'keyboard' stamp: 'jmv 11/9/2021 15:37:01' prior: 50555266! - kbdTest - " - Sensor kbdTest - " - "This test routine will print the unmodified character, its keycode, - and the OR of all its modifier bits, until the character x is typed - -Also useful: - Sensor test - " - | char | - char _ nil. - [ char = $x ] whileFalse: [ - [ self keyboardPressed ] whileFalse. - char _ self keyboard. - Display fill: `5@5 extent: 400@50` fillColor: `Color white`. - (String streamContents: [ :s | - s - nextPut: $-; - nextPut: char; - nextPut: $-; - space; - print: char numericValue; - space. - self isMouseButton3Pressed ifTrue: [ s nextPutAll: ' mouseButton3/blue/tertiary/halo ' ]. - self isMouseButton2Pressed ifTrue: [ s nextPutAll: ' mouseButton2/yellow/secondary/menu ' ]. - self isMouseButton1Pressed ifTrue: [ s nextPutAll: ' mouseButton1/red/primary ' ]. - self shiftPressed ifTrue: [ s nextPutAll: ' shift ' ]. - self controlKeyPressed ifTrue: [ s nextPutAll: ' control/ctrl ' ]. - (self primMouseButtons anyMask: 32) ifTrue: [ s nextPutAll: ' macOption ' ]. - self commandAltKeyPressed ifTrue: [ s nextPutAll: ' macCommand/winAlt ' ]. - Time now printOn: s - ]) - displayAt: 10 @ 10 ].! ! - -Time class removeSelector: #primLocalSecondsClock! - -!methodRemoval: Time class #primLocalSecondsClock stamp: 'Install-4970-Cleanup-JuanVuletich-2021Nov09-16h43m-jmv.001.cs.st 11/23/2021 10:54:26'! -primLocalSecondsClock - "Answer the number of seconds since the Smalltalk epoch, - i.e. 00:00 on the morning of January 1, 1901, in the local host time zone. - In other words, the number of seconds since it was that time in this time zone. - Answer is a 32-bit unsigned number. - Answer might be a LargePositiveInteger on 32-bit images. - Note: This is in local time, i.e. the time the system shows to the user. - Essential. See Object documentation whatIsAPrimitive. - - Time primLocalSecondsClock - Time primLocalSecondsClock / 60 / 60 / 24 / 365.25 - - Warning: Will overflow in year 2037 - " - - - self primitiveFailed! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4970-Cleanup-JuanVuletich-2021Nov09-16h43m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4969] on 9 November 2021 at 4:47:58 pm'! -!Time class methodsFor: 'general inquiries' stamp: 'jmv 11/9/2021 16:21:57' prior: 50445391! - localMicrosecondClock - "Answer the number of microseconds since the Smalltalk epoch, - i.e. 00:00 on the morning of January 1, 1901, in the local host time zone. - In other words, the number of microseconds since it was that time in this time zone. - Answer might be a LargePositiveInteger (very likely on 32-bit images, very unlikely on 64-bit images)." - - ^self primLocalMicrosecondClock! ! -!Time class methodsFor: 'general inquiries' stamp: 'jmv 11/9/2021 16:21:30' prior: 50445495! - localSecondClock - "Answer the number of seconds since the Smalltalk epoch, - i.e. 00:00 on the morning of January 1, 1901, in the local host time zone. - In other words, the number of microseconds since it was that time in this time zone." - - ^self primLocalMicrosecondClock // 1000000! ! -!Time class methodsFor: 'primitives' stamp: 'jmv 11/9/2021 16:12:41' prior: 50340829! - primMillisecondClock - "Primitive. Answer the number of milliseconds since the millisecond clock - was last reset or rolled over. No sync to any system clock. - Implemented by all major platforms. - Essential. See Object documentation whatIsAPrimitive. - - Time primMillisecondClock - Time primMillisecondClock / 1000 / 60.0 - - Range is from zero to 16r1FFFFFFF. - The VM defines MillisecondClockMask as 16r1FFFFFFF - - Overflows usually every six days. - " -"Not really a clock, but a timer or ticker" - - - self primitiveFailed! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4971-Cleanup-JuanVuletich-2021Nov09-16h44m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4969] on 9 November 2021 at 4:58:59 pm'! - -Magnitude subclass: #DateAndTime - instanceVariableNames: 'seconds offset jdn nanos ' - classVariableNames: 'LastTick LastTickSemaphore LocalTimeZone ' - poolDictionaries: '' - category: 'Kernel-Chronology'! - -!classDefinition: #DateAndTime category: #'Kernel-Chronology' stamp: 'Install-4972-Remove-TimeZone-JuanVuletich-2021Nov09-16h47m-jmv.001.cs.st 11/23/2021 10:54:26'! -Magnitude subclass: #DateAndTime - instanceVariableNames: 'seconds offset jdn nanos' - classVariableNames: 'LastTick LastTickSemaphore LocalTimeZone' - poolDictionaries: '' - category: 'Kernel-Chronology'! -!DateAndTime class methodsFor: 'squeak protocol' stamp: 'jmv 11/9/2021 16:56:54' prior: 16829255! - localOffset - "Answer the duration we are offset from UTC" - - ^ self now offset! ! -!DateAndTime class methodsFor: 'system startup & shutdown' stamp: 'jmv 11/9/2021 16:57:39' prior: 16829486 overrides: 50510042! - releaseClassCachedState - - LastTickSemaphore _ nil. - LastTick _ nil.! ! -!DateAndTime class methodsFor: 'constants' stamp: 'jmv 11/9/2021 16:54:14' prior: 16829492! - unixEpoch - " - DateAndTime unixEpoch - 1970-01-01T00:00:00+00:00 - - (DateAndTime now - DateAndTime unixEpoch) days / 365.25 - " - ^ self - julianDayNumber: 2440588 - seconds: 0 - nanoseconds: 0 - offset: `Duration zero`.! ! -!Timespan class methodsFor: 'instance creation' stamp: 'jmv 11/9/2021 16:54:23' prior: 50342520! - includingDateAndTime: aDateAndTime - - ^ self starting: aDateAndTime duration: `Duration zero`.! ! -!BlockClosure methodsFor: 'evaluating' stamp: 'jmv 11/9/2021 16:54:33' prior: 16788150! - valueWithin: aDuration onTimeout: timeoutBlock - "Evaluate the receiver. - If the evaluation does not complete in less than aDuration evaluate the timeoutBlock instead" - - | theProcess delay watchdog tag | - - aDuration <= `Duration zero` ifTrue: [^ timeoutBlock value ]. - - "the block will be executed in the current process" - theProcess := Processor activeProcess. - delay := aDuration asDelay. - tag := self. - - "make a watchdog process" - watchdog := [ - delay wait. "wait for timeout or completion" - theProcess ifNotNil:[ theProcess signalException: (TimedOut new tag: tag)] - ] newProcess. - - "Watchdog needs to run at high priority to do its job (but not at timing priority)" - watchdog priority: Processor timingPriority-1. - - "catch the timeout signal" - ^ [ watchdog resume. "start up the watchdog" - self ensure:[ "evaluate the receiver" - theProcess := nil. "it has completed, so ..." - delay delaySemaphore signal. "arrange for the watchdog to exit" - ]] on: TimedOut do: [ :e | - e tag == tag - ifTrue:[ timeoutBlock value ] - ifFalse:[ e pass]].! ! - -DateAndTime class removeSelector: #localTimeZone:! - -!methodRemoval: DateAndTime class #localTimeZone: stamp: 'Install-4972-Remove-TimeZone-JuanVuletich-2021Nov09-16h47m-jmv.001.cs.st 11/23/2021 10:54:26'! -localTimeZone: aTimeZone - "Set the local time zone" - - " - DateAndTime localTimeZone: (TimeZone offset: 0 hours name: 'Universal Time' abbreviation: 'UTC'). - DateAndTime localTimeZone: (TimeZone offset: -8 hours name: 'Pacific Standard Time' abbreviation: 'PST'). - " - - LocalTimeZone := aTimeZone - - -! - -DateAndTime class removeSelector: #localTimeZone! - -!methodRemoval: DateAndTime class #localTimeZone stamp: 'Install-4972-Remove-TimeZone-JuanVuletich-2021Nov09-16h47m-jmv.001.cs.st 11/23/2021 10:54:26'! -localTimeZone - "Answer the local time zone" - - ^ LocalTimeZone ifNil: [ LocalTimeZone _ TimeZone default ] - -! - -DateAndTime removeSelector: #asLocal! - -!methodRemoval: DateAndTime #asLocal stamp: 'Install-4972-Remove-TimeZone-JuanVuletich-2021Nov09-16h47m-jmv.001.cs.st 11/23/2021 10:54:26'! -asLocal - - - ^ (self offset = self class localOffset) - - ifTrue: [self] - ifFalse: [self utcOffset: self class localOffset] -! - -DateAndTime removeSelector: #timeZoneAbbreviation! - -!methodRemoval: DateAndTime #timeZoneAbbreviation stamp: 'Install-4972-Remove-TimeZone-JuanVuletich-2021Nov09-16h47m-jmv.001.cs.st 11/23/2021 10:54:26'! -timeZoneAbbreviation - - ^ self class localTimeZone abbreviation -! - -DateAndTime removeSelector: #timeZoneName! - -!methodRemoval: DateAndTime #timeZoneName stamp: 'Install-4972-Remove-TimeZone-JuanVuletich-2021Nov09-16h47m-jmv.001.cs.st 11/23/2021 10:54:26'! -timeZoneName - - ^ self class localTimeZone name -! - -Magnitude subclass: #DateAndTime - instanceVariableNames: 'seconds offset jdn nanos' - classVariableNames: 'LastTick LastTickSemaphore' - poolDictionaries: '' - category: 'Kernel-Chronology'! - -!classDefinition: #DateAndTime category: #'Kernel-Chronology' stamp: 'Install-4972-Remove-TimeZone-JuanVuletich-2021Nov09-16h47m-jmv.001.cs.st 11/23/2021 10:54:26'! -Magnitude subclass: #DateAndTime - instanceVariableNames: 'seconds offset jdn nanos' - classVariableNames: 'LastTick LastTickSemaphore' - poolDictionaries: '' - category: 'Kernel-Chronology'! - -Smalltalk removeClassNamed: #TimeZone! - -!classRemoval: #TimeZone stamp: 'Install-4972-Remove-TimeZone-JuanVuletich-2021Nov09-16h47m-jmv.001.cs.st 11/23/2021 10:54:26'! -Object subclass: #TimeZone - instanceVariableNames: 'offset abbreviation name' - classVariableNames: '' - poolDictionaries: '' - category: 'Kernel-Chronology'! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4972-Remove-TimeZone-JuanVuletich-2021Nov09-16h47m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4972] on 16 November 2021 at 10:56:28 am'! -!StepMessage methodsFor: 'testing' stamp: 'jmv 11/16/2021 10:54:58' prior: 16913955! - stepTime - "Return the step time for this message. If nil, the receiver of the message will be asked for its #stepTime." - ^stepTime ifNil: [ receiver stepTime asInteger ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4973-DontCrashOnNonIntegerStepTimes-JuanVuletich-2021Nov16-10h54m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4973] on 23 November 2021 at 9:37:30 am'! -!EventSensor methodsFor: 'private-I/O' stamp: 'jmv 11/22/2021 22:12:30' prior: 50598266! - processSensorEvent: evt discardingMouseEvents: discardMouseEvents - "Process a single event. This method is run at high priority." - | type | - type _ evt at: 1. - - "Check if the event is a user interrupt" - (type = EventSensor eventTypeKeyboard and: [ (evt at: 4) = 0 and: [ - ((evt at: 3) bitOr: (((evt at: 5) bitAnd: 9) bitShift: 8)) = interruptKey]]) - ifTrue: [ - "interrupt key is meta - not reported as event" - ^interruptSemaphore signal]. - - "Store the event in the queue if there's any" - type = EventSensor eventTypeMouse ifTrue: [ - "Only swap secondary and tertiary buttons if there is no command or option modifier keys. - This swap is done so a 3-button mouse is - left -> mouseButton1 (select) - center -> mouseButton3 (halo) - right -> mouseButton2 (menu). - This is only needed on the Mac, Window VM does this mapping by default. - We avoid ding the swap if there are modifier keys, because in that case the buttons were generated by the VM as follows: - left -> mouseButton1 - macOption + left -> mouseButton3 - command + left -> mouseButton2, - but Mac users are already used to - macOption + left -> menu - command + left -> halo. - See #installMouseDecodeTable" - ((evt at: 6) anyMask: 12) ifFalse: [ - evt at: 5 put: (ButtonDecodeTable at: (evt at: 5) + 1)]]. - - (discardMouseEvents and: [ type = EventSensor eventTypeMouse ]) ifFalse: [ - self queueEvent: evt ]. - - "Update state for InputSensor." - "KLG: Why not `self class` instead of `EventSensor`?" - type = EventSensor eventTypeMouse ifTrue: [ - self processMouseSensorEvent: evt ]. - type = EventSensor eventTypeKeyboard ifTrue: [ - self processKeyboardSensorEvent: evt ]. - type = EventSensor eventTypeMouseScroll ifTrue: [ - self processMouseSensorWheelEvent: evt ]! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4974-InterruptKeyIsUnshifted-JuanVuletich-2021Nov23-09h35m-jmv.001.cs.st----! - -'From Cuis 5.0 [latest update: #4973] on 23 November 2021 at 10:01:51 am'! -!HandMorph methodsFor: 'private events' stamp: 'jmv 11/23/2021 10:00:50' prior: 50561318! - generateKeyboardEvent: evtBuf - "Generate the appropriate mouse event for the given raw event buffer" - | buttons modifiers type keyValue pressType stamp mouseScrollDirection | - stamp _ evtBuf second. - stamp = 0 ifTrue: [ stamp _ Time millisecondClockValue ]. "VMs report events using #millisecondClockValue" - (evtBuf sixth <= 0 or: [ (keyValue _ Character iso8859s15CodeForUnicodeCodePoint: evtBuf sixth) isNil ]) ifTrue: [ keyValue _ Character macRomanToLatin1: evtBuf third ]. - Sensor peekEvent ifNotNil: [ :nxt | - "start: Combining diacritical marks (i.e. accents in the Linux VM)" - (nxt fourth = EventSensor eventKeyDown and: [ nxt third > 255 ]) ifTrue: [ - keyValue _ ((Character numericValue: keyValue) withDiacriticalMark: nxt third) iso8859s15Code. - Sensor - nextEvent; - nextEvent; - nextEvent ]. - "end: Combining diacritical marks (i.e. accents in the Linux VM)" - "start: Spurious LF after CR on Ctrl-Enter on Windows VM" - ((evtBuf fourth = EventSensor eventKeyChar and: [ evtBuf third = 13 ]) and: [ - nxt fourth = EventSensor eventKeyChar and: [ nxt third = 10 ]]) ifTrue: [ Sensor nextEvent - "print " ]]. - modifiers _ evtBuf fifth. - pressType _ evtBuf fourth. - pressType = EventSensor eventKeyDown ifTrue: [ - type _ #keyDown. - lastKeyDownValue _ keyValue ]. - pressType = EventSensor eventKeyUp ifTrue: [ - (keyValue = 9 and: [(modifiers anyMask: 1) and: [Smalltalk platformName = 'unix']]) - ifTrue: [ - "Linux VMs don't generate shift-tab keystroke. Turn #keyUp into #keystroke" - pressType _ EventSensor eventKeyChar ] - ifFalse: [type _ #keyUp ]]. - pressType = EventSensor eventKeyChar ifTrue: [ - type _ #keystroke. - "If Control key pressed, and the VM answers a code below 27, - it means it did the translation, convert it back to regular character: - We want to handle the meaning of ctrl ourselves." - (modifiers anyMask: 2) ifTrue: [ "Control key pressed" - keyValue < 27 ifTrue: [ "But we don't want to do it for Home/End/PgUp/PgDn, just for alphabetic keys" - lastKeyDownValue = keyValue ifFalse: [ "If equal, real Home/End/PgUp/PgDn in Windows => don't translate" - (keyValue + 64 = lastKeyDownValue or: [ "If Equal, Ctrl-alphabetic in Windows => do translate" - lastKeyDownValue < 47 ]) ifTrue: [ "Not on windows. If less (not sure about the bound, but do not translate 48: tab on Mac), alphabetic on Mac => do translate" - keyValue _ (modifiers anyMask: 1) - ifTrue: [ keyValue + 64 ] - ifFalse: [ keyValue + 96 "shift not pressed: conver to lowercase letter" ]]]]. - "On Windows, ctrl-backSpace is reported as ctrl-forwardDelete. But keyDown is ok, so we can know and fix." - (keyValue = 127 and: [ lastKeyDownValue = 8 ]) - ifTrue: [ keyValue _ 8 ]. - "Act as if command/alt was pressed for some usual Windows ctrl-key combinations" - (self shouldControlEmulateAltFor: keyValue) ifTrue: [ modifiers _ modifiers bitOr: 8 ]]. - (modifiers anyMask: 8) ifTrue: [ "CmdAlt key pressed (or Control key pressed, and #shouldControlEmulateAltFor: just answered true)" - (modifiers anyMask: 1) ifTrue: [ "Shift pressed" - | i | - "It seems that for ctrl-shifted keys and cmd-shifted keys, the VM incorrectly reports the UNSHIFTED character. - Correct this, at least for common cmd-shortcuts, and for the US keyboard... Sigh... - (This has only been observed on Mac VMs, but seems harmless if proper shifted character is reported (as in Linux), as this wil be NOP) - (On Windows, the situation is even worse: ctrl-{ is not even reported as a keystroke event. Only keyDown and keyUp.)" - "#($' $, $. $9 $0 $[ $]) -> #($'' $< $> $( $) ${) $}" - i _ #[39 44 46 57 48 91 93 ] indexOf: keyValue. - i > 0 ifTrue: [ - keyValue _ #[34 60 62 40 41 123 125] at: i ]]]]. - buttons _ modifiers bitShift: 3. - "Linux and Windows VM send keyboard ctrl-upArrow and ctrl-downArrow when the user tries to scroll using the mouse wheel - Mac VM sends cmd-option-ctrl-shift-upArrow and cmd-option-ctrl-shift-downArrow for trackpad vertical scroll gestures, - and cmd-option-ctrl-shift-leftArrow and cmd-option-ctrl-shift-rightArrow for horizontal scroll gestures. - This way of reporting scroll events by the VM also enables scrolling using the keyboard (actually, we can't tell if user gesture was on Mouse, Trackpad or Keyboard). - But ctrl-shift and cmdAlt-shift are needed used for selecting while moving by word, line, etc. - Additionally, #ctrlArrowsScrollHorizontally allows chosing between keyboard horizontal scroll and moving word by word in text editors." - mouseScrollDirection _ nil. - "Ctrl for Keyboard or Mouse wheel gestures. All modifiers for Trackpad gestures." - (buttons = InputSensor controlKey or: [buttons = InputSensor cmdAltOptionCtrlShiftModifierKeys]) ifTrue: [ - keyValue = 30 - ifTrue: [mouseScrollDirection _ #up] - ifFalse: [keyValue = 31 - ifTrue: [mouseScrollDirection _ #down]]]. - "Ctrl for Keyboard or Mouse wheel gestures, only if preference is set. All modifiers for Trackpad gestures." - ((buttons = InputSensor controlKey and: [Preferences ctrlArrowsScrollHorizontally]) or: [buttons = InputSensor cmdAltOptionCtrlShiftModifierKeys]) ifTrue: [ - keyValue = 28 - ifTrue: [mouseScrollDirection _ #left] - ifFalse: [keyValue = 29 - ifTrue: [mouseScrollDirection _ #right]]]. - mouseScrollDirection ifNotNil: [ - ^ MouseScrollEvent new - setType: #mouseScroll - position: self morphPosition - direction: mouseScrollDirection - buttons: buttons - hand: self - stamp: stamp ]. - ^ KeyboardEvent new - setType: type - buttons: buttons - position: self morphPosition - keyValue: keyValue - hand: self - stamp: stamp! ! - -----End fileIn of C:\Users\Juan Vuletich\Cuis-Smalltalk\Cuis-Smalltalk-Dev\CoreUpdates\4975-KeyboardEventsFromVMBufferEnhancements-JuanVuletich-2021Nov23-09h37m-jmv.001.cs.st----! - -----QUIT----(23 November 2021 10:54:29) Cuis5.0-4975-v3.image priorSource: 9324145! \ No newline at end of file diff --git a/Cuis5.0-4975.changes b/Cuis5.0-4975.changes deleted file mode 100644 index 708889ec..00000000 --- a/Cuis5.0-4975.changes +++ /dev/null @@ -1,357301 +0,0 @@ -'From Cuis 5.0 of 7 November 2016 [latest update: #2974] on 7 November 2016 at 2:53:38 pm'! - - -----SNAPSHOT----#(7 November 2016 2:53:55.973029 pm) Cuis5.0-2974-spur.image priorSource: 0! - -----QUIT----#(7 November 2016 2:54:03.110029 pm) Cuis5.0-2974-spur.image priorSource: 92! - -----STARTUP----#(17 November 2016 12:32:23.600889 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-2974-spur.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #2974] on 16 November 2016 at 3:55:25 pm'! -!Integer class methodsFor: 'instance creation' stamp: 'jmv 11/16/2016 15:37:15' prior: 16860879! - readFrom: aStream base: base - "Answer an instance of one of my concrete subclasses. Initial minus sign - accepted, and bases > 10 use letters A-Z. Embedded radix specifiers not - allowed--use Number readFrom: for that. Answer zero (not an error) if - there are no digits." - - | digit value neg cc atLeastOneDigitRead | - neg _ aStream peekFor: $-. - neg ifFalse: [aStream peekFor: $+]. - value _ 0. - atLeastOneDigitRead _ false. - [ aStream atEnd ] - whileFalse: [ - cc _ aStream next. - digit _ cc digitValue. - (digit < 0 or: [digit >= base]) - ifTrue: [ - aStream skip: -1. - atLeastOneDigitRead ifFalse: [self error: 'At least one digit expected here']. - ^neg - ifTrue: [value negated] - ifFalse: [value]]. - value _ value * base + digit. - atLeastOneDigitRead _ true ]. - neg ifTrue: [^ value negated]. - ^ value! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2975-Integer-readFrom-cleanup-JuanVuletich-2016Nov16-15h20m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2975] on 17 November 2016 at 9:08:34 am'! -!PositionableStream methodsFor: 'accessing' stamp: 'jmv 11/17/2016 09:06:59' prior: 16891425! - 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 | - position < readLimit ifTrue: [ - ^collection at: position+1 ]. - self atEnd ifTrue: [^nil]. - nextObject _ self next. - position _ position - 1. - ^nextObject! ! -!StandardFileStream methodsFor: 'read, write, position' stamp: 'jmv 11/17/2016 09:07:20' prior: 16913380! - peek - "Answer what would be returned if the message next were sent to the receiver. If the receiver is at the end, answer nil. " - | next | - position < readLimit ifTrue: [ - ^collection at: position+1 ]. - self atEnd ifTrue: [^ nil]. - next _ self basicNext. - self position: self position - 1. - ^ next! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2976-peek-Optimization-JuanVuletich-2016Nov17-09h06m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2975] on 17 November 2016 at 9:18:37 am'! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:42'! - nextDouble64BigEndian: bigEndian - "Store the given number as a 32 bit Float on this (binary) stream. - - Float pi hex '400921FB54442D18' - Float pi negated hex 'C00921FB54442D18' - - (ByteArray streamContents: [ :strm | - strm nextDouble64Put: Float pi bigEndian: false ]) - readStream nextDouble64BigEndian: false - - (ByteArray streamContents: [ :strm | - strm nextDouble64Put: Float pi bigEndian: true ]) - readStream nextDouble64BigEndian: true - " - | bytes | - bytes _ self next: 8. - ^ bytes doubleAt: 1 bigEndian: bigEndian! ! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:40'! - nextDouble64Put: aFloat bigEndian: bigEndian - "Store the given number as a 32 bit Float on this (binary) stream. - - Float pi hex '400921FB54442D18' - Float pi negated hex 'C00921FB54442D18' - - (ByteArray streamContents: [ :strm | - strm nextDouble64Put: Float pi bigEndian: false ]) hex - - (ByteArray streamContents: [ :strm | - strm nextDouble64Put: Float pi bigEndian: true ]) hex - " - | bytes | - bytes _ ByteArray new: 8. - bytes doubleAt: 1 put: aFloat bigEndian: bigEndian. - self nextPutAll: bytes! ! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:38'! - nextFloat32BigEndian: bigEndian - "Store the given number as a 32 bit Float on this (binary) stream. - - Float pi hex '400921FB54442D18' - Float pi negated hex 'C00921FB54442D18' - Float pi asIEEE32BitWord hex '16r40490FDB' - Float pi negated asIEEE32BitWord hex '16rC0490FDB' - - (ByteArray streamContents: [ :strm | - strm nextFloat32Put: Float pi bigEndian: false ]) - readStream nextFloat32BigEndian: false - - (ByteArray streamContents: [ :strm | - strm nextFloat32Put: Float pi bigEndian: true ]) - readStream nextFloat32BigEndian: true - " - | bytes | - bytes _ self next: 4. - ^ bytes floatAt: 1 bigEndian: bigEndian! ! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:34'! - nextFloat32Put: aFloat bigEndian: bigEndian - "Store the given number as a 32 bit Float on this (binary) stream. - - Float pi hex '400921FB54442D18' - Float pi negated hex 'C00921FB54442D18' - Float pi asIEEE32BitWord hex '16r40490FDB' - Float pi negated asIEEE32BitWord hex '16rC0490FDB' - - (ByteArray streamContents: [ :strm | - strm nextFloat32Put: Float pi bigEndian: false ]) hex 'DB0F4940' - - (ByteArray streamContents: [ :strm | - strm nextFloat32Put: Float pi bigEndian: true ]) hex '40490FDB' - " - | bytes | - bytes _ ByteArray new: 4. - bytes floatAt: 1 put: aFloat bigEndian: bigEndian. - self nextPutAll: bytes! ! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:26'! - nextSignedInt16BigEndian: bigEndian - "Answer the next signed, 16-bit integer from this (binary) stream. - - (ByteArray streamContents: [ :strm | - strm nextSignedInt16Put: -12345 bigEndian: false ]) - readStream nextSignedInt16BigEndian: false - - (ByteArray streamContents: [ :strm | - strm nextSignedInt16Put: -12345 bigEndian: true ]) - readStream nextSignedInt16BigEndian: true - " - | bytes | - bytes _ self next: 2. - ^ bytes shortAt: 1 bigEndian: bigEndian! ! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:26'! - nextSignedInt16Put: aNumber bigEndian: bigEndian - "Store the given number as a signed, 16-bit integer on this (binary) stream. - - (16r10000-12345) hex '16rCFC7' - - (ByteArray streamContents: [ :strm | - strm nextSignedInt16Put: -12345 bigEndian: false ]) hex - - (ByteArray streamContents: [ :strm | - strm nextSignedInt16Put: -12345 bigEndian: true ]) hex - " - | bytes | - bytes _ ByteArray new: 2. - bytes shortAt: 1 put: aNumber bigEndian: bigEndian. - self nextPutAll: bytes! ! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:26'! -nextSignedInt32BigEndian: bigEndian - "Answer the next signed, 32-bit integer from this (binary) stream. - - (ByteArray streamContents: [ :strm | - strm nextSignedInt32Put: -123456 bigEndian: false ]) - readStream nextSignedInt32BigEndian: false - - (ByteArray streamContents: [ :strm | - strm nextSignedInt32Put: -123456 bigEndian: true ]) - readStream nextSignedInt32BigEndian: true - " - | bytes | - bytes _ self next: 4. - ^ bytes longAt: 1 bigEndian: bigEndian! ! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:27'! - nextSignedInt32Put: aNumber bigEndian: bigEndian - "Store the given number as a signed, 32-bit integer on this (binary) stream. - - (16r100000000-123456) hex '16rFFFE1DC0' - - (ByteArray streamContents: [ :strm | - strm nextSignedInt32Put: -123456 bigEndian: false ]) hex - - (ByteArray streamContents: [ :strm | - strm nextSignedInt32Put: -123456 bigEndian: true ]) hex - " - | bytes | - bytes _ ByteArray new: 4. - bytes longAt: 1 put: aNumber bigEndian: bigEndian. - self nextPutAll: bytes! ! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:18'! - nextUnsignedInt16BigEndian: bigEndian - "Answer the next unsigned, 16-bit integer from this (binary) stream. - - (ByteArray streamContents: [ :strm | - strm nextUnsignedInt16Put: 12345 bigEndian: false ]) - readStream nextUnsignedInt16BigEndian: false - - (ByteArray streamContents: [ :strm | - strm nextUnsignedInt16Put: 12345 bigEndian: true ]) - readStream nextUnsignedInt16BigEndian: true - " - | bytes | - bytes _ self next: 2. - ^ bytes unsignedShortAt: 1 bigEndian: bigEndian! ! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:27'! - nextUnsignedInt16Put: aNumber bigEndian: bigEndian - "Store the given number as a unsigned, 16-bit integer on this (binary) stream. - - 12345 hex '16r3039' - - (ByteArray streamContents: [ :strm | - strm nextUnsignedInt16Put: 12345 bigEndian: false ]) hex - - (ByteArray streamContents: [ :strm | - strm nextUnsignedInt16Put: 12345 bigEndian: true ]) hex - " - | bytes | - bytes _ ByteArray new: 2. - bytes unsignedShortAt: 1 put: aNumber bigEndian: bigEndian. - self nextPutAll: bytes! ! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:19'! - nextUnsignedInt32BigEndian: bigEndian - "Answer the next unsigned, 32-bit integer from this (binary) stream. - - (ByteArray streamContents: [ :strm | - strm nextUnsignedInt32Put: 123456 bigEndian: false ]) - readStream nextUnsignedInt32BigEndian: false - - (ByteArray streamContents: [ :strm | - strm nextUnsignedInt32Put: 123456 bigEndian: true ]) - readStream nextUnsignedInt32BigEndian: true - " - | bytes | - bytes _ self next: 4. - ^ bytes unsignedLongAt: 1 bigEndian: bigEndian! ! -!Stream methodsFor: 'normalized access' stamp: 'jmv 2/25/2016 11:27'! - nextUnsignedInt32Put: aNumber bigEndian: bigEndian - "Store the given number as a unsigned, 32-bit integer on this (binary) stream. - - 123456 hex '16r1E240' - - (ByteArray streamContents: [ :strm | - strm nextUnsignedInt32Put: 123456 bigEndian: false ]) hex - - (ByteArray streamContents: [ :strm | - strm nextUnsignedInt32Put: 123456 bigEndian: true ]) hex - " - | bytes | - bytes _ ByteArray new: 4. - bytes unsignedLongAt: 1 put: aNumber bigEndian: bigEndian. - self nextPutAll: bytes! ! -!Stream methodsFor: 'nonhomogeneous accessing' stamp: 'jmv 6/14/2013 20:02'! - nextNumber - "Answer a number from the stream." - - |element| - [(element := self next) isNil or: [element isDigit or: [element = $- or: [element = $)]]]] whileFalse. - element ifNil: [^nil]. - self skip: -1. - element = $) ifTrue: [^nil]. - ^Number readFrom: self! ! -!Stream methodsFor: 'nonhomogeneous accessing' stamp: 'jmv 2/29/2016 11:04'! - nextNumber: n - "Answer the next n bytes as a positive Integer or LargePositiveInteger. - Currently only for bigEndian. Consider following the convention in category 'normalized access'" - | s | - s _ 0. - 1 to: n do: - [:i | s _ (s bitShift: 8) bitOr: self next asInteger]. - ^ s normalize! ! -!Stream methodsFor: 'nonhomogeneous accessing' stamp: 'jmv 2/29/2016 11:04'! - 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. - Currently only for bigEndian. Consider following the convention in category 'normalized access'" - - 1 to: n do: [:i | self nextPut: (v digitAt: n+1-i)]. - ^ v -! ! -!Stream methodsFor: 'nonhomogeneous accessing' stamp: 'ls 9/14/1998 22:46'! - 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)." - - | aString length | - - "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]]. - aString _ String new: length. - - "read the characters in ASCII mode" - self ascii. - self nextInto: aString. - ^aString! ! -!Stream methodsFor: 'nonhomogeneous accessing' stamp: 'yo 4/16/2001 17:56'! - 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! ! - -DummyStream removeSelector: #nextDouble64BigEndian:! - -DummyStream removeSelector: #nextDouble64BigEndian:! - -DummyStream removeSelector: #nextDouble64Put:bigEndian:! - -DummyStream removeSelector: #nextDouble64Put:bigEndian:! - -DummyStream removeSelector: #nextNumber:put:! - -DummyStream removeSelector: #nextNumber:put:! - -DummyStream removeSelector: #nextSignedInt16BigEndian:! - -DummyStream removeSelector: #nextSignedInt16BigEndian:! - -DummyStream removeSelector: #nextSignedInt16Put:bigEndian:! - -DummyStream removeSelector: #nextSignedInt16Put:bigEndian:! - -DummyStream removeSelector: #nextSignedInt32BigEndian:! - -DummyStream removeSelector: #nextSignedInt32BigEndian:! - -DummyStream removeSelector: #nextSignedInt32Put:bigEndian:! - -DummyStream removeSelector: #nextSignedInt32Put:bigEndian:! - -DummyStream removeSelector: #nextStringPut:! - -DummyStream removeSelector: #nextStringPut:! - -DummyStream removeSelector: #nextUnsignedInt16BigEndian:! - -DummyStream removeSelector: #nextUnsignedInt16BigEndian:! - -DummyStream removeSelector: #nextUnsignedInt16Put:bigEndian:! - -DummyStream removeSelector: #nextUnsignedInt16Put:bigEndian:! - -DummyStream removeSelector: #nextUnsignedInt32BigEndian:! - -DummyStream removeSelector: #nextUnsignedInt32BigEndian:! - -DummyStream removeSelector: #nextUnsignedInt32Put:bigEndian:! - -DummyStream removeSelector: #nextUnsignedInt32Put:bigEndian:! - -DataStream removeSelector: #readStringOld! - -DataStream removeSelector: #readStringOld! - -PositionableStream removeSelector: #nextDouble64BigEndian:! - -PositionableStream removeSelector: #nextDouble64BigEndian:! - -PositionableStream removeSelector: #nextDouble64Put:bigEndian:! - -PositionableStream removeSelector: #nextDouble64Put:bigEndian:! - -PositionableStream removeSelector: #nextFloat32BigEndian:! - -PositionableStream removeSelector: #nextFloat32BigEndian:! - -PositionableStream removeSelector: #nextFloat32Put:bigEndian:! - -PositionableStream removeSelector: #nextFloat32Put:bigEndian:! - -PositionableStream removeSelector: #nextNumber! - -PositionableStream removeSelector: #nextNumber! - -PositionableStream removeSelector: #nextNumber:! - -PositionableStream removeSelector: #nextNumber:! - -PositionableStream removeSelector: #nextNumber:put:! - -PositionableStream removeSelector: #nextNumber:put:! - -PositionableStream removeSelector: #nextSignedInt16BigEndian:! - -PositionableStream removeSelector: #nextSignedInt16BigEndian:! - -PositionableStream removeSelector: #nextSignedInt16Put:bigEndian:! - -PositionableStream removeSelector: #nextSignedInt16Put:bigEndian:! - -PositionableStream removeSelector: #nextSignedInt32BigEndian:! - -PositionableStream removeSelector: #nextSignedInt32BigEndian:! - -PositionableStream removeSelector: #nextSignedInt32Put:bigEndian:! - -PositionableStream removeSelector: #nextSignedInt32Put:bigEndian:! - -PositionableStream removeSelector: #nextString! - -PositionableStream removeSelector: #nextString! - -PositionableStream removeSelector: #nextStringOld! - -PositionableStream removeSelector: #nextStringOld! - -PositionableStream removeSelector: #nextStringPut:! - -PositionableStream removeSelector: #nextStringPut:! - -PositionableStream removeSelector: #nextUnsignedInt16BigEndian:! - -PositionableStream removeSelector: #nextUnsignedInt16BigEndian:! - -PositionableStream removeSelector: #nextUnsignedInt16Put:bigEndian:! - -PositionableStream removeSelector: #nextUnsignedInt16Put:bigEndian:! - -PositionableStream removeSelector: #nextUnsignedInt32BigEndian:! - -PositionableStream removeSelector: #nextUnsignedInt32BigEndian:! - -PositionableStream removeSelector: #nextUnsignedInt32Put:bigEndian:! - -PositionableStream removeSelector: #nextUnsignedInt32Put:bigEndian:! - -Stream removeSelector: #nextStringOld! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2977-Stream-refactor-JuanVuletich-2016Nov17-09h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2977] on 17 November 2016 at 10:29:07 am'! -!PositionableStream methodsFor: 'testing' stamp: 'jmv 11/17/2016 10:28:06' prior: 16891536! - atEnd - "Answer whether the receiver can access any more objects." - - ^position >= readLimit! ! -!ReadStream methodsFor: 'accessing' stamp: 'jmv 11/17/2016 09:59:57' prior: 16897965! - next - "Answer the next object in the Stream represented by the receiver." - - ^position >= readLimit - ifFalse: [collection at: (position _ position + 1)]! ! -!WriteStream methodsFor: 'accessing' stamp: 'jmv 11/17/2016 10:28:35' prior: 16946385! - nextPut: anObject - "Insert the argument at the next position in the Stream represented by the receiver." - - position >= writeLimit - ifTrue: [^ self pastEndPut: anObject] - ifFalse: [ - position _ position + 1. - ^collection at: position put: anObject]! ! -!ReadWriteStream methodsFor: 'accessing' stamp: 'jmv 11/17/2016 10:28:45' prior: 16898094! - next - "Return the next object in the Stream represented by the receiver." - - "treat me as a FIFO" - ^ position >= readLimit - ifFalse: [collection at: (position _ position + 1)]! ! -!StandardFileStream methodsFor: 'read, write, position' stamp: 'jmv 11/17/2016 10:00:56' prior: 16913098! - basicNext - "Answer the next byte from this file, or nil if at the end of the file." - - | count | - collection ifNotNil: [ - position < readLimit - ifFalse: [ - readLimit := self primRead: fileID into: collection startingAt: 1 count: collection size. - position := 0. - readLimit = 0 ifTrue: [ ^nil ] ]. - ^collection at: (position := position + 1) ]. - count _ self primRead: fileID into: buffer1 startingAt: 1 count: 1. - ^count = 1 - ifTrue: [ buffer1 at: 1 ]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2978-RemoveObsoletePrimCalls-JuanVuletich-2016Nov17-10h26m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2977] on 17 November 2016 at 10:31:18 am'! - -Stream subclass: #StdIOReadStream - instanceVariableNames: 'fileID name buffer1' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #StdIOReadStream category: #'System-Support'! -Stream subclass: #StdIOReadStream - instanceVariableNames: 'fileID name buffer1' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! -!StdIOReadStream commentStamp: '' prior: 0! - Standard Input Stream. - -A basic problem/restriction with this code is that currently the VM runs multiple VM threads within a single OS thread. - -This means that waiting on StdIn blocks the VM, suspending all Smalltalk code.! - -Stream subclass: #StdIOWriteStream - instanceVariableNames: 'fileID name buffer1 collection readLimit position' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #StdIOWriteStream category: #'System-Support'! -Stream subclass: #StdIOWriteStream - instanceVariableNames: 'fileID name buffer1 collection readLimit position' - classVariableNames: '' - poolDictionaries: '' - category: 'System-Support'! -!StdIOWriteStream commentStamp: '' prior: 0! - Standard Output/Error Streams.! -!StdIOReadStream methodsFor: 'open / close' stamp: 'jmv 11/17/2016 10:12:24'! - openOnHandle: aFileID name: streamName - "Initialize the instance with the given file handle. - N.B. Do _not_ register the stream. We do not want it to be - closed implicitly (e.g. on GC). There may be multiple instances - accessing the same stream. The stream is not a file." - - fileID _ aFileID. - name _ streamName. - buffer1 _ String new: 1! ! -!StdIOReadStream methodsFor: 'streaming' stamp: 'jmv 11/17/2016 10:01:57'! - next - "Answer the next byte from this stream, or wait until one becomes available. - Warning: all Smalltalk processes are essentially suspended until that happens!!" - - | count | - count _ self primRead: fileID into: buffer1 startingAt: 1 count: 1. - ^count = 1 - ifTrue: [ buffer1 at: 1 ]! ! -!StdIOReadStream methodsFor: 'printing' stamp: 'jmv 11/17/2016 09:47:10'! - printOn: aStream - "Put a printed version of the receiver onto aStream." - - aStream nextPutAll: self class name; nextPutAll: ': '; print: name! ! -!StdIOReadStream methodsFor: 'primitives' stamp: 'jmv 11/17/2016 09:45:28'! - primRead: id into: byteArray startingAt: startIndex count: count - "Read up to count bytes of data from this file into the given string or byte array starting at the given index. Answer the number of bytes actually read." - - - self error: 'File read failed'! ! -!StdIOReadStream class methodsFor: 'instance creation' stamp: 'jmv 11/17/2016 09:46:36'! - stdin - | newSelf | - newSelf _ self basicNew. - newSelf - openOnHandle: self stdinHandle - name: 'stdin'. - ^newSelf! ! -!StdIOReadStream class methodsFor: 'accessing' stamp: 'jmv 11/17/2016 09:26:47'! - stdinHandle - - ^ StdIOWriteStream stdioHandles at: 1! ! -!StdIOWriteStream methodsFor: 'open / close' stamp: 'jmv 11/17/2016 10:14:32'! - openOnHandle: aFileID name: streamName - "Initialize the instance with the given file handle. - N.B. Do _not_ register the stream. We do not want it to be - closed implicitly (e.g. on GC). There may be multiple instances - accessing the same stream. The stream is not a file." - - fileID _ aFileID. - name _ streamName. - buffer1 _ String new: 1! ! -!StdIOWriteStream methodsFor: 'streaming' stamp: 'jmv 11/17/2016 10:19:51'! - flush - "Flush pending changes" - ^self primFlush: fileID! ! -!StdIOWriteStream methodsFor: 'streaming' stamp: 'jmv 11/17/2016 10:18:42'! - nextPut: char - "Write the given character to this file." - - buffer1 at: 1 put: char. - self primWrite: fileID from: buffer1 startingAt: 1 count: 1. - ^ char -! ! -!StdIOWriteStream methodsFor: 'printing' stamp: 'jmv 11/17/2016 09:35:56'! - printOn: aStream - "Put a printed version of the receiver onto aStream. 1/31/96 sw" - - aStream nextPutAll: self class name; nextPutAll: ': '; print: name! ! -!StdIOWriteStream methodsFor: 'primitives' stamp: 'jmv 11/17/2016 10:20:17'! - primFlush: id - "Flush pending changes to the disk" - - ! ! -!StdIOWriteStream methodsFor: 'primitives' stamp: 'jmv 11/17/2016 10:19:14'! - primWrite: id from: stringOrByteArray startingAt: startIndex count: count - "Write count bytes onto this file from the given string or byte array starting at the given index. Answer the number of bytes written." - - - (FileWriteError fileName: name) - signal: (self closed - ifTrue: [ 'File [', name, '] is closed' ] - ifFalse: [ 'File [', name, '] write failed' ])! ! -!StdIOWriteStream class methodsFor: 'instance creation' stamp: 'jmv 11/17/2016 10:15:08'! -stderr - | newSelf | - newSelf _ self basicNew. - newSelf - openOnHandle: self stderrHandle - name: 'stderr'. - ^newSelf! ! -!StdIOWriteStream class methodsFor: 'instance creation' stamp: 'jmv 11/17/2016 10:15:11'! - stdout - | newSelf | - newSelf _ self basicNew. - newSelf - openOnHandle: self stdoutHandle - name: 'stdout'. - ^newSelf! ! -!StdIOWriteStream class methodsFor: 'accessing' stamp: 'jmv 11/17/2016 09:26:20'! - stderrHandle - - ^ self stdioHandles at: 3! ! -!StdIOWriteStream class methodsFor: 'accessing' stamp: 'jmv 11/17/2016 09:26:09'! - stdioHandles -" answer handles: #(stdin stdout stderr) " - - self primitiveFailed! ! -!StdIOWriteStream class methodsFor: 'accessing' stamp: 'jmv 11/17/2016 09:26:12'! - stdoutHandle - - ^ self stdioHandles at: 2! ! - -Smalltalk removeClassNamed: #StdIOFileStream! - -Smalltalk removeClassNamed: #StdIOFileStream! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2979-NewStdIO-JuanVuletich-2016Nov17-10h29m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2979] on 17 November 2016 at 10:51:20 am'! -!StdIOWriteStream methodsFor: 'character writing' stamp: 'jmv 11/17/2016 10:48:18'! - newLine - "Append a newLine character to the receiver. - The Cuis convention is to use lf on output." - - self nextPut: Character newLineCharacter! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2980-stdout-newLine-JuanVuletich-2016Nov17-10h48m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2980] on 17 November 2016 at 11:51:03 am'! - -Stream subclass: #StdIOReadStream - instanceVariableNames: 'fileID name buffer1 peeked ' - classVariableNames: 'StdIn ' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #StdIOReadStream category: #'System-Support'! -Stream subclass: #StdIOReadStream - instanceVariableNames: 'fileID name buffer1 peeked' - classVariableNames: 'StdIn' - poolDictionaries: '' - category: 'System-Support'! - -Stream subclass: #StdIOWriteStream - instanceVariableNames: 'fileID name buffer1 collection readLimit position ' - classVariableNames: 'StdOut StdErr ' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #StdIOWriteStream category: #'System-Support'! -Stream subclass: #StdIOWriteStream - instanceVariableNames: 'fileID name buffer1 collection readLimit position' - classVariableNames: 'StdErr StdOut' - poolDictionaries: '' - category: 'System-Support'! -!StdIOReadStream methodsFor: 'streaming' stamp: 'jmv 11/17/2016 11:28:43'! - peek - "Answer the next byte from this stream, or wait until one becomes available. - Warning: all Smalltalk processes are essentially suspended until that happens!! - - Do not advance the stream!!" - - "Multiple calls to #peek don't make new reads" - peeked ifFalse: [ - self privateRead. - peeked _ true ]. - - "peeked is always true on exit" - ^buffer1 at: 1! ! -!StdIOReadStream methodsFor: 'streaming' stamp: 'jmv 11/17/2016 11:33:22'! - peekFor: aCharacter - "Answer false and do not move over the next element if it is not equal to the argument, aCharacter - Answer true and increment the position for accessing elements, if the next element is equal to anObject." - - | nextChar | - nextChar _ self peek. - aCharacter = nextChar ifTrue: [ - self next. - ^ true]. - ^ false! ! -!StdIOReadStream methodsFor: 'streaming' stamp: 'jmv 11/17/2016 11:24:52'! - privateRead - "Read one Character. - Private." - | count | - count _ self primRead: fileID into: buffer1 startingAt: 1 count: 1. - count = 1 ifFalse: [ buffer1 at: 1 put: nil ]! ! -!StdIOReadStream class methodsFor: 'cached state access' stamp: 'jmv 11/17/2016 11:45:00'! - releaseClassCachedState - - StdIn _ nil! ! -!StdIOWriteStream methodsFor: 'character writing' stamp: 'jmv 11/17/2016 11:08:02'! - space - "Append a space character to the receiver." - - self nextPut: Character space! ! -!StdIOWriteStream class methodsFor: 'cached state access' stamp: 'jmv 11/17/2016 11:44:50'! - releaseClassCachedState - - StdOut _ nil. - StdErr _ nil! ! -!StdIOReadStream methodsFor: 'open / close' stamp: 'jmv 11/17/2016 11:13:30' prior: 50332252! - openOnHandle: aFileID name: streamName - "Initialize the instance with the given file handle. - N.B. Do _not_ register the stream. We do not want it to be - closed implicitly (e.g. on GC). There may be multiple instances - accessing the same stream. The stream is not a file." - - fileID _ aFileID. - name _ streamName. - buffer1 _ String new: 1. - peeked _ false! ! -!StdIOReadStream methodsFor: 'streaming' stamp: 'jmv 11/17/2016 11:28:44' prior: 50332266! - next - "Answer the next byte from this stream, or wait until one becomes available. - Warning: all Smalltalk processes are essentially suspended until that happens!!" - - "If last call was #peek, not #next, then just answer cached value." - peeked - ifFalse: [ self privateRead ] - ifTrue: [ peeked _ false ]. - - "peeked is always false on exit" - ^buffer1 at: 1! ! -!StdIOReadStream class methodsFor: 'instance creation' stamp: 'jmv 11/17/2016 11:45:39' prior: 50332298! - stdin - StdIn ifNil: [ - StdIn _ self basicNew. - StdIn - openOnHandle: self stdinHandle - name: 'stdin' ]. - ^StdIn! ! -!StdIOWriteStream class methodsFor: 'instance creation' stamp: 'jmv 11/17/2016 11:46:13' prior: 50332367! - stderr - StdErr ifNil: [ - StdErr _ self basicNew. - StdErr - openOnHandle: self stderrHandle - name: 'stderr' ]. - ^StdErr! ! -!StdIOWriteStream class methodsFor: 'instance creation' stamp: 'jmv 11/17/2016 11:46:37' prior: 50332374! - stdout - StdOut ifNil: [ - StdOut _ self basicNew. - StdOut - openOnHandle: self stdoutHandle - name: 'stdout' ]. - ^StdOut! ! - -Stream subclass: #StdIOReadStream - instanceVariableNames: 'fileID name buffer1 peeked' - classVariableNames: 'StdIn' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #StdIOReadStream category: #'System-Support'! -Stream subclass: #StdIOReadStream - instanceVariableNames: 'fileID name buffer1 peeked' - classVariableNames: 'StdIn' - poolDictionaries: '' - category: 'System-Support'! - -Stream subclass: #StdIOWriteStream - instanceVariableNames: 'fileID name buffer1' - classVariableNames: 'StdErr StdOut' - poolDictionaries: '' - category: 'System-Support'! - -!classDefinition: #StdIOWriteStream category: #'System-Support'! -Stream subclass: #StdIOWriteStream - instanceVariableNames: 'fileID name buffer1' - classVariableNames: 'StdErr StdOut' - poolDictionaries: '' - category: 'System-Support'! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2981-StdIn-peek-peekFor-JuanVuletich-2016Nov17-11h08m-jmv.1.cs.st----! - -----SNAPSHOT----#(17 November 2016 12:32:56.842092 pm) Cuis5.0-2981-spur.image priorSource: 186! - -----QUIT----#(17 November 2016 12:33:29.990717 pm) Cuis5.0-2981-spur.image priorSource: 29844! - -----STARTUP----#(14 December 2016 2:31:49.510252 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-2981-spur.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #2981] on 17 November 2016 at 5:11:35 pm'! -!SequenceableCollection methodsFor: 'copying' stamp: 'jmv 11/17/2016 17:08:04' prior: 16906186! - copyReplaceFrom: start to: stop with: replacementCollection - "Answer a copy of the receiver satisfying the following conditions: - + 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! ! -!SHTextStylerST80 methodsFor: 'private' stamp: 'jmv 11/17/2016 16:54:39' prior: 16903350! - setAttributesFromRanges: ranges - - formattedText removeAttributesThat: [ :attribute | attribute isForShout ]. - - "Optimize for mutation speed unless method is really large but with very few distict elements: - Source code that includes just big literals is better served by conventional Text+RunArray" - "Do it only if we are not breaking textModel!! (for instance, StyledTextEditor asks for formatting just sections, not whole #actualContents)." - formattedText == textModel actualContents ifTrue: [ - (formattedText size > 2000 and: [ ranges size < 50 ]) ifFalse: [ - formattedText _ formattedText optimizedForMutationSpeed. - textModel basicActualContents: formattedText ]]. - - ranges do: [ :range | - - "Smalltalk text styling" - (self attributesFor: range rangeType) ifNotNil: [ :attributes | - attributes do: [ :each | - formattedText addAttribute: each from: range start to: range end ]]. - - "Show as subscripts if appropriate." - (classOrMetaClass isNil or: [ - classOrMetaClass theNonMetaClass lastUnderscoreMeansSubscript]) ifTrue: [ - (#( instVar classVar globalVar workspaceVar poolConstant - patternArg methodArg patternTempVar tempVar - blockPatternArg blockArg blockPatternTempVar blockTempVar - incompleteIdentifier undefinedIdentifier) pointsTo: range rangeType ) - ifTrue: [ - formattedText lastIndexOf: $_ startingAt: range end endingAt: range start do: [ :i | - formattedText addAttribute: ShoutTextEmphasis subscript from: i to: range end ] ]]]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2982-CodeColorizerFix-JuanVuletich-2016Nov17-17h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2981] on 17 November 2016 at 5:18:27 pm'! -!DummyStream methodsFor: 'as yet unclassified' stamp: 'KenD 11/5/2016 16:17:09'! - space! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2983-DummyStream-space-KenDickey-2016Nov17-17h18m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2981] on 18 November 2016 at 10:49:39 am'! -!TheWorldMenu methodsFor: 'construction' stamp: 'jmv 5/3/2015 10:19' prior: 16935004! - newMorph - "The user requested 'new morph' from the world menu. Put up a menu that allows many ways of obtaining new morphs. If the preference #classicNewMorphMenu is true, the full form of yore is used; otherwise, a much shortened form is used." - | menu subMenu catDict shortCat class | - menu _ self menu: 'Add a new morph'. - menu - - add: 'From Clipboard' - target: myHand - action: #pasteMorph; - - add: 'From Alphabetical List' - subMenu: self alphabeticalMorphMenu. - menu addLine. - - "Add 'Classic' New Morph menu" - catDict _ Dictionary new. - SystemOrganization categories do: [ :cat | - ((cat beginsWith: 'Morphic-') and: [ (#('Morphic-Menus' 'Morphic-Support' ) includes: cat) not ]) ifTrue: [ - shortCat _ (cat - copyFrom: 'Morphic-' size + 1 - to: cat size). - (SystemOrganization listAtCategoryNamed: cat) do: [ :cName | - class _ Smalltalk at: cName. - ((class inheritsFrom: Morph) and: [ class includeInNewMorphMenu ]) ifTrue: [ - (catDict includesKey: shortCat) - ifTrue: [ (catDict at: shortCat) addLast: class ] - ifFalse: [ - catDict - at: shortCat - put: (OrderedCollection with: class) ]]]]]. - catDict keys sort do: [ :categ | - subMenu _ MenuMorph new. - ((catDict at: categ) asArray sort: [ :c1 :c2 | - c1 name < c2 name ]) do: [ :cl | - subMenu - add: cl name - target: self - selector: #newMorphOfClass:event: - argument: cl ]. - menu - add: categ - subMenu: subMenu ]. - - self doPopUp: menu.! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2984-NewMorphMenuFix-JuanVuletich-2016Nov18-10h34m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2984] on 30 November 2016 at 2:56:21 pm'! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'jmv 11/30/2016 14:52:08'! - with: otherCollection with: thirdCollection collect: threeArgBlock - "Collect and return the result of evaluating twoArgBlock with corresponding elements from this collection and otherCollection." - | n result | - n _ self size. - otherCollection size = n ifFalse: [ self error: 'otherCollection must be the same size' ]. - thirdCollection size = n ifFalse: [ self error: 'thirdCollection must be the same size' ]. - result _ self species new: n. - 1 to: n do: [ :index | - result at: index put: - (threeArgBlock - value: (self at: index) - value: (otherCollection at: index) - value: (thirdCollection at: index) )]. - ^ result! ! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'jmv 11/25/2016 12:15:27'! - with: otherCollection with: thirdCollection do: threeArgBlock - "Evaluate twoArgBlock with corresponding elements from this collection and otherCollection." - | n | - n _ self size. - otherCollection size = n ifFalse: [self error: 'otherCollection must be the same size']. - thirdCollection size = n ifFalse: [self error: 'thirdCollection must be the same size']. - 1 to: n do: [ :index | - threeArgBlock - value: (self at: index) - value: (otherCollection at: index) - value: (thirdCollection at: index)]! ! -!OrderedCollection methodsFor: 'enumerating' stamp: 'jmv 11/30/2016 14:51:19'! - with: otherCollection with: thirdCollection collect: threeArgBlock - "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: - (threeArgBlock - value: (self at: index) - value: (otherCollection at: index) - value: (thirdCollection at: index) )]. - ^ result! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2985-withwithdo-withwithdcollect-JuanVuletich-2016Nov30-14h47m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2984] on 30 November 2016 at 3:22:11 pm'! -!SequenceableCollection methodsFor: 'math functions' stamp: 'jmv 11/30/2016 15:04:11'! - += anObject - ^anObject isNumber - ifTrue: [ self replace: [ :v | v + anObject ]] - ifFalse: [ - self withIndexDo: [ :v :i | - self at: i put: ((self at: i) + (anObject at: i)) ]]! ! -!SequenceableCollection methodsFor: 'math functions' stamp: 'jmv 11/25/2016 11:41:25'! - -= anObject - ^anObject isNumber - ifTrue: [ self replace: [ :v | v - anObject ]] - ifFalse: [ - self withIndexDo: [ :v :i | - self at: i put: ((self at: i) - (anObject at: i)) ]]! ! -!SequenceableCollection methodsFor: 'math functions' stamp: 'jmv 11/30/2016 15:21:00'! - derivative - | displaced answer | - displaced _ self class new: self size. - displaced replaceFrom: 2 to: self size with: self startingAt: 1. - displaced at: 1 put: self first - self first. "Some reasonable zero" - answer _ self copy. - answer -= displaced. - ^answer! ! -!SequenceableCollection methodsFor: 'math functions' stamp: 'jmv 11/29/2016 14:23:32'! - integral - | answer | - answer _ self copy. - 2 to: answer size do: [ :i | - answer at: i put: (answer at: i) + (answer at: i-1) ]. - ^answer! ! - -FloatArray removeSelector: #derivative! - -FloatArray removeSelector: #derivative! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2986-Collection-derivative-integral-JuanVuletich-2016Nov30-14h56m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2974] on 26 November 2016 at 8:42:22 am'! -!HaloMorph methodsFor: 'stepping' stamp: 'len 7/25/2016 21:39'! - step - (target isNil or: [target isInWorld not]) ifTrue: [self delete]! ! -!HaloMorph methodsFor: 'stepping' stamp: 'len 7/25/2016 21:41'! - stepTime - ^ 100! ! -!HaloMorph methodsFor: 'stepping' stamp: 'len 7/25/2016 21:38'! - wantsSteps - ^ true! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2987-DeleteHaloWhenMorphIsDeleted-LucianoEstebanNotarfrancesco-2016Nov26-08h41m-len.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2974] on 26 November 2016 at 8:46:53 am'! -!MenuMorph methodsFor: 'keyboard control' stamp: 'len 6/11/2016 20:40' prior: 16867064! - keyboardFocusChange: aBoolean - "Notify change due to green border for keyboard focus" - - aBoolean ifFalse: [self deleteIfPopUp: nil]. - self redrawNeeded! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2988-AvoidManuesHangingAround-LucianoEstebanNotarfrancesco-2016Nov26-08h42m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2974] on 26 November 2016 at 8:52:37 am'! -!SequenceableCollection methodsFor: 'copying' stamp: 'len 4/18/2016 22:08'! - shuffledBy: aGenerator - "To answer a mutable collection when receiver is, for example, an Interval." - ^ (self collect: [ :each | each ]) shuffleBy: aGenerator! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2989-ShuffledBy-LucianoEstebanNotarfrancesco-2016Nov26-08h46m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2974] on 26 November 2016 at 9:02:48 am'! -!SystemDictionary methodsFor: 'browsing' stamp: 'len 6/9/2016 23:23'! - browseAllPrimitives - self browseAllSelect: [:each| each primitive ~= 0 and: [(each primitive between: 256 and: 291) not]] -! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2990-SmalltalkBrowseAllPrimitives-LucianoEstebanNotarfrancesco-2016Nov26-08h52m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2974] on 26 November 2016 at 9:03:51 am'! -!SystemDictionary methodsFor: 'retrieving' stamp: 'len 11/26/2016 09:03:25' prior: 16921461! - allCallsOn: aLiteral "Smalltalk browseAllCallsOn: #open:label:." - "Answer a Collection of all the methods that call on aLiteral." - | aCollection special aList byte | - - #(23 48 'fred' (new open:label:)) size. -"Example above should find #open:label:, though it is deeply embedded here." - - aCollection _ OrderedCollection new. - special _ self hasSpecialSelector: aLiteral ifTrueSetByte: [:b | byte _ b ]. - self allBehaviorsDo: [:class | - aList _ class whichSelectorsReferTo: aLiteral special: special byte: byte. - aList do: [ :sel | - "For special selectors, look for the literal in the source code. - Otherwise, for example, searching for senders of #== will include senders of #ifNil. - Except for #at:put:, because it has two arguments and won't find it in the source code like that." - (byte isNil or: [aLiteral = #at:put: or: [ - ((class sourceCodeAt: sel) - findString: aLiteral) > 0]]) ifTrue: [ - - aCollection add: ( - MethodReference new - setStandardClass: class - methodSymbol: sel - ) - ] - ] - ]. - ^ aCollection! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2991-SendersOfatput-LucianoEstebanNotarfrancesco-2016Nov26-09h02m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2974] on 26 November 2016 at 9:06:05 am'! -!String methodsFor: 'testing' stamp: 'len 11/26/2016 09:05:35'! - isAlphaNumeric - "Answer true if the receiver contains only letters or digits." - ^ self allSatisfy: [:each| each isAlphaNumeric]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2992-StringisAlphaNumeric-LucianoEstebanNotarfrancesco-2016Nov26-09h03m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2974] on 26 November 2016 at 9:08:39 am'! -!Form methodsFor: 'fileIn/Out' stamp: 'len 8/1/2016 08:13' prior: 16847779! - printOn: aStream - aStream isText - ifTrue: - [aStream withAttribute: (TextAnchor new anchoredFormOrMorph: self) do: [aStream nextPut: $*]. - ^ self]. - aStream - nextPutAll: self class name; - nextPut: $(; print: width; - nextPut: $x; print: height; - nextPut: $x; print: depth; - nextPut: $)! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2993-FormPrintOnTextForWorkspaces-LucianoEstebanNotarfrancesco-2016Nov26-09h06m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2993] on 5 December 2016 at 8:17:22 am'! -!Morph methodsFor: 'printing' stamp: 'jmv 12/5/2016 08:16:19' prior: 16876467! - printOn: aStream - "Add the identity of the receiver to a stream" - aStream isText - ifTrue: [ - aStream - withAttribute: (TextAnchor new anchoredFormOrMorph: (owner ifNil: [self] ifNotNil: [self imageForm:32])) - do: [ aStream nextPut: $* ]. - ^ self]. - super printOn: aStream. "a(n) className" - aStream - nextPut: $(; - print: self identityHash; - nextPut: $). - self valueOfProperty: #morphName ifPresentDo: [ :x | aStream nextPutAll: x asString]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2994-MorphPrintOnTextEnh-JuanVuletich-2016Dec05-08h16m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2994] on 5 December 2016 at 9:46:02 am'! -!Integer methodsFor: 'comparing' stamp: 'len 12/5/2016 09:46:00' prior: 16859447! - hash - "Hash is reimplemented because = is implemented. - | s | - s _ (1 to: 10000) asSet. - [s includes: 123456] bench - " - - ^self hashMultiply! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - -Set rehashAllSets! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2995-Integer-hash-LucianoEstebanNotarfrancesco-2016Dec05-09h39m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2986] on 2 December 2016 at 4:40:51 pm'! -!Form methodsFor: 'scaling, rotation' stamp: 'jmv 12/2/2016 15:47:08' prior: 16848280! - flippedBy: direction - "Return a copy of the receiver flipped either #vertical, #horizontal or #both. (#both is a 180 degrees rotation) - Form lena display. - (Form lena flippedBy: #vertical) display. - (Form lena flippedBy: #horizontal) display. - (Form lena flippedBy: #both) display. - " - | newForm quad | - newForm _ self class extent: self extent depth: depth. - quad _ self boundingBox innerCorners. - quad _ ( - direction caseOf: { - [ #vertical ] -> [#(2 1 4 3)]. - [ #horizontal ] -> [#(4 3 2 1)]. - [ #both ] -> [#(3 4 1 2)]}) - collect: [:i | quad at: i]. - (WarpBlt toForm: newForm) - sourceForm: self; - colorMap: (self colormapIfNeededFor: newForm); - combinationRule: 3; - copyQuad: quad toRect: newForm boundingBox. -" newForm offset: (self offset flippedBy: direction centerAt: aPoint)." - ^ newForm -" -[Sensor isAnyButtonPressed] whileFalse: - [((Form fromDisplay: (Sensor mousePoint extent: 130@66)) - flippedBy: #vertical centerAt: 0@0) display] -" -"Consistency test... - | f f2 p | -[ Sensor isAnyButtonPressed ] whileFalse: [ - f _ Form fromDisplay: ((p _ Sensor mousePoint) extent: 31@41). - Display fillBlack: (p extent: 31@41). - f2 _ f flippedBy: #vertical centerAt: 0@0. - (f2 flippedBy: #vertical centerAt: 0@0) displayAt: p ] -"! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2996-Form-FlippedBy-both-JuanVuletich-2016Dec02-15h42m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2996] on 9 December 2016 at 9:12:18 am'! -!StringMorph methodsFor: 'initialization' stamp: 'jmv 12/9/2016 09:09:45' prior: 16918230! - initialize - super initialize. - font _ nil. - emphasis _ 0. - self contents: 'String Morph' -! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2997-StringMorph-fix-JuanVuletich-2016Dec09-09h07m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2974] on 29 November 2016 at 9:10:32 pm'! -!OrderedCollection methodsFor: 'converting' stamp: 'len 11/29/2016 08:54:14'! - asNewArray - ^ array copyFrom: firstIndex to: lastIndex! ! -!OrderedCollection class methodsFor: 'instance creation' stamp: 'len 11/28/2016 19:18:39'! - newFrom: aCollection - "Create a new collection containing all the elements from aCollection" - - ^(self new: aCollection size) - resetTo: 1; - addAll: aCollection; - yourself! ! -!OrderedCollection methodsFor: 'enumerating' stamp: 'len 11/28/2016 10:50:21' prior: 16883972! - 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. - newCollection resetTo: 1. - firstIndex to: lastIndex do: [ :index | - newCollection addLast: (aBlock value: (array at: index))]. - ^ newCollection! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2998-OrderedCollectionTweaks-LucianoEstebanNotarfrancesco-2016Nov26-09h08m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2995] on 6 December 2016 at 8:16:54 pm'! - -RectangleLikeMorph subclass: #ResizeMorph - instanceVariableNames: 'gridLineWidth gridColor selectionColor outlineMorph grid from to action' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #ResizeMorph category: #'Morphic-Views'! -RectangleLikeMorph subclass: #ResizeMorph - instanceVariableNames: 'gridLineWidth gridColor selectionColor outlineMorph grid from to action' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! -!SystemWindow methodsFor: 'resize/collapse' stamp: 'bp 10/18/2015 12:18'! - resize - | resizeMorph | - resizeMorph _ ResizeMorph new morphExtent: 200@150. - resizeMorph action: [self resize: (resizeMorph selectionRectangle: Display extent)]. - resizeMorph morphPosition: self world activeHand morphPosition. - resizeMorph openInWorld - ! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 22:22'! - action: aBlock - action _ aBlock! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/18/2015 18:00'! - drawGridOn: aCanvas - 0 to: grid x do: [:i | - | x | - x _ i * (extent x - gridLineWidth) / grid x. - aCanvas line: x @ 0 to: x @ (extent y - 2) width: gridLineWidth color: gridColor]. - 0 to: grid y do: [:i | - | y | - y _ i * (extent y - gridLineWidth) / grid y. - aCanvas line: 0 @ y to: (extent x - 2) @ y width: gridLineWidth color: gridColor]! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 23:02'! - drawOn: aCanvas - super drawOn: aCanvas. - from ifNotNil: [aCanvas fillRectangle: (self selectionRectangle: extent) color: selectionColor]. - self drawGridOn: aCanvas! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 19:00'! - grid: aPoint - grid _ aPoint! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 19:00'! - handlesMouseDown: aMouseButtonEvent - ^true! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/17/2015 15:51'! - initialize - super initialize. - extent _ 400@300. - color _ Color white. - grid _ 8@6. - gridLineWidth _ 2. - gridColor _ Color black. - selectionColor _ Color red! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 23:18'! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - from _ self toGridPoint: localEventPosition. - outlineMorph _ BorderedRectMorph new - borderColor: Color black; - color: Color transparent; - openInWorld; - hide. - self selectTo: localEventPosition! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 23:17'! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - self selectTo: localEventPosition. - outlineMorph delete. - action ifNotNil: [ - action value. - self delete]! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 21:32'! - mouseMove: aMouseButtonEvent localPosition: localEventPosition - self selectTo: localEventPosition! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 21:25'! - printOn: aStream - super printOn: aStream. - aStream space; print: from; space; print: to! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 23:14'! - selectTo: localEventPosition - | newTo | - newTo _ self toGridPoint: localEventPosition. - newTo ~= to ifTrue: [ - to _ newTo. - self redrawNeeded. - self updateOutlineMorph]! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/17/2015 15:35'! - selectionRectangle: aRectangle - ^(from corner: to + 1) scaledBy: aRectangle // grid! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/17/2015 15:34'! - toGridPoint: aPoint - ^(aPoint min: extent - 1) // (extent // grid)! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 23:15'! - updateOutlineMorph - | rectangle | - rectangle _ self selectionRectangle: Display extent. - outlineMorph - morphPosition: rectangle origin extent: rectangle extent; - show! ! -!SystemWindow methodsFor: 'menu' stamp: 'bp 10/11/2015 21:42' prior: 16926424! - buildWindowMenu - - | aMenu | - - aMenu _ MenuMorph new defaultTarget: self. - - aMenu - add: 'change title...' action: #relabel; - add: 'window color...' action: #setWindowColor; - addLine; - add: 'send to back' action: #sendToBack; - add: 'make next-to-topmost' action: #makeSecondTopmost; - addLine; - add: (self isSticky ifTrue: [ 'make draggable' ] ifFalse: [ 'make undraggable' ]) action: #toggleStickiness; - addLine; - add: 'close' action: #delete; - add: 'collapse' action: #collapse; - add: 'expand / contract' action: #expandBoxHit; - addLine; - add: 'resize...' action: #resize; - add: 'resize full' action: #resizeFull; - add: 'resize top' action: #resizeTop; - add: 'resize left' action: #resizeLeft; - add: 'resize bottom' action: #resizeBottom; - add: 'resize right' action: #resizeRight; - add: 'resize top left' action: #resizeTopLeft; - add: 'resize top right' action: #resizeTopRight; - add: 'resize bottom left' action: #resizeBottomLeft; - add: 'resize bottom right' action: #resizeBottomRight. - - ^ aMenu! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/2999-ResizeMorph-BernhardPieber-2016Dec06-20h13m-bp.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2981] on 9 December 2016 at 10:27:21 am'! -!PasteUpMorph methodsFor: 'printing' stamp: 'jmv 12/9/2016 10:25:13' prior: 16887389! - printOn: aStream - "Reimplemented to add a tag showing that the receiver is currently functioning as a 'world', if it is" - - self isWorldMorph - ifTrue: [aStream nextPutAll: ' [world]'] - ifFalse: [super printOn: aStream]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3000-PasteUpMorph-print-fix-JuanVuletich-2016Dec09-10h25m-jmv.1.cs.st----! - -----SNAPSHOT----#(14 December 2016 2:32:05.602236 pm) Cuis5.0-3000-spur.image priorSource: 29942! - -----QUIT----#(14 December 2016 2:32:40.672866 pm) Cuis5.0-3000-spur.image priorSource: 54545! - -----STARTUP----#(19 December 2016 1:35:02.293384 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3000-spur.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3000] on 15 December 2016 at 12:11:15 pm'! -!Point methodsFor: 'printing' stamp: 'jmv 12/15/2016 10:20:58'! - printStringFractionDigits: placesDesired - ^(x printStringFractionDigits: placesDesired), '@', (y printStringFractionDigits: placesDesired)! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3001-Point-printStringFractionDigits-JuanVuletich-2016Dec15-10h20m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3000] on 16 December 2016 at 3:13:12 pm'! -!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 12/16/2016 15:05:52' prior: 16924259! - browseMyChanges - "Browse only the changes (in the changes file) by the current author. - Smalltalk browseMyChanges - " - self browseAllSelect: [ :method | - method fileIndex > 1 "only look at changes file" - and: [ method timeStamp beginsWith: Utilities authorInitials, ' ' ]]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3002-BrowseMyChanges-fix-JuanVuletich-2016Dec16-15h03m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3002] on 19 December 2016 at 12:44:03 pm'! -!CompiledMethod methodsFor: 'accessing' stamp: 'jmv 12/17/2016 22:38:52' prior: 16819446! - initialPC - "Answer the program counter for the receiver's first bytecode." - ^ (self numLiterals + 1) * Smalltalk wordSize + 1! ! -!SystemDictionary methodsFor: 'memory space' stamp: 'jmv 12/17/2016 22:37:27' prior: 16920388! -lowSpaceThreshold - "Answer the low space threshold. When the amount of free memory (after garbage collection) - falls below this limit, the system is in serious danger of completely exhausting memory and - crashing. This limit should be made high enough to allow the user open a debugger to diagnose - a problem or to save the image. In a stack-based VM such as Cog contexts for activations in - the stack zone will have to be created as the debugger opens, requiring additional headroom." - - | slotsForDebugger slotsForContextsOnStackPages | - slotsForDebugger := 65536. "Arbitrary guess" - slotsForContextsOnStackPages := - (self vmParameterAt: 42) - ifNil: [0] - ifNotNil: - [:numStackPages| | headerSize numActivationsPerPage maxContextSize | - numActivationsPerPage := 40. "Design goal of the Cog VM" - headerSize := 2. "64-bytes for Spur" - maxContextSize := MethodContext instSize + CompiledMethod fullFrameSize + headerSize. - numStackPages * numActivationsPerPage * maxContextSize]. - ^slotsForDebugger + slotsForContextsOnStackPages * self wordSize! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3003-FixFor64BitSpur-JuanVuletich-2016Dec19-12h41m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3002] on 19 December 2016 at 12:54:39 pm'! -!Parser methodsFor: 'primitives' stamp: 'nice 9/6/2013 00:48' prior: 16885817! - externalFunctionDeclaration - "Parse the function declaration for a call to an external library." - | descriptorClass callType modifier retType externalName args argType module fn | - descriptorClass := Smalltalk at: #ExternalFunction ifAbsent: [ ^ false ]. - callType := descriptorClass callingConventionFor: here. - callType == nil ifTrue:[^false]. - [modifier := descriptorClass callingConventionModifierFor: token. - modifier notNil] whileTrue: - [self advance. - callType := callType bitOr: modifier]. - "Parse return type" - self advance. - retType := self externalType: descriptorClass. - retType == nil ifTrue:[^self expected:'return type']. - "Parse function name or index" - externalName := here. - (self match: #string) - ifTrue:[externalName := externalName asSymbol] - ifFalse:[(self match:#number) ifFalse:[^self expected:'function name or index']]. - (self match: #leftParenthesis) ifFalse:[^self expected:'argument list']. - args := WriteStream on: Array new. - [self match: #rightParenthesis] whileFalse:[ - argType := self externalType: descriptorClass. - argType == nil ifTrue:[^self expected:'argument']. - argType isVoid & argType isPointerType not ifFalse:[args nextPut: argType]]. - (self matchToken: 'module:') ifTrue:[ - module := here. - (self match: #string) ifFalse:[^self expected: 'String']. - module := module asSymbol]. - Smalltalk at: #ExternalLibraryFunction ifPresent:[:xfn| - fn := xfn name: externalName - module: module - callType: callType - returnType: retType - argumentTypes: args contents. - self allocateLiteral: fn]. - (self matchToken: 'error:') - ifTrue: - [| errorCodeVariable | - errorCodeVariable := here. - (hereType == #string - or: [hereType == #word]) ifFalse:[^self expected: 'error code (a variable or string)']. - self advance. - self addPragma: (Pragma keyword: #primitive:error: arguments: (Array with: 120 with: errorCodeVariable)). - fn ifNotNil: [fn setErrorCodeName: errorCodeVariable]] - ifFalse: - [self addPragma: (Pragma keyword: #primitive: arguments: #(120))]. - ^true! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3004-externalFunctionDeclaration-JuanVuletich-2016Dec19-12h44m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3002] on 19 December 2016 at 1:08:36 pm'! - -SmallInteger class - instanceVariableNames: 'minVal maxVal '! - -!classDefinition: 'SmallInteger class' category: #'Kernel-Numbers'! -SmallInteger class - instanceVariableNames: 'minVal maxVal'! -!SmallInteger class methodsFor: 'class initialization' stamp: 'jmv 12/19/2016 13:03:09'! - initMinValAndMaxVal - | next val | - val := -32768. "Assume at least 16 bits" - [next := val + val. - next class == self] whileTrue: - [val := next]. - minVal := val. - maxVal := -1 - val! ! -!SystemDictionary methodsFor: 'image' stamp: 'jmv 12/19/2016 13:04:12' prior: 16925538! - wordSize - "Answer the size in bytes of an object pointer or word in the object memory. - The value does not change for a given image, but may be modified by a SystemTracer - when converting the image to another format. The value is cached in WordSize to - avoid the performance overhead of repeatedly consulting the VM." - - "Smalltalk wordSize" - - ^ WordSize ifNil: [ - SmallInteger initMinValAndMaxVal. - WordSize := [self vmParameterAt: 40] on: Error do: [4]]! ! - -SmallInteger class - instanceVariableNames: 'minVal maxVal'! - -!classDefinition: 'SmallInteger class' category: #'Kernel-Numbers'! -SmallInteger class - instanceVariableNames: 'minVal maxVal'! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -SmallInteger initMinValAndMaxVal! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3005-SmallInteger-minVal-maxVal-part1-JuanVuletich-2016Dec19-12h54m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3005] on 19 December 2016 at 1:12:20 pm'! -!SmallInteger class methodsFor: 'constants' stamp: 'jmv 12/19/2016 13:06:38' prior: 16909182! - maxVal - "Answer the maximum value for a SmallInteger." - - "Ensure word size is properly set. If so, maxVal is also set." - Smalltalk wordSize. - ^maxVal! ! -!SmallInteger class methodsFor: 'constants' stamp: 'jmv 12/19/2016 13:07:24' prior: 16909186! - minVal - "Answer the minimum value for a SmallInteger." - - "Ensure word size is properly set. If so, minVal is also set." - Smalltalk wordSize. - ^minVal! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3006-SmallInteger-minVal-maxVal-part2-JuanVuletich-2016Dec19-13h11m-jmv.1.cs.st----! - -----SNAPSHOT----#(19 December 2016 1:35:11.847544 pm) Cuis5.0-3006-spur.image priorSource: 54644! - -----QUIT----#(19 December 2016 1:35:24.272429 pm) Cuis5.0-3006-spur.image priorSource: 62581! - -----STARTUP----#(19 December 2016 1:45:03.353057 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3006-spur.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3006] on 19 December 2016 at 1:42:27 pm'! -!SmallFloat64 commentStamp: '' prior: 16908181! - My instances represent 64-bit Floats whose exponent fits in 8 bits as immediate objects. This representation is only available on 64-bit systems, not 32-bit systems.! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -SmallFloat64 tryPrimitive: 161 withArgs: #(999). -! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3007-SmallFloat64-fixHash-forSpur64Conversion-JuanVuletich-2016Dec19-13h41m-jmv.1.cs.st----! - -----SNAPSHOT----#(19 December 2016 1:45:10.081033 pm) Cuis5.0-3007-spur.image priorSource: 62680! - -----QUIT----#(19 December 2016 1:45:27.503203 pm) Cuis5.0-3007-spur.image priorSource: 63733! - -----STARTUP----#(19 December 2016 3:02:46.256654 pm) as /root/PayloadSoftware/ffi/Cuis5.0-3007-spur-64.image! - - -Display extent! - -Display extent! - -Display extent! - -----QUIT----#(19 December 2016 3:04:52.716701 pm) Cuis5.0-3007-spur-64.image priorSource: 63832! - -----STARTUP----#(27 December 2016 12:18:48.689655 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3007-spur-64.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3007] on 22 December 2016 at 4:05:04 pm'! -!LargePositiveInteger methodsFor: 'testing' stamp: 'nice 8/31/2008 00:07'! - isLarge - ^true! ! -!SmallInteger methodsFor: 'testing' stamp: 'nice 8/31/2008 00:07'! - isLarge - ^false! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/27/2015 23:01'! - long64At: index bigEndian: bigEndian - "Return a 64-bit signed integer quantity starting from the given byte index." - - | value | - value := self unsignedLong64At: index bigEndian: bigEndian. - value digitLength < 8 ifTrue: [ ^value ]. - (value digitAt: 8) < 16r80 ifTrue: [ ^value ]. - ^value - 16r10000000000000000! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/27/2015 22:57'! - long64At: index put: value bigEndian: bigEndian - "Store a 64-bit signed integer quantity starting from the given byte index." - - ^self - unsignedLong64At: index - put: (value negative - ifFalse: [ value ] - ifTrue: [ value + 16r10000000000000000 ]) - bigEndian: bigEndian! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'eem 2/22/2016 09:36'! - unsignedLong64At: index bigEndian: bigEndian - "Return a 64-bit unsigned integer quantity starting from the given byte index. Use #normalize where necessary to ensure compatibility with non-30-bit SmallIntegers." - - | byte | - SmallInteger maxVal > 1073741823 ifTrue: - [bigEndian - ifTrue: "64-bit SmallIntegers have a 3 bit tag and a sign bit, so the most positive value has 16rF as its top byte." - [(byte := self at: index) <= 16rF ifTrue: - [^((((((((byte bitShift: 8) + (self at: index + 1) bitShift: 8) + (self at: index + 2) bitShift: 8) + (self at: index + 3)) bitShift: 8) - + (self at: index + 4) bitShift: 8) + (self at: index + 5) bitShift: 8) + (self at: index + 6) bitShift: 8) + (self at: index + 7)]] - ifFalse: - [(byte := self at: index + 7) <= 16rF ifTrue: - [^((((((((byte bitShift: 8) + (self at: index + 6) bitShift: 8) + (self at: index + 5) bitShift: 8) + (self at: index + 4)) bitShift: 8) - + (self at: index + 3) bitShift: 8) + (self at: index + 2) bitShift: 8) + (self at: index + 1) bitShift: 8) + (self at: index)]]]. - bigEndian ifFalse: [ - (byte := self at: index + 7) = 0 ifFalse: [ - ^(LargePositiveInteger new: 8) - replaceFrom: 1 to: 8 with: self startingAt: index; - normalize ]. - (byte := self at: index + 6) = 0 ifFalse: [ - ^(LargePositiveInteger new: 7) - replaceFrom: 1 to: 7 with: self startingAt: index; - normalize ]. - (byte := self at: index + 5) = 0 ifFalse: [ - ^(LargePositiveInteger new: 6) - replaceFrom: 1 to: 6 with: self startingAt: index; - normalize ]. - (byte := self at: index + 4) = 0 ifFalse: [ - ^(LargePositiveInteger new: 5) - replaceFrom: 1 to: 5 with: self startingAt: index; - normalize ]. - (byte := self at: index + 3) <= 16r3F ifFalse: [ - ^(LargePositiveInteger new: 4) - replaceFrom: 1 to: 4 with: self startingAt: index; - normalize ]. - ^(((byte bitShift: 8) + (self at: index + 2) bitShift: 8) + (self at: index + 1) bitShift: 8) + (self at: index) ]. - (byte := self at: index) = 0 ifFalse: [ - ^(LargePositiveInteger new: 8) - digitAt: 1 put: (self at: index + 7); - digitAt: 2 put: (self at: index + 6); - digitAt: 3 put: (self at: index + 5); - digitAt: 4 put: (self at: index + 4); - digitAt: 5 put: (self at: index + 3); - digitAt: 6 put: (self at: index + 2); - digitAt: 7 put: (self at: index + 1); - digitAt: 8 put: byte; - normalize ]. - (byte := self at: index + 1) = 0 ifFalse: [ - ^(LargePositiveInteger new: 7) - digitAt: 1 put: (self at: index + 7); - digitAt: 2 put: (self at: index + 6); - digitAt: 3 put: (self at: index + 5); - digitAt: 4 put: (self at: index + 4); - digitAt: 5 put: (self at: index + 3); - digitAt: 6 put: (self at: index + 2); - digitAt: 7 put: byte; - normalize ]. - (byte := self at: index + 2) = 0 ifFalse: [ - ^(LargePositiveInteger new: 6) - digitAt: 1 put: (self at: index + 7); - digitAt: 2 put: (self at: index + 6); - digitAt: 3 put: (self at: index + 5); - digitAt: 4 put: (self at: index + 4); - digitAt: 5 put: (self at: index + 3); - digitAt: 6 put: byte; - normalize ]. - (byte := self at: index + 3) = 0 ifFalse: [ - ^(LargePositiveInteger new: 5) - digitAt: 1 put: (self at: index + 7); - digitAt: 2 put: (self at: index + 6); - digitAt: 3 put: (self at: index + 5); - digitAt: 4 put: (self at: index + 4); - digitAt: 5 put: byte; - normalize ]. - (byte := self at: index + 4) <= 16r3F ifFalse: [ - ^(LargePositiveInteger new: 4) - digitAt: 1 put: (self at: index + 7); - digitAt: 2 put: (self at: index + 6); - digitAt: 3 put: (self at: index + 5); - digitAt: 4 put: byte; - normalize ]. - ^(((byte bitShift: 8) + (self at: index + 5) bitShift: 8) + (self at: index + 6) bitShift: 8) + (self at: index + 7)! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/9/2015 20:18'! - unsignedLong64At: index put: value bigEndian: bigEndian - "Store a 64-bit unsigned integer quantity starting from the given byte index" - - | i j | - value isLarge ifTrue: [ - i := value digitLength. - bigEndian ifFalse: [ - self - replaceFrom: index - to: index + i - 1 - with: value - startingAt: 1; - replaceFrom: index + i - to: index + 7 - with: #[0 0 0 0 0 0 0 0] - startingAt: 1. - ^value ]. - j := index + 8. - i <= 7 ifTrue: [ - self - replaceFrom: index - to: j - i - 1 - with: #[0 0 0 0 0 0 0 0] - startingAt: 1 ]. - [ 1 <= i ] whileTrue: [ - self at: j - i put: (value digitAt: i). - i := i - 1 ]. - ^value ]. - bigEndian ifFalse: [ - j := index - 1. - i := value. - [ 1 <= i ] whileTrue: [ - self at: (j := j + 1) put: (i bitAnd: 16rFF). - i := i bitShift: -8 ]. - self replaceFrom: j + 1 - to: index + 7 - with: #[0 0 0 0 0 0 0 0] - startingAt: 1. - ^value ]. - j := index + 8. - i := value. - [ 1 <= i ] whileTrue: [ - self at: (j := j - 1) put: (i bitAnd: 16rFF). - i := i bitShift: -8 ]. - self replaceFrom: index - to: j - 1 - with: #[0 0 0 0 0 0 0 0] - startingAt: 1. - ^value! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/9/2015 20:28' prior: 16793638! - longAt: index bigEndian: bigEndian - "Return a 32-bit integer quantity starting from the given byte index. Use #normalize where necessary to ensure compatibility with non-30-bit SmallIntegers." - - | byte result | - bigEndian ifFalse: [ - (byte := self at: index + 3) <= 16r7F ifTrue: [ "Is the result non-negative?" - byte <= 16r3F ifTrue: [ - ^(((byte bitShift: 8) + (self at: index + 2) bitShift: 8) + (self at: index + 1) bitShift: 8) + (self at: index) ]. - ^(LargePositiveInteger new: 4) - replaceFrom: 1 - to: 4 - with: self - startingAt: index; - normalize ]. - "Negative" - byte >= 16rC0 ifTrue: [ - ^-1 - (((((byte bitShift: 8) + (self at: index + 2) bitShift: 8) + (self at: index + 1) bitXor: 16rFFFFFF) bitShift: 8) + ((self at: index) bitXor: 16rFF)) ]. - (result := LargeNegativeInteger new: 4) - digitAt: 4 put: ((self at: index + 3) bitXor: 16rFF); - digitAt: 3 put: ((self at: index + 2) bitXor: 16rFF); - digitAt: 2 put: ((self at: index + 1) bitXor: 16rFF). - (byte := ((self at: index) bitXor: 16rFF) + 1) <= 16rFF ifTrue: [ - ^result - digitAt: 1 put: byte; - normalize ]. - ^result - digitAt: 1 put: 16rFF; - - 1 "It's tempting to do the subtraction in a loop to avoid the LargeInteger creation, but it's actually slower than this." ]. - (byte := self at: index) <= 16r7F ifTrue: [ "Is the result non-negative?" - byte <= 16r3F ifTrue: [ - ^(((byte bitShift: 8) + (self at: index + 1) bitShift: 8) + (self at: index + 2) bitShift: 8) + (self at: index + 3) ]. - ^(LargePositiveInteger new: 4) - digitAt: 1 put: (self at: index + 3); - digitAt: 2 put: (self at: index + 2); - digitAt: 3 put: (self at: index + 1); - digitAt: 4 put: byte; - normalize ]. - "Negative" - 16rC0 <= byte ifTrue: [ - ^-1 - (((((byte bitShift: 8) + (self at: index + 1) bitShift: 8) + (self at: index + 2) bitXor: 16rFFFFFF) bitShift: 8) + ((self at: index + 3) bitXor: 16rFF)) ]. - (result := LargeNegativeInteger new: 4) - digitAt: 4 put: (byte bitXor: 16rFF); - digitAt: 3 put: ((self at: index + 1) bitXor: 16rFF); - digitAt: 2 put: ((self at: index + 2) bitXor: 16rFF). - (byte := ((self at: index + 3) bitXor: 16rFF) + 1) <= 16rFF ifTrue: [ - ^result - digitAt: 1 put: byte; - normalize ]. - ^result - digitAt: 1 put: 16rFF; - - 1 "It's tempting to do the subtraction in a loop to avoid the LargeInteger creation, but it's actually slower than this."! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/6/2015 17:13' prior: 16793658! - longAt: index put: value bigEndian: bigEndian - "Store a 32-bit signed integer quantity starting from the given byte index" - - | v v2 | - value isLarge ifTrue: [ - bigEndian ifFalse: [ - value positive ifTrue: [ - self - replaceFrom: index - to: index + 3 - with: value - startingAt: 1. - ^value ]. - v := 0. - [ v <= 3 and: [ (v2 := ((value digitAt: v + 1) bitXor: 16rFF) + 1) = 16r100 ] ] whileTrue: [ - self at: index + v put: 0. - v := v + 1 ]. - self at: index + v put: v2. - v := v + 1. - [ v <= 3 ] whileTrue: [ - self at: index + v put: ((value digitAt: (v := v + 1)) bitXor: 16rFF) ]. - ^value ]. - value positive ifTrue: [ - self - at: index put: (value digitAt: 4); - at: index + 1 put: (value digitAt: 3); - at: index + 2 put: (value digitAt: 2); - at: index + 3 put: (value digitAt: 1). - ^value ]. - v := 3. - [ 0 <= v and: [ (v2 := ((value digitAt: 4 - v) bitXor: 16rFF) + 1) = 16r100 ] ] whileTrue: [ - self at: index + v put: 0. - v := v - 1 ]. - self at: index + v put: v2. - [ 0 <= (v := v - 1) ] whileTrue: [ - self at: index + v put: ((value digitAt: 4 - v) bitXor: 16rFF) ]. - ^value ]. - v := value bitShift: -24. - 0 <= (v := (v bitAnd: 16r7F) - (v bitAnd: 16r80)) ifFalse: [ - v := v + 16r100 ]. - bigEndian ifFalse: [ - self - at: index put: (value bitAnd: 16rFF); - at: index + 1 put: ((value bitShift: -8) bitAnd: 16rFF); - at: index + 2 put: ((value bitShift: -16) bitAnd: 16rFF); - at: index + 3 put: v. - ^value ]. - self - at: index put: v; - at: index + 1 put: ((value bitShift: -16) bitAnd: 16rFF); - at: index + 2 put: ((value bitShift: -8) bitAnd: 16rFF); - at: index + 3 put: (value bitAnd: 16rFF). - ^value! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/6/2015 23:16' prior: 16793680! - shortAt: index bigEndian: bigEndian - "Return a 16-bit signed integer quantity starting from the given byte index" - - | result | - result := bigEndian - ifFalse: [ ((self at: index + 1) bitShift: 8) + (self at: index) ] - ifTrue: [ ((self at: index) bitShift: 8) + (self at: index + 1) ]. - result < 16r8000 ifTrue: [ ^result ]. - ^result - 16r10000! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/6/2015 23:16' prior: 16793690! - shortAt: index put: value bigEndian: bigEndian - "Store a 16-bit signed integer quantity starting from the given byte index" - - | unsignedValue | - (unsignedValue := value) < 0 ifTrue: [ - unsignedValue := unsignedValue + 16r10000 ]. - bigEndian ifFalse: [ - self - at: index + 1 put: (unsignedValue bitShift: -8); - at: index put: (unsignedValue bitAnd: 16rFF). - ^value ]. - self - at: index put: (unsignedValue bitShift: -8); - at: index + 1 put: (unsignedValue bitAnd: 16rFF). - ^value! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'eem 2/22/2016 09:20' prior: 16793700! - unsignedLongAt: index bigEndian: bigEndian - "Return a 32-bit unsigned integer quantity starting from the given byte index. Use #normalize where necessary to ensure compatibility with non-30-bit SmallIntegers." - | byte | - bigEndian ifTrue: - [((byte := self at: index) <= 16r3F - or: [SmallInteger maxVal > 1073741823]) ifTrue: - [^(((byte bitShift: 8) + (self at: index + 1) bitShift: 8) + (self at: index + 2) bitShift: 8) + (self at: index + 3)]. - ^(LargePositiveInteger new: 4) - digitAt: 1 put: (self at: index + 3); - digitAt: 2 put: (self at: index + 2); - digitAt: 3 put: (self at: index + 1); - digitAt: 4 put: byte; - normalize]. - ((byte := self at: index + 3) <= 16r3F - or: [SmallInteger maxVal > 1073741823]) ifTrue: - [^(((byte bitShift: 8) + (self at: index + 2) bitShift: 8) + (self at: index + 1) bitShift: 8) + (self at: index)]. - ^(LargePositiveInteger new: 4) - replaceFrom: 1 to: 4 with: self startingAt: index; - normalize! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/3/2015 01:33' prior: 16793720! - unsignedLongAt: index put: value bigEndian: bigEndian - "Store a 32-bit unsigned integer quantity starting from the given byte index" - - value isLarge - ifTrue: [ - bigEndian ifFalse: [ - self - replaceFrom: index - to: index + 3 - with: value - startingAt: 1. - ^value ]. - self - at: index put: (value digitAt: 4); - at: index + 1 put: (value digitAt: 3); - at: index + 2 put: (value digitAt: 2); - at: index +3 put: (value digitAt: 1) ] - ifFalse: [ - bigEndian ifFalse: [ - self - at: index put: (value bitAnd: 16rFF); - at: index + 1 put: ((value bitShift: -8) bitAnd: 16rFF); - at: index + 2 put: ((value bitShift: -16) bitAnd: 16rFF); - at: index + 3 put: (value bitShift: -24). - ^value ]. - self - at: index put: (value bitShift: -24); - at: index + 1 put: ((value bitShift: -16) bitAnd: 16rFF); - at: index + 2 put: ((value bitShift: -8) bitAnd: 16rFF); - at: index + 3 put: (value bitAnd: 16rFF) ]. - ^value! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/3/2015 01:33' prior: 16793740! - unsignedShortAt: index bigEndian: bigEndian - "Return a 16-bit unsigned integer quantity starting from the given byte index" - - bigEndian ifFalse: [ ^((self at: index + 1) bitShift: 8) + (self at: index) ]. - ^((self at: index) bitShift: 8) + (self at: index + 1) - ! ! -!ByteArray methodsFor: 'platform independent access' stamp: 'ul 9/3/2015 15:29' prior: 16793751! - unsignedShortAt: index put: value bigEndian: bigEndian - "Store a 16-bit unsigned integer quantity starting from the given byte index" - - bigEndian ifFalse: [ - self - at: index + 1 put: (value bitShift: -8); - at: index put: (value bitAnd: 16rFF). - ^value ]. - self - at: index put: (value bitShift: -8); - at: index+1 put: (value bitAnd: 16rFF). - ^value! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3008-ByteArray-UpdateToSqueak-JuanVuletich-2016Dec22-15h54m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3008] on 26 December 2016 at 2:54:38 pm'! -!Float64Array methodsFor: 'accessing' stamp: 'jmv 12/26/2016 14:53:06' prior: 16846088! - floatAt: index put: aFloat - "Store the argument (e.g., 64 bit Float) at the given index - Use the same internal representation as BoxedFloat64. I.e. a BoxedFloat64 and a Float64Array of size 1 hold the same bits. - Allow subclasses to redefine #at:put:" - - "This breaks with SmallFloat64" - "self replaceWordsFrom: index * 2 - 1 to: index * 2 with: aFloat asFloat startingAt: 1." - - "Float >>basicAt: acts as if Floats were stored in big endian format. Our instances are in platform endianess." - Smalltalk isLittleEndian - ifTrue: [ - self basicAt: index * 2 - 1 put: (aFloat basicAt: 2). - self basicAt: index * 2 put: (aFloat basicAt: 1) ] - ifFalse: [ - self basicAt: index * 2 - 1 put: (aFloat basicAt: 1). - self basicAt: index * 2 put: (aFloat basicAt: 2) ]. - ^aFloat! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3009-Float64Array-fixForSmallFloats-JuanVuletich-2016Dec26-14h53m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3009] on 27 December 2016 at 12:14:57 pm'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 12/27/2016 12:14:33' prior: 16922764! - saveAsNewVersion - "Save the image/changes using the next available version number." - " - Smalltalk saveAsNewVersion - " - | fileName newName changesName systemVersion | - self okayToSave ifFalse: [ ^ self ]. - systemVersion _ SystemVersion current. - fileName _ String streamContents: [ :strm | - strm - nextPutAll: 'Cuis'; - print: systemVersion versionMajor; - nextPut: $.; - print: systemVersion versionMinor; - nextPut: $-; - print: systemVersion highestUpdate. - Smalltalk isSpur ifTrue: [ - strm nextPutAll: '-spur'. - Smalltalk wordSize = 8 ifTrue: [ - strm nextPutAll: '-64' ]]]. - newName _ fileName, '.image'. - (DirectoryEntry smalltalkImageDirectory // newName) exists ifTrue: [ - newName _ DirectoryEntry smalltalkImageDirectory - nextNameFor: fileName - extension: 'image' ]. - changesName _ self fullNameForChangesNamed: newName. - "Check to see if there is a .changes file that would cause a problem if we saved a new .image file with the new version number" - changesName asFileEntry exists ifTrue: [ - ^ self inform: -'There is already .changes file of the desired name, -', newName, ' -curiously already present, even though there is -no corresponding .image file. Please remedy -manually and then repeat your request.' ]. - "Try to clear all user state, including all class vars, preferences, etc" - self saveAs: newName andQuit: false clearAllClassState: true! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3010-saveAsNewVersion-spur64-JuanVuletich-2016Dec27-12h14m-jmv.1.cs.st----! - -----SNAPSHOT----#(27 December 2016 12:18:59.203561 pm) Cuis5.0-3010-spur-64.image priorSource: 64090! - -----QUIT----#(27 December 2016 12:19:11.089187 pm) Cuis5.0-3010-spur-64.image priorSource: 81847! - -----STARTUP----#(27 December 2016 3:30:14.950041 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3010-spur-64.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3009] on 27 December 2016 at 9:51:30 am'! -!Float64Array methodsFor: 'accessing' stamp: 'jmv 12/27/2016 09:51:21' prior: 50334122! - floatAt: index put: aNumber - "Store the argument (e.g., 64 bit Float) at the given index - Use the same internal representation as BoxedFloat64. I.e. a BoxedFloat64 and a Float64Array of size 1 hold the same bits. - Allow subclasses to redefine #at:put:" - - "This breaks with SmallFloat64" - "self replaceWordsFrom: index * 2 - 1 to: index * 2 with: aFloat asFloat startingAt: 1." - - "Float >>basicAt: acts as if Floats were stored in big endian format. Our instances are in platform endianess." - | aFloat | - aFloat _ aNumber asFloat. - Smalltalk isLittleEndian - ifTrue: [ - self basicAt: index * 2 - 1 put: (aFloat basicAt: 2). - self basicAt: index * 2 put: (aFloat basicAt: 1) ] - ifFalse: [ - self basicAt: index * 2 - 1 put: (aFloat basicAt: 1). - self basicAt: index * 2 put: (aFloat basicAt: 2) ]. - ^aFloat! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3011-Float64Array-fixForSmallIntegers-JuanVuletich-2016Dec27-09h51m-jmv.1.cs.st----! - -----SNAPSHOT----#(27 December 2016 3:30:22.206752 pm) Cuis5.0-3011-spur-64.image priorSource: 81950! - -----QUIT----#(27 December 2016 3:30:38.307126 pm) Cuis5.0-3011-spur-64.image priorSource: 83341! - -----STARTUP----#(18 January 2017 10:35:47.281303 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3011-spur-64.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3011] on 29 December 2016 at 11:02:24 am'! - -PluggableScrollPane subclass: #HierarchicalListMorph - instanceVariableNames: 'selectedMorph getListSelector keystrokeActionSelector autoDeselect autoExpand sortingSelector getSelectionSelector setSelectionSelector menuGetter mainView highlightedMorph doubleClickSelector ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #HierarchicalListMorph category: #'Morphic-Views'! -PluggableScrollPane subclass: #HierarchicalListMorph - instanceVariableNames: 'selectedMorph getListSelector keystrokeActionSelector autoDeselect autoExpand sortingSelector getSelectionSelector setSelectionSelector menuGetter mainView highlightedMorph doubleClickSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! -!Inspector methodsFor: 'user commands' stamp: 'jmv 12/29/2016 10:58:58'! - inspectSelection - self selection inspect! ! -!ObjectExplorer methodsFor: 'user commands' stamp: 'jmv 12/29/2016 11:01:35'! - inspectSelection - self object inspect! ! -!HierarchicalListMorph methodsFor: 'events' stamp: 'jmv 12/29/2016 10:55:06'! - doubleClick: aMouseButtonEvent localPosition: localEventPosition - - doubleClickSelector ifNil: [ ^super doubleClick: aMouseButtonEvent localPosition: localEventPosition ]. - ^ self model perform: doubleClickSelector! ! -!HierarchicalListMorph methodsFor: 'initialization' stamp: 'jmv 12/29/2016 10:55:42'! - doubleClickSelector: aSymbol - doubleClickSelector _ aSymbol! ! -!PluggableListMorph methodsFor: 'initialization' stamp: 'jmv 12/29/2016 10:41:28'! - doubleClickSelector: aSymbol - doubleClickSelector _ aSymbol! ! -!HierarchicalListMorph methodsFor: 'events' stamp: 'jmv 12/29/2016 10:53:49' prior: 16853080! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - - | itemMorph | - aMouseButtonEvent hand newKeyboardFocus: self. - itemMorph _ self itemFromPoint: localEventPosition. - itemMorph ifNil: [ ^super mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition ]. - self highlightedMorph: itemMorph. - (itemMorph inToggleArea: (itemMorph internalize: (scroller internalize: localEventPosition))) - ifTrue: [ ^self toggleExpandedState: itemMorph event: aMouseButtonEvent ]. - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: #click:localPosition: - clkNHalf: nil - dblClkSel: (doubleClickSelector ifNotNil: [ #doubleClick:localPosition: ]) - dblClkNHalfSel: nil - tripleClkSel: nil! ! -!DebuggerWindow methodsFor: 'GUI building' stamp: 'jmv 12/29/2016 10:59:15' prior: 16831023! - buildMorphicWindow - "Open a full morphic debugger with the given label" - - | upperMorph receiverInspector receiverInspectorText contextVariableInspector contextVariableInspectorText bottomMorph | - - upperMorph _ PluggableListMorph - model: model - listGetter: #contextStackList - indexGetter: #contextStackIndex - indexSetter: #toggleContextStackIndex: - mainView: self - menuGetter: #contextStackMenu - keystrokeAction: #contextStackKey:from:. - - receiverInspector _ PluggableListMorph - model: model receiverInspector - listGetter: #fieldList - indexGetter: #selectionIndex - indexSetter: #toggleIndex: - mainView: self - menuGetter: #receiverFieldListMenu - keystrokeAction: #inspectorKey:from:. - receiverInspector doubleClickSelector: #inspectSelection. - receiverInspectorText _ TextModelMorph - textProvider: model receiverInspector - textGetter: #acceptedContents - textSetter: #accept: - selectionGetter: #contentsSelection. - contextVariableInspector _ PluggableListMorph - model: model contextVariablesInspector - listGetter: #fieldList - indexGetter: #selectionIndex - indexSetter: #toggleIndex: - mainView: self - menuGetter: #contextFieldListMenu - keystrokeAction: #inspectorKey:from:. - contextVariableInspector doubleClickSelector: #inspectSelection. - contextVariableInspectorText _ TextModelMorph - textProvider: model contextVariablesInspector - textGetter: #acceptedContents - textSetter: #accept: - selectionGetter: #contentsSelection. - - bottomMorph _ LayoutMorph newRow. - bottomMorph - addMorph: receiverInspector proportionalWidth: 0.2; - addAdjusterAndMorph: receiverInspectorText proportionalWidth: 0.3; - addAdjusterAndMorph: contextVariableInspector proportionalWidth: 0.2; - addAdjusterAndMorph: contextVariableInspectorText proportionalWidth: 0.3. - - self layoutMorph - addMorph: upperMorph proportionalHeight: 0.25; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.55; - addAdjusterAndMorph: bottomMorph proportionalHeight: 0.2! ! -!InspectorWindow methodsFor: 'GUI building' stamp: 'jmv 12/29/2016 11:00:06' prior: 16857200! - buildMorphicWindow - " Inspector openOn: SystemOrganization " - | contentsText list upperRow evaluatorText label | - "Build widgets. We'll assemble them below." - list _ PluggableListMorph - model: model - listGetter: #fieldList - indexGetter: #selectionIndex - indexSetter: #toggleIndex: - mainView: self - menuGetter: #fieldListMenu - keystrokeAction: #inspectorKey:from:. - list doubleClickSelector: #inspectSelection. - contentsText _ TextModelMorph - textProvider: model - textGetter: #acceptedContents - textSetter: #accept: - selectionGetter: #contentsSelection. - evaluatorText _ (TextModelMorph textProvider: model) - askBeforeDiscardingEdits: false. - "Upper row has two widgets, side by side: the list of variables at the left side, and the variable contents pane at the right side." - upperRow _ LayoutMorph newRow. - upperRow - addMorph: list proportionalWidth: 0.3; - addAdjusterAndMorph: contentsText proportionalWidth: 0.7. - "Inspector Window has two rows: At the top, the one we just bult. Below it, the evaluation pane." - self layoutMorph - addMorph: upperRow proportionalHeight: 0.7; - addAdjusterAndMorph: evaluatorText proportionalHeight: 0.3. - "Set label" - label _ [model object printStringLimitedTo: 64] - on: UnhandledError - do: [:ex | ex return: model object class printString, ' (printing failed)']. - (label includesSubString: model object class name) - ifFalse: [label _ model object class name, ': ', label]. - self setLabel: label! ! -!ObjectExplorerWindow methodsFor: 'GUI building' stamp: 'jmv 12/29/2016 11:00:46' prior: 16883288! -buildMorphicWindow - - | textMorph | - listMorph _ HierarchicalListMorph - model: model - listGetter: #getList - indexGetter: #getCurrentSelection - indexSetter: #noteNewSelection: - mainView: self - menuGetter: #genericMenu - keystrokeAction: #explorerKey:from:. - listMorph autoDeselect: false. - listMorph doubleClickSelector: #inspectSelection. - textMorph _ (TextModelMorph textProvider: model) - askBeforeDiscardingEdits: false. - self layoutMorph - addMorph: listMorph proportionalHeight: 0.8; - addAdjusterAndMorph: textMorph proportionalHeight: 0.2. - self setLabel: (model rootObject printStringLimitedTo: 64)! ! -!ObjectExplorerWindow methodsFor: 'menu commands' stamp: 'jmv 12/29/2016 10:50:28' prior: 16883479! - openWeightExplorer - "Create and schedule a Weight Explorer on the receiver's model's currently selected object." - - ^WeightTracer openExplorerOn: model object! ! - -PluggableScrollPane subclass: #HierarchicalListMorph - instanceVariableNames: 'selectedMorph getListSelector keystrokeActionSelector autoDeselect autoExpand sortingSelector getSelectionSelector setSelectionSelector menuGetter mainView highlightedMorph doubleClickSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #HierarchicalListMorph category: #'Morphic-Views'! -PluggableScrollPane subclass: #HierarchicalListMorph - instanceVariableNames: 'selectedMorph getListSelector keystrokeActionSelector autoDeselect autoExpand sortingSelector getSelectionSelector setSelectionSelector menuGetter mainView highlightedMorph doubleClickSelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3012-DoubleClickOpensInspector-JuanVuletich-2016Dec29-10h36m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3012] on 29 December 2016 at 11:30:18 am'! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 12/29/2016 11:29:52' prior: 16902537! - parseExternalCall - self scanNext. - self failWhen: currentToken isNil. - self scanPast: #externalCallType. - currentToken = '*' - ifTrue: [self scanPast: #externalCallTypePointerIndicator]. - currentTokenFirst isDigit - ifTrue: [self scanPast: #integer] - ifFalse: [ - self failUnless: currentTokenFirst == $'. - self parseString]. - self failUnless: currentTokenFirst == $(. - self scanPast: #leftParenthesis. - [currentTokenFirst ~~ $)] - whileTrue: [ - self failWhen: currentToken isNil. - self scanPast: #externalCallType. - currentToken = '*' - ifTrue: [self scanPast: #externalCallTypePointerIndicator]]. - self scanPast: #rightParenthesis. - currentToken = 'module:' - ifTrue: [ - self scanPast: #module. - self failUnless: currentTokenFirst == $'. - self parseString]. - self failUnless: currentToken = '>'. - self scanPast: #primitiveOrExternalCallEnd! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3013-Shout-ExternalCallFix-JuanVuletich-2016Dec29-11h29m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3013] on 29 December 2016 at 3:36:31 pm'! -!CompiledMethod methodsFor: 'file in/out' stamp: 'jmv 12/29/2016 15:25:13' prior: 16820644! - storeDataOn: aDataStream - "Store myself on a DataStream. I am a mixture of objects and raw data bytes. Only use this for blocks. Normal methodDictionaries should not be put out using ReferenceStreams. Their fileOut should be attached to the beginning of the file." - - | byteLength lits | - "No inst vars of the normal type" - byteLength _ self basicSize. - aDataStream - beginInstance: self class - size: byteLength. - lits _ self numLiterals + 1. "counting header" - 1 to: lits do: - [:ii | aDataStream nextPut: (self objectAt: ii)]. - lits*Smalltalk wordSize+1 to: byteLength do: - [:ii | aDataStream byteStream nextPut: (self basicAt: ii)]. - "write bytes straight through to the file"! ! -!DataStream methodsFor: 'write and read' stamp: 'jmv 12/29/2016 15:27:40' prior: 16827456! - readMethod - "PRIVATE -- Read the contents of an arbitrary instance. - ASSUMES: readDataFrom:size: sends me beginReference: after it - instantiates the new object but before reading nested objects. - NOTE: We must restore the current reference position after - recursive calls to next. - Let the instance, not the class read the data. " - | instSize refPosn newClass className xxHeader nLits byteCodeSizePlusTrailer newMethod lits | - - instSize _ (byteStream nextUnsignedInt32BigEndian: true) - 1. - refPosn _ self getCurrentReference. - className _ self next. - newClass _ Smalltalk at: className asSymbol. - - xxHeader _ self next. - "nArgs _ (xxHeader >> 24) bitAnd: 16rF." - "nTemps _ (xxHeader >> 18) bitAnd: 16r3F." - "largeBit _ (xxHeader >> 17) bitAnd: 1." - nLits _ (xxHeader >> 9) bitAnd: 16rFF. - "primBits _ ((xxHeader >> 19) bitAnd: 16r600) + (xxHeader bitAnd: 16r1FF)." - byteCodeSizePlusTrailer _ instSize - (newClass instSize "0") - (nLits + 1 * Smalltalk wordSize). - - newMethod _ newClass - newMethod: byteCodeSizePlusTrailer - header: xxHeader. - - self setCurrentReference: refPosn. "before readDataFrom:size:" - self beginReference: newMethod. - lits _ newMethod numLiterals + 1. "counting header" - 2 to: lits do: - [:ii | newMethod objectAt: ii put: self next]. - lits*Smalltalk wordSize+1 to: newMethod basicSize do: - [:ii | newMethod basicAt: ii put: byteStream next]. - "Get raw bytes directly from the file" - self setCurrentReference: refPosn. "before returning to next" - ^ newMethod! ! -!DataStream methodsFor: 'other' stamp: 'jmv 12/29/2016 15:36:22' prior: 16827907! - vacantRef - "Answer the magic 32-bit constant we use ***ON DISK*** as a stream 'reference - position' to identify a reference that's not yet filled in. This must be a - value that won't be used as an ordinary reference. Cf. outputReference: and - readReference. -- - NOTE: We could use a different type ID for vacant-refs rather than writing - object-references with a magic value. (The type ID and value are - overwritten by ordinary object-references when weak refs are fullfilled.)" - - "In 32 bit Cuis it was:" - "^ SmallInteger maxVal" - - "Use that very same value even if in 64 bit Cuis. - This means that DataStreams are limited to 1GibiBytes in size." - ^16r3FFFFFFF! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3014-DataStream-FixFor64Bits-JuanVuletich-2016Dec29-15h19m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3000] on 10 December 2016 at 10:41:46 am'! -!Scanner methodsFor: 'multi-character scans' stamp: 'jmv 12/10/2016 01:38:21'! - xBacktick - "Smalltalk code evaluated at compile time as a literal." - - self step. - buffer reset. - [hereChar == $` - and: [aheadChar == $` - ifTrue: [self step. false] - ifFalse: [true]]] - whileFalse: [ - buffer nextPut: self step. - (hereChar = Scanner doItCharacterValue asCharacter and: [source atEnd]) - ifTrue: [^self offEnd: 'Unmatched back quote']]. - self step. - token _ Compiler evaluate: buffer contents. - tokenType _ #literal! ! -!Character methodsFor: 'testing' stamp: 'jmv 12/10/2016 01:26:44' prior: 16800539! - isValidInIdentifiers - "Can c be part of an identifier? (unary or keyword selector, or variable name)" - - ^self isAlphaNumeric or: [ #( $_ ) statePointsTo: self ]! ! -!CompiledMethod methodsFor: 'comparing' stamp: 'jmv 12/10/2016 01:27:06' prior: 16819629! - = method - | numLits lit1 lit2 | - - "Any object is equal to itself" - self == method ifTrue: [ ^ true ]. - - "Answer whether the receiver implements the same code as the - argument, method." - (method is: #CompiledMethod) ifFalse: [ ^false ]. - self size = method size ifFalse: [ ^false ]. - self header = method header ifFalse: [ ^false ]. - self initialPC to: self endPC do: [ :i | - (self at: i) = (method at: i) ifFalse: [ ^false ]]. - (numLits _ self numLiterals) ~= method numLiterals ifTrue: [ ^false ]. - - "Dont bother checking FFI and named primitives'' - jmv: Does this make any sense? - (#(117 120) includes: self primitive) ifTrue: [^ true]." - - "properties" - (self properties analogousCodeTo: method properties) ifFalse: [ - ^false ]. - - "#penultimateLiteral is selector (or properties, just compared, above) - Last literal is #methodClass. - Don't compare them. Two methods might be equal even if they have different selector (or none at all) - or are installed in different classes (or none at all)" - 1 to: numLits-2 do: [ :i | - lit1 _ self literalAt: i. - lit2 _ method literalAt: i. - lit1 = lit2 ifFalse: [ - (i = 1 and: [ #(117 120) includes: self primitive ]) - ifTrue: [ - lit1 isArray - ifTrue: [ - (lit2 isArray and: [ lit1 allButLast = lit2 allButLast ]) ifFalse: [ - ^false ]] - ifFalse: [ "ExternalLibraryFunction" - (lit1 analogousCodeTo: lit2) ifFalse: [ - ^false ]]] - ifFalse: [ - lit1 isFloat - ifTrue: [ - "Floats match if values are close, due to roundoff error." - (lit1 closeTo: lit2) ifFalse: [ ^false ]. - self flag: 'just checking'. self halt ] - ifFalse: [ - "any other discrepancy is a failure" - ^ false ]]]]. - ^true! ! -!Scanner class methodsFor: 'cached class state' stamp: 'jmv 12/10/2016 01:26:17' prior: 16904329! - initTypeTable - | newTable | - newTable := Array new: 256 withAll: #xIllegal. "default" - newTable atAll: #(9 10 12 13 32 ) put: #xDelimiter. "tab lf ff cr space" - - 1 to: 255 - do: [:index | - (Character numericValue: index) isValidInIdentifiers - ifTrue: [ - "Digits and $_ are overwritten later" - newTable at: index put: #xLetter ]]. - - newTable atAll: ($0 numericValue to: $9 numericValue) put: #xDigit. - newTable atAll: '!!%&+-*/\±×÷¬­¯,<=>”•–—˜™š›œ«»?@~€‚ƒŽ‘’“žŸ°·' asByteArray put: #xBinary. - - newTable at: Scanner doItCharacterValue put: #doIt. - newTable at: $" numericValue put: #xDoubleQuote. - newTable at: $# numericValue put: #xLitQuote. - newTable at: $$ numericValue put: #xDollar. - newTable at: $' numericValue put: #xSingleQuote. - newTable at: $` numericValue put: #xBacktick. - newTable at: $: numericValue put: #xColon. - newTable at: $( numericValue put: #leftParenthesis. - newTable at: $) numericValue put: #rightParenthesis. - newTable at: $. numericValue put: #period. - newTable at: $; numericValue put: #semicolon. - newTable at: $[ numericValue put: #leftBracket. - newTable at: $] numericValue put: #rightBracket. - newTable at: ${ numericValue put: #leftBrace. - newTable at: $} numericValue put: #rightBrace. - newTable at: $^ numericValue put: #upArrow. - newTable at: $_ numericValue put: #xUnderscore. - newTable at: $| numericValue put: #verticalBar. - TypeTable := newTable "bon voyage!!" - - " - Scanner initTypeTable - "! ! -!SHParserST80 methodsFor: 'scan' stamp: 'jmv 12/10/2016 01:42:02' prior: 16901958! - scanWhitespace - | c | - - [c := self currentChar. - c notNil and: [c isSeparator or: [c == $`]]] - whileTrue: [sourcePosition := sourcePosition + 1]. - c == $" ifTrue: [self scanComment]! ! -!SHParserST80 methodsFor: 'character testing' stamp: 'jmv 12/10/2016 10:24:38' prior: 16902078! - isBinarySelectorCharacter: aCharacter - - aCharacter isValidInIdentifiers ifTrue: [^false]. - aCharacter isSeparator ifTrue: [^false]. - - ('"#$'':().;[]{}_`' includes: aCharacter) - ifTrue:[^false]. - aCharacter numericValue = Scanner doItCharacterValue ifTrue: [^false "the doIt char"]. - aCharacter numericValue = 0 ifTrue: [^false]. - "Any other char is ok as a binary selector char." - ^true! ! - -Scanner removeSelector: #scanStringStruct! - -Scanner removeSelector: #scanStringStruct! - -Scanner removeSelector: #scanStringStruct:! - -Scanner removeSelector: #scanStringStruct:! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Scanner initTypeTable! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3015-Backticks-JuanVuletich-2016Dec10-10h41m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3015] on 29 December 2016 at 4:06:32 pm'! -!LiteralNode methodsFor: 'printing' stamp: 'jmv 12/29/2016 16:06:13' prior: 16865098! - printOn: aStream indent: level - - key isVariableBinding - ifTrue: [ - key key isNil - ifTrue: [ - aStream nextPutAll: '###'; nextPutAll: key value soleInstance name ] - ifFalse: [ - aStream nextPutAll: '##'; nextPutAll: key key ]] - ifFalse: [ - key isLiteral - ifTrue: [ key storeOn: aStream ] - ifFalse: [ - "Need to generate code for stuff that is in a CompiledMethod literal - but is not understood as a literal by the Compiler. - Well, then it is because it was generated using backticks!!" - aStream nextPut: $`. - key storeOn: aStream. - aStream nextPut: $`. - ] - ]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3016-Backticks-SupportInDecompiler-JuanVuletich-2016Dec29-15h57m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3016] on 30 December 2016 at 10:57:00 am'! -!Scanner methodsFor: 'multi-character scans' stamp: 'jmv 12/30/2016 10:29:16' prior: 50334670! - xBacktick - "Smalltalk code evaluated at compile time as a literal." - - self step. - buffer reset. - [hereChar == $` - and: [aheadChar == $` - ifTrue: [self step. false] - ifFalse: [true]]] - whileFalse: [ - buffer nextPut: self step. - (hereChar = Scanner doItCharacterValue asCharacter and: [source atEnd]) - ifTrue: [^self offEnd: 'Unmatched back quote']]. - self step. - token _ [ Compiler evaluate: buffer contents ] - on: SyntaxErrorNotification, UndeclaredVariableReference, Error - do: [ :ex | - ex class caseOf: { - [ SyntaxErrorNotification ] -> [ - self notify: 'Can not compile: ', ex errorMessage at: mark]. - [ UndeclaredVariableReference ] -> [ - self notify: 'Can not compile: Variable ''', ex varName, ''' is not declared' at: mark ] - } otherwise: [ - self notify: 'Can not evaluate code: ', ex description at: mark ]]. - tokenType _ #literal! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3017-Backticks-betterErrorMessages-JuanVuletich-2016Dec30-10h56m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3016] on 30 December 2016 at 11:00:38 am'! -!Editor class methodsFor: 'class initialization' stamp: 'jmv 12/30/2016 11:00:14' prior: 16836909! - initialize - " - Editor initialize - " - self withAllSubclassesDo: [ :c | - c basicInitialize ]! ! -!TextEditor methodsFor: 'editing keys' stamp: 'jmv 12/30/2016 10:34:01' prior: 16931735! - enclose: aKeyboardEvent - "Insert or remove bracket characters around the current selection." - "This is a user command, and generates undo" - - | left right startIndex stopIndex oldSelection which | - startIndex _ self startIndex. - stopIndex _ self stopIndex. - oldSelection _ self selection. - which _ '([<{"''`' indexOf: aKeyboardEvent keyCharacter ifAbsent: [ ^true ]. - left _ '([<{"''`' at: which. - right _ ')]>}"''`' at: which. - ((startIndex > 1 and: [stopIndex <= model textSize]) - and: [ (model actualContents at: startIndex-1) = left and: [(model actualContents at: stopIndex) = right]]) - ifTrue: [ - "already enclosed; strip off brackets" - self selectFrom: startIndex-1 to: stopIndex. - self replaceSelectionWith: oldSelection] - ifFalse: [ - "not enclosed; enclose by matching brackets" - self replaceSelectionWith: - (Text string: (String with: left) attributes: emphasisHere), - oldSelection, - (Text string: (String with: right) attributes: emphasisHere). - self selectFrom: startIndex+1 to: stopIndex]. - ^true! ! -!TextEditor class methodsFor: 'keyboard shortcut tables' stamp: 'jmv 12/30/2016 10:33:45' prior: 16933087! - basicCmdShortcutsSpec - " - Editor initialize - " - - "arranged in QWERTY keyboard order" - ^#( - #( $( #enclose: 'Enclose within ( and ), or remove enclosing ( and )') - #( $[ #enclose: 'Enclose within [ and ], or remove enclosing [ and ]') - #( ${ #enclose: 'Enclose within { and }, or remove enclosing { and }') - #( $' #enclose: 'Enclose within single quotes, or remove enclosing single quotes') - #( $" #enclose: 'Enclose within double quotes, or remove enclosing double quotes') - #( $` #enclose: 'Enclose within backticks, or remove enclosing backticks') - #( $< #enclose: 'Enclose within < and >, or remove enclosing < and >') - - #( $a #selectAll: 'Select all') - #( $f #find: 'Find') - #( $g #findAgain: 'Find again') - #( $h #help: 'Open this help') - #( $j #setSearchString: 'Set selection as search string for find again') - - #( $z #undo: 'Undo (multiple levels)') - #( $x #cut: 'Cut selection and store it in the Clipboard') - #( $c #copySelection: 'Copy selection to the Clipboard') - #( $v #paste: 'Paste Clipboard contents') - - #( $R #indent: 'Indent (move selection one tab-stap right)') - #( $Y #makeUppercase: 'Force selection to uppercase') - #( $U #changeLineEndsToLf: 'Convert line endings to LF characters (Cuis convention) in selection') - - #( $H #cursorTopHome: 'Move cursor to start of text') - #( $L #outdent: 'Outdent (move selection one tab-stop left)') - - #( $Z #redo: 'Redo (multiple levels)') - #( $X #makeLowercase: 'Force selection to lowercase') - #( $C #compareToClipboard: 'Compare argument to clipboard') - - #( $ #selectWord: 'Select the current word as with double clicking') - )! ! -!SmalltalkEditor methodsFor: 'new selection' stamp: 'jmv 12/30/2016 10:36:10' prior: 16910578! - selectWord - "Select delimited text or word--the result of double-clicking." - - | leftDelimiters rightDelimiters | - "Warning. Once me (jmv) added Character crCharacter to the delimiters, to make double-click at and of line select whole line. - This had the bad effect that if a class name is the last word of a line, double-click would correctly select it, but after that, - doing ctrl-b to browse it would select the whole line..." - leftDelimiters _ '([{<|''"`'. - rightDelimiters _ ')]}>|''"`'. - ^self selectWordLeftDelimiters: leftDelimiters rightDelimiters: rightDelimiters! ! - -Editor initialize! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3018-Backticks-editorSupport-JuanVuletich-2016Dec30-10h57m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3016] on 30 December 2016 at 11:01:51 am'! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 12/30/2016 10:51:03'! - parseBacktick - self enterBlock. - self scanPast: #backtick. - currentTokenFirst == $| ifTrue: [self parseBlockTemporaries]. - self parseStatementList. - self failUnless: currentTokenFirst == $`. - self scanPast: #backtick. - self leaveBlock! ! -!SHParserST80 methodsFor: 'scan' stamp: 'tween 2/17/2007 14:51' prior: 50334801! - scanWhitespace - | c | - - [c := self currentChar. - c notNil and: [c isSeparator]] - whileTrue: [sourcePosition := sourcePosition + 1]. - c == $" ifTrue: [self scanComment]! ! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 12/30/2016 10:51:08' prior: 16902861! - parseTerm - self failWhen: currentToken isNil. - currentTokenFirst == $( - ifTrue: [ - bracketDepth := bracketDepth + 1. - self scanPast: #leftParenthesis level: bracketDepth. - self parseExpression. - self failUnless: currentTokenFirst == $). - self scanPast: #rightParenthesis level: bracketDepth. - bracketDepth := bracketDepth - 1. - ^self ]. - currentTokenFirst == $[ ifTrue: [^self parseBlock]. - currentTokenFirst == $` ifTrue: [^self parseBacktick]. - currentTokenFirst == ${ - ifTrue: [ - self scanPast: #leftBrace. - self parseBraceArray. - ^self ]. - self isName ifTrue: [^self scanPast: (self resolve: currentToken)]. - self parseLiteral: false! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3019-Backticks-BetterShoutSupport-JuanVuletich-2016Dec30-11h00m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3019] on 30 December 2016 at 11:46:58 am'! -!SHTextStylerST80 methodsFor: 'private' stamp: 'jmv 12/30/2016 11:44:19' prior: 50332635! - setAttributesFromRanges: ranges - - formattedText removeAttributesThat: [ :attribute | attribute isForShout ]. - - "Optimize for mutation speed unless method is really large but with very few distict elements: - Source code that includes just big literals is better served by conventional Text+RunArray" - "Do it only if we are not breaking textModel!! (for instance, StyledTextEditor asks for formatting just sections, not whole #actualContents)." - formattedText == textModel actualContents ifTrue: [ - (formattedText size > 2000 and: [ ranges size < 50 ]) ifFalse: [ - formattedText _ formattedText optimizedForMutationSpeed. - textModel basicActualContents: formattedText ]]. - - ranges do: [ :range | - - "Smalltalk text styling" - (self attributesFor: range rangeType) ifNotNil: [ :attributes | - attributes do: [ :each | - formattedText addAttribute: each from: range start to: range end ]]. - - "Show as subscripts if appropriate." - classOrMetaClass ifNotNil: [ - classOrMetaClass theNonMetaClass lastUnderscoreMeansSubscript ifTrue: [ - (#( instVar classVar globalVar workspaceVar poolConstant - patternArg methodArg patternTempVar tempVar - blockPatternArg blockArg blockPatternTempVar blockTempVar - incompleteIdentifier undefinedIdentifier) pointsTo: range rangeType ) - ifTrue: [ - formattedText lastIndexOf: $_ startingAt: range end endingAt: range start do: [ :i | - formattedText addAttribute: ShoutTextEmphasis subscript from: i to: range end ] ]]]]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3020-AvoidUnwantedSubscriptInClassDefinitions-JuanVuletich-2016Dec30-11h45m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3020] on 2 January 2017 at 2:27:29 pm'! -!Preferences class methodsFor: 'personalization' stamp: 'jmv 1/2/2017 14:18:06'! - usePreDebugWindow - ^ self - valueOfFlag: #usePreDebugWindow - ifAbsent: [ false ].! ! -!SystemWindow methodsFor: 'open/close' stamp: 'jmv 1/2/2017 14:11:03'! - initialFrameIn: aWorld - ^RealEstateAgent initialFrameFor: self world: aWorld! ! -!DebuggerWindow methodsFor: 'GUI building' stamp: 'jmv 1/2/2017 14:13:23'! - initialFrameIn: aWorld - | e | - e _ self runningWorld morphExtent. - ^(0@0 corner: e) insetBy: e // 10! ! -!SystemWindow methodsFor: 'open/close' stamp: 'jmv 1/2/2017 14:11:12' prior: 16926575! - openInWorld: aWorld - "This msg and its callees result in the window being activeOnlyOnTop" - | frameRect | - frameRect _ self initialFrameIn: aWorld. - self morphExtent: frameRect extent. - aWorld addMorph: self position: frameRect topLeft. - "Do it deferred. Was needed for text cursor to start blinking if (Preferences disable: #focusFollowsMouse) " - WorldState addDeferredUIMessage: [ self activate ]! ! -!PreDebugWindow class methodsFor: 'instance creation' stamp: 'jmv 1/2/2017 14:19:05' prior: 16892694! - open: model label: aString message: messageString - | window | - Preferences usePreDebugWindow - ifTrue: [ - window _ self new. - window - model: model; - buildMorphicWindowMessage: messageString print. - aString ifNotNil: [ window setLabel: aString ]. - window openInWorld ] - ifFalse: [ - model openFullMorphicLabel: aString ]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3021-DebuggerUsabilityEnh-JuanVuletich-2017Jan02-14h27m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3021] on 3 January 2017 at 9:34:24 pm'! -!WriteStream methodsFor: 'accessing' stamp: 'jmv 1/3/2017 21:22:43'! - nextPutAllString: aString withAttributes: attributesArray - - | newEnd | - (self isCompatibleWithContents: aString) - ifFalse: [ ^ super nextPutAllString: aString withAttributes: attributesArray ]. - - newEnd _ position + aString size. - newEnd > writeLimit ifTrue: [ - self growTo: newEnd + 10]. - - collection - replaceFrom: position+1 - to: newEnd - withString: aString - attributes: attributesArray - startingAt: 1. - position _ newEnd! ! -!WriteStream methodsFor: 'private' stamp: 'jmv 1/3/2017 21:21:34'! - isCompatibleWithContents: aCollection - - collection class == aCollection class - ifTrue: [ ^ true ]. - - (aCollection isString and: [ collection is: #Text]) - ifTrue: [ ^ true ]. - - ^ false! ! -!PositionableStream methodsFor: 'testing' stamp: 'jmv 1/3/2017 10:57:48' prior: 16891569! - isText - "Return true if the receiver is a Text stream" - ^collection is: #Text! ! -!WriteStream methodsFor: 'accessing' stamp: 'jmv 1/3/2017 21:22:51' prior: 16946406! - nextPutAll: aCollection - - | newEnd | - (self isCompatibleWithContents: aCollection) - 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.! ! -!WriteStream methodsFor: 'private' stamp: 'jmv 1/3/2017 10:57:15' prior: 16946621! - withAttribute: aTextAttribute do: streamBlock - | pos1 val | - - (collection is: #Text) ifFalse: [ - ^streamBlock value ]. - - pos1 _ self position. - val _ streamBlock value. - collection addAttribute: aTextAttribute from: pos1+1 to: self position. - ^ val! ! -!WriteStream methodsFor: 'private' stamp: 'jmv 1/3/2017 10:57:19' prior: 16946627! - withAttributes: attributes do: streamBlock - | pos1 val | - - (collection is: #Text) ifFalse: [ - ^streamBlock value ]. - - pos1 _ self position. - val _ streamBlock value. - attributes do: [:attribute | - collection - addAttribute: attribute - from: pos1 + 1 - to: self position]. - ^ val! ! - -Text class removeSelector: #streamContents:! - -Text class removeSelector: #streamContents:! - -Smalltalk removeClassNamed: #TextStream! - -Smalltalk removeClassNamed: #TextStream! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3022-TextStream-removal-JuanVuletich-2017Jan03-21h10m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3022] on 4 January 2017 at 10:42:00 am'! -!SmallInteger methodsFor: 'system primitives' stamp: 'jmv 1/4/2017 10:35:09' prior: 16909090! - digitAt: n - "Answer the value of an indexable field in the receiver. LargePositiveInteger uses bytes of base two number, and each is a 'digit' base 256. Fail if the argument (the index) is not an Integer or is out of bounds." - n > Smalltalk wordSize ifTrue: [^ 0]. - self < 0 - ifTrue: - [self = SmallInteger minVal ifTrue: [ - "Can't negate minVal -- treat specially" - ^ Smalltalk wordSize = 4 - ifTrue: [ #(0 0 0 64) at: n ] - ifFalse: [ #(0 0 0 0 0 0 0 16) at: n ]]. - ^ ((0-self) bitShift: (1-n)*8) bitAnd: 16rFF] - ifFalse: [^ (self bitShift: (1-n)*8) bitAnd: 16rFF]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3023-SmallInteger-digitAt-fixFor64Bits-JuanVuletich-2017Jan04-10h41m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3022] on 4 January 2017 at 10:46:32 am'! - -Integer class removeSelector: #byte1:byte2:byte3:byte4:! - -Integer class removeSelector: #byte1:byte2:byte3:byte4:! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3024-Integer-from4Bytes-removal-JuanVuletich-2017Jan04-10h44m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3024] on 6 January 2017 at 10:05:27 am'! -!WeakArray class methodsFor: 'system startup' stamp: 'jmv 1/6/2017 09:56:14'! -startUp - "Do it even if just continuing after image snapshot" - self restartFinalizationProcess! ! -!SystemDictionary methodsFor: 'startup' stamp: 'jmv 1/6/2017 09:59:32'! - doStartUp: isARealStartup - " - isARealStartup - true: system is coming up (VM and image just started) - false: we have just saved an image snapshot, but didn't quit. - " - - "Here, startup begins!!" - Cursor normal activateCursor. - self setGCParameters. - isARealStartup ifTrue: [ - self clearExternalObjects ]. - self readCommandLineArguments. - self processStartUpList: isARealStartup. - isARealStartup ifTrue: [ - self setPlatformPreferences. - self setStartupStamp ]! ! -!Behavior methodsFor: 'system startup' stamp: 'jmv 1/6/2017 09:52:14' prior: 16785037! - startUp - "This message is sent to registered classes when the system is coming up, or after an image save."! ! -!Behavior methodsFor: 'system startup' stamp: 'jmv 1/6/2017 09:53:18' prior: 16785042! - startUp: isARealStartup - "This message is sent to registered classes, with isARealStartup = true when the system is coming up, - and with isARealStartup = false after a snapshot (image save, no quit). - Classes caring about the difference should reimplement this method." - - ^ self startUp! ! -!WeakArray class methodsFor: 'class initialization' stamp: 'jmv 1/6/2017 09:49:16' prior: 16943683! - initialize - " - WeakArray initialize. - SystemDictionary initialize. - " - - self restartFinalizationProcess! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 1/6/2017 09:53:30' prior: 16922685! - processStartUpList: isARealStartup - "Send #startUp to each class that needs to run initialization after a snapshot." - - EndianCache _ self calcEndianness. - self send: #startUp: toClassesNamedIn: StartUpList with: isARealStartup! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 1/6/2017 09:55:41' prior: 16922813! - send: startUpOrShutDown toClassesNamedIn: startUpOrShutDownList with: argument - "Send the message #startUp: or #shutDown: to each class named in the list. - The argument indicates if the system is about to quit (for #shutDown:) or if - the image is ia real startup (or just continue after image save) (for #startUp:). - If any name cannot be found, then remove it from the list." - - | removals class | - removals _ OrderedCollection new. - startUpOrShutDownList do: - [:name | - class _ self at: name ifAbsent: nil. - class - ifNil: [removals add: name] - ifNotNil: [ - class isInMemory ifTrue: [ - class perform: startUpOrShutDown with: argument]]]. - - "Remove any obsolete entries, but after the iteration" - "Well, not. Better just ignore them. Maybe it is stuff, like SoundPlayer, that was moved to optional packages, and can be loaded again anytime." - "startUpOrShutDownList removeAll: removals"! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 1/6/2017 09:59:34' prior: 16922908! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag -"WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " -| activeProc | -activeProc _ Processor activeProcess. -[ - | isARealStartup world reopenTranscript | - self logSapshot: save andQuit: quit. - - reopenTranscript _ false. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | each isInWorld ifTrue: [ each delete. reopenTranscript _ true ]]. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - - - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - - "Cosas que levanto explicitamente abajo" - world _ ProjectX ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "world _ clearAllStateFlag ifFalse: [ ProjectX ui ]." - ProjectX stopUIProcess. - activeProc isTerminated ifFalse: [ - activeProc terminate ]. - - "Clean Globals" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: nil. - Smalltalk closeSourceFiles. Smalltalk at: #SourceFiles put: nil. - Smalltalk allClassesDo: [ :cls | cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ Smalltalk printStuffToCleanOnImageSave ]. - - - "Do image save & quit as apropriate" - Cursor write activateCursor. - save - ifTrue: [ - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - - - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: (DisplayScreen extent: 1024@768 depth: 32). - Smalltalk at: #SourceFiles put: (Array new: 2). - Smalltalk openSourceFiles. - - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - - - ProjectX spawnNewMorphicProcessFor: (world ifNil: [ PasteUpMorph newWorld ]). - - reopenTranscript ifTrue: [ - WorldState addDeferredUIMessage: [ - TranscriptWindow openTranscript ]]. - " - WorldState addDeferredUIMessage: [ - world fullRepaintNeeded ]. - " - - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - WorldState addDeferredUIMessage: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]. - -] forkAt: Processor timingPriority-1 named: 'Startup process'.! ! - -SystemDictionary removeSelector: #startup:! - -SystemDictionary removeSelector: #startup:! - -WeakArray class removeSelector: #startUp:! - -WeakArray class removeSelector: #startUp:! - -WeakArray initialize! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3025-RestartFinalizationAfterImageSave-JuanVuletich-2017Jan06-09h49m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3025] on 13 January 2017 at 9:55:29 am'! -!LargePositiveInteger methodsFor: 'bit manipulation' stamp: 'jmv 1/13/2017 09:39:07'! - bitXor: arg - "Primitive 36 deals with only 64-bit values (up to 8 byte LargeIntegers). - The inherited deals with - arbitrary sized large integers, but is much slower. - This method gives a performance improvement for integers using 32 to 64 bits on 32 bit VMs, - but only for 62 to 64 bits on 64 bits VMs. - See http://forum.world.st/Integer-arithmetic-and-bit-operations-in-Squeak-and-Pharo-32bit-amp-64bit-tc4928994.html#none - " - - - ^super bitXor: arg! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3026-LargeInteger-bitXor-performanceImprov-JuanVuletich-2017Jan13-09h54m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3025] on 13 January 2017 at 9:55:58 am'! -!SHParserST80 methodsFor: 'parse' stamp: 'ul 10/12/2010 02:43'! - parseStringOrSymbol - - currentTokenFirst == $' ifTrue: [ ^self parseString ]. - currentTokenFirst == $# ifTrue: [ ^self parseSymbol ]. - self error! ! -!SHParserST80 methodsFor: 'parse' stamp: 'jmv 1/13/2017 09:53:38' prior: 16902728! - parsePrimitive - self scanNext. - currentTokenFirst isDigit - ifTrue: [self scanPast: #integer] - ifFalse: [ - self failUnless: currentTokenFirst == $'. - self parseString. - currentToken = 'module:' - ifTrue: [ - self scanPast: #module. - self failUnless: currentTokenFirst == $'. - self parseString]]. - currentToken = 'error:' ifTrue: [ - self scanPast: #primitive. "there's no rangeType for error" - self isName - ifTrue: [ self scanPast: #patternTempVar ] - ifFalse: [ self parseStringOrSymbol ] ]. - self failUnless: currentToken = '>'. - self scanPast: #primitiveOrExternalCallEnd! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3027-ShoutFix-JuanVuletich-2017Jan13-09h55m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3025] on 13 January 2017 at 9:59:33 am'! -!Float methodsFor: 'private' stamp: 'jmv 1/13/2017 09:57:46' prior: 16845694! - replaceWordsFrom: 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." - - - self primitiveFailed! ! -!LargePositiveInteger methodsFor: 'system primitives' stamp: 'jmv 1/13/2017 09:58:53' prior: 16862796! - replaceFrom: start to: stop with: replacement startingAt: repStart - "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." - - - super replaceFrom: start to: stop with: replacement startingAt: repStart! ! -!String methodsFor: 'private' stamp: 'jmv 1/13/2017 09:58:04' prior: 16917188! - replaceFrom: start to: stop with: replacement startingAt: repStart - "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." - - - super replaceFrom: start to: stop with: replacement startingAt: repStart! ! -!Array methodsFor: 'private' stamp: 'jmv 1/13/2017 09:57:31' prior: 16779882! - replaceFrom: start to: stop with: replacement startingAt: repStart - "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." - - - super replaceFrom: start to: stop with: replacement startingAt: repStart! ! -!ByteArray methodsFor: 'private' stamp: 'jmv 1/13/2017 09:57:38' prior: 16793800! - replaceFrom: start to: stop with: replacement startingAt: repStart - "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." - - - super replaceFrom: start to: stop with: replacement startingAt: repStart! ! -!Float64Array methodsFor: 'private' stamp: 'jmv 1/13/2017 09:57:50' prior: 16846133! - replaceWordsFrom: 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." - - - self primitiveFailed! ! -!FloatArray methodsFor: 'private' stamp: 'jmv 1/13/2017 09:58:24' prior: 16846632! -replaceFrom: start to: stop with: replacement startingAt: repStart - "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." - - - super replaceFrom: start to: stop with: replacement startingAt: repStart! ! -!RunNotArray methodsFor: 'private' stamp: 'jmv 1/13/2017 09:58:00' prior: 16901681! - replaceFrom: start to: stop with: replacement startingAt: repStart - "Copied from Array" - "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." - - - super replaceFrom: start to: stop with: replacement startingAt: repStart! ! -!WordArray methodsFor: 'private' stamp: 'jmv 1/13/2017 09:58:38' prior: 16945290! - replaceFrom: start to: stop with: replacement startingAt: repStart - - - super replaceFrom: start to: stop with: replacement startingAt: repStart ! ! -!Bitmap methodsFor: 'accessing' stamp: 'jmv 1/13/2017 09:57:27' prior: 16787571! -replaceFrom: start to: stop with: replacement startingAt: repStart - "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." - - - super replaceFrom: start to: stop with: replacement startingAt: repStart! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3028-GrabErrorCodeForPrim105-JuanVuletich-2017Jan13-09h55m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3028] on 14 January 2017 at 8:18:04 am'! -!Point commentStamp: 'jmv 12/30/2016 17:39:06' prior: 16890200! - I represent an x-y pair of numbers usually designating a location on the screen. - -When dealing with display coordinates, the y axis is usually considered to increase downwards. However, the standard math convention is to consider it increasing upwards. -Points don't need to know about this. In the first case, theta increases clockwise. In the second case, it increases counter-clockwise, also the standard math convention. - -Any method that doesn't follow this (because it assumes one specific convention) include this fact in the selector and in a comment. - -My instances are immutable. See #privateSetX:setY:! -!Point methodsFor: 'private' stamp: 'jmv 12/11/2016 10:28:44'! - privateSetX: xValue setY: yValue - "Points are immutable. Right now this is by convention, but we'll make this enfoced by VM. - Do not all this method, except from instance creation." - x _ xValue. - y _ yValue! ! -!Point methodsFor: 'copying' stamp: 'pb 10/29/2016 18:18:07'! - shallowCopy - "Immutable" - ^ self.! ! -!Object class methodsFor: 'instance creation' stamp: 'jmv 12/30/2016 17:33:31' prior: 16882941! - unStream: aByteArray - ^ ReferenceStream unStream: aByteArray! ! -!DataStream class methodsFor: 'as yet unclassified' stamp: 'jmv 12/30/2016 17:33:27' prior: 16828091! - unStream: aByteArray - - ^(self on: ((RWBinaryOrTextStream with: aByteArray) reset; binary)) next! ! -!Point class methodsFor: 'instance creation' stamp: 'pb 10/29/2016 17:14:00' prior: 16890866! - r: rho degrees: degrees - "Answer an instance of me with polar coordinates rho and theta." - ^ self - rho: rho - theta: degrees asFloat degreesToRadians.! ! -!Point class methodsFor: 'instance creation' stamp: 'pb 10/29/2016 17:12:53' prior: 16890873! - rho: rho theta: radians - "Answer an instance of me with polar coordinates rho and theta." - ^ self - x: rho asFloat * radians cos - y: rho asFloat * radians sin.! ! -!Point class methodsFor: 'instance creation' stamp: 'jmv 12/11/2016 10:28:50' prior: 16890880! - x: anX y: anY - "Answer an instance of me with supplied coordinates." - - ^self new privateSetX: anX setY: anY! ! - -Point removeSelector: #setR:degrees:! - -Point removeSelector: #setR:degrees:! - -Point removeSelector: #setRho:theta:! - -Point removeSelector: #setRho:theta:! - -Point removeSelector: #setX:setY:! - -Point removeSelector: #setX:setY:! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3029-Point-immutable-PhilBellalouna-2017Jan14-08h15m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3029] on 14 January 2017 at 8:53:02 am'! -!SystemDictionary methodsFor: 'code authors' stamp: 'jmv 1/14/2017 08:52:09' prior: 16920588! - knownInitialsAndNames - "This list could include people who hasn't contributed code to the Cuis image, but to some optional package." -" -| all ok | -all _ Smalltalk allContributors asSet. -ok _ (Smalltalk knownInitialsAndNames collect: [ :pair | pair first ]) asSet. -(all copyWithoutAll: ok) print - - initials name" -^ #( - #('ab' 'Alexandre Bergel') - #('abc' 'Colin Putney') - #('acg' 'Andrew C. Greenberg') - #('ads' 'Adam Spitz') - #('AFi' 'Alain Fischer') - #('ajh' 'Anthony Hannan') - #('al' 'Adrian Lienhard') - #('aoy' 'Andres Otaduy') - #('apb' 'Andrew P. Black') - #('ar' 'Andreas Raab') - #('asm' 'Alejandro Magistrello') - #('avi' 'Avi Bryant') - #('BenComan' 'Ben Coman') - #('bf' 'Bert Freudenberg') - #('BG' 'Boris Gaertner') - #('BJP' 'Bijan Parsia') - #('bkv' 'Brent Vukmer') - #('bolot' 'Bolot Kerimbaev') - #('bp' 'Bernhard Pieber') - #('BP' 'Brent Pinkney') - #('brp' 'Brent Pinkney') - #('cbc' 'Chris Cunningham') - #('cbr' 'Casey Ransberger') - #('ccn' 'Chris Norton') - #('cmm' 'Chris Muller') - #('crl' 'Craig Latta') - #('cwp' 'Colin Putney') - #('das' 'David A Smith') - #('dc' 'Damien Cassou') - #('dew' 'Doug Way') - #('dgd' 'Diego Gomez Deck') - #('dkh' 'Dale Henrichs') - #('dhn' 'Dan Norton') - #('dhhi' 'Dan Ingalls') - #('di' 'Dan Ingalls') - #('djp' 'David J. Pennell') - #('DKL' 'Daniel K Lyons') - #('DM' 'Duncan Mak') - #('DSM' 'Duane Maxwell') - #('DSG' 'David Graham') - #('dtl' 'Dave Lewis') - #('dvf' 'Daniel Vainsencher') - #('eat' 'Eric Arseneau Tremblay') - #('eem' 'Eliot Emilio Miranda') - #('eliot' 'Eliot Emilio Miranda') - #('efc' 'Eddie Cottongim') - #('em' 'Ernest Micklei?') - #('emm' 'Ernest Micklei') - #('fbs' 'Frank Shearar') - #('FBS' 'Frank Shearar') - #('fc' 'Frank Caggiano') - #('fcs' 'Frank Sergeant') - #('FernandoOlivero' 'Fernando Olivero') - #('FernanodOlivero' 'Fernando Olivero') - #('GabrielOmarCotelli' 'Gabriel Omar Cotelli') - #('gera' 'Gerardo Richarte') - #('gh' 'Goran Krampe (nee Hultgren)') - #('gk' 'Goran Krampe (nee Hultgren)') - #('gm' 'German Morales') - #('go' 'Georg Gollmann') - #('gsa' 'German Arduino') - #('HAW' 'Hernan Wilkinson') - #('HB' 'Hari Balaraman') - #('hjh' 'Hannes Hirzel') - #('hmm' 'Hans-Martin Mosner') - #('hsj' 'Henrik Sperre Johansen') - #('Igor.Stasenko' 'Igor Stasenko') - #('ikp' 'Ian Piumarta') - #('Jb' 'Jean Baptiste Arnaud') - #('jcg' 'Joshua Gargus') - #('jdr' 'Javier Diaz-Reinoso') - #('je' 'Joern Eyrich') - #('jf' 'Julian Fitzell') - #('JF' 'Julian Fitzell') - #('jhm' 'John Maloney') - #('jk' 'Jonathan Kelly') - #('jlb' 'Jim Benson') - #('jm' ' John Maloney') - #('jmb' 'Hans Baveco') - #('JMG' 'Jeff Gonis') - #('JMM' 'John McIntosh') - #('jmv' 'Juan Vuletich') - #('JMV' 'Juan Vuletich') - #('jp' 'Joseph Pelrine') - #('jrm' 'John-Reed Maffeo') - #('jrp' 'John Pierce') - #('jsp' 'Jeff Pierce') - #('KenD' 'Ken Dickey') - #('kfr' 'Karl Ramberg') - #('KLC' 'Ken Causey') - #('kph' 'Keith Hodges') - #('KTT' 'Kurt Thams') - #('laza' 'Alexander Lazarevic') - #('LC' 'Leandro Caniglia') - #('len' 'Luciano Esteban Notarfrancesco') - #('lpc' 'Laura Perez Cerrato') - #('lr' 'Lukas Renggli') - #('Lukas Renggli' 'Lukas Renggli') - #('ls' 'Lex Spoon') - #('md' 'Marcus Denker') - #('MarcusDenker' 'Marcus Denker') - #('marcus.denker' 'Marcus Denker') - #('mdr' 'Mike Rutenberg') - #('mga' 'Markus Galli') - #('mha' 'Michael Haupt') - #('mir' 'Michael Rueger') - #('mjg' 'Mark Guzdial') - #('mk' 'Matej Kosik') - #('MPH' 'Michael Hewner') - #('mpw' 'Marcel Weiher') - #('MPW' 'Marcel Weiher') - #('mrm' 'Martin McClure') - #('mtf' 'Matthew Fulmer') - #('mu' 'Masashi Umezawa') - #('nb' 'Naala Brewer') - #('nice' 'Nicolas Cellier') - #('nk' 'Ned Konz') - #('nop' 'Jay Carlson') - #('NS' 'Nathanael Schaerli') - #('panda' 'Michael Rueger') - #('pb' 'Phil Bellalouna') - #('PHK' 'Peter Keeler') - #('Pmm' 'Philippe Marschall') - #('pnm' 'Paul McDonough') - #('r++' 'Gerardo Richarte') - #('raa' 'Bob Arning') - #('RAA' 'Bob Arning') - #('raok' 'Richard A. O''Keefe') - #('rca' 'Russell Allen') - #('reThink' 'Paul McDonough') - #('rew' 'Roger Whitney') - #('rhi' 'Robert Hirschfeld') - #('RJT' 'Ron Teitelbaum') - #('rr' 'Romain Robbes') - #('rss' 'Ron Spengler') - #('rw' 'Robert Withers') - #('rww' 'Robert Withers') - #('Sames' 'Samuel S. Shuster') - #('sbw' 'Stephan B. Wessels') - #('sd' 'Stephane Ducasse') - #('SD' 'Stephane Ducasse') - #('sge' 'Steve Elkins') - #('sma' 'Stefan Matthias Aust') - #('sps' 'Steven Swerling') - #('SqR' 'Andres Valloud') - #('sqr' 'Andres Valloud') - #('sr' 'Stephan Rudlof') - #('SSS' 'Samuel S. Shuster') - #('stephane.ducasse' 'Stephane Ducasse') - #('stephaneducasse' 'Stephane Ducasse') - #('stp' 'Stephen Travis Pope') - #('sumim' 'Masato Sumi') - #('svp' 'Stephen Vincent Pair') - #('sw' 'Scott Wallace') - #('TAG' 'Travis Griggs') - #('tak' 'Takashi Yamamiya') - #('tao' 'Tim Olson') - #('TBn' 'Torsten Bergmann') - #('tfei' 'The Fourth Estate, Inc.') - #('tfel' 'Tim Felgentreff') - #('th' 'Torge Husfeldt') - #('tk' 'Ted Kaehler') - #('tlk' 'Tom Koenig') - #('tpr' 'Tim Rowledge') - #('TPR' 'Tim Rowledge') - #('tween' 'Andy Tween') - #('ul' 'Levente Uzonyi') - #('vb' 'Vassili Bykov') - #('ward' 'Ward Cunningham') - #('wiz' 'Jerome Peace') - #('wod' 'Bill Dargel') - #('yo' 'Yoshiki Ohshima') - #('zz' 'Serge Stinckwich'))! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3030-AddHernanAndGeraToKnownAuthors-JuanVuletich-2017Jan14-08h52m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3025] on 10 January 2017 at 8:09:15 pm'! - -Object subclass: #TestResultForDebuggingAndInspection - instanceVariableNames: 'testResult' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Testing'! - -!classDefinition: #TestResultForDebuggingAndInspection category: #'Tools-Testing'! -Object subclass: #TestResultForDebuggingAndInspection - instanceVariableNames: 'testResult' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Testing'! -!CompiledMethod methodsFor: 'testing' stamp: 'HernanWilkinson 1/10/2017 18:22:10'! - isTestMethod - - ^ (self methodClass is: #TestCaseClass) - and: [ ((self selector beginsWith: 'test') or: [ (self selector beginsWith: 'should')]) - and: [ self numArgs isZero ] ]! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HernanWilkinson 1/10/2017 19:35:14'! - acceptAndTest - - ^self acceptThenTestMethodAndSuite: [ :aMethod | self testSuiteOf: aMethod methodClass ]! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HernanWilkinson 1/10/2017 19:35:34'! - acceptAndTestAll - - ^self acceptThenTestMethodAndSuite: [ :aMethod | self testSuiteForCategoryOf: aMethod methodClass ] - - ! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HernanWilkinson 1/10/2017 19:04:06'! - acceptThenTestMethodAndSuite: aSuiteBuilder - - | potencialTestMethod | - - self acceptContents ifFalse: [ ^false ]. - - potencialTestMethod _ model textProvider currentCompiledMethod. - self runAndDebuggIfNecessary: potencialTestMethod. - ^(self runTestSuite: (aSuiteBuilder value: potencialTestMethod)) hasPassed - ! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HernanWilkinson 1/10/2017 18:50:03'! - flashWith: aColor - - ^morph flashWith: aColor! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HernanWilkinson 1/10/2017 18:50:21'! -flashWithGreen - - ^self flashWith: Color green - - - - ! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HernanWilkinson 1/10/2017 19:03:07'! - runAndDebuggIfNecessary: aPotentialTestMethod - - aPotentialTestMethod isTestMethod ifTrue: [ - aPotentialTestMethod methodClass debug: aPotentialTestMethod selector ]! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HernanWilkinson 1/10/2017 19:04:42'! - runTestSuite: aTestSuite - - | suiteRunResult | - - suiteRunResult _ aTestSuite run. - suiteRunResult hasPassed - ifTrue: [self flashWithGreen ] - ifFalse: [ suiteRunResult forDebuggingAndInspection inspect ]. - - ^suiteRunResult - - - - ! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HernanWilkinson 1/10/2017 19:35:52'! - testSuiteForCategoryOf: aClass - - | testCaseClasses | - - testCaseClasses _ (SystemOrganization listAtCategoryNamed: aClass category) - collect: [ :aClassName | Smalltalk classNamed: aClassName ] - thenSelect: [ :aClassInCategory | aClassInCategory is: #TestCaseClass ]. - - - ^testCaseClasses - inject: (TestSuite named: 'Test of Category ', aClass category) - into: [ :suite :testCaseClass | testCaseClass addToSuiteFromSelectors: suite ]! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HernanWilkinson 1/10/2017 19:34:58'! - testSuiteOf: aPotentialTestCaseClass - - ^(aPotentialTestCaseClass is: #TestCaseClass) - ifTrue: [ aPotentialTestCaseClass buildSuite ] - ifFalse: [ TestSuite named: 'Tests of ', aPotentialTestCaseClass name ]! ! -!DisplayScreen methodsFor: 'displaying' stamp: 'HernanWilkinson 1/10/2017 18:45:48'! - flash: aRectangle with: aColor - - self fill: aRectangle fillColor: aColor. - self forceToScreen: aRectangle. - (Delay forMilliseconds: 100) wait. - self fill: aRectangle fillColor: aColor. - self forceToScreen: aRectangle! ! -!Morph methodsFor: 'macpal' stamp: 'HernanWilkinson 1/10/2017 18:49:44'! - flashWith: aColor - - self morphBoundsInWorld ifNotNil: [ :r | Display flash: r with: aColor ]! ! -!InnerTextMorph methodsFor: 'editing' stamp: 'HernanWilkinson 1/10/2017 15:56:51'! - confirmAcceptAnyway - - ^ self confirm: -'Caution!! Contents were saved -elsewhere since you started -editing them here. Accept anyway?'! ! -!TestCase class methodsFor: 'Testing' stamp: 'HernanWilkinson 1/10/2017 16:29:48'! - is: aSymbol - - ^aSymbol == #TestCaseClass or: [ super is: aSymbol ]! ! -!TestResult methodsFor: 'Inspecting' stamp: 'HernanWilkinson 1/10/2017 16:33:03'! - forDebuggingAndInspection - - ^TestResultForDebuggingAndInspection on: self! ! -!TestResultForDebuggingAndInspection methodsFor: 'initialization' stamp: 'HernanWilkinson 1/10/2017 16:34:56'! - initializeOn: aTestResult - - testResult _ aTestResult! ! -!TestResultForDebuggingAndInspection methodsFor: 'printing' stamp: 'HernanWilkinson 1/10/2017 17:49:59'! - print: aCollectionOfTestCases startingWith: header on: aStream - - aCollectionOfTestCases - do: [ :aTestCase | - aStream - nextPutAll: header; - space; - nextPutAll: aTestCase class name; - nextPutAll: ' debug: #'; - nextPutAll: aTestCase selector ] - separatedBy: [ aStream newLine ]. - - ! ! -!TestResultForDebuggingAndInspection methodsFor: 'printing' stamp: 'HernanWilkinson 1/10/2017 17:49:05'! - printOn: aStream - - aStream print: testResult. - aStream newLine. - - self print: testResult errors startingWith: '"E"' on: aStream. - self print: testResult failures startingWith: '"F"' on: aStream. - ! ! -!TestResultForDebuggingAndInspection methodsFor: 'running' stamp: 'HernanWilkinson 1/10/2017 18:14:09'! - reRun - - | suite | - - suite _ TestSuite new. - suite addTests: testResult tests. - - testResult _ suite run.! ! -!TestResultForDebuggingAndInspection class methodsFor: 'instance creation' stamp: 'HernanWilkinson 1/10/2017 16:34:28'! - on: aTestResult - - ^self new initializeOn: aTestResult! ! -!TextEditor methodsFor: 'menu messages' stamp: 'HernanWilkinson 1/10/2017 16:00:24' prior: 16932076! - acceptContents - "Save the current text of the text being edited as the current acceptable version for purposes of canceling. Allow my morph to take appropriate action" - ^morph acceptContents! ! -!SmalltalkEditor class methodsFor: 'keyboard shortcut tables' stamp: 'HernanWilkinson 1/10/2017 19:58:01' prior: 16910705! - initializeMenu - "Initialize the mouseButton2 (right button) pop-up menu and corresponding messages." - " - Editor initialize - " - - menu _ SelectionMenu fromArray: { - {'Help...'. #openHelp}. - #-. - {'Do it (d)'. #doIt}. - {'Print it (p)'. #printIt}. - {'Inspect it (i)'. #inspectIt}. - {'Explore it (I)'. #exploreIt}. - {'Debug it (D)'. #debugIt}. - {'Profile it'. #profileIt}. - #-. - {'Explain'. #explain}. - {'Browse it (b)'. #browseIt}. - {'Senders of it (n)'. #sendersOfIt}. - {'Implementors of it (m)'. #implementorsOfIt}. - {'References to it (N)'. #referencesToIt}. - #-. - {'Method Strings with it (E)'. #methodStringsContainingit}. - {'Method Source with it'. #methodSourceContainingIt}. - {'Class Comments with it'. #classCommentsContainingIt}. - #-. - {'Accept (s)'. #acceptContents}. - {'Cancel (l)'. #cancelEdits}. - {'Accept & Run Test in Class (t)'. #acceptAndTest}. - {'Accept & Run Test in Category (y)'. #acceptAndTestAll}. - #-. - {'More...'. #getMenu2}. - }. - menu2 _ SelectionMenu fromArray: { - {'Find...(f)'. #find}. - {'Find Again (g)'. #findAgain}. - {'Use Selection for Find (j)'. #setSearchString}. - #-. - {'Undo - multiple (z)'. #undo}. - {'Redo - multiple (Z)'. #redo}. - {'Undo / Redo history'. #offerUndoHistory}. - #-. - {'Copy (c)'. #copySelection}. - {'Cut (x)'. #cut}. - {'Paste (v)'. #paste}. - {'Paste without Format'. #pasteString}. - {'Paste...'. #pasteRecent}. - #-. - {'Toggle WordWrap'. #wrapOnOff}. - {'Set Font... (k)'. #offerFontMenu}. - {'Clear Font'. #clearFont}. - {'Set Default Font...'. #offerDefaultFontMenu}. - #-. - {'More...'. #getMenu}. - }! ! -!InspectorWindow methodsFor: 'GUI building' stamp: 'HernanWilkinson 1/10/2017 17:47:44' prior: 16857247! - initialExtent - - ^600@325! ! -!InnerTextMorph methodsFor: 'editing' stamp: 'HernanWilkinson 1/10/2017 19:46:39' prior: 16855583! - acceptContents - "The message is sent when the user hits return or Cmd-S. - Accept the current contents and end editing." - "Inform the model of text to be accepted, and return true if OK." - - | accepted prevSelection prevScrollValue | - - prevSelection _ self editor selectionInterval copy. - prevScrollValue _ owner verticalScrollBar value. - - (self canDiscardEdits and: [(self hasProperty: #alwaysAccept) not]) ifTrue: [self flash. ^true]. - (self hasEditingConflicts and: [ self confirmAcceptAnyway not ]) ifTrue: [self flash. ^false]. - - accepted _ model acceptContentsFrom: owner. - "During the step for the browser, updatePaneIfNeeded is called, and - invariably resets the contents of the code-holding PluggableTextMorph - at that time, resetting the cursor position and scroller in the process. - The following line forces that update without waiting for the step, - then restores the cursor and scrollbar" - - "some implementors of acceptContentsFrom: answer self :(" - ^accepted == true - ifTrue: [ - model refetch. - self editor selectFrom: prevSelection first to: prevSelection last. - WorldState addDeferredUIMessage: [ - self world ifNotNil: [ :w | w activeHand newKeyboardFocus: self ]. - owner verticalScrollBar setValue: prevScrollValue]. - true] - ifFalse: [ false ]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3031-TDDSupport-0-HernanWilkinson.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3025] on 10 January 2017 at 8:09:22 pm'! -!SmalltalkEditor methodsFor: 'editing keys' stamp: 'HernanWilkinson 1/10/2017 20:04:06'! - acceptAndTest: aKeyboardEvent - - ^self acceptAndTest! ! -!SmalltalkEditor methodsFor: 'editing keys' stamp: 'HernanWilkinson 1/10/2017 20:04:34'! - acceptAndTestAll: aKeyboardEvent - - ^self acceptAndTestAll! ! -!SmalltalkEditor methodsFor: 'editing keys' stamp: 'HernanWilkinson 1/10/2017 20:02:27'! - debugIt: aKeyboardEvent - - self debugIt. - ^true! ! -!SmalltalkEditor class methodsFor: 'keyboard shortcut tables' stamp: 'HernanWilkinson 1/10/2017 20:03:23' prior: 16910661! - cmdShortcutsSpec - " - Editor initialize - " - "arranged in QWERTY keyboard order" - ^#( - #( $t #acceptAndTest: 'Saves method, runs it as test and then all tests in class. Opens debugger if error') - #( $y #acceptAndTestAll: 'Saves method, runs it as test and then all tests in class category. Opens debugger if error') - #( $i #inspectIt: 'Inspect it (selection is a valid expression, or selection is over an inspect-ilst)') - #( $p #printIt: 'Print it (selection is a valid expression)') - - #( $s #save: 'Save (i.e. accept)') - #( $d #doIt: 'Do it (selection is a valid expression)') - #( $l #cancelEdits: 'Cancel') - - #( $b #browseIt: 'Browse it (selection is a class name or cursor is over a class-list or message-list)') - #( $n #sendersOfIt: 'Senders of it (selection is a message selector or cursor is over a class-list or message-list)') - #( $m #implementorsOfIt: 'Implementors of it (selection is a message selector or cursor is over a class-list or message-list)') - - #( $E #methodStringsContainingit:'Method strings containing it') - #( $T #displayIfTrue: 'Insert #ifTrue:') - #( $I #exploreIt: 'Inspect via Object Explorer') - - #( $A #argAdvance: 'Advance argument') - #( $D #debugIt: 'Debut it') - #( $F #displayIfFalse: 'Insert #ifFalse:') - #( $G #fileItIn: 'File in selection') - - #( $V #pasteInitials: 'Paste author initials') - #( $N #referencesToIt: 'References to it (selection is a class name, or cursor is over a class-list or message-list)') - )! ! -!SmalltalkEditor class methodsFor: 'keyboard shortcut tables' stamp: 'HernanWilkinson 1/10/2017 19:58:01' prior: 50336255! - initializeMenu - "Initialize the mouseButton2 (right button) pop-up menu and corresponding messages." - " - Editor initialize - " - - menu _ SelectionMenu fromArray: { - {'Help...'. #openHelp}. - #-. - {'Do it (d)'. #doIt}. - {'Print it (p)'. #printIt}. - {'Inspect it (i)'. #inspectIt}. - {'Explore it (I)'. #exploreIt}. - {'Debug it (D)'. #debugIt}. - {'Profile it'. #profileIt}. - #-. - {'Explain'. #explain}. - {'Browse it (b)'. #browseIt}. - {'Senders of it (n)'. #sendersOfIt}. - {'Implementors of it (m)'. #implementorsOfIt}. - {'References to it (N)'. #referencesToIt}. - #-. - {'Method Strings with it (E)'. #methodStringsContainingit}. - {'Method Source with it'. #methodSourceContainingIt}. - {'Class Comments with it'. #classCommentsContainingIt}. - #-. - {'Accept (s)'. #acceptContents}. - {'Cancel (l)'. #cancelEdits}. - {'Accept & Run Test in Class (t)'. #acceptAndTest}. - {'Accept & Run Test in Category (y)'. #acceptAndTestAll}. - #-. - {'More...'. #getMenu2}. - }. - menu2 _ SelectionMenu fromArray: { - {'Find...(f)'. #find}. - {'Find Again (g)'. #findAgain}. - {'Use Selection for Find (j)'. #setSearchString}. - #-. - {'Undo - multiple (z)'. #undo}. - {'Redo - multiple (Z)'. #redo}. - {'Undo / Redo history'. #offerUndoHistory}. - #-. - {'Copy (c)'. #copySelection}. - {'Cut (x)'. #cut}. - {'Paste (v)'. #paste}. - {'Paste without Format'. #pasteString}. - {'Paste...'. #pasteRecent}. - #-. - {'Toggle WordWrap'. #wrapOnOff}. - {'Set Font... (k)'. #offerFontMenu}. - {'Clear Font'. #clearFont}. - {'Set Default Font...'. #offerDefaultFontMenu}. - #-. - {'More...'. #getMenu}. - }! ! -!InnerTextMorph methodsFor: 'editing' stamp: 'HernanWilkinson 1/10/2017 19:46:39' prior: 50336320! - acceptContents - "The message is sent when the user hits return or Cmd-S. - Accept the current contents and end editing." - "Inform the model of text to be accepted, and return true if OK." - - | accepted prevSelection prevScrollValue | - - prevSelection _ self editor selectionInterval copy. - prevScrollValue _ owner verticalScrollBar value. - - (self canDiscardEdits and: [(self hasProperty: #alwaysAccept) not]) ifTrue: [self flash. ^true]. - (self hasEditingConflicts and: [ self confirmAcceptAnyway not ]) ifTrue: [self flash. ^false]. - - accepted _ model acceptContentsFrom: owner. - "During the step for the browser, updatePaneIfNeeded is called, and - invariably resets the contents of the code-holding PluggableTextMorph - at that time, resetting the cursor position and scroller in the process. - The following line forces that update without waiting for the step, - then restores the cursor and scrollbar" - - "some implementors of acceptContentsFrom: answer self :(" - ^accepted == true - ifTrue: [ - model refetch. - self editor selectFrom: prevSelection first to: prevSelection last. - WorldState addDeferredUIMessage: [ - self world ifNotNil: [ :w | w activeHand newKeyboardFocus: self ]. - owner verticalScrollBar setValue: prevScrollValue]. - true] - ifFalse: [ false ]! ! - -Editor initialize! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3032-TDDSupport-1-HernanWilkinson.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3025] on 12 January 2017 at 5:14:29 pm'! -!Debugger methodsFor: 'as yet unclassified' stamp: 'HAW 1/12/2017 17:05:16'! - askForSuperclassOf: aClass toImplement: aSelector ifCancel: cancelBlock - - | classes chosenClassIndex | - - classes _ aClass withAllSuperclasses. - chosenClassIndex _ PopUpMenu - withCaption: 'Define #', aSelector, ' in which class?' - chooseFrom: (classes collect: [:c | c name]). - chosenClassIndex = 0 ifTrue: [^ cancelBlock value]. - - ^ classes at: chosenClassIndex! ! -!Debugger methodsFor: 'as yet unclassified' stamp: 'HAW 1/12/2017 17:09:46'! - create - - self shouldBeAbleToCreateMethod - ifTrue: [ self createMethod ] - ifFalse: [ self inform: 'Only available for doesNotUndertand:' ]! ! -!Debugger methodsFor: 'as yet unclassified' stamp: 'HAW 1/12/2017 17:04:29'! - createMethod - - | message chosenClass interruptedContext | - - interruptedContext _ self interruptedContext. - message _ interruptedContext tempAt: 1. - chosenClass _ self - askForSuperclassOf: interruptedContext receiver class - toImplement: message selector - ifCancel: [^self]. - self implement: message inClass: chosenClass. -! ! -!Debugger methodsFor: 'as yet unclassified' stamp: 'HAW 1/12/2017 17:01:22'! - shouldBeAbleToCreateMethod - - ^self interruptedContext selector == #doesNotUnderstand:! ! -!DebuggerWindow methodsFor: 'GUI building' stamp: 'HAW 1/12/2017 17:04:50' prior: 16831115! - customButtonSpecs - "Answer an array of elements of the form wording, selector, help-message, that characterize the custom button row of a debugger." - - ^#( - ('Restart' restart 'reset this context to its start.') - ('Into' send 'step Into message sends') - ('Over' doStep 'step Over message sends') - ('Through' stepIntoBlock 'step into a block') - ('Full Stack' fullStack 'show full stack') - ('Where' where 'select current pc range') - ('Create' create 'create method'))! ! -!PreDebugWindow methodsFor: 'GUI building' stamp: 'HAW 1/12/2017 17:06:02' prior: 16892577! - buttonRowForPreDebugWindow: aDebugger - | row aButton triads buttons | - buttons _ OrderedCollection new. - triads _ OrderedCollection withAll: self preDebugButtonSpec. - (aDebugger shouldBeAbleToCreateMethod) ifTrue: [ - triads add: { 'Create'. #createMethod. 'create the missing method' } - ]. - triads do: [ :triad | - aButton _ PluggableButtonMorph new model: self. - aButton label: triad first. - aButton action: triad second. - aButton setBalloonText: triad third. - buttons add: aButton]. - - row _ LayoutMorph newRow. - row doAdoptWidgetsColor. - row color: Color transparent. - row separation: 1. - row addMorphs: buttons. - ^row! ! -!PreDebugWindow methodsFor: 'button actions' stamp: 'HAW 1/12/2017 17:06:43' prior: 16892636! - createMethod - "Should only be called when this Debugger was created in response to a - MessageNotUnderstood exception. Create a stub for the method that was - missing and proceed into it." - - model createMethod. - self debug -! ! - -PreDebugWindow removeSelector: #askForSuperclassOf:toImplement:ifCancel:! - -PreDebugWindow removeSelector: #askForSuperclassOf:toImplement:ifCancel:! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3033-CreateMethodSupport-HernanWilkinson-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3025] on 12 January 2017 at 6:54:23 pm'! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'HAW 1/12/2017 18:29:00'! - allSuperclassesUpTo: aSuperclass - - | superclasses | - - ^ superclass = aSuperclass - ifTrue: [ OrderedCollection with: aSuperclass] - ifFalse: [superclasses _ superclass allSuperclassesUpTo: aSuperclass. - superclasses addFirst: superclass. - superclasses]! ! -!Behavior methodsFor: 'accessing class hierarchy' stamp: 'HAW 1/12/2017 18:30:53'! - withAllSuperclassesUpTo: aSuperclass - - | classes | - - classes _ self allSuperclassesUpTo: aSuperclass. - classes addFirst: self. - - ^ classes! ! -!ContextPart methodsFor: 'debugger access' stamp: 'HAW 1/12/2017 17:48:35'! - arguments - - | arguments | - - arguments _ Array new: self selector numArgs. - 1 to: arguments size do: [ :index | arguments at: index put: (self tempAt: index)]. - - ^arguments. - - ! ! -!ContextPart methodsFor: 'debugger access' stamp: 'HAW 1/12/2017 17:47:30'! -messageForYourself - - ^Message selector: self selector arguments: self arguments. - ! ! -!Debugger methodsFor: 'method creation' stamp: 'HAW 1/12/2017 18:31:14'! - askForSuperclassOf: aClass upTo: aSuperclass toImplement: aSelector ifCancel: cancelBlock - - | classes chosenClassIndex | - - classes _ aClass withAllSuperclassesUpTo: aSuperclass. - chosenClassIndex _ PopUpMenu - withCaption: 'Define #', aSelector, ' in which class?' - chooseFrom: (classes collect: [:c | c name]). - chosenClassIndex = 0 ifTrue: [^ cancelBlock value]. - - ^ classes at: chosenClassIndex! ! -!Debugger methodsFor: 'method creation' stamp: 'HAW 1/12/2017 18:45:03'! - createMethodOnSubclassResponsibility - - | message chosenClass subclassResponsibilityContext | - - subclassResponsibilityContext _ self interruptedContext sender sender. - message _ subclassResponsibilityContext messageForYourself. - - chosenClass _ self - askForSuperclassOf: subclassResponsibilityContext receiver class - upTo: subclassResponsibilityContext method methodClass - toImplement: message selector - ifCancel: [^self]. - - self implement: message inClass: chosenClass context: subclassResponsibilityContext - -! ! -!Debugger methodsFor: 'method creation' stamp: 'HAW 1/12/2017 18:43:11'! - createMethodWhenDoesNotUndertand - - | message chosenClass interruptedContext | - - interruptedContext _ self interruptedContext. - message _ interruptedContext tempAt: 1. - - chosenClass _ self - askForSuperclassOf: interruptedContext receiver class - toImplement: message selector - ifCancel: [^self]. - - self implement: message inClass: chosenClass context: self selectedContext - -! ! -!Debugger methodsFor: 'method creation' stamp: 'HAW 1/12/2017 18:43:25'! - implement: aMessage inClass: aClass context: aContext - - aClass - compile: aMessage createStubMethod - classified: (self askForCategoryIn: aClass default: 'as yet unclassified'). - - aContext privRefreshWith: (aClass lookupSelector: aMessage selector). - aMessage arguments withIndexDo: [ :arg :index | aContext tempAt: index put: arg ]. - self resetContext: aContext! ! -!Debugger methodsFor: 'method creation' stamp: 'HAW 1/12/2017 17:22:28'! - wasInterrupedOnDoesNotUnderstand - - ^self interruptedContext selector == #doesNotUnderstand:! ! -!Debugger methodsFor: 'method creation' stamp: 'HAW 1/12/2017 17:25:23'! - wasInterruptedOnSubclassResponsibility - - ^self interruptedContext sender ifNil: [ false ] ifNotNil: [ :senderContext | senderContext selector == #subclassResponsibility ]! ! -!Debugger methodsFor: 'method creation' stamp: 'HAW 1/12/2017 18:31:48' prior: 50336551! - askForSuperclassOf: aClass toImplement: aSelector ifCancel: cancelBlock - - ^self askForSuperclassOf: aClass upTo: ProtoObject toImplement: aSelector ifCancel: cancelBlock -! ! -!Debugger methodsFor: 'method creation' stamp: 'HAW 1/12/2017 18:46:00' prior: 50336572! - createMethod - - self wasInterrupedOnDoesNotUnderstand ifTrue: [ ^self createMethodWhenDoesNotUndertand ]. - self wasInterruptedOnSubclassResponsibility ifTrue: [ ^self createMethodOnSubclassResponsibility ]. - - self inform: 'Only available for #doesNotUndertand: and #subclassResponsibility' ! ! -!Debugger methodsFor: 'method creation' stamp: 'HAW 1/12/2017 17:22:47' prior: 50336585! - shouldBeAbleToCreateMethod - - ^self wasInterrupedOnDoesNotUnderstand or: [ self wasInterruptedOnSubclassResponsibility]! ! -!DebuggerWindow methodsFor: 'GUI building' stamp: 'HAW 1/12/2017 18:46:32' prior: 50336591! - customButtonSpecs - "Answer an array of elements of the form wording, selector, help-message, that characterize the custom button row of a debugger." - - ^#( - ('Restart' restart 'reset this context to its start.') - ('Into' send 'step Into message sends') - ('Over' doStep 'step Over message sends') - ('Through' stepIntoBlock 'step into a block') - ('Full Stack' fullStack 'show full stack') - ('Where' where 'select current pc range') - ('Create' createMethod 'create method'))! ! -!PreDebugWindow methodsFor: 'GUI building' stamp: 'HAW 1/12/2017 18:47:35' prior: 50336610! - buttonRowForPreDebugWindow: aDebugger - | row aButton triads buttons | - buttons _ OrderedCollection new. - triads _ OrderedCollection withAll: self preDebugButtonSpec. - aDebugger shouldBeAbleToCreateMethod ifTrue: [ triads add: { 'Create'. #createMethod. 'create the missing method' }]. - - triads do: [ :triad | - aButton _ PluggableButtonMorph new model: self. - aButton label: triad first. - aButton action: triad second. - aButton setBalloonText: triad third. - buttons add: aButton]. - - row _ LayoutMorph newRow. - row doAdoptWidgetsColor. - row color: Color transparent. - row separation: 1. - row addMorphs: buttons. - ^row! ! - -Debugger removeSelector: #create! - -Debugger removeSelector: #create! - -Debugger removeSelector: #implement:inClass:! - -Debugger removeSelector: #implement:inClass:! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3034-CreateMethodSupport-HernanWilkinson-1-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3032] on 14 January 2017 at 9:09:47 am'! -!Theme methodsFor: 'menus' stamp: 'jmv 1/14/2017 09:09:05' prior: 16936064! - miscellaneousIcons - - "Everything else." - - ^ { - #('restore display (r)' 'set display depth...' 'move windows onscreen' 'Utilities saveDisplay.') -> #displayIcon. - #('changes...' 'dual change sorter' 'change sets with this method' 'find a change sorter' 'recent changes in file' 'Undo / Redo history' 'code file contents' 'package file contents') -> #changesIcon. - #('Install New Updates' 'update' 'turn on auto-update (a)' 'update list (u)' 'install code' 'fileIn entire file' 'install package') -> #updateIcon. - #('find again (g)' 'full stack (k)') -> #systemIcon. - #('print it (p)' 'check change set for slips') -> #printIcon. - #('accept (s)' 'make changes go to me (m)') -> #acceptIcon. - #('cancel (l)' 'turn off auto-update (a)') -> #cancelIcon. - #('debug...' 'Debug it (D)' 'toggle break on entry') -> #debugIcon. - #('close' 'close all debuggers' 'close top window') -> #closeIcon. - #('collapse' 'hide taskbar' 'collapse all windows') -> #collapseIcon. - #('expand / contract' 'show taskbar' 'restore all windows') -> #expandIcon. - #('menu') -> #windowMenuIcon. - #('browse all' 'browser' 'browse it (b)' 'MessageTally UI and browse' 'browse recent submissions' 'browse full (b)' 'find changed browsers...' 'browse (b)' 'browse my changes') -> #editFindReplaceIcon. - #('workspace' 'workspace with contents') -> #terminalIcon. - #('styled text editor' 'text editor' 'basic text editor' 'unicode editor' 'edit this list' 'edit postscript...' 'add postscript...') -> #textEditorIcon. - #('file list' 'find a fileList' 'compress file') -> #systemFileManagerIcon. - #('transcript' 'find a transcript' 'Transcript clear.' 'log to transcript') -> #printerIcon. - #('process browser' 'vm statistics' 'MessageTally all Processes') -> #systemMonitorIcon. - #('emergency evaluator' 'conflicts with other change sets' 'check for slips' 'conflicts with change set opposite' 'conflicts with category opposite') -> #emblemImportantIcon. - #('change sorter') -> #halfRefreshIcon. - #('SUnit Test Runner' 'Accept & Run Test in Class (t)' 'Accept & Run Test in Category (y)') -> #weatherFewCloudsIcon. - #('Font Sizes...' 'system fonts...' 'set font... (k)') -> #preferencesDesktopFontIcon. - #('full screen on') -> #viewFullscreenIcon. - #('full screen off') -> #exitFullscreenIcon. - #('set desktop color...') -> #wallpaperIcon. - #('preferences...' 'All preferences...' 'what to show...' 'view as hex') -> #preferencesIcon. - #('Editor keyboard shortcuts') -> #keyboardShortcutsIcon. - #('world menu help') -> #globeIcon. "currently unused, but a neat icon" - #('useful expressions' 'class comments with it' 'check for uncommented methods' 'check for uncommented classes') -> #chatIcon. - #('set code author...' 'check for other authors' 'check for any other authors') -> #usersIcon. - #('space left') -> #removableMediaIcon. - #('start drawing all again' 'window color...') -> #graphicsIcon. - #('start stepping again') -> #mediaPlaybackStartIcon. - #('file out current change set' 'fileOut' 'File out and remove (o)' 'File out and keep (k)') -> #fileOutIcon. - #('recently logged changes...' 'versions (v)' 'recent classes... (r)' 'trim history' 'Profile it') -> #clockIcon. - #('senders of it (n)' 'senders of... (n)' 'local senders of...' 'senders (n)') -> #mailForwardIcon. - #('implementors of it (m)' 'implementors of... (m)' 'implementors of sent messages') -> #developmentIcon. - #('references to it (N)') -> #addressBookIcon. - #('class var refs...' 'class refs (N)' 'class variables' 'class vars' 'local implementors of...' 'subclass template') -> #classIcon. - #('inst var refs...' 'inst var defs...' 'sample instance') -> #instanceIcon. - #('Use Selection for Find (j)' 'rename class ...' 'rename...' 'change title...') -> #saveAsIcon. - #('smalltalk options' 'method source with it' 'browse method (O)' 'check for uncategorized methods') -> #scriptIcon. - #('method strings with it (E)' 'Toggle WordWrap') -> #genericTextIcon. - #('browse hierarchy (h)' 'move to top' 'promote to top of list') -> #goTopIcon. - #('move up' 'make next-to-topmost') -> #goUpIcon. - #('move to bottom' 'send to back' 'send top window to back') -> #goBottomIcon. - #('inheritance (i)' 'move down') -> #goDownIcon. - #('browse protocol (p)' 'spawn sub-protocol') -> #spreadsheetIcon. - #('spawn full protocol') -> #speadsheetTemplateIcon. - #('alphabetize') -> #fontXGenericIcon. - #('Installed Packages' 'browse' 'show category (C)' 'categorize all uncategorized' 'select change set...' 'view affected class categories') -> #packageIcon. - #('remove from current change set' 'remove empty categories' 'subtract other side (-)' 'remove from this browser') -> #listRemoveIcon. - #('add to current change set' 'add all meths to current chgs' 'add preamble (p)' 'More...') -> #listAddIcon. - #('toggle diffing (D)' 'toggle selections') -> #switchIcon. - #('reorganize' 'create inst var accessors' 'ChangeSorter reorderChangeSets.' 'reorder all change sets' 'by name' 'by size' 'by date') -> #sendReceiveIcon. - #('unsent methods' 'unreferenced class vars' 'unreferenced inst vars' 'Undeclared inspect.' 'Undeclared removeUnreferencedKeys; inspect.' 'ChangeSorter removeEmptyUnnamedChangeSets.' 'check for unsent messages') -> #junkIcon. - #('find changed windows...') -> #newWindowIcon. - #('make undraggable') -> #pushPinIcon. - #('Utilities saveScreenshot.') -> #stillCameraIcon. - #('add new directory') -> #newFolderIcon. - #('select all' 'deselect all') -> #selectAllIcon. - #('sort by date') -> #dateIcon. - #('justified') -> #formatJustifyFillIcon. - #('centered') -> #formatJustifyCenterIcon. - #('set alignment...' 'leftFlush') -> #formatJustifyLeftIcon. - #('rightFlush') -> #formatJustifyRightIcon. - #('signal Semaphore (S)') -> #haloHelpIcon. - #('Change Paragraph Style...' 'Change Character Style...' 'Remove Character Style' 'Replace all uses of Paragraph Style...' 'Replace all uses of Character Style...' 'Set Default Font...') -> #fontXGenericIcon. - #('Clear Font') -> #newIcon. - #('code file browser' 'package file browser') -> #findIcon. - }! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." -Theme current class beCurrent! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3035-AddIconsForTDDSupport-JuanVuletich-2017Jan14-09h07m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3035] on 16 January 2017 at 11:04:32 am'! - -(Smalltalk classNamed: 'Taskbar') ifNotNil: [ :tbClass | - PasteUpMorph allInstancesDo: [ :w | w hideTaskbar ]. - tbClass allInstancesDo: [ :each | each delete ]]! - -StringMorph subclass: #UpdatingStringMorph - instanceVariableNames: 'target getSelector stepTime' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - -!classDefinition: #UpdatingStringMorph category: #'Morphic-Widgets'! -StringMorph subclass: #UpdatingStringMorph - instanceVariableNames: 'target getSelector stepTime' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! -!UpdatingStringMorph commentStamp: 'jmv 1/5/2013 23:49' prior: 0! - UpdatingStringMorph new - target: [self runningWorld activeHand morphPosition asString]; - getSelector: #value; - stepTime: 10; - openInWorld! - -LayoutMorph subclass: #TaskbarMorph - instanceVariableNames: 'viewBox scale' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Taskbar'! - -!classDefinition: #TaskbarMorph category: #'Tools-Taskbar'! -LayoutMorph subclass: #TaskbarMorph - instanceVariableNames: 'viewBox scale' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Taskbar'! -!TaskbarMorph commentStamp: '' prior: 0! - A simple task bar written for Cuis. - -dashBoard contains views/controls -viewBox contains graphic buttons of "iconized" windows/morphs. -scale allows 1x 2x 4x tarkbar height. [scale= 1,2,4]! -!Preferences class methodsFor: 'personalization' stamp: 'jmv 1/15/2017 18:51:02'! - taskbarIncludesAllWindows - " - true: All windows are included in Taskbar - false: Only collapsed windows are included in Taskbar - " - ^ self - valueOfFlag: #taskbarIncludesAllWindows - ifAbsent: [ true ].! ! -!Morph methodsFor: 'accessing' stamp: 'jmv 1/15/2017 18:06:45'! - taskbar - ^self world ifNotNil: [ :w | w taskbar ]! ! -!Morph methodsFor: 'submorphs-add/remove' stamp: 'jmv 1/15/2017 14:52:58'! -showAndComeToFront - - self show; comeToFront! ! -!PasteUpMorph methodsFor: 'change reporting' stamp: 'jmv 1/16/2017 09:56:14'! - addedMorph: aMorph - "Notify the receiver that the given morph was just added." - super addedMorph: aMorph. - self taskbar ifNotNil: [ :tb | - tb wasOpened: aMorph ]! ! -!PasteUpMorph methodsFor: 'change reporting' stamp: 'jmv 1/16/2017 09:56:07'! - removedMorph: aMorph - "Notify the receiver that aMorph was just removed from its children" - super removedMorph: aMorph. - self taskbar ifNotNil: [ :tb | - tb wasDeleted: aMorph ]! ! -!PasteUpMorph methodsFor: 'taskbar' stamp: 'jmv 1/15/2017 18:57:53'! - taskbarDeleted - taskbar _ nil! ! -!UpdatingStringMorph methodsFor: 'accessing' stamp: 'jmv 1/4/2013 13:15'! - getSelector: aSymbol - getSelector _ aSymbol! ! -!UpdatingStringMorph methodsFor: 'accessing' stamp: 'jmv 1/4/2013 13:18'! - stepTime - - ^stepTime! ! -!UpdatingStringMorph methodsFor: 'accessing' stamp: 'jmv 1/4/2013 13:15'! - stepTime: aNumber - stepTime _ aNumber! ! -!UpdatingStringMorph methodsFor: 'accessing' stamp: 'jmv 1/4/2013 13:15'! - target: anObject - target _ anObject! ! -!UpdatingStringMorph methodsFor: 'initialization' stamp: 'jmv 9/13/2013 09:23'! - initialize - super initialize. - target _ self. - getSelector _ #contents. - stepTime _ 50! ! -!UpdatingStringMorph methodsFor: 'stepping' stamp: 'jmv 2/27/2016 20:07'! - stepAt: millisecondSinceLast - - self contents: (target perform: getSelector)! ! -!UpdatingStringMorph methodsFor: 'stepping' stamp: 'jmv 1/4/2013 13:18'! - wantsSteps - "Return true if the receiver wants to its #step or #stepAt: methods be run" - - ^true! ! -!UpdatingStringMorph methodsFor: 'geometry' stamp: 'jmv 1/15/2017 14:25:27'! - fitContents - "Don't shrink each time contents change. - Might shrink during layout" - self morphExtent: (extent max: self measureContents)! ! -!UpdatingStringMorph class methodsFor: 'new-morph participation' stamp: 'jmv 4/15/2014 09:26'! - initializedInstance - "Answer a digital clock" - - | newInst | - newInst := self - contents: '' - font: (AbstractFont familyName: 'DejaVu' pointSize: 22) - emphasis: AbstractFont boldCode. - newInst - stepTime: 500; "half a second" - target: [String streamContents: [ :strm | DateAndTime now printHMSOn: strm]] ; - getSelector: #value. - - ^ newInst! ! -!TaskbarMorph methodsFor: 'accessing' stamp: 'jmv 1/15/2017 14:49:41'! - buttonFor: aMorph - - viewBox ifNotNil: [ - viewBox submorphs do: [ :button | - button model == aMorph - ifTrue: [ ^button ]] - ]. - ^nil! ! -!TaskbarMorph methodsFor: 'accessing' stamp: 'jmv 1/15/2017 14:49:30'! - scale - - ^ scale ifNil: [ self defaultScale ] ifNotNil: [ scale ]! ! -!TaskbarMorph methodsFor: 'events' stamp: 'jmv 1/8/2017 16:48:00'! - notifyDisplayResize - Display - when: #screenSizeChanged - send: #screenSizeChanged - to: self. - self screenSizeChanged! ! -!TaskbarMorph methodsFor: 'events' stamp: 'jmv 1/8/2017 16:48:14'! - screenSizeChanged - "Respond to change in screen size by repositioning self to bottom of screen" - -" Transcript newLine; print: 'Taskbar screenSizeChanged'. -" - | y e | - WorldState addDeferredUIMessage: [ - self world ifNotNil: [ :w | - y _ w morphExtent y - self defaultHeight. - e _ self internalizeDistance: w morphExtent x @ self defaultHeight. - self morphPosition: 0@y extent: e ]]! ! -!TaskbarMorph methodsFor: 'initialization' stamp: 'jmv 1/15/2017 14:49:51'! - defaultHeight - - ^ Preferences windowTitleFont height * 2 * self scale! ! -!TaskbarMorph methodsFor: 'initialization' stamp: 'jmv 1/15/2017 14:49:19'! - defaultScale - - ^ 1! ! -!TaskbarMorph methodsFor: 'initialization' stamp: 'jmv 1/8/2017 16:57:33'! - initialize - super initialize. - viewBox _ LayoutMorph newRow color: self defaultColor. - self - addMorph: UpdatingStringMorph initializedInstance - layoutSpec: (LayoutSpec morphWidthProportionalHeight: 1.0). - self - addMorph: viewBox - layoutSpec: (LayoutSpec - proportionalWidth: 1.0 - proportionalHeight: 1.0 - minorDirectionPadding: #right). - viewBox separation: 5 -! ! -!TaskbarMorph methodsFor: 'testing' stamp: 'jmv 1/8/2017 16:44:53'! - is: aSymbol - ^ aSymbol == #TaskbarMorph or: [ super is: aSymbol ]! ! -!TaskbarMorph methodsFor: 'testing' stamp: 'jmv 1/8/2017 16:47:41'! - isSticky - "answer whether the receiver is Sticky" - ^true! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 1/15/2017 18:42:23'! - addButtonFor: aMorph - - | button | - button _ PluggableButtonMorph - model: aMorph - stateGetter: nil - action: #showAndComeToFront. - button - color: self color; - icon: (aMorph imageForm: 32); - setBalloonText: aMorph label. - viewBox - addMorph: button - fixedWidth: self defaultHeight! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 1/15/2017 18:20:11'! - removeButtonFor: aMorph - - (self buttonFor: aMorph) ifNotNil: [ :b | - b delete ]! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 1/15/2017 18:49:21'! - restoreAll - viewBox ifNotNil: [ - viewBox submorphs do: [ :button | - button model showAndComeToFront ] ]! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 1/15/2017 18:23:09'! - wasCollapsed: aMorph - "Add a button for aMorph if not already there (see #taskbarIncludesAllWindows)" - - (self buttonFor: aMorph) ifNil: [ - self addButtonFor: aMorph ]! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 1/15/2017 18:25:27'! - wasDeleted: aMorph - "aMorph was deleted. Remove button for aMorph" - - self removeButtonFor: aMorph! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 1/15/2017 18:19:22'! - wasMadeVisible: aMorph - "aMorph is now visible. Remove button for aMorph if appropriate (see #taskbarIncludesAllWindows)" - - Preferences taskbarIncludesAllWindows ifFalse: [ - self removeButtonFor: aMorph ]! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 1/15/2017 18:21:15'! - wasOpened: aMorph - "aMorph was added to the world. Add button for aMorph if appropriate (see #taskbarIncludesAllWindows)" - - Preferences taskbarIncludesAllWindows ifTrue: [ - self addButtonFor: aMorph ]! ! -!TaskbarMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 1/15/2017 18:57:58'! -delete - - | w | - self restoreAll. - super delete. - w _ self world ifNil: [ self runningWorld ]. - Display removeActionsWithReceiver: self. - w ifNotNil: [ w taskbarDeleted ]! ! -!TaskbarMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 1/16/2017 09:52:23'! - noteNewOwner: aMorph - "I have just been added as a submorph of aMorph" - super noteNewOwner: aMorph. - Preferences taskbarIncludesAllWindows ifTrue: [ - aMorph submorphsDo: [ :m | - m == self ifFalse: [ - self addButtonFor: m ]]]. - self notifyDisplayResize! ! -!TaskbarMorph methodsFor: 'menus' stamp: 'jmv 1/15/2017 19:14:11'! - handlesMouseDown: aMouseButtonEvent - - ^ true! ! -!TaskbarMorph methodsFor: 'menus' stamp: 'jmv 1/15/2017 19:10:57'! - mouseButton2Activity - - | menu | - menu _ MenuMorph new defaultTarget: self. - menu - addLine; - add: 'Normal Height' action: #scaleNormal; - add: 'Scale x 2' action: #scaleX2; - add: 'Scale x 4' action: #scaleX4. - menu popUpInWorld! ! -!TaskbarMorph methodsFor: 'resize' stamp: 'jmv 1/15/2017 19:01:25'! - scale: anInteger - - (anInteger between: 1 and: 4) ifFalse: [ self error: 'scale should be 1 2 or 4' ]. - scale := anInteger. - self screenSizeChanged. "rescale self" - viewBox ifNotNil: [ "rescale buttons" - viewBox submorphs do: [ :button | - button layoutSpec fixedWidth: self defaultHeight - ] - ]! ! -!TaskbarMorph methodsFor: 'resize' stamp: 'jmv 1/15/2017 19:00:49'! - scaleNormal - - self scale: 1! ! -!TaskbarMorph methodsFor: 'resize' stamp: 'jmv 1/15/2017 19:00:52'! - scaleX2 - - self scale: 2! ! -!TaskbarMorph methodsFor: 'resize' stamp: 'jmv 1/15/2017 19:00:55'! - scaleX4 - - self scale: 4! ! -!TaskbarMorph class methodsFor: 'system startup' stamp: 'jmv 1/8/2017 16:47:17'! - initClassCachedState - - "Should use some other way to find relevant instances" - self flag: #jmvVer2. - self allInstancesDo: [ :each | - each notifyDisplayResize ]! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 1/15/2017 18:24:25' prior: 16874345! - visible: aBoolean - "set the 'visible' attribute of the receiver to aBoolean" - - self visible == aBoolean - ifTrue: [ ^ self ]. - aBoolean ifFalse: [ - self redrawNeeded ]. - self setProperty: #visible toValue: aBoolean. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - aBoolean ifTrue: [ - self redrawNeeded. - self taskbar ifNotNil: [ :tb | - tb wasMadeVisible: self ]]! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'jmv 1/15/2017 14:58:58' prior: 16875692! - comeToFrontAndAddHalo - self show. - self comeToFront. - self addHalo! ! -!Morph methodsFor: 'menus' stamp: 'jmv 1/15/2017 18:24:40' prior: 16876276! - collapse - "If taskbar not visible, just hide." - - self hide. - self taskbar - ifNotNil: [ :tb | tb wasCollapsed: self ]! ! -!Morph methodsFor: 'menus' stamp: 'jmv 1/15/2017 14:59:12' prior: 16876281! - expand - - self show. - self comeToFront! ! -!Morph methodsFor: 'testing' stamp: 'jmv 1/15/2017 15:04:18' prior: 16876985! - isCollapsed - - ^ self visible not! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 1/8/2017 16:44:57' prior: 16887743! - allNonWindowRelatedSubmorphs - "Answer all non-window submorphs that are not flap-related" - - ^submorphs - reject: [ :m | (m is: #SystemWindow) or: [ m is: #TaskbarMorph ] ]! ! -!PasteUpMorph methodsFor: 'taskbar' stamp: 'jmv 1/15/2017 14:43:48' prior: 16887920! - showTaskbar - - taskbar ifNil: [ - taskbar _ TaskbarMorph newRow. - taskbar openInWorld: self ]! ! -!StringMorph methodsFor: 'geometry' stamp: 'jmv 1/15/2017 14:22:53' prior: 16918181! - measureContents - | f | - f _ self fontToUse. - ^((f widthOfString: contents) max: 3) @ f height! ! - -TaskbarMorph removeSelector: #intoWorld:! - -PasteUpMorph removeSelector: #isCollapsed:! - -PasteUpMorph removeSelector: #isCollapsed:! - -PasteUpMorph removeSelector: #minimize:! - -PasteUpMorph removeSelector: #minimize:! - -PasteUpMorph removeSelector: #restore:! - -PasteUpMorph removeSelector: #restore:! - -PasteUpMorph removeSelector: #taskbar:! - -PasteUpMorph removeSelector: #taskbar:! - -PasteUpMorph allInstancesDo: [ :w | w showTaskbar ]! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3036-NewTaskbar-JuanVuletich-2017Jan16-10h55m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3036] on 17 January 2017 at 11:13:18 am'! -!DebuggerWindow methodsFor: 'GUI building' stamp: 'jmv 1/17/2017 10:51:52'! - initialExtent - ^ RealEstateAgent standardWindowExtent * 3 // 2! ! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 1/17/2017 11:12:27' prior: 16898269! - maximumUsableAreaInWorld: aWorldOrNil - - | allowedArea | - allowedArea _ Display boundingBox. - aWorldOrNil ifNotNil: [ - allowedArea _ allowedArea intersect: aWorldOrNil viewBox. - aWorldOrNil taskbar ifNotNil: [ :tb | - allowedArea _ (allowedArea areasOutside: tb morphBoundsInWorld) first ]]. - ^allowedArea -! ! -!PasteUpMorph methodsFor: 'geometry' stamp: 'jmv 1/17/2017 11:00:35' prior: 16887247! - privateExtent: newExtent - - ^ (super privateExtent: newExtent) - ifTrue: [ - self buildMagnifiedBackgroundImage. - worldState clearCanvas ]; yourself! ! -!PasteUpMorph methodsFor: 'project state' stamp: 'jmv 1/17/2017 10:56:23' prior: 16887422! - viewBox - - ^ worldState - ifNotNil: [ - 0@0 extent: extent ] - ifNil: [ - self world viewBox ]! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 1/17/2017 11:05:24' prior: 16887834! - restoreMorphicDisplay - DisplayScreen startUp. - self - morphExtent: Display extent; - handsDo: [ :h | h visible: true ]; - fullRepaintNeeded. - WorldState addDeferredUIMessage: [ Cursor normal activateCursor ]! ! -!PasteUpMorph class methodsFor: 'instance creation' stamp: 'jmv 1/17/2017 11:04:44' prior: 16887959! - newWorld - " -[ - ProjectX stopUIProcess. - ProjectX spawnNewMorphicProcessFor: PasteUpMorph newWorld -] fork. - " - | w ws | - w _ self new. - ws _ WorldState new. - w worldState: ws. - w morphPosition: 0@0 extent: Display extent. - ws setCanvas: Display getCanvas. - w borderWidth: 0. - ws handsDo: [ :h | - h privateOwner: w ]. - ^w! ! -!WorldState methodsFor: 'canvas' stamp: 'jmv 1/17/2017 10:57:47' prior: 16945711! - ensureNonDisplayCanvas - (canvas isNil or: [ - canvas drawsOnDisplay or: [ - (canvas extent ~= world morphExtent) or: [ - canvas form depth ~= Display depth]]]) ifTrue: [ - "allocate a new offscreen canvas the size of the window" - self setCanvas: (BitBltCanvas withExtent: world morphExtent depth: Display depth)]! ! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 1/17/2017 11:05:18' prior: 16946039! - tryDeferredUpdatingAndSetCanvasFor: aWorld - "If this platform supports deferred updates, then make my canvas be the Display (or a rectangular portion of it), set the Display to deferred update mode, and answer true. Otherwise, set a non-Disply canvas and answer false.." - | properDisplay | - - "As this is the only sender of #deferUpdates: , this could be done in Morphic or image startup, and never efterwards..." - (Display deferUpdates: true) ifNil: [ - "deferred updates not supported by the VM, do them in the image!!" - self ensureNonDisplayCanvas. - ^ false]. - - "if no canvas, or canvas was offscreen, from a platform that didnt support defers, then fix it" - properDisplay _ canvas notNil and: [canvas drawsOnDisplay]. - properDisplay ifFalse: [ - aWorld morphPosition: 0@0 extent: Display extent. - self setCanvas: Display getCanvas. - ]. - ^ true! ! -!WorldState methodsFor: 'drawing' stamp: 'jmv 7/28/2015 08:35' prior: 16946090! - displayWorld: aWorld submorphs: submorphs - "Update this world's display." - - | deferredUpdateVMMode worldDamageRects handsToDraw allDamage | - self checkIfUpdateNeeded ifFalse: [ ^ self ]. "display is already up-to-date" - "I (jmv) removed the call to 'deferUpdates: false' below. No more need to call this every time." - deferredUpdateVMMode _ self tryDeferredUpdatingAndSetCanvasFor: aWorld. - - "repair world's damage on canvas" - worldDamageRects _ self drawInvalidAreasWorld: aWorld submorphs: submorphs. - - "Check which hands need to be drawn (they are not the hardware mouse pointer)" - handsToDraw _ self selectHandsToDrawForDamage: worldDamageRects. - allDamage _ Array streamContents: [ :strm | - strm nextPutAll: worldDamageRects. - handsToDraw do: [ :h | - h savePatchFrom: canvas appendDamageTo: strm ]]. - - "Draw hands (usually carying morphs) onto world canvas" - canvas newClipRect: nil. - handsToDraw reverseDo: [ :h | canvas fullDrawHand: h ]. - - "quickly copy altered rects of canvas to Display:" - deferredUpdateVMMode ifFalse: [ - "Drawing was done to off-Display canvas. Copy content to Display" - canvas showAt: aWorld viewBox origin invalidRects: allDamage ]. - - "Display deferUpdates: false." - "Display forceDisplayUpdate" - Display forceDamageToScreen: allDamage. - - "Restore world canvas under hands and their carried morphs" - handsToDraw do: [ :h | h restoreSavedPatchOn: canvas ].! ! - -WorldState removeSelector: #viewBox! - -WorldState removeSelector: #viewBox! - -WorldState removeSelector: #viewBox:! - -WorldState removeSelector: #viewBox:! - -DebuggerWindow removeSelector: #initialFrameIn:! - -DebuggerWindow removeSelector: #initialFrameIn:! - -PasteUpMorph removeSelector: #viewBox:! - -PasteUpMorph removeSelector: #viewBox:! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3037-WindowsAvoidTaskbarArea-JuanVuletich-2017Jan17-10h47m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3037] on 18 January 2017 at 10:36:09 am'! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 1/18/2017 10:34:55' prior: 50337258! - addButtonFor: aMorph - - | button | - aMorph == self ifFalse: [ - button _ PluggableButtonMorph - model: aMorph - stateGetter: nil - action: #showAndComeToFront. - button - color: self color; - icon: (aMorph imageForm: 32); - setBalloonText: aMorph label. - viewBox - addMorph: button - fixedWidth: self defaultHeight ]! ! -!TaskbarMorph methodsFor: 'submorphs-add/remove' stamp: 'jmv 1/18/2017 10:35:05' prior: 50337321! - noteNewOwner: aMorph - "I have just been added as a submorph of aMorph" - super noteNewOwner: aMorph. - Preferences taskbarIncludesAllWindows ifTrue: [ - aMorph submorphsDo: [ :m | - self addButtonFor: m ]]. - self notifyDisplayResize! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3038-TaskbarTweaks-JuanVuletich-2017Jan18-10h34m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3038] on 18 January 2017 at 7:35:13 pm'! -!DirectoryEntry methodsFor: 'enumeration' stamp: 'jmv 1/18/2017 11:20:57'! - fileMatching: pattern -" - DirectoryEntry smalltalkImageDirectory fileMatching: '*.image'. - DirectoryEntry smalltalkImageDirectory fileMatching: 'x*.image'. -" - self filesDo: [ :file | - (pattern match: file name) - ifTrue: [ ^ file ]]. - ^ nil! ! -!DirectoryEntry methodsFor: 'enumeration' stamp: 'jmv 1/18/2017 11:13:59' prior: 16834484! - directoriesDo: aBlock - self childrenDo: [ :each | - each isFile ifFalse: [ - aBlock value: each ]]! ! -!DirectoryEntry methodsFor: 'enumeration' stamp: 'jmv 1/18/2017 11:19:42' prior: 16834701! - directoryMatching: pattern -" - DirectoryEntry smalltalkImageDirectory directoryMatching: 'C*Pack*'. - DirectoryEntry smalltalkImageDirectory directoryMatching: 'xC*Pack*'. -" - self directoriesDo: [ :directory | - (pattern match: directory name) - ifTrue: [ ^ directory ]]. - ^ nil! ! -!DirectoryEntry methodsFor: 'enumeration' stamp: 'jmv 1/18/2017 11:14:17' prior: 16834493! - filesDo: aBlock - self childrenDo: [ :each | - each isFile ifTrue: [ - aBlock value: each ]]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3039-DirectoryEntryTweaks-JuanVuletich-2017Jan18-19h34m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3039] on 18 January 2017 at 10:26:44 pm'! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 1/18/2017 22:25:29' prior: 50337619! - addButtonFor: aMorph - - | button | - aMorph == self ifFalse: [ - button _ PluggableButtonMorph - model: aMorph - stateGetter: nil - action: #showAndComeToFront. - button - color: self color; - icon: (aMorph imageForm: 32); - setBalloonText: aMorph label. - button icon: button magnifiedIcon. - viewBox - addMorph: button - fixedWidth: self defaultHeight ]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3040-DontWasteMemoryOnTaskbarButtons-JuanVuletich-2017Jan18-22h26m-jmv.1.cs.st----! - -----SNAPSHOT----#(18 January 2017 10:36:10.429049 pm) Cuis5.0-3040-spur-64.image priorSource: 83443! - -----QUIT----#(18 January 2017 10:36:23.953152 pm) Cuis5.0-3040-spur-64.image priorSource: 193992! - -----STARTUP----#(20 February 2017 12:08:31.543295 pm) as /home/juan/Rectifier/Cuis-Smalltalk-Dev/Cuis5.0-3040-spur-64.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3040] on 22 January 2017 at 9:33:48 pm'! -!PasteUpMorph methodsFor: 'geometry' stamp: 'jmv 1/22/2017 21:17:32' prior: 50337474! - privateExtent: newExtent - - ^ (super privateExtent: newExtent) - ifTrue: [ - self buildMagnifiedBackgroundImage. - worldState ifNotNil: [ - worldState clearCanvas ]]; - yourself! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 1/22/2017 21:25:10' prior: 16926091! - drawOn: aCanvas - - | titleColor roundCorners | - - titleColor _ self widgetsColor. - self isTopWindow - ifTrue: [ titleColor _ titleColor lighter ]. - - roundCorners _ Theme current roundWindowCorners. - roundCorners - ifTrue: [ - "Round corners. Optional title gradient." - self drawRoundedFrameOn: aCanvas color: titleColor ] - ifFalse: [ - "No round corners. No title gradient." - self drawClassicFrameOn: aCanvas color: titleColor ]. - Theme current minimalWindows - ifFalse: [ - labelString ifNotNil: [self drawLabelOn: aCanvas]]! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 1/22/2017 21:31:40' prior: 16866779! - popUpInWorld: aWorld - "Present this menu under control of the given hand." - "Needed if not the real world but an inner PasteUpMorph" - | positionInWorld | - positionInWorld _ aWorld internalizeFromWorld: aWorld activeHand morphPosition. - ^self - popUpAt: positionInWorld - forHand: aWorld activeHand - in: aWorld -! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3041-Fix-clearCanvas-DNU-JuanVuletich-2017Jan22-21h17m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #2974] on 3 December 2016 at 9:04:32 am'! -!Integer methodsFor: 'private' stamp: 'nice 1/19/2013 03:13'! - montgomeryDigitBase - "Answer the base used by Montgomery algorithm." - ^1 << self montgomeryDigitLength! ! -!Integer methodsFor: 'private' stamp: 'nice 1/19/2013 03:27'! - montgomeryDigitLength - "Answer the number of bits composing a digit in Montgomery algorithm. - Primitive use either 8 or 32 bits digits" - - ^8 "Legacy plugin which did not have this primitive did use 8 bits digits"! ! -!Integer methodsFor: 'private' stamp: 'nice 1/19/2013 03:14'! - montgomeryDigitMax - "Answer the maximum value of a digit used in Montgomery algorithm." - - ^1 << self montgomeryDigitLength - 1! ! -!Integer methodsFor: 'private' stamp: 'nice 1/19/2013 03:16'! - montgomeryNumberOfDigits - "Answer the number of montgomery digits required to represent the receiver." - ^self digitLength * 8 + (self montgomeryDigitLength - 1) // self montgomeryDigitLength! ! -!Integer methodsFor: 'mathematical functions' stamp: 'nice 1/16/2013 18:38' prior: 16859768! - raisedTo: n modulo: m - "Answer the modular exponential. - Note: this implementation is optimized for case of large integers raised to large powers." - | a s mInv | - n = 0 ifTrue: [^1]. - (self >= m or: [self < 0]) ifTrue: [^self \\ m raisedTo: n modulo: m]. - n < 0 ifTrue: [^(self reciprocalModulo: m) raisedTo: n negated modulo: m]. - (n < 4096 or: [m even]) - ifTrue: - ["Overhead of Montgomery method might cost more than naive divisions, use naive" - ^self slidingLeftRightRaisedTo: n modulo: m]. - - mInv := self montgomeryDigitBase - ((m bitAnd: self montgomeryDigitMax) reciprocalModulo: self montgomeryDigitBase). - - "Initialize the result to R=self montgomeryDigitModulo raisedTo: m montgomeryNumberOfDigits" - a := (1 bitShift: m montgomeryNumberOfDigits * m montgomeryDigitLength) \\ m. - - "Montgomerize self (multiply by R)" - (s := self montgomeryTimes: (a*a \\ m) modulo: m mInvModB: mInv) - ifNil: - ["No Montgomery primitive available ? fallback to naive divisions" - ^self slidingLeftRightRaisedTo: n modulo: m]. - - "Exponentiate self*R" - a := s montgomeryRaisedTo: n times: a modulo: m mInvModB: mInv. - - "Demontgomerize the result (divide by R)" - ^a montgomeryTimes: 1 modulo: m mInvModB: mInv! ! -!Integer methodsFor: 'testing' stamp: 'nice 11/14/2011 21:59' prior: 16860231! - isProbablyPrime - "See isProbablyPrimeWithK:andQ: for the algoritm description." - - | k q | - self <= 1 ifTrue: [ ^false ]. - self even ifTrue: [ ^self = 2 ]. - "Factor self into (2 raisedTo: k) * q + 1, where q odd" - q := self bitShift: -1. - k := q lowBit. - q := q bitShift: 1 - k. - "Repeat the probabilistic until false (the probability of false negative is null) or until probability is very low." - 25 timesRepeat: [ (self isProbablyPrimeWithK: k andQ: q) ifFalse: [ ^false ] ]. - "The probability of false positive after 25 iterations is less than (1/4 raisedTo: 25) < 1.0e-15" - ^true! ! -!Integer methodsFor: 'private' stamp: 'nice 11/15/2011 23:13' prior: 16860590! - isProbablyPrimeWithK: k andQ: q - "Algorithm P, probabilistic primality test, from - Knuth, Donald E. 'The Art of Computer Programming', Vol 2, - Third Edition, section 4.5.4, page 395, P1-P5 refer to Knuth description.. - Note that this is a Miller Rabin test which may answer false positives (known as pseudoprimes) for at most 1/4 of the possible bases x." - - | x j y minusOne | - "P1" - x := (self - 2) atRandom + 1. - "P2" - j := 0. - y := x raisedTo: q modulo: self. - minusOne := self - 1. - - ["P3" - y = 1 ifTrue: [^j = 0]. - y = minusOne ifTrue: [^true]. - "P4" - (j := j + 1) < k] - whileTrue: - [y := y squared \\ self]. - "P5" - ^false! ! -!Integer methodsFor: 'private' stamp: 'nice 1/16/2013 18:40' prior: 16860675! - montgomeryTimes: a modulo: m mInvModB: mInv - "Answer the result of a Montgomery multiplication - self * a * (b raisedTo: m montgomeryNumberOfDigits) inv \\ m - NOTE: it is assumed that: - self montgomeryNumberOfDigits <= m montgomeryNumberOfDigits - a montgomeryNumberOfDigits <= m montgomeryNumberOfDigits - mInv * m \\ b = (-1 \\ b) = (b-1) (this implies m odd) - where b = self montgomeryDigitBase - - Answer nil in case of absent plugin or other failure." - - - ^nil! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3042-MontgomeryExponentiationFix-LucianoEstebanNotarfrancesco-2016Nov29-21h10m-len.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3042] on 22 January 2017 at 9:49:56 pm'! -!Integer methodsFor: 'arithmetic' stamp: 'len 12/4/2016 13:11:44'! - reciprocalModulo2: n - "Answer an integer x such that self * x \\ n = 1, with 0 < x < n, or nil if it doesn't exist." - | xgcd | - self == 0 ifTrue: [^ nil]. - self == 1 ifTrue: [^ 1]. - xgcd _ self xgcd: n. - ^ (xgcd at: 1) == 1 ifTrue: [^ (xgcd at: 2) \\ n]! ! -!Integer methodsFor: 'arithmetic' stamp: 'len 12/4/2016 13:07:08'! - xgcd: anInteger - "Extended Euclidean algorithm. - Answer an array {x. u. v} where self * u + (anInteger * v) = x, and x = (self gcd: anInteger)." - | a b s t sp tp r rp | - a _ self. b _ anInteger. - s _ 0. sp _ 1. - t _ 1. tp _ 0. - r _ a abs. rp _ b abs. - [r == 0] - whileFalse: - [ | q temp | - q _ rp // r. - temp _ r. r _ rp - (q * r). rp _ temp. - temp _ s. s _ sp - (q * s). sp _ temp. - temp _ t. t _ tp - (q * t). tp _ temp]. - sp _ sp * b sign. tp _ tp * a sign. - ^ {rp. tp. sp}! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3043-Alternative-gcd-reciprocalModulo-LucianoEstebanNotarfrancesco-2017Jan22-21h46m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3043] on 16 February 2017 at 2:31:35 pm'! -!FileSystemEntry methodsFor: 'accessing-file name' stamp: 'jmv 2/16/2017 11:21:10' prior: 16843823! - baseName - ^self fileAccessor baseNameFor: name! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3044-basename-fix-JuanVuletich-2017Feb16-11h21m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3044] on 17 February 2017 at 3:11:08 pm'! -!PluggableButtonMorph methodsFor: 'private' stamp: 'jmv 2/17/2017 15:10:48' prior: 16888368! - magnifiedIcon - | factor magnifiedExtent w h | - - icon ifNil: [ ^nil ]. - magnifiedIcon ifNil: [ - magnifiedIcon _ icon. - w _ icon width. - h _ icon height. - w*h = 0 ifFalse: [ - factor _ 1.0 * extent x / w min: 1.0 * extent y / h. - (factor < 1 or: [ factor > 1.7 and: [self isRoundButton]]) ifTrue: [ - magnifiedExtent _ (icon extent * factor) rounded. - magnifiedIcon _ icon magnifyTo: magnifiedExtent ]]]. - ^magnifiedIcon! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3045-magnifiedIcon-fix-JuanVuletich-2017Feb17-15h10m-jmv.1.cs.st----! - -----SNAPSHOT----#(20 February 2017 12:09:34.739158 pm) Cuis5.0-3045-spur-64.image priorSource: 194094! - -----QUIT----#(20 February 2017 12:09:57.201979 pm) Cuis5.0-3045-spur-64.image priorSource: 202910! - -----STARTUP----#(6 March 2017 10:16:04.474788 am) as /home/juan/Rectifier/Cuis-Smalltalk-Dev/Cuis5.0-3045-spur-64.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3042] on 10 February 2017 at 5:39:28 pm'! - -Object subclass: #ProgessiveTestRunner - instanceVariableNames: 'testSuite testsStream progressBar testResult testRunIncrement' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Testing'! - -!classDefinition: #ProgessiveTestRunner category: #'Tools-Testing'! -Object subclass: #ProgessiveTestRunner - instanceVariableNames: 'testSuite testsStream progressBar testResult testRunIncrement' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Testing'! -!Browser methodsFor: 'tdd' stamp: 'HAW 2/10/2017 17:32:22'! - debugMethodTest - - currentCompiledMethod isTestMethod ifTrue: [ - currentCompiledMethod methodClass debugAsFailure: currentCompiledMethod selector ] -! ! -!Browser methodsFor: 'tdd' stamp: 'HAW 2/4/2017 20:33:00'! - runClassTests - - self selectedClassName ifNotNil: [ :aClassName | | selectedClass | - selectedClass _ Smalltalk classNamed: aClassName. - (ProgessiveTestRunner for: (TestSuite forClass: selectedClass)) value ]! ! -!Browser methodsFor: 'tdd' stamp: 'HAW 2/7/2017 10:47:50'! - runMessageCategoryTests - - selectedMessageCategory ifNotNil: [ | selectedClass suite | - selectedClass _ Smalltalk classNamed: selectedClassName. - suite _ TestSuite forMessageCategoryNamed: selectedMessageCategory of: selectedClass categorizedWith: classOrganizer. - (ProgessiveTestRunner for: suite) value ] - - ! ! -!Browser methodsFor: 'tdd' stamp: 'HAW 2/4/2017 21:51:50'! - runMethodTest - - | suite | - - suite _ TestSuite forCompiledMethod: currentCompiledMethod. - (ProgessiveTestRunner for: suite) value - ! ! -!Browser methodsFor: 'tdd' stamp: 'HAW 2/1/2017 19:23:54'! - runSystemCategoryTests - - selectedSystemCategory ifNotNil: [ | suite | - suite _ TestSuite forSystemCategoryNamed: selectedSystemCategory using: systemOrganizer. - (ProgessiveTestRunner for: suite) value ] - - ! ! -!Behavior methodsFor: 'tdd' stamp: 'HAW 2/7/2017 11:55:50'! - testCaseClass - - self subclassResponsibility ! ! -!Behavior methodsFor: 'tdd' stamp: 'HAW 2/7/2017 11:55:40'! - withTestCaseClassDo: aFoundTestCaseClassBlock ifNone: aNoneBlock - - | potentialTestCaseClass | - - potentialTestCaseClass _ self testCaseClass. - - ^potentialTestCaseClass ifNil: aNoneBlock ifNotNil: aFoundTestCaseClassBlock - ! ! -!Class methodsFor: 'tdd' stamp: 'HAW 2/7/2017 10:42:40'! -testCaseClass - - | potentialTestCaseClass | - - potentialTestCaseClass _ Smalltalk classNamed: self name, 'Test'. - - ^potentialTestCaseClass - - ! ! -!Metaclass methodsFor: 'tdd' stamp: 'HAW 2/7/2017 11:56:51'! - testCaseClass - - ^self soleInstance testCaseClass ! ! -!Categorizer methodsFor: 'tdd' stamp: 'HAW 2/7/2017 09:06:13'! - classesAt: aCategoryName - - ^(self listAtCategoryNamed: aCategoryName) collect: [:aClassName | Smalltalk classNamed: aClassName ] - ! ! -!Categorizer methodsFor: 'tdd' stamp: 'HAW 2/7/2017 09:06:34'! - testCaseClassesAt: aCategoryName - - ^(self classesAt: aCategoryName) select: [ :aClass | aClass is: #TestCaseClass ]! ! -!SmalltalkEditor methodsFor: 'editing keys' stamp: 'HAW 2/10/2017 16:03:46'! - acceptAndDebugTest: aKeyboardEvent - - ^self acceptAndDebugTest ! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HAW 2/10/2017 17:34:45'! - acceptAndDebugTest - - ^self acceptAndWithMethodDo: [ :aPotencialTestMethod | - aPotencialTestMethod isTestMethod ifTrue: [ aPotencialTestMethod methodClass debugAsFailure: aPotencialTestMethod selector ]]! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HAW 2/10/2017 17:34:38'! - acceptAndWithMethodDo: aBlock - - | potencialTestMethod | - - self acceptContents ifFalse: [ ^false ]. - - potencialTestMethod _ self codeProvider currentCompiledMethod. - ^potencialTestMethod - ifNil: [ false ] - ifNotNil: [ - aBlock value: potencialTestMethod. - true]! ! -!ProgessiveTestRunner methodsFor: 'initialization' stamp: 'HAW 2/1/2017 19:20:06'! - initializeFor: aTestSuite - - testSuite _ aTestSuite. - ! ! -!ProgessiveTestRunner methodsFor: 'evaluating' stamp: 'HAW 1/31/2017 11:50:37'! - value - - testsStream _ ReadStream on: testSuite tests. - testsStream atEnd - ifTrue: [ self informNoTestToRun ] - ifFalse:[ self createProgressBarAndRun ]! ! -!ProgessiveTestRunner methodsFor: 'progress bar - private' stamp: 'HAW 1/31/2017 10:25:22'! - calculateTestRunIncrement - - testRunIncrement _ 1/testsStream size! ! -!ProgessiveTestRunner methodsFor: 'progress bar - private' stamp: 'HAW 1/31/2017 10:25:31'! - createProgressBar - - progressBar _ ProgressMorph label: testSuite name. - self calculateTestRunIncrement. - self updateProgressBarSubLabel. - ! ! -!ProgessiveTestRunner methodsFor: 'progress bar - private' stamp: 'HAW 1/31/2017 10:25:43'! - updateDoneIncrement - - progressBar incrDone: testRunIncrement - ! ! -!ProgessiveTestRunner methodsFor: 'progress bar - private' stamp: 'HAW 1/31/2017 11:10:25'! - updateProgressBarSubLabel - - testsStream atEnd ifFalse: [ - progressBar subLabel: testsStream next printString, ' (', testsStream position printString, '/', testsStream size printString, ')' ].! ! -!ProgessiveTestRunner methodsFor: 'show result - private' stamp: 'HAW 1/31/2017 20:05:25'! - informAllTestPassed - - PopUpMenu inform: testResult printString. - ! ! -!ProgessiveTestRunner methodsFor: 'show result - private' stamp: 'HAW 1/31/2017 10:05:21'! - informNoTestToRun - - PopUpMenu inform: 'No test to run'! ! -!ProgessiveTestRunner methodsFor: 'show result - private' stamp: 'HAW 2/1/2017 19:26:08'! - openTestResultForDebuggingAndInspection - - testResult forDebuggingAndInspection inspect ! ! -!ProgessiveTestRunner methodsFor: 'show result - private' stamp: 'HAW 1/31/2017 10:10:53'! - showDeffects - - | defects | - - defects _ testResult defects. - defects size = 1 - ifTrue: [ defects anyOne debug ] - ifFalse: [ self openTestResultForDebuggingAndInspection]! ! -!ProgessiveTestRunner methodsFor: 'evaluating - private' stamp: 'HAW 2/1/2017 19:14:08'! - createProgressBarAndRun - - self createProgressBar. - [ self runSuiteShowingProgress ] fork! ! -!ProgessiveTestRunner methodsFor: 'evaluating - private' stamp: 'HAW 2/1/2017 19:26:59'! - registerTestSuiteAction - - testSuite when: #changed: send: #testRun: to: self! ! -!ProgessiveTestRunner methodsFor: 'evaluating - private' stamp: 'HAW 1/31/2017 10:09:41'! - runSuite - - testResult _ testSuite run. - testResult hasPassed - ifTrue: [ self informAllTestPassed ] - ifFalse: [self showDeffects ] - ! ! -!ProgessiveTestRunner methodsFor: 'evaluating - private' stamp: 'HAW 1/31/2017 11:47:58'! - runSuiteShowingProgress - - [ self registerTestSuiteAction. - progressBar openInWorld. - self runSuite ] ensure: [ - self unregisterTestSuiteAction. - WorldState addDeferredUIMessage: [progressBar dismissMorph] ]. - ! ! -!ProgessiveTestRunner methodsFor: 'evaluating - private' stamp: 'HAW 2/1/2017 19:19:28'! - testRun: aTest - - self updateProgressBarSubLabel. - self updateDoneIncrement - - ! ! -!ProgessiveTestRunner methodsFor: 'evaluating - private' stamp: 'HAW 1/31/2017 10:04:32'! - unregisterTestSuiteAction - - testSuite releaseActionMap ! ! -!ProgessiveTestRunner class methodsFor: 'instance creation' stamp: 'HAW 1/31/2017 09:37:34'! - for: aTestSuite - - ^self new initializeFor: aTestSuite! ! -!TestCase class methodsFor: 'Instance Creation' stamp: 'HAW 2/10/2017 16:01:40'! - debugAsFailure: aSymbol - - ^(self selector: aSymbol) debugAsFailure - ! ! -!TestSuite class methodsFor: 'Creation' stamp: 'HAW 2/4/2017 20:31:47'! - forClass: aClass - - ^(aClass is: #TestCaseClass) - ifTrue: [ self forTestCaseClass: aClass ] - ifFalse: [ self forNoTestCaseClass: aClass ] -! ! -!TestSuite class methodsFor: 'Creation' stamp: 'HAW 2/4/2017 21:53:12'! - forCompiledMethod: aCompiledMethod - - ^aCompiledMethod isTestMethod - ifTrue: [ self forTestMethod: aCompiledMethod ] - ifFalse: [ self forNoTestMethod: aCompiledMethod ] - ! ! -!TestSuite class methodsFor: 'Creation' stamp: 'HAW 2/1/2017 18:43:22'! - forMessageCategoryNamed: aMessageCategoryName of: aClass categorizedWith: aClassOrganizer - - | suite | - - suite _ self named: aClass name, ' tests categorized under ',aMessageCategoryName. - (aClassOrganizer listAtCategoryNamed: aMessageCategoryName) do: [ :selector | - (aClass compiledMethodAt: selector) isTestMethod ifTrue: [ suite addTest: (aClass selector: selector) ]]. - - ^suite - ! ! -!TestSuite class methodsFor: 'Creation' stamp: 'HAW 2/7/2017 10:24:12'! - forSystemCategoryNamed: aCategoryName using: aSystemOrganizer - - | testCaseClasses | - - testCaseClasses _ aSystemOrganizer testCaseClassesAt: aCategoryName. - - ^testCaseClasses isEmpty - ifTrue: [ self forClasses: (aSystemOrganizer classesAt: aCategoryName) named: aCategoryName, ' infered tests' ] - ifFalse: [ self forTestCaseClasses: testCaseClasses named: aCategoryName, ' tests' ] - -! ! -!TestSuite class methodsFor: 'Creation - Private' stamp: 'HAW 2/7/2017 10:25:51'! - allTestCaseClassesReferencing: aClass - - ^(aClass allCallsOn - collect: [ :aMethodReference | aMethodReference actualClass ] - thenSelect: [ :aPotentialTestCaseClass | aPotentialTestCaseClass is: #TestCaseClass ]) asSet.! ! -!TestSuite class methodsFor: 'Creation - Private' stamp: 'HAW 2/7/2017 10:27:27'! - allTestsSending: aSelector - - ^(Smalltalk allCallsOn: aSelector) select: [:aMethodReference | - (aMethodReference actualClass is: #TestCaseClass) and: [aMethodReference compiledMethod isTestMethod ]].! ! -!TestSuite class methodsFor: 'Creation - Private' stamp: 'HAW 2/7/2017 09:08:23'! - forClasses: classes named: name - - | suite | - - suite _ classes - inject: (self named: name) - into: [ :partialSuite :aClass | partialSuite addTests: (self forClass: aClass) tests ]. - - ^suite - -! ! -!TestSuite class methodsFor: 'Creation - Private' stamp: 'HAW 2/7/2017 10:32:17'! - forNoTestCaseClass: aClass - - ^aClass - withTestCaseClassDo: [ :aTestCaseClass | self forTestCaseClass: aTestCaseClass ] - ifNone: [ self forReferencesToClass: aClass ] - -! ! -!TestSuite class methodsFor: 'Creation - Private' stamp: 'HAW 2/7/2017 11:28:55'! - forNoTestMethod: aCompiledMethod - - | allTestSenders testCaseClassesReferencingClass reducedTestSenders suite | - - allTestSenders _ self allTestsSending: aCompiledMethod selector. - testCaseClassesReferencingClass _ aCompiledMethod methodClass - withTestCaseClassDo: [:aTestCaseClass | Array with: aTestCaseClass ] - ifNone: [ self allTestCaseClassesReferencing: aCompiledMethod methodClass ]. - - reducedTestSenders _ allTestSenders select: [ :aMethodReference | testCaseClassesReferencingClass includes: aMethodReference actualClass ]. - reducedTestSenders isEmpty - ifTrue: [ suite _ self forClass: aCompiledMethod methodClass ] - ifFalse: [ - suite _ self named: 'Tests senders of ', aCompiledMethod selector. - reducedTestSenders do: [ :aMethodReference | suite addTest: (aMethodReference actualClass selector: aMethodReference selector)]]. - - ^suite! ! -!TestSuite class methodsFor: 'Creation - Private' stamp: 'HAW 2/7/2017 10:33:27'! - forReferencesToClass: aClass - - | testCaseClasses | - - testCaseClasses _ self allTestCaseClassesReferencing: aClass. - - ^testCaseClasses - inject: (self named: aClass name, ' all test references') - into: [ :suite :aTestCaseClass | aTestCaseClass addToSuiteFromSelectors: suite ] - - -! ! -!TestSuite class methodsFor: 'Creation - Private' stamp: 'HAW 2/7/2017 10:34:27'! - forTestCaseClass: aTestCaseClass - - | suite | - - suite _ aTestCaseClass buildSuite. - suite name: aTestCaseClass name, ' tests'. - - ^suite! ! -!TestSuite class methodsFor: 'Creation - Private' stamp: 'HAW 2/7/2017 09:04:48'! - forTestCaseClasses: testCaseClasses named: aName - - | suite | - - suite _ testCaseClasses - inject: (self named: aName) - into: [:partialSuite :aTestCaseClass | aTestCaseClass addToSuiteFromSelectors: partialSuite ]. - - ^suite! ! -!TestSuite class methodsFor: 'Creation - Private' stamp: 'HAW 2/4/2017 21:53:22'! - forTestMethod: aCompiledMethod - - | suite | - - suite _ self named: 'Test'. - suite addTest: (aCompiledMethod methodClass selector: aCompiledMethod selector). - - ^suite - ! ! -!UndefinedObject methodsFor: 'class hierarchy' stamp: 'HAW 2/10/2017 17:37:23'! - allSuperclassesUpTo: aSuperclass - - self error: (self superclassNotValidErrorDescriptionFor: aSuperclass)! ! -!UndefinedObject methodsFor: 'class hierarchy' stamp: 'HAW 2/10/2017 17:37:30'! - superclassNotValidErrorDescriptionFor: aClass - - ^aClass name, ' not in superclasses chain'! ! -!Behavior methodsFor: 'system-support' stamp: 'HAW 2/4/2017 20:51:10' prior: 16785122! - allCallsOn - "Answer a SortedCollection of all the methods that refer to me by name or - as part of an association in a global dict." - " - ^ (Smalltalk - allCallsOn: (Smalltalk associationAt: self theNonMetaClass name)) - , (Smalltalk allCallsOn: self theNonMetaClass name) - " - - ^ Smalltalk allCallsOn: self theNonMetaClass name! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'HAW 2/4/2017 20:49:09' prior: 16923905! - browseAllCallsOnClass: aClass - "Create and schedule a message browser on each method that refers to - aClass. For example, Smalltalk browseAllCallsOnClass: Object." - self - browseMessageList: aClass allCallsOn asArray sort - name: 'Users of class ' , aClass theNonMetaClass name - autoSelect: aClass theNonMetaClass name.! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HAW 2/1/2017 18:51:22' prior: 50336089! - acceptAndTest - - self acceptThenTestMethodAndSuite: [ :aMethod | self testSuiteOf: aMethod methodClass ]. - ^true! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HAW 2/1/2017 18:50:41' prior: 50336095! - acceptAndTestAll - - self acceptThenTestMethodAndSuite: [ :aMethod | self testSuiteForCategoryOf: aMethod methodClass ]. - ^true - - ! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HAW 2/10/2017 17:34:52' prior: 50336102! - acceptThenTestMethodAndSuite: aSuiteBuilder - - self acceptAndWithMethodDo: [ :aPotencialTestMethod | - self runAndDebuggIfNecessary: aPotencialTestMethod. - self runTestSuite: (aSuiteBuilder value: aPotencialTestMethod) ]! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HAW 2/10/2017 16:08:47' prior: 50336124! - runAndDebuggIfNecessary: aPotencialTestMethod - - aPotencialTestMethod isTestMethod ifTrue: [ - aPotencialTestMethod methodClass debug: aPotencialTestMethod selector ]! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HAW 2/1/2017 19:19:02' prior: 50336132! - runTestSuite: aTestSuite - - (ProgessiveTestRunner for: aTestSuite) value - - ! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HAW 2/5/2017 10:49:25' prior: 50336142! - testSuiteForCategoryOf: aClass - - ^TestSuite forSystemCategoryNamed: aClass category using: SystemOrganization -! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HAW 2/5/2017 10:48:27' prior: 50336159! - testSuiteOf: aClass - - ^TestSuite forClass: aClass -! ! -!SmalltalkEditor class methodsFor: 'keyboard shortcut tables' stamp: 'HAW 2/10/2017 15:58:27' prior: 50336386! - cmdShortcutsSpec - " - Editor initialize - " - "arranged in QWERTY keyboard order" - ^#( - #( $r #acceptAndDebugTest: 'Saves method and debugs it') - #( $t #acceptAndTest: 'Saves method, runs it as test and then all tests in class. Opens debugger if error') - #( $y #acceptAndTestAll: 'Saves method, runs it as test and then all tests in class category. Opens debugger if error') - #( $i #inspectIt: 'Inspect it (selection is a valid expression, or selection is over an inspect-ilst)') - #( $p #printIt: 'Print it (selection is a valid expression)') - - #( $s #save: 'Save (i.e. accept)') - #( $d #doIt: 'Do it (selection is a valid expression)') - #( $l #cancelEdits: 'Cancel') - - #( $b #browseIt: 'Browse it (selection is a class name or cursor is over a class-list or message-list)') - #( $n #sendersOfIt: 'Senders of it (selection is a message selector or cursor is over a class-list or message-list)') - #( $m #implementorsOfIt: 'Implementors of it (selection is a message selector or cursor is over a class-list or message-list)') - - #( $E #methodStringsContainingit:'Method strings containing it') - #( $T #displayIfTrue: 'Insert #ifTrue:') - #( $I #exploreIt: 'Inspect via Object Explorer') - - #( $A #argAdvance: 'Advance argument') - #( $D #debugIt: 'Debut it') - #( $F #displayIfFalse: 'Insert #ifFalse:') - #( $G #fileItIn: 'File in selection') - - #( $V #pasteInitials: 'Paste author initials') - #( $N #referencesToIt: 'References to it (selection is a class name, or cursor is over a class-list or message-list)') - )! ! -!SmalltalkEditor class methodsFor: 'keyboard shortcut tables' stamp: 'HAW 2/10/2017 15:57:40' prior: 50336440! - initializeMenu - "Initialize the mouseButton2 (right button) pop-up menu and corresponding messages." - " - Editor initialize - " - - menu _ SelectionMenu fromArray: { - {'Help...'. #openHelp}. - #-. - {'Do it (d)'. #doIt}. - {'Print it (p)'. #printIt}. - {'Inspect it (i)'. #inspectIt}. - {'Explore it (I)'. #exploreIt}. - {'Debug it (D)'. #debugIt}. - {'Profile it'. #profileIt}. - #-. - {'Explain'. #explain}. - {'Browse it (b)'. #browseIt}. - {'Senders of it (n)'. #sendersOfIt}. - {'Implementors of it (m)'. #implementorsOfIt}. - {'References to it (N)'. #referencesToIt}. - #-. - {'Method Strings with it (E)'. #methodStringsContainingit}. - {'Method Source with it'. #methodSourceContainingIt}. - {'Class Comments with it'. #classCommentsContainingIt}. - #-. - {'Accept (s)'. #acceptContents}. - {'Cancel (l)'. #cancelEdits}. - {'Accept & Run Test in Class (t)'. #acceptAndTest}. - {'Accept & Run Test in Category (y)'. #acceptAndTestAll}. - {'Accept & Debug Test (r)'. #acceptAndDebugTest}. - #-. - {'More...'. #getMenu2}. - }. - menu2 _ SelectionMenu fromArray: { - {'Find...(f)'. #find}. - {'Find Again (g)'. #findAgain}. - {'Use Selection for Find (j)'. #setSearchString}. - #-. - {'Undo - multiple (z)'. #undo}. - {'Redo - multiple (Z)'. #redo}. - {'Undo / Redo history'. #offerUndoHistory}. - #-. - {'Copy (c)'. #copySelection}. - {'Cut (x)'. #cut}. - {'Paste (v)'. #paste}. - {'Paste without Format'. #pasteString}. - {'Paste...'. #pasteRecent}. - #-. - {'Toggle WordWrap'. #wrapOnOff}. - {'Set Font... (k)'. #offerFontMenu}. - {'Clear Font'. #clearFont}. - {'Set Default Font...'. #offerDefaultFontMenu}. - #-. - {'More...'. #getMenu}. - }! ! -!CodeWindow methodsFor: 'keyboard shortcuts' stamp: 'HAW 1/31/2017 11:56:31' prior: 16813767! - classListKey: aChar from: view - "Respond to a Command key. I am a model with a list of classes and a - code pane, and I also have a listView that has a list of methods. The - view knows how to get the list and selection." - - aChar == $r ifTrue: [^ model recent]. - aChar == $h ifTrue: [^ self browseHierarchy]. - aChar == $x ifTrue: [^ model removeClass]. - aChar == $t ifTrue: [^ model runClassTests ]. - - ^ self messageListKey: aChar from: view! ! -!CodeWindow methodsFor: 'keyboard shortcuts' stamp: 'HAW 2/10/2017 17:33:25' prior: 16813782! - messageListKey: aChar from: view - "Respond to a Command key. I am a model with a code pane, and I also - have a listView that has a list of methods. The view knows how to get - the list and selection." - - | sel class | - aChar == $D ifTrue: [^ model toggleDiffing]. - - sel _ model selectedMessageName. - aChar == $m ifTrue: [ "These next two put up a type in if no message selected" - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllImplementorsOf: to: Smalltalk]. - aChar == $n ifTrue: [ - ^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllCallsOn: to: Smalltalk]. - - "The following require a class selection" - (class _ model selectedClassOrMetaClass) ifNil: [^ self ]. - aChar == $b ifTrue: [^ BrowserWindow fullOnClass: class selector: sel]. - aChar == $N ifTrue: [^ self browseClassRefs]. - aChar == $i ifTrue: [^ self methodHierarchy]. - aChar == $h ifTrue: [^ self browseHierarchy]. - aChar == $p ifTrue: [^ self browseFullProtocol]. - - "The following require a method selection" - sel ifNotNil: [ - aChar == $o ifTrue: [^ model fileOutMessage]. - aChar == $c ifTrue: [^ model copySelector]. - aChar == $v ifTrue: [^ self browseVersions]. - aChar == $O ifTrue: [^ self openSingleMessageBrowser]. - aChar == $x ifTrue: [^ model removeMessage]. - aChar == $t ifTrue: [^ model runMethodTest]. - aChar == $r ifTrue: [^ model debugMethodTest]]! ! -!CodeWindow methodsFor: 'keyboard shortcuts' stamp: 'HAW 2/7/2017 10:49:07' prior: 16813824! - systemCatListKey: aChar from: view - "Respond to a Command key. I am a model with a code pane, and I also have a listView that has a list of methods. The view knows how to get the list and selection." - - aChar == $f ifTrue: [^ self findClass]. - aChar == $x ifTrue: [^ model removeSystemCategory]. - aChar == $t ifTrue: [ ^model runSystemCategoryTests ]. - - ^ self classListKey: aChar from: view! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'HAW 1/31/2017 11:32:21' prior: 16793212! - classListMenu - "Set up the menu to apply to the receiver's class list, honoring the #shifted boolean" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addList: #( - ('browse full (b)' browseMethodFull) - ('browse hierarchy (h)' browseHierarchy) - ('browse protocol (p)' browseFullProtocol) - - - ('fileOut' fileOutClass '' model) - - - ('show hierarchy' hierarchy '' model) - ('show definition' editClass '' model) - ('show comment' editComment '' model) - - - ('inst var refs...' browseInstVarRefs) - ('inst var defs...' browseInstVarDefs) - - - ('class var refs...' browseClassVarRefs) - ('class vars' browseClassVariables) - ('class refs (N)' browseClassRefs) - - - ('rename class ...' renameClass '' model) - ('copy class...' copyClass '' model) - ('remove class (x)' removeClass '' model) - - - ('Run tests (t)' runClassTests '' model) - ('more...' offerShiftedClassListMenu)). - ^ aMenu! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'HAW 1/31/2017 19:57:02' prior: 16793244! - messageCategoryMenu - - | aMenu | - aMenu _ MenuMorph new defaultTarget: model. "All the options are for the model." - aMenu addList: #( - ('fileOut' fileOutMessageCategories) - - - ('reorganize' editMessageCategories) - ('alphabetize' alphabetizeMessageCategories) - ('remove empty categories' removeEmptyCategories) - ('categorize all uncategorized' categorizeAllUncategorizedMethods) - ('new category...' addCategory) - - - ('rename...' renameCategory) - ('remove' removeMessageCategory) - - - ('Run tests' runMessageCategoryTests)). - ^aMenu! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'HAW 2/10/2017 17:29:43' prior: 16793264! -messageListMenu - "Answer the message-list menu" - "Changed by emm to include menu-item for breakpoints" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addList:#( - ('what to show...' offerWhatToShowMenu) - ('toggle break on entry' toggleBreakOnEntry '' model) - - - ('browse full (b)' browseMethodFull) - ('browse hierarchy (h)' browseHierarchy) - ('browse method (O)' openSingleMessageBrowser) - ('browse protocol (p)' browseFullProtocol) - - - ('fileOut' fileOutMessage '' model) - - - ('senders of... (n)' browseSendersOfMessages) - ('implementors of... (m)' browseMessages) - ('inheritance (i)' methodHierarchy) - ('versions (v)' browseVersions) - - - ('inst var refs...' browseInstVarRefs) - ('inst var defs...' browseInstVarDefs) - ('class var refs...' browseClassVarRefs) - ('class variables' browseClassVariables) - ('class refs (N)' browseClassRefs) - - - ('remove method (x)' removeMessage '' model) - ('Run test (t)' runMethodTest '' model) - ('Debug test (r)' debugMethodTest '' model) - - - ('more...' openShiftedMessageListMenu)). - ^ aMenu -! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'HAW 1/31/2017 11:52:17' prior: 16793404! - systemCategoryMenu - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - self flag: #renameSystemCategory. "temporarily disabled" - aMenu addList: #( - ('find class... (f)' findClass) - ('recent classes... (r)' recent '' model) - - - ('browse all' browseAllClasses) - ('browse' openSystemCategoryBrowser) - - - ('fileOut' fileOutSystemCategory '' model) - - - ('reorganize' editSystemCategories '' model) - ('alphabetize' alphabetizeSystemCategories '' model) - - - ('update' updateSystemCategories '' model) - ('add item...' addSystemCategory '' model) -" ('rename...' renameSystemCategory '' model)" - ('remove' removeSystemCategory '' model) - - - ('move to top' moveSystemCategoryTop '' model) - ('move up' moveSystemCategoryUp '' model) - ('move down' moveSystemCategoryDown '' model) - ('move to bottom' moveSystemCategoryBottom '' model) - - - ('Run tests (t)' runSystemCategoryTests '' model)). - ^aMenu! ! -!Theme methodsFor: 'menus' stamp: 'HAW 2/10/2017 17:30:49' prior: 50336846! - miscellaneousIcons - - "Everything else." - - ^ { - #('restore display (r)' 'set display depth...' 'move windows onscreen' 'Utilities saveDisplay.') -> #displayIcon. - #('changes...' 'dual change sorter' 'change sets with this method' 'find a change sorter' 'recent changes in file' 'Undo / Redo history' 'code file contents' 'package file contents') -> #changesIcon. - #('Install New Updates' 'update' 'turn on auto-update (a)' 'update list (u)' 'install code' 'fileIn entire file' 'install package') -> #updateIcon. - #('find again (g)' 'full stack (k)') -> #systemIcon. - #('print it (p)' 'check change set for slips') -> #printIcon. - #('accept (s)' 'make changes go to me (m)') -> #acceptIcon. - #('cancel (l)' 'turn off auto-update (a)') -> #cancelIcon. - #('debug...' 'Debug it (D)' 'toggle break on entry') -> #debugIcon. - #('close' 'close all debuggers' 'close top window') -> #closeIcon. - #('collapse' 'hide taskbar' 'collapse all windows') -> #collapseIcon. - #('expand / contract' 'show taskbar' 'restore all windows') -> #expandIcon. - #('menu') -> #windowMenuIcon. - #('browse all' 'browser' 'browse it (b)' 'MessageTally UI and browse' 'browse recent submissions' 'browse full (b)' 'find changed browsers...' 'browse (b)' 'browse my changes') -> #editFindReplaceIcon. - #('workspace' 'workspace with contents') -> #terminalIcon. - #('styled text editor' 'text editor' 'basic text editor' 'unicode editor' 'edit this list' 'edit postscript...' 'add postscript...') -> #textEditorIcon. - #('file list' 'find a fileList' 'compress file') -> #systemFileManagerIcon. - #('transcript' 'find a transcript' 'Transcript clear.' 'log to transcript') -> #printerIcon. - #('process browser' 'vm statistics' 'MessageTally all Processes') -> #systemMonitorIcon. - #('emergency evaluator' 'conflicts with other change sets' 'check for slips' 'conflicts with change set opposite' 'conflicts with category opposite') -> #emblemImportantIcon. - #('change sorter') -> #halfRefreshIcon. - #('SUnit Test Runner' 'Accept & Run Test in Class (t)' 'Accept & Run Test in Category (y)' 'Run tests (t)' 'Run tests' 'Run test (t)' 'Accept & Debug Test (r)' 'Debug test (r)') -> #weatherFewCloudsIcon. - #('Font Sizes...' 'system fonts...' 'set font... (k)') -> #preferencesDesktopFontIcon. - #('full screen on') -> #viewFullscreenIcon. - #('full screen off') -> #exitFullscreenIcon. - #('set desktop color...') -> #wallpaperIcon. - #('preferences...' 'All preferences...' 'what to show...' 'view as hex') -> #preferencesIcon. - #('Editor keyboard shortcuts') -> #keyboardShortcutsIcon. - #('world menu help') -> #globeIcon. "currently unused, but a neat icon" - #('useful expressions' 'class comments with it' 'check for uncommented methods' 'check for uncommented classes') -> #chatIcon. - #('set code author...' 'check for other authors' 'check for any other authors') -> #usersIcon. - #('space left') -> #removableMediaIcon. - #('start drawing all again' 'window color...') -> #graphicsIcon. - #('start stepping again') -> #mediaPlaybackStartIcon. - #('file out current change set' 'fileOut' 'File out and remove (o)' 'File out and keep (k)') -> #fileOutIcon. - #('recently logged changes...' 'versions (v)' 'recent classes... (r)' 'trim history' 'Profile it') -> #clockIcon. - #('senders of it (n)' 'senders of... (n)' 'local senders of...' 'senders (n)') -> #mailForwardIcon. - #('implementors of it (m)' 'implementors of... (m)' 'implementors of sent messages') -> #developmentIcon. - #('references to it (N)') -> #addressBookIcon. - #('class var refs...' 'class refs (N)' 'class variables' 'class vars' 'local implementors of...' 'subclass template') -> #classIcon. - #('inst var refs...' 'inst var defs...' 'sample instance') -> #instanceIcon. - #('Use Selection for Find (j)' 'rename class ...' 'rename...' 'change title...') -> #saveAsIcon. - #('smalltalk options' 'method source with it' 'browse method (O)' 'check for uncategorized methods') -> #scriptIcon. - #('method strings with it (E)' 'Toggle WordWrap') -> #genericTextIcon. - #('browse hierarchy (h)' 'move to top' 'promote to top of list') -> #goTopIcon. - #('move up' 'make next-to-topmost') -> #goUpIcon. - #('move to bottom' 'send to back' 'send top window to back') -> #goBottomIcon. - #('inheritance (i)' 'move down') -> #goDownIcon. - #('browse protocol (p)' 'spawn sub-protocol') -> #spreadsheetIcon. - #('spawn full protocol') -> #speadsheetTemplateIcon. - #('alphabetize') -> #fontXGenericIcon. - #('Installed Packages' 'browse' 'show category (C)' 'categorize all uncategorized' 'select change set...' 'view affected class categories') -> #packageIcon. - #('remove from current change set' 'remove empty categories' 'subtract other side (-)' 'remove from this browser') -> #listRemoveIcon. - #('add to current change set' 'add all meths to current chgs' 'add preamble (p)' 'More...') -> #listAddIcon. - #('toggle diffing (D)' 'toggle selections') -> #switchIcon. - #('reorganize' 'create inst var accessors' 'ChangeSorter reorderChangeSets.' 'reorder all change sets' 'by name' 'by size' 'by date') -> #sendReceiveIcon. - #('unsent methods' 'unreferenced class vars' 'unreferenced inst vars' 'Undeclared inspect.' 'Undeclared removeUnreferencedKeys; inspect.' 'ChangeSorter removeEmptyUnnamedChangeSets.' 'check for unsent messages') -> #junkIcon. - #('find changed windows...') -> #newWindowIcon. - #('make undraggable') -> #pushPinIcon. - #('Utilities saveScreenshot.') -> #stillCameraIcon. - #('add new directory') -> #newFolderIcon. - #('select all' 'deselect all') -> #selectAllIcon. - #('sort by date') -> #dateIcon. - #('justified') -> #formatJustifyFillIcon. - #('centered') -> #formatJustifyCenterIcon. - #('set alignment...' 'leftFlush') -> #formatJustifyLeftIcon. - #('rightFlush') -> #formatJustifyRightIcon. - #('signal Semaphore (S)') -> #haloHelpIcon. - #('Change Paragraph Style...' 'Change Character Style...' 'Remove Character Style' 'Replace all uses of Paragraph Style...' 'Replace all uses of Character Style...' 'Set Default Font...') -> #fontXGenericIcon. - #('Clear Font') -> #newIcon. - #('code file browser' 'package file browser') -> #findIcon. - }! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 2/10/2017 17:37:41'! - should: aBlock raise: anExceptionalType withExceptionDo: assertionsBlock - - ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalType withExceptionDo: assertionsBlock) - ! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 2/10/2017 17:38:10'! - executeShould: aBlock inScopeOf: anExceptionType withExceptionDo: assertionsBlock - - ^[aBlock value. - false] - on: anExceptionType - do: [:exception | - assertionsBlock value: exception. - exception sunitExitWith: true]! ! -!TestCase class methodsFor: 'Testing' stamp: 'HAW 2/10/2017 16:32:10' prior: 50336192! - is: aSymbol - - ^self ~= TestCase - and: [ aSymbol == #TestCaseClass or: [ super is: aSymbol ]]! ! -!TestCase class methodsFor: 'Testing' stamp: 'HAW 2/1/2017 19:35:57' prior: 16927731! - shouldInheritSelectors - "I should inherit from an Abstract superclass but not from a concrete one by default, unless I have no testSelectors in which case I must be expecting to inherit them from my superclass. If a test case with selectors wants to inherit selectors from a concrete superclass, override this to true in that subclass." - - ^self ~= TestCase - and: [ self superclass isAbstract or: [self testSelectors isEmpty]] - -"$QA Ignore:Sends system method(superclass)$" - ! ! -!TestResultForDebuggingAndInspection methodsFor: 'printing' stamp: 'HAW 2/7/2017 10:51:56' prior: 50336209! - print: aCollectionOfTestCases startingWith: header on: aStream - - aCollectionOfTestCases do: [ :aTestCase | - aStream - nextPutAll: header; - space; - nextPutAll: aTestCase class name; - nextPutAll: ' debug: #'; - nextPutAll: aTestCase selector; - newLine ] - - - ! ! - -TestSuite class removeSelector: #allTestCasesReferencing:! - -TestSuite class removeSelector: #allTestReferencesTo:! - -TestSuite class removeSelector: #allTestsReferencing:! - -TestSuite class removeSelector: #from:using:! - -TestSuite class removeSelector: #fromClass:! - -TestSuite class removeSelector: #fromSystemCategoryNamed:using:! - -ProgessiveTestRunner removeSelector: #initializeFor:informingResultUsing:! - -ProgessiveTestRunner removeSelector: #initializeFor:showingTestPassedWith:! - -ProgessiveTestRunner removeSelector: #showProgressBarAndRunSuite! - -SmalltalkEditor removeSelector: #acceptAndWithTestMethodDo:! - -SmalltalkEditor removeSelector: #flashWith:! - -SmalltalkEditor removeSelector: #flashWith:! - -SmalltalkEditor removeSelector: #flashWithGreen! - -SmalltalkEditor removeSelector: #flashWithGreen! - -Categorizer removeSelector: #testCasesAt:! - -Class removeSelector: #withTestCaseClassDo:ifNone:! - -Behavior removeSelector: #withTestClassDo:ifNone:! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3046-TestRunningHelpers-HernanWilkinson-2017Jan31-09h21m-HAW.5.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3046] on 1 March 2017 at 12:34:07 pm'! -!CodeFile methodsFor: 'change record types' stamp: 'jmv 3/1/2017 12:31:23' prior: 16808869! - doIt: chgRec - "See senders of #doIt " - | string | - string := chgRec string. - - "Method classification spec" - (string beginsWith: '(''') ifTrue: [ - ^ doIts add: chgRec ]. - - "Just for compatibility with Squeak, as Cuis always adds the #classDefinition change type marker in the files." - ('*ubclass:*instanceVariableNames:*classVariableNames:*poolDictionaries:*category:*' - match: string) ifTrue:[^self classDefinition: string with: chgRec]. - - "Just for compatibility with Squeak, as Cuis always adds the #classDefinition change type marker in the files." - ('* class*instanceVariableNames:*' - match: string) ifTrue:[^self metaClassDefinition: string with: chgRec]. - - "Just for compatibility with Squeak, as Cuis always adds the #methodRemoval: (or similar) change type marker in the files." - ('* removeSelector: *' - match: string) ifTrue:[^self removedMethod: string with: chgRec]. - - "Just for compatibility with Squeak, as Cuis always adds the #classComment change type marker in the files." - ('* comment:*' - match: string) ifTrue:[^self msgClassComment: string with: chgRec]. - - "Don't add these to a CodeFile. They will be added on save if needed." - ('* initialize' - match: string) ifTrue:[^self]. "Initialization is done based on class>>initialize" - - ('''From *' - match: string) ifTrue:[^self possibleSystemSource: chgRec]. - doIts add: chgRec.! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3047-FileCodeBrowserFix-JuanVuletich-2017Mar01-12h33m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3047] on 2 March 2017 at 10:50:58 am'! - -BorderedRectMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp popUpOwner activeSubMenu titleMorph oldKeyboardFocus ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #MenuMorph category: #'Morphic-Menus'! -BorderedRectMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp popUpOwner activeSubMenu titleMorph oldKeyboardFocus' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! -!MenuMorph commentStamp: '' prior: 16866262! - Instance variables: - defaultTarget The default target for creating menu items - selectedItem The currently selected item in the receiver - stayUp True if the receiver should stay up after clicks! -!MenuMorph methodsFor: 'control' stamp: 'jmv 3/2/2017 10:47:30' prior: 16866663! - deleteIfPopUp: evt - "Remove this menu from the screen if stayUp is not true." - - stayUp ifFalse: [ self delete ]. - evt ifNotNil: [ evt hand ifNotNil: [ :h | h releaseMouseFocus: self ]]! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 3/2/2017 10:48:01' prior: 16866680! - popUpAdjacentTo: rightOrLeftPointInWorld from: sourceItem - "Present this menu at the given point under control of the given hand. - Used mostly for submenus." - - | delta tryToPlace selectedOffset | - selectedOffset _ (selectedItem ifNil: [ self items first ]) morphPosition. - sourceItem world addMorphFront: self. - - tryToPlace _ [ :where :mustFit | - self morphPosition: where - selectedOffset. - delta _ self morphFullBoundsInWorld - amountToTranslateWithin: sourceItem world morphBoundsInWorld. - (delta x = 0 | mustFit) ifTrue: [ - delta = (0@0) ifFalse: [ self morphPosition: self morphPosition + delta ]. - ^ self]]. - tryToPlace - value: rightOrLeftPointInWorld first value: false; - value: rightOrLeftPointInWorld last - (extent x @ 0) value: false; - value: rightOrLeftPointInWorld first value: true! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 3/2/2017 10:48:31' prior: 16866709! - popUpAt: aPoint forHand: hand allowKeyboard: aBoolean - "Present this menu at the given point under control of the given hand." - - | evt | - self items isEmpty ifTrue: [^self]. - Theme current decorateMenu: self. - (self submorphs select: [ :m | m is: #UpdatingMenuItemMorph ]) - do: [ :m | m updateContents]. - self runningWorld addMorphFront: self position: aPoint - (2 @ 8). - self fitInWorld. - "Acquire focus for valid pop up behavior" - hand newMouseFocus: self. - aBoolean ifTrue: [ hand newKeyboardFocus: self ]. - evt _ hand lastMouseEvent. - (evt isKeyboard or: [ evt isMouse and: [ evt anyButtonPressed not ]]) - ifTrue: [ - "Select first item if button not down" - self moveSelectionDown: 1 event: evt ]! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 3/2/2017 10:48:26' prior: 16866745! - popUpAt: aPoint forHand: hand in: aWorld allowKeyboard: aBoolean - "Present this menu at the given point under control of the given hand." - - self items isEmpty ifTrue: [ ^self ]. - Theme current decorateMenu: self. - (self submorphs select: [ :m | m is: #UpdatingMenuItemMorph]) - do: [ :m | m updateContents]. - aWorld addMorphFront: self position: aPoint - (2 @ 8). - self fitInWorld. - "Acquire focus for valid pop up behavior" - hand newMouseFocus: self. - aBoolean ifTrue: [ hand newKeyboardFocus: self ]! ! -!MenuMorph methodsFor: 'events' stamp: 'jmv 3/2/2017 10:47:45' prior: 16866819! - keyStroke: aKeyboardEvent - | matchString char asc selectable | - char := aKeyboardEvent keyCharacter. - asc := char numericValue. - aKeyboardEvent isReturnKey - ifTrue: [ - selectedItem ifNotNil: [ - selectedItem hasSubMenu - ifTrue: [ - aKeyboardEvent hand newMouseFocus: selectedItem subMenu. - ^aKeyboardEvent hand newKeyboardFocus: selectedItem subMenu] - ifFalse: [ - "self delete." - ^selectedItem invokeWithEvent: aKeyboardEvent]]. - (selectable := self items) size = 1 - ifTrue: [^selectable first invokeWithEvent: aKeyboardEvent]. - ^self]. - asc = 27 - ifTrue: [ - "escape key" - self - valueOfProperty: #matchString - ifPresentDo: [ :str | - str isEmpty - ifFalse: [ - "If filtered, first ESC removes filter" - self setProperty: #matchString toValue: String new. - self selectItem: nil. - ^self displayFiltered: aKeyboardEvent]]. - "If a stand-alone menu, just delete it" - ^self delete]. - (asc = 28 or: [asc = 29]) - ifTrue: [ - "left or right arrow key" - (selectedItem notNil and: [selectedItem hasSubMenu]) - ifTrue: [ - aKeyboardEvent hand newMouseFocus: selectedItem subMenu. - selectedItem subMenu moveSelectionDown: 1 event: aKeyboardEvent. - ^aKeyboardEvent hand newKeyboardFocus: selectedItem subMenu]]. - asc = 30 ifTrue: [^self moveSelectionDown: -1 event: aKeyboardEvent]. "up arrow key" - asc = 31 ifTrue: [^self moveSelectionDown: 1 event: aKeyboardEvent]. "down arrow key" - asc = 11 ifTrue: [^self moveSelectionDown: -5 event: aKeyboardEvent]. "page up key" - asc = 12 ifTrue: [^self moveSelectionDown: 5 event: aKeyboardEvent]. "page down key" - matchString := self valueOfProperty: #matchString ifAbsent: [String new]. - matchString := char = Character backspace - ifTrue: [ - matchString isEmpty ifTrue: [matchString] ifFalse: [matchString allButLast]] - ifFalse: [matchString copyWith: aKeyboardEvent keyCharacter]. - self setProperty: #matchString toValue: matchString. - self displayFiltered: aKeyboardEvent! ! -!MenuMorph methodsFor: 'events-processing' stamp: 'jmv 3/2/2017 10:47:57' prior: 16866952! - handleFocusEvent: aMorphicEvent - "Handle focus events. Valid menu transitions are determined based on the menu currently holding the focus after the mouse went down on one of its children." - | eventPositionInOurCoordinates | - eventPositionInOurCoordinates _ self internalizeFromWorld: aMorphicEvent eventPosition. - - self dispatchEvent: aMorphicEvent localPosition: eventPositionInOurCoordinates. - - "Need to handle keyboard input if we have the focus." - aMorphicEvent isKeyboard ifTrue: [ ^ aMorphicEvent sentTo: self localPosition: eventPositionInOurCoordinates]. - - "We need to handle button clicks outside and transitions to local popUps so throw away everything else" - (aMorphicEvent isMouseOver or: [aMorphicEvent isMouse not]) ifTrue: [ ^self ]. - "What remains are mouse buttons and moves" - aMorphicEvent isMove ifFalse: [ ^ aMorphicEvent sentTo: self localPosition: eventPositionInOurCoordinates ]. "handle clicks outside by regular means" - "Now it's getting tricky. On #mouseMove we might transfer control to *either* the currently active submenu or the pop up owner, if any. Since the active sub menu is always displayed upfront check it first." - selectedItem ifNotNil:[(selectedItem activateSubmenu: aMorphicEvent) ifTrue: [^self]]! ! -!MenuMorph methodsFor: 'initialization' stamp: 'jmv 3/2/2017 10:47:34' prior: 16867015! - initialize - super initialize. - extent _ 40@10. - defaultTarget _ nil. - selectedItem _ nil. - stayUp _ false! ! -!MenuItemMorph methodsFor: 'events' stamp: 'jmv 3/2/2017 10:45:33' prior: 16866023! - mouseEnter: evt - "The mouse entered the receiver" - owner ifNil: [ ^self ]. - owner selectItem: self! ! -!MenuItemMorph methodsFor: 'selecting' stamp: 'jmv 3/2/2017 10:36:12' prior: 16866139! - deselect - - self isSelected: false. - subMenu ifNotNil: [ - self removeAlarm: #deselectTimeOut ]! ! -!MenuItemMorph methodsFor: 'selecting' stamp: 'jmv 3/2/2017 10:36:17' prior: 16866151! - select - self isSelected: true. - subMenu ifNotNil: [ - subMenu delete. - subMenu - popUpAdjacentTo: (Array with: self morphBoundsInWorld topRight + (10@0) - with: self morphBoundsInWorld topLeft) - from: self. - subMenu selectItem: nil ]! ! - -MenuItemMorph removeSelector: #activateOwnerMenu:! - -MenuItemMorph removeSelector: #activateOwnerMenu:! - -MenuMorph removeSelector: #activeSubmenu:! - -MenuMorph removeSelector: #activeSubmenu:! - -MenuMorph removeSelector: #delete! - -MenuMorph removeSelector: #delete! - -MenuMorph removeSelector: #popUpOwner! - -MenuMorph removeSelector: #popUpOwner! - -BorderedRectMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp titleMorph' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #MenuMorph category: #'Morphic-Menus'! -BorderedRectMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp titleMorph' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3048-MenuSimplification-JuanVuletich-2017Mar02-10h45m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3048] on 2 March 2017 at 4:11:32 pm'! -!Transcripter class methodsFor: 'instance creation' stamp: 'dhn 2/6/2017 13:38:40' prior: 16938922! - newInFrame: frame -" -(Transcripter newInFrame: (0@0 extent: 100@200)) - nextPutAll: 'Hello there'; endEntry; - newLine; print: 355.0/113; endEntry; - readEvalPrint. -" - | transcript | - transcript _ self on: (String new: 100). - transcript initInFrame: frame. - ^ transcript clear! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3049-TranscripterCommentFix-DanNorton-2017Mar02-16h10m-dhn.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3049] on 3 March 2017 at 9:17:59 am'! -!WorldState methodsFor: 'stepping' stamp: 'jmv 3/2/2017 19:35:58'! -cleanseStepList - "Remove morphs from the step list that are not in this World. Often were in a flap that has moved on to another world." - - | deletions morphToStep | - deletions _ nil. - stepList do: [:entry | - morphToStep _ entry receiver. - morphToStep world == world ifFalse:[ - deletions ifNil: [deletions _ OrderedCollection new]. - deletions addLast: entry]]. - - deletions ifNotNil:[ - deletions do: [:entry| - self stopSteppingMorph: entry receiver]]. - - self alarms copy do:[:entry| - morphToStep _ entry receiver. - ((morphToStep is: #Morph) and: [ morphToStep world == world ]) - ifFalse: [ self removeAlarm: entry selector for: entry receiver ]].! ! -!WorldState methodsFor: 'stepping' stamp: 'jmv 3/2/2017 19:42:28'! - runStepMethods - "Perform periodic activity inbetween event cycles" - | queue msg | - - queue _ self class deferredUIMessages. - [ (msg _ queue nextOrNil) isNil ] whileFalse: [ - msg value - ]. - self runLocalStepMethods. - - "we are using a normal #step for these now" - "aWorld allLowerWorldsDo: [ :each | each runLocalStepMethods ]." -! ! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 3/2/2017 19:34:41'! - displayWorldSafely - "Update this world's display and keep track of errors during draw methods." - - [world displayWorld] ifError: [:err :rcvr | - "Handle a drawing error" - | errCtx errMorph | - errCtx _ thisContext. - [ - errCtx _ errCtx sender. - "Search the sender chain to find the morph causing the problem" - [errCtx notNil and: [ (errCtx receiver is: #Morph) not ]] - whileTrue:[errCtx _ errCtx sender]. - "If we're at the root of the context chain then we have a fatal drawing problem" - errCtx ifNil:[^self handleFatalDrawingError: err]. - errMorph _ errCtx receiver. - "If the morph causing the problem has already the #drawError flag set, - then search for the next morph above in the caller chain." - errMorph isKnownFailing - ] whileTrue. - errMorph drawingFails. - self clearCanvas. - "Install the old error handler, so we can re-raise the error" - rcvr error: err. - ]! ! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 3/2/2017 19:34:09'! - doOneCycle - "Do one cycle of the interaction loop. This method is called repeatedly when the world is running. - - Make for low cpu usage if the ui is inactive, but quick response when ui is in use. - However, after some inactivity, there will be a larger delay before the ui gets responsive again." - - | wait waitUntil | - waitDelay ifNil: [ waitDelay _ Delay forMilliseconds: 50 ]. - lastCycleHadAnyEvent - ifTrue: [ - pause _ 20. "This value will only be used when there are no more events to serve." - wait _ 0 ] "Don't wait" - ifFalse: [ - pause < 200 "No events processed? Start saving CPU!! But never make the user wait more than 200ms for being responsive again." - ifTrue: [ pause _ pause * 21//20 ]. - waitUntil _ lastCycleTime + pause. - "Earlier if steps" - stepList isEmpty not ifTrue: [ - waitUntil _ waitUntil min: stepList first scheduledTime ]. - "Earlier if alarms" - alarms ifNotNil: [ - alarms isEmpty not ifTrue: [ - waitUntil _ waitUntil min: alarms first scheduledTime ]]. - - wait _ waitUntil - Time localMillisecondClock ]. - Preferences serverMode - ifTrue: [ wait _ wait max: 50 ]. "Always wait at least a bit on servers, even if this makes the UI slow." - wait > 0 ifTrue: [ - waitDelay beingWaitedOn - ifFalse: [ waitDelay setDelay: wait; wait ] - ifTrue: [ - "If we are called from a different process than that of the main UI, we might be called in the main - interCyclePause. In such case, use a new Delay to avoid 'This Delay has already been scheduled' errors" - (Delay forMilliseconds: wait) wait ]]. - - "Record start time of this cycle, and do cycle" - lastCycleTime _ Time localMillisecondClock. - lastCycleHadAnyEvent _ self doOneCycleNow! ! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 3/2/2017 19:34:47'! - doOneCycleNow - "Immediately do one cycle of the interaction loop. - This should not be called directly, but only via doOneCycleFor:" - - | hadAnyEvent | - "See #eventTickler" - Cursor currentCursor = Cursor wait ifTrue: [ - Cursor normal activateCursor ]. - - "Repair visual damage." - DisplayScreen checkForNewScreenSize. - self displayWorldSafely. - - "Run steps, alarms and deferred UI messages" - world runStepMethods. - - "Process user input events. Run all event triggered code." - hadAnyEvent _ false. - self handsDo: [ :h | - activeHand _ h. - hadAnyEvent _ hadAnyEvent | h processEventQueue. - activeHand _ nil ]. - - "The default is the primary hand" - activeHand _ self hands first. - - - ^hadAnyEvent! ! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 3/2/2017 19:43:12'! - tryDeferredUpdatingAndSetCanvas - "If this platform supports deferred updates, then make my canvas be the Display (or a rectangular portion of it), set the Display to deferred update mode, and answer true. Otherwise, set a non-Disply canvas and answer false.." - | properDisplay | - - "As this is the only sender of #deferUpdates: , this could be done in Morphic or image startup, and never efterwards..." - (Display deferUpdates: true) ifNil: [ - "deferred updates not supported by the VM, do them in the image!!" - self ensureNonDisplayCanvas. - ^ false]. - - "if no canvas, or canvas was offscreen, from a platform that didnt support defers, then fix it" - properDisplay _ canvas notNil and: [canvas drawsOnDisplay]. - properDisplay ifFalse: [ - world morphPosition: 0@0 extent: Display extent. - self setCanvas: Display getCanvas. - ]. - ^ true! ! -!WorldState methodsFor: 'drawing' stamp: 'jmv 3/2/2017 19:43:18'! - displayWorldAndSubmorphs: submorphs - "Update this world's display." - - | deferredUpdateVMMode worldDamageRects handsToDraw allDamage | - self checkIfUpdateNeeded ifFalse: [ ^ self ]. "display is already up-to-date" - "I (jmv) removed the call to 'deferUpdates: false' below. No more need to call this every time." - deferredUpdateVMMode _ self tryDeferredUpdatingAndSetCanvas. - - "repair world's damage on canvas" - worldDamageRects _ self drawInvalidAreasSubmorphs: submorphs. - - "Check which hands need to be drawn (they are not the hardware mouse pointer)" - handsToDraw _ self selectHandsToDrawForDamage: worldDamageRects. - allDamage _ Array streamContents: [ :strm | - strm nextPutAll: worldDamageRects. - handsToDraw do: [ :h | - h savePatchFrom: canvas appendDamageTo: strm ]]. - - "Draw hands (usually carying morphs) onto world canvas" - canvas newClipRect: nil. - handsToDraw reverseDo: [ :h | canvas fullDrawHand: h ]. - - "quickly copy altered rects of canvas to Display:" - deferredUpdateVMMode ifFalse: [ - "Drawing was done to off-Display canvas. Copy content to Display" - canvas showAt: world viewBox origin invalidRects: allDamage ]. - - "Display deferUpdates: false." - "Display forceDisplayUpdate" - Display forceDamageToScreen: allDamage. - - "Restore world canvas under hands and their carried morphs" - handsToDraw do: [ :h | h restoreSavedPatchOn: canvas ].! ! -!WorldState methodsFor: 'drawing' stamp: 'jmv 3/2/2017 19:40:12'! - drawInvalidAreasSubmorphs: submorphs - "Redraw the damaged areas of the given canvas and clear the damage list. Return a collection of the areas that were redrawn." - - | initialRectsToRepair currentRectsToRepair newRectsToRepair morphsToDraw rectsForEachMorph thisMorphRects reuse i n morph morphBounds morphClipRect | - - "The simple implementation is slowers as it draws morph areas that will later be covered by other morphs. - But it works, and it is easier to understand. - See en.wikipedia.org/wiki/Painter's_algorithm" - true not ifTrue: [ ^self simpleDrawInvalidAreasSubmorphs: submorphs ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - initialRectsToRepair _ damageRecorder invalidRectsFullBounds: world viewBox. - damageRecorder reset. - currentRectsToRepair _ OrderedCollection new. - newRectsToRepair _ OrderedCollection withAll: initialRectsToRepair. - morphsToDraw _ OrderedCollection new. - rectsForEachMorph _ OrderedCollection new. - thisMorphRects _ OrderedCollection new. - n _ submorphs size. - i _ 1. - - "The idea here is to iterate morphs front to back, i.e. first the ones on top. - For each morph, record the rectangles it affects. And if a morph is opaque, remove the area behind it from the list of rectangles to be repaired. - This means, for example, that morphs completely covered might even not be redrawn. - this is a huge performance gain when there are many morphs on screen, especially if there are more than ten open windows, and Theme uses opaque colors. - See 'A reverse painter's algorithm' at en.wikipedia.org/wiki/Painter's_algorithm" - [ i <= n and: [ newRectsToRepair notEmpty ]] whileTrue: [ - morph _ submorphs at: i. - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - reuse _ currentRectsToRepair. - currentRectsToRepair _ newRectsToRepair. - newRectsToRepair _ reuse removeAll. - currentRectsToRepair do: [ :r | - (morphBounds intersects: r) - ifTrue: [ - morphClipRect _ morphBounds intersect: r. - thisMorphRects add: morphClipRect. "We could perhaps try and join adjacent rectangles in this collection..." - morph addPossiblyUncoveredAreasIn: r to: newRectsToRepair ] - ifFalse: [ - newRectsToRepair add: r ]]. - thisMorphRects ifNotEmpty: [ - morphsToDraw add: morph. - rectsForEachMorph add: thisMorphRects. - thisMorphRects _ OrderedCollection new. - ]]. - i _ i + 1 ]. - - "*make this true to flash damaged areas for testing*" - Preferences debugShowDamage ifTrue: [ world fillRects: initialRectsToRepair color: Color gray ]. - - "Draw world background on those areas that were not completely covered by opaque morphs" - i > n ifTrue: [ - newRectsToRepair do: [ :r | - world drawOn: (canvas newClipRect: r) ]]. - - "Now, draw the recorded areas of selected morphs, back to front." - morphsToDraw with: rectsForEachMorph reverseDo: [ :m :xrects | - "Here we could think about merging all xrects into just one call... - This would mean drawing each morph just once. - But that would mean drawing pixels we were not told to. There could be other morphs in that area that are not even being drawn!! - See WorldState class >> #experiment1" -" rr _ nil." - xrects do: [ :r | -" rr _ rr ifNil: [ r ] ifNotNil: [ r quickMerge: rr ]." - (canvas newClipRect: r) fullDraw: m. - ]. -" (canvas newClipRect: rr) fullDraw: m" - "*make this true to flash damaged areas for testing*" - Preferences debugShowDamage2 ifTrue: [ - world flashRects: xrects color: Color random ]. - ]. - - "Answer a list of rectangles to be updated on the Display. - This usually is not performance critical, drawing morphs is slower than just exposing the Display." - "What should we force on Display? Whatever was asked? Each small rect that was updated? A single bigger rect? - Right now, answer whatever was asked... Maybe this could be changed if that enhances performance... - (think of vnc over slow networks)" - ^ initialRectsToRepair! ! -!WorldState methodsFor: 'drawing' stamp: 'jmv 3/2/2017 19:39:56'! - simpleDrawInvalidAreasSubmorphs: submorphs - - "mover todo esto al canvas, no? - Y ver que hacer con los argumentos, etc.... Toda esta bananarama!!" - - "Redraw the damaged areas of the given canvas and clear the damage list. - Return a collection of the areas that were redrawn. - This simple implementation just does as requested: No optimizations are done." - - | rectsToRepair morphBounds | - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - rectsToRepair _ damageRecorder invalidRectsFullBounds: world viewBox. - damageRecorder reset. - - "Draw World" - rectsToRepair do: [ :r | - world drawOn: (canvas newClipRect: r) ]. - - "Draw morphs" - submorphs reverseDo: [ :morph | - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - rectsToRepair do: [ :r | - (morphBounds intersects: r) ifTrue: [ - (canvas newClipRect: r) fullDraw: morph ]]]]. - - ^ rectsToRepair! ! -!WorldState methodsFor: 'accessing' stamp: 'jmv 3/2/2017 21:47:15'! - runLocalStepMethods - "Run morph 'step' methods (LOCAL TO THIS WORLD) whose time has come. Purge any morphs that are no longer in this world." - - | now morphToStep scheduledTime | - now _ lastCycleTime. - self triggerAlarmsBefore: now. - stepList isEmpty - ifTrue: [ ^self]. - [ stepList isEmpty not and: [ stepList first scheduledTime <= now ]] - whileTrue: [ - lastStepMessage _ stepList removeFirst. - morphToStep _ lastStepMessage receiver. - (morphToStep shouldGetStepsFrom: world) - ifTrue: [ - scheduledTime _ lastStepMessage scheduledTime. - lastStepMessage valueAtTime: now - scheduledTime + lastStepMessage stepTime. - lastStepMessage ifNotNil: [ - lastStepMessage scheduledTime: (scheduledTime + lastStepMessage stepTime max: now + 1). - stepList add: lastStepMessage ]]. - lastStepMessage _ nil ]! ! -!PasteUpMorph methodsFor: 'interaction loop' stamp: 'jmv 3/2/2017 19:34:01' prior: 16887286! - doOneCycleNow - "see the comment in doOneCycleNowFor: - Only used for a few tests." - worldState doOneCycleNow! ! -!PasteUpMorph methodsFor: 'stepping' stamp: 'jmv 3/2/2017 19:36:23' prior: 16887443! - cleanseStepList - "Remove morphs from the step list that are not in this World. Often were in a flap that has moved on to another world." - - worldState cleanseStepList! ! -!PasteUpMorph methodsFor: 'stepping' stamp: 'jmv 3/2/2017 19:42:32' prior: 16887451! - runStepMethods - - worldState runStepMethods! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 3/2/2017 19:34:54' prior: 16887760! - displayWorldSafely - - worldState displayWorldSafely -! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 3/2/2017 19:33:20' prior: 16887765! - doOneCycle - "see the comment in WorldState >> doOneCycle" - - worldState doOneCycle! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 3/2/2017 19:37:11' prior: 16887829! - privateOuterDisplayWorld - - worldState displayWorldAndSubmorphs: submorphs -! ! -!WorldState class methodsFor: 'sample code' stamp: 'jmv 3/2/2017 19:39:21' prior: 16946320! - experiment1 - "To play with and learn about morphic Display update logic. - Remove the morphs when done!!" - " - WorldState experiment1 - " - | dr morph1 morph2 s w | - morph1 _ RectangleLikeMorph new openInWorld. - morph2 _ RectangleLikeMorph new openInWorld. - morph2 color: Color green. - morph2 morphPosition: 200@800 extent: 50@40. - morph1 morphPosition: 120@720 extent: 220@100. - - w _ self runningWorld. - s _ w instVarNamed: 'worldState'. - dr _ s instVarNamed: 'damageRecorder'. - - dr doFullRepaint. - dr reset; - " recordInvalidRect: (100@700 corner: 400@900);" - recordInvalidRect: (100@700 corner: 150@900); - recordInvalidRect: (300@700 corner: 400@900). - Display fillColor: Color gray. - "Do not draw the area used by the small rectangle, unless it is also drawn!!" - s drawInvalidAreasSubmorphs: {morph1. morph2 }! ! - -WorldState removeSelector: #cleanseStepListForWorld:! - -WorldState removeSelector: #cleanseStepListForWorld:! - -WorldState removeSelector: #displayWorld:submorphs:! - -WorldState removeSelector: #displayWorld:submorphs:! - -WorldState removeSelector: #displayWorldSafely:! - -WorldState removeSelector: #displayWorldSafely:! - -WorldState removeSelector: #doOneCycleFor:! - -WorldState removeSelector: #doOneCycleFor:! - -WorldState removeSelector: #doOneCycleNowFor:! - -WorldState removeSelector: #doOneCycleNowFor:! - -WorldState removeSelector: #drawInvalidAreasWorld:submorphs:! - -WorldState removeSelector: #drawInvalidAreasWorld:submorphs:! - -WorldState removeSelector: #runLocalStepMethodsIn:! - -WorldState removeSelector: #runLocalStepMethodsIn:! - -WorldState removeSelector: #runStepMethodsIn:! - -WorldState removeSelector: #runStepMethodsIn:! - -WorldState removeSelector: #simpleDrawInvalidAreasWorld:submorphs:! - -WorldState removeSelector: #simpleDrawInvalidAreasWorld:submorphs:! - -WorldState removeSelector: #tryDeferredUpdatingAndSetCanvasFor:! - -WorldState removeSelector: #tryDeferredUpdatingAndSetCanvasFor:! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3050-WorldState-refactor-JuanVuletich-2017Mar03-09h17m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3049] on 3 March 2017 at 9:22:19 am'! -!PasteUpMorph methodsFor: 'interaction loop' stamp: 'jmv 3/2/2017 19:58:01' prior: 50339854! - doOneCycleNow - "see the comment in WorldState >> doOneCycleNow - Only used for a few tests." - worldState doOneCycleNow! ! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 3/3/2017 09:21:41' prior: 50339571! - doOneCycleNow - "Immediately do one cycle of the interaction loop." - - | hadAnyEvent | - "See #eventTickler" - Cursor currentCursor = Cursor wait ifTrue: [ - Cursor normal activateCursor ]. - - "Repair visual damage." - DisplayScreen checkForNewScreenSize. - self displayWorldSafely. - - "Run steps, alarms and deferred UI messages" - self runStepMethods. - - "Process user input events. Run all event triggered code." - hadAnyEvent _ false. - self handsDo: [ :h | - activeHand _ h. - hadAnyEvent _ hadAnyEvent | h processEventQueue. - activeHand _ nil ]. - - "The default is the primary hand" - activeHand _ self hands first. - - - ^hadAnyEvent! ! - -PasteUpMorph removeSelector: #runStepMethods! - -PasteUpMorph removeSelector: #runStepMethods! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3051-WorldState-refactor-JuanVuletich-2017Mar03-09h17m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3049] on 3 March 2017 at 9:27:56 am'! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 3/2/2017 20:08:11'! - doOneMinimalCycleNow - "see the comment in WorldState >> doOneMinimalCycleNow" - - worldState doOneMinimalCycleNow! ! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 3/2/2017 20:06:48'! - doOneMinimalCycleNow - "Immediately do one cycle of the interaction loop. - Only repair display and process events. For modal menus and such." - - "Repair visual damage." - self displayWorldSafely. - - "Process user input events. Run all event triggered code." - ^activeHand processEventQueue! ! -!MenuMorph methodsFor: 'modal control' stamp: 'jmv 3/2/2017 20:08:34' prior: 16867177! - invokeModal: allowKeyboardControl - "Invoke this menu and don't return until the user has chosen a value. If the allowKeyboarControl boolean is true, permit keyboard control of the menu - See senders of this method for finding out how to use modal menu morphs." - | w oldFocus actHand | - w _ self runningWorld. - actHand _ w activeHand. - oldFocus _ actHand keyboardFocus. - w doOneMinimalCycleNow. - self - popUpAt: actHand morphPosition - forHand: actHand - allowKeyboard: allowKeyboardControl. - self isModalInvokationDone: false. - [ self isInWorld & self isModalInvokationDone not ] whileTrue: [ w doOneMinimalCycleNow ]. - self delete. - oldFocus ifNotNil: [ actHand newKeyboardFocus: oldFocus ]. - ^ self modalSelection! ! -!MVCMenuMorph methodsFor: 'invoking' stamp: 'jmv 3/2/2017 20:08:29' prior: 16865463! - invokeAt: aPoint allowKeyboard: aBoolean - "Add this menu to the given world centered at the given point. Wait for the user to make a selection and answer it. The selection value returned is an integer in keeping with PopUpMenu, if the menu is converted from an MVC-style menu." - "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop." - |actHand w oldFocus | - self flag: #bob. "is global or local?" - self flag: #arNote. " is local to aWorld" - w _ self runningWorld. - actHand _ w activeHand. - oldFocus _ actHand keyboardFocus. - w doOneMinimalCycleNow. - self - popUpAt: aPoint - forHand: actHand - allowKeyboard: aBoolean. - done _ false. - [ self isInWorld & done not ] whileTrue: [ w doOneMinimalCycleNow ]. - self delete. - oldFocus ifNotNil: [ actHand newKeyboardFocus: oldFocus ]. - ^ mvcSelection ! ! -!FillInTheBlankMorph methodsFor: 'invoking' stamp: 'jmv 3/2/2017 20:08:24' prior: 16844196! - getUserResponse - "Wait for the user to accept or cancel, and answer the result string. Answers the empty string if the user cancels." - "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop." - - | w | - w _ self world. - w ifNil: [^ response]. - done _ false. - textPane focusText. - [done] whileFalse: [w doOneMinimalCycleNow]. - self delete. - w doOneMinimalCycleNow. - ^ response -! ! -!FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'jmv 3/3/2017 09:26:42' prior: 16844289! - request: queryString initialAnswer: defaultAnswer centerAt: aPoint onCancelReturn: returnOnCancel acceptOnCR: acceptBoolean - "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. If the user cancels, answer returnOnCancel." - " - FillInTheBlankMorph - request: 'Type something, then type [Return].' - initialAnswer: 'yo ho ho!!' - " - - | aFillInTheBlankMorph | - aFillInTheBlankMorph _ self new - setQuery: queryString - initialAnswer: defaultAnswer - acceptOnCR: acceptBoolean. - aFillInTheBlankMorph responseUponCancel: returnOnCancel. - self runningWorld addMorph: aFillInTheBlankMorph centeredNear: aPoint. - ^ aFillInTheBlankMorph getUserResponse! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3052-MenusDoReducedWorldCycle-JuanVuletich-2017Mar03-09h22m-jmv.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3049] on 3 March 2017 at 9:49:08 am'! -!WorldState methodsFor: 'accessing' stamp: 'jmv 3/3/2017 09:47:13'! - runLocalStepMethods: nowTime - "Run morph 'step' methods (LOCAL TO THIS WORLD) whose time has come. Purge any morphs that are no longer in this world." - - | morphToStep scheduledTime | - [ stepList notEmpty and: [ stepList first scheduledTime <= nowTime ]] - whileTrue: [ - lastStepMessage _ stepList removeFirst. - morphToStep _ lastStepMessage receiver. - (morphToStep shouldGetStepsFrom: world) - ifTrue: [ - scheduledTime _ lastStepMessage scheduledTime. - lastStepMessage valueAtTime: nowTime - scheduledTime + lastStepMessage stepTime. - lastStepMessage ifNotNil: [ - lastStepMessage scheduledTime: (scheduledTime + lastStepMessage stepTime max: nowTime + 1). - stepList add: lastStepMessage ]]. - lastStepMessage _ nil ]! ! -!WorldState methodsFor: 'alarms' stamp: 'jmv 3/3/2017 09:33:59' prior: 16945643! - addAlarm: aSelector withArguments: argArray for: aTarget at: scheduledTime - "Add a new alarm with the given set of parameters" - - alarms add: - (MorphicAlarm - receiver: aTarget - selector: aSelector - arguments: argArray - at: scheduledTime)! ! -!WorldState methodsFor: 'alarms' stamp: 'jmv 3/3/2017 09:34:03' prior: 16945653! - adjustAlarmTimes: nowTime - "Adjust the alarm times after some clock weirdness (such as image-startup etc)" - | deltaTime | - deltaTime _ nowTime - lastAlarmTime. - alarms do: [ :alarm | - alarm scheduledTime: alarm scheduledTime + deltaTime ]! ! -!WorldState methodsFor: 'alarms' stamp: 'jmv 3/3/2017 09:34:21' prior: 16945673! - removeAlarm: aSelector for: aTarget - "Remove the alarm with the given selector" - - | alarm | - alarm := alarms - detect: [ :any | any receiver == aTarget and: [any selector == aSelector]] - ifNone: nil. - alarm ifNotNil: [ alarms remove: alarm ]! ! -!WorldState methodsFor: 'alarms' stamp: 'jmv 3/3/2017 09:35:03' prior: 16945684! - triggerAlarmsBefore: nowTime - "Trigger all pending alarms that are to be executed before nowTime." - - nowTime - lastAlarmTime > 10000 - ifTrue: [ self adjustAlarmTimes: nowTime ]. - [ alarms notEmpty and: [ alarms first scheduledTime < nowTime ]] - whileTrue: [ alarms removeFirst valueAtTime: nowTime ]. - lastAlarmTime _ nowTime! ! -!WorldState methodsFor: 'initialization' stamp: 'jmv 3/3/2017 09:33:53' prior: 16945782! - initialize - - activeHand _ HandMorph new. - hands _ { activeHand }. - damageRecorder _ DamageRecorder new. - stepList _ Heap sortBlock: self stepListSortBlock. - alarms _ Heap sortBlock: self alarmSortBlock. - lastAlarmTime _ 0. - drawingFailingMorphs _ WeakIdentitySet new. - pause _ 20. - lastCycleTime _ Time localMillisecondClock. - lastCycleHadAnyEvent _ false! ! -!WorldState methodsFor: 'stepping' stamp: 'jmv 3/3/2017 09:39:18' prior: 50339448! - cleanseStepList - "Remove morphs from the step list that are not in this World." - - | deletions morphToStep | - deletions _ nil. - stepList do: [:entry | - morphToStep _ entry receiver. - morphToStep world == world ifFalse:[ - deletions ifNil: [deletions _ OrderedCollection new]. - deletions addLast: entry]]. - - deletions ifNotNil:[ - deletions do: [:entry| - self stopSteppingMorph: entry receiver]]. - - alarms copy do: [ :entry | - morphToStep _ entry receiver. - ((morphToStep is: #Morph) and: [ morphToStep world == world ]) - ifFalse: [ self removeAlarm: entry selector for: entry receiver ]]! ! -!WorldState methodsFor: 'stepping' stamp: 'jmv 3/3/2017 09:46:37' prior: 50339471! - runStepMethods - "Perform periodic activity inbetween event cycles" - | queue msg | - - queue _ self class deferredUIMessages. - [ (msg _ queue nextOrNil) isNil ] whileFalse: [ - msg value - ]. - self triggerAlarmsBefore: lastCycleTime. - self runLocalStepMethods: lastCycleTime. - - "we are using a normal #step for these now" - "aWorld allLowerWorldsDo: [ :each | each runLocalStepMethods ]." -! ! - -WorldState removeSelector: #alarms! - -WorldState removeSelector: #alarms! - -WorldState removeSelector: #runLocalStepMethods! - -WorldState removeSelector: #runLocalStepMethods! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3053-WorldState-refactor-JuanVuletich-2017Mar03-09h27m-jmv.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3053] on 3 March 2017 at 11:17:47 am'! - -MorphicAlarm subclass: #StepMessage - instanceVariableNames: 'stepTime lastEvaluationTime ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Events'! - -!classDefinition: #StepMessage category: #'Morphic-Events'! -MorphicAlarm subclass: #StepMessage - instanceVariableNames: 'stepTime lastEvaluationTime' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Events'! -!StepMessage methodsFor: 'evaluating' stamp: 'jmv 3/3/2017 11:14:28'! - valueAtTime: millisecondClock - - | nArgs millisecondsSinceLast | - numArgs ifNil: [numArgs _ selector numArgs]. - nArgs _ arguments ifNil: [0] ifNotNil: [arguments size]. -"OJO!!" -lastEvaluationTime ifNil: [ lastEvaluationTime _ millisecondClock ]. - millisecondsSinceLast _ millisecondClock - lastEvaluationTime. - lastEvaluationTime _ millisecondClock. - nArgs = numArgs ifTrue: [ - "Ignore extra argument" - ^self value ]. - ^arguments - ifNil: [ receiver perform: selector with: millisecondsSinceLast] - ifNotNil: [ receiver perform: selector withArguments: (arguments copyWith: millisecondsSinceLast) ]! ! -!WorldState methodsFor: 'accessing' stamp: 'jmv 3/3/2017 11:16:08' prior: 50340135! - runLocalStepMethods: nowTime - "Run morph 'step' methods (LOCAL TO THIS WORLD) whose time has come. Purge any morphs that are no longer in this world." - - | morphToStep scheduledTime | - [ stepList notEmpty and: [ stepList first scheduledTime <= nowTime ]] - whileTrue: [ - lastStepMessage _ stepList removeFirst. - morphToStep _ lastStepMessage receiver. - (morphToStep shouldGetStepsFrom: world) - ifTrue: [ - scheduledTime _ lastStepMessage scheduledTime. - lastStepMessage valueAtTime: nowTime. - lastStepMessage ifNotNil: [ - lastStepMessage scheduledTime: (scheduledTime + lastStepMessage stepTime max: nowTime + 1). - stepList add: lastStepMessage ]]. - lastStepMessage _ nil ]! ! - -MorphicAlarm subclass: #StepMessage - instanceVariableNames: 'stepTime lastEvaluationTime' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Events'! - -!classDefinition: #StepMessage category: #'Morphic-Events'! -MorphicAlarm subclass: #StepMessage - instanceVariableNames: 'stepTime lastEvaluationTime' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Events'! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3054-StepMessageCleanup-JuanVuletich-2017Mar03-11h11m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3053] on 3 March 2017 at 11:41:31 am'! -!StepMessage methodsFor: 'evaluating' stamp: 'jmv 3/3/2017 11:28:02'! - rescheduleAfter: millisecondTimer - "Schedule next run" - scheduledTime _ scheduledTime + self stepTime max: millisecondTimer + 1! ! -!WorldState methodsFor: 'stepping' stamp: 'jmv 3/3/2017 11:39:34' prior: 16945882! - stopStepping: aMorph selector: aSelector - "Remove the given morph from the step list." - stepList removeAll: (stepList select:[:stepMsg| stepMsg receiver == aMorph and: [ stepMsg selector == aSelector ]])! ! -!WorldState methodsFor: 'stepping' stamp: 'jmv 3/3/2017 11:39:22' prior: 16945896! - stopSteppingMorph: aMorph - "Remove the given morph from the step list." - stepList removeAll: (stepList select: [ :stepMsg | stepMsg receiver == aMorph])! ! -!WorldState methodsFor: 'accessing' stamp: 'jmv 3/3/2017 11:39:10' prior: 50340307! - runLocalStepMethods: nowTime - "Run morph 'step' methods (LOCAL TO THIS WORLD) whose time has come. Purge any morphs that are no longer in this world." - - | stepMessage | - [ stepList notEmpty and: [ stepList first scheduledTime <= nowTime ]] - whileTrue: [ - - stepMessage _ stepList first. - (stepMessage receiver shouldGetStepsFrom: world) - ifTrue: [ - stepMessage valueAtTime: nowTime. - "If it was not removed from the list during its own evaluation" - stepMessage == stepList first ifTrue: [ - stepList removeFirst. - stepMessage rescheduleAfter: nowTime. - stepList add: stepMessage ]] - - ifFalse: [ stepList removeFirst ]. - ]! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3055-SteppingCleanup-JuanVuletich-2017Mar03-11h17m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3053] on 3 March 2017 at 11:55:19 am'! -!StepMessage methodsFor: 'evaluating' stamp: 'jmv 3/3/2017 11:55:15' prior: 50340285! - valueAtTime: millisecondClock - - | nArgs millisecondsSinceLast | - numArgs ifNil: [numArgs _ selector numArgs]. - nArgs _ arguments ifNil: [0] ifNotNil: [arguments size]. - lastEvaluationTime ifNil: [ lastEvaluationTime _ millisecondClock ]. - millisecondsSinceLast _ millisecondClock - lastEvaluationTime. - lastEvaluationTime _ millisecondClock. - nArgs = numArgs ifTrue: [ - "Ignore extra argument" - ^self value ]. - ^arguments - ifNil: [ receiver perform: selector with: millisecondsSinceLast] - ifNotNil: [ receiver perform: selector withArguments: (arguments copyWith: millisecondsSinceLast) ]! ! -!PasteUpMorph methodsFor: 'caching' stamp: 'jmv 3/3/2017 11:42:44' prior: 16887042! - releaseCachedState - super releaseCachedState. - backgroundImage _ nil. - self isWorldMorph ifTrue: [ - worldState cleanseStepList. - worldState clearCanvas ]! ! -!WorldState methodsFor: 'alarms' stamp: 'jmv 3/3/2017 11:54:00' prior: 50340184! - removeAlarm: aSelector for: aTarget - "Remove the alarm with the given selector" - - | alarm | - alarm _ alarms - detect: [ :any | any receiver == aTarget and: [any selector == aSelector]] - ifNone: nil. - alarm ifNotNil: [ alarms remove: alarm ]! ! -!WorldState methodsFor: 'stepping' stamp: 'jmv 3/3/2017 11:51:16' prior: 50340223! - cleanseStepList - "Remove morphs from the step list that are not in this World." - - | deletions | - deletions _ OrderedCollection new. - stepList do: [ :entry | - entry receiver world == world ifFalse: [ - deletions add: entry]]. - deletions do: [ :entry| - stepList remove: entry ]. - - deletions _ OrderedCollection new. - alarms do: [ :entry | - ((entry receiver is: #Morph) and: [ entry receiver world == world ]) ifFalse: [ - deletions add: entry]]. - deletions do: [ :entry| - alarms remove: entry ]! ! - -PasteUpMorph removeSelector: #cleanseStepList! - -PasteUpMorph removeSelector: #cleanseStepList! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3056-SteppingCleanup-JuanVuletich-2017Mar03-11h41m-jmv.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3056] on 3 March 2017 at 3:11:05 pm'! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 3/3/2017 15:04:20' prior: 50339515! - doOneCycle - "Do one cycle of the interaction loop. This method is called repeatedly when the world is running. - - Make for low cpu usage if the ui is inactive, but quick response when ui is in use. - However, after some inactivity, there will be a larger delay before the ui gets responsive again." - - | wait waitUntil | - waitDelay ifNil: [ waitDelay _ Delay forMilliseconds: 50 ]. - lastCycleHadAnyEvent - ifTrue: [ - pause _ 20. "This value will only be used when there are no more events to serve." - wait _ 0 ] "Don't wait" - ifFalse: [ - pause < 200 "No events processed? Start saving CPU!! But never make the user wait more than 200ms for being responsive again." - ifTrue: [ pause _ pause * 21//20 ]. - waitUntil _ lastCycleTime + pause. - "Earlier if steps" - stepList isEmpty not ifTrue: [ - waitUntil _ waitUntil min: stepList first scheduledTime ]. - "Earlier if alarms" - alarms ifNotNil: [ - alarms isEmpty not ifTrue: [ - waitUntil _ waitUntil min: alarms first scheduledTime ]]. - - wait _ waitUntil - Time localMillisecondClock ]. - Preferences serverMode - ifTrue: [ wait _ wait max: 50 ]. "Always wait at least a bit on servers, even if this makes the UI slow." - wait > 5 - ifFalse: [ Processor yield ] - ifTrue: [ - waitDelay beingWaitedOn - ifFalse: [ waitDelay setDelay: wait; wait ] - ifTrue: [ - "If we are called from a different process than that of the main UI, we might be called in the main - interCyclePause. In such case, use a new Delay to avoid 'This Delay has already been scheduled' errors" - (Delay forMilliseconds: wait) wait ]]. - - "Record start time of this cycle, and do cycle" - lastCycleTime _ Time localMillisecondClock. - lastCycleHadAnyEvent _ self doOneCycleNow! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3057-SteppingHangWorkaround-JuanVuletich-2017Mar03-15h10m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3049] on 3 March 2017 at 7:15:45 pm'! -!TestCase methodsFor: 'Running' stamp: 'HAW 3/3/2017 19:13:13'! - debugAsFailureIfCanNot: handler - - | semaphore | - - self ifCanNotDebugDo: [ ^handler value]. - - semaphore := Semaphore new. - self resources do: [:res | - res isAvailable ifFalse: [^res signalInitializationError]]. - [semaphore wait. - self tearDown. - self resources do: [:each | each reset]] fork. - (self class selector: testSelector) runCaseAsFailure: semaphore.! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 3/3/2017 14:13:09'! - canNotDebugMethodErrorDescription - - ^self class canNotDebugMethodErrorDescription! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 3/3/2017 18:50:08'! - ifCanNotDebugDo: handler - - ^self testMethod isQuick ifTrue: handler! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 3/3/2017 14:13:37'! - signalCanNotDebugMethod - - self error: self canNotDebugMethodErrorDescription! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 3/3/2017 14:10:20'! - testMethod - - ^self class lookupSelector: self selector! ! -!TestCase class methodsFor: 'Instance Creation' stamp: 'HAW 3/3/2017 18:51:38'! - debugAsFailure: aSymbol ifCanNot: handler - - ^(self selector: aSymbol) debugAsFailureIfCanNot: handler - ! ! -!TestCase class methodsFor: 'Error Descriptions' stamp: 'HAW 3/3/2017 16:33:00'! - canNotDebugMethodErrorDescription - - ^'Quick methods can not be debugged'! ! -!Browser methodsFor: 'tdd' stamp: 'HAW 3/3/2017 19:12:25' prior: 50338019! - debugMethodTest - - currentCompiledMethod isTestMethod ifTrue: [ - currentCompiledMethod methodClass debugAsFailure: currentCompiledMethod selector ifCanNot: [ PopUpMenu inform: TestCase canNotDebugMethodErrorDescription ]] -! ! -!SmalltalkEditor methodsFor: 'tdd' stamp: 'HAW 3/3/2017 19:12:39' prior: 50338106! - acceptAndDebugTest - - ^self acceptAndWithMethodDo: [ :aPotencialTestMethod | - aPotencialTestMethod isTestMethod ifTrue: [ - aPotencialTestMethod methodClass debugAsFailure: aPotencialTestMethod selector ifCanNot: [ PopUpMenu inform: TestCase canNotDebugMethodErrorDescription ]]]! ! -!TestCase methodsFor: 'Running' stamp: 'HAW 3/3/2017 18:49:24' prior: 16927491! - debugAsFailure - - ^self debugAsFailureIfCanNot: [ self signalCanNotDebugMethod ]! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 3/3/2017 19:13:40' prior: 16927518! - openDebuggerOnFailingTestMethod - - | guineaPig context compiledMethod debugger | - - compiledMethod _ self testMethod. - guineaPig _ [ self performTest ] newProcess. - context _ guineaPig suspendedContext. - debugger _ Debugger new - process: guineaPig - context: context. - debugger openFullNoSuspendLabel: 'Debug failed test ', self printString. - - [debugger interruptedContext method == compiledMethod] - whileFalse: [debugger send]. -! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 3/3/2017 19:14:27' prior: 16927535! - openDebuggerOnFailingTestMethod: semaphore - - | guineaPig context compiledMethod debugger | - - compiledMethod _ self testMethod. - guineaPig _ [ self performTest ] newProcess. - context _ guineaPig suspendedContext. - debugger _ TestCaseDebugger new - process: guineaPig - context: context. - debugger doneSemaphore: semaphore. - debugger openFullNoSuspendLabel: 'Debug failed test ', self printString. - - [debugger interruptedContext method == compiledMethod] - whileFalse: [debugger send]. -! ! - -TestCase class removeSelector: #debugAsFailure:! - -TestCase class removeSelector: #debugAsFailure:! - -TestCase removeSelector: #assertCanDebugMethod! - -TestCase removeSelector: #canNotDebugQuickMethodErrorDescription! - -TestCase removeSelector: #signalCanNotDebugQuickMethod! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3058-CuisCore-HernanWilkinson-2017Mar02-18h30m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3058] on 6 March 2017 at 10:14:29 am'! -!Delay class methodsFor: 'timer process' stamp: 'jmv 3/6/2017 10:13:34' prior: 16833016! - handleTimerEvent - "Handle a timer event; which can be either: - - a schedule request (ScheduledDelay notNil) - - an unschedule request (FinishedDelay notNil) - - a timer signal (not explicitly specified) - We check for timer expiry every time we get a signal." - | nowTick nextTick afterwardsTick | - "Wait until there is work to do." - TimingSemaphore wait. - - "Process any schedule requests" - ScheduledDelay ifNotNil: [ - "Schedule the given delay" - self scheduleDelay: ScheduledDelay. - ScheduledDelay := nil. - ScheduledDelayNilledSemaphore initSignals. - ScheduledDelayNilledSemaphore signal ]. - - "Process any unschedule requests" - FinishedDelay ifNotNil: [ - self unscheduleDelay: FinishedDelay. - FinishedDelay := nil. - FinishedDelayNilledSemaphore initSignals. - FinishedDelayNilledSemaphore signal ]. - - "Check for clock wrap-around." - nowTick := Time millisecondClockValue. - nowTick < ActiveDelayStartTime ifTrue: [ - "clock wrapped" - self saveResumptionTimes. - self restoreResumptionTimes ]. - ActiveDelayStartTime := nowTick. - - "Signal any expired delays" - [ ActiveDelay notNil and:[ nowTick >= ActiveDelay resumptionTime ]] whileTrue: [ - ActiveDelay signalWaitingProcess. - SuspendedDelays isEmpty - ifTrue: [ ActiveDelay := nil ] - ifFalse:[ ActiveDelay := SuspendedDelays removeFirst ]]. - - "And signal when the next request is due. We sleep at most 1sec here - as a soft busy-loop so that we don't accidentally miss signals." - nextTick := nowTick + 1000. - ActiveDelay ifNotNil: [ - nextTick := nextTick min: ActiveDelay resumptionTime ]. - nextTick := nextTick min: SmallInteger maxVal. - - "Since we have processed all outstanding requests, reset the timing semaphore so - that only new work will wake us up again. Do this RIGHT BEFORE setting the next - wakeup call from the VM because it is only signaled once so we mustn't miss it." - TimingSemaphore initSignals. - Delay primSignal: TimingSemaphore atMilliseconds: nextTick. - - "This test is necessary for the obscure case that the msecs clock rolls over - after nowTick has been computed (unlikely but not impossible). In this case we'd - wait for MillisecondClockMask msecs (roughly six days) or until another delay gets - scheduled (which may not be any time soon). In any case, since handling the - condition is easy, let's just deal with it." - afterwardsTick _ Time millisecondClockValue. - afterwardsTick < nowTick "Means clock rollover." - ifTrue: [ TimingSemaphore signal ]. "retry" - - "It seems that #primSignal:atMilliseconds: might not signal the semaphore if the requested moment is in the past. - This behavior was observed in Linux Spur64 VMs. - If this happens, next delay never finishes. Usual symptom is frozen Morphic. - If there is any risk of this happening, just do another iteration right now." - nextTick < afterwardsTick "We're already late for next signal." - ifTrue: [ TimingSemaphore signal ]. "retry"! ! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 3/5/2017 00:38:27' prior: 50340477! - doOneCycle - "Do one cycle of the interaction loop. This method is called repeatedly when the world is running. - - Make for low cpu usage if the ui is inactive, but quick response when ui is in use. - However, after some inactivity, there will be a larger delay before the ui gets responsive again." - - | wait waitUntil | - waitDelay ifNil: [ waitDelay _ Delay forMilliseconds: 50 ]. - lastCycleHadAnyEvent - ifTrue: [ - pause _ 20. "This value will only be used when there are no more events to serve." - wait _ 0 ] "Don't wait" - ifFalse: [ - pause < 200 "No events processed? Start saving CPU!! But never make the user wait more than 200ms for being responsive again." - ifTrue: [ pause _ pause * 21//20 ]. - waitUntil _ lastCycleTime + pause. - "Earlier if steps" - stepList isEmpty not ifTrue: [ - waitUntil _ waitUntil min: stepList first scheduledTime ]. - "Earlier if alarms" - alarms ifNotNil: [ - alarms isEmpty not ifTrue: [ - waitUntil _ waitUntil min: alarms first scheduledTime ]]. - - wait _ waitUntil - Time localMillisecondClock ]. - Preferences serverMode - ifTrue: [ wait _ wait max: 50 ]. "Always wait at least a bit on servers, even if this makes the UI slow." - wait > 0 - ifFalse: [ Processor yield ] - ifTrue: [ - waitDelay beingWaitedOn - ifFalse: [ waitDelay setDelay: wait; wait ] - ifTrue: [ - "If we are called from a different process than that of the main UI, we might be called in the main - interCyclePause. In such case, use a new Delay to avoid 'This Delay has already been scheduled' errors" - (Delay forMilliseconds: wait) wait ]]. - - "Record start time of this cycle, and do cycle" - lastCycleTime _ Time localMillisecondClock. - lastCycleHadAnyEvent _ self doOneCycleNow! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3059-RealFixForSteppingFreeze-JuanVuletich-2017Mar06-10h02m-jmv.1.cs.st----! - -----SNAPSHOT----#(6 March 2017 10:16:14.796027 am) Cuis5.0-3059-spur-64.image priorSource: 203014! - -----QUIT----#(6 March 2017 10:16:31.136894 am) Cuis5.0-3059-spur-64.image priorSource: 293443! - -----STARTUP----#(8 March 2017 9:09:50.654222 am) as /home/juan/Rectifier/Cuis-Smalltalk-Dev/Cuis5.0-3059-spur-64.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3059] on 7 March 2017 at 9:52:45 am'! -!Time class methodsFor: 'primitives' stamp: 'jmv 3/7/2017 09:52:37' prior: 16937622! - primMillisecondClock - "Primitive. Answer the number of milliseconds since the millisecond clock - was last reset or rolled over. No sync to any system clock. - Implemented by all major platforms. - Essential. See Object documentation whatIsAPrimitive. - - Time primMillisecondClock - Time primMillisecondClock / 1000 / 60.0 - - Range is from zero to 16r1FFFFFFF. - The VM defines MillisecondClockMask as 16r1FFFFFFF - - Overflows usually every six days. - Still used in #localMillisecondClock if the VM doesn't implement - Time primLocalMicrosecondClock - " -"Not really a clock, but a timer or ticker" - - - self primitiveFailed! ! -!Delay class methodsFor: 'timer process' stamp: 'jmv 3/7/2017 09:51:10' prior: 50340665! - handleTimerEvent - "Handle a timer event; which can be either: - - a schedule request (ScheduledDelay notNil) - - an unschedule request (FinishedDelay notNil) - - a timer signal (not explicitly specified) - We check for timer expiry every time we get a signal." - | nowTick nextTick afterwardsTick | - "Wait until there is work to do." - TimingSemaphore wait. - - "Process any schedule requests" - ScheduledDelay ifNotNil: [ - "Schedule the given delay" - self scheduleDelay: ScheduledDelay. - ScheduledDelay := nil. - ScheduledDelayNilledSemaphore initSignals. - ScheduledDelayNilledSemaphore signal ]. - - "Process any unschedule requests" - FinishedDelay ifNotNil: [ - self unscheduleDelay: FinishedDelay. - FinishedDelay := nil. - FinishedDelayNilledSemaphore initSignals. - FinishedDelayNilledSemaphore signal ]. - - "Check for clock wrap-around." - nowTick := Time millisecondClockValue. - nowTick < ActiveDelayStartTime ifTrue: [ - "clock wrapped" - self saveResumptionTimes. - self restoreResumptionTimes ]. - ActiveDelayStartTime := nowTick. - - "Signal any expired delays" - [ ActiveDelay notNil and:[ nowTick >= ActiveDelay resumptionTime ]] whileTrue: [ - ActiveDelay signalWaitingProcess. - SuspendedDelays isEmpty - ifTrue: [ ActiveDelay := nil ] - ifFalse:[ ActiveDelay := SuspendedDelays removeFirst ]]. - - "And signal when the next request is due. We sleep at most 1sec here - as a soft busy-loop so that we don't accidentally miss signals." - nextTick := nowTick + 1000. - ActiveDelay ifNotNil: [ - nextTick := nextTick min: ActiveDelay resumptionTime ]. - nextTick := nextTick min: 16r1FFFFFFF. "MillisecondClockMask" - - "Since we have processed all outstanding requests, reset the timing semaphore so - that only new work will wake us up again. Do this RIGHT BEFORE setting the next - wakeup call from the VM because it is only signaled once so we mustn't miss it." - TimingSemaphore initSignals. - Delay primSignal: TimingSemaphore atMilliseconds: nextTick. - - "This test is necessary for the obscure case that the msecs clock rolls over - after nowTick has been computed (unlikely but not impossible). In this case we'd - wait for MillisecondClockMask msecs (roughly six days) or until another delay gets - scheduled (which may not be any time soon). In any case, since handling the - condition is easy, let's just deal with it." - afterwardsTick _ Time millisecondClockValue. - afterwardsTick < nowTick "Means clock rollover." - ifTrue: [ TimingSemaphore signal ]. "retry" - - "It seems that #primSignal:atMilliseconds: might not signal the semaphore if the requested moment is in the past. - This behavior was observed in Linux Spur64 VMs. - If this happens, next delay never finishes. Usual symptom is frozen Morphic. - If there is any risk of this happening, just do another iteration right now." - nextTick < afterwardsTick "We're already late for next signal." - ifTrue: [ TimingSemaphore signal ]. "retry"! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3060-Proper-MillisecondClockMask-JuanVuletich-2017Mar07-09h05m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3061] on 7 March 2017 at 12:20:30 pm'! -!Time class methodsFor: 'primitives' stamp: 'jmv 3/7/2017 12:16:43' prior: 16937642! - primUtcMicrosecondClock - "Answer the number of microseconds since the UTC Smalltalk epoch, - i.e. 00:00 on the morning of January 1, 1901, the start of the 20th century, in UTC time. - The value is derived from the Posix epoch with a constant offset corresponding to elapsed microseconds - between the two epochs according to RFC 868. - Answer is (at least usually) a LargePositiveInteger - Cog VMs implement this. Interpreters might not." - " - Time primUtcMicrosecondClock - Time primUtcMicrosecondClock/ 1000 / 1000 / 60 / 60 / 24 / 365.25 - - (Time primUtcMicrosecondClock / 1000 / 1000 + Time primUtcWithOffset second) / 60 / 60 / 24 / 365.25 - (DateAndTime now - (DateAndTime year: 1901 month: 1 day: 1)) totalSeconds / 60 / 60 / 24 / 365.25 - " - - ^nil! ! -!Delay class methodsFor: 'primitives' stamp: 'jmv 3/7/2017 12:19:39'! - primSignal: aSemaphore atUTCMicroseconds: anInteger - "Signal the semaphore when the UTC microsecond clock reaches the value of the second argument. - Fail if the first argument is neither a Semaphore nor nil. - Fail if the second argument is not an integer (either SmallInteger or LargePositiveInteger). - See #primUtcMicrosecondClock - Essential. See Object documentation whatIsAPrimitive." - - ^self primitiveFailed! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3061-UTCDelayedSignalPrimitive-JuanVuletich-2017Mar07-12h16m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3061] on 7 March 2017 at 2:55:27 pm'! - -BorderedRectMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp titleMorph activeSubMenu popUpOwner ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #MenuMorph category: #'Morphic-Menus'! -BorderedRectMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp titleMorph activeSubMenu popUpOwner' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! -!MenuMorph methodsFor: 'control' stamp: 'ar 9/17/2000 20:38'! - activeSubmenu: aSubmenu - activeSubMenu ifNotNil:[activeSubMenu delete]. - activeSubMenu _ aSubmenu.! ! -!MenuMorph methodsFor: 'initialization' stamp: 'ar 10/10/2000 01:57'! - delete - activeSubMenu ifNotNil:[activeSubMenu delete]. - ^super delete! ! -!MenuItemMorph methodsFor: 'events' stamp: 'jmv 9/20/2012 00:14'! - activateOwnerMenu: evt - "Activate our owner menu; e.g., pass control to it" - owner ifNil: [ ^false ]. "not applicable" - (owner morphContainsPoint: (owner internalizeFromWorld: evt eventPosition)) - ifFalse: [ ^false ]. - owner activate: evt. - ^true! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 3/7/2017 14:37:43' prior: 50339178! - deleteIfPopUp: evt - "Remove this menu from the screen if stayUp is not true. If it is a submenu, also remove its owning menu." - - stayUp ifFalse: [ self delete ]. - popUpOwner ifNotNil: [ - popUpOwner isSelected: false. - popUpOwner deleteIfPopUp: evt ]. - evt ifNotNil: [ evt hand ifNotNil: [ :h | h releaseMouseFocus: self ]]! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 5/9/2016 20:40' prior: 50339187! - popUpAdjacentTo: rightOrLeftPointInWorld from: sourceItem - "Present this menu at the given point under control of the given hand. - Used mostly for submenus." - - | delta tryToPlace selectedOffset | - popUpOwner _ sourceItem. - selectedOffset _ (selectedItem ifNil: [ self items first ]) morphPosition. - sourceItem world addMorphFront: self. - - tryToPlace _ [ :where :mustFit | - self morphPosition: where - selectedOffset. - delta _ self morphFullBoundsInWorld - amountToTranslateWithin: sourceItem world morphBoundsInWorld. - (delta x = 0 | mustFit) ifTrue: [ - delta = (0@0) ifFalse: [ self morphPosition: self morphPosition + delta ]. - ^ self]]. - tryToPlace - value: rightOrLeftPointInWorld first value: false; - value: rightOrLeftPointInWorld last - (extent x @ 0) value: false; - value: rightOrLeftPointInWorld first value: true! ! -!MenuMorph methodsFor: 'events-processing' stamp: 'jmv 8/20/2012 17:50' prior: 50339326! - handleFocusEvent: aMorphicEvent - "Handle focus events. Valid menu transitions are determined based on the menu currently holding the focus after the mouse went down on one of its children." - | eventPositionInOurCoordinates | - eventPositionInOurCoordinates _ self internalizeFromWorld: aMorphicEvent eventPosition. - - self dispatchEvent: aMorphicEvent localPosition: eventPositionInOurCoordinates. - - "Need to handle keyboard input if we have the focus." - aMorphicEvent isKeyboard ifTrue: [ ^ aMorphicEvent sentTo: self localPosition: eventPositionInOurCoordinates]. - - "We need to handle button clicks outside and transitions to local popUps so throw away everything else" - (aMorphicEvent isMouseOver or: [aMorphicEvent isMouse not]) ifTrue: [ ^self ]. - "What remains are mouse buttons and moves" - aMorphicEvent isMove ifFalse: [ ^ aMorphicEvent sentTo: self localPosition: eventPositionInOurCoordinates ]. "handle clicks outside by regular means" - "Now it's getting tricky. On #mouseMove we might transfer control to *either* the currently active submenu or the pop up owner, if any. Since the active sub menu is always displayed upfront check it first." - selectedItem ifNotNil:[(selectedItem activateSubmenu: aMorphicEvent) ifTrue: [^self]]. - "Note: The following does not traverse upwards but it's the best I can do for now" - popUpOwner ifNotNil:[(popUpOwner activateOwnerMenu: aMorphicEvent) ifTrue: [^self]].! ! -!MenuMorph methodsFor: 'initialization' stamp: 'jmv 9/8/2012 20:15' prior: 50339368! - initialize - super initialize. - extent _ 40@10. - defaultTarget _ nil. - selectedItem _ nil. - stayUp _ false. - popUpOwner _ nil! ! -!MenuItemMorph methodsFor: 'selecting' stamp: 'jmv 1/29/2014 23:46' prior: 50339381! - deselect - - self isSelected: false. - subMenu ifNotNil: [ - owner ifNotNil:[ owner activeSubmenu: nil ]. - self removeAlarm: #deselectTimeOut ]! ! -!MenuItemMorph methodsFor: 'selecting' stamp: 'jmv 1/29/2014 23:44' prior: 50339387! - select - self isSelected: true. - owner activeSubmenu: subMenu. - subMenu ifNotNil: [ - subMenu delete. - subMenu - popUpAdjacentTo: (Array with: self morphBoundsInWorld topRight + (10@0) - with: self morphBoundsInWorld topLeft) - from: self. - subMenu selectItem: nil ]! ! - -BorderedRectMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp titleMorph activeSubMenu popUpOwner' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -!classDefinition: #MenuMorph category: #'Morphic-Menus'! -BorderedRectMorph subclass: #MenuMorph - instanceVariableNames: 'defaultTarget selectedItem stayUp titleMorph activeSubMenu popUpOwner' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Menus'! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3062-FixRecentMenuBreackage-JuanVuletich-2017Mar07-14h20m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3049] on 7 March 2017 at 3:18:07 pm'! -!TestCase methodsFor: 'Private' stamp: 'HAW 3/6/2017 14:55:23'! - methodForTest - - "Can not call it testMethod because it will be detected as test - Hernan" - - ^self class lookupSelector: self selector! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 3/6/2017 14:55:38' prior: 50340560! - ifCanNotDebugDo: handler - - ^self methodForTest isQuick ifTrue: handler! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 3/6/2017 14:55:45' prior: 50340614! - openDebuggerOnFailingTestMethod - - | guineaPig context compiledMethod debugger | - - compiledMethod _ self methodForTest. - guineaPig _ [ self performTest ] newProcess. - context _ guineaPig suspendedContext. - debugger _ Debugger new - process: guineaPig - context: context. - debugger openFullNoSuspendLabel: 'Debug failed test ', self printString. - - [debugger interruptedContext method == compiledMethod] - whileFalse: [debugger send]. -! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 3/6/2017 14:55:50' prior: 50340631! - openDebuggerOnFailingTestMethod: semaphore - - | guineaPig context compiledMethod debugger | - - compiledMethod _ self methodForTest. - guineaPig _ [ self performTest ] newProcess. - context _ guineaPig suspendedContext. - debugger _ TestCaseDebugger new - process: guineaPig - context: context. - debugger doneSemaphore: semaphore. - debugger openFullNoSuspendLabel: 'Debug failed test ', self printString. - - [debugger interruptedContext method == compiledMethod] - whileFalse: [debugger send]. -! ! - -TestCase removeSelector: #testMethod! - -TestCase removeSelector: #testMethod! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3063-FixForExtraTest-HernanWilkinson-2017Mar03-19h15m-HAW.1.cs.st----! - -----SNAPSHOT----#(8 March 2017 9:10:16.580592 am) Cuis5.0-3063-spur-64.image priorSource: 293543! - -----QUIT----#(8 March 2017 9:10:32.980626 am) Cuis5.0-3063-spur-64.image priorSource: 306790! - -----STARTUP----#(13 March 2017 4:27:27.626002 pm) as /home/juan/Rectifier/Cuis-Smalltalk-Dev/Cuis5.0-3063-spur-64.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3063] on 13 March 2017 at 4:16:45 pm'! -!WriteStream methodsFor: 'accessing' stamp: 'jmv 3/12/2017 18:55:36' prior: 50335208! - nextPutAllString: aString withAttributes: attributesArray - - | newEnd | - (self isCompatibleWithContents: aString) - ifFalse: [ ^ self nextPutAll: aString ]. - - newEnd _ position + aString size. - newEnd > writeLimit ifTrue: [ - self growTo: newEnd + 10]. - - collection - replaceFrom: position+1 - to: newEnd - withString: aString - attributes: attributesArray - startingAt: 1. - position _ newEnd! ! -!WriteStream methodsFor: 'private' stamp: 'jmv 3/12/2017 19:08:07' prior: 16946568! -growTo: anInteger - "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. - - anInteger is the required minimal new size of the collection " - - | oldSize grownCollection newSize | - oldSize _ collection size. - newSize _ anInteger + (oldSize max: 20). - grownCollection _ collection class new: newSize. - collection _ grownCollection replaceFrom: 1 to: oldSize with: collection startingAt: 1. - writeLimit _ collection size! ! -!WriteStream methodsFor: 'private' stamp: 'jmv 3/12/2017 19:07:28' prior: 16946596! - pastEndPut: anObject - "Grow the collection. - Then we put at the current write position." - - self growTo: collection size + 1. - collection at: (position _ position + 1) put: anObject! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3064-WriteStreamTweaks-JuanVuletich-2017Mar13-16h06m-jmv.1.cs.st----! - -----SNAPSHOT----#(13 March 2017 4:27:36.062745 pm) Cuis5.0-3064-spur-64.image priorSource: 306889! - -----QUIT----#(13 March 2017 4:27:47.296681 pm) Cuis5.0-3064-spur-64.image priorSource: 308719! - -----STARTUP----#(19 March 2017 8:11:18.86056 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3064-spur-64.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3064] on 15 March 2017 at 2:07:10 pm'! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 3/15/2017 14:06:54' prior: 50337461! - maximumUsableAreaInWorld: aWorldOrNil - - | allowedArea | - allowedArea _ Display boundingBox. - aWorldOrNil ifNotNil: [ - allowedArea _ allowedArea intersect: aWorldOrNil viewBox. - aWorldOrNil taskbar ifNotNil: [ :tb | - tb morphBoundsInWorld ifNotNil: [ :r | - allowedArea _ (allowedArea areasOutside: r) first ]]]. - ^allowedArea -! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3065-TaskbarFix-JuanVuletich-2017Mar15-14h03m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3064] on 17 March 2017 at 10:25:22 am'! -!Debugger methodsFor: 'method creation' stamp: 'HAW 3/17/2017 10:24:51' prior: 50336720! - createMethodWhenDoesNotUndertand - - | message chosenClass interruptedContext | - - "The doesNotUndertand context must be selected - Hernan" - contextStackIndex = 1 ifFalse: [ self contextStackIndex: 1 oldContextWas: self selectedContext ]. - - interruptedContext _ self interruptedContext. - message _ interruptedContext tempAt: 1. - - chosenClass _ self - askForSuperclassOf: interruptedContext receiver class - toImplement: message selector - ifCancel: [^self]. - - self implement: message inClass: chosenClass context: self selectedContext - -! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3066-CreateMissingMethodInDebuggerFix-HernanWilkinson-2017Mar16-20h05m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3064] on 18 March 2017 at 10:47:28 am'! -!SmalltalkEditor class methodsFor: 'keyboard shortcut tables' stamp: 'HAW 3/18/2017 10:44:48' prior: 50338485! - cmdShortcutsSpec - " - Editor initialize - " - "arranged in QWERTY keyboard order" - ^#( - #( $r #acceptAndDebugTest: 'Saves method and debugs it') - #( $t #acceptAndTest: 'Saves method, runs it as test and then all tests in class. Opens debugger if error') - #( $y #acceptAndTestAll: 'Saves method, runs it as test and then all tests in class category. Opens debugger if error') - #( $i #inspectIt: 'Inspect it (selection is a valid expression, or selection is over an inspect-ilst)') - #( $p #printIt: 'Print it (selection is a valid expression)') - - #( $s #save: 'Save (i.e. accept)') - #( $d #doIt: 'Do it (selection is a valid expression)') - #( $l #cancelEdits: 'Cancel') - - #( $b #browseIt: 'Browse it (selection is a class name or cursor is over a class-list or message-list)') - #( $n #sendersOfIt: 'Senders of it (selection is a message selector or cursor is over a class-list or message-list)') - #( $m #implementorsOfIt: 'Implementors of it (selection is a message selector or cursor is over a class-list or message-list)') - - #( $E #methodStringsContainingit:'Method strings containing it') - #( $T #displayIfTrue: 'Insert #ifTrue:') - #( $I #exploreIt: 'Inspect via Object Explorer') - - #( $A #argAdvance: 'Advance argument') - #( $D #debugIt: 'Debug it') - #( $F #displayIfFalse: 'Insert #ifFalse:') - #( $G #fileItIn: 'File in selection') - - #( $V #pasteInitials: 'Paste author initials') - #( $N #referencesToIt: 'References to it (selection is a class name, or cursor is over a class-list or message-list)') - )! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3067-FixATypo-HernanWilkinson-2017Mar18-10h44m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3064] on 18 March 2017 at 8:30:03 pm'! -!TheWorldMenu methodsFor: 'construction' stamp: 'HAW 3/18/2017 20:26:59' prior: 16934784! - buildWorldMenu - "Build the menu that is put up when the screen-desktop is clicked on" - - | menu | - menu _ MenuMorph new defaultTarget: self. - self colorForDebugging: menu. - menu addStayUpIcons. - self fillIn: menu - from: { - { 'Open...'. { self. #openWindow}}. - { 'New morph...'. { self. #newMorph}. - 'Offers a variety of ways to create new objects'}. - { 'Preferences...'. { self. #preferencesDo}. - 'put up a menu offering many controls over appearance and system preferences.'}. - { 'Windows...'. { self. #windowsDo}}. - { 'Help...'. { self. #helpDo}. - 'puts up a menu of useful items for updating the system, determining what version you are running, and much else'}. - nil. - { 'Changes...'. { self. #changesDo}}. - { 'Debug...'. { self. #debugDo}. - 'a menu of debugging items'}. - { 'Restore Display (r)'. { myWorld. #restoreMorphicDisplay}. - 'repaint the screen -- useful for removing unwanted display artifacts, lingering cursors, etc.'}. - nil. - { 'Save'. { Smalltalk . #saveSession}. - 'save the current version of the image on disk'}. - { 'Save as...'. { Smalltalk . #saveAs}. - 'save the current version of the image on disk under a new name.'}. - { 'Save as New Version'. { Smalltalk . #saveAsNewVersion}. - 'give the current image a new version-stamped name\and save it under that name on disk.\Clear all user preferences and user state (class vars).' withNewLines}. - { 'Save and Quit'. { self. #saveAndQuit}. - 'save the image and quit out of Cuis.'}. - { 'Quit'. { self. #quitSession}. - 'quit out of Cuis.'}}. - ^menu! ! - -TheWorldMenu removeSelector: #saveAndQuitSession! - -TheWorldMenu removeSelector: #saveMenu! - -TheWorldMenu removeSelector: #saveMenu! - -TheWorldMenu removeSelector: #saveOptionsDo! - -TheWorldMenu removeSelector: #saveOptionsDo! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3068-SaveMenuIntegrationInWorldMenu-HernanWilkinson-2017Mar18-10h53m-HAW.1.cs.st----! - -----SNAPSHOT----#(19 March 2017 8:11:24.98593 pm) Cuis5.0-3068-spur-64.image priorSource: 308819! - -----QUIT----#(19 March 2017 8:11:36.879466 pm) Cuis5.0-3068-spur-64.image priorSource: 314821! - -----STARTUP----#(16 April 2017 9:01:55.583301 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3068-spur-64.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3068] on 26 March 2017 at 11:30:12 pm'! -!Theme class methodsFor: 'class initialization' stamp: 'jmv 3/26/2017 23:25:17' prior: 16936878! - currentTheme: aTheme - - CurrentTheme := aTheme new. - SHTextStylerST80 initialize. - self runningWorld ifNotNil: [ :w | - w backgroundImage ifNil: [ - w color: CurrentTheme background ]]. - SystemWindow initialize. - BitBltCanvas releaseClassCachedState. - self runningWorld ifNotNil: [ :w | - CurrentTheme useTaskbar - ifTrue: [w showTaskbar] - ifFalse: [w hideTaskbar]. - w restoreMorphicDisplay ]. - - ^ CurrentTheme! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3069-Theme-fix-JuanVuletich-2017Mar26-23h30m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3064] on 25 March 2017 at 10:48:23 am'! -!BasicClassOrganizer methodsFor: 'accessing' stamp: 'HAW 3/25/2017 10:48:00' prior: 16782575! - classComment: aString - "Store the comment, aString, associated with the object that refers to the - receiver." - - aString ifNil: [ ^classComment _ nil ]. - - aString isRemote - ifTrue: [classComment _ aString] - ifFalse: [aString size = 0 - ifTrue: [classComment _ nil] - ifFalse: [ - self error: 'use aClass classComment:'. - classComment _ RemoteString newString: aString onFileNumber: 2]] - "Later add priorSource and date and initials?"! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3070-ClassCommentSetterFix-HernanWilkinson-2017Mar25-10h47m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3064] on 27 March 2017 at 9:11:54 am'! -!Delay class methodsFor: 'instance creation' stamp: 'HAW 3/27/2017 09:08:00' prior: 16832891! - forDuration: aDuration - - ^ self forMilliseconds: aDuration totalMilliseconds! ! - -Duration removeSelector: #totalMilliSeconds! - -Duration removeSelector: #totalMilliSeconds! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3071-Remove-totalMilliSeconds-HernanWilkinson-2017Mar27-09h08m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3068] on 30 March 2017 at 8:42:47 am'! -!Morph methodsFor: 'user interface' stamp: 'jmv 3/30/2017 08:41:08'! - toggleCollapseOrShow - "If collapsed, show me. - If visible, collapse me." - - self visible - ifTrue: [ self collapse ] - ifFalse: [ self showAndComeToFront ]! ! -!Morph methodsFor: 'user interface' stamp: 'jmv 3/30/2017 08:38:46' prior: 50337398! - collapse - "If taskbar not visible, just hide." - - self hide. - self taskbar - ifNotNil: [ :tb | tb wasCollapsed: self ]! ! -!Morph methodsFor: 'user interface' stamp: 'jmv 3/30/2017 08:38:12' prior: 50337113! - showAndComeToFront - "Make me visible if not, set me on top of all other sibling morphs." - self show; comeToFront! ! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 3/30/2017 08:41:28' prior: 50337694! - addButtonFor: aMorph - - | button | - aMorph == self ifFalse: [ - button _ PluggableButtonMorph - model: aMorph - stateGetter: nil - action: #toggleCollapseOrShow. - button - color: self color; - icon: (aMorph imageForm: 32); - setBalloonText: aMorph label. - button icon: button magnifiedIcon. - viewBox - addMorph: button - fixedWidth: self defaultHeight ]! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3072-taskbarButtonTogglesCollapsing-JuanVuletich-2017Mar30-08h36m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3072] on 30 March 2017 at 8:57:52 am'! -!TaskbarMorph methodsFor: 'services' stamp: 'jmv 3/30/2017 08:54:49'! - aboutToCollapse: aMorph - "Add a button for aMorph if not already there (see #taskbarIncludesAllWindows)" - - (self buttonFor: aMorph) ifNil: [ - self addButtonFor: aMorph ]! ! -!Morph methodsFor: 'user interface' stamp: 'jmv 3/30/2017 08:55:31' prior: 50341576! - collapse - "If taskbar not visible, just hide." - - self taskbar - ifNotNil: [ :tb | tb aboutToCollapse: self ]. - self hide! ! - -TaskbarMorph removeSelector: #wasCollapsed:! - -TaskbarMorph removeSelector: #wasCollapsed:! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3073-TaskbarFix-JuanVuletich-2017Mar30-08h57m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3064] on 29 March 2017 at 5:18:04 pm'! - -Object subclass: #ExceptionHandlingCondition - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #ExceptionHandlingCondition category: #'Exceptions Kernel'! -Object subclass: #ExceptionHandlingCondition - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! -!ExceptionHandlingCondition commentStamp: '' prior: 0! - I represent the protocol expected to be as condition on the exception handling message on:do: -I also define the protocol to create and combine exceptions handling conditions. -See methods #, and #- for a complemented documentation! -!ExceptionHandlingCondition commentStamp: '' prior: 50341649! - I represent the protocol expected to be as condition on the exception handling message on:do: -I also define the protocol to create and combine exceptions handling conditions. -See methods #, and #- for a complemented documentation! - -Smalltalk renameClassNamed: #ExceptionFilter as: #FilterExceptionHandlingCondition! - -ExceptionHandlingCondition subclass: #FilterExceptionHandlingCondition - instanceVariableNames: 'handleCondition filterCondition' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #FilterExceptionHandlingCondition category: #'Exceptions Kernel'! -ExceptionHandlingCondition subclass: #FilterExceptionHandlingCondition - instanceVariableNames: 'handleCondition filterCondition' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -Smalltalk renameClassNamed: #ExceptionAdd as: #OrExceptionHandlingCondition! - -ExceptionHandlingCondition subclass: #OrExceptionHandlingCondition - instanceVariableNames: 'leftCondition rightCondition' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! - -!classDefinition: #OrExceptionHandlingCondition category: #'Exceptions Kernel'! -ExceptionHandlingCondition subclass: #OrExceptionHandlingCondition - instanceVariableNames: 'leftCondition rightCondition' - classVariableNames: '' - poolDictionaries: '' - category: 'Exceptions Kernel'! -!BlockClosure methodsFor: 'error handing' stamp: 'HAW 3/29/2017 15:16:01'! - handles: anException - - "This allows a block to be the handling condition of an exception handling. - See Exception class>>handles:" - - ^self value: anException ! ! -!Exception class methodsFor: 'handling condition creation' stamp: 'HAW 3/28/2017 15:48:57' prior: 16840211! - , anExceptionHandlingCondition - - "See ExceptionHandlingCondition>>," - - ^anExceptionHandlingCondition createOrConditionWithExceptionType: self! ! -!Exception class methodsFor: 'handling condition creation' stamp: 'HAW 3/28/2017 15:49:08'! - - anExceptionHandlingCondition - - "See ExceptionHandlingCondition>>-" - - ^anExceptionHandlingCondition createFilterConditionWithExceptionType: self! ! -!Exception class methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 11:23:04'! - createFilterConditionWithExceptionType: anExceptionType - - ^FilterExceptionHandlingCondition handling: anExceptionType filtering: self! ! -!Exception class methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 11:26:42'! - createFilterConditionWithFilterCondition: aFilterExceptionHandlingCondition - - ^FilterExceptionHandlingCondition handling: aFilterExceptionHandlingCondition filtering: self! ! -!Exception class methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 15:40:33'! - createFilterConditionWithOrCondition: anOrExceptionHandlingCondition - - ^FilterExceptionHandlingCondition handling: anOrExceptionHandlingCondition filtering: self! ! -!Exception class methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 15:37:59'! - createOrConditionWithExceptionType: anExceptionType - - ^OrExceptionHandlingCondition handling: anExceptionType or: self -! ! -!Exception class methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 15:48:29'! - createOrConditionWithFilterCondition: aFilterExceptionHandlingCondition - - ^aFilterExceptionHandlingCondition handleCondition, self - aFilterExceptionHandlingCondition filterCondition - - ! ! -!Exception class methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 11:09:54'! - createOrConditionWithOrCondition: anOrExceptionHandlingCondition - - ^OrExceptionHandlingCondition handling: anOrExceptionHandlingCondition or: self! ! -!ExceptionHandlingCondition methodsFor: 'error handling' stamp: 'HAW 3/28/2017 17:29:18'! - handles: anException - - "Must return true if anException must be handle - See also Exception class>>handles: anException" - - self subclassResponsibility ! ! -!ExceptionHandlingCondition methodsFor: 'handling condition creation' stamp: 'HAW 3/28/2017 17:17:36'! - , anExceptionHandlingCondition - - "Creates a handling condition that will return true if either part of the condition handles the exception. - It behaves like an or - The following example will handle the exception - [ Error signal ] - on: Error, Halt - do: [ :anError | ... ] - - The following example will also handle the exception: - [ Halt signal ] - on: Error, Halt - do: [ :anError | ... ]" - - self subclassResponsibility - ! ! -!ExceptionHandlingCondition methodsFor: 'handling condition creation' stamp: 'HAW 3/29/2017 13:59:37'! - - anExceptionHandlingCondition - - "Creates a handling condition that will not handle exceptions that meet the right side of the condition - The following example will not handle the exception - [ 1/0 ] - on: Error - ZeroDivide - do: [ :anError | ... ] - - The following example will handle the exception: - [ Error signal ] - on: Error - ZeroDivide - do: [ :anError | ... ] - - Due to inconsisties that can arrise with combining #, with #- the implementation orders the in such a way that 'or conditions' go first - and 'filter conditions' go last. Doing so (Error - Notification) , (UnhandledError - ZeroDivide) is converted to Error, UnhandledError - Notification - ZeroDivide - Inconsisties can arrise because ZeroDivide is a subclass of Error and therefore if the condition is not ordered correctly a ZeroDivide could be handled. - This inconsisty can be found in Pharo where the condition (Error - Notification) , (UnhandledError - ZeroDivide) does not filter ZeroDivide but - the condition Error, UnhandledError - Notification - ZeroDivide does filter it. - That is the reason the implementation uses double dispatch - " - - self subclassResponsibility - ! ! -!ExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/29/2017 13:31:13'! -createFilterConditionWithExceptionType: anExceptionType - - self subclassResponsibility ! ! -!ExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/29/2017 13:33:31'! - createFilterConditionWithFilterCondition: aFilterExceptionHandlingCondition - - self subclassResponsibility ! ! -!ExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/29/2017 13:33:39'! -createFilterConditionWithOrCondition: anOrExceptionHandlingCondition - - self subclassResponsibility ! ! -!ExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/29/2017 13:33:51'! - createOrConditionWithExceptionType: anExceptionType - - self subclassResponsibility ! ! -!ExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/29/2017 13:34:31'! - createOrConditionWithFilterCondition: aFilterExceptionHandlingCondition - - self subclassResponsibility ! ! -!ExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/29/2017 13:34:42'! - createOrConditionWithOrCondition: anOrExceptionHandlingCondition - - self subclassResponsibility ! ! -!FilterExceptionHandlingCondition methodsFor: 'accessing' stamp: 'HAW 3/28/2017 17:20:21'! - filterCondition - - ^filterCondition ! ! -!FilterExceptionHandlingCondition methodsFor: 'accessing' stamp: 'HAW 3/28/2017 17:20:26'! - handleCondition - - ^handleCondition ! ! -!FilterExceptionHandlingCondition methodsFor: 'error handling' stamp: 'HAW 3/28/2017 17:20:41'! - handles: anException - - ^ (filterCondition handles: anException) not and: [ handleCondition handles: anException ]! ! -!FilterExceptionHandlingCondition methodsFor: 'initialization' stamp: 'HAW 3/29/2017 13:45:21'! - initializeHandling: aHandleCondition filtering: aFilterCondition - - handleCondition _ aHandleCondition. - filterCondition _ aFilterCondition ! ! -!FilterExceptionHandlingCondition methodsFor: 'handling condition creation' stamp: 'HAW 3/29/2017 13:59:08'! - , anExceptionHandlingCondition - - "See ExceptionHandlingCondition>>#- for an explanation of why double dispatch is used as implementation" - - ^anExceptionHandlingCondition createOrConditionWithFilterCondition: self! ! -!FilterExceptionHandlingCondition methodsFor: 'handling condition creation' stamp: 'HAW 3/29/2017 13:59:00'! - - anExceptionHandlingCondition - - "See ExceptionHandlingCondition>>#- for an explanation of why double dispatch is used as implementation" - - ^anExceptionHandlingCondition createFilterConditionWithFilterCondition: self! ! -!FilterExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 17:56:46'! - createFilterConditionWithExceptionType: anExceptionType - - ^self class - handling: anExceptionType, filterCondition - filtering: handleCondition ! ! -!FilterExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 17:19:24'! - createFilterConditionWithFilterCondition: aFilterExceptionHandlingCondition - - ^aFilterExceptionHandlingCondition - handleCondition, filterCondition ! ! -!FilterExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 17:19:48'! - createFilterConditionWithOrCondition: anOrExceptionHandlingCondition - - ^anOrExceptionHandlingCondition, filterCondition - handleCondition ! ! -!FilterExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 17:19:56'! - createOrConditionWithExceptionType: anExceptionType - - ^anExceptionType - handleCondition - filterCondition ! ! -!FilterExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 17:20:04'! - createOrConditionWithFilterCondition: aFilterExceptionHandlingCondition - - ^aFilterExceptionHandlingCondition handleCondition,handleCondition - aFilterExceptionHandlingCondition filterCondition - filterCondition ! ! -!FilterExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/29/2017 15:32:33'! - createOrConditionWithOrCondition: anOrExceptionHandlingCondition - - ^anOrExceptionHandlingCondition, handleCondition - filterCondition ! ! -!FilterExceptionHandlingCondition methodsFor: 'printing' stamp: 'HAW 3/28/2017 17:20:55'! - printOn: aStream - - aStream - print: handleCondition ; - nextPutAll: ' - '; - print: filterCondition ! ! -!FilterExceptionHandlingCondition class methodsFor: 'instance creation' stamp: 'HAW 3/28/2017 17:18:11'! - handling: aHandleCondition filtering: aFilterCondition - - ^self new initializeHandling: aHandleCondition filtering: aFilterCondition -! ! -!OrExceptionHandlingCondition methodsFor: 'accessing' stamp: 'HAW 3/28/2017 17:55:27'! - leftCondition - - ^leftCondition ! ! -!OrExceptionHandlingCondition methodsFor: 'accessing' stamp: 'HAW 3/28/2017 17:56:11'! - rightCondition - - ^rightCondition ! ! -!OrExceptionHandlingCondition methodsFor: 'error handling' stamp: 'HAW 3/28/2017 17:31:39'! - handles: anException - - ^ (leftCondition handles: anException) or: [ rightCondition handles: anException ]! ! -!OrExceptionHandlingCondition methodsFor: 'initialization' stamp: 'HAW 3/28/2017 17:32:20'! - initializeHandling: aLeftCondition or: aRightCondition - - leftCondition _ aLeftCondition. - rightCondition _ aRightCondition ! ! -!OrExceptionHandlingCondition methodsFor: 'handling condition creation' stamp: 'HAW 3/29/2017 13:59:16'! - , anExceptionHandlingCondition - - "See ExceptionHandlingCondition>>#- for an explanation of why double dispatch is used as implementation" - - ^anExceptionHandlingCondition createOrConditionWithOrCondition: self - ! ! -!OrExceptionHandlingCondition methodsFor: 'handling condition creation' stamp: 'HAW 3/29/2017 13:59:22'! -- anExceptionHandlingCondition - - "See ExceptionHandlingCondition>>#- for an explanation of why double dispatch is used as implementation" - - ^anExceptionHandlingCondition createFilterConditionWithOrCondition: self - ! ! -!OrExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 17:32:37'! - createFilterConditionWithExceptionType: anExceptionType - - ^FilterExceptionHandlingCondition - handling: anExceptionType - leftCondition - filtering: rightCondition ! ! -!OrExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 17:33:37'! - createFilterConditionWithFilterCondition: aFilterExceptionHandlingCondition - - ^aFilterExceptionHandlingCondition - leftCondition - rightCondition ! ! -!OrExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 17:34:05'! - createFilterConditionWithOrCondition: anOrExceptionHandlingCondition - - ^ anOrExceptionHandlingCondition - leftCondition - rightCondition ! ! -!OrExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 11:16:37'! - createOrConditionWithExceptionType: anExceptionType - - ^self class handling: anExceptionType or: self! ! -!OrExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 14:56:09'! - createOrConditionWithFilterCondition: aFilterExceptionHandlingCondition - - ^self, aFilterExceptionHandlingCondition ! ! -!OrExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/28/2017 11:20:32'! - createOrConditionWithOrCondition: anOrExceptionHandlingCondition - - ^self class handling: anOrExceptionHandlingCondition or: self! ! -!OrExceptionHandlingCondition methodsFor: 'printing' stamp: 'HAW 3/28/2017 17:54:46'! - printOn: aStream - - aStream - print: leftCondition; - nextPutAll: ', '; - print: rightCondition ! ! -!OrExceptionHandlingCondition class methodsFor: 'instance creation' stamp: 'HAW 3/27/2017 15:47:32'! - handling: anExceptionClass or: anotherExceptionClass - - ^self new initializeHandling: anExceptionClass or: anotherExceptionClass -! ! - -OrExceptionHandlingCondition removeSelector: #createOrHandlingConditionWithOrHandlingCondition:! - -Exception class removeSelector: #createFilterConditionWithExceptionClass:! - -Exception class removeSelector: #createHandlingConditionWithExceptionClass:! - -Exception class removeSelector: #handling:! - -Exception class removeSelector: #orHandlingExceptionClass:! - -Smalltalk removeClassNamed: #ExceptionSet! - -Smalltalk removeClassNamed: #ExceptionSet! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3074-ExceptionHandlingConditionEnh-HernanWilkinson-2017Mar26-18h04m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3064] on 29 March 2017 at 6:09:56 pm'! -!FilterExceptionHandlingCondition methodsFor: 'handling condition creation - private' stamp: 'HAW 3/29/2017 17:59:55' prior: 50341963! - createOrConditionWithExceptionType: anExceptionType - - ^anExceptionType, handleCondition - filterCondition ! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3075-ExceptionHandlingConditionFix-HernanWilkinson-2017Mar29-17h18m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3068] on 16 April 2017 at 7:53:58 pm'! -!TextEditor methodsFor: 'menu messages' stamp: 'jmv 4/16/2017 19:53:14' prior: 16932110! - compareToClipboard - "Check to see if whether the receiver's text is the same as the text currently on the clipboard, and inform the user." - | s1 s2 | - s1 _ self clipboardStringOrText string. - s2 _ self selection ifEmpty: [self privateCurrentString]. - s1 = s2 ifTrue: [^ self inform: 'Exact match']. - - (TextModel new contents: - (DifferenceFinder displayPatchFrom: s1 to: s2 tryWords: true)) - openLabel: 'Comparison to Clipboard Text'! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3076-CompareToClipboardComparesSelection-JuanVuletich-2017Apr16-19h53m-jmv.1.cs.st----! - -----SNAPSHOT----#(16 April 2017 9:02:02.273545 pm) Cuis5.0-3076-spur-64.image priorSource: 314920! - -----QUIT----#(16 April 2017 9:02:15.23247 pm) Cuis5.0-3076-spur-64.image priorSource: 336694! - -----STARTUP----#(14 May 2017 7:55:36.65277 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3076-spur-64.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3076] on 13 May 2017 at 12:54:11 pm'! -!Integer methodsFor: 'printing' stamp: 'jmv 5/9/2017 19:45:38'! - printOn: aStream length: minimum zeroPadded: zeroFlag - " - 7 printOn: Transcript length: 4 padded: true. Transcript newLine. - " - self printOn: aStream base: 10 length: minimum padded: zeroFlag! ! -!Character methodsFor: 'accessing' stamp: 'jmv 5/9/2017 19:49:32' prior: 16800371! - 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. - $0 numericValue = 48 - $9 numericValue = 57 - $A numericValue = 65 - $Z numericValue = 90 - $7 digitValue = 7 - " - - | nv | - nv _ self numericValue. - (nv between: 48 and: 57) - ifTrue: [ ^ nv - 48 ]. - (nv between: 65 and: 90) - ifTrue: [ ^ nv - 55 ]. - ^ -1! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3077-Integer-printPadded-JuanVuletich-2017May13-12h51m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3076] on 13 May 2017 at 1:02:33 pm'! -!Timespan class methodsFor: 'squeak protocol' stamp: 'jmv 5/9/2017 19:54:38'! - fromString: aString - "Please call with specific subclass." - - ^ self readFrom: aString readStream! ! -!Week class methodsFor: 'squeak protocol' stamp: 'jmv 5/12/2017 17:48:37'! - readFrom: aStream - "Read a Week from the stream in any of the forms: - -W (2009-W01) (ISO8601)" - | weekNumber yearNumber firstAsNumber firstAsNumberSign | - firstAsNumberSign := aStream peek = $- ifTrue: [-1] ifFalse: [1]. - [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. - aStream peek isDigit ifTrue: [ - firstAsNumber := (Integer readFrom: aStream) * firstAsNumberSign. - (firstAsNumber < 0 or: [firstAsNumber > 12]) - ifTrue: [yearNumber := firstAsNumber]]. - - [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. - aStream next = $W ifFalse: [ - self error: 'Invalid Format' ]. - - weekNumber _ Integer readFrom: aStream. - weekNumber < 1 ifTrue: [ self error: 'Invalid Format' ]. - (yearNumber < 100 and: [yearNumber >= 0]) ifTrue: [ - yearNumber _ yearNumber < 69 - ifTrue: [2000 + yearNumber] - ifFalse: [1900 + yearNumber]]. - - ^ self yearNumber: yearNumber weekNumber: weekNumber! ! -!Week class methodsFor: 'squeak protocol' stamp: 'jmv 5/13/2017 10:54:55'! - yearNumber: yearNumber weekNumber: weekNumber - - | firstOfJanuary firstThursday thisThursday | - firstOfJanuary _ DateAndTime year: yearNumber month: 1 day: 1. - firstThursday _ firstOfJanuary + (4 - firstOfJanuary dayOfWeek \\ 7) days. - thisThursday _ firstThursday + ((weekNumber-1) * 7) days. - - thisThursday yearNumber = yearNumber - ifFalse: [ self error: 'Week does not exist' ]. - - ^ self including: thisThursday! ! -!Year class methodsFor: 'squeak protocol' stamp: 'jmv 5/12/2017 16:41:15'! - readFrom: aStream - - | year sign | - sign := aStream peek = $- ifTrue: [-1] ifFalse: [1]. - [aStream peek isDigit] whileFalse: [aStream skip: 1]. - year := (Integer readFrom: aStream) * sign. - ^ self yearNumber: year! ! -!String methodsFor: 'converting' stamp: 'jmv 5/12/2017 11:24:09'! - asMonth - "Many allowed forms, see Month>>#readFrom: - 'July 1998' asMonth. - '1998/7'asMonth. - " - - ^ Month fromString: self! ! -!String methodsFor: 'converting' stamp: 'jmv 5/12/2017 16:39:13'! - asWeek - " - '2008-W52' asWeek. - '2008-W53' asWeek. 'Invalid format!!'. - '2009-W01' asWeek - '2009-W02' asWeek - '2009-W53' asWeek - '2010-W01' asWeek - '2010-W02' asWeek - '2008-W52' asWeek start. - '2009-W01' asWeek start - '2009-W02' asWeek start - '2009-W53' asWeek start - '2010-W01' asWeek start - '2010-W02' asWeek start - " - - ^ Week fromString: self! ! -!String methodsFor: 'converting' stamp: 'jmv 5/12/2017 16:37:23'! - asYear - " - '2008' asYear. - '2008' asYear start. - " - - ^ Year fromString: self! ! -!DateAndTime methodsFor: 'ansi protocol' stamp: 'jmv 5/12/2017 10:55:06' prior: 16828675! - dayOfWeek - - " - Sunday=1, ... , Saturday=7 - Monday=1, ... , Sunday=7 - '12 May 2017 ' asDate dayOfWeek = 5 - " - - ^ (jdn rem: 7) + 1! ! -!DateAndTime methodsFor: 'ansi protocol' stamp: 'jmv 5/12/2017 10:53:00' prior: 16828685! - dayOfWeekName - " - '12 May 2017 ' asDate dayOfWeek = 5 - '12 May 2017 ' asDate dayOfWeekName = #Friday - " - - ^ Week nameOfDay: self dayOfWeek -! ! -!Duration methodsFor: 'squeak protocol' stamp: 'jmv 5/12/2017 10:59:51' prior: 16836040! - printOn: aStream - "Format as per ANSI 5.8.2.16: [-]D:HH:MM:SS[.S] - (Duration days: 2 hours: 3 minutes: 16 seconds: 43) printString = '2:03:16:43' - " - | d h m s n | - d _ self days abs. - h _ self hours abs. - m _ self minutes abs. - s _ self seconds abs truncated. - n _ self nanoSeconds abs. self negative ifTrue: [ aStream nextPut: $- ]. - d printOn: aStream. aStream nextPut: $:. - h printOn: aStream length: 2 zeroPadded: true.aStream nextPut: $:. - m printOn: aStream length: 2 zeroPadded: true.aStream nextPut: $:. - s printOn: aStream length: 2 zeroPadded: true. - n = 0 ifFalse: [ - | z ps | - aStream nextPut: $.. - ps _ n printString padded: #left to: 9 with: $0. - z _ ps findLast: [ :c | c digitValue > 0 ]. - ps from: 1 to: z do: [ :c | aStream nextPut: c ] ]! ! -!Date methodsFor: 'smalltalk-80' stamp: 'jmv 5/12/2017 10:54:58' prior: 16828235! - weekdayIndex - "Sunday=1, ... , Saturday=7 - Monday=1, ... , Sunday=7 - '12 May 2017 ' asDate weekdayIndex = 5 - " - - ^ self dayOfWeek! ! -!Date class methodsFor: 'squeak protocol' stamp: 'jmv 5/10/2017 21:56:27' prior: 16828417! -readFrom: aStream - "Read a Date from the stream in any of the forms: - (15 April 1982; 15-APR-82; 15.4.82; 15APR82) - (April 15, 1982; 4/15/82) - -- (1982-04-15) (ISO8601)" - | day month year firstAsNumber firstAsNumberSign | - firstAsNumberSign := aStream peek = $- ifTrue: [-1] ifFalse: [1]. - [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. - aStream peek isDigit ifTrue: [ - firstAsNumber := (Integer readFrom: aStream) * firstAsNumberSign. - (firstAsNumber < 0 or: [firstAsNumber > 31]) - ifTrue: [year := firstAsNumber]]. - - [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. - aStream peek isLetter - ifTrue: ["MonthName-DD-YY or DD-MonthName-YY or YY-MonthName-DD" - month _ String streamContents: [ :strm | - [ aStream peek isLetter ] whileTrue: [ strm nextPut: aStream next ]]. - [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. - firstAsNumber - ifNil: ["MonthName DD YY" - day := Integer readFrom: aStream] - ifNotNil: [ - year ifNil: ["DD MonthName YY" - day := firstAsNumber]]] - ifFalse: ["MM-DD-YY or DD-MM-YY or YY-MM-DD" - year - ifNil: ["MM-DD-YY or DD-MM-YY" - firstAsNumber > 12 - ifTrue: ["DD-MM-YY" - day := firstAsNumber. - month := Month nameOfMonth: (Integer readFrom: aStream)] - ifFalse: ["MM-DD-YY" - month := Month nameOfMonth: firstAsNumber. - day := Integer readFrom: aStream]] - ifNotNil: ["YY-MM-DD" - month := Month nameOfMonth: (Integer readFrom: aStream)]]. - - [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. - year - ifNil: [year := Integer readFrom: aStream] - ifNotNil: [day := Integer readFrom: aStream]. - (year < 100 and: [year >= 0]) ifTrue: [ - year _ year < 69 - ifTrue: [2000 + year] - ifFalse: [1900 + year]]. - - ^ self year: year month: month day: day! ! -!Month class methodsFor: 'squeak protocol' stamp: 'jmv 5/12/2017 11:28:03' prior: 16873841! - readFrom: aStream - "Read a Month from the stream in any of the forms: - (April 1982; APR-82; 4.82; APR82) - (April, 1982; 4/82) - - (1982-04) (ISO8601)" - " - Month readFrom: 'July 1998' readStream - " - | month year firstAsNumber firstAsNumberSign | - firstAsNumberSign := aStream peek = $- ifTrue: [-1] ifFalse: [1]. - [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. - aStream peek isDigit ifTrue: [ - firstAsNumber := (Integer readFrom: aStream) * firstAsNumberSign. - (firstAsNumber < 0 or: [firstAsNumber > 12]) - ifTrue: [year := firstAsNumber]]. - - [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. - aStream peek isLetter - ifTrue: ["MonthName-YY or YY-MonthName" - month _ String streamContents: [ :strm | - [ aStream peek isLetter ] whileTrue: [ strm nextPut: aStream next ]]. - [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]] - ifFalse: ["MM-YY or YY-MM" - month _ year - ifNil: ["MM-YY" - Month nameOfMonth: firstAsNumber ] - ifNotNil: ["YY-MM" - Month nameOfMonth: (Integer readFrom: aStream)]]. - - year ifNil: [ - [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. - year := Integer readFrom: aStream]. - (year < 100 and: [year >= 0]) ifTrue: [ - year _ year < 69 - ifTrue: [2000 + year] - ifFalse: [1900 + year]]. - - ^ self month: month year: year! ! -!Week methodsFor: 'squeak protocol' stamp: 'jmv 5/12/2017 11:53:32' prior: 16944751! - printOn: aStream - " - '2008-W52' asWeek. - '2009-W01' asWeek - '2009-W02' asWeek - '2009-W53' asWeek - '2010-W01' asWeek - '2010-W02' asWeek - " - | thursday | - thursday _ self start + 3 days. - thursday yearNumber printOn: aStream. - aStream nextPutAll: '-W'. - (thursday dayOfYear-1 // 7 + 1) printOn: aStream length: 2 zeroPadded: true! ! -!Week class methodsFor: 'squeak protocol' stamp: 'jmv 5/12/2017 10:54:04' prior: 16944773! - indexOfDay: aSymbol - " - Week indexOfDay: #Sunday = 7 - Week nameOfDay: 7 = #Sunday - " - - ^ self dayNames indexOf: aSymbol! ! -!Week class methodsFor: 'smalltalk-80' stamp: 'jmv 5/12/2017 10:53:55' prior: 16944778! - nameOfDay: anIndex - " - Week indexOfDay: #Sunday = 7 - Week nameOfDay: 7 = #Sunday - " - - ^ self dayNames at: anIndex! ! -!Week class methodsFor: 'inquiries' stamp: 'jmv 5/10/2017 22:25:02' prior: 16944786! - dayNames - - ^ #(Monday Tuesday Wednesday Thursday Friday Saturday Sunday)! ! -!String methodsFor: 'converting' stamp: 'jmv 5/12/2017 11:22:17' prior: 16916294! - asDate - "Many allowed forms, see Date>>#readFrom: - '2014/6/30' asDate. - '70/12/30' asDate. - '12/30/70' asDate. - '30/12/70' asDate. - '4/5/6' asDate. - '15 April 1982' asDate. - " - - ^ Date fromString: self! ! - -Date class removeSelector: #fromString:! - -Date class removeSelector: #fromString:! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3078-WeekStartsOnMonday-NewWeekMonthYearCreationMethods-JuanVuletich-2017May13-12h54m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3076] on 13 May 2017 at 1:02:55 pm'! -!DateAndTime methodsFor: 'double dispatching' stamp: 'jmv 5/12/2017 17:17:21'! - includingTimespanOf: aTimespanClass - - ^ aTimespanClass includingDateAndTime: self! ! -!Timespan methodsFor: 'double displatching' stamp: 'jmv 5/12/2017 17:17:18'! - includingTimespanOf: aTimespanClass - - ^ aTimespanClass includingTimespan: self! ! -!Timespan class methodsFor: 'instance creation' stamp: 'jmv 5/12/2017 16:48:47'! - includingDateAndTime: aDateAndTime - - ^ self starting: aDateAndTime duration: Duration zero! ! -!Timespan class methodsFor: 'instance creation' stamp: 'jmv 5/12/2017 17:22:59'! - includingTimespan: aDateAndTime - - | ending starting | - starting _ self includingDateAndTime: aDateAndTime start. - ending _ self includingDateAndTime: aDateAndTime end. - starting = ending ifTrue: [ ^ starting ]. - self error: aDateAndTime printString, ' can not be included in a ', self name! ! -!Date class methodsFor: 'instance creation' stamp: 'jmv 5/12/2017 16:48:52'! - includingDateAndTime: aDateAndTime - - ^self basicNew - start: aDateAndTime midnight; - duration: (Duration days: 1); - yourself! ! -!Month class methodsFor: 'squeak protocol' stamp: 'jmv 5/12/2017 16:48:55'! - includingDateAndTime: aDateAndTime - "Months start at day 1" - | monthStart days | - monthStart _ DateAndTime - year: aDateAndTime yearNumber - month: aDateAndTime monthIndex - day: 1. - days _ self daysInMonth: monthStart monthIndex forYear: monthStart yearNumber. - ^ self basicNew - start: monthStart; - duration: (Duration days: days); - yourself! ! -!Week class methodsFor: 'squeak protocol' stamp: 'jmv 5/12/2017 18:05:57'! - includingDateAndTime: aDateAndTime - " - Week including: '12 May 2017 ' asDate start - (Week including: '12 May 2017 ' asDate start) start dayOfWeekName = #Monday - " - - | midnight weekStart | - midnight _ aDateAndTime midnight. - weekStart _ midnight - (midnight dayOfWeek - 1) days. - - ^ self basicNew - start: weekStart; - duration: (Duration weeks: 1); - yourself! ! -!Year class methodsFor: 'squeak protocol' stamp: 'jmv 5/12/2017 18:00:49'! - includingDateAndTime: aDateAndTime - "Answer a calendar year" - - ^ self yearNumber: aDateAndTime yearNumber! ! -!Timespan class methodsFor: 'instance creation' stamp: 'jmv 5/12/2017 17:18:23' prior: 16938217! - including: aDateAndTime - - ^ aDateAndTime includingTimespanOf: self! ! -!Year class methodsFor: 'squeak protocol' stamp: 'jmv 5/12/2017 17:43:17' prior: 16946731! - yearNumber: aYear - - | yearStart | - yearStart _ DateAndTime year: aYear month: 1 day: 1. - ^ self basicNew - start: yearStart; - duration: (Duration days: (self daysInYear: yearStart yearNumber)); - yourself! ! - -Year class removeSelector: #including:! - -Year class removeSelector: #including:! - -Week class removeSelector: #including:! - -Week class removeSelector: #including:! - -Month class removeSelector: #including:! - -Month class removeSelector: #including:! - -Date class removeSelector: #including:! - -Date class removeSelector: #including:! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3079-TimespanCreation-includingTimespan-JuanVuletich-2017May13-13h02m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3079] on 13 May 2017 at 2:18:26 pm'! -!DateAndTime methodsFor: 'private' stamp: 'jmv 5/13/2017 10:58:22'! - substractDateAndtime: operand - "operand is a DateAndTime or a Duration" - - | lvalue rvalue | - offset = operand offset - ifTrue: [ - lvalue _ self. - rvalue _ operand ] - ifFalse: [ - lvalue _ self asUTC. - rvalue _ operand asUTC ]. - ^ Duration - seconds: (Time secondsInDay *(lvalue julianDayNumber - rvalue julianDayNumber)) + - (lvalue secondsSinceMidnight - rvalue secondsSinceMidnight) - nanoSeconds: lvalue nanoSecond - rvalue nanoSecond! ! -!DateAndTime methodsFor: 'private' stamp: 'jmv 5/13/2017 10:58:31'! - substractDuration: operand - "operand is a DateAndTime or a Duration" - - ^self + operand negated! ! -!DateAndTime methodsFor: 'double dispatching' stamp: 'jmv 5/13/2017 10:59:45'! - substractFrom: aDateAndTime - - ^ aDateAndTime substractDateAndtime: self! ! -!Duration methodsFor: 'double dispatching' stamp: 'jmv 5/13/2017 11:03:50'! - substractFrom: aDateAndTimeOrDate - - ^aDateAndTimeOrDate substractDuration: self! ! -!Timespan methodsFor: 'private' stamp: 'jmv 5/13/2017 11:09:07'! - substractDuration: aDuration - - ^self class classDefinesDuration - ifTrue: [ self class including: start - aDuration ] - ifFalse: [ self class starting: start - aDuration duration: duration ]! ! -!Timespan methodsFor: 'private' stamp: 'jmv 5/13/2017 11:18:25'! - substractTimespan: aTimespan - - aTimespan duration = self duration ifFalse: [ - self error: 'Can not substract Timespans of different duration' ]. - - ^self start substractDateAndtime: aTimespan start! ! -!Timespan methodsFor: 'double displatching' stamp: 'jmv 5/13/2017 11:08:17'! - substractFrom: aTimespan - - ^ aTimespan substractTimespan: self! ! -!DateAndTime methodsFor: 'ansi protocol' stamp: 'jmv 5/13/2017 11:00:53' prior: 16828596! - - operand - "operand is a DateAndTime or a Duration. - Double dispatch" - - ^ operand substractFrom: self! ! -!Timespan methodsFor: 'ansi protocol' stamp: 'jmv 5/13/2017 14:16:21' prior: 16937995! -- aDurationOrTimespan - - ^ aDurationOrTimespan substractFrom: self! ! -!Timespan methodsFor: 'squeak protocol' stamp: 'jmv 5/13/2017 11:13:39' prior: 16938027! - includes: operand - "Operand might be a Timespan or a DateAndtime" - - ^ (operand is: #Timespan) - ifTrue: [ (self includes: operand start) - and: [ self includes: operand end ] ] - ifFalse: [ operand between: start and: self end ]! ! -!Timespan class methodsFor: 'instance creation' stamp: 'jmv 5/13/2017 11:12:44' prior: 50342535! - includingTimespan: aTimespan - - | ending starting | - starting _ self includingDateAndTime: aTimespan start. - ending _ self includingDateAndTime: aTimespan end. - starting = ending ifTrue: [ ^ starting ]. - self error: aTimespan printString, ' can not be included in a ', self name! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3080-TimespanLessTimespan-JuanVuletich-2017May13-14h12m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3080] on 13 May 2017 at 7:48:17 pm'! -!Week methodsFor: 'public protocol' stamp: 'jmv 5/13/2017 14:37:37'! - weekNumber - - | thursday | - thursday _ self start + 3 days. - ^thursday dayOfYear-1 // 7 + 1! ! -!Week methodsFor: 'public protocol' stamp: 'jmv 5/13/2017 14:37:18'! - yearNumber - - | thursday | - thursday _ self start + 3 days. - ^thursday yearNumber! ! -!Year methodsFor: 'public protocol' stamp: 'jmv 5/13/2017 14:51:58'! - yearNumber - - ^ start yearNumber! ! -!Week methodsFor: 'squeak protocol' stamp: 'jmv 5/13/2017 14:38:20' prior: 50342464! - printOn: aStream - " - '2008-W52' asWeek. - '2009-W01' asWeek - '2009-W02' asWeek - '2009-W53' asWeek - '2010-W01' asWeek - '2010-W02' asWeek - " - self yearNumber printOn: aStream. - aStream nextPutAll: '-W'. - self weekNumber printOn: aStream length: 2 zeroPadded: true! ! -!Week class methodsFor: 'squeak protocol' stamp: 'jmv 5/13/2017 14:59:27' prior: 50342478! - indexOfDay: aSymbol - " - (Week indexOfDay: #Sunday) = 7 - (Week nameOfDay: 7) = #Sunday - " - - ^ self dayNames indexOf: aSymbol! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3081-WeekYearTweaks-JuanVuletich-2017May13-19h46m-jmv.1.cs.st----! - -Cursor webLink maskForm bits: (Form extent: 16@16 - fromArray: (#(3072 7680 7680 7680 7680 8118 8191 32767 65535 65535 65535 65535 65535 32766 32766 16380 ) collect: [:bits | bits bitShift: 16]) - offset: 0@0) bits. -Smalltalk garbageCollect.! - -Form allInstances! - -----SNAPSHOT----#(14 May 2017 7:55:58.705571 pm) Cuis5.0-3081-spur-64.image priorSource: 336794! - -----QUIT----#(14 May 2017 7:56:15.500912 pm) Cuis5.0-3081-spur-64.image priorSource: 355670! - -----STARTUP----#(25 May 2017 9:59:53.730516 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3081-spur-64.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3081] on 16 May 2017 at 10:43:45 am'! -!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'jmv 5/16/2017 10:43:40' prior: 16896077! - defaultAction - - | delta textFrame barFrame outerFrame result range width filledWidth f h textWidth textForm innerBarFrame oldFilledWidth oldFilledWidth2 prevContents | - f _ AbstractFont default. - h _ f height * 3//2. - textWidth _ (f widthOfString: progressTitle) + h. - width _ 150 max: textWidth. - - textForm _ Form extent: width@h depth: 32. - textForm fillBlack. - textForm fillWhite: (textForm boundingBox insetBy: 2). - progressTitle displayOn: textForm at: (width-textWidth+h//2@4). - barFrame _ Rectangle center: aPoint extent: width@h. - textFrame _ 0@0 extent: width@h. - textFrame _ textFrame - aligned: textFrame bottomCenter - with: barFrame topCenter + (0@2). - outerFrame _ barFrame merge: textFrame. - delta _ outerFrame amountToTranslateWithin: Display boundingBox. - barFrame _ barFrame translatedBy: delta. - textFrame _ textFrame translatedBy: delta. - outerFrame _ outerFrame translatedBy: delta. - prevContents _ Form fromDisplay: outerFrame. - range _ maxVal = minVal ifTrue: [1] ifFalse: [maxVal - minVal]. "Avoid div by 0" - innerBarFrame _ barFrame insetBy: 2. - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - oldFilledWidth _ 0. - oldFilledWidth2 _ 0. - result _ workBlock value: "Supply the bar-update block for evaluation in the work block" - [ :barVal | - barVal - ifNotNil: [ currentVal _ barVal ] - ifNil: [ - currentVal _ currentVal + 1. - currentVal >= maxVal - ifTrue: [ currentVal _ minVal ]]. - filledWidth _ ((barFrame width-4) asFloat * ((currentVal-minVal) asFloat / range min: 1.0)) asInteger. - filledWidth > oldFilledWidth ifTrue: [ - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - Display fillGray: (barFrame topLeft + (2@2) extent: filledWidth@17). - filledWidth -200 > oldFilledWidth2 - ifFalse: [ - "Usually just request an update, to be done asynchronously." - DisplayScreen screenUpdateRequired: outerFrame ] - ifTrue: [ - "Once in a while, force a real screen update (warning: really slow on MacOS if done too often)" - Display forceToScreen: outerFrame. oldFilledWidth2 _ filledWidth ]. - oldFilledWidth _ filledWidth ]]. - prevContents displayAt: outerFrame topLeft. - self resume: result! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3082-displayProgressAt-slownessOnMacFix-JuanVuletich-2017May16-10h38m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3082] on 24 May 2017 at 12:34:49 am'! -!Collection methodsFor: 'sorting' stamp: 'jmv 5/24/2017 00:28:06'! - sorted - "Return a new sequenceable collection which contains the same elements as self but its elements are sorted " - - ^self sorted: nil! ! -!ClassDescription methodsFor: 'instance variables' stamp: 'jmv 5/24/2017 00:29:04' prior: 16805949! - chooseInstVarAlphabeticallyThenDo: aBlock - | allVars index | - "Put up a menu of all the instance variables in the receiver, presented in alphabetical order, and when the user chooses one, evaluate aBlock with the chosen variable as its parameter." - - allVars _ self allInstVarNames sorted. - allVars isEmpty ifTrue: [^ self inform: 'There are no -instance variables']. - - index _ (PopUpMenu labelArray: allVars lines: #()) startUpWithCaption: 'Instance variables in -', self name. - index = 0 ifTrue: [^ self]. - aBlock value: (allVars at: index)! ! -!ClassDescription methodsFor: 'method dictionary' stamp: 'jmv 5/24/2017 00:28:55' prior: 16807219! - allMethodsInCategory: aSymbol - "Answer a list of all the method categories of the receiver and all its superclasses" - - | aColl | - aColl _ OrderedCollection new. - self withAllSuperclasses do: - [:aClass | aColl addAll: - (aSymbol == ClassOrganizer allCategory - ifTrue: - [aClass organization allMethodSelectors] - ifFalse: - [aClass organization listAtCategoryNamed: aSymbol])]. - ^ aColl asSet sorted - -"TileMorph allMethodsInCategory: #initialization"! ! -!SystemDictionary methodsFor: 'browsing' stamp: 'jmv 5/24/2017 00:29:09' prior: 16924088! - browseClassesWithNamesContaining: aString caseSensitive: caseSensitive - "Smalltalk browseClassesWithNamesContaining: 'eMorph' caseSensitive: true " - "Launch a class-list list browser on all classes whose names containg aString as a substring." - - | suffix aList | - suffix _ caseSensitive - ifTrue: [' (case-sensitive)'] - ifFalse: [' (use shift for case-sensitive)']. - aList _ OrderedCollection new. - Smalltalk allClassesDo: [ :class | - (class name includesSubstring: aString caseSensitive: caseSensitive) - ifTrue: [aList add: class name]]. - aList size > 0 - ifTrue: [HierarchyBrowserWindow forClassesNamed: aList asSet sorted title: 'Classes whose names contain ' , aString , suffix]! ! -!ChangeSet methodsFor: 'method changes' stamp: 'jmv 5/24/2017 00:28:50' prior: 16797810! - changedMessageList - "Used by a message set browser to access the list view information." - - | messageList | - messageList _ OrderedCollection new. - changeRecords associationsDo: [ :clAssoc | | classNameInFull classNameInParts | - classNameInFull _ clAssoc key asString. - classNameInParts _ classNameInFull findTokens: ' '. - - (clAssoc value allChangeTypes includes: #comment) ifTrue: [ - messageList add: - (MethodReference new - setClassSymbol: classNameInParts first asSymbol - classIsMeta: false - methodSymbol: #Comment - stringVersion: classNameInFull, ' Comment')]. - - clAssoc value methodChangeTypes associationsDo: [ :mAssoc | - (#(remove addedThenRemoved movedToOtherPackage) includes: mAssoc value) ifFalse: [ - messageList add: - (MethodReference new - setClassSymbol: classNameInParts first asSymbol - classIsMeta: classNameInParts size > 1 - methodSymbol: mAssoc key - stringVersion: classNameInFull, ' ' , mAssoc key)]]]. - ^ messageList sorted! ! - -ArrayedCollection removeSelector: #asSortedArray! - -ArrayedCollection removeSelector: #asSortedArray! - -Collection removeSelector: #asSortedArray! - -Collection removeSelector: #asSortedArray! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3083-remove-asSortedArray-JuanVuletich-2017May24-00h34m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3083] on 25 May 2017 at 8:17:34 pm'! -!Integer methodsFor: 'benchmarks' stamp: 'jmv 5/25/2017 20:10:06' prior: 16859018! - tinyBenchmarks - "Report the results of running the two tiny Squeak benchmarks. - ar 9/10/1999: Adjusted to run at least 1 sec to get more stable results - 0 tinyBenchmarks - 292 MHz G3 Mac: 22,727,272 bytecodes/sec; 984,169 sends/sec - 400 MHz PII/Win98: 18,028,169 bytecodes/sec; 1,081,272 sends/sec - - RasPi2 - StackVM: 37,758,112 bytecodes/sec; 2,412,667 sends/sec - Raspi2- CogSSpur: 157,441,574 bytecodes/sec; 10,946,039 sends/sec - - C.H.I.P. (*1) - StackVM: 55,315,471 bytecodes/sec; 3,348,667 sends/sec - C.H.I.P. (*1) - CogSpur: 253,716,551 bytecodes/sec; 16,853,816 sends/sec - - 1.66GHz Atom N450 - Cog: 244,274,809 bytecodes/sec; 28,795,277 sends/sec - 1.66GHz Atom N450 - CogSpur: 469,724,770 bytecodes/sec; 30,754,699 sends/sec - - 1.33GHz Atom 3735G - Cog: 326,114,649 bytecodes/sec; 34,985,976 sends/sec - 1.33GHz Atom 3735G - CogSpur: 632,098,765 bytecodes/sec; 33,692,910 sends/sec - - 1.5GHz AMD A4-5000 APU - Cog: 390,243,902 bytecodes/sec; 47,507,997 sends/sec - 1.5GHz AMD A4-5000 APU - CogSpur: 675,907,590 bytecodes/sec; 40,669,724 sends/sec - 1.5GHz AMD A4-5000 APU - CogSpur64: 659,368,963 bytecodes/sec; 50,338,916 sends/sec - - 2.3GHz Tegra (*2) - StackVM: 258,847,320 bytecodes/sec; 13,014,759 sends/sec - 2.3GHz Tegra (*2) - CogSpur: 1,083,024,854 bytecodes/sec; 64,289,750 sends/sec - - 3.1GHz Core i3-2100 - Cog: 1,203,290,246 bytecodes/sec; 165,723,327 sends/sec - 3.1GHz Core i3-2100 - CogSpur: 2,042,892,768 bytecodes/sec; 127,837,794 sends/sec - - (*1) C.H.I.P. $9 Computer [Next Thing Co], Allwinner R8 Single-Core ARM Cortex-A8 - 1 GHz - (*2) ACER Chromebook CB5-311 - NVIDIA Tegra K1 Quad-Core ARM Cortex-A15 'r3' - 2.3 GHz - - It is interesting to note that Spur for the first time brings ARM hardware (RasPi and C.H.I.P.) into a 'Morphic is confortable and nice to use' level of performance. - " - | t1 t2 r n1 n2 | - n1 _ 1. - [ - t1 _ Time millisecondsToRun: [n1 benchmark]. - t1 < 1000] - whileTrue:[n1 _ n1 * 2]. "Note: #benchmark's runtime is about O(n)" - - n2 _ 28. - [ - t2 _ Time millisecondsToRun: [r _ n2 benchFib]. - t2 < 1000] - whileTrue:[n2 _ n2 + 1]. - "Note: #benchFib's runtime is about O(k^n), - where k is the golden number = (1 + 5 sqrt) / 2 = 1.618...." - - ^ ((n1 * 500000 * 1000) // t1) printStringWithCommas, ' bytecodes/sec; ', - ((r * 1000) // t2) printStringWithCommas, ' sends/sec'! ! -!SystemDictionary methodsFor: 'system attributes' stamp: 'jmv 5/14/2017 23:20:19' prior: 16925038! - isRunningCogit - "Returns true if we're running on the Cog JIT - (vmParameterAt: 46 is the size of the machine code zone) - Smalltalk isRunningCogit - " - - ^(self vmParameterAt: 46) - ifNotNil: [ :machineCodeZoneSize | machineCodeZoneSize > 0 ] - ifNil: [ false ]! ! -!SystemDictionary methodsFor: 'system attributes' stamp: 'jmv 5/14/2017 23:20:40' prior: 16925049! - isSpur - "Answer true if we are a Spur ObjectMemory. - Spur introduces a new format of header for objects, new format for classes, etc. - Smalltalk isSpur - " - - ^ self compactClassesArray isNil! ! -!SystemDictionary class methodsFor: 'copyright' stamp: 'jmv 5/14/2017 23:13:07' prior: 16925610! - copyright - "The Cuis Smalltalk copyright. - Parts are copyright of many contributors to Squeak and Cuis projects." - - ^ -'Portions of Cuis are: -Copyright (c) Xerox Corp. 1981, 1982. -Copyright (c) Apple Computer, Inc. 1985-1996. -Copyright (c) Contributors to Squeak and Cuis projects. 1997-2017.'! ! - -Utilities class removeSelector: #compileUsingClosures! - -Utilities class removeSelector: #compileUsingClosures! - -Utilities class removeSelector: #decommissionTheAllCategory! - -Utilities class removeSelector: #decommissionTheAllCategory! - -Utilities class removeSelector: #initializeClosures! - -Utilities class removeSelector: #initializeClosures! - -SystemVersion class removeSelector: #currentPluginVersion! - -SystemVersion class removeSelector: #currentPluginVersion! - -SystemVersion class removeSelector: #parseVersionString:! - -SystemVersion class removeSelector: #parseVersionString:! - -SystemVersion class removeSelector: #pluginVersion:newerThan:! - -SystemVersion class removeSelector: #pluginVersion:newerThan:! - -SystemDictionary removeSelector: #fixSourceCodeLineEndings! - -SystemDictionary removeSelector: #fixSourceCodeLineEndings! - -SystemDictionary removeSelector: #makeInternalRelease! - -SystemDictionary removeSelector: #makeInternalRelease! - -SystemDictionary removeSelector: #removeTextCode! - -SystemDictionary removeSelector: #removeTextCode! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3084-Cleanup-JuanVuletich-2017May25-20h08m-jmv.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3083] on 25 May 2017 at 8:23:29 pm'! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3085-Cleanup-JuanVuletich-2017May25-20h17m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3085] on 25 May 2017 at 9:56:27 pm'! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 5/25/2017 21:56:04' prior: 50334158! - saveAsNewVersion - "Save the image/changes using the next available version number." - " - Smalltalk saveAsNewVersion - " - | fileName newName changesName systemVersion | - self okayToSave ifFalse: [ ^ self ]. - systemVersion _ SystemVersion current. - fileName _ String streamContents: [ :strm | - strm - nextPutAll: 'Cuis'; - print: systemVersion versionMajor; - nextPut: $.; - print: systemVersion versionMinor; - nextPut: $-; - print: systemVersion highestUpdate. - Smalltalk isSpur - ifTrue: [ - Smalltalk wordSize = 4 ifTrue: [ - strm nextPutAll: '-32' ]] - ifFalse: [ - strm nextPutAll: '-v3' ]]. - newName _ fileName, '.image'. - (DirectoryEntry smalltalkImageDirectory // newName) exists ifTrue: [ - newName _ DirectoryEntry smalltalkImageDirectory - nextNameFor: fileName - extension: 'image' ]. - changesName _ self fullNameForChangesNamed: newName. - "Check to see if there is a .changes file that would cause a problem if we saved a new .image file with the new version number" - changesName asFileEntry exists ifTrue: [ - ^ self inform: -'There is already .changes file of the desired name, -', newName, ' -curiously already present, even though there is -no corresponding .image file. Please remedy -manually and then repeat your request.' ]. - "Try to clear all user state, including all class vars, preferences, etc" - self saveAs: newName andQuit: false clearAllClassState: true! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3086-NewImageFlavorNaming-JuanVuletich-2017May25-21h56m-jmv.1.cs.st----! - -----SNAPSHOT----#(25 May 2017 10:00:04.671955 pm) Cuis5.0-3086.image priorSource: 355768! - -----QUIT----#(25 May 2017 10:00:19.215065 pm) Cuis5.0-3086.image priorSource: 369480! - -----STARTUP----#(14 June 2017 3:33:55.592953 pm) as /home/juan/Rectifier/Cuis-Smalltalk-Dev/Cuis5.0-3086.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3086] on 29 May 2017 at 10:56:45 pm'! -!Integer methodsFor: 'benchmarks' stamp: 'jmv 5/29/2017 22:55:50' prior: 50342981! - tinyBenchmarks - "Report the results of running the two tiny Squeak benchmarks. - ar 9/10/1999: Adjusted to run at least 1 sec to get more stable results - 0 tinyBenchmarks - 292 MHz G3 Mac: 22,727,272 bytecodes/sec; 984,169 sends/sec - 400 MHz PII/Win98: 18,028,169 bytecodes/sec; 1,081,272 sends/sec - - RasPi2 - StackVM: 37,758,112 bytecodes/sec; 2,412,667 sends/sec - RasPi2- CogSSpur: 157,441,574 bytecodes/sec; 10,946,039 sends/sec - - C.H.I.P. (*1) - StackVM: 55,315,471 bytecodes/sec; 3,348,667 sends/sec - C.H.I.P. (*1) - CogSpur: 253,716,551 bytecodes/sec; 16,853,816 sends/sec - - RasPi3B - StackSpur 44,107,512 bytecodes/sec; 2,767,863 sends/sec - RasPi3B - CogSpur 281,783,159 bytecodes/sec; 16,404,381 sends/sec - - 1.66GHz Atom N450 - Cog: 244,274,809 bytecodes/sec; 28,795,277 sends/sec - 1.66GHz Atom N450 - CogSpur: 469,724,770 bytecodes/sec; 30,754,699 sends/sec - - 1.33GHz Atom 3735G - Cog: 326,114,649 bytecodes/sec; 34,985,976 sends/sec - 1.33GHz Atom 3735G - CogSpur: 632,098,765 bytecodes/sec; 33,692,910 sends/sec - - 1.5GHz AMD A4-5000 APU - Cog: 390,243,902 bytecodes/sec; 47,507,997 sends/sec - 1.5GHz AMD A4-5000 APU - CogSpur: 675,907,590 bytecodes/sec; 40,669,724 sends/sec - 1.5GHz AMD A4-5000 APU - CogSpur64: 659,368,963 bytecodes/sec; 50,338,916 sends/sec - - 2.3GHz Tegra (*2) - StackVM: 258,847,320 bytecodes/sec; 13,014,759 sends/sec - 2.3GHz Tegra (*2) - CogSpur: 1,083,024,854 bytecodes/sec; 64,289,750 sends/sec - - 3.1GHz Core i3-2100 - Cog: 1,203,290,246 bytecodes/sec; 165,723,327 sends/sec - 3.1GHz Core i3-2100 - CogSpur: 2,042,892,768 bytecodes/sec; 127,837,794 sends/sec - - (*1) C.H.I.P. $9 Computer [Next Thing Co], Allwinner R8 Single-Core ARM Cortex-A8 - 1 GHz - (*2) ACER Chromebook CB5-311 - NVIDIA Tegra K1 Quad-Core ARM Cortex-A15 'r3' - 2.3 GHz - - It is interesting to note that Spur for the first time brings ARM hardware (RasPi and C.H.I.P.) into a 'Morphic is confortable and nice to use' level of performance. - " - | t1 t2 r n1 n2 | - n1 _ 1. - [ - t1 _ Time millisecondsToRun: [n1 benchmark]. - t1 < 1000] - whileTrue:[n1 _ n1 * 2]. "Note: #benchmark's runtime is about O(n)" - - n2 _ 28. - [ - t2 _ Time millisecondsToRun: [r _ n2 benchFib]. - t2 < 1000] - whileTrue:[n2 _ n2 + 1]. - "Note: #benchFib's runtime is about O(k^n), - where k is the golden number = (1 + 5 sqrt) / 2 = 1.618...." - - ^ ((n1 * 500000 * 1000) // t1) printStringWithCommas, ' bytecodes/sec; ', - ((r * 1000) // t2) printStringWithCommas, ' sends/sec'! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3087-RasPi3-tinyBenchmarks-JuanVuletich-2017May29-22h54m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3087] on 30 May 2017 at 2:27:08 pm'! -!Integer methodsFor: 'benchmarks' stamp: 'jmv 5/30/2017 14:24:33' prior: 50343209! - tinyBenchmarks - "Report the results of running the two tiny Squeak benchmarks. - ar 9/10/1999: Adjusted to run at least 1 sec to get more stable results - 0 tinyBenchmarks - 292 MHz G3 Mac: 22,727,272 bytecodes/sec; 984,169 sends/sec - 400 MHz PII/Win98: 18,028,169 bytecodes/sec; 1,081,272 sends/sec - - RasPi2 - StackVM: 37,758,112 bytecodes/sec; 2,412,667 sends/sec - RasPi2- CogSSpur: 157,441,574 bytecodes/sec; 10,946,039 sends/sec - - C.H.I.P. (*1) - StackVM: 55,315,471 bytecodes/sec; 3,348,667 sends/sec - C.H.I.P. (*1) - CogSpur: 253,716,551 bytecodes/sec; 16,853,816 sends/sec - - RasPi3B - StackSpur 44,107,512 bytecodes/sec; 2,767,863 sends/sec - RasPi3B - CogSpur 281,783,159 bytecodes/sec; 16,404,381 sends/sec - - 1.66GHz Atom N450 - Cog: 244,274,809 bytecodes/sec; 28,795,277 sends/sec - 1.66GHz Atom N450 - CogSpur: 469,724,770 bytecodes/sec; 30,754,699 sends/sec - - 1.33GHz Atom 3735G - Cog: 326,114,649 bytecodes/sec; 34,985,976 sends/sec - 1.33GHz Atom 3735G - CogSpur: 632,098,765 bytecodes/sec; 33,692,910 sends/sec - - 1.5GHz AMD A4-5000 APU - Cog: 390,243,902 bytecodes/sec; 47,507,997 sends/sec - 1.5GHz AMD A4-5000 APU - CogSpur: 675,907,590 bytecodes/sec; 40,669,724 sends/sec - 1.5GHz AMD A4-5000 APU - CogSpur64: 659,368,963 bytecodes/sec; 50,338,916 sends/sec - - 2.3GHz Tegra (*2) - StackVM: 258,847,320 bytecodes/sec; 13,014,759 sends/sec - 2.3GHz Tegra (*2) - CogSpur: 1,083,024,854 bytecodes/sec; 64,289,750 sends/sec - - 3.1GHz Core i3-2100 - Cog: 1,203,290,246 bytecodes/sec; 165,723,327 sends/sec - 3.1GHz Core i3-2100 - CogSpur: 2,042,892,768 bytecodes/sec; 127,837,794 sends/sec - - 2.70GHz Core i5-6400 -CogSpur64 3,162,934,362 bytecodes/sec; 243,321,293 sends/sec - - (*1) C.H.I.P. $9 Computer [Next Thing Co], Allwinner R8 Single-Core ARM Cortex-A8 - 1 GHz - (*2) ACER Chromebook CB5-311 - NVIDIA Tegra K1 Quad-Core ARM Cortex-A15 'r3' - 2.3 GHz - - It is interesting to note that Spur for the first time brings ARM hardware (RasPi and C.H.I.P.) into a 'Morphic is confortable and nice to use' level of performance. - " - | t1 t2 r n1 n2 | - n1 _ 1. - [ - t1 _ Time millisecondsToRun: [n1 benchmark]. - t1 < 1000] - whileTrue:[n1 _ n1 * 2]. "Note: #benchmark's runtime is about O(n)" - - n2 _ 28. - [ - t2 _ Time millisecondsToRun: [r _ n2 benchFib]. - t2 < 1000] - whileTrue:[n2 _ n2 + 1]. - "Note: #benchFib's runtime is about O(k^n), - where k is the golden number = (1 + 5 sqrt) / 2 = 1.618...." - - ^ ((n1 * 500000 * 1000) // t1) printStringWithCommas, ' bytecodes/sec; ', - ((r * 1000) // t2) printStringWithCommas, ' sends/sec'! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3088-CoreI5-tinyBenchmarks-JuanVuletich-2017May30-14h24m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3088] on 31 May 2017 at 10:25:43 am'! -!WordArray methodsFor: 'accessing' stamp: 'jmv 5/31/2017 09:48:37'! - bytesAt: index - "Answer a ByteArray of 4 elements. - The 32-bit word is split in 4 bytes, in little endian format - WordArray with: 16rFF32791B :: bytesAt: 1 :: hex - " - - | bytes word | - bytes _ ByteArray new: 4. - word _ self at: index. "Usually a SmallInteger, but may be a Large Integer in 32-bit images" - 1 to: 4 do: [ :i | bytes at: i put: (word digitAt: i) ]. - ^ bytes! ! -!WordArray methodsFor: 'accessing' stamp: 'jmv 5/31/2017 09:53:07'! - bytesAt: index put: aByteArray - "Takes a ByteArray of 4 elements. - Store the 32-bit word made with those byes, in little endian format - WordArray new: 1 :: bytesAt: 1 put: #[16r1B 16r79 16r32 16rFF] :: first hex - " - - | word | - word _ 0. - 4 to: 1 by: -1 do: [ :i | word _ word * 256 + (aByteArray at: i) ]. - self at: index put: word! ! -!Bitmap methodsFor: 'accessing' stamp: 'jmv 5/31/2017 10:16:34'! - bytesAt: index - "Answer a ByteArray of 4 elements. - The 32-bit word is split in 4 bytes, in little endian format - WordArray with: 16rFF32791B :: bytesAt: 1 :: hex - " - - | bytes word | - bytes _ ByteArray new: 4. - word _ self at: index. "Usually a SmallInteger, but may be a Large Integer in 32-bit images" - 1 to: 4 do: [ :i | bytes at: i put: (word digitAt: i) ]. - ^ bytes! ! -!Bitmap methodsFor: 'accessing' stamp: 'jmv 5/31/2017 10:16:38'! - bytesAt: index put: aByteArray - "Takes a ByteArray of 4 elements. - Store the 32-bit word made with those byes, in little endian format - WordArray new: 1 :: bytesAt: 1 put: #[16r1B 16r79 16r32 16rFF] :: first hex - " - - | word | - word _ 0. - 4 to: 1 by: -1 do: [ :i | word _ word * 256 + (aByteArray at: i) ]. - self at: index put: word! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3089-BytesAccessForBitmapAndWordArray-JuanVuletich-2017May31-10h25m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3083] on 28 May 2017 at 8:07:38 pm'! -!TestCase methodsFor: 'Running' stamp: 'HAW 5/28/2017 20:01:43'! - setUpResources - - self resources do: [:res | res isAvailable ifFalse: [^res signalInitializationError]]. -! ! -!TestCase methodsFor: 'Running' stamp: 'HAW 5/28/2017 20:02:07'! - tearDownResources - - self resources do: [:each | each reset]! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 5/28/2017 20:03:22'! - runCaseAsFailure - - self setUpResources. - self setUp. - - self openDebuggerOnFailingTestMethod! ! -!TestSuite methodsFor: 'Running - Private' stamp: 'HAW 5/28/2017 20:04:46'! - setUpResources - - self resources do: [ :res | res isAvailable ifFalse: [^res signalInitializationError]]. - ! ! -!TestSuite methodsFor: 'Running - Private' stamp: 'HAW 5/28/2017 20:05:08'! - tearDownResources - - self resources do: [:each | each reset]! ! -!TestCase methodsFor: 'Running' stamp: 'HAW 5/28/2017 20:01:57' prior: 16927482! - debug - - self setUpResources. - - [(self class selector: testSelector) runCase] ensure: [self tearDownResources] - ! ! -!TestCase methodsFor: 'Running' stamp: 'HAW 5/28/2017 20:06:48' prior: 50340541! - debugAsFailureIfCanNot: handler - - self ifCanNotDebugDo: [ ^handler value]. - - (self class selector: testSelector) runCaseAsFailure! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 5/28/2017 16:11:59' prior: 16927577! - executeShould: aBlock inScopeOf: anExceptonHandlingCondition - - ^self executeShould: aBlock inScopeOf: anExceptonHandlingCondition withExceptionDo: [:anException | ] -! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 5/28/2017 16:12:11' prior: 50339015! - executeShould: aBlock inScopeOf: anExceptonHandlingCondition withExceptionDo: assertionsBlock - - ^[aBlock value. - false] - on: anExceptonHandlingCondition - do: [:exception | - assertionsBlock value: exception. - exception sunitExitWith: true]! ! -!TestCase methodsFor: 'Private' stamp: 'HAW 5/28/2017 20:03:03' prior: 50341196! - openDebuggerOnFailingTestMethod - - | processToDebug context compiledMethod debugger | - - compiledMethod _ self methodForTest. - - processToDebug _ [ [ self performTest ] ensure: [ - self tearDown. - self tearDownResources]] newProcess. - context _ processToDebug suspendedContext. - - debugger _ Debugger new - process: processToDebug - context: context. - debugger openFullNoSuspendLabel: 'Debug failed test ', self printString. - - [debugger interruptedContext method == compiledMethod] whileFalse: [debugger send]. -! ! -!TestSuite methodsFor: 'Running' stamp: 'HAW 5/28/2017 20:04:59' prior: 16928869! - run - - | result | - - result := TestResult new. - self setUpResources. - [self run: result] ensure: [self tearDownResources]. - - ^result - ! ! - -TestCase removeSelector: #openDebuggerOnFailingTestMethod2! - -TestCase removeSelector: #openDebuggerOnFailingTestMethod:! - -TestCase removeSelector: #openDebuggerOnFailingTestMethod:! - -TestCase removeSelector: #runCaseAsFailure:! - -TestCase removeSelector: #runCaseAsFailure:! - -Smalltalk removeClassNamed: #TestCaseDebugger! - -Smalltalk removeClassNamed: #TestCaseDebugger! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3090-SUnitDebugFix-HernanWilkinson-2017May23-19h28m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3083] on 28 May 2017 at 8:55:15 pm'! - -MessageNode removeSelector: #test! - -MessageNode removeSelector: #test! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3091-MessageNode-test-removal-HernanWilkinson-2017May28-20h54m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3083] on 28 May 2017 at 8:56:52 pm'! -!SetInspector methodsFor: 'accessing' stamp: 'HAW 5/28/2017 20:56:40' prior: 16907433! - fieldList - - (object isNil or: [ object array isNil]) ifTrue: [^ Set new]. - - ^ self baseFieldList, (object array withIndexCollect: [:each :i | each ifNotNil: [i printString]]) select: [:each | each notNil]! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3092-SetInspectorFix-HernanWilkinson-2017May28-20h55m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3092] on 2 June 2017 at 11:21:59 am'! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 11:01:27'! - defaultFailDescription - - ^'Test failed'! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 11:02:09'! - fail - - ^self failWith: self defaultFailDescription ! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 11:02:55'! - failWith: aDescription - - self signalFailure: aDescription ! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 10:57:13'! -should: aBlock raise: anExceptonHandlingCondition withExceptionDo: assertionsBlock description: aFailDescription - - ^[aBlock value. - self failWith: aFailDescription ] - on: anExceptonHandlingCondition - do: assertionsBlock ! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 10:58:09' prior: 16927436! - should: aBlock - - self assert: aBlock value - ! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 10:58:16' prior: 16927439! - should: aBlock description: aString - - self assert: aBlock value description: aString - ! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 10:54:56' prior: 16927443! - should: aBlock raise: anExceptonHandlingCondition - - ^self should: aBlock raise: anExceptonHandlingCondition withExceptionDo: [ :anException | ] - ! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 11:00:17' prior: 16927448! - should: aBlock raise: anExceptonHandlingCondition description: aFailDescription - - ^self should: aBlock raise: anExceptonHandlingCondition withExceptionDo: [:anException | ] description: aFailDescription! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 10:57:59' prior: 50339007! -should: aBlock raise: anExceptonHandlingCondition withExceptionDo: assertionsBlock - - ^self should: aBlock raise: anExceptonHandlingCondition withExceptionDo: assertionsBlock description: self defaultFailDescription! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 11:09:25' prior: 16927455! - shouldnt: aBlock - - self deny: aBlock value - ! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 11:09:20' prior: 16927458! - shouldnt: aBlock description: aString - - self deny: aBlock value description: aString - ! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 11:10:31' prior: 16927462! - shouldnt: aBlock raise: anExceptonHandlingCondition - - ^self shouldnt: aBlock raise: anExceptonHandlingCondition description: anExceptonHandlingCondition printString, ' was not expected to be raised'! ! -!TestCase methodsFor: 'Accessing' stamp: 'HAW 6/2/2017 11:06:04' prior: 16927468! - shouldnt: aBlock raise: anExceptonHandlingCondition description: aFailDescription - - ^aBlock - on: anExceptonHandlingCondition - do: [ :anException | self failWith: aFailDescription ] -! ! - -TestCase removeSelector: #executeShould:inScopeOf:! - -TestCase removeSelector: #executeShould:inScopeOf:! - -TestCase removeSelector: #executeShould:inScopeOf:withExceptionDo:! - -TestCase removeSelector: #executeShould:inScopeOf:withExceptionDo:! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3093-TestsDebuggingImprovements-HernanWilkinson-2017Jun02-10h25m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3092] on 2 June 2017 at 4:06:08 pm'! -!Behavior methodsFor: 'user interface' stamp: 'HAW 6/2/2017 16:05:24'! - addTo: aSet referencesTo: aSymbol special: special byte: byte. - - self withAllSuperAndSubclassesDoGently: [ :class | - (class whichSelectorsReferTo: aSymbol special: special byte: byte) - do: [ :sel | aSet add: (MethodReference class: class selector: sel) ]]. - ! ! -!Behavior methodsFor: 'user interface' stamp: 'HAW 6/2/2017 16:05:35' prior: 16784612! - allLocalCallsOn: aSymbol - "Answer a SortedCollection of all the methods that call on aSymbol, anywhere in my class hierarchy." - - | aSet special byte cls | - - aSet _ Set new. - cls _ self theNonMetaClass. - special _ Smalltalk - hasSpecialSelector: aSymbol - ifTrueSetByte: [ :b | byte _ b ]. - - cls addTo: aSet referencesTo: aSymbol special: special byte: byte. - cls class addTo: aSet referencesTo: aSymbol special: special byte: byte. - - ^aSet! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3094-LocalCallsFix-HernanWilkinson-2017Jun02-11h21m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3095] on 7 June 2017 at 10:50:30 am'! -!MessageSetWindow class methodsFor: 'instance creation' stamp: 'jmv 6/7/2017 10:49:13' prior: 16870573! - openMessageList: anArray label: aString - "Create a standard system view for the message set on the list, anArray. - The label of the view is aString." - - ^self open: (MessageSet messageList: anArray) label: aString! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3095-openMessageListlabel-fix-JuanVuletich-2017Jun07-10h47m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3094] on 3 June 2017 at 8:52:25 pm'! - -MessageSetWindow subclass: #TestResultWindow - instanceVariableNames: 'testResult' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Testing'! - -!classDefinition: #TestResultWindow category: #'Tools-Testing'! -MessageSetWindow subclass: #TestResultWindow - instanceVariableNames: 'testResult' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Testing'! -!ProgessiveTestRunner methodsFor: 'show result - private' stamp: 'HAW 6/3/2017 20:40:29'! - openTestResultWindow - - TestResultWindow openFor: testResult - ! ! -!TestCase methodsFor: 'Testing' stamp: 'HAW 6/3/2017 20:26:43'! - isSameAs: aTestCase - - ^self class = aTestCase class and: [ testSelector = aTestCase selector ]! ! -!TestResult methodsFor: 'Accessing' stamp: 'HAW 6/3/2017 20:27:28'! - removeFromDefectsAndAddToPassed: aPassed - - errors - detect: [ :anError | anError isSameAs: aPassed ] - ifFound: [ :anError | errors remove: anError ] - ifNone: [ - failures - detect: [ :aFail | aFail isSameAs: aPassed ] - ifFound: [ :aFail | failures remove: aFail ] - ifNone: [ self error: aPassed printString, ' is not an error nor a failure' ]]. - passed add: aPassed -! ! -!TestResultWindow methodsFor: 'actions' stamp: 'HAW 6/3/2017 20:51:08'! - debug - - model selection ifNotNil: [ :selection | | test | - test := selection actualClass selector: selection selector. - test debug. - testResult removeFromDefectsAndAddToPassed: test. - model removeMessageFromBrowserKeepingLabel. - self setLabel: testResult printString ]! ! -!TestResultWindow methodsFor: 'actions' stamp: 'HAW 6/3/2017 20:51:12'! - runSuite - - | suite | - - suite := TestSuite new. - suite addTests: testResult tests. - self delete. - (ProgessiveTestRunner for: suite) value. - ! ! -!TestResultWindow methodsFor: 'button creation' stamp: 'HAW 6/3/2017 20:51:16'! - createDebugButton - - ^PluggableButtonMorph - model: self - stateGetter: #isMessageSelected - action: #debug - label: 'Debug'. -! ! -!TestResultWindow methodsFor: 'button creation' stamp: 'HAW 6/3/2017 20:51:20'! - createReRunButton - - ^PluggableButtonMorph - model: self - stateGetter: nil - action: #runSuite - label: 'Run Suite'. -! ! -!TestResultWindow methodsFor: 'GUI building' stamp: 'HAW 6/3/2017 20:51:24'! - addButton: button to: row color: buttonColor - - button color: buttonColor. - row addMorph: button proportionalWidth: 10! ! -!TestResultWindow methodsFor: 'GUI building' stamp: 'HAW 6/3/2017 20:51:28'! - addButtonsTo: row color: buttonColor - - self addButton: self createDebugButton to: row color: buttonColor. - self addButton: self createReRunButton to: row color: buttonColor. - ! ! -!TestResultWindow methodsFor: 'GUI building' stamp: 'HAW 6/3/2017 20:51:32'! -buildLowerPanes - - | codeAndButtons | - - codeAndButtons _ LayoutMorph newColumn. - codeAndButtons - addMorph: self buttonsRow fixedHeight: self defaultButtonPaneHeight; - addAdjusterMorph; - addMorph: self buildMorphicCodePane proportionalHeight: 1.0. - - ^codeAndButtons ! ! -!TestResultWindow methodsFor: 'GUI building' stamp: 'HAW 6/3/2017 20:51:36'! - buttonsRow - - | buttonColor row | - - buttonColor := self buttonColor. - row := LayoutMorph newRow. - row doAdoptWidgetsColor. - row color: buttonColor. - - self addButtonsTo: row color: buttonColor. - - ^row - - ! ! -!TestResultWindow methodsFor: 'initialization' stamp: 'HAW 6/3/2017 20:51:40'! - initializeFor: aTestResult - - testResult := aTestResult ! ! -!TestResultWindow methodsFor: 'testing' stamp: 'HAW 6/3/2017 20:51:46'! - isMessageSelected - - ^model selection notNil ! ! -!TestResultWindow class methodsFor: 'instance creation' stamp: 'HAW 6/3/2017 20:50:29'! - methodReferencesOf: tests - - ^tests collect: [:aTest | MethodReference class: aTest class selector: aTest selector]. -! ! -!TestResultWindow class methodsFor: 'instance creation' stamp: 'HAW 6/3/2017 20:50:25'! - openFor: aTestResult - - | window | - - window := self openMessageList: (self methodReferencesOf: aTestResult defects) label: aTestResult printString. - window initializeFor: aTestResult. - - ^window - -! ! -!ProgessiveTestRunner methodsFor: 'show result - private' stamp: 'HAW 6/3/2017 20:40:17' prior: 50338186! - showDeffects - - | defects | - - defects _ testResult defects. - defects size = 1 - ifTrue: [ defects anyOne debug ] - ifFalse: [ self openTestResultWindow]! ! - -TestResult removeSelector: #forDebuggingAndInspection! - -TestResult removeSelector: #forDebuggingAndInspection! - -TestCase removeSelectorIfInBaseSystem: #should:raise:withMessageText:! - -ProgessiveTestRunner removeSelector: #openTestResultForDebuggingAndInspection! - -ProgessiveTestRunner removeSelector: #openTestResultForDebuggingAndInspection! - -Smalltalk removeClassNamed: #TestResultForDebuggingAndInspection! - -Smalltalk removeClassNamed: #TestResultForDebuggingAndInspection! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3096-TestResultWindow-HernanWilkinson-2017May28-21h03m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3094] on 3 June 2017 at 8:55:22 pm'! -!StringMorph methodsFor: 'drawing' stamp: 'HAW 6/3/2017 20:55:08' prior: 16918187! - drawOn: aCanvas - aCanvas - drawString: (contents ifNil: [ '' ]) - at: 0@0 - font: self fontToUse - color: color - ! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3097-StringMorph-fix-HernanWilkinson-2017Jun03-20h52m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3092] on 5 June 2017 at 12:39:46 am'! -!TheWorldMenu methodsFor: 'commands' stamp: 'pb 6/5/2017 00:35:30' prior: 16934691! - splitNewMorphList: list depth: d - | middle c prev next out | - d <= 0 ifTrue: [ ^ Array with: list ]. - middle := list size // 2 + 1. - c := (list at: middle) name first: 3. - prev := middle - 1. - [ - prev > 0 and: [ ((list at: prev) name first: 3) = c ]] whileTrue: [ prev := prev - 1 ]. - next := middle + 1. - [ - next <= list size and: [ ((list at: next) name first: 3) = c ]] whileTrue: [ next := next + 1 ]. - "Choose the better cluster" - middle := middle - prev < (next - middle) - ifTrue: [ prev + 1 ] - ifFalse: [ next ]. - middle = 1 ifTrue: [ middle := next ]. - middle >= list size ifTrue: [ middle := prev + 1 ]. - (middle = 1 or: [ middle >= list size ]) ifTrue: [ ^ Array with: list ]. - out := WriteStream on: Array new. - out nextPutAll: - (self - splitNewMorphList: - (list - copyFrom: 1 - to: middle - 1) - depth: d - 1). - out nextPutAll: - (self - splitNewMorphList: - (list - copyFrom: middle - to: list size) - depth: d - 1). - ^ out contents.! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'pb 6/5/2017 00:38:53' prior: 16934754! - alphabeticalMorphMenu - | list splitLists menu firstChar lastChar subMenu | - list := Morph withAllSubclasses select: [ :m | - m includeInNewMorphMenu ]. - list := list asArray sort: [ :c1 :c2 | - c1 name < c2 name ]. - splitLists := self - splitNewMorphList: list - depth: 4. - menu := MenuMorph new defaultTarget: self. - 1 - to: splitLists size - do: [ :i | - firstChar := i = 1 - ifTrue: [ $A ] - ifFalse: [ - (splitLists at: i) first name first: 3 ]. - lastChar := i = splitLists size - ifTrue: [ $Z ] - ifFalse: [ - (splitLists at: i) last name first: 3 ]. - subMenu := MenuMorph new. - (splitLists at: i) do: [ :cl | - subMenu - add: cl name - target: self - selector: #newMorphOfClass:event: - argument: cl ]. - menu - add: firstChar asString , ' - ' , lastChar asString - subMenu: subMenu ]. - ^ menu.! ! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3098-MoreGranularAlphaMorphMenu-PhilBellalouna-2017Jun05-00h35m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3086] on 5 June 2017 at 11:53:55 am'! -!CodeProvider methodsFor: 'message list menu' stamp: 'jmv 6/5/2017 11:51:33'! - exploreCompiledMethod - "Open an Explorer on the CompiledMethod itself" - - self selectedMessageName ifNotNil: [ - (self selectedClassOrMetaClass compiledMethodAt: self selectedMessageName) - explore ]! ! -!BrowserWindow methodsFor: 'menu building' stamp: 'jmv 6/5/2017 11:46:27' prior: 50338736! - messageListMenu - "Answer the message-list menu" - "Changed by emm to include menu-item for breakpoints" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addList:#( - ('what to show...' offerWhatToShowMenu) - ('toggle break on entry' toggleBreakOnEntry '' model) - - - ('browse full (b)' browseMethodFull) - ('browse hierarchy (h)' browseHierarchy) - ('browse method (O)' openSingleMessageBrowser) - ('browse protocol (p)' browseFullProtocol) - - - ('fileOut' fileOutMessage '' model) - ('explore CompiledMethod' exploreCompiledMethod '' model) - - - ('senders of... (n)' browseSendersOfMessages) - ('implementors of... (m)' browseMessages) - ('inheritance (i)' methodHierarchy) - ('versions (v)' browseVersions) - - - ('inst var refs...' browseInstVarRefs) - ('inst var defs...' browseInstVarDefs) - ('class var refs...' browseClassVarRefs) - ('class variables' browseClassVariables) - ('class refs (N)' browseClassRefs) - - - ('remove method (x)' removeMessage '' model) - ('Run test (t)' runMethodTest '' model) - ('Debug test (r)' debugMethodTest '' model) - - - ('more...' openShiftedMessageListMenu)). - ^ aMenu -! ! -!Theme methodsFor: 'menus' stamp: 'jmv 6/5/2017 11:46:34' prior: 16935967! - basicIcons - - "Minimal menu scheme. - Theme current class beCurrent - " - - ^ { - #('open...') -> #openIcon. - #('windows...' 'find window' 'Focus follows mouse' 'Click to focus') -> #windowIcon. - #('help...' 'explain' 'about this system...' 'Terse Guide to Cuis' 'Class Comment Browser' 'Code management in Cuis' 'Using GitHub to host Cuis packages' ) -> #helpIcon. - #('themes...') -> #appearanceIcon. - #('do it (d)') -> #doItIcon. - #('new morph...' 'objects (o)' 'save world as morph file') -> #morphsIcon. - #('save' ) -> #saveIcon. - #('Save options...' 'save as...' 'change category...' 'rename change set (r)' 'rename') -> #saveAsIcon. - #('save as new version') -> #saveAsNewVersionIcon. - #('quit') -> #quitIcon. - #('save and quit' ) -> #saveAndQuitIcon. - #('inspect it (i)' 'inspect world' 'inspect model' 'inspect morph' - 'inspect owner chain' 'inspect' 'inspect (i)' 'basic inspect' 'message names' 'find message names' 'inspect instances' 'inspect subinstances' 'inspect change set' 'inspect context (c)' 'inspect receiver (i)' 'start CPUWatcher' 'stop CPUWatcher') - -> #inspectIcon. - #('explore' 'explore it (I)' 'explore world' 'explore morph' 'explore (I)' 'explore context (C)' 'explore receiver (I)' 'references finder' 'weight explorer' 'explore CompiledMethod') -> #exploreIcon. - #('find...(f)' 'find class... (f)' 'find method...' 'find recent submissions' 'show hierarchy' 'show definition' 'show comment' 'filter' 'filter message list...' 'find context... (f)') -> #findIcon. - #('add item...' 'new category...' 'create new change set...' 'new change set... (n)' 'add new file') -> #newIcon. - #('remove method (x)' 'remove' 'remove class (x)' 'remove method from system (x)' 'remove class from system (x)' 'remove postscript') -> #deleteIcon. - #('delete method from changeset (d)' 'delete class from change set (d)' 'destroy change set (X)' 'revert & remove from changes' 'delete unchanged windows' 'delete non windows' 'delete both of the above' 'reset variables' 'remove contained in class categories...' 'clear this change set' 'uninstall this change set' 'delete directory...' 'delete') -> #warningIcon. - #('do again (j)' 'Redo - multiple (Z)') -> #redoIcon. - #('undo (z)' 'revert to previous version' 'Undo - multiple (z)') -> #undoIcon. - #('copy (c)' 'copy class...' 'copy class chgs to other side' 'copy method to other side' 'copy all to other side (c)' 'copy name to clipboard' 'copy selector to clipboard') -> #copyIcon. - #('paste (v)' 'Paste without Format') -> #pasteIcon. - #('cut (x)' 'move class chgs to other side' 'move method to other side' 'submerge into other side') -> #cutIcon. - #('paste...' 'icons...') -> #worldIcon. -}! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - - Theme current class beCurrent! - -----End fileIn of /home/juan/Rectifier/Cuis-Smalltalk-Dev/CoreUpdates/3099-exploreCompiledMethod-menuOption-JuanVuletich-2017Jun05-11h19m-jmv.1.cs.st----! - -----SNAPSHOT----#(14 June 2017 3:34:05.365138 pm) Cuis5.0-3099.image priorSource: 369571! - -----QUIT----#(14 June 2017 3:34:31.560152 pm) Cuis5.0-3099.image priorSource: 400239! - -----STARTUP----#(20 June 2017 5:55:35.881237 pm) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3099.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3099] on 9 June 2017 at 12:14:01 am'! -!RectangleLikeMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:47:05'! - categoryInNewMorphMenu - ^ 'Kernel'! ! -!PasteUpMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:51:39'! - categoryInNewMorphMenu - ^ 'Worlds'! ! -!EllipseMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:50:14'! - categoryInNewMorphMenu - ^ 'Basic'! ! -!ProgressBarMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/9/2017 00:05:22'! - categoryInNewMorphMenu - ^ 'Widgets'! ! -!ImageMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:54:09'! - categoryInNewMorphMenu - ^ 'Basic'! ! -!StringMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:55:41'! - categoryInNewMorphMenu - ^ 'Basic'! ! -!UpdatingStringMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/9/2017 00:04:50'! - categoryInNewMorphMenu - ^ 'Widgets'! ! -!LayoutMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:48:35'! - categoryInNewMorphMenu - ^ 'Layouts'! ! -!ProgressMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/9/2017 00:10:17'! - categoryInNewMorphMenu - ^ 'Widgets'! ! -!HaloHandleMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:53:34'! - categoryInNewMorphMenu - ^ 'Halos'! ! -!HaloMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:53:26'! - categoryInNewMorphMenu - ^ 'Halos'! ! -!ResizeMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:56:28'! - categoryInNewMorphMenu - ^ 'Views'! ! -!FillInTheBlankMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:52:51'! - categoryInNewMorphMenu - ^ 'Widgets'! ! -!HoverHelpMorph class methodsFor: 'new-morph participation' stamp: 'pb 6/8/2017 23:54:39'! - categoryInNewMorphMenu - ^ 'Widgets'! ! -!TheWorldMenu methodsFor: 'construction' stamp: 'pb 6/9/2017 00:11:33' prior: 50332703! - newMorph - "The user requested 'new morph' from the world menu. Put up a menu that allows many ways of obtaining new morphs. If the preference #classicNewMorphMenu is true, the full form of yore is used; otherwise, a much shortened form is used." - | menu subMenu catDict | - menu _ self menu: 'Add a new morph'. - menu - - add: 'From Clipboard' - target: myHand - action: #pasteMorph; - - add: 'From Alphabetical List' - subMenu: self alphabeticalMorphMenu. - menu addLine. - "Add 'Classic' New Morph menu" - catDict _ Dictionary new. - - Morph allSubclassesDo: [ :eaSubclass | - eaSubclass includeInNewMorphMenu ifTrue: [ | category | - (eaSubclass respondsTo: #categoryInNewMorphMenu) - ifTrue: [ category _ eaSubclass categoryInNewMorphMenu ] - ifFalse: [ category _ 'Unknown' ]. - (catDict includesKey: category) - ifTrue: [ (catDict at: category) add: eaSubclass ] - ifFalse: [ - catDict - at: category - put: (OrderedCollection with: eaSubclass) ]]]. - catDict keys sort do: [ :categ | - subMenu _ MenuMorph new. - ((catDict at: categ) asArray sort: [ :c1 :c2 | - c1 name < c2 name ]) do: [ :cl | - subMenu - add: cl name - target: self - selector: #newMorphOfClass:event: - argument: cl ]. - menu - add: categ - subMenu: subMenu ]. - self doPopUp: menu.! ! - -TheWorldMenu removeSelector: #newMorphOld! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3100-DynamicMorphMenuCategories-PhilBellalouna-2017Jun08-23h33m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3099] on 11 June 2017 at 8:11:06 pm'! -!TestCase class methodsFor: 'Testing' stamp: 'pb 6/11/2017 20:10:43' prior: 16927725! - isAbstract - "Override to true if a TestCase subclass is Abstract and should not have - TestCase instances built from it" - ^ thisContext methodClass == self class.! ! -!TestResource class methodsFor: 'Testing' stamp: 'pb 6/11/2017 20:10:52' prior: 16927869! - isAbstract - "Override to true if a TestResource subclass is Abstract and should not have - TestCase instances built from it" - ^ thisContext methodClass == self class.! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3101-isAbstract-PhilBellalouna-2017Jun11-20h10m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3099] on 9 June 2017 at 1:04:48 am'! -!Preferences class methodsFor: 'halos' stamp: 'pb 6/9/2017 00:46:36' prior: 16893159! -iconicHaloSpecifications - "Answer an array that characterizes the locations, colors, icons, and selectors of the halo handles that may be used in the iconic halo scheme" - - " - Preferences resetHaloSpecifications - " - -^ #( - "selector horiz vert color info icon key balloon help - --------- ------ ----------- ------------------------------- ---------------" - (addCollapseHandle: left topCenter (tan) haloCollapseIcon 'Collapse') - (addDebugHandle: right topCenter (orange) haloDebugIcon 'Debug') - (addDismissHandle: left top (red) haloDismissIcon 'Remove') - "FIXME - Currently non-functional... - (addRotateHandle: left bottom (blue) haloRotateIcon 'Rotate') - " - (addMenuHandle: leftCenter top (blue lighter) haloMenuIcon 'Menu') - (addGrabHandle: center top (black) haloGrabIcon 'Pick up') - (addDragHandle: rightCenter top (brown) haloDragIcon 'Move') - (addDupHandle: right top (green) haloDuplicateIcon 'Duplicate') - (addHelpHandle: center bottom (lightBlue) haloHelpIcon 'Help') - (addGrowHandle: right bottom (yellow) haloScaleIcon 'Change size') - (addFontSizeHandle: leftCenter bottom (lightGreen) haloFontSizeIcon 'Change font') - (addFontEmphHandle: rightCenter bottom (lightBrown darker) haloFontEmphasisIcon 'Emphasis & alignment') - "FIXME - Currently non-functional... - (addRecolorHandle: right bottomCenter (magenta darker) haloColorIcon 'Change color') - " -)! ! -!Morph methodsFor: 'halos and balloon help' stamp: 'pb 6/9/2017 00:52:09' prior: 16875868! - wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph - "Answer whether the receiver would like to offer the halo handle with the given selector (e.g. #addCollapseHandle:)" - - (#(addRotateHandle: addRecolorHandle:) statePointsTo: aSelector) - ifTrue: ["FIXME - hack to disable for non-functional halo items" - ^ false]. - - Preferences selectiveHalos ifFalse: [ - ^true ]. - - (#(#addDismissHandle: ) includes: aSelector) - ifTrue: [ ^ self resistsRemoval not ]. - (#(#addDragHandle: ) includes: aSelector) - ifTrue: [ ^ self okayToBrownDragEasily ]. - (#(#addGrowHandle: ) includes: aSelector) - ifTrue: [ ^ self okayToResizeEasily ]. - (#(#addRotateHandle: ) includes: aSelector) - ifTrue: [ ^ self okayToRotateEasily ]. - (#(#addRecolorHandle: ) includes: aSelector) - ifTrue: [ ^ self wantsRecolorHandle ]. - ^ true! ! -!PasteUpMorph methodsFor: 'halos and balloon help' stamp: 'pb 6/9/2017 00:51:44' prior: 16887852! - wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph - "Answer whether the receiver would like to offer the halo handle with the given selector (e.g. #addCollapseHandle:)" - (#(addHelpHandle: addRotateHandle: addRecolorHandle:) statePointsTo: aSelector) - ifTrue: ["FIXME - hack to disable for non-functional halo items" - ^ false]. - - self isWorldMorph ifFalse: [ - ^super wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph ]. - - ^#(addDebugHandle: addMenuHandle: addHelpHandle:) - statePointsTo: aSelector! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3102-Disable-Nonfunctional-Halos-PhilBellalouna-2017Jun09-00h45m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3099] on 10 June 2017 at 1:39:18 am'! -!Array methodsFor: 'printing' stamp: 'pb 6/10/2017 01:39:04' prior: 16779829! - isLiteral - "Definition from Squeak" - ^ self class == Array and: [ - self allSatisfy: [ :each | - each isLiteral ]].! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3103-Array-isLiteral-compatibility-with-Squeak-PhilBellalouna-2017Jun10-01h39m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3103] on 19 June 2017 at 11:46:49 am'! -!ChangeList methodsFor: 'menu actions' stamp: 'jmv 6/19/2017 11:45:52'! - fileOutCurrentVersionsOfSelections - - (FillInTheBlankMorph - request: 'Enter file name' - initialAnswer: 'Filename.st' - onCancel: [^nil]) - - asFileEntry writeStreamDo: [ :stream | - stream timeStamp. - self currentVersionsOfSelections do: [ :methodRef | - methodRef actualClass - printMethodChunk: methodRef methodSymbol - withPreamble: true - on: stream - moveSource: false - toFile: 0 ]]! ! -!ChangeListWindow methodsFor: 'menu building' stamp: 'jmv 6/19/2017 11:39:03' prior: 16797171! - listMenu - "Fill aMenu up so that it comprises the primary changelist-browser menu" - - | aMenu | - aMenu _ MenuMorph new defaultTarget: self. - aMenu addTitle: 'change list'. - aMenu addStayUpIcons. - aMenu addList: #( - ('fileIn selections' fileInSelections - 'import the selected items into the image' model) - ('fileOut selections... ' fileOutSelections - 'create a new file containing the selected items' model) - ('fileOut current version of selections...' fileOutCurrentVersionsOfSelections - 'create a new file containing the current (in-image) counterparts of the selected methods' model) - - - ('compare to current' compareToCurrentVersion - 'open a separate window which shows the text differences between the on-file version and the in-image version.' model) - ('toggle diffing (D)' toggleDiffing - 'start or stop showing diffs in the code pane.' model) - - - ('select new methods' selectNewMethods - 'select methods in the file that do not currently exist in the image' model) - ('select changes for absent classes' selectAllForAbsentClasses - 'select methods in the file for classes that are not defined in the image' model) - ('select all changes for this class' selectAllForThisClass - 'select all methods in the file that belong to the currently-selected class' model) - ('select unchanged methods' selectUnchangedMethods - 'select methods in the file whose in-image versions are the same as their in-file counterparts' model) - ('select methods equivalent to current' selectEquivalentMethods - 'select methods in the file whose in-image versions have the same behavior as their in-file counterparts' model) - ('select methods older than current' selectMethodsOlderThanCurrent - 'select methods in the file that are older than the one currently in the image' model) - ('select removals of sent methods' selectRemovalsOfSent - 'select all method removals of methods that have some sender in the image' model) - - - ('select all (a)' selectAll - 'select all the items in the list' model) - ('deselect all' deselectAll - 'deselect all the items in the list' model) - ('invert selections' invertSelections - 'select every item that is not currently selected, and deselect every item that *is* currently selected' model) - - - ('browse class and method' browseMethodFull - 'open a full browser showing the selected method') - ('browse all versions of single selection' browseVersions - 'open a version browser showing the versions of the currently selected method') - ('browse current versions of selections' browseCurrentVersionsOfSelections - 'open a message-list browser showing the current (in-image) counterparts of the selected methods') - ('destroy current methods of selections' destroyCurrentCodeOfSelections - 'remove (*destroy*) the in-image counterparts of all selected methods' model) - - - ('remove doIts' removeDoIts - 'remove all items that are doIts rather than definitions' model) - ('remove older versions' removeOlderMethodVersions - 'remove all but the most recent versions of methods in the list' model) - ('remove up-to-date versions' removeUpToDate - 'remove all items whose code is the same as the counterpart in-image code' model) - ('remove empty class comments' removeEmptyClassComments - 'remove all empty class comments' model) - ('remove selected items' removeSelections - 'remove the selected items from the change-list' model) - ('remove unselected items' removeNonSelections - 'remove all the items not currently selected from the change-list' model)). - ^ aMenu! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3104-fileOutCurrentVersions-JuanVuletich-2017Jun19-11h26m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3103] on 19 June 2017 at 11:07:11 am'! - -FloatArray variableWordSubclass: #Colour - instanceVariableNames: '' - classVariableNames: 'CachedColormaps ColorNamesDict FromGrayColormaps GrayToIndexMap IndexedColors MaskingMap ToGrayColormaps' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -!classDefinition: #Colour category: #'Graphics-Primitives'! -FloatArray variableWordSubclass: #Colour - instanceVariableNames: '' - classVariableNames: 'CachedColormaps ColorNamesDict FromGrayColormaps GrayToIndexMap IndexedColors MaskingMap ToGrayColormaps' - poolDictionaries: '' - category: 'Graphics-Primitives'! -!Colour commentStamp: 'jmv 6/18/2017 20:14:31' prior: 0! - This class represents abstract color, regardless of the depth of bitmap it will be shown in. At the very last moment a Color is converted to a pixelValue that depends on the depth of the actual Bitmap inside the Form it will be used with. The supported depths (in bits) are 1, 2, 4, 8, 16, and 32. The number of actual colors at these depths are: 2, 4, 16, 256, 32768, and 16 million. (See comment in BitBlt.) To change the depth of the Display and set how many colors you can see, execute: (Display newDepth: 8). (See comment in DisplayMedium) - Color is represented as the amount of light in red, green, and blue. White is (1.0, 1.0, 1.0) and black is (0, 0, 0). Pure red is (1.0, 0, 0). These colors are "additive". Think of Color's instance variables as: - r amount of red, a Float between 0.0 and 1.0. - g amount of green, a Float between 0.0 and 1.0. - b amount of blue, a Float between 0.0 and 1.0. - Many colors are named. You find a color by name by sending a message to class Color, for example (Color lightBlue). Also, (Color red: 0.2 green: 0.6 blue: 1.0) or (Color r: 0.2 g: 0.6 b: 1.0) creates a color. (see below) - A color is essentially immutable. Once you set red, green, and blue, you cannot change them. Instead, create a new Color and use it. - Applications such as contour maps and bar graphs will want to display one of a set of shades based on a number. Convert the range of this number to an integer from 1 to N. Then call (Color green lightShades: N) to get an Array of colors from white to green. Use the Array messages at:, atPin:, or atWrap: to pull out the correct color from the array. atPin: gives the first (or last) color if the index is out of range. atWrap: wraps around to the other end if the index is out of range. - Here are some fun things to run in when your screen has color: - Pen new mandala: 30 diameter: Display height-100. - Pen new web "Draw with the mouse, opt-click to end" - Display fillWhite. Pen new hilberts: 5. - Form toothpaste: 30 "Draw with mouse, opt-click to end" - -Messages: - mixed: proportion with: aColor Answer this color mixed with the given color additively. The proportion, a number between 0.0 and 1.0, determines what what fraction of the receiver to use in the mix. - - + add two colors - - subtract two colors - * multiply the values of r, g, b by a number or an Array of factors. ((Color named: #white) * 0.3) gives a darkish gray. (aColor * #(0 0 0.9)) gives a color with slightly less blue. - / divide a color by a factor or an array of three factors. - - hue Returns the hue of the color. On a wheel from 0 to 360 with pure red at 0 and again at 360. - saturation Returns the saturation of the color. 0.0 to 1.0 - brightness Returns the brightness of the color. 0.0 to 1.0 - - name Look to see if this Color has a name. - display Show a swatch of this color tracking the cursor. - - lightShades: thisMany An array of thisMany colors from white to the receiver. - darkShades: thisMany An array of thisMany colors from black to the receiver. Array is of length num. - mix: color2 shades: thisMany An array of thisMany colors from the receiver to color2. - wheel: thisMany An array of thisMany colors around the color wheel starting and ending at the receiver. - - pixelValueForDepth: d Returns the bits that appear be in a Bitmap of this depth for this color. Represents the nearest available color at this depth. Normal users do not need to know which pixelValue is used for which color. - -Messages to Class Color. - red: r green: g blue: b Return a color with the given r, g, and b components. - r: g: b: Same as above, for fast typing. - - hue: h saturation: s brightness: b Create a color with the given hue, saturation, and brightness. - - pink - blue - red ... Many colors have messages that return an instance of Color. - canUnderstand: #brown Returns true if #brown is a defined color. - names An OrderedCollection of the names of the colors. - named: #notAllThatGray put: aColor Add a new color to the list and create an access message and a class variable for it. - fromUser Shows the palette of colors available at this display depth. Click anywhere to return the color you clicked on. - - hotColdShades: thisMany An array of thisMany colors showing temperature from blue to red to white hot. - - stdColorsForDepth: d An Array of colors available at this depth. For 16 bit and 32 bits, returns a ColorGenerator. It responds to at: with a Color for that index, simulating a very big Array. - - colorFromPixelValue: value depth: d Returns a Color whose bit pattern (inside a Bitmap) at this depth is the number specified. Normal users do not need to use this. - -(See also comments in these classes: Form, Bitmap, BitBlt) - -Default colorSpace is #sRGB. Subclasses might use other color spaces! - -Colour variableWordSubclass: #TranslucentColour - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -!classDefinition: #TranslucentColour category: #'Graphics-Primitives'! -Colour variableWordSubclass: #TranslucentColour - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Primitives'! -!TranslucentColour commentStamp: '' prior: 0! - A TranslucentColor behaves just like a normal color, except that it will pack its alpha value into the fourth position. This allows creating forms with translucency for use with the alpha blend function of BitBlt. An alpha of zero is transparent, and 1.0 is opaque.! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:10:00'! - alpha - "Return the opacity ('alpha') value of opaque so that normal colors can be compared to TranslucentColors." - - ^ 1.0 -! ! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:35:34'! - blue - "Return the blue component of this color, a float in the range [0.0..1.0]." - - ^ self at: 3! ! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:33:10'! - brightness - "Return the brightness of this color, a float in the range [0.0..1.0]. - Color red brightness - " - - "Do not include alpha if TranslucentColour" - ^ (self red max: self green) max: self blue! ! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:34:30'! - chroma - "Return the chroma of this color, a value between 0.0 and 1.0, somewhat related to saturation. - See http://en.wikipedia.org/wiki/HSL_and_HSV - Color red chroma - Color gray chroma - " - - | r g b max min | - r _ self red. - g _ self green. - b _ self blue. - max _ (r max: g) max: b. - min _ (r min: g) min: b. - ^max - min! ! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:35:28'! - green - "Return the green component of this color, a float in the range [0.0..1.0]." - - ^ self at: 2! ! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:31:54'! - hue - "Return the hue of this color, an angle in the range [0.0..360.0]. - Color orange hue - " - - | r g b max min span h | - r _ self red. - g _ self green. - b _ self blue. - max _ (r max: g) max: b. - min _ (r min: g) min: b. - span _ (max - min) asFloat. - span = 0.0 ifTrue: [ ^ 0.0 ]. - - r = max ifTrue: [ - h _ ((g - b) asFloat / span) * 60.0. - ] ifFalse: [ - g = max - ifTrue: [ h _ 120.0 + (((b - r) asFloat / span) * 60.0). ] - ifFalse: [ h _ 240.0 + (((r - g) asFloat / span) * 60.0). ]. - ]. - - ^h mod: 360.0! ! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:10:00'! - icon - "Answer a swatch to display in a menu or browser" - ^self swatch! ! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:10:00'! - iconOrThumbnailOfSize: aNumberOrPoint - "Answer an appropiate form to represent the receiver" - | form | - form := Form extent: aNumberOrPoint asPoint asPoint depth: 32. - form fillColor: self. - ^ form! ! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:10:00'! - luminance - "Return the luminance of this color, a brightness value weighted by the human eye's color sensitivity." - - ^ ((299 * self red) + - (587 * self green) + - (114 * self blue)) / 1000! ! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:35:25'! - red - "Return the red component of this color, a float in the range [0.0..1.0]." - - ^ self at: 1! ! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:34:08'! -saturation - "Return the saturation of this color, a value between 0.0 and 1.0. - Color red saturation - Color gray saturation - " - - | r g b max min | - r _ self red. - g _ self green. - b _ self blue. - max _ (r max: g) max: b. - min _ (r min: g) min: b. - max = 0.0 ifTrue: [ ^0.0 ]. - ^max - min / max! ! -!Colour methodsFor: 'access' stamp: 'jmv 6/18/2017 20:10:00'! - swatch - "Answer a swatch to display in a menu or browser" - ^self iconOrThumbnailOfSize: 16! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:00'! - asNontranslucentColor - ^ self! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:20:07'! - bitPatternForDepth: depth - "Return a Bitmap, that best represents this color at the given depth. BitBlt calls this method to convert colors into Bitmaps." - "See also: pixelValueForDepth: -- value for single pixel - pixelWordForDepth: -- a 32-bit word filled with the pixel value" - - ^ Bitmap with: (self pixelWordForDepth: depth)! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:00'! - bitPatternForGrayForm - "Return a Bitmap, that best represents this color at the given depth. BitBlt calls this method to convert colors into Bitmaps." - "See also: pixelValueForDepth: -- value for single pixel - pixelWordForDepth: -- a 32-bit word filled with the pixel value" - "Details: The pattern for the most recently requested depth is cached." - - ^Bitmap with: (self pixelWordFor: 8 filledWith: (self luminance * 255) rounded)! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:00'! - closestPixelValue1 - "Return the nearest approximation to this color for a monochrome Form." - - "fast special cases" - self isBlack ifTrue: [^ 1]. "black" - self isWhite ifTrue: [^ 0]. "white" - - self luminance > 0.5 - ifTrue: [^ 0] "white" - ifFalse: [^ 1]. "black"! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:00'! - closestPixelValue2 - "Return the nearest approximation to this color for a 2-bit deep Form." - - | lum | - "fast special cases" - self isBlack ifTrue: [^ 1]. "black" - self isWhite ifTrue: [^ 2]. "opaque white" - - lum _ self luminance. - lum < 0.2 ifTrue: [^ 1]. "black" - lum > 0.6 ifTrue: [^ 2]. "opaque white" - ^ 3 "50% gray" -! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:00'! - closestPixelValue4 - "Return the nearest approximation to this color for a 4-bit deep Form." - - | bIndex | - "fast special cases" - self isBlack ifTrue: [^ 1]. "black" - self isWhite ifTrue: [^ 2]. "opaque white" - - self isRed ifTrue: [^ 4]. - self isGreen ifTrue: [^ 5]. - self isBlue ifTrue: [^ 6]. - self isCyan ifTrue: [^ 7]. - self isYellow ifTrue: [^ 8]. - self isMagenta ifTrue: [^ 9]. - - bIndex _ (self luminance * 8.0) rounded. "bIndex in [0..8]" - ^ #( - 1 "black" - 10 "1/8 gray" - 11 "2/8 gray" - 12 "3/8 gray" - 3 "4/8 gray" - 13 "5/8 gray" - 14 "6/8 gray" - 15 "7/8 gray" - 2 "opaque white" - ) at: bIndex + 1. -! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:00'! - closestPixelValue8 - "Return the nearest approximation to this color for an 8-bit deep Form." - - "fast special cases" - self isBlack ifTrue: [^ 1]. "black" - self isWhite ifTrue: [^ 255]. "white" - - ^self saturation < 0.2 - ifTrue: [ - ^ self class grayToIndexMap at:(self green * 255) rounded + 1. "nearest gray" - ] - ifFalse: [ - "compute nearest entry in the color cube" - 40 + - ((self red * 5) rounded * 36) + - ((self blue * 5) rounded * 6) + - (self green * 5) rounded ]! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:00'! - dominantColor - ^ self! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:00'! - indexInMap: aColorMap - "Return the index corresponding to this color in the given color map. RGB colors are truncated to 3-, 4-, or 5-bits per color component when indexing into such a colorMap. " - - aColorMap size = 2 ifTrue: [^ (self pixelValueForDepth: 1) + 1]. - aColorMap size = 4 ifTrue: [^ (self pixelValueForDepth: 2) + 1]. - aColorMap size = 16 ifTrue: [^ (self pixelValueForDepth: 4) + 1]. - aColorMap size = 256 ifTrue: [^ (self pixelValueForDepth: 8) + 1]. - aColorMap size = 512 ifTrue: [^ (self pixelValueForDepth: 9) + 1]. - aColorMap size = 4096 ifTrue: [^ (self pixelValueForDepth: 12) + 1]. - aColorMap size = 32768 ifTrue: [^ (self pixelValueForDepth: 15) + 1]. - self error: 'unknown pixel depth'. -! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:51:40'! - makeForegroundColor - "Make a foreground color contrasting with me" - ^self luminance >= 0.5 - ifTrue: [Colour black] - ifFalse: [Colour white]! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:00'! - pixelValueForDepth: d - "Returns an integer representing the bits that appear in a single pixel of this color in a Form of the given depth. The depth must be one of 1, 2, 4, 8, 16, or 32. Contrast with pixelWordForDepth: and bitPatternForDepth:, which return either a 32-bit word packed with the given pixel value or a multiple-word Bitmap containing a pattern. The inverse is the class message colorFromPixelValue:depth:" - "Details: For depths of 8 or less, the result is a colorMap index. For depths of 16 and 32, it is a direct color value with 5 or 8 bits per color component." - "Transparency: The pixel value zero is reserved for transparent. For depths greater than 8 and less than 32 (no Indexed colors, no real alpha), black maps to the darkest possible blue. - Note that - Color transparent class = TranslucentColor - this special case is handled in TranslucentColor >> #pixelValueForDepth: - " - - | bitBltFakeBlack val | - d = 8 ifTrue: [^ self closestPixelValue8]. "common case" - d < 8 ifTrue: [ - d = 4 ifTrue: [^ self closestPixelValue4]. - d = 2 ifTrue: [^ self closestPixelValue2]. - d = 1 ifTrue: [^ self closestPixelValue1]]. - - d = 32 ifTrue: [ - "eight bits per component; top 8 bits set to all ones (opaque alpha)" - val _ LargePositiveInteger new: 4. - val at: 3 put: (self red * 255) rounded. - val at: 2 put: (self green * 255) rounded. - val at: 1 put: (self blue * 255) rounded. - val at: 4 put: 16rFF. "opaque alpha" - ^ val normalize]. - - "For the depth 16, pixelValue = 0 means transparent, black is represented as 16r8000 (rgb=0, pixelvalue !!= 0)." - (d = 16) | (d = 15) ifTrue: [ - "five bits per component; top bits ignored" - val _ ((self red * 31) rounded bitShift: 10) bitOr: - (((self green * 31) rounded bitShift: 5) bitOr: - ((self blue * 31) rounded)). - ^ val = 0 - ifTrue: [d = 16 ifTrue: [16r8000] ifFalse: [1]] - ifFalse: [val]]. - - "For the rest of the depths, pixelValue = 0 means transparent, and darkest blue is considered to be black." - bitBltFakeBlack := 1. "closest black that is not transparent in RGB - Not for depths <=8 (Indexed) or = 32 (RGBA)" - d = 12 ifTrue: [ "for indexing a color map with 4 bits per color component" - val _ ((self red * 15) rounded bitShift: 8) bitOr: - (((self green * 15) rounded bitShift: 4) bitOr: - ((self blue * 15) rounded)). - ^ val = 0 ifTrue: [bitBltFakeBlack] ifFalse: [val]]. - - d = 9 ifTrue: [ "for indexing a color map with 3 bits per color component" - val _ ((self red * 7) rounded bitShift: 6) bitOr: - (((self green * 7) rounded bitShift: 3) bitOr: - ((self blue * 7) rounded)). - ^ val = 0 ifTrue: [bitBltFakeBlack] ifFalse: [val]]. - - self error: 'unknown pixel depth: ', d printString! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:00'! - pixelWordFor: depth filledWith: pixelValue - "Return to a 32-bit word that concatenates enough copies of the given pixel value to fill the word (i.e., 32/depth copies). Depth should be one of 1, 2, 4, 8, 16, or 32. The pixel value should be an integer in 0..2^depth-1." - | halfword | - depth = 32 ifTrue: [^ pixelValue]. - depth = 16 - ifTrue: [halfword _ pixelValue] - ifFalse: [halfword _ pixelValue * - (#(16rFFFF "replicates at every bit" - 16r5555 - "replicates every 2 bits" - 16r1111 - - - "replicates every 4 bits" - 16r0101) at: depth) "replicates every 8 bits"]. - ^ halfword bitOr: (halfword bitShift: 16)! ! -!Colour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:00'! - pixelWordForDepth: depth - "Return to a 32-bit word that concatenates enough copies of the receiver's pixel value to fill the word (i.e., 32/depth copies). Depth should be one of 1, 2, 4, 8, 16, or 32. The pixel value should be an integer in 0..2^depth-1." - - | pixelValue | - pixelValue _ self pixelValueForDepth: depth. - ^ self pixelWordFor: depth filledWith: pixelValue -! ! -!Colour methodsFor: 'equality' stamp: 'jmv 6/18/2017 20:38:11'! - diff: theOther - "Returns a number between 0.0 and 1.0. - Color gray diff: Color red - " - ^(self - theOther ) abs sum / self size! ! -!Colour methodsFor: 'equality' stamp: 'jmv 6/18/2017 20:10:00'! - rgbDistance: otherColor - "Compare two colors in distance" -" - ^ (self hue - otherColor hue) abs + - (self saturation - otherColor saturation) abs *10 + - (self brightness - otherColor brightness) abs -" - "See http://www.compuphase.com/cmetric.htm" - | meanRed deltaRed deltaGreen deltaBlue | - meanRed := (self red + otherColor red) abs / 2. - deltaRed := (self red - otherColor red) abs. - deltaGreen := (self green - otherColor green) abs. - deltaBlue := (self blue - otherColor blue) abs. - - ^ ( ((2 + (meanRed / 256)) * (deltaRed * deltaRed)) + - (4 * deltaGreen) + - ((2 + ((255 - meanRed) / 256)) * deltaBlue) - ) sqrt! ! -!Colour methodsFor: 'groups of shades' stamp: 'jmv 6/18/2017 20:10:00'! - darkShades: thisMany - "An array of thisMany colors from black to the receiver. Array is of length num. Very useful for displaying color based on a variable in your program. " - "Color showColors: (Color red darkShades: 12)" - - ^ self class black mix: self shades: thisMany -! ! -!Colour methodsFor: 'groups of shades' stamp: 'jmv 6/18/2017 20:10:00'! - lightShades: thisMany - "An array of thisMany colors from white to self. Very useful for displaying color based on a variable in your program. " - "Color showColors: (Color red lightShades: 12)" - - ^ self class white mix: self shades: thisMany -! ! -!Colour methodsFor: 'groups of shades' stamp: 'jmv 6/18/2017 20:51:45'! - mix: color2 shades: thisMany - "Return an array of thisMany colors from self to color2. Very useful for displaying color based on a variable in your program. " - "Color showColors: (Color red mix: Color green shades: 12)" - - | redInc greenInc blueInc rr gg bb c out | - thisMany = 1 ifTrue: [^ Array with: color2]. - redInc _ color2 red - self red / (thisMany-1). - greenInc _ color2 green - self green / (thisMany-1). - blueInc _ color2 blue - self blue / (thisMany-1). - rr _ self red. gg _ self green. bb _ self blue. - out _ (1 to: thisMany) collect: [:num | - c _ Colour r: rr g: gg b: bb. - rr _ rr + redInc. - gg _ gg + greenInc. - bb _ bb + blueInc. - c]. - out at: out size put: color2. "hide roundoff errors" - ^ out -! ! -!Colour methodsFor: 'groups of shades' stamp: 'jmv 6/18/2017 20:52:45'! - wheel: thisMany - "An array of thisMany colors around the color wheel starting at self and ending all the way around the hue space just before self. Array is of length thisMany. Very useful for displaying color based on a variable in your program. " - - | sat bri hue step c | - sat _ self saturation. - bri _ self brightness. - hue _ self hue. - step _ 360.0 / (thisMany max: 1). - ^ (1 to: thisMany) collect: [:num | - c _ Colour h: hue s: sat v: bri. "hue is taken mod 360" - hue _ hue + step. - c]. -" -(Colour wheel: 8) withIndexDo: [:c :i | Display fill: (i*10@20 extent: 10@20) fillColor: c] -"! ! -!Colour methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:00'! - closestAssocFrom: aColorDict - "Answer closest associated color in aColorDict" -" - ((Color r: 0.3 g: 0.2 b: 0.8) closestAssocFrom: (Color colorNamesDict)) explore. -" - "Filter values for those close in hue (cheap test) then use rgbDistance" - | closeInHue isClose close distance myHue | - closeInHue := OrderedCollection new. - myHue := self hue. - isClose := [ :assoc | | delta | - delta := ((assoc value hue) - myHue) abs. - (delta < 20) or: [ delta > 340 ] "hues within 20 degrees" - ]. - aColorDict associationsDo: [ :assoc | - (isClose value: assoc) ifTrue: [ closeInHue add: assoc ] - ]. - - close := nil. - distance := 1000. "big" - (closeInHue size > 0) - ifFalse: [ "fallback -- no color really close" - aColorDict associationsDo: [ :assoc | | dist | - dist := self rgbDistance: (assoc value). - (dist < distance) ifTrue: [distance := dist. close := assoc] - ] - ] - ifTrue: [ closeInHue do: [ :assoc | | dist | - dist := self rgbDistance: (assoc value). - (dist < distance) ifTrue: [distance := dist. close := assoc] - ] - ]. - - ^ close! ! -!Colour methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:51:07'! - closestColor - "Answer the closest matching color in the colorNames dictionary" - -" - (Color red lighter lighter) closestColor explore. -" - ^ self closestColorFrom: (Colour colorNamesDict)! ! -!Colour methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:51:11'! -closestColorAssociation - "Answer this color's closest name->color match." - -" - (Color blue lighter lighter) closestColorAssociation explore. -" - ^ self closestAssocFrom: (Colour colorNamesDict)! ! -!Colour methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:00'! - closestColorFrom: aColorDict - "Answer closest associated color" -" - ((Color lightBlue) closestColorFrom: (Color css2NamedColors)) explore.. -" - ^(self closestAssocFrom: aColorDict) value! ! -!Colour methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:51:15'! -closestColorName - "Answer the name symbol of the closest matching color in the colorNames dictionary" -" - (Color red lighter lighter) closestColor name. -" - - ^ self closestNameFrom: (Colour colorNamesDict)! ! -!Colour methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:00'! - closestNameFrom: aColorDict - "Answer closest associated color name" -" - ((Color lightBlue) closestNameFrom: (Color namedColors)) print. -" - ^(self closestAssocFrom: aColorDict) key! ! -!Colour methodsFor: 'other' stamp: 'jmv 6/18/2017 20:51:20'! - colorName - "Return this color's name, or nil if it has no name. Only returns a name if it exactly matches the named color." - - ^(Colour colorNamesDict keyAtValue: self ifAbsent: [nil]) -! ! -!Colour methodsFor: 'other' stamp: 'jmv 6/18/2017 20:10:00'! - name - "Return this color's name, or description if unnamed." - - ^ self printString -! ! -!Colour methodsFor: 'printing' stamp: 'jmv 6/18/2017 20:10:00'! - hexStringRGB - " - Color fromUser hexStringRGB - " - ^String streamContents: [ :strm | - (self red * 255) rounded printOn: strm base: 16 length: 2 padded: true. - (self green * 255) rounded printOn: strm base: 16 length: 2 padded: true. - (self blue * 255) rounded printOn: strm base: 16 length: 2 padded: true ]! ! -!Colour methodsFor: 'printing' stamp: 'jmv 6/18/2017 20:53:07'! - printOn: aStream - self colorName ifNotNil: [ :name | - ^ aStream - nextPutAll: 'Colour '; - nextPutAll: name]. - self storeOn: aStream. -! ! -!Colour methodsFor: 'printing' stamp: 'jmv 6/18/2017 20:10:00'! - printString - "Answer a String whose characters are a description of the receiver." - - ^ String streamContents: [ :stream | self printOn: stream ]! ! -!Colour methodsFor: 'printing' stamp: 'jmv 6/18/2017 20:10:00'! - storeArrayOn: aStream - - aStream nextPutAll: '#('. - self storeArrayValuesOn: aStream. - aStream nextPutAll: ') ' -! ! -!Colour methodsFor: 'printing' stamp: 'jmv 6/18/2017 20:10:00'! - storeArrayValuesOn: aStream - - - self red printOn: aStream fractionDigits: 3. - aStream space. - self green printOn: aStream fractionDigits: 3. - aStream space. - self blue printOn: aStream fractionDigits: 3 - -! ! -!Colour methodsFor: 'printing' stamp: 'jmv 6/18/2017 20:10:00'! - storeOn: aStream - - aStream - nextPut: $(; - nextPutAll: self class name; - nextPutAll: ' r: '. - self red printOn: aStream fractionDigits: 3. - aStream nextPutAll: ' g: '. - self green printOn: aStream fractionDigits: 3. - aStream nextPutAll: ' b: '. - self blue printOn: aStream fractionDigits: 3. - aStream nextPut: $)! ! -!Colour methodsFor: 'queries' stamp: 'jmv 6/18/2017 20:40:55'! - isBlack - "Return true if the receiver represents black" - (self at: 1) = 0.0 ifFalse: [ ^ false ]. - (self at: 2) = 0.0 ifFalse: [ ^ false ]. - (self at: 3) = 0.0 ifFalse: [ ^ false ]. - ^ true! ! -!Colour methodsFor: 'queries' stamp: 'jmv 6/18/2017 20:10:00'! -isOpaque - ^true! ! -!Colour methodsFor: 'queries' stamp: 'jmv 6/18/2017 20:10:00'! - isTransparent - - ^ false -! ! -!Colour methodsFor: 'queries' stamp: 'jmv 6/18/2017 20:40:46'! - isWhite - "Return true if the receiver represents white" - (self at: 1) = 1.0 ifFalse: [ ^ false ]. - (self at: 2) = 1.0 ifFalse: [ ^ false ]. - (self at: 3) = 1.0 ifFalse: [ ^ false ]. - ^ true! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isBlue - "Am I considered Blue?" - - ^self blue > (self green + 0.3) - and: [self blue > (self red + 0.3)] - and: [(self green - self red) abs < 0.4]! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isBlueGreen - "Am I considered BlueGreen ?" - - ^self green > self red - and: [self red < 0.3] - and: [(self green - self blue) abs < 0.1]! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isBright - "Am I considered a Bright color ?" - - ^self brightness > 0.6! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isBrown - "Am I considered Brown ?" - - ^self red >= self green - and: [self green > self blue] - and: [(self red - self green) < 0.5] - and: [(self green - self blue) < 0.3]! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isCyan - "Am I considered Cyan ?" - - ^self red < 0.05 - and: [(self green min: self blue) > 0.5] - and: [(self green - self blue) abs < 0.2]! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isDark - "Am I considered a Dark color ?" - - ^self brightness < 0.5! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isGray - "Am I considered Gray ?" - - ^(self red closeTo: self green) - and: [self blue closeTo: self green ]! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isGreen - "Am I considered Green ?" - - ^self green > (self blue + 0.3) - and: [self blue > (self red + 0.3)]! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isGrey - "Am I considered Grey ?" - - ^self isGray! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isLight - "Am I considered a Light color ?" - - ^self brightness > 0.6! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isMagenta - "Am I considered Magenta ?" - - ^self green < 0.05 - and: [(self red min: self blue) > 0.5] - and: [(self red - self blue) abs < 0.2]! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isOrange - "Am I considered Orange ?" - - ^self red > ((self green max: self blue) + 0.2) - and: [self green > (self blue + 0.2)]! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isPastel - "Am I considered Pastel ?" - - ^self saturation < 0.4! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isPink - "Am I considered Pink ?" - - ^self red > ((self green max: self blue) + 0.3) - and: [self blue > (self green + 0.2)]! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isRed - "Am I considered Red ?" - - ^self red > (self green + 0.4) - and: [self red > (self blue + 0.6)] - and: [(self green - self blue) abs < 0.4]! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isSaturated - "Am I considered to be a Saturated color ?" - - ^self saturation > 0.6! ! -!Colour methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:00'! - isYellow - "Am I considered Yellow ?" - - ^self blue < 0.05 - and: [(self red min: self green) > 0.5] - and: [(self red - self green) abs < 0.2]! ! -!Colour methodsFor: 'testing' stamp: 'jmv 6/18/2017 20:10:00'! - is: aSymbol - ^ aSymbol == #Color or: [ super is: aSymbol ]! ! -!Colour methodsFor: 'testing' stamp: 'jmv 6/18/2017 20:10:00'! - mightBeTranslucent - "For Colors, answer if actually translucent or not." - ^self isOpaque not! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:56:14'! - * aNumber - "Answer this color with its RGB multiplied by the given number. " - " - (Colour brown *2) display - " - ^ Colour new - setRed: (self red * aNumber min: 1.0 max: 0.0) - green: (self green * aNumber min: 1.0 max: 0.0) - blue: (self blue * aNumber min: 1.0 max: 0.0)! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:56:18'! - + aColor - "Answer this color mixed with the given color in an additive color space. " - " - (Colour blue + Colour green) display - " - ^ Colour new - setRed: (self red + aColor red min: 1.0 max: 0.0) - green: (self green + aColor green min: 1.0 max: 0.0) - blue: (self blue + aColor blue min: 1.0 max: 0.0)! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:56:22'! - - aColor - "Answer aColor is subtracted from the given color in an additive color space. " - " - (Color white - Color red) display - " - ^ Colour new - setRed: (self red - aColor red min: 1.0 max: 0.0) - green: (self green - aColor green min: 1.0 max: 0.0) - blue: (self blue - aColor blue min: 1.0 max: 0.0)! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:56:26'! - / aNumber - "Answer this color with its RGB divided by the given number. " - " - (Color red / 2) display - " - ^ Colour new - setRed: (self red / aNumber min: 1.0 max: 0.0) - green: (self green / aNumber min: 1.0 max: 0.0) - blue: (self blue / aNumber min: 1.0 max: 0.0)! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:50:50'! - adjustBrightness: brightness - "Adjust the relative brightness of this color. (lowest value is 0.005 so that hue information is not lost)" - - ^ Colour - h: self hue - s: self saturation - v: (self brightness + brightness min: 1.0 max: 0.005) - alpha: self alpha! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:50:53'! - adjustSaturation: saturation brightness: brightness - "Adjust the relative saturation and brightness of this color. (lowest value is 0.005 so that hue information is not lost)" - - ^ Colour - h: self hue - s: (self saturation + saturation min: 1.0 max: 0.005) - v: (self brightness + brightness min: 1.0 max: 0.005) - alpha: self alpha! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:10:41'! - alpha: alphaValue - "Return a new TranslucentColor with the given amount of opacity ('alpha')." - alphaValue = 1.0 ifFalse: [ - ^ TranslucentColour new - setRed: self red - green: self green - blue: self blue - alpha: alphaValue ]! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:50:57'! - alphaMixed: proportion with: aColor - "Answer this color mixed with the given color. The proportion, a number - between 0.0 and 1.0, determines what what fraction of the receiver to - use in the mix. For example, 0.9 would yield a color close to the - receiver. This method uses RGB interpolation; HSV interpolation can lead - to surprises. Mixes the alphas (for transparency) also." - - | frac1 frac2 | - frac1 _ proportion asFloat min: 1.0 max: 0.0. - frac2 _ 1.0 - frac1. - ^ Colour - r: self red * frac1 + (aColor red * frac2) - g: self green * frac1 + (aColor green * frac2) - b: self blue * frac1 + (aColor blue * frac2) - alpha: self alpha * frac1 + (aColor alpha * frac2)! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:10:00'! - atLeastAsLuminentAs: aFloat - - | revisedColor | - revisedColor _ self. - [revisedColor luminance < aFloat] whileTrue: [revisedColor _ revisedColor slightlyLighter]. - ^revisedColor -! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:10:00'! - atMostAsLuminentAs: aFloat - - | revisedColor | - revisedColor _ self. - [revisedColor luminance > aFloat] whileTrue: [revisedColor _ revisedColor slightlyDarker]. - ^revisedColor -! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:51:02'! - blacker - - ^ self alphaMixed: 0.8333 with: Colour black -! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:51:27'! - dansDarker - "Return a darker shade of the same color. - An attempt to do better than the current darker method. - (now obsolete, since darker has been changed to do this. -dew)" - ^ Colour h: self hue s: self saturation - v: (self brightness - 0.16 max: 0.0)! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:10:00'! - darker - "Answer a darker shade of this color." - - ^ self adjustBrightness: -0.08! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:10:00'! - duller - - ^ self adjustSaturation: -0.03 brightness: -0.2! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:10:00'! - lighter - "Answer a lighter shade of this color." - - ^ self adjustSaturation: -0.03 brightness: 0.08! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:51:59'! - mixed: proportion with: aColor - "Mix with another color and do not preserve transpareny. Only use this for extracting the RGB value and mixing it. All other callers should use instead: - aColor alphaMixed: proportion with: anotherColor - " - - | frac1 frac2 | - frac1 _ proportion asFloat min: 1.0 max: 0.0. - frac2 _ 1.0 - frac1. - ^ Colour - r: self red * frac1 + (aColor red * frac2) - g: self green * frac1 + (aColor green * frac2) - b: self blue * frac1 + (aColor blue * frac2)! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:52:03'! - muchDarker - - ^ self alphaMixed: 0.5 with: Colour black -! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:52:07'! - muchLighter - - ^ self alphaMixed: 0.233 with: Colour white -! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:52:12'! - negated - "Return an RGB inverted color" - ^Colour - r: 1.0 - self red - g: 1.0 - self green - b: 1.0 - self blue! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:37:53'! - orColorUnlike: theOther - "If this color is a lot like theOther, then return its complement, otherwide, return self" - - ^ (self diff: theOther) < 0.3 - ifTrue: [theOther negated] - ifFalse: [self]! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:10:00'! - paler - "Answer a paler shade of this color." - - ^ self adjustSaturation: -0.09 brightness: 0.09 -! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:52:16'! - quiteBlacker - - ^ self alphaMixed: 0.8 with: Colour black -! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:52:19'! - quiteWhiter - - ^ self alphaMixed: 0.6 with: Colour white! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:10:00'! - slightlyDarker - - ^ self adjustBrightness: -0.03 -! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:10:00'! - slightlyLighter - - ^ self adjustSaturation: -0.01 brightness: 0.03! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:52:24'! - slightlyWhiter - - ^ self alphaMixed: 0.85 with: Colour white -! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:10:00'! - twiceDarker - "Answer a significantly darker shade of this color." - - ^ self adjustSaturation: 0.076 brightness: -0.15! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:10:01'! - twiceLighter - "Answer a significantly lighter shade of this color." - - ^ self adjustSaturation: -0.06 brightness: 0.15! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:52:27'! -veryMuchDarker - - ^ self alphaMixed: 0.25 with: Colour black -! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:52:32'! - veryMuchLighter - - ^ self alphaMixed: 0.07 with: Colour white! ! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:02:05'! - whiter - - ^ self alphaMixed: 0.8333 with: Colour white -! ! -!Colour methodsFor: 'private' stamp: 'jmv 6/18/2017 20:10:01'! - attemptToMutateError - "A color is immutable. Once a color's red, green, and blue have been initialized, you cannot change them. Instead, create a new Color and use it." - - self error: 'Color objects are immutable once created' -! ! -!Colour methodsFor: 'private' stamp: 'jmv 6/18/2017 20:29:32'! - basicSetRed: r green: g blue: b - "Initialize this color's r, g, and b components to the given values in the range [0.0..1.0]." - - self - at: 1 put: r; - at: 2 put: g; - at: 3 put: b! ! -!Colour methodsFor: 'private' stamp: 'jmv 6/18/2017 20:15:44'! - setHue: hue chroma: chroma brightness: brightness - "Initialize this color to the given hue, chroma, and luma. See the comment in the instance creation method for details. - http://en.wikipedia.org/wiki/HSL_and_HSV - hue belongs in [0.0, 360.0) - chroma and luma belongs in [0.0, 1.0] - " - - | x hf i r1 g1 b1 m | - hf _ hue \\ 360. - i _ hf // 60. "integer part of hue" - x _ (hf \\ 60) / 60.0 . "fractional part of hue" - x _ x \\ 2 . - i \\ 2 = 1 ifTrue: [ x _ 1.0 - x ]. - x _ chroma * x. - - 0 = i ifTrue: [ r1 _ chroma. g1 _ x. b1 _ 0.0 ]. - 1 = i ifTrue: [ r1 _ x. g1 _ chroma. b1 _ 0.0 ]. - 2 = i ifTrue: [ r1 _ 0.0. g1 _ chroma. b1 _ x ]. - 3 = i ifTrue: [ r1 _ 0.0. g1 _ x. b1 _ chroma ]. - 4 = i ifTrue: [ r1 _ x. g1 _ 0.0. b1 _ chroma ]. - 5 = i ifTrue: [ r1 _ chroma. g1 _ 0.0. b1 _ x ]. - - m _ brightness - ((r1 max: g1) max: b1). - m < 0.0 - ifTrue: [ ^nil ]. "No color exists with required parameters" - r1 _ r1 + m. - r1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - g1 _ g1 + m. - g1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - b1 _ b1 + m. - b1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - self setRed: r1 green: g1 blue: b1! ! -!Colour methodsFor: 'private' stamp: 'jmv 6/18/2017 20:15:49'! - setHue: hue chroma: chroma luminance: luma - "Initialize this color to the given hue, chroma, and luma. See the comment in the instance creation method for details. - http://en.wikipedia.org/wiki/HSL_and_HSV - hue belongs in [0.0, 360.0) - chroma and luma belongs in [0.0, 1.0] - " - - | x hf i r1 g1 b1 m | - - hf _ hue \\ 360. - i _ hf // 60. "integer part of hue" - x _ (hf \\ 60) / 60.0 . "fractional part of hue" - x _ x \\ 2 . - i \\ 2 = 1 ifTrue: [ x _ 1.0 - x ]. - x _ chroma * x. - - 0 = i ifTrue: [ r1 _ chroma. g1 _ x. b1 _ 0.0 ]. - 1 = i ifTrue: [ r1 _ x. g1 _ chroma. b1 _ 0.0 ]. - 2 = i ifTrue: [ r1 _ 0.0. g1 _ chroma. b1 _ x ]. - 3 = i ifTrue: [ r1 _ 0.0. g1 _ x. b1 _ chroma ]. - 4 = i ifTrue: [ r1 _ x. g1 _ 0.0. b1 _ chroma ]. - 5 = i ifTrue: [ r1 _ chroma. g1 _ 0.0. b1 _ x ]. - - m _ luma - (0.299*r1) - (0.587*g1) - (0.114*b1). - m < 0.0 - ifTrue: [ ^nil ]. "No color exists with required parameters" - r1 _ r1 + m. - r1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - g1 _ g1 + m. - g1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - b1 _ b1 + m. - b1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - self setRed: r1 green: g1 blue: b1! ! -!Colour methodsFor: 'private' stamp: 'jmv 6/18/2017 20:16:07'! - setHue: hue saturation: saturation brightness: brightness - "Initialize this color to the given hue, saturation, and brightness. See the comment in the instance creation method for details." - - | s v hf i f p q t | - s _ saturation asFloat min: 1.0 max: 0.0. - v _ brightness asFloat min: 1.0 max: 0.0. - hf _ hue \\ 360. - i _ hf // 60. "integer part of hue" - f _ (hf \\ 60) / 60.0. "fractional part of hue" - - p _ (1.0 - s) * v. - q _ (1.0 - (s * f)) * v. - t _ (1.0 - (s * (1.0 - f))) * v. - - 0 = i ifTrue: [ ^ self setRed: v green: t blue: p ]. - 1 = i ifTrue: [ ^ self setRed: q green: v blue: p ]. - 2 = i ifTrue: [ ^ self setRed: p green: v blue: t ]. - 3 = i ifTrue: [ ^ self setRed: p green: q blue: v ]. - 4 = i ifTrue: [ ^ self setRed: t green: p blue: v ]. - 5 = i ifTrue: [ ^ self setRed: v green: p blue: q ]. - - self error: 'implementation error'! ! -!Colour methodsFor: 'private' stamp: 'jmv 6/18/2017 20:13:04'! - setRed: r green: g blue: b - - self basicSetRed: r green: g blue: b! ! -!Colour methodsFor: 'private' stamp: 'jmv 6/18/2017 20:29:48'! - setRed: r green: g blue: b range: range - "Initialize this color's r, g, and b components to the given values in the range [0..r]." - - self basicSetRed: r green: g blue: b. - self /= range! ! -!Colour methodsFor: 'as yet unclassified' stamp: 'jmv 6/18/2017 20:10:01'! - color - ^ self! ! -!Colour methodsFor: 'please remove' stamp: 'jmv 6/18/2017 21:26:21'! - floatRGB -"to be removed" - ^ self! ! -!Colour methodsFor: 'please remove' stamp: 'jmv 6/18/2017 21:26:07'! - setRed: r green: g blue: b colorSpace: aSymbol - ^ self setRed: r green: g blue: b! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:10:01'! - clipR: r g: g b: b - "Return a color with the given r, g, and b components in the range [0.0..1.0]. - Clip if necessary" - - ^ self - r: (r min: 1.0 max: 0.0) - g: (g min: 1.0 max: 0.0) - b: (b min: 1.0 max: 0.0)! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:10:01'! - colorFrom: parm - "Return an instantiated color from parm. If parm is already a color, return it, else return the result of my performing it if it's a symbol or, if it is a list, it can either be an array of three numbers, which will be interpreted as RGB values, or a list of symbols, the first of which is sent to me and then the others of which are in turn sent to the prior result, thus allowing entries of the form #(blue darker). Else just return the thing" - - | aColor firstParm | - (parm is: #Color) ifTrue: [ ^ parm ]. - parm isSymbol ifTrue: [ ^ self perform: parm ]. - (parm isSequenceableCollection and: [ parm size > 0 ]) - ifTrue: [ - firstParm _ parm first. - firstParm isNumber ifTrue: [ - ^ self fromRgbTriplet: parm]. - aColor _ self colorFrom: firstParm. - parm withIndexDo: [ :sym :ind | - ind > 1 ifTrue: [ - aColor _ aColor perform: sym ]]. - ^ aColor]. - ^ parm - -" -Color colorFrom: #(blue darker) -Color colorFrom: Color blue darker -Color colorFrom: #blue -Color colorFrom: #(0.0 0.0 1.0) -"! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 21:02:20'! - colorFromPixelValue: p depth: d - "Convert a pixel value for the given display depth into a color." - "Details: For depths of 8 or less, the pixel value is simply looked up in a table. For greater depths, the color components are extracted and converted into a color." - "Warning: In BitBlt, a pixel with pixelValue = 0 is transparent. - Squeak usually assumes that r=g=b=0 => transparent. But this is false if we have alpha (opacity). - A color with r=g=b=0 and opacity = 255 is BLACK, not TRANSPARENT. - Squeak also answers darkest possible blue when asked for black. Again, this is not needed in 32 bits (with alpha). It is also not really needed for 16 bits as we have an extra, unused bit: 16r8000 is not zero, but rgb=0, and hence, black. - The real rule is that pixelValue=0 means transparent. - And that darkest blue must be used instead of black, but only for depths >8 and < 16 (no indexed colors, no alpha) - This method is updated to reflect that." - - | r g b alpha | - - d = 1 ifTrue: [^ self indexedColors at: (p bitAnd: 16r01) + 1]. - - "For the rest of the depths, pixelValue = 0 means transparent, and darkest blue is considered to be black." - p = 0 ifTrue: [ ^Colour transparent ]. - - d = 8 ifTrue: [^ self indexedColors at: (p bitAnd: 16rFF) + 1]. - d = 4 ifTrue: [^ self indexedColors at: (p bitAnd: 16r0F) + 1]. - d = 2 ifTrue: [^ self indexedColors at: (p bitAnd: 16r03) + 1]. - - d = 32 ifTrue: [ - "eight bits per component; 8 bits of alpha" - alpha _ p bitShift: -24. - alpha = 0 ifTrue: [ ^Colour transparent ]. - r _ (p bitShift: -16) bitAnd: 16rFF. - g _ (p bitShift: -8) bitAnd: 16rFF. - b _ p bitAnd: 16rFF. - ^alpha < 255 - ifTrue: [ (Colour r: r g: g b: b range: 255) alpha: alpha asFloat / 255.0 ] - ifFalse: [ Colour r: r g: g b: b range: 255 ]]. - - d = 16 ifTrue: [ - "five bits per component. The most significant bit, unused, allows having real black, without p being zero" - r _ (p bitShift: -10) bitAnd: 16r1F. - g _ (p bitShift: -5) bitAnd: 16r1F. - b _ p bitAnd: 16r1F. - ^ Colour r: r g: g b: b range: 31]. - - d = 15 ifTrue: [ - "five bits per component" - r _ (p bitShift: -10) bitAnd: 16r1F. - g _ (p bitShift: -5) bitAnd: 16r1F. - b _ p bitAnd: 16r1F. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Colour black ]. - ^ Colour r: r g: g b: b range: 31]. - - d = 12 ifTrue: [ - "four bits per component" - r _ (p bitShift: -8) bitAnd: 16rF. - g _ (p bitShift: -4) bitAnd: 16rF. - b _ p bitAnd: 16rF. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Colour black ]. - ^ Colour r: r g: g b: b range: 15]. - - d = 9 ifTrue: [ - "three bits per component" - r _ (p bitShift: -6) bitAnd: 16r7. - g _ (p bitShift: -3) bitAnd: 16r7. - b _ p bitAnd: 16r7. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Colour black ]. - ^ Colour r: r g: g b: b range: 7]. - - self error: 'unknown pixel depth: ', d printString! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:10:01'! - fromArray: colorDef - - | answer | - colorDef size = 0 ifTrue: [^self transparent]. - colorDef size between: 3 and: 4 :: ifFalse: [self error: 'Undefined color definition']. - answer _ self r: (colorDef at: 1) g: (colorDef at: 2) b: (colorDef at: 3). - ^colorDef size = 3 - ifTrue: [answer] - ifFalse: [answer alpha: (colorDef at: 4)]! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:10:01'! - fromRgbTriplet: list - ^ self r: list first g: list second b: list last! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:10:01'! - fromString: aString - "For HTML color spec: #FFCCAA. Also support named colors. - See http://www.w3schools.com/cssref/css_colors_legal.asp" - " - Color fromString: '#FFCCAA'. - Color fromString: 'white'. - Color fromString: 'orange' - Color fromString: 'rgb(255,0,98)' - " - (aString size = 7 and: [ aString first = $# ]) ifTrue: [ - | aColorHexU red green blue | - aColorHexU _ aString asUppercase. - red _ ('16r', (aColorHexU copyFrom: 2 to: 3)) asNumber/255. - green _ ('16r', (aColorHexU copyFrom: 4 to: 5)) asNumber/255. - blue _ ('16r', (aColorHexU copyFrom: 6 to: 7)) asNumber/255. - ^ self r: red g: green b: blue]. - - (aString beginsWith: 'rgb') - ifTrue: [|values r g b| - values := (aString allButFirst: 4) allButLast findTokens: ','. - r := (values first includes: $%) - ifTrue: [(values first asNumber min: 100 max: 0) / 100.0] - ifFalse: [(values first asInteger min: 255 max: 0) / 255.0]. - g := (values second includes: $%) - ifTrue: [(values second asNumber min: 100 max: 0) / 100.0] - ifFalse: [(values second asInteger min: 255 max: 0) / 255.0]. - b := (values third includes: $%) - ifTrue: [(values third asNumber min: 100 max: 0) / 100.0] - ifFalse: [(values third asInteger min: 255 max: 0) / 255.0]. - ^self r: r g: g b: b]. - - ^self exactColorNamed: aString! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:29'! - gray: brightness - "Return a gray shade with the given brightness in the range [0.0..1.0]." - - ^ self new - setRed: brightness - green: brightness - blue: brightness! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:31'! - h: hue s: saturation v: brightness - "Create a color with the given hue, saturation, and brightness. Hue is given as the angle in degrees of the color on the color circle where red is zero degrees. Saturation and brightness are numbers in [0.0..1.0] where larger values are more saturated or brighter colors. For example, (Color h: 0 s: 1 v: 1) is pure red." - "Note: By convention, brightness is abbreviated 'v' to to avoid confusion with blue." - - ^ self new setHue: hue saturation: saturation brightness: brightness! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:10:01'! - h: h s: s v: v alpha: alpha - - ^ (self h: h s: s v: v) alpha: alpha! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:34'! - hue: hue chroma: chroma brightness: brightness - ^self new setHue: hue chroma: chroma brightness: brightness! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:37'! - hue: hue chroma: chroma luminance: luma - ^self new setHue: hue chroma: chroma luminance: luma! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:39'! - hue: hue saturation: saturation brightness: brightness - "Create a color with the given hue, saturation, and brightness. Hue is given as the angle in degrees of the color on the color circle where red is zero degrees. Saturation and brightness are numbers in [0.0..1.0] where larger values are more saturated or brighter colors. For example, (Color h: 0 s: 1 v: 1) is pure red." - "Note: By convention, brightness is abbreviated 'v' to to avoid confusion with blue." - - ^ self new setHue: hue saturation: saturation brightness: brightness! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:54:20'! - new - ^ self new: 3! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:41'! - r: r g: g b: b - "Return a color with the given r, g, and b components in the range [0.0..1.0]." - - ^ self new - setRed: r - green: g - blue: b! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:10:01'! -r: r g: g b: b alpha: alpha - - ^ (self r: r g: g b: b) alpha: alpha! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:43'! - r: r g: g b: b range: range - "Return a color with the given r, g, and b components specified as integers in the range [0..r]. This avoids the floating point arithmetic in the red:green:blue: message and is thus a bit faster for certain applications (such as computing a sequence of colors for a palette)." - - ^ self new setRed: r green: g blue: b range: range! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:10:01'! - random - "Return a random color that isn't too dark or under-saturated. - Display fill: (10@10 extent: 200@200) fillColor: Color random - " - - ^ Random withDefaultDo: [ :random | - self random: random ]! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:10:01'! - random2 - "Return a random color with a distribution that spans over all possible colors. - Display fill: (10@10 extent: 200@200) fillColor: Color random2 - " - - ^ Random withDefaultDo: [ :random | - self random2: random ]! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:46'! - random2: aRandom - "Return a random color with a distribution that spans over all possible colors." - - ^ self new - setRed: aRandom next - green: aRandom next - blue: aRandom next! ! -!Colour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:48'! - random: aRandom - "Return a random color that isn't too dark or under-saturated." - - ^ self new - setHue: (360.0 * aRandom next) - saturation: (0.3 + (aRandom next * 0.7)) - brightness: (0.4 + (aRandom next * 0.6))! ! -!Colour class methodsFor: 'class initialization' stamp: 'jmv 6/18/2017 20:10:01'! - initializeGrayToIndexMap - "Build an array of gray values available in the 8-bit colormap. This array is indexed by a gray level between black (1) and white (256) and returns the pixel value for the corresponding gray level." - "Note: This method must be called after initializeIndexedColors, since it uses IndexedColors." - " - Color initializeGrayToIndexMap - " - - | grayLevels grayIndices c distToClosest dist indexOfClosest indexedColors | - "record the level and index of each gray in the 8-bit color table" - grayLevels _ OrderedCollection new. - grayIndices _ OrderedCollection new. - indexedColors _ self indexedColors. - "Note: skip the first entry, which is reserved for transparent" - 2 to: indexedColors size do: [:i | - c _ indexedColors at: i. - c saturation = 0.0 ifTrue: [ "c is a gray" - grayLevels add: (c green * 255) rounded. "0 to 255; R, G, and B are the same" - grayIndices add: i - 1]]. "pixel values are zero-based" - grayLevels _ grayLevels asArray. - grayIndices _ grayIndices asArray. - - "for each gray level in [0..255], select the closest match" - GrayToIndexMap _ ByteArray new: 256. - 0 to: 255 do: [ :level | - distToClosest _ 10000. "greater than distance to any real gray" - 1 to: grayLevels size do: [:i | - dist _ (level - (grayLevels at: i)) abs. - dist < distToClosest ifTrue: [ - distToClosest _ dist. - indexOfClosest _ grayIndices at: i]]. - GrayToIndexMap at: (level + 1) put: indexOfClosest]! ! -!Colour class methodsFor: 'class initialization' stamp: 'jmv 6/18/2017 20:59:48'! - initializeIndexedColors - "Build an array of colors corresponding to the fixed colormap used - for display depths of 1, 2, 4, or 8 bits." - "Color initializeIndexedColors" - - | a index grayVal | - a _ Array new: 256. - - "1-bit colors (monochrome)" - a at: 1 put: (Colour r: 1.0 g: 1.0 b: 1.0). "white or transparent" - a at: 2 put: (Colour r: 0.0 g: 0.0 b: 0.0). "black" - - "additional colors for 2-bit color" - a at: 3 put: (Colour r: 1.0 g: 1.0 b: 1.0). "opaque white" - a at: 4 put: (Colour r: 0.5 g: 0.5 b: 0.5). "1/2 gray" - - "additional colors for 4-bit color" - a at: 5 put: (Colour r: 1.0 g: 0.0 b: 0.0). "red" - a at: 6 put: (Colour r: 0.0 g: 1.0 b: 0.0). "green" - a at: 7 put: (Colour r: 0.0 g: 0.0 b: 1.0). "blue" - a at: 8 put: (Colour r: 0.0 g: 1.0 b: 1.0). "cyan" - a at: 9 put: (Colour r: 1.0 g: 1.0 b: 0.0). "yellow" - a at: 10 put: (Colour r: 1.0 g: 0.0 b: 1.0). "magenta" - - a at: 11 put: (Colour r: 0.125 g: 0.125 b: 0.125). "1/8 gray" - a at: 12 put: (Colour r: 0.25 g: 0.25 b: 0.25). "2/8 gray" - a at: 13 put: (Colour r: 0.375 g: 0.375 b: 0.375). "3/8 gray" - a at: 14 put: (Colour r: 0.625 g: 0.625 b: 0.625). "5/8 gray" - a at: 15 put: (Colour r: 0.75 g: 0.75 b: 0.75). "6/8 gray" - a at: 16 put: (Colour r: 0.875 g: 0.875 b: 0.875). "7/8 gray" - - "additional colors for 8-bit color" - "24 more shades of gray (1/32 increments but not repeating 1/8 increments)" - index _ 17. - 1 to: 31 do: [:v | - (v \\ 4) = 0 ifFalse: [ - grayVal _ v / 32.0. - a at: index put: (Colour r: grayVal g: grayVal b: grayVal). - index _ index + 1]]. - - "The remainder of color table defines a color cube with six steps - for each primary color. Note that the corners of this cube repeat - previous colors, but this simplifies the mapping between RGB colors - and color map indices. This color cube spans indices 40 through 255 - (indices 41-256 in this 1-based array)." - 0 to: 5 do: [:r | - 0 to: 5 do: [:g | - 0 to: 5 do: [:b | - index _ 41 + ((36 * r) + (6 * b) + g). - index > 256 ifTrue: [ - self error: 'index out of range in color table compuation']. - a at: index put: (Colour r: r g: g b: b range: 5)]]]. - - IndexedColors _ a. -! ! -!Colour class methodsFor: 'examples' stamp: 'jmv 6/18/2017 20:58:14'! - colorRampForDepth: depth extent: aPoint - "Returns a form of the given size showing R, G, B, and gray ramps for the given depth. Useful for testing color conversions between different depths." - "(Color colorRampForDepth: Display depth extent: 256@80) display" - "(Color colorRampForDepth: 32 extent: 256@80) displayOn: Display at: 0@0 rule: Form paint" - - | f dx dy r | - f _ Form extent: aPoint depth: depth. - dx _ aPoint x // 256. - dy _ aPoint y // 4. - 0 to: 255 do: [:i | - r _ (dx * i)@0 extent: dx@dy. - f fill: r fillColor: (Colour r: i g: 0 b: 0 range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Colour r: 0 g: i b: 0 range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Colour r: 0 g: 0 b: i range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Colour r: i g: i b: i range: 255)]. - ^ f -! ! -!Colour class methodsFor: 'examples' stamp: 'jmv 6/18/2017 21:29:30'! - experimentsTowarsANewColorPalette -" -self experimentsTowarsANewColorPalette -" -| selectedHue selectedSaturation selectedV selectedColor h s v color width height selectedChroma selectedLuminance | -width _ 300. -height _ 120. -selectedColor _ Colour random. -selectedHue _ selectedColor hue. -selectedSaturation _ selectedColor saturation. -selectedChroma _ selectedColor chroma. -selectedV _ selectedColor brightness. -selectedLuminance _ selectedColor luminance. -Display getCanvas fillRectangle: (0@0 extent: height@height) color: selectedColor. -0 to: height do: [ :y | - v _ 1.0 - (y / height). - 0 to: height do: [ :x | - s _ x / height. - color _ Colour new setHue: selectedHue saturation: s brightness: v. - Display colorAt: x@(y+height) put: color - ]. - DisplayScreen screenUpdateRequired: nil -]. -0 to: height do: [ :y | | c | - v _ 1.0 - (y / height). - s _ 1.0 - (y / height). - c _ s. - 0 to: width do: [ :x | - h _ x / width * 360. - - color _ Colour new setHue: h chroma: c luminance: selectedLuminance. -" color _ Colour new setHue: h chroma: c brightness: selectedV." - color ifNil: [ color _ Colour black ]. -" color _ Colour new setHue: h saturation: s brightness: selectedV." - Display colorAt: x+height@y put: color. - - color _ Colour new setHue: h chroma: selectedChroma luminance: v. -" color _ Colour new setHue: h chroma: selectedChroma brightness: v." - color ifNil: [ color _ Colour black ]. -" color _ Colour new setHue: h saturation: selectedSaturation brightness: v." - Display colorAt: x+height@(y+height) put: color. - - ]. - DisplayScreen screenUpdateRequired: nil -].! ! -!Colour class methodsFor: 'examples' stamp: 'jmv 6/18/2017 20:10:01'! - hotColdShades: thisMany - "An array of thisMany colors showing temperature from blue to red to white hot. (Later improve this by swinging in hue.) " - "Color showColors: (Color hotColdShades: 25)" - - | n s1 s2 s3 s4 s5 | - thisMany < 5 ifTrue: [^ self error: 'must be at least 5 shades']. - n _ thisMany // 5. - s1 _ self white mix: self yellow shades: (thisMany - (n*4)). - s2 _ self yellow mix: self red shades: n+1. - s2 _ s2 copyFrom: 2 to: n+1. - s3 _ self red mix: self green darker shades: n+1. - s3 _ s3 copyFrom: 2 to: n+1. - s4 _ self green darker mix: self blue shades: n+1. - s4 _ s4 copyFrom: 2 to: n+1. - s5 _ self blue mix: self black shades: n+1. - s5 _ s5 copyFrom: 2 to: n+1. - ^ s1, s2, s3, s4, s5 -! ! -!Colour class methodsFor: 'examples' stamp: 'jmv 6/18/2017 20:59:58'! - showColorCube - "Show a 12x12x12 color cube." - "Color showColorCube" - - 0 to: 11 do: [:r | - 0 to: 11 do: [:g | - 0 to: 11 do: [:b | - Display fill: (((r*60) + (b*5)) @ (g*5) extent: 5@5) - fillColor: (Colour r: r g: g b: b range: 11)]]]. -! ! -!Colour class methodsFor: 'examples' stamp: 'jmv 6/18/2017 20:10:01'! - showColors: colorList - "Display the given collection of colors across the top of the Display." - - | w r | - w _ Display width // colorList size. - r _ 0@0 extent: w@((w min: 30) max: 10). - colorList do: [:c | - Display fill: r fillColor: c. - r _ r translatedBy: w@0]. -! ! -!Colour class methodsFor: 'examples' stamp: 'jmv 6/18/2017 21:00:03'! - showHSVPalettes - "Shows a palette of hues, varying the saturation and brightness for each one. Best results are with depths 16 and 32." - "Color showHSVPalettes" - - | left top c | - left _ top _ 0. - 0 to: 179 by: 15 do: [:h | - 0 to: 10 do: [:s | - left _ (h * 4) + (s * 4). - 0 to: 10 do: [:v | - c _ Colour h: h s: s asFloat / 10.0 v: v asFloat / 10.0. - top _ (v * 4). - Display fill: (left@top extent: 4@4) fillColor: c. - - c _ Colour h: h + 180 s: s asFloat / 10.0 v: v asFloat / 10.0. - top _ (v * 4) + 50. - Display fill: (left@top extent: 4@4) fillColor: c]]]. -! ! -!Colour class methodsFor: 'examples' stamp: 'jmv 6/18/2017 20:10:01'! - showHuesInteractively - "Shows a palette of hues at a (saturation, brightness) point determined by the mouse position. Click the mouse button to exit and return the selected (saturation, brightness) point." - "Color showHuesInteractively" - - | p s v | - [Sensor isAnyButtonPressed] whileFalse: [ - p _ Sensor mousePoint. - s _ p x asFloat / 300.0. - v _ p y asFloat / 300.0. - self showColors: (self wheel: 12 saturation: s brightness: v)]. - ^ (s min: 1.0) @ (v min: 1.0)! ! -!Colour class methodsFor: 'examples' stamp: 'jmv 6/18/2017 21:01:15'! - wheel: thisMany - "Return a collection of thisMany colors evenly spaced around the color wheel." - "Color showColors: (Color wheel: 12)" - - ^ Colour wheel: thisMany saturation: 0.9 brightness: 0.7 -! ! -!Colour class methodsFor: 'examples' stamp: 'jmv 6/18/2017 21:01:20'! - wheel: thisMany saturation: s brightness: v - "Return a collection of thisMany colors evenly spaced around the color wheel, all of the given saturation and brightness." - "Color showColors: (Color wheel: 12 saturation: 0.4 brightness: 1.0)" - "Color showColors: (Color wheel: 12 saturation: 0.8 brightness: 0.5)" - - ^ (Colour h: 0.0 s: s v: v) wheel: thisMany -! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - aqua - - ^ self colorNamesDict at: #aqua! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - beige - - ^ self colorNamesDict at: #beige! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - black - - ^ self colorNamesDict at: #black! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - blue - - ^ self colorNamesDict at: #blue! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - brightGreen - - ^ self colorNamesDict at: #brightGreen! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - brown - - ^ self colorNamesDict at: #brown! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - cyan - - ^ self colorNamesDict at: #cyan! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - darkBlue - - ^ self colorNamesDict at: #darkBlue! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - darkGray - - ^ self colorNamesDict at: #darkGray! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - darkGreen - - ^ self colorNamesDict at: #darkGreen! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - darkPink - - ^ self colorNamesDict at: #darkPink! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - darkPurple - - ^ self colorNamesDict at: #darkPurple! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! -forestGreen - - ^ self colorNamesDict at: #forestGreen! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - gray - - ^ self colorNamesDict at: #gray! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - green - - ^ self colorNamesDict at: #green! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - grey - - ^ self colorNamesDict at: #grey! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - hotPink - - ^ self colorNamesDict at: #hotPink! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - indigo - - ^ self colorNamesDict at: #indigo! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lavender - - ^ self colorNamesDict at: #lavender! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lightBlue - - ^ self colorNamesDict at: #lightBlue! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lightBrown - - ^ self colorNamesDict at: #lightBrown! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! -lightCyan - - ^ self colorNamesDict at: #lightCyan! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lightGray - - ^ self colorNamesDict at: #lightGray! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lightGreen - - ^ self colorNamesDict at: #lightGreen! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! -lightMagenta - - ^ self colorNamesDict at: #lightMagenta! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lightOrange - - ^ self colorNamesDict at: #lightOrange! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lightPink - - ^ self colorNamesDict at: #lightPink! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lightPurple - - ^ self colorNamesDict at: #lightPurple! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lightRed - - ^ self colorNamesDict at: #lightRed! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lightYellow - - ^ self colorNamesDict at: #lightYellow! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lilac - - ^ self colorNamesDict at: #lilac! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - lime - - ^ self colorNamesDict at: #lime! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - limeGreen - - ^ self colorNamesDict at: #limeGreen! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - magenta - - ^ self colorNamesDict at: #magenta! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - maroon - - ^ self colorNamesDict at: #maroon! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - mauve - - ^ self colorNamesDict at: #mauve! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - mustard - - ^ self colorNamesDict at: #mustard! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - navyBlue - - ^ self colorNamesDict at: #navyBlue! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - olive - - ^ self colorNamesDict at: #olive! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - oliveGreen - - ^ self colorNamesDict at: #oliveGreen! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! -orange - - ^ self colorNamesDict at: #orange! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - paleGreen - - ^ self colorNamesDict at: #paleGreen! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - peach - - ^ self colorNamesDict at: #peach! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - periwinkle - - ^ self colorNamesDict at: #periwinkle! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! -pink - - ^ self colorNamesDict at: #pink! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - purple - - ^ self colorNamesDict at: #purple! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - red - - ^ self colorNamesDict at: #red! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - royalBlue - - ^ self colorNamesDict at: #royalBlue! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - salmon - - ^ self colorNamesDict at: #salmon! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - seaGreen - - ^ self colorNamesDict at: #seaGreen! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - skyBlue - - ^ self colorNamesDict at: #skyBlue! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - tan - - ^ self colorNamesDict at: #tan! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - teal - - ^ self colorNamesDict at: #teal! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - transparent - - ^ self colorNamesDict at: #transparent! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - turquoise - - ^ self colorNamesDict at: #turquoise! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - veryDarkGray - - ^ self colorNamesDict at: #veryDarkGray! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - veryLightGray - - ^ self colorNamesDict at: #veryLightGray! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - veryVeryDarkGray - - ^ self colorNamesDict at: #veryVeryDarkGray! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - veryVeryLightGray - - ^ self colorNamesDict at: #veryVeryLightGray! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - violet - - ^ self colorNamesDict at: #violet! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - white - - ^ self colorNamesDict at: #white! ! -!Colour class methodsFor: 'named colors' stamp: 'jmv 6/18/2017 20:10:01'! - yellow - - ^ self colorNamesDict at: #yellow! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:10:01'! - cachedColormapForGrayFrom: sourceDepth - "Return a cached colormap for mapping from the given depth to the 8bpp grays. Always return a real colormap, not nil; this allows the client to get an identity colormap that can then be copied and modified to do color transformations." - "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" - "Note: The colormap cache may be cleared by evaluating 'Color shutDown'." - "Note: The color maps for sourceDepth=16 and for sourceDepth=32 are the same" - - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | srcIndex map | - ToGrayColormaps ifNil: [ - ToGrayColormaps _ Array new: 5]. - - srcIndex _ sourceDepth highBit min: 5. - - (ToGrayColormaps at: srcIndex) ifNotNil: [ :m | ^ m ]. - - map _ self computeColormapForGray8bppFrom: sourceDepth. - ToGrayColormaps at: srcIndex put: map. - ^ map! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:10:01'! - cachedColormapFrom: sourceDepth to: destDepth - "Return a cached colormap for mapping between the given depths. Always return a real colormap, not nil; this allows the client to get an identity colormap that can then be copied and modified to do color transformations." - "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" - "Note: The colormap cache may be cleared by evaluating 'Color shutDown'." - "Note: The color maps for sourceDepth=16 and for sourceDepth=32 are the same" - - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | srcIndex dstIndex map | - CachedColormaps - ifNil: [CachedColormaps _ (1 to: 5) collect: [:i | Array new: 6]]. - - srcIndex _ sourceDepth highBit min: 5. - dstIndex _ destDepth highBit. - - ((CachedColormaps at: srcIndex) at: dstIndex) ifNotNil: [ :m | ^ m ]. - - map _ self computeColormapFrom: sourceDepth to: destDepth. - (CachedColormaps at: srcIndex) at: dstIndex put: map. - ^ map! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:10:01'! - cachedColormapFromGrayTo: destDepth - "Return a cached colormap for mapping from 8bpp grays to the given depth. Always return a real colormap, not nil; this allows the client to get an identity colormap that can then be copied and modified to do color transformations." - "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" - "Note: The colormap cache may be cleared by evaluating 'Color shutDown'." - "Note: The color maps for sourceDepth=16 and for sourceDepth=32 are the same" - - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | dstIndex map | - FromGrayColormaps - ifNil: [FromGrayColormaps _ Array new: 6 ]. - - dstIndex _ destDepth highBit. - - (FromGrayColormaps at: dstIndex) ifNotNil: [ :m | ^ m ]. - - map _ self computeColormapFromGray8bppForDepth: destDepth. - FromGrayColormaps at: dstIndex put: map. - ^ map! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:57:57'! - colorMapIfNeededFrom: sourceDepth to: destDepth - "Return a colormap for mapping between the given depths, or nil if no colormap is needed." - "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" - - sourceDepth = destDepth ifTrue: [^ nil]. "not needed if depths are the same" - - (sourceDepth >= 16) & (destDepth >= 16) ifTrue: [ - "mapping is done in BitBlt by zero-filling or truncating each color component" - ^ nil]. - - ^ Colour cachedColormapFrom: sourceDepth to: destDepth -! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:10:01'! - computeColorConvertingMap: targetColor from: sourceDepth to: destDepth keepSubPixelAA: keepSubPix - "Note: The color converting map for sourceDepth=16 and for sourceDepth=32 are the same" - sourceDepth < 16 ifTrue: [ - "source is 1-, 2-, 4-, or 8-bit indexed color. - Assumed not to include subpixelAA" - ^ self computeIndexedColorConvertingMap: targetColor from: sourceDepth to: destDepth - ] ifFalse: [ - "source is 16-bit or 32-bit RGB. - Might include subpixelAA" - ^ self computeRGBColorConvertingMap: targetColor to: destDepth keepSubPixelAA: keepSubPix - ]! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:10:01'! - computeColormapForGray8bppFrom: sourceDepth - "Compute a colorMap for translatingfrom the given depth to the 8bpp grays" - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | map | - sourceDepth < 16 ifTrue: [ - "source is 1-, 2-, 4-, or 8-bit indexed color" - map _ (self indexedColors copyFrom: 1 to: (1 bitShift: sourceDepth)) - collect: [ :c | (c luminance * 255) rounded]. - map _ map as: Bitmap. - ^ map - ] - ifFalse: [ - ^ self computeRGBColormapForGray8 ]! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:10:01'! - computeColormapFrom: sourceDepth to: destDepth - "Compute a colorMap for translating between the given depths. A colormap is a Bitmap whose entries contain the pixel values for the destination depth. Typical clients use cachedColormapFrom:to: instead." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | map bitsPerColor | - sourceDepth < 16 ifTrue: [ - "source is 1-, 2-, 4-, or 8-bit indexed color" - map _ (self indexedColors copyFrom: 1 to: (1 bitShift: sourceDepth)) - collect: [:c | c pixelValueForDepth: destDepth]. - map _ map as: Bitmap. - ] ifFalse: [ - "source is 16-bit or 32-bit RGB" - destDepth > 8 - ifTrue: [bitsPerColor _ 5] "retain maximum color resolution" - ifFalse: [bitsPerColor _ 4]. - map _ self computeRGBColormapFor: destDepth bitsPerColor: bitsPerColor]. - - "Note: zero is transparent except when source depth is one-bit deep" - sourceDepth > 1 ifTrue: [map at: 1 put: 0]. - ^ map -! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:58:29'! - computeColormapFromGray8bppForDepth: destDepth - "Return a colormap for displaying a GrayForm at the given depth" - - | newMap | - newMap _ Bitmap new: 256. - 1 to: 256 do: [ :i | - newMap - at: i - put: ((Colour gray: (i-1) asFloat / 255.0) pixelValueForDepth: destDepth)]. - ^ newMap! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:58:33'! - computeIndexedColorConvertingMap: targetColor from: sourceDepth to: destDepth - | map | - - map _ (self indexedColors copyFrom: 1 to: (1 bitShift: sourceDepth)) collect: [ :cc | | f c | - f _ 1.0 - (cc red + cc green + cc blue / 3.0 ). - c _ targetColor - ifNotNil: [ - destDepth = 32 - ifTrue: [ targetColor * f alpha: f] - ifFalse: [ targetColor alphaMixed: f*1.5 with: Colour white ]] - ifNil: [ cc ]. - destDepth = 32 - ifTrue: [ c pixelValueForDepth: destDepth] - ifFalse: [ - f = 0.0 - ifTrue: [ 0 ] - ifFalse: [ c pixelValueForDepth: destDepth ]]]. - map _ map as: Bitmap. - ^map! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:58:41'! - computeRGBColorConvertingMap: targetColor to: destDepth keepSubPixelAA: keepSubPix - "Builds a colormap intended to convert from subpixelAA black values to targetColor values. - keepSubPix - ifTrue: [ Answer colors that also include subpixelAA ] - ifFalse: [ - Take fullpixel luminance level. Apply it to targetColor. - I.e. answer colors with NO subpixelAA ]" - - | mask map c bitsPerColor r g b f v | - - destDepth > 8 - ifTrue: [bitsPerColor _ 5] "retain maximum color resolution" - ifFalse: [bitsPerColor _ 4]. - "Usually a bit less is enough, but make it configurable" - bitsPerColor _ bitsPerColor min: Preferences aaFontsColormapDepth. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - r _ (i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask. - g _ (i bitShift: 0 - bitsPerColor) bitAnd: mask. - b _ (i bitShift: 0) bitAnd: mask. - f _ 1.0 - (r + g + b / 3.0 / mask). - c _ targetColor - ifNotNil: [ - (keepSubPix and: [destDepth > 8]) ifTrue: [ - Colour - r: 1.0 - (r asFloat/mask) * targetColor red - g: 1.0 - (g asFloat/mask) * targetColor green - b: 1.0 - (b asFloat/mask) * targetColor blue - alpha: f * targetColor alpha "alpha will be ignored below, in #pixelValueForDepth: if destDepth ~= 32" ] - ifFalse: [ - destDepth = 32 - ifTrue: [ targetColor * f alpha: f * targetColor alpha ] - ifFalse: [ targetColor alphaMixed: f*1.5 with: Colour white ]]] - ifNil: [ Colour r: r g: g b: b range: mask]. "This is currently used only to keep some SubPixelAA on destDepth = 8, using a single pass of rule 25" - v _ destDepth = 32 - ifTrue: [ c pixelValueForDepth: destDepth] - ifFalse: [ - f < 0.1 - ifTrue: [ 0 ] - ifFalse: [ c pixelValueForDepth: destDepth ]]. - map at: i + 1 put: v ]. - ^ map! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:58:48'! - computeRGBColormapFor: destDepth bitsPerColor: bitsPerColor - "Compute a colorMap for translating from 16-bit or 32-bit RGB color to the given depth, using the given number of of bits per color component." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | mask map c | - (#(3 4 5) includes: bitsPerColor) - ifFalse: [self error: 'BitBlt only supports 3, 4, or 5 bits per color component']. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - c _ Colour - r: ((i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask) - g: ((i bitShift: 0 - bitsPerColor) bitAnd: mask) - b: ((i bitShift: 0) bitAnd: mask) - range: mask. - map at: i + 1 put: (c pixelValueForDepth: destDepth)]. - - map at: 1 put: (Colour transparent pixelWordForDepth: destDepth). "zero always transparent" - ^ map -! ! -!Colour class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 20:58:56'! - computeRGBColormapForGray8 - "Compute a colorMap for translating from 16-bit or 32-bit RGB color to 8bpp grays, using the default number of of bits per color component." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | bitsPerColor mask map c | - bitsPerColor _ 5. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - c _ Colour - r: ((i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask) - g: ((i bitShift: 0 - bitsPerColor) bitAnd: mask) - b: ((i bitShift: 0) bitAnd: mask) - range: mask. - map at: i + 1 put: (c luminance * 255) rounded]. - - ^ map! ! -!Colour class methodsFor: 'other' stamp: 'jmv 6/18/2017 20:10:01'! - maskingMap: depth - "Return a color map that maps all colors except transparent to words of all ones. Used to create a mask for a Form whose transparent pixel value is zero. Cache the most recently used map." - "Warning: The behavior is incorrect if depth = 32. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | sizeNeeded | - depth <= 8 - ifTrue: [sizeNeeded _ 1 bitShift: depth] - ifFalse: [sizeNeeded _ 4096]. - - (MaskingMap == nil or: [MaskingMap size ~= sizeNeeded]) ifTrue: - [MaskingMap _ Bitmap new: sizeNeeded withAll: 16rFFFFFFFF. - MaskingMap at: 1 put: 0. "transparent"]. - - ^ MaskingMap -! ! -!Colour class methodsFor: 'color from user' stamp: 'jmv 6/18/2017 20:58:07'! - colorPaletteForDepth: depth extent: chartExtent - "Display a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." - "Note: It is slow to build this palette, so it should be cached for quick access." - "(Color colorPaletteForDepth: 16 extent: 190@60) display" - - | basicHue x y startHue palette transHt vSteps transCaption grayWidth hSteps | - palette _ Form extent: chartExtent depth: depth. - transCaption _ - (Form extent: 34@9 depth: 1 - fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0) - offset: 0@0). - transHt _ transCaption height. - palette fillWhite: (0@0 extent: palette width@transHt). - palette fillBlack: (0@transHt extent: palette width@1). - transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0). - grayWidth _ 10. - startHue _ 338.0. - vSteps _ palette height - transHt // 2. - hSteps _ palette width - grayWidth. - x _ 0. - startHue to: startHue + 360.0 by: 360.0/hSteps do: [ :h | - basicHue _ Colour h: h asFloat s: 1.0 v: 1.0. - y _ transHt+1. - 0 to: vSteps do: [ :n | | c | - c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Colour white. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - 1 to: vSteps do: [ :n | | c | - c _ Colour black mixed: (n asFloat / vSteps asFloat) with: basicHue. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - x _ x + 1]. - y _ transHt + 1. - 1 to: vSteps * 2 do: [ :n | | c | - c _ Colour black mixed: (n asFloat / (vSteps*2) asFloat) with: Colour white. - palette fill: (x@y extent: 10@1) fillColor: c. - y _ y + 1]. - ^ palette -! ! -!Colour class methodsFor: 'color from user' stamp: 'jmv 6/18/2017 20:58:24'! - colorTest: depth extent: chartExtent colorMapper: colorMapper - "Create a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." - "Note: It is slow to build this palette, so it should be cached for quick access." - "(Color colorTest: 32 extent: 570@180 colorMapper: [:c | c]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 7) asInteger / 7 - g: (c green * 7) asInteger / 7 - b: (c blue * 3) asInteger / 3]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 5) asInteger / 5 - g: (c green * 5) asInteger / 5 - b: (c blue * 5) asInteger / 5]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 15) asInteger / 15 - g: (c green * 15) asInteger / 15 - b: (c blue * 15) asInteger / 15]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 31) asInteger / 31 - g: (c green * 31) asInteger / 31 - b: (c blue * 31) asInteger / 31]) display" - - | basicHue x y c startHue palette transHt vSteps transCaption grayWidth hSteps | - palette _ Form extent: chartExtent depth: depth. - transCaption _ - (Form extent: 34@9 depth: 1 - fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0) - offset: 0@0). - transHt _ transCaption height. - palette fillWhite: (0@0 extent: palette width@transHt). - palette fillBlack: (0@transHt extent: palette width@1). - transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0). - grayWidth _ 10. - startHue _ 338.0. - vSteps _ palette height - transHt // 2. - hSteps _ palette width - grayWidth. - x _ 0. - startHue to: startHue + 360.0 by: 360.0/hSteps do: [:h | - basicHue _ Colour h: h asFloat s: 1.0 v: 1.0. - y _ transHt+1. - 0 to: vSteps do: [:n | - c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Colour white. - c _ colorMapper value: c. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - 1 to: vSteps do: [:n | - c _ Colour black mixed: (n asFloat / vSteps asFloat) with: basicHue. - c _ colorMapper value: c. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - x _ x + 1]. - y _ transHt + 1. - 1 to: vSteps * 2 do: [:n | - c _ Colour black mixed: (n asFloat / (vSteps*2) asFloat) with: Colour white. - c _ colorMapper value: c. - palette fill: (x@y extent: 10@1) fillColor: c. - y _ y + 1]. - ^ palette -! ! -!Colour class methodsFor: 'color name lookup' stamp: 'jmv 6/18/2017 20:10:01'! - colorNames - "Answer the current dictionary of name->color associations." - - ^self colorNamesDict keys! ! -!Colour class methodsFor: 'color name lookup' stamp: 'jmv 6/18/2017 20:59:02'! - defaultColorNamesDictionary - "Answer a amall but useful name->color dictionary" - - | defaultDict | - "Meld most used xkcd colors into traditional colors." - defaultDict := (self traditionalColorNamesDictionary addAll: - self xkcdFirst48ColorNamesDictionary; - yourself). - - "Override traditional names existing in extended XKCD naming" - defaultDict at: #lightYellow put: (Colour r: 1.0 g: 0.996 b: 0.478). - defaultDict at: #lightOrange put: (Colour r: 0.992 g: 0.667 b: 0.283). - defaultDict at: #lightCyan put: (Colour r: 0.674 g: 1.0 b: 0.988). - defaultDict at: #lightRed put: (Colour r: 1.0 g: 0.279 b: 0.298). - defaultDict at: #lightMagenta put: (Colour r: 0.98 g: 0.372 b: 0.969). - - ^defaultDict! ! -!Colour class methodsFor: 'color name lookup' stamp: 'jmv 6/18/2017 20:59:12'! - doesNotUnderstand: aMessage - "Some code takes - Color colorNames - and does - Color perform: aColorname. - - Make this work." - - ^(Colour colorNamesDict) - at: (aMessage selector) - ifAbsent: [super doesNotUnderstand: aMessage]! ! -!Colour class methodsFor: 'color name lookup' stamp: 'jmv 6/18/2017 20:10:01'! - exactColorNamed: aColorName - - "Answer color matching name or nil - from my ColorName->Color Dictionary" - - ^ self colorNamesDict at: (aColorName asSymbol) ifAbsent: [nil]! ! -!Colour class methodsFor: 'color name lookup' stamp: 'jmv 6/18/2017 20:59:55'! - setColorNamesDict: aNameColorDictionary - "Answer the current dictionary of name->color associations." - - "Note: This is a non-standard name because this is a non-standard action!! - Do this if you really, really know what you are doing." - - "Some Colors are required for proper system operation" - Colour defaultColorNamesDictionary keysAndValuesDo: [ :colorName :colorValue | - aNameColorDictionary at: colorName ifAbsentPut: colorValue - ]. - - ColorNamesDict := aNameColorDictionary! ! -!Colour class methodsFor: 'color name lookup' stamp: 'jmv 6/18/2017 21:01:08'! - traditionalColorNamesDictionary - "Answer a dictionary of Squeak traditional name->color associations.." - - | nameDict | - nameDict _ Dictionary new. - nameDict at: #black put: (Colour r: 0 g: 0 b: 0). - nameDict at: #veryVeryDarkGray put: (Colour r: 0.125 g: 0.125 b: 0.125). - nameDict at: #veryDarkGray put: (Colour r: 0.25 g: 0.25 b: 0.25). - nameDict at: #darkGray put: (Colour r: 0.375 g: 0.375 b: 0.375). - nameDict at: #gray put: (Colour r: 0.5 g: 0.5 b: 0.5). - nameDict at: #lightGray put: (Colour r: 0.625 g: 0.625 b: 0.625). - nameDict at: #veryLightGray put: (Colour r: 0.75 g: 0.75 b: 0.75). - nameDict at: #veryVeryLightGray put: (Colour r: 0.875 g: 0.875 b: 0.875). - nameDict at: #white put: (Colour r: 1.0 g: 1.0 b: 1.0). - nameDict at: #red put: (Colour r: 1.0 g: 0 b: 0). - nameDict at: #yellow put: (Colour r: 1.0 g: 1.0 b: 0). - nameDict at: #green put: (Colour r: 0 g: 1.0 b: 0). - nameDict at: #cyan put: (Colour r: 0 g: 1.0 b: 1.0). - nameDict at: #blue put: (Colour r: 0 g: 0 b: 1.0). - nameDict at: #magenta put: (Colour r: 1.0 g: 0 b: 1.0). - nameDict at: #brown put: (Colour r: 0.6 g: 0.2 b: 0). - nameDict at: #orange put: (Colour r: 1.0 g: 0.6 b: 0). - nameDict at: #lightRed put: (Colour r: 1.0 g: 0.8 b: 0.8). - nameDict at: #lightYellow put: (Colour r: 1.0 g: 1.0 b: 0.8). - nameDict at: #lightGreen put: (Colour r: 0.8 g: 1.0 b: 0.6). - nameDict at: #lightCyan put: (Colour r: 0.4 g: 1.0 b: 1.0). - nameDict at: #lightBlue put: (Colour r: 0.8 g: 1.0 b: 1.0). - nameDict at: #lightMagenta put: (Colour r: 1.0 g: 0.8 b: 1.0). - nameDict at: #lightBrown put: (Colour r: 1.0 g: 0.6 b: 0.2). - nameDict at: #lightOrange put: (Colour r: 1.0 g: 0.8 b: 0.4). - nameDict at: #transparent put: (TranslucentColour r: 0.0 g: 0.0 b: 0.0 alpha: 0.0). - - ^nameDict -! ! -!Colour class methodsFor: 'color name lookup' stamp: 'jmv 6/18/2017 21:01:38'! - xkcdFirst48ColorNamesDictionary - "XKCD color names are based on a survey oc colors people call by the same name. - http://blog.xkcd.com/2010/05/03/color-survey-results/" - - "Answer a dictionary of the most agreed upon first 48 xkcd colors" -" - Color xkcdFirst48ColorNamesDictionary explore. -" - | xkcdDict | - xkcdDict := Dictionary new - at: #lightPink put: (Colour fromString: '#ffd1df') ; - at: #mustard put: (Colour fromString: '#ceb301') ; - at: #indigo put: (Colour fromString: '#380282') ; - at: #lime put: (Colour fromString: '#aaff32') ; - at: #seaGreen put: (Colour fromString: '#53fca1') ; - at: #periwinkle put: (Colour fromString: '#8e82fe') ; - at: #darkPink put: (Colour fromString: '#cb416b') ; - at: #oliveGreen put: (Colour fromString: '#677a04') ; - at: #peach put: (Colour fromString: '#ffb07c') ; - at: #paleGreen put: (Colour fromString: '#c7fdb5') ; - at: #lightBrown put: (Colour fromString: '#ad8150') ; - at: #hotPink put: (Colour fromString: '#ff028d') ; - at: #black put: (Colour fromString: '#000000') ; - at: #lilac put: (Colour fromString: '#cea2fd') ; - at: #navyBlue put: (Colour fromString: '#001146') ; - at: #royalBlue put: (Colour fromString: '#0504aa') ; - at: #beige put: (Colour fromString: '#e6daa6') ; - at: #salmon put: (Colour fromString: '#ff796c') ; - at: #olive put: (Colour fromString: '#6e750e') ; - at: #maroon put: (Colour fromString: '#650021') ; - at: #brightGreen put: (Colour fromString: '#01ff07') ; - at: #darkPurple put: (Colour fromString: '#35063e') ; - at: #mauve put: (Colour fromString: '#ae7181') ; - at: #forestGreen put: (Colour fromString: '#06470c') ; - at: #aqua put: (Colour fromString: '#13eac9') ; - at: #cyan put: (Colour fromString: '#00ffff') ; - at: #tan put: (Colour fromString: '#d1b26f') ; - at: #darkBlue put: (Colour fromString: '#00035b') ; - at: #lavender put: (Colour fromString: '#c79fef') ; - at: #turquoise put: (Colour fromString: '#06c2ac') ; - at: #darkGreen put: (Colour fromString: '#033500') ; - at: #violet put: (Colour fromString: '#9a0eea') ; - at: #lightPurple put: (Colour fromString: '#bf77f6') ; - at: #limeGreen put: (Colour fromString: '#89fe05') ; - at: #grey put: (Colour fromString: '#929591') ; - at: #skyBlue put: (Colour fromString: '#75bbfd') ; - at: #yellow put: (Colour fromString: '#ffff14') ; - at: #magenta put: (Colour fromString: '#c20078') ; - at: #lightGreen put: (Colour fromString: '#96f97b') ; - at: #orange put: (Colour fromString: '#f97306') ; - at: #teal put: (Colour fromString: '#029386') ; - at: #lightBlue put: (Colour fromString: '#95d0fc') ; - at: #red put: (Colour fromString: '#e50000') ; - at: #brown put: (Colour fromString: '#653700') ; - at: #pink put: (Colour fromString: '#ff81c0') ; - at: #blue put: (Colour fromString: '#0343df') ; - at: #green put: (Colour fromString: '#15b01a') ; - at: #purple put: (Colour fromString: '#7e1e9c') ; - yourself. - - ^xkcdDict - -! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - blueColorDict - "Answer a dictionary of named colors considered Blue" -" - Color blueColorDict explore. -" - ^self blueColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - blueColorDict: aColorDict - "Answer a dictionary of named colors considered Blue" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isBlue) - or: [assoc key asString asLowercase includesSubString: 'blue']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - blueGreenColorDict - "Answer a dictionary of named colors considered Blue" -" - Color blueGreenColorDict explore. -" - ^self blueGreenColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - blueGreenColorDict: aColorDict - "Answer a dictionary of named colors considered Blue" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isBlueGreen) - or: [assoc key asString asLowercase includesSubString: 'bluegreen']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - brightColorDict - "Answer a dictionary of named colors considered Bright" -" - Color brightColorDict explore. -" - ^self brightColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - brightColorDict: aColorDict - "Answer a dictionary of named colors considered Bright" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - (assoc value isBright) ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - brownColorDict - "Answer a dictionary of named colors considered Brown" -" - Color brownColorDict explore. -" - ^self brownColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - brownColorDict: aColorDict - "Answer a dictionary of named colors considered Brown" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isBrown) - or: [assoc key asString asLowercase includesSubString: 'brown']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - darkColorDict - "Answer a dictionary of named colors considered Dark" -" - Color darkColorDict explore. -" - ^self darkColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - darkColorDict: aColorDict - "Answer a dictionary of named colors considered Dark" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - (assoc value isDark) ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - grayColorDict: aColorDict - "Answer a dictionary of named colors considered Grey" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isGrey) - or: [assoc key asString asLowercase includesSubString: 'grey']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - greenColorDict - "Answer a dictionary of named colors considered Green" -" - Color greenColorDict explore. -" - ^self greenColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - greenColorDict: aColorDict - "Answer a dictionary of named colors considered Green" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isGreen) - or: [assoc key asString asLowercase includesSubString: 'green']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - greyColorDict - "Answer a dictionary of named colors considered Grey" -" - Color greyColorDict explore. -" - ^self greyColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - greyColorDict: aColorDict - "Answer a dictionary of named colors considered Grey" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isGrey) - or: [assoc key asString asLowercase includesSubString: 'grey']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - lightColorDict - "Answer a dictionary of named colors considered light" -" - Color lightColorDict explore. -" - ^self lightColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - lightColorDict: aColorDict - "Answer a dictionary of named colors considered Liight" - - ^self brightColorDict: aColorDict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - orangeColorDict - "Answer a dictionary of named colors considered Orange" -" - Color orangeColorDict explore. -" - ^self orangeColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - orangeColorDict: aColorDict - "Answer a dictionary of named colors considered Orange" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isOrange) - or: [assoc key asString asLowercase includesSubString: 'orange']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - pastelColorDict - "Answer a dictionary of named colors considered Pastel" -" - Color pastelColorDict explore. -" - ^self pastelColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - pastelColorDict: aColorDict - "Answer a dictionary of named colors considered Bright" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - (assoc value isPastel) ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - pinkColorDict - "Answer a dictionary of named colors considered Pink" -" - Color pinkColorDict explore. -" - ^self pinkColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - pinkColorDict: aColorDict - "Answer a dictionary of named colors considered Pink" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isPink) - or: [assoc key asString asLowercase includesSubString: 'pink']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - purpleColorDict - "Answer a dictionary of named colors considered Purple" -" - Color purpleColorDict explore. -" - ^self purpleColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - purpleColorDict: aColorDict - "Answer a dictionary of named colors considered Pink" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc key asString asLowercase includesSubString: 'purple') - or: [assoc key asString asLowercase includesSubString: 'violet']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - redColorDict - "Answer a dictionary of named colors considered Red" -" - Color redColorDict explore. -" - ^self redColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - redColorDict: aColorDict - "Answer a dictionary of named colors considered Red" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isRed) - or: [assoc key asString asLowercase includesSubString: 'red']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - saturatedColorDict - "Answer a dictionary of named colors considered Saturated" -" - Color saturatedColorDict explore. -" - ^self saturatedColorDict: (self colorNamesDict )! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - saturatedColorDict: aColorDict - "Answer a dictionary of named colors considered Saturated" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - (assoc value isSaturated) ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - yellowColorDict - "Answer a dictionary of named colors considered Yellow" -" - Color yellowColorDict explore. -" - ^self yellowColorDict: (self colorNamesDict)! ! -!Colour class methodsFor: 'selection' stamp: 'jmv 6/18/2017 20:10:01'! - yellowColorDict: aColorDict - "Answer a dictionary of named colors considered Yellow" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isYellow) - or: [assoc key asString asLowercase includesSubString: 'yellow']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Colour class methodsFor: 'color space conversions' stamp: 'jmv 6/18/2017 20:10:01'! - applySimpleGamma: gamma to: value - "Encode / decode Gamma. Typical gamma are 0.4545 ( = 1.0 / 2.2, for encoding) and 2.2 (for decoding) - In a non gamma encoded image, the pixel values are proportional to luminance, i.e. the actual light intensity, the photon count. - In an gamma encoded image, the pixel value is close to the average perceived brightness, or 'lightness'. This optimizes the use of available bits in digital images, and dynamic range in analog images and film. This is like the 'luma' signal in video. - - Usually: - - Images stored in file formats such as jpg, png, tiff and bmp are gamma encoded - (unless they are actually raw images). - - Images sent to a framebuffer (video memory) should be gamma encoded. - - Raw images from sensors are not gamma encoded. - - - Image processing algorithms that simulate the real world, or are applied to real world data should work on unencoded (linear) images. - This includes filtering, resizing, blending, and most operations done on images. - This means that if the images come from jpg photos from a camera, they should be gamma decoded. - - Image processing algorithms that works on human perception should work on gamma encoded images. - This includes histograms, histogram equalization, bit allocation (i.e. quantization), compression, etc. - This also includes detecting objects like a human would do - - - See - http://en.wikipedia.org/wiki/Gamma_correction - http://www.poynton.com/notes/colour_and_gamma/GammaFAQ.html - - Mostly for documentation. - value must be in [0.0 .. 1.0]. - Note that the sRGB standard specifies a function that is close to this, but slightly different. - See #linearTosRGBGamma: and #sRGBGammaToLinear:" - - ^ value raisedTo: gamma! ! -!Colour class methodsFor: 'color space conversions' stamp: 'jmv 6/18/2017 20:10:01'! - linearTosRGBGamma: value - "The sRGB standard specifies a gamma curve that is close to gamma = 2.2, but is actually - built from one stright line segment, and a curve with exponent = 2.4. - This method converts value from linearSpace to gammaSpace, i.e. it 'encodes' with gamma. - This is the operation done when producing an 8bit Form for displaying, or for saving on a JPG, PNG, etc; if source data is in linear space (for example, from raw data a sensor image, or data that was converted previously to linear space for proper image processing). - value must be in [0.0 .. 1.0]. - - See - http://en.wikipedia.org/wiki/Gamma_correction - http://www.poynton.com/notes/colour_and_gamma/GammaFAQ.html - http://entropymine.com/imageworsener/srgbformula - - | r v | - r _ Random new. - 1000 timesRepeat: [ - v _ r next. - self assert: ((Color sRGBGammaToLinear: (Color linearTosRGBGamma: v)) closeTo: v) ] - - | r | - r _ 10@10 extent: 600@400. - Display fill: r fillColor: Color white. - FFT new plot: ((0.0 to: 1.0 count: 100) collect: [ :v | Color linearTosRGBGamma: v ]) in: r color: Color black min: 0.0 max: 1.0. - FFT new plot: ((0.0 to: 1.0 count: 100) collect: [ :v | Color applySimpleGamma: 1/2.2 to: v ]) in: r color: Color blue min: 0.0 max: 1.0. - FFT new plot: ((0.0 to: 1.0 count: 100) collect: [ :v | Color sRGBGammaToLinear: v ]) in: r color: Color black min: 0.0 max: 1.0. - FFT new plot: ((0.0 to: 1.0 count: 100) collect: [ :v | Color applySimpleGamma: 2.2 to: v ]) in: r color: Color blue min: 0.0 max: 1.0. - " - - ^ value <= 0.00313066844250063 - ifTrue: [ value * 12.92 ] - ifFalse: [ (value raisedTo: 1.0/2.4) * 1.055 - 0.055 ]! ! -!Colour class methodsFor: 'color space conversions' stamp: 'jmv 6/18/2017 20:10:01'! - sRGBGammaToLinear: value - "The sRGB standard specifies a gamma curve that is close to gamma = 2.2, but is actually - built from one stright line segment, and a curve with exponent = 2.4. - This method converts value from gammaSpace to linearSpace, i.e. it 'decodes'. - This is the operation done by display screens. It is also needed to convert 8bit Forms (from a frameBuffer, or from PNG, JPG, etc.) to linear space for proper image processing. - value must be in [0.0 .. 1.0]. - - See - http://en.wikipedia.org/wiki/Gamma_correction - http://www.poynton.com/notes/colour_and_gamma/GammaFAQ.html - http://entropymine.com/imageworsener/srgbformula - " - - ^ value <= 0.0404482362771082 - ifTrue: [ value / 12.92 ] - ifFalse: [ value + 0.055 / 1.055 raisedTo: 2.4 ]! ! -!Colour class methodsFor: 'cached state access' stamp: 'jmv 6/18/2017 20:10:01'! - colorNamesDict - "Answer the current dictionary of name->color associations." -" - Color colorNamesDict explore. -" - ColorNamesDict ifNil: [ - self setColorNamesDict: self defaultColorNamesDictionary ]. - ^ColorNamesDict! ! -!Colour class methodsFor: 'cached state access' stamp: 'jmv 6/18/2017 20:10:01'! - grayToIndexMap - " - Color grayToIndexMap explore. - " - GrayToIndexMap ifNil: [ - self initializeGrayToIndexMap ]. - ^GrayToIndexMap! ! -!Colour class methodsFor: 'cached state access' stamp: 'jmv 6/18/2017 20:10:01'! - indexedColors - " - Color indexedColors explore. - " - IndexedColors ifNil: [ - self initializeIndexedColors ]. - ^IndexedColors! ! -!Colour class methodsFor: 'cached state access' stamp: 'jmv 6/18/2017 20:10:01'! - releaseClassCachedState - " - Color releaseClassCachedState - " - CachedColormaps _ nil. "Maps to translate between color depths" - ToGrayColormaps _ nil. "Maps colors to 8bpp grays for various color depths" - FromGrayColormaps _ nil. "Maps from 8bpp grays to colors of various depths" - MaskingMap _ nil. "Maps all colors except transparent to black for creating a mask" - ColorNamesDict _ nil. - IndexedColors _ nil. - GrayToIndexMap _ nil! ! -!TranslucentColour methodsFor: 'accessing' stamp: 'jmv 6/18/2017 20:41:17'! - alpha - "Return my alpha value, a number between 0.0 and 1.0 where 0.0 is completely transparent and 1.0 is completely opaque." - - ^ self at: 4! ! -!TranslucentColour methodsFor: 'printing' stamp: 'jmv 6/18/2017 20:10:08'! - storeArrayValuesOn: aStream - - self isTransparent ifTrue: [ - ^ aStream space]. - super storeArrayValuesOn: aStream. - aStream space. - self alpha printOn: aStream fractionDigits: 3! ! -!TranslucentColour methodsFor: 'printing' stamp: 'jmv 6/18/2017 20:10:08'! -storeOn: aStream - - self isTransparent ifTrue: [^ aStream nextPutAll: '(Color transparent)']. - aStream - nextPut: $(; - nextPutAll: self class name; - nextPutAll: ' r: '. - self red printOn: aStream fractionDigits: 3. - aStream nextPutAll: ' g: '. - self green printOn: aStream fractionDigits: 3. - aStream nextPutAll: ' b: '. - self blue printOn: aStream fractionDigits: 3. - aStream nextPutAll: ' alpha: '. - self alpha printOn: aStream fractionDigits: 3. - aStream nextPutAll: ')'! ! -!TranslucentColour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:55:03'! - alpha: alphaValue - "Return a new TranslucentColor with the given amount of opacity ('alpha')." - alphaValue = 1.0 ifTrue: [ - ^ Colour new - setRed: self red - green: self green - blue: self blue]. - ^ super alpha: alphaValue! ! -!TranslucentColour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:08'! - asNontranslucentColor - ^ self alpha: 1.0! ! -!TranslucentColour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:10:08'! - bitPatternForDepth: depth - "Return an appropriate bit pattern. This will almost never be meaningful for tranlucentColors, except for the degenerate case of tranparency." - - self isTransparent ifTrue: [ - ^ Bitmap with: 0]. - ^ super bitPatternForDepth: depth! ! -!TranslucentColour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:41:47'! - pixelValueForDepth: d - "Return the pixel value for this color at the given depth. Translucency only works in RGB; this color will appear either opaque or transparent at all other depths." - | basicPixelWord | - "In 32bpp, if alpha = 0, ignore any color components, and answer R=0, G=0, B=0, Alpha=0. - In depths > 8 and < 32, pixelValue zero is the special value used by BitBlt to denote transparent." - self isTransparent ifTrue: [ - ^ 0]. - basicPixelWord _ super pixelValueForDepth: d. - ^d < 32 - ifTrue: [ basicPixelWord ] - ifFalse: [ (basicPixelWord bitAnd: 16rFFFFFF) bitOr: - ((self alpha*255.0) rounded - bitShift: 24) ]! ! -!TranslucentColour methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:41:50'! - pixelWordForDepth: depth - "Return the pixel value for this color at the given depth. Translucency only works in RGB; this color will appear either opaque or transparent at all other depths." - - | basicPixelWord | - self isTransparent ifTrue: [^ 0]. - basicPixelWord _ super pixelWordForDepth: depth. - ^depth < 32 - ifTrue: [ basicPixelWord ] - ifFalse: [ (basicPixelWord bitAnd: 16rFFFFFF) bitOr: - ((self alpha*255.0) rounded - bitShift: 24) ]! ! -!TranslucentColour methodsFor: 'private' stamp: 'jmv 6/18/2017 20:42:05'! - setRed: r green: g blue: b alpha: alphaValue - - self basicSetRed: r green: g blue: b. - self at: 4 put: alphaValue! ! -!TranslucentColour methodsFor: 'queries' stamp: 'jmv 6/18/2017 20:41:26'! - isOpaque - - ^self alpha = 1.0! ! -!TranslucentColour methodsFor: 'queries' stamp: 'jmv 6/18/2017 20:41:54'! - isTransparent - ^ self alpha = 0.0! ! -!TranslucentColour methodsFor: 'please remove' stamp: 'jmv 6/18/2017 21:27:51'! - setRed: r green: g blue: b alpha: alphaValue colorSpace: aSymbol - ^ self setRed: r green: g blue: b alpha: alphaValue! ! -!TranslucentColour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:54:35'! - new - ^ self new: 4! ! -!TranslucentColour class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:57:08'! - r: r g: g b: b alpha: alphaValue - "Return a color with the given r, g, and b components in the range [0.0..1.0]." - - ^ self new - setRed: r - green: g - blue: b - alpha: alphaValue! ! -!FloatArray methodsFor: 'comparing' stamp: 'jmv 6/18/2017 20:25:14' prior: 16846542! - = another - self == another ifTrue: [ ^ true ]. - self class == another class ifFalse: [ ^ false ]. - ^self primitiveEqual: another! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3105-FloatArrayColour-JuanVuletich-2017Jun19-09h57m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3103] on 19 June 2017 at 11:11:02 am'! -!Integer methodsFor: 'converting' stamp: 'ar 10/31/1998 23:04' prior: 16859466! - asColorOfDepth: d - "Return a color value representing the receiver as color of the given depth" - ^Colour colorFromPixelValue: self depth: d! ! -!InputSensor methodsFor: 'keyboard' stamp: 'jmv 9/2/2016 11:08:09' prior: 16856307! - kbdTest - " - Sensor kbdTest - " - "This test routine will print the unmodified character, its keycode, - and the OR of all its modifier bits, until the character x is typed - -Also useful: - Sensor test - " - | char | - char _ nil. - [ char = $x ] whileFalse: [ - [ self keyboardPressed ] whileFalse. - char _ self keyboard. - Display fill: (5@5 extent: 400@20) fillColor: Colour white. - (String streamContents: [ :s | - s - nextPut: $-; - nextPut: char; - nextPut: $-; - space; - print: char numericValue; - space. - self isMouseButton3Pressed ifTrue: [ s nextPutAll: ' mouseButton3/blue/tertiary/halo ' ]. - self isMouseButton2Pressed ifTrue: [ s nextPutAll: ' mouseButton2/yellow/secondary/menu ' ]. - self isMouseButton1Pressed ifTrue: [ s nextPutAll: ' mouseButton1/red/primary ' ]. - self shiftPressed ifTrue: [ s nextPutAll: ' shift ' ]. - self controlKeyPressed ifTrue: [ s nextPutAll: ' control/ctrl ' ]. - (self primMouseButtons anyMask: 32) ifTrue: [ s nextPutAll: ' macOption ' ]. - self commandAltKeyPressed ifTrue: [ s nextPutAll: ' macCommand/winAlt ' ]]) - displayAt: 10 @ 10 ].! ! -!String methodsFor: 'displaying' stamp: 'jmv 5/12/2015 15:52' prior: 16917036! - 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: Colour black - " - 'Display' displayOn: Display at: 10@10 - "! ! -!SystemDictionary methodsFor: 'shrinking' stamp: 'jmv 4/25/2016 15:31' prior: 16922270! - reduceCuis - " - Smalltalk reduceCuis - " - | keep n unused newDicts oldDicts | - - self nominallyUnsent: #reduceCuis. - - "Remove icons" - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - PasteUpMorph allInstancesDo: [ :w | - w backgroundImageData: nil. - w submorphsDo: [ :a | a delete ]]. - Preferences useNoIcons. - Theme current initialize. - Theme content: nil. - Colour shutDown. - BitBltCanvas releaseClassCachedState. - - Transcript clear. - Clipboard default initialize. - - - "Remove some methods, even if they have senders." -" ColorPickerMorph class removeSelector: #buildEyedropperIcon." - Theme removeSelector: #miscellaneousIcons. - Utilities removeSelector: #vmStatisticsReportString. - SystemDictionary removeSelector: #recreateSpecialObjectsArray. - - StrikeFont removeMostFonts. - StrikeFont saveSpace. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - - keep := OrderedCollection new. - keep addAll: #(SpaceTally). - AppLauncher appGlobalName ifNotNil: [ :any | - keep add: any ]. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - [ - #hereWeGo print. - unused do: [:c | - c print. - (Smalltalk at: c) removeFromSystem]. - n := Smalltalk removeAllUnSentMessages. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - n > 0 or: [ - unused notEmpty ]] whileTrue. - ChangeSet zapAllChangeSets. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - Symbol rehash. - - "Shrink method dictionaries." - Smalltalk garbageCollect. - oldDicts _ MethodDictionary allInstances. - newDicts _ Array new: oldDicts size. - oldDicts withIndexDo: [:d :index | - newDicts at: index put: d rehashWithoutBecome ]. - oldDicts elementsExchangeIdentityWith: newDicts. - oldDicts _ newDicts _ nil. - - SmalltalkCompleter initialize . - - "Sanity checks" -" Undeclared - Smalltalk cleanOutUndeclared - Smalltalk browseUndeclaredReferences - Smalltalk obsoleteClasses - Smalltalk obsoleteBehaviors - Smalltalk browseObsoleteMethodReferences - SmalltalkImage current fixObsoleteReferences - Smalltalk browseAllUnimplementedCalls"! ! -!Transcripter methodsFor: 'accessing' stamp: 'jmv 7/28/2015 08:26' prior: 16938828! - 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]. - textComposition - setModel: (TextModel withText: c asText); - extentForComposing: frame width-8 @9999. - textComposition composeAll. - d _ textComposition usedHeight - frame height. - d > 0 ifTrue: [ - "Scroll up to keep all contents visible" - cb _ textComposition characterBlockAtPoint: - 0@0 + (0@(d+AbstractFont default height)). - self on: (c copyFrom: cb stringIndex to: c size). - readLimit _ position _ collection size. - ^ self endEntry]. - Display fill: (frame insetBy: -2) fillColor: self black; - fill: frame fillColor: self white. - Display getCanvas - textComposition: textComposition - bounds: (4@4 + frame topLeft extent: Display extent) - color: Colour black - selectionColor: Colour blue. - DisplayScreen screenUpdateRequired: nil! ! -!Transcripter methodsFor: 'private' stamp: 'di 8/14/97 12:12' prior: 16938904! - black - Display depth = 1 ifTrue: [^ Bitmap with: 16rFFFFFFFF "Works without color support"]. - ^ Colour black! ! -!Transcripter methodsFor: 'private' stamp: 'di 8/14/97 12:12' prior: 16938910! - white - Display depth = 1 ifTrue: [^ Bitmap with: 0 "Works without color support"]. - ^ Colour white! ! -!DataStream class methodsFor: 'as yet unclassified' stamp: '' prior: 16827931! - example - "An example and test of DataStream/ReferenceStream. - 11/19/92 jhm: Use self testWith:." - "DataStream example" - "ReferenceStream example" - | input sharedPoint | - - "Construct the test data." - input _ Array new: 9. - input at: 1 put: nil. - input at: 2 put: true. - input at: 3 put: (Form extent: 63 @ 50 depth: 8). - (input at: 3) fillWithColor: Colour lightBlue. - input at: 4 put: #(3 3.0 'three'). - input at: 5 put: false. - input at: 6 put: 1024 @ -2048. - input at: 7 put: #x. - input at: 8 put: (Array with: (sharedPoint _ 0 @ -30000)). - input at: 9 put: sharedPoint. - - "Write it out, read it back, and return it for inspection." - ^ self testWith: input! ! -!ReferenceStream class methodsFor: 'as yet unclassified' stamp: '' prior: 16900040! - example2 -"Here is the way to use DataStream and ReferenceStream: - rr _ ReferenceStream fileNamed: ''test.obj''. - rr nextPut: . - rr close. - -To get it back: - rr _ ReferenceStream fileNamed: ''test.obj''. - _ rr next. - rr close. -" -"An example and test of DataStream/ReferenceStream. - 11/19/92 jhm: Use self testWith:." - "ReferenceStream example2" - | input sharedPoint | - - "Construct the test data." - input _ Array new: 9. - input at: 1 put: nil. - input at: 2 put: true. - input at: 3 put: false. - input at: 4 put: #(-4 -4.0 'four' four). - input at: 5 put: (Form extent: 63 @ 50 depth: 8). - (input at: 5) fillWithColor: Colour lightOrange. - input at: 6 put: 1024 @ -2048. - input at: 7 put: input. "a cycle" - input at: 8 put: (Array with: (sharedPoint _ 0 @ -30000)). - input at: 9 put: sharedPoint. - - "Write it out, read it back, and return it for inspection." - ^ self testWith: input -! ! -!TextEditor methodsFor: 'attributes' stamp: 'jmv 6/18/2017 21:32:55' prior: 16931569! - offerColorMenu - "Present a menu of available colors, and if one is chosen, apply it to the current selection." - "This is a user command, and generates undo" - - | attribute colors index thisSel | - thisSel _ self selection. - colors _ #(#black #magenta #red #yellow #green #blue #cyan #white ). - index _ (PopUpMenu - labelArray: colors , #('choose color...' ) - lines: (Array with: colors size + 1)) startUpMenu. - index = 0 ifTrue: [ ^ true ]. - index <= colors size - ifTrue: [ attribute _ TextColor color: (Colour perform: (colors at: index)) ] - ifFalse: [ - index _ index - colors size - 1. - "Re-number!!!!!!" - index = 0 ifTrue: [ attribute _ self chooseColor ]. - thisSel ifNil: [ ^ true ]]. - attribute ifNotNil: [ self applyAttribute: attribute ]. - ^ true.! ! -!TextAction class methodsFor: 'as yet unclassified' stamp: 'jmv 4/19/2015 09:38' prior: 16930008! - textActionColor - ^Colour r: 0.4 g: 0 b: 1.0! ! -!TextColor methodsFor: 'testing' stamp: 'jmv 1/21/2011 11:33' prior: 16930362! - isSet - "Do not include Colour black, as it is the default color." - ^color ~= Colour black! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 16930372! - black - ^ self new color: Colour black! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 16930375! - blue - ^ self new color: Colour blue! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 16930378! - cyan - ^ self new color: Colour cyan! ! -!TextColor class methodsFor: 'constants' stamp: 'ajh 9/10/2002 02:26' prior: 16930382! - gray - ^ self new color: Colour gray! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 16930385! - green - ^ self new color: Colour green! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 16930388! - magenta - ^ self new color: Colour magenta! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 16930391! - red - ^ self new color: Colour red! ! -!TextColor class methodsFor: 'constants' stamp: 'sma 3/24/2000 10:50' prior: 16930395! - white - ^ self new color: Colour white! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 16930398! - yellow - ^ self new color: Colour yellow! ! -!Preferences class methodsFor: 'halos' stamp: 'jmv 6/18/2017 21:33:44' prior: 16893209! - installHaloSpecsFromArray: anArray - - | aColour | - ^ self parameters at: #HaloSpecs put: (anArray collect: [ :each | - aColour _ Colour. - each fourth do: [ :sel | aColour _ aColour perform: sel]. - HaloSpec new - horizontalPlacement: each second - verticalPlacement: each third - color: aColour - iconSymbol: each fifth - addHandleSelector: each first - hoverHelp: each sixth])! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 9/19/2016 20:45:55' prior: 16938476! - displayOn: aForm in: aRectangle - " - Transcript displayOn: Display - " - | font count i string x y fh f canvas innerR | - aForm fill: aRectangle fillColor: Colour white. - font _ AbstractFont default. - - innerR _ aRectangle insetBy: self padding. - fh _ font height. - count _ innerR height // fh-1. - x _ innerR left. - y _ innerR top. - f _ firstIndex-1. - firstIndex > lastIndex ifTrue: [ f _ f - self maxEntries ]. - i _ (lastIndex - count max: f) \\ self maxEntries + 1. - canvas _ aForm getCanvas. - canvas newClipRect: innerR. - [ - string _ entries at: i. - canvas drawString: string at: x@y font: font color: Colour veryDarkGray. - y _ y + fh. - i = lastIndex - ] whileFalse: [ i _ i \\ self maxEntries + 1 ]. - - string _ unfinishedEntry contents. - canvas drawString: string at: x@y font: font color: Colour veryDarkGray! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 9/19/2016 20:53:35' prior: 16938512! - displayUnfinishedEntryOn: aForm - - | font count string x y fh canvas r innerR | - innerR _ bounds insetBy: self padding. - lastDisplayPosition < innerR right ifTrue: [ - font _ AbstractFont default. - fh _ font height. - count _ innerR height // fh-1. - x _ innerR left. - string _ unfinishedEntry contents. - y _ ((lastIndex - firstIndex \\ self maxEntries) min: count-1) + 1 * font height + innerR top. - canvas _ aForm getCanvas. - r _ innerR left: lastDisplayPosition. - canvas newClipRect: r. - (canvas drawString: string at: x@y font: font color: Colour veryDarkGray) ifNotNil: [ :lastPoint | - lastDisplayPosition _ lastPoint x. - ^r ]]. - ^nil! ! -!Form methodsFor: 'analyzing' stamp: 'ar 5/17/2001 15:40' prior: 16846838! - dominantColor - | tally max maxi | - self depth > 16 ifTrue: - [^(self asFormOfDepth: 16) dominantColor]. - tally _ self tallyPixelValues. - max _ maxi _ 0. - tally withIndexDo: [:n :i | n > max ifTrue: [max _ n. maxi _ i]]. - ^ Colour colorFromPixelValue: maxi - 1 depth: self depth! ! -!Form methodsFor: 'bordering' stamp: 'jmv 1/22/2015 10:22' prior: 16847019! - border: aRectangle width: borderWidth - "Paint a border whose rectangular area is defined by aRectangle. The - width of the border of each side is borderWidth. Uses black for - drawing the border." - - self border: aRectangle width: borderWidth fillColor: Colour black! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:20' prior: 16847087! - fillBlack - "Set all bits in the receiver to black (ones)." - - self fill: self boundingBox fillColor: Colour black! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:20' prior: 16847093! - fillBlack: aRectangle - "Set all bits in the receiver's area defined by aRectangle to black (ones)." - - self fill: aRectangle rule: Form over fillColor: Colour black! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:20' prior: 16847109! - fillGray - "Set all bits in the receiver to gray." - - self fill: self boundingBox fillColor: Colour gray! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:20' prior: 16847115! - fillGray: aRectangle - "Set all bits in the receiver's area defined by aRectangle to the gray mask." - - self fill: aRectangle rule: Form over fillColor: Colour gray! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:21' prior: 16847146! - fillWhite - "Set all bits in the form to white." - - self fill: self boundingBox fillColor: Colour white! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:21' prior: 16847152! - fillWhite: aRectangle - "Set all bits in the receiver's area defined by aRectangle to white." - - self fill: aRectangle rule: Form over fillColor: Colour white! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:21' prior: 16847165! - reverse - "Change all the bits in the receiver that are white to black, and the ones - that are black to white. - Display reverse - " - - self fill: self boundingBox rule: Form reverse fillColor: Colour white! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:21' prior: 16847174! - reverse: aRectangle - "Change all the bits in the receiver's area that intersects with aRectangle - that are white to black, and the ones that are black to white." - - self fill: aRectangle rule: Form reverse fillColor: Colour white! ! -!Form methodsFor: 'color mapping' stamp: 'ar 5/17/2001 15:42' prior: 16847212! - colormapIfNeededForDepth: destDepth - "Return a colormap for displaying the receiver at the given depth, or nil if no colormap is needed." - - self depth = destDepth ifTrue: [^ nil]. "not needed if depths are the same" - ^ Colour colorMapIfNeededFrom: self depth to: destDepth -! ! -!Form methodsFor: 'color mapping' stamp: 'jmv 5/12/2016 13:53' prior: 16847223! - colormapIfNeededForGray8bpp - "Return a colormap for displaying the receiver at the given depth. - Note: Uses 5 bits per color component. 32bit Forms will lose information!!" - - ^ Colour cachedColormapForGrayFrom: self depth! ! -!Form methodsFor: 'color mapping' stamp: 'jmv 6/18/2017 21:31:52' prior: 16847240! - mapColor: oldColour to: newColor - "Make all pixels of the given color in this Form to the given new color." - "Warnings: This method modifies the receiver. It may lose some color accuracy on 32-bit Forms, since the transformation uses a color map with only 15-bit resolution." - - | map | - map _ (Colour cachedColormapFrom: self depth to: self depth) copy. - map at: (oldColour indexInMap: map) put: (newColor pixelWordForDepth: self depth). - (BitBlt toForm: self) - sourceForm: self; - sourceOrigin: 0@0; - combinationRule: Form over; - destX: 0 destY: 0 width: width height: height; - colorMap: map; - copyBits. -! ! -!Form methodsFor: 'color mapping' stamp: 'jmv 1/31/2011 09:21' prior: 16847262! - maskingMap - "Return a color map that maps all colors except transparent to words of all ones. Used to create a mask for a Form whose transparent pixel value is zero." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Colour maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - ^Colour maskingMap: self depth! ! -!Form methodsFor: 'converting' stamp: 'jm 11/12/97 19:28' prior: 16847299! - as8BitColorForm - "Simple conversion of zero pixels to transparent. Force it to 8 bits." - - | f map | - f _ ColorForm extent: self extent depth: 8. - self displayOn: f at: self offset negated. - map _ Colour indexedColors copy. - map at: 1 put: Colour transparent. - f colors: map. - f offset: self offset. - ^ f -! ! -!Form methodsFor: 'pixel access' stamp: 'ar 5/17/2001 15:42' prior: 16848158! - colorAt: aPoint - "Return the color in the pixel at the given point. " - - ^ Colour - colorFromPixelValue: (self pixelValueAt: aPoint) - depth: self depth -! ! -!Form methodsFor: 'pixel access' stamp: 'jmv 11/4/2015 12:40' prior: 16848175! - colorInterpolatedAt: aPoint - "Evaluate a bilinear (i.e. cheap) interpolation - Like OpenCV's CV_INTER_LINEAR - Answer Colour transparent if outside image bounds. - Copied almost verbatim from FloatImage. - Answer Colors with float components. Will be rounded to be stored in, for example, a 32-bit Form." - - | x y w interpolated xWeight1 xWeight0 yWeight1 yWeight0 xIndex0 xIndex1 yIndex0 yIndex1 | - x _ aPoint x. - y _ aPoint y. - x < 0.0 ifTrue: [ ^Colour transparent ]. - xIndex0 _ x truncated. "Could be #floor. But as we only care for values >=0, it is the same. But faster." - xIndex0 > (width-1) ifTrue: [ ^Colour transparent ]. - (xIndex0 = (width-1) and: [ x > (width-1) ]) ifTrue: [ ^Colour transparent ]. - xIndex1 _ xIndex0 = (width-1) "Avoid the invalid access if this was true, but don't make it slower the most common, general case." - ifFalse: [ xIndex0 + 1 ] - ifTrue: [ xIndex0 ]. - - y < 0.0 ifTrue: [ ^Colour transparent ]. - yIndex0 _ y truncated. "Could be #floor. But as we only care for values >=0, it is the same. But faster." - yIndex0 > (height-1) ifTrue: [ ^Colour transparent ]. - (yIndex0 = (height-1) and: [ y > (height-1) ]) ifTrue: [ ^Colour transparent ]. - yIndex1 _ yIndex0 = (height-1) "Avoid the invalid access if this was true, but don't make it slower the most common, general case." - ifFalse: [ yIndex0 + 1 ] - ifTrue: [ yIndex0 ]. - - xWeight1 _ x - xIndex0. - xWeight0 _ 1.0 - xWeight1. - - yWeight1 _ y - yIndex0. - yWeight0 _ 1.0 - yWeight1. - - "/* perform interpolation */" - w _ ((self colorAt: xIndex0 @ yIndex0) * xWeight0) + - ((self colorAt: xIndex1 @ yIndex0) * xWeight1). - interpolated _ w * yWeight0. - - w _ ((self colorAt: xIndex0 @ yIndex1) * xWeight0) + - ((self colorAt: xIndex1 @ yIndex1) * xWeight1). - interpolated _ w * yWeight1 + interpolated. - - ^interpolated! ! -!Form methodsFor: 'transitions' stamp: 'jmv 7/28/2015 08:32' prior: 16848519! - pageWarp: otherImage at: topLeft forward: forward - "Produce a page-turning illusion that gradually reveals otherImage - located at topLeft in this form. - forward == true means turn pages toward you, else away. [ignored for now]" - | pageRect oldPage nSteps buffer p leafRect sourceQuad warp oldBottom d | - pageRect _ otherImage boundingBox. - oldPage _ self copy: (pageRect translatedBy: topLeft). - (forward ifTrue: [oldPage] ifFalse: [otherImage]) - border: pageRect - widthRectangle: (Rectangle - left: 0 - right: 2 - top: 1 - bottom: 1) - rule: Form over - fillColor: Colour black. - oldBottom _ self copy: ((pageRect bottomLeft + topLeft) extent: (pageRect width@(pageRect height//4))). - nSteps _ 8. - buffer _ Form extent: otherImage extent + (0@(pageRect height//4)) depth: self depth. - d _ pageRect topLeft + (0@(pageRect height//4)) - pageRect topRight. - 1 to: nSteps-1 do: - [:i | forward - ifTrue: [buffer copy: pageRect from: otherImage to: 0@0 rule: Form over. - p _ pageRect topRight + (d * i // nSteps)] - ifFalse: [buffer copy: pageRect from: oldPage to: 0@0 rule: Form over. - p _ pageRect topRight + (d * (nSteps-i) // nSteps)]. - buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over. - leafRect _ pageRect topLeft corner: p x @ (pageRect bottom + p y). - sourceQuad _ Array with: pageRect topLeft - with: pageRect bottomLeft + (0@p y) - with: pageRect bottomRight - with: pageRect topRight - (0@p y). - warp _ (WarpBlt toForm: buffer) - clipRect: leafRect; - sourceForm: (forward ifTrue: [oldPage] ifFalse: [otherImage]); - combinationRule: Form paint. - warp copyQuad: sourceQuad toRect: leafRect. - self copy: buffer boundingBox from: buffer to: topLeft rule: Form over. - Display forceToScreen. - ]. - - buffer copy: pageRect from: otherImage to: 0@0 rule: Form over. - buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over. - self copy: buffer boundingBox from: buffer to: topLeft rule: Form over. - Display forceToScreen. -" -1 to: 4 do: [:corner | Display pageWarp: - (Form fromDisplay: (10@10 extent: 200@300)) reverse - at: 10@10 forward: false] -" -! ! -!Form class methodsFor: 'instance creation' stamp: 'jmv 9/23/2012 21:44' prior: 16848886! - dotOfSize: diameter - "Create a form which contains a round black dot." - | radius form bb rect centerX centerY centerYBias centerXBias radiusSquared xOverY maxy dx | - radius _ diameter//2. - form _ self extent: diameter@diameter offset: (0@0) - (radius@radius). - bb _ (BitBlt toForm: form) - sourceX: 0; sourceY: 0; - combinationRule: Form over; - fillColor: Colour black. - rect _ form boundingBox. - centerX _ rect center x. - centerY _ rect center y. - centerYBias _ rect height odd ifTrue: [0] ifFalse: [1]. - centerXBias _ rect width odd ifTrue: [0] ifFalse: [1]. - radiusSquared _ (rect height asFloat / 2.0) squared - 0.01. - xOverY _ rect width asFloat / rect height asFloat. - maxy _ rect height - 1 // 2. - - "First do the inner fill, and collect x values" - 0 to: maxy do: - [:dy | - dx _ ((radiusSquared - (dy * dy) asFloat) sqrt * xOverY) truncated. - bb destX: centerX - centerXBias - dx - destY: centerY - centerYBias - dy - width: dx + dx + centerXBias + 1 - height: 1; - copyBits. - bb destY: centerY + dy; - copyBits]. - ^ form -" -Time millisecondsToRun: - [1 to: 20 do: [:i | (Form dotOfSize: i) displayAt: (i*20)@(i*20)]] -"! ! -!Form class methodsFor: 'instance creation' stamp: 'pb 5/4/2016 17:43' prior: 16849005! - fakeSphereAt: aPoint diameter: diameter color: aColor - "Create a form which contains a round black dot." - | bb rect d p | - bb _ GrafPort toForm: Display. - bb fillColor: aColor. - bb combinationRule: Form blend. - rect _ aPoint extent: diameter. - bb fillOval: rect. - p _ (diameter * 2 // 5) asPoint + aPoint. - #(2 3 4 5 6 ) do: [ :i | - "simulate facade by circles of gray" - bb fillColor: (Colour white alpha: 0.3). - d _ i * diameter // 10. - rect _ Rectangle - center: p - extent: d. - bb fillOval: rect ]. - DisplayScreen screenUpdateRequired: nil. -" - Form fakeSphereAt: 50@50 diameter: 30 color: (Colour red alpha: 0.5) -"! ! -!Form class methodsFor: 'examples' stamp: 'jmv 3/20/2013 22:36' prior: 16849178! - toothpaste: diam - " - Display restoreAfter: [Form toothpaste: 30] - " - "Not completely unlike the ST-80 implementation :) - Original comment: - Draws wormlike lines by laying down images of spheres. - See Ken Knowlton, Computer Graphics, vol. 15 no. 4 p352. - Draw with mouse button down; terminate by option-click." - | point queue color q colors colr colr2 | - colors _ Colour red wheel: 12. - color _ 8. - [ true ] whileTrue: [ - queue _ OrderedCollection new: 32. - 16 timesRepeat: [queue addLast: -40@-40]. - Sensor waitButton. - Sensor isMouseButton2Pressed ifTrue: [^ self]. - point _ Sensor mousePoint. - colr _ colors atWrap: (color _ color + 5). "choose increment relatively prime to colors size" - colr2 _ colr alpha: 0.3. - [Sensor isMouseButton1Pressed or: [queue size > 0]] whileTrue: [ - point _ point * 4 + Sensor mousePoint // 5. - point _ point. - Form fakeSphereAt: point diameter: diam color: colr. - (q _ queue removeFirst) ifNil: [^ self]. "exit" - Form fakeSphereAt: q diameter: diam color: colr2. - Sensor isMouseButton1Pressed ifTrue: [queue addLast: point]]]! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 5/15/2015 09:37' prior: 16849256! - bottomLeftCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - "Create and answer a Form for the bottomLeft corner of a rounded rectangle" - | f aaw topColor bottomColor l d c width dy | - topColor _ Colour white * gradientTopFactor. - bottomColor _ Colour white * gradientBottomFactor. - width _ r. - aaw _ 1.3. - f _ Form - extent: width @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: width - 1 - do: [ :x | - dy _ height - r - y. - dy > 0 - ifTrue: [ l _ 1.0 ] - ifFalse: [ - d _ (width - 1 - x @ dy) r. - l _ ((r - d max: 0.0) min: aaw) / aaw ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 5/15/2015 09:47' prior: 16849283! - bottomLeftCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor borderWidth: bw - "Create and answer a Form for the bottomLeft corner of a rounded rectangle" - | f aaw topColor bottomColor l d c width dy l1 l2 | - topColor _ Colour white * gradientTopFactor. - bottomColor _ Colour white * gradientBottomFactor. - width _ r. - aaw _ 1.3. - f _ Form - extent: width @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: width - 1 - do: [ :x | - dy _ height - r - y. - dy > 0 - ifTrue: [ l _ 1.0 ] - ifFalse: [ - d _ (width - 1 - x @ dy) r. - l1 _ ((r - d-1+aaw max: 0.0) min: aaw) / aaw. - l2 _ ((d - r+bw+aaw max: 0.0) min: aaw) / aaw. - l _ l1 min: l2. - ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 5/15/2015 09:38' prior: 16849314! - bottomRightCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - "Create and answer a Form for the bottomRight corner of a rounded rectangle" - | f aaw topColor bottomColor l d c width dy | - topColor _ Colour white * gradientTopFactor. - bottomColor _ Colour white * gradientBottomFactor. - width _ r. - aaw _ 1.3. - f _ Form - extent: width @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: width - 1 - do: [ :x | - dy _ height - r - y. - dy > 0 - ifTrue: [ l _ 1.0 ] - ifFalse: [ - d _ (x @ dy) r. - l _ ((r - d max: 0.0) min: aaw) / aaw ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 5/15/2015 09:41' prior: 16849341! - bottomRightCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor borderWidth: bw - "Create and answer a Form for the bottomLeft corner of a rounded rectangle" - | f aaw topColor bottomColor l d c width dy l1 l2 | - topColor _ Colour white * gradientTopFactor. - bottomColor _ Colour white * gradientBottomFactor. - width _ r. - aaw _ 1.3. - f _ Form - extent: width @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: width - 1 - do: [ :x | - dy _ height - r - y. - dy > 0 - ifTrue: [ l _ 1.0 ] - ifFalse: [ - d _ (x @ dy) r. - l1 _ ((r - d-1+aaw max: 0.0) min: aaw) / aaw. - l2 _ ((d - r+bw+aaw max: 0.0) min: aaw) / aaw. - l _ l1 min: l2. - ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 11/30/2010 10:34' prior: 16849371! - topLeftCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - "Create and answer a Form with a vertical gray gradient as specified for the topLeft corner of a rounded rectangle" - | f bw topColor bottomColor l d c w | - topColor _ Colour white * gradientTopFactor. - bottomColor _ Colour white * gradientBottomFactor. - w _ r. - bw _ 1.3. - f _ Form - extent: w @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: w - 1 - do: [ :x | - l _ 1.0. - y < r ifTrue: [ - d _ (w - 1 - x @ (w - 1 - y)) r. - l _ ((r - d max: 0.0) min: bw) / bw ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 11/30/2010 10:36' prior: 16849397! - topRightCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - "Create and answer a Form with a vertical gray gradient as specified for the topRight corner of a rounded rectangle" - | f bw topColor bottomColor l d c w | - topColor _ Colour white * gradientTopFactor. - bottomColor _ Colour white * gradientBottomFactor. - w _ r. - bw _ 1.3. - f _ Form - extent: w @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: w - 1 - do: [ :x | - l _ 1.0. - y < r ifTrue: [ - d _ (x @ (w - y - 1)) r. - l _ ((r - d max: 0.0) min: bw) / bw ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!ColorForm methodsFor: 'accessing' stamp: 'ar 5/17/2001 15:45' prior: 16818750! - colors: colorList - "Set my color palette to the given collection." - - | colorArray colorCount newColors | - colorList ifNil: [ - colors _ cachedDepth _ cachedColormap _ nil. - ^ self]. - - colorArray _ colorList asArray. - colorCount _ colorArray size. - newColors _ Array new: (1 bitShift: self depth). - 1 to: newColors size do: [:i | - i <= colorCount - ifTrue: [newColors at: i put: (colorArray at: i)] - ifFalse: [newColors at: i put: Colour transparent]]. - - colors _ newColors. - cachedDepth _ nil. - cachedColormap _ nil. -! ! -!ColorForm methodsFor: 'color manipulation' stamp: 'di 11/11/1998 13:20' prior: 16818824! - asGrayScale - "Return a grayscale ColorForm computed by mapping each color into its grayscale equivalent" - ^ self copy colors: - (colors collect: - [:c | c isTransparent ifTrue: [c] - ifFalse: [Colour gray: c luminance]])! ! -!ColorForm methodsFor: 'color manipulation' stamp: 'jmv 3/1/2010 09:41' prior: 16818834! - colormapIfNeededForDepth: destDepth - "Return a colormap for displaying the receiver at the given depth, or nil if no colormap is needed." - - | newMap | - colors ifNil: [ - "use the standard colormap" - ^ Colour colorMapIfNeededFrom: self depth to: destDepth]. - - (destDepth = cachedDepth and:[cachedColormap isColormap not]) - ifTrue: [^ cachedColormap]. - newMap _ Bitmap new: colors size. - 1 to: colors size do: [:i | - newMap - at: i - put: ((colors at: i) pixelValueForDepth: destDepth)]. - - cachedDepth _ destDepth. - ^ cachedColormap _ newMap. -! ! -!ColorForm methodsFor: 'private' stamp: 'ar 5/17/2001 15:44' prior: 16818940! - ensureColorArrayExists - "Return my color palette." - - colors ifNil: [ - self depth > 8 ifTrue: [^ self error: 'ColorForms only support depths up to 8 bits']. - self colors: (Colour indexedColors copyFrom: 1 to: (1 bitShift: self depth))]. -! ! -!ColorForm class methodsFor: 'as yet unclassified' stamp: 'jmv 4/10/2015 23:20' prior: 16819047! - mappingWhiteToTransparentFrom: aFormOrCursor - "Return a ColorForm copied from the given Form or Cursor with white mapped to transparent." - - | f map | - aFormOrCursor depth <= 8 ifFalse: [ - ^ self error: 'argument depth must be 8-bits per pixel or less']. - (aFormOrCursor is: #ColorForm) ifTrue: [ - f _ aFormOrCursor copy. - map _ aFormOrCursor colors. - ] ifFalse: [ - f _ ColorForm extent: aFormOrCursor extent depth: aFormOrCursor depth. - f copyBits: aFormOrCursor boundingBox - from: aFormOrCursor - at: 0@0 - clippingBox: aFormOrCursor boundingBox - rule: Form over. - map _ Colour indexedColors copyFrom: 1 to: (1 bitShift: aFormOrCursor depth)]. - map _ map collect: [:c | - c = Colour white ifTrue: [Colour transparent] ifFalse: [c]]. - f colors: map. - ^ f -! ! -!ColorForm class methodsFor: 'instance creation' stamp: 'jmv 5/4/2016 16:31' prior: 16819074! - grayScaleAndTransparentExtent: aPoint -"Native depth" - "Answer a ColorForm for storing 8bpp gray scale. (do not include any slot for transparent)" - - | grays result | - result _ self extent: aPoint depth: (Smalltalk isLittleEndian ifTrue: [ -8 ] ifFalse: [ 8 ]). - grays _ (0 to: 255) collect: [ :brightness | Colour gray: brightness asFloat / 255.0]. - grays at: 1 put: Colour transparent. - result colors: grays. - ^result! ! -!Cursor methodsFor: 'converting' stamp: 'jmv 2/25/2011 19:47' prior: 16825855! - asCursorForm - | form | - form _ Form extent: self extent depth: 8. - form fillShape: self fillColor: Colour black at: offset negated. - ^ form offset: offset! ! -!CursorWithMask methodsFor: 'converting' stamp: 'jmv 2/25/2011 19:47' prior: 16826695! - asCursorForm - | form | - form _ Form extent: self extent depth: 8. - form fillShape: maskForm fillColor: Colour white. - form fillShape: self fillColor: Colour black at: offset negated. - ^ form offset: offset! ! -!GrayForm methodsFor: 'pixel accessing' stamp: 'jmv 5/11/2016 19:57' prior: 16850335! - grayAt: aPoint - "Return the color of the pixel at aPoint." - - ^Colour gray: (self pixelValueAt: aPoint) asFloat / 255.0! ! -!GrayForm methodsFor: 'color manipulation' stamp: 'jmv 5/12/2016 15:04' prior: 16850359! - colormapIfNeededForDepth: destDepth - "Return a colormap for displaying the receiver at the given depth, or nil if no colormap is needed." - - ^ Colour cachedColormapFromGrayTo: destDepth! ! -!BMPReadWriter methodsFor: 'reading' stamp: 'ar 10/24/2005 20:57' prior: 16781762! - readColorMap - "Read colorCount BMP color map entries from the given binary stream. Answer an array of Colors." - | colorCount colors maxLevel b g r ccStream | - colorCount := (bfOffBits - 54) // 4. - "Note: some programs (e.g. Photoshop 4.0) apparently do not set colorCount; assume that any data between the end of the header and the start of the pixel data is the color map" - biBitCount >= 16 ifTrue:[^nil]. - colorCount = 0 ifTrue: [ "this BMP file does not have a color map" - "default monochrome color map" - biBitCount = 1 ifTrue: [^ Array with: Colour white with: Colour black]. - "default gray-scale color map" - maxLevel := (2 raisedTo: biBitCount) - 1. - ^ (0 to: maxLevel) collect: [:level | Colour gray: (level asFloat / maxLevel)]]. - ccStream := ReadStream on: (stream next: colorCount*4). - colors := Array new: colorCount. - 1 to: colorCount do: [:i | - b := ccStream next. - g := ccStream next. - r := ccStream next. - ccStream next. "skip reserved" - colors at: i put: (Colour r: r g: g b: b range: 255)]. - ^ colors -! ! -!BitBlt methodsFor: 'accessing' stamp: 'jmv 3/20/2013 00:50' prior: 16785567! - fillColor - "Return the current fill color as a Color. - Gives the wrong answer if the halftoneForm is a complex pattern of more than one word." - - halftoneForm ifNil: [^ Colour black]. - ^ Colour colorFromPixelValue: halftoneForm first depth: destForm depth! ! -!BitBlt class methodsFor: 'examples' stamp: 'jmv 7/27/2015 17:07' prior: 16786237! - alphaBlendDemo - "To run this demo, use... - Display restoreAfter: [BitBlt alphaBlendDemo] - Displays 10 alphas, then lets you paint. Option-Click to stop painting." - - "This code exhibits alpha blending in any display depth by performing - the blend in an off-screen buffer with 32-bit pixels, and then copying - the result back onto the screen with an appropriate color map. - tk 3/10/97" - - "This version uses a sliding buffer for painting that keeps pixels in 32 bits - as long as they are in the buffer, so as not to lose info by converting down - to display resolution and back up to 32 bits at each operation. - di 3/15/97" - - | brush buff dispToBuff buffToDisplay mapDto32 map32toD prevP p brushToBuff theta buffRect buffSize buffToBuff brushRect delta newBuffRect updateRect | - - "compute color maps if needed" - Display depth <= 8 ifTrue: [ - mapDto32 _ Colour cachedColormapFrom: Display depth to: 32. - map32toD _ Colour cachedColormapFrom: 32 to: Display depth]. - - "display 10 different alphas, across top of screen" - buff _ Form extent: 500@50 depth: 32. - dispToBuff _ BitBlt toForm: buff. - dispToBuff colorMap: mapDto32. - dispToBuff copyFrom: (50@10 extent: 500@50) in: Display to: 0@0. - 1 to: 10 do: [:i | dispToBuff fill: (50*(i-1)@0 extent: 50@50) - fillColor: (Colour red alpha: i/10) - rule: Form blend]. - buffToDisplay _ BitBlt toForm: Display. - buffToDisplay colorMap: map32toD. - buffToDisplay copyFrom: buff boundingBox in: buff to: 50@10. - DisplayScreen screenUpdateRequired: nil. - - "Create a brush with radially varying alpha" - brush _ Form extent: 30@30 depth: 32. - 1 to: 5 do: - [:i | brush fillShape: (Form dotOfSize: brush width*(6-i)//5) - fillColor: (Colour red alpha: 0.02 * i - 0.01) - at: brush extent // 2]. - - "Now paint with the brush using alpha blending." - buffSize _ 100. - buff _ Form extent: brush extent + buffSize depth: 32. "Travelling 32-bit buffer" - dispToBuff _ BitBlt toForm: buff. "This is from Display to buff" - dispToBuff colorMap: mapDto32. - brushToBuff _ BitBlt toForm: buff. "This is from brush to buff" - brushToBuff sourceForm: brush; sourceOrigin: 0@0. - brushToBuff combinationRule: Form blend. - buffToBuff _ BitBlt toForm: buff. "This is for slewing the buffer" - - [Sensor isMouseButton2Pressed] whileFalse: - [prevP _ nil. - buffRect _ Sensor mousePoint - (buffSize // 2) extent: buff extent. - dispToBuff copyFrom: buffRect in: Display to: 0@0. - [Sensor isMouseButton1Pressed] whileTrue: - ["Here is the painting loop" - p _ Sensor mousePoint - (brush extent // 2). - (prevP == nil or: [prevP ~= p]) ifTrue: - [prevP == nil ifTrue: [prevP _ p]. - (p dist: prevP) > buffSize ifTrue: - ["Stroke too long to fit in buffer -- clip to buffer, - and next time through will do more of it" - theta _ (p-prevP) theta. - p _ ((theta cos@theta sin) * buffSize asFloat + prevP) truncated]. - brushRect _ p extent: brush extent. - (buffRect containsRect: brushRect) ifFalse: - ["Brush is out of buffer region. Scroll the buffer, - and fill vacated regions from the display" - delta _ brushRect amountToTranslateWithin: buffRect. - buffToBuff copyFrom: buff boundingBox in: buff to: delta. - newBuffRect _ buffRect translatedBy: delta negated. - newBuffRect - areasOutside: buffRect - do: [ :r | dispToBuff copyFrom: r in: Display to: r origin - newBuffRect origin ]. - buffRect _ newBuffRect]. - - "Interpolate from prevP to p..." - brushToBuff drawFrom: prevP - buffRect origin - to: p - buffRect origin - withFirstPoint: false. - - "Update (only) the altered pixels of the destination" - updateRect _ (p min: prevP) corner: (p max: prevP) + brush extent. - buffToDisplay copy: updateRect from: updateRect origin - buffRect origin in: buff. - DisplayScreen screenUpdateRequired: updateRect. - prevP _ p]]]! ! -!WarpBlt methodsFor: 'setup' stamp: 'mtf 8/14/2009 18:21' prior: 16942977! - cellSize: s - "Set the number of samples used for averaging" - cellSize := s. - cellSize = 1 ifTrue: [^ self]. - "Install the colorMap to used for mapping the averaged RGBA 32bit pixels to the - destination depth. Note that we need to install the 32->32 color map explicitly because - the VM will substitute a colorMap derived from sourceForm->destForm mapping which - is just plain wrong for <32 source and 32bit dest depth" - (destForm depth = 32 and: [sourceForm notNil] and: [sourceForm depth < 32]) - ifTrue:[colorMap := ColorMap shifts: #(0 0 0 0) masks:#(16rFF0000 16rFF00 16rFF 16rFF000000) colors: nil] - ifFalse:[colorMap := Colour colorMapIfNeededFrom: 32 to: destForm depth]. -! ! -!GrafPort methodsFor: 'text' stamp: 'jmv 6/1/2015 13:28' prior: 16850127! - displayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font color: foregroundColor - "If required, do a second pass with new rule and colorMap. - Answer last affected pixel position - Answer nil if nothing was done - " - - | answer prevRule secondPassMap sourceDepth destDepth | - - "Slight optimization when there's nothing to do." - clipHeight = 0 ifTrue: [^nil]. - clipWidth = 0 ifTrue: [^nil]. - - self installStrikeFont: font foregroundColor: (foregroundColor alpha: 1). - - "If combinationRule is rgbMul, we might need the special two-pass technique for component alpha blending. - If not, do it simply" - combinationRule = 37 "rgbMul" ifFalse: [ - ^self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font ]. - - "We need to do a second pass. The colormap set is for use in the second pass." - secondPassMap _ colorMap. - sourceDepth _ sourceForm depth. - destDepth _ destForm depth. - colorMap _ sourceDepth ~= destDepth - ifTrue: [ Colour cachedColormapFrom: sourceDepth to: destDepth ]. - answer := self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font. - colorMap := secondPassMap. - secondPassMap ifNotNil: [ - prevRule := combinationRule. - combinationRule := 20. "rgbAdd" - self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font. - combinationRule := prevRule ]. - ^answer! ! -!GrafPort methodsFor: 'private' stamp: 'jmv 5/12/2016 14:52' prior: 16850173! - cachedFontColormapFrom1BitTo: destDepth - - | map dstIndex | - CachedFontColorMaps - ifNil: [CachedFontColorMaps _ Array new: 6]. - - dstIndex _ destDepth highBit. - (CachedFontColorMaps at: dstIndex) ifNotNil: [ :m | ^ m ]. - - map _ (Colour cachedColormapFrom: 1 to: destDepth) copy. - CachedFontColorMaps at: dstIndex put: map. - ^ map! ! -!GrafPort methodsFor: 'private' stamp: 'jmv 5/12/2016 14:55' prior: 16850186! - colorConvertingMap: targetColour from: sourceDepth to: destDepth keepSubPixelAA: keepSubPix - "Note: The color converting map for sourceDepth=16 and for sourceDepth=32 are the same" - - | srcIndex dstIndex map mapsForSource mapsForSourceAndDest | - ColorConvertingMaps - ifNil: [ColorConvertingMaps _ (1 to: 6) collect: [:i | Array new: 6]]. - - srcIndex _ sourceDepth highBit. - sourceDepth > 8 ifTrue: [ srcIndex _ keepSubPix ifTrue: [5] ifFalse: [6] ]. - dstIndex _ destDepth highBit. - - mapsForSource _ ColorConvertingMaps at: srcIndex. - (mapsForSourceAndDest _ mapsForSource at: dstIndex) ifNil: [ - mapsForSourceAndDest _ mapsForSource at: dstIndex put: Dictionary new ]. - - map _ mapsForSourceAndDest at: targetColour ifAbsentPut: [ - Colour - computeColorConvertingMap: targetColour - from: sourceDepth - to: destDepth - keepSubPixelAA: keepSubPix ]. - - ^ map! ! -!GrafPort methodsFor: 'private' stamp: 'jmv 4/17/2014 16:57' prior: 16850225! - setRuleAndMapFor: sourceDepth foregroundColor: foregroundColor - - | targetColor destDepth | - destDepth _ destForm depth. - halftoneForm _ nil. "Don't use fillColor. Use a more powerful ColorMap" - - sourceDepth = 1 ifTrue: [ - self combinationRule: Form paint. - "Set up color map for a different source depth (color font)" - "Uses caching for reasonable efficiency" - colorMap _ self cachedFontColormapFrom1BitTo: destDepth. - colorMap at: 1 put: (destForm pixelValueFor: Colour transparent). - colorMap at: 2 put: (destForm pixelValueFor: foregroundColor) ] - - ifFalse: [ - "Enable subpixel rendering if requested, but never for translucent text: - This technique always draws opaque text. This could be added, by using an extra colormap for the rgbMul phase... - So far, no need arised for doing so." - (sourceDepth > 8 and: [ - Preferences subPixelRenderFonts and: [ foregroundColor = Colour black or: [ - Preferences subPixelRenderColorFonts and: [ foregroundColor isOpaque ]]]]) ifTrue: [ - destDepth > 8 ifTrue: [ - "rgbMul is equivalent to component alpha blend if text is black (only faster, hehe)" - self combinationRule: 37. "rgbMul" - colorMap _ (foregroundColor ~= Colour black or: [ - destDepth = 32 and: [ destForm ~~ Display or: [Preferences properDisplayAlphaForFonts] ]]) ifTrue: [ - "rgbMul / rgbAdd IS component alpha blend for any color of text (neat trick, eh!!)" - "This colorMap is to be used on the second pass with rule 20 (rgbAdd) - See #displayString:from:to:at:strikeFont:color:" - "Note: In 32bpp, if we want the correct alpha in the result, we need the second pass, as the destination could have transparent pixels, - and we need to add to the alpha channel" - self colorConvertingMap: foregroundColor from: sourceDepth to: destDepth keepSubPixelAA: true]] - ifFalse: [ - self combinationRule: 25. "Paint" - targetColor _ foregroundColor = Colour black ifFalse: [ foregroundColor ]. - colorMap _ self colorConvertingMap: targetColor from: sourceDepth to: destDepth keepSubPixelAA: true]] - ifFalse: [ - "Do not use rule 34 for 16bpp display. TTCFont uses it, but it builds a glyphs cache for each color used!!" - self combinationRule: (destDepth = 32 ifTrue: [34 "alphaBlendScaled"] ifFalse: [25 "Paint"]). - colorMap _ self colorConvertingMap: foregroundColor from: sourceDepth to: destDepth keepSubPixelAA: false]]! ! -!Color methodsFor: 'conversions' stamp: 'bf 4/18/2001 16:25' prior: 16815566! - makeForegroundColor - "Make a foreground color contrasting with me" - ^self luminance >= 0.5 - ifTrue: [Colour black] - ifFalse: [Colour white]! ! -!Color methodsFor: 'groups of shades' stamp: 'tk 6/18/96' prior: 16815760! - mix: color2 shades: thisMany - "Return an array of thisMany colors from self to color2. Very useful for displaying color based on a variable in your program. " - "Color showColors: (Color red mix: Colour green shades: 12)" - - | redInc greenInc blueInc rr gg bb c out | - thisMany = 1 ifTrue: [^ Array with: color2]. - redInc _ color2 red - self red / (thisMany-1). - greenInc _ color2 green - self green / (thisMany-1). - blueInc _ color2 blue - self blue / (thisMany-1). - rr _ self red. gg _ self green. bb _ self blue. - out _ (1 to: thisMany) collect: [:num | - c _ Colour r: rr g: gg b: bb. - rr _ rr + redInc. - gg _ gg + greenInc. - bb _ bb + blueInc. - c]. - out at: out size put: color2. "hide roundoff errors" - ^ out -! ! -!Color methodsFor: 'groups of shades' stamp: 'di 10/23/2000 09:45' prior: 16815785! - wheel: thisMany - "An array of thisMany colors around the color wheel starting at self and ending all the way around the hue space just before self. Array is of length thisMany. Very useful for displaying color based on a variable in your program. " - - | sat bri hue step c | - sat _ self saturation. - bri _ self brightness. - hue _ self hue. - step _ 360.0 / (thisMany max: 1). - ^ (1 to: thisMany) collect: [:num | - c _ Colour h: hue s: sat v: bri. "hue is taken mod 360" - hue _ hue + step. - c]. -" -(Color wheel: 8) withIndexDo: [:c :i | Display fill: (i*10@20 extent: 10@20) fillColor: c] -"! ! -!Color methodsFor: 'named colors' stamp: 'KenD 1/26/2013 16:33' prior: 16815842! - closestColor - "Answer the closest matching color in the colorNames dictionary" - -" - (Colour red lighter lighter) closestColour explore. -" - ^ self closestColorFrom: (Colour colorNamesDict)! ! -!Color methodsFor: 'named colors' stamp: 'KenD 1/26/2013 16:36' prior: 16815850! - closestColorAssociation - "Answer this color's closest name->color match." - -" - (Colour blue lighter lighter) closestColorAssociation explore. -" - ^ self closestAssocFrom: (Colour colorNamesDict)! ! -!Color methodsFor: 'named colors' stamp: 'KenD 1/26/2013 16:36' prior: 16815867! - closestColorName - "Answer the name symbol of the closest matching color in the colorNames dictionary" -" - (Colour red lighter lighter) closestColour name. -" - - ^ self closestNameFrom: (Colour colorNamesDict)! ! -!Color methodsFor: 'other' stamp: 'KenD 7/18/2015 20:41' prior: 16815891! - colorName - "Return this color's name, or nil if it has no name. Only returns a name if it exactly matches the named color." - - ^(Colour colorNamesDict keyAtValue: self ifAbsent: [nil]) -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:27:03' prior: 16816085! - * aNumber - "Answer this color with its RGB multiplied by the given number. " - " - (Color brown *2) display - " - ^ Colour new - setRed: (self red * aNumber min: 1.0 max: 0.0) - green: (self green * aNumber min: 1.0 max: 0.0) - blue: (self blue * aNumber min: 1.0 max: 0.0) - colorSpace: colorSpace! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:27:06' prior: 16816097! -+ aColor - "Answer this color mixed with the given color in an additive color space. " - " - (Color blue + Color green) display - " - ^ Colour new - setRed: (self red + aColor red min: 1.0 max: 0.0) - green: (self green + aColor green min: 1.0 max: 0.0) - blue: (self blue + aColor blue min: 1.0 max: 0.0) - colorSpace: colorSpace! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:27:09' prior: 16816110! -- aColor - "Answer aColor is subtracted from the given color in an additive color space. " - " - (Color white - Color red) display - " - ^ Colour new - setRed: (self red - aColor red min: 1.0 max: 0.0) - green: (self green - aColor green min: 1.0 max: 0.0) - blue: (self blue - aColor blue min: 1.0 max: 0.0) - colorSpace: colorSpace! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:27:10' prior: 16816123! - / aNumber - "Answer this color with its RGB divided by the given number. " - " - (Color red / 2) display - " - ^ Colour new - setRed: (self red / aNumber min: 1.0 max: 0.0) - green: (self green / aNumber min: 1.0 max: 0.0) - blue: (self blue / aNumber min: 1.0 max: 0.0) - colorSpace: colorSpace! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:34:18' prior: 16816135! - adjustBrightness: brightness - "Adjust the relative brightness of this color. (lowest value is 0.005 so that hue information is not lost)" - - ^ Colour - h: self hue - s: self saturation - v: (self brightness + brightness min: 1.0 max: 0.005) - alpha: self alpha! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:34:22' prior: 16816146! - adjustSaturation: saturation brightness: brightness - "Adjust the relative saturation and brightness of this color. (lowest value is 0.005 so that hue information is not lost)" - - ^ Colour - h: self hue - s: (self saturation + saturation min: 1.0 max: 0.005) - v: (self brightness + brightness min: 1.0 max: 0.005) - alpha: self alpha! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:28:01' prior: 16816159! - alpha: alphaValue - "Return a new TranslucentColor with the given amount of opacity ('alpha')." - alphaValue = 1.0 ifFalse: [ - ^ TranslucentColour new - setRed: self red - green: self green - blue: self blue - alpha: alphaValue - colorSpace: colorSpace ]! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:34:26' prior: 16816170! - alphaMixed: proportion with: aColour - "Answer this color mixed with the given color. The proportion, a number - between 0.0 and 1.0, determines what what fraction of the receiver to - use in the mix. For example, 0.9 would yield a color close to the - receiver. This method uses RGB interpolation; HSV interpolation can lead - to surprises. Mixes the alphas (for transparency) also." - - | frac1 frac2 | - frac1 _ proportion asFloat min: 1.0 max: 0.0. - frac2 _ 1.0 - frac1. - ^ Colour - r: self red * frac1 + (aColour red * frac2) - g: self green * frac1 + (aColour green * frac2) - b: self blue * frac1 + (aColour blue * frac2) - alpha: self alpha * frac1 + (aColour alpha * frac2)! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/23/2002 01:38' prior: 16816210! - blacker - - ^ self alphaMixed: 0.8333 with: Colour black -! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:54' prior: 16816214! - dansDarker - "Return a darker shade of the same color. - An attempt to do better than the current darker method. - (now obsolete, since darker has been changed to do this. -dew)" - ^ Colour h: self hue s: self saturation - v: (self brightness - 0.16 max: 0.0)! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:34:30' prior: 16816240! - mixed: proportion with: aColour - "Mix with another color and do not preserve transpareny. Only use this for extracting the RGB value and mixing it. All other callers should use instead: - aColour alphaMixed: proportion with: anotherColor - " - - | frac1 frac2 | - frac1 _ proportion asFloat min: 1.0 max: 0.0. - frac2 _ 1.0 - frac1. - ^ Colour - r: self red * frac1 + (aColour red * frac2) - g: self green * frac1 + (aColour green * frac2) - b: self blue * frac1 + (aColour blue * frac2)! ! -!Color methodsFor: 'transformations' stamp: 'dew 1/19/2002 01:29' prior: 16816258! - muchDarker - - ^ self alphaMixed: 0.5 with: Colour black -! ! -!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 12:07' prior: 16816262! - muchLighter - - ^ self alphaMixed: 0.233 with: Colour white -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:34:33' prior: 16816266! - negated - "Return an RGB inverted color" - ^Colour - r: 1.0 - self red - g: 1.0 - self green - b: 1.0 - self blue! ! -!Color methodsFor: 'transformations' stamp: 'jmv 9/10/2009 18:41' prior: 16816287! - quiteBlacker - - ^ self alphaMixed: 0.8 with: Colour black -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 9/10/2009 18:44' prior: 16816291! - quiteWhiter - - ^ self alphaMixed: 0.6 with: Colour white! ! -!Color methodsFor: 'transformations' stamp: 'dew 1/19/2002 01:25' prior: 16816304! - slightlyWhiter - - ^ self alphaMixed: 0.85 with: Colour white -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 8/23/2009 23:24' prior: 16816321! - veryMuchDarker - - ^ self alphaMixed: 0.25 with: Colour black -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 7/28/2016 15:43:04' prior: 16816326! - veryMuchLighter - - ^ self alphaMixed: 0.07 with: Colour white! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/23/2002 01:38' prior: 16816331! - whiter - - ^ self alphaMixed: 0.8333 with: Colour white -! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/2/2016 15:04' prior: 16816547! - colorFromPixelValue: p depth: d - "Convert a pixel value for the given display depth into a color." - "Details: For depths of 8 or less, the pixel value is simply looked up in a table. For greater depths, the color components are extracted and converted into a color." - "Warning: In BitBlt, a pixel with pixelValue = 0 is transparent. - Squeak usually assumes that r=g=b=0 => transparent. But this is false if we have alpha (opacity). - A color with r=g=b=0 and opacity = 255 is BLACK, not TRANSPARENT. - Squeak also answers darkest possible blue when asked for black. Again, this is not needed in 32 bits (with alpha). It is also not really needed for 16 bits as we have an extra, unused bit: 16r8000 is not zero, but rgb=0, and hence, black. - The real rule is that pixelValue=0 means transparent. - And that darkest blue must be used instead of black, but only for depths >8 and < 16 (no indexed colors, no alpha) - This method is updated to reflect that." - - | r g b alpha | - - d = 1 ifTrue: [^ self indexedColors at: (p bitAnd: 16r01) + 1]. - - "For the rest of the depths, pixelValue = 0 means transparent, and darkest blue is considered to be black." - p = 0 ifTrue: [ ^Colour transparent ]. - - d = 8 ifTrue: [^ self indexedColors at: (p bitAnd: 16rFF) + 1]. - d = 4 ifTrue: [^ self indexedColors at: (p bitAnd: 16r0F) + 1]. - d = 2 ifTrue: [^ self indexedColors at: (p bitAnd: 16r03) + 1]. - - d = 32 ifTrue: [ - "eight bits per component; 8 bits of alpha" - alpha _ p bitShift: -24. - alpha = 0 ifTrue: [ ^Colour transparent ]. - r _ (p bitShift: -16) bitAnd: 16rFF. - g _ (p bitShift: -8) bitAnd: 16rFF. - b _ p bitAnd: 16rFF. - ^alpha < 255 - ifTrue: [ (Colour r: r g: g b: b range: 255) alpha: alpha asFloat / 255.0 ] - ifFalse: [ Colour r: r g: g b: b range: 255 ]]. - - d = 16 ifTrue: [ - "five bits per component. The most significant bit, unused, allows having real black, without p being zero" - r _ (p bitShift: -10) bitAnd: 16r1F. - g _ (p bitShift: -5) bitAnd: 16r1F. - b _ p bitAnd: 16r1F. - ^ Colour r: r g: g b: b range: 31]. - - d = 15 ifTrue: [ - "five bits per component" - r _ (p bitShift: -10) bitAnd: 16r1F. - g _ (p bitShift: -5) bitAnd: 16r1F. - b _ p bitAnd: 16r1F. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Colour black ]. - ^ Colour r: r g: g b: b range: 31]. - - d = 12 ifTrue: [ - "four bits per component" - r _ (p bitShift: -8) bitAnd: 16rF. - g _ (p bitShift: -4) bitAnd: 16rF. - b _ p bitAnd: 16rF. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Colour black ]. - ^ Colour r: r g: g b: b range: 15]. - - d = 9 ifTrue: [ - "three bits per component" - r _ (p bitShift: -6) bitAnd: 16r7. - g _ (p bitShift: -3) bitAnd: 16r7. - b _ p bitAnd: 16r7. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Colour black ]. - ^ Colour r: r g: g b: b range: 7]. - - self error: 'unknown pixel depth: ', d printString! ! -!Color class methodsFor: 'class initialization' stamp: '' prior: 16816881! -initializeIndexedColors - "Build an array of colors corresponding to the fixed colormap used - for display depths of 1, 2, 4, or 8 bits." - "Colour initializeIndexedColors" - - | a index grayVal | - a _ Array new: 256. - - "1-bit colors (monochrome)" - a at: 1 put: (Colour r: 1.0 g: 1.0 b: 1.0). "white or transparent" - a at: 2 put: (Colour r: 0.0 g: 0.0 b: 0.0). "black" - - "additional colors for 2-bit color" - a at: 3 put: (Colour r: 1.0 g: 1.0 b: 1.0). "opaque white" - a at: 4 put: (Colour r: 0.5 g: 0.5 b: 0.5). "1/2 gray" - - "additional colors for 4-bit color" - a at: 5 put: (Colour r: 1.0 g: 0.0 b: 0.0). "red" - a at: 6 put: (Colour r: 0.0 g: 1.0 b: 0.0). "green" - a at: 7 put: (Colour r: 0.0 g: 0.0 b: 1.0). "blue" - a at: 8 put: (Colour r: 0.0 g: 1.0 b: 1.0). "cyan" - a at: 9 put: (Colour r: 1.0 g: 1.0 b: 0.0). "yellow" - a at: 10 put: (Colour r: 1.0 g: 0.0 b: 1.0). "magenta" - - a at: 11 put: (Colour r: 0.125 g: 0.125 b: 0.125). "1/8 gray" - a at: 12 put: (Colour r: 0.25 g: 0.25 b: 0.25). "2/8 gray" - a at: 13 put: (Colour r: 0.375 g: 0.375 b: 0.375). "3/8 gray" - a at: 14 put: (Colour r: 0.625 g: 0.625 b: 0.625). "5/8 gray" - a at: 15 put: (Colour r: 0.75 g: 0.75 b: 0.75). "6/8 gray" - a at: 16 put: (Colour r: 0.875 g: 0.875 b: 0.875). "7/8 gray" - - "additional colors for 8-bit color" - "24 more shades of gray (1/32 increments but not repeating 1/8 increments)" - index _ 17. - 1 to: 31 do: [:v | - (v \\ 4) = 0 ifFalse: [ - grayVal _ v / 32.0. - a at: index put: (Colour r: grayVal g: grayVal b: grayVal). - index _ index + 1]]. - - "The remainder of color table defines a color cube with six steps - for each primary color. Note that the corners of this cube repeat - previous colors, but this simplifies the mapping between RGB colors - and color map indices. This color cube spans indices 40 through 255 - (indices 41-256 in this 1-based array)." - 0 to: 5 do: [:r | - 0 to: 5 do: [:g | - 0 to: 5 do: [:b | - index _ 41 + ((36 * r) + (6 * b) + g). - index > 256 ifTrue: [ - self error: 'index out of range in color table compuation']. - a at: index put: (Colour r: r g: g b: b range: 5)]]]. - - IndexedColors _ a. -! ! -!Color class methodsFor: 'examples' stamp: 'jmv 8/17/2012 18:48' prior: 16816950! - colorRampForDepth: depth extent: aPoint - "Returns a form of the given size showing R, G, B, and gray ramps for the given depth. Useful for testing color conversions between different depths." - "(Colour colorRampForDepth: Display depth extent: 256@80) display" - "(Colour colorRampForDepth: 32 extent: 256@80) displayOn: Display at: 0@0 rule: Form paint" - - | f dx dy r | - f _ Form extent: aPoint depth: depth. - dx _ aPoint x // 256. - dy _ aPoint y // 4. - 0 to: 255 do: [:i | - r _ (dx * i)@0 extent: dx@dy. - f fill: r fillColor: (Colour r: i g: 0 b: 0 range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Colour r: 0 g: i b: 0 range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Colour r: 0 g: 0 b: i range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Colour r: i g: i b: i range: 255)]. - ^ f -! ! -!Color class methodsFor: 'examples' stamp: 'jmv 6/18/2017 21:30:09' prior: 16816978! - experimentsTowarsANewColorPalette -" -self experimentsTowarsANewColorPalette -" -| selectedHue selectedSaturation selectedV selectedColor h s v color width height selectedChroma selectedLuminance | -width _ 300. -height _ 120. -selectedColor _ Colour random. -selectedHue _ selectedColor hue. -selectedSaturation _ selectedColor saturation. -selectedChroma _ selectedColor chroma. -selectedV _ selectedColor brightness. -selectedLuminance _ selectedColor luminance. -Display getCanvas fillRectangle: (0@0 extent: height@height) color: selectedColor. -0 to: height do: [ :y | - v _ 1.0 - (y / height). - 0 to: height do: [ :x | - s _ x / height. - color _ Colour new setHue: selectedHue saturation: s brightness: v. - Display colorAt: x@(y+height) put: color - ]. - DisplayScreen screenUpdateRequired: nil -]. -0 to: height do: [ :y | | c | - v _ 1.0 - (y / height). - s _ 1.0 - (y / height). - c _ s. - 0 to: width do: [ :x | - h _ x / width * 360. - - color _ Colour new setHue: h chroma: c luminance: selectedLuminance. -" color _ Colour new setHue: h chroma: c brightness: selectedV." - color ifNil: [ color _ Colour black ]. -" color _ Colour new setHue: h saturation: s brightness: selectedV." - Display colorAt: x+height@y put: color. - - color _ Colour new setHue: h chroma: selectedChroma luminance: v. -" color _ Colour new setHue: h chroma: selectedChroma brightness: v." - color ifNil: [ color _ Colour black ]. -" color _ Colour new setHue: h saturation: selectedSaturation brightness: v." - Display colorAt: x+height@(y+height) put: color. - - ]. - DisplayScreen screenUpdateRequired: nil -].! ! -!Color class methodsFor: 'examples' stamp: '' prior: 16817055! - showColorCube - "Show a 12x12x12 color cube." - "Colour showColorCube" - - 0 to: 11 do: [:r | - 0 to: 11 do: [:g | - 0 to: 11 do: [:b | - Display fill: (((r*60) + (b*5)) @ (g*5) extent: 5@5) - fillColor: (Colour r: r g: g b: b range: 11)]]]. -! ! -!Color class methodsFor: 'examples' stamp: '' prior: 16817075! - showHSVPalettes - "Shows a palette of hues, varying the saturation and brightness for each one. Best results are with depths 16 and 32." - "Color showHSVPalettes" - - | left top c | - left _ top _ 0. - 0 to: 179 by: 15 do: [:h | - 0 to: 10 do: [:s | - left _ (h * 4) + (s * 4). - 0 to: 10 do: [:v | - c _ Colour h: h s: s asFloat / 10.0 v: v asFloat / 10.0. - top _ (v * 4). - Display fill: (left@top extent: 4@4) fillColor: c. - - c _ Colour h: h + 180 s: s asFloat / 10.0 v: v asFloat / 10.0. - top _ (v * 4) + 50. - Display fill: (left@top extent: 4@4) fillColor: c]]]. -! ! -!Color class methodsFor: 'examples' stamp: '' prior: 16817112! - wheel: thisMany - "Return a collection of thisMany colors evenly spaced around the color wheel." - "Color showColors: (Color wheel: 12)" - - ^ Colour wheel: thisMany saturation: 0.9 brightness: 0.7 -! ! -!Color class methodsFor: 'examples' stamp: '' prior: 16817120! - wheel: thisMany saturation: s brightness: v - "Return a collection of thisMany colors evenly spaced around the color wheel, all of the given saturation and brightness." - "Colour showColors: (Colour wheel: 12 saturation: 0.4 brightness: 1.0)" - "Colour showColors: (Colour wheel: 12 saturation: 0.8 brightness: 0.5)" - - ^ (Colour h: 0.0 s: s v: v) wheel: thisMany -! ! -!Color class methodsFor: 'colormaps' stamp: '' prior: 16817522! - colorMapIfNeededFrom: sourceDepth to: destDepth - "Return a colormap for mapping between the given depths, or nil if no colormap is needed." - "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" - - sourceDepth = destDepth ifTrue: [^ nil]. "not needed if depths are the same" - - (sourceDepth >= 16) & (destDepth >= 16) ifTrue: [ - "mapping is done in BitBlt by zero-filling or truncating each color component" - ^ nil]. - - ^ Colour cachedColormapFrom: sourceDepth to: destDepth -! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 5/12/2016 15:56' prior: 16817637! - computeColormapFromGray8bppForDepth: destDepth - "Return a colormap for displaying a GrayForm at the given depth" - - | newMap | - newMap _ Bitmap new: 256. - 1 to: 256 do: [ :i | - newMap - at: i - put: ((Colour gray: (i-1) asFloat / 255.0) pixelValueForDepth: destDepth)]. - ^ newMap! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 4/17/2015 15:05' prior: 16817648! - computeIndexedColorConvertingMap: targetColor from: sourceDepth to: destDepth - | map | - - map _ (self indexedColors copyFrom: 1 to: (1 bitShift: sourceDepth)) collect: [ :cc | | f c | - f _ 1.0 - (cc red + cc green + cc blue / 3.0 ). - c _ targetColor - ifNotNil: [ - destDepth = 32 - ifTrue: [ targetColor * f alpha: f] - ifFalse: [ targetColor alphaMixed: f*1.5 with: Colour white ]] - ifNil: [ cc ]. - destDepth = 32 - ifTrue: [ c pixelValueForDepth: destDepth] - ifFalse: [ - f = 0.0 - ifTrue: [ 0 ] - ifFalse: [ c pixelValueForDepth: destDepth ]]]. - map _ map as: Bitmap. - ^map! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 21:34:38' prior: 16817670! - computeRGBColorConvertingMap: targetColour to: destDepth keepSubPixelAA: keepSubPix - "Builds a colormap intended to convert from subpixelAA black values to targetColour values. - keepSubPix - ifTrue: [ Answer colors that also include subpixelAA ] - ifFalse: [ - Take fullpixel luminance level. Apply it to targetColor. - I.e. answer colors with NO subpixelAA ]" - - | mask map c bitsPerColour r g b f v | - - destDepth > 8 - ifTrue: [bitsPerColour _ 5] "retain maximum color resolution" - ifFalse: [bitsPerColour _ 4]. - "Usually a bit less is enough, but make it configurable" - bitsPerColour _ bitsPerColour min: Preferences aaFontsColormapDepth. - mask _ (1 bitShift: bitsPerColour) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColour)). - 0 to: map size - 1 do: [:i | - r _ (i bitShift: 0 - (2 * bitsPerColour)) bitAnd: mask. - g _ (i bitShift: 0 - bitsPerColour) bitAnd: mask. - b _ (i bitShift: 0) bitAnd: mask. - f _ 1.0 - (r + g + b / 3.0 / mask). - c _ targetColour - ifNotNil: [ - (keepSubPix and: [destDepth > 8]) ifTrue: [ - Colour - r: 1.0 - (r asFloat/mask) * targetColour red - g: 1.0 - (g asFloat/mask) * targetColour green - b: 1.0 - (b asFloat/mask) * targetColour blue - alpha: f * targetColour alpha "alpha will be ignored below, in #pixelValueForDepth: if destDepth ~= 32" ] - ifFalse: [ - destDepth = 32 - ifTrue: [ targetColour * f alpha: f * targetColour alpha ] - ifFalse: [ targetColour alphaMixed: f*1.5 with: Colour white ]]] - ifNil: [ Colour r: r g: g b: b range: mask]. "This is currently used only to keep some SubPixelAA on destDepth = 8, using a single pass of rule 25" - v _ destDepth = 32 - ifTrue: [ c pixelValueForDepth: destDepth] - ifFalse: [ - f < 0.1 - ifTrue: [ 0 ] - ifFalse: [ c pixelValueForDepth: destDepth ]]. - map at: i + 1 put: v ]. - ^ map! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 21:34:42' prior: 16817730! - computeRGBColormapFor: destDepth bitsPerColor: bitsPerColor - "Compute a colorMap for translating from 16-bit or 32-bit RGB color to the given depth, using the given number of of bits per color component." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Colour maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | mask map c | - (#(3 4 5) includes: bitsPerColor) - ifFalse: [self error: 'BitBlt only supports 3, 4, or 5 bits per color component']. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - c _ Colour - r: ((i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask) - g: ((i bitShift: 0 - bitsPerColor) bitAnd: mask) - b: ((i bitShift: 0) bitAnd: mask) - range: mask. - map at: i + 1 put: (c pixelValueForDepth: destDepth)]. - - map at: 1 put: (Colour transparent pixelWordForDepth: destDepth). "zero always transparent" - ^ map -! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 6/18/2017 21:34:46' prior: 16817772! - computeRGBColormapForGray8 - "Compute a colorMap for translating from 16-bit or 32-bit RGB color to 8bpp grays, using the default number of of bits per color component." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Colour maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | bitsPerColor mask map c | - bitsPerColor _ 5. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - c _ Colour - r: ((i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask) - g: ((i bitShift: 0 - bitsPerColor) bitAnd: mask) - b: ((i bitShift: 0) bitAnd: mask) - range: mask. - map at: i + 1 put: (c luminance * 255) rounded]. - - ^ map! ! -!Color class methodsFor: 'color from user' stamp: 'jmv 3/1/2010 15:13' prior: 16817838! - colorPaletteForDepth: depth extent: chartExtent - "Display a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." - "Note: It is slow to build this palette, so it should be cached for quick access." - "(Color colorPaletteForDepth: 16 extent: 190@60) display" - - | basicHue x y startHue palette transHt vSteps transCaption grayWidth hSteps | - palette _ Form extent: chartExtent depth: depth. - transCaption _ - (Form extent: 34@9 depth: 1 - fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0) - offset: 0@0). - transHt _ transCaption height. - palette fillWhite: (0@0 extent: palette width@transHt). - palette fillBlack: (0@transHt extent: palette width@1). - transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0). - grayWidth _ 10. - startHue _ 338.0. - vSteps _ palette height - transHt // 2. - hSteps _ palette width - grayWidth. - x _ 0. - startHue to: startHue + 360.0 by: 360.0/hSteps do: [ :h | - basicHue _ Colour h: h asFloat s: 1.0 v: 1.0. - y _ transHt+1. - 0 to: vSteps do: [ :n | | c | - c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Colour white. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - 1 to: vSteps do: [ :n | | c | - c _ Colour black mixed: (n asFloat / vSteps asFloat) with: basicHue. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - x _ x + 1]. - y _ transHt + 1. - 1 to: vSteps * 2 do: [ :n | | c | - c _ Colour black mixed: (n asFloat / (vSteps*2) asFloat) with: Colour white. - palette fill: (x@y extent: 10@1) fillColor: c. - y _ y + 1]. - ^ palette -! ! -!Color class methodsFor: 'color from user' stamp: 'jmv 7/27/2009 11:32' prior: 16817895! - colorTest: depth extent: chartExtent colorMapper: colorMapper - "Create a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." - "Note: It is slow to build this palette, so it should be cached for quick access." - "(Color colorTest: 32 extent: 570@180 colorMapper: [:c | c]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 7) asInteger / 7 - g: (c green * 7) asInteger / 7 - b: (c blue * 3) asInteger / 3]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 5) asInteger / 5 - g: (c green * 5) asInteger / 5 - b: (c blue * 5) asInteger / 5]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 15) asInteger / 15 - g: (c green * 15) asInteger / 15 - b: (c blue * 15) asInteger / 15]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 31) asInteger / 31 - g: (c green * 31) asInteger / 31 - b: (c blue * 31) asInteger / 31]) display" - - | basicHue x y c startHue palette transHt vSteps transCaption grayWidth hSteps | - palette _ Form extent: chartExtent depth: depth. - transCaption _ - (Form extent: 34@9 depth: 1 - fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0) - offset: 0@0). - transHt _ transCaption height. - palette fillWhite: (0@0 extent: palette width@transHt). - palette fillBlack: (0@transHt extent: palette width@1). - transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0). - grayWidth _ 10. - startHue _ 338.0. - vSteps _ palette height - transHt // 2. - hSteps _ palette width - grayWidth. - x _ 0. - startHue to: startHue + 360.0 by: 360.0/hSteps do: [:h | - basicHue _ Colour h: h asFloat s: 1.0 v: 1.0. - y _ transHt+1. - 0 to: vSteps do: [:n | - c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Colour white. - c _ colorMapper value: c. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - 1 to: vSteps do: [:n | - c _ Colour black mixed: (n asFloat / vSteps asFloat) with: basicHue. - c _ colorMapper value: c. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - x _ x + 1]. - y _ transHt + 1. - 1 to: vSteps * 2 do: [:n | - c _ Colour black mixed: (n asFloat / (vSteps*2) asFloat) with: Colour white. - c _ colorMapper value: c. - palette fill: (x@y extent: 10@1) fillColor: c. - y _ y + 1]. - ^ palette -! ! -!Color class methodsFor: 'color name lookup' stamp: 'KenD 1/28/2013 20:34' prior: 16817983! - defaultColorNamesDictionary - "Answer a amall but useful name->color dictionary" - - | defaultDict | - "Meld most used xkcd colors into traditional colors." - defaultDict := (self traditionalColorNamesDictionary addAll: - self xkcdFirst48ColorNamesDictionary; - yourself). - - "Override traditional names existing in extended XKCD naming" - defaultDict at: #lightYellow put: (Colour r: 1.0 g: 0.996 b: 0.478). - defaultDict at: #lightOrange put: (Colour r: 0.992 g: 0.667 b: 0.283). - defaultDict at: #lightCyan put: (Colour r: 0.674 g: 1.0 b: 0.988). - defaultDict at: #lightRed put: (Colour r: 1.0 g: 0.279 b: 0.298). - defaultDict at: #lightMagenta put: (Colour r: 0.98 g: 0.372 b: 0.969). - - ^defaultDict! ! -!Color class methodsFor: 'color name lookup' stamp: 'KenD 2/1/2013 14:39' prior: 16818009! - doesNotUnderstand: aMessage - "Some code takes - Colour colorNames - and does - Colour perform: aColorname. - - Make this work." - - ^(Colour colorNamesDict) - at: (aMessage selector) - ifAbsent: [super doesNotUnderstand: aMessage]! ! -!Color class methodsFor: 'color name lookup' stamp: 'KenD 7/25/2014 21:22' prior: 16818027! - setColorNamesDict: aNameColorDictionary - "Answer the current dictionary of name->color associations." - - "Note: This is a non-standard name because this is a non-standard action!! - Do this if you really, really know what you are doing." - - "Some Colors are required for proper system operation" - Colour defaultColorNamesDictionary keysAndValuesDo: [ :colorName :colorValue | - aNameColorDictionary at: colorName ifAbsentPut: colorValue - ]. - - ColorNamesDict := aNameColorDictionary! ! -!Color class methodsFor: 'color name lookup' stamp: 'sqr 10/21/2016 12:44:48' prior: 16818045! - traditionalColorNamesDictionary - "Answer a dictionary of Squeak traditional name->color associations.." - - | nameDict | - nameDict _ Dictionary new. - nameDict at: #black put: (Colour r: 0 g: 0 b: 0). - nameDict at: #veryVeryDarkGray put: (Colour r: 0.125 g: 0.125 b: 0.125). - nameDict at: #veryDarkGray put: (Colour r: 0.25 g: 0.25 b: 0.25). - nameDict at: #darkGray put: (Colour r: 0.375 g: 0.375 b: 0.375). - nameDict at: #gray put: (Colour r: 0.5 g: 0.5 b: 0.5). - nameDict at: #lightGray put: (Colour r: 0.625 g: 0.625 b: 0.625). - nameDict at: #veryLightGray put: (Colour r: 0.75 g: 0.75 b: 0.75). - nameDict at: #veryVeryLightGray put: (Colour r: 0.875 g: 0.875 b: 0.875). - nameDict at: #white put: (Colour r: 1.0 g: 1.0 b: 1.0). - nameDict at: #red put: (Colour r: 1.0 g: 0 b: 0). - nameDict at: #yellow put: (Colour r: 1.0 g: 1.0 b: 0). - nameDict at: #green put: (Colour r: 0 g: 1.0 b: 0). - nameDict at: #cyan put: (Colour r: 0 g: 1.0 b: 1.0). - nameDict at: #blue put: (Colour r: 0 g: 0 b: 1.0). - nameDict at: #magenta put: (Colour r: 1.0 g: 0 b: 1.0). - nameDict at: #brown put: (Colour r: 0.6 g: 0.2 b: 0). - nameDict at: #orange put: (Colour r: 1.0 g: 0.6 b: 0). - nameDict at: #lightRed put: (Colour r: 1.0 g: 0.8 b: 0.8). - nameDict at: #lightYellow put: (Colour r: 1.0 g: 1.0 b: 0.8). - nameDict at: #lightGreen put: (Colour r: 0.8 g: 1.0 b: 0.6). - nameDict at: #lightCyan put: (Colour r: 0.4 g: 1.0 b: 1.0). - nameDict at: #lightBlue put: (Colour r: 0.8 g: 1.0 b: 1.0). - nameDict at: #lightMagenta put: (Colour r: 1.0 g: 0.8 b: 1.0). - nameDict at: #lightBrown put: (Colour r: 1.0 g: 0.6 b: 0.2). - nameDict at: #lightOrange put: (Colour r: 1.0 g: 0.8 b: 0.4). - nameDict at: #transparent put: (TranslucentColour r: 0.0 g: 0.0 b: 0.0 alpha: 0.0). - - ^nameDict -! ! -!Color class methodsFor: 'color name lookup' stamp: 'jmv 6/30/2014 15:22' prior: 16818102! - xkcdFirst48ColorNamesDictionary - "XKCD color names are based on a survey oc colors people call by the same name. - http://blog.xkcd.com/2010/05/03/color-survey-results/" - - "Answer a dictionary of the most agreed upon first 48 xkcd colors" -" - Colour xkcdFirst48ColorNamesDictionary explore. -" - | xkcdDict | - xkcdDict := Dictionary new - at: #lightPink put: (Colour fromString: '#ffd1df') ; - at: #mustard put: (Colour fromString: '#ceb301') ; - at: #indigo put: (Colour fromString: '#380282') ; - at: #lime put: (Colour fromString: '#aaff32') ; - at: #seaGreen put: (Colour fromString: '#53fca1') ; - at: #periwinkle put: (Colour fromString: '#8e82fe') ; - at: #darkPink put: (Colour fromString: '#cb416b') ; - at: #oliveGreen put: (Colour fromString: '#677a04') ; - at: #peach put: (Colour fromString: '#ffb07c') ; - at: #paleGreen put: (Colour fromString: '#c7fdb5') ; - at: #lightBrown put: (Colour fromString: '#ad8150') ; - at: #hotPink put: (Colour fromString: '#ff028d') ; - at: #black put: (Colour fromString: '#000000') ; - at: #lilac put: (Colour fromString: '#cea2fd') ; - at: #navyBlue put: (Colour fromString: '#001146') ; - at: #royalBlue put: (Colour fromString: '#0504aa') ; - at: #beige put: (Colour fromString: '#e6daa6') ; - at: #salmon put: (Colour fromString: '#ff796c') ; - at: #olive put: (Colour fromString: '#6e750e') ; - at: #maroon put: (Colour fromString: '#650021') ; - at: #brightGreen put: (Colour fromString: '#01ff07') ; - at: #darkPurple put: (Colour fromString: '#35063e') ; - at: #mauve put: (Colour fromString: '#ae7181') ; - at: #forestGreen put: (Colour fromString: '#06470c') ; - at: #aqua put: (Colour fromString: '#13eac9') ; - at: #cyan put: (Colour fromString: '#00ffff') ; - at: #tan put: (Colour fromString: '#d1b26f') ; - at: #darkBlue put: (Colour fromString: '#00035b') ; - at: #lavender put: (Colour fromString: '#c79fef') ; - at: #turquoise put: (Colour fromString: '#06c2ac') ; - at: #darkGreen put: (Colour fromString: '#033500') ; - at: #violet put: (Colour fromString: '#9a0eea') ; - at: #lightPurple put: (Colour fromString: '#bf77f6') ; - at: #limeGreen put: (Colour fromString: '#89fe05') ; - at: #grey put: (Colour fromString: '#929591') ; - at: #skyBlue put: (Colour fromString: '#75bbfd') ; - at: #yellow put: (Colour fromString: '#ffff14') ; - at: #magenta put: (Colour fromString: '#c20078') ; - at: #lightGreen put: (Colour fromString: '#96f97b') ; - at: #orange put: (Colour fromString: '#f97306') ; - at: #teal put: (Colour fromString: '#029386') ; - at: #lightBlue put: (Colour fromString: '#95d0fc') ; - at: #red put: (Colour fromString: '#e50000') ; - at: #brown put: (Colour fromString: '#653700') ; - at: #pink put: (Colour fromString: '#ff81c0') ; - at: #blue put: (Colour fromString: '#0343df') ; - at: #green put: (Colour fromString: '#15b01a') ; - at: #purple put: (Colour fromString: '#7e1e9c') ; - yourself. - - ^xkcdDict - -! ! -!TranslucentColor methodsFor: 'conversions' stamp: 'jmv 6/18/2017 21:28:31' prior: 16939024! - alpha: alphaValue - "Return a new TranslucentColor with the given amount of opacity ('alpha')." - alphaValue = 1.0 ifTrue: [ - ^ Colour new - setRed: self red - green: self green - blue: self blue - colorSpace: colorSpace]. - ^ super alpha: alphaValue! ! -!Rectangle methodsFor: 'transforming' stamp: 'jmv 9/24/2013 22:36' prior: 16898974! - newRectFrom: newRectBlock - "Track the outline of a new rectangle until mouse button changes. - newFrameBlock produces each new rectangle from the previous" - | rect newRect buttonStart buttonNow aHand delay | - delay _ Delay forMilliseconds: 10. - buttonStart _ buttonNow _ Sensor isAnyButtonPressed. - rect _ self. - Display border: rect width: 2 rule: Form reverse fillColor: Colour gray. - [buttonNow == buttonStart] whileTrue: - [delay wait. - buttonNow _ Sensor isAnyButtonPressed. - newRect _ newRectBlock value: rect. - newRect = rect ifFalse: - [Display border: rect width: 2 rule: Form reverse fillColor: Colour gray. - Display border: newRect width: 2 rule: Form reverse fillColor: Colour gray. - rect _ newRect]]. - Display border: rect width: 2 rule: Form reverse fillColor: Colour gray. - " pay the price for reading the sensor directly ; get this party started " - aHand _ self runningWorld activeHand. - aHand - newMouseFocus: nil; - flushEvents. - Sensor processSensorEvent: Sensor createMouseEvent discardingMouseEvents: false. - ^ rect! ! -!StrikeFont methodsFor: 'emphasis' stamp: 'jmv 4/10/2015 23:21' prior: 16914485! - makeBoldGlyphs - "Make a bold set of glyphs with same widths by ORing 1 bit to the right - (requires at least 1 pixel of intercharacter space)" - | g bonkForm | - g _ glyphs copy. - bonkForm _ (Form extent: 1@16) fillBlack offset: -1@0. - self bonk: g with: bonkForm. - glyphs depth = 1 ifTrue: [ - g copyBits: g boundingBox from: g at: (1@0) - clippingBox: g boundingBox rule: Form under ] - ifFalse: [ - 0 to: g width - 2 do: [ :x | 0 to: g height-1 do: [ :y | - (glyphs colorAt: x@y) = Colour white ifFalse: [ - g colorAt: x+1@y put: - ((glyphs colorAt: x+1@y) = Colour white - ifTrue: [glyphs colorAt: x@y] - ifFalse: [Colour black])]]]]. - glyphs _ g. - self isSynthetic: true! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 9/2/2016 11:03:22' prior: 16914725! - makeControlCharsVisible - | glyph | - self characterToGlyphMap. - glyph _ self glyphAt: (Character space). - glyph border: glyph boundingBox width: 1 fillColor: Colour blue. - self glyphAt: (Character numericValue: 134) put: glyph. - - "Keep tab(9), lf(10), cr(13) and space(32) transparent or whatever the user chose" - #(0 1 2 3 4 5 6 7 8 11 12 14 15 16 17 18 19 20 21 22 23 24 25 26 27) - do: [ :ascii | - characterToGlyphMap at: ascii + 1 put: 134 ]! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 9/2/2016 11:03:27' prior: 16914749! - makeCrVisible - | glyph | - self characterToGlyphMap. - glyph _ self glyphAt: (Character numericValue: 182). - glyph border: glyph boundingBox width: 1 fillColor: Colour blue. -" glyph _ glyph reverse." - self glyphAt: (Character numericValue: 133) put: glyph. - characterToGlyphMap at: 14 put: 133! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 9/2/2016 11:03:31' prior: 16914768! - makeLfVisible - | glyph | - self characterToGlyphMap. - glyph _ self glyphAt: (Character numericValue: 163). - glyph border: glyph boundingBox width: 1 fillColor: Colour blue. -" glyph _ glyph reverse." - self glyphAt: (Character numericValue: 132) put: glyph. - characterToGlyphMap at: 11 put: 132! ! -!Morph methodsFor: 'accessing' stamp: 'jmv 8/21/2012 20:40' prior: 16873946! - color - - ^ Colour blue! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 4/14/2015 08:53' prior: 16874298! - drawOn: aCanvas - "A canvas is already set with a proper transformation from our coordinates to those of the Canvas target." - aCanvas - fillRectangle: self morphLocalBounds - color: Colour blue! ! -!RectangleLikeMorph methodsFor: 'initialization' stamp: 'jmv 8/21/2012 18:46' prior: 16899196! - defaultColor - ^ Colour orange! ! -!BorderedRectMorph methodsFor: 'initialization' stamp: 'jmv 8/17/2014 21:28' prior: 16790410! - defaultBorderColor - "answer the default border color/fill style for the receiver" - ^ Colour gray! ! -!PasteUpMorph methodsFor: 'initialization' stamp: 'jmv 6/18/2017 21:33:36' prior: 16887268! -defaultBorderColor - "answer the default border color/fill style for the receiver" - ^ Colour - r: 0.861 - g: 1.0 - b: 0.722! ! -!PasteUpMorph methodsFor: 'initialization' stamp: 'jmv 6/18/2017 21:33:40' prior: 16887280! - defaultColor - "answer the default color/fill style for the receiver" - ^ Colour - r: 0.8 - g: 1.0 - b: 0.6! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 11/10/2013 19:32' prior: 16887655! - findWindow: evt - "Present a menu names of windows and naked morphs, and activate the one that gets chosen. Collapsed windows appear below line, expand if chosen; naked morphs appear below second line; if any of them has been given an explicit name, that is what's shown, else the class-name of the morph shows; if a naked morph is chosen, bring it to front and have it don a halo." - | menu expanded collapsed nakedMorphs | - menu _ MenuMorph new. - expanded _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed not ]. - collapsed _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed ]. - nakedMorphs _ self submorphsSatisfying: [ :m | - (m is: #SystemWindow) not ]. - expanded isEmpty & (collapsed isEmpty & nakedMorphs isEmpty) ifTrue: [ ^ Smalltalk beep ]. - (expanded asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #activateAndForceLabelToShow. - w canDiscardEdits ifFalse: [ menu lastItem color: Colour red ]]. - expanded isEmpty | (collapsed isEmpty & nakedMorphs isEmpty) ifFalse: [ menu addLine ]. - (collapsed asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #expand. - w canDiscardEdits ifFalse: [ menu lastItem color: Colour red ]]. - nakedMorphs isEmpty ifFalse: [ menu addLine ]. - (nakedMorphs asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #comeToFrontAndAddHalo ]. - menu addTitle: 'find window'. - menu popUpInWorld: self! ! -!EllipseMorph methodsFor: 'visual properties' stamp: 'ar 6/25/1999 11:14' prior: 16837113! - defaultColor - "Return the default fill style for the receiver" - ^Colour yellow! ! -!PluggableMorph methodsFor: 'initialization' stamp: 'jmv 8/6/2014 09:15' prior: 16889451! - defaultColor - "answer the default color/fill style for the receiver" - ^ Colour lightGray! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 9/9/2012 23:50' prior: 16888164! - drawRoundGradientLookOn: aCanvas - | r colorForButton rect bottomFactor topFactor | - - self isPressed - ifFalse: [ - topFactor _ Theme current buttonGradientTopFactor. - bottomFactor _ Theme current buttonGradientBottomFactor. - self mouseIsOver - ifTrue: [ - colorForButton _ Colour h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ - colorForButton _ color ]] - ifTrue: [ - topFactor _ Theme current buttonGradientBottomFactor. - bottomFactor _ Theme current buttonGradientTopFactor. - colorForButton _ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - Theme current useButtonGradient - ifTrue: [ - rect _ (0@0 extent: extent) insetBy: 1@3. - aCanvas - roundRect: rect - color: colorForButton - radius: r - gradientTop: topFactor - gradientBottom: bottomFactor - gradientHeight: Theme current buttonGradientHeight ] - ifFalse: [ - rect _ (0@0 extent: extent) insetBy: 1@3. - aCanvas roundRect: rect color: colorForButton radius: r ] - ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawEmbossedLabelOn: aCanvas ] - ifFalse: [ self drawRegularLabelOn: aCanvas ]! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 4/12/2012 22:37' prior: 16888215! - iconColor - - ^ self isPressed - ifTrue: [ Colour gray: 0.75 ] - ifFalse: [ - self mouseIsOver - ifTrue: [ Colour gray: 0.75 ] - ifFalse: [ Colour white ]].! ! -!PluggableButtonMorph class methodsFor: 'example' stamp: 'jmv 1/4/2013 13:31' prior: 16888484! - example - " - PluggableButtonMorph example openInWorld - " - - | s1 s2 s3 b1 b2 b3 row | - s1 _ Switch new. - s2 _ Switch new turnOn. - s3 _ Switch new. - s2 onAction: [s3 turnOff]. - s3 onAction: [s2 turnOff]. - b1 _ (PluggableButtonMorph model: s1 stateGetter: #isOn action: #switch) label: 'S1'. - b2 _ (PluggableButtonMorph model: s2 stateGetter: #isOn action: #turnOn) label: 'S2'. - b3 _ (PluggableButtonMorph model: s3 stateGetter: #isOn action: #turnOn) label: 'S3'. - b1 color: Colour lightRed. - b2 color: Colour lightRed. - b3 color: Colour lightRed. - row _ LayoutMorph newRow - addMorphs: (Array with: b1 with: b2 with: b3); - morphExtent: 120@35. - ^ row -! ! -!TextModelMorph methodsFor: 'drawing' stamp: 'cbr 10/10/2012 23:04' prior: 16933987! - drawOn: aCanvas - "Include a thin red inset border for unaccepted edits, or, if the unaccepted edits are known to conflict with a change made somewhere else to the same method (typically), put a thick red frame" - - - | bw bc | - - self flag: #todo. "Integrate this method with the Theme system. --cbr" - - - super drawOn: aCanvas. - bw _ Preferences focusIndicatorWidth. - bc _ nil. - self wantsFrameAdornments ifTrue: [ - model refusesToAccept - ifTrue: [ "Put up feedback showing that code cannot be submitted in this state" - bc _ Colour tan] - ifFalse: [ - self textMorph hasEditingConflicts - ifTrue: [ - bw _ 3. - bc _ Colour red ] - ifFalse: [ - self textMorph hasUnacceptedEdits - ifTrue: [ - bc _ Colour red]]]]. - - (drawKeyboardFocusIndicator and: [ self textMorph hasKeyboardFocus ]) ifTrue: [ - bc ifNil: [ - bc _ Theme current focusIndicator ]] - ifFalse: [ - bc ifNotNil: [ - bc _ bc alphaMixed: 0.4 with: Colour white ]]. - bc ifNotNil: [ - aCanvas frameRectangle: self focusIndicatorRectangle borderWidth: bw color: bc ]! ! -!SystemWindow methodsFor: 'initialization' stamp: 'cbr 11/7/2010 18:58' prior: 16926270! - defaultColor - "answer the default color/fill style for the receiver" - ^ Colour white! ! -!SystemWindow methodsFor: 'menu' stamp: 'jmv 6/7/2013 23:23' prior: 16926535! - setWindowColor: incomingColor - | existingColor aColor | - incomingColor ifNil: [^ self]. "it happens" - aColor _ incomingColor asNontranslucentColor. - aColor = Colour black ifTrue: [^ self]. - existingColor _ self widgetsColor. - existingColor ifNil: [^ Smalltalk beep]. - self widgetsColor: aColor. - self redrawNeeded! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'KenD 8/27/2015 14:39' prior: 16811424! - buildMorphicWindow - " - CodePackageListWindow open: CodePackageList new - " - | dirtyFlags names fileNames upperRow description summary backColor labelBackground textHeigth | - backColor := self textBackgroundColor. - labelBackground := Theme current background. - textHeigth := AbstractFont default height. - - dirtyFlags := PluggableListMorph - model: model - listGetter: #packageDirtyFlags - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - dirtyFlags color: backColor. - dirtyFlags := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Colour transparent) fixedHeight: 4; - addMorph: (StringMorph new contents: ' Unsaved?') fixedHeight: textHeigth; - addMorphUseAll: dirtyFlags. - - names := PluggableListMorph - model: model - listGetter: #packageNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - names color: backColor. - names := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Colour transparent) fixedHeight: 4; - addMorph: (StringMorph new contents: ' Package Name') fixedHeight: textHeigth; - addMorphUseAll: names. - - fileNames := PluggableListMorph - model: model - listGetter: #packageFullNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - fileNames color: backColor. - fileNames := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Colour transparent) fixedHeight: 4; - addMorph: (StringMorph new contents: ' File Name') fixedHeight: textHeigth; - addMorphUseAll: fileNames. - - upperRow := LayoutMorph newRow. - upperRow - addMorph: dirtyFlags proportionalWidth: 0.13; - addAdjusterAndMorph: names proportionalWidth: 0.27; - addAdjusterAndMorph: fileNames proportionalWidth: 0.6. - - description := TextModelMorph - textProvider: model - textGetter: #description - textSetter: #description:. - - summary := TextModelMorph - textProvider: model - textGetter: #summary. - - self layoutMorph - addMorph: upperRow proportionalHeight: 0.5; - addAdjusterAndMorph: self buildButtonPane proportionalHeight: 0.1; - addAdjusterAndMorph: summary proportionalHeight: 0.18; - addAdjusterAndMorph: description proportionalHeight: 0.22; - addAdjusterAndMorph: self buildRequirementsPane proportionalHeight: 0.2. - self setLabel: 'Installed Packages'! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'len 5/27/2016 21:51' prior: 16811499! - buildRequirementsPane - - | requirements deleteReqButton "editReqButton" reqLayout buttonLayout | - requirements := PluggableListMorph - model: (PackageRequirementsList fromCodePackageList: model) - listGetter: #requirementsStrings - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - requirements color: Theme current textPane. - - deleteReqButton := PluggableButtonMorph - model: requirements model - action: #deleteSelectedRequirement - label: 'delete'. - deleteReqButton color: self widgetsColor. - - buttonLayout := LayoutMorph newColumn. - buttonLayout addMorph: deleteReqButton - layoutSpec: (LayoutSpec - proportionalWidth: 1.0 - proportionalHeight: 1.0 - minorDirectionPadding: #top); - color: self widgetsColor quiteWhiter. - - model when: #changed: send: #updateRequirementsFromPackageList to: requirements model. - self when: #changed: send: #updateRequirementsFromPackageList to: requirements model. - requirements model when: #changed: send: #verifyContents to: requirements. - self when: #changed: send: #verifyContents to: requirements. - - reqLayout := LayoutMorph newRow. - ^ reqLayout - doAdoptWidgetsColor; - addMorph: requirements - layoutSpec: (LayoutSpec - proportionalWidth: 0.9 - proportionalHeight: 1.0 - minorDirectionPadding: #left); - addMorph: buttonLayout - layoutSpec: (LayoutSpec - proportionalWidth: 0.1 - proportionalHeight: 1.0 - minorDirectionPadding: #right); - color: Colour transparent; - yourself - ! ! -!CodeWindow methodsFor: 'updating' stamp: 'jmv 6/18/2017 21:32:16' prior: 16813173! - decorateForInheritance - "Check to see if the currently-viewed method has a super send or an override, and if so, change screen feedback, unless the #decorateBrowserButtons says not to." - - | cm aColour aButton flags buttonColour | - (aButton _ self inheritanceButton) ifNil: [^ self]. - buttonColour _ self buttonColor. - - Preferences decorateBrowserButtons - ifFalse: [ ^aButton color: buttonColour ]. - cm _ model currentCompiledMethod. - (cm is: #CompiledMethod) - ifFalse: [ ^aButton color: buttonColour ]. - - flags _ 0. - model isThisAnOverride ifTrue: [ flags _ flags bitOr: 4 ]. - cm sendsToSuper ifTrue: [ flags _ flags bitOr: 2 ]. - model isThereAnOverride ifTrue: [ flags _ flags bitOr: 1 ]. - aColour _ { - - "This is NOTan override. There is no super implementation." - buttonColour. "no sends to super. there is not override in any subclass" - Colour tan. "no sends to super. there is an override in some subclass" - Colour red. "sends to super. there is no override in any subclass. Error: no super to call (or calls super with a different message)" - Colour red. "sends to super. there is an override in some subclass. Error: no super to call (or calls super with a different message)" - - "This is an override. There is some super implementation" - Colour red muchLighter. "doesn't have sub; has super but doesn't call it" - Colour r: 0.94 g: 0.823 b: 0.673. "has sub; has super but doesn't call it" - Colour green muchLighter. "doesn't have sub; has super and callsl it" - Colour blue muchLighter. "has sub; has super and callsl it" - - } at: flags + 1. - aButton color: buttonColour! ! -!ChangeSorterWindow methodsFor: 'GUI building' stamp: 'DM 8/22/2015 12:34' prior: 16799978! - buildMorphicWindow - "Add a set of change sorter views to the given top view offset by the given amount. To create a single change sorter, call this once with an offset of 0@0. To create a dual change sorter, call it twice with offsets of 0@0 and 0.5@0." - - | dirtyFlags changeSetList classList messageList upperPanes backColor labelBackground | - backColor _ self textBackgroundColor. - labelBackground _ Theme current background. - model myChangeSet ifNil: [ - self flag: #ojo. "Or whatever was last changed, or is top of list, or whatever" - model myChangeSet: ChangeSet changeSetForBaseSystem ]. - - dirtyFlags _ PluggableListMorph - model: model - listGetter: #changeSetDirtyFlags - indexGetter: nil - indexSetter: nil. - dirtyFlags color: backColor. - dirtyFlags _ LayoutMorph newColumn - color: Theme current background; - addMorph: (RectangleLikeMorph new color: Colour transparent) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: ' Unsaved?'); - addMorphUseAll: dirtyFlags. - - changeSetList _ (PluggableListMorphByItem - model: model - listGetter: #changeSetList - indexGetter: #currentCngSet - indexSetter: #showChangeSetNamed: - mainView: self - menuGetter: #changeSetMenu - keystrokeAction: #changeSetListKey:from:) - autoDeselect: false. - changeSetList color: backColor. - changeSetList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Colour transparent) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: 'Change Set name'); - addMorphUseAll: changeSetList. - - classList _ PluggableListMorphByItem - model: model - listGetter: #classList - indexGetter: #currentClassName - indexSetter: #currentClassName: - mainView: self - menuGetter: #classListMenu - keystrokeAction: #classListKey:from:. - classList color: backColor. - classList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Colour transparent) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: 'Classes'); - addMorphUseAll: classList. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: dirtyFlags proportionalWidth: 0.13; - addAdjusterAndMorph: changeSetList proportionalWidth: 0.47; - addAdjusterAndMorph: classList proportionalWidth: 0.4. - - messageList _ PluggableListMorphByItem - model: model - listGetter: #messageList - indexGetter: #currentSelector - indexSetter: #currentSelector: - mainView: self - menuGetter: #messageMenu - keystrokeAction: #messageListKey:from:. - messageList color: backColor. - messageList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Colour transparent) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: 'Methods'); - addMorphUseAll: messageList. - - self layoutMorph - addMorph: upperPanes proportionalHeight: 0.25; - addAdjusterAndMorph: messageList proportionalHeight: 0.2; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.55. - - self setLabel: model labelString! ! -!PreDebugWindow methodsFor: 'GUI building' stamp: 'HAW 1/12/2017 18:47:35' prior: 50336811! - buttonRowForPreDebugWindow: aDebugger - | row aButton triads buttons | - buttons _ OrderedCollection new. - triads _ OrderedCollection withAll: self preDebugButtonSpec. - aDebugger shouldBeAbleToCreateMethod ifTrue: [ triads add: { 'Create'. #createMethod. 'create the missing method' }]. - - triads do: [ :triad | - aButton _ PluggableButtonMorph new model: self. - aButton label: triad first. - aButton action: triad second. - aButton setBalloonText: triad third. - buttons add: aButton]. - - row _ LayoutMorph newRow. - row doAdoptWidgetsColor. - row color: Colour transparent. - row separation: 1. - row addMorphs: buttons. - ^row! ! -!TestRunnerWindow methodsFor: 'constants' stamp: 'jmv 4/16/2011 13:57' prior: 16928704! - runButtonColor - ^ Colour green lighter duller! ! -!ProgressBarMorph methodsFor: 'initialization' stamp: 'jmv 12/2/2011 10:52' prior: 16896023! - defaultColor - ^Colour white! ! -!ProgressBarMorph methodsFor: 'initialization' stamp: 'jmv 12/2/2011 10:53' prior: 16896027! - initialize - super initialize. - progressColor _ Colour gray. - value _ 0.0! ! -!MenuMorph methodsFor: 'construction' stamp: 'len 11/16/2015 02:52' prior: 16866472! - addStayUpIcons - | closeBox pinBox w | - Preferences optionalButtons ifFalse: [ ^self ]. - (self valueOfProperty: #hasStayUpIcons ifAbsent: [ false ]) - ifTrue: [ - self removeProperty: #needsStayUpIcons. - ^self ]. - titleMorph ifNil: [ - "Title not yet there. Flag ourself, so this method is called again when adding title." - self setProperty: #needsStayUpIcons toValue: true. - ^ self]. - closeBox _ PluggableButtonMorph model: self action: #delete. - closeBox icon: Theme current closeIcon; color: Colour transparent. - pinBox _ PluggableButtonMorph model: self action: #stayUp. - pinBox icon: Theme current pushPinIcon; color: Colour transparent. - w _ (titleMorph hasSubmorphs ifTrue: [ titleMorph firstSubmorph morphWidth ] ifFalse: [ 0 ]) + 60. - self addMorphFront: - (LayoutMorph newRow - "Make room for buttons" - morphExtent: w @ (titleMorph morphHeight max: 19); - color: Colour transparent; - addMorph: closeBox fixedWidth: 20; - addMorph: (RectangleLikeMorph new color: Colour transparent) fixedWidth: 4; - addMorph: titleMorph proportionalWidth: 1; - addMorph: (RectangleLikeMorph new color: Colour transparent) fixedWidth: 4; - addMorph: pinBox fixedWidth: 20). - - self setProperty: #hasStayUpIcons toValue: true. - self removeProperty: #needsStayUpIcons! ! -!MenuMorph methodsFor: 'keyboard control' stamp: 'jmv 6/8/2014 20:32' prior: 16867035! - displayFiltered: evt - | matchStr allItems isMatch matches feedbackMorph | - matchStr _ self valueOfProperty: #matchString. - allItems _ self submorphs select: [ :m | - m is: #MenuItemMorph ]. - matches _ allItems select: [ :m | - isMatch _ matchStr isEmpty or: [ - m contents - includesSubstring: matchStr - caseSensitive: false ]. - m isEnabled: isMatch. - isMatch ]. - feedbackMorph _ self valueOfProperty: #feedbackMorph. - feedbackMorph ifNil: [ - feedbackMorph _ StringMorph new color: Colour veryDarkGray. - self addMorphBack: feedbackMorph lock position: (0@ -20). - self - setProperty: #feedbackMorph - toValue: feedbackMorph ]. - feedbackMorph contents: '<' , matchStr , '>'. - matchStr isEmpty ifTrue: [ - feedbackMorph delete. - self removeProperty: #feedbackMorph ]. - matches notEmpty ifTrue: [ - self selectItem: matches first ]! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'jmv 4/14/2016 15:10' prior: 16781489! - drawOn: aCanvas - | rectangle w y0 h y1 y2 scrollbarThickness | - aCanvas frameAndFillRectangle: (0@0 extent: extent) fillColor: self color borderWidth: borderWidth borderColor: borderColor. - y0 _ 1. - w _ extent x-2. - scrollbarThickness _ ScrollBar scrollbarThickness. - completer entryCount > self class itemsPerPage ifTrue: [ - w _ w - scrollbarThickness. - aCanvas - frameRectangle: (extent x - scrollbarThickness@0 - extent: scrollbarThickness @ extent y) - borderWidth: 1 - color: borderColor. - aCanvas - image: (BitBltCanvas arrowOfDirection: #up size: scrollbarThickness) - at: self upButtonPosition. - aCanvas - image: (BitBltCanvas arrowOfDirection: #down size: scrollbarThickness) - at: self downButtonPosition. - h _ extent y - (2 * scrollbarThickness). - y1 _ (1.0 * self firstVisible-1 / completer entryCount * h) ceiling + y0 + scrollbarThickness-1. - y2 _ (1.0 * self lastVisible / completer entryCount * h) floor + y0 + scrollbarThickness -1. - aCanvas - fillRectangle: (extent x - scrollbarThickness+2@y1 corner: extent x-2 @ y2) - color: Colour veryLightGray ]. - self firstVisible - to: self lastVisible - do: [ :index | - rectangle _ 1@y0 extent: w@self class itemHeight. - index = self selected - ifTrue: [ - aCanvas fillRectangle: rectangle color: (Theme current listHighlightFocused: true) ]. - aCanvas - drawString: (completer entries at: index) asString - at: rectangle topLeft - font: self class listFont - color: Theme current text. - y0 _ y0 + self itemHeight ]! ! -!AutoCompleterMorph methodsFor: 'initialization' stamp: 'jmv 12/2/2011 10:09' prior: 16781571! - defaultBorderColor - ^ Colour gray! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 9/9/2012 23:59' prior: 16851609! - drawOn: aCanvas - "Draw the hand itself (i.e., the cursor)." - "This method is only called when we are carrying morphs around..." - aCanvas - stencil: Cursor move - at: 0@0 - color: Colour black! ! -!ImageMorph methodsFor: 'accessing' stamp: 'jmv 6/18/2017 21:32:59' prior: 16854101! - color: aColor - super color: aColor. - (image depth = 1 and: [aColor is: #Color]) ifTrue: [ - image colors: {Colour transparent. aColor}. - self redrawNeeded]! ! -!MenuItemMorph methodsFor: 'accessing' stamp: 'jmv 3/13/2009 10:04' prior: 16865863! - isEnabled: aBoolean - - isEnabled = aBoolean ifTrue: [^ self]. - isEnabled _ aBoolean. - self color: (aBoolean ifTrue: [Colour black] ifFalse: [Colour gray]). -! ! -!MenuItemMorph methodsFor: 'private' stamp: 'jmv 9/9/2012 23:55' prior: 16866162! - offImage - "Return the form to be used for indicating an '' marker" - | form | - form _ Form extent: (self fontToUse ascent-2) asPoint depth: 16. - form getCanvas - frameAndFillRectangle: form boundingBox fillColor: (Colour gray: 0.9) - borderWidth: 1 borderColor: Colour black. - ^form! ! -!MenuItemMorph methodsFor: 'private' stamp: 'jmv 9/9/2012 23:55' prior: 16866174! - onImage - "Return the form to be used for indicating an '' marker" - | form | - form _ Form extent: (self fontToUse ascent-2) asPoint depth: 16. - form getCanvas - frameAndFillRectangle: form boundingBox fillColor: (Colour gray: 0.8) - borderWidth: 1 borderColor: Colour black; - fillRectangle: (form boundingBox insetBy: 2) color: Colour black. - ^form! ! -!LayoutMorph methodsFor: 'accessing' stamp: 'jmv 12/1/2015 09:53' prior: 16863001! - adoptWidgetsColor: paneColor - super adoptWidgetsColor: paneColor. - doAdoptWidgetsColor - ifTrue: [ self color: (Theme current buttonColorFrom: paneColor) ] - ifFalse: [ self color: Colour transparent ]! ! -!LayoutMorph methodsFor: 'initialization' stamp: 'jmv 8/17/2014 21:38' prior: 16863302! - defaultColor - ^Colour gray! ! -!LayoutMorph class methodsFor: 'instance creation' stamp: 'jmv 4/3/2011 22:59' prior: 16863603! - initializedInstance - "Answer a row by default so the 'new morph' menu doesn't fail..." - ^self newRow color: (Colour red alpha: 0.2)! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/5/2015 10:57' prior: 16863624! - example1 -" - self example1 -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example1. -pane color: Colour red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addMorph: (BorderedRectMorph new color: (Colour blue); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addMorph: (BorderedRectMorph new color: (Colour h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 20). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #G) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8); - addMorph: (BorderedRectMorph new color: (Colour h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (BorderedRectMorph new color: (Colour h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -pane morphPosition: 150@130 extent: 400@300. -pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/12/2015 16:42' prior: 16863690! - example10 -" - self example10 openInWorld -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example10. -pane color: Colour red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Colour blue); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Colour h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 20). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #G) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8); - addMorph: (BorderedRectMorph new color: (Colour h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (BorderedRectMorph new color: (Colour h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -^ pane! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/5/2015 10:55' prior: 16863758! -example11 -" - self example11 -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example11. -pane color: Colour red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Colour blue); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Colour h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 20). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #G) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8); - addMorph: (BorderedRectMorph new color: (Colour h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (BorderedRectMorph new color: (Colour h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -pane morphPosition: 150@130 extent: 400@300. -pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/5/2015 11:08' prior: 16863827! - example13 - " - self example13 - " - | pane row innerRow | -pane _ (LayoutMorph newColumn separation: 5) name: #example13. - pane color: Colour red. - row _ (LayoutMorph newRow separation: 5) name: #Row. - innerRow _ (LayoutMorph newRow separation: 5) name: #InnerRow; - color: Colour red. - innerRow - addMorph: (BorderedRectMorph new name: #Box1) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (BorderedRectMorph new name: #Box2) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (BorderedRectMorph new name: #Bar) - layoutSpec: (LayoutSpec proportionalWidth: 1.0 fixedHeight: 10). - row - color: (Colour h: 270 s: 0.2 v: 0.6); - addMorph: innerRow - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 30 minorDirectionPadding: #center); - addMorph: LayoutAdjustingMorph new layoutSpec: (LayoutSpec fixedWidth: 5); - addMorph: (BorderedRectMorph new color: (Colour h: 90 s: 0.6 v: 0.6); name: #Rect1) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40 minorDirectionPadding: #top); - addMorph: LayoutAdjustingMorph new layoutSpec: (LayoutSpec fixedWidth: 5); - addMorph: (BorderedRectMorph new color: (Colour h: 150 s: 0.6 v: 0.6); name: #Rect2) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). - pane addMorph: row layoutSpec: (LayoutSpec proportionalHeight: 0.9). - pane morphPosition: 250@130 extent: 400@300. - pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 2/16/2016 13:27' prior: 16863874! - example1b -" -Based on #example1, but using some Morph instead of RectangleLikeMorph -> extent is not adjustable - self example1b -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example1. -pane color: Colour red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addMorph: (Morph new name: #B); - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addMorph: (BorderedRectMorph new color: (Colour h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 20). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (Morph new name: #G); - addMorph: (BorderedRectMorph new color: (Colour h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Colour red; - addMorph: (Morph new name: #J); - addMorph: (BorderedRectMorph new color: (Colour h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (BorderedRectMorph new color: (Colour h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -pane morphPosition: 150@130 extent: 400@300. -pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/5/2015 11:25' prior: 16863934! - example2 - " - self example2 - " - | pane row | - pane _ (LayoutMorph newColumn separation: 5) name: #example2. - pane color: Colour red. - row _ (LayoutMorph newRow separation: 5) name: #Row. - row - color: (Colour h: 270 s: 0.2 v: 0.6); - addMorph: (BorderedRectMorph new color: (Colour h: 120 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8 minorDirectionPadding: #bottom); - addMorph: (BorderedRectMorph new color: (Colour h: 90 s: 0.6 v: 0.6); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8 fixedHeight: 40 minorDirectionPadding: #top); - addMorph: (BorderedRectMorph new color: (Colour h: 150 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 0.7 minorDirectionPadding: #center). - pane addMorph: row layoutSpec: (LayoutSpec proportionalHeight: 0.9). - pane morphPosition: 200@180 extent: 400@300. - pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 11/18/2015 09:45' prior: 16863965! - example20 -" - self example20 -" -| column | - -column _ (LayoutMorph newColumn separation: 5) name: #Column. -column - color: Colour red; - addMorph: (BorderedRectMorph new color: (Colour h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec proportionalWidth: 0.8 fixedHeight: 20); - addMorph: (BorderedRectMorph new color: (Colour h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec fixedWidth: 40 proportionalHeight: 0.5); - addMorph: (BorderedRectMorph new color: (Colour h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec proportionalWidth: 1.0 fixedHeight: 30). -column morphPosition: 150@130 extent: 400@300. -column openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/5/2015 11:13' prior: 16863988! - example3 - " - self example3 - " - | pane row innerRow | -pane _ (LayoutMorph newColumn separation: 5) name: #example3. - pane color: Colour red. - row _ (LayoutMorph newRow separation: 5) name: #Row. - innerRow _ (LayoutMorph newRow separation: 5) name: #InnerRow; - color: Colour red. - innerRow - addMorph: (BorderedRectMorph new name: #Box1) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (BorderedRectMorph new name: #Box2) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (BorderedRectMorph new name: #Bar) - layoutSpec: (LayoutSpec proportionalWidth: 1.0 fixedHeight: 10). - row - color: (Colour h: 270 s: 0.2 v: 0.6); - addMorph: innerRow - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 30 minorDirectionPadding: #center); - addMorph: (BorderedRectMorph new color: (Colour h: 90 s: 0.6 v: 0.6); name: #Rect1) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40 minorDirectionPadding: #top); - addMorph: (BorderedRectMorph new color: (Colour h: 150 s: 0.6 v: 0.6); name: #Rect2) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). - pane addMorph: row layoutSpec: (LayoutSpec proportionalHeight: 0.9). - pane morphPosition: 250@130 extent: 400@300. - pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 6/8/2014 20:03' prior: 16864030! - example6 - " - Useful example contributed by Ken Dickey - All these should look the same, right? (mmmh this should be a test...) - self example6 - " -| pane rect1 rect2 | -pane _ LayoutMorph newRow separation: 5. "1" -pane addMorph: (StringMorph contents: '1'). - -rect1 := BorderedRectMorph new color: (Colour lightOrange); - morphExtent: 20 @ 30. -pane addMorphFront: rect1. -rect2 := BorderedRectMorph new color: (Colour cyan); - morphExtent: 20 @ 30. -pane addMorphFront: rect2. -pane - color: Colour lightGreen; - morphPosition: 120 @ 50 extent: 180 @ 100; - openInWorld. - -pane _ LayoutMorph newRow separation: 5. "2" -pane addMorph: (StringMorph contents: '2'). - -rect1 := BorderedRectMorph new color: (Colour lightOrange); - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 minorDirectionPadding: #center). -pane addMorph: rect1. -rect2 := BorderedRectMorph new color: (Colour cyan). -pane addMorph: rect2 - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 minorDirectionPadding: #center). -pane - color: Colour lightGreen; - morphPosition: 320 @ 50 extent: 180 @ 100; - openInWorld. - - -pane _ LayoutMorph newRow separation: 5. "3" -pane addMorph: (StringMorph contents: '3'). - -rect1 := BorderedRectMorph new color: (Colour lightOrange). -pane addMorph: rect1 - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 minorDirectionPadding: #center). -rect2 := BorderedRectMorph new color: (Colour cyan); - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 minorDirectionPadding: #center). -pane addMorph: rect2. -pane - color: Colour lightGreen; - morphPosition: 520 @ 50 extent: 180 @ 100; - openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 1/4/2013 13:42' prior: 16864106! - launcherExample - " - self launcherExample - " - | b1 b2 b3 row b4 random buttons | - random _ Random new. - b1 _ PluggableButtonMorph model: [ Date today print ] action: #value label: 'Date'. - b2 _ PluggableButtonMorph model: [ Time now print ] action: #value label: 'Time'. - b3 _ PluggableButtonMorph model: [ SystemVersion current print ] action: #value label: 'Version'. - b4 _ PluggableButtonMorph model: [ random next print ] action: #value label: 'Random'. - buttons _ {b1. b2. b3. b4}. - buttons do: [ :button | - button color: Colour lightRed ]. - row _ LayoutMorph newRow - color: Colour red; - addMorphs: buttons; - morphExtent: 300 @ 40. - ^ row openInWorld! ! -!ProgressMorph methodsFor: 'initialization' stamp: 'jmv 12/2/2011 10:55' prior: 16896260! - defaultColor - ^Colour veryLightGray! ! -!HaloHandleMorph class methodsFor: 'accessing' stamp: 'jmv 11/18/2010 09:44' prior: 16850573! - circleForm: extent - " - CircleForm _ nil - " - | r d l bw center | - (CircleForm isNil or: [ CircleForm extent ~= extent ]) ifTrue: [ - center _ extent -1 * 0.5. - r _ center r * 0.75. - bw _ 1.3. - CircleForm _ Form extent: extent depth: 32. - 0 to: extent y - 1 do: [ :y | - 0 to: extent x - 1 do: [ :x | - d _ (x@y - center) r. - l _ (r - d max: 0.0) min: bw. - CircleForm - colorAt: x @ y - put: (Colour white alpha: (l / bw)) - ]]. - ]. - ^CircleForm! ! -!HaloMorph methodsFor: 'initialization' stamp: 'jmv 6/18/2017 21:33:32' prior: 16850854! - defaultColor - "answer the default color/fill style for the receiver" - ^ Colour - r: 0.6 - g: 0.8 - b: 1.0! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 5/27/2015 13:42' prior: 16850874! - addHandle: handleSpec - "Add a handle within the halo box as per the haloSpec, and set it up to respond to the given event by sending the given selector to the given recipient. Return the handle." - - | handle aPoint colorToUse form icon | - aPoint _ self - positionIn: haloBox - horizontalPlacement: handleSpec horizontalPlacement - verticalPlacement: handleSpec verticalPlacement. - colorToUse _ Colour colorFrom: handleSpec color. - handle _ HaloHandleMorph new color: colorToUse. - self addMorph: handle. - handle morphBoundsInWorld: (Rectangle center: aPoint extent: self class handleSize asPoint). - handleSpec iconSymbol ifNotNil: [ :iconName | - form _ self class icons at: iconName ifAbsent: [self class perform: iconName]. - form ifNotNil: [ - icon _ ImageMorph new - image: form; - color: colorToUse makeForegroundColor; - lock. - handle addMorphFront: icon position: 0@0 ]]. - handle mouseUpSelector: #endInteraction. - handle setBalloonText: handleSpec hoverHelp. - ^handle! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/4/2016 22:14' prior: 16850920! - addNameString: aString - "Add a name display centered beneath the bottom of the outer rectangle. Return the handle." - - | nameMorph namePosition nameBackground | - nameBackground _ RectangleLikeMorph new - color: ((target is: #SystemWindow) ifTrue: [target windowColor] ifFalse: [Colour lightBlue alpha: 0.9]). - nameMorph _ StringMorph contents: aString. - nameMorph color: Colour black. - nameBackground morphExtent: nameMorph morphExtent + 4. - namePosition _ haloBox width - nameMorph morphWidth // 2 @ (haloBox height). - self addMorph: nameBackground position: namePosition - 2. - self addMorph: nameMorph position: namePosition. - ^nameMorph! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 9/22/2012 15:18' prior: 16851047! - doRot: evt with: rotHandle - "Update the rotation of my target if it is rotatable. Keep the relevant command object up to date." - - | degrees | -self revisar. - self flag: #jmvVer2. - evt hand obtainHalo: self. - degrees _ (evt eventPosition - target referencePosition) degrees. - degrees _ degrees - angleOffset degrees. - degrees _ degrees detentBy: 10.0 atMultiplesOf: 90.0 snap: false. - degrees = 0.0 - ifTrue: [rotHandle color: Colour lightBlue] - ifFalse: [rotHandle color: Colour blue]. - rotHandle submorphsDo: - [:m | m color: rotHandle color makeForegroundColor]. - self removeAllHandlesBut: rotHandle. - - target rotationDegrees: degrees. - - rotHandle morphPositionInWorld: evt eventPosition - (rotHandle morphExtent // 2)! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 9/20/2012 00:01' prior: 16851135! - setDismissColor: evt with: dismissHandle - "Called on mouseStillDown in the dismiss handle; set the color appropriately." - - | colorToUse | - evt hand obtainHalo: self. - colorToUse _ (dismissHandle morphContainsPoint: (dismissHandle internalizeFromWorld: evt eventPosition)) - ifFalse: [ Colour red muchLighter ] - ifTrue: [ Colour lightGray ]. - dismissHandle color: colorToUse! ! -!InnerListMorph methodsFor: 'initialization' stamp: 'jmv 5/27/2013 09:39' prior: 16855063! - initialize - super initialize. - self color: Colour black. - font _ Preferences standardListFont. - listItems _ #(). - selectedRow _ nil. - selectedRows _ Set new. - highlightedRow _ nil! ! -!InnerTextMorph methodsFor: 'drawing' stamp: 'jmv 10/16/2013 19:55' prior: 16855561! - debugDrawLineRectsOn: aCanvas - "Shows where text line rectangles are" - - self textComposition lines do: [ :line | - aCanvas - frameRectangle: line rectangle - borderWidth: 1 - color: Colour brown ] -! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/17/2015 15:51' prior: 50333232! - initialize - super initialize. - extent _ 400@300. - color _ Colour white. - grid _ 8@6. - gridLineWidth _ 2. - gridColor _ Colour black. - selectionColor _ Colour red! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 23:18' prior: 50333240! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - from _ self toGridPoint: localEventPosition. - outlineMorph _ BorderedRectMorph new - borderColor: Colour black; - color: Colour transparent; - openInWorld; - hide. - self selectTo: localEventPosition! ! -!HoverHelpMorph methodsFor: 'initialization' stamp: 'jmv 9/25/2011 23:12' prior: 16853831! - defaultColor - - ^Colour r: 1.0 g: 1.0 b: 0.7! ! -!HoverHelpMorph methodsFor: 'drawing' stamp: 'jmv 12/20/2014 15:09' prior: 16853866! - drawOn: aCanvas - - | r | - r _ self morphLocalBounds. - aCanvas roundRect: r color: self color radius: 4. - aCanvas - textComposition: textComposition - bounds: (r insetBy: 4) - color: Colour black - selectionColor: (Theme current textHighlightFocused: false)! ! -!WorldState methodsFor: 'drawing' stamp: 'jmv 3/2/2017 19:40:12' prior: 50339669! - drawInvalidAreasSubmorphs: submorphs - "Redraw the damaged areas of the given canvas and clear the damage list. Return a collection of the areas that were redrawn." - - | initialRectsToRepair currentRectsToRepair newRectsToRepair morphsToDraw rectsForEachMorph thisMorphRects reuse i n morph morphBounds morphClipRect | - - "The simple implementation is slowers as it draws morph areas that will later be covered by other morphs. - But it works, and it is easier to understand. - See en.wikipedia.org/wiki/Painter's_algorithm" - true not ifTrue: [ ^self simpleDrawInvalidAreasSubmorphs: submorphs ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - initialRectsToRepair _ damageRecorder invalidRectsFullBounds: world viewBox. - damageRecorder reset. - currentRectsToRepair _ OrderedCollection new. - newRectsToRepair _ OrderedCollection withAll: initialRectsToRepair. - morphsToDraw _ OrderedCollection new. - rectsForEachMorph _ OrderedCollection new. - thisMorphRects _ OrderedCollection new. - n _ submorphs size. - i _ 1. - - "The idea here is to iterate morphs front to back, i.e. first the ones on top. - For each morph, record the rectangles it affects. And if a morph is opaque, remove the area behind it from the list of rectangles to be repaired. - This means, for example, that morphs completely covered might even not be redrawn. - this is a huge performance gain when there are many morphs on screen, especially if there are more than ten open windows, and Theme uses opaque colors. - See 'A reverse painter's algorithm' at en.wikipedia.org/wiki/Painter's_algorithm" - [ i <= n and: [ newRectsToRepair notEmpty ]] whileTrue: [ - morph _ submorphs at: i. - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - reuse _ currentRectsToRepair. - currentRectsToRepair _ newRectsToRepair. - newRectsToRepair _ reuse removeAll. - currentRectsToRepair do: [ :r | - (morphBounds intersects: r) - ifTrue: [ - morphClipRect _ morphBounds intersect: r. - thisMorphRects add: morphClipRect. "We could perhaps try and join adjacent rectangles in this collection..." - morph addPossiblyUncoveredAreasIn: r to: newRectsToRepair ] - ifFalse: [ - newRectsToRepair add: r ]]. - thisMorphRects ifNotEmpty: [ - morphsToDraw add: morph. - rectsForEachMorph add: thisMorphRects. - thisMorphRects _ OrderedCollection new. - ]]. - i _ i + 1 ]. - - "*make this true to flash damaged areas for testing*" - Preferences debugShowDamage ifTrue: [ world fillRects: initialRectsToRepair color: Colour gray ]. - - "Draw world background on those areas that were not completely covered by opaque morphs" - i > n ifTrue: [ - newRectsToRepair do: [ :r | - world drawOn: (canvas newClipRect: r) ]]. - - "Now, draw the recorded areas of selected morphs, back to front." - morphsToDraw with: rectsForEachMorph reverseDo: [ :m :xrects | - "Here we could think about merging all xrects into just one call... - This would mean drawing each morph just once. - But that would mean drawing pixels we were not told to. There could be other morphs in that area that are not even being drawn!! - See WorldState class >> #experiment1" -" rr _ nil." - xrects do: [ :r | -" rr _ rr ifNil: [ r ] ifNotNil: [ r quickMerge: rr ]." - (canvas newClipRect: r) fullDraw: m. - ]. -" (canvas newClipRect: rr) fullDraw: m" - "*make this true to flash damaged areas for testing*" - Preferences debugShowDamage2 ifTrue: [ - world flashRects: xrects color: Colour random ]. - ]. - - "Answer a list of rectangles to be updated on the Display. - This usually is not performance critical, drawing morphs is slower than just exposing the Display." - "What should we force on Display? Whatever was asked? Each small rect that was updated? A single bigger rect? - Right now, answer whatever was asked... Maybe this could be changed if that enhances performance... - (think of vnc over slow networks)" - ^ initialRectsToRepair! ! -!WorldState class methodsFor: 'sample code' stamp: 'jmv 3/2/2017 19:39:21' prior: 50339891! - experiment1 - "To play with and learn about morphic Display update logic. - Remove the morphs when done!!" - " - WorldState experiment1 - " - | dr morph1 morph2 s w | - morph1 _ RectangleLikeMorph new openInWorld. - morph2 _ RectangleLikeMorph new openInWorld. - morph2 color: Colour green. - morph2 morphPosition: 200@800 extent: 50@40. - morph1 morphPosition: 120@720 extent: 220@100. - - w _ self runningWorld. - s _ w instVarNamed: 'worldState'. - dr _ s instVarNamed: 'damageRecorder'. - - dr doFullRepaint. - dr reset; - " recordInvalidRect: (100@700 corner: 400@900);" - recordInvalidRect: (100@700 corner: 150@900); - recordInvalidRect: (300@700 corner: 400@900). - Display fillColor: Colour gray. - "Do not draw the area used by the small rectangle, unless it is also drawn!!" - s drawInvalidAreasSubmorphs: {morph1. morph2 }! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 12/20/2014 15:35' prior: 16877458! - drawCurrentAsError - "The morph (or one of its submorphs) had an error in its drawing method." - | r w | - r _ currentMorph morphLocalBounds. - w _ r extent > (50@50) - ifTrue: [ 6 ] - ifFalse: [ 2 ]. - self - frameAndFillRectangle: r - fillColor: Colour red - borderWidth: w - borderColor: Colour yellow. - self line: r topLeft to: r bottomRight-w width: w color: Colour yellow. - self line: r topRight -(w@0) to: r bottomLeft -(0@w)width: w color: Colour yellow! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 6/1/2015 13:30' prior: 16877630! - drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - aColor = Colour black ifFalse: [ | topColor | - topColor _ aColor alphaMixed: 0.25 with: Colour black. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint - font: fontOrNil - color: topColor ]. - aColor = Colour white ifFalse: [ | bottomColor | - bottomColor _ aColor alphaMixed: 0.22 with: Colour white. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + (0@2) - font: fontOrNil - color: bottomColor ]. - ^self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + (0@1) - font: fontOrNil - color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 11/29/2015 18:01' prior: 16786666! - fillRectangle: aRectangle color: aColor - "Fill the given rectangle." - - aColor isTransparent ifFalse: [ - self - frameAndFillRectangle: aRectangle - fillColor: aColor - borderWidth: 0 - borderColor: Colour transparent ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 11/29/2015 18:14' prior: 16786789! - reverseRectangleBorder: r borderWidth: borderWidth - " - Display getCanvas - reverseRectangleBorder: (10@10 extent: 300@200) - borderWidth: 20. - Display forceToScreen - " - | rect | - rect _ currentTransformation displayBoundsOfTransformOf: r. - port - sourceForm: nil; - fillColor: Colour gray; - combinationRule: Form reverse; - frameRect: rect borderWidth: borderWidth! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 4/9/2015 09:46' prior: 16787146! - setPaintColor: aColor - "Install a new color used for filling." - | paintColor | - paintColor _ aColor ifNil: [ Colour transparent ]. - (paintColor is: #Color) ifFalse: [ - ^self error: 'Cannot install color' ]. - - "Okay, so paintColor really *is* a color" - port sourceForm: nil. - (paintColor isOpaque or: [ self depth < 32]) ifTrue: [ - port fillColor: paintColor. - port combinationRule: Form paint. - ^self ]. - - "BitBlt setup for alpha mapped transfer" - port fillColor: paintColor. - port combinationRule: Form blend! ! -!BitBltCanvas class methodsFor: 'cached forms' stamp: 'jmv 4/17/2015 12:16' prior: 16787260! - steButtonForm: extent - ^self cachedForms - at: { #steButton . extent } - ifAbsentPut: [ - | form canvas | - form _ Form extent: extent depth: 32. - canvas _ form getCanvas. - canvas - roundRect: (0@0 extent: extent) - color: (Colour gray: 0.4) - radius: 4. - canvas - roundRect: (1@1 extent: extent-2) - color: Colour white - radius: 4 - gradientTop: 1.0 - gradientCenter: 0.73 - gradientBottom: 0.94 - gradient1Height: (extent y-8+1 max: extent y//2). - form]! ! -!BitBltCanvas class methodsFor: 'cached forms' stamp: 'jmv 4/17/2015 12:16' prior: 16787305! - verticalGrayGradient: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - ^self cachedForms - at: { #vertical. height. gradientTopFactor . gradientBottomFactor } - ifAbsentPut: [ - Form - verticalGradient: height - topColor: (Colour gray: gradientTopFactor) - bottomColor: (Colour gray: gradientBottomFactor) ]! ! -!BitBltCanvas class methodsFor: 'cached arrow forms' stamp: 'jmv 1/7/2015 08:12' prior: 16787328! - buildArrowOfDirection: aSymbolDirection size: finalSizeInteger - "PRIVATE - create an arrow with aSymbolDirectionDirection, - finalSizeInteger and aColor - - aSymbolDirectionDirection = #up, #down. #left or #right - (self buildArrowOfDirection: #down size: 120) display - (self buildArrowOfDirection: #up size: 120) display - " - - | resizeFactor resizedForm f e c bottomMargin topMargin | - resizeFactor _ 4. - e _ finalSizeInteger@finalSizeInteger*resizeFactor. - f _ Form extent: e depth: 32. - c _ Colour gray: 0.5. - topMargin _ finalSizeInteger * 3//4. - bottomMargin _ finalSizeInteger * 4//4. - 0 to: e y-1-bottomMargin do: [ :y | - 0 to: e x -1 do: [ :x | - (e x / 2 - 1 - x) abs * 2 + topMargin < y ifTrue: [ - f colorAt: x@y put: c - ] - ] - ]. - resizedForm _ f - magnify: f boundingBox - by: 1 / resizeFactor - smoothing: 4. - - aSymbolDirection == #right ifTrue: [ - resizedForm _ resizedForm rotatedByDegrees: 90 ]. - aSymbolDirection == #down ifTrue: [ - resizedForm _ resizedForm rotatedByDegrees: 180 ]. - aSymbolDirection == #left ifTrue: [ - resizedForm _ resizedForm rotatedByDegrees: 270 ]. - - aSymbolDirection == #up ifFalse: [ - resizedForm _ resizedForm - copy: (resizedForm boundingBox insetBy: (resizedForm width - finalSizeInteger/ 2.0) rounded) ]. - - ^resizedForm! ! -!BitBltCanvas class methodsFor: 'cached arrow forms' stamp: 'jmv 10/9/2014 23:02' prior: 16787371! - buildArrowWith: insideForm borderForm: borderForm - | extent translucentForm color insideSpec borderSpec border background alpha| - " - Display getCanvas - image: (BitBltCanvas buildArrowWith: BitBltCanvas downInsideForm borderForm: BitBltCanvas downBorderForm) - at: 20@20 - Display getCanvas - image: (BitBltCanvas buildArrowWith:BitBltCanvas upInsideForm borderForm: BitBltCanvas upBorderForm) - at: 40@20 - " - extent _ insideForm extent - (1@2). - translucentForm _ Form extent: insideForm extent depth: 32. - 0 to: extent x-1 do: [ :x | - 0 to: extent y-1 do: [ :y | - insideSpec _ insideForm colorAt: x@(y+1). - borderSpec _ borderForm colorAt: x@(y+1). - insideSpec = (Colour r: 0.0 g: 0.0 b: 1.0) - ifTrue: [ color _ Colour transparent ] - ifFalse: [ - borderSpec = (Colour r: 1.0 g: 0.0 b: 0.0) - ifTrue: [ color _ insideSpec ] - ifFalse: [ - border _ x < (extent x//2) - ifTrue: [Colour white] - ifFalse: [Colour black]. - background _ borderForm colorAt: extent x@(y+1). - alpha _ borderSpec red asFloat - background red / (border red - background red). - color _ border alpha: (alpha min: 1 max: 0) ]]. - translucentForm colorAt: x@y put: color ]]. - ^translucentForm! ! -!Theme methodsFor: 'colors' stamp: 'jmv 11/19/2010 14:06' prior: 16935417! - background - ^ Colour r: 0.7 g: 0.72 b: 0.83! ! -!Theme methodsFor: 'colors' stamp: 'jmv 11/23/2010 09:42' prior: 16935421! - buttonColorFrom: aColor - ^ Display depth <= 8 - ifTrue: [ Colour transparent ] - ifFalse: [ aColor paler ]! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/14/2011 08:50' prior: 16935427! - buttonLabel - ^Colour gray: 0.18! ! -!Theme methodsFor: 'colors' stamp: 'len 6/9/2016 17:38' prior: 16935430! - errorColor - ^ Colour red lighter! ! -!Theme methodsFor: 'colors' stamp: 'len 6/9/2016 17:40' prior: 16935433! - failureColor - ^ Colour yellow lighter! ! -!Theme methodsFor: 'colors' stamp: 'len 11/14/2015 02:34' prior: 16935453! - scrollbarButtonColor - ^Colour gray: 0.95! ! -!Theme methodsFor: 'colors' stamp: 'len 11/17/2015 23:55' prior: 16935457! - scrollbarColor - ^Colour white! ! -!Theme methodsFor: 'colors' stamp: 'len 11/14/2015 02:34' prior: 16935460! - scrollbarSliderShadowColor - ^Colour white! ! -!Theme methodsFor: 'colors' stamp: 'len 6/9/2016 17:38' prior: 16935464! - successColor - ^ Colour green lighter! ! -!Theme methodsFor: 'colors' stamp: 'cbr 11/7/2010 18:00' prior: 16935468! - text - ^ Colour black! ! -!Theme methodsFor: 'colors' stamp: 'jmv 10/16/2013 22:08' prior: 16935471! - textCursor - ^ Display depth <= 2 - ifTrue: [ Colour black ] - ifFalse: [ self text ]! ! -!Theme methodsFor: 'colors' stamp: 'jmv 5/30/2011 14:31' prior: 16935476! - textHighlight - "A nice light blue." - " - ^ Colour r: 0.71 g: 0.835 b: 1.0 - ^ Colour hue: 214 chroma: 0.29 luminance: 0.816 - " - ^Colour hue: 204 chroma: 0.29 luminance: 0.77! ! -!Theme methodsFor: 'colors' stamp: 'jmv 11/23/2010 09:58' prior: 16935484! - textHighlightFocused: focused - "A nice light blue." - | textHighlight | - Display depth = 1 ifTrue: [^ Colour veryLightGray]. - Display depth = 2 ifTrue: [^ Colour gray: 0.87]. - textHighlight _ self textHighlight. - ^focused - ifTrue: [ textHighlight ] - ifFalse: [ self unfocusedTextHighlightFrom: textHighlight ]! ! -!Theme methodsFor: 'colors' stamp: 'cbr 12/6/2010 20:08' prior: 16935501! - windowLabel - ^Colour gray: 0.3! ! -!Theme methodsFor: 'menu colors' stamp: 'jmv 5/26/2011 09:07' prior: 16935505! - menu - Display depth <= 2 ifTrue: [^ Colour white]. - ^Colour r: 0.75 g: 0.75 b: 0.75 alpha: 0.93! ! -!Theme methodsFor: 'menu colors' stamp: 'jmv 11/23/2010 09:45' prior: 16935511! - menuHighlight - ^ Display depth < 8 - ifTrue: [ Colour veryLightGray ] - ifFalse: [ self textHighlight ]! ! -!Theme methodsFor: 'menu colors' stamp: 'cbr 11/7/2010 18:28' prior: 16935517! - menuText - ^ Colour black! ! -!Theme methodsFor: 'menu colors' stamp: 'jmv 11/28/2010 08:04' prior: 16935520! - menuTitleBar - Display depth = 1 ifTrue: [^ Colour white]. - Display depth = 2 ifTrue: [^ Colour gray]. - ^ self menu darker! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 4/15/2011 14:59' prior: 16935526! - browser - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Colour r: 0.5 g: 0.7 b: 0.4]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 2/14/2013 11:05' prior: 16935539! - debugger - ^Colour h: 0.0 s: 0.6 v: 0.7! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 11/23/2010 09:16' prior: 16935543! - defaultWindowColor - ^ Colour lightGray! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 11/18/2010 12:44' prior: 16935551! - fileContentsBrowser - ^Colour tan duller! ! -!Theme methodsFor: 'tool colors' stamp: 'cbr 12/4/2010 18:44' prior: 16935555! - fileList - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Colour r: 0.7 g: 0.55 b: 0.7 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 5/23/2012 19:23' prior: 16935561! - messageNames - - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Colour r: 0.53 g: 0.77 b: 0.382 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'cbr 12/4/2010 18:45' prior: 16935567! - messageSet - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Colour r: 0.45 g: 0.6 b: 0.85 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 11/18/2010 12:44' prior: 16935573! - object - ^Colour white duller! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/28/2012 09:41' prior: 16935576! - packageList - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Colour r: 0.63 g: 0.47 b: 0.08 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 11/23/2010 09:17' prior: 16935582! - testRunner - ^ self useUniformColors - ifTrue: [ self defaultWindowColour ] - ifFalse: [ (Colour r: 0.650 g: 0.753 b: 0.976) duller ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/16/2011 08:15' prior: 16935589! - textEditor - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Colour gray: 0.6 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'cbr 12/4/2010 18:45' prior: 16935595! - transcript - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Colour r: 0.8 g: 0.6 b: 0.3 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'cbr 12/18/2010 17:56' prior: 16935601! - versionsBrowser - ^ self useUniformColors - ifTrue: [ self defaultWindowColour ] - ifFalse: [ (Colour r: 0.869 g: 0.753 b: 1.0) duller ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/16/2011 08:13' prior: 16935608! - workspace - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Colour h: 60.0 s: 0.73 v: 0.72 ]! ! -!Theme methodsFor: 'widget colors' stamp: 'jmv 5/23/2012 18:49' prior: 16935614! - acceptButton - - ^ self buttonColorFrom: - (self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Colour r: 0.2 g: 0.6 b: 0.1 ])! ! -!Theme methodsFor: 'widget colors' stamp: 'jmv 5/23/2012 18:51' prior: 16935621! - cancelButton - - ^ self buttonColorFrom: - (self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Colour r: 0.8 g: 0.2 b: 0.2 ])! ! -!Theme methodsFor: 'widget colors' stamp: 'cbr 10/10/2012 23:36' prior: 16935647! - textPane - ^Colour white! ! -!SHTextStylerST80 class methodsFor: 'style table' stamp: 'pb 5/4/2016 17:44' prior: 16903544! - initialTextAttributes - | d element color emphasis attrArray | - d _ IdentityDictionary new. - self styleTable do: [ :each | - element _ each first. - color _ each at: 2 ifAbsent: nil. - color _ color ifNotNil: [ Colour colorFrom: color ]. - emphasis _ each at: 3 ifAbsent: nil. - attrArray _ self attributeArrayForColor: color emphasis: emphasis. - attrArray notEmpty ifTrue: [ - d at: element put: attrArray ]]. - ^ d! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3106-ChangeReferencesToColour-JuanVuletich-2017Jun19-11h07m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3106] on 19 June 2017 at 12:18:58 pm'! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/19/2017 12:18:51' prior: 50345511! - * aNumber - "Answer this color with its RGB multiplied by the given number. " - " - (Colour brown *2) display - " - ^ (Colour new - setRed: (self red * aNumber min: 1.0 max: 0.0) - green: (self green * aNumber min: 1.0 max: 0.0) - blue: (self blue * aNumber min: 1.0 max: 0.0)) - alpha: self alpha! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/19/2017 12:18:50' prior: 50349788! - * aNumber - "Answer this color with its RGB multiplied by the given number. " - " - (Color brown *2) display - " - ^ (Colour new - setRed: (self red * aNumber min: 1.0 max: 0.0) - green: (self green * aNumber min: 1.0 max: 0.0) - blue: (self blue * aNumber min: 1.0 max: 0.0) - colorSpace: colorSpace) - alpha: self alpha! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3107-KeepAlphaOnColorMultiply-JuanVuletich-2017Jun19-12h18m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3106] on 19 June 2017 at 11:52:30 am'! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - -| all | -all := Color allInstances. -all elementsForwardIdentityTo: (all collect: [ :c | c * 1 ]). -all := TranslucentColor allInstances. -all elementsForwardIdentityTo: (all collect: [ :c | c * 1 ]).! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3108-MigrateInstancesToColour-JuanVuletich-2017Jun19-11h51m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3103] on 19 June 2017 at 11:15:55 am'! - -TranslucentColour removeSelector: #setRed:green:blue:alpha:colorSpace:! - -TranslucentColour removeSelector: #setRed:green:blue:alpha:colorSpace:! - -Colour removeSelector: #floatRGB! - -Colour removeSelector: #floatRGB! - -Colour removeSelector: #setRed:green:blue:colorSpace:! - -Colour removeSelector: #setRed:green:blue:colorSpace:! - -Smalltalk removeClassNamed: #Color! - -Smalltalk removeClassNamed: #Color! - -Smalltalk removeClassNamed: #TranslucentColor! - -Smalltalk removeClassNamed: #TranslucentColor! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3109-removeColor-JuanVuletich-2017Jun19-11h11m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3108] on 19 June 2017 at 11:58:54 am'! - -FloatArray variableWordSubclass: #Color - instanceVariableNames: '' - classVariableNames: 'CachedColormaps ColorNamesDict FromGrayColormaps GrayToIndexMap IndexedColors MaskingMap ToGrayColormaps' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -!classDefinition: #Color category: #'Graphics-Primitives'! -FloatArray variableWordSubclass: #Color - instanceVariableNames: '' - classVariableNames: 'CachedColormaps ColorNamesDict FromGrayColormaps GrayToIndexMap IndexedColors MaskingMap ToGrayColormaps' - poolDictionaries: '' - category: 'Graphics-Primitives'! -!Color commentStamp: 'jmv 6/18/2017 20:14:31' prior: 0! - This class represents abstract color, regardless of the depth of bitmap it will be shown in. At the very last moment a Color is converted to a pixelValue that depends on the depth of the actual Bitmap inside the Form it will be used with. The supported depths (in bits) are 1, 2, 4, 8, 16, and 32. The number of actual colors at these depths are: 2, 4, 16, 256, 32768, and 16 million. (See comment in BitBlt.) To change the depth of the Display and set how many colors you can see, execute: (Display newDepth: 8). (See comment in DisplayMedium) - Color is represented as the amount of light in red, green, and blue. White is (1.0, 1.0, 1.0) and black is (0, 0, 0). Pure red is (1.0, 0, 0). These colors are "additive". Think of Color's instance variables as: - r amount of red, a Float between 0.0 and 1.0. - g amount of green, a Float between 0.0 and 1.0. - b amount of blue, a Float between 0.0 and 1.0. - Many colors are named. You find a color by name by sending a message to class Color, for example (Color lightBlue). Also, (Color red: 0.2 green: 0.6 blue: 1.0) or (Color r: 0.2 g: 0.6 b: 1.0) creates a color. (see below) - A color is essentially immutable. Once you set red, green, and blue, you cannot change them. Instead, create a new Color and use it. - Applications such as contour maps and bar graphs will want to display one of a set of shades based on a number. Convert the range of this number to an integer from 1 to N. Then call (Color green lightShades: N) to get an Array of colors from white to green. Use the Array messages at:, atPin:, or atWrap: to pull out the correct color from the array. atPin: gives the first (or last) color if the index is out of range. atWrap: wraps around to the other end if the index is out of range. - Here are some fun things to run in when your screen has color: - Pen new mandala: 30 diameter: Display height-100. - Pen new web "Draw with the mouse, opt-click to end" - Display fillWhite. Pen new hilberts: 5. - Form toothpaste: 30 "Draw with mouse, opt-click to end" - -Messages: - mixed: proportion with: aColor Answer this color mixed with the given color additively. The proportion, a number between 0.0 and 1.0, determines what what fraction of the receiver to use in the mix. - - + add two colors - - subtract two colors - * multiply the values of r, g, b by a number or an Array of factors. ((Color named: #white) * 0.3) gives a darkish gray. (aColor * #(0 0 0.9)) gives a color with slightly less blue. - / divide a color by a factor or an array of three factors. - - hue Returns the hue of the color. On a wheel from 0 to 360 with pure red at 0 and again at 360. - saturation Returns the saturation of the color. 0.0 to 1.0 - brightness Returns the brightness of the color. 0.0 to 1.0 - - name Look to see if this Color has a name. - display Show a swatch of this color tracking the cursor. - - lightShades: thisMany An array of thisMany colors from white to the receiver. - darkShades: thisMany An array of thisMany colors from black to the receiver. Array is of length num. - mix: color2 shades: thisMany An array of thisMany colors from the receiver to color2. - wheel: thisMany An array of thisMany colors around the color wheel starting and ending at the receiver. - - pixelValueForDepth: d Returns the bits that appear be in a Bitmap of this depth for this color. Represents the nearest available color at this depth. Normal users do not need to know which pixelValue is used for which color. - -Messages to Class Color. - red: r green: g blue: b Return a color with the given r, g, and b components. - r: g: b: Same as above, for fast typing. - - hue: h saturation: s brightness: b Create a color with the given hue, saturation, and brightness. - - pink - blue - red ... Many colors have messages that return an instance of Color. - canUnderstand: #brown Returns true if #brown is a defined color. - names An OrderedCollection of the names of the colors. - named: #notAllThatGray put: aColor Add a new color to the list and create an access message and a class variable for it. - fromUser Shows the palette of colors available at this display depth. Click anywhere to return the color you clicked on. - - hotColdShades: thisMany An array of thisMany colors showing temperature from blue to red to white hot. - - stdColorsForDepth: d An Array of colors available at this depth. For 16 bit and 32 bits, returns a ColorGenerator. It responds to at: with a Color for that index, simulating a very big Array. - - colorFromPixelValue: value depth: d Returns a Color whose bit pattern (inside a Bitmap) at this depth is the number specified. Normal users do not need to use this. - -(See also comments in these classes: Form, Bitmap, BitBlt) - -Default colorSpace is #sRGB. Subclasses might use other color spaces! - -Color variableWordSubclass: #TranslucentColor - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Primitives'! - -!classDefinition: #TranslucentColor category: #'Graphics-Primitives'! -Color variableWordSubclass: #TranslucentColor - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Primitives'! -!TranslucentColor commentStamp: '' prior: 0! - A TranslucentColor behaves just like a normal color, except that it will pack its alpha value into the fourth position. This allows creating forms with translucency for use with the alpha blend function of BitBlt. An alpha of zero is transparent, and 1.0 is opaque.! -!Color methodsFor: 'access' stamp: 'jmv 1/31/2011 09:25'! - alpha - "Return the opacity ('alpha') value of opaque so that normal colors can be compared to TranslucentColors." - - ^ 1.0 -! ! -!Color methodsFor: 'access' stamp: 'jmv 6/18/2017 20:35:34'! - blue - "Return the blue component of this color, a float in the range [0.0..1.0]." - - ^ self at: 3! ! -!Color methodsFor: 'access' stamp: 'jmv 6/18/2017 20:33:10'! - brightness - "Return the brightness of this color, a float in the range [0.0..1.0]. - Color red brightness - " - - "Do not include alpha if TranslucentColor" - ^ (self red max: self green) max: self blue! ! -!Color methodsFor: 'access' stamp: 'jmv 6/18/2017 20:34:30'! - chroma - "Return the chroma of this color, a value between 0.0 and 1.0, somewhat related to saturation. - See http://en.wikipedia.org/wiki/HSL_and_HSV - Color red chroma - Color gray chroma - " - - | r g b max min | - r _ self red. - g _ self green. - b _ self blue. - max _ (r max: g) max: b. - min _ (r min: g) min: b. - ^max - min! ! -!Color methodsFor: 'access' stamp: 'jmv 6/18/2017 20:35:28'! - green - "Return the green component of this color, a float in the range [0.0..1.0]." - - ^ self at: 2! ! -!Color methodsFor: 'access' stamp: 'jmv 6/18/2017 20:31:54'! - hue - "Return the hue of this color, an angle in the range [0.0..360.0]. - Color orange hue - " - - | r g b max min span h | - r _ self red. - g _ self green. - b _ self blue. - max _ (r max: g) max: b. - min _ (r min: g) min: b. - span _ (max - min) asFloat. - span = 0.0 ifTrue: [ ^ 0.0 ]. - - r = max ifTrue: [ - h _ ((g - b) asFloat / span) * 60.0. - ] ifFalse: [ - g = max - ifTrue: [ h _ 120.0 + (((b - r) asFloat / span) * 60.0). ] - ifFalse: [ h _ 240.0 + (((r - g) asFloat / span) * 60.0). ]. - ]. - - ^h mod: 360.0! ! -!Color methodsFor: 'access' stamp: 'KenD 1/23/2013 18:19'! - icon - "Answer a swatch to display in a menu or browser" - ^self swatch! ! -!Color methodsFor: 'access' stamp: 'KenD 1/23/2013 18:17'! - iconOrThumbnailOfSize: aNumberOrPoint - "Answer an appropiate form to represent the receiver" - | form | - form := Form extent: aNumberOrPoint asPoint asPoint depth: 32. - form fillColor: self. - ^ form! ! -!Color methodsFor: 'access' stamp: 'jmv 4/19/2013 16:46'! - luminance - "Return the luminance of this color, a brightness value weighted by the human eye's color sensitivity." - - ^ ((299 * self red) + - (587 * self green) + - (114 * self blue)) / 1000! ! -!Color methodsFor: 'access' stamp: 'jmv 6/18/2017 20:35:25'! - red - "Return the red component of this color, a float in the range [0.0..1.0]." - - ^ self at: 1! ! -!Color methodsFor: 'access' stamp: 'jmv 6/18/2017 20:34:08'! - saturation - "Return the saturation of this color, a value between 0.0 and 1.0. - Color red saturation - Color gray saturation - " - - | r g b max min | - r _ self red. - g _ self green. - b _ self blue. - max _ (r max: g) max: b. - min _ (r min: g) min: b. - max = 0.0 ifTrue: [ ^0.0 ]. - ^max - min / max! ! -!Color methodsFor: 'access' stamp: 'KenD 1/23/2013 18:18'! - swatch - "Answer a swatch to display in a menu or browser" - ^self iconOrThumbnailOfSize: 16! ! -!Color methodsFor: 'conversions' stamp: 'sw 10/27/1999 10:51'! - asNontranslucentColor - ^ self! ! -!Color methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:20:07'! - bitPatternForDepth: depth - "Return a Bitmap, that best represents this color at the given depth. BitBlt calls this method to convert colors into Bitmaps." - "See also: pixelValueForDepth: -- value for single pixel - pixelWordForDepth: -- a 32-bit word filled with the pixel value" - - ^ Bitmap with: (self pixelWordForDepth: depth)! ! -!Color methodsFor: 'conversions' stamp: 'jmv 6/3/2016 17:28'! - bitPatternForGrayForm - "Return a Bitmap, that best represents this color at the given depth. BitBlt calls this method to convert colors into Bitmaps." - "See also: pixelValueForDepth: -- value for single pixel - pixelWordForDepth: -- a 32-bit word filled with the pixel value" - "Details: The pattern for the most recently requested depth is cached." - - ^Bitmap with: (self pixelWordFor: 8 filledWith: (self luminance * 255) rounded)! ! -!Color methodsFor: 'conversions' stamp: 'jmv 4/19/2013 16:17'! - closestPixelValue1 - "Return the nearest approximation to this color for a monochrome Form." - - "fast special cases" - self isBlack ifTrue: [^ 1]. "black" - self isWhite ifTrue: [^ 0]. "white" - - self luminance > 0.5 - ifTrue: [^ 0] "white" - ifFalse: [^ 1]. "black"! ! -!Color methodsFor: 'conversions' stamp: 'jmv 12/13/2014 16:18'! - closestPixelValue2 - "Return the nearest approximation to this color for a 2-bit deep Form." - - | lum | - "fast special cases" - self isBlack ifTrue: [^ 1]. "black" - self isWhite ifTrue: [^ 2]. "opaque white" - - lum _ self luminance. - lum < 0.2 ifTrue: [^ 1]. "black" - lum > 0.6 ifTrue: [^ 2]. "opaque white" - ^ 3 "50% gray" -! ! -!Color methodsFor: 'conversions' stamp: 'jmv 12/13/2014 16:17'! - closestPixelValue4 - "Return the nearest approximation to this color for a 4-bit deep Form." - - | bIndex | - "fast special cases" - self isBlack ifTrue: [^ 1]. "black" - self isWhite ifTrue: [^ 2]. "opaque white" - - self isRed ifTrue: [^ 4]. - self isGreen ifTrue: [^ 5]. - self isBlue ifTrue: [^ 6]. - self isCyan ifTrue: [^ 7]. - self isYellow ifTrue: [^ 8]. - self isMagenta ifTrue: [^ 9]. - - bIndex _ (self luminance * 8.0) rounded. "bIndex in [0..8]" - ^ #( - 1 "black" - 10 "1/8 gray" - 11 "2/8 gray" - 12 "3/8 gray" - 3 "4/8 gray" - 13 "5/8 gray" - 14 "6/8 gray" - 15 "7/8 gray" - 2 "opaque white" - ) at: bIndex + 1. -! ! -!Color methodsFor: 'conversions' stamp: 'jmv 4/21/2015 09:57'! - closestPixelValue8 - "Return the nearest approximation to this color for an 8-bit deep Form." - - "fast special cases" - self isBlack ifTrue: [^ 1]. "black" - self isWhite ifTrue: [^ 255]. "white" - - ^self saturation < 0.2 - ifTrue: [ - ^ self class grayToIndexMap at:(self green * 255) rounded + 1. "nearest gray" - ] - ifFalse: [ - "compute nearest entry in the color cube" - 40 + - ((self red * 5) rounded * 36) + - ((self blue * 5) rounded * 6) + - (self green * 5) rounded ]! ! -!Color methodsFor: 'conversions' stamp: 'di 9/2/97 20:21'! - dominantColor - ^ self! ! -!Color methodsFor: 'conversions' stamp: 'jmv 6/2/2016 14:48'! - indexInMap: aColorMap - "Return the index corresponding to this color in the given color map. RGB colors are truncated to 3-, 4-, or 5-bits per color component when indexing into such a colorMap. " - - aColorMap size = 2 ifTrue: [^ (self pixelValueForDepth: 1) + 1]. - aColorMap size = 4 ifTrue: [^ (self pixelValueForDepth: 2) + 1]. - aColorMap size = 16 ifTrue: [^ (self pixelValueForDepth: 4) + 1]. - aColorMap size = 256 ifTrue: [^ (self pixelValueForDepth: 8) + 1]. - aColorMap size = 512 ifTrue: [^ (self pixelValueForDepth: 9) + 1]. - aColorMap size = 4096 ifTrue: [^ (self pixelValueForDepth: 12) + 1]. - aColorMap size = 32768 ifTrue: [^ (self pixelValueForDepth: 15) + 1]. - self error: 'unknown pixel depth'. -! ! -!Color methodsFor: 'conversions' stamp: 'bf 4/18/2001 16:25'! - makeForegroundColor - "Make a foreground color contrasting with me" - ^self luminance >= 0.5 - ifTrue: [Color black] - ifFalse: [Color white]! ! -!Color methodsFor: 'conversions' stamp: 'jmv 6/2/2016 14:50'! - pixelValueForDepth: d - "Returns an integer representing the bits that appear in a single pixel of this color in a Form of the given depth. The depth must be one of 1, 2, 4, 8, 16, or 32. Contrast with pixelWordForDepth: and bitPatternForDepth:, which return either a 32-bit word packed with the given pixel value or a multiple-word Bitmap containing a pattern. The inverse is the class message colorFromPixelValue:depth:" - "Details: For depths of 8 or less, the result is a colorMap index. For depths of 16 and 32, it is a direct color value with 5 or 8 bits per color component." - "Transparency: The pixel value zero is reserved for transparent. For depths greater than 8 and less than 32 (no Indexed colors, no real alpha), black maps to the darkest possible blue. - Note that - Color transparent class = TranslucentColor - this special case is handled in TranslucentColor >> #pixelValueForDepth: - " - - | bitBltFakeBlack val | - d = 8 ifTrue: [^ self closestPixelValue8]. "common case" - d < 8 ifTrue: [ - d = 4 ifTrue: [^ self closestPixelValue4]. - d = 2 ifTrue: [^ self closestPixelValue2]. - d = 1 ifTrue: [^ self closestPixelValue1]]. - - d = 32 ifTrue: [ - "eight bits per component; top 8 bits set to all ones (opaque alpha)" - val _ LargePositiveInteger new: 4. - val at: 3 put: (self red * 255) rounded. - val at: 2 put: (self green * 255) rounded. - val at: 1 put: (self blue * 255) rounded. - val at: 4 put: 16rFF. "opaque alpha" - ^ val normalize]. - - "For the depth 16, pixelValue = 0 means transparent, black is represented as 16r8000 (rgb=0, pixelvalue !!= 0)." - (d = 16) | (d = 15) ifTrue: [ - "five bits per component; top bits ignored" - val _ ((self red * 31) rounded bitShift: 10) bitOr: - (((self green * 31) rounded bitShift: 5) bitOr: - ((self blue * 31) rounded)). - ^ val = 0 - ifTrue: [d = 16 ifTrue: [16r8000] ifFalse: [1]] - ifFalse: [val]]. - - "For the rest of the depths, pixelValue = 0 means transparent, and darkest blue is considered to be black." - bitBltFakeBlack := 1. "closest black that is not transparent in RGB - Not for depths <=8 (Indexed) or = 32 (RGBA)" - d = 12 ifTrue: [ "for indexing a color map with 4 bits per color component" - val _ ((self red * 15) rounded bitShift: 8) bitOr: - (((self green * 15) rounded bitShift: 4) bitOr: - ((self blue * 15) rounded)). - ^ val = 0 ifTrue: [bitBltFakeBlack] ifFalse: [val]]. - - d = 9 ifTrue: [ "for indexing a color map with 3 bits per color component" - val _ ((self red * 7) rounded bitShift: 6) bitOr: - (((self green * 7) rounded bitShift: 3) bitOr: - ((self blue * 7) rounded)). - ^ val = 0 ifTrue: [bitBltFakeBlack] ifFalse: [val]]. - - self error: 'unknown pixel depth: ', d printString! ! -!Color methodsFor: 'conversions' stamp: 'di 11/30/1998 09:03'! - pixelWordFor: depth filledWith: pixelValue - "Return to a 32-bit word that concatenates enough copies of the given pixel value to fill the word (i.e., 32/depth copies). Depth should be one of 1, 2, 4, 8, 16, or 32. The pixel value should be an integer in 0..2^depth-1." - | halfword | - depth = 32 ifTrue: [^ pixelValue]. - depth = 16 - ifTrue: [halfword _ pixelValue] - ifFalse: [halfword _ pixelValue * - (#(16rFFFF "replicates at every bit" - 16r5555 - "replicates every 2 bits" - 16r1111 - - - "replicates every 4 bits" - 16r0101) at: depth) "replicates every 8 bits"]. - ^ halfword bitOr: (halfword bitShift: 16)! ! -!Color methodsFor: 'conversions'! - pixelWordForDepth: depth - "Return to a 32-bit word that concatenates enough copies of the receiver's pixel value to fill the word (i.e., 32/depth copies). Depth should be one of 1, 2, 4, 8, 16, or 32. The pixel value should be an integer in 0..2^depth-1." - - | pixelValue | - pixelValue _ self pixelValueForDepth: depth. - ^ self pixelWordFor: depth filledWith: pixelValue -! ! -!Color methodsFor: 'equality' stamp: 'jmv 6/18/2017 20:38:11'! - diff: theOther - "Returns a number between 0.0 and 1.0. - Color gray diff: Color red - " - ^(self - theOther ) abs sum / self size! ! -!Color methodsFor: 'equality' stamp: 'KenD 12/8/2013 08:35'! - rgbDistance: otherColor - "Compare two colors in distance" -" - ^ (self hue - otherColor hue) abs + - (self saturation - otherColor saturation) abs *10 + - (self brightness - otherColor brightness) abs -" - "See http://www.compuphase.com/cmetric.htm" - | meanRed deltaRed deltaGreen deltaBlue | - meanRed := (self red + otherColor red) abs / 2. - deltaRed := (self red - otherColor red) abs. - deltaGreen := (self green - otherColor green) abs. - deltaBlue := (self blue - otherColor blue) abs. - - ^ ( ((2 + (meanRed / 256)) * (deltaRed * deltaRed)) + - (4 * deltaGreen) + - ((2 + ((255 - meanRed) / 256)) * deltaBlue) - ) sqrt! ! -!Color methodsFor: 'groups of shades' stamp: 'tk 6/18/96'! - darkShades: thisMany - "An array of thisMany colors from black to the receiver. Array is of length num. Very useful for displaying color based on a variable in your program. " - "Color showColors: (Color red darkShades: 12)" - - ^ self class black mix: self shades: thisMany -! ! -!Color methodsFor: 'groups of shades' stamp: 'tk 6/18/96'! - lightShades: thisMany - "An array of thisMany colors from white to self. Very useful for displaying color based on a variable in your program. " - "Color showColors: (Color red lightShades: 12)" - - ^ self class white mix: self shades: thisMany -! ! -!Color methodsFor: 'groups of shades' stamp: 'tk 6/18/96'! - mix: color2 shades: thisMany - "Return an array of thisMany colors from self to color2. Very useful for displaying color based on a variable in your program. " - "Color showColors: (Color red mix: Color green shades: 12)" - - | redInc greenInc blueInc rr gg bb c out | - thisMany = 1 ifTrue: [^ Array with: color2]. - redInc _ color2 red - self red / (thisMany-1). - greenInc _ color2 green - self green / (thisMany-1). - blueInc _ color2 blue - self blue / (thisMany-1). - rr _ self red. gg _ self green. bb _ self blue. - out _ (1 to: thisMany) collect: [:num | - c _ Color r: rr g: gg b: bb. - rr _ rr + redInc. - gg _ gg + greenInc. - bb _ bb + blueInc. - c]. - out at: out size put: color2. "hide roundoff errors" - ^ out -! ! -!Color methodsFor: 'groups of shades' stamp: 'di 10/23/2000 09:45'! - wheel: thisMany - "An array of thisMany colors around the color wheel starting at self and ending all the way around the hue space just before self. Array is of length thisMany. Very useful for displaying color based on a variable in your program. " - - | sat bri hue step c | - sat _ self saturation. - bri _ self brightness. - hue _ self hue. - step _ 360.0 / (thisMany max: 1). - ^ (1 to: thisMany) collect: [:num | - c _ Color h: hue s: sat v: bri. "hue is taken mod 360" - hue _ hue + step. - c]. -" -(Color wheel: 8) withIndexDo: [:c :i | Display fill: (i*10@20 extent: 10@20) fillColor: c] -"! ! -!Color methodsFor: 'named colors' stamp: 'KenD 12/8/2013 14:59'! - closestAssocFrom: aColorDict - "Answer closest associated color in aColorDict" -" - ((Color r: 0.3 g: 0.2 b: 0.8) closestAssocFrom: (Color colorNamesDict)) explore. -" - "Filter values for those close in hue (cheap test) then use rgbDistance" - | closeInHue isClose close distance myHue | - closeInHue := OrderedCollection new. - myHue := self hue. - isClose := [ :assoc | | delta | - delta := ((assoc value hue) - myHue) abs. - (delta < 20) or: [ delta > 340 ] "hues within 20 degrees" - ]. - aColorDict associationsDo: [ :assoc | - (isClose value: assoc) ifTrue: [ closeInHue add: assoc ] - ]. - - close := nil. - distance := 1000. "big" - (closeInHue size > 0) - ifFalse: [ "fallback -- no color really close" - aColorDict associationsDo: [ :assoc | | dist | - dist := self rgbDistance: (assoc value). - (dist < distance) ifTrue: [distance := dist. close := assoc] - ] - ] - ifTrue: [ closeInHue do: [ :assoc | | dist | - dist := self rgbDistance: (assoc value). - (dist < distance) ifTrue: [distance := dist. close := assoc] - ] - ]. - - ^ close! ! -!Color methodsFor: 'named colors' stamp: 'KenD 1/26/2013 16:33'! - closestColor - "Answer the closest matching color in the colorNames dictionary" - -" - (Color red lighter lighter) closestColor explore. -" - ^ self closestColorFrom: (Color colorNamesDict)! ! -!Color methodsFor: 'named colors' stamp: 'KenD 1/26/2013 16:36'! - closestColorAssociation - "Answer this color's closest name->color match." - -" - (Color blue lighter lighter) closestColorAssociation explore. -" - ^ self closestAssocFrom: (Color colorNamesDict)! ! -!Color methodsFor: 'named colors' stamp: 'KenD 1/25/2013 14:31'! - closestColorFrom: aColorDict - "Answer closest associated color" -" - ((Color lightBlue) closestColorFrom: (Color css2NamedColors)) explore.. -" - ^(self closestAssocFrom: aColorDict) value! ! -!Color methodsFor: 'named colors' stamp: 'KenD 1/26/2013 16:36'! - closestColorName - "Answer the name symbol of the closest matching color in the colorNames dictionary" -" - (Color red lighter lighter) closestColor name. -" - - ^ self closestNameFrom: (Color colorNamesDict)! ! -!Color methodsFor: 'named colors' stamp: 'KenD 1/26/2013 16:36'! - closestNameFrom: aColorDict - "Answer closest associated color name" -" - ((Color lightBlue) closestNameFrom: (Color namedColors)) print. -" - ^(self closestAssocFrom: aColorDict) key! ! -!Color methodsFor: 'other' stamp: 'KenD 7/18/2015 20:41'! - colorName - "Return this color's name, or nil if it has no name. Only returns a name if it exactly matches the named color." - - ^(Color colorNamesDict keyAtValue: self ifAbsent: [nil]) -! ! -!Color methodsFor: 'other' stamp: 'KenD 7/18/2015 20:46'! - name - "Return this color's name, or description if unnamed." - - ^ self printString -! ! -!Color methodsFor: 'printing' stamp: 'jmv 2/13/2014 13:41'! - hexStringRGB - " - Color fromUser hexStringRGB - " - ^String streamContents: [ :strm | - (self red * 255) rounded printOn: strm base: 16 length: 2 padded: true. - (self green * 255) rounded printOn: strm base: 16 length: 2 padded: true. - (self blue * 255) rounded printOn: strm base: 16 length: 2 padded: true ]! ! -!Color methodsFor: 'printing' stamp: 'KenD 7/18/2015 20:42'! - printOn: aStream - self colorName ifNotNil: [ :name | - ^ aStream - nextPutAll: 'Color '; - nextPutAll: name]. - self storeOn: aStream. -! ! -!Color methodsFor: 'printing' stamp: 'KenD 7/18/2015 20:44'! - printString - "Answer a String whose characters are a description of the receiver." - - ^ String streamContents: [ :stream | self printOn: stream ]! ! -!Color methodsFor: 'printing' stamp: 'mir 7/21/1999 11:41'! - storeArrayOn: aStream - - aStream nextPutAll: '#('. - self storeArrayValuesOn: aStream. - aStream nextPutAll: ') ' -! ! -!Color methodsFor: 'printing' stamp: 'jmv 1/5/2014 21:04'! - storeArrayValuesOn: aStream - - - self red printOn: aStream fractionDigits: 3. - aStream space. - self green printOn: aStream fractionDigits: 3. - aStream space. - self blue printOn: aStream fractionDigits: 3 - -! ! -!Color methodsFor: 'printing' stamp: 'jmv 1/5/2014 21:01'! - storeOn: aStream - - aStream - nextPut: $(; - nextPutAll: self class name; - nextPutAll: ' r: '. - self red printOn: aStream fractionDigits: 3. - aStream nextPutAll: ' g: '. - self green printOn: aStream fractionDigits: 3. - aStream nextPutAll: ' b: '. - self blue printOn: aStream fractionDigits: 3. - aStream nextPut: $)! ! -!Color methodsFor: 'queries' stamp: 'jmv 6/18/2017 20:40:55'! - isBlack - "Return true if the receiver represents black" - (self at: 1) = 0.0 ifFalse: [ ^ false ]. - (self at: 2) = 0.0 ifFalse: [ ^ false ]. - (self at: 3) = 0.0 ifFalse: [ ^ false ]. - ^ true! ! -!Color methodsFor: 'queries' stamp: 'ar 4/20/2001 04:33'! - isOpaque - ^true! ! -!Color methodsFor: 'queries'! - isTransparent - - ^ false -! ! -!Color methodsFor: 'queries' stamp: 'jmv 6/18/2017 20:40:46'! - isWhite - "Return true if the receiver represents white" - (self at: 1) = 1.0 ifFalse: [ ^ false ]. - (self at: 2) = 1.0 ifFalse: [ ^ false ]. - (self at: 3) = 1.0 ifFalse: [ ^ false ]. - ^ true! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:35'! - isBlue - "Am I considered Blue?" - - ^self blue > (self green + 0.3) - and: [self blue > (self red + 0.3)] - and: [(self green - self red) abs < 0.4]! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:37'! - isBlueGreen - "Am I considered BlueGreen ?" - - ^self green > self red - and: [self red < 0.3] - and: [(self green - self blue) abs < 0.1]! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:50'! - isBright - "Am I considered a Bright color ?" - - ^self brightness > 0.6! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:40'! - isBrown - "Am I considered Brown ?" - - ^self red >= self green - and: [self green > self blue] - and: [(self red - self green) < 0.5] - and: [(self green - self blue) < 0.3]! ! -!Color methodsFor: 'selection' stamp: 'jmv 4/19/2013 17:14'! - isCyan - "Am I considered Cyan ?" - - ^self red < 0.05 - and: [(self green min: self blue) > 0.5] - and: [(self green - self blue) abs < 0.2]! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:50'! - isDark - "Am I considered a Dark color ?" - - ^self brightness < 0.5! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:42'! - isGray - "Am I considered Gray ?" - - ^(self red closeTo: self green) - and: [self blue closeTo: self green ]! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:38'! - isGreen - "Am I considered Green ?" - - ^self green > (self blue + 0.3) - and: [self blue > (self red + 0.3)]! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:40'! - isGrey - "Am I considered Grey ?" - - ^self isGray! ! -!Color methodsFor: 'selection' stamp: 'jmv 4/19/2013 17:06'! - isLight - "Am I considered a Light color ?" - - ^self brightness > 0.6! ! -!Color methodsFor: 'selection' stamp: 'jmv 4/19/2013 17:13'! - isMagenta - "Am I considered Magenta ?" - - ^self green < 0.05 - and: [(self red min: self blue) > 0.5] - and: [(self red - self blue) abs < 0.2]! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:44'! - isOrange - "Am I considered Orange ?" - - ^self red > ((self green max: self blue) + 0.2) - and: [self green > (self blue + 0.2)]! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:45'! - isPastel - "Am I considered Pastel ?" - - ^self saturation < 0.4! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:46'! - isPink - "Am I considered Pink ?" - - ^self red > ((self green max: self blue) + 0.3) - and: [self blue > (self green + 0.2)]! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:47'! - isRed - "Am I considered Red ?" - - ^self red > (self green + 0.4) - and: [self red > (self blue + 0.6)] - and: [(self green - self blue) abs < 0.4]! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:55'! - isSaturated - "Am I considered to be a Saturated color ?" - - ^self saturation > 0.6! ! -!Color methodsFor: 'selection' stamp: 'KenD 1/30/2013 16:49'! - isYellow - "Am I considered Yellow ?" - - ^self blue < 0.05 - and: [(self red min: self green) > 0.5] - and: [(self red - self green) abs < 0.2]! ! -!Color methodsFor: 'testing' stamp: 'jmv 12/2/2010 08:38'! - is: aSymbol - ^ aSymbol == #Color or: [ super is: aSymbol ]! ! -!Color methodsFor: 'testing' stamp: 'jmv 2/10/2011 21:46'! - mightBeTranslucent - "For Colors, answer if actually translucent or not." - ^self isOpaque not! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:56:14'! - * aNumber - "Answer this color with its RGB multiplied by the given number. " - " - (Color brown *2) display - " - ^ (Color new - setRed: (self red * aNumber min: 1.0 max: 0.0) - green: (self green * aNumber min: 1.0 max: 0.0) - blue: (self blue * aNumber min: 1.0 max: 0.0)) - alpha: self alpha! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:56:18'! - + aColor - "Answer this color mixed with the given color in an additive color space. " - " - (Color blue + Color green) display - " - ^ Color new - setRed: (self red + aColor red min: 1.0 max: 0.0) - green: (self green + aColor green min: 1.0 max: 0.0) - blue: (self blue + aColor blue min: 1.0 max: 0.0)! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:56:22'! - - aColor - "Answer aColor is subtracted from the given color in an additive color space. " - " - (Color white - Color red) display - " - ^ Color new - setRed: (self red - aColor red min: 1.0 max: 0.0) - green: (self green - aColor green min: 1.0 max: 0.0) - blue: (self blue - aColor blue min: 1.0 max: 0.0)! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:56:26'! - / aNumber - "Answer this color with its RGB divided by the given number. " - " - (Color red / 2) display - " - ^ Color new - setRed: (self red / aNumber min: 1.0 max: 0.0) - green: (self green / aNumber min: 1.0 max: 0.0) - blue: (self blue / aNumber min: 1.0 max: 0.0)! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:50'! - adjustBrightness: brightness - "Adjust the relative brightness of this color. (lowest value is 0.005 so that hue information is not lost)" - - ^ Color - h: self hue - s: self saturation - v: (self brightness + brightness min: 1.0 max: 0.005) - alpha: self alpha! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:51'! - adjustSaturation: saturation brightness: brightness - "Adjust the relative saturation and brightness of this color. (lowest value is 0.005 so that hue information is not lost)" - - ^ Color - h: self hue - s: (self saturation + saturation min: 1.0 max: 0.005) - v: (self brightness + brightness min: 1.0 max: 0.005) - alpha: self alpha! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 21:10:41'! - alpha: alphaValue - "Return a new TranslucentColor with the given amount of opacity ('alpha')." - alphaValue = 1.0 ifFalse: [ - ^ TranslucentColor new - setRed: self red - green: self green - blue: self blue - alpha: alphaValue ]! ! -!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 11:55'! - alphaMixed: proportion with: aColor - "Answer this color mixed with the given color. The proportion, a number - between 0.0 and 1.0, determines what what fraction of the receiver to - use in the mix. For example, 0.9 would yield a color close to the - receiver. This method uses RGB interpolation; HSV interpolation can lead - to surprises. Mixes the alphas (for transparency) also." - - | frac1 frac2 | - frac1 _ proportion asFloat min: 1.0 max: 0.0. - frac2 _ 1.0 - frac1. - ^ Color - r: self red * frac1 + (aColor red * frac2) - g: self green * frac1 + (aColor green * frac2) - b: self blue * frac1 + (aColor blue * frac2) - alpha: self alpha * frac1 + (aColor alpha * frac2)! ! -!Color methodsFor: 'transformations' stamp: 'RAA 6/2/2000 08:47'! - atLeastAsLuminentAs: aFloat - - | revisedColor | - revisedColor _ self. - [revisedColor luminance < aFloat] whileTrue: [revisedColor _ revisedColor slightlyLighter]. - ^revisedColor -! ! -!Color methodsFor: 'transformations' stamp: 'nk 3/8/2004 09:43'! - atMostAsLuminentAs: aFloat - - | revisedColor | - revisedColor _ self. - [revisedColor luminance > aFloat] whileTrue: [revisedColor _ revisedColor slightlyDarker]. - ^revisedColor -! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/23/2002 01:38'! - blacker - - ^ self alphaMixed: 0.8333 with: Color black -! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:54'! - dansDarker - "Return a darker shade of the same color. - An attempt to do better than the current darker method. - (now obsolete, since darker has been changed to do this. -dew)" - ^ Color h: self hue s: self saturation - v: (self brightness - 0.16 max: 0.0)! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:40'! - darker - "Answer a darker shade of this color." - - ^ self adjustBrightness: -0.08! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/8/2002 00:13'! - duller - - ^ self adjustSaturation: -0.03 brightness: -0.2! ! -!Color methodsFor: 'transformations' stamp: 'dew 1/23/2002 20:19'! - lighter - "Answer a lighter shade of this color." - - ^ self adjustSaturation: -0.03 brightness: 0.08! ! -!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 12:00'! - mixed: proportion with: aColor - "Mix with another color and do not preserve transpareny. Only use this for extracting the RGB value and mixing it. All other callers should use instead: - aColor alphaMixed: proportion with: anotherColor - " - - | frac1 frac2 | - frac1 _ proportion asFloat min: 1.0 max: 0.0. - frac2 _ 1.0 - frac1. - ^ Color - r: self red * frac1 + (aColor red * frac2) - g: self green * frac1 + (aColor green * frac2) - b: self blue * frac1 + (aColor blue * frac2)! ! -!Color methodsFor: 'transformations' stamp: 'dew 1/19/2002 01:29'! - muchDarker - - ^ self alphaMixed: 0.5 with: Color black -! ! -!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 12:07'! - muchLighter - - ^ self alphaMixed: 0.233 with: Color white -! ! -!Color methodsFor: 'transformations' stamp: 'ar 6/19/1999 00:36'! - negated - "Return an RGB inverted color" - ^Color - r: 1.0 - self red - g: 1.0 - self green - b: 1.0 - self blue! ! -!Color methodsFor: 'transformations' stamp: 'jmv 6/18/2017 20:37:53'! - orColorUnlike: theOther - "If this color is a lot like theOther, then return its complement, otherwide, return self" - - ^ (self diff: theOther) < 0.3 - ifTrue: [theOther negated] - ifFalse: [self]! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:42'! - paler - "Answer a paler shade of this color." - - ^ self adjustSaturation: -0.09 brightness: 0.09 -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 9/10/2009 18:41'! - quiteBlacker - - ^ self alphaMixed: 0.8 with: Color black -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 9/10/2009 18:44'! - quiteWhiter - - ^ self alphaMixed: 0.6 with: Color white! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:43'! - slightlyDarker - - ^ self adjustBrightness: -0.03 -! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:43'! - slightlyLighter - - ^ self adjustSaturation: -0.01 brightness: 0.03! ! -!Color methodsFor: 'transformations' stamp: 'dew 1/19/2002 01:25'! - slightlyWhiter - - ^ self alphaMixed: 0.85 with: Color white -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 5/7/2012 15:05'! - twiceDarker - "Answer a significantly darker shade of this color." - - ^ self adjustSaturation: 0.076 brightness: -0.15! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:45'! - twiceLighter - "Answer a significantly lighter shade of this color." - - ^ self adjustSaturation: -0.06 brightness: 0.15! ! -!Color methodsFor: 'transformations' stamp: 'jmv 8/23/2009 23:24'! - veryMuchDarker - - ^ self alphaMixed: 0.25 with: Color black -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 7/28/2016 15:43:04'! - veryMuchLighter - - ^ self alphaMixed: 0.07 with: Color white! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/23/2002 01:38'! - whiter - - ^ self alphaMixed: 0.8333 with: Color white -! ! -!Color methodsFor: 'private'! - attemptToMutateError - "A color is immutable. Once a color's red, green, and blue have been initialized, you cannot change them. Instead, create a new Color and use it." - - self error: 'Color objects are immutable once created' -! ! -!Color methodsFor: 'private' stamp: 'jmv 6/18/2017 20:29:32'! - basicSetRed: r green: g blue: b - "Initialize this color's r, g, and b components to the given values in the range [0.0..1.0]." - - self - at: 1 put: r; - at: 2 put: g; - at: 3 put: b! ! -!Color methodsFor: 'private' stamp: 'jmv 6/18/2017 20:15:44'! - setHue: hue chroma: chroma brightness: brightness - "Initialize this color to the given hue, chroma, and luma. See the comment in the instance creation method for details. - http://en.wikipedia.org/wiki/HSL_and_HSV - hue belongs in [0.0, 360.0) - chroma and luma belongs in [0.0, 1.0] - " - - | x hf i r1 g1 b1 m | - hf _ hue \\ 360. - i _ hf // 60. "integer part of hue" - x _ (hf \\ 60) / 60.0 . "fractional part of hue" - x _ x \\ 2 . - i \\ 2 = 1 ifTrue: [ x _ 1.0 - x ]. - x _ chroma * x. - - 0 = i ifTrue: [ r1 _ chroma. g1 _ x. b1 _ 0.0 ]. - 1 = i ifTrue: [ r1 _ x. g1 _ chroma. b1 _ 0.0 ]. - 2 = i ifTrue: [ r1 _ 0.0. g1 _ chroma. b1 _ x ]. - 3 = i ifTrue: [ r1 _ 0.0. g1 _ x. b1 _ chroma ]. - 4 = i ifTrue: [ r1 _ x. g1 _ 0.0. b1 _ chroma ]. - 5 = i ifTrue: [ r1 _ chroma. g1 _ 0.0. b1 _ x ]. - - m _ brightness - ((r1 max: g1) max: b1). - m < 0.0 - ifTrue: [ ^nil ]. "No color exists with required parameters" - r1 _ r1 + m. - r1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - g1 _ g1 + m. - g1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - b1 _ b1 + m. - b1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - self setRed: r1 green: g1 blue: b1! ! -!Color methodsFor: 'private' stamp: 'jmv 6/18/2017 20:15:49'! - setHue: hue chroma: chroma luminance: luma - "Initialize this color to the given hue, chroma, and luma. See the comment in the instance creation method for details. - http://en.wikipedia.org/wiki/HSL_and_HSV - hue belongs in [0.0, 360.0) - chroma and luma belongs in [0.0, 1.0] - " - - | x hf i r1 g1 b1 m | - - hf _ hue \\ 360. - i _ hf // 60. "integer part of hue" - x _ (hf \\ 60) / 60.0 . "fractional part of hue" - x _ x \\ 2 . - i \\ 2 = 1 ifTrue: [ x _ 1.0 - x ]. - x _ chroma * x. - - 0 = i ifTrue: [ r1 _ chroma. g1 _ x. b1 _ 0.0 ]. - 1 = i ifTrue: [ r1 _ x. g1 _ chroma. b1 _ 0.0 ]. - 2 = i ifTrue: [ r1 _ 0.0. g1 _ chroma. b1 _ x ]. - 3 = i ifTrue: [ r1 _ 0.0. g1 _ x. b1 _ chroma ]. - 4 = i ifTrue: [ r1 _ x. g1 _ 0.0. b1 _ chroma ]. - 5 = i ifTrue: [ r1 _ chroma. g1 _ 0.0. b1 _ x ]. - - m _ luma - (0.299*r1) - (0.587*g1) - (0.114*b1). - m < 0.0 - ifTrue: [ ^nil ]. "No color exists with required parameters" - r1 _ r1 + m. - r1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - g1 _ g1 + m. - g1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - b1 _ b1 + m. - b1 > 1.0 - ifTrue: [ ^nil ]. "No color exists with required parameters". - self setRed: r1 green: g1 blue: b1! ! -!Color methodsFor: 'private' stamp: 'jmv 6/18/2017 20:16:07'! - setHue: hue saturation: saturation brightness: brightness - "Initialize this color to the given hue, saturation, and brightness. See the comment in the instance creation method for details." - - | s v hf i f p q t | - s _ saturation asFloat min: 1.0 max: 0.0. - v _ brightness asFloat min: 1.0 max: 0.0. - hf _ hue \\ 360. - i _ hf // 60. "integer part of hue" - f _ (hf \\ 60) / 60.0. "fractional part of hue" - - p _ (1.0 - s) * v. - q _ (1.0 - (s * f)) * v. - t _ (1.0 - (s * (1.0 - f))) * v. - - 0 = i ifTrue: [ ^ self setRed: v green: t blue: p ]. - 1 = i ifTrue: [ ^ self setRed: q green: v blue: p ]. - 2 = i ifTrue: [ ^ self setRed: p green: v blue: t ]. - 3 = i ifTrue: [ ^ self setRed: p green: q blue: v ]. - 4 = i ifTrue: [ ^ self setRed: t green: p blue: v ]. - 5 = i ifTrue: [ ^ self setRed: v green: p blue: q ]. - - self error: 'implementation error'! ! -!Color methodsFor: 'private' stamp: 'jmv 6/18/2017 20:13:04'! - setRed: r green: g blue: b - - self basicSetRed: r green: g blue: b! ! -!Color methodsFor: 'private' stamp: 'jmv 6/18/2017 20:29:48'! - setRed: r green: g blue: b range: range - "Initialize this color's r, g, and b components to the given values in the range [0..r]." - - self basicSetRed: r green: g blue: b. - self /= range! ! -!Color methodsFor: 'as yet unclassified' stamp: 'jmv 8/15/2015 18:23'! - color - ^ self! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 9/17/2015 15:22'! - clipR: r g: g b: b - "Return a color with the given r, g, and b components in the range [0.0..1.0]. - Clip if necessary" - - ^ self - r: (r min: 1.0 max: 0.0) - g: (g min: 1.0 max: 0.0) - b: (b min: 1.0 max: 0.0)! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 4/2/2016 23:05'! - colorFrom: parm - "Return an instantiated color from parm. If parm is already a color, return it, else return the result of my performing it if it's a symbol or, if it is a list, it can either be an array of three numbers, which will be interpreted as RGB values, or a list of symbols, the first of which is sent to me and then the others of which are in turn sent to the prior result, thus allowing entries of the form #(blue darker). Else just return the thing" - - | aColor firstParm | - (parm is: #Color) ifTrue: [ ^ parm ]. - parm isSymbol ifTrue: [ ^ self perform: parm ]. - (parm isSequenceableCollection and: [ parm size > 0 ]) - ifTrue: [ - firstParm _ parm first. - firstParm isNumber ifTrue: [ - ^ self fromRgbTriplet: parm]. - aColor _ self colorFrom: firstParm. - parm withIndexDo: [ :sym :ind | - ind > 1 ifTrue: [ - aColor _ aColor perform: sym ]]. - ^ aColor]. - ^ parm - -" -Color colorFrom: #(blue darker) -Color colorFrom: Color blue darker -Color colorFrom: #blue -Color colorFrom: #(0.0 0.0 1.0) -"! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/2/2016 15:04'! - colorFromPixelValue: p depth: d - "Convert a pixel value for the given display depth into a color." - "Details: For depths of 8 or less, the pixel value is simply looked up in a table. For greater depths, the color components are extracted and converted into a color." - "Warning: In BitBlt, a pixel with pixelValue = 0 is transparent. - Squeak usually assumes that r=g=b=0 => transparent. But this is false if we have alpha (opacity). - A color with r=g=b=0 and opacity = 255 is BLACK, not TRANSPARENT. - Squeak also answers darkest possible blue when asked for black. Again, this is not needed in 32 bits (with alpha). It is also not really needed for 16 bits as we have an extra, unused bit: 16r8000 is not zero, but rgb=0, and hence, black. - The real rule is that pixelValue=0 means transparent. - And that darkest blue must be used instead of black, but only for depths >8 and < 16 (no indexed colors, no alpha) - This method is updated to reflect that." - - | r g b alpha | - - d = 1 ifTrue: [^ self indexedColors at: (p bitAnd: 16r01) + 1]. - - "For the rest of the depths, pixelValue = 0 means transparent, and darkest blue is considered to be black." - p = 0 ifTrue: [ ^Color transparent ]. - - d = 8 ifTrue: [^ self indexedColors at: (p bitAnd: 16rFF) + 1]. - d = 4 ifTrue: [^ self indexedColors at: (p bitAnd: 16r0F) + 1]. - d = 2 ifTrue: [^ self indexedColors at: (p bitAnd: 16r03) + 1]. - - d = 32 ifTrue: [ - "eight bits per component; 8 bits of alpha" - alpha _ p bitShift: -24. - alpha = 0 ifTrue: [ ^Color transparent ]. - r _ (p bitShift: -16) bitAnd: 16rFF. - g _ (p bitShift: -8) bitAnd: 16rFF. - b _ p bitAnd: 16rFF. - ^alpha < 255 - ifTrue: [ (Color r: r g: g b: b range: 255) alpha: alpha asFloat / 255.0 ] - ifFalse: [ Color r: r g: g b: b range: 255 ]]. - - d = 16 ifTrue: [ - "five bits per component. The most significant bit, unused, allows having real black, without p being zero" - r _ (p bitShift: -10) bitAnd: 16r1F. - g _ (p bitShift: -5) bitAnd: 16r1F. - b _ p bitAnd: 16r1F. - ^ Color r: r g: g b: b range: 31]. - - d = 15 ifTrue: [ - "five bits per component" - r _ (p bitShift: -10) bitAnd: 16r1F. - g _ (p bitShift: -5) bitAnd: 16r1F. - b _ p bitAnd: 16r1F. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Color black ]. - ^ Color r: r g: g b: b range: 31]. - - d = 12 ifTrue: [ - "four bits per component" - r _ (p bitShift: -8) bitAnd: 16rF. - g _ (p bitShift: -4) bitAnd: 16rF. - b _ p bitAnd: 16rF. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Color black ]. - ^ Color r: r g: g b: b range: 15]. - - d = 9 ifTrue: [ - "three bits per component" - r _ (p bitShift: -6) bitAnd: 16r7. - g _ (p bitShift: -3) bitAnd: 16r7. - b _ p bitAnd: 16r7. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Color black ]. - ^ Color r: r g: g b: b range: 7]. - - self error: 'unknown pixel depth: ', d printString! ! -!Color class methodsFor: 'instance creation' stamp: 'sqr 10/15/2016 20:41:04'! - fromArray: colorDef - - | answer | - colorDef size = 0 ifTrue: [^self transparent]. - colorDef size between: 3 and: 4 :: ifFalse: [self error: 'Undefined color definition']. - answer _ self r: (colorDef at: 1) g: (colorDef at: 2) b: (colorDef at: 3). - ^colorDef size = 3 - ifTrue: [answer] - ifFalse: [answer alpha: (colorDef at: 4)]! ! -!Color class methodsFor: 'instance creation' stamp: 'sw 8/8/97 22:03'! - fromRgbTriplet: list - ^ self r: list first g: list second b: list last! ! -!Color class methodsFor: 'instance creation' stamp: 'pb 10/16/2016 18:42:44'! - fromString: aString - "For HTML color spec: #FFCCAA. Also support named colors. - See http://www.w3schools.com/cssref/css_colors_legal.asp" - " - Color fromString: '#FFCCAA'. - Color fromString: 'white'. - Color fromString: 'orange' - Color fromString: 'rgb(255,0,98)' - " - (aString size = 7 and: [ aString first = $# ]) ifTrue: [ - | aColorHexU red green blue | - aColorHexU _ aString asUppercase. - red _ ('16r', (aColorHexU copyFrom: 2 to: 3)) asNumber/255. - green _ ('16r', (aColorHexU copyFrom: 4 to: 5)) asNumber/255. - blue _ ('16r', (aColorHexU copyFrom: 6 to: 7)) asNumber/255. - ^ self r: red g: green b: blue]. - - (aString beginsWith: 'rgb') - ifTrue: [|values r g b| - values := (aString allButFirst: 4) allButLast findTokens: ','. - r := (values first includes: $%) - ifTrue: [(values first asNumber min: 100 max: 0) / 100.0] - ifFalse: [(values first asInteger min: 255 max: 0) / 255.0]. - g := (values second includes: $%) - ifTrue: [(values second asNumber min: 100 max: 0) / 100.0] - ifFalse: [(values second asInteger min: 255 max: 0) / 255.0]. - b := (values third includes: $%) - ifTrue: [(values third asNumber min: 100 max: 0) / 100.0] - ifFalse: [(values third asInteger min: 255 max: 0) / 255.0]. - ^self r: r g: g b: b]. - - ^self exactColorNamed: aString! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:29'! - gray: brightness - "Return a gray shade with the given brightness in the range [0.0..1.0]." - - ^ self new - setRed: brightness - green: brightness - blue: brightness! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:31'! - h: hue s: saturation v: brightness - "Create a color with the given hue, saturation, and brightness. Hue is given as the angle in degrees of the color on the color circle where red is zero degrees. Saturation and brightness are numbers in [0.0..1.0] where larger values are more saturated or brighter colors. For example, (Color h: 0 s: 1 v: 1) is pure red." - "Note: By convention, brightness is abbreviated 'v' to to avoid confusion with blue." - - ^ self new setHue: hue saturation: saturation brightness: brightness! ! -!Color class methodsFor: 'instance creation' stamp: 'dew 3/19/2002 23:49'! - h: h s: s v: v alpha: alpha - - ^ (self h: h s: s v: v) alpha: alpha! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:34'! - hue: hue chroma: chroma brightness: brightness - ^self new setHue: hue chroma: chroma brightness: brightness! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:37'! - hue: hue chroma: chroma luminance: luma - ^self new setHue: hue chroma: chroma luminance: luma! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:39'! - hue: hue saturation: saturation brightness: brightness - "Create a color with the given hue, saturation, and brightness. Hue is given as the angle in degrees of the color on the color circle where red is zero degrees. Saturation and brightness are numbers in [0.0..1.0] where larger values are more saturated or brighter colors. For example, (Color h: 0 s: 1 v: 1) is pure red." - "Note: By convention, brightness is abbreviated 'v' to to avoid confusion with blue." - - ^ self new setHue: hue saturation: saturation brightness: brightness! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:54:20'! - new - ^ self new: 3! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:41'! - r: r g: g b: b - "Return a color with the given r, g, and b components in the range [0.0..1.0]." - - ^ self new - setRed: r - green: g - blue: b! ! -!Color class methodsFor: 'instance creation'! - r: r g: g b: b alpha: alpha - - ^ (self r: r g: g b: b) alpha: alpha! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:43'! - r: r g: g b: b range: range - "Return a color with the given r, g, and b components specified as integers in the range [0..r]. This avoids the floating point arithmetic in the red:green:blue: message and is thus a bit faster for certain applications (such as computing a sequence of colors for a palette)." - - ^ self new setRed: r green: g blue: b range: range! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 4/4/2015 20:30'! - random - "Return a random color that isn't too dark or under-saturated. - Display fill: (10@10 extent: 200@200) fillColor: Color random - " - - ^ Random withDefaultDo: [ :random | - self random: random ]! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 4/4/2015 20:30'! - random2 - "Return a random color with a distribution that spans over all possible colors. - Display fill: (10@10 extent: 200@200) fillColor: Color random2 - " - - ^ Random withDefaultDo: [ :random | - self random2: random ]! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:46'! - random2: aRandom - "Return a random color with a distribution that spans over all possible colors." - - ^ self new - setRed: aRandom next - green: aRandom next - blue: aRandom next! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:56:48'! - random: aRandom - "Return a random color that isn't too dark or under-saturated." - - ^ self new - setHue: (360.0 * aRandom next) - saturation: (0.3 + (aRandom next * 0.7)) - brightness: (0.4 + (aRandom next * 0.6))! ! -!Color class methodsFor: 'class initialization' stamp: 'jmv 4/17/2015 15:06'! - initializeGrayToIndexMap - "Build an array of gray values available in the 8-bit colormap. This array is indexed by a gray level between black (1) and white (256) and returns the pixel value for the corresponding gray level." - "Note: This method must be called after initializeIndexedColors, since it uses IndexedColors." - " - Color initializeGrayToIndexMap - " - - | grayLevels grayIndices c distToClosest dist indexOfClosest indexedColors | - "record the level and index of each gray in the 8-bit color table" - grayLevels _ OrderedCollection new. - grayIndices _ OrderedCollection new. - indexedColors _ self indexedColors. - "Note: skip the first entry, which is reserved for transparent" - 2 to: indexedColors size do: [:i | - c _ indexedColors at: i. - c saturation = 0.0 ifTrue: [ "c is a gray" - grayLevels add: (c green * 255) rounded. "0 to 255; R, G, and B are the same" - grayIndices add: i - 1]]. "pixel values are zero-based" - grayLevels _ grayLevels asArray. - grayIndices _ grayIndices asArray. - - "for each gray level in [0..255], select the closest match" - GrayToIndexMap _ ByteArray new: 256. - 0 to: 255 do: [ :level | - distToClosest _ 10000. "greater than distance to any real gray" - 1 to: grayLevels size do: [:i | - dist _ (level - (grayLevels at: i)) abs. - dist < distToClosest ifTrue: [ - distToClosest _ dist. - indexOfClosest _ grayIndices at: i]]. - GrayToIndexMap at: (level + 1) put: indexOfClosest]! ! -!Color class methodsFor: 'class initialization'! - initializeIndexedColors - "Build an array of colors corresponding to the fixed colormap used - for display depths of 1, 2, 4, or 8 bits." - "Color initializeIndexedColors" - - | a index grayVal | - a _ Array new: 256. - - "1-bit colors (monochrome)" - a at: 1 put: (Color r: 1.0 g: 1.0 b: 1.0). "white or transparent" - a at: 2 put: (Color r: 0.0 g: 0.0 b: 0.0). "black" - - "additional colors for 2-bit color" - a at: 3 put: (Color r: 1.0 g: 1.0 b: 1.0). "opaque white" - a at: 4 put: (Color r: 0.5 g: 0.5 b: 0.5). "1/2 gray" - - "additional colors for 4-bit color" - a at: 5 put: (Color r: 1.0 g: 0.0 b: 0.0). "red" - a at: 6 put: (Color r: 0.0 g: 1.0 b: 0.0). "green" - a at: 7 put: (Color r: 0.0 g: 0.0 b: 1.0). "blue" - a at: 8 put: (Color r: 0.0 g: 1.0 b: 1.0). "cyan" - a at: 9 put: (Color r: 1.0 g: 1.0 b: 0.0). "yellow" - a at: 10 put: (Color r: 1.0 g: 0.0 b: 1.0). "magenta" - - a at: 11 put: (Color r: 0.125 g: 0.125 b: 0.125). "1/8 gray" - a at: 12 put: (Color r: 0.25 g: 0.25 b: 0.25). "2/8 gray" - a at: 13 put: (Color r: 0.375 g: 0.375 b: 0.375). "3/8 gray" - a at: 14 put: (Color r: 0.625 g: 0.625 b: 0.625). "5/8 gray" - a at: 15 put: (Color r: 0.75 g: 0.75 b: 0.75). "6/8 gray" - a at: 16 put: (Color r: 0.875 g: 0.875 b: 0.875). "7/8 gray" - - "additional colors for 8-bit color" - "24 more shades of gray (1/32 increments but not repeating 1/8 increments)" - index _ 17. - 1 to: 31 do: [:v | - (v \\ 4) = 0 ifFalse: [ - grayVal _ v / 32.0. - a at: index put: (Color r: grayVal g: grayVal b: grayVal). - index _ index + 1]]. - - "The remainder of color table defines a color cube with six steps - for each primary color. Note that the corners of this cube repeat - previous colors, but this simplifies the mapping between RGB colors - and color map indices. This color cube spans indices 40 through 255 - (indices 41-256 in this 1-based array)." - 0 to: 5 do: [:r | - 0 to: 5 do: [:g | - 0 to: 5 do: [:b | - index _ 41 + ((36 * r) + (6 * b) + g). - index > 256 ifTrue: [ - self error: 'index out of range in color table compuation']. - a at: index put: (Color r: r g: g b: b range: 5)]]]. - - IndexedColors _ a. -! ! -!Color class methodsFor: 'examples' stamp: 'jmv 8/17/2012 18:48'! - colorRampForDepth: depth extent: aPoint - "Returns a form of the given size showing R, G, B, and gray ramps for the given depth. Useful for testing color conversions between different depths." - "(Color colorRampForDepth: Display depth extent: 256@80) display" - "(Color colorRampForDepth: 32 extent: 256@80) displayOn: Display at: 0@0 rule: Form paint" - - | f dx dy r | - f _ Form extent: aPoint depth: depth. - dx _ aPoint x // 256. - dy _ aPoint y // 4. - 0 to: 255 do: [:i | - r _ (dx * i)@0 extent: dx@dy. - f fill: r fillColor: (Color r: i g: 0 b: 0 range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Color r: 0 g: i b: 0 range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Color r: 0 g: 0 b: i range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Color r: i g: i b: i range: 255)]. - ^ f -! ! -!Color class methodsFor: 'examples' stamp: 'jmv 6/18/2017 21:29:30'! - experimentsTowarsANewColorPalette -" -self experimentsTowarsANewColorPalette -" -| selectedHue selectedSaturation selectedV selectedColor h s v color width height selectedChroma selectedLuminance | -width _ 300. -height _ 120. -selectedColor _ Color random. -selectedHue _ selectedColor hue. -selectedSaturation _ selectedColor saturation. -selectedChroma _ selectedColor chroma. -selectedV _ selectedColor brightness. -selectedLuminance _ selectedColor luminance. -Display getCanvas fillRectangle: (0@0 extent: height@height) color: selectedColor. -0 to: height do: [ :y | - v _ 1.0 - (y / height). - 0 to: height do: [ :x | - s _ x / height. - color _ Color new setHue: selectedHue saturation: s brightness: v. - Display colorAt: x@(y+height) put: color - ]. - DisplayScreen screenUpdateRequired: nil -]. -0 to: height do: [ :y | | c | - v _ 1.0 - (y / height). - s _ 1.0 - (y / height). - c _ s. - 0 to: width do: [ :x | - h _ x / width * 360. - - color _ Color new setHue: h chroma: c luminance: selectedLuminance. -" color _ Color new setHue: h chroma: c brightness: selectedV." - color ifNil: [ color _ Color black ]. -" color _ Color new setHue: h saturation: s brightness: selectedV." - Display colorAt: x+height@y put: color. - - color _ Color new setHue: h chroma: selectedChroma luminance: v. -" color _ Color new setHue: h chroma: selectedChroma brightness: v." - color ifNil: [ color _ Color black ]. -" color _ Color new setHue: h saturation: selectedSaturation brightness: v." - Display colorAt: x+height@(y+height) put: color. - - ]. - DisplayScreen screenUpdateRequired: nil -].! ! -!Color class methodsFor: 'examples' stamp: 'tk 6/19/96'! -hotColdShades: thisMany - "An array of thisMany colors showing temperature from blue to red to white hot. (Later improve this by swinging in hue.) " - "Color showColors: (Color hotColdShades: 25)" - - | n s1 s2 s3 s4 s5 | - thisMany < 5 ifTrue: [^ self error: 'must be at least 5 shades']. - n _ thisMany // 5. - s1 _ self white mix: self yellow shades: (thisMany - (n*4)). - s2 _ self yellow mix: self red shades: n+1. - s2 _ s2 copyFrom: 2 to: n+1. - s3 _ self red mix: self green darker shades: n+1. - s3 _ s3 copyFrom: 2 to: n+1. - s4 _ self green darker mix: self blue shades: n+1. - s4 _ s4 copyFrom: 2 to: n+1. - s5 _ self blue mix: self black shades: n+1. - s5 _ s5 copyFrom: 2 to: n+1. - ^ s1, s2, s3, s4, s5 -! ! -!Color class methodsFor: 'examples'! - showColorCube - "Show a 12x12x12 color cube." - "Color showColorCube" - - 0 to: 11 do: [:r | - 0 to: 11 do: [:g | - 0 to: 11 do: [:b | - Display fill: (((r*60) + (b*5)) @ (g*5) extent: 5@5) - fillColor: (Color r: r g: g b: b range: 11)]]]. -! ! -!Color class methodsFor: 'examples' stamp: 'jmv 8/17/2012 18:48'! - showColors: colorList - "Display the given collection of colors across the top of the Display." - - | w r | - w _ Display width // colorList size. - r _ 0@0 extent: w@((w min: 30) max: 10). - colorList do: [:c | - Display fill: r fillColor: c. - r _ r translatedBy: w@0]. -! ! -!Color class methodsFor: 'examples'! - showHSVPalettes - "Shows a palette of hues, varying the saturation and brightness for each one. Best results are with depths 16 and 32." - "Color showHSVPalettes" - - | left top c | - left _ top _ 0. - 0 to: 179 by: 15 do: [:h | - 0 to: 10 do: [:s | - left _ (h * 4) + (s * 4). - 0 to: 10 do: [:v | - c _ Color h: h s: s asFloat / 10.0 v: v asFloat / 10.0. - top _ (v * 4). - Display fill: (left@top extent: 4@4) fillColor: c. - - c _ Color h: h + 180 s: s asFloat / 10.0 v: v asFloat / 10.0. - top _ (v * 4) + 50. - Display fill: (left@top extent: 4@4) fillColor: c]]]. -! ! -!Color class methodsFor: 'examples' stamp: 'jmv 1/14/2013 21:12'! - showHuesInteractively - "Shows a palette of hues at a (saturation, brightness) point determined by the mouse position. Click the mouse button to exit and return the selected (saturation, brightness) point." - "Color showHuesInteractively" - - | p s v | - [Sensor isAnyButtonPressed] whileFalse: [ - p _ Sensor mousePoint. - s _ p x asFloat / 300.0. - v _ p y asFloat / 300.0. - self showColors: (self wheel: 12 saturation: s brightness: v)]. - ^ (s min: 1.0) @ (v min: 1.0)! ! -!Color class methodsFor: 'examples'! - wheel: thisMany - "Return a collection of thisMany colors evenly spaced around the color wheel." - "Color showColors: (Color wheel: 12)" - - ^ Color wheel: thisMany saturation: 0.9 brightness: 0.7 -! ! -!Color class methodsFor: 'examples'! - wheel: thisMany saturation: s brightness: v - "Return a collection of thisMany colors evenly spaced around the color wheel, all of the given saturation and brightness." - "Color showColors: (Color wheel: 12 saturation: 0.4 brightness: 1.0)" - "Color showColors: (Color wheel: 12 saturation: 0.8 brightness: 0.5)" - - ^ (Color h: 0.0 s: s v: v) wheel: thisMany -! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:58'! - aqua - - ^ self colorNamesDict at: #aqua! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:58'! - beige - - ^ self colorNamesDict at: #beige! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:58'! - black - - ^ self colorNamesDict at: #black! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:58'! - blue - - ^ self colorNamesDict at: #blue! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:58'! - brightGreen - - ^ self colorNamesDict at: #brightGreen! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:58'! - brown - - ^ self colorNamesDict at: #brown! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - cyan - - ^ self colorNamesDict at: #cyan! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - darkBlue - - ^ self colorNamesDict at: #darkBlue! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - darkGray - - ^ self colorNamesDict at: #darkGray! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - darkGreen - - ^ self colorNamesDict at: #darkGreen! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - darkPink - - ^ self colorNamesDict at: #darkPink! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - darkPurple - - ^ self colorNamesDict at: #darkPurple! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - forestGreen - - ^ self colorNamesDict at: #forestGreen! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - gray - - ^ self colorNamesDict at: #gray! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - green - - ^ self colorNamesDict at: #green! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - grey - - ^ self colorNamesDict at: #grey! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - hotPink - - ^ self colorNamesDict at: #hotPink! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - indigo - - ^ self colorNamesDict at: #indigo! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - lavender - - ^ self colorNamesDict at: #lavender! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - lightBlue - - ^ self colorNamesDict at: #lightBlue! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - lightBrown - - ^ self colorNamesDict at: #lightBrown! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - lightCyan - - ^ self colorNamesDict at: #lightCyan! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - lightGray - - ^ self colorNamesDict at: #lightGray! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - lightGreen - - ^ self colorNamesDict at: #lightGreen! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! - lightMagenta - - ^ self colorNamesDict at: #lightMagenta! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 14:59'! -lightOrange - - ^ self colorNamesDict at: #lightOrange! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - lightPink - - ^ self colorNamesDict at: #lightPink! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - lightPurple - - ^ self colorNamesDict at: #lightPurple! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - lightRed - - ^ self colorNamesDict at: #lightRed! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - lightYellow - - ^ self colorNamesDict at: #lightYellow! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - lilac - - ^ self colorNamesDict at: #lilac! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - lime - - ^ self colorNamesDict at: #lime! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - limeGreen - - ^ self colorNamesDict at: #limeGreen! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - magenta - - ^ self colorNamesDict at: #magenta! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - maroon - - ^ self colorNamesDict at: #maroon! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - mauve - - ^ self colorNamesDict at: #mauve! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - mustard - - ^ self colorNamesDict at: #mustard! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - navyBlue - - ^ self colorNamesDict at: #navyBlue! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - olive - - ^ self colorNamesDict at: #olive! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - oliveGreen - - ^ self colorNamesDict at: #oliveGreen! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - orange - - ^ self colorNamesDict at: #orange! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - paleGreen - - ^ self colorNamesDict at: #paleGreen! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - peach - - ^ self colorNamesDict at: #peach! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - periwinkle - - ^ self colorNamesDict at: #periwinkle! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - pink - - ^ self colorNamesDict at: #pink! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - purple - - ^ self colorNamesDict at: #purple! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:00'! - red - - ^ self colorNamesDict at: #red! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - royalBlue - - ^ self colorNamesDict at: #royalBlue! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - salmon - - ^ self colorNamesDict at: #salmon! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - seaGreen - - ^ self colorNamesDict at: #seaGreen! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - skyBlue - - ^ self colorNamesDict at: #skyBlue! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - tan - - ^ self colorNamesDict at: #tan! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - teal - - ^ self colorNamesDict at: #teal! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - transparent - - ^ self colorNamesDict at: #transparent! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - turquoise - - ^ self colorNamesDict at: #turquoise! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - veryDarkGray - - ^ self colorNamesDict at: #veryDarkGray! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! -veryLightGray - - ^ self colorNamesDict at: #veryLightGray! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - veryVeryDarkGray - - ^ self colorNamesDict at: #veryVeryDarkGray! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - veryVeryLightGray - - ^ self colorNamesDict at: #veryVeryLightGray! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - violet - - ^ self colorNamesDict at: #violet! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - white - - ^ self colorNamesDict at: #white! ! -!Color class methodsFor: 'named colors' stamp: 'jmv 4/17/2015 15:01'! - yellow - - ^ self colorNamesDict at: #yellow! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 5/12/2016 15:49'! - cachedColormapForGrayFrom: sourceDepth - "Return a cached colormap for mapping from the given depth to the 8bpp grays. Always return a real colormap, not nil; this allows the client to get an identity colormap that can then be copied and modified to do color transformations." - "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" - "Note: The colormap cache may be cleared by evaluating 'Color shutDown'." - "Note: The color maps for sourceDepth=16 and for sourceDepth=32 are the same" - - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | srcIndex map | - ToGrayColormaps ifNil: [ - ToGrayColormaps _ Array new: 5]. - - srcIndex _ sourceDepth highBit min: 5. - - (ToGrayColormaps at: srcIndex) ifNotNil: [ :m | ^ m ]. - - map _ self computeColormapForGray8bppFrom: sourceDepth. - ToGrayColormaps at: srcIndex put: map. - ^ map! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 5/12/2016 14:50'! - cachedColormapFrom: sourceDepth to: destDepth - "Return a cached colormap for mapping between the given depths. Always return a real colormap, not nil; this allows the client to get an identity colormap that can then be copied and modified to do color transformations." - "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" - "Note: The colormap cache may be cleared by evaluating 'Color shutDown'." - "Note: The color maps for sourceDepth=16 and for sourceDepth=32 are the same" - - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | srcIndex dstIndex map | - CachedColormaps - ifNil: [CachedColormaps _ (1 to: 5) collect: [:i | Array new: 6]]. - - srcIndex _ sourceDepth highBit min: 5. - dstIndex _ destDepth highBit. - - ((CachedColormaps at: srcIndex) at: dstIndex) ifNotNil: [ :m | ^ m ]. - - map _ self computeColormapFrom: sourceDepth to: destDepth. - (CachedColormaps at: srcIndex) at: dstIndex put: map. - ^ map! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 5/12/2016 15:49'! - cachedColormapFromGrayTo: destDepth - "Return a cached colormap for mapping from 8bpp grays to the given depth. Always return a real colormap, not nil; this allows the client to get an identity colormap that can then be copied and modified to do color transformations." - "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" - "Note: The colormap cache may be cleared by evaluating 'Color shutDown'." - "Note: The color maps for sourceDepth=16 and for sourceDepth=32 are the same" - - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | dstIndex map | - FromGrayColormaps - ifNil: [FromGrayColormaps _ Array new: 6 ]. - - dstIndex _ destDepth highBit. - - (FromGrayColormaps at: dstIndex) ifNotNil: [ :m | ^ m ]. - - map _ self computeColormapFromGray8bppForDepth: destDepth. - FromGrayColormaps at: dstIndex put: map. - ^ map! ! -!Color class methodsFor: 'colormaps'! - colorMapIfNeededFrom: sourceDepth to: destDepth - "Return a colormap for mapping between the given depths, or nil if no colormap is needed." - "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" - - sourceDepth = destDepth ifTrue: [^ nil]. "not needed if depths are the same" - - (sourceDepth >= 16) & (destDepth >= 16) ifTrue: [ - "mapping is done in BitBlt by zero-filling or truncating each color component" - ^ nil]. - - ^ Color cachedColormapFrom: sourceDepth to: destDepth -! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 8/27/2009 08:47'! - computeColorConvertingMap: targetColor from: sourceDepth to: destDepth keepSubPixelAA: keepSubPix - "Note: The color converting map for sourceDepth=16 and for sourceDepth=32 are the same" - sourceDepth < 16 ifTrue: [ - "source is 1-, 2-, 4-, or 8-bit indexed color. - Assumed not to include subpixelAA" - ^ self computeIndexedColorConvertingMap: targetColor from: sourceDepth to: destDepth - ] ifFalse: [ - "source is 16-bit or 32-bit RGB. - Might include subpixelAA" - ^ self computeRGBColorConvertingMap: targetColor to: destDepth keepSubPixelAA: keepSubPix - ]! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 5/12/2016 15:55'! - computeColormapForGray8bppFrom: sourceDepth - "Compute a colorMap for translatingfrom the given depth to the 8bpp grays" - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | map | - sourceDepth < 16 ifTrue: [ - "source is 1-, 2-, 4-, or 8-bit indexed color" - map _ (self indexedColors copyFrom: 1 to: (1 bitShift: sourceDepth)) - collect: [ :c | (c luminance * 255) rounded]. - map _ map as: Bitmap. - ^ map - ] - ifFalse: [ - ^ self computeRGBColormapForGray8 ]! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 4/17/2015 15:05'! - computeColormapFrom: sourceDepth to: destDepth - "Compute a colorMap for translating between the given depths. A colormap is a Bitmap whose entries contain the pixel values for the destination depth. Typical clients use cachedColormapFrom:to: instead." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | map bitsPerColor | - sourceDepth < 16 ifTrue: [ - "source is 1-, 2-, 4-, or 8-bit indexed color" - map _ (self indexedColors copyFrom: 1 to: (1 bitShift: sourceDepth)) - collect: [:c | c pixelValueForDepth: destDepth]. - map _ map as: Bitmap. - ] ifFalse: [ - "source is 16-bit or 32-bit RGB" - destDepth > 8 - ifTrue: [bitsPerColor _ 5] "retain maximum color resolution" - ifFalse: [bitsPerColor _ 4]. - map _ self computeRGBColormapFor: destDepth bitsPerColor: bitsPerColor]. - - "Note: zero is transparent except when source depth is one-bit deep" - sourceDepth > 1 ifTrue: [map at: 1 put: 0]. - ^ map -! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 5/12/2016 15:56'! - computeColormapFromGray8bppForDepth: destDepth - "Return a colormap for displaying a GrayForm at the given depth" - - | newMap | - newMap _ Bitmap new: 256. - 1 to: 256 do: [ :i | - newMap - at: i - put: ((Color gray: (i-1) asFloat / 255.0) pixelValueForDepth: destDepth)]. - ^ newMap! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 4/17/2015 15:05'! - computeIndexedColorConvertingMap: targetColor from: sourceDepth to: destDepth - | map | - - map _ (self indexedColors copyFrom: 1 to: (1 bitShift: sourceDepth)) collect: [ :cc | | f c | - f _ 1.0 - (cc red + cc green + cc blue / 3.0 ). - c _ targetColor - ifNotNil: [ - destDepth = 32 - ifTrue: [ targetColor * f alpha: f] - ifFalse: [ targetColor alphaMixed: f*1.5 with: Color white ]] - ifNil: [ cc ]. - destDepth = 32 - ifTrue: [ c pixelValueForDepth: destDepth] - ifFalse: [ - f = 0.0 - ifTrue: [ 0 ] - ifFalse: [ c pixelValueForDepth: destDepth ]]]. - map _ map as: Bitmap. - ^map! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 12/26/2011 13:49'! - computeRGBColorConvertingMap: targetColor to: destDepth keepSubPixelAA: keepSubPix - "Builds a colormap intended to convert from subpixelAA black values to targetColor values. - keepSubPix - ifTrue: [ Answer colors that also include subpixelAA ] - ifFalse: [ - Take fullpixel luminance level. Apply it to targetColor. - I.e. answer colors with NO subpixelAA ]" - - | mask map c bitsPerColor r g b f v | - - destDepth > 8 - ifTrue: [bitsPerColor _ 5] "retain maximum color resolution" - ifFalse: [bitsPerColor _ 4]. - "Usually a bit less is enough, but make it configurable" - bitsPerColor _ bitsPerColor min: Preferences aaFontsColormapDepth. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - r _ (i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask. - g _ (i bitShift: 0 - bitsPerColor) bitAnd: mask. - b _ (i bitShift: 0) bitAnd: mask. - f _ 1.0 - (r + g + b / 3.0 / mask). - c _ targetColor - ifNotNil: [ - (keepSubPix and: [destDepth > 8]) ifTrue: [ - Color - r: 1.0 - (r asFloat/mask) * targetColor red - g: 1.0 - (g asFloat/mask) * targetColor green - b: 1.0 - (b asFloat/mask) * targetColor blue - alpha: f * targetColor alpha "alpha will be ignored below, in #pixelValueForDepth: if destDepth ~= 32" ] - ifFalse: [ - destDepth = 32 - ifTrue: [ targetColor * f alpha: f * targetColor alpha ] - ifFalse: [ targetColor alphaMixed: f*1.5 with: Color white ]]] - ifNil: [ Color r: r g: g b: b range: mask]. "This is currently used only to keep some SubPixelAA on destDepth = 8, using a single pass of rule 25" - v _ destDepth = 32 - ifTrue: [ c pixelValueForDepth: destDepth] - ifFalse: [ - f < 0.1 - ifTrue: [ 0 ] - ifFalse: [ c pixelValueForDepth: destDepth ]]. - map at: i + 1 put: v ]. - ^ map! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 1/30/2011 23:10'! - computeRGBColormapFor: destDepth bitsPerColor: bitsPerColor - "Compute a colorMap for translating from 16-bit or 32-bit RGB color to the given depth, using the given number of of bits per color component." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | mask map c | - (#(3 4 5) includes: bitsPerColor) - ifFalse: [self error: 'BitBlt only supports 3, 4, or 5 bits per color component']. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - c _ Color - r: ((i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask) - g: ((i bitShift: 0 - bitsPerColor) bitAnd: mask) - b: ((i bitShift: 0) bitAnd: mask) - range: mask. - map at: i + 1 put: (c pixelValueForDepth: destDepth)]. - - map at: 1 put: (Color transparent pixelWordForDepth: destDepth). "zero always transparent" - ^ map -! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 5/12/2016 15:57'! - computeRGBColormapForGray8 - "Compute a colorMap for translating from 16-bit or 32-bit RGB color to 8bpp grays, using the default number of of bits per color component." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | bitsPerColor mask map c | - bitsPerColor _ 5. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - c _ Color - r: ((i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask) - g: ((i bitShift: 0 - bitsPerColor) bitAnd: mask) - b: ((i bitShift: 0) bitAnd: mask) - range: mask. - map at: i + 1 put: (c luminance * 255) rounded]. - - ^ map! ! -!Color class methodsFor: 'other' stamp: 'jmv 1/31/2011 09:30'! - maskingMap: depth - "Return a color map that maps all colors except transparent to words of all ones. Used to create a mask for a Form whose transparent pixel value is zero. Cache the most recently used map." - "Warning: The behavior is incorrect if depth = 32. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | sizeNeeded | - depth <= 8 - ifTrue: [sizeNeeded _ 1 bitShift: depth] - ifFalse: [sizeNeeded _ 4096]. - - (MaskingMap == nil or: [MaskingMap size ~= sizeNeeded]) ifTrue: - [MaskingMap _ Bitmap new: sizeNeeded withAll: 16rFFFFFFFF. - MaskingMap at: 1 put: 0. "transparent"]. - - ^ MaskingMap -! ! -!Color class methodsFor: 'color from user' stamp: 'jmv 3/1/2010 15:13'! - colorPaletteForDepth: depth extent: chartExtent - "Display a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." - "Note: It is slow to build this palette, so it should be cached for quick access." - "(Color colorPaletteForDepth: 16 extent: 190@60) display" - - | basicHue x y startHue palette transHt vSteps transCaption grayWidth hSteps | - palette _ Form extent: chartExtent depth: depth. - transCaption _ - (Form extent: 34@9 depth: 1 - fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0) - offset: 0@0). - transHt _ transCaption height. - palette fillWhite: (0@0 extent: palette width@transHt). - palette fillBlack: (0@transHt extent: palette width@1). - transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0). - grayWidth _ 10. - startHue _ 338.0. - vSteps _ palette height - transHt // 2. - hSteps _ palette width - grayWidth. - x _ 0. - startHue to: startHue + 360.0 by: 360.0/hSteps do: [ :h | - basicHue _ Color h: h asFloat s: 1.0 v: 1.0. - y _ transHt+1. - 0 to: vSteps do: [ :n | | c | - c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Color white. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - 1 to: vSteps do: [ :n | | c | - c _ Color black mixed: (n asFloat / vSteps asFloat) with: basicHue. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - x _ x + 1]. - y _ transHt + 1. - 1 to: vSteps * 2 do: [ :n | | c | - c _ Color black mixed: (n asFloat / (vSteps*2) asFloat) with: Color white. - palette fill: (x@y extent: 10@1) fillColor: c. - y _ y + 1]. - ^ palette -! ! -!Color class methodsFor: 'color from user' stamp: 'jmv 7/27/2009 11:32'! - colorTest: depth extent: chartExtent colorMapper: colorMapper - "Create a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." - "Note: It is slow to build this palette, so it should be cached for quick access." - "(Color colorTest: 32 extent: 570@180 colorMapper: [:c | c]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 7) asInteger / 7 - g: (c green * 7) asInteger / 7 - b: (c blue * 3) asInteger / 3]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 5) asInteger / 5 - g: (c green * 5) asInteger / 5 - b: (c blue * 5) asInteger / 5]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 15) asInteger / 15 - g: (c green * 15) asInteger / 15 - b: (c blue * 15) asInteger / 15]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 31) asInteger / 31 - g: (c green * 31) asInteger / 31 - b: (c blue * 31) asInteger / 31]) display" - - | basicHue x y c startHue palette transHt vSteps transCaption grayWidth hSteps | - palette _ Form extent: chartExtent depth: depth. - transCaption _ - (Form extent: 34@9 depth: 1 - fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0) - offset: 0@0). - transHt _ transCaption height. - palette fillWhite: (0@0 extent: palette width@transHt). - palette fillBlack: (0@transHt extent: palette width@1). - transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0). - grayWidth _ 10. - startHue _ 338.0. - vSteps _ palette height - transHt // 2. - hSteps _ palette width - grayWidth. - x _ 0. - startHue to: startHue + 360.0 by: 360.0/hSteps do: [:h | - basicHue _ Color h: h asFloat s: 1.0 v: 1.0. - y _ transHt+1. - 0 to: vSteps do: [:n | - c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Color white. - c _ colorMapper value: c. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - 1 to: vSteps do: [:n | - c _ Color black mixed: (n asFloat / vSteps asFloat) with: basicHue. - c _ colorMapper value: c. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - x _ x + 1]. - y _ transHt + 1. - 1 to: vSteps * 2 do: [:n | - c _ Color black mixed: (n asFloat / (vSteps*2) asFloat) with: Color white. - c _ colorMapper value: c. - palette fill: (x@y extent: 10@1) fillColor: c. - y _ y + 1]. - ^ palette -! ! -!Color class methodsFor: 'color name lookup' stamp: 'KenD 1/26/2013 20:13'! - colorNames - "Answer the current dictionary of name->color associations." - - ^self colorNamesDict keys! ! -!Color class methodsFor: 'color name lookup' stamp: 'KenD 1/28/2013 20:34'! - defaultColorNamesDictionary - "Answer a amall but useful name->color dictionary" - - | defaultDict | - "Meld most used xkcd colors into traditional colors." - defaultDict := (self traditionalColorNamesDictionary addAll: - self xkcdFirst48ColorNamesDictionary; - yourself). - - "Override traditional names existing in extended XKCD naming" - defaultDict at: #lightYellow put: (Color r: 1.0 g: 0.996 b: 0.478). - defaultDict at: #lightOrange put: (Color r: 0.992 g: 0.667 b: 0.283). - defaultDict at: #lightCyan put: (Color r: 0.674 g: 1.0 b: 0.988). - defaultDict at: #lightRed put: (Color r: 1.0 g: 0.279 b: 0.298). - defaultDict at: #lightMagenta put: (Color r: 0.98 g: 0.372 b: 0.969). - - ^defaultDict! ! -!Color class methodsFor: 'color name lookup' stamp: 'KenD 2/1/2013 14:39'! - doesNotUnderstand: aMessage - "Some code takes - Color colorNames - and does - Color perform: aColorname. - - Make this work." - - ^(Color colorNamesDict) - at: (aMessage selector) - ifAbsent: [super doesNotUnderstand: aMessage]! ! -!Color class methodsFor: 'color name lookup' stamp: 'KenD 1/26/2013 20:51'! - exactColorNamed: aColorName - - "Answer color matching name or nil - from my ColorName->Color Dictionary" - - ^ self colorNamesDict at: (aColorName asSymbol) ifAbsent: [nil]! ! -!Color class methodsFor: 'color name lookup' stamp: 'KenD 7/25/2014 21:22'! - setColorNamesDict: aNameColorDictionary - "Answer the current dictionary of name->color associations." - - "Note: This is a non-standard name because this is a non-standard action!! - Do this if you really, really know what you are doing." - - "Some Colors are required for proper system operation" - Color defaultColorNamesDictionary keysAndValuesDo: [ :colorName :colorValue | - aNameColorDictionary at: colorName ifAbsentPut: colorValue - ]. - - ColorNamesDict := aNameColorDictionary! ! -!Color class methodsFor: 'color name lookup' stamp: 'sqr 10/21/2016 12:44:48'! - traditionalColorNamesDictionary - "Answer a dictionary of Squeak traditional name->color associations.." - - | nameDict | - nameDict _ Dictionary new. - nameDict at: #black put: (Color r: 0 g: 0 b: 0). - nameDict at: #veryVeryDarkGray put: (Color r: 0.125 g: 0.125 b: 0.125). - nameDict at: #veryDarkGray put: (Color r: 0.25 g: 0.25 b: 0.25). - nameDict at: #darkGray put: (Color r: 0.375 g: 0.375 b: 0.375). - nameDict at: #gray put: (Color r: 0.5 g: 0.5 b: 0.5). - nameDict at: #lightGray put: (Color r: 0.625 g: 0.625 b: 0.625). - nameDict at: #veryLightGray put: (Color r: 0.75 g: 0.75 b: 0.75). - nameDict at: #veryVeryLightGray put: (Color r: 0.875 g: 0.875 b: 0.875). - nameDict at: #white put: (Color r: 1.0 g: 1.0 b: 1.0). - nameDict at: #red put: (Color r: 1.0 g: 0 b: 0). - nameDict at: #yellow put: (Color r: 1.0 g: 1.0 b: 0). - nameDict at: #green put: (Color r: 0 g: 1.0 b: 0). - nameDict at: #cyan put: (Color r: 0 g: 1.0 b: 1.0). - nameDict at: #blue put: (Color r: 0 g: 0 b: 1.0). - nameDict at: #magenta put: (Color r: 1.0 g: 0 b: 1.0). - nameDict at: #brown put: (Color r: 0.6 g: 0.2 b: 0). - nameDict at: #orange put: (Color r: 1.0 g: 0.6 b: 0). - nameDict at: #lightRed put: (Color r: 1.0 g: 0.8 b: 0.8). - nameDict at: #lightYellow put: (Color r: 1.0 g: 1.0 b: 0.8). - nameDict at: #lightGreen put: (Color r: 0.8 g: 1.0 b: 0.6). - nameDict at: #lightCyan put: (Color r: 0.4 g: 1.0 b: 1.0). - nameDict at: #lightBlue put: (Color r: 0.8 g: 1.0 b: 1.0). - nameDict at: #lightMagenta put: (Color r: 1.0 g: 0.8 b: 1.0). - nameDict at: #lightBrown put: (Color r: 1.0 g: 0.6 b: 0.2). - nameDict at: #lightOrange put: (Color r: 1.0 g: 0.8 b: 0.4). - nameDict at: #transparent put: (TranslucentColor r: 0.0 g: 0.0 b: 0.0 alpha: 0.0). - - ^nameDict -! ! -!Color class methodsFor: 'color name lookup' stamp: 'jmv 6/30/2014 15:22'! - xkcdFirst48ColorNamesDictionary - "XKCD color names are based on a survey oc colors people call by the same name. - http://blog.xkcd.com/2010/05/03/color-survey-results/" - - "Answer a dictionary of the most agreed upon first 48 xkcd colors" -" - Color xkcdFirst48ColorNamesDictionary explore. -" - | xkcdDict | - xkcdDict := Dictionary new - at: #lightPink put: (Color fromString: '#ffd1df') ; - at: #mustard put: (Color fromString: '#ceb301') ; - at: #indigo put: (Color fromString: '#380282') ; - at: #lime put: (Color fromString: '#aaff32') ; - at: #seaGreen put: (Color fromString: '#53fca1') ; - at: #periwinkle put: (Color fromString: '#8e82fe') ; - at: #darkPink put: (Color fromString: '#cb416b') ; - at: #oliveGreen put: (Color fromString: '#677a04') ; - at: #peach put: (Color fromString: '#ffb07c') ; - at: #paleGreen put: (Color fromString: '#c7fdb5') ; - at: #lightBrown put: (Color fromString: '#ad8150') ; - at: #hotPink put: (Color fromString: '#ff028d') ; - at: #black put: (Color fromString: '#000000') ; - at: #lilac put: (Color fromString: '#cea2fd') ; - at: #navyBlue put: (Color fromString: '#001146') ; - at: #royalBlue put: (Color fromString: '#0504aa') ; - at: #beige put: (Color fromString: '#e6daa6') ; - at: #salmon put: (Color fromString: '#ff796c') ; - at: #olive put: (Color fromString: '#6e750e') ; - at: #maroon put: (Color fromString: '#650021') ; - at: #brightGreen put: (Color fromString: '#01ff07') ; - at: #darkPurple put: (Color fromString: '#35063e') ; - at: #mauve put: (Color fromString: '#ae7181') ; - at: #forestGreen put: (Color fromString: '#06470c') ; - at: #aqua put: (Color fromString: '#13eac9') ; - at: #cyan put: (Color fromString: '#00ffff') ; - at: #tan put: (Color fromString: '#d1b26f') ; - at: #darkBlue put: (Color fromString: '#00035b') ; - at: #lavender put: (Color fromString: '#c79fef') ; - at: #turquoise put: (Color fromString: '#06c2ac') ; - at: #darkGreen put: (Color fromString: '#033500') ; - at: #violet put: (Color fromString: '#9a0eea') ; - at: #lightPurple put: (Color fromString: '#bf77f6') ; - at: #limeGreen put: (Color fromString: '#89fe05') ; - at: #grey put: (Color fromString: '#929591') ; - at: #skyBlue put: (Color fromString: '#75bbfd') ; - at: #yellow put: (Color fromString: '#ffff14') ; - at: #magenta put: (Color fromString: '#c20078') ; - at: #lightGreen put: (Color fromString: '#96f97b') ; - at: #orange put: (Color fromString: '#f97306') ; - at: #teal put: (Color fromString: '#029386') ; - at: #lightBlue put: (Color fromString: '#95d0fc') ; - at: #red put: (Color fromString: '#e50000') ; - at: #brown put: (Color fromString: '#653700') ; - at: #pink put: (Color fromString: '#ff81c0') ; - at: #blue put: (Color fromString: '#0343df') ; - at: #green put: (Color fromString: '#15b01a') ; - at: #purple put: (Color fromString: '#7e1e9c') ; - yourself. - - ^xkcdDict - -! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:26'! - blueColorDict - "Answer a dictionary of named colors considered Blue" -" - Color blueColorDict explore. -" - ^self blueColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:24'! - blueColorDict: aColorDict - "Answer a dictionary of named colors considered Blue" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isBlue) - or: [assoc key asString asLowercase includesSubString: 'blue']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:28'! - blueGreenColorDict - "Answer a dictionary of named colors considered Blue" -" - Color blueGreenColorDict explore. -" - ^self blueGreenColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:29'! - blueGreenColorDict: aColorDict - "Answer a dictionary of named colors considered Blue" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isBlueGreen) - or: [assoc key asString asLowercase includesSubString: 'bluegreen']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:31'! - brightColorDict - "Answer a dictionary of named colors considered Bright" -" - Color brightColorDict explore. -" - ^self brightColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:31'! - brightColorDict: aColorDict - "Answer a dictionary of named colors considered Bright" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - (assoc value isBright) ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:34'! - brownColorDict - "Answer a dictionary of named colors considered Brown" -" - Color brownColorDict explore. -" - ^self brownColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:33'! - brownColorDict: aColorDict - "Answer a dictionary of named colors considered Brown" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isBrown) - or: [assoc key asString asLowercase includesSubString: 'brown']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:36'! - darkColorDict - "Answer a dictionary of named colors considered Dark" -" - Color darkColorDict explore. -" - ^self darkColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:37'! - darkColorDict: aColorDict - "Answer a dictionary of named colors considered Dark" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - (assoc value isDark) ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:41'! - grayColorDict: aColorDict - "Answer a dictionary of named colors considered Grey" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isGrey) - or: [assoc key asString asLowercase includesSubString: 'grey']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:38'! - greenColorDict - "Answer a dictionary of named colors considered Green" -" - Color greenColorDict explore. -" - ^self greenColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:38'! - greenColorDict: aColorDict - "Answer a dictionary of named colors considered Green" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isGreen) - or: [assoc key asString asLowercase includesSubString: 'green']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:41'! - greyColorDict - "Answer a dictionary of named colors considered Grey" -" - Color greyColorDict explore. -" - ^self greyColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:40'! - greyColorDict: aColorDict - "Answer a dictionary of named colors considered Grey" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isGrey) - or: [assoc key asString asLowercase includesSubString: 'grey']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:44'! - lightColorDict - "Answer a dictionary of named colors considered light" -" - Color lightColorDict explore. -" - ^self lightColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:43'! - lightColorDict: aColorDict - "Answer a dictionary of named colors considered Liight" - - ^self brightColorDict: aColorDict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:46'! - orangeColorDict - "Answer a dictionary of named colors considered Orange" -" - Color orangeColorDict explore. -" - ^self orangeColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:46'! - orangeColorDict: aColorDict - "Answer a dictionary of named colors considered Orange" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isOrange) - or: [assoc key asString asLowercase includesSubString: 'orange']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:48'! - pastelColorDict - "Answer a dictionary of named colors considered Pastel" -" - Color pastelColorDict explore. -" - ^self pastelColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:48'! - pastelColorDict: aColorDict - "Answer a dictionary of named colors considered Bright" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - (assoc value isPastel) ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:50'! - pinkColorDict - "Answer a dictionary of named colors considered Pink" -" - Color pinkColorDict explore. -" - ^self pinkColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:50'! - pinkColorDict: aColorDict - "Answer a dictionary of named colors considered Pink" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isPink) - or: [assoc key asString asLowercase includesSubString: 'pink']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:52'! - purpleColorDict - "Answer a dictionary of named colors considered Purple" -" - Color purpleColorDict explore. -" - ^self purpleColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:52'! - purpleColorDict: aColorDict - "Answer a dictionary of named colors considered Pink" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc key asString asLowercase includesSubString: 'purple') - or: [assoc key asString asLowercase includesSubString: 'violet']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:54'! - redColorDict - "Answer a dictionary of named colors considered Red" -" - Color redColorDict explore. -" - ^self redColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:53'! - redColorDict: aColorDict - "Answer a dictionary of named colors considered Red" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isRed) - or: [assoc key asString asLowercase includesSubString: 'red']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:56'! - saturatedColorDict - "Answer a dictionary of named colors considered Saturated" -" - Color saturatedColorDict explore. -" - ^self saturatedColorDict: (self colorNamesDict )! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:55'! - saturatedColorDict: aColorDict - "Answer a dictionary of named colors considered Saturated" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - (assoc value isSaturated) ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:26'! - yellowColorDict - "Answer a dictionary of named colors considered Yellow" -" - Color yellowColorDict explore. -" - ^self yellowColorDict: (self colorNamesDict)! ! -!Color class methodsFor: 'selection' stamp: 'KenD 1/30/2013 17:19'! - yellowColorDict: aColorDict - "Answer a dictionary of named colors considered Yellow" - - | dict | - dict := Dictionary new. - aColorDict associationsDo: - [ :assoc | - ((assoc value isYellow) - or: [assoc key asString asLowercase includesSubString: 'yellow']) - ifTrue: [dict add: assoc] - ]. - ^dict! ! -!Color class methodsFor: 'color space conversions' stamp: 'jmv 4/24/2013 10:55'! - applySimpleGamma: gamma to: value - "Encode / decode Gamma. Typical gamma are 0.4545 ( = 1.0 / 2.2, for encoding) and 2.2 (for decoding) - In a non gamma encoded image, the pixel values are proportional to luminance, i.e. the actual light intensity, the photon count. - In an gamma encoded image, the pixel value is close to the average perceived brightness, or 'lightness'. This optimizes the use of available bits in digital images, and dynamic range in analog images and film. This is like the 'luma' signal in video. - - Usually: - - Images stored in file formats such as jpg, png, tiff and bmp are gamma encoded - (unless they are actually raw images). - - Images sent to a framebuffer (video memory) should be gamma encoded. - - Raw images from sensors are not gamma encoded. - - - Image processing algorithms that simulate the real world, or are applied to real world data should work on unencoded (linear) images. - This includes filtering, resizing, blending, and most operations done on images. - This means that if the images come from jpg photos from a camera, they should be gamma decoded. - - Image processing algorithms that works on human perception should work on gamma encoded images. - This includes histograms, histogram equalization, bit allocation (i.e. quantization), compression, etc. - This also includes detecting objects like a human would do - - - See - http://en.wikipedia.org/wiki/Gamma_correction - http://www.poynton.com/notes/colour_and_gamma/GammaFAQ.html - - Mostly for documentation. - value must be in [0.0 .. 1.0]. - Note that the sRGB standard specifies a function that is close to this, but slightly different. - See #linearTosRGBGamma: and #sRGBGammaToLinear:" - - ^ value raisedTo: gamma! ! -!Color class methodsFor: 'color space conversions' stamp: 'jmv 4/24/2013 10:49'! - linearTosRGBGamma: value - "The sRGB standard specifies a gamma curve that is close to gamma = 2.2, but is actually - built from one stright line segment, and a curve with exponent = 2.4. - This method converts value from linearSpace to gammaSpace, i.e. it 'encodes' with gamma. - This is the operation done when producing an 8bit Form for displaying, or for saving on a JPG, PNG, etc; if source data is in linear space (for example, from raw data a sensor image, or data that was converted previously to linear space for proper image processing). - value must be in [0.0 .. 1.0]. - - See - http://en.wikipedia.org/wiki/Gamma_correction - http://www.poynton.com/notes/colour_and_gamma/GammaFAQ.html - http://entropymine.com/imageworsener/srgbformula - - | r v | - r _ Random new. - 1000 timesRepeat: [ - v _ r next. - self assert: ((Color sRGBGammaToLinear: (Color linearTosRGBGamma: v)) closeTo: v) ] - - | r | - r _ 10@10 extent: 600@400. - Display fill: r fillColor: Color white. - FFT new plot: ((0.0 to: 1.0 count: 100) collect: [ :v | Color linearTosRGBGamma: v ]) in: r color: Color black min: 0.0 max: 1.0. - FFT new plot: ((0.0 to: 1.0 count: 100) collect: [ :v | Color applySimpleGamma: 1/2.2 to: v ]) in: r color: Color blue min: 0.0 max: 1.0. - FFT new plot: ((0.0 to: 1.0 count: 100) collect: [ :v | Color sRGBGammaToLinear: v ]) in: r color: Color black min: 0.0 max: 1.0. - FFT new plot: ((0.0 to: 1.0 count: 100) collect: [ :v | Color applySimpleGamma: 2.2 to: v ]) in: r color: Color blue min: 0.0 max: 1.0. - " - - ^ value <= 0.00313066844250063 - ifTrue: [ value * 12.92 ] - ifFalse: [ (value raisedTo: 1.0/2.4) * 1.055 - 0.055 ]! ! -!Color class methodsFor: 'color space conversions' stamp: 'jmv 4/24/2013 10:50'! - sRGBGammaToLinear: value - "The sRGB standard specifies a gamma curve that is close to gamma = 2.2, but is actually - built from one stright line segment, and a curve with exponent = 2.4. - This method converts value from gammaSpace to linearSpace, i.e. it 'decodes'. - This is the operation done by display screens. It is also needed to convert 8bit Forms (from a frameBuffer, or from PNG, JPG, etc.) to linear space for proper image processing. - value must be in [0.0 .. 1.0]. - - See - http://en.wikipedia.org/wiki/Gamma_correction - http://www.poynton.com/notes/colour_and_gamma/GammaFAQ.html - http://entropymine.com/imageworsener/srgbformula - " - - ^ value <= 0.0404482362771082 - ifTrue: [ value / 12.92 ] - ifFalse: [ value + 0.055 / 1.055 raisedTo: 2.4 ]! ! -!Color class methodsFor: 'cached state access' stamp: 'jmv 4/17/2015 14:58'! - colorNamesDict - "Answer the current dictionary of name->color associations." -" - Color colorNamesDict explore. -" - ColorNamesDict ifNil: [ - self setColorNamesDict: self defaultColorNamesDictionary ]. - ^ColorNamesDict! ! -!Color class methodsFor: 'cached state access' stamp: 'jmv 4/17/2015 15:08'! - grayToIndexMap - " - Color grayToIndexMap explore. - " - GrayToIndexMap ifNil: [ - self initializeGrayToIndexMap ]. - ^GrayToIndexMap! ! -!Color class methodsFor: 'cached state access' stamp: 'jmv 4/17/2015 15:04'! - indexedColors - " - Color indexedColors explore. - " - IndexedColors ifNil: [ - self initializeIndexedColors ]. - ^IndexedColors! ! -!Color class methodsFor: 'cached state access' stamp: 'jmv 5/12/2016 14:58'! - releaseClassCachedState - " - Color releaseClassCachedState - " - CachedColormaps _ nil. "Maps to translate between color depths" - ToGrayColormaps _ nil. "Maps colors to 8bpp grays for various color depths" - FromGrayColormaps _ nil. "Maps from 8bpp grays to colors of various depths" - MaskingMap _ nil. "Maps all colors except transparent to black for creating a mask" - ColorNamesDict _ nil. - IndexedColors _ nil. - GrayToIndexMap _ nil! ! -!TranslucentColor methodsFor: 'accessing' stamp: 'jmv 6/18/2017 20:41:17'! - alpha - "Return my alpha value, a number between 0.0 and 1.0 where 0.0 is completely transparent and 1.0 is completely opaque." - - ^ self at: 4! ! -!TranslucentColor methodsFor: 'printing' stamp: 'jmv 1/5/2014 21:06'! - storeArrayValuesOn: aStream - - self isTransparent ifTrue: [ - ^ aStream space]. - super storeArrayValuesOn: aStream. - aStream space. - self alpha printOn: aStream fractionDigits: 3! ! -!TranslucentColor methodsFor: 'printing' stamp: 'jmv 1/5/2014 21:20'! - storeOn: aStream - - self isTransparent ifTrue: [^ aStream nextPutAll: '(Color transparent)']. - aStream - nextPut: $(; - nextPutAll: self class name; - nextPutAll: ' r: '. - self red printOn: aStream fractionDigits: 3. - aStream nextPutAll: ' g: '. - self green printOn: aStream fractionDigits: 3. - aStream nextPutAll: ' b: '. - self blue printOn: aStream fractionDigits: 3. - aStream nextPutAll: ' alpha: '. - self alpha printOn: aStream fractionDigits: 3. - aStream nextPutAll: ')'! ! -!TranslucentColor methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:55:03'! - alpha: alphaValue - "Return a new TranslucentColor with the given amount of opacity ('alpha')." - alphaValue = 1.0 ifTrue: [ - ^ Color new - setRed: self red - green: self green - blue: self blue]. - ^ super alpha: alphaValue! ! -!TranslucentColor methodsFor: 'conversions' stamp: 'sw 10/27/1999 10:51'! - asNontranslucentColor - ^ self alpha: 1.0! ! -!TranslucentColor methodsFor: 'conversions' stamp: 'jmv 4/19/2013 16:10'! - bitPatternForDepth: depth - "Return an appropriate bit pattern. This will almost never be meaningful for tranlucentColors, except for the degenerate case of tranparency." - - self isTransparent ifTrue: [ - ^ Bitmap with: 0]. - ^ super bitPatternForDepth: depth! ! -!TranslucentColor methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:41:47'! - pixelValueForDepth: d - "Return the pixel value for this color at the given depth. Translucency only works in RGB; this color will appear either opaque or transparent at all other depths." - | basicPixelWord | - "In 32bpp, if alpha = 0, ignore any color components, and answer R=0, G=0, B=0, Alpha=0. - In depths > 8 and < 32, pixelValue zero is the special value used by BitBlt to denote transparent." - self isTransparent ifTrue: [ - ^ 0]. - basicPixelWord _ super pixelValueForDepth: d. - ^d < 32 - ifTrue: [ basicPixelWord ] - ifFalse: [ (basicPixelWord bitAnd: 16rFFFFFF) bitOr: - ((self alpha*255.0) rounded - bitShift: 24) ]! ! -!TranslucentColor methodsFor: 'conversions' stamp: 'jmv 6/18/2017 20:41:50'! - pixelWordForDepth: depth - "Return the pixel value for this color at the given depth. Translucency only works in RGB; this color will appear either opaque or transparent at all other depths." - - | basicPixelWord | - self isTransparent ifTrue: [^ 0]. - basicPixelWord _ super pixelWordForDepth: depth. - ^depth < 32 - ifTrue: [ basicPixelWord ] - ifFalse: [ (basicPixelWord bitAnd: 16rFFFFFF) bitOr: - ((self alpha*255.0) rounded - bitShift: 24) ]! ! -!TranslucentColor methodsFor: 'private' stamp: 'jmv 6/18/2017 20:42:05'! - setRed: r green: g blue: b alpha: alphaValue - - self basicSetRed: r green: g blue: b. - self at: 4 put: alphaValue! ! -!TranslucentColor methodsFor: 'queries' stamp: 'jmv 6/18/2017 20:41:26'! - isOpaque - - ^self alpha = 1.0! ! -!TranslucentColor methodsFor: 'queries' stamp: 'jmv 6/18/2017 20:41:54'! - isTransparent - ^ self alpha = 0.0! ! -!TranslucentColor class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:54:35'! - new - ^ self new: 4! ! -!TranslucentColor class methodsFor: 'instance creation' stamp: 'jmv 6/18/2017 20:57:08'! - r: r g: g b: b alpha: alphaValue - "Return a color with the given r, g, and b components in the range [0.0..1.0]." - - ^ self new - setRed: r - green: g - blue: b - alpha: alphaValue! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3110-CallItColorAgain-JuanVuletich-2017Jun19-11h54m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3109] on 19 June 2017 at 12:07:06 pm'! -!Integer methodsFor: 'converting' stamp: 'ar 10/31/1998 23:04' prior: 50348248! - asColorOfDepth: d - "Return a color value representing the receiver as color of the given depth" - ^Color colorFromPixelValue: self depth: d! ! -!InputSensor methodsFor: 'keyboard' stamp: 'jmv 9/2/2016 11:08:09' prior: 50348256! - kbdTest - " - Sensor kbdTest - " - "This test routine will print the unmodified character, its keycode, - and the OR of all its modifier bits, until the character x is typed - -Also useful: - Sensor test - " - | char | - char _ nil. - [ char = $x ] whileFalse: [ - [ self keyboardPressed ] whileFalse. - char _ self keyboard. - Display fill: (5@5 extent: 400@20) fillColor: Color white. - (String streamContents: [ :s | - s - nextPut: $-; - nextPut: char; - nextPut: $-; - space; - print: char numericValue; - space. - self isMouseButton3Pressed ifTrue: [ s nextPutAll: ' mouseButton3/blue/tertiary/halo ' ]. - self isMouseButton2Pressed ifTrue: [ s nextPutAll: ' mouseButton2/yellow/secondary/menu ' ]. - self isMouseButton1Pressed ifTrue: [ s nextPutAll: ' mouseButton1/red/primary ' ]. - self shiftPressed ifTrue: [ s nextPutAll: ' shift ' ]. - self controlKeyPressed ifTrue: [ s nextPutAll: ' control/ctrl ' ]. - (self primMouseButtons anyMask: 32) ifTrue: [ s nextPutAll: ' macOption ' ]. - self commandAltKeyPressed ifTrue: [ s nextPutAll: ' macCommand/winAlt ' ]]) - displayAt: 10 @ 10 ].! ! -!String methodsFor: 'displaying' stamp: 'jmv 5/12/2015 15:52' prior: 50348294! - 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 - " - 'Display' displayOn: Display at: 10@10 - "! ! -!Color methodsFor: 'conversions' stamp: 'bf 4/18/2001 16:25' prior: 50353442! - makeForegroundColor - "Make a foreground color contrasting with me" - ^self luminance >= 0.5 - ifTrue: [Color black] - ifFalse: [Color white]! ! -!Color methodsFor: 'groups of shades' stamp: 'tk 6/18/96' prior: 50353622! - mix: color2 shades: thisMany - "Return an array of thisMany colors from self to color2. Very useful for displaying color based on a variable in your program. " - "Color showColors: (Color red mix: Color green shades: 12)" - - | redInc greenInc blueInc rr gg bb c out | - thisMany = 1 ifTrue: [^ Array with: color2]. - redInc _ color2 red - self red / (thisMany-1). - greenInc _ color2 green - self green / (thisMany-1). - blueInc _ color2 blue - self blue / (thisMany-1). - rr _ self red. gg _ self green. bb _ self blue. - out _ (1 to: thisMany) collect: [:num | - c _ Color r: rr g: gg b: bb. - rr _ rr + redInc. - gg _ gg + greenInc. - bb _ bb + blueInc. - c]. - out at: out size put: color2. "hide roundoff errors" - ^ out -! ! -!Color methodsFor: 'groups of shades' stamp: 'di 10/23/2000 09:45' prior: 50353647! - wheel: thisMany - "An array of thisMany colors around the color wheel starting at self and ending all the way around the hue space just before self. Array is of length thisMany. Very useful for displaying color based on a variable in your program. " - - | sat bri hue step c | - sat _ self saturation. - bri _ self brightness. - hue _ self hue. - step _ 360.0 / (thisMany max: 1). - ^ (1 to: thisMany) collect: [:num | - c _ Color h: hue s: sat v: bri. "hue is taken mod 360" - hue _ hue + step. - c]. -" -(Color wheel: 8) withIndexDo: [:c :i | Display fill: (i*10@20 extent: 10@20) fillColor: c] -"! ! -!Color methodsFor: 'named colors' stamp: 'KenD 1/26/2013 16:33' prior: 50353704! - closestColor - "Answer the closest matching color in the colorNames dictionary" - -" - (Color red lighter lighter) closestColor explore. -" - ^ self closestColorFrom: (Color colorNamesDict)! ! -!Color methodsFor: 'named colors' stamp: 'KenD 1/26/2013 16:36' prior: 50353712! - closestColorAssociation - "Answer this color's closest name->color match." - -" - (Color blue lighter lighter) closestColorAssociation explore. -" - ^ self closestAssocFrom: (Color colorNamesDict)! ! -!Color methodsFor: 'named colors' stamp: 'KenD 1/26/2013 16:36' prior: 50353729! - closestColorName - "Answer the name symbol of the closest matching color in the colorNames dictionary" -" - (Color red lighter lighter) closestColor name. -" - - ^ self closestNameFrom: (Color colorNamesDict)! ! -!Color methodsFor: 'other' stamp: 'KenD 7/18/2015 20:41' prior: 50353746! - colorName - "Return this color's name, or nil if it has no name. Only returns a name if it exactly matches the named color." - - ^(Color colorNamesDict keyAtValue: self ifAbsent: [nil]) -! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:50' prior: 50353993! - adjustBrightness: brightness - "Adjust the relative brightness of this color. (lowest value is 0.005 so that hue information is not lost)" - - ^ Color - h: self hue - s: self saturation - v: (self brightness + brightness min: 1.0 max: 0.005) - alpha: self alpha! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:51' prior: 50354004! - adjustSaturation: saturation brightness: brightness - "Adjust the relative saturation and brightness of this color. (lowest value is 0.005 so that hue information is not lost)" - - ^ Color - h: self hue - s: (self saturation + saturation min: 1.0 max: 0.005) - v: (self brightness + brightness min: 1.0 max: 0.005) - alpha: self alpha! ! -!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 11:55' prior: 50354027! -alphaMixed: proportion with: aColor - "Answer this color mixed with the given color. The proportion, a number - between 0.0 and 1.0, determines what what fraction of the receiver to - use in the mix. For example, 0.9 would yield a color close to the - receiver. This method uses RGB interpolation; HSV interpolation can lead - to surprises. Mixes the alphas (for transparency) also." - - | frac1 frac2 | - frac1 _ proportion asFloat min: 1.0 max: 0.0. - frac2 _ 1.0 - frac1. - ^ Color - r: self red * frac1 + (aColor red * frac2) - g: self green * frac1 + (aColor green * frac2) - b: self blue * frac1 + (aColor blue * frac2) - alpha: self alpha * frac1 + (aColor alpha * frac2)! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/23/2002 01:38' prior: 50354067! - blacker - - ^ self alphaMixed: 0.8333 with: Color black -! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:54' prior: 50354071! - dansDarker - "Return a darker shade of the same color. - An attempt to do better than the current darker method. - (now obsolete, since darker has been changed to do this. -dew)" - ^ Color h: self hue s: self saturation - v: (self brightness - 0.16 max: 0.0)! ! -!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 12:00' prior: 50354097! - mixed: proportion with: aColor - "Mix with another color and do not preserve transpareny. Only use this for extracting the RGB value and mixing it. All other callers should use instead: - aColor alphaMixed: proportion with: anotherColor - " - - | frac1 frac2 | - frac1 _ proportion asFloat min: 1.0 max: 0.0. - frac2 _ 1.0 - frac1. - ^ Color - r: self red * frac1 + (aColor red * frac2) - g: self green * frac1 + (aColor green * frac2) - b: self blue * frac1 + (aColor blue * frac2)! ! -!Color methodsFor: 'transformations' stamp: 'dew 1/19/2002 01:29' prior: 50354115! - muchDarker - - ^ self alphaMixed: 0.5 with: Color black -! ! -!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 12:07' prior: 50354119! - muchLighter - - ^ self alphaMixed: 0.233 with: Color white -! ! -!Color methodsFor: 'transformations' stamp: 'ar 6/19/1999 00:36' prior: 50354123! - negated - "Return an RGB inverted color" - ^Color - r: 1.0 - self red - g: 1.0 - self green - b: 1.0 - self blue! ! -!Color methodsFor: 'transformations' stamp: 'jmv 9/10/2009 18:41' prior: 50354144! - quiteBlacker - - ^ self alphaMixed: 0.8 with: Color black -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 9/10/2009 18:44' prior: 50354148! - quiteWhiter - - ^ self alphaMixed: 0.6 with: Color white! ! -!Color methodsFor: 'transformations' stamp: 'dew 1/19/2002 01:25' prior: 50354161! - slightlyWhiter - - ^ self alphaMixed: 0.85 with: Color white -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 8/23/2009 23:24' prior: 50354178! - veryMuchDarker - - ^ self alphaMixed: 0.25 with: Color black -! ! -!Color methodsFor: 'transformations' stamp: 'jmv 7/28/2016 15:43:04' prior: 50354183! - veryMuchLighter - - ^ self alphaMixed: 0.07 with: Color white! ! -!Color methodsFor: 'transformations' stamp: 'dew 3/23/2002 01:38' prior: 50354188! - whiter - - ^ self alphaMixed: 0.8333 with: Color white -! ! -!Color class methodsFor: 'instance creation' stamp: 'jmv 6/2/2016 15:04' prior: 50354381! - colorFromPixelValue: p depth: d - "Convert a pixel value for the given display depth into a color." - "Details: For depths of 8 or less, the pixel value is simply looked up in a table. For greater depths, the color components are extracted and converted into a color." - "Warning: In BitBlt, a pixel with pixelValue = 0 is transparent. - Squeak usually assumes that r=g=b=0 => transparent. But this is false if we have alpha (opacity). - A color with r=g=b=0 and opacity = 255 is BLACK, not TRANSPARENT. - Squeak also answers darkest possible blue when asked for black. Again, this is not needed in 32 bits (with alpha). It is also not really needed for 16 bits as we have an extra, unused bit: 16r8000 is not zero, but rgb=0, and hence, black. - The real rule is that pixelValue=0 means transparent. - And that darkest blue must be used instead of black, but only for depths >8 and < 16 (no indexed colors, no alpha) - This method is updated to reflect that." - - | r g b alpha | - - d = 1 ifTrue: [^ self indexedColors at: (p bitAnd: 16r01) + 1]. - - "For the rest of the depths, pixelValue = 0 means transparent, and darkest blue is considered to be black." - p = 0 ifTrue: [ ^Color transparent ]. - - d = 8 ifTrue: [^ self indexedColors at: (p bitAnd: 16rFF) + 1]. - d = 4 ifTrue: [^ self indexedColors at: (p bitAnd: 16r0F) + 1]. - d = 2 ifTrue: [^ self indexedColors at: (p bitAnd: 16r03) + 1]. - - d = 32 ifTrue: [ - "eight bits per component; 8 bits of alpha" - alpha _ p bitShift: -24. - alpha = 0 ifTrue: [ ^Color transparent ]. - r _ (p bitShift: -16) bitAnd: 16rFF. - g _ (p bitShift: -8) bitAnd: 16rFF. - b _ p bitAnd: 16rFF. - ^alpha < 255 - ifTrue: [ (Color r: r g: g b: b range: 255) alpha: alpha asFloat / 255.0 ] - ifFalse: [ Color r: r g: g b: b range: 255 ]]. - - d = 16 ifTrue: [ - "five bits per component. The most significant bit, unused, allows having real black, without p being zero" - r _ (p bitShift: -10) bitAnd: 16r1F. - g _ (p bitShift: -5) bitAnd: 16r1F. - b _ p bitAnd: 16r1F. - ^ Color r: r g: g b: b range: 31]. - - d = 15 ifTrue: [ - "five bits per component" - r _ (p bitShift: -10) bitAnd: 16r1F. - g _ (p bitShift: -5) bitAnd: 16r1F. - b _ p bitAnd: 16r1F. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Color black ]. - ^ Color r: r g: g b: b range: 31]. - - d = 12 ifTrue: [ - "four bits per component" - r _ (p bitShift: -8) bitAnd: 16rF. - g _ (p bitShift: -4) bitAnd: 16rF. - b _ p bitAnd: 16rF. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Color black ]. - ^ Color r: r g: g b: b range: 15]. - - d = 9 ifTrue: [ - "three bits per component" - r _ (p bitShift: -6) bitAnd: 16r7. - g _ (p bitShift: -3) bitAnd: 16r7. - b _ p bitAnd: 16r7. - (r = 0 and: [ g = 0 and: [ b = 1]]) ifTrue: [ - ^Color black ]. - ^ Color r: r g: g b: b range: 7]. - - self error: 'unknown pixel depth: ', d printString! ! -!Color class methodsFor: 'class initialization' stamp: '' prior: 50354712! - initializeIndexedColors - "Build an array of colors corresponding to the fixed colormap used - for display depths of 1, 2, 4, or 8 bits." - "Color initializeIndexedColors" - - | a index grayVal | - a _ Array new: 256. - - "1-bit colors (monochrome)" - a at: 1 put: (Color r: 1.0 g: 1.0 b: 1.0). "white or transparent" - a at: 2 put: (Color r: 0.0 g: 0.0 b: 0.0). "black" - - "additional colors for 2-bit color" - a at: 3 put: (Color r: 1.0 g: 1.0 b: 1.0). "opaque white" - a at: 4 put: (Color r: 0.5 g: 0.5 b: 0.5). "1/2 gray" - - "additional colors for 4-bit color" - a at: 5 put: (Color r: 1.0 g: 0.0 b: 0.0). "red" - a at: 6 put: (Color r: 0.0 g: 1.0 b: 0.0). "green" - a at: 7 put: (Color r: 0.0 g: 0.0 b: 1.0). "blue" - a at: 8 put: (Color r: 0.0 g: 1.0 b: 1.0). "cyan" - a at: 9 put: (Color r: 1.0 g: 1.0 b: 0.0). "yellow" - a at: 10 put: (Color r: 1.0 g: 0.0 b: 1.0). "magenta" - - a at: 11 put: (Color r: 0.125 g: 0.125 b: 0.125). "1/8 gray" - a at: 12 put: (Color r: 0.25 g: 0.25 b: 0.25). "2/8 gray" - a at: 13 put: (Color r: 0.375 g: 0.375 b: 0.375). "3/8 gray" - a at: 14 put: (Color r: 0.625 g: 0.625 b: 0.625). "5/8 gray" - a at: 15 put: (Color r: 0.75 g: 0.75 b: 0.75). "6/8 gray" - a at: 16 put: (Color r: 0.875 g: 0.875 b: 0.875). "7/8 gray" - - "additional colors for 8-bit color" - "24 more shades of gray (1/32 increments but not repeating 1/8 increments)" - index _ 17. - 1 to: 31 do: [:v | - (v \\ 4) = 0 ifFalse: [ - grayVal _ v / 32.0. - a at: index put: (Color r: grayVal g: grayVal b: grayVal). - index _ index + 1]]. - - "The remainder of color table defines a color cube with six steps - for each primary color. Note that the corners of this cube repeat - previous colors, but this simplifies the mapping between RGB colors - and color map indices. This color cube spans indices 40 through 255 - (indices 41-256 in this 1-based array)." - 0 to: 5 do: [:r | - 0 to: 5 do: [:g | - 0 to: 5 do: [:b | - index _ 41 + ((36 * r) + (6 * b) + g). - index > 256 ifTrue: [ - self error: 'index out of range in color table compuation']. - a at: index put: (Color r: r g: g b: b range: 5)]]]. - - IndexedColors _ a. -! ! -!Color class methodsFor: 'examples' stamp: 'jmv 8/17/2012 18:48' prior: 50354781! - colorRampForDepth: depth extent: aPoint - "Returns a form of the given size showing R, G, B, and gray ramps for the given depth. Useful for testing color conversions between different depths." - "(Color colorRampForDepth: Display depth extent: 256@80) display" - "(Color colorRampForDepth: 32 extent: 256@80) displayOn: Display at: 0@0 rule: Form paint" - - | f dx dy r | - f _ Form extent: aPoint depth: depth. - dx _ aPoint x // 256. - dy _ aPoint y // 4. - 0 to: 255 do: [:i | - r _ (dx * i)@0 extent: dx@dy. - f fill: r fillColor: (Color r: i g: 0 b: 0 range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Color r: 0 g: i b: 0 range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Color r: 0 g: 0 b: i range: 255). - r _ r translatedBy: 0@dy. - f fill: r fillColor: (Color r: i g: i b: i range: 255)]. - ^ f -! ! -!Color class methodsFor: 'examples' stamp: '' prior: 50354885! - showColorCube - "Show a 12x12x12 color cube." - "Color showColorCube" - - 0 to: 11 do: [:r | - 0 to: 11 do: [:g | - 0 to: 11 do: [:b | - Display fill: (((r*60) + (b*5)) @ (g*5) extent: 5@5) - fillColor: (Color r: r g: g b: b range: 11)]]]. -! ! -!Color class methodsFor: 'examples' stamp: '' prior: 50354905! - showHSVPalettes - "Shows a palette of hues, varying the saturation and brightness for each one. Best results are with depths 16 and 32." - "Color showHSVPalettes" - - | left top c | - left _ top _ 0. - 0 to: 179 by: 15 do: [:h | - 0 to: 10 do: [:s | - left _ (h * 4) + (s * 4). - 0 to: 10 do: [:v | - c _ Color h: h s: s asFloat / 10.0 v: v asFloat / 10.0. - top _ (v * 4). - Display fill: (left@top extent: 4@4) fillColor: c. - - c _ Color h: h + 180 s: s asFloat / 10.0 v: v asFloat / 10.0. - top _ (v * 4) + 50. - Display fill: (left@top extent: 4@4) fillColor: c]]]. -! ! -!Color class methodsFor: 'examples' stamp: '' prior: 50354942! - wheel: thisMany - "Return a collection of thisMany colors evenly spaced around the color wheel." - "Color showColors: (Color wheel: 12)" - - ^ Color wheel: thisMany saturation: 0.9 brightness: 0.7 -! ! -!Color class methodsFor: 'examples' stamp: '' prior: 50354950! - wheel: thisMany saturation: s brightness: v - "Return a collection of thisMany colors evenly spaced around the color wheel, all of the given saturation and brightness." - "Color showColors: (Color wheel: 12 saturation: 0.4 brightness: 1.0)" - "Color showColors: (Color wheel: 12 saturation: 0.8 brightness: 0.5)" - - ^ (Color h: 0.0 s: s v: v) wheel: thisMany -! ! -!Color class methodsFor: 'colormaps' stamp: '' prior: 50355350! - colorMapIfNeededFrom: sourceDepth to: destDepth - "Return a colormap for mapping between the given depths, or nil if no colormap is needed." - "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" - - sourceDepth = destDepth ifTrue: [^ nil]. "not needed if depths are the same" - - (sourceDepth >= 16) & (destDepth >= 16) ifTrue: [ - "mapping is done in BitBlt by zero-filling or truncating each color component" - ^ nil]. - - ^ Color cachedColormapFrom: sourceDepth to: destDepth -! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 5/12/2016 15:56' prior: 50355465! - computeColormapFromGray8bppForDepth: destDepth - "Return a colormap for displaying a GrayForm at the given depth" - - | newMap | - newMap _ Bitmap new: 256. - 1 to: 256 do: [ :i | - newMap - at: i - put: ((Color gray: (i-1) asFloat / 255.0) pixelValueForDepth: destDepth)]. - ^ newMap! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 4/17/2015 15:05' prior: 50355476! - computeIndexedColorConvertingMap: targetColor from: sourceDepth to: destDepth - | map | - - map _ (self indexedColors copyFrom: 1 to: (1 bitShift: sourceDepth)) collect: [ :cc | | f c | - f _ 1.0 - (cc red + cc green + cc blue / 3.0 ). - c _ targetColor - ifNotNil: [ - destDepth = 32 - ifTrue: [ targetColor * f alpha: f] - ifFalse: [ targetColor alphaMixed: f*1.5 with: Color white ]] - ifNil: [ cc ]. - destDepth = 32 - ifTrue: [ c pixelValueForDepth: destDepth] - ifFalse: [ - f = 0.0 - ifTrue: [ 0 ] - ifFalse: [ c pixelValueForDepth: destDepth ]]]. - map _ map as: Bitmap. - ^map! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 12/26/2011 13:49' prior: 50355498! - computeRGBColorConvertingMap: targetColor to: destDepth keepSubPixelAA: keepSubPix - "Builds a colormap intended to convert from subpixelAA black values to targetColor values. - keepSubPix - ifTrue: [ Answer colors that also include subpixelAA ] - ifFalse: [ - Take fullpixel luminance level. Apply it to targetColor. - I.e. answer colors with NO subpixelAA ]" - - | mask map c bitsPerColor r g b f v | - - destDepth > 8 - ifTrue: [bitsPerColor _ 5] "retain maximum color resolution" - ifFalse: [bitsPerColor _ 4]. - "Usually a bit less is enough, but make it configurable" - bitsPerColor _ bitsPerColor min: Preferences aaFontsColormapDepth. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - r _ (i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask. - g _ (i bitShift: 0 - bitsPerColor) bitAnd: mask. - b _ (i bitShift: 0) bitAnd: mask. - f _ 1.0 - (r + g + b / 3.0 / mask). - c _ targetColor - ifNotNil: [ - (keepSubPix and: [destDepth > 8]) ifTrue: [ - Color - r: 1.0 - (r asFloat/mask) * targetColor red - g: 1.0 - (g asFloat/mask) * targetColor green - b: 1.0 - (b asFloat/mask) * targetColor blue - alpha: f * targetColor alpha "alpha will be ignored below, in #pixelValueForDepth: if destDepth ~= 32" ] - ifFalse: [ - destDepth = 32 - ifTrue: [ targetColor * f alpha: f * targetColor alpha ] - ifFalse: [ targetColor alphaMixed: f*1.5 with: Color white ]]] - ifNil: [ Color r: r g: g b: b range: mask]. "This is currently used only to keep some SubPixelAA on destDepth = 8, using a single pass of rule 25" - v _ destDepth = 32 - ifTrue: [ c pixelValueForDepth: destDepth] - ifFalse: [ - f < 0.1 - ifTrue: [ 0 ] - ifFalse: [ c pixelValueForDepth: destDepth ]]. - map at: i + 1 put: v ]. - ^ map! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 1/30/2011 23:10' prior: 50355558! - computeRGBColormapFor: destDepth bitsPerColor: bitsPerColor - "Compute a colorMap for translating from 16-bit or 32-bit RGB color to the given depth, using the given number of of bits per color component." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | mask map c | - (#(3 4 5) includes: bitsPerColor) - ifFalse: [self error: 'BitBlt only supports 3, 4, or 5 bits per color component']. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - c _ Color - r: ((i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask) - g: ((i bitShift: 0 - bitsPerColor) bitAnd: mask) - b: ((i bitShift: 0) bitAnd: mask) - range: mask. - map at: i + 1 put: (c pixelValueForDepth: destDepth)]. - - map at: 1 put: (Color transparent pixelWordForDepth: destDepth). "zero always transparent" - ^ map -! ! -!Color class methodsFor: 'colormaps' stamp: 'jmv 5/12/2016 15:57' prior: 50355600! - computeRGBColormapForGray8 - "Compute a colorMap for translating from 16-bit or 32-bit RGB color to 8bpp grays, using the default number of of bits per color component." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - - | bitsPerColor mask map c | - bitsPerColor _ 5. - mask _ (1 bitShift: bitsPerColor) - 1. - map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)). - 0 to: map size - 1 do: [:i | - c _ Color - r: ((i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask) - g: ((i bitShift: 0 - bitsPerColor) bitAnd: mask) - b: ((i bitShift: 0) bitAnd: mask) - range: mask. - map at: i + 1 put: (c luminance * 255) rounded]. - - ^ map! ! -!Color class methodsFor: 'color from user' stamp: 'jmv 3/1/2010 15:13' prior: 50355666! - colorPaletteForDepth: depth extent: chartExtent - "Display a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." - "Note: It is slow to build this palette, so it should be cached for quick access." - "(Color colorPaletteForDepth: 16 extent: 190@60) display" - - | basicHue x y startHue palette transHt vSteps transCaption grayWidth hSteps | - palette _ Form extent: chartExtent depth: depth. - transCaption _ - (Form extent: 34@9 depth: 1 - fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0) - offset: 0@0). - transHt _ transCaption height. - palette fillWhite: (0@0 extent: palette width@transHt). - palette fillBlack: (0@transHt extent: palette width@1). - transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0). - grayWidth _ 10. - startHue _ 338.0. - vSteps _ palette height - transHt // 2. - hSteps _ palette width - grayWidth. - x _ 0. - startHue to: startHue + 360.0 by: 360.0/hSteps do: [ :h | - basicHue _ Color h: h asFloat s: 1.0 v: 1.0. - y _ transHt+1. - 0 to: vSteps do: [ :n | | c | - c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Color white. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - 1 to: vSteps do: [ :n | | c | - c _ Color black mixed: (n asFloat / vSteps asFloat) with: basicHue. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - x _ x + 1]. - y _ transHt + 1. - 1 to: vSteps * 2 do: [ :n | | c | - c _ Color black mixed: (n asFloat / (vSteps*2) asFloat) with: Color white. - palette fill: (x@y extent: 10@1) fillColor: c. - y _ y + 1]. - ^ palette -! ! -!Color class methodsFor: 'color from user' stamp: 'jmv 7/27/2009 11:32' prior: 50355723! - colorTest: depth extent: chartExtent colorMapper: colorMapper - "Create a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." - "Note: It is slow to build this palette, so it should be cached for quick access." - "(Color colorTest: 32 extent: 570@180 colorMapper: [:c | c]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 7) asInteger / 7 - g: (c green * 7) asInteger / 7 - b: (c blue * 3) asInteger / 3]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 5) asInteger / 5 - g: (c green * 5) asInteger / 5 - b: (c blue * 5) asInteger / 5]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 15) asInteger / 15 - g: (c green * 15) asInteger / 15 - b: (c blue * 15) asInteger / 15]) display" - "(Color colorTest: 32 extent: 570@180 colorMapper: - [:c | Color - r: (c red * 31) asInteger / 31 - g: (c green * 31) asInteger / 31 - b: (c blue * 31) asInteger / 31]) display" - - | basicHue x y c startHue palette transHt vSteps transCaption grayWidth hSteps | - palette _ Form extent: chartExtent depth: depth. - transCaption _ - (Form extent: 34@9 depth: 1 - fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0) - offset: 0@0). - transHt _ transCaption height. - palette fillWhite: (0@0 extent: palette width@transHt). - palette fillBlack: (0@transHt extent: palette width@1). - transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0). - grayWidth _ 10. - startHue _ 338.0. - vSteps _ palette height - transHt // 2. - hSteps _ palette width - grayWidth. - x _ 0. - startHue to: startHue + 360.0 by: 360.0/hSteps do: [:h | - basicHue _ Color h: h asFloat s: 1.0 v: 1.0. - y _ transHt+1. - 0 to: vSteps do: [:n | - c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Color white. - c _ colorMapper value: c. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - 1 to: vSteps do: [:n | - c _ Color black mixed: (n asFloat / vSteps asFloat) with: basicHue. - c _ colorMapper value: c. - palette fill: (x@y extent: 1@1) fillColor: c. - y _ y + 1]. - x _ x + 1]. - y _ transHt + 1. - 1 to: vSteps * 2 do: [:n | - c _ Color black mixed: (n asFloat / (vSteps*2) asFloat) with: Color white. - c _ colorMapper value: c. - palette fill: (x@y extent: 10@1) fillColor: c. - y _ y + 1]. - ^ palette -! ! -!Color class methodsFor: 'color name lookup' stamp: 'KenD 1/28/2013 20:34' prior: 50355811! - defaultColorNamesDictionary - "Answer a amall but useful name->color dictionary" - - | defaultDict | - "Meld most used xkcd colors into traditional colors." - defaultDict := (self traditionalColorNamesDictionary addAll: - self xkcdFirst48ColorNamesDictionary; - yourself). - - "Override traditional names existing in extended XKCD naming" - defaultDict at: #lightYellow put: (Color r: 1.0 g: 0.996 b: 0.478). - defaultDict at: #lightOrange put: (Color r: 0.992 g: 0.667 b: 0.283). - defaultDict at: #lightCyan put: (Color r: 0.674 g: 1.0 b: 0.988). - defaultDict at: #lightRed put: (Color r: 1.0 g: 0.279 b: 0.298). - defaultDict at: #lightMagenta put: (Color r: 0.98 g: 0.372 b: 0.969). - - ^defaultDict! ! -!Color class methodsFor: 'color name lookup' stamp: 'KenD 2/1/2013 14:39' prior: 50355837! - doesNotUnderstand: aMessage - "Some code takes - Color colorNames - and does - Color perform: aColorname. - - Make this work." - - ^(Color colorNamesDict) - at: (aMessage selector) - ifAbsent: [super doesNotUnderstand: aMessage]! ! -!Color class methodsFor: 'color name lookup' stamp: 'KenD 7/25/2014 21:22' prior: 50355855! - setColorNamesDict: aNameColorDictionary - "Answer the current dictionary of name->color associations." - - "Note: This is a non-standard name because this is a non-standard action!! - Do this if you really, really know what you are doing." - - "Some Colors are required for proper system operation" - Color defaultColorNamesDictionary keysAndValuesDo: [ :colorName :colorValue | - aNameColorDictionary at: colorName ifAbsentPut: colorValue - ]. - - ColorNamesDict := aNameColorDictionary! ! -!Color class methodsFor: 'color name lookup' stamp: 'sqr 10/21/2016 12:44:48' prior: 50355873! - traditionalColorNamesDictionary - "Answer a dictionary of Squeak traditional name->color associations.." - - | nameDict | - nameDict _ Dictionary new. - nameDict at: #black put: (Color r: 0 g: 0 b: 0). - nameDict at: #veryVeryDarkGray put: (Color r: 0.125 g: 0.125 b: 0.125). - nameDict at: #veryDarkGray put: (Color r: 0.25 g: 0.25 b: 0.25). - nameDict at: #darkGray put: (Color r: 0.375 g: 0.375 b: 0.375). - nameDict at: #gray put: (Color r: 0.5 g: 0.5 b: 0.5). - nameDict at: #lightGray put: (Color r: 0.625 g: 0.625 b: 0.625). - nameDict at: #veryLightGray put: (Color r: 0.75 g: 0.75 b: 0.75). - nameDict at: #veryVeryLightGray put: (Color r: 0.875 g: 0.875 b: 0.875). - nameDict at: #white put: (Color r: 1.0 g: 1.0 b: 1.0). - nameDict at: #red put: (Color r: 1.0 g: 0 b: 0). - nameDict at: #yellow put: (Color r: 1.0 g: 1.0 b: 0). - nameDict at: #green put: (Color r: 0 g: 1.0 b: 0). - nameDict at: #cyan put: (Color r: 0 g: 1.0 b: 1.0). - nameDict at: #blue put: (Color r: 0 g: 0 b: 1.0). - nameDict at: #magenta put: (Color r: 1.0 g: 0 b: 1.0). - nameDict at: #brown put: (Color r: 0.6 g: 0.2 b: 0). - nameDict at: #orange put: (Color r: 1.0 g: 0.6 b: 0). - nameDict at: #lightRed put: (Color r: 1.0 g: 0.8 b: 0.8). - nameDict at: #lightYellow put: (Color r: 1.0 g: 1.0 b: 0.8). - nameDict at: #lightGreen put: (Color r: 0.8 g: 1.0 b: 0.6). - nameDict at: #lightCyan put: (Color r: 0.4 g: 1.0 b: 1.0). - nameDict at: #lightBlue put: (Color r: 0.8 g: 1.0 b: 1.0). - nameDict at: #lightMagenta put: (Color r: 1.0 g: 0.8 b: 1.0). - nameDict at: #lightBrown put: (Color r: 1.0 g: 0.6 b: 0.2). - nameDict at: #lightOrange put: (Color r: 1.0 g: 0.8 b: 0.4). - nameDict at: #transparent put: (TranslucentColor r: 0.0 g: 0.0 b: 0.0 alpha: 0.0). - - ^nameDict -! ! -!Color class methodsFor: 'color name lookup' stamp: 'jmv 6/30/2014 15:22' prior: 50355930! - xkcdFirst48ColorNamesDictionary - "XKCD color names are based on a survey oc colors people call by the same name. - http://blog.xkcd.com/2010/05/03/color-survey-results/" - - "Answer a dictionary of the most agreed upon first 48 xkcd colors" -" - Color xkcdFirst48ColorNamesDictionary explore. -" - | xkcdDict | - xkcdDict := Dictionary new - at: #lightPink put: (Color fromString: '#ffd1df') ; - at: #mustard put: (Color fromString: '#ceb301') ; - at: #indigo put: (Color fromString: '#380282') ; - at: #lime put: (Color fromString: '#aaff32') ; - at: #seaGreen put: (Color fromString: '#53fca1') ; - at: #periwinkle put: (Color fromString: '#8e82fe') ; - at: #darkPink put: (Color fromString: '#cb416b') ; - at: #oliveGreen put: (Color fromString: '#677a04') ; - at: #peach put: (Color fromString: '#ffb07c') ; - at: #paleGreen put: (Color fromString: '#c7fdb5') ; - at: #lightBrown put: (Color fromString: '#ad8150') ; - at: #hotPink put: (Color fromString: '#ff028d') ; - at: #black put: (Color fromString: '#000000') ; - at: #lilac put: (Color fromString: '#cea2fd') ; - at: #navyBlue put: (Color fromString: '#001146') ; - at: #royalBlue put: (Color fromString: '#0504aa') ; - at: #beige put: (Color fromString: '#e6daa6') ; - at: #salmon put: (Color fromString: '#ff796c') ; - at: #olive put: (Color fromString: '#6e750e') ; - at: #maroon put: (Color fromString: '#650021') ; - at: #brightGreen put: (Color fromString: '#01ff07') ; - at: #darkPurple put: (Color fromString: '#35063e') ; - at: #mauve put: (Color fromString: '#ae7181') ; - at: #forestGreen put: (Color fromString: '#06470c') ; - at: #aqua put: (Color fromString: '#13eac9') ; - at: #cyan put: (Color fromString: '#00ffff') ; - at: #tan put: (Color fromString: '#d1b26f') ; - at: #darkBlue put: (Color fromString: '#00035b') ; - at: #lavender put: (Color fromString: '#c79fef') ; - at: #turquoise put: (Color fromString: '#06c2ac') ; - at: #darkGreen put: (Color fromString: '#033500') ; - at: #violet put: (Color fromString: '#9a0eea') ; - at: #lightPurple put: (Color fromString: '#bf77f6') ; - at: #limeGreen put: (Color fromString: '#89fe05') ; - at: #grey put: (Color fromString: '#929591') ; - at: #skyBlue put: (Color fromString: '#75bbfd') ; - at: #yellow put: (Color fromString: '#ffff14') ; - at: #magenta put: (Color fromString: '#c20078') ; - at: #lightGreen put: (Color fromString: '#96f97b') ; - at: #orange put: (Color fromString: '#f97306') ; - at: #teal put: (Color fromString: '#029386') ; - at: #lightBlue put: (Color fromString: '#95d0fc') ; - at: #red put: (Color fromString: '#e50000') ; - at: #brown put: (Color fromString: '#653700') ; - at: #pink put: (Color fromString: '#ff81c0') ; - at: #blue put: (Color fromString: '#0343df') ; - at: #green put: (Color fromString: '#15b01a') ; - at: #purple put: (Color fromString: '#7e1e9c') ; - yourself. - - ^xkcdDict - -! ! -!SystemDictionary methodsFor: 'shrinking' stamp: 'jmv 4/25/2016 15:31' prior: 50348306! - reduceCuis - " - Smalltalk reduceCuis - " - | keep n unused newDicts oldDicts | - - self nominallyUnsent: #reduceCuis. - - "Remove icons" - Smalltalk at: #ClassicTheme ifPresent: [ :cls | cls beCurrent ]. - PasteUpMorph allInstancesDo: [ :w | - w backgroundImageData: nil. - w submorphsDo: [ :a | a delete ]]. - Preferences useNoIcons. - Theme current initialize. - Theme content: nil. - Color shutDown. - BitBltCanvas releaseClassCachedState. - - Transcript clear. - Clipboard default initialize. - - - "Remove some methods, even if they have senders." -" ColorPickerMorph class removeSelector: #buildEyedropperIcon." - Theme removeSelector: #miscellaneousIcons. - Utilities removeSelector: #vmStatisticsReportString. - SystemDictionary removeSelector: #recreateSpecialObjectsArray. - - StrikeFont removeMostFonts. - StrikeFont saveSpace. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - - keep := OrderedCollection new. - keep addAll: #(SpaceTally). - AppLauncher appGlobalName ifNotNil: [ :any | - keep add: any ]. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - [ - #hereWeGo print. - unused do: [:c | - c print. - (Smalltalk at: c) removeFromSystem]. - n := Smalltalk removeAllUnSentMessages. - unused := Smalltalk unusedClasses copyWithoutAll: keep. - n > 0 or: [ - unused notEmpty ]] whileTrue. - ChangeSet zapAllChangeSets. - Smalltalk garbageCollect. - - Smalltalk removeEmptyMessageCategories. - Smalltalk organization removeEmptyCategories. - Symbol rehash. - - "Shrink method dictionaries." - Smalltalk garbageCollect. - oldDicts _ MethodDictionary allInstances. - newDicts _ Array new: oldDicts size. - oldDicts withIndexDo: [:d :index | - newDicts at: index put: d rehashWithoutBecome ]. - oldDicts elementsExchangeIdentityWith: newDicts. - oldDicts _ newDicts _ nil. - - SmalltalkCompleter initialize . - - "Sanity checks" -" Undeclared - Smalltalk cleanOutUndeclared - Smalltalk browseUndeclaredReferences - Smalltalk obsoleteClasses - Smalltalk obsoleteBehaviors - Smalltalk browseObsoleteMethodReferences - SmalltalkImage current fixObsoleteReferences - Smalltalk browseAllUnimplementedCalls"! ! -!Transcripter methodsFor: 'accessing' stamp: 'jmv 7/28/2015 08:26' prior: 50348377! - 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]. - textComposition - setModel: (TextModel withText: c asText); - extentForComposing: frame width-8 @9999. - textComposition composeAll. - d _ textComposition usedHeight - frame height. - d > 0 ifTrue: [ - "Scroll up to keep all contents visible" - cb _ textComposition characterBlockAtPoint: - 0@0 + (0@(d+AbstractFont default height)). - self on: (c copyFrom: cb stringIndex to: c size). - readLimit _ position _ collection size. - ^ self endEntry]. - Display fill: (frame insetBy: -2) fillColor: self black; - fill: frame fillColor: self white. - Display getCanvas - textComposition: textComposition - bounds: (4@4 + frame topLeft extent: Display extent) - color: Color black - selectionColor: Color blue. - DisplayScreen screenUpdateRequired: nil! ! -!Transcripter methodsFor: 'private' stamp: 'di 8/14/97 12:12' prior: 50348411! - black - Display depth = 1 ifTrue: [^ Bitmap with: 16rFFFFFFFF "Works without color support"]. - ^ Color black! ! -!Transcripter methodsFor: 'private' stamp: 'di 8/14/97 12:12' prior: 50348417! - white - Display depth = 1 ifTrue: [^ Bitmap with: 0 "Works without color support"]. - ^ Color white! ! -!DataStream class methodsFor: 'as yet unclassified' stamp: '' prior: 50348423! - example - "An example and test of DataStream/ReferenceStream. - 11/19/92 jhm: Use self testWith:." - "DataStream example" - "ReferenceStream example" - | input sharedPoint | - - "Construct the test data." - input _ Array new: 9. - input at: 1 put: nil. - input at: 2 put: true. - input at: 3 put: (Form extent: 63 @ 50 depth: 8). - (input at: 3) fillWithColor: Color lightBlue. - input at: 4 put: #(3 3.0 'three'). - input at: 5 put: false. - input at: 6 put: 1024 @ -2048. - input at: 7 put: #x. - input at: 8 put: (Array with: (sharedPoint _ 0 @ -30000)). - input at: 9 put: sharedPoint. - - "Write it out, read it back, and return it for inspection." - ^ self testWith: input! ! -!ReferenceStream class methodsFor: 'as yet unclassified' stamp: '' prior: 50348449! - example2 -"Here is the way to use DataStream and ReferenceStream: - rr _ ReferenceStream fileNamed: ''test.obj''. - rr nextPut: . - rr close. - -To get it back: - rr _ ReferenceStream fileNamed: ''test.obj''. - _ rr next. - rr close. -" -"An example and test of DataStream/ReferenceStream. - 11/19/92 jhm: Use self testWith:." - "ReferenceStream example2" - | input sharedPoint | - - "Construct the test data." - input _ Array new: 9. - input at: 1 put: nil. - input at: 2 put: true. - input at: 3 put: false. - input at: 4 put: #(-4 -4.0 'four' four). - input at: 5 put: (Form extent: 63 @ 50 depth: 8). - (input at: 5) fillWithColor: Color lightOrange. - input at: 6 put: 1024 @ -2048. - input at: 7 put: input. "a cycle" - input at: 8 put: (Array with: (sharedPoint _ 0 @ -30000)). - input at: 9 put: sharedPoint. - - "Write it out, read it back, and return it for inspection." - ^ self testWith: input -! ! -!TextEditor methodsFor: 'attributes' stamp: 'jmv 12/12/2014 15:53' prior: 50348481! - offerColorMenu - "Present a menu of available colors, and if one is chosen, apply it to the current selection." - "This is a user command, and generates undo" - - | attribute colors index thisSel | - thisSel _ self selection. - colors _ #(#black #magenta #red #yellow #green #blue #cyan #white ). - index _ (PopUpMenu - labelArray: colors , #('choose color...' ) - lines: (Array with: colors size + 1)) startUpMenu. - index = 0 ifTrue: [ ^ true ]. - index <= colors size - ifTrue: [ attribute _ TextColor color: (Color perform: (colors at: index)) ] - ifFalse: [ - index _ index - colors size - 1. - "Re-number!!!!!!" - index = 0 ifTrue: [ attribute _ self chooseColor ]. - thisSel ifNil: [ ^ true ]]. - attribute ifNotNil: [ self applyAttribute: attribute ]. - ^ true.! ! -!TextAction class methodsFor: 'as yet unclassified' stamp: 'jmv 4/19/2015 09:38' prior: 50348509! -textActionColor - ^Color r: 0.4 g: 0 b: 1.0! ! -!TextColor methodsFor: 'testing' stamp: 'jmv 1/21/2011 11:33' prior: 50348513! - isSet - "Do not include Color black, as it is the default color." - ^color ~= Color black! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 50348519! - black - ^ self new color: Color black! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 50348523! - blue - ^ self new color: Color blue! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 50348527! - cyan - ^ self new color: Color cyan! ! -!TextColor class methodsFor: 'constants' stamp: 'ajh 9/10/2002 02:26' prior: 50348531! - gray - ^ self new color: Color gray! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 50348535! - green - ^ self new color: Color green! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 50348539! - magenta - ^ self new color: Color magenta! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 50348543! - red - ^ self new color: Color red! ! -!TextColor class methodsFor: 'constants' stamp: 'sma 3/24/2000 10:50' prior: 50348547! - white - ^ self new color: Color white! ! -!TextColor class methodsFor: 'constants' stamp: '' prior: 50348551! - yellow - ^ self new color: Color yellow! ! -!Preferences class methodsFor: 'halos' stamp: 'jmv 4/20/2015 16:17' prior: 50348556! - installHaloSpecsFromArray: anArray - - | aColor | - ^ self parameters at: #HaloSpecs put: (anArray collect: [ :each | - aColor _ Color. - each fourth do: [ :sel | aColor _ aColor perform: sel]. - HaloSpec new - horizontalPlacement: each second - verticalPlacement: each third - color: aColor - iconSymbol: each fifth - addHandleSelector: each first - hoverHelp: each sixth])! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 9/19/2016 20:45:55' prior: 50348572! - displayOn: aForm in: aRectangle - " - Transcript displayOn: Display - " - | font count i string x y fh f canvas innerR | - aForm fill: aRectangle fillColor: Color white. - font _ AbstractFont default. - - innerR _ aRectangle insetBy: self padding. - fh _ font height. - count _ innerR height // fh-1. - x _ innerR left. - y _ innerR top. - f _ firstIndex-1. - firstIndex > lastIndex ifTrue: [ f _ f - self maxEntries ]. - i _ (lastIndex - count max: f) \\ self maxEntries + 1. - canvas _ aForm getCanvas. - canvas newClipRect: innerR. - [ - string _ entries at: i. - canvas drawString: string at: x@y font: font color: Color veryDarkGray. - y _ y + fh. - i = lastIndex - ] whileFalse: [ i _ i \\ self maxEntries + 1 ]. - - string _ unfinishedEntry contents. - canvas drawString: string at: x@y font: font color: Color veryDarkGray! ! -!Transcript class methodsFor: 'displaying' stamp: 'jmv 9/19/2016 20:53:35' prior: 50348601! - displayUnfinishedEntryOn: aForm - - | font count string x y fh canvas r innerR | - innerR _ bounds insetBy: self padding. - lastDisplayPosition < innerR right ifTrue: [ - font _ AbstractFont default. - fh _ font height. - count _ innerR height // fh-1. - x _ innerR left. - string _ unfinishedEntry contents. - y _ ((lastIndex - firstIndex \\ self maxEntries) min: count-1) + 1 * font height + innerR top. - canvas _ aForm getCanvas. - r _ innerR left: lastDisplayPosition. - canvas newClipRect: r. - (canvas drawString: string at: x@y font: font color: Color veryDarkGray) ifNotNil: [ :lastPoint | - lastDisplayPosition _ lastPoint x. - ^r ]]. - ^nil! ! -!Form methodsFor: 'analyzing' stamp: 'ar 5/17/2001 15:40' prior: 50348624! - dominantColor - | tally max maxi | - self depth > 16 ifTrue: - [^(self asFormOfDepth: 16) dominantColor]. - tally _ self tallyPixelValues. - max _ maxi _ 0. - tally withIndexDo: [:n :i | n > max ifTrue: [max _ n. maxi _ i]]. - ^ Color colorFromPixelValue: maxi - 1 depth: self depth! ! -!Form methodsFor: 'bordering' stamp: 'jmv 1/22/2015 10:22' prior: 50348636! - border: aRectangle width: borderWidth - "Paint a border whose rectangular area is defined by aRectangle. The - width of the border of each side is borderWidth. Uses black for - drawing the border." - - self border: aRectangle width: borderWidth fillColor: Color black! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:20' prior: 50348647! - fillBlack - "Set all bits in the receiver to black (ones)." - - self fill: self boundingBox fillColor: Color black! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:20' prior: 50348653! - fillBlack: aRectangle - "Set all bits in the receiver's area defined by aRectangle to black (ones)." - - self fill: aRectangle rule: Form over fillColor: Color black! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:20' prior: 50348661! - fillGray - "Set all bits in the receiver to gray." - - self fill: self boundingBox fillColor: Color gray! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:20' prior: 50348667! - fillGray: aRectangle - "Set all bits in the receiver's area defined by aRectangle to the gray mask." - - self fill: aRectangle rule: Form over fillColor: Color gray! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:21' prior: 50348675! - fillWhite - "Set all bits in the form to white." - - self fill: self boundingBox fillColor: Color white! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:21' prior: 50348681! - fillWhite: aRectangle - "Set all bits in the receiver's area defined by aRectangle to white." - - self fill: aRectangle rule: Form over fillColor: Color white! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:21' prior: 50348689! - reverse - "Change all the bits in the receiver that are white to black, and the ones - that are black to white. - Display reverse - " - - self fill: self boundingBox rule: Form reverse fillColor: Color white! ! -!Form methodsFor: 'coloring' stamp: 'jmv 1/22/2015 10:21' prior: 50348698! - reverse: aRectangle - "Change all the bits in the receiver's area that intersects with aRectangle - that are white to black, and the ones that are black to white." - - self fill: aRectangle rule: Form reverse fillColor: Color white! ! -!Form methodsFor: 'color mapping' stamp: 'ar 5/17/2001 15:42' prior: 50348708! - colormapIfNeededForDepth: destDepth - "Return a colormap for displaying the receiver at the given depth, or nil if no colormap is needed." - - self depth = destDepth ifTrue: [^ nil]. "not needed if depths are the same" - ^ Color colorMapIfNeededFrom: self depth to: destDepth -! ! -!Form methodsFor: 'color mapping' stamp: 'jmv 5/12/2016 13:53' prior: 50348720! - colormapIfNeededForGray8bpp - "Return a colormap for displaying the receiver at the given depth. - Note: Uses 5 bits per color component. 32bit Forms will lose information!!" - - ^ Color cachedColormapForGrayFrom: self depth! ! -!Form methodsFor: 'color mapping' stamp: 'jmv 9/23/2012 21:42' prior: 50348730! - mapColor: oldColor to: newColor - "Make all pixels of the given color in this Form to the given new color." - "Warnings: This method modifies the receiver. It may lose some color accuracy on 32-bit Forms, since the transformation uses a color map with only 15-bit resolution." - - | map | - map _ (Color cachedColormapFrom: self depth to: self depth) copy. - map at: (oldColor indexInMap: map) put: (newColor pixelWordForDepth: self depth). - (BitBlt toForm: self) - sourceForm: self; - sourceOrigin: 0@0; - combinationRule: Form over; - destX: 0 destY: 0 width: width height: height; - colorMap: map; - copyBits. -! ! -!Form methodsFor: 'color mapping' stamp: 'jmv 1/31/2011 09:21' prior: 50348752! - maskingMap - "Return a color map that maps all colors except transparent to words of all ones. Used to create a mask for a Form whose transparent pixel value is zero." - "Warning: The behavior is incorrect for 32bpp Forms with translucency. - Color maps are RGB only, they don't map on alpha values. Alpha is ignored when using the color map. This means that the only value mapped as transparent is pixel value 0, - that is R=0, G=0, B=0, Alpha=0. - However, a 32bpp form could have, for instance R=255, G=0, B=0, Alpha=0, also meaning transparent. But this will be mapped as if the source was red, not transparent." - ^Color maskingMap: self depth! ! -!Form methodsFor: 'converting' stamp: 'jm 11/12/97 19:28' prior: 50348775! - as8BitColorForm - "Simple conversion of zero pixels to transparent. Force it to 8 bits." - - | f map | - f _ ColorForm extent: self extent depth: 8. - self displayOn: f at: self offset negated. - map _ Color indexedColors copy. - map at: 1 put: Color transparent. - f colors: map. - f offset: self offset. - ^ f -! ! -!Form methodsFor: 'pixel access' stamp: 'ar 5/17/2001 15:42' prior: 50348788! - colorAt: aPoint - "Return the color in the pixel at the given point. " - - ^ Color - colorFromPixelValue: (self pixelValueAt: aPoint) - depth: self depth -! ! -!Form methodsFor: 'pixel access' stamp: 'jmv 11/4/2015 12:40' prior: 50348796! - colorInterpolatedAt: aPoint - "Evaluate a bilinear (i.e. cheap) interpolation - Like OpenCV's CV_INTER_LINEAR - Answer Color transparent if outside image bounds. - Copied almost verbatim from FloatImage. - Answer Colors with float components. Will be rounded to be stored in, for example, a 32-bit Form." - - | x y w interpolated xWeight1 xWeight0 yWeight1 yWeight0 xIndex0 xIndex1 yIndex0 yIndex1 | - x _ aPoint x. - y _ aPoint y. - x < 0.0 ifTrue: [ ^Color transparent ]. - xIndex0 _ x truncated. "Could be #floor. But as we only care for values >=0, it is the same. But faster." - xIndex0 > (width-1) ifTrue: [ ^Color transparent ]. - (xIndex0 = (width-1) and: [ x > (width-1) ]) ifTrue: [ ^Color transparent ]. - xIndex1 _ xIndex0 = (width-1) "Avoid the invalid access if this was true, but don't make it slower the most common, general case." - ifFalse: [ xIndex0 + 1 ] - ifTrue: [ xIndex0 ]. - - y < 0.0 ifTrue: [ ^Color transparent ]. - yIndex0 _ y truncated. "Could be #floor. But as we only care for values >=0, it is the same. But faster." - yIndex0 > (height-1) ifTrue: [ ^Color transparent ]. - (yIndex0 = (height-1) and: [ y > (height-1) ]) ifTrue: [ ^Color transparent ]. - yIndex1 _ yIndex0 = (height-1) "Avoid the invalid access if this was true, but don't make it slower the most common, general case." - ifFalse: [ yIndex0 + 1 ] - ifTrue: [ yIndex0 ]. - - xWeight1 _ x - xIndex0. - xWeight0 _ 1.0 - xWeight1. - - yWeight1 _ y - yIndex0. - yWeight0 _ 1.0 - yWeight1. - - "/* perform interpolation */" - w _ ((self colorAt: xIndex0 @ yIndex0) * xWeight0) + - ((self colorAt: xIndex1 @ yIndex0) * xWeight1). - interpolated _ w * yWeight0. - - w _ ((self colorAt: xIndex0 @ yIndex1) * xWeight0) + - ((self colorAt: xIndex1 @ yIndex1) * xWeight1). - interpolated _ w * yWeight1 + interpolated. - - ^interpolated! ! -!Form methodsFor: 'transitions' stamp: 'jmv 7/28/2015 08:32' prior: 50348855! - pageWarp: otherImage at: topLeft forward: forward - "Produce a page-turning illusion that gradually reveals otherImage - located at topLeft in this form. - forward == true means turn pages toward you, else away. [ignored for now]" - | pageRect oldPage nSteps buffer p leafRect sourceQuad warp oldBottom d | - pageRect _ otherImage boundingBox. - oldPage _ self copy: (pageRect translatedBy: topLeft). - (forward ifTrue: [oldPage] ifFalse: [otherImage]) - border: pageRect - widthRectangle: (Rectangle - left: 0 - right: 2 - top: 1 - bottom: 1) - rule: Form over - fillColor: Color black. - oldBottom _ self copy: ((pageRect bottomLeft + topLeft) extent: (pageRect width@(pageRect height//4))). - nSteps _ 8. - buffer _ Form extent: otherImage extent + (0@(pageRect height//4)) depth: self depth. - d _ pageRect topLeft + (0@(pageRect height//4)) - pageRect topRight. - 1 to: nSteps-1 do: - [:i | forward - ifTrue: [buffer copy: pageRect from: otherImage to: 0@0 rule: Form over. - p _ pageRect topRight + (d * i // nSteps)] - ifFalse: [buffer copy: pageRect from: oldPage to: 0@0 rule: Form over. - p _ pageRect topRight + (d * (nSteps-i) // nSteps)]. - buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over. - leafRect _ pageRect topLeft corner: p x @ (pageRect bottom + p y). - sourceQuad _ Array with: pageRect topLeft - with: pageRect bottomLeft + (0@p y) - with: pageRect bottomRight - with: pageRect topRight - (0@p y). - warp _ (WarpBlt toForm: buffer) - clipRect: leafRect; - sourceForm: (forward ifTrue: [oldPage] ifFalse: [otherImage]); - combinationRule: Form paint. - warp copyQuad: sourceQuad toRect: leafRect. - self copy: buffer boundingBox from: buffer to: topLeft rule: Form over. - Display forceToScreen. - ]. - - buffer copy: pageRect from: otherImage to: 0@0 rule: Form over. - buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over. - self copy: buffer boundingBox from: buffer to: topLeft rule: Form over. - Display forceToScreen. -" -1 to: 4 do: [:corner | Display pageWarp: - (Form fromDisplay: (10@10 extent: 200@300)) reverse - at: 10@10 forward: false] -" -! ! -!Form class methodsFor: 'instance creation' stamp: 'jmv 9/23/2012 21:44' prior: 50348926! - dotOfSize: diameter - "Create a form which contains a round black dot." - | radius form bb rect centerX centerY centerYBias centerXBias radiusSquared xOverY maxy dx | - radius _ diameter//2. - form _ self extent: diameter@diameter offset: (0@0) - (radius@radius). - bb _ (BitBlt toForm: form) - sourceX: 0; sourceY: 0; - combinationRule: Form over; - fillColor: Color black. - rect _ form boundingBox. - centerX _ rect center x. - centerY _ rect center y. - centerYBias _ rect height odd ifTrue: [0] ifFalse: [1]. - centerXBias _ rect width odd ifTrue: [0] ifFalse: [1]. - radiusSquared _ (rect height asFloat / 2.0) squared - 0.01. - xOverY _ rect width asFloat / rect height asFloat. - maxy _ rect height - 1 // 2. - - "First do the inner fill, and collect x values" - 0 to: maxy do: - [:dy | - dx _ ((radiusSquared - (dy * dy) asFloat) sqrt * xOverY) truncated. - bb destX: centerX - centerXBias - dx - destY: centerY - centerYBias - dy - width: dx + dx + centerXBias + 1 - height: 1; - copyBits. - bb destY: centerY + dy; - copyBits]. - ^ form -" -Time millisecondsToRun: - [1 to: 20 do: [:i | (Form dotOfSize: i) displayAt: (i*20)@(i*20)]] -"! ! -!Form class methodsFor: 'instance creation' stamp: 'pb 5/4/2016 17:43' prior: 50348965! - fakeSphereAt: aPoint diameter: diameter color: aColor - "Create a form which contains a round black dot." - | bb rect d p | - bb _ GrafPort toForm: Display. - bb fillColor: aColor. - bb combinationRule: Form blend. - rect _ aPoint extent: diameter. - bb fillOval: rect. - p _ (diameter * 2 // 5) asPoint + aPoint. - #(2 3 4 5 6 ) do: [ :i | - "simulate facade by circles of gray" - bb fillColor: (Color white alpha: 0.3). - d _ i * diameter // 10. - rect _ Rectangle - center: p - extent: d. - bb fillOval: rect ]. - DisplayScreen screenUpdateRequired: nil. -" - Form fakeSphereAt: 50@50 diameter: 30 color: (Color red alpha: 0.5) -"! ! -!Form class methodsFor: 'examples' stamp: 'jmv 3/20/2013 22:36' prior: 50348988! - toothpaste: diam - " - Display restoreAfter: [Form toothpaste: 30] - " - "Not completely unlike the ST-80 implementation :) - Original comment: - Draws wormlike lines by laying down images of spheres. - See Ken Knowlton, Computer Graphics, vol. 15 no. 4 p352. - Draw with mouse button down; terminate by option-click." - | point queue color q colors colr colr2 | - colors _ Color red wheel: 12. - color _ 8. - [ true ] whileTrue: [ - queue _ OrderedCollection new: 32. - 16 timesRepeat: [queue addLast: -40@-40]. - Sensor waitButton. - Sensor isMouseButton2Pressed ifTrue: [^ self]. - point _ Sensor mousePoint. - colr _ colors atWrap: (color _ color + 5). "choose increment relatively prime to colors size" - colr2 _ colr alpha: 0.3. - [Sensor isMouseButton1Pressed or: [queue size > 0]] whileTrue: [ - point _ point * 4 + Sensor mousePoint // 5. - point _ point. - Form fakeSphereAt: point diameter: diam color: colr. - (q _ queue removeFirst) ifNil: [^ self]. "exit" - Form fakeSphereAt: q diameter: diam color: colr2. - Sensor isMouseButton1Pressed ifTrue: [queue addLast: point]]]! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 5/15/2015 09:37' prior: 50349025! - bottomLeftCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - "Create and answer a Form for the bottomLeft corner of a rounded rectangle" - | f aaw topColor bottomColor l d c width dy | - topColor _ Color white * gradientTopFactor. - bottomColor _ Color white * gradientBottomFactor. - width _ r. - aaw _ 1.3. - f _ Form - extent: width @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: width - 1 - do: [ :x | - dy _ height - r - y. - dy > 0 - ifTrue: [ l _ 1.0 ] - ifFalse: [ - d _ (width - 1 - x @ dy) r. - l _ ((r - d max: 0.0) min: aaw) / aaw ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 5/15/2015 09:47' prior: 50349053! - bottomLeftCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor borderWidth: bw - "Create and answer a Form for the bottomLeft corner of a rounded rectangle" - | f aaw topColor bottomColor l d c width dy l1 l2 | - topColor _ Color white * gradientTopFactor. - bottomColor _ Color white * gradientBottomFactor. - width _ r. - aaw _ 1.3. - f _ Form - extent: width @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: width - 1 - do: [ :x | - dy _ height - r - y. - dy > 0 - ifTrue: [ l _ 1.0 ] - ifFalse: [ - d _ (width - 1 - x @ dy) r. - l1 _ ((r - d-1+aaw max: 0.0) min: aaw) / aaw. - l2 _ ((d - r+bw+aaw max: 0.0) min: aaw) / aaw. - l _ l1 min: l2. - ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 5/15/2015 09:38' prior: 50349084! - bottomRightCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - "Create and answer a Form for the bottomRight corner of a rounded rectangle" - | f aaw topColor bottomColor l d c width dy | - topColor _ Color white * gradientTopFactor. - bottomColor _ Color white * gradientBottomFactor. - width _ r. - aaw _ 1.3. - f _ Form - extent: width @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: width - 1 - do: [ :x | - dy _ height - r - y. - dy > 0 - ifTrue: [ l _ 1.0 ] - ifFalse: [ - d _ (x @ dy) r. - l _ ((r - d max: 0.0) min: aaw) / aaw ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 5/15/2015 09:41' prior: 50349111! - bottomRightCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor borderWidth: bw - "Create and answer a Form for the bottomLeft corner of a rounded rectangle" - | f aaw topColor bottomColor l d c width dy l1 l2 | - topColor _ Color white * gradientTopFactor. - bottomColor _ Color white * gradientBottomFactor. - width _ r. - aaw _ 1.3. - f _ Form - extent: width @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: width - 1 - do: [ :x | - dy _ height - r - y. - dy > 0 - ifTrue: [ l _ 1.0 ] - ifFalse: [ - d _ (x @ dy) r. - l1 _ ((r - d-1+aaw max: 0.0) min: aaw) / aaw. - l2 _ ((d - r+bw+aaw max: 0.0) min: aaw) / aaw. - l _ l1 min: l2. - ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 11/30/2010 10:34' prior: 50349142! - topLeftCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - "Create and answer a Form with a vertical gray gradient as specified for the topLeft corner of a rounded rectangle" - | f bw topColor bottomColor l d c w | - topColor _ Color white * gradientTopFactor. - bottomColor _ Color white * gradientBottomFactor. - w _ r. - bw _ 1.3. - f _ Form - extent: w @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: w - 1 - do: [ :x | - l _ 1.0. - y < r ifTrue: [ - d _ (w - 1 - x @ (w - 1 - y)) r. - l _ ((r - d max: 0.0) min: bw) / bw ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!Form class methodsFor: 'creation - anti aliased' stamp: 'jmv 11/30/2010 10:36' prior: 50349169! - topRightCorner: r height: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - "Create and answer a Form with a vertical gray gradient as specified for the topRight corner of a rounded rectangle" - | f bw topColor bottomColor l d c w | - topColor _ Color white * gradientTopFactor. - bottomColor _ Color white * gradientBottomFactor. - w _ r. - bw _ 1.3. - f _ Form - extent: w @ height - depth: 32. - 0 - to: height - 1 - do: [ :y | - c _ bottomColor - mixed: 1.0 * y / (height - 1) - with: topColor. - 0 - to: w - 1 - do: [ :x | - l _ 1.0. - y < r ifTrue: [ - d _ (x @ (w - y - 1)) r. - l _ ((r - d max: 0.0) min: bw) / bw ]. - f - colorAt: x @ y - put: (c alpha: l) ]]. - ^ f! ! -!ColorForm methodsFor: 'accessing' stamp: 'ar 5/17/2001 15:45' prior: 50349195! - colors: colorList - "Set my color palette to the given collection." - - | colorArray colorCount newColors | - colorList ifNil: [ - colors _ cachedDepth _ cachedColormap _ nil. - ^ self]. - - colorArray _ colorList asArray. - colorCount _ colorArray size. - newColors _ Array new: (1 bitShift: self depth). - 1 to: newColors size do: [:i | - i <= colorCount - ifTrue: [newColors at: i put: (colorArray at: i)] - ifFalse: [newColors at: i put: Color transparent]]. - - colors _ newColors. - cachedDepth _ nil. - cachedColormap _ nil. -! ! -!ColorForm methodsFor: 'color manipulation' stamp: 'di 11/11/1998 13:20' prior: 50349215! - asGrayScale - "Return a grayscale ColorForm computed by mapping each color into its grayscale equivalent" - ^ self copy colors: - (colors collect: - [:c | c isTransparent ifTrue: [c] - ifFalse: [Color gray: c luminance]])! ! -!ColorForm methodsFor: 'color manipulation' stamp: 'jmv 3/1/2010 09:41' prior: 50349225! - colormapIfNeededForDepth: destDepth - "Return a colormap for displaying the receiver at the given depth, or nil if no colormap is needed." - - | newMap | - colors ifNil: [ - "use the standard colormap" - ^ Color colorMapIfNeededFrom: self depth to: destDepth]. - - (destDepth = cachedDepth and:[cachedColormap isColormap not]) - ifTrue: [^ cachedColormap]. - newMap _ Bitmap new: colors size. - 1 to: colors size do: [:i | - newMap - at: i - put: ((colors at: i) pixelValueForDepth: destDepth)]. - - cachedDepth _ destDepth. - ^ cachedColormap _ newMap. -! ! -!ColorForm methodsFor: 'private' stamp: 'ar 5/17/2001 15:44' prior: 50349245! - ensureColorArrayExists - "Return my color palette." - - colors ifNil: [ - self depth > 8 ifTrue: [^ self error: 'ColorForms only support depths up to 8 bits']. - self colors: (Color indexedColors copyFrom: 1 to: (1 bitShift: self depth))]. -! ! -!ColorForm class methodsFor: 'as yet unclassified' stamp: 'jmv 4/10/2015 23:20' prior: 50349256! - mappingWhiteToTransparentFrom: aFormOrCursor - "Return a ColorForm copied from the given Form or Cursor with white mapped to transparent." - - | f map | - aFormOrCursor depth <= 8 ifFalse: [ - ^ self error: 'argument depth must be 8-bits per pixel or less']. - (aFormOrCursor is: #ColorForm) ifTrue: [ - f _ aFormOrCursor copy. - map _ aFormOrCursor colors. - ] ifFalse: [ - f _ ColorForm extent: aFormOrCursor extent depth: aFormOrCursor depth. - f copyBits: aFormOrCursor boundingBox - from: aFormOrCursor - at: 0@0 - clippingBox: aFormOrCursor boundingBox - rule: Form over. - map _ Color indexedColors copyFrom: 1 to: (1 bitShift: aFormOrCursor depth)]. - map _ map collect: [:c | - c = Color white ifTrue: [Color transparent] ifFalse: [c]]. - f colors: map. - ^ f -! ! -!ColorForm class methodsFor: 'instance creation' stamp: 'jmv 5/4/2016 16:31' prior: 50349284! - grayScaleAndTransparentExtent: aPoint -"Native depth" - "Answer a ColorForm for storing 8bpp gray scale. (do not include any slot for transparent)" - - | grays result | - result _ self extent: aPoint depth: (Smalltalk isLittleEndian ifTrue: [ -8 ] ifFalse: [ 8 ]). - grays _ (0 to: 255) collect: [ :brightness | Color gray: brightness asFloat / 255.0]. - grays at: 1 put: Color transparent. - result colors: grays. - ^result! ! -!Cursor methodsFor: 'converting' stamp: 'jmv 2/25/2011 19:47' prior: 50349300! - asCursorForm - | form | - form _ Form extent: self extent depth: 8. - form fillShape: self fillColor: Color black at: offset negated. - ^ form offset: offset! ! -!CursorWithMask methodsFor: 'converting' stamp: 'jmv 2/25/2011 19:47' prior: 50349308! - asCursorForm - | form | - form _ Form extent: self extent depth: 8. - form fillShape: maskForm fillColor: Color white. - form fillShape: self fillColor: Color black at: offset negated. - ^ form offset: offset! ! -!GrayForm methodsFor: 'pixel accessing' stamp: 'jmv 5/11/2016 19:57' prior: 50349318! - grayAt: aPoint - "Return the color of the pixel at aPoint." - - ^Color gray: (self pixelValueAt: aPoint) asFloat / 255.0! ! -!GrayForm methodsFor: 'color manipulation' stamp: 'jmv 5/12/2016 15:04' prior: 50349325! - colormapIfNeededForDepth: destDepth - "Return a colormap for displaying the receiver at the given depth, or nil if no colormap is needed." - - ^ Color cachedColormapFromGrayTo: destDepth! ! -!BMPReadWriter methodsFor: 'reading' stamp: 'ar 10/24/2005 20:57' prior: 50349334! - readColorMap - "Read colorCount BMP color map entries from the given binary stream. Answer an array of Colors." - | colorCount colors maxLevel b g r ccStream | - colorCount := (bfOffBits - 54) // 4. - "Note: some programs (e.g. Photoshop 4.0) apparently do not set colorCount; assume that any data between the end of the header and the start of the pixel data is the color map" - biBitCount >= 16 ifTrue:[^nil]. - colorCount = 0 ifTrue: [ "this BMP file does not have a color map" - "default monochrome color map" - biBitCount = 1 ifTrue: [^ Array with: Color white with: Color black]. - "default gray-scale color map" - maxLevel := (2 raisedTo: biBitCount) - 1. - ^ (0 to: maxLevel) collect: [:level | Color gray: (level asFloat / maxLevel)]]. - ccStream := ReadStream on: (stream next: colorCount*4). - colors := Array new: colorCount. - 1 to: colorCount do: [:i | - b := ccStream next. - g := ccStream next. - r := ccStream next. - ccStream next. "skip reserved" - colors at: i put: (Color r: r g: g b: b range: 255)]. - ^ colors -! ! -!BitBlt methodsFor: 'accessing' stamp: 'jmv 3/20/2013 00:50' prior: 50349369! - fillColor - "Return the current fill color as a Color. - Gives the wrong answer if the halftoneForm is a complex pattern of more than one word." - - halftoneForm ifNil: [^ Color black]. - ^ Color colorFromPixelValue: halftoneForm first depth: destForm depth! ! -!BitBlt class methodsFor: 'examples' stamp: 'jmv 7/27/2015 17:07' prior: 50349380! - alphaBlendDemo - "To run this demo, use... - Display restoreAfter: [BitBlt alphaBlendDemo] - Displays 10 alphas, then lets you paint. Option-Click to stop painting." - - "This code exhibits alpha blending in any display depth by performing - the blend in an off-screen buffer with 32-bit pixels, and then copying - the result back onto the screen with an appropriate color map. - tk 3/10/97" - - "This version uses a sliding buffer for painting that keeps pixels in 32 bits - as long as they are in the buffer, so as not to lose info by converting down - to display resolution and back up to 32 bits at each operation. - di 3/15/97" - - | brush buff dispToBuff buffToDisplay mapDto32 map32toD prevP p brushToBuff theta buffRect buffSize buffToBuff brushRect delta newBuffRect updateRect | - - "compute color maps if needed" - Display depth <= 8 ifTrue: [ - mapDto32 _ Color cachedColormapFrom: Display depth to: 32. - map32toD _ Color cachedColormapFrom: 32 to: Display depth]. - - "display 10 different alphas, across top of screen" - buff _ Form extent: 500@50 depth: 32. - dispToBuff _ BitBlt toForm: buff. - dispToBuff colorMap: mapDto32. - dispToBuff copyFrom: (50@10 extent: 500@50) in: Display to: 0@0. - 1 to: 10 do: [:i | dispToBuff fill: (50*(i-1)@0 extent: 50@50) - fillColor: (Color red alpha: i/10) - rule: Form blend]. - buffToDisplay _ BitBlt toForm: Display. - buffToDisplay colorMap: map32toD. - buffToDisplay copyFrom: buff boundingBox in: buff to: 50@10. - DisplayScreen screenUpdateRequired: nil. - - "Create a brush with radially varying alpha" - brush _ Form extent: 30@30 depth: 32. - 1 to: 5 do: - [:i | brush fillShape: (Form dotOfSize: brush width*(6-i)//5) - fillColor: (Color red alpha: 0.02 * i - 0.01) - at: brush extent // 2]. - - "Now paint with the brush using alpha blending." - buffSize _ 100. - buff _ Form extent: brush extent + buffSize depth: 32. "Travelling 32-bit buffer" - dispToBuff _ BitBlt toForm: buff. "This is from Display to buff" - dispToBuff colorMap: mapDto32. - brushToBuff _ BitBlt toForm: buff. "This is from brush to buff" - brushToBuff sourceForm: brush; sourceOrigin: 0@0. - brushToBuff combinationRule: Form blend. - buffToBuff _ BitBlt toForm: buff. "This is for slewing the buffer" - - [Sensor isMouseButton2Pressed] whileFalse: - [prevP _ nil. - buffRect _ Sensor mousePoint - (buffSize // 2) extent: buff extent. - dispToBuff copyFrom: buffRect in: Display to: 0@0. - [Sensor isMouseButton1Pressed] whileTrue: - ["Here is the painting loop" - p _ Sensor mousePoint - (brush extent // 2). - (prevP == nil or: [prevP ~= p]) ifTrue: - [prevP == nil ifTrue: [prevP _ p]. - (p dist: prevP) > buffSize ifTrue: - ["Stroke too long to fit in buffer -- clip to buffer, - and next time through will do more of it" - theta _ (p-prevP) theta. - p _ ((theta cos@theta sin) * buffSize asFloat + prevP) truncated]. - brushRect _ p extent: brush extent. - (buffRect containsRect: brushRect) ifFalse: - ["Brush is out of buffer region. Scroll the buffer, - and fill vacated regions from the display" - delta _ brushRect amountToTranslateWithin: buffRect. - buffToBuff copyFrom: buff boundingBox in: buff to: delta. - newBuffRect _ buffRect translatedBy: delta negated. - newBuffRect - areasOutside: buffRect - do: [ :r | dispToBuff copyFrom: r in: Display to: r origin - newBuffRect origin ]. - buffRect _ newBuffRect]. - - "Interpolate from prevP to p..." - brushToBuff drawFrom: prevP - buffRect origin - to: p - buffRect origin - withFirstPoint: false. - - "Update (only) the altered pixels of the destination" - updateRect _ (p min: prevP) corner: (p max: prevP) + brush extent. - buffToDisplay copy: updateRect from: updateRect origin - buffRect origin in: buff. - DisplayScreen screenUpdateRequired: updateRect. - prevP _ p]]]! ! -!WarpBlt methodsFor: 'setup' stamp: 'mtf 8/14/2009 18:21' prior: 50349503! - cellSize: s - "Set the number of samples used for averaging" - cellSize := s. - cellSize = 1 ifTrue: [^ self]. - "Install the colorMap to used for mapping the averaged RGBA 32bit pixels to the - destination depth. Note that we need to install the 32->32 color map explicitly because - the VM will substitute a colorMap derived from sourceForm->destForm mapping which - is just plain wrong for <32 source and 32bit dest depth" - (destForm depth = 32 and: [sourceForm notNil] and: [sourceForm depth < 32]) - ifTrue:[colorMap := ColorMap shifts: #(0 0 0 0) masks:#(16rFF0000 16rFF00 16rFF 16rFF000000) colors: nil] - ifFalse:[colorMap := Color colorMapIfNeededFrom: 32 to: destForm depth]. -! ! -!GrafPort methodsFor: 'text' stamp: 'jmv 6/1/2015 13:28' prior: 50349527! - displayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font color: foregroundColor - "If required, do a second pass with new rule and colorMap. - Answer last affected pixel position - Answer nil if nothing was done - " - - | answer prevRule secondPassMap sourceDepth destDepth | - - "Slight optimization when there's nothing to do." - clipHeight = 0 ifTrue: [^nil]. - clipWidth = 0 ifTrue: [^nil]. - - self installStrikeFont: font foregroundColor: (foregroundColor alpha: 1). - - "If combinationRule is rgbMul, we might need the special two-pass technique for component alpha blending. - If not, do it simply" - combinationRule = 37 "rgbMul" ifFalse: [ - ^self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font ]. - - "We need to do a second pass. The colormap set is for use in the second pass." - secondPassMap _ colorMap. - sourceDepth _ sourceForm depth. - destDepth _ destForm depth. - colorMap _ sourceDepth ~= destDepth - ifTrue: [ Color cachedColormapFrom: sourceDepth to: destDepth ]. - answer := self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font. - colorMap := secondPassMap. - secondPassMap ifNotNil: [ - prevRule := combinationRule. - combinationRule := 20. "rgbAdd" - self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font. - combinationRule := prevRule ]. - ^answer! ! -!GrafPort methodsFor: 'private' stamp: 'jmv 5/12/2016 14:52' prior: 50349574! - cachedFontColormapFrom1BitTo: destDepth - - | map dstIndex | - CachedFontColorMaps - ifNil: [CachedFontColorMaps _ Array new: 6]. - - dstIndex _ destDepth highBit. - (CachedFontColorMaps at: dstIndex) ifNotNil: [ :m | ^ m ]. - - map _ (Color cachedColormapFrom: 1 to: destDepth) copy. - CachedFontColorMaps at: dstIndex put: map. - ^ map! ! -!GrafPort methodsFor: 'private' stamp: 'jmv 5/12/2016 14:55' prior: 50349587! - colorConvertingMap: targetColor from: sourceDepth to: destDepth keepSubPixelAA: keepSubPix - "Note: The color converting map for sourceDepth=16 and for sourceDepth=32 are the same" - - | srcIndex dstIndex map mapsForSource mapsForSourceAndDest | - ColorConvertingMaps - ifNil: [ColorConvertingMaps _ (1 to: 6) collect: [:i | Array new: 6]]. - - srcIndex _ sourceDepth highBit. - sourceDepth > 8 ifTrue: [ srcIndex _ keepSubPix ifTrue: [5] ifFalse: [6] ]. - dstIndex _ destDepth highBit. - - mapsForSource _ ColorConvertingMaps at: srcIndex. - (mapsForSourceAndDest _ mapsForSource at: dstIndex) ifNil: [ - mapsForSourceAndDest _ mapsForSource at: dstIndex put: Dictionary new ]. - - map _ mapsForSourceAndDest at: targetColor ifAbsentPut: [ - Color - computeColorConvertingMap: targetColor - from: sourceDepth - to: destDepth - keepSubPixelAA: keepSubPix ]. - - ^ map! ! -!GrafPort methodsFor: 'private' stamp: 'jmv 4/17/2014 16:57' prior: 50349617! - setRuleAndMapFor: sourceDepth foregroundColor: foregroundColor - - | targetColor destDepth | - destDepth _ destForm depth. - halftoneForm _ nil. "Don't use fillColor. Use a more powerful ColorMap" - - sourceDepth = 1 ifTrue: [ - self combinationRule: Form paint. - "Set up color map for a different source depth (color font)" - "Uses caching for reasonable efficiency" - colorMap _ self cachedFontColormapFrom1BitTo: destDepth. - colorMap at: 1 put: (destForm pixelValueFor: Color transparent). - colorMap at: 2 put: (destForm pixelValueFor: foregroundColor) ] - - ifFalse: [ - "Enable subpixel rendering if requested, but never for translucent text: - This technique always draws opaque text. This could be added, by using an extra colormap for the rgbMul phase... - So far, no need arised for doing so." - (sourceDepth > 8 and: [ - Preferences subPixelRenderFonts and: [ foregroundColor = Color black or: [ - Preferences subPixelRenderColorFonts and: [ foregroundColor isOpaque ]]]]) ifTrue: [ - destDepth > 8 ifTrue: [ - "rgbMul is equivalent to component alpha blend if text is black (only faster, hehe)" - self combinationRule: 37. "rgbMul" - colorMap _ (foregroundColor ~= Color black or: [ - destDepth = 32 and: [ destForm ~~ Display or: [Preferences properDisplayAlphaForFonts] ]]) ifTrue: [ - "rgbMul / rgbAdd IS component alpha blend for any color of text (neat trick, eh!!)" - "This colorMap is to be used on the second pass with rule 20 (rgbAdd) - See #displayString:from:to:at:strikeFont:color:" - "Note: In 32bpp, if we want the correct alpha in the result, we need the second pass, as the destination could have transparent pixels, - and we need to add to the alpha channel" - self colorConvertingMap: foregroundColor from: sourceDepth to: destDepth keepSubPixelAA: true]] - ifFalse: [ - self combinationRule: 25. "Paint" - targetColor _ foregroundColor = Color black ifFalse: [ foregroundColor ]. - colorMap _ self colorConvertingMap: targetColor from: sourceDepth to: destDepth keepSubPixelAA: true]] - ifFalse: [ - "Do not use rule 34 for 16bpp display. TTCFont uses it, but it builds a glyphs cache for each color used!!" - self combinationRule: (destDepth = 32 ifTrue: [34 "alphaBlendScaled"] ifFalse: [25 "Paint"]). - colorMap _ self colorConvertingMap: foregroundColor from: sourceDepth to: destDepth keepSubPixelAA: false]]! ! -!Rectangle methodsFor: 'transforming' stamp: 'jmv 9/24/2013 22:36' prior: 50350830! - newRectFrom: newRectBlock - "Track the outline of a new rectangle until mouse button changes. - newFrameBlock produces each new rectangle from the previous" - | rect newRect buttonStart buttonNow aHand delay | - delay _ Delay forMilliseconds: 10. - buttonStart _ buttonNow _ Sensor isAnyButtonPressed. - rect _ self. - Display border: rect width: 2 rule: Form reverse fillColor: Color gray. - [buttonNow == buttonStart] whileTrue: - [delay wait. - buttonNow _ Sensor isAnyButtonPressed. - newRect _ newRectBlock value: rect. - newRect = rect ifFalse: - [Display border: rect width: 2 rule: Form reverse fillColor: Color gray. - Display border: newRect width: 2 rule: Form reverse fillColor: Color gray. - rect _ newRect]]. - Display border: rect width: 2 rule: Form reverse fillColor: Color gray. - " pay the price for reading the sensor directly ; get this party started " - aHand _ self runningWorld activeHand. - aHand - newMouseFocus: nil; - flushEvents. - Sensor processSensorEvent: Sensor createMouseEvent discardingMouseEvents: false. - ^ rect! ! -!StrikeFont methodsFor: 'emphasis' stamp: 'jmv 4/10/2015 23:21' prior: 50350866! - makeBoldGlyphs - "Make a bold set of glyphs with same widths by ORing 1 bit to the right - (requires at least 1 pixel of intercharacter space)" - | g bonkForm | - g _ glyphs copy. - bonkForm _ (Form extent: 1@16) fillBlack offset: -1@0. - self bonk: g with: bonkForm. - glyphs depth = 1 ifTrue: [ - g copyBits: g boundingBox from: g at: (1@0) - clippingBox: g boundingBox rule: Form under ] - ifFalse: [ - 0 to: g width - 2 do: [ :x | 0 to: g height-1 do: [ :y | - (glyphs colorAt: x@y) = Color white ifFalse: [ - g colorAt: x+1@y put: - ((glyphs colorAt: x+1@y) = Color white - ifTrue: [glyphs colorAt: x@y] - ifFalse: [Color black])]]]]. - glyphs _ g. - self isSynthetic: true! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 9/2/2016 11:03:22' prior: 50350891! - makeControlCharsVisible - | glyph | - self characterToGlyphMap. - glyph _ self glyphAt: (Character space). - glyph border: glyph boundingBox width: 1 fillColor: Color blue. - self glyphAt: (Character numericValue: 134) put: glyph. - - "Keep tab(9), lf(10), cr(13) and space(32) transparent or whatever the user chose" - #(0 1 2 3 4 5 6 7 8 11 12 14 15 16 17 18 19 20 21 22 23 24 25 26 27) - do: [ :ascii | - characterToGlyphMap at: ascii + 1 put: 134 ]! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 9/2/2016 11:03:27' prior: 50350908! - makeCrVisible - | glyph | - self characterToGlyphMap. - glyph _ self glyphAt: (Character numericValue: 182). - glyph border: glyph boundingBox width: 1 fillColor: Color blue. -" glyph _ glyph reverse." - self glyphAt: (Character numericValue: 133) put: glyph. - characterToGlyphMap at: 14 put: 133! ! -!StrikeFont methodsFor: 'glyphs' stamp: 'jmv 9/2/2016 11:03:31' prior: 50350920! - makeLfVisible - | glyph | - self characterToGlyphMap. - glyph _ self glyphAt: (Character numericValue: 163). - glyph border: glyph boundingBox width: 1 fillColor: Color blue. -" glyph _ glyph reverse." - self glyphAt: (Character numericValue: 132) put: glyph. - characterToGlyphMap at: 11 put: 132! ! -!Morph methodsFor: 'accessing' stamp: 'jmv 8/21/2012 20:40' prior: 50350932! - color - - ^ Color blue! ! -!Morph methodsFor: 'drawing' stamp: 'jmv 4/14/2015 08:53' prior: 50350936! - drawOn: aCanvas - "A canvas is already set with a proper transformation from our coordinates to those of the Canvas target." - aCanvas - fillRectangle: self morphLocalBounds - color: Color blue! ! -!RectangleLikeMorph methodsFor: 'initialization' stamp: 'jmv 8/21/2012 18:46' prior: 50350946! - defaultColor - ^ Color orange! ! -!BorderedRectMorph methodsFor: 'initialization' stamp: 'jmv 8/17/2014 21:28' prior: 50350950! - defaultBorderColor - "answer the default border color/fill style for the receiver" - ^ Color gray! ! -!PasteUpMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:35' prior: 50350956! - defaultBorderColor - "answer the default border color/fill style for the receiver" - ^ Color - r: 0.861 - g: 1.0 - b: 0.722! ! -!PasteUpMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:29' prior: 50350963! - defaultColor - "answer the default color/fill style for the receiver" - ^ Color - r: 0.8 - g: 1.0 - b: 0.6! ! -!PasteUpMorph methodsFor: 'world menu' stamp: 'jmv 11/10/2013 19:32' prior: 50350970! - findWindow: evt - "Present a menu names of windows and naked morphs, and activate the one that gets chosen. Collapsed windows appear below line, expand if chosen; naked morphs appear below second line; if any of them has been given an explicit name, that is what's shown, else the class-name of the morph shows; if a naked morph is chosen, bring it to front and have it don a halo." - | menu expanded collapsed nakedMorphs | - menu _ MenuMorph new. - expanded _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed not ]. - collapsed _ SystemWindow windowsIn: self satisfying: [ :w | w isCollapsed ]. - nakedMorphs _ self submorphsSatisfying: [ :m | - (m is: #SystemWindow) not ]. - expanded isEmpty & (collapsed isEmpty & nakedMorphs isEmpty) ifTrue: [ ^ Smalltalk beep ]. - (expanded asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #activateAndForceLabelToShow. - w canDiscardEdits ifFalse: [ menu lastItem color: Color red ]]. - expanded isEmpty | (collapsed isEmpty & nakedMorphs isEmpty) ifFalse: [ menu addLine ]. - (collapsed asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #expand. - w canDiscardEdits ifFalse: [ menu lastItem color: Color red ]]. - nakedMorphs isEmpty ifFalse: [ menu addLine ]. - (nakedMorphs asArray sort: [ :w1 :w2 | - w1 label caseInsensitiveLessOrEqual: w2 label ]) do: [ :w | - menu - add: w label - target: w - action: #comeToFrontAndAddHalo ]. - menu addTitle: 'find window'. - menu popUpInWorld: self! ! -!EllipseMorph methodsFor: 'visual properties' stamp: 'ar 6/25/1999 11:14' prior: 50351024! - defaultColor - "Return the default fill style for the receiver" - ^Color yellow! ! -!PluggableMorph methodsFor: 'initialization' stamp: 'jmv 8/6/2014 09:15' prior: 50351030! - defaultColor - "answer the default color/fill style for the receiver" - ^ Color lightGray! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 9/9/2012 23:50' prior: 50351036! - drawRoundGradientLookOn: aCanvas - | r colorForButton rect bottomFactor topFactor | - - self isPressed - ifFalse: [ - topFactor _ Theme current buttonGradientTopFactor. - bottomFactor _ Theme current buttonGradientBottomFactor. - self mouseIsOver - ifTrue: [ - colorForButton _ Color h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ - colorForButton _ color ]] - ifTrue: [ - topFactor _ Theme current buttonGradientBottomFactor. - bottomFactor _ Theme current buttonGradientTopFactor. - colorForButton _ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - Theme current useButtonGradient - ifTrue: [ - rect _ (0@0 extent: extent) insetBy: 1@3. - aCanvas - roundRect: rect - color: colorForButton - radius: r - gradientTop: topFactor - gradientBottom: bottomFactor - gradientHeight: Theme current buttonGradientHeight ] - ifFalse: [ - rect _ (0@0 extent: extent) insetBy: 1@3. - aCanvas roundRect: rect color: colorForButton radius: r ] - ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawEmbossedLabelOn: aCanvas ] - ifFalse: [ self drawRegularLabelOn: aCanvas ]! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 4/12/2012 22:37' prior: 50351077! - iconColor - - ^ self isPressed - ifTrue: [ Color gray: 0.75 ] - ifFalse: [ - self mouseIsOver - ifTrue: [ Color gray: 0.75 ] - ifFalse: [ Color white ]].! ! -!PluggableButtonMorph class methodsFor: 'example' stamp: 'jmv 1/4/2013 13:31' prior: 50351086! - example - " - PluggableButtonMorph example openInWorld - " - - | s1 s2 s3 b1 b2 b3 row | - s1 _ Switch new. - s2 _ Switch new turnOn. - s3 _ Switch new. - s2 onAction: [s3 turnOff]. - s3 onAction: [s2 turnOff]. - b1 _ (PluggableButtonMorph model: s1 stateGetter: #isOn action: #switch) label: 'S1'. - b2 _ (PluggableButtonMorph model: s2 stateGetter: #isOn action: #turnOn) label: 'S2'. - b3 _ (PluggableButtonMorph model: s3 stateGetter: #isOn action: #turnOn) label: 'S3'. - b1 color: Color lightRed. - b2 color: Color lightRed. - b3 color: Color lightRed. - row _ LayoutMorph newRow - addMorphs: (Array with: b1 with: b2 with: b3); - morphExtent: 120@35. - ^ row -! ! -!TextModelMorph methodsFor: 'drawing' stamp: 'cbr 10/10/2012 23:04' prior: 50351110! - drawOn: aCanvas - "Include a thin red inset border for unaccepted edits, or, if the unaccepted edits are known to conflict with a change made somewhere else to the same method (typically), put a thick red frame" - - - | bw bc | - - self flag: #todo. "Integrate this method with the Theme system. --cbr" - - - super drawOn: aCanvas. - bw _ Preferences focusIndicatorWidth. - bc _ nil. - self wantsFrameAdornments ifTrue: [ - model refusesToAccept - ifTrue: [ "Put up feedback showing that code cannot be submitted in this state" - bc _ Color tan] - ifFalse: [ - self textMorph hasEditingConflicts - ifTrue: [ - bw _ 3. - bc _ Color red ] - ifFalse: [ - self textMorph hasUnacceptedEdits - ifTrue: [ - bc _ Color red]]]]. - - (drawKeyboardFocusIndicator and: [ self textMorph hasKeyboardFocus ]) ifTrue: [ - bc ifNil: [ - bc _ Theme current focusIndicator ]] - ifFalse: [ - bc ifNotNil: [ - bc _ bc alphaMixed: 0.4 with: Color white ]]. - bc ifNotNil: [ - aCanvas frameRectangle: self focusIndicatorRectangle borderWidth: bw color: bc ]! ! -!SystemWindow methodsFor: 'initialization' stamp: 'cbr 11/7/2010 18:58' prior: 50351147! - defaultColor - "answer the default color/fill style for the receiver" - ^ Color white! ! -!SystemWindow methodsFor: 'menu' stamp: 'jmv 6/7/2013 23:23' prior: 50351153! - setWindowColor: incomingColor - | existingColor aColor | - incomingColor ifNil: [^ self]. "it happens" - aColor _ incomingColor asNontranslucentColor. - aColor = Color black ifTrue: [^ self]. - existingColor _ self widgetsColor. - existingColor ifNil: [^ Smalltalk beep]. - self widgetsColor: aColor. - self redrawNeeded! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'KenD 8/27/2015 14:39' prior: 50351166! - buildMorphicWindow - " - CodePackageListWindow open: CodePackageList new - " - | dirtyFlags names fileNames upperRow description summary backColor labelBackground textHeigth | - backColor := self textBackgroundColor. - labelBackground := Theme current background. - textHeigth := AbstractFont default height. - - dirtyFlags := PluggableListMorph - model: model - listGetter: #packageDirtyFlags - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - dirtyFlags color: backColor. - dirtyFlags := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorph: (StringMorph new contents: ' Unsaved?') fixedHeight: textHeigth; - addMorphUseAll: dirtyFlags. - - names := PluggableListMorph - model: model - listGetter: #packageNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - names color: backColor. - names := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorph: (StringMorph new contents: ' Package Name') fixedHeight: textHeigth; - addMorphUseAll: names. - - fileNames := PluggableListMorph - model: model - listGetter: #packageFullNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - fileNames color: backColor. - fileNames := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorph: (StringMorph new contents: ' File Name') fixedHeight: textHeigth; - addMorphUseAll: fileNames. - - upperRow := LayoutMorph newRow. - upperRow - addMorph: dirtyFlags proportionalWidth: 0.13; - addAdjusterAndMorph: names proportionalWidth: 0.27; - addAdjusterAndMorph: fileNames proportionalWidth: 0.6. - - description := TextModelMorph - textProvider: model - textGetter: #description - textSetter: #description:. - - summary := TextModelMorph - textProvider: model - textGetter: #summary. - - self layoutMorph - addMorph: upperRow proportionalHeight: 0.5; - addAdjusterAndMorph: self buildButtonPane proportionalHeight: 0.1; - addAdjusterAndMorph: summary proportionalHeight: 0.18; - addAdjusterAndMorph: description proportionalHeight: 0.22; - addAdjusterAndMorph: self buildRequirementsPane proportionalHeight: 0.2. - self setLabel: 'Installed Packages'! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'len 5/27/2016 21:51' prior: 50351242! - buildRequirementsPane - - | requirements deleteReqButton "editReqButton" reqLayout buttonLayout | - requirements := PluggableListMorph - model: (PackageRequirementsList fromCodePackageList: model) - listGetter: #requirementsStrings - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - requirements color: Theme current textPane. - - deleteReqButton := PluggableButtonMorph - model: requirements model - action: #deleteSelectedRequirement - label: 'delete'. - deleteReqButton color: self widgetsColor. - - buttonLayout := LayoutMorph newColumn. - buttonLayout addMorph: deleteReqButton - layoutSpec: (LayoutSpec - proportionalWidth: 1.0 - proportionalHeight: 1.0 - minorDirectionPadding: #top); - color: self widgetsColor quiteWhiter. - - model when: #changed: send: #updateRequirementsFromPackageList to: requirements model. - self when: #changed: send: #updateRequirementsFromPackageList to: requirements model. - requirements model when: #changed: send: #verifyContents to: requirements. - self when: #changed: send: #verifyContents to: requirements. - - reqLayout := LayoutMorph newRow. - ^ reqLayout - doAdoptWidgetsColor; - addMorph: requirements - layoutSpec: (LayoutSpec - proportionalWidth: 0.9 - proportionalHeight: 1.0 - minorDirectionPadding: #left); - addMorph: buttonLayout - layoutSpec: (LayoutSpec - proportionalWidth: 0.1 - proportionalHeight: 1.0 - minorDirectionPadding: #right); - color: Color transparent; - yourself - ! ! -!CodeWindow methodsFor: 'updating' stamp: 'jmv 9/2/2013 10:25' prior: 50351293! - decorateForInheritance - "Check to see if the currently-viewed method has a super send or an override, and if so, change screen feedback, unless the #decorateBrowserButtons says not to." - - | cm aColor aButton flags buttonColor | - (aButton _ self inheritanceButton) ifNil: [^ self]. - buttonColor _ self buttonColor. - - Preferences decorateBrowserButtons - ifFalse: [ ^aButton color: buttonColor ]. - cm _ model currentCompiledMethod. - (cm is: #CompiledMethod) - ifFalse: [ ^aButton color: buttonColor ]. - - flags _ 0. - model isThisAnOverride ifTrue: [ flags _ flags bitOr: 4 ]. - cm sendsToSuper ifTrue: [ flags _ flags bitOr: 2 ]. - model isThereAnOverride ifTrue: [ flags _ flags bitOr: 1 ]. - aColor _ { - - "This is NOTan override. There is no super implementation." - buttonColor. "no sends to super. there is not override in any subclass" - Color tan. "no sends to super. there is an override in some subclass" - Color red. "sends to super. there is no override in any subclass. Error: no super to call (or calls super with a different message)" - Color red. "sends to super. there is an override in some subclass. Error: no super to call (or calls super with a different message)" - - "This is an override. There is some super implementation" - Color red muchLighter. "doesn't have sub; has super but doesn't call it" - Color r: 0.94 g: 0.823 b: 0.673. "has sub; has super but doesn't call it" - Color green muchLighter. "doesn't have sub; has super and callsl it" - Color blue muchLighter. "has sub; has super and callsl it" - - } at: flags + 1. - aButton color: aColor! ! -!ChangeSorterWindow methodsFor: 'GUI building' stamp: 'DM 8/22/2015 12:34' prior: 50351347! - buildMorphicWindow - "Add a set of change sorter views to the given top view offset by the given amount. To create a single change sorter, call this once with an offset of 0@0. To create a dual change sorter, call it twice with offsets of 0@0 and 0.5@0." - - | dirtyFlags changeSetList classList messageList upperPanes backColor labelBackground | - backColor _ self textBackgroundColor. - labelBackground _ Theme current background. - model myChangeSet ifNil: [ - self flag: #ojo. "Or whatever was last changed, or is top of list, or whatever" - model myChangeSet: ChangeSet changeSetForBaseSystem ]. - - dirtyFlags _ PluggableListMorph - model: model - listGetter: #changeSetDirtyFlags - indexGetter: nil - indexSetter: nil. - dirtyFlags color: backColor. - dirtyFlags _ LayoutMorph newColumn - color: Theme current background; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: ' Unsaved?'); - addMorphUseAll: dirtyFlags. - - changeSetList _ (PluggableListMorphByItem - model: model - listGetter: #changeSetList - indexGetter: #currentCngSet - indexSetter: #showChangeSetNamed: - mainView: self - menuGetter: #changeSetMenu - keystrokeAction: #changeSetListKey:from:) - autoDeselect: false. - changeSetList color: backColor. - changeSetList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: 'Change Set name'); - addMorphUseAll: changeSetList. - - classList _ PluggableListMorphByItem - model: model - listGetter: #classList - indexGetter: #currentClassName - indexSetter: #currentClassName: - mainView: self - menuGetter: #classListMenu - keystrokeAction: #classListKey:from:. - classList color: backColor. - classList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: 'Classes'); - addMorphUseAll: classList. - - upperPanes _ LayoutMorph newRow. - upperPanes - addMorph: dirtyFlags proportionalWidth: 0.13; - addAdjusterAndMorph: changeSetList proportionalWidth: 0.47; - addAdjusterAndMorph: classList proportionalWidth: 0.4. - - messageList _ PluggableListMorphByItem - model: model - listGetter: #messageList - indexGetter: #currentSelector - indexSetter: #currentSelector: - mainView: self - menuGetter: #messageMenu - keystrokeAction: #messageListKey:from:. - messageList color: backColor. - messageList _ LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorphKeepMorphHeight: (StringMorph new contents: 'Methods'); - addMorphUseAll: messageList. - - self layoutMorph - addMorph: upperPanes proportionalHeight: 0.25; - addAdjusterAndMorph: messageList proportionalHeight: 0.2; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.55. - - self setLabel: model labelString! ! -!PreDebugWindow methodsFor: 'GUI building' stamp: 'HAW 1/12/2017 18:47:35' prior: 50351445! - buttonRowForPreDebugWindow: aDebugger - | row aButton triads buttons | - buttons _ OrderedCollection new. - triads _ OrderedCollection withAll: self preDebugButtonSpec. - aDebugger shouldBeAbleToCreateMethod ifTrue: [ triads add: { 'Create'. #createMethod. 'create the missing method' }]. - - triads do: [ :triad | - aButton _ PluggableButtonMorph new model: self. - aButton label: triad first. - aButton action: triad second. - aButton setBalloonText: triad third. - buttons add: aButton]. - - row _ LayoutMorph newRow. - row doAdoptWidgetsColor. - row color: Color transparent. - row separation: 1. - row addMorphs: buttons. - ^row! ! -!TestRunnerWindow methodsFor: 'constants' stamp: 'jmv 4/16/2011 13:57' prior: 50351468! - runButtonColor - ^ Color green lighter duller! ! -!ProgressBarMorph methodsFor: 'initialization' stamp: 'jmv 12/2/2011 10:52' prior: 50351473! - defaultColor - ^Color white! ! -!ProgressBarMorph methodsFor: 'initialization' stamp: 'jmv 12/2/2011 10:53' prior: 50351477! - initialize - super initialize. - progressColor _ Color gray. - value _ 0.0! ! -!MenuMorph methodsFor: 'construction' stamp: 'len 11/16/2015 02:52' prior: 50351483! -addStayUpIcons - | closeBox pinBox w | - Preferences optionalButtons ifFalse: [ ^self ]. - (self valueOfProperty: #hasStayUpIcons ifAbsent: [ false ]) - ifTrue: [ - self removeProperty: #needsStayUpIcons. - ^self ]. - titleMorph ifNil: [ - "Title not yet there. Flag ourself, so this method is called again when adding title." - self setProperty: #needsStayUpIcons toValue: true. - ^ self]. - closeBox _ PluggableButtonMorph model: self action: #delete. - closeBox icon: Theme current closeIcon; color: Color transparent. - pinBox _ PluggableButtonMorph model: self action: #stayUp. - pinBox icon: Theme current pushPinIcon; color: Color transparent. - w _ (titleMorph hasSubmorphs ifTrue: [ titleMorph firstSubmorph morphWidth ] ifFalse: [ 0 ]) + 60. - self addMorphFront: - (LayoutMorph newRow - "Make room for buttons" - morphExtent: w @ (titleMorph morphHeight max: 19); - color: Color transparent; - addMorph: closeBox fixedWidth: 20; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedWidth: 4; - addMorph: titleMorph proportionalWidth: 1; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedWidth: 4; - addMorph: pinBox fixedWidth: 20). - - self setProperty: #hasStayUpIcons toValue: true. - self removeProperty: #needsStayUpIcons! ! -!MenuMorph methodsFor: 'keyboard control' stamp: 'jmv 6/8/2014 20:32' prior: 50351526! - displayFiltered: evt - | matchStr allItems isMatch matches feedbackMorph | - matchStr _ self valueOfProperty: #matchString. - allItems _ self submorphs select: [ :m | - m is: #MenuItemMorph ]. - matches _ allItems select: [ :m | - isMatch _ matchStr isEmpty or: [ - m contents - includesSubstring: matchStr - caseSensitive: false ]. - m isEnabled: isMatch. - isMatch ]. - feedbackMorph _ self valueOfProperty: #feedbackMorph. - feedbackMorph ifNil: [ - feedbackMorph _ StringMorph new color: Color veryDarkGray. - self addMorphBack: feedbackMorph lock position: (0@ -20). - self - setProperty: #feedbackMorph - toValue: feedbackMorph ]. - feedbackMorph contents: '<' , matchStr , '>'. - matchStr isEmpty ifTrue: [ - feedbackMorph delete. - self removeProperty: #feedbackMorph ]. - matches notEmpty ifTrue: [ - self selectItem: matches first ]! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'jmv 4/14/2016 15:10' prior: 50351556! - drawOn: aCanvas - | rectangle w y0 h y1 y2 scrollbarThickness | - aCanvas frameAndFillRectangle: (0@0 extent: extent) fillColor: self color borderWidth: borderWidth borderColor: borderColor. - y0 _ 1. - w _ extent x-2. - scrollbarThickness _ ScrollBar scrollbarThickness. - completer entryCount > self class itemsPerPage ifTrue: [ - w _ w - scrollbarThickness. - aCanvas - frameRectangle: (extent x - scrollbarThickness@0 - extent: scrollbarThickness @ extent y) - borderWidth: 1 - color: borderColor. - aCanvas - image: (BitBltCanvas arrowOfDirection: #up size: scrollbarThickness) - at: self upButtonPosition. - aCanvas - image: (BitBltCanvas arrowOfDirection: #down size: scrollbarThickness) - at: self downButtonPosition. - h _ extent y - (2 * scrollbarThickness). - y1 _ (1.0 * self firstVisible-1 / completer entryCount * h) ceiling + y0 + scrollbarThickness-1. - y2 _ (1.0 * self lastVisible / completer entryCount * h) floor + y0 + scrollbarThickness -1. - aCanvas - fillRectangle: (extent x - scrollbarThickness+2@y1 corner: extent x-2 @ y2) - color: Color veryLightGray ]. - self firstVisible - to: self lastVisible - do: [ :index | - rectangle _ 1@y0 extent: w@self class itemHeight. - index = self selected - ifTrue: [ - aCanvas fillRectangle: rectangle color: (Theme current listHighlightFocused: true) ]. - aCanvas - drawString: (completer entries at: index) asString - at: rectangle topLeft - font: self class listFont - color: Theme current text. - y0 _ y0 + self itemHeight ]! ! -!AutoCompleterMorph methodsFor: 'initialization' stamp: 'jmv 12/2/2011 10:09' prior: 50351607! - defaultBorderColor - ^ Color gray! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 9/9/2012 23:59' prior: 50351611! - drawOn: aCanvas - "Draw the hand itself (i.e., the cursor)." - "This method is only called when we are carrying morphs around..." - aCanvas - stencil: Cursor move - at: 0@0 - color: Color black! ! -!ImageMorph methodsFor: 'accessing' stamp: 'jmv 3/14/2011 09:15' prior: 50351620! - color: aColor - super color: aColor. - (image depth = 1 and: [aColor is: #Color]) ifTrue: [ - image colors: {Color transparent. aColor}. - self redrawNeeded]! ! -!MenuItemMorph methodsFor: 'accessing' stamp: 'jmv 3/13/2009 10:04' prior: 50351629! - isEnabled: aBoolean - - isEnabled = aBoolean ifTrue: [^ self]. - isEnabled _ aBoolean. - self color: (aBoolean ifTrue: [Color black] ifFalse: [Color gray]). -! ! -!MenuItemMorph methodsFor: 'private' stamp: 'jmv 9/9/2012 23:55' prior: 50351637! - offImage - "Return the form to be used for indicating an '' marker" - | form | - form _ Form extent: (self fontToUse ascent-2) asPoint depth: 16. - form getCanvas - frameAndFillRectangle: form boundingBox fillColor: (Color gray: 0.9) - borderWidth: 1 borderColor: Color black. - ^form! ! -!MenuItemMorph methodsFor: 'private' stamp: 'jmv 9/9/2012 23:55' prior: 50351649! - onImage - "Return the form to be used for indicating an '' marker" - | form | - form _ Form extent: (self fontToUse ascent-2) asPoint depth: 16. - form getCanvas - frameAndFillRectangle: form boundingBox fillColor: (Color gray: 0.8) - borderWidth: 1 borderColor: Color black; - fillRectangle: (form boundingBox insetBy: 2) color: Color black. - ^form! ! -!LayoutMorph methodsFor: 'accessing' stamp: 'jmv 12/1/2015 09:53' prior: 50351663! - adoptWidgetsColor: paneColor - super adoptWidgetsColor: paneColor. - doAdoptWidgetsColor - ifTrue: [ self color: (Theme current buttonColorFrom: paneColor) ] - ifFalse: [ self color: Color transparent ]! ! -!LayoutMorph methodsFor: 'initialization' stamp: 'jmv 8/17/2014 21:38' prior: 50351673! - defaultColor - ^Color gray! ! -!LayoutMorph class methodsFor: 'instance creation' stamp: 'jmv 4/3/2011 22:59' prior: 50351677! - initializedInstance - "Answer a row by default so the 'new morph' menu doesn't fail..." - ^self newRow color: (Color red alpha: 0.2)! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/5/2015 10:57' prior: 50351684! - example1 -" - self example1 -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example1. -pane color: Color red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addMorph: (BorderedRectMorph new color: (Color blue); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addMorph: (BorderedRectMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 20). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #G) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8); - addMorph: (BorderedRectMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (BorderedRectMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -pane morphPosition: 150@130 extent: 400@300. -pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/12/2015 16:42' prior: 50351751! - example10 -" - self example10 openInWorld -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example10. -pane color: Color red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Color blue); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 20). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #G) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8); - addMorph: (BorderedRectMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (BorderedRectMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -^ pane! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/5/2015 10:55' prior: 50351819! - example11 -" - self example11 -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example11. -pane color: Color red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Color blue); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addAdjusterMorph; - addMorph: (BorderedRectMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 20). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #G) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8); - addMorph: (BorderedRectMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (BorderedRectMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -pane morphPosition: 150@130 extent: 400@300. -pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/5/2015 11:08' prior: 50351889! - example13 - " - self example13 - " - | pane row innerRow | -pane _ (LayoutMorph newColumn separation: 5) name: #example13. - pane color: Color red. - row _ (LayoutMorph newRow separation: 5) name: #Row. - innerRow _ (LayoutMorph newRow separation: 5) name: #InnerRow; - color: Color red. - innerRow - addMorph: (BorderedRectMorph new name: #Box1) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (BorderedRectMorph new name: #Box2) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (BorderedRectMorph new name: #Bar) - layoutSpec: (LayoutSpec proportionalWidth: 1.0 fixedHeight: 10). - row - color: (Color h: 270 s: 0.2 v: 0.6); - addMorph: innerRow - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 30 minorDirectionPadding: #center); - addMorph: LayoutAdjustingMorph new layoutSpec: (LayoutSpec fixedWidth: 5); - addMorph: (BorderedRectMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #Rect1) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40 minorDirectionPadding: #top); - addMorph: LayoutAdjustingMorph new layoutSpec: (LayoutSpec fixedWidth: 5); - addMorph: (BorderedRectMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #Rect2) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). - pane addMorph: row layoutSpec: (LayoutSpec proportionalHeight: 0.9). - pane morphPosition: 250@130 extent: 400@300. - pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 2/16/2016 13:27' prior: 50351937! - example1b -" -Based on #example1, but using some Morph instead of RectangleLikeMorph -> extent is not adjustable - self example1b -" -| pane row | -pane _ (LayoutMorph newColumn separation: 5) name: #example1. -pane color: Color red. - -row _ LayoutMorph newRow name: #Row1. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 10); - addMorph: (Morph new name: #B); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec proportionalWidth: 0.4); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #D) - layoutSpec: (LayoutSpec proportionalWidth: 0.15); - addMorph: (BorderedRectMorph new color: (Color h: 60 s: 0.6 v: 0.6); name: #E) - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 20). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row2. -row - color: Color red; - addMorph: (BorderedRectMorph new color: (Color blue); name: #F) - layoutSpec: (LayoutSpec proportionalWidth: 0.8); - addMorph: (Morph new name: #G); - addMorph: (BorderedRectMorph new color: (Color h: 30 s: 0.6 v: 0.6); name: #H) - layoutSpec: (LayoutSpec proportionalWidth: 0.2). -pane addMorph: row layoutSpec: LayoutSpec useAll. - -row _ (LayoutMorph newRow separation: 5) name: #Row3. -row - color: Color red; - addMorph: (Morph new name: #J); - addMorph: (BorderedRectMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40); - addMorph: (BorderedRectMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). -pane addMorph: row layoutSpec: (LayoutSpec fixedHeight: 60). -pane morphPosition: 150@130 extent: 400@300. -pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/5/2015 11:25' prior: 50351998! - example2 - " - self example2 - " - | pane row | - pane _ (LayoutMorph newColumn separation: 5) name: #example2. - pane color: Color red. - row _ (LayoutMorph newRow separation: 5) name: #Row. - row - color: (Color h: 270 s: 0.2 v: 0.6); - addMorph: (BorderedRectMorph new color: (Color h: 120 s: 0.6 v: 0.6); name: #A) - layoutSpec: (LayoutSpec fixedWidth: 20 proportionalHeight: 0.8 minorDirectionPadding: #bottom); - addMorph: (BorderedRectMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #B) - layoutSpec: (LayoutSpec proportionalWidth: 0.8 fixedHeight: 40 minorDirectionPadding: #top); - addMorph: (BorderedRectMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #C) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 0.7 minorDirectionPadding: #center). - pane addMorph: row layoutSpec: (LayoutSpec proportionalHeight: 0.9). - pane morphPosition: 200@180 extent: 400@300. - pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 11/18/2015 09:45' prior: 50352030! - example20 -" - self example20 -" -| column | - -column _ (LayoutMorph newColumn separation: 5) name: #Column. -column - color: Color red; - addMorph: (BorderedRectMorph new color: (Color h: 120 s: 0.6 v: 0.6); name: #J) - layoutSpec: (LayoutSpec proportionalWidth: 0.8 fixedHeight: 20); - addMorph: (BorderedRectMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #K) - layoutSpec: (LayoutSpec fixedWidth: 40 proportionalHeight: 0.5); - addMorph: (BorderedRectMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #L) - layoutSpec: (LayoutSpec proportionalWidth: 1.0 fixedHeight: 30). -column morphPosition: 150@130 extent: 400@300. -column openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'dhn 4/5/2015 11:13' prior: 50352053! - example3 - " - self example3 - " - | pane row innerRow | -pane _ (LayoutMorph newColumn separation: 5) name: #example3. - pane color: Color red. - row _ (LayoutMorph newRow separation: 5) name: #Row. - innerRow _ (LayoutMorph newRow separation: 5) name: #InnerRow; - color: Color red. - innerRow - addMorph: (BorderedRectMorph new name: #Box1) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (BorderedRectMorph new name: #Box2) - layoutSpec: (LayoutSpec fixedWidth: 10 fixedHeight: 10); - addMorph: (BorderedRectMorph new name: #Bar) - layoutSpec: (LayoutSpec proportionalWidth: 1.0 fixedHeight: 10). - row - color: (Color h: 270 s: 0.2 v: 0.6); - addMorph: innerRow - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 30 minorDirectionPadding: #center); - addMorph: (BorderedRectMorph new color: (Color h: 90 s: 0.6 v: 0.6); name: #Rect1) - layoutSpec: (LayoutSpec proportionalWidth: 0.5 fixedHeight: 40 minorDirectionPadding: #top); - addMorph: (BorderedRectMorph new color: (Color h: 150 s: 0.6 v: 0.6); name: #Rect2) - layoutSpec: (LayoutSpec fixedWidth: 30 proportionalHeight: 1.0). - pane addMorph: row layoutSpec: (LayoutSpec proportionalHeight: 0.9). - pane morphPosition: 250@130 extent: 400@300. - pane openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 6/8/2014 20:03' prior: 50352096! - example6 - " - Useful example contributed by Ken Dickey - All these should look the same, right? (mmmh this should be a test...) - self example6 - " -| pane rect1 rect2 | -pane _ LayoutMorph newRow separation: 5. "1" -pane addMorph: (StringMorph contents: '1'). - -rect1 := BorderedRectMorph new color: (Color lightOrange); - morphExtent: 20 @ 30. -pane addMorphFront: rect1. -rect2 := BorderedRectMorph new color: (Color cyan); - morphExtent: 20 @ 30. -pane addMorphFront: rect2. -pane - color: Color lightGreen; - morphPosition: 120 @ 50 extent: 180 @ 100; - openInWorld. - -pane _ LayoutMorph newRow separation: 5. "2" -pane addMorph: (StringMorph contents: '2'). - -rect1 := BorderedRectMorph new color: (Color lightOrange); - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 minorDirectionPadding: #center). -pane addMorph: rect1. -rect2 := BorderedRectMorph new color: (Color cyan). -pane addMorph: rect2 - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 minorDirectionPadding: #center). -pane - color: Color lightGreen; - morphPosition: 320 @ 50 extent: 180 @ 100; - openInWorld. - - -pane _ LayoutMorph newRow separation: 5. "3" -pane addMorph: (StringMorph contents: '3'). - -rect1 := BorderedRectMorph new color: (Color lightOrange). -pane addMorph: rect1 - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 minorDirectionPadding: #center). -rect2 := BorderedRectMorph new color: (Color cyan); - layoutSpec: (LayoutSpec fixedWidth: 20 fixedHeight: 30 minorDirectionPadding: #center). -pane addMorph: rect2. -pane - color: Color lightGreen; - morphPosition: 520 @ 50 extent: 180 @ 100; - openInWorld! ! -!LayoutMorph class methodsFor: 'examples' stamp: 'jmv 1/4/2013 13:42' prior: 50352149! - launcherExample - " - self launcherExample - " - | b1 b2 b3 row b4 random buttons | - random _ Random new. - b1 _ PluggableButtonMorph model: [ Date today print ] action: #value label: 'Date'. - b2 _ PluggableButtonMorph model: [ Time now print ] action: #value label: 'Time'. - b3 _ PluggableButtonMorph model: [ SystemVersion current print ] action: #value label: 'Version'. - b4 _ PluggableButtonMorph model: [ random next print ] action: #value label: 'Random'. - buttons _ {b1. b2. b3. b4}. - buttons do: [ :button | - button color: Color lightRed ]. - row _ LayoutMorph newRow - color: Color red; - addMorphs: buttons; - morphExtent: 300 @ 40. - ^ row openInWorld! ! -!ProgressMorph methodsFor: 'initialization' stamp: 'jmv 12/2/2011 10:55' prior: 50352173! - defaultColor - ^Color veryLightGray! ! -!HaloHandleMorph class methodsFor: 'accessing' stamp: 'jmv 11/18/2010 09:44' prior: 50352178! - circleForm: extent - " - CircleForm _ nil - " - | r d l bw center | - (CircleForm isNil or: [ CircleForm extent ~= extent ]) ifTrue: [ - center _ extent -1 * 0.5. - r _ center r * 0.75. - bw _ 1.3. - CircleForm _ Form extent: extent depth: 32. - 0 to: extent y - 1 do: [ :y | - 0 to: extent x - 1 do: [ :x | - d _ (x@y - center) r. - l _ (r - d max: 0.0) min: bw. - CircleForm - colorAt: x @ y - put: (Color white alpha: (l / bw)) - ]]. - ]. - ^CircleForm! ! -!HaloMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:28' prior: 50352196! - defaultColor - "answer the default color/fill style for the receiver" - ^ Color - r: 0.6 - g: 0.8 - b: 1.0! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 5/27/2015 13:42' prior: 50352202! - addHandle: handleSpec - "Add a handle within the halo box as per the haloSpec, and set it up to respond to the given event by sending the given selector to the given recipient. Return the handle." - - | handle aPoint colorToUse form icon | - aPoint _ self - positionIn: haloBox - horizontalPlacement: handleSpec horizontalPlacement - verticalPlacement: handleSpec verticalPlacement. - colorToUse _ Color colorFrom: handleSpec color. - handle _ HaloHandleMorph new color: colorToUse. - self addMorph: handle. - handle morphBoundsInWorld: (Rectangle center: aPoint extent: self class handleSize asPoint). - handleSpec iconSymbol ifNotNil: [ :iconName | - form _ self class icons at: iconName ifAbsent: [self class perform: iconName]. - form ifNotNil: [ - icon _ ImageMorph new - image: form; - color: colorToUse makeForegroundColor; - lock. - handle addMorphFront: icon position: 0@0 ]]. - handle mouseUpSelector: #endInteraction. - handle setBalloonText: handleSpec hoverHelp. - ^handle! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 7/4/2016 22:14' prior: 50352236! - addNameString: aString - "Add a name display centered beneath the bottom of the outer rectangle. Return the handle." - - | nameMorph namePosition nameBackground | - nameBackground _ RectangleLikeMorph new - color: ((target is: #SystemWindow) ifTrue: [target windowColor] ifFalse: [Color lightBlue alpha: 0.9]). - nameMorph _ StringMorph contents: aString. - nameMorph color: Color black. - nameBackground morphExtent: nameMorph morphExtent + 4. - namePosition _ haloBox width - nameMorph morphWidth // 2 @ (haloBox height). - self addMorph: nameBackground position: namePosition - 2. - self addMorph: nameMorph position: namePosition. - ^nameMorph! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 9/22/2012 15:18' prior: 50352259! - doRot: evt with: rotHandle - "Update the rotation of my target if it is rotatable. Keep the relevant command object up to date." - - | degrees | -self revisar. - self flag: #jmvVer2. - evt hand obtainHalo: self. - degrees _ (evt eventPosition - target referencePosition) degrees. - degrees _ degrees - angleOffset degrees. - degrees _ degrees detentBy: 10.0 atMultiplesOf: 90.0 snap: false. - degrees = 0.0 - ifTrue: [rotHandle color: Color lightBlue] - ifFalse: [rotHandle color: Color blue]. - rotHandle submorphsDo: - [:m | m color: rotHandle color makeForegroundColor]. - self removeAllHandlesBut: rotHandle. - - target rotationDegrees: degrees. - - rotHandle morphPositionInWorld: evt eventPosition - (rotHandle morphExtent // 2)! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 9/20/2012 00:01' prior: 50352285! - setDismissColor: evt with: dismissHandle - "Called on mouseStillDown in the dismiss handle; set the color appropriately." - - | colorToUse | - evt hand obtainHalo: self. - colorToUse _ (dismissHandle morphContainsPoint: (dismissHandle internalizeFromWorld: evt eventPosition)) - ifFalse: [ Color red muchLighter ] - ifTrue: [ Color lightGray ]. - dismissHandle color: colorToUse! ! -!InnerListMorph methodsFor: 'initialization' stamp: 'jmv 5/27/2013 09:39' prior: 50352300! - initialize - super initialize. - self color: Color black. - font _ Preferences standardListFont. - listItems _ #(). - selectedRow _ nil. - selectedRows _ Set new. - highlightedRow _ nil! ! -!InnerTextMorph methodsFor: 'drawing' stamp: 'jmv 10/16/2013 19:55' prior: 50352309! - debugDrawLineRectsOn: aCanvas - "Shows where text line rectangles are" - - self textComposition lines do: [ :line | - aCanvas - frameRectangle: line rectangle - borderWidth: 1 - color: Color brown ] -! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/17/2015 15:51' prior: 50352319! - initialize - super initialize. - extent _ 400@300. - color _ Color white. - grid _ 8@6. - gridLineWidth _ 2. - gridColor _ Color black. - selectionColor _ Color red! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'bp 10/11/2015 23:18' prior: 50352328! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - from _ self toGridPoint: localEventPosition. - outlineMorph _ BorderedRectMorph new - borderColor: Color black; - color: Color transparent; - openInWorld; - hide. - self selectTo: localEventPosition! ! -!HoverHelpMorph methodsFor: 'initialization' stamp: 'jmv 9/25/2011 23:12' prior: 50352340! - defaultColor - - ^Color r: 1.0 g: 1.0 b: 0.7! ! -!HoverHelpMorph methodsFor: 'drawing' stamp: 'jmv 12/20/2014 15:09' prior: 50352345! - drawOn: aCanvas - - | r | - r _ self morphLocalBounds. - aCanvas roundRect: r color: self color radius: 4. - aCanvas - textComposition: textComposition - bounds: (r insetBy: 4) - color: Color black - selectionColor: (Theme current textHighlightFocused: false)! ! -!WorldState methodsFor: 'drawing' stamp: 'jmv 3/2/2017 19:40:12' prior: 50352356! - drawInvalidAreasSubmorphs: submorphs - "Redraw the damaged areas of the given canvas and clear the damage list. Return a collection of the areas that were redrawn." - - | initialRectsToRepair currentRectsToRepair newRectsToRepair morphsToDraw rectsForEachMorph thisMorphRects reuse i n morph morphBounds morphClipRect | - - "The simple implementation is slowers as it draws morph areas that will later be covered by other morphs. - But it works, and it is easier to understand. - See en.wikipedia.org/wiki/Painter's_algorithm" - true not ifTrue: [ ^self simpleDrawInvalidAreasSubmorphs: submorphs ]. - - "The response for #invalidRectsFullBounds: can include nils, that should be ignored." - initialRectsToRepair _ damageRecorder invalidRectsFullBounds: world viewBox. - damageRecorder reset. - currentRectsToRepair _ OrderedCollection new. - newRectsToRepair _ OrderedCollection withAll: initialRectsToRepair. - morphsToDraw _ OrderedCollection new. - rectsForEachMorph _ OrderedCollection new. - thisMorphRects _ OrderedCollection new. - n _ submorphs size. - i _ 1. - - "The idea here is to iterate morphs front to back, i.e. first the ones on top. - For each morph, record the rectangles it affects. And if a morph is opaque, remove the area behind it from the list of rectangles to be repaired. - This means, for example, that morphs completely covered might even not be redrawn. - this is a huge performance gain when there are many morphs on screen, especially if there are more than ten open windows, and Theme uses opaque colors. - See 'A reverse painter's algorithm' at en.wikipedia.org/wiki/Painter's_algorithm" - [ i <= n and: [ newRectsToRepair notEmpty ]] whileTrue: [ - morph _ submorphs at: i. - morph visible ifTrue: [ - morphBounds _ morph morphFullBoundsInWorld. - reuse _ currentRectsToRepair. - currentRectsToRepair _ newRectsToRepair. - newRectsToRepair _ reuse removeAll. - currentRectsToRepair do: [ :r | - (morphBounds intersects: r) - ifTrue: [ - morphClipRect _ morphBounds intersect: r. - thisMorphRects add: morphClipRect. "We could perhaps try and join adjacent rectangles in this collection..." - morph addPossiblyUncoveredAreasIn: r to: newRectsToRepair ] - ifFalse: [ - newRectsToRepair add: r ]]. - thisMorphRects ifNotEmpty: [ - morphsToDraw add: morph. - rectsForEachMorph add: thisMorphRects. - thisMorphRects _ OrderedCollection new. - ]]. - i _ i + 1 ]. - - "*make this true to flash damaged areas for testing*" - Preferences debugShowDamage ifTrue: [ world fillRects: initialRectsToRepair color: Color gray ]. - - "Draw world background on those areas that were not completely covered by opaque morphs" - i > n ifTrue: [ - newRectsToRepair do: [ :r | - world drawOn: (canvas newClipRect: r) ]]. - - "Now, draw the recorded areas of selected morphs, back to front." - morphsToDraw with: rectsForEachMorph reverseDo: [ :m :xrects | - "Here we could think about merging all xrects into just one call... - This would mean drawing each morph just once. - But that would mean drawing pixels we were not told to. There could be other morphs in that area that are not even being drawn!! - See WorldState class >> #experiment1" -" rr _ nil." - xrects do: [ :r | -" rr _ rr ifNil: [ r ] ifNotNil: [ r quickMerge: rr ]." - (canvas newClipRect: r) fullDraw: m. - ]. -" (canvas newClipRect: rr) fullDraw: m" - "*make this true to flash damaged areas for testing*" - Preferences debugShowDamage2 ifTrue: [ - world flashRects: xrects color: Color random ]. - ]. - - "Answer a list of rectangles to be updated on the Display. - This usually is not performance critical, drawing morphs is slower than just exposing the Display." - "What should we force on Display? Whatever was asked? Each small rect that was updated? A single bigger rect? - Right now, answer whatever was asked... Maybe this could be changed if that enhances performance... - (think of vnc over slow networks)" - ^ initialRectsToRepair! ! -!WorldState class methodsFor: 'sample code' stamp: 'jmv 3/2/2017 19:39:21' prior: 50352482! - experiment1 - "To play with and learn about morphic Display update logic. - Remove the morphs when done!!" - " - WorldState experiment1 - " - | dr morph1 morph2 s w | - morph1 _ RectangleLikeMorph new openInWorld. - morph2 _ RectangleLikeMorph new openInWorld. - morph2 color: Color green. - morph2 morphPosition: 200@800 extent: 50@40. - morph1 morphPosition: 120@720 extent: 220@100. - - w _ self runningWorld. - s _ w instVarNamed: 'worldState'. - dr _ s instVarNamed: 'damageRecorder'. - - dr doFullRepaint. - dr reset; - " recordInvalidRect: (100@700 corner: 400@900);" - recordInvalidRect: (100@700 corner: 150@900); - recordInvalidRect: (300@700 corner: 400@900). - Display fillColor: Color gray. - "Do not draw the area used by the small rectangle, unless it is also drawn!!" - s drawInvalidAreasSubmorphs: {morph1. morph2 }! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 12/20/2014 15:35' prior: 50352511! - drawCurrentAsError - "The morph (or one of its submorphs) had an error in its drawing method." - | r w | - r _ currentMorph morphLocalBounds. - w _ r extent > (50@50) - ifTrue: [ 6 ] - ifFalse: [ 2 ]. - self - frameAndFillRectangle: r - fillColor: Color red - borderWidth: w - borderColor: Color yellow. - self line: r topLeft to: r bottomRight-w width: w color: Color yellow. - self line: r topRight -(w@0) to: r bottomLeft -(0@w)width: w color: Color yellow! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 6/1/2015 13:30' prior: 50352529! - drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - aColor = Color black ifFalse: [ | topColor | - topColor _ aColor alphaMixed: 0.25 with: Color black. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint - font: fontOrNil - color: topColor ]. - aColor = Color white ifFalse: [ | bottomColor | - bottomColor _ aColor alphaMixed: 0.22 with: Color white. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + (0@2) - font: fontOrNil - color: bottomColor ]. - ^self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + (0@1) - font: fontOrNil - color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 11/29/2015 18:01' prior: 50352556! - fillRectangle: aRectangle color: aColor - "Fill the given rectangle." - - aColor isTransparent ifFalse: [ - self - frameAndFillRectangle: aRectangle - fillColor: aColor - borderWidth: 0 - borderColor: Color transparent ]! ! -!BitBltCanvas methodsFor: 'drawing-rectangles' stamp: 'jmv 11/29/2015 18:14' prior: 50352567! -reverseRectangleBorder: r borderWidth: borderWidth - " - Display getCanvas - reverseRectangleBorder: (10@10 extent: 300@200) - borderWidth: 20. - Display forceToScreen - " - | rect | - rect _ currentTransformation displayBoundsOfTransformOf: r. - port - sourceForm: nil; - fillColor: Color gray; - combinationRule: Form reverse; - frameRect: rect borderWidth: borderWidth! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 4/9/2015 09:46' prior: 50352582! - setPaintColor: aColor - "Install a new color used for filling." - | paintColor | - paintColor _ aColor ifNil: [ Color transparent ]. - (paintColor is: #Color) ifFalse: [ - ^self error: 'Cannot install color' ]. - - "Okay, so paintColor really *is* a color" - port sourceForm: nil. - (paintColor isOpaque or: [ self depth < 32]) ifTrue: [ - port fillColor: paintColor. - port combinationRule: Form paint. - ^self ]. - - "BitBlt setup for alpha mapped transfer" - port fillColor: paintColor. - port combinationRule: Form blend! ! -!BitBltCanvas class methodsFor: 'cached forms' stamp: 'jmv 4/17/2015 12:16' prior: 50352602! - steButtonForm: extent - ^self cachedForms - at: { #steButton . extent } - ifAbsentPut: [ - | form canvas | - form _ Form extent: extent depth: 32. - canvas _ form getCanvas. - canvas - roundRect: (0@0 extent: extent) - color: (Color gray: 0.4) - radius: 4. - canvas - roundRect: (1@1 extent: extent-2) - color: Color white - radius: 4 - gradientTop: 1.0 - gradientCenter: 0.73 - gradientBottom: 0.94 - gradient1Height: (extent y-8+1 max: extent y//2). - form]! ! -!BitBltCanvas class methodsFor: 'cached forms' stamp: 'jmv 4/17/2015 12:16' prior: 50352621! - verticalGrayGradient: height gradientTop: gradientTopFactor gradientBottom: gradientBottomFactor - ^self cachedForms - at: { #vertical. height. gradientTopFactor . gradientBottomFactor } - ifAbsentPut: [ - Form - verticalGradient: height - topColor: (Color gray: gradientTopFactor) - bottomColor: (Color gray: gradientBottomFactor) ]! ! -!BitBltCanvas class methodsFor: 'cached arrow forms' stamp: 'jmv 1/7/2015 08:12' prior: 50352635! - buildArrowOfDirection: aSymbolDirection size: finalSizeInteger - "PRIVATE - create an arrow with aSymbolDirectionDirection, - finalSizeInteger and aColor - - aSymbolDirectionDirection = #up, #down. #left or #right - (self buildArrowOfDirection: #down size: 120) display - (self buildArrowOfDirection: #up size: 120) display - " - - | resizeFactor resizedForm f e c bottomMargin topMargin | - resizeFactor _ 4. - e _ finalSizeInteger@finalSizeInteger*resizeFactor. - f _ Form extent: e depth: 32. - c _ Color gray: 0.5. - topMargin _ finalSizeInteger * 3//4. - bottomMargin _ finalSizeInteger * 4//4. - 0 to: e y-1-bottomMargin do: [ :y | - 0 to: e x -1 do: [ :x | - (e x / 2 - 1 - x) abs * 2 + topMargin < y ifTrue: [ - f colorAt: x@y put: c - ] - ] - ]. - resizedForm _ f - magnify: f boundingBox - by: 1 / resizeFactor - smoothing: 4. - - aSymbolDirection == #right ifTrue: [ - resizedForm _ resizedForm rotatedByDegrees: 90 ]. - aSymbolDirection == #down ifTrue: [ - resizedForm _ resizedForm rotatedByDegrees: 180 ]. - aSymbolDirection == #left ifTrue: [ - resizedForm _ resizedForm rotatedByDegrees: 270 ]. - - aSymbolDirection == #up ifFalse: [ - resizedForm _ resizedForm - copy: (resizedForm boundingBox insetBy: (resizedForm width - finalSizeInteger/ 2.0) rounded) ]. - - ^resizedForm! ! -!BitBltCanvas class methodsFor: 'cached arrow forms' stamp: 'jmv 10/9/2014 23:02' prior: 50352679! - buildArrowWith: insideForm borderForm: borderForm - | extent translucentForm color insideSpec borderSpec border background alpha| - " - Display getCanvas - image: (BitBltCanvas buildArrowWith: BitBltCanvas downInsideForm borderForm: BitBltCanvas downBorderForm) - at: 20@20 - Display getCanvas - image: (BitBltCanvas buildArrowWith:BitBltCanvas upInsideForm borderForm: BitBltCanvas upBorderForm) - at: 40@20 - " - extent _ insideForm extent - (1@2). - translucentForm _ Form extent: insideForm extent depth: 32. - 0 to: extent x-1 do: [ :x | - 0 to: extent y-1 do: [ :y | - insideSpec _ insideForm colorAt: x@(y+1). - borderSpec _ borderForm colorAt: x@(y+1). - insideSpec = (Color r: 0.0 g: 0.0 b: 1.0) - ifTrue: [ color _ Color transparent ] - ifFalse: [ - borderSpec = (Color r: 1.0 g: 0.0 b: 0.0) - ifTrue: [ color _ insideSpec ] - ifFalse: [ - border _ x < (extent x//2) - ifTrue: [Color white] - ifFalse: [Color black]. - background _ borderForm colorAt: extent x@(y+1). - alpha _ borderSpec red asFloat - background red / (border red - background red). - color _ border alpha: (alpha min: 1 max: 0) ]]. - translucentForm colorAt: x@y put: color ]]. - ^translucentForm! ! -!Theme methodsFor: 'colors' stamp: 'jmv 11/19/2010 14:06' prior: 50352720! - background - ^ Color r: 0.7 g: 0.72 b: 0.83! ! -!Theme methodsFor: 'colors' stamp: 'jmv 11/23/2010 09:42' prior: 50352724! - buttonColorFrom: aColor - ^ Display depth <= 8 - ifTrue: [ Color transparent ] - ifFalse: [ aColor paler ]! ! -!Theme methodsFor: 'colors' stamp: 'jmv 3/14/2011 08:50' prior: 50352730! - buttonLabel - ^Color gray: 0.18! ! -!Theme methodsFor: 'colors' stamp: 'len 6/9/2016 17:38' prior: 50352734! - errorColor - ^ Color red lighter! ! -!Theme methodsFor: 'colors' stamp: 'len 6/9/2016 17:40' prior: 50352738! - failureColor - ^ Color yellow lighter! ! -!Theme methodsFor: 'colors' stamp: 'len 11/14/2015 02:34' prior: 50352742! - scrollbarButtonColor - ^Color gray: 0.95! ! -!Theme methodsFor: 'colors' stamp: 'len 11/17/2015 23:55' prior: 50352746! - scrollbarColor - ^Color white! ! -!Theme methodsFor: 'colors' stamp: 'len 11/14/2015 02:34' prior: 50352750! - scrollbarSliderShadowColor - ^Color white! ! -!Theme methodsFor: 'colors' stamp: 'len 6/9/2016 17:38' prior: 50352754! - successColor - ^ Color green lighter! ! -!Theme methodsFor: 'colors' stamp: 'cbr 11/7/2010 18:00' prior: 50352758! - text - ^ Color black! ! -!Theme methodsFor: 'colors' stamp: 'jmv 10/16/2013 22:08' prior: 50352762! - textCursor - ^ Display depth <= 2 - ifTrue: [ Color black ] - ifFalse: [ self text ]! ! -!Theme methodsFor: 'colors' stamp: 'jmv 5/30/2011 14:31' prior: 50352768! - textHighlight - "A nice light blue." - " - ^ Color r: 0.71 g: 0.835 b: 1.0 - ^ Color hue: 214 chroma: 0.29 luminance: 0.816 - " - ^Color hue: 204 chroma: 0.29 luminance: 0.77! ! -!Theme methodsFor: 'colors' stamp: 'jmv 11/23/2010 09:58' prior: 50352776! - textHighlightFocused: focused - "A nice light blue." - | textHighlight | - Display depth = 1 ifTrue: [^ Color veryLightGray]. - Display depth = 2 ifTrue: [^ Color gray: 0.87]. - textHighlight _ self textHighlight. - ^focused - ifTrue: [ textHighlight ] - ifFalse: [ self unfocusedTextHighlightFrom: textHighlight ]! ! -!Theme methodsFor: 'colors' stamp: 'cbr 12/6/2010 20:08' prior: 50352789! - windowLabel - ^Color gray: 0.3! ! -!Theme methodsFor: 'menu colors' stamp: 'jmv 5/26/2011 09:07' prior: 50352793! - menu - Display depth <= 2 ifTrue: [^ Color white]. - ^Color r: 0.75 g: 0.75 b: 0.75 alpha: 0.93! ! -!Theme methodsFor: 'menu colors' stamp: 'jmv 11/23/2010 09:45' prior: 50352799! - menuHighlight - ^ Display depth < 8 - ifTrue: [ Color veryLightGray ] - ifFalse: [ self textHighlight ]! ! -!Theme methodsFor: 'menu colors' stamp: 'cbr 11/7/2010 18:28' prior: 50352805! - menuText - ^ Color black! ! -!Theme methodsFor: 'menu colors' stamp: 'jmv 11/28/2010 08:04' prior: 50352809! - menuTitleBar - Display depth = 1 ifTrue: [^ Color white]. - Display depth = 2 ifTrue: [^ Color gray]. - ^ self menu darker! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 4/15/2011 14:59' prior: 50352816! - browser - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Color r: 0.5 g: 0.7 b: 0.4]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 2/14/2013 11:05' prior: 50352823! - debugger - ^Color h: 0.0 s: 0.6 v: 0.7! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 11/23/2010 09:16' prior: 50352827! - defaultWindowColor - ^ Color lightGray! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 11/18/2010 12:44' prior: 50352831! - fileContentsBrowser - ^Color tan duller! ! -!Theme methodsFor: 'tool colors' stamp: 'cbr 12/4/2010 18:44' prior: 50352835! - fileList - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Color r: 0.7 g: 0.55 b: 0.7 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 5/23/2012 19:23' prior: 50352842! - messageNames - - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Color r: 0.53 g: 0.77 b: 0.382 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'cbr 12/4/2010 18:45' prior: 50352849! - messageSet - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Color r: 0.45 g: 0.6 b: 0.85 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 11/18/2010 12:44' prior: 50352856! - object - ^Color white duller! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/28/2012 09:41' prior: 50352860! - packageList - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Color r: 0.63 g: 0.47 b: 0.08 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 11/23/2010 09:17' prior: 50352867! - testRunner - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ (Color r: 0.650 g: 0.753 b: 0.976) duller ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/16/2011 08:15' prior: 50352874! - textEditor - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Color gray: 0.6 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'cbr 12/4/2010 18:45' prior: 50352880! - transcript - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Color r: 0.8 g: 0.6 b: 0.3 ]! ! -!Theme methodsFor: 'tool colors' stamp: 'cbr 12/18/2010 17:56' prior: 50352887! - versionsBrowser - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ (Color r: 0.869 g: 0.753 b: 1.0) duller ]! ! -!Theme methodsFor: 'tool colors' stamp: 'jmv 3/16/2011 08:13' prior: 50352894! - workspace - ^ self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Color h: 60.0 s: 0.73 v: 0.72 ]! ! -!Theme methodsFor: 'widget colors' stamp: 'jmv 5/23/2012 18:49' prior: 50352901! - acceptButton - - ^ self buttonColorFrom: - (self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Color r: 0.2 g: 0.6 b: 0.1 ])! ! -!Theme methodsFor: 'widget colors' stamp: 'jmv 5/23/2012 18:51' prior: 50352909! - cancelButton - - ^ self buttonColorFrom: - (self useUniformColors - ifTrue: [ self defaultWindowColor ] - ifFalse: [ Color r: 0.8 g: 0.2 b: 0.2 ])! ! -!Theme methodsFor: 'widget colors' stamp: 'cbr 10/10/2012 23:36' prior: 50352917! - textPane - ^Color white! ! -!SHTextStylerST80 class methodsFor: 'style table' stamp: 'pb 5/4/2016 17:44' prior: 50352921! - initialTextAttributes - | d element color emphasis attrArray | - d _ IdentityDictionary new. - self styleTable do: [ :each | - element _ each first. - color _ each at: 2 ifAbsent: nil. - color _ color ifNotNil: [ Color colorFrom: color ]. - emphasis _ each at: 3 ifAbsent: nil. - attrArray _ self attributeArrayForColor: color emphasis: emphasis. - attrArray notEmpty ifTrue: [ - d at: element put: attrArray ]]. - ^ d! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3111-ChangeReferencesBackToColor-JuanVuletich-2017Jun19-12h05m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3106] on 19 June 2017 at 11:52:30 am'! -!Colour methodsFor: 'transformations' stamp: 'jmv 6/19/2017 12:10:13' prior: 50352945! - * aNumber - "Answer this color with its RGB multiplied by the given number. " - " - (Colour brown *2) display - " - ^ (Color new - setRed: (self red * aNumber min: 1.0 max: 0.0) - green: (self green * aNumber min: 1.0 max: 0.0) - blue: (self blue * aNumber min: 1.0 max: 0.0)) - alpha: self alpha! ! - -"Postscript: -Leave the line above, and replace the rest of this comment by a useful one. -Executable statements should follow this comment, and should -be separated by periods, with no exclamation points (!!). -Be sure to put any further comments in double-quotes, like this one." - -| all | -all := Colour allInstances. -all elementsForwardIdentityTo: (all collect: [ :c | c * 1 ]). -all := TranslucentColour allInstances. -all elementsForwardIdentityTo: (all collect: [ :c | c * 1 ]).! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3112-MigrateInstancesToColor-JuanVuletich-2017Jun19-11h51m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3111] on 19 June 2017 at 12:11:51 pm'! - -Smalltalk removeClassNamed: #Colour! - -Smalltalk removeClassNamed: #Colour! - -Smalltalk removeClassNamed: #TranslucentColour! - -Smalltalk removeClassNamed: #TranslucentColour! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3113-RemoveColour-JuanVuletich-2017Jun19-12h11m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3113] on 19 June 2017 at 3:22:14 pm'! - -InnerPluggableMorph subclass: #InnerListMorph - instanceVariableNames: 'listItems font selectedRow selectedRows highlightedRow ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #InnerListMorph category: #'Morphic-Views'! -InnerPluggableMorph subclass: #InnerListMorph - instanceVariableNames: 'listItems font selectedRow selectedRows highlightedRow' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! -!InnerListMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 15:21:44' prior: 50360533! - initialize - super initialize. - self color: Color black. - font _ Preferences standardListFont. - listItems _ #(). - selectedRow _ nil. - highlightedRow _ nil! ! -!InnerListMorph methodsFor: 'list management' stamp: 'jmv 6/19/2017 15:21:40' prior: 16855089! - listChanged - "set newList to be the list of strings to display" - listItems _ Array new: self getListSize withAll: nil. - selectedRow _ nil. - self adjustExtent! ! -!InnerListMorph methodsFor: 'private' stamp: 'jmv 6/19/2017 15:21:48' prior: 16855308! - noSelection - selectedRow _ nil. - highlightedRow _ nil! ! - -InnerPluggableMorph subclass: #InnerListMorph - instanceVariableNames: 'listItems font selectedRow highlightedRow' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -!classDefinition: #InnerListMorph category: #'Morphic-Views'! -InnerPluggableMorph subclass: #InnerListMorph - instanceVariableNames: 'listItems font selectedRow highlightedRow' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Views'! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3114-removeAnUnusedIvar-JuanVuletich-2017Jun19-15h21m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3113] on 19 June 2017 at 4:40:20 pm'! -!Object methodsFor: 'private' stamp: 'jmv 6/19/2017 16:14:39' prior: 16882717! - primitiveError: aString - "This method is called when the error handling results in a recursion in - calling on error: or halt or halt:." - - | context emergencyEvaluator lines r | - r _ `10@10` extent: (Display extent -20 min: `700@1000`). - lines _ r height // AbstractFont default height. - emergencyEvaluator _ Transcripter newInFrame: r. - emergencyEvaluator - nextPutAll: '***System error handling failed***'; newLine; - nextPutAll: aString; newLine; - nextPutAll: '-------------------------------'; newLine. - context _ thisContext sender sender. - (30 min: lines - 10) timesRepeat: [context ifNotNil: [emergencyEvaluator print: (context _ context sender); newLine]]. - emergencyEvaluator - nextPutAll: '-------------------------------'; newLine; - nextPutAll: 'Type ''revert'' to revert your last method change.'; newLine; - nextPutAll: 'Type ''exit'' to exit the emergency evaluator.'; newLine. - emergencyEvaluator readEvalPrint! ! -!InputSensor methodsFor: 'private' stamp: 'jmv 6/19/2017 15:53:29' prior: 16856661! - primMousePt - "Primitive. Poll the mouse to find out its position. Return a Point. Fail if - event-driven tracking is used instead of polling. Optional. See Object - documentation whatIsAPrimitive." - - - ^ `0@0`! ! -!EventSensor methodsFor: 'initialization' stamp: 'jmv 6/19/2017 15:48:40' prior: 16839804! - initialize - "Run the I/O process" - mouseButtons _ 0. - mousePosition _ `0@0`. - self setInterruptKey: (interruptKey ifNil: [$. numericValue bitOr: 16r0800 ]). "cmd-." - interruptSemaphore _ (Smalltalk specialObjectsArray at: 31) ifNil: [Semaphore new]. - self flushAllButDandDEvents. - inputSemaphore _ Semaphore new. - hasInputSemaphore _ false. - - self primSetInputSemaphore: (Smalltalk registerExternalObject: inputSemaphore). - self installInterruptWatcher. - self installEventTickler. - self flushAllButDandDEvents. - - "Attempt to discover whether the input semaphore is actually being signaled." - hasInputSemaphore _ false. - inputSemaphore initSignals! ! -!String methodsFor: 'displaying' stamp: 'jmv 6/19/2017 16:12:23' prior: 16917029! - displayOn: aDisplayMedium - "Display the receiver on the given DisplayMedium. 5/16/96 sw" - - self displayOn: aDisplayMedium at: `0 @ 0`! ! -!Bitmap methodsFor: 'as yet unclassified' stamp: 'jmv 6/19/2017 15:45:57' prior: 16787594! - asByteArray - "Faster way to make a byte array from me. - copyFromByteArray:, if receiver is BigEndian makes equal Bitmap. - Assume receiver bytes-in-word mapping is BigEndian: - Most significant bye of first word in self goes to first position in result. - This means that for a BigEndian 8bpp Form, pixels are in the right order in the ByteArray - - Form lena asGrayForm bits asByteArray copyFrom: 1 to: 4. - (Form lena asGrayForm asFormOfDepth: 8) bits asByteArray copyFrom: 1 to: 4. - (0 to: 3) collect: [ :x | ((Form lena asGrayForm colorAt: x@0) luminance * 255) rounded ]. - " - | f bytes hack | - f _ Form extent: 4@self size depth: 8 bits: self. - bytes _ ByteArray new: self size * 4. - hack _ Form new hackBits: bytes. - Smalltalk isLittleEndian ifTrue: [hack swapEndianness]. - hack copyBits: f boundingBox - from: f - at: `0@0` - clippingBox: hack boundingBox - rule: Form over. - - "f displayOn: hack." - ^ bytes! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jmv 6/19/2017 16:12:37' prior: 50335423! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag -"WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " -| activeProc | -activeProc _ Processor activeProcess. -[ - | isARealStartup world reopenTranscript | - self logSapshot: save andQuit: quit. - - reopenTranscript _ false. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | each isInWorld ifTrue: [ each delete. reopenTranscript _ true ]]. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - - - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - - "Cosas que levanto explicitamente abajo" - world _ ProjectX ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "world _ clearAllStateFlag ifFalse: [ ProjectX ui ]." - ProjectX stopUIProcess. - activeProc isTerminated ifFalse: [ - activeProc terminate ]. - - "Clean Globals" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: nil. - Smalltalk closeSourceFiles. Smalltalk at: #SourceFiles put: nil. - Smalltalk allClassesDo: [ :cls | cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ Smalltalk printStuffToCleanOnImageSave ]. - - - "Do image save & quit as apropriate" - Cursor write activateCursor. - save - ifTrue: [ - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - - - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: (DisplayScreen extent: `1024@768` depth: 32). - Smalltalk at: #SourceFiles put: (Array new: 2). - Smalltalk openSourceFiles. - - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - - - ProjectX spawnNewMorphicProcessFor: (world ifNil: [ PasteUpMorph newWorld ]). - - reopenTranscript ifTrue: [ - WorldState addDeferredUIMessage: [ - TranscriptWindow openTranscript ]]. - " - WorldState addDeferredUIMessage: [ - world fullRepaintNeeded ]. - " - - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - WorldState addDeferredUIMessage: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]. - -] forkAt: Processor timingPriority-1 named: 'Startup process'.! ! -!Transcripter methodsFor: 'accessing' stamp: 'jmv 6/19/2017 16:13:36' prior: 50357755! - 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]. - textComposition - setModel: (TextModel withText: c asText); - extentForComposing: frame width-8 @9999. - textComposition composeAll. - d _ textComposition usedHeight - frame height. - d > 0 ifTrue: [ - "Scroll up to keep all contents visible" - cb _ textComposition characterBlockAtPoint: - `0@0` + (0@(d+AbstractFont default height)). - self on: (c copyFrom: cb stringIndex to: c size). - readLimit _ position _ collection size. - ^ self endEntry]. - Display fill: (frame insetBy: -2) fillColor: self black; - fill: frame fillColor: self white. - Display getCanvas - textComposition: textComposition - bounds: (`4@4` + frame topLeft extent: Display extent) - color: Color black - selectionColor: Color blue. - DisplayScreen screenUpdateRequired: nil! ! -!Transcripter class methodsFor: 'utilities' stamp: 'jmv 6/19/2017 15:58:42' prior: 16938949! - emergencyEvaluator - (Transcripter newInFrame: `0@0 corner: 320@200`) - show: 'Type ''exit'' to exit the emergency evaluator.'; - readEvalPrint! ! -!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'jmv 6/19/2017 16:15:27' prior: 50342779! - defaultAction - - | delta textFrame barFrame outerFrame result range width filledWidth f h textWidth textForm innerBarFrame oldFilledWidth oldFilledWidth2 prevContents | - f _ AbstractFont default. - h _ f height * 3//2. - textWidth _ (f widthOfString: progressTitle) + h. - width _ 150 max: textWidth. - - textForm _ Form extent: width@h depth: 32. - textForm fillBlack. - textForm fillWhite: (textForm boundingBox insetBy: 2). - progressTitle displayOn: textForm at: (width-textWidth+h//2@4). - barFrame _ Rectangle center: aPoint extent: width@h. - textFrame _ `0@0` extent: width@h. - textFrame _ textFrame - aligned: textFrame bottomCenter - with: barFrame topCenter + `0@2`. - outerFrame _ barFrame merge: textFrame. - delta _ outerFrame amountToTranslateWithin: Display boundingBox. - barFrame _ barFrame translatedBy: delta. - textFrame _ textFrame translatedBy: delta. - outerFrame _ outerFrame translatedBy: delta. - prevContents _ Form fromDisplay: outerFrame. - range _ maxVal = minVal ifTrue: [1] ifFalse: [maxVal - minVal]. "Avoid div by 0" - innerBarFrame _ barFrame insetBy: 2. - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - oldFilledWidth _ 0. - oldFilledWidth2 _ 0. - result _ workBlock value: "Supply the bar-update block for evaluation in the work block" - [ :barVal | - barVal - ifNotNil: [ currentVal _ barVal ] - ifNil: [ - currentVal _ currentVal + 1. - currentVal >= maxVal - ifTrue: [ currentVal _ minVal ]]. - filledWidth _ ((barFrame width-4) asFloat * ((currentVal-minVal) asFloat / range min: 1.0)) asInteger. - filledWidth > oldFilledWidth ifTrue: [ - textForm displayAt: textFrame topLeft. - Display fillBlack: barFrame. - Display fillWhite: innerBarFrame. - Display fillGray: (barFrame topLeft + `2@2` extent: filledWidth@17). - filledWidth -200 > oldFilledWidth2 - ifFalse: [ - "Usually just request an update, to be done asynchronously." - DisplayScreen screenUpdateRequired: outerFrame ] - ifTrue: [ - "Once in a while, force a real screen update (warning: really slow on MacOS if done too often)" - Display forceToScreen: outerFrame. oldFilledWidth2 _ filledWidth ]. - oldFilledWidth _ filledWidth ]]. - prevContents displayAt: outerFrame topLeft. - self resume: result! ! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 6/19/2017 16:10:37' prior: 16898287! - staggerOffset - ^`6 @ 20`! ! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 6/19/2017 16:10:46' prior: 16898320! - standardWindowExtent - "Answer the standard default extent for new windows. " - - | effectiveExtent width strips height grid allowedArea maxLevel | - effectiveExtent _ self maximumUsableArea extent - - (self scrollBarSetback @ self screenTopSetback). - Preferences reverseWindowStagger ifTrue: - ["NOTE: following copied from strictlyStaggeredInitialFrameFor:" - allowedArea _ self maximumUsableArea insetBy: ( - self scrollBarSetback @ self screenTopSetback extent: `0@0` - ). - "Number to be staggered at each corner (less on small screens)" - maxLevel _ allowedArea area > 700000 ifTrue: [3] ifFalse: [2]. - "Amount by which to stagger (less on small screens)" - grid _ allowedArea area > 700000 ifTrue: [40] ifFalse: [20]. - ^ (allowedArea extent - (grid*(maxLevel+1*2) + (grid//2))) min: `52@40` * Preferences standardCodeFont height ]. - width _ (strips _ self windowColumnsDesired) > 1 - ifTrue: - [effectiveExtent x // strips] - ifFalse: - [(3 * effectiveExtent x) // 4]. - height _ (strips _ self windowRowsDesired) > 1 - ifTrue: - [effectiveExtent y // strips] - ifFalse: - [(3 * effectiveExtent y) //4]. - ^ width @ height - -"RealEstateAgent standardWindowExtent"! ! -!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jmv 6/19/2017 16:10:58' prior: 16898360! - strictlyStaggeredInitialFrameFor: aStandardSystemView initialExtent: initialExtent world: aWorld - "This method implements a staggered window placement policy that I (di) like. - Basically it provides for up to 4 windows, staggered from each of the 4 corners. - The windows are staggered so that there will always be a corner visible." - - | allowedArea grid initialFrame otherFrames cornerSel corner delta putativeCorner free maxLevel | - allowedArea := (self maximumUsableAreaInWorld: aWorld) - insetBy: (self scrollBarSetback @ self screenTopSetback extent: `0 @ 0`). - "Number to be staggered at each corner (less on small screens)" - maxLevel := allowedArea area > 300000 ifTrue: [3] ifFalse: [2]. - "Amount by which to stagger (less on small screens)" - grid := allowedArea area > 500000 ifTrue: [40] ifFalse: [20]. - initialFrame := `0 @ 0` extent: initialExtent. - "min: (allowedArea extent - (grid*(maxLevel+1*2) + (grid//2)))) - min: 600@400" - otherFrames := (SystemWindow windowsIn: aWorld satisfying: [ :w | w visible and: [w isCollapsed not]]) - collect: [:w | w morphBoundsInWorld]. - otherFrames _ otherFrames reject: [ :f | f isNil ]. - 0 to: maxLevel do: [ :level | - 1 to: 4 do: [:ci | - cornerSel := #(#topLeft #topRight #bottomRight #bottomLeft) at: ci. - corner := allowedArea perform: cornerSel. - "The extra grid//2 in delta helps to keep title tabs distinct" - delta := ((maxLevel - level) * grid + (grid // 2)) @ (level * grid). - 1 to: ci - 1 do: [ :i | delta _ delta y negated @ delta x ]. "slow way" - putativeCorner := corner + delta. - free := true. - otherFrames do: [ :w | - free := free & ((w perform: cornerSel) ~= putativeCorner)]. - free - ifTrue: [ - ^(initialFrame aligned: (initialFrame perform: cornerSel) - with: putativeCorner) translatedAndSquishedToBeWithin: allowedArea]]]. - "If all else fails..." - ^(self scrollBarSetback @ self screenTopSetback - extent: initialFrame extent) translatedAndSquishedToBeWithin: allowedArea! ! -!Form methodsFor: 'accessing' stamp: 'jmv 6/19/2017 15:50:37' prior: 16846782! - offset - ^offset ifNil:[`0@0`]! ! -!Form methodsFor: 'analyzing' stamp: 'jmv 6/19/2017 15:51:14' prior: 16846919! - primCountBits - "Count the non-zero pixels of this form." - self depth > 8 ifTrue: - [^(self asFormOfDepth: 8) primCountBits]. - ^ (BitBlt toForm: self) - fillColor: (Bitmap with: 0); - destRect: (`0@0` extent: width@height); - combinationRule: 32; - copyBits! ! -!Form methodsFor: 'analyzing' stamp: 'jmv 6/19/2017 15:51:36' prior: 16846929! - tallyPixelValuesInRect: destRect into: valueTable - "Tally the selected pixels of this Form into valueTable, a Bitmap of depth 2^depth similar to a color map. Answer valueTable." - - (BitBlt toForm: self) - sourceForm: self; "src must be given for color map ops" - sourceOrigin: `0@0`; - colorMap: valueTable; - combinationRule: 33; - destRect: destRect; - copyBits. - ^ valueTable - -" -Move a little rectangle around the screen and print its tallies... - | r tallies nonZero | -Cursor blank showWhile: [ -[Sensor isAnyButtonPressed] whileFalse: - [r _ Sensor mousePoint extent: 10@10. - Display border: (r expandBy: 2) width: 2 rule: Form reverse fillColor: nil. - tallies _ (Display copy: r) tallyPixelValues. - nonZero _ (1 to: tallies size) select: [:i | (tallies at: i) > 0] - thenCollect: [:i | (tallies at: i) -> (i-1)]. - Display fill: (0@0 extent: Display width@20) fillColor: Color white. - nonZero printString , ' ' displayAt: 0@0. - Display border: (r expandBy: 2) width: 2 rule: Form reverse fillColor: nil]] -"! ! -!Form methodsFor: 'analyzing' stamp: 'jmv 6/19/2017 15:51:54' prior: 16846963! - xTallyPixelValue: pv orNot: not - "Return an array of the number of pixels with value pv by x-value. - Note that if not is true, then this will tally those different from pv." - | cm slice countBlt copyBlt | - cm _ self newColorMap. "Map all colors but pv to zero" - not ifTrue: [cm atAllPut: 1]. "... or all but pv to one" - cm at: pv+1 put: 1 - (cm at: pv+1). - slice _ Form extent: 1@height. - copyBlt _ (BitBlt destForm: slice sourceForm: self - combinationRule: Form over - destOrigin: `0@0` sourceOrigin: `0@0` extent: 1 @ slice height - clipRect: slice boundingBox) - colorMap: cm. - countBlt _ (BitBlt toForm: slice) - fillColor: (Bitmap with: 0); - destRect: (`0@0` extent: slice extent); - combinationRule: 32. - ^ (0 to: width-1) collect: - [:x | - copyBlt sourceOrigin: x@0; copyBits. - countBlt copyBits]! ! -!Form methodsFor: 'analyzing' stamp: 'jmv 6/19/2017 15:52:04' prior: 16846991! - yTallyPixelValue: pv orNot: not - "Return an array of the number of pixels with value pv by y-value. - Note that if not is true, then this will tally those different from pv." - | cm slice copyBlt countBlt | - cm _ self newColorMap. "Map all colors but pv to zero" - not ifTrue: [cm atAllPut: 1]. "... or all but pv to one" - cm at: pv+1 put: 1 - (cm at: pv+1). - slice _ Form extent: width@1. - copyBlt _ (BitBlt destForm: slice sourceForm: self - combinationRule: Form over - destOrigin: `0@0` sourceOrigin: `0@0` extent: slice width @ 1 - clipRect: slice boundingBox) - colorMap: cm. - countBlt _ (BitBlt toForm: slice) - fillColor: (Bitmap with: 0); - destRect: (`0@0` extent: slice extent); - combinationRule: 32. - ^ (0 to: height-1) collect: - [:y | - copyBlt sourceOrigin: 0@y; copyBits. - countBlt copyBits]! ! -!Form methodsFor: 'coloring' stamp: 'jmv 6/19/2017 15:50:16' prior: 16847123! - fillShape: aShapeForm fillColor: aColor - "Fill a region corresponding to 1 bits in aShapeForm with aColor" - - ^ self fillShape: aShapeForm fillColor: aColor at: `0@0`! ! -!Form methodsFor: 'coloring' stamp: 'jmv 6/19/2017 15:50:23' prior: 16847131! - fillShape: aShapeForm fillColor: aColor at: location - "Fill a region corresponding to 1 bits in aShapeForm with aColor" - - ((BitBlt destForm: self sourceForm: aShapeForm fillColor: aColor - combinationRule: Form paint - destOrigin: location + aShapeForm offset sourceOrigin: `0@0` - extent: self extent clipRect: self boundingBox) - colorMap: (Bitmap with: 0 with: 16rFFFFFFFF)) - copyBits! ! -!Form methodsFor: 'color mapping' stamp: 'jmv 6/19/2017 15:50:33' prior: 50358105! - mapColor: oldColor to: newColor - "Make all pixels of the given color in this Form to the given new color." - "Warnings: This method modifies the receiver. It may lose some color accuracy on 32-bit Forms, since the transformation uses a color map with only 15-bit resolution." - - | map | - map _ (Color cachedColormapFrom: self depth to: self depth) copy. - map at: (oldColor indexInMap: map) put: (newColor pixelWordForDepth: self depth). - (BitBlt toForm: self) - sourceForm: self; - sourceOrigin: `0@0`; - combinationRule: Form over; - destX: 0 destY: 0 width: width height: height; - colorMap: map; - copyBits. -! ! -!Form methodsFor: 'converting' stamp: 'jmv 6/19/2017 15:49:08' prior: 16847321! - asFormOfDepth: d - | newForm source | - d = depth ifTrue: [ ^self ]. - source _ (self depth = 32 and: [ d abs < 32 ]) - ifTrue: [ self copy convertAlphaToZeroValueTransparency ] - ifFalse: [ self ]. - newForm _ Form extent: source extent depth: d. - (BitBlt toForm: newForm) - colorMap: (source colormapIfNeededFor: newForm); - copy: source boundingBox - from: `0@0` in: source - fillColor: nil rule: Form over. - "If we build a 32bpp from one of smaller depth, - it will have zero in the alpha channel (until BitBlt is fixed!!)" - (newForm depth = 32 and: [self depth < 32]) ifTrue: [ - newForm fixAlpha ]. - ^newForm! ! -!Form methodsFor: 'converting' stamp: 'jmv 6/19/2017 15:49:12' prior: 16847342! - asGrayForm - | answer map | - - "For lower bit depths, the 15 bit ColorMap loses no information, - and answers the real #luminance of each pixel." - self depth < 32 ifTrue: [ - answer _ GrayForm extent: width@height. - map _ self colormapIfNeededForGray8bpp. - (BitBlt toForm: answer) - colorMap: map; - copy: self boundingBox - from: `0@0` in: self - fillColor: nil rule: Form over. - answer offset: self offset. - ^ answer ]. - - "For 32bpp, the approach below would use just 5bits per component. - Generally it is best to extract a component in full 8bpp and keep full dynamic range. - Green usually is a good choice." - ^ self asGrayForm: 3! ! -!Form methodsFor: 'converting' stamp: 'jmv 6/19/2017 15:49:19' prior: 16847364! - asGrayForm: componentIndex -"Native depth" - "Assume the receiver is a grayscale image. Return a GrayForm computed by extracting the brightness levels of one color component. This technique allows a 32-bit Form to be converted to an 8-bit GrayForm to save space while retaining a full 255 levels of gray. (The usual colormapping technique quantizes to 8, 16, or 32 levels, which loses information.) - - If component = 1, take the alpha component - If component = 2, take the red component - If component = 3, take the green component - If component = 4, take the blue component - " - | f32 result map mask shift | - self depth = 32 ifFalse: [ - f32 _ Form extent: width@height depth: 32. - self displayOn: f32. - ^ f32 asGrayForm: componentIndex ]. - - result _ GrayForm extent: width@height. - shift _ #(-24 -16 -8 0) at: componentIndex. - mask _ #(16rFF000000 16rFF0000 16rFF00 16rFF) at: componentIndex. - map _ ColorMap masks: { mask. 0. 0. 0 } shifts: { shift. 0. 0. 0 }. - (BitBlt toForm: result) - sourceForm: self; - combinationRule: Form over; - colorMap: map; - sourceRect: (`0@0` extent: width@height); - destOrigin: `0@0`; - copyBits. - ^ result! ! -!Form methodsFor: 'converting' stamp: 'jmv 6/19/2017 15:49:38' prior: 16847425! - asGrayScaleAndTransparent: componentIndex -"Native depth" - "Assume the receiver is a grayscale image. Return a grayscale ColorForm computed by extracting the brightness levels of one color component. This technique allows a 32-bit Form to be converted to an 8-bit ColorForm to save space while retaining a full 255 levels of gray. (The usual colormapping technique quantizes to 8, 16, or 32 levels, which loses information.) - - If component = 1, take the alpha component - If component = 2, take the red component - If component = 3, take the green component - If component = 4, take the blue component - " - | f32 result map mask shift | - self depth = 32 ifFalse: [ - f32 _ Form extent: width@height depth: 32. - self displayOn: f32. - ^ f32 asGrayScaleAndTransparent: componentIndex ]. - - result _ ColorForm grayScaleAndTransparentExtent: width@height. - shift _ #(-24 -16 -8 0) at: componentIndex. - mask _ #(16rFF000000 16rFF0000 16rFF00 16rFF) at: componentIndex. - map _ ColorMap masks: { mask. 0. 0. 0 } shifts: { shift. 0. 0. 0 }. - (BitBlt toForm: result) - sourceForm: self; - combinationRule: Form over; - colorMap: map; - sourceRect: (`0@0` extent: width@height); - destOrigin: `0@0`; - copyBits. - - "final BitBlt to zero-out pixels that were truely transparent in the original" - map _ Bitmap new: 512. - map at: 1 put: 16rFF. - (BitBlt toForm: result) - sourceForm: self; - sourceRect: self boundingBox; - destOrigin: `0@0`; - combinationRule: Form erase; - colorMap: map; - copyBits. - ^ result! ! -!Form methodsFor: 'converting' stamp: 'jmv 6/19/2017 16:04:17' prior: 16847525! - icon - "Answer a 16 x 16 icon of myself" - - ^self magnifyTo: `16 @ 16`! ! -!Form methodsFor: 'copying' stamp: 'jmv 6/19/2017 15:49:47' prior: 16847584! - contentsOfArea: aRect into: newForm - "Return a new form which derives from the portion of the original form delineated by aRect." - ^ newForm copyBits: aRect from: self at: `0@0` - clippingBox: newForm boundingBox rule: Form over! ! -!Form methodsFor: 'copying' stamp: 'jmv 6/19/2017 15:49:55' prior: 16847594! - copy: aRect - "Return a new form which derives from the portion of the original form delineated by aRect." - | newForm | - newForm _ self class extent: aRect extent depth: depth. - ^ newForm copyBits: aRect from: self at: `0@0` - clippingBox: newForm boundingBox rule: Form over! ! -!Form methodsFor: 'copying' stamp: 'jmv 6/19/2017 15:50:02' prior: 16847621! - copyBits: sourceForm at: destOrigin translucent: factor - "Make up a BitBlt table and copy the bits with the given colorMap." - (BitBlt - destForm: self - sourceForm: sourceForm - combinationRule: 30 - destOrigin: destOrigin - sourceOrigin: `0@0` - extent: sourceForm extent - clipRect: self boundingBox) - copyBitsTranslucent: ((0 max: (factor*255.0) asInteger) min: 255) -" - | f f2 f3 | f _ Form fromUser. f2 _ Form fromDisplay: (0@0 extent: f extent). f3 _ f2 copy. -0.0 to: 1.0 by: 1.0/32 do: - [:t | f3 _ f2 copy. f3 copyBits: f at: 0@0 translucent: t. - f3 displayAt: 0@0. (Delay forMilliseconds: 100) wait]. -"! ! -!Form methodsFor: 'display box access' stamp: 'jmv 6/19/2017 16:04:01' prior: 16847674! -boundingBox - ^ Rectangle - origin: `0 @ 0` - corner: width @ height! ! -!Form methodsFor: 'displaying' stamp: 'jmv 6/19/2017 15:51:05' prior: 16847690! - paintBits: sourceForm at: destOrigin translucent: factor - "Make up a BitBlt table and copy the bits with the given colorMap." - (BitBlt destForm: self - sourceForm: sourceForm - combinationRule: 31 - destOrigin: destOrigin - sourceOrigin: `0@0` - extent: sourceForm extent - clipRect: self boundingBox) - copyBitsTranslucent: ((0 max: (factor*255.0) asInteger) min: 255) -" - | f f2 f3 | f _ Form fromUser. f replaceColor: f dominantColor withColor: Color transparent. -f2 _ Form fromDisplay: (0@0 extent: f extent). f3 _ f2 copy. -0.0 to: 1.0 by: 1.0/32 do: - [:t | f3 _ f2 copy. f3 paintBits: f at: 0@0 translucent: t. - f3 displayAt: 0@0. (Delay forMilliseconds: 100) wait]. -"! ! -!Form methodsFor: 'displaying-generic' stamp: 'jmv 6/19/2017 16:04:09' prior: 16847730! - displayOn: aDisplayMedium - "Simple default display in order to see the receiver in the upper left - corner of screen." - - self displayOn: aDisplayMedium at: `0 @ 0`! ! -!Form methodsFor: 'filling' stamp: 'jmv 6/19/2017 15:50:07' prior: 16847937! - eraseShape: bwForm - "use bwForm as a mask to clear all pixels where bwForm has 1's" - ((BitBlt destForm: self sourceForm: bwForm - combinationRule: Form erase1bitShape "Cut a hole in the picture with my mask" - destOrigin: bwForm offset - sourceOrigin: `0@0` - extent: self extent clipRect: self boundingBox) - colorMap: (Bitmap with: 0 with: 16rFFFFFFFF)) - copyBits. -! ! -!Form methodsFor: 'filling' stamp: 'jmv 6/19/2017 15:50:12' prior: 16847951! - fill: aRectangle rule: anInteger fillColor: aForm - "Replace a rectangular area of the receiver with the pattern described by aForm - according to the rule anInteger." - (BitBlt toForm: self) - copy: aRectangle - from: `0@0` in: nil - fillColor: aForm rule: anInteger! ! -!Form methodsFor: 'image manipulation' stamp: 'jmv 6/19/2017 15:51:26' prior: 16848014! - smear: dir distance: dist - "Smear any black pixels in this form in the direction dir in Log N steps" - | skew bb | - bb _ BitBlt destForm: self sourceForm: self - combinationRule: Form under destOrigin: `0@0` sourceOrigin: `0@0` - extent: self extent clipRect: self boundingBox. - skew _ 1. - [skew < dist] whileTrue: - [bb destOrigin: dir*skew; copyBits. - skew _ skew+skew]! ! -!Form methodsFor: 'transitions' stamp: 'jmv 6/19/2017 15:50:50' prior: 50358230! - pageWarp: otherImage at: topLeft forward: forward - "Produce a page-turning illusion that gradually reveals otherImage - located at topLeft in this form. - forward == true means turn pages toward you, else away. [ignored for now]" - | pageRect oldPage nSteps buffer p leafRect sourceQuad warp oldBottom d | - pageRect _ otherImage boundingBox. - oldPage _ self copy: (pageRect translatedBy: topLeft). - (forward ifTrue: [oldPage] ifFalse: [otherImage]) - border: pageRect - widthRectangle: (Rectangle - left: 0 - right: 2 - top: 1 - bottom: 1) - rule: Form over - fillColor: Color black. - oldBottom _ self copy: ((pageRect bottomLeft + topLeft) extent: (pageRect width@(pageRect height//4))). - nSteps _ 8. - buffer _ Form extent: otherImage extent + (0@(pageRect height//4)) depth: self depth. - d _ pageRect topLeft + (0@(pageRect height//4)) - pageRect topRight. - 1 to: nSteps-1 do: - [:i | forward - ifTrue: [buffer copy: pageRect from: otherImage to: `0@0` rule: Form over. - p _ pageRect topRight + (d * i // nSteps)] - ifFalse: [buffer copy: pageRect from: oldPage to: `0@0` rule: Form over. - p _ pageRect topRight + (d * (nSteps-i) // nSteps)]. - buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over. - leafRect _ pageRect topLeft corner: p x @ (pageRect bottom + p y). - sourceQuad _ Array with: pageRect topLeft - with: pageRect bottomLeft + (0@p y) - with: pageRect bottomRight - with: pageRect topRight - (0@p y). - warp _ (WarpBlt toForm: buffer) - clipRect: leafRect; - sourceForm: (forward ifTrue: [oldPage] ifFalse: [otherImage]); - combinationRule: Form paint. - warp copyQuad: sourceQuad toRect: leafRect. - self copy: buffer boundingBox from: buffer to: topLeft rule: Form over. - Display forceToScreen. - ]. - - buffer copy: pageRect from: otherImage to: `0@0` rule: Form over. - buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over. - self copy: buffer boundingBox from: buffer to: topLeft rule: Form over. - Display forceToScreen. -" -1 to: 4 do: [:corner | Display pageWarp: - (Form fromDisplay: (10@10 extent: 200@300)) reverse - at: 10@10 forward: false] -" -! ! -!Form methodsFor: 'private' stamp: 'jmv 6/19/2017 16:04:06' prior: 16848740! - copyFromByteArray: bigEndianByteArray - "This method should work with either byte orderings. - See comment at Bitmap>>#asByteArray - Also see #copyFromByteArray2:to:" - - | myHack byteHack | - myHack := Form new hackBits: bits. - byteHack := Form new hackBits: bigEndianByteArray. - "We are passing a ByteArray instead of a Words object. Will be accessed according to native endianness." - Smalltalk isLittleEndian = self isLittleEndian ifFalse: [byteHack swapEndianness]. - byteHack displayOn: myHack at: `0 @ 0` rule: Form over! ! -!Form methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:04:13' prior: 16848849! - fromDisplay: aRectangle - "Create a virtual bit map from a user specified rectangular area on the - display screen. Reallocates bitmap only if aRectangle ~= the receiver's - extent." - - (width = aRectangle width and: [height = aRectangle height]) - ifFalse: [self setExtent: aRectangle extent depth: depth]. - self - copyBits: (aRectangle origin extent: self extent) - from: Display - at: `0 @ 0` - clippingBox: self boundingBox - rule: Form over! ! -!Form methodsFor: 'encoding' stamp: 'jmv 6/19/2017 15:49:02' prior: 16848870! - addDeltasFrom: previousForm - - (BitBlt - destForm: self - sourceForm: previousForm - fillColor: nil - combinationRule: Form reverse - destOrigin: `0@0` - sourceOrigin: `0@0` - extent: self extent - clipRect: self boundingBox) copyBits. - ^self! ! -!Form class methodsFor: 'instance creation' stamp: 'jmv 6/19/2017 16:37:08' prior: 50358301! - dotOfSize: diameter - "Create a form which contains a round black dot." - | radius form bb rect centerX centerY centerYBias centerXBias radiusSquared xOverY maxy dx | - radius _ diameter//2. - form _ self extent: diameter@diameter offset: `0@0` - radius. - bb _ (BitBlt toForm: form) - sourceX: 0; sourceY: 0; - combinationRule: Form over; - fillColor: Color black. - rect _ form boundingBox. - centerX _ rect center x. - centerY _ rect center y. - centerYBias _ rect height odd ifTrue: [0] ifFalse: [1]. - centerXBias _ rect width odd ifTrue: [0] ifFalse: [1]. - radiusSquared _ (rect height asFloat / 2.0) squared - 0.01. - xOverY _ rect width asFloat / rect height asFloat. - maxy _ rect height - 1 // 2. - - "First do the inner fill, and collect x values" - 0 to: maxy do: - [:dy | - dx _ ((radiusSquared - (dy * dy) asFloat) sqrt * xOverY) truncated. - bb destX: centerX - centerXBias - dx - destY: centerY - centerYBias - dy - width: dx + dx + centerXBias + 1 - height: 1; - copyBits. - bb destY: centerY + dy; - copyBits]. - ^ form -" -Time millisecondsToRun: - [1 to: 20 do: [:i | (Form dotOfSize: i) displayAt: (i*20)@(i*20)]] -"! ! -!Form class methodsFor: 'examples' stamp: 'jmv 6/19/2017 16:04:23' prior: 50358363! - toothpaste: diam - " - Display restoreAfter: [Form toothpaste: 30] - " - "Not completely unlike the ST-80 implementation :) - Original comment: - Draws wormlike lines by laying down images of spheres. - See Ken Knowlton, Computer Graphics, vol. 15 no. 4 p352. - Draw with mouse button down; terminate by option-click." - | point queue color q colors colr colr2 | - colors _ Color red wheel: 12. - color _ 8. - [ true ] whileTrue: [ - queue _ OrderedCollection new: 32. - 16 timesRepeat: [queue addLast: `-40@-40`]. - Sensor waitButton. - Sensor isMouseButton2Pressed ifTrue: [^ self]. - point _ Sensor mousePoint. - colr _ colors atWrap: (color _ color + 5). "choose increment relatively prime to colors size" - colr2 _ colr alpha: 0.3. - [Sensor isMouseButton1Pressed or: [queue size > 0]] whileTrue: [ - point _ point * 4 + Sensor mousePoint // 5. - point _ point. - Form fakeSphereAt: point diameter: diam color: colr. - (q _ queue removeFirst) ifNil: [^ self]. "exit" - Form fakeSphereAt: q diameter: diam color: colr2. - Sensor isMouseButton1Pressed ifTrue: [queue addLast: point]]]! ! -!ColorForm methodsFor: 'color manipulation' stamp: 'jmv 6/19/2017 15:47:08' prior: 16818811! - asGrayForm - "Build an optimal GrayForm, - for any color palette in the receiver." - | answer map | - answer _ GrayForm extent: width@height. - map _ self colormapIfNeededForGray8bpp. - (BitBlt toForm: answer) - colorMap: map; - copy: self boundingBox - from: `0@0` in: self - fillColor: nil rule: Form over. - ^ answer! ! -!ColorForm methodsFor: 'copying' stamp: 'jmv 6/19/2017 15:47:12' prior: 16818912! - copy: aRect - "Return a new ColorForm containing the portion of the receiver delineated by aRect." - - | newForm | - newForm _ self class extent: aRect extent depth: depth. - ((BitBlt - destForm: newForm - sourceForm: self - combinationRule: Form over - destOrigin: `0@0` - sourceOrigin: aRect origin - extent: aRect extent - clipRect: newForm boundingBox) - colorMap: nil) copyBits. - colors ifNotNil: [newForm colors: colors copy]. - ^ newForm -! ! -!ColorForm class methodsFor: 'as yet unclassified' stamp: 'jmv 6/19/2017 15:47:16' prior: 50358630! -mappingWhiteToTransparentFrom: aFormOrCursor - "Return a ColorForm copied from the given Form or Cursor with white mapped to transparent." - - | f map | - aFormOrCursor depth <= 8 ifFalse: [ - ^ self error: 'argument depth must be 8-bits per pixel or less']. - (aFormOrCursor is: #ColorForm) ifTrue: [ - f _ aFormOrCursor copy. - map _ aFormOrCursor colors. - ] ifFalse: [ - f _ ColorForm extent: aFormOrCursor extent depth: aFormOrCursor depth. - f copyBits: aFormOrCursor boundingBox - from: aFormOrCursor - at: `0@0` - clippingBox: aFormOrCursor boundingBox - rule: Form over. - map _ Color indexedColors copyFrom: 1 to: (1 bitShift: aFormOrCursor depth)]. - map _ map collect: [:c | - c = Color white ifTrue: [Color transparent] ifFalse: [c]]. - f colors: map. - ^ f -! ! -!Cursor methodsFor: 'converting' stamp: 'jmv 6/19/2017 15:47:21' prior: 16825862! - enlargedBy: scale - "Big cursors are 32 bits deep (ARGB premultiplied)" - | big | - scale = 1 ifTrue: [^self]. - big := CursorWithAlpha extent: self extent * scale depth: 32. - (self asCursorForm magnifyBy: scale) displayOn: big. - big offset: (self offset - 0.5 * scale min: `0@0` max: big extent negated) asIntegerPoint. - big fallback: self. - ^big! ! -!DisplayScreen class methodsFor: 'snapshots' stamp: 'jmv 6/19/2017 16:02:49' prior: 16835519! - actualScreenSize - - ^ `640@480`! ! -!DisplayScreen class methodsFor: 'snapshots' stamp: 'jmv 6/19/2017 16:02:57' prior: 16835523! - shutDown - "Minimize Display memory saved in image" - Display setExtent: `240@120` depth: Display nativeDepth. - ScreenUpdaterProcess ifNotNil: [ - ScreenUpdaterProcess terminate. - ScreenUpdaterProcess _ nil ]! ! -!GrayForm methodsFor: 'copying' stamp: 'jmv 6/19/2017 15:52:16' prior: 16850389! - copy: aRect - "Return a new instance containing the portion of the receiver delineated by aRect." - - | newForm | - newForm _ self class extent: aRect extent depth: depth. - ((BitBlt - destForm: newForm - sourceForm: self - combinationRule: Form over - destOrigin: `0@0` - sourceOrigin: aRect origin - extent: aRect extent - clipRect: newForm boundingBox) - colorMap: nil) copyBits. - ^ newForm! ! -!BitBlt class methodsFor: 'instance creation' stamp: 'jmv 6/19/2017 15:45:22' prior: 16786163! - bitPeekerFromForm: sourceForm - "Answer an instance to be used extract individual pixels from the given Form. The destination for a 1x1 copyBits will be the low order bits of (bits at: 1)." - | pixPerWord answer | - pixPerWord _ sourceForm pixelsPerWord. - answer _ self destForm: (Form extent: pixPerWord@1 depth: sourceForm depth) - sourceForm: nil "To ensure no colormap set" - combinationRule: Form over - destOrigin: (pixPerWord - 1)@0 - sourceOrigin: `0@0` - extent: `1@1` - clipRect: (`0@0` extent: pixPerWord@1). - "To ensure no colormap set" - answer sourceForm: sourceForm. - ^ answer! ! -!BitBlt class methodsFor: 'instance creation' stamp: 'jmv 6/19/2017 15:45:33' prior: 16786184! - bitPokerToForm: destForm - "Answer an instance to be used for valueAt: aPoint put: pixValue. - The source for a 1x1 copyBits will be the low order of (bits at: 1)" - | pixPerWord answer | - pixPerWord _ 32//destForm depth. - answer _ self destForm: destForm - sourceForm: nil "To ensure no colormap set" - combinationRule: Form over - destOrigin: `0@0` - sourceOrigin: (pixPerWord-1)@0 - extent: `1@1` - clipRect: (`0@0` extent: destForm extent). - "To ensure no colormap set" - answer sourceForm: (Form extent: pixPerWord@1 depth: destForm depth). - ^ answer! ! -!AffineTransformation methodsFor: 'converting coordinates' stamp: 'jmv 6/19/2017 15:43:10' prior: 16778110! - internalizeDelta: aPoint - "Internalize a distance vector. A distance is not a position. It is a magnitude with a direction. - It is usually used as a delta to be added to a position to obtain some other position." - - | x y det a11 a12 a21 a22 detX detY | - x _ aPoint x. - y _ aPoint y. - a11 _ self a11. - a12 _ self a12. - a21 _ self a21. - a22 _ self a22. - det _ (a11 * a22) - (a12 * a21). - det = 0.0 ifTrue: [ ^`0@0` ]. "So we have at least a valid result" - det _ 1.0 / det. - detX _ (x * a22) - (a12 * y). - detY _ (a11 * y) - (x * a21). - ^(detX * det) @ (detY * det)! ! -!AffineTransformation methodsFor: 'converting coordinates' stamp: 'jmv 6/19/2017 15:43:16' prior: 16778149! - inverseTransform: aPoint - "Apply the inverse transformation to aPoint, i.e. multiply our inverse by aPoint. - Use Smalltalk code, and not Matrix2x3Plugin, because we want Float conversion." - | x y det a11 a12 a21 a22 detX detY | - - x _ aPoint x - self a13. - y _ aPoint y - self a23. - a11 _ self a11. - a12 _ self a12. - a21 _ self a21. - a22 _ self a22. - det _ (a11 * a22) - (a12 * a21). - det = 0.0 ifTrue: [ ^`0@0` ]. "So we have at least a valid result" - det _ 1.0 / det. - detX _ (x * a22) - (a12 * y). - detY _ (a11 * y) - (x * a21). - ^(detX * det) @ (detY * det)! ! -!AffineTransformation methodsFor: 'accessing' stamp: 'jmv 6/19/2017 15:43:25' prior: 16778231! - inverseTransformation - "Return the inverse transformation of the receiver. - The inverse transformation is computed by first calculating - the inverse offset and then computing transformations - for the two identity vectors (1@0) and (0@1)" - | r1 r2 r3 m | - r3 _ self inverseTransform: `0@0`. - r1 _ (self inverseTransform: `1@0`) - r3. - r2 _ (self inverseTransform: `0@1`) - r3. - m _ self species new. - m - a11: r1 x; a12: r2 x; a13: r3 x; - a21: r1 y; a22: r2 y; a23: r3 y. - ^m! ! -!AffineTransformation methodsFor: 'transforming rects' stamp: 'jmv 6/19/2017 15:43:02' prior: 16778783! - displayBoundsOfTransformOf: aRectangle - "Externalize aRectangle, and find a bounding rectangle with horizontal - and vertical bounds and integer coordinates (i.e. adisplayBounds). - Primitive rounds and answers integers. - Warning: if answer from primitive is not strictly positive, it is off by one. Fix it here." - - | dstRect | - dstRect _ Rectangle new. - (self primDisplayBoundsOfTransformOf: aRectangle into: dstRect) ifNotNil: [ - dstRect topLeft > `0@0` ifTrue: [ ^dstRect ]]. - ^Rectangle encompassing: (aRectangle corners collect: [ :pt | - (self transform: pt) rounded ])! ! -!Point methodsFor: 'point functions' stamp: 'jmv 6/19/2017 16:10:05' prior: 16890518! - eightNeighbors - ^ (Array with: self + `1@0` - with: self + `1@1` - with: self + `0@1` - with: self + `-1@1`) , - (Array with: self + `-1@0` - with: self + `-1@-1` - with: self + `0@-1` - with: self + `1@-1`) -! ! -!Point methodsFor: 'point functions' stamp: 'jmv 6/19/2017 16:10:18' prior: 16890538! - fourNeighbors - ^ Array with: self + `1@0` - with: self + `0@1` - with: self + `-1@0` - with: self + `0@-1` -! ! -!Rectangle methodsFor: 'accessing' stamp: 'jmv 6/19/2017 16:11:04' prior: 16898560! - innerCorners - "Return an array of inner corner points, - ie, the most extreme pixels included, - in the order of a quadrilateral spec for WarpBlt" - | r1 | - r1 _ self topLeft corner: self bottomRight - `1@1`. - ^ Array with: r1 topLeft with: r1 bottomLeft with: r1 bottomRight with: r1 topRight! ! -!Morph methodsFor: 'events-processing' stamp: 'jmv 6/19/2017 15:54:30' prior: 16875129! - processUnknownEvent: aMorphicEvent localPosition: localEventPosition - "An event of an unknown type was sent to the receiver. What shall we do?!!" - - Smalltalk beep. - aMorphicEvent printString displayAt: `0@0`. - aMorphicEvent wasHandled: true! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 6/19/2017 16:08:34' prior: 16875336! - minimumExtent - "This returns the minimum extent that the morph may be shrunk to. Not honored in too many places yet, but respected by the resizeToFit feature, at least" - - self flag: #jmvVer2. "in owner's coordinates?" - ^self valueOfProperty: #minimumExtent ifAbsent: [`1@1`]! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 6/19/2017 16:08:41' prior: 16875397! - morphExtent - "In our own coordinates!!" -"Quizas eventualmente borrar este tambien? (no se usa mucho...)" - self flag: #jmvVer2. - ^`50 @ 40`! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 6/19/2017 15:54:22' prior: 16875457! - morphPositionInWorld - - self flag: #jmvVer2. - "Most likely we don't want to use global coordinates... - In fact, we could be in many frames of reference at the same time... - This method makes no sense at all!!" - - ^self externalizeToWorld: `0@0`! ! -!Morph methodsFor: 'geometry' stamp: 'jmv 6/19/2017 15:54:26' prior: 16875515! - morphTopLeft - "By default, morphs occupy a rectangle specified by #morphTopLef and #morphExtent" - ^`0@0`! ! -!Morph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:08:46' prior: 16875946! - openInWorld: aWorld - "Add this morph to the requested World." - (location = MorphicTranslation new) - ifTrue: [ aWorld addMorph: self position: `50@50` ] - ifFalse: [ aWorld addMorph: self ]! ! -!RectangleLikeMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:11:08' prior: 16899200! - initialize - super initialize. - extent _ `50@40`. - color _ self defaultColor! ! -!PasteUpMorph methodsFor: 'change reporting' stamp: 'jmv 6/19/2017 15:55:13' prior: 16887050! - invalidateDisplayRect: damageRect from: aMorph - "Clip damage reports to my bounds, since drawing is clipped to my bounds." - - self == self world - ifTrue: [ worldState recordDamagedRect: (damageRect intersect: ( `0@0` extent: extent) ) ] - ifFalse: [ super invalidateDisplayRect: damageRect from: aMorph ] -! ! -!PasteUpMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:55:00' prior: 16887077! - drawOn: aCanvas - - "draw background image." - backgroundImage - ifNotNil: [ - aCanvas image: backgroundImage at: `0@0` ] - ifNil: [ - "draw background fill" - (self isWorldMorph and: [ aCanvas drawsOnDisplay ] and: [ color mightBeTranslucent ]) - ifTrue: [ - "Special case so a translucent background on the Display allows you to see through the main Cuis Window. - Requires proper handling of translucent Display in the VM. - Seems to work only on Linux when using a composing window manager." - (BitBlt toForm: Display) clipRect: aCanvas clipRect; - copy: Display boundingBox - from: `0@0` in: nil - fillColor: color rule: Form over. - Display forceToScreen] - ifFalse: [ super drawOn: aCanvas ]]! ! -!PasteUpMorph methodsFor: 'geometry' stamp: 'jmv 6/19/2017 15:55:18' prior: 16887238! - morphPositionInWorld - - self flag: #jmvVer2. "Solo para evitar los warning por falta de owner... pensar despues este caso" - self isWorldMorph ifTrue: [ ^ `0@0` ]. - ^super morphPositionInWorld! ! -!PasteUpMorph methodsFor: 'project state' stamp: 'jmv 6/19/2017 15:55:22' prior: 50337482! - viewBox - - ^ worldState - ifNotNil: [ - `0@0` extent: extent ] - ifNil: [ - self world viewBox ]! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 6/19/2017 15:55:05' prior: 16887770! - fillRects: rectangleList color: aColor - "For testing. Flashes the given list of rectangles on the Display so you can watch incremental redisplay at work." - - - | blt screenRect | - blt _ (BitBlt toForm: Display) - sourceForm: nil; - sourceOrigin: `0@0`; - clipRect: self viewBox; - fillColor: aColor; - combinationRule: Form over. - - rectangleList do: [:r | - screenRect _ r translatedBy: self viewBox origin. - blt destRect: screenRect; copyBits. - Display forceToScreen: screenRect ]. - - (Delay forMilliseconds: 150) wait! ! -!PasteUpMorph methodsFor: 'world state' stamp: 'jmv 6/19/2017 15:55:09' prior: 16887789! - flashRects: rectangleList color: aColor - "For testing. Flashes the given list of rectangles on the Display so you can watch incremental redisplay at work." - "Details: Uses two reverses so that the display is restored to its original state. This is necessary when in deferred update mode." - - | blt screenRect | - blt _ (BitBlt toForm: Display) - sourceForm: nil; - sourceOrigin: `0@0`; - clipRect: self viewBox; - fillColor: aColor; - combinationRule: Form reverse. - - rectangleList do: [:r | - screenRect _ r translatedBy: self viewBox origin. - blt destRect: screenRect; copyBits. - Display forceToScreen: screenRect ]. - - (Delay forMilliseconds: 250) wait. - - rectangleList do: [:r | - screenRect _ r translatedBy: self viewBox origin. - blt destRect: screenRect; copyBits. - Display forceToScreen: screenRect ]! ! -!PasteUpMorph class methodsFor: 'instance creation' stamp: 'jmv 6/19/2017 15:55:26' prior: 50337498! - newWorld - " -[ - ProjectX stopUIProcess. - ProjectX spawnNewMorphicProcessFor: PasteUpMorph newWorld -] fork. - " - | w ws | - w _ self new. - ws _ WorldState new. - w worldState: ws. - w morphPosition: `0@0` extent: Display extent. - ws setCanvas: Display getCanvas. - w borderWidth: 0. - ws handsDo: [ :h | - h privateOwner: w ]. - ^w! ! -!EllipseMorph methodsFor: 'geometry testing' stamp: 'jmv 6/19/2017 16:03:06' prior: 16837091! - morphContainsPoint: aLocalPoint - - | radius other delta xOverY | - ((`0@0` extent: extent) containsPoint: aLocalPoint) ifFalse: [^ false]. "quick elimination" - extent > `1@1` - ifFalse: [^ true]. "Degenerate case -- code below fails by a bit" - - radius _ extent y asFloat / 2. - other _ extent x asFloat / 2. - delta _ aLocalPoint - (other@radius). - xOverY _ extent x asFloat / extent y asFloat. - ^ (delta x asFloat / xOverY) squared + delta y squared <= radius squared! ! -!HandleMorph methodsFor: 'events' stamp: 'jmv 6/19/2017 16:05:03' prior: 16852419! - keyStroke: aKeyboardEvent - "Check for cursor keys" - | keyValue | - (owner is: #HandMorph) ifFalse: [ ^self ]. - keyValue _ aKeyboardEvent keyValue. - keyValue = 28 ifTrue: [ ^self morphPosition: self morphPosition - `1@0` ]. - keyValue = 29 ifTrue: [ ^self morphPosition: self morphPosition + `1@0` ]. - keyValue = 30 ifTrue: [ ^self morphPosition: self morphPosition - `0@1` ]. - keyValue = 31 ifTrue: [ ^self morphPosition: self morphPosition + `0@1` ]. - "Special case for return" - aKeyboardEvent isReturnKey ifTrue:[ - "Drop the receiver and be done" - self flag: #arNote. "Probably unnecessary" - owner releaseKeyboardFocus: self. - self delete ]! ! -!HandleMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:04:48' prior: 16852446! - initialize - "initialize the state of the receiver" - super initialize. - extent _ `12@12`! ! -!PluggableMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:09:25' prior: 16889457! - initialize - super initialize. - extent _ `200@100`! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:55:30' prior: 16888083! - draw3DLookOn: aCanvas - - | borderStyleSymbol c | - borderStyleSymbol _ self isPressed ifFalse: [ #raised ] ifTrue: [ #inset ]. - c _ color. - self mouseIsOver ifTrue: [ c _ c lighter ]. - aCanvas - fillRectangle: (`0@0` extent: extent) - color: c - borderWidth: borderWidth - borderStyleSymbol: borderStyleSymbol - baseColorForBorder: c. - - self drawRegularLabelOn: aCanvas! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:55:46' prior: 50359274! - drawRoundGradientLookOn: aCanvas - | r colorForButton rect bottomFactor topFactor | - - self isPressed - ifFalse: [ - topFactor _ Theme current buttonGradientTopFactor. - bottomFactor _ Theme current buttonGradientBottomFactor. - self mouseIsOver - ifTrue: [ - colorForButton _ Color h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ - colorForButton _ color ]] - ifTrue: [ - topFactor _ Theme current buttonGradientBottomFactor. - bottomFactor _ Theme current buttonGradientTopFactor. - colorForButton _ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - Theme current useButtonGradient - ifTrue: [ - rect _ (`0@0` extent: extent) insetBy: `1@3`. - aCanvas - roundRect: rect - color: colorForButton - radius: r - gradientTop: topFactor - gradientBottom: bottomFactor - gradientHeight: Theme current buttonGradientHeight ] - ifFalse: [ - rect _ (`0@0` extent: extent) insetBy: `1@3`. - aCanvas roundRect: rect color: colorForButton radius: r ] - ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawEmbossedLabelOn: aCanvas ] - ifFalse: [ self drawRegularLabelOn: aCanvas ]! ! -!PluggableButtonMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:09:15' prior: 16888316! - initialize - "initialize the state of the receiver" - super initialize. - - roundButtonStyle _ nil. "nil: honor Theme. true: draw as round button. false: draw as classic 3d border square button" - model _ nil. - getStateSelector _ nil. - actionSelector _ nil. - isPressed _ false. - mouseIsOver _ false. - actWhen _ #buttonUp. - extent _ `20 @ 15`! ! -!PluggableButtonMorph methodsFor: 'geometry testing' stamp: 'jmv 6/19/2017 15:55:52' prior: 16888418! - morphContainsPoint: aLocalPoint - - | iconOrigin | - ((`0@0` extent: extent) containsPoint: aLocalPoint) ifFalse: [ ^false ]. - ^ self isOrthoRectangularMorph or: [ - magnifiedIcon isNil or: [ - iconOrigin _ extent - magnifiedIcon extent // 2. - (magnifiedIcon isTransparentAt: (aLocalPoint - iconOrigin) rounded) not ]]! ! -!PluggableButtonMorph class methodsFor: 'example' stamp: 'jmv 6/19/2017 16:09:19' prior: 50359323! - example - " - PluggableButtonMorph example openInWorld - " - - | s1 s2 s3 b1 b2 b3 row | - s1 _ Switch new. - s2 _ Switch new turnOn. - s3 _ Switch new. - s2 onAction: [s3 turnOff]. - s3 onAction: [s2 turnOff]. - b1 _ (PluggableButtonMorph model: s1 stateGetter: #isOn action: #switch) label: 'S1'. - b2 _ (PluggableButtonMorph model: s2 stateGetter: #isOn action: #turnOn) label: 'S2'. - b3 _ (PluggableButtonMorph model: s3 stateGetter: #isOn action: #turnOn) label: 'S3'. - b1 color: Color lightRed. - b2 color: Color lightRed. - b3 color: Color lightRed. - row _ LayoutMorph newRow - addMorphs: (Array with: b1 with: b2 with: b3); - morphExtent: `120@35`. - ^ row -! ! -!PluggableScrollPane methodsFor: 'access' stamp: 'jmv 6/19/2017 15:56:26' prior: 16889497! - addToScroller: aMorph - - scroller - addMorph: aMorph position: `0@0`; - morphExtent: aMorph morphExtent! ! -!PluggableScrollPane methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:09:31' prior: 16889865! - initialize - - "initialize the state of the receiver" - super initialize. - hideScrollBars _ false. - - "initialize the receiver's scrollBars" - scrollBar _ self scrollBarClass new model: self setValueSelector: #vScrollBarValue:. - hScrollBar _ self scrollBarClass new model: self setValueSelector: #hScrollBarValue:. - drawKeyboardFocusIndicator _ true. - - scroller _ self innerMorphClass new. - self addMorph: scroller. - self scrollerOffset: `0@ 0`. - self addMorph: scrollBar. - self addMorph: hScrollBar.! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'jmv 6/19/2017 15:56:31' prior: 16889992! - scrollToShow: aRectangle - "scroll to include as much of aRectangle as possible, where aRectangle is in the scroller's local space. - This means that 0@0 is scrolling all the way top and all the way left" - | delta | - (aRectangle top >= 0 and: [ - aRectangle bottom <= self viewableHeight ]) - ifTrue: [ - "already visible" - ^self ]. - - "Scroll end of selection into view if necessary" - delta _ aRectangle amountToTranslateWithin: (`0@0` extent: self viewableExtent). - delta y ~= 0 ifTrue: [ - self scrollBy: 0@delta y ]! ! -!PluggableListMorphOfMany methodsFor: 'events' stamp: 'jmv 6/19/2017 15:55:58' prior: 16889279! - mouseMove: aMouseMoveEvent localPosition: localEventPosition - "The mouse has moved, as characterized by the event provided. Adjust the scrollbar, and alter the selection as appropriate" - - | oldIndex oldVal row | - row _ (localEventPosition y < 0 and: [ scrollBar value > 0.0 ]) - ifTrue: [ - scrollBar scrollUp: 1. - "Leave at least one visible item unaffected, for better visual feedback to the user." - (self rowAtLocation: `0@0`) + 2 ] - ifFalse: [ - (localEventPosition y > extent y and: [ scrollBar value < 1.0 ]) - ifTrue: [ - scrollBar scrollDown: 1. - "Leave at least one visible item unaffected, for better visual feedback to the user." - (self rowAtLocation: 0@extent y) - 3 ] - ifFalse: [ self rowAtLocation: localEventPosition ]]. - row = 0 ifTrue: [ ^ self ]. - - "No change if model is locked" - self owningWindow ifNotNil: [ :w | - w okToChange ifFalse: [^ self]]. - - dragOnOrOff ifNil: [ - "Was not set at mouse down, which means the mouse must have gone down in an area where there was no list item" - dragOnOrOff _ (self listSelectionAt: row) not. - dragStartRow _ row ]. - - "Set meaning for subsequent dragging of selection" - oldIndex _ self getCurrentSelectionIndex. - oldIndex ~= 0 ifTrue: [ oldVal _ self listSelectionAt: oldIndex ]. - - "Set or clear new primary selection (listIndex)" - dragOnOrOff - ifTrue: [ self changeModelSelection: row ] - ifFalse: [ self changeModelSelection: 0 ]. - - "Need to restore the old one, due to how model works, and set new one." - oldIndex ~= 0 ifTrue: [ self listSelectionAt: oldIndex put: oldVal ]. - - "Select all in between if drag was too fast" - "self listSelectionAt: row put: dragOnOrOff." - (row min: dragStartRow) to: (row max: dragStartRow) do: [ :r | - self listSelectionAt: r put: dragOnOrOff ]! ! -!SystemWindow methodsFor: 'change reporting' stamp: 'jmv 6/19/2017 15:58:02' prior: 16926004! - invalidateTitleArea - - "not really pretty... also invalidating the top border, regardless of it being above or below the title area - (Different themes use various looks, this covers them all)" - self invalidateLocalRect: (`0@0` extent: extent x @ (self labelHeight + borderWidth))! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:57:54' prior: 16926054! - drawClassicFrameOn: aCanvas color: titleColor - "Window border encompasses title area. No round corners. No title gradient." - - aCanvas fillRectangle: (`0@0` extent: extent) color: color borderWidth: borderWidth borderStyleSymbol: #simple baseColorForBorder: self widgetsColor. - - "A border was drawn at the left, top and right of the title area. - The look is that the title area is inside the window" - aCanvas fillRectangle: (borderWidth@borderWidth extent: extent x - (2*borderWidth)@ self labelHeight) color: titleColor! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:57:58' prior: 16926109! -drawRoundedFrameOn: aCanvas color: widgetsColor - "Title area is not inside window borders" - | bottomFactor topFactor | - Theme current useWindowTitleGradient - ifTrue: [ - topFactor _ Theme current titleGradientTopFactor. - bottomFactor _ Theme current titleGradientBottomFactor ] - ifFalse: [ - topFactor _ 1. - bottomFactor _ 1 ]. - aCanvas - windowFrame: (`0@0` extent: extent) - color: widgetsColor * Theme current titleGradientExtraLightness - radius: Theme current roundedWindowRadius - border: borderWidth - labelHeight: self labelHeight + borderWidth - gradientTop: topFactor - gradientBottom: bottomFactor - insideColor: color! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 6/19/2017 16:37:43' prior: 16926132! - makeMeFullyVisible - - self world morphExtent > `0@0` ifFalse: [^ self]. - - (self morphPosition >= `0@0` and: [ self morphPosition < (self world morphExtent-self morphExtent)]) ifTrue: [ - ^ self "OK -- visible"]. - - self morphPosition: (RealEstateAgent initialFrameFor: self initialExtent: self morphExtentInWorld world: self world) topLeft! ! -!SystemWindow methodsFor: 'drawing' stamp: 'jmv 6/19/2017 16:37:53' prior: 16926145! - makeMeVisible - - self world morphExtent > `0@0` ifFalse: [^ self]. - - (self morphPosition >= `0@0` and: [ self morphPosition < (self world morphExtent-self labelHeight)]) ifTrue: [ - ^ self "OK -- at least my top left is visible"]. - - "window not on screen (probably due to reframe) -- move it now" - self morphPosition: (RealEstateAgent initialFrameFor: self initialExtent: extent world: self world) topLeft! ! -!SystemWindow methodsFor: 'geometry' stamp: 'jmv 6/19/2017 16:12:56' prior: 16926196! - minimumExtent - - ^`160@80`! ! -!SystemWindow methodsFor: 'geometry' stamp: 'jmv 6/19/2017 16:13:07' prior: 16926199! - rescaleButtons - "boxExtent changed. Update my buttons." - | buttonExtent buttonPos buttonDelta | - buttonExtent := self boxExtent. - buttonPos := `2@2`. - buttonDelta := self boxExtent x + 2. - self submorphsReverseDo: [ :aMorph | - (aMorph is: #PluggableButtonMorph) - ifTrue: [ - aMorph morphExtent: buttonExtent. - aMorph morphPosition: buttonPos. - buttonPos := (buttonPos x + buttonDelta) @ 2. - ]. - ]. -! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 6/19/2017 15:57:49' prior: 16926215! -boxExtent - "answer the extent to use in all the buttons. - - the label height is used to be proportional to the fonts preferences" - | e | - Theme current minimalWindows ifTrue: [^`0@0`]. - e _ Preferences windowTitleFont height. - ^e@e! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:12:42' prior: 16926276! - initialize - "Initialize a system window. Add label, stripes, etc., if desired" - - super initialize. - labelString ifNil: [ labelString _ 'Untitled Window']. - - self initializeLabelArea. - extent _ `300 @ 200`. - - adjusters _ Dictionary new. - adjusters at: #topAdjuster put: WindowEdgeAdjustingMorph forTop. - adjusters at: #bottomAdjuster put: WindowEdgeAdjustingMorph forBottom. - adjusters at: #leftAdjuster put: WindowEdgeAdjustingMorph forLeft. - adjusters at: #rightAdjuster put: WindowEdgeAdjustingMorph forRight. - adjusters at: #topLeftAdjuster put: WindowEdgeAdjustingMorph forTopLeft. - adjusters at: #bottomLeftAdjuster put: WindowEdgeAdjustingMorph forBottomLeft. - adjusters at: #topRightAdjuster put: WindowEdgeAdjustingMorph forTopRight. - adjusters at: #bottomRightAdjuster put: WindowEdgeAdjustingMorph forBottomRight. - adjusters do: [ :m | - self addMorphFront: m ]. - - "by default" - self beColumn! ! -!SystemWindow methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:12:52' prior: 16926307! - initializeLabelArea - "Initialize the label area (titlebar) for the window." - - | spacing | - spacing _ self boxExtent x + 2. - self addMorph: self createCloseBox position: `2@2`. - self addMorph: self createCollapseBox position: spacing+2@2. - self addMorph: self createExpandBox position: spacing*2+2@2. - self addMorph: self createMenuBox position: spacing*3+2@2! ! -!SystemWindow methodsFor: 'layout' stamp: 'jmv 6/19/2017 15:58:05' prior: 16926374! - layoutSubmorphs - "Compute a new layout of submorphs based on the given layout bounds." - - | h thickness w cornerExtent wh ww pos | - thickness _ 4. - cornerExtent _ 20. - ww _ extent x. - wh _ extent y. - w _ ww - cornerExtent - cornerExtent. - h _ wh - cornerExtent - cornerExtent. - (adjusters at: #topAdjuster) morphPosition: cornerExtent@0 extent: w@thickness. - (adjusters at: #bottomAdjuster) morphPosition: cornerExtent@(wh-thickness) extent: w@thickness. - (adjusters at: #leftAdjuster) morphPosition: 0@cornerExtent extent: thickness@h. - (adjusters at: #rightAdjuster) morphPosition: ww-thickness@cornerExtent extent: thickness@h. - (adjusters at: #topLeftAdjuster) morphPosition: `0@0` extent: cornerExtent@cornerExtent. - (adjusters at: #bottomLeftAdjuster) morphPosition: 0@(wh-cornerExtent) extent: cornerExtent@cornerExtent. - (adjusters at: #topRightAdjuster) morphPosition: ww-cornerExtent@0 extent: cornerExtent@cornerExtent. - (adjusters at: #bottomRightAdjuster) morphPosition: ww@wh-cornerExtent extent: cornerExtent@cornerExtent. - - layoutMorph ifNotNil: [ - pos _ borderWidth @ (borderWidth + self labelHeight). - layoutMorph - morphPosition: pos - extent: extent - pos - borderWidth ]. - - layoutNeeded _ false! ! -!SystemWindow methodsFor: 'resize/collapse' stamp: 'jmv 6/19/2017 16:13:13' prior: 50333187! - resize - | resizeMorph | - resizeMorph _ ResizeMorph new morphExtent: `200@150`. - resizeMorph action: [self resize: (resizeMorph selectionRectangle: Display extent)]. - resizeMorph morphPosition: self world activeHand morphPosition. - resizeMorph openInWorld - ! ! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'jmv 6/19/2017 16:01:26' prior: 16811550! - initialExtent - - ^`540@400`! ! -!ChangeSorterWindow methodsFor: 'GUI building' stamp: 'jmv 6/19/2017 16:01:18' prior: 16800076! - initialExtent - ^`540@300`! ! -!PreDebugWindow methodsFor: 'GUI building' stamp: 'jmv 6/19/2017 16:01:38' prior: 16892600! - initialExtent - ^ `640 @ 320`! ! -!InspectorWindow methodsFor: 'GUI building' stamp: 'jmv 6/19/2017 16:01:32' prior: 50336316! - initialExtent - - ^`600@325`! ! -!ObjectExplorerWindow methodsFor: 'GUI building' stamp: 'jmv 6/19/2017 16:01:35' prior: 16883318! -initialExtent - - ^`300@500`! ! -!TestRunnerWindow methodsFor: 'GUI building' stamp: 'jmv 6/19/2017 16:13:18' prior: 16928555! - buildMorphicWindow - - self layoutMorph - addMorph: self buildUpperControls proportionalHeight: 0.25; - addAdjusterAndMorph: self buildLowerPanes proportionalHeight: 0.75. - self setLabel: 'SUnit Test Runner'. - self refreshWindow. - self morphExtent: `460 @ 400`! ! -!ScrollBar methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:57:09' prior: 16904515! - drawOn: aCanvas - - aCanvas - fillRectangle: (`0@0` extent: extent) - color: (color alphaMixed: 0.3 with: Theme current scrollbarColor) - borderWidth: borderWidth - borderStyleSymbol: #simple - baseColorForBorder: borderColor! ! -!MenuMorph methodsFor: 'construction' stamp: 'jmv 6/19/2017 16:07:49' prior: 16866514! - addTitle: aString - "Add a title line at the top of this menu Make aString its initial - contents. - If aSelector is not nil, then periodically obtain fresh values for its - contents by sending aSelector to aTarget.." - - | s pp w | - - titleMorph _ RectangleLikeMorph new. - titleMorph color: Theme current menuTitleBar. - pp _ `8@2`. - aString asString linesDo: [ :line | - s _ StringMorph new - contents: line; - font: Preferences standardMenuFont bold. - titleMorph addMorphBack: s position: pp. - pp _ pp + (0@(s morphHeight+2)) ]. - w _ titleMorph submorphs inject: 0 into: [ :prev :each | - prev max: each morphWidth ]. - titleMorph morphExtent: (w + 16) @ (pp y). - self addMorphFront: titleMorph. - - (self hasProperty: #needsStayUpIcons) ifTrue: [ self addStayUpIcons ]! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 6/19/2017 16:37:20' prior: 50341059! - popUpAdjacentTo: rightOrLeftPointInWorld from: sourceItem - "Present this menu at the given point under control of the given hand. - Used mostly for submenus." - - | delta tryToPlace selectedOffset | - popUpOwner _ sourceItem. - selectedOffset _ (selectedItem ifNil: [ self items first ]) morphPosition. - sourceItem world addMorphFront: self. - - tryToPlace _ [ :where :mustFit | - self morphPosition: where - selectedOffset. - delta _ self morphFullBoundsInWorld - amountToTranslateWithin: sourceItem world morphBoundsInWorld. - (delta x = 0 | mustFit) ifTrue: [ - delta = `0@0` ifFalse: [ self morphPosition: self morphPosition + delta ]. - ^ self]]. - tryToPlace - value: rightOrLeftPointInWorld first value: false; - value: rightOrLeftPointInWorld last - (extent x @ 0) value: false; - value: rightOrLeftPointInWorld first value: true! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 6/19/2017 16:08:25' prior: 50339215! - popUpAt: aPoint forHand: hand allowKeyboard: aBoolean - "Present this menu at the given point under control of the given hand." - - | evt | - self items isEmpty ifTrue: [^self]. - Theme current decorateMenu: self. - (self submorphs select: [ :m | m is: #UpdatingMenuItemMorph ]) - do: [ :m | m updateContents]. - self runningWorld addMorphFront: self position: aPoint - `2 @ 8`. - self fitInWorld. - "Acquire focus for valid pop up behavior" - hand newMouseFocus: self. - aBoolean ifTrue: [ hand newKeyboardFocus: self ]. - evt _ hand lastMouseEvent. - (evt isKeyboard or: [ evt isMouse and: [ evt anyButtonPressed not ]]) - ifTrue: [ - "Select first item if button not down" - self moveSelectionDown: 1 event: evt ]! ! -!MenuMorph methodsFor: 'control' stamp: 'jmv 6/19/2017 16:08:29' prior: 50339240! - popUpAt: aPoint forHand: hand in: aWorld allowKeyboard: aBoolean - "Present this menu at the given point under control of the given hand." - - self items isEmpty ifTrue: [ ^self ]. - Theme current decorateMenu: self. - (self submorphs select: [ :m | m is: #UpdatingMenuItemMorph]) - do: [ :m | m updateContents]. - aWorld addMorphFront: self position: aPoint - `2 @ 8`. - self fitInWorld. - "Acquire focus for valid pop up behavior" - hand newMouseFocus: self. - aBoolean ifTrue: [ hand newKeyboardFocus: self ]! ! -!MenuMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:08:18' prior: 50341135! - initialize - super initialize. - extent _ `40@10`. - defaultTarget _ nil. - selectedItem _ nil. - stayUp _ false. - popUpOwner _ nil! ! -!MenuMorph methodsFor: 'keyboard control' stamp: 'jmv 6/19/2017 16:08:04' prior: 50359760! - displayFiltered: evt - | matchStr allItems isMatch matches feedbackMorph | - matchStr _ self valueOfProperty: #matchString. - allItems _ self submorphs select: [ :m | - m is: #MenuItemMorph ]. - matches _ allItems select: [ :m | - isMatch _ matchStr isEmpty or: [ - m contents - includesSubstring: matchStr - caseSensitive: false ]. - m isEnabled: isMatch. - isMatch ]. - feedbackMorph _ self valueOfProperty: #feedbackMorph. - feedbackMorph ifNil: [ - feedbackMorph _ StringMorph new color: Color veryDarkGray. - self addMorphBack: feedbackMorph lock position: `0@ -20`. - self - setProperty: #feedbackMorph - toValue: feedbackMorph ]. - feedbackMorph contents: '<' , matchStr , '>'. - matchStr isEmpty ifTrue: [ - feedbackMorph delete. - self removeProperty: #feedbackMorph ]. - matches notEmpty ifTrue: [ - self selectItem: matches first ]! ! -!MenuMorph methodsFor: 'private' stamp: 'jmv 6/19/2017 16:07:56' prior: 16867223! - adjustSubmorphsLayout - "Enlarge the width of submorphs as needed - so all of them are have the same width, and no less than #minWidth. - Also adjust their vertical position. - Finally, set our own extent." - - | w p h | - - submorphs isEmpty ifTrue: [ ^self ]. - w _ submorphs inject: 0 into: [ :prev :each | - prev max: each minItemWidth]. - - w _ w + 1. - p _ `5 @ 5`. - submorphs do: [ :m | - h _ m morphHeight. - m morphPosition: p extent: w@h. - p _ p + (0@(h + 1)) ]. - - self morphExtent: w+4 @ p y + 5! ! -!MenuMorph methodsFor: 'private' stamp: 'jmv 6/19/2017 16:08:14' prior: 16867241! - fitInWorld - "Note: items may not be laid out yet (I found them all to be at 0@0), - so we have to add up heights of items above the selected item." - - | delta | - "If it doesn't fit, show it to the left, not to the right of the hand." - self morphBoundsInWorld right > owner world morphBoundsInWorld right - ifTrue: [ - self morphPosition: ((self morphPosition x + 10 - extent x) @ self morphPosition y) ]. - - "Make sure that the menu fits in the world." - delta _ self morphBoundsInWorld amountToTranslateWithin: - (owner world morphBoundsInWorld withHeight: - ((owner world morphExtentInWorld y) max: (self morphPosition y) + 1)). - delta = `0 @ 0` ifFalse: [ self morphPosition: self morphPosition + delta ]! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:43:48' prior: 16781484! - downButtonPosition - ^`0@0` + (extent - ScrollBar scrollbarThickness)! ! -!AutoCompleterMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:43:54' prior: 50359790! - drawOn: aCanvas - | rectangle w y0 h y1 y2 scrollbarThickness | - aCanvas frameAndFillRectangle: (`0@0` extent: extent) fillColor: self color borderWidth: borderWidth borderColor: borderColor. - y0 _ 1. - w _ extent x-2. - scrollbarThickness _ ScrollBar scrollbarThickness. - completer entryCount > self class itemsPerPage ifTrue: [ - w _ w - scrollbarThickness. - aCanvas - frameRectangle: (extent x - scrollbarThickness@0 - extent: scrollbarThickness @ extent y) - borderWidth: 1 - color: borderColor. - aCanvas - image: (BitBltCanvas arrowOfDirection: #up size: scrollbarThickness) - at: self upButtonPosition. - aCanvas - image: (BitBltCanvas arrowOfDirection: #down size: scrollbarThickness) - at: self downButtonPosition. - h _ extent y - (2 * scrollbarThickness). - y1 _ (1.0 * self firstVisible-1 / completer entryCount * h) ceiling + y0 + scrollbarThickness-1. - y2 _ (1.0 * self lastVisible / completer entryCount * h) floor + y0 + scrollbarThickness -1. - aCanvas - fillRectangle: (extent x - scrollbarThickness+2@y1 corner: extent x-2 @ y2) - color: Color veryLightGray ]. - self firstVisible - to: self lastVisible - do: [ :index | - rectangle _ 1@y0 extent: w@self class itemHeight. - index = self selected - ifTrue: [ - aCanvas fillRectangle: rectangle color: (Theme current listHighlightFocused: true) ]. - aCanvas - drawString: (completer entries at: index) asString - at: rectangle topLeft - font: self class listFont - color: Theme current text. - y0 _ y0 + self itemHeight ]! ! -!AutoCompleterMorph class methodsFor: 'instance creation' stamp: 'jmv 6/19/2017 16:00:57' prior: 16781686! - initializedInstance - | completer m | - completer _ SmalltalkCompleter withModel: (TextModel withText: 'Small'). - completer - instVarNamed: 'position' - put: 5. - completer computeEntries. - m _ AutoCompleterMorph - completer: completer - position: `200 @ 200`. - completer instVarNamed: 'menuMorph' put: m. - ^m! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:52:36' prior: 50359845! - drawOn: aCanvas - "Draw the hand itself (i.e., the cursor)." - "This method is only called when we are carrying morphs around..." - aCanvas - stencil: Cursor move - at: `0@0` - color: Color black! ! -!HandMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:52:45' prior: 16851711! - savePatchFrom: aCanvas appendDamageTo: aStream - "Save the part of the given canvas under this hand as a Form and return its bounding rectangle." - - "Details: The previously used patch Form is recycled when possible to reduce the burden on storage management." - - | fullBounds | - fullBounds _ self morphFullBoundsInWorld. - fullBounds ifNil: [ ^self ]. - - fullBounds _ fullBounds intersect: (`0@0` extent: aCanvas extent). - (savedPatch isNil or: [savedPatch extent ~= fullBounds extent]) - ifTrue: [ - "allocate new patch form if needed" - savedPatch _ Form extent: fullBounds extent depth: aCanvas depth ]. - aCanvas - contentsOfArea: fullBounds - into: savedPatch. - savedPatch offset: fullBounds topLeft. - prevFullBounds - ifNil: [ aStream nextPut: fullBounds ] - ifNotNil: [ aStream nextPut: (fullBounds merge: prevFullBounds)]. - prevFullBounds _ fullBounds! ! -!HandMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 15:52:41' prior: 16852160! - initForEvents - mouseOverHandler _ nil. - lastMouseEvent _ MouseEvent new setType: #mouseMove position: `0@0` buttons: 0 hand: self. - lastMouseEventTime _ Time localMillisecondClock. - lastEventBuffer _ {1. 0. 0. 0. 0. 0. nil. nil}. - self dontWaitForMoreClicks! ! -!ImageMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:52:49' prior: 16854128! - drawOn: aCanvas - - aCanvas image: image at: `0@0`! ! -!StringMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:57:40' prior: 50343919! - drawOn: aCanvas - aCanvas - drawString: (contents ifNil: [ '' ]) - at: `0@0` - font: self fontToUse - color: color - ! ! -!StringMorph methodsFor: 'geometry' stamp: 'jmv 6/19/2017 15:57:44' prior: 16918155! - fitContents - "Measures contents later at #minimumExtent" - self morphExtent: `0@0`! ! -!IndentingListItemMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:53:00' prior: 16854676! - drawOn: aCanvas - - | tRect colorToUse sLeft aForm centeringOffset | - isHighlighted ifTrue: [ - aCanvas - fillRectangle: (`0@0` extent: extent) - color: (Theme current - listHighlightFocused: owner owner hasKeyboardFocus) duller ]. - isSelected ifTrue: [ - aCanvas - fillRectangle: (`0@0` extent: extent) - color: (Theme current - listHighlightFocused: owner owner hasKeyboardFocus) ]. - - tRect _ self toggleRectangle. - aForm _ isExpanded - ifTrue: [ container expandedForm ] - ifFalse: [ container notExpandedForm ]. - centeringOffset _ ((tRect height - aForm extent y) / 2.0) rounded. - - complexContents hasContents ifTrue: [ - aCanvas - image: aForm - at: (tRect topLeft translatedBy: 0 @ centeringOffset) ]. - - icon isNil - ifFalse: [ - aCanvas - image: icon - at: (tRect topLeft translatedBy: icon width @ centeringOffset). - sLeft _ indentLevel * 12 + 16 + (icon width + 2). - ] - ifTrue: [ - sLeft _ indentLevel * 12 + 16. - ]. - colorToUse _ complexContents preferredColor ifNil: [ color ]. - - aCanvas - drawString: contents asString - at: sLeft@0 - font: self fontToUse - color: colorToUse! ! -!MenuItemMorph methodsFor: 'accessing' stamp: 'jmv 6/19/2017 16:06:04' prior: 16865800! - contents: aString withMarkers: aBool inverse: inverse - "Set the menu item entry. If aBool is true, parse aString for embedded markers." - - | markerIndex marker | - self contentString: nil. "get rid of old" - aBool ifFalse: [^super contents: aString]. - self removeAllMorphs. "get rid of old markers if updating" - self hasIcon ifTrue: [ self icon: nil ]. - (aString notEmpty and: [aString first = $<]) - ifFalse: [^super contents: aString]. - markerIndex := aString indexOf: $>. - markerIndex = 0 ifTrue: [^super contents: aString]. - marker := (aString copyFrom: 1 to: markerIndex) asLowercase. - (#('' '' '' '') includes: marker) - ifFalse: [^super contents: aString]. - self contentString: aString. "remember actual string" - marker := (marker = '' or: [marker = '']) ~= inverse - ifTrue: [self onImage] - ifFalse: [self offImage]. - super contents: (aString copyFrom: markerIndex + 1 to: aString size). - "And set the marker" - marker := ImageMorph new image: marker. - self addMorphFront: marker position: `0@2`! ! -!MenuItemMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:53:42' prior: 16865892! - drawOn: aCanvas - | stringColor leftEdge | - - stringColor _ color. - isSelected & isEnabled - ifTrue: [ - aCanvas fillRectangle: (`0@0` extent: extent) color: Theme current menuHighlight]. - leftEdge _ 0. - - self hasMarker ifTrue: [ - leftEdge _ leftEdge + submorphs first morphWidth + 8 ]. - - self hasIcon - ifTrue: [| iconForm | - iconForm _ isEnabled ifTrue: [ self icon ] ifFalse: [ self icon asGrayScaleAndTransparent ]. - aCanvas image: iconForm at: leftEdge+1 @ (extent y - iconForm height // 2). - leftEdge _ leftEdge + iconForm width + self iconSeparation]. - - aCanvas - drawString: contents - at: leftEdge @ 1 - font: self fontToUse - color: stringColor. - subMenu ifNotNil: [ - aCanvas - image: self class subMenuMarker - at: extent x - 8 @ (extent y - self class subMenuMarker height // 2) ]! ! -!MenuItemMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:06:09' prior: 16866103! - initialize - "initialize the state of the receiver" - super initialize. - "" - extent _ `10@10`. - contents _ ''. - isEnabled _ true. - subMenu _ nil. - isSelected _ false. - target _ nil. - selector _ nil. - arguments _ nil. - font _ Preferences standardMenuFont! ! -!MenuItemMorph methodsFor: 'layout' stamp: 'jmv 6/19/2017 16:06:26' prior: 16866117! - measureContents - | e | - e _ super measureContents. - ^e y > 12 - ifTrue: [e+`2@2`] - ifFalse: [e+`2@1`]! ! -!MenuItemMorph methodsFor: 'selecting' stamp: 'jmv 6/19/2017 15:53:59' prior: 50341150! - select - self isSelected: true. - owner activeSubmenu: subMenu. - subMenu ifNotNil: [ - subMenu delete. - subMenu - popUpAdjacentTo: (Array with: self morphBoundsInWorld topRight + `10@0` - with: self morphBoundsInWorld topLeft) - from: self. - subMenu selectItem: nil ]! ! -!MenuItemMorph class methodsFor: 'cached state access' stamp: 'jmv 6/19/2017 16:06:33' prior: 16866204! - subMenuMarker - - | f | - SubMenuMarker ifNotNil: [ ^SubMenuMarker ]. - f _ Form - extent: `5@9` - fromArray: #(2147483648 3221225472 3758096384 4026531840 4160749568 4026531840 3758096384 3221225472 2147483648) - offset: `0@0`. - SubMenuMarker _ ColorForm mappingWhiteToTransparentFrom: f. - ^SubMenuMarker! ! -!LayoutAdjustingMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:53:34' prior: 16862884! - drawOn: aCanvas - - aCanvas - fillRectangle: (`0@0` extent: extent) - color: color! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 6/19/2017 15:53:38' prior: 16863315! - layoutBounds - "Return the bounds for laying out children of the receiver" - - ^`0@0` extent: extent! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 6/19/2017 16:05:36' prior: 16863335! - layoutSubmorphsHorizontallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - | xSep ySep usableWidth sumOfFixed normalizationFactor availableForPropWidth - fractionalWidths integerWidths theLeft usableHeight boundsTop boundsRight theTop minWidth submorphsToLayout - nextMorph ht wd ls theRight boundsBottom theBottom alternativeWidths count diff i | - - boundsForLayout extent > `2@2` "self minimumExtent" - ifFalse: [ ^self ]. "Too small. Don't bother!!" - - submorphsToLayout := self submorphsToLayout. - xSep := self xSeparation. - ySep := self ySeparation. - usableWidth := boundsForLayout width - ((submorphsToLayout size + 1) * xSep). - sumOfFixed := submorphsToLayout sum: [ :m | m layoutSpec fixedWidth ]. - availableForPropWidth := usableWidth - sumOfFixed max: 0. - normalizationFactor := self proportionalWidthNormalizationFactor. - availableForPropWidth := availableForPropWidth * normalizationFactor. - - fractionalWidths := submorphsToLayout collect: [ :m | m layoutSpec widthFor: availableForPropWidth ]. - "Compute integer widths, mostly rounding but with occasional #floor or #ceiling as needed to keep sum" - integerWidths _ fractionalWidths collect: [ :w | w rounded ]. - diff _ integerWidths sum - fractionalWidths sum rounded. - alternativeWidths _ diff > 0 ifTrue: [ fractionalWidths collect: [ :w | w floor ]] ifFalse: [ fractionalWidths collect: [ :w | w ceiling ]]. - count _ diff abs. - i _ 1. - [ count > 0] whileTrue: [ - (integerWidths at: i) = (alternativeWidths at: i) ifFalse: [ - integerWidths at: i put: (alternativeWidths at: i). - count _ count -1 ]. - i _ i + 1 ]. - minWidth := integerWidths sum. - theLeft := ((usableWidth - minWidth) * (padding ifNil: [0]) max: 0) + boundsForLayout left + xSep. - usableHeight := boundsForLayout height - (ySep * 2) max: 0. - boundsTop := boundsForLayout top + ySep. - boundsRight := boundsForLayout right - xSep. - boundsBottom := boundsForLayout bottom - ySep. - - submorphsToLayout size to: 1 by: -1 do: [ :index | - nextMorph := submorphsToLayout at: index. - "major direction" - wd := integerWidths at: index. - "minor direction" - ls := nextMorph layoutSpec. - ht := (ls heightFor: usableHeight) min: usableHeight. - theTop := ((usableHeight - ht) * ls minorDirectionPadding) floor + boundsTop. - theBottom := (theTop + ht) ceiling min: boundsBottom. - theRight := (theLeft + (wd min: minWidth)) "ceiling "min: boundsRight. - "Set bounds and adjust major direction for next step" - self flag: #jmvVer2. "should extent be set in m's coordinate system? what if its scale is not 1?" - ls usesMorphExtent - ifTrue: [ - nextMorph morphPosition: theLeft floor @ theTop floor ] - ifFalse: [ - nextMorph morphPosition: theLeft floor @ theTop floor extent: theRight - theLeft @ (theBottom - theTop) ]. - theLeft := theRight + xSep - ]! ! -!LayoutMorph methodsFor: 'layout' stamp: 'jmv 6/19/2017 16:05:46' prior: 16863426! - layoutSubmorphsVerticallyIn: boundsForLayout - "Compute a new layout based on the given layout bounds." - | xSep ySep usableHeight sumOfFixed normalizationFactor availableForPropHeight - fractionalHeights integerHeights theTop usableWidth boundsLeft boundsBottom theLeft minHeight submorphsToLayout - nextMorph ht wd ls theBottom boundsRight theRight alternativeHeights count diff i | - - boundsForLayout extent > `2@2` "self minimumExtent" - ifFalse: [ ^self ]. "Too small. Don't bother!!" - - submorphsToLayout := self submorphsToLayout. - xSep := self xSeparation. - ySep := self ySeparation. - usableHeight := boundsForLayout height - ((submorphsToLayout size + 1) * ySep). - sumOfFixed := submorphsToLayout sum: [ :m | m layoutSpec fixedHeight ]. - availableForPropHeight := usableHeight - sumOfFixed max: 0. - normalizationFactor := self proportionalHeightNormalizationFactor. - availableForPropHeight := availableForPropHeight * normalizationFactor. - - fractionalHeights := submorphsToLayout collect: [ :m | m layoutSpec heightFor: availableForPropHeight ]. - "Compute integer widths, mostly rounding but with occasional #floor or #ceiling as needed to keep sum" - integerHeights _ fractionalHeights collect: [ :w | w rounded ]. - diff _ integerHeights sum - fractionalHeights sum rounded. - alternativeHeights _ diff > 0 ifTrue: [ fractionalHeights collect: [ :w | w floor ]] ifFalse: [ fractionalHeights collect: [ :w | w ceiling ]]. - count _ diff abs. - i _ 1. - [ count > 0] whileTrue: [ - (integerHeights at: i) = (alternativeHeights at: i) ifFalse: [ - integerHeights at: i put: (alternativeHeights at: i). - count _ count -1 ]. - i _ i + 1 ]. - minHeight := integerHeights sum. - theTop := ((usableHeight - minHeight) * (padding ifNil: [0]) max: 0) + boundsForLayout top + ySep. - usableWidth := boundsForLayout width - (xSep * 2) max: 0. - boundsLeft := boundsForLayout left + xSep. - boundsBottom := boundsForLayout bottom - ySep. - boundsRight := boundsForLayout right - xSep. - - submorphsToLayout size to: 1 by: -1 do: [ :index | - nextMorph := submorphsToLayout at: index. - "major direction" - ht := integerHeights at: index. - "minor direction" - ls := nextMorph layoutSpec. - wd := (ls widthFor: usableWidth) min: usableWidth. - theLeft := ((usableWidth - wd) * ls minorDirectionPadding) floor + boundsLeft. - theRight := (theLeft + wd) ceiling min: boundsRight. - theBottom := (theTop + (ht min: minHeight)) "ceiling" min: boundsBottom. - "Set bounds and adjust major direction for next step" - self flag: #jmvVer2. "should extent be set in m's coordinate system? what if its scale is not 1?" - ls usesMorphExtent - ifTrue: [ - nextMorph morphPosition: theLeft floor @ theTop floor ] - ifFalse: [ - nextMorph morphPosition: theLeft floor @ theTop floor extent: theRight - theLeft @ (theBottom - theTop) ]. - theTop := theBottom + ySep - ]! ! -!ProgressMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:10:33' prior: 16896264! - initialize - super initialize. - self separation: 0. - labelMorph _ StringMorph contents: '' font: AbstractFont default. - subLabelMorph _ StringMorph contents: '' font: AbstractFont default. - progress _ ProgressBarMorph new. - progress morphExtent: `200 @ 15`. - self addMorphFront: labelMorph. - self addMorphFront: subLabelMorph. - self addMorph: progress fixedHeight: 15.! ! -!HaloHandleMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:52:21' prior: 16850527! - drawOn: aCanvas - - aCanvas - image: (self class circleForm: extent) - multipliedBy: color - at: `0@0`! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 6/19/2017 15:52:25' prior: 50360435! - addHandle: handleSpec - "Add a handle within the halo box as per the haloSpec, and set it up to respond to the given event by sending the given selector to the given recipient. Return the handle." - - | handle aPoint colorToUse form icon | - aPoint _ self - positionIn: haloBox - horizontalPlacement: handleSpec horizontalPlacement - verticalPlacement: handleSpec verticalPlacement. - colorToUse _ Color colorFrom: handleSpec color. - handle _ HaloHandleMorph new color: colorToUse. - self addMorph: handle. - handle morphBoundsInWorld: (Rectangle center: aPoint extent: self class handleSize asPoint). - handleSpec iconSymbol ifNotNil: [ :iconName | - form _ self class icons at: iconName ifAbsent: [self class perform: iconName]. - form ifNotNil: [ - icon _ ImageMorph new - image: form; - color: colorToUse makeForegroundColor; - lock. - handle addMorphFront: icon position: `0@0` ]]. - handle mouseUpSelector: #endInteraction. - handle setBalloonText: handleSpec hoverHelp. - ^handle! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 6/19/2017 16:04:44' prior: 16850943! - basicBox - | aBox minSide anExtent w | - minSide _ 4 * self class handleSize. - anExtent _ ((extent x + self class handleSize + 8) max: minSide) @ - ((extent y + self class handleSize + 8) max: minSide). - aBox _ Rectangle center: self morphBoundsInWorld center extent: anExtent. - w _ self world ifNil: [ target world ]. - ^ w - ifNil: - [ aBox ] - ifNotNil: - [ aBox intersect: (w viewBox insetBy: `8@8`) ]! ! -!HaloMorph methodsFor: 'private' stamp: 'jmv 6/19/2017 15:52:32' prior: 16851149! - startGrow: evt with: growHandle - "Initialize resizing of my target. Launch a command representing it, to support Undo" - - | botRt | - evt hand obtainHalo: self. "Make sure the event's hand correlates with the receiver" - self removeAllHandlesBut: growHandle. "remove all other handles" - botRt _ target morphPositionInWorld + target morphExtentInWorld. - positionOffset _ (self world viewBox containsPoint: botRt) - ifTrue: [evt eventPosition - botRt] - ifFalse: [`0@0`]! ! -!InnerHierarchicalListMorph methodsFor: 'geometry' stamp: 'jmv 6/19/2017 16:36:31' prior: 16854885! - itemFromPoint: aPoint - "Return the list element (morph) at the given point or nil if outside" - | ptY last | - self hasSubmorphs ifFalse: [ ^nil ]. - (aPoint > `0@0` and: [ aPoint < extent ]) ifFalse: [ ^nil ]. - ptY _ aPoint y. - "note: following assumes that submorphs are vertical, non-overlapping, and ordered" - self firstSubmorph morphPosition y > ptY ifTrue: [ ^nil ]. - last _ self lastSubmorph. - last morphPosition y + last morphHeight < ptY ifTrue: [ ^nil ]. - "now use binary search" - ^self - findSubmorphBinary: [ :m | - (m morphPosition y <= ptY and: [ m morphPosition y + m morphHeight >= ptY ]) - ifTrue: [ 0 ] "found" - ifFalse: [ m morphPosition y + (m morphHeight // 2) > ptY ifTrue: [-1] ifFalse: [1]]]! ! -!InnerListMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:53:10' prior: 16855151! - drawBackgroundForMulti: row on: aCanvas - | selectionDrawBounds c | - "shade the background darker, if this row is selected" - selectionDrawBounds _ self drawBoundsForRow: row. - selectionDrawBounds _ selectionDrawBounds intersect: (`0@0` extent: extent). - c _ (selectedRow notNil and: [ row = selectedRow]) - ifTrue: [ Theme current listHighlightFocused: owner hasKeyboardFocus ] - ifFalse: [ Theme current listMultiHighlightFocused: owner hasKeyboardFocus ]. - aCanvas fillRectangle: selectionDrawBounds color: c! ! -!InnerListMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:53:15' prior: 16855170! - drawHighlightOn: aCanvas -"Ademas, poner el mouse pointer de relojito si tarda... Detectarlo automaticamente, etc. Aunque no estoy seguro de como hacerlo... quizas colgar un cachito de codigo en un proceso de mayor prioridad, onda 'si pasa 1 segundo, y todavia no te resetee este flag, entonces pone el relojito'" - | selectionDrawBounds | - highlightedRow ifNil: [ ^self ]. - highlightedRow = 0 ifTrue: [ ^self ]. - selectionDrawBounds _ self drawBoundsForRow: highlightedRow. - selectionDrawBounds _ selectionDrawBounds intersect: (`0@0` extent: extent). - aCanvas - fillRectangle: selectionDrawBounds - color: (Theme current listHighlightFocused: owner hasKeyboardFocus) duller! ! -!InnerListMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:53:20' prior: 16855209! - drawSelectionOn: aCanvas - | selectionDrawBounds | - selectedRow ifNil: [ ^self ]. - selectedRow = 0 ifTrue: [ ^self ]. - selectionDrawBounds _ self drawBoundsForRow: selectedRow. - selectionDrawBounds _ selectionDrawBounds intersect: (`0@0` extent: extent). - aCanvas - fillRectangle: selectionDrawBounds - color: (Theme current listHighlightFocused: owner hasKeyboardFocus)! ! -!InnerTextMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:53:24' prior: 16855570! - drawOn: aCanvas - "Draw the receiver on a canvas" - - false ifTrue: [ self debugDrawLineRectsOn: aCanvas ]. "show line rects for debugging" - - aCanvas - textComposition: self textComposition - bounds: (`0@0` extent: extent) - color: color - selectionColor: (Theme current textHighlightFocused: self hasKeyboardFocus)! ! -!ResizeMorph methodsFor: 'as yet unclassified' stamp: 'jmv 6/19/2017 16:15:44' prior: 50360552! - initialize - super initialize. - extent _ `400@300`. - color _ Color white. - grid _ `8@6`. - gridLineWidth _ 2. - gridColor _ Color black. - selectionColor _ Color red! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:03:19' prior: 16844103! - createAcceptButton - "create the [accept] button" - | result | - result _ PluggableButtonMorph new - model: self; - color: Theme current acceptButton; - label: 'Accept'; - action: #acceptClicked. - result morphExtent: `6@2` * self sizeUnit. - self addMorph: result position: `2@7.5` * self sizeUnit // 1. - ^ result! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:03:31' prior: 16844116! -createCancelButton - "create the [cancel] button" - | result | - result _ PluggableButtonMorph new - model: self; - color: Theme current cancelButton; - label: 'Cancel'; - action: #cancelClicked. - result morphExtent: `6@2` * self sizeUnit. - self addMorph: result position: `12@7.5` * self sizeUnit // 1. - ^ result! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:03:37' prior: 16844129! - createQueryTextMorph: queryString - "create the queryTextMorph" - | result | - result _ StringMorph new contents: queryString. - result lock. - result morphExtent: `24@2` * self sizeUnit. - self addMorph: result position: `2@0.5` * self sizeUnit // 1. - ^ result! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:03:44' prior: 16844140! - createTextPaneAcceptOnCR: acceptBoolean - "create the textPane" - | result | - - self flag: #todo. "Integrate this method with the Theme system. --cbr" - - result _ TextModelMorph - textProvider: self - textGetter: #response - textSetter: #response: - selectionGetter: #selectionInterval. - result hasUnacceptedEdits: true. - result acceptOnCR: acceptBoolean. - result morphExtent: `18@5` * self sizeUnit. - self addMorph: result position: `1@2` * self sizeUnit. - ^ result! ! -!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:03:48' prior: 16844169! - initialize - - super initialize. - extent _ `20@10` * self sizeUnit. - responseUponCancel _ ''! ! -!FillInTheBlankMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:48:53' prior: 16844226! - drawOn: aCanvas - - Theme current roundWindowCorners - ifTrue: [ - aCanvas - roundRect: (`0@0` extent: extent) - color: color - radius: Theme current roundedWindowRadius ] - ifFalse: [ super drawOn: aCanvas ]! ! -!TranscriptMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:58:30' prior: 16938600! - drawOn: aCanvas - Transcript - showOnDisplay: true; - displayOn: form in: (`0@0` extent: extent). - aCanvas image: form at: `0@0`. - Transcript - bounds: self morphBoundsInWorld; - showOnDisplay: doImmediateUpdates. - self updateWorkspace! ! -!MenuLineMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:54:11' prior: 16866232! - drawOn: aCanvas - | baseColor | - baseColor _ owner color. - aCanvas - fillRectangle: (`0@0` corner: extent x @ (extent y / 2)) - color: baseColor twiceDarker. - - aCanvas - fillRectangle: (0 @ (extent y / 2) corner: extent) - color: baseColor twiceLighter! ! -!MenuLineMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:06:38' prior: 16866243! -initialize - super initialize. - extent _ `50 @ 2`! ! -!MenuLineMorph methodsFor: 'geometry' stamp: 'jmv 6/19/2017 16:07:43' prior: 16866250! - minimumExtent - - ^`10@2`! ! -!WorldState methodsFor: 'update cycle' stamp: 'jmv 6/19/2017 15:59:45' prior: 50339595! - tryDeferredUpdatingAndSetCanvas - "If this platform supports deferred updates, then make my canvas be the Display (or a rectangular portion of it), set the Display to deferred update mode, and answer true. Otherwise, set a non-Disply canvas and answer false.." - | properDisplay | - - "As this is the only sender of #deferUpdates: , this could be done in Morphic or image startup, and never efterwards..." - (Display deferUpdates: true) ifNil: [ - "deferred updates not supported by the VM, do them in the image!!" - self ensureNonDisplayCanvas. - ^ false]. - - "if no canvas, or canvas was offscreen, from a platform that didnt support defers, then fix it" - properDisplay _ canvas notNil and: [canvas drawsOnDisplay]. - properDisplay ifFalse: [ - world morphPosition: `0@0` extent: Display extent. - self setCanvas: Display getCanvas. - ]. - ^ true! ! -!MorphicEvent methodsFor: 'dispatching' stamp: 'jmv 6/19/2017 15:54:47' prior: 16877833! - startDispatchFrom: aHand - "double dispatch the event dispatch" - "An event of an unknown type was sent. What shall we do?!!" - - Smalltalk beep. - self printString displayAt: `0@0`. - self wasHandled: true! ! -!MorphicCanvas methodsFor: 'accessing' stamp: 'jmv 6/19/2017 15:54:34' prior: 16877393! - newClipRect: aRectangleOrNil - "aRectangle is in world coordinates. - But ivar clipRect is relative to the form, - For example, if we had previously been built like - aCanvas on: someForm over: (100@100 extent 200@100) - then our origin would be -100 @ -100. - Then, a clipRect argument like (120@120 extent: 40@30) would mean affecting - only (20@20 extent: 40@30) in our form" - - self setClipRect: (aRectangleOrNil - ifNil: [ `0@0` corner: form extent ] - ifNotNil: [ aRectangleOrNil translatedBy: self canvasOrigin ])! ! -!MorphicCanvas methodsFor: 'morphic' stamp: 'jmv 6/19/2017 16:08:51' prior: 50360743! - drawCurrentAsError - "The morph (or one of its submorphs) had an error in its drawing method." - | r w | - r _ currentMorph morphLocalBounds. - w _ r extent > `50@50` - ifTrue: [ 6 ] - ifFalse: [ 2 ]. - self - frameAndFillRectangle: r - fillColor: Color red - borderWidth: w - borderColor: Color yellow. - self line: r topLeft to: r bottomRight-w width: w color: Color yellow. - self line: r topRight -(w@0) to: r bottomLeft -(0@w)width: w color: Color yellow! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 6/19/2017 16:09:00' prior: 50360760! - drawStringEmbossed: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - aColor = Color black ifFalse: [ | topColor | - topColor _ aColor alphaMixed: 0.25 with: Color black. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint - font: fontOrNil - color: topColor ]. - aColor = Color white ifFalse: [ | bottomColor | - bottomColor _ aColor alphaMixed: 0.22 with: Color white. - self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + `0@2` - font: fontOrNil - color: bottomColor ]. - ^self - drawString: aString - from: firstIndex - to: lastIndex - at: aPoint + `0@1` - font: fontOrNil - color: aColor! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 6/19/2017 15:54:38' prior: 16877657! - textComposition: aTextComposition bounds: boundsRect color: c selectionColor: sc - | displayScanner leftInRun line boundsInWorld tl | - - tl _ boundsRect topLeft. - boundsInWorld _ currentTransformation displayBoundsOfTransformOf: boundsRect. - - displayScanner _ MorphicScanner new - defaultFont: aTextComposition defaultFont; - text: aTextComposition textComposed - foreground: c. - displayScanner canvas: self. - - leftInRun _ 0. - "Take clipRect into account. Extrememly fast scrolls and redraws of huge files (like .sources)" - (aTextComposition lineIndexForPoint: (`0@0` max: (clipLeft@clipTop)- boundsInWorld origin)) - to: (aTextComposition lineIndexForPoint: (boundsInWorld extent min: (clipRight@clipBottom+1) - boundsInWorld origin)) - do: [ :i | - line _ aTextComposition lines at: i. - aTextComposition - displaySelectionInLine: line - on: self - textTopLeft: tl - selectionColor: sc. - leftInRun _ displayScanner displayLine: line textTopLeft: tl leftInRun: leftInRun ]! ! -!MorphicCanvas class methodsFor: 'instance creation' stamp: 'jmv 6/19/2017 15:54:43' prior: 16877740! - onForm: aForm - - ^ self basicNew - initializeWith: aForm origin: `0@0`! ! -!BitBltCanvas methodsFor: 'private' stamp: 'jmv 6/19/2017 15:45:38' prior: 16787053! - fillRectangle: aRectangle tilingWith: aForm sourceRect: patternBox rule: aCombinationRule - "aRectangle is in form coordinates, no transformation is done." - | displayRectangle additionalOffset clippedPort targetTopLeft clipOffset ex - targetBox savedMap top left | - - ex _ patternBox extent. - ex x = 0 ifTrue: [ ^self ]. - ex y = 0 ifTrue: [ ^self ]. - displayRectangle _ currentTransformation displayBoundsOfTransformOf: aRectangle. - - "this is a bit of a kludge to get the form to be aligned where I *think* it should be. - something better is needed, but not now" - - additionalOffset _ `0@0`. - clippedPort _ port clippedBy: displayRectangle. - targetTopLeft _ clippedPort clipRect topLeft truncateTo: ex. - clipOffset _ displayRectangle topLeft - targetTopLeft. - additionalOffset _ (clipOffset \\ ex) - ex. - - "do it iteratively" - targetBox _ clippedPort clipRect. - savedMap _ clippedPort colorMap. - clippedPort sourceForm: aForm; - fillColor: nil; - combinationRule: aCombinationRule; - sourceRect: patternBox; - colorMap: (aForm colormapIfNeededFor: clippedPort destForm). - top _ (targetBox top truncateTo: patternBox height) + additionalOffset y. - left _ (targetBox left truncateTo: patternBox width) + additionalOffset x. - - left to: (targetBox right - 1) by: patternBox width do: [:x | - top to: (targetBox bottom - 1) by: patternBox height do: [:y | - clippedPort destOrigin: x@y; copyBits]]. - clippedPort colorMap: savedMap! ! -!BitBltCanvas class methodsFor: 'cached forms' stamp: 'jmv 6/19/2017 15:45:51' prior: 50360832! - steButtonForm: extent - ^self cachedForms - at: { #steButton . extent } - ifAbsentPut: [ - | form canvas | - form _ Form extent: extent depth: 32. - canvas _ form getCanvas. - canvas - roundRect: (`0@0` extent: extent) - color: (Color gray: 0.4) - radius: 4. - canvas - roundRect: (`1@1` extent: extent-2) - color: Color white - radius: 4 - gradientTop: 1.0 - gradientCenter: 0.73 - gradientBottom: 0.94 - gradient1Height: (extent y-8+1 max: extent y//2). - form]! ! -!BitBltCanvas class methodsFor: 'cached arrow forms' stamp: 'jmv 6/19/2017 16:01:13' prior: 50360909! - buildArrowWith: insideForm borderForm: borderForm - | extent translucentForm color insideSpec borderSpec border background alpha| - " - Display getCanvas - image: (BitBltCanvas buildArrowWith: BitBltCanvas downInsideForm borderForm: BitBltCanvas downBorderForm) - at: 20@20 - Display getCanvas - image: (BitBltCanvas buildArrowWith:BitBltCanvas upInsideForm borderForm: BitBltCanvas upBorderForm) - at: 40@20 - " - extent _ insideForm extent - `1@2`. - translucentForm _ Form extent: insideForm extent depth: 32. - 0 to: extent x-1 do: [ :x | - 0 to: extent y-1 do: [ :y | - insideSpec _ insideForm colorAt: x@(y+1). - borderSpec _ borderForm colorAt: x@(y+1). - insideSpec = (Color r: 0.0 g: 0.0 b: 1.0) - ifTrue: [ color _ Color transparent ] - ifFalse: [ - borderSpec = (Color r: 1.0 g: 0.0 b: 0.0) - ifTrue: [ color _ insideSpec ] - ifFalse: [ - border _ x < (extent x//2) - ifTrue: [Color white] - ifFalse: [Color black]. - background _ borderForm colorAt: extent x@(y+1). - alpha _ borderSpec red asFloat - background red / (border red - background red). - color _ border alpha: (alpha min: 1 max: 0) ]]. - translucentForm colorAt: x@y put: color ]]. - ^translucentForm! ! -!TextComposition methodsFor: 'selection' stamp: 'jmv 6/19/2017 16:13:22' prior: 16931067! - defaultCharacterBlock - ^ CharacterBlock - stringIndex: 1 - text: model actualContents - topLeft: lines first topLeft - extent: `0 @ 0` - textLine: lines first! ! -!DifferenceFinder methodsFor: 'private' stamp: 'jmv 6/19/2017 16:02:44' prior: 16834082! - maxLengthPoints - | max points | - max := self maxLength. - max = 0 ifTrue: [^Array with: `0 @ 0`]. - points := OrderedCollection new. - tally withIndexesDo: [:i :j :t | t = max ifTrue: [points add: i @ j]]. - ^points! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3115-UseLiteralPoints-JuanVuletich-2017Jun19-16h29m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3115] on 20 June 2017 at 5:50:34 pm'! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 6/20/2017 13:47:09' prior: 16919543! - browseObsoleteMethodReferences - "Open a browser on all referenced behaviors that are obsolete - Smalltalk browseObsoleteMethodReferences - Remember that if no methods reference obsoletes, but - Smalltalk obsoleteBehaviors inspect - still finds them, maybe they are referenced by ChangeSets!! - " - | list | - list _ self obsoleteMethodReferences. - self browseMessageList: list name:'Method referencing obsoletes' autoSelect: nil! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 6/20/2017 13:46:17' prior: 16919851! - obsoleteBehaviors - " - Smalltalk obsoleteBehaviors inspect - Find all obsolete behaviors including meta classes - " - | obs | - obs _ OrderedCollection new. - Smalltalk garbageCollect. - self allObjectsDo: [ :cl | - (cl isBehavior and: [cl isObsolete]) ifTrue: [obs add: cl]]. - ^ obs asArray! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 6/20/2017 13:46:10' prior: 16919891! - obsoleteMethodReferences - " - Smalltalk obsoleteMethodReferences - Smalltalk browseObsoleteMethodReferences - Open a browser on all referenced behaviors that are obsolete" - | obsClasses obsRefs references | - references _ WriteStream on: Array new. - obsClasses _ self obsoleteBehaviors. - 'Scanning for methods referencing obsolete classes' displayProgressAt: Sensor mousePoint - from: 1 to: obsClasses size during: [ :bar | - obsClasses keysAndValuesDo: [ :index :each | - bar value: index. - obsRefs _ self pointersTo: each except: obsClasses. - obsRefs do: [ :ref | - "Figure out if it may be a global" - (ref isVariableBinding and: [ ref key isString "or Symbol" ]) ifTrue: [ - (self pointersTo: ref) do: [ :meth | - (meth is: #CompiledMethod) ifTrue: [ - meth methodReference ifNotNil: [ :mref | - (mref isValid and: [ mref compiledMethod == meth]) ifTrue: [ - references nextPut: mref ]]]]]]]. - ]. - ^references contents! ! -!MethodReference methodsFor: 'queries' stamp: 'jmv 6/20/2017 13:30:02' prior: 16873082! - printOn: aStream - "Print the receiver on a stream" - - super printOn: aStream. - aStream - space; - nextPutAll: classSymbol. - classIsMeta ifTrue: [ aStream nextPutAll: ' class' ]. - aStream - nextPutAll: ' >> '; - nextPutAll: methodSymbol! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3116-obsoleteMethodRefs-fix-JuanVuletich-2017Jun20-17h49m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3115] on 20 June 2017 at 5:51:43 pm'! -!Color methodsFor: 'conversions' stamp: 'jmv 6/20/2017 17:46:14' prior: 50353450! - pixelValueForDepth: d - "Returns an integer representing the bits that appear in a single pixel of this color in a Form of the given depth. The depth must be one of 1, 2, 4, 8, 16, or 32. Contrast with pixelWordForDepth: and bitPatternForDepth:, which return either a 32-bit word packed with the given pixel value or a multiple-word Bitmap containing a pattern. The inverse is the class message colorFromPixelValue:depth:" - "Details: For depths of 8 or less, the result is a colorMap index. For depths of 16 and 32, it is a direct color value with 5 or 8 bits per color component." - "Transparency: The pixel value zero is reserved for transparent. For depths greater than 8 and less than 32 (no Indexed colors, no real alpha), black maps to the darkest possible blue. - Note that - Color transparent class = TranslucentColor - this special case is handled in TranslucentColor >> #pixelValueForDepth: - " - - | bitBltFakeBlack val | - "Most common case" - "eight bits per component; top 8 bits set to all ones (opaque alpha)" - d = 32 ifTrue: [ - ^ 16rFF000000 bitOr: - ((((self at: 1) * 255.999) truncated bitShift: 16) bitOr: - ((((self at: 2) * 255.999) truncated bitShift: 8) bitOr: - (((self at: 3) * 255.999) truncated))) ]. - -"Faster in 32 bit systems, but slower in 64 bits" -" d = 32 ifTrue: [ - val _ LargePositiveInteger new: 4. - val at: 3 put: ((self at: 1) * 255.999) truncated. - val at: 2 put: ((self at: 2) * 255.999) truncated. - val at: 1 put: ((self at: 3) * 255.999) truncated. - val at: 4 put: 16rFF. - ^ val normalize]." - - d = 8 ifTrue: [^ self closestPixelValue8]. "common case" - d < 8 ifTrue: [ - d = 4 ifTrue: [^ self closestPixelValue4]. - d = 2 ifTrue: [^ self closestPixelValue2]. - d = 1 ifTrue: [^ self closestPixelValue1]]. - - "For the depth 16, pixelValue = 0 means transparent, black is represented as 16r8000 (rgb=0, pixelvalue !!= 0)." - (d = 16) | (d = 15) ifTrue: [ - "five bits per component; top bits ignored" - val _ ((self red * 31) rounded bitShift: 10) bitOr: - (((self green * 31) rounded bitShift: 5) bitOr: - ((self blue * 31) rounded)). - ^ val = 0 - ifTrue: [d = 16 ifTrue: [16r8000] ifFalse: [1]] - ifFalse: [val]]. - - "For the rest of the depths, pixelValue = 0 means transparent, and darkest blue is considered to be black." - bitBltFakeBlack := 1. "closest black that is not transparent in RGB - Not for depths <=8 (Indexed) or = 32 (RGBA)" - d = 12 ifTrue: [ "for indexing a color map with 4 bits per color component" - val _ ((self red * 15) rounded bitShift: 8) bitOr: - (((self green * 15) rounded bitShift: 4) bitOr: - ((self blue * 15) rounded)). - ^ val = 0 ifTrue: [bitBltFakeBlack] ifFalse: [val]]. - - d = 9 ifTrue: [ "for indexing a color map with 3 bits per color component" - val _ ((self red * 7) rounded bitShift: 6) bitOr: - (((self green * 7) rounded bitShift: 3) bitOr: - ((self blue * 7) rounded)). - ^ val = 0 ifTrue: [bitBltFakeBlack] ifFalse: [val]]. - - self error: 'unknown pixel depth: ', d printString! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3117-pixelValueForDepth-speedup-JuanVuletich-2017Jun20-17h50m-jmv.1.cs.st----! - -----SNAPSHOT----#(20 June 2017 5:55:49.418702 pm) Cuis5.0-3117.image priorSource: 400330! - -----QUIT----#(20 June 2017 5:56:01.546904 pm) Cuis5.0-3117.image priorSource: 1058175! - -----STARTUP----#(27 June 2017 7:10:33.593307 am) as /root/PayloadSoftware/Cuis-Smalltalk-Dev/Cuis5.0-3117.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3117] on 20 June 2017 at 11:19:24 pm'! -!WorldState methodsFor: 'initialization' stamp: 'jmv 6/20/2014 20:24:55' prior: 16945777! - clearWaitDelay - waitDelay ifNotNil: [ - waitDelay unschedule. - waitDelay _ nil ]. - "Needed if for some reason Cuis is started with an earlier DateTime than the image was saved. - Might happen, especially on RasPi or other systems without an RTC" - lastCycleTime _ Time localMillisecondClock. - lastAlarmTime _ 0.! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3118-FixHangWhenStartupInThePast-JuanVuletich-2017Jun20-23h18m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3103] on 18 June 2017 at 5:34:41 am'! -!Browser methodsFor: 'class comment pane' stamp: 'pb 6/18/2017 05:34:23' prior: 16791499! - newClassComment: aText - "The user has just entered aText. - It may be all red (a side-effect of replacing the default comment), so remove the color if it is." - | theClass | - theClass _ self selectedClassOrMetaClass theNonMetaClass. - theClass ifNotNil: [ - theClass classComment: aText asString ]. - self changed: #classCommentText. - ^ true! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3119-Class-comment-editor-fix-PhilBellalouna-2017Jun18-05h34m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3119] on 22 June 2017 at 12:54:43 pm'! -!Color methodsFor: 'as yet unclassified' stamp: 'jmv 6/22/2017 12:54:10'! - convertToCurrentVersion: varDict refStream: smartRefStrm - - "subclasses should implement if they wish to convert old instances to modern ones" - self size = 0 ifTrue: [ - ^ Color new copyFrom: (varDict at: 'floatRGB') ]. - ^ self! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3120-MigrateColorInstancesInSmartRefStream-JuanVuletich-2017Jun22-12h43m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3120] on 26 June 2017 at 8:03:37 pm'! -!ReadStream methodsFor: 'accessing' stamp: 'jmv 6/26/2017 19:34:17'! - readInto: byteArray startingAt: startIndex count: count - "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: count. - byteArray - replaceFrom: startIndex - to: startIndex+max-1 - with: collection - startingAt: position+1. - position _ position + max. - ^max! ! - -----End fileIn of /root/PayloadSoftware/Cuis-Smalltalk-Dev/CoreUpdates/3121-ReadStream-readInto-JuanVuletich-2017Jun26-19h32m-jmv.1.cs.st----! - -----SNAPSHOT----#(27 June 2017 7:10:42.11782 am) Cuis5.0-3121.image priorSource: 1058266! - -----QUIT----#(27 June 2017 7:10:56.089378 am) Cuis5.0-3121.image priorSource: 1061095! - -----STARTUP----#(2 August 2017 3:47:45.344369 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3121.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3121] on 6 July 2017 at 3:13:37 am'! -!ScrollBar methodsFor: 'access' stamp: 'pb 7/6/2017 02:44:45'! - scrollValue - ^ value! ! -!ScrollBar methodsFor: 'model access' stamp: 'pb 7/6/2017 02:53:19'! - internalScrollValue: newValue - "Called internally for propagation to model" - self scrollValue: newValue. - setValueSelector ifNotNil: [ - model perform: setValueSelector with: value ]! ! -!ScrollBar methodsFor: 'model access' stamp: 'pb 7/6/2017 02:45:15'! - scrollValue: newValue - "Drive the slider position externally..." - value _ newValue min: 1.0 max: 0.0. - self computeSlider! ! -!ProgressBarMorph methodsFor: 'accessing' stamp: 'pb 7/6/2017 02:42:04'! - progressValue - ^value! ! -!ProgressBarMorph methodsFor: 'accessing' stamp: 'pb 7/6/2017 02:42:12'! - progressValue: aValue - value _ aValue. - self redrawNeeded! ! -!PositionableStream methodsFor: 'fileIn/Out' stamp: 'jmv 10/10/2015 23:26' prior: 16891768! - 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 | - announcement - displayProgressAt: Sensor mousePoint - from: 0 - to: self size - during: [ :bar | - [ self atEnd ] whileFalse: [ - bar value: self position. - self skipSeparators. - - [ - val := (self peekFor: $!!) - ifTrue: [ - chunk := self nextChunk. - "These are the ones that should do nothing, - because next line is a doit that does the stuff - (or because it is handled elsewhere)" - (chunk beginsWith: 'description: ') - | (chunk beginsWith: 'provides: ') - | (chunk beginsWith: 'requires: ') - | (chunk beginsWith: 'classDefinition: ') - | (chunk beginsWith: 'classRemoval: ') - | (chunk beginsWith: 'methodRemoval: ') - | (chunk beginsWith: 'classMoveToSomePackage: ') - | (chunk beginsWith: 'methodMoveToSomePackage: ') - ifFalse: [(Compiler evaluate: chunk logged: false) scanFrom: self]] - ifFalse: [ - chunk := self nextChunk. - self checkForPreamble: chunk. - [ Compiler evaluate: chunk logged: true ] - on: Error - do: [ :ex | - ex print. - ('while evaluating: ', chunk) print. - ex pass ] - ]] - on: InMidstOfFileinNotification - do: [ :ex | ex resume: true ] ]. - ]. - "Note: The main purpose of this banner is to flush the changes file." - Smalltalk logChange: '----End fileIn of ' , self name , '----'. - ^val! ! -!PositionableStream methodsFor: 'gui' stamp: 'pb 7/6/2017 02:51:46' prior: 16892012! - untilEnd: aBlock displayingProgress: aString - aString - displayProgressAt: Sensor mousePoint - from: 0 to: self size - during: [ :bar | - [ self atEnd ] whileFalse: [ - bar scrollValue: self position. - aBlock value ]]! ! -!ProgressInitiationException class methodsFor: 'examples and tests' stamp: 'pb 7/6/2017 02:52:33' prior: 16896176! - testInnermost - - "test the progress code WITHOUT special handling" - - ^'Now here''s some Real Progress' - displayProgressAt: Sensor mousePoint - from: 0 - to: 10 - during: [ :bar | - 1 to: 10 do: [ :x | - bar scrollValue: x. - (Delay forMilliseconds: 500) wait. - x = 5 ifTrue: [1/0]. "just to make life interesting" - ]. - 'done' - ]. - -! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'pb 7/6/2017 02:46:41' prior: 16889660! - hSetScrollDelta - "Set the ScrollBar deltas, value and interval, based on the current scroll pane size, offset and range." - | range delta w | - - delta _ self scrollDeltaWidth * 1.0. "avoid Fraction arithmetic" - range _ self hLeftoverScrollRange. - range = 0 ifTrue: [ - ^hScrollBar scrollDelta: 0.02 pageDelta: 0.2; interval: 1.0; internalScrollValue: 0 ]. - - "Set up for one line (for arrow scrolling), or a full pane less one line (for paging)." - w _ self viewableWidth * 1.0. "avoid Fraction arithmetic" - hScrollBar scrollDelta: delta / range pageDelta: w - delta / range. - hScrollBar interval: w / self hTotalScrollRange. - hScrollBar internalScrollValue: hScrollBar scrollValue! ! -!PluggableScrollPane methodsFor: 'geometry' stamp: 'pb 7/6/2017 02:48:25' prior: 16889801! - vSetScrollDelta - "Set the ScrollBar deltas, value and interval, based on the current scroll pane size, offset and range." - | range delta h | - - delta _ self scrollDeltaHeight * 1.0. "avoid Fraction arithmetic" - range _ self vLeftoverScrollRange. - range = 0 ifTrue: [ - ^ scrollBar scrollDelta: 0.02 pageDelta: 0.2; interval: 1.0; internalScrollValue: 0 ]. - - "Set up for one line (for arrow scrolling), or a full pane less one line (for paging)." - h _ self viewableHeight * 1.0. "avoid Fraction arithmetic" - scrollBar scrollDelta: delta / range pageDelta: h - delta / range. - scrollBar interval: h / self vTotalScrollRange. - scrollBar internalScrollValue: scrollBar scrollValue! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'pb 7/6/2017 02:48:00' prior: 16889930! - hideOrShowScrollBars - - "Assume for a moment we don't need an horizontal scrollbar" - self hHideScrollBar. - - "Add or remove vertical scrollbar, asuming for a monent there's no horizontal scrollbar, - to determine need of horizontal scrollbar..." - self vIsScrollbarNeeded - ifTrue: [ self vShowScrollBar ] - ifFalse: [ self vHideScrollBar ]. - - "If we need an horizontal scrollbar, add it." - self hIsScrollbarNeeded ifTrue: [ - self hShowScrollBar. - - "If horizontal scrollbar is needed, maybe vertical scrollbar will be needed too (even if we previously thoutht it wouldn't be needed)." - "Note that there is no chance of modifying the need of horizontal scrollbar: it was already needed. Therefore, there is no circularity here." - self vIsScrollbarNeeded ifTrue: [ - self vShowScrollBar ]]. - - "Ensure that if no scrollbars are needed, whole contents are visible" - self vIsScrollbarShowing ifFalse: [ - scrollBar internalScrollValue: 0 ]. - self hIsScrollbarShowing ifFalse: [ - hScrollBar internalScrollValue: 0 ]. - - self updateScrollBarsBounds! ! -!PluggableScrollPane methodsFor: 'scrolling' stamp: 'pb 7/6/2017 02:51:24' prior: 16889965! - scrollBy: delta - "Move the contents in the direction delta." - - | newYoffset r newXoffset | - - "Set the offset on the scroller" - newYoffset _ self scrollerOffset y - delta y max: 0. - newXoffset _ self scrollerOffset x - delta x max: 0. - - self scrollerOffset: newXoffset@ newYoffset. - - "Update the scrollBars" - (r _ self vLeftoverScrollRange) = 0 - ifTrue: [ scrollBar scrollValue: 0.0 ] - ifFalse: [ scrollBar scrollValue: newYoffset asFloat / r ]. - (r _ self hLeftoverScrollRange) = 0 - ifTrue: [ hScrollBar scrollValue: 0.0 ] - ifFalse: [ hScrollBar scrollValue: newXoffset asFloat / r ]! ! -!PluggableListMorph methodsFor: 'selection' stamp: 'pb 7/6/2017 02:47:04' prior: 16889020! - scrollSelectionIntoView - "make sure that the current selection is visible" - | row r | - row _ self getCurrentSelectionIndex. - row = 0 - ifTrue: [ - "Value is 0, but we need to propagate it to model" - scrollBar internalScrollValue: scrollBar scrollValue ] - ifFalse: [ - self flag: #jmvVer2. - r _ self listMorph drawBoundsForRow: row. - r _ ((self listMorph externalize: r origin) extent: r extent). - self scrollToShow: r ]! ! -!PluggableListMorphOfMany methodsFor: 'events' stamp: 'pb 7/6/2017 02:56:44' prior: 50362985! - mouseMove: aMouseMoveEvent localPosition: localEventPosition - "The mouse has moved, as characterized by the event provided. Adjust the scrollbar, and alter the selection as appropriate" - - | oldIndex oldVal row | - row _ (localEventPosition y < 0 and: [ scrollBar scrollValue > 0.0 ]) - ifTrue: [ - scrollBar scrollUp: 1. - "Leave at least one visible item unaffected, for better visual feedback to the user." - (self rowAtLocation: `0@0`) + 2 ] - ifFalse: [ - (localEventPosition y > extent y and: [ scrollBar scrollValue < 1.0 ]) - ifTrue: [ - scrollBar scrollDown: 1. - "Leave at least one visible item unaffected, for better visual feedback to the user." - (self rowAtLocation: 0@extent y) - 3 ] - ifFalse: [ self rowAtLocation: localEventPosition ]]. - row = 0 ifTrue: [ ^ self ]. - - "No change if model is locked" - self owningWindow ifNotNil: [ :w | - w okToChange ifFalse: [^ self]]. - - dragOnOrOff ifNil: [ - "Was not set at mouse down, which means the mouse must have gone down in an area where there was no list item" - dragOnOrOff _ (self listSelectionAt: row) not. - dragStartRow _ row ]. - - "Set meaning for subsequent dragging of selection" - oldIndex _ self getCurrentSelectionIndex. - oldIndex ~= 0 ifTrue: [ oldVal _ self listSelectionAt: oldIndex ]. - - "Set or clear new primary selection (listIndex)" - dragOnOrOff - ifTrue: [ self changeModelSelection: row ] - ifFalse: [ self changeModelSelection: 0 ]. - - "Need to restore the old one, due to how model works, and set new one." - oldIndex ~= 0 ifTrue: [ self listSelectionAt: oldIndex put: oldVal ]. - - "Select all in between if drag was too fast" - "self listSelectionAt: row put: dragOnOrOff." - (row min: dragStartRow) to: (row max: dragStartRow) do: [ :r | - self listSelectionAt: r put: dragOnOrOff ]! ! -!ScrollBar methodsFor: 'scrolling' stamp: 'pb 7/6/2017 02:48:48' prior: 16904721! - scrollByPage - "Scroll automatically while mouse is down" - nextPageDirection - ifTrue: [self internalScrollValue: (value + pageDelta min: 1.0)] - ifFalse: [self internalScrollValue: (value - pageDelta max: 0.0)] -! ! -!ScrollBar methodsFor: 'scrolling' stamp: 'pb 7/6/2017 02:48:59' prior: 16904734! - scrollDown: count - self internalScrollValue: (value + (scrollDelta * count) + 0.000001 min: 1.0)! ! -!ScrollBar methodsFor: 'scrolling' stamp: 'pb 7/6/2017 02:49:09' prior: 16904739! - scrollTo: handPositionRelativeToSlider - | v handPositionRelativeToUs | - grabPosition ifNotNil: [ - handPositionRelativeToUs _ slider externalize: handPositionRelativeToSlider. - v _ (self isHorizontal - ifTrue: [ handPositionRelativeToUs x - grabPosition x ] - ifFalse: [ handPositionRelativeToUs y - grabPosition y ]) - - borderWidth - self buttonExtent * 1.0 - / self freeSliderRoom. - self internalScrollValue: v ]! ! -!ScrollBar methodsFor: 'scrolling' stamp: 'pb 7/6/2017 02:49:21' prior: 16904758! - scrollUp: count - self internalScrollValue: (value - (scrollDelta * count) - 0.000001 max: 0.0)! ! -!ProgressBarMorph methodsFor: 'menu' stamp: 'pb 7/6/2017 02:57:29' prior: 16896049! - changeProgressValue: evt - | answer | - answer _ FillInTheBlankMorph - request: 'Enter new value (0 - 1.0)' - initialAnswer: self progressValue contents asString. - answer isEmptyOrNil ifTrue: [^ self]. - self progressValue: answer asNumber! ! -!ProgressMorph methodsFor: 'accessing' stamp: 'pb 7/6/2017 02:57:41' prior: 16896233! - done - ^progress progressValue! ! -!ProgressMorph methodsFor: 'accessing' stamp: 'pb 7/6/2017 02:52:47' prior: 16896236! - done: amountDone - progress progressValue: ((amountDone min: 1.0) max: 0.0)! ! -!InnerTextMorph methodsFor: 'editing' stamp: 'pb 7/6/2017 02:47:26' prior: 50336501! - acceptContents - "The message is sent when the user hits return or Cmd-S. - Accept the current contents and end editing." - "Inform the model of text to be accepted, and return true if OK." - - | accepted prevSelection prevScrollValue | - - prevSelection _ self editor selectionInterval copy. - prevScrollValue _ owner verticalScrollBar scrollValue. - - (self canDiscardEdits and: [(self hasProperty: #alwaysAccept) not]) ifTrue: [self flash. ^true]. - (self hasEditingConflicts and: [ self confirmAcceptAnyway not ]) ifTrue: [self flash. ^false]. - - accepted _ model acceptContentsFrom: owner. - "During the step for the browser, updatePaneIfNeeded is called, and - invariably resets the contents of the code-holding PluggableTextMorph - at that time, resetting the cursor position and scroller in the process. - The following line forces that update without waiting for the step, - then restores the cursor and scrollbar" - - "some implementors of acceptContentsFrom: answer self :(" - ^accepted == true - ifTrue: [ - model refetch. - self editor selectFrom: prevSelection first to: prevSelection last. - WorldState addDeferredUIMessage: [ - self world ifNotNil: [ :w | w activeHand newKeyboardFocus: self ]. - owner verticalScrollBar internalScrollValue: prevScrollValue]. - true] - ifFalse: [ false ]! ! - -ProgressBarMorph removeSelector: #value! - -ProgressBarMorph removeSelector: #value! - -ProgressBarMorph removeSelector: #value:! - -ProgressBarMorph removeSelector: #value:! - -ScrollBar removeSelector: #setValue:! - -ScrollBar removeSelector: #setValue:! - -ScrollBar removeSelector: #value! - -ScrollBar removeSelector: #value! - -ScrollBar removeSelector: #value:! - -ScrollBar removeSelector: #value:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3122-Morphs-Distinct-value-Methods-PhilBellalouna-2017Jul06-02h42m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3121] on 15 July 2017 at 10:07:51 pm'! -!UpdatingStringMorph methodsFor: 'stepping' stamp: 'pb 7/15/2017 22:07:40' prior: 50337159! - stepAt: millisecondSinceLast - - self contents: (target perform: getSelector) asString! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3123-UpdatingStringMorph-Squeak-compatibility-PhilBellalouna-2017Jul15-22h07m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3121] on 15 July 2017 at 11:19:17 pm'! -!PluggableButtonMorph methodsFor: 'as yet unclassified' stamp: 'pb 7/15/2017 23:15:35'! - morphExtent - "Use extent if it has already been manually set, otherwise try to set it by computing from the label text and font, otherwise try using the icon extent, or finally fall back to the default value." - ^ extent ifNil: [ - extent := (self fontToUse notNil and: [ label notNil ]) - ifTrue: [ "Add a bit of padding" - (self fontToUse widthOfString: label) + 10 @ (self fontToUse height + 10) ] - ifFalse: [ - icon - ifNil: [ `20@15` ] - ifNotNil: [ icon extent ]]].! ! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'pb 7/15/2017 22:34:12' prior: 16899252! - morphHeight - -"Ensure everybody wants our coordinates!!" - self flag: #jmvVer2. - ^ self morphExtent y! ! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'pb 7/15/2017 22:34:52' prior: 16899265! - morphPosition: newPos extent: newExtent - "Change the position of this morph. Argument is in owner's coordinates." - - | oldBoundsInWorld someChange | - - "Ask for the old bounds before updating them, but ask for repair only if extent or position has really changed." - oldBoundsInWorld _ self morphBoundsInWorld. - someChange _ false. - (location isTranslation: newPos) ifFalse: [ - location _ location withTranslation: newPos. - someChange _ true ]. - - self morphExtent = newExtent ifFalse: [ - (self privateExtent: newExtent) ifTrue: [ - someChange _ true ]]. - - someChange ifTrue: [ - "Ask for the old bounds before updating them, but ask for repair only if extent or position has really changed." - oldBoundsInWorld ifNotNil: [ - self invalidateDisplayRect: oldBoundsInWorld from: nil ]. - self someSubmorphPositionOrExtentChanged. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]! ! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'pb 7/15/2017 22:34:20' prior: 16899296! - morphWidth - -"Ensure everybody wants our coordinates!!" - self flag: #jmvVer2. - ^ self morphExtent x! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'pb 7/15/2017 22:40:30' prior: 50362830! - draw3DLookOn: aCanvas - - | borderStyleSymbol c | - borderStyleSymbol _ self isPressed ifFalse: [ #raised ] ifTrue: [ #inset ]. - c _ color. - self mouseIsOver ifTrue: [ c _ c lighter ]. - aCanvas - fillRectangle: (`0@0` extent: self morphExtent) - color: c - borderWidth: borderWidth - borderStyleSymbol: borderStyleSymbol - baseColorForBorder: c. - - self drawRegularLabelOn: aCanvas! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'pb 7/15/2017 22:40:17' prior: 16888097! - drawEmbossedLabelOn: aCanvas - - | availableW center colorForLabel f l labelMargin targetSize w x y | - label ifNotNil: [ - colorForLabel _ Theme current buttonLabel. - self isPressed - ifFalse: [ - self mouseIsOver - ifFalse: [ colorForLabel _ colorForLabel adjustSaturation: -0.10 brightness: 0.10 ]] - ifTrue: [ colorForLabel _ colorForLabel adjustSaturation: 0.0 brightness: -0.07 ]. - f _ self fontToUse. - center _ self morphExtent // 2. - labelMargin _ 3. - w _ f widthOfString: label. - availableW _ self morphExtent x - labelMargin - labelMargin. - availableW >= w - ifTrue: [ - l _ label ] - ifFalse: [ - x _ labelMargin. - targetSize _ label size * availableW // w. - l _ label squeezedTo: targetSize. - (f widthOfString: l) > availableW ifTrue: [ - targetSize _ targetSize - 1. - l _ label squeezedTo: targetSize ]]. - - w _ f widthOfString: l. - x _ center x - (w // 2). - y _ center y - (f height // 2). - aCanvas - drawString: l - at: x@y - font: f - color: colorForLabel - embossed: true ]! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'pb 7/15/2017 22:39:57' prior: 16888142! - drawRegularLabelOn: aCanvas - - | w f center x y availableW l labelMargin | - - f _ self fontToUse. - center _ self morphExtent // 2. - - label ifNotNil: [ - labelMargin _ 4. - w _ f widthOfString: label. - availableW _ self morphExtent x - labelMargin - labelMargin - 1. - availableW >= w - ifTrue: [ - x _ center x - (w // 2). - l _ label ] - ifFalse: [ - x _ labelMargin. - l _ label squeezedTo: (label size * availableW / w) rounded ]. - y _ center y - (f height // 2). - self isPressed ifTrue: [ - x _ x + 1. - y _ y + 1 ]. - aCanvas - drawString: l - at: x@y - font: f - color: Theme current buttonLabel ]! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'pb 7/15/2017 22:39:34' prior: 50362845! - drawRoundGradientLookOn: aCanvas - | r colorForButton rect bottomFactor topFactor | - - self isPressed - ifFalse: [ - topFactor _ Theme current buttonGradientTopFactor. - bottomFactor _ Theme current buttonGradientBottomFactor. - self mouseIsOver - ifTrue: [ - colorForButton _ Color h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ - colorForButton _ color ]] - ifTrue: [ - topFactor _ Theme current buttonGradientBottomFactor. - bottomFactor _ Theme current buttonGradientTopFactor. - colorForButton _ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - Theme current useButtonGradient - ifTrue: [ - rect _ (`0@0` extent: self morphExtent) insetBy: `1@3`. - aCanvas - roundRect: rect - color: colorForButton - radius: r - gradientTop: topFactor - gradientBottom: bottomFactor - gradientHeight: Theme current buttonGradientHeight ] - ifFalse: [ - rect _ (`0@0` extent: self morphExtent) insetBy: `1@3`. - aCanvas roundRect: rect color: colorForButton radius: r ] - ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawEmbossedLabelOn: aCanvas ] - ifFalse: [ self drawRegularLabelOn: aCanvas ]! ! -!PluggableButtonMorph methodsFor: 'initialization' stamp: 'pb 7/15/2017 22:36:46' prior: 50362887! - initialize - "initialize the state of the receiver" - super initialize. - - roundButtonStyle := nil. "nil: honor Theme. true: draw as round button. false: draw as classic 3d border square button" - model := nil. - getStateSelector := nil. - actionSelector := nil. - isPressed := false. - mouseIsOver := false. - actWhen := #buttonUp. - "We are overriding any value populated in extent by our superclass with nil so we know to perform the inital morph extent calculation" - extent := nil! ! -!PluggableButtonMorph methodsFor: 'private' stamp: 'pb 7/15/2017 22:36:28' prior: 50337971! - magnifiedIcon - | factor magnifiedExtent w h | - - icon ifNil: [ ^nil ]. - magnifiedIcon ifNil: [ - magnifiedIcon := icon. - w := icon width. - h := icon height. - w*h = 0 ifFalse: [ - factor _ 1.0 * self morphExtent x / w min: 1.0 * self morphExtent y / h. - (factor < 1 or: [ factor > 1.7 and: [self isRoundButton]]) ifTrue: [ - magnifiedExtent := (icon extent * factor) rounded. - magnifiedIcon := icon magnifyTo: magnifiedExtent ]]]. - ^magnifiedIcon! ! -!PluggableButtonMorph methodsFor: 'geometry testing' stamp: 'pb 7/15/2017 22:38:44' prior: 50362901! - morphContainsPoint: aLocalPoint - - | iconOrigin | - ((`0@0` extent: self morphExtent) containsPoint: aLocalPoint) ifFalse: [ ^false ]. - ^ self isOrthoRectangularMorph or: [ - magnifiedIcon isNil or: [ - iconOrigin := self morphExtent - magnifiedIcon extent // 2. - (magnifiedIcon isTransparentAt: (aLocalPoint - iconOrigin) rounded) not ]]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3124-PluggableButtonMorph-initial-extent-PhilBellalouna-2017Jul15-22h29m-pb.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3121] on 16 July 2017 at 3:33:18 pm'! -!Morph methodsFor: 'events' stamp: 'pb 7/16/2017 15:06:53'! - mouseHover: aMouseMoveEvent localPosition: localEventPosition - "Handle a mouse move event. - This message will only be sent to Morphs that answer true to #handlesMouseHover for events that have not been previously handled. - We can query aMouseMoveEvent to know about pressed mouse buttons." - "Allow instances to dynamically use properties for handling common events." - self - valueOfProperty: #mouseHover:localPosition: - ifPresentDo: [ :handler | - handler - value: aMouseMoveEvent - value: localEventPosition ].! ! -!Morph methodsFor: 'event handling testing' stamp: 'pb 7/16/2017 15:00:51'! - handlesMouseHover - "Do I want to receive unhandled mouseMove events when the button is up and the hand is empty? The default response is false." - "Use a property test to allow individual instances to specify this." - ^ self hasProperty: #handlesMouseHover.! ! -!Morph methodsFor: 'events-processing' stamp: 'pb 7/16/2017 15:31:38' prior: 16875080! - processMouseOver: aMouseEvent localPosition: localEventPosition - "System level event handling." - self hasMouseFocus ifTrue: [ - "Got this directly through #handleFocusEvent: so check explicitly" - (self containsPoint: localEventPosition event: aMouseEvent) ifFalse: [ - ^self ]]. - aMouseEvent hand noticeMouseOver: self event: aMouseEvent. - "Open question: should any unhandled mouse move events be filtered out? (i.e. should mouseHover:localPosition: be called when a mouse button is pressed but the morph doesn't have mouse button handlers? Essentially, what are the limits of what is considered 'hovering'?" - (self handlesMouseHover and: [aMouseEvent wasHandled not]) ifTrue: [ - self - mouseHover: aMouseEvent - localPosition: localEventPosition ].! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3125-Morph-hovering-PhilBellalouna-2017Jul16-15h00m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3122] on 17 July 2017 at 3:52:45 pm'! -!ChangeList methodsFor: 'scanning' stamp: 'jmv 7/17/2017 15:44:04' prior: 16795940! - scanFile: aFile from: startPosition to: stopPosition - - file _ aFile. - changeList _ OrderedCollection new. - list _ OrderedCollection new. - listIndex _ 0. - file position: startPosition. - 'Scanning ', aFile localName, '...' - displayProgressAt: Sensor mousePoint - from: startPosition to: stopPosition - during: [ :barBlock | - [file position < stopPosition] whileTrue: [ | prevChar | - barBlock value: file position. - [file atEnd not and: [file peek isSeparator]] - whileTrue: [prevChar _ file next]. - (file peekFor: $!!) - ifTrue: [ - "A line starting with $!! means a specific ChangeRecord type" - (prevChar notNil and: [ prevChar isLineSeparator ]) - ifTrue: [self scanSpecificChangeRecordType]] - ifFalse: [ - "Otherwise, interpret it with #doIt:" - | itemPosition item | - itemPosition _ file position. - item _ file nextChunk. - item size > 0 ifTrue: [ - self - addItem: (ChangeRecord new file: file position: itemPosition type: #doIt) - text: 'do it: ' , (item contractTo: 160)]]]]. - self clearSelections! ! -!ClassBuilder methodsFor: 'private' stamp: 'jmv 7/17/2017 15:48:14' prior: 16803943! - informUserDuring: aBlock - self class isSilent ifTrue:[^aBlock value]. - Utilities informUserDuring:[:barBlock| - progress _ barBlock. - aBlock value]. - progress _ nil.! ! -!Integer class methodsFor: 'prime numbers' stamp: 'jmv 7/17/2017 15:44:55' prior: 16861068! - verbosePrimesUpTo: max do: aBlock - "Integer verbosePrimesUpTo: SmallInteger maxVal" "<- heh, heh" - "Compute primes up to max, but be verbose about it" - | lastTime | - lastTime := Time localMillisecondClock. - Utilities informUserDuring: [ :barBlock| - barBlock value:'Computing primes...'. - self primesUpTo: max do: [ :prime| | nowTime | - aBlock value: prime. - nowTime := Time localMillisecondClock. - (nowTime - lastTime > 1000) ifTrue:[ - lastTime := nowTime. - barBlock value: 'Last prime found: ', prime printString]]].! ! -!LookupKey methodsFor: 'bindings' stamp: 'jmv 7/17/2017 15:45:04' prior: 16865388! - recompileBindingsAnnouncing: aBool - "Make the receiver (a global read-write binding) be a read-only binding" - aBool ifTrue:[ - Utilities informUserDuring: [ :barBlock | - (Smalltalk allCallsOn: self) do: [ :mref | - barBlock value: 'Recompiling ', mref stringVersion. - mref actualClass recompile: mref methodSymbol ]. - ]. - ] ifFalse:[ - (Smalltalk allCallsOn: self) do: [ :mref | - mref actualClass recompile: mref methodSymbol ] - ]! ! -!SequenceableCollection methodsFor: 'gui' stamp: 'jmv 7/17/2017 15:45:17' prior: 16906997! - do: aBlock displayingProgress: aString - aString - displayProgressAt: Sensor mousePoint - from: 0 to: self size - during: [ :barBlock | - self withIndexDo: [ :each :i | - barBlock value: i. - aBlock value: each]]! ! -!String methodsFor: 'displaying' stamp: 'jmv 7/17/2017 15:41:46' prior: 16917058! - 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 mousePoint - from: 0 to: 100 - during: [:barBlock | - 1 to: 100 do: [:x | - (Delay forMilliseconds: 10) wait. - barBlock value: x.]]. - -['Now here''s some Real Progress' - displayProgressAt: Sensor mousePoint - from: 0 to: 100 - during: [:barBlock | - 1 to: 100 do: [:x | barBlock value: x. - (Delay forMilliseconds: 100) wait]].] fork - -['Now here''s some Real Progress' - displayProgressAt: Sensor mousePoint - from: 0 to: 10 - during: [:barBlock | - 1 to: 30 do: [:x | barBlock value: x \\ 11. - (Delay forMilliseconds: 100) wait]]] fork - -'Now here''s some Real Progress' - displayProgressAt: Sensor mousePoint - from: 0 to: 10 - during: [:barBlock | - 1 to: 30 do: [:x | barBlock value: nil. - (Delay forMilliseconds: 200) 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. - -The use of ProgressInitiationException allows for avoiding actual -progress display, by catching the exception. -" - ^ProgressInitiationException - display: self - at: aPoint - from: minVal - to: maxVal - during: workBlock! ! -!Set class methodsFor: 'initialization' stamp: 'jmv 7/17/2017 15:40:16' prior: 16907390! - quickRehashAllSets "Set rehashAllSets" - | insts | - self withAllSubclassesDo: - [:c | - insts _ c allInstances. - (insts isEmpty or: [c = MethodDictionary]) ifFalse: - ['Rehashing instances of ' , c name - displayProgressAt: Sensor mousePoint - from: 1 to: insts size - during: [ :barBlock | 1 to: insts size do: [:x | barBlock value: x. (insts at: x) rehash]] - ] - ]! ! -!Set class methodsFor: 'initialization' stamp: 'jmv 7/17/2017 15:40:27' prior: 16907404! - rehashAllSets "Set rehashAllSets" - | insts | - self withAllSubclassesDo: - [:c | insts _ c allInstances. - insts isEmpty ifFalse: - ['Rehashing instances of ' , c name - displayProgressAt: Sensor mousePoint - from: 1 to: insts size - during: [ :barBlock | - 1 to: insts size do: - [ :x | barBlock value: x. - (insts at: x) rehash]]]]! ! -!Dictionary methodsFor: 'removing' stamp: 'jmv 7/17/2017 15:44:29' prior: 16833635! - unreferencedKeys - "| uk | (Time millisecondsToRun: [uk := TextConstants unreferencedKeys]) -> uk" - - ^'Scanning for references . . .' - displayProgressAt: Sensor mousePoint - from: 0 - to: Smalltalk classNames size * 2 - during: - [:barBlock | | currentClass n associations referencedAssociations | - currentClass := nil. - n := 0. - associations := self associations asIdentitySet. - referencedAssociations := IdentitySet new: associations size. - Smalltalk allSelect: - [:m| - m methodClass ~~ currentClass ifTrue: - [currentClass := m methodClass. - barBlock value: (n := n + 1)]. - m literalsDo: - [:l| - (l isVariableBinding and: [associations includes: l]) ifTrue: - [referencedAssociations add: l]]. - false]. - ((associations reject: [:assoc | referencedAssociations includes: assoc]) collect: [:assoc| assoc key]) asSet]! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 7/17/2017 15:46:10' prior: 16919601! -condenseChanges - "Move all the changes onto a compacted sources file." - " - Smalltalk condenseChanges - " - - | oldChanges classCount oldChangesLocalName oldChangesPathName | - DirectoryEntry smalltalkImageDirectory // 'ST80.temp' forceWriteStreamDo: [ :f | - f timeStamp. - 'Condensing Changes File...' - displayProgressAt: Sensor mousePoint - from: 0 to: Smalltalk classNames size - during: [ :barBlock | - classCount _ 0. - Smalltalk allClassesDo: [ :class | - barBlock value: (classCount _ classCount + 1). - class moveChangesTo: f. - class putClassCommentToCondensedChangesFile: f. - class class moveChangesTo: f ]]. - LastQuitLogPosition _ f position ]. - - CompiledMethod allInstancesDo: [ :e | - e isInstalled ifFalse: [ e destroySourcePointer ] ]. - - oldChanges _ SourceFiles at: 2. - oldChangesPathName _ oldChanges name. - oldChangesLocalName _ oldChanges localName. - oldChanges close. - (oldChangesPathName, '.old') asFileEntry delete. - oldChangesPathName asFileEntry rename: oldChangesLocalName, '.old'. - DirectoryEntry smalltalkImageDirectory // 'ST80.temp' rename: oldChangesLocalName. - - SourceFiles - at: 2 put: oldChangesPathName asFileEntry appendStream. - - self inform: 'Changes file has been rewritten!! - -Check that all is well, and then save/quit. - -Otherwise, remove new changes, -replace it with the former one, and -exit without saving the image. - '! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 7/17/2017 15:46:14' prior: 16919647! - condenseSources - "Move all the changes onto a compacted sources file." - "Smalltalk condenseSources" - - | classCount newVersionString oldChanges oldChangesLocalName oldChangesPathName newChangesPathName newSourcesName | - newVersionString _ FillInTheBlankMorph request: 'Please name the new sources file' initialAnswer: SourceFileVersionString. - newVersionString ifNil: [^ self]. - newVersionString = SourceFileVersionString ifTrue: [ - ^ self error: 'The new source file must not be the same as the old.']. - SourceFileVersionString _ newVersionString. - - "Write all sources with fileIndex 1" - newSourcesName _ self defaultSourcesName. - newSourcesName asFileEntry writeStreamDo: [ :f | - f timeStamp. - 'Condensing Sources File...' - displayProgressAt: Sensor mousePoint - from: 0 to: Smalltalk classNames size - during: [ :barBlock | - classCount _ 0. - Smalltalk allClassesDo: [ :class | - barBlock value: (classCount _ classCount + 1). - class fileOutOn: f moveSource: true toFile: 1]]]. - - CompiledMethod allInstancesDo: [ :e | - e isInstalled ifFalse: [ e destroySourcePointer ] ]. - - "Make a new empty changes file" - oldChanges _ SourceFiles at: 2. - oldChangesPathName _ oldChanges name. - oldChangesLocalName _ oldChanges localName. - self closeSourceFiles. - oldChangesPathName ifNotNil: [ - (oldChangesPathName, '.old') asFileEntry delete. - oldChangesPathName asFileEntry rename: oldChangesLocalName, '.old' ]. - newChangesPathName _ self defaultChangesName. - newChangesPathName asFileEntry writeStreamDo: [ :stream | - stream timeStamp ]. - LastQuitLogPosition _ 0. - - self openSourceFiles. - self inform: 'Source files have been rewritten!! - -Check that all is well, and then save/quit. - -Otherwise, remove new sources/changes, -replace them with the former ones, and -exit without saving the image. - '! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 7/17/2017 15:41:56' prior: 16919755! - macroBenchmark1 "Smalltalk macroBenchmark1" - "Decompiles and prettyPrints the source for every method in the system (or less depending on the *FILTER*, and then compiles that source and verifies that it generates (and decompiles to) identical code. This currently fails in a number of places because some different patterns (esp involving conditionals where the first branch returns) decompile the same. Because it never installs the new method, it should not cause any flusing of the method cache." - | methodNode oldMethod newMethod badOnes oldCodeString n classes | - classes _ Smalltalk allClasses select: [:c | c name < 'B3']. - badOnes _ OrderedCollection new. -'Decompiling and recompiling...' -displayProgressAt: Sensor mousePoint -from: 0 to: (classes detectSum: [:c | c selectors size]) -during: [:barBlock | n _ 0. - classes do: - [:cls | - "Transcript cr; show: cls name." - cls selectors do: - [:selector | barBlock value: (n _ n+1). - oldMethod _ cls compiledMethodAt: selector. - oldCodeString _ (cls decompilerClass new - decompile: selector in: cls method: oldMethod) - decompileString. - methodNode _ cls compilerClass new - compile: oldCodeString - in: cls notifying: nil ifFail: nil. - newMethod _ methodNode generate: #(0 0 0 0). - oldCodeString = (cls decompilerClass new - decompile: selector in: cls method: newMethod) - decompileString ifFalse: [badOnes add: cls name , ' ' , selector]]]. -]. - ^ badOnes size! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 7/17/2017 15:46:19' prior: 16919804! - macroBenchmark3 "Smalltalk macroBenchmark3" - | testBlock tallies prev receiver | - "Runs the stepping simulator with the messageTally tree (like tallySends)." - testBlock _ - ['Running the context step simulator' - displayProgressAt: Sensor mousePoint - from: 0 to: 200 - during: - [:barBlock | - 1 to: 200 do: - [:x | barBlock value: x. - Float pi printString. - 15 factorial printString]]]. - tallies _ MessageTally new class: testBlock receiver class - method: testBlock method. - receiver _ nil. - prev _ testBlock. - thisContext sender - runSimulated: testBlock - contextAtEachStep: - [:current | - current == prev ifFalse: [ - "call or return" - prev sender ifNotNil: [ - "call only" - (receiver == nil or: [current receiver == receiver]) - ifTrue: [tallies tally: current by: 1]]. - prev _ current]]. -! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 7/17/2017 15:46:24' prior: 50364567! - obsoleteMethodReferences - " - Smalltalk obsoleteMethodReferences - Smalltalk browseObsoleteMethodReferences - Open a browser on all referenced behaviors that are obsolete" - | obsClasses obsRefs references | - references _ WriteStream on: Array new. - obsClasses _ self obsoleteBehaviors. - 'Scanning for methods referencing obsolete classes' displayProgressAt: Sensor mousePoint - from: 1 to: obsClasses size during: [ :barBlock | - obsClasses keysAndValuesDo: [ :index :each | - barBlock value: index. - obsRefs _ self pointersTo: each except: obsClasses. - obsRefs do: [ :ref | - "Figure out if it may be a global" - (ref isVariableBinding and: [ ref key isString "or Symbol" ]) ifTrue: [ - (self pointersTo: ref) do: [ :meth | - (meth is: #CompiledMethod) ifTrue: [ - meth methodReference ifNotNil: [ :mref | - (mref isValid and: [ mref compiledMethod == meth]) ifTrue: [ - references nextPut: mref ]]]]]]]. - ]. - ^references contents! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 7/17/2017 15:46:30' prior: 16919989! - testDecompiler - " - Smalltalk testDecompiler - " - "Decompiles the source for every method in the system, and then compiles that source and verifies that it generates (and decompiles to) identical code. This currently fails in a number of places because some different patterns (esp involving conditionals where the first branch returns) decompile the same." - | methodNode oldMethod newMethod badOnes oldCodeString n | - badOnes _ OrderedCollection new. - 'Decompiling all classes...' - displayProgressAt: Sensor mousePoint - from: 0 - to: CompiledMethod instanceCount - during: [ :barBlock | - n _ 0. - Smalltalk allBehaviorsDo: [ :cls | - "Transcript cr; show: cls name." - cls selectors do: [ :selector | - (n _ n + 1) \\ 100 = 0 ifTrue: [ barBlock value: n ]. - oldMethod _ cls compiledMethodAt: selector. - oldCodeString _ (cls decompilerClass new - decompile: selector - in: cls - method: oldMethod) decompileString. - methodNode _ cls compilerClass new - compile: oldCodeString - in: cls - notifying: nil - ifFail: nil. - newMethod _ methodNode generate: #(0 0 0 0 ). - oldCodeString = - (cls decompilerClass new - decompile: selector - in: cls - method: newMethod) decompileString ifFalse: [ - Transcript - newLine; - show: '***' , cls name , ' ' , selector. - badOnes add: (MethodReference class: cls selector: selector) ]]]]. - Smalltalk - browseMessageList: badOnes asArray sort - name: 'Decompiler Discrepancies'.! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 7/17/2017 15:46:37' prior: 16920039! - testFormatter - "Smalltalk testFormatter" - "Reformats the source for every method in the system, and then compiles that source and verifies that it generates identical code. - The formatting used will be classic monochrome." - | newCodeString methodNode oldMethod newMethod badOnes n | - badOnes _ OrderedCollection new. - 'Formatting all classes...' - displayProgressAt: Sensor mousePoint - from: 0 - to: CompiledMethod instanceCount - during: [ :barBlock | - n _ 0. - Smalltalk allBehaviorsDo: [ :cls | - "Transcript cr; show: cls name." - cls selectors do: [ :selector | - (n _ n + 1) \\ 100 = 0 ifTrue: [ barBlock value: n ]. - newCodeString _ cls compilerClass new - format: (cls sourceCodeAt: selector) - in: cls - notifying: nil. - methodNode _ cls compilerClass new - compile: newCodeString - in: cls - notifying: nil - ifFail: nil. - newMethod _ methodNode generate: #(0 0 0 0 ). - oldMethod _ cls compiledMethodAt: selector. - oldMethod = newMethod ifFalse: [ - Transcript - newLine; - show: '***' , cls name , ' ' , selector. - badOnes add: cls name , ' ' , selector ]]]]. - Smalltalk - browseMessageList: badOnes asArray sort - name: 'Formatter Discrepancies'.! ! -!SystemDictionary methodsFor: 'housekeeping' stamp: 'jmv 7/17/2017 15:46:43' prior: 16920080! - testFormatter2 - "Smalltalk testFormatter2" - "Reformats the source for every method in the system, and then verifies that the order of source tokens is unchanged. - The formatting used will be classic monochrome" - | newCodeString badOnes n oldCodeString oldTokens newTokens | - badOnes _ OrderedCollection new. - 'Formatting all classes...' - displayProgressAt: Sensor mousePoint - from: 0 - to: CompiledMethod instanceCount - during: [ :barBlock | - n _ 0. - Smalltalk allBehaviorsDo: [ :cls | - "Transcript cr; show: cls name." - cls selectors do: [ :selector | - (n _ n + 1) \\ 100 = 0 ifTrue: [ barBlock value: n ]. - oldCodeString _ (cls sourceCodeAt: selector) asString. - newCodeString _ cls compilerClass new - format: oldCodeString - in: cls - notifying: nil. - oldTokens _ oldCodeString findTokens: Character separators. - newTokens _ newCodeString findTokens: Character separators. - oldTokens = newTokens ifFalse: [ - Transcript - newLine; - show: '***' , cls name , ' ' , selector. - badOnes add: cls name , ' ' , selector ]]]]. - Smalltalk - browseMessageList: badOnes asArray sort - name: 'Formatter Discrepancies'.! ! -!SystemDictionary methodsFor: 'retrieving' stamp: 'jmv 7/17/2017 15:45:58' prior: 16921677! - allMethodsSourceStringMatching: aString - "Answer a sorted Collection of all the methods that contain, in source code, aString as a substring. - Search the class comments also. - Argument might include $*, that matches any subsequence. - For example, try: - ensure:*[*close*] - " - | list classCount adder | - list _ Set new. - adder _ [ :mrClass :mrSel | - list add: - (MethodReference new - setStandardClass: mrClass - methodSymbol: mrSel) ]. - 'Searching all source code...' - displayProgressAt: Sensor mousePoint - from: 0 - to: Smalltalk classNames size - during: [ :barBlock | - classCount _ 0. - Smalltalk allClassesDo: [ :class | - barBlock value: (classCount _ classCount + 1). - (Array - with: class - with: class class) do: [ :cl | - cl selectorsDo: [ :sel | - (aString match: (cl sourceCodeAt: sel)) ifTrue: [ - adder - value: cl - value: sel ]]. - - (aString match: cl organization classComment asString) ifTrue: [ - adder - value: cl - value: #Comment ]]]]. - ^ list asArray sort.! ! -!SystemDictionary methodsFor: 'retrieving' stamp: 'jmv 7/17/2017 15:46:02' prior: 16921712! - allMethodsWithSourceString: aString matchCase: caseSensitive - "Answer a sorted Collection of all the methods that contain, in source code, aString as a substring. Search the class comments also" - | list classCount adder | - list _ Set new. - adder _ [ :mrClass :mrSel | - list add: - (MethodReference new - setStandardClass: mrClass - methodSymbol: mrSel) ]. - 'Searching all source code...' - displayProgressAt: Sensor mousePoint - from: 0 - to: Smalltalk classNames size - during: [ :barBlock | - classCount _ 0. - Smalltalk allClassesDo: [ :class | - barBlock value: (classCount _ classCount + 1). - (Array - with: class - with: class class) do: [ :cl | - cl selectorsDo: [ :sel | - ((cl sourceCodeAt: sel) - findString: aString - startingAt: 1 - caseSensitive: caseSensitive) > 0 ifTrue: [ - adder - value: cl - value: sel ]]. - (cl organization classComment asString - findString: aString - startingAt: 1 - caseSensitive: caseSensitive) > 0 ifTrue: [ - adder - value: cl - value: #Comment ]]]]. - ^ list asArray sort.! ! -!SystemDictionary methodsFor: 'shrinking' stamp: 'jmv 7/17/2017 15:45:48' prior: 16922180! - abandonSources - " - Smalltalk abandonSources - " - | m bTotal bCount | - (self confirm: -'This method will detach the image fom source code. -A fresh changes file will be created to record further changes. --- CAUTION -- -If you have backed up your system and -are prepared to face the consequences of -abandoning source code files, choose Yes. -If you have any doubts, you may choose No -to back out with no harm done.') - == true ifFalse: [^ self inform: 'Okay - no harm done']. - bTotal _ 0. bCount _ 0. - Smalltalk allBehaviorsDo: [: b | bTotal _ bTotal + 1]. -'Doing #destroySourcePointer ...' - displayProgressAt: Sensor mousePoint - from: 0 to: bTotal - during: [ :barBlock | - Smalltalk allBehaviorsDo: [ :cl | - "for testing" - "{ EllipseMorph } do: [ :cl |" - barBlock value: (bCount _ bCount + 1). - cl selectors do: [:selector | - m _ cl compiledMethodAt: selector. - m destroySourcePointer ]]]. - Smalltalk allBehaviorsDo: [:b | b zapOrganization]. - Smalltalk closeSourceFiles. - Preferences disable: #warnIfNoChangesFile. - Preferences disable: #warnIfNoSourcesFile! ! -!SystemDictionary methodsFor: 'shrinking' stamp: 'jmv 7/17/2017 15:42:02' prior: 16922340! - removeAllUnSentMessages - "Smalltalk removeAllUnSentMessages" - "[Smalltalk unusedClasses do: [:c | (Smalltalk at: c) removeFromSystem]. - Smalltalk removeAllUnSentMessages > 0] whileTrue." - "Remove all implementations of unsent messages." - | sels n | - sels _ self allUnSentMessages. - self presumedSentMessages - do: [:sel | sels - remove: sel - ifAbsent: nil]. - sels size = 0 - ifTrue: [^ 0]. - n _ 0. - Smalltalk - allBehaviorsDo: [:x | n _ n + 1]. - 'Removing ' , sels size printString , ' messages . . .' - displayProgressAt: Sensor mousePoint - from: 0 - to: n - during: [:barBlock | - n _ 0. - self - allBehaviorsDo: [:class | - barBlock value: (n _ n + 1). - sels - do: [:sel | class removeSelector: sel]]]. - ^ sels size! ! -!PositionableStream methodsFor: 'fileIn/Out' stamp: 'jmv 7/17/2017 15:45:10' prior: 50364849! - 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 | - announcement - displayProgressAt: Sensor mousePoint - from: 0 - to: self size - during: [ :barBlock | - [ self atEnd ] whileFalse: [ - barBlock value: self position. - self skipSeparators. - - [ - val := (self peekFor: $!!) - ifTrue: [ - chunk := self nextChunk. - "These are the ones that should do nothing, - because next line is a doit that does the stuff - (or because it is handled elsewhere)" - (chunk beginsWith: 'description: ') - | (chunk beginsWith: 'provides: ') - | (chunk beginsWith: 'requires: ') - | (chunk beginsWith: 'classDefinition: ') - | (chunk beginsWith: 'classRemoval: ') - | (chunk beginsWith: 'methodRemoval: ') - | (chunk beginsWith: 'classMoveToSomePackage: ') - | (chunk beginsWith: 'methodMoveToSomePackage: ') - ifFalse: [(Compiler evaluate: chunk logged: false) scanFrom: self]] - ifFalse: [ - chunk := self nextChunk. - self checkForPreamble: chunk. - [ Compiler evaluate: chunk logged: true ] - on: Error - do: [ :ex | - ex print. - ('while evaluating: ', chunk) print. - ex pass ] - ]] - on: InMidstOfFileinNotification - do: [ :ex | ex resume: true ] ]. - ]. - "Note: The main purpose of this banner is to flush the changes file." - Smalltalk logChange: '----End fileIn of ' , self name , '----'. - ^val! ! -!PositionableStream methodsFor: 'gui' stamp: 'jmv 7/17/2017 15:38:57' prior: 50364907! - untilEnd: aBlock displayingProgress: aString - aString - displayProgressAt: Sensor mousePoint - from: 0 to: self size - during: [ :barBlock | - [ self atEnd ] whileFalse: [ - barBlock value: self position. - aBlock value ]]! ! -!ReferenceStream methodsFor: 'statistics' stamp: 'jmv 7/17/2017 15:40:06' prior: 16899982! - statisticsOfRefs - "Analyze the information in references, the objects being written out" - - | parents n kids nm ownerBags tallies owners objParent normalReferences | - normalReferences _ self references. "Exclude unrealized weaks" - parents _ IdentityDictionary new: normalReferences size * 2. - n _ 0. - 'Finding Owners...' - displayProgressAt: Sensor mousePoint - from: 0 to: normalReferences size - during: [ :barBlock | - normalReferences keysDo: - [ :parent | barBlock value: (n _ n+1). - kids _ parent class isFixed - ifTrue: [(1 to: parent class instSize) collect: [:i | parent instVarAt: i]] - ifFalse: [parent class isBits ifTrue: [Array new] - ifFalse: [(1 to: parent basicSize) collect: [:i | parent basicAt: i]]]. - (kids select: [:x | normalReferences includesKey: x]) - do: [:child | parents at: child put: parent]]]. - ownerBags _ Dictionary new. - tallies _ Bag new. - n _ 0. - 'Tallying Owners...' - displayProgressAt: Sensor mousePoint - from: 0 to: normalReferences size - during: [ :barBlock | - normalReferences keysDo: "For each class of obj, tally a bag of owner classes" - [ :obj | barBlock value: (n _ n+1). - nm _ obj class name. - tallies add: nm. - owners _ ownerBags at: nm ifAbsent: [ownerBags at: nm put: Bag new]. - (objParent _ parents at: obj ifAbsent: nil) ifNotNil: [ - owners add: objParent class name]]]. - ^ String streamContents: [ :strm | - tallies sortedCounts do: [ :assn | - n _ assn key. nm _ assn value. - owners _ ownerBags at: nm. - strm newLine; nextPutAll: nm; space; print: n. - owners size > 0 ifTrue: [ - strm newLine; tab; print: owners sortedCounts]]]! ! -!SmartRefStream methodsFor: 'read write' stamp: 'jmv 7/17/2017 15:40:37' prior: 16911182! - nextPut: anObject - "Really write three objects: (version, class structure, object). But only when called from the outside. If any instance-specific classes are present, prepend their source code. byteStream will be in fileOut format. - You can see an analysis of which objects are written out by doing: - (SmartRefStream statsOfSubObjects: anObject) - (SmartRefStream tallyOfSubObjects: anObject) - (SmartRefStream subObjects: anObject ofClass: aClass)" - -| info | -topCall - ifNil: [ - topCall _ anObject. - 'Please wait while objects are counted' - displayProgressAt: Sensor mousePoint - from: 0 to: 10 - during: [ :barBlock | info _ self instVarInfo: anObject]. - byteStream binary. - 'Writing an object file' displayProgressAt: Sensor mousePoint - from: 0 to: objCount*4 "estimate" - during: [ :barBlock | - objCount _ 0. - progressBar _ barBlock. - self setStream: byteStream reading: false. - "set basePos, but keep any class renames" - super nextPut: ReferenceStream versionCode. - super nextPut: info. - super nextPut: anObject. "<- the real writing" - ]. - "Note: the terminator, $!!, is not doubled inside object data" - "references is an IDict of every object that got written" - byteStream ascii. - byteStream nextPutAll: '!!'; newLine; newLine. - byteStream padToEndWith: $ . "really want to truncate file, but can't" - topCall _ progressBar _ nil] "reset it" - ifNotNil: [ - super nextPut: anObject. - progressBar ifNotNil: [progressBar value: (objCount _ objCount + 1)]]. -! ! -!SmartRefStream methodsFor: 'read write' stamp: 'jmv 7/17/2017 15:40:57' prior: 16911232! - nextPutObjOnly: anObject - "Really write three objects: (version, class structure, object). But only when called from the outside. Not in fileOut format. No class definitions will be written for instance-specific classes. Error if find one. (Use nextPut: instead)" - - | info | - topCall - ifNil: [ - topCall _ anObject. - super nextPut: ReferenceStream versionCode. - 'Please wait while objects are counted' displayProgressAt: Sensor mousePoint - from: 0 to: 10 - during: [ :barBlock | - info _ self instVarInfo: anObject]. - 'Writing an object file' displayProgressAt: Sensor mousePoint - from: 0 to: objCount*4 "estimate" - during: [ :barBlock | - objCount _ 0. - progressBar _ barBlock. - super nextPut: info. - super nextPut: anObject. "<- the real writing" - "Class inst vars not written here!!"]. - "references is an IDict of every object that got written - (in case you want to take statistics)" - "Transcript cr; show: structures keys printString." "debug" - topCall _ progressBar _ nil] "reset it" - ifNotNil: [ - super nextPut: anObject. - progressBar ifNotNil: [progressBar value: (objCount _ objCount + 1)]].! ! -!ProgressInitiationException class methodsFor: 'examples and tests' stamp: 'jmv 7/17/2017 15:39:39' prior: 50364918! -testInnermost - - " - test the progress code WITHOUT special handling - - ProgressInitiationException testInnermost - " - - ^'Now here''s some Real Progress' - displayProgressAt: Sensor mousePoint - from: 0 - to: 10 - during: [ :barBlock | - 1 to: 10 do: [ :x | - barBlock value: x. - (Delay forMilliseconds: 500) wait. - x = 5 ifTrue: [1/0]. "just to make life interesting" - ]. - 'done' - ]. - -! ! -!Utilities class methodsFor: 'user interface' stamp: 'jmv 7/17/2017 15:48:35' prior: 16941514! - informUserDuring: barBlock - "Display a message above (or below if insufficient room) the cursor during execution of the given block." - - "Utilities informUserDuring:[:barBlock| - #(one two three) do:[:info| - barBlock value: info. - (Delay forSeconds: 1) wait]]" - - (MVCMenuMorph from: (SelectionMenu labels: '') title: ' ') - informUserAt: Sensor mousePoint - during: barBlock! ! -!CodeFile methodsFor: 'reading' stamp: 'jmv 7/17/2017 15:44:20' prior: 16808992! - buildFrom: aStream - | chgRec changes | - changes _ (ChangeList new scanFile: aStream from: 0 to: aStream size) changeList. - ('Processing ', self name) - displayProgressAt: Sensor mousePoint - from: 1 - to: changes size - during: [ :barBlock | - 1 to: changes size do:[:i| - barBlock value: i. - chgRec := changes at: i. - chgRec class == MethodDeletionChangeRecord - ifTrue: [ self removedMethod: chgRec command with: chgRec ] - ifFalse: [ self perform: (chgRec changeType copyWith: $:) asSymbol with: chgRec ]. - ]. - ]! ! -!SpaceTally methodsFor: 'fileOut' stamp: 'jmv 7/17/2017 15:45:36' prior: 16912516! - printSpaceAnalysis: threshold on: aStream - " - SpaceTally new printSpaceAnalysis: 1 on:(FileStream forceNewFileNamed: 'STspace.text') - " - "sd-This method should be rewrote to be more coherent within the rest of the class - ie using preAllocate and spaceForInstanceOf:" - - "If threshold > 0, then only those classes with more than that number - of instances will be shown, and they will be sorted by total instance space. - If threshold = 0, then all classes will appear, sorted by name." - - | codeSpace instCount instSpace totalCodeSpace totalInstCount totalInstSpace eltSize n totalPercent percent | - Smalltalk garbageCollect. - totalCodeSpace _ totalInstCount _ totalInstSpace _ n _ 0. - results _ OrderedCollection new: Smalltalk classNames size. - 'Taking statistics...' - displayProgressAt: Sensor mousePoint - from: 0 to: Smalltalk classNames size - during: [ :barBlock | - Smalltalk allClassesDo: [ :cl | - codeSpace _ cl spaceUsed. - barBlock value: (n _ n+1). - Smalltalk garbageCollectMost. - instCount _ cl instanceCount. - instSpace _ (cl indexIfCompact > 0 ifTrue: [4] ifFalse: [8]) * instCount. "Object headers""Warning: The 3rd header word for big objects is not considered!!" - cl isVariable - ifTrue: [ - eltSize _ cl isBytes ifTrue: [1] ifFalse: [4]. - cl allInstancesDo: [ :x | - instSpace _ instSpace + (x basicSize * eltSize)]] - ifFalse: [instSpace _ instSpace + (cl instSize * instCount * 4)]. - results add: (SpaceTallyItem analyzedClassName: cl name codeSize: codeSpace instanceCount: instCount spaceForInstances: instSpace). - totalCodeSpace _ totalCodeSpace + codeSpace. - totalInstCount _ totalInstCount + instCount. - totalInstSpace _ totalInstSpace + instSpace]]. - totalPercent _ 0.0. - - aStream timeStamp. - aStream - nextPutAll: ('Class' padded: #right to: 30 with: $ ); - nextPutAll: ('code space' padded: #left to: 12 with: $ ); - nextPutAll: ('# instances' padded: #left to: 12 with: $ ); - nextPutAll: ('inst space' padded: #left to: 12 with: $ ); - nextPutAll: ('percent' padded: #left to: 8 with: $ ); newLine. - - threshold > 0 ifTrue: [ - "If inst count threshold > 0, then sort by space" - results _ (results select: [:s | s instanceCount >= threshold or: [s spaceForInstances > (totalInstSpace // 500)]]) - asArray sort: [:s :s2 | s spaceForInstances > s2 spaceForInstances]]. - - results do: [:s | - aStream - nextPutAll: (s analyzedClassName padded: #right to: 30 with: $ ); - nextPutAll: (s codeSize printString padded: #left to: 12 with: $ ); - nextPutAll: (s instanceCount printString padded: #left to: 12 with: $ ); - nextPutAll: (s spaceForInstances printString padded: #left to: 14 with: $ ). - percent _ s spaceForInstances*100.0/totalInstSpace. - totalPercent _ totalPercent + percent. - percent >= 0.1 ifTrue: [ - percent printOn: aStream integerDigits: 6 padWith: $ fractionDigits: 1 positiveIndicator: nil ]. - aStream newLine]. - - aStream - newLine; nextPutAll: ('Total' padded: #right to: 30 with: $ ); - nextPutAll: (totalCodeSpace printString padded: #left to: 12 with: $ ); - nextPutAll: (totalInstCount printString padded: #left to: 12 with: $ ); - nextPutAll: (totalInstSpace printString padded: #left to: 14 with: $ ). - totalPercent printOn: aStream integerDigits: 6 padWith: $ fractionDigits: 1 positiveIndicator: nil! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3126-ProgressArgumentIsABlock-JuanVuletich-2017Jul17-15h32m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3121] on 12 July 2017 at 1:50:53 pm'! -!Float64Array methodsFor: 'testing' stamp: 'jmv 7/11/2017 14:04:20'! - isLiteral - "so that - #(1 #[1.0 2 3] 5) - prints itself" - ^self class == Float64Array! ! -!Float64Array methodsFor: 'printing' stamp: 'jmv 7/11/2017 14:10:44'! - printOn: aStream - - self storeOn: aStream! ! -!Float64Array methodsFor: 'printing' stamp: 'jmv 7/11/2017 14:10:41'! - storeOn: aStream - - aStream nextPutAll: '#['. - self - do: [ :each | each storeOn: aStream ] - separatedBy: [ aStream nextPut: $ ]. - aStream nextPut: $]! ! -!ByteArray methodsFor: 'printing' stamp: 'jmv 7/11/2017 14:09:10' prior: 16793833! - printOn: aStream - self storeOn: aStream! ! -!Scanner methodsFor: 'expression types' stamp: 'jmv 7/12/2017 13:50:30' prior: 16903764! - scanLitByteVec - "Also accept Floats besides bytes!! - #[1 2 3 255] - #[1.0 0.2 1.0] - #[1.0 -0.2e-23 1.0e4] - " - | stream | - stream _ nil. - [ tokenType == #rightBracket or: [ tokenType == #doIt ] ] whileFalse: [ - (token == #- and: [(self typeTableAt: hereChar) == #xDigit]) ifTrue: [ - self scanToken. - token _ token negated ]. - ((token isInteger and: [ token between: 0 and: 255 ]) or: [token isFloat]) - ifFalse: [ ^ self offEnd: '8-bit integer, floating point number, or right bracket expected' ]. - stream ifNil: [ - stream _ ((token isFloat ifTrue: [Float64Array] ifFalse: [ByteArray]) new: 16) writeStream ]. - stream nextPut: token. - self scanToken ]. - token _ stream contents! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3127-LiteralFloatArrays-JuanVuletich-2017Jul12-13h50m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3127] on 17 July 2017 at 5:00:00 pm'! -!Collection methodsFor: 'converting' stamp: 'jmv 7/17/2017 16:59:02'! - asFloat64Array - "Answer a Float64Array whose elements are the elements of the receiver" - - ^self as: Float64Array! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3128-asFloat64Array-JuanVuletich-2017Jul17-16h59m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3128] on 18 July 2017 at 10:23:11 am'! -!PluggableButtonMorph methodsFor: 'as yet unclassified' stamp: 'jmv 7/18/2017 10:22:53' prior: 50365253! - morphExtent - "Use extent if it has already been manually set, otherwise try to set it by computing from the label text and font, otherwise try using the icon extent, or finally fall back to the default value." - ^ extent ifNil: [ - extent := (self fontToUse notNil and: [ label notNil ]) - ifTrue: [ "Add a bit of padding" - (self fontToUse widthOfString: label) + 10 @ (self fontToUse height + 10) ] - ifFalse: [ - `20@15` - "Usually button extent should not depend on icon extent. Icons are many times very big. - For example, the icons in buttons in Taskbar are full size captures of the windows" - "icon - ifNil: [ `20@15` ] - ifNotNil: [ icon extent ]" - ]].! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3129-AvoidHugeButtons-JuanVuletich-2017Jul18-10h22m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3128] on 19 July 2017 at 2:45:06 am'! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'pb 7/19/2017 02:42:16'! - moveEnd - self gotoPage: self pageCount. - self selected: completer entryCount. - self redrawNeeded.! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'pb 7/19/2017 02:42:22'! - moveHome - self gotoPage: 1. - self redrawNeeded.! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'pb 7/19/2017 02:43:17' prior: 16781410! - moveDown - self selected = completer entryCount - ifTrue: [ self moveHome ] - ifFalse: [ - self selected: self selected + 1. - (self selected > self lastVisible and: [ self selected <= completer entryCount ]) ifTrue: [ firstVisible _ firstVisible + 1 ]]. - self redrawNeeded.! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'pb 7/19/2017 02:42:32' prior: 16781419! - moveUp - (self selected = 0 and: [ self firstVisible = 1 ]) ifTrue: [ ^ self ]. - self selected = 1 - ifTrue: [ - self moveEnd ] - ifFalse: [ - self selected: self selected - 1. - self selected < self firstVisible ifTrue: [ firstVisible _ firstVisible - 1 ]]. - self redrawNeeded.! ! -!AutoCompleter methodsFor: 'keyboard' stamp: 'pb 7/19/2017 02:42:44' prior: 16781174! - handleKeystrokeBefore: kbEvent - "I return a boolean. true when I have handled the event and no futher processing is needed by the caller." - | currentPos currentCharIsAlphaNumeric keyValue ctrl cmd tab colon alphanum backspace esc space return keyChar | - currentPos _ textMorph editor startIndex-1. - currentCharIsAlphaNumeric _ currentPos > 0 and: [ model textSize >= currentPos and: [ - (model actualContents at: currentPos) isAlphaNumeric ]]. - keyValue _ kbEvent keyValue. - keyChar _ kbEvent keyCharacter. - ctrl _ kbEvent controlKeyPressed. - cmd _ kbEvent commandAltKeyPressed. - tab _ keyChar = Character tab. - colon _ keyChar = $:. - alphanum _ kbEvent keyCharacter isAlphaNumeric. - backspace _ keyValue = 8. - esc _ keyValue = 27. - space _ #(0 32 160) includes: keyValue. - return _ kbEvent isReturnKey. - - "Stuff to do if the menu is not open" - menuMorph ifNil: [ - "Ctrl-Space or Tab for open" - "Mac specific note: Using option-space (actually option+160) effectively disables the non-breaking space character 160" - (space & (ctrl | kbEvent rawMacOptionKeyPressed) or: [ - (self opensWithTab and: [tab]) and: [ currentCharIsAlphaNumeric ]]) - ifTrue: [ self openCompletionMenu. ^ true]. - "Auto-open - currently deactivated" -" (ctrl not & cmd not & alphanum) - ifTrue: [ self openCompletionMenu ]." - ^ false]. - - "Starting here, stuff to do if the menu is open" - menuMorph stillActive. - "Escape" - esc ifTrue: [ self closeMenu. ^ true]. - "Backspace" - backspace ifTrue: [ - currentCharIsAlphaNumeric ifFalse: [ self closeMenu ]. - ^ false]. - "Home" - keyValue = 1 ifTrue: [ menuMorph moveHome. ^ true ]. - "End" - keyValue = 4 ifTrue: [ menuMorph moveEnd. ^ true]. - "?" - keyChar = $? ifTrue: [ menuMorph help. ^true]. - "Arrow up" - keyValue = 30 ifTrue: [ menuMorph moveUp. ^ true]. - "Arrow down" - keyValue = 31 ifTrue: [ menuMorph moveDown. ^ true]. - "Page up" - keyValue = 11 ifTrue: [ menuMorph pageUp. ^ true]. - "Page down" - keyValue = 12 ifTrue: [ menuMorph pageDown. ^ true]. - "Return, Tab or Ctrl-Space" - (return or: [ space & (ctrl | kbEvent rawMacOptionKeyPressed) or: [ tab]]) ifTrue: [ - self insertSelected - ifTrue: [^ true]]. - "All keys but the alphanumeric chars (without command and control ) - and the backspace key do close the menu" - (ctrl not & cmd not and: [ alphanum | colon]) - ifFalse: [ self closeMenu ]. - ^false! ! - -AutoCompleterMorph removeSelector: #end! - -AutoCompleterMorph removeSelector: #end! - -AutoCompleterMorph removeSelector: #ensureVisible! - -AutoCompleterMorph removeSelector: #home! - -AutoCompleterMorph removeSelector: #home! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3130-AutoCompleterMorph-wrapping-PhilBellalouna-2017Jul19-02h20m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3130] on 2 August 2017 at 12:48:23 pm'! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'jmv 8/2/2017 12:45:12'! - goDown - self selected: self selected + 1. - (self selected > self lastVisible - and: [self selected <= completer entryCount]) - ifTrue: [firstVisible := firstVisible + 1]. - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'jmv 8/2/2017 12:45:38'! - goHome - firstVisible := 1. - self selected: firstVisible. - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'jmv 8/2/2017 12:47:05'! - goPageDown - (self gotoPage: self currentPage + 1) - ifFalse: [ self goToEnd ]. - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'jmv 8/2/2017 12:45:54'! - goPageUp - self gotoPage: self currentPage - 1. - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'jmv 8/2/2017 12:45:32'! - goToEnd - self selected: completer entryCount. - firstVisible := selected - self class itemsPerPage + 1 max: 1. - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'jmv 8/2/2017 12:45:45'! - goUp - (self selected = 0 - and: [self firstVisible = 1]) - ifTrue: [^ self]. - self selected: self selected - 1. - self selected < self firstVisible - ifTrue: [firstVisible := firstVisible - 1]. - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'events' stamp: 'jmv 8/2/2017 12:46:45' prior: 16781544! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - (self morphContainsPoint: localEventPosition) - ifTrue: [ - ((self upButtonPosition extent: ScrollBar scrollbarThickness) containsPoint: localEventPosition) - ifTrue: [ ^self stillActive; goUp ]. - ((self downButtonPosition extent: ScrollBar scrollbarThickness) containsPoint: localEventPosition) - ifTrue: [ ^self stillActive; goDown ]. - self selected: (localEventPosition y // self class itemHeight) + self firstVisible. - completer insertSelected ] - ifFalse: [ self delete. completer menuClosed ]! ! -!AutoCompleterMorph methodsFor: 'paging' stamp: 'jmv 8/2/2017 12:38:44' prior: 16781597! -gotoPage: anInteger - | item | - item := ((anInteger - 1) * self class itemsPerPage) + 1. - item >= completer entryCount ifTrue: [^false]. - item < 1 ifTrue: [item := 1]. - firstVisible := item. - self selected: firstVisible. - ^ true! ! -!AutoCompleter methodsFor: 'keyboard' stamp: 'jmv 8/2/2017 12:47:30' prior: 50366765! - handleKeystrokeBefore: kbEvent - "I return a boolean. true when I have handled the event and no futher processing is needed by the caller." - | currentPos currentCharIsAlphaNumeric keyValue ctrl cmd tab colon alphanum backspace esc space return keyChar | - currentPos _ textMorph editor startIndex-1. - currentCharIsAlphaNumeric _ currentPos > 0 and: [ model textSize >= currentPos and: [ - (model actualContents at: currentPos) isAlphaNumeric ]]. - keyValue _ kbEvent keyValue. - keyChar _ kbEvent keyCharacter. - ctrl _ kbEvent controlKeyPressed. - cmd _ kbEvent commandAltKeyPressed. - tab _ keyChar = Character tab. - colon _ keyChar = $:. - alphanum _ kbEvent keyCharacter isAlphaNumeric. - backspace _ keyValue = 8. - esc _ keyValue = 27. - space _ #(0 32 160) includes: keyValue. - return _ kbEvent isReturnKey. - - "Stuff to do if the menu is not open" - menuMorph ifNil: [ - "Ctrl-Space or Tab for open" - "Mac specific note: Using option-space (actually option+160) effectively disables the non-breaking space character 160" - (space & (ctrl | kbEvent rawMacOptionKeyPressed) or: [ - (self opensWithTab and: [tab]) and: [ currentCharIsAlphaNumeric ]]) - ifTrue: [ self openCompletionMenu. ^ true]. - "Auto-open - currently deactivated" -" (ctrl not & cmd not & alphanum) - ifTrue: [ self openCompletionMenu ]." - ^ false]. - - "Starting here, stuff to do if the menu is open" - menuMorph stillActive. - "Escape" - esc ifTrue: [ self closeMenu. ^ true]. - "Backspace" - backspace ifTrue: [ - currentCharIsAlphaNumeric ifFalse: [ self closeMenu ]. - ^ false]. - "Home" - keyValue = 1 ifTrue: [ menuMorph goHome. ^ true ]. - "End" - keyValue = 4 ifTrue: [ menuMorph goToEnd. ^ true]. - "?" - keyChar = $? ifTrue: [ menuMorph help. ^true]. - "Arrow up" - keyValue = 30 ifTrue: [ menuMorph goUp. ^ true]. - "Arrow down" - keyValue = 31 ifTrue: [ menuMorph goDown. ^ true]. - "Page up" - keyValue = 11 ifTrue: [ menuMorph goPageUp. ^ true]. - "Page down" - keyValue = 12 ifTrue: [ menuMorph goPageDown. ^ true]. - "Return, Tab or Ctrl-Space" - (return or: [ space & (ctrl | kbEvent rawMacOptionKeyPressed) or: [ tab]]) ifTrue: [ - self insertSelected - ifTrue: [^ true]]. - "All keys but the alphanumeric chars (without command and control ) - and the backspace key do close the menu" - (ctrl not & cmd not and: [ alphanum | colon]) - ifFalse: [ self closeMenu ]. - ^false! ! - -AutoCompleterMorph removeSelector: #moveDown! - -AutoCompleterMorph removeSelector: #moveDown! - -AutoCompleterMorph removeSelector: #moveEnd! - -AutoCompleterMorph removeSelector: #moveEnd! - -AutoCompleterMorph removeSelector: #moveHome! - -AutoCompleterMorph removeSelector: #moveHome! - -AutoCompleterMorph removeSelector: #moveUp! - -AutoCompleterMorph removeSelector: #moveUp! - -AutoCompleterMorph removeSelector: #pageDown! - -AutoCompleterMorph removeSelector: #pageDown! - -AutoCompleterMorph removeSelector: #pageUp! - -AutoCompleterMorph removeSelector: #pageUp! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3131-AutoCompletterMorph-removeWrapping-JuanVuletich-2017Aug02-12h43m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3131] on 2 August 2017 at 12:59:24 pm'! -!Scanner methodsFor: 'expression types' stamp: 'jmv 8/2/2017 12:59:08' prior: 50366654! - scanLitByteVec - "Also accept Floats besides bytes!! - #[1 2 3 255] - #[1.0 0.2 1.0] - #[1.0 -0.2e-23 1.0e4] - " - | stream | - stream _ nil. - [ tokenType == #rightBracket or: [ tokenType == #doIt ] ] whileFalse: [ - (token == #- and: [(self typeTableAt: hereChar) == #xDigit]) ifTrue: [ - self scanToken. - token _ token negated ]. - ((token isInteger and: [ token between: 0 and: 255 ]) or: [token isFloat]) - ifFalse: [ ^ self offEnd: '8-bit integer, floating point number, or right bracket expected' ]. - stream ifNil: [ - stream _ ((token isFloat ifTrue: [Float64Array] ifFalse: [ByteArray]) new: 16) writeStream ]. - stream nextPut: token. - self scanToken ]. - token _ stream - ifNotNil: [ stream contents ] - ifNil: [ - "For back compatibility, if empty, assume ByteArray" - ByteArray new ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3132-EmptyLiteralByteArrayFix-JuanVuletich-2017Aug02-12h59m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3094] on 29 July 2017 at 9:36:44 pm'! -!Exception methodsFor: 'debug support' stamp: 'HAW 7/29/2017 15:47:08'! - canSearchForSignalerContext - "This method is /only/ to support the debugger's catching of exceptions in stepIntoBlock." - ^signalContext isContext! ! -!Debugger methodsFor: 'context stack menu' stamp: 'HAW 7/29/2017 20:49:55' prior: 16829808! - doStep - "Send the selected message in the accessed method, and regain control - after the invoked method returns." - - | currentContext newContext | - - currentContext := self selectedContext. - newContext := self handleLabelUpdatesIn: [interruptedProcess completeStep: currentContext] - whenExecuting: currentContext. - newContext == currentContext ifTrue: - [newContext := interruptedProcess stepToSendOrReturn]. - self contextStackIndex > 1 - ifTrue: [self resetContext: newContext] - ifFalse: - [newContext == currentContext - ifTrue: [self changed: #contentsSelection. - self updateInspectors] - ifFalse: [self resetContext: newContext]]. -! ! -!Debugger methodsFor: 'context stack menu' stamp: 'HAW 7/29/2017 20:50:01'! - handleLabelUpdatesIn: aBlock whenExecuting: aContext - "Send the selected message in the accessed method, and regain control - after the invoked method returns." - - ^aBlock - on: Notification - do: [:ex| - (ex tag isArray - and: [ex tag size = 2 - and: [(ex tag first == aContext or: [ex tag first hasSender: aContext])]]) - ifTrue: - [self labelString: ex tag second description. - ex resume] - ifFalse: - [ex pass]]! ! -!Debugger methodsFor: 'context stack menu' stamp: 'HAW 7/29/2017 20:50:15' prior: 16829946! - stepIntoBlock - "Send messages until you return to the present method context. - Used to step into a block in the method." - - self - handleLabelUpdatesIn: [interruptedProcess stepToHome: self selectedContext] - whenExecuting: self selectedContext. - self resetContext: interruptedProcess stepToSendOrReturn! ! -!Inspector methodsFor: 'initialization' stamp: 'HAW 7/29/2017 15:28:27' prior: 16857112! - inspect: anObject - "Initialize the receiver so that it is inspecting anObject. There is no current selection. - - Normally the receiver will be of the correct class (as defined by anObject inspectorClass), - because it will have just been created by sedning inspect to anObject. However, the - debugger uses two embedded inspectors, which are re-targetted on the current receiver - each time the stack frame changes. The left-hand inspector in the debugger has its - class changed by the code here. Care should be taken if this method is overridden to - ensure that the overriding code calls 'super inspect: anObject', or otherwise ensures that - the class of these embedded inspectors are changed back." - - | c | - c := anObject inspectorClass. - self class ~= c ifTrue: [ - self class format = c format - ifTrue: [self primitiveChangeClassTo: c basicNew] - ifFalse: [self becomeForward: (c basicNew copyFrom: self)]]. - - "Set 'object' before sending the initialize message, because some implementations - of initialize (e.g., in DictionaryInspector) require 'object' to be non-nil." - - object := anObject. - self initialize! ! -!OrderedCollectionInspector methodsFor: 'as yet unclassified' stamp: 'HAW 7/29/2017 15:13:36' prior: 16884334! - fieldList - - | fieldsHere | - object isNil ifTrue: [^OrderedCollection new]. - fieldsHere _ - [ - (object size <= (self i1 + self i2) - ifTrue: [(1 to: object size) collect: [:i | i printString]] - ifFalse: [(1 to: self i1) , (object size-(self i2-1) to: object size) collect: [:i | i printString]]) - ] on: Error do: [:ex | ex return: OrderedCollection new]. - ^self baseFieldList , fieldsHere -" -OrderedCollection new inspect -(OrderedCollection newFrom: #(3 5 7 123)) inspect -(OrderedCollection newFrom: (1 to: 1000)) inspect -"! ! -!Process methodsFor: 'changing suspended state' stamp: 'HAW 7/29/2017 16:00:49' prior: 16894360! - stepToHome: aContext - "Resume self until the home of top context is aContext. Top context may be a block context. - Catch any UnhandledErrors that are created while stepping, answering the relevant signalerContext - if so. Note that this will cause weird effects if using through to step through UnhandledError - code, but as the doctor ordered, don't do that; use over or into instead." - - | home anError | - - home := aContext home. - [suspendedContext := suspendedContext step. - home == suspendedContext home or: [home isDead]] whileFalse: - [(suspendedContext selector == #signalForException: - and: [(suspendedContext receiver isBehavior - and: [suspendedContext receiver includesBehavior: UnhandledError]) - and: [anError := suspendedContext tempAt: 1. - ((suspendedContext objectClass: anError) includesBehavior: Exception) - and: [anError canSearchForSignalerContext]]]) ifTrue: - [anError signalerContext ifNotNil: [:unhandledErrorSignalerContext| - [unhandledErrorSignalerContext == suspendedContext] whileFalse: - [self completeStep: suspendedContext]. - "Give a debugger a chance to update its title to reflect the new exception" - Notification new - tag: {unhandledErrorSignalerContext. anError}; - signal. - ^unhandledErrorSignalerContext]]]. - - ^suspendedContext! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3133-DebuggerFixes-HernanWilkinson-2017Jun03-20h55m-HAW.1.cs.st----! - -----SNAPSHOT----#(2 August 2017 3:48:00.408185 pm) Cuis5.0-3133.image priorSource: 1061186! - -----QUIT----#(2 August 2017 3:48:11.160628 pm) Cuis5.0-3133.image priorSource: 1138633! - -----STARTUP----#(17 August 2017 10:41:08.754587 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3133.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3133] on 3 August 2017 at 12:49:11 pm'! -!Number methodsFor: 'intervals' stamp: 'jmv 8/3/2017 11:57:08'! - to: stop do: elementBlock separatedBy: separatorBlock - " - String streamContents: [ :strm | - 1 to: 10 do: [ :i | i printOn: strm ] separatedBy: [ strm nextPutAll: ' -- ' ]] - " - | beforeFirst | - "Evaluate the elementBlock for all elements in the receiver, - and evaluate the separatorBlock between." - - beforeFirst _ true. - self to: stop do: [ :element | - beforeFirst - ifTrue: [beforeFirst _ false] - ifFalse: [separatorBlock value]. - elementBlock value: element]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3134-to_do_separatedBy-JuanVuletich-2017Aug03-11h50m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3129] on 24 July 2017 at 4:30:44 pm'! -!TextEditor methodsFor: 'typing/selecting keys' stamp: 'jmv 7/24/2017 09:10:47' prior: 16932568! - forwardDelete: aKeyboardEvent - "Delete forward over the next character." - "This is a user command, and generates undo" - - | startIndex stopIndex | - - "If there was a selection" - self hasSelection ifTrue: [ - self replaceSelectionWith: self nullText. - ^ false]. - - "Exit if at end" - startIndex _ self markIndex. - startIndex > model textSize ifTrue: [ - ^ false]. - - "Null selection - do the delete forward" - stopIndex _ startIndex. - (aKeyboardEvent keyValue = 127 and: [ aKeyboardEvent shiftPressed ]) - ifTrue: [stopIndex := (self nextWordStart: stopIndex) - 1]. - self selectFrom: startIndex to: stopIndex. - self replaceSelectionWith: self nullText. - self deselectAndPlaceCursorAt: startIndex. - ^false! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3135-DeleteSelectionAtEndOfText-fix-JuanVuletich-2017Jul24-16h25m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3134] on 9 August 2017 at 11:37:48 am'! -!BitBltCanvas methodsFor: 'drawing-images' stamp: 'jmv 8/9/2017 11:37:34' prior: 16786577! - image: aForm at: aPoint sourceRect: sourceRect - "Draw a translucent image using the best available way of representing translucency. - Note: This will be fixed in the future." - | r p | - p _ (currentTransformation transform: aPoint) rounded. - r _ (self depth < 32 or: [ aForm mightBeTranslucent not ]) - ifTrue: [ - "Rule Form paint treats pixels with a value of zero as transparent" - Form paint ] - ifFalse: [ Form blend ]. - port colorMap: (aForm colormapIfNeededFor: form); fillColor: nil. - port image: aForm at: p sourceRect: sourceRect rule: r. - (self depth = 32 and: [ aForm depth < 32 ]) ifTrue: [ - "If we blit to 32bpp from one of smaller depth, - it will have zero in the alpha channel (until BitBlt is fixed!!) - This is the same workaround as in #asFormOfDepth:" - port sourceForm: nil. - port combinationRule: 40. "fixAlpha:with:" - port copyBits ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3136-BitBltCanvas-fix-JuanVuletich-2017Aug08-16h59m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3134] on 17 August 2017 at 1:06:03 pm'! -!PluggableListMorph methodsFor: 'events' stamp: 'jmv 8/17/2017 13:05:27' prior: 16888588! - doubleClick: aMouseButtonEvent localPosition: localEventPosition - | index | - doubleClickSelector ifNil: [ ^super doubleClick: aMouseButtonEvent localPosition: localEventPosition ]. - index _ self rowAtLocation: localEventPosition. - index = 0 ifTrue: [ ^super doubleClick: aMouseButtonEvent localPosition: localEventPosition ]. - index == self selectionIndex - ifFalse: [ self changeModelSelection: index ]. - ^ self model perform: doubleClickSelector! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3137-DoubleClickOnSelection-Inspector-Fix-JuanVuletich-2017Aug17-12h45m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3137] on 17 August 2017 at 5:00:13 pm'! -!Inspector methodsFor: 'user interface support' stamp: 'jmv 8/17/2017 16:28:29'! - textStylerClassFor: textGetter - - ^SHTextStylerST80! ! -!Inspector methodsFor: 'shout styling' stamp: 'jmv 8/17/2017 16:51:54'! - bindingNamesDo: aBlock - object class allInstVarNames do: aBlock! ! -!Inspector methodsFor: 'shout styling' stamp: 'jmv 8/17/2017 16:52:08'! - hasBindingOf: aString - ^ object class allInstVarNames includes: aString! ! -!Inspector methodsFor: 'shout styling' stamp: 'jmv 8/17/2017 16:48:11'! - shoutAboutToStyle: aSHTextStyler - "This is a notification that aSHTextStyler is about to re-style its text. - Set the classOrMetaClass in aSHTextStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - - aSHTextStyler -"No. Impica que es un metodo!! - classOrMetaClass: self selectedClassOrMetaClass." - - workspace: self. - ^true! ! -!ContextVariablesInspector methodsFor: 'shout styling' stamp: 'jmv 8/17/2017 16:58:45'! - bindingNamesDo: aBlock - fieldList do: aBlock! ! -!ContextVariablesInspector methodsFor: 'shout styling' stamp: 'jmv 8/17/2017 16:58:56'! - hasBindingOf: aString - ^ fieldList includes: aString! ! -!ObjectExplorer methodsFor: 'user interface support' stamp: 'jmv 8/17/2017 16:28:32'! - textStylerClassFor: textGetter - - ^SHTextStylerST80! ! -!ObjectExplorer methodsFor: 'shout styling' stamp: 'jmv 8/17/2017 16:54:38'! - bindingNamesDo: aBlock - self doItReceiver class allInstVarNames do: aBlock! ! -!ObjectExplorer methodsFor: 'shout styling' stamp: 'jmv 8/17/2017 16:54:33'! - hasBindingOf: aString - ^ self doItReceiver class allInstVarNames includes: aString! ! -!ObjectExplorer methodsFor: 'shout styling' stamp: 'jmv 8/17/2017 16:48:02'! - shoutAboutToStyle: aSHTextStyler - "This is a notification that aSHTextStyler is about to re-style its text. - Set the classOrMetaClass in aSHTextStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - - aSHTextStyler -"No. Impica que es un metodo!! - classOrMetaClass: self selectedClassOrMetaClass." - - workspace: self. - ^true! ! -!Inspector methodsFor: 'accessing' stamp: 'jmv 8/17/2017 16:47:26' prior: 16856921! - selectedClassOrMetaClass -"NOOOOOO" - ^ self selectedClass "I don't know any better"! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3138-ShoutInInspectorsAndExplorers-JuanVuletich-2017Aug17-16h27m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3137] on 17 August 2017 at 5:07:41 pm'! -!SmalltalkCompleter methodsFor: 'entries' stamp: 'jmv 8/17/2017 17:06:33' prior: 16909227! - computeEntries - - | allSource contextClass id specificModel last3Ranges range prevRange receiverClass prevPrevRange | - allSource _ model actualContents string. - specificModel _ (model is: #hasTextProvider) - ifTrue: [ model textProvider ] - ifFalse: [ model ]. - contextClass _ (specificModel is: #CodeProvider) ifTrue: [ - specificModel selectedClassOrMetaClass ]. - - "Instead of creating a new string, maybe we could pass the last position to parse to Shout..." - parser _ SHParserST80 new. - parser - workspace: specificModel; - classOrMetaClass: contextClass; - source: (allSource copyFrom: 1 to: position). - parser parse. - last3Ranges _ parser last3Ranges. - range _ last3Ranges third. - range ifNil: [ ^entries _ #() ]. - - "If parsing breaks before position, then we don't know what to suggest, therefore don't open Completion" - range end = position ifFalse: [ ^entries _ #() ]. - - prefix _ allSource copyFrom: range start to: range end. - - (parser isMessage: range rangeType) ifTrue: [ - "If previous range is a constant or a well known identifier, we might filter messages" - prevRange _ last3Ranges second. - prevPrevRange _ last3Ranges first. - receiverClass _ nil. - "3 if -> ifNil: but not ifTrue: - 3=4 -> ifNil: or ifTrue:" - (prevRange notNil and: [ prevPrevRange isNil or: [ (#(binary keyword) includes: prevPrevRange rangeType) not]]) ifTrue: [ - id _ (allSource copyFrom: prevRange start to: prevRange end). - receiverClass _ prevRange rangeType caseOf: { - [ #globalVar ] -> [ (Smalltalk at: id asSymbol) class ]. - [ #self ] -> [ contextClass ]. - [ #super ] -> [ contextClass superclass ]. - [ #true ] -> [ True ]. - [ #false ] -> [ False ]. - [ #nil ] -> [ UndefinedObject ]. - [ #character ] -> [ id first class ]. - [ #number ] -> [ (Compiler evaluate: id) class ]. - [ #string ] -> [ (Compiler evaluate: id) class ]. - [ #symbol ] -> [ (Compiler evaluate: id) class ]. - [ #stringSymbol ] -> [ (Compiler evaluate: id) class ]. - "thisContext could mean ContextPart or BlockClosure..." - "[ #thisContext ] -> [ ContextPart ]" - } otherwise: [ nil ] - ]. - ^self computeMessageEntries: receiverClass ]. - - (parser isPartialOrFullIdentifier: range rangeType) ifTrue: [ - ^self computeIdentifierEntries ]. - - "If we don't know what to do, do nothing" - entries _ #()! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3139-AutocompleterInInspectorsAndExplorers-JuanVuletich-2017Aug17-17h00m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3139] on 17 August 2017 at 9:26:32 pm'! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'jmv 9/22/2012 14:56' prior: 50365272! - morphHeight - -"Ensure everybody wants our coordinates!!" - self flag: #jmvVer2. - ^ extent y! ! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'jmv 2/16/2016 12:58' prior: 50365279! - morphPosition: newPos extent: newExtent - "Change the position of this morph. Argument is in owner's coordinates." - - | oldBoundsInWorld someChange | - - "Ask for the old bounds before updating them, but ask for repair only if extent or position has really changed." - oldBoundsInWorld _ self morphBoundsInWorld. - someChange _ false. - (location isTranslation: newPos) ifFalse: [ - location _ location withTranslation: newPos. - someChange _ true ]. - - extent = newExtent ifFalse: [ - (self privateExtent: newExtent) ifTrue: [ - someChange _ true ]]. - - someChange ifTrue: [ - "Ask for the old bounds before updating them, but ask for repair only if extent or position has really changed." - oldBoundsInWorld ifNotNil: [ - self invalidateDisplayRect: oldBoundsInWorld from: nil ]. - self someSubmorphPositionOrExtentChanged. - owner ifNotNil: [ owner someSubmorphPositionOrExtentChanged ]. - self redrawNeeded ]! ! -!RectangleLikeMorph methodsFor: 'geometry' stamp: 'jmv 9/22/2012 14:57' prior: 50365311! - morphWidth - -"Ensure everybody wants our coordinates!!" - self flag: #jmvVer2. - ^ extent x! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:55:30' prior: 50365318! - draw3DLookOn: aCanvas - - | borderStyleSymbol c | - borderStyleSymbol _ self isPressed ifFalse: [ #raised ] ifTrue: [ #inset ]. - c _ color. - self mouseIsOver ifTrue: [ c _ c lighter ]. - aCanvas - fillRectangle: (`0@0` extent: extent) - color: c - borderWidth: borderWidth - borderStyleSymbol: borderStyleSymbol - baseColorForBorder: c. - - self drawRegularLabelOn: aCanvas! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 5/1/2015 16:20' prior: 50365333! - drawEmbossedLabelOn: aCanvas - - | availableW center colorForLabel f l labelMargin targetSize w x y | - label ifNotNil: [ - colorForLabel _ Theme current buttonLabel. - self isPressed - ifFalse: [ - self mouseIsOver - ifFalse: [ colorForLabel _ colorForLabel adjustSaturation: -0.10 brightness: 0.10 ]] - ifTrue: [ colorForLabel _ colorForLabel adjustSaturation: 0.0 brightness: -0.07 ]. - f _ self fontToUse. - center _ extent // 2. - labelMargin _ 3. - w _ f widthOfString: label. - availableW _ extent x - labelMargin - labelMargin. - availableW >= w - ifTrue: [ - l _ label ] - ifFalse: [ - x _ labelMargin. - targetSize _ label size * availableW // w. - l _ label squeezedTo: targetSize. - (f widthOfString: l) > availableW ifTrue: [ - targetSize _ targetSize - 1. - l _ label squeezedTo: targetSize ]]. - - w _ f widthOfString: l. - x _ center x - (w // 2). - y _ center y - (f height // 2). - aCanvas - drawString: l - at: x@y - font: f - color: colorForLabel - embossed: true ]! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 7/10/2014 22:43' prior: 50365369! - drawRegularLabelOn: aCanvas - - | w f center x y availableW l labelMargin | - - f _ self fontToUse. - center _ extent // 2. - - label ifNotNil: [ - labelMargin _ 4. - w _ f widthOfString: label. - availableW _ extent x - labelMargin - labelMargin - 1. - availableW >= w - ifTrue: [ - x _ center x - (w // 2). - l _ label ] - ifFalse: [ - x _ labelMargin. - l _ label squeezedTo: (label size * availableW / w) rounded ]. - y _ center y - (f height // 2). - self isPressed ifTrue: [ - x _ x + 1. - y _ y + 1 ]. - aCanvas - drawString: l - at: x@y - font: f - color: Theme current buttonLabel ]! ! -!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jmv 6/19/2017 15:55:46' prior: 50365392! - drawRoundGradientLookOn: aCanvas - | r colorForButton rect bottomFactor topFactor | - - self isPressed - ifFalse: [ - topFactor _ Theme current buttonGradientTopFactor. - bottomFactor _ Theme current buttonGradientBottomFactor. - self mouseIsOver - ifTrue: [ - colorForButton _ Color h: color hue s: color saturation * 1.3 v: color brightness * 0.9 ] - ifFalse: [ - colorForButton _ color ]] - ifTrue: [ - topFactor _ Theme current buttonGradientBottomFactor. - bottomFactor _ Theme current buttonGradientTopFactor. - colorForButton _ color adjustSaturation: 0.1 brightness: -0.1 ]. - - colorForButton ifNotNil: [ - r _ Theme current roundedButtonRadius. - Theme current useButtonGradient - ifTrue: [ - rect _ (`0@0` extent: extent) insetBy: `1@3`. - aCanvas - roundRect: rect - color: colorForButton - radius: r - gradientTop: topFactor - gradientBottom: bottomFactor - gradientHeight: Theme current buttonGradientHeight ] - ifFalse: [ - rect _ (`0@0` extent: extent) insetBy: `1@3`. - aCanvas roundRect: rect color: colorForButton radius: r ] - ]. - - Theme current embossedButtonLabels - ifTrue: [ self drawEmbossedLabelOn: aCanvas ] - ifFalse: [ self drawRegularLabelOn: aCanvas ]! ! -!PluggableButtonMorph methodsFor: 'initialization' stamp: 'jmv 6/19/2017 16:09:15' prior: 50365435! - initialize - "initialize the state of the receiver" - super initialize. - - roundButtonStyle _ nil. "nil: honor Theme. true: draw as round button. false: draw as classic 3d border square button" - model _ nil. - getStateSelector _ nil. - actionSelector _ nil. - isPressed _ false. - mouseIsOver _ false. - actWhen _ #buttonUp. - extent _ `20 @ 15`! ! -!PluggableButtonMorph methodsFor: 'private' stamp: 'jmv 2/17/2017 15:10:48' prior: 50365453! - magnifiedIcon - | factor magnifiedExtent w h | - - icon ifNil: [ ^nil ]. - magnifiedIcon ifNil: [ - magnifiedIcon _ icon. - w _ icon width. - h _ icon height. - w*h = 0 ifFalse: [ - factor _ 1.0 * extent x / w min: 1.0 * extent y / h. - (factor < 1 or: [ factor > 1.7 and: [self isRoundButton]]) ifTrue: [ - magnifiedExtent _ (icon extent * factor) rounded. - magnifiedIcon _ icon magnifyTo: magnifiedExtent ]]]. - ^magnifiedIcon! ! -!PluggableButtonMorph methodsFor: 'geometry testing' stamp: 'jmv 6/19/2017 15:55:52' prior: 50365471! - morphContainsPoint: aLocalPoint - - | iconOrigin | - ((`0@0` extent: extent) containsPoint: aLocalPoint) ifFalse: [ ^false ]. - ^ self isOrthoRectangularMorph or: [ - magnifiedIcon isNil or: [ - iconOrigin _ extent - magnifiedIcon extent // 2. - (magnifiedIcon isTransparentAt: (aLocalPoint - iconOrigin) rounded) not ]]! ! - -PluggableButtonMorph removeSelector: #morphExtent! - -PluggableButtonMorph removeSelector: #morphExtent! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3140-Revert-3124-BreaksExistingPackages-JuanVuletich-2017Aug17-21h24m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3140] on 17 August 2017 at 9:45:47 pm'! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 8/17/2017 21:37:11'! - raisedToFraction: aFraction - self isZero ifTrue: [ - aFraction negative ifTrue: [ - ^ (ZeroDivide dividend: 1) signal ]. - ^ self ]. - self negative ifFalse: [ - ^ (self ln * aFraction) exp ]. - aFraction denominator even ifTrue: [ - ^ ArithmeticError signal: 'nth root only defined for positive Integer n.' ]. - ^ (self negated ln * aFraction) exp negated! ! -!Fraction methodsFor: 'mathematical functions' stamp: 'jmv 8/17/2017 21:37:35'! - raisedToFraction: aFraction - | root | - root _ (self numerator nthRootTruncated: aFraction denominator) / - (self denominator nthRootTruncated: aFraction denominator). - (root raisedToInteger: aFraction denominator) = self ifTrue: [ - ^ root raisedToInteger: aFraction numerator ]. - ^ super raisedToFraction: aFraction! ! -!Integer methodsFor: 'mathematical functions' stamp: 'jmv 8/17/2017 21:37:42'! - raisedToFraction: aFraction - | root | - root _ self nthRootTruncated: aFraction denominator. - (root raisedToInteger: aFraction denominator) = self ifTrue: [ - ^ root raisedToInteger: aFraction numerator ]. - ^ super raisedToFraction: aFraction! ! -!Number methodsFor: 'mathematical functions' stamp: 'jmv 8/17/2017 21:44:25' prior: 16880173! - raisedTo: aNumber - "Answer the receiver raised to aNumber." - - aNumber isInteger ifTrue: [ - "Do the special case of integer power" - ^ self raisedToInteger: aNumber]. - aNumber isFraction ifTrue: [ - "Special case for fraction power by Nicolas Cellier: - If aNumber is a fraction, but result must be a Float, learn it as quickly as possible, and give quick Float answer - Allows evaluating: - (2009/2000) raisedTo: (3958333/100000) - " - ^ self raisedToFraction: aNumber]. - self < 0 ifTrue: [ - ^ ArithmeticError signal: 'Negative numbers can''t be raised to float powers.' ]. - 0 = aNumber ifTrue: [^ self class one]. "Special case of exponent=0" - 1 = aNumber ifTrue: [^ self]. "Special case of exponent=1" - 0 = self ifTrue: [ "Special case of self = 0" - aNumber < 0 - ifTrue: [^ (ZeroDivide dividend: self) signal] - ifFalse: [^ self]]. - ^ (aNumber * self ln) exp "Otherwise use logarithms"! ! -!Fraction methodsFor: 'mathematical functions' stamp: 'jmv 8/17/2017 21:38:55' prior: 16849696! - nthRoot: aPositiveInteger - "Answer the nth root of the receiver." - | guess | - guess _ (numerator nthRootTruncated: aPositiveInteger) / - (denominator nthRootTruncated: aPositiveInteger). - (guess raisedTo: aPositiveInteger) = self ifTrue: [ - ^ guess ]. - "There is no exact nth root, so answer a Float approximation" - ^ (self abs ln / aPositiveInteger) exp * self sign! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3141-raisedTo-fix-NicolasCellier-2017Aug17-21h28m-jmv.1.cs.st----! - -----SNAPSHOT----#(17 August 2017 10:41:17.376739 pm) Cuis5.0-3141.image priorSource: 1138726! - -----QUIT----#(17 August 2017 10:41:31.478313 pm) Cuis5.0-3141.image priorSource: 1157913! - -----STARTUP----#(18 August 2017 6:05:19.36561 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3141.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3138] on 18 August 2017 at 3:36:55 pm'! -!Debugger methodsFor: 'code pane' stamp: 'jmv 8/18/2017 15:36:20' prior: 16829971! - contentsSelection - - "If we are just creating the method in the debugger, help the user by selecting the method body." - currentCompiledMethod ifNotNil: [ - ((currentCompiledMethod hasLiteral: #shouldBeImplemented) and: [ - (self selectedContext debuggerMap method abstractPCForConcretePC: self selectedContext pc) = 1]) ifTrue: [ - ^currentCompiledMethod selector size + 3 to: currentCompiledMethod getSource size ]]. - - ^self pcRange! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3142-autoSelectBodyIfCreateInDebugger-JuanVuletich-2017Aug18-15h00m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3141] on 18 August 2017 at 5:43:59 pm'! -!Workspace methodsFor: 'testing' stamp: 'jmv 8/18/2017 17:42:35'! - is: aSymbol - ^ aSymbol == #providesBindings or: [ super is: aSymbol ]! ! -!Debugger methodsFor: 'testing' stamp: 'jmv 8/18/2017 17:41:49'! - is: aSymbol - ^ aSymbol == #providesBindings or: [ super is: aSymbol ]! ! -!Inspector methodsFor: 'testing' stamp: 'jmv 8/18/2017 17:42:07'! - is: aSymbol - ^ aSymbol == #providesBindings or: [ super is: aSymbol ]! ! -!ObjectExplorer methodsFor: 'testing' stamp: 'jmv 8/18/2017 17:42:19'! - is: aSymbol - ^ aSymbol == #providesBindings or: [ super is: aSymbol ]! ! -!Inspector methodsFor: 'accessing' stamp: 'jmv 9/21/2009 15:16' prior: 50367437! - selectedClassOrMetaClass - - ^ self selectedClass "I don't know any better"! ! -!SmalltalkCompleter methodsFor: 'entries' stamp: 'jmv 8/18/2017 17:43:14' prior: 50367451! - computeEntries - - | allSource contextClass id specificModel last3Ranges range prevRange receiverClass prevPrevRange | - allSource _ model actualContents string. - specificModel _ (model is: #hasTextProvider) - ifTrue: [ model textProvider ] - ifFalse: [ model ]. - contextClass _ (specificModel is: #CodeProvider) ifTrue: [ - specificModel selectedClassOrMetaClass ]. - - "Instead of creating a new string, maybe we could pass the last position to parse to Shout..." - parser _ SHParserST80 new. - parser - workspace: ((specificModel is: #providesBindings) ifTrue: [specificModel]); - classOrMetaClass: contextClass; - source: (allSource copyFrom: 1 to: position). - parser parse. - last3Ranges _ parser last3Ranges. - range _ last3Ranges third. - range ifNil: [ ^entries _ #() ]. - - "If parsing breaks before position, then we don't know what to suggest, therefore don't open Completion" - range end = position ifFalse: [ ^entries _ #() ]. - - prefix _ allSource copyFrom: range start to: range end. - - (parser isMessage: range rangeType) ifTrue: [ - "If previous range is a constant or a well known identifier, we might filter messages" - prevRange _ last3Ranges second. - prevPrevRange _ last3Ranges first. - receiverClass _ nil. - "3 if -> ifNil: but not ifTrue: - 3=4 -> ifNil: or ifTrue:" - (prevRange notNil and: [ prevPrevRange isNil or: [ (#(binary keyword) includes: prevPrevRange rangeType) not]]) ifTrue: [ - id _ (allSource copyFrom: prevRange start to: prevRange end). - receiverClass _ prevRange rangeType caseOf: { - [ #globalVar ] -> [ (Smalltalk at: id asSymbol) class ]. - [ #self ] -> [ contextClass ]. - [ #super ] -> [ contextClass superclass ]. - [ #true ] -> [ True ]. - [ #false ] -> [ False ]. - [ #nil ] -> [ UndefinedObject ]. - [ #character ] -> [ id first class ]. - [ #number ] -> [ (Compiler evaluate: id) class ]. - [ #string ] -> [ (Compiler evaluate: id) class ]. - [ #symbol ] -> [ (Compiler evaluate: id) class ]. - [ #stringSymbol ] -> [ (Compiler evaluate: id) class ]. - "thisContext could mean ContextPart or BlockClosure..." - "[ #thisContext ] -> [ ContextPart ]" - } otherwise: [ nil ] - ]. - ^self computeMessageEntries: receiverClass ]. - - (parser isPartialOrFullIdentifier: range rangeType) ifTrue: [ - ^self computeIdentifierEntries ]. - - "If we don't know what to do, do nothing" - entries _ #()! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3143-fixRecentAutocompleteBug-JuanVuletich-2017Aug18-17h34m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3129] on 18 August 2017 at 9:07:32 am'! -!Message methodsFor: 'stub creation' stamp: 'HAW 8/18/2017 09:04:10'! - addGetterCodeOn: stream - - stream - newLine; tab; - nextPut: $^; - nextPutAll: selector ! ! -!Message methodsFor: 'stub creation' stamp: 'HAW 8/18/2017 09:04:52'! - addSetterCodeOn: stream with: argumentName - - stream - newLine; tab; - nextPutAll: selector allButLast; - nextPutAll: ' := '; - nextPutAll: argumentName ! ! -!Message methodsFor: 'stub creation' stamp: 'HAW 8/18/2017 07:43:09'! - writeShouldBeImplementedOn: stream. - - stream - nextPutAll: 'self '; - nextPutAll: #shouldBeImplemented; - nextPut: $.! ! -!Message methodsFor: 'testing' stamp: 'HAW 8/18/2017 07:40:37'! - isGetter - - ^selector isUnary and: [ lookupClass instVarNames includes: selector ]! ! -!Message methodsFor: 'testing' stamp: 'HAW 8/18/2017 07:44:22'! - isSetter - - ^selector isKeyword and: [ self numArgs = 1 and: [ lookupClass instVarNames includes: selector allButLast ]]! ! -!Message methodsFor: 'stub creation' stamp: 'HAW 8/18/2017 09:03:49' prior: 16867424! - createStubMethod - | argNames aOrAn argName arg argClassName | - - argNames _ Set new. - ^ String streamContents: [ :s | - self selector keywords withIndexDo: [ :key :i | - s nextPutAll: key. - ((key last = $:) or: [self selector isInfix]) ifTrue: [ - arg _ self arguments at: i. - argClassName _ (arg class isMeta) ifTrue: ['Class'] ifFalse: [arg class name]. - aOrAn _ argClassName first isVowel ifTrue: ['an'] ifFalse: ['a']. - argName _ aOrAn, argClassName. - [argNames includes: argName] whileTrue: [argName _ argName, i asString]. - argNames add: argName. - s nextPutAll: ' '; nextPutAll: argName; space - ]. - ]. - s newLine; tab. - self writeShouldBeImplementedOn: s. - self isGetter ifTrue: [ self addGetterCodeOn: s ]. - self isSetter ifTrue: [ self addSetterCodeOn: s with: argName ]. - ]! ! - -Message removeSelector: #createGetterStub! - -Message removeSelector: #createSetterStub! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3144-CreateAccessorsInDebugger-HernanWilkinson-2017Aug17-20h05m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3144] on 18 August 2017 at 6:03:22 pm'! -!Debugger methodsFor: 'code pane' stamp: 'jmv 8/18/2017 18:02:55' prior: 50367848! - contentsSelection - - "If we are just creating the method in the debugger, help the user by selecting the method body." - | sendInterval | - currentCompiledMethod ifNotNil: [ - ((currentCompiledMethod hasLiteral: #shouldBeImplemented) and: [ - (currentCompiledMethod abstractPCForConcretePC: self selectedContext pc) = 1]) ifTrue: [ - sendInterval _ (self selectedContext debuggerMap abstractSourceMap at: 2 ifAbsent: [nil]). - sendInterval ifNotNil: [ ^ sendInterval first - 5 to: sendInterval last + 1 ]]]. - - ^self pcRange! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3145-autoSelectOnCreateInDebugger-update-JuanVuletich-2017Aug18-17h52m-jmv.1.cs.st----! - -----SNAPSHOT----#(18 August 2017 6:05:26.606222 pm) Cuis5.0-3145.image priorSource: 1158008! - -----QUIT----#(18 August 2017 6:05:36.519928 pm) Cuis5.0-3145.image priorSource: 1165642! - -----STARTUP----#(28 August 2017 9:43:32.500614 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3145.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3145] on 22 August 2017 at 11:23:45 am'! -!Object methodsFor: 'message handling' stamp: 'HAW 8/22/2017 10:17:59'! - argumentName - - ^self argumentNameSufix prefixedWithAOrAn ! ! -!Object methodsFor: 'message handling' stamp: 'HAW 8/22/2017 10:16:01'! - argumentNameSufix - - ^self class isMeta ifTrue: ['Class'] ifFalse: [self class name]! ! -!String methodsFor: 'converting' stamp: 'HAW 8/22/2017 10:14:02'! - aOrAnPrefix - - ^self isEmpty - ifTrue: [ self ] - ifFalse: [ self first isVowel ifTrue: ['an'] ifFalse: ['a'] ] -! ! -!String methodsFor: 'converting' stamp: 'HAW 8/22/2017 10:14:46'! - prefixedWithAOrAn - - ^self aOrAnPrefix, self! ! -!Debugger methodsFor: 'method creation' stamp: 'HAW 8/22/2017 11:22:30' prior: 50336735! - implement: aMessage inClass: aClass context: aContext - - aClass - compile: (aMessage createStubMethodFor: aClass) - classified: (self askForCategoryIn: aClass default: 'as yet unclassified'). - - aContext privRefreshWith: (aClass lookupSelector: aMessage selector). - aMessage arguments withIndexDo: [ :arg :index | aContext tempAt: index put: arg ]. - self resetContext: aContext! ! -!Message methodsFor: 'stub creation' stamp: 'HAW 8/22/2017 11:23:03' prior: 50367982! - addGetterCodeOn: stream - - stream - newLine; tab; - nextPut: $^; - nextPutAll: selector ! ! -!Message methodsFor: 'stub creation' stamp: 'HAW 8/22/2017 11:23:07' prior: 50367988! - addSetterCodeOn: stream with: argumentName - - stream - newLine; tab; - nextPutAll: selector allButLast; - nextPutAll: ' := '; - nextPutAll: argumentName ! ! -!Message methodsFor: 'stub creation' stamp: 'HAW 8/22/2017 11:22:53'! - createStubMethodFor: aClass - - | argNames argName arg | - - argNames _ Set new. - ^ String streamContents: [ :s | - self selector keywords withIndexDo: [ :key :i | - s nextPutAll: key. - ((key last = $:) or: [self selector isInfix]) ifTrue: [ - arg _ self arguments at: i. - argName _ arg argumentName. - [argNames includes: argName] whileTrue: [argName _ argName, i asString]. - argNames add: argName. - s nextPutAll: ' '; nextPutAll: argName; space - ]. - ]. - - s newLine; tab. - self writeShouldBeImplementedOn: s. - (self isGetterFor: aClass) ifTrue: [ self addGetterCodeOn: s ]. - (self isSetterFor: aClass) ifTrue: [ self addSetterCodeOn: s with: argName ]. - ]! ! -!Message methodsFor: 'stub creation' stamp: 'HAW 8/22/2017 11:23:11' prior: 50367996! - writeShouldBeImplementedOn: stream. - - stream - nextPutAll: 'self '; - nextPutAll: #shouldBeImplemented; - nextPut: $.! ! -!Message methodsFor: 'testing' stamp: 'HAW 8/22/2017 11:22:40'! - isGetterFor: aClass - - ^selector isUnary and: [ aClass instVarNames includes: selector ]! ! -!Message methodsFor: 'testing' stamp: 'HAW 8/22/2017 11:22:43'! - isSetterFor: aClass - - ^selector isKeyword and: [ self numArgs = 1 and: [ aClass instVarNames includes: selector allButLast ]]! ! - -Message removeSelector: #createStubMethod! - -Message removeSelector: #createStubMethod! - -Message removeSelector: #isGetter! - -Message removeSelector: #isGetter! - -Message removeSelector: #isSetter! - -Message removeSelector: #isSetter! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3146-CreateAccessorsInDebuggerFix-HernanWilkinson-2017Aug19-20h52m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3145] on 23 August 2017 at 2:35:44 pm'! -!TextModelMorph methodsFor: 'accessing' stamp: 'HAW 8/23/2017 14:22:17'! - enableEdition - - self textMorph enableEdition! ! -!InnerTextMorph methodsFor: 'accessing' stamp: 'HAW 8/23/2017 14:23:36'! - enableEdition - - self removeProperty: #disablesEdition! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3147-textMorph-enableEdition-HernanWilkinson-2017Aug23-12h52m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3147] on 25 August 2017 at 10:56:35 am'! -!Object methodsFor: 'printing' stamp: 'jmv 8/25/2017 10:55:31' prior: 16882206! - printOn: aStream - "Append to the argument, aStream, a sequence of characters that - identifies the receiver." - - | title | - title _ self class name. - aStream - nextPutAll: title aOrAnPrefix; - space; - nextPutAll: title! ! -!Object methodsFor: 'printing' stamp: 'jmv 8/25/2017 10:55:49' prior: 16882255! - printWithClosureAnalysisOn: aStream - "Append to the argument, aStream, a sequence of characters that - identifies the receiver." - - | title | - title _ self class name. - aStream - nextPutAll: title aOrAnPrefix; - space; - nextPutAll: title! ! -!ContextPart methodsFor: 'debugger access' stamp: 'jmv 8/25/2017 10:55:54' prior: 16824084! - print: anObject on: aStream - "Safely print anObject in the face of direct ProtoObject subclasses." - | objClass title | - objClass _ self objectClass: anObject. - (objClass canUnderstand: #printOn:) ifTrue: [ - ^anObject printOn: aStream]. - title _ objClass name. - aStream - nextPutAll: title aOrAnPrefix; - space; - nextPutAll: title! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3148-Use-aOrAnPrefix-JuanVuletich-2017Aug25-10h53m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3128] on 23 July 2017 at 1:07:52 am'! -!CodePackageListWindow methodsFor: 'GUI building' stamp: 'pb 7/23/2017 00:53:45' prior: 50359402! - buildMorphicWindow - " - CodePackageListWindow open: CodePackageList new - " - | dirtyFlags names fileNames upperRow description summary backColor labelBackground textHeigth | - backColor := self textBackgroundColor. - labelBackground := Theme current background. - textHeigth := AbstractFont default height. - - dirtyFlags := PluggableListMorph - model: model - listGetter: #packageDirtyFlags - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - dirtyFlags color: backColor. - dirtyFlags := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorph: (StringMorph new contents: ' Unsaved?') fixedHeight: textHeigth; - addMorphUseAll: dirtyFlags. - - names := PluggableListMorph - model: model - listGetter: #packageNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - names color: backColor. - names := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorph: (StringMorph new contents: ' Package Name') fixedHeight: textHeigth; - addMorphUseAll: names. - - fileNames := PluggableListMorph - model: model - listGetter: #packageFullNames - indexGetter: #selectionIndex - indexSetter: #selectionIndex:. - fileNames color: backColor. - fileNames := LayoutMorph newColumn - color: labelBackground; - addMorph: (RectangleLikeMorph new color: Color transparent) fixedHeight: 4; - addMorph: (StringMorph new contents: ' File Name') fixedHeight: textHeigth; - addMorphUseAll: fileNames. - - upperRow := LayoutMorph newRow. - upperRow - addMorph: dirtyFlags proportionalWidth: 0.13; - addAdjusterAndMorph: names proportionalWidth: 0.27; - addAdjusterAndMorph: fileNames proportionalWidth: 0.6. - - description := TextModelMorph - textProvider: model - textGetter: #description - textSetter: #description:. - - summary := TextModelMorph - textProvider: model - textGetter: #summary. - - self layoutMorph - addMorph: upperRow proportionalHeight: 0.6; - addAdjusterAndMorph: self buildButtonPane fixedHeight: Theme current buttonPaneHeight; - addAdjusterAndMorph: summary fixedHeight: 60; - addAdjusterAndMorph: description proportionalHeight: 0.25; - addAdjusterAndMorph: self buildRequirementsPane proportionalHeight: 0.15. - self setLabel: 'Installed Packages'! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3149-CodePackageWindow-layout-tweak-PhilBellalouna-2017Jul23-00h53m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3128] on 23 July 2017 at 1:47:54 pm'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3150-category-cleanup-PhilBellalouna-2017Jul23-13h39m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3131] on 27 July 2017 at 3:27:46 am'! -!Debugger class methodsFor: 'opening' stamp: 'pb 7/27/2017 03:27:10' prior: 16830456! -openOn: process context: context label: title fullView: bool - "Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger." - | w | - Preferences logDebuggerStackToFile ifTrue: [ - Smalltalk - logError: title - inContext: context - to: 'CuisDebug.log' ]. - w := ProjectX newProcessIfUIX: process. - "schedule debugger in deferred UI message to address redraw - problems after opening a debugger e.g. from the testrunner." - WorldState addDeferredUIMessage: [ - [ | debugger | - "In case an error in Morphic code got us here, ensure mouse focus has been released" - true runningWorld ifNotNil: [ :rWorld | - rWorld activeHand ifNotNil: [ :aHand | - aHand releaseMouseFocus ]]. - debugger := self new - process: process - context: context. - debugger interruptedProcessUI: w. - bool - ifTrue: [ debugger openFullMorphicLabel: title ] - ifFalse: [ - PreDebugWindow - open: debugger - label: title - message: nil ]] - on: UnhandledError - do: [ :exOuter | | errorDescription | - errorDescription := 'Error while trying to open Debugger' , String newLineString , 'Orginal error: ' , title asString , '.' , String newLineString , ' Debugger error: ' , - ([ exOuter description ] - on: UnhandledError - do: [ :exInner | - exInner return: 'a ' , exInner class printString ]) , ':'. - self primitiveError: errorDescription ]]. - process suspend.! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3151-Debugger-ensure-focus-released-fix-PhilBellalouna-2017Jul27-03h27m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3130] on 27 July 2017 at 2:24:40 pm'! -!HierarchicalListMorph methodsFor: 'commands' stamp: 'pb 7/27/2017 14:24:23' prior: 16852992! - toggleExpandedState: aMorph event: event - - "self setSelectedMorph: aMorph." - ((self autoExpand or: [event shiftPressed]) and: [aMorph isExpanded not]) - ifTrue: [aMorph beFullyExpanded] - ifFalse: [aMorph toggleExpandedState]. - scroller adjustExtent. - self setScrollDeltas! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3152-HierarchicalListMorph-shift-key-fully-expands-PhilBellalouna-2017Jul27-14h17m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3130] on 27 July 2017 at 6:26:56 am'! - -TextProvider subclass: #FileList - instanceVariableNames: 'acceptedContentsCache fileName directory list listIndex pattern sortMode brevityState sortAscending showDirsInFileList currentDirectorySelected ' - classVariableNames: 'FileReaderRegistry ' - poolDictionaries: '' - category: 'Tools-FileList'! - -!classDefinition: #FileList category: #'Tools-FileList'! -TextProvider subclass: #FileList - instanceVariableNames: 'acceptedContentsCache fileName directory list listIndex pattern sortMode brevityState sortAscending showDirsInFileList currentDirectorySelected' - classVariableNames: 'FileReaderRegistry' - poolDictionaries: '' - category: 'Tools-FileList'! -!FileList class methodsFor: 'file reader registration' stamp: 'pb 7/27/2017 06:05:51' prior: 16843241! - itemsForFile: filename - "Answer a list of services appropriate for a file of the given name" - | services suffix classList | - suffix _ (FileIOAccessor default extensionFor: filename) asLowercase. - services _ OrderedCollection new. - "Build the list dynamically for all implementers of the appropriate class method... registration no longer required" - classList _ (Smalltalk allClassesImplementing: #fileReaderServicesForFile:suffix:) - collect: [ :item | - item class == Metaclass ifTrue: [ item soleInstance ]] - thenSelect: [ :item | - item notNil ]. - classList do: [ :reader | - reader ifNotNil: [ - services addAll: - (reader - fileReaderServicesForFile: filename - suffix: suffix) ]]. - ^ services.! ! -!FileList class methodsFor: 'file reader registration' stamp: 'pb 7/27/2017 06:02:20' prior: 16843256! - registerFileReader: aProviderClass - "For compatibility... no longer necessary"! ! -!FileList class methodsFor: 'file reader registration' stamp: 'pb 7/27/2017 06:02:32' prior: 16843266! - unregisterFileReader: aProviderClass - "For compatibility... no longer necessary"! ! - -Morph class removeSelector: #unload! - -Morph class removeSelector: #unload! - -Form class removeSelector: #unload! - -Form class removeSelector: #unload! - -FileList class removeSelector: #initialize! - -FileList class removeSelector: #initialize! - -ChangeSorter class removeSelector: #unload! - -ChangeSorter class removeSelector: #unload! - -ChangeList class removeSelector: #unload! - -ChangeList class removeSelector: #unload! - -CodeFileBrowser class removeSelector: #unload! - -CodeFileBrowser class removeSelector: #unload! - -MessageNames class removeSelector: #unload! - -MessageNames class removeSelector: #unload! - -TextProvider subclass: #FileList - instanceVariableNames: 'acceptedContentsCache fileName directory list listIndex pattern sortMode brevityState sortAscending showDirsInFileList currentDirectorySelected' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-FileList'! - -!classDefinition: #FileList category: #'Tools-FileList'! -TextProvider subclass: #FileList - instanceVariableNames: 'acceptedContentsCache fileName directory list listIndex pattern sortMode brevityState sortAscending showDirsInFileList currentDirectorySelected' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-FileList'! - -FileList initialize! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3153-FileList-dynamic-registration-PhilBellalouna-2017Jul27-05h59m-pb.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3153] on 25 August 2017 at 1:01:32 pm'! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'jmv 8/25/2017 13:00:40' prior: 50366856! - goDown - self selected = completer entryCount ifTrue: [ - "Wrap around" - ^ self goHome ]. - self selected: self selected + 1. - (self selected > self lastVisible - and: [self selected <= completer entryCount]) - ifTrue: [firstVisible := firstVisible + 1]. - self redrawNeeded! ! -!AutoCompleterMorph methodsFor: 'actions' stamp: 'jmv 8/25/2017 13:00:48' prior: 50366888! - goUp - (self selected = 0 - and: [self firstVisible = 1]) - ifTrue: [^ self]. - self selected = 1 ifTrue: [ - "Wrap around" - ^self goToEnd ]. - self selected: self selected - 1. - self selected < self firstVisible - ifTrue: [firstVisible := firstVisible - 1]. - self redrawNeeded! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3154-WraparoundAutoComplete-JuanVuletich-2017Aug25-12h57m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3145] on 28 August 2017 at 1:59:42 pm'! -!CompiledMethod class methodsFor: 'method encoding' stamp: 'HAW 8/28/2017 13:59:31' prior: 16821632! - headerFlagForEncoder: anEncoder - - (anEncoder class includesBehavior: PrimaryBytecodeSetEncoderClass) ifTrue: [^0]. - (anEncoder class includesBehavior: SecondaryBytecodeSetEncoderClass) ifTrue: [^SmallInteger minVal]. - - self error: 'The encoder is not one of the two installed bytecode sets'! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3155-AllowOtherMethodEncoders-HernanWilkinson-2017Aug28-13h56m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3145] on 28 August 2017 at 1:50:13 pm'! - -CodeWindow subclass: #BrowserWindow - instanceVariableNames: 'codePane ' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Tools'! - -!classDefinition: #BrowserWindow category: #'Morphic-Tools'! -CodeWindow subclass: #BrowserWindow - instanceVariableNames: 'codePane' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Tools'! -!BrowserWindow methodsFor: 'updating' stamp: 'HAW 8/28/2017 13:44:30'! - disableCodePaneEdition - - codePane ifNotNil: [ codePane disableEdition ]! ! -!BrowserWindow methodsFor: 'updating' stamp: 'HAW 8/28/2017 13:41:24'! - editSelectionChanged - - self isEditSelectionNone - ifTrue: [ self disableCodePaneEdition ] - ifFalse: [ self enableCodePaneEdition]! ! -!BrowserWindow methodsFor: 'updating' stamp: 'HAW 8/28/2017 13:43:20'! - enableCodePaneEdition - - codePane ifNotNil: [ codePane enableEdition ]! ! -!BrowserWindow methodsFor: 'updating' stamp: 'HAW 8/28/2017 13:43:44'! - isEditSelectionNone - - ^ model editSelection = #none! ! -!BrowserWindow methodsFor: 'updating' stamp: 'HAW 8/28/2017 13:41:51'! -update: anEvent - super update: anEvent. - anEvent = #editSelection ifTrue: [self editSelectionChanged ] ! ! -!BrowserWindow methodsFor: 'GUI building' stamp: 'HAW 8/28/2017 13:39:41'! - buildMorphicCodePane - "Construct the pane that shows the code. - Respect the Preference for standardCodeFont." - - codePane _ super buildMorphicCodePane. - ^codePane! ! - -CodeWindow subclass: #BrowserWindow - instanceVariableNames: 'codePane' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Tools'! - -!classDefinition: #BrowserWindow category: #'Morphic-Tools'! -CodeWindow subclass: #BrowserWindow - instanceVariableNames: 'codePane' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Tools'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3156-DisableEditionIfNoSysCatSelected-HernanWilkinson-2017Aug23-14h35m-HAW.2.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3156] on 28 August 2017 at 5:05:29 pm'! -!MessageSet methodsFor: 'private' stamp: 'jmv 8/28/2017 17:05:18' prior: 16870086! - initializeMessageList: anArray - - messageList _ anArray. - messageList isEmpty - ifTrue: [ selectedMessage _ nil ] - ifFalse: [ - selectedMessage _ messageList first. - self editSelection: #editMessage ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3157-MessageSetFix-JuanVuletich-2017Aug28-16h59m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3157] on 28 August 2017 at 5:16:24 pm'! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 8/28/2017 17:06:34'! - reservedNames - - ^Theme current pseudoVariables! ! -!ClassBuilder methodsFor: 'private' stamp: 'jmv 8/28/2017 16:58:40' prior: 16804009! - reservedNames - "Return a list of names that must not be used for variables" - ^#(#self #super #true #false #nil #thisContext)! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 8/28/2017 16:51:25' prior: 16902210! -isIncompleteReservedName: aString - "Answer true if aString is the start of a reserved name, false otherwise" - - self reservedNames do: [ :arg | (arg beginsWith: aString) ifTrue: [ ^true ]]. - ^false! ! -!SHParserST80 methodsFor: 'identifier testing' stamp: 'jmv 8/28/2017 16:53:14' prior: 16902288! - resolve: aString - - self reservedNames do: [ :symbol | aString = symbol ifTrue: [^symbol]]. - (self isBlockTempName: aString) ifTrue: [^#blockTempVar]. - (self isBlockArgName: aString) ifTrue: [^#blockArg]. - (self isMethodTempName: aString) ifTrue: [^#tempVar]. - (self isMethodArgName: aString) ifTrue: [^#methodArg]. - (self isInstVarName: aString) ifTrue: [^#instVar]. - (self isWorkspaceVarName: aString) ifTrue: [^#workspaceVar]. - Symbol hasInterned: aString ifTrue: [ :symbol | - (self isClassVarName: symbol) ifTrue: [ ^#classVar ]. - (self isPoolConstantName: symbol) ifTrue: [ ^#poolConstant]. - (self isGlobal: symbol) ifTrue: [^#globalVar]]. - ^self resolvePartial: aString! ! -!SHParserST80 methodsFor: 'indentifier iteration' stamp: 'jmv 8/28/2017 16:52:46' prior: 16902979! - nonGlobalNamesDo: aBlock - "Evaluate aBlock over all available names, except for globals" - - self - blockArgNamesDo: aBlock; - blockTempNamesDo: aBlock; - methodArgNamesDo: aBlock; - methodTempNamesDo: aBlock; - instVarNamesDo: aBlock; - classVarNamesDo: aBlock; - poolConstantNamesDo: aBlock; - workspaceNamesDo: aBlock. - self - reservedNames do: aBlock! ! -!SHParserST80 methodsFor: 'testing' stamp: 'jmv 8/28/2017 17:14:20' prior: 16903020! - isPartialOrFullIdentifier: aSymbol - - (#(#incompleteIdentifier - #blockTempVar #blockArg #tempVar #methodArg - #instVar #classVar - #workspaceVar #poolConstant #globalVar ) - statePointsTo:aSymbol) ifTrue: [ ^ true ]. - (self reservedNames statePointsTo: aSymbol) ifTrue: [ ^ true ]. - ^ false! ! - -SHParserST80 removeSelector: #isReservedName:! - -SHParserST80 removeSelector: #isReservedName:! - -SHParserST80 removeSelector: #reservedNamesDo:! - -SHParserST80 removeSelector: #reservedNamesDo:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3158-AllowNewReservedNamesInSHParserST80-JuanVuletich-2017Aug28-17h12m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3158] on 28 August 2017 at 5:26:35 pm'! -!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jmv 8/25/2017 15:05:56' prior: 16888064! -label: aStringOrNil font: aFontOrNil - "Label this button with the given string." - label _ aStringOrNil. - font _ aFontOrNil. - (self fontToUse notNil and: [ label notNil ]) - ifTrue: [ "Add a bit of padding" - extent := (self fontToUse widthOfString: label) + 10 @ (self fontToUse height + 10) ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3159-SetAppropriateButtonExtent-JuanVuletich-2017Aug28-17h25m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3154] on 26 August 2017 at 7:48:09 pm'! -!TextModel methodsFor: 'user interface support' stamp: 'jmv 8/26/2017 19:19:29'! - formatAndStyleIfNeededWith: anSHTextStyler - anSHTextStyler ifNotNil: [ - (self shouldStyle: self actualContents with: anSHTextStyler) ifTrue: [ - anSHTextStyler formatAndStyle: self actualContents allowBackgroundStyleProcess: true. - self basicActualContents: anSHTextStyler formattedText ]]! ! -!PluggableTextModel methodsFor: 'shout styling' stamp: 'jmv 8/26/2017 19:21:51'! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text. - Set the classOrMetaClass in anSHTextStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - ^textProvider shouldStyle: text with: anSHTextStyler! ! -!Workspace methodsFor: 'shout styling' stamp: 'jmv 8/26/2017 19:21:53'! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text." - - self shouldStyle ifFalse: [ ^false ]. - anSHTextStyler - classOrMetaClass: nil; - workspace: self. - ^true! ! -!CodeProvider methodsFor: 'shout styling' stamp: 'jmv 8/26/2017 19:21:32'! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text. - Answer false if showing difs, to veto the styling." - - ^self showingAnyKindOfDiffs not! ! -!Browser methodsFor: 'shout styling' stamp: 'jmv 8/26/2017 19:21:20'! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text. - Set the classOrMetaClass in anSHTextStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - | type | - - self isModeStyleable ifFalse: [^false]. - type _ self editSelection. - (#(newMessage editMessage editClass newClass) includes: type) ifFalse:[^false]. - anSHTextStyler classOrMetaClass: (type = #editClass ifFalse:[self selectedClassOrMetaClass]). - ^true! ! -!MessageSet methodsFor: 'shout styling' stamp: 'jmv 8/26/2017 19:21:44'! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text. - Set the classOrMetaClass in anSHTextStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - - self isModeStyleable ifFalse: [^false]. - anSHTextStyler classOrMetaClass: self selectedClassOrMetaClass. - ^true! ! -!CodeFileBrowser methodsFor: 'shout styling' stamp: 'jmv 8/26/2017 19:21:30'! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text. - Set the classOrMetaClass in anSHTextStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - - self isModeStyleable ifFalse: [^false]. - anSHTextStyler classOrMetaClass: self selectedClassOrMetaClass. - ^true! ! -!ChangeList methodsFor: 'shout styling' stamp: 'jmv 8/26/2017 19:21:23'! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text. - Set the classOrMetaClass in anSHTextStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - - self isModeStyleable ifFalse: [^false]. - listIndex = 0 ifFalse: [ - (changeList at: listIndex) changeType = #method ifTrue: [ - self selectedClassOrMetaClass ifNotNil: [ :cl | - anSHTextStyler classOrMetaClass: cl. - ^true ]]]. - ^false! ! -!ChangeSorter methodsFor: 'shout styling' stamp: 'jmv 8/26/2017 19:21:27'! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text. - Set the classOrMetaClass in anSHTextStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - - self isModeStyleable ifFalse: [^false]. - self currentSelector ifNil: [^false]. - anSHTextStyler classOrMetaClass: self selectedClassOrMetaClass. - ^true! ! -!Debugger methodsFor: 'shout styling' stamp: 'jmv 8/26/2017 19:21:36'! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text. - Set the classOrMetaClass in anSHTextStyler, so that identifiers - will be resolved correctly. - Answer true to allow styling to proceed, or false to veto the styling" - - self isModeStyleable ifFalse: [^false]. - anSHTextStyler - classOrMetaClass: self selectedClassOrMetaClass; - disableFormatAndConvert; - workspace: self. - ^true! ! -!Inspector methodsFor: 'shout styling' stamp: 'jmv 8/26/2017 19:42:36'! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text. - Answer true to allow styling to proceed, or false to veto the styling" - - anSHTextStyler workspace: self. - ^(text = self acceptedContents) not! ! -!ObjectExplorer methodsFor: 'shout styling' stamp: 'jmv 8/26/2017 19:27:12'! - shouldStyle: text with: anSHTextStyler - "This is a notification that anSHTextStyler is about to re-style its text. - Answer true to allow styling to proceed, or false to veto the styling" - - anSHTextStyler workspace: self. - ^true! ! -!Inspector methodsFor: 'contents' stamp: 'jmv 8/26/2017 19:40:39' prior: 16857103! - acceptedStringOrText - "We need our cache not to be modified by user editions" - ^acceptedContentsCache copy! ! -!InnerTextMorph methodsFor: 'editing' stamp: 'jmv 8/26/2017 19:07:20' prior: 16855670! - hasUnacceptedEdits: aBoolean - "Set the hasUnacceptedEdits flag to the given value. " - aBoolean == hasUnacceptedEdits ifFalse: [ - hasUnacceptedEdits _ aBoolean. - owner redrawNeeded]. - aBoolean ifFalse: [ hasEditingConflicts _ false]. - - "shout: re-style the text iff aBoolean is true - Do not apply any formatting (i.e. changes to the characters in the text), - just styling (i.e. TextAttributes)" - aBoolean ifTrue: [ - self formatAndStyleIfNeeded ]! ! -!InnerTextMorph methodsFor: 'shout' stamp: 'jmv 8/26/2017 19:14:13' prior: 16856199! - formatAndStyleIfNeeded - "Apply both formatting (changes to the characters in the text, such as - preferred assignment operators), and styling (TextAttributes to make - Smalltalk code easier to understand)" - - model formatAndStyleIfNeededWith: styler! ! - -InnerTextMorph removeSelector: #okToStyle! - -InnerTextMorph removeSelector: #okToStyle! - -ObjectExplorer removeSelector: #shoutAboutToStyle:! - -ObjectExplorer removeSelector: #shoutAboutToStyle:! - -Inspector removeSelector: #shoutAboutToStyle:! - -Inspector removeSelector: #shoutAboutToStyle:! - -Debugger removeSelector: #shoutAboutToStyle:! - -Debugger removeSelector: #shoutAboutToStyle:! - -ChangeSorter removeSelector: #shoutAboutToStyle:! - -ChangeSorter removeSelector: #shoutAboutToStyle:! - -ChangeList removeSelector: #shoutAboutToStyle:! - -ChangeList removeSelector: #shoutAboutToStyle:! - -CodeFileBrowser removeSelector: #shoutAboutToStyle:! - -CodeFileBrowser removeSelector: #shoutAboutToStyle:! - -MessageSet removeSelector: #shoutAboutToStyle:! - -MessageSet removeSelector: #shoutAboutToStyle:! - -Browser removeSelector: #shoutAboutToStyle:! - -Browser removeSelector: #shoutAboutToStyle:! - -CodeProvider removeSelector: #shoutAboutToStyle:! - -CodeProvider removeSelector: #shoutAboutToStyle:! - -Workspace removeSelector: #shoutAboutToStyle:! - -Workspace removeSelector: #shoutAboutToStyle:! - -PluggableTextModel removeSelector: #shoutAboutToStyle:! - -PluggableTextModel removeSelector: #shoutAboutToStyle:! - -TextModel removeSelector: #formatAndStyleWith:! - -TextModel removeSelector: #formatAndStyleWith:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3160-AvoidStylingInIspectorUntilEdit-JuanVuletich-2017Aug26-19h42m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3160] on 28 August 2017 at 9:40:53 pm'! - -ActiveModel subclass: #SimpleServiceEntry - instanceVariableNames: 'provider label selector useLineAfter stateSelector description argumentGetter buttonLabel argumentProvider triggerFileListChanged sortOrder ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-FileList'! - -!classDefinition: #SimpleServiceEntry category: #'Tools-FileList'! -ActiveModel subclass: #SimpleServiceEntry - instanceVariableNames: 'provider label selector useLineAfter stateSelector description argumentGetter buttonLabel argumentProvider triggerFileListChanged sortOrder' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-FileList'! -!SimpleServiceEntry methodsFor: 'accessing' stamp: 'jmv 8/28/2017 21:35:11'! - sortOrder - ^sortOrder! ! -!SimpleServiceEntry methodsFor: 'accessing' stamp: 'jmv 8/28/2017 21:28:07'! - sortOrder: aNumber - sortOrder _ aNumber! ! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'jmv 8/28/2017 21:40:08' prior: 16809512! - serviceBrowseCode - "Answer the service of opening a file-contents browser" - - ^ (SimpleServiceEntry - provider: self - label: 'code file browser' - selector: #browseCode: - description: 'open a "file-contents browser" on this file, allowing you to view and selectively load its code' - buttonLabel: 'code') - sortOrder: 10; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!CodeFileBrowser class methodsFor: 'instance creation' stamp: 'jmv 8/28/2017 21:40:05' prior: 16809527! - serviceBrowsePackage - "Answer the service of opening a file-contents browser" - - ^ (SimpleServiceEntry - provider: self - label: 'package file browser' - selector: #browsePackage: - description: 'open a "package file browser" on this file, allowing you to view and selectively load its code' - buttonLabel: 'package browser') - sortOrder: 10; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!ChangeList class methodsFor: 'fileIn/Out' stamp: 'jmv 8/28/2017 21:39:59' prior: 16796992! - serviceContents - "Answer a service for opening a changelist browser on a file" - - ^ (SimpleServiceEntry - provider: self - label: 'code file contents' - selector: #browseContents: - description: 'open a code file contents tool on this file' - buttonLabel: 'contents') - sortOrder: 20; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!ChangeList class methodsFor: 'fileIn/Out' stamp: 'jmv 8/28/2017 21:39:55' prior: 16797005! - servicePackageContents - "Answer a service for opening a changelist browser on a file" - - ^ (SimpleServiceEntry - provider: self - label: 'package file contents' - selector: #browsePackageContents: - description: 'open a code file contents tool on this package file' - buttonLabel: 'pck contents') - sortOrder: 20; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!FileList class methodsFor: 'file reader registration' stamp: 'jmv 8/28/2017 21:39:36' prior: 50368443! - itemsForFile: filename - "Answer a list of services appropriate for a file of the given name" - | services suffix classList | - suffix _ (FileIOAccessor default extensionFor: filename) asLowercase. - "Build the list dynamically for all implementers of the appropriate class method... registration no longer required" - classList _ (Smalltalk allClassesImplementing: #fileReaderServicesForFile:suffix:) - collect: [ :item | - item class == Metaclass ifTrue: [ item soleInstance ]] - thenSelect: [ :item | - item notNil ]. - services _ OrderedCollection new. - classList do: [ :reader | - services addAll: - (reader - fileReaderServicesForFile: filename - suffix: suffix) ]. - services sort: [ :a :b | a sortOrder < b sortOrder ]. - ^ services.! ! -!ChangeSet class methodsFor: 'file list services' stamp: 'jmv 8/28/2017 21:28:59' prior: 16799248! - serviceFileIn - "Answer a service for filing in an entire file" - - ^ (SimpleServiceEntry - provider: self - label: 'fileIn entire file' - selector: #fileIn: - description: 'file in the entire contents of the file, which is expected to contain Smalltalk code in fileout ("chunk") format' - buttonLabel: 'filein') - sortOrder: 100; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!ChangeSet class methodsFor: 'file list services' stamp: 'jmv 8/28/2017 21:29:05' prior: 16799263! - serviceInstall - "Answer a service for filing in an entire file" - - ^ (SimpleServiceEntry - provider: self - label: 'install code' - selector: #install: - description: 'install change set' - buttonLabel: 'install') - sortOrder: 100; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!CodePackageFile class methodsFor: 'file list services' stamp: 'jmv 8/28/2017 21:29:39' prior: 16811207! - serviceInstallPackage - "Answer the service of installing a CodePackageFile (a chunk format file for a CodePackage)" - - ^ (SimpleServiceEntry - provider: self - label: 'install package' - selector: #installPackageStream: - description: 'install the package, replacing all existing code in the package (if any); create a new change set just for the installation' - buttonLabel: 'install package') - sortOrder: 100; - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! - -ActiveModel subclass: #SimpleServiceEntry - instanceVariableNames: 'provider label selector useLineAfter stateSelector description argumentGetter buttonLabel argumentProvider triggerFileListChanged sortOrder' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-FileList'! - -!classDefinition: #SimpleServiceEntry category: #'Tools-FileList'! -ActiveModel subclass: #SimpleServiceEntry - instanceVariableNames: 'provider label selector useLineAfter stateSelector description argumentGetter buttonLabel argumentProvider triggerFileListChanged sortOrder' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-FileList'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3161-RestoreFileListButtonsOrder-JuanVuletich-2017Aug28-21h38m-jmv.1.cs.st----! - -----SNAPSHOT----#(28 August 2017 9:43:40.036554 pm) Cuis5.0-3161.image priorSource: 1165736! - -----QUIT----#(28 August 2017 9:43:51.101075 pm) Cuis5.0-3161.image priorSource: 1201771! - -----STARTUP----#(6 September 2017 8:11:07.510878 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3161.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3161] on 29 August 2017 at 3:54:37 pm'! -!Theme methodsFor: 'keyboard shortcuts' stamp: 'jmv 8/29/2017 15:53:47' prior: 16936827! - keyStroke: aKeyboardEvent morph: aMorph - aKeyboardEvent controlKeyPressed ifTrue: [^false]. - aKeyboardEvent commandAltKeyPressed ifFalse: [^false]. - - aKeyboardEvent keyValue = $w numericValue ifTrue: [ - aMorph owningWindow ifNotNil: [ :w | - (w morphContainsPoint: (w internalizeFromWorld: aKeyboardEvent eventPosition)) ifTrue: [ - w delete. - ^true ] ]]. -" aKeyboardEvent keyValue = $f numericValue - ifTrue: [aMorph owningWindow ifNotNil: [ :w | w fullScreen. ^true ]]. -" - ^ false! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3162-OnlyCloseWindowIfContainsMousePointer-JuanVuletich-2017Aug29-15h49m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3121] on 9 July 2017 at 7:49:17 pm'! -!Interval class methodsFor: 'instance creation' stamp: 'jmv 7/9/2017 16:59:23' prior: 16861363! - 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). - (newInterval hasEqualElements: aCollection) - ifFalse: [ 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 -"! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3163-IntervalFix-JuanVuletich-2017Jul09-16h58m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3163] on 31 August 2017 at 10:20:55 am'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3164-CategorizePinningProtocol-JuanVuletich-2017Aug31-10h17m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3164] on 6 September 2017 at 9:59:44 am'! -!SimpleServiceEntry methodsFor: 'initialization' stamp: 'jmv 9/6/2017 09:56:01' prior: 16908010! -initialize - triggerFileListChanged _ false. - sortOrder _ 1! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3165-FileListFix-JuanVuletich-2017Sep06-09h43m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3165] on 6 September 2017 at 10:08:50 am'! -!ReparseAfterSourceEditing commentStamp: 'jmv 9/6/2017 10:05:54' prior: 16900979! - A ReparseAfterSourceEditing is a Notification used to restart the syntax parsing phase of a compilation after a change in source code.! -!TextModelMorph methodsFor: 'accessing' stamp: 'jmv 9/6/2017 10:01:18'! - disableEditing - self textMorph disableEditing! ! -!TextModelMorph methodsFor: 'accessing' stamp: 'jmv 9/6/2017 10:03:26'! - enableEditing - - self textMorph enableEditing! ! -!BrowserWindow methodsFor: 'updating' stamp: 'jmv 9/6/2017 10:04:36'! - disableCodePaneEditing - - codePane ifNotNil: [ codePane disableEditing ]! ! -!BrowserWindow methodsFor: 'updating' stamp: 'jmv 9/6/2017 10:04:48'! - enableCodePaneEditing - - codePane ifNotNil: [ codePane enableEditing ]! ! -!InnerTextMorph methodsFor: 'accessing' stamp: 'jmv 9/6/2017 10:01:59'! - disableEditing - self setProperty: #disablesEditing toValue: true. - self stopBlinking! ! -!InnerTextMorph methodsFor: 'accessing' stamp: 'jmv 9/6/2017 10:03:03'! -enableEditing - - self removeProperty: #disablesEditing! ! -!InnerTextMorph methodsFor: 'event handling testing' stamp: 'jmv 9/6/2017 10:02:01'! - disablesEditing - - ^self hasProperty: #disablesEditing! ! -!Inspector methodsFor: 'contents' stamp: 'jmv 9/6/2017 10:05:31' prior: 50368934! - acceptedStringOrText - "We need our cache not to be modified by user changes" - ^acceptedContentsCache copy! ! -!TextEditor methodsFor: 'accessing' stamp: 'jmv 9/6/2017 10:02:22' prior: 16931330! - replaceSelectionWith: aTextOrString - "Deselect, and replace the selection text by aText." - "This is a user command, and generates undo" - - | start stop replacement | - - morph disablesEditing ifTrue: [ - ^ self ]. - - start _ self startIndex. - stop _ self stopIndex. - (aTextOrString isEmpty and: [stop > start]) ifTrue: [ - "If deleting, then set emphasisHere from 1st character of the deletion" - emphasisHere _ (model actualContents attributesAt: start) select: [:att | - att mayBeExtended]]. - - (start = stop and: [ aTextOrString isEmpty ]) ifFalse: [ - replacement _ self addAttributesForPasting: aTextOrString. - model logUndoAndReplaceFrom: start to: stop - 1 with: replacement. - textComposition - recomposeFrom: start - to: start + replacement size - 1 - delta: replacement size - (stop-start). - self deselectAndPlaceCursorAt: start + replacement size. - selectionStartBlocks _ #(). - selectionStopBlocks _ #(). - self userHasEdited " -- note text now dirty" ]. - - morph possiblyChanged! ! -!TextEditor methodsFor: 'private' stamp: 'jmv 9/6/2017 10:02:19' prior: 16932614! - applyAttribute: aTextAttribute - "The user selected aTextAttribute via shortcut, menu or other means. - If there is a selection, apply the attribute to the selection. - In any case use the attribute for the user input (emphasisHere)" - "This generates undo" - | anythingDone | - - morph disablesEditing ifTrue: [ - ^ self ]. - - anythingDone _ false. - emphasisHere _ Text addAttribute: aTextAttribute toArray: emphasisHere. - self selectionIntervalsDo: [ :interval | - (interval notEmpty or: [ aTextAttribute isParagraphAttribute ]) - ifTrue: [ - anythingDone _ true. - model logUndoAndAddAttribute: aTextAttribute from: interval first to: interval last. - textComposition recomposeFrom: interval first to: interval last delta: 0 ]]. - anythingDone ifTrue: [ - self recomputeSelection. "Needed so visible selection is updated to reflect new visual extent of selection" - self userHasEdited ]. - - "Even if nothing done, emphasisHere might have changed" - morph possiblyChanged! ! -!TextEditor methodsFor: 'undo & redo' stamp: 'jmv 9/6/2017 10:02:20' prior: 16933011! - redo - - morph disablesEditing ifTrue: [ - ^ self ]. - - model redoAndEvaluate: [ :modelUpdated :newCursorPos | - newCursorPos - ifNil: [ self recomputeSelection ] - ifNotNil: [ self markIndex: newCursorPos pointIndex: newCursorPos ]. - modelUpdated ifTrue: [ - self userHasEdited. - textComposition composeAll. "this could be made more specific..." - morph possiblyChanged ]]! ! -!TextEditor methodsFor: 'undo & redo' stamp: 'jmv 9/6/2017 10:02:24' prior: 16933031! - undo - - morph disablesEditing ifTrue: [ - ^ self ]. - - model undoAndEvaluate: [ :modelUpdated :newCursorPos | - newCursorPos - ifNil: [ self recomputeSelection ] - ifNotNil: [ self markIndex: newCursorPos pointIndex: newCursorPos ]. - modelUpdated ifTrue: [ - self userHasEdited. - textComposition composeAll. "this could be made more specific..." - morph possiblyChanged ]]! ! -!BrowserWindow methodsFor: 'updating' stamp: 'jmv 9/6/2017 10:04:55' prior: 50368594! - editSelectionChanged - - self isEditSelectionNone - ifTrue: [ self disableCodePaneEditing ] - ifFalse: [ self enableCodePaneEditing]! ! -!InnerTextMorph methodsFor: 'blinking cursor' stamp: 'jmv 9/6/2017 10:02:07' prior: 16856157! - showsBlinkingCursor - - ^self handlesKeyboard and: [ self disablesEditing not ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3166-ItIsEditingNotEdition-JuanVuletich-2017Sep06-10h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3165] on 6 September 2017 at 10:09:36 am'! - -InnerTextMorph removeSelector: #disableEdition! - -InnerTextMorph removeSelector: #disableEdition! - -InnerTextMorph removeSelector: #disablesEdition! - -InnerTextMorph removeSelector: #disablesEdition! - -InnerTextMorph removeSelector: #enableEdition! - -InnerTextMorph removeSelector: #enableEdition! - -BrowserWindow removeSelector: #disableCodePaneEdition! - -BrowserWindow removeSelector: #disableCodePaneEdition! - -BrowserWindow removeSelector: #enableCodePaneEdition! - -BrowserWindow removeSelector: #enableCodePaneEdition! - -TextModelMorph removeSelector: #disableEdition! - -TextModelMorph removeSelector: #disableEdition! - -TextModelMorph removeSelector: #enableEdition! - -TextModelMorph removeSelector: #enableEdition! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3167-EditionMisnomerCleanup-JuanVuletich-2017Sep06-10h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3162] on 4 September 2017 at 5:01:33 pm'! - -ChangeList subclass: #ChangeListWithFileInErrors - instanceVariableNames: 'errors' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #ChangeListWithFileInErrors category: #'Tools-Changes'! -ChangeList subclass: #ChangeListWithFileInErrors - instanceVariableNames: 'errors' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! -!ChangeListWithFileInErrors commentStamp: 'HAW 9/4/2017 10:23:05' prior: 0! - This class is used to keep errors when filing in changes. -I could have use ChangeList directly, selecting changes with errors, then removing them, etc., but it had some problems and that solution is more a hack. -So, instances of this class will keep errors when filing in a change, and it allows the posibility to show the change with the error in a change list window. - -A doit change that signaled a MessageNotUnderstood is assume to not be an error becuase those kinds of things are evaluations in specific contexts that will obiously generate errors. -All doits with errors could be assume not to be errors, but I limited to MNU type of errors to avoid filtering errors that should be shown.! -!ChangeListWithFileInErrors methodsFor: 'filing in' stamp: 'HAW 9/4/2017 09:34:35'! - fileInAllKeepingErrors - - errors := Dictionary new. - changeList do: [ :change | self fileInKeepingError: change ]. -! ! -!ChangeListWithFileInErrors methodsFor: 'filing in' stamp: 'HAW 9/4/2017 16:36:13'! - fileInKeepingError: change - - [ change fileIn ] - on: Error - do: [ :anError | (self hasToKeep: anError for: change) ifTrue: [ errors at: change put: anError ]]! ! -!ChangeListWithFileInErrors methodsFor: 'initialization-release' stamp: 'HAW 9/4/2017 09:34:20'! - initialize - - super initialize. - errors := Dictionary new.! ! -!ChangeListWithFileInErrors methodsFor: 'testing' stamp: 'HAW 9/4/2017 09:37:00'! - hasFileInErrors - - ^errors notEmpty! ! -!ChangeListWithFileInErrors methodsFor: 'testing' stamp: 'HAW 9/4/2017 16:37:07'! - hasToKeep: anError for: change - - ^(change isDoIt and: [ anError isKindOf: MessageNotUnderstood ]) not! ! -!ChangeListWithFileInErrors methodsFor: 'showing filein errors' stamp: 'HAW 9/4/2017 10:01:06'! - failedFileInChangesLabel - - ^'Changes that failed to file in'! ! -!ChangeListWithFileInErrors methodsFor: 'showing filein errors' stamp: 'HAW 9/4/2017 10:45:43'! -ifFiledInWithErrorAdd: aChange at: anIndex to: newChangeList and: newList - - (self wasFiledInWithError: aChange) ifTrue: [ - newChangeList add: aChange. - newList add: ((list at: anIndex) contractTo: 40), ' | ', (errors at: aChange) printString ]! ! -!ChangeListWithFileInErrors methodsFor: 'showing filein errors' stamp: 'HAW 9/4/2017 10:04:47'! - removeSucessfullyFiledInChanges - - | newChangeList newList | - - newChangeList := OrderedCollection new. - newList := OrderedCollection new. - - changeList withIndexDo: [ :aChange :anIndex | self ifFiledInWithErrorAdd: aChange at: anIndex to: newChangeList and: newList ]. - - changeList _ newChangeList. - list _ newList. - listIndex _ 0. - self clearSelections. - self changed: #list.! ! -!ChangeListWithFileInErrors methodsFor: 'showing filein errors' stamp: 'HAW 9/4/2017 10:02:20'! - showChangesWithFileInErrors - - self removeSucessfullyFiledInChanges. - ChangeListWindow open: self label: self failedFileInChangesLabel - -! ! -!ChangeListWithFileInErrors methodsFor: 'showing filein errors' stamp: 'HAW 9/4/2017 10:46:01'! - wasFiledInWithError: aChange - - ^errors includesKey: aChange! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:48:40'! - logSnapshot: save andQuit: quit - "Log quitting to changes file" - | msg | - (SourceFiles at: 2) ifNotNil: [ - msg _ self snapshotMessageFor: save andQuit: quit. - self assureStartupStampLogged. - save ifTrue: [ - LastQuitLogPosition _ (SourceFiles at: 2) - setToEnd; - position ]. - self logChange: msg. - Transcript - newLine; - show: msg; - newLine ]! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:42:57'! - nopTag - - ^ 'NOP'! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:42:27'! - quitNoSaveTag - - ^ 'QUIT/NOSAVE' ! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:40:45'! - quitTag - - ^'QUIT'! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:51:51'! - snapshotMessageFor: save andQuit: quit - - ^String streamContents: [ :stream | - stream - nextPutAll: self tagHeader; - nextPutAll: (self snapshotTagFor: save andQuit: quit); - nextPutAll: self tagTail; - print: Date dateAndTimeNow; - space; - nextPutAll: self imageName asFileEntry name; - nextPutAll: ' priorSource: '; - print: LastQuitLogPosition ].! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:41:19'! - snapshotTag - - ^'SNAPSHOT'! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:51:20'! - snapshotTagFor: save andQuit: quit - - ^save - ifTrue: [ quit - ifTrue: [ self quitTag ] - ifFalse: [ self snapshotTag ]] - ifFalse: [ quit - ifTrue: [ self quitNoSaveTag ] - ifFalse: [ self nopTag ]]! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:45:54'! - tagHeader - - ^ '----'! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:46:02'! - tagTail - - ^ self tagHeader! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:11:51'! - hasToRestoreChanges - - ^self withChangesFileDo: [ :changesFile | - changesFile position: self lastQuitLogPosition. - self hasToRestoreChangesFrom: changesFile ]. - ! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 16:41:24'! - hasToRestoreChangesFrom: changesFile - - | chunk | - - [ changesFile atEnd ] whileFalse: [ chunk := changesFile nextChunk ]. - - ^(self isSnapshotQuitOrQuitNoSaveRecord: chunk) not -! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 08:56:02'! - isQuitNoSaveRecord: chunk - - ^chunk beginsWith: self tagHeader, self quitNoSaveTag - ! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 08:55:51'! - isQuitRecord: chunk - - ^chunk beginsWith: self tagHeader, self quitTag ! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 16:34:34'! - isSnapshotQuitOrQuitNoSaveRecord: chunk - - ^(self isSnapshotRecord: chunk) - or: [ (self isQuitRecord: chunk) - or: [ self isQuitNoSaveRecord: chunk ]]! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 08:57:09'! - isSnapshotRecord: chunk - - ^chunk beginsWith: self tagHeader, self snapshotTag - ! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 09:07:35'! - lostChangesDetectedCaption - - ^ -'Last changes may have been lost -(maybe the VM crashed or you had to kill it) -What do you want to do?'! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:25:45'! - restoreLostChanges - - | decision | - - decision := PopUpMenu withCaption: self lostChangesDetectedCaption chooseFrom: self restoreLostChangesOptions. - - decision = 1 ifTrue: [ ^self restoreLostChangesAutomatically ]. - decision = 2 ifTrue: [ ^self restoreLostChangesManually ]! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:13:01'! - restoreLostChangesAutomatically - - self withChangesFileDo: [ :aChangesFile | self restoreLostChangesAutomaticallyFrom: aChangesFile ]! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 10:15:16'! - restoreLostChangesAutomaticallyFrom: aChangesFile - - | changeList | - - changeList := ChangeListWithFileInErrors new. - changeList scanFile: aChangesFile from: LastQuitLogPosition to: aChangesFile size. - changeList fileInAllKeepingErrors. - (changeList hasFileInErrors and: [ self shouldShowFileInErrors ]) ifTrue: [ changeList showChangesWithFileInErrors ] -! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:09:39'! - restoreLostChangesIfNecessary - - " - Smalltalk restoreLostChangesIfNecessary - " - - self hasToRestoreChanges ifTrue: [ WorldState addDeferredUIMessage: [self restoreLostChanges ]]. -! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/1/2017 17:28:22'! - restoreLostChangesManually - - ChangeList browseRecentLog! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:25:55'! - restoreLostChangesOptions - - ^{'Restore lost changes automatically'. 'Restore lost changes manually'. 'Nothing'}.! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:29:46'! - restoringChangesHasErrorsCaption - - ^'There were errors filing in the lost changes. Do you want to see them?'! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 09:37:34'! - shouldShowFileInErrors - - ^self confirm: self restoringChangesHasErrorsCaption - ! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:11:39'! - withChangesFileDo: aBlock - - ^self currentChangesName asFileEntry readStreamDo: aBlock! ! -!ChangeRecord methodsFor: 'testing' stamp: 'HAW 9/4/2017 06:32:29'! - isDoIt - - ^type = #doIt! ! -!ChangeList methodsFor: 'menu actions' stamp: 'HAW 9/4/2017 10:26:32' prior: 16796254! - removeDoIts - "Remove doits from the receiver, other than initializes. 1/26/96 sw" - - | newChangeList newList | - newChangeList _ OrderedCollection new. - newList _ OrderedCollection new. - - changeList with: list do: [ :chRec :str | - (chRec isDoIt not or: [str endsWith: 'initialize']) - ifTrue: [ - newChangeList add: chRec. - newList add: str]]. - newChangeList size < changeList size - ifTrue: [ - changeList _ newChangeList. - list _ newList. - listIndex _ 0. - self clearSelections ]. - self changed: #list. - - ! ! -!ChangeList methodsFor: 'menu actions' stamp: 'HAW 9/4/2017 10:26:50' prior: 16796515! - selectRemovalsOfSent - "Selects all method removal for sent methods" - - 1 to: changeList size do: [ :i | | change | - change _ changeList at: i. - listSelections at: i put: - (change isDoIt and: [ - change string includesSubString: 'removeSelector: #' ] and: [ - Smalltalk isThereAReferenceTo: (change string copyAfterLast: $#) asSymbol ]) ]. - self changed: #allSelections. - self changed: #annotation! ! -!ChangeList class methodsFor: 'public access' stamp: 'HAW 9/4/2017 10:32:00' prior: 16796892! - browseRecentLogOn: origChangesFileName - "figure out where the last snapshot or quit was, then browse the recent entries." - - | end done block positions prevBlock | - origChangesFileName asFileEntry readStreamDo: [ :changesFile | - positions _ SortedCollection new. - end _ changesFile size. - prevBlock _ end. - block _ end - 1024 max: 0. - done _ false. - [ done or: [ positions size > 0 ]] - whileFalse: [ - changesFile position: block. - "ignore first fragment" - changesFile nextChunk. - [ changesFile position < prevBlock ] - whileTrue: [ - | pos chunk | - pos _ changesFile position. - chunk _ changesFile nextChunk. - ((Smalltalk isQuitRecord: chunk) or: [ Smalltalk isSnapshotRecord: chunk ]) - ifTrue: [ positions add: pos ]]. - block = 0 - ifTrue: [done _ true] - ifFalse: [ - prevBlock _ block. - block _ block - 1024 max: 0]]. - ]. - positions isEmpty - ifTrue: [self inform: 'File ' , origChangesFileName , ' does not appear to be a changes file'] - ifFalse: [self browseRecentLogOn: origChangesFileName startingFrom: positions last]! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:46:37' prior: 50361384! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag -"WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " -| activeProc | -activeProc _ Processor activeProcess. -[ - | isARealStartup world reopenTranscript | - self logSnapshot: save andQuit: quit. - - reopenTranscript _ false. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | each isInWorld ifTrue: [ each delete. reopenTranscript _ true ]]. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - - - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - - "Cosas que levanto explicitamente abajo" - world _ ProjectX ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "world _ clearAllStateFlag ifFalse: [ ProjectX ui ]." - ProjectX stopUIProcess. - activeProc isTerminated ifFalse: [ - activeProc terminate ]. - - "Clean Globals" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: nil. - Smalltalk closeSourceFiles. Smalltalk at: #SourceFiles put: nil. - Smalltalk allClassesDo: [ :cls | cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ Smalltalk printStuffToCleanOnImageSave ]. - - - "Do image save & quit as apropriate" - Cursor write activateCursor. - save - ifTrue: [ - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - - - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: (DisplayScreen extent: `1024@768` depth: 32). - Smalltalk at: #SourceFiles put: (Array new: 2). - Smalltalk openSourceFiles. - - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - - - ProjectX spawnNewMorphicProcessFor: (world ifNil: [ PasteUpMorph newWorld ]). - - reopenTranscript ifTrue: [ - WorldState addDeferredUIMessage: [ - TranscriptWindow openTranscript ]]. - " - WorldState addDeferredUIMessage: [ - world fullRepaintNeeded ]. - " - - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - WorldState addDeferredUIMessage: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]. - -] forkAt: Processor timingPriority-1 named: 'Startup process'.! ! -!SystemDictionary methodsFor: 'startup' stamp: 'HAW 9/4/2017 06:14:44' prior: 50335335! - doStartUp: isARealStartup - " - isARealStartup - true: system is coming up (VM and image just started) - false: we have just saved an image snapshot, but didn't quit. - " - - "Here, startup begins!!" - Cursor normal activateCursor. - self setGCParameters. - isARealStartup ifTrue: [ - self clearExternalObjects ]. - self readCommandLineArguments. - self processStartUpList: isARealStartup. - isARealStartup ifTrue: [ - self setPlatformPreferences. - self setStartupStamp. - self restoreLostChangesIfNecessary ]! ! -!ChangeRecord methodsFor: 'initialization' stamp: 'HAW 9/4/2017 10:27:15' prior: 16797438! - fileIn - "File the receiver in. If I represent a method or a class-comment, file the method in and make a note of it in the recent-submissions list; if I represent a do-it, then, well, do it." - | s | - type == #method ifTrue: [ - self changeClass ifNotNil: [ :methodClass | - methodClass - compile: self text - classified: category - withStamp: stamp - notifying: nil ]]. - self isDoIt ifTrue: [ - ((s _ self string) beginsWith: '----') ifFalse: [ Compiler evaluate: s ]]. - type == #classDefinition ifTrue: [ Compiler evaluate: self string ]. - type == #classComment ifTrue: [ - (Smalltalk at: class asSymbol) - comment: self text - stamp: stamp ]! ! - -SystemDictionary removeSelector: #logSapshot:andQuit:! - -SystemDictionary removeSelector: #logSapshot:andQuit:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3168-AidInRecoveringChanges-HernanWilkinson-2017Sep01-13h49m-HAW.1.cs.st----! -!String methodsFor: 'comparing' stamp: 'jmv 9/6/2017 20:12:13'! - toto: aString - "Answer whether the receiver sorts equally as aString. - This means same characters in same order." - - "Any object is equal to itself" - self == aString ifTrue: [ ^ true ]. - - "If argument is not a String or Symbol, maybe it is a Text?" - aString species == String ifFalse: [ - (aString is: #Text) ifTrue: [ ^ self = aString string ]. - ^ false]. - - self size = aString size ifFalse: [ [] value. 3 > 4 ifTrue: [ [true] whileTrue: []]. - ^false ]. - - ^ (self compare: self with: aString collated: CaseSensitiveOrder) = 2! ! -!String methodsFor: 'comparing' stamp: 'jmv 9/6/2017 20:12:30' prior: 50370036! - toto: aString - "Answer whether the receiver sorts equally as aString. - This means same characters in same order." - - "Any object is equal to itself" - self == aString ifTrue: [ ^ true ]. - - "If argument is not a String or Symbol, maybe it is a Text?" - aString species == String ifFalse: [ - (aString is: #Text) ifTrue: [ ^ self = aString string ]. - ^ false]. - - self size = aString size ifFalse: [ [ ] value. 3 > 4 ifTrue: [ [true] whileTrue: []]. - ^false ]. - - ^ (self compare: self with: aString collated: CaseSensitiveOrder) = 2! ! -!String methodsFor: 'comparing' stamp: 'jmv 9/6/2017 20:14:48' prior: 50370056! - toto: aString - "Answer whether the receiver sorts equally as aString. - This means same characters in same order." - - "Any object is equal to itself" - self == aString ifTrue: [ ^ true ]. - - "If argument is not a String or Symbol, maybe it is a Text?" - aString species == String ifFalse: [ - (aString is: #Text) ifTrue: [ ^ self = aString string ]. - ^ false]. - - self size = aString size ifFalse: [ [ ] value. 3 > 4 ifTrue: [ [true] whileTrue: [ - 1 = 2 ifFalse: [ - 3=3 ifTrue: [] - ] - ]]. - ^false ]. - - ^ (self compare: self with: aString collated: CaseSensitiveOrder) = 2! ! -!SHTextStylerST80 methodsFor: 'private' stamp: 'jmv 9/6/2017 20:19:21' prior: 16903322! - replaceStringForRangesWithType: aSymbol with: aString - "Answer aText if no replacements, or a copy of aText with - each range with a type of aSymbol replaced by aString" - | toReplace increaseInLength | - - "We don't handle format and conversion for debuggers" - disableFormatAndConvert ifTrue: [ ^self ]. -ZZZ ifNil: [ ZZZ _ true . (self rangesSetWorkspace: false) inspect ]. - toReplace := (self rangesSetWorkspace: false) - select: [:each | each rangeType = aSymbol]. - toReplace isEmpty ifTrue: [^self]. - increaseInLength := 0. - - (toReplace asArray sort: [:a :b | a start <= b start]) - do: [:each | | end start thisIncrease | - start := each start + increaseInLength. - end := each end + increaseInLength. - formattedText replaceFrom: start to: end with: aString. - thisIncrease := aString size - each length. - increaseInLength := increaseInLength + thisIncrease ]! ! -!SHTextStylerST80 methodsFor: 'private' stamp: 'jmv 9/6/2017 20:19:45' prior: 16903299! - privateStyle - | ranges | - - ranges _ self rangesSetWorkspace: true. - -ZZZ ifNil: [ ZZZ _ true . (ranges) inspect ]. - ranges ifNotNil: [ self setAttributesFromRanges: ranges ]! ! -!SHParserST80 methodsFor: 'recording ranges' stamp: 'jmv 9/6/2017 20:21:42' prior: 16902916! - rangeType: aSymbol start: s end: e -{blockDepth. bracketDepth } print. - ^ranges add: (SHRange start: s end: e type: aSymbol)! ! - -Object subclass: #SHRange - instanceVariableNames: 'start end type blockDepth' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -!classDefinition: #SHRange category: #'Tools-Syntax Highlighting'! -Object subclass: #SHRange - instanceVariableNames: 'start end type blockDepth' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! -!SHRange methodsFor: 'accessing' stamp: 'jmv 9/6/2017 20:22:45'! - blockDepth: anInteger - blockDepth := anInteger! ! -!SHParserST80 methodsFor: 'recording ranges' stamp: 'jmv 9/6/2017 20:22:58' prior: 50370138! - rangeType: aSymbol start: s end: e -{blockDepth. bracketDepth } print. - ^ranges add: ((SHRange start: s end: e type: aSymbol) blockDepth: blockDepth)! ! -!SHRange methodsFor: 'accessing' stamp: 'jmv 9/6/2017 20:25:10'! - blockDepth - ^blockDepth! ! -!SHTextStylerST80 methodsFor: 'private' stamp: 'jmv 9/6/2017 20:25:40' prior: 50335097! - setAttributesFromRanges: ranges - - formattedText removeAttributesThat: [ :attribute | attribute isForShout ]. - - "Optimize for mutation speed unless method is really large but with very few distict elements: - Source code that includes just big literals is better served by conventional Text+RunArray" - "Do it only if we are not breaking textModel!! (for instance, StyledTextEditor asks for formatting just sections, not whole #actualContents)." - formattedText == textModel actualContents ifTrue: [ - (formattedText size > 2000 and: [ ranges size < 50 ]) ifFalse: [ - formattedText _ formattedText optimizedForMutationSpeed. - textModel basicActualContents: formattedText ]]. - - ranges do: [ :range | - - "Smalltalk text styling" - (self attributesFor: range rangeType) ifNotNil: [ :attributes | - attributes do: [ :each | - formattedText addAttribute: each from: range start to: range end. - range blockDepth odd ifTrue: [ - ] - ]]. - - "Show as subscripts if appropriate." - classOrMetaClass ifNotNil: [ - classOrMetaClass theNonMetaClass lastUnderscoreMeansSubscript ifTrue: [ - (#( instVar classVar globalVar workspaceVar poolConstant - patternArg methodArg patternTempVar tempVar - blockPatternArg blockArg blockPatternTempVar blockTempVar - incompleteIdentifier undefinedIdentifier) pointsTo: range rangeType ) - ifTrue: [ - formattedText lastIndexOf: $_ startingAt: range end endingAt: range start do: [ :i | - formattedText addAttribute: ShoutTextEmphasis subscript from: i to: range end ] ]]]]! ! -!SHParserST80 methodsFor: 'recording ranges' stamp: 'jmv 9/6/2017 20:25:46' prior: 50370162! - rangeType: aSymbol start: s end: e -"{blockDepth. bracketDepth } print." - ^ranges add: ((SHRange start: s end: e type: aSymbol) blockDepth: blockDepth)! ! -!SHTextStylerST80 methodsFor: 'private' stamp: 'jmv 9/6/2017 20:26:21' prior: 50370173! - setAttributesFromRanges: ranges - - formattedText removeAttributesThat: [ :attribute | attribute isForShout ]. - - "Optimize for mutation speed unless method is really large but with very few distict elements: - Source code that includes just big literals is better served by conventional Text+RunArray" - "Do it only if we are not breaking textModel!! (for instance, StyledTextEditor asks for formatting just sections, not whole #actualContents)." - formattedText == textModel actualContents ifTrue: [ - (formattedText size > 2000 and: [ ranges size < 50 ]) ifFalse: [ - formattedText _ formattedText optimizedForMutationSpeed. - textModel basicActualContents: formattedText ]]. - - ranges do: [ :range | - - "Smalltalk text styling" - (self attributesFor: range rangeType) ifNotNil: [ :attributes | - attributes do: [ :each | - formattedText addAttribute: each from: range start to: range end. - range blockDepth odd ifTrue: [ - formattedText addAttribute: ShoutTextEmphasis struckThrough from: range start to: range end - ] - ]]. - - "Show as subscripts if appropriate." - classOrMetaClass ifNotNil: [ - classOrMetaClass theNonMetaClass lastUnderscoreMeansSubscript ifTrue: [ - (#( instVar classVar globalVar workspaceVar poolConstant - patternArg methodArg patternTempVar tempVar - blockPatternArg blockArg blockPatternTempVar blockTempVar - incompleteIdentifier undefinedIdentifier) pointsTo: range rangeType ) - ifTrue: [ - formattedText lastIndexOf: $_ startingAt: range end endingAt: range start do: [ :i | - formattedText addAttribute: ShoutTextEmphasis subscript from: i to: range end ] ]]]]! ! -!SHTextStylerST80 methodsFor: 'private' stamp: 'jmv 9/6/2017 20:26:38' prior: 50370233! -setAttributesFromRanges: ranges - - formattedText removeAttributesThat: [ :attribute | attribute isForShout ]. - - "Optimize for mutation speed unless method is really large but with very few distict elements: - Source code that includes just big literals is better served by conventional Text+RunArray" - "Do it only if we are not breaking textModel!! (for instance, StyledTextEditor asks for formatting just sections, not whole #actualContents)." - formattedText == textModel actualContents ifTrue: [ - (formattedText size > 2000 and: [ ranges size < 50 ]) ifFalse: [ - formattedText _ formattedText optimizedForMutationSpeed. - textModel basicActualContents: formattedText ]]. - - ranges do: [ :range | - - "Smalltalk text styling" - (self attributesFor: range rangeType) ifNotNil: [ :attributes | - attributes do: [ :each | - formattedText addAttribute: each from: range start to: range end. - range blockDepth odd ifTrue: [ - formattedText addAttribute: ShoutTextEmphasis bold from: range start to: range end - ] - ]]. - - "Show as subscripts if appropriate." - classOrMetaClass ifNotNil: [ - classOrMetaClass theNonMetaClass lastUnderscoreMeansSubscript ifTrue: [ - (#( instVar classVar globalVar workspaceVar poolConstant - patternArg methodArg patternTempVar tempVar - blockPatternArg blockArg blockPatternTempVar blockTempVar - incompleteIdentifier undefinedIdentifier) pointsTo: range rangeType ) - ifTrue: [ - formattedText lastIndexOf: $_ startingAt: range end endingAt: range start do: [ :i | - formattedText addAttribute: ShoutTextEmphasis subscript from: i to: range end ] ]]]]! ! -!SHTextStylerST80 methodsFor: 'private' stamp: 'jmv 9/6/2017 20:26:47' prior: 50370287! - setAttributesFromRanges: ranges - - formattedText removeAttributesThat: [ :attribute | attribute isForShout ]. - - "Optimize for mutation speed unless method is really large but with very few distict elements: - Source code that includes just big literals is better served by conventional Text+RunArray" - "Do it only if we are not breaking textModel!! (for instance, StyledTextEditor asks for formatting just sections, not whole #actualContents)." - formattedText == textModel actualContents ifTrue: [ - (formattedText size > 2000 and: [ ranges size < 50 ]) ifFalse: [ - formattedText _ formattedText optimizedForMutationSpeed. - textModel basicActualContents: formattedText ]]. - - ranges do: [ :range | - - "Smalltalk text styling" - (self attributesFor: range rangeType) ifNotNil: [ :attributes | - attributes do: [ :each | - formattedText addAttribute: each from: range start to: range end. - range blockDepth odd ifTrue: [ - formattedText addAttribute: ShoutTextEmphasis underlined from: range start to: range end - ] - ]]. - - "Show as subscripts if appropriate." - classOrMetaClass ifNotNil: [ - classOrMetaClass theNonMetaClass lastUnderscoreMeansSubscript ifTrue: [ - (#( instVar classVar globalVar workspaceVar poolConstant - patternArg methodArg patternTempVar tempVar - blockPatternArg blockArg blockPatternTempVar blockTempVar - incompleteIdentifier undefinedIdentifier) pointsTo: range rangeType ) - ifTrue: [ - formattedText lastIndexOf: $_ startingAt: range end endingAt: range start do: [ :i | - formattedText addAttribute: ShoutTextEmphasis subscript from: i to: range end ] ]]]]! ! -!Theme methodsFor: 'colors' stamp: 'jmv 9/6/2017 20:31:25' prior: 16935449! - paneBackgroundFrom: aColor - ^ " aColor veryMuchLighter" Color red! ! -!Theme methodsFor: 'colors' stamp: 'jmv 9/6/2017 20:31:35' prior: 50370395! - paneBackgroundFrom: aColor - ^ aColor veryMuchLighter! ! -!MorphicCanvas methodsFor: 'drawing-text' stamp: 'jmv 9/6/2017 20:37:28' prior: 50364365! - textComposition: aTextComposition bounds: boundsRect color: c selectionColor: sc - | displayScanner leftInRun line boundsInWorld tl | - - tl _ boundsRect topLeft. - boundsInWorld _ currentTransformation displayBoundsOfTransformOf: boundsRect. - - displayScanner _ MorphicScanner new - defaultFont: aTextComposition defaultFont; - text: aTextComposition textComposed - foreground: c. - displayScanner canvas: self. - - leftInRun _ 0. - "Take clipRect into account. Extrememly fast scrolls and redraws of huge files (like .sources)" - (aTextComposition lineIndexForPoint: (`0@0` max: (clipLeft@clipTop)- boundsInWorld origin)) - to: (aTextComposition lineIndexForPoint: (boundsInWorld extent min: (clipRight@clipBottom+1) - boundsInWorld origin)) - do: [ :i | - "Como llego hasta aca?" - line _ aTextComposition lines at: i. - aTextComposition - displaySelectionInLine: line - on: self - textTopLeft: tl - selectionColor: sc. - leftInRun _ displayScanner displayLine: line textTopLeft: tl leftInRun: leftInRun ]! ! -!BitBlt methodsFor: 'accessing' stamp: 'jmv 9/6/2017 20:39:52' prior: 16785548! - destX: x destY: y width: w height: h - "Combined init message saves 3 sends from MorphicScanner" - destX _ x. - destY _ y. - width _ w. - height _ h.! ! -!BitBlt methodsFor: 'accessing' stamp: 'jmv 9/6/2017 20:40:02' prior: 50370440! - destX: x destY: y width: w height: h - destX _ x. - destY _ y. - width _ w. - height _ h.! ! -!CharacterScanner methodsFor: 'private' stamp: 'jmv 9/6/2017 20:40:09' prior: 16801989! - textColor: ignored - "Overridden in MorphicScanner"! ! -!MorphicScanner methodsFor: 'private' stamp: 'jmv 9/6/2017 20:40:32' prior: 16878082! - textColor: textColor -"similar para backgroundColor" - foregroundColor _ textColor! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 9/6/2017 20:42:56' prior: 16787001! - drawString: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | p1 font | - "Don't waste any time if NOP" - lastIndex = 0 ifTrue: [ - ^nil ]. -"Aca llegar tambien con un backColor" - p1 _ (currentTransformation transform: aPoint) rounded. - port colorMap: nil. - font _ fontOrNil ifNil: [ AbstractFont default ]. - ^font on: port - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 9/6/2017 20:43:59' prior: 50370465! - drawString: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | p1 font | - "Don't waste any time if NOP" - lastIndex = 0 ifTrue: [ - ^nil ]. -"Aca llegar tambien con un backColor -Lo ideal seria, creo, meter tambien en este framework la seleccion. Es un backColor artificial por un rato -" - p1 _ (currentTransformation transform: aPoint) rounded. - port colorMap: nil. - font _ fontOrNil ifNil: [ AbstractFont default ]. - ^font on: port - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: aColor! ! -!BitBltCanvas methodsFor: 'drawing-text' stamp: 'jmv 9/6/2017 20:46:47' prior: 50370484! - drawString: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: aColor - "Answer last affected pixel position - Answer nil if nothing was done" - - | p1 font | - "Don't waste any time if NOP" - lastIndex = 0 ifTrue: [ - ^nil ]. -"Aca llegar tambien con un backColor -Lo ideal seria, creo, meter tambien en este framework la seleccion. Es un backColor artificial por un rato -de ultima, el backColor mezclarlo o algo asi con la seleccion... ver. -" - p1 _ (currentTransformation transform: aPoint) rounded. - port colorMap: nil. - font _ fontOrNil ifNil: [ AbstractFont default ]. - ^font on: port - displayString: aString - from: firstIndex - to: lastIndex - at: p1 - color: aColor! ! - -----QUIT/NOSAVE----#(6 September 2017 8:47:25.268108 pm) Cuis5.0-3161.image priorSource: 1201865! - -----STARTUP----#(8 September 2017 5:22:36.855813 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3161.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3161] on 29 August 2017 at 3:54:37 pm'! -!Theme methodsFor: 'keyboard shortcuts' stamp: 'jmv 8/29/2017 15:53:47' prior: 16936827! - keyStroke: aKeyboardEvent morph: aMorph - aKeyboardEvent controlKeyPressed ifTrue: [^false]. - aKeyboardEvent commandAltKeyPressed ifFalse: [^false]. - - aKeyboardEvent keyValue = $w numericValue ifTrue: [ - aMorph owningWindow ifNotNil: [ :w | - (w morphContainsPoint: (w internalizeFromWorld: aKeyboardEvent eventPosition)) ifTrue: [ - w delete. - ^true ] ]]. -" aKeyboardEvent keyValue = $f numericValue - ifTrue: [aMorph owningWindow ifNotNil: [ :w | w fullScreen. ^true ]]. -" - ^ false! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3162-OnlyCloseWindowIfContainsMousePointer-JuanVuletich-2017Aug29-15h49m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3121] on 9 July 2017 at 7:49:17 pm'! -!Interval class methodsFor: 'instance creation' stamp: 'jmv 7/9/2017 16:59:23' prior: 16861363! - 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). - (newInterval hasEqualElements: aCollection) - ifFalse: [ 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 -"! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3163-IntervalFix-JuanVuletich-2017Jul09-16h58m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3163] on 31 August 2017 at 10:20:55 am'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3164-CategorizePinningProtocol-JuanVuletich-2017Aug31-10h17m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3164] on 6 September 2017 at 9:59:44 am'! -!SimpleServiceEntry methodsFor: 'initialization' stamp: 'jmv 9/6/2017 09:56:01' prior: 16908010! -initialize - triggerFileListChanged _ false. - sortOrder _ 1! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3165-FileListFix-JuanVuletich-2017Sep06-09h43m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3165] on 6 September 2017 at 10:08:50 am'! -!ReparseAfterSourceEditing commentStamp: 'jmv 9/6/2017 10:05:54' prior: 16900979! - A ReparseAfterSourceEditing is a Notification used to restart the syntax parsing phase of a compilation after a change in source code.! -!TextModelMorph methodsFor: 'accessing' stamp: 'jmv 9/6/2017 10:01:18'! - disableEditing - self textMorph disableEditing! ! -!TextModelMorph methodsFor: 'accessing' stamp: 'jmv 9/6/2017 10:03:26'! - enableEditing - - self textMorph enableEditing! ! -!BrowserWindow methodsFor: 'updating' stamp: 'jmv 9/6/2017 10:04:36'! - disableCodePaneEditing - - codePane ifNotNil: [ codePane disableEditing ]! ! -!BrowserWindow methodsFor: 'updating' stamp: 'jmv 9/6/2017 10:04:48'! - enableCodePaneEditing - - codePane ifNotNil: [ codePane enableEditing ]! ! -!InnerTextMorph methodsFor: 'accessing' stamp: 'jmv 9/6/2017 10:01:59'! - disableEditing - self setProperty: #disablesEditing toValue: true. - self stopBlinking! ! -!InnerTextMorph methodsFor: 'accessing' stamp: 'jmv 9/6/2017 10:03:03'! -enableEditing - - self removeProperty: #disablesEditing! ! -!InnerTextMorph methodsFor: 'event handling testing' stamp: 'jmv 9/6/2017 10:02:01'! - disablesEditing - - ^self hasProperty: #disablesEditing! ! -!Inspector methodsFor: 'contents' stamp: 'jmv 9/6/2017 10:05:31' prior: 50368934! - acceptedStringOrText - "We need our cache not to be modified by user changes" - ^acceptedContentsCache copy! ! -!TextEditor methodsFor: 'accessing' stamp: 'jmv 9/6/2017 10:02:22' prior: 16931330! - replaceSelectionWith: aTextOrString - "Deselect, and replace the selection text by aText." - "This is a user command, and generates undo" - - | start stop replacement | - - morph disablesEditing ifTrue: [ - ^ self ]. - - start _ self startIndex. - stop _ self stopIndex. - (aTextOrString isEmpty and: [stop > start]) ifTrue: [ - "If deleting, then set emphasisHere from 1st character of the deletion" - emphasisHere _ (model actualContents attributesAt: start) select: [:att | - att mayBeExtended]]. - - (start = stop and: [ aTextOrString isEmpty ]) ifFalse: [ - replacement _ self addAttributesForPasting: aTextOrString. - model logUndoAndReplaceFrom: start to: stop - 1 with: replacement. - textComposition - recomposeFrom: start - to: start + replacement size - 1 - delta: replacement size - (stop-start). - self deselectAndPlaceCursorAt: start + replacement size. - selectionStartBlocks _ #(). - selectionStopBlocks _ #(). - self userHasEdited " -- note text now dirty" ]. - - morph possiblyChanged! ! -!TextEditor methodsFor: 'private' stamp: 'jmv 9/6/2017 10:02:19' prior: 16932614! - applyAttribute: aTextAttribute - "The user selected aTextAttribute via shortcut, menu or other means. - If there is a selection, apply the attribute to the selection. - In any case use the attribute for the user input (emphasisHere)" - "This generates undo" - | anythingDone | - - morph disablesEditing ifTrue: [ - ^ self ]. - - anythingDone _ false. - emphasisHere _ Text addAttribute: aTextAttribute toArray: emphasisHere. - self selectionIntervalsDo: [ :interval | - (interval notEmpty or: [ aTextAttribute isParagraphAttribute ]) - ifTrue: [ - anythingDone _ true. - model logUndoAndAddAttribute: aTextAttribute from: interval first to: interval last. - textComposition recomposeFrom: interval first to: interval last delta: 0 ]]. - anythingDone ifTrue: [ - self recomputeSelection. "Needed so visible selection is updated to reflect new visual extent of selection" - self userHasEdited ]. - - "Even if nothing done, emphasisHere might have changed" - morph possiblyChanged! ! -!TextEditor methodsFor: 'undo & redo' stamp: 'jmv 9/6/2017 10:02:20' prior: 16933011! - redo - - morph disablesEditing ifTrue: [ - ^ self ]. - - model redoAndEvaluate: [ :modelUpdated :newCursorPos | - newCursorPos - ifNil: [ self recomputeSelection ] - ifNotNil: [ self markIndex: newCursorPos pointIndex: newCursorPos ]. - modelUpdated ifTrue: [ - self userHasEdited. - textComposition composeAll. "this could be made more specific..." - morph possiblyChanged ]]! ! -!TextEditor methodsFor: 'undo & redo' stamp: 'jmv 9/6/2017 10:02:24' prior: 16933031! - undo - - morph disablesEditing ifTrue: [ - ^ self ]. - - model undoAndEvaluate: [ :modelUpdated :newCursorPos | - newCursorPos - ifNil: [ self recomputeSelection ] - ifNotNil: [ self markIndex: newCursorPos pointIndex: newCursorPos ]. - modelUpdated ifTrue: [ - self userHasEdited. - textComposition composeAll. "this could be made more specific..." - morph possiblyChanged ]]! ! -!BrowserWindow methodsFor: 'updating' stamp: 'jmv 9/6/2017 10:04:55' prior: 50368594! - editSelectionChanged - - self isEditSelectionNone - ifTrue: [ self disableCodePaneEditing ] - ifFalse: [ self enableCodePaneEditing]! ! -!InnerTextMorph methodsFor: 'blinking cursor' stamp: 'jmv 9/6/2017 10:02:07' prior: 16856157! - showsBlinkingCursor - - ^self handlesKeyboard and: [ self disablesEditing not ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3166-ItIsEditingNotEdition-JuanVuletich-2017Sep06-10h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3165] on 6 September 2017 at 10:09:36 am'! - -InnerTextMorph removeSelector: #disableEdition! - -InnerTextMorph removeSelector: #disableEdition! - -InnerTextMorph removeSelector: #disablesEdition! - -InnerTextMorph removeSelector: #disablesEdition! - -InnerTextMorph removeSelector: #enableEdition! - -InnerTextMorph removeSelector: #enableEdition! - -BrowserWindow removeSelector: #disableCodePaneEdition! - -BrowserWindow removeSelector: #disableCodePaneEdition! - -BrowserWindow removeSelector: #enableCodePaneEdition! - -BrowserWindow removeSelector: #enableCodePaneEdition! - -TextModelMorph removeSelector: #disableEdition! - -TextModelMorph removeSelector: #disableEdition! - -TextModelMorph removeSelector: #enableEdition! - -TextModelMorph removeSelector: #enableEdition! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3167-EditionMisnomerCleanup-JuanVuletich-2017Sep06-10h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3162] on 4 September 2017 at 5:01:33 pm'! - -ChangeList subclass: #ChangeListWithFileInErrors - instanceVariableNames: 'errors' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #ChangeListWithFileInErrors category: #'Tools-Changes'! -ChangeList subclass: #ChangeListWithFileInErrors - instanceVariableNames: 'errors' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! -!ChangeListWithFileInErrors commentStamp: 'HAW 9/4/2017 10:23:05' prior: 0! - This class is used to keep errors when filing in changes. -I could have use ChangeList directly, selecting changes with errors, then removing them, etc., but it had some problems and that solution is more a hack. -So, instances of this class will keep errors when filing in a change, and it allows the posibility to show the change with the error in a change list window. - -A doit change that signaled a MessageNotUnderstood is assume to not be an error becuase those kinds of things are evaluations in specific contexts that will obiously generate errors. -All doits with errors could be assume not to be errors, but I limited to MNU type of errors to avoid filtering errors that should be shown.! -!ChangeListWithFileInErrors methodsFor: 'filing in' stamp: 'HAW 9/4/2017 09:34:35'! - fileInAllKeepingErrors - - errors := Dictionary new. - changeList do: [ :change | self fileInKeepingError: change ]. -! ! -!ChangeListWithFileInErrors methodsFor: 'filing in' stamp: 'HAW 9/4/2017 16:36:13'! - fileInKeepingError: change - - [ change fileIn ] - on: Error - do: [ :anError | (self hasToKeep: anError for: change) ifTrue: [ errors at: change put: anError ]]! ! -!ChangeListWithFileInErrors methodsFor: 'initialization-release' stamp: 'HAW 9/4/2017 09:34:20'! - initialize - - super initialize. - errors := Dictionary new.! ! -!ChangeListWithFileInErrors methodsFor: 'testing' stamp: 'HAW 9/4/2017 09:37:00'! - hasFileInErrors - - ^errors notEmpty! ! -!ChangeListWithFileInErrors methodsFor: 'testing' stamp: 'HAW 9/4/2017 16:37:07'! - hasToKeep: anError for: change - - ^(change isDoIt and: [ anError isKindOf: MessageNotUnderstood ]) not! ! -!ChangeListWithFileInErrors methodsFor: 'showing filein errors' stamp: 'HAW 9/4/2017 10:01:06'! - failedFileInChangesLabel - - ^'Changes that failed to file in'! ! -!ChangeListWithFileInErrors methodsFor: 'showing filein errors' stamp: 'HAW 9/4/2017 10:45:43'! -ifFiledInWithErrorAdd: aChange at: anIndex to: newChangeList and: newList - - (self wasFiledInWithError: aChange) ifTrue: [ - newChangeList add: aChange. - newList add: ((list at: anIndex) contractTo: 40), ' | ', (errors at: aChange) printString ]! ! -!ChangeListWithFileInErrors methodsFor: 'showing filein errors' stamp: 'HAW 9/4/2017 10:04:47'! - removeSucessfullyFiledInChanges - - | newChangeList newList | - - newChangeList := OrderedCollection new. - newList := OrderedCollection new. - - changeList withIndexDo: [ :aChange :anIndex | self ifFiledInWithErrorAdd: aChange at: anIndex to: newChangeList and: newList ]. - - changeList _ newChangeList. - list _ newList. - listIndex _ 0. - self clearSelections. - self changed: #list.! ! -!ChangeListWithFileInErrors methodsFor: 'showing filein errors' stamp: 'HAW 9/4/2017 10:02:20'! - showChangesWithFileInErrors - - self removeSucessfullyFiledInChanges. - ChangeListWindow open: self label: self failedFileInChangesLabel - -! ! -!ChangeListWithFileInErrors methodsFor: 'showing filein errors' stamp: 'HAW 9/4/2017 10:46:01'! - wasFiledInWithError: aChange - - ^errors includesKey: aChange! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:48:40'! - logSnapshot: save andQuit: quit - "Log quitting to changes file" - | msg | - (SourceFiles at: 2) ifNotNil: [ - msg _ self snapshotMessageFor: save andQuit: quit. - self assureStartupStampLogged. - save ifTrue: [ - LastQuitLogPosition _ (SourceFiles at: 2) - setToEnd; - position ]. - self logChange: msg. - Transcript - newLine; - show: msg; - newLine ]! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:42:57'! - nopTag - - ^ 'NOP'! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:42:27'! - quitNoSaveTag - - ^ 'QUIT/NOSAVE' ! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:40:45'! - quitTag - - ^'QUIT'! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:51:51'! - snapshotMessageFor: save andQuit: quit - - ^String streamContents: [ :stream | - stream - nextPutAll: self tagHeader; - nextPutAll: (self snapshotTagFor: save andQuit: quit); - nextPutAll: self tagTail; - print: Date dateAndTimeNow; - space; - nextPutAll: self imageName asFileEntry name; - nextPutAll: ' priorSource: '; - print: LastQuitLogPosition ].! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:41:19'! - snapshotTag - - ^'SNAPSHOT'! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:51:20'! - snapshotTagFor: save andQuit: quit - - ^save - ifTrue: [ quit - ifTrue: [ self quitTag ] - ifFalse: [ self snapshotTag ]] - ifFalse: [ quit - ifTrue: [ self quitNoSaveTag ] - ifFalse: [ self nopTag ]]! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:45:54'! - tagHeader - - ^ '----'! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:46:02'! - tagTail - - ^ self tagHeader! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:11:51'! - hasToRestoreChanges - - ^self withChangesFileDo: [ :changesFile | - changesFile position: self lastQuitLogPosition. - self hasToRestoreChangesFrom: changesFile ]. - ! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 16:41:24'! - hasToRestoreChangesFrom: changesFile - - | chunk | - - [ changesFile atEnd ] whileFalse: [ chunk := changesFile nextChunk ]. - - ^(self isSnapshotQuitOrQuitNoSaveRecord: chunk) not -! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 08:56:02'! - isQuitNoSaveRecord: chunk - - ^chunk beginsWith: self tagHeader, self quitNoSaveTag - ! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 08:55:51'! - isQuitRecord: chunk - - ^chunk beginsWith: self tagHeader, self quitTag ! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 16:34:34'! - isSnapshotQuitOrQuitNoSaveRecord: chunk - - ^(self isSnapshotRecord: chunk) - or: [ (self isQuitRecord: chunk) - or: [ self isQuitNoSaveRecord: chunk ]]! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 08:57:09'! - isSnapshotRecord: chunk - - ^chunk beginsWith: self tagHeader, self snapshotTag - ! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 09:07:35'! - lostChangesDetectedCaption - - ^ -'Last changes may have been lost -(maybe the VM crashed or you had to kill it) -What do you want to do?'! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:25:45'! - restoreLostChanges - - | decision | - - decision := PopUpMenu withCaption: self lostChangesDetectedCaption chooseFrom: self restoreLostChangesOptions. - - decision = 1 ifTrue: [ ^self restoreLostChangesAutomatically ]. - decision = 2 ifTrue: [ ^self restoreLostChangesManually ]! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:13:01'! - restoreLostChangesAutomatically - - self withChangesFileDo: [ :aChangesFile | self restoreLostChangesAutomaticallyFrom: aChangesFile ]! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 10:15:16'! - restoreLostChangesAutomaticallyFrom: aChangesFile - - | changeList | - - changeList := ChangeListWithFileInErrors new. - changeList scanFile: aChangesFile from: LastQuitLogPosition to: aChangesFile size. - changeList fileInAllKeepingErrors. - (changeList hasFileInErrors and: [ self shouldShowFileInErrors ]) ifTrue: [ changeList showChangesWithFileInErrors ] -! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:09:39'! - restoreLostChangesIfNecessary - - " - Smalltalk restoreLostChangesIfNecessary - " - - self hasToRestoreChanges ifTrue: [ WorldState addDeferredUIMessage: [self restoreLostChanges ]]. -! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/1/2017 17:28:22'! - restoreLostChangesManually - - ChangeList browseRecentLog! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:25:55'! - restoreLostChangesOptions - - ^{'Restore lost changes automatically'. 'Restore lost changes manually'. 'Nothing'}.! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:29:46'! - restoringChangesHasErrorsCaption - - ^'There were errors filing in the lost changes. Do you want to see them?'! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 09:37:34'! - shouldShowFileInErrors - - ^self confirm: self restoringChangesHasErrorsCaption - ! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:11:39'! - withChangesFileDo: aBlock - - ^self currentChangesName asFileEntry readStreamDo: aBlock! ! -!ChangeRecord methodsFor: 'testing' stamp: 'HAW 9/4/2017 06:32:29'! - isDoIt - - ^type = #doIt! ! -!ChangeList methodsFor: 'menu actions' stamp: 'HAW 9/4/2017 10:26:32' prior: 16796254! - removeDoIts - "Remove doits from the receiver, other than initializes. 1/26/96 sw" - - | newChangeList newList | - newChangeList _ OrderedCollection new. - newList _ OrderedCollection new. - - changeList with: list do: [ :chRec :str | - (chRec isDoIt not or: [str endsWith: 'initialize']) - ifTrue: [ - newChangeList add: chRec. - newList add: str]]. - newChangeList size < changeList size - ifTrue: [ - changeList _ newChangeList. - list _ newList. - listIndex _ 0. - self clearSelections ]. - self changed: #list. - - ! ! -!ChangeList methodsFor: 'menu actions' stamp: 'HAW 9/4/2017 10:26:50' prior: 16796515! - selectRemovalsOfSent - "Selects all method removal for sent methods" - - 1 to: changeList size do: [ :i | | change | - change _ changeList at: i. - listSelections at: i put: - (change isDoIt and: [ - change string includesSubString: 'removeSelector: #' ] and: [ - Smalltalk isThereAReferenceTo: (change string copyAfterLast: $#) asSymbol ]) ]. - self changed: #allSelections. - self changed: #annotation! ! -!ChangeList class methodsFor: 'public access' stamp: 'HAW 9/4/2017 10:32:00' prior: 16796892! - browseRecentLogOn: origChangesFileName - "figure out where the last snapshot or quit was, then browse the recent entries." - - | end done block positions prevBlock | - origChangesFileName asFileEntry readStreamDo: [ :changesFile | - positions _ SortedCollection new. - end _ changesFile size. - prevBlock _ end. - block _ end - 1024 max: 0. - done _ false. - [ done or: [ positions size > 0 ]] - whileFalse: [ - changesFile position: block. - "ignore first fragment" - changesFile nextChunk. - [ changesFile position < prevBlock ] - whileTrue: [ - | pos chunk | - pos _ changesFile position. - chunk _ changesFile nextChunk. - ((Smalltalk isQuitRecord: chunk) or: [ Smalltalk isSnapshotRecord: chunk ]) - ifTrue: [ positions add: pos ]]. - block = 0 - ifTrue: [done _ true] - ifFalse: [ - prevBlock _ block. - block _ block - 1024 max: 0]]. - ]. - positions isEmpty - ifTrue: [self inform: 'File ' , origChangesFileName , ' does not appear to be a changes file'] - ifFalse: [self browseRecentLogOn: origChangesFileName startingFrom: positions last]! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:46:37' prior: 50361384! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag -"WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " -| activeProc | -activeProc _ Processor activeProcess. -[ - | isARealStartup world reopenTranscript | - self logSnapshot: save andQuit: quit. - - reopenTranscript _ false. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | each isInWorld ifTrue: [ each delete. reopenTranscript _ true ]]. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - - - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - - "Cosas que levanto explicitamente abajo" - world _ ProjectX ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "world _ clearAllStateFlag ifFalse: [ ProjectX ui ]." - ProjectX stopUIProcess. - activeProc isTerminated ifFalse: [ - activeProc terminate ]. - - "Clean Globals" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: nil. - Smalltalk closeSourceFiles. Smalltalk at: #SourceFiles put: nil. - Smalltalk allClassesDo: [ :cls | cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ Smalltalk printStuffToCleanOnImageSave ]. - - - "Do image save & quit as apropriate" - Cursor write activateCursor. - save - ifTrue: [ - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - - - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: (DisplayScreen extent: `1024@768` depth: 32). - Smalltalk at: #SourceFiles put: (Array new: 2). - Smalltalk openSourceFiles. - - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - - - ProjectX spawnNewMorphicProcessFor: (world ifNil: [ PasteUpMorph newWorld ]). - - reopenTranscript ifTrue: [ - WorldState addDeferredUIMessage: [ - TranscriptWindow openTranscript ]]. - " - WorldState addDeferredUIMessage: [ - world fullRepaintNeeded ]. - " - - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - WorldState addDeferredUIMessage: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]. - -] forkAt: Processor timingPriority-1 named: 'Startup process'.! ! -!SystemDictionary methodsFor: 'startup' stamp: 'HAW 9/4/2017 06:14:44' prior: 50335335! - doStartUp: isARealStartup - " - isARealStartup - true: system is coming up (VM and image just started) - false: we have just saved an image snapshot, but didn't quit. - " - - "Here, startup begins!!" - Cursor normal activateCursor. - self setGCParameters. - isARealStartup ifTrue: [ - self clearExternalObjects ]. - self readCommandLineArguments. - self processStartUpList: isARealStartup. - isARealStartup ifTrue: [ - self setPlatformPreferences. - self setStartupStamp. - self restoreLostChangesIfNecessary ]! ! -!ChangeRecord methodsFor: 'initialization' stamp: 'HAW 9/4/2017 10:27:15' prior: 16797438! - fileIn - "File the receiver in. If I represent a method or a class-comment, file the method in and make a note of it in the recent-submissions list; if I represent a do-it, then, well, do it." - | s | - type == #method ifTrue: [ - self changeClass ifNotNil: [ :methodClass | - methodClass - compile: self text - classified: category - withStamp: stamp - notifying: nil ]]. - self isDoIt ifTrue: [ - ((s _ self string) beginsWith: '----') ifFalse: [ Compiler evaluate: s ]]. - type == #classDefinition ifTrue: [ Compiler evaluate: self string ]. - type == #classComment ifTrue: [ - (Smalltalk at: class asSymbol) - comment: self text - stamp: stamp ]! ! - -SystemDictionary removeSelector: #logSapshot:andQuit:! - -SystemDictionary removeSelector: #logSapshot:andQuit:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3168-AidInRecoveringChanges-HernanWilkinson-2017Sep01-13h49m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3168] on 7 September 2017 at 5:51:10 pm'! - -TextAttribute subclass: #TextBackgroundColor - instanceVariableNames: 'color' - classVariableNames: '' - poolDictionaries: '' - category: 'System-TextAttributes'! - -!classDefinition: #TextBackgroundColor category: #'System-TextAttributes'! -TextAttribute subclass: #TextBackgroundColor - instanceVariableNames: 'color' - classVariableNames: '' - poolDictionaries: '' - category: 'System-TextAttributes'! -!TextBackgroundColor commentStamp: '' prior: 0! - A TextColor encodes a text color change applicable over a given range of text.! - -TextBackgroundColor subclass: #ShoutTextBackgroundColor - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'System-TextAttributes'! - -!classDefinition: #ShoutTextBackgroundColor category: #'System-TextAttributes'! -TextBackgroundColor subclass: #ShoutTextBackgroundColor - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'System-TextAttributes'! -!ShoutTextBackgroundColor commentStamp: '' prior: 0! - Just for code styler (Shout)! - -CharacterScanner subclass: #MorphicScanner - instanceVariableNames: 'canvas lineY foregroundColor defaultColor topLeft ignoreColorChanges backgroundColor ' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Text'! - -!classDefinition: #MorphicScanner category: #'Graphics-Text'! -CharacterScanner subclass: #MorphicScanner - instanceVariableNames: 'canvas lineY foregroundColor defaultColor topLeft ignoreColorChanges backgroundColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Text'! - -Object subclass: #SHRange - instanceVariableNames: 'start end type blockDepth ' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -!classDefinition: #SHRange category: #'Tools-Syntax Highlighting'! -Object subclass: #SHRange - instanceVariableNames: 'start end type blockDepth' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! -!String methodsFor: 'comparing' stamp: 'jmv 9/7/2017 10:29:52'! - toto: aString - "Answer whether the receiver sorts equally as aString. - This means same characters in same order." - - "Any object is equal to itself" - self == aString ifTrue: [ ^ true ]. - - "If argument is not a String or Symbol, maybe it is a Text?" - aString species == String ifFalse: [ - (aString is: #Text) ifTrue: [ ^ self = aString string ]. - ^ false]. - - self size = aString size ifFalse: [ [ ] value. 3 > 4 ifTrue: [ [true] whileTrue: [ - 1 = 2 ifFalse: [ - 3=3 ifTrue: [] - ] - ]]. - ^false ]. - - ^ (self compare: self with: aString collated: CaseSensitiveOrder) = 2! ! -!TextAttribute methodsFor: 'iterating' stamp: 'jmv 9/7/2017 16:45:20'! - forTextBackgroundColorDo: aBlock - "No action is the default"! ! -!TextBackgroundColor methodsFor: 'accessing' stamp: 'jmv 9/7/2017 16:41:55'! - color - ^ color! ! -!TextBackgroundColor methodsFor: 'accessing' stamp: 'jmv 9/7/2017 16:41:55'! - color: aColor - color _ aColor! ! -!TextBackgroundColor methodsFor: 'comparing' stamp: 'jmv 9/7/2017 16:41:55'! - = other - self == other ifTrue: [ ^ true ]. - ^ (other class == self class) - and: [other color = color]! ! -!TextBackgroundColor methodsFor: 'comparing' stamp: 'jmv 9/7/2017 16:41:55'! - hash - ^ color hash! ! -!TextBackgroundColor methodsFor: 'printing' stamp: 'jmv 9/7/2017 16:41:55'! - printOn: strm - super printOn: strm. - strm nextPutAll: ' code: '; print: color! ! -!TextBackgroundColor methodsFor: 'scanning' stamp: 'jmv 9/7/2017 16:41:55'! - dominates: other - ^ other class == self class! ! -!TextBackgroundColor methodsFor: 'iterating' stamp: 'jmv 9/7/2017 16:45:12'! - forTextBackgroundColorDo: aBlock - aBlock value: color! ! -!TextBackgroundColor methodsFor: 'testing' stamp: 'jmv 9/7/2017 16:44:40'! - isSet - "Do not include Color black, as it is the default color." - ^color isTransparent not! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - black - ^ self new color: Color black! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - blue - ^ self new color: Color blue! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - cyan - ^ self new color: Color cyan! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - gray - ^ self new color: Color gray! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - green - ^ self new color: Color green! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - magenta - ^ self new color: Color magenta! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - red - ^ self new color: Color red! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - white - ^ self new color: Color white! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - yellow - ^ self new color: Color yellow! ! -!TextBackgroundColor class methodsFor: 'instance creation' stamp: 'jmv 9/7/2017 16:41:55'! - color: aColor - ^ self new color: aColor! ! -!ShoutTextBackgroundColor methodsFor: 'testing' stamp: 'jmv 9/7/2017 16:42:03'! - isForShout - "True if to be removed from code before styling" - ^true! ! -!CharacterScanner methodsFor: 'private' stamp: 'jmv 9/7/2017 17:00:23'! - backgroundColor: ignored - "Overridden in MorphicScanner"! ! -!MorphicScanner methodsFor: 'private' stamp: 'jmv 9/7/2017 16:56:38'! - backgroundColor: aColor - backgroundColor _ aColor! ! -!SHRange methodsFor: 'accessing' stamp: 'jmv 9/6/2017 20:25:10'! - blockDepth - ^blockDepth! ! -!SHRange methodsFor: 'accessing' stamp: 'jmv 9/6/2017 20:22:45'! - blockDepth: anInteger - blockDepth := anInteger! ! -!Text methodsFor: 'emphasis' stamp: 'jmv 9/7/2017 17:18:49' prior: 16929486! - withAttributeValues: attributes do: aBlock - "Evaluate aBlock with the values of various attributes that affect text formatting, applied in the correct order - The order is (each overwriting the previous one) - 1) basic defaults - 2) ParagraphStyleReferene - 3) CharacterStyleReference - 4) TextFontReference - 5) TextEmphasis" - - | paragraphStyle characterStyle familyName pointSize emphasis alignment color backgroundColor | - paragraphStyle _ nil. - characterStyle _ nil. - familyName _ nil. - pointSize _ nil. - emphasis _ 0. - alignment _ 0. - color _ nil. - backgroundColor _ nil. - - "ParagraphStyle is the first to set several values" - attributes do: [ :attribute | - attribute forParagraphStyleReferenceDo: [ :s | - paragraphStyle _ s. - familyName _ s familyName. - pointSize _ s pointSize. - emphasis _ s emphasis. - alignment _ s alignment. - s color ifNotNil: [ :c | color _ c ]]]. - - "CharacterStyle, if present, can override font and color" - attributes do: [ :attribute | - attribute forCharacterStyleReferenceDo: [ :s | - characterStyle _ s. - familyName _ s familyName. - pointSize _ s pointSize. - emphasis _ s emphasis. - s color ifNotNil: [ :c | color _ c ]]]. - - "These will not interfere with each other, and all of them take precedence over previous values" - attributes do: [ :attribute | - attribute forFontFamilyAndSizeDo: [ :fn :ps | familyName _ fn. pointSize _ ps ]. - attribute forTextEmphasisDo: [ :e | emphasis _ emphasis bitOr: e ]. - attribute forTextColorDo: [ :c | color _ c ]. - attribute forTextBackgroundColorDo: [ :c | backgroundColor _ c ]. - attribute forTextAlignmentDo: [ :a | alignment _ a ]. - ]. - - "Done. Now evaluate the block." -"cambiar senders!!!!!!!!!!!!" - aBlock numArgs = 8 ifTrue: [ - ^aBlock valueWithArguments: { familyName. pointSize. emphasis. color. alignment. characterStyle. paragraphStyle. backgroundColor } - ]. - ^aBlock valueWithArguments: { familyName. pointSize. emphasis. color. alignment. characterStyle. paragraphStyle }! ! -!BitBlt methodsFor: 'accessing' stamp: 'jmv 9/6/2017 20:40:02' prior: 16785548! - destX: x destY: y width: w height: h - destX _ x. - destY _ y. - width _ w. - height _ h.! ! -!CharacterScanner methodsFor: 'private' stamp: 'jmv 9/7/2017 17:19:12' prior: 16801954! - setFont - | attributes | - "Set the font and other emphasis. - In fact set actual ParagraphStyle (or nil), alignment, font and emphasis" - - self setActualFont: (text fontAt: lastIndex default: defaultFont). - attributes _ text attributesAt: lastIndex. - text - withAttributeValues: attributes - do: [ :familyNameInText :pointSizeInText :emphasisInText :colorInText :alignmentInText :characterStyleInText :paragraphStyleInText :backgroundColorInText | - colorInText ifNotNil: [ self textColor: colorInText ]. - self backgroundColor: backgroundColorInText. - alignment _ alignmentInText. - paragraphStyle _ paragraphStyleInText ]. - - "Hardcoded color for TextAction" - attributes do: [ :attribute | - attribute forTextActionInfoDo: [ :info | - self textColor: TextAction textActionColor ]]. - - "Install various parameters from the font." - spaceWidth _ font widthOf: Character space. - tabWidth _ (font widthOf: $a) * 3. - xTable _ font xTable. - map _ font characterToGlyphMap! ! -!CharacterScanner methodsFor: 'private' stamp: 'jmv 9/6/2017 20:40:09' prior: 16801989! - textColor: ignored - "Overridden in MorphicScanner"! ! -!MorphicScanner methodsFor: 'scanning' stamp: 'jmv 9/7/2017 17:50:39' prior: 16877966! - displayLine: textLine textTopLeft: textTopLeft leftInRun: leftInRun - "The call on the primitive (scanCharactersFrom:to:in:rightX:) will be interrupted according to an array of stop conditions passed to the scanner at which time the code to handle the stop condition is run and the call on the primitive continued until a stop condition returns true (which means the line has terminated). leftInRun is the # of characters left to scan in the current run; when 0, it is time to call setStopConditions." - - "textTopLeft is relative to the morph currently being drawn" - | stopCondition nowLeftInRun startIndex string lastPos tt | - - topLeft _ textTopLeft. - line _ textLine. - lineY _ line top + textTopLeft y. - rightMargin _ line rightMargin + textTopLeft x. - lastIndex _ line first. - leftInRun <= 0 ifTrue: [ - self setFont. - self setStopConditions ]. - leftMargin _ (line leftMarginForAlignment: alignment) + textTopLeft x. - destX _ leftMargin. - destY _ lineY + line baseline - font ascent. - - textLine isEmptyLine ifTrue: [ - textLine paragraphStyle ifNotNil: [ :ps | - ps = paragraphStyle ifFalse: [ - foregroundColor _ defaultColor. - self setActualFont: ps font. - ps color ifNotNil: [ :color | self textColor: color ]. - alignment _ ps alignment. - paragraphStyle _ ps. - spaceWidth _ font widthOf: Character space. - tabWidth _ (font widthOf: $a) * 3. - xTable _ font xTable. - map _ font characterToGlyphMap. - self setStopConditions. - text ifNotNil: [ destY _ lineY + line baseline - font ascent ]]]. - self displayBulletIfAppropriateFor: textLine textLeft: textTopLeft x. - ^leftInRun ]. - - self displayBulletIfAppropriateFor: textLine textLeft: textTopLeft x. - - lastIndex _ line first. - leftInRun <= 0 - ifTrue: [nowLeftInRun _ text runLengthFor: lastIndex] - ifFalse: [nowLeftInRun _ leftInRun]. - runStopIndex _ lastIndex + (nowLeftInRun - 1) min: line last. - spaceCount _ 0. - string _ text string. - - self placeEmbeddedObject. - [ - startIndex _ lastIndex. - lastPos _ destX@destY. - stopCondition _ self - scanCharactersFrom: lastIndex to: runStopIndex - in: string rightX: rightMargin stopConditions: stopConditions - kern: font baseKern. - backgroundColor ifNotNil: [ - "origin y podria ser el del argumento" - "dest y lo tome de la seleccion. Podria quizas venir de otro lado" - "corner x = rightMargin para ir hasta el final - corner x = destX para pintar solo el texto (no seguir hasta el final) - Wow, esto está bastante cerca." - "mhhh solo poner rightMargin para el ultimo. No antes (siquiero usar transparencia y no pintar de mas)" - "En libreoffice writer, background es para parrafo. - ademas, seleccion y background marcan hasta el borde derecho de la pgina. - pero highlight (resaltador) solo hasta los bounds de las palabras (en cualquier modo de justificado)" - tt _ lastIndex +1 = line last ifTrue: [rightMargin] ifFalse: [destX]. - tt _ destX. - canvas - fillRectangle: (lastPos corner: tt @ (line bottom + textTopLeft y)) - color: backgroundColor. - ]. - lastIndex >= startIndex ifTrue: [ - canvas - drawString: string - from: startIndex - to: lastIndex - at: lastPos - font: font - color: foregroundColor ]. - "see setStopConditions for stopping conditions for displaying." - (self perform: stopCondition) ifTrue: [ - "Number of characters remaining in the current run" - ^ runStopIndex - lastIndex ] - ] repeat! ! -!SHParserST80 methodsFor: 'recording ranges' stamp: 'jmv 9/7/2017 17:38:19' prior: 16902916! - rangeType: aSymbol start: s end: e - ^ranges add: ((SHRange start: s end: e type: aSymbol) blockDepth: blockDepth + 1)! ! -!SHTextStylerST80 methodsFor: 'private' stamp: 'jmv 9/7/2017 17:49:29' prior: 50335097! - setAttributesFromRanges: ranges - - | alpha rangeStart range start end | - formattedText removeAttributesThat: [ :attribute | attribute isForShout ]. - - "Optimize for mutation speed unless method is really large but with very few distict elements: - Source code that includes just big literals is better served by conventional Text+RunArray" - "Do it only if we are not breaking textModel!! (for instance, StyledTextEditor asks for formatting just sections, not whole #actualContents)." - formattedText == textModel actualContents ifTrue: [ - (formattedText size > 2000 and: [ ranges size < 50 ]) ifFalse: [ - formattedText _ formattedText optimizedForMutationSpeed. - textModel basicActualContents: formattedText ]]. - -"Algo asi....." - rangeStart _ 1. -" ranges do: [ :range |" - 1 to: ranges size do: [ :idx | - range _ ranges at: idx. - - "Smalltalk text styling" - "Parece que hay que arreglar rangos... Hay parentesis que no tienen rango????????" - (self attributesFor: range rangeType) ifNotNil: [ :attributes | - attributes do: [ :each | - formattedText addAttribute: each from: range start to: range end ]]. - - alpha _ range blockDepth \\ 5 / 5.0. - alpha _ alpha / 2 + 0.1. - start _ rangeStart. - start _ range start. - end _ range end. - idx < ranges size ifTrue: [ end _ (ranges at: idx + 1) start - 1]. - formattedText addAttribute: (ShoutTextBackgroundColor color: (("Color gray: 0.5" Theme current text) alpha: alpha) ) from: start to: end - . - - "Show as subscripts if appropriate." - classOrMetaClass ifNotNil: [ - classOrMetaClass theNonMetaClass lastUnderscoreMeansSubscript ifTrue: [ - (#( instVar classVar globalVar workspaceVar poolConstant - patternArg methodArg patternTempVar tempVar - blockPatternArg blockArg blockPatternTempVar blockTempVar - incompleteIdentifier undefinedIdentifier) pointsTo: range rangeType ) - ifTrue: [ - formattedText lastIndexOf: $_ startingAt: range end endingAt: range start do: [ :i | - formattedText addAttribute: ShoutTextEmphasis subscript from: i to: range end ] ]]]. -rangeStart _ range end + 1. - ]! ! - -TextBackgroundColor removeSelector: #forTextColorDo:! - -CharacterScanner subclass: #MorphicScanner - instanceVariableNames: 'canvas lineY foregroundColor defaultColor topLeft backgroundColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Text'! - -!classDefinition: #MorphicScanner category: #'Graphics-Text'! -CharacterScanner subclass: #MorphicScanner - instanceVariableNames: 'canvas lineY foregroundColor defaultColor topLeft backgroundColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Text'! - -Object subclass: #SHRange - instanceVariableNames: 'start end type blockDepth' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -!classDefinition: #SHRange category: #'Tools-Syntax Highlighting'! -Object subclass: #SHRange - instanceVariableNames: 'start end type blockDepth' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Syntax Highlighting'! - -----End fileIn of /home/juan/Dropbox/3169-CuisCore-JuanVuletich-2017Sep07-16h41m-jmv.4.cs.st----! - -----QUIT/NOSAVE----#(8 September 2017 5:25:15.582632 pm) Cuis5.0-3161.image priorSource: 1201865! - -----STARTUP----#(8 September 2017 5:25:18.4615 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3161.image! - - -----QUIT/NOSAVE----#(8 September 2017 5:25:23.904918 pm) Cuis5.0-3161.image priorSource: 1201865! - -----STARTUP----#(10 September 2017 4:16:02.551509 pm) as /home/juan/Cuis/Cuis-Smalltalk-Dev/Cuis5.0-3161.image! - - -'From Cuis 5.0 of 7 November 2016 [latest update: #3161] on 29 August 2017 at 3:54:37 pm'! -!Theme methodsFor: 'keyboard shortcuts' stamp: 'jmv 8/29/2017 15:53:47' prior: 16936827! - keyStroke: aKeyboardEvent morph: aMorph - aKeyboardEvent controlKeyPressed ifTrue: [^false]. - aKeyboardEvent commandAltKeyPressed ifFalse: [^false]. - - aKeyboardEvent keyValue = $w numericValue ifTrue: [ - aMorph owningWindow ifNotNil: [ :w | - (w morphContainsPoint: (w internalizeFromWorld: aKeyboardEvent eventPosition)) ifTrue: [ - w delete. - ^true ] ]]. -" aKeyboardEvent keyValue = $f numericValue - ifTrue: [aMorph owningWindow ifNotNil: [ :w | w fullScreen. ^true ]]. -" - ^ false! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3162-OnlyCloseWindowIfContainsMousePointer-JuanVuletich-2017Aug29-15h49m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3121] on 9 July 2017 at 7:49:17 pm'! -!Interval class methodsFor: 'instance creation' stamp: 'jmv 7/9/2017 16:59:23' prior: 16861363! - 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). - (newInterval hasEqualElements: aCollection) - ifFalse: [ 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 -"! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3163-IntervalFix-JuanVuletich-2017Jul09-16h58m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3163] on 31 August 2017 at 10:20:55 am'! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3164-CategorizePinningProtocol-JuanVuletich-2017Aug31-10h17m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3164] on 6 September 2017 at 9:59:44 am'! -!SimpleServiceEntry methodsFor: 'initialization' stamp: 'jmv 9/6/2017 09:56:01' prior: 16908010! -initialize - triggerFileListChanged _ false. - sortOrder _ 1! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3165-FileListFix-JuanVuletich-2017Sep06-09h43m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3165] on 6 September 2017 at 10:08:50 am'! -!ReparseAfterSourceEditing commentStamp: 'jmv 9/6/2017 10:05:54' prior: 16900979! - A ReparseAfterSourceEditing is a Notification used to restart the syntax parsing phase of a compilation after a change in source code.! -!TextModelMorph methodsFor: 'accessing' stamp: 'jmv 9/6/2017 10:01:18'! - disableEditing - self textMorph disableEditing! ! -!TextModelMorph methodsFor: 'accessing' stamp: 'jmv 9/6/2017 10:03:26'! - enableEditing - - self textMorph enableEditing! ! -!BrowserWindow methodsFor: 'updating' stamp: 'jmv 9/6/2017 10:04:36'! - disableCodePaneEditing - - codePane ifNotNil: [ codePane disableEditing ]! ! -!BrowserWindow methodsFor: 'updating' stamp: 'jmv 9/6/2017 10:04:48'! - enableCodePaneEditing - - codePane ifNotNil: [ codePane enableEditing ]! ! -!InnerTextMorph methodsFor: 'accessing' stamp: 'jmv 9/6/2017 10:01:59'! - disableEditing - self setProperty: #disablesEditing toValue: true. - self stopBlinking! ! -!InnerTextMorph methodsFor: 'accessing' stamp: 'jmv 9/6/2017 10:03:03'! -enableEditing - - self removeProperty: #disablesEditing! ! -!InnerTextMorph methodsFor: 'event handling testing' stamp: 'jmv 9/6/2017 10:02:01'! - disablesEditing - - ^self hasProperty: #disablesEditing! ! -!Inspector methodsFor: 'contents' stamp: 'jmv 9/6/2017 10:05:31' prior: 50368934! - acceptedStringOrText - "We need our cache not to be modified by user changes" - ^acceptedContentsCache copy! ! -!TextEditor methodsFor: 'accessing' stamp: 'jmv 9/6/2017 10:02:22' prior: 16931330! - replaceSelectionWith: aTextOrString - "Deselect, and replace the selection text by aText." - "This is a user command, and generates undo" - - | start stop replacement | - - morph disablesEditing ifTrue: [ - ^ self ]. - - start _ self startIndex. - stop _ self stopIndex. - (aTextOrString isEmpty and: [stop > start]) ifTrue: [ - "If deleting, then set emphasisHere from 1st character of the deletion" - emphasisHere _ (model actualContents attributesAt: start) select: [:att | - att mayBeExtended]]. - - (start = stop and: [ aTextOrString isEmpty ]) ifFalse: [ - replacement _ self addAttributesForPasting: aTextOrString. - model logUndoAndReplaceFrom: start to: stop - 1 with: replacement. - textComposition - recomposeFrom: start - to: start + replacement size - 1 - delta: replacement size - (stop-start). - self deselectAndPlaceCursorAt: start + replacement size. - selectionStartBlocks _ #(). - selectionStopBlocks _ #(). - self userHasEdited " -- note text now dirty" ]. - - morph possiblyChanged! ! -!TextEditor methodsFor: 'private' stamp: 'jmv 9/6/2017 10:02:19' prior: 16932614! - applyAttribute: aTextAttribute - "The user selected aTextAttribute via shortcut, menu or other means. - If there is a selection, apply the attribute to the selection. - In any case use the attribute for the user input (emphasisHere)" - "This generates undo" - | anythingDone | - - morph disablesEditing ifTrue: [ - ^ self ]. - - anythingDone _ false. - emphasisHere _ Text addAttribute: aTextAttribute toArray: emphasisHere. - self selectionIntervalsDo: [ :interval | - (interval notEmpty or: [ aTextAttribute isParagraphAttribute ]) - ifTrue: [ - anythingDone _ true. - model logUndoAndAddAttribute: aTextAttribute from: interval first to: interval last. - textComposition recomposeFrom: interval first to: interval last delta: 0 ]]. - anythingDone ifTrue: [ - self recomputeSelection. "Needed so visible selection is updated to reflect new visual extent of selection" - self userHasEdited ]. - - "Even if nothing done, emphasisHere might have changed" - morph possiblyChanged! ! -!TextEditor methodsFor: 'undo & redo' stamp: 'jmv 9/6/2017 10:02:20' prior: 16933011! - redo - - morph disablesEditing ifTrue: [ - ^ self ]. - - model redoAndEvaluate: [ :modelUpdated :newCursorPos | - newCursorPos - ifNil: [ self recomputeSelection ] - ifNotNil: [ self markIndex: newCursorPos pointIndex: newCursorPos ]. - modelUpdated ifTrue: [ - self userHasEdited. - textComposition composeAll. "this could be made more specific..." - morph possiblyChanged ]]! ! -!TextEditor methodsFor: 'undo & redo' stamp: 'jmv 9/6/2017 10:02:24' prior: 16933031! - undo - - morph disablesEditing ifTrue: [ - ^ self ]. - - model undoAndEvaluate: [ :modelUpdated :newCursorPos | - newCursorPos - ifNil: [ self recomputeSelection ] - ifNotNil: [ self markIndex: newCursorPos pointIndex: newCursorPos ]. - modelUpdated ifTrue: [ - self userHasEdited. - textComposition composeAll. "this could be made more specific..." - morph possiblyChanged ]]! ! -!BrowserWindow methodsFor: 'updating' stamp: 'jmv 9/6/2017 10:04:55' prior: 50368594! - editSelectionChanged - - self isEditSelectionNone - ifTrue: [ self disableCodePaneEditing ] - ifFalse: [ self enableCodePaneEditing]! ! -!InnerTextMorph methodsFor: 'blinking cursor' stamp: 'jmv 9/6/2017 10:02:07' prior: 16856157! - showsBlinkingCursor - - ^self handlesKeyboard and: [ self disablesEditing not ]! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3166-ItIsEditingNotEdition-JuanVuletich-2017Sep06-10h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3165] on 6 September 2017 at 10:09:36 am'! - -InnerTextMorph removeSelector: #disableEdition! - -InnerTextMorph removeSelector: #disableEdition! - -InnerTextMorph removeSelector: #disablesEdition! - -InnerTextMorph removeSelector: #disablesEdition! - -InnerTextMorph removeSelector: #enableEdition! - -InnerTextMorph removeSelector: #enableEdition! - -BrowserWindow removeSelector: #disableCodePaneEdition! - -BrowserWindow removeSelector: #disableCodePaneEdition! - -BrowserWindow removeSelector: #enableCodePaneEdition! - -BrowserWindow removeSelector: #enableCodePaneEdition! - -TextModelMorph removeSelector: #disableEdition! - -TextModelMorph removeSelector: #disableEdition! - -TextModelMorph removeSelector: #enableEdition! - -TextModelMorph removeSelector: #enableEdition! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3167-EditionMisnomerCleanup-JuanVuletich-2017Sep06-10h08m-jmv.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3162] on 4 September 2017 at 5:01:33 pm'! - -ChangeList subclass: #ChangeListWithFileInErrors - instanceVariableNames: 'errors' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! - -!classDefinition: #ChangeListWithFileInErrors category: #'Tools-Changes'! -ChangeList subclass: #ChangeListWithFileInErrors - instanceVariableNames: 'errors' - classVariableNames: '' - poolDictionaries: '' - category: 'Tools-Changes'! -!ChangeListWithFileInErrors commentStamp: 'HAW 9/4/2017 10:23:05' prior: 0! - This class is used to keep errors when filing in changes. -I could have use ChangeList directly, selecting changes with errors, then removing them, etc., but it had some problems and that solution is more a hack. -So, instances of this class will keep errors when filing in a change, and it allows the posibility to show the change with the error in a change list window. - -A doit change that signaled a MessageNotUnderstood is assume to not be an error becuase those kinds of things are evaluations in specific contexts that will obiously generate errors. -All doits with errors could be assume not to be errors, but I limited to MNU type of errors to avoid filtering errors that should be shown.! -!ChangeListWithFileInErrors methodsFor: 'filing in' stamp: 'HAW 9/4/2017 09:34:35'! - fileInAllKeepingErrors - - errors := Dictionary new. - changeList do: [ :change | self fileInKeepingError: change ]. -! ! -!ChangeListWithFileInErrors methodsFor: 'filing in' stamp: 'HAW 9/4/2017 16:36:13'! - fileInKeepingError: change - - [ change fileIn ] - on: Error - do: [ :anError | (self hasToKeep: anError for: change) ifTrue: [ errors at: change put: anError ]]! ! -!ChangeListWithFileInErrors methodsFor: 'initialization-release' stamp: 'HAW 9/4/2017 09:34:20'! - initialize - - super initialize. - errors := Dictionary new.! ! -!ChangeListWithFileInErrors methodsFor: 'testing' stamp: 'HAW 9/4/2017 09:37:00'! - hasFileInErrors - - ^errors notEmpty! ! -!ChangeListWithFileInErrors methodsFor: 'testing' stamp: 'HAW 9/4/2017 16:37:07'! - hasToKeep: anError for: change - - ^(change isDoIt and: [ anError isKindOf: MessageNotUnderstood ]) not! ! -!ChangeListWithFileInErrors methodsFor: 'showing filein errors' stamp: 'HAW 9/4/2017 10:01:06'! - failedFileInChangesLabel - - ^'Changes that failed to file in'! ! -!ChangeListWithFileInErrors methodsFor: 'showing filein errors' stamp: 'HAW 9/4/2017 10:45:43'! -ifFiledInWithErrorAdd: aChange at: anIndex to: newChangeList and: newList - - (self wasFiledInWithError: aChange) ifTrue: [ - newChangeList add: aChange. - newList add: ((list at: anIndex) contractTo: 40), ' | ', (errors at: aChange) printString ]! ! -!ChangeListWithFileInErrors methodsFor: 'showing filein errors' stamp: 'HAW 9/4/2017 10:04:47'! - removeSucessfullyFiledInChanges - - | newChangeList newList | - - newChangeList := OrderedCollection new. - newList := OrderedCollection new. - - changeList withIndexDo: [ :aChange :anIndex | self ifFiledInWithErrorAdd: aChange at: anIndex to: newChangeList and: newList ]. - - changeList _ newChangeList. - list _ newList. - listIndex _ 0. - self clearSelections. - self changed: #list.! ! -!ChangeListWithFileInErrors methodsFor: 'showing filein errors' stamp: 'HAW 9/4/2017 10:02:20'! - showChangesWithFileInErrors - - self removeSucessfullyFiledInChanges. - ChangeListWindow open: self label: self failedFileInChangesLabel - -! ! -!ChangeListWithFileInErrors methodsFor: 'showing filein errors' stamp: 'HAW 9/4/2017 10:46:01'! - wasFiledInWithError: aChange - - ^errors includesKey: aChange! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:48:40'! - logSnapshot: save andQuit: quit - "Log quitting to changes file" - | msg | - (SourceFiles at: 2) ifNotNil: [ - msg _ self snapshotMessageFor: save andQuit: quit. - self assureStartupStampLogged. - save ifTrue: [ - LastQuitLogPosition _ (SourceFiles at: 2) - setToEnd; - position ]. - self logChange: msg. - Transcript - newLine; - show: msg; - newLine ]! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:42:57'! - nopTag - - ^ 'NOP'! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:42:27'! - quitNoSaveTag - - ^ 'QUIT/NOSAVE' ! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:40:45'! - quitTag - - ^'QUIT'! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:51:51'! - snapshotMessageFor: save andQuit: quit - - ^String streamContents: [ :stream | - stream - nextPutAll: self tagHeader; - nextPutAll: (self snapshotTagFor: save andQuit: quit); - nextPutAll: self tagTail; - print: Date dateAndTimeNow; - space; - nextPutAll: self imageName asFileEntry name; - nextPutAll: ' priorSource: '; - print: LastQuitLogPosition ].! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:41:19'! - snapshotTag - - ^'SNAPSHOT'! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:51:20'! - snapshotTagFor: save andQuit: quit - - ^save - ifTrue: [ quit - ifTrue: [ self quitTag ] - ifFalse: [ self snapshotTag ]] - ifFalse: [ quit - ifTrue: [ self quitNoSaveTag ] - ifFalse: [ self nopTag ]]! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:45:54'! - tagHeader - - ^ '----'! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:46:02'! - tagTail - - ^ self tagHeader! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:11:51'! - hasToRestoreChanges - - ^self withChangesFileDo: [ :changesFile | - changesFile position: self lastQuitLogPosition. - self hasToRestoreChangesFrom: changesFile ]. - ! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 16:41:24'! - hasToRestoreChangesFrom: changesFile - - | chunk | - - [ changesFile atEnd ] whileFalse: [ chunk := changesFile nextChunk ]. - - ^(self isSnapshotQuitOrQuitNoSaveRecord: chunk) not -! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 08:56:02'! - isQuitNoSaveRecord: chunk - - ^chunk beginsWith: self tagHeader, self quitNoSaveTag - ! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 08:55:51'! - isQuitRecord: chunk - - ^chunk beginsWith: self tagHeader, self quitTag ! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 16:34:34'! - isSnapshotQuitOrQuitNoSaveRecord: chunk - - ^(self isSnapshotRecord: chunk) - or: [ (self isQuitRecord: chunk) - or: [ self isQuitNoSaveRecord: chunk ]]! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 08:57:09'! - isSnapshotRecord: chunk - - ^chunk beginsWith: self tagHeader, self snapshotTag - ! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 09:07:35'! - lostChangesDetectedCaption - - ^ -'Last changes may have been lost -(maybe the VM crashed or you had to kill it) -What do you want to do?'! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:25:45'! - restoreLostChanges - - | decision | - - decision := PopUpMenu withCaption: self lostChangesDetectedCaption chooseFrom: self restoreLostChangesOptions. - - decision = 1 ifTrue: [ ^self restoreLostChangesAutomatically ]. - decision = 2 ifTrue: [ ^self restoreLostChangesManually ]! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:13:01'! - restoreLostChangesAutomatically - - self withChangesFileDo: [ :aChangesFile | self restoreLostChangesAutomaticallyFrom: aChangesFile ]! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 10:15:16'! - restoreLostChangesAutomaticallyFrom: aChangesFile - - | changeList | - - changeList := ChangeListWithFileInErrors new. - changeList scanFile: aChangesFile from: LastQuitLogPosition to: aChangesFile size. - changeList fileInAllKeepingErrors. - (changeList hasFileInErrors and: [ self shouldShowFileInErrors ]) ifTrue: [ changeList showChangesWithFileInErrors ] -! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:09:39'! - restoreLostChangesIfNecessary - - " - Smalltalk restoreLostChangesIfNecessary - " - - self hasToRestoreChanges ifTrue: [ WorldState addDeferredUIMessage: [self restoreLostChanges ]]. -! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/1/2017 17:28:22'! - restoreLostChangesManually - - ChangeList browseRecentLog! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:25:55'! - restoreLostChangesOptions - - ^{'Restore lost changes automatically'. 'Restore lost changes manually'. 'Nothing'}.! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:29:46'! - restoringChangesHasErrorsCaption - - ^'There were errors filing in the lost changes. Do you want to see them?'! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 09:37:34'! - shouldShowFileInErrors - - ^self confirm: self restoringChangesHasErrorsCaption - ! ! -!SystemDictionary methodsFor: 'startup - restore lost changes' stamp: 'HAW 9/4/2017 06:11:39'! - withChangesFileDo: aBlock - - ^self currentChangesName asFileEntry readStreamDo: aBlock! ! -!ChangeRecord methodsFor: 'testing' stamp: 'HAW 9/4/2017 06:32:29'! - isDoIt - - ^type = #doIt! ! -!ChangeList methodsFor: 'menu actions' stamp: 'HAW 9/4/2017 10:26:32' prior: 16796254! - removeDoIts - "Remove doits from the receiver, other than initializes. 1/26/96 sw" - - | newChangeList newList | - newChangeList _ OrderedCollection new. - newList _ OrderedCollection new. - - changeList with: list do: [ :chRec :str | - (chRec isDoIt not or: [str endsWith: 'initialize']) - ifTrue: [ - newChangeList add: chRec. - newList add: str]]. - newChangeList size < changeList size - ifTrue: [ - changeList _ newChangeList. - list _ newList. - listIndex _ 0. - self clearSelections ]. - self changed: #list. - - ! ! -!ChangeList methodsFor: 'menu actions' stamp: 'HAW 9/4/2017 10:26:50' prior: 16796515! - selectRemovalsOfSent - "Selects all method removal for sent methods" - - 1 to: changeList size do: [ :i | | change | - change _ changeList at: i. - listSelections at: i put: - (change isDoIt and: [ - change string includesSubString: 'removeSelector: #' ] and: [ - Smalltalk isThereAReferenceTo: (change string copyAfterLast: $#) asSymbol ]) ]. - self changed: #allSelections. - self changed: #annotation! ! -!ChangeList class methodsFor: 'public access' stamp: 'HAW 9/4/2017 10:32:00' prior: 16796892! - browseRecentLogOn: origChangesFileName - "figure out where the last snapshot or quit was, then browse the recent entries." - - | end done block positions prevBlock | - origChangesFileName asFileEntry readStreamDo: [ :changesFile | - positions _ SortedCollection new. - end _ changesFile size. - prevBlock _ end. - block _ end - 1024 max: 0. - done _ false. - [ done or: [ positions size > 0 ]] - whileFalse: [ - changesFile position: block. - "ignore first fragment" - changesFile nextChunk. - [ changesFile position < prevBlock ] - whileTrue: [ - | pos chunk | - pos _ changesFile position. - chunk _ changesFile nextChunk. - ((Smalltalk isQuitRecord: chunk) or: [ Smalltalk isSnapshotRecord: chunk ]) - ifTrue: [ positions add: pos ]]. - block = 0 - ifTrue: [done _ true] - ifFalse: [ - prevBlock _ block. - block _ block - 1024 max: 0]]. - ]. - positions isEmpty - ifTrue: [self inform: 'File ' , origChangesFileName , ' does not appear to be a changes file'] - ifFalse: [self browseRecentLogOn: origChangesFileName startingFrom: positions last]! ! -!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'HAW 9/4/2017 08:46:37' prior: 50361384! - snapshot: save andQuit: quit embedded: embeddedFlag clearAllClassState: clearAllStateFlag -"WARNING: Current process will be killed. -UI Process will be restarted -" - "Mark the changes file and close all files as part of #processShutdownList. - If save is true, save the current state of this Smalltalk in the image file. - If quit is true, then exit to the outer OS shell. - The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." - " - To test the full cleanup and startup procedures, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: true - - To test the cleanup done when saving the image, evaluate: - Smalltalk snapshot: false andQuit: false embedded: false clearAllClassState: false - " -| activeProc | -activeProc _ Processor activeProcess. -[ - | isARealStartup world reopenTranscript | - self logSnapshot: save andQuit: quit. - - reopenTranscript _ false. - clearAllStateFlag ifTrue: [ - TranscriptWindow allInstancesDo: [ :each | each isInWorld ifTrue: [ each delete. reopenTranscript _ true ]]. - Transcript logToFile: false ]. - ActiveModel flushEventSystem. - self processShutDownList: quit. - - - "Lo que sigue aca podria ir al shutdown de alguien... (se levantan en startup!!)" - Smalltalk stopLowSpaceWatcher. - WeakArray stopFinalizationProcess. - ProcessorScheduler stopBackgroundProcess. - - "Cosas que levanto explicitamente abajo" - world _ ProjectX ui. - "Replace with this to create a new world at startup after 'saveAsNewVersion'" - "world _ clearAllStateFlag ifFalse: [ ProjectX ui ]." - ProjectX stopUIProcess. - activeProc isTerminated ifFalse: [ - activeProc terminate ]. - - "Clean Globals" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: nil. - Smalltalk closeSourceFiles. Smalltalk at: #SourceFiles put: nil. - Smalltalk allClassesDo: [ :cls | cls releaseClassCachedState ]. - clearAllStateFlag ifTrue: [ - Smalltalk allClassesDo: [ :cls | cls releaseClassState ]]. - "Ojo con los pool dicts. Creo que no hay ninguno..." - - "To keep cleaning stuff that shouldn't be saved..." - clearAllStateFlag ifTrue: [ Smalltalk printStuffToCleanOnImageSave ]. - - - "Do image save & quit as apropriate" - Cursor write activateCursor. - save - ifTrue: [ - isARealStartup _ embeddedFlag - ifTrue: [ self snapshotEmbeddedPrimitive ] - ifFalse: [ self snapshotPrimitive ]] - ifFalse: [ isARealStartup _ false ]. - quit & (isARealStartup == false) ifTrue: [ self quitPrimitive ]. - - - "If starting from absolute scratch, this would be a good time to recreate Global names" - Smalltalk at: #Sensor put: nil. - Smalltalk at: #Display put: (DisplayScreen extent: `1024@768` depth: 32). - Smalltalk at: #SourceFiles put: (Array new: 2). - Smalltalk openSourceFiles. - - "Here, startup begins!! (isARealStartup might be nil)" - Smalltalk allClassesDo: [ :cls | cls initClassCachedState ]. - self doStartUp: isARealStartup == true. - - - ProjectX spawnNewMorphicProcessFor: (world ifNil: [ PasteUpMorph newWorld ]). - - reopenTranscript ifTrue: [ - WorldState addDeferredUIMessage: [ - TranscriptWindow openTranscript ]]. - " - WorldState addDeferredUIMessage: [ - world fullRepaintNeeded ]. - " - - "If system is coming up (VM and image just started)" - isARealStartup == true ifTrue: [ - WorldState addDeferredUIMessage: [ - self processCommandLineArguments. - AppLauncher launchApp ]]. - - "Now it's time to raise an error" - isARealStartup ifNil: [ self error: 'Failed to write image file (disk full?)' ]. - -] forkAt: Processor timingPriority-1 named: 'Startup process'.! ! -!SystemDictionary methodsFor: 'startup' stamp: 'HAW 9/4/2017 06:14:44' prior: 50335335! - doStartUp: isARealStartup - " - isARealStartup - true: system is coming up (VM and image just started) - false: we have just saved an image snapshot, but didn't quit. - " - - "Here, startup begins!!" - Cursor normal activateCursor. - self setGCParameters. - isARealStartup ifTrue: [ - self clearExternalObjects ]. - self readCommandLineArguments. - self processStartUpList: isARealStartup. - isARealStartup ifTrue: [ - self setPlatformPreferences. - self setStartupStamp. - self restoreLostChangesIfNecessary ]! ! -!ChangeRecord methodsFor: 'initialization' stamp: 'HAW 9/4/2017 10:27:15' prior: 16797438! - fileIn - "File the receiver in. If I represent a method or a class-comment, file the method in and make a note of it in the recent-submissions list; if I represent a do-it, then, well, do it." - | s | - type == #method ifTrue: [ - self changeClass ifNotNil: [ :methodClass | - methodClass - compile: self text - classified: category - withStamp: stamp - notifying: nil ]]. - self isDoIt ifTrue: [ - ((s _ self string) beginsWith: '----') ifFalse: [ Compiler evaluate: s ]]. - type == #classDefinition ifTrue: [ Compiler evaluate: self string ]. - type == #classComment ifTrue: [ - (Smalltalk at: class asSymbol) - comment: self text - stamp: stamp ]! ! - -SystemDictionary removeSelector: #logSapshot:andQuit:! - -SystemDictionary removeSelector: #logSapshot:andQuit:! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/CoreUpdates/3168-AidInRecoveringChanges-HernanWilkinson-2017Sep01-13h49m-HAW.1.cs.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3153] on 25 August 2017 at 12:08:17 pm'! - -'Description Please enter a description for this package '! - -SharedPool subclass: #GZipConstants - instanceVariableNames: '' - classVariableNames: 'GZipAsciiFlag GZipCommentFlag GZipContinueFlag GZipDeflated GZipEncryptFlag GZipExtraField GZipMagic GZipNameFlag GZipReservedFlags' - poolDictionaries: '' - category: 'Compression-System'! - -!classDefinition: #GZipConstants category: #'Compression-System'! -SharedPool subclass: #GZipConstants - instanceVariableNames: '' - classVariableNames: 'GZipAsciiFlag GZipCommentFlag GZipContinueFlag GZipDeflated GZipEncryptFlag GZipExtraField GZipMagic GZipNameFlag GZipReservedFlags' - poolDictionaries: '' - category: 'Compression-System'! - -GZipConstants class - instanceVariableNames: ''! - -!classDefinition: 'GZipConstants class' category: #'Compression-System'! -GZipConstants class - instanceVariableNames: ''! - -SharedPool subclass: #ZipConstants - instanceVariableNames: '' - classVariableNames: 'BaseDistance BaseLength BitLengthOrder DistanceCodes DynamicBlock EndBlock ExtraBitLengthBits ExtraDistanceBits ExtraLengthBits FixedBlock FixedDistanceTree FixedLiteralTree HashBits HashMask HashShift MatchLengthCodes MaxBitLengthBits MaxBitLengthCodes MaxBits MaxDistCodes MaxDistance MaxLengthCodes MaxLiteralCodes MaxMatch MinMatch NumLiterals Repeat11To138 Repeat3To10 Repeat3To6 StoredBlock WindowMask WindowSize' - poolDictionaries: '' - category: 'Compression-System'! - -!classDefinition: #ZipConstants category: #'Compression-System'! -SharedPool subclass: #ZipConstants - instanceVariableNames: '' - classVariableNames: 'BaseDistance BaseLength BitLengthOrder DistanceCodes DynamicBlock EndBlock ExtraBitLengthBits ExtraDistanceBits ExtraLengthBits FixedBlock FixedDistanceTree FixedLiteralTree HashBits HashMask HashShift MatchLengthCodes MaxBitLengthBits MaxBitLengthCodes MaxBits MaxDistCodes MaxDistance MaxLengthCodes MaxLiteralCodes MaxMatch MinMatch NumLiterals Repeat11To138 Repeat3To10 Repeat3To6 StoredBlock WindowMask WindowSize' - poolDictionaries: '' - category: 'Compression-System'! - -ZipConstants class - instanceVariableNames: ''! - -!classDefinition: 'ZipConstants class' category: #'Compression-System'! -ZipConstants class - instanceVariableNames: ''! - -SharedPool subclass: #ZipFileConstants - instanceVariableNames: '' - classVariableNames: 'CentralDirectoryFileHeaderSignature CompressionDeflated CompressionLevelDefault CompressionLevelNone CompressionStored DataDescriptorLength DefaultDirectoryPermissions DefaultFilePermissions DeflatingCompressionFast DeflatingCompressionMaximum DeflatingCompressionNormal DeflatingCompressionSuperFast DirectoryAttrib EndOfCentralDirectorySignature FaMsdos FaUnix FileAttrib IfaBinaryFile IfaTextFile LocalFileHeaderSignature' - poolDictionaries: '' - category: 'Compression-Archives'! - -!classDefinition: #ZipFileConstants category: #'Compression-Archives'! -SharedPool subclass: #ZipFileConstants - instanceVariableNames: '' - classVariableNames: 'CentralDirectoryFileHeaderSignature CompressionDeflated CompressionLevelDefault CompressionLevelNone CompressionStored DataDescriptorLength DefaultDirectoryPermissions DefaultFilePermissions DeflatingCompressionFast DeflatingCompressionMaximum DeflatingCompressionNormal DeflatingCompressionSuperFast DirectoryAttrib EndOfCentralDirectorySignature FaMsdos FaUnix FileAttrib IfaBinaryFile IfaTextFile LocalFileHeaderSignature' - poolDictionaries: '' - category: 'Compression-Archives'! - -ZipFileConstants class - instanceVariableNames: ''! - -!classDefinition: 'ZipFileConstants class' category: #'Compression-Archives'! -ZipFileConstants class - instanceVariableNames: ''! - -ReadStream subclass: #InflateStream - instanceVariableNames: 'state bitBuf bitPos source sourcePos sourceLimit litTable distTable sourceStream crc' - classVariableNames: 'BlockProceedBit BlockTypes FixedDistCodes FixedLitCodes MaxBits StateNewBlock StateNoMoreData' - poolDictionaries: '' - category: 'Compression-System'! - -!classDefinition: #InflateStream category: #'Compression-System'! -ReadStream subclass: #InflateStream - instanceVariableNames: 'state bitBuf bitPos source sourcePos sourceLimit litTable distTable sourceStream crc' - classVariableNames: 'BlockProceedBit BlockTypes FixedDistCodes FixedLitCodes MaxBits StateNewBlock StateNoMoreData' - poolDictionaries: '' - category: 'Compression-System'! - -InflateStream class - instanceVariableNames: ''! - -!classDefinition: 'InflateStream class' category: #'Compression-System'! -InflateStream class - instanceVariableNames: ''! - -InflateStream subclass: #FastInflateStream - instanceVariableNames: '' - classVariableNames: 'DistanceMap FixedDistTable FixedLitTable LiteralLengthMap' - poolDictionaries: '' - category: 'Compression-System'! - -!classDefinition: #FastInflateStream category: #'Compression-System'! -InflateStream subclass: #FastInflateStream - instanceVariableNames: '' - classVariableNames: 'DistanceMap FixedDistTable FixedLitTable LiteralLengthMap' - poolDictionaries: '' - category: 'Compression-System'! - -FastInflateStream class - instanceVariableNames: ''! - -!classDefinition: 'FastInflateStream class' category: #'Compression-System'! -FastInflateStream class - instanceVariableNames: ''! - -FastInflateStream subclass: #GZipReadStream - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: 'GZipConstants' - category: 'Compression-System'! - -!classDefinition: #GZipReadStream category: #'Compression-System'! -FastInflateStream subclass: #GZipReadStream - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: 'GZipConstants' - category: 'Compression-System'! - -GZipReadStream class - instanceVariableNames: ''! - -!classDefinition: 'GZipReadStream class' category: #'Compression-System'! -GZipReadStream class - instanceVariableNames: ''! - -FastInflateStream subclass: #ZLibReadStream - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Compression-System'! - -!classDefinition: #ZLibReadStream category: #'Compression-System'! -FastInflateStream subclass: #ZLibReadStream - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Compression-System'! - -ZLibReadStream class - instanceVariableNames: ''! - -!classDefinition: 'ZLibReadStream class' category: #'Compression-System'! -ZLibReadStream class - instanceVariableNames: ''! - -FastInflateStream subclass: #ZipReadStream - instanceVariableNames: 'expectedCrc' - classVariableNames: '' - poolDictionaries: '' - category: 'Compression-System'! - -!classDefinition: #ZipReadStream category: #'Compression-System'! -FastInflateStream subclass: #ZipReadStream - instanceVariableNames: 'expectedCrc' - classVariableNames: '' - poolDictionaries: '' - category: 'Compression-System'! - -ZipReadStream class - instanceVariableNames: ''! - -!classDefinition: 'ZipReadStream class' category: #'Compression-System'! -ZipReadStream class - instanceVariableNames: ''! - -WriteStream subclass: #DeflateStream - instanceVariableNames: 'hashHead hashTail hashValue blockPosition blockStart' - classVariableNames: '' - poolDictionaries: 'ZipConstants' - category: 'Compression-System'! - -!classDefinition: #DeflateStream category: #'Compression-System'! -WriteStream subclass: #DeflateStream - instanceVariableNames: 'hashHead hashTail hashValue blockPosition blockStart' - classVariableNames: '' - poolDictionaries: 'ZipConstants' - category: 'Compression-System'! - -DeflateStream class - instanceVariableNames: ''! - -!classDefinition: 'DeflateStream class' category: #'Compression-System'! -DeflateStream class - instanceVariableNames: ''! - -DeflateStream subclass: #ZipWriteStream - instanceVariableNames: 'literals distances literalFreq distanceFreq litCount matchCount encoder crc crcPosition bytesWritten' - classVariableNames: 'CrcTable VerboseLevel' - poolDictionaries: 'ZipConstants' - category: 'Compression-System'! - -!classDefinition: #ZipWriteStream category: #'Compression-System'! -DeflateStream subclass: #ZipWriteStream - instanceVariableNames: 'literals distances literalFreq distanceFreq litCount matchCount encoder crc crcPosition bytesWritten' - classVariableNames: 'CrcTable VerboseLevel' - poolDictionaries: 'ZipConstants' - category: 'Compression-System'! - -ZipWriteStream class - instanceVariableNames: ''! - -!classDefinition: 'ZipWriteStream class' category: #'Compression-System'! -ZipWriteStream class - instanceVariableNames: ''! - -ZipWriteStream subclass: #GZipWriteStream - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: 'GZipConstants' - category: 'Compression-System'! - -!classDefinition: #GZipWriteStream category: #'Compression-System'! -ZipWriteStream subclass: #GZipWriteStream - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: 'GZipConstants' - category: 'Compression-System'! - -GZipWriteStream class - instanceVariableNames: ''! - -!classDefinition: 'GZipWriteStream class' category: #'Compression-System'! -GZipWriteStream class - instanceVariableNames: ''! - -ZipWriteStream subclass: #ZLibWriteStream - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Compression-System'! - -!classDefinition: #ZLibWriteStream category: #'Compression-System'! -ZipWriteStream subclass: #ZLibWriteStream - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Compression-System'! - -ZLibWriteStream class - instanceVariableNames: ''! - -!classDefinition: 'ZLibWriteStream class' category: #'Compression-System'! -ZLibWriteStream class - instanceVariableNames: ''! - -WriteStream subclass: #ZipEncoder - instanceVariableNames: 'bitBuffer bitPosition encodedStream' - classVariableNames: '' - poolDictionaries: 'ZipConstants' - category: 'Compression-System'! - -!classDefinition: #ZipEncoder category: #'Compression-System'! -WriteStream subclass: #ZipEncoder - instanceVariableNames: 'bitBuffer bitPosition encodedStream' - classVariableNames: '' - poolDictionaries: 'ZipConstants' - category: 'Compression-System'! - -ZipEncoder class - instanceVariableNames: ''! - -!classDefinition: 'ZipEncoder class' category: #'Compression-System'! -ZipEncoder class - instanceVariableNames: ''! - -Error subclass: #CRCError - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Compression-System'! - -!classDefinition: #CRCError category: #'Compression-System'! -Error subclass: #CRCError - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Compression-System'! - -CRCError class - instanceVariableNames: ''! - -!classDefinition: 'CRCError class' category: #'Compression-System'! -CRCError class - instanceVariableNames: ''! - -Object subclass: #GZipSurrogateStream - instanceVariableNames: 'gZipStream zippedFileStream bufferStream positionThusFar' - classVariableNames: '' - poolDictionaries: '' - category: 'Compression-System'! - -!classDefinition: #GZipSurrogateStream category: #'Compression-System'! -Object subclass: #GZipSurrogateStream - instanceVariableNames: 'gZipStream zippedFileStream bufferStream positionThusFar' - classVariableNames: '' - poolDictionaries: '' - category: 'Compression-System'! - -GZipSurrogateStream class - instanceVariableNames: ''! - -!classDefinition: 'GZipSurrogateStream class' category: #'Compression-System'! -GZipSurrogateStream class - instanceVariableNames: ''! - -Object subclass: #ZipEncoderNode - instanceVariableNames: 'value frequency height bitLength code parent left right' - classVariableNames: '' - poolDictionaries: '' - category: 'Compression-System'! - -!classDefinition: #ZipEncoderNode category: #'Compression-System'! -Object subclass: #ZipEncoderNode - instanceVariableNames: 'value frequency height bitLength code parent left right' - classVariableNames: '' - poolDictionaries: '' - category: 'Compression-System'! - -ZipEncoderNode class - instanceVariableNames: ''! - -!classDefinition: 'ZipEncoderNode class' category: #'Compression-System'! -ZipEncoderNode class - instanceVariableNames: ''! - -Object subclass: #ZipEncoderTree - instanceVariableNames: 'bitLengths codes maxCode' - classVariableNames: '' - poolDictionaries: '' - category: 'Compression-System'! - -!classDefinition: #ZipEncoderTree category: #'Compression-System'! -Object subclass: #ZipEncoderTree - instanceVariableNames: 'bitLengths codes maxCode' - classVariableNames: '' - poolDictionaries: '' - category: 'Compression-System'! - -ZipEncoderTree class - instanceVariableNames: ''! - -!classDefinition: 'ZipEncoderTree class' category: #'Compression-System'! -ZipEncoderTree class - instanceVariableNames: ''! - -Object subclass: #Archive - instanceVariableNames: 'members' - classVariableNames: '' - poolDictionaries: '' - category: 'Compression-Archives'! - -!classDefinition: #Archive category: #'Compression-Archives'! -Object subclass: #Archive - instanceVariableNames: 'members' - classVariableNames: '' - poolDictionaries: '' - category: 'Compression-Archives'! - -Archive class - instanceVariableNames: ''! - -!classDefinition: 'Archive class' category: #'Compression-Archives'! -Archive class - instanceVariableNames: ''! - -Archive subclass: #ZipArchive - instanceVariableNames: 'centralDirectorySize centralDirectoryOffsetWRTStartingDiskNumber zipFileComment writeCentralDirectoryOffset writeEOCDOffset' - classVariableNames: '' - poolDictionaries: 'ZipFileConstants' - category: 'Compression-Archives'! - -!classDefinition: #ZipArchive category: #'Compression-Archives'! -Archive subclass: #ZipArchive - instanceVariableNames: 'centralDirectorySize centralDirectoryOffsetWRTStartingDiskNumber zipFileComment writeCentralDirectoryOffset writeEOCDOffset' - classVariableNames: '' - poolDictionaries: 'ZipFileConstants' - category: 'Compression-Archives'! - -ZipArchive class - instanceVariableNames: ''! - -!classDefinition: 'ZipArchive class' category: #'Compression-Archives'! -ZipArchive class - instanceVariableNames: ''! - -Object subclass: #ArchiveMember - instanceVariableNames: 'fileName isCorrupt' - classVariableNames: '' - poolDictionaries: '' - category: 'Compression-Archives'! - -!classDefinition: #ArchiveMember category: #'Compression-Archives'! -Object subclass: #ArchiveMember - instanceVariableNames: 'fileName isCorrupt' - classVariableNames: '' - poolDictionaries: '' - category: 'Compression-Archives'! - -ArchiveMember class - instanceVariableNames: ''! - -!classDefinition: 'ArchiveMember class' category: #'Compression-Archives'! -ArchiveMember class - instanceVariableNames: ''! - -ArchiveMember subclass: #ZipArchiveMember - instanceVariableNames: 'lastModFileDateTime fileAttributeFormat versionMadeBy versionNeededToExtract bitFlag compressionMethod desiredCompressionMethod desiredCompressionLevel internalFileAttributes externalFileAttributes cdExtraField localExtraField fileComment crc32 compressedSize uncompressedSize writeLocalHeaderRelativeOffset readDataRemaining' - classVariableNames: '' - poolDictionaries: 'ZipFileConstants' - category: 'Compression-Archives'! - -!classDefinition: #ZipArchiveMember category: #'Compression-Archives'! -ArchiveMember subclass: #ZipArchiveMember - instanceVariableNames: 'lastModFileDateTime fileAttributeFormat versionMadeBy versionNeededToExtract bitFlag compressionMethod desiredCompressionMethod desiredCompressionLevel internalFileAttributes externalFileAttributes cdExtraField localExtraField fileComment crc32 compressedSize uncompressedSize writeLocalHeaderRelativeOffset readDataRemaining' - classVariableNames: '' - poolDictionaries: 'ZipFileConstants' - category: 'Compression-Archives'! - -ZipArchiveMember class - instanceVariableNames: ''! - -!classDefinition: 'ZipArchiveMember class' category: #'Compression-Archives'! -ZipArchiveMember class - instanceVariableNames: ''! - -ZipArchiveMember subclass: #ZipFileMember - instanceVariableNames: 'externalFileName stream localHeaderRelativeOffset dataOffset' - classVariableNames: '' - poolDictionaries: '' - category: 'Compression-Archives'! - -!classDefinition: #ZipFileMember category: #'Compression-Archives'! -ZipArchiveMember subclass: #ZipFileMember - instanceVariableNames: 'externalFileName stream localHeaderRelativeOffset dataOffset' - classVariableNames: '' - poolDictionaries: '' - category: 'Compression-Archives'! - -ZipFileMember class - instanceVariableNames: ''! - -!classDefinition: 'ZipFileMember class' category: #'Compression-Archives'! -ZipFileMember class - instanceVariableNames: ''! - -ZipFileMember subclass: #ZipDirectoryMember - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Compression-Archives'! - -!classDefinition: #ZipDirectoryMember category: #'Compression-Archives'! -ZipFileMember subclass: #ZipDirectoryMember - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Compression-Archives'! - -ZipDirectoryMember class - instanceVariableNames: ''! - -!classDefinition: 'ZipDirectoryMember class' category: #'Compression-Archives'! -ZipDirectoryMember class - instanceVariableNames: ''! - -ZipArchiveMember subclass: #ZipNewFileMember - instanceVariableNames: 'externalFileName stream' - classVariableNames: '' - poolDictionaries: '' - category: 'Compression-Archives'! - -!classDefinition: #ZipNewFileMember category: #'Compression-Archives'! -ZipArchiveMember subclass: #ZipNewFileMember - instanceVariableNames: 'externalFileName stream' - classVariableNames: '' - poolDictionaries: '' - category: 'Compression-Archives'! - -ZipNewFileMember class - instanceVariableNames: ''! - -!classDefinition: 'ZipNewFileMember class' category: #'Compression-Archives'! -ZipNewFileMember class - instanceVariableNames: ''! - -ZipArchiveMember subclass: #ZipStringMember - instanceVariableNames: 'contents stream' - classVariableNames: '' - poolDictionaries: '' - category: 'Compression-Archives'! - -!classDefinition: #ZipStringMember category: #'Compression-Archives'! -ZipArchiveMember subclass: #ZipStringMember - instanceVariableNames: 'contents stream' - classVariableNames: '' - poolDictionaries: '' - category: 'Compression-Archives'! - -ZipStringMember class - instanceVariableNames: ''! - -!classDefinition: 'ZipStringMember class' category: #'Compression-Archives'! -ZipStringMember class - instanceVariableNames: ''! -!InflateStream commentStamp: '' prior: 0! - This class implements the Inflate decompression algorithm as defined by RFC1951 and used in PKZip, GZip and ZLib (and many, many more). It is a variant of the LZ77 compression algorithm described in - -[LZ77] Ziv J., Lempel A., "A Universal Algorithm for Sequential Data Compression", IEEE Transactions on Information Theory", Vol. 23, No. 3, pp. 337-343. - -[RFC1951] Deutsch. P, "DEFLATE Compressed Data Format Specification version 1.3" - -For more information see the above mentioned RFC 1951 which can for instance be found at - - http://www.leo.org/pub/comp/doc/standards/rfc/index.html - -Huffman Tree Implementation Notes: -=========================================== -The huffman tree used for decoding literal, distance and length codes in the inflate algorithm has been encoded in a single Array. The tree is made up of subsequent tables storing all entries at the current bit depth. Each entry in the table (e.g., a 32bit Integer value) is either a leaf or a non-leaf node. Leaf nodes store the immediate value in its low 16 bits whereas non-leaf nodes store the offset of the subtable in its low 16bits. The high 8 bits of non-leaf nodes contain the number of additional bits needed for the sub table (the high 8 bits of leaf-nodes are always zero). The first entry in each table is always a non-leaf node indicating how many bits we need to fetch initially. We can thus travel down the tree as follows (written in sort-of-pseudocode the actual implementation can be seen in InflateStream>>decodeValueFrom:): - - table _ initialTable. - bitsNeeded _ high 8 bits of (table at: 1). "Determine initial bits" - table _ initialTable + (low 16 bits of (table at: 1)). "Determine start of first real table" - [bits _ fetch next bitsNeeded bits. "Grab the bits" - value _ table at: bits. "Lookup the value" - value has high 8 bit set] whileTrue:[ "Check if it's leaf" - table _ initialTable + (low 16 bits of value). "No - compute new sub table start" - bitsNeeded _ high 8 bit of value]. "Compute additional number of bits needed" - ^value -! -!FastInflateStream commentStamp: '' prior: 0! - This class adds the following optimizations to the basic Inflate decompression: - -a) Bit reversed access -If we want to fetch the bits efficiently then we have them in the wrong bit order (e.g., when we should fetch 2r100 we would get 2r001). But since the huffman tree lookup determines the efficiency of the decompression, reversing the bits before traversal is expensive. Therefore the entries in each table are stored in REVERSE BIT ORDER. This is achieved by a reverse increment of the current table index in the huffman table construction phase (see method increment:bits:). According to my measures this speeds up the implementation by about 30-40%. - -b) Inplace storage of code meanings and extra bits -Rather than looking up the meaning for each code during decompression of blocks we store the appropriate values directly in the huffman tables, using a pre-defined mapping. Even though this does not make a big difference in speed, it cleans up the code and allows easier translation into primitive code (which is clearly one goal of this implementation). - -c) Precomputed huffman tables for fixed blocks -So we don't have to compute the huffman tables from scratch. The precomputed tables are not in our superclass to avoid double storage (and my superclass is more intended for documentation anyways).! -!ZipReadStream commentStamp: 'nk 3/7/2004 18:54' prior: 0! - ZipReadStream is intended for uncompressing the compressed contents of Zip archive members. - -Since Zip archive members keep their expected CRC value separately in Zip headers, this class does not attempt to read the CRC from its input stream. - -Instead, if you want the CRC verification to work you have to call #expectedCrc: with the expected CRC-32 value from the Zip member header.! -!GZipSurrogateStream commentStamp: 'jmv 6/17/2015 11:47' prior: 0! - A pseudo stream that allows SmartRefStream to write directly to a gzipped file. There are some peculiarities of the project exporting process that require: - -1. We ignore #close since the file is closed and may be reopened to continue writing. We implement #reallyClose for when we know that all writing is over. - -2. We use a BitBlt to write WordArrayForSegment objects. Bit of a hack, but there it is. - -| fileStream wa | - -wa _ WordArrayForSegment new: 30000. -1 to: wa size do: [ :i | wa at: i put: i]. -fileStream _ GZipSurrogateStream newFileNamed: 'xxx3.gz' inDirectory: FileDirectory smalltalkImageDirectory. -fileStream nextPutAll: 'this is a test'. -fileStream nextPutAll: wa. -fileStream reallyClose. -! -!ZipEncoderNode commentStamp: '' prior: 0! - ZipEncoderNode represents a node in a huffman tree for encoding ZipStreams. - -Instance variables: - value - Encoded value - frequency - Number of occurences of the encoded value - height - Height of the node in the tree - bitLength - bit length of the code - code - Assigned code for this node - parent - Parent of this node - left - First child of this node - right - Second child of this node -! -!ZipEncoderTree commentStamp: '' prior: 0! - ZipEncoderTree represents a huffman tree for encoding ZipStreams. - -Instance variables: - bitLengths - Bit lengths of each generated code - codes - Codes for each value - maxCode - Maximum value with non-zero frequency! -!Archive commentStamp: '' prior: 0! - This is the abstract superclass for file archives. Archives can be read from or written to files, and contain members that represent files and directories.! -!ZipArchive commentStamp: '' prior: 0! - A ZipArchive represents an archive that is read and/or written using the PKZIP file format. - -ZipArchive instances know how to read and write such archives; their members are subinstances of ZipArchiveMember.! -!ArchiveMember commentStamp: '' prior: 0! - This is the abstract superclass for archive members, which are files or directories stored in archives.! -!ZipArchiveMember commentStamp: '' prior: 0! - Subinstances of me are members in a ZipArchive. -They represent different data sources: - * ZipDirectoryMember -- a directory to be added to a zip file - * ZipFileMember -- a file or directory that is already in a zip file - * ZipNewFilemember -- a file that is to be added to a zip file - * ZipStringMember -- a string that is to be added to a zip file - -They can write their data to another stream either copying, compressing, -or decompressing as desired.! -!ZipFileMember commentStamp: '' prior: 0! - ZipNewFileMember instances are used to represent files that have been read from a ZipArchive. -Their data stays in the file on disk, so the original Zip file cannot be directly overwritten.! -!ZipDirectoryMember commentStamp: '' prior: 0! - ZipFileMember instances represent directories inside ZipArchives. -They don't do much other than hold names and permissions (and extra fields). - -You can add files in subdirectories to a ZipArchive without using any ZipDirectoryMembers.! -!ZipNewFileMember commentStamp: '' prior: 0! - ZipNewFileMember instances are used to represent files that are going to be written to a ZipArchive. -Their data comes from external file streams.! -!ZipStringMember commentStamp: '' prior: 0! - ZipStringMember instances are used to represent files that are going to be written to a ZipArchive. -Their data comes from in-image strings, though.! -!CodeFileBrowser class methodsFor: '*Compression' stamp: 'jmv 10/2/2015 16:55'! - browseMCZCode: aFileEntry - "Browse the selected file." - - CodeFileBrowserWindow browseMCZFile: aFileEntry! ! -!CodeFileBrowser class methodsFor: '*Compression' stamp: 'jmv 7/5/2016 12:29'! - serviceBrowseMCZCode - "Answer a service for opening a changelist browser on a file" - - ^ (SimpleServiceEntry - provider: self - label: 'code file browser' - selector: #browseMCZCode: - description: 'open a "file-contents browser" on this file, allowing you to view and selectively load its code' - buttonLabel: 'code') - argumentGetter: [ :fileList | - fileList selectedFileEntry ]! ! -!ChangeList class methodsFor: '*Compression' stamp: 'pb 5/25/2016 01:31'! - browseMCZContents: aFileEntry - "Browse the selected file." - | unzipped changeList fullName packageFile pkName | - - "For Monticello packages we do as we do with our own .pck.st files: Instead of just browsing - contents, also include what is no longer part of the package (and should therefore be removed on install) - See #browsePackageContents: - However, this was never tested to run!!" - self flag: #jmvVer. - - fullName _ aFileEntry pathName. - pkName _ CodePackageFile monticelloPackageNameFrom: fullName. - aFileEntry readStreamDo: [ :stream | - unzipped _ stream asUnZippedStream: 'snapshot/source.st'. - unzipped ascii. - changeList _ self new scanFile: unzipped from: 0 to: unzipped size. - stream reset. - packageFile _ CodePackageFile - buildFileStream: unzipped - packageName: pkName - fullName: fullName. - ]. - "Add deletions of methods and classes that are in the CodePackage (i.e., active in the system) - but are no longer in the CodePackageFile being viewed." - packageFile methodsToRemove do: [ :methodReference | - changeList - addItem: (MethodDeletionChangeRecord new methodReference: methodReference) - text: 'method no longer in package: ', methodReference stringVersion ]. - packageFile classesToRemove do: [ :clsName | - changeList - addItem: (ClassDeletionChangeRecord new clsName: clsName) - text: 'class no longer in package: ', clsName ]. - changeList clearSelections. - ChangeListWindow open: changeList label: aFileEntry pathName! ! -!ChangeList class methodsFor: '*Compression' stamp: 'jmv 10/2/2015 16:51'! - serviceMCZContents - "Answer a service for opening a changelist browser on a file" - - ^ (SimpleServiceEntry - provider: self - label: 'code file contents' - selector: #browseMCZContents: - description: 'open a code file contents tool on this file' - buttonLabel: 'contents') - argumentGetter: [ :fileList | - fileList selectedFileEntry ]! ! -!FileList methodsFor: '*Compression' stamp: 'pb 5/25/2016 01:50'! - compressFile - "Compress the currently selected file" - - self fullName asFileEntry readStream - compressFile. - self updateFileList! ! -!FileList methodsFor: '*Compression' stamp: 'jmv 6/10/2013 20:41'! - serviceCompressFile - "Answer a service for compressing a file" - - ^ SimpleServiceEntry - provider: self - label: 'compress' - selector: #compressFile - description: 'compress file' - buttonLabel: 'compress'! ! -!ArrayedCollection methodsFor: '*Compression' stamp: 'tk 3/7/2001 18:07'! - writeOnGZIPByteStream: aStream - "We only intend this for non-pointer arrays. Do nothing if I contain pointers." - - self class isPointers | self class isWords not ifTrue: [^ super writeOnGZIPByteStream: aStream]. - "super may cause an error, but will not be called." - - aStream nextPutAllWordArray: self! ! -!String methodsFor: '*Compression' stamp: 'jmv 9/5/2016 22:13:54'! - unzipped - | magic1 magic2 | - magic1 _ (self at: 1) numericValue. - magic2 _ (self at: 2) numericValue. - (magic1 = 16r1F and:[magic2 = 16r8B]) ifFalse: [ ^self ]. - ^ (GZipReadStream on: self) upToEnd! ! -!PositionableStream methodsFor: '*Compression' stamp: 'jmv 6/10/2013 20:40'! - asZLibReadStream - ^ ZLibReadStream on: collection from: position+1 to: readLimit! ! -!ReadWriteStream methodsFor: '*Compression' stamp: 'jmv 6/10/2013 20:39'! - asUnZippedStream - | isGZip outputStream first strm | - "Decompress this file if needed, and return a stream. No file is written. File extension may be .gz or anything else." - - strm _ self binary. - - first _ strm next. - isGZip _ (strm next * 256 + first) = (GZipConstants gzipMagic). - strm skip: -2. - isGZip - ifTrue: [ outputStream _ (RWBinaryOrTextStream with: - (GZipReadStream on: strm) upToEnd) reset. - strm close] - ifFalse: [ outputStream _ strm]. - ^ outputStream! ! -!ReadWriteStream methodsFor: '*Compression' stamp: 'jmv 6/10/2013 20:40'! - asUnZippedStream: memberFileName - | 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 ifFalse: [ - ^self error: 'Not a Zip file' ]. - - archive _ ZipArchive new readFrom: strm. - which _ archive members - detect: [:any | any fileName = memberFileName] - ifNone: nil. - which ifNil: [ - archive close. - ^ self error: 'Can''t find requested file in archive']. - strm _ which contentStream. - archive close. - ^ strm! ! -!ReadWriteStream methodsFor: '*Compression' stamp: 'jmv 6/10/2013 20:40'! - isZipArchive - "Determine if this appears to be a valid Zip archive" - | sig | - self binary. - sig _ (self next: 4) asString. - self position: self position - 4. "rewind" - ^ (ZipArchive validSignatures includes: sig)! ! -!FileStream methodsFor: '*Compression' stamp: 'jmv 6/10/2013 20:39'! - viewGZipContents - "View the contents of a gzipped file" - - | stringContents | - self binary. - stringContents _ self contentsOfEntireFile. - stringContents _ (GZipReadStream on: stringContents) upToEnd. - stringContents _ stringContents asString withCuisLineEndings. - - Workspace new - contents: stringContents; - openLabel: 'Decompressed contents of: ', self localName! ! -!StandardFileStream methodsFor: '*Compression' stamp: 'jmv 7/17/2017 15:45:40'! -compressFile - "Write a new file that has the data in me compressed in GZip format." - | zipped buffer | - - self readOnly; binary. - zipped _ (self directory // (self name, '.gz')) writeStream. - zipped binary. - zipped _ GZipWriteStream on: zipped. - buffer _ ByteArray new: 50000. - 'Compressing ', self fullName displayProgressAt: Sensor mousePoint - from: 0 to: self size - during: [ :barBlock | - [self atEnd] whileFalse: [ - barBlock value: self position. - zipped nextPutAll: (self nextInto: buffer)]. - zipped close. - self close ]. - ^zipped! ! -!CodeFileBrowserWindow class methodsFor: '*Compression' stamp: 'pb 5/25/2016 01:31'! - browseMCZFile: aFileEntry - - | codeFile organizer browser unzipped | - organizer _ SystemOrganizer defaultList: Array new. - aFileEntry readStreamDo: [ :stream | - unzipped _ stream asUnZippedStream: 'snapshot/source.st'. - unzipped ascii. - codeFile _ (CodeFile new fullName: aFileEntry pathName; buildFrom: unzipped) ]. - organizer - classifyAll: codeFile classes keys - under: codeFile name. - (browser _ CodeFileBrowser new) - systemOrganizer: organizer; - codeFile: codeFile. - CodeFileBrowserWindow open: browser label: nil! ! -!CodePackageFile class methodsFor: '*Compression' stamp: 'jmv 10/2/2015 16:55'! - browseMCZCode: aFileEntry - "Browse the selected file." - - CodeFileBrowserWindow browseMCZFile: aFileEntry! ! -!CodePackageFile class methodsFor: '*Compression' stamp: 'jmv 5/31/2016 11:15'! - installMonticelloPackage: aFileEntry - - | fullName pkName unzip | - fullName _ aFileEntry pathName. - pkName _ CodePackageFile monticelloPackageNameFrom: fullName. - aFileEntry readStreamDo: [ :stream | - unzip _ stream asUnZippedStream: 'snapshot/source.st'. - unzip ascii. - CodePackageFile - installFileStream: unzip - packageName: pkName - fullName: fullName ]! ! -!CodePackageFile class methodsFor: '*Compression' stamp: 'jmv 11/3/2016 11:38:49'! - monticelloPackageNameFrom: fullName - | localName | - localName _ fullName asFileEntry name. - ^(localName prefixAndSuffix: $-) - ifNotNil: [ :ary | ary first ] - ifNil: [ localName withoutSuffix: '.mcz' ]! ! -!CodePackageFile class methodsFor: '*Compression' stamp: 'jmv 7/5/2016 12:29'! - serviceBrowseMCZCode - "Answer a service for opening a changelist browser on a file" - - ^ (SimpleServiceEntry - provider: self - label: 'code file browser' - selector: #browseMCZCode: - description: 'open a "file-contents browser" on this file, allowing you to view and selectively load its code' - buttonLabel: 'code') - argumentGetter: [ :fileList | fileList selectedFileEntry ] ! ! -!CodePackageFile class methodsFor: '*Compression' stamp: 'jmv 10/2/2015 17:00'! - serviceInstallMonticelloPackage - "Answer the service of installing a Monticello package file (Squeak's compressed chunk format file for a package)" - - ^ (SimpleServiceEntry - provider: self - label: 'install Monticello package' - selector: #installMonticelloPackage: - description: 'install the Monticello package, replacing all existing code in the package (if any); create a new change set just for the installation' - buttonLabel: 'install package') - argumentGetter: [ :fileList | fileList selectedFileEntry ] ! ! -!GZipConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 19:00'! - gzipMagic - ^GZipMagic! ! -!GZipConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 19:00'! - initialize - "GZipConstants initialize" - GZipMagic := 16r8B1F. "GZIP magic number" - GZipDeflated := 8. "Compression method" - - GZipAsciiFlag := 16r01. "Contents is ASCII" - GZipContinueFlag := 16r02. "Part of a multi-part archive" - GZipExtraField := 16r04. "Archive has extra fields" - GZipNameFlag := 16r08. "Archive has original file name" - GZipCommentFlag := 16r10. "Archive has comment" - GZipEncryptFlag := 16r20. "Archive is encrypted" - GZipReservedFlags := 16rC0. "Reserved" ! ! -!ZipConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 19:09'! - initialize - "ZipConstants initialize" - self initializeDeflateConstants. - self initializeWriteStreamConstants.! ! -!ZipConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 19:06'! - initializeDeflateConstants - - WindowSize _ 16r8000. - WindowMask _ WindowSize - 1. - MaxDistance _ WindowSize. - - MinMatch _ 3. - MaxMatch _ 258. - - HashBits _ 15. - HashMask _ (1 << HashBits) - 1. - HashShift _ (HashBits + MinMatch - 1) // MinMatch. -! ! -!ZipConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 19:08'! - initializeDistanceCodes - | dist | - BaseDistance _ WordArray new: MaxDistCodes. - DistanceCodes _ WordArray new: 512. - dist _ 0. - 1 to: 16 do:[:code| - BaseDistance at: code put: dist. - 1 to: (1 bitShift: (ExtraDistanceBits at: code)) do:[:n| - dist _ dist + 1. - DistanceCodes at: dist put: code-1]]. - dist = 256 ifFalse:[self error:'Whoops?!!']. - dist _ dist >> 7. - 17 to: MaxDistCodes do:[:code| - BaseDistance at: code put: dist << 7. - 1 to: (1 bitShift: (ExtraDistanceBits at: code)-7) do:[:n| - dist _ dist + 1. - DistanceCodes at: 256 + dist put: code-1]]. -! ! -!ZipConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 19:07'! - initializeExtraBits - ExtraLengthBits _ - WordArray withAll: #(0 0 0 0 0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 4 4 4 4 5 5 5 5 0). - ExtraDistanceBits _ - WordArray withAll: #(0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10 11 11 12 12 13 13). - ExtraBitLengthBits _ - WordArray withAll: #(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 3 7). - BitLengthOrder _ - WordArray withAll: #(16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15). -! ! -!ZipConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 19:08'! - initializeFixedTrees - "ZipWriteStream initializeFixedTrees" - | counts nodes | - FixedLiteralTree _ ZipEncoderTree new. - FixedLiteralTree maxCode: 287. - counts _ WordArray new: MaxBits+1. - counts at: 7+1 put: 24. - counts at: 8+1 put: 144+8. - counts at: 9+1 put: 112. - nodes _ Array new: 288. - 1 to: 288 do:[:i| nodes at: i put: (ZipEncoderNode value: i-1 frequency: 0 height: 0)]. - 0 to: 143 do:[:i| (nodes at: i+1) setBitLengthTo: 8]. - 144 to: 255 do:[:i| (nodes at: i+1) setBitLengthTo: 9]. - 256 to: 279 do:[:i| (nodes at: i+1) setBitLengthTo: 7]. - 280 to: 287 do:[:i| (nodes at: i+1) setBitLengthTo: 8]. - FixedLiteralTree buildCodes: nodes counts: counts maxDepth: MaxBits. - FixedLiteralTree setValuesFrom: nodes. - - FixedDistanceTree _ ZipEncoderTree new. - FixedDistanceTree maxCode: MaxDistCodes. - FixedDistanceTree - bitLengths: ((WordArray new: MaxDistCodes+1) atAllPut: 5) - codes: ((0 to: MaxDistCodes) collect:[:i| FixedDistanceTree reverseBits: i length: 5]).! ! -!ZipConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 19:07'! - initializeLengthCodes - | length | - BaseLength _ WordArray new: MaxLengthCodes. - MatchLengthCodes _ WordArray new: MaxMatch - MinMatch + 1. - length _ 0. - 1 to: MaxLengthCodes - 1 do:[:code| - BaseLength at: code put: length. - 1 to: (1 bitShift: (ExtraLengthBits at: code)) do:[:n| - length _ length + 1. - MatchLengthCodes at: length put: NumLiterals + code]]. -! ! -!ZipConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 19:09'! - initializeWriteStreamConstants - - MaxBits _ 15. - MaxBitLengthBits _ 7. - EndBlock _ 256. - - StoredBlock _ 0. - FixedBlock _ 1. - DynamicBlock _ 2. - - NumLiterals _ 256. - MaxLengthCodes _ 29. - MaxDistCodes _ 30. - MaxBitLengthCodes _ 19. - MaxLiteralCodes _ NumLiterals + MaxLengthCodes + 1. "+ End of Block" - - Repeat3To6 _ 16. "Repeat previous bit length 3-6 times (2 bits repeat count)" - Repeat3To10 _ 17. "Repeat previous bit length 3-10 times (3 bits repeat count)" - Repeat11To138 _ 18. "Repeat previous bit length 11-138 times (7 bits repeat count)" - - self initializeExtraBits. - self initializeLengthCodes. - self initializeDistanceCodes. - self initializeFixedTrees. -! ! -!ZipFileConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 19:20'! - initialize - "ZipFileConstants initialize" - FaMsdos := 0. - FaUnix := 3. - DeflatingCompressionNormal := 0. - DeflatingCompressionMaximum := 2. - DeflatingCompressionFast := 4. - DeflatingCompressionSuperFast := 6. - CompressionStored := 0. - CompressionDeflated := 8. - CompressionLevelNone := 0. - CompressionLevelDefault := 6. - IfaTextFile := 1. - IfaBinaryFile := 0. - CentralDirectoryFileHeaderSignature := 0. - LocalFileHeaderSignature := 0. - EndOfCentralDirectorySignature := 0. - DataDescriptorLength := 12. - - "Unix permission bits" - DefaultDirectoryPermissions := 8r040755. - DefaultFilePermissions := 8r0100666. - DirectoryAttrib := 8r040000. - FileAttrib := 8r0100000. - - CentralDirectoryFileHeaderSignature _ - (ByteArray with: 16r50 with: 16r4B with: 16r01 with: 16r02) asString. - LocalFileHeaderSignature _ - (ByteArray with: 16r50 with: 16r4B with: 16r03 with: 16r04) asString. - EndOfCentralDirectorySignature _ - (ByteArray with: 16r50 with: 16r4B with: 16r05 with: 16r06) asString.! ! -!InflateStream methodsFor: 'testing' stamp: 'jmv 3/1/2010 11:28'! - atEnd - "Note: It is possible that we have a few bits left, - representing just the EOB marker. To check for - this we must force decompression of the next - block if at end of data." - super atEnd ifFalse:[^false]. "Primitive test" - (position >= readLimit and:[state = StateNoMoreData]) ifTrue:[^true]. - "Force decompression, by calling #next. Since #moveContentsToFront - will never move data to the beginning of the buffer it is safe to - skip back the read position afterwards" - self next - ifNil: [^ true]. - position _ position - 1. - ^false! ! -!InflateStream methodsFor: 'bit access' stamp: 'jmv 3/1/2010 11:28'! - bitPosition - "Return the current bit position of the source" - ^sourceStream - ifNil: [sourcePos * 8 + bitPos] - ifNotNil: [sourceStream position + sourcePos * 8 + bitPos]! ! -!InflateStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 15:31'! - close - sourceStream ifNotNil:[sourceStream close].! ! -!InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/21/1999 22:59'! - computeHuffmanValues: aCollection counts: counts from: minBits to: maxBits - "Assign numerical values to all codes. - Note: The values are stored according to the bit length" - | offsets values baseOffset codeLength | - offsets _ Array new: maxBits. - offsets atAllPut: 0. - baseOffset _ 1. - minBits to: maxBits do:[:bits| - offsets at: bits put: baseOffset. - baseOffset _ baseOffset + (counts at: bits+1)]. - values _ WordArray new: aCollection size. - 1 to: aCollection size do:[:i| - codeLength _ aCollection at: i. - codeLength > 0 ifTrue:[ - baseOffset _ offsets at: codeLength. - values at: baseOffset put: i-1. - offsets at: codeLength put: baseOffset + 1]]. - ^values! ! -!InflateStream methodsFor: 'accessing' stamp: 'jmv 7/12/2016 10:11:19'! - contents - "Use a copy to avoid modifying receiver. - The copy is shallow, i.e. cheap." - ^ self copy upToEnd! ! -!InflateStream methodsFor: 'crc' stamp: 'ar 2/29/2004 04:04'! - crcError: aString - ^CRCError signal: aString! ! -!InflateStream methodsFor: 'huffman trees' stamp: 'sma 5/12/2000 10:49'! - createHuffmanTables: values counts: counts from: minBits to: maxBits - "Create the actual tables" - | table tableStart tableSize tableEnd - valueIndex tableStack numValues deltaBits maxEntries - lastTable lastTableStart tableIndex lastTableIndex | - - table _ WordArray new: ((4 bitShift: minBits) max: 16). - - "Create the first entry - this is a dummy. - It gives us information about how many bits to fetch initially." - table at: 1 put: (minBits bitShift: 24) + 2. "First actual table starts at index 2" - - "Create the first table from scratch." - tableStart _ 2. "See above" - tableSize _ 1 bitShift: minBits. - tableEnd _ tableStart + tableSize. - "Store the terminal symbols" - valueIndex _ (counts at: minBits+1). - tableIndex _ 0. - 1 to: valueIndex do:[:i| - table at: tableStart + tableIndex put: (values at: i). - tableIndex _ self increment: tableIndex bits: minBits]. - "Fill up remaining entries with invalid entries" - tableStack _ OrderedCollection new: 10. "Should be more than enough" - tableStack addLast: - (Array - with: minBits "Number of bits (e.g., depth) for this table" - with: tableStart "Start of table" - with: tableIndex "Next index in table" - with: minBits "Number of delta bits encoded in table" - with: tableSize - valueIndex "Entries remaining in table"). - "Go to next value index" - valueIndex _ valueIndex + 1. - "Walk over remaining bit lengths and create new subtables" - minBits+1 to: maxBits do:[:bits| - numValues _ counts at: bits+1. - [numValues > 0] whileTrue:["Create a new subtable" - lastTable _ tableStack last. - lastTableStart _ lastTable at: 2. - lastTableIndex _ lastTable at: 3. - deltaBits _ bits - (lastTable at: 1). - "Make up a table of deltaBits size" - tableSize _ 1 bitShift: deltaBits. - tableStart _ tableEnd. - tableEnd _ tableEnd + tableSize. - [tableEnd > table size ] - whileTrue:[table _ self growHuffmanTable: table]. - "Connect to last table" - self assert:[(table at: lastTableStart + lastTableIndex) = 0]."Entry must be unused" - table at: lastTableStart + lastTableIndex put: (deltaBits bitShift: 24) + tableStart. - lastTable at: 3 put: (self increment: lastTableIndex bits: (lastTable at: 4)). - lastTable at: 5 put: (lastTable at: 5) - 1. - self assert:[(lastTable at: 5) >= 0]. "Don't exceed tableSize" - "Store terminal values" - maxEntries _ numValues min: tableSize. - tableIndex _ 0. - 1 to: maxEntries do:[:i| - table at: tableStart + tableIndex put: (values at: valueIndex). - valueIndex _ valueIndex + 1. - numValues _ numValues - 1. - tableIndex _ self increment: tableIndex bits: deltaBits]. - "Check if we have filled up the current table completely" - maxEntries = tableSize ifTrue:[ - "Table has been filled. Back up to the last table with space left." - [tableStack isEmpty not and:[(tableStack last at: 5) = 0]] - whileTrue:[tableStack removeLast]. - ] ifFalse:[ - "Table not yet filled. Put it back on the stack." - tableStack addLast: - (Array - with: bits "Nr. of bits in this table" - with: tableStart "Start of table" - with: tableIndex "Index in table" - with: deltaBits "delta bits of table" - with: tableSize - maxEntries "Unused entries in table"). - ]. - ]. - ]. - ^table copyFrom: 1 to: tableEnd-1! ! -!InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 02:25'! -decodeDynamicTable: nItems from: aHuffmanTable - "Decode the code length of the literal/length and distance table - in a block compressed with dynamic huffman trees" - | values index value repCount theValue | - values _ Array new: nItems. - index _ 1. - theValue _ 0. - [index <= nItems] whileTrue:[ - value _ self decodeValueFrom: aHuffmanTable. - value < 16 ifTrue:[ - "Immediate values" - theValue _ value. - values at: index put: value. - index _ index+1. - ] ifFalse:[ - "Repeated values" - value = 16 ifTrue:[ - "Repeat last value" - repCount _ (self nextBits: 2) + 3. - ] ifFalse:[ - "Repeat zero value" - theValue _ 0. - value = 17 - ifTrue:[repCount _ (self nextBits: 3) + 3] - ifFalse:[value = 18 - ifTrue:[repCount _ (self nextBits: 7) + 11] - ifFalse:[^self error:'Invalid bits tree value']]]. - 0 to: repCount-1 do:[:i| values at: index+i put: theValue]. - index _ index + repCount]. - ]. - ^values! ! -!InflateStream methodsFor: 'inflating' stamp: 'ar 12/4/1998 02:24'! - decodeValueFrom: table - "Decode the next value in the receiver using the given huffman table." - | bits bitsNeeded tableIndex value | - bitsNeeded _ (table at: 1) bitShift: -24. "Initial bits needed" - tableIndex _ 2. "First real table" - [bits _ self nextSingleBits: bitsNeeded. "Get bits" - value _ table at: (tableIndex + bits). "Lookup entry in table" - (value bitAnd: 16r3F000000) = 0] "Check if it is a non-leaf node" - whileFalse:["Fetch sub table" - tableIndex _ value bitAnd: 16rFFFF. "Table offset in low 16 bit" - bitsNeeded _ (value bitShift: -24) bitAnd: 255. "Additional bits in high 8 bit" - bitsNeeded > MaxBits ifTrue:[^self error:'Invalid huffman table entry']]. - ^value! ! -!InflateStream methodsFor: 'private' stamp: 'ar 12/4/1998 02:03'! - decompressAll - "Profile the decompression speed" - [self atEnd] whileFalse:[ - position _ readLimit. - self next "Provokes decompression" - ].! ! -!InflateStream methodsFor: 'inflating' stamp: 'yo 5/9/2014 15:19'! - decompressBlock: llTable with: dTable - "Process the compressed data in the block. - llTable is the huffman table for literal/length codes - and dTable is the huffman table for distance codes." - | value extra length distance oldPos oldBits oldBitPos | - [readLimit < collection size and: [sourcePos <= sourceLimit]] whileTrue: [ - "Back up stuff if we're running out of space" - oldBits _ bitBuf. - oldBitPos _ bitPos. - oldPos _ sourcePos. - value _ self decodeValueFrom: llTable. - value < 256 ifTrue:[ "A literal" - collection byteAt: (readLimit _ readLimit + 1) put: value. - ] ifFalse: ["length/distance or end of block" - value = 256 ifTrue:["End of block" - state _ state bitAnd: StateNoMoreData. - ^self]. - "Compute the actual length value (including possible extra bits)" - extra _ #(0 0 0 0 0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 4 4 4 4 5 5 5 5 0) at: value - 256. - length _ #(3 4 5 6 7 8 9 10 11 13 15 17 19 23 27 31 35 43 51 59 67 83 99 115 131 163 195 227 258) at: value - 256. - extra > 0 ifTrue:[length _ length + (self nextBits: extra)]. - "Compute the distance value" - value _ self decodeValueFrom: dTable. - extra _ #(0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10 11 11 12 12 13 13) at: value+1. - distance _ #(1 2 3 4 5 7 9 13 17 25 33 49 65 97 129 193 257 385 513 769 - 1025 1537 2049 3073 4097 6145 8193 12289 16385 24577) at: value+1. - extra > 0 ifTrue: [distance _ distance + (self nextBits: extra)]. - (readLimit + length >= collection size) ifTrue:[ - bitBuf _ oldBits. - bitPos _ oldBitPos. - sourcePos _ oldPos. - ^self]. - collection - replaceFrom: readLimit+1 - to: readLimit + length - with: collection - startingAt: readLimit - distance + 1. - readLimit _ readLimit + length. - ]. - ].! ! -!InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 01:51'! - distanceMap - "This is used by the fast decompressor" - ^nil! ! -!InflateStream methodsFor: 'private' stamp: 'jmv 3/1/2010 11:29'! -getFirstBuffer - "Get the first source buffer after initialization has been done" - sourceStream - ifNil: [^ self]. - source _ sourceStream next: 1 << 16. "This is more than enough..." - sourceLimit _ source size! ! -!InflateStream methodsFor: 'private' stamp: 'ar 12/3/1998 17:32'! - getNextBlock - ^self nextBits: 3! ! -!InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/3/1998 13:16'! - growHuffmanTable: table - | newTable | - newTable _ table species new: table size * 2. - newTable replaceFrom: 1 to: table size with: table startingAt: 1. - ^newTable! ! -!InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 02:27'! - huffmanTableFrom: aCollection mappedBy: valueMap - "Create a new huffman table from the given code lengths. - Map the actual values by valueMap if it is given. - See the class comment for a documentation of the huffman - tables used in this decompressor." - | counts values table minBits maxBits | - minBits _ MaxBits + 1. - maxBits _ 0. - "Count the occurences of each code length and compute minBits and maxBits" - counts _ Array new: MaxBits+1. - counts atAllPut: 0. - aCollection do:[:length| - length > 0 ifTrue:[ - length < minBits ifTrue:[minBits _ length]. - length > maxBits ifTrue:[maxBits _ length]. - counts at: length+1 put: (counts at: length+1)+1]]. - maxBits = 0 ifTrue:[^nil]. "Empty huffman table" - - "Assign numerical values to all codes." - values _ self computeHuffmanValues: aCollection counts: counts from: minBits to: maxBits. - - "Map the values if requested" - self mapValues: values by: valueMap. - - "Create the actual tables" - table _ self createHuffmanTables: values counts: counts from: minBits to: maxBits. - - ^table! ! -!InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 01:48'! - increment: value bits: nBits - "Increment a value of nBits length. - The fast decompressor will do this differently" - ^value+1! ! -!InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 01:50'! - literalLengthMap - "This is used by the fast decompressor" - ^nil! ! -!InflateStream methodsFor: 'huffman trees' stamp: 'jmv 3/2/2010 16:07'! - mapValues: values by: valueMap - | oldValue | - valueMap ifNil:[^values]. - 1 to: values size do:[:i| - oldValue _ values at: i. - "Note: there may be nil values if not all values are used" - oldValue - ifNil: [ ^values] - ifNotNil: [ values at: i put: (valueMap at: oldValue+1)]]! ! -!InflateStream methodsFor: 'private' stamp: 'ar 12/23/1999 15:17'! - moveContentsToFront - "Move the decoded contents of the receiver to the front so that we have enough space for decoding more data." - | delta | - readLimit > 32768 ifTrue:[ - delta _ readLimit - 32767. - collection - replaceFrom: 1 - to: collection size - delta + 1 - with: collection - startingAt: delta. - position _ position - delta + 1. - readLimit _ readLimit - delta + 1].! ! -!InflateStream methodsFor: 'private' stamp: 'ar 12/23/1999 15:27'! - moveSourceToFront - "Move the encoded contents of the receiver to the front so that we have enough space for decoding more data." - (sourceStream == nil or:[sourceStream atEnd]) ifTrue:[^self]. - sourcePos > 10000 ifTrue:[ - source - replaceFrom: 1 - to: source size - sourcePos - with: source - startingAt: sourcePos + 1. - source _ sourceStream - next: sourcePos - into: source - startingAt: source size - sourcePos + 1. - sourcePos _ 0. - sourceLimit _ source size].! ! -!InflateStream methodsFor: 'accessing' stamp: 'ar 12/22/1999 01:29'! - next - "Answer the next decompressed object in the Stream represented by the - receiver." - - - position >= readLimit - ifTrue: [^self pastEndRead] - ifFalse: [^collection at: (position _ position + 1)]! ! -!InflateStream methodsFor: 'accessing' stamp: 'nk 3/7/2004 18:45'! - next: anInteger - "Answer the next anInteger elements of my collection. overriden for simplicity" - | newArray | - - "try to do it the fast way" - position + anInteger < readLimit ifTrue: [ - newArray _ collection copyFrom: position + 1 to: position + anInteger. - position _ position + anInteger. - ^newArray - ]. - - "oh, well..." - newArray _ collection species new: anInteger. - 1 to: anInteger do: [:index | newArray at: index put: (self next ifNil: [ ^newArray copyFrom: 1 to: index - 1]) ]. - ^newArray! ! -!InflateStream methodsFor: 'accessing' stamp: 'jmv 3/1/2010 11:29'! - next: n into: buffer startingAt: startIndex - "Read n objects into the given collection. - Return aCollection or a partial copy if less than - n elements have been read." - | c numRead count | - numRead _ 0. - ["Force decompression if necessary" - (c _ self next) - ifNil: [ ^buffer copyFrom: 1 to: startIndex+numRead-1 ]. - "Store the first value which provoked decompression" - buffer at: startIndex + numRead put: c. - numRead _ numRead + 1. - "After collection has been filled copy as many objects as possible" - count _ (readLimit - position) min: (n - numRead). - buffer - replaceFrom: startIndex + numRead - to: startIndex + numRead + count - 1 - with: collection - startingAt: position+1. - position _ position + count. - numRead _ numRead + count. - numRead = n] whileFalse. - ^buffer! ! -!InflateStream methodsFor: 'bit access' stamp: 'ar 12/4/1998 02:00'! - nextBits: n - | bits | - [bitPos < n] whileTrue:[ - bitBuf _ bitBuf + (self nextByte bitShift: bitPos). - bitPos _ bitPos + 8]. - bits _ bitBuf bitAnd: (1 bitShift: n)-1. - bitBuf _ bitBuf bitShift: 0 - n. - bitPos _ bitPos - n. - ^bits! ! -!InflateStream methodsFor: 'bit access' stamp: 'ar 12/5/1998 14:54'! - nextByte - ^source byteAt: (sourcePos _ sourcePos + 1)! ! -!InflateStream methodsFor: 'bit access' stamp: 'ar 12/4/1998 02:01'! - nextSingleBits: n - | out | - out _ 0. - 1 to: n do:[:i| out _ (out bitShift: 1) + (self nextBits: 1)]. - ^out! ! -!InflateStream methodsFor: 'initialization' stamp: 'jmv 1/12/2010 11:51'! - on: aCollectionOrStream - (aCollectionOrStream is: #Stream) - ifTrue: [ aCollectionOrStream binary. - sourceStream _ aCollectionOrStream. - self getFirstBuffer] - ifFalse: [ source _ aCollectionOrStream]. - ^self on: source from: 1 to: source size.! ! -!InflateStream methodsFor: 'initialization' stamp: 'ar 12/23/1999 15:35'! - on: aCollection from: firstIndex to: lastIndex - bitBuf _ bitPos _ 0. - "The decompression buffer has a size of at 64k, - since we may have distances up to 32k back and - repetitions of at most 32k length forward" - collection _ aCollection species new: 1 << 16. - readLimit _ 0. "Not yet initialized" - position _ 0. - source _ aCollection. - sourceLimit _ lastIndex. - sourcePos _ firstIndex-1. - state _ StateNewBlock.! ! -!InflateStream methodsFor: 'private' stamp: 'ar 2/29/2004 04:18'! -pastEndRead - "A client has attempted to read beyond the read limit. - Check in what state we currently are and perform - the appropriate action" - | blockType bp oldLimit | - state = StateNoMoreData ifTrue:[^nil]. "Get out early if possible" - "Check if we can move decoded data to front" - self moveContentsToFront. - "Check if we can fetch more source data" - self moveSourceToFront. - state = StateNewBlock ifTrue:[state _ self getNextBlock]. - blockType _ state bitShift: -1. - bp _ self bitPosition. - oldLimit := readLimit. - self perform: (BlockTypes at: blockType+1). - "Note: if bit position hasn't advanced then nothing has been decoded." - bp = self bitPosition - ifTrue:[^self primitiveFailed]. - "Update crc for the decoded contents" - readLimit > oldLimit - ifTrue:[crc _ self updateCrc: crc from: oldLimit+1 to: readLimit in: collection]. - state = StateNoMoreData ifTrue:[self verifyCrc]. - ^self next! ! -!InflateStream methodsFor: 'inflating' stamp: 'ar 12/3/1998 20:49'! - proceedDynamicBlock - self decompressBlock: litTable with: distTable! ! -!InflateStream methodsFor: 'inflating' stamp: 'ar 12/3/1998 20:49'! - proceedFixedBlock - self decompressBlock: litTable with: distTable! ! -!InflateStream methodsFor: 'inflating' stamp: 'jmv 3/1/2010 11:29'! - proceedStoredBlock - "Proceed decompressing a stored (e.g., uncompressed) block" - | length decoded | - "Literal table must be nil for a stored block" - litTable - ifNotNil: [^ self error: 'Bad state']. - length _ distTable. - [length > 0 and:[readLimit < collection size and:[sourcePos < sourceLimit]]] - whileTrue:[ - collection at: (readLimit _ readLimit + 1) put: - (source at: (sourcePos _ sourcePos + 1)). - length _ length - 1]. - length = 0 ifTrue:[state _ state bitAnd: StateNoMoreData]. - decoded _ length - distTable. - distTable _ length. - ^decoded! ! -!InflateStream methodsFor: 'inflating' stamp: 'ar 12/4/1998 01:46'! - processDynamicBlock - | nLit nDist nLen codeLength lengthTable bits | - nLit _ (self nextBits: 5) + 257. - nDist _ (self nextBits: 5) + 1. - nLen _ (self nextBits: 4) + 4. - codeLength _ Array new: 19. - codeLength atAllPut: 0. - 1 to: nLen do:[:i| - bits _ #(16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15) at: i. - codeLength at: bits+1 put: (self nextBits: 3). - ]. - lengthTable _ self huffmanTableFrom: codeLength mappedBy: nil. - "RFC 1951: In other words, all code lengths form a single sequence..." - codeLength _ self decodeDynamicTable: nLit+nDist from: lengthTable. - litTable _ self - huffmanTableFrom: (codeLength copyFrom: 1 to: nLit) - mappedBy: self literalLengthMap. - distTable _ self - huffmanTableFrom: (codeLength copyFrom: nLit+1 to: codeLength size) - mappedBy: self distanceMap. - state _ state bitOr: BlockProceedBit. - self proceedDynamicBlock.! ! -!InflateStream methodsFor: 'inflating' stamp: 'ar 12/4/1998 19:13'! - processFixedBlock - litTable _ self - huffmanTableFrom: FixedLitCodes - mappedBy: self literalLengthMap. - distTable _ self - huffmanTableFrom: FixedDistCodes - mappedBy: self distanceMap. - state _ state bitOr: BlockProceedBit. - self proceedFixedBlock.! ! -!InflateStream methodsFor: 'inflating' stamp: 'ar 12/27/1999 13:49'! - processStoredBlock - | chkSum length | - "Skip to byte boundary" - self nextBits: (bitPos bitAnd: 7). - length _ self nextBits: 16. - chkSum _ self nextBits: 16. - (chkSum bitXor: 16rFFFF) = length - ifFalse:[^self error:'Bad block length']. - litTable _ nil. - distTable _ length. - state _ state bitOr: BlockProceedBit. - ^self proceedStoredBlock! ! -!InflateStream methodsFor: 'private' stamp: 'ar 12/4/1998 02:03'! - profile - "Profile the decompression speed" - MessageTally spyOn:[self decompressAll].! ! -!InflateStream methodsFor: 'initialization' stamp: 'ar 12/3/1998 16:32'! - reset - "Position zero - nothing decoded yet" - position _ readLimit _ 0. - sourcePos _ 0. - bitBuf _ bitPos _ 0. - state _ 0.! ! -!InflateStream methodsFor: 'accessing' stamp: 'ar 12/3/1998 16:19'! - size - "This is a compressed stream - we don't know the size beforehand" - ^self shouldNotImplement! ! -!InflateStream methodsFor: 'accessing' stamp: 'ar 12/21/1999 23:54'! - sourceLimit - ^sourceLimit! ! -!InflateStream methodsFor: 'accessing' stamp: 'ar 12/21/1999 23:52'! - sourcePosition - ^sourcePos! ! -!InflateStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 15:31'! - sourceStream - ^sourceStream! ! -!InflateStream methodsFor: 'accessing' stamp: 'ar 12/3/1998 16:19'! - 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! ! -!InflateStream methodsFor: 'accessing' stamp: 'ar 12/22/1999 02:04'! - upToEnd - "Answer a subcollection from the current access position through the last element of the receiver." - - | newStream buffer | - buffer _ collection species new: 1000. - newStream _ WriteStream on: (collection species new: 100). - [self atEnd] whileFalse: [newStream nextPutAll: (self nextInto: buffer)]. - ^ newStream contents! ! -!InflateStream methodsFor: 'crc' stamp: 'ar 2/29/2004 03:49'! - updateCrc: oldCrc from: start to: stop in: aCollection - "Answer an updated CRC for the range of bytes in aCollection. - Subclasses can implement the appropriate means for the check sum they wish to use." - ^oldCrc! ! -!InflateStream methodsFor: 'crc' stamp: 'ar 2/29/2004 04:22'! - verifyCrc - "Verify the crc checksum in the input"! ! -!InflateStream class methodsFor: 'class initialization' stamp: 'ar 12/4/1998 19:12'! - initialize - "InflateStream initialize" - MaxBits _ 16. - StateNewBlock _ 0. - StateNoMoreData _ 1. - BlockProceedBit _ 8. - BlockTypes _ #( processStoredBlock "New block in stored format" - processFixedBlock "New block with fixed huffman tables" - processDynamicBlock "New block with dynamic huffman tables" - errorBadBlock "Bad block format" - proceedStoredBlock "Continue block in stored format" - proceedFixedBlock "Continue block in fixed format" - proceedDynamicBlock "Continue block in dynamic format" - errorBadBlock "Bad block format"). - "Initialize fixed block values" - FixedLitCodes _ ((1 to: 144) collect:[:i| 8]), - ((145 to: 256) collect:[:i| 9]), - ((257 to: 280) collect:[:i| 7]), - ((281 to: 288) collect:[:i| 8]). - FixedDistCodes _ ((1 to: 32) collect:[:i| 5]).! ! -!FastInflateStream methodsFor: 'inflating' stamp: 'yo 5/9/2014 15:19'! - decompressBlock: llTable with: dTable - "Process the compressed data in the block. - llTable is the huffman table for literal/length codes - and dTable is the huffman table for distance codes." - | value extra length distance oldPos oldBits oldBitPos | - - [readLimit < collection size and:[sourcePos <= sourceLimit]] whileTrue:[ - "Back up stuff if we're running out of space" - oldBits _ bitBuf. - oldBitPos _ bitPos. - oldPos _ sourcePos. - value _ self decodeValueFrom: llTable. - value < 256 ifTrue:[ "A literal" - collection byteAt: (readLimit _ readLimit + 1) put: value. - ] ifFalse: ["length/distance or end of block" - value = 256 ifTrue:["End of block" - state _ state bitAnd: StateNoMoreData. - ^self]. - "Compute the actual length value (including possible extra bits)" - extra _ (value bitShift: -16) - 1. - length _ value bitAnd: 16rFFFF. - extra > 0 ifTrue:[length _ length + (self nextBits: extra)]. - "Compute the distance value" - value _ self decodeValueFrom: dTable. - extra _ (value bitShift: -16). - distance _ value bitAnd: 16rFFFF. - extra > 0 ifTrue: [distance _ distance + (self nextBits: extra)]. - (readLimit + length >= collection size) ifTrue:[ - bitBuf _ oldBits. - bitPos _ oldBitPos. - sourcePos _ oldPos. - ^self]. - collection - replaceFrom: readLimit+1 - to: readLimit + length - with: collection - startingAt: readLimit - distance + 1. - readLimit _ readLimit + length. - ]. - ].! ! -!FastInflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 02:26'! - distanceMap - ^DistanceMap! ! -!FastInflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 01:48'! - increment: value bits: nBits - "Increment value in reverse bit order, e.g. - for a 3 bit value count as follows: - 000 / 100 / 010 / 110 - 001 / 101 / 011 / 111 - See the class comment why we need this." - | result bit | - result _ value. - "Test the lowest bit first" - bit _ 1 << (nBits - 1). - "If the currently tested bit is set then we need to - turn this bit off and test the next bit right to it" - [(result bitAnd: bit) = 0] whileFalse:[ - "Turn off current bit" - result _ result bitXor: bit. - "And continue testing the next bit" - bit _ bit bitShift: -1]. - "Turn on the right-most bit that we haven't touched in the loop above" - ^result bitXor: bit! ! -!FastInflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 02:26'! - literalLengthMap - ^LiteralLengthMap! ! -!FastInflateStream methodsFor: 'bit access' stamp: 'ar 12/4/1998 02:02'! - nextSingleBits: n - "Fetch the bits all at once" - ^self nextBits: n.! ! -!FastInflateStream methodsFor: 'inflating' stamp: 'ar 12/4/1998 19:15'! - processFixedBlock - litTable _ FixedLitTable. - distTable _ FixedDistTable. - state _ state bitOr: BlockProceedBit. - self proceedFixedBlock.! ! -!FastInflateStream class methodsFor: 'class initialization' stamp: 'ar 12/21/1999 23:00'! - initialize - "FastInflateStream initialize" - | low high | - - "Init literal/length map" - low _ #(3 4 5 6 7 8 9 10 11 13 15 17 19 23 27 31 35 43 51 59 67 83 99 115 131 163 195 227 258 ). - high _ #(0 0 0 0 0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 4 4 4 4 5 5 5 5 0 0). - LiteralLengthMap _ WordArray new: 256 + 32. - 1 to: 257 do:[:i| LiteralLengthMap at: i put: i-1]. - 1 to: 29 do:[:i| LiteralLengthMap at: 257+i put: (low at:i) + ( (high at: i) + 1 << 16)]. - - "Init distance map" - high _ #(0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10 11 11 12 12 13 13). - low _ #(1 2 3 4 5 7 9 13 17 25 33 49 65 97 129 193 257 385 513 769 - 1025 1537 2049 3073 4097 6145 8193 12289 16385 24577). - DistanceMap _ WordArray new: 32. - 1 to: 30 do:[:i| DistanceMap at: i put: (low at: i) + ( (high at: i) << 16)]. - - "Init fixed block huffman tables" - FixedLitTable _ self basicNew - huffmanTableFrom: FixedLitCodes - mappedBy: LiteralLengthMap. - FixedDistTable _ self basicNew - huffmanTableFrom: FixedDistCodes - mappedBy: DistanceMap.! ! -!GZipReadStream methodsFor: 'initialization' stamp: 'ar 2/29/2004 03:32'! - on: aCollection from: firstIndex to: lastIndex - "Check the header of the GZIP stream." - | method magic flags length | - super on: aCollection from: firstIndex to: lastIndex. - crc _ 16rFFFFFFFF. - magic _ self nextBits: 16. - (magic = GZipMagic) - ifFalse:[^self error:'Not a GZipped stream']. - method _ self nextBits: 8. - (method = GZipDeflated) - ifFalse:[^self error:'Bad compression method']. - flags _ self nextBits: 8. - (flags anyMask: GZipEncryptFlag) - ifTrue:[^self error:'Cannot decompress encrypted stream']. - (flags anyMask: GZipReservedFlags) - ifTrue:[^self error:'Cannot decompress stream with unknown flags']. - "Ignore stamp, extra flags, OS type" - self nextBits: 16; nextBits: 16. "stamp" - self nextBits: 8. "extra flags" - self nextBits: 8. "OS type" - (flags anyMask: GZipContinueFlag) "Number of multi-part archive - ignored" - ifTrue:[self nextBits: 16]. - (flags anyMask: GZipExtraField) "Extra fields - ignored" - ifTrue:[ length _ self nextBits: 16. - 1 to: length do:[:i| self nextBits: 8]]. - (flags anyMask: GZipNameFlag) "Original file name - ignored" - ifTrue:[[(self nextBits: 8) = 0] whileFalse]. - (flags anyMask: GZipCommentFlag) "Comment - ignored" - ifTrue:[[(self nextBits: 8) = 0] whileFalse]. -! ! -!GZipReadStream methodsFor: 'crc' stamp: 'ar 2/29/2004 03:30'! - updateCrc: oldCrc from: start to: stop in: aCollection - "Answer an updated CRC for the range of bytes in aCollection" - ^ZipWriteStream updateCrc: oldCrc from: start to: stop in: aCollection.! ! -!GZipReadStream methodsFor: 'crc' stamp: 'ar 2/29/2004 04:20'! - verifyCrc - | stored | - stored := 0. - 0 to: 24 by: 8 do: [ :i | - sourcePos >= sourceLimit ifTrue: [ ^ self crcError: 'No checksum (proceed to ignore)' ]. - stored := stored + (self nextByte bitShift: i) ]. - stored := stored bitXor: 16rFFFFFFFF. - stored = crc ifFalse: [ ^ self crcError: 'Wrong checksum (proceed to ignore)' ]. - ^stored! ! -!GZipReadStream class methodsFor: 'fileIn/Out' stamp: 'jmv 1/11/2013 12:52'! -fileReaderServicesForFile: fullName suffix: suffix - "FileList buttons that are serviced by us." - - ^suffix = 'gz' - ifTrue: [ {self serviceViewDecompress. self serviceDecompressToFile} ] - ifFalse: [ #() ]! ! -!GZipReadStream class methodsFor: 'fileIn/Out' stamp: 'jmv 7/17/2017 15:44:39'! -saveContents: fullFileName - "Save the contents of a gzipped file" - | zipped buffer newName | - newName _ FileIOAccessor default baseNameFor: fullFileName. - newName asFileEntry writeStreamDo: [ :unzipped | - unzipped binary. - fullFileName asFileEntry readStreamDo: [ :zipContents | - zipped _ GZipReadStream on: zipContents. - buffer _ ByteArray new: 50000. - 'Extracting ' , fullFileName - displayProgressAt: Sensor mousePoint - from: 0 - to: zipped sourceStream size - during: [ :barBlock | - [ zipped atEnd ] - whileFalse: [ - barBlock value: zipped sourceStream position. - unzipped nextPutAll: (zipped nextInto: buffer) ]]]]. - ^ newName! ! -!GZipReadStream class methodsFor: 'fileIn/Out' stamp: 'jmv 4/19/2011 11:19'! - serviceDecompressToFile - - ^ (SimpleServiceEntry - provider: self - label: 'decompress to file' - selector: #saveContents: - description: 'decompress to file') triggerFileListChanged! ! -!GZipReadStream class methodsFor: 'fileIn/Out' stamp: 'sd 2/1/2002 22:15'! - serviceViewDecompress - - ^ SimpleServiceEntry - provider: self - label: 'view decompressed' - selector: #viewContents: - description: 'view decompressed' -! ! -!GZipReadStream class methodsFor: 'fileIn/Out' stamp: 'pb 5/25/2016 01:50'! - viewContents: fullFileName - "Open the decompressed contents of the .gz file with the given name. This method is only required for the registering-file-list of Squeak 3.3a and beyond, but does no harm in an earlier system" - - (fullFileName asFileEntry readStream ) ifNotNil: [ :aStream | - aStream viewGZipContents]! ! -!ZLibReadStream methodsFor: 'initialization' stamp: 'ar 2/29/2004 03:31'! - on: aCollection from: firstIndex to: lastIndex - "Check the header of the ZLib stream." - | method byte | - super on: aCollection from: firstIndex to: lastIndex. - crc _ 1. - method _ self nextBits: 8. - (method bitAnd: 15) = 8 ifFalse:[^self error:'Unknown compression method']. - (method bitShift: -4) + 8 > 15 ifTrue:[^self error:'Invalid window size']. - byte _ self nextBits: 8. - (method bitShift: 8) + byte \\ 31 = 0 ifFalse:[^self error:'Incorrect header']. - (byte anyMask: 32) ifTrue:[^self error:'Need preset dictionary']. -! ! -!ZLibReadStream methodsFor: 'crc' stamp: 'ar 2/29/2004 03:30'! - updateCrc: oldCrc from: start to: stop in: aCollection - "Answer an updated CRC for the range of bytes in aCollection" - ^ZLibWriteStream updateAdler32: oldCrc from: start to: stop in: aCollection.! ! -!ZLibReadStream methodsFor: 'crc' stamp: 'ar 2/29/2004 04:21'! - verifyCrc - | stored | - stored := 0. - 24 to: 0 by: -8 do: [ :i | - sourcePos >= sourceLimit ifTrue: [ ^ self crcError: 'No checksum (proceed to ignore)' ]. - stored := stored + (self nextByte bitShift: i) ]. - stored = crc ifFalse: [ ^ self crcError: 'Wrong checksum (proceed to ignore)' ]. - ^stored! ! -!ZipReadStream methodsFor: 'crc' stamp: 'nk 3/7/2004 18:55'! - expectedCrc: aNumberOrNil - "If expectedCrc is set, it will be compared against the calculated CRC32 in verifyCrc. - This number should be the number read from the Zip header (which is the bitwise complement of my crc if all is working correctly)" - expectedCrc _ aNumberOrNil! ! -!ZipReadStream methodsFor: 'initialization' stamp: 'nk 3/7/2004 15:31'! - on: aCollection from: firstIndex to: lastIndex - super on: aCollection from: firstIndex to: lastIndex. - crc _ 16rFFFFFFFF. - expectedCrc _ nil.! ! -!ZipReadStream methodsFor: 'crc' stamp: 'nk 3/7/2004 15:32'! - updateCrc: oldCrc from: start to: stop in: aCollection - ^ZipWriteStream updateCrc: oldCrc from: start to: stop in: aCollection! ! -!ZipReadStream methodsFor: 'crc' stamp: 'jmv 2/22/2011 22:55'! - verifyCrc - "Verify the CRC-32 checksum calculated from the input against the expected CRC-32, if any. - Answer the calculated CRC-32 in any case. - Note that the CRC-32 used in Zip files is actually the bit inverse of the calculated value, so that is what is returned." - - | invertedCrc | - invertedCrc _ crc bitXor: 16rFFFFFFFF. - (expectedCrc notNil and: [ expectedCrc ~= invertedCrc ]) - ifTrue: [ ^ self crcError: ('Wrong CRC-32 (expected {1} got {2}) (proceed to ignore)' format: { expectedCrc hex. invertedCrc hex }) ]. - ^invertedCrc! ! -!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 20:24'! - compare: here with: matchPos min: minLength - "Compare the two strings and return the length of matching characters. - minLength is a lower bound for match lengths that will be accepted. - Note: here and matchPos are zero based." - | length | - "First test if we can actually get longer than minLength" - (collection at: here+minLength+1) = (collection at: matchPos+minLength+1) - ifFalse:[^0]. - (collection at: here+minLength) = (collection at: matchPos+minLength) - ifFalse:[^0]. - "Then test if we have an initial match at all" - (collection at: here+1) = (collection at: matchPos+1) - ifFalse:[^0]. - (collection at: here+2) = (collection at: matchPos+2) - ifFalse:[^1]. - "Finally do the real comparison" - length _ 3. - [length <= MaxMatch and:[ - (collection at: here+length) = (collection at: matchPos+length)]] - whileTrue:[length _ length + 1]. - ^length - 1! ! -!DeflateStream methodsFor: 'deflating' stamp: 'jmv 3/1/2010 09:56'! -deflateBlock - "Deflate the current contents of the stream" - | flushNeeded lastIndex | - blockStart ifNil: [ - "One time initialization for the first block" - 1 to: MinMatch-1 do:[:i| self updateHashAt: i]. - blockStart _ 0]. - - [blockPosition < position] whileTrue:[ - (position + MaxMatch > writeLimit) - ifTrue:[lastIndex _ writeLimit - MaxMatch] - ifFalse:[lastIndex _ position]. - flushNeeded _ self deflateBlock: lastIndex-1 - chainLength: self hashChainLength - goodMatch: self goodMatchLength. - flushNeeded ifTrue:[ - self flushBlock. - blockStart _ blockPosition]. - "Make room for more data" - self moveContentsToFront]. -! ! -!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 18:05'! - deflateBlock: lastIndex chainLength: chainLength goodMatch: goodMatch - "Continue deflating the receiver's collection from blockPosition to lastIndex. - Note that lastIndex must be at least MaxMatch away from the end of collection" - | here matchResult flushNeeded hereMatch hereLength newMatch newLength hasMatch | - blockPosition > lastIndex ifTrue:[^false]. "Nothing to deflate" - hasMatch _ false. - here _ blockPosition. - [here <= lastIndex] whileTrue:[ - hasMatch ifFalse:[ - "Find the first match" - matchResult _ self findMatch: here - lastLength: MinMatch-1 - lastMatch: here - chainLength: chainLength - goodMatch: goodMatch. - self insertStringAt: here. "update hash table" - hereMatch _ matchResult bitAnd: 16rFFFF. - hereLength _ matchResult bitShift: -16]. - - "Look ahead if there is a better match at the next position" - matchResult _ self findMatch: here+1 - lastLength: hereLength - lastMatch: hereMatch - chainLength: chainLength - goodMatch: goodMatch. - newMatch _ matchResult bitAnd: 16rFFFF. - newLength _ matchResult bitShift: -16. - - "Now check if the next match is better than the current one. - If not, output the current match (provided that the current match - is at least MinMatch long)" - (hereLength >= newLength and:[hereLength >= MinMatch]) ifTrue:[ - self assert:[self validateMatchAt: here - from: hereMatch to: hereMatch + hereLength - 1]. - "Encode the current match" - flushNeeded _ self - encodeMatch: hereLength - distance: here - hereMatch. - "Insert all strings up to the end of the current match. - Note: The first string has already been inserted." - 1 to: hereLength-1 do:[:i| self insertStringAt: (here _ here + 1)]. - hasMatch _ false. - here _ here + 1. - ] ifFalse:[ - "Either the next match is better than the current one or we didn't - have a good match after all (e.g., current match length < MinMatch). - Output a single literal." - flushNeeded _ self encodeLiteral: (collection byteAt: (here + 1)). - here _ here + 1. - (here <= lastIndex and:[flushNeeded not]) ifTrue:[ - "Cache the results for the next round" - self insertStringAt: here. - hasMatch _ true. - hereMatch _ newMatch. - hereLength _ newLength]. - ]. - flushNeeded ifTrue:[blockPosition _ here. ^true]. - ]. - blockPosition _ here. - ^false! ! -!DeflateStream methodsFor: 'encoding' stamp: 'ar 12/29/1999 18:04'! - encodeLiteral: literal - "Encode the given literal. - Return true if the current block needs to be flushed." - ^false! ! -!DeflateStream methodsFor: 'encoding' stamp: 'ar 12/29/1999 18:04'! - encodeMatch: matchLength distance: matchDistance - "Encode a match of the given length and distance. - Return true if the current block should be flushed." - ^false! ! -!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 17:45'! - findMatch: here lastLength: lastLength lastMatch: lastMatch chainLength: maxChainLength goodMatch: goodMatch - "Find the longest match for the string starting at here. - If there is no match longer than lastLength return lastMatch/lastLength. - Traverse at most maxChainLength entries in the hash table. - Stop if a match of at least goodMatch size has been found." - | matchResult matchPos distance chainLength limit bestLength length | - "Compute the default match result" - matchResult _ (lastLength bitShift: 16) bitOr: lastMatch. - - "There is no way to find a better match than MaxMatch" - lastLength >= MaxMatch ifTrue:[^matchResult]. - - "Start position for searches" - matchPos _ hashHead at: (self updateHashAt: here + MinMatch) + 1. - - "Compute the distance to the (possible) match" - distance _ here - matchPos. - - "Note: It is required that 0 < distance < MaxDistance" - (distance > 0 and:[distance < MaxDistance]) ifFalse:[^matchResult]. - - chainLength _ maxChainLength. "Max. nr of match chain to search" - here > MaxDistance "Limit for matches that are too old" - ifTrue:[limit _ here - MaxDistance] - ifFalse:[limit _ 0]. - - "Best match length so far (current match must be larger to take effect)" - bestLength _ lastLength. - - ["Compare the current string with the string at match position" - length _ self compare: here with: matchPos min: bestLength. - "Truncate accidental matches beyound stream position" - (here + length > position) ifTrue:[length _ position - here]. - "Ignore very small matches if they are too far away" - (length = MinMatch and:[(here - matchPos) > (MaxDistance // 4)]) - ifTrue:[length _ MinMatch - 1]. - length > bestLength ifTrue:["We have a new (better) match than before" - "Compute the new match result" - matchResult _ (length bitShift: 16) bitOr: matchPos. - bestLength _ length. - "There is no way to find a better match than MaxMatch" - bestLength >= MaxMatch ifTrue:[^matchResult]. - "But we may have a good, fast match" - bestLength > goodMatch ifTrue:[^matchResult]. - ]. - (chainLength _ chainLength - 1) > 0] whileTrue:[ - "Compare with previous entry in hash chain" - matchPos _ hashTail at: (matchPos bitAnd: WindowMask) + 1. - matchPos <= limit ifTrue:[^matchResult]. "Match position is too old" - ]. - ^matchResult! ! -!DeflateStream methodsFor: 'initialization' stamp: 'ar 12/29/1999 17:30'! - flush - "Force compression" - self deflateBlock.! ! -!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/28/1999 17:37'! - flushBlock - "Flush a deflated block"! ! -!DeflateStream methodsFor: 'accessing' stamp: 'ar 12/29/1999 20:00'! - goodMatchLength - "Return the length that is considered to be a 'good' match. - Higher values will result in better compression but take more time." - ^MaxMatch "Best compression"! ! -!DeflateStream methodsFor: 'accessing' stamp: 'ar 12/29/1999 20:00'! - hashChainLength - "Return the max. number of hash chains to traverse. - Higher values will result in better compression but take more time." - ^4096 "Best compression"! ! -!DeflateStream methodsFor: 'initialization' stamp: 'ar 12/31/1999 18:00'! - initialize - blockStart _ nil. - blockPosition _ 0. - hashValue _ 0. - self initializeHashTables.! ! -!DeflateStream methodsFor: 'initialization' stamp: 'ar 12/29/1999 17:32'! - initializeHashTables - hashHead _ WordArray new: 1 << HashBits. - hashTail _ WordArray new: WindowSize. -! ! -!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 17:46'! - insertStringAt: here - "Insert the string at the given start position into the hash table. - Note: The hash value is updated starting at MinMatch-1 since - all strings before have already been inserted into the hash table - (and the hash value is updated as well)." - | prevEntry | - hashValue _ self updateHashAt: (here + MinMatch). - prevEntry _ hashHead at: hashValue+1. - hashHead at: hashValue+1 put: here. - hashTail at: (here bitAnd: WindowMask)+1 put: prevEntry.! ! -!DeflateStream methodsFor: 'private' stamp: 'ar 12/29/1999 17:50'! - moveContentsToFront - "Move the contents of the receiver to the front" - | delta | - delta _ (blockPosition - WindowSize). - delta <= 0 ifTrue:[^self]. - "Move collection" - collection - replaceFrom: 1 - to: collection size - delta - with: collection - startingAt: delta+1. - position _ position - delta. - "Move hash table entries" - blockPosition _ blockPosition - delta. - blockStart _ blockStart - delta. - self updateHashTable: hashHead delta: delta. - self updateHashTable: hashTail delta: delta.! ! -!DeflateStream methodsFor: 'accessing' stamp: 'ar 2/19/2004 00:34'! - next: bytes putAll: aCollection startingAt: startPos - (startPos = 1 and:[bytes = aCollection size]) - ifTrue:[^self nextPutAll: aCollection]. - ^self nextPutAll: (aCollection copyFrom: startPos to: startPos + bytes - 1)! ! -!DeflateStream methodsFor: 'accessing' stamp: 'ar 12/29/1999 17:33'! - nextPutAll: aCollection - | start count max | - aCollection species = collection species - ifFalse:[ - aCollection do:[:ch| self nextPut: ch]. - ^aCollection]. - start _ 1. - count _ aCollection size. - [count = 0] whileFalse:[ - position = writeLimit ifTrue:[self deflateBlock]. - max _ writeLimit - position. - max > count ifTrue:[max _ count]. - collection replaceFrom: position+1 - to: position+max - with: aCollection - startingAt: start. - start _ start + max. - count _ count - max. - position _ position + max]. - ^aCollection! ! -!DeflateStream methodsFor: 'initialization' stamp: 'ar 12/29/1999 17:33'! - on: aCollection - self initialize. - super on: (aCollection species new: WindowSize * 2).! ! -!DeflateStream methodsFor: 'initialization' stamp: 'ar 12/28/1999 17:34'! - on: aCollection from: firstIndex to: lastIndex - "Not for DeflateStreams please" - ^self shouldNotImplement! ! -!DeflateStream methodsFor: 'accessing' stamp: 'ar 12/28/1999 17:35'! - pastEndPut: anObject - self deflateBlock. - ^self nextPut: anObject! ! -!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 17:48'! - updateHash: nextValue - "Update the running hash value based on the next input byte. - Return the new updated hash value." - ^((hashValue bitShift: HashShift) bitXor: nextValue) bitAnd: HashMask.! ! -!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 17:47'! - updateHashAt: here - "Update the hash value at position here (one based)" - ^self updateHash: (collection byteAt: here)! ! -!DeflateStream methodsFor: 'private' stamp: 'ar 2/2/2001 15:47'! - updateHashTable: table delta: delta - | pos | - - 1 to: table size do:[:i| - "Discard entries that are out of range" - (pos _ table at: i) >= delta - ifTrue:[table at: i put: pos - delta] - ifFalse:[table at: i put: 0]].! ! -!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/28/1999 17:43'! - validateMatchAt: pos from: startPos to: endPos - | here | - here _ pos. - startPos+1 to: endPos+1 do:[:i| - (collection at: i) = (collection at: (here _ here + 1)) - ifFalse:[^self error:'Not a match']]. - ^true! ! -!ZipWriteStream methodsFor: 'initialization' stamp: 'ar 2/28/2001 13:39'! - close - self deflateBlock. - self flushBlock: true. - encoder close.! ! -!ZipWriteStream methodsFor: 'accessing' stamp: 'ar 2/24/2001 19:46'! - crc - ^crc! ! -!ZipWriteStream methodsFor: 'deflating' stamp: 'ar 2/2/2001 15:47'! - deflateBlock: lastIndex chainLength: chainLength goodMatch: goodMatch - "^DeflatePlugin doPrimitive:#primitiveDeflateBlock" - - ^super deflateBlock: lastIndex chainLength: chainLength goodMatch: goodMatch! ! -!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 01:55'! - dynamicBlockSizeFor: lTree and: dTree using: blTree and: blFreq - "Compute the length for the current block using dynamic huffman trees" - | bits index extra treeBits freq | - bits _ 3 "block type" + 5 "literal codes length" + 5 "distance codes length". - - "Compute the # of bits for sending the bit length tree" - treeBits _ 4. "Max index for bit length tree" - index _ MaxBitLengthCodes. - [index >= 4] whileTrue:[ - (index = 4 or:[(blFreq at: (BitLengthOrder at: index)+1) > 0]) - ifTrue:[treeBits _ treeBits + (index * 3). - index _ -1] - ifFalse:[index _ index - 1]]. - - "Compute the # of bits for sending the literal/distance tree. - Note: The frequency are already stored in the blTree" - 0 to: 15 do:[:i| "First, the non-repeating values" - freq _ blFreq at: i+1. - freq > 0 ifTrue:[treeBits _ treeBits + (freq * (blTree bitLengthAt: i))]]. - "Now the repeating values" - (Repeat3To6 to: Repeat11To138) with: #(2 3 7) do:[:i :addl| - freq _ blFreq at: i+1. - freq > 0 ifTrue:[ - treeBits _ treeBits + (freq * ((blTree bitLengthAt: i) + addl "addl bits"))]]. - VerboseLevel > 1 ifTrue:[ - Transcript show:'['; print: treeBits; show:' bits for dynamic tree]']. - bits _ bits + treeBits. - - "Compute the size of the compressed block" - 0 to: NumLiterals do:[:i| "encoding of literals" - freq _ literalFreq at: i+1. - freq > 0 ifTrue:[bits _ bits + (freq * (lTree bitLengthAt: i))]]. - NumLiterals+1 to: lTree maxCode do:[:i| "encoding of match lengths" - freq _ literalFreq at: i+1. - extra _ ExtraLengthBits at: i-NumLiterals. - freq > 0 ifTrue:[bits _ bits + (freq * ((lTree bitLengthAt: i) + extra))]]. - 0 to: dTree maxCode do:[:i| "encoding of distances" - freq _ distanceFreq at: i+1. - extra _ ExtraDistanceBits at: i+1. - freq > 0 ifTrue:[bits _ bits + (freq * ((dTree bitLengthAt: i) + extra))]]. - - ^bits! ! -!ZipWriteStream methodsFor: 'encoding' stamp: 'ar 12/29/1999 18:05'! - encodeLiteral: lit - "Encode the given literal" - litCount _ litCount + 1. - literals at: litCount put: lit. - distances at: litCount put: 0. - literalFreq at: lit+1 put: (literalFreq at: lit+1) + 1. - ^self shouldFlush! ! -!ZipWriteStream methodsFor: 'encoding' stamp: 'ar 12/29/1999 18:05'! - encodeMatch: length distance: dist - "Encode the given match of length length starting at dist bytes ahead" - | literal distance | - dist > 0 - ifFalse:[^self error:'Distance must be positive']. - length < MinMatch - ifTrue:[^self error:'Match length must be at least ', MinMatch printString]. - litCount _ litCount + 1. - matchCount _ matchCount + 1. - literals at: litCount put: length - MinMatch. - distances at: litCount put: dist. - literal _ (MatchLengthCodes at: length - MinMatch + 1). - literalFreq at: literal+1 put: (literalFreq at: literal+1) + 1. - dist < 257 - ifTrue:[distance _ DistanceCodes at: dist] - ifFalse:[distance _ DistanceCodes at: 257 + (dist - 1 bitShift: -7)]. - distanceFreq at: distance+1 put: (distanceFreq at: distance+1) + 1. - ^self shouldFlush! ! -!ZipWriteStream methodsFor: 'accessing' stamp: 'ar 12/30/1999 00:37'! - encodedStream - ^encoder encodedStream! ! -!ZipWriteStream methodsFor: 'initialization' stamp: 'ar 2/27/2001 13:23'! - finish - "Finish pending operation. Do not close output stream." - self deflateBlock. - self flushBlock: true. - encoder flush.! ! -!ZipWriteStream methodsFor: 'fixed blocks' stamp: 'ar 12/29/1999 18:18'! - fixedBlockSizeFor: lTree and: dTree - "Compute the length for the current block using fixed huffman trees" - | bits extra | - bits _ 3 "block type". - "Compute the size of the compressed block" - 0 to: NumLiterals do:[:i| "encoding of literals" - bits _ bits + ((literalFreq at: i+1) * (FixedLiteralTree bitLengthAt: i))]. - NumLiterals+1 to: lTree maxCode+1 do:[:i| "Encoding of match lengths" - extra _ ExtraLengthBits at: i-NumLiterals. - bits _ bits + ((literalFreq at: i+1) * ((FixedLiteralTree bitLengthAt: i) + extra))]. - 0 to: dTree maxCode do:[:i| "encoding of distances" - extra _ ExtraDistanceBits at: i+1. - bits _ bits + ((distanceFreq at: i+1) * ((FixedDistanceTree bitLengthAt: i) + extra))]. - - ^bits! ! -!ZipWriteStream methodsFor: 'encoding' stamp: 'ar 12/29/1999 18:08'! - flushBlock - ^self flushBlock: false! ! -!ZipWriteStream methodsFor: 'encoding' stamp: 'jmv 3/13/2012 12:58'! - flushBlock: lastBlock - "Send the current block" - | lastFlag bitsRequired method bitsSent - storedLength fixedLength dynamicLength - blTree lTree dTree blBits blFreq | - - lastFlag _ lastBlock ifTrue:[1] ifFalse:[0]. - - "Compute the literal/length and distance tree" - lTree _ ZipEncoderTree buildTreeFrom: literalFreq maxDepth: MaxBits. - dTree _ ZipEncoderTree buildTreeFrom: distanceFreq maxDepth: MaxBits. - - "Compute the bit length tree" - blBits _ lTree bitLengths, dTree bitLengths. - blFreq _ WordArray new: MaxBitLengthCodes. - self scanBitLengths: blBits into: blFreq. - blTree _ ZipEncoderTree buildTreeFrom: blFreq maxDepth: MaxBitLengthBits. - - "Compute the bit length for the current block. - Note: Most of this could be computed on the fly but it's getting - really ugly in this case so we do it afterwards." - storedLength _ self storedBlockSize. - fixedLength _ self fixedBlockSizeFor: lTree and: dTree. - dynamicLength _ self dynamicBlockSizeFor: lTree and: dTree - using: blTree and: blFreq. - VerboseLevel > 1 ifTrue:[ - Transcript newLine; show:'Block sizes (S/F/D):'; - space; print: storedLength // 8; - nextPut:$/; print: fixedLength // 8; - nextPut:$/; print: dynamicLength // 8; space; endEntry]. - - "Check which method to use" - method _ self forcedMethod. - method ifNil: [ - method _ (storedLength < fixedLength and:[storedLength < dynamicLength]) - ifTrue:[#stored] - ifFalse:[fixedLength < dynamicLength ifTrue:[#fixed] ifFalse:[#dynamic]]]. - (method == #stored and:[blockStart < 0]) ifTrue:[ - "Cannot use #stored if the block is not available" - method _ fixedLength < dynamicLength ifTrue:[#fixed] ifFalse:[#dynamic]]. - - bitsSent _ encoder bitPosition. "# of bits sent before this block" - bitsRequired _ nil. - - (method == #stored) ifTrue:[ - VerboseLevel > 0 ifTrue:[Transcript show:'S']. - bitsRequired _ storedLength. - encoder nextBits: 3 put: StoredBlock << 1 + lastFlag. - self sendStoredBlock]. - - (method == #fixed) ifTrue:[ - VerboseLevel > 0 ifTrue:[Transcript show:'F']. - bitsRequired _ fixedLength. - encoder nextBits: 3 put: FixedBlock << 1 + lastFlag. - self sendFixedBlock]. - - (method == #dynamic) ifTrue:[ - VerboseLevel > 0 ifTrue:[Transcript show:'D']. - bitsRequired _ dynamicLength. - encoder nextBits: 3 put: DynamicBlock << 1 + lastFlag. - self sendDynamicBlock: blTree - literalTree: lTree - distanceTree: dTree - bitLengths: blBits]. - - bitsRequired = (encoder bitPosition - bitsSent) - ifFalse:[self error:'Bits size mismatch']. - - lastBlock - ifTrue:[self release] - ifFalse:[self initializeNewBlock].! ! -!ZipWriteStream methodsFor: 'accessing' stamp: 'ar 12/29/1999 18:32'! - forcedMethod - "Return a symbol describing an enforced method or nil if the method should - be chosen adaptively. Valid symbols are - #stored - store blocks (do not compress) - #fixed - use fixed huffman trees - #dynamic - use dynamic huffman trees." - ^nil! ! -!ZipWriteStream methodsFor: 'initialization' stamp: 'ar 12/30/1999 00:40'! - initialize - super initialize. - literals _ ByteArray new: WindowSize. - distances _ WordArray new: WindowSize. - literalFreq _ WordArray new: MaxLiteralCodes. - distanceFreq _ WordArray new: MaxDistCodes. - self initializeNewBlock. -! ! -!ZipWriteStream methodsFor: 'initialization' stamp: 'ar 12/29/1999 18:29'! - initializeNewBlock - "Initialize the encoder for a new block of data" - literalFreq atAllPut: 0. - distanceFreq atAllPut: 0. - literalFreq at: EndBlock+1 put: 1. - litCount _ 0. - matchCount _ 0.! ! -!ZipWriteStream methodsFor: 'private' stamp: 'ar 2/24/2001 19:45'! - moveContentsToFront - "Need to update crc here" - self updateCrc. - super moveContentsToFront. - crcPosition _ position + 1.! ! -!ZipWriteStream methodsFor: 'initialization' stamp: 'ar 2/24/2001 19:43'! - on: aCollectionOrStream - crc _ 16rFFFFFFFF. - crcPosition _ 1. - bytesWritten _ 0. - encoder _ ZipEncoder on: aCollectionOrStream. - encoder isBinary - ifTrue:[super on: ByteArray new] - ifFalse:[super on: String new]. - self writeHeader. -! ! -!ZipWriteStream methodsFor: 'initialization' stamp: 'nk 2/17/2004 16:31'! - release - "We're done with compression. Do some cleanup." - literals _ distances _ literalFreq _ distanceFreq _ nil. - self updateCrc. - encoder flushBits. - self writeFooter.! ! -!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 11:55'! - scanBitLength: bitLength repeatCount: repeatCount into: anArray - "Update the frequency for the aTree based on the given values" - | count | - count _ repeatCount. - bitLength = 0 ifTrue:[ - [count >= 11] whileTrue:[ - anArray at: Repeat11To138+1 put: (anArray at: Repeat11To138+1) + 1. - count _ (count - 138) max: 0]. - [count >= 3] whileTrue:[ - anArray at: Repeat3To10+1 put: (anArray at: Repeat3To10+1) + 1. - count _ (count - 10) max: 0]. - count > 0 ifTrue:[anArray at: bitLength+1 put: (anArray at: bitLength+1) + count]. - ] ifFalse:[ - anArray at: bitLength+1 put: (anArray at: bitLength+1) + 1. - count _ count - 1. - [count >= 3] whileTrue:[ - anArray at: Repeat3To6+1 put: (anArray at: Repeat3To6+1) + 1. - count _ (count - 6) max: 0]. - count > 0 ifTrue:[anArray at: bitLength+1 put: (anArray at: bitLength+1) + count]. - ].! ! -!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 11:55'! - scanBitLengths: bits into: anArray - "Scan the trees and determine the frequency of the bit lengths. - For repeating codes, emit a repeat count." - | lastValue lastCount value | - bits size = 0 ifTrue:[^self]. - lastValue _ bits at: 1. - lastCount _ 1. - 2 to: bits size do:[:i| - value _ bits at: i. - value = lastValue - ifTrue:[lastCount _ lastCount + 1] - ifFalse:[self scanBitLength: lastValue repeatCount: lastCount into: anArray. - lastValue _ value. - lastCount _ 1]]. - self scanBitLength: lastValue repeatCount: lastCount into: anArray.! ! -!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 11:40'! - sendBitLength: bitLength repeatCount: repeatCount tree: aTree - "Send the given bitLength, repeating repeatCount times" - | count | - count _ repeatCount. - bitLength = 0 ifTrue:[ - [count >= 11] whileTrue:[ - self sendBitLength: Repeat11To138 tree: aTree. - encoder nextBits: 7 put: (count min: 138) - 11. - count _ (count - 138) max: 0]. - [count >= 3] whileTrue:[ - self sendBitLength: Repeat3To10 tree: aTree. - encoder nextBits: 3 put: (count min: 10) - 3. - count _ (count - 10) max: 0]. - count timesRepeat:[self sendBitLength: bitLength tree: aTree]. - ] ifFalse:[ - self sendBitLength: bitLength tree: aTree. - count _ count - 1. - [count >= 3] whileTrue:[ - self sendBitLength: Repeat3To6 tree: aTree. - encoder nextBits: 2 put: (count min: 6) - 3. - count _ (count - 6) max: 0]. - count timesRepeat:[self sendBitLength: bitLength tree: aTree]. - ].! ! -!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 11:40'! - sendBitLength: bitLength tree: aTree - "Send the given bitLength" - encoder nextBits: (aTree bitLengthAt: bitLength) - put: (aTree codeAt: bitLength).! ! -!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 11:40'! - sendBitLengthTree: blTree - "Send the bit length tree" - | blIndex bitLength | - MaxBitLengthCodes to: 4 by: -1 do:[:maxIndex| - blIndex _ BitLengthOrder at: maxIndex. - bitLength _ blIndex <= blTree maxCode - ifTrue:[blTree bitLengthAt: blIndex] ifFalse:[0]. - (maxIndex = 4 or:[bitLength > 0]) ifTrue:[ - encoder nextBits: 4 put: maxIndex - 4. - 1 to: maxIndex do:[:j| - blIndex _ BitLengthOrder at: j. - bitLength _ blIndex <= blTree maxCode - ifTrue:[blTree bitLengthAt: blIndex] ifFalse:[0]. - encoder nextBits: 3 put: bitLength]. - ^self]].! ! -!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 00:48'! - sendCompressedBlock: litTree with: distTree - "Send the current block using the encodings from the given literal/length and distance tree" - | sum | - sum _ encoder - sendBlock: (ReadStream on: literals from: 1 to: litCount) - with: (ReadStream on: distances from: 1 to: litCount) - with: litTree - with: distTree. - sum = (blockPosition - blockStart) ifFalse:[self error:'Wrong number of bytes'].! ! -!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/29/1999 18:19'! - sendDynamicBlock: blTree literalTree: lTree distanceTree: dTree bitLengths: bits - "Send a block using dynamic huffman trees" - self sendLiteralTree: lTree distanceTree: dTree using: blTree bitLengths: bits. - self sendCompressedBlock: lTree with: dTree.! ! -!ZipWriteStream methodsFor: 'fixed blocks' stamp: 'ar 12/29/1999 18:18'! - sendFixedBlock - "Send a block using fixed huffman trees" - self sendCompressedBlock: FixedLiteralTree with: FixedDistanceTree.! ! -!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 11:40'! - sendLiteralTree: lTree distanceTree: dTree using: blTree bitLengths: bits - "Send all the trees needed for dynamic huffman tree encoding" - | lastValue lastCount value | - encoder nextBits: 5 put: (lTree maxCode - 256). - encoder nextBits: 5 put: (dTree maxCode). - self sendBitLengthTree: blTree. - bits size = 0 ifTrue:[^self]. - lastValue _ bits at: 1. - lastCount _ 1. - 2 to: bits size do:[:i| - value _ bits at: i. - value = lastValue - ifTrue:[lastCount _ lastCount + 1] - ifFalse:[self sendBitLength: lastValue repeatCount: lastCount tree: blTree. - lastValue _ value. - lastCount _ 1]]. - self sendBitLength: lastValue repeatCount: lastCount tree: blTree.! ! -!ZipWriteStream methodsFor: 'stored blocks' stamp: 'ar 1/2/2000 16:36'! - sendStoredBlock - "Send an uncompressed block" - | inBytes | - inBytes _ blockPosition - blockStart. - encoder flushBits. "Skip to byte boundary" - encoder nextBits: 16 put: inBytes. - encoder nextBits: 16 put: (inBytes bitXor: 16rFFFF). - encoder flushBits. - 1 to: inBytes do:[:i| - encoder nextBytePut: (collection byteAt: blockStart+i)].! ! -!ZipWriteStream methodsFor: 'encoding' stamp: 'ar 12/29/1999 18:08'! - shouldFlush - "Check if we should flush the current block. - Flushing can be useful if the input characteristics change." - | nLits | - litCount = literals size ifTrue:[^true]. "We *must* flush" - (litCount bitAnd: 16rFFF) = 0 ifFalse:[^false]. "Only check every N kbytes" - matchCount * 10 <= litCount ifTrue:[ - "This is basically random data. - There is no need to flush early since the overhead - for encoding the trees will add to the overall size" - ^false]. - "Try to adapt to the input data. - We flush if the ratio between matches and literals - changes beyound a certain threshold" - nLits _ litCount - matchCount. - nLits <= matchCount ifTrue:[^false]. "whow!! so many matches" - ^nLits * 4 <= matchCount! ! -!ZipWriteStream methodsFor: 'stored blocks' stamp: 'ar 12/30/1999 00:42'! - storedBlockSize - "Compute the length for the current block when stored as is" - ^3 "block type bits" - + (8 - (encoder bitPosition + 3 bitAnd: 7) bitAnd: 7)"skipped bits to byte boundary" - + 32 "byte length + chksum" - + (blockPosition - blockStart * 8) "actual data bits".! ! -!ZipWriteStream methodsFor: 'private' stamp: 'ar 2/24/2001 19:45'! - updateCrc - crcPosition <= position ifTrue:[ - bytesWritten _ bytesWritten + position - crcPosition + 1. - crc _ self updateCrc: crc from: crcPosition to: position in: collection. - crcPosition _ position + 1].! ! -!ZipWriteStream methodsFor: 'private' stamp: 'nk 2/17/2004 16:51'! - updateCrc: oldCrc from: start to: stop in: aCollection - ^self class updateCrc: oldCrc from: start to: stop in: aCollection! ! -!ZipWriteStream methodsFor: 'initialization' stamp: 'nk 2/17/2004 16:30'! - writeFooter - "Write footer information if necessary" - crc _ crc bitXor: 16rFFFFFFFF.! ! -!ZipWriteStream methodsFor: 'initialization' stamp: 'ar 2/24/2001 19:44'! - writeHeader - "Write header information if necessary"! ! -!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/30/1999 15:55'! - baseDistance - ^BaseDistance! ! -!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/30/1999 15:55'! - baseLength - ^BaseLength! ! -!ZipWriteStream class methodsFor: 'regression test' stamp: 'jmv 7/17/2017 15:51:45'! - compressAndDecompress: aFile using: tempName stats: stats - | fileSize tempFile result | - aFile - ifNil: [^ nil]. - fileSize _ aFile size. - (fileSize < 1"00000" "or:[fileSize > 1000000]") ifTrue:[aFile close. ^nil]. - Transcript newLine; show:'Testing ', aFile name,' ... '. - tempFile _ StandardFileStream new open: tempName forWrite: true. - 'Compressing ', aFile name,'...' displayProgressAt: Sensor mousePoint - from: 1 to: aFile size during:[:barBlock| - result _ self regressionCompress: aFile into: tempFile notifiying: barBlock stats: stats]. - result ifTrue:[ - 'Validating ', aFile name,'...' displayProgressAt: Sensor mousePoint - from: 0 to: aFile size during:[:barBlock| - result _ self regressionDecompress: aFile from: tempFile notifying: barBlock stats: stats]]. - aFile close. - tempFile close. - (DirectoryEntry smalltalkImageDirectory // tempName) delete. - result ~~ false ifTrue:[ - Transcript show:' ok (', (result * 100 truncateTo: 0.01) printString,')']. - ^result! ! -!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 2/24/2001 19:42'! - crcTable - ^CrcTable! ! -!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/29/1999 20:42'! - distanceCodes - ^DistanceCodes! ! -!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/30/1999 15:55'! - extraDistanceBits - ^ExtraDistanceBits! ! -!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/30/1999 15:55'! - extraLengthBits - ^ExtraLengthBits! ! -!ZipWriteStream class methodsFor: 'class initialization' stamp: 'ar 5/18/2003 19:10'! - initialize - "ZipWriteStream initialize" - VerboseLevel := 0. - self initializeCrcTable.! ! -!ZipWriteStream class methodsFor: 'class initialization' stamp: 'ar 2/24/2001 19:42'! - initializeCrcTable - "ZipWriteStream initialize" - CrcTable _ #(16r00000000 16r77073096 16rEE0E612C 16r990951BA 16r076DC419 - 16r706AF48F 16rE963A535 16r9E6495A3 16r0EDB8832 16r79DCB8A4 - 16rE0D5E91E 16r97D2D988 16r09B64C2B 16r7EB17CBD 16rE7B82D07 - 16r90BF1D91 16r1DB71064 16r6AB020F2 16rF3B97148 16r84BE41DE - 16r1ADAD47D 16r6DDDE4EB 16rF4D4B551 16r83D385C7 16r136C9856 - 16r646BA8C0 16rFD62F97A 16r8A65C9EC 16r14015C4F 16r63066CD9 - 16rFA0F3D63 16r8D080DF5 16r3B6E20C8 16r4C69105E 16rD56041E4 - 16rA2677172 16r3C03E4D1 16r4B04D447 16rD20D85FD 16rA50AB56B - 16r35B5A8FA 16r42B2986C 16rDBBBC9D6 16rACBCF940 16r32D86CE3 - 16r45DF5C75 16rDCD60DCF 16rABD13D59 16r26D930AC 16r51DE003A - 16rC8D75180 16rBFD06116 16r21B4F4B5 16r56B3C423 16rCFBA9599 - 16rB8BDA50F 16r2802B89E 16r5F058808 16rC60CD9B2 16rB10BE924 - 16r2F6F7C87 16r58684C11 16rC1611DAB 16rB6662D3D 16r76DC4190 - 16r01DB7106 16r98D220BC 16rEFD5102A 16r71B18589 16r06B6B51F - 16r9FBFE4A5 16rE8B8D433 16r7807C9A2 16r0F00F934 16r9609A88E - 16rE10E9818 16r7F6A0DBB 16r086D3D2D 16r91646C97 16rE6635C01 - 16r6B6B51F4 16r1C6C6162 16r856530D8 16rF262004E 16r6C0695ED - 16r1B01A57B 16r8208F4C1 16rF50FC457 16r65B0D9C6 16r12B7E950 - 16r8BBEB8EA 16rFCB9887C 16r62DD1DDF 16r15DA2D49 16r8CD37CF3 - 16rFBD44C65 16r4DB26158 16r3AB551CE 16rA3BC0074 16rD4BB30E2 - 16r4ADFA541 16r3DD895D7 16rA4D1C46D 16rD3D6F4FB 16r4369E96A - 16r346ED9FC 16rAD678846 16rDA60B8D0 16r44042D73 16r33031DE5 - 16rAA0A4C5F 16rDD0D7CC9 16r5005713C 16r270241AA 16rBE0B1010 - 16rC90C2086 16r5768B525 16r206F85B3 16rB966D409 16rCE61E49F - 16r5EDEF90E 16r29D9C998 16rB0D09822 16rC7D7A8B4 16r59B33D17 - 16r2EB40D81 16rB7BD5C3B 16rC0BA6CAD 16rEDB88320 16r9ABFB3B6 - 16r03B6E20C 16r74B1D29A 16rEAD54739 16r9DD277AF 16r04DB2615 - 16r73DC1683 16rE3630B12 16r94643B84 16r0D6D6A3E 16r7A6A5AA8 - 16rE40ECF0B 16r9309FF9D 16r0A00AE27 16r7D079EB1 16rF00F9344 - 16r8708A3D2 16r1E01F268 16r6906C2FE 16rF762575D 16r806567CB - 16r196C3671 16r6E6B06E7 16rFED41B76 16r89D32BE0 16r10DA7A5A - 16r67DD4ACC 16rF9B9DF6F 16r8EBEEFF9 16r17B7BE43 16r60B08ED5 - 16rD6D6A3E8 16rA1D1937E 16r38D8C2C4 16r4FDFF252 16rD1BB67F1 - 16rA6BC5767 16r3FB506DD 16r48B2364B 16rD80D2BDA 16rAF0A1B4C - 16r36034AF6 16r41047A60 16rDF60EFC3 16rA867DF55 16r316E8EEF - 16r4669BE79 16rCB61B38C 16rBC66831A 16r256FD2A0 16r5268E236 - 16rCC0C7795 16rBB0B4703 16r220216B9 16r5505262F 16rC5BA3BBE - 16rB2BD0B28 16r2BB45A92 16r5CB36A04 16rC2D7FFA7 16rB5D0CF31 - 16r2CD99E8B 16r5BDEAE1D 16r9B64C2B0 16rEC63F226 16r756AA39C - 16r026D930A 16r9C0906A9 16rEB0E363F 16r72076785 16r05005713 - 16r95BF4A82 16rE2B87A14 16r7BB12BAE 16r0CB61B38 16r92D28E9B - 16rE5D5BE0D 16r7CDCEFB7 16r0BDBDF21 16r86D3D2D4 16rF1D4E242 - 16r68DDB3F8 16r1FDA836E 16r81BE16CD 16rF6B9265B 16r6FB077E1 - 16r18B74777 16r88085AE6 16rFF0F6A70 16r66063BCA 16r11010B5C - 16r8F659EFF 16rF862AE69 16r616BFFD3 16r166CCF45 16rA00AE278 - 16rD70DD2EE 16r4E048354 16r3903B3C2 16rA7672661 16rD06016F7 - 16r4969474D 16r3E6E77DB 16rAED16A4A 16rD9D65ADC 16r40DF0B66 - 16r37D83BF0 16rA9BCAE53 16rDEBB9EC5 16r47B2CF7F 16r30B5FFE9 - 16rBDBDF21C 16rCABAC28A 16r53B39330 16r24B4A3A6 16rBAD03605 - 16rCDD70693 16r54DE5729 16r23D967BF 16rB3667A2E 16rC4614AB8 - 16r5D681B02 16r2A6F2B94 16rB40BBE37 16rC30C8EA1 16r5A05DF1B - 16r2D02EF8D -).! ! -!ZipWriteStream class methodsFor: 'regression test' stamp: 'pb 5/25/2016 01:30'! - logProblem: reason for: aFile - - 'problems.log' asFileEntry appendStreamDo: [ :errFile | - errFile - newLine; - nextPutAll: aFile name; - newLine; - nextPutAll: reason ]. - Transcript show:' failed (', reason,')'. - aFile close. - ^false! ! -!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/29/1999 20:42'! - matchLengthCodes - ^MatchLengthCodes! ! -!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/29/1999 20:53'! - maxDistanceCodes - ^MaxDistCodes! ! -!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/29/1999 20:53'! - maxLiteralCodes - ^MaxLiteralCodes! ! -!ZipWriteStream class methodsFor: 'regression test' stamp: 'jmv 1/9/2014 23:32'! - printRegressionStats: stats from: fd - | raw compressed numFiles | - raw _ stats at: #rawSize ifAbsent:[0]. - raw = 0 ifTrue:[^self]. - compressed _ stats at: #compressedSize ifAbsent:[0]. - numFiles _ stats at: #numFiles ifAbsent:[0]. - Transcript newLine; nextPutAll: fd pathName. - Transcript newLine; tab; nextPutAll:'Files compressed: ', numFiles printStringWithCommas. - Transcript newLine; tab; nextPutAll:'Bytes compressed: ', raw printStringWithCommas. - Transcript newLine; tab; nextPutAll:'Avg. compression ratio: '; - print: ((compressed / raw asFloat * 100.0) truncateTo: 0.01). - Transcript endEntry.! ! -!ZipWriteStream class methodsFor: 'regression test' stamp: 'jmv 7/17/2017 15:52:09'! - regressionCompress: aFile into: tempFile notifiying: progressBarBlock stats: stats - "Compress aFile into tempFile" - | zip encoded buffer | - aFile binary. - aFile position: 0. - tempFile binary. - buffer _ ByteArray new: 4096. - zip _ self on: (ByteArray new: 10000). - encoded _ zip encodedStream. - [aFile atEnd] whileFalse:[ - progressBarBlock value: aFile position. - zip nextPutAll: (aFile nextInto: buffer). - encoded position > 0 ifTrue:[ - tempFile nextPutAll: encoded contents. - encoded position: 0]]. - zip close. - tempFile nextPutAll: encoded contents. - ^true! ! -!ZipWriteStream class methodsFor: 'regression test' stamp: 'jmv 7/17/2017 15:52:23'! - regressionDecompress: aFile from: tempFile notifying: progressBarBlock stats: stats - "Validate aFile as decompressed from tempFile" - | unzip rawSize compressedSize buffer1 buffer2 | - rawSize _ aFile size. - compressedSize _ tempFile size. - aFile ascii. - aFile position: 0. - tempFile ascii. - tempFile position: 0. - buffer1 _ ByteArray new: 4096. - buffer2 _ buffer1 copy. - unzip _ FastInflateStream on: tempFile. - [aFile atEnd] whileFalse:[ - progressBarBlock value: aFile position. - buffer1 _ aFile nextInto: buffer1. - buffer2 _ unzip nextInto: buffer2. - buffer1 = buffer2 - ifFalse:[^self logProblem: 'contents ' for: aFile]. - ]. - unzip next ifNotNil: [ ^self logProblem: 'EOF' for: aFile]. - stats at: #rawSize put: - (stats at: #rawSize ifAbsent:[0]) + rawSize. - stats at: #compressedSize put: - (stats at: #compressedSize ifAbsent:[0]) + compressedSize. - ^compressedSize asFloat / rawSize asFloat.! ! -!ZipWriteStream class methodsFor: 'regression test' stamp: 'pb 5/25/2016 01:16'! - regressionTest - " - ZipWriteStream regressionTest - " - "Compress and decompress everything we can - find to validate that compression works as expected." - self regressionTestFrom: DirectoryEntry smalltalkImageDirectory! ! -!ZipWriteStream class methodsFor: 'regression test' stamp: 'pb 5/25/2016 01:16'! - regressionTestFrom: fd - "ZipWriteStream regressionTestFrom: FileDirectory currentDirectory" - "ZipWriteStream regressionTestFrom: (FileDirectory on:'')" - "ZipWriteStream regressionTestFrom: (FileDirectory on:'C:')" - | stats entry | - Transcript clear. - stats _ Dictionary new. - entry _ (DirectoryEntry smalltalkImageDirectory // '$$sqcompress$$'). - entry exists ifTrue: [ entry delete ]. - self regressionTestFrom: fd using: entry pathName stats: stats.! ! -!ZipWriteStream class methodsFor: 'regression test' stamp: 'jmv 11/3/2016 10:22:29'! - regressionTestFrom: fd using: tempName stats: stats - | files file fullName | - files _ fd fileNames asArray sort. - files do: [ :fName | - file _ nil. - fullName _ (fd // fName) pathName. - fullName = tempName ifFalse: [ - file _ StandardFileStream new - open: fullName - forWrite: false ]. - self - compressAndDecompress: file - using: tempName - stats: stats ]. - stats - at: #numFiles - put: - (stats - at: #numFiles - ifAbsent: [ 0 ]) + files size. - files _ nil. - self - printRegressionStats: stats - from: fd. - fd directoryNames asArray sort do: [ :dName | - self - regressionTestFrom: fd / dName - using: tempName - stats: stats ].! ! -!ZipWriteStream class methodsFor: 'crc' stamp: 'nk 2/17/2004 16:50'! - updateCrc: oldCrc from: start to: stop in: aCollection - | newCrc | - - newCrc _ oldCrc. - start to: stop do:[:i| - newCrc _ (CrcTable at: ((newCrc bitXor: (aCollection byteAt: i)) - bitAnd: 255) + 1) bitXor: (newCrc bitShift: -8). - ]. - ^newCrc! ! -!GZipWriteStream methodsFor: 'initialization' stamp: 'nk 2/19/2004 08:31'! - writeFooter - "Write some footer information for the crc" - super writeFooter. - 0 to: 3 do:[:i| encoder nextBytePut: (crc >> (i*8) bitAnd: 255)]. - 0 to: 3 do:[:i| encoder nextBytePut: (bytesWritten >> (i*8) bitAnd: 255)].! ! -!GZipWriteStream methodsFor: 'initialization' stamp: 'ar 12/30/1999 11:41'! - writeHeader - "Write the GZip header" - encoder nextBits: 16 put: GZipMagic. - encoder nextBits: 8 put: GZipDeflated. - encoder nextBits: 8 put: 0. "No flags" - encoder nextBits: 32 put: 0. "no time stamp" - encoder nextBits: 8 put: 0. "No extra flags" - encoder nextBits: 8 put: 0. "No OS type" -! ! -!GZipWriteStream class methodsFor: 'file list services' stamp: 'pb 5/25/2016 01:50'! - compressFile: fileName - "Create a compressed file from the file of the given name" - - (fileName asFileEntry readStream) compressFile! ! -!GZipWriteStream class methodsFor: 'file list services' stamp: 'jmv 1/11/2013 12:52'! - fileReaderServicesForFile: fullName suffix: suffix - "FileList buttons that are serviced by us." - "Don't offer to compress already-compressed files - sjc 3-May 2003-added jpeg extension" - - ^({ 'gz' . 'sar' . 'zip' . 'gif' . 'jpg' . 'jpeg'. 'pr'. 'png' } includes: suffix) - ifTrue: [ #() ] - ifFalse: [ { self serviceCompressFile } ] -! ! -!GZipWriteStream class methodsFor: 'file list services' stamp: 'jmv 4/19/2011 11:19'! - serviceCompressFile - - ^ (SimpleServiceEntry - provider: self - label: 'compress file' - selector: #compressFile: - description: 'compress file using gzip compression, making a new file') triggerFileListChanged! ! -!ZLibWriteStream methodsFor: 'initialization' stamp: 'nk 2/17/2004 16:28'! - on: aCollectionOrStream - super on: aCollectionOrStream. - crc _ 1.! ! -!ZLibWriteStream methodsFor: 'initialization' stamp: 'nk 2/17/2004 16:53'! - updateCrc: adler from: start to: stop in: aCollection - "Update crc using the Adler32 checksum technique from RFC1950" - ^self class updateAdler32: adler from: start to: stop in: aCollection! ! -!ZLibWriteStream methodsFor: 'initialization' stamp: 'ar 2/29/2004 04:40'! - writeFooter - "Store the Adler32 checksum as the last 4 bytes." - 3 to: 0 by: -1 do:[:i| encoder nextBytePut: (crc >> (i*8) bitAnd: 255)].! ! -!ZLibWriteStream methodsFor: 'initialization' stamp: 'nk 2/17/2004 18:23'! - writeHeader - "Write header information" - encoder nextBits: 8 put: 120. "deflate method with 15bit window size" - encoder nextBits: 8 put: 94. "checksum; no preset; fast (flevel=1) compression"! ! -!ZLibWriteStream class methodsFor: 'crc' stamp: 'ar 4/14/2010 19:50'! - updateAdler32: adler from: start to: stop in: aCollection - "Update crc using the Adler32 checksum technique from RFC1950" -" - unsigned long s1 = adler & 0xffff; - unsigned long s2 = (adler >> 16) & 0xffff; - int n; - - for (n = 0; n < len; n++) { - s1 = (s1 + buf[n]) % BASE; - s2 = (s2 + s1) % BASE; - } - return (s2 << 16) + s1; -" - | s1 s2 | - - s1 := adler bitAnd: 16rFFFF. - s2 := (adler bitShift: -16) bitAnd: 16rFFFF. - start to: stop do: [ :n | | b | - b := aCollection byteAt: n. - s1 := (s1 + b) \\ 65521. - s2 := (s2 + s1) \\ 65521. ]. - ^(s2 bitShift: 16) + s1! ! -!ZipEncoder methodsFor: 'accessing' stamp: 'ar 12/30/1999 00:45'! - bitPosition - ^encodedStream position + position * 8 + bitPosition.! ! -!ZipEncoder methodsFor: 'initialization' stamp: 'sd 1/30/2004 15:24'! - close - self flush. - encodedStream close.! ! -!ZipEncoder methodsFor: 'initialization' stamp: 'ar 12/30/1999 15:51'! - commit - encodedStream next: position putAll: collection. - position _ readLimit _ 0.! ! -!ZipEncoder methodsFor: 'accessing' stamp: 'ar 12/30/1999 00:37'! - encodedStream - ^encodedStream! ! -!ZipEncoder methodsFor: 'initialization' stamp: 'ar 12/30/1999 15:51'! - flush - self flushBits. - self commit.! ! -!ZipEncoder methodsFor: 'initialization' stamp: 'ar 1/2/2000 16:35'! - flushBits - "Flush currently unsent bits" - [bitPosition > 0] whileTrue:[ - self nextBytePut: (bitBuffer bitAnd: 255). - bitBuffer _ bitBuffer bitShift: -8. - bitPosition _ bitPosition - 8]. - bitPosition _ 0.! ! -!ZipEncoder methodsFor: 'accessing' stamp: 'ar 1/2/2000 16:34'! - nextBits: nBits put: value - "Store a value of nBits" - "self assert:[value >= 0 and:[(1 bitShift: nBits) > value]]." - bitBuffer _ bitBuffer bitOr: (value bitShift: bitPosition). - bitPosition _ bitPosition + nBits. - [bitPosition >= 8] whileTrue:[ - self nextBytePut: (bitBuffer bitAnd: 255). - bitBuffer _ bitBuffer bitShift: -8. - bitPosition _ bitPosition - 8].! ! -!ZipEncoder methodsFor: 'accessing' stamp: 'ar 1/2/2000 16:34'! - nextBytePut: 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." - - - position >= writeLimit - ifTrue: [^ self pastEndPut: anObject] - ifFalse: - [position _ position + 1. - ^collection byteAt: position put: anObject]! ! -!ZipEncoder methodsFor: 'initialization' stamp: 'jmv 2/17/2010 22:09'! - on: aCollectionOrStream - (aCollectionOrStream is: #Stream) - ifTrue:[encodedStream _ aCollectionOrStream] - ifFalse:[ encodedStream _ WriteStream on: aCollectionOrStream]. - encodedStream isBinary - ifTrue:[super on: (ByteArray new: 4096)] - ifFalse:[super on: (String new: 4096)]. - bitPosition _ bitBuffer _ 0.! ! -!ZipEncoder methodsFor: 'private' stamp: 'ar 1/2/2000 16:38'! - pastEndPut: anObject - "Flush the current buffer and store the new object at the beginning" - self commit. - ^self nextBytePut: anObject asInteger! ! -!ZipEncoder methodsFor: 'private' stamp: 'ar 2/2/2001 15:47'! - privateSendBlock: literalStream with: distanceStream with: litTree with: distTree - "Send the current block using the encodings from the given literal/length and distance tree" - | lit dist code extra sum | - - sum _ 0. - [lit _ literalStream next. - dist _ distanceStream next. - lit == nil] whileFalse:[ - dist = 0 ifTrue:["lit is a literal" - sum _ sum + 1. - self nextBits: (litTree bitLengthAt: lit) - put: (litTree codeAt: lit). - ] ifFalse:["lit is match length" - sum _ sum + lit + MinMatch. - code _ (MatchLengthCodes at: lit + 1). - self nextBits: (litTree bitLengthAt: code) - put: (litTree codeAt: code). - extra _ ExtraLengthBits at: code-NumLiterals. - extra = 0 ifFalse:[ - lit _ lit - (BaseLength at: code-NumLiterals). - self nextBits: extra put: lit. - ]. - dist _ dist - 1. - dist < 256 - ifTrue:[code _ DistanceCodes at: dist + 1] - ifFalse:[code _ DistanceCodes at: 257 + (dist bitShift: -7)]. - "self assert:[code < MaxDistCodes]." - self nextBits: (distTree bitLengthAt: code) - put: (distTree codeAt: code). - extra _ ExtraDistanceBits at: code+1. - extra = 0 ifFalse:[ - dist _ dist - (BaseDistance at: code+1). - self nextBits: extra put: dist. - ]. - ]. - ]. - ^sum! ! -!ZipEncoder methodsFor: 'block encoding' stamp: 'ar 12/30/1999 18:39'! - sendBlock: literalStream with: distanceStream with: litTree with: distTree - "Send the current block using the encodings from the given literal/length and distance tree" - | result | - result _ 0. - [literalStream atEnd] whileFalse:[ - result _ result + (self privateSendBlock: literalStream - with: distanceStream with: litTree with: distTree). - self commit. - ]. - self nextBits: (litTree bitLengthAt: EndBlock) put: (litTree codeAt: EndBlock). - ^result! ! -!CRCError methodsFor: 'as yet unclassified' stamp: 'nk 3/7/2004 15:56'! - isResumable - ^true! ! -!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:41'! - ascii - - self bufferStream ascii! ! -!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:42'! - binary - - self bufferStream binary! ! -!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:43'! - bufferStream - - ^bufferStream ifNil: [bufferStream _ RWBinaryOrTextStream on: (ByteArray new: 5000)]. -! ! -!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 09:26'! - close - - "we don't want to until user is really done" - - -! ! -!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:26'! - closed - - ^false! ! -!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 19:18'! - 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 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 - ]. - - "Append the object's raw data" - srefStream _ SmartRefStream on: self. - srefStream nextPut: theObject. "and all subobjects" - srefStream close. "also closes me - well it thinks it does, anyway" -! ! -!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 19:16'! - flushBuffer - - | data | - bufferStream ifNil: [^self]. - data _ bufferStream contents asByteArray. - gZipStream nextPutAll: data. - positionThusFar _ positionThusFar + data size. - bufferStream _ nil. -! ! -!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'jmv 3/13/2012 12:12'! - newLine - "Append a newLine character to the receiver. - The Cuis convention is to use lf on output." - - self bufferStream newLine! ! -!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 09:23'! - next - - ^self bufferStream next! ! -!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:42'! - nextChunkPut: aString - - self bufferStream nextChunkPut: aString! ! -!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:41'! - nextPut: aByte - - ^self bufferStream nextPut: aByte -! ! -!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:24'! - nextPutAll: aString - - ^aString writeOnGZIPByteStream: self -! ! -!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:41'! - nextPutAllBytes: aString - - ^self bufferStream nextPutAll: aString -! ! -!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 11:36'! - nextPutAllWordArray: aWordArray - - | ba hackwa hackba blt rowsAtATime sourceOrigin rowsRemaining | - - self flag: #bob. "do we need to be concerned by bytesPerElement??" - ba _ nil. - rowsAtATime _ 2000. "or 8000 bytes" - hackwa _ Form new hackBits: aWordArray. - sourceOrigin _ 0@0. - [(rowsRemaining _ hackwa height - sourceOrigin y) > 0] whileTrue: [ - rowsAtATime _ rowsAtATime min: rowsRemaining. - (ba isNil or: [ba size ~= (rowsAtATime * 4)]) ifTrue: [ - ba _ ByteArray new: rowsAtATime * 4. - hackba _ Form new hackBits: ba. - blt _ (BitBlt toForm: hackba) sourceForm: hackwa. - ]. - blt - combinationRule: Form over; - sourceOrigin: sourceOrigin; - destX: 0 destY: 0 width: 4 height: rowsAtATime; - copyBits. - self bufferStream nextPutAll: ba. - self flushBuffer. - sourceOrigin _ sourceOrigin x @ (sourceOrigin y + rowsAtATime). - ]. -! ! -!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'jmv 2/26/2016 16:19'! - nextSignedInt32Put: int32 bigEndian: bigEndian - - ^self bufferStream nextSignedInt32Put: int32 bigEndian: bigEndian! ! -!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/22/2000 18:42'! - 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. - ^s! ! -!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'ar 5/17/2001 19:08'! - 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)." - ^self nextPutAllWordArray: aCollection! ! -!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 11:22'! - originalContents - - ^'' "used only to determine if we are byte-structured"! ! -!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:26'! - padToEndWith: aChar - "We don't have pages, so we are at the end, and don't need to pad."! ! -!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 19:12'! - position - - ^self bufferStream position + positionThusFar! ! -!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 19:13'! - reallyClose - - self flushBuffer. - gZipStream close. -! ! -!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:30'! - reopen - - "ignore"! ! -!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:30'! - setToEnd - - "ignore"! ! -!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 09:21'! - skip: aNumber - - ^self bufferStream skip: aNumber -! ! -!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'jmv 3/13/2012 12:35'! - timeStamp - "Append the current time to the receiver as a String." - self bufferStream nextChunkPut: "double string quotes and !!s" - (String streamContents: [:s | Smalltalk timeStamp: s]) printString. - self bufferStream newLine! ! -!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/25/1999 19:41'! - bitLength - ^bitLength ifNil:[0]! ! -!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/30/1999 14:28'! - code - ^code ifNil:[0]! ! -!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/25/1999 21:51'! - code: aCode - self assert:[aCode >= 0 and:[(1 bitShift: bitLength) > aCode]]. - code _ aCode.! ! -!ZipEncoderNode methodsFor: 'private' stamp: 'ar 12/26/1999 10:45'! - computeHeight - ^self isLeaf - ifTrue:[height _ 0] - ifFalse:[height _ (left computeHeight max: right computeHeight) + 1].! ! -!ZipEncoderNode methodsFor: 'encoding' stamp: 'jmv 3/2/2010 11:31'! - encodeBitLength: blCounts from: aTree - | index | - "Note: If bitLength is not nil then the tree must be broken" - bitLength ifNotNil: [ self error:'Huffman tree is broken']. - bitLength _ parent - ifNil: [0] - ifNotNil: [ parent bitLength + 1]. - self isLeaf ifTrue:[ - index _ bitLength + 1. - blCounts at: index put: (blCounts at: index) + 1. - ] ifFalse:[ - left encodeBitLength: blCounts from: aTree. - right encodeBitLength: blCounts from: aTree. - ]! ! -!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/24/1999 23:36'! - frequency - ^frequency! ! -!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/28/1999 00:56'! - frequency: aNumber - frequency _ aNumber! ! -!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/26/1999 10:44'! - height - ^height! ! -!ZipEncoderNode methodsFor: 'testing' stamp: 'ar 12/24/1999 23:17'! - isLeaf - ^left == nil! ! -!ZipEncoderNode methodsFor: 'private' stamp: 'ar 12/25/1999 18:14'! - leafNodes - self isLeaf - ifTrue:[^Array with: self] - ifFalse:[^left leafNodes, right leafNodes]! ! -!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/24/1999 23:43'! - left - ^left! ! -!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/25/1999 20:06'! - left: aNode - aNode parent: self. - left _ aNode.! ! -!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/24/1999 23:43'! - parent - ^parent! ! -!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/24/1999 23:43'! - parent: aNode - parent _ aNode! ! -!ZipEncoderNode methodsFor: 'printing' stamp: 'ar 12/26/1999 10:46'! - printOn: aStream - super printOn: aStream. - aStream nextPut:$(; - nextPutAll:'value = '; print: value; - nextPutAll:', freq = '; print: frequency; - nextPutAll:', bitLength = '; print: bitLength; - nextPutAll:', code = '; print: code; - nextPutAll:', height = '; print: height; - nextPut:$).! ! -!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/24/1999 23:43'! - right - ^right! ! -!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/25/1999 20:06'! - right: aNode - aNode parent: self. - right _ aNode.! ! -!ZipEncoderNode methodsFor: 'encoding' stamp: 'ar 12/27/1999 14:27'! - rotateToHeight: maxHeight - "Rotate the tree to achieve maxHeight depth" - | newParent | - height < 4 ifTrue:[^self]. - self left: (left rotateToHeight: maxHeight-1). - self right: (right rotateToHeight: maxHeight-1). - height _ (left height max: right height) + 1. - height <= maxHeight ifTrue:[^self]. - (left height - right height) abs <= 2 ifTrue:[^self]. - left height < right height ifTrue:[ - right right height >= right left height ifTrue:[ - newParent _ right. - self right: newParent left. - newParent left: self. - ] ifFalse:[ - newParent _ right left. - right left: newParent right. - newParent right: right. - self right: newParent left. - newParent left: self. - ]. - ] ifFalse:[ - left left height >= left right height ifTrue:[ - newParent _ left. - self left: newParent right. - newParent right: self. - ] ifFalse:[ - newParent _ left right. - left right: newParent left. - newParent left: left. - self left: newParent right. - newParent right: self. - ]. - ]. - parent computeHeight. - ^parent! ! -!ZipEncoderNode methodsFor: 'private' stamp: 'ar 12/26/1999 12:05'! - setBitLengthTo: bl - bitLength _ bl! ! -!ZipEncoderNode methodsFor: 'private' stamp: 'ar 12/26/1999 10:46'! - setValue: v frequency: f height: h - value _ v. - frequency _ f. - height _ h.! ! -!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/24/1999 23:43'! - value - ^value! ! -!ZipEncoderNode class methodsFor: 'instance creation' stamp: 'ar 12/26/1999 10:47'! - value: v frequency: f height: h - ^self new setValue: v frequency: f height: h! ! -!ZipEncoderTree methodsFor: 'accessing' stamp: 'ar 12/30/1999 01:43'! - bitLengthAt: index - ^bitLengths at: index+1! ! -!ZipEncoderTree methodsFor: 'accessing' stamp: 'ar 12/30/1999 01:32'! - bitLengths - "Return an array of all bitLength values for valid codes" - ^bitLengths! ! -!ZipEncoderTree methodsFor: 'private' stamp: 'ar 12/30/1999 14:26'! - bitLengths: blArray codes: codeArray - bitLengths _ blArray as: WordArray. - codes _ codeArray as: WordArray. - self assert:[(self bitLengthAt: maxCode) > 0].! ! -!ZipEncoderTree methodsFor: 'encoding' stamp: 'ar 12/30/1999 01:34'! - buildCodes: nodeList counts: blCounts maxDepth: depth - "Build the codes for all nodes" - | nextCode code node length | - nextCode _ WordArray new: depth+1. - code _ 0. - 1 to: depth do:[:bits| - code _ (code + (blCounts at: bits)) << 1. - nextCode at: bits+1 put: code]. - self assert:[(code + (blCounts at: depth+1) - 1) = (1 << depth - 1)]. - 0 to: maxCode do:[:n| - node _ nodeList at: n+1. - length _ node bitLength. - length = 0 ifFalse:[ - code _ nextCode at: length+1. - node code: (self reverseBits: code length: length). - nextCode at: length+1 put: code+1. - ]. - ].! ! -!ZipEncoderTree methodsFor: 'encoding' stamp: 'ar 12/26/1999 10:42'! - buildHierarchyFrom: aHeap - "Build the node hierarchy based on the leafs in aHeap" - | left right parent | - [aHeap size > 1] whileTrue:[ - left _ aHeap removeFirst. - right _ aHeap removeFirst. - parent _ ZipEncoderNode value: -1 - frequency: (left frequency + right frequency) - height: (left height max: right height) + 1. - left parent: parent. - right parent: parent. - parent left: left. - parent right: right. - aHeap add: parent]. - ^aHeap removeFirst -! ! -!ZipEncoderTree methodsFor: 'encoding' stamp: 'ar 12/30/1999 14:19'! - buildTree: nodeList maxDepth: depth - "Build either the literal or the distance tree" - | heap rootNode blCounts | - heap _ Heap new: nodeList size // 3. - heap sortBlock: self nodeSortBlock. - "Find all nodes with non-zero frequency and add to heap" - maxCode _ 0. - nodeList do:[:dNode| - dNode frequency = 0 ifFalse:[ - maxCode _ dNode value. - heap add: dNode]]. - "The pkzip format requires that at least one distance code exists, - and that at least one bit should be sent even if there is only one - possible code. So to avoid special checks later on we force at least - two codes of non zero frequency." - heap size = 0 ifTrue:[ - self assert:[maxCode = 0]. - heap add: nodeList first. - heap add: nodeList second. - maxCode _ 1]. - heap size = 1 ifTrue:[ - nodeList first frequency = 0 - ifTrue:[heap add: nodeList first] - ifFalse:[heap add: nodeList second]. - maxCode _ maxCode max: 1]. - rootNode _ self buildHierarchyFrom: heap. - rootNode height > depth ifTrue:[ - rootNode _ rootNode rotateToHeight: depth. - rootNode height > depth ifTrue:[self error:'Cannot encode tree']]. - blCounts _ WordArray new: depth+1. - rootNode encodeBitLength: blCounts from: self. - self buildCodes: nodeList counts: blCounts maxDepth: depth. - self setValuesFrom: nodeList.! ! -!ZipEncoderTree methodsFor: 'encoding' stamp: 'ar 12/30/1999 01:24'! - buildTreeFrom: frequencies maxDepth: depth - "Build the receiver from the given frequency values" - | nodeList | - nodeList _ Array new: frequencies size. - 1 to: frequencies size do:[:i| - nodeList at: i put: (ZipEncoderNode value: i-1 frequency: (frequencies at: i) height: 0) - ]. - self buildTree: nodeList maxDepth: depth.! ! -!ZipEncoderTree methodsFor: 'accessing' stamp: 'ar 12/30/1999 01:04'! - codeAt: index - ^codes at: index+1! ! -!ZipEncoderTree methodsFor: 'accessing' stamp: 'ar 12/30/1999 01:24'! - codes - "Return an array of all valid codes" - ^codes! ! -!ZipEncoderTree methodsFor: 'accessing' stamp: 'ar 12/25/1999 17:15'! - maxCode - ^maxCode! ! -!ZipEncoderTree methodsFor: 'accessing' stamp: 'ar 12/25/1999 21:45'! - maxCode: aNumber - maxCode _ aNumber.! ! -!ZipEncoderTree methodsFor: 'encoding' stamp: 'ar 12/26/1999 10:42'! - nodeSortBlock - ^[:n1 :n2| - n1 frequency = n2 frequency - ifTrue:[n1 height <= n2 height] - ifFalse:[n1 frequency <= n2 frequency]].! ! -!ZipEncoderTree methodsFor: 'private' stamp: 'ar 12/26/1999 11:02'! - reverseBits: code length: length - "Bit reverse the given code" - | result bit bits | - result _ 0. - bits _ code. - 1 to: length do:[:i| - bit _ bits bitAnd: 1. - result _ result << 1 bitOr: bit. - bits _ bits >> 1]. - ^result! ! -!ZipEncoderTree methodsFor: 'private' stamp: 'ar 12/30/1999 14:26'! - setValuesFrom: nodeList - self bitLengths: (nodeList collect:[:n| n bitLength] from: 1 to: maxCode+1) - codes: (nodeList collect:[:n| n code] from: 1 to: maxCode+1).! ! -!ZipEncoderTree class methodsFor: 'instance creation' stamp: 'ar 12/30/1999 01:25'! - buildTreeFrom: frequencies maxDepth: depth - ^self new buildTreeFrom: frequencies maxDepth: depth! ! -!Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 19:09'! - addDirectory: aFileName - ^self addDirectory: aFileName as: aFileName -! ! -!Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:57'! - addDirectory: aFileName as: anotherFileName - | newMember | - newMember _ self memberClass newFromDirectory: aFileName. - self addMember: newMember. - newMember localFileName: anotherFileName. - ^newMember! ! -!Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 18:29'! - addFile: aFileName - ^self addFile: aFileName as: aFileName! ! -!Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 15:03'! - addFile: aFileName as: anotherFileName - | newMember | - newMember _ self memberClass newFromFile: aFileName. - self addMember: newMember. - newMember localFileName: anotherFileName. - ^newMember! ! -!Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 19:09'! - addMember: aMember - ^members addLast: aMember! ! -!Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 15:03'! - addString: aString as: aFileName - | newMember | - newMember _ self memberClass newFromString: aString named: aFileName. - self addMember: newMember. - newMember localFileName: aFileName. - ^newMember! ! -!Archive methodsFor: 'archive operations' stamp: 'nk 2/24/2001 14:12'! - canWriteToFileNamed: aFileName - "Catch attempts to overwrite existing zip file" - ^(members anySatisfy: [ :ea | ea usesFileNamed: aFileName ]) not. -! ! -!Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'! - contentsOf: aMemberOrName - | member | - member _ self member: aMemberOrName. - member ifNil: [ ^nil ]. - ^member contents! ! -!Archive methodsFor: 'archive operations' stamp: 'pb 5/25/2016 01:06'! - extractMember: aMemberOrName - | member | - member _ self member: aMemberOrName. - member ifNil: [ ^nil ]. - member extractToFileNamed: member localFileName inDirectory: DirectoryEntry currentDirectory! ! -!Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'! - extractMember: aMemberOrName toFileNamed: aFileName - | member | - member _ self member: aMemberOrName. - member ifNil: [ ^nil ]. - member extractToFileNamed: aFileName! ! -!Archive methodsFor: 'archive operations' stamp: 'pb 5/25/2016 01:06'! - extractMemberWithoutPath: aMemberOrName - self extractMemberWithoutPath: aMemberOrName inDirectory: DirectoryEntry currentDirectory! ! -!Archive methodsFor: 'archive operations' stamp: 'jmv 5/31/2016 10:35'! - extractMemberWithoutPath: aMemberOrName inDirectory: aDirectoryEntry - | member | - member _ self member: aMemberOrName. - member ifNil: [ ^nil ]. - member extractToFileNamed: member localFileName asFileEntry name inDirectory: aDirectoryEntry! ! -!Archive methodsFor: 'initialization' stamp: 'nk 2/21/2001 17:58'! - initialize - members _ OrderedCollection new.! ! -!Archive methodsFor: 'private' stamp: 'nk 2/22/2001 07:56'! - member: aMemberOrName - ^(members includes: aMemberOrName) - ifTrue: [ aMemberOrName ] - ifFalse: [ self memberNamed: aMemberOrName ].! ! -!Archive methodsFor: 'private' stamp: 'nk 2/21/2001 18:14'! - memberClass - self subclassResponsibility! ! -!Archive methodsFor: 'archive operations' stamp: 'jmv 3/2/2010 08:56'! - memberNamed: aString - "Return the first member whose zip name or local file name matches aString, or nil" - ^members detect: [ :ea | ea fileName = aString or: [ ea localFileName = aString ]] ifNone: nil! ! -!Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 18:00'! - memberNames - ^members collect: [ :ea | ea fileName ]! ! -!Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 17:58'! - members - ^members! ! -!Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:50'! - membersMatching: aString - ^members select: [ :ea | (aString match: ea fileName) or: [ aString match: ea localFileName ] ]! ! -!Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 17:59'! - numberOfMembers - ^members size! ! -!Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'! - removeMember: aMemberOrName - | member | - member _ self member: aMemberOrName. - member ifNotNil: [ members remove: member ]. - ^member! ! -!Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'! - replaceMember: aMemberOrName with: newMember - | member | - member _ self member: aMemberOrName. - member ifNotNil: [ members replaceAll: member with: newMember ]. - ^member! ! -!Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 17:24'! - setContentsOf: aMemberOrName to: aString - | newMember oldMember | - oldMember _ self member: aMemberOrName. - newMember _ (self memberClass newFromString: aString named: oldMember fileName) - copyFrom: oldMember. - self replaceMember: oldMember with: newMember.! ! -!Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 20:58'! - writeTo: aStream - self subclassResponsibility! ! -!Archive methodsFor: 'archive operations' stamp: 'pb 5/25/2016 01:35'! - writeToFileNamed: aFileName - - "Catch attempts to overwrite existing zip file" - (self canWriteToFileNamed: aFileName) - ifFalse: [ ^self error: (aFileName, ' is needed by one or more members in this archive') ]. - aFileName asFileEntry writeStreamDo: [ :stream | - self writeTo: stream ]! ! -!ZipArchive methodsFor: 'initialization' stamp: 'ar 3/2/2001 18:47'! - close - self members do:[:m| m close].! ! -!ZipArchive methodsFor: 'archive operations' stamp: 'jmv 7/17/2017 15:47:50'! - extractAllTo: aDirectoryEntry - "Extract all elements to the given directory" - Utilities informUserDuring: [ :barBlock | self extractAllTo: aDirectoryEntry informing: barBlock]! ! -!ZipArchive methodsFor: 'archive operations' stamp: 'jmv 7/17/2017 15:47:41'! - extractAllTo: aDirectoryEntry informing: barBlock - "Extract all elements to the given directory" - ^self extractAllTo: aDirectoryEntry informing: barBlock overwrite: false! ! -!ZipArchive methodsFor: 'archive operations' stamp: 'jmv 7/17/2017 15:50:56'! - extractAllTo: aDirectory informing: barBlock overwrite: allOverwrite - "Extract all elements to the given directory" - | dir overwriteAll response | - overwriteAll := allOverwrite. - self members do:[:entry| - entry isDirectory ifTrue:[ - barBlock ifNotNil:[barBlock value: 'Creating ', entry fileName]. - dir := (entry fileName findTokens:'/') - inject: aDirectory into:[:base :part| base / part]. - dir assureExistence. - ]. - ]. - self members do:[:entry| - entry isDirectory ifFalse:[ - barBlock ifNotNil:[barBlock value: 'Extracting ', entry fileName]. - response := entry extractInDirectory: aDirectory overwrite: overwriteAll. - response == #retryWithOverwrite ifTrue:[ - overwriteAll := true. - response := entry extractInDirectory: aDirectory overwrite: overwriteAll. - ]. - response == #abort ifTrue:[^self]. - response == #failed ifTrue:[ - (self confirm: 'Failed to extract ', entry fileName, '. Proceed?') ifFalse:[^self]. - ]. - ]. - ]. -! ! -!ZipArchive methodsFor: 'initialization' stamp: 'nk 2/22/2001 17:20'! - initialize - super initialize. - writeEOCDOffset _ writeCentralDirectoryOffset _ 0. - zipFileComment _ ''. -! ! -!ZipArchive methodsFor: 'private' stamp: 'nk 2/21/2001 18:26'! - memberClass - ^ZipArchiveMember! ! -!ZipArchive methodsFor: 'accessing' stamp: 'nk 3/27/2002 11:23'! - prependedDataSize - "Answer the size of whatever data exists before my first member. - Assumes that I was read from a file or stream (i.e. the first member is a ZipFileMember)" - ^members isEmpty - ifFalse: [ members first localHeaderRelativeOffset ] - ifTrue: [ centralDirectoryOffsetWRTStartingDiskNumber ]! ! -!ZipArchive methodsFor: 'private' stamp: 'jmv 2/26/2016 16:28'! - readEndOfCentralDirectoryFrom: aStream - "Read EOCD, starting from position before signature." - | signature zipFileCommentLength | - signature _ self readSignatureFrom: aStream. - signature = EndOfCentralDirectorySignature ifFalse: [ ^self error: 'bad signature at ', aStream position printString ]. - - aStream nextUnsignedInt16BigEndian: false. "# of this disk" - aStream nextUnsignedInt16BigEndian: false. "# of disk with central dir start" - aStream nextUnsignedInt16BigEndian: false. "# of entries in central dir on this disk" - aStream nextUnsignedInt16BigEndian: false. "total # of entries in central dir" - centralDirectorySize _ aStream nextUnsignedInt32BigEndian: false. "size of central directory" - centralDirectoryOffsetWRTStartingDiskNumber _ aStream nextUnsignedInt32BigEndian: false. "offset of start of central directory" - zipFileCommentLength _ aStream nextUnsignedInt16BigEndian: false. "zip file comment" - zipFileComment _ aStream next: zipFileCommentLength. -! ! -!ZipArchive methodsFor: 'reading' stamp: 'pb 5/25/2016 01:51'! - readFrom: aStreamOrFileName - | stream name eocdPosition | - stream _ (aStreamOrFileName is: #Stream) - ifTrue: [name _ aStreamOrFileName name. aStreamOrFileName] - ifFalse: [(name _ aStreamOrFileName) asFileEntry readStream]. - stream binary. - eocdPosition _ self class findEndOfCentralDirectoryFrom: stream. - eocdPosition <= 0 ifTrue: [self error: 'can''t find EOCD position']. - self readEndOfCentralDirectoryFrom: stream. - stream position: eocdPosition - centralDirectorySize. - self readMembersFrom: stream named: name! ! -!ZipArchive methodsFor: 'private' stamp: 'nk 2/23/2001 09:19'! - readMembersFrom: stream named: fileName - | newMember signature | - [ - newMember _ self memberClass newFromZipFile: stream named: fileName. - signature _ self readSignatureFrom: stream. - signature = EndOfCentralDirectorySignature ifTrue: [ ^self ]. - signature = CentralDirectoryFileHeaderSignature - ifFalse: [ self error: 'bad CD signature at ', (stream position - 4) hex ]. - newMember readFrom: stream. - newMember looksLikeDirectory ifTrue: [ newMember _ newMember asDirectory ]. - self addMember: newMember. - ] repeat.! ! -!ZipArchive methodsFor: 'private' stamp: 'nk 2/21/2001 20:09'! - readSignatureFrom: stream - "Returns next signature from given stream, leaves stream positioned afterwards." - - | signatureData | - signatureData _ String new: 4. - stream next: 4 into: signatureData. - ({ CentralDirectoryFileHeaderSignature . LocalFileHeaderSignature . EndOfCentralDirectorySignature } - includes: signatureData) - ifFalse: [ ^self error: 'bad signature ', signatureData asHex, ' at position ', (stream position - 4) asString ]. - ^signatureData -! ! -!ZipArchive methodsFor: 'private' stamp: 'nk 2/21/2001 20:19'! - writeCentralDirectoryTo: aStream - | offset | - offset _ writeCentralDirectoryOffset. - members do: [ :member | - member writeCentralDirectoryFileHeaderTo: aStream. - offset _ offset + member centralDirectoryHeaderSize. - ]. - writeEOCDOffset _ offset. - self writeEndOfCentralDirectoryTo: aStream. - -! ! -!ZipArchive methodsFor: 'private' stamp: 'jmv 2/26/2016 16:37'! - writeEndOfCentralDirectoryTo: aStream - - aStream nextPutAll: EndOfCentralDirectorySignature. - aStream nextUnsignedInt16Put: 0 bigEndian: false. "diskNumber" - aStream nextUnsignedInt16Put: 0 bigEndian: false. "diskNumberWithStartOfCentralDirectory" - aStream nextUnsignedInt16Put: members size bigEndian: false. "numberOfCentralDirectoriesOnThisDisk" - aStream nextUnsignedInt16Put: members size bigEndian: false. "numberOfCentralDirectories" - aStream nextUnsignedInt32Put: writeEOCDOffset - writeCentralDirectoryOffset bigEndian: false. "size of central dir" - aStream nextUnsignedInt32Put: writeCentralDirectoryOffset bigEndian: false. "offset of central dir" - aStream nextUnsignedInt16Put: zipFileComment size bigEndian: false. "zip file comment" - zipFileComment isEmpty ifFalse: [ aStream nextPutAll: zipFileComment ]. - -! ! -!ZipArchive methodsFor: 'writing' stamp: 'nk 2/23/2001 10:29'! - writeTo: stream - stream binary. - members do: [ :member | - member writeTo: stream. - member endRead. - ]. - writeCentralDirectoryOffset _ stream position. - self writeCentralDirectoryTo: stream. - ! ! -!ZipArchive methodsFor: 'writing' stamp: 'nk 3/27/2002 10:42'! - writeTo: stream prepending: aString - stream binary. - stream nextPutAll: aString. - members do: [ :member | - member writeTo: stream. - member endRead. - ]. - writeCentralDirectoryOffset _ stream position. - self writeCentralDirectoryTo: stream. - ! ! -!ZipArchive methodsFor: 'writing' stamp: 'pb 5/25/2016 01:51'! - writeTo: stream prependingFileNamed: aFileName - | prepended buffer | - stream binary. - prepended _ aFileName asFileEntry readStream. - prepended binary. - buffer _ ByteArray new: (prepended size min: 32768). - [ prepended atEnd ] whileFalse: [ | bytesRead | - bytesRead _ prepended readInto: buffer startingAt: 1 count: buffer size. - stream next: bytesRead putAll: buffer startingAt: 1 - ]. - members do: [ :member | - member writeTo: stream. - member endRead. - ]. - writeCentralDirectoryOffset _ stream position. - self writeCentralDirectoryTo: stream. - ! ! -!ZipArchive methodsFor: 'writing' stamp: 'jmv 5/31/2016 11:24'! - writeToFileNamed: aFileName prepending: aString - - "Catch attempts to overwrite existing zip file" - (self canWriteToFileNamed: aFileName) - ifFalse: [ ^self error: (aFileName, ' is needed by one or more members in this archive') ]. - aFileName asFileEntry forceWriteStreamDo: [ :stream | - self writeTo: stream prepending: aString ]! ! -!ZipArchive methodsFor: 'writing' stamp: 'jmv 5/31/2016 11:24'! - writeToFileNamed: aFileName prependingFileNamed: anotherFileName - - "Catch attempts to overwrite existing zip file" - (self canWriteToFileNamed: aFileName) - ifFalse: [ ^self error: (aFileName, ' is needed by one or more members in this archive') ]. - aFileName asFileEntry forceWriteStreamDo: [ :stream | - self writeTo: stream prependingFileNamed: anotherFileName ]! ! -!ZipArchive methodsFor: 'accessing' stamp: 'nk 2/24/2001 13:44'! - zipFileComment - ^zipFileComment asString! ! -!ZipArchive methodsFor: 'accessing' stamp: 'nk 2/24/2001 13:43'! - zipFileComment: aString - zipFileComment _ aString! ! -!ZipArchive class methodsFor: 'constants' stamp: 'nk 2/22/2001 14:13'! - compressionDeflated - ^CompressionDeflated! ! -!ZipArchive class methodsFor: 'constants' stamp: 'nk 2/22/2001 14:12'! - compressionLevelDefault - ^CompressionLevelDefault! ! -!ZipArchive class methodsFor: 'constants' stamp: 'nk 2/22/2001 14:12'! - compressionLevelNone - ^CompressionLevelNone ! ! -!ZipArchive class methodsFor: 'constants' stamp: 'nk 2/22/2001 14:13'! - compressionStored - ^CompressionStored! ! -!ZipArchive class methodsFor: 'file list services' stamp: 'jmv 6/16/2013 19:46'! - fileReaderServicesForFile: fullName suffix: suffix - "FileList buttons that are swe know about." - - suffix = 'mcz' - ifTrue: [ ^ { - CodePackageFile serviceInstallMonticelloPackage . - CodeFileBrowser serviceBrowseMCZCode - } ]. - ^#()! ! -!ZipArchive class methodsFor: 'constants' stamp: 'jmv 11/2/2010 12:40'! - findEndOfCentralDirectoryFrom: stream - "Seek in the given stream to the end, then read backwards until we find the - signature of the central directory record. Leave the file positioned right - before the signature. - - Answers the file position of the EOCD, or 0 if not found." - - | data fileLength seekOffset pos maxOffset | - stream setToEnd. - fileLength _ stream position. - "If the file length is less than 18 for the EOCD length plus 4 for the signature, we have a problem" - fileLength < 22 ifTrue: [^ self error: 'file is too short']. - - seekOffset _ 0. - pos _ 0. - data _ String new: 4100. - maxOffset _ 40960 min: fileLength. "limit search range to 40K" - - [ - seekOffset _ (seekOffset + 4096) min: fileLength. - stream position: fileLength - seekOffset. - data _ stream next: (4100 min: seekOffset) into: data startingAt: 1. - pos _ self - lastIndexOfPKSignature: EndOfCentralDirectorySignature - in: data. - pos = 0 and: [seekOffset < maxOffset] - ] whileTrue. - - ^ pos > 0 - ifTrue: [ | newPos | stream position: (newPos _ (stream position + pos - seekOffset - 1)). newPos] - ifFalse: [0]! ! -!ZipArchive class methodsFor: 'file format' stamp: 'pb 5/25/2016 01:51'! - isZipArchive: aStreamOrFileName - "Answer whether the given filename represents a valid zip file." - - | stream eocdPosition | - stream _ (aStreamOrFileName is: #Stream) - ifTrue: [aStreamOrFileName] - ifFalse: [aStreamOrFileName asFileEntry readStream ]. - stream ifNil: [^ false]. - "nil happens sometimes somehow" - stream size < 22 ifTrue: [^ false]. - stream binary. - eocdPosition _ self findEndOfCentralDirectoryFrom: stream. - stream ~= aStreamOrFileName ifTrue: [stream close]. - ^ eocdPosition > 0! ! -!ZipArchive class methodsFor: 'constants' stamp: 'ar 9/6/2010 15:28'! - lastIndexOfPKSignature: aSignature in: data - "Answer the last index in data 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. - (data size - 3) to: 1 by: -1 do: [ :i | - (((data at: i) = a) - and: [ ((data at: i + 1) = b) - and: [ ((data at: i + 2) = c) - and: [ ((data at: i + 3) = d) ]]]) - ifTrue: [ ^i ] - ]. - ^0! ! -!ZipArchive class methodsFor: 'constants' stamp: 'ar 2/27/2001 13:38'! - validSignatures - "Return the valid signatures for a zip file" - ^Array - with: LocalFileHeaderSignature - with: CentralDirectoryFileHeaderSignature - with: EndOfCentralDirectorySignature! ! -!ArchiveMember methodsFor: 'initialization' stamp: 'ar 3/2/2001 18:46'! - close -! ! -!ArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 16:00'! - fileName - ^fileName! ! -!ArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 16:00'! - fileName: aName - fileName _ aName! ! -!ArchiveMember methodsFor: 'initialization' stamp: 'nk 3/7/2004 16:05'! - initialize - fileName _ ''. - isCorrupt _ false.! ! -!ArchiveMember methodsFor: 'accessing' stamp: 'nk 3/7/2004 16:16'! - isCorrupt - ^isCorrupt ifNil: [ isCorrupt _ false ]! ! -!ArchiveMember methodsFor: 'accessing' stamp: 'nk 3/7/2004 16:06'! - isCorrupt: aBoolean - "Mark this member as being corrupt." - isCorrupt := aBoolean! ! -!ArchiveMember methodsFor: 'accessing' stamp: 'jmv 10/27/2015 18:12'! - localFileName: aString - "Set my internal filename. - Returns the (possibly new) filename. - aString will be translated from local FS format into Unix format." - - ^fileName _ aString copyReplaceAll: '\' with: '/'.! ! -!ArchiveMember methodsFor: 'printing' stamp: 'nk 12/20/2002 15:11'! - printOn: aStream - super printOn: aStream. - aStream nextPut: $(; - nextPutAll: self fileName; - nextPut: $)! ! -!ArchiveMember methodsFor: 'testing' stamp: 'nk 2/21/2001 19:43'! - usesFileNamed: aFileName - "Do I require aFileName? That is, do I care if it's clobbered?" - ^false! ! -!ArchiveMember class methodsFor: 'as yet unclassified' stamp: 'nk 2/21/2001 18:33'! - newDirectoryNamed: aString - self subclassResponsibility! ! -!ArchiveMember class methodsFor: 'as yet unclassified' stamp: 'nk 2/21/2001 18:32'! - newFromFile: aFileName - self subclassResponsibility! ! -!ArchiveMember class methodsFor: 'as yet unclassified' stamp: 'nk 2/21/2001 18:32'! - newFromString: aString - self subclassResponsibility! ! -!ZipArchiveMember methodsFor: 'private' stamp: 'nk 2/21/2001 21:55'! - asDirectory - ^ZipDirectoryMember new copyFrom: self! ! -!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 09:44'! - centralDirectoryHeaderSize - ^ 46 + fileName size + cdExtraField size + fileComment size! ! -!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/23/2001 08:00'! - clearExtraFields - cdExtraField _ ''. - localExtraField _ ''.! ! -!ZipArchiveMember methodsFor: 'private-writing' stamp: 'ar 2/28/2001 14:01'! - compressDataTo: aStream - "Copy my deflated data to the given stream." - | encoder startPos endPos | - - encoder _ ZipWriteStream on: aStream. - startPos _ aStream position. - - [ readDataRemaining > 0 ] whileTrue: [ | data | - data _ self readRawChunk: (4096 min: readDataRemaining). - encoder nextPutAll: data asByteArray. - readDataRemaining _ readDataRemaining - data size. - ]. - encoder finish. "not close!!" - endPos _ aStream position. - compressedSize _ endPos - startPos. - crc32 _ encoder crc. -! ! -!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 00:38'! - compressedSize - "Return the compressed size for this member. - This will not be set for members that were constructed from strings - or external files until after the member has been written." - ^compressedSize! ! -!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/21/2001 22:02'! - compressionMethod - "Returns my compression method. This is the method that is - currently being used to compress my data. - - This will be CompressionStored for added string or file members, - or CompressionStored or CompressionDeflated (others are possible but not handled)" - - ^compressionMethod! ! -!ZipArchiveMember methodsFor: 'reading' stamp: 'ar 2/27/2001 14:30'! - contentStream - "Answer my contents as a string." - | s | - s _ RWBinaryOrTextStream on: (String new: self uncompressedSize). - self extractTo: s. - ^s reset! ! -!ZipArchiveMember methodsFor: 'reading' stamp: 'nk 2/24/2001 22:28'! - contents - "Answer my contents as a string." - | s | - s _ RWBinaryOrTextStream on: (String new: self uncompressedSize). - self extractTo: s. - s text. - ^s contents! ! -!ZipArchiveMember methodsFor: 'reading' stamp: 'nk 2/24/2001 23:53'! - contentsFrom: start to: finish - "Answer my contents as a string." - | s | - s _ RWBinaryOrTextStream on: (String new: finish - start + 1). - self extractTo: s from: start to: finish. - s text. - ^s contents! ! -!ZipArchiveMember methodsFor: 'private-writing' stamp: 'nk 2/23/2001 11:04'! - copyDataTo: aStream - - compressionMethod = CompressionStored ifTrue: [ ^self copyDataWithCRCTo: aStream ]. - - self copyRawDataTo: aStream.! ! -!ZipArchiveMember methodsFor: 'private-writing' stamp: 'nk 3/7/2004 15:42'! - copyDataWithCRCTo: aStream - "Copy my data to aStream. Also set the CRC-32. - Only used when compressionMethod = desiredCompressionMethod = CompressionStored" - - uncompressedSize _ compressedSize _ readDataRemaining. - - crc32 _ 16rFFFFFFFF. - - [ readDataRemaining > 0 ] whileTrue: [ | data | - data _ self readRawChunk: (4096 min: readDataRemaining). - aStream nextPutAll: data. - crc32 _ ZipWriteStream updateCrc: crc32 from: 1 to: data size in: data. - readDataRemaining _ readDataRemaining - data size. - ]. - - crc32 _ crc32 bitXor: 16rFFFFFFFF. -! ! -!ZipArchiveMember methodsFor: 'private-writing' stamp: 'nk 2/23/2001 11:04'! - copyRawDataTo: aStream - - [ readDataRemaining > 0 ] whileTrue: [ | data | - data _ self readRawChunk: (4096 min: readDataRemaining). - aStream nextPutAll: data. - readDataRemaining _ readDataRemaining - data size. - ]. -! ! -!ZipArchiveMember methodsFor: 'private-writing' stamp: 'nk 2/24/2001 17:57'! - copyRawDataTo: aStream from: start to: finish - - readDataRemaining _ readDataRemaining min: finish - start + 1. - - self readRawChunk: start - 1. - - [ readDataRemaining > 0 ] whileTrue: [ | data | - data _ self readRawChunk: (32768 min: readDataRemaining). - aStream nextPutAll: data. - readDataRemaining _ readDataRemaining - data size. - ]. -! ! -!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 00:28'! - crc32 - ^crc32! ! -!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 00:35'! - crc32String - | hexString | - hexString _ crc32 hex. - ^('00000000' copyFrom: 1 to: 11 - (hexString size)) , (hexString copyFrom: 4 to: hexString size)! ! -!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/21/2001 22:10'! - desiredCompressionLevel - ^desiredCompressionLevel! ! -!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/21/2001 22:14'! - desiredCompressionLevel: aNumber - "Set my desiredCompressionLevel - This is the method that will be used to write. - Returns prior desiredCompressionLevel. - - Valid arguments are 0 (CompressionLevelNone) through 9, - including 6 (CompressionLevelDefault). - - 0 (CompressionLevelNone) will change the desiredCompressionMethod - to CompressionStored. All other arguments will change the - desiredCompressionMethod to CompressionDeflated." - - | old | - old _ desiredCompressionLevel. - desiredCompressionLevel _ aNumber. - desiredCompressionMethod _ (aNumber > 0) - ifTrue: [ CompressionDeflated ] - ifFalse: [ CompressionStored ]. - ^old! ! -!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/21/2001 22:03'! - desiredCompressionMethod - "Get my desiredCompressionMethod. - This is the method that will be used to write" - - ^desiredCompressionMethod! ! -!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/23/2001 11:25'! - desiredCompressionMethod: aNumber - "Set my desiredCompressionMethod - This is the method that will be used to write. - Answers prior desiredCompressionMethod. - - Only CompressionDeflated or CompressionStored are valid arguments. - - Changing to CompressionStored will change my desiredCompressionLevel - to CompressionLevelNone; changing to CompressionDeflated will change my - desiredCompressionLevel to CompressionLevelDefault." - - | old | - old _ desiredCompressionMethod. - desiredCompressionMethod _ aNumber. - desiredCompressionLevel _ (aNumber = CompressionDeflated) - ifTrue: [ CompressionLevelDefault ] - ifFalse: [ CompressionLevelNone ]. - compressionMethod = CompressionStored ifTrue: [ compressedSize _ uncompressedSize ]. - ^old.! ! -!ZipArchiveMember methodsFor: 'private' stamp: 'jmv 2/16/2011 18:29'! - dosToSqueakTime: dt - "DOS years start at 1980, so add 1980." - | year mon mday hour min sec date time | - - year := (( dt bitShift: -25 ) bitAnd: 16r7F ). - mon := (( dt bitShift: -21 ) bitAnd: 16r0F ). - mday := (( dt bitShift: -16 ) bitAnd: 16r1F ). - date := Date newDay: mday month: mon year: year+1980. - - hour := (( dt bitShift: -11 ) bitAnd: 16r1F ). - min := (( dt bitShift: -5 ) bitAnd: 16r3F ). - sec := (( dt bitShift: 1 ) bitAnd: 16r3E ). - time := ((( hour * 60 ) + min ) * 60 ) + sec. - - ^date secondsSinceSqueakEpoch + time - - ! ! -!ZipArchiveMember methodsFor: 'private' stamp: 'nk 2/23/2001 08:24'! - endRead - readDataRemaining _ 0.! ! -!ZipArchiveMember methodsFor: 'extraction' stamp: 'jmv 5/31/2016 10:38'! - extractInDirectory: aDirectoryEntry - - self extractToFileNamed: self localFileName inDirectory: aDirectoryEntry -! ! -!ZipArchiveMember methodsFor: 'extraction' stamp: 'jmv 11/3/2016 11:52:24'! - extractInDirectory: aDirectory overwrite: overwriteAll - "Extract this entry into the given directory. Answer #okay, #failed, #abort, or #retryWithOverwrite." - | path fileDir file index localName | - path := fileName findTokens:'/'. - localName := path last. - fileDir := path allButLast inject: aDirectory into:[:base :part| base / part]. - fileDir assureExistence. - file := [fileDir privateNewFile: localName] on: FileExistsException do:[:ex| ex return: nil]. - file ifNil:[ - overwriteAll ifFalse:[ - [index := (PopUpMenu labelArray:{ - 'Yes, overwrite'. - 'No, don''t overwrite'. - 'Overwrite ALL files'. - 'Cancel operation' - } lines: #(2)) startUpWithCaption: fileName, ' already exists. Overwrite?'. - index == nil] whileTrue. - index = 4 ifTrue:[^#abort]. - index = 3 ifTrue:[^#retryWithOverwrite]. - index = 2 ifTrue:[^#okay]. - ]. - file := [fileDir privateForceNewFile: localName] on: Error do:[:ex| ex return]. - file ifNil:[^#failed]. - ]. - self extractTo: file. - file close. - ^#okay! ! -!ZipArchiveMember methodsFor: 'extraction' stamp: 'nk 2/22/2001 18:03'! - extractTo: aStream - | oldCompression | - self isEncrypted ifTrue: [ self error: 'encryption is unsupported' ]. - aStream binary. - oldCompression _ self desiredCompressionMethod: CompressionStored. - self rewindData. - self writeDataTo: aStream. - self desiredCompressionMethod: oldCompression. - self endRead.! ! -!ZipArchiveMember methodsFor: 'extraction' stamp: 'nk 2/24/2001 18:03'! - extractTo: aStream from: start to: finish - | oldCompression | - self isEncrypted ifTrue: [ self error: 'encryption is unsupported' ]. - aStream binary. - oldCompression _ self desiredCompressionMethod: CompressionStored. - self rewindData. - self writeDataTo: aStream from: start to: finish. - self desiredCompressionMethod: oldCompression. - self endRead.! ! -!ZipArchiveMember methodsFor: 'extraction' stamp: 'pb 5/25/2016 01:16'! - extractToFileNamed: aFileName - - self extractToFileNamed: aFileName inDirectory: DirectoryEntry currentDirectory! ! -!ZipArchiveMember methodsFor: 'extraction' stamp: 'jmv 5/31/2016 11:24'! - extractToFileNamed: aLocalFileName inDirectory: aDirectoryEntry - - self isEncrypted ifTrue: [ ^self error: 'encryption unsupported' ]. - self isDirectory - ifFalse: [ - aDirectoryEntry / aLocalFileName forceWriteStreamDo: [ :stream | - self extractTo: stream ] ] - ifTrue: [ - (aDirectoryEntry / aLocalFileName) asDirectoryEntry assureExistence ]! ! -!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 00:25'! - fileComment - ^fileComment! ! -!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 00:25'! - fileComment: aString - fileComment _ aString! ! -!ZipArchiveMember methodsFor: 'testing' stamp: 'nk 2/22/2001 00:40'! - hasDataDescriptor - ^ (bitFlag bitAnd: 8) ~= 0 "GPBF_HAS_DATA_DESCRIPTOR_MASK"! ! -!ZipArchiveMember methodsFor: 'initialization' stamp: 'nk 2/24/2001 16:16'! - initialize - super initialize. - lastModFileDateTime _ 0. - fileAttributeFormat _ FaUnix. - versionMadeBy _ 20. - versionNeededToExtract _ 20. - bitFlag _ 0. - compressionMethod _ CompressionStored. - desiredCompressionMethod _ CompressionDeflated. - desiredCompressionLevel _ CompressionLevelDefault. - internalFileAttributes _ 0. - externalFileAttributes _ 0. - fileName _ ''. - cdExtraField _ ''. - localExtraField _ ''. - fileComment _ ''. - crc32 _ 0. - compressedSize _ 0. - uncompressedSize _ 0. - self unixFileAttributes: DefaultFilePermissions.! ! -!ZipArchiveMember methodsFor: 'testing' stamp: 'nk 2/22/2001 00:00'! - isDirectory - ^false! ! -!ZipArchiveMember methodsFor: 'testing' stamp: 'nk 2/22/2001 00:39'! - isEncrypted - "Return true if this member is encrypted (this is unsupported)" - ^ (bitFlag bitAnd: 1) ~= 0! ! -!ZipArchiveMember methodsFor: 'testing' stamp: 'nk 2/22/2001 00:41'! - isTextFile - "Returns true if I am a text file. - Note that this module does not currently do anything with this flag - upon extraction or storage. - That is, bytes are stored in native format whether or not they came - from a text file." - ^ (internalFileAttributes bitAnd: 1) ~= 0 -! ! -!ZipArchiveMember methodsFor: 'testing' stamp: 'nk 2/22/2001 00:43'! - isTextFile: aBoolean - "Set whether I am a text file. - Note that this module does not currently do anything with this flag - upon extraction or storage. - That is, bytes are stored in native format whether or not they came - from a text file." - internalFileAttributes _ aBoolean - ifTrue: [ internalFileAttributes bitOr: 1 ] - ifFalse: [ internalFileAttributes bitAnd: 1 bitInvert ] -! ! -!ZipArchiveMember methodsFor: 'accessing' stamp: 'jdr 8/11/2010 10:38'! - lastModTime - "Return my last modification date/time stamp, - converted to Squeak seconds" - - ^self dosToSqueakTime: lastModFileDateTime! ! -!ZipArchiveMember methodsFor: 'accessing' stamp: 'jmv 10/27/2015 18:16'! - localFileName - "Answer my fileName in terms of the local directory naming convention" - ^fileName! ! -!ZipArchiveMember methodsFor: 'testing' stamp: 'nk 2/21/2001 20:38'! - looksLikeDirectory - ^false! ! -!ZipArchiveMember methodsFor: 'private' stamp: 'nk 2/21/2001 23:57'! - mapPermissionsFromUnix: unixPerms - ^ unixPerms bitShift: 16.! ! -!ZipArchiveMember methodsFor: 'private' stamp: 'nk 2/21/2001 23:58'! - mapPermissionsToUnix: dosPerms - ^ dosPerms bitShift: -16.! ! -!ZipArchiveMember methodsFor: 'private' stamp: 'nk 2/22/2001 20:42'! - readRawChunk: n - self subclassResponsibility! ! -!ZipArchiveMember methodsFor: 'private-writing' stamp: 'jmv 2/26/2016 16:51'! - refreshLocalFileHeaderTo: aStream - "Re-writes my local header to the given stream. - To be called after writing the data stream. - Assumes that fileName and localExtraField sizes didn't change since last written." - - | here | - here _ aStream position. - aStream position: writeLocalHeaderRelativeOffset. - - aStream nextPutAll: LocalFileHeaderSignature. - aStream nextUnsignedInt16Put: versionNeededToExtract bigEndian: false. - aStream nextUnsignedInt16Put: bitFlag bigEndian: false. - aStream nextUnsignedInt16Put: desiredCompressionMethod bigEndian: false. - aStream nextUnsignedInt32Put: lastModFileDateTime bigEndian: false. - aStream nextUnsignedInt32Put: crc32 bigEndian: false. - aStream nextUnsignedInt32Put: (desiredCompressionMethod = CompressionStored - ifTrue: [ uncompressedSize ] ifFalse: [ compressedSize ]) bigEndian: false. - aStream nextUnsignedInt32Put: uncompressedSize bigEndian: false. - aStream nextUnsignedInt16Put: fileName size bigEndian: false. - aStream nextUnsignedInt16Put: localExtraField size bigEndian: false. - - aStream position: here! ! -!ZipArchiveMember methodsFor: 'private' stamp: 'nk 4/28/2002 21:53'! - rewindData - readDataRemaining _ (desiredCompressionMethod = CompressionDeflated - and: [ compressionMethod = CompressionDeflated ]) - ifTrue: [ compressedSize ] - ifFalse: [ uncompressedSize ]. -! ! -!ZipArchiveMember methodsFor: 'accessing' stamp: 'jdr 8/11/2010 11:08'! - setLastModFileDateTimeFrom: aSmalltalkTime - - lastModFileDateTime := self squeakToDosTime: aSmalltalkTime! ! -!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 11/11/2002 21:03'! - splitFileName - "Answer my name split on slash boundaries. A directory will have a trailing empty string." - ^ fileName findTokens: '/'.! ! -!ZipArchiveMember methodsFor: 'private' stamp: 'jdr 8/11/2010 11:00'! - squeakToDosTime: secs - | dosTime dateTime | - - dateTime := Time dateAndTimeFromSeconds: secs. - dosTime := (dateTime second seconds) bitShift: -1. - dosTime := dosTime + ((dateTime second minutes) bitShift: 5). - dosTime := dosTime + ((dateTime second hours) bitShift: 11). - dosTime := dosTime + ((dateTime first dayOfMonth) bitShift: 16). - dosTime := dosTime + ((dateTime first monthIndex) bitShift: 21). - dosTime := dosTime + (((dateTime first year) - 1980) bitShift: 25). - ^dosTime -! ! -!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 00:38'! - uncompressedSize - "Return the uncompressed size for this member." - ^uncompressedSize! ! -!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 00:18'! - unixFileAttributes - ^self mapPermissionsToUnix: externalFileAttributes.! ! -!ZipArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 00:24'! - unixFileAttributes: perms - | oldPerms newPerms | - oldPerms _ self mapPermissionsToUnix: externalFileAttributes. - newPerms _ self isDirectory - ifTrue: [ (perms bitAnd: FileAttrib bitInvert) bitOr: DirectoryAttrib ] - ifFalse: [ (perms bitAnd: DirectoryAttrib bitInvert) bitOr: FileAttrib ]. - externalFileAttributes _ self mapPermissionsFromUnix: newPerms. - ^oldPerms.! ! -!ZipArchiveMember methodsFor: 'private-writing' stamp: 'jmv 2/26/2016 16:53'! - writeCentralDirectoryFileHeaderTo: aStream - "C2 v3 V4 v5 V2" - - aStream nextPutAll: CentralDirectoryFileHeaderSignature. - aStream nextPut: versionMadeBy. - aStream nextPut: fileAttributeFormat. - - aStream nextUnsignedInt16Put: versionNeededToExtract bigEndian: false. - aStream nextUnsignedInt16Put: bitFlag bigEndian: false. - aStream nextUnsignedInt16Put: desiredCompressionMethod bigEndian: false. - - aStream nextUnsignedInt32Put: lastModFileDateTime bigEndian: false. - - "These next 3 should have been updated during the write of the data" - aStream nextUnsignedInt32Put: crc32 bigEndian: false. - aStream nextUnsignedInt32Put: (desiredCompressionMethod = CompressionStored - ifTrue: [ uncompressedSize ] ifFalse: [ compressedSize ]) bigEndian: false. - aStream nextUnsignedInt32Put: uncompressedSize bigEndian: false. - - aStream nextUnsignedInt16Put: fileName size bigEndian: false. - aStream nextUnsignedInt16Put: cdExtraField size bigEndian: false. - aStream nextUnsignedInt16Put: fileComment size bigEndian: false. - aStream nextUnsignedInt16Put: 0 bigEndian: false. "diskNumberStart" - aStream nextUnsignedInt16Put: internalFileAttributes bigEndian: false. - - aStream nextUnsignedInt32Put: externalFileAttributes bigEndian: false. - aStream nextUnsignedInt32Put: writeLocalHeaderRelativeOffset bigEndian: false. - - aStream nextPutAll: fileName asByteArray. - aStream nextPutAll: cdExtraField asByteArray. - aStream nextPutAll: fileComment asByteArray.! ! -!ZipArchiveMember methodsFor: 'private-writing' stamp: 'jmv 2/26/2016 16:54'! - writeDataDescriptorTo: aStream - "This writes a data descriptor to the given stream. - Assumes that crc32, writeOffset, and uncompressedSize are - set correctly (they should be after a write). - Further, the local file header should have the - GPBF_HAS_DATA_DESCRIPTOR_MASK (8) bit set." - - aStream nextUnsignedInt32Put: crc32 bigEndian: false. - aStream nextUnsignedInt32Put: compressedSize bigEndian: false. - aStream nextUnsignedInt32Put: uncompressedSize bigEndian: false! ! -!ZipArchiveMember methodsFor: 'private-writing' stamp: 'ar 8/10/2010 13:15'! - writeDataTo: aStream - "Copy my (possibly inflated or deflated) data to the given stream. - This might do compression, decompression, or straight copying, depending - on the values of compressionMethod and desiredCompressionMethod" - - "Note: Do not shortcut this method if uncompressedSize = 0. Even in this case - data may be produced by the compressor (i.e., '' zipped size > 0) and must - be stored in the file or else other utilities will treat the zip file as corrupt." - - (compressionMethod = CompressionStored and: [ desiredCompressionMethod = CompressionDeflated ]) - ifTrue: [ ^self compressDataTo: aStream ]. - - (compressionMethod = CompressionDeflated and: [ desiredCompressionMethod = CompressionStored ]) - ifTrue: [ ^self uncompressDataTo: aStream ]. - - self copyDataTo: aStream.! ! -!ZipArchiveMember methodsFor: 'private-writing' stamp: 'nk 2/24/2001 18:01'! - writeDataTo: aStream from: start to: finish - "Copy my (possibly inflated or deflated) data to the given stream. - But only the specified byte range. - This might do decompression, or straight copying, depending - on the values of compressionMethod and desiredCompressionMethod" - - uncompressedSize = 0 ifTrue: [ ^self ]. "nothing to do because no data" - start > finish ifTrue: [ ^self ]. - start > uncompressedSize ifTrue: [ ^self ]. - - (compressionMethod = CompressionStored and: [ desiredCompressionMethod = CompressionDeflated ]) - ifTrue: [ ^self error: 'only supports uncompression or copying right now' ]. - - (compressionMethod = CompressionDeflated and: [ desiredCompressionMethod = CompressionStored ]) - ifTrue: [ ^self uncompressDataTo: aStream from: start to: finish ]. - - self copyRawDataTo: aStream from: start to: finish.! ! -!ZipArchiveMember methodsFor: 'private-writing' stamp: 'jmv 2/26/2016 16:55'! - writeLocalFileHeaderTo: aStream - "Write my local header to a file handle. - Stores the offset to the start of the header in my - writeLocalHeaderRelativeOffset member." - - aStream nextPutAll: LocalFileHeaderSignature. - aStream nextUnsignedInt16Put: versionNeededToExtract bigEndian: false. - aStream nextUnsignedInt16Put: bitFlag bigEndian: false. - aStream nextUnsignedInt16Put: desiredCompressionMethod bigEndian: false. - - aStream nextUnsignedInt32Put: lastModFileDateTime bigEndian: false. - aStream nextUnsignedInt32Put: crc32 bigEndian: false. - aStream nextUnsignedInt32Put: (desiredCompressionMethod = CompressionStored - ifTrue: [ uncompressedSize ] ifFalse: [ compressedSize ]) bigEndian: false. - aStream nextUnsignedInt32Put: uncompressedSize bigEndian: false. - - aStream nextUnsignedInt16Put: fileName size bigEndian: false. - aStream nextUnsignedInt16Put: localExtraField size bigEndian: false. - - aStream nextPutAll: fileName asByteArray. - aStream nextPutAll: localExtraField asByteArray! ! -!ZipArchiveMember methodsFor: 'writing' stamp: 'nk 2/23/2001 11:28'! - writeTo: aStream - self rewindData. - writeLocalHeaderRelativeOffset _ aStream position. - self writeLocalFileHeaderTo: aStream. - self writeDataTo: aStream. - self refreshLocalFileHeaderTo: aStream.! ! -!ZipArchiveMember class methodsFor: 'instance creation' stamp: 'nk 2/22/2001 17:27'! - newFromDirectory: aFileName - ^ZipDirectoryMember newNamed: aFileName! ! -!ZipArchiveMember class methodsFor: 'instance creation' stamp: 'nk 2/22/2001 17:27'! - newFromFile: aFileName - ^ZipNewFileMember newNamed: aFileName! ! -!ZipArchiveMember class methodsFor: 'instance creation' stamp: 'nk 2/22/2001 17:25'! - newFromString: aString named: aFileName - ^ZipStringMember newFrom: aString named: aFileName! ! -!ZipArchiveMember class methodsFor: 'instance creation' stamp: 'nk 2/21/2001 20:40'! - newFromZipFile: stream named: fileName - ^ZipFileMember newFrom: stream named: fileName! ! -!ZipFileMember methodsFor: 'private-reading' stamp: 'nk 11/11/2002 21:46'! - canonicalizeFileName - "For security reasons, make all paths relative and remove any ../ portions" - - [fileName beginsWith: '/'] whileTrue: [fileName := fileName allButFirst]. - fileName := fileName copyReplaceAll: '../' with: ''! ! -!ZipFileMember methodsFor: 'initialization' stamp: 'ar 3/2/2001 18:46'! - close - stream ifNotNil:[stream close].! ! -!ZipFileMember methodsFor: 'private-writing' stamp: 'nk 2/23/2001 11:04'! - copyDataTo: aStream - - self copyRawDataTo: aStream.! ! -!ZipFileMember methodsFor: 'initialization' stamp: 'nk 2/22/2001 16:52'! - initialize - super initialize. - crc32 _ 0. - localHeaderRelativeOffset _ 0. - dataOffset _ 0.! ! -!ZipFileMember methodsFor: 'private-writing' stamp: 'nk 3/27/2002 11:20'! - localHeaderRelativeOffset - ^localHeaderRelativeOffset! ! -!ZipFileMember methodsFor: 'testing' stamp: 'nk 2/21/2001 21:52'! - looksLikeDirectory - ^fileName last = $/ - and: [ uncompressedSize = 0 ]! ! -!ZipFileMember methodsFor: 'private-reading' stamp: 'jmv 2/26/2016 16:30'! - readCentralDirectoryFileHeaderFrom: aStream - "Assumes aStream positioned after signature" - - | fileNameLength extraFieldLength fileCommentLength | - - versionMadeBy _ aStream next. - fileAttributeFormat _ aStream next. - - versionNeededToExtract _ aStream nextUnsignedInt16BigEndian: false. - bitFlag _ aStream nextUnsignedInt16BigEndian: false. - compressionMethod _ aStream nextUnsignedInt16BigEndian: false. - - lastModFileDateTime _ aStream nextUnsignedInt32BigEndian: false. - crc32 _ aStream nextUnsignedInt32BigEndian: false. - compressedSize _ aStream nextUnsignedInt32BigEndian: false. - uncompressedSize _ aStream nextUnsignedInt32BigEndian: false. - - fileNameLength _ aStream nextUnsignedInt16BigEndian: false. - extraFieldLength _ aStream nextUnsignedInt16BigEndian: false. - fileCommentLength _ aStream nextUnsignedInt16BigEndian: false. - aStream nextUnsignedInt16BigEndian: false. "disk number start" - internalFileAttributes _ aStream nextUnsignedInt16BigEndian: false. - - externalFileAttributes _ aStream nextUnsignedInt32BigEndian: false. - localHeaderRelativeOffset _ aStream nextUnsignedInt32BigEndian: false. - - fileName _ (aStream next: fileNameLength) asString. - cdExtraField _ (aStream next: extraFieldLength) asByteArray. - fileComment _ (aStream next: fileCommentLength) asString. - - self desiredCompressionMethod: compressionMethod! ! -!ZipFileMember methodsFor: 'private-reading' stamp: 'nk 11/11/2002 21:48'! - readFrom: aStream - "assumes aStream positioned after CD header; leaves stream positioned after my CD entry" - - self readCentralDirectoryFileHeaderFrom: aStream. - self readLocalDirectoryFileHeaderFrom: aStream. - self endRead. - self canonicalizeFileName. -! ! -!ZipFileMember methodsFor: 'private-reading' stamp: 'jmv 2/26/2016 16:31'! - readLocalDirectoryFileHeaderFrom: aStream - "Positions stream as necessary. Will return stream to its original position" - - | fileNameLength extraFieldLength xcrc32 xcompressedSize xuncompressedSize sig oldPos | - - oldPos _ aStream position. - - aStream position: localHeaderRelativeOffset. - - sig _ aStream next: 4. - sig = LocalFileHeaderSignature asByteArray - ifFalse: [ aStream position: oldPos. - ^self error: 'bad LH signature at ', localHeaderRelativeOffset hex ]. - - versionNeededToExtract _ aStream nextUnsignedInt16BigEndian: false. - bitFlag _ aStream nextUnsignedInt16BigEndian: false. - compressionMethod _ aStream nextUnsignedInt16BigEndian: false. - - lastModFileDateTime _ aStream nextUnsignedInt32BigEndian: false. - xcrc32 _ aStream nextUnsignedInt32BigEndian: false. - xcompressedSize _ aStream nextUnsignedInt32BigEndian: false. - xuncompressedSize _ aStream nextUnsignedInt32BigEndian: false. - - fileNameLength _ aStream nextUnsignedInt16BigEndian: false. - extraFieldLength _ aStream nextUnsignedInt16BigEndian: false. - - fileName _ (aStream next: fileNameLength) asString. - localExtraField _ (aStream next: extraFieldLength) asByteArray. - - dataOffset _ aStream position. - - "Don't trash these fields if we already got them from the central directory" - self hasDataDescriptor ifFalse: [ - crc32 _ xcrc32. - compressedSize _ xcompressedSize. - uncompressedSize _ xuncompressedSize. - ]. - - aStream position: oldPos.! ! -!ZipFileMember methodsFor: 'private-reading' stamp: 'nk 2/22/2001 20:46'! - readRawChunk: n - ^stream next: n! ! -!ZipFileMember methodsFor: 'private-reading' stamp: 'nk 2/23/2001 09:56'! - rewindData - super rewindData. - (stream isNil or: [ stream closed ]) - ifTrue: [ self error: 'stream missing or closed' ]. - stream position: (localHeaderRelativeOffset + 4). - self skipLocalDirectoryFileHeaderFrom: stream.! ! -!ZipFileMember methodsFor: 'private-reading' stamp: 'jmv 2/26/2016 16:31'! - skipLocalDirectoryFileHeaderFrom: aStream - "Assumes that stream is positioned after signature." - - | extraFieldLength fileNameLength | - aStream next: 22. - fileNameLength _ aStream nextUnsignedInt16BigEndian: false. - extraFieldLength _ aStream nextUnsignedInt16BigEndian: false. - aStream next: fileNameLength. - aStream next: extraFieldLength. - dataOffset _ aStream position! ! -!ZipFileMember methodsFor: 'initialization' stamp: 'nk 2/22/2001 16:51'! - stream: aStream externalFileName: aFileName - stream _ aStream. - externalFileName _ aFileName.! ! -!ZipFileMember methodsFor: 'private-writing' stamp: 'nk 3/7/2004 16:08'! - uncompressDataTo: aStream - - | decoder buffer chunkSize crcErrorMessage | - decoder _ ZipReadStream on: stream. - decoder expectedCrc: self crc32. - buffer _ ByteArray new: (32768 min: readDataRemaining). - crcErrorMessage _ nil. - - [[ readDataRemaining > 0 ] whileTrue: [ - chunkSize _ 32768 min: readDataRemaining. - buffer _ decoder next: chunkSize into: buffer startingAt: 1. - aStream next: chunkSize putAll: buffer startingAt: 1. - readDataRemaining _ readDataRemaining - chunkSize. - ]] on: CRCError do: [ :ex | crcErrorMessage _ ex messageText. ex proceed ]. - - crcErrorMessage ifNotNil: [ self isCorrupt: true. CRCError signal: crcErrorMessage ] - -! ! -!ZipFileMember methodsFor: 'private-writing' stamp: 'nk 2/24/2001 17:52'! - uncompressDataTo: aStream from: start to: finish - - | decoder buffer chunkSize | - decoder _ FastInflateStream on: stream. - readDataRemaining _ readDataRemaining min: finish - start + 1. - buffer _ ByteArray new: (32768 min: readDataRemaining). - decoder next: start - 1. - - [ readDataRemaining > 0 ] whileTrue: [ - chunkSize _ 32768 min: readDataRemaining. - buffer _ decoder next: chunkSize into: buffer startingAt: 1. - aStream next: chunkSize putAll: buffer startingAt: 1. - readDataRemaining _ readDataRemaining - chunkSize. - ]. -! ! -!ZipFileMember methodsFor: 'testing' stamp: 'jmv 10/14/2015 17:28'! - usesFileNamed: aFileName - "Do I require aFileName? That is, do I care if it's clobbered?" - - ^externalFileName asFileEntry = aFileName asFileEntry! ! -!ZipFileMember class methodsFor: 'as yet unclassified' stamp: 'nk 2/22/2001 17:31'! - newFrom: stream named: fileName - ^(self new) stream: stream externalFileName: fileName! ! -!ZipDirectoryMember methodsFor: 'private' stamp: 'nk 2/21/2001 21:55'! - asDirectory - ^self! ! -!ZipDirectoryMember methodsFor: 'accessing' stamp: 'nk 2/23/2001 10:00'! - desiredCompressionMethod: aNumber! ! -!ZipDirectoryMember methodsFor: 'initialization' stamp: 'nk 2/23/2001 10:01'! - initialize - super initialize. - super desiredCompressionMethod: CompressionStored.! ! -!ZipDirectoryMember methodsFor: 'testing' stamp: 'nk 2/22/2001 00:00'! - isDirectory - ^true! ! -!ZipDirectoryMember methodsFor: 'accessing' stamp: 'jmv 10/14/2015 17:34'! - localFileName: aString - | fe | - super localFileName: aString. - fileName last = $/ ifFalse: [ fileName _ fileName, '/' ]. - fe _ fileName asDirectoryEntry. - fe exists ifTrue: [ - self setLastModFileDateTimeFrom: fe modificationTime ]! ! -!ZipDirectoryMember methodsFor: 'private' stamp: 'nk 3/27/2002 11:30'! - rewindData! ! -!ZipDirectoryMember methodsFor: 'testing' stamp: 'nk 3/27/2002 11:29'! - usesFileNamed: aName - ^false! ! -!ZipDirectoryMember methodsFor: 'private' stamp: 'cmm 9/16/2010 18:59'! - writeDataTo: aStream - "Write nothing. Directories have no contents to write."! ! -!ZipDirectoryMember class methodsFor: 'as yet unclassified' stamp: 'nk 12/20/2002 14:57'! - newNamed: aFileName - ^(self new) localFileName: aFileName; yourself! ! -!ZipNewFileMember methodsFor: 'initialization' stamp: 'ar 3/2/2001 18:50'! - close - stream ifNotNil:[stream close].! ! -!ZipNewFileMember methodsFor: 'initialization' stamp: 'pb 5/25/2016 01:51'! - from: aFileName - | entry | - compressionMethod _ CompressionStored. - "Now get the size, attributes, and timestamps, and see if the file exists" - stream _ aFileName asFileEntry readStream. - self localFileName: (externalFileName _ stream name). - entry _ aFileName asFileEntry. - compressedSize _ uncompressedSize _ entry fileSize. - desiredCompressionMethod _ compressedSize > 0 ifTrue: [ CompressionDeflated ] ifFalse: [ CompressionStored ]. - self setLastModFileDateTimeFrom: entry modificationTime -! ! -!ZipNewFileMember methodsFor: 'initialization' stamp: 'nk 2/22/2001 16:56'! - initialize - super initialize. - externalFileName _ ''.! ! -!ZipNewFileMember methodsFor: 'private' stamp: 'nk 2/22/2001 20:48'! - readRawChunk: n - ^stream next: n! ! -!ZipNewFileMember methodsFor: 'private-writing' stamp: 'nk 2/23/2001 09:58'! - rewindData - super rewindData. - readDataRemaining _ stream size. - stream position: 0.! ! -!ZipNewFileMember methodsFor: 'testing' stamp: 'jmv 10/14/2015 17:28'! - usesFileNamed: aFileName - "Do I require aFileName? That is, do I care if it's clobbered?" - - ^externalFileName asFileEntry = aFileName asFileEntry! ! -!ZipNewFileMember class methodsFor: 'instance creation' stamp: 'nk 2/22/2001 17:27'! - newNamed: aFileName - ^(self new) from: aFileName! ! -!ZipStringMember methodsFor: 'initialization' stamp: 'nk 2/22/2001 16:47'! - contents - ^contents! ! -!ZipStringMember methodsFor: 'initialization' stamp: 'jmv 4/17/2013 11:57'! - contents: aString - contents _ aString. - compressedSize _ uncompressedSize _ aString size. - "set the file date to now" - self setLastModFileDateTimeFrom: Time localSecondClock! ! -!ZipStringMember methodsFor: 'initialization' stamp: 'nk 2/22/2001 20:50'! - initialize - super initialize. - self contents: ''. - compressionMethod _ desiredCompressionMethod _ CompressionStored. -! ! -!ZipStringMember methodsFor: 'private' stamp: 'nk 2/22/2001 20:51'! - readRawChunk: n - ^stream next: n! ! -!ZipStringMember methodsFor: 'private-writing' stamp: 'nk 2/23/2001 10:28'! - rewindData - super rewindData. - stream _ ReadStream on: contents. - readDataRemaining _ contents size.! ! -!ZipStringMember class methodsFor: 'as yet unclassified' stamp: 'nk 12/20/2002 15:06'! - newFrom: aString named: aFileName - ^(self new) contents: aString; localFileName: aFileName; yourself! ! - -InflateStream initialize! - -FastInflateStream initialize! - -ZipWriteStream initialize! - -GZipConstants initialize! - -ZipConstants initialize! - -ZipFileConstants initialize! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/Packages/Compression.pck.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3063] on 13 March 2017 at 4:14:44 pm'! - -'Description Please enter a description for this package '! - -ImageReadWriter subclass: #PNGReadWriter - instanceVariableNames: 'chunk form width height depth backColor bitsPerChannel colorType interlaceMethod bitsPerPixel bytesPerScanline thisScanline prevScanline rowSize globalDataChunk unknownChunks palette transparentPixelValue filtersSeen cachedDecoderMap bigEndian auxBitBlt auxSource auxDest auxCMap' - classVariableNames: 'BPP BlockHeight BlockWidth Debugging StandardColors StandardSwizzleMaps' - poolDictionaries: '' - category: 'Graphics-Files-Additional'! - -!classDefinition: #PNGReadWriter category: #'Graphics-Files-Additional'! -ImageReadWriter subclass: #PNGReadWriter - instanceVariableNames: 'chunk form width height depth backColor bitsPerChannel colorType interlaceMethod bitsPerPixel bytesPerScanline thisScanline prevScanline rowSize globalDataChunk unknownChunks palette transparentPixelValue filtersSeen cachedDecoderMap bigEndian auxBitBlt auxSource auxDest auxCMap' - classVariableNames: 'BPP BlockHeight BlockWidth Debugging StandardColors StandardSwizzleMaps' - poolDictionaries: '' - category: 'Graphics-Files-Additional'! - -PNGReadWriter class - instanceVariableNames: ''! - -!classDefinition: 'PNGReadWriter class' category: #'Graphics-Files-Additional'! -PNGReadWriter class - instanceVariableNames: ''! - -ImageReadWriter subclass: #TIFFReadWriter - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Files-Additional'! - -!classDefinition: #TIFFReadWriter category: #'Graphics-Files-Additional'! -ImageReadWriter subclass: #TIFFReadWriter - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Files-Additional'! - -TIFFReadWriter class - instanceVariableNames: ''! - -!classDefinition: 'TIFFReadWriter class' category: #'Graphics-Files-Additional'! -TIFFReadWriter class - instanceVariableNames: ''! - -Object subclass: #TIFFField - instanceVariableNames: 'tag type values' - classVariableNames: 'DefaultFields SingleValuedTagSymbols TagSymbols ValueReaderSelectors' - poolDictionaries: '' - category: 'Graphics-Files-Additional'! - -!classDefinition: #TIFFField category: #'Graphics-Files-Additional'! -Object subclass: #TIFFField - instanceVariableNames: 'tag type values' - classVariableNames: 'DefaultFields SingleValuedTagSymbols TagSymbols ValueReaderSelectors' - poolDictionaries: '' - category: 'Graphics-Files-Additional'! - -TIFFField class - instanceVariableNames: ''! - -!classDefinition: 'TIFFField class' category: #'Graphics-Files-Additional'! -TIFFField class - instanceVariableNames: ''! - -Object subclass: #TIFFImageFileDirectory - instanceVariableNames: 'fields' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Files-Additional'! - -!classDefinition: #TIFFImageFileDirectory category: #'Graphics-Files-Additional'! -Object subclass: #TIFFImageFileDirectory - instanceVariableNames: 'fields' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Files-Additional'! - -TIFFImageFileDirectory class - instanceVariableNames: ''! - -!classDefinition: 'TIFFImageFileDirectory class' category: #'Graphics-Files-Additional'! -TIFFImageFileDirectory class - instanceVariableNames: ''! - -Object subclass: #TIFFReader - instanceVariableNames: 'stream structure' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Files-Additional'! - -!classDefinition: #TIFFReader category: #'Graphics-Files-Additional'! -Object subclass: #TIFFReader - instanceVariableNames: 'stream structure' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Files-Additional'! - -TIFFReader class - instanceVariableNames: ''! - -!classDefinition: 'TIFFReader class' category: #'Graphics-Files-Additional'! -TIFFReader class - instanceVariableNames: ''! - -Object subclass: #TIFFStream - instanceVariableNames: 'stream bigEndian compressionType remainBitCount outCodes maxOutCodes outCount prefixTable suffixTable bitMask clearCode eoiCode freeCode codeSize maxCode finChar oldCode' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Files-Additional'! - -!classDefinition: #TIFFStream category: #'Graphics-Files-Additional'! -Object subclass: #TIFFStream - instanceVariableNames: 'stream bigEndian compressionType remainBitCount outCodes maxOutCodes outCount prefixTable suffixTable bitMask clearCode eoiCode freeCode codeSize maxCode finChar oldCode' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Files-Additional'! - -TIFFStream class - instanceVariableNames: ''! - -!classDefinition: 'TIFFStream class' category: #'Graphics-Files-Additional'! -TIFFStream class - instanceVariableNames: ''! - -Object subclass: #TIFFStructure - instanceVariableNames: 'imageFileDirectories' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Files-Additional'! - -!classDefinition: #TIFFStructure category: #'Graphics-Files-Additional'! -Object subclass: #TIFFStructure - instanceVariableNames: 'imageFileDirectories' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Files-Additional'! - -TIFFStructure class - instanceVariableNames: ''! - -!classDefinition: 'TIFFStructure class' category: #'Graphics-Files-Additional'! -TIFFStructure class - instanceVariableNames: ''! -!PNGReadWriter commentStamp: '' prior: 0! - I am a subclass of ImageReadWriter that decodes Portable Network Graphics -(PNG) images. - -Submitted by Duane Maxwell! -!TIFFReadWriter commentStamp: 'mrm 7/27/2001 21:56' prior: 0! - For translating Forms to and from the TIFF file format. -By Martin McClure - -This work is based on TIFF revision 6.0. I got the specification from: -http://partners.adobe.com/asn/developer/PDFS/TN/TIFF6.pdf -The spec itself claims it can be obtained from: -http://www.adobe.com/Support/TechNotes.html -and from: -ftp://ftp.adobe.com/pub/adobe/DeveloperSupport/TechNotes/PDFfiles - - -Structure: - stream TIFFStream -- defined by superclass, wraps the stream that - is being read or written - -Current features: -* Reads uncompressed 24-bit RGB TIFF files with 8-bit alpha channels - into 32-bit Forms, with the alpha channel intact. -* Reads both big-endian and little-endian TIFF files -* Reading TIFFs without alpha channels -* Reading compressed TIFFS (LZW only) - -Some features not yet implemented that would be reasonable for this class: -* Writing TIFFs -* Reading TIFFS of different bit depths -* Any of the many other TIFF features - -I've tried to make it reasonably easy for anyone who wants to add more of the missing features by breaking the design down into simple little chunks. The chief components are TIFFStream, which wraps a PositionableStream and translates the endian-ness of the stream, TIFFStructure and all its associated classes, which mirror the logical structure of the TIFF file, and TIFFReader (and future TIFFWriter) which interprets the structure of a TIFF and generates the appropriate Form.! -!TIFFField commentStamp: 'mrm 7/28/2001 15:55' prior: 0! - I represent a TIFF field, or tag-value pair. I'm part of a TIFFImageFileDirectory. -By Martin McClure - -Structure: - tag Integer -- one of my tag constants that is the integer TIFF tag indicating the field meaning. - type Integer -- one of my type constants that is the integer TIFF type of my values - values Array -- my array of values. The size of size is equal to the TIFF 'count' word. - Each value should be of a type compatible with my 'type' ivar. - -ValueReaderSelectors Dictionary -- maps TIFF type integers to the selectors of the methods used to read field values of that type. - -TagSymbols Dictionary -- maps TIFF tag integers to tag symbols. - -SingleValuedTagSymbols Set -- contains the tag symbols of the fields types that should have a value that consists of an array of length one. - -DefaultFields Dictionary -- maps tag symbols to the default field with that tag. Only maps tag symbols for which the TIFF spec defines a default.! -!TIFFImageFileDirectory commentStamp: 'mrm 7/28/2001 13:12' prior: 0! - Mirrors the structure of a TIFF file's Image File Directory. Can be created by parsing itself from a TIFFStream or can (future) write itself to a TIFFStream. -By Martin McClure - -Structure: - fields Dictionary -- maps tag symbols to the TIFFFields that make up this IFD. - -See TIFFStructure for more information about where I fit.! -!TIFFReader commentStamp: 'mrm 7/27/2001 22:05' prior: 0! - I parse a TIFF file and produce a Form. I usually am created and used by a TIFFReadWriter. -By Martin McClure - -Structure: - stream TIFFStream -- Usually over a TIFF file. - structure TIFFStructure -- The TIFF IFDs and fields that together make up the image characteristics, all the information but the pixels themselves. - -! -!TIFFStream commentStamp: '' prior: 0! - Wraps a PositionableStream. Allows access to TIFF simple multi-byte types, remembering whether this TIFF is big-endian or little-endian. -By Martin McClure - -Structure: - stream PositionableStream -- my underlying stream - bigEndian Boolean -- false if little-endian, true if big-endian - compressionType Integer -- currently supported: 1: no compression, 5 LZW compression - -Only implements enough Stream protocol to let TIFFReadWriter and its cohorts to do their job.! -!TIFFStructure commentStamp: 'mrm 7/27/2001 21:42' prior: 0! - I mirror the logical structure of a TIFF file, including its directories and fields but not its pixel data. I can parse a TIFFStream or (future) write to a TIFFStream. I'm not too smart about what my structure means, I leave that interpretation to TIFFImage. -By Martin McClure - -Structure: - imageFileDirectories SequenceableCollection -- each element is a TIFFImageFileDirectory - -I hold the logical structure of the TIFF, but I do not preserve the physical structure (specific offsets) of the file I was parsed from (except for the offsets of the pixel data.) - -See TIFFReader (and future TIFFWriter) for more information about the structure into which I fit.! -!Form methodsFor: '*Graphics-Files-Additional' stamp: 'jmv 6/8/2013 14:08'! -writePNGfileNamed: fName - " - Display writePNGfileNamed: 'display.png' - " - PNGReadWriter putForm: self onFileNamed: fName! ! -!PNGReadWriter methodsFor: 'pixel copies' stamp: 'DSM 3/26/2000 21:32'! - copyPixels: y - "Handle non-interlaced pixels of supported colorTypes" - - | s | - s _ #(copyPixelsGray: nil copyPixelsRGB: copyPixelsIndexed: - copyPixelsGrayAlpha: nil copyPixelsRGBA:) at: colorType+1. - self perform: s asSymbol with: y -! ! -!PNGReadWriter methodsFor: 'pixel copies' stamp: 'RAA 11/4/2000 16:08'! - copyPixels: y at: startX by: incX - "Handle interlaced pixels of supported colorTypes" - - | s | - s _ #(copyPixelsGray:at:by: nil copyPixelsRGB:at:by: copyPixelsIndexed:at:by: - copyPixelsGrayAlpha:at:by: nil copyPixelsRGBA:at:by:) at: colorType+1. - self perform: s asSymbol with: y with: startX with: incX -! ! -!PNGReadWriter methodsFor: 'pixel copies' stamp: 'jmv 6/7/2016 10:36'! - copyPixelsGray: y - "Handle non-interlaced grayscale color mode (colorType = 0)" - - | blitter high low value base bits bytesLeft word | - - bitsPerChannel = 16 ifTrue: [ - "Warning: This is extremely slow. Besides we are downsampling to 8 bits!!" - blitter := BitBlt bitPokerToForm: form. - 0 to: width - 1 do: [ :x | - high := thisScanline at: x * 2 + 1. - low := thisScanline at: x * 2 + 2. - value := (high * 256 + low = transparentPixelValue) - ifTrue: [0 "transparent"] - ifFalse: [high max: 1]. - blitter pixelAt: x @ y put: value ]. - ^self ]. - - "Just copy the bits" - "This interesting technique (By Andreas Raab) is a bit obscure, but it is so fast that we leave it active - Note that currently it only works on 1bpp PNG, building a BigEndian form." - (bitsPerChannel = 1 and: [ form isBigEndian ]) ifTrue: [ ^self copyPixelsGrayWeirdBitBltHack: y ]. - - "This interesting technique (By Yoshiki Ohshima) is very fast, although only works with whole word image width" - (thisScanline size bitAnd: 3) = 0 ifTrue: [ - ^form copyFromByteArray2: thisScanline to: y * (form width* bitsPerChannel // 32) ]. - - "This Smalltalk version might be easier to understand and is quite fast too." - "This somewhat weird mixture of (#* and #+) with (#bitShift: and #bitOr:) - is to make use of faster arithmetic bytecodes, but not of slow largeintegers." - "This works for GrayForms of any endianness and width" - base _ y * (form width * bitsPerChannel + 31 // 32) + 1. - bits _ form bits. - form isBigEndian ifTrue: [ - 0 to: thisScanline size // 4 - 1 do: [ :i | - | ii | - ii _ i * 4. - word _ - ((thisScanline at: ii+1) *256 + - (thisScanline at: ii+2) *256 + - ((thisScanline at: ii+3)) bitShift: 8) bitOr: - (thisScanline at: ii+4). - bits at: base + i put: word.]. - (bytesLeft := thisScanline size bitAnd: 3) = 0 ifFalse: [ - word := 0. - thisScanline size - bytesLeft + 1 to: thisScanline size do: [ :ii | - word := word * 256 + (thisScanline at: ii) ]. - word := word bitShift: 8 * (4 - bytesLeft). - bits at: base + (thisScanline size // 4) put: word ]. - ] ifFalse: [ - 0 to: thisScanline size // 4 - 1 do: [ :i | - | ii | - ii _ i * 4. - word _ - ((thisScanline at: ii+4) *256 + - (thisScanline at: ii+3) *256 + - ((thisScanline at: ii+2)) bitShift: 8) bitOr: - (thisScanline at: ii+1). - bits at: base + i put: word ]. - (bytesLeft := thisScanline size bitAnd: 3) = 0 ifFalse: [ - word := 0. - thisScanline size to: thisScanline size - bytesLeft + 1 by: -1 do: [ :ii | - word := word * 256 + (thisScanline at: ii) ]. - bits at: base + (thisScanline size // 4) put: word ]. - ]! ! -!PNGReadWriter methodsFor: 'pixel copies' stamp: 'nice 5/10/2014 20:14'! - copyPixelsGray: y at: startX by: incX - "Handle interlaced grayscale color mode (colorType = 0)" - - | offset bits blitter pixPerByte shifts b pixel mask pixelNumber | - bitsPerChannel = 16 - ifTrue: [ - "Warning: This is extremely slow. Besides we are downsampling to 8 bits!!!!" - blitter := BitBlt bitPokerToForm: form. - startX to: width-1 by: incX do: [ :x | - | high low value | - high := thisScanline at: x//incX<<1 + 1. - low := thisScanline at: x//incX<<1 + 2. - value := (high * 256 + low = transparentPixelValue) - ifTrue: [0 "transparent"] - ifFalse: [high max: 1]. - blitter pixelAt: x @ y put: value ]. - ^self ]. - offset := y*rowSize+1. - bits := form bits. - bitsPerChannel = 8 ifTrue: [ - startX to: width-1 by: incX do: [ :x | | w | - w := offset + (x>>2). - b := 3- (x \\ 4) * 8. - pixel := (thisScanline at: x // incX + 1)<> (shifts at: (pixelNumber \\ pixPerByte) + 1)) bitAnd: mask. - blitter pixelAt: (x@y) put: pixel. - pixelNumber := pixelNumber + 1. - ]. -! ! -!PNGReadWriter methodsFor: 'pixel copies' stamp: 'jmv 9/23/2012 21:45'! - copyPixelsGrayAlpha: y - "Handle non-interlaced grayscale with alpha color mode (colorType = 4)" - - | i pixel gray b | - b _ BitBlt bitPokerToForm: form. - bitsPerChannel = 8 - ifTrue: [ - 0 to: width-1 do: [ :x | - i _ (x << 1) + 1. - gray _ thisScanline at: i. - pixel _ ((thisScanline at: i+1)<<24) + (gray<<16) + (gray<<8) + gray. - b pixelAt: x@y put: pixel. - ] - ] - ifFalse: [ - 0 to: width-1 do: [ :x | - i _ (x << 2) + 1. - gray _ thisScanline at: i. - pixel _ ((thisScanline at: i+2)<<24) + (gray<<16) + (gray<<8) + gray. - b pixelAt: x@y put: pixel. - ] - ] -! ! -!PNGReadWriter methodsFor: 'pixel copies' stamp: 'jmv 9/23/2012 21:45'! - copyPixelsGrayAlpha: y at: startX by: incX - "Handle interlaced grayscale with alpha color mode (colorType = 4)" - - | i pixel gray b | - b _ BitBlt bitPokerToForm: form. - bitsPerChannel = 8 - ifTrue: [ - startX to: width-1 by: incX do: [ :x | - i _ (x // incX << 1) + 1. - gray _ thisScanline at: i. - pixel _ ((thisScanline at: i+1)<<24) + (gray<<16) + (gray<<8) + gray. - b pixelAt: x@y put: pixel. - ] - ] - ifFalse: [ - startX to: width-1 by: incX do: [ :x | - i _ (x // incX << 2) + 1. - gray _ thisScanline at: i. - pixel _ ((thisScanline at: i+2)<<24) + (gray<<16) + (gray<<8) + gray. - b pixelAt: x@y put: pixel. - ] - ] -! ! -!PNGReadWriter methodsFor: 'pixel copies' stamp: 'jmv 1/15/2013 18:24'! - copyPixelsGrayWeirdBitBltHack: y - "Handle non-interlaced black and white color mode (colorType = 0) - By Andreas Raab - - Currently enabled only for 1bpp, otherwise the comment at the bottom displays an incorrect image" - - auxBitBlt - destX: 0 destY: (y * form width*bitsPerChannel//32) width: 1 height: (form width+31*bitsPerChannel//32); - copyBits. -" -(Form fromBinaryStream: - 'iVBORw0KGgoAAAANSUhEUgAAAGwAAACHCAAAAADWjuNQAAAAB3RJTUUH2QMFAAEAkIBc5AAA -GadJREFUaIHte2l4lUXS9t39nC052UPCZpCdAIKgEJVFBhUV3EBQB0ERFXfFccOZQUXlehVl -lEsdBUVGEEEERRREENk3gQAqWwghEAgkJCHbOTnr0/f341nOCeDMOJ8z1/dd7/SPnO7qpbqq -q6qrqp8I4j9X5H8Q13+R/cbIziUoNkydC2hUyHNO57mqjhgo7A/4hdmqD8PlOj/J3tKeZfuP -EIKugaNb2XNDGxFp3cmoi/0H/eIGewKEvm7LrnLh7dl3QJLSNZMmmkVxWvPmHqfL5XK5XG6H -lA7Msfr4RqK9StZLNvRkKnA/ldGYALj2213cO8Sa0PkLFdSNQXHIngMgEFemGQspzgcAuJo3 -dwHAe9b6J1OBh63GX4GEn8y1dC7LtJYSwLuMGINsNiot0eavK0IIItscHpoC4bz99y0ytPJ5 -rwFT7vDa68R2pwBhLSYP310F2ebKC1KOrlkj+PTFebTPjBCgxHWJCdKRQFeqZ8FbEEx97VZl -sPpgAXjvXwGg2YXpBd4W8dTbp18MOFOtxqRyqR6dlArguanPwD89zxpN6qQyuUqSfDURErn5 -dnunB+i7+1hlTW0kyrhSlgo8ZjXGA6llZv1YBjDMPBze12zyEeo2G+WRoh6Z9l7rHp4LqNtm -pCpLLTpdsENuuiTVpYkEZvQd3T2estKtDVE6ooL748g8XA08bnBayVdeagolbMrUob8VGYQp -xbL+kBCTFG1SFb9xxS3vmWN1laXFoxVIPWnO+BpIO2wLC5UyJ4Bk1aZ1P4ZNwdueC4nMxfHc -UlGuHXdhkltCAJBocsJiY6ajkfSmWchWCXj2mZMj4di2HQAyasv7GISKL8fWaHruvJ4qzo5R -w4ABkeO1dSHBw+8Uhivzr7ckMIpsVzUIQISiYMSEt0z0B3d1NiY76uszYkuR3L7x6HFSkS9p -ELi2wtyLKTRq9ZsfvF9uCQ+A18z6ycwWyU/XHy0pKSkpKR8PJBdZrOsNdDhmyAdHt/+ScUod -JZVOsm40hNAejjBKRqPRqMXqdwAMPkqSLOwFYLnFxnQ3xlss+iOQcsRqzIZA128CJA+NBvAI -Y0otCQrg9E0bhVCuw8MjDQm6T0Rbzk42iL/hpVNyeY8+GY5o5eZawUuuoCVcYeigfW7Urdqd -Sxdqe4d07ZxYtaFOUFwWz0ZDar5C45JdZaif4jxA2CY7Y7OpNSxLi22az8RRprNySGwd7X0L -hy0HAtEzkBFANApQH7n0MuFs1iQBQOL1ay/TLcICQDg2Hw0hq65nLnnPvA6cA1eOs8dYikix -/c3EZIfuSRJwQbqEcI5KMHhEAX3nifLTp31tWnfvBFoGsWFm8HSfG0025u+QzmG2vaKAf/vP -xTyvZW6P2PZjyHjWpc3Gl8C5u5UQ5ur/uMSQGRiFAIUNjFuBIAVEI4iBT9jzGyOkuZ0YVPzX -b/wvsr9XYq5cTPQpLFGOB9pVBSGsJoXhOQphaKQtegqCBiXKcDoaIYNoqIs0cwIATwW184wp -Ws22/Lr6pPT+vZ00llOIahogRK1SKlMAIAWjglIAmr01XbktvBKgqYb2Fcm/pLc4RJKs6pI4 -2oQu62DOGFhiGsGn215aQkX/I+e36LCAilTccMWAi/K6devapc+4DdZy4dFX3XaQimTDn242 -fcJ4v3Ei5AGSZEUqRhnAfenQ+j7yzIO9gYERA3QrUorJw5cDrVeYU9fETkVbYq6rcoGuJxgl -Q11wI8/wGwUkNGEdpOl0LKrGtEcA4PHtnqqmZl+SG6vuPIlr5mSbllMKDm8Ld9QV+LjsjevN -NZwQe0cuagLADcsrdwDgicMXJUIICDcAwKNZkYQTqNzr0jze151QBt8lpOO1P0cx4WWnARDQ -iCf6AACOzz9cm26ctguOyLqRn6eAtOXGARD+410TAQLvZjrCynHUZzll174QfnGKRzodroue -voQmft/vVwPo6rQlzy24OhhSIe3kZrTymrKgMPzip1eNmZdAIMGWG/Lgpu+21ZAvpVjCreEu -8zg+bGUJWDPTNxsHCW1oEhI2W6fNDTFbqy2i4cfq3TCWrwncznBPjDMHOgC0O+bL81JIIZMN -dPWwLvi779xVqIuQf9GGstX3AAD8UJnv/P7VPwbGfJ9j3SsiUXMw7Efm1fdcaYm/gMDT1a/M -805tsJ1XBwAZDDkkEK51L+8UBWTF5ZVm78Lj+u29ASBzAyotqhM+uwLP7p9TeP+XphiFGZh+ -a/T4DcfUkxdbJBrbmFz1/geBetiFttP6AlyFhp5lYYxB9wSgz8Kdhbs/7wKsMUB3otkJKtZ0 -A54zubMO+JLk1xpaFdqa1B3jqMhxgMS9JjBOz56Hs4AkeSoDYw3gie4APEkewJ5wO5ocIcl8 -L7T5huuzBlhMKr4E9PFbetbNPKlxEPbcOEOsI2LGxwmWfW6+4vH2aUFf0JP7l+lm8ByE2wGA -F70JfVy+BIAI4AOAiTdj811h8xwjCAIg3h9FWJ5y3E196ICznxcAwgfpbWugFfAdO6ajZUeP -5WUU1GjdXQCg1oYjXdoBQNmWUN8cgKJiu1CXm87mppNtLgZAUfN1TVfT0/yt3IJzOTwxmOkV -Oc4e82uLEsDZrhl4xi9+A8rUr7h//29vauqRfzzIKmdT9k+5m7HRf9+R/UfI/o2lsYCEdhfJ -nF7GRWP4GgAoziA25DLgjYjSYz7BLzOHpNJ1XSfJzy8AgF5rqUidd7X+miT5aLcvScX8G8eH -Sc4YMmhKmCTX9MwbMPCaG4c/sZeK5Imru60nqfhdv9trSHLNTTcPGzb03j8tDtrXgxl5RnWS -nwLd7hrVAcnbSRXlYMwmSQ7GB6TiJvSN8vRI4MWgIslFgNAkgKZ7SOr8A+4gqXgTniBJfmyR -87vj8cjUzm/9umJFazwVIX2DHTNJ6rwZC0iSN2AWSW7BIO7pjXbfGDExv8C1xUWHig7cgEkk -dR7NcO2m4lbZqoIkOQuD87f+sOqDPPS3aHMAEKgBKH440muKBLwzqrvTiD6+qQ2nOVlgHIMD -oU8fqnZ/2ssOZZKaBkAtFWEAEq3ue/XNj4Cp6qEmAACJFhcBwPX9NqweHHPlDsx/d31U58e2 -ddZJpfMW+1xnkTp/cDrRrB1utXjyBTxpqZlNm8CzyQCUNHXu5DaZYxDGj2D6g8Pxl7h0UsdC -XiiJRBwAFGSdnk4hgDJc1EJBcEs1AF26HYGeS+ou+6zTS6QEBZHcMbK/ynPbA30MLyvn5vfe -+fAN9VgT05tGBCSE8MNlyS1JtXp5va54LAuv6WR4bIfvSJL98AVJcpBxZhtETin5GWDeYgtx -O/m9W1vEqBnDF2VmzHK1qzMpn4PbSJKfOsQ2xudBVERXitOAyx59pCfwSQyZUtGBBrJ16B5U -is8iYydJci5GUfF1eNdZORo+Bjfettg8F91fnvyn8UPdGEN1hkdMku80BYBWs0lSMc9AGuhu -5G9Xo0OAZHggcstIcjpuIclhaHnAmn84Ce1qrMZ888ATHw5YoHhzRVG2tVK1vCxDlwIUX50a -2A5kePGxmzoBOLI8ZYQbFCeX1l7VAxQFm8+/AsCpj+ovHmqtsLT44j6W+di/LES4s9IuaG8j -iEdm3RakjBkjoyEII46yHQkzrrJyFzZM/Z2kw7/LEEfoOhv4G9zU5yznvCcbAxl3m8e/RCiA -OmmOUIwNiQ23RwIANQ2MLWh2xrExVNikGVBT1NaIQ7Bydfl5119i1PPLfuelKCy51Asoob79 -viqx+4gsCiB0FIgirYV1cOVLd+udRzYBiEiBty2AvUuGdomZK0UqRe4U80kuw1qSpP8OZLf1 -ipcNob0V95L8s+cwSZ3j0bx7R1xQQZLFTaTURPIYM/N9oDVyctD5EEnqQ3IqSd7gPBQfef60 -3Bcld+BLkitgmLrnMc0fLRuKjVQk7wLGk39yF5NkecrlYXLJw3tJ8rBnxPfrVjyDWxSpU12d -+F0kMrO9YYPWYwr5IyZaegaSavsH5STzcfl9Dz5yldhEkqEOw0iySD5Pkryl8/OYwonJJ0iq -hi7OobfdNamAOskjCX8kyXscJaTicdcEkgybq49MOswHPVYinA4AvpLE0mwAYn+lQq0d4gGA -7jbOVHe+qCYkRdwuAEj47L2dNdqCGfnNAUQNn71lNGyELk4A8JnH/sIXbz4186E2MQEkuWa2 -TynmYxYVl5hsHIu54UjFMGwkSQ5v18BnkNr8JEldXzC1jnwc+SRZmvYUI/rmrJxqkuTvkrcw -OitrIUlS53PeoXaa2mTj5u8COrkDH5L8GutIkmV90Kp9CiYYJv66NgHySaSWklSchrbXd8cV -DSRZ3jShXdvW8JhZ6h+y0bYV2u8lSSqWZ+NBK8trZguMhHHypdkAmvRPAQA2/faTjSXXDhls -aOLtxQRebXbcDUBgfLdVJzs8NDIBAJy3+smknMHdDOnO2/LJIXnhSCOzIJD99rZ7Y7rcyFyR -oDQdt0Y2TknQyA6d6aXZ3rcVt0ucNdsujZFBRV0UlldIY3cwDLHdgGk3zOyWMJJWcQnVxiPj -dve/I5NqWFrSNLEEoOIIp91koxn2j2mNTYtMxNVjz5DWTIHy2tR0FwGgWiZL/RSyBaBOe5Kg -VyUmAWjwS8p0Y4cnDl3q4unNl2QByh8i6EklBSjqV+zLvqq9EgBE6KfTWR2T4h7rrFI2KjUz -4ykfScXr72bNdTmLqEhfx5lkTe6bJPmWJzklPW8ZSfJDjFHcK9aSiq97m7ds1nQGSfLIhQl5 -LVJWkSSLL81qkd1pb5ye+XcndydEeETNxzl7HsTrAFCXve9WtSgPAhCVAkjS6wGgLnGmC18M -+74fBbxiPmdTSgAobbGYjr88PSIDwMS6n9v57tt+JUDxyc8bOlW9eti8YhwAXPVBAti+Kb8n -ehyb9bIHSstZtqL0HuMRlokfbosGjhtJ1oxhwNVLl/UDoGfNGJUzWghAwFk6AYk/dvYCCG+9 -sR2S5hmKd7F2T7L7/G7mQTkAlNR5TrYggtIDIBw2HoBqFzcMH3CH4ec01EOFYvrSEEqCAERw -8De37DHVy5X348Lb3nUrCVebXQDWdmwBgH2Xnyw/NUWfZQsU69+eS5KVrXtuPPi+9zmSOgfe -Qv4Za6mTvrSZZDTnRZKc7H3zrdd7tjxMRU53n+YaL9aRig/mkqOzjEtnnbvXayPxHknFqZ0X -/Phl2j1xhrjm6x0kyd2XJSVmPhogqXP0A2Ro6KBqkg29PyWD17xDkh+0bH1+79t+ok5y6Wgf -ufKBQlJx+j1Blg+5vU6RiptH9R/8foSk4onbWp/fbOhJ86aOsyAUemFNuyyjGhEOAH6PBiCs -aRQRqQHQdcApzrKQFCAEAi7tLHjQF3uY/99hrv7Jwn+ZGf8Csui/jE3CspO0DWbMlT3rMx2S -cELE9585zIbaf+1fQSCiOxwgosoJGXBLwhdNE9V6E4DH/Uw+j5RQP3Xw+vde6KaoPNYzvL51 -ewBLO7er/m6oC8CRd2o73ZeihMBPn9T1HuUGsOdgJNqrk5LAgrnZf/WYSMnjX+whyT2Dqrh2 -cIDk3LHkG4+R1Pv2vDpvbINOBjtfr4rbnyS59pLKETeVkOSl81jQsZ5kVe/73x44JESyusvk -BcM3keQTfZ4a3aGM5IoOs7/yxzk8ifWEQNekj56YOsADILx3tb7TA0DVv9endvBnYwDVTD38 -rFcASDg6qLQoiQJIdMHhAYAN3ukY1+lAd8B7weYj6akAhTudHqcCsPiBO2OvHVBHTjVEAGDi -khXHHgQAV8HU11e5AUBLQ2qiHwDdM1MeUcZb8VvX3AcBwH0QRwISQMvS9cFvmAGA1z81+sA7 -ABBKS5n5P811oMdn+T9FY/dZ6btmOP+I628kyek3kU/eSTKSe/mofgMrSJ7uVcC7mp0iueZy -1vR4myS3XjSgqxGv/61XbtdFVKT+QP8b8taQ5NPT+crgCpLBx3vc7I/ZxrIfzA8wDr4eUCRZ -sIbcuplkdMmHCzf6qcjw9lo2bAtQsb5IZ8V2nVSsKyg1Tayv2ArcS4uqqUhVWc3QEQNJfcB0 -U+Nto+4AKUFKKEhQmO4fIazwmYTdaYXZiKvZYbWSUEJYw0xbKmgNRuMFYEPQqCkaAc7Ko1oe -ZRyKf38Af87yK80Vf7HxSwPjB2mT4vkOKJN4BYryY8kOXeinPRAgKxNY6HEAJ0rraumhXucR -tf4EssyhHXE5Kao2l2VLiPJjR0NpQgm1Zl2zZIKy9MdWMbaTkcoKUnHPg6OHrafipBHDn/Qr -xVVXjrjmFHlojJHFfSD//sdqqTh9XH/XMir9wbUc8w2VurmQI7eRp65+8c7pVJx4y7N9N5Hq -Dw/8+doT1HXe09r6Xo8SgLZ7Jyhw6NA1cguA/U++VTtDAFNeXPiCg1AhCBCouvv7l1N08P5H -HLOHKMihswv8VwPi9ITxWx2As0VZOAqFUGi/5gWO//ze5G5rIOS2olvnWLyUgH7YGagRgBao -aFIMgO4UrQFA83U/ro8KuGq3rzwhBEJv/uGugKSYeWkP90EpcHX6nXdrAMK/G9U5CITS89JW -QaDhziu8nYDmzce/mt8LxKzzHSv2mWKoTYLwlznaaxDHNjvK+vWCWDt3cdrTXorLVy5p31cT -3L91V/scINKvf3F6c2B9B09B6/Mp0Kp2nAQYHNpFtstkQnB3kwlpFFrPQa6UdGpXnZYP5SrR -oE24MjczA/Yrk1pZeg8FQn7N7aGAHhHuM5P5jVTvzLaSMZWyc6YifmycUkeroi1/3aNIfIkq -51mq/QtF0AhiEZfKM7J7jT6DOHsvNoRmqvwX6ImfKRjXVsbXQoKksL/AUIKmkaOEEhBQkqC0 -DKWEopA2IiPINiNwA2gH2NokIFJWmwpARbQwJKPaEekht5Y2l6j/6bgjiVDrDrR0AlyengRx -qKDVlkyXKP1wxwUuWfK3i3bM6auVf7attIPE0hT3960cFVPW7e7hEp8v/ambQ6z8aEPieRZl -EoBWcAgEdn4gph4X1ZNnzHZAe3/x4hXAymkLnlVCvrN0XT4gdr07E8TP969fVovQlLyk1wVK -5n318TdRlHx+6uUSQCxcfsCFihW+FDeji47tbQB2nyz6AvHISmW0nkR0wcRvJRwblrXxEpuf -bH8ACDaEKsPAnrEPZQCY6/6kSALPfLfBiYjPjSAQuvfNNp2iCGrZE88DriucfRegpSbVhiB6 -NN97FKjJK7nGRqZNAiK1eiuHRElk8v4LsuoPfjgjtTVSPy5rdyFOHHBmDXKiyfRVvZrj9Ik/ -5EZao7blTcE8l6vd55GHvVAtL+nXqo0m+w3J1QDktO2mhNuV7Mn1SG/ZjX0kHEP6h+xvqgUB -biy7BYDfn12d5FR1aao+FQiFkwEVpfufEGmerVzxUmhXBQEViKaeOeDfUgTjlMmQe3FGwsZq -k8IwyTBua+IXlfAXipmPIgEIS4+UoKACoJQQQukQQuhKSCodEIoUIkoKIZQCoFPRrxjUoxGg -rkQBerUCfCUno1Any8BonemZSwD69j0CQGTfvqisKN9ZIX07G3YJsW1JvtS2jJ9HrWTOoiot -MP2FIq3h05pZUv6waE5AlEz541554uHDY49KKWZFxfcrPz4I37RZh4Dv7/cDhU+O9GHrpKm7 -xNEpIkaZ8JXoBPa+MnEnjj+xIB2+r8JfQXy6yo/wR4/lH0bp8rk74O3Quh2SI5ObCFzw3vEU -BE4fUAi43mAAVasqJIK7f65GrecGILoi8CmQqj+ahFM9ehyFtL4J1SYhWlBYltAMOBYZcaGr -TMtObuLd/UOnrthanNlTc+9IH+jw73H3awnhaQWcV3CHFAU9HC0Sa7vkNk9XrVMGNE0VO3u0 -Qerl3bKSU8IHu3l97camZKM4JamVy1uaMcjp7ZAau2JC37kHKYk6kUxG6AgniFBdlhKBsDOR -UtdIRuG2pcb4MZ5ojPyfEgJK2HeSbqUsEXJKG2Qh0zfK/r9Ohv/JcqaYCgK6du6xv3mRAIRu -ZPwafWRDReutxQpHz4ws7TBVEdCJ2EtM/CgF3ZqpTQLqVkWyAQohlBSCQkCpqA5AqqCmM+wI -QxL+sKvspFcrPprkLtb93gpR6wnt0w60OLqkoaXcFsz0H6z1pW/7Nkf/4Hhu4IsjraPbS5MS -Ni1Kzd7+fqCjHZ+BoXIAcsP0nbJ42VeyaPqKav2liTrn/3XOz/LL8nnihyJQbNgs3n2yQDz/ -P/twYkwFTs1Yrp167pWv8fP82VrgjanQ33jxANalBSo+qZU/1mwp9GxemYaSdRK7E9ebLHFQ -1O3zqEACRYH7k4uK516Hir0ru3sukR7ou0JDEXq1DyIfjLx4x+q70eaEW/W9riUwsLhL12/z -4B0d6Iy2r1Sg/I6G0+6RmRr6/aglT+uNbnt75mJEAODFPtyyoavlpChF37QodZ2b3vqZR0o3 -BCvK9tfzVCWV//QppYd2hdhQVKWCVSoSCem6ooqGGYrqxqlSp/GtvVIkjYSV8cW4Tuo6GfvX -AFIoIFLY0akACdQnx+4J0lAf0wGCUIAgISBs50zQqijThCtpR13GUEA0umL+Y+X/9dzV/yfI -HGEJBU0J848QyqGUAKWSSkJpikaHQxcKAtB0mr2aoiMKIRVo9EpC0ymVAMC4XmH9R5ijOE3V -yfSA9LOJXwsohzuQ3VDrcgSTfN76VNRk+4Jaml82oGmVxwe30LNOBxKU7gl6fBnBhmaVuisp -wKDMqvL4kBhxZJRHkoKaVCKcUR/NOsUETygScWYlGNb3/wA9AhmM+SowxQAAAABJRU5ErkJg -gg==' - base64Decoded asByteArray readStream) display -"! ! -!PNGReadWriter methodsFor: 'pixel copies' stamp: 'jmv 6/30/2011 10:22'! - copyPixelsIndexed: y - "Handle non-interlaced indexed color mode (colorType = 3)" - | hack hackBlt swizzleHack swizzleBlt scanline hackDepth | - scanline := ByteArray new: bytesPerScanline + 3 // 4 * 4. - scanline replaceFrom: 1 to: thisScanline size with: thisScanline startingAt: 1. - hackDepth := bigEndian ifTrue:[form depth] ifFalse:[form depth negated]. - hack := Form extent: width@1 depth: hackDepth bits: scanline. - hackBlt := BitBlt toForm: form. - hackBlt sourceForm: hack. - hackBlt combinationRule: Form over. - hackBlt destOrigin: 0@y. - hackBlt width: width; height: 1. - - (form depth < 8 and:[bigEndian not]) ifTrue:[ - swizzleHack := Form new hackBits: scanline. - swizzleBlt := BitBlt toForm: swizzleHack. - swizzleBlt sourceForm: swizzleHack. - swizzleBlt combinationRule: Form over. - swizzleBlt colorMap: (StandardSwizzleMaps at: form depth). - swizzleBlt copyBits. - ]. - - hackBlt copyBits! ! -!PNGReadWriter methodsFor: 'pixel copies' stamp: 'jmv 9/23/2012 21:45'! - copyPixelsIndexed: y at: startX by: incX - "Handle interlaced indexed color mode (colorType = 3)" - - | offset bits pixPerByte shifts blitter pixel mask pixelNumber | - offset := y*rowSize+1. - bits := form bits. - bitsPerChannel = 8 - ifTrue: [ - startX to: width-1 by: incX do: [ :x | | b w | - w := offset + (x>>2). - b := 3 - (x \\ 4) * 8. - pixel := (thisScanline at: x // incX + 1)<> (shifts at: (pixelNumber \\ pixPerByte) + 1)) bitAnd: mask. - blitter pixelAt: (x@y) put: pixel. - pixelNumber := pixelNumber + 1. - ]. -! ! -!PNGReadWriter methodsFor: 'pixel copies' stamp: 'jmv 1/24/2017 11:22:33'! - copyPixelsRGB: y - "Handle non-interlaced RGB color mode (colorType = 2)" - - | i pixel tempForm tempBits | - tempForm _ Form extent: width @ 1 depth: 32. - tempBits _ tempForm bits. - pixel _ LargePositiveInteger new: 4. - pixel at: 4 put: 255. - bitsPerChannel = 8 - ifTrue: [ - i _ 1. - 1 to: width do: [ :x | - pixel - at: 3 put: (thisScanline at: i); - at: 2 put: (thisScanline at: i + 1); - at: 1 put: (thisScanline at: i + 2). - tempBits at: x put: pixel normalize. - i _ i + 3 ]. - transparentPixelValue ifNotNil: [ - 1 to: width do: [ :x | - (tempBits at: x) = transparentPixelValue ifTrue: [ - tempBits at: x put: 0 ]]]] - ifFalse: [ - i _ 1. - 1 to: width do: [ :x | - (transparentPixelValue == nil or: [ - (1 to: 6) anySatisfy: [ :k | - (transparentPixelValue digitAt: k) ~= (thisScanline at: i + 6 - k) ]]) - ifTrue: [ - pixel - at: 3 put: (thisScanline at: i); - at: 2 put: (thisScanline at: i + 2); - at: 1 put: (thisScanline at: i + 4). - tempBits at: x put: pixel normalize ] - ifFalse: [ - tempBits at: x put: 0 ]. - i _ i + 6 ]]. - tempForm displayOn: form at: 0 @ y rule: Form over! ! -!PNGReadWriter methodsFor: 'pixel copies' stamp: 'jmv 1/24/2017 11:22:49'! - copyPixelsRGB: y at: startX by: incX - "Handle interlaced RGB color mode (colorType = 2)" - | i pixel tempForm tempBits xx loopsToDo | - tempForm _ Form - extent: width @ 1 - depth: 32. - tempBits _ tempForm bits. - pixel _ LargePositiveInteger new: 4. - pixel - at: 4 - put: 255. - loopsToDo _ width - startX + incX - 1 // incX. - bitsPerChannel = 8 - ifTrue: [ - i _ startX // incX * 3 + 1. - xx _ startX + 1. - 1 to: loopsToDo do: [ :j | - pixel - at: 3 put: (thisScanline at: i); - at: 2 put: (thisScanline at: i + 1); - at: 1 put: (thisScanline at: i + 2). - tempBits at: xx put: pixel normalize. - i _ i + 3. - xx _ xx + incX ]. - transparentPixelValue ifNotNil: [ - startX to: width - 1 by: incX do: [ :x | - (tempBits at: x + 1) = transparentPixelValue ifTrue: [ - tempBits at: x + 1 put: 0 ]]]] - ifFalse: [ - i _ startX // incX * 6 + 1. - xx _ startX + 1. - 1 to: loopsToDo do: [ :j | - (transparentPixelValue == nil or: [ - (1 to: 6) anySatisfy: [ :k | - (transparentPixelValue digitAt: k) ~= (thisScanline at: i + 6 - k) ]]) - ifTrue: [ - pixel - at: 3 put: (thisScanline at: i); - at: 2 put: (thisScanline at: i + 2); - at: 1 put: (thisScanline at: i + 4). - tempBits at: xx put: pixel normalize ] - ifFalse: [ - tempBits at: xx put: 0 ]. - i _ i + 6. - xx _ xx + incX ]]. - tempForm displayOn: form at: 0 @ y rule: Form over! ! -!PNGReadWriter methodsFor: 'pixel copies' stamp: 'jmv 1/24/2017 11:23:10'! - copyPixelsRGBA: y - "Handle non-interlaced RGBA color modes (colorType = 6)" - - | i pixel tempForm tempBits ff | - bitsPerChannel = 8 ifTrue: [ - ff := Form extent: width@1 depth: 32 bits: thisScanline. - cachedDecoderMap - ifNil:[cachedDecoderMap := self rgbaDecoderMapForDepth: depth]. - (BitBlt toForm: form) - sourceForm: ff; - destOrigin: 0@y; - combinationRule: Form over; - colorMap: cachedDecoderMap; - copyBits. - ^self. - ]. - tempForm _ Form extent: width@1 depth: 32. - tempBits _ tempForm bits. - pixel := LargePositiveInteger new: 4. - i := -7. - 0 to: width-1 do: [ :x | - i := i + 8. - pixel at: 4 put: (thisScanline at: i+6); - at: 3 put: (thisScanline at: i); - at: 2 put: (thisScanline at: i+2); - at: 1 put: (thisScanline at: i+4). - tempBits at: x+1 put: pixel normalize. - ]. - tempForm displayOn: form at: 0@y rule: Form over. -! ! -!PNGReadWriter methodsFor: 'pixel copies' stamp: 'jmv 1/24/2017 11:23:39'! - copyPixelsRGBA: y at: startX by: incX - "Handle interlaced RGBA color modes (colorType = 6)" - - | i pixel tempForm tempBits | - - tempForm := Form extent: width@1 depth: 32. - tempBits := tempForm bits. - pixel := LargePositiveInteger new: 4. - bitsPerChannel = 8 ifTrue: [ - i := (startX // incX << 2) + 1. - startX to: width-1 by: incX do: [ :x | - pixel at: 4 put: (thisScanline at: i+3); - at: 3 put: (thisScanline at: i); - at: 2 put: (thisScanline at: i+1); - at: 1 put: (thisScanline at: i+2). - tempBits at: x+1 put: pixel normalize. - i := i + 4. - ] - ] ifFalse: [ - i := (startX // incX << 3) +1. - startX to: width-1 by: incX do: [ :x | - pixel at: 4 put: (thisScanline at: i+6); - at: 3 put: (thisScanline at: i); - at: 2 put: (thisScanline at: i+2); - at: 1 put: (thisScanline at: i+4). - tempBits at: x+1 put: pixel normalize. - i := i + 8. - ]. - ]. - tempForm displayOn: form at: 0@y rule: Form paintAlpha. - -! ! -!PNGReadWriter methodsFor: 'accessing' stamp: 'RAA 11/7/2000 09:20'! - debugging - - ^Debugging == true! ! -!PNGReadWriter methodsFor: 'miscellaneous' stamp: 'DSM 4/27/2000 13:09'! - doPass: pass - "Certain interlace passes are skipped with certain small image -dimensions" - - pass = 1 ifTrue: [ ^ true ]. - ((width = 1) and: [height = 1]) ifTrue: [ ^ false ]. - pass = 2 ifTrue: [ ^ width >= 5 ]. - pass = 3 ifTrue: [ ^ height >= 5 ]. - pass = 4 ifTrue: [ ^ (width >=3 ) or: [height >= 5] ]. - pass = 5 ifTrue: [ ^ height >=3 ]. - pass = 6 ifTrue: [ ^ width >=2 ]. - pass = 7 ifTrue: [ ^ height >=2 ]. - -! ! -!PNGReadWriter methodsFor: 'filtering' stamp: 'RAA 11/7/2000 09:43'! - filterAverage: count - "Use the average of the pixel to the left and the pixel above as a predictor" - - | delta | - delta _ bitsPerPixel // 8 max: 1. - 1 to: delta do: [:i | - thisScanline at: i put: ((thisScanline at: i) + ((prevScanline at: i) // 2) bitAnd: 255)]. - delta + 1 to: count do: [:i | - thisScanline at: i put: - ((thisScanline at: i) - + ((prevScanline at: i) - + (thisScanline at: i - delta) // 2) bitAnd: 255)]! ! -!PNGReadWriter methodsFor: 'filtering' stamp: 'DSM 3/25/2000 17:54'! - filterHorizontal: count - "Use the pixel to the left as a predictor" - - | delta | - delta _ bitsPerPixel // 8 max: 1. - delta+1 to: count do: [ :i | - thisScanline at: i put: (((thisScanline at: i) + -(thisScanline at: i-delta)) bitAnd: 255) ] - - -! ! -!PNGReadWriter methodsFor: 'filtering' stamp: 'DSM 3/25/2000 17:55'! - filterNone: count -! ! -!PNGReadWriter methodsFor: 'filtering' stamp: 'RAA 11/7/2000 09:45'! - filterPaeth: count - "Select one of (the pixel to the left, the pixel above and the pixel to above left) to - predict the value of this pixel" - - | delta | - delta _ bitsPerPixel // 8 max: 1. - 1 to: delta do: [ :i | - thisScanline at: i put: - (((thisScanline at: i) + (prevScanline at: i)) bitAnd: 255)]. - delta+1 to: count do: [ :i | - thisScanline - at: i - put: (((thisScanline at: i) + (self - paethPredictLeft: (thisScanline at: i-delta) - above: (prevScanline at: i) - aboveLeft: (prevScanline at: i-delta))) - bitAnd: 255)] - -! ! -!PNGReadWriter methodsFor: 'filtering' stamp: 'eat 9/11/2000 20:08'! - filterScanline: filterType count: count - - self - perform: ( - #(filterNone: filterHorizontal: filterVertical: filterAverage: filterPaeth:) - at: filterType+1) - with: count. - -! ! -!PNGReadWriter methodsFor: 'filtering' stamp: 'DSM 3/25/2000 17:54'! - filterVertical: count - "Use the pixel above as a predictor" - - 1 to: count do: [ :i | - thisScanline at: i put: (((thisScanline at: i) + -(prevScanline at: i)) bitAnd: 255) ] - -! ! -!PNGReadWriter methodsFor: 'miscellaneous' stamp: 'jmv 4/15/2010 10:19'! - grayColorsFor: d - "return a color table for a gray image" - - palette _ Array new: 1< c ifTrue: [b - c] ifFalse: [c - b]. - pb _ a > c ifTrue: [a - c] ifFalse: [c - a]. - pc _ a + b - c - c. - pc < 0 ifTrue: [ - pc := pc * -1]. - ((pa <= pb) and: [pa <= pc]) ifTrue: [^ a]. - (pb <= pc) ifTrue: [^ b]. - ^ c -! ! -!PNGReadWriter methodsFor: 'chunks' stamp: 'ar 2/10/2004 23:55'! - processBackgroundChunk - - | val red green blue max | - - "Transcript show: ' BACKGROUND: ',chunk printString." - colorType = 3 ifTrue: [ - backColor := palette at: chunk first + 1. - ^self - ]. - max _ (2 raisedTo: bitsPerChannel) - 1. - (colorType = 0 or: [colorType = 4]) ifTrue: [ - val _ chunk unsignedShortAt: 1 bigEndian: true. - backColor := Color gray: val / max. - ^self - ]. - (colorType = 2 or: [colorType = 6]) ifTrue: [ - red _ chunk unsignedShortAt: 1 bigEndian: true. - green _ chunk unsignedShortAt: 3 bigEndian: true. - blue _ chunk unsignedShortAt: 5 bigEndian: true. - backColor := Color r: red/max g: green/max b: blue/max. - ^self - ]. -"self halt." - -"==== -The bKGD chunk specifies a default background color to present the image against. Note that viewers are not bound to honor this chunk; a viewer can choose to use a different background. - -For color type 3 (indexed color), the bKGD chunk contains: - - - Palette index: 1 byte - -The value is the palette index of the color to be used as background. - -For color types 0 and 4 (grayscale, with or without alpha), bKGD contains: - - - Gray: 2 bytes, range 0 .. (2^bitdepth)-1 - -(For consistency, 2 bytes are used regardless of the image bit depth.) The value is the gray level to be used as background. - -For color types 2 and 6 (truecolor, with or without alpha), bKGD contains: - - - Red: 2 bytes, range 0 .. (2^bitdepth)-1 - Green: 2 bytes, range 0 .. (2^bitdepth)-1 - Blue: 2 bytes, range 0 .. (2^bitdepth)-1 - -(For consistency, 2 bytes per sample are used regardless of the image bit depth.) This is the RGB color to be used as background. - -When present, the bKGD chunk must precede the first IDAT chunk, and must follow the PLTE chunk, if any. -===" -! ! -!PNGReadWriter methodsFor: 'chunks' stamp: 'RAA 11/4/2000 17:00'! - processIDATChunk - - interlaceMethod = 0 - ifTrue: [ self processNonInterlaced ] - ifFalse: [ self processInterlaced ] -! ! -!PNGReadWriter methodsFor: 'chunks' stamp: 'jmv 5/13/2016 15:04'! - processIHDRChunk - width _ chunk longAt: 1 bigEndian: true. - height _ chunk longAt: 5 bigEndian: true. - bitsPerChannel _ chunk at: 9. - colorType _ chunk at: 10. - "compression _ chunk at: 11." "TODO - validate compression" - "filterMethod _ chunk at: 12." "TODO - validate filterMethod" - interlaceMethod _ chunk at: 13. "TODO - validate interlace method" - (#(2 4 6) includes: colorType) - ifTrue: [depth _ 32]. - (colorType = 0 and: [ bitsPerChannel = 8 ]) ifTrue: [ - depth _ 8. - palette _ nil. "Meaning: 'please use a GrayForm'" - ] ifFalse: [ - (#(0 3) includes: colorType) ifTrue: [ - depth _ bitsPerChannel min: 8. - colorType = 0 ifTrue: [ "grayscale" - palette := self grayColorsFor: depth ]]]. - bitsPerPixel _ (BPP at: colorType+1) at: bitsPerChannel highBit. - bytesPerScanline _ width * bitsPerPixel + 7 // 8. - rowSize _ width * depth + 31 >> 5. -! ! -!PNGReadWriter methodsFor: 'chunks' stamp: 'nice 12/26/2009 19:05'! -processInterlaced - | z startingCol colIncrement rowIncrement startingRow | - startingCol := #(0 4 0 2 0 1 0 ). - colIncrement := #(8 8 4 4 2 2 1 ). - rowIncrement := #(8 8 8 4 4 2 2 ). - startingRow := #(0 0 4 0 2 0 1 ). - z := ZLibReadStream on: chunk from: 1 to: chunk size. - 1 to: 7 do: [:pass | - | cx sc bytesPerPass | - (self doPass: pass) - ifTrue: - [cx := colIncrement at: pass. - sc := startingCol at: pass. - bytesPerPass := width - sc + cx - 1 // cx * bitsPerPixel + 7 // 8. - prevScanline := ByteArray new: bytesPerPass. - thisScanline := ByteArray new: bytesPerScanline. - (startingRow at: pass) - to: height - 1 - by: (rowIncrement at: pass) - do: [:y | - | filter temp | - filter := z next. - filtersSeen add: filter. - (filter isNil or: [(filter between: 0 and: 4) not]) - ifTrue: [^ self]. - thisScanline := z next: bytesPerPass into: thisScanline startingAt: 1. - self filterScanline: filter count: bytesPerPass. - self copyPixels: y at: sc by: cx. - temp := prevScanline. - prevScanline := thisScanline. - thisScanline := temp. - ] - ] - ]. - z atEnd ifFalse:[self error:'Unexpected data'].! ! -!PNGReadWriter methodsFor: 'chunks' stamp: 'jmv 2/29/2016 11:19'! - processNextChunk - - | length chunkType crc chunkCrc | - - length _ self nextUnsignedInt32. - chunkType _ (self next: 4) asString. - - "If someone appended garbage at the end of the file, don't let that bite us." - fileSize - self position < length ifTrue: [ - unknownChunks add: chunkType. - stream setToEnd. - ^self ]. - - chunk _ self next: length. - chunkCrc := self nextUnsignedInt32 bitXor: 16rFFFFFFFF. - crc := self updateCrc: 16rFFFFFFFF from: 1 to: 4 in: chunkType. - crc := self updateCrc: crc from: 1 to: length in: chunk. - crc = chunkCrc ifFalse:[ - self error: 'PNGReadWriter crc error in chunk ', chunkType. - ]. - - chunkType = 'IEND' ifTrue: [^self "*should* be the last chunk"]. - chunkType = 'sBIT' ifTrue: [^self processSBITChunk "could indicate unusual sample depth in original"]. - chunkType = 'gAMA' ifTrue: [^self "indicates gamma correction value"]. - chunkType = 'bKGD' ifTrue: [^self processBackgroundChunk]. - chunkType = 'pHYs' ifTrue: [^self processPhysicalPixelChunk]. - chunkType = 'tRNS' ifTrue: [^self processTransparencyChunk]. - - chunkType = 'IHDR' ifTrue: [^self processIHDRChunk]. - chunkType = 'PLTE' ifTrue: [^self processPLTEChunk]. - chunkType = 'IDAT' ifTrue: [ - "---since the compressed data can span multiple - chunks, stitch them all together first. later, - if memory is an issue, we need to figure out how - to do this on the fly---" - globalDataChunk _ globalDataChunk ifNil: [chunk] ifNotNil: - [globalDataChunk,chunk]. - ^self - ]. - unknownChunks add: chunkType. -! ! -!PNGReadWriter methodsFor: 'chunks' stamp: 'jmv 3/13/2012 12:42'! - processNonInterlaced - | z filter temp copyMethod debug | - debug := self debugging. - copyMethod _ #(copyPixelsGray: nil copyPixelsRGB: copyPixelsIndexed: - copyPixelsGrayAlpha: nil copyPixelsRGBA:) at: colorType+1. - debug ifTrue: [ Transcript newLine; nextPutAll: 'NI chunk size='; print: chunk size ]. - z _ ZLibReadStream on: chunk from: 1 to: chunk size. - prevScanline _ ByteArray new: bytesPerScanline. - thisScanline := ByteArray new: bytesPerScanline. - - (colorType = 0 and: [ bitsPerChannel < 16]) ifTrue: [ - auxSource _ Form extent: 1 @ (thisScanline size // 4) depth: 32 bits: thisScanline. - auxDest _ Form extent: 1 @ (form bits size) depth: 32 bits: form bits. - auxCMap _ Smalltalk isLittleEndian - ifTrue:[ColorMap - shifts: #(-24 -8 8 24) - masks: #(16rFF000000 16r00FF0000 16r0000FF00 16r000000FF)]. - auxBitBlt _ (BitBlt toForm: auxDest) - sourceForm: auxSource; - colorMap: auxCMap; - combinationRule: 3 ]. - - 0 to: height-1 do: [ :y | - filter _ (z next: 1) first. - debug ifTrue:[filtersSeen add: filter]. - thisScanline _ z next: bytesPerScanline into: thisScanline startingAt: 1. - (debug and: [ thisScanline size < bytesPerScanline ]) ifTrue: [ - Transcript nextPutAll: ('wanted {1} but only got {2}' format: { bytesPerScanline. thisScanline size }); newLine ]. - filter = 0 ifFalse:[self filterScanline: filter count: bytesPerScanline]. - self perform: copyMethod with: y. - temp := prevScanline. - prevScanline := thisScanline. - thisScanline := temp. - ]. - z atEnd ifFalse:[self error:'Unexpected data']. - debug ifTrue: [Transcript nextPutAll: ' compressed size='; print: z position ]. -! ! -!PNGReadWriter methodsFor: 'chunks' stamp: 'ar 2/11/2004 01:02'! - processPLTEChunk - - | colorCount i | - - colorCount _ chunk size // 3. "TODO - validate colorCount against depth" - palette _ Array new: colorCount. - 0 to: colorCount-1 do: [ :index | - i _ index * 3 + 1. - palette at: index+1 put: - (Color r: (chunk at: i)/255.0 g: (chunk at: i+1)/255.0 b: (chunk at: i+2)/255.0) - ].! ! -!PNGReadWriter methodsFor: 'chunks' stamp: 'RAA 11/5/2000 11:24'! - processPhysicalPixelChunk - - "Transcript show: ' PHYSICAL: ',chunk printString." -! ! -!PNGReadWriter methodsFor: 'chunks' stamp: 'ar 12/12/2003 18:33'! - processSBITChunk - | rBits gBits bBits aBits | - colorType = 6 ifFalse:[^self]. - rBits := chunk at: 1. - gBits := chunk at: 2. - bBits := chunk at: 3. - aBits := chunk at: 4. - (rBits = 5 and:[gBits = 5 and:[bBits = 5 and:[aBits = 1]]]) ifTrue:[ - depth := 16. - ].! ! -!PNGReadWriter methodsFor: 'chunks' stamp: 'jmv 1/18/2017 11:52:19'! - processTransparencyChunk - - "Transcript show: ' TRANSPARENCY ',chunk printString." - colorType = 0 ifTrue: [ - transparentPixelValue _ chunk unsignedShortAt: 1 bigEndian: true. - bitsPerChannel <= 8 - ifTrue: [ - "If palette is nil, we are building a GrayForm from a grayscale 8bpp file. Ignore any transparency chunk!!" - palette ifNotNil: [ - palette at: transparentPixelValue + 1 put: Color transparent ]] - ifFalse: [ - palette at: 1 put: Color transparent ]. - ^ self ]. - colorType = 2 ifTrue: [ - | red green blue | - red _ chunk unsignedShortAt: 1 bigEndian: true. - green _ chunk unsignedShortAt: 3 bigEndian: true. - blue _ chunk unsignedShortAt: 5 bigEndian: true. - transparentPixelValue _ bitsPerChannel <= 8 - ifTrue: [ 16rFF00 + red << 8 + green << 8 + blue ] - ifFalse: [ red << 16 + green << 16 + blue ]. - ^ self ]. - colorType = 3 ifTrue: [ - chunk withIndexDo: [ :alpha :index | - palette at: index put: ((palette at: index) alpha: alpha / 255) ]. - ^ self ]! ! -!PNGReadWriter methodsFor: 'pixel copies' stamp: 'ar 2/19/2004 00:10'! - rgbaDecoderMapForDepth: decoderDepth - bigEndian ifTrue:[ - depth = 16 ifTrue:[ - "Big endian, 32 -> 16 color mapping." - ^ColorMap - shifts: #(-17 -14 -11 0) - masks: #(16rF8000000 16rF80000 16rF800 16r00) - ] ifFalse:[ - "Big endian, 32 -> 32 color mapping" - ^ColorMap - shifts: #(-8 -8 -8 24) - masks: #(16rFF000000 16rFF0000 16rFF00 16rFF). - ]. - ]. - depth = 16 ifTrue:[ - "Little endian, 32 -> 16 color mapping." - ^ColorMap - shifts: #(7 -6 -19 0) - masks: #(16rF8 16rF800 16rF80000 0) - ] ifFalse:[ - "Little endian, 32 -> 32 color mapping" - ^ColorMap - shifts: #(-16 0 16 0) - masks: #(16rFF0000 16rFF00 16rFF 16rFF000000). - ].! ! -!PNGReadWriter methodsFor: 'accessing' stamp: 'DSM 3/24/2000 01:12'! - understandsImageFormat - #(137 80 78 71 13 10 26 10) do: [ :byte | - stream next = byte ifFalse: [^ false]]. - ^ true -! ! -!PNGReadWriter methodsFor: 'writing' stamp: 'nk 2/17/2004 16:51'! - updateCrc: oldCrc from: start to: stop in: aCollection - ^ZipWriteStream updateCrc: oldCrc from: start to: stop in: aCollection! ! -!PNGReadWriter methodsFor: 'writing' stamp: 'jmv 2/26/2016 17:06'! - writeChunk: crcStream - | bytes length crc debug | - debug := self debugging. - bytes := crcStream originalContents. - length := crcStream position. - crc := self updateCrc: 16rFFFFFFFF from: 1 to: length in: bytes. - crc := crc bitXor: 16rFFFFFFFF. - debug ifTrue: [ - Transcript newLine; - print: stream position; space; - nextPutAll: (bytes copyFrom: 1 to: 4) asString; - nextPutAll: ' len='; print: length; - nextPutAll: ' crc=0x'; nextPutAll: crc printStringHex ]. - stream nextUnsignedInt32Put: length-4 bigEndian: true. "exclude chunk name" - stream next: length putAll: bytes startingAt: 1. - stream nextUnsignedInt32Put: crc bigEndian: true. - debug ifTrue: [ Transcript nextPutAll: ' afterPos='; print: stream position ]. - crcStream resetToStart.! ! -!PNGReadWriter methodsFor: 'writing' stamp: 'nice 1/18/2010 18:08'! - writeFileSignature - stream nextPutAll: #[ 16r89 16r50 16r4E 16r47 16r0D 16r0A 16r1A 16r0A ]! ! -!PNGReadWriter methodsFor: 'writing' stamp: 'jmv 3/12/2017 19:19:47'! - writeIDATChunkOn: aStream - "Write the IDAT chunk" - | z | - aStream nextPutAll: 'IDAT' asByteArray. - - "Avoid growing multiple times. do a rough estimation of space needed" - aStream growTo: bytesPerScanline * height *11//20. - - z _ ZLibWriteStream on: aStream. - form depth <= 8 - ifTrue: [ - "Same format for type 3 (indexed color) and type 0 (grayscale, GrayForm)" - self writeType3DataOn: z ] - ifFalse: [ self writeType6DataOn: z ]. - z close. - self debugging ifTrue: [ - Transcript newLine; - nextPutAll: 'compressed size='; - print: aStream position; - nextPutAll: ' uncompressed size='; - print: z position ]! ! -!PNGReadWriter methodsFor: 'writing' stamp: 'ar 12/12/2003 17:08'! - writeIENDChunkOn: aStream - "Write the IEND chunk" - aStream nextPutAll: 'IEND' asByteArray.! ! -!PNGReadWriter methodsFor: 'writing' stamp: 'jmv 2/26/2016 17:06'! - writeIHDRChunkOn: aStream - "Write the IHDR chunk" - aStream nextPutAll: 'IHDR' asByteArray. - aStream nextSignedInt32Put: width bigEndian: true. - aStream nextSignedInt32Put: height bigEndian: true. - aStream nextPut: bitsPerChannel. - aStream nextPut: colorType. - aStream nextPut: 0. "compression" - aStream nextPut: 0. "filter method" - aStream nextPut: 0. "interlace method" -! ! -!PNGReadWriter methodsFor: 'writing' stamp: 'jmv 1/12/2010 12:12'! - writePLTEChunkOn: aStream - "Write the PLTE chunk" - | r g b colors | - aStream nextPutAll: 'PLTE' asByteArray. - (form is: #ColorForm) - ifTrue: [ colors := form colors] - ifFalse: [ colors := Color indexedColors copyFrom: 1 to: (1 bitShift: form depth)]. - colors do:[:aColor| - r := (aColor red * 255) truncated. - g := (aColor green * 255) truncated. - b := (aColor blue * 255) truncated. - aStream nextPut: r; nextPut: g; nextPut: b. - ].! ! -!PNGReadWriter methodsFor: 'writing' stamp: 'ar 12/12/2003 18:29'! - writeSBITChunkOn: aStream - "Write the IDAT chunk" - aStream nextPutAll: 'sBIT' asByteArray. - form depth = 16 ifFalse:[self error: 'Unimplemented feature']. - aStream nextPut: 5. - aStream nextPut: 5. - aStream nextPut: 5. - aStream nextPut: 1.! ! -!PNGReadWriter methodsFor: 'writing' stamp: 'ar 12/12/2003 17:34'! - writeTRNSChunkOn: aStream - "Write out tRNS chunk" - aStream nextPutAll: 'tRNS' asByteArray. - form colors do:[:aColor| - aStream nextPut: (aColor alpha * 255) truncated. - ].! ! -!PNGReadWriter methodsFor: 'writing' stamp: 'jmv 10/3/2015 14:18'! - writeType3DataOn: zStream - "Write color indexed data." - | scanline hack hackBlt swizzleBlt swizzleHack hackDepth | - scanline := ByteArray new: bytesPerScanline + 3 // 4 * 4. - hackDepth := bigEndian ifTrue:[form depth] ifFalse:[form depth negated]. - hack := Form extent: width@1 depth: hackDepth bits: scanline. - hackBlt := BitBlt toForm: hack. - hackBlt sourceForm: form. - hackBlt combinationRule: Form over. - hackBlt destOrigin: 0@0. - hackBlt width: width; height: 1. - (form depth < 8 and:[bigEndian not]) ifTrue:[ - swizzleHack := Form new hackBits: scanline. - swizzleBlt := BitBlt toForm: swizzleHack. - swizzleBlt sourceForm: swizzleHack. - swizzleBlt combinationRule: Form over. - swizzleBlt colorMap: (StandardSwizzleMaps at: form depth). - ]. - 0 to: height-1 do:[:i| - hackBlt sourceOrigin: 0@i; copyBits. - swizzleBlt ifNotNil:[swizzleBlt copyBits]. - zStream nextPut: 0. "filterType" - zStream next: bytesPerScanline putAll: scanline startingAt: 1. - ]! ! -!PNGReadWriter methodsFor: 'writing' stamp: 'jmv 10/3/2015 14:19'! - writeType6DataOn: zStream - "Write RGBA data." - | scanline hack hackBlt cm miscBlt | - scanline := ByteArray new: bytesPerScanline. - hack := Form extent: width@1 depth: 32 bits: scanline. - form depth = 16 ifTrue:[ - "Expand 16 -> 32" - miscBlt := BitBlt toForm: hack. - miscBlt sourceForm: form. - miscBlt combinationRule: Form over. - miscBlt destOrigin: 0@0. - miscBlt width: width; height: 1. - ]. - hackBlt := BitBlt toForm: hack. - hackBlt sourceForm: (miscBlt ifNil:[form] ifNotNil:[hack]). - hackBlt combinationRule: Form over. - hackBlt destOrigin: 0@0. - hackBlt width: width; height: 1. - bigEndian ifTrue:[ - cm := ColorMap - shifts: #(8 8 8 -24) - masks: #(16rFF0000 16rFF00 16rFF 16rFF000000). - ] ifFalse:[ - cm := ColorMap - shifts: #(-16 0 16 0) - masks: #(16rFF0000 16rFF00 16rFF 16rFF000000). - ]. - hackBlt colorMap: cm. - 0 to: height-1 do:[:i| - miscBlt ifNil:[ - hackBlt sourceOrigin: 0@i; copyBits. - ] ifNotNil:[ - miscBlt sourceOrigin: 0@i; copyBits. - hack fixAlpha. - hackBlt copyBits. - ]. - zStream nextPut: 0. "filterType" - zStream nextPutAll: scanline. - ]! ! -!PNGReadWriter class methodsFor: 'as yet unclassified' stamp: 'ar 2/11/2004 00:54'! - computeSwizzleMapForDepth: depth - "Answer a map that maps pixels in a word to their opposite location. Used for 'middle-endian' forms where the byte-order is different from the bit order (good joke, eh?)." - | map swizzled | - map := Bitmap new: 256. - depth = 4 ifTrue:[ - 0 to: 255 do:[:pix| - swizzled := 0. - swizzled := swizzled bitOr: (((pix bitShift: 0) bitAnd: 15) bitShift: 4). - swizzled := swizzled bitOr: (((pix bitShift: -4) bitAnd: 15) bitShift: 0). - map at: pix+1 put: swizzled. - ]. - ^ColorMap colors: map - ]. - - depth = 2 ifTrue:[ - 0 to: 255 do:[:pix| - swizzled := 0. - swizzled := swizzled bitOr: (((pix bitShift: 0) bitAnd: 3) bitShift: 6). - swizzled := swizzled bitOr: (((pix bitShift: -2) bitAnd: 3) bitShift: 4). - swizzled := swizzled bitOr: (((pix bitShift: -4) bitAnd: 3) bitShift: 2). - swizzled := swizzled bitOr: (((pix bitShift: -6) bitAnd: 3) bitShift: 0). - map at: pix+1 put: swizzled. - ]. - ^ColorMap colors: map - ]. - - depth = 1 ifTrue:[ - 0 to: 255 do:[:pix| - swizzled := 0. - swizzled := swizzled bitOr: (((pix bitShift: 0) bitAnd: 1) bitShift: 7). - swizzled := swizzled bitOr: (((pix bitShift: -1) bitAnd: 1) bitShift: 6). - swizzled := swizzled bitOr: (((pix bitShift: -2) bitAnd: 1) bitShift: 5). - swizzled := swizzled bitOr: (((pix bitShift: -3) bitAnd: 1) bitShift: 4). - swizzled := swizzled bitOr: (((pix bitShift: -4) bitAnd: 1) bitShift: 3). - swizzled := swizzled bitOr: (((pix bitShift: -5) bitAnd: 1) bitShift: 2). - swizzled := swizzled bitOr: (((pix bitShift: -6) bitAnd: 1) bitShift: 1). - swizzled := swizzled bitOr: (((pix bitShift: -7) bitAnd: 1) bitShift: 0). - map at: pix+1 put: swizzled. - ]. - ^ColorMap colors: map - ]. - self error: 'Unrecognized depth'! ! -!PNGReadWriter class methodsFor: 'as yet unclassified' stamp: 'RAA 11/7/2000 09:20'! - debugging: aBoolean - - Debugging _ aBoolean! ! -!PNGReadWriter class methodsFor: 'as yet unclassified' stamp: 'ar 2/11/2004 00:55'! - initialize - " - PNGReadWriter initialize - " - - BPP _ { #(1 2 4 8 16). - #(0 0 0 0 0). - #(0 0 0 24 48). - #(1 2 4 8 0). - #(0 0 0 16 32). - #(0 0 0 0 0). - #(0 0 0 32 64). - #(0 0 0 0 0) }. - - BlockHeight _ #(8 8 4 4 2 2 1). - BlockWidth _ #(8 4 4 2 2 1 1). - - StandardColors := Color indexedColors collect:[:aColor| - Color - r: (aColor red * 255) truncated / 255 - g: (aColor green * 255) truncated / 255 - b: (aColor blue * 255) truncated / 255. - ]. - - StandardSwizzleMaps := Array new: 4. - #(1 2 4) do:[:i| StandardSwizzleMaps at: i put: (self computeSwizzleMapForDepth: i)].! ! -!PNGReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 7/16/2003 17:57'! - typicalFileExtensions - "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" - ^#('png')! ! -!TIFFReadWriter methodsFor: 'private' stamp: 'jmv 12/21/2013 09:26'! - binaryStream: aPositionableStream - "Reset the given Stream, wrap it in a TIFFStream, and set it as my stream." - - | bigEndian | - super binaryStream: aPositionableStream. - bigEndian _ (aPositionableStream peek) = 16r4D. - "Assume 16r49 or 16r4D. Bad first byte caught later by TIFFStructure>>validateHeaderOf:" - stream _ TIFFStream - on: aPositionableStream - bigEndian: bigEndian.! ! -!TIFFReadWriter methodsFor: 'accessing' stamp: 'jmv 4/8/2015 15:39'! - nextImage - "Decode an image on my stream and answer the image as a Form." - ^ self reader readForm! ! -!TIFFReadWriter methodsFor: 'accessing' stamp: 'mrm 7/22/2001 18:46'! - nextPutImage: aForm - "Encode aForm into TIFF form and write on my stream." - - ^self error: 'Not Yet Implemented.'.! ! -!TIFFReadWriter methodsFor: 'accessing' stamp: 'jmv 4/8/2015 15:39'! - reader - | reader | - reader _ TIFFReader onTiffStream: stream. - ^ reader! ! -!TIFFReadWriter methodsFor: 'testing' stamp: 'mrm 7/22/2001 19:07'! - understandsImageFormat - "Test to see if the image stream format is understood by this decoder." - "Return true if this stream appears to contain a TIFF file, otherwise - return false." - - "Check for Big-endian header." - (self hasMagicNumber: - (ByteArray with: 16r4D with: 16r4D with: 16r00 with: 16r2A) ) - ifTrue: [ ^ true]. - - "Check for little-endian header." - ^ (self hasMagicNumber: - (ByteArray with: 16r49 with: 16r49 with: 16r2A with: 16r00) ).! ! -!TIFFField methodsFor: 'private' stamp: 'mrm 7/28/2001 13:47'! - isSingleValued - "Answer true iff my tag is one that should only have one value, and I only have one value. - Raise an error if I should have exactly one value but I have some other number of values." - | singleValued | - singleValued _ SingleValuedTagSymbols includes: self tagSymbol. - (singleValued and: [values size ~= 1]) - ifTrue: [self error: 'Field not single-valued that should be.']. - ^ singleValued.! ! -!TIFFField methodsFor: 'private' stamp: 'jmv 2/29/2016 11:22'! - parseFrom: aTIFFStream - "Fill in my state with the results from parsing the given TIFFStream from its current position. Leave the stream positioned after the field, which will be the beginning of the next field, if any. Answer nil if the field has an unknown tag, otherwise answer self." - - | selector | - tag _ aTIFFStream nextUnsignedInt16. - (TagSymbols includesKey: tag) - ifFalse: [aTIFFStream skip: 10. "Move past the type, count, and value/offset." - ^ nil]. - type _ aTIFFStream nextUnsignedInt16. - selector _ ValueReaderSelectors - at: type - ifAbsent: "Can't read this type, ignore the field." - [aTIFFStream skip: 8. "Move past the value/offset." - ^ nil]. - self perform: selector with: aTIFFStream. - ! ! -!TIFFField methodsFor: 'printing' stamp: 'mrm 7/31/2001 21:51'! - printOn: aStream - - super printOn: aStream. - values printOn: aStream.! ! -!TIFFField methodsFor: 'private-value reading' stamp: 'jmv 9/5/2016 16:57:57'! - read: count charsFrom: aTIFFStream - "Read count bytes from the current position of aTIFFStream and return them as an Array of Strings, using NUL as the separating character between strings. Don't worry about the ending position of aTIFFStream." - | strings oneString size | - strings _ OrderedCollection new. - oneString _ OrderedCollection new. - 1 to: count do: [ :i | - aTIFFStream peek = 0 - ifFalse: [ - oneString add: (Character numericValue: aTIFFStream nextByte) ] - ifTrue: [ "Null, so that's the end of this string. " - size _ oneString size. - strings add: ((String new: size) replaceFrom: 1 to: size with: oneString) ]]. - ^ strings asArray! ! -!TIFFField methodsFor: 'private-value reading' stamp: 'jmv 2/29/2016 11:19'! -readAsciiValuesFrom: aTIFFStream - "Read the count long and count number of characters from aTIFFStream at its current position according to my type. Store the result as one or more Strings in my array of values, using the NUL character to detect separation between strings. Leave aTIFFStream positioned eight bytes past its starting position." - - | count | - count _ aTIFFStream nextUnsignedInt32. - values _ (count <= 4) "Offset is immediate data, not pointer to data." - ifTrue: [self readImmediate: count charsFrom: aTIFFStream.] - ifFalse: [self readIndirect: count charsFrom: aTIFFStream.].! ! -!TIFFField methodsFor: 'private-value reading' stamp: 'jmv 2/29/2016 11:19'! - readByteValuesFrom: aTIFFStream - "Read the count long and count number of bytes from aTIFFStream at its current position according to my type. Store the result as my array of values. Leave aTIFFStream positioned eight bytes past its starting position." - - | count | - count _ aTIFFStream nextUnsignedInt32. - values _ Array new: count. - (count <= 4) "Offset is immediate data, not pointer to data." - ifTrue: [self readImmediate: count bytesFrom: aTIFFStream.] - ifFalse: [self readIndirect: count bytesFrom: aTIFFStream.]. -! ! -!TIFFField methodsFor: 'private-value reading' stamp: 'jmv 4/7/2015 16:32'! - readImmediate: count bytesFrom: aTIFFStream - "Put the next count bytes in aTIFFStream into my values array, starting from values at: 1. Leave aTIFFStream positioned four bytes past its starting position. Count must be <= 4." - | position | - position _ aTIFFStream position. - 1 to: count do: [ :i | values at: i put: aTIFFStream nextByte]. - aTIFFStream position: position + 4. - ! ! -!TIFFField methodsFor: 'private-value reading' stamp: 'mrm 7/27/2001 16:56'! - readImmediate: count charsFrom: aTIFFStream - "Read the next count bytes in aTIFFStream and return an Array of Strings, using NUL as the separating character between strings. Leave aTIFFStream positioned four bytes past its starting position. Count must be <= 4." - | position result | - position _ aTIFFStream position. - result _ self read: count charsFrom: aTIFFStream. - aTIFFStream position: position + 4. - ^ result.! ! -!TIFFField methodsFor: 'private-value reading' stamp: 'jmv 2/29/2016 11:19'! - readImmediate: count longsFrom: aTIFFStream - "Put the next count 32-bit longs in aTIFFStream into my values array, starting from values at: 1. Leave aTIFFStream positioned four bytes past its starting position. Count must be <= 1." - | position | - position _ aTIFFStream position. - 1 to: count do: [:i | values at: i put: aTIFFStream nextUnsignedInt32]. - aTIFFStream position: position + 4. - ! ! -!TIFFField methodsFor: 'private-value reading' stamp: 'jmv 2/29/2016 11:21'! - readImmediate: count shortsFrom: aTIFFStream - "Put the next count 16-bit shorts in aTIFFStream into my values array, starting from values at: 1. Leave aTIFFStream positioned four bytes past its starting position. Count must be <= 2." - | position | - position _ aTIFFStream position. - 1 to: count do: [:i | values at: i put: aTIFFStream nextUnsignedInt16]. - aTIFFStream position: position + 4. - ! ! -!TIFFField methodsFor: 'private-value reading' stamp: 'jmv 2/29/2016 11:19'! - readIndirect: count bytesFrom: aTIFFStream - "Read a long offset from aTIFFStream, then read count bytes from that offset in aTIFFStream into my values array, starting from values at: 1. Leave aTIFFStream positioned four bytes past its starting position." - | offset position | - offset _ aTIFFStream nextUnsignedInt32. - position _ aTIFFStream position. - aTIFFStream position: offset. - 1 to: count do: [:i | values at: i put: aTIFFStream nextByte]. - aTIFFStream position: position.! ! -!TIFFField methodsFor: 'private-value reading' stamp: 'jmv 2/29/2016 11:19'! - readIndirect: count charsFrom: aTIFFStream - "Read a long offset from aTIFFStream, then read count bytes from that offset in aTIFFStream and return them as an Array of Strings, using NUL as the separating character between strings. Leave aTIFFStream positioned four bytes past its starting position." - | offset position result | - offset _ aTIFFStream nextUnsignedInt32. - position _ aTIFFStream position. - aTIFFStream position: offset. - result _ self read: count charsFrom: aTIFFStream. - aTIFFStream position: position. - ^ result.! ! -!TIFFField methodsFor: 'private-value reading' stamp: 'jmv 2/29/2016 11:20'! - readIndirect: count longsFrom: aTIFFStream - "Read a 32-bit offset from aTIFFStream, then read count 32-bit longs from that offset in aTIFFStream into my values array, starting from values at: 1. Leave aTIFFStream positioned four bytes past its starting position." - | offset position | - offset _ aTIFFStream nextUnsignedInt32. - position _ aTIFFStream position. - aTIFFStream position: offset. - 1 to: count do: [:i | values at: i put: aTIFFStream nextUnsignedInt32]. - aTIFFStream position: position.! ! -!TIFFField methodsFor: 'private-value reading' stamp: 'jmv 2/29/2016 11:20'! - readIndirect: count rationalsFrom: aTIFFStream - "Read a 32-bit offset from aTIFFStream, then read count 32-bit longs from that offset in aTIFFStream into my values array, starting from values at: 1. Leave aTIFFStream positioned four bytes past its starting position." - | offset position | - offset _ aTIFFStream nextUnsignedInt32. - position _ aTIFFStream position. - aTIFFStream position: offset. - 1 to: count do: [:i | values at: i put: (aTIFFStream nextUnsignedInt32 / aTIFFStream nextUnsignedInt32)]. - aTIFFStream position: position.! ! -!TIFFField methodsFor: 'private-value reading' stamp: 'jmv 2/29/2016 11:21'! - readIndirect: count shortsFrom: aTIFFStream - "Read a long offset from aTIFFStream, then read count 16-bit shorts from that offset in aTIFFStream into my values array, starting from values at: 1. Leave aTIFFStream positioned four bytes past its starting position." - | offset position | - offset _ aTIFFStream nextUnsignedInt32. - position _ aTIFFStream position. - aTIFFStream position: offset. - 1 to: count do: [:i | values at: i put: aTIFFStream nextUnsignedInt16]. - aTIFFStream position: position.! ! -!TIFFField methodsFor: 'private-value reading' stamp: 'jmv 2/29/2016 11:20'! - readLongValuesFrom: aTIFFStream - "Read the 32-bit count and count number of 32-bit values from aTIFFStream at its current position according to my type. Store the result as my array of values. Leave aTIFFStream positioned eight bytes past its starting position." - - | count | - count _ aTIFFStream nextUnsignedInt32. - values _ Array new: count. - (count <= 1) "Offset is immediate data, not pointer to data." - ifTrue: [self readImmediate: count longsFrom: aTIFFStream.] - ifFalse: [self readIndirect: count longsFrom: aTIFFStream.]. -! ! -!TIFFField methodsFor: 'private-value reading' stamp: 'jmv 2/29/2016 11:20'! - readRationalValuesFrom: aTIFFStream - "Read the 32-bit count and count number of 64-bit rational values from aTIFFStream at its current position according to my type. Store the result as my array of values. Leave aTIFFStream positioned eight bytes past its starting position." - - | count | - count _ aTIFFStream nextUnsignedInt32. - values _ Array new: count. - "Can't fit even one rational into 32 bits, so always indirect, never immediate." - self readIndirect: count rationalsFrom: aTIFFStream. -! ! -!TIFFField methodsFor: 'private-value reading' stamp: 'jmv 2/29/2016 11:20'! - readShortValuesFrom: aTIFFStream - "Read the 32-bit count and count number of 16-bit shorts from aTIFFStream at its current position according to my type. Store the result as my array of values. Leave aTIFFStream positioned eight bytes past its starting position." - - | count | - count _ aTIFFStream nextUnsignedInt32. - values _ Array new: count. - (count <= 2) "Offset is immediate data, not pointer to data." - ifTrue: [self readImmediate: count shortsFrom: aTIFFStream.] - ifFalse: [self readIndirect: count shortsFrom: aTIFFStream.]. -! ! -!TIFFField methodsFor: 'accessing' stamp: 'mrm 7/27/2001 17:50'! - tag - "Return the tag integer that indicates what kind of TIFF field this is." - ^ tag. -! ! -!TIFFField methodsFor: 'private' stamp: 'mrm 7/28/2001 16:27'! - tag: tagInteger type: typeInteger values: valueArray - "Set my state to the given values." - tag _ tagInteger. - type _ typeInteger. - values _ valueArray.! ! -!TIFFField methodsFor: 'accessing' stamp: 'mrm 7/31/2001 20:12'! - tagSymbol - "Answer the Symbol that indicates what kind of TIFF field this is. - If it's an unknown tag, answer nil." - ^ TagSymbols at: tag ifAbsent: [nil]. -! ! -!TIFFField methodsFor: 'accessing' stamp: 'mrm 7/28/2001 13:38'! -value - "Answer my value. All TIFF fields are structured with array values, but many tags never have an array with more than one value. Thus, I answer the sole value for such tags, and answer an array for tags that can have more than one value. - I report an error if I have more than one value for a tag that should only have one value." - - ^ (self isSingleValued) - ifTrue: [values at: 1] - ifFalse: [values].! ! -!TIFFField class methodsFor: 'defaults' stamp: 'mrm 7/28/2001 15:53'! - defaultFor: tagSymbol - "Answer the default field for the given tag Symbol. Raise an error if there is no default field for the given tag Symbol." - ^ DefaultFields - at: tagSymbol - ifAbsent: [self error: 'No default value for this tag.']. ! ! -!TIFFField class methodsFor: 'initializing' stamp: 'mrm 7/28/2001 15:56'! - initialize - "TIFFField initialize." - - self initializeValueReaderSelectors. - self initializeTagSymbols. - self initializeSingleValuedTagSymbols. - self initializeDefaultFields.! ! -!TIFFField class methodsFor: 'initializing' stamp: 'jmv 1/12/2011 15:58'! - initializeDefaultFields - "DefaultFields Dictionary -- maps tag symbols to the default field with that tag. Only maps tag symbols for which the TIFF spec defines a default." - - DefaultFields _ Dictionary new. - DefaultFields - at: #BitsPerSample "1-bit bi-level image." - put: (TIFFField tag: 258 type: 3 values: (Array with: 1)); - - at: #Compression "No compression" - put: (TIFFField tag: 259 type: 3 values: (Array with: 1)); - - at: #Predictor "No predictor" - put: (TIFFField tag: 317 type: 3 values: (Array with: 1)); - - at: #FillOrder "Lower column values in higher-order bits" - put: (TIFFField tag: 266 type: 3 values: (Array with: 1)); - - at: #GrayResponseUnit "hundredths" - put: (TIFFField tag: 290 type: 3 values: (Array with: 2)); - - "The defaults for MaxSampleValue and MinSampleValue are a function of BitsPerSample and SmaplesPerPixel, and I don't anticipate needing these fields for Squeak purposes, so defaults for them are not handled according to the spec." - - at: #NewSubfileType "Primary Image" - put: (TIFFField tag: 254 type: 4 values: (Array with: 0)); - - at: #Orientation "0, 0 is top left of image" - put: (TIFFField tag: 274 type: 3 values: (Array with: 1)); - - at: #PlanarConfiguration "Chunky" - put: (TIFFField tag: 284 type: 3 values: (Array with: 1)); - - at: #ResolutionUnit "Inch" - put: (TIFFField tag: 296 type: 3 values: (Array with: 2)); - - at: #RowsPerStrip "Effectively infinite" - put: (TIFFField tag: 278 type: 4 values: (Array with: 16rFFFFFFFF)); - - at: #SamplesPerPixel "One" - put: (TIFFField tag: 277 type: 3 values: (Array with: 1)); - - at: #Threshholding "No dithering or halftoning applied" - put: (TIFFField tag: 263 type: 3 values: (Array with: 1)). - -! ! -!TIFFField class methodsFor: 'initializing' stamp: 'jmv 1/12/2011 15:59'! - initializeSingleValuedTagSymbols - "SingleValuedTagSymbols Set -- contains the tag symbols of the fields types that should have a value that consists of an array of length one." - SingleValuedTagSymbols _ Set new. - SingleValuedTagSymbols - add: #CellLength ; - add: #CellWidth ; - add: #Compression ; - add: #Predictor ; - add: #DateTime ; "Should be a single String." - add: #FillOrder ; - add: #GrayResponseUnit ; - add: #ImageLength ; - add: #ImageWidth ; - add: #NewSubfileType ; - add: #Orientation ; - add: #PhotometricInterpretation ; - add: #PlanarConfiguration ; - add: #ResolutionUnit ; - add: #RowsPerStrip ; - add: #SamplesPerPixel ; - add: #SubfileType ; - add: #Threshholding ; - add: #XResolution ; - add: #YResolution . -! ! -!TIFFField class methodsFor: 'initializing' stamp: 'jmv 1/12/2011 15:58'! - initializeTagSymbols - "TagSymbols Dictionary -- maps TIFF tag integers to tag symbols." - TagSymbols _ Dictionary new. - TagSymbols - at: 315 put: #Artist ; - at: 258 put: #BitsPerSample ; - at: 265 put: #CellLength ; - at: 264 put: #CellWidth ; - at: 320 put: #ColorMap ; - at: 259 put: #Compression ; - at: 317 put: #Predictor ; - at: 33432 put: #Copyright ; - at: 306 put: #DateTime ; - at: 338 put: #ExtraSamples ; - at: 266 put: #FillOrder ; - at: 289 put: #FreeByteCounts ; - at: 288 put: #FreeOffsets ; - at: 291 put: #GrayResponseCurve ; - at: 290 put: #GrayResponseUnit ; - at: 316 put: #HostComputer ; - at: 270 put: #ImageDescription ; - at: 257 put: #ImageLength ; - at: 256 put: #ImageWidth ; - at: 271 put: #Make ; - at: 281 put: #MaxSampleValue ; - at: 280 put: #MinSampleValue ; - at: 272 put: #Model ; - at: 254 put: #NewSubfileType ; - at: 274 put: #Orientation ; - at: 262 put: #PhotometricInterpretation ; - at: 284 put: #PlanarConfiguration ; - at: 296 put: #ResolutionUnit ; - at: 278 put: #RowsPerStrip ; - at: 277 put: #SamplesPerPixel ; - at: 305 put: #Software ; - at: 279 put: #StripByteCounts ; - at: 273 put: #StripOffsets ; - at: 255 put: #SubfileType ; - at: 263 put: #Threshholding ; - at: 282 put: #XResolution ; - at: 283 put: #YResolution . -! ! -!TIFFField class methodsFor: 'initializing' stamp: 'mrm 7/27/2001 17:47'! - initializeValueReaderSelectors - "ValueReaderSelectors Dictionary -- maps TIFF type integers to the selectors of the methods used to read field values of that type." - - ValueReaderSelectors _ Dictionary new. - ValueReaderSelectors - at: 1 put: #readByteValuesFrom: ; - at: 2 put: #readAsciiValuesFrom: ; - at: 3 put: #readShortValuesFrom: ; - at: 4 put: #readLongValuesFrom: ; - at: 5 put: #readRationalValuesFrom: . -! ! -!TIFFField class methodsFor: 'instance creation' stamp: 'mrm 7/25/2001 22:22'! - parseFrom: aTIFFStream - "Answer a new instance of the receiver resulting from parsing the given TIFFStream from its current position. Leave the stream positioned after the field, which will be the beginning of the next field, if any." - - ^ self new parseFrom: aTIFFStream.! ! -!TIFFField class methodsFor: 'private' stamp: 'mrm 7/28/2001 16:25'! - tag: tagInteger type: typeInteger values: valueArray - "Answer a new instance with the given state." - ^ self new - tag: tagInteger - type: typeInteger - values: valueArray.! ! -!TIFFImageFileDirectory methodsFor: 'accessing' stamp: 'mrm 7/28/2001 15:52'! - at: tagSymbol - "Answer the value I have for the given tag Symbol. If I have no value for that tag, return the default value for that tag. - All TIFF tags are structured with array values, but many tags never have an array with more than one value. Thus, I answer the sole value for such tags, and answer an array for tags that can have more than one value. - I report an error if I have no value for a tag that has no default or if I have more than one value for a tag that should only have one value." - - | field | - field _ fields - at: tagSymbol - ifAbsent: - [TIFFField defaultFor: tagSymbol]. "Raises error if no default." - ^ field value.! ! -!TIFFImageFileDirectory methodsFor: 'private' stamp: 'jmv 2/29/2016 11:22'! - parseFrom: aTIFFStream - "Blow away any former state I had and parse a new collection of fields from the given stream. - Leave the stream positioned at the end of the IFD, just before the pointer to the next IFD." - | fieldCount field | - fieldCount _ aTIFFStream nextUnsignedInt16. - fields _ (Dictionary new: fieldCount). - fieldCount timesRepeat: - [field _ TIFFField parseFrom: aTIFFStream. - field isNil ifFalse: [fields at: field tagSymbol put: field] ]. -! ! -!TIFFImageFileDirectory class methodsFor: 'instance creation' stamp: 'mrm 7/25/2001 22:22'! - parseFrom: aTIFFStream - "Answer a new instance of the receiver resulting from parsing the given TIFFStream from its current position. Leave the stream positioned at the start of the next IFD, or at 0 if no more." - ^ self new parseFrom: aTIFFStream.! ! -!TIFFReader methodsFor: 'accessing' stamp: 'mrm 7/28/2001 17:03'! - extent - "Answer a Point that defines my image's size in pixels." - ^ (structure at: #ImageWidth) @ (structure at: #ImageLength). -! ! -!TIFFReader methodsFor: 'private' stamp: 'jmv 1/12/2011 16:52'! - positionStreamToStripNum: anInteger - "Position my TIFFStream at the start of the given strip, where 1 is the first strip." - stream position: ((structure at: #StripOffsets) at: anInteger). - stream newStrip! ! -!TIFFReader methodsFor: 'reading' stamp: 'jmv 8/1/2016 10:37:24'! - readForm - "Answer a Form created from the data in my stream and structure." - | result bps | - self validateTIFFType. "Make sure it's a type we can handle." - - (structure at: #SamplesPerPixel) >= 3 ifTrue: [ - result _ Form - extent: self extent - depth: 32. "32 bits form with RGB or RGBA" - - ((structure at: #PlanarConfiguration) = 1) - ifTrue: [ "chunky" - self - readRGB8PixelsInto: result - readAlpha: (structure at: #SamplesPerPixel) = 4 - horizontalPredictor: ((structure at: #Predictor) = 2) ] - ifFalse: [ "planar" - self - readPlanarRGB8PixelsInto: result - readAlpha: (structure at: #SamplesPerPixel) = 4 - horizontalPredictor: (structure at: #Predictor) = 2 ]]. - - (structure at: #SamplesPerPixel) = 1 ifTrue: [ - bps _ (structure at: #BitsPerSample) at: 1. - bps caseOf: { - [ 8 ] -> [ - "ColorForm set for 8bpp gray scale images" - result _ GrayForm extent: self extent. - self - readGray8PixelsInto: result - horizontalPredictor: ((structure at: #Predictor) = 2) ]. - - [ 16 ] -> [ - "float image" - result _ (Smalltalk at: #ShortWordMatrix ifAbsent: [ - self error: '16bpp TIFF requires ShortWordMatrix (LinearAlgebra package)' ]) - extent: self extent. - self readGray16PixelsInto: result ] }]. - - ^ result! ! -!TIFFReader methodsFor: 'private' stamp: 'jmv 7/26/2016 15:55:59'! - readGray16PixelsInto: aShortWordMatrix - "Replace the given Form's pixel values with pixel values from my TIFFStream. aForm must have the correct extent. - Handles 16 bit pixels on source, float as destination." - - | elements totalPixels pixelsPerStrip currentStripNum pixel | - elements _ aShortWordMatrix elements. - totalPixels _ elements size. - pixelsPerStrip _ aShortWordMatrix extent x * (structure at: #RowsPerStrip). - currentStripNum _ 0. - - 1 to: totalPixels do: [ :pixNum | - (pixNum-1 \\ aShortWordMatrix width = 0) ifTrue: [ - (pixNum - 1 \\ pixelsPerStrip = 0) ifTrue: [ - "Time to go to next strip" - currentStripNum _ currentStripNum + 1. - self positionStreamToStripNum: currentStripNum ]]. - - pixel _ stream nextUnsignedInt16. - elements at: pixNum put: pixel ]! ! -!TIFFReader methodsFor: 'private' stamp: 'jmv 5/12/2016 18:27'! - readGray8PixelsInto: aGrayForm horizontalPredictor: useHorizontalPredictor - "Replace the given Form's pixel values with pixel values from my TIFFStream. aForm must have the correct extent. - Only handles 8-bit gray pixels on both source and destination." - - | bits totalPixels pixelsPerStrip currentStripNum g gg pixel bytesPerRow row column | - bits _ aGrayForm bits. - totalPixels _ aGrayForm width * aGrayForm height. - pixelsPerStrip _ aGrayForm width * (structure at: #RowsPerStrip). - currentStripNum _ 0. - row _ -1. - column _ 0. - bytesPerRow _ aGrayForm width + 3 // 4 * 4. - 1 to: totalPixels do: [ :pixNum | - (pixNum-1 \\ aGrayForm width = 0) ifTrue: [ - row _ row + 1. - column _ 0. - (pixNum - 1 \\ pixelsPerStrip = 0) ifTrue: [ - "Time to go to next strip" - currentStripNum _ currentStripNum + 1. - self positionStreamToStripNum: currentStripNum ]. - useHorizontalPredictor ifTrue: [ - g _ 0 ]]. - column _ column + 1. - - gg _ stream nextByteInBody. - - useHorizontalPredictor - ifTrue: [ - g _ (g + gg) bitAnd: 255 ] - ifFalse: [ - g _ gg ]. - pixel _ g. - bits byteAt: (row * bytesPerRow) + column put: pixel bigEndian: aGrayForm isBigEndian ]! ! -!TIFFReader methodsFor: 'private' stamp: 'jmv 4/8/2015 11:54'! - readPlanarRGB8PixelsInto: a32BitForm readAlpha: doReadAlpha horizontalPredictor: useHorizontalPredictor - "Replace the given Form's pixel values with pixel values from my TIFFStream. aForm must have the correct extent. - Handles 24 or 32-bit pixels on source, and destination of 32 bits per pixel." - - | bits totalPixels pixelsPerStrip currentStripNum pixel component componentByte shifts | - bits _ a32BitForm bits. - totalPixels _ bits size. - pixelsPerStrip _ a32BitForm extent x * (structure at: #RowsPerStrip). - currentStripNum _ 0. - - shifts _ doReadAlpha - ifTrue: [ #( 24 16 8 0 ) ] - ifFalse: [ #( 16 8 0 ) ]. - - shifts do: [ :shift | - 1 to: totalPixels do: [ :pixNum | - (pixNum-1 \\ a32BitForm width = 0) ifTrue: [ - (pixNum - 1 \\ pixelsPerStrip = 0) ifTrue: [ - "Time to go to next strip" - currentStripNum _ currentStripNum + 1. - self positionStreamToStripNum: currentStripNum ]. - useHorizontalPredictor ifTrue: [ - component _ 0 ]]. - - componentByte _ stream nextByteInBody. - component _ useHorizontalPredictor - ifTrue: [ (component + componentByte) bitAnd: 255 ] - ifFalse: [ componentByte ]. - - pixel _ component << shift + (bits at: pixNum). - bits at: pixNum put: pixel ]]. - - "Alpha set at the end, to avoid LargIntegers in the code above - (a32BitForm came with all zeros, see senders)" - doReadAlpha ifFalse: [ - a32BitForm makeAllPixelsOpaque ]! ! -!TIFFReader methodsFor: 'private' stamp: 'jmv 4/7/2015 16:34'! - readRGB8PixelsInto: a32BitForm readAlpha: doReadAlpha horizontalPredictor: useHorizontalPredictor - "Replace the given Form's pixel values with pixel values from my TIFFStream. aForm must have the correct extent. - Handles 24 or 32-bit pixels on source, and destination of 32 bits per pixel." - - | bits totalPixels pixelsPerStrip currentStripNum pixel a b g r aa bb rr gg | - bits _ a32BitForm bits. - totalPixels _ bits size. - pixelsPerStrip _ a32BitForm extent x * (structure at: #RowsPerStrip). - currentStripNum _ 0. - a _ 255. - - 1 to: totalPixels do: [ :pixNum | - (pixNum-1 \\ a32BitForm width = 0) ifTrue: [ - (pixNum - 1 \\ pixelsPerStrip = 0) ifTrue: [ - "Time to go to next strip" - currentStripNum _ currentStripNum + 1. - self positionStreamToStripNum: currentStripNum ]. - useHorizontalPredictor ifTrue: [ - r _ g _ b _ 0. - a _ doReadAlpha ifTrue: [ 0 ] ifFalse: [ 255 ] ]]. - - rr _ stream nextByteInBody. - gg _ stream nextByteInBody. - bb _ stream nextByteInBody. - doReadAlpha - ifTrue: [ aa _ stream nextByteInBody ]. - - useHorizontalPredictor - ifTrue: [ - r _ (r + rr) bitAnd: 255. - g _ (g + gg) bitAnd: 255. - b _ (b + bb) bitAnd: 255. - doReadAlpha - ifTrue: [ a _ (a + aa) bitAnd: 255 ] ] - ifFalse: [ - r _ rr. - g _ gg. - b _ bb. - doReadAlpha - ifTrue: [ a _ aa ] ]. - pixel _ (r << 16) + (g << 8) + b + (a << 24). - bits at: pixNum put: pixel.].! ! -!TIFFReader methodsFor: 'private' stamp: 'jmv 12/21/2013 09:28'! - tiffStream: aTIFFStream - "Set the given stream as my stream, and read the TIFF's structure from that stream." - stream _ aTIFFStream. - structure _ TIFFStructure parseFrom: stream. -! ! -!TIFFReader methodsFor: 'private' stamp: 'jmv 4/8/2015 11:13'! - validateTIFFType - "Examine my structure to see if it represents a TIFF that I know how to read. - At the moment, I can read only - Gray 8-bit - Gray 16-bit - RGB 24-bit - RGB 32-bit with an alpha channel, - uncompressed, chunky TIFFs ." - - | bpsArray compression predictor | - ((structure at: #PhotometricInterpretation) between: 1 and: 2) "Black is zero: 1, RGB: 2" - ifFalse: [self error: 'Cannot read, this is not an Gray or RGB TIFF.']. - (#(1 3 4) includes: (structure at: #SamplesPerPixel)) "gray/bilevel: 1, RGB: 3, RGBA: 4" - ifFalse: [self error: 'Cannot read, this TIFF is not a Gray, Bilevel, RGB, or RGBA TIFF.']. - compression _ structure at: #Compression. - (compression = 1 or: [ compression = 5 ]) "Uncompressed (1) or LZW (5)" - ifFalse: [self error: 'Cannot read, this TIFF is compressed with an unsupported algorithm.']. - predictor _ structure at: #Predictor. - (predictor = 1 or: [ predictor = 2 and: [ compression = 5]]) - ifFalse: [self error: 'Cannot read, this TIFF uses an unsupported predictor.']. - ((structure at: #FillOrder) = 1) - ifFalse: [self error: 'Cannot read, this TIFF has a FillOrder other than 1.']. - ((structure at: #Orientation) = 1) - ifFalse: [self error: 'Cannot read, this TIFF has an Orientation other than 1.']. - bpsArray _ structure at: #BitsPerSample. - ((#(1 3 4) includes: bpsArray size) and: [ (bpsArray allSatisfy: [ :d | d = 8 ]) or: [bpsArray = #(16)]]) - ifFalse: [self error: 'Cannot read, this TIFF is not a Gray, RGB or RGBA TIFF with 8bpp or Gray 16bpp.']! ! -!TIFFReader class methodsFor: 'instance creation' stamp: 'jmv 12/21/2013 09:28'! - onTiffStream: aTIFFStream - "Create and answer an instance of the receiver based on the given TIFFStream. Parse the structure at this time as well." - ^ self new tiffStream: aTIFFStream. -! ! -!TIFFStream methodsFor: 'LZW uncompressions' stamp: 'jmv 1/12/2011 16:52'! - checkLZWCodeSize - - (freeCode+1 > maxCode and: [ codeSize < 12 ]) ifTrue: [ - codeSize := codeSize + 1. - maxCode := (1 bitShift: codeSize) - 1 ]! ! -!TIFFStream methodsFor: 'accessing' stamp: 'jmv 1/12/2011 16:05'! - compressionType: aNumber - compressionType _ aNumber. - aNumber = 5 ifTrue: [ - self initializeLZWDecompression ]! ! -!TIFFStream methodsFor: 'LZW uncompressions' stamp: 'jmv 1/12/2011 16:57'! - initializeLZWDecompression - - maxOutCodes := 4096. - remainBitCount := 0. - outCodes := ByteArray new: maxOutCodes + 1. - outCount := 0. - prefixTable := Array new: 4096. - suffixTable := Array new: 4096. - bitMask := (1 bitShift: 8) - 1! ! -!TIFFStream methodsFor: 'accessing' stamp: 'mrm 7/22/2001 21:59'! - isBigEndian - "Return true if I am a big-endian TIFF, false if I am little-endian." - ^ bigEndian. -! ! -!TIFFStream methodsFor: 'TIFF type access' stamp: 'jmv 1/12/2011 17:02'! - newStrip - remainBitCount _ 0. - self reInitializeLZWDecompression! ! -!TIFFStream methodsFor: 'stream access' stamp: 'mrm 7/22/2001 20:23'! - next: anInteger - - "Answer the next anInteger elements of my stream's collection." - ^ stream next: anInteger.! ! -!TIFFStream methodsFor: 'TIFF type access' stamp: 'mrm 7/27/2001 17:49'! - nextByte - "Answer the next 8-bit unsigned quantity from the stream." - - ^ stream next.! ! -!TIFFStream methodsFor: 'TIFF type access' stamp: 'jmv 1/13/2011 10:13'! - nextByteInBody - "Answer the next 8-bit unsigned quantity from the stream. - Uncompress data if appropriate" - compressionType = 5 ifTrue: [ - ^self nextLZWUncompressedByte ]. - ^ stream next! ! -!TIFFStream methodsFor: 'LZW uncompressions' stamp: 'jmv 1/12/2011 17:02'! - nextLZWCode - | integer readBitCount shiftCount byte | - integer := 0. - remainBitCount = 0 - ifTrue: [ - readBitCount := 8. - shiftCount := 0 ] - ifFalse: [ - readBitCount := remainBitCount. - shiftCount := remainBitCount - 8 ]. - [ readBitCount < codeSize ] whileTrue: [ - byte := self nextByte. - byte == nil ifTrue: [ ^ eoiCode ]. - remainBitCount = 0 ifFalse: [ - byte _ byte bitAnd: (1 bitShift: remainBitCount)-1. - remainBitCount _ 0 ]. - integer := (integer bitShift: 8) + byte. - shiftCount := shiftCount + 8. - readBitCount := readBitCount + 8 ]. - (remainBitCount := readBitCount - codeSize) = 0 - ifTrue: [ byte := self nextByte ] - ifFalse: [ byte := self peek ]. - byte == nil ifTrue: [ ^ eoiCode ]. - integer := (integer bitShift: 8) + byte. - integer _ integer bitShift: remainBitCount negated. - ^integer! ! -!TIFFStream methodsFor: 'LZW uncompressions' stamp: 'jmv 1/12/2011 17:04'! - nextLZWUncompressedByte - "Answer the next 8-bit unsigned quantity from the stream." - | answer | - outCount = 0 ifTrue: [ - self readAdditionalLZWStuff ]. - - answer _ outCodes at: outCount. - outCount _ outCount - 1. - ^answer! ! -!TIFFStream methodsFor: 'TIFF type access' stamp: 'jmv 2/29/2016 11:21'! - nextUnsignedInt16 - "Read a 16-bit unsigned quantity from the stream." - - ^ stream nextUnsignedInt16BigEndian: bigEndian! ! -!TIFFStream methodsFor: 'TIFF type access' stamp: 'jmv 2/29/2016 11:18'! - nextUnsignedInt32 - "Read a 32-bit unsigned quantity from the stream." - - ^ stream nextUnsignedInt32BigEndian: bigEndian! ! -!TIFFStream methodsFor: 'private' stamp: 'mrm 7/22/2001 20:34'! - on: aPositionableStream bigEndian: aBoolean - - "Make aPositionableStream be the stream I'm wrapping. Interpret it as big or little-endian according to aBoolean." - stream _ aPositionableStream. - bigEndian _ aBoolean. -! ! -!TIFFStream methodsFor: 'stream access' stamp: 'mrm 7/27/2001 17:35'! - peek - - "Answer the next byte of my underlying stream." - ^ stream peek. - -! ! -!TIFFStream methodsFor: 'stream access' stamp: 'mrm 7/22/2001 20:11'! - position - - "Answer the current position of accessing the sequence of objects." - ^ stream position.! ! -!TIFFStream methodsFor: 'stream access' stamp: 'mrm 7/22/2001 20:18'! - 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." - stream position: anInteger.! ! -!TIFFStream methodsFor: 'LZW uncompressions' stamp: 'jmv 1/12/2011 15:18'! - reInitializeLZWDecompression - clearCode := 1 bitShift: 8. - eoiCode := clearCode + 1. - freeCode := clearCode + 2. - codeSize := 9. - maxCode := (1 bitShift: codeSize) - 1! ! -!TIFFStream methodsFor: 'LZW uncompressions' stamp: 'jmv 1/12/2011 17:13'! - readAdditionalLZWStuff - "Answer the next 8-bit unsigned quantity from the stream." - | code curCode inCode | - code := self nextLZWCode. - code = eoiCode ifTrue: [ - ^nil ]. - - code = clearCode - ifTrue: [ - self reInitializeLZWDecompression. - curCode := oldCode := code := self nextLZWCode. - finChar := curCode] - ifFalse: [ - curCode := inCode := code. - curCode >= freeCode ifTrue: [ - curCode := oldCode. - outCodes - at: (outCount := outCount + 1) - put: finChar ]. - [ curCode > bitMask ] whileTrue: [ - outCount > maxOutCodes ifTrue: [ ^ self error: 'corrupt LZW TIFF file (OutCount)' ]. - outCodes - at: (outCount := outCount + 1) - put: (suffixTable at: curCode + 1). - curCode := prefixTable at: curCode + 1 ]. - finChar := curCode. - prefixTable - at: freeCode + 1 - put: oldCode. - suffixTable - at: freeCode + 1 - put: finChar. - oldCode := inCode. - freeCode := freeCode + 1. - self checkLZWCodeSize ]. - outCodes - at: (outCount := outCount + 1) - put: finChar! ! -!TIFFStream methodsFor: 'stream access' stamp: 'jmv 1/12/2011 10:01'! - reset - "Goto start." - stream reset! ! -!TIFFStream methodsFor: 'stream access' stamp: 'mrm 7/22/2001 20:13'! - size - - "Answer the size of my underlying stream." - ^ stream size. - -! ! -!TIFFStream methodsFor: 'stream access' stamp: 'mrm 7/31/2001 21:44'! - skip: anInteger - "Set the receiver's position to be the current position+anInteger." - - stream skip: anInteger.! ! -!TIFFStream class methodsFor: 'instance creation' stamp: 'mrm 7/22/2001 20:42'! - on: aPositionableStream bigEndian: aBoolean - - "Answer an instance of the receiver for encoding and/or decoding TIFFs on the given." - - ^ self new - on: aPositionableStream - bigEndian: aBoolean. -! ! -!TIFFStructure methodsFor: 'accessing' stamp: 'mrm 7/28/2001 09:33'! - at: tagSymbol - "Answer the value I have for the given tag Symbol. If I have no value for that tag, return the default value for that tag. - All TIFF tags are structured with array values, but many tags never have an array with more than one value. Thus, I answer the sole value for such tags, and answer an array for tags that can have more than one value. - I report an error if I have no value for a tag that has no default or if I have more than one value for a tag that should only have one value. - I only look in my first image file directory for values." - - | ifd | - ifd _ imageFileDirectories first. "Reports an error if no IFDs." - ^ ifd at: tagSymbol.! ! -!TIFFStructure methodsFor: 'parsing' stamp: 'jmv 1/12/2011 16:06'! - parseFrom: aTIFFStream - "Parse the given TIFFStream and set my internal state to match. Error if the TIFFStream does not contain a valid TIFF." - - "Wipe out any former contents." - imageFileDirectories _ OrderedCollection new. - - self validateHeaderOf: aTIFFStream. - self parseIFDsFrom: aTIFFStream. - aTIFFStream compressionType: (self at: #Compression)! ! -!TIFFStructure methodsFor: 'parsing' stamp: 'jmv 2/29/2016 11:20'! - parseIFDsFrom: aTIFFStream - "Read as many image file directories as aTIFFStream contains, and put them into my state. Per the TIFF spec, there must be at least one IFD." - - | ifd ifdPosition | - aTIFFStream position: 4. "Offset in header of pointer to first IFD." - ifdPosition _ aTIFFStream nextUnsignedInt32. - [ifdPosition = 0] - whileFalse: [ - aTIFFStream position: ifdPosition. - ifd _ TIFFImageFileDirectory parseFrom: aTIFFStream. - imageFileDirectories add: ifd. - ifdPosition _ aTIFFStream nextUnsignedInt32]. -! ! -!TIFFStructure methodsFor: 'parsing' stamp: 'jmv 5/9/2016 17:00'! - validateHeaderOf: aTIFFStream - "Report an error if the header of the given stream is not valid, - or does not match the endian-ness of the TIFFStream." - - | expectedWord douglasAdams | - expectedWord _ aTIFFStream isBigEndian - ifTrue: [16r4D4D] - ifFalse: [16r4949]. - douglasAdams _ 42. - aTIFFStream reset. - (aTIFFStream nextUnsignedInt16 = expectedWord) - ifFalse: [self error: 'TIFF Header not valid. First word not correct for expected endian-ness']. - (aTIFFStream nextUnsignedInt16 = douglasAdams) - ifFalse: [self error: 'TIFF Header not valid. Answer not 42.']! ! -!TIFFStructure class methodsFor: 'instance creation' stamp: 'mrm 7/25/2001 21:52'! - parseFrom: aTIFFStream - "Answer a new instance of the receiver resulting from parsing the given TIFFStream from a position of 0. Error if the TIFFStream does not contain a valid TIFF." - - ^ self new parseFrom: aTIFFStream.! ! - -PNGReadWriter initialize! - -TIFFField initialize! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/Packages/Graphics-Files-Additional.pck.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3081] on 14 May 2017 at 7:08:16 pm'! - -'Description Please enter a description for this package.'! - -SharedPool subclass: #FFIConstants - instanceVariableNames: '' - classVariableNames: 'FFIAtomicTypeMask FFIAtomicTypeShift FFICallFlagThreaded FFICallTypeApi FFICallTypeCDecl FFICallTypesMask FFIErrorAddressNotFound FFIErrorAttemptToPassVoid FFIErrorBadAddress FFIErrorBadArg FFIErrorBadArgs FFIErrorBadAtomicType FFIErrorBadExternalFunction FFIErrorBadExternalLibrary FFIErrorBadReturn FFIErrorCallFrameTooBig FFIErrorCallType FFIErrorCoercionFailed FFIErrorGenericError FFIErrorIntAsPointer FFIErrorInvalidPointer FFIErrorModuleNotFound FFIErrorNoModule FFIErrorNotFunction FFIErrorStructSize FFIErrorWrongType FFIFlagAtomic FFIFlagPointer FFIFlagStructure FFINoCalloutAvailable FFIStructSizeMask FFITypeBool FFITypeDoubleFloat FFITypeSignedByte FFITypeSignedChar FFITypeSignedInt FFITypeSignedLongLong FFITypeSignedShort FFITypeSingleFloat FFITypeUnsignedByte FFITypeUnsignedChar FFITypeUnsignedInt FFITypeUnsignedLongLong FFITypeUnsignedShort FFITypeVoid' - poolDictionaries: '' - category: 'FFI-Pools'! - -!classDefinition: #FFIConstants category: #'FFI-Pools'! -SharedPool subclass: #FFIConstants - instanceVariableNames: '' - classVariableNames: 'FFIAtomicTypeMask FFIAtomicTypeShift FFICallFlagThreaded FFICallTypeApi FFICallTypeCDecl FFICallTypesMask FFIErrorAddressNotFound FFIErrorAttemptToPassVoid FFIErrorBadAddress FFIErrorBadArg FFIErrorBadArgs FFIErrorBadAtomicType FFIErrorBadExternalFunction FFIErrorBadExternalLibrary FFIErrorBadReturn FFIErrorCallFrameTooBig FFIErrorCallType FFIErrorCoercionFailed FFIErrorGenericError FFIErrorIntAsPointer FFIErrorInvalidPointer FFIErrorModuleNotFound FFIErrorNoModule FFIErrorNotFunction FFIErrorStructSize FFIErrorWrongType FFIFlagAtomic FFIFlagPointer FFIFlagStructure FFINoCalloutAvailable FFIStructSizeMask FFITypeBool FFITypeDoubleFloat FFITypeSignedByte FFITypeSignedChar FFITypeSignedInt FFITypeSignedLongLong FFITypeSignedShort FFITypeSingleFloat FFITypeUnsignedByte FFITypeUnsignedChar FFITypeUnsignedInt FFITypeUnsignedLongLong FFITypeUnsignedShort FFITypeVoid' - poolDictionaries: '' - category: 'FFI-Pools'! - -FFIConstants class - instanceVariableNames: ''! - -!classDefinition: 'FFIConstants class' category: #'FFI-Pools'! -FFIConstants class - instanceVariableNames: ''! - -ByteArray variableByteSubclass: #ExternalAddress - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'FFI-Kernel'! - -!classDefinition: #ExternalAddress category: #'FFI-Kernel'! -ByteArray variableByteSubclass: #ExternalAddress - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'FFI-Kernel'! - -ExternalAddress class - instanceVariableNames: 'wordSize'! - -!classDefinition: 'ExternalAddress class' category: #'FFI-Kernel'! -ExternalAddress class - instanceVariableNames: 'wordSize'! - -Form subclass: #ExternalForm - instanceVariableNames: 'pointer' - classVariableNames: '' - poolDictionaries: '' - category: 'FFI-Kernel'! - -!classDefinition: #ExternalForm category: #'FFI-Kernel'! -Form subclass: #ExternalForm - instanceVariableNames: 'pointer' - classVariableNames: '' - poolDictionaries: '' - category: 'FFI-Kernel'! - -ExternalForm class - instanceVariableNames: ''! - -!classDefinition: 'ExternalForm class' category: #'FFI-Kernel'! -ExternalForm class - instanceVariableNames: ''! - -Object subclass: #ExternalObject - instanceVariableNames: 'handle' - classVariableNames: '' - poolDictionaries: '' - category: 'FFI-Kernel'! - -!classDefinition: #ExternalObject category: #'FFI-Kernel'! -Object subclass: #ExternalObject - instanceVariableNames: 'handle' - classVariableNames: '' - poolDictionaries: '' - category: 'FFI-Kernel'! - -ExternalObject class - instanceVariableNames: ''! - -!classDefinition: 'ExternalObject class' category: #'FFI-Kernel'! -ExternalObject class - instanceVariableNames: ''! - -ExternalObject subclass: #ExternalFunction - instanceVariableNames: 'flags argTypes' - classVariableNames: 'FFIErrorMessages' - poolDictionaries: 'FFIConstants' - category: 'FFI-Kernel'! - -!classDefinition: #ExternalFunction category: #'FFI-Kernel'! -ExternalObject subclass: #ExternalFunction - instanceVariableNames: 'flags argTypes' - classVariableNames: 'FFIErrorMessages' - poolDictionaries: 'FFIConstants' - category: 'FFI-Kernel'! - -ExternalFunction class - instanceVariableNames: ''! - -!classDefinition: 'ExternalFunction class' category: #'FFI-Kernel'! -ExternalFunction class - instanceVariableNames: ''! - -ExternalFunction subclass: #ExternalLibraryFunction - instanceVariableNames: 'name module errorCodeName' - classVariableNames: '' - poolDictionaries: '' - category: 'FFI-Kernel'! - -!classDefinition: #ExternalLibraryFunction category: #'FFI-Kernel'! -ExternalFunction subclass: #ExternalLibraryFunction - instanceVariableNames: 'name module errorCodeName' - classVariableNames: '' - poolDictionaries: '' - category: 'FFI-Kernel'! - -ExternalLibraryFunction class - instanceVariableNames: ''! - -!classDefinition: 'ExternalLibraryFunction class' category: #'FFI-Kernel'! -ExternalLibraryFunction class - instanceVariableNames: ''! - -ExternalObject subclass: #ExternalLibrary - instanceVariableNames: 'name' - classVariableNames: '' - poolDictionaries: '' - category: 'FFI-Kernel'! - -!classDefinition: #ExternalLibrary category: #'FFI-Kernel'! -ExternalObject subclass: #ExternalLibrary - instanceVariableNames: 'name' - classVariableNames: '' - poolDictionaries: '' - category: 'FFI-Kernel'! - -ExternalLibrary class - instanceVariableNames: ''! - -!classDefinition: 'ExternalLibrary class' category: #'FFI-Kernel'! -ExternalLibrary class - instanceVariableNames: ''! - -ExternalObject subclass: #ExternalStructure - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: 'FFIConstants' - category: 'FFI-Kernel'! - -!classDefinition: #ExternalStructure category: #'FFI-Kernel'! -ExternalObject subclass: #ExternalStructure - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: 'FFIConstants' - category: 'FFI-Kernel'! - -ExternalStructure class - instanceVariableNames: 'compiledSpec'! - -!classDefinition: 'ExternalStructure class' category: #'FFI-Kernel'! -ExternalStructure class - instanceVariableNames: 'compiledSpec'! - -ExternalStructure subclass: #ExternalData - instanceVariableNames: 'type' - classVariableNames: '' - poolDictionaries: '' - category: 'FFI-Kernel'! - -!classDefinition: #ExternalData category: #'FFI-Kernel'! -ExternalStructure subclass: #ExternalData - instanceVariableNames: 'type' - classVariableNames: '' - poolDictionaries: '' - category: 'FFI-Kernel'! - -ExternalData class - instanceVariableNames: ''! - -!classDefinition: 'ExternalData class' category: #'FFI-Kernel'! -ExternalData class - instanceVariableNames: ''! - -Object subclass: #ExternalType - instanceVariableNames: 'compiledSpec referentClass referencedType pointerSize' - classVariableNames: 'AtomicSelectors AtomicTypeNames AtomicTypes StructTypes' - poolDictionaries: 'FFIConstants' - category: 'FFI-Kernel'! - -!classDefinition: #ExternalType category: #'FFI-Kernel'! -Object subclass: #ExternalType - instanceVariableNames: 'compiledSpec referentClass referencedType pointerSize' - classVariableNames: 'AtomicSelectors AtomicTypeNames AtomicTypes StructTypes' - poolDictionaries: 'FFIConstants' - category: 'FFI-Kernel'! - -ExternalType class - instanceVariableNames: ''! - -!classDefinition: 'ExternalType class' category: #'FFI-Kernel'! -ExternalType class - instanceVariableNames: ''! -!ExternalAddress commentStamp: '' prior: 0! - An ExternalAddress is an opaque handle to objects outside Smalltalk memory (e.g., a pointer).! -!ExternalForm commentStamp: '' prior: 0! - An ExternalForm is a specialized Form whose pixel-data is stored in memory that the user provides a pointer to. This can simply be memory on the C heap, or (the motivating use-case...) it can be a pointer that is temporarily "mapped" from GPU memory by an API such as OpenCL. - -The user is responsible for both releasing the image-memory, as well as destroying the surface handle (perhaps the latter should be handled by automatic finalization). - -Example usage: - -| extent form ptr | -extent := 400@300. -form := ExternalForm extent: extent depth: 32. -ptr := ExternalAddress gcallocate: (extent x * extent y * 4). -form setManualSurfacePointer: ptr. -Display displayOn: form. -form displayAt: 100@500. -form destroySurface. -! -!ExternalObject commentStamp: '' prior: 0! - External objects represent entities that are not part of the Smalltalk universe. They are accessed using a unique handle which is interpreted depending on the actual entity that is represented. - -Instance variables: - handle ! -!ExternalFunction commentStamp: '' prior: 0! - This class represents an external function called from Smalltalk. Instances of ExternalFunction can be created if the address/parameters of the function are known by some other means than loading from a shared library or compiling the appropriate primitive specification. - -Instance variables: - flags a set of flags encoding the calling convention - args the parameters of the function - -Implementation notes: - -The arguments consist of an array with the first element defining the return type, the remaining arguments defining the parameters of the call. -! -!ExternalLibraryFunction commentStamp: '' prior: 0! - An ExternalLibraryFunction specifies a fully qualified function from an external library. - -Instance variables: - name name or ordinal of function - module name of module (nil if bound in the VM). - errorCodeName name of temp receiving error code, if any! -!ExternalLibrary commentStamp: '' prior: 0! - An external library bundles calls to functions from the same library. It is provided mainly as convenience since every external function can be fully specified by the name and the module it resides in. - -Every external function that is defined in an external library by default will use the library it is defined in. This can always be modified by providing the appropriate module in the specification. ! -!ExternalStructure commentStamp: '' prior: 0! - This class provides an abstract base for all structures that can be used by external functions. ExternalStructures have two possible handle types: - - ExternalAddress - If the handle is an external address then the object described does not reside in the Smalltalk object memory. - - ByteArray - If the handle is a byte array then the object described resides in Smalltalk memory. -Useful methods should be implemented by subclasses of ExternalStructure using the common ByteArray/ExternalAddress platform dependent access protocol which will transparently access the correct memory location.! -!ExternalData commentStamp: '' prior: 0! - Instances of ExternalData explicitly describe objects with associated type. They can be used for describing atomic C types like arrays of atomic types (e.g., 'int[]') or pointer to atomic types (e.g., 'int *'). - -Instance variables: - type The basic type of the receiver. - -The encoding of type is equivalent to that of the basic type in class ExternalType. The interpretation of whether the receiver describes an array of data or a pointer to data depends on the contents of the instance variable 'handle'. If handle contains an ExternalAddress the receiver is treated as pointer to type. If the handle contains a ByteArray the receiver is interpreted as describing an array of type. Note that both interpretations are treated equivalent in external calls, e.g., if one describes an argument to an external call as taking 'int*' then, depending on the type of handle either the actual contents (if ExternalAddress) or a pointer to the contents (if ByteArray) is passed. - -! -!ExternalType commentStamp: '' prior: 0! - An external type represents the type of external objects. - -Instance variables: - compiledSpec Compiled specification of the external type - referentClass Class type of argument required - referencedType Associated (non)pointer type with the receiver - -Compiled Spec: -The compiled spec defines the type in terms which are understood by the VM. Each word is defined as: - bits 0...15 - byte size of the entity - bit 16 - structure flag (FFIFlagStructure) - This flag is set if the following words define a structure - bit 17 - pointer flag (FFIFlagPointer) - This flag is set if the entity represents a pointer to another object - bit 18 - atomic flag (FFIFlagAtomic) - This flag is set if the entity represents an atomic type. - If the flag is set the atomic type bits are valid. - bits 19...23 - unused - bits 24...27 - atomic type (FFITypeVoid ... FFITypeDoubleFloat) - bits 28...31 - unused - -Note that all combinations of the flags FFIFlagPointer, FFIFlagAtomic, and FFIFlagStructure are invalid, EXCEPT from the following: - - FFIFlagPointer + FFIFlagAtomic: - This defines a pointer to an atomic type (e.g., 'char*', 'int*'). - The actual atomic type is represented in the atomic type bits. - - FFIFlagPointer + FFIFlagStructure: - This defines a structure which is a typedef of a pointer type as in - typedef void* VoidPointer; - typedef Pixmap* PixmapPtr; - It requires a byte size of four (e.g. a 32bit pointer) to work correctly. - -[Note: Other combinations may be allowed in the future] -! -!Object methodsFor: '*FFI-Kernel' stamp: 'ar 8/14/2006 23:02'! - externalCallFailed - "Raise an error after a failed call to an external function" - | errCode | - errCode := ExternalFunction getLastError. "this allows us to look at the actual error code" - ^self error: (ExternalFunction errorMessageFor: errCode).! ! -!SequenceableCollection methodsFor: '*FFI-Kernel' stamp: 'jmv 12/26/2016 10:45:56'! - asMachineWordArray - "Answer an IntegerArray or Bytearray with the elements are the elements of the receiver stored as machine words, - suitable for FFI." - - | answer | - Smalltalk wordSize = 4 ifTrue: [ - ^self as: IntegerArray ]. - answer _ ByteArray new: self size * Smalltalk wordSize. - 1 to: self size do: [ :i | - answer unsignedLong64At: i-1*Smalltalk wordSize+1 put: (self at: i) bigEndian: Smalltalk isBigEndian ]. - ^answer! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'EstebanLorenzano 11/4/2016 14:53'! - asExternalPointer - "Convert the receiver assuming that it describes a pointer to an object." - ^ self pointerAt: 1! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 1/10/2017 16:03:53'! - booleanAt: byteOffset - "Booleans are just integers in C word" - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - ^((self integerAt: byteOffset size: 1 signed: false) == 0) not! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:10:06'! - booleanAt: byteOffset put: value - "Booleans are just integers in C word" - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - ^self integerAt: byteOffset put: (value ifTrue:[1] ifFalse:[0]) size: 1 signed: false! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:10:09'! - doubleAt: byteOffset - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - - ^self primitiveFailed! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:10:13'! - doubleAt: byteOffset put: value - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - - ^self primitiveFailed! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:10:16'! - floatAt: byteOffset - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - - ^self primitiveFailed! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:10:20'! - floatAt: byteOffset put: value - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - - ^self primitiveFailed! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:10:24'! - integerAt: byteOffset put: value size: nBytes signed: aBoolean - "Primitive. Store the given value as integer of nBytes size - in the receiver. Fail if the value is out of range. - Note: This primitive will access memory in the outer space if - invoked from ExternalAddress." - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - - ^self primitiveFailed! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:10:27'! - integerAt: byteOffset size: nBytes signed: aBoolean - "Primitive. Return an integer of nBytes size from the receiver. - Note: This primitive will access memory in the outer space if - invoked from ExternalAddress." - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - - ^self primitiveFailed! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jcg 6/4/2010 02:40'! - isExternalAddress - "Return true if the receiver describes the address of an object in the outside world" - ^false! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'ar 11/16/2006 15:35'! - isNull - "Answer false since only external addresses can be null" - ^false! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:10:30'! - longPointerAt: byteOffset - "Answer an 8-byte pointer object stored at the given byte address" - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - | addr | - addr := ExternalAddress basicNew: 8. - 1 to: 8 do: - [:i| - addr basicAt: i put: (self unsignedByteAt: byteOffset+i-1)]. - ^addr! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:10:32'! - longPointerAt: byteOffset put: value - "Store an 8-byte pointer object at the given byte address" - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - value isExternalAddress ifFalse: - [^self error:'Only external addresses can be stored']. - 1 to: 8 do: - [:i| - self unsignedByteAt: byteOffset+i-1 put: (value basicAt: i)]. - ^value! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:10:35'! - pointerAt: byteOffset - "Answer a pointer object stored at the given byte address" - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - | addr | - addr := ExternalAddress new. - 1 to: ExternalAddress wordSize do: - [:i| - addr basicAt: i put: (self unsignedByteAt: byteOffset+i-1)]. - ^addr! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:10:38'! - pointerAt: byteOffset put: value - "Store a pointer object at the given byte address" - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - value isExternalAddress ifFalse: - [^self error:'Only external addresses can be stored']. - 1 to: ExternalAddress wordSize do: - [:i| - self unsignedByteAt: byteOffset+i-1 put: (value basicAt: i)]. - ^value! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:10:41'! - shortPointerAt: byteOffset - "Answer a 4-byte pointer object stored at the given byte address" - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - | addr | - addr := ExternalAddress basicNew: 4. - 1 to: 4 do: - [:i| - addr basicAt: i put: (self unsignedByteAt: byteOffset+i-1)]. - ^addr! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:10:44'! - shortPointerAt: byteOffset put: value - "Store a 4-byte pointer object at the given byte address" - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - value isExternalAddress ifFalse: - [^self error:'Only external addresses can be stored']. - 1 to: 4 do: - [:i| - self unsignedByteAt: byteOffset+i-1 put: (value basicAt: i)]. - ^value! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:10:48'! - signedByteAt: byteOffset - "Return a 8bit signed integer starting at the given byte offset" - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - ^self integerAt: byteOffset size: 1 signed: true! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:10:56'! - signedByteAt: byteOffset put: value - "Store a 8bit signed integer starting at the given byte offset" - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - ^self integerAt: byteOffset put: value size: 1 signed: true! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:10:59'! - signedCharAt: byteOffset - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - ^(self unsignedByteAt: byteOffset) asCharacter! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:11:03'! - signedCharAt: byteOffset put: aCharacter - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - ^self unsignedByteAt: byteOffset put: aCharacter numericValue! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:11:06'! - signedLongAt: byteOffset - "Return a 32bit signed integer starting at the given byte offset" - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - ^self integerAt: byteOffset size: 4 signed: true! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:11:12'! - signedLongAt: byteOffset put: value - "Store a 32bit signed integer starting at the given byte offset" - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - ^self integerAt: byteOffset put: value size: 4 signed: true! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:11:17'! - signedLongLongAt: byteOffset - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - | int | - int := self unsignedLongLongAt: byteOffset. - int > 16r7FFFFFFFFFFFFFFF ifTrue: [^int - 16r10000000000000000]. - ^int! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:11:20'! - signedLongLongAt: byteOffset put: value - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - self unsignedLongLongAt: byteOffset put: (value < 0 - ifTrue: [ value + 16r10000000000000000 ] - ifFalse: [ value ])! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:11:23'! - signedShortAt: byteOffset - "Return a 16bit signed integer starting at the given byte offset" - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - ^self integerAt: byteOffset size: 2 signed: true! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:11:27'! - signedShortAt: byteOffset put: value - "Store a 16bit signed integer starting at the given byte offset" - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - ^self integerAt: byteOffset put: value size: 2 signed: true! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:11:31'! - structAt: byteOffset length: length - "Return a structure of the given length starting at the indicated byte offset." - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - | value | - value := ByteArray new: length. - 1 to: length do:[:i| - value unsignedByteAt: i put: (self unsignedByteAt: byteOffset+i-1)]. - ^value! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:11:33'! - structAt: byteOffset put: value length: length - "Store a structure of the given length starting at the indicated byte offset." - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - 1 to: length do:[:i| - self unsignedByteAt: byteOffset+i-1 put: (value unsignedByteAt: i)]. - ^value! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:11:36'! - unsignedByteAt: byteOffset - "Return a 8bit unsigned integer starting at the given byte offset" - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - ^self integerAt: byteOffset size: 1 signed: false! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:11:39'! - unsignedByteAt: byteOffset put: value - "Store a 8bit unsigned integer starting at the given byte offset" - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - ^self integerAt: byteOffset put: value size: 1 signed: false! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:11:42'! - unsignedCharAt: byteOffset - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - ^(self unsignedByteAt: byteOffset) asCharacter! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:11:45'! - unsignedCharAt: byteOffset put: aCharacter - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - ^self unsignedByteAt: byteOffset put: aCharacter numericValue! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:11:47'! - unsignedLongAt: byteOffset - "Return a 32bit unsigned integer starting at the given byte offset" - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - ^self integerAt: byteOffset size: 4 signed: false! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:11:50'! - unsignedLongAt: byteOffset put: value - "Store a 32bit signed integer starting at the given byte offset" - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - ^self integerAt: byteOffset put: value size: 4 signed: false! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:11:53'! - unsignedLongLongAt: byteOffset - "Answer a 64-bit integer in Smalltalk order (little-endian)." - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - ^self integerAt: byteOffset size: 8 signed: false! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:11:55'! - unsignedLongLongAt: byteOffset put: value - "I store 64-bit integers in Smalltalk (little-endian) order." - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - ^self integerAt: byteOffset put: value size: 8 signed: false! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:11:59'! - unsignedShortAt: byteOffset - "Return a 16bit unsigned integer starting at the given byte offset" - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - ^self integerAt: byteOffset size: 2 signed: false! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'jmv 12/22/2016 17:12:01'! - unsignedShortAt: byteOffset put: value - "Store a 16bit unsigned integer starting at the given byte offset" - "If a regular ByteArray, byteOffset is the start position in self. - If an ExternalAddress, take us as a pointer. byteOffset is applied to the pointer. Access memory at pointer+offset." - ^self integerAt: byteOffset put: value size: 2 signed: false! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'ar 11/29/1999 00:16'! - voidAt: byteOffset - "no accessors for void" - ^self shouldNotImplement! ! -!ByteArray methodsFor: '*FFI-Kernel' stamp: 'ar 11/29/1999 00:16'! - voidAt: byteOffset put: value - "no accessors for void" - ^self shouldNotImplement! ! -!FFIConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 18:54'! - initialize - "FFIConstants initialize" - self initializeTypeConstants. - self initializeErrorConstants. - self initializeCallingConventions.! ! -!FFIConstants class methodsFor: 'pool initialization' stamp: 'eem 8/4/2009 19:49'! - initializeCallingConventions - "These constants map onto the flags inst var of an ExternalFunction. - The first eight bits define the calling convention. Attribute flags - occupy bits 8 on up." - "FFIConstants initializeCallingConventions" - FFICallTypesMask := 255. - FFICallTypeCDecl := 0. - FFICallTypeApi := 1. - FFICallFlagThreaded := 256! ! -!FFIConstants class methodsFor: 'pool initialization' stamp: 'eem 11/5/2009 10:21'! - initializeErrorConstants - "FFIConstants initializeErrorConstants" - - "No callout mechanism available" - FFINoCalloutAvailable := -1. - "generic error" - FFIErrorGenericError := 0. - "primitive invoked without ExternalFunction" - FFIErrorNotFunction := 1. - "bad arguments to primitive call" - FFIErrorBadArgs := 2. - - "generic bad argument" - FFIErrorBadArg := 3. - "int passed as pointer" - FFIErrorIntAsPointer := 4. - "bad atomic type (e.g., unknown)" - FFIErrorBadAtomicType := 5. - "argument coercion failed" - FFIErrorCoercionFailed := 6. - "Type check for non-atomic types failed" - FFIErrorWrongType := 7. - "struct size wrong or too large" - FFIErrorStructSize := 8. - "unsupported calling convention" - FFIErrorCallType := 9. - "cannot return the given type" - FFIErrorBadReturn := 10. - "bad function address" - FFIErrorBadAddress := 11. - "no module given but required for finding address" - FFIErrorNoModule := 12. - "function address not found" - FFIErrorAddressNotFound := 13. - "attempt to pass 'void' parameter" - FFIErrorAttemptToPassVoid := 14. - "module not found" - FFIErrorModuleNotFound := 15. - "external library invalid" - FFIErrorBadExternalLibrary := 16. - "external function invalid" - FFIErrorBadExternalFunction := 17. - "ExternalAddress points to ST memory (don't you dare to do this!!)" - FFIErrorInvalidPointer := 18. - "Stack frame required more than 16k bytes to pass arguments." - FFIErrorCallFrameTooBig := 19! ! -!FFIConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 18:34'! - initializeTypeConstants - "type void" - FFITypeVoid := 0. - - "type bool" - FFITypeBool := 1. - - "basic integer types. - note: (integerType anyMask: 1) = integerType isSigned" - - FFITypeUnsignedByte := 2. - FFITypeSignedByte := 3. - FFITypeUnsignedShort := 4. - FFITypeSignedShort := 5. - FFITypeUnsignedInt := 6. - FFITypeSignedInt := 7. - - "64bit types" - FFITypeUnsignedLongLong := 8. - FFITypeSignedLongLong := 9. - - "special integer types" - FFITypeUnsignedChar := 10. - FFITypeSignedChar := 11. - - "float types" - FFITypeSingleFloat := 12. - FFITypeDoubleFloat := 13. - - "type flags" - FFIFlagAtomic := 16r40000. "type is atomic" - FFIFlagPointer := 16r20000. "type is pointer to base type" - FFIFlagStructure := 16r10000. "baseType is structure of 64k length" - FFIStructSizeMask := 16rFFFF. "mask for max size of structure" - FFIAtomicTypeMask := 16r0F000000. "mask for atomic type spec" - FFIAtomicTypeShift := 24. "shift for atomic type" -! ! -!ExternalAddress methodsFor: 'arithmetic' stamp: 'pb 5/12/2017 23:44:52'! - + offset - "Create an address that is offset by the given number of bytes. - More tricky than one would think due to the FFI's handling of ExternalAddress - as pointer to an object so that 'self unsignedLongAt: ' would dereference." - "Convert xaddr -> bytes" - | bytes | - bytes := self asByteArrayPointer. - "Update bytes using platform dependent accessors" - Smalltalk wordSize = 4 - ifTrue: [ - bytes - unsignedLongAt: 1 - put: (bytes unsignedLongAt: 1) + offset ] - ifFalse: [ - bytes - unsignedLongLongAt: 1 - put: (bytes unsignedLongLongAt: 1) + offset ]. - ^ bytes asExternalPointer.! ! -!ExternalAddress methodsFor: 'private' stamp: 'eem 2/22/2016 10:03'! - asByteArrayPointer - "Answer a ByteArray containing a copy of pointer to the contents of the receiver." - | sz | - ^(ByteArray basicNew: (sz := self class wordSize)) - replaceFrom: 1 to: sz with: self startingAt: 1 "answers self"! ! -!ExternalAddress methodsFor: 'private' stamp: 'jcg 2/16/2010 01:00'! - asExternalPointer - "No need to convert." - ^self! ! -!ExternalAddress methodsFor: 'converting' stamp: 'eem 2/21/2016 15:23'! - asInteger - "convert address to integer" - ^ self asByteArrayPointer integerAt: 1 size: self class wordSize signed: false! ! -!ExternalAddress methodsFor: 'release' stamp: 'ar 11/22/1999 04:25'! -beNull - "Make the receiver a NULL pointer" - self atAllPut: 0.! ! -!ExternalAddress methodsFor: 'accessing' stamp: 'ar 11/21/1999 15:43'! - byteAt: byteOffset - "Go through a different primitive since the receiver describes data in the outside world" - ^self unsignedByteAt: byteOffset! ! -!ExternalAddress methodsFor: 'accessing' stamp: 'ar 11/21/1999 15:43'! - byteAt: byteOffset put: value - "Go through a different primitive since the receiver describes data in the outside world" - ^self unsignedByteAt: byteOffset put: value! ! -!ExternalAddress methodsFor: 'copying' stamp: 'tbn 4/26/2012 14:10'! - clone - - - self primitiveFailed! ! -!ExternalAddress methodsFor: 'initialize-release' stamp: 'EstebanLorenzano 3/10/2016 16:39'! - finalize - "I am an executor (a copy) of an ExternalAddress that was just garbage collected. - I must finalize. my mission is to free memory" - self isNull ifTrue: [^self]. - self free! ! -!ExternalAddress methodsFor: 'release' stamp: 'ar 11/28/1999 23:40'! - free - "Primitive. Free the object pointed to on the external heap. - Dangerous - may break your system if the receiver hasn't been - allocated by ExternalAddress class>>allocate:. No checks are done." - - ^self primitiveFailed! ! -!ExternalAddress methodsFor: 'converting' stamp: 'eem 2/21/2016 15:29'! - fromInteger: address - "set my handle to point at address." - "Do we really need this? bf 2/21/2001 23:48" - - | sz pointer | - sz := self class wordSize. - pointer := ByteArray new: sz. - pointer integerAt: 1 put: address size: sz signed: false. . - self basicAt: 1 put: (pointer byteAt: 1); - basicAt: 2 put: (pointer byteAt: 2); - basicAt: 3 put: (pointer byteAt: 3); - basicAt: 4 put: (pointer byteAt: 4). - sz = 8 ifTrue: - [self basicAt: 5 put: (pointer byteAt: 5); - basicAt: 6 put: (pointer byteAt: 6); - basicAt: 7 put: (pointer byteAt: 7); - basicAt: 8 put: (pointer byteAt: 8)]! ! -!ExternalAddress methodsFor: 'accessing' stamp: 'jcg 6/4/2010 02:40'! - isExternalAddress - "Return true if the receiver describes the address of an object in the outside world" - ^true! ! -!ExternalAddress methodsFor: 'testing' stamp: 'ar 11/16/2006 15:35'! - isNull - "Answer true if I am a null pointer" - 1 to: self size do:[:i| (self at: i) = 0 ifFalse:[^false]]. - ^true! ! -!ExternalAddress methodsFor: 'printing' stamp: 'jmv 1/9/2014 21:37'! - printOn: aStream - "print this as a hex address ('@ 16rFFFFFFFF') to distinguish it from ByteArrays" - - aStream nextPutAll: '@ '; nextPutAll: self asInteger hex8! ! -!ExternalAddress methodsFor: 'copying' stamp: 'eem 2/21/2016 15:31'! - shallowCopy - "Re-implemented to avoid superclass call to #new:" - "But superclass's shallowCopy sends basicNew: and basicNew: is ok. eem 2/21/2016 15:31" - ^self clone! ! -!ExternalAddress class methodsFor: 'instance creation' stamp: 'ar 11/28/1999 23:20'! - allocate: byteSize - "Primitive. Allocate an object on the external heap." - - ^self primitiveFailed! ! -!ExternalAddress class methodsFor: 'instance creation' stamp: 'nice 5/19/2006 03:24'! - gcallocate: byteSize - "Primitive. Allocate an object on the external heap. - The external memory will be freed when i am garbage collected. - BEWARE: there should be no copy of self, nor any pointer to a sub part..." - - | externalAddress | - externalAddress := self allocate: byteSize. - self finalizationRegistry add: externalAddress. - ^externalAddress! ! -!ExternalAddress class methodsFor: 'class initialization' stamp: 'eem 2/20/2016 17:29'! - initialize - wordSize := Smalltalk wordSize! ! -!ExternalAddress class methodsFor: 'instance creation' stamp: 'dtl 9/12/2015 18:04'! - loadSymbol: moduleSymbol module: module - - ^ self primitiveFailed! ! -!ExternalAddress class methodsFor: 'instance creation' stamp: 'eem 2/16/2016 12:17'! -new - "External addresses are either four or eight bytes long." - ^super new: wordSize! ! -!ExternalAddress class methodsFor: 'instance creation' stamp: 'eem 2/22/2016 15:42'! - new: n - "Only create ExternalAddresses of the right size." - ^n = wordSize - ifTrue: [super new: n] - ifFalse: [self shouldNotImplement]! ! -!ExternalAddress class methodsFor: 'class initialization' stamp: 'eem 2/22/2016 15:30'! - startUp: resuming - "If starting the image afresh all external addresses should be zero. - In addition, if the word size has changed then external addresses shoiuld be resized. - The two steps are combined for efficiency." - resuming ifTrue: - [| instances | - instances := self allInstances. - wordSize ~= Smalltalk wordSize - ifTrue: "Implement nulling by becomming all existing instances to new (and hence null) pointers of the right size." - [wordSize := Smalltalk wordSize. - instances elementsForwardIdentityTo: (instances collect: [:ea| self basicNew: wordSize])] - ifFalse: - [instances do: [:addr| addr beNull]]]! ! -!ExternalAddress class methodsFor: 'accessing' stamp: 'eem 2/16/2016 12:34'! - wordSize - ^wordSize! ! -!ExternalForm methodsFor: 'initialization' stamp: 'jmv 5/4/2016 12:43'! - allocateSpace - "Convenient way to allocate space for the pixels. This isn't done by default, because it is common to use a pointer obtained from elsewhere." - | addr | - pointer ifNotNil: [self error: 'space is already allocated']. - addr := ExternalAddress gcallocate: width*height * depth abs // 8. "area times bytes/pixel" - self setManualSurfacePointer: addr.! ! -!ExternalForm methodsFor: 'initialization' stamp: 'jcg 1/29/2010 01:29'! - destroySurface - "Users must call this explicitly when this object is no longer needed; otherwise, resource-leakage will occur in the SurfacePlugin" - bits ifNotNil: [:surfaceID | - bits := nil. - self primDestroyManualSurface: surfaceID - ].! ! -!ExternalForm methodsFor: 'initialization' stamp: 'jcg 6/4/2010 02:04'! - initialize - super initialize. - pointer := nil. - ! ! -!ExternalForm methodsFor: 'accessing' stamp: 'jcg 2/16/2010 00:01'! - pointer - ^pointer! ! -!ExternalForm methodsFor: 'primitives' stamp: 'jcg 1/30/2010 02:52'! - primCreateManualSurfaceWidth: width height: height rowPitch: rowPitch depth: depth isMSB: isMSB - - self primitiveFailed -! ! -!ExternalForm methodsFor: 'primitives' stamp: 'jcg 1/30/2010 02:52'! - primDestroyManualSurface: surfaceID - - self primitiveFailed -! ! -!ExternalForm methodsFor: 'primitives' stamp: 'jcg 1/30/2010 02:52'! - primManualSurface: surfaceID setPointer: pointer - "The 'surfaceID' is a handle returned by #primitiveCreateManualSurface from SurfacePlugin. The pointer is a 32-bit unsigned integer that SurfacePlugin casts to a void*." - - self primitiveFailed -! ! -!ExternalForm methodsFor: 'initialization' stamp: 'jmv 5/4/2016 12:47'! - setExtent: extent depth: bitsPerPixel - bits ifNotNil: [self error: 'bits are already set']. - (#(8 16 32) includes: bitsPerPixel abs) - ifFalse: [self error: 'only +/- 8, 16 or 32 bits for now'. "see 'rowPitch' below"]. - width := extent x asInteger. - width < 0 ifTrue: [width := 0]. - height := extent y asInteger. - height < 0 ifTrue: [height := 0]. - depth := bitsPerPixel. - bits := self - primCreateManualSurfaceWidth: width - height: height - rowPitch: width * (bitsPerPixel abs/8) - depth: bitsPerPixel abs - isMSB: bitsPerPixel > 0.! ! -!ExternalForm methodsFor: 'initialization' stamp: 'jcg 1/29/2010 01:31'! - setExtent: extent depth: bitsPerPixel bits: pointer - self setExtent: extent depth: bitsPerPixel. - self setManualSurfacePointer: pointer.! ! -!ExternalForm methodsFor: 'initialization' stamp: 'jmv 12/22/2016 16:04:33'! - setManualSurfacePointer: newPointer "ExternalStructure, ExternalAddress, or nil" - "Set the memory-location of the image data. It is OK to set a NULL pointer; in this case, any attempt to BitBlt to or from the form will result in a primitive-failure." - | integer | - pointer := newPointer. - pointer ifNil: [^self primManualSurface: bits setPointer: 0]. - pointer isExternalAddress - ifFalse: ["must already be ExternalStructure, so nothing to do"] - ifTrue: [pointer := ExternalData - fromHandle: newPointer - type: ExternalType void asPointerType]. - "The primitive expects an unsigned integer arg, not an ExternalAddress." - "NOTE: it used to be acceptable for 'newPointer' to be an Integer... - if you get a MNU for #getHandle here, you should update your code - to pass in either an ExternalStructure or an ExternalAddress." - integer := Smalltalk wordSize caseOf: { - [ 4 ] -> [ pointer getHandle unsignedLongAt: 1 bigEndian: Smalltalk isBigEndian ]. - [ 8 ] -> [ pointer getHandle unsignedLong64At: 1 bigEndian: Smalltalk isBigEndian ] - } - otherwise: [ self error ]. - self primManualSurface: bits setPointer: integer! ! -!ExternalObject methodsFor: 'private' stamp: 'ar 11/16/1999 20:25'! - getHandle - "Private. Return the handle used to represent the external entitiy." - ^handle! ! -!ExternalObject methodsFor: 'testing' stamp: 'jcg 6/4/2010 02:40'! - isExternalAddress - "Return true if the receiver describes the address of an object in the outside world" - ^false! ! -!ExternalObject methodsFor: 'testing' stamp: 'ar 11/16/2006 15:36'! - isNull - "Answer true if the receiver currently is a NULL pointer" - ^handle == nil or:[handle isNull]! ! -!ExternalObject methodsFor: 'private' stamp: 'ar 11/16/1999 20:26'! - setHandle: anObject - "Private. Set the handle used to represent the external entity." - handle := anObject! ! -!ExternalObject class methodsFor: 'class initialization' stamp: 'ar 11/19/1999 22:37'! - initialize - "ExternalObject initialize" -" Smalltalk addToStartUpList: self after: ShortRunArray." - Smalltalk addToStartUpList: self.! ! -!ExternalObject class methodsFor: 'system startup' stamp: 'ar 11/28/1999 23:37'! - install - "Notify all instances of the receiver that we're coming up on a new platform. - Note: The default implementation does nothing since the general external - objects are cleaned up by ExternalAddress>>startUp: but subclasses may - implement this method so that the appropriate action for existing instances can - be taken."! ! -!ExternalObject class methodsFor: 'system startup' stamp: 'ar 11/28/1999 23:36'! - installSubclasses - "Notify all the subclasses of ExternalObject that we are starting up on a new platform." - self withAllSubclassesDo:[:cls| cls install].! ! -!ExternalObject class methodsFor: 'system startup' stamp: 'ar 11/28/1999 23:36'! - startUp: resuming - "The system is coming up. If it is on a new platform, clear out the existing handles." - ExternalAddress startUp: resuming. "Make sure handles are invalid" - resuming ifTrue:[self installSubclasses]. -! ! -!ExternalFunction methodsFor: 'accessing' stamp: 'ar 11/19/1999 19:13'! - argTypes - ^argTypes! ! -!ExternalFunction methodsFor: 'printing' stamp: 'ar 11/19/1999 16:35'! - callingConventionString - (flags allMask: FFICallTypeApi) - ifTrue:[^'apicall'] - ifFalse:[^'cdecl']! ! -!ExternalFunction methodsFor: 'accessing' stamp: 'eem 10/28/2009 17:03'! - errorCodeName - ^nil! ! -!ExternalFunction methodsFor: 'accessing' stamp: 'ar 11/19/1999 19:13'! - flags - ^flags! ! -!ExternalFunction methodsFor: 'initialization' stamp: 'ar 11/29/1999 00:35'! - initialize - "Initialize the receiver" - handle := ExternalAddress new.! ! -!ExternalFunction methodsFor: 'invoking' stamp: 'ar 11/19/1999 21:54'! - invoke - ^self invokeWithArguments: #()! ! -!ExternalFunction methodsFor: 'invoking' stamp: 'ar 11/19/1999 21:53'! - invokeWith: arg1 - ^self invokeWithArguments: (Array with: arg1)! ! -!ExternalFunction methodsFor: 'invoking' stamp: 'ar 11/19/1999 21:53'! - invokeWith: arg1 with: arg2 - ^self invokeWithArguments: (Array with: arg1 with: arg2)! ! -!ExternalFunction methodsFor: 'invoking' stamp: 'ar 11/19/1999 21:53'! -invokeWith: arg1 with: arg2 with: arg3 - ^self invokeWithArguments: (Array with: arg1 with: arg2 with: arg3)! ! -!ExternalFunction methodsFor: 'invoking' stamp: 'ar 11/19/1999 19:08'! - invokeWith: arg1 with: arg2 with: arg3 with: arg4 - ^self invokeWithArguments: (Array with: arg1 with: arg2 with: arg3 with: arg4)! ! -!ExternalFunction methodsFor: 'invoking' stamp: 'ar 11/19/1999 21:53'! - invokeWith: arg1 with: arg2 with: arg3 with: arg4 with: arg5 - ^self invokeWithArguments: (Array with: arg1 with: arg2 with: arg3 with: arg4 with: arg5)! ! -!ExternalFunction methodsFor: 'invoking' stamp: 'ar 11/19/1999 21:54'! - invokeWith: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6 - ^self invokeWithArguments: (Array with: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6)! ! -!ExternalFunction methodsFor: 'invoking' stamp: 'ar 11/28/1999 20:12'! - invokeWithArguments: argArray - "Manually invoke the receiver, representing an external function." - - ^self externalCallFailed! ! -!ExternalFunction methodsFor: 'accessing' stamp: 'ar 11/17/1999 19:55'! - module - ^nil! ! -!ExternalFunction methodsFor: 'accessing' stamp: 'ar 11/17/1999 17:06'! - name - ^nil! ! -!ExternalFunction methodsFor: 'printing' stamp: 'eem 10/28/2009 17:10'! - printOn: aStream - aStream - nextPut:$<; - nextPutAll: self callingConventionString; nextPutAll:': '. - { 'threaded' } with: { FFICallFlagThreaded } do: - [:modifier :flag| - (flags anyMask: flag) ifTrue: - [aStream nextPutAll: modifier; space]]. - aStream print: argTypes first; space. - self name == nil - ifTrue:[aStream nextPutAll:'(*) '] - ifFalse:[aStream print: self name asString; space]. - aStream nextPut:$(. - 2 to: argTypes size do:[:i| - aStream print: (argTypes at: i). - i < argTypes size ifTrue:[aStream space]]. - aStream nextPut:$). - self module == nil ifFalse:[ - aStream space; nextPutAll:'module: '; print: self module asString. - ]. - self errorCodeName == nil ifFalse:[ - aStream space; nextPutAll:'error: '; nextPutAll: self errorCodeName. - ]. - aStream nextPut:$>! ! -!ExternalFunction methodsFor: 'invoking' stamp: 'eem 2/20/2016 17:25'! - tryInvokeWithArguments: argArray - "Sent from the debugger to simulate an FFI call." - - - ^thisContext class primitiveFailTokenFor: ec! ! -!ExternalFunction class methodsFor: 'compiler support' stamp: 'ar 12/2/1999 16:20'! - atomicTypeNamed: aString - ^ExternalType atomicTypeNamed: aString! ! -!ExternalFunction class methodsFor: 'constants' stamp: 'ar 11/19/1999 16:36'! - callTypeAPI - ^FFICallTypeApi! ! -!ExternalFunction class methodsFor: 'constants' stamp: 'ar 11/19/1999 16:36'! - callTypeCDecl - ^FFICallTypeCDecl! ! -!ExternalFunction class methodsFor: 'compiler support' stamp: 'ar 11/17/1999 19:58'! - callingConventionFor: aString - "Return the constant describing the calling convention for the given string specification or nil if unknown." - aString = 'cdecl:' ifTrue:[^self callTypeCDecl]. - aString = 'apicall:' ifTrue:[^self callTypeAPI]. - ^nil! ! -!ExternalFunction class methodsFor: 'compiler support' stamp: 'eem 8/4/2009 19:44'! - callingConventionModifierFor: aString - "Return the constant describing the calling convention modifier for the given string specification or nil if unknown." - aString = 'threaded' ifTrue:[^FFICallFlagThreaded]. - ^nil! ! -!ExternalFunction class methodsFor: 'error handling' stamp: 'ar 11/19/1999 14:17'! - errorMessageFor: code - "Return the error message for the given error code from the foreign function interface" - ^FFIErrorMessages at: code ifAbsent:['Call to external function failed'].! ! -!ExternalFunction class methodsFor: 'error handling' stamp: 'ar 11/19/1999 19:09'! - externalCallFailed - "Raise an error after a failed call to an external function" - | errCode | - errCode := self getLastError. "this allows us to look at the actual error code" - ^self error: (self errorMessageFor: errCode).! ! -!ExternalFunction class methodsFor: 'error handling' stamp: 'eem 11/19/2009 10:47'! - externalCallFailedWith: primErrorCode - "Raise an error after a failed call to an external function. - The primFailCode could be any of: - - a symbol; one of the standard primitive errors defined in Smalltalk primitiveErrorTable - - nil; the VM does not support primitive errors and is not providing error codes - - an integer; one of the FFI codes incremented by Smalltalk primitiveErrorTable size + 2 - so as not to clash with the standard primitive errors." - ^self error: (primErrorCode isInteger - ifTrue: [self errorMessageFor: primErrorCode - (Smalltalk primitiveErrorTable size + 2)] - ifFalse: [primErrorCode isNil - ifTrue: ['Call to external function failed'] - ifFalse: [primErrorCode]])! ! -!ExternalFunction class methodsFor: 'compiler support' stamp: 'ar 12/2/1999 16:49'! - forceTypeNamed: aString - ^ExternalType forceTypeNamed: aString! ! -!ExternalFunction class methodsFor: 'error handling' stamp: 'ar 11/28/1999 18:37'! - getLastError - "Return the last error from an external call. - Only valid immediately after the external call failed." - - ^-1! ! -!ExternalFunction class methodsFor: 'class initialization' stamp: 'ar 3/9/2010 21:45'! - initialize - "ExternalFunction initialize" - FFIConstants initialize. "ensure proper initialization" - self initializeErrorMessages. - (Smalltalk specialObjectsArray at: 47) == self - ifFalse:[Smalltalk recreateSpecialObjectsArray]. -! ! -!ExternalFunction class methodsFor: 'class initialization' stamp: 'eem 11/5/2009 10:24'! - initializeErrorMessages - "ExternalFunction initializeErrorMessages" - FFIErrorMessages := Dictionary new. - FFIErrorMessages - at: FFINoCalloutAvailable put: 'Callout mechanism not available'; - at: FFIErrorGenericError put: 'A call to an external function failed'; - at: FFIErrorNotFunction put: 'Only ExternalFunctions can be called'; - at: FFIErrorBadArgs put: 'Bad arguments in primitive invocation'; - at: FFIErrorBadArg put: 'Bad argument for external function'; - at: FFIErrorIntAsPointer put: 'Cannot use integer as pointer'; - at: FFIErrorBadAtomicType put: 'Unknown atomic type in external call'; - at: FFIErrorCoercionFailed put: 'Could not coerce arguments'; - at: FFIErrorWrongType put: 'Wrong type in external call'; - at: FFIErrorStructSize put: 'Bad structure size in external call'; - at: FFIErrorCallType put: 'Unsupported calling convention'; - at: FFIErrorBadReturn put: 'Cannot return the given type'; - at: FFIErrorBadAddress put: 'Bad function address'; - at: FFIErrorNoModule put: 'No module to load address from'; - at: FFIErrorAddressNotFound put: 'Unable to find function address'; - at: FFIErrorAttemptToPassVoid put: 'Cannot pass ''void'' parameter'; - at: FFIErrorModuleNotFound put: 'External module not found'; - at: FFIErrorBadExternalLibrary put: 'External library is invalid'; - at: FFIErrorBadExternalFunction put: 'External function is invalid'; - at: FFIErrorInvalidPointer put: 'Attempt to pass invalid pointer'; - at: FFIErrorCallFrameTooBig put: 'Call requires more than 16k of stack space'; - yourself! ! -!ExternalFunction class methodsFor: 'compiler support' stamp: 'ar 12/2/1999 16:30'! - isValidType: anObject - ^anObject isBehavior and:[anObject includesBehavior: ExternalStructure]! ! -!ExternalFunction class methodsFor: 'compiler support' stamp: 'ar 12/2/1999 16:21'! - structTypeNamed: aString - ^ExternalType structTypeNamed: aString! ! -!ExternalFunction class methodsFor: 'class initialization' stamp: 'ar 3/9/2010 21:45'! - unload - "Clean out the splObj array" - Smalltalk specialObjectsArray from: 44 to: 48 put: nil. -! ! -!ExternalLibraryFunction methodsFor: 'comparing' stamp: 'eem 10/28/2009 17:07'! - analogousCodeTo: anObject - ^(anObject isKindOf: ExternalLibraryFunction) - and: [flags = anObject flags - and: [argTypes = anObject argTypes - and: [name = anObject name - and: [module = anObject module - and: [errorCodeName = anObject errorCodeName]]]]]! ! -!ExternalLibraryFunction methodsFor: 'accessing' stamp: 'eem 10/28/2009 17:07'! - errorCodeName - ^errorCodeName! ! -!ExternalLibraryFunction methodsFor: 'accessing' stamp: 'ar 11/17/1999 19:55'! - module - ^module! ! -!ExternalLibraryFunction methodsFor: 'accessing' stamp: 'ar 11/17/1999 17:06'! - name - ^name! ! -!ExternalLibraryFunction methodsFor: 'private' stamp: 'ar 11/19/1999 19:12'! - name: aName module: aModule flags: anInteger argTypes: argTypeArray - - name := aName. - module := aModule. - flags := anInteger. - argTypes := argTypeArray.! ! -!ExternalLibraryFunction methodsFor: 'accessing' stamp: 'eem 10/28/2009 17:07'! - setErrorCodeName: aString - errorCodeName := aString! ! -!ExternalLibraryFunction methodsFor: 'accessing' stamp: 'das 5/23/2005 10:50'! - setModule: aString - "Private. Hack the module" - module := aString.! ! -!ExternalLibraryFunction class methodsFor: 'instance creation' stamp: 'ar 11/17/1999 14:52'! - name: aName module: aModule callType: callType returnType: retType argumentTypes: argTypes - ^self new - name: aName - module: aModule - flags: callType - argTypes: (Array with: retType), argTypes! ! -!ExternalLibrary methodsFor: 'initialization' stamp: 'ar 12/8/1999 21:49'! - forceLoading - "Primitive. Force loading the given library. - The primitive will fail if the library is not available - or if anything is wrong with the receiver." - - ^self externalCallFailed "The primitive will set the error code"! ! -!ExternalLibrary methodsFor: 'accessing' stamp: 'ar 11/17/1999 19:35'! - handle - ^handle! ! -!ExternalLibrary methodsFor: 'initialization' stamp: 'ar 11/29/1999 00:35'! - initialize - "Initialize the receiver" - name := self class moduleName. - handle := ExternalAddress new.! ! -!ExternalLibrary methodsFor: 'accessing' stamp: 'ar 11/17/1999 19:35'! - name - ^name! ! -!ExternalLibrary class methodsFor: 'accessing' stamp: 'ar 11/17/1999 19:33'! - moduleName - "Return the name of the module for this library" - ^nil! ! -!ExternalStructure methodsFor: 'release' stamp: 'ar 11/28/1999 23:21'! - free - "Free the handle pointed to by the receiver" - (handle ~~ nil and:[handle isExternalAddress]) ifTrue:[handle free]. - handle := nil.! ! -!ExternalStructure methodsFor: 'printing' stamp: 'jmv 3/13/2012 12:33'! - longPrintOn: aStream - "Append to the argument, aStream, the names and values of all the record's variables." - | fields | - fields := self class fields. - (fields isEmpty or: [fields first isNil]) ifTrue: [fields := #()] - ifFalse: [(fields first isKindOf: Array) ifFalse: [fields := Array with: fields]]. - fields do: [ :field | - field first notNil ifTrue: [ - aStream nextPutAll: field first; nextPut: $:; space; tab. - (self perform: field first) printOn: aStream. - aStream newLine]].! ! -!ExternalStructure class methodsFor: 'field definition' stamp: 'ar 12/2/1999 14:31'! - byteSize - "Return the size in bytes of this structure." - ^self compiledSpec first bitAnd: FFIStructSizeMask! ! -!ExternalStructure class methodsFor: 'field definition' stamp: 'gk 3/1/2005 12:06'! - compileAlias: spec withAccessors: aBool - "Define all the fields in the receiver. - Return the newly compiled spec." - | fieldName fieldType isPointerField externalType | - fieldName := spec first. - fieldType := spec second. - isPointerField := fieldType last = $*. - fieldType := fieldType copyWithout: $*. - externalType := ExternalType atomicTypeNamed: fieldType. - externalType == nil ifTrue:["non-atomic" - Symbol hasInterned: fieldType ifTrue:[:sym| - externalType := ExternalType structTypeNamed: sym]]. - externalType == nil ifTrue:[ - Transcript show:'(', fieldType,' is void)'. - externalType := ExternalType void]. - isPointerField ifTrue:[externalType := externalType asPointerType]. - (fieldName notNil and:[aBool]) ifTrue:[ - self defineAliasAccessorsFor: fieldName - type: externalType]. - isPointerField - ifTrue:[compiledSpec := WordArray with: - (ExternalType structureSpec bitOr: ExternalType pointerSpec)] - ifFalse:[compiledSpec := externalType compiledSpec]. - ExternalType noticeModificationOf: self. - ^compiledSpec! ! -!ExternalStructure class methodsFor: 'field definition' stamp: 'ar 12/2/1999 15:35'! - compileAllFields - "ExternalStructure compileAllFields" - self withAllSubclassesDo:[:cls| - cls compileFields. - ].! ! -!ExternalStructure class methodsFor: 'field definition' stamp: 'ar 12/2/1999 14:28'! - compileFields - "Compile the field definition of the receiver. - Return the newly compiled spec." - ^self compileFields: self fields! ! -!ExternalStructure class methodsFor: 'field definition' stamp: 'ar 12/2/1999 14:28'! - compileFields: fieldSpec - "Compile the field definition of the receiver. - Return the newly compiled spec." - ^self compileFields: fieldSpec withAccessors: false.! ! -!ExternalStructure class methodsFor: 'field definition' stamp: 'eem 2/16/2016 12:56'! - compileFields: specArray withAccessors: aBool - "Define all the fields in the receiver. - Return the newly compiled spec." - | byteOffset typeSpec | - (specArray size > 0 and: [specArray first class ~~ Array]) ifTrue: - [^ self compileAlias: specArray withAccessors: aBool]. - byteOffset := 1. - typeSpec := WriteStream on: (WordArray new: 10). - typeSpec nextPut: FFIFlagStructure. - "dummy for size" - specArray do: - [:spec | | fieldName fieldType isPointerField externalType typeSize selfRefering | - fieldName := spec first. - fieldType := spec second. - isPointerField := fieldType last = $*. - fieldType := (fieldType findTokens: ' *') first. - externalType := ExternalType atomicTypeNamed: fieldType. - selfRefering := isPointerField and: [externalType isNil and: [fieldType = self asString]]. - selfRefering ifTrue: [ - externalType := ExternalType void asPointerType - ] ifFalse:[ - externalType == nil ifTrue: ["non-atomic" - Symbol - hasInterned: fieldType - ifTrue: [:sym | externalType := ExternalType structTypeNamed: sym]. - ]. - externalType == nil ifTrue:[ - Transcript show: '(' , fieldType , ' is void)'. - externalType := ExternalType void. - ]. - isPointerField ifTrue: [externalType := externalType asPointerType: self pointerSize]]. - typeSize := externalType byteSize. - spec size > 2 ifTrue: ["extra size" - spec third < typeSize - ifTrue: [^ self error: 'Explicit type size is less than expected']. - typeSize := spec third. - ]. - (fieldName notNil and: [aBool]) ifTrue: [ - self defineFieldAccessorsFor: fieldName startingAt: byteOffset type: externalType. - ]. - typeSpec nextPutAll: (externalType embeddedSpecWithSize: typeSize). - byteOffset := byteOffset + typeSize. - ]. - compiledSpec := typeSpec contents. - compiledSpec at: 1 put: (byteOffset - 1 bitOr: FFIFlagStructure). - ExternalType noticeModificationOf: self. - ^ compiledSpec! ! -!ExternalStructure class methodsFor: 'field definition' stamp: 'ar 12/2/1999 14:28'! - compiledSpec - "Return the compiled spec of the receiver" - ^compiledSpec ifNil:[self compileFields].! ! -!ExternalStructure class methodsFor: 'field definition' stamp: 'jmv 4/16/2017 20:57:12'! -defineAliasAccessorsFor: fieldName type: type - "Define read/write accessors for the given field" - | code refClass argName | - (type isVoid and:[type isPointerType not]) ifTrue:[^self]. - refClass := type referentClass. - code := String streamContents:[:s| - s - nextPutAll: fieldName; newLine; tab; - nextPutAll:'"This method was automatically generated"'; newLine; tab. - refClass == nil - ifTrue:[(type isAtomic and:[type isPointerType not]) - ifTrue:[s nextPutAll:'^handle'] - ifFalse:[s nextPutAll:'^ExternalData fromHandle: handle'. - type isPointerType ifTrue:[s nextPutAll:' asExternalPointer']. - s nextPutAll:' type: '; - nextPutAll: type externalTypeName]] - ifFalse:[s nextPutAll:'^', refClass name,' fromHandle: handle'. - type isPointerType ifTrue:[s nextPutAll:' asExternalPointer']]]. - self compile: code classified: 'accessing' withStamp: nil notifying: nil. - - code := String streamContents:[:s| - argName := refClass == nil - ifTrue:[(type isAtomic and:[type isPointerType not]) - ifTrue:['anObject'] - ifFalse:['anExternalData']] - ifFalse:['a',refClass name]. - s - nextPutAll: fieldName,': '; nextPutAll: argName; newLine; tab; - nextPutAll:'"This method was automatically generated"'; newLine; tab. - (refClass == nil and:[type isAtomic and:[type isPointerType not]]) - ifTrue:[s nextPutAll:'handle := ', argName] - ifFalse:[s nextPutAll:'handle := ', argName,' getHandle'. - type isPointerType ifTrue:[s nextPutAll:' asByteArrayPointer']]]. - self compile: code classified: 'accessing' withStamp: nil notifying: nil.! ! -!ExternalStructure class methodsFor: 'field definition' stamp: 'jmv 12/19/2016 15:52:42'! - defineFieldAccessorsFor: fieldName startingAt: byteOffset type: type - "Define read/write accessors for the given field" - | comment | - (type isVoid and: [type isPointerType not]) ifTrue:[^self]. - comment := ('\ "This method was automatically generated. See ', self class name, '>>fields."\ ') withNewLines. - self maybeCompileAccessor: fieldName, comment, (type readFieldAt: byteOffset) - withSelector: fieldName asSymbol. - self maybeCompileAccessor: fieldName,': anObject', comment, (type writeFieldAt: byteOffset with: 'anObject') - withSelector: (fieldName, ':') asSymbol! ! -!ExternalStructure class methodsFor: 'field definition' stamp: 'ar 12/2/1999 14:37'! - defineFields - "Define all the fields in the receiver" - self defineFields: self fields.! ! -!ExternalStructure class methodsFor: 'field definition' stamp: 'ar 12/2/1999 14:38'! - defineFields: fields - "Define all the fields in the receiver" - self compileFields: fields withAccessors: true.! ! -!ExternalStructure class methodsFor: 'class management' stamp: 'ar 11/22/1999 10:10'! - doneCompiling - "I have been recompiled. Update any types that reference me." - ExternalType noticeModificationOf: self.! ! -!ExternalStructure class methodsFor: 'instance creation' stamp: 'ar 12/1/1999 15:58'! - externalNew - "Create an instance of the receiver on the external heap" - ^self fromHandle: (ExternalAddress allocate: self byteSize)! ! -!ExternalStructure class methodsFor: 'converting' stamp: 'ar 12/2/1999 16:55'! - externalType - "Return an external type describing the receiver as a structure" - ^ExternalType structTypeNamed: self name! ! -!ExternalStructure class methodsFor: 'field definition' stamp: 'ar 11/29/1999 00:28'! - fields - "Return the fields defining the receiver" - ^#()! ! -!ExternalStructure class methodsFor: 'class management' stamp: 'jmv 3/13/2012 12:34'! - fileOutInitializerOn: aFileStream - - super fileOutInitializerOn: aFileStream. - aFileStream newLine. - aFileStream newLine. - aFileStream nextChunkPut: self name , ' compileFields'. - aFileStream newLine.! ! -!ExternalStructure class methodsFor: 'class management' stamp: 'jmv 3/13/2012 12:34'! - fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: aBool - - super fileOutOn: aFileStream - moveSource: moveSource - toFile: fileIndex - initializing: aBool. - (aBool and:[moveSource not]) ifTrue: [ - aFileStream newLine. - aFileStream newLine. - aFileStream nextChunkPut: self name , ' compileFields'. - aFileStream newLine]! ! -!ExternalStructure class methodsFor: 'instance creation' stamp: 'ar 11/29/1999 00:36'! - fromHandle: aHandle - ^self basicNew setHandle: aHandle! ! -!ExternalStructure class methodsFor: 'class initialization' stamp: 'jmv 1/13/2016 10:22'! - initialize - ExternalType initialize. - self compileFields! ! -!ExternalStructure class methodsFor: 'compiling' stamp: 'jmv 4/16/2017 20:53:30'! - maybeCompileAccessor: aString withSelector: selector - - (self compiledMethodAt: selector ifAbsent: []) ifNotNil: [ :existingMethod | - existingMethod getSourceFromFile asString = aString ifTrue: [ - ^self]]. - self compile: aString classified: #accessing withStamp: nil notifying: nil! ! -!ExternalStructure class methodsFor: 'instance creation' stamp: 'ar 12/1/1999 15:58'! - new - ^self fromHandle: (ByteArray new: self byteSize)! ! -!ExternalStructure class methodsFor: 'class management' stamp: 'sma 6/16/2000 22:12'! - obsolete - "The receiver is becoming obsolete. - NOTE: You if you remove the whole class category at once, you cannot - assume that the ExternalType class is still present." - - Smalltalk at: #ExternalType ifPresent: [:class | class noticeRemovalOf: self]. - ^ super obsolete! ! -!ExternalStructure class methodsFor: 'accessing' stamp: 'eem 2/16/2016 12:42'! - pointerSize - "Answer the size of pointers for this class. By default answer nil. - Subclasses that contain pointers must define the size of a pointer if the code is to operate on 64-bit and 32-bit platforms. - Currently we have no way of converting a type between 32- and 64- bit versions beyond recompiling it." - ^nil! ! -!ExternalStructure class methodsFor: 'class management' stamp: 'ar 11/22/1999 04:12'! - rename: aString - | oldName | - oldName := name. - super rename: aString. - oldName = name ifFalse:[ExternalType noticeRenamingOf: self from: oldName to: name].! ! -!ExternalStructure class methodsFor: 'converting' stamp: 'eem 2/16/2016 10:32'! - typedef - ^self externalType typedef! ! -!ExternalData methodsFor: 'conversion' stamp: 'hg 2/25/2000 14:51'! - fromCString - "Assume that the receiver represents a C string and convert it to a Smalltalk string. hg 2/25/2000 14:18" - - | stream index char | - type isPointerType ifFalse: [self error: 'External object is not a pointer type.']. - stream := WriteStream on: String new. - index := 1. - [(char := handle unsignedCharAt: index) = 0 asCharacter] whileFalse: [ - stream nextPut: char. - index := index + 1]. - ^stream contents! ! -!ExternalData methodsFor: 'conversion' stamp: 'jrd 4/23/2009 17:35'! - fromCStrings - "Assume that the receiver represents a set of C strings and is teerminated by a empty string and convert it to a Smalltalk ordered collection of strings" - - | stream index char strings str | - type isPointerType ifFalse: [self error: 'External object is not a pointer type.']. - strings := OrderedCollection new. - index := 1. - [ - stream := WriteStream on: String new. - [(char := handle unsignedCharAt: index) = 0 asCharacter] - whileFalse: [ - stream nextPut: char. - index := index + 1 - ]. - str := stream contents. - strings addLast: str. - str size = 0 - ] whileFalse. - ^strings! ! -!ExternalData methodsFor: 'private' stamp: 'ar 11/21/1999 14:23'! - setHandle: aHandle type: aType - handle := aHandle. - type := aType.! ! -!ExternalData class methodsFor: 'class initialization' stamp: 'ar 8/14/2006 23:18'! - compileFields - "Ensure proper initialization of ExternalType when first loading" - ExternalType initialize. - ^super compileFields! ! -!ExternalData class methodsFor: 'field definition' stamp: 'ar 1/27/2000 01:23'! - fields - "ExternalData defineFields" - "Note: The definition is for completeness only. - ExternalData is treated specially by the VM." - ^#(nil 'void*')! ! -!ExternalData class methodsFor: 'instance creation' stamp: 'ar 12/2/1999 14:57'! - fromHandle: aHandle type: aType - "Create a pointer to the given type" - "ExternalData fromHandle: ExternalAddress new type: ExternalType float" - ^self basicNew setHandle: aHandle type: aType! ! -!ExternalData class methodsFor: 'class initialization' stamp: 'jmv 8/21/2013 17:38'! - initialize - self compileFields! ! -!ExternalData class methodsFor: 'instance creation' stamp: 'ar 11/22/1999 04:28'! - new - "You better not..." - ^self shouldNotImplement! ! -!ExternalType methodsFor: 'converting' stamp: 'ar 12/2/1999 16:41'! - asNonPointerType - "convert the receiver into a non pointer type" - self isPointerType - ifTrue:[^referencedType] - ifFalse:[^self]! ! -!ExternalType methodsFor: 'converting' stamp: 'ar 12/2/1999 16:40'! - asPointerType - "convert the receiver into a pointer type" - self isPointerType - ifTrue:[^self] - ifFalse:[^referencedType]! ! -!ExternalType methodsFor: 'converting' stamp: 'eem 2/16/2016 12:57'! - asPointerType: pointerSize - "convert the receiver into a pointer type" - | type | - type := self asPointerType. - ^type pointerSize = pointerSize - ifTrue: [type] - ifFalse: - [type copy pointerSize: pointerSize; yourself]! ! -!ExternalType methodsFor: 'accessing' stamp: 'ar 12/2/1999 14:15'! - atomicType - ^(self headerWord bitAnd: FFIAtomicTypeMask) >> FFIAtomicTypeShift! ! -!ExternalType methodsFor: 'accessing' stamp: 'ar 12/2/1999 14:11'! - byteSize - "Return the size in bytes of this type" - ^self headerWord bitAnd: FFIStructSizeMask! ! -!ExternalType methodsFor: 'accessing' stamp: 'ar 12/2/1999 14:29'! - compiledSpec - "Return the compiled spec of the receiver" - ^compiledSpec! ! -!ExternalType methodsFor: 'private' stamp: 'ar 12/2/1999 15:19'! - compiledSpec: aWordArray - compiledSpec := aWordArray.! ! -!ExternalType methodsFor: 'private' stamp: 'ar 12/2/1999 20:34'! - embeddedSpecWithSize: typeSize - "Return a compiled spec for embedding in a new compiled spec." - | spec header | - spec := self compiledSpec copy. - header := spec at: 1. - header := (header bitAnd: FFIStructSizeMask bitInvert32) bitOr: typeSize. - spec at: 1 put: header. - (self isStructureType and:[self isPointerType not]) - ifTrue:[spec := spec copyWith: self class structureSpec]. - ^spec! ! -!ExternalType methodsFor: 'private' stamp: 'ar 1/27/2000 00:22'! - externalTypeName - ^'ExternalType ', (AtomicTypeNames at: self atomicType), ' asPointerType'! ! -!ExternalType methodsFor: 'private' stamp: 'ar 12/2/1999 14:11'! -headerWord - "Return the compiled header word" - ^compiledSpec at: 1! ! -!ExternalType methodsFor: 'testing' stamp: 'ar 12/2/1999 20:27'! - isAtomic - "Return true if the receiver describes a built-in type" - ^self headerWord anyMask: FFIFlagAtomic! ! -!ExternalType methodsFor: 'testing' stamp: 'ar 12/2/1999 14:14'! - isIntegerType - "Return true if the receiver is a built-in integer type" - | type | - type := self atomicType. - ^type > FFITypeBool and:[type <= FFITypeUnsignedLongLong]! ! -!ExternalType methodsFor: 'testing' stamp: 'ar 1/27/2000 00:29'! - isPointerType - "Return true if the receiver represents a pointer type" - ^self isStructureType not and:[self headerWord anyMask: FFIFlagPointer]! ! -!ExternalType methodsFor: 'testing' stamp: 'ar 12/2/1999 14:15'! - isSigned - "Return true if the receiver is a signed type. - Note: Only useful for integer types." - ^self atomicType anyMask: 1! ! -!ExternalType methodsFor: 'testing' stamp: 'ar 12/2/1999 14:15'! - isStructureType - "Return true if the receiver represents a structure type" - ^self headerWord anyMask: FFIFlagStructure! ! -!ExternalType methodsFor: 'testing' stamp: 'ar 11/18/1999 18:28'! - isUnsigned - "Return true if the receiver is an unsigned type. - Note: Only useful for integer types." - ^self isSigned not! ! -!ExternalType methodsFor: 'testing' stamp: 'ar 12/2/1999 14:16'! - isVoid - "Return true if the receiver describes a plain 'void' type" - ^self isAtomic and:[self atomicType = 0]! ! -!ExternalType methodsFor: 'private' stamp: 'ar 12/2/1999 20:30'! - newReferentClass: aClass - "The class I'm referencing has changed. Update my spec." - referentClass := aClass. - self isPointerType ifTrue:[^self]. "for pointers only the referentClass changed" - referentClass == nil ifTrue:[ - "my class has been removed - make me 'struct { void }'" - compiledSpec := WordArray with: (FFIFlagStructure). - ] ifFalse:[ - "my class has been changed - update my compiledSpec" - compiledSpec := referentClass compiledSpec. - ].! ! -!ExternalType methodsFor: 'accessing' stamp: 'eem 2/16/2016 12:43'! - pointerSize - "Answer the pointer size of the receiver, if specified." - ^pointerSize! ! -!ExternalType methodsFor: 'private' stamp: 'eem 2/16/2016 13:02'! - pointerSize: anInteger - | spec | - pointerSize := anInteger. - (((spec := compiledSpec at: 1) anyMask: FFIFlagPointer) - and: [(spec bitAnd: FFIStructSizeMask) ~= anInteger]) ifTrue: - [compiledSpec := compiledSpec shallowCopy. - compiledSpec at: 1 put: (spec bitClear: FFIStructSizeMask) + anInteger]! ! -!ExternalType methodsFor: 'printing' stamp: 'eem 2/16/2016 10:29'! - printAtomicType: spec on: aStream - self assert: (spec anyMask: FFIFlagAtomic). - aStream nextPutAll: (#( 'void' 'unsigned char' 'unsigned char' 'signed char' - 'unsigned short' 'short' 'unsigned long' 'long' - 'unsigned long long' 'long long' 'char' 'signed char' - 'float' 'double') at: ((spec bitAnd: FFIAtomicTypeMask) bitShift: FFIAtomicTypeShift negated) + 1). - aStream space. - (spec anyMask: FFIFlagPointer) ifTrue: - [aStream nextPut: $*]! ! -!ExternalType methodsFor: 'printing' stamp: 'ar 12/2/1999 17:02'! - printOn: aStream - referentClass == nil - ifTrue:[aStream nextPutAll: (AtomicTypeNames at: self atomicType)] - ifFalse:[aStream nextPutAll: referentClass name]. - self isPointerType ifTrue:[aStream nextPut: $*].! ! -!ExternalType methodsFor: 'printing' stamp: 'jmv 12/18/2016 18:29:56'! - printStructureFieldStartingAt: initialSpecIndex withName: name inClass: structureClass on: aStream indent: indent - "Print the structure's field starting at initialSpecIndex and answer the index in compiledSpec of the subsequent type." - | spec subStructureClassBinding | - aStream tab: indent. - spec := compiledSpec at: initialSpecIndex. - (spec anyMask: FFIFlagAtomic) ifTrue: - [self printAtomicType: spec on: aStream. - aStream nextPutAll: (name ifNotNil: [name] ifNil: ['foo']). - ^initialSpecIndex + 1]. - subStructureClassBinding := (structureClass >> name) literals detect: - [:l| l isVariableBinding and: [l value inheritsFrom: ExternalStructure]]. - (spec bitClear: FFIStructSizeMask) = FFIFlagStructure ifTrue: - [| next | - next := initialSpecIndex + 1. - aStream nextPutAll: 'struct {'. - subStructureClassBinding value fields withIndexDo: - [:tuple :i| - aStream newLine. - next := self printStructureFieldStartingAt: next - withName: tuple first - inClass: subStructureClassBinding value - on: aStream - indent: indent + 1. - aStream nextPut: $;]. - aStream newLine; tab: indent; nextPut: $}. - name ifNotNil: [aStream space; nextPutAll: name]. - self assert: (next - 1 = compiledSpec size or: [(compiledSpec at: next) = FFIFlagStructure]). - ^next <= compiledSpec size ifTrue: [next + 1] ifFalse: [next]]. - self assert: (spec anyMask: FFIFlagPointer). - aStream nextPutAll: 'struct '; nextPutAll: subStructureClassBinding value name; nextPutAll: ' *'; nextPutAll: name. - ^initialSpecIndex + 1! ! -!ExternalType methodsFor: 'printing' stamp: 'jmv 12/18/2016 18:30:07'! - printTypedefOn: s - s nextPutAll: 'typedef '. - (compiledSpec first bitClear: FFIStructSizeMask) = FFIFlagStructure - ifTrue: - [| next | - next := 2. - s nextPutAll: 'struct {'. - referentClass fields withIndexDo: - [:tuple :i| - s newLine. - next := self printStructureFieldStartingAt: next - withName: tuple first - inClass: referentClass - on: s - indent: 1. - s nextPut: $;]. - s newLine; nextPutAll: '} '. - self assert: (next - 1 = compiledSpec size or: [(compiledSpec at: next) = FFIFlagStructure])] - ifFalse: - [self printAtomicType: compiledSpec first on: s]. - s nextPutAll: (referentClass ifNotNil: [referentClass name] ifNil: ['foo'])! ! -!ExternalType methodsFor: 'private' stamp: 'eem 2/16/2016 13:16'! - readFieldAt: byteOffset - "Answer a string defining the accessor to an entity of the receiver type starting at the given byte offset. - Private. Used for field definition only." - self isPointerType ifTrue: - [| accessor | - accessor := self pointerSize caseOf: { - [nil] -> [#pointerAt:]. - [4] -> [#shortPointerAt:]. - [8] -> [#longPointerAt:] }. - ^String streamContents: - [:s| - referentClass - ifNil: - [s nextPutAll: '^ExternalData fromHandle: (handle ', accessor, ' '; - print: byteOffset; - nextPutAll: ') type: ExternalType '; - nextPutAll: (AtomicTypeNames at: self atomicType); - nextPutAll: ' asPointerType'] - ifNotNil: - [s nextPutAll: '^'; - print: referentClass; - nextPutAll: ' fromHandle: (handle ', accessor, ' '; - print: byteOffset; - nextPut: $)]]]. - - self isAtomic ifFalse: "structure type" - [^String streamContents:[:s| - s nextPutAll:'^'; - print: referentClass; - nextPutAll:' fromHandle: (handle structAt: '; - print: byteOffset; - nextPutAll:' length: '; - print: self byteSize; - nextPutAll:')']]. - - "Atomic non-pointer types" - ^String streamContents: - [:s| - s nextPutAll:'^handle '; - nextPutAll: (AtomicSelectors at: self atomicType); - space; print: byteOffset].! ! -!ExternalType methodsFor: 'accessing' stamp: 'ar 12/2/1999 14:11'! - referentClass - "Return the class specifying the receiver" - ^referentClass! ! -!ExternalType methodsFor: 'private' stamp: 'ar 12/2/1999 16:41'! - setReferencedType: aType - referencedType := aType! ! -!ExternalType methodsFor: 'printing' stamp: 'nice 5/21/2006 21:40'! - storeOn: aStream - referentClass == nil - ifTrue:[aStream nextPutAll: ExternalType name; space; nextPutAll: (AtomicTypeNames at: self atomicType)] - ifFalse:[aStream nextPut: $(; nextPutAll: ExternalType name; space; nextPutAll: #structTypeNamed:; space; store: referentClass name; nextPut: $)]. - self isPointerType ifTrue: [aStream space; nextPutAll: #asPointer].! ! -!ExternalType methodsFor: 'printing' stamp: 'eem 2/16/2016 10:05'! - typedef - ^String streamContents: [:s| self printTypedefOn: s]! ! -!ExternalType methodsFor: 'private' stamp: 'eem 2/16/2016 13:16'! - writeFieldAt: byteOffset with: valueName - "Answer a string defining the accessor to an entity of the receiver type starting at the given byte offset. - Private. Used for field definition only." - self isPointerType ifTrue: - [| accessor | - accessor := self pointerSize caseOf: { - [nil] -> [#pointerAt:]. - [4] -> [#shortPointerAt:]. - [8] -> [#longPointerAt:] }. - ^String streamContents: - [:s| - s nextPutAll:'handle ', accessor, ' '; - print: byteOffset; - nextPutAll:' put: '; - nextPutAll: valueName; - nextPutAll:' getHandle.']]. - - self isAtomic ifFalse:[ - ^String streamContents:[:s| - s nextPutAll:'handle structAt: '; - print: byteOffset; - nextPutAll:' put: '; - nextPutAll: valueName; - nextPutAll:' getHandle'; - nextPutAll:' length: '; - print: self byteSize; - nextPutAll:'.']]. - - ^String streamContents:[:s| - s nextPutAll:'handle '; - nextPutAll: (AtomicSelectors at: self atomicType); - space; print: byteOffset; - nextPutAll:' put: '; - nextPutAll: valueName].! ! -!ExternalType class methodsFor: 'private' stamp: 'jmv 12/26/2016 17:09:18'! - atomicTypeNamed: aString - | n | - n _ aString. - n = 'size_t' ifTrue: [ - n _ Smalltalk wordSize = 8 ifTrue: [ 'ulonglong' ] ifFalse: [ 'ulong' ]]. - ^AtomicTypes at: n ifAbsent:[nil]! ! -!ExternalType class methodsFor: 'type constants' stamp: 'ar 12/2/1999 16:56'! - bool - ^AtomicTypes at: 'bool'! ! -!ExternalType class methodsFor: 'type constants' stamp: 'ar 11/20/1999 17:29'! - byte - "byte defaults to unsigned byte" - ^self unsignedByte! ! -!ExternalType class methodsFor: 'type constants' stamp: 'ar 11/20/1999 17:29'! - char - "char defaults to unsigned char" - ^self unsignedChar! ! -!ExternalType class methodsFor: 'housekeeping' stamp: 'ar 12/2/1999 18:00'! - cleanupUnusedTypes - "ExternalType cleanupUnusedTypes" - | value | - StructTypes keys do:[:key| - value := StructTypes at: key. - value == nil ifTrue:[StructTypes removeKey: key ifAbsent:[]]].! ! -!ExternalType class methodsFor: 'type constants' stamp: 'ar 12/2/1999 16:56'! - double - ^AtomicTypes at: 'double'! ! -!ExternalType class methodsFor: 'type constants' stamp: 'ar 12/2/1999 16:57'! - float - ^AtomicTypes at: 'float'! ! -!ExternalType class methodsFor: 'private' stamp: 'ar 12/2/1999 16:50'! - forceTypeNamed: aString - ^self newTypeNamed: aString force: true! ! -!ExternalType class methodsFor: 'class initialization' stamp: 'ar 12/2/1999 16:15'! - initialize - "ExternalType initialize" - self initializeFFIConstants. - self initializeDefaultTypes.! ! -!ExternalType class methodsFor: 'class initialization' stamp: 'jmv 12/26/2016 15:02:13'! - initializeAtomicTypes - "ExternalType initialize" - | atomicType byteSize type typeName | - #( - "name atomic id byte size" - ('void' 0 0) - ('bool' 1 1) - ('byte' 2 1) - ('sbyte' 3 1) - ('ushort' 4 2) - ('short' 5 2) - ('ulong' 6 4) - ('long' 7 4) - ('ulonglong' 8 8) - ('longlong' 9 8) - ('char' 10 1) - ('schar' 11 1) - ('float' 12 4) - ('double' 13 8) - ) do:[:typeSpec| | compiled | - typeName := typeSpec first. - atomicType := typeSpec second. - byteSize := typeSpec third. - compiled := WordArray with: ((byteSize bitOr: FFIFlagAtomic) bitOr: - (atomicType bitShift: FFIAtomicTypeShift)). - type := (AtomicTypes at: typeName). - type compiledSpec: compiled. - compiled := WordArray with: ((self pointerSpec bitOr: FFIFlagAtomic) bitOr: - (atomicType bitShift: FFIAtomicTypeShift)). - type asPointerType compiledSpec: compiled. - ].! ! -!ExternalType class methodsFor: 'class initialization' stamp: 'ar 12/2/1999 17:01'! - initializeDefaultTypes - "ExternalType initialize" - | type pointerType | - AtomicTypes = nil ifTrue:[ - "Create new atomic types and setup the dictionaries" - AtomicTypes := Dictionary new. - StructTypes := WeakValueDictionary new. - AtomicTypeNames valuesDo:[:k| - type := self basicNew. - pointerType := self basicNew. - AtomicTypes at: k put: type. - type setReferencedType: pointerType. - pointerType setReferencedType: type. - ]. - ]. - self initializeAtomicTypes. - self initializeStructureTypes. - "AtomicTypes := nil"! ! -!ExternalType class methodsFor: 'class initialization' stamp: 'ar 8/14/2006 23:13'! - initializeFFIConstants - "ExternalType initialize" - FFIConstants initialize. "ensure proper initialization" - AtomicTypeNames := IdentityDictionary new. - AtomicSelectors := IdentityDictionary new. - AtomicTypeNames - at: FFITypeVoid put: 'void'; - at: FFITypeBool put: 'bool'; - at: FFITypeUnsignedByte put: 'byte'; - at: FFITypeSignedByte put: 'sbyte'; - at: FFITypeUnsignedShort put: 'ushort'; - at: FFITypeSignedShort put: 'short'; - at: FFITypeUnsignedInt put: 'ulong'; - at: FFITypeSignedInt put: 'long'; - at: FFITypeUnsignedLongLong put: 'ulonglong'; - at: FFITypeSignedLongLong put: 'longlong'; - at: FFITypeUnsignedChar put: 'char'; - at: FFITypeSignedChar put: 'schar'; - at: FFITypeSingleFloat put: 'float'; - at: FFITypeDoubleFloat put: 'double'; - yourself. - - AtomicSelectors - at: FFITypeVoid put: #voidAt:; - at: FFITypeBool put: #booleanAt:; - at: FFITypeUnsignedByte put: #unsignedByteAt:; - at: FFITypeSignedByte put: #signedByteAt:; - at: FFITypeUnsignedShort put: #unsignedShortAt:; - at: FFITypeSignedShort put: #signedShortAt:; - at: FFITypeUnsignedInt put: #unsignedLongAt:; - at: FFITypeSignedInt put: #signedLongAt:; - at: FFITypeUnsignedLongLong put: #unsignedLongLongAt:; - at: FFITypeSignedLongLong put: #signedLongLongAt:; - at: FFITypeUnsignedChar put: #unsignedCharAt:; - at: FFITypeSignedChar put: #signedCharAt:; - at: FFITypeSingleFloat put: #floatAt:; - at: FFITypeDoubleFloat put: #doubleAt:; - yourself! ! -!ExternalType class methodsFor: 'class initialization' stamp: 'ar 3/22/2007 20:14'! - initializeStructureTypes - "ExternalType initialize" - | referentClass pointerType | - self cleanupUnusedTypes. - StructTypes keysAndValuesDo:[:referentName :type| - referentClass := (Smalltalk at: referentName ifAbsent:[nil]). - (referentClass isBehavior and:[ - referentClass includesBehavior: ExternalStructure]) - ifFalse:[referentClass := nil]. - type compiledSpec: - (WordArray with: self structureSpec). - type newReferentClass: referentClass. - pointerType := type asPointerType. - pointerType compiledSpec: - (WordArray with: self pointerSpec). - pointerType newReferentClass: referentClass. - ].! ! -!ExternalType class methodsFor: 'type constants' stamp: 'ar 11/22/1999 13:10'! - long - ^self signedLong! ! -!ExternalType class methodsFor: 'instance creation' stamp: 'ar 1/26/2000 14:58'! - new - "Use either the type constants or #externalType for creating external types" - ^self shouldNotImplement! ! -!ExternalType class methodsFor: 'private' stamp: 'ar 1/26/2000 21:41'! - newTypeNamed: aString force: aBool - | sym type referentClass pointerType | - sym := aString asSymbol. - type := StructTypes at: aString ifAbsent:[nil]. - type == nil ifFalse:[^type]. - referentClass := Smalltalk at: sym ifAbsent:[nil]. - (referentClass isBehavior and:[referentClass includesBehavior: ExternalStructure]) - ifFalse:[referentClass := nil]. - "If we don't have a referent class and are not forced to create a type get out" - (referentClass == nil and:[aBool not]) ifTrue:[^nil]. - type := self basicNew compiledSpec: - (WordArray with: self structureSpec). - pointerType := self basicNew compiledSpec: - (WordArray with: self pointerSpec). - type setReferencedType: pointerType. - pointerType setReferencedType: type. - type newReferentClass: referentClass. - pointerType newReferentClass: referentClass. - StructTypes at: sym put: type. - ^type! ! -!ExternalType class methodsFor: 'housekeeping' stamp: 'ar 12/2/1999 17:58'! - noticeModificationOf: aClass - "A subclass of ExternalStructure has been redefined. - Clean out any obsolete references to its type." - | type | - aClass isBehavior ifFalse:[^nil]. "how could this happen?" - aClass withAllSubclassesDo:[:cls| - type := StructTypes at: cls name ifAbsent:[nil]. - type == nil ifFalse:[ - type newReferentClass: cls. - type asPointerType newReferentClass: cls]. - ].! ! -!ExternalType class methodsFor: 'housekeeping' stamp: 'ar 12/2/1999 17:59'! - noticeRemovalOf: aClass - "A subclass of ExternalStructure is being removed. - Clean out any obsolete references to its type." - | type | - type := StructTypes at: aClass name ifAbsent:[nil]. - type == nil ifFalse:[ - type newReferentClass: nil. - type asPointerType newReferentClass: nil]. -! ! -!ExternalType class methodsFor: 'housekeeping' stamp: 'ar 12/2/1999 16:14'! - noticeRenamingOf: aClass from: oldName to: newName - "An ExternalStructure has been renamed from oldName to newName. - Keep our type names in sync." - | type | - type := StructTypes at: oldName ifAbsent:[nil]. - type == nil ifFalse:[StructTypes at: newName put: type]. - StructTypes removeKey: oldName ifAbsent:[].! ! -!ExternalType class methodsFor: 'private' stamp: 'jmv 12/20/2016 11:41:12'! - pointerSpec - ^(Smalltalk wordSize bitOr: FFIFlagPointer)! ! -!ExternalType class methodsFor: 'type constants' stamp: 'ar 11/28/1999 23:43'! - sbyte - ^self signedByte! ! -!ExternalType class methodsFor: 'type constants' stamp: 'ar 11/28/1999 23:43'! - schar - ^self signedChar! ! -!ExternalType class methodsFor: 'type constants' stamp: 'ar 11/20/1999 17:26'! - short - ^self signedShort! ! -!ExternalType class methodsFor: 'type constants' stamp: 'ar 12/2/1999 16:57'! - signedByte - ^AtomicTypes at: 'sbyte'! ! -!ExternalType class methodsFor: 'type constants' stamp: 'ar 12/2/1999 16:57'! - signedChar - ^AtomicTypes at: 'schar'! ! -!ExternalType class methodsFor: 'type constants' stamp: 'ar 12/2/1999 16:57'! - signedLong - ^AtomicTypes at: 'long'! ! -!ExternalType class methodsFor: 'type constants' stamp: 'ar 12/2/1999 16:57'! - signedLongLong - ^AtomicTypes at: 'longlong'! ! -!ExternalType class methodsFor: 'type constants' stamp: 'ar 12/2/1999 16:57'! - signedShort - ^AtomicTypes at: 'short'! ! -!ExternalType class methodsFor: 'type constants' stamp: 'ar 12/2/1999 16:57'! - string - ^(AtomicTypes at: 'char') asPointerType! ! -!ExternalType class methodsFor: 'private' stamp: 'ar 12/2/1999 16:48'! - structTypeNamed: aSymbol - aSymbol == nil ifTrue:[^nil]. - ^self newTypeNamed: aSymbol force: false! ! -!ExternalType class methodsFor: 'private' stamp: 'ar 12/2/1999 20:34'! - structureSpec - ^FFIFlagStructure! ! -!ExternalType class methodsFor: 'type constants' stamp: 'ar 11/28/1999 23:44'! - ulong - ^self unsignedLong! ! -!ExternalType class methodsFor: 'type constants' stamp: 'ar 12/2/1999 16:57'! - unsignedByte - ^AtomicTypes at: 'byte'! ! -!ExternalType class methodsFor: 'type constants' stamp: 'ar 12/2/1999 16:58'! - unsignedChar - ^AtomicTypes at: 'char'! ! -!ExternalType class methodsFor: 'type constants' stamp: 'ar 12/2/1999 16:58'! - unsignedLong - ^AtomicTypes at: 'ulong'! ! -!ExternalType class methodsFor: 'type constants' stamp: 'ar 12/2/1999 16:58'! - unsignedLongLong - ^AtomicTypes at: 'ulonglong'! ! -!ExternalType class methodsFor: 'type constants' stamp: 'ar 12/2/1999 16:58'! -unsignedShort - ^AtomicTypes at: 'ushort'! ! -!ExternalType class methodsFor: 'type constants' stamp: 'ar 11/28/1999 23:44'! - ushort - ^self unsignedShort! ! -!ExternalType class methodsFor: 'type constants' stamp: 'ar 12/2/1999 16:58'! - void - ^AtomicTypes at: 'void'! ! - -ExternalAddress initialize! - -FFIConstants initialize! - -ExternalObject initialize! - -ExternalFunction initialize! - -ExternalStructure initialize! - -ExternalData initialize! - -ExternalType initialize! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/Packages/FFI.pck.st----! - -'From Cuis 4.2 of 25 July 2013 [latest update: #2713] on 2 April 2016 at 10:51:26.959666 pm'! - -'Description Please enter a description for this package.'! - -Object subclass: #ExtendedClipboardInterface - instanceVariableNames: 'clipboard' - classVariableNames: 'Current WinClipboardTypes' - poolDictionaries: '' - category: 'ExtendedClipboard'! - -!classDefinition: #ExtendedClipboardInterface category: #ExtendedClipboard! -Object subclass: #ExtendedClipboardInterface - instanceVariableNames: 'clipboard' - classVariableNames: 'Current WinClipboardTypes' - poolDictionaries: '' - category: 'ExtendedClipboard'! - -ExtendedClipboardInterface class - instanceVariableNames: ''! - -!classDefinition: 'ExtendedClipboardInterface class' category: #ExtendedClipboard! -ExtendedClipboardInterface class - instanceVariableNames: ''! - -ExtendedClipboardInterface subclass: #ExtendedClipboardMacInterface - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ExtendedClipboard'! - -!classDefinition: #ExtendedClipboardMacInterface category: #ExtendedClipboard! -ExtendedClipboardInterface subclass: #ExtendedClipboardMacInterface - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ExtendedClipboard'! - -ExtendedClipboardMacInterface class - instanceVariableNames: ''! - -!classDefinition: 'ExtendedClipboardMacInterface class' category: #ExtendedClipboard! -ExtendedClipboardMacInterface class - instanceVariableNames: ''! - -ExtendedClipboardInterface subclass: #ExtendedClipboardUnixInterface - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ExtendedClipboard'! - -!classDefinition: #ExtendedClipboardUnixInterface category: #ExtendedClipboard! -ExtendedClipboardInterface subclass: #ExtendedClipboardUnixInterface - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ExtendedClipboard'! - -ExtendedClipboardUnixInterface class - instanceVariableNames: ''! - -!classDefinition: 'ExtendedClipboardUnixInterface class' category: #ExtendedClipboard! -ExtendedClipboardUnixInterface class - instanceVariableNames: ''! - -ExtendedClipboardInterface subclass: #ExtendedClipboardWinInterface - instanceVariableNames: 'lastSeenSequenceNr' - classVariableNames: '' - poolDictionaries: '' - category: 'ExtendedClipboard'! - -!classDefinition: #ExtendedClipboardWinInterface category: #ExtendedClipboard! -ExtendedClipboardInterface subclass: #ExtendedClipboardWinInterface - instanceVariableNames: 'lastSeenSequenceNr' - classVariableNames: '' - poolDictionaries: '' - category: 'ExtendedClipboard'! - -ExtendedClipboardWinInterface class - instanceVariableNames: ''! - -!classDefinition: 'ExtendedClipboardWinInterface class' category: #ExtendedClipboard! -ExtendedClipboardWinInterface class - instanceVariableNames: ''! - -ExternalStructure subclass: #Win32Bitmap - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ExtendedClipboard-Win32'! - -!classDefinition: #Win32Bitmap category: #'ExtendedClipboard-Win32'! -ExternalStructure subclass: #Win32Bitmap - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ExtendedClipboard-Win32'! - -Win32Bitmap class - instanceVariableNames: ''! - -!classDefinition: 'Win32Bitmap class' category: #'ExtendedClipboard-Win32'! -Win32Bitmap class - instanceVariableNames: ''! - -TestCase subclass: #ExtendedClipboardTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ExtendedClipboard-tests'! - -!classDefinition: #ExtendedClipboardTest category: #'ExtendedClipboard-tests'! -TestCase subclass: #ExtendedClipboardTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ExtendedClipboard-tests'! - -ExtendedClipboardTest class - instanceVariableNames: ''! - -!classDefinition: 'ExtendedClipboardTest class' category: #'ExtendedClipboard-tests'! -ExtendedClipboardTest class - instanceVariableNames: ''! -!Form methodsFor: '*extendedClipboard-Win32' stamp: 'mir 2/16/2008 19:52'! - fromWin32BitMap: bitmapBits - 0 to: self height-1 do: [:y | - 1 to: self width do: [:x | - bits integerAt: (y*width) + x put: ((bitmapBits unsignedLongAt: 1 + (y*width*4) + ((x-1) *4)) bitOr: 16rFF000000) - ]]. -! ! -!Form class methodsFor: '*extendedClipboard-Win32' stamp: 'mir 2/15/2008 10:24'! - fromWin32BitMap: bitmap bits: bits - | form | - form := self extent: bitmap bmWidth@bitmap bmHeight depth: bitmap bmBitsPixel. - form fromWin32BitMap: bits. - ^form! ! -!ExtendedClipboardInterface methodsFor: 'private' stamp: 'jmv 1/18/2011 23:45'! - addClipboardData: data dataFormat: aFormat - clipboard = 0 ifTrue: [ - "Should never happen!!" - self error: 'broken clipboard'. - ^self]. - self primAddClipboardData: clipboard data: data dataFormat: aFormat! ! -!ExtendedClipboardInterface methodsFor: 'testing' stamp: 'jmv 11/12/2013 08:50'! - canImportRTF - ^Smalltalk includesKey: #RTFTextBuilder! ! -!ExtendedClipboardInterface methodsFor: 'testing' stamp: 'jmv 1/18/2011 23:44'! - canStore - "Store into clipboard implemented on most platforms. - Answer false in subclasses that can't store into clipboard." - ^clipboard ~= 0! ! -!ExtendedClipboardInterface methodsFor: 'private' stamp: 'jmv 1/18/2011 14:47'! - clearClipboard - clipboard = 0 ifTrue: [^self]. - ^ self primClearClipboard: clipboard! ! -!ExtendedClipboardInterface methodsFor: 'private' stamp: 'jmv 1/18/2011 14:47'! - createClipboard - clipboard = 0 ifTrue: [^self]. - ^ self primCreateClipboard! ! -!ExtendedClipboardInterface methodsFor: 'object from raw data' stamp: 'jmv 12/21/2013 09:30'! - fromBMPBytes: bytes - ^ (BMPReadWriter onBinaryStream: bytes readStream) nextImage! ! -!ExtendedClipboardInterface methodsFor: 'object from raw data' stamp: 'jmv 12/21/2013 09:30'! - fromJPEGBytes: bytes - ^ (JPEGReadWriter2 onBinaryStream: bytes readStream) nextImage! ! -!ExtendedClipboardInterface methodsFor: 'object from raw data' stamp: 'jmv 1/26/2011 10:25'! - fromMacRomanBytes: bytes - ^ (bytes collect: [ :c | Character macRomanToLatin1: c]) asString! ! -!ExtendedClipboardInterface methodsFor: 'object from raw data' stamp: 'jmv 12/21/2013 09:31'! - fromPNGBytes: bytes - ^ (PNGReadWriter onBinaryStream: bytes readStream) nextImage! ! -!ExtendedClipboardInterface methodsFor: 'object from raw data' stamp: 'jmv 3/17/2011 09:23'! - fromRefStreamBytes: bytes - ^ ReferenceStream unStream: bytes! ! -!ExtendedClipboardInterface methodsFor: 'object from raw data' stamp: 'jmv 1/26/2011 10:24'! - fromTIFFBytes: bytes - ^ (TIFFReadWriter on: bytes readStream) nextImage! ! -!ExtendedClipboardInterface methodsFor: 'object from raw data' stamp: 'jmv 2/25/2013 14:34'! - fromUTF8Bytes: bytes - - ^(String fromUtf8: bytes hex: false trimLastNull: true) withCuisLineEndings! ! -!ExtendedClipboardInterface methodsFor: 'private' stamp: 'jmv 1/18/2011 14:47'! - getClipboardFormat: formatNumber - clipboard = 0 ifTrue: [^nil]. - ^ self primGetClipboardFormat: clipboard formatNumber: formatNumber! ! -!ExtendedClipboardInterface methodsFor: 'initialization' stamp: 'tak 5/16/2007 12:03'! - initialize - clipboard := [self createClipboard] on: Error do: [:ex | clipboard := 0]! ! -!ExtendedClipboardInterface methodsFor: 'testing' stamp: 'jmv 11/10/2013 09:46'! - isOperational - "Can be redefined if needed. - We should check that ClipboardExtendedPlugin is available and operational." - ^clipboard ~= 0! ! -!ExtendedClipboardInterface methodsFor: 'system primitives' stamp: 'JSM 5/6/2006 16:32'! - primAddClipboardData: clipboard data: data dataFormat: aFormat - - - ^ self primitiveFailed.! ! -!ExtendedClipboardInterface methodsFor: 'system primitives' stamp: 'JSM 5/6/2006 16:32'! - primClearClipboard: clipboard - - - ^ self primitiveFailed. -! ! -!ExtendedClipboardInterface methodsFor: 'system primitives' stamp: 'JSM 5/6/2006 18:53'! - primCreateClipboard - - ^ self primitiveFailed. -! ! -!ExtendedClipboardInterface methodsFor: 'system primitives' stamp: 'JSM 5/6/2006 16:33'! - primGetClipboardFormat: clipboard formatNumber: formatNumber - - - ^ self primitiveFailed. -! ! -!ExtendedClipboardInterface methodsFor: 'system primitives' stamp: 'JSM 5/6/2006 16:33'! - primReadClipboardData: clipboard format: format - - . - ^ self primitiveFailed. -! ! -!ExtendedClipboardInterface methodsFor: 'private' stamp: 'jmv 1/18/2011 14:47'! - readClipboardData: format - ^clipboard = 0 ifFalse: [ - self primReadClipboardData: clipboard format: format ]! ! -!ExtendedClipboardInterface methodsFor: 'api - retrieve' stamp: 'jmv 1/19/2011 15:17'! - retrieveId - ^self subclassResponsibility! ! -!ExtendedClipboardInterface methodsFor: 'api - retrieve' stamp: 'jmv 1/26/2011 10:09'! - retrieveObject - ^self subclassResponsibility! ! -!ExtendedClipboardInterface methodsFor: 'api - store' stamp: 'jmv 1/26/2011 10:07'! - storeForm: aForm id: otherString - "I presume the order is: most preferred format first, least desirable format last. - Cuis object id at the end." - ^self subclassResponsibility! ! -!ExtendedClipboardInterface methodsFor: 'api - store' stamp: 'jmv 1/26/2011 10:07'! - storeString: aString id: otherString - "I presume the order is: most preferred format first, least desirable format last. - Cuis object id at the end." - ^self subclassResponsibility! ! -!ExtendedClipboardInterface methodsFor: 'api - store' stamp: 'jmv 3/17/2011 09:35'! - storeText: aText id: otherString - "I presume the order is: most preferred format first, least desirable format last. - Cuis object id is usually at the end, but don't include it if we include a streamed representation." - - ^self subclassResponsibility! ! -!ExtendedClipboardInterface class methodsFor: 'accessing' stamp: 'jmv 1/11/2011 13:59'! - current - | platform | - Current ifNil: [ - platform _ Smalltalk platformName. - Current _ platform = 'unix' - ifTrue: [ ExtendedClipboardUnixInterface new ] - ifFalse: [ - platform = 'Win32' - ifTrue: [ ExtendedClipboardWinInterface new ] - ifFalse: [ ExtendedClipboardMacInterface new ]]]. - ^ Current.! ! -!ExtendedClipboardInterface class methodsFor: 'class initialization' stamp: 'mir 5/10/2006 19:12'! - initialize - "ExtendedClipboardInterface initialize" - Current := nil. - Smalltalk - addToStartUpList: self after: nil; - addToShutDownList: self after: nil.! ! -!ExtendedClipboardInterface class methodsFor: 'system startup' stamp: 'JSM 5/6/2006 15:33'! - shutDown: quitting -! ! -!ExtendedClipboardInterface class methodsFor: 'system startup' stamp: 'JSM 5/6/2006 15:33'! - startUp: resuming - "The image is either being newly started (resuming is true), or it's just been snapshotted" - - Current := nil. - self current.! ! -!ExtendedClipboardMacInterface methodsFor: 'private' stamp: 'jmv 1/18/2011 15:56'! - readPrimAvailableFormats - | i availableFormats formatData | - availableFormats _ OrderedCollection new: 10. - i _ 1. - [ - formatData _ self getClipboardFormat: i. - formatData notNil ] whileTrue: [ - availableFormats add: formatData. - i _ i + 1 ]. - ^ availableFormats! ! -!ExtendedClipboardMacInterface methodsFor: 'api - retrieve' stamp: 'jmv 1/19/2011 14:55'! - retrieveId - | bytes formats | - formats _ self readPrimAvailableFormats. - (formats includes: 'cuis-id') - ifTrue: [ - bytes _ self readClipboardData: 'cuis-id'. - ^ bytes asString ]. - ^ nil! ! -!ExtendedClipboardMacInterface methodsFor: 'api - retrieve' stamp: 'jmv 11/12/2013 08:53'! - retrieveObject - | conversion bytes | - self readPrimAvailableFormats do: [ :format | - conversion _ format caseOf: { - "Unformatted plain text" - [ 'public.utf8-plain-text' ] -> [ #fromUTF8Bytes: ]. - [ 'com.apple.traditional-mac-plain-text' ] -> [ #fromMacRomanBytes: ]. - "Bitmap images (not sure if all of them are actually used in this platform)" - [ 'public.png' ] -> [ #fromPNGBytes: ]. - [ 'public.tiff' ] -> [ #fromTIFFBytes: ]. - [ 'public.jpeg' ] -> [ #fromJPEGBytes: ]. - [ 'public.bmp' ] -> [ #fromBMPBytes: ]. - [ 'cuis-refStreamed' ] -> [ #fromRefStreamBytes: ]. - "Rich text" - [ 'public.rtf' ] -> [ self canImportRTF ifTrue: [#fromRTFBytes:] ] "Only if package RTFImporting is loaded" - } otherwise: [ nil ]. - conversion ifNotNil: [ - bytes _ self readClipboardData: format. - ^self perform: conversion with: bytes ] - ]. - ^nil "Could not read any of the available formats"! ! -!ExtendedClipboardMacInterface methodsFor: 'api - store' stamp: 'jmv 1/26/2011 10:07'! - storeForm: aForm id: otherString - "I presume the order is: most preferred format first, least desirable format last. - Cuis object id at the end." - self clearClipboard. - self addClipboardData: (PNGReadWriter bytesFor: aForm) dataFormat: 'public.png'. - " - Could be done in addition... - self addClipboardData: (JPEGReadWriter2 bytesFor: aForm) dataFormat: 'public.jpeg' - " - self addClipboardData: otherString dataFormat: 'cuis-id'! ! -!ExtendedClipboardMacInterface methodsFor: 'api - store' stamp: 'jmv 2/14/2013 12:21'! - storeString: aString id: otherString - "I presume the order is: most preferred format first, least desirable format last. - Cuis object id at the end." - self clearClipboard. - self - addClipboardData: aString asUtf8 - dataFormat: 'public.utf8-plain-text'. - "Could be done in addition (maybe with cr line ending?) - self - addClipboardData: (aString asByteArray collect: [ :c | Character latin1ToMacRoman: c ]) - dataFormat: 'com.apple.traditional-mac-plain-text'. - " - self addClipboardData: otherString dataFormat: 'cuis-id'! ! -!ExtendedClipboardMacInterface methodsFor: 'api - store' stamp: 'jmv 11/13/2013 07:59'! - storeText: aText id: otherString - "I presume the order is: most preferred format first, least desirable format last. - Cuis object id is usually at the end, but don't include it if we include a streamed representation." - self clearClipboard. - - "SmartRefStream handles class changes, but a little testing shows stuff is twice as big, and takes 20 times more time to generate" - self addClipboardData: (ReferenceStream streamedRepresentationOf: aText) dataFormat: 'cuis-refStreamed'. - - "RTF format - #rtfString might not be loaded (Package RTFExporting)" - [ self addClipboardData: aText rtfString dataFormat: 'public.rtf' ] on: MessageNotUnderstood do: []. - - "Just the string" - self - addClipboardData: aText asString asUtf8 - dataFormat: 'public.utf8-plain-text'. - - "If we store a streamed representation, don't store the id. In these cases, we prefer rebuilding the object, regardless of - whether it is present in memory (because we stored it in the clipboard) or not (because some other Cuis image did it)" - self addClipboardData: otherString dataFormat: 'cuis-id'! ! -!ExtendedClipboardUnixInterface methodsFor: 'private' stamp: 'jmv 1/18/2011 15:56'! - readPrimAvailableFormats - | i availableFormats formatData | - availableFormats _ OrderedCollection new: 10. - i _ 1. - [ - formatData _ self getClipboardFormat: i. - formatData notNil ] whileTrue: [ - availableFormats add: formatData. - i _ i + 1 ]. - ^ availableFormats! ! -!ExtendedClipboardUnixInterface methodsFor: 'api - retrieve' stamp: 'jmv 1/19/2011 15:17'! - retrieveId - | bytes formats | - formats _ self readPrimAvailableFormats. - (formats includes: 'cuis-id') - ifTrue: [ - bytes _ self readClipboardData: 'cuis-id'. - ^ bytes asString ]. - ^ nil! ! -!ExtendedClipboardUnixInterface methodsFor: 'api - retrieve' stamp: 'jmv 3/17/2011 09:08'! - retrieveObject - | conversion bytes | - self readPrimAvailableFormats do: [ :format | - conversion _ format caseOf: { - "Unformatted plain text" - [ 'UTF8_STRING' ] -> [ #fromUTF8Bytes: ]. - "Bitmap images (not sure if all of them are actually used in this platform)" - [ 'image/png' ] -> [ #fromPNGBytes: ]. - [ 'image/tiff' ] -> [ #fromTIFFBytes: ]. - [ 'image/jpeg' ] -> [ #fromJPEGBytes: ]. - [ 'image/bmp' ] -> [ #fromBMPBytes: ]. - [ 'cuis-refStreamed' ] -> [ #fromRefStreamBytes: ]. - "Rich text" -" [ '????rtf' ] -> [ #fromRTFBytes: ]" - } otherwise: [ nil ]. - conversion ifNotNil: [ - bytes _ self readClipboardData: format. - ^self perform: conversion with: bytes ] - ]. - ^nil "Could not read any of the available formats"! ! -!ExtendedClipboardUnixInterface methodsFor: 'api - store' stamp: 'jmv 1/26/2011 10:07'! - storeForm: aForm id: otherString - "I presume the order is: most preferred format first, least desirable format last. - Cuis object id at the end." - self clearClipboard. - self addClipboardData: (PNGReadWriter bytesFor: aForm) dataFormat: 'image/png'. - self addClipboardData: otherString dataFormat: 'cuis-id'! ! -!ExtendedClipboardUnixInterface methodsFor: 'api - store' stamp: 'jmv 2/14/2013 12:21'! - storeString: aString id: otherString - "I presume the order is: most preferred format first, least desirable format last. - Cuis object id at the end." - self clearClipboard. - self - addClipboardData: aString asUtf8 - dataFormat: 'UTF8_STRING'. - self addClipboardData: otherString dataFormat: 'cuis-id'! ! -!ExtendedClipboardUnixInterface methodsFor: 'api - store' stamp: 'jmv 2/14/2013 12:21'! - storeText: aText id: otherString - "I presume the order is: most preferred format first, least desirable format last. - Cuis object id is usually at the end, but don't include it if we include a streamed representation." - self clearClipboard. - - "SmartRefStream handles class changes, but a little testing shows stuff is twice as big, and takes 20 times more time to generate" - self addClipboardData: (ReferenceStream streamedRepresentationOf: aText) dataFormat: 'cuis-refStreamed'. - - "onvert text to RTF and implement" - " - self - addClipboardData: aText rtfString - dataFormat: '????' - " - self - addClipboardData: aText asString asUtf8 - dataFormat: 'UTF8_STRING'. - - "If we store a streamed representation, don't store the id. In these cases, we prefer rebuilding the object, regardless of - whether it is present in memory (because we stored it in the clipboard) or not (because some other Cuis image did it)" - self addClipboardData: otherString dataFormat: 'cuis-id'! ! -!ExtendedClipboardWinInterface methodsFor: 'private' stamp: 'jmv 7/27/2015 15:44'! - addClipboardData: data dataFormat: aFormat - self canStore ifFalse: [ - self error: 'Writing to Extended Clipboard not implemented in Windows' ]! ! -!ExtendedClipboardWinInterface methodsFor: 'system calls' stamp: 'jmv 11/10/2013 09:55'! - attemptCloseClipboard - "ExtendedClipboardWinInterface new closeClipboard" - "http://msdn.microsoft.com/library/default.asp?url=/library/en-us/winui/winui/windowsuserinterface/dataexchange/clipboard/clipboardreference/clipboardfunctions/getclipboardformatname.asp - -BOOL CloseClipboard( - - VOID -);" - ! ! -!ExtendedClipboardWinInterface methodsFor: 'testing' stamp: 'jmv 1/18/2011 22:27'! - canStore - "Store into clipboard not yet implemented on Windows" - ^false! ! -!ExtendedClipboardWinInterface methodsFor: 'private' stamp: 'jmv 7/27/2015 15:45'! - clearClipboard - self canStore ifFalse: [ - self error: 'Writing to Extended Clipboard not implemented in Windows' ]! ! -!ExtendedClipboardWinInterface methodsFor: 'system calls' stamp: 'mir 2/14/2008 23:56'! - clipboardAvailable: format - "ExtendedClipboardWinInterface new clipboardAvailable: 8" - - "http://msdn2.microsoft.com/en-us/library/ms649047(VS.85).aspx - -BOOL IsClipboardFormatAvailable( - UINT format -);" - - ^self externalCallFailed! ! -!ExtendedClipboardWinInterface methodsFor: 'system calls' stamp: 'mir 5/10/2006 17:56'! - closeClipboard - "ExtendedClipboardWinInterface new closeClipboard" - "http://msdn.microsoft.com/library/default.asp?url=/library/en-us/winui/winui/windowsuserinterface/dataexchange/clipboard/clipboardreference/clipboardfunctions/getclipboardformatname.asp - -BOOL CloseClipboard( - - VOID -);" - - ^self externalCallFailed! ! -!ExtendedClipboardWinInterface methodsFor: 'private' stamp: 'jmv 7/27/2015 15:46'! - createClipboard - "Not on Windows" - clipboard := 0! ! -!ExtendedClipboardWinInterface methodsFor: 'system calls' stamp: 'mir 5/10/2006 16:09'! - format: format - "ExtendedClipboardInterface format: 0" - - "http://msdn.microsoft.com/library/default.asp?url=/library/en-us/winui/winui/windowsuserinterface/dataexchange/clipboard/clipboardreference/clipboardfunctions/emptyclipboard.asp - -UINT EnumClipboardFormats( - - UINT format -);" - - ^self externalCallFailed! ! -!ExtendedClipboardWinInterface methodsFor: 'system calls' stamp: 'mir 2/15/2008 00:09'! - getBitmapBitsFrom: handle count: nrOfBytes buffer: buffer - "ExtendedClipboardWinInterface new getBitmapBitsFrom: handle count: nrOfBytes buffer: buffer" - - "http://msdn2.microsoft.com/en-us/library/ms532332(VS.85).aspx - -LONG GetBitmapBits( - HBITMAP hbmp, // handle to bitmap - LONG cbBuffer, // number of bytes to copy - LPVOID lpvBits // buffer to receive bits -);" - - ^self externalCallFailed! ! -!ExtendedClipboardWinInterface methodsFor: 'system calls' stamp: 'mir 5/10/2006 17:57'! - getClipboardData: format - "ExtendedClipboardWinInterface new getClipboardData: 1" - - "http://msdn.microsoft.com/library/default.asp?url=/library/en-us/winui/winui/windowsuserinterface/dataexchange/clipboard/clipboardreference/clipboardfunctions/getclipboarddata.asp - -HANDLE GetClipboardData( - - UINT uFormat -);" - - ^self externalCallFailed! ! -!ExtendedClipboardWinInterface methodsFor: 'system calls' stamp: 'mir 2/14/2008 23:38'! - getClipboardDataHandle: format - "ExtendedClipboardWinInterface new getBMPClipboardData: 2" - - "http://msdn2.microsoft.com/en-us/library/ms649039.aspx - -HANDLE GetClipboardData( - - UINT uFormat -);" - - ^self externalCallFailed! ! -!ExtendedClipboardWinInterface methodsFor: 'system calls' stamp: 'mir 5/10/2006 16:09'! - getClipboardFormatName: format name: string size: stringSize - "ExtendedClipboardInterface getClipboardFormatName: 49171 name: (String new:128) size: 128" - - "http://msdn.microsoft.com/library/default.asp?url=/library/en-us/winui/winui/windowsuserinterface/dataexchange/clipboard/clipboardreference/clipboardfunctions/getclipboardformatname.asp - -int GetClipboardFormatName( - - UINT format, - LPTSTR lpszFormatName, - int cchMaxCount -);" - - ^self externalCallFailed! ! -!ExtendedClipboardWinInterface methodsFor: 'system calls' stamp: 'mir 1/23/2008 12:13'! - getClipboardSequenceNumber - - "http://msdn2.microsoft.com/en-us/library/ms649042(VS.85).aspx - - DWORD GetClipboardSequenceNumber( - VOID -);" - - ^self externalCallFailed! ! -!ExtendedClipboardWinInterface methodsFor: 'system calls' stamp: 'mir 2/14/2008 21:57'! - getObject: handle bufferSize: bufferSize buffer: buffer - "ExtendedClipboardWinInterface new getObject: handle bufferSize buffer: buffer" - - "http://msdn2.microsoft.com/en-us/library/ms533268.aspx - -int GetObject( - HGDIOBJ hgdiobj, // handle to graphics object - int cbBuffer, // size of buffer for object information - LPVOID lpvObject // buffer for object information -);" - - ^self externalCallFailed! ! -!ExtendedClipboardWinInterface methodsFor: 'testing' stamp: 'mir 1/23/2008 12:07'! - hasExternalClipboardChanged - | prevSequenceNr | - prevSequenceNr := self lastSeenSequenceNr. - self - openClipboard; - closeClipboard. - ^prevSequenceNr < self lastSeenSequenceNr! ! -!ExtendedClipboardWinInterface methodsFor: 'testing' stamp: 'jmv 11/10/2013 09:56'! - isOperational - "Check that we can access the Wiindows clipboard." - | result | - result _ self openClipboard: 0. - self attemptCloseClipboard. - ^result ~= 0! ! -!ExtendedClipboardWinInterface methodsFor: 'private' stamp: 'mir 1/23/2008 12:11'! - lastSeenSequenceNr - ^lastSeenSequenceNr ifNil: [lastSeenSequenceNr := -1].! ! -!ExtendedClipboardWinInterface methodsFor: 'system calls' stamp: 'jmv 3/13/2012 12:33'! - listFormats - "ExtendedClipboardWinInterface new listFormats" - - | currentFormat result data buffer | - result := self openClipboard: 0. - result = 0 - ifTrue: [^self halt]. - currentFormat := 0. - [ - '' print. - currentFormat := self format: currentFormat. - Transcript show: 'format: '; show: currentFormat printString; newLine. - (#(1 16 7 49510 49355) includes: currentFormat) - ifTrue: [ - data := self getClipboardData: currentFormat. - Transcript show: data fromCString; newLine]. -" 13 = currentFormat - ifTrue: [ - data := self getClipboardData: currentFormat. - Transcript show: data fromUTF16String; newLine]." - - currentFormat > 18 - ifTrue: [ - buffer := ByteArray new:128. - self getClipboardFormatName: currentFormat name: buffer size: buffer size. - Transcript show: 'buffer: '; show: buffer; newLine]. - currentFormat ~= 0 - ] whileTrue. - self closeClipboard! ! -!ExtendedClipboardWinInterface methodsFor: 'system calls' stamp: 'mir 1/23/2008 12:11'! - openClipboard - | result | - result := self openClipboard: 0. - lastSeenSequenceNr := self getClipboardSequenceNumber. - result = 0 - ifTrue: [self halt]. -! ! -!ExtendedClipboardWinInterface methodsFor: 'system calls' stamp: 'jmv 11/10/2013 09:51'! - openClipboard: windowOwner - "ExtendedClipboardInterface openClipboard: 0" - - "http://msdn.microsoft.com/library/default.asp?url=/library/en-us/winui/winui/windowsuserinterface/dataexchange/clipboard/clipboardreference/clipboardfunctions/openclipboard.asp - -BOOL OpenClipboard( - - HWND hWndNewOwner -);" - - "^self externalCallFailed" - ^0! ! -!ExtendedClipboardWinInterface methodsFor: 'private' stamp: 'jmv 1/18/2011 14:47'! - readClipboardData: format - | answer | - self openClipboard. - [ - answer _ (self getClipboardData: format) fromCString - ] ensure: [ self closeClipboard ]. - ^ answer! ! -!ExtendedClipboardWinInterface methodsFor: 'private' stamp: 'jmv 1/18/2011 15:56'! - readPrimAvailableFormats - | i availableFormats | - availableFormats _ OrderedCollection new: 10. - i _ 0. - self openClipboard. - [ - i _ self format: i. - i ~= 0 ] whileTrue: [ - availableFormats add: i ]. - self closeClipboard. - ^ availableFormats! ! -!ExtendedClipboardWinInterface methodsFor: 'api - retrieve' stamp: 'jmv 1/19/2011 15:18'! - retrieveId - "Implement!!" - ^nil! ! -!ExtendedClipboardWinInterface methodsFor: 'api - retrieve' stamp: 'jmv 11/12/2013 08:53'! - retrieveObject - | conversion formatName bytes | - conversion _ nil. - self readPrimAvailableFormats do: [ :format | - - "Bitmap images " - format = 2 ifTrue: [ - ^ self retrieveWindowsBMPForm ]. "CF_BITMAP: read using FFI" - - "Unformatted plain text" - format = 1 ifTrue: [ - conversion _ #fromUTF8Bytes: ]. "'text/plain' CF_TEXT" - "Check for other formats such as 13 'text/unicode' CF_UNICODETEXT if needed" - - - format > 18 ifTrue: [ - formatName := ByteArray new:128. - self getClipboardFormatName: format name: formatName size: formatName size. - (formatName asString beginsWith: 'Rich Text Format') ifTrue: [ - self canImportRTF ifTrue: [conversion _ #fromRTFBytes:] ]. "text/rtf" "Only if package RTFImporting is loaded" - ]. - - "Work on this when we do copy to clipboard" - "[ 'cuis-refStreamed' ] -> [ #fromRefStreamBytes: ]" - - conversion ifNotNil: [ - bytes _ self readClipboardData: format. - ^self perform: conversion with: bytes ] - ]. - ^ nil "Could not read any of the available formats"! ! -!ExtendedClipboardWinInterface methodsFor: 'private' stamp: 'jmv 1/18/2011 16:05'! - retrieveWindowsBMPForm - | handle bitmap result form bitBuffer byteCount | - self openClipboard. - [handle := self getClipboardDataHandle: 2 " 'image/*' CF_BITMAP"] - ensure: [self closeClipboard]. - - "Check handle" - "Allocate buffer for bitmap structure" - bitmap := Win32Bitmap new. - result := self getObject: handle bufferSize: Win32Bitmap byteSize buffer: bitmap. - byteCount := bitmap bmWidth * bitmap bmHeight * bitmap bmBitsPixel / 8. - bitBuffer := ByteArray new: byteCount. - result := self getBitmapBitsFrom: handle count: byteCount buffer: bitBuffer. - - result = 0 - ifTrue: [ - ^nil]. - form := Form fromWin32BitMap: bitmap bits: bitBuffer. - ^form! ! -!ExtendedClipboardWinInterface methodsFor: 'private' stamp: 'jmv 1/18/2011 16:05'! - retrieveWindowsDIBForm - | handle bitmap result form bitBuffer | - self openClipboard. - [handle := self getClipboardDataHandle: 8 "CF_DIB"] - ensure: [self closeClipboard]. - - "Check handle" - "Allocate buffer for bitmap structure" -" result := self getObject: handle bufferSize: Win32BitmapInfoHeader byteSize buffer: nil." -self halt. - bitmap := Win32Bitmap new. - result := self getObject: handle bufferSize: Win32Bitmap byteSize buffer: bitmap. - bitBuffer := ExternalAddress allocate: bitmap bmWidth*bitmap bmHeight*bitmap bmBitsPixel. - bitmap bmBits: (ExternalData fromHandle: bitBuffer type: ExternalType byte asPointerType). - result := self getObject: handle bufferSize: Win32Bitmap byteSize buffer: bitmap. - - result = 0 - ifTrue: [ - bitBuffer free. - self halt. - ^nil]. - form := Form fromWin32BitMap: bitmap. - bitBuffer free. - ^form! ! -!ExtendedClipboardWinInterface methodsFor: 'system calls' stamp: 'mir 6/18/2006 18:47'! - setClipboardFormat: format data: data - "ExtendedClipboardInterface current setClipboardFormat: 1 data: ('clipboard test' copyWith: 0 asCharacter) " - - "http://msdn.microsoft.com/library/default.asp?url=/library/en-us/winui/winui/windowsuserinterface/dataexchange/clipboard/clipboardreference/clipboardfunctions/setclipboarddata.asp - -HANDLE SetClipboardData( - - UINT uFormat, - HANDLE hMem -);" - - ^self externalCallFailed! ! -!ExtendedClipboardWinInterface methodsFor: 'system calls' stamp: 'jmv 1/13/2011 11:16'! - setClipboardString: string - "ExtendedClipboardInterface current setClipboardString: 'clipboard test'" - - "http://msdn.microsoft.com/library/default.asp?url=/library/en-us/winui/winui/windowsuserinterface/dataexchange/clipboard/clipboardreference/clipboardfunctions/setclipboarddata.asp - -HANDLE SetClipboardData( - - UINT uFormat, - HANDLE hMem -);" -" Warning (jmv) This code from Sophie gives a compilation error in Cuis. Learn why. - -" - ^self externalCallFailed! ! -!ExtendedClipboardWinInterface methodsFor: 'api - store' stamp: 'jmv 1/26/2011 10:07'! - storeForm: aForm id: otherString - "I presume the order is: most preferred format first, least desirable format last. - Cuis object id at the end." - "To be implemented" - self halt! ! -!ExtendedClipboardWinInterface methodsFor: 'api - store' stamp: 'jmv 1/26/2011 10:07'! - storeString: aString id: otherString - "I presume the order is: most preferred format first, least desirable format last. - Cuis object id at the end." - "To be implemented" - self halt! ! -!ExtendedClipboardWinInterface methodsFor: 'api - store' stamp: 'jmv 3/17/2011 09:35'! - storeText: aText id: otherString - "To be implemented (store both as string and as RTF)" - "I presume the order is: most preferred format first, least desirable format last. - Cuis object id is usually at the end, but don't include it if we include a streamed representation." - self halt! ! -!Win32Bitmap methodsFor: 'accessing' stamp: 'mir 2/14/2008 22:47'! - bmBits - "This method was automatically generated" - ^ExternalData fromHandle: (handle pointerAt: 21) type: ExternalType byte asPointerType! ! -!Win32Bitmap methodsFor: 'accessing' stamp: 'mir 2/14/2008 22:47'! - bmBits: anObject - "This method was automatically generated" - handle pointerAt: 21 put: anObject getHandle.! ! -!Win32Bitmap methodsFor: 'accessing' stamp: 'mir 2/14/2008 22:47'! - bmBitsPixel - "This method was automatically generated" - ^handle signedShortAt: 19! ! -!Win32Bitmap methodsFor: 'accessing' stamp: 'mir 2/14/2008 22:47'! - bmBitsPixel: anObject - "This method was automatically generated" - handle signedShortAt: 19 put: anObject! ! -!Win32Bitmap methodsFor: 'accessing' stamp: 'mir 2/14/2008 22:47'! - bmHeight - "This method was automatically generated" - ^handle signedLongAt: 9! ! -!Win32Bitmap methodsFor: 'accessing' stamp: 'mir 2/14/2008 22:47'! - bmHeight: anObject - "This method was automatically generated" - handle signedLongAt: 9 put: anObject! ! -!Win32Bitmap methodsFor: 'accessing' stamp: 'mir 2/14/2008 22:47'! - bmPlanes - "This method was automatically generated" - ^handle signedShortAt: 17! ! -!Win32Bitmap methodsFor: 'accessing' stamp: 'mir 2/14/2008 22:47'! - bmPlanes: anObject - "This method was automatically generated" - handle signedShortAt: 17 put: anObject! ! -!Win32Bitmap methodsFor: 'accessing' stamp: 'mir 2/14/2008 22:47'! - bmType - "This method was automatically generated" - ^handle signedLongAt: 1! ! -!Win32Bitmap methodsFor: 'accessing' stamp: 'mir 2/14/2008 22:47'! - bmType: anObject - "This method was automatically generated" - handle signedLongAt: 1 put: anObject! ! -!Win32Bitmap methodsFor: 'accessing' stamp: 'mir 2/14/2008 22:47'! - bmWidth - "This method was automatically generated" - ^handle signedLongAt: 5! ! -!Win32Bitmap methodsFor: 'accessing' stamp: 'mir 2/14/2008 22:47'! - bmWidth: anObject - "This method was automatically generated" - handle signedLongAt: 5 put: anObject! ! -!Win32Bitmap methodsFor: 'accessing' stamp: 'mir 2/14/2008 22:47'! - bmWidthBytes - "This method was automatically generated" - ^handle signedLongAt: 13! ! -!Win32Bitmap methodsFor: 'accessing' stamp: 'mir 2/14/2008 22:47'! - bmWidthBytes: anObject - "This method was automatically generated" - handle signedLongAt: 13 put: anObject! ! -!Win32Bitmap class methodsFor: 'instance creation' stamp: 'mir 2/14/2008 22:47'! - fields - "Win32TagBitmap defineFields" - - - ^ #( - #(#bmType 'long') - #(#bmWidth 'long') - #(#bmHeight 'long') - #(#bmWidthBytes 'long') - #(#bmPlanes 'short') - #(#bmBitsPixel 'short') - #(#bmBits 'byte*') - ) - -"typedef struct tagBITMAP { - LONG bmType; - LONG bmWidth; - LONG bmHeight; - LONG bmWidthBytes; - WORD bmPlanes; - WORD bmBitsPixel; - LPVOID bmBits; -} BITMAP" -! ! -!ExtendedClipboardTest methodsFor: 'testing' stamp: 'jmv 7/14/2015 22:57'! - testStar16BitToAndFromImageClipboard - " - ExtendedClipboardTest new testStar16BitToAndFromImageClipboard - " - | form form1 form2 | - form _ (Display copy: (10@10 extent: 60@40)) asFormOfDepth: 16. - - "This will use a refStreamed object" - Clipboard default storeObject: form. - form2 _ Clipboard default retrieveObject. - form1 _ form copy. - form1 addDeltasFrom: form2. - self assert: form1 primCountBits = 0 description: 'Form copyPasted from Clipboard appears to be bad.'. - - "This will also test storing and retrieving PNG data from platform Clipboard, and PNG conversion" - ExtendedClipboardInterface current - clearClipboard; - addClipboardData: (PNGReadWriter bytesFor: form) dataFormat: 'public.png'. - form2 _ Clipboard default retrieveObject. - form1 _ form copy. - form1 addDeltasFrom: form2. - self assert: form1 primCountBits = 0 description: 'Form copyPasted from Clipboard appears to be bad.'.! ! -!ExtendedClipboardTest methodsFor: 'testing' stamp: 'jmv 4/2/2016 14:40'! - testStar8BitToAndFromImageClipboard - " - ExtendedClipboardTest new testStar8BitToAndFromImageClipboard - " - | form form1 form2 | - self assert: Clipboard default extendedClipboardInterface canStore description: 'Extended Clipboard cant store'. - - form _ (Display copy: (10@10 extent: 60@40)) asFormOfDepth: 8. - - "This will use a refStreamed object" - Clipboard default storeObject: form. - form2 _ Clipboard default retrieveObject. - self assert: (form2 is: #Form). - form1 _ form copy. - form1 addDeltasFrom: form2. - self assert: form1 primCountBits = 0 description: 'Form copyPasted from Clipboard appears to be bad.'. - - "This will also test storing and retrieving PNG data from platform Clipboard, and PNG conversion" - ExtendedClipboardInterface current - clearClipboard; - addClipboardData: (PNGReadWriter bytesFor: form) dataFormat: 'public.png'. - form2 _ Clipboard default retrieveObject. - form1 _ form copy. - form1 addDeltasFrom: form2. - self assert: form1 primCountBits = 0 description: 'Form copyPasted from Clipboard appears to be bad.'.! ! -!ExtendedClipboardTest methodsFor: 'testing' stamp: 'jmv 7/14/2015 22:57'! - testStarToAndFromImageClipboard - " - ExtendedClipboardTest new testStarToAndFromImageClipboard - " - | form form1 form2 | - form _ Display copy: (10@10 extent: 60@40). - - "This will use a refStreamed object" - Clipboard default storeObject: form. - form2 _ Clipboard default retrieveObject. - form1 _ form copy. - form1 addDeltasFrom: form2. - self assert: form1 primCountBits = 0 description: 'Form copyPasted from Clipboard appears to be bad.'. - - "This will also test storing and retrieving PNG data from platform Clipboard, and PNG conversion" - ExtendedClipboardInterface current - clearClipboard; - addClipboardData: (PNGReadWriter bytesFor: form) dataFormat: 'public.png'. - form2 _ Clipboard default retrieveObject. - form1 _ form copy. - form1 addDeltasFrom: form2. - self assert: form1 primCountBits = 0 description: 'Form copyPasted from Clipboard appears to be bad.'.! ! - -ExtendedClipboardInterface initialize! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/Packages/ExtendedClipboard.pck.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3022] on 3 January 2017 at 9:51:30 pm'! - -'Description Please enter a description for this package.'! - -Error subclass: #RTFException - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFimporting'! - -!classDefinition: #RTFException category: #RTFimporting! -Error subclass: #RTFException - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFimporting'! - -RTFException class - instanceVariableNames: ''! - -!classDefinition: 'RTFException class' category: #RTFimporting! -RTFException class - instanceVariableNames: ''! - -Object subclass: #RTFChunkScanner - instanceVariableNames: 'destX lastIndex xTable rightEdge stopConditions prevIndex bufferStream buffer chunk' - classVariableNames: 'BufferStream ScannerTable XTable' - poolDictionaries: '' - category: 'RTFimporting'! - -!classDefinition: #RTFChunkScanner category: #RTFimporting! -Object subclass: #RTFChunkScanner - instanceVariableNames: 'destX lastIndex xTable rightEdge stopConditions prevIndex bufferStream buffer chunk' - classVariableNames: 'BufferStream ScannerTable XTable' - poolDictionaries: '' - category: 'RTFimporting'! - -RTFChunkScanner class - instanceVariableNames: ''! - -!classDefinition: 'RTFChunkScanner class' category: #RTFimporting! -RTFChunkScanner class - instanceVariableNames: ''! - -Object subclass: #RTFColorDef - instanceVariableNames: 'red green blue' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFimporting'! - -!classDefinition: #RTFColorDef category: #RTFimporting! -Object subclass: #RTFColorDef - instanceVariableNames: 'red green blue' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFimporting'! - -RTFColorDef class - instanceVariableNames: ''! - -!classDefinition: 'RTFColorDef class' category: #RTFimporting! -RTFColorDef class - instanceVariableNames: ''! - -Object subclass: #RTFFontInfo - instanceVariableNames: 'name num family charset cpg' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFimporting'! - -!classDefinition: #RTFFontInfo category: #RTFimporting! -Object subclass: #RTFFontInfo - instanceVariableNames: 'name num family charset cpg' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFimporting'! - -RTFFontInfo class - instanceVariableNames: ''! - -!classDefinition: 'RTFFontInfo class' category: #RTFimporting! -RTFFontInfo class - instanceVariableNames: ''! - -Object subclass: #RTFParser - instanceVariableNames: 'tokenizer state builder' - classVariableNames: 'HandleMessages' - poolDictionaries: '' - category: 'RTFimporting'! - -!classDefinition: #RTFParser category: #RTFimporting! -Object subclass: #RTFParser - instanceVariableNames: 'tokenizer state builder' - classVariableNames: 'HandleMessages' - poolDictionaries: '' - category: 'RTFimporting'! - -RTFParser class - instanceVariableNames: ''! - -!classDefinition: 'RTFParser class' category: #RTFimporting! -RTFParser class - instanceVariableNames: ''! - -Object subclass: #RTFParserDestination - instanceVariableNames: 'block type' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFimporting'! - -!classDefinition: #RTFParserDestination category: #RTFimporting! -Object subclass: #RTFParserDestination - instanceVariableNames: 'block type' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFimporting'! - -RTFParserDestination class - instanceVariableNames: ''! - -!classDefinition: 'RTFParserDestination class' category: #RTFimporting! -RTFParserDestination class - instanceVariableNames: ''! - -Object subclass: #RTFParserState - instanceVariableNames: 'stack destination context' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFimporting'! - -!classDefinition: #RTFParserState category: #RTFimporting! -Object subclass: #RTFParserState - instanceVariableNames: 'stack destination context' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFimporting'! - -RTFParserState class - instanceVariableNames: ''! - -!classDefinition: 'RTFParserState class' category: #RTFimporting! -RTFParserState class - instanceVariableNames: ''! - -Object subclass: #RTFStylesheet - instanceVariableNames: 'additive name type num style basedon' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFimporting'! - -!classDefinition: #RTFStylesheet category: #RTFimporting! -Object subclass: #RTFStylesheet - instanceVariableNames: 'additive name type num style basedon' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFimporting'! - -RTFStylesheet class - instanceVariableNames: ''! - -!classDefinition: 'RTFStylesheet class' category: #RTFimporting! -RTFStylesheet class - instanceVariableNames: ''! - -RTFStylesheet subclass: #RTFSophieStylesheet - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFimporting'! - -!classDefinition: #RTFSophieStylesheet category: #RTFimporting! -RTFStylesheet subclass: #RTFSophieStylesheet - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFimporting'! - -RTFSophieStylesheet class - instanceVariableNames: ''! - -!classDefinition: 'RTFSophieStylesheet class' category: #RTFimporting! -RTFSophieStylesheet class - instanceVariableNames: ''! - -Object subclass: #RTFTextBuilder - instanceVariableNames: 'textConverter colorTable fontTable styleTable skipNextCharacters defaultSkipNextCharacters textStream currentFgColor fontFamilyName fontPointSize bold italic underline align stateStack firstIndent leftIndent rightIndent spaceBefore spaceAfter' - classVariableNames: 'CodePageConverterTable' - poolDictionaries: '' - category: 'RTFimporting'! - -!classDefinition: #RTFTextBuilder category: #RTFimporting! -Object subclass: #RTFTextBuilder - instanceVariableNames: 'textConverter colorTable fontTable styleTable skipNextCharacters defaultSkipNextCharacters textStream currentFgColor fontFamilyName fontPointSize bold italic underline align stateStack firstIndent leftIndent rightIndent spaceBefore spaceAfter' - classVariableNames: 'CodePageConverterTable' - poolDictionaries: '' - category: 'RTFimporting'! - -RTFTextBuilder class - instanceVariableNames: ''! - -!classDefinition: 'RTFTextBuilder class' category: #RTFimporting! -RTFTextBuilder class - instanceVariableNames: ''! - -Object subclass: #RTFTextConverter - instanceVariableNames: 'acceptingEncodings' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFimporting'! - -!classDefinition: #RTFTextConverter category: #RTFimporting! -Object subclass: #RTFTextConverter - instanceVariableNames: 'acceptingEncodings' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFimporting'! - -RTFTextConverter class - instanceVariableNames: ''! - -!classDefinition: 'RTFTextConverter class' category: #RTFimporting! -RTFTextConverter class - instanceVariableNames: ''! - -RTFTextConverter subclass: #RTFLatin1TextConverter - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFimporting'! - -!classDefinition: #RTFLatin1TextConverter category: #RTFimporting! -RTFTextConverter subclass: #RTFLatin1TextConverter - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFimporting'! - -RTFLatin1TextConverter class - instanceVariableNames: ''! - -!classDefinition: 'RTFLatin1TextConverter class' category: #RTFimporting! -RTFLatin1TextConverter class - instanceVariableNames: ''! - -RTFTextConverter subclass: #RTFMappingUnicodeTextConverter - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFimporting'! - -!classDefinition: #RTFMappingUnicodeTextConverter category: #RTFimporting! -RTFTextConverter subclass: #RTFMappingUnicodeTextConverter - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFimporting'! - -RTFMappingUnicodeTextConverter class - instanceVariableNames: ''! - -!classDefinition: 'RTFMappingUnicodeTextConverter class' category: #RTFimporting! -RTFMappingUnicodeTextConverter class - instanceVariableNames: ''! - -RTFMappingUnicodeTextConverter subclass: #RTFCP1250UnicodeTextConverter - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFimporting'! - -!classDefinition: #RTFCP1250UnicodeTextConverter category: #RTFimporting! -RTFMappingUnicodeTextConverter subclass: #RTFCP1250UnicodeTextConverter - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFimporting'! - -RTFCP1250UnicodeTextConverter class - instanceVariableNames: ''! - -!classDefinition: 'RTFCP1250UnicodeTextConverter class' category: #RTFimporting! -RTFCP1250UnicodeTextConverter class - instanceVariableNames: ''! - -RTFMappingUnicodeTextConverter subclass: #RTFCP1251UnicodeTextConverter - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFimporting'! - -!classDefinition: #RTFCP1251UnicodeTextConverter category: #RTFimporting! -RTFMappingUnicodeTextConverter subclass: #RTFCP1251UnicodeTextConverter - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFimporting'! - -RTFCP1251UnicodeTextConverter class - instanceVariableNames: ''! - -!classDefinition: 'RTFCP1251UnicodeTextConverter class' category: #RTFimporting! -RTFCP1251UnicodeTextConverter class - instanceVariableNames: ''! - -RTFMappingUnicodeTextConverter subclass: #RTFCP1252UnicodeTextConverter - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFimporting'! - -!classDefinition: #RTFCP1252UnicodeTextConverter category: #RTFimporting! -RTFMappingUnicodeTextConverter subclass: #RTFCP1252UnicodeTextConverter - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFimporting'! - -RTFCP1252UnicodeTextConverter class - instanceVariableNames: ''! - -!classDefinition: 'RTFCP1252UnicodeTextConverter class' category: #RTFimporting! -RTFCP1252UnicodeTextConverter class - instanceVariableNames: ''! - -RTFMappingUnicodeTextConverter subclass: #RTFMacRomanUnicodeTextConverter - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFimporting'! - -!classDefinition: #RTFMacRomanUnicodeTextConverter category: #RTFimporting! -RTFMappingUnicodeTextConverter subclass: #RTFMacRomanUnicodeTextConverter - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFimporting'! - -RTFMacRomanUnicodeTextConverter class - instanceVariableNames: ''! - -!classDefinition: 'RTFMacRomanUnicodeTextConverter class' category: #RTFimporting! -RTFMacRomanUnicodeTextConverter class - instanceVariableNames: ''! - -Object subclass: #RTFToken - instanceVariableNames: 'type content arg' - classVariableNames: 'DefaultArgs' - poolDictionaries: '' - category: 'RTFimporting'! - -!classDefinition: #RTFToken category: #RTFimporting! -Object subclass: #RTFToken - instanceVariableNames: 'type content arg' - classVariableNames: 'DefaultArgs' - poolDictionaries: '' - category: 'RTFimporting'! - -RTFToken class - instanceVariableNames: ''! - -!classDefinition: 'RTFToken class' category: #RTFimporting! -RTFToken class - instanceVariableNames: ''! - -Object subclass: #RTFTokenizer - instanceVariableNames: 'stream buffer chunkBuffer last next afterNext afterAfter' - classVariableNames: 'ControlSymbolSet EndOfKeywordSet' - poolDictionaries: '' - category: 'RTFimporting'! - -!classDefinition: #RTFTokenizer category: #RTFimporting! -Object subclass: #RTFTokenizer - instanceVariableNames: 'stream buffer chunkBuffer last next afterNext afterAfter' - classVariableNames: 'ControlSymbolSet EndOfKeywordSet' - poolDictionaries: '' - category: 'RTFimporting'! - -RTFTokenizer class - instanceVariableNames: ''! - -!classDefinition: 'RTFTokenizer class' category: #RTFimporting! -RTFTokenizer class - instanceVariableNames: ''! - -Object subclass: #RTFUnicode - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFimporting'! - -!classDefinition: #RTFUnicode category: #RTFimporting! -Object subclass: #RTFUnicode - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFimporting'! - -RTFUnicode class - instanceVariableNames: ''! - -!classDefinition: 'RTFUnicode class' category: #RTFimporting! -RTFUnicode class - instanceVariableNames: ''! -!RTFColorDef commentStamp: '' prior: 0! - Carries color information for the color table! -!RTFFontInfo commentStamp: '' prior: 0! - Carries RTF font information to be passed to a builder! -!RTFParser commentStamp: '' prior: 0! - An RTF parser! -!RTFParserState commentStamp: '' prior: 0! - A state of the RTF parser contains: - - a destination block (to send plain text to) - - a context (a currently built object for the builder, e.g. RTFFontInfo) -The state has abilities for saving and restoring states on a stack! -!RTFStylesheet commentStamp: '' prior: 0! - Carries information about RTF styles! -!RTFSophieStylesheet commentStamp: '' prior: 0! - Adds style applying functionality to stylesheets! -!RTFTextBuilder commentStamp: '' prior: 0! - To do: -- Ensure consistency between rtf export and import -- write tests for that consistency -- integrate with StyledTextBuilder (el parser der rtf seria un transcodificador???)!! - (el builder es solo para StyledText... Yo quisiera que esto sea mas general!!)! -!RTFTextConverter commentStamp: '' prior: 0! - The abstract class for all different type of text converters. nextFromStream: and nextPut:toStream: are the public accessible methods. If you are going to make a subclass for a stateful text conversion, you should override restoreStateOf:with: and saveStateOf: along the line of CompoundTextConverter. -! -!RTFLatin1TextConverter commentStamp: '' prior: 0! - Text converter for ISO 8859-1. An international encoding used in Western Europe.! -!RTFMappingUnicodeTextConverter commentStamp: '' prior: 0! - Base class for Unicode converters based on mappings as defined in -http://www.unicode.org/Public/MAPPINGS/! -!RTFCP1250UnicodeTextConverter commentStamp: '' prior: 0! - CP1250 to Unicode converter based on -http://www.unicode.org/Public/MAPPINGS/VENDORS/MICSFT/WINDOWS/CP1250.TXT! -!RTFCP1251UnicodeTextConverter commentStamp: '' prior: 0! - CP1251 to Unicode converter based on -http://www.unicode.org/Public/MAPPINGS/VENDORS/MICSFT/WINDOWS/CP1251.TXT! -!RTFCP1252UnicodeTextConverter commentStamp: '' prior: 0! - CP1251 to Unicode converter based on -http://www.unicode.org/Public/MAPPINGS/VENDORS/MICSFT/WINDOWS/CP1252.TXT! -!RTFMacRomanUnicodeTextConverter commentStamp: '' prior: 0! - True MacRoman to Unicode converter based on -http://www.unicode.org/Public/MAPPINGS/VENDORS/APPLE/ROMAN.TXT! -!RTFToken commentStamp: '' prior: 0! - token types: - #blockOpen - '{' - #blockClose - '}' - #keyword - e.g. '\alabala' - #string - e.g. 'alabala' - -content stores keyword or string -arg stores keyword argument -if any field unapplicable for type, it returns nil -DafaultArgs: All keywords have argument value. Default keyowrd parameters is defined in DefaultArgs. If no default argument is fount, the default is assumed 0. ! -!RTFTokenizer commentStamp: '' prior: 0! - Because of getAfterNext, don't expect the stream of this token to behave as expected. Two tokens ahead are actually read from the stream - -At initialization last is nil. Must getToken to get first - -newline is a Mac-hack. No newlines are expected in a RTF, but Mac makes escaped newlines! -!RTFUnicode commentStamp: '' prior: 0! - Not a real Unicode implementation. Just compatibility for Sophie-RTF. Answers instances of Character (i.e. ISO-8859-15). -Based on http://www.unicode.org/Public/MAPPINGS/ISO8859/8859-15.TXT! -!ExtendedClipboardInterface methodsFor: '*rtfImporting' stamp: 'jmv 11/12/2013 08:52'! - fromRTFBytes: bytes - | parser builder | - builder _ RTFTextBuilder currentClass new. - parser _ RTFParser new. - parser - parseWithTokenizer: (RTFTokenizer newFromString: bytes asString) - buildWith: builder. - ^builder text! ! -!RTFChunkScanner methodsFor: 'private' stamp: 'mir 8/14/2006 16:25'! - addScannedString - | scannedString | - scannedString := ''. - prevIndex < lastIndex - ifTrue: [scannedString := chunk copyFrom: prevIndex to: lastIndex-1]. - self bufferStream isEmpty - ifFalse: [ - self bufferStream nextPutAll: scannedString. - scannedString := self bufferStream contents. - self bufferStream reset]. - scannedString isEmpty - ifFalse: [buffer add: (RTFToken newString: scannedString)] -! ! -!RTFChunkScanner methodsFor: 'private' stamp: 'mir 8/12/2006 15:51'! - addScannedStringToBuffer - prevIndex < lastIndex - ifFalse: [^self]. - self bufferStream nextPutAll: (chunk copyFrom: prevIndex to: lastIndex-1)! ! -!RTFChunkScanner methodsFor: 'stop conditions' stamp: 'mir 8/12/2006 15:44'! - blockCloseAt: index - self addScannedString. - buffer add: (RTFToken newBlockClose). - lastIndex := lastIndex + 1. - prevIndex := lastIndex! ! -!RTFChunkScanner methodsFor: 'stop conditions' stamp: 'mir 8/12/2006 15:44'! - blockOpenAt: index - self addScannedString. - buffer add: (RTFToken newBlockOpen). - lastIndex := lastIndex + 1. - prevIndex := lastIndex! ! -!RTFChunkScanner methodsFor: 'private' stamp: 'mir 8/12/2006 14:59'! - bufferStream - ^BufferStream! ! -!RTFChunkScanner methodsFor: 'stop conditions' stamp: 'mir 8/12/2006 15:46'! - crAt: index - self addScannedStringToBuffer. - lastIndex := lastIndex + 1. - prevIndex := lastIndex! ! -!RTFChunkScanner methodsFor: 'stop conditions' stamp: 'mir 8/12/2006 15:50'! - lfAt: index - self addScannedStringToBuffer. - lastIndex := lastIndex + 1. - prevIndex := lastIndex! ! -!RTFChunkScanner methodsFor: 'initialization' stamp: 'mir 8/12/2006 16:05'! - scan: chunkString into: aBuffer startingAt: index - chunk := chunkString. - buffer := aBuffer. - self scanStartingAt: index! ! -!RTFChunkScanner methodsFor: 'private' stamp: 'jmv 9/5/2016 20:31:48'! - scanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta - "Primitive. This is the inner loop of text display--but see - scanCharactersFrom: to:rightX: which would get the string, - stopConditions and displaying from the instance. March through source - String from startIndex to stopIndex. If any character is flagged with a - non-nil entry in stops, then return the corresponding value. Determine - width of each character from xTable, indexed by map. - If dextX would exceed rightX, then return stops at: 258. - Advance destX by the width of the character. If stopIndex has been - reached, then return stops at: 257. Optional. - See Object documentation whatIsAPrimitive." - | ascii char | - - - lastIndex _ startIndex. - [lastIndex <= stopIndex] - whileTrue: - [char _ (sourceString at: lastIndex). - ascii _ char numericValue + 1. - (stops at: ascii) == nil ifFalse: [^stops at: ascii]. - lastIndex _ lastIndex + 1]. - lastIndex _ stopIndex. - ^stops at: CharacterScanner endOfRunCode! ! -!RTFChunkScanner methodsFor: 'private' stamp: 'mir 8/12/2006 15:16'! - scanFrom: startIndex to: stopIndex - | stopCondition | - stopCondition := self scanCharactersFrom: startIndex to: stopIndex in: chunk rightX: SmallInteger maxVal stopConditions: stopConditions kern: 0. - stopCondition - ifNil: [^nil] - ifNotNil: [stopCondition == #scanFinished - ifTrue: [^nil] - ifFalse: [self perform: stopCondition with: lastIndex]]! ! -!RTFChunkScanner methodsFor: 'private' stamp: 'mir 8/14/2006 16:32'! - scanStartingAt: index - | chunkSize | - self bufferStream reset. - stopConditions := ScannerTable. - xTable := XTable. - destX := 0. - lastIndex := index. - prevIndex := index. - rightEdge := SmallInteger maxVal. - chunkSize := chunk size. - [(self scanFrom: lastIndex to: chunkSize) isNil] - whileFalse. - prevIndex <= lastIndex - ifTrue: [lastIndex := lastIndex + 1]. - self addScannedString! ! -!RTFChunkScanner class methodsFor: 'class initialization' stamp: 'jmv 9/5/2016 20:31:57'! - initialize - "RTFChunkScanner initialize" - - BufferStream := (String new: 4096) writeStream. - XTable := Array new: 258 withAll: 0. - - ScannerTable := Array new: 258. - ScannerTable atAllPut: nil. - ScannerTable at: CharacterScanner endOfRunCode put: #scanFinished. - ScannerTable at: CharacterScanner crossedXCode put: #scanFinished. - - ScannerTable at: ${ numericValue + 1 put: #blockOpenAt:. - ScannerTable at: $} numericValue + 1 put: #blockCloseAt:. - ScannerTable at: Character lfCharacter numericValue + 1 put: #lfAt:. - ScannerTable at: Character crCharacter numericValue + 1 put: #crAt:. -! ! -!RTFChunkScanner class methodsFor: 'instance creation' stamp: 'mir 8/12/2006 16:04'! - scan: chunk into: buffer startingAt: index - ^self new scan: chunk into: buffer startingAt: index! ! -!RTFColorDef methodsFor: 'accessing' stamp: 'tat 5/5/2006 13:49'! - blue - ^blue! ! -!RTFColorDef methodsFor: 'accessing' stamp: 'tat 5/5/2006 13:49'! - blue: b - blue := b! ! -!RTFColorDef methodsFor: 'accessing' stamp: 'tat 5/5/2006 13:48'! - green - ^green! ! -!RTFColorDef methodsFor: 'accessing' stamp: 'tat 5/5/2006 13:48'! - green: g - green := g! ! -!RTFColorDef methodsFor: 'accessing' stamp: 'tat 5/5/2006 13:48'! - red - ^red! ! -!RTFColorDef methodsFor: 'accessing' stamp: 'tat 5/5/2006 13:48'! - red: r - red := r! ! -!RTFFontInfo methodsFor: 'accessing' stamp: 'tat 5/5/2006 01:40'! - charset - ^charset! ! -!RTFFontInfo methodsFor: 'accessing' stamp: 'tat 5/5/2006 01:40'! - charset: c - charset := c! ! -!RTFFontInfo methodsFor: 'accessing' stamp: 'tat 5/5/2006 01:44'! - cpg - ^cpg! ! -!RTFFontInfo methodsFor: 'accessing' stamp: 'tat 5/5/2006 01:44'! - cpg: n - cpg := n! ! -!RTFFontInfo methodsFor: 'accessing' stamp: 'tat 5/5/2006 01:31'! - family - ^family! ! -!RTFFontInfo methodsFor: 'accessing' stamp: 'tat 5/5/2006 01:31'! - family: f - family := f! ! -!RTFFontInfo methodsFor: 'accessing' stamp: 'tat 5/3/2006 02:21'! - name - ^name! ! -!RTFFontInfo methodsFor: 'accessing' stamp: 'tat 5/3/2006 02:21'! - name: fn - name := fn! ! -!RTFFontInfo methodsFor: 'accessing' stamp: 'tat 5/3/2006 02:22'! - num - ^num! ! -!RTFFontInfo methodsFor: 'accessing' stamp: 'tat 5/3/2006 02:22'! - num: n - num := n! ! -!RTFParser methodsFor: 'handlers' stamp: 'tat 11/1/2006 15:00'! - addContents - "assuming that the next RTF token is a string - add the string to the content tree - using current style settings" - - |token| - "self break." - - token := tokenizer getToken. - state destination value: (token string) -! ! -!RTFParser methodsFor: 'utilities' stamp: 'mir 8/12/2006 16:56'! - createHandleMessage: token - "builds a handle message from a keyword token" - ^HandleMessages at: token word ifAbsent: [('handle' , token word , ':') asSymbol]! ! -!RTFParser methodsFor: 'utilities' stamp: 'jmv 9/5/2016 20:32:13'! - digitValue: char - - | value | - value _ char numericValue. - value <= $9 numericValue - ifTrue: [^value - $0 numericValue]. - value >= $a numericValue - ifTrue: [value <= $z numericValue ifTrue: [^value - $a numericValue + 10]]. - value >= $A numericValue - ifTrue: [value <= $Z numericValue ifTrue: [^value - $A numericValue + 10]]. -! ! -!RTFParser methodsFor: 'utilities' stamp: 'tat 5/3/2006 02:18'! - emptyToken - ^tokenizer tokenClass emptyToken - ! ! -!RTFParser methodsFor: 'utilities' stamp: 'jmv 4/4/2011 16:26'! - getAddress: string - - "expects a string of the type - HYPERLINK('|dblquot)('|dblquot) - and answers the link text" - - |count countEnd first last | - - "self break." - - "skip the HYPERLINK part" - count := 10. - [(((string at: count) = $') or: [(string at: count) = $"]) or: [count >= (string size)]] whileFalse: - [count := count +1]. - - "skip potential whitechars after the address" - - countEnd := string size. - [(((string at: countEnd) = $') or: [(string at: countEnd) = $"] or: [countEnd <= (count+1)])] whileFalse: - [countEnd := countEnd - 1]. - - first _ count + 1 max: 1. - last _ countEnd-1 min: string size. - (first > string size or: [first > last ]) ifTrue: [ ^'']. - ^string copyFrom: first to: last! ! -!RTFParser methodsFor: 'handlers-general' stamp: 'tat 5/5/2006 13:53'! - handleAll: token! ! -!RTFParser methodsFor: 'handlers-characters' stamp: 'tat 4/11/2007 15:07'! - handleLeftCurlyBracket: token - builder addUnicodeContents: '{'! ! -!RTFParser methodsFor: 'handlers-characters' stamp: 'tat 4/11/2007 14:30'! - handleRightCurlyBracket: token - builder addUnicodeContents: '}'! ! -!RTFParser methodsFor: 'handlers-characters' stamp: 'jmv 9/5/2016 21:03:40'! - handleSomeCodePageHexValue: token - "send text to destination if not nil" - state destination value: (String with: (Character codePoint: token arg)) -! ! -!RTFParser methodsFor: 'handlers-general' stamp: 'tat 5/5/2006 14:36'! - handleStar: token - "check if the parser can respond to the command following the *" - (self respondsTo: (self createHandleMessage: (tokenizer lookAhead: 1))) ifFalse: [ - "if not, suppress plain text within this block" - self handlerSupressText - ]! ! -!RTFParser methodsFor: 'handlers-stylesheet' stamp: 'tat 5/5/2006 14:45'! - handleadditive: token - state context additive! ! -!RTFParser methodsFor: 'handlers-skipping' stamp: 'kalin 7/9/2006 16:58'! - handleaftnsep: token - - self skipUntilBlockClose.! ! -!RTFParser methodsFor: 'handlers-general' stamp: 'tat 7/11/2006 22:26'! - handleansi: token - builder buildAnsiCharacterSet! ! -!RTFParser methodsFor: 'handlers-general' stamp: 'tat 7/27/2006 11:38'! - handleansicpg: token - builder buildCodePage: (token arg)! ! -!RTFParser methodsFor: 'handlers-charformat' stamp: 'tat 7/10/2006 23:31'! - handleb: token - - builder buildSetBold: (token arg = 1)! ! -!RTFParser methodsFor: 'handlers-general' stamp: 'tat 6/24/2006 00:37'! - handlebin: token - "ignore binary data in RTF" - self skipUntilBlockClose! ! -!RTFParser methodsFor: 'handlers-colortable' stamp: 'tat 5/5/2006 13:50'! - handleblue: token - state context blue: (token arg)! ! -!RTFParser methodsFor: 'handlers-characters' stamp: 'tat 6/22/2006 22:54'! - handlebullet: token - builder buildAddBullet! ! -!RTFParser methodsFor: 'handlers-charformat' stamp: 'kalin 5/3/2006 12:00'! - handlecaps: token - - builder buildSetCaps! ! -!RTFParser methodsFor: 'handlers-charformat' stamp: 'kalin 5/3/2006 12:03'! - handlecb: token - - builder buildSetBkColor: (token arg)! ! -!RTFParser methodsFor: 'handlers-charformat' stamp: 'tat 3/12/2007 19:22'! - handlecbpat: token - "treat this as changing the background color" - self handlecb: token! ! -!RTFParser methodsFor: 'handlers-charformat' stamp: 'kalin 5/3/2006 12:03'! - handlecf: token - - builder buildSetFgColor: (token arg)! ! -!RTFParser methodsFor: 'handlers-charformat' stamp: 'tat 3/1/2007 15:37'! - handlechcbpat: token - "treat this as changing the background color" - self handlecb: token! ! -!RTFParser methodsFor: 'handlers-skipping' stamp: 'kalin 7/9/2006 16:57'! - handlechftnsep: token - - self skipUntilBlockClose.! ! -!RTFParser methodsFor: 'handlers-colortable' stamp: 'tat 11/1/2006 15:09'! -handlecolortbl: token - state destination block: [:string | string = ';' ifTrue: [ - builder buildAddColorDef: state context. - state context: RTFColorDef new - ]] type: #colortable. - state context: RTFColorDef new - ! ! -!RTFParser methodsFor: 'handlers-fonttable' stamp: 'tat 5/5/2006 01:45'! - handlecpg: token - state context cpg: (token arg)! ! -!RTFParser methodsFor: 'handlers-stylesheet' stamp: 'tat 5/6/2006 17:08'! - handlecs: token - self handles: token. - state context isNil ifFalse: [state context type: #character]! ! -!RTFParser methodsFor: 'handlers-paragraph' stamp: 'MR 5/4/2006 13:43'! - handlecufi: token - - builder buildFirstLineIndentPercentage: (token arg)! ! -!RTFParser methodsFor: 'handlers-paragraph' stamp: 'MR 5/4/2006 13:42'! - handleculi: token - - builder buildLeftIndentPercentage: (token arg)! ! -!RTFParser methodsFor: 'handlers-paragraph' stamp: 'MR 5/4/2006 13:43'! - handlecuri: token - - builder buildRightIndentPercentage: (token arg)! ! -!RTFParser methodsFor: 'handlers' stamp: 'tat 11/1/2006 15:09'! - handledatafield: token - - state destination block: [:string|] type: #ignore. - self parseUntilBlockClose.! ! -!RTFParser methodsFor: 'handlers-header' stamp: 'tat 11/1/2006 15:18'! - handledeff: token - builder buildSetDefaultFont: token arg! ! -!RTFParser methodsFor: 'handlers-pictures' stamp: 'tat 5/18/2007 18:53'! - handledibitmap: token - "Windows device-independent bitmap (DIB)" - "state context atProperty: #type put: #bmp" - state context at: #type put: #bmp! ! -!RTFParser methodsFor: 'handlers-charformat' stamp: 'MR 6/7/2006 18:09'! - handledn: token - - builder buildSetBaselineOffset: (token arg negated)! ! -!RTFParser methodsFor: 'handlers-stylesheet' stamp: 'tat 5/6/2006 16:57'! - handleds: token - self handles: token. - state context isNil ifFalse: [state context type: #paragraph]! ! -!RTFParser methodsFor: 'handlers-characters' stamp: 'tat 6/22/2006 22:53'! - handleemdash: token - builder buildAddEmDash! ! -!RTFParser methodsFor: 'handlers-pictures' stamp: 'tat 5/18/2007 18:54'! - handleemfblip: token - "Enhanced metafile (EMF)" - "state context atProperty: #type put: #emf" - state context at: #type put: #emf! ! -!RTFParser methodsFor: 'handlers-characters' stamp: 'tat 6/22/2006 22:53'! - handleemspace: token - builder buildAddEmSpace! ! -!RTFParser methodsFor: 'handlers-characters' stamp: 'tat 6/22/2006 22:53'! - handleendash: token - builder buildAddEnDash! ! -!RTFParser methodsFor: 'handlers-characters' stamp: 'tat 6/22/2006 22:53'! - handleenspace: token - builder buildAddEnSpace! ! -!RTFParser methodsFor: 'handlers-fonttable' stamp: 'tat 1/16/2007 11:59'! - handlef: token - "check if we are defining or using a font" - (state destination type = #fonttable) - ifTrue: [ state context: (RTFFontInfo new). state context num: (token arg) ] - ifFalse: [ builder buildSetFont: (token arg) ]! ! -!RTFParser methodsFor: 'handlers-fonttable' stamp: 'tat 5/5/2006 01:36'! - handlefbidi: token - self handlefnil: token! ! -!RTFParser methodsFor: 'handlers-fonttable' stamp: 'tat 5/5/2006 01:40'! - handlefcharset: token - state context charset: (token arg)! ! -!RTFParser methodsFor: 'handlers-fonttable' stamp: 'tat 5/5/2006 01:35'! - handlefdecor: token - self handlefnil: token! ! -!RTFParser methodsFor: 'handlers-paragraph' stamp: 'kalin 5/3/2006 11:45'! - handlefi: token - - builder buildFirstLineIndent: (token arg)! ! -!RTFParser methodsFor: 'handlers' stamp: 'tat 11/1/2006 15:09'! - handlefield: token - - |linkUri linkAlt| - - linkUri := nil. - linkAlt := ''. - - state destination block: - [:string | linkUri isNil ifTrue: - [(string findString: 'HYPERLINK') > 0 ifTrue: - [linkUri := self getAddress: string]] - ifFalse: - [linkAlt := linkAlt , string] - ] type: #field. - - self parseUntilBlockClose. - - linkAlt isNil not ifTrue: [builder buildAddURI: linkUri alternate: linkAlt]. -! ! -!RTFParser methodsFor: 'handlers-header' stamp: 'tat 5/5/2006 13:44'! - handlefiletbl: token - self handlerSupressText! ! -!RTFParser methodsFor: 'handlers' stamp: 'kalin 6/24/2006 17:17'! - handlefldinst: token -! ! -!RTFParser methodsFor: 'handlers-fonttable' stamp: 'tat 5/5/2006 01:32'! - handlefmodern: token - self handlefnil: token! ! -!RTFParser methodsFor: 'handlers-fonttable' stamp: 'tat 5/5/2006 01:31'! - handlefnil: token - state context family: (token word)! ! -!RTFParser methodsFor: 'handlers-fonttable' stamp: 'tat 11/1/2006 15:10'! - handlefonttbl: token - state destination block: [:string | - (string endsWith: ';') - ifTrue: [string = ';' - "a single ; means end of font info" - ifTrue: [ builder buildAddFontInfo: (state context) ] - "this is a font name with a ; at the end" - ifFalse: [ - state context name: (string allButLast). - builder buildAddFontInfo: (state context) - ] - ] - " this is a font name" - ifFalse: [ state context name: string ] - ] - type: #fonttable! ! -!RTFParser methodsFor: 'handlers-skipping' stamp: 'tat 6/18/2007 00:47'! - handlefooter: token - - self skipUntilBlockClose.! ! -!RTFParser methodsFor: 'handlers-general' stamp: 'tat 11/1/2006 17:24'! - handlefootnote: token - self skipUntilBlockClose! ! -!RTFParser methodsFor: 'handlers-fonttable' stamp: 'tat 5/5/2006 01:32'! - handlefroman: token - self handlefnil: token! ! -!RTFParser methodsFor: 'handlers-charformat' stamp: 'kalin 5/3/2006 12:12'! - handlefs: token - - builder buildSetFontSize: (token arg)! ! -!RTFParser methodsFor: 'handlers-fonttable' stamp: 'tat 5/5/2006 01:32'! - handlefscript: token - self handlefnil: token! ! -!RTFParser methodsFor: 'handlers-fonttable' stamp: 'tat 5/5/2006 01:32'! - handlefswiss: token - self handlefnil: token! ! -!RTFParser methodsFor: 'handlers-fonttable' stamp: 'tat 5/5/2006 01:36'! - handleftech: token - self handlefnil: token! ! -!RTFParser methodsFor: 'handlers-skipping' stamp: 'kalin 7/9/2006 16:58'! - handleftnsepc: token - - self skipUntilBlockClose.! ! -!RTFParser methodsFor: 'handlers-colortable' stamp: 'tat 5/5/2006 13:50'! - handlegreen: token - state context green: (token arg)! ! -!RTFParser methodsFor: 'handlers-skipping' stamp: 'kalin 7/9/2006 16:55'! - handleheader: token - - self skipUntilBlockClose.! ! -!RTFParser methodsFor: 'handlers-charformat' stamp: 'tat 6/13/2007 23:50'! - handlehighlight: token - "treat highlighting as changing the background color" - self handlecb: token! ! -!RTFParser methodsFor: 'handlers-charformat' stamp: 'tat 7/11/2006 00:38'! - handlei: token - - builder buildSetItalic: (token arg = 1)! ! -!RTFParser methodsFor: 'handlers' stamp: 'tat 5/5/2006 00:30'! - handleinfo: token - self handlerSupressText! ! -!RTFParser methodsFor: 'handlers-pictures' stamp: 'tat 5/18/2007 18:10'! - handlejpegblip: token - "state context atProperty: #type put: #jpeg" - state context at: #type put: #jpeg! ! -!RTFParser methodsFor: 'handlers-charformat' stamp: 'MR 6/7/2006 17:59'! - handlekerning: token - - builder buildSetKerning: (token arg)! ! -!RTFParser methodsFor: 'handlers-characters' stamp: 'tat 6/22/2006 22:42'! - handleldblquote: token - - builder buildAddDoubleLeftQuote! ! -!RTFParser methodsFor: 'handlers-paragraph' stamp: 'kalin 5/3/2006 11:47'! - handleli: token - - builder buildLeftIndent: (token arg)! ! -!RTFParser methodsFor: 'handlers-paragraph' stamp: 'kalin 5/3/2006 11:47'! - handlelin: token - - builder buildLeftIndent: (token arg)! ! -!RTFParser methodsFor: 'handlers-characters' stamp: 'MR 7/10/2007 08:31'! - handleline: token - - builder buildStartParagraph! ! -!RTFParser methodsFor: 'handlers-characters' stamp: 'tat 6/22/2006 22:54'! - handlelquote: token - builder buildAddLeftQuote! ! -!RTFParser methodsFor: 'handlers-general' stamp: 'tat 7/11/2006 22:26'! - handlemac: token - builder buildMacCharacterSet! ! -!RTFParser methodsFor: 'handlers-pictures' stamp: 'tat 5/18/2007 18:54'! - handlemacpict: token - "QuickDraw image (PICT)" - "state context atProperty: #type put: #pict" - state context at: #type put: #pict! ! -!RTFParser methodsFor: 'handlers-characters' stamp: 'tat 6/22/2006 22:55'! - handlenbhyph: token - builder buildAddNonBreakingHyphen! ! -!RTFParser methodsFor: 'handlers-characters' stamp: 'tat 6/22/2006 22:55'! - handlenbsp: token - builder buildAddNonBreakingSpace! ! -!RTFParser methodsFor: 'handlers-pictures' stamp: 'tat 6/24/2006 00:38'! -handlenonshppict: token - "ignore this group" - self skipUntilBlockClose! ! -!RTFParser methodsFor: 'handlers-characters' stamp: 'tat 6/22/2006 22:55'! - handleopthyph: token - builder buildAddOptionalHyphen! ! -!RTFParser methodsFor: 'handlers-paragraph' stamp: 'kalin 5/3/2006 11:25'! - handlepar: token - builder buildStartParagraph! ! -!RTFParser methodsFor: 'handlers-paragraph' stamp: 'tat 11/1/2006 15:40'! - handlepard: token - builder buildResetParagraphSettings! ! -!RTFParser methodsFor: 'handlers-pictures' stamp: 'MR 7/2/2006 19:24'! - handlepiccropb: token - "Bottom cropping value in twips. A positive value crops toward the center of the picture; a negative value crops away from the center, adding a space border around the picture (the default value is 0). OPTIONAL" - state context at: 'piccropb' put: token arg -! ! -!RTFParser methodsFor: 'handlers-pictures' stamp: 'MR 7/2/2006 19:23'! - handlepiccropr: token - "Right cropping value in twips. A positive value crops toward the center of the picture; a negative value crops away from the center, adding a space border around the picture (the default value is 0). OPTIONAL" - state context at: 'piccropr' put: token arg -! ! -!RTFParser methodsFor: 'handlers-pictures' stamp: 'MR 7/2/2006 19:17'! - handlepich: token - "yExt field if the picture is a Windows metafile; picture height in pixels if the picture is a bitmap or from QuickDraw. The N argument is a long integer" - state context at: 'pich' put: token arg -! ! -!RTFParser methodsFor: 'handlers-pictures' stamp: 'MR 7/2/2006 19:18'! - handlepichgoal: token - "Desired height of the picture in twips. The N argument is a long integer. OPTIONAL" - state context at: 'pichgoal' put: token arg -! ! -!RTFParser methodsFor: 'handlers-pictures' stamp: 'MR 7/2/2006 19:20'! - handlepicscalex: token - "Horizontal scaling value. The N argument is a value representing a percentage (the default is 100 percent). OPTIONAL" - state context at: 'picscalex' put: token arg -! ! -!RTFParser methodsFor: 'handlers-pictures' stamp: 'MR 7/2/2006 19:20'! - handlepicscaley: token - "Vertical scaling value. The N argument is a value representing a percentage (the default is 100 percent). OPTIONAL" - state context at: 'picscaley' put: token arg -! ! -!RTFParser methodsFor: 'handlers-pictures' stamp: 'tat 5/18/2007 18:45'! - handlepict: token - | stream | - stream _ ReadWriteStream with: ByteArray new. - - state destination block: [:string | - 1 to: string size by: 2 do: [:index | - stream - nextPut: ((self digitValue: (string at: index)) bitShift: 4) - + (self digitValue: (string at: index+1))]] - type: #pict. - state context: Dictionary new. - stream reset. - - "state context atProperty: #type put: #none." - state context at: #type put: #none. - - self parseUntilBlockClose. - builder buildAddPicture: state context from: stream! ! -!RTFParser methodsFor: 'handlers-pictures' stamp: 'MR 7/2/2006 19:17'! - handlepicw: token - "xExt field if the picture is a Windows metafile; picture width in pixels if the picture is a bitmap or from QuickDraw. The N argument is a long integer" - state context at: 'picw' put: token arg -! ! -!RTFParser methodsFor: 'handlers-pictures' stamp: 'MR 7/2/2006 19:19'! - handlepicwgoal: token - "Desired width of the picture in twips. The N argument is a long integer. OPTIONAL" - state context at: 'picwgoal' put: token arg -! ! -!RTFParser methodsFor: 'handlers-charformat' stamp: 'kalin 5/3/2006 11:58'! - handleplain: token - - builder buildResetCharFormat! ! -!RTFParser methodsFor: 'handlers-pictures' stamp: 'tat 5/18/2007 18:51'! - handlepmmetafile: token - "OS/2 bitmap" - "state context atProperty: #type put: #pmm" - state context at: #type put: #pmm! ! -!RTFParser methodsFor: 'handlers-pictures' stamp: 'tat 6/23/2006 22:39'! - handlepngblip: token - "state context atProperty: #type put: #png" - state context at: #type put: #png! ! -!RTFParser methodsFor: 'handlers-characters' stamp: 'tat 5/2/2006 01:46'! - handlepntxta: token - "only skips the text that follows" - ((tokenizer lookAhead: 1) type = #string) - ifTrue: [tokenizer getToken]. -! ! -!RTFParser methodsFor: 'handlers' stamp: 'tat 5/2/2006 02:04'! - handlepntxtb: token - self handlepntxta: token! ! -!RTFParser methodsFor: 'handlers-paragraph' stamp: 'kalin 5/3/2006 11:29'! - handleqc: token - - builder buildParagraphAlignCenter! ! -!RTFParser methodsFor: 'handlers-paragraph' stamp: 'kalin 5/3/2006 11:29'! - handleqj: token - - builder buildParagraphAlignJustified! ! -!RTFParser methodsFor: 'handlers-paragraph' stamp: 'kalinm 5/4/2006 19:00'! - handleql: token - - builder buildParagraphAlignLeft! ! -!RTFParser methodsFor: 'handlers-characters' stamp: 'tat 6/22/2006 22:53'! - handleqmspace: token - builder buildAddQmSpace! ! -!RTFParser methodsFor: 'handlers-paragraph' stamp: 'kalin 5/3/2006 11:30'! - handleqr: token - - builder buildParagraphAlignRight! ! -!RTFParser methodsFor: 'handlers-general' stamp: 'tat 11/1/2006 15:11'! - handlerSupressText - "suppress plain text output" - state destination block: [:string | ] type: #ignore. - self parseUntilBlockClose.! ! -!RTFParser methodsFor: 'handlers-characters' stamp: 'tat 6/22/2006 22:42'! - handlerdblquote: token - - builder buildAddDoubleRightQuote! ! -!RTFParser methodsFor: 'handlers-colortable' stamp: 'tat 5/5/2006 13:50'! - handlered: token - state context red: (token arg)! ! -!RTFParser methodsFor: 'handlers-paragraph' stamp: 'kalin 5/3/2006 11:47'! - handleri: token - - builder buildRightIndent: (token arg)! ! -!RTFParser methodsFor: 'handlers-paragraph' stamp: 'kalin 5/3/2006 11:47'! - handlerin: token - - builder buildRightIndent: (token arg)! ! -!RTFParser methodsFor: 'handlers-characters' stamp: 'tat 6/22/2006 22:54'! - handlerquote: token - builder buildAddRightQuote! ! -!RTFParser methodsFor: 'handlers-stylesheet' stamp: 'tat 11/1/2006 15:13'! - handles: token - state destination type = #stylesheet - ifFalse: [ builder buildApplyStylesheet: (token arg)] - ifTrue: [ - state context: (builder buildStartStylesheet). - state context num: (token arg). - state context type: #paragraph - ]! ! -!RTFParser methodsFor: 'handlers-paragraph' stamp: 'MR 5/4/2006 13:26'! - handlesa: token - "sa = space after" - - builder buildSpaceBelow: (token arg)! ! -!RTFParser methodsFor: 'handlers-paragraph' stamp: 'MR 5/4/2006 13:27'! - handlesb: token - "sb = space before" - - builder buildSpaceAbove: (token arg)! ! -!RTFParser methodsFor: 'handlers-stylesheet' stamp: 'tat 5/6/2006 16:53'! - handlesbasedon: token - state context basedon: (token arg)! ! -!RTFParser methodsFor: 'handlers' stamp: 'kalin 5/3/2006 11:16'! - handlesectd: token - - builder buildResetSectionSettings! ! -!RTFParser methodsFor: 'handlers-paragraph' stamp: 'tat 7/11/2006 22:11'! - handlesl: token - - builder buildLineSpacing: (token arg). - - "If the next command is not \slmult then we have to call it manually with default - parameter 0" - - (tokenizer lookAhead: 1) word = #slmult ifFalse: [ - builder buildLineSpacingType: 0 - ] -! ! -!RTFParser methodsFor: 'handlers-paragraph' stamp: 'MR 5/6/2006 13:15'! - handleslmult: token - - builder buildLineSpacingType: (token arg)! ! -!RTFParser methodsFor: 'handlers-stylesheet' stamp: 'tat 11/1/2006 15:11'! - handlestylesheet: token - state destination block: [:string | (string endsWith: ';') - ifTrue: [builder buildAddStylesheet: state context] - ifFalse: [state context name: string] - ] type: #stylesheet. - state context: (builder buildStartStylesheet) -! ! -!RTFParser methodsFor: 'handlers-characters' stamp: 'kalin 5/3/2006 12:34'! - handletab: token - - builder buildAddTab! ! -!RTFParser methodsFor: 'handlers-general' stamp: 'jmv 9/5/2016 20:30:28'! - handleu: token - | string char | - char _ token arg < 0 - ifTrue: [ RTFUnicode codePoint: (65536 + token arg) or: nil ] - ifFalse: [ RTFUnicode codePoint: token arg or: nil ]. - - "Do not output Unicode characters to a different destination, just suppress output" - state destination type = #default ifFalse: [^self]. - - "If we can represent char (i.e. it belongs in ISO 8859-15), add it, and skip next char - (as it should be included only if the unicode char point is not recognized)" - char ifNotNil: [ - string _ char asString. - builder buildAddUnicodeContents: string. - builder skipNextCharacters: 1 ]! ! -!RTFParser methodsFor: 'handlers-characters' stamp: 'tat 1/16/2007 12:03'! - handleuc: token - "this command states how many characters to skip after reading an unicode character" - builder defaultSkipNextCharacters: token arg! ! -!RTFParser methodsFor: 'handlers-characters' stamp: 'tat 6/21/2006 23:51'! - handleud: token - "Do nothing. This handler exists only to state that the upcoming block of unicode text should not be ignored"! ! -!RTFParser methodsFor: 'handlers-charformat' stamp: 'kalinm 5/4/2006 19:51'! - handleul: token - - builder buildSetUnderline: true! ! -!RTFParser methodsFor: 'handlers-charformat' stamp: 'tat 6/13/2007 11:35'! -handleuld: token - - builder buildSetUnderline: true! ! -!RTFParser methodsFor: 'handlers-charformat' stamp: 'tat 6/13/2007 11:35'! - handleuldash: token - - builder buildSetUnderline: true! ! -!RTFParser methodsFor: 'handlers-charformat' stamp: 'tat 6/13/2007 11:35'! - handleuldashd: token - - builder buildSetUnderline: true! ! -!RTFParser methodsFor: 'handlers-charformat' stamp: 'tat 6/13/2007 11:35'! - handleuldb: token - - builder buildSetUnderline: true! ! -!RTFParser methodsFor: 'handlers-charformat' stamp: 'tat 6/13/2007 11:35'! - handleulhwave: token - - builder buildSetUnderline: true! ! -!RTFParser methodsFor: 'handlers-charformat' stamp: 'tat 6/13/2007 11:35'! - handleulldash: token - - builder buildSetUnderline: true! ! -!RTFParser methodsFor: 'handlers-charformat' stamp: 'tpr 9/6/2006 13:00'! - handleulnone: token - - builder buildSetUnderline: false! ! -!RTFParser methodsFor: 'handlers-charformat' stamp: 'tat 6/13/2007 11:36'! - handleulth: token - - builder buildSetUnderline: true! ! -!RTFParser methodsFor: 'handlers-charformat' stamp: 'tat 6/13/2007 11:36'! - handleulthd: token - - builder buildSetUnderline: true! ! -!RTFParser methodsFor: 'handlers-charformat' stamp: 'tat 6/13/2007 11:36'! - handleulthdash: token - - builder buildSetUnderline: true! ! -!RTFParser methodsFor: 'handlers-charformat' stamp: 'tat 6/13/2007 11:36'! - handleulthdashd: token - - builder buildSetUnderline: true! ! -!RTFParser methodsFor: 'handlers-charformat' stamp: 'tat 6/13/2007 11:36'! - handleulthdashdd: token - - builder buildSetUnderline: true! ! -!RTFParser methodsFor: 'handlers-charformat' stamp: 'tat 6/13/2007 11:36'! - handleulthldashd: token - - builder buildSetUnderline: true! ! -!RTFParser methodsFor: 'handlers-charformat' stamp: 'tat 6/13/2007 11:36'! - handleululdbwave: token - - builder buildSetUnderline: true! ! -!RTFParser methodsFor: 'handlers-charformat' stamp: 'tat 6/13/2007 11:36'! - handleulw: token - - builder buildSetUnderline: true! ! -!RTFParser methodsFor: 'handlers-charformat' stamp: 'tat 6/13/2007 11:36'! - handleulwave: token - - builder buildSetUnderline: true! ! -!RTFParser methodsFor: 'handlers-charformat' stamp: 'MR 6/7/2006 18:09'! - handleup: token - - builder buildSetBaselineOffset: (token arg)! ! -!RTFParser methodsFor: 'handlers-characters' stamp: 'tat 6/21/2006 23:51'! - handleupr: token - "{\upr{keyword ansi_text}{\*\ud{keyword Unicode_text}}}" - - "skip the first block of ansi text" - - self skipBlock - - "the Unicode block will be parsed by the \ud keyword"! ! -!RTFParser methodsFor: 'handlers-pictures' stamp: 'tat 5/18/2007 18:54'! - handlewbitmap: token - "Windows device-dependent bitmap (DDB)" - "state context atProperty: #type put: #ddb" - state context at: #type put: #ddb! ! -!RTFParser methodsFor: 'handlers-pictures' stamp: 'tat 5/18/2007 18:51'! - handlewmetafile: token - "Windows metafile" - "state context atProperty: #type put: #wmf" - state context at: #type put: #wmf! ! -!RTFParser methodsFor: 'initialization' stamp: 'kalin 5/7/2006 19:25'! - initialize - - RTFToken initialize! ! -!RTFParser methodsFor: 'parsing' stamp: 'tat 5/4/2006 18:52'! - parse - self parseBlock. -! ! -!RTFParser methodsFor: 'parsing' stamp: 'tat 5/4/2006 00:50'! - parse: string buildWith: b - "parse the string with the specified builder" - self parseWithTokenizer: (RTFTokenizer newFromString: string) buildWith: b! ! -!RTFParser methodsFor: 'utilities' stamp: 'tat 8/13/2007 10:41'! - parseBlock - | token | - "parses a complete {..} block" - - "is there a block to parse?" - token := (tokenizer lookAhead: 1). - ((token isNil not) and: [token type == #blockOpen]) ifFalse: [^self]. - - "skip the { character" - tokenizer getToken. - - "save the state" - self saveState. - - "parse all words until the end of the block is reached" - self parseUntilBlockClose. - - "skip the } character" - tokenizer getToken. - - "restore the state" - self restoreState! ! -!RTFParser methodsFor: 'utilities' stamp: 'kalin 5/1/2006 14:08'! - parseCommand - - "parse a command, string or a block of commands - disregarding their inner sctructure" - - |peeked| - - peeked := (tokenizer lookAhead: 1) type. - - (peeked == #blockOpen) - ifTrue: [self parseBlock]. - (peeked == #string) - ifTrue: [self addContents]. - (peeked == #keyword) - ifTrue: [self parseKeyWord]. -! ! -!RTFParser methodsFor: 'utilities' stamp: 'kalin 5/16/2006 12:04'! - parseKeyWord - "assuming that the next RTF token is a keyword, - find appropriate keyword handler and execute it" - - | token message | - - token := tokenizer getToken. - - "build the message name for the RTF keyword" - message := self createHandleMessage: token. - - (self respondsTo: message) ifTrue: [ - "Transcript show: 'Handling keyword: '; show: (token word); cr." - self perform: message with: token - ] ifFalse: [ - "run a general handler" - self handleAll: token - ] - - - - - ! ! -!RTFParser methodsFor: 'utilities' stamp: 'tat 5/4/2006 23:09'! - parseUntilBlockClose - "reads until a not parsed #blockClose token" - - [(tokenizer lookAhead: 1) type = #blockClose] whileFalse: - [self parseCommand] - -! ! -!RTFParser methodsFor: 'parsing' stamp: 'jmv 4/8/2011 11:29'! - parseWithTokenizer: t buildWith: b - tokenizer := t. - builder := b. - state := RTFParserState new. - "set default destination to builder's method to add contents" - state destination block: [:string | builder buildAddContents: string] type: #default. - self parse. - builder finishBuild! ! -!RTFParser methodsFor: 'utilities' stamp: 'tat 5/4/2006 23:59'! - restoreState - "restores the state of the parser on exiting a block" - state restoreState. - builder restoreState! ! -!RTFParser methodsFor: 'utilities' stamp: 'tat 5/4/2006 23:59'! - saveState - "saves the state of the parser on entering a block" - state saveState. - builder saveState! ! -!RTFParser methodsFor: 'utilities' stamp: 'tat 5/4/2006 23:11'! - skipBlock - - "skips a complete {..} block" - - "is there a block to skip?" - ((tokenizer lookAhead: 1) type = #blockOpen) ifFalse: [^self]. - - "skip the { character" - tokenizer getToken. - - "skip until }" - self skipUntilBlockClose. - - "skip the } character" - tokenizer getToken! ! -!RTFParser methodsFor: 'utilities' stamp: 'kalin 4/30/2006 23:12'! - skipCommand - - "skips a command. skips the whole block if the next token - is a #blockOpen" - - ((tokenizer lookAhead: 1) type == #blockOpen) - ifTrue: [self skipBlock] - ifFalse: [tokenizer getToken] - - ! ! -!RTFParser methodsFor: 'utilities' stamp: 'tat 5/4/2006 23:13'! - skipUntilBlockClose - "skips until a not parsed #blockClose token" - - [(tokenizer lookAhead: 1) type = #blockClose] whileFalse: - [self skipCommand] - -! ! -!RTFParser class methodsFor: 'class initialization' stamp: 'tat 4/11/2007 14:28'! - initialize - "RTFParser initialize" - - HandleMessages := Dictionary new: 11. - HandleMessages - at: '*' put: #handleStar: ; - at: '|' put: #handleFormula: ; - at: '~' put: #handlenbsp: ; - at: '-' put: #handleopthyph: ; - at: '_' put: #handlenbhyph: ; - at: ':' put: #handlesubentry: ; - at: '{' put: #handleLeftCurlyBracket: ; - at: '}' put: #handleRightCurlyBracket: ; - yourself. -! ! -!RTFParserDestination methodsFor: 'accessing' stamp: 'tat 11/1/2006 15:03'! - block - ^block! ! -!RTFParserDestination methodsFor: 'accessing' stamp: 'tat 11/1/2006 15:05'! - block: aBlock type: aSymbol - block := aBlock. - type := aSymbol! ! -!RTFParserDestination methodsFor: 'accessing' stamp: 'tat 11/1/2006 15:03'! - type - ^type! ! -!RTFParserDestination methodsFor: 'accessing' stamp: 'tat 11/1/2006 15:03'! - value: arg - block ifNotNil: [^block value: arg]! ! -!RTFParserState methodsFor: 'accessing' stamp: 'tat 5/4/2006 23:39'! - context - ^context! ! -!RTFParserState methodsFor: 'accessing' stamp: 'tat 5/4/2006 23:39'! - context: anObject - context := anObject! ! -!RTFParserState methodsFor: 'accessing' stamp: 'tat 5/4/2006 23:39'! - destination - ^destination! ! -!RTFParserState methodsFor: 'accessing' stamp: 'tat 5/4/2006 23:38'! - destination: aBlock - destination := aBlock! ! -!RTFParserState methodsFor: 'private' stamp: 'tat 5/4/2006 23:48'! - empty - ^stack size = 0! ! -!RTFParserState methodsFor: 'initialization' stamp: 'tat 11/1/2006 15:06'! - initialize - super initialize. - destination := RTFParserDestination new. - context := nil. - stack := OrderedCollection new! ! -!RTFParserState methodsFor: 'private' stamp: 'tat 5/5/2006 00:25'! - pop - self empty ifTrue: [^nil] ifFalse: [^stack removeLast]! ! -!RTFParserState methodsFor: 'private' stamp: 'tat 5/5/2006 00:25'! - push: anObject - stack addLast: anObject! ! -!RTFParserState methodsFor: 'stack' stamp: 'tat 5/4/2006 23:42'! - restoreState - context := self pop. - destination := self pop! ! -!RTFParserState methodsFor: 'stack' stamp: 'tat 11/1/2006 15:00'! - saveState - self push: (destination copy). - self push: (context copy)! ! -!RTFStylesheet methodsFor: 'accessing' stamp: 'tat 5/5/2006 14:50'! - additive - additive := true! ! -!RTFStylesheet methodsFor: 'accessing' stamp: 'tat 5/6/2006 15:53'! - basedon - ^basedon! ! -!RTFStylesheet methodsFor: 'accessing' stamp: 'tat 5/6/2006 15:53'! - basedon: bo - basedon := bo! ! -!RTFStylesheet methodsFor: 'initializing' stamp: 'tat 5/6/2006 16:50'! - initialize - additive := false. - type := #paragraph. - num := 0! ! -!RTFStylesheet methodsFor: 'accessing' stamp: 'tat 5/5/2006 14:49'! - name - ^name! ! -!RTFStylesheet methodsFor: 'accessing' stamp: 'tat 5/5/2006 14:49'! - name: n - name := n! ! -!RTFStylesheet methodsFor: 'accessing' stamp: 'tat 5/5/2006 15:02'! - num - ^num! ! -!RTFStylesheet methodsFor: 'accessing' stamp: 'tat 5/5/2006 15:01'! - num: n - num := n! ! -!RTFStylesheet methodsFor: 'accessing' stamp: 'tat 5/5/2006 15:33'! - style - ^style! ! -!RTFStylesheet methodsFor: 'accessing' stamp: 'tat 5/5/2006 15:32'! - style: s - style := s! ! -!RTFStylesheet methodsFor: 'accessing' stamp: 'tat 5/5/2006 14:49'! - type - ^type! ! -!RTFStylesheet methodsFor: 'accessing' stamp: 'tat 5/5/2006 14:49'! - type: t - type := t! ! -!RTFSophieStylesheet methodsFor: 'applying' stamp: 'tat 3/11/2007 22:15'! -applyTo: builder - "applies the stylesheet to the builder" - basedon isNil ifFalse: [ builder buildApplyStylesheet: basedon]. - additive ifFalse: [ self resetStyle: builder ]. - style do: [:aBlock | aBlock value: builder state] - ! ! -!RTFSophieStylesheet methodsFor: 'applying' stamp: 'tat 5/6/2006 17:05'! - getStyleFrom: builder - type = #paragraph ifTrue: [^builder activeParagraphStyle]. - type = #character ifTrue: [^builder activeCharacterStyle]! ! -!RTFSophieStylesheet methodsFor: 'applying' stamp: 'tat 5/6/2006 17:40'! - resetStyle: builder - type = #paragraph ifTrue: [builder buildResetParagraphSettings. builder buildResetCharFormat]. - type = #character ifTrue: [builder buildResetCharFormat ]! ! -!RTFTextBuilder methodsFor: 'private' stamp: 'jmv 3/30/2011 15:53'! - addToText: aString - self addToText: aString specialAttributes: nil! ! -!RTFTextBuilder methodsFor: 'private' stamp: 'jmv 4/11/2011 21:58'! - addToText: aString specialAttributes: nonFormattingAttributesOrNil - "nonFormattingAttributesOrNil should only contains attributes that answer false to #isForFormatting" - | attributes emphasis | - - attributes _ Array streamContents: [ :strm | - fontFamilyName ifNotNil: [ - fontPointSize ifNotNil: [ - strm nextPut: (TextFontFamilyAndSize - familyName: fontFamilyName pointSize: fontPointSize) ]]. - emphasis _ 0. - bold ifTrue: [ emphasis _ emphasis + 1 ]. - italic ifTrue: [ emphasis _ emphasis + 2 ]. - underline ifTrue: [ emphasis _ emphasis + 4 ]. - emphasis > 0 ifTrue: [ - strm nextPut: (TextEmphasis new emphasisCode: emphasis) ]. - currentFgColor ifNotNil: [ - strm nextPut: (TextColor color: currentFgColor) ]. - nonFormattingAttributesOrNil ifNotNil: [ strm nextPutAll: nonFormattingAttributesOrNil ]]. - textStream nextPutAllString: aString withAttributes: attributes! ! -!RTFTextBuilder methodsFor: 'building' stamp: 'jmv 11/22/2011 15:21'! - addUnicodeContents: string - - "Add Unicode strings to the content tree. Skip characters if prescribed by the \uc command (see doSkipNextCharacters)" - - string size <= skipNextCharacters ifTrue: [ - self skipNextCharacters: skipNextCharacters - (string size). ^self]. - - "For unicode characters do not use converter" - self addToText: (string allButFirst: skipNextCharacters). - - self skipNextCharacters: 0! ! -!RTFTextBuilder methodsFor: 'private' stamp: 'jmv 3/30/2011 16:36'! - attachCharacterStyleToParagraph - "Ver si hace falta algo como lo que hace Sophie..."! ! -!RTFTextBuilder methodsFor: 'building-characters' stamp: 'jmv 9/5/2016 20:30:31'! - buildAddBullet - self addUnicodeContents: (RTFUnicode codePoint: 16r2022 or: $°) asString! ! -!RTFTextBuilder methodsFor: 'building-header' stamp: 'jmv 3/29/2011 22:26'! - buildAddColorDef: coldef - "adds an entry to the color table" - (coldef red isNil or: [coldef green isNil or: [coldef blue isNil]]) - ifTrue: [colorTable addLast: nil] - ifFalse: [colorTable addLast: (Color r: (coldef red) / 255 g: (coldef green) / 255 b: (coldef blue) / 255)]! ! -!RTFTextBuilder methodsFor: 'building' stamp: 'jmv 3/30/2011 15:42'! - buildAddContents: string - | possibleString | - possibleString _ self convertAndSkip: string. - possibleString ifNil: [^self]. - - self addToText: possibleString! ! -!RTFTextBuilder methodsFor: 'building-characters' stamp: 'jmv 9/5/2016 20:30:34'! - buildAddDoubleLeftQuote - self addUnicodeContents: (RTFUnicode codePoint: 16r201C or: $") asString! ! -!RTFTextBuilder methodsFor: 'building-characters' stamp: 'jmv 9/5/2016 20:30:35'! - buildAddDoubleRightQuote - self addUnicodeContents: (RTFUnicode codePoint: 16r201D or: $") asString! ! -!RTFTextBuilder methodsFor: 'building-characters' stamp: 'jmv 9/5/2016 20:30:37'! - buildAddEmDash - self addUnicodeContents: (RTFUnicode codePoint: 16r2014 or: '--') asString! ! -!RTFTextBuilder methodsFor: 'building-characters' stamp: 'jmv 9/5/2016 20:30:39'! - buildAddEmSpace - self addUnicodeContents: (RTFUnicode codePoint: 16r2003 or: ' ') asString! ! -!RTFTextBuilder methodsFor: 'building-characters' stamp: 'jmv 9/5/2016 20:30:41'! - buildAddEnDash - self addUnicodeContents: (RTFUnicode codePoint: 16r2013 or: $-) asString! ! -!RTFTextBuilder methodsFor: 'building-characters' stamp: 'jmv 9/5/2016 20:30:44'! - buildAddEnSpace - self addUnicodeContents: (RTFUnicode codePoint: 16r2002 or: ' ') asString! ! -!RTFTextBuilder methodsFor: 'building-header' stamp: 'jmv 3/30/2011 16:38'! - buildAddFontInfo: fontInfo - "add font information to the table" - "fontTable atProperty: (fontInfo num) put: fontInfo" - fontTable at: (fontInfo num) put: fontInfo! ! -!RTFTextBuilder methodsFor: 'building-characters' stamp: 'jmv 9/5/2016 20:30:46'! - buildAddLeftQuote - self addUnicodeContents: (RTFUnicode codePoint: 16r2018 or: $') asString! ! -!RTFTextBuilder methodsFor: 'building-characters' stamp: 'jmv 9/5/2016 20:30:49'! - buildAddNonBreakingHyphen - self addUnicodeContents: (RTFUnicode codePoint: 16r2011 or: '-') asString! ! -!RTFTextBuilder methodsFor: 'building-characters' stamp: 'jmv 9/5/2016 20:34:02'! - buildAddNonBreakingSpace - "This character is supported by ISO-8859-15" - self addUnicodeContents: (RTFUnicode codePoint: 16r00A0) asString! ! -!RTFTextBuilder methodsFor: 'building-characters' stamp: 'jmv 9/5/2016 20:34:09'! - buildAddOptionalHyphen - "This character is supported by ISO-8859-15" - self addUnicodeContents: (RTFUnicode codePoint: 16r00AD) asString! ! -!RTFTextBuilder methodsFor: 'building-pictures' stamp: 'jmv 3/30/2011 17:18'! - buildAddPicture: picInfo from: aStream - - (ImageReadWriter formFromStream: aStream) - ifNotNil: [ :form | - self addToText: '*' specialAttributes: {TextAnchor new anchoredFormOrMorph: form} ]! ! -!RTFTextBuilder methodsFor: 'building-characters' stamp: 'jmv 9/5/2016 20:30:51'! - buildAddQmSpace - self addUnicodeContents: (RTFUnicode codePoint: 16r2005 or: ' ') asString! ! -!RTFTextBuilder methodsFor: 'building-characters' stamp: 'jmv 9/5/2016 20:30:54'! - buildAddRightQuote - self addUnicodeContents: (RTFUnicode codePoint: 16r2019 or: $') asString! ! -!RTFTextBuilder methodsFor: 'building-header' stamp: 'jmv 3/30/2011 16:38'! - buildAddStylesheet: pp! ! -!RTFTextBuilder methodsFor: 'building-characters' stamp: 'jmv 9/5/2016 20:34:17'! - buildAddTab - "This character is supported by ISO-8859-15" - self addUnicodeContents: (RTFUnicode codePoint: 16r0009) asString! ! -!RTFTextBuilder methodsFor: 'building' stamp: 'jmv 3/30/2011 15:55'! - buildAddURI: uriString alternate: string - | possibleString | - possibleString _ self convertAndSkip: string. - possibleString ifNil: [^self]. - - self addToText: possibleString specialAttributes: { TextURL new url: uriString }! ! -!RTFTextBuilder methodsFor: 'building' stamp: 'jmv 3/30/2011 15:57'! - buildAddUnicodeContents: string - - self addToText: string! ! -!RTFTextBuilder methodsFor: 'building-general' stamp: 'jmv 4/6/2011 10:44'! - buildAnsiCharacterSet - self textConverter: RTFLatin1TextConverter new! ! -!RTFTextBuilder methodsFor: 'building-general' stamp: 'jmv 3/30/2011 16:39'! - buildApplyStylesheet:pp! ! -!RTFTextBuilder methodsFor: 'building-general' stamp: 'jmv 3/30/2011 16:39'! - buildCodePage: cp - self textConverter: (CodePageConverterTable at: cp ifAbsent: [^nil]) new! ! -!RTFTextBuilder methodsFor: 'building-paragraph' stamp: 'jmv 4/8/2011 15:06'! - buildFirstLineIndent: aNumber - "Guardar en una ivar, como todo lo demas. - meter en el stack tambien. - Quizas cambiar el stack... meter self copy????? no se. - - Despues usar al construir el parastyle - - " - firstIndent _ (aNumber / 20.0) rounded! ! -!RTFTextBuilder methodsFor: 'building-paragraph' stamp: 'jmv 3/30/2011 16:27'! - buildFirstLineIndentPercentage: i! ! -!RTFTextBuilder methodsFor: 'building-paragraph' stamp: 'jmv 4/8/2011 15:06'! - buildLeftIndent: aNumber - - leftIndent _ (aNumber / 20.0) rounded! ! -!RTFTextBuilder methodsFor: 'building-paragraph' stamp: 'jmv 3/30/2011 16:28'! - buildLeftIndentPercentage: i! ! -!RTFTextBuilder methodsFor: 'building-paragraph' stamp: 'jmv 3/30/2011 16:28'! - buildLineSpacing:pp! ! -!RTFTextBuilder methodsFor: 'building-paragraph' stamp: 'jmv 3/30/2011 16:28'! - buildLineSpacingType:pp! ! -!RTFTextBuilder methodsFor: 'building-general' stamp: 'jmv 3/30/2011 16:40'! - buildMacCharacterSet! ! -!RTFTextBuilder methodsFor: 'building-paragraph' stamp: 'jmv 3/30/2011 16:28'! - buildParagraphAlignCenter - align _ 2! ! -!RTFTextBuilder methodsFor: 'building-paragraph' stamp: 'jmv 4/7/2011 09:06'! - buildParagraphAlignJustified -"Atencion. Este, y cualquier otro de parrafo, falla si la ultima linea NO termina en enter... atrapar el final, y hacer algo como #buildStartParagraph..." -align _ 3! ! -!RTFTextBuilder methodsFor: 'building-paragraph' stamp: 'jmv 4/11/2011 09:58'! - buildParagraphAlignLeft - - align _ 0! ! -!RTFTextBuilder methodsFor: 'building-paragraph' stamp: 'jmv 3/30/2011 16:28'! - buildParagraphAlignRight -align _ 1! ! -!RTFTextBuilder methodsFor: 'building-charformat' stamp: 'jmv 3/30/2011 16:20'! - buildResetCharFormat! ! -!RTFTextBuilder methodsFor: 'building-paragraph' stamp: 'jmv 4/11/2011 21:39'! - buildResetParagraphSettings - "resets the paragraph settings to the default paragraph - settings" - - bold _ italic _ underline _ false. - align _ 0. "left" - - firstIndent _ leftIndent _ spaceBefore _ spaceAfter _ 0. - rightIndent _ nil! ! -!RTFTextBuilder methodsFor: 'building-general' stamp: 'jmv 3/30/2011 16:40'! - buildResetSectionSettings! ! -!RTFTextBuilder methodsFor: 'building-paragraph' stamp: 'jmv 4/8/2011 15:06'! - buildRightIndent: aNumber - rightIndent _ (aNumber / 20.0) rounded! ! -!RTFTextBuilder methodsFor: 'building-paragraph' stamp: 'jmv 3/30/2011 16:29'! - buildRightIndentPercentage: i! ! -!RTFTextBuilder methodsFor: 'building-charformat' stamp: 'jmv 3/30/2011 16:19'! - buildSetBaselineOffset: s - "sets the font size in half points"! ! -!RTFTextBuilder methodsFor: 'building-charformat' stamp: 'jmv 3/30/2011 16:21'! - buildSetBkColor: index - "Ignored in Sophie"! ! -!RTFTextBuilder methodsFor: 'building-charformat' stamp: 'jmv 3/30/2011 16:19'! - buildSetBold: aBoolean - bold _ aBoolean! ! -!RTFTextBuilder methodsFor: 'building-charformat' stamp: 'jmv 3/30/2011 16:21'! - buildSetCaps - "Ignored in Sophie"! ! -!RTFTextBuilder methodsFor: 'building-header' stamp: 'jmv 3/30/2011 16:38'! - buildSetDefaultFont: pp! ! -!RTFTextBuilder methodsFor: 'building-charformat' stamp: 'jmv 3/30/2011 16:19'! - buildSetFgColor: zindex - "sets the current foreground color to - color with the given index in the - color table" -| index | -index _ zindex + 1. -currentFgColor _ colorTable at: index! ! -!RTFTextBuilder methodsFor: 'building-charformat' stamp: 'jmv 3/31/2011 15:36'! - buildSetFont: i - "en Sophie, pone el textConverter... ver!!" - "Hasta donde entiendo, el font NO incluye emphasis ni pointSize, solo la familia, charset y code page"! ! -!RTFTextBuilder methodsFor: 'building-charformat' stamp: 'jmv 4/12/2011 09:16'! - buildSetFontSize: s - "sets the font size in half points" - - "Note font shoudl always be a baseFont, any emphasis should be done by emphasis attributes" - fontPointSize _ (s / 2.0 / Text pointSizeConversionFactor) rounded. - fontPointSize = 0 - ifTrue: [ - fontFamilyName _ nil. - fontPointSize _ nil ] - ifFalse: [ fontFamilyName _ 'DejaVu' ]! ! -!RTFTextBuilder methodsFor: 'building-charformat' stamp: 'jmv 3/30/2011 16:20'! - buildSetItalic: aBoolean - italic _ aBoolean! ! -!RTFTextBuilder methodsFor: 'building-charformat' stamp: 'jmv 4/8/2011 09:43'! - buildSetKerning: popo! ! -!RTFTextBuilder methodsFor: 'building-charformat' stamp: 'jmv 3/30/2011 16:20'! - buildSetUnderline: aBoolean - underline _ aBoolean! ! -!RTFTextBuilder methodsFor: 'building-paragraph' stamp: 'jmv 4/8/2011 15:06'! - buildSpaceAbove: aNumber - spaceBefore _ (aNumber / 20.0) rounded! ! -!RTFTextBuilder methodsFor: 'building-paragraph' stamp: 'jmv 4/8/2011 15:06'! - buildSpaceBelow: aNumber - spaceAfter _ (aNumber / 20.0) rounded! ! -!RTFTextBuilder methodsFor: 'building-paragraph' stamp: 'jmv 4/8/2011 11:36'! - buildStartParagraph - - self finishParagraph! ! -!RTFTextBuilder methodsFor: 'building-header' stamp: 'jmv 3/30/2011 16:38'! - buildStartStylesheet - "?????" - ^RTFStylesheet new! ! -!RTFTextBuilder methodsFor: 'private' stamp: 'jmv 11/22/2011 15:26'! - convert: string startingAt: startIndex withConverter: converter - - | writeStream | - converter ifNil: [^string copyFrom: startIndex to: string size]. - writeStream _ (String new: string size) writeStream. - startIndex to: string size do: [:index | - writeStream nextPut: (converter toSqueak: (string at: index))]. - ^writeStream contents! ! -!RTFTextBuilder methodsFor: 'building' stamp: 'jmv 11/22/2011 15:26'! - convertAndSkip: string - - "Convert non-Unicode string using the specified encoder. - Skip characters if prescribed by the \uc command (see doSkipNextCharacters)." - - | convertedString | - - "Check if some characters need to be skipped and do the math" - (string size <= skipNextCharacters and: [string size > 0]) - ifTrue: [ - self skipNextCharacters: skipNextCharacters - (string size). - ^nil]. - - "convert the string using the specified encoder" - convertedString := self - convert: string - startingAt: skipNextCharacters+1 - withConverter: self textConverter. - - "don't skip characters anymore" - self skipNextCharacters: 0. - - ^convertedString! ! -!RTFTextBuilder methodsFor: 'accessing' stamp: 'jmv 3/29/2011 10:15'! - defaultSkipNextCharacters: anInteger - defaultSkipNextCharacters := anInteger! ! -!RTFTextBuilder methodsFor: 'building-general' stamp: 'jmv 4/11/2011 10:18'! - finishBuild - "Don't do this. It looks like it would help, include the paragraphstyle of the last paragraph, but it will hurt when, for example, we are pasting one or a few words, not an entire paragraph." -" self finishParagraph"! ! -!RTFTextBuilder methodsFor: 'building-paragraph' stamp: 'jmv 3/13/2012 16:57'! - finishParagraph - - | attrs | - "Don't include attributes for left alignment. No need to." - attrs _ align = 0 - ifTrue: [ #() ] - ifFalse: [ { TextAlignment new alignment: align } ]. - textStream - nextPutAllString: String newLineString - withAttributes: attrs! ! -!RTFTextBuilder methodsFor: 'initialization' stamp: 'jmv 1/3/2017 21:08:34'! - initialize - -" state := RTFSophieContentTreeBuilderState new." - - "the active character style is the character style of the current rtf block - being built. It is modified by methods from the buiding-charformat section and - is used mainly by the buildAddContents method" - -" self buildResetCharFormat." - textStream _ WriteStream on: (Text string: (String new: 400)). - -" paragraphStarted := false." - - colorTable := OrderedCollection new. - - fontTable := Dictionary new. - - styleTable := Dictionary new. - bold _ italic _ underline _ false. - align _ 0. "left" - firstIndent _ leftIndent _ spaceBefore _ spaceAfter _ 0. - rightIndent _ nil. - - stateStack _ OrderedCollection new. - -" styleChangeList := nil." - -" self buildStartParagraph." - - "RTF spec says assume default value of \uc1" - self defaultSkipNextCharacters: 1. - - "reset skip next characters counter to 0" - self skipNextCharacters: 0. -! ! -!RTFTextBuilder methodsFor: 'state' stamp: 'jmv 4/8/2011 15:07'! - restoreState - - spaceAfter _ stateStack removeLast. - spaceBefore _ stateStack removeLast. - rightIndent _ stateStack removeLast. - leftIndent _ stateStack removeLast. - firstIndent _ stateStack removeLast. - align _ stateStack removeLast. - underline _ stateStack removeLast. - italic _ stateStack removeLast. - bold _ stateStack removeLast. - fontPointSize _ stateStack removeLast. - fontFamilyName _ stateStack removeLast. - currentFgColor _ stateStack removeLast. - defaultSkipNextCharacters _ stateStack removeLast. - textConverter _ stateStack removeLast! ! -!RTFTextBuilder methodsFor: 'state' stamp: 'jmv 4/8/2011 15:08'! - saveState - - stateStack - addLast: textConverter; - addLast: defaultSkipNextCharacters; - addLast: currentFgColor; - addLast: fontFamilyName; - addLast: fontPointSize; - addLast: bold; - addLast: italic; - addLast: underline; - addLast: align; - addLast: firstIndent; - addLast: leftIndent; - addLast: rightIndent; - addLast: spaceBefore; - addLast: spaceAfter! ! -!RTFTextBuilder methodsFor: 'accessing' stamp: 'jmv 3/29/2011 10:14'! - skipNextCharacters: value - "sets a count to skip the next character added with simplyAddContents:" - skipNextCharacters := value! ! -!RTFTextBuilder methodsFor: 'accessing' stamp: 'jmv 3/30/2011 16:34'! - text - "viene a ser equivalente a #contentTree, no? - En ese caso, llamara #finishBuild, PERO SOLO UNA VEZ!! - " - " - solo una vez ifTrue: [ - self finishBuild ]. - " - ^textStream contents! ! -!RTFTextBuilder methodsFor: 'accessing' stamp: 'jmv 3/29/2011 10:16'! - textConverter - ^textConverter! ! -!RTFTextBuilder methodsFor: 'accessing' stamp: 'jmv 3/29/2011 10:24'! - textConverter: aTextConverter - textConverter := aTextConverter! ! -!RTFTextBuilder methodsFor: 'private' stamp: 'jmv 4/6/2011 10:38'! - textConverterFromCharset: n - "returns a new text converter from a given font charset" - n = 77 ifTrue: [^RTFMacRomanUnicodeTextConverter new]. - n = 204 ifTrue: [^RTFCP1251UnicodeTextConverter new]. - n = 0 ifTrue: [^RTFCP1252UnicodeTextConverter new]. - ^self textConverter! ! -!RTFTextBuilder class methodsFor: 'instance creation' stamp: 'jmv 4/11/2011 18:10'! - currentClass - ^Smalltalk at: #RTFStyledTextBuilder ifAbsent: [ self ]! ! -!RTFTextBuilder class methodsFor: 'class initialization' stamp: 'jmv 4/6/2011 10:37'! - initialize - " - self initialize - " - (CodePageConverterTable := Dictionary new) - "atProperty: 10000 put: MacRomanUnicodeTextConverter; - atProperty: 1250 put: CP1250UnicodeTextConverter; - atProperty: 1251 put: CP1251UnicodeTextConverter; - atProperty: 1252 put: CP1252UnicodeTextConverter" - at: 10000 put: RTFMacRomanUnicodeTextConverter; - at: 1250 put: RTFCP1250UnicodeTextConverter; - at: 1251 put: RTFCP1251UnicodeTextConverter; - at: 1252 put: RTFCP1252UnicodeTextConverter! ! -!RTFTextConverter class methodsFor: 'instance creation' stamp: 'jmv 3/29/2011 08:43'! - default - "add if neeced" - ^ "UTF8TextConverter new." nil! ! -!RTFTextConverter class methodsFor: 'services' stamp: 'jmv 9/5/2016 20:32:27'! - digitValue: char - - | value | - value _ char numericValue. - value <= $9 numericValue - ifTrue: [^value - $0 numericValue]. - value >= $A numericValue - ifTrue: [value <= $Z numericValue ifTrue: [^value - $A numericValue + 10]]. - value >= $a numericValue - ifTrue: [value <= $z numericValue ifTrue: [^value - $a numericValue + 10]]. -! ! -!RTFLatin1TextConverter methodsFor: 'conversion' stamp: 'mir 8/13/2006 17:36'! - toSqueak: aChar - ^aChar! ! -!RTFMappingUnicodeTextConverter methodsFor: 'conversion' stamp: 'tat 8/2/2006 22:15'! - toSqueak: char - ^self subclassResponsibility! ! -!RTFMappingUnicodeTextConverter methodsFor: 'conversion' stamp: 'jmv 9/5/2016 20:31:31'! - toSqueak: char withTable: table - - | value | - value _ char numericValue. - value < 128 ifTrue: [^ char]. - value > 255 ifTrue: [^ char]. - ^ RTFUnicode codePoint: (table at: (value - 128 + 1)). -! ! -!RTFCP1250UnicodeTextConverter methodsFor: 'conversion' stamp: 'tat 8/2/2006 22:49'! - toSqueak: char - ^self toSqueak: char withTable: #(8364 129 8218 131 8222 8230 8224 8225 136 8240 352 8249 346 356 381 377 144 8216 8217 8220 8221 8226 8211 8212 152 8482 353 8250 347 357 382 378 160 711 728 321 164 260 166 167 168 169 350 171 172 173 174 379 176 177 731 322 180 181 182 183 184 261 351 187 317 733 318 380 340 193 194 258 196 313 262 199 268 201 280 203 282 205 206 270 272 323 327 211 212 336 214 215 344 366 218 368 220 221 354 223 341 225 226 259 228 314 263 231 269 233 281 235 283 237 238 271 273 324 328 243 244 337 246 247 345 367 250 369 252 253 355 729) -! ! -!RTFCP1251UnicodeTextConverter methodsFor: 'conversion' stamp: 'tat 8/2/2006 22:49'! - toSqueak: char - ^self toSqueak: char withTable: #(1026 1027 8218 1107 8222 8230 8224 8225 8364 8240 1033 8249 1034 1036 1035 1039 1106 8216 8217 8220 8221 8226 8211 8212 152 8482 1113 8250 1114 1116 1115 1119 160 1038 1118 1032 164 1168 166 167 1025 169 1028 171 172 173 174 1031 176 177 1030 1110 1169 181 182 183 1105 8470 1108 187 1112 1029 1109 1111 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103) -! ! -!RTFCP1252UnicodeTextConverter methodsFor: 'conversion' stamp: 'tat 8/2/2006 22:49'! - toSqueak: char - ^self toSqueak: char withTable: #(8364 129 8218 402 8222 8230 8224 8225 710 8240 352 8249 338 141 381 143 144 8216 8217 8220 8221 8226 8211 8212 732 8482 353 8250 339 157 382 376 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255) -! ! -!RTFMacRomanUnicodeTextConverter methodsFor: 'conversion' stamp: 'tat 8/2/2006 22:13'! - toSqueak: char - ^self toSqueak: char withTable: #( - 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 - 8224 176 162 163 167 8226 182 223 174 169 8482 180 168 8800 198 216 - 8734 177 8804 8805 165 181 8706 8721 8719 960 8747 170 186 937 230 248 - 191 161 172 8730 402 8776 8710 171 187 8230 160 192 195 213 338 339 - 8211 8212 8220 8221 8216 8217 247 9674 255 376 8260 8364 8249 8250 64257 64258 - 8225 183 8218 8222 8240 194 202 193 203 200 205 206 207 204 211 212 - 63743 210 218 219 217 305 710 732 175 728 729 730 184 733 731 711 256)! ! -!RTFToken methodsFor: 'accessing' stamp: 'tat 7/11/2006 00:38'! - arg - - "returns the argument of this keyword token" - - self isKeyword ifFalse: [^nil]. - - arg isNil not ifTrue: [^arg]. - - (DefaultArgs includesKey: self word) - ifTrue: [^ DefaultArgs at: self word]. - - ^0! ! -!RTFToken methodsFor: 'converting' stamp: 'MR 5/5/2006 00:24'! - asString - self isKeyword ifTrue: [(arg = nil) ifTrue: [^'keyword:', content] ifFalse: [^'keyword:', content, ' ', (arg asString)]]. - self isStringToken ifTrue: [^'string:', '!!',content,'!!']. - ^type asString.! ! -!RTFToken methodsFor: 'deprecated' stamp: 'kalin 5/7/2006 19:14'! - getArg - - self isKeyword ifTrue: [^arg]. - ^nil! ! -!RTFToken methodsFor: 'deprecated' stamp: 'kalin 5/7/2006 19:14'! - getString - - self isString ifTrue: [^content]. - ^nil! ! -!RTFToken methodsFor: 'deprecated' stamp: 'MR 5/1/2006 16:23'! - getType - self isBlockOpen ifTrue: [^#blockOpen]. - self isBlockClose ifTrue: [^#blockClose]. - self isKeyword ifTrue: [^#keyword]. - self isStringToken ifTrue: [^#string]. - ^nil -! ! -!RTFToken methodsFor: 'deprecated' stamp: 'kalin 5/7/2006 19:14'! - getWord - - "if this token is a command, returns the command's keyword. - For example: \kw0102 getWord -> kw" - - self isKeyword ifTrue: [^content]. - ^nil! ! -!RTFToken methodsFor: 'testing' stamp: 'MR 4/30/2006 23:10'! - isBlockClose - ^(type = #blockClose)! ! -!RTFToken methodsFor: 'testing' stamp: 'MR 4/30/2006 23:10'! - isBlockOpen - ^(type = #blockOpen)! ! -!RTFToken methodsFor: 'testing' stamp: 'MR 4/30/2006 23:10'! - isKeyword - ^(type = #keyword)! ! -!RTFToken methodsFor: 'testing' stamp: 'MR 5/1/2006 16:23'! - isStringToken - ^(type = #string)! ! -!RTFToken methodsFor: 'accessing' stamp: 'kalin 5/7/2006 19:15'! - string - "returns the contents of this string token" - - self isStringToken ifTrue: [^content]. - ^nil! ! -!RTFToken methodsFor: 'private' stamp: 'MR 7/4/2006 10:50'! - string: aContent - content := aContent. - type := #string! ! -!RTFToken methodsFor: 'accessing' stamp: 'MR 5/2/2006 13:48'! - type - self isBlockOpen ifTrue: [^#blockOpen]. - self isBlockClose ifTrue: [^#blockClose]. - self isKeyword ifTrue: [^#keyword]. - self isStringToken ifTrue: [^#string]. - ^nil -! ! -!RTFToken methodsFor: 'private' stamp: 'MR 7/4/2006 10:50'! - type: aType - type := aType.! ! -!RTFToken methodsFor: 'accessing' stamp: 'kalin 5/7/2006 19:14'! -word - - "if this token is a command, returns the command's keyword. - For example: \kw0102 getWord -> kw" - - self isKeyword ifTrue: [^content]. - ^nil! ! -!RTFToken methodsFor: 'private' stamp: 'MR 4/30/2006 23:16'! - word: aWord - self word: aWord withArg: nil! ! -!RTFToken methodsFor: 'private' stamp: 'MR 7/4/2006 10:50'! - word: aWord withArg: anArg - content := aWord. - arg := anArg. - type := #keyword! ! -!RTFToken class methodsFor: 'instance creation' stamp: 'tat 5/4/2006 00:25'! - emptyToken - ^self new type: #empty; word: #empty! ! -!RTFToken class methodsFor: 'class initialization' stamp: 'kalin 5/7/2006 19:23'! - initialize - - self initializeDefaultArgs.! ! -!RTFToken class methodsFor: 'class initialization' stamp: 'tat 7/10/2006 23:31'! - initializeDefaultArgs - - DefaultArgs := Dictionary new. - - DefaultArgs at: #i put: 1. - DefaultArgs at: #b put: 1. -! ! -!RTFToken class methodsFor: 'instance creation' stamp: 'MR 7/4/2006 10:51'! -newBlockClose - | instance | - instance := self new. - instance type: #blockClose. - ^instance! ! -!RTFToken class methodsFor: 'instance creation' stamp: 'MR 7/4/2006 10:51'! - newBlockOpen - | instance | - instance := self new. - instance type: #blockOpen. - ^instance! ! -!RTFToken class methodsFor: 'instance creation' stamp: 'MR 4/30/2006 23:24'! - newKeyword: aWord - ^(self newKeyword: aWord withArg: nil)! ! -!RTFToken class methodsFor: 'instance creation' stamp: 'MR 7/4/2006 10:51'! - newKeyword: aWord withArg: anArg - | instance | - instance := self new. - instance word: aWord withArg: anArg. - ^instance! ! -!RTFToken class methodsFor: 'instance creation' stamp: 'MR 7/4/2006 10:51'! - newString: aString - | instance | - instance := self new. - instance string: aString. - ^instance! ! -!RTFTokenizer methodsFor: 'private' stamp: 'MR 5/3/2006 13:26'! - addStringToken: aString to: aBuffer - "puts the new token to the buffer only if it is not empty" - aString ifNotEmpty: [aBuffer add: (RTFToken newString: aString)]! ! -!RTFTokenizer methodsFor: 'private' stamp: 'mir 8/12/2006 14:24'! - chunkBuffer - ^chunkBuffer ifNil: [chunkBuffer := String new: 2048]! ! -!RTFTokenizer methodsFor: 'private' stamp: 'mir 8/11/2006 20:54'! - controlSymbolSet - ^ControlSymbolSet! ! -!RTFTokenizer methodsFor: 'private' stamp: 'mir 8/11/2006 21:01'! - endOfKeywordSet - ^EndOfKeywordSet! ! -!RTFTokenizer methodsFor: 'tokenizing' stamp: 'MR 5/5/2006 14:30'! - getToken - - self readNext. - ^self peekLast! ! -!RTFTokenizer methodsFor: 'tokenizing' stamp: 'kalin 5/6/2006 01:04'! - lookAhead: n - "peeks n tokens ahead where n is less or equal to 3" - - n = 0 ifTrue: [^self peekLast]. - n = 1 ifTrue: [^self peekNext]. - n = 2 ifTrue: [^self peekAfterNext]. - n = 3 ifTrue: [^self peekAfterAfter]. -! ! -!RTFTokenizer methodsFor: 'tokenizing' stamp: 'kalin 5/6/2006 01:05'! - moreTokens - "are there any tokens left?" - - ^next notNil -! ! -!RTFTokenizer methodsFor: 'private' stamp: 'tat 8/13/2007 11:00'! - on: aStream - - "this message expects proper RTF as input" - - stream := aStream. - last := nil. - buffer := stream upTo: $\. - (buffer = '{') - ifTrue: [next := RTFToken newBlockOpen] - ifFalse: [RTFException new signal: 'Not a valid RTF file']. - self parseChunk. - "buffer cannot be empty" - afterNext := buffer removeFirst. - buffer ifEmpty: [self parseChunk]. - afterAfter := buffer removeFirst. - - - -! ! -!RTFTokenizer methodsFor: 'private' stamp: 'jmv 11/3/2016 10:13:12'! - parseChunk - - "reads a string between two backslashes into buffer" - - | index token word arg tokenFirst tokenStream | - - buffer := OrderedCollection new. - stream atEnd ifTrue: [^buffer]. - - tokenStream := self chunkBuffer writeStream. - self readStreamUpToNoEscapeInto: tokenStream. - token := tokenStream contents. - - "control words start with alphabetic character, - control symbols are special character" - - index := 1. - tokenFirst := token first. - (self controlSymbolSet includes: tokenFirst) - ifTrue: [ - buffer add: (RTFToken newKeyword: (tokenFirst asString)). - index := index+1] - ifFalse: [ "this is a keyword" - index := token indexOfAnyOf: self endOfKeywordSet. - (index = 0) - ifTrue: [ - buffer add: (RTFToken newKeyword: token). - ^buffer] - ifFalse: [ - word := token truncateTo: (index - 1). - ((token at: index) isDigit - or: [(token at: index) = $-]) - ifTrue: [ - token := token copyFrom: index to: token size. - index _ token findFirst: [ :c | c isDigit not and: [ c ~= $- ]]. - (index = 0) - "if no separator or brace found, then whole chunk is a number" - ifTrue: [arg := token asNumber. - buffer add: (RTFToken newKeyword: word withArg: arg). - ^buffer] - ifFalse: [ - arg := (token truncateTo: (index - 1)) asNumber. - buffer add: (RTFToken newKeyword: word withArg: arg). - (token at: index) isSeparator - ifTrue: [index := index+1]]] - ifFalse: [ - buffer add: (RTFToken newKeyword: word). - (token at: index) isSeparator ifTrue: [index := index+1]. - ] - ]. - ]. - - self parseNoKeywordChunk: token startingAt: index. - - ^buffer! ! -!RTFTokenizer methodsFor: 'private' stamp: 'mir 8/12/2006 16:04'! - parseNoKeywordChunk: aString startingAt: index - "reads a string without \ into buffer" - "tokenizes on {, and then tokenizes chunks on }" - - RTFChunkScanner new scan: aString into: buffer startingAt: index - -" | chunkStream nextChar bufferStream charValue | - - chunkStream := ReadStream on: aString. - bufferStream := WriteStream on: self chunkBuffer. - [chunkStream atEnd] whileFalse: [ - nextChar := chunkStream next. - charValue := nextChar asciiValue. - charValue = 123 - ifTrue: [ - self addStringToken: bufferStream contents. - bufferStream reset. - buffer add: (RTFToken newBlockOpen)] - ifFalse: [ - charValue = 125 - ifTrue: [ - self addStringToken: bufferStream contents. - bufferStream reset. - buffer add: (RTFToken newBlockClose)] - ifFalse: [ - (charValue = 10 - or: [charValue = 13]) - ifFalse: [bufferStream nextPut: nextChar]]]]. - self addStringToken: bufferStream contents -"! ! -!RTFTokenizer methodsFor: 'accesing' stamp: 'MR 5/3/2006 10:51'! - peekAfterAfter - ^afterAfter! ! -!RTFTokenizer methodsFor: 'accesing' stamp: 'MR 4/30/2006 23:41'! - peekAfterNext - ^afterNext! ! -!RTFTokenizer methodsFor: 'accesing' stamp: 'MR 4/30/2006 23:40'! - peekLast - ^last! ! -!RTFTokenizer methodsFor: 'accesing' stamp: 'MR 4/30/2006 23:40'! - peekNext - ^next! ! -!RTFTokenizer methodsFor: 'accesing' stamp: 'MR 7/4/2006 10:54'! - readNext - last := next. - next := afterNext. - afterNext := afterAfter. - buffer ifEmpty: [self parseChunk]. - buffer ifEmpty: [afterAfter := nil] ifNotEmpty: [afterAfter := buffer removeFirst] -! ! -!RTFTokenizer methodsFor: 'private' stamp: 'jmv 9/5/2016 20:33:12'! - readStreamUpToNoEscapeInto: tokenStream - "reads from the stream until the \ at the end is not an escape character (i.e. not \\,\{ or \}" - "assume that stream is not at end" - | token peek index peekValue | - - token := (stream upTo: $\). - index := 1. - - "convert newline (#10#13, #13#10) to \par - convert \'HH to \specialDDD" - token ifNotEmpty: [ - peekValue := (token at: 1) numericValue. - peekValue = 10 - ifTrue: [ - index := index + 1. - token size > 1 - ifTrue: [ - peekValue := (token at: 2) numericValue. - peekValue = 13 - ifTrue: [index := index + 1]]. - tokenStream - nextPutAll: 'par '; - nextPutAll: (token copyFrom: index to: token size)] - ifFalse: [ - peekValue = 13 - ifTrue: [ - index := index + 1. - token size > 1 - ifTrue: [ - peekValue := (token at: 2) numericValue. - peekValue = 10 - ifTrue: [index := index + 1]]. - tokenStream - nextPutAll: 'par '; - nextPutAll: (token copyFrom: index to: token size)] - ifFalse: ["a non-ascii characters" - peekValue = 39 "$' numericValue" - ifTrue: [ - tokenStream - nextPutAll: 'SomeCodePageHexValue'; - nextPutAll: (Integer readFrom: ((token copyFrom: 2 to: 3) asUppercase) readStream base: 16) asString; - nextPutAll: ' '; - nextPutAll: (token copyFrom: 4 to: token size)] - ifFalse: [tokenStream nextPutAll: token]]]]. - - "if token is empty, than we have \\ and read next token" - "similar if first character is { or }" - peek := stream peek. -" tokenStream nextPutAll: token." - peek ifNil: [^self]. - - peek = $\ - ifTrue: [ - tokenStream nextPut: stream next. - self readStreamUpToNoEscapeInto: tokenStream] -! ! -!RTFTokenizer methodsFor: 'accesing' stamp: 'tat 5/4/2006 00:46'! - tokenClass - "the token class used by this tokenizer" - ^RTFToken! ! -!RTFTokenizer class methodsFor: 'class initialization' stamp: 'jmv 11/3/2016 10:13:35'! - initialize - "RTFTokenizer initialize" - - EndOfKeywordSet := CharacterSet new. - (0 to: ($A numericValue - 1)) do: - [:v | EndOfKeywordSet add: (Character numericValue: v)]. - (($Z numericValue + 1) to: ($a numericValue - 1)) do: - [:v | EndOfKeywordSet add: (Character numericValue: v)]. - (($z numericValue + 1) to: 255) do: - [:v | EndOfKeywordSet add: (Character numericValue: v)]. - - " \'hh is handled separately. it is converted to \sophieUtfHexDDD" - ControlSymbolSet _ CharacterSet newFrom: '|~-_:*{}'! ! -!RTFTokenizer class methodsFor: 'instance creation' stamp: 'mir 8/11/2006 20:57'! - newFromString: aString - ^self on: aString readStream! ! -!RTFTokenizer class methodsFor: 'instance creation' stamp: 'mir 8/11/2006 20:57'! - on: aStream - ^self new on: aStream! ! -!RTFUnicode class methodsFor: 'compatibility' stamp: 'jmv 9/5/2016 20:30:17'! - codePoint: unicodeCodePoint - ^self codePoint: unicodeCodePoint or: $?! ! -!RTFUnicode class methodsFor: 'compatibility' stamp: 'jmv 9/5/2016 20:30:11'! - codePoint: unicodeCodePoint or: aCharacter - "In Cuis, #codePoint: handles those Unicode characters that are present in the ISO8859-15 char set" - ^(Character codePoint: unicodeCodePoint) ifNil: [ aCharacter ]! ! - -RTFChunkScanner initialize! - -RTFParser initialize! - -RTFTextBuilder initialize! - -RTFToken initialize! - -RTFTokenizer initialize! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-StyledTextEditor/RTFImporting.pck.st----! - -'From Cuis 4.2 of 25 July 2013 [latest update: #2933] on 6 September 2016 at 10:05:12 am'! - -'Description Please enter a description for this package.'! -!String methodsFor: '*rtfExporting' stamp: 'jmv 9/5/2016 20:27:00'! - iso8859s15ToRTFEncoding - "Convert the given string to RTF escaped Unicode from the internal encoding: ISO Latin 9 (ISO 8859-15)" - " - self assert: ('A¢¤' iso8859s15ToRTFEncoding) hex = ' 'A\u162?\u8364?'' - " - | c cp | - ^String streamContents: [ :strm | | characters | - characters _ self readStream. - [ characters atEnd ] whileFalse: [ - c _ characters next. - cp _ c codePoint. - cp < 128 - ifTrue: [ strm nextPut: c ] - ifFalse: [ - strm - nextPut: $\; - nextPut: $u. - cp printOn: strm. - strm nextPut: $? ]]]! ! -!Text methodsFor: '*rtfExporting' stamp: 'jmv 11/22/2011 15:30'! - rtfString - " - | text | - text _ RTFConversionTest textSample1 asStyledText. - StyledTextModel new contents: text; openAsStyledEditorLabel: 'Styled Text Editor' inWorld: World. - Clipboard default storeObject: text - " - | prevAttributes colors fonts s | - "Build colors and fonts tables" - colors _ Set new. - fonts _ Set new. - runs withStartStopAndValueDo: [ :start :stop :attributes | - attributes do: [ :attribute | - attribute forParagraphStyleReferenceDo: [ :ts | ts color ifNotNil: [ :color | colors add: color ]]. - attribute forCharacterStyleReferenceDo: [ :cs | cs color ifNotNil: [ : color | colors add: color ]]. - attribute forTextColorDo: [ :color | colors add: color ]. - attribute forBaseFontDo: [ :font | fonts add: font familyName ]]]. - colors _ colors asArray. - fonts _ fonts asArray. - ^String - streamContents: [ :strm | - self writeRTFHeaderOn: strm colorTable: colors fontTable: fonts. - prevAttributes _ #(). - runs withStartStopAndValueDo: [ :start :stop :attributes | | currentAttributes actualStart | - currentAttributes _ attributes asSet. - "Close attributes no longer present" - prevAttributes do: [ :each | - (currentAttributes includes: each) ifFalse: [ - each writeRTFStopOn: strm colorTable: colors fontTable: fonts ]]. - "Open attributes not previously present" - actualStart _ start. - currentAttributes do: [ :each | - "Repeat existing, because the closing of other attributes, in some cases, sets defaults, and not the now active values... - For example, finishing a CharStyle sets text to black. But what if the ParaStyle indicated some other color?" - "(prevAttributes includes: each) ifFalse: [" - actualStart _ actualStart + (each writeRTFStartOn: strm colorTable: colors fontTable: fonts) - "]" - ]. - "Add string now" - s _ string copyFrom: actualStart to: stop. - s _ s withLineEndings: '\par '. - s _ s iso8859s15ToRTFEncoding. - strm nextPutAll: s. - prevAttributes _ currentAttributes ]. - strm nextPut: $} ] - estimatedSize: string size! ! -!Text methodsFor: '*rtfExporting' stamp: 'jmv 3/13/2012 12:55'! - writeRTFHeaderOn: aStream colorTable: colorArray fontTable: fontNamesArray - - aStream nextPutAll: '{\rtf'; newLine. - - aStream nextPutAll: '{\colortbl;'. - colorArray do: [:each | - aStream - nextPutAll: '\red'; nextPutAll: (each red * 255) rounded asString; - nextPutAll: '\green'; nextPutAll: (each green * 255) rounded asString; - nextPutAll: '\blue'; nextPutAll: (each blue * 255) rounded asString; - nextPut: $; ]. - aStream nextPutAll: '}'; newLine! ! -!Text class methodsFor: '*rtfExporting' stamp: 'jmv 11/1/2011 10:40'! - pointSizeConversionFactor - "This constant is used for conversion of font point sizes ofr RTF export and import. - In theory, it shouldn't be needed. After all, a 72point font in RTF should be imported as a 72 point font in Cuis. - - Cuis uses 96 pixels per inch. This means that the inter baseline height for a 72 point font is (at least) 96 pixels. - This is also the convention used (by default) on Windows, so fonts look about the same in Cuis and in Windows native software (such as Wordpad). - But the Mac uses (by default) a convention of 72 pixels per inch. So, text on the Mac looks smaller. - If this method is modified to answer 96/72, then text on the Mac will look the same as in Cuis. This could be good to make Mac users happy, as long as we never show them the point size we believe our fonts have. The font that they happily use export and import content, and to look side by side, that is called '12 points' in Mac software, well call '9 point'" - "^1.33333" - ^1! ! -!TextAttribute methodsFor: '*rtfExporting' stamp: 'jmv 1/24/2011 11:51'! - writeRTFStartOn: aStream colorTable: colorArray fontTable: fontArray - "Write the RTF code for attribute start. Return number of characters to skip (usually 0)" - ^0! ! -!TextAttribute methodsFor: '*rtfExporting' stamp: 'jmv 1/21/2011 13:41'! - writeRTFStopOn: aStream colorTable: colorArray fontTable: fontArray - "Write the RTF code for attribute stop."! ! -!TextAlignment methodsFor: '*rtfExporting' stamp: 'jmv 1/24/2011 11:52'! - writeRTFStartOn: aStream colorTable: colorArray fontTable: fontArray - "Write the RTF code for attribute start. Return number of characters to skip (usually 0)" - alignment caseOf: { - [ 0 ] -> [ aStream nextPutAll: '\ql ' ]. - [ 1 ] -> [ aStream nextPutAll: '\qr ' ]. - [ 2 ] -> [ aStream nextPutAll: '\qc ' ]. - [ 3 ] -> [ aStream nextPutAll: '\qj ' ] }. - ^0! ! -!TextAlignment methodsFor: '*rtfExporting' stamp: 'jmv 1/21/2011 14:57'! - writeRTFStopOn: aStream colorTable: colorArray fontTable: fontArray - "Write the RTF code for attribute stop." - aStream nextPutAll: '\ql '! ! -!TextColor methodsFor: '*rtfExporting' stamp: 'jmv 1/24/2011 11:52'! - writeRTFStartOn: aStream colorTable: colorArray fontTable: fontArray - "Write the RTF code for attribute start. Return number of characters to skip (usually 0)" - aStream nextPutAll: '\cf'; nextPutAll: (colorArray indexOf: color) asString; space. - ^0! ! -!TextColor methodsFor: '*rtfExporting' stamp: 'jmv 1/21/2011 13:51'! - writeRTFStopOn: aStream colorTable: colorArray fontTable: fontArray - "Write the RTF code for attribute stop." - aStream nextPutAll: '\cf0 '! ! -!TextEmphasis methodsFor: '*rtfExporting' stamp: 'jmv 4/1/2016 13:45'! - writeRTFStartOn: aStream colorTable: colorArray fontTable: fontArray - "Write the RTF code for attribute start. Return number of characters to skip (usually 0)" - - (emphasisCode allMask: AbstractFont boldCode) ifTrue: [ - aStream nextPutAll: '\b ' ]. - (emphasisCode allMask: AbstractFont italicCode) ifTrue: [ - aStream nextPutAll: '\i ' ]. - (emphasisCode allMask: AbstractFont underlinedCode) ifTrue: [ - aStream nextPutAll: '\ul ' ]. - (emphasisCode allMask: AbstractFont struckThroughCode) ifTrue: [ - aStream nextPutAll: '\strike \strikec0 ' ]. - ^0! ! -!TextEmphasis methodsFor: '*rtfExporting' stamp: 'jmv 4/1/2016 13:46'! - writeRTFStopOn: aStream colorTable: colorArray fontTable: fontArray - "Write the RTF code for attribute stop. - Do it in the inverse order of writeRTFStartOn:colorTable:fontTable:" - - (emphasisCode allMask: AbstractFont struckThroughCode) ifTrue: [ - aStream nextPutAll: '\strike0\striked0 ' ]. - (emphasisCode allMask: AbstractFont underlinedCode) ifTrue: [ - aStream nextPutAll: '\ulnone ' ]. - (emphasisCode allMask: AbstractFont italicCode) ifTrue: [ - aStream nextPutAll: '\i0 ' ]. - (emphasisCode allMask: AbstractFont boldCode) ifTrue: [ - aStream nextPutAll: '\b0 ' ]! ! -!TextFontFamilyAndSize methodsFor: '*rtfExporting' stamp: 'jmv 4/12/2011 09:06'! - writeRTFStartOn: aStream colorTable: colorArray fontTable: fontArray - "Write the RTF code for attribute start. Return number of characters to skip (usually 0)" - "We should also reference familyName, in the table with \f# where # is the number in the table..." - - aStream nextPutAll: '\fs'; nextPutAll: ((pointSize * Text pointSizeConversionFactor ) rounded * 2) asString; space. - ^0! ! -!TextFontFamilyAndSize methodsFor: '*rtfExporting' stamp: 'jmv 4/7/2011 15:20'! - writeRTFStopOn: aStream colorTable: colorArray fontTable: fontArray - "Write the RTF code for attribute stop." - aStream nextPutAll: '\fs0 '! ! -!TextAnchor methodsFor: '*rtfExporting' stamp: 'jmv 4/7/2011 15:08'! - writeRTFStartOn: aStream colorTable: colorArray fontTable: fontArray - "Write the RTF code for attribute start. Return number of characters to skip: one in this case" - aStream - nextPutAll: '{\*\shppict{\pict\pngblip '; - nextPutAll: (PNGReadWriter bytesFor: anchoredFormOrMorph) hex; - nextPutAll: '}}'. - "Skip the character holding the attribute" - ^1! ! -!TextAnchor methodsFor: '*rtfExporting' stamp: 'jmv 1/24/2011 11:12'! - writeRTFStopOn: aStream colorTable: colorArray fontTable: fontArray - "Write the RTF code for attribute stop."! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-StyledTextEditor/RTFExporting.pck.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3165] on 6 September 2017 at 10:11:06 am'! - -'Description Please enter a description for this package'! - -Editor subclass: #SimpleEditor - instanceVariableNames: 'string pointIndex markIndex' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets-Extras'! - -!classDefinition: #SimpleEditor category: #'Morphic-Widgets-Extras'! -Editor subclass: #SimpleEditor - instanceVariableNames: 'string pointIndex markIndex' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets-Extras'! - -SimpleEditor class - instanceVariableNames: ''! - -!classDefinition: 'SimpleEditor class' category: #'Morphic-Widgets-Extras'! -SimpleEditor class - instanceVariableNames: ''! - -TextModelMorph subclass: #LimitedHeightTextMorph - instanceVariableNames: 'maxHeight' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets-Extras'! - -!classDefinition: #LimitedHeightTextMorph category: #'Morphic-Widgets-Extras'! -TextModelMorph subclass: #LimitedHeightTextMorph - instanceVariableNames: 'maxHeight' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets-Extras'! - -LimitedHeightTextMorph class - instanceVariableNames: ''! - -!classDefinition: 'LimitedHeightTextMorph class' category: #'Morphic-Widgets-Extras'! -LimitedHeightTextMorph class - instanceVariableNames: ''! - -BorderedRectMorph subclass: #MagnifierMorph - instanceVariableNames: 'magnification trackPointer lastPos srcExtent auxCanvas magnifiedForm' - classVariableNames: 'RecursionLock' - poolDictionaries: '' - category: 'Morphic-Widgets-Extras'! - -!classDefinition: #MagnifierMorph category: #'Morphic-Widgets-Extras'! -BorderedRectMorph subclass: #MagnifierMorph - instanceVariableNames: 'magnification trackPointer lastPos srcExtent auxCanvas magnifiedForm' - classVariableNames: 'RecursionLock' - poolDictionaries: '' - category: 'Morphic-Widgets-Extras'! - -MagnifierMorph class - instanceVariableNames: ''! - -!classDefinition: 'MagnifierMorph class' category: #'Morphic-Widgets-Extras'! -MagnifierMorph class - instanceVariableNames: ''! - -RectangleLikeMorph subclass: #DragAndDropAreaMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets-Extras'! - -!classDefinition: #DragAndDropAreaMorph category: #'Morphic-Widgets-Extras'! -RectangleLikeMorph subclass: #DragAndDropAreaMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets-Extras'! - -DragAndDropAreaMorph class - instanceVariableNames: ''! - -!classDefinition: 'DragAndDropAreaMorph class' category: #'Morphic-Widgets-Extras'! -DragAndDropAreaMorph class - instanceVariableNames: ''! - -DragAndDropAreaMorph subclass: #PartsBinMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets-Extras'! - -!classDefinition: #PartsBinMorph category: #'Morphic-Widgets-Extras'! -DragAndDropAreaMorph subclass: #PartsBinMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets-Extras'! - -PartsBinMorph class - instanceVariableNames: ''! - -!classDefinition: 'PartsBinMorph class' category: #'Morphic-Widgets-Extras'! -PartsBinMorph class - instanceVariableNames: ''! - -RectangleLikeMorph subclass: #FrameRateMorph - instanceVariableNames: 'lastStepDelta meanStepDelta' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets-Extras'! - -!classDefinition: #FrameRateMorph category: #'Morphic-Widgets-Extras'! -RectangleLikeMorph subclass: #FrameRateMorph - instanceVariableNames: 'lastStepDelta meanStepDelta' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets-Extras'! - -FrameRateMorph class - instanceVariableNames: ''! - -!classDefinition: 'FrameRateMorph class' category: #'Morphic-Widgets-Extras'! -FrameRateMorph class - instanceVariableNames: ''! - -RectangleLikeMorph subclass: #FunctionGraphMorph - instanceVariableNames: 'xMin xMax yMin yMax functions colors' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets-Extras'! - -!classDefinition: #FunctionGraphMorph category: #'Morphic-Widgets-Extras'! -RectangleLikeMorph subclass: #FunctionGraphMorph - instanceVariableNames: 'xMin xMax yMin yMax functions colors' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets-Extras'! - -FunctionGraphMorph class - instanceVariableNames: ''! - -!classDefinition: 'FunctionGraphMorph class' category: #'Morphic-Widgets-Extras'! -FunctionGraphMorph class - instanceVariableNames: ''! - -RectangleLikeMorph subclass: #MinimalStringMorph - instanceVariableNames: 'font emphasis contents' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets-Extras'! - -!classDefinition: #MinimalStringMorph category: #'Morphic-Widgets-Extras'! -RectangleLikeMorph subclass: #MinimalStringMorph - instanceVariableNames: 'font emphasis contents' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets-Extras'! - -MinimalStringMorph class - instanceVariableNames: ''! - -!classDefinition: 'MinimalStringMorph class' category: #'Morphic-Widgets-Extras'! -MinimalStringMorph class - instanceVariableNames: ''! - -RectangleLikeMorph subclass: #OneLineEditorMorph - instanceVariableNames: 'font emphasis contents editor showTextCursor pauseBlinking textCursorRect keyboardFocusWatcher crAction' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets-Extras'! - -!classDefinition: #OneLineEditorMorph category: #'Morphic-Widgets-Extras'! -RectangleLikeMorph subclass: #OneLineEditorMorph - instanceVariableNames: 'font emphasis contents editor showTextCursor pauseBlinking textCursorRect keyboardFocusWatcher crAction' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets-Extras'! - -OneLineEditorMorph class - instanceVariableNames: ''! - -!classDefinition: 'OneLineEditorMorph class' category: #'Morphic-Widgets-Extras'! -OneLineEditorMorph class - instanceVariableNames: ''! -!SimpleEditor commentStamp: '' prior: 0! - See comment in Editor! -!LimitedHeightTextMorph commentStamp: '' prior: 0! - A TextMorph that will expand and contract vertically to adjust for the contents, but limited to a specific max height. If contents are larger, a scrollbar will be used. - -LimitedHeightTextMorph new - maxHeight: 48; - model: (TextModel new contents: 'This is some text to test the morph.'); - openInWorld! -!MagnifierMorph commentStamp: '' prior: 0! - Provides a magnifying glass. Magnifies the morphs below (if grabbed) or the area around the mouse pointer.! -!DragAndDropAreaMorph commentStamp: '' prior: 0! - A simple morph that allows dragging submorphs, and dropping other morphs on it. It is provided as an example, and also as a reference of the methods you might need to implement in your morphs to handle drag and drop. - -| m | -m _ DragAndDropAreaMorph new. -m openInWorld. -m addMorph: EllipseMorph new. -m morphExtent: 320@240! -!PartsBinMorph commentStamp: '' prior: 0! - Like DragAndDropAreaMorph, but when submorphs are dragged, get a copy and not the original one. - -| m | -m _ PartsBinMorph new. -m openInWorld. -m addMorph: EllipseMorph new. -m morphExtent: 120@240! -!FrameRateMorph commentStamp: 'jmv 6/11/2012 10:14' prior: 0! - A very simple morph to demo stepping, and for knowing about stepping (and world update) frame rates. - -FrameRateMorph new openInHand! -!FunctionGraphMorph commentStamp: 'jmv 7/1/2015 11:28' prior: 0! - | g d | -d _ -1. -g _ FunctionGraphMorph new. -g domain: (-4 to: 4). -g addFunction: [ :x | x \\ d ] color: Color green. -g addFunction: [ :x | x // d ] color: Color red. -(g embeddedInMorphicWindowLabeled: 'graph') openInWorld - -| g d | -d _ -1. -g _ FunctionGraphMorph new. -g domain: (-4 to: 4). -g addFunction: [ :x | x rem: d ] color: Color green. -g addFunction: [ :x | x quo: d ] color: Color red. -g openInWorld - -| g d | -d _ -1. -g _ FunctionGraphMorph new. -g domain: (-4 to: 4). -g addFunction: [ :x | x mod: d ] color: Color green. -g addFunction: [ :x | x div: d ] color: Color red. -g openInWorld -! -!MinimalStringMorph commentStamp: 'jmv 4/1/2009 21:43' prior: 0! - A greatly reduced StringMorph. May be of some use.! -!OneLineEditorMorph commentStamp: '' prior: 0! - A plain text editor for Morphic. Handles only one line. Does not handle fonts/styles, alignment, Smalltalk utilities and any other advanced stuff in TextModelMorph. Just a simple text editor. - -Can optionally include a crAction: a zero argument closure, to be evaluated on Cr keystroke.! -!SimpleEditor methodsFor: 'typing support' stamp: 'jmv 12/19/2011 12:24'! - addString: aString - "Think of a better name" - - self replaceSelectionWith: aString! ! -!SimpleEditor methodsFor: 'typing support' stamp: 'jmv 12/19/2011 12:24'! - backTo: startIndex - "During typing, backspace to startIndex." - - self markIndex: startIndex. - self replaceSelectionWith: ''. - self markIndex: self pointIndex! ! -!SimpleEditor methodsFor: 'initialization' stamp: 'jmv 11/4/2008 13:08'! - changeString: aString - "Install aString as the one to be edited by the receiver." - - string _ aString. - self resetState! ! -!SimpleEditor methodsFor: 'events' stamp: 'jmv 8/21/2012 08:42'! - clickAndHalf - - | here | - here _ self pointIndex. - (here between: 2 and: string size) - ifTrue: [ self selectWord ] - ifFalse: [ - "if at beginning or end, select entire string" - self selectAll ].! ! -!SimpleEditor methodsFor: 'menu messages' stamp: 'jmv 10/16/2013 22:37'! - copySelection - "Copy the current selection and store it in the Clipboard, unless empty." - - self lineSelectAndEmptyCheck: [^ self]. - self clipboardTextPut: self selection! ! -!SimpleEditor methodsFor: 'nonediting/nontyping keys' stamp: 'jmv 9/19/2011 09:12'! - cursorEnd: aKeyboardEvent - "Private - Move cursor end of current line." - - self - moveCursor: [ :dummy | self endOfText ] - forward: true - event: aKeyboardEvent. - ^ true.! ! -!SimpleEditor methodsFor: 'nonediting/nontyping keys' stamp: 'jmv 9/17/2010 13:42'! - cursorHome: aKeyboardEvent - - "Private - Move cursor from position in current line to beginning of - current line. If control key is pressed put cursor at beginning of text" - - self - moveCursor: [ :dummy | self beginningOfText ] - forward: false - event: aKeyboardEvent. - ^true! ! -!SimpleEditor methodsFor: 'menu messages' stamp: 'jmv 9/22/2011 17:09'! - cut - "Cut out the current selection and redisplay the paragraph if necessary." - - | selection | - self lineSelectAndEmptyCheck: [^ self]. - selection _ self selection. - self replaceSelectionWith: ''. - self clipboardTextPut: selection! ! -!SimpleEditor methodsFor: 'typing support' stamp: 'jmv 6/10/2012 11:14'! - dispatchOn: aKeyboardEvent - "Carry out the action associated with this character, if any." - | asciiValue | - asciiValue _ aKeyboardEvent keyValue. - "Control keys are handled by #shortcuts even if they have any modifiers" - (asciiValue >= 32 and: [ - aKeyboardEvent commandAltKeyPressed ]) ifTrue: [ - ^self perform: (self cmdShortcuts at: asciiValue + 1) with: aKeyboardEvent ]. - - "We don't support multiple lines. Therefore, we don't process return as a #normalCharacter:" - aKeyboardEvent isReturnKey ifTrue: [ - ^ true]. - - ^ self perform: (self shortcuts at: asciiValue + 1) with: aKeyboardEvent! ! -!SimpleEditor methodsFor: 'typing/selecting keys' stamp: 'jmv 12/19/2011 12:24'! - forwardDelete: aKeyboardEvent - "Delete forward over the next character." - - | startIndex stopIndex | - startIndex _ self markIndex. - startIndex > string size ifTrue: [ - ^ false]. - self hasSelection ifTrue: [ - "there was a selection" - self replaceSelectionWith: ''. - ^ false]. - "Null selection - do the delete forward" - stopIndex := startIndex. - (aKeyboardEvent keyValue = 127 and: [ aKeyboardEvent shiftPressed ]) - ifTrue: [ stopIndex := (self nextWordStart: stopIndex) - 1 ]. - self selectFrom: startIndex to: stopIndex. - self replaceSelectionWith: ''. - self deselectAndPlaceCursorAt: startIndex. - ^false! ! -!SimpleEditor methodsFor: 'accessing-selection' stamp: 'jmv 10/16/2013 22:17'! - hasSelection - ^markIndex ~= pointIndex! ! -!SimpleEditor methodsFor: 'initialization' stamp: 'jmv 11/4/2008 13:42'! - initialize - "Initialize the state of the receiver. Subclasses should include 'super - initialize' when redefining this message to insure proper initialization." - - super initialize. - self changeString: ''! ! -!SimpleEditor methodsFor: 'testing' stamp: 'jmv 11/17/2008 17:01'! - isAtEnd - ^pointIndex = (string size + 1)! ! -!SimpleEditor methodsFor: 'testing' stamp: 'jmv 11/17/2008 17:01'! - isAtStart - ^pointIndex = 1! ! -!SimpleEditor methodsFor: 'editing keys' stamp: 'jmv 9/2/2009 12:40'! - makeCapitalized: aKeyboardEvent - "Force the current selection to uppercase. Triggered by Cmd-X." - | prev | - prev _ $-. "not a letter" - self replaceSelectionWith: - (self selection collect: [:c | - prev _ prev isLetter ifTrue: [c asLowercase] ifFalse: [c asUppercase]]). - ^ true! ! -!SimpleEditor methodsFor: 'editing keys' stamp: 'jmv 12/19/2011 12:22'! - makeLowercase: aKeyboardEvent - "Force the current selection to lowercase. Triggered by Cmd-X." - - self replaceSelectionWith: self selection asLowercase. - ^ true! ! -!SimpleEditor methodsFor: 'editing keys' stamp: 'jmv 12/19/2011 12:22'! - makeUppercase: aKeyboardEvent - "Force the current selection to uppercase. Triggered by Cmd-Y." - - self replaceSelectionWith: self selection asUppercase. - ^ true! ! -!SimpleEditor methodsFor: 'accessing-selection' stamp: 'jmv 11/4/2008 13:57'! - markIndex - ^markIndex! ! -!SimpleEditor methodsFor: 'accessing-selection' stamp: 'jmv 11/5/2008 11:41'! - markIndex: anIndex - markIndex _ anIndex min: string size + 1 max: 1! ! -!SimpleEditor methodsFor: 'accessing-selection' stamp: 'jmv 5/27/2011 15:25'! - markIndex: anIndex pointIndex: anotherIndex - markIndex _ anIndex min: string size + 1 max: 1. - pointIndex _ anotherIndex min: string size + 1 max: 1! ! -!SimpleEditor methodsFor: 'events' stamp: 'jmv 12/29/2011 14:51'! - mouseDown: evt index: index - - evt shiftPressed - ifFalse: [ - self markIndex: index pointIndex: index ] - ifTrue: [ - self mouseMove: evt index: index ]! ! -!SimpleEditor methodsFor: 'events' stamp: 'jmv 5/27/2011 15:23'! - mouseMove: evt index: index - "Change the selection in response to mouse-down drag" - - self pointIndex: index! ! -!SimpleEditor methodsFor: 'accessing-selection' stamp: 'jmv 11/4/2008 13:57'! - pointIndex - ^ pointIndex! ! -!SimpleEditor methodsFor: 'accessing-selection' stamp: 'jmv 11/5/2008 11:41'! - pointIndex: anIndex - pointIndex _ anIndex min: string size + 1 max: 1! ! -!SimpleEditor methodsFor: 'private' stamp: 'jmv 9/20/2011 08:46'! - privateCurrentString - "Answer the string I'm editing. Private. Just for internal Editor use." - - ^string! ! -!SimpleEditor methodsFor: 'typing support' stamp: 'jmv 9/19/2011 09:47'! - processKeyStroke: aKeyboardEvent - - "Key struck on the keyboard. Find out which one and, if special, carry - out the associated special action. Otherwise, add the character to the - stream of characters." - - (self dispatchOn: aKeyboardEvent) ifTrue: [ - ^self]. - self markIndex: self pointIndex! ! -!SimpleEditor methodsFor: 'accessing' stamp: 'jmv 9/6/2017 10:02:17'! - replaceSelectionWith: aString - "Deselect, and replace the selection text by aText." - - | start stop | - morph disablesEditing ifTrue: [ - ^ self ]. - start _ self startIndex. - stop _ self stopIndex. - (start = stop and: [aString size = 0]) ifFalse: [ - string _ string copyReplaceFrom: start to: stop-1 with: aString. - self deselectAndPlaceCursorAt: start + aString size. - self userHasEdited " -- note text now dirty" ]! ! -!SimpleEditor methodsFor: 'initialization' stamp: 'jmv 10/16/2013 22:37'! - resetState - "Establish the initial conditions for editing the paragraph: place text cursor - before first character, set the emphasis to that of the first character, - and save the paragraph for purposes of canceling." - - pointIndex _ 1. "Like pointBlock in TextEditor" - markIndex _ 1. "Like markBlock in TextEditor"! ! -!SimpleEditor methodsFor: 'private' stamp: 'jmv 3/16/2011 10:44'! - sameColumn: start newLine: lineBlock forward: isForward - "See comment in other implementors." - ^start! ! -!SimpleEditor methodsFor: 'new selection' stamp: 'jmv 9/19/2011 09:12'! - selectFrom: start to: stop - - "Select the specified characters inclusive." - self selectInvisiblyFrom: start to: stop! ! -!SimpleEditor methodsFor: 'new selection' stamp: 'jmv 10/16/2013 22:10'! -selectLine - "Make the receiver's selection, if currently empty, encompass the current line." - self hasSelection ifTrue:[^self]. - self selectAll! ! -!SimpleEditor methodsFor: 'accessing-selection' stamp: 'jmv 1/31/2013 21:09'! - selection - - | firstIndex lastIndex | - firstIndex _ self startIndex. - lastIndex _ self stopIndex - 1. - - (firstIndex = 1 and: [ lastIndex = string size ]) - ifTrue: [ ^string ]. - - ^string copyFrom: firstIndex to: lastIndex! ! -!SimpleEditor methodsFor: 'accessing-selection' stamp: 'jmv 11/4/2008 13:55'! - startIndex - ^ pointIndex min: markIndex! ! -!SimpleEditor methodsFor: 'accessing-selection' stamp: 'jmv 11/4/2008 13:55'! - stopIndex - ^ pointIndex max: markIndex! ! -!SimpleEditor methodsFor: 'accessing' stamp: 'jmv 9/22/2011 16:52'! - string - ^string! ! -!SimpleEditor class methodsFor: 'keyboard shortcut tables' stamp: 'jmv 6/10/2012 11:07'! - cmdShortcutsSpec - " - Editor initialize - " - "arranged in QWERTY keyboard order" - ^#( - #( $a #selectAll: 'Select all') - - #( $x #cut: 'Cut selection and store it in the Clipboard') - #( $c #copySelection: 'Copy selection to the Clipboard') - #( $v #paste: 'Paste Clipboard contents') - #( $ #selectWord: 'Select the current word as with double clicking') - )! ! -!LimitedHeightTextMorph methodsFor: 'initialization' stamp: 'jmv 8/21/2012 21:59'! - initialize - super initialize. - extent _ 200 @ 120! ! -!LimitedHeightTextMorph methodsFor: 'geometry' stamp: 'jmv 12/12/2011 14:20'! - innerHeight: aNumber - "Adjust height and scrollbar to the new contents height." - self morphHeight: (aNumber + 10 min: maxHeight)! ! -!LimitedHeightTextMorph methodsFor: 'accessing' stamp: 'jmv 11/14/2011 16:32'! - maxHeight: aNumber - maxHeight _ aNumber! ! -!LimitedHeightTextMorph methodsFor: 'geometry' stamp: 'jmv 7/20/2014 10:12'! - privateExtent: aPoint - - ^ (super privateExtent: aPoint) - ifTrue: [ - maxHeight _ extent y ]; yourself! ! -!LimitedHeightTextMorph class methodsFor: 'instance creation' stamp: 'jmv 11/14/2011 16:32'! - initializedInstance - ^self new - maxHeight: 48; - model: (TextModel new contents: 'This is some text to test the morph.')! ! -!MagnifierMorph methodsFor: 'menu' stamp: 'di 9/28/1999 23:06'! - addCustomMenuItems: aCustomMenu hand: aHandMorph - super addCustomMenuItems: aCustomMenu hand: aHandMorph. - aCustomMenu - addLine; - add: 'magnification...' action: #chooseMagnification; - addUpdating: #trackingPointerString action: #toggleTrackingPointer; - addUpdating: #toggleRoundString action: #toggleRoundness.! ! -!MagnifierMorph methodsFor: 'geometry' stamp: 'jmv 12/16/2011 10:28'! - borderWidth: anInteger - "Grow outwards preserving innerBounds" - | c | - c _ self referencePosition. - super borderWidth: anInteger. - super morphExtent: self defaultExtent. - self referencePosition: c.! ! -!MagnifierMorph methodsFor: 'menu' stamp: 'jmv 8/21/2012 21:53'! - chooseMagnification - | result | - result _ (SelectionMenu selections: #(1.5 2 4 8)) - startUpWithCaption: 'Choose magnification -(currently ', magnification printString, ')'. - (result == nil or: [ result = magnification ]) ifTrue: [ ^ self ]. - magnification _ result. - self morphExtent: extent. "round to new magnification" - self redrawNeeded. "redraw even if extent wasn't changed"! ! -!MagnifierMorph methodsFor: 'menu' stamp: 'jmv 9/22/2012 15:35'! - chooseMagnification: evt - | handle origin aHand currentMag | - currentMag _ magnification. - aHand _ evt ifNil: [ self world activeHand ] ifNotNil: [evt hand]. - origin _ aHand morphPosition y. - handle _ HandleMorph new forEachPointDo: - [ :newPoint | self magnification: (newPoint y - origin) / 8.0 + currentMag ]. - aHand attachMorph: handle. - handle startStepping. - self redrawNeeded. ! ! -!MagnifierMorph methodsFor: 'initialization' stamp: 'jmv 12/2/2011 10:20'! - defaultBorderWidth - "answer the default border width for the receiver" - ^ 1! ! -!MagnifierMorph methodsFor: 'geometry' stamp: 'bf 9/21/1999 09:22'! - defaultExtent - ^(srcExtent * magnification) truncated + (2 * borderWidth)! ! -!MagnifierMorph methodsFor: 'drawing' stamp: 'jmv 4/9/2015 09:43'! - drawOn: aCanvas - RecursionLock == self ifFalse: [ - super drawOn: aCanvas. "border and fill" - aCanvas image: self magnifiedForm at: borderWidth@borderWidth]! ! -!MagnifierMorph methodsFor: 'event handling testing' stamp: 'jmv 1/17/2013 17:27'! - handlesMouseDown: aMouseButtonEvent - - ^aMouseButtonEvent mouseButton2Pressed! ! -!MagnifierMorph methodsFor: 'initialization' stamp: 'jmv 9/13/2013 10:02'! - initialize - super initialize. - trackPointer _ true. - magnification _ 2. - self morphExtent: 128@128! ! -!MagnifierMorph methodsFor: 'round view' stamp: 'jmv 12/10/2010 09:25'! - isRound - - ^ "owner isMemberOf: ScreeningMorph" false! ! -!MagnifierMorph methodsFor: 'magnifying' stamp: 'jmv 12/16/2011 10:28'! -magnification: aNumber - | c | - magnification _ aNumber min: 8 max: 0.5. - magnification _ magnification roundTo: - (magnification < 3 ifTrue: [0.5] ifFalse: [1]). - srcExtent _ srcExtent min: (512@512) // magnification. "to prevent accidents" - c _ self referencePosition. - super morphExtent: self defaultExtent. - self referencePosition: c.! ! -!MagnifierMorph methodsFor: 'magnifying' stamp: 'jmv 10/1/2014 09:47'! - magnifiedForm - | srcRect form neededExtent | - lastPos _ self sourcePoint. - srcRect _ self sourceRectFrom: lastPos. - ((srcRect intersects: self morphBoundsInWorld) and: [ RecursionLock == nil ]) - ifTrue: [ - RecursionLock _ self. - "try to reuse form if appropriate" - auxCanvas _ (auxCanvas notNil and: [ auxCanvas extent = srcExtent ]) - ifTrue: [ - "Just in case we go out of the Display" - srcRect origin > (0@0) ifFalse: [ - auxCanvas form fillBlack ]. - BitBltCanvas on: auxCanvas form over: srcRect ] - ifFalse: [ BitBltCanvas depth: 32 over: srcRect ]. - auxCanvas fullDraw: self world. - form _ auxCanvas form. - RecursionLock _ nil] - ifFalse: [ - "cheaper method if the source is not occluded" - form _ Display copy: srcRect]. - "smooth if non-integer scale" - neededExtent _ (srcExtent * magnification ) truncated. - (magnifiedForm isNil or: [ magnifiedForm extent ~= neededExtent ]) - ifTrue: [ magnifiedForm _ Form extent: neededExtent depth: 32 ]. - (WarpBlt toForm: magnifiedForm) - sourceForm: form; - colorMap: (form colormapIfNeededFor: magnifiedForm); - cellSize: (magnification isInteger ifTrue: [1] ifFalse: [2]); "installs a new colormap if cellSize > 1" - combinationRule: 3; - copyQuad: form boundingBox innerCorners toRect: magnifiedForm boundingBox. - ^magnifiedForm.! ! -!MagnifierMorph methodsFor: 'events' stamp: 'jmv 1/14/2013 22:45'! - mouseButton2Down: aMouseButtonEvent localPosition: localEventPosition - - self chooseMagnification: aMouseButtonEvent! ! -!MagnifierMorph methodsFor: 'geometry' stamp: 'jmv 6/6/2014 18:06'! - privateExtent: aPoint - "Round to multiples of magnification" - - srcExtent _ (aPoint - (2 * borderWidth)) // magnification. - ^ super privateExtent: self defaultExtent! ! -!MagnifierMorph methodsFor: 'magnifying' stamp: 'jmv 9/25/2012 22:24'! - sourcePoint - "If we are being dragged use our center, otherwise use pointer position" - ^ (trackPointer not or: [owner notNil and: [owner is: #HandMorph]]) - ifTrue: [ self morphBoundsInWorld center ] - ifFalse: [ self world activeHand morphPosition ]! ! -!MagnifierMorph methodsFor: 'magnifying' stamp: 'jmv 8/4/2012 16:41'! - sourceRect - "world global coordinates, etc" - self flag: #jmvVer2. - ^self sourceRectFrom: self sourcePoint! ! -!MagnifierMorph methodsFor: 'magnifying' stamp: 'jmv 8/17/2012 18:52'! - sourceRectFrom: aPoint - ^ (aPoint extent: srcExtent) translatedBy: (srcExtent // -2) + 1. -! ! -!MagnifierMorph methodsFor: 'stepping' stamp: 'jmv 2/27/2016 19:53'! - stepAt: millisecondSinceLast - - self redrawNeeded! ! -!MagnifierMorph methodsFor: 'stepping' stamp: 'jmv 6/11/2012 23:32'! - stepTime - "Update very often. Very short steptimes should only be used for morphs that are not stepping all the time!!" - ^ 20! ! -!MagnifierMorph methodsFor: 'round view' stamp: 'di 9/28/1999 23:17'! - toggleRoundString - ^ self isRound - ifTrue: ['be square'] - ifFalse: ['be round']! ! -!MagnifierMorph methodsFor: 'round view' stamp: 'jmv 12/11/2011 23:35'! - toggleRoundness - | | -" w _ self world. - self isRound - ifTrue: [owner delete. - w addMorph: self] - ifFalse: [sm _ ScreeningMorph new position: self zzposition. - sm addMorph: self. - sm addMorph: (EllipseMorph newBounds: self bounds). - w addMorph: sm] - "! ! -!MagnifierMorph methodsFor: 'menu' stamp: 'bf 9/20/1999 15:48'! - toggleTrackingPointer - trackPointer _ trackPointer not! ! -!MagnifierMorph methodsFor: 'menu' stamp: 'bf 9/20/1999 15:49'! - trackingPointerString - ^trackPointer - ifTrue: ['stop tracking pointer'] - ifFalse: ['start tracking pointer']! ! -!MagnifierMorph methodsFor: 'stepping' stamp: 'jmv 6/11/2012 09:58'! - wantsSteps - "Return true if the receiver wants to its #step or #stepAt: methods be run ALL THE TIME. - Morphs that send #startStepping and #stopStepping at appropriate times (i.e. when they are already in the world!!) don't need to answer true to this message" - - ^true! ! -!DragAndDropAreaMorph methodsFor: 'drag and drop us' stamp: 'jmv 1/24/2013 22:53'! - aboutToBeGrabbedBy: aHand - "The receiver is being grabbed by a hand. - Perform necessary adjustments (if any) and return the actual morph - that should be added to the hand. - Answer nil to reject the drag." - "This message is sent to the dragged morph, not to the owner. - It is included here just for reference." - - ^self "Grab me"! ! -!DragAndDropAreaMorph methodsFor: 'drag and drop other morphs' stamp: 'jmv 1/24/2013 22:52'! - allowsMorphDrop - "Answer whether we accept dropping morphs. Redefined to answer true." - - ^ true! ! -!DragAndDropAreaMorph methodsFor: 'drag and drop other morphs' stamp: 'jmv 1/24/2013 22:52'! -allowsSubmorphDrag - "Answer whether our morphs can just be grabbed with the hand, instead of requiring the use of the halo. Redefined to answer true." - - ^ true! ! -!DragAndDropAreaMorph methodsFor: 'drag and drop us' stamp: 'jmv 1/24/2013 22:53'! - justDroppedInto: newOwnerMorph event: anEvent - "This message is sent to a dropped morph after it has been dropped on -- and been accepted by -- a drop-sensitive morph" - "This message is sent to the dragged morph, not to the owner. - It is included here just for reference." - - ^super justDroppedInto: newOwnerMorph event: anEvent ! ! -!DragAndDropAreaMorph methodsFor: 'drag and drop us' stamp: 'jmv 1/24/2013 22:53'! -justGrabbedFrom: formerOwner - "The receiver was just grabbed from its former owner and is now attached to the hand." - "This message is sent to the dragged morph, not to the owner. - It is included here just for reference."! ! -!DragAndDropAreaMorph methodsFor: 'drag and drop other morphs' stamp: 'jmv 1/24/2013 22:52'! - wantsDroppedMorph: aMorph event: evt - "Return true if the receiver wishes to accept the given morph, which is being dropped by a hand in response to the given event. Note that for a successful drop operation both parties need to agree. The symmetric check is done automatically via aMorph wantsToBeDroppedInto: self. - This method just answers super. It is included here to say it is relevant to D&D behavior." - - ^super wantsDroppedMorph: aMorph event: evt! ! -!DragAndDropAreaMorph methodsFor: 'drag and drop us' stamp: 'jmv 1/24/2013 22:53'! - wantsToBeDroppedInto: aMorph - "Return true if it's okay to drop the receiver into aMorph. This check is symmetric to #wantsDroppedMorph:event: to give both parties a chance of figuring out whether they like each other." - "This message is sent to the dragged morph, not to the owner. - It is included here just for reference." - - ^true! ! -!PartsBinMorph methodsFor: 'dropping/grabbing' stamp: 'jmv 2/22/2013 12:49'! - aboutToGrab: aMorph - "submorph is being grabbed by a hand. - Perform necessary adjustments (if any) and return the actual morph - that should be added to the hand. - Answer nil to reject the drag." - - ^aMorph copy! ! -!FrameRateMorph methodsFor: 'drawing' stamp: 'jmv 4/15/2014 09:22'! - drawOn: aCanvas - super drawOn: aCanvas. - meanStepDelta ifNotNil: [ - aCanvas drawString: lastStepDelta rounded printString at: 0@0 font: AbstractFont default color: Color black. - aCanvas drawString: meanStepDelta rounded printString at: 0@14 font: AbstractFont default color: Color black. - "aCanvas drawString: lastStepStamp printString at: bounds topLeft + (0@28) font: AbstractFont default color: Color black " - ]! ! -!FrameRateMorph methodsFor: 'stepping' stamp: 'jmv 2/27/2016 19:52'! - stepAt: millisecondSinceLast - - | n | - lastStepDelta _ millisecondSinceLast. - "This factor is a damper, to show a sort of mean of the n latest step deltas" - meanStepDelta - ifNil: [ meanStepDelta _ 0. n _ 0 ] - ifNotNil: [ -" n _ (meanStepDelta / lastStepDelta between: 0.5 and: 2) - ifTrue: [ 10 ] - ifFalse: [10 ]." - n _ 20 ]. - meanStepDelta _ meanStepDelta * n + lastStepDelta / (n+1). - self redrawNeeded! ! -!FrameRateMorph methodsFor: 'stepping' stamp: 'jmv 6/11/2012 23:34'! - stepTime - - ^20! ! -!FrameRateMorph methodsFor: 'stepping' stamp: 'jmv 6/11/2012 09:20'! - wantsSteps - "Return true if the receiver wants to its #step or #stepAt: methods be run" - - ^true! ! -!FunctionGraphMorph methodsFor: 'accessing' stamp: 'jmv 11/18/2014 08:52'! - addFunction: aOneArgBlock color: aColor - - functions add: aOneArgBlock. - colors add: aColor! ! -!FunctionGraphMorph methodsFor: 'accessing' stamp: 'jmv 11/25/2016 09:24:52'! - domain: anInterval - - xMin _ anInterval first. - xMax _ anInterval last. - - yMin _ nil. - yMax _ nil.! ! -!FunctionGraphMorph methodsFor: 'drawing' stamp: 'jmv 11/30/2016 16:04:28'! - drawOn: aCanvas - " - | g | - g _ FunctionGraphMorph new. - g domain: (-4 to: 4). - g addFunction: [ :x | x mod: 1 ] color: Color green. - g addFunction: [ :x | x div: 1 ] color: Color red. - g openInWorld - " - | r r2 fontToUse xtra | - yMin ifNil: [ - yMin _ Float infinity. - yMax _ Float negativeInfinity. - self iterate: [ :x :y :c | - yMin _ yMin min: y. - yMax _ yMax max: y ]. - xtra _ yMax-yMin/50. - yMin _ yMin - xtra. - yMax _ yMax + xtra - ]. - - r _ 40@0 corner: extent - (0@20). - aCanvas - frameAndFillRectangle: r fillColor: (Color gray: 0.9) - borderWidth: 0.05 borderColor: Color white. - (0 between: xMin and: xMax) ifTrue: [ - aCanvas line: (self toMorphic:0@yMin)-(0@2) to: (self toMorphic: 0 @ yMax)+(0@2) width: 2 color: Color darkGray ]. - (0 between: yMin and: yMax) ifTrue: [ - aCanvas line: (self toMorphic: xMin@0)+(2@0) to: (self toMorphic: xMax@0)-(2@0) width: 2 color: Color darkGray ]. - - self iterate: [ :x :y :c | - (y between: yMin and: yMax) ifTrue: [ - r2 _ (self xToMorphic: x)@(self yToMorphic: y) extent: 2.5. - (r containsRect: r2) ifTrue: [ - aCanvas - fillRectangle: r2 - color: c ]]]. - fontToUse _ AbstractFont default. - aCanvas drawString: xMin printString at: 40@(extent y - 16) font: fontToUse color: Color black. - aCanvas drawString: xMax printString at: extent -(32@16) font: fontToUse color: Color black. - aCanvas drawString: yMin printString at: 4@(extent y - 32) font: fontToUse color: Color black. - aCanvas drawString: yMax printString at: 4@4 font: fontToUse color: Color black.! ! -!FunctionGraphMorph methodsFor: 'initialization' stamp: 'jmv 7/1/2015 11:16'! - initialize - super initialize. - extent _ 320@240. - functions _ OrderedCollection new. - colors _ OrderedCollection new! ! -!FunctionGraphMorph methodsFor: 'drawing' stamp: 'jmv 11/25/2016 11:32:06'! - iterate: aBlock - - | y | - xMin*1.0 to: xMax count: extent x do: [ :x | - functions with: colors do: [ :f :c | - y _ f value: x. - aBlock value: x value: y value: c ]]! ! -!FunctionGraphMorph methodsFor: 'geometry' stamp: 'jmv 5/17/2015 09:20'! - toMorphic: aPoint - ^(self xToMorphic: aPoint x) @ (self yToMorphic: aPoint y)! ! -!FunctionGraphMorph methodsFor: 'geometry' stamp: 'jmv 11/25/2016 11:03:22'! - xToMorphic: x - ^x - xMin / (xMax - xMin ) * (extent x-40)+40! ! -!FunctionGraphMorph methodsFor: 'accessing' stamp: 'jmv 6/25/2016 17:16'! - yRange: anInterval - - yMin _ anInterval first. - yMax _ anInterval last.! ! -!FunctionGraphMorph methodsFor: 'geometry' stamp: 'jmv 11/25/2016 11:03:27'! - yToMorphic: y - ^yMax - y / (yMax - yMin ) * (extent y-20)! ! -!FunctionGraphMorph class methodsFor: 'instance creation' stamp: 'jmv 7/20/2016 10:00:31'! - initializedInstance - " - self initializedInstance openInWorld - " - | g | - g _ FunctionGraphMorph new. - g domain: (-4 to: 4). - g addFunction: [ :x | x cos ] color: Color green. - g addFunction: [ :x | (x + 1) squared - 3 ] color: Color red. "parabola with vertex at (-1,-3)" - ^ g! ! -!MinimalStringMorph methodsFor: 'accessing' stamp: 'jmv 6/6/2014 10:58'! - contents: newContents - contents _ (newContents is: #Text) - ifTrue: [ - emphasis := newContents emphasisAt: 1. - newContents string] - ifFalse: [ - contents = newContents ifTrue: [^self]. "no substantive change" - newContents]. - self fitContents. - self redrawNeeded! ! -!MinimalStringMorph methodsFor: 'initialization' stamp: 'cbr 12/3/2010 23:29'! - defaultColor - "answer the default color/fill style for the receiver" - ^ Theme current text! ! -!MinimalStringMorph methodsFor: 'drawing' stamp: 'jmv 7/10/2014 22:41'! - drawOn: aCanvas - - aCanvas drawString: contents at: 0@0 font: self fontToUse color: color! ! -!MinimalStringMorph methodsFor: 'accessing' stamp: 'jmv 1/1/2015 21:16'! - fitContents - "Measures contents later at #minimumExtent" - self morphExtent: 0@0! ! -!MinimalStringMorph methodsFor: 'accessing' stamp: 'jmv 4/15/2014 09:22'! - fontToUse - | fontToUse | - fontToUse := font ifNil: [AbstractFont default]. - ^(emphasis isNil or: [emphasis = 0]) - ifTrue: [fontToUse] - ifFalse: [fontToUse emphasized: emphasis]! ! -!MinimalStringMorph methodsFor: 'initialization' stamp: 'jmv 9/10/2010 22:55'! - initWithContents: aString font: aFont emphasis: emphasisCode - self initialize. - - font _ aFont. - emphasis _ emphasisCode. - self contents: aString! ! -!MinimalStringMorph methodsFor: 'initialization' stamp: 'jmv 9/10/2010 22:55'! - initialize - super initialize. - font _ nil. - emphasis _ 0! ! -!MinimalStringMorph methodsFor: 'accessing' stamp: 'jmv 12/20/2010 16:25'! - measureContents - | f | - f _ self fontToUse. - ^(((f widthOfString: contents) max: 3) @ f height).! ! -!MinimalStringMorph class methodsFor: 'instance creation' stamp: 'jmv 4/3/2011 22:34'! - contents: aString - " 'StringMorph contents: str' is faster than 'StringMorph new contents: str' - (MinimalStringMorph contents: 'Some string') openInWorld - " - ^ self contents: aString font: nil! ! -!MinimalStringMorph class methodsFor: 'instance creation' stamp: 'jmv 11/4/2008 12:56'! - contents: aString font: aFont - ^ self basicNew initWithContents: aString font: aFont emphasis: 0! ! -!MinimalStringMorph class methodsFor: 'instance creation' stamp: 'jmv 11/4/2008 12:56'! - contents: aString font: aFont emphasis: emphasisCode - ^ self basicNew initWithContents: aString font: aFont emphasis: emphasisCode! ! -!MinimalStringMorph class methodsFor: 'instance creation' stamp: 'jmv 4/3/2011 22:34'! - new - ^self contents: 'some string'! ! -!OneLineEditorMorph methodsFor: 'accessing' stamp: 'jmv 4/15/2014 09:23'! - baseFont - - font ifNil: [ font _ AbstractFont default ]. - ^font! ! -!OneLineEditorMorph methodsFor: 'drawing' stamp: 'KenD 12/12/2016 19:53:05'! - characterIndexAtPoint: aPoint - - | line block f | - f _ self fontToUse. - - line _ TextLine - start: 1 - stop: contents size - internalSpaces: 0 - paddingWidth: 0. - line - rectangle: (0@0 extent: extent); - lineHeight: f height baseline: f ascent. - - block _ (CharacterBlockScanner new text: - (contents asText font: f)) - characterBlockAtPoint: aPoint index: nil - in: line. - - ^ block stringIndex! ! -!OneLineEditorMorph methodsFor: 'events' stamp: 'jmv 8/21/2012 08:43'! - clickAndHalf: aMouseButtonEvent localPosition: localEventPosition - self handleInteraction: [ self editor clickAndHalf ]! ! -!OneLineEditorMorph methodsFor: 'accessing' stamp: 'jmv 3/16/2011 10:34'! - contents - ^contents! ! -!OneLineEditorMorph methodsFor: 'accessing' stamp: 'jmv 3/16/2011 10:41'! - contents: newContents - contents _ (newContents is: #Text) - ifTrue: [ - emphasis := newContents emphasisAt: 1. - newContents string] - ifFalse: [ - contents = newContents ifTrue: [^self]. "no substantive change" - newContents]. - editor _ nil. - self fitContents. - self redrawNeeded! ! -!OneLineEditorMorph methodsFor: 'accessing' stamp: 'jmv 1/5/2013 14:23'! - crAction - "Answer the optional Cr action" - ^crAction! ! -!OneLineEditorMorph methodsFor: 'accessing' stamp: 'jmv 1/5/2013 14:24'! - crAction: aBlock - - crAction := aBlock! ! -!OneLineEditorMorph methodsFor: 'initialization' stamp: 'cbr 12/3/2010 23:29'! - defaultColor - "answer the default color/fill style for the receiver" - ^ Theme current text! ! -!OneLineEditorMorph methodsFor: 'accessing' stamp: 'jmv 9/6/2017 10:02:09'! - disableEditing - self setProperty: #disablesEditing toValue: true. - self stopBlinking! ! -!OneLineEditorMorph methodsFor: 'event handling testing' stamp: 'jmv 9/6/2017 10:02:10'! - disablesEditing - - ^self hasProperty: #disablesEditing! ! -!OneLineEditorMorph methodsFor: 'drawing' stamp: 'jmv 10/16/2013 22:37'! - displayTextCursorAtX: x top: top bottom: bottom emphasis: emphasis on: aCanvas - | textCursorColor x1 isBold isItalic x0 h w halfW r d | - isBold _ emphasis allMask: 1. - isItalic _ emphasis allMask: 2. - textCursorColor _ Theme current textCursor. - h _ bottom - top. - w _ isBold - ifTrue: [ h // 25 + 2 ] - ifFalse: [ h // 30 + 1 ]. - halfW _ w // 2. - isItalic - ifTrue: [ - "Keep tweaking if needed!!" - d _ isBold ifTrue: [ 3 ] ifFalse: [ h // 24]. - x0 _ x- (h*5//24) + d. - x1 _ x + d ] - ifFalse: [ - x0 _ x. - x1 _ x]. - x0 < halfW ifTrue: [ - x1 _ x1 - x0 + halfW. - x0 _ halfW ]. - r _ extent x-halfW-1. - r < x1 ifTrue: [ - x0 _ x0 + r - x1. - x1 _ r ]. - textCursorRect _ x0-halfW-1@ top corner: x1+halfW+1+1 @ bottom. - aCanvas - line: x0+halfW@bottom to: x1+halfW@(top+w) - width: w color: textCursorColor! ! -!OneLineEditorMorph methodsFor: 'drawing' stamp: 'jmv 7/10/2014 22:42'! - drawOn: aCanvas - self hasSelection ifTrue: [ self drawSelectionOn: aCanvas ]. - self hasTextCursor ifTrue: [ self drawTextCursorOn: aCanvas ]. - aCanvas - drawString: contents - at: 0@0 - font: self fontToUse - color: color! ! -!OneLineEditorMorph methodsFor: 'drawing' stamp: 'KenD 9/27/2016 09:10:25'! - drawSelectionOn: aCanvas - | rightX leftX bottom | - - bottom _ self baseFont height. - leftX _ self fontToUse widthOfString: contents from: 1 to: editor startIndex-1. - leftX _ leftX min: extent x. - rightX _ self fontToUse widthOfString: contents from: 1 to: editor stopIndex-1. - rightX _ rightX min: extent x. - - aCanvas - fillRectangle: (leftX+1 @ 1 corner: (rightX + 2) @ (bottom + 2)) - color: (Theme current textHighlightFocused: self hasKeyboardFocus)! ! -!OneLineEditorMorph methodsFor: 'drawing' stamp: 'jmv 10/16/2013 22:19'! - drawTextCursorOn: aCanvas - | bottom x | - - showTextCursor ifTrue: [ - bottom _ self baseFont height. - x _ self fontToUse widthOfString: contents from: 1 to: editor startIndex-1. - self displayTextCursorAtX: x top: 0 bottom: bottom emphasis: emphasis on: aCanvas ]! ! -!OneLineEditorMorph methodsFor: 'accessing' stamp: 'jmv 12/4/2011 22:25'! - editor - "Return my current editor, or install a new one." - editor ifNil: [ self installEditor ]. - ^editor! ! -!OneLineEditorMorph methodsFor: 'accessing' stamp: 'jmv 1/1/2015 21:16'! - fitContents - "Measures contents later at #minimumExtent" - self morphExtent: 0@0! ! -!OneLineEditorMorph methodsFor: 'events-processing' stamp: 'jmv 12/28/2011 22:45'! - focusKeyboardFor: aKeyboardEvent - "If aKeyboardEvent tab or shift-tab use it to navigate keyboard focus. - ctrl key ignored." - aKeyboardEvent keyValue = 9 - ifTrue: [ - aKeyboardEvent shiftPressed - ifFalse: [ aKeyboardEvent hand keyboardFocusNext ] - ifTrue: [ aKeyboardEvent hand keyboardFocusPrevious ]. - ^ true ]. - ^super focusKeyboardFor: aKeyboardEvent! ! -!OneLineEditorMorph methodsFor: 'events-processing' stamp: 'KenD 10/29/2015 20:43'! - fontPreferenceChanged - - font := nil. - self baseFont.! ! -!OneLineEditorMorph methodsFor: 'accessing' stamp: 'jmv 11/5/2008 13:18'! - fontToUse - - ^ (emphasis isNil or: [emphasis = 0]) - ifTrue: [ self baseFont ] - ifFalse: [ self baseFont emphasized: emphasis ]! ! -!OneLineEditorMorph methodsFor: 'editing' stamp: 'jmv 10/16/2013 21:03'! - handleInteraction: interactionBlock - "Perform the changes in interactionBlock, noting any change in selection - and possibly a change in the size of the composition" - - "Also couple the editor to Morphic keyboard events" - - | oldEditor oldContents | - oldEditor _ editor. - oldContents _ contents. - interactionBlock value. - oldContents == contents - ifTrue: [ "this will not work if the composition changed" - editor _ oldEditor "since it may have been changed while in block"]. - self redrawNeeded! ! -!OneLineEditorMorph methodsFor: 'event handling testing' stamp: 'jmv 8/20/2012 18:52'! - handlesKeyboard - - ^self visible! ! -!OneLineEditorMorph methodsFor: 'event handling testing' stamp: 'jmv 8/20/2012 18:52'! - handlesMouseDown: aMouseButtonEvent - ^ true! ! -!OneLineEditorMorph methodsFor: 'event handling testing' stamp: 'jmv 8/20/2012 18:52'! - handlesMouseOver: evt - "implements #mouseEnter: and/or #mouseLeave:" - ^true! ! -!OneLineEditorMorph methodsFor: 'testing' stamp: 'jmv 11/5/2008 12:41'! - hasSelection - - ^editor notNil and: [editor hasSelection]! ! -!OneLineEditorMorph methodsFor: 'testing' stamp: 'jmv 10/16/2013 22:18'! - hasTextCursor - - ^ self hasKeyboardFocus and: [editor notNil and: [editor hasSelection not]]! ! -!OneLineEditorMorph methodsFor: 'unaccepted edits' stamp: 'jmv 3/14/2011 09:21'! - hasUnacceptedEdits: aBoolean - "Set the hasUnacceptedEdits flag to the given value. " - - self flag: #jmv. - "Not used in this morph, as it doesn't do accept / cancel" - self redrawNeeded! ! -!OneLineEditorMorph methodsFor: 'initialization' stamp: 'jmv 11/5/2008 12:15'! - initWithContents: aString font: aFont emphasis: emphasisCode - self initialize. - - font _ aFont. - emphasis _ emphasisCode. - self contents: aString! ! -!OneLineEditorMorph methodsFor: 'initialization' stamp: 'jmv 10/16/2013 22:19'! - initialize - super initialize. - contents _ ''. - font _ nil. - emphasis _ 0. - showTextCursor _ false. "Should never be nil"! ! -!OneLineEditorMorph methodsFor: 'private' stamp: 'jmv 12/4/2011 22:25'! - installEditor - "Install an editor for my contents. This constitutes 'hasFocus'. - If priorEditor is not nil, then initialize the new editor from its state. - We may want to rework this so it actually uses the prior editor." - - editor _ SimpleEditor new morph: self. - editor changeString: contents. - self redrawNeeded. - ^editor! ! -!OneLineEditorMorph methodsFor: 'events' stamp: 'len 11/15/2015 06:45'! - keyStroke: aKeyboardEvent - "Handle a keystroke event." - - (Theme current keyStroke: aKeyboardEvent morph: self) - ifTrue: [^ self]. - - (self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - - "Return - check for special action - Note: Code below assumes that this was some - input field reacting on Return." - aKeyboardEvent isReturnKey ifTrue: [ - crAction ifNotNil: [ - "Break the keyboard focus so that the receiver can be safely deleted." - "Is this needed at all? (jmv)" - "aKeyboardEvent hand newKeyboardFocus: nil." - ^crAction value ]]. - - self pauseBlinking. - self handleInteraction: [ self editor processKeyStroke: aKeyboardEvent ]. - self updateFromContents. - super keyStroke: aKeyboardEvent "sends to keyStroke event handler, if any"! ! -!OneLineEditorMorph methodsFor: 'events-processing' stamp: 'jmv 3/6/2015 08:59'! - keyboardFocusChange: aBoolean - aBoolean - ifTrue: [ - "A hand is wanting to send us characters..." - editor ifNil: [ self editor ]. "Forces install" - self selectAll. - self showsBlinkingCursor ifTrue: [ - self startBlinking ]] - ifFalse: [ - self stopBlinking. - keyboardFocusWatcher ifNotNil: [ - keyboardFocusWatcher lostFocus: self ]]. - self redrawNeeded! ! -!OneLineEditorMorph methodsFor: 'accessing' stamp: 'jmv 3/17/2011 07:58'! - keyboardFocusWatcher: aMorph - "We are usually used as a part of a bigger morph. - Usually, that morph would be interested in us changing keyboard focus. - An alternative implementation would be to define a new type of event, but: - - I (jmv) prefer explicit message sends to registering in events. - - There are too many evens already defined. It would be good to reduce that." - keyboardFocusWatcher _ aMorph! ! -!OneLineEditorMorph methodsFor: 'accessing' stamp: 'jmv 12/20/2010 16:25'! - measureContents - | f | - - f _ self fontToUse. - ^((f widthOfString: contents) max: 3) @ f height.! ! -!OneLineEditorMorph methodsFor: 'geometry' stamp: 'jmv 3/6/2015 08:52'! - minimumExtent - - ^ self measureContents! ! -!OneLineEditorMorph methodsFor: 'events' stamp: 'jmv 1/14/2013 22:27'! - mouseButton1Down: aMouseButtonEvent localPosition: localEventPosition - "Make this TextMorph be the keyboard input focus, if it isn't already, - and repond to the text selection gesture." - - aMouseButtonEvent hand newKeyboardFocus: self. - - self handleInteraction: [ - self editor mouseDown: aMouseButtonEvent index: (self characterIndexAtPoint: localEventPosition) ]. - - aMouseButtonEvent hand - waitForClicksOrDragOrSimulatedMouseButton2: self - event: aMouseButtonEvent - clkSel: nil - clkNHalf: #clickAndHalf:localPosition: - dblClkSel: nil - dblClkNHalfSel: nil - tripleClkSel: nil! ! -!OneLineEditorMorph methodsFor: 'events' stamp: 'jmv 1/14/2013 23:16'! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - - super mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition. - self pauseBlinking -! ! -!OneLineEditorMorph methodsFor: 'events' stamp: 'jmv 8/20/2012 18:07'! - mouseEnter: event - super mouseEnter: event. - Preferences focusFollowsMouse - ifTrue: [ event hand newKeyboardFocus: self ]! ! -!OneLineEditorMorph methodsFor: 'events' stamp: 'jmv 8/21/2012 13:20'! - mouseMove: aMouseMoveEvent localPosition: localEventPosition - - aMouseMoveEvent mouseButton1Pressed ifFalse: [ ^ self ]. - self handleInteraction: [ - self editor mouseMove: aMouseMoveEvent index: (self characterIndexAtPoint: localEventPosition) ]! ! -!OneLineEditorMorph methodsFor: 'blink cursor' stamp: 'jmv 7/18/2014 14:53'! - onBlinkCursor - "Blink the cursor" - showTextCursor _ showTextCursor not | pauseBlinking. - pauseBlinking _ false. - textCursorRect ifNotNil: [ :r | self invalidateLocalRect: r]! ! -!OneLineEditorMorph methodsFor: 'blink cursor' stamp: 'jmv 3/6/2015 08:59'! - pauseBlinking - "Show a solid cursor (non blinking) for a short while" - pauseBlinking _ true. - self showsBlinkingCursor ifTrue: [ - "Show cursor right now if needed" - showTextCursor ifFalse: [ - showTextCursor _ true. - textCursorRect ifNotNil: [ :r | self invalidateLocalRect: r ]]]! ! -!OneLineEditorMorph methodsFor: 'typing/selecting keys' stamp: 'jmv 3/16/2011 10:45'! - selectAll - self editor selectAll. - self redrawNeeded! ! -!OneLineEditorMorph methodsFor: 'blink cursor' stamp: 'jmv 9/6/2017 10:02:15'! - showsBlinkingCursor - - ^self handlesKeyboard and: [ self disablesEditing not ]! ! -!OneLineEditorMorph methodsFor: 'blink cursor' stamp: 'jmv 2/2/2014 22:20'! - startBlinking - "And show the cursor" - pauseBlinking _ true. - "Start blinking in a short while" - showTextCursor _ true. - self startStepping: #onBlinkCursor stepTime: 500! ! -!OneLineEditorMorph methodsFor: 'blink cursor' stamp: 'jmv 7/18/2014 14:53'! - stopBlinking - "And do not show cursor anymore." - self stopStepping: #onBlinkCursor. - "Hide cursor right now if needed" - showTextCursor ifTrue: [ - showTextCursor _ false. - textCursorRect ifNotNil: [ :r | self invalidateLocalRect: r ]]! ! -!OneLineEditorMorph methodsFor: 'private' stamp: 'jmv 12/29/2011 15:05'! - updateFromContents - - "O contents deberia ser un StringHolder????" - contents _ self editor string. - self redrawNeeded! ! -!OneLineEditorMorph class methodsFor: 'instance creation' stamp: 'jmv 3/16/2011 10:25'! - contents: aString - " 'StringMorph contents: str' is faster than 'StringMorph new contents: str' - (OneLineEditorMorph contents: 'Some string') openInWorld - " - ^ self contents: aString font: nil! ! -!OneLineEditorMorph class methodsFor: 'instance creation' stamp: 'jmv 11/4/2008 12:47'! - contents: aString font: aFont - ^ self basicNew initWithContents: aString font: aFont emphasis: 0! ! -!OneLineEditorMorph class methodsFor: 'instance creation' stamp: 'jmv 11/4/2008 12:47'! - contents: aString font: aFont emphasis: emphasisCode - ^ self basicNew initWithContents: aString font: aFont emphasis: emphasisCode! ! -!OneLineEditorMorph class methodsFor: 'instance creation' stamp: 'jmv 4/3/2011 22:35'! - new - ^self contents: 'some string'! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/Packages/Morphic-Widgets-Extras.pck.st----! - -'From Cuis 4.2 of 25 July 2013 [latest update: #1976] on 19 April 2014 at 11:12:07.79669 am'! - -'Description Please enter a description for this package.'! - -TestCase subclass: #RTFConversionTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFtests'! - -!classDefinition: #RTFConversionTest category: #RTFtests! -TestCase subclass: #RTFConversionTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFtests'! - -RTFConversionTest class - instanceVariableNames: ''! - -!classDefinition: 'RTFConversionTest class' category: #RTFtests! -RTFConversionTest class - instanceVariableNames: ''! - -TestCase subclass: #RTFTokenTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFtests'! - -!classDefinition: #RTFTokenTest category: #RTFtests! -TestCase subclass: #RTFTokenTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFtests'! - -RTFTokenTest class - instanceVariableNames: ''! - -!classDefinition: 'RTFTokenTest class' category: #RTFtests! -RTFTokenTest class - instanceVariableNames: ''! - -TestCase subclass: #RTFTokenizerTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFtests'! - -!classDefinition: #RTFTokenizerTest category: #RTFtests! -TestCase subclass: #RTFTokenizerTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'RTFtests'! - -RTFTokenizerTest class - instanceVariableNames: ''! - -!classDefinition: 'RTFTokenizerTest class' category: #RTFtests! -RTFTokenizerTest class - instanceVariableNames: ''! -!RTFConversionTest methodsFor: 'tests' stamp: 'jmv 4/11/2011 19:45'! - testSample1ToAndFromRTF - " - RTFConversionTest new testSample1ToAndFromRTF - " - | builder parser rtf text result | - text _ RTFConversionTest textSample1. - rtf _ text rtfString. - - builder _ RTFTextBuilder new. - parser _ RTFParser new. - parser parseWithTokenizer: (RTFTokenizer newFromString: rtf) buildWith: builder. - self assert: builder text = text. - self assert: builder text runs = text runs. - - builder _ RTFTextBuilder currentClass new. - parser _ RTFParser new. - parser parseWithTokenizer: (RTFTokenizer newFromString: rtf) buildWith: builder. - result _ builder text asNonStyledText. - self assert: result = text. - self assert: result runs = text runs.! ! -!RTFConversionTest methodsFor: 'tests' stamp: 'jmv 4/11/2011 19:45'! - testSample2ToAndFromRTF - " - RTFConversionTest new testSample2ToAndFromRTF - " - | builder parser rtf text result | - text _ RTFConversionTest textSample2. - rtf _ text rtfString. - - builder _ RTFTextBuilder new. - parser _ RTFParser new. - parser parseWithTokenizer: (RTFTokenizer newFromString: rtf) buildWith: builder. - self assert: builder text = text. - self assert: builder text runs = text runs. - - builder _ RTFTextBuilder currentClass new. - parser _ RTFParser new. - parser parseWithTokenizer: (RTFTokenizer newFromString: rtf) buildWith: builder. - result _ builder text asNonStyledText. - self assert: result = text. - self assert:result runs = text runs.! ! -!RTFConversionTest methodsFor: 'tests' stamp: 'jmv 4/11/2011 20:03'! - testSample3ToAndFromRTF - " - RTFConversionTest new testSample3ToAndFromRTF - " - | builder parser rtf text result | - text _ RTFConversionTest textSample3. - rtf _ text rtfString. - - builder _ RTFTextBuilder new. - parser _ RTFParser new. - parser parseWithTokenizer: (RTFTokenizer newFromString: rtf) buildWith: builder. - self assert: builder text = text. - self assert: builder text runs = text runs. - - builder _ RTFTextBuilder currentClass new. - parser _ RTFParser new. - parser parseWithTokenizer: (RTFTokenizer newFromString: rtf) buildWith: builder. - result _ builder text asNonStyledText. - self assert: result = text. - self assert: result runs = text runs.! ! -!RTFConversionTest methodsFor: 'tests' stamp: 'jmv 4/12/2011 10:09'! - testSample4ToAndFromRTF - " - RTFConversionTest new testSample4ToAndFromRTF - " - | builder parser rtf text result | - text _ RTFConversionTest textSample4. - rtf _ text rtfString. - - builder _ RTFTextBuilder new. - parser _ RTFParser new. - parser parseWithTokenizer: (RTFTokenizer newFromString: rtf) buildWith: builder. - self assert: builder text = text. - "kern and struckThrough not supported in rtf yet..." -" self assert: builder text runs = text runs." - - builder _ RTFTextBuilder currentClass new. - parser _ RTFParser new. - parser parseWithTokenizer: (RTFTokenizer newFromString: rtf) buildWith: builder. - result _ builder text asNonStyledText. - self assert: result = text. - "kern and struckThrough not supported in rtf yet..." -" self assert: result runs = text runs."! ! -!RTFConversionTest methodsFor: 'tests' stamp: 'jmv 4/11/2011 19:45'! - testSample5ToAndFromRTF - " - RTFConversionTest new testSample5ToAndFromRTF - " - | builder parser rtf text result | - text _ RTFConversionTest textSample5. - rtf _ text rtfString. - - builder _ RTFTextBuilder new. - parser _ RTFParser new. - parser parseWithTokenizer: (RTFTokenizer newFromString: rtf) buildWith: builder. - self assert: builder text = text. - self assert: builder text runs = text runs. - - builder _ RTFTextBuilder currentClass new. - parser _ RTFParser new. - parser parseWithTokenizer: (RTFTokenizer newFromString: rtf) buildWith: builder. - result _ builder text asNonStyledText. - self assert: result = text. - self assert: result runs = text runs.! ! -!RTFConversionTest methodsFor: 'tests' stamp: 'jmv 11/22/2011 15:27'! - testSample6ToAndFromRTF - " - RTFConversionTest new testSample6ToAndFromRTF - " - | builder parser rtf text result | - text _ RTFConversionTest textSample6. - rtf _ text rtfString. - - builder _ RTFTextBuilder new. - parser _ RTFParser new. - parser parseWithTokenizer: (RTFTokenizer newFromString: rtf) buildWith: builder. - self assert: builder text = text. - self assert: builder text runs = text runs. - - builder _ RTFTextBuilder currentClass new. - parser _ RTFParser new. - parser parseWithTokenizer: (RTFTokenizer newFromString: rtf) buildWith: builder. - result _ builder text asNonStyledText. - self assert: result = text. - self assert: result runs = text runs.! ! -!RTFConversionTest class methodsFor: 'rtf examples' stamp: 'jmv 3/13/2012 11:45'! - rtfABCExample - " - | rtf | - rtf _ RTFConversionTest rtfABCExample. - 'Works on the mac'. - ExtendedClipboardInterface current - clearClipboard; - addClipboardData: (rtf withLineEndings: String crString) dataFormat: 'public.rtf' - " - ^'{\rtf1\ansi\ansicpg1251\uc1\deff0\stshfdbch0\stshfloch0\stshfhich0\stshfbi0\deflang1026\deflangfe1026{\fonttbl{\f0\froman\fcharset204\fprq2{\*\panose 02020603050405020304}Times New Roman;}{\f38\froman\fcharset0\fprq2 Times New Roman;} -{\f36\froman\fcharset238\fprq2 Times New Roman CE;}{\f39\froman\fcharset161\fprq2 Times New Roman Greek;}{\f40\froman\fcharset162\fprq2 Times New Roman Tur;}{\f41\froman\fcharset177\fprq2 Times New Roman (Hebrew);} -{\f42\froman\fcharset178\fprq2 Times New Roman (Arabic);}{\f43\froman\fcharset186\fprq2 Times New Roman Baltic;}{\f44\froman\fcharset163\fprq2 Times New Roman (Vietnamese);}}{\colortbl;\red0\green0\blue0;\red0\green0\blue255;\red0\green255\blue255; -\red0\green255\blue0;\red255\green0\blue255;\red255\green0\blue0;\red255\green255\blue0;\red255\green255\blue255;\red0\green0\blue128;\red0\green128\blue128;\red0\green128\blue0;\red128\green0\blue128;\red128\green0\blue0;\red128\green128\blue0; -\red128\green128\blue128;\red192\green192\blue192;}{\stylesheet{\ql \li0\ri0\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \fs24\lang1026\langfe1026\cgrid\langnp1026\langfenp1026 \snext0 Normal;}{\*\cs10 \additive \ssemihidden -Default Paragraph Font;}{\*\ts11\tsrowd\trftsWidthB3\trpaddl108\trpaddr108\trpaddfl3\trpaddft3\trpaddfb3\trpaddfr3\trcbpat1\trcfpat1\tscellwidthfts0\tsvertalt\tsbrdrt\tsbrdrl\tsbrdrb\tsbrdrr\tsbrdrdgl\tsbrdrdgr\tsbrdrh\tsbrdrv -\ql \li0\ri0\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \fs20\lang1024\langfe1024\cgrid\langnp1024\langfenp1024 \snext11 \ssemihidden Normal Table;}}{\*\rsidtbl \rsid1073017\rsid6048286\rsid13708270} -{\*\generator Microsoft Word 10.0.4219;}{\info{\title abc}{\author trifon}{\operator trifon}{\creatim\yr2006\mo5\dy16\hr10\min38}{\revtim\yr2006\mo5\dy16\hr10\min38}{\version1}{\edmins0}{\nofpages1}{\nofwords0}{\nofchars3}{\*\company CLBME}{\nofcharsws3} -{\vern16469}}\paperw11906\paperh16838\margl1417\margr1417\margt1417\margb1417 \deftab708\widowctrl\ftnbj\aenddoc\hyphhotz425\noxlattoyen\expshrtn\noultrlspc\dntblnsbdb\nospaceforul\formshade\horzdoc\dgmargin\dghspace180\dgvspace180\dghorigin1417 -\dgvorigin1417\dghshow1\dgvshow1\jexpand\viewkind1\viewscale110\pgbrdrhead\pgbrdrfoot\splytwnine\ftnlytwnine\htmautsp\nolnhtadjtbl\useltbaln\alntblind\lytcalctblwd\lyttblrtgr\lnbrkrule\nobrkwrptbl\snaptogridincell\allowfieldendsel\wrppunct -\asianbrkrule\rsidroot1073017 \fet0\sectd \linex0\headery708\footery708\colsx708\endnhere\sectlinegrid360\sectdefaultcl\sftnbj {\*\pnseclvl1\pnucrm\pnstart1\pnindent720\pnhang {\pntxta .}}{\*\pnseclvl2\pnucltr\pnstart1\pnindent720\pnhang {\pntxta .}} -{\*\pnseclvl3\pndec\pnstart1\pnindent720\pnhang {\pntxta .}}{\*\pnseclvl4\pnlcltr\pnstart1\pnindent720\pnhang {\pntxta )}}{\*\pnseclvl5\pndec\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}{\*\pnseclvl6\pnlcltr\pnstart1\pnindent720\pnhang {\pntxtb (} -{\pntxta )}}{\*\pnseclvl7\pnlcrm\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}{\*\pnseclvl8\pnlcltr\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}{\*\pnseclvl9\pnlcrm\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}\pard\plain -\ql \li0\ri0\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \fs24\lang1026\langfe1026\cgrid\langnp1026\langfenp1026 {\lang1033\langfe1026\langnp1033\insrsid13708270 a}{\b\lang1033\langfe1026\langnp1033\insrsid13708270\charrsid13708270 bc}{ -\lang1033\langfe1026\langnp1033\insrsid6048286\charrsid13708270 -\par }}'! ! -!RTFConversionTest class methodsFor: 'rtf examples' stamp: 'jmv 3/13/2012 11:45'! - rtfColoredSample1 - " - | rtf | - rtf _ RTFConversionTest rtfColoredSample1. - 'Works on the mac'. - ExtendedClipboardInterface current - clearClipboard; - addClipboardData: (rtf withLineEndings: String crString) dataFormat: 'public.rtf' - " - ^'{\rtf1\ansi\ansicpg1251\uc1\deff0\stshfdbch0\stshfloch0\stshfhich0\stshfbi0\deflang1026\deflangfe1026{\fonttbl{\f0\froman\fcharset204\fprq2{\*\panose 02020603050405020304}Times New Roman{\*\falt Times New Roman};} -{\f211\froman\fcharset0\fprq2 Times New Roman{\*\falt Times New Roman};}{\f209\froman\fcharset238\fprq2 Times New Roman CE{\*\falt Times New Roman};}{\f212\froman\fcharset161\fprq2 Times New Roman Greek{\*\falt Times New Roman};} -{\f213\froman\fcharset162\fprq2 Times New Roman Tur{\*\falt Times New Roman};}{\f214\froman\fcharset177\fprq2 Times New Roman (Hebrew){\*\falt Times New Roman};}{\f215\froman\fcharset178\fprq2 Times New Roman (Arabic){\*\falt Times New Roman};} -{\f216\froman\fcharset186\fprq2 Times New Roman Baltic{\*\falt Times New Roman};}{\f217\froman\fcharset163\fprq2 Times New Roman (Vietnamese){\*\falt Times New Roman};}}{\colortbl;\red0\green0\blue0;\red0\green0\blue255;\red0\green255\blue255; -\red0\green255\blue0;\red255\green0\blue255;\red255\green0\blue0;\red255\green255\blue0;\red255\green255\blue255;\red0\green0\blue128;\red0\green128\blue128;\red0\green128\blue0;\red128\green0\blue128;\red128\green0\blue0;\red128\green128\blue0; -\red128\green128\blue128;\red192\green192\blue192;}{\stylesheet{\ql \li0\ri0\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \fs24\lang1026\langfe1026\cgrid\langnp1026\langfenp1026 \snext0 Normal;}{\*\cs10 \additive \ssemihidden -Default Paragraph Font;}{\*\ts11\tsrowd\trftsWidthB3\trpaddl108\trpaddr108\trpaddfl3\trpaddft3\trpaddfb3\trpaddfr3\tscellwidthfts0\tsvertalt\tsbrdrt\tsbrdrl\tsbrdrb\tsbrdrr\tsbrdrdgl\tsbrdrdgr\tsbrdrh\tsbrdrv -\ql \li0\ri0\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \fs20\lang1024\langfe1024\cgrid\langnp1024\langfenp1024 \snext11 \ssemihidden Normal Table;}}{\*\latentstyles\lsdstimax156\lsdlockeddef0}{\*\rsidtbl \rsid6056135}{\*\generator Micro -soft Word 11.0.6568;}{\info{\title Red green blue}{\author triffon}{\operator triffon}{\creatim\yr2006\mo5\dy5\hr17\min22}{\revtim\yr2006\mo5\dy5\hr17\min29}{\version1}{\edmins7}{\nofpages1}{\nofwords2}{\nofchars13}{\*\company SU}{\nofcharsws14} -{\vern24579}}\paperw11906\paperh16838\margl1417\margr1417\margt1417\margb1417 \deftab708\widowctrl\ftnbj\aenddoc\hyphhotz425\noxlattoyen\expshrtn\noultrlspc\dntblnsbdb\nospaceforul\formshade\horzdoc\dgmargin\dghspace180\dgvspace180\dghorigin1417 -\dgvorigin1417\dghshow1\dgvshow1\jexpand\viewkind1\viewscale130\pgbrdrhead\pgbrdrfoot\splytwnine\ftnlytwnine\htmautsp\nolnhtadjtbl\useltbaln\alntblind\lytcalctblwd\lyttblrtgr\lnbrkrule\nobrkwrptbl\snaptogridincell\allowfieldendsel\wrppunct -\asianbrkrule\rsidroot6056135\newtblstyruls\nogrowautofit \fet0\sectd \linex0\headery708\footery708\colsx708\endnhere\sectlinegrid360\sectdefaultcl\sftnbj {\*\pnseclvl1\pnucrm\pnstart1\pnindent720\pnhang {\pntxta .}}{\*\pnseclvl2 -\pnucltr\pnstart1\pnindent720\pnhang {\pntxta .}}{\*\pnseclvl3\pndec\pnstart1\pnindent720\pnhang {\pntxta .}}{\*\pnseclvl4\pnlcltr\pnstart1\pnindent720\pnhang {\pntxta )}}{\*\pnseclvl5\pndec\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}{\*\pnseclvl6 -\pnlcltr\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}{\*\pnseclvl7\pnlcrm\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}{\*\pnseclvl8\pnlcltr\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}{\*\pnseclvl9\pnlcrm\pnstart1\pnindent720\pnhang -{\pntxtb (}{\pntxta )}}\pard\plain \ql \li0\ri0\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \fs24\lang1026\langfe1026\cgrid\langnp1026\langfenp1026 {\cf6\lang1033\langfe1026\langnp1033\insrsid6056135\charrsid6056135 Red}{ -\lang1033\langfe1026\langnp1033\insrsid6056135 }{\cf4\lang1033\langfe1026\langnp1033\insrsid6056135\charrsid6056135 green}{\lang1033\langfe1026\langnp1033\insrsid6056135 }{\cf2\lang1033\langfe1026\langnp1033\insrsid6056135\charrsid6056135 blue}{ -\lang1033\langfe1026\langnp1033\insrsid6056135\charrsid6056135 -\par }}'! ! -!RTFConversionTest class methodsFor: 'rtf examples' stamp: 'jmv 3/13/2012 11:45'! - rtfColoredSample2 - " - | rtf | - rtf _ RTFConversionTest rtfColoredSample2. - 'Works on the mac'. - ExtendedClipboardInterface current - clearClipboard; - addClipboardData: (rtf withLineEndings: String cStringr) dataFormat: 'public.rtf' - " - ^'{\rtf1\ansi\ansicpg1252\cocoartf949\cocoasubrtf540 -{\fonttbl\f0\froman\fcharset0 TimesNewRomanPSMT;} -{\colortbl;\red255\green255\blue255;\red255\green0\blue0;\red0\green255\blue0;\red0\green0\blue255; -} -\deftab708 -\pard\pardeftab708\ri-432 - -\f0\fs24 \cf2 Red\cf0 \cf3 green\cf0 \cf4 blue}'! ! -!RTFConversionTest class methodsFor: 'rtf examples' stamp: 'jmv 3/13/2012 11:45'! - rtfSample1 - " - | rtf | - rtf _ RTFConversionTest rtfSample1. - 'Works on the mac'. - ExtendedClipboardInterface current - clearClipboard; - addClipboardData: (rtf withLineEndings: String crString) dataFormat: 'public.rtf' - " - ^'{\rtf1\ansi\ansicpg1251\uc1\deff0\stshfdbch0\stshfloch0\stshfhich0\stshfbi0\deflang1026\deflangfe1026{\fonttbl{\f0\froman\fcharset204\fprq2{\*\panose 02020603050405020304}Times New Roman;} -{\f1\fswiss\fcharset204\fprq2{\*\panose 020b0604020202020204}Arial;}{\f92\froman\fcharset0\fprq2 Times New Roman;}{\f90\froman\fcharset238\fprq2 Times New Roman CE;}{\f93\froman\fcharset161\fprq2 Times New Roman Greek;} -{\f94\froman\fcharset162\fprq2 Times New Roman Tur;}{\f95\froman\fcharset177\fprq2 Times New Roman (Hebrew);}{\f96\froman\fcharset178\fprq2 Times New Roman (Arabic);}{\f97\froman\fcharset186\fprq2 Times New Roman Baltic;} -{\f98\froman\fcharset163\fprq2 Times New Roman (Vietnamese);}{\f102\fswiss\fcharset0\fprq2 Arial;}{\f100\fswiss\fcharset238\fprq2 Arial CE;}{\f103\fswiss\fcharset161\fprq2 Arial Greek;}{\f104\fswiss\fcharset162\fprq2 Arial Tur;} -{\f105\fswiss\fcharset177\fprq2 Arial (Hebrew);}{\f106\fswiss\fcharset178\fprq2 Arial (Arabic);}{\f107\fswiss\fcharset186\fprq2 Arial Baltic;}{\f108\fswiss\fcharset163\fprq2 Arial (Vietnamese);}}{\colortbl;\red0\green0\blue0;\red0\green0\blue255; -\red0\green255\blue255;\red0\green255\blue0;\red255\green0\blue255;\red255\green0\blue0;\red255\green255\blue0;\red255\green255\blue255;\red0\green0\blue128;\red0\green128\blue128;\red0\green128\blue0;\red128\green0\blue128;\red128\green0\blue0; -\red128\green128\blue0;\red128\green128\blue128;\red192\green192\blue192;}{\stylesheet{\ql \li0\ri0\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \fs24\lang1026\langfe1026\cgrid\langnp1026\langfenp1026 \snext0 Normal;}{\*\cs10 \additive -\ssemihidden Default Paragraph Font;}{\*\ts11\tsrowd\trftsWidthB3\trpaddl108\trpaddr108\trpaddfl3\trpaddft3\trpaddfb3\trpaddfr3\tscellwidthfts0\tsvertalt\tsbrdrt\tsbrdrl\tsbrdrb\tsbrdrr\tsbrdrdgl\tsbrdrdgr\tsbrdrh\tsbrdrv -\ql \li0\ri0\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \fs20\lang1024\langfe1024\cgrid\langnp1024\langfenp1024 \snext11 \ssemihidden Normal Table;}}{\*\rsidtbl \rsid670965\rsid4534232\rsid4597070\rsid8857962\rsid13514577\rsid13519090} -{\*\generator Microsoft Word 10.0.4219;}{\info{\title aaabbbccc}{\author kalin}{\operator kalin}{\creatim\yr2006\mo4\dy29\hr15\min39}{\revtim\yr2006\mo4\dy30\hr18\min47}{\version8}{\edmins1}{\nofpages1}{\nofwords4}{\nofchars29}{\*\company HCData} -{\nofcharsws32}{\vern16469}}\paperw11906\paperh16838\margl1417\margr1417\margt1417\margb1417 \deftab708\widowctrl\ftnbj\aenddoc\hyphhotz425\noxlattoyen\expshrtn\noultrlspc\dntblnsbdb\nospaceforul\hyphcaps0\formshade\horzdoc\dgmargin\dghspace180 -\dgvspace180\dghorigin1417\dgvorigin1417\dghshow1\dgvshow1 -\jexpand\viewkind1\viewscale100\pgbrdrhead\pgbrdrfoot\splytwnine\ftnlytwnine\htmautsp\nolnhtadjtbl\useltbaln\alntblind\lytcalctblwd\lyttblrtgr\lnbrkrule\nobrkwrptbl\snaptogridincell\allowfieldendsel\wrppunct\asianbrkrule\rsidroot4534232 \fet0\sectd -\linex0\headery708\footery708\colsx708\endnhere\sectlinegrid360\sectdefaultcl\sftnbj {\*\pnseclvl1\pnucrm\pnstart1\pnindent720\pnhang {\pntxta .}}{\*\pnseclvl2\pnucltr\pnstart1\pnindent720\pnhang {\pntxta .}}{\*\pnseclvl3\pndec\pnstart1\pnindent720\pnhang -{\pntxta .}}{\*\pnseclvl4\pnlcltr\pnstart1\pnindent720\pnhang {\pntxta )}}{\*\pnseclvl5\pndec\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}{\*\pnseclvl6\pnlcltr\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}{\*\pnseclvl7 -\pnlcrm\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}{\*\pnseclvl8\pnlcltr\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}{\*\pnseclvl9\pnlcrm\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}\pard\plain -\ql \li0\ri0\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \fs24\lang1026\langfe1026\cgrid\langnp1026\langfenp1026 {\b\i\lang1033\langfe1026\langnp1033\insrsid670965\charrsid670965 aaa}{\lang1033\langfe1026\langnp1033\insrsid670965 bbb}{ -\b\lang1033\langfe1026\langnp1033\insrsid670965\charrsid670965 ccc}{\lang1033\langfe1026\langnp1033\insrsid8857962 -\par }{\lang1033\langfe1026\langnp1033\insrsid670965 -\par ddd}{\f1\lang1033\langfe1026\langnp1033\insrsid670965\charrsid670965 eee}{\lang1033\langfe1026\langnp1033\insrsid670965 fff -\par ggg}{\b\i\f1\lang1033\langfe1026\langnp1033\insrsid670965\charrsid670965 hhh}{\lang1033\langfe1026\langnp1033\insrsid670965 iii -\par }} -'! ! -!RTFConversionTest class methodsFor: 'rtf examples' stamp: 'jmv 3/13/2012 11:45'! - rtfSrcCharFormat - " - | rtf | - rtf _ RTFConversionTest rtfSrcCharFormat. - 'Works on the mac'. - ExtendedClipboardInterface current - clearClipboard; - addClipboardData: (rtf withLineEndings: String crString) dataFormat: 'public.rtf' - " - ^'{\rtf1\mac\ansicpg10000\uc1\deff0\stshfdbch0\stshfloch0\stshfhich0\stshfbi0\deflang1033\deflangfe1033{\upr{\fonttbl{\f0\fnil\fcharset256\fprq2{\*\panose 00020206030504050203}Times New Roman;} -{\f1\fnil\fcharset256\fprq2{\*\panose 00020b06040202020202}Arial;}}{\*\ud{\fonttbl{\f0\fnil\fcharset256\fprq2{\*\panose 00020206030504050203}Times New Roman;}{\f1\fnil\fcharset256\fprq2{\*\panose 00020b06040202020202}Arial;}}}} -{\colortbl;\red0\green0\blue0;\red0\green0\blue255;\red0\green255\blue255;\red0\green255\blue0;\red255\green0\blue255;\red255\green0\blue0;\red255\green255\blue0;\red255\green255\blue255;\red0\green0\blue128;\red0\green128\blue128;\red0\green128\blue0; -\red128\green0\blue128;\red128\green0\blue0;\red128\green128\blue0;\red128\green128\blue128;\red192\green192\blue192;}{\stylesheet{\ql \li0\ri0\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 -\lang1033\langfe1033\cgrid\langnp1033\langfenp1033 \snext0 Normal;}{\*\cs10 \additive Default Paragraph Font;}{\* -\ts11\tsrowd\trftsWidthB3\trpaddl108\trpaddr108\trpaddfl3\trpaddft3\trpaddfb3\trpaddfr3\trcbpat1\trcfpat1\tscellwidthfts0\tsvertalt\tsbrdrt\tsbrdrl\tsbrdrb\tsbrdrr\tsbrdrdgl\tsbrdrdgr\tsbrdrh\tsbrdrv -\ql \li0\ri0\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \fs20\lang1024\langfe1024\cgrid\langnp1024\langfenp1024 \snext11 Normal Table;}{\s15\ql \li0\ri0\widctlpar\tqc\tx4320\tqr\tx8640\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 -\lang1033\langfe1033\cgrid\langnp1033\langfenp1033 \sbasedon0 \snext15 header;}}{\*\rsidtbl \rsid12155552}{\info{\title This test is written using \''d2Microsoft Word Test Drive\''d3 for Mac}{\author Office 2004 Test Drive User} -{\operator Office 2004 Test Drive User}{\creatim\yr2006\mo5\dy6\min58}{\revtim\yr2006\mo5\dy6\min58}{\version2}{\edmins0}{\nofpages1}{\nofwords0}{\nofchars0}{\nofcharsws0}{\vern24835}}\paperw11900\paperh16840 -\ftnbj\aenddoc\noxlattoyen\expshrtn\noultrlspc\dntblnsbdb\nospaceforul\formshade\horzdoc\dghspace180\dgvspace180\dghorigin1701\dgvorigin1984\dghshow0\dgvshow0 -\jexpand\viewkind1\viewscale130\pgbrdrhead\pgbrdrfoot\splytwnine\ftnlytwnine\htmautsp\nolnhtadjtbl\useltbaln\alntblind\lytcalctblwd\lyttblrtgr\lnbrkrule\nobrkwrptbl\rsidroot16320125 \fet0\sectd \linex0\endnhere\sectdefaultcl\sectrsid12517500\sftnbj -{\header \pard\plain \s15\ql \li0\ri0\widctlpar\tqc\tx4320\tqr\tx8640\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \lang1033\langfe1033\cgrid\langnp1033\langfenp1033 {\insrsid12517500 -\par }}{\*\pnseclvl1\pnucrm\pnstart1\pnindent720\pnhang{\pntxta .}}{\*\pnseclvl2\pnucltr\pnstart1\pnindent720\pnhang{\pntxta .}}{\*\pnseclvl3\pndec\pnstart1\pnindent720\pnhang{\pntxta .}}{\*\pnseclvl4\pnlcltr\pnstart1\pnindent720\pnhang{\pntxta )}} -{\*\pnseclvl5\pndec\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}{\*\pnseclvl6\pnlcltr\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}{\*\pnseclvl7\pnlcrm\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}{\*\pnseclvl8 -\pnlcltr\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}{\*\pnseclvl9\pnlcrm\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}\pard\plain \ql \li0\ri0\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 -\lang1033\langfe1033\cgrid\langnp1033\langfenp1033 {\insrsid12517500 This test is written using \ldblquote Microsoft Word Test Drive\rdblquote for Mac. It is shows some aspects of the character formattings, like: }{ -\b\cf6\insrsid12517500\charrsid12517500 Color}{\insrsid12517500 , }{\b\insrsid12517500\charrsid12517500 Bold}{\insrsid12517500 , }{\b\i\insrsid12517500\charrsid12517500 Bold Italic}{\insrsid12517500 , }{\i\insrsid12517500\charrsid12517500 Italic}{ -\insrsid12517500 , and }{\ul\insrsid12517500\charrsid12517500 Underlining}{\insrsid12517500\charrsid12517500 .}{\ul\insrsid12517500\charrsid12517500 }{\insrsid12517500\charrsid12517500 -\par }{\f1\fs28\insrsid12517500\charrsid12517500 This is the Arial font, sized 14}{\insrsid12517500\charrsid12517500 . -\par }}'! ! -!RTFConversionTest class methodsFor: 'rtf examples' stamp: 'jmv 3/13/2012 11:45'! - rtfSrcParagraphFormatting - " - | rtf | - rtf _ RTFConversionTest rtfSrcParagraphFormatting. - 'Works on the mac'. - ExtendedClipboardInterface current - clearClipboard; - addClipboardData: (rtf withLineEndings: String crString) dataFormat: 'public.rtf' - " - ^'{\rtf1\mac\ansicpg10000\cocoartf824\cocoasubrtf350 -{\fonttbl\f0\froman\fcharset77 TimesNewRomanPSMT;} -{\colortbl;\red255\green255\blue255;} -{\info -{\title This is a test of all formatting needed} -{\author Compay Sedungo} -{\*\company WAY AHEAD}}\vieww9200\viewh8100\viewkind1\viewscale100 -\deftab720 -\pard\pardeftab720\ri0 - -\f0\fs24 \cf0 This is a test of almost all paragraph formatting needed.\ -\pard\pardeftab720\fi7200\ri0\sb400 -\cf0 This is left aligned and with 20pt before. And has indentFirst\ -\pard\pardeftab720\ri0\sa300\qc -\cf0 This is centered and with 15pt after\ -\pard\pardeftab720\ri0\qr -\cf0 This is right aligned\ -\pard\pardeftab720\li1440\ri2880\qj -\cf0 This is justified and with left and right indents\ -\pard\pardeftab720\ri0 -\cf0 \ -}'! ! -!RTFConversionTest class methodsFor: 'rtf examples' stamp: 'jmv 3/13/2012 11:45'! - rtfSrcPrefaceHalsOriginal - " - | rtf | - rtf _ RTFConversionTest rtfSrcPrefaceHalsOriginal. - 'Works on the mac'. - ExtendedClipboardInterface current - clearClipboard; - addClipboardData: (rtf withLineEndings: String crString) dataFormat: 'public.rtf' - " - ^'{\rtf1\mac\ansicpg10000\uc1 \deff4\deflang1033\deflangfe1033{\upr{\fonttbl{\f0\fnil\fcharset256\fprq2{\*\panose 00020206030504050203}Times New Roman;}{\f4\fnil\fcharset256\fprq2{\*\panose 00020005000000000000}Times;} -{\f5\fnil\fcharset256\fprq2{\*\panose 00020005000000000000}Helvetica;}{\f216\fnil\fcharset256\fprq2{\*\panose 0204002c795c00000002}Palex{\*\falt Times New Roman};}}{\*\ud{\fonttbl{\f0\fnil\fcharset256\fprq2{\*\panose 00020206030504050203}Times New Roman;} -{\f4\fnil\fcharset256\fprq2{\*\panose 00020005000000000000}Times;}{\f5\fnil\fcharset256\fprq2{\*\panose 00020005000000000000}Helvetica;}{\f216\fnil\fcharset256\fprq2{\*\panose 0204002c795c00000002}Palex{\*\falt Times New Roman};}}}} -{\colortbl;\red0\green0\blue0;\red0\green0\blue255;\red0\green255\blue255;\red0\green255\blue0;\red255\green0\blue255;\red255\green0\blue0;\red255\green255\blue0;\red255\green255\blue255;\red0\green0\blue128;\red0\green128\blue128;\red0\green128\blue0; -\red128\green0\blue128;\red128\green0\blue0;\red128\green128\blue0;\red128\green128\blue128;\red192\green192\blue192;}{\stylesheet{\widctlpar\faauto\adjustright\rin0\lin0\itap0 \f4\lang1033\cgrid \snext0 Normal;}{\*\cs10 \additive Default Paragraph Font;} -{\*\cs15 \additive \ul\cf2 \sbasedon10 Hyperlink;}{\*\cs16 \additive \ul\cf12 \sbasedon10 FollowedHyperlink;}}{\info{\title PREFACE}{\author Bob Stein}{\operator dan visel}{\creatim\yr1999\mo6\dy20\hr10\min39}{\revtim\yr2006\mo4\dy12\hr8\min2}{\version6} -{\edmins22}{\nofpages4}{\nofwords1299}{\nofchars7408}{\nofcharsws9097}{\vern16525}}\ftnbj\aenddoc\noxlattoyen\expshrtn\noultrlspc\dntblnsbdb\nospaceforul\hyphcaps0\formshade\horzdoc\dgmargin\dghspace120\dgvspace120\dghorigin1701\dgvorigin1984\dghshow0 -\dgvshow3\jcompress\viewkind4\viewscale150\pgbrdrhead\pgbrdrfoot\nolnhtadjtbl \fet0\sectd \linex0\endnhere\sectdefaultcl {\*\pnseclvl1\pnucrm\pnstart1\pnindent720\pnhang{\pntxta .}}{\*\pnseclvl2\pnucltr\pnstart1\pnindent720\pnhang{\pntxta .}}{\*\pnseclvl3 -\pndec\pnstart1\pnindent720\pnhang{\pntxta .}}{\*\pnseclvl4\pnlcltr\pnstart1\pnindent720\pnhang{\pntxta )}}{\*\pnseclvl5\pndec\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}{\*\pnseclvl6\pnlcltr\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}} -{\*\pnseclvl7\pnlcrm\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}{\*\pnseclvl8\pnlcltr\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}{\*\pnseclvl9\pnlcrm\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}\pard\plain \sl-340\slmult0 -\widctlpar\faauto\adjustright\rin0\lin0\itap0 \f4\lang1033\cgrid {\i\f216\fs28\cf1 I am a HAL Nine Thousand computer, Production Number 3. I became operational at the HAL Plant in Urbana, Illinois, on January 12, 1997. }{\f216\fs28\cf1 }{\fs28\cf1 -\par }\pard \qr\sl-340\slmult0\widctlpar\faauto\adjustright\rin0\lin0\itap0 {\f216\cf1 - }{\i\f216\cf1 HAL, 2001: A Space Odyssey }{\f216\cf1 (the novel) -\par }\pard \sl-340\slmult0\widctlpar\faauto\adjustright\rin0\lin0\itap0 {\cf1 -\par }{\f216\cf1 At a dinner party some time ago, an acquaintance, a nonscientist, asked me - in a casual way about my duties as chief scientist at a research lab. I said that one of my great joys was overseeing a wide range of projects, to varying extents, and I mentioned a few of them: pattern recognition, machine learning, neural networks, com -p -uter-chip design, supercomputer design, image compression, expert systems, handwriting recognition, document analysis, uses of global networks such as the World Wide Web, novel human-machine interfaces, and so on. Then I turned to one of the areas of my p -articular expertise: lipreading by computer. -\par }{\cf1 -\par }{\f216\cf1 "Oh," she said, "Like HAL." Ah, a kindred soul, I thought. We spent quite some time discussing the state of the art and the challenges of computer lipreading, its possible applications, and so on. Later our dis -cussion turned to other topics suggested by the movie - language understanding, chess, computer vision, artificial intelligence. It was clear that she was interested in the current state of the art and that many years before the film had both caught her i -magination and helped her identify crucial issues in today''s computer science. One of the questions she asked was, "How realistic was HAL?" -\par }{\cf1 -\par }{\f216\cf1 This book is for people like her. And because no one is an expert in all the topics covered in the film, even scien -tists are sure to learn from the accounts of other areas. The book is much more than an answer to her question, though. It has four major goals, which it addresses in varying proportions in the sixteen chapters. -\par -\par }{\b\f5\cf1 Analysis -\par }{\f216\cf1 It is a testament to Clarke and -Kubrick''s achievement that 2001 still holds up to close scrutiny in the late 1990s. Under the expert eyes of the contributors, the most innocuous aspects of scenes - a line of computer code on a screen, a chess move, the use of a word, the form of a butto -n - reveal a great deal. Even though I''ve seen the film several dozen times, I have learned an immense amount from the contributors. }{\i\f216\cf1 HAL''s Legacy}{\f216\cf1 seeks to do for }{\i\f216\cf1 2001}{\f216\cf1 - what good art history does for a major painting; namely, make the viewer see it in a new light - a tall order, to be sure!! -\par -\par }{\b\f5\cf1 Teaching}{\f5\cf1 -\par }{\f216\cf1 The film illustrates key ideas in several disciplines of computer science, and thus provides a springboard for discussions of the field in greater depth, including our own research. Descriptions of the world com -puter chess champion Deep Blue system, the commercially successful VOICE recognition system, the massive CYC artificial-intelligence project, the award-winning Mathematica software system, and much more are here discussed by their creators at a level acce -ssible to the general reader. -\par -\par }{\b\f5\cf1 Prognostication }{\f5\cf1 -\par }{\f216\cf1 It is natural, too, to look to the future. Several contributors make informed and fascinating predictions based on developments in the field. What are the most promising approaches toward artificial intellig -ence? Will we ever be able to "reverse engineer" a human brain and represent it in a computer? -\par -\par }{\b\f5\cf1 Reflection }{\f5\cf1 -\par }{\i\f216\cf1 2001}{\f216\cf1 transcends the label of "science fiction movie" and captures many of the central metaphors of our time, telling us much about society and its - aspirations. The film has even been praised by the pope!! Many people have been deeply affected by the film, among them several contributors who reflect here about its influence on their own careers and on computer science in general. -\par }{\cf1 -\par }{\f216\cf1 Clearly, }{\i\f216\cf1 HAL''s Legacy}{\f216\cf1 - differs from books on the making of the film or its cinematography. It differs, too, from books that analyze the science shown in movies or on television - science that is incidental and just "goes along for the ride." To an extent unprecedented and nev -er duplicated in a feature film, the makers of 2001 were as careful as possible to get things right; when they did make errors, they often did so in illuminating ways. -\par -\par Now seems like the perfect time for }{\i\f216\cf1 HAL''s Legacy.}{\f216\cf1 - Birthdays are an important theme in the film (there are at least five of them), and in the novel, HAL "becomes operational ... on January 12, 1997." Kubrick changed the year to 1992 for the film version - perhaps to give HAL a longer lifetime and so make - -his death more poignant. On the 1992 date, I - along with colleagues, faculty, and assorted Silicon Valley friends - held a birthday party for HAL. I was interviewed by several papers, and an Associated Press photo of me cutting the HAL cake (shaped like -his console, complete with red LED under a clear plastic hemisphere) appeared worldwide. I was pleasantly surprised to learn that much of the general public was interested in HAL too. -\par -\par It has been particularly rewarding for me to work with this group of co -ntributors - all of whom were chosen because of their preeminence in their respective subfields. I have known a few of them personally for many years; Azriel Rosenfeld was on my dissertation committee. Others I met serving on panel discussions. I''ll never - -forget the time I came dressed in a suit while fellow panelist Marvin Minsky showed up in a Pac Man T-shirt. Yet others I knew primarily through their books - Dan Dennett and Don Norman, for example - and still others are inventors of products I use regul -a -rly (e.g., Steve Wolfram''s Mathematica). At our meetings and dinners in Stanford, Urbana, and Cambridge, and through frequent written messages, we passed many ideas back and forth. Although I had strong ideas about what I wanted them to write, they all ha -d the good sense to ignore me when appropriate. At times I felt like someone trying to herd cats. -\par }{\cf1 -\par }{\f216\cf1 Even at a distance, there was a great sense of camaraderie. As we approached one of the important publishing deadlines, one contributor, who was still late w -ith a chapter, replied to my frantic entreaties thus: "Dave, I honestly think you ought to sit down calmly, take a stress pill and think things over." A later message read, "I still have every confidence in the success of my chapter," which at first broug -ht bemusement but then a diffuse sense of dread. -\par -\par It has been a privilege to correspond with Arthur C. Clarke, whose work inspired us all. Throughout the preparation of this book he has been gracious, enthusiastic, and helpful. -\par }{\cf1 -\par }{\f216\cf1 Although I did my writing -and editing at home, often late into the night and on weekends, I would like to thank my colleagues at the Ricoh California Research Center for their support of our ongoing research, which influenced this book in numerous ways: Greg Wolff, K.V. Prasad, Mi -c -hael Angelo (yes, that''s his real name), Morten Pedersen (visiting from the Technical University of Denmark), Stanford graduate students Vicky Lu, Chuck Lam, and (especially) Marcus Hennecke (by the time this book is released, Dr. Hennecke!!). Thanks also -go to Director Peter Hart for making CRC such a great place to work. -\par }{\cf1 -\par }{\f216\cf1 This book was improved indirectly by a large number of people. One colleague pointed out a used bookstore selling an out-of-print book about the filming of 2001; an acquaintance asked a -"naive" question that ultimately led to a new section in a chapter; a student told me about a 2001 World Wide Web site; an intrepid cab driver took me through the blizzard of ''96 to interview Marvin Minsky. Piers Bizony, whose book on the filming of 2001 -b -oth inspired and informed me, made several transatlantic phone calls and helped me track down photographs. I also had a somewhat eerie telephone conversation with Douglas Rain, the Canadian actor who played the voice of HAL. Thanks go also to the efficien -t staff at Turner Broadcasting for their assistance providing stills from the film. -\par }{\cf1 -\par }{\f216\cf1 An extra-special thanks goes to my editor at the MIT Press, Bob Prior. He was the only person in the publishing industry who "got" the idea of HAL''s Legacy instantly, as p -roven by his enthusiastic response to my proposal. Michael Rutter, also at the Press, helped obtain illustrations and kept track of numerous production details. Sandra Minkkinen helped to orchestrate the editing and production process for the entire proje -ct, and copy editor Roberta Clark improved the text immeasurably. -\par }{\cf1 -\par }{\f216\cf1 Deep appreciation goes to my immediate family - Nancy, Alex, and Olivia - for putting up with my many late nights and weekend hours working on the book. I am happy to say that groggy Saturd -ay mornings after marathon editing sessions are now a thing of the past, and we can spend more time doing what we all love so much: hiking Mount Tamalpais and the Marin headlands and kayaking on Squibnocket Pond. -\par }{\cf1 -\par }{\f216\cf1 David G. Stork -\par Stanford, California -\par January 12, 1996 }{\cf1 -\par -\par -\par }{\f216\cf1 UCSC Perpetual Science Laboratory }{\field{\*\fldinst {\f216\cf1 HYPERLINK "http://mambo.ucsc.edu/" }{\f216\cf1 {\*\datafield -00d0c9ea79f9bace118c8200aa004ba90b02000000170000001700000068007400740070003a002f002f006d0061006d0062006f002e0075006300730063002e006500640075002f000000e0c9ea79f9bace118c8200aa004ba90b2e00000068007400740070003a002f002f006d0061006d0062006f002e00750063007300 -63002e006500640075002f000000}}}{\fldrslt {\cs15\f216\ul\cf2 http://mambo.ucsc.edu/}}}{\f216\cf1 -\par Ricoh''s California Research Center }{\field{\*\fldinst {\f216\cf1 HYPERLINK "http://www.crc.ricoh.com/" }{\f216\cf1 {\*\datafield -00d0c9ea79f9bace118c8200aa004ba90b0200000003000000e0c9ea79f9bace118c8200aa004ba90b3400000068007400740070003a002f002f007700770077002e006300720063002e007200690063006f0068002e0063006f006d002f000000}}}{\fldrslt {\cs15\f216\ul\cf2 http://www.crc.ricoh.com/}}}{ -\cf1 -\par -\par -\par }{ -\par }}' -! ! -!RTFConversionTest class methodsFor: 'rtf examples' stamp: 'jmv 3/13/2012 11:45'! - rtfSrcSpacing - " - | rtf | - rtf _ RTFConversionTest rtfSrcSpacing. - 'Works on the mac'. - ExtendedClipboardInterface current - clearClipboard; - addClipboardData: (rtf withLineEndings: String crString) dataFormat: 'public.rtf' - " - ^'{\rtf1\ansi\ansicpg1252\uc1\deff0\stshfdbch0\stshfloch0\stshfhich0\stshfbi0\deflang1033\deflangfe1033{\fonttbl{\f0\froman\fcharset0\fprq2{\*\panose 02020603050405020304}Times New Roman;}{\f81\froman\fcharset238\fprq2 Times New Roman CE;} -{\f82\froman\fcharset204\fprq2 Times New Roman Cyr;}{\f84\froman\fcharset161\fprq2 Times New Roman Greek;}{\f85\froman\fcharset162\fprq2 Times New Roman Tur;}{\f86\froman\fcharset177\fprq2 Times New Roman (Hebrew);} -{\f87\froman\fcharset178\fprq2 Times New Roman (Arabic);}{\f88\froman\fcharset186\fprq2 Times New Roman Baltic;}{\f89\froman\fcharset163\fprq2 Times New Roman (Vietnamese);}}{\colortbl;\red0\green0\blue0;\red0\green0\blue255;\red0\green255\blue255; -\red0\green255\blue0;\red255\green0\blue255;\red255\green0\blue0;\red255\green255\blue0;\red255\green255\blue255;\red0\green0\blue128;\red0\green128\blue128;\red0\green128\blue0;\red128\green0\blue128;\red128\green0\blue0;\red128\green128\blue0; -\red128\green128\blue128;\red192\green192\blue192;}{\stylesheet{\ql \li0\ri0\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \fs24\lang1033\langfe1033\cgrid\langnp1033\langfenp1033 \snext0 Normal;}{\*\cs10 \additive \ssemihidden -Default Paragraph Font;}{\*\ts11\tsrowd\trftsWidthB3\trpaddl108\trpaddr108\trpaddfl3\trpaddft3\trpaddfb3\trpaddfr3\tscellwidthfts0\tsvertalt\tsbrdrt\tsbrdrl\tsbrdrb\tsbrdrr\tsbrdrdgl\tsbrdrdgr\tsbrdrh\tsbrdrv -\ql \li0\ri0\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \fs20\lang1024\langfe1024\cgrid\langnp1024\langfenp1024 \snext11 \ssemihidden Normal Table;}}{\*\latentstyles\lsdstimax156\lsdlockeddef0}{\*\rsidtbl \rsid9840235}{\*\generator Micro -soft Word 11.0.6568;}{\info{\title This example is a test of line spacing}{\author Compay Sedungo}{\operator Compay Sedungo}{\creatim\yr2006\mo5\dy4\hr10\min14}{\revtim\yr2006\mo5\dy4\hr10\min18}{\version1}{\edmins4}{\nofpages1}{\nofwords153} -{\nofchars873}{\*\company WAY AHEAD}{\nofcharsws1024}{\vern24579}}\widowctrl\ftnbj\aenddoc\noxlattoyen\expshrtn\noultrlspc\dntblnsbdb\nospaceforul\formshade\horzdoc\dgmargin\dghspace180\dgvspace180\dghorigin1800\dgvorigin1440\dghshow1\dgvshow1 -\jexpand\viewkind1\viewscale100\pgbrdrhead\pgbrdrfoot\splytwnine\ftnlytwnine\htmautsp\nolnhtadjtbl\useltbaln\alntblind\lytcalctblwd\lyttblrtgr\lnbrkrule\nobrkwrptbl\viewnobound1\snaptogridincell\allowfieldendsel -\wrppunct\asianbrkrule\rsidroot9840235\newtblstyruls\nogrowautofit \fet0\sectd \linex0\endnhere\sectlinegrid360\sectdefaultcl\sftnbj {\*\pnseclvl1\pnucrm\pnstart1\pnindent720\pnhang {\pntxta .}}{\*\pnseclvl2\pnucltr\pnstart1\pnindent720\pnhang -{\pntxta .}}{\*\pnseclvl3\pndec\pnstart1\pnindent720\pnhang {\pntxta .}}{\*\pnseclvl4\pnlcltr\pnstart1\pnindent720\pnhang {\pntxta )}}{\*\pnseclvl5\pndec\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}{\*\pnseclvl6\pnlcltr\pnstart1\pnindent720\pnhang -{\pntxtb (}{\pntxta )}}{\*\pnseclvl7\pnlcrm\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}{\*\pnseclvl8\pnlcltr\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}{\*\pnseclvl9\pnlcrm\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}\pard\plain -\ql \li0\ri0\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0\pararsid9840235 \fs24\lang1033\langfe1033\cgrid\langnp1033\langfenp1033 {\insrsid9840235 This example is a test of line spacing. -Line spacing is the space between lines in a paragraph. Sometimes it is also called paragraph leading. This paragraph is single spaced. -\par }\pard \ql \li0\ri0\sl360\slmult1\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0\pararsid9840235 {\insrsid9840235 This example is a test of line spacing. Line spacing is the space between lines in a paragraph. -Sometimes it is also called paragraph leading. This is 1.5-spaced -\par }\pard \ql \li0\ri0\sl480\slmult1\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0\pararsid9840235 {\insrsid9840235 This example is a test of line spacing. Line spacing is the space between lines in a paragraph. -Sometimes it is also called paragraph leading. This is double-spaced -\par }\pard \ql \li0\ri0\sl240\slmult0\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0\pararsid9840235 {\insrsid9840235 This example is a test of line spacing. Line spacing is the space between lines in a paragraph. -Sometimes it is also called paragraph leading. This is at lease 12pt -\par }\pard \ql \li0\ri0\sl-240\slmult0\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0\pararsid9840235 {\insrsid9840235 This example is a test of line spacing. Line spacing is the space between lines in a paragraph. -Sometimes it is also called paragraph leading. This is exactly 12pt. -\par }\pard \ql \li0\ri0\sl720\slmult1\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0\pararsid9840235 {\insrsid9840235 This example is a test of line spacing. Line spacing is the space between lines in a paragraph. -Sometimes it is also called paragraph leading. This is spaced by a multiple of a line \endash 3 times. -\par }}'! ! -!RTFConversionTest class methodsFor: 'rtf examples' stamp: 'jmv 3/13/2012 11:46'! - rtfSrcSpecialSymbols - " - | rtf | - rtf _ RTFConversionTest rtfSrcSpecialSymbols. - 'Works on the mac'. - ExtendedClipboardInterface current - clearClipboard; - addClipboardData: (rtf withLineEndings: String crString) dataFormat: 'public.rtf' - " - ^'{\rtf1\ansi\ansicpg1252\uc1\deff0\stshfdbch0\stshfloch0\stshfhich0\stshfbi0\deflang1033\deflangfe1033{\fonttbl{\f0\froman\fcharset0\fprq2{\*\panose 02020603050405020304}Times New Roman;}{\f71\froman\fcharset238\fprq2 Times New Roman CE;} - -{\f72\froman\fcharset204\fprq2 Times New Roman Cyr;}{\f74\froman\fcharset161\fprq2 Times New Roman Greek;}{\f75\froman\fcharset162\fprq2 Times New Roman Tur;}{\f76\froman\fcharset177\fprq2 Times New Roman (Hebrew);} - -{\f77\froman\fcharset178\fprq2 Times New Roman (Arabic);}{\f78\froman\fcharset186\fprq2 Times New Roman Baltic;}{\f79\froman\fcharset163\fprq2 Times New Roman (Vietnamese);}}{\colortbl;\red0\green0\blue0;\red0\green0\blue255;\red0\green255\blue255; - -\red0\green255\blue0;\red255\green0\blue255;\red255\green0\blue0;\red255\green255\blue0;\red255\green255\blue255;\red0\green0\blue128;\red0\green128\blue128;\red0\green128\blue0;\red128\green0\blue128;\red128\green0\blue0;\red128\green128\blue0; - -\red128\green128\blue128;\red192\green192\blue192;}{\stylesheet{\ql \li0\ri0\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \fs24\lang1033\langfe1033\cgrid\langnp1033\langfenp1033 \snext0 Normal;}{\*\cs10 \additive \ssemihidden - -Default Paragraph Font;}{\*\ts11\tsrowd\trftsWidthB3\trpaddl108\trpaddr108\trpaddfl3\trpaddft3\trpaddfb3\trpaddfr3\tscellwidthfts0\tsvertalt\tsbrdrt\tsbrdrl\tsbrdrb\tsbrdrr\tsbrdrdgl\tsbrdrdgr\tsbrdrh\tsbrdrv - -\ql \li0\ri0\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \fs20\lang1024\langfe1024\cgrid\langnp1024\langfenp1024 \snext11 \ssemihidden Normal Table;}}{\*\latentstyles\lsdstimax156\lsdlockeddef0}{\*\rsidtbl \rsid11999034}{\*\generator Micr - -osoft Word 11.0.6568;}{\info{\title Tabulation}{\author Compay Sedungo}{\operator Compay Sedungo}{\creatim\yr2006\mo5\dy3\hr10\min7}{\revtim\yr2006\mo5\dy3\hr10\min8}{\version1}{\edmins1}{\nofpages1}{\nofwords8}{\nofchars48}{\*\company WAY AHEAD} - -{\nofcharsws55}{\vern24579}}\widowctrl\ftnbj\aenddoc\noxlattoyen\expshrtn\noultrlspc\dntblnsbdb\nospaceforul\formshade\horzdoc\dgmargin\dghspace180\dgvspace180\dghorigin1800\dgvorigin1440\dghshow1\dgvshow1 - -\jexpand\viewkind1\viewscale100\pgbrdrhead\pgbrdrfoot\splytwnine\ftnlytwnine\htmautsp\nolnhtadjtbl\useltbaln\alntblind\lytcalctblwd\lyttblrtgr\lnbrkrule\nobrkwrptbl\snaptogridincell\allowfieldendsel\wrppunct - -\asianbrkrule\rsidroot11999034\newtblstyruls\nogrowautofit \fet0\sectd \linex0\endnhere\sectlinegrid360\sectdefaultcl\sftnbj {\*\pnseclvl1\pnucrm\pnstart1\pnindent720\pnhang {\pntxta .}}{\*\pnseclvl2\pnucltr\pnstart1\pnindent720\pnhang {\pntxta .}} - -{\*\pnseclvl3\pndec\pnstart1\pnindent720\pnhang {\pntxta .}}{\*\pnseclvl4\pnlcltr\pnstart1\pnindent720\pnhang {\pntxta )}}{\*\pnseclvl5\pndec\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}{\*\pnseclvl6\pnlcltr\pnstart1\pnindent720\pnhang {\pntxtb (} - -{\pntxta )}}{\*\pnseclvl7\pnlcrm\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}{\*\pnseclvl8\pnlcltr\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}{\*\pnseclvl9\pnlcrm\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}\pard\plain - -\ql \li0\ri0\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \fs24\lang1033\langfe1033\cgrid\langnp1033\langfenp1033 {\insrsid11999034 Tabulation\tab tabulation - -\par Return - -\par Return - -\par Softbreak\line softbreak - -\par }}'! ! -!RTFConversionTest class methodsFor: 'rtf examples' stamp: 'jmv 3/13/2012 11:46'! - rtfSrcWin32ClipboardTest - " - | rtf | - rtf _ RTFConversionTest rtfSrcWin32ClipboardTest. - 'Works on the mac'. - ExtendedClipboardInterface current - clearClipboard; - addClipboardData: (rtf withLineEndings: String crString) dataFormat: 'public.rtf' - " - ^'{\rtf1\ansi\ansicpg1251\uc1\deff0\stshfdbch0\stshfloch0\stshfhich0\stshfbi0\deflang1026\deflangfe1026{\fonttbl{\f0\froman\fcharset204\fprq2{\*\panose 02020603050405020304}Times New Roman;} - -{\f38\fswiss\fcharset204\fprq2{\*\panose 020b0604030504040204}Verdana;}{\f174\froman\fcharset0\fprq2 Times New Roman;}{\f172\froman\fcharset238\fprq2 Times New Roman CE;}{\f175\froman\fcharset161\fprq2 Times New Roman Greek;} - -{\f176\froman\fcharset162\fprq2 Times New Roman Tur;}{\f177\froman\fcharset177\fprq2 Times New Roman (Hebrew);}{\f178\froman\fcharset178\fprq2 Times New Roman (Arabic);}{\f179\froman\fcharset186\fprq2 Times New Roman Baltic;} - -{\f180\froman\fcharset163\fprq2 Times New Roman (Vietnamese);}{\f554\fswiss\fcharset0\fprq2 Verdana;}{\f552\fswiss\fcharset238\fprq2 Verdana CE;}{\f555\fswiss\fcharset161\fprq2 Verdana Greek;}{\f556\fswiss\fcharset162\fprq2 Verdana Tur;} - -{\f559\fswiss\fcharset186\fprq2 Verdana Baltic;}{\f560\fswiss\fcharset163\fprq2 Verdana (Vietnamese);}}{\colortbl;\red0\green0\blue0;\red0\green0\blue255;\red0\green255\blue255;\red0\green255\blue0;\red255\green0\blue255;\red255\green0\blue0; - -\red255\green255\blue0;\red255\green255\blue255;\red0\green0\blue128;\red0\green128\blue128;\red0\green128\blue0;\red128\green0\blue128;\red128\green0\blue0;\red128\green128\blue0;\red128\green128\blue128;\red192\green192\blue192;}{\stylesheet{ - -\ql \li0\ri0\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \fs20\lang1033\langfe1033\cgrid\langnp1033\langfenp1033 \snext0 \styrsid8157421 Normal,DO NOT USE,n;}{ - -\s4\ql \li0\ri0\sb100\sa60\keepn\widctlpar\aspalpha\aspnum\faauto\outlinelevel3\adjustright\rin0\lin0\itap0 \b\f38\fs18\expnd-2\expndtw-10\lang1033\langfe1033\cgrid\langnp1033\langfenp1033 \sbasedon0 \snext0 \styrsid8157421 heading 4,H4;}{\*\cs10 - -\additive \ssemihidden Default Paragraph Font;}{\*\ts11\tsrowd\trftsWidthB3\trpaddl108\trpaddr108\trpaddfl3\trpaddft3\trpaddfb3\trpaddfr3\tscellwidthfts0\tsvertalt\tsbrdrt\tsbrdrl\tsbrdrb\tsbrdrr\tsbrdrdgl\tsbrdrdgr\tsbrdrh\tsbrdrv - -\ql \li0\ri0\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \fs20\lang1024\langfe1024\cgrid\langnp1024\langfenp1024 \snext11 \ssemihidden Normal Table;}{\s15\ql \li0\ri0\sa120\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 - -\f38\fs20\lang1033\langfe1033\langnp1033\langfenp1033 \sbasedon0 \snext15 \slink16 \styrsid8157421 Body Text;}{\*\cs16 \additive \f38\lang1033\langfe1033\cgrid0\langnp1033\langfenp1033 \sbasedon10 \slink15 \slocked \styrsid8157421 Body Text Char;}} - -{\*\latentstyles\lsdstimax156\lsdlockeddef0}{\*\rsidtbl \rsid8157421}\margl1417\margr1417\margt1417\margb1417 \deftab708\widowctrl\ftnbj\aenddoc\hyphhotz425\noxlattoyen\expshrtn\noultrlspc\dntblnsbdb\nospaceforul\formshade\horzdoc\dgmargin\dghspace180 - -\dgvspace180\dghorigin1701\dgvorigin1984\dghshow1\dgvshow1 - -\jexpand\pgbrdrhead\pgbrdrfoot\splytwnine\ftnlytwnine\htmautsp\nolnhtadjtbl\useltbaln\alntblind\lytcalctblwd\lyttblrtgr\lnbrkrule\nobrkwrptbl\snaptogridincell\allowfieldendsel\wrppunct\asianbrkrule\rsidroot8157421\newtblstyruls\nogrowautofit \fet0\sectd - -\linex0\headery708\footery708\colsx708\endnhere\sectdefaultcl\sftnbj {\*\pnseclvl1\pnucrm\pnstart1\pnindent720\pnhang {\pntxta .}}{\*\pnseclvl2\pnucltr\pnstart1\pnindent720\pnhang {\pntxta .}}{\*\pnseclvl3\pndec\pnstart1\pnindent720\pnhang {\pntxta .}} - -{\*\pnseclvl4\pnlcltr\pnstart1\pnindent720\pnhang {\pntxta )}}{\*\pnseclvl5\pndec\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}{\*\pnseclvl6\pnlcltr\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}{\*\pnseclvl7\pnlcrm\pnstart1\pnindent720\pnhang - -{\pntxtb (}{\pntxta )}}{\*\pnseclvl8\pnlcltr\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}{\*\pnseclvl9\pnlcrm\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}\pard\plain - -\s4\ql \li0\ri0\sb100\sa60\keepn\widctlpar\aspalpha\aspnum\faauto\outlinelevel3\adjustright\rin0\lin0\itap0\pararsid8157421 \b\f38\fs18\expnd-2\expndtw-10\lang1033\langfe1033\cgrid\langnp1033\langfenp1033 {\insrsid8157421 {\*\bkmkstart _Toc335399101} - -{\*\bkmkstart _Ref335401498}{\*\bkmkstart _Ref335402606}{\*\bkmkstart _Ref335402655}{\*\bkmkstart _Ref335402668}{\*\bkmkstart _Ref335402836}{\*\bkmkstart _Ref335403019}{\*\bkmkstart _Ref335403299}{\*\bkmkstart _Ref335403350}{\*\bkmkstart _Toc380819805} - -{\*\bkmkstart Special_Characters}Special Characters{\*\bkmkend _Toc335399101}{\*\bkmkend _Ref335401498}{\*\bkmkend _Ref335402606}{\*\bkmkend _Ref335402655}{\*\bkmkend _Ref335402668}{\*\bkmkend _Ref335402836}{\*\bkmkend _Ref335403019} - -{\*\bkmkend _Ref335403299}{\*\bkmkend _Ref335403350}{\*\bkmkend _Toc380819805}{\*\bkmkend Special_Characters} - -\par }\pard\plain \s15\ql \li0\ri0\sa120\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0\pararsid8157421 \f38\fs20\lang1033\langfe1033\langnp1033\langfenp1033 {\insrsid8157421 - -The RTF Specification includes control words for special characters (described as in the character-text syntax description). If - -a special-character control word is not recognized by the RTF reader, it is ignored and the text following it is considered plain text. The RTF Specification is flexible enough to allow new special characters to be added for interchange with other softwar - -e. - -\par The special RTF characters are listed in the following table. - -\par }} '! ! -!RTFConversionTest class methodsFor: 'text samples' stamp: 'jmv 4/11/2011 20:06'! - textSample1 - " - | text | - text _ RTFConversionTest textSample1. - text edit. - Clipboard default storeObject: text - " - ^ - (Text string: 'normal '), - (Text string: 'bold ' attribute: (TextEmphasis bold)), - (Text string: 'boldItalic ' attributes: {TextEmphasis new emphasisCode: AbstractFont boldCode + AbstractFont italicCode}), - (Text string: 'italic ' attributes: {TextEmphasis italic}), - (Text string: 'boldGreen ' attributes: {TextEmphasis bold. TextColor green}), - (Text string: 'red ' attributes: {TextColor red}), - (Text string: 'underlined ' attribute: (TextEmphasis underlined)), - (Text string: 'normal ' attributes: #())! ! -!RTFConversionTest class methodsFor: 'text samples' stamp: 'jmv 3/13/2012 16:57'! - textSample2 - " - | text | - text _ RTFConversionTest textSample2. - text edit. - Clipboard default storeObject: text - " - ^ - (Text string: 'This text has no tyle set', String newLineString), - (Text string: 'This is centered', String newLineString attribute: TextAlignment centered), - (Text string: 'This text has no tyle set', String newLineString), - (Text string: 'This is right', String newLineString attribute: TextAlignment rightFlush), - (Text string: 'This text has no tyle set', String newLineString), - (Text string: 'This is justified, and to see the effect, the paragraph needs to span over several lines, ', - 'as, otherwise, you won"t be able to see the effect', String newLineString attribute: TextAlignment justified), - (Text string: 'This text has no tyle set', String newLineString), - (Text string: 'This is left', String newLineString), - (Text string: 'This text has no tyle set', String newLineString), - (Text string: 'This is right', String newLineString attribute: TextAlignment rightFlush)! ! -!RTFConversionTest class methodsFor: 'text samples' stamp: 'jmv 4/11/2011 20:06'! - textSample3 - " - | text | - text _ RTFConversionTest textSample3. - text edit. - Clipboard default storeObject: text - " - ^ ( - (Text string: 'normal '), - (Text string: 'bold ' attributes: {(TextFontFamilyAndSize familyName: 'DejaVu' pointSize: 17). TextEmphasis bold}), - (Text string: 'italic ' attributes: {(TextFontFamilyAndSize familyName: 'DejaVu' pointSize: 6). TextEmphasis italic}), - (Text string: 'boldGreen ' attributes: {(TextFontFamilyAndSize familyName: 'DejaVu' pointSize: 12). TextEmphasis bold. TextColor green}), - (Text string: 'red ' attributes: {TextColor red}), - (Text string: 'underlined ' attribute: (TextEmphasis underlined)), - (Text string: 'normal ' attributes: #()) - )! ! -!RTFConversionTest class methodsFor: 'text samples' stamp: 'jmv 4/19/2014 11:11'! - textSample4 - " - | text | - text _ RTFConversionTest textSample4. - text edit. - Clipboard default storeObject: text - " - ^ ( - (Text string: 'normal '), - (Text string: 'bold ' attributes: { (TextFontFamilyAndSize familyName: 'DejaVu' pointSize: 17). TextEmphasis bold }), - (Text string: 'italic ' attributes: { (TextFontFamilyAndSize familyName: 'DejaVu' pointSize: 6). TextEmphasis italic }), - (Text string: 'boldGreen ' attributes: { (TextFontFamilyAndSize familyName: 'DejaVu' pointSize: 12). TextEmphasis bold. TextColor green }), - (Text string: 'boldGreen ' attributes: { (TextFontFamilyAndSize familyName: 'DejaVu' pointSize: 12). TextEmphasis bold. TextColor green }), - (Text string: 'boldGreen ' attributes: { (TextFontFamilyAndSize familyName: 'DejaVu' pointSize: 12). TextEmphasis bold. TextColor green }), - (Text string: 'red ' attributes: {TextColor red}), - (Text string: 'underlined ' attribute: (TextEmphasis underlined)), - (Text string: 'struckThrough ' attribute: (TextEmphasis struckThrough)), - (Text string: 'normal ' attributes: #()) - )! ! -!RTFConversionTest class methodsFor: 'text samples' stamp: 'jmv 12/7/2012 22:38'! - textSample5 - " - | text | - text _ RTFConversionTest textSample5. - text edit. - Clipboard default storeObject: text - " - ^'Hello', (Text withForm: (EllipseMorph new imageForm: 32)), 'world'! ! -!RTFConversionTest class methodsFor: 'text samples' stamp: 'jmv 11/22/2011 15:00'! - textSample6 - " - | text | - text _ RTFConversionTest textSample6. - text edit. - Clipboard default storeObject: text - " - ^'Tomá agüita, ñandú. Ñandú. -½´®¥¨øå߃©Ý²Þ¬­ç¦µ. -¼´®Á¨ØÅÍÎÏ©ÓÔÞҭǦÐÂ' asText! ! -!RTFTokenTest methodsFor: 'as yet unclassified' stamp: 'MR 5/24/2006 12:10'! - testCreateBlockClose - | token | - - token _ RTFToken newBlockClose. - self - assert: (token type = #blockClose); - assert: (token string = nil); - assert: (token word = nil); - assert: (token arg = nil). -! ! -!RTFTokenTest methodsFor: 'as yet unclassified' stamp: 'MR 5/24/2006 12:10'! - testCreateBlockOpen - | token | - - token _ RTFToken newBlockOpen. - self - assert: (token type = #blockOpen); - assert: (token string = nil); - assert: (token word = nil); - assert: (token arg = nil). -! ! -!RTFTokenTest methodsFor: 'as yet unclassified' stamp: 'MR 5/24/2006 12:11'! - testCreateKeyword - | token | - - token _ RTFToken newKeyword: 'abcd'. - self - assert: (token type = #keyword); - assert: (token string = nil); - assert: (token word = 'abcd'); - assert: (token arg = 0). - - token _ RTFToken newKeyword: 'abcd' withArg: 10. - self - assert: (token type = #keyword); - assert: (token string = nil); - assert: (token word = 'abcd'); - assert: (token arg = 10). -! ! -!RTFTokenTest methodsFor: 'as yet unclassified' stamp: 'MR 5/24/2006 12:11'! - testCreateString - | token | - - token _ RTFToken newString: 'abcd'. - self - assert: (token type = #string); - assert: (token string = 'abcd'); - assert: (token word = nil); - assert: (token arg = nil). - -! ! -!RTFTokenizerTest methodsFor: 'as yet unclassified' stamp: 'MR 5/25/2006 18:44'! - testMacGetToken - | string tokenizer token | - - "string is an empty rtf generated by word 2003" - string _ '{\rtf1\mac\ansicpg10000\cocoartf824\cocoasubrtf350 -{\fonttbl} -{\colortbl;\red255\green255\blue255;} -\paperw11900\paperh16840\margl1440\margr1440\vieww9000\viewh8400\viewkind0 -}'. - - tokenizer _ RTFTokenizer newFromString: string. - - "start parsing check" - self assert: tokenizer getToken isBlockOpen. - token _ tokenizer getToken. - self assert: (token word = 'rtf'); - assert: (token arg = 1). - token _ tokenizer getToken. - self assert: (token word = 'mac'). - token _ tokenizer getToken. - self assert: (token word = 'ansicpg'); - assert: (token arg = 10000). - token _ tokenizer getToken. - self assert: (token word = 'cocoartf'); - assert: (token arg = 824). - token _ tokenizer getToken. - self assert: (token word = 'cocoasubrtf'); - assert: (token arg = 350). - self assert: tokenizer getToken isBlockOpen. - token _ tokenizer getToken. - self assert: (token word = 'fonttbl'). - self assert: tokenizer getToken isBlockClose. - self assert: tokenizer getToken isBlockOpen. - token _ tokenizer getToken. - self assert: (token word = 'colortbl'). - token _ tokenizer getToken. - self assert: (token string = ';'). - token _ tokenizer getToken. - self assert: (token word = 'red'); - assert: (token arg = 255). - token _ tokenizer getToken. - self assert: (token word = 'green'); - assert: (token arg = 255). - token _ tokenizer getToken. - self assert: (token word = 'blue'); - assert: (token arg = 255). - token _ tokenizer getToken. - self assert: (token string = ';'). - self assert: tokenizer getToken isBlockClose. - token _ tokenizer getToken. - self assert: (token word = 'paperw'); - assert: (token arg = 11900). - token _ tokenizer getToken. - self assert: (token word = 'paperh'); - assert: (token arg = 16840). - token _ tokenizer getToken. - self assert: (token word = 'margl'); - assert: (token arg = 1440). - token _ tokenizer getToken. - self assert: (token word = 'margr'); - assert: (token arg = 1440). - token _ tokenizer getToken. - self assert: (token word = 'vieww'); - assert: (token arg = 9000). - token _ tokenizer getToken. - self assert: (token word = 'viewh'); - assert: (token arg = 8400). - token _ tokenizer getToken. - self assert: (token word = 'viewkind'); - assert: (token arg = 0). - self assert: tokenizer getToken isBlockClose. - self deny: tokenizer moreTokens. -! ! -!RTFTokenizerTest methodsFor: 'as yet unclassified' stamp: 'MR 5/25/2006 18:38'! - testMacLookAhead - | string tokenizer | - - "string is an empty rtf generated by word 2003" - string _ '{\rtf1\mac\ansicpg10000\cocoartf824\cocoasubrtf350 -{\fonttbl} -{\colortbl;\red255\green255\blue255;} -\paperw11900\paperh16840\margl1440\margr1440\vieww9000\viewh8400\viewkind0 -}'. - - tokenizer _ RTFTokenizer newFromString: string. - - self - assert: ((tokenizer lookAhead: 0) = nil); - assert: (tokenizer lookAhead: 1) isBlockOpen; - assert: ((tokenizer lookAhead: 2) word = 'rtf'); - assert: ((tokenizer lookAhead: 2) arg = 1); - assert: ((tokenizer lookAhead: 3) word = 'mac'); - assert: (tokenizer moreTokens). - -! ! -!RTFTokenizerTest methodsFor: 'as yet unclassified' stamp: 'MR 5/25/2006 18:45'! - testWinGetToken - | string tokenizer token | - - "string is an empty rtf generated by word 2003" - string _ '{\rtf1\ansi\ansicpg1252\uc1\deff0\stshfdbch0\stshfloch0\stshfhich0\stshfbi0\deflang1033\deflangfe1033{\fonttbl{\f0\froman\fcharset0\fprq2{\*\panose 02020603050405020304}Times New Roman;}{\f37\froman\fcharset238\fprq2 Times New Roman CE;} -{\f38\froman\fcharset204\fprq2 Times New Roman Cyr;}{\f40\froman\fcharset161\fprq2 Times New Roman Greek;}{\f41\froman\fcharset162\fprq2 Times New Roman Tur;}{\f42\froman\fcharset177\fprq2 Times New Roman (Hebrew);} -{\f43\froman\fcharset178\fprq2 Times New Roman (Arabic);}{\f44\froman\fcharset186\fprq2 Times New Roman Baltic;}{\f45\froman\fcharset163\fprq2 Times New Roman (Vietnamese);}}{\colortbl;\red0\green0\blue0;\red0\green0\blue255;\red0\green255\blue255; -\red0\green255\blue0;\red255\green0\blue255;\red255\green0\blue0;\red255\green255\blue0;\red255\green255\blue255;\red0\green0\blue128;\red0\green128\blue128;\red0\green128\blue0;\red128\green0\blue128;\red128\green0\blue0;\red128\green128\blue0; -\red128\green128\blue128;\red192\green192\blue192;}{\stylesheet{\ql \li0\ri0\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \fs24\lang1033\langfe1033\cgrid\langnp1033\langfenp1033 \snext0 Normal;}{\*\cs10 \additive \ssemihidden -Default Paragraph Font;}{\*\ts11\tsrowd\trftsWidthB3\trpaddl108\trpaddr108\trpaddfl3\trpaddft3\trpaddfb3\trpaddfr3\trcbpat1\trcfpat1\tscellwidthfts0\tsvertalt\tsbrdrt\tsbrdrl\tsbrdrb\tsbrdrr\tsbrdrdgl\tsbrdrdgr\tsbrdrh\tsbrdrv -\ql \li0\ri0\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \fs20\lang1024\langfe1024\cgrid\langnp1024\langfenp1024 \snext11 \ssemihidden Normal Table;}}{\*\latentstyles\lsdstimax156\lsdlockeddef0}{\*\rsidtbl \rsid1642803}{\*\generator Micro -soft Word 11.0.6568;}{\info{\author Compay Sedungo}{\operator Compay Sedungo}{\creatim\yr2006\mo5\dy24\hr13\min40}{\revtim\yr2006\mo5\dy24\hr13\min40}{\version1}{\edmins0}{\nofpages1}{\nofwords0}{\nofchars0}{\*\company WAY AHEAD}{\nofcharsws0} -{\vern24579}}\widowctrl\ftnbj\aenddoc\noxlattoyen\expshrtn\noultrlspc\dntblnsbdb\nospaceforul\formshade\horzdoc\dgmargin\dghspace180\dgvspace180\dghorigin1800\dgvorigin1440\dghshow1\dgvshow1 -\jexpand\viewkind1\viewscale75\viewzk1\pgbrdrhead\pgbrdrfoot\splytwnine\ftnlytwnine\htmautsp\nolnhtadjtbl\useltbaln\alntblind\lytcalctblwd\lyttblrtgr\lnbrkrule\nobrkwrptbl\snaptogridincell\allowfieldendsel -\wrppunct\asianbrkrule\rsidroot1642803\newtblstyruls\nogrowautofit \fet0\sectd \linex0\endnhere\sectlinegrid360\sectdefaultcl\sftnbj {\*\pnseclvl1\pnucrm\pnstart1\pnindent720\pnhang {\pntxta .}}{\*\pnseclvl2\pnucltr\pnstart1\pnindent720\pnhang -{\pntxta .}}{\*\pnseclvl3\pndec\pnstart1\pnindent720\pnhang {\pntxta .}}{\*\pnseclvl4\pnlcltr\pnstart1\pnindent720\pnhang {\pntxta )}}{\*\pnseclvl5\pndec\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}{\*\pnseclvl6\pnlcltr\pnstart1\pnindent720\pnhang -{\pntxtb (}{\pntxta )}}{\*\pnseclvl7\pnlcrm\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}{\*\pnseclvl8\pnlcltr\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}{\*\pnseclvl9\pnlcrm\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}\pard\plain -\ql \li0\ri0\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \fs24\lang1033\langfe1033\cgrid\langnp1033\langfenp1033 {\insrsid1642803 -\par }}'. - - tokenizer _ RTFTokenizer newFromString: string. - - "start parsing check" - self assert: tokenizer getToken isBlockOpen. - token _ tokenizer getToken. - self assert: (token word = 'rtf'); - assert: (token arg = 1). - token _ tokenizer getToken. - self assert: (token word = 'ansi'). - 1 to: 9 do: [:i | tokenizer getToken]. - self assert: tokenizer getToken isBlockOpen. - 1 to: 7 do: [:i | tokenizer getToken]. - token _ tokenizer getToken. - self assert: (token word = '*'). - tokenizer getToken. - token _ tokenizer getToken. - self assert: (token string = '02020603050405020304'). - token _ tokenizer getToken. - self assert: token isBlockClose. - token _ tokenizer getToken. - self assert: (token string = 'Times New Roman;'). - token _ tokenizer getToken. - self assert: token isBlockClose. - token _ tokenizer getToken. - self assert: token isBlockOpen. - - "end parsing check" - 1 to: 464 do: [:i | tokenizer getToken]. - token _ tokenizer getToken. - self assert: (token word = 'par'). - token _ tokenizer getToken. - self assert: token isBlockClose. - token _ tokenizer getToken. - self assert: token isBlockClose. - self deny: tokenizer moreTokens. - -! ! -!RTFTokenizerTest methodsFor: 'as yet unclassified' stamp: 'MR 5/24/2006 14:50'! - testWinLookAhead - | string tokenizer | - - "string is an empty rtf generated by word 2003" - string _ '{\rtf1\ansi\ansicpg1252\uc1\deff0\stshfdbch0\stshfloch0\stshfhich0\stshfbi0\deflang1033\deflangfe1033{\fonttbl{\f0\froman\fcharset0\fprq2{\*\panose 02020603050405020304}Times New Roman;}{\f37\froman\fcharset238\fprq2 Times New Roman CE;} -{\f38\froman\fcharset204\fprq2 Times New Roman Cyr;}{\f40\froman\fcharset161\fprq2 Times New Roman Greek;}{\f41\froman\fcharset162\fprq2 Times New Roman Tur;}{\f42\froman\fcharset177\fprq2 Times New Roman (Hebrew);} -{\f43\froman\fcharset178\fprq2 Times New Roman (Arabic);}{\f44\froman\fcharset186\fprq2 Times New Roman Baltic;}{\f45\froman\fcharset163\fprq2 Times New Roman (Vietnamese);}}{\colortbl;\red0\green0\blue0;\red0\green0\blue255;\red0\green255\blue255; -\red0\green255\blue0;\red255\green0\blue255;\red255\green0\blue0;\red255\green255\blue0;\red255\green255\blue255;\red0\green0\blue128;\red0\green128\blue128;\red0\green128\blue0;\red128\green0\blue128;\red128\green0\blue0;\red128\green128\blue0; -\red128\green128\blue128;\red192\green192\blue192;}{\stylesheet{\ql \li0\ri0\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \fs24\lang1033\langfe1033\cgrid\langnp1033\langfenp1033 \snext0 Normal;}{\*\cs10 \additive \ssemihidden -Default Paragraph Font;}{\*\ts11\tsrowd\trftsWidthB3\trpaddl108\trpaddr108\trpaddfl3\trpaddft3\trpaddfb3\trpaddfr3\trcbpat1\trcfpat1\tscellwidthfts0\tsvertalt\tsbrdrt\tsbrdrl\tsbrdrb\tsbrdrr\tsbrdrdgl\tsbrdrdgr\tsbrdrh\tsbrdrv -\ql \li0\ri0\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \fs20\lang1024\langfe1024\cgrid\langnp1024\langfenp1024 \snext11 \ssemihidden Normal Table;}}{\*\latentstyles\lsdstimax156\lsdlockeddef0}{\*\rsidtbl \rsid1642803}{\*\generator Micro -soft Word 11.0.6568;}{\info{\author Compay Sedungo}{\operator Compay Sedungo}{\creatim\yr2006\mo5\dy24\hr13\min40}{\revtim\yr2006\mo5\dy24\hr13\min40}{\version1}{\edmins0}{\nofpages1}{\nofwords0}{\nofchars0}{\*\company WAY AHEAD}{\nofcharsws0} -{\vern24579}}\widowctrl\ftnbj\aenddoc\noxlattoyen\expshrtn\noultrlspc\dntblnsbdb\nospaceforul\formshade\horzdoc\dgmargin\dghspace180\dgvspace180\dghorigin1800\dgvorigin1440\dghshow1\dgvshow1 -\jexpand\viewkind1\viewscale75\viewzk1\pgbrdrhead\pgbrdrfoot\splytwnine\ftnlytwnine\htmautsp\nolnhtadjtbl\useltbaln\alntblind\lytcalctblwd\lyttblrtgr\lnbrkrule\nobrkwrptbl\snaptogridincell\allowfieldendsel -\wrppunct\asianbrkrule\rsidroot1642803\newtblstyruls\nogrowautofit \fet0\sectd \linex0\endnhere\sectlinegrid360\sectdefaultcl\sftnbj {\*\pnseclvl1\pnucrm\pnstart1\pnindent720\pnhang {\pntxta .}}{\*\pnseclvl2\pnucltr\pnstart1\pnindent720\pnhang -{\pntxta .}}{\*\pnseclvl3\pndec\pnstart1\pnindent720\pnhang {\pntxta .}}{\*\pnseclvl4\pnlcltr\pnstart1\pnindent720\pnhang {\pntxta )}}{\*\pnseclvl5\pndec\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}{\*\pnseclvl6\pnlcltr\pnstart1\pnindent720\pnhang -{\pntxtb (}{\pntxta )}}{\*\pnseclvl7\pnlcrm\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}{\*\pnseclvl8\pnlcltr\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}{\*\pnseclvl9\pnlcrm\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}\pard\plain -\ql \li0\ri0\widctlpar\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \fs24\lang1033\langfe1033\cgrid\langnp1033\langfenp1033 {\insrsid1642803 -\par }}'. - - tokenizer _ RTFTokenizer newFromString: string. - - self - assert: ((tokenizer lookAhead: 0) = nil); - assert: (tokenizer lookAhead: 1) isBlockOpen; - assert: ((tokenizer lookAhead: 2) word = 'rtf'); - assert: ((tokenizer lookAhead: 2) arg = 1); - assert: ((tokenizer lookAhead: 3) word = 'ansi'); - assert: (tokenizer moreTokens). - -! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-StyledTextEditor/RTFTests.pck.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3153] on 25 August 2017 at 12:08:33 pm'! - -'Description Please enter a description for this package.'! - -TextModel subclass: #StyledTextModel - instanceVariableNames: 'styleSet fileName' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText'! - -!classDefinition: #StyledTextModel category: #StyledText! -TextModel subclass: #StyledTextModel - instanceVariableNames: 'styleSet fileName' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText'! - -StyledTextModel class - instanceVariableNames: ''! - -!classDefinition: 'StyledTextModel class' category: #StyledText! -StyledTextModel class - instanceVariableNames: ''! - -ActiveModel subclass: #StyleSet - instanceVariableNames: 'paragraphStyles characterStyles volatileParaStyles volatileCharStyles' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText'! - -!classDefinition: #StyleSet category: #StyledText! -ActiveModel subclass: #StyleSet - instanceVariableNames: 'paragraphStyles characterStyles volatileParaStyles volatileCharStyles' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText'! - -StyleSet class - instanceVariableNames: ''! - -!classDefinition: 'StyleSet class' category: #StyledText! -StyleSet class - instanceVariableNames: ''! - -TextEditor subclass: #StyledTextEditor - instanceVariableNames: 'cmdShortcuts cmdActions' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText'! - -!classDefinition: #StyledTextEditor category: #StyledText! -TextEditor subclass: #StyledTextEditor - instanceVariableNames: 'cmdShortcuts cmdActions' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText'! - -StyledTextEditor class - instanceVariableNames: ''! - -!classDefinition: 'StyledTextEditor class' category: #StyledText! -StyledTextEditor class - instanceVariableNames: ''! - -TextAttribute subclass: #CharacterStyleReference - instanceVariableNames: 'characterStyle' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText'! - -!classDefinition: #CharacterStyleReference category: #StyledText! -TextAttribute subclass: #CharacterStyleReference - instanceVariableNames: 'characterStyle' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText'! - -CharacterStyleReference class - instanceVariableNames: ''! - -!classDefinition: 'CharacterStyleReference class' category: #StyledText! -CharacterStyleReference class - instanceVariableNames: ''! - -TextAttribute subclass: #ParagraphStyleReference - instanceVariableNames: 'paragraphStyle' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText'! - -!classDefinition: #ParagraphStyleReference category: #StyledText! -TextAttribute subclass: #ParagraphStyleReference - instanceVariableNames: 'paragraphStyle' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText'! - -ParagraphStyleReference class - instanceVariableNames: ''! - -!classDefinition: 'ParagraphStyleReference class' category: #StyledText! -ParagraphStyleReference class - instanceVariableNames: ''! - -DraggeableButtonMorph subclass: #FancyDraggeableButtonMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText-Morphic-Windows'! - -!classDefinition: #FancyDraggeableButtonMorph category: #'StyledText-Morphic-Windows'! -DraggeableButtonMorph subclass: #FancyDraggeableButtonMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText-Morphic-Windows'! - -FancyDraggeableButtonMorph class - instanceVariableNames: ''! - -!classDefinition: 'FancyDraggeableButtonMorph class' category: #'StyledText-Morphic-Windows'! -FancyDraggeableButtonMorph class - instanceVariableNames: ''! - -PluggableButtonMorph subclass: #FancyButtonMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText-Morphic-Windows'! - -!classDefinition: #FancyButtonMorph category: #'StyledText-Morphic-Windows'! -PluggableButtonMorph subclass: #FancyButtonMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText-Morphic-Windows'! - -FancyButtonMorph class - instanceVariableNames: ''! - -!classDefinition: 'FancyButtonMorph class' category: #'StyledText-Morphic-Windows'! -FancyButtonMorph class - instanceVariableNames: ''! - -PluggableListMorph subclass: #PluggableActOnReturnKeyListMorph - instanceVariableNames: 'currentIndex' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText-Morphic-Windows'! - -!classDefinition: #PluggableActOnReturnKeyListMorph category: #'StyledText-Morphic-Windows'! -PluggableListMorph subclass: #PluggableActOnReturnKeyListMorph - instanceVariableNames: 'currentIndex' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText-Morphic-Windows'! - -PluggableActOnReturnKeyListMorph class - instanceVariableNames: ''! - -!classDefinition: 'PluggableActOnReturnKeyListMorph class' category: #'StyledText-Morphic-Windows'! -PluggableActOnReturnKeyListMorph class - instanceVariableNames: ''! - -TextModelMorph subclass: #PluggableStyledTextMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText-Morphic-Windows'! - -!classDefinition: #PluggableStyledTextMorph category: #'StyledText-Morphic-Windows'! -TextModelMorph subclass: #PluggableStyledTextMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText-Morphic-Windows'! - -PluggableStyledTextMorph class - instanceVariableNames: ''! - -!classDefinition: 'PluggableStyledTextMorph class' category: #'StyledText-Morphic-Windows'! -PluggableStyledTextMorph class - instanceVariableNames: ''! - -ScrollBar subclass: #FancyScrollBar - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText-Morphic-Windows'! - -!classDefinition: #FancyScrollBar category: #'StyledText-Morphic-Windows'! -ScrollBar subclass: #FancyScrollBar - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText-Morphic-Windows'! - -FancyScrollBar class - instanceVariableNames: ''! - -!classDefinition: 'FancyScrollBar class' category: #'StyledText-Morphic-Windows'! -FancyScrollBar class - instanceVariableNames: ''! - -PluggableMorph subclass: #PluggableDropDownListMorph - instanceVariableNames: 'listMorph getListSelector getIndexSelector setIndexSelector label downButton' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText-Morphic-Windows'! - -!classDefinition: #PluggableDropDownListMorph category: #'StyledText-Morphic-Windows'! -PluggableMorph subclass: #PluggableDropDownListMorph - instanceVariableNames: 'listMorph getListSelector getIndexSelector setIndexSelector label downButton' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText-Morphic-Windows'! - -PluggableDropDownListMorph class - instanceVariableNames: ''! - -!classDefinition: 'PluggableDropDownListMorph class' category: #'StyledText-Morphic-Windows'! -PluggableDropDownListMorph class - instanceVariableNames: ''! - -PluggableDropDownListMorph subclass: #PluggableFilteringDropDownListMorph - instanceVariableNames: 'editorMorph' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText-Morphic-Windows'! - -!classDefinition: #PluggableFilteringDropDownListMorph category: #'StyledText-Morphic-Windows'! -PluggableDropDownListMorph subclass: #PluggableFilteringDropDownListMorph - instanceVariableNames: 'editorMorph' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText-Morphic-Windows'! - -PluggableFilteringDropDownListMorph class - instanceVariableNames: ''! - -!classDefinition: 'PluggableFilteringDropDownListMorph class' category: #'StyledText-Morphic-Windows'! -PluggableFilteringDropDownListMorph class - instanceVariableNames: ''! - -LayoutMorph subclass: #ToolbarMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText-Morphic-Windows'! - -!classDefinition: #ToolbarMorph category: #'StyledText-Morphic-Windows'! -LayoutMorph subclass: #ToolbarMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText-Morphic-Windows'! - -ToolbarMorph class - instanceVariableNames: ''! - -!classDefinition: 'ToolbarMorph class' category: #'StyledText-Morphic-Windows'! -ToolbarMorph class - instanceVariableNames: ''! - -LayoutMorph subclass: #STEMainMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText-Morphic'! - -!classDefinition: #STEMainMorph category: #'StyledText-Morphic'! -LayoutMorph subclass: #STEMainMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText-Morphic'! - -STEMainMorph class - instanceVariableNames: ''! - -!classDefinition: 'STEMainMorph class' category: #'StyledText-Morphic'! -STEMainMorph class - instanceVariableNames: ''! - -OneLineEditorMorph subclass: #FilteringDDLEditorMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText-Morphic-Windows'! - -!classDefinition: #FilteringDDLEditorMorph category: #'StyledText-Morphic-Windows'! -OneLineEditorMorph subclass: #FilteringDDLEditorMorph - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText-Morphic-Windows'! - -FilteringDDLEditorMorph class - instanceVariableNames: ''! - -!classDefinition: 'FilteringDDLEditorMorph class' category: #'StyledText-Morphic-Windows'! -FilteringDDLEditorMorph class - instanceVariableNames: ''! - -Theme subclass: #STETheme - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText-Themes'! - -!classDefinition: #STETheme category: #'StyledText-Themes'! -Theme subclass: #STETheme - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText-Themes'! - -STETheme class - instanceVariableNames: ''! - -!classDefinition: 'STETheme class' category: #'StyledText-Themes'! -STETheme class - instanceVariableNames: ''! - -TestCase subclass: #StyledTextEditorTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText-Tests'! - -!classDefinition: #StyledTextEditorTest category: #'StyledText-Tests'! -TestCase subclass: #StyledTextEditorTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText-Tests'! - -StyledTextEditorTest class - instanceVariableNames: ''! - -!classDefinition: 'StyledTextEditorTest class' category: #'StyledText-Tests'! -StyledTextEditorTest class - instanceVariableNames: ''! - -TestCase subclass: #StyledTextModelTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText-Tests'! - -!classDefinition: #StyledTextModelTest category: #'StyledText-Tests'! -TestCase subclass: #StyledTextModelTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText-Tests'! - -StyledTextModelTest class - instanceVariableNames: ''! - -!classDefinition: 'StyledTextModelTest class' category: #'StyledText-Tests'! -StyledTextModelTest class - instanceVariableNames: ''! - -TestCase subclass: #StyledTextTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText-Tests'! - -!classDefinition: #StyledTextTest category: #'StyledText-Tests'! -TestCase subclass: #StyledTextTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText-Tests'! - -StyledTextTest class - instanceVariableNames: ''! - -!classDefinition: 'StyledTextTest class' category: #'StyledText-Tests'! -StyledTextTest class - instanceVariableNames: ''! - -AutoCompleter subclass: #STECompleter - instanceVariableNames: 'words' - classVariableNames: 'EnglishDict' - poolDictionaries: '' - category: 'StyledText-Completion'! - -!classDefinition: #STECompleter category: #'StyledText-Completion'! -AutoCompleter subclass: #STECompleter - instanceVariableNames: 'words' - classVariableNames: 'EnglishDict' - poolDictionaries: '' - category: 'StyledText-Completion'! - -STECompleter class - instanceVariableNames: ''! - -!classDefinition: 'STECompleter class' category: #'StyledText-Completion'! -STECompleter class - instanceVariableNames: ''! - -RTFTextBuilder subclass: #RTFStyledTextBuilder - instanceVariableNames: 'paragraphStyleInUse characterStyleInUse' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText-RTF-importing'! - -!classDefinition: #RTFStyledTextBuilder category: #'StyledText-RTF-importing'! -RTFTextBuilder subclass: #RTFStyledTextBuilder - instanceVariableNames: 'paragraphStyleInUse characterStyleInUse' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText-RTF-importing'! - -RTFStyledTextBuilder class - instanceVariableNames: ''! - -!classDefinition: 'RTFStyledTextBuilder class' category: #'StyledText-RTF-importing'! -RTFStyledTextBuilder class - instanceVariableNames: ''! - -Object subclass: #CharacterStyle - instanceVariableNames: 'name familyName pointSize emphasis color' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText'! - -!classDefinition: #CharacterStyle category: #StyledText! -Object subclass: #CharacterStyle - instanceVariableNames: 'name familyName pointSize emphasis color' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText'! - -CharacterStyle class - instanceVariableNames: ''! - -!classDefinition: 'CharacterStyle class' category: #StyledText! -CharacterStyle class - instanceVariableNames: ''! - -CharacterStyle subclass: #ParagraphStyle - instanceVariableNames: 'alignment tabsArray firstIndent restIndent rightIndent spaceBefore spaceAfter listBulletPattern doesShout' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText'! - -!classDefinition: #ParagraphStyle category: #StyledText! -CharacterStyle subclass: #ParagraphStyle - instanceVariableNames: 'alignment tabsArray firstIndent restIndent rightIndent spaceBefore spaceAfter listBulletPattern doesShout' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText'! - -ParagraphStyle class - instanceVariableNames: ''! - -!classDefinition: 'ParagraphStyle class' category: #StyledText! -ParagraphStyle class - instanceVariableNames: ''! - -Object subclass: #StyledTextBuilder - instanceVariableNames: 'styleDict text characterStyleStack textStream' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText'! - -!classDefinition: #StyledTextBuilder category: #StyledText! -Object subclass: #StyledTextBuilder - instanceVariableNames: 'styleDict text characterStyleStack textStream' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText'! - -StyledTextBuilder class - instanceVariableNames: ''! - -!classDefinition: 'StyledTextBuilder class' category: #StyledText! -StyledTextBuilder class - instanceVariableNames: ''! - -Object subclass: #SampleListModel - instanceVariableNames: 'sel' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText-Tests'! - -!classDefinition: #SampleListModel category: #'StyledText-Tests'! -Object subclass: #SampleListModel - instanceVariableNames: 'sel' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledText-Tests'! - -SampleListModel class - instanceVariableNames: ''! - -!classDefinition: 'SampleListModel class' category: #'StyledText-Tests'! -SampleListModel class - instanceVariableNames: ''! -!StyledTextModel commentStamp: 'jmv 10/16/2013 21:43' prior: 0! - A StyledText is a Text where every character has a ParagraphStyle. All the characters in a Paragraph (including the ending Character newLineCharacter) share the same ParagraphStyle.! -!StyleSet commentStamp: '' prior: 0! - My instances know some styles (and the keyboard shortcuts to apply them).! -!CharacterStyleReference commentStamp: '' prior: 0! - A CharacterStyleReference encodes a CharacterStyle change applicable over a given range of text. Instances of CharacterStyleReference (and other TextAttributes) are usually volatile, and they are usually referenced only from the Text.! -!ParagraphStyleReference commentStamp: 'jmv 3/13/2012 11:45' prior: 0! - A ParagraphStyleReference encodes a ParagraphStyle change applicable over a given range of text. Instances of CharacterStyleReference (and other TextAttributes) are usually volatile, and they are usually referenced only from the Text. - -Warning: TextAlignment and ParagraphStyleReference should always be applied to whole 'paragraphs' in the text. See #isParagraphAttribute - -( -(Text string: 'THIS CLASS HAS NO COMMENT!!', String cStringr attribute: TextColor green), -(Text string: ('Heading of Level 1', String crString) attribute: (ParagraphStyleReference named: 'Heading 1')), -(Text string: ('Heading of Level 2', String crString) attribute: (ParagraphStyleReference named: 'Heading 2')), -(Text string: ('Heading of Level 3', String crString) attribute: (ParagraphStyleReference named: 'Heading 3')), -(Text string: ('This is some emphasized text. ', String crString) attribute: (ParagraphStyleReference named: 'Emphasized')), -(Text string: ('This is some normal text. ', String crString) attribute: (ParagraphStyleReference named: 'Normal')), -(Text string: ('This is some normal text. ', String crString) attribute: (ParagraphStyleReference named: 'Normal')), -(Text string: 'This text has no tyle set') -) edit - -This example shows how attributes such as ParagraphStyleReference, that must be applied to whole paragraphs, are indeed done so when concatenating Texts -( -(Text string: 'This text has no style set', String crString), -(Text string: 'This is Heading 1', String crString attribute: (ParagraphStyleReference named: 'Heading 1')), -(Text string: 'no tyle set'), -(Text string: 'This is Heading 1', String crString attribute: (ParagraphStyleReference named: 'Heading 1')), -(Text string: 'no style set'), -(Text string: 'This is Heading 2', String crString attribute: (ParagraphStyleReference named: 'Heading 2')), -(Text string: 'This text has no tsyle set', String cStringr) -) edit! -!FancyDraggeableButtonMorph commentStamp: '' prior: 0! - for STE scrollbars! -!FancyButtonMorph commentStamp: '' prior: 0! - For STE drop down list and fancy scrollbars! -!PluggableStyledTextMorph commentStamp: '' prior: 0! - To be used with StyledTextEditors! -!FancyScrollBar commentStamp: '' prior: 0! - A Fancy Scrollbar for STE.! -!PluggableDropDownListMorph commentStamp: '' prior: 0! - A widget that shows the current value, and can open the full list for user selection.! -!PluggableFilteringDropDownListMorph commentStamp: '' prior: 0! - A DropDownList that allows typing in, to filter visible items in the list.! -!RTFStyledTextBuilder commentStamp: '' prior: 0! - Builds styled text! -!CharacterStyle commentStamp: '' prior: 0! - A CharacterStyle comprises a font and color, and can be applied to any part of a Text via a CharacterStyleReference. - -Instances are usually shared. They are not modified often, and any change will affect the style's many users. -They should not be copied, but new instances might be created.! -!ParagraphStyle commentStamp: '' prior: 0! - A ParagraphStyle comprises the formatting information for composing and displaying a unit (usually a paragraph) of text. -ParagraphStyle instances are shared. They are not modified often, and any change will affect the style's many users. -They should not be copied, but new instances might be created. - -Each of my instances consists of... - name If available for general use in the AvailableParagraphStyles dictionary, it is also the key for access - font The default font to use - alignment An integer; text alignment, see ParagraphStyle alignment: - tabsArray An array of integers giving tab offsets in pixels - color Color of the text - firstIndent Left indent (margin) of the first line of a paragraph - restIndent Left indent (margin) for the rest of the paragraph - rightIndent Right indent (margin) of the paragraph - paragraphSpacingBefore Additional vertical spacing to add before a paragraph - paragraphSpacingAfter Additional verital spacing to add after a paragraph - listBulletPattern String pattern for bulleted lists. See the comment at #privateListBulletPattern: -! -!StyledTextBuilder commentStamp: 'jmv 1/25/2011 14:28' prior: 0! - A StyledTextBuilder helps building StyledText instances (i.e. Texts whose only attributes are ParagraphStyles and CharacterStyles) in a convenient way with Smalltalk syntax. See class methods, class references and senders for examples. - -Advantages of this approach: -- Text creation code is easy to read and write -- No need to explicitly reference StyledTextBuilder -- No need to add foreign protocol to String, Text or Array -- Supports nesting of character styles -- Takes advantage of Shout to make it easier to see the text and the format! -!SampleListModel commentStamp: 'jmv 9/17/2009 09:46' prior: 0! - (PluggableDropDownListMorph - model: SampleListModel new - listGetter: #list - indexGetter: #sel - indexSetter: #sel:) openInWorld! -!Text methodsFor: '*styledText' stamp: 'jmv 4/11/2011 19:37'! - asNonStyledText - self usesAnyStyles ifFalse: [ ^self ]. - ^self copy beNonStyledText! ! -!Text methodsFor: '*styledText' stamp: 'jmv 8/10/2011 15:48'! - asStyledTextWith: aStyleSet - "Next line is disabled, because even if already styled, we need to compatibilize styles with aStyleSet" -" self isStyledText ifTrue: [ ^self ]." - ^self copy beStyledTextWith: aStyleSet! ! -!Text methodsFor: '*styledText' stamp: 'jmv 4/19/2014 11:07'! - beNonStyledText - "Modify the receiver so that it doesn't include any ParagraphStyle or CharacterStyle. - Turn them into TextFontFamilyAndSize, TextEmphasis, TextColor, and TextAlignment as appropriate. - Useful as an option when copying StyledText to the clipboard, as not all RTF editor might support the notion of style." - - runs mapValues: [ :attributes | - Array streamContents: [ :strm | - self withAttributeValues: attributes do: [ - :familyName :pointSize :emphasis :color :alignment :characterStyle :paragraphStyle | - familyName ifNotNil: [ - strm nextPut: (TextFontFamilyAndSize familyName: familyName pointSize: pointSize) ]. - emphasis = 0 ifFalse: [ - strm nextPut: (TextEmphasis new emphasisCode: emphasis) ]. - color ifNotNil: [ - strm nextPut: (TextColor color: color) ]. - alignment = 0 ifFalse: [ - strm nextPut: (TextAlignment new alignment: alignment) ]]. - attributes do: [ :attribute | - attribute isForFormatting ifFalse: [ - strm nextPut: attribute ]] - ] - ]. - runs coalesce! ! -!Text methodsFor: '*styledText' stamp: 'jmv 4/19/2014 11:11'! - beStyledTextWith: aStyleSet - "Modify the receiver so that it doesn't include any TextFontFamilyAndSize, TextEmphasis, TextColor, TextAlignment. Turn all of them into ParagraphStyleReference or CharacterStyleReference as appropriate. - Keep any TextAttribute that doesn't fit into the Styles: TextAction (and subclasses) and TextAnchor. - Create new ParagraphStyle and CharacterStyle as needed." - - "1) break runs so that each Cr char is at the end of a run" - | s prevParagraphEnd paragraphEnd newRunSegments thisParagraphStyle thisCharStyle newRunArray nonFormattingAttributes originalParagraphStyle | - prevParagraphEnd _ 0. - s _ self size. - s = 0 ifTrue: [ ^self ]. - - newRunSegments _ OrderedCollection new. - [ prevParagraphEnd < s ] whileTrue: [ - paragraphEnd _ string indexOf: Character newLineCharacter startingAt: prevParagraphEnd+1 ifAbsent: [ s ]. - newRunSegments add: (runs copyFrom: prevParagraphEnd+1 to: paragraphEnd). - prevParagraphEnd _ paragraphEnd ]. - - "2) For each Cr, create a a Paragraph attribute for the current attributes at it" - - "3) For each run, take the Paragraph attribute. - a) If it ends with a Cr, it is that one. Just replace all the relevant attributes with the ParagraphAttribute. - b) If it doesn't end with a Cr, use the Paragraph attribute from the next run. Build a CharAttr. - Replace the relevant attributes with the ParaAtt + the CharAtt" - - newRunArray _ nil. - newRunSegments do: [ :runArray | - self - withAttributeValues: runArray last - do: [ :familyName :pointSize :emphasis :color :alignment :characterStyle :paragraphStyle | - originalParagraphStyle _ paragraphStyle. - originalParagraphStyle ifNil: [ - originalParagraphStyle _ familyName - ifNil: [ (aStyleSet defaultStyle) ] - ifNotNil: [ ParagraphStyle new - privateFamilyName: familyName pointSize: pointSize emphasis: emphasis color: color alignment: alignment ]]]. - - thisParagraphStyle _ aStyleSet equivalentOrSameNamePSTo: originalParagraphStyle orAddVolatile: 'Imported '. - "thisParagraphStyle _ aStyleSet equivalentPSTo: thisParagraphStyle orAddVolatile: 'Imported '." - - runArray mapValues: [ :attributes | - nonFormattingAttributes _ attributes reject: [ :attr | attr isForFormatting ]. - attributes = nonFormattingAttributes - ifTrue: [ { ParagraphStyleReference for: thisParagraphStyle }, nonFormattingAttributes ] "If only attribute is, for example, a TextAnchor (to a Form), then just add paragraph style" - ifFalse: [ - self withAttributeValues: attributes do: [ :familyName :pointSize :emphasis :color :alignment :characterStyle :paragraphStyle | - thisCharStyle _ characterStyle. - (thisCharStyle isNil and: [ familyName = originalParagraphStyle familyName and: [ pointSize = originalParagraphStyle pointSize and: [ - emphasis = originalParagraphStyle emphasis and: [ color = originalParagraphStyle color ]]]]) - ifTrue: [ { ParagraphStyleReference for: thisParagraphStyle }, nonFormattingAttributes ] - ifFalse: [ - thisCharStyle ifNil: [ - thisCharStyle _ CharacterStyle new - privateFamilyName: familyName pointSize: pointSize emphasis: emphasis color: color]. - - thisCharStyle _ aStyleSet equivalentOrSameNameCSTo: thisCharStyle orAddVolatile: 'Imported '. - "thisCharStyle _ aStyleSet equivalentCSTo: thisCharStyle orAddVolatile: 'Imported '." - - { ParagraphStyleReference for: thisParagraphStyle. - CharacterStyleReference for: thisCharStyle }, - nonFormattingAttributes ]]]]. - newRunArray _ newRunArray ifNil: [ runArray ] ifNotNil: [ newRunArray, runArray ]]. - self privateSetRuns: newRunArray. - runs coalesce! ! -!Text methodsFor: '*styledText' stamp: 'jmv 9/21/2011 11:00'! - commandForRemoveCharacterStylesIn: anInterval - "Remove any CharacterStyles in anInterval." - - | start stop new old attributesToRemove | - start _ anInterval first. - stop _ anInterval last. - - attributesToRemove _ Set new. - self attributesFrom: anInterval first to: anInterval last do: [ :attribute | - attribute class == CharacterStyleReference ifTrue: [ - attributesToRemove add: attribute ]]. - - old _ runs copyFrom: start to: stop. - new _ old copy mapValues: [ :attributes | - attributes copyWithoutAll: attributesToRemove]. - ^AttributesReplaceCommand - old: old - new: new - start: start - stop: stop! ! -!Text methodsFor: '*styledText' stamp: 'jmv 4/11/2011 22:08'! - isStyledText - runs do: [ :run | - (run anySatisfy: [ :attribute | attribute class = ParagraphStyleReference]) - ifFalse: [ ^false ]. - run do: [ :attribute | - (attribute isForFormatting and: [ attribute isStyle not ]) ifTrue: [ ^false ]]]. - ^true! ! -!Text methodsFor: '*styledText' stamp: 'jmv 12/29/2011 15:44'! - removeReferencesToCharacterStyle: oldCharacterStyle - self - removeAttributes: {(CharacterStyleReference for: oldCharacterStyle)} - from: 1 - to: self size! ! -!Text methodsFor: '*styledText' stamp: 'jmv 11/1/2011 11:30'! - replaceReferencesToStyle: oldParagraphOrCharacterStyle with: newParagraphOrCharacterStyle - "Both arguments must be of the same kind (either para or char style)" - runs runsAndValuesDo: [ :count :attributes | - attributes do: [ :att | - (att isStyle and: [ att style == oldParagraphOrCharacterStyle ]) - ifTrue: [ att style: newParagraphOrCharacterStyle ]]]! ! -!Text methodsFor: '*styledText' stamp: 'jmv 4/11/2011 22:04'! - usesAnyStyles - runs do: [ :run | - run do: [ :attribute | - attribute isStyle ifTrue: [ ^true ]]]. - ^false! ! -!Text methodsFor: '*styledText' stamp: 'jmv 4/11/2011 22:04'! - usesOnlyStyles - runs do: [ :run | - run do: [ :attribute | - (attribute isForFormatting and: [ attribute isStyle not ]) ifTrue: [ ^false ]]]. - ^true! ! -!Text class methodsFor: '*styledText' stamp: 'jmv 1/25/2011 16:15'! - buildWithStyles: aDictionary contents: aBlock - "Builds a StyledText, i.e. a Text whose only attributes are ParagraphStyles and CharacterStyles" - | builder | - builder _ StyledTextBuilder new styles: aDictionary. - aBlock value: builder. - ^builder text! ! -!TextAttribute methodsFor: '*styledText' stamp: 'jmv 11/1/2011 11:32'! - isStyle - ^false! ! -!SystemWindow class methodsFor: '*styledText' stamp: 'jmv 7/24/2014 10:26'! - editFancierStyledText: aTextModel label: labelString - | window textMorph | - textMorph _ PluggableStyledTextMorph withModel: aTextModel in: LayoutMorph newColumn. - window _ SystemWindow new model: aTextModel. - window setLabel: labelString. - window layoutMorph - addMorph: textMorph - proportionalHeight: 1. - window setProperty: #minimumExtent toValue: 660@300. - ^ window openInWorld! ! -!SystemWindow class methodsFor: '*styledText' stamp: 'jmv 5/24/2011 08:24'! - editStyledText: aTextModel label: labelString - | window | - window _ SystemWindow new model: aTextModel. - window setLabel: labelString. - window layoutMorph - addMorph: ((PluggableStyledTextMorph withModel: aTextModel) - wrapFlag: true) - proportionalHeight: 1. - ^ window openInWorld! ! -!StyledTextModel methodsFor: 'accessing' stamp: 'jmv 8/11/2011 11:27'! - actualContents: aTextOrString - "Merge styles appropriately. Warning: modifies the argument." - super actualContents: (aTextOrString ifNotNil: [ - aTextOrString - asText - beStyledTextWith: styleSet])! ! -!StyledTextModel methodsFor: 'user interface support' stamp: 'jmv 2/16/2016 16:29'! -autoCompleterClass - ^STECompleter! ! -!StyledTextModel methodsFor: 'accessing' stamp: 'jmv 8/11/2011 11:27'! - basicActualContents: aTextOrString - "Merge styles appropriately. Warning: modifies the argument." - super basicActualContents: (aTextOrString ifNotNil: [ - aTextOrString - asText - beStyledTextWith: styleSet])! ! -!StyledTextModel methodsFor: 'user interface support' stamp: 'jmv 2/16/2016 16:29'! - editorClass - ^StyledTextEditor! ! -!StyledTextModel methodsFor: 'accessing' stamp: 'KenD 4/1/2016 14:35'! - fileName - ^fileName! ! -!StyledTextModel methodsFor: 'accessing' stamp: 'jmv 4/30/2012 00:08'! - fileName: aString - fileName _ aString! ! -!StyledTextModel methodsFor: 'Shout Styling' stamp: 'jmv 11/3/2016 11:36:02'! - formatAndStyleWith: anSHTextStyler - - | toStyle | - self actualContents paragraphStyleChunksDo: [ :interval :paragraphStyle | - paragraphStyle ifNotNil: [ paragraphStyle doesShout ifTrue: [ - toStyle _ actualContents copyFrom: interval first to: interval last. - anSHTextStyler formatAndStyle: toStyle allowBackgroundStyleProcess: false. - actualContents replaceFrom: interval first to: interval last with: anSHTextStyler formattedText ]]]! ! -!StyledTextModel methodsFor: 'undoable commands' stamp: 'jmv 9/22/2011 15:06'! - logUndoAndRemoveCharacterStylesIn: anInterval - "Remove any char styles from selection" - "This is a user command, and generates undo" - - | command | - command _ actualContents commandForRemoveCharacterStylesIn: anInterval. - undoRedoCommands - nextPut: command; - truncateAtPosition. "To disable redo of previous commands, now invalidated." - command doOn: self! ! -!StyledTextModel methodsFor: 'undoable commands' stamp: 'jmv 12/29/2011 15:38'! - removeReferencesToCharacterStyle: oldCharacterStyle - "Replace in all contents. Both arguments must be of the same kind (either para or char style)." - "This is a user command, and generates undo" - - "Undo not yet implemented. Reasons: - 1) it would hold references to unused styles that we might want to die - 2) it would require a slower implementation" - self flag: #jmv. - - actualContents removeReferencesToCharacterStyle: oldCharacterStyle! ! -!StyledTextModel methodsFor: 'undoable commands' stamp: 'jmv 9/21/2011 11:35'! - replaceReferencesToStyle: oldParagraphOrCharacterStyle with: newParagraphOrCharacterStyle - "Replace in all contents. Both arguments must be of the same kind (either para or char style)." - "This is a user command, and generates undo" - - "Undo not yet implemented. Reasons: - 1) it would hold references to unused styles that we might want to die - 2) it would require a slower implementation" - self flag: #jmv. - - actualContents replaceReferencesToStyle: oldParagraphOrCharacterStyle with: newParagraphOrCharacterStyle! ! -!StyledTextModel methodsFor: 'file save' stamp: 'jmv 12/20/2012 12:21'! - save - "Answer wether save was successful." - "Note: to enable the use of StyledText in applications, where 'accept' or 'save' have other meanings than 'save to file', we need to merge this class with PluggableTextModel, and have the textProvider be the application." - fileName ifNil: [ - fileName _ FillInTheBlankMorph - request: 'File name?' - initialAnswer: ''. - fileName isEmpty ifTrue: [ ^false ]]. - - self saveAs: fileName. - ^true! ! -!StyledTextModel methodsFor: 'file save' stamp: 'jmv 5/31/2016 11:24'! - saveAs: aName - | refStream | - fileName _ self class withExtension: aName. - self flushUndoRedoCommands. - fileName asFileEntry forceWriteStreamDo: [ :strm | - refStream _ SmartRefStream on: strm. - refStream nextPut: self - ].! ! -!StyledTextModel methodsFor: 'Shout Styling' stamp: 'jmv 12/21/2010 23:48'! - shoutAboutToStyle: aSHTextStyler - "This is a notification that aSHTextStyler is about to re-style its text." - - aSHTextStyler classOrMetaClass: nil. - ^true! ! -!StyledTextModel methodsFor: 'accessing' stamp: 'jmv 8/9/2011 14:40'! - styleSet - ^styleSet! ! -!StyledTextModel methodsFor: 'accessing' stamp: 'jmv 8/11/2011 11:31'! - styleSet: aStyleSet - "All assignments to the styleSet ivar should call this method." - styleSet ifNotNil: [ styleSet removeActionsWithReceiver: self ]. - styleSet _ aStyleSet. - styleSet ifNotNil: [ styleSet when: #stylesChanged send: #styleSetChanged to: self ]! ! -!StyledTextModel methodsFor: 'events' stamp: 'jmv 8/11/2011 11:33'! - styleSetChanged - "Our style set (or some style in it) changed. - Update text and any views." - actualContents beStyledTextWith: styleSet. - self triggerEvent: #stylesChanged! ! -!StyledTextModel methodsFor: 'user interface support' stamp: 'jmv 11/3/2016 11:03:59'! - textStylerClass - ^SHTextStylerST80! ! -!StyledTextModel class methodsFor: 'as yet unclassified' stamp: 'jmv 5/31/2016 11:16'! - fromFileNamed: aFileName - | fileName model | - fileName _ self withExtension: aFileName. - fileName asFileEntry readStreamDo: [ :strm | - model _ (SmartRefStream on: strm) next - ]. - model fileName: fileName. - "Crude way to fix old Color subInstances in files" - " - Color allInstancesDo: [ :c | c fix ]. - TranslucentColor allInstancesDo: [ :c | c fix ]. - " - ^model! ! -!StyledTextModel class methodsFor: 'as yet unclassified' stamp: 'bp 12/21/2011 10:20'! - new - ^self styleSet: StyleSet sample! ! -!StyledTextModel class methodsFor: 'as yet unclassified' stamp: 'bp 12/21/2011 10:19'! - styleSet: aStyleSet - ^super new - styleSet: aStyleSet; - yourself! ! -!StyledTextModel class methodsFor: 'as yet unclassified' stamp: 'jmv 4/28/2012 19:10'! - withExtension: aName - | suffix | - suffix := '.object'. - ^(aName endsWith: suffix) - ifTrue: [ aName ] - ifFalse: [ aName , suffix ]! ! -!StyleSet methodsFor: 'accessing' stamp: 'jmv 8/9/2011 11:03'! - autoCompletedStyle - ^self characterStyleNamed: 'Completed Text'! ! -!StyleSet methodsFor: 'accessing' stamp: 'jmv 4/2/2016 23:07'! - characterStyleAt: index - | i ii | - index <= characterStyles size ifTrue: [ - ^(characterStyles at: index) second ]. - volatileParaStyles ifNotNil: [ - i _ index - characterStyles size. - ii _ 0. - volatileCharStyles withIndexDo: [ :each :iii | - each ifNotNil: [ - ii _ ii + 1. - ii = i ifTrue: [ ^each ]]]]. - ^nil! ! -!StyleSet methodsFor: 'accessing' stamp: 'jmv 12/30/2011 09:51'! - characterStyleForShortcut: aCharacter - - characterStyles do: [ :pair | - pair first = aCharacter ifTrue: [ ^pair second ]]. - ^nil! ! -!StyleSet methodsFor: 'accessing' stamp: 'jmv 4/2/2016 23:07'! - characterStyleIndexOf: aCharacterStyle - | index ii | - index _ characterStyles findFirst: [ :pair | pair second = aCharacterStyle ]. - index = 0 ifFalse: [ ^index ]. - - volatileCharStyles ifNotNil: [ - ii _ 0. - volatileCharStyles withIndexDo: [ :each :iii | - each ifNotNil: [ - ii _ ii + 1. - each = aCharacterStyle ifTrue: [ ^characterStyles size + ii ]]]]. - - ^0! ! -!StyleSet methodsFor: 'accessing' stamp: 'jmv 8/11/2011 11:37'! - characterStyleNamed: aString - - | style | - characterStyles ifNotNil: [ - characterStyles do: [ :pair | - style _ pair second. - style name = aString ifTrue: [ ^style ]]]. - ^nil! ! -!StyleSet methodsFor: 'accessing' stamp: 'jmv 8/11/2011 10:03'! - characterStyleNamedOrNew: aString - - ^(self characterStyleNamed: aString) ifNil: [ - CharacterStyle new privateName: aString ]! ! -!StyleSet methodsFor: 'accessing' stamp: 'jmv 12/19/2011 12:33'! - characterStyleNamesAndShortcuts - ^Array streamContents: [ :strm | - characterStyles do: [ :pair | - strm nextPut: pair second name, ' (', pair first asString, ')' ]. - volatileCharStyles ifNotNil: [ - volatileCharStyles do: [ :styleOrNil | - styleOrNil ifNotNil: [ - strm nextPut: styleOrNil name ]]]]! ! -!StyleSet methodsFor: 'accessing' stamp: 'jmv 8/9/2011 14:38'! - characterStyles - ^characterStyles! ! -!StyleSet methodsFor: 'initialization examples' stamp: 'bp 12/9/2011 02:26'! - createDocumentationCharacterStyleSet - "Build one of the many possible sets of Styles. Maybe other methods like this will be added." - | emphasised className completedText nullStyle | - emphasised _ self characterStyleNamedOrNew: 'Emphasized'. - emphasised privateFamilyName: 'DejaVu' pointSize: 11 emphasis: 0 color: Color blue. - - className _ self characterStyleNamedOrNew: 'Class Name'. - className privateFamilyName: 'DejaVu' pointSize: 11 emphasis: 0 color: Color magenta. - - completedText _ self characterStyleNamedOrNew: 'Completed Text'. - completedText privateFamilyName: 'DejaVu' pointSize: 12 emphasis: 0 color: Color green. - - nullStyle _ CharacterStyle nullStyle. - - characterStyles _ { - {$e. emphasised}. - {$l. className}. - {$p. completedText}. - {$n. nullStyle} - }. - - self triggerEvent: #stylesChanged! ! -!StyleSet methodsFor: 'initialization examples' stamp: 'bp 12/9/2011 02:27'! - createDocumentationParagraphStyleSet - "Build one of the many possible sets of Styles. Maybe other methods like this will be added." - | figure indent heading1 heading2 heading3 text | - - indent _ 10. - - text _ self paragraphStyleNamedOrNew: 'Text'. - text privateFamilyName: 'DejaVu' pointSize: 11 emphasis: 0 color: nil - alignment: CharacterScanner leftFlushCode firstIndent: indent + 20 restIndent: indent rightIndent: indent - spaceBefore: 2 spaceAfter: 2. - - figure _ self paragraphStyleNamedOrNew: 'Figure'. - figure privateFamilyName: 'DejaVu' pointSize: 5 emphasis: 0 color: nil - alignment: CharacterScanner leftFlushCode firstIndent: indent restIndent: indent rightIndent: indent - spaceBefore: 0 spaceAfter: 0. - - heading1 _ self paragraphStyleNamedOrNew: 'Heading 1'. - heading1 privateFamilyName: 'DejaVu' pointSize: 22 emphasis: AbstractFont boldCode color: nil - alignment: CharacterScanner leftFlushCode firstIndent: indent restIndent: indent rightIndent: indent - spaceBefore: 20 spaceAfter: 10. - - heading2 _ self paragraphStyleNamedOrNew: 'Heading 2'. - heading2 privateFamilyName: 'DejaVu' pointSize: 17 emphasis: AbstractFont boldCode color: Color red - alignment: CharacterScanner leftFlushCode firstIndent: indent restIndent: indent rightIndent: indent - spaceBefore: 24 spaceAfter: 10. - - heading3 _ self paragraphStyleNamedOrNew: 'Heading 3'. - heading3 privateFamilyName: 'DejaVu' pointSize: 11 emphasis: AbstractFont boldCode color: nil - alignment: CharacterScanner leftFlushCode firstIndent: indent restIndent: indent rightIndent: indent - spaceBefore: 22 spaceAfter: 3. - - paragraphStyles _ { - {$0. text}. - {$1. heading1}. - {$2. heading2}. - {$3. heading3}. - }. - - self triggerEvent: #stylesChanged! ! -!StyleSet methodsFor: 'initialization examples' stamp: 'bp 10/29/2011 16:47'! - createDramaCharacterStyleSet - "Build one of the many possible sets of Styles. Maybe other methods like this will be added." - | completedText nullStyle | - - completedText _ self characterStyleNamedOrNew: 'Completed Text'. - completedText privateFamilyName: 'DejaVu' pointSize: 12 emphasis: 0 color: Color green. - - nullStyle _ CharacterStyle nullStyle. - - characterStyles _ { - {$p. completedText}. - {$n. nullStyle} - }. - - self triggerEvent: #stylesChanged! ! -!StyleSet methodsFor: 'initialization examples' stamp: 'bp 10/29/2011 16:47'! - createDramaParagraphStyleSet - "Build one of the many possible sets of Styles. Maybe other methods like this will be added." - | figure leftIndent act scene sceneDescription sceneInstruction speaker text | - - leftIndent _ 20. - - figure _ self paragraphStyleNamedOrNew: 'Figure'. - figure privateFamilyName: 'DejaVu' pointSize: 5 emphasis: 0 color: nil - alignment: CharacterScanner leftFlushCode firstIndent: leftIndent restIndent: leftIndent rightIndent: 10 - spaceBefore: 0 spaceAfter: 0. - - act _ self paragraphStyleNamedOrNew: 'Act'. - act privateFamilyName: 'DejaVu' pointSize: 22 emphasis: AbstractFont boldCode color: nil - alignment: CharacterScanner leftFlushCode firstIndent: leftIndent restIndent: leftIndent rightIndent: 0 - spaceBefore: 20 spaceAfter: 10. - - scene _ self paragraphStyleNamedOrNew: 'Scene'. - scene privateFamilyName: 'DejaVu' pointSize: 17 emphasis: AbstractFont boldCode color: Color red - alignment: CharacterScanner leftFlushCode firstIndent: leftIndent restIndent: leftIndent rightIndent: 0 - spaceBefore: 24 spaceAfter: 10. - - sceneDescription _ self paragraphStyleNamedOrNew: 'Scene Description'. - sceneDescription privateFamilyName: 'DejaVu' pointSize: 11 emphasis: AbstractFont boldCode color: Color blue - alignment: CharacterScanner leftFlushCode firstIndent: leftIndent restIndent: leftIndent rightIndent: 10 - spaceBefore: 2 spaceAfter: 2. - - sceneInstruction _ self paragraphStyleNamedOrNew: 'Scene Instruction'. - sceneInstruction privateFamilyName: 'DejaVu' pointSize: 11 emphasis: AbstractFont italicCode color: Color blue - alignment: CharacterScanner leftFlushCode firstIndent: leftIndent restIndent: leftIndent rightIndent: 10 - spaceBefore: 2 spaceAfter: 2. - - speaker _ self paragraphStyleNamedOrNew: 'Speaker'. - speaker privateFamilyName: 'DejaVu' pointSize: 11 emphasis: AbstractFont boldCode color: nil - alignment: CharacterScanner leftFlushCode firstIndent: leftIndent restIndent: leftIndent rightIndent: 10 - spaceBefore: 22 spaceAfter: 3. - - text _ self paragraphStyleNamedOrNew: 'Text'. - text privateFamilyName: 'DejaVu' pointSize: 11 emphasis: AbstractFont italicCode color: nil - alignment: CharacterScanner leftFlushCode firstIndent: leftIndent + 20 restIndent: leftIndent +20 rightIndent: 10 - spaceBefore: 2 spaceAfter: 2. - - paragraphStyles _ { - {$f. figure}. - {$a. act}. - {$s. scene}. - {$d. sceneDescription}. - {$i. sceneInstruction}. - {$k. speaker}. - {$t. text}. - }. - - self triggerEvent: #stylesChanged! ! -!StyleSet methodsFor: 'initialization examples' stamp: 'bp 12/11/2011 01:36'! - createFeaturesCharacterStyleSet - "Build one of the many possible sets of Styles. Maybe other methods like this will be added." - | title featureType nullStyle completedText | - - title _ self characterStyleNamedOrNew: 'Title'. - title privateFamilyName: 'DejaVu' pointSize: 11 emphasis: 0 color: Color blue. - - featureType _ self characterStyleNamedOrNew: 'Feature Type'. - featureType privateFamilyName: 'DejaVu' pointSize: 10 emphasis: AbstractFont boldCode color: Color red. - - completedText _ self characterStyleNamedOrNew: 'Completed Text'. - completedText privateFamilyName: 'DejaVu' pointSize: 12 emphasis: 0 color: Color green. - - nullStyle _ CharacterStyle nullStyle. - - characterStyles _ { - {$t. title}. - {$y. featureType}. - {$p. completedText}. - {$n. nullStyle} - }. - - self triggerEvent: #stylesChanged! ! -!StyleSet methodsFor: 'initialization examples' stamp: 'bp 10/29/2011 15:41'! - createFeaturesParagraphStyleSet - "Build one of the many possible sets of Styles. Maybe other methods like this will be added." - | heading1 heading2 heading3 emphasized normal numbered alphabetic bulleted smalltalkCode | - - normal _ self paragraphStyleNamedOrNew: 'Normal'. - normal privateFamilyName: 'DejaVu' pointSize: 11 emphasis: 0 color: nil - alignment: CharacterScanner leftFlushCode firstIndent: 30 restIndent: 10 rightIndent: 10 - spaceBefore: 8 spaceAfter: 2. - - emphasized _ self paragraphStyleNamedOrNew: 'Emphasized'. - emphasized privateFamilyName: 'DejaVu' pointSize: 10 emphasis: AbstractFont boldCode color: nil - alignment: CharacterScanner justifiedCode firstIndent: 60 restIndent: 60 rightIndent: 60 - spaceBefore: 10 spaceAfter: 2. - - heading1 _ self paragraphStyleNamedOrNew: 'Heading 1'. - heading1 privateFamilyName: 'DejaVu' pointSize: 22 emphasis: 0 color: nil - alignment: CharacterScanner centeredCode firstIndent: 0 restIndent: 0 rightIndent: 0 - spaceBefore: 34 spaceAfter: 18. - - heading2 _ self paragraphStyleNamedOrNew: 'Heading 2'. - heading2 privateFamilyName: 'DejaVu' pointSize: 17 emphasis: AbstractFont boldCode color: nil - alignment: CharacterScanner leftFlushCode firstIndent: 0 restIndent: 0 rightIndent: 0 - spaceBefore: 24 spaceAfter: 8. - - heading3 _ self paragraphStyleNamedOrNew: 'Heading 3'. - heading3 privateFamilyName: 'DejaVu' pointSize: 14 emphasis: AbstractFont italicCode color: nil - alignment: CharacterScanner leftFlushCode firstIndent: 0 restIndent: 0 rightIndent: 0 - spaceBefore: 18 spaceAfter: 4. - - numbered _ self paragraphStyleNamedOrNew: 'Numbered List'. - numbered privateFamilyName: 'DejaVu' pointSize: 11 emphasis: 0 color: nil - alignment: CharacterScanner justifiedCode firstIndent: 10 restIndent: 50 rightIndent: 10 - spaceBefore: 8 spaceAfter: 2; - privateListBulletPattern: '%%%. '. - - alphabetic _ self paragraphStyleNamedOrNew: 'Alphabetic List'. - alphabetic privateFamilyName: 'DejaVu' pointSize: 11 emphasis: 0 color: nil - alignment: CharacterScanner justifiedCode firstIndent: 10 restIndent: 30 rightIndent: 10 - spaceBefore: 8 spaceAfter: 2; - privateListBulletPattern: 'z) '. - - bulleted _ self paragraphStyleNamedOrNew: 'Bulleted List'. - bulleted privateFamilyName: 'DejaVu' pointSize: 11 emphasis: 0 color: nil - alignment: CharacterScanner justifiedCode firstIndent: 10 restIndent: 30 rightIndent: 10 - spaceBefore: 8 spaceAfter: 2; - privateListBulletPattern: '° '. - - smalltalkCode _ self paragraphStyleNamedOrNew: 'Smalltalk code'. - smalltalkCode privateFamilyName: 'DejaVu' pointSize: 11 emphasis: 0 color: nil - alignment: CharacterScanner leftFlushCode firstIndent: 10 restIndent: 10 rightIndent: 10 - spaceBefore: 0 spaceAfter: 0; - doShout. - - paragraphStyles _ { - {$0. normal}. - {$e. emphasized}. - {$1. heading1}. - {$2. heading2}. - {$3. heading3}. - {$4. numbered}. - {$5. alphabetic}. - {$6. bulleted}. - {$7. smalltalkCode} - }. - - self triggerEvent: #stylesChanged! ! -!StyleSet methodsFor: 'initialization examples' stamp: 'jmv 8/11/2011 11:00'! - createSampleCharacterStyleSet - "Build one of the many possible sets of Styles. Maybe other methods like this will be added." - | green11Italic green14 red10Bold nullStyle completedText | - - green11Italic _ self characterStyleNamedOrNew: 'Green 11 Italic'. - green11Italic privateFamilyName: 'DejaVu' pointSize: 11 emphasis: AbstractFont italicCode color: Color green. - - green14 _ self characterStyleNamedOrNew: 'Green 14'. - green14 privateFamilyName: 'DejaVu' pointSize: 14 emphasis: 0 color: Color green. - - red10Bold _ self characterStyleNamedOrNew: 'Red 10 bold'. - red10Bold privateFamilyName: 'DejaVu' pointSize: 10 emphasis: AbstractFont boldCode color: Color red. - - completedText _ self characterStyleNamedOrNew: 'Completed Text'. - completedText privateFamilyName: 'DejaVu' pointSize: 12 emphasis: 0 color: Color green. - - nullStyle _ CharacterStyle nullStyle. - - characterStyles _ { - {$u. green11Italic}. - {$i. green14}. - {$o. red10Bold}. - {$p. completedText}. - {$n. nullStyle} - }. - - self triggerEvent: #stylesChanged! ! -!StyleSet methodsFor: 'initialization examples' stamp: 'jmv 8/11/2011 11:00'! - createSampleParagraphStyleSet - "Build one of the many possible sets of Styles. Maybe other methods like this will be added." - | heading1 heading2 heading3 emphasized normal numbered alphabetic bulleted smalltalkCode | - - normal _ self paragraphStyleNamedOrNew: 'Normal'. - normal privateFamilyName: 'DejaVu' pointSize: 11 emphasis: 0 color: nil - alignment: CharacterScanner justifiedCode firstIndent: 30 restIndent: 10 rightIndent: 10 - spaceBefore: 8 spaceAfter: 2. - - emphasized _ self paragraphStyleNamedOrNew: 'Emphasized'. - emphasized privateFamilyName: 'DejaVu' pointSize: 10 emphasis: AbstractFont boldCode color: nil - alignment: CharacterScanner justifiedCode firstIndent: 60 restIndent: 60 rightIndent: 60 - spaceBefore: 10 spaceAfter: 2. - - heading1 _ self paragraphStyleNamedOrNew: 'Heading 1'. - heading1 privateFamilyName: 'DejaVu' pointSize: 22 emphasis: 0 color: nil - alignment: CharacterScanner centeredCode firstIndent: 0 restIndent: 0 rightIndent: 0 - spaceBefore: 34 spaceAfter: 18. - - heading2 _ self paragraphStyleNamedOrNew: 'Heading 2'. - heading2 privateFamilyName: 'DejaVu' pointSize: 17 emphasis: AbstractFont boldCode color: nil - alignment: CharacterScanner centeredCode firstIndent: 0 restIndent: 0 rightIndent: 0 - spaceBefore: 24 spaceAfter: 8. - - heading3 _ self paragraphStyleNamedOrNew: 'Heading 3'. - heading3 privateFamilyName: 'DejaVu' pointSize: 14 emphasis: AbstractFont italicCode color: nil - alignment: CharacterScanner centeredCode firstIndent: 0 restIndent: 0 rightIndent: 0 - spaceBefore: 18 spaceAfter: 4. - - numbered _ self paragraphStyleNamedOrNew: 'Numbered List'. - numbered privateFamilyName: 'DejaVu' pointSize: 11 emphasis: 0 color: nil - alignment: CharacterScanner justifiedCode firstIndent: 10 restIndent: 50 rightIndent: 10 - spaceBefore: 8 spaceAfter: 2; - privateListBulletPattern: '%%%. '. - - alphabetic _ self paragraphStyleNamedOrNew: 'Alphabetic List'. - alphabetic privateFamilyName: 'DejaVu' pointSize: 11 emphasis: 0 color: nil - alignment: CharacterScanner justifiedCode firstIndent: 10 restIndent: 30 rightIndent: 10 - spaceBefore: 8 spaceAfter: 2; - privateListBulletPattern: 'z) '. - - bulleted _ self paragraphStyleNamedOrNew: 'Bulleted List'. - bulleted privateFamilyName: 'DejaVu' pointSize: 11 emphasis: 0 color: nil - alignment: CharacterScanner justifiedCode firstIndent: 10 restIndent: 30 rightIndent: 10 - spaceBefore: 8 spaceAfter: 2; - privateListBulletPattern: '° '. - - smalltalkCode _ self paragraphStyleNamedOrNew: 'Smalltalk code'. - smalltalkCode privateFamilyName: 'DejaVu' pointSize: 11 emphasis: 0 color: nil - alignment: CharacterScanner leftFlushCode firstIndent: 10 restIndent: 10 rightIndent: 10 - spaceBefore: 0 spaceAfter: 0; - doShout. - - paragraphStyles _ { - {$0. normal}. - {$e. emphasized}. - {$1. heading1}. - {$2. heading2}. - {$3. heading3}. - {$4. numbered}. - {$5. alphabetic}. - {$6. bulleted}. - {$7. smalltalkCode} - }. - - self triggerEvent: #stylesChanged! ! -!StyleSet methodsFor: 'accessing' stamp: 'jmv 1/13/2012 14:05'! - defaultStyle - "Usually we include a 'Normal' style. If not, answer some style anyway. - We might refine this!!" - ^(self paragraphStyleNamed: 'Normal') ifNil: [ self paragraphStyleAt: 1 ]! ! -!StyleSet methodsFor: 'special' stamp: 'jmv 12/19/2011 12:38'! - equivalentCSTo: aCharacterStyle orAddVolatile: namePrefix - "Do not match existing style by name: add as new style to set" - - | count nameToUse possibleName newCharacterStyle i | - characterStyles do: [ :pair | - (pair second isEquivalentTo: aCharacterStyle) ifTrue: [ ^ pair second ]]. - - possibleName _ aCharacterStyle name isEmpty - ifFalse: [ namePrefix, aCharacterStyle name ] - ifTrue: [ namePrefix, aCharacterStyle shortDescription ]. - volatileCharStyles - ifNil: [ - newCharacterStyle _ aCharacterStyle copy. - newCharacterStyle privateName: possibleName. - volatileCharStyles _ WeakArray with: newCharacterStyle ] - ifNotNil: [ - volatileCharStyles do: [ :cs | (cs notNil and: [ cs isEquivalentTo: aCharacterStyle]) ifTrue: [ ^cs ]]. - newCharacterStyle _ aCharacterStyle copy. - nameToUse _ possibleName. - count _ 1. - [ volatileCharStyles anySatisfy: [ :cs | cs notNil and: [ cs name = nameToUse ]]] whileTrue: [ - count _ count +1. - nameToUse _ possibleName, ' ', count printString ]. - newCharacterStyle privateName: nameToUse. - i _ volatileCharStyles indexOf: nil. - i = 0 - ifTrue: [ volatileCharStyles _ volatileCharStyles copyWith: newCharacterStyle] - ifFalse: [ volatileCharStyles at: i put: newCharacterStyle ]]. - ^newCharacterStyle! ! -!StyleSet methodsFor: 'special' stamp: 'jmv 12/19/2011 10:58'! - equivalentOrSameNameCSTo: aCharacterStyle orAddVolatile: namePrefix - - "Match existing style by name." - (self characterStyleNamed: aCharacterStyle name) ifNotNil: [ :namedTheSame | - ^ namedTheSame ]. - - "Find equivalent, or add." - ^self equivalentCSTo: aCharacterStyle orAddVolatile: namePrefix! ! -!StyleSet methodsFor: 'special' stamp: 'jmv 12/19/2011 10:58'! - equivalentOrSameNamePSTo: aParagraphStyle orAddVolatile: namePrefix - - "Match existing style by name." - (self paragraphStyleNamed: aParagraphStyle name) ifNotNil: [ :namedTheSame | - ^ namedTheSame ]. - - "Find equivalent, or add." - ^self equivalentPSTo: aParagraphStyle orAddVolatile: namePrefix! ! -!StyleSet methodsFor: 'special' stamp: 'jmv 12/19/2011 12:37'! - equivalentPSTo: aParagraphStyle orAddVolatile: namePrefix - "Do not match existing style by name: add as new style to set" - - | count nameToUse possibleName newParagraphStyle i | - paragraphStyles do: [ :pair | - (pair second isEquivalentTo: aParagraphStyle) ifTrue: [ ^ pair second ]]. - - possibleName _ aParagraphStyle name isEmpty - ifFalse: [ namePrefix, aParagraphStyle name ] - ifTrue: [ namePrefix, aParagraphStyle shortDescription ]. - volatileParaStyles - ifNil: [ - newParagraphStyle _ aParagraphStyle copy. - newParagraphStyle privateName: possibleName. - volatileParaStyles _ WeakArray with: newParagraphStyle ] - ifNotNil: [ - volatileParaStyles do: [ :ps | (ps notNil and: [ ps isEquivalentTo: aParagraphStyle]) ifTrue: [ ^ps ]]. - newParagraphStyle _ aParagraphStyle copy. - nameToUse _ possibleName. - count _ 1. - [ volatileParaStyles anySatisfy: [ :ps | ps notNil and: [ ps name = nameToUse ]]] whileTrue: [ - count _ count +1. - nameToUse _ possibleName, ' ', count printString ]. - newParagraphStyle privateName: nameToUse. - i _ volatileParaStyles indexOf: nil. - i = 0 - ifTrue: [ volatileParaStyles _ volatileParaStyles copyWith: newParagraphStyle] - ifFalse: [ volatileParaStyles at: i put: newParagraphStyle ]]. - ^newParagraphStyle! ! -!StyleSet methodsFor: 'initialization examples' stamp: 'jmv 8/9/2011 15:55'! - initializeEmpty - paragraphStyles _ #(). - characterStyles _ #()! ! -!StyleSet methodsFor: 'initialization examples' stamp: 'jmv 8/11/2011 11:41'! - makeStylesMuchSmaller - "Just an example - - | model text | - model _ StyledTextModel new. - text _ Text string: 'Just a text' attribute: (ParagraphStyleReference for: (model styleSet paragraphStyleNamed: 'Normal')). - model contents: text. - model styleSet makeStylesMuchSmaller. - SystemWindow editFancierStyledText: model label: 'Styled Text Editor' - " - paragraphStyles do: [ :pair | - pair second privatePointSize: 8 ]. - characterStyles do: [ :pair | - pair second pointSize ifNotNil: [ :ps | - pair second privatePointSize: 8]]. - - self triggerEvent: #stylesChanged! ! -!StyleSet methodsFor: 'initialization examples' stamp: 'jmv 8/11/2011 11:41'! - makeStylesSmaller - "Just an example - - | model text | - model _ StyledTextModel new. - text _ Text string: 'Just a text' attribute: (ParagraphStyleReference for: (model styleSet paragraphStyleNamed: 'Normal')). - model contents: text. - model styleSet makeStylesSmaller. - SystemWindow editFancierStyledText: model label: 'Styled Text Editor' - " - paragraphStyles do: [ :pair | - pair second privatePointSize: 10 ]. - characterStyles do: [ :pair | - pair second pointSize ifNotNil: [ :ps | - pair second privatePointSize: 10]]. - - self triggerEvent: #stylesChanged! ! -!StyleSet methodsFor: 'accessing' stamp: 'jmv 4/2/2016 23:07'! - paragraphStyleAt: index - | i ii | - index <= paragraphStyles size ifTrue: [ - ^(paragraphStyles at: index) second ]. - volatileParaStyles ifNotNil: [ - i _ index - paragraphStyles size. - ii _ 0. - volatileParaStyles withIndexDo: [ :each :iii | - each ifNotNil: [ - ii _ ii + 1. - ii = i ifTrue: [ ^each ]]]]. - ^nil! ! -!StyleSet methodsFor: 'accessing' stamp: 'jmv 12/30/2011 09:53'! - paragraphStyleForShortcut: aCharacter - - paragraphStyles do: [ :pair | - pair first = aCharacter ifTrue: [ ^pair second ]]. - ^nil! ! -!StyleSet methodsFor: 'accessing' stamp: 'jmv 4/2/2016 23:07'! - paragraphStyleIndexOf: aParagraphStyle - | index ii | - index _ paragraphStyles findFirst: [ :pair | pair second = aParagraphStyle ]. - index = 0 ifFalse: [ ^index ]. - - volatileParaStyles ifNotNil: [ - ii _ 0. - volatileParaStyles withIndexDo: [ :each :iii | - each ifNotNil: [ - ii _ ii + 1. - each = aParagraphStyle ifTrue: [ ^paragraphStyles size + ii ]]]]. - - ^0! ! -!StyleSet methodsFor: 'accessing' stamp: 'jmv 8/11/2011 11:36'! - paragraphStyleNamed: aString - - | style | - paragraphStyles ifNotNil: [ - paragraphStyles do: [ :pair | - style _ pair second. - style name = aString ifTrue: [ ^style ]]]. - ^nil! ! -!StyleSet methodsFor: 'accessing' stamp: 'jmv 8/11/2011 10:02'! - paragraphStyleNamedOrNew: aString - - ^(self paragraphStyleNamed: aString) ifNil: [ - ParagraphStyle new privateName: aString ]! ! -!StyleSet methodsFor: 'accessing' stamp: 'jmv 12/19/2011 12:33'! - paragraphStyleNamesAndShortcuts - ^Array streamContents: [ :strm | - paragraphStyles do: [ :pair | - strm nextPut: pair second name, ' (', pair first asString, ')' ]. - volatileParaStyles ifNotNil: [ - volatileParaStyles do: [ :styleOrNil | - styleOrNil ifNotNil: [ - strm nextPut: styleOrNil name ]]]]! ! -!StyleSet methodsFor: 'accessing' stamp: 'jmv 8/9/2011 14:38'! - paragraphStyles - ^paragraphStyles! ! -!StyleSet methodsFor: 'private' stamp: 'jmv 12/30/2011 10:38'! - useWeakArrays - "An aux conversion method for old instances - StyleSet allInstancesDo: [ :a | a useWeakArrays ]. Smalltalk garbageCollect - " - volatileParaStyles class == Array ifTrue: [ - volatileParaStyles _ WeakArray withAll: volatileParaStyles ]. - volatileCharStyles class == Array ifTrue: [ - volatileCharStyles _ WeakArray withAll: volatileCharStyles ].! ! -!StyleSet class methodsFor: 'instance creation' stamp: 'jmv 8/9/2011 15:55'! - empty - ^self new initializeEmpty! ! -!StyleSet class methodsFor: 'instance creation' stamp: 'bp 12/21/2011 10:21'! - features - ^self new - createFeaturesParagraphStyleSet; - createFeaturesCharacterStyleSet! ! -!StyleSet class methodsFor: 'instance creation' stamp: 'jmv 12/20/2011 12:37'! - sample - ^self new - createSampleParagraphStyleSet; - createSampleCharacterStyleSet! ! -!StyledTextEditor methodsFor: 'private' stamp: 'jmv 3/14/2012 08:25'! - addAttributesForPasting: replacement - | start stop answer paragraphStyle | - (replacement is: #Text) - ifTrue: [ - start _ self startIndex. - stop _ self stopIndex. - - "Version previous to 12/19/2011" - "If we are pasting a text that doesn't bring a ParagraphStyleReference in the last paragraph (because it doesn't end with a NewLine), and we need it, - but it won't be provided by our text, as we are at the end, then add any paragraph attribute from emphasisHere. - Note: If we are replacing all the current text (or we have no current text), then just leave whatever comes with replacement, - asuming that the pasted text knows better than our default for empty text - (unless it brings no paragraph style at the end. In that case, add emphasisHere anyway)" -" (replacement notEmpty and: [ - replacement last isLineSeparator not and: [ - stop > model textSize and: [ - start > 1 or: [(replacement paragraphStyleOrNilAt: replacement size + 1) isNil] - ] - ] - ])". - - - "If we are pasting a text that maybe doesn't bring a relevant ParagraphStyleReference in the last paragraph (because it doesn't include a NewLine), - but it won't be provided by our text, as we are at the end of it, then add any paragraph attribute from emphasisHere." - answer _ ((replacement includes: Character newLineCharacter) not and: [ stop > model textSize and: [ - "Note: Do this only if the current paragraph is not empty, meaning that it is already using the current ParagraphStyle for some text." - (start > 1 and: [ (model actualContents at: start-1) isLineSeparator not ]) - ]]) - ifTrue: [ (replacement, (Text string: String newLineString attributes: emphasisHere)) copyFrom: 1 to: replacement size ] - ifFalse: [ replacement ]. - - "In any case, ensure ParagraphStyle. (we could reach this point without a ParagraphStyle, for example, by choosing autocompletion on an empty text, - i.e. Open new STE, type 'Aardv' open completion and select 'Aardvark')" - emphasisHere do: [ :each | - each forParagraphStyleReferenceDo: [ :s | paragraphStyle _ s ]]. - answer runs mapValues: [ :attributes | - (attributes anySatisfy: [ :att | att class == ParagraphStyleReference ]) - ifTrue: [ attributes ] - ifFalse: [ attributes copyWith: (ParagraphStyleReference for: paragraphStyle) ]]. - - ^answer ] - - ifFalse: [ - ^Text string: replacement attributes: emphasisHere ]! ! -!StyledTextEditor methodsFor: 'private' stamp: 'jmv 9/5/2016 21:15:05'! - buildCmdShortcuts - cmdShortcuts _ self class cmdShortcuts copy. - model styleSet paragraphStyles do: [ :pair | - cmdShortcuts at: pair first numericValue + 1 put: #changeCurrentStyle: ]. - model styleSet characterStyles do: [ :pair | - cmdShortcuts at: pair first numericValue + 1 put: #changeCharacterStyle: ]! ! -!StyledTextEditor methodsFor: 'editing keys' stamp: 'jmv 9/21/2011 10:54'! - changeCharacterStyle: aKeyboardEvent - "This is a user command, and generates undo" - - (model styleSet characterStyleForShortcut: aKeyboardEvent keyCharacter) - ifNil: [ self removeCharacterStyles ] - ifNotNil: [ :style | - style isNullStyle - ifTrue: [ self removeCharacterStyles ] - ifFalse: [ self applyAttribute: (CharacterStyleReference for: style) ]]. - ^true! ! -!StyledTextEditor methodsFor: 'editing keys' stamp: 'jmv 9/19/2011 17:22'! - changeCurrentStyle: aKeyboardEvent - "This is a user command, and generates undo" - - (model styleSet paragraphStyleForShortcut: aKeyboardEvent keyCharacter) - ifNotNil: [ :style | - self applyAttribute: (ParagraphStyleReference for: style) ]. - ^true! ! -!StyledTextEditor methodsFor: 'clipboard access' stamp: 'jmv 8/11/2011 11:27'! - clipboardStringOrText - - | clipContents | - clipContents _ Clipboard retrieveStringOrText. - ^(clipContents is: #Text) - ifTrue: [ - "Merge styles appropriately, but in a copy." - clipContents asStyledTextWith: model styleSet ] - ifFalse: [ clipContents]! ! -!StyledTextEditor methodsFor: 'typing support' stamp: 'jmv 6/13/2012 18:06'! - cmdShortcuts - "We have keyboard shortcuts on a per-instance basis." - ^cmdShortcuts! ! -!StyledTextEditor methodsFor: 'accessing' stamp: 'jmv 6/13/2012 18:30'! - help - " - Editor help - SimpleEditor help - CellStyleEditor help - TextEditor help - SmalltalkEditor help - " - | allSpecs | - allSpecs _ self class cmdShortcutsSpec", self class basicCmdShortcutsSpec". - ^String streamContents: [ :strm | - model styleSet paragraphStyles do: [ :pair | - strm nextPutAll: ('Cmd-', pair first asString, String tab, String tab, String tab, 'Paragraph Style: ', pair second name). - strm newLine ]. - model styleSet characterStyles do: [ :pair | - strm nextPutAll: ('Cmd-', pair first asString, String tab, String tab, String tab, 'Character Style: ', pair second name). - strm newLine ]. - allSpecs do: [ :triplet | | c | - c _ triplet first = Character space - ifFalse: [ triplet first asString, String tab ] - ifTrue: [ 'Space']. - strm nextPutAll: ('Cmd-', c, String tab, String tab, triplet third). - strm newLine ]. - ]! ! -!StyledTextEditor methodsFor: 'model access' stamp: 'jmv 6/13/2012 18:07'! - model: aModel - super model: aModel. - "All assignments to the styleSet ivar should call this method." - model ifNotNil: [ model removeActionsWithReceiver: self ]. - model _ aModel. - model ifNotNil: [ model when: #stylesChanged send: #someStyleChanged to: self ]. - emphasisHere _ { ParagraphStyleReference for: model styleSet defaultStyle }. - self buildCmdShortcuts! ! -!StyledTextEditor methodsFor: 'commands' stamp: 'jmv 4/1/2016 13:47'! - quit: aKeyboardEvent - morph hasUnacceptedEdits ifTrue: [ - (self confirm: 'Save changes before quitting?' orCancel: [^ true]) ifTrue: [ - self save: aKeyboardEvent ]]. - Smalltalk - snapshot: false - andQuit: true - clearAllClassState: false. - ^true! ! -!StyledTextEditor methodsFor: 'commands' stamp: 'jmv 10/16/2013 20:10'! - removeCharacterStyles - "Let user remove character styles for the current selection." - "This is a user command, and generates undo" - | anythingDone | - emphasisHere _ emphasisHere reject: [ :att | - att class == CharacterStyleReference ]. - - anythingDone _ false. - self selectionIntervalsDo: [ :interval | - interval notEmpty ifTrue: [ - anythingDone _ true. - model logUndoAndRemoveCharacterStylesIn: interval. - textComposition recomposeFrom: interval first to: interval last delta: 0 ]]. - - anythingDone ifTrue: [ - self recomputeSelection. "Needed so visible selection is updated to reflect new visual extent of selection" - self userHasEdited ]. - - "Even if nothing done, emphasisHere might have changed" - morph possiblyChanged! ! -!StyledTextEditor methodsFor: 'commands' stamp: 'jmv 12/29/2011 15:39'! - replaceAllCharacterStyle - "Let user add or change character styles for the current selection, or for text to be typed." - "This is a user command, and generates undo" - | styles current menuList | - current _ self currentCharacterStyleOrNil. - styles _ model styleSet characterStyles collect: [ :pair | pair second ]. - menuList _ model styleSet characterStyles collect: [ :pair | - ((pair second = current or: [ pair second isNullStyle and: [current isNil]]) - ifTrue: [ '' ] - ifFalse: [ '' ]), - pair second name, ' (', pair first asString, ')' ]. - ((SelectionMenu labelList: menuList lines: #() selections: styles) startUp) - ifNotNil: [ :style | - style isNullStyle ifTrue: [ - model removeReferencesToCharacterStyle: current. - self someStyleChanged. - ^true ]. - style = current - ifFalse: [ - model replaceReferencesToStyle: current with: style. - self someStyleChanged ] ]. - ^ true! ! -!StyledTextEditor methodsFor: 'commands' stamp: 'jmv 9/19/2011 17:10'! -replaceAllCurrentStyle - "Let user change styles for the current selection or pragraph." - "This is a user command, and generates undo" - | styles current menuList | - - current _ self currentParagraphStyle. - styles _ model styleSet paragraphStyles collect: [ :pair | pair second ]. - menuList _ model styleSet paragraphStyles collect: [ :pair | - (pair second = current - ifTrue: [ '' ] - ifFalse: [ '' ]), - pair second name, ' (', pair first asString, ')' ]. - ((SelectionMenu labelList: menuList lines: #() selections: styles) startUp) - ifNotNil: [ :style | - style = current - ifFalse: [ - model replaceReferencesToStyle: current with: style. - self someStyleChanged ]]. - ^ true! ! -!StyledTextEditor methodsFor: 'commands' stamp: 'KenD 4/1/2016 14:36'! - save - "Save command" - model fileName ifNotNil: [ - model save - ifTrue: [ morph hasUnacceptedEdits: false ] - ] - ifNil: [ self saveAs ]. - ^true! ! -!StyledTextEditor methodsFor: 'commands' stamp: 'KenD 4/1/2016 14:37'! - save: aKeyboardEvent - "Save keystroke" - ^self save! ! -!StyledTextEditor methodsFor: 'commands' stamp: 'jmv 4/7/2016 17:48'! - saveAs - "SaveAs command" - | fileName | - fileName _ FillInTheBlankMorph - request: 'File name?' - initialAnswer: ''. - fileName isEmpty ifTrue: [ ^false ]. "abort" - - model saveAs: fileName. - morph hasUnacceptedEdits: false. - morph owningWindow - setLabel: model fileName; - invalidateTitleArea. - - ^true! ! -!StyledTextEditor methodsFor: 'selecting' stamp: 'jmv 11/18/2011 14:08'! - selectAllWithCurrentCharStyle - - self selectAllWithStyle: self currentCharacterStyleOrNil! ! -!StyledTextEditor methodsFor: 'selecting' stamp: 'jmv 11/18/2011 14:08'! - selectAllWithCurrentStyle - - self selectAllWithStyle: self currentParagraphStyle! ! -!StyledTextEditor methodsFor: 'selecting' stamp: 'jmv 6/6/2016 10:10'! - selectAllWithStyle: aParagraphOrCharacterStyle - - | i startIndexes stopIndexes start stop includeInSelection wasLastIncludedInSelection | - i _ 1. - startIndexes _ OrderedCollection new. - stopIndexes _ OrderedCollection new. - start _ nil. - stop _ nil. - wasLastIncludedInSelection _ false. - model actualContents runs runsAndValuesDo: [ :count :attributes | - includeInSelection _ attributes anySatisfy: [ :att | att isStyle and: [ att style == aParagraphOrCharacterStyle ]]. - includeInSelection - ifTrue: [ - wasLastIncludedInSelection - ifTrue: [ stop _ stop + count ] - ifFalse: [ start _ i. stop _ i+count ]] - ifFalse: [ - start ifNotNil: [ - startIndexes add: start. stopIndexes add: stop. - start _ nil. stop _ nil ]]. - i _ i + count. - wasLastIncludedInSelection _ includeInSelection ]. - wasLastIncludedInSelection ifTrue: [ - startIndexes add: start. stopIndexes add: stop ]. - selectionStartBlocks _ startIndexes collect: [ :index | (textComposition characterBlockForIndex: index) ]. - selectionStopBlocks _ stopIndexes collect: [ :index | (textComposition characterBlockForIndex: index) ]. - self storeSelectionInComposition! ! -!StyledTextEditor methodsFor: 'commands' stamp: 'jmv 6/24/2016 11:14'! - selectCharacterStyle - "Let user add or change character styles for the current selection, or for text to be typed." - "This is a user command, and generates undo" - - | styles current menuList | - current _ self currentCharacterStyleOrNil. - styles _ model styleSet characterStyles collect: [ :pair | pair second ]. - menuList _ model styleSet characterStyles collect: [ :pair | - ((pair second = current or: [ pair second isNullStyle and: [current isNil]]) - ifTrue: [ '' ] - ifFalse: [ '' ]), - pair second name, ' (', pair first asString, ')' ]. - ((SelectionMenu labelList: menuList lines: #() selections: styles) startUpWithCaption: 'Set Style') - ifNotNil: [ :style | - style isNullStyle ifTrue: [ - self removeCharacterStyles. - ^true ]. - style = current - ifFalse: [ self applyAttribute: (CharacterStyleReference for: style) ] - ifTrue: [ self unapplyAttributes: {CharacterStyleReference for: style} ] ]. - ^ true! ! -!StyledTextEditor methodsFor: 'commands' stamp: 'jmv 9/15/2009 09:27'! - selectCharacterStyle: aKeyboardEvent - "Let user add or change character styles for the current selection, or for text to be typed." - - ^self selectCharacterStyle! ! -!StyledTextEditor methodsFor: 'commands' stamp: 'jmv 6/24/2016 11:14'! - selectCurrentStyle - "Let user change styles for the current selection or pragraph." - "This is a user command, and generates undo" - - | styles current menuList | - current _ self currentParagraphStyle. - styles _ model styleSet paragraphStyles collect: [ :pair | pair second ]. - menuList _ model styleSet paragraphStyles collect: [ :pair | - (pair second = current - ifTrue: [ '' ] - ifFalse: [ '' ]), - pair second name, ' (', pair first asString, ')' ]. - ((SelectionMenu labelList: menuList lines: #() selections: styles) startUpWithCaption: 'Set Style') - ifNotNil: [ :style | - style = current - ifFalse: [ self applyAttribute: (ParagraphStyleReference for: style) ] - ifTrue: [ self unapplyAttributes: {ParagraphStyleReference for: style} ] ]. - ^ true! ! -!StyledTextEditor methodsFor: 'commands' stamp: 'jmv 9/15/2009 09:26'! - selectCurrentStyle: aKeyboardEvent - "Let user change styles for the current selection or pragraph." - - ^self selectCurrentStyle! ! -!StyledTextEditor methodsFor: 'typing support' stamp: 'jmv 1/13/2012 12:36'! - setEmphasisHereFromTextForward: f - - model isTextEmpty - ifTrue: [ - "default emphasisHere already set, but reflect it if needed" - morph possiblyChanged ] - ifFalse: [ super setEmphasisHereFromTextForward: f ]! ! -!StyledTextEditor methodsFor: 'notifications' stamp: 'jmv 10/16/2013 20:10'! - someStyleChanged - textComposition composeAll. - self recomputeSelection. - morph updateFromTextComposition. - - "Update keyboard shortcuts" - self buildCmdShortcuts! ! -!StyledTextEditor class methodsFor: 'keyboard shortcut tables' stamp: 'jmv 6/13/2012 18:02'! -cmdShortcutsSpec - " - Editor initialize - " - "arranged in QWERTY keyboard order" - ^#( - #( $q #quit: 'Quit') - - #( $s #save: 'Save') - #( $j #selectCurrentStyle: 'Select Paragraph Style') - #( $k #selectCharacterStyle: 'Select Character Style') - )! ! -!StyledTextEditor class methodsFor: 'file reader registration' stamp: 'KenD 2/3/2016 16:01'! - fileReaderServicesForFile: filename suffix: suffix - "FileList buttons that open a CodeFileBrowserWindow on contents." - - (#('object' 'ste') includes: suffix) ifTrue: [ - ^ { self serviceSTEEdit } ]. - - ^#()! ! -!StyledTextEditor class methodsFor: 'keyboard shortcut tables' stamp: 'KenD 4/1/2016 13:42'! - initializeMenu - "Initialize the yellow button pop-up menu and corresponding messages." - - " - Editor initialize - " - menu _ SelectionMenu fromArray: { - {'Help...'. #openHelp}. - #-. - {'Save (s)'. #save}. - {'SaveAs...'. #saveAs}. - #-. - {'Find...(f)'. #find}. - {'Find Again (g)'. #findAgain}. - {'Use Selection for Find (h)'. #setSearchString}. - #-. - {'Undo - multiple (z)'. #undo}. - {'Redo - multiple (Z)'. #redo}. - {'Undo / Redo history'. #offerUndoHistory}. - {'Forget Undo / Redo history'. #flushUndoRedoCommands}. - #-. - {'Copy (c)'. #copySelection}. - {'Cut (x)'. #cut}. - {'Paste (v)'. #paste}. - {'Paste without Format'. #pasteString}. - {'Paste...'. #pasteRecent}. - #-. - {'Select text with Paragraph Style'. #selectAllWithCurrentStyle}. - {'Select text with Character Style'. #selectAllWithCurrentCharStyle}. - #-. - {'Change Paragraph Style...'. #selectCurrentStyle}. - {'Change Character Style...'. #selectCharacterStyle}. - {'Remove Character Style'. #removeCharacterStyles}. - {'Replace all uses of Paragraph Style...'. #replaceAllCurrentStyle}. - {'Replace all uses of Character Style...'. #replaceAllCharacterStyle}. - }! ! -!StyledTextEditor class methodsFor: 'instance creation' stamp: 'KenD 4/1/2016 13:46'! - open - "Open a new instance on an empty file" -" - StyledTextEditor open. -" - | model | - model _ StyledTextModel new. - ^SystemWindow editFancierStyledText: model label: 'Styled Text Editor'! ! -!StyledTextEditor class methodsFor: 'instance creation' stamp: 'KenD 2/3/2016 16:07'! - openFromFileEntry: fileEntry - | model | - model _ StyledTextModel fromFileNamed: fileEntry pathName. - ^SystemWindow editFancierStyledText: model label: fileEntry name! ! -!StyledTextEditor class methodsFor: 'file reader registration' stamp: 'KenD 2/3/2016 16:07'! - serviceSTEEdit - "Answer the service of opening a file in a STEditor" - - ^ (SimpleServiceEntry - provider: self - label: 'open Styled Text Editor file' - selector: #openFromFileEntry: - description: 'open this file with a Styled Text Editor' - buttonLabel: 'open STE') - argumentGetter: [ :fileList | fileList selectedFileEntry ]! ! -!StyledTextEditor class methodsFor: 'menu-world' stamp: 'KenD 4/1/2016 14:32'! - worldMenuForOpenGroup - ^ Dictionary new - - at: #itemGroup - put: 10; - - at: #itemOrder - put: 10; - - at: #label - put: 'Styled Text Editor'; - - at: #object - put: self; - - at: #selector - put: #open; - - at: #balloonText - put: 'A window for composing Styled text'; - yourself.! ! -!CharacterStyleReference methodsFor: 'comparing' stamp: 'jmv 9/21/2011 11:14'! - = other - ^ (other class == self class) - and: [other style isEquivalentTo: characterStyle]! ! -!CharacterStyleReference methodsFor: 'scanning' stamp: 'jmv 1/25/2011 14:26'! - dominates: other - "See what happens with ParagraphStyleReference, CharacterStyleReference, TextFontReference, TextEmphasis and TextAlignment - So far, no one dominates the other. This means they are all applied. We don't specify an order though. This might need refinement" - ^ other class == self class! ! -!CharacterStyleReference methodsFor: 'iterating' stamp: 'jmv 9/1/2009 15:36'! - forCharacterStyleReferenceDo: aBlock - aBlock value: characterStyle! ! -!CharacterStyleReference methodsFor: 'comparing' stamp: 'jmv 4/11/2011 21:33'! - hash - "Rather cheap. Can be improved." - ^ characterStyle shortDescription hash! ! -!CharacterStyleReference methodsFor: 'testing' stamp: 'jmv 4/11/2011 19:35'! - isStyle - ^true! ! -!CharacterStyleReference methodsFor: 'printing' stamp: 'jmv 4/6/2011 18:12'! - printOn: strm - super printOn: strm. - strm nextPutAll: ': '. - characterStyle shortPrintOn: strm! ! -!CharacterStyleReference methodsFor: 'accessing' stamp: 'jmv 9/21/2011 11:08'! - style - ^characterStyle! ! -!CharacterStyleReference methodsFor: 'accessing' stamp: 'jmv 9/21/2011 11:08'! - style: aCharacterStyle - characterStyle _ aCharacterStyle! ! -!CharacterStyleReference methodsFor: 'rtf exporting' stamp: 'jmv 4/1/2016 13:45'! - writeRTFStartOn: aStream colorTable: colorArray fontTable: fontArray - "Write the RTF code for attribute start. Return number of characters to skip (usually 0)" - - "familyName and pointSize" - characterStyle pointSize ifNotNil: [ :ps | - aStream nextPutAll: '\fs'; nextPutAll: ((ps * Text pointSizeConversionFactor ) rounded * 2) asString; space ]. - - "emphasis" - (characterStyle emphasis allMask: AbstractFont boldCode) ifTrue: [ - aStream nextPutAll: '\b ' ]. - (characterStyle emphasis allMask: AbstractFont italicCode) ifTrue: [ - aStream nextPutAll: '\i ' ]. - (characterStyle emphasis allMask: AbstractFont underlinedCode) ifTrue: [ - aStream nextPutAll: '\ul ' ]. - (characterStyle emphasis allMask: AbstractFont struckThroughCode) ifTrue: [ - aStream nextPutAll: '\strike \strikec0 ' ]. - - "color" - characterStyle color ifNotNil: [ :c | - aStream nextPutAll: '\cf'; nextPutAll: (colorArray indexOf: c) asString; space ]. - - ^0! ! -!CharacterStyleReference methodsFor: 'rtf exporting' stamp: 'jmv 4/1/2016 13:45'! - writeRTFStopOn: aStream colorTable: colorArray fontTable: fontArray - "Write the RTF code for attribute stop. - Do it in the inverse order of writeRTFStartOn:colorTable:fontTable:" - - "kern" - aStream nextPutAll: '\kerning1\expnd0\expndtw0 ' . - - "color" - aStream nextPutAll: '\cf0 '. - - "emphasis" - (characterStyle emphasis allMask: AbstractFont struckThroughCode) ifTrue: [ - aStream nextPutAll: '\strike0\striked0 ' ]. - (characterStyle emphasis allMask: AbstractFont underlinedCode) ifTrue: [ - aStream nextPutAll: '\ulnone ' ]. - (characterStyle emphasis allMask: AbstractFont italicCode) ifTrue: [ - aStream nextPutAll: '\i0 ' ]. - (characterStyle emphasis allMask: AbstractFont boldCode) ifTrue: [ - aStream nextPutAll: '\b0 ' ]. - - "familyName and pointSize" - characterStyle pointSize ifNotNil: [ :ps | - aStream nextPutAll: '\fs0 ' ]! ! -!CharacterStyleReference class methodsFor: 'instance creation' stamp: 'jmv 9/21/2011 11:14'! - for: aCharacterStyle - | attribute | -self assert: aCharacterStyle notNil. - attribute _ self new. - attribute style: aCharacterStyle. - ^attribute! ! -!ParagraphStyleReference methodsFor: 'comparing' stamp: 'jmv 9/21/2011 11:12'! - = other - ^ (other class == self class) - and: [other style isEquivalentTo: paragraphStyle]! ! -!ParagraphStyleReference methodsFor: 'scanning' stamp: 'jmv 11/29/2011 13:50'! - dominates: other - "See what happens with ParagraphStyleReference, CharacterStyleReference, TextFontReference, TextEmphasis and TextAlignment - So far, no one dominates the other. This means they are all applied. We don't specify an order though. This might need refinement" - - "Leave TextAnchors and such alone!!" - other isForFormatting ifFalse: [ ^false ]. - - ^ other class == self class - or: [ - "Any ParagraphStyle precludes the use of regular CharacterAttributes. - This restriction is not usually needed, as the StyledTextEditor doesn't allow the use of regular attributes. - But it was needed to add this, because the 'Smalltalk Code' ParagraphStyle uses shout to decorate text, and this adds regular Attributes - such as color, bold, italic... Later, if we remove that ParagraphStyle (to use a regular one), we need to ensure that all those attributes - are removed" - other isStyle not - or: [ - "A ParahraphStyle that does Shout (auto code formatting) precludes the use of CharacterStyles and other CharacterAttributes" - paragraphStyle doesShout and: [ other isParagraphAttribute not ] ] ]! ! -!ParagraphStyleReference methodsFor: 'iterating' stamp: 'jmv 1/25/2011 13:42'! - forParagraphStyleReferenceDo: aBlock - aBlock value: paragraphStyle! ! -!ParagraphStyleReference methodsFor: 'comparing' stamp: 'jmv 4/11/2011 21:33'! - hash - "Rather cheap. Can be improved." - ^ paragraphStyle shortDescription hash! ! -!ParagraphStyleReference methodsFor: 'testing' stamp: 'jmv 9/1/2009 23:02'! - isParagraphAttribute - "Attributes that answer true will always be applied to whole paragraphs, i.e. starting at the position after a cr (or 1) and ending at a cr (or text size)" - - ^true! ! -!ParagraphStyleReference methodsFor: 'testing' stamp: 'jmv 4/11/2011 19:35'! - isStyle - ^true! ! -!ParagraphStyleReference methodsFor: 'printing' stamp: 'jmv 4/7/2011 17:06'! - printOn: strm - super printOn: strm. - strm nextPutAll: ': ('. - paragraphStyle name printOn: strm. - strm nextPutAll: ') '. - paragraphStyle shortPrintOn: strm! ! -!ParagraphStyleReference methodsFor: 'accessing' stamp: 'jmv 9/21/2011 11:08'! - style - ^paragraphStyle! ! -!ParagraphStyleReference methodsFor: 'accessing' stamp: 'jmv 9/21/2011 11:08'! - style: aParagraphStyle - paragraphStyle _ aParagraphStyle! ! -!ParagraphStyleReference methodsFor: 'rtf exporting' stamp: 'jmv 4/1/2016 13:45'! - writeRTFStartOn: aStream colorTable: colorArray fontTable: fontArray - "Write the RTF code for attribute start. Return number of characters to skip (usually 0)" - "paragraph attributes still missing..." - - | twips k | - - "familyName and pointSize" - paragraphStyle pointSize ifNotNil: [ :ps | - aStream nextPutAll: '\fs'; nextPutAll: ((ps * Text pointSizeConversionFactor ) rounded * 2) asString; space ]. - - "emphasis" - (paragraphStyle emphasis allMask: AbstractFont boldCode) ifTrue: [ - aStream nextPutAll: '\b ' ]. - (paragraphStyle emphasis allMask: AbstractFont italicCode) ifTrue: [ - aStream nextPutAll: '\i ' ]. - (paragraphStyle emphasis allMask: AbstractFont underlinedCode) ifTrue: [ - aStream nextPutAll: '\ul ' ]. - (paragraphStyle emphasis allMask: AbstractFont struckThroughCode) ifTrue: [ - aStream nextPutAll: '\strike \strikec0 ' ]. - - "color" - paragraphStyle color ifNotNil: [ :c | - aStream nextPutAll: '\cf'; nextPutAll: (colorArray indexOf: c) asString; space ]. - - "alignment" - paragraphStyle alignment caseOf: { - [ 0 ] -> [ aStream nextPutAll: '\ql ' ]. - [ 1 ] -> [ aStream nextPutAll: '\qr ' ]. - [ 2 ] -> [ aStream nextPutAll: '\qc ' ]. - [ 3 ] -> [ aStream nextPutAll: '\qj ' ] }. - - "Exportar. Cerrar tambien, y despues, importar!! - tabsArray listBulletPattern - " - - "indent" - k _ 20. - twips _ (paragraphStyle firstIndent-paragraphStyle restIndent) * k. - twips = 0 ifFalse: [ - aStream nextPutAll: '\fi', twips asString; space ]. - twips _ paragraphStyle restIndent * k. - twips = 0 ifFalse: [ - aStream nextPutAll: '\li', twips asString; space ]. - "Have no idea why, but it seems that on paste, an extra inch is added!!" - twips _ (paragraphStyle rightIndent-72) * k. - twips = 0 ifFalse: [ - aStream nextPutAll: '\ri', twips asString; space ]. - - k _ 20. - "paragraph spacing" - twips _ paragraphStyle spaceBefore * k. - twips = 0 ifFalse: [ - aStream nextPutAll: '\sb', twips asString; space ]. - twips _ paragraphStyle spaceAfter * k. - twips = 0 ifFalse: [ - aStream nextPutAll: '\sa', twips asString; space ]. - - ^0! ! -!ParagraphStyleReference methodsFor: 'rtf exporting' stamp: 'jmv 4/1/2016 13:45'! - writeRTFStopOn: aStream colorTable: colorArray fontTable: fontArray - "Write the RTF code for attribute stop. - Do it in the inverse order of writeRTFStartOn:colorTable:fontTable:" - - "alignment" - aStream nextPutAll: '\ql '. - - "kern" - aStream nextPutAll: '\kerning1\expnd0\expndtw0 ' . - - "color" - aStream nextPutAll: '\cf0 '. - - "emphasis" - (paragraphStyle emphasis allMask: AbstractFont struckThroughCode) ifTrue: [ - aStream nextPutAll: '\strike0\striked0 ' ]. - (paragraphStyle emphasis allMask: AbstractFont underlinedCode) ifTrue: [ - aStream nextPutAll: '\ulnone ' ]. - (paragraphStyle emphasis allMask: AbstractFont italicCode) ifTrue: [ - aStream nextPutAll: '\i0 ' ]. - (paragraphStyle emphasis allMask: AbstractFont boldCode) ifTrue: [ - aStream nextPutAll: '\b0 ' ]. - - "familyName and pointSize" - paragraphStyle pointSize ifNotNil: [ :ps | - aStream nextPutAll: '\fs0 ' ]. - - "paragraph defaults (i.e. paragraph end). Needed to honor spaceBefore and spaceAfter" - aStream nextPutAll: '\pard '! ! -!ParagraphStyleReference class methodsFor: 'instance creation' stamp: 'jmv 9/21/2011 11:09'! - for: aParagraphStyle - | attribute | -self assert: aParagraphStyle notNil. - attribute _ self new. - attribute style: aParagraphStyle. - ^attribute! ! -!FancyDraggeableButtonMorph methodsFor: 'drawing' stamp: 'jmv 4/12/2012 22:14'! - drawOn: aCanvas - - self drawSTELookOn: aCanvas! ! -!FancyDraggeableButtonMorph methodsFor: 'drawing' stamp: 'jmv 2/14/2013 13:16'! - drawSTELookOn: aCanvas - - aCanvas - roundRect: (((0@0 extent: extent) insetBy: (owner morphBoundsInWorld isWide ifTrue: [0@4] ifFalse: [4@0])) ) - color: (Color black) - radius: 4. - aCanvas - roundRect: (((-1@0 extent: extent) insetBy: (owner morphBoundsInWorld isWide ifTrue: [0@4] ifFalse: [5@0 corner: 4@0])) ) - color: (self isPressed ifTrue: [Color red] ifFalse: [Color gray: 0.86]) - radius: 4.! ! -!FancyDraggeableButtonMorph methodsFor: 'drawing' stamp: 'jmv 4/12/2012 22:37'! - iconColor - - ^ self isPressed - ifTrue: [ Color red ] - ifFalse: [ - self mouseIsOver - ifTrue: [ Color gray: 0.75 ] - ifFalse: [ Color white ]].! ! -!FancyButtonMorph methodsFor: 'drawing' stamp: 'jmv 8/4/2014 08:39'! - drawOn: aCanvas - - self isRoundButton - ifTrue: [ - aCanvas drawButtonIconFromCurrentMorph ifFalse: [ - self drawRoundGradientLookOn: aCanvas ]] - ifFalse: [ - self drawSTELookOn: aCanvas. - aCanvas drawButtonIconFromCurrentMorph ]! ! -!FancyButtonMorph methodsFor: 'drawing' stamp: 'jmv 11/30/2014 18:51'! - drawSTELookOn: aCanvas - - aCanvas image: (BitBltCanvas steButtonForm: extent) at:0@0! ! -!FancyButtonMorph methodsFor: 'drawing' stamp: 'jmv 4/12/2012 22:37'! - iconColor - - ^ self isPressed - ifTrue: [ Color red ] - ifFalse: [ - self mouseIsOver - ifTrue: [ Color gray: 0.75 ] - ifFalse: [ Color white ]].! ! -!FancyButtonMorph methodsFor: 'scrollbar button' stamp: 'KenD 12/4/2015 21:19'! - updateDownButtonImage - "update the receiver's as a downButton. put a new image inside" - - icon _ BitBltCanvas buildArrowOfDirection: #down size: ScrollBar scrollbarThickness. - "##FIXME@@ arrowWithGradientOfDirection: #down." - actionSelector _ #scrollDown. - self - roundButtonStyle: false; - redrawNeeded! ! -!FancyButtonMorph methodsFor: 'scrollbar button' stamp: 'KenD 12/4/2015 21:16'! - updateLeftButtonImage - "update the receiver's as a downButton. put a new image inside" - - icon _ BitBltCanvas buildArrowOfDirection: #left size: ScrollBar scrollbarThickness. - "@@FIXME@@ arrowWithGradientOfDirection: #left." - actionSelector _ #scrollUp. - self - roundButtonStyle: false; - redrawNeeded! ! -!FancyButtonMorph methodsFor: 'scrollbar button' stamp: 'KenD 12/4/2015 21:20'! - updateRightButtonImage - "update the receiver's as a downButton. put a new image inside" - - icon _ BitBltCanvas buildArrowOfDirection: #right size: ScrollBar scrollbarThickness. - - "##FIXME@@ arrowWithGradientOfDirection: #right." - actionSelector _ #scrollDown. - self - roundButtonStyle: false; - redrawNeeded! ! -!FancyButtonMorph methodsFor: 'scrollbar button' stamp: 'KenD 12/4/2015 21:18'! - updateUpButtonImage - "update the receiver's as a upButton. put a new image inside" - - icon _ BitBltCanvas buildArrowOfDirection: #up size: ScrollBar scrollbarThickness.. - "@@FIXME@@ arrowWithGradientOfDirection: #up" - actionSelector _ #scrollUp. - self - roundButtonStyle: false; - redrawNeeded! ! -!PluggableActOnReturnKeyListMorph methodsFor: 'model access' stamp: 'jmv 3/13/2012 10:57'! - changeModelSelection: anInteger - "On regular PluggableListMorphs this method is called when a selection is made. - But we don't want to update the model when the arrow keys are pressed, we'll wait for - However we do act immediately on mouse click. - - Just store the current index." - currentIndex _ anInteger. - self selectionIndex: currentIndex! ! -!PluggableActOnReturnKeyListMorph methodsFor: 'geometry' stamp: 'jmv 4/14/2013 22:00'! - clippingRect - "Return the bounds to which any submorphs should be clipped if the property is set" - "Should be a region, like our shadow" - | r | - r _ super clippingRect. - ^r origin extent: r extent - 4! ! -!PluggableActOnReturnKeyListMorph methodsFor: 'drawing' stamp: 'jmv 2/25/2013 15:18'! - drawOn: aCanvas - "We draw our shadow outside our strict bounds..." - - aCanvas - roundRect: (4@4 extent: extent-4) - color: (Color black alpha: 0.13) - radius: 4. - aCanvas - roundRect: (0@0 extent: extent-4) - color: (Color gray: 0.4) - radius: 4. - aCanvas - roundRect: (1@1 extent: extent-2-4) - color: (Color white) - radius: 4! ! -!PluggableActOnReturnKeyListMorph methodsFor: 'model access' stamp: 'jmv 3/13/2012 10:10'! - getCurrentSelectionIndex - ^currentIndex ifNil: [ super getCurrentSelectionIndex ]! ! -!PluggableActOnReturnKeyListMorph methodsFor: 'events' stamp: 'jmv 12/27/2012 15:02'! - keyStroke: event - - event isReturnKey ifTrue: [ - self returnPressed. - ^self ]. - super keyStroke: event. - - "We know our model is a PluggableDropDownListMorph" - model keyStrokeInList: event! ! -!PluggableActOnReturnKeyListMorph methodsFor: 'events' stamp: 'jmv 2/14/2013 12:46'! - mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition - "Do update model right away" - super mouseButton1Up: aMouseButtonEvent localPosition: localEventPosition. - self realChangeModelSelection! ! -!PluggableActOnReturnKeyListMorph methodsFor: 'events' stamp: 'jmv 12/27/2012 15:02'! - mouseLeave: evt - "We know our model is a PluggableDropDownListMorph" - model mouseLeaveList: evt! ! -!PluggableActOnReturnKeyListMorph methodsFor: 'model access' stamp: 'jmv 3/13/2012 10:10'! - realChangeModelSelection - "Change the model's selected item index to be anInteger." - setIndexSelector ifNotNil: [ - model - perform: setIndexSelector - with: currentIndex ]. - currentIndex _ nil! ! -!PluggableActOnReturnKeyListMorph methodsFor: 'events' stamp: 'jmv 3/13/2012 10:10'! - returnPressed - currentIndex - ifNotNil: [ self realChangeModelSelection ] - ifNil: [ self delete ]! ! -!PluggableActOnReturnKeyListMorph methodsFor: 'initialization' stamp: 'jmv 4/12/2012 22:05'! - scrollBarClass - ^FancyScrollBar! ! -!PluggableActOnReturnKeyListMorph methodsFor: 'geometry' stamp: 'jmv 2/25/2013 15:19'! - updateScrollBarsBounds - - | t | - hideScrollBars ifTrue: [^self]. - t _ self scrollBarClass scrollbarThickness. - scrollBar - morphPosition: extent x - t - borderWidth - 4 @ borderWidth; - morphExtent: t @ (self vScrollBarHeight-4). - hScrollBar - morphPosition: borderWidth @ (extent y - t - borderWidth - 4); - morphExtent: self hScrollBarWidth - 4@t! ! -!PluggableActOnReturnKeyListMorph methodsFor: 'updating' stamp: 'jmv 3/13/2012 10:10'! - verifyContents - super verifyContents. - "ok???" - self selectionIndex = 0 ifTrue: [ - self changeModelSelection: 1 ]! ! -!PluggableActOnReturnKeyListMorph methodsFor: 'geometry' stamp: 'jmv 2/25/2013 15:26'! - viewableExtent - - ^self focusIndicatorExtent - (self xtraBorder * 2) - 4! ! -!PluggableStyledTextMorph methodsFor: 'services' stamp: 'jmv 8/3/2011 17:04'! - characterStyleNamesAndShortcuts - ^model styleSet characterStyleNamesAndShortcuts! ! -!PluggableStyledTextMorph methodsFor: 'services' stamp: 'jmv 11/16/2011 17:12'! - currentCharacterStyleIndex - | cs | - cs _ self textMorph editor currentCharacterStyleOrNil. - cs ifNil: [ ^0 ]. - ^(model styleSet characterStyleIndexOf: cs)! ! -!PluggableStyledTextMorph methodsFor: 'services' stamp: 'jmv 10/16/2013 19:54'! - currentCharacterStyleIndex: index - "This is a user command, and generates undo" - (model styleSet characterStyleAt: index) - ifNil: [ - self textMorph editor removeCharacterStyles ] - ifNotNil: [ :style | - style isNullStyle - ifTrue: [ self textMorph editor removeCharacterStyles ] - ifFalse: [ self textMorph editor applyAttribute: (CharacterStyleReference for: style) ]]. - self textMorph updateFromTextComposition! ! -!PluggableStyledTextMorph methodsFor: 'services' stamp: 'jmv 11/16/2011 17:12'! - currentParagraphStyleIndex - ^model styleSet paragraphStyleIndexOf: self textMorph editor currentParagraphStyle! ! -!PluggableStyledTextMorph methodsFor: 'services' stamp: 'jmv 10/16/2013 19:54'! - currentParagraphStyleIndex: index - "This is a user command, and generates undo" - | style | - style _ model styleSet paragraphStyleAt: index. - self textMorph editor applyAttribute: (ParagraphStyleReference for: style). - self textMorph updateFromTextComposition! ! -!PluggableStyledTextMorph methodsFor: 'services' stamp: 'jmv 8/3/2011 17:03'! - paragraphStyleNamesAndShortcuts - ^model styleSet paragraphStyleNamesAndShortcuts! ! -!PluggableStyledTextMorph methodsFor: 'notifications' stamp: 'jmv 9/18/2009 14:06'! - possiblyChanged - self triggerEvent: #possiblyChanged! ! -!PluggableStyledTextMorph methodsFor: 'initialization' stamp: 'jmv 4/12/2012 22:06'! - scrollBarClass - ^FancyScrollBar! ! -!PluggableStyledTextMorph class methodsFor: 'menu-world' stamp: 'jmv 2/20/2016 18:40'! - openBasicStyledTextEditor - - SystemWindow editStyledText: StyledTextModel new label: 'Styled Text Editor'! ! -!PluggableStyledTextMorph class methodsFor: 'menu-world' stamp: 'jmv 2/20/2016 18:38'! - openFancierStyledTextEditor - - SystemWindow editFancierStyledText: StyledTextModel new label: 'Styled Text Editor'! ! -!PluggableStyledTextMorph class methodsFor: 'class initialization' stamp: 'jmv 8/13/2013 12:24'! - withModel: aStyledTextModel in: aLayoutMorph - | topRow paragraphStyleList characterStyleList textMorph m topRowHeight labelFont topRowElementsWidth | - textMorph _ self withModel: aStyledTextModel. - textMorph - borderWidth: 0; - drawKeyboardFocusIndicator: false; - wrapFlag: true. - aLayoutMorph separation: 0. - topRow _ ToolbarMorph newRow separation: 10@4. - - topRowHeight _ 32. - topRow - color: (Form - verticalGradient: topRowHeight - topColor: (Color r: 189 g: 214 b: 199 range: 255) - bottomColor: (Color r: 115 g: 134 b: 125 range: 255)).. -" borderWidth: topRowBorderWidth;" -" borderColor: (Color r: 80 g: 80 b: 80 range: 255)." - - labelFont _ AbstractFont familyName: 'DejaVu' aroundPointSize: 10. - m _ StringMorph contents: 'Paragraph Style'. - m font: labelFont emphasis: 1; color: Color white. - topRowElementsWidth _ m morphWidth. - topRow - addMorph: m - layoutSpec: (((LayoutSpec morphHeightFixedWidth: topRowElementsWidth) minorDirectionPadding: #center) minorDirectionPadding: #center). - paragraphStyleList _ PluggableFilteringDropDownListMorph - model: textMorph - listGetter: #paragraphStyleNamesAndShortcuts - indexGetter: #currentParagraphStyleIndex - indexSetter: #currentParagraphStyleIndex:. - paragraphStyleList borderWidth: 0"; height: ddlHeight". - topRow - addMorph: paragraphStyleList - layoutSpec: (((LayoutSpec morphHeightFixedWidth: topRowElementsWidth+50) minorDirectionPadding: #center) minorDirectionPadding: #center). - textMorph when: #possiblyChanged send: #modelChanged to: paragraphStyleList. - - m _ RectangleLikeMorph new. - m color: Color transparent. - topRow addMorph: m layoutSpec: (LayoutSpec fixedWidth: 8). - - m _ StringMorph contents: 'Character Style'. - m font: labelFont emphasis: 1; color: Color white. - topRow - addMorph: m - layoutSpec: (((LayoutSpec morphHeightFixedWidth: topRowElementsWidth) minorDirectionPadding: #center) minorDirectionPadding: #center). - characterStyleList _ PluggableFilteringDropDownListMorph - model:textMorph - listGetter: #characterStyleNamesAndShortcuts - indexGetter: #currentCharacterStyleIndex - indexSetter: #currentCharacterStyleIndex:. - characterStyleList borderWidth: 0"; height: ddlHeight". - topRow - addMorph: characterStyleList - layoutSpec: (((LayoutSpec morphHeightFixedWidth: topRowElementsWidth+50) minorDirectionPadding: #center) minorDirectionPadding: #center). - textMorph when: #possiblyChanged send: #modelChanged to: characterStyleList. - - aLayoutMorph - addMorph: topRow layoutSpec: (LayoutSpec fixedHeight: topRowHeight); - addMorph: textMorph layoutSpec: (LayoutSpec new). - - ^aLayoutMorph! ! -!PluggableStyledTextMorph class methodsFor: 'menu-world' stamp: 'jmv 2/20/2016 18:38'! - worldMenu: aMenu menuGroup: aGroupSymbol - ^ aGroupSymbol = #worldOpenMenu ifTrue: [ - Dictionary new - - at: #itemGroup - put: 10; - - at: #itemOrder - put: 5; - - at: #label - put: 'Styled Text Editor'; - - at: #object - put: self; - - at: #selector - put: #openFancierStyledTextEditor; - - at: #balloonText - put: 'A window for composing styled text'; - yourself ].! ! -!FancyScrollBar methodsFor: 'initialization' stamp: 'jmv 4/12/2012 22:12'! - buttonClass - ^FancyButtonMorph! ! -!FancyScrollBar methodsFor: 'drawing' stamp: 'jmv 2/14/2013 13:19'! - drawOn: aCanvas - - aCanvas - roundRect: (0@0 extent: extent) - color: (Color gray: 0.4) - radius: 4. - aCanvas - roundRect: (1@1 extent: extent-2) - color: (Color gray: 0.95) - radius: 4! ! -!FancyScrollBar methodsFor: 'initialization' stamp: 'jmv 4/12/2012 22:23'! - sliderClass - ^FancyDraggeableButtonMorph! ! -!FancyScrollBar methodsFor: 'scrolling' stamp: 'jmv 3/5/2013 08:20'! - sliderGrabbedAt: handPositionRelativeToSlider - - grabPosition _ handPositionRelativeToSlider. - sliderShadow - morphBoundsInWorld: (slider morphBoundsInWorld insetBy: (extent x > extent y ifTrue: [0@3] ifFalse: [3@0])); - show! ! -!FancyScrollBar class methodsFor: 'constants' stamp: 'jmv 8/13/2013 12:29'! - scrollbarThickness - - ^super scrollbarThickness + 11! ! -!PluggableDropDownListMorph methodsFor: 'private' stamp: 'jmv 2/25/2013 15:21'! - basicOpenList - | xtraWidth xtraHeight bounds | - bounds _ self morphBoundsInWorld. - listMorph _ PluggableActOnReturnKeyListMorph - model: self - listGetter: #getList - indexGetter: #getIndex - indexSetter: #setIndex:. - listMorph - color: Color white; - morphWidth: self morphWidth; - morphHeight: 4; - borderWidth: 1; - borderColor: (Color black alpha: 0.3); - morphPosition: bounds bottomLeft; - autoDeselect: false. - self world addMorph: listMorph. - listMorph updateList. - xtraWidth _ listMorph hLeftoverScrollRange + 4. - xtraWidth > 0 ifTrue: [ - listMorph morphWidth: listMorph morphWidth + xtraWidth ]. - xtraHeight _ listMorph vLeftoverScrollRange + 4. - xtraHeight > 0 ifTrue: [ - listMorph morphHeight: (listMorph morphHeight + xtraHeight min: 100) ]! ! -!PluggableDropDownListMorph methodsFor: 'private' stamp: 'jmv 9/10/2010 15:31'! - closeList - listMorph ifNotNil: [ - listMorph delete. - listMorph _ nil ]! ! -!PluggableDropDownListMorph methodsFor: 'drawing' stamp: 'jmv 2/14/2013 13:29'! - drawBasicLookOn: aCanvas - - aCanvas - fillRectangle: (0@0 extent: extent) - color: color - borderWidth: borderWidth - borderStyleSymbol: #simple - baseColorForBorder: borderColor. - self drawLabelOn: aCanvas ! ! -!PluggableDropDownListMorph methodsFor: 'drawing' stamp: 'jmv 2/14/2013 13:33'! - drawLabelOn: aCanvas - - | f | - f _ Preferences standardButtonFont. - aCanvas drawString: label at: 0@(extent y // 2) + (8@ f height negated // 2) font: f color: Color black! ! -!PluggableDropDownListMorph methodsFor: 'drawing' stamp: 'jmv 4/12/2012 22:19'! - drawOn: aCanvas - - "Theme current steButtons" - true - ifTrue: [ self drawSTELookOn: aCanvas ] - ifFalse: [ self drawBasicLookOn: aCanvas ]! ! -!PluggableDropDownListMorph methodsFor: 'drawing' stamp: 'jmv 2/14/2013 13:31'! - drawSTELookOn: aCanvas - | gh | -"sin gradiente el borde!!" - gh _ extent y-8 max: extent y//2. - aCanvas - roundRect: (0@0 extent: extent) - color: (Color gray: 0.4) - radius: 4 - gradientTop: 0.9 - gradientBottom: 0.6 - gradientHeight: gh. - aCanvas - roundRect: (1@1 extent: extent-2) - color: (Color gray: 0.95) - radius: 4 - gradientTop: 0.99 - gradientBottom: 0.96 - gradientHeight: gh. - self drawLabelOn: aCanvas ! ! -!PluggableDropDownListMorph methodsFor: 'model' stamp: 'jmv 9/9/2010 15:12'! - getIndex - ^model ifNil: [ 0 ] ifNotNil: [ model perform: getIndexSelector ]! ! -!PluggableDropDownListMorph methodsFor: 'accessing' stamp: 'jmv 4/6/2011 19:03'! -getLabel - | i | - i _ self getIndex. - label _ i = 0 - ifTrue: [ '-none-' ] - ifFalse: [ self getList at: i ].! ! -!PluggableDropDownListMorph methodsFor: 'model' stamp: 'jmv 9/16/2009 13:45'! - getList - ^model perform: getListSelector! ! -!PluggableDropDownListMorph methodsFor: 'testing' stamp: 'jmv 9/9/2010 14:25'! - handlesMouseDown: evt - "So our #mouseDown: method is called" - ^ true! ! -!PluggableDropDownListMorph methodsFor: 'testing' stamp: 'jmv 9/9/2010 14:25'! - handlesMouseOver: anEvent - "So our #mouseLeave: method is called" - ^ true! ! -!PluggableDropDownListMorph methodsFor: 'initialization' stamp: 'KenD 12/4/2015 21:21'! - initialize - | icon | - super initialize. - self color: Color white. - self borderColor: Color black. - self getLabel. -" self extent: 120 @ 20." - icon _ "Theme current steButtons" true - ifFalse: [ BitBltCanvas arrowOfDirection: #down size: ScrollBar scrollbarThickness ] - ifTrue: [ BitBltCanvas buildArrowOfDirection: #down size: ScrollBar scrollbarThickness]. - "@@FIXME@@ arrowWithGradientOfDirection: #down" - downButton _ FancyButtonMorph new. - downButton - model: self; - roundButtonStyle: false; - icon: icon; - actWhen: #buttonDown; - action: #openOrCloseList. - self addMorph: downButton.! ! -!PluggableDropDownListMorph methodsFor: 'testing' stamp: 'jmv 1/27/2011 16:11'! - isListOpen - ^ listMorph notNil! ! -!PluggableDropDownListMorph methodsFor: 'accessing' stamp: 'jmv 9/10/2010 08:37'! - label - ^ label! ! -!PluggableDropDownListMorph methodsFor: 'layout' stamp: 'jmv 12/20/2012 12:57'! - layoutSubmorphs - | e innerBounds | - "innerBounds _ self innerBounds". - innerBounds _ self morphBoundsInWorld insetBy: borderWidth. - e _ innerBounds height. - downButton morphBoundsInWorld: (innerBounds bottomRight - e extent: e)! ! -!PluggableDropDownListMorph methodsFor: 'initialization' stamp: 'jmv 9/16/2009 11:29'! - model: anObject listGetter: getListSel indexGetter: getSelectionSel indexSetter: setSelectionSel - - self model: anObject. - getListSelector _ getListSel. - getIndexSelector _ getSelectionSel. - setIndexSelector _ setSelectionSel.! ! -!PluggableDropDownListMorph methodsFor: 'model' stamp: 'jmv 6/3/2011 14:43'! - modelChanged - self getLabel. - self changed: self! ! -!PluggableDropDownListMorph methodsFor: 'events' stamp: 'jmv 12/20/2012 13:24'! - mouseLeave: evt - super mouseLeave: evt. - (listMorph isNil or: [ (listMorph morphBoundsInWorld containsPoint: evt eventPosition) not]) - ifTrue: [ - "Do the call even if the list is not there, as this also clears selection in subclass with entry field" - self closeList ]! ! -!PluggableDropDownListMorph methodsFor: 'events' stamp: 'jmv 12/27/2012 15:02'! - mouseLeaveList: evt - (self morphBoundsInWorld containsPoint: evt eventPosition) - ifFalse: [ self closeList ]! ! -!PluggableDropDownListMorph methodsFor: 'private' stamp: 'jmv 2/14/2013 12:41'! - openList - self basicOpenList. - self world activeHand newKeyboardFocus: listMorph! ! -!PluggableDropDownListMorph methodsFor: 'private' stamp: 'jmv 8/16/2010 16:01'! - openOrCloseList - self isListOpen - ifFalse: [ self openList ] - ifTrue: [ self closeList ]! ! -!PluggableDropDownListMorph methodsFor: 'events' stamp: 'jmv 6/3/2011 14:44'! - setIndex: index - model perform: setIndexSelector with: index. - "self changed: #getIndex." "No chance to actually see it, it is closed too quickly" - self getLabel. - self changed: self. - self closeList! ! -!PluggableDropDownListMorph class methodsFor: 'instance creation' stamp: 'jmv 9/16/2009 11:30'! - model: anObject listGetter: getListSel indexGetter: getSelectionSel indexSetter: setSelectionSel - - ^self new - model: anObject - listGetter: getListSel - indexGetter: getSelectionSel - indexSetter: setSelectionSel! ! -!PluggableFilteringDropDownListMorph methodsFor: 'private' stamp: 'jmv 12/20/2012 13:22'! - closeList - "Also clear the selection in the entry field" - (listMorph notNil and: [ listMorph hasKeyboardFocus ]) ifTrue: [ - self world activeHand newKeyboardFocus: editorMorph ]. - super closeList! ! -!PluggableFilteringDropDownListMorph methodsFor: 'drawing' stamp: 'jmv 9/10/2010 08:57'! - drawLabelOn: aCanvas - "Not needed. Our label is a submorph"! ! -!PluggableFilteringDropDownListMorph methodsFor: 'events' stamp: 'jmv 12/20/2010 15:00'! - editorClass - ^TextEditor! ! -!PluggableFilteringDropDownListMorph methodsFor: 'accessing' stamp: 'jmv 7/5/2011 09:02'! - filter - ^editorMorph contents withBlanksTrimmed! ! -!PluggableFilteringDropDownListMorph methodsFor: 'filtering' stamp: 'jmv 9/10/2010 15:56'! - filter: entry with: filter - - ^filter, '*' match: entry! ! -!PluggableFilteringDropDownListMorph methodsFor: 'model' stamp: 'jmv 4/6/2011 19:03'! - getIndex - "answer the index in the filtered list" - | i filter | - i _ super getIndex. - i = 0 ifFalse: [ - filter _ self filter. - (filter notEmpty and: [ filter ~= '-none-' ]) ifTrue: [ - i _ self getList indexOf: ((model perform: getListSelector) at: i) ]]. - ^i! ! -!PluggableFilteringDropDownListMorph methodsFor: 'accessing' stamp: 'jmv 3/16/2011 17:28'! - getLabel - super getLabel. - editorMorph ifNotNil: [ editorMorph contents: label ]! ! -!PluggableFilteringDropDownListMorph methodsFor: 'model' stamp: 'jmv 8/10/2011 15:17'! - getList - | answer filter | - answer _ super getList. - filter _ self filter. - (filter notEmpty and: [ filter ~= '-none-' ]) ifTrue: [ | filtered | - filtered _ (answer select: [ :str | self filter: str with: filter ]). - (filtered includes: filter) ifFalse: [ - answer _ filtered ]]. - ^answer! ! -!PluggableFilteringDropDownListMorph methodsFor: 'initialization' stamp: 'jmv 12/27/2012 15:06'! - initialize - | labelFont | - super initialize. - labelFont _ AbstractFont familyName: 'DejaVu' aroundPointSize: 10. - editorMorph _ FilteringDDLEditorMorph contents: self label font: labelFont emphasis: 1. - editorMorph keyboardFocusWatcher: self. - self addMorph: editorMorph! ! -!PluggableFilteringDropDownListMorph methodsFor: 'events' stamp: 'jmv 3/13/2012 10:41'! - keyStrokeInList: aKeyboardEvent - "Send to the text anything but Up, Down, Return and Escape" - (aKeyboardEvent isReturnKey or: [ - (#(27 30 31) includes: aKeyboardEvent keyValue)]) ifFalse: [ - editorMorph keyStroke: aKeyboardEvent ]! ! -!PluggableFilteringDropDownListMorph methodsFor: 'events' stamp: 'jmv 3/13/2012 10:59'! - keyStrokeInText: aKeyboardEvent - - "Handle Return and Escape separatedly" - aKeyboardEvent isReturnKey ifTrue: [ ^self returnInEditor ]. - aKeyboardEvent keyValue = 27 ifTrue: [ ^self closeList ]. - - "Send to the list only Up and Down," - self shouldOpenList - ifTrue: [ self basicOpenList ] - ifFalse: [ - self shouldCloseList ifTrue: [ self closeList ]]. - listMorph ifNotNil: [ - (#(30 31 ) includes: aKeyboardEvent keyValue) - ifTrue: [ listMorph keyStroke: aKeyboardEvent ]. - listMorph verifyContents ]! ! -!PluggableFilteringDropDownListMorph methodsFor: 'layout' stamp: 'jmv 12/20/2012 13:11'! - layoutSubmorphs - | b innerBounds | - super layoutSubmorphs. - "innerBounds _ self innerBounds". - innerBounds _ self morphBoundsInWorld insetBy: borderWidth. - b _ innerBounds insetBy: 8@4. - editorMorph morphBoundsInWorld: (b topLeft extent: b extent - (downButton morphWidth@0))! ! -!PluggableFilteringDropDownListMorph methodsFor: 'events' stamp: 'jmv 12/29/2011 14:50'! - lostFocus: aMorph - (self isListOpen and: [ listMorph hasKeyboardFocus not ]) ifTrue: [ - self closeList ]! ! -!PluggableFilteringDropDownListMorph methodsFor: 'private' stamp: 'jmv 11/4/2010 15:42'! - openList - - super openList. - editorMorph selectAll! ! -!PluggableFilteringDropDownListMorph methodsFor: 'model' stamp: 'jmv 3/13/2012 10:26'! - returnInEditor - | filter all selected | - self isListOpen ifTrue: [ - ^ listMorph returnPressed ]. - - filter _ self filter. - filter isEmpty ifTrue: [ ^ self ]. - all _ model perform: getListSelector. - selected _ all - detect: [ :any | self filter: any with: filter ] - ifNone: [ ^ self ]. - ^ super setIndex: (super getList indexOf: selected)! ! -!PluggableFilteringDropDownListMorph methodsFor: 'model' stamp: 'jmv 3/16/2011 09:10'! - setIndex: index - | i filter | - i _ index. - filter _ self filter. - filter notEmpty ifTrue: [ - i _ (model perform: getListSelector) indexOf: ( self getList at: i ) ]. - super setIndex: i! ! -!PluggableFilteringDropDownListMorph methodsFor: 'events' stamp: 'jmv 3/16/2011 09:27'! - shouldCloseList - "True if no matches to show, or if there is no typed text" - ^self isListOpen and: [ - "Filter empty does not mean we shouldn't show the list. Show it without filtering!!" - "self filter isEmpty or: [ " - self getList isEmpty - "]" - ]! ! -!PluggableFilteringDropDownListMorph methodsFor: 'events' stamp: 'jmv 3/16/2011 09:24'! - shouldOpenList - "True if list not open, but it makes sense to show it, because there is more than one entry that matches the typed text. " - ^self isListOpen not and: [ - "Open full list if filter empty. Why not???" - "self filter notEmpty and: [ " - self getList notEmpty " - ]" - ]! ! -!ToolbarMorph methodsFor: 'hacks' stamp: 'jmv 8/4/2014 08:37'! - adoptWidgetsColor: paneColor - "We hold a Form in the color instance variable..."! ! -!ToolbarMorph methodsFor: 'drawing' stamp: 'jmv 4/12/2013 20:23'! - drawOn: aCanvas - aCanvas - fillRectangle: (0@0 extent: self morphExtent) - tilingWith: color - sourceRect: color boundingBox - rule: Form paint! ! -!STEMainMorph methodsFor: 'stepping' stamp: 'jmv 2/27/2016 20:07'! - stepAt: millisecondSinceLast - - "My dimensions are constrained live." - " - | r | - (owner notNil and: [ owner isWorldMorph ]) ifTrue: [ - r _ owner morphBoundsInWorld. - self morphBoundsInWorld = r ifFalse: [ - self morphBoundsInWorld: r ]] - " - "My dimensions are constrained live." - (owner notNil and: [ owner isWorldMorph ]) ifTrue: [ - self morphExtent: (self internalize: owner morphExtent). - self morphPosition: 0@0 ]! ! -!STEMainMorph methodsFor: 'stepping' stamp: 'jmv 5/24/2011 09:04'! - stepTime - ^ 0 "every cycle"! ! -!FilteringDDLEditorMorph methodsFor: 'events' stamp: 'jmv 11/3/2016 11:42:30'! - keyStroke: aKeyboardEvent - "Handle a keystroke event." - - (self focusKeyboardFor: aKeyboardEvent) - ifTrue: [ ^ self ]. - - super keyStroke: aKeyboardEvent. - - "We know that our owner is a PluggableFilteringDropDownListMorph" - owner keyStrokeInText: aKeyboardEvent! ! -!STETheme methodsFor: 'colors' stamp: 'bp 4/22/2012 10:51'! - textHighlight - " - ^ Color r: 0.71 g: 0.835 b: 1.0 - ^ Color hue: 214 chroma: 0.29 luminance: 0.816 - " - ^Color r: 204 g: 235 b: 214 range: 255! ! -!STETheme methodsFor: 'colors' stamp: 'jmv 12/30/2011 11:42'! - unfocusedTextHighlightFrom: aColor - ^Color r: 218 g: 228 b: 228 range: 255! ! -!StyledTextEditorTest methodsFor: 'tests' stamp: 'jmv 2/14/2013 12:29'! - testClickAndHalf - " - StyledTextEditorTest new testClickAndHalf - " - | hand ev morph textModelMorph | - hand _ HandMorph new. - ev _ MouseButtonEvent new - setType: #mouseDown - position: 10@10 - which: 4 - buttons: 4 - hand: hand - stamp: nil. - textModelMorph _ TextModelMorph withModel: (StyledTextModel new contents: ''). - textModelMorph openInWorld: PasteUpMorph someInstance. - morph _ textModelMorph textMorph. - morph world activeHand newKeyboardFocus: morph. - morph mouseButton1Down: ev localPosition: 10@10. - self assert: ((hand instVarNamed: 'mouseClickState') instVarNamed: 'clickAndHalfSelector') notNil description: 'Click-n-half should be handled'. - textModelMorph delete! ! -!StyledTextEditorTest methodsFor: 'tests' stamp: 'jmv 2/14/2013 12:29'! - testClickAndHalfSelection - " - StyledTextEditorTest new testClickAndHalfSelection - " - | morph model style text hand point1 | - model _ StyledTextModel new. - style _ model styleSet paragraphStyleNamed: 'Normal'. - text _ Text string: 'This is a test.' attribute: (ParagraphStyleReference for: style). - model contents: text. - morph _ (PluggableStyledTextMorph withModel: model) openInWorld: PasteUpMorph someInstance. - morph world activeHand newKeyboardFocus: morph textMorph. - - point1 _ 60@20. - hand _ HandMorph new. - morph mouseButton1Down: - (MouseButtonEvent new - setType: #mouseDown position: point1 - which: 4 buttons: 4 hand: hand stamp: nil) - localPosition: point1. - morph mouseButton1Up: - (MouseButtonEvent new - setType: #mouseUp position: point1 - which: 4 buttons: 4 hand: hand stamp: nil) - localPosition: point1. - morph textMorph clickAndHalf: - (MouseButtonEvent new - setType: nil position: point1 - which: 4 buttons: 4 hand: hand stamp: nil) - localPosition: point1. - self assert: morph editor selectionInterval = (1 to: 4) description: 'Click-n-half does not set selection properly.'. - morph delete! ! -!StyledTextEditorTest methodsFor: 'tests' stamp: 'jmv 2/14/2013 12:44'! - testDropDownKeyboardNavigation - " - StyledTextEditorTest new testDropDownKeyboardNavigation - " - | model style text window editorMorph listMorph | - model _ StyledTextModel new. - style _ model styleSet paragraphStyleNamed: 'Normal'. - text _ Text string: 'x' attribute: (ParagraphStyleReference for: style). - model contents: text. - window _ SystemWindow editFancierStyledText: model label: 'Styled Text Editor'. - window world ifNil: [ window openInWorld: PasteUpMorph someInstance ]. - editorMorph _ window findDeepSubmorphThat: [:m | m class = PluggableStyledTextMorph ] ifAbsent: nil. - editorMorph _ editorMorph textMorph. - listMorph _ window - findDeepSubmorphThat: [ :any | - any class = PluggableFilteringDropDownListMorph and: [ - (any instVarNamed: 'getListSelector') = #paragraphStyleNamesAndShortcuts ]] - ifAbsent: nil. - listMorph openOrCloseList. - (listMorph instVarNamed: 'editorMorph') contents: 'Norm'. - self shouldnt: [ (listMorph instVarNamed: 'listMorph') verifyContents ] raise: MessageNotUnderstood. - listMorph openOrCloseList. - - window delete! ! -!StyledTextEditorTest methodsFor: 'tests' stamp: 'jmv 4/2/2016 14:47'! - testEmpasizeScanner - "Create a few instances of styled text (i.e. Text using various styles) - and assert their properties - StyledTextEditorTest new testEmpasizeScanner - " - - | model style unstyled heading1 composition canvas scanner - boundsInWorld leftInRun line | - unstyled _ Text string: 'Non-styled part. should use no paragraph style', String newLineString. - model _ StyledTextModel new. - style _ model styleSet paragraphStyleNamed: 'Heading 1'. - heading1 _ Text string: 'This should have the "Heading 1" style', String newLineString attribute: (ParagraphStyleReference for: style). - - composition _ TextComposition new. - composition setModel: (model contents: unstyled, heading1); extentForComposing: 300@300. - composition composeAll. - - canvas _ Display getCanvas. - scanner _ MorphicScanner new - text: composition textComposed - foreground: Color black. - scanner canvas: canvas. - - self - assert: (scanner instVarNamed: 'paragraphStyle') isNil - description: 'Incorrect initial value text style in scanner'. - -" canvas display: paragraph using: scanner in: (10@10 extent: 300@300)." - boundsInWorld _ (10@10 extent: 300@300). - leftInRun _ 0. - (composition lineIndexForPoint: 0@0) - to: (composition lineIndexForPoint: boundsInWorld extent) - do: [ :i | - line _ composition lines at: i. - composition - displaySelectionInLine: line - on: canvas - textTopLeft: boundsInWorld topLeft - selectionColor: Color blue. - leftInRun _ scanner displayLine: line textTopLeft: boundsInWorld topLeft leftInRun: leftInRun ]. - - self - assert: (scanner instVarNamed: 'paragraphStyle') = style - description: 'Incorrect initial value text style in scanner'. - - Display restore! ! -!StyledTextEditorTest methodsFor: 'tests' stamp: 'jmv 10/16/2013 19:56'! - testEmptyLine - " - StyledTextEditorTest new testEmptyLine - " - - | model t style morph block oldFont | - - model _ StyledTextModel new. - style _ model styleSet paragraphStyleNamed: 'Normal'. - t _ Text - buildWithStyles: ({ - #N -> style. - } as: Dictionary) - contents: [ :builder | - builder , 'Hi' / #N ]. - model contents: t. - morph _ (TextModelMorph withModel: model) textMorph. - block _ morph textComposition characterBlockAtPoint: 100@100. - self assert: block width = 0. - - oldFont _ style font. - style _ model styleSet paragraphStyleNamed: 'Emphasized'. - morph editor pointIndex: model actualContents size + 1. - morph editor markIndex: model actualContents size + 1. - morph editor applyAttribute: (ParagraphStyleReference for: style). - morph stylerStyled. - self deny: morph editor lastFont = oldFont. - self assert: morph editor lastFont = style font. - block _ morph textComposition characterBlockAtPoint: 100@100. - self assert: block width = 0. - self assert: block left = style firstIndent.! ! -!StyledTextEditorTest methodsFor: 'tests' stamp: 'jmv 10/16/2013 21:42'! - testEmptyText - " - StyledTextEditorTest new testEmptyText - " - - | model morph block style oldFont | - - model _ StyledTextModel new contents: '' asText. - morph _ (TextModelMorph withModel: model) textMorph. - block _ morph textComposition characterBlockAtPoint: 0@0. - style _ model styleSet paragraphStyleNamed: 'Normal'. - self assert: block width = 0. - self assert: block left = style firstIndent. - - oldFont _ style font. - style _ model styleSet paragraphStyleNamed: 'Emphasized'. - morph editor applyAttribute: (ParagraphStyleReference for: style). - morph editor pointIndex: model actualContents size + 1. - morph stylerStyled. - self deny: morph editor lastFont = oldFont. - self assert: morph editor lastFont = style font. - block _ morph textComposition characterBlockAtPoint: 0@0. - self assert: block width = 0. - self assert: block left = style firstIndent.! ! -!StyledTextEditorTest methodsFor: 'tests' stamp: 'jmv 10/16/2013 19:56'! - testEmptyTextClick - " - StyledTextEditorTest new testEmptyTextClick - " - - | model morph block style oldFont evt | - - model _ StyledTextModel new contents: '' asText. - morph _ (TextModelMorph withModel: model) textMorph. - block _ morph textComposition characterBlockAtPoint: 0@0. - style _ model styleSet paragraphStyleNamed: 'Normal'. - self assert: block width = 0. - self assert: block left = style firstIndent. - - oldFont _ style font. - style _ model styleSet paragraphStyleNamed: 'Emphasized'. - morph editor applyAttribute: (ParagraphStyleReference for: style). - morph editor pointIndex: model actualContents size + 1. - - evt _ MouseEvent new setType: #mouseMove position: 100@100 buttons: 0 hand: nil. - morph editor mouseButton1Down: evt localPosition: 100@100. - morph editor mouseButton1Up: evt - localPosition: 100@100. - - self deny: morph editor lastFont = oldFont. - self assert: morph editor lastFont = style font. - block _ morph textComposition characterBlockAtPoint: 0@0. - self assert: block width = 0. - self assert: block left = style firstIndent.! ! -!StyledTextEditorTest methodsFor: 'tests' stamp: 'jmv 10/16/2013 22:11'! - testEmptyTrailingLine - "Test that the special case of an artificial empty last line behaves as normal lines. - StyledTextEditorTest new testEmptyTrailingLine - " - - | emptyText notEmptyText model style textComposition canvas form1 form2 | - emptyText _ Text string: ''. - model _ StyledTextModel new. - style _ model styleSet paragraphStyleNamed: 'Normal'. - notEmptyText _ Text string: ' ', String newLineString attribute: (ParagraphStyleReference for: style). - form1 _ Form extent: 100@50 depth: 32. - form1 fillWhite. - form2 _ Form extent: 100@50 depth: 32. - form2 fillWhite. - - textComposition _ TextComposition new. - - canvas _ form1 getCanvas. - textComposition setModel: (model contents: emptyText); extentForComposing: 300@300. - textComposition composeAll. - textComposition selectionStartBlocks: {textComposition defaultCharacterBlock} selectionStopBlocks: {textComposition defaultCharacterBlock}. - canvas textComposition: textComposition bounds: (10@10 extent: 300@300) color: Color black selectionColor: Color blue. - - canvas _ form2 getCanvas. - textComposition setModel: (model contents: notEmptyText); extentForComposing: 300@300. - textComposition composeAll. - textComposition selectionStartBlocks: {textComposition defaultCharacterBlock} selectionStopBlocks: {textComposition defaultCharacterBlock}. - canvas textComposition: textComposition bounds: (10@10 extent: 300@300) color: Color black selectionColor: Color blue. - - form1 addDeltasFrom: form2. - self assert: form1 primCountBits = 0 description: 'Incorrect text cursor for empty text.'! ! -!StyledTextEditorTest methodsFor: 'tests' stamp: 'jmv 1/3/2017 21:30:10'! - testEmptyTrailingLineNumberedStyle - "Test that the special case of an artificial empty last line behaves as normal lines. - StyledTextEditorTest new testEmptyTrailingLineNumberedStyle - " - - | emptyText emptyTextModel notEmptyText model style textComposition canvas form1 form2 editor inner | - emptyText _ Text string: ''. - model _ StyledTextModel new. - style _ model styleSet paragraphStyleNamed: 'Numbered List'. - notEmptyText _ Text string: ' ', String newLineString attribute: (ParagraphStyleReference for: style). - form1 _ Form extent: 100@50 depth: 32. - form1 fillWhite. - form2 _ Form extent: 100@50 depth: 32. - form2 fillWhite. - - textComposition _ TextComposition new. - - canvas _ form1 getCanvas. - editor _ TextEditor new. - emptyTextModel _ model contents: emptyText. - textComposition setModel: emptyTextModel; extentForComposing: 300@300. - textComposition composeAll. - inner _ InnerTextMorph new. - inner model: emptyTextModel. - editor morph: inner. - inner privateOwner: TextModelMorph new. - editor model: emptyTextModel. - editor instVarNamed: 'textComposition' put: textComposition. - textComposition editor: editor. - editor resetState. - editor instVarNamed: 'emphasisHere' put: ({ParagraphStyleReference for: style}). - "Set model again, so editor emhasisHere is considered." - textComposition setModel: (model contents: emptyText); extentForComposing: 300@300. - textComposition composeAll. - textComposition selectionStartBlocks: {textComposition defaultCharacterBlock} selectionStopBlocks: {textComposition defaultCharacterBlock}. - canvas textComposition: textComposition bounds: (10@10 extent: 300@300) color: Color black selectionColor: Color blue. - - canvas _ form2 getCanvas. - textComposition setModel: (model contents: notEmptyText); extentForComposing: 300@300. - textComposition composeAll. - textComposition selectionStartBlocks: {textComposition defaultCharacterBlock} selectionStopBlocks: {textComposition defaultCharacterBlock}. - canvas textComposition: textComposition bounds: (10@10 extent: 300@300) color: Color black selectionColor: Color blue. - - form1 addDeltasFrom: form2. - self assert: form1 primCountBits = 0 description: 'Incorrect text cursor for empty text.'! ! -!StyledTextEditorTest methodsFor: 'tests' stamp: 'jmv 1/3/2017 21:30:37'! - testKeepParagraphStyleOnDeleteAll - " - StyledTextEditorTest new testKeepParagraphStyleOnDeleteAll - " - | editor composition model heading1 heading1Text innerMorph | - model _ StyledTextModel new. - heading1 _ model styleSet paragraphStyleNamed: 'Heading 1'. - heading1Text _ Text string: 'This is the heading', String newLineString attribute: (ParagraphStyleReference for: heading1). "Include a newLine, so our paragraphStyle is applied to resulting paragraph" - - model contents: heading1Text. - editor _ StyledTextEditor new model: model. - composition _ TextComposition new. - composition setModel: model; extentForComposing: 300@300. - composition composeAll. - innerMorph _ TextModelMorph new textMorph. - innerMorph model: model. - editor morph: innerMorph. - editor textComposition: composition; resetState. - - editor selectAll. - self assert: editor currentParagraphStyle = heading1 description: 'Please check this test'. - editor cut. - self assert: editor currentParagraphStyle = heading1 description: 'Paragraph style should not be lost because of deletion'! ! -!StyledTextEditorTest methodsFor: 'tests' stamp: 'jmv 6/9/2011 16:32'! - testRecentClipping - " - StyledTextEditorTest new testRecentClipping - " - Clipboard default: Clipboard new. - self shouldnt: [ Clipboard chooseRecentClipping ] raise: Error! ! -!StyledTextEditorTest methodsFor: 'tests' stamp: 'jmv 1/3/2017 21:31:09'! - testSelectStyle - "Create a few instances of styled text (i.e. Text using various styles) - and assert their properties - StyledTextEditorTest new testSelectStyle - " - - | model normal heading1 heading2 unstyled heading1Text editor composition text innerMorph | - model _ StyledTextModel new. - normal _ model styleSet paragraphStyleNamed: 'Normal'. - unstyled _ Text string: 'Part with "Normal" style', String newLineString attribute: (ParagraphStyleReference for: normal). - heading1 _ model styleSet paragraphStyleNamed: 'Heading 1'. - heading2 _ model styleSet paragraphStyleNamed: 'Heading 2'. - heading1Text _ Text string: 'This should have the "Heading 1" style', String newLineString attribute: (ParagraphStyleReference for: heading1). - text _ unstyled, heading1Text. - - model contents: text. - text _ model actualContents. "Might have created a new instance" - editor _ StyledTextEditor new model: model. - composition _ TextComposition new. - composition setModel: model; extentForComposing: 300@300. - composition composeAll. - innerMorph _ TextModelMorph new textMorph. - innerMorph model: model. - editor morph: innerMorph. - editor textComposition: composition; resetState. - - editor pointIndex: 2. - editor setEmphasisHereFromText. - self - assert: (editor instVarNamed: 'emphasisHere') first style = normal - description: 'Incorrect style at text cursor'. - - editor markIndex: 26 pointIndex: 28. - editor setEmphasisHereFromText. - self - assert: (editor instVarNamed: 'emphasisHere') first style = heading1 - description: 'Incorrect style at text cursor'. - - editor applyAttribute: (ParagraphStyleReference for: heading2). - editor setEmphasisHereFromText. - self - assert: (editor instVarNamed: 'emphasisHere') first style = heading2 - description: 'Should have new style at text cursor'. - - self - assert: (text paragraphStyleOrNilAt: 1) = normal - description: 'Should have no style at beginning of text'. - self - assert: (text paragraphStyleOrNilAt: unstyled size - 1) = normal - description: 'Should have no style in previous line'. - self - assert: (text paragraphStyleOrNilAt: unstyled size) = normal - description: 'Should have no style in previous line'. - self - assert: (text paragraphStyleOrNilAt: unstyled size + 1) = heading2 - description: 'Should have new style affected line'.! ! -!StyledTextEditorTest methodsFor: 'tests' stamp: 'jmv 2/14/2013 12:33'! - testShiftClickSelection - " - StyledTextEditorTest new testShiftClickSelection - " - | morph model hand editor point1 point2 p textMorph text style | - model _ StyledTextModel new. - style _ model styleSet paragraphStyleNamed: 'Normal'. - text _ Text string: 'This is a test.' attribute: (ParagraphStyleReference for: style). - model contents: text. - morph _ (PluggableStyledTextMorph withModel: model) openInWorld: PasteUpMorph someInstance. - morph world activeHand newKeyboardFocus: morph textMorph. - - point1 _ 64@20. - point2 _ 110@20. - hand _ HandMorph new. - textMorph _ morph textMorph. - p _ textMorph morphPosition. - morph mouseButton1Down: - (MouseButtonEvent new - setType: #mouseDown position: point1 - which: 4 buttons: 4 hand: hand stamp: nil) - localPosition: point1-p. - morph mouseButton1Up: - (MouseButtonEvent new - setType: #mouseUp position: point1 - which: 4 buttons: 4 hand: hand stamp: nil) - localPosition: point1-p. - morph mouseButton1Down: - (MouseButtonEvent new - setType: #mouseDown position: point2 - which: 4 buttons: 12 hand: hand stamp: nil) - localPosition: point2-p. - morph mouseButton1Up: - (MouseButtonEvent new - setType: #mouseUp position: point2 - which: 4 buttons: 12 hand: hand stamp: nil) - localPosition: point2-p. - editor _ textMorph editor. - self assert: (editor startBlock containsPoint: (point1 - p)) description: 'Incorrect selection when shift-click'. - self assert: (editor stopBlock left > (point2 - p)) description: 'Incorrect selection when shift-click'. - morph delete! ! -!StyledTextEditorTest methodsFor: 'tests' stamp: 'jmv 1/3/2017 21:31:37'! - testStylesInPaste1 - " - StyledTextEditorTest new testStylesInPaste1 - " - | heading1 heading1Text simpleText editor composition concatenation initialText model innerMorph | - model _ StyledTextModel new. - heading1 _ model styleSet paragraphStyleNamed: 'Heading 1'. - heading1Text _ Text string: 'This is the heading', String newLineString attribute: (ParagraphStyleReference for: heading1). "Include a newLine, so our paragraphStyle is applied to resulting paragraph" - simpleText _ 'This is a text without style' asText. - - initialText _ simpleText copy. - model contents: initialText. - editor _ StyledTextEditor new model: model. - composition _ TextComposition new. - composition setModel: model; extentForComposing: 300@300. - composition composeAll. - innerMorph _ TextModelMorph new textMorph. - innerMorph model: model. - editor morph: innerMorph. - editor textComposition: composition; resetState. - - editor deselectAndPlaceCursorAt: initialText size+1. - Clipboard storeObject: heading1Text. editor paste. "Extends heading 1 to beginning, runs must be compacted" - concatenation _ editor text. - self assert: concatenation runs runs size = 1 description: 'Should apply the "Heading 1" paragraph style to the whole text'. - self assert: concatenation runs first size = 1 description: 'Should apply just the "Heading 1" paragraph style to the whole text'. - self assert: concatenation runs first first style == heading1 description: 'Should apply the "Heading 1" paragraph style to the whole text'! ! -!StyledTextEditorTest methodsFor: 'tests' stamp: 'jmv 1/3/2017 21:31:42'! - testStylesInPaste2 - " - StyledTextEditorTest new testStylesInPaste2 - " - | heading1 heading1Text simpleText editor composition concatenation initialText model innerMorph | - model _ StyledTextModel new. - heading1 _ model styleSet paragraphStyleNamed: 'Heading 1'. - heading1Text _ Text string: 'This is the heading', String newLineString attribute: (ParagraphStyleReference for: heading1). "Include a newLine, so our paragraphStyle is applied to resulting paragraph" - simpleText _ 'This is a text without style' asText. - - initialText _ simpleText copy. - model contents: initialText. - editor _ StyledTextEditor new model: model. - composition _ TextComposition new. - composition setModel: model; extentForComposing: 300@300. - composition composeAll. - innerMorph _ TextModelMorph new textMorph. - innerMorph model: model. - editor morph: innerMorph. - editor textComposition: composition; resetState. - - editor deselectAndPlaceCursorAt: initialText size+1. - Clipboard storeObject: String newLineString. editor paste. - Clipboard storeObject: heading1Text. editor paste. "Extends heading 1 to beginning, runs must be compacted" - concatenation _ editor text. - self assert: concatenation runs runs size = 2 description: 'Should have 2 parts with different attributes'. -" self assert: concatenation runs runs first = (simpleText size + 1) description: 'Should apply an empty paragraph style to the first part'." - self assert: concatenation runs runs second = heading1Text size description: 'Should apply the "Heading 1" paragraph style to the second part'. -" self assert: concatenation runs values first size = 1 description: 'Should apply an empty paragraph style to the first part'." -" self assert: (concatenation runs values first first style isEquivalentTo: ParagraphStyle new) description: 'Should apply an empty paragraph style to the first part'." - self assert: concatenation runs values second size = 1 description: 'Should apply the "Heading 1" paragraph style to the second part'. - self assert: concatenation runs values second first style == heading1 description: 'Should apply the "Heading 1" paragraph style to the second part'! ! -!StyledTextEditorTest methodsFor: 'tests' stamp: 'jmv 1/3/2017 21:31:48'! - testStylesInPaste3 - " - StyledTextEditorTest new testStylesInPaste3 - " - | heading1Text simpleText editor composition concatenation initialText model heading1 innerMorph | - model _ StyledTextModel new. - heading1 _ model styleSet paragraphStyleNamed: 'Heading 1'. - heading1Text _ Text string: 'This is the heading' attribute: (ParagraphStyleReference for: heading1). - simpleText _ 'This is a text without style' asText. - - initialText _ heading1Text copy. - model contents: initialText. - editor _ StyledTextEditor new model: model. - composition _ TextComposition new. - composition setModel: model; extentForComposing: 300@300. - composition composeAll. - innerMorph _ TextModelMorph new textMorph. - innerMorph model: model. - editor morph: innerMorph. - editor textComposition: composition; resetState. - - editor deselectAndPlaceCursorAt: initialText size+1. - Clipboard storeObject: simpleText. editor paste. "Extends style to beginning. I.e., lose the style, style comes from paragraph end" - concatenation _ editor text. - self assert: concatenation runs runs size = 1 description: 'Should apply no character style to the whole text'. - self assert: concatenation runs first first style == heading1 description: 'Should apply just the "Heading 1" paragraph style to the whole text'! ! -!StyledTextEditorTest methodsFor: 'tests' stamp: 'jmv 1/3/2017 21:31:52'! - testStylesInPaste4 - " - StyledTextEditorTest new testStylesInPaste4 - " - | heading1Text heading1 simpleText editor textComposition concatenation initialText model innerMorph | - model _ StyledTextModel new. - heading1 _ model styleSet paragraphStyleNamed: 'Heading 1'. - heading1Text _ Text string: 'This is the heading' attribute: (ParagraphStyleReference for: heading1). - simpleText _ 'This is a text without style' asText. - - initialText _ heading1Text copy. - model contents: initialText. - editor _ StyledTextEditor new model: model. - textComposition _ TextComposition new. - textComposition setModel: model; extentForComposing: 300@300. - textComposition composeAll. - innerMorph _ TextModelMorph new textMorph. - innerMorph model: model. - editor morph: innerMorph. - editor textComposition: textComposition; resetState. - - editor deselectAndPlaceCursorAt: initialText size+1. - "Enter styled text. Then press return and paste text without style. - The paragraph style in use should be that of the first part." - Clipboard storeObject: String newLineString. editor paste. - Clipboard storeObject: simpleText. editor paste. - concatenation _ editor text. - self assert: concatenation runs runs size = 2 description: 'Should use imported RTF style'. - self assert: concatenation runs runs first = (heading1Text size +1) description: 'Should apply the "Heading 1" paragraph style to the first part'. - self assert: concatenation runs runs second = simpleText size description: 'Should apply the "Normal" paragraph style to the second part'. - self assert: concatenation runs values first first style name = 'Heading 1'. - self assert: concatenation runs values second first style name = 'Normal'! ! -!StyledTextEditorTest methodsFor: 'tests' stamp: 'jmv 1/3/2017 21:31:59'! - testStylesInPaste5 - " - StyledTextEditorTest new testStylesInPaste5 - " - | heading1Text heading1 simpleText editor textComposition concatenation initialText model innerMorph | - model _ StyledTextModel new. - heading1 _ model styleSet paragraphStyleNamed: 'Heading 1'. - heading1Text _ Text string: 'This is the heading' attribute: (ParagraphStyleReference for: heading1). - simpleText _ 'This is a text without style' asText. - - initialText _ heading1Text copy. - model contents: initialText. - editor _ StyledTextEditor new model: model. - textComposition _ TextComposition new. - textComposition setModel: model; extentForComposing: 300@300. - textComposition composeAll. - innerMorph _ TextModelMorph new textMorph. - innerMorph model: model. - editor morph: innerMorph. - editor textComposition: textComposition; resetState. - - editor deselectAndPlaceCursorAt: initialText size+1. - "Enter styled text. Then press return and paste a simple string. - The paragraph style in use should be that of the first part." - Clipboard storeObject: String newLineString. editor paste. - Clipboard storeObject: simpleText asString. editor paste. - concatenation _ editor text. - self assert: concatenation runs runs size = 1 description: 'Should apply same attributes to the whole text'. - self assert: concatenation runs runs first = concatenation size description: 'Should apply the "Heading 1" paragraph style to all the text'.! ! -!StyledTextEditorTest methodsFor: 'tests' stamp: 'jmv 1/3/2017 21:32:04'! - testStylesInPaste6 - " - StyledTextEditorTest new testStylesInPaste6 - " - | heading1 heading1Text heading2 heading2Text editor textComposition concatenation initialText model innerMorph | - model _ StyledTextModel new. - heading1 _ model styleSet paragraphStyleNamed: 'Heading 1'. - heading1Text _ Text string: 'This is the heading 1' attribute: (ParagraphStyleReference for: heading1). - heading2 _ model styleSet paragraphStyleNamed: 'Heading 2'. - heading2Text _ Text string: 'This is a text without style', String newLineString attribute: (ParagraphStyleReference for: heading2). - - initialText _ heading1Text copy. - model contents: initialText. - editor _ StyledTextEditor new model: model. - textComposition _ TextComposition new. - textComposition setModel: model; extentForComposing: 300@300. - textComposition composeAll. - innerMorph _ TextModelMorph new textMorph. - innerMorph model: model. - editor morph: innerMorph. - editor textComposition: textComposition; resetState. - - editor deselectAndPlaceCursorAt: initialText size+1. - Clipboard storeObject: String newLineString. editor paste. - "This is an almost trivial case. just check that both parts are as they were at the beginning" - Clipboard storeObject: heading2Text. editor paste. - concatenation _ editor text. - self assert: concatenation runs runs size = 2 description: 'Should have 2 parts with different attributes'. - self assert: concatenation runs runs first = (heading1Text size + 1) description: 'Should apply the "Heading 1" paragraph style to the first part'. - self assert: concatenation runs runs second = heading2Text size description: ''. - self assert: concatenation runs values first size = 1 description: 'Should apply the "Heading 1" paragraph style to the first part'. - self assert: concatenation runs values first first style == heading1 description: 'Should apply the "Heading 1" paragraph style to the first part'. - self deny: concatenation runs values second first style == heading1 description: 'Should not apply the "Heading 1" paragraph style to the second part'! ! -!StyledTextEditorTest methodsFor: 'tests' stamp: 'jmv 1/3/2017 21:32:08'! - testStylesInPaste7 - " - StyledTextEditorTest new testStylesInPaste7 - " - | heading1 heading1Text simpleText editor textComposition concatenation initialText model innerMorph | - model _ StyledTextModel new. - heading1 _ model styleSet paragraphStyleNamed: 'Heading 1'. - heading1Text _ Text string: 'This is the heading' attribute: (ParagraphStyleReference for: heading1). "Do not include a cr" - simpleText _ 'This is a text without style' asText. - - initialText _ simpleText copy. - model contents: initialText. - editor _ StyledTextEditor new model: model. - textComposition _ TextComposition new. - textComposition setModel: model; extentForComposing: 300@300. - textComposition composeAll. - innerMorph _ TextModelMorph new textMorph. - innerMorph model: model. - editor morph: innerMorph. - editor textComposition: textComposition; resetState. - - editor selectAll. - Clipboard storeObject: heading1Text. editor paste. "Extends heading 1 to beginning, runs must be compacted" - concatenation _ editor text. - self assert: concatenation runs runs size = 1 description: 'Should apply the "Heading 1" paragraph style to the whole text, as no part of original text is left.'. - self assert: concatenation runs first size = 1 description: 'Should apply just the "Heading 1" paragraph style to the whole text, as no part of original text is left.'. - self assert: concatenation runs first first style == heading1 description: 'Should apply the "Heading 1" paragraph style to the whole text, as no part of original text is left.'! ! -!StyledTextEditorTest methodsFor: 'tests' stamp: 'jmv 1/3/2017 21:32:12'! - testStylesInPaste8 - " - Not exactly a Paste operation, but #replaceSelectionWith: , as done by the autocompletter - StyledTextEditorTest new testStylesInPaste8 - " - | simpleText editor textComposition concatenation initialText model innerMorph | - model _ StyledTextModel new. - simpleText _ (Text - string: 'Aardvark' - attribute: (CharacterStyleReference new style: model styleSet autoCompletedStyle)), ' '. - - initialText _ '' asText. - model contents: initialText. - editor _ StyledTextEditor new model: model. - textComposition _ TextComposition new. - textComposition setModel: model; extentForComposing: 300@300. - textComposition composeAll. - innerMorph _ TextModelMorph new textMorph. - innerMorph model: model. - editor morph: innerMorph. - editor textComposition: textComposition; resetState. - - editor deselectAndPlaceCursorAt: initialText size+1. - editor replaceSelectionWith: simpleText. - concatenation _ editor text. - self - assert: (concatenation runs values allSatisfy: [ :attrs | attrs anySatisfy: [ :att | att class == ParagraphStyleReference ]]) - description: 'Must have ParagraphStyle everywhere!!'! ! -!StyledTextModelTest methodsFor: 'as yet unclassified' stamp: 'jmv 5/31/2016 10:34'! - tearDown - (DirectoryEntry currentDirectory // 'StyledTextModelTest.object') delete! ! -!StyledTextModelTest methodsFor: 'as yet unclassified' stamp: 'bp 4/22/2012 13:15'! - testFromFileNamed - | model1 model2 model3 | - model1 _ StyledTextModel new contents: 'Some text' asText. - model1 saveAs: 'StyledTextModelTest'. - model2 _ StyledTextModel fromFileNamed: 'StyledTextModelTest.object'. - self assert: model1 actualContents equals: model2 actualContents. - model3 _ StyledTextModel fromFileNamed: 'StyledTextModelTest'. - self assert: model1 actualContents equals: model3 actualContents! ! -!StyledTextModelTest methodsFor: 'as yet unclassified' stamp: 'jmv 5/31/2016 10:34'! - testSave - | model | - model _ StyledTextModel new. - self deny: (DirectoryEntry currentDirectory // 'StyledTextModelTest.object') exists. - model saveAs: 'StyledTextModelTest'. - self assert: (DirectoryEntry currentDirectory // 'StyledTextModelTest.object') exists! ! -!StyledTextTest methodsFor: 'tests' stamp: 'jmv 12/20/2011 12:41'! - testAsStyledAsNonStyledSample5 - " - StyledTextTest new testAsStyledAsNonStyledSample5Bis - " - | styled unstyled model style | - unstyled _ RTFConversionTest textSample5. - styled _ unstyled asStyledTextWith: StyleSet sample. - model _ StyledTextModel new. - style _ model styleSet paragraphStyleNamed: 'Heading 1'. - styled addAttribute: (ParagraphStyleReference for: style). - self assert: (unstyled attributesAt: 7) first class = TextAnchor. "Or test is broken" - self assert: ((styled attributesAt: 7) anySatisfy: [ :att | att class = TextAnchor])! ! -!StyledTextTest methodsFor: 'tests' stamp: 'jmv 10/16/2013 21:43'! - testCharacterStyleConcatenation - " - self new testCharacterStyleConcatenation - " - | model normal normalText1 red10Bold simpleColoredText normalText3 concatenation5 concatenation6 | - model _ StyledTextModel new. - normal _ model styleSet paragraphStyleNamed: 'Normal'. - normalText1 _ Text string: 'This is just ' attribute: (ParagraphStyleReference for: normal). - red10Bold _ model styleSet characterStyleNamed: 'Red 10 bold'. - simpleColoredText _ Text string: 'colored' attribute: (CharacterStyleReference for: red10Bold). - normalText3 _ Text string: ' normal text', String newLineString attribute: (ParagraphStyleReference for: normal). "End with a newLine, so our paragraph style is applied all over the resulting paragraph" - concatenation5 _ normalText1, simpleColoredText, normalText3. - - self assert: concatenation5 runs runs size = 3 description: 'Should have 3 parts with distinct CharacterStyles'. - self assert: concatenation5 runs runs first = normalText1 size description: 'Should apply no character style to the first part'. - self assert: concatenation5 runs values first size = 1 description: 'Should apply no character style to the first part'. - - self assert: concatenation5 runs runs second = simpleColoredText size description: 'Should apply "Red 10 bold" style to the second part'. - self assert: concatenation5 runs values second size = 2 description: 'Should apply "Red 10 bold" style to the second part'. - self assert: concatenation5 runs values second second style == red10Bold description: 'Should apply "Red 10 bold" style to the second part'. - - self assert: concatenation5 runs runs third = normalText3 size description: 'Should apply no character style to the third part'. - self assert: concatenation5 runs values third size = 1 description: 'Should apply no character style to the third part'. - - concatenation6 _ simpleColoredText, normalText3. - self assert: concatenation6 runs runs size = 2 description: 'Should have 2 parts with distinct CharacterStyles'. - - self assert: concatenation6 runs runs first = simpleColoredText size description: 'Should apply "Red 10 bold" style to the second part'. - self assert: concatenation6 runs values first size = 2 description: 'Should apply "Red 10 bold" style to the second part'. - self assert: concatenation6 runs values first second style == red10Bold description: 'Should apply "Red 10 bold" style to the second part'. - - self assert: concatenation6 runs runs second = normalText3 size description: 'Should apply no character style to the third part'. - self assert: concatenation6 runs values second size = 1 description: 'Should apply no character style to the third part'! ! -!StyledTextTest methodsFor: 'tests' stamp: 'jmv 11/1/2011 09:49'! - testOldInstanceDeserialization - " - StyledTextTest new testOldInstanceDeserialization - " - | newInstance oldFormat | - "Evaluated in an image without 'undoRedoCommands' ivar" - " - oldInstance _ StyledTextModel withText: 'This is a text'. - (SmartRefStream streamedRepresentationOf: oldInstance) inspect. - " - oldFormat _ 'class structure  -Dictionary0  AssociationObject?SequenceableCollection?StyledTextModel actionMapactualContents?Pointxy?RunArrayrunsvalues lastIndexlastRun -lastOffsetcanJoinMessage? ActiveModel -¥?Symbol?ArrayedCollection?Number? TextModel -¥ -°?Textstringruns? Rectangleorigincorner? ProtoObject? Magnitude? MessageSendreceiverselector arguments?String?LargePositiveInteger? -Collection?Array?Integer superclasses 0? -L -"? -c -Ì? -Š -²? -Î -L? -î -{? -D -L? -d -’? -{ -c? -œ -?? -² -D? -× -{? -ù -L? -"nil? -? -L? -X -L? -’ -{? -¨ -û? -Ì -L? -æ -{? -û -œŠ×This is a textîX -e canJoin:and:!! - -'. - newInstance _ SmartRefStream unStream: oldFormat. - self shouldnt: [ newInstance undoRedoCommands ] raise: Exception. - ! ! -!StyledTextTest methodsFor: 'tests' stamp: 'jmv 3/14/2012 09:49'! - testSample1ToAndFromRTFClipboardStyle - " - StyledTextTest new testSample1ToAndFromRTFClipboardStyle - " - | text text2 | - text _ RTFConversionTest textSample1. - - "This will use a refStreamed object" - Clipboard default storeObject: text. - text2 _ Clipboard default retrieveObject. - self assert: text2 = text. - self assert: text2 runs = text runs. - - "This will also test storing and retrieving RTF data from platform Clipboard, and RTF conversion" - ExtendedClipboardInterface current - clearClipboard; - addClipboardData: text rtfString dataFormat: 'public.rtf'. - text2 _ Clipboard default retrieveObject. - self assert: text2 = text. - self assert: text2 asNonStyledText runs = text runs.! ! -!StyledTextTest methodsFor: 'tests' stamp: 'jmv 4/2/2016 14:48'! - testSample2ToAndFromRTFClipboardStyle - " - StyledTextTest new testSample2ToAndFromRTFClipboardStyle - " - | text text2 | - self assert: Clipboard default extendedClipboardInterface canStore description: 'Extended Clipboard cant store'. - text _ RTFConversionTest textSample2. - - "This will use a refStreamed object" - Clipboard default storeObject: text. - text2 _ Clipboard default retrieveObject. - self assert: text2 = text. - self assert: text2 runs = text runs. - - "This will also test storing and retrieving RTF data from platform Clipboard, and RTF conversion" - ExtendedClipboardInterface current - clearClipboard; - addClipboardData: text rtfString dataFormat: 'public.rtf'. - text2 _ Clipboard default retrieveObject. - self assert: text2 = text. - self assert: text2 asNonStyledText runs = text runs.! ! -!StyledTextTest methodsFor: 'tests' stamp: 'jmv 3/14/2012 09:50'! - testSample3ToAndFromRTFClipboardStyle - " - StyledTextTest new testSample3ToAndFromRTFClipboardStyle - " - | text text2 | - text _ RTFConversionTest textSample3. - - "This will use a refStreamed object" - Clipboard default storeObject: text. - text2 _ Clipboard default retrieveObject. - self assert: text2 = text. - self assert: text2 runs = text runs. - - "This will also test storing and retrieving RTF data from platform Clipboard, and RTF conversion" - ExtendedClipboardInterface current - clearClipboard; - addClipboardData: text rtfString dataFormat: 'public.rtf'. - text2 _ Clipboard default retrieveObject. - self assert: text2 = text. - self assert: text2 asNonStyledText runs = text runs.! ! -!StyledTextTest methodsFor: 'tests' stamp: 'jmv 3/14/2012 09:50'! - testSample4ToAndFromRTFClipboardStyle - " - StyledTextTest new testSample4ToAndFromRTFClipboardStyle - " - | text text2 | - text _ RTFConversionTest textSample4. - - "This will use a refStreamed object" - Clipboard default storeObject: text. - text2 _ Clipboard default retrieveObject. - self assert: text2 = text. - self assert: text2 runs = text runs. - - "This will also test storing and retrieving RTF data from platform Clipboard, and RTF conversion" - ExtendedClipboardInterface current - clearClipboard; - addClipboardData: text rtfString dataFormat: 'public.rtf'. - text2 _ Clipboard default retrieveObject. - self assert: text2 = text. - "kern and struckThrough not supported in rtf yet..." -" self assert: text2 asNonStyledText runs = text runs." -" self assert: text2 usesOnlyStyles description: 'If not using the RTFStyledTextBuilder, next assert makes no sense.'." - "kern and struckThrough not supported in rtf yet..." -" self assert: text2 runs = text asStyledText runs"! ! -!StyledTextTest methodsFor: 'tests' stamp: 'jmv 3/14/2012 09:50'! - testSample5ToAndFromRTFClipboardStyle - " - StyledTextTest new testSample5ToAndFromRTFClipboardStyle - " - | text text2 | - text _ RTFConversionTest textSample5. - - "This will use a refStreamed object" - Clipboard default storeObject: text. - text2 _ Clipboard default retrieveObject. - self assert: text2 = text. - self assert: text2 runs = text runs. - - "This will also test storing and retrieving RTF data from platform Clipboard, and RTF conversion" - ExtendedClipboardInterface current - clearClipboard; - addClipboardData: text rtfString dataFormat: 'public.rtf'. - text2 _ Clipboard default retrieveObject. - self assert: text2 = text. - self assert: text2 asNonStyledText runs = text runs.! ! -!StyledTextTest methodsFor: 'tests' stamp: 'jmv 3/14/2012 09:50'! - testSample6ToAndFromRTFClipboardStyle - " - StyledTextTest new testSample6ToAndFromRTFClipboardStyle - " - | text text2 | - text _ RTFConversionTest textSample6. - - "This will use a refStreamed object" - Clipboard default storeObject: text. - text2 _ Clipboard default retrieveObject. - self assert: text2 = text. - self assert: text2 runs = text runs. - - "This will also test storing and retrieving RTF data from platform Clipboard, and RTF conversion" - ExtendedClipboardInterface current - clearClipboard; - addClipboardData: text rtfString dataFormat: 'public.rtf'. - text2 _ Clipboard default retrieveObject. - self assert: text2 = text. - self assert: text2 asNonStyledText runs = text runs.! ! -!StyledTextTest methodsFor: 'tests' stamp: 'jmv 3/13/2012 17:01'! - testStyledText - "Create a few instances of styled text (i.e. Text using various styles) - and assert their properties - StyledTextTest new testStyledText - " - - | model heading1 heading2 heading3 normal unstyledText heading1Text heading2Text heading3Text normalText multiText | - model _ StyledTextModel new. - heading1 _ model styleSet paragraphStyleNamed: 'Heading 1'. - heading2 _ model styleSet paragraphStyleNamed: 'Heading 2'. - heading3 _ model styleSet paragraphStyleNamed: 'Heading 3'. - normal _ model styleSet paragraphStyleNamed: 'Normal'. - unstyledText _ Text string: 'Non-styled part. should use no style', String newLineString. - heading1Text _ Text string: ('This should have the "Heading 1" style', String newLineString) attribute: (ParagraphStyleReference for: heading1). - heading2Text _ Text string: ('This should have the "Heading 2" style', String newLineString) attribute: (ParagraphStyleReference for: heading2). - heading3Text _ Text string: ('This should have the "Heading 3" style', String newLineString) attribute: (ParagraphStyleReference for: heading3). - normalText _ Text string: ('This should have the "Normal" style', String newLineString) attribute: (ParagraphStyleReference for: normal). - multiText _ unstyledText, heading1Text, heading2Text, heading3Text, normalText, unstyledText. - - self - assert: multiText string = (unstyledText string, heading1Text string, heading2Text string, heading3Text string, normalText string, unstyledText string) - description: 'It seems concatenating texts breaks the string'. - self - assert: (unstyledText paragraphStyleOrNilAt: 3) isNil - description: 'initialStyle failing'. - self - assert: (multiText paragraphStyleOrNilAt: 3) isNil - description: 'initialStyle failing'. - self - assert: (heading1Text paragraphStyleOrNilAt: 3) = heading1 - description: 'initialStyle failing'. - self - assert: (multiText paragraphStyleOrNilAt: 60) = heading1 - description: 'Incorrect ParagraphStyle in styled text'. - self - assert: (multiText paragraphStyleOrNilAt: multiText size) isNil - description: 'Incorrect ParagraphStyle in styled text'! ! -!StyledTextTest methodsFor: 'tests' stamp: 'jmv 3/13/2012 17:01'! - testStyledTextAndString - "Create a few instances of styled text (i.e. Text using various styles) - and assert their properties - StyledTextTest new testStyledTextAndString - " - - | model style heading1 multi string | - string _ 'Just a String '. - model _ StyledTextModel new. - style _ model styleSet paragraphStyleNamed: 'Heading 1'. - heading1 _ Text string: 'This should have the "Heading 1" style', String newLineString attribute: (ParagraphStyleReference for: style). - multi _ string, heading1. - self - assert: multi class = Text - description: 'Concatenation of String and Text should answer Text'. - self - assert: multi string = (string, heading1 string) - description: 'It seems concatenating texts breaks the string'. - self - assert: (heading1 paragraphStyleOrNilAt: 3) = style - description: 'ParagraphStyle not properly set'. - self - assert: (multi paragraphStyleOrNilAt: 3) = style - description: 'ParagraphStyle not properly set'.! ! -!StyledTextTest methodsFor: 'tests' stamp: 'jmv 3/13/2012 17:01'! - testStyledTextBuilder - " - Test building with nested CharacterStyles - self new testStyledTextBuilder - " - | model heading3 green14 red10Bold green11Italic t | - model _ StyledTextModel new. - heading3 _ model styleSet paragraphStyleNamed: 'Heading 3'. - green14 _ model styleSet characterStyleNamed: 'Green 14'. - red10Bold _ model styleSet characterStyleNamed: 'Red 10 bold'. - green11Italic _ model styleSet characterStyleNamed: 'Green 11 Italic'. - t _ Text - buildWithStyles: ({ - #H3 -> heading3. - #g14 -> green14. - #r10b -> red10Bold. - #g11i -> green11Italic - } as: Dictionary) - contents: [ :builder | - builder , 'Starts as Heading 3. But later gets' < #g14 , ' big and green' , ' and stays like that. Then' >< #r10b , ' red & bold and inside this,' < #g11i , ' green and italic' > ' for a while. Later' > ' back to Heading 3.' / #H3]. - - " - t inspect. - t edit. - " - - self assert: t string = ('Starts as Heading 3. But later gets big and green and stays like that. Then red & bold and inside this, green and italic for a while. Later back to Heading 3.', String newLineString) description: 'Broken string built.'. - - self assert: (t paragraphStyleOrNilAt: 12) name = 'Heading 3' description: 'Wrong paragraph style'. - self assert: (t characterStyleOrNilAt: 2) isNil description: 'Should not have a char style yet'. - self assert: (t characterStyleOrNilAt: 40) name = 'Green 14' description: 'Wrong charStyle'. - self assert: (t characterStyleOrNilAt: 75) name = 'Green 14' description: 'Wrong charStyle'. - self assert: (t characterStyleOrNilAt: 76) name = 'Red 10 bold' description: 'Wrong charStyle'. - self assert: (t characterStyleOrNilAt: 103) name = 'Red 10 bold' description: 'Wrong charStyle'. - self assert: (t characterStyleOrNilAt: 104) name = 'Green 11 Italic' description: 'Wrong charStyle'. - self assert: (t characterStyleOrNilAt: 120) name = 'Green 11 Italic' description: 'Wrong charStyle'. - self assert: (t characterStyleOrNilAt: 121) name = 'Red 10 bold' description: 'Wrong charStyle'. - self assert: (t characterStyleOrNilAt: 139) name = 'Red 10 bold' description: 'Wrong charStyle'. - self assert: (t characterStyleOrNilAt: 140) isNil description: 'Should not have a char style any longer'. - self assert: (t characterStyleOrNilAt: t size) isNil description: 'Should not have a char style any longer'.! ! -!StyledTextTest methodsFor: 'tests' stamp: 'jmv 8/10/2011 10:43'! -testStyledTextBuilder2 - " - Test several paragraphs, with various ParagraphStyles - self new testStyledTextBuilder2 - " - |model heading1 heading2 heading3 emphasized normal green14 red10Bold green11Italic t | - model _ StyledTextModel new. - heading1 _ model styleSet paragraphStyleNamed: 'Heading 1'. - heading2 _ model styleSet paragraphStyleNamed: 'Heading 2'. - heading3 _ model styleSet paragraphStyleNamed: 'Heading 3'. - emphasized _ model styleSet paragraphStyleNamed: 'Emphasized'. - normal _ model styleSet paragraphStyleNamed: 'Normal'. - green14 _ model styleSet characterStyleNamed: 'Green 14'. - red10Bold _ model styleSet characterStyleNamed: 'Red 10 bold'. - green11Italic _ model styleSet characterStyleNamed: 'Green 11 Italic'. - t _ Text - buildWithStyles: ({ - #H1 -> heading1. - #H2 -> heading2. - #H3 -> heading3. - #E -> emphasized. - #N -> normal. - #g14 -> green14. - #r10b -> red10Bold. - #g11i -> green11Italic - } as: Dictionary) - contents: [ :builder | - builder, - 'This is the main title' / #H1, - 'This is the title of level 2' / #H2, - 'This is title 3' / #H3, - 'Then, we have some normal text. But later gets' < #g14 , ' big and green' , ' and stays like that. Then' >< #r10b , ' red & bold and inside this,' < #g11i , ' green and italic' > ' for a while.' > ' Lets make this look like a paragraph, i.e. add enough text so that we''l be using more than one display line. Is this enough? Who knows... Let''s add a bit more. Maybe this is enough.' / #N, - 'This is an emphasized paragraph. It uses a Paragraph Style, not a Character Style, and therefore it has the same style all over the paragraph' / #E, - 'This' < #r10b, ' is' > ' again a' < #g14, ' title 2' >/ #H2, - 'And now another paragraph. This one may be smaller than previous ones' / #N ]. - - " - model contents: t. - SystemWindow editFancierStyledText: model label: 'Styled Text Editor' - " - - self assert: t string = 'This is the main title -This is the title of level 2 -This is title 3 -Then, we have some normal text. But later gets big and green and stays like that. Then red & bold and inside this, green and italic for a while. Lets make this look like a paragraph, i.e. add enough text so that we''l be using more than one display line. Is this enough? Who knows... Let''s add a bit more. Maybe this is enough. -This is an emphasized paragraph. It uses a Paragraph Style, not a Character Style, and therefore it has the same style all over the paragraph -This is again a title 2 -And now another paragraph. This one may be smaller than previous ones -' description: 'Broken string built.'. - - self assert: (t paragraphStyleOrNilAt: 10) name = 'Heading 1' description: 'Wrong paragraphStyle'. - self assert: (t characterStyleOrNilAt: 10) isNil description: 'Should not have a char style yet'. - self assert: (t paragraphStyleOrNilAt: 30) name = 'Heading 2' description: 'Wrong paragraphStyle'. - self assert: (t characterStyleOrNilAt: 30) isNil description: 'Should not have a char style yet'. - self assert: (t paragraphStyleOrNilAt: 60) name = 'Heading 3' description: 'Wrong paragraphStyle'. - self assert: (t characterStyleOrNilAt: 60) isNil description: 'Should not have a char style yet'. - self assert: (t paragraphStyleOrNilAt: 70) name = 'Normal' description: 'Wrong paragraphStyle'. - self assert: (t characterStyleOrNilAt: 70) isNil description: 'Should not have a char style yet'. - self assert: (t paragraphStyleOrNilAt: 120) name = 'Normal' description: 'Wrong paragraphStyle'. - self assert: (t characterStyleOrNilAt: 120) name = 'Green 14' description: 'Wrong charStyle'. - self assert: (t paragraphStyleOrNilAt: 160) name = 'Normal' description: 'Wrong paragraphStyle'. - self assert: (t characterStyleOrNilAt: 160) name = 'Red 10 bold' description: 'Wrong charStyle'. - self assert: (t paragraphStyleOrNilAt: 190) name = 'Normal' description: 'Wrong paragraphStyle'. - self assert: (t characterStyleOrNilAt: 190) name = 'Green 11 Italic' description: 'Wrong charStyle'. - self assert: (t paragraphStyleOrNilAt: 210) name = 'Normal' description: 'Wrong paragraphStyle'. - self assert: (t characterStyleOrNilAt: 210) name = 'Red 10 bold' description: 'Wrong charStyle'. - self assert: (t paragraphStyleOrNilAt: 220) name = 'Normal' description: 'Wrong paragraphStyle'. - self assert: (t characterStyleOrNilAt: 220) isNil description: 'Should not have a char style any longer'. - self assert: (t paragraphStyleOrNilAt: 400) name = 'Emphasized' description: 'Wrong paragraphStyle'. - self assert: (t characterStyleOrNilAt: 400) isNil description: 'Should not have a char style'. - self assert: (t paragraphStyleOrNilAt: 539) name = 'Heading 2' description: 'Wrong paragraphStyle'. - self assert: (t characterStyleOrNilAt: 539) isNil description: 'Should not have a char style yet'. - self assert: (t paragraphStyleOrNilAt: 543) name = 'Heading 2' description: 'Wrong paragraphStyle'. - self assert: (t characterStyleOrNilAt: 543) name = 'Red 10 bold' description: 'Wrong charStyle'. - self assert: (t paragraphStyleOrNilAt: 546) name = 'Heading 2' description: 'Wrong paragraphStyle'. - self assert: (t characterStyleOrNilAt: 546) isNil description: 'Should not have a char style'. - self assert: (t paragraphStyleOrNilAt: 554) name = 'Heading 2' description: 'Wrong paragraphStyle'. - self assert: (t characterStyleOrNilAt: 554) name = 'Green 14' description: 'Wrong charStyle'. - self assert: (t paragraphStyleOrNilAt: t size) name = 'Normal' description: 'Wrong paragraphStyle'. - self assert: (t characterStyleOrNilAt: t size) isNil description: 'Should not have a char style any longer'.! ! -!StyledTextTest methodsFor: 'tests' stamp: 'jmv 1/3/2017 21:27:33'! - testStylesInPaste1 - " - self new testStylesInPaste1 - " - | heading1 heading1Text simpleText editor textComposition concatenation initialText model innerMorph | - model _ StyledTextModel new. - heading1 _ model styleSet paragraphStyleNamed: 'Heading 1'. - heading1Text _ Text string: 'This is the heading', String newLineString attribute: (ParagraphStyleReference for: heading1). "Include a cr, so our paragraphStyle is applied to resulting paragraph" - simpleText _ 'This is a text without style' asText. - - initialText _ simpleText copy. - model contents: initialText. - editor _ StyledTextEditor new model: model. - textComposition _ TextComposition new. - textComposition setModel: model; extentForComposing: 300@300. - textComposition composeAll. - innerMorph _ TextModelMorph new textMorph. - innerMorph model: model. - editor morph: innerMorph. - editor textComposition: textComposition; resetState. - - editor deselectAndPlaceCursorAt: initialText size+1. - ExtendedClipboardInterface current - clearClipboard; - addClipboardData: heading1Text rtfString dataFormat: 'public.rtf'. - editor paste. "Extends heading 1 to beginning, runs must be compacted" - concatenation _ editor text. - self assert: concatenation runs runs size = 1 description: 'Should apply the "Heading 1" paragraph style to the whole text'. - self assert: concatenation runs first size = 1 description: 'Should apply just the "Heading 1" paragraph style to the whole text'. - self assert: concatenation runs first first style == heading1 description: 'Should apply the "Heading 1" paragraph style to the whole text'! ! -!StyledTextTest methodsFor: 'tests' stamp: 'jmv 1/3/2017 21:32:55'! - testStylesInPaste2 - " - self new testStylesInPaste2 - " - | heading1 heading1Text simpleText editor textComposition concatenation initialText model innerMorph | - model _ StyledTextModel new. - heading1 _ model styleSet paragraphStyleNamed: 'Heading 1'. - heading1Text _ Text string: 'This is the heading', String newLineString attribute: (ParagraphStyleReference for: heading1). "Include a cr, so our paragraphStyle is applied to resulting paragraph" - simpleText _ 'This is a text without style' asText. - - initialText _ simpleText copy. - model contents: initialText. - editor _ StyledTextEditor new model: model. - textComposition _ TextComposition new. - textComposition setModel: model; extentForComposing: 300@300. - textComposition composeAll. - innerMorph _ TextModelMorph new textMorph. - innerMorph model: model. - editor morph: innerMorph. - editor textComposition: textComposition; resetState. - - editor deselectAndPlaceCursorAt: initialText size+1. - Clipboard storeObject: String newLineString. editor paste. - ExtendedClipboardInterface current - clearClipboard; - addClipboardData: heading1Text rtfString dataFormat: 'public.rtf'. - editor paste. "Extends heading 1 to beginning, runs must be compacted" - concatenation _ editor text. - self assert: concatenation runs runs size = 2 description: 'Should have 2 parts with different attributes'. -" self assert: concatenation runs runs first = (simpleText size + 1) description: 'Should apply an empty paragraph style to the first part'." - self assert: concatenation runs runs second = heading1Text size description: 'Should apply the "Heading 1" paragraph style to the second part'. -" self assert: concatenation runs values first size = 1 description: 'Should apply an empty paragraph style to the first part'." -" self assert: (concatenation runs values first first style isEquivalentTo: ParagraphStyle new) description: 'Should apply an empty paragraph style to the first part'." - self assert: concatenation runs values second size = 1 description: 'Should apply the "Heading 1" paragraph style to the second part'. - self assert: concatenation runs values second first style == heading1 description: 'Should apply the "Heading 1" paragraph style to the second part'! ! -!StyledTextTest methodsFor: 'tests' stamp: 'jmv 1/3/2017 21:33:01'! - testStylesInPaste3 - " - self new testStylesInPaste3 - " - | heading1Text simpleText editor textComposition concatenation initialText model heading1 innerMorph | - model _ StyledTextModel new. - heading1 _ model styleSet paragraphStyleNamed: 'Heading 1'. - heading1Text _ Text string: 'This is the heading' attribute: (ParagraphStyleReference for: heading1). - simpleText _ 'This is a text without style' asText. - - initialText _ heading1Text copy. - model contents: initialText. - editor _ StyledTextEditor new model: model. - textComposition _ TextComposition new. - textComposition setModel: model; extentForComposing: 300@300. - textComposition composeAll. - innerMorph _ TextModelMorph new textMorph. - innerMorph model: model. - editor morph: innerMorph. - editor textComposition: textComposition; resetState. - - editor deselectAndPlaceCursorAt: initialText size+1. - ExtendedClipboardInterface current - clearClipboard; - addClipboardData: simpleText rtfString dataFormat: 'public.rtf'. - editor paste. "Extends style to beginning. I.e., lose the style, style comes from paragraph end" - concatenation _ editor text. - self assert: concatenation runs runs size = 1 description: 'Should apply no character style to the whole text'. - self assert: concatenation runs first first style == heading1 description: 'Should apply just the "Heading 1" paragraph style to the whole text'! ! -!StyledTextTest methodsFor: 'tests' stamp: 'jmv 1/3/2017 21:33:06'! - testStylesInPaste4 - " - self new testStylesInPaste4 - " - | heading1Text heading1 simpleText editor textComposition concatenation initialText model innerMorph | - model _ StyledTextModel new. - heading1 _ model styleSet paragraphStyleNamed: 'Heading 1'. - heading1Text _ Text string: 'This is the heading' attribute: (ParagraphStyleReference for: heading1). - simpleText _ 'This is a text without style' asText. - - initialText _ heading1Text copy. - model contents: initialText. - editor _ StyledTextEditor new model: model. - textComposition _ TextComposition new. - textComposition setModel: model; extentForComposing: 300@300. - textComposition composeAll. - innerMorph _ TextModelMorph new textMorph. - innerMorph model: model. - editor morph: innerMorph. - editor textComposition: textComposition; resetState. - - editor deselectAndPlaceCursorAt: initialText size+1. - Clipboard storeObject: String newLineString. editor paste. - "Now we give an text without styles to the Clipboard, and we test that it does include some paragrpah style when it comes back" - ExtendedClipboardInterface current - clearClipboard; - addClipboardData: simpleText rtfString dataFormat: 'public.rtf'. - editor paste. - concatenation _ editor text. - self assert: concatenation runs runs size = 2 description: 'Should use imported RTF style'. - self assert: concatenation runs runs first = (heading1Text size +1) description: 'Should apply the "Heading 1" paragraph style to the first part'. - self assert: concatenation runs runs second = simpleText size description: 'Should apply the "Imported " paragraph style to the second part'. - self assert: concatenation runs values first first style name = 'Heading 1'. - self assert: concatenation runs values second first style name = 'Imported '! ! -!StyledTextTest methodsFor: 'tests' stamp: 'jmv 1/3/2017 21:33:11'! - testStylesInPaste5 - " - self new testStylesInPaste5 - " - | heading1Text heading1 simpleText editor textComposition concatenation initialText model innerMorph | - model _ StyledTextModel new. - heading1 _ model styleSet paragraphStyleNamed: 'Heading 1'. - heading1Text _ Text string: 'This is the heading' attribute: (ParagraphStyleReference for: heading1). - simpleText _ 'This is a text without style' asText. - - initialText _ heading1Text copy. - model contents: initialText. - editor _ StyledTextEditor new model: model. - textComposition _ TextComposition new. - textComposition setModel: model; extentForComposing: 300@300. - textComposition composeAll. - innerMorph _ TextModelMorph new textMorph. - innerMorph model: model. - editor morph: innerMorph. - editor textComposition: textComposition; resetState. - - editor deselectAndPlaceCursorAt: initialText size+1. - Clipboard storeObject: String newLineString. editor paste. - "Now we give an text without styles to the Clipboard, and we test that it does include some paragraph style when it comes back" - ExtendedClipboardInterface current - clearClipboard; - addClipboardData: simpleText asString asUtf8 dataFormat: 'public.utf8-plain-text'. - editor paste. - concatenation _ editor text. - self assert: concatenation runs runs size = 1 description: 'Should apply same attributes to the whole text'. - self assert: concatenation runs runs first = concatenation size description: 'Should apply the "Heading 1" paragraph style to all the text'.! ! -!StyledTextTest methodsFor: 'tests' stamp: 'jmv 1/3/2017 21:33:16'! - testStylesInPaste6 - " - self new testStylesInPaste6 - " - | heading1 heading1Text simpleText editor textComposition concatenation initialText model innerMorph | - model _ StyledTextModel new. - heading1 _ model styleSet paragraphStyleNamed: 'Heading 1'. - heading1Text _ Text string: 'This is the heading' attribute: (ParagraphStyleReference for: heading1). - simpleText _ ('This is a text without style', String newLineString) asText. - - initialText _ heading1Text copy. - model contents: initialText. - editor _ StyledTextEditor new model: model. - textComposition _ TextComposition new. - textComposition setModel: model; extentForComposing: 300@300. - textComposition composeAll. - innerMorph _ TextModelMorph new textMorph. - innerMorph model: model. - editor morph: innerMorph. - editor textComposition: textComposition; resetState. - - editor deselectAndPlaceCursorAt: initialText size+1. - Clipboard storeObject: String newLineString. editor paste. - "Now we give an text without styles to the Clipboard, and we test that it does include some paragrpah style when it comes back" - ExtendedClipboardInterface current - clearClipboard; - addClipboardData: simpleText rtfString dataFormat: 'public.rtf'. - editor paste. - concatenation _ editor text. - self assert: concatenation runs runs size = 2 description: 'Should have 2 parts with different attributes'. - self assert: concatenation runs runs first = (heading1Text size + 1) description: 'Should apply the "Heading 1" paragraph style to the first part'. - self assert: concatenation runs runs second = simpleText size description: 'Should apply no paragraph style to the second part'. - self assert: concatenation runs values first size = 1 description: 'Should apply the "Heading 1" paragraph style to the first part'. - self assert: concatenation runs values first first style == heading1 description: 'Should apply the "Heading 1" paragraph style to the first part'. - self deny: concatenation runs values second first style == heading1 description: 'Should not apply the "Heading 1" paragraph style to the second part'! ! -!STECompleter methodsFor: 'entries' stamp: 'jmv 7/14/2011 13:58'! - addEntriesTo: aStream - | s count capitalize | - s _ 400. - count _ 0. - "Capitalize options if user's word is capitalized" - capitalize _ prefix notEmpty and: [ prefix first isUppercase ]. - words forPrefix: prefix keysAndValuesDo: [ :key :value | - count = s - ifTrue: [ ^self ]. - aStream nextPut: (capitalize ifTrue: [key capitalized] ifFalse: [key]). - count _ count + 1 ]! ! -!STECompleter methodsFor: 'initialization' stamp: 'jmv 8/5/2013 10:45'! -clearWords - words _ nil! ! -!STECompleter methodsFor: 'objects from disk' stamp: 'jmv 8/5/2013 10:44'! - comeFullyUpOnReload: smartRefStream - "This is not the proper way to handle multiple dictionaries!!" - - words _ EnglishDict. - ^ self! ! -!STECompleter methodsFor: 'initialization' stamp: 'jmv 7/14/2011 13:58'! - initialize - words _ EnglishDict! ! -!STECompleter methodsFor: 'objects from disk' stamp: 'jmv 8/5/2013 10:45'! - objectForDataStream: refStrm - - ^self shallowCopy clearWords; yourself! ! -!STECompleter methodsFor: 'entries' stamp: 'jmv 9/21/2011 11:14'! - selectedEntry - ^(Text - string: (self entries at: menuMorph selected) - attribute: (CharacterStyleReference new style: model styleSet autoCompletedStyle)), ' '! ! -!STECompleter class methodsFor: 'class initialization' stamp: 'jmv 5/31/2016 11:16'! - initialize - " - STECompleter initialize - An English dictionary with (at this time of writing) 166211 words, taking 7.5Mbytes. - Load a dictionary from (for example) ./scowl-7.1/final/ up to a certain level. - " - | level baseDirectory possibleDirs dirEntry | - level _ 70. - EnglishDict _ Trie new. - baseDirectory := self package fullFileName asFileEntry parent. - possibleDirs := baseDirectory directories select: [ :dir | 'scowl*' match: dir name ] . - possibleDirs ifEmpty: [ - Transcript newLine; show: 'No word list for English spell checker was found.'. - ^self - ]. - dirEntry := possibleDirs detect: [ :dir | dir directoryNames includes: 'final' ]. - dirEntry ifNil: [ - Transcript newLine; show: 'No word list for English spell checker was found.'. - ^self - ]. - dirEntry allFilesDo: [ :fileEntry | | fileLevel | - fileLevel := fileEntry extension asInteger. - ((fileLevel isNil not) and: [fileLevel <= level]) - ifTrue: [ fileEntry readStreamDo: [ :strm | - fileEntry name print. - [ strm atEnd ] whileFalse: [ - strm nextLine substrings do: [ :word | - EnglishDict add: word asLowercase - ] - ] - ] - ] - ]. - - 'Spell Checker importing done.' print.! ! -!RTFStyledTextBuilder methodsFor: 'private' stamp: 'jmv 4/19/2014 19:31'! -addToText: aString specialAttributes: nonFormattingAttributesOrNil - "nonFormattingAttributesOrNil should only contains attributes that answer false to #isForFormatting" - | attributes emphasis ps cs | - - ps _ self paragraphStyle. - emphasis _ 0. - bold ifTrue: [ emphasis _ emphasis + 1 ]. - italic ifTrue: [ emphasis _ emphasis + 2 ]. - underline ifTrue: [ emphasis _ emphasis + 4 ]. - attributes _ Array streamContents: [ :strm | - strm nextPut: (ParagraphStyleReference for: ps). - (fontFamilyName = ps familyName and: [ fontPointSize = ps pointSize and: [ emphasis = ps emphasis and: [ currentFgColor = ps color ]]]) ifFalse: [ - cs _ CharacterStyle new - privateFamilyName: fontFamilyName pointSize: fontPointSize emphasis: emphasis color: currentFgColor. - strm nextPut: (CharacterStyleReference for: cs) ]. - nonFormattingAttributesOrNil ifNotNil: [ strm nextPutAll: nonFormattingAttributesOrNil ]]. - textStream nextPutAllString: aString withAttributes: attributes! ! -!RTFStyledTextBuilder methodsFor: 'building-paragraph' stamp: 'jmv 3/13/2012 16:57'! - finishParagraph - - textStream - nextPutAllString: String newLineString - withAttributes: { ParagraphStyleReference for: self paragraphStyle }. - paragraphStyleInUse _ nil. "So we can build a new one"! ! -!RTFStyledTextBuilder methodsFor: 'private' stamp: 'jmv 8/11/2011 10:40'! - paragraphStyle - "We need a paragraph style to be actually used. - If we don't have it, take whatever is in construction and use it." - | emphasis | - paragraphStyleInUse ifNil: [ - "Build it" - emphasis _ 0. - bold ifTrue: [ emphasis _ emphasis + 1 ]. - italic ifTrue: [ emphasis _ emphasis + 2 ]. - underline ifTrue: [ emphasis _ emphasis + 4 ]. - paragraphStyleInUse _ ParagraphStyle new. - paragraphStyleInUse - privateFamilyName: fontFamilyName pointSize: fontPointSize emphasis: emphasis color: currentFgColor - alignment: align firstIndent: firstIndent+leftIndent restIndent: leftIndent - "nil means that we didn't get any value from rtf. therefore, the +72 is not needed" - rightIndent: (rightIndent ifNil: [ 0 ] ifNotNil: [ rightIndent +72 ]) - spaceBefore: spaceBefore spaceAfter: spaceAfter ]. - ^paragraphStyleInUse! ! -!CharacterStyle methodsFor: 'accessing' stamp: 'jmv 8/26/2009 22:52'! - color - ^color! ! -!CharacterStyle methodsFor: 'accessing' stamp: 'jmv 4/6/2011 16:18'! - emphasis - ^emphasis! ! -!CharacterStyle methodsFor: 'accessing' stamp: 'jmv 4/6/2011 16:18'! - familyName - ^familyName! ! -!CharacterStyle methodsFor: 'accessing' stamp: 'jmv 12/19/2011 13:40'! - font - | base | - base _ (AbstractFont familyName: familyName pointSize: pointSize) ifNil: [ AbstractFont default baseFont ]. - ^base emphasized: emphasis! ! -!CharacterStyle methodsFor: 'initialization' stamp: 'jmv 4/19/2014 11:09'! - initialize - name _ ''. - emphasis _ 0! ! -!CharacterStyle methodsFor: 'comparing' stamp: 'jmv 4/19/2014 11:08'! - isEquivalentTo: aStyle - "Compare all 'functional' attributes. I.e. ignore name." - self class == aStyle class ifFalse: [ ^false ]. - - ^ pointSize = aStyle pointSize and: [ - emphasis = aStyle emphasis and: [ - color = aStyle color and: [ - familyName = aStyle familyName ]]]! ! -!CharacterStyle methodsFor: 'testing' stamp: 'jmv 8/9/2011 10:44'! - isNullStyle - ^ name = '-none-'! ! -!CharacterStyle methodsFor: 'accessing' stamp: 'jmv 8/26/2009 22:52'! - name - ^name! ! -!CharacterStyle methodsFor: 'accessing' stamp: 'jmv 4/6/2011 16:18'! - pointSize - ^pointSize! ! -!CharacterStyle methodsFor: 'accessing' stamp: 'jmv 8/26/2009 22:52'! - printOn: aStream - super printOn: aStream. - aStream space; nextPutAll: self name! ! -!CharacterStyle methodsFor: 'private' stamp: 'jmv 4/19/2014 19:29'! - privateFamilyName: otherString pointSize: aNumber emphasis: otherNumber color: aColor - "To be used from CharacterStyle instance creation methods. - If used on existing instances, existing text will be modified, but in any case, senders are responsible - for updating any text editor using us, or any text that should start using us (i.e. users of a StyleSet to which we are added)." - - familyName _ otherString. - pointSize _ aNumber. - emphasis _ otherNumber. - color _ aColor! ! -!CharacterStyle methodsFor: 'private' stamp: 'jmv 8/11/2011 10:48'! - privateName: aString - "To be used from CharacterStyle instance creation methods. - If used on existing instances, existing text will be modified, but in any case, senders are responsible - for updating any text editor using us, or any text that should start using us (i.e. users of a StyleSet to which we are added)." - name _ aString! ! -!CharacterStyle methodsFor: 'private' stamp: 'jmv 8/11/2011 10:48'! - privatePointSize: aNumber - "To be used from CharacterStyle instance creation methods. - If used on existing instances, existing text will be modified, but in any case, senders are responsible - for updating any text editor using us, or any text that should start using us (i.e. users of a StyleSet to which we are added)." - pointSize _ aNumber! ! -!CharacterStyle methodsFor: 'accessing' stamp: 'jmv 4/7/2011 11:11'! - shortDescription - "note: Does not use all state. Two different instances could answer the same shortDescription." - ^String streamContents: [ :strm | self shortPrintOn: strm ]! ! -!CharacterStyle methodsFor: 'printing' stamp: 'KenD 12/5/2015 08:31'! - shortPrintOn: strm - familyName ifNotNil: [ - strm nextPutAll: familyName ]. - pointSize ifNotNil: [ - strm nextPut: $ . - pointSize printOn: strm]. - (emphasis anyMask: AbstractFont boldCode) ifTrue: [ - strm nextPutAll: ' bold' ]. - (emphasis anyMask: AbstractFont italicCode) ifTrue: [ - strm nextPutAll: ' italic' ]. - (emphasis anyMask: AbstractFont underlinedCode) ifTrue: [ - strm nextPutAll: ' underlined' ]. - (emphasis anyMask: AbstractFont struckThroughCode) ifTrue: [ - strm nextPutAll: ' struckThrough' ]. - (emphasis anyMask: AbstractFont normalCode) ifTrue: [ - strm nextPutAll: ' plain' ]. - color ifNotNil: [ - strm nextPut: $ . - color printOn: strm ]! ! -!CharacterStyle class methodsFor: 'instance creation' stamp: 'jmv 8/9/2011 10:45'! - nullStyle - - ^self new - privateName: '-none-'! ! -!ParagraphStyle methodsFor: 'accessing'! - alignment - "Answer the code for the current setting of the alignment." - - ^alignment! ! -!ParagraphStyle methodsFor: 'accessing' stamp: 'jmv 1/25/2011 13:32'! - doNotShout - doesShout _ false! ! -!ParagraphStyle methodsFor: 'accessing' stamp: 'jmv 1/25/2011 13:32'! - doShout - doesShout _ true! ! -!ParagraphStyle methodsFor: 'accessing' stamp: 'jmv 1/25/2011 13:32'! - doesShout - ^doesShout! ! -!ParagraphStyle methodsFor: 'accessing'! - firstIndent - "Answer the horizontal indenting of the first line of a paragraph in the - style of the receiver." - - ^firstIndent! ! -!ParagraphStyle methodsFor: 'initialization' stamp: 'jmv 8/11/2011 08:08'! - initialize - super initialize. - firstIndent _ restIndent _ rightIndent _ spaceBefore _ spaceAfter _ 0. - listBulletPattern _ nil. - doesShout _ false. - alignment _ 0. - tabsArray _ ParagraphStyle defaultTabsArray! ! -!ParagraphStyle methodsFor: 'comparing' stamp: 'jmv 8/9/2011 15:50'! - isEquivalentTo: aStyle - (super isEquivalentTo: aStyle) ifFalse: [ ^false ]. - - ^alignment = aStyle alignment and: [ - doesShout = aStyle doesShout and: [ - firstIndent = aStyle firstIndent and: [ - restIndent = aStyle restIndent and: [ - rightIndent = aStyle rightIndent and: [ - spaceBefore = aStyle spaceBefore and: [ - spaceAfter = aStyle spaceAfter and: [ - listBulletPattern = aStyle listBulletPattern and: [ - tabsArray = aStyle tabsArray ]]]]]]]]! ! -!ParagraphStyle methodsFor: 'accessing' stamp: 'jmv 9/29/2009 09:39'! - isListStyle - ^listBulletPattern notNil! ! -!ParagraphStyle methodsFor: 'accessing' stamp: 'jmv 9/29/2009 09:15'! - listBulletPattern - "Answer the string patter to be used to display bullets at the start of each line." - - ^listBulletPattern! ! -!ParagraphStyle methodsFor: 'tabs and margins' stamp: 'jmv 6/29/2010 10:03'! - nextTabXFrom: anX leftMargin: leftMargin rightMargin: rightMargin - "Tab stops are distances from the left margin. Set the distance into the - argument, anX, normalized for the paragraph's left margin." - - | normalizedX tabX | - - "Doing columns (i.e. using tabsArray) only makes sense if left flush. Otherwise, just answer a wider space" - - alignment = CharacterScanner leftFlushCode ifFalse: [ - ^anX + self tabWidth min: rightMargin ]. - - normalizedX _ anX - leftMargin. - 1 to: tabsArray size do: - [:i | (tabX _ tabsArray at: i) > normalizedX - ifTrue: [^leftMargin + tabX min: rightMargin]]. - ^rightMargin! ! -!ParagraphStyle methodsFor: 'private' stamp: 'jmv 4/19/2014 19:30'! - privateFamilyName: aString pointSize: aNumber emphasis: otherNumber color: aColor alignment: code - "To be used from ParagraphStyle instance creation methods. - If used on existing instances, existing text will be modified, but in any case, senders are responsible - for updating any text editor using us, or any text that should start using us (i.e. users of a StyleSet to which we are added)." - familyName _ aString. - pointSize _ aNumber. - emphasis _ otherNumber. - color _ aColor. - alignment _ code. -" tabsArray _ ParagraphStyle defaultTabsArray." -" firstIndent _ fi. - restIndent _ ri. - rightIndent _ rri. - spaceBefore _ sb. - spaceAfter _ sa." -" listBulletPattern - doesShout"! ! -!ParagraphStyle methodsFor: 'private' stamp: 'jmv 4/19/2014 19:30'! - privateFamilyName: aString pointSize: aNumber emphasis: otherNumber color: aColor alignment: code firstIndent: fi restIndent: ri rightIndent: rri spaceBefore: sb spaceAfter: sa - "To be used from ParagraphStyle instance creation methods. - If used on existing instances, existing text will be modified, but in any case, senders are responsible - for updating any text editor using us, or any text that should start using us (i.e. users of a StyleSet to which we are added)." - familyName _ aString. - pointSize _ aNumber. - emphasis _ otherNumber. - color _ aColor. - alignment _ code. -" tabsArray _ ParagraphStyle defaultTabsArray." - firstIndent _ fi. - restIndent _ ri. - rightIndent _ rri. - spaceBefore _ sb. - spaceAfter _ sa. -" listBulletPattern - doesShout"! ! -!ParagraphStyle methodsFor: 'private' stamp: 'jmv 8/11/2011 10:49'! - privateListBulletPattern: aString - "If this is notNil, then this style is a Bullet List Style - Some examples are: - '%. ' -> '1. ' '2. ' etc. - 'z) ' -> 'a) ' 'b) ' etc. - 'Z- ' -> 'A- ' 'B- ' etc - " - "To be used from ParagraphStyle instance creation methods. - If used on existing instances, existing text will be modified, but in any case, senders are responsible - for updating any text editor using us, or any text that should start using us (i.e. users of a StyleSet to which we are added)." - - listBulletPattern _ aString! ! -!ParagraphStyle methodsFor: 'accessing'! - restIndent - "Answer the indent for all but the first line of a paragraph in the style - of the receiver." - - ^restIndent! ! -!ParagraphStyle methodsFor: 'accessing'! - rightIndent - "Answer the right margin indent for the lines of a paragraph in the style - of the receiver." - - ^rightIndent! ! -!ParagraphStyle methodsFor: 'printing' stamp: 'jmv 4/7/2011 11:11'! - shortPrintOn: strm - "note: Does not use all state. Two different instances could print the same." - - super shortPrintOn: strm. - - alignment > 0 ifTrue: [ - strm nextPut: $ . - strm nextPutAll: (#(right centered justified) at: alignment) ]! ! -!ParagraphStyle methodsFor: 'accessing' stamp: 'jmv 4/7/2011 11:15'! - spaceAfter - ^spaceAfter! ! -!ParagraphStyle methodsFor: 'accessing' stamp: 'jmv 4/7/2011 11:14'! -spaceBefore - ^spaceBefore! ! -!ParagraphStyle methodsFor: 'tabs and margins' stamp: 'jmv 7/27/2009 13:05'! - tabWidth - "Answer the width of a tab." - - ^ParagraphStyle defaultTab! ! -!ParagraphStyle methodsFor: 'accessing' stamp: 'jmv 4/7/2011 13:44'! - tabsArray - ^tabsArray! ! -!ParagraphStyle class methodsFor: 'constants' stamp: 'jmv 7/27/2009 13:05'! - defaultTab - ^24! ! -!ParagraphStyle class methodsFor: 'constants' stamp: 'jmv 7/27/2009 13:07'! - defaultTabsArray - ^#(24 48 72 96 120 144 168 192 216 240 264 288 312 336 360 384 408 432 456 480 504 528 552 576 600 624 648 672 696 720 744 768 792 816 840 864 888 912 936 960 984 1008 1032 1056 1080 1104 1128 1152 1176 1200 1224 1248 1272 1296 1320 1344 1368 1392 1416 1440 1464 1488 1512 1536 1560)! ! -!StyledTextBuilder methodsFor: 'building' stamp: 'jmv 1/25/2011 14:32'! - , aString - "Add aString to the Text we are building, using current style." - textStream - nextPutAllString: aString - withAttributes: - (characterStyleStack isEmpty - ifTrue: [ #() ] - ifFalse: [ {CharacterStyleReference for: (styleDict at: characterStyleStack last)} ])! ! -!StyledTextBuilder methodsFor: 'building' stamp: 'jmv 10/16/2013 21:40'! - / aParagraphStyleKey - "Finish the current paragraph (adding a newLine). Apply a ParagraphStyle to it. " - textStream - nextPutAllString: String newLineString - withAttributes: {ParagraphStyleReference for: (styleDict at: aParagraphStyleKey)}! ! -!StyledTextBuilder methodsFor: 'building' stamp: 'jmv 1/25/2011 14:31'! - < aCharacterStyleKey - "Add a new CharacterStyle to the stack. This is the new current style. - aKey is for accessing the styles dictionary that was given on setup." - characterStyleStack addLast: aCharacterStyleKey! ! -!StyledTextBuilder methodsFor: 'building' stamp: 'jmv 1/25/2011 14:32'! -> aString - "We finished using the CharacterStyle that was last set. Remove it from the stack, to go on with the previous one. Then, add aString to the text being built." - characterStyleStack removeLast. - self , aString! ! -!StyledTextBuilder methodsFor: 'building' stamp: 'jmv 10/16/2013 21:40'! - >/ aParagraphStyleKey - "Stop using the CharacterStyle that was added last. - Finish the current paragraph (adding a newLine). Apply a ParagraphStyle to it. - The effect is the same as sending - > '' - / aParagraphStyleKey" - characterStyleStack removeLast. - self / aParagraphStyleKey! ! -!StyledTextBuilder methodsFor: 'building' stamp: 'jmv 1/25/2011 14:31'! - >< aCharacterStyleKey - "Stop using the CharacterStyle that was added last, and start using a new one. - The effect is the same as sending - > '' - < aCharacterStyleKey - but the implementation is optimized" - characterStyleStack at: characterStyleStack size put: aCharacterStyleKey! ! -!StyledTextBuilder methodsFor: 'accessing' stamp: 'jmv 1/3/2017 21:10:04'! - styles: aDictionary - styleDict _ aDictionary. - characterStyleStack _ OrderedCollection new. - textStream _ WriteStream on: (Text string: (String new: 400))! ! -!StyledTextBuilder methodsFor: 'accessing' stamp: 'jmv 9/9/2010 09:05'! - text - ^textStream contents! ! -!StyledTextBuilder class methodsFor: 'examples' stamp: 'jmv 8/10/2011 10:44'! - example1 - " - StyledTextBuilder example1 - " - | model heading3 green14 red10Bold green11Italic t | - model _ StyledTextModel new. - heading3 _ model styleSet paragraphStyleNamed: 'Heading 3'. - green14 _ model styleSet characterStyleNamed: 'Green 14'. - red10Bold _ model styleSet characterStyleNamed: 'Red 10 bold'. - green11Italic _ model styleSet characterStyleNamed: 'Green 11 Italic'. - t _ Text - buildWithStyles: ({ - #H3 -> heading3. - #g14 -> green14. - #r10b -> red10Bold. - #g11i -> green11Italic - } as: Dictionary) - contents: [ :builder | - builder , 'Starts as Heading 3. But later gets' < #g14 , ' big and green' , ' and stays like that. Then' >< #r10b , ' red & bold and inside this,' < #g11i , ' green and italic' > ' for a while. Later' > ' back to Heading 3.' / #H3]. - - model contents: t. - SystemWindow editFancierStyledText: model label: 'Styled Text Editor'! ! -!StyledTextBuilder class methodsFor: 'examples' stamp: 'jmv 8/10/2011 10:43'! - example2 - " - StyledTextBuilder example2 - " - |model heading1 heading2 heading3 emphasized normal green14 red10Bold green11Italic t | - model _ StyledTextModel new. - heading1 _ model styleSet paragraphStyleNamed: 'Heading 1'. - heading2 _ model styleSet paragraphStyleNamed: 'Heading 2'. - heading3 _ model styleSet paragraphStyleNamed: 'Heading 3'. - emphasized _ model styleSet paragraphStyleNamed: 'Emphasized'. - normal _ model styleSet paragraphStyleNamed: 'Normal'. - green14 _ model styleSet characterStyleNamed: 'Green 14'. - red10Bold _ model styleSet characterStyleNamed: 'Red 10 bold'. - green11Italic _ model styleSet characterStyleNamed: 'Green 11 Italic'. - t _ Text - buildWithStyles: ({ - #H1 -> heading1. - #H2 -> heading2. - #H3 -> heading3. - #E -> emphasized. - #N -> normal. - #g14 -> green14. - #r10b -> red10Bold. - #g11i -> green11Italic - } as: Dictionary) - contents: [ :builder | - builder, - 'This is the main title' / #H1, - 'This is the title of level 2' / #H2, - 'This is title 3' / #H3, - 'Then, we have some normal text. But later gets' < #g14 , ' big and green' , ' and stays like that. Then' >< #r10b , ' red & bold and inside this,' < #g11i , ' green and italic' > ' for a while.' > ' Lets make this look like a paragraph, i.e. add enough text so that we''l be using more than one display line. Is this enough? Who knows... Let''s add a bit more. Maybe this is enough.' / #N, - 'This is an emphasized paragraph. It uses a Paragraph Style, not a Character Style, and therefore it has the same style all over the paragraph' / #E, - 'This' < #r10b, ' is' > ' again a' < #g14, ' title 2' >/ #H2, - 'And now another paragraph. This one may be smaller than previous ones' / #N ]. - model contents: t. - SystemWindow editFancierStyledText: model label: 'Styled Text Editor'! ! -!SampleListModel methodsFor: 'as yet unclassified' stamp: 'jmv 9/16/2009 10:35'! - initialize - sel _ 3! ! -!SampleListModel methodsFor: 'as yet unclassified' stamp: 'jmv 9/16/2009 14:39'! - list - ^#('first' 'second' 'third' 'first' 'second' 'third''first' 'second' 'third''first' 'second' 'third''first' 'second' 'third''first' 'second' 'third''first' 'second' 'third''first' 'second' 'third''first' 'second' 'third')! ! -!SampleListModel methodsFor: 'as yet unclassified' stamp: 'jmv 9/16/2009 10:09'! - sel -^sel! ! -!SampleListModel methodsFor: 'as yet unclassified' stamp: 'jmv 9/16/2009 10:35'! - sel:x -sel _ x. -self changed: #list - -" -(PluggableListMorph - on: SampleListModel new - list: #list - selected: #sel - changeSelected: #sel:) autoDeselect: false; openInWorld -"! ! - -STECompleter initialize! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-StyledTextEditor/StyledText.pck.st----! - -'From Cuis 4.2 of 25 July 2013 [latest update: #1823] on 11 September 2013 at 12:05:22.900264 am'! - -'Description Please enter a description for this package.'! - -Object subclass: #StyledTextWiki - instanceVariableNames: 'textModel pages currentPage' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledTextWiki'! - -!classDefinition: #StyledTextWiki category: #StyledTextWiki! -Object subclass: #StyledTextWiki - instanceVariableNames: 'textModel pages currentPage' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledTextWiki'! - -StyledTextWiki class - instanceVariableNames: ''! - -!classDefinition: 'StyledTextWiki class' category: #StyledTextWiki! -StyledTextWiki class - instanceVariableNames: ''! - -Object subclass: #StyledTextWikiEditor - instanceVariableNames: 'wiki textModel textMorph' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledTextWiki'! - -!classDefinition: #StyledTextWikiEditor category: #StyledTextWiki! -Object subclass: #StyledTextWikiEditor - instanceVariableNames: 'wiki textModel textMorph' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledTextWiki'! - -StyledTextWikiEditor class - instanceVariableNames: ''! - -!classDefinition: 'StyledTextWikiEditor class' category: #StyledTextWiki! -StyledTextWikiEditor class - instanceVariableNames: ''! - -Object subclass: #StyledTextWikiPage - instanceVariableNames: 'wiki text' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledTextWiki'! - -!classDefinition: #StyledTextWikiPage category: #StyledTextWiki! -Object subclass: #StyledTextWikiPage - instanceVariableNames: 'wiki text' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledTextWiki'! - -StyledTextWikiPage class - instanceVariableNames: ''! - -!classDefinition: 'StyledTextWikiPage class' category: #StyledTextWiki! -StyledTextWikiPage class - instanceVariableNames: ''! -!StyledTextWikiEditor commentStamp: 'bp 12/18/2011 18:09' prior: 0! - (StyledTextWikiEditor wiki: StyledTextWiki new) morphicWindow openInWorld! -!StyledTextWiki methodsFor: 'as yet unclassified' stamp: 'bp 10/24/2010 16:58'! - currentPage - ^currentPage! ! -!StyledTextWiki methodsFor: 'as yet unclassified' stamp: 'bp 10/24/2010 17:00'! - currentPageIndex - ^pages indexOf: currentPage! ! -!StyledTextWiki methodsFor: 'as yet unclassified' stamp: 'jmv 8/10/2011 10:55'! - currentPageIndex: anInteger - currentPage := pages at: anInteger. - textModel actualContents: currentPage text! ! -!StyledTextWiki methodsFor: 'as yet unclassified' stamp: 'jmv 8/10/2011 10:56'! -initialize - | heading1 | - textModel _ StyledTextModel new. - heading1 _ textModel styleSet paragraphStyleNamed: 'Heading 1'. - pages := OrderedCollection new. - currentPage := self newPage: ( - Text - string: 'Welcome to the Styled Text Wiki!!' - attribute: (ParagraphStyleReference for: heading1)). - textModel actualContents: currentPage text! ! -!StyledTextWiki methodsFor: 'as yet unclassified' stamp: 'jmv 1/13/2012 14:03'! - newPage - | normal | - normal _ textModel styleSet defaultStyle. - currentPage := self newPage: - (Text string: '' attribute: (ParagraphStyleReference for: normal)). - textModel actualContents: currentPage text! ! -!StyledTextWiki methodsFor: 'as yet unclassified' stamp: 'bp 10/24/2010 16:47'! - newPage: aText - ^pages add: ((StyledTextWikiPage wiki: self) - text: aText; - yourself)! ! -!StyledTextWiki methodsFor: 'as yet unclassified' stamp: 'bp 10/24/2010 16:39'! - pageNames - ^pages collect: [:each | each name]! ! -!StyledTextWiki methodsFor: 'as yet unclassified' stamp: 'jmv 8/10/2011 10:53'! - textModel - ^textModel! ! -!StyledTextWikiEditor methodsFor: 'as yet unclassified' stamp: 'jmv 9/11/2013 00:01'! - createMorph - | appMorph pagesList newPageButton toolbar | - textModel := StyledTextModel withText: wiki currentPage text. - appMorph := PluggableStyledTextMorph withModel: textModel in: STEMainMorph newColumn. - textMorph := appMorph submorphs first. - pagesList := PluggableFilteringDropDownListMorph - model: self - listGetter: #pageNames - indexGetter: #currentPageIndex - indexSetter: #currentPageIndex:. - pagesList - borderWidth: 0; - layoutSpec: (LayoutSpec morphHeightProportionalWidth: 0.5). - newPageButton := PluggableButtonMorph model: self action: #newPage. - newPageButton - morphExtent: 22@22; - icon: Theme current newIcon; - layoutSpec: LayoutSpec keepMorphExtent. - toolbar := appMorph submorphs last. - toolbar addMorphBack: newPageButton. - toolbar addMorphBack: pagesList. "add it at the left of the layout" - textMorph when: #possiblyChanged send: #modelChanged to: pagesList. - ^appMorph! ! -!StyledTextWikiEditor methodsFor: 'as yet unclassified' stamp: 'bp 10/24/2010 17:00'! - currentPageIndex - ^wiki currentPageIndex! ! -!StyledTextWikiEditor methodsFor: 'as yet unclassified' stamp: 'bp 7/8/2011 22:49'! -currentPageIndex: anInteger - self updateCurrentPage. - wiki currentPageIndex: anInteger. - textModel actualContents: wiki currentPage text! ! -!StyledTextWikiEditor methodsFor: 'as yet unclassified' stamp: 'jmv 5/24/2011 11:00'! - morphicWindow - | window | - window _ SystemWindow new model: self. - window setLabel: 'Styled Text Wiki'. - window layoutMorph - addMorph: (self createMorph) - proportionalHeight: 1. - ^ window! ! -!StyledTextWikiEditor methodsFor: 'as yet unclassified' stamp: 'bp 7/8/2011 23:11'! - newPage - | selection pageName | - selection := textMorph selectionInterval. - pageName := textModel actualContents copyFrom: selection first to: selection last. - textMorph currentCharacterStyleIndex: 1. - wiki newPage. - textModel actualContents: pageName. - self updateCurrentPage. - textMorph - selectAll; - currentParagraphStyleIndex: 3! ! -!StyledTextWikiEditor methodsFor: 'as yet unclassified' stamp: 'bp 7/8/2011 22:49'! - pageNames - ^wiki pageNames! ! -!StyledTextWikiEditor methodsFor: 'as yet unclassified' stamp: 'bp 10/24/2010 16:58'! - setWiki: aStyledTextWiki - wiki := aStyledTextWiki! ! -!StyledTextWikiEditor methodsFor: 'as yet unclassified' stamp: 'jmv 1/6/2012 12:03'! - updateCurrentPage - textMorph textMorph acceptContents. - wiki currentPage text: textModel actualContents! ! -!StyledTextWikiEditor class methodsFor: 'as yet unclassified' stamp: 'bp 10/24/2010 16:56'! - wiki: aStyledTextWiki - ^self new setWiki: aStyledTextWiki! ! -!StyledTextWikiPage methodsFor: 'as yet unclassified' stamp: 'jmv 3/14/2012 08:27'! - name - | string | - string _ self text asString lines first. - string size > 30 ifTrue: [ - string _ string copyFrom: 1 to: 30 ]. - string ifEmpty: [ ^ '(Empty page)' ]. - ^ string! ! -!StyledTextWikiPage methodsFor: 'as yet unclassified' stamp: 'jmv 1/13/2012 14:03'! - setWiki: aStyledTextWiki - | normal | - wiki := aStyledTextWiki. - normal _ wiki textModel styleSet defaultStyle. - text := Text string: '' attribute: (ParagraphStyleReference for: normal)! ! -!StyledTextWikiPage methodsFor: 'as yet unclassified' stamp: 'bp 10/24/2010 16:17'! - text - ^text! ! -!StyledTextWikiPage methodsFor: 'as yet unclassified' stamp: 'bp 10/24/2010 16:45'! - text: aText - text := aText! ! -!StyledTextWikiPage class methodsFor: 'as yet unclassified' stamp: 'bp 10/24/2010 16:56'! - wiki: aStyledTextWiki - ^self new setWiki: aStyledTextWiki! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-StyledTextEditor/StyledTextWiki.pck.st----! - -'From Cuis 4.2 of 25 July 2013 [latest update: #2781] on 31 May 2016 at 12:07:04.27849 pm'! - -'Description Please enter a description for this package.'! - -Object subclass: #BpStyledTextNotebook - instanceVariableNames: '' - classVariableNames: 'AppMorph Filename MyModel SaveIcon' - poolDictionaries: '' - category: 'StyledTextNotebook'! - -!classDefinition: #BpStyledTextNotebook category: #StyledTextNotebook! -Object subclass: #BpStyledTextNotebook - instanceVariableNames: '' - classVariableNames: 'AppMorph Filename MyModel SaveIcon' - poolDictionaries: '' - category: 'StyledTextNotebook'! - -BpStyledTextNotebook class - instanceVariableNames: ''! - -!classDefinition: 'BpStyledTextNotebook class' category: #StyledTextNotebook! -BpStyledTextNotebook class - instanceVariableNames: ''! -!BpStyledTextNotebook class methodsFor: 'StyledText Notebook' stamp: 'jmv 9/11/2013 00:17'! - createModelAndView - " - BpStyledTextNotebook createModelAndView - " - - | saveButton topRow w | - MyModel _ StyledTextModel new. - AppMorph _ PluggableStyledTextMorph withModel: MyModel in: STEMainMorph newColumn. - AppMorph adoptWidgetsColor: MyModel class windowColor. - saveButton _ (PluggableButtonMorph model: self action: #save) - morphExtent: 22@22; - icon: self saveIcon; - layoutSpec: LayoutSpec keepMorphExtent; - yourself. - topRow _ AppMorph submorphs last. - topRow addMorphBack: saveButton. - - w _ PasteUpMorph someInstance. - AppMorph morphBoundsInWorld: w morphBoundsInWorld. - w addMorph: AppMorph. - AppMorph startStepping! ! -!BpStyledTextNotebook class methodsFor: 'StyledText Notebook' stamp: 'jmv 9/11/2013 00:33'! - install - " - BpStyledTextNotebook install - Preferences enable: #focusFollowsMouse - " - | newName | - Preferences disable: #focusFollowsMouse. - Preferences disable: #commandClickOpensHalo. - Smalltalk addToStartUpList: self. - - Filename _ 'StyledText.object'. - PasteUpMorph allInstancesDo: [ :w | - w submorphs copy do: [ :m | m delete ]. - w color: Color white ]. - - self createModelAndView. - - "Save image" - newName _ 'StyledTextEditor.image'. - " - (SourceFiles at: 2) ifNotNil: [ - Smalltalk - closeSourceFiles; ""so copying the changes file will always work"" - saveChangesInFileNamed: (Smalltalk fullNameForChangesNamed: newName)]. - Smalltalk saveImageInFileNamed: newName - " - Smalltalk saveAs: newName! ! -!BpStyledTextNotebook class methodsFor: 'StyledText Notebook' stamp: 'jmv 1/6/2012 14:17'! - save - "Maybe we're still saving too much... - Besides, check if new instances of ParagraphStyle et al are created on startup..." - MyModel saveAs: Filename! ! -!BpStyledTextNotebook class methodsFor: 'StyledText Notebook' stamp: 'jmv 3/11/2011 17:39'! - saveIcon - "Created using: - Clipboard default storeObject: - ((PNGReadWriter bytesFor: (Form fromFileNamed: 'Save.png')) asString base64Encoded) - " - SaveIcon ifNil: [ SaveIcon _ Form fromBinaryStream: 'iVBORw0KGgoAAAANSUhEUgAAABQAAAAUCAYAAACNiR0NAAACjElEQVR4Xq3UXUhaYRwG8HNd -aZmk6WrmGkbWytJdlJgTuq3RaAPJm9ZY+wrHYrYPvPNqI02Z0EZjFycH3W6apqkgxDZiW4PR -xQi2XeximbAgkNHFM/9vKOcgywkTHt9zDs/58Z7X98il02mk/2M4+pqfn4fb7cbg4CB8Ph+m -bs3BMjpVlqHzV0u54nzAugaDAcPDw7gwNnYEplIpTE9P4/nSEsxmMw4PD8FHt3Dp3stjQx3q -6vV6nLNaoVQqQRYDR0dGMOdyoaOjA/l8vqooFQroOzshk8mOwGQyCevQEBwTE1Cr1Tg4OKgq -BGm1WkilUpDFra+vw2KxwG63Q61SYX9/H5lMBsFg8NhQh7qyhgZo29oYSBaXSCREYC6XqypC -kCwuHo+LwGw2y6bu9/uPDXWoKwTJ4tbW1kTg7u5uxfwUHAtBssrAlZWVf0Ip1C0DY7FYCdTp -dJA3NlYV2n9FkCwRaDIacbq9vapoNBoxGI1Gy8BHjxfw/uM2y+ftHXz9/gN7e78KG/k36LPM -L+OsyYQz3d0ikCxudXW1DCxCPB/Cxpu3JYhGgr/sfGM9QoUgWQwcGBjAxfFxGPv7WbE4o9ra -WhYh9G7zE5Kpjb+DkUgE3YWp22w2VjpVeI2KMyqukxCKxtJ4HUkwqLenBydbW9mxRCIBWVw4 -HMaJwjvc1dXF3mVVc3NpRq0tLSxCiEY6l8vlDFI0NbFfmp6ELI7neVyenGR7sL6+HnV1ddj8 -sMXW0FhY074+owh6FY7j6bMXqKmpYY9JfRrpnCwuEAjA6/XC4XCwix6PB665hyzXrs/gxk0n -ZpyzuH3Hhdm799l178ITdg916R5Kf2H9yeJCoRAWFxcr/rtUChlk/QGoFPNClwN64wAAAABJ -RU5ErkJggg==' base64Decoded asByteArray readStream ]. - ^SaveIcon! ! -!BpStyledTextNotebook class methodsFor: 'StyledText Notebook' stamp: 'jmv 5/31/2016 11:15'! - startUp - - [ - MyModel _ Filename asFileEntry readStreamDo: [ :strm | - (SmartRefStream on: strm) next ]. - AppMorph submorphs first - model: MyModel; - possiblyChanged - ] on: FileDoesNotExistException do: nil.! ! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-StyledTextEditor/StyledTextNotebook.pck.st----! - -'From Cuis 4.2 of 25 July 2013 [latest update: #2710] on 1 April 2016 at 2:13:03.062542 pm'! - -'Description '! - -Object subclass: #StyledTextInstaller - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledTextInstaller'! - -!classDefinition: #StyledTextInstaller category: #StyledTextInstaller! -Object subclass: #StyledTextInstaller - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'StyledTextInstaller'! - -StyledTextInstaller class - instanceVariableNames: ''! - -!classDefinition: 'StyledTextInstaller class' category: #StyledTextInstaller! -StyledTextInstaller class - instanceVariableNames: ''! -!StyledTextInstaller methodsFor: 'private' stamp: 'bp 12/4/2011 09:14'! - createStyledTextEditorDocumentation - "self new createStyledTextEditorDocumentation" - | model styleSet | - model _ StyledTextModel new. - SystemWindow - editFancierStyledText: model - label: 'Styled Text Editor Documentation'. - styleSet _ model styleSet. - styleSet - createDocumentationParagraphStyleSet; - createDocumentationCharacterStyleSet! ! -!StyledTextInstaller methodsFor: 'private' stamp: 'KenD 12/4/2015 21:03'! - documentsDirectory - ^(self repositoryDirectory) / 'Documents'! ! -!StyledTextInstaller methodsFor: 'features' stamp: 'bp 4/21/2012 14:58'! - featuresModelNames - ^#('STE - New Features' 'STE - Done Features' 'Cuis Features')! ! -!StyledTextInstaller methodsFor: 'private' stamp: 'KenD 12/4/2015 21:23'! -open: name - | fileName model | - fileName _ ((self documentsDirectory) // name) pathName. - model _ StyledTextModel fromFileNamed: fileName. - ^SystemWindow editFancierStyledText: model label: name! ! -!StyledTextInstaller methodsFor: 'public' stamp: 'bp 12/4/2011 10:10'! - openExamples - "self new openExamples" - self - openStyledTextEditorDocumentation; - openMacbethExample! ! -!StyledTextInstaller methodsFor: 'public' stamp: 'jmv 8/9/2014 10:55'! - openMacbethExample - "self new openMacbethExample" - | window | - window _ self open: 'Macbeth Example'. - window ifNotNil: [window widgetsColor: Color white]! ! -!StyledTextInstaller methodsFor: 'public' stamp: 'bp 4/5/2012 23:24'! - openStyledTextEditorDocumentation - "self new openStyledTextEditorDocumentation" - self open: 'Styled Text Editor Documentation'! ! -!StyledTextInstaller methodsFor: 'features' stamp: 'bp 12/7/2011 02:06'! - openStyledTextEditorFeatures - "self new openStyledTextEditorFeatures" - self featuresModelNames do: [:each | self open: each]! ! -!StyledTextInstaller methodsFor: 'public' stamp: 'bp 12/4/2011 10:06'! - recreateDocumentationStyleSet - "self new recreateDocumentationStyleSet" - | model styleSet | - model _ self styledTextModelNamed: 'Styled Text Editor Documentation'. - styleSet _ model styleSet. - styleSet - createDocumentationParagraphStyleSet; - createDocumentationCharacterStyleSet! ! -!StyledTextInstaller methodsFor: 'features' stamp: 'bp 12/7/2011 02:08'! - recreateFeaturesStyleSet - "self new recreateFeaturesStyleSet" - self featuresModelNames do: [:each | - | model styleSet | - model _ self styledTextModelNamed: each. - styleSet _ model styleSet. - styleSet - createFeaturesParagraphStyleSet; - createFeaturesCharacterStyleSet]! ! -!StyledTextInstaller methodsFor: 'private' stamp: 'KenD 12/4/2015 20:56'! - repositoryDirectory - ^(self class package fullFileName asFileEntry parent)! ! -!StyledTextInstaller methodsFor: 'private' stamp: 'jmv 4/1/2016 14:01'! - save: name - | model | - model _ self styledTextModelNamed: name. - model saveAs: (self documentsDirectory // name) pathName! ! -!StyledTextInstaller methodsFor: 'public' stamp: 'bp 8/10/2013 14:08'! - saveMacbethExample - "self new saveMacbethExample" - self save: 'Macbeth Example'! ! -!StyledTextInstaller methodsFor: 'public' stamp: 'bp 12/4/2011 09:40'! - saveStyledTextEditorDocumentation - "self new saveStyledTextEditorDocumentation" - self save: 'Styled Text Editor Documentation'! ! -!StyledTextInstaller methodsFor: 'features' stamp: 'bp 12/7/2011 02:07'! - saveStyledTextEditorFeatures - "self new saveStyledTextEditorFeatures" - self featuresModelNames do: [:each | self save: each]! ! -!StyledTextInstaller methodsFor: 'private' stamp: 'bp 12/4/2011 09:59'! - styledTextModelNamed: name - | window | - window _ SystemWindow allInstances detect: [:each | each label = name]. - ^window model! ! -!StyledTextInstaller class methodsFor: 'class initialization' stamp: 'jmv 7/17/2013 09:55'! - initialize - " - StyledTextInstaller initialize - " - STETheme beCurrent. - self new openExamples! ! - -StyledTextInstaller initialize! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-StyledTextEditor/StyledTextInstaller.pck.st----! -!StyledTextModel methodsFor: 'Shout Styling' stamp: 'jmv 9/9/2017 16:15:15'! - formatAndStyleIfNeededWith: anSHTextStyler - - | toStyle | - anSHTextStyler ifNotNil: [ - (self shouldStyle: self actualContents with: anSHTextStyler) ifTrue: [ - self actualContents paragraphStyleChunksDo: [ :interval :paragraphStyle | - paragraphStyle ifNotNil: [ paragraphStyle doesShout ifTrue: [ - toStyle _ actualContents copyFrom: interval first to: interval last. - anSHTextStyler formatAndStyle: toStyle allowBackgroundStyleProcess: false. - actualContents replaceFrom: interval first to: interval last with: anSHTextStyler formattedText ]]]]]! ! -!StyledTextModel methodsFor: 'Shout Styling' stamp: 'jmv 9/9/2017 16:12:55'! - shouldStyle: text with: anSHTextStyler - "This is a notification that aSHTextStyler is about to re-style its text." - - anSHTextStyler classOrMetaClass: nil. - ^true! ! - -StyledTextModel removeSelector: #formatAndStyleWith:! - -StyledTextModel removeSelector: #shoutAboutToStyle:! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'jmv 9/9/2017 15:55:48'! - withNextDo: twoArgBlock - "Evaluate the block with each element and the one following it. - For the last element, next is nil - (1 to: 10) asArray withNextDo: [ :each :next | {each. next} print ] - " - | first previous | - first _ true. - self do: [ :each | - first ifTrue: [ - first _ false ] - ifFalse: [ - twoArgBlock value: previous value: each ]. - previous _ each ]. - twoArgBlock value: previous value: nil! ! -!SequenceableCollection methodsFor: 'enumerating' stamp: 'jmv 9/9/2017 15:58:15'! - withPreviousDo: twoArgBlock - "Evaluate the block with each element and the one before it. - For the first element, previous is nil - (1 to: 10) asArray withPreviousDo: [ :each :previous | {previous. each} print ] - " - | previous | - previous _ nil. - self do: [ :each | - twoArgBlock value: each value: previous. - previous _ each ].! ! - -!classDefinition: #TextBackgroundColor category: #'System-TextAttributes'! -TextAttribute subclass: #TextBackgroundColor - instanceVariableNames: 'color' - classVariableNames: '' - poolDictionaries: '' - category: 'System-TextAttributes'! -!TextBackgroundColor commentStamp: '' prior: 0! - A TextColor encodes a text color change applicable over a given range of text.! -!TextBackgroundColor methodsFor: 'accessing' stamp: 'jmv 9/7/2017 16:41:55'! - color - ^ color! ! -!TextBackgroundColor methodsFor: 'accessing' stamp: 'jmv 9/7/2017 16:41:55'! - color: aColor - color _ aColor! ! -!TextBackgroundColor methodsFor: 'comparing' stamp: 'jmv 9/7/2017 16:41:55'! - = other - self == other ifTrue: [ ^ true ]. - ^ (other class == self class) - and: [other color = color]! ! -!TextBackgroundColor methodsFor: 'comparing' stamp: 'jmv 9/7/2017 16:41:55'! - hash - ^ color hash! ! -!TextBackgroundColor methodsFor: 'printing' stamp: 'jmv 9/7/2017 16:41:55'! - printOn: strm - super printOn: strm. - strm nextPutAll: ' code: '; print: color! ! -!TextBackgroundColor methodsFor: 'scanning' stamp: 'jmv 9/7/2017 16:41:55'! - dominates: other - ^ other class == self class! ! -!TextBackgroundColor methodsFor: 'iterating' stamp: 'jmv 9/7/2017 16:45:12'! - forTextBackgroundColorDo: aBlock - aBlock value: color! ! -!TextBackgroundColor methodsFor: 'testing' stamp: 'jmv 9/7/2017 16:44:40'! - isSet - "Do not include Color black, as it is the default color." - ^color isTransparent not! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - black - ^ self new color: Color black! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - blue - ^ self new color: Color blue! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - cyan - ^ self new color: Color cyan! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - gray - ^ self new color: Color gray! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - green - ^ self new color: Color green! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - magenta - ^ self new color: Color magenta! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - red - ^ self new color: Color red! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - white - ^ self new color: Color white! ! -!TextBackgroundColor class methodsFor: 'constants' stamp: 'jmv 9/7/2017 16:41:55'! - yellow - ^ self new color: Color yellow! ! -!TextBackgroundColor class methodsFor: 'instance creation' stamp: 'jmv 9/7/2017 16:41:55'! - color: aColor - ^ self new color: aColor! ! - -!classDefinition: #ShoutTextBackgroundColor category: #'System-TextAttributes'! -TextBackgroundColor subclass: #ShoutTextBackgroundColor - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'System-TextAttributes'! -!ShoutTextBackgroundColor commentStamp: '' prior: 0! - Just for code styler (Shout)! -!ShoutTextBackgroundColor methodsFor: 'testing' stamp: 'jmv 9/7/2017 16:42:03'! - isForShout - "True if to be removed from code before styling" - ^true! ! -!TextBackgroundColor commentStamp: '' prior: 50399844! - A TextBackgroundColor encodes a highlight (background) color change applicable over a given range of text.! - -!classDefinition: #MorphicScanner category: #'Graphics-Text'! -CharacterScanner subclass: #MorphicScanner - instanceVariableNames: 'canvas lineY foregroundColor defaultColor topLeft backgroundColor' - classVariableNames: '' - poolDictionaries: '' - category: 'Graphics-Text'! -!TextAttribute methodsFor: 'iterating' stamp: 'jmv 9/7/2017 16:45:20'! - forTextBackgroundColorDo: aBlock - "No action is the default"! ! -!CharacterScanner methodsFor: 'private' stamp: 'jmv 9/7/2017 17:00:23'! - backgroundColor: ignored - "Overridden in MorphicScanner"! ! -!MorphicScanner methodsFor: 'private' stamp: 'jmv 9/7/2017 16:56:38'! - backgroundColor: aColor - backgroundColor _ aColor! ! -!Text methodsFor: 'emphasis' stamp: 'jmv 9/7/2017 17:18:49' prior: 16929486! - withAttributeValues: attributes do: aBlock - "Evaluate aBlock with the values of various attributes that affect text formatting, applied in the correct order - The order is (each overwriting the previous one) - 1) basic defaults - 2) ParagraphStyleReferene - 3) CharacterStyleReference - 4) TextFontReference - 5) TextEmphasis" - - | paragraphStyle characterStyle familyName pointSize emphasis alignment color backgroundColor | - paragraphStyle _ nil. - characterStyle _ nil. - familyName _ nil. - pointSize _ nil. - emphasis _ 0. - alignment _ 0. - color _ nil. - backgroundColor _ nil. - - "ParagraphStyle is the first to set several values" - attributes do: [ :attribute | - attribute forParagraphStyleReferenceDo: [ :s | - paragraphStyle _ s. - familyName _ s familyName. - pointSize _ s pointSize. - emphasis _ s emphasis. - alignment _ s alignment. - s color ifNotNil: [ :c | color _ c ]]]. - - "CharacterStyle, if present, can override font and color" - attributes do: [ :attribute | - attribute forCharacterStyleReferenceDo: [ :s | - characterStyle _ s. - familyName _ s familyName. - pointSize _ s pointSize. - emphasis _ s emphasis. - s color ifNotNil: [ :c | color _ c ]]]. - - "These will not interfere with each other, and all of them take precedence over previous values" - attributes do: [ :attribute | - attribute forFontFamilyAndSizeDo: [ :fn :ps | familyName _ fn. pointSize _ ps ]. - attribute forTextEmphasisDo: [ :e | emphasis _ emphasis bitOr: e ]. - attribute forTextColorDo: [ :c | color _ c ]. - attribute forTextBackgroundColorDo: [ :c | backgroundColor _ c ]. - attribute forTextAlignmentDo: [ :a | alignment _ a ]. - ]. - - "Done. Now evaluate the block." -"cambiar senders!!!!!!!!!!!!" - aBlock numArgs = 8 ifTrue: [ - ^aBlock valueWithArguments: { familyName. pointSize. emphasis. color. alignment. characterStyle. paragraphStyle. backgroundColor } - ]. - ^aBlock valueWithArguments: { familyName. pointSize. emphasis. color. alignment. characterStyle. paragraphStyle }! ! -!BitBlt methodsFor: 'accessing' stamp: 'jmv 9/6/2017 20:40:02' prior: 16785548! - destX: x destY: y width: w height: h - destX _ x. - destY _ y. - width _ w. - height _ h.! ! -!CharacterScanner methodsFor: 'private' stamp: 'jmv 9/7/2017 17:19:12' prior: 16801954! - setFont - | attributes | - "Set the font and other emphasis. - In fact set actual ParagraphStyle (or nil), alignment, font and emphasis" - - self setActualFont: (text fontAt: lastIndex default: defaultFont). - attributes _ text attributesAt: lastIndex. - text - withAttributeValues: attributes - do: [ :familyNameInText :pointSizeInText :emphasisInText :colorInText :alignmentInText :characterStyleInText :paragraphStyleInText :backgroundColorInText | - colorInText ifNotNil: [ self textColor: colorInText ]. - self backgroundColor: backgroundColorInText. - alignment _ alignmentInText. - paragraphStyle _ paragraphStyleInText ]. - - "Hardcoded color for TextAction" - attributes do: [ :attribute | - attribute forTextActionInfoDo: [ :info | - self textColor: TextAction textActionColor ]]. - - "Install various parameters from the font." - spaceWidth _ font widthOf: Character space. - tabWidth _ (font widthOf: $a) * 3. - xTable _ font xTable. - map _ font characterToGlyphMap! ! -!CharacterScanner methodsFor: 'private' stamp: 'jmv 9/6/2017 20:40:09' prior: 16801989! - textColor: ignored - "Overridden in MorphicScanner"! ! -!MorphicScanner methodsFor: 'scanning' stamp: 'jmv 9/7/2017 17:50:39' prior: 16877966! - displayLine: textLine textTopLeft: textTopLeft leftInRun: leftInRun - "The call on the primitive (scanCharactersFrom:to:in:rightX:) will be interrupted according to an array of stop conditions passed to the scanner at which time the code to handle the stop condition is run and the call on the primitive continued until a stop condition returns true (which means the line has terminated). leftInRun is the # of characters left to scan in the current run; when 0, it is time to call setStopConditions." - - "textTopLeft is relative to the morph currently being drawn" - | stopCondition nowLeftInRun startIndex string lastPos tt | - - topLeft _ textTopLeft. - line _ textLine. - lineY _ line top + textTopLeft y. - rightMargin _ line rightMargin + textTopLeft x. - lastIndex _ line first. - leftInRun <= 0 ifTrue: [ - self setFont. - self setStopConditions ]. - leftMargin _ (line leftMarginForAlignment: alignment) + textTopLeft x. - destX _ leftMargin. - destY _ lineY + line baseline - font ascent. - - textLine isEmptyLine ifTrue: [ - textLine paragraphStyle ifNotNil: [ :ps | - ps = paragraphStyle ifFalse: [ - foregroundColor _ defaultColor. - self setActualFont: ps font. - ps color ifNotNil: [ :color | self textColor: color ]. - alignment _ ps alignment. - paragraphStyle _ ps. - spaceWidth _ font widthOf: Character space. - tabWidth _ (font widthOf: $a) * 3. - xTable _ font xTable. - map _ font characterToGlyphMap. - self setStopConditions. - text ifNotNil: [ destY _ lineY + line baseline - font ascent ]]]. - self displayBulletIfAppropriateFor: textLine textLeft: textTopLeft x. - ^leftInRun ]. - - self displayBulletIfAppropriateFor: textLine textLeft: textTopLeft x. - - lastIndex _ line first. - leftInRun <= 0 - ifTrue: [nowLeftInRun _ text runLengthFor: lastIndex] - ifFalse: [nowLeftInRun _ leftInRun]. - runStopIndex _ lastIndex + (nowLeftInRun - 1) min: line last. - spaceCount _ 0. - string _ text string. - - self placeEmbeddedObject. - [ - startIndex _ lastIndex. - lastPos _ destX@destY. - stopCondition _ self - scanCharactersFrom: lastIndex to: runStopIndex - in: string rightX: rightMargin stopConditions: stopConditions - kern: font baseKern. - backgroundColor ifNotNil: [ - "origin y podria ser el del argumento" - "dest y lo tome de la seleccion. Podria quizas venir de otro lado" - "corner x = rightMargin para ir hasta el final - corner x = destX para pintar solo el texto (no seguir hasta el final) - Wow, esto está bastante cerca." - "mhhh solo poner rightMargin para el ultimo. No antes (siquiero usar transparencia y no pintar de mas)" - "En libreoffice writer, background es para parrafo. - ademas, seleccion y background marcan hasta el borde derecho de la pgina. - pero highlight (resaltador) solo hasta los bounds de las palabras (en cualquier modo de justificado)" - tt _ lastIndex +1 = line last ifTrue: [rightMargin] ifFalse: [destX]. - tt _ destX. - canvas - fillRectangle: (lastPos corner: tt @ (line bottom + textTopLeft y)) - color: backgroundColor. - ]. - lastIndex >= startIndex ifTrue: [ - canvas - drawString: string - from: startIndex - to: lastIndex - at: lastPos - font: font - color: foregroundColor ]. - "see setStopConditions for stopping conditions for displaying." - (self perform: stopCondition) ifTrue: [ - "Number of characters remaining in the current run" - ^ runStopIndex - lastIndex ] - ] repeat! ! -!MorphicScanner methodsFor: 'scanning' stamp: 'jmv 9/9/2017 15:36:49' prior: 50400084! - displayLine: textLine textTopLeft: textTopLeft leftInRun: leftInRun - "The call on the primitive (scanCharactersFrom:to:in:rightX:) will be interrupted according to an array of stop conditions passed to the scanner at which time the code to handle the stop condition is run and the call on the primitive continued until a stop condition returns true (which means the line has terminated). leftInRun is the # of characters left to scan in the current run; when 0, it is time to call setStopConditions." - - "textTopLeft is relative to the morph currently being drawn" - | stopCondition nowLeftInRun startIndex string lastPos | - - topLeft _ textTopLeft. - line _ textLine. - lineY _ line top + textTopLeft y. - rightMargin _ line rightMargin + textTopLeft x. - lastIndex _ line first. - leftInRun <= 0 ifTrue: [ - self setFont. - self setStopConditions ]. - leftMargin _ (line leftMarginForAlignment: alignment) + textTopLeft x. - destX _ leftMargin. - destY _ lineY + line baseline - font ascent. - - textLine isEmptyLine ifTrue: [ - textLine paragraphStyle ifNotNil: [ :ps | - ps = paragraphStyle ifFalse: [ - foregroundColor _ defaultColor. - self setActualFont: ps font. - ps color ifNotNil: [ :color | self textColor: color ]. - alignment _ ps alignment. - paragraphStyle _ ps. - spaceWidth _ font widthOf: Character space. - tabWidth _ (font widthOf: $a) * 3. - xTable _ font xTable. - map _ font characterToGlyphMap. - self setStopConditions. - text ifNotNil: [ destY _ lineY + line baseline - font ascent ]]]. - self displayBulletIfAppropriateFor: textLine textLeft: textTopLeft x. - ^leftInRun ]. - - self displayBulletIfAppropriateFor: textLine textLeft: textTopLeft x. - - lastIndex _ line first. - leftInRun <= 0 - ifTrue: [nowLeftInRun _ text runLengthFor: lastIndex] - ifFalse: [nowLeftInRun _ leftInRun]. - runStopIndex _ lastIndex + (nowLeftInRun - 1) min: line last. - spaceCount _ 0. - string _ text string. - - self placeEmbeddedObject. - [ - startIndex _ lastIndex. - lastPos _ destX@destY. - stopCondition _ self - scanCharactersFrom: lastIndex to: runStopIndex - in: string rightX: rightMargin stopConditions: stopConditions - kern: font baseKern. - backgroundColor ifNotNil: [ - canvas - fillRectangle: (lastPos corner: destX @ (line bottom + textTopLeft y)) - color: backgroundColor. - ]. - lastIndex >= startIndex ifTrue: [ - canvas - drawString: string - from: startIndex - to: lastIndex - at: lastPos - font: font - color: foregroundColor ]. - "see setStopConditions for stopping conditions for displaying." - (self perform: stopCondition) ifTrue: [ - "Number of characters remaining in the current run" - ^ runStopIndex - lastIndex ] - ] repeat! ! -!MorphicScanner methodsFor: 'scanning' stamp: 'jmv 9/10/2017 16:28:26' prior: 50400193! - displayLine: textLine textTopLeft: textTopLeft leftInRun: leftInRun - "The call on the primitive (scanCharactersFrom:to:in:rightX:) will be interrupted according to an array of stop conditions passed to the scanner at which time the code to handle the stop condition is run and the call on the primitive continued until a stop condition returns true (which means the line has terminated). leftInRun is the # of characters left to scan in the current run; when 0, it is time to call setStopConditions." - - "textTopLeft is relative to the morph currently being drawn" - | stopCondition nowLeftInRun startIndex string lastPos | - - topLeft _ textTopLeft. - line _ textLine. - lineY _ line top + textTopLeft y. - rightMargin _ line rightMargin + textTopLeft x. - lastIndex _ line first. - leftInRun <= 0 ifTrue: [ - self setFont. - self setStopConditions ]. - leftMargin _ (line leftMarginForAlignment: alignment) + textTopLeft x. - destX _ leftMargin. - destY _ lineY + line baseline - font ascent. - - textLine isEmptyLine ifTrue: [ - textLine paragraphStyle ifNotNil: [ :ps | - ps = paragraphStyle ifFalse: [ - foregroundColor _ defaultColor. - self setActualFont: ps font. - ps color ifNotNil: [ :color | self textColor: color ]. - alignment _ ps alignment. - paragraphStyle _ ps. - spaceWidth _ font widthOf: Character space. - tabWidth _ (font widthOf: $a) * 3. - xTable _ font xTable. - map _ font characterToGlyphMap. - self setStopConditions. - text ifNotNil: [ destY _ lineY + line baseline - font ascent ]]]. - self displayBulletIfAppropriateFor: textLine textLeft: textTopLeft x. - ^leftInRun ]. - - self displayBulletIfAppropriateFor: textLine textLeft: textTopLeft x. - - lastIndex _ line first. - leftInRun <= 0 - ifTrue: [nowLeftInRun _ text runLengthFor: lastIndex] - ifFalse: [nowLeftInRun _ leftInRun]. - runStopIndex _ lastIndex + (nowLeftInRun - 1) min: line last. - spaceCount _ 0. - string _ text string. - - self placeEmbeddedObject. - [ - startIndex _ lastIndex. - lastPos _ destX@destY. - stopCondition _ self - scanCharactersFrom: lastIndex to: runStopIndex - in: string rightX: rightMargin stopConditions: stopConditions - kern: font baseKern. - backgroundColor ifNotNil: [ - canvas - fillRectangle: (lastPos corner: destX @ (line bottom + textTopLeft y)) - color: backgroundColor ]. - lastIndex >= startIndex ifTrue: [ - canvas - drawString: string - from: startIndex - to: lastIndex - at: lastPos - font: font - color: foregroundColor ]. - "see setStopConditions for stopping conditions for displaying." - (self perform: stopCondition) ifTrue: [ - "Number of characters remaining in the current run" - ^ runStopIndex - lastIndex ] - ] repeat! ! -!Text methodsFor: 'emphasis' stamp: 'jmv 9/10/2017 16:28:51' prior: 50399974! - withAttributeValues: attributes do: aBlock - "Evaluate aBlock with the values of various attributes that affect text formatting, applied in the correct order - The order is (each overwriting the previous one) - 1) basic defaults - 2) ParagraphStyleReferene - 3) CharacterStyleReference - 4) TextFontReference - 5) TextEmphasis" - - | paragraphStyle characterStyle familyName pointSize emphasis alignment color backgroundColor | - paragraphStyle _ nil. - characterStyle _ nil. - familyName _ nil. - pointSize _ nil. - emphasis _ 0. - alignment _ 0. - color _ nil. - backgroundColor _ nil. - - "ParagraphStyle is the first to set several values" - attributes do: [ :attribute | - attribute forParagraphStyleReferenceDo: [ :s | - paragraphStyle _ s. - familyName _ s familyName. - pointSize _ s pointSize. - emphasis _ s emphasis. - alignment _ s alignment. - s color ifNotNil: [ :c | color _ c ]]]. - - "CharacterStyle, if present, can override font and color" - attributes do: [ :attribute | - attribute forCharacterStyleReferenceDo: [ :s | - characterStyle _ s. - familyName _ s familyName. - pointSize _ s pointSize. - emphasis _ s emphasis. - s color ifNotNil: [ :c | color _ c ]]]. - - "These will not interfere with each other, and all of them take precedence over previous values" - attributes do: [ :attribute | - attribute forFontFamilyAndSizeDo: [ :fn :ps | familyName _ fn. pointSize _ ps ]. - attribute forTextEmphasisDo: [ :e | emphasis _ emphasis bitOr: e ]. - attribute forTextColorDo: [ :c | color _ c ]. - attribute forTextBackgroundColorDo: [ :c | backgroundColor _ c ]. - attribute forTextAlignmentDo: [ :a | alignment _ a ]. - ]. - - "Done. Now evaluate the block." -"change all senders!!!!!!!!!!!!" - aBlock numArgs = 8 ifTrue: [ - ^aBlock valueWithArguments: { familyName. pointSize. emphasis. color. alignment. characterStyle. paragraphStyle. backgroundColor } - ]. - ^aBlock valueWithArguments: { familyName. pointSize. emphasis. color. alignment. characterStyle. paragraphStyle }! ! - -'From Cuis 4.2 of 25 July 2013 [latest update: #2855] on 28 July 2016 at 3:26:08 pm'! - -'Description Please enter a description for this package'! - -IntegerArray variableWordSubclass: #PointArray - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Collections-CompactArrays'! - -!classDefinition: #PointArray category: #'Collections-CompactArrays'! -IntegerArray variableWordSubclass: #PointArray - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Collections-CompactArrays'! - -PointArray class - instanceVariableNames: ''! - -!classDefinition: 'PointArray class' category: #'Collections-CompactArrays'! -PointArray class - instanceVariableNames: ''! - -ArrayedCollection variableWordSubclass: #ShortIntegerArray - instanceVariableNames: '' - classVariableNames: 'LastSaveOrder' - poolDictionaries: '' - category: 'Collections-CompactArrays'! - -!classDefinition: #ShortIntegerArray category: #'Collections-CompactArrays'! -ArrayedCollection variableWordSubclass: #ShortIntegerArray - instanceVariableNames: '' - classVariableNames: 'LastSaveOrder' - poolDictionaries: '' - category: 'Collections-CompactArrays'! - -ShortIntegerArray class - instanceVariableNames: ''! - -!classDefinition: 'ShortIntegerArray class' category: #'Collections-CompactArrays'! -ShortIntegerArray class - instanceVariableNames: ''! - -ShortIntegerArray variableWordSubclass: #ShortPointArray - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Collections-CompactArrays'! - -!classDefinition: #ShortPointArray category: #'Collections-CompactArrays'! -ShortIntegerArray variableWordSubclass: #ShortPointArray - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Collections-CompactArrays'! - -ShortPointArray class - instanceVariableNames: ''! - -!classDefinition: 'ShortPointArray class' category: #'Collections-CompactArrays'! -ShortPointArray class - instanceVariableNames: ''! - -ShortIntegerArray variableWordSubclass: #ShortWordArray - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Collections-CompactArrays'! - -!classDefinition: #ShortWordArray category: #'Collections-CompactArrays'! -ShortIntegerArray variableWordSubclass: #ShortWordArray - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Collections-CompactArrays'! - -ShortWordArray class - instanceVariableNames: ''! - -!classDefinition: 'ShortWordArray class' category: #'Collections-CompactArrays'! -ShortWordArray class - instanceVariableNames: ''! - -ArrayedCollection variableWordSubclass: #ShortRunArray - instanceVariableNames: '' - classVariableNames: 'LastSaveOrder' - poolDictionaries: '' - category: 'Collections-CompactArrays'! - -!classDefinition: #ShortRunArray category: #'Collections-CompactArrays'! -ArrayedCollection variableWordSubclass: #ShortRunArray - instanceVariableNames: '' - classVariableNames: 'LastSaveOrder' - poolDictionaries: '' - category: 'Collections-CompactArrays'! - -ShortRunArray class - instanceVariableNames: ''! - -!classDefinition: 'ShortRunArray class' category: #'Collections-CompactArrays'! -ShortRunArray class - instanceVariableNames: ''! -!PointArray commentStamp: '' prior: 0! - This class stores 32bit Integer points in place. It is used to pass data efficiently to the primitive level during high-bandwidth 2D graphics operations.! -!ShortIntegerArray commentStamp: '' prior: 0! - ShortIntegerArray is an array for efficiently representing signed integers in the 16bit range, i.e. between -16r8000 and 16r7FFF. - -Additionaly, using #at:putUnsigned: and #at:putSigned:, it supports unsigned 16 bits integers, between 0 and 16rFFFF. You can also alternatively ShortWordArray to store unsigned 16 bit integers with the usual #at: and #at:put: protocol. - -Array size must be even, as two vales are stored in each word.! -!ShortPointArray commentStamp: '' prior: 0! - This class stores points that are in short integer range (e.g., -32767 <= value <= 32768). It is used to pass data efficiently to the primitive level during high-bandwidth 2D graphics operations.! -!ShortWordArray commentStamp: '' prior: 0! - ShortWordArrays store 16-bit unsigned Integer values, between 0 and 16rFFFF.! -!ShortRunArray commentStamp: '' prior: 0! - This class is run-length encoded representation of short integer (e.g., 16bit signed integer values)! -!Collection methodsFor: '*Collections-CompactArrays' stamp: 'jmv 12/18/2015 15:01'! - asPointArray - "Answer a PointArray whose elements are the elements of the receiver" - - ^self as: PointArray! ! -!PointArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:21'! - at: index - "Return the element (e.g., point) at the given index" - ^(super at: index * 2 - 1) @ (super at: index * 2)! ! -!PointArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:21'! - at: index put: aPoint - "Store the argument aPoint at the given index" - super at: index * 2 - 1 put: aPoint x asInteger. - super at: index * 2 put: aPoint y asInteger. - ^aPoint! ! -!PointArray methodsFor: 'accessing' stamp: 'ar 11/10/1998 19:41'! - bounds - | min max | - min _ max _ self at: 1. - self do:[:pt| - min _ min min: pt. - max _ max max: pt]. - ^min corner: max - ! ! -!PointArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:19'! -defaultElement - "Return the default element of the receiver" - ^0@0! ! -!PointArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:21'! - size - "Return the number of elements in the receiver" - ^super size // 2! ! -!PointArray class methodsFor: 'instance creation' stamp: 'ar 10/16/1998 00:04'! - new: n - ^super new: n*2! ! -!ShortIntegerArray methodsFor: 'accessing' stamp: 'jmv 2/27/2013 07:21'! - at: index - "Return the 16-bit signed integer value at the given index of the receiver." - - ^self signedAt: index! ! -!ShortIntegerArray methodsFor: 'accessing' stamp: 'jmv 2/27/2013 07:23'! - at: index put: value - "Store the given 16-bit signed integer at the given index in the receiver." - - ^self at: index putSigned: value! ! -!ShortIntegerArray methodsFor: 'accessing' stamp: 'jmv 2/27/2013 07:21'! - at: index putSigned: value - "Store the given 16-bit signed integer at the given index in the receiver." - - - index isInteger - ifTrue: [ - (index >= 1 and: [index <= self size]) - ifTrue: [self errorImproperStore] - ifFalse: [self errorSubscriptBounds: index]]. - index isNumber ifTrue: [^ self at: index truncated put: value]. - self errorNonIntegerIndex. -! ! -!ShortIntegerArray methodsFor: 'accessing' stamp: 'jmv 2/28/2013 16:54'! - at: index putUnsigned: value - "Store the given 16-bit unsigned integer at the given index in the receiver." - - | primValue | - value < 0 ifTrue: [ self errorImproperStore ]. - value > 16rFFFF ifTrue: [ self errorImproperStore ]. - primValue _ value > 16r7FFF - ifTrue: [ - value - 16r10000. "Faster. No need for LargeInteger arithmetic" - "(value bitInvert16 + 1) negated" ] - ifFalse: [ value ]. - self at: index putSigned: primValue. - ^value! ! -!ShortIntegerArray methodsFor: 'objects from disk' stamp: 'nk 3/7/2004 13:54'! - bytesPerElement - ^2! ! -!ShortIntegerArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 15:41'! - defaultElement - ^0! ! -!ShortIntegerArray methodsFor: 'objects from disk' stamp: 'jmv 2/15/2008 00:48'! - restoreEndianness - "This word object was just read in from a stream. It was stored in Big Endian (Mac) format. Swap each pair of bytes (16-bit word), if the current machine is Little Endian. - Why is this the right thing to do? We are using memory as a byteStream. High and low bytes are reversed in each 16-bit word, but the stream of words ascends through memory. Different from a Bitmap." - - | hack blt | - Smalltalk isLittleEndian ifTrue: [ - "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: hack height; width: 1. - blt sourceX: 0; destX: 1; copyBits. "Exchange bytes 0 and 1" - blt sourceX: 1; destX: 0; copyBits. - blt sourceX: 0; destX: 1; copyBits. - blt sourceX: 2; destX: 3; copyBits. "Exchange bytes 2 and 3" - blt sourceX: 3; destX: 2; copyBits. - blt sourceX: 2; destX: 3; copyBits - ]. -! ! -!ShortIntegerArray methodsFor: 'accessing' stamp: 'jmv 2/27/2013 07:21'! - signedAt: index - "Return the 16-bit signed integer value at the given index of the receiver." - - - index isInteger ifTrue: [self errorSubscriptBounds: index]. - index isNumber ifTrue: [^ self at: index truncated]. - self errorNonIntegerIndex. -! ! -!ShortIntegerArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 15:41'! - size - ^super size * 2! ! -!ShortIntegerArray methodsFor: 'accessing' stamp: 'jmv 2/28/2013 16:52'! - unsignedAt: index - "Return the 16-bit unsigned integer value at the given index of the receiver." - - | primValue | - primValue _ self signedAt: index. - ^primValue < 0 - ifTrue: [ - primValue + 16r10000. "Faster. No need for LargeInteger arithmetic" - "(primValue + 1) negated bitInvert16" ] - ifFalse: [ primValue ]! ! -!ShortIntegerArray methodsFor: 'objects from disk' stamp: 'jmv 2/26/2016 17:08'! - writeOn: aStream - - | w | - aStream nextSignedInt32Put: self basicSize bigEndian: true. - - 1 to: self basicSize do: [ :i | - w _ self basicAt: i. - Smalltalk isLittleEndian - ifFalse: [ aStream nextUnsignedInt32Put: w bigEndian: true ] - ifTrue: [ aStream - nextPut: (w digitAt: 2); - nextPut: (w digitAt: 1); - nextPut: (w digitAt: 4); - nextPut: (w digitAt: 3) ]].! ! -!ShortIntegerArray class methodsFor: 'class initialization' stamp: 'jmv 12/18/2015 15:29'! - initClassCachedState - "Check if the word order has changed from the last save" - - ((LastSaveOrder at: 1) = 42 and:[(LastSaveOrder at: 2) = 13]) - ifTrue:[^self]. "Okay" - ((LastSaveOrder at: 2) = 42 and:[(LastSaveOrder at: 1) = 13]) - ifTrue:[^self swapShortObjects]. "Reverse guys" - ^self error:'This must never happen'! ! -!ShortIntegerArray class methodsFor: 'class initialization' stamp: 'jmv 12/12/2014 16:56'! - initialize - " - ShortIntegerArray initialize. - SystemDictionary initialize. - " - LastSaveOrder _ self new: 2. - LastSaveOrder at: 1 put: 42. - LastSaveOrder at: 2 put: 13! ! -!ShortIntegerArray class methodsFor: 'instance creation' stamp: 'jmv 9/4/2015 13:09'! -new: n - "Instances are always of even size. Only accept those." - n even ifFalse: [ - self error: 'ShortIntegerArray>>#new: must be called with an even argument' ]. - ^ super new: n // 2! ! -!ShortIntegerArray class methodsFor: 'class initialization' stamp: 'jmv 2/25/2016 10:51'! - swapShortObjects - self allSubInstancesDo: [ :inst | - BitBlt swapHalvesIn32BitWords: inst ]! ! -!ShortPointArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 15:43'! - at: index - "Return the element (e.g., point) at the given index" - ^(super at: index * 2 - 1) @ (super at: index * 2)! ! -!ShortPointArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 15:43'! - at: index put: aPoint - "Store the argument aPoint at the given index" - super at: index * 2 - 1 put: aPoint x asInteger. - super at: index * 2 put: aPoint y asInteger. - ^aPoint! ! -!ShortPointArray methodsFor: 'accessing' stamp: 'ar 11/10/1998 19:41'! - bounds - | min max | - min _ max _ self at: 1. - self do:[:pt| - min _ min min: pt. - max _ max max: pt]. - ^min corner: max - ! ! -!ShortPointArray methodsFor: 'accessing' stamp: 'yo 3/6/2004 12:56'! - bytesPerElement - - ^ 4. - ! ! -!ShortPointArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 15:43'! - defaultElement - "Return the default element of the receiver" - ^0@0! ! -!ShortPointArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 15:43'! - size - ^self basicSize! ! -!ShortPointArray class methodsFor: 'instance creation' stamp: 'ar 1/15/1999 17:40'! - new: n - ^super new: n * 2! ! -!ShortWordArray methodsFor: 'accessing' stamp: 'jmv 2/27/2013 07:23'! - at: index - "Return the 16-bit unsigned integer value at the given index of the receiver." - - ^self unsignedAt: index! ! -!ShortWordArray methodsFor: 'accessing' stamp: 'jmv 2/27/2013 07:23'! - at: index put: value - "Store the given 16-bit unsigned integer at the given index in the receiver." - - ^self at: index putUnsigned: value! ! -!ShortRunArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 17:26'! - at: index - "Return the short value at the given index" - | rlIndex | - index < 1 ifTrue:[^self errorSubscriptBounds: index]. - rlIndex _ index. - self lengthsAndValuesDo:[:runLength :runValue| - rlIndex <= runLength ifTrue:[^runValue]. - rlIndex _ rlIndex - runLength]. - "Not found. Must be out of range" - ^self errorSubscriptBounds: index! ! -!ShortRunArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 17:18'! - at: index put: value - "ShortRunArrays are read-only" - ^self shouldNotImplement.! ! -!ShortRunArray methodsFor: 'accessing' stamp: 'yo 3/6/2004 14:19'! - bytesPerElement - - ^ 4 -! ! -!ShortRunArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 17:39'! - compressionRatio - "Return the compression ratio. - The compression ratio is computed based - on how much space would be needed to - store the receiver in a ShortIntegerArray" - ^(self size asFloat * 0.5) "Would need only half of the amount in ShortIntegerArray" - / (self runSize max: 1)! ! -!ShortRunArray methodsFor: 'enumerating' stamp: 'ar 11/3/1998 17:31'! - do: aBlock - "Evaluate aBlock with all elements of the receiver" - self lengthsAndValuesDo:[:runLength :runValue| - "Use to:do: instead of timesRepeat: for compiler optimization" - 1 to: runLength do:[:i| - aBlock value: runValue. - ]. - ].! ! -!ShortRunArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 17:21'! - lengthAtRun: index - "Return the length of the run starting at the given index" - ^(self basicAt: index) bitShift: -16! ! -!ShortRunArray methodsFor: 'enumerating' stamp: 'ar 12/27/1999 13:44'! - lengthsAndValuesDo: aBlock - "Evaluate aBlock with the length and value of each run in the receiver" - ^self runsAndValuesDo: aBlock! ! -!ShortRunArray methodsFor: 'printing' stamp: 'ar 11/3/1998 17:41'! - printOn: aStream - aStream nextPutAll: self class name; nextPutAll:' ( '. - self lengthsAndValuesDo:[:runLength :runValue | - aStream - nextPutAll:' ('; - print: runLength; - space; - print: runValue; - nextPut:$). - ]. - aStream nextPutAll:' )'.! ! -!ShortRunArray methodsFor: 'objects from disk' stamp: 'jmv 2/15/2008 00:49'! - restoreEndianness - "This word object was just read in from a stream. It was stored in Big Endian (Mac) format. Swap each pair of bytes (16-bit word), if the current machine is Little Endian. - Why is this the right thing to do? We are using memory as a byteStream. High and low bytes are reversed in each 16-bit word, but the stream of words ascends through memory. Different from a Bitmap." - - | w b1 b2 b3 b4 | - Smalltalk isLittleEndian ifTrue: [ - 1 to: self basicSize do: [:i | - w _ self basicAt: i. - b1 _ w digitAt: 1. - b2 _ w digitAt: 2. - b3 _ w digitAt: 3. - b4 _ w digitAt: 4. - w _ (b1 << 24) + (b2 << 16) + (b3 << 8) + b4. - self basicAt: i put: w. - ] - ]. - -! ! -!ShortRunArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 17:28'! - runSize - "Return the number of runs in the receiver" - ^self basicSize! ! -!ShortRunArray methodsFor: 'enumerating' stamp: 'ar 12/27/1999 13:44'! - runsAndValuesDo: aBlock - "Evaluate aBlock with the length and value of each run in the receiver" - | basicValue length value | - 1 to: self basicSize do:[:i| - basicValue _ self basicAt: i. - length _ basicValue bitShift: -16. - value _ basicValue bitAnd: 16rFFFF. - value _ (value bitAnd: 16r7FFF) - (value bitAnd: 16r8000). - aBlock value: length value: value. - ].! ! -!ShortRunArray methodsFor: 'private' stamp: 'ar 11/3/1998 21:02'! - setRunAt: i toLength: runLength value: value - (value < -16r7FFF or:[value > 16r8000]) ifTrue:[^self errorImproperStore]. - (runLength < 0 or:[runLength > 16rFFFF]) ifTrue:[^self errorImproperStore]. - self basicAt: i put: (runLength bitShift: 16) + - ((value bitAnd: 16r7FFF) - (value bitAnd: -16r8000)).! ! -!ShortRunArray methodsFor: 'private' stamp: 'ar 11/3/1998 21:00'! - setRuns: runArray values: valueArray - | runLength value | - 1 to: runArray size do:[:i| - runLength _ runArray at: i. - value _ valueArray at: i. - self setRunAt: i toLength: runLength value: value. - ].! ! -!ShortRunArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 17:28'! - size - "Return the number of elements stored in the receiver" - | n | - n _ 0. - "Note: The following loop is open-coded for speed" - 1 to: self basicSize do:[:i| - n _ n + ((self basicAt: i) bitShift: -16). - ]. - ^n! ! -!ShortRunArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 17:29'! - species - "Answer the preferred class for reconstructing the receiver." - ^ShortIntegerArray! ! -!ShortRunArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 17:22'! - valueAtRun: index - "Return the value of the run starting at the given index" - | uShort | - uShort _ (self basicAt: index) bitAnd: 16rFFFF. - ^(uShort bitAnd: 16r7FFF) - (uShort bitAnd: 16r8000)! ! -!ShortRunArray methodsFor: 'enumerating' stamp: 'ar 11/3/1998 21:05'! - valuesCollect: aBlock - "Evaluate aBlock with each of the receiver's values as the argument. - Collect the resulting values into a collection like the receiver. Answer - the new collection." - | newArray newValue | - newArray _ self class basicNew: self basicSize. - 1 to: self runSize do:[:i| - newValue _ aBlock value: (self valueAtRun: i). - newArray setRunAt: i toLength: (self lengthAtRun: i) value: newValue. - ]. - ^newArray! ! -!ShortRunArray methodsFor: 'enumerating' stamp: 'ar 11/15/1998 17:22'! - valuesDo: aBlock - self lengthsAndValuesDo:[:runLength :runValue| aBlock value: runValue]! ! -!ShortRunArray class methodsFor: 'class initialization' stamp: 'jmv 12/18/2015 15:29'! - initClassCachedState - "Check if the word order has changed from the last save" - - ((LastSaveOrder valueAtRun: 1) = 42 and:[(LastSaveOrder lengthAtRun: 1) = 3]) - ifTrue:[^self]. "Okay" - ((LastSaveOrder lengthAtRun: 1) = 42 and:[(LastSaveOrder valueAtRun: 1) = 3]) - ifTrue:[^self swapRuns]. "Reverse guys" - ^self error:'This must never happen'! ! -!ShortRunArray class methodsFor: 'class initialization' stamp: 'jmv 12/12/2014 16:56'! - initialize - " - ShortRunArray initialize - SystemDictionary initialize. - " - LastSaveOrder _ #(42 42 42) as: self! ! -!ShortRunArray class methodsFor: 'instance creation' stamp: 'ar 11/3/1998 17:12'! - new: n - "ShortRunArrays must be created with either - someCollection as: ShortRunArray - or by using - ShortRunArray runs: runCollection values: valueCollection. - " - ^self shouldNotImplement! ! -!ShortRunArray class methodsFor: 'instance creation' stamp: 'jmv 12/12/2014 17:12'! - newFrom: aCollection - "Compress aCollection into a ShortRunArray" - | lastValue lastRun runs values valueCount | - aCollection isEmpty ifTrue: [ ^self runs:#() values: #() ]. - runs _ WriteStream on: (WordArray new: 100). - values _ WriteStream on: (ShortIntegerArray new: 100). - lastValue _ aCollection first. - lastRun _ 0. - valueCount _ 0. - aCollection do: [ :item | - (item = lastValue and:[lastRun < 16r8000]) ifTrue:[ - lastRun _ lastRun + 1. - ] ifFalse:[ - runs nextPut: lastRun. - values nextPut: lastValue. - lastRun _ 1. - lastValue _ item. - valueCount _ valueCount + 1. - ]. - ]. - runs nextPut: lastRun. - values nextPut: lastValue. - valueCount _ valueCount + 1. - valueCount odd ifTrue: [ - values nextPut: 0 ]. - ^ self runs: runs contents values: values contents! ! -!ShortRunArray class methodsFor: 'instance creation' stamp: 'ar 11/3/1998 17:12'! - runs: runCollection values: valueCollection - ^(self basicNew: runCollection size) setRuns: runCollection values: valueCollection! ! -!ShortRunArray class methodsFor: 'class initialization' stamp: 'jmv 2/25/2016 10:52'! - swapRuns - self allSubInstancesDo: [ :inst | - BitBlt swapHalvesIn32BitWords: inst ]! ! - -ShortIntegerArray initialize! - -ShortRunArray initialize! - -----End fileIn of /home/juan/Cuis/Cuis-Smalltalk-Dev/Packages/Collections-CompactArrays.pck.st----! - -'From Cuis 5.0 of 7 November 2016 [latest update: #3129] on 24 July 2017 at 4:28:05 pm'! - -'Description Please enter a description for this package '! - -ArrayedCollection variableWordSubclass: #SoundBuffer - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -!classDefinition: #SoundBuffer category: #'Sound-Synthesis'! -ArrayedCollection variableWordSubclass: #SoundBuffer - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -SoundBuffer class - instanceVariableNames: ''! - -!classDefinition: 'SoundBuffer class' category: #'Sound-Synthesis'! -SoundBuffer class - instanceVariableNames: ''! - -ImageMorph subclass: #Sonogram - instanceVariableNames: 'lastX scrollDelta columnForm minVal maxVal pixValMap' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -!classDefinition: #Sonogram category: #'Sound-Synthesis'! -ImageMorph subclass: #Sonogram - instanceVariableNames: 'lastX scrollDelta columnForm minVal maxVal pixValMap' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -Sonogram class - instanceVariableNames: ''! - -!classDefinition: 'Sonogram class' category: #'Sound-Synthesis'! -Sonogram class - instanceVariableNames: ''! - -Object subclass: #AIFFFileReader - instanceVariableNames: 'in fileType channelCount frameCount bitsPerSample samplingRate channelData channelDataOffset markers pitch gain isLooped skipDataChunk mergeIfStereo' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -!classDefinition: #AIFFFileReader category: #'Sound-Synthesis'! -Object subclass: #AIFFFileReader - instanceVariableNames: 'in fileType channelCount frameCount bitsPerSample samplingRate channelData channelDataOffset markers pitch gain isLooped skipDataChunk mergeIfStereo' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -AIFFFileReader class - instanceVariableNames: ''! - -!classDefinition: 'AIFFFileReader class' category: #'Sound-Synthesis'! -AIFFFileReader class - instanceVariableNames: ''! - -Object subclass: #AbstractSound - instanceVariableNames: 'envelopes mSecsSinceStart samplesUntilNextControl scaledVol scaledVolIncr scaledVolLimit' - classVariableNames: 'FloatScaleFactor MaxScaledValue PitchesForBottomOctave ScaleFactor Sounds TopOfBottomOctave UnloadedSnd' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -!classDefinition: #AbstractSound category: #'Sound-Synthesis'! -Object subclass: #AbstractSound - instanceVariableNames: 'envelopes mSecsSinceStart samplesUntilNextControl scaledVol scaledVolIncr scaledVolLimit' - classVariableNames: 'FloatScaleFactor MaxScaledValue PitchesForBottomOctave ScaleFactor Sounds TopOfBottomOctave UnloadedSnd' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -AbstractSound class - instanceVariableNames: ''! - -!classDefinition: 'AbstractSound class' category: #'Sound-Synthesis'! -AbstractSound class - instanceVariableNames: ''! - -AbstractSound subclass: #FMSound - instanceVariableNames: 'initialCount count waveTable scaledWaveTableSize scaledIndex scaledIndexIncr modulation multiplier normalizedModulation scaledOffsetIndex scaledOffsetIndexIncr' - classVariableNames: 'SineTable' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -!classDefinition: #FMSound category: #'Sound-Synthesis'! -AbstractSound subclass: #FMSound - instanceVariableNames: 'initialCount count waveTable scaledWaveTableSize scaledIndex scaledIndexIncr modulation multiplier normalizedModulation scaledOffsetIndex scaledOffsetIndexIncr' - classVariableNames: 'SineTable' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -FMSound class - instanceVariableNames: ''! - -!classDefinition: 'FMSound class' category: #'Sound-Synthesis'! -FMSound class - instanceVariableNames: ''! - -FMSound subclass: #FMBassoonSound - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -!classDefinition: #FMBassoonSound category: #'Sound-Synthesis'! -FMSound subclass: #FMBassoonSound - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -FMBassoonSound class - instanceVariableNames: ''! - -!classDefinition: 'FMBassoonSound class' category: #'Sound-Synthesis'! -FMBassoonSound class - instanceVariableNames: ''! - -FMSound subclass: #FMClarinetSound - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -!classDefinition: #FMClarinetSound category: #'Sound-Synthesis'! -FMSound subclass: #FMClarinetSound - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -FMClarinetSound class - instanceVariableNames: ''! - -!classDefinition: 'FMClarinetSound class' category: #'Sound-Synthesis'! -FMClarinetSound class - instanceVariableNames: ''! - -FMSound subclass: #UnloadedSound - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -!classDefinition: #UnloadedSound category: #'Sound-Synthesis'! -FMSound subclass: #UnloadedSound - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -UnloadedSound class - instanceVariableNames: ''! - -!classDefinition: 'UnloadedSound class' category: #'Sound-Synthesis'! -UnloadedSound class - instanceVariableNames: ''! - -AbstractSound subclass: #LoopedSampledSound - instanceVariableNames: 'initialCount count releaseCount sampleCountForRelease leftSamples rightSamples originalSamplingRate perceivedPitch gain firstSample lastSample loopEnd scaledLoopLength scaledIndex scaledIndexIncr' - classVariableNames: 'FloatLoopIndexScaleFactor LoopIndexFractionMask LoopIndexScaleFactor' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -!classDefinition: #LoopedSampledSound category: #'Sound-Synthesis'! -AbstractSound subclass: #LoopedSampledSound - instanceVariableNames: 'initialCount count releaseCount sampleCountForRelease leftSamples rightSamples originalSamplingRate perceivedPitch gain firstSample lastSample loopEnd scaledLoopLength scaledIndex scaledIndexIncr' - classVariableNames: 'FloatLoopIndexScaleFactor LoopIndexFractionMask LoopIndexScaleFactor' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -LoopedSampledSound class - instanceVariableNames: ''! - -!classDefinition: 'LoopedSampledSound class' category: #'Sound-Synthesis'! -LoopedSampledSound class - instanceVariableNames: ''! - -AbstractSound subclass: #MixedSound - instanceVariableNames: 'sounds leftVols rightVols soundDone' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -!classDefinition: #MixedSound category: #'Sound-Synthesis'! -AbstractSound subclass: #MixedSound - instanceVariableNames: 'sounds leftVols rightVols soundDone' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -MixedSound class - instanceVariableNames: ''! - -!classDefinition: 'MixedSound class' category: #'Sound-Synthesis'! -MixedSound class - instanceVariableNames: ''! - -AbstractSound subclass: #PluckedSound - instanceVariableNames: 'initialCount count ring scaledIndex scaledIndexIncr scaledIndexLimit' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -!classDefinition: #PluckedSound category: #'Sound-Synthesis'! -AbstractSound subclass: #PluckedSound - instanceVariableNames: 'initialCount count ring scaledIndex scaledIndexIncr scaledIndexLimit' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -PluckedSound class - instanceVariableNames: ''! - -!classDefinition: 'PluckedSound class' category: #'Sound-Synthesis'! -PluckedSound class - instanceVariableNames: ''! - -AbstractSound subclass: #QueueSound - instanceVariableNames: 'startTime sounds currentSound done' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -!classDefinition: #QueueSound category: #'Sound-Synthesis'! -AbstractSound subclass: #QueueSound - instanceVariableNames: 'startTime sounds currentSound done' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -QueueSound class - instanceVariableNames: ''! - -!classDefinition: 'QueueSound class' category: #'Sound-Synthesis'! -QueueSound class - instanceVariableNames: ''! - -AbstractSound subclass: #RepeatingSound - instanceVariableNames: 'sound iterationCount iteration samplesPerIteration' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -!classDefinition: #RepeatingSound category: #'Sound-Synthesis'! -AbstractSound subclass: #RepeatingSound - instanceVariableNames: 'sound iterationCount iteration samplesPerIteration' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -RepeatingSound class - instanceVariableNames: ''! - -!classDefinition: 'RepeatingSound class' category: #'Sound-Synthesis'! -RepeatingSound class - instanceVariableNames: ''! - -AbstractSound subclass: #RestSound - instanceVariableNames: 'initialCount count' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -!classDefinition: #RestSound category: #'Sound-Synthesis'! -AbstractSound subclass: #RestSound - instanceVariableNames: 'initialCount count' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -RestSound class - instanceVariableNames: ''! - -!classDefinition: 'RestSound class' category: #'Sound-Synthesis'! -RestSound class - instanceVariableNames: ''! - -AbstractSound subclass: #ReverbSound - instanceVariableNames: 'sound tapDelays tapGains tapCount bufferSize bufferIndex leftBuffer rightBuffer' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -!classDefinition: #ReverbSound category: #'Sound-Synthesis'! -AbstractSound subclass: #ReverbSound - instanceVariableNames: 'sound tapDelays tapGains tapCount bufferSize bufferIndex leftBuffer rightBuffer' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -ReverbSound class - instanceVariableNames: ''! - -!classDefinition: 'ReverbSound class' category: #'Sound-Synthesis'! -ReverbSound class - instanceVariableNames: ''! - -AbstractSound subclass: #SampledSound - instanceVariableNames: 'initialCount count samples originalSamplingRate samplesSize scaledIndex indexHighBits scaledIncrement' - classVariableNames: 'CoffeeCupClink DefaultSampleTable IncrementFractionBits IncrementScaleFactor NominalSamplePitch ScaledIndexOverflow SoundLibrary' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -!classDefinition: #SampledSound category: #'Sound-Synthesis'! -AbstractSound subclass: #SampledSound - instanceVariableNames: 'initialCount count samples originalSamplingRate samplesSize scaledIndex indexHighBits scaledIncrement' - classVariableNames: 'CoffeeCupClink DefaultSampleTable IncrementFractionBits IncrementScaleFactor NominalSamplePitch ScaledIndexOverflow SoundLibrary' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -SampledSound class - instanceVariableNames: ''! - -!classDefinition: 'SampledSound class' category: #'Sound-Synthesis'! -SampledSound class - instanceVariableNames: ''! - -AbstractSound subclass: #SequentialSound - instanceVariableNames: 'sounds currentIndex' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -!classDefinition: #SequentialSound category: #'Sound-Synthesis'! -AbstractSound subclass: #SequentialSound - instanceVariableNames: 'sounds currentIndex' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -SequentialSound class - instanceVariableNames: ''! - -!classDefinition: 'SequentialSound class' category: #'Sound-Synthesis'! -SequentialSound class - instanceVariableNames: ''! - -AbstractSound subclass: #StreamingMonoSound - instanceVariableNames: 'stream volume repeat headerStart audioDataStart streamSamplingRate totalSamples codec mixer leftoverSamples lastBufferMSecs mutex' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -!classDefinition: #StreamingMonoSound category: #'Sound-Synthesis'! -AbstractSound subclass: #StreamingMonoSound - instanceVariableNames: 'stream volume repeat headerStart audioDataStart streamSamplingRate totalSamples codec mixer leftoverSamples lastBufferMSecs mutex' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -StreamingMonoSound class - instanceVariableNames: ''! - -!classDefinition: 'StreamingMonoSound class' category: #'Sound-Synthesis'! -StreamingMonoSound class - instanceVariableNames: ''! - -AbstractSound subclass: #ScorePlayer - instanceVariableNames: 'score instruments overallVolume leftVols rightVols muted rate tempo secsPerTick done repeat ticksSinceStart ticksClockIncr trackEventIndex tempoMapIndex activeSounds activeMIDINotes midiPort midiPlayerProcess durationInTicks' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Scores'! - -!classDefinition: #ScorePlayer category: #'Sound-Scores'! -AbstractSound subclass: #ScorePlayer - instanceVariableNames: 'score instruments overallVolume leftVols rightVols muted rate tempo secsPerTick done repeat ticksSinceStart ticksClockIncr trackEventIndex tempoMapIndex activeSounds activeMIDINotes midiPort midiPlayerProcess durationInTicks' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Scores'! - -ScorePlayer class - instanceVariableNames: ''! - -!classDefinition: 'ScorePlayer class' category: #'Sound-Scores'! -ScorePlayer class - instanceVariableNames: ''! - -Object subclass: #CompressedSoundData - instanceVariableNames: 'channels soundClassName codecName loopEnd loopLength perceivedPitch samplingRate gain firstSample cachedSound' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -!classDefinition: #CompressedSoundData category: #'Sound-Synthesis'! -Object subclass: #CompressedSoundData - instanceVariableNames: 'channels soundClassName codecName loopEnd loopLength perceivedPitch samplingRate gain firstSample cachedSound' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -CompressedSoundData class - instanceVariableNames: ''! - -!classDefinition: 'CompressedSoundData class' category: #'Sound-Synthesis'! -CompressedSoundData class - instanceVariableNames: ''! - -Object subclass: #Envelope - instanceVariableNames: 'points loopStartIndex loopEndIndex loopStartMSecs loopMSecs target updateSelector loopEndMSecs endMSecs scale decayScale lastValue currValue valueIncr nextRecomputeTime noChangesDuringLoop' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -!classDefinition: #Envelope category: #'Sound-Synthesis'! -Object subclass: #Envelope - instanceVariableNames: 'points loopStartIndex loopEndIndex loopStartMSecs loopMSecs target updateSelector loopEndMSecs endMSecs scale decayScale lastValue currValue valueIncr nextRecomputeTime noChangesDuringLoop' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -Envelope class - instanceVariableNames: ''! - -!classDefinition: 'Envelope class' category: #'Sound-Synthesis'! -Envelope class - instanceVariableNames: ''! - -Envelope subclass: #PitchEnvelope - instanceVariableNames: 'centerPitch' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -!classDefinition: #PitchEnvelope category: #'Sound-Synthesis'! -Envelope subclass: #PitchEnvelope - instanceVariableNames: 'centerPitch' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -PitchEnvelope class - instanceVariableNames: ''! - -!classDefinition: 'PitchEnvelope class' category: #'Sound-Synthesis'! -PitchEnvelope class - instanceVariableNames: ''! - -Envelope subclass: #RandomEnvelope - instanceVariableNames: 'rand lowLimit highLimit delta' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -!classDefinition: #RandomEnvelope category: #'Sound-Synthesis'! -Envelope subclass: #RandomEnvelope - instanceVariableNames: 'rand lowLimit highLimit delta' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -RandomEnvelope class - instanceVariableNames: ''! - -!classDefinition: 'RandomEnvelope class' category: #'Sound-Synthesis'! -RandomEnvelope class - instanceVariableNames: ''! - -Envelope subclass: #VolumeEnvelope - instanceVariableNames: 'targetVol mSecsForChange' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -!classDefinition: #VolumeEnvelope category: #'Sound-Synthesis'! -Envelope subclass: #VolumeEnvelope - instanceVariableNames: 'targetVol mSecsForChange' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -VolumeEnvelope class - instanceVariableNames: ''! - -!classDefinition: 'VolumeEnvelope class' category: #'Sound-Synthesis'! -VolumeEnvelope class - instanceVariableNames: ''! - -Object subclass: #SampledInstrument - instanceVariableNames: 'sustainedSoft sustainedLoud staccatoSoft staccatoLoud sustainedThreshold loudThreshold' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -!classDefinition: #SampledInstrument category: #'Sound-Synthesis'! -Object subclass: #SampledInstrument - instanceVariableNames: 'sustainedSoft sustainedLoud staccatoSoft staccatoLoud sustainedThreshold loudThreshold' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -SampledInstrument class - instanceVariableNames: ''! - -!classDefinition: 'SampledInstrument class' category: #'Sound-Synthesis'! -SampledInstrument class - instanceVariableNames: ''! - -Object subclass: #SoundCodec - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -!classDefinition: #SoundCodec category: #'Sound-Synthesis'! -Object subclass: #SoundCodec - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -SoundCodec class - instanceVariableNames: ''! - -!classDefinition: 'SoundCodec class' category: #'Sound-Synthesis'! -SoundCodec class - instanceVariableNames: ''! - -SoundCodec subclass: #ADPCMCodec - instanceVariableNames: 'predicted index deltaSignMask deltaValueMask deltaValueHighBit frameSizeMask currentByte bitPosition byteIndex encodedBytes samples rightSamples sampleIndex bitsPerSample stepSizeTable indexTable' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -!classDefinition: #ADPCMCodec category: #'Sound-Synthesis'! -SoundCodec subclass: #ADPCMCodec - instanceVariableNames: 'predicted index deltaSignMask deltaValueMask deltaValueHighBit frameSizeMask currentByte bitPosition byteIndex encodedBytes samples rightSamples sampleIndex bitsPerSample stepSizeTable indexTable' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -ADPCMCodec class - instanceVariableNames: ''! - -!classDefinition: 'ADPCMCodec class' category: #'Sound-Synthesis'! -ADPCMCodec class - instanceVariableNames: ''! - -SoundCodec subclass: #GSMCodec - instanceVariableNames: 'encodeState decodeState' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -!classDefinition: #GSMCodec category: #'Sound-Synthesis'! -SoundCodec subclass: #GSMCodec - instanceVariableNames: 'encodeState decodeState' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -GSMCodec class - instanceVariableNames: ''! - -!classDefinition: 'GSMCodec class' category: #'Sound-Synthesis'! -GSMCodec class - instanceVariableNames: ''! - -SoundCodec subclass: #MuLawCodec - instanceVariableNames: '' - classVariableNames: 'DecodingTable' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -!classDefinition: #MuLawCodec category: #'Sound-Synthesis'! -SoundCodec subclass: #MuLawCodec - instanceVariableNames: '' - classVariableNames: 'DecodingTable' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -MuLawCodec class - instanceVariableNames: ''! - -!classDefinition: 'MuLawCodec class' category: #'Sound-Synthesis'! -MuLawCodec class - instanceVariableNames: ''! - -Object subclass: #SoundPlayer - instanceVariableNames: '' - classVariableNames: 'ActiveSounds Buffer BufferIndex BufferMSecs LastBuffer PlayerProcess PlayerSemaphore ReadyForBuffer ReverbState SamplingRate SoundJustStarted SoundSupported Stereo UseReadySemaphore UseReverb' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -!classDefinition: #SoundPlayer category: #'Sound-Synthesis'! -Object subclass: #SoundPlayer - instanceVariableNames: '' - classVariableNames: 'ActiveSounds Buffer BufferIndex BufferMSecs LastBuffer PlayerProcess PlayerSemaphore ReadyForBuffer ReverbState SamplingRate SoundJustStarted SoundSupported Stereo UseReadySemaphore UseReverb' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -SoundPlayer class - instanceVariableNames: ''! - -!classDefinition: 'SoundPlayer class' category: #'Sound-Synthesis'! -SoundPlayer class - instanceVariableNames: ''! - -Object subclass: #SoundRecorder - instanceVariableNames: 'stereo samplingRate recordLevel recordedBuffers recordedSound recordProcess bufferAvailableSema paused meteringBuffer meterLevel soundPlaying currentBuffer nextIndex codec desiredSampleRate' - classVariableNames: 'CanRecordWhilePlaying RecorderActive' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -!classDefinition: #SoundRecorder category: #'Sound-Synthesis'! -Object subclass: #SoundRecorder - instanceVariableNames: 'stereo samplingRate recordLevel recordedBuffers recordedSound recordProcess bufferAvailableSema paused meteringBuffer meterLevel soundPlaying currentBuffer nextIndex codec desiredSampleRate' - classVariableNames: 'CanRecordWhilePlaying RecorderActive' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -SoundRecorder class - instanceVariableNames: ''! - -!classDefinition: 'SoundRecorder class' category: #'Sound-Synthesis'! -SoundRecorder class - instanceVariableNames: ''! - -SoundRecorder subclass: #SoundInputStream - instanceVariableNames: 'bufferSize mutex' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -!classDefinition: #SoundInputStream category: #'Sound-Synthesis'! -SoundRecorder subclass: #SoundInputStream - instanceVariableNames: 'bufferSize mutex' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Synthesis'! - -SoundInputStream class - instanceVariableNames: ''! - -!classDefinition: 'SoundInputStream class' category: #'Sound-Synthesis'! -SoundInputStream class - instanceVariableNames: ''! - -Object subclass: #AbstractScoreEvent - instanceVariableNames: 'time' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Scores'! - -!classDefinition: #AbstractScoreEvent category: #'Sound-Scores'! -Object subclass: #AbstractScoreEvent - instanceVariableNames: 'time' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Scores'! - -AbstractScoreEvent class - instanceVariableNames: ''! - -!classDefinition: 'AbstractScoreEvent class' category: #'Sound-Scores'! -AbstractScoreEvent class - instanceVariableNames: ''! - -AbstractScoreEvent subclass: #ControlChangeEvent - instanceVariableNames: 'control value channel' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Scores'! - -!classDefinition: #ControlChangeEvent category: #'Sound-Scores'! -AbstractScoreEvent subclass: #ControlChangeEvent - instanceVariableNames: 'control value channel' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Scores'! - -ControlChangeEvent class - instanceVariableNames: ''! - -!classDefinition: 'ControlChangeEvent class' category: #'Sound-Scores'! -ControlChangeEvent class - instanceVariableNames: ''! - -AbstractScoreEvent subclass: #NoteEvent - instanceVariableNames: 'duration midiKey velocity channel' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Scores'! - -!classDefinition: #NoteEvent category: #'Sound-Scores'! -AbstractScoreEvent subclass: #NoteEvent - instanceVariableNames: 'duration midiKey velocity channel' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Scores'! - -NoteEvent class - instanceVariableNames: ''! - -!classDefinition: 'NoteEvent class' category: #'Sound-Scores'! -NoteEvent class - instanceVariableNames: ''! - -AbstractScoreEvent subclass: #PitchBendEvent - instanceVariableNames: 'bend channel' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Scores'! - -!classDefinition: #PitchBendEvent category: #'Sound-Scores'! -AbstractScoreEvent subclass: #PitchBendEvent - instanceVariableNames: 'bend channel' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Scores'! - -PitchBendEvent class - instanceVariableNames: ''! - -!classDefinition: 'PitchBendEvent class' category: #'Sound-Scores'! -PitchBendEvent class - instanceVariableNames: ''! - -AbstractScoreEvent subclass: #ProgramChangeEvent - instanceVariableNames: 'program channel' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Scores'! - -!classDefinition: #ProgramChangeEvent category: #'Sound-Scores'! -AbstractScoreEvent subclass: #ProgramChangeEvent - instanceVariableNames: 'program channel' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Scores'! - -ProgramChangeEvent class - instanceVariableNames: ''! - -!classDefinition: 'ProgramChangeEvent class' category: #'Sound-Scores'! -ProgramChangeEvent class - instanceVariableNames: ''! - -AbstractScoreEvent subclass: #TempoEvent - instanceVariableNames: 'tempo' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Scores'! - -!classDefinition: #TempoEvent category: #'Sound-Scores'! -AbstractScoreEvent subclass: #TempoEvent - instanceVariableNames: 'tempo' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Scores'! - -TempoEvent class - instanceVariableNames: ''! - -!classDefinition: 'TempoEvent class' category: #'Sound-Scores'! -TempoEvent class - instanceVariableNames: ''! - -Object subclass: #MIDIFileReader - instanceVariableNames: 'stream fileType trackCount ticksPerQuarter tracks trackInfo tempoMap strings track trackStream activeEvents maxNoteTicks' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Scores'! - -!classDefinition: #MIDIFileReader category: #'Sound-Scores'! -Object subclass: #MIDIFileReader - instanceVariableNames: 'stream fileType trackCount ticksPerQuarter tracks trackInfo tempoMap strings track trackStream activeEvents maxNoteTicks' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Scores'! - -MIDIFileReader class - instanceVariableNames: ''! - -!classDefinition: 'MIDIFileReader class' category: #'Sound-Scores'! -MIDIFileReader class - instanceVariableNames: ''! - -Object subclass: #MIDIInputParser - instanceVariableNames: 'cmdActionTable midiPort received rawDataBuffer sysExBuffer ignoreSysEx startTime timeNow state lastSelector lastCmdByte argByte1 argByte2' - classVariableNames: 'DefaultMidiTable' - poolDictionaries: '' - category: 'Sound-Scores'! - -!classDefinition: #MIDIInputParser category: #'Sound-Scores'! -Object subclass: #MIDIInputParser - instanceVariableNames: 'cmdActionTable midiPort received rawDataBuffer sysExBuffer ignoreSysEx startTime timeNow state lastSelector lastCmdByte argByte1 argByte2' - classVariableNames: 'DefaultMidiTable' - poolDictionaries: '' - category: 'Sound-Scores'! - -MIDIInputParser class - instanceVariableNames: ''! - -!classDefinition: 'MIDIInputParser class' category: #'Sound-Scores'! -MIDIInputParser class - instanceVariableNames: ''! - -Object subclass: #MIDIScore - instanceVariableNames: 'tracks trackInfo tempoMap ticksPerQuarterNote' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Scores'! - -!classDefinition: #MIDIScore category: #'Sound-Scores'! -Object subclass: #MIDIScore - instanceVariableNames: 'tracks trackInfo tempoMap ticksPerQuarterNote' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Scores'! - -MIDIScore class - instanceVariableNames: ''! - -!classDefinition: 'MIDIScore class' category: #'Sound-Scores'! -MIDIScore class - instanceVariableNames: ''! - -Object subclass: #MIDISynth - instanceVariableNames: 'midiParser channels process' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Scores'! - -!classDefinition: #MIDISynth category: #'Sound-Scores'! -Object subclass: #MIDISynth - instanceVariableNames: 'midiParser channels process' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Scores'! - -MIDISynth class - instanceVariableNames: ''! - -!classDefinition: 'MIDISynth class' category: #'Sound-Scores'! -MIDISynth class - instanceVariableNames: ''! - -Object subclass: #MIDISynthChannel - instanceVariableNames: 'instrument muted masterVolume channelVolume pan pitchBend activeSounds' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Scores'! - -!classDefinition: #MIDISynthChannel category: #'Sound-Scores'! -Object subclass: #MIDISynthChannel - instanceVariableNames: 'instrument muted masterVolume channelVolume pan pitchBend activeSounds' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-Scores'! - -MIDISynthChannel class - instanceVariableNames: ''! - -!classDefinition: 'MIDISynthChannel class' category: #'Sound-Scores'! -MIDISynthChannel class - instanceVariableNames: ''! - -Object subclass: #SimpleMIDIPort - instanceVariableNames: 'portNumber accessSema lastCommandByteOut' - classVariableNames: 'DefaultPortNumber InterfaceClockRate' - poolDictionaries: '' - category: 'Sound-Scores'! - -!classDefinition: #SimpleMIDIPort category: #'Sound-Scores'! -Object subclass: #SimpleMIDIPort - instanceVariableNames: 'portNumber accessSema lastCommandByteOut' - classVariableNames: 'DefaultPortNumber InterfaceClockRate' - poolDictionaries: '' - category: 'Sound-Scores'! - -SimpleMIDIPort class - instanceVariableNames: ''! - -!classDefinition: 'SimpleMIDIPort class' category: #'Sound-Scores'! -SimpleMIDIPort class - instanceVariableNames: ''! - -Object subclass: #Beeper - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-System-Support'! - -!classDefinition: #Beeper category: #'Sound-System-Support'! -Object subclass: #Beeper - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Sound-System-Support'! - -Beeper class - instanceVariableNames: 'default'! - -!classDefinition: 'Beeper class' category: #'Sound-System-Support'! -Beeper class - instanceVariableNames: 'default'! - -Object subclass: #SoundSystem - instanceVariableNames: '' - classVariableNames: 'Default' - poolDictionaries: '' - category: 'Sound-System-Support'! - -!classDefinition: #SoundSystem category: #'Sound-System-Support'! -Object subclass: #SoundSystem - instanceVariableNames: '' - classVariableNames: 'Default' - poolDictionaries: '' - category: 'Sound-System-Support'! - -SoundSystem class - instanceVariableNames: ''! - -!classDefinition: 'SoundSystem class' category: #'Sound-System-Support'! -SoundSystem class - instanceVariableNames: ''! -!SoundBuffer commentStamp: '' prior: 0! - SoundBuffers store 16 bit unsigned quantities. - -Array size must be even, as two vales are stored in each word.! -!Sonogram commentStamp: '' prior: 0! - Sonograms are imageMorphs that will repeatedly plot arrays of values as black on white columns moving to the right in time and scrolling left as necessary.! -!AIFFFileReader commentStamp: '' prior: 0! - I am a parser for AIFF (audio interchange file format) files. I can read uncompressed 8-bit and 16-bit mono, stereo, or multichannel AIFF files. I read the marker information used by the TransferStation utility to mark the loop points in sounds extracted from commercial sampled-sound CD-ROMs. -! -!UnloadedSound commentStamp: '' prior: 0! - Instances of me, which are really just FMSounds, are used placeholders for sounds that have been unloaded from this image but which may be re-loaded later.! -!LoopedSampledSound commentStamp: '' prior: 0! - I respresent a sequence of sound samples, often used to record a single note played by a real instrument. I can be pitch-shifted up or down, and can include a looped portion to allow a sound to be sustained indefinitely. -! -!PluckedSound commentStamp: '' prior: 0! - The Karplus-Strong plucked string algorithm: start with a buffer full of random noise and repeatedly play the contents of that buffer while averaging adjacent samples. High harmonics damp out more quickly, transfering their energy to lower ones. The length of the buffer corresponds to the length of the string. Fractional indexing is used to allow precise tuning; without this, the pitch would be rounded to the pitch corresponding to the nearest buffer size. -! -!QueueSound commentStamp: 'efc 1/2/2003 00:30' prior: 0! - I am a queue for sound - give me a bunch of sounds to play and I will play them one at a time in the order that they are received. - -Example: -"Here is a simple example which plays two sounds three times." -| clink warble queue | -clink _ SampledSound soundNamed: 'clink'. -warble _ SampledSound soundNamed: 'warble'. -queue _ QueueSound new. -3 timesRepeat:[ - queue add: clink; add: warble -]. -queue play. - -Structure: - startTime Integer -- if present, start playing when startTime <= Time millisecondClockValue - (schedule the sound to play later) - sounds SharedQueue -- the synchronized list of sounds. - currentSound AbstractSound -- the currently active sound - done Boolean -- am I done playing ? - -Other: -You may want to keep track of the queue's position so that you can feed it at an appropriate rate. To do this in an event driven way, modify or subclass nextSound to notify you when appropriate. You could also poll by checking currentSound, but this is not recommended for most applications. - -! -!StreamingMonoSound commentStamp: '' prior: 0! - I implement a streaming player for monophonic Sun (.au) and AIFF (.aif) audio files. -Example of use: - (StreamingMonoSound onFileNamed: 'song.aif') play. -! -!ScorePlayer commentStamp: '' prior: 0! - This is a real-time player for MIDI scores (i.e., scores read from MIDI files). Score can be played using either the internal sound synthesis or an external MIDI synthesizer on platforms that support MIDI output. -! -!CompressedSoundData commentStamp: '' prior: 0! - Instances of this class hold the data resulting from compressing a sound. Each carries a reference to the codec class that created it, so that it can reconstruct a sound similar to the original in response to the message asSound. - -In order to facilitate integration with existing sounds, a CompressedSoundData instance can masquerade as a sound by caching a copy of its original sound and delegating the essential sound-playing protocol to that cached copy. It should probably be made a subclass of AbstractSound to complete the illusion.! -!Envelope commentStamp: '' prior: 0! - An envelope models a three-stage progression for a musical note: attack, sustain, decay. Envelopes can either return the envelope value at a given time or can update some target object using a client-specified message selector. - -The points instance variable holds an array of (time, value) points, where the times are in milliseconds. The points array must contain at least two points. The time coordinate of the first point must be zero and the time coordinates of subsequent points must be in ascending order, although the spacing between them is arbitrary. Envelope values between points are computed by linear interpolation. - -The scale slot is initially set so that the peak of envelope matches some note attribute, such as its loudness. When entering the decay phase, the scale is adjusted so that the decay begins from the envelope's current value. This avoids a potential sharp transient when entering the decay phase. - -The loopStartIndex and loopEndIndex slots contain the indices of points in the points array; if they are equal, then the envelope holds a constant value for the sustain phase of the note. Otherwise, envelope values are computed by repeatedly looping between these two points. - -The loopEndMSecs slot can be set in advance (as when playing a score) or dynamically (as when responding to interactive inputs from a MIDI keyboard). In the latter case, the value of scale is adjusted to start the decay phase with the current envelope value. Thus, if a note ends before its attack is complete, the decay phase is started immediately (i.e., the attack phase is never completed). - -For best results, amplitude envelopes should start and end with zero values. Otherwise, the sharp transient at the beginning or end of the note may cause audible clicks or static. For envelopes on other parameters, this may not be necessary. -! -!SampledInstrument commentStamp: '' prior: 0! - I represent a collection of individual notes at different pitches, volumes, and articulations. On request, I can select the best note to use for a given pitch, duration, and volume. I currently only support two volumes, loud and soft, and two articulations, normal and staccato, but I can easily be extended to include more. The main barrier to keeping more variations is simply the memory space (assuming my component notes are sampled sounds). -! -!SoundCodec commentStamp: '' prior: 0! - I am an abstract class that describes the protocol for sound codecs. Each codec (the name stems from "COder/DECoder") describes a particular algorithm for compressing and decompressing sound data. Most sound codecs are called 'lossy' because they lose information; the decompressed sound data is not exactly the same as the original data. -! -!ADPCMCodec commentStamp: '' prior: 0! - This is a simple ADPCM (adapative delta pulse code modulation) codec. This is a general audio codec that compresses speech, music, or sound effects equally well, and works at any sampling rate (i.e., it contains no frequency-sensitive filters). It compresses 16-bit sample data down to 5, 4, 3, or 2 bits per sample, with lower fidelity and increased noise at the lowest bit rates. Although it does not deliver state-of-the-art compressions, the algorithm is small, simple, and extremely fast, since the encode/decode primitives have been translated into C primitives. - -This codec will also encode and decode all Flash .swf file compressed sound formats, both mono and stereo. (Note: stereo Flash compression is not yet implemented, but stereo decompression works.) -! -!MuLawCodec commentStamp: '' prior: 0! - I represent a mu-law (u-law) codec. I compress sound data by a factor of 2:1 by encoding the most significant 12 bits of each 16-bit sample as a signed, exponentially encoded byte. The idea is to use more resolution for smaller lower sample values. This encoding was developed for the North American phone system and a variant of it, a-law, is a European phone standard. It is a popular sound encoding on Unix platforms (.au files). -! -!SoundInputStream commentStamp: '' prior: 0! - This subclass of SoundRecorder supports real-time processing of incoming sound data. The sound input process queues raw sound buffers, allowing them to be read and processed by the client as they become available. A semaphore is used to synchronize between the record process and the client process. Since sound data is buffered, the client process may lag behind the input process without losing data. -! -!AbstractScoreEvent commentStamp: '' prior: 0! - Abstract class for timed events in a MIDI score. -! -!NoteEvent commentStamp: '' prior: 0! - Represents a note on or off event in a MIDI score. -! -!TempoEvent commentStamp: '' prior: 0! - Represents a tempo change in a MIDI score. -! -!MIDIFileReader commentStamp: '' prior: 0! - A reader for Standard 1.0 format MIDI files. -MIDI File Types: - type 0 -- one multi-channel track - type 1 -- one or more simultaneous tracks - type 2 -- a number on independent single-track patterns - -Instance variables: - stream source of MIDI data - fileType MIDI file type - trackCount number of tracks in file - ticksPerQuarter number of ticks per quarter note for all tracks in this file - tracks collects track data for non-empty tracks - strings collects all strings in the MIDI file - tempoMap nil or a MIDITrack consisting only of tempo change events - trackStream stream on buffer containing track chunk - track track being read - activeEvents notes that have been turned on but not off -! -!MIDIInputParser commentStamp: '' prior: 0! - I am a parser for a MIDI data stream. I support: - - real-time MIDI recording, - overdubbing (recording while playing), - monitoring incoming MIDI, and - interactive MIDI performances. - -Note: MIDI controllers such as pitch benders and breath controllers generate large volumes of data which consume processor time. In cases where this information is not of interest to the program using it, it is best to filter it out as soon as possible. I support various options for doing this filtering, including filtering by MIDI channel and/or by command type. -! -!MIDIScore commentStamp: '' prior: 0! - A MIDIScore is a container for a number of MIDI tracks as well as an ambient track for such things as sounds, book page triggers and other related events.! -!MIDISynth commentStamp: '' prior: 0! - I implement a simple real-time MIDI synthesizer on platforms that support MIDI input. I work best on platforms that allow the sound buffer to be made very short--under 50 milliseconds is good and under 20 milliseconds is preferred (see below). The buffer size is changed by modifying the class initialization method of SoundPlayer and executing the do-it there to re-start the sound player. - -Each instance of me takes input from a single MIDI input port. Multiple instances of me can be used to handle multiple MIDI input ports. I distribute incoming commands among my sixteen MIDISynthChannel objects. Most of the interpretation of the MIDI commands is done by these channel objects. - -Buffer size notes: At the moment, most fast PowerPC Macintosh computers can probably work with buffer sizes down to 50 milliseconds, and the Powerbook G3 works down to about 15 milliseconds. You will need to experiment to discover the minimum buffer size that does not result in clicking during sound output. (Hint: Be sure to turn off power cycling on your Powerbook. Other applications and extensions can steal cycles from Squeak, causing intermittent clicking. Experimentation may be necessary to find a configuration that works for you.) -! -!MIDISynthChannel commentStamp: '' prior: 0! - I implement one polyphonic channel of a 16-channel MIDI synthesizer. Many MIDI commands effect all the notes played on a particular channel, so I record the state for a single channel, including a list of notes currently playing. - -This initial implementation is extremely spartan, having just enough functionality to play notes. Things that are not implemented include: - - 1. program changes - 2. sustain pedal - 3. aftertouch (either kind) - 4. most controllers - 5. portamento - 6. mono-mode -! -!SimpleMIDIPort commentStamp: '' prior: 0! - This is a first cut at a simple MIDI output port. -! -!Beeper commentStamp: 'gk 2/26/2004 22:44' prior: 0! - Beeper provides simple audio (or in some other way) feedback to the user. - -The recommended use is "Beeper beep" to give the user the equivalence of a beep. If you want to force the beep to use the primitive in the VM for beeping, then use "Beeper beepPrimitive". In either case, if sounds are disabled there will be no beep. - -The actual beeping, when you use "Beeper beep", is done by sending a #play message to a registered playable object. You can register your own playable object by invoking the class side method #setDefault: passing in an object that responds to the #play message. - -The default playable object is an instance of Beeper itself which implements #play on the instance side. That implementation delegates the playing of the beep to the default SoundService. - -Note that #play is introduced as a common interface between AbstractSound and Beeper. -This way we can register instances of AbstractSound as playable entities, for example: - - Beeper setDefault: (SampledSound new - setSamples: self coffeeCupClink - samplingRate: 12000). - -Then "Beeper beep" will play the coffeeCup sound.! -!SoundSystem commentStamp: '' prior: 0! - This is the sound system. A sound system offers a small protocol for playing sounds and making beeps and works like a facade towards the rest of Squeak. A sound system is registered in the application registry SoundService and can be accessed by "SoundService default" like for example: - -SoundService default playSoundNamed: 'croak' - -The idea is that as much sound playing as possible should go through this facade. This way we decouple the sound system from the rest of Squeak and make it pluggable. It also is a perfect spot to check for the Preference class>>soundsEnabled. - -Two basic subclasses exist at the time of this writing, the BaseSoundSystem which represents the standard Squeak sound system, and the DummySoundSystem which is a dummy implementation that can be used when there is no sound card available, or when the base sound system isn't in the image, or when you simply don't want to use the available sound card.! -!FileEntry methodsFor: '*Sound' stamp: 'jmv 7/24/2017 16:25:59'! - wavContents - ^SampledSound fromFileEntry: self! ! -!SoundBuffer methodsFor: 'utilities' stamp: 'jm 8/15/1998 13:03'! - asByteArray - "Answer a ByteArray containing my sample data serialized in most-significant byte first order." - - | sampleCount bytes dst s | - sampleCount _ self monoSampleCount. - bytes _ ByteArray new: 2 * sampleCount. - dst _ 0. - 1 to: sampleCount do: [:src | - s _ self at: src. - bytes at: (dst _ dst + 1) put: ((s bitShift: -8) bitAnd: 255). - bytes at: (dst _ dst + 1) put: (s bitAnd: 255)]. - ^ bytes - - ! ! -!SoundBuffer methodsFor: 'primitives' stamp: 'jm 9/17/97 13:03'! - at: index - "Return the 16-bit integer value at the given index of the receiver." - - - index isInteger ifTrue: [self errorSubscriptBounds: index]. - index isNumber ifTrue: [^ self at: index truncated]. - self errorNonIntegerIndex. -! ! -!SoundBuffer methodsFor: 'primitives' stamp: 'jm 9/17/97 13:03'! - at: index put: value - "Store the given 16-bit integer at the given index in the receiver." - - - index isInteger - ifTrue: [ - (index >= 1 and: [index <= self size]) - ifTrue: [self errorImproperStore] - ifFalse: [self errorSubscriptBounds: index]]. - index isNumber ifTrue: [^ self at: index truncated put: value]. - self errorNonIntegerIndex. -! ! -!SoundBuffer methodsFor: 'utilities' stamp: 'RAA 12/30/2000 18:26'! - averageEvery: nSamples from: anotherBuffer upTo: inCount - - | fromIndex sum | - - fromIndex _ 1. - 1 to: inCount // nSamples do: [ :i | - sum _ 0. - nSamples timesRepeat: [ - sum _ sum + (anotherBuffer at: fromIndex). - fromIndex _ fromIndex + 1. - ]. - self at: i put: sum // nSamples. - ]. -! ! -!SoundBuffer methodsFor: 'accessing' stamp: 'tk 3/13/2000 14:46'! - bytesPerElement - "Number of bytes in each item. This multiplied by (self size)*8 gives the number of bits stored." - ^ 2! ! -!SoundBuffer methodsFor: 'utilities' stamp: 'jm 8/18/1998 06:49'! - downSampledLowPassFiltering: doFiltering - "Answer a new SoundBuffer half the size of the receiver consisting of every other sample. If doFiltering is true, a simple low-pass filter is applied to avoid aliasing of high frequencies. Assume that receiver is monophonic." - "Details: The simple low-pass filter in the current implementation could be improved, at some additional cost." - - | n resultBuf j | - n _ self monoSampleCount. - resultBuf _ SoundBuffer newMonoSampleCount: n // 2. - j _ 0. - doFiltering - ifTrue: [ - 1 to: n by: 2 do: [:i | - resultBuf at: (j _ j + 1) put: - (((self at: i) + (self at: i + 1)) bitShift: -1)]] - ifFalse: [ - 1 to: n by: 2 do: [:i | - resultBuf at: (j _ j + 1) put: (self at: i)]]. - - ^ resultBuf! ! -!SoundBuffer methodsFor: 'utilities' stamp: 'jm 8/18/1998 06:52'! - extractLeftChannel - "Answer a new SoundBuffer half the size of the receiver consisting of only the left channel of the receiver, which is assumed to contain stereo sound data." - - | n resultBuf j | - n _ self monoSampleCount. - resultBuf _ SoundBuffer newMonoSampleCount: n // 2. - j _ 0. - 1 to: n by: 2 do: [:i | resultBuf at: (j _ j + 1) put: (self at: i)]. - ^ resultBuf! ! -!SoundBuffer methodsFor: 'utilities' stamp: 'jm 8/18/1998 06:53'! - extractRightChannel - "Answer a new SoundBuffer half the size of the receiver consisting of only the right channel of the receiver, which is assumed to contain stereo sound data." - - | n resultBuf j | - n _ self monoSampleCount. - resultBuf _ SoundBuffer newMonoSampleCount: n // 2. - j _ 0. - 2 to: n by: 2 do: [:i | resultBuf at: (j _ j + 1) put: (self at: i)]. - ^ resultBuf! ! -!SoundBuffer methodsFor: 'utilities' stamp: 'jhm 10/15/97 15:13'! - indexOfFirstSampleOver: threshold - "Return the index of the first sample whose absolute value is over the given threshold value. Return an index one greater than my size if no sample is over the threshold." - - 1 to: self size do: [:i | - (self at: i) abs > threshold ifTrue: [^ i]]. - ^ self size + 1! ! -!SoundBuffer methodsFor: 'utilities' stamp: 'jhm 10/15/97 15:13'! - indexOfLastSampleOver: threshold - "Return the index of the last sample whose absolute value is over the given threshold value. Return zero if no sample is over the threshold." - - self size to: 1 by: -1 do: [:i | - (self at: i) abs > threshold ifTrue: [^ i]]. - ^ 0 -! ! -!SoundBuffer methodsFor: 'utilities' stamp: 'jmv 5/14/2015 09:54'! - lowPassFiltered - "Answer a simple low-pass filtered copy of this buffer. Assume it is monophonic." - - | sz out last this | - sz _ self monoSampleCount. - out _ self copy. - last _ self at: 1. - 2 to: sz do: [:i | - this _ self at: i. - out at: i put: (this + last) // 2. - last _ this]. - ^ out -! ! -!SoundBuffer methodsFor: 'utilities' stamp: 'jm 11/15/2001 18:26'! - mergeStereo - "Answer a new SoundBuffer half the size of the receiver that mixes the left and right stereo channels of the receiver, which is assumed to contain stereo sound data." - - | n resultBuf j | - n _ self monoSampleCount. - resultBuf _ SoundBuffer newMonoSampleCount: n // 2. - j _ 0. - 1 to: n by: 2 do: [:i | resultBuf at: (j _ j + 1) put: (((self at: i) + (self at: i + 1)) // 2)]. - ^ resultBuf -! ! -!SoundBuffer methodsFor: 'accessing' stamp: 'jm 9/17/97 13:00'! - monoSampleCount - "Return the number of monaural 16-bit samples that fit into this SoundBuffer." - - ^ super size * 2 -! ! -!SoundBuffer methodsFor: 'utilities' stamp: 'jhm 10/15/97 15:13'! - normalized: percentOfFullVolume - "Increase my amplitudes so that the highest peak is the given percent of full volume. For example 's normalized: 50' would normalize to half of full volume." - - | peak s mult | - peak _ 0. - 1 to: self size do: [:i | - s _ (self at: i) abs. - s > peak ifTrue: [peak _ s]]. - mult _ (32767.0 * percentOfFullVolume) / (100.0 * peak). - 1 to: self size do: [:i | self at: i put: (mult * (self at: i)) asInteger]. -! ! -!SoundBuffer methodsFor: 'primitives' stamp: 'jm 9/2/97 16:07'! - 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." - "Note: Since 16-bit word arrays are not built into the virtual machine, this primitive fills by 32-bit words." - - - self errorImproperStore. -! ! -!SoundBuffer methodsFor: 'objects from disk' stamp: 'jmv 2/15/2008 00:49'! - restoreEndianness - "This word object was just read in from a stream. It was stored in Big Endian (Mac) format. Swap each pair of bytes (16-bit word), if the current machine is Little Endian. - Why is this the right thing to do? We are using memory as a byteStream. High and low bytes are reversed in each 16-bit word, but the stream of words ascends through memory. Different from a Bitmap." - - | hack blt | - Smalltalk isLittleEndian ifTrue: [ - "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: 1. - blt sourceX: 0; destX: 1; copyBits. "Exchange bytes 0 and 1" - blt sourceX: 1; destX: 0; copyBits. - blt sourceX: 0; destX: 1; copyBits. - blt sourceX: 2; destX: 3; copyBits. "Exchange bytes 2 and 3" - blt sourceX: 3; destX: 2; copyBits. - blt sourceX: 2; destX: 3; copyBits]. - -! ! -!SoundBuffer methodsFor: 'objects from disk' stamp: 'jm 10/29/2001 19:53'! - reverseEndianness - "Swap the bytes of each 16-bit word, using a fast BitBlt hack." - - | hack blt | - 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: 1. - blt sourceX: 0; destX: 1; copyBits. "Exchange bytes 0 and 1" - blt sourceX: 1; destX: 0; copyBits. - blt sourceX: 0; destX: 1; copyBits. - blt sourceX: 2; destX: 3; copyBits. "Exchange bytes 2 and 3" - blt sourceX: 3; destX: 2; copyBits. - blt sourceX: 2; destX: 3; copyBits. -! ! -!SoundBuffer methodsFor: 'utilities' stamp: 'jmv 2/26/2016 17:09'! - saveAsAIFFFileSamplingRate: rate on: aBinaryStream - "Store this mono sound buffer in AIFF file format with the given sampling rate on the given stream." - - | sampleCount s swapBytes | - sampleCount _ self monoSampleCount. - aBinaryStream nextPutAll: 'FORM' asByteArray. - aBinaryStream nextSignedInt32Put: (2 * sampleCount) + ((7 * 4) + 18) bigEndian: true. - aBinaryStream nextPutAll: 'AIFF' asByteArray. - aBinaryStream nextPutAll: 'COMM' asByteArray. - aBinaryStream nextSignedInt32Put: 18 bigEndian: true. - aBinaryStream nextUnsignedInt16Put: 1 bigEndian: true. "channels" - aBinaryStream nextSignedInt32Put: sampleCount bigEndian: true. - aBinaryStream nextUnsignedInt16Put: 16 bigEndian: true. "bits/sample" - self storeExtendedFloat: rate on: aBinaryStream. - aBinaryStream nextPutAll: 'SSND' asByteArray. - aBinaryStream nextSignedInt32Put: (2 * sampleCount) + 8 bigEndian: true. - aBinaryStream nextSignedInt32Put: 0 bigEndian: true. - aBinaryStream nextSignedInt32Put: 0 bigEndian: true. - - (aBinaryStream isKindOf: StandardFileStream) ifTrue: [ - "optimization: write sound buffer directly to file" - swapBytes _ Smalltalk isLittleEndian. - swapBytes ifTrue: [self reverseEndianness]. "make big endian" - aBinaryStream next: (self size // 2) putAll: self startingAt: 1. "size in words" - swapBytes ifTrue: [self reverseEndianness]. "revert to little endian" - ^ self]. - - 1 to: sampleCount do: [:i | - s _ self at: i. - aBinaryStream nextPut: ((s bitShift: -8) bitAnd: 16rFF). - aBinaryStream nextPut: (s bitAnd: 16rFF)]. -! ! -!SoundBuffer methodsFor: 'accessing' stamp: 'jm 9/17/97 13:28'! - size - "Return the number of 16-bit sound samples that fit in this sound buffer. To avoid confusion, it is better to get the size of SoundBuffer using monoSampleCount or stereoSampleCount." - - ^ self monoSampleCount -! ! -!SoundBuffer methodsFor: 'utilities' stamp: 'jm 3/28/1999 07:23'! - splitStereo - "Answer an array of two SoundBuffers half the size of the receiver consisting of the left and right channels of the receiver (which is assumed to contain stereo sound data)." - - | n leftBuf rightBuf leftIndex rightIndex | - n _ self monoSampleCount. - leftBuf _ SoundBuffer newMonoSampleCount: n // 2. - rightBuf _ SoundBuffer newMonoSampleCount: n // 2. - leftIndex _ rightIndex _ 0. - 1 to: n by: 2 do: [:i | - leftBuf at: (leftIndex _ leftIndex + 1) put: (self at: i). - rightBuf at: (rightIndex _ rightIndex + 1) put: (self at: i + 1)]. - ^ Array with: leftBuf with: rightBuf -! ! -!SoundBuffer methodsFor: 'accessing' stamp: 'jm 9/17/97 13:01'! - stereoSampleCount - "Return the number of stereo slices that fit into this SoundBuffer. A stereo 'slice' consists of two 16-bit samples, one for each channel." - - ^ super size -! ! -!SoundBuffer methodsFor: 'utilities' stamp: 'jhm 10/15/97 15:13'! - trimmedThreshold: threshold - - | start end | - start _ self indexOfFirstSampleOver: threshold. - end _ self indexOfLastSampleOver: threshold. - start > end ifTrue: [^ SoundBuffer new]. - start _ (start - 200) max: 1. - end _ (end + 200) min: self size. - ^ self copyFrom: start to: end -! ! -!SoundBuffer methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 11:31'! - writeOnGZIPByteStream: aStream - - aStream nextPutAllWordArray: self! ! -!SoundBuffer class methodsFor: 'instance creation' stamp: 'RAA 12/30/2000 18:20'! - averageEvery: nSamples from: anotherBuffer upTo: inCount - - ^(self newMonoSampleCount: inCount // nSamples) - averageEvery: nSamples - from: anotherBuffer - upTo: inCount! ! -!SoundBuffer class methodsFor: 'instance creation' stamp: 'jm 9/17/97 12:39'! - fromArray: anArray - "Return a new SoundBuffer whose contents are copied from the given Array or ByteArray." - - | new | - new _ SoundBuffer newMonoSampleCount: anArray size. - 1 to: anArray size do: [:i | new at: i put: (anArray at: i)]. - ^ new -! ! -!SoundBuffer class methodsFor: 'instance creation' stamp: 'jm 8/15/1998 14:35'! - fromByteArray: aByteArray - "Convert the given ByteArray (stored with the most significant byte first) into 16-bit sample buffer." - - | n buf src w | - n _ aByteArray size // 2. - buf _ SoundBuffer newMonoSampleCount: n. - src _ 1. - 1 to: n do: [:i | - w _ ((aByteArray at: src) bitShift: 8) + (aByteArray at: src + 1). - w > 32767 ifTrue: [w _ w - 65536]. - buf at: i put: w. - src _ src + 2]. - ^ buf -! ! -!SoundBuffer class methodsFor: 'class initialization' stamp: 'jmv 12/15/2014 21:51'! - initialize - "SoundBuffer initialize" - Smalltalk addToStartUpList: self! ! -!SoundBuffer class methodsFor: 'instance creation' stamp: 'jm 9/17/97 13:25'! - new: anInteger - "See the comment in newMonoSampleCount:. To avoid confusion, it is best to create new instances using newMonoSampleCount: or newStereoSampleCount:." - - ^ self newMonoSampleCount: anInteger -! ! -!SoundBuffer class methodsFor: 'instance creation' stamp: 'jm 9/17/97 12:44'! - newMonoSampleCount: anInteger - "Return a SoundBuffer large enough to hold the given number of monaural samples (i.e., 16-bit words)." - "Details: The size is rounded up to an even number, since the underlying representation is in terms of 32-bit words." - - ^ self basicNew: (anInteger + 1) // 2 -! ! -!SoundBuffer class methodsFor: 'instance creation' stamp: 'jm 9/17/97 12:52'! - newStereoSampleCount: anInteger - "Return a SoundBuffer large enough to hold the given number of stereo slices. A stereo 'slice' consists of two 16-bit samples, one for each channel." - - ^ self basicNew: anInteger -! ! -!SoundBuffer class methodsFor: 'class initialization' stamp: 'jmv 2/25/2016 10:33'! - startUp - "Check if the word order has changed from the last save." - - | la | - la _ ShortIntegerArray classPool at: #LastSaveOrder. - ((la at: 2) = 42 and: [(la at: 1) = 13]) - ifTrue: [ - self allInstancesDo: [ :each | - BitBlt swapHalvesIn32BitWords: each ]] - "Reverse the two 16-bit halves." - "Another reversal happened automatically which reversed the bytes."! ! -!Sonogram methodsFor: 'all' stamp: 'jmv 12/16/2011 10:26'! - extent: extent minVal: min maxVal: max scrollDelta: d - minVal _ min. - maxVal _ max. - scrollDelta _ d. - self morphExtent: extent. - -" try following with scrolldelta = 1, 20, 200 - | s data | - s _ Sonogram new extent: 200@50 - minVal: 0.0 maxVal: 1.0 scrollDelta: 20. - World addMorph: s. - data _ (1 to: 133) collect: [:i | 0.0]. - 1 to: 300 do: - [:i | data at: (i\\133)+1 put: 1.0. - s plotColumn: data. - data at: (i\\133)+1 put: 0.0. - World doOneCycleNow]. - s delete -"! ! -!Sonogram methodsFor: 'geometry' stamp: 'jmv 12/16/2011 10:22'! - morphExtent: newExtent - super image: (Form extent: newExtent depth: Display depth). - lastX _ -1. - columnForm _ Form extent: (32//image depth)@(image height) depth: image depth. - pixValMap _ ((1 to: 256) collect: - [:i | columnForm pixelValueFor: (Color gray: (256-i)/255.0)]) - as: Bitmap. -! ! -!Sonogram methodsFor: 'all' stamp: 'jmv 1/21/2015 23:56'! - plotColumn: dataArray - - | chm1 i normVal r | - chm1 _ columnForm height - 1. - 0 to: chm1 do: [ :y | - i _ y*(dataArray size-1)//chm1 + 1. - normVal _ ((dataArray at: i) - minVal) / (maxVal - minVal). - normVal < 0.0 ifTrue: [normVal _ 0.0]. - normVal > 1.0 ifTrue: [normVal _ 1.0]. - columnForm bits at: chm1-y+1 put: (pixValMap at: (normVal * 255.0) truncated + 1)]. - (lastX _ lastX + 1) > (image width - 1) ifTrue: - [self scroll]. - image copy: (r _ (lastX@0 extent: 1@image height)) - from: (32//image depth-1)@0 - in: columnForm rule: Form over. - "self changed." - self invalidateLocalRect: r! ! -!Sonogram methodsFor: 'all' stamp: 'jmv 3/14/2011 09:26'! - scroll - image copy: (scrollDelta@0 extent: (image width-scrollDelta)@image height) - from: image to: 0@0 rule: Form over. - lastX _ lastX - scrollDelta. - self redrawNeeded! ! -!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 8/2/1998 21:25'! - bitsPerSample - - ^ bitsPerSample -! ! -!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 8/2/1998 21:24'! - channelCount - - ^ channelCount -! ! -!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 8/2/1998 21:25'! - channelData - - ^ channelData -! ! -!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 10/20/2001 15:07'! - channelDataOffset - - ^ channelDataOffset -! ! -!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 8/2/1998 21:24'! - frameCount - - ^ frameCount -! ! -!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 8/2/1998 21:25'! - gain - - ^ gain -! ! -!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 7/12/1998 01:40'! - isLooped - - ^ isLooped -! ! -!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 8/2/1998 20:02'! - isStereo - - ^ channelData size = 2 -! ! -!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 7/12/1998 18:26'! - leftSamples - - ^ channelData at: 1 -! ! -!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 7/12/1998 18:30'! - loopEnd - - ^ markers last last -! ! -!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 7/12/1998 18:30'! - loopLength - - ^ markers last last - markers first last -! ! -!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 8/2/1998 21:25'! - markers - - ^ markers -! ! -!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 7/12/1998 01:48'! - pitch - - ^ pitch -! ! -!AIFFFileReader methodsFor: 'other' stamp: 'jm 7/12/1998 01:44'! - pitchForKey: midiKey - "Convert my MIDI key number to a pitch and return it." - - | indexInOctave octave p | - indexInOctave _ (midiKey \\ 12) + 1. - octave _ (midiKey // 12) + 1. - "Table generator: (0 to: 11) collect: [:i | 16.3516 * (2.0 raisedTo: i asFloat / 12.0)]" - p _ #(16.3516 17.32391 18.35405 19.44544 20.60173 21.82677 - 23.12466 24.49972 25.95655 27.50000 29.13524 30.86771) at: indexInOctave. - ^ p * (#(0.5 1.0 2.0 4.0 8.0 16.0 32.0 64.0 128.0 256.0 512.0) at: octave) -! ! -!AIFFFileReader methodsFor: 'private' stamp: 'jm 6/29/1998 07:33'! - readChunk: chunkType size: chunkSize - "Read a AIFF chunk of the given type. Skip unrecognized chunks. Leave the input stream positioned chunkSize bytes past its position when this method is called." - - chunkType = 'COMM' ifTrue: [^ self readCommonChunk: chunkSize]. - chunkType = 'SSND' ifTrue: [^ self readSamplesChunk: chunkSize]. - chunkType = 'INST' ifTrue: [^ self readInstrumentChunk: chunkSize]. - chunkType = 'MARK' ifTrue: [^ self readMarkerChunk: chunkSize]. - in skip: chunkSize. "skip unknown chunks" -! ! -!AIFFFileReader methodsFor: 'private' stamp: 'jmv 2/26/2016 16:59'! - readCommonChunk: chunkSize - "Read a COMM chunk. All AIFF files have exactly one chunk of this type." - - | compressionType | - channelCount _ in nextUnsignedInt16BigEndian: true. - frameCount _ in nextUnsignedInt32BigEndian: true. - bitsPerSample _ in nextUnsignedInt16BigEndian: true. - samplingRate _ self readExtendedFloat. - chunkSize > 18 ifTrue: [ - fileType = 'AIFF' - ifTrue: [self error: 'unexpectedly long COMM chunk size for AIFF file']. - compressionType _ (in next: 4) asString. - compressionType = 'NONE' ifFalse: [self error: 'cannot read compressed AIFF files']. - in skip: (chunkSize - 22)]. "skip the reminder of AIFF-C style chunk" -! ! -!AIFFFileReader methodsFor: 'private' stamp: 'jmv 2/29/2016 10:44'! - readExtendedFloat - "Read and answer an Apple extended-precision 80-bit floating point number from the input stream." - "Details: I could not find the specification for this format, so constants were determined empirically based on assumption of 1-bit sign, 15-bit exponent, 64-bit mantissa. This format does not seem to have an implicit one before the mantissa as some float formats do." - - | signAndExp mantissa sign exp | - signAndExp _ in nextUnsignedInt16BigEndian: true. - mantissa _ in nextNumber: 8. "scaled by (2 raisedTo: -64) below" - (signAndExp bitAnd: 16r8000) = 0 - ifTrue: [sign _ 1.0] - ifFalse: [sign _ -1.0]. - exp _ (signAndExp bitAnd: 16r7FFF) - 16r4000 + 2. "not sure why +2 is needed..." - ^ (sign * mantissa asFloat * (2.0 raisedTo: exp - 64)) roundTo: 0.00000001 -! ! -!AIFFFileReader methodsFor: 'private' stamp: 'jmv 2/26/2016 17:00'! - readFrom: aBinaryStream - "Read AIFF data from the given binary stream." - "Details: An AIFF file consists of a header (FORM chunk) followed by a sequence of tagged data chunks. Each chunk starts with a header consisting of a four-byte tag (a string) and a four byte size. These eight bytes of chunk header are not included in the chunk size. For each chunk, the readChunk:size: method consumes chunkSize bytes of the input stream, parsing recognized chunks or skipping unrecognized ones. If chunkSize is odd, it will be followed by a padding byte. Chunks may occur in any order." - - | sz end chunkType chunkSize p | - in _ aBinaryStream. - - "read FORM chunk" - (in next: 4) asString = 'FORM' ifFalse: [^ self error: 'not an AIFF file']. - sz _ in nextUnsignedInt32BigEndian: true. - end _ in position + sz. - fileType _ (in next: 4) asString. - - [in atEnd not and: [in position < end]] whileTrue: [ - chunkType _ (in next: 4) asString. - chunkSize _ in nextUnsignedInt32BigEndian: true. - p _ in position. - self readChunk: chunkType size: chunkSize. - (in position = (p + chunkSize)) - ifFalse: [self error: 'chunk size mismatch; bad AIFF file?']. - chunkSize odd ifTrue: [in skip: 1]]. "skip padding byte" -! ! -!AIFFFileReader methodsFor: 'reading' stamp: 'jm 8/2/1998 16:27'! - readFromFile: fileName - "Read the AIFF file of the given name." - "AIFFFileReader new readFromFile: 'test.aiff'" - - self readFromFile: fileName - mergeIfStereo: false - skipDataChunk: false. -! ! -!AIFFFileReader methodsFor: 'reading' stamp: 'pb 5/25/2016 01:30'! - readFromFile: fileName mergeIfStereo: mergeFlag skipDataChunk: skipDataFlag - "Read the AIFF file of the given name. See comment in readFromStream:mergeIfStereo:skipDataChunk:." - "AIFFFileReader new readFromFile: 'test.aiff' mergeIfStereo: false skipDataChunk: true" - - fileName asFileEntry readStreamDo: [ :strm | - strm binary. - self readFromStream: strm mergeIfStereo: mergeFlag skipDataChunk: skipDataFlag ]! ! -!AIFFFileReader methodsFor: 'reading'! - readFromStream: aBinaryStream mergeIfStereo: mergeFlag skipDataChunk: skipDataFlag - "Read an AIFF file from the given binary stream. If mergeFlag is true and the file contains stereo data, then the left and right channels will be mixed together as the samples are read in. If skipDataFlag is true, then the data chunk to be skipped; this allows the other chunks of a file to be processed in order to extract format information quickly without reading the data." - - mergeIfStereo _ mergeFlag. - skipDataChunk _ skipDataFlag. - isLooped _ false. - gain _ 1.0. - self readFrom: aBinaryStream. -! ! -!AIFFFileReader methodsFor: 'private' stamp: 'jmv 2/26/2016 16:57'! - readInstrumentChunk: chunkSize - - | midiKey detune lowNote highNote lowVelocity highVelocity - sustainMode sustainStartID sustainEndID - releaseMode releaseStartID releaseEndID | - - midiKey _ in next. - detune _ in next. - lowNote _ in next. - highNote _ in next. - lowVelocity _ in next. - highVelocity _ in next. - gain _ in nextUnsignedInt16BigEndian: true. - sustainMode _ in nextUnsignedInt16BigEndian: true. - sustainStartID _ in nextUnsignedInt16BigEndian: true. - sustainEndID _ in nextUnsignedInt16BigEndian: true. - releaseMode _ in nextUnsignedInt16BigEndian: true. - releaseStartID _ in nextUnsignedInt16BigEndian: true. - releaseEndID _ in nextUnsignedInt16BigEndian: true. - isLooped _ sustainMode = 1. - (isLooped and: [markers notNil]) ifTrue: [ - ((markers first last > frameCount) or: - [markers last last > frameCount]) ifTrue: [ - "bad loop data; some sample CD files claim to be looped but aren't" - isLooped _ false]]. - pitch _ self pitchForKey: midiKey. -! ! -!AIFFFileReader methodsFor: 'private' stamp: 'jmv 2/26/2016 17:00'! - readMarkerChunk: chunkSize - - | markerCount id position labelBytes label | - markerCount _ in nextUnsignedInt16BigEndian: true. - markers _ Array new: markerCount. - 1 to: markerCount do: [:i | - id _ in nextUnsignedInt16BigEndian: true. - position _ in nextUnsignedInt32BigEndian: true. - labelBytes _ in next. - label _ (in next: labelBytes) asString. - labelBytes even ifTrue: [in skip: 1]. - markers at: i put: (Array with: id with: label with: position)]. - -! ! -!AIFFFileReader methodsFor: 'private' stamp: 'jm 8/2/1998 18:58'! - readMergedStereoChannelDataFrom: s - "Read stereophonic channel data from the given stream, mixing the two channels to create a single monophonic channel. Each frame contains two samples." - - | buf w1 w2 | - buf _ channelData at: 1. - bitsPerSample = 8 - ifTrue: [ - 1 to: frameCount do: [:i | - w1 _ s next. - w1 > 127 ifTrue: [w1 _ w1 - 256]. - w2 _ s next. - w2 > 127 ifTrue: [w2 _ w2 - 256]. - buf at: i put: ((w1 + w2) bitShift: 7)]] - ifFalse: [ - 1 to: frameCount do: [:i | - w1 _ (s next bitShift: 8) + s next. - w1 > 32767 ifTrue: [w1 _ w1 - 65536]. - w2 _ (s next bitShift: 8) + s next. - w2 > 32767 ifTrue: [w2 _ w2 - 65536]. - buf at: i put: ((w1 + w2) bitShift: -1)]]. -! ! -!AIFFFileReader methodsFor: 'private' stamp: 'jm 8/2/1998 18:53'! - readMonoChannelDataFrom: s - "Read monophonic channel data from the given stream. Each frame contains a single sample." - - | buf w | - buf _ channelData at: 1. "the only buffer" - bitsPerSample = 8 - ifTrue: [ - 1 to: frameCount do: [:i | - w _ s next. - w > 127 ifTrue: [w _ w - 256]. - buf at: i put: (w bitShift: 8)]] - ifFalse: [ - 1 to: frameCount do: [:i | - w _ (s next bitShift: 8) + s next. - w > 32767 ifTrue: [w _ w - 65536]. - buf at: i put: w]]. -! ! -!AIFFFileReader methodsFor: 'private' stamp: 'jm 8/2/1998 18:55'! - readMultiChannelDataFrom: s - "Read multi-channel data from the given stream. Each frame contains channelCount samples." - - | w | - bitsPerSample = 8 - ifTrue: [ - 1 to: frameCount do: [:i | - 1 to: channelCount do: [:ch | - w _ s next. - w > 127 ifTrue: [w _ w - 256]. - (channelData at: ch) at: i put: (w bitShift: 8)]]] - ifFalse: [ - 1 to: frameCount do: [:i | - 1 to: channelCount do: [:ch | - w _ (s next bitShift: 8) + s next. - w > 32767 ifTrue: [w _ w - 65536]. - (channelData at: ch) at: i put: w]]]. -! ! -!AIFFFileReader methodsFor: 'private' stamp: 'jmv 2/26/2016 17:00'! - readSamplesChunk: chunkSize - "Read a SSND chunk. All AIFF files with a non-zero frameCount contain exactly one chunk of this type." - - | offset blockSize bytesOfSamples s | - offset _ in nextUnsignedInt32BigEndian: true. - blockSize _ in nextUnsignedInt32BigEndian: true. - ((offset ~= 0) or: [blockSize ~= 0]) - ifTrue: [^ self error: 'this AIFF reader cannot handle blocked sample chunks']. - bytesOfSamples _ chunkSize - 8. - bytesOfSamples = (channelCount * frameCount * (bitsPerSample // 8)) - ifFalse: [self error: 'actual sample count does not match COMM chunk']. - - channelDataOffset _ in position. "record stream position for start of data" - skipDataChunk ifTrue: [in skip: (chunkSize - 8). ^ self]. "if skipDataChunk, skip sample data" - - (mergeIfStereo and: [channelCount = 2]) - ifTrue: [ - channelData _ Array with: (SoundBuffer newMonoSampleCount: frameCount)] - ifFalse: [ - channelData _ - (1 to: channelCount) collect: [:i | SoundBuffer newMonoSampleCount: frameCount]]. - - (bytesOfSamples < (Smalltalk garbageCollectMost - 300000)) - ifTrue: [s _ ReadStream on: (in next: bytesOfSamples)] "bulk-read, then process" - ifFalse: [s _ in]. "not enough space to buffer; read directly from file" - - "mono and stereo are special-cased for better performance" - channelCount = 1 ifTrue: [^ self readMonoChannelDataFrom: s]. - channelCount = 2 ifTrue: [ - mergeIfStereo - ifTrue: [channelCount _ 1. ^ self readMergedStereoChannelDataFrom: s] - ifFalse: [^ self readStereoChannelDataFrom: s]]. - self readMultiChannelDataFrom: s. -! ! -!AIFFFileReader methodsFor: 'private' stamp: 'jm 8/2/1998 18:56'! - readStereoChannelDataFrom: s - "Read stereophonic channel data from the given stream. Each frame contains two samples." - - | left right w | - left _ channelData at: 1. - right _ channelData at: 2. - bitsPerSample = 8 - ifTrue: [ - 1 to: frameCount do: [:i | - w _ s next. - w > 127 ifTrue: [w _ w - 256]. - left at: i put: (w bitShift: 8). - w _ s next. - w > 127 ifTrue: [w _ w - 256]. - right at: i put: (w bitShift: 8)]] - ifFalse: [ - 1 to: frameCount do: [:i | - w _ (s next bitShift: 8) + s next. - w > 32767 ifTrue: [w _ w - 65536]. - left at: i put: w. - w _ (s next bitShift: 8) + s next. - w > 32767 ifTrue: [w _ w - 65536]. - right at: i put: w]]. -! ! -!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 8/2/1998 19:34'! - rightSamples - - ^ channelData at: 2 -! ! -!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 7/12/1998 18:25'! - samplingRate - - ^ samplingRate -! ! -!AIFFFileReader methodsFor: 'other' stamp: 'jm 1/14/1999 10:11'! - sound - "Answer the sound represented by this AIFFFileReader. This method should be called only after readFrom: has been done." - - | snd rightSnd | - snd _ SampledSound - samples: (channelData at: 1) - samplingRate: samplingRate. - self isStereo ifTrue: [ - rightSnd _ SampledSound - samples: (channelData at: 2) - samplingRate: samplingRate. - snd _ MixedSound new - add: snd pan: 0; - add: rightSnd pan: 1.0]. - ^ snd -! ! -!AbstractSound methodsFor: 'composition'! - + aSound - "Return the mix of the receiver and the argument sound." - - ^ MixedSound new - add: self; - add: aSound -! ! -!AbstractSound methodsFor: 'composition'! - , aSound - "Return the concatenation of the receiver and the argument sound." - - ^ SequentialSound new - add: self; - add: aSound -! ! -!AbstractSound methodsFor: 'envelopes' stamp: 'jm 12/17/97 22:23'! - addEnvelope: anEnvelope - "Add the given envelope to my envelopes list." - - anEnvelope target: self. - envelopes _ envelopes copyWith: anEnvelope. -! ! -!AbstractSound methodsFor: 'volume' stamp: 'RAA 8/11/2000 11:51'! - adjustVolumeTo: vol overMSecs: mSecs - "Adjust the volume of this sound to the given volume, a number in the range [0.0..1.0], over the given number of milliseconds. The volume will be changed a little bit on each sample until the desired volume is reached." - - | newScaledVol | - - self flag: #bob. "I removed the upper limit to allow making sounds louder. hmm..." - - newScaledVol _ (32768.0 * vol) truncated. - newScaledVol = scaledVol ifTrue: [^ self]. - scaledVolLimit _ newScaledVol. - "scaledVolLimit > ScaleFactor ifTrue: [scaledVolLimit _ ScaleFactor]." - scaledVolLimit < 0 ifTrue: [scaledVolLimit _ 0]. - mSecs = 0 - ifTrue: [ "change immediately" - scaledVol _ scaledVolLimit. - scaledVolIncr _ 0] - ifFalse: [ - scaledVolIncr _ - ((scaledVolLimit - scaledVol) * 1000) // (self samplingRate * mSecs)]. -! ! -!AbstractSound methodsFor: 'conversion' stamp: 'jm 12/16/2001 13:26'! - asSampledSound - "Answer a SampledSound containing my samples. If the receiver is some kind of sampled sound, the resulting SampledSound will have the same original sampling rate as the receiver." - - ^ SampledSound samples: self samples samplingRate: self originalSamplingRate -! ! -!AbstractSound methodsFor: 'composition' stamp: 'jm 2/2/1999 15:53'! - asSound - - ^ self -! ! -!AbstractSound methodsFor: 'playing' stamp: 'jm 1/26/98 22:05'! - computeSamplesForSeconds: seconds - "Compute the samples of this sound without outputting them, and return the resulting buffer of samples." - - | buf | - self reset. - buf _ SoundBuffer newStereoSampleCount: (self samplingRate * seconds) asInteger. - self playSampleCount: buf stereoSampleCount into: buf startingAt: 1. - ^ buf -! ! -!AbstractSound methodsFor: 'sampling rates' stamp: 'jm 12/15/97 14:15'! - controlRate - "Answer the number of control changes per second." - - ^ 100 -! ! -!AbstractSound methodsFor: 'copying' stamp: 'jm 12/17/97 22:22'! - copyEnvelopes - "Private!! Support for copying. Copy my envelopes." - - envelopes _ envelopes collect: [:e | e copy target: self]. -! ! -!AbstractSound methodsFor: 'composition' stamp: 'jm 12/17/97 18:00'! - delayedBy: seconds - "Return a composite sound consisting of a rest for the given amount of time followed by the receiver." - - ^ (RestSound dur: seconds), self -! ! -!AbstractSound methodsFor: 'sound generation' stamp: 'jm 8/17/1998 13:34'! - doControl - "Update the control parameters of this sound using its envelopes, if any." - "Note: This is only called at a small fraction of the sampling rate." - - | pitchModOrRatioChange | - envelopes size > 0 ifTrue: [ - pitchModOrRatioChange _ false. - 1 to: envelopes size do: [:i | - ((envelopes at: i) updateTargetAt: mSecsSinceStart) - ifTrue: [pitchModOrRatioChange _ true]]. - pitchModOrRatioChange ifTrue: [self internalizeModulationAndRatio]]. - mSecsSinceStart _ mSecsSinceStart + (1000 // self controlRate). -! ! -!AbstractSound methodsFor: 'initialization' stamp: 'jm 12/9/97 11:31'! - duration: seconds - "Scale my envelopes to the given duration. Subclasses overriding this method should include a resend to super." - - envelopes do: [:e | e duration: seconds]. -! ! -!AbstractSound methodsFor: 'envelopes' stamp: 'jm 12/15/97 17:02'! - envelopes - "Return my collection of envelopes." - - ^ envelopes -! ! -!AbstractSound methodsFor: 'volume' stamp: 'jm 12/17/97 17:39'! - initialVolume: vol - "Set the initial volume of this sound to the given volume, a number in the range [0.0..1.0]." - - scaledVol _ (((vol asFloat min: 1.0) max: 0.0) * ScaleFactor) rounded. - scaledVolLimit _ scaledVol. - scaledVolIncr _ 0. -! ! -!AbstractSound methodsFor: 'initialization' stamp: 'jm 2/4/98 09:54'! - initialize - - envelopes _ #(). - mSecsSinceStart _ 0. - samplesUntilNextControl _ 0. - scaledVol _ (1.0 * ScaleFactor) rounded. - scaledVolIncr _ 0. - scaledVolLimit _ scaledVol. -! ! -!AbstractSound methodsFor: 'sound generation' stamp: 'jm 2/4/98 08:56'! - internalizeModulationAndRatio - "Overridden by FMSound. This default implementation does nothing." -! ! -!AbstractSound methodsFor: 'playing' stamp: 'ar 12/5/1998 22:20'! - isPlaying - "Return true if the receiver is currently playing" - ^ SoundPlayer isPlaying: self! ! -!AbstractSound methodsFor: 'accessing' stamp: 'jm 12/16/2001 22:34'! - isStereo - "Answer true if this sound has distinct left and right channels. (Every sound plays into a stereo sample buffer, but most sounds, which produce exactly the same samples on both channels, are not stereo.)" - - ^ false -! ! -!AbstractSound methodsFor: 'volume' stamp: 'jm 8/13/1998 16:37'! - loudness - "Answer the current volume setting for this sound." - - ^ scaledVol asFloat / ScaleFactor asFloat! ! -!AbstractSound methodsFor: 'initialization' stamp: 'jm 3/24/1999 12:03'! - loudness: aNumber - "Initialize my volume envelopes and initial volume. Subclasses overriding this method should include a resend to super." - - | vol | - vol _ (aNumber asFloat max: 0.0) min: 1.0. - envelopes do: [:e | - (e isKindOf: VolumeEnvelope) ifTrue: [e scale: vol]]. - self initialVolume: vol. -! ! -!AbstractSound methodsFor: 'playing' stamp: 'di 5/30/1999 12:46'! - millisecondsSinceStart - - ^ mSecsSinceStart! ! -!AbstractSound methodsFor: 'sound generation' stamp: 'jm 7/6/1998 06:40'! - mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol - "Mix the given number of samples with the samples already in the given buffer starting at the given index. Assume that the buffer size is at least (index + count) - 1. The leftVol and rightVol parameters determine the volume of the sound in each channel, where 0 is silence and ScaleFactor is full volume." - - self subclassResponsibility. -! ! -!AbstractSound methodsFor: 'initialization' stamp: 'jm 7/6/1998 17:04'! - nameOrNumberToPitch: aStringOrNumber - "Answer the pitch in cycles/second for the given pitch specification. The specification can be either a numeric pitch or pitch name such as 'c4'." - - aStringOrNumber isNumber - ifTrue: [^ aStringOrNumber asFloat] - ifFalse: [^ AbstractSound pitchForName: aStringOrNumber] -! ! -!AbstractSound methodsFor: 'sampling rates' stamp: 'jm 12/16/2001 13:14'! - originalSamplingRate - "For sampled sounds, answer the sampling rate used to record the stored samples. For other sounds, this is the same as the playback sampling rate." - - ^ SoundPlayer samplingRate -! ! -!AbstractSound methodsFor: 'playing' stamp: 'jm 8/24/97 20:48'! - pause - "Pause this sound. It can be resumed from this point, or reset and resumed to start from the beginning." - - SoundPlayer pauseSound: self.! ! -!AbstractSound methodsFor: 'playing' stamp: 'gk 2/24/2004 22:23'! - play - "Play this sound to the sound output port in real time." - - SoundPlayer playSound: self.! ! -!AbstractSound methodsFor: 'playing' stamp: 'jm 8/13/1998 15:09'! - playAndWaitUntilDone - "Play this sound to the sound ouput port and wait until it has finished playing before returning." - - SoundPlayer playSound: self. - [self samplesRemaining > 0] whileTrue. - (Delay forMilliseconds: 2 * SoundPlayer bufferMSecs) wait. "ensure last buffer has been output" -! ! -!AbstractSound methodsFor: 'playing' stamp: 'jm 8/18/1998 10:52'! - playChromaticRunFrom: startPitch to: endPitch - "Play a fast chromatic run between the given pitches. Useful for auditioning a sound." - - (AbstractSound chromaticRunFrom: startPitch to: endPitch on: self) play. -! ! -!AbstractSound methodsFor: 'playing' stamp: 'jm 8/13/1998 16:17'! - playSampleCount: n into: aSoundBuffer startingAt: startIndex - "Mix the next n samples of this sound into the given buffer starting at the given index. Update the receiver's control parameters periodically." - - | fullVol samplesBetweenControlUpdates pastEnd i remainingSamples count | - fullVol _ AbstractSound scaleFactor. - samplesBetweenControlUpdates _ self samplingRate // self controlRate. - pastEnd _ startIndex + n. "index just after the last sample" - i _ startIndex. - [i < pastEnd] whileTrue: [ - remainingSamples _ self samplesRemaining. - remainingSamples <= 0 ifTrue: [^ self]. - count _ pastEnd - i. - samplesUntilNextControl < count ifTrue: [count _ samplesUntilNextControl]. - remainingSamples < count ifTrue: [count _ remainingSamples]. - self mixSampleCount: count into: aSoundBuffer startingAt: i leftVol: fullVol rightVol: fullVol. - samplesUntilNextControl _ samplesUntilNextControl - count. - samplesUntilNextControl <= 0 ifTrue: [ - self doControl. - samplesUntilNextControl _ samplesBetweenControlUpdates]. - i _ i + count]. -! ! -!AbstractSound methodsFor: 'playing' stamp: 'jm 7/5/1998 17:53'! - playSilently - "Compute the samples of this sound without outputting them. Used for performance analysis." - - | bufSize buf | - self reset. - bufSize _ self samplingRate // 10. - buf _ SoundBuffer newStereoSampleCount: bufSize. - [self samplesRemaining > 0] whileTrue: [ - buf primFill: 0. - self playSampleCount: bufSize into: buf startingAt: 1]. -! ! -!AbstractSound methodsFor: 'playing' stamp: 'jm 1/26/98 22:06'! - playSilentlyUntil: startTime - "Compute the samples of this sound without outputting them. Used to fast foward to a particular starting time. The start time is given in seconds." - - | buf startSample nextSample samplesRemaining n | - self reset. - buf _ SoundBuffer newStereoSampleCount: (self samplingRate // 10). - startSample _ (startTime * self samplingRate) asInteger. - nextSample _ 1. - [self samplesRemaining > 0] whileTrue: [ - nextSample >= startSample ifTrue: [^ self]. - samplesRemaining _ startSample - nextSample. - samplesRemaining > buf stereoSampleCount - ifTrue: [n _ buf stereoSampleCount] - ifFalse: [n _ samplesRemaining]. - self playSampleCount: n into: buf startingAt: 1. - nextSample _ nextSample + n]. -! ! -!AbstractSound methodsFor: 'copying' stamp: 'jmv 5/14/2015 09:55'! - postCopy - "A sound should copy all of the state needed to play itself, allowing two copies of a sound to play at the same time. These semantics require a recursive copy but only down to the level of immutable data. For example, a SampledSound need not copy its sample buffer. Subclasses overriding this method should include a resend to super." - - self copyEnvelopes! ! -!AbstractSound methodsFor: 'envelopes' stamp: 'jm 8/18/1998 09:57'! - removeAllEnvelopes - "Remove all envelopes from my envelopes list." - - envelopes _ #(). -! ! -!AbstractSound methodsFor: 'envelopes' stamp: 'jm 12/15/97 17:02'! - removeEnvelope: anEnvelope - "Remove the given envelope from my envelopes list." - - envelopes _ envelopes copyWithout: anEnvelope. -! ! -!AbstractSound methodsFor: 'sound generation' stamp: 'jm 8/17/1998 13:45'! - reset - "Reset my internal state for a replay. Methods that override this method should do super reset." - - mSecsSinceStart _ 0. - samplesUntilNextControl _ 0. - envelopes size > 0 ifTrue: [ - 1 to: envelopes size do: [:i | (envelopes at: i) reset]]. -! ! -!AbstractSound methodsFor: 'playing' stamp: 'jm 3/4/98 13:16'! - resumePlaying - "Resume playing this sound from where it last stopped." - - SoundPlayer resumePlaying: self. -! ! -!AbstractSound methodsFor: 'playing' stamp: 'jm 12/16/2001 13:22'! - samples - "Answer a monophonic sample buffer containing my samples. The left and write channels are merged." - "Warning: This may require a lot of memory!!" - - ^ (self computeSamplesForSeconds: self duration) mergeStereo -! ! -!AbstractSound methodsFor: 'sound generation' stamp: 'jm 12/17/97 17:57'! - samplesRemaining - "Answer the number of samples remaining until the end of this sound. A sound with an indefinite ending time should answer some large integer such as 1000000." - - ^ 1000000 -! ! -!AbstractSound methodsFor: 'sampling rates' stamp: 'jm 12/17/97 18:00'! - samplingRate - "Answer the sampling rate in samples per second." - - ^ SoundPlayer samplingRate -! ! -!AbstractSound methodsFor: 'initialization' stamp: 'jm 8/19/1998 08:45'! - setPitch: pitchNameOrNumber dur: d loudness: l - "Initialize my envelopes for the given parameters. Subclasses overriding this method should include a resend to super." - - | p | - p _ self nameOrNumberToPitch: pitchNameOrNumber. - envelopes do: [:e | - e volume: l. - e centerPitch: p]. - self initialVolume: l. - self duration: d. -! ! -!AbstractSound methodsFor: 'initialization' stamp: 'jm 8/3/1998 17:11'! - soundForMidiKey: midiKey dur: d loudness: l - "Answer an initialized sound object (a copy of the receiver) that generates a note for the given MIDI key (in the range 0..127), duration (in seconds), and loudness (in the range 0.0 to 1.0)." - - ^ self copy - setPitch: (AbstractSound pitchForMIDIKey: midiKey) - dur: d - loudness: l -! ! -!AbstractSound methodsFor: 'initialization' stamp: 'jm 8/3/1998 16:58'! - soundForPitch: pitchNameOrNumber dur: d loudness: l - "Answer an initialized sound object (a copy of the receiver) that generates a note of the given pitch, duration, and loudness. Pitch may be a numeric pitch or a string pitch name such as 'c4'. Duration is in seconds and loudness is in the range 0.0 to 1.0." - - ^ self copy setPitch: pitchNameOrNumber dur: d loudness: l -! ! -!AbstractSound methodsFor: 'copying' stamp: 'di 3/4/1999 21:29'! - sounds - "Allows simple sounds to behave as, eg, sequential sounds" - - ^ Array with: self! ! -!AbstractSound methodsFor: 'sound generation' stamp: 'jm 9/9/1998 21:56'! - stopAfterMSecs: mSecs - "Terminate this sound this note after the given number of milliseconds. This default implementation does nothing." -! ! -!AbstractSound methodsFor: 'sound generation' stamp: 'jm 9/9/1998 21:54'! - stopGracefully - "End this note with a graceful decay. If the note has envelopes, determine the decay time from its envelopes." - - | decayInMs env | - envelopes isEmpty - ifTrue: [ - self adjustVolumeTo: 0 overMSecs: 10. - decayInMs _ 10] - ifFalse: [ - env _ envelopes first. - decayInMs _ env attackTime + env decayTime]. - self duration: (mSecsSinceStart + decayInMs) / 1000.0. - self stopAfterMSecs: decayInMs. -! ! -!AbstractSound methodsFor: 'file i/o' stamp: 'pb 5/25/2016 01:35'! - storeAIFFOnFileNamed: fileName - "Store this sound as a AIFF file of the given name." - - fileName asFileEntry writeStreamDo: [ :strm | - strm binary. - self storeAIFFSamplesOn: strm ]! ! -!AbstractSound methodsFor: 'file i/o' stamp: 'jmv 2/26/2016 17:03'! - storeAIFFSamplesOn: aBinaryStream - "Store this sound as a 16-bit AIFF file at the current SoundPlayer sampling rate. Store both channels if self isStereo is true; otherwise, store the left channel only as a mono sound." - - | samplesToStore channelCount dataByteCount | - samplesToStore _ (self duration * self samplingRate) ceiling. - channelCount _ self isStereo ifTrue: [2] ifFalse: [1]. - dataByteCount _ samplesToStore * channelCount * 2. - - "write AIFF file header:" - aBinaryStream nextPutAll: 'FORM' asByteArray. - aBinaryStream nextSignedInt32Put: ((7 * 4) + 18) + dataByteCount bigEndian: true. - aBinaryStream nextPutAll: 'AIFF' asByteArray. - aBinaryStream nextPutAll: 'COMM' asByteArray. - aBinaryStream nextSignedInt32Put: 18 bigEndian: true. - aBinaryStream nextUnsignedInt16Put: channelCount bigEndian: true. - aBinaryStream nextSignedInt32Put: samplesToStore bigEndian: true. - aBinaryStream nextUnsignedInt16Put: 16 bigEndian: true. "bits/sample" - self storeExtendedFloat: self samplingRate on: aBinaryStream. - aBinaryStream nextPutAll: 'SSND' asByteArray. - aBinaryStream nextSignedInt32Put: dataByteCount + 8 bigEndian: true. - aBinaryStream nextSignedInt32Put: 0 bigEndian: true. - aBinaryStream nextSignedInt32Put: 0 bigEndian: true. - - "write data:" - self storeSampleCount: samplesToStore bigEndian: true on: aBinaryStream. -! ! -!AbstractSound methodsFor: 'file i/o' stamp: 'jmv 2/29/2016 11:03'! - storeExtendedFloat: aNumber on: aBinaryStream - "Store an Apple extended-precision 80-bit floating point number on the given stream." - "Details: I could not find the specification for this format, so constants were determined empirically based on assumption of 1-bit sign, 15-bit exponent, 64-bit mantissa. This format does not seem to have an implicit one before the mantissa as some float formats do." - - | n isNeg exp mantissa | - n _ aNumber asFloat. - isNeg _ false. - n < 0.0 ifTrue: [ - n _ 0.0 - n. - isNeg _ true]. - exp _ (n log: 2.0) ceiling. - mantissa _ (n * (2 raisedTo: 64 - exp)) truncated. - exp _ exp + 16r4000 - 2. "not sure why the -2 is needed..." - isNeg ifTrue: [exp _ exp bitOr: 16r8000]. "set sign bit" - aBinaryStream nextPut: ((exp bitShift: -8) bitAnd: 16rFF). - aBinaryStream nextPut: (exp bitAnd: 16rFF). - aBinaryStream nextNumber: 8 put: mantissa! ! -!AbstractSound methodsFor: 'sound generation' stamp: 'jm 1/5/98 14:21'! - storeSample: sample in: aSoundBuffer at: sliceIndex leftVol: leftVol rightVol: rightVol - "This method is provided for documentation. To gain 10% more speed when running sound generation in Smalltalk, this method is hand-inlined into all sound generation methods that use it." - - | i s | - leftVol > 0 ifTrue: [ - i _ (2 * sliceIndex) - 1. - s _ (aSoundBuffer at: i) + ((sample * leftVol) // ScaleFactor). - s > 32767 ifTrue: [s _ 32767]. "clipping!!" - s < -32767 ifTrue: [s _ -32767]. "clipping!!" - aSoundBuffer at: i put: s]. - rightVol > 0 ifTrue: [ - i _ 2 * sliceIndex. - s _ (aSoundBuffer at: i) + ((sample * rightVol) // ScaleFactor). - s > 32767 ifTrue: [s _ 32767]. "clipping!!" - s < -32767 ifTrue: [s _ -32767]. "clipping!!" - aSoundBuffer at: i put: s]. -! ! -!AbstractSound methodsFor: 'file i/o' stamp: 'jmv 7/17/2017 15:39:47'! - storeSampleCount: samplesToStore bigEndian: bigEndianFlag on: aBinaryStream - "Store my samples on the given stream at the current SoundPlayer sampling rate. If bigFlag is true, then each 16-bit sample is stored most-significant byte first (AIFF files), otherwise it is stored least-significant byte first (WAV files). If self isStereo is true, both channels are stored, creating a stereo file. Otherwise, only the left channel is stored, creating a mono file." - - | bufSize stereoBuffer | - self reset. - bufSize _ (2 * self samplingRate rounded) min: samplesToStore. "two second buffer" - stereoBuffer _ SoundBuffer newStereoSampleCount: bufSize. - - 'Storing audio...' displayProgressAt: Sensor mousePoint - from: 0 to: samplesToStore during: [:barBlock | | remaining out | - remaining _ samplesToStore. - [remaining > 0] whileTrue: [ - barBlock value: samplesToStore - remaining. - stereoBuffer primFill: 0. "clear the buffer" - self playSampleCount: (bufSize min: remaining) into: stereoBuffer startingAt: 1. - self isStereo - ifTrue: [out _ stereoBuffer] - ifFalse: [out _ stereoBuffer extractLeftChannel]. - (aBinaryStream isKindOf: StandardFileStream) - ifTrue: [ "optimization for files: write sound buffer directly to file" - aBinaryStream next: (out size // 2) putAll: out startingAt: 1] "size in words" - ifFalse: [ "for non-file streams:" - 1 to: out monoSampleCount do: [:i | aBinaryStream nextSignedInt16Put: (out at: i) bigEndian: bigEndianFlag ]]. - remaining _ remaining - bufSize]]! ! -!AbstractSound methodsFor: 'file i/o' stamp: 'pb 5/25/2016 01:35'! - storeWAVOnFileNamed: fileName - "Store this sound as a 16-bit Windows WAV file of the given name." - - fileName asFileEntry writeStreamDo: [ :strm | - strm binary. - self storeWAVSamplesOn: strm ]! ! -!AbstractSound methodsFor: 'file i/o' stamp: 'jmv 2/26/2016 16:33'! - storeWAVSamplesOn: aBinaryStream - "Store this sound as a 16-bit Windows WAV file at the current SoundPlayer sampling rate. Store both channels if self isStereo is true; otherwise, store the left channel only as a mono sound." - - | samplesToStore channelCount dataByteCount samplesPerSec bytesPerSec | - samplesToStore _ (self duration * self samplingRate) ceiling. - channelCount _ self isStereo ifTrue: [2] ifFalse: [1]. - dataByteCount _ samplesToStore * channelCount * 2. - samplesPerSec _ self samplingRate rounded. - bytesPerSec _ samplesPerSec * channelCount * 2. - - "file header" - aBinaryStream - nextPutAll: 'RIFF' asByteArray; - nextUnsignedInt32Put: dataByteCount + 36 bigEndian: false; "total length of all chunks" - nextPutAll: 'WAVE' asByteArray. - - "format chunk" - aBinaryStream - nextPutAll: 'fmt ' asByteArray; - nextUnsignedInt32Put: 16 bigEndian: false; "length of this chunk" - nextUnsignedInt16Put: 1 bigEndian: false; "format tag" - nextUnsignedInt16Put: channelCount bigEndian: false; - nextUnsignedInt32Put: samplesPerSec bigEndian: false; - nextUnsignedInt32Put: bytesPerSec bigEndian: false; - nextUnsignedInt16Put: 4 bigEndian: false; "alignment" - nextUnsignedInt16Put: 16 bigEndian: false. "bits per sample" - - "data chunk" - aBinaryStream - nextPutAll: 'data' asByteArray; - nextUnsignedInt32Put: dataByteCount bigEndian: false. "length of this chunk" - - self storeSampleCount: samplesToStore bigEndian: false on: aBinaryStream. -! ! -!AbstractSound methodsFor: 'sound generation' stamp: 'jm 12/17/97 17:57'! - updateVolume - "Increment the volume envelope of this sound. To avoid clicks, the volume envelope must be interpolated at the sampling rate, rather than just at the control rate like other envelopes. At the control rate, the volume envelope computes the slope and next target volume volume for the current segment of the envelope (i.e., it sets the rate of change for the volume parameter). When that target volume is reached, incrementing is stopped until a new increment is set." - "This method is provided for documentation. To gain 10% more speed when running sound generation in Smalltalk, it is hand-inlined into all sound generation methods that use it." - - scaledVolIncr ~= 0 ifTrue: [ - scaledVol _ scaledVol + scaledVolIncr. - ((scaledVolIncr > 0 and: [scaledVol >= scaledVolLimit]) or: - [scaledVolIncr < 0 and: [scaledVol <= scaledVolLimit]]) - ifTrue: [ "reached the limit; stop incrementing" - scaledVol _ scaledVolLimit. - scaledVolIncr _ 0]]. -! ! -!AbstractSound methodsFor: 'playing' stamp: 'jmv 4/1/2009 21:36'! - viewSamples - "Open a WaveEditor on my samples." - -" WaveEditor openOn: self samples"! ! -!AbstractSound methodsFor: 'volume' stamp: 'jm 8/13/1998 16:28'! - volumeEnvelopeScaledTo: scalePoint - "Return a collection of values representing my volume envelope scaled by the given point. The scale point's x component is pixels/second and its y component is the number of pixels for full volume." - - self error: 'not yet implemented'. -! ! -!AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 1/5/98 17:38'! - bachFugue - "Play a fugue by J. S. Bach using and instance of me as the sound for all four voices." - "PluckedSound bachFugue play" - - ^ self bachFugueOn: self default -! ! -!AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 1/5/98 18:27'! - bachFugueOn: aSound - "Play a fugue by J. S. Bach using the given sound as the sound for all four voices." - "PluckedSound bachFugue play" - - ^ MixedSound new - add: (self bachFugueVoice1On: aSound) pan: 1.0; - add: (self bachFugueVoice2On: aSound) pan: 0.0; - add: (self bachFugueVoice3On: aSound) pan: 1.0; - add: (self bachFugueVoice4On: aSound) pan: 0.0. -! ! -!AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 12/17/97 16:51'! - bachFugueVoice1On: aSound - "Voice one of a fugue by J. S. Bach." - - ^ self noteSequenceOn: aSound from: #( - (1047 0.15 268) - (988 0.15 268) - (1047 0.30 268) - (784 0.30 268) - (831 0.30 268) - (1047 0.15 268) - (988 0.15 268) - (1047 0.30 268) - (1175 0.30 268) - (784 0.30 268) - (1047 0.15 268) - (988 0.15 268) - (1047 0.30 268) - (1175 0.30 268) - (698 0.15 268) - (784 0.15 268) - (831 0.60 268) - (784 0.15 268) - (698 0.15 268) - (622 0.15 268) - (1047 0.15 268) - (988 0.15 268) - (880 0.15 268) - (784 0.15 268) - (698 0.15 268) - (622 0.15 268) - (587 0.15 268) - (523 0.30 268) - (1245 0.30 268) - (1175 0.30 268) - (1047 0.30 268) - (932 0.30 268) - (880 0.30 268) - (932 0.30 268) - (1047 0.30 268) - (740 0.30 268) - (784 0.30 268) - (880 0.30 268) - (740 0.30 268) - (784 0.60 268) - (rest 0.15) - (523 0.15 268) - (587 0.15 268) - (622 0.15 268) - (698 0.15 268) - (784 0.15 268) - (831 0.45 268) - (587 0.15 268) - (622 0.15 268) - (698 0.15 268) - (784 0.15 268) - (880 0.15 268) - (932 0.45 268) - (622 0.15 268) - (698 0.15 268) - (784 0.15 268) - (831 0.15 268) - (784 0.15 268) - (698 0.15 268) - (622 0.15 268) - (587 0.30 268) - (1047 0.15 268) - (988 0.15 268) - (1047 0.60 268) - (rest 0.9) - (1397 0.30 268) - (1245 0.30 268) - (1175 0.30 268) - (rest 0.3) - (831 0.30 268) - (784 0.30 268) - (698 0.30 268) - (784 0.30 268) - (698 0.15 268) - (622 0.15 268) - (698 0.30 268) - (587 0.30 268) - (784 0.60 268) - (rest 0.3) - (988 0.30 268) - (1047 0.30 268) - (1047 0.15 268) - (988 0.15 268) - (1047 0.30 268) - (784 0.30 268) - (831 0.60 268) - (rest 0.3) - (880 0.30 268) - (932 0.30 268) - (932 0.15 268) - (880 0.15 268) - (932 0.30 268) - (698 0.30 268) - (784 0.60 268) - (rest 0.3) - (784 0.30 268) - (831 0.30 268) - (831 0.30 268) - (784 0.30 268) - (698 0.30 268) - (rest 0.3) - (415 0.30 268) - (466 0.30 268) - (523 0.30 268) - (rest 0.3) - (415 0.15 268) - (392 0.15 268) - (415 0.30 268) - (349 0.30 268) - (466 0.30 268) - (523 0.30 268) - (466 0.30 268) - (415 0.30 268) - (466 0.30 268) - (392 0.30 268) - (349 0.30 268) - (311 0.30 268) - (349 0.30 268) - (554 0.30 268) - (523 0.30 268) - (466 0.30 268) - (523 0.30 268) - (415 0.30 268) - (392 0.30 268) - (349 0.30 268) - (392 0.30 268) - (784 0.15 268) - (740 0.15 268) - (784 0.30 268) - (523 0.30 268) - (622 0.30 268) - (784 0.15 268) - (740 0.15 268) - (784 0.30 268) - (880 0.30 268) - (587 0.30 268) - (784 0.15 268) - (740 0.15 268) - (784 0.30 268) - (880 0.30 268) - (523 0.15 268) - (587 0.15 268) - (622 0.60 268) - (587 0.15 268) - (523 0.15 268) - (466 0.30 346) - (rest 0.45) - (587 0.15 346) - (659 0.15 346) - (740 0.15 346) - (784 0.15 346) - (880 0.15 346) - (932 0.45 346) - (659 0.15 346) - (698 0.15 346) - (784 0.15 346) - (880 0.15 346) - (932 0.15 346) - (1047 0.45 346) - (740 0.15 346) - (784 0.15 346) - (880 0.15 346) - (932 0.30 346) - (622 0.15 346) - (587 0.15 346) - (622 0.30 346) - (392 0.30 346) - (415 0.30 346) - (698 0.15 346) - (622 0.15 346) - (698 0.30 346) - (440 0.30 346) - (466 0.30 346) - (784 0.15 346) - (698 0.15 346) - (784 0.30 346) - (494 0.30 346) - (523 0.15 346) - (698 0.15 346) - (622 0.15 346) - (587 0.15 346) - (523 0.15 346) - (466 0.15 346) - (440 0.15 346) - (392 0.15 346) - (349 0.30 346) - (831 0.30 346) - (784 0.30 346) - (698 0.30 346) - (622 0.30 346) - (587 0.30 346) - (622 0.30 346) - (698 0.30 346) - (494 0.30 346) - (523 0.30 346) - (587 0.30 346) - (494 0.30 346) - (523 0.60 346) - (rest 0.3) - (659 0.30 346) - (698 0.30 346) - (698 0.15 346) - (659 0.15 346) - (698 0.30 346) - (523 0.30 346) - (587 0.60 346) - (rest 0.3) - (587 0.30 346) - (622 0.30 346) - (622 0.15 346) - (587 0.15 346) - (622 0.30 346) - (466 0.30 346) - (523 1.20 346) - (523 0.30 346) - (587 0.15 346) - (622 0.15 346) - (698 0.15 346) - (622 0.15 346) - (698 0.15 346) - (587 0.15 346) - (494 0.30 457) - (rest 0.6) - (494 0.30 457) - (523 0.30 457) - (rest 0.6) - (622 0.30 457) - (587 0.30 457) - (rest 0.6) - (698 0.60 457) - (rest 0.6) - (698 0.30 457) - (622 0.30 457) - (831 0.30 457) - (784 0.30 457) - (698 0.30 457) - (622 0.30 457) - (587 0.30 457) - (622 0.30 457) - (698 0.30 457) - (494 0.30 457) - (523 0.30 457) - (587 0.30 457) - (494 0.30 457) - (494 0.30 457) - (523 0.30 457) - (rest 0.3) - (523 0.30 457) - (698 0.15 457) - (587 0.15 457) - (622 0.15 457) - (523 0.45 457) - (494 0.30 457) - (523 0.60 457) - (rest 0.3) - (659 0.30 268) - (698 0.60 268) - (rest 0.3) - (698 0.30 268) - (698 0.30 268) - (622 0.15 268) - (587 0.15 268) - (622 0.30 268) - (698 0.30 268) - (587 0.40 268) - (rest 0.4) - (587 0.40 268) - (rest 0.4) - (523 1.60 268)).! ! -!AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 12/17/97 16:52'! - bachFugueVoice2On: aSound - "Voice two of a fugue by J. S. Bach." - - ^ self noteSequenceOn: aSound from: #( - (rest 4.8) - (1568 0.15 346) - (1480 0.15 346) - (1568 0.30 346) - (1047 0.30 346) - (1245 0.30 346) - (1568 0.15 346) - (1480 0.15 346) - (1568 0.30 346) - (1760 0.30 346) - (1175 0.30 346) - (1568 0.15 346) - (1480 0.15 346) - (1568 0.30 346) - (1760 0.30 346) - (1047 0.15 346) - (1175 0.15 346) - (1245 0.60 346) - (1175 0.15 346) - (1047 0.15 346) - (932 0.30 346) - (1245 0.15 346) - (1175 0.15 346) - (1245 0.30 346) - (784 0.30 346) - (831 0.30 346) - (1397 0.15 346) - (1245 0.15 346) - (1397 0.30 346) - (880 0.30 346) - (932 0.30 346) - (1568 0.15 346) - (1397 0.15 346) - (1568 0.30 346) - (988 0.30 346) - (1047 0.30 346) - (1175 0.15 346) - (1245 0.15 346) - (1397 0.90 346) - (1245 0.15 346) - (1175 0.15 346) - (1047 0.15 346) - (932 0.15 346) - (831 0.15 346) - (784 0.15 346) - (698 0.30 346) - (1661 0.30 346) - (1568 0.30 346) - (1397 0.30 346) - (1245 0.30 346) - (1175 0.30 346) - (1245 0.30 346) - (1397 0.30 346) - (988 0.30 346) - (1047 0.30 346) - (1175 0.30 346) - (988 0.30 346) - (1047 0.30 457) - (1568 0.15 457) - (1480 0.15 457) - (1568 0.30 457) - (1175 0.30 457) - (1245 0.60 457) - (rest 0.3) - (1319 0.30 457) - (1397 0.30 457) - (1397 0.15 457) - (1319 0.15 457) - (1397 0.30 457) - (1047 0.30 457) - (1175 0.60 457) - (rest 0.3) - (1175 0.30 457) - (1245 0.30 457) - (1245 0.15 457) - (1175 0.15 457) - (1245 0.30 457) - (932 0.30 457) - (1047 0.30 457) - (1245 0.15 457) - (1175 0.15 457) - (1245 0.30 457) - (1397 0.30 457) - (932 0.30 457) - (1245 0.15 457) - (1175 0.15 457) - (1245 0.30 457) - (1397 0.30 457) - (831 0.15 457) - (932 0.15 457) - (1047 0.60 457) - (932 0.15 457) - (831 0.15 457) - (784 0.15 457) - (622 0.15 457) - (698 0.15 457) - (784 0.15 457) - (831 0.15 457) - (932 0.15 457) - (1047 0.15 457) - (1175 0.15 457) - (1245 0.15 457) - (1175 0.15 457) - (1047 0.15 457) - (1175 0.15 457) - (1245 0.15 457) - (1397 0.15 457) - (1568 0.15 457) - (1760 0.15 457) - (1865 0.15 457) - (698 0.15 457) - (784 0.15 457) - (831 0.15 457) - (932 0.15 457) - (1047 0.15 457) - (1175 0.15 457) - (1319 0.15 457) - (1397 0.15 457) - (1245 0.15 457) - (1175 0.15 457) - (1245 0.15 457) - (1397 0.15 457) - (1568 0.15 457) - (1760 0.15 457) - (1976 0.15 457) - (2093 0.30 457) - (1976 0.15 457) - (1760 0.15 457) - (1568 0.15 457) - (1397 0.15 457) - (1245 0.15 457) - (1175 0.15 457) - (1047 0.30 457) - (1245 0.30 457) - (1175 0.30 457) - (1047 0.30 457) - (932 0.30 457) - (880 0.30 457) - (932 0.30 457) - (1047 0.30 457) - (740 0.30 457) - (784 0.30 457) - (880 0.30 457) - (740 0.30 457) - (784 0.30 457) - (1175 0.15 457) - (1047 0.15 457) - (1175 0.30 457) - (rest 0.6) - (1319 0.15 457) - (1175 0.15 457) - (1319 0.30 457) - (rest 0.6) - (1480 0.15 457) - (1319 0.15 457) - (1480 0.30 457) - (rest 0.6) - (784 0.15 457) - (698 0.15 457) - (784 0.30 457) - (rest 0.6) - (880 0.15 457) - (784 0.15 457) - (880 0.30 457) - (rest 0.6) - (988 0.15 457) - (880 0.15 457) - (988 0.30 457) - (rest 0.6) - (1047 0.15 457) - (988 0.15 457) - (1047 0.30 457) - (784 0.30 457) - (831 0.30 457) - (1047 0.15 457) - (988 0.15 457) - (1047 0.30 457) - (1175 0.30 457) - (784 0.30 457) - (1047 0.15 457) - (988 0.15 457) - (1047 0.30 457) - (1175 0.30 457) - (698 0.15 457) - (784 0.15 457) - (831 0.60 457) - (784 0.15 457) - (698 0.15 457) - (622 0.30 457) - (1047 0.15 457) - (988 0.15 457) - (1047 0.30 457) - (784 0.30 457) - (831 0.60 457) - (rest 0.3) - (880 0.30 457) - (932 0.30 457) - (932 0.15 457) - (880 0.15 457) - (932 0.30 457) - (698 0.30 457) - (784 0.60 457) - (rest 0.3) - (784 0.60 457) - (831 0.15 457) - (932 0.15 457) - (1047 0.15 457) - (988 0.15 457) - (1047 0.15 457) - (831 0.15 457) - (698 1.20 457) - (698 0.30 591) - (1175 0.15 591) - (1047 0.15 591) - (1175 0.30 591) - (698 0.30 591) - (622 0.30 591) - (1245 0.15 591) - (1175 0.15 591) - (1245 0.30 591) - (784 0.30 591) - (698 0.30 591) - (1397 0.15 591) - (1245 0.15 591) - (1397 0.30 591) - (831 0.30 591) - (784 0.15 591) - (1397 0.15 591) - (1245 0.15 591) - (1175 0.15 591) - (1047 0.15 591) - (988 0.15 591) - (880 0.15 591) - (784 0.15 591) - (1047 0.30 591) - (1397 0.30 591) - (1245 0.30 591) - (1175 0.30 591) - (rest 0.3) - (831 0.30 591) - (784 0.30 591) - (698 0.30 591) - (784 0.30 591) - (698 0.15 591) - (622 0.15 591) - (698 0.30 591) - (587 0.30 591) - (831 0.30 591) - (784 0.30 591) - (rest 0.3) - (880 0.30 591) - (988 0.30 591) - (1047 0.30 591) - (698 0.15 591) - (622 0.15 591) - (587 0.15 591) - (523 0.15 591) - (523 0.30 591) - (1047 0.15 346) - (988 0.15 346) - (1047 0.30 346) - (784 0.30 346) - (831 0.30 346) - (1047 0.15 346) - (988 0.15 346) - (1047 0.30 346) - (1175 0.30 346) - (784 0.30 346) - (1047 0.15 346) - (988 0.15 346) - (1047 0.30 346) - (1175 0.30 346) - (698 0.20 346) - (784 0.20 346) - (831 0.80 346) - (784 0.20 346) - (698 0.20 346) - (659 1.60 346)). -! ! -!AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 12/17/97 16:52'! - bachFugueVoice3On: aSound - "Voice three of a fugue by J. S. Bach." - - ^ self noteSequenceOn: aSound from: #( - (rest 14.4) - (523 0.15 457) - (494 0.15 457) - (523 0.30 457) - (392 0.30 457) - (415 0.30 457) - (523 0.15 457) - (494 0.15 457) - (523 0.30 457) - (587 0.30 457) - (392 0.30 457) - (523 0.15 457) - (494 0.15 457) - (523 0.30 457) - (587 0.30 457) - (349 0.15 457) - (392 0.15 457) - (415 0.60 457) - (392 0.15 457) - (349 0.15 457) - (311 0.15 457) - (523 0.15 457) - (494 0.15 457) - (440 0.15 457) - (392 0.15 457) - (349 0.15 457) - (311 0.15 457) - (294 0.15 457) - (262 0.15 457) - (294 0.15 457) - (311 0.15 457) - (294 0.15 457) - (262 0.15 457) - (233 0.15 457) - (208 0.15 457) - (196 0.15 457) - (175 0.15 457) - (466 0.15 457) - (415 0.15 457) - (392 0.15 457) - (349 0.15 457) - (311 0.15 457) - (294 0.15 457) - (262 0.15 457) - (233 0.15 457) - (262 0.15 457) - (294 0.15 457) - (262 0.15 457) - (233 0.15 457) - (208 0.15 457) - (196 0.15 457) - (175 0.15 457) - (156 0.15 457) - (415 0.15 457) - (392 0.15 457) - (349 0.15 457) - (311 0.15 457) - (277 0.15 457) - (262 0.15 457) - (233 0.15 457) - (208 0.30 457) - (523 0.30 457) - (466 0.30 457) - (415 0.30 457) - (392 0.30 457) - (349 0.30 457) - (392 0.30 457) - (415 0.30 457) - (294 0.30 457) - (311 0.30 457) - (349 0.30 457) - (294 0.30 457) - (311 0.30 457) - (415 0.30 457) - (392 0.30 457) - (349 0.30 457) - (392 0.30 457) - (311 0.30 457) - (294 0.30 457) - (262 0.30 457) - (294 0.30 457) - (466 0.30 457) - (415 0.30 457) - (392 0.30 457) - (415 0.30 457) - (349 0.30 457) - (311 0.30 457) - (294 0.30 457) - (311 0.30 457) - (rest 1.2) - (262 0.30 457) - (233 0.30 457) - (220 0.30 457) - (rest 0.3) - (311 0.30 457) - (294 0.30 457) - (262 0.30 457) - (294 0.30 457) - (262 0.15 457) - (233 0.15 457) - (262 0.30 457) - (294 0.30 457) - (196 0.30 591) - (466 0.15 591) - (440 0.15 591) - (466 0.30 591) - (294 0.30 591) - (311 0.30 591) - (523 0.15 591) - (466 0.15 591) - (523 0.30 591) - (330 0.30 591) - (349 0.30 591) - (587 0.15 591) - (523 0.15 591) - (587 0.30 591) - (370 0.30 591) - (392 0.60 591) - (rest 0.15) - (196 0.15 591) - (220 0.15 591) - (247 0.15 591) - (262 0.15 591) - (294 0.15 591) - (311 0.45 591) - (220 0.15 591) - (233 0.15 591) - (262 0.15 591) - (294 0.15 591) - (311 0.15 591) - (349 0.45 591) - (247 0.15 591) - (262 0.15 591) - (294 0.15 591) - (311 0.30 591) - (rest 0.6) - (330 0.30 591) - (349 0.30 591) - (175 0.30 591) - (156 0.30 591) - (147 0.30 591) - (rest 0.3) - (208 0.30 591) - (196 0.30 591) - (175 0.30 591) - (196 0.30 591) - (175 0.15 591) - (156 0.15 591) - (175 0.30 591) - (196 0.30 591) - (262 0.15 591) - (294 0.15 591) - (311 0.15 591) - (294 0.15 591) - (262 0.15 591) - (233 0.15 591) - (208 0.15 591) - (196 0.15 591) - (175 0.15 591) - (466 0.15 591) - (415 0.15 591) - (392 0.15 591) - (349 0.15 591) - (311 0.15 591) - (294 0.15 591) - (262 0.15 591) - (233 0.15 591) - (262 0.15 591) - (294 0.15 591) - (262 0.15 591) - (233 0.15 591) - (208 0.15 591) - (196 0.15 591) - (175 0.15 591) - (156 0.15 591) - (415 0.15 591) - (392 0.15 591) - (349 0.15 591) - (311 0.15 591) - (294 0.15 591) - (262 0.15 591) - (233 0.15 591) - (208 0.15 591) - (233 0.15 591) - (262 0.15 591) - (233 0.15 591) - (208 0.15 591) - (196 0.15 591) - (175 0.15 591) - (156 0.15 591) - (147 0.15 591) - (392 0.15 591) - (349 0.15 591) - (311 0.15 591) - (294 0.15 591) - (262 0.15 591) - (247 0.15 591) - (220 0.15 591) - (196 0.60 772) - (196 0.60 772) - (rest 0.15) - (196 0.15 772) - (220 0.15 772) - (247 0.15 772) - (262 0.15 772) - (294 0.15 772) - (311 0.15 772) - (349 0.15 772) - (392 0.15 772) - (349 0.15 772) - (415 0.15 772) - (392 0.15 772) - (349 0.15 772) - (311 0.15 772) - (294 0.15 772) - (262 0.15 772) - (247 0.30 772) - (262 0.15 772) - (494 0.15 772) - (262 0.30 772) - (196 0.30 772) - (208 0.30 772) - (262 0.15 772) - (247 0.15 772) - (262 0.30 772) - (294 0.30 772) - (196 0.30 772) - (262 0.15 772) - (247 0.15 772) - (262 0.30 772) - (294 0.30 772) - (175 0.15 772) - (196 0.15 772) - (208 0.60 772) - (196 0.15 772) - (175 0.15 772) - (156 0.60 772) - (rest 0.3) - (311 0.30 772) - (294 0.30 772) - (262 0.30 772) - (392 0.30 772) - (196 0.30 772) - (262 3.60 268) - (494 0.40 268) - (rest 0.4) - (494 0.40 268) - (rest 0.4) - (392 1.60 268)). -! ! -!AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 12/17/97 16:52'! - bachFugueVoice4On: aSound - "Voice four of a fugue by J. S. Bach." - - ^ self noteSequenceOn: aSound from: #( - (rest 61.2) - (131 0.15 500) - (123 0.15 500) - (131 0.30 500) - (98 0.30 500) - (104 0.30 500) - (131 0.15 500) - (123 0.15 500) - (131 0.30 500) - (147 0.30 500) - (98 0.30 500) - (131 0.15 500) - (123 0.15 500) - (131 0.30 500) - (147 0.30 500) - (87 0.15 500) - (98 0.15 500) - (104 0.60 500) - (98 0.15 500) - (87 0.15 500) - (78 0.60 500) - (rest 0.3) - (156 0.30 500) - (147 0.30 500) - (131 0.30 500) - (196 0.30 500) - (98 0.30 500) - (131 3.60 268) - (131 3.20 205)). -! ! -!AbstractSound class methodsFor: 'utilities' stamp: 'DSM 9/5/2000 13:50'! - busySignal: count - "AbstractSound busySignal: 3" - | m s | - s _ SequentialSound new. - m _ MixedSound new. - m add: (FMSound new setPitch: 480 dur: 0.5 loudness: 0.5); - add: (FMSound new setPitch: 620 dur: 0.5 loudness: 0.5). - s add: m. - s add: (FMSound new setPitch: 1 dur: 0.5 loudness: 0). - ^ (RepeatingSound repeat: s count: count) play. - -! ! -!AbstractSound class methodsFor: 'examples' stamp: 'jm 6/30/1998 18:40'! - chromaticPitchesFrom: aPitch - - | halfStep pitch | - halfStep _ 2.0 raisedTo: (1.0 / 12.0). - pitch _ aPitch isNumber - ifTrue: [aPitch] - ifFalse: [self pitchForName: aPitch]. - pitch _ pitch / halfStep. - ^ (0 to: 14) collect: [:i | pitch _ pitch * halfStep] -! ! -!AbstractSound class methodsFor: 'examples' stamp: 'jm 8/18/1998 11:32'! - chromaticRunFrom: startPitch to: endPitch on: aSound - "Answer a composite sound consisting of a rapid chromatic run between the given pitches on the given sound." - "(AbstractSound chromaticRunFrom: 'c3' to: 'c#5' on: FMSound oboe1) play" - - | scale halfStep pEnd p | - scale _ SequentialSound new. - halfStep _ 2.0 raisedTo: (1.0 / 12.0). - endPitch isNumber - ifTrue: [pEnd _ endPitch asFloat] - ifFalse: [pEnd _ AbstractSound pitchForName: endPitch]. - startPitch isNumber - ifTrue: [p _ startPitch asFloat] - ifFalse: [p _ AbstractSound pitchForName: startPitch]. - [p <= pEnd] whileTrue: [ - scale add: (aSound soundForPitch: p dur: 0.2 loudness: 0.5). - p _ p * halfStep]. - ^ scale -! ! -!AbstractSound class methodsFor: 'examples' stamp: 'jm 1/5/98 17:35'! - chromaticScale - "PluckedSound chromaticScale play" - - ^ self chromaticScaleOn: self default -! ! -!AbstractSound class methodsFor: 'examples' stamp: 'jm 1/31/98 16:14'! - chromaticScaleOn: aSound - "PluckedSound chromaticScale play" - - ^ self noteSequenceOn: aSound - from: (((self chromaticPitchesFrom: #c4) copyFrom: 1 to: 13) - collect: [:pitch | Array with: pitch with: 0.5 with: 300]) -! ! -!AbstractSound class methodsFor: 'instance creation' stamp: 'jm 1/5/98 17:40'! - default - "Return a default sound prototype for this class, with envelopes if appropriate. (This is in contrast to new, which returns a raw instance without envelopes.)" - - ^ self new -! ! -!AbstractSound class methodsFor: 'utilities' stamp: 'eem 6/11/2008 12:40'! - dial: aString - | s | - "AbstractSound dial: '867-5309'" "ask for Jenny" - - s := SequentialSound new. - aString do: [ :c | | index lo hi m | - c = $, - ifTrue: [ s add: (FMSound new setPitch: 1 dur: 1 loudness: 0) ] - ifFalse: [ - (index := ('123A456B789C*0#D' indexOf: c)) > 0 - ifTrue: [ - lo := #(697 770 852 941) at: (index - 1 // 4 + 1). - hi := #(1209 1336 1477 1633) at: (index - 1 \\ 4 + 1). - m := MixedSound new. - m add: (FMSound new setPitch: lo dur: 0.15 loudness: 0.5). - m add: (FMSound new setPitch: hi dur: 0.15 loudness: 0.5). - s add: m. - s add: (FMSound new setPitch: 1 dur: 0.05 loudness: 0)]]]. - ^ s play. - -! ! -!AbstractSound class methodsFor: 'utilities' stamp: 'DSM 9/5/2000 13:49'! - dialTone: duration - "AbstractSound dialTone: 2" - | m | - m _ MixedSound new. - m add: (FMSound new setPitch: 350 dur: duration loudness: 0.5). - m add: (FMSound new setPitch: 440 dur: duration loudness: 0.5). - m play. - ^ m! ! -!AbstractSound class methodsFor: 'instance creation' stamp: 'jm 12/17/97 17:26'! - dur: d - "Return a rest of the given duration." - - ^ self basicNew setDur: d -! ! -!AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'jm 8/19/1998 12:42'! - fileOutSoundLibrary - "File out the current sound library." - "AbstractSound fileOutSoundLibrary" - - self fileOutSoundLibrary: Sounds. -! ! -!AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'pb 5/25/2016 01:35'! - fileOutSoundLibrary: aDictionary - "File out the given dictionary, which is assumed to contain sound and instrument objects keyed by their names." - "Note: This method is separated out so that one can file out edited sound libraries, as well as the system sound library. To make such a collection, you can inspect AbstractSound sounds and remove the items you don't want. Then do: 'AbstractSound fileOutSoundLibrary: self' from the Dictionary inspector." - - | fileName refStream | - (aDictionary isKindOf: Dictionary) - ifFalse: [self error: 'arg should be a dictionary of sounds']. - fileName _ FillInTheBlankMorph request: 'Sound library file name?'. - fileName isEmptyOrNil ifTrue: [^ self]. - (fileName, '.sounds') asFileEntry writeStreamDo: [ :file | - refStream _ SmartRefStream on: file. - [ refStream nextPut: aDictionary ]]! ! -!AbstractSound class methodsFor: 'utilities' stamp: 'DSM 9/5/2000 13:50'! - hangUpWarning: count - "AbstractSound hangUpWarning: 20" - | m s | - s _ SequentialSound new. - m _ MixedSound new. - m add: (FMSound new setPitch: 1400 dur: 0.1 loudness: 0.5); - add: (FMSound new setPitch: 2060 dur: 0.1 loudness: 0.5). - s add: m; add: (FMSound new setPitch: 1 dur: 0.1 loudness: 0). - ^ (RepeatingSound repeat: s count: count) play - -! ! -!AbstractSound class methodsFor: 'examples' stamp: 'jm 1/5/98 17:36'! - hiMajorScale - "FMSound hiMajorScale play" - - ^ self hiMajorScaleOn: self default -! ! -!AbstractSound class methodsFor: 'examples' stamp: 'di 1/30/98 16:00'! - hiMajorScaleOn: aSound - "FMSound hiMajorScale play" - - ^ self majorScaleOn: aSound from: #c6! ! -!AbstractSound class methodsFor: 'utilities' stamp: 'jm 8/3/1998 16:16'! - indexOfBottomOctavePitch: p - "Answer the index of the first pitch in the bottom octave equal to or higher than the given pitch. Assume that the given pitch is below the top pitch of the bottom octave." - - 1 to: PitchesForBottomOctave size do: [:i | - (PitchesForBottomOctave at: i) >= p ifTrue: [^ i]]. - self error: 'implementation error: argument pitch should be below or within the bottom octave'. -! ! -!AbstractSound class methodsFor: 'sound library' stamp: 'jm 8/14/1998 13:27'! - initSounds - "AbstractSound initSounds" - - Sounds _ Dictionary new. - (FMSound class organization listAtCategoryNamed: #instruments) - do: [:sel | Sounds at: sel asString put: (FMSound perform: sel)]. -! ! -!AbstractSound class methodsFor: 'class initialization' stamp: 'jm 8/3/1998 16:13'! - initialize - "AbstractSound initialize" - - | bottomC | - ScaleFactor _ 2 raisedTo: 15. - FloatScaleFactor _ ScaleFactor asFloat. - MaxScaledValue _ ((2 raisedTo: 31) // ScaleFactor) - 1. "magnitude of largest scaled value in 32-bits" - - "generate pitches for c-1 through c0" - bottomC _ (440.0 / 32) * (2.0 raisedTo: -9.0 / 12.0). - PitchesForBottomOctave _ (0 to: 12) collect: [:i | bottomC * (2.0 raisedTo: i asFloat / 12.0)]. - TopOfBottomOctave _ PitchesForBottomOctave last. -! ! -!AbstractSound class methodsFor: 'examples' stamp: 'jm 1/5/98 17:36'! - lowMajorScale - "PluckedSound lowMajorScale play" - - ^ self lowMajorScaleOn: self default -! ! -!AbstractSound class methodsFor: 'examples' stamp: 'di 1/30/98 16:01'! - lowMajorScaleOn: aSound - "PluckedSound lowMajorScale play" - - ^ self majorScaleOn: aSound from: #c3! ! -!AbstractSound class methodsFor: 'examples' stamp: 'di 1/30/98 16:04'! - majorChord - "FMSound majorChord play" - ^ self majorChordOn: self default from: #c4! ! -!AbstractSound class methodsFor: 'examples' stamp: 'eem 6/11/2008 12:41'! -majorChordOn: aSound from: aPitch - "FMSound majorChord play" - - | score majorScale leadingRest pan | - majorScale := self majorPitchesFrom: aPitch. - score := MixedSound new. - leadingRest := pan := 0. - #(1 3 5 8) do: [:noteIndex | | note | - note := aSound - soundForPitch: (majorScale at: noteIndex) - dur: 2.0 - leadingRest - loudness: 0.3. - score add: (RestSound dur: leadingRest), note pan: pan. - leadingRest := leadingRest + 0.2. - pan := pan + 0.3]. - ^ score -! ! -!AbstractSound class methodsFor: 'examples' stamp: 'di 1/30/98 14:45'! - majorPitchesFrom: aPitch - | chromatic | - chromatic _ self chromaticPitchesFrom: aPitch. - ^ #(1 3 5 6 8 10 12 13 15 13 12 10 8 6 5 3 1) collect: [:i | chromatic at: i]. -! ! -!AbstractSound class methodsFor: 'examples' stamp: 'jm 1/5/98 17:34'! - majorScale - "FMSound majorScale play" - - ^ self majorScaleOn: self default -! ! -!AbstractSound class methodsFor: 'examples' stamp: 'di 1/30/98 16:00'! - majorScaleOn: aSound - "FMSound majorScale play" - - ^ self majorScaleOn: aSound from: #c5! ! -!AbstractSound class methodsFor: 'examples' stamp: 'jm 7/13/1998 13:09'! - majorScaleOn: aSound from: aPitch - "FMSound majorScale play" - - ^ self noteSequenceOn: aSound - from: ((self majorPitchesFrom: aPitch) - collect: [:pitch | Array with: pitch with: 0.5 with: 300]) -! ! -!AbstractSound class methodsFor: 'examples' stamp: 'jmv 3/1/2010 14:41'! - majorScaleOn: aSound from: aPitch octaves: octaveCount - "(AbstractSound majorScaleOn: FMSound oboe1 from: #c2 octaves: 5) play" - - | startingPitch pitches | - startingPitch _ aPitch isNumber - ifTrue: [aPitch] - ifFalse: [self pitchForName: aPitch]. - pitches _ OrderedCollection new. - 0 to: octaveCount - 1 do: [ :i | | chromatic | - chromatic _ self chromaticPitchesFrom: startingPitch * (2 raisedTo: i). - #(1 3 5 6 8 10 12) do: [ :j | pitches addLast: (chromatic at: j)]]. - pitches addLast: startingPitch * (2 raisedTo: octaveCount). - ^ self noteSequenceOn: aSound - from: (pitches collect: [ :pitch | Array with: pitch with: 0.5 with: 300]) -! ! -!AbstractSound class methodsFor: 'utilities' stamp: 'jm 8/3/1998 16:16'! - midiKeyForPitch: pitchNameOrNumber - "Answer the midiKey closest to the given pitch. Pitch may be a numeric pitch or a pitch name string such as 'c4'." - "AbstractSound midiKeyForPitch: 440.0" - - | p octave i midiKey | - pitchNameOrNumber isNumber - ifTrue: [p _ pitchNameOrNumber asFloat] - ifFalse: [p _ AbstractSound pitchForName: pitchNameOrNumber]. - octave _ -1. - [p >= TopOfBottomOctave] whileTrue: [ - octave _ octave + 1. - p _ p / 2.0]. - - i _ self indexOfBottomOctavePitch: p. - (i > 1) ifTrue: [ - (p - (PitchesForBottomOctave at: i - 1)) < ((PitchesForBottomOctave at: i) - p) - ifTrue: [i _ i - 1]]. - - midiKey _ ((octave * 12) + 11 + i). - midiKey > 127 ifTrue: [midiKey _ 127]. - ^ midiKey -! ! -!AbstractSound class methodsFor: 'instance creation' stamp: 'eem 6/11/2008 12:41'! - noteSequenceOn: aSound from: anArray - "Build a note sequence (i.e., a SequentialSound) from the given array using the given sound as the instrument. Elements are either (pitch, duration, loudness) triples or (#rest duration) pairs. Pitches can be given as names or as numbers." - | score | - score := SequentialSound new. - anArray do: [:el | | pitch | - el size = 3 - ifTrue: [ - pitch := el at: 1. - pitch isNumber ifFalse: [pitch := self pitchForName: pitch]. - score add: ( - aSound - soundForPitch: pitch - dur: (el at: 2) - loudness: (el at: 3) / 1000.0)] - ifFalse: [ - score add: (RestSound dur: (el at: 2))]]. - ^ score -! ! -!AbstractSound class methodsFor: 'instance creation' stamp: 'jm 12/17/97 17:27'! -pitch: p dur: d loudness: l - "Return a new sound object for a note with the given parameters." - - ^ self new setPitch: p dur: d loudness: l -! ! -!AbstractSound class methodsFor: 'utilities' stamp: 'jm 8/3/1998 16:43'! - pitchForMIDIKey: midiKey - "Answer the pitch for the given MIDI key." - "(1 to: 127) collect: [:i | AbstractSound pitchForMIDIKey: i]" - - | indexInOctave octave | - indexInOctave _ (midiKey \\ 12) + 1. - octave _ (midiKey // 12) + 1. - ^ (PitchesForBottomOctave at: indexInOctave) * - (#(1.0 2.0 4.0 8.0 16.0 32.0 64.0 128.0 256.0 512.0 1024.0) at: octave) -! ! -!AbstractSound class methodsFor: 'utilities' stamp: 'jmv 2/6/2010 20:32'! - pitchForName: aString - "AbstractSound pitchForName: 'c2'" - "#(c 'c#' d eb e f fs g 'g#' a bf b) collect: [ :s | AbstractSound pitchForName: s, '4']" - - | s modifier octave i j noteName p | - s _ ReadStream on: aString. - modifier _ $n. - noteName _ s next. - (s atEnd not and: [ s peek isDigit ]) ifFalse: [ modifier _ s next ]. - octave _ s atEnd - ifTrue: [ 4 ] - ifFalse: [ Integer readFrom: s ]. - octave < 0 ifTrue: [ self error: 'cannot use negative octave number' ]. - i _ 'cdefgab' indexOf: noteName. - i = 0 ifTrue: [ self error: 'bad note name: ', noteName asString ]. - i _ #(2 4 6 7 9 11 13) at: i. - j _ 's#fb' indexOf: modifier. - j = 0 ifFalse: [ i _ i + (#(1 1 -1 -1) at: j) ]. "i is now in range: [1..14]" - "Table generator: (1 to: 14) collect: [ :i | 16.3516 * (2.0 raisedTo: (i - 2) asFloat / 12.0)]" - p _ #(15.4339 16.3516 17.3239 18.354 19.4454 20.6017 21.8268 23.1247 24.4997 25.9565 27.5 29.1352 30.8677 32.7032) at: i. - p _ p * (2.0 raisedToInteger: octave). - ^ p -! ! -!AbstractSound class methodsFor: 'utilities' stamp: 'jmv 3/13/2012 12:13'! -pitchTable - "AbstractSound pitchTable" - - | out i | - out := WriteStream on: (String new: 1000). - i := 12. - 0 to: 8 do: [:octave | - #(c 'c#' d eb e f fs g 'g#' a bf b) do: [:noteName | | note | - note := noteName, octave printString. - out nextPutAll: note; tab. - out nextPutAll: i printString; tab. - out nextPutAll: (AbstractSound pitchForName: note) printString; newLine. - i := i + 1]]. - ^ out contents -! ! -!AbstractSound class methodsFor: 'class initialization' stamp: 'jm 1/5/98 13:51'! - scaleFactor - - ^ ScaleFactor -! ! -!AbstractSound class methodsFor: 'examples' stamp: 'jm 1/5/98 17:32'! - scaleTest - "AbstractSound scaleTest play" - - ^ MixedSound new - add: FMSound majorScale pan: 0; - add: (PluckedSound lowMajorScale delayedBy: 0.5) pan: 1.0. -! ! -!AbstractSound class methodsFor: 'sound library' stamp: 'jm 8/14/1998 13:25'! - soundNamed: soundName - - ^ Sounds at: soundName -! ! -!AbstractSound class methodsFor: 'sound library' stamp: 'jm 3/4/98 10:29'! - soundNamed: soundName ifAbsent: aBlock - - ^ Sounds at: soundName ifAbsent: aBlock -! ! -!AbstractSound class methodsFor: 'sound library' stamp: 'di 11/7/2000 12:12'! - soundNamed: soundName put: aSound - - Sounds at: soundName put: aSound. - AbstractSound updateScorePlayers. -! ! -!AbstractSound class methodsFor: 'sound library' stamp: 'jmv 1/16/2011 23:53'! - soundNames - - ^ Sounds keys sort! ! -!AbstractSound class methodsFor: 'sound library' stamp: 'jm 8/4/1998 18:26'! - sounds - - ^ Sounds -! ! -!AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 1/5/98 17:45'! - stereoBachFugue - "Play fugue by J. S. Bach in stereo using different timbres." - "AbstractSound stereoBachFugue play" - - "(AbstractSound bachFugueVoice1On: FMSound flute1) play" - "(AbstractSound bachFugueVoice1On: PluckedSound default) play" - - ^ MixedSound new - add: (self bachFugueVoice1On: FMSound oboe1) pan: 0.2; - add: (self bachFugueVoice2On: FMSound organ1) pan: 0.8; - add: (self bachFugueVoice3On: PluckedSound default) pan: 0.4; - add: (self bachFugueVoice4On: FMSound brass1) pan: 0.6. -! ! -!AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'jm 9/12/1998 21:35'! - storeFiledInSound: snd named: sndName - "Store the given sound in the sound library. Use the given name if it isn't in use, otherwise ask the user what to do." - - | menu choice i | - (Sounds includesKey: sndName) ifFalse: [ "no name clash" - Sounds at: sndName put: snd. - ^ self]. - - (Sounds at: sndName) == UnloadedSnd ifTrue: [ - "re-loading a sound that was unloaded to save space" - Sounds at: sndName put: snd. - ^ self]. - - "the given sound name is already used" - menu _ SelectionMenu selections: - #('replace the existing sound' 'rename the new sound' 'skip it'). - choice _ menu startUpWithCaption: - '"', sndName, '" has the same name as an existing sound'. - (choice beginsWith: 'replace') ifTrue: [ - Sounds at: sndName put: snd. - ^ self]. - (choice beginsWith: 'rename') ifTrue: [ - i _ 2. - [Sounds includesKey: (sndName, ' v', i printString)] whileTrue: [i _ i + 1]. - Sounds at: (sndName, ' v', i printString) put: snd]. -! ! -!AbstractSound class methodsFor: 'examples' stamp: 'jmv 1/14/2013 21:11'! - testFMInteractively - "Experiment with different settings of the FM modulation and multiplier settings interactively by moving the mouse. The top-left corner of the screen is 0 for both parameters. Stop when the mouse is pressed." - "AbstractSound testFMInteractively" - - | s mousePt lastVal status mod ratio | - SoundPlayer startPlayerProcessBufferSize: 1100 rate: 11025 stereo: false. - s _ FMSound pitch: 440.0 dur: 200.0 loudness: 0.2. - - SoundPlayer playSound: s. - lastVal _ nil. - [Sensor isAnyButtonPressed] whileFalse: [ - mousePt _ Sensor mousePoint. - mousePt ~= lastVal ifTrue: [ - mod _ mousePt x asFloat / 20.0. - ratio _ mousePt y asFloat / 20.0. - s modulation: mod ratio: ratio. - lastVal _ mousePt. - status _ -'mod: ', mod printString, ' -ratio: ', ratio printString. - status displayOn: Display at: 10@10]]. - - SoundPlayer shutDown. -! ! -!AbstractSound class methodsFor: 'primitive generation' stamp: 'ar 2/3/2001 15:30'! - translatedPrimitives - ^#( - (FMSound mixSampleCount:into:startingAt:leftVol:rightVol:) - (PluckedSound mixSampleCount:into:startingAt:leftVol:rightVol:) - (LoopedSampledSound mixSampleCount:into:startingAt:leftVol:rightVol:) - (SampledSound mixSampleCount:into:startingAt:leftVol:rightVol:) - (ReverbSound applyReverbTo:startingAt:count:) - ). -! ! -!AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'jmv 1/16/2011 23:57'! - unloadSampledTimbres - "This can be done to unload those bulky sampled timbres to shrink the image. The unloaded sounds are replaced by a well-known 'unloaded sound' object to enable the unloaded sounds to be detected when the process is reversed." - "AbstractSound unloadSampledTimbres" - - Sounds keys do: [:soundName | - (((Sounds at: soundName) isKindOf: SampledInstrument) or: - [(Sounds at: soundName) isKindOf: LoopedSampledSound]) ifTrue: [ - Sounds at: soundName put: self unloadedSound]]. - self updateScorePlayers. - Smalltalk garbageCollect! ! -!AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'jm 9/11/1998 16:47'! - unloadSoundNamed: soundName - - (Sounds includesKey: soundName) ifTrue: [ - Sounds at: soundName put: self unloadedSound]. - self updateScorePlayers. -! ! -!AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'jm 9/12/1998 21:48'! - unloadedSound - "Answer a sound to be used as the place-holder for sounds that have been unloaded." - - UnloadedSnd ifNil: [UnloadedSnd _ UnloadedSound default copy]. - ^ UnloadedSnd -! ! -!AbstractSound class methodsFor: 'sound library' stamp: 'jmv 3/2/2010 09:00'! - updateFMSounds - "AbstractSound updateFMSounds" - - Sounds keys do: [:k | - ((Sounds at: k) isKindOf: FMSound) ifTrue: [ - Sounds removeKey: k ifAbsent: nil]]. - - (FMSound class organization listAtCategoryNamed: #instruments) do: - [:sel | Sounds at: sel asString put: (FMSound perform: sel)]. -! ! -!AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'jmv 4/1/2009 21:39'! - updateScorePlayers - "Force all ScorePlayers to update their instrument list from the sound library. This may done after loading, unloading, or replacing a sound to make all ScorePlayers feel the change." - - | soundsBeingEdited | - ScorePlayer allSubInstancesDo: [:p | p pause]. - SoundPlayer shutDown. -" soundsBeingEdited := EnvelopeEditorMorph allSubInstances - collect: [:ed | ed soundBeingEdited]. - ScorePlayerMorph - allSubInstancesDo: [:p | p updateInstrumentsFromLibraryExcept: soundsBeingEdited]"! ! -!FMSound methodsFor: 'accessing' stamp: 'jm 3/26/98 10:45'! - duration - - ^ initialCount asFloat / self samplingRate asFloat -! ! -!FMSound methodsFor: 'accessing' stamp: 'jm 9/9/1998 07:49'! - duration: seconds - - super duration: seconds. - count _ initialCount _ (seconds * self samplingRate) rounded. -! ! -!FMSound methodsFor: 'initialization' stamp: 'jm 7/5/1998 11:44'! - initialize - - super initialize. - waveTable _ SineTable. - scaledWaveTableSize _ waveTable size * ScaleFactor. - self setPitch: 440.0 dur: 1.0 loudness: 0.2. -! ! -!FMSound methodsFor: 'accessing' stamp: 'jm 2/4/98 07:44'! - internalizeModulationAndRatio - "Recompute the internal state for the modulation index and frequency ratio relative to the current pitch." - - modulation < 0.0 ifTrue: [modulation _ modulation negated]. - multiplier < 0.0 ifTrue: [multiplier _ multiplier negated]. - normalizedModulation _ - ((modulation * scaledIndexIncr) / ScaleFactor) asInteger. - scaledOffsetIndexIncr _ (multiplier * scaledIndexIncr) asInteger. - - "clip to maximum values if necessary" - normalizedModulation > MaxScaledValue ifTrue: [ - normalizedModulation _ MaxScaledValue. - modulation _ (normalizedModulation * ScaleFactor) asFloat / scaledIndexIncr]. - scaledOffsetIndexIncr > (scaledWaveTableSize // 2) ifTrue: [ - scaledOffsetIndexIncr _ scaledWaveTableSize // 2. - multiplier _ scaledOffsetIndexIncr asFloat / scaledIndexIncr]. -! ! -!FMSound methodsFor: 'sound generation' stamp: 'ar 2/3/2001 15:22'! - mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol - "Play samples from a wave table by stepping a fixed amount through the table on every sample. The table index and increment are scaled to allow fractional increments for greater pitch accuracy." - "(FMSound pitch: 440.0 dur: 1.0 loudness: 0.5) play" - - | doingFM lastIndex sample offset i s | - - self var: #aSoundBuffer declareC: 'short int *aSoundBuffer'. - self var: #waveTable declareC: 'short int *waveTable'. - - doingFM _ (normalizedModulation ~= 0) and: [scaledOffsetIndexIncr ~= 0]. - lastIndex _ (startIndex + n) - 1. - startIndex to: lastIndex do: [:sliceIndex | - sample _ (scaledVol * (waveTable at: (scaledIndex // ScaleFactor) + 1)) // ScaleFactor. - doingFM - ifTrue: [ - offset _ normalizedModulation * (waveTable at: (scaledOffsetIndex // ScaleFactor) + 1). - scaledOffsetIndex _ (scaledOffsetIndex + scaledOffsetIndexIncr) \\ scaledWaveTableSize. - scaledOffsetIndex < 0 - ifTrue: [scaledOffsetIndex _ scaledOffsetIndex + scaledWaveTableSize]. - scaledIndex _ (scaledIndex + scaledIndexIncr + offset) \\ scaledWaveTableSize. - scaledIndex < 0 - ifTrue: [scaledIndex _ scaledIndex + scaledWaveTableSize]] - ifFalse: [ - scaledIndex _ (scaledIndex + scaledIndexIncr) \\ scaledWaveTableSize]. - - leftVol > 0 ifTrue: [ - i _ (2 * sliceIndex) - 1. - s _ (aSoundBuffer at: i) + ((sample * leftVol) // ScaleFactor). - s > 32767 ifTrue: [s _ 32767]. "clipping!!" - s < -32767 ifTrue: [s _ -32767]. "clipping!!" - aSoundBuffer at: i put: s]. - rightVol > 0 ifTrue: [ - i _ 2 * sliceIndex. - s _ (aSoundBuffer at: i) + ((sample * rightVol) // ScaleFactor). - s > 32767 ifTrue: [s _ 32767]. "clipping!!" - s < -32767 ifTrue: [s _ -32767]. "clipping!!" - aSoundBuffer at: i put: s]. - - scaledVolIncr ~= 0 ifTrue: [ - scaledVol _ scaledVol + scaledVolIncr. - ((scaledVolIncr > 0 and: [scaledVol >= scaledVolLimit]) or: - [scaledVolIncr < 0 and: [scaledVol <= scaledVolLimit]]) - ifTrue: [ "reached the limit; stop incrementing" - scaledVol _ scaledVolLimit. - scaledVolIncr _ 0]]]. - - count _ count - n. -! ! -!FMSound methodsFor: 'accessing' stamp: 'jm 2/4/98 07:15'! - modulation - "Return the FM modulation index." - - ^ modulation -! ! -!FMSound methodsFor: 'accessing' stamp: 'jm 2/4/98 07:22'! - modulation: mod - "Set the FM modulation index. Typical values range from 0 (no modulation) to 5, although values up to about 10 are sometimes useful." - "Warning: This method is intended primarily for use by envelopes. For efficiency during envelope processing, this change will not take effect until internalizeModulationAndRatio is called." - - modulation _ mod asFloat. -! ! -!FMSound methodsFor: 'accessing' stamp: 'jm 2/4/98 07:39'! - modulation: mod multiplier: freqRatio - "For backward compatibility. Needed to read old .fmp files." - - self modulation: mod ratio: freqRatio. -! ! -!FMSound methodsFor: 'accessing' stamp: 'jm 2/4/98 07:41'! - modulation: mod ratio: freqRatio - "Set the modulation index and carrier to modulation frequency ratio for this sound, and compute the internal state that depends on these parameters." - - modulation _ mod asFloat. - multiplier _ freqRatio asFloat. - self internalizeModulationAndRatio. -! ! -!FMSound methodsFor: 'accessing' stamp: 'jm 12/17/97 18:05'! - multiplier - - ^ multiplier -! ! -!FMSound methodsFor: 'accessing' stamp: 'jm 8/7/1998 15:45'! - pitch - - ^ (self samplingRate asFloat * scaledIndexIncr / ScaleFactor) asFloat / waveTable size -! ! -!FMSound methodsFor: 'accessing' stamp: 'jm 2/4/98 07:38'! - pitch: p - "Warning: Since the modulation and ratio are relative to the current pitch, some internal state must be recomputed when the pitch is changed. However, for efficiency during envelope processing, this compuation will not be done until internalizeModulationAndRatio is called." - - scaledIndexIncr _ - ((p asFloat * waveTable size asFloat * ScaleFactor asFloat) / self samplingRate asFloat) asInteger - min: (waveTable size // 2) * ScaleFactor. -! ! -!FMSound methodsFor: 'accessing' stamp: 'jm 2/4/98 07:08'! - ratio - "Return the FM modulation to carrier frequency ratio." - - ^ multiplier -! ! -!FMSound methodsFor: 'accessing' stamp: 'jm 2/4/98 07:22'! - ratio: freqRatio - "Set the FM modulation to carrier frequency ratio." - "Warning: This method is intended primarily for use by envelopes. For efficiency during envelope processing, this change will not take effect until internalizeModulationAndRatio is called." - - multiplier _ freqRatio asFloat. -! ! -!FMSound methodsFor: 'sound generation' stamp: 'jm 2/4/98 20:12'! - reset - - self internalizeModulationAndRatio. - super reset. - count _ initialCount. - scaledIndex _ 0. - scaledOffsetIndex _ 0. -! ! -!FMSound methodsFor: 'sound generation' stamp: 'jm 12/8/97 19:34'! - samplesRemaining - - ^ count -! ! -!FMSound methodsFor: 'initialization' stamp: 'jm 7/6/1998 17:08'! - setPitch: pitchNameOrNumber dur: d loudness: vol - "(FMSound pitch: 'a4' dur: 2.5 loudness: 0.4) play" - - super setPitch: pitchNameOrNumber dur: d loudness: vol. - modulation ifNil: [modulation _ 0.0]. - multiplier ifNil: [multiplier _ 0.0]. - self pitch: (self nameOrNumberToPitch: pitchNameOrNumber). - self reset. -! ! -!FMSound methodsFor: 'initialization' stamp: 'jm 9/20/1998 10:10'! - setWavetable: anArray - "(AbstractSound lowMajorScaleOn: (FMSound new setWavetable: AA)) play" - - | samples p dur vol | - "copy the array into a SoundBuffer if necessary" - anArray class isPointers - ifTrue: [samples _ SoundBuffer fromArray: anArray] - ifFalse: [samples _ anArray]. - - p _ self pitch. - dur _ self duration. - vol _ self loudness. - waveTable _ samples. - scaledWaveTableSize _ waveTable size * ScaleFactor. - self setPitch: p dur: dur loudness: vol. -! ! -!FMSound methodsFor: 'sound generation' stamp: 'jm 9/9/1998 21:55'! - stopAfterMSecs: mSecs - "Terminate this sound this note after the given number of milliseconds." - - count _ (mSecs * self samplingRate) // 1000. -! ! -!FMSound methodsFor: 'storing' stamp: 'jmv 3/13/2012 12:34'! - storeOn: strm - | env | - strm nextPutAll: '(((FMSound'; - nextPutAll: ' pitch: '; print: self pitch; - nextPutAll: ' dur: '; print: self duration; - nextPutAll: ' loudness: '; print: self loudness; nextPutAll: ')'; - nextPutAll: ' modulation: '; print: self modulation; - nextPutAll: ' ratio: '; print: self ratio; nextPutAll: ')'. - 1 to: envelopes size do: - [:i | env _ envelopes at: i. - strm newLine; nextPutAll: ' addEnvelope: '. env storeOn: strm. - i < envelopes size ifTrue: [strm nextPutAll: ';']]. - strm nextPutAll: ')'. -! ! -!FMSound class methodsFor: 'instruments' stamp: 'jm 1/14/1999 12:00'! -bass1 - "FMSound bass1 play" - "(FMSound lowMajorScaleOn: FMSound bass1) play" - - | snd | - snd _ FMSound new modulation: 0 ratio: 0. - snd addEnvelope: (VolumeEnvelope exponentialDecay: 0.95). - ^ snd setPitch: 220 dur: 1.0 loudness: 0.3 -! ! -!FMSound class methodsFor: 'instruments' stamp: 'jm 5/30/1999 20:37'! - bassoon1 - "FMSound bassoon1 play" - "(FMSound lowMajorScaleOn: FMSound bassoon1) play" - - | snd p env | - snd _ FMBassoonSound new ratio: 1. - - p _ OrderedCollection new. - p add: 0@0.0; add: 40@0.45; add: 90@1.0; add: 180@0.9; add: 270@1.0; add: 320@0.0. - snd addEnvelope: (VolumeEnvelope points: p loopStart: 3 loopEnd: 5). - - p _ OrderedCollection new. - p add: 0@0.2; add: 40@0.9; add: 90@0.6; add: 270@0.6; add: 320@0.5. - env _ Envelope points: p loopStart: 3 loopEnd: 4. - env updateSelector: #modulation:; scale: 5.05. - snd addEnvelope: env. - - ^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5 -! ! -!FMSound class methodsFor: 'instruments' stamp: 'jm 1/14/1999 12:00'! - brass1 - "FMSound brass1 play" - "(FMSound lowMajorScaleOn: FMSound brass1) play" - - | snd p env | - snd _ FMSound new modulation: 0 ratio: 1. - p _ OrderedCollection new. - p add: 0@0.0; add: 30@0.8; add: 90@1.0; add: 120@0.9; add: 220@0.7; add: 320@0.9; add: 360@0.0. - snd addEnvelope: (VolumeEnvelope points: p loopStart: 4 loopEnd: 6). - - p _ OrderedCollection new. - p add: 0@0.5; add: 60@1.0; add: 120@0.8; add: 220@0.65; add: 320@0.8; add: 360@0.0. - env _ Envelope points: p loopStart: 3 loopEnd: 5. - env target: snd; updateSelector: #modulation:; scale: 5.0. - snd addEnvelope: env. - - ^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5 -! ! -!FMSound class methodsFor: 'instruments' stamp: 'jm 1/14/1999 12:00'! - brass2 - "FMSound brass2 play" - "(FMSound lowMajorScaleOn: FMSound brass2) play" - - | snd p env | - snd _ FMSound new modulation: 1 ratio: 1. - - p _ OrderedCollection new. - p add: 0@0.0; add: 20@1.0; add: 40@0.9; add: 100@0.7; add: 160@0.9; add: 200@0.0. - snd addEnvelope: (VolumeEnvelope points: p loopStart: 3 loopEnd: 5). - - p _ OrderedCollection new. - p add: 0@0.5; add: 30@1.0; add: 40@0.8; add: 100@0.7; add: 160@0.8; add: 200@0.0. - env _ Envelope points: p loopStart: 3 loopEnd: 5. - env updateSelector: #modulation:; scale: 5.0. - snd addEnvelope: env. - - ^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5 -! ! -!FMSound class methodsFor: 'instruments' stamp: 'jm 1/14/1999 12:10'! - clarinet - "FMSound clarinet play" - "(FMSound lowMajorScaleOn: FMSound clarinet) play" - - | snd p env | - snd _ FMSound new modulation: 0 ratio: 2. - - p _ OrderedCollection new. - p add: 0@0.0; add: 60@1.0; add: 310@1.0; add: 350@0.0. - snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3). - - p _ OrderedCollection new. - p add: 0@0.0167; add: 60@0.106; add: 310@0.106; add: 350@0.0. - env _ Envelope points: p loopStart: 2 loopEnd: 3. - env updateSelector: #modulation:; scale: 10.0. - snd addEnvelope: env. - - ^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5 -! ! -!FMSound class methodsFor: 'instruments' stamp: 'jm 5/30/1999 10:20'! - clarinet2 - "FMSound clarinet2 play" - "(FMSound lowMajorScaleOn: FMSound clarinet2) play" - - | snd p env | - snd _ FMClarinetSound new modulation: 0 ratio: 2. - - p _ OrderedCollection new. - p add: 0@0.0; add: 60@1.0; add: 310@1.0; add: 350@0.0. - snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3). - - p _ OrderedCollection new. - p add: 0@0.0167; add: 60@0.106; add: 310@0.106; add: 350@0.0. - env _ Envelope points: p loopStart: 2 loopEnd: 3. - env updateSelector: #modulation:; scale: 10.0. - snd addEnvelope: env. - - ^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5 - -! ! -!FMSound class methodsFor: 'instruments' stamp: 'jm 1/5/98 17:35'! - default - - ^ self oboe1 -! ! -!FMSound class methodsFor: 'instruments' stamp: 'jm 8/14/1998 13:02'! - flute1 - "FMSound flute1 play" - "(FMSound majorScaleOn: FMSound flute1) play" - - | snd p | - snd _ FMSound new. - p _ OrderedCollection new. - p add: 0@0; add: 20@1.0; add: 100@1.0; add: 120@0.0. - snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3). - ^ snd setPitch: 440.0 dur: 1.0 loudness: 0.5 -! ! -!FMSound class methodsFor: 'instruments' stamp: 'jm 8/14/1998 13:02'! - flute2 - "FMSound flute2 play" - "(FMSound majorScaleOn: FMSound flute2) play" - - | snd p | - snd _ FMSound new. - p _ OrderedCollection new. - p add: 0@0; add: 20@1.0; add: 100@1.0; add: 120@0.0. - snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3). - snd addEnvelope: (RandomEnvelope for: #pitch:). - ^ snd setPitch: 440.0 dur: 1.0 loudness: 0.5 -! ! -!FMSound class methodsFor: 'class initialization' stamp: 'jm 7/6/1998 10:26'! - initialize - "Build a sine wave table." - "FMSound initialize" - - | tableSize radiansPerStep peak | - tableSize _ 4000. - SineTable _ SoundBuffer newMonoSampleCount: tableSize. - radiansPerStep _ (2.0 * Float pi) / tableSize asFloat. - peak _ ((1 bitShift: 15) - 1) asFloat. "range is +/- (2^15 - 1)" - 1 to: tableSize do: [:i | - SineTable at: i put: (peak * (radiansPerStep * (i - 1)) sin) rounded]. -! ! -!FMSound class methodsFor: 'instruments' stamp: 'jm 9/2/1999 13:32'! - marimba - "FMSound marimba play" - "(FMSound majorScaleOn: FMSound marimba) play" - - | snd p env | - snd _ FMSound new modulation: 1 ratio: 0.98. - - p _ OrderedCollection new. - p add: 0@1.0; add: 10@0.3; add: 40@0.1; add: 80@0.02; add: 120@0.1; add: 160@0.02; add: 220@0.0. - snd addEnvelope: (VolumeEnvelope points: p loopStart: 4 loopEnd: 6). - - p _ OrderedCollection new. - p add: 0@1.2; add: 80@0.85; add: 120@1.0; add: 160@0.85; add: 220@0.0. - env _ Envelope points: p loopStart: 2 loopEnd: 4. - env updateSelector: #modulation:. - snd addEnvelope: env. - - ^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5 -! ! -!FMSound class methodsFor: 'instruments' stamp: 'jm 1/14/1999 12:00'! - mellowBrass - "FMSound mellowBrass play" - "(FMSound lowMajorScaleOn: FMSound mellowBrass) play" - - | snd p env | - snd _ FMSound new modulation: 0 ratio: 1. - - p _ OrderedCollection new. - p add: 0@0.0; add: 70@0.325; add: 120@0.194; add: 200@0.194; add: 320@0.194; add: 380@0.0. - snd addEnvelope: (VolumeEnvelope points: p loopStart: 3 loopEnd: 5). - - p _ OrderedCollection new. - p add: 0@0.1; add: 70@0.68; add: 120@0.528; add: 200@0.519; add: 320@0.528; add: 380@0.0. - env _ Envelope points: p loopStart: 3 loopEnd: 5. - env updateSelector: #modulation:; scale: 5.0. - snd addEnvelope: env. - - ^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5 -! ! -!FMSound class methodsFor: 'instruments' stamp: 'jm 1/14/1999 12:00'! - oboe1 - "FMSound oboe1 play" - "(FMSound majorScaleOn: FMSound oboe1) play" - - | snd p | - snd _ FMSound new modulation: 1 ratio: 1. - p _ OrderedCollection new. - p add: 0@0.0; add: 10@1.0; add: 100@1.0; add: 120@0.0. - snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3). - ^ snd setPitch: 440.0 dur: 1.0 loudness: 0.5 -! ! -!FMSound class methodsFor: 'instruments' stamp: 'jm 1/14/1999 12:00'! - oboe2 - "FMSound oboe2 play" - "(FMSound majorScaleOn: FMSound oboe2) play" - - | snd p | - snd _ FMSound new modulation: 1 ratio: 1. - p _ OrderedCollection new. - p add: 0@0; add: 20@1.0; add: 100@1.0; add: 120@0.0. - snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3). - snd addEnvelope: (RandomEnvelope for: #pitch:). - ^ snd setPitch: 440.0 dur: 1.0 loudness: 0.5 -! ! -!FMSound class methodsFor: 'instruments' stamp: 'jm 1/14/1999 12:56'! - organ1 - "FMSound organ1 play" - "(FMSound majorScaleOn: FMSound organ1) play" - - | snd p | - snd _ FMSound new. - p _ OrderedCollection new. - p add: 0@0; add: 60@1.0; add: 110@0.8; add: 200@1.0; add: 250@0.0. - snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 4). - ^ snd setPitch: 440.0 dur: 1.0 loudness: 0.5 -! ! -!FMSound class methodsFor: 'instruments' stamp: 'jm 9/1/1999 17:33'! - pluckedElecBass - "FMSound pluckedElecBass play" - "(FMSound lowMajorScaleOn: FMSound pluckedElecBass) play" - - | snd p env | - snd _ FMSound new modulation: 1 ratio: 3.0. - - p _ OrderedCollection new. - p add: 0@0.4; add: 20@1.0; add: 30@0.6; add: 100@0.6; add: 130@0.0. - snd addEnvelope: (VolumeEnvelope points: p loopStart: 3 loopEnd: 4). - - p _ OrderedCollection new. - p add: 0@1.0; add: 20@2.0; add: 30@4.5; add: 100@4.5; add: 130@0.0. - env _ Envelope points: p loopStart: 3 loopEnd: 4. - env updateSelector: #modulation:. - snd addEnvelope: env. - - p _ OrderedCollection new. - p add: 0@6.0; add: 20@4.0; add: 30@3.0; add: 100@3.0; add: 130@3.0. - env _ Envelope points: p loopStart: 3 loopEnd: 4. - env updateSelector: #ratio:. - snd addEnvelope: env. - - ^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5 -! ! -!FMSound class methodsFor: 'instruments' stamp: 'jm 8/14/1998 13:00'! - randomWeird1 - "FMSound randomWeird1 play" - - | snd p | - snd _ FMSound new. - snd addEnvelope: (VolumeEnvelope exponentialDecay: 0.96). - p _ Array with: 0@0 with: 100@1.0 with: 250@0.7 with: 400@1.0 with: 500@0. - snd addEnvelope: (PitchEnvelope points: p loopStart: 2 loopEnd: 4). - ^ snd setPitch: (150 + 2000 atRandom) dur: 2.0 loudness: 0.5 -! ! -!FMSound class methodsFor: 'instruments' stamp: 'jm 8/14/1998 12:57'! - randomWeird2 - "FMSound randomWeird2 play" - - | snd | - snd _ FMSound new. - snd addEnvelope: (VolumeEnvelope exponentialDecay: 0.96). - snd addEnvelope: (PitchEnvelope exponentialDecay: 0.98). - ^ snd setPitch: (150 + 2000 atRandom) dur: 2.0 loudness: 0.5 -! ! -!FMSound class methodsFor: 'class initialization' stamp: 'jm 7/5/1998 14:22'! - sineTable - "Answer a SoundBuffer containing one complete cycle of a sine wave." - - ^ SineTable -! ! -!FMBassoonSound methodsFor: 'as yet unclassified' stamp: 'jm 5/30/1999 21:17'! - setPitch: pitchNameOrNumber dur: d loudness: l - "Select a modulation ratio and modulation envelope scale based on my pitch." - - | p modScale | - p _ self nameOrNumberToPitch: pitchNameOrNumber. - modScale _ 9.4. - p > 100.0 ifTrue: [modScale _ 8.3]. - p > 150.0 ifTrue: [modScale _ 6.4]. - p > 200.0 ifTrue: [modScale _ 5.2]. - p > 300.0 ifTrue: [modScale _ 3.9]. - p > 400.0 ifTrue: [modScale _ 2.8]. - p > 600.0 ifTrue: [modScale _ 1.7]. - - envelopes size > 0 ifTrue: [ - envelopes do: [:e | - (e updateSelector = #modulation:) - ifTrue: [e scale: modScale]]]. - - super setPitch: p dur: d loudness: l. -! ! -!FMClarinetSound methodsFor: 'initialization' stamp: 'jm 5/30/1999 10:10'! - setPitch: pitchNameOrNumber dur: d loudness: l - "Select a modulation ratio and modulation envelope scale based on my pitch." - - | p modScale | - p _ self nameOrNumberToPitch: pitchNameOrNumber. - p < 262.0 - ifTrue: [modScale _ 25.0. self ratio: 4] - ifFalse: [modScale _ 20.0. self ratio: 2]. - p > 524.0 ifTrue: [modScale _ 8.0]. - - envelopes size > 0 ifTrue: [ - envelopes do: [:e | - (e updateSelector = #modulation:) - ifTrue: [e scale: modScale]]]. - - super setPitch: p dur: d loudness: l. -! ! -!UnloadedSound class methodsFor: 'as yet unclassified' stamp: 'jm 1/14/1999 12:00'! - default - "UnloadedSound default play" - - | snd p | - snd _ super new modulation: 1 ratio: 1. - p _ OrderedCollection new. - p add: 0@0.0; add: 10@1.0; add: 100@1.0; add: 120@0.0. - snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3). - ^ snd setPitch: 440.0 dur: 1.0 loudness: 0.5 -! ! -!LoopedSampledSound methodsFor: 'initialization' stamp: 'jm 10/14/1998 16:04'! - addReleaseEnvelope - "Add a simple release envelope to this sound." - - | p env | - p _ OrderedCollection new. - p add: 0@1.0; add: 10@1.0; add: 100@1.0; add: 120@0.0. - env _ (VolumeEnvelope points: p loopStart: 2 loopEnd: 3) target: self. - envelopes size > 0 ifTrue: [ "remove any existing volume envelopes" - envelopes copy do: [:e | - (e isKindOf: VolumeEnvelope) ifTrue: [self removeEnvelope: e]]]. - self addEnvelope: env. -! ! -!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 5/31/1999 14:09'! - beUnlooped - - scaledLoopLength _ 0. -! ! -!LoopedSampledSound methodsFor: 'disk i/o' stamp: 'tk 4/8/1999 12:45'! - comeFullyUpOnReload: smartRefStream - "Convert my sample buffers from ByteArrays into SampleBuffers after raw loading from a DataStream. Answer myself." - - leftSamples == rightSamples - ifTrue: [ - leftSamples _ SoundBuffer fromByteArray: self leftSamples. - rightSamples _ leftSamples] - ifFalse: [ - leftSamples _ SoundBuffer fromByteArray: self leftSamples. - rightSamples _ SoundBuffer fromByteArray: self rightSamples]. - -! ! -!LoopedSampledSound methodsFor: 'initialization' stamp: 'jm 8/18/1998 11:48'! - computeSampleCountForRelease - "Calculate the number of samples before the end of the note after which looping back will be be disabled. The units of this value, sampleCountForRelease, are samples at the original sampling rate. When playing a specific note, this value is converted to releaseCount, which is number of samples to be computed at the current pitch and sampling rate." - "Details: For short loops, set the sampleCountForRelease to the loop length plus the number of samples between loopEnd and lastSample. Otherwise, set it to 1/10th of a second worth of samples plus the number of samples between loopEnd and lastSample. In this case, the trailing samples will be played only if the last loop-back occurs within 1/10th of a second of the total note duration, and the note may be shortened by up to 1/10th second. For long loops, this is the best we can do." - - (scaledLoopLength > 0 and: [lastSample > loopEnd]) - ifTrue: [ - sampleCountForRelease _ (lastSample - loopEnd) + - (self loopLength min: (originalSamplingRate / 10.0)) asInteger] - ifFalse: [sampleCountForRelease _ 0]. - - releaseCount _ sampleCountForRelease. -! ! -!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/18/1998 07:26'! - duration - "Answer the duration of this sound in seconds." - - ^ initialCount asFloat / self samplingRate asFloat -! ! -!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 9/11/1998 15:36'! - duration: seconds - - super duration: seconds. - count _ initialCount _ (seconds * self samplingRate) rounded. -! ! -!LoopedSampledSound methodsFor: 'other' stamp: 'jm 5/29/1999 18:56'! - findStartPointAfter: index - "Answer the index of the last zero crossing sample before the given index." - - | i | - i _ index min: lastSample. - - "scan backwards to the last zero-crossing" - (leftSamples at: i) > 0 - ifTrue: [ - [i > 1 and: [(leftSamples at: i) > 0]] whileTrue: [i _ i - 1]] - ifFalse: [ - [i > 1 and: [(leftSamples at: i) < 0]] whileTrue: [i _ i - 1]]. - ^ i -! ! -!LoopedSampledSound methodsFor: 'other' stamp: 'jm 8/18/1998 09:29'! - findStartPointForThreshold: threshold - "Answer the index of the last zero crossing sample before the first sample whose absolute value (in either the right or left channel) exceeds the given threshold." - - | i | - i _ self indexOfFirstPointOverThreshold: threshold. - i >= lastSample ifTrue: [^ self error: 'no sample exceeds the given threshold']. - - "scan backwards to the last zero-crossing" - (leftSamples at: i) > 0 - ifTrue: [ - [i > 1 and: [(leftSamples at: i) > 0]] whileTrue: [i _ i - 1]] - ifFalse: [ - [i > 1 and: [(leftSamples at: i) < 0]] whileTrue: [i _ i - 1]]. - ^ i -! ! -!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/18/1998 07:25'! - firstSample - - ^ firstSample -! ! -!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/18/1998 07:25'! - firstSample: aNumber - - firstSample _ (aNumber asInteger max: 1) min: lastSample. -! ! -!LoopedSampledSound methodsFor: 'initialization' stamp: 'jm 5/5/1999 20:59'! - fromAIFFFileNamed: fileName mergeIfStereo: mergeFlag - "Initialize this sound from the data in the given AIFF file. If mergeFlag is true and the file is stereo, its left and right channels are mixed together to produce a mono sampled sound." - - | aiffFileReader | - aiffFileReader _ AIFFFileReader new. - aiffFileReader readFromFile: fileName - mergeIfStereo: mergeFlag - skipDataChunk: false. - aiffFileReader isLooped - ifTrue: [ - self samples: aiffFileReader leftSamples - loopEnd: aiffFileReader loopEnd - loopLength: aiffFileReader loopLength - pitch: aiffFileReader pitch - samplingRate: aiffFileReader samplingRate] - ifFalse: [ - self unloopedSamples: aiffFileReader leftSamples - pitch: aiffFileReader pitch - samplingRate: aiffFileReader samplingRate]. - - "the following must be done second, since the initialization above sets - leftSamples and rightSamples to the same sample data" - aiffFileReader isStereo - ifTrue: [rightSamples _ aiffFileReader rightSamples]. - - initialCount _ (leftSamples size * self samplingRate) // originalSamplingRate. - self loudness: 1.0. - - self addReleaseEnvelope. -! ! -!LoopedSampledSound methodsFor: 'initialization'! - fromAIFFFileReader: aiffFileReader mergeIfStereo: mergeFlag - "Initialize this sound from the data in the given AIFF file. If mergeFlag is true and the file is stereo, its left and right channels are mixed together to produce a mono sampled sound." - - aiffFileReader isLooped - ifTrue: [ - self samples: aiffFileReader leftSamples - loopEnd: aiffFileReader loopEnd - loopLength: aiffFileReader loopLength - pitch: aiffFileReader pitch - samplingRate: aiffFileReader samplingRate] - ifFalse: [ - self unloopedSamples: aiffFileReader leftSamples - pitch: aiffFileReader pitch - samplingRate: aiffFileReader samplingRate]. - - "the following must be done second, since the initialization above sets - leftSamples and rightSamples to the same sample data" - aiffFileReader isStereo - ifTrue: [rightSamples _ aiffFileReader rightSamples]. - - initialCount _ (leftSamples size * self samplingRate) // originalSamplingRate. - self loudness: 1.0. - - self addReleaseEnvelope. -! ! -!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/3/1998 18:52'! - gain - - ^ gain -! ! -!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/3/1998 18:52'! - gain: aNumber - - gain _ aNumber asFloat. -! ! -!LoopedSampledSound methodsFor: 'other' stamp: 'jm 8/17/1998 09:22'! - indexOfFirstPointOverThreshold: threshold - "Answer the index of the first sample whose absolute value exceeds the given threshold." - - | s | - leftSamples == rightSamples - ifTrue: [ - 1 to: lastSample do: [:i | - s _ leftSamples at: i. - s < 0 ifTrue: [s _ 0 - s]. - s > threshold ifTrue: [^ i]]] - ifFalse: [ - 1 to: lastSample do: [:i | - s _ leftSamples at: i. - s < 0 ifTrue: [s _ 0 - s]. - s > threshold ifTrue: [^ i]. - s _ rightSamples at: i. - s < 0 ifTrue: [s _ 0 - s]. - s > threshold ifTrue: [^ i]]]. - ^ lastSample + 1 -! ! -!LoopedSampledSound methodsFor: 'initialization' stamp: 'jm 8/18/1998 07:43'! - initialize - "This default initialization creates a loop consisting of a single cycle of a sine wave." - "(LoopedSampledSound pitch: 440.0 dur: 1.0 loudness: 0.4) play" - - | samples | - super initialize. - samples _ FMSound sineTable. - self samples: samples - loopEnd: samples size - loopLength: samples size - pitch: 1.0 - samplingRate: samples size. - self addReleaseEnvelope. - self setPitch: 440.0 dur: 1.0 loudness: 0.5. -! ! -!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/18/1998 07:26'! - isLooped - - ^ scaledLoopLength ~= 0. "zero loop length means unlooped" -! ! -!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/2/1998 10:14'! - isStereo - - ^ leftSamples ~~ rightSamples -! ! -!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 7/13/1998 11:46'! - leftSamples - - ^ leftSamples -! ! -!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 7/13/1998 11:46'! - leftSamples: aSampleBuffer - - leftSamples _ aSampleBuffer. -! ! -!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/17/1998 09:35'! - loopEnd - - ^ loopEnd -! ! -!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/2/1998 10:12'! -loopLength - - ^ scaledLoopLength / FloatLoopIndexScaleFactor -! ! -!LoopedSampledSound methodsFor: 'sound generation' stamp: 'ar 2/3/2001 15:23'! - mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol - "Play samples from a wave table by stepping a fixed amount through the table on every sample. The table index and increment are scaled to allow fractional increments for greater pitch accuracy. If a loop length is specified, then the index is looped back when the loopEnd index is reached until count drops below releaseCount. This allows a short sampled sound to be sustained indefinitely." - "(LoopedSampledSound pitch: 440.0 dur: 5.0 loudness: 0.5) play" - - | lastIndex sampleIndex i s compositeLeftVol compositeRightVol nextSampleIndex m isInStereo rightVal leftVal | - - self var: #aSoundBuffer declareC: 'short int *aSoundBuffer'. - self var: #leftSamples declareC: 'short int *leftSamples'. - self var: #rightSamples declareC: 'short int *rightSamples'. - - isInStereo _ leftSamples ~~ rightSamples. - compositeLeftVol _ (leftVol * scaledVol) // ScaleFactor. - compositeRightVol _ (rightVol * scaledVol) // ScaleFactor. - - i _ (2 * startIndex) - 1. - lastIndex _ (startIndex + n) - 1. - startIndex to: lastIndex do: [:sliceIndex | - sampleIndex _ (scaledIndex _ scaledIndex + scaledIndexIncr) // LoopIndexScaleFactor. - ((sampleIndex > loopEnd) and: [count > releaseCount]) ifTrue: [ - "loop back if not within releaseCount of the note end" - "note: unlooped sounds will have loopEnd = lastSample" - sampleIndex _ (scaledIndex _ scaledIndex - scaledLoopLength) // LoopIndexScaleFactor]. - (nextSampleIndex _ sampleIndex + 1) > lastSample ifTrue: [ - sampleIndex > lastSample ifTrue: [count _ 0. ^ nil]. "done!!" - scaledLoopLength = 0 - ifTrue: [nextSampleIndex _ sampleIndex] - ifFalse: [nextSampleIndex _ ((scaledIndex - scaledLoopLength) // LoopIndexScaleFactor) + 1]]. - - m _ scaledIndex bitAnd: LoopIndexFractionMask. - rightVal _ leftVal _ - (((leftSamples at: sampleIndex) * (LoopIndexScaleFactor - m)) + - ((leftSamples at: nextSampleIndex) * m)) // LoopIndexScaleFactor. - isInStereo ifTrue: [ - rightVal _ - (((rightSamples at: sampleIndex) * (LoopIndexScaleFactor - m)) + - ((rightSamples at: nextSampleIndex) * m)) // LoopIndexScaleFactor]. - - leftVol > 0 ifTrue: [ - s _ (aSoundBuffer at: i) + ((compositeLeftVol * leftVal) // ScaleFactor). - s > 32767 ifTrue: [s _ 32767]. "clipping!!" - s < -32767 ifTrue: [s _ -32767]. "clipping!!" - aSoundBuffer at: i put: s]. - i _ i + 1. - rightVol > 0 ifTrue: [ - s _ (aSoundBuffer at: i) + ((compositeRightVol * rightVal) // ScaleFactor). - s > 32767 ifTrue: [s _ 32767]. "clipping!!" - s < -32767 ifTrue: [s _ -32767]. "clipping!!" - aSoundBuffer at: i put: s]. - i _ i + 1. - - scaledVolIncr ~= 0 ifTrue: [ "update volume envelope if it is changing" - scaledVol _ scaledVol + scaledVolIncr. - ((scaledVolIncr > 0 and: [scaledVol >= scaledVolLimit]) or: - [scaledVolIncr < 0 and: [scaledVol <= scaledVolLimit]]) - ifTrue: [ "reached the limit; stop incrementing" - scaledVol _ scaledVolLimit. - scaledVolIncr _ 0]. - compositeLeftVol _ (leftVol * scaledVol) // ScaleFactor. - compositeRightVol _ (rightVol * scaledVol) // ScaleFactor]]. - - count _ count - n. -! ! -!LoopedSampledSound methodsFor: 'disk i/o' stamp: 'tk 9/25/2000 12:06'! - objectForDataStream: refStrm - "Answer an object to store on a data stream, a copy of myself whose SampleBuffers have been converted into ByteArrays." - - refStrm replace: leftSamples with: leftSamples asByteArray. - refStrm replace: rightSamples with: rightSamples asByteArray. - "substitution will be made in DataStream nextPut:" - ^ self -! ! -!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 10/14/1998 16:26'! -originalSamplingRate - - ^ originalSamplingRate -! ! -!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:54'! - perceivedPitch - - ^ perceivedPitch -! ! -!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/17/1998 09:08'! - pitch - - ^ (scaledIndexIncr asFloat * perceivedPitch * self samplingRate asFloat) / - (originalSamplingRate * FloatLoopIndexScaleFactor) -! ! -!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/18/1998 11:38'! - pitch: p - - scaledIndexIncr _ - ((p asFloat * originalSamplingRate * FloatLoopIndexScaleFactor) / - (perceivedPitch * self samplingRate asFloat)) asInteger. - - sampleCountForRelease > 0 - ifTrue: [releaseCount _ (sampleCountForRelease * LoopIndexScaleFactor) // scaledIndexIncr] - ifFalse: [releaseCount _ 0]. -! ! -!LoopedSampledSound methodsFor: 'sound generation' stamp: 'jm 8/17/1998 09:38'! - reset - - super reset. - count _ initialCount. - scaledIndex _ firstSample * LoopIndexScaleFactor. -! ! -!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 7/13/1998 11:46'! - rightSamples - - ^ rightSamples -! ! -!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 7/13/1998 11:46'! - rightSamples: aSampleBuffer - - rightSamples _ aSampleBuffer. -! ! -!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 3/15/1999 08:01'! - samples - "For compatability with SampledSound. Just return my left channel (which is the only channel if I am mono)." - - ^ leftSamples -! ! -!LoopedSampledSound methodsFor: 'initialization' stamp: 'jm 7/9/1999 22:28'! - samples: aSoundBuffer loopEnd: loopEndIndex loopLength: loopSampleCount pitch: perceivedPitchInHz samplingRate: samplingRateInHz - "Make this sound use the given samples array with a loop of the given length starting at the given index. The loop length may have a fractional part; this is necessary to achieve pitch accuracy for short loops." - - | loopStartIndex | - super initialize. - loopStartIndex _ (loopEndIndex - loopSampleCount) truncated + 1. - ((1 <= loopStartIndex) and: - [loopStartIndex < loopEndIndex and: - [loopEndIndex <= aSoundBuffer size]]) - ifFalse: [self error: 'bad loop parameters']. - - leftSamples _ rightSamples _ aSoundBuffer. - originalSamplingRate _ samplingRateInHz asFloat. - perceivedPitch _ perceivedPitchInHz asFloat. - gain _ 1.0. - firstSample _ 1. - lastSample _ leftSamples size. - lastSample >= (SmallInteger maxVal // LoopIndexScaleFactor) ifTrue: [ - self error: 'cannot handle more than ', - (SmallInteger maxVal // LoopIndexScaleFactor) printString, ' samples']. - loopEnd _ loopEndIndex. - scaledLoopLength _ (loopSampleCount * LoopIndexScaleFactor) asInteger. - scaledIndexIncr _ (samplingRateInHz * LoopIndexScaleFactor) // self samplingRate. - self computeSampleCountForRelease. -! ! -!LoopedSampledSound methodsFor: 'sound generation' stamp: 'jm 8/18/1998 09:31'! - samplesRemaining - "Answer the number of samples remaining until the end of this sound." - - ^ count -! ! -!LoopedSampledSound methodsFor: 'initialization' stamp: 'jm 7/6/1998 17:09'! - setPitch: pitchNameOrNumber dur: d loudness: vol - "(LoopedSampledSound pitch: 440.0 dur: 2.5 loudness: 0.4) play" - - super setPitch: pitchNameOrNumber dur: d loudness: vol. - self pitch: (self nameOrNumberToPitch: pitchNameOrNumber). - self reset. -! ! -!LoopedSampledSound methodsFor: 'sound generation' stamp: 'jm 9/9/1998 21:57'! - stopAfterMSecs: mSecs - "Terminate this sound this note after the given number of milliseconds." - - count _ (mSecs * self samplingRate) // 1000. -! ! -!LoopedSampledSound methodsFor: 'file i/o' stamp: 'jmv 2/26/2016 16:05'! - storeSampleCount: samplesToStore bigEndian: bigEndianFlag on: aBinaryStream - "Store my samples on the given stream at the current SoundPlayer sampling rate. If bigFlag is true, then each 16-bit sample is stored most-significant byte first (AIFF files), otherwise it is stored least-significant byte first (WAV files)." - - (self isStereo or: [self samplingRate ~= originalSamplingRate]) ifTrue: [ - ^ super storeSampleCount: samplesToStore bigEndian: bigEndianFlag on: aBinaryStream]. - - "optimization: if I'm not stereo and sampling rates match, just store my buffer" - (aBinaryStream isKindOf: StandardFileStream) - ifTrue: [ "optimization for files: write sound buffer directly to file" - aBinaryStream next: (leftSamples size // 2) putAll: leftSamples startingAt: 1] "size in words" - ifFalse: [ "for non-file streams:" - 1 to: leftSamples monoSampleCount do: [:i | aBinaryStream nextSignedInt16Put: (leftSamples at: i) bigEndian: bigEndianFlag ]]! ! -!LoopedSampledSound methodsFor: 'initialization' stamp: 'jm 7/9/1999 22:28'! - unloopedSamples: aSoundBuffer pitch: perceivedPitchInHz samplingRate: samplingRateInHz - "Make this sound play the given samples unlooped. The samples have the given perceived pitch when played at the given sampling rate. By convention, unpitched sounds such as percussion sounds should specify a pitch of nil or 100 Hz." - - super initialize. - leftSamples _ rightSamples _ aSoundBuffer. - originalSamplingRate _ samplingRateInHz asFloat. - perceivedPitchInHz - ifNil: [perceivedPitch _ 100.0] - ifNotNil: [perceivedPitch _ perceivedPitchInHz asFloat]. - gain _ 1.0. - firstSample _ 1. - lastSample _ leftSamples size. - lastSample >= (SmallInteger maxVal // LoopIndexScaleFactor) ifTrue: [ - self error: 'cannot handle more than ', - (SmallInteger maxVal // LoopIndexScaleFactor) printString, ' samples']. - loopEnd _ leftSamples size. - scaledLoopLength _ 0. "zero length means unlooped" - scaledIndexIncr _ (samplingRateInHz * LoopIndexScaleFactor) // self samplingRate. - self computeSampleCountForRelease. -! ! -!LoopedSampledSound class methodsFor: 'instance creation'! - fromAIFFFileNamed: fileName mergeIfStereo: mergeFlag - "Initialize this sound from the data in the given AIFF file. If mergeFlag is true and the file is stereo, its left and right channels are mixed together to produce a mono sampled sound." - - | aiffFileReader | - aiffFileReader _ AIFFFileReader new. - aiffFileReader readFromFile: fileName - mergeIfStereo: mergeFlag - skipDataChunk: false. - self new fromAIFFFileReader: aiffFileReader mergeIfStereo: mergeFlag! ! -!LoopedSampledSound class methodsFor: 'class initialization' stamp: 'jm 8/13/1998 12:54'! - initialize - "LoopedSampledSound initialize" - - LoopIndexScaleFactor _ 512. - FloatLoopIndexScaleFactor _ LoopIndexScaleFactor asFloat. - LoopIndexFractionMask _ LoopIndexScaleFactor - 1. -! ! -!LoopedSampledSound class methodsFor: 'instance creation' stamp: 'jm 8/18/1998 07:40'! - samples: aSoundBuffer loopEnd: loopEndIndex loopLength: loopSampleCount pitch: perceivedPitchInHz samplingRate: samplingRateInHz - "See the comment in the instance method of this name." - - ^ self basicNew - samples: aSoundBuffer - loopEnd: loopEndIndex - loopLength: loopSampleCount - pitch: perceivedPitchInHz - samplingRate: samplingRateInHz -! ! -!LoopedSampledSound class methodsFor: 'instance creation' stamp: 'jm 8/18/1998 07:41'! - unloopedSamples: aSoundBuffer pitch: perceivedPitchInHz samplingRate: samplingRateInHz - "See the comment in the instance method of this name." - - ^ self basicNew - unloopedSamples: aSoundBuffer - pitch: perceivedPitchInHz - samplingRate: samplingRateInHz -! ! -!MixedSound methodsFor: 'composition'! - + aSound - "Return the mix of the receiver and the argument sound." - - ^ self add: aSound -! ! -!MixedSound methodsFor: 'composition' stamp: 'jm 1/5/98 13:47'! - add: aSound - "Add the given sound with a pan setting of centered and no attenuation." - - self add: aSound pan: 0.5 volume: 1.0. -! ! -!MixedSound methodsFor: 'composition' stamp: 'jm 1/5/98 13:47'! - add: aSound pan: leftRightPan - "Add the given sound with the given left-right panning and no attenuation." - - self add: aSound pan: leftRightPan volume: 1.0. -! ! -!MixedSound methodsFor: 'composition' stamp: 'jm 1/5/98 17:33'! - add: aSound pan: leftRightPan volume: volume - "Add the given sound with the given left-right pan, where 0.0 is full left, 1.0 is full right, and 0.5 is centered. The loudness of the sound will be scaled by volume, which ranges from 0 to 1.0." - - | pan vol | - pan _ ((leftRightPan * ScaleFactor) asInteger max: 0) min: ScaleFactor. - vol _ ((volume * ScaleFactor) asInteger max: 0) min: ScaleFactor. - sounds _ sounds copyWith: aSound. - leftVols _ leftVols copyWith: ((ScaleFactor - pan) * vol) // ScaleFactor. - rightVols _ rightVols copyWith: (pan * vol) // ScaleFactor. -! ! -!MixedSound methodsFor: 'copying' stamp: 'jm 12/15/97 22:33'! - copySounds - "Private!! Support for copying. Copy my component sounds and settings array." - - sounds _ sounds collect: [:s | s copy]. - leftVols _ leftVols copy. - rightVols _ rightVols copy. -! ! -!MixedSound methodsFor: 'sound generation' stamp: 'jm 11/25/97 13:40'! - doControl - - super doControl. - 1 to: sounds size do: [:i | (sounds at: i) doControl]. -! ! -!MixedSound methodsFor: 'accessing' stamp: 'jm 8/17/1998 14:05'! - duration - "Answer the duration of this sound in seconds." - - | dur | - dur _ 0. - sounds do: [:snd | dur _ dur max: snd duration]. - ^ dur -! ! -!MixedSound methodsFor: 'initialization' stamp: 'jmv 12/2/2011 10:48'! - initialize - - super initialize. - sounds _ #(). - leftVols _ #(). - rightVols _ #()! ! -!MixedSound methodsFor: 'accessing' stamp: 'jm 12/16/2001 20:23'! - isStereo - - ^ true -! ! -!MixedSound methodsFor: 'sound generation' stamp: 'jm 1/5/98 13:42'! - mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol - "Play a number of sounds concurrently. The level of each sound can be set independently for the left and right channels." - - | snd left right | - 1 to: sounds size do: [:i | - (soundDone at: i) ifFalse: [ - snd _ sounds at: i. - left _ (leftVol * (leftVols at: i)) // ScaleFactor. - right _ (rightVol * (rightVols at: i)) // ScaleFactor. - snd samplesRemaining > 0 - ifTrue: [ - snd mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: left rightVol: right] - ifFalse: [soundDone at: i put: true]]]. -! ! -!MixedSound methodsFor: 'copying' stamp: 'jmv 5/14/2015 09:57'! - postCopy - "Copy my component sounds." - - super postCopy. - self copySounds! ! -!MixedSound methodsFor: 'sound generation' stamp: 'jm 12/8/97 17:07'! - reset - - super reset. - sounds do: [:snd | snd reset]. - soundDone _ (Array new: sounds size) atAllPut: false. -! ! -!MixedSound methodsFor: 'sound generation' stamp: 'jm 12/8/97 17:08'! - samplesRemaining - - | remaining r | - remaining _ 0. - 1 to: sounds size do: [:i | - r _ (sounds at: i) samplesRemaining. - r > remaining ifTrue: [remaining _ r]]. - - ^ remaining -! ! -!MixedSound methodsFor: 'accessing' stamp: 'jm 2/4/98 13:37'! - sounds - - ^ sounds -! ! -!MixedSound methodsFor: 'sound generation' stamp: 'jm 1/10/1999 08:45'! - stopGracefully - "End this note with a graceful decay. If the note has envelopes, determine the decay time from its envelopes." - - super stopGracefully. - sounds do: [:s | s stopGracefully]. -! ! -!PluckedSound methodsFor: 'copying' stamp: 'jm 11/4/97 08:25'! - copyRing - "Private!! Support for copying" - - ring _ ring copy. -! ! -!PluckedSound methodsFor: 'accessing' stamp: 'jm 8/17/1998 14:07'! - duration - "Answer the duration of this sound in seconds." - - ^ initialCount asFloat / self samplingRate -! ! -!PluckedSound methodsFor: 'accessing' stamp: 'jm 9/11/1998 15:40'! - duration: seconds - - super duration: seconds. - count _ initialCount _ (seconds * self samplingRate) rounded. -! ! -!PluckedSound methodsFor: 'sound generation' stamp: 'ar 2/3/2001 15:23'! - mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol - "The Karplus-Strong plucked string algorithm: start with a buffer full of random noise and repeatedly play the contents of that buffer while averaging adjacent samples. High harmonics damp out more quickly, transfering their energy to lower ones. The length of the buffer corresponds to the length of the string." - "(PluckedSound pitch: 220.0 dur: 6.0 loudness: 0.8) play" - - | lastIndex scaledThisIndex scaledNextIndex average sample i s | - - self var: #aSoundBuffer declareC: 'short int *aSoundBuffer'. - self var: #ring declareC: 'short int *ring'. - - lastIndex _ (startIndex + n) - 1. - scaledThisIndex _ scaledNextIndex _ scaledIndex. - startIndex to: lastIndex do: [:sliceIndex | - scaledNextIndex _ scaledThisIndex + scaledIndexIncr. - scaledNextIndex >= scaledIndexLimit - ifTrue: [scaledNextIndex _ ScaleFactor + (scaledNextIndex - scaledIndexLimit)]. - average _ - ((ring at: scaledThisIndex // ScaleFactor) + - (ring at: scaledNextIndex // ScaleFactor)) // 2. - ring at: scaledThisIndex // ScaleFactor put: average. - sample _ (average * scaledVol) // ScaleFactor. "scale by volume" - scaledThisIndex _ scaledNextIndex. - - leftVol > 0 ifTrue: [ - i _ (2 * sliceIndex) - 1. - s _ (aSoundBuffer at: i) + ((sample * leftVol) // ScaleFactor). - s > 32767 ifTrue: [s _ 32767]. "clipping!!" - s < -32767 ifTrue: [s _ -32767]. "clipping!!" - aSoundBuffer at: i put: s]. - rightVol > 0 ifTrue: [ - i _ 2 * sliceIndex. - s _ (aSoundBuffer at: i) + ((sample * rightVol) // ScaleFactor). - s > 32767 ifTrue: [s _ 32767]. "clipping!!" - s < -32767 ifTrue: [s _ -32767]. "clipping!!" - aSoundBuffer at: i put: s]. - - scaledVolIncr ~= 0 ifTrue: [ - scaledVol _ scaledVol + scaledVolIncr. - ((scaledVolIncr > 0 and: [scaledVol >= scaledVolLimit]) or: - [scaledVolIncr < 0 and: [scaledVol <= scaledVolLimit]]) - ifTrue: [ "reached the limit; stop incrementing" - scaledVol _ scaledVolLimit. - scaledVolIncr _ 0]]]. - - scaledIndex _ scaledNextIndex. - count _ count - n. -! ! -!PluckedSound methodsFor: 'copying' stamp: 'jmv 5/14/2015 09:56'! - postCopy - - super postCopy. - self copyRing -! ! -!PluckedSound methodsFor: 'sound generation' stamp: 'jm 12/17/97 21:35'! - reset - "Fill the ring with random noise." - - | seed n | - super reset. - seed _ 17. - n _ ring monoSampleCount. - 1 to: n do: [:i | - seed _ ((seed * 1309) + 13849) bitAnd: 65535. - ring at: i put: seed - 32768]. - count _ initialCount. - scaledIndex _ ScaleFactor. -! ! -!PluckedSound methodsFor: 'sound generation' stamp: 'jm 11/26/97 10:51'! - samplesRemaining - - ^ count -! ! -!PluckedSound methodsFor: 'initialization' stamp: 'jm 7/6/1998 17:09'! - setPitch: pitchNameOrNumber dur: d loudness: vol - - | p sz | - super setPitch: pitchNameOrNumber dur: d loudness: vol. - p _ self nameOrNumberToPitch: pitchNameOrNumber. - initialCount _ (d * self samplingRate asFloat) asInteger. - ring _ SoundBuffer newMonoSampleCount: - (((2.0 * self samplingRate) / p) asInteger max: 2). - sz _ ring monoSampleCount. - scaledIndexLimit _ (sz + 1) * ScaleFactor. - scaledIndexIncr _ (p * sz * ScaleFactor) // (2.0 * self samplingRate). - self reset. -! ! -!PluckedSound methodsFor: 'sound generation' stamp: 'jm 9/9/1998 21:58'! - stopAfterMSecs: mSecs - "Terminate this sound this note after the given number of milliseconds." - - count _ (mSecs * self samplingRate) // 1000. -! ! -!PluckedSound class methodsFor: 'instruments' stamp: 'jm 1/31/98 16:32'! - default - "PluckedSound default play" - "(AbstractSound majorScaleOn: PluckedSound default) play" - - | snd p env | - snd _ PluckedSound new. - p _ OrderedCollection new. - p add: 0@1.0; add: 10@1.0; add: 20@0.0. - env _ VolumeEnvelope points: p loopStart: 2 loopEnd: 2. - env target: snd; scale: 0.3. - ^ snd - addEnvelope: env; - setPitch: 220 dur: 3.0 loudness: 0.3 -! ! -!QueueSound methodsFor: 'accessing' stamp: 'len 8/29/1999 21:52'! - add: aSound - self sounds nextPut: aSound. - ^ aSound! ! -!QueueSound methodsFor: 'accessing' stamp: 'jmv 3/2/2010 16:24'! - currentSound - currentSound ifNil: [currentSound _ self nextSound]. - ^ currentSound! ! -!QueueSound methodsFor: 'accessing' stamp: 'len 8/29/1999 22:07'! - currentSound: aSound - currentSound _ aSound! ! -!QueueSound methodsFor: 'sound generation' stamp: 'jmv 3/2/2010 17:13'! - doControl - super doControl. - self currentSound ifNotNil: [self currentSound doControl]! ! -!QueueSound methodsFor: 'accessing' stamp: 'len 8/29/1999 22:07'! - done: aBoolean - done _ aBoolean! ! -!QueueSound methodsFor: 'initialization' stamp: 'jmv 4/17/2013 12:08'! - initialize - super initialize. - sounds _ SharedQueue new. - done _ false. - startTime _ Time localMillisecondClock! ! -!QueueSound methodsFor: 'sound generation' stamp: 'jmv 4/17/2013 12:08'! - mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol - "Play a collection of sounds in sequence." - - | finalIndex i remaining count rate | - self currentSound ifNil: [^ self]. "already done" - self startTime > Time localMillisecondClock ifTrue: [^ self]. - rate _ self samplingRate. - finalIndex _ (startIndex + n) - 1. - i _ startIndex. - [i <= finalIndex] whileTrue: [ - [ - self currentSound ifNil: [^ self]. - (remaining _ self currentSound samplesRemaining) <= 0] - whileTrue: [self currentSound: self nextSound]. - count _ (finalIndex - i) + 1. - remaining < count ifTrue: [count _ remaining]. - self currentSound mixSampleCount: count into: aSoundBuffer startingAt: i leftVol: leftVol rightVol: rightVol. - i _ i + count]! ! -!QueueSound methodsFor: 'sound generation' stamp: 'len 11/30/1999 04:13'! - nextSound - | answer | - sounds isEmpty ifTrue: [^ nil]. - answer _ sounds next. - answer reset. - ^ answer! ! -!QueueSound methodsFor: 'sound generation' stamp: 'jmv 3/2/2010 17:13'! - reset - super reset. - self currentSound - ifNotNil: [ self currentSound reset] - ifNil: [ self currentSound: self nextSound]! ! -!QueueSound methodsFor: 'sound generation' stamp: 'len 8/29/1999 22:13'! - samplesRemaining - (done and: [self sounds isEmpty]) - ifTrue: [^ 0] - ifFalse: [^ 1000000]. -! ! -!QueueSound methodsFor: 'accessing' stamp: 'len 8/29/1999 21:46'! - sounds - ^ sounds! ! -!QueueSound methodsFor: 'accessing' stamp: 'len 9/26/1999 17:19'! - startTime - ^ startTime! ! -!QueueSound methodsFor: 'accessing' stamp: 'len 9/26/1999 17:19'! - startTime: anInteger - startTime _ anInteger! ! -!RepeatingSound methodsFor: 'copying' stamp: 'jm 12/15/97 22:34'! - copySound - "Private!! Support for copying. Copy my component sound." - - sound _ sound copy. -! ! -!RepeatingSound methodsFor: 'sound generation' stamp: 'jm 11/25/97 13:40'! - doControl - - super doControl. - sound doControl. -! ! -!RepeatingSound methodsFor: 'accessing' stamp: 'jm 11/17/97 18:48'! - iterationCount - - ^ iterationCount -! ! -!RepeatingSound methodsFor: 'accessing' stamp: 'jm 11/17/97 18:48'! - iterationCount: aNumber - - iterationCount _ aNumber. -! ! -!RepeatingSound methodsFor: 'sound generation' stamp: 'jm 11/24/97 16:05'! - mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol - "Play a collection of sounds in sequence." - "(RepeatingSound new - setSound: FMSound majorScale - iterations: 2) play" - - | i count samplesNeeded | - iteration <= 0 ifTrue: [^ self]. - i _ startIndex. - samplesNeeded _ n. - [samplesNeeded > 0] whileTrue: [ - count _ sound samplesRemaining min: samplesNeeded. - count = 0 ifTrue: [ - iterationCount == #forever - ifFalse: [ - iteration _ iteration - 1. - iteration <= 0 ifTrue: [^ self]]. "done" - sound reset. - count _ sound samplesRemaining min: samplesNeeded. - count = 0 ifTrue: [^ self]]. "zero length sound" - sound mixSampleCount: count - into: aSoundBuffer - startingAt: i - leftVol: leftVol - rightVol: rightVol. - i _ i + count. - samplesNeeded _ samplesNeeded - count]. -! ! -!RepeatingSound methodsFor: 'copying' stamp: 'jmv 5/14/2015 09:58'! - postCopy - "Copy my component sound." - - super postCopy. - self copySound -! ! -!RepeatingSound methodsFor: 'sound generation' stamp: 'jm 6/30/1998 18:28'! - reset - - super reset. - sound reset. - samplesPerIteration _ sound samplesRemaining. - iterationCount == #forever - ifTrue: [iteration _ 1] - ifFalse: [iteration _ iterationCount]. -! ! -!RepeatingSound methodsFor: 'sound generation' stamp: 'jm 1/18/1999 10:31'! - samplesRemaining - - iterationCount == #forever ifTrue: [^ 1000000]. - iteration > 0 - ifTrue: [^ sound samplesRemaining + ((iteration - 1) * samplesPerIteration)] - ifFalse: [^ 0]. -! ! -!RepeatingSound methodsFor: 'initialization' stamp: 'jm 9/12/97 15:54'! - setPitch: p dur: d loudness: l - - self error: 'RepeatingSounds do not support playing notes'. -! ! -!RepeatingSound methodsFor: 'initialization' stamp: 'jm 9/12/97 16:39'! - setSound: aSound iterations: anIntegerOrSymbol - "Initialize the receiver to play the given sound the given number of times. If iteration count is the symbol #forever, then repeat indefinitely." - "(RepeatingSound repeat: AbstractSound scaleTest count: 2) play" - "(RepeatingSound repeatForever: PluckedSound lowMajorScale) play" - - super initialize. - sound _ aSound. - iterationCount _ anIntegerOrSymbol. - self reset. -! ! -!RepeatingSound methodsFor: 'accessing' stamp: 'jm 11/17/97 18:48'! - sound - - ^ sound -! ! -!RepeatingSound methodsFor: 'accessing' stamp: 'jm 12/15/97 22:39'! - sound: aSound - - sound _ aSound. -! ! -!RepeatingSound class methodsFor: 'instance creation' stamp: 'jm 9/12/97 16:14'! - repeat: aSound count: anInteger - "Return a RepeatingSound that will repeat the given sound for the given number of iterations." - - ^ self new setSound: aSound iterations: anInteger -! ! -!RepeatingSound class methodsFor: 'instance creation' stamp: 'jm 9/12/97 16:13'! - repeatForever: aSound - "Return a RepeatingSound that will repeat the given sound forever." - - ^ self new setSound: aSound iterations: #forever -! ! -!RestSound methodsFor: 'accessing' stamp: 'jm 8/17/1998 14:07'! - duration - "Answer the duration of this sound in seconds." - - ^ initialCount asFloat / self samplingRate -! ! -!RestSound methodsFor: 'accessing' stamp: 'jm 9/11/1998 15:42'! - duration: seconds - - super duration: seconds. - count _ initialCount _ (seconds * self samplingRate) rounded. -! ! -!RestSound methodsFor: 'sound generation' stamp: 'jm 11/24/97 16:04'! - mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol - "Play silence for a given duration." - "(RestSound dur: 1.0) play" - - count _ count - n. -! ! -!RestSound methodsFor: 'sound generation'! - reset - - super reset. - count _ initialCount. -! ! -!RestSound methodsFor: 'accessing' stamp: 'di 2/17/1999 21:09'! - samples - ^ SoundBuffer newMonoSampleCount: initialCount! ! -!RestSound methodsFor: 'sound generation' stamp: 'jm 12/15/97 22:37'! - samplesRemaining - - ^ count -! ! -!RestSound methodsFor: 'initialization' stamp: 'jm 1/28/98 13:08'! - setDur: d - "Set rest duration in seconds." - - initialCount _ (d * self samplingRate asFloat) rounded. - count _ initialCount. - self reset. -! ! -!RestSound class methodsFor: 'instance creation' stamp: 'jm 3/31/1999 21:05'! - dur: d - "Return a rest of the given duration." - - ^ self new setDur: d -! ! -!RestSound class methodsFor: 'instance creation' stamp: 'jm 12/15/97 22:38'! - pitch: p dur: d loudness: l - "Return a rest of the given duration." - "Note: This message allows one to silence one or more voices of a multi-voice piece by using RestSound as their instrument." - - ^ self new setDur: d -! ! -!ReverbSound methodsFor: 'private' stamp: 'ar 2/3/2001 15:55'! - applyReverbTo: aSoundBuffer startingAt: startIndex count: n - - | delayedLeft delayedRight i tapGain j out | - - self var: #aSoundBuffer declareC: 'short int *aSoundBuffer'. - self var: #tapDelays declareC: 'int *tapDelays'. - self var: #tapGains declareC: 'int *tapGains'. - self var: #leftBuffer declareC: 'short int *leftBuffer'. - self var: #rightBuffer declareC: 'short int *rightBuffer'. - - startIndex to: ((startIndex + n) - 1) do: [:sliceIndex | - delayedLeft _ delayedRight _ 0. - 1 to: tapCount do: [:tapIndex | - i _ bufferIndex - (tapDelays at: tapIndex). - i < 1 ifTrue: [i _ i + bufferSize]. "wrap" - tapGain _ tapGains at: tapIndex. - delayedLeft _ delayedLeft + (tapGain * (leftBuffer at: i)). - delayedRight _ delayedRight + (tapGain * (rightBuffer at: i))]. - - "left channel" - j _ (2 * sliceIndex) - 1. - out _ (aSoundBuffer at: j) + (delayedLeft // ScaleFactor). - out > 32767 ifTrue: [out _ 32767]. "clipping!!" - out < -32767 ifTrue: [out _ -32767]. "clipping!!" - aSoundBuffer at: j put: out. - leftBuffer at: bufferIndex put: out. - - "right channel" - j _ j + 1. - out _ (aSoundBuffer at: j) + (delayedRight // ScaleFactor). - out > 32767 ifTrue: [out _ 32767]. "clipping!!" - out < -32767 ifTrue: [out _ -32767]. "clipping!!" - aSoundBuffer at: j put: out. - rightBuffer at: bufferIndex put: out. - - bufferIndex _ (bufferIndex \\ bufferSize) + 1]. -! ! -!ReverbSound methodsFor: 'copying' stamp: 'jmv 5/14/2015 09:53'! - copySound - "Private!! Support for copying. Copy my component sound." - - sound _ sound copy. - leftBuffer _ leftBuffer copy. - rightBuffer _ rightBuffer copy. -! ! -!ReverbSound methodsFor: 'sound generation' stamp: 'jm 1/21/98 14:32'! - doControl - - super doControl. - sound doControl. -! ! -!ReverbSound methodsFor: 'sound generation' stamp: 'jm 1/21/98 15:00'! - mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol - "Play my sound with reberberation." - - sound mixSampleCount: n - into: aSoundBuffer - startingAt: startIndex - leftVol: leftVol - rightVol: rightVol. - self applyReverbTo: aSoundBuffer startingAt: startIndex count: n. -! ! -!ReverbSound methodsFor: 'copying' stamp: 'jmv 5/14/2015 09:58'! - postCopy - "Copy my component sound." - - super postCopy. - self copySound -! ! -!ReverbSound methodsFor: 'sound generation' stamp: 'jm 1/21/98 16:47'! - reset - - super reset. - sound reset. - 1 to: bufferSize do: [:i | - leftBuffer at: i put: 0. - rightBuffer at: i put: 0]. -! ! -!ReverbSound methodsFor: 'sound generation' stamp: 'jm 1/21/98 17:02'! - samplesRemaining - - ^ sound samplesRemaining -! ! -!ReverbSound methodsFor: 'accessing' stamp: 'jm 1/7/98 22:41'! - sound - - ^ sound -! ! -!ReverbSound methodsFor: 'accessing' stamp: 'jm 1/7/98 22:42'! - sound: aSound - - sound _ aSound. -! ! -!ReverbSound methodsFor: 'accessing' stamp: 'jm 1/27/98 19:10'! - tapDelays: delayList gains: gainList - "ReverbSound new tapDelays: #(537 691 1191) gains: #(0.07 0.07 0.07)" - - | maxDelay gain d | - delayList size = gainList size - ifFalse: [self error: 'tap delay and gains lists must be the same size']. - tapCount _ delayList size. - tapDelays _ Bitmap new: tapCount. - tapGains _ Bitmap new: tapCount. - - maxDelay _ 0. - 1 to: tapGains size do: [:i | - tapDelays at: i put: (delayList at: i) asInteger. - gain _ gainList at: i. - gain >= 1.0 ifTrue: [self error: 'reverb tap gains must be under 1.0']. - tapGains at: i put: (gain * ScaleFactor) asInteger. - d _ tapDelays at: i. - d > maxDelay ifTrue: [maxDelay _ d]]. - bufferSize _ maxDelay. - leftBuffer _ SoundBuffer newMonoSampleCount: maxDelay. - rightBuffer _ SoundBuffer newMonoSampleCount: maxDelay. - bufferIndex _ 1. -! ! -!SampledSound methodsFor: 'accessing' stamp: 'di 12/7/2000 16:04'! - compressWith: codecClass - ^ codecClass new compressSound: self! ! -!SampledSound methodsFor: 'accessing' stamp: 'RAA 12/24/2000 08:49'! - compressWith: codecClass atRate: aSamplingRate - - ^ codecClass new compressSound: self atRate: aSamplingRate! ! -!SampledSound methodsFor: 'accessing' stamp: 'jm 3/28/98 05:46'! - duration - - ^ initialCount asFloat / self samplingRate asFloat -! ! -!SampledSound methodsFor: 'accessing' stamp: 'jm 9/11/1998 15:39'! - duration: seconds - - super duration: seconds. - count _ initialCount _ (seconds * self samplingRate) rounded. -! ! -!SampledSound methodsFor: 'playing' stamp: 'di 10/28/2000 17:08'! - endGracefully - "See stopGracefully, which affects initialCOunt, and I don't think it should (di)." - - | decayInMs env | - envelopes isEmpty - ifTrue: [ - self adjustVolumeTo: 0 overMSecs: 10. - decayInMs _ 10] - ifFalse: [ - env _ envelopes first. - decayInMs _ env attackTime + env decayTime]. - count _ decayInMs * self samplingRate // 1000. -! ! -!SampledSound methodsFor: 'playing' stamp: 'ar 2/3/2001 15:23'! - mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol - "Mix the given number of samples with the samples already in the given buffer starting at the given index. Assume that the buffer size is at least (index + count) - 1." - - | lastIndex outIndex sampleIndex sample i s overflow | - - self var: #aSoundBuffer declareC: 'short int *aSoundBuffer'. - self var: #samples declareC: 'short int *samples'. - - lastIndex _ (startIndex + n) - 1. - outIndex _ startIndex. "index of next stereo output sample pair" - sampleIndex _ indexHighBits + (scaledIndex >> IncrementFractionBits). - [(sampleIndex <= samplesSize) and: [outIndex <= lastIndex]] whileTrue: [ - sample _ ((samples at: sampleIndex) * scaledVol) // ScaleFactor. - leftVol > 0 ifTrue: [ - i _ (2 * outIndex) - 1. - s _ (aSoundBuffer at: i) + ((sample * leftVol) // ScaleFactor). - s > 32767 ifTrue: [s _ 32767]. "clipping!!" - s < -32767 ifTrue: [s _ -32767]. "clipping!!" - aSoundBuffer at: i put: s]. - rightVol > 0 ifTrue: [ - i _ 2 * outIndex. - s _ (aSoundBuffer at: i) + ((sample * rightVol) // ScaleFactor). - s > 32767 ifTrue: [s _ 32767]. "clipping!!" - s < -32767 ifTrue: [s _ -32767]. "clipping!!" - aSoundBuffer at: i put: s]. - - scaledVolIncr ~= 0 ifTrue: [ - scaledVol _ scaledVol + scaledVolIncr. - ((scaledVolIncr > 0 and: [scaledVol >= scaledVolLimit]) or: - [scaledVolIncr < 0 and: [scaledVol <= scaledVolLimit]]) - ifTrue: [ "reached the limit; stop incrementing" - scaledVol _ scaledVolLimit. - scaledVolIncr _ 0]]. - - scaledIndex _ scaledIndex + scaledIncrement. - scaledIndex >= ScaledIndexOverflow ifTrue: [ - overflow _ scaledIndex >> IncrementFractionBits. - indexHighBits _ indexHighBits + overflow. - scaledIndex _ scaledIndex - (overflow << IncrementFractionBits)]. - - sampleIndex _ indexHighBits + (scaledIndex >> IncrementFractionBits). - outIndex _ outIndex + 1]. - count _ count - n. -! ! -!SampledSound methodsFor: 'accessing' stamp: 'jm 12/15/97 22:51'! - originalSamplingRate - - ^ originalSamplingRate -! ! -!SampledSound methodsFor: 'initialization' stamp: 'jm 1/18/1999 06:42'! - pitch: pitchNameOrNumber - - | p | - p _ self nameOrNumberToPitch: pitchNameOrNumber. - originalSamplingRate _ - ((self samplingRate asFloat * p asFloat) / NominalSamplePitch asFloat) asInteger. - self reset. -! ! -!SampledSound methodsFor: 'playing' stamp: 'di 10/28/2000 22:31'! - playSilentlyUntil: startTime - "Used to fast foward to a particular starting time. - Overridden to be instant for sampled sounds." - -"true ifTrue: [^ super playSilentlyUntil: startTime]." - indexHighBits _ (startTime * originalSamplingRate) asInteger. - scaledIndex _ IncrementScaleFactor. - count _ initialCount - (startTime * self samplingRate). - mSecsSinceStart _ (startTime * 1000) asInteger. - -! ! -!SampledSound methodsFor: 'playing' stamp: 'jm 7/9/1999 18:29'! - reset - "Details: The sample index and increment are scaled to allow fractional increments without having to do floating point arithmetic in the inner loop." - - super reset. - scaledIncrement _ - ((originalSamplingRate asFloat / self samplingRate) * IncrementScaleFactor) rounded. - count _ initialCount. - scaledIndex _ IncrementScaleFactor. "index of the first sample, scaled" - indexHighBits _ 0. -! ! -!SampledSound methodsFor: 'accessing' stamp: 'jm 9/12/97 16:46'! - samples - - ^ samples -! ! -!SampledSound methodsFor: 'playing' stamp: 'jm 9/13/97 19:07'! - samplesRemaining - - ^ count -! ! -!SampledSound methodsFor: 'initialization' stamp: 'jm 3/24/1999 12:01'! - setPitch: pitchNameOrNumber dur: d loudness: vol - "Used to play scores using the default sample table." - "(SampledSound pitch: 880.0 dur: 1.5 loudness: 0.6) play" - - | p | - super setPitch: pitchNameOrNumber dur: d loudness: vol. - p _ self nameOrNumberToPitch: pitchNameOrNumber. - samples _ DefaultSampleTable. - samplesSize _ samples size. - initialCount _ (d * self samplingRate asFloat) rounded. - originalSamplingRate _ - ((self samplingRate asFloat * p asFloat) / NominalSamplePitch asFloat) asInteger. - self loudness: vol. - self reset. -! ! -!SampledSound methodsFor: 'initialization' stamp: 'jm 7/9/1999 19:23'! - setSamples: anArray samplingRate: rate - "Set my samples array to the given array with the given nominal sampling rate. Altering the rate parameter allows the sampled sound to be played back at different pitches." - "Note: There are two ways to use sampled sound: (a) you can play them through once (supported by this method) or (b) you can make them the default waveform with which to play a musical score (supported by the class method defaultSampleTable:)." - "Assume: anArray is either a SoundBuffer or a collection of signed 16-bit sample values." - "(SampledSound - samples: SampledSound coffeeCupClink - samplingRate: 5000) play" - - "copy the array into a SoundBuffer if necessary" - anArray class isWords - ifTrue: [samples _ anArray] - ifFalse: [samples _ SoundBuffer fromArray: anArray]. - - samplesSize _ samples size. - samplesSize >= SmallInteger maxVal ifTrue: [ "this is unlikely..." - self error: 'sample count must be under ', SmallInteger maxVal printString]. - originalSamplingRate _ rate. - initialCount _ (samplesSize * self samplingRate) // originalSamplingRate. - self loudness: 1.0. - self reset. -! ! -!SampledSound methodsFor: 'playing' stamp: 'RAA 8/12/2000 15:11'! - setScaledIncrement: aNumber - - scaledIncrement _ (aNumber * IncrementScaleFactor) rounded. - -! ! -!SampledSound methodsFor: 'playing' stamp: 'jm 9/9/1998 21:58'! - stopAfterMSecs: mSecs - "Terminate this sound this note after the given number of milliseconds." - - count _ (mSecs * self samplingRate) // 1000. -! ! -!SampledSound methodsFor: 'file i/o' stamp: 'jmv 2/26/2016 16:05'! - storeSampleCount: samplesToStore bigEndian: bigEndianFlag on: aBinaryStream - "Store my samples on the given stream at the current SoundPlayer sampling rate. If bigFlag is true, then each 16-bit sample is stored most-significant byte first (AIFF files), otherwise it is stored least-significant byte first (WAV files)." - - self samplingRate ~= originalSamplingRate ifTrue: [ - ^ super storeSampleCount: samplesToStore bigEndian: bigEndianFlag on: aBinaryStream]. - - "optimization: if sampling rates match, just store my buffer" - (aBinaryStream isKindOf: StandardFileStream) - ifTrue: [ "optimization for files: write sound buffer directly to file" - aBinaryStream next: (samples size // 2) putAll: samples startingAt: 1] "size in words" - ifFalse: [ "for non-file streams:" - 1 to: samples monoSampleCount do: [:i | aBinaryStream nextSignedInt16Put: (samples at: i) bigEndian: bigEndianFlag ]]! ! -!SampledSound methodsFor: 'sound tracks' stamp: 'jmv 12/4/2012 23:42'! - volumeForm: height from: start to: stop nSamplesPerPixel: nPerPixel - "Note: nPerPixel can be Integer or Float for pixel-perfect alignment." - "In an inspector of a samplesSound... - self currentWorld addMorph: (ImageMorph new image: - (self volumeForm: 32 from: 1 to: samples size nSamplesPerPixel: 225)) - " - | volPlot width sample min max vol | - width _ stop-start//nPerPixel. - volPlot _ Form extent: width@height. - (start max: 1) to: (stop min: samples size)-nPerPixel by: nPerPixel do: - [:i | min _ max _ 0. - i asInteger to: (i+nPerPixel-1) asInteger by: 4 do: "by: 4 makes it faster yet looks the same" - [:j | sample _ samples at: j. - sample < min ifTrue: [min _ sample]. - sample > max ifTrue: [max _ sample]]. - vol _ (max - min) * height // 65536. - volPlot fillBlack: ((i-start//nPerPixel) @ (height-vol//2) extent: 1@(vol+1))]. - ^ volPlot - -! ! -!SampledSound class methodsFor: 'sound library' stamp: 'jmv 6/17/2015 11:26'! - addLibrarySoundNamed: aString fromAIFFfileNamed: fileName - "Add a sound from the given AIFF file to the library." - "SampledSound - addLibrarySoundNamed: 'shutterClick' - fromAIFFfileNamed: '7.aif'" - "Add all .aif files in the current directory to the sound library: - | fileNames | - fileNames _ FileDirectory smalltalkImageDirectory fileNamesMatching: '*.aif'. - fileNames do: [:fName | - SampledSound - addLibrarySoundNamed: (fName copyUpTo: $.) - fromAIFFfileNamed: fName]" - - | snd | - snd _ self fromAIFFfileNamed: fileName. - self addLibrarySoundNamed: aString - samples: snd samples - samplingRate: snd originalSamplingRate. -! ! -!SampledSound class methodsFor: 'sound library' stamp: 'jm 1/14/1999 10:41'! - addLibrarySoundNamed: aString samples: sampleData samplingRate: samplesPerSecond - "Add the given sound to the sound library. The sample data may be either a ByteArray or a SoundBuffer. If the former, it is take to be 8-bit unsigned samples. If the latter, it is taken to be 16 bit signed samples." - - SoundLibrary - at: aString - put: (Array with: sampleData with: samplesPerSecond). -! ! -!SampledSound class methodsFor: 'sound library' stamp: 'sw 4/14/2003 00:01'! - assimilateSoundsFrom: aDictionary - "assimilate sounds with new keys from the given dictionary" - - aDictionary associationsDo: - [:assoc | (SoundLibrary includesKey: assoc key) ifFalse: - [SoundLibrary add: assoc]]! ! -!SampledSound class methodsFor: 'instance creation' stamp: 'gk 2/24/2004 08:50'! - beep - "Beep in the presence of the sound system. - Not to be used directly - use Beeper class>>beep - or Beeper class>>beepPrimitive instead." - - (self new - setSamples: self coffeeCupClink - samplingRate: 12000) play - ! ! -!SampledSound class methodsFor: 'coffee cup clink' stamp: 'jm 8/23/97 22:25'! - coffeeCupClink - "Return the samples array for the sound of a spoon being tapped against a coffee cup." - - CoffeeCupClink ifNil: [self initializeCoffeeCupClink]. - ^ CoffeeCupClink -! ! -!SampledSound class methodsFor: 'utilities' stamp: 'ar 2/3/2001 16:14'! - convert8bitSignedFrom: aByteArray to16Bit: aSoundBuffer - "Copy the contents of the given array of signed 8-bit samples into the given array of 16-bit signed samples." - - | n s | - - self var: #aByteArray declareC: 'unsigned char *aByteArray'. - self var: #aSoundBuffer declareC: 'unsigned short *aSoundBuffer'. - n _ aByteArray size. - 1 to: n do: [:i | - s _ aByteArray at: i. - s > 127 - ifTrue: [aSoundBuffer at: i put: ((s - 256) bitShift: 8)] - ifFalse: [aSoundBuffer at: i put: (s bitShift: 8)]]. -! ! -!SampledSound class methodsFor: 'utilities' stamp: 'jm 2/15/98 18:13'! - convert8bitSignedTo16Bit: aByteArray - "Convert the given array of samples--assumed to be 8-bit signed, linear data--into 16-bit signed samples. Return an array containing the resulting samples. Typically used to read uncompressed AIFF sound data." - - | result | - result _ SoundBuffer newMonoSampleCount: aByteArray size. - self convert8bitSignedFrom: aByteArray to16Bit: result. - ^ result -! ! -!SampledSound class methodsFor: 'utilities' stamp: 'ar 1/27/98 23:11'! - convert8bitUnsignedTo16Bit: anArray - "Convert the given array of samples--assumed to be 8-bit unsigned, linear data--into 16-bit signed samples. Return an array containing the resulting samples. Typically used to read uncompressed WAVE sound data." - - | n samples s | - n _ anArray size. - samples _ SoundBuffer newMonoSampleCount: n. - 1 to: n do: [:i | - s _ anArray at: i. - samples at: i put: (s - 128 * 256)]. - ^ samples -! ! -!SampledSound class methodsFor: 'utilities' stamp: 'jm 3/17/98 21:07'! - convertBytesTo16BitSamples: aByteArray mostSignificantByteFirst: msbFirst - "Convert the given ByteArray (with the given byte ordering) into 16-bit sample buffer." - - | n data src b1 b2 w | - n _ aByteArray size // 2. - data _ SoundBuffer newMonoSampleCount: n. - src _ 1. - 1 to: n do: [:i | - b1 _ aByteArray at: src. - b2 _ aByteArray at: src + 1. - msbFirst - ifTrue: [w _ (b1 bitShift: 8) + b2] - ifFalse: [w _ (b2 bitShift: 8) + b1]. - w > 32767 ifTrue: [w _ w - 65536]. - data at: i put: w. - src _ src + 2]. - ^ data -! ! -!SampledSound class methodsFor: 'default sound' stamp: 'jm 9/17/97 12:49'! - defaultSampleTable: anArray - "Set the sample table to be used as the default waveform for playing a score such as the Bach fugue. Array is assumed to contain monaural signed 16-bit sample values." - - DefaultSampleTable _ SoundBuffer fromArray: anArray. -! ! -!SampledSound class methodsFor: 'default sound' stamp: 'jm 9/17/97 13:10'! - defaultSamples: anArray repeated: n - - | data | - data _ WriteStream on: (SoundBuffer newMonoSampleCount: anArray size * n). - n timesRepeat: [ - anArray do: [:sample | data nextPut: sample truncated]]. - DefaultSampleTable _ data contents. -! ! -!SampledSound class methodsFor: 'instance creation' stamp: 'jmv 6/17/2015 11:26'! - fromAIFFfileNamed: fileName - "Read a SampledSound from the AIFF file of the given name, merging stereo to mono if necessary." - "(SampledSound fromAIFFfileNamed: '1.aif') play" - "| snd | - FileDirectory smalltalkImageDirectory fileNames do: [:n | - (n endsWith: '.aif') - ifTrue: [ - snd _ SampledSound fromAIFFfileNamed: n. - snd play. - SoundPlayer waitUntilDonePlaying: snd]]." - - | aiffFileReader | - aiffFileReader _ AIFFFileReader new. - aiffFileReader readFromFile: fileName - mergeIfStereo: true - skipDataChunk: false. - ^ self - samples: (aiffFileReader channelData at: 1) - samplingRate: aiffFileReader samplingRate -! ! -!SampledSound class methodsFor: 'instance creation' stamp: 'jmv 7/21/2017 16:19:57'! - fromFileEntry: aFileEntry - "(SampledSound fromWaveFileNamed: 'c:\windows\media\chimes.wav') play" - "| snd fd | - fd := FileDirectory on:'c:\windows\media\'. - fd fileNames do: [:n | - (n asLowercase endsWith: '.wav') - ifTrue: [ - snd _ SampledSound fromWaveFileNamed: (fd pathName,n). - snd play. - SoundPlayer waitUntilDonePlaying: snd]]." - - ^ aFileEntry readStreamDo: [ :strm | - self fromWaveStream: strm ] -! ! -!SampledSound class methodsFor: 'instance creation' stamp: 'pb 5/25/2016 01:33'! - fromWaveFileNamed: fileName - "(SampledSound fromWaveFileNamed: 'c:\windows\media\chimes.wav') play" - "| snd fd | - fd := FileDirectory on:'c:\windows\media\'. - fd fileNames do: [:n | - (n asLowercase endsWith: '.wav') - ifTrue: [ - snd _ SampledSound fromWaveFileNamed: (fd pathName,n). - snd play. - SoundPlayer waitUntilDonePlaying: snd]]." - - ^ fileName asFileEntry readStreamDo: [ :strm | - self fromWaveStream: strm ] -! ! -!SampledSound class methodsFor: 'instance creation'! - fromWaveStream: fileStream - - | stream header data type channels samplingRate blockAlign bitsPerSample leftAndRight | - header _ self readWaveChunk: 'fmt ' inRIFF: fileStream. - data _ self readWaveChunk: 'data' inRIFF: fileStream. - fileStream close. - stream _ ReadStream on: header. - type _ self next16BitWord: false from: stream. - type = 1 ifFalse: [^ self error:'Unexpected wave format']. - channels _ self next16BitWord: false from: stream. - (channels < 1 or: [channels > 2]) - ifTrue: [^ self error: 'Unexpected number of wave channels']. - samplingRate _ self next32BitWord: false from: stream. - stream skip: 4. "skip average bytes per second" - blockAlign _ self next16BitWord: false from: stream. - bitsPerSample _ self next16BitWord: false from: stream. - (bitsPerSample = 8 or: [bitsPerSample = 16]) - ifFalse: [ "recompute bits per sample" - bitsPerSample _ (blockAlign // channels) * 8]. - - bitsPerSample = 8 - ifTrue: [data _ self convert8bitUnsignedTo16Bit: data] - ifFalse: [data _ self convertBytesTo16BitSamples: data mostSignificantByteFirst: false]. - - channels = 2 ifTrue: [ - leftAndRight _ data splitStereo. - ^ MixedSound new - add: (self samples: leftAndRight first samplingRate: samplingRate) pan: 0.0; - add: (self samples: leftAndRight last samplingRate: samplingRate) pan: 1.0; - yourself]. - - ^ self samples: data samplingRate: samplingRate -! ! -!SampledSound class methodsFor: 'class initialization' stamp: 'jmv 6/16/2013 12:36'! - initialize - "SampledSound initialize" - - SoundPlayer initialize. - IncrementFractionBits _ 16. - IncrementScaleFactor _ 2 raisedTo: IncrementFractionBits. - ScaledIndexOverflow _ 2 raisedTo: 29. "handle overflow before needing LargePositiveIntegers" - self useCoffeeCupClink. - SoundLibrary ifNil: [SoundLibrary _ Dictionary new]. - Beeper setDefault: (self new - setSamples: self coffeeCupClink - samplingRate: 12000). -! ! -!SampledSound class methodsFor: 'coffee cup clink' stamp: 'jm 9/17/97 12:50'! - initializeCoffeeCupClink - "Initialize the samples array for the sound of a spoon being tapped against a coffee cup." - "SampledSound initializeCoffeeCupClink" - - | samples | - samples _ #(768 1024 -256 2304 -13312 26624 32512 19200 6400 -256 5888 32512 28928 32512 -32768 32512 -32768 18688 26368 -26112 32512 32512 2304 32512 5632 2816 10240 -4608 -1792 32512 32512 -5376 10752 32512 32512 32512 8192 15872 32512 -3584 -32768 -23296 -24832 -32768 -32768 -32768 -2304 32512 32512 -32768 32512 -15360 6400 8448 -18176 -32768 -256 -32768 -29440 9472 20992 17920 32512 32512 -256 32512 -32768 -32768 -23040 -32768 -25088 -32768 -27648 -1536 24320 -32768 32512 20480 27904 22016 16384 -32768 32512 -27648 -32768 -7168 28160 -6400 5376 32512 -256 32512 -7168 -11776 -19456 -27392 -24576 -32768 -24064 -19456 12800 32512 27136 2048 25344 15616 8192 -4608 -28672 -32768 -30464 -2560 17664 256 -8192 8448 32512 27648 -6144 -512 -7424 -18688 7936 -256 -22272 -14080 2048 27648 15616 -12288 -768 5376 3328 5632 3072 -6656 -20480 10240 27136 -10752 -11008 -768 -2048 6144 -7168 -3584 -1024 -7680 19712 26112 1024 -11008 3072 16384 -8960 -14848 -4864 -23808 -11264 12288 8192 7168 4864 23040 32512 512 -11776 -5632 -16896 -21504 -12800 -6144 -16896 -4352 32512 32512 23296 21760 5632 2816 -9472 -20992 -11264 -29440 -32768 -3584 7680 8448 15360 32512 32512 15616 15104 -2048 -27904 -27904 -25600 -12288 -12032 -13568 17152 22272 15360 30208 28160 7680 -5632 -8192 -16384 -31744 -25856 -10752 -3840 6656 13056 24320 26368 12800 20736 12288 -19200 -20992 -16640 -21504 -17920 -6912 8448 11264 14080 23040 18176 8192 -1024 0 256 -20992 -19712 -4608 -11264 -2048 14080 12032 8192 6912 13056 9216 -5632 -5376 -3840 -6656 -9984 -5632 4864 -3584 -1280 17408 7680 -1280 4096 2816 -1024 -4864 3328 8448 -768 -5888 -2048 5120 0 3072 11008 -7680 -15360 2560 6656 -3840 0 11776 7680 2816 1536 -1280 -3840 -8704 -1536 3584 -9728 -9728 11776 18688 7680 6656 6400 -4864 -3840 -256 -6912 -13312 -11264 2304 9728 1792 3328 18944 18432 6912 6144 -1536 -17664 -14336 -2304 -10496 -15616 -4096 9728 17152 14848 13312 11520 2304 -1024 2560 -8704 -26624 -18688 -256 -256 2816 14080 13824 12544 14080 9728 -512 -12032 -8960 -3328 -9984 -15872 -5120 8192 3584 10496 20224 7936 4608 6144 1280 -8704 -12800 -7424 -8448 -8960 -3840 7424 13056 8704 13312 13056 -2304 -4864 -768 -7168 -10496 -4608 -1536 -3072 -1280 6144 13312 11008 4864 4864 1536 -8960 -7680 1792 -4864 -7680 2816 5632 3328 2560 5376 7936 3584 -512 512 -4608 -9728 0 9216 768 -4096 7680 7168 256 4608 -768 -8704 -6400 2048 6144 -3072 -3328 6400 9472 3840 -768 1792 -3840 -5120 6144 768 -9984 -4352 5120 9472 6912 2816 1792 1280 768 512 -2816 -9728 -6912 6912 6912 -3328 -768 8448 11776 10752 3328 -6912 -10752 -8704 -1536 0 -6912 -3328 9984 13568 7424 6144 6656 256 0 256 -12032 -17920 -8192 3584 8960 4096 5632 12032 8704 6912 5632 -3584 -10496 -7936 -2048 -9216 -11776 2304 9472 15104 14848 5888 512 -2816 1024 2560 -9984 -13312 -5120 768 1792 768 8448 12032 11264 12800 -256 -11264 -9728 -2304 3072 -4352 -6912 256 2304 5376 9984 8192 2816 1280 3584 -2048 -11008 -8448 -2048 3072 4864 2304 3072 3072 3072 7168 3328 -5376 -4864 512 512 -1792 -1792 1792 5376 5888 5888 512 -5888 -3584 4096 3584 -6400 -4864 4608 3072 3840 5376 1024 768 2816 5888 -768 -12288 -7936 2304 5888 3328 2048 6144 3072 3072 6400 -3328 -7168 256 4096 -512 -9472 -6656 3328 6912 9216 8704 3840 -2560 -256 6656 -2560 -11264 -4608 -768 -1280 1536 3072 4096 5120 9984 11264 1024 -8192 -6144 -1024 -3840 -5632 -512 1024 2304 9728 9728 1280 512 4096 2816 -3584 -9984 -6912 -2304 512 5632 7680 3584 1024 5632 5888 -1280 -3584 -2304 -2560 -1536 -1024 -1792 -512 1536 7680 9984 2048 -2048 2048 3328 -1280 -4096 -3328 -4608 -1280 4352 3328 1280 1792 5120 6912 1024 -2560 0 -768 -1024 1280 -256 -4608 -1280 6400 5120 768 1792 2560 2048 0 -1536 -1280 -2304 1024 5376 2560 -2560 -512 4096 2048 512 768 -1280 -256 2560 2560 -256 -1024 768 3584 1280 -3328 -1536 1792 2816 3328 2304 -256 256 2816 2304 -1280 -3328 -1536 2304 2304 -256 -256 1024 1536 3840 5120 1024 -2048 0 1536 -768 -2560 -1792 256 2304 2048 1536 256 768 5888 6656 256 -3840 -2304 -1280 -1536 256 0 -512 2304 4352 3840 768 0 2304 3072 256 -3072 -2560 -2560 256 4608 2560 256 1536 3072 3072 1792 256 256 512 -256 -768 -1280 -1536 768 4352 2816 -512 768 2560 2560 2304 -256 -1792 -768 768 1792 256 -2304 -256 3328 3840 2304 2304 1536 256 2048 1024 -1536 -1792 -1024 512 256 -512 0 2304 4864 5120 4352 1024 -1280 0 -768 -2816 -2304 -512 1024 2048 2304 2048 3072 3840 2816 2048 -512 -3072 -1792 -1536 -1280 768 1280 1536 2304 2816 2048 1536 2048 1536 1536 -768 -3840 -2048 0 1280 2816 1792 1536 2560 3584 2816 1024 256 -768 -768 -1280 -2816 -768 1792 3328 5120 3072 1280 1536 1792 768 -1024 -1280 -1536 -768 512 256 1536 2560 2560 3328 1280 0 768 1536 768 -256 -512 -1536 -1280 768 1280 2304 2560 2560 2560 1024 -256 -512 0 1280 1536 768 -1280 -512 2048 1536 2048 1280 -256 256 512 768 768 1280 2304 1792 512 -1280 -1024 768 1536 1536 256 -768 1536 3584 3072 1792 -256 -1536 -512 256 -512 -512 768 2048 2048 1792 1280 1280 3072 2816 768 -1024 -2304 -1024 256 256 1280 1792 2304 2816 2304 1280 512 1024 768 -768 -1280 -1280 -512 1536 2560 2816 2048 512 1024 1792 1280 768 0 -768 -768 0 256 256 1280 2560 2304 2304 1536 512 512 1024 1280 0 -1792 -1536 -512 1280 3072 2816 1792 512 1024 1536 256 -256 768 768 256 256 -256 512 1280 1280 1536 768 1024 1792 1536 1024 0 256 -512 -256 1024 512 256 768 1792 2304 1280 256 768 1024 1280 1792 768 -768 -768 768 512 256 1024 1792 1536 1280 1536 1792 1280 768 512 -512 -1792 -512 512 768 2304 2816 1792 768 1536 2304 1536 0 -256 -256 -768 -768 256 1536 1536 2304 2048 256 768 2048 2304 1280 0 -256 -1024 -1024 0 1024 1792 2304 2304 1280 512 1280 2048 1280 256 -512 -1792 -1536 256 1536 1792 2048 2048 2048 1536 512 512 768 256 -256 0 -512 -1024 768 2048 2304 2304 1280 1280 1024 1024 1024 0 -512 256 768 0 -256 1536 2304 1792 2304 1280 -512 -256 768 1536 1024 256 512 512 1024 1792 1792 1536 1024 1280 0 -1280 256 2048 2560 2048 1024 -256 -256 1024 1280 1536 1024 0 0 256 768 1792 2304 2048 1280 1024 0 -512 -256 256 1024 1024 512 768 768 1280 2048 1792 1024 768 768 -256 -1024 0 256 1024 1536 1024 1280 1536 1792 1792 1024 512 512 0 -512 -256 512 768 1280 1280 1024 1280 1792 1792 1280 512 -256 -256 256 512 1280 1024 1280 1280 1024 1024 768 1024 1024 1024 1280 256 256 768 768 1024 512 256 768 1280 2560 2560 1280 512 -256 -512 -256 1024 1536 768 1024 1280 768 1024 1536 1536 1024 256 0 0 0 768 768 512 1280 1536 1280 1280 1280 1280 768 768 256 -256 768 768 256 768 1280 1792 1536 1536 1536 256 512 1024 0 -768 -256 768 512 1024 2048 1536 1024 1536 1536 768 0 0 -256). - - CoffeeCupClink _ SoundBuffer fromArray: samples. -! ! -!SampledSound class methodsFor: 'WAV reading' stamp: 'ar 1/27/98 23:06'! - next16BitWord: msbFirst from: stream - "Read a 16-bit positive integer from the input stream." - "Assume: Stream has at least two bytes left." - - | n | - n _ stream next: 2. - ^msbFirst - ifTrue:[(n at: 1) * 256 + (n at: 2)] - ifFalse:[(n at: 2) * 256 + (n at: 1)] -! ! -!SampledSound class methodsFor: 'WAV reading' stamp: 'ar 1/27/98 23:06'! - next32BitWord: msbFirst from: stream - "Read a 32-bit positive integer from the input stream." - "Assume: Stream has at least four bytes left." - - | n | - n _ stream next: 4. - ^msbFirst - ifTrue:[(n at: 1) * 256 + (n at: 2) * 256 + (n at: 3) * 256 + (n at: 4)] - ifFalse:[(n at: 4) * 256 + (n at: 3) * 256 + (n at: 2) * 256 + (n at: 1)] -! ! -!SampledSound class methodsFor: 'default sound'! - nominalSamplePitch: aNumber - "Record an estimate of the normal pitch of the sampled sound." - - NominalSamplePitch _ aNumber. -! ! -!SampledSound class methodsFor: 'sound library' stamp: 'jm 1/14/1999 11:04'! - playSoundNamed: aString - "Play the sound with given name. Do nothing if there is no sound of that name in the library." - "SampledSound playSoundNamed: 'croak'" - - | snd | - snd _ self soundNamed: aString. - snd ifNotNil: [snd play]. - ^ snd -! ! -!SampledSound class methodsFor: 'sound library' stamp: 'jm 1/14/1999 10:40'! - putCoffeeCupClinkInSoundLibrary - "SampledSound putCoffeeCupClinkInSoundLibrary" - - self addLibrarySoundNamed: 'clink' - samples: self coffeeCupClink - samplingRate: 11025! ! -!SampledSound class methodsFor: 'WAV reading' stamp: 'jm 3/17/98 21:03'! - readWaveChunk: chunkType inRIFF: stream - "Search the stream for a format chunk of the given type and return its contents." - - | id count | - stream reset; binary. - stream skip: 8. "skip 'RIFF' and total length" - id _ (stream next: 4) asString. "contents type" - id = 'WAVE' ifFalse: [^ '']. "content type must be WAVE" - - "search for a chunk of the given type" - [id _ (stream next: 4) asString. - count _ self next32BitWord: false from: stream. - id = chunkType] whileFalse: [ - "skip this chunk, rounding length up to a word boundary" - stream skip: (count + 1 bitAnd: 16rFFFFFFFE). - stream atEnd ifTrue: [^ '']]. - - ^ stream next: count "return raw chunk data" -! ! -!SampledSound class methodsFor: 'sound library' stamp: 'jmv 3/2/2010 10:06'! - removeSoundNamed: aString - "Remove the sound with the given name from the sound library." - - SoundLibrary removeKey: aString ifAbsent: nil! ! -!SampledSound class methodsFor: 'instance creation' stamp: 'jm 9/12/97 19:20'! - samples: anArrayOf16BitSamples samplingRate: samplesPerSecond - "Return a SampledSound with the given samples array and sampling rate." - - ^ self new setSamples: anArrayOf16BitSamples samplingRate: samplesPerSecond -! ! -!SampledSound class methodsFor: 'sound library' stamp: 'sw 9/27/2001 14:46'! - soundNamed: aString - "Answer the sound of the given name, or, if there is no sound of that name, put up an informer so stating, and answer nil" - - "(SampledSound soundNamed: 'shutterClick') play" - - ^ self soundNamed: aString ifAbsent: - [self inform: aString, ' not found in the Sound Library'. - nil]! ! -!SampledSound class methodsFor: 'sound library' stamp: 'sw 9/27/2001 14:45'! - soundNamed: aString ifAbsent: aBlock - "Answer the sound of the given name, or if there is no sound of that name, answer the result of evaluating aBlock" - "(SampledSound soundNamed: 'shutterClick') play" - - | entry samples | - entry _ SoundLibrary - at: aString - ifAbsent: - [^ aBlock value]. - entry ifNil: [^ aBlock value]. - samples _ entry at: 1. - samples class isBytes ifTrue: [samples _ self convert8bitSignedTo16Bit: samples]. - ^ self samples: samples samplingRate: (entry at: 2) -! ! -!SampledSound class methodsFor: 'sound library' stamp: 'jmv 1/16/2011 23:55'! - soundNames - "Answer a list of sound names for the sounds stored in the sound library." - "| s | - SampledSound soundNames asSortedCollection do: [:n | - n asParagraph display. - s _ SampledSound soundNamed: n. - s ifNotNil: [s playAndWaitUntilDone]]" - - ^ SoundLibrary keys! ! -!SampledSound class methodsFor: 'utilities' stamp: 'jm 9/17/97 13:11'! - uLawDecode: aByteArray - "Convert the given array of uLaw-encoded 8-bit samples into a SoundBuffer of 16-bit signed samples." - - | n out decodingTable | - n _ aByteArray size. - out _ SoundBuffer newMonoSampleCount: n. - decodingTable _ self uLawDecodeTable. - 1 to: n do: [:i | out at: i put: (decodingTable at: (aByteArray at: i) + 1)]. - ^ out -! ! -!SampledSound class methodsFor: 'utilities' stamp: 'jm 9/13/97 16:41'! - uLawDecodeTable - "Return a 256 entry table to be used to decode 8-bit uLaw-encoded samples." - "Details: This table was computed as follows: - | d encoded lastEncodedPos lastEncodedNeg | - d _ Array new: 256. - lastEncodedPos _ nil. - lastEncodedNeg _ nil. - 4095 to: 0 by: -1 do: [:s | - encoded _ SampledSound uLawEncodeSample: s. - lastEncodedPos = encoded - ifFalse: [ - d at: (encoded + 1) put: (s bitShift: 3). - lastEncodedPos _ encoded]. - encoded _ encoded bitOr: 16r80. - lastEncodedNeg = encoded - ifFalse: [ - d at: (encoded + 1) put: (s bitShift: 3) negated. - lastEncodedNeg _ encoded]]. - d " - - ^ #(32760 31608 30584 29560 28536 27512 26488 25464 24440 23416 22392 21368 20344 19320 18296 17272 16248 15736 15224 14712 14200 13688 13176 12664 12152 11640 11128 10616 10104 9592 9080 8568 8056 7800 7544 7288 7032 6776 6520 6264 6008 5752 5496 5240 4984 4728 4472 4216 3960 3832 3704 3576 3448 3320 3192 3064 2936 2808 2680 2552 2424 2296 2168 2040 1912 1848 1784 1720 1656 1592 1528 1464 1400 1336 1272 1208 1144 1080 1016 952 888 856 824 792 760 728 696 664 632 600 568 536 504 472 440 408 376 360 344 328 312 296 280 264 248 232 216 200 184 168 152 136 120 112 104 96 88 80 72 64 56 48 40 32 24 16 8 0 -32760 -31608 -30584 -29560 -28536 -27512 -26488 -25464 -24440 -23416 -22392 -21368 -20344 -19320 -18296 -17272 -16248 -15736 -15224 -14712 -14200 -13688 -13176 -12664 -12152 -11640 -11128 -10616 -10104 -9592 -9080 -8568 -8056 -7800 -7544 -7288 -7032 -6776 -6520 -6264 -6008 -5752 -5496 -5240 -4984 -4728 -4472 -4216 -3960 -3832 -3704 -3576 -3448 -3320 -3192 -3064 -2936 -2808 -2680 -2552 -2424 -2296 -2168 -2040 -1912 -1848 -1784 -1720 -1656 -1592 -1528 -1464 -1400 -1336 -1272 -1208 -1144 -1080 -1016 -952 -888 -856 -824 -792 -760 -728 -696 -664 -632 -600 -568 -536 -504 -472 -440 -408 -376 -360 -344 -328 -312 -296 -280 -264 -248 -232 -216 -200 -184 -168 -152 -136 -120 -112 -104 -96 -88 -80 -72 -64 -56 -48 -40 -32 -24 -16 -8 0) -! ! -!SampledSound class methodsFor: 'utilities' stamp: 'jm 9/13/97 15:52'! - uLawEncode: anArray - "Convert the given array of 16-bit signed samples into a ByteArray of uLaw-encoded 8-bit samples." - - | n out s | - n _ anArray size. - out _ ByteArray new: n. - 1 to: n do: [:i | - s _ anArray at: i. - s _ s bitShift: -3. "drop 4 least significant bits" - s < 0 - ifTrue: [s _ (self uLawEncodeSample: s negated) bitOr: 16r80] - ifFalse: [s _ (self uLawEncodeSample: s)]. - out at: i put: s]. - ^ out -! ! -!SampledSound class methodsFor: 'utilities' stamp: 'jm 9/13/97 15:40'! - uLawEncodeSample: s - "Encode the given 16-bit signed sample using the uLaw 8-bit encoding." - - s < 496 ifTrue: [ - s < 112 ifTrue: [ - s < 48 ifTrue: [ - s < 16 - ifTrue: [^ 16r70 bitOr: (15 - s)] - ifFalse: [^ 16r60 bitOr: (15 - ((s - 16) bitShift: -1))]]. - ^ 16r50 bitOr: (15 - ((s - 48) bitShift: -2))]. - s < 240 - ifTrue: [^ 16r40 bitOr: (15 - ((s - 112) bitShift: -3))] - ifFalse: [^ 16r30 bitOr: (15 - ((s - 240) bitShift: -4))]]. - - s < 2032 ifTrue: [ - s < 1008 - ifTrue: [^ 16r20 bitOr: (15 - ((s - 496) bitShift: -5))] - ifFalse: [^ 16r10 bitOr: (15 - ((s - 1008) bitShift: -6))]]. - - s < 4080 - ifTrue: [^ 15 - ((s - 2032) bitShift: -7)] - ifFalse: [^ 0]. -! ! -!SampledSound class methodsFor: 'sound library' stamp: 'jhm 10/15/97 14:57'! - unusedSoundNameLike: desiredName - "Pick an unused sound name based on the given string. If necessary, append digits to avoid name conflicts with existing sounds." - "SampledSound unusedSoundNameLike: 'chirp'" - - | newName i | - newName _ desiredName. - i _ 2. - [SoundLibrary includesKey: newName] whileTrue: [ - newName _ desiredName, i printString. - i _ i + 1]. - ^ newName -! ! -!SampledSound class methodsFor: 'default sound' stamp: 'jm 5/8/1998 18:53'! - useCoffeeCupClink - "Set the sample table to be used as the default waveform to the sound of a coffee cup being tapped with a spoon." - "SampledSound useCoffeeCupClink bachFugue play" - - DefaultSampleTable _ self coffeeCupClink. - NominalSamplePitch _ 400. -! ! -!SequentialSound methodsFor: 'composition'! - , aSound - "Return the concatenation of the receiver and the argument sound." - - ^ self add: aSound -! ! -!SequentialSound methodsFor: 'composition' stamp: 'jm 12/15/97 22:48'! - add: aSound - - sounds _ sounds copyWith: aSound. -! ! -!SequentialSound methodsFor: 'composition' stamp: 'di 12/7/2000 16:03'! - compressWith: codecClass - ^ self copy transformSounds: [:s | s compressWith: codecClass]! ! -!SequentialSound methodsFor: 'composition' stamp: 'RAA 12/24/2000 08:42'! - compressWith: codecClass atRate: aSamplingRate - ^ self copy transformSounds: [:s | s compressWith: codecClass atRate: aSamplingRate]! ! -!SequentialSound methodsFor: 'copying' stamp: 'jm 12/15/97 22:48'! - copySounds - "Private!! Support for copying. Copy my component sounds." - - sounds _ sounds collect: [:s | s copy]. -! ! -!SequentialSound methodsFor: 'sound generation' stamp: 'jm 11/25/97 13:41'! - doControl - - super doControl. - currentIndex > 0 - ifTrue: [(sounds at: currentIndex) doControl]. -! ! -!SequentialSound methodsFor: 'accessing' stamp: 'RAA 12/7/2000 17:24'! - duration - "Answer the duration of this sound in seconds." - - "7 dec 2000 - handle compressed sounds. better way??" - - | dur | - dur _ 0. - sounds do: [:snd | dur _ dur + snd asSound duration]. - ^ dur -! ! -!SequentialSound methodsFor: 'initialization' stamp: 'jmv 12/2/2011 10:49'! - initialize - - super initialize. - sounds _ #(). - currentIndex _ 0. -! ! -!SequentialSound methodsFor: 'sound generation' stamp: 'jm 11/24/97 16:16'! - mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol - "Play a collection of sounds in sequence." - "PluckedSound chromaticScale play" - - | finalIndex i snd remaining count | - currentIndex = 0 ifTrue: [^ self]. "already done" - finalIndex _ (startIndex + n) - 1. - i _ startIndex. - [i <= finalIndex] whileTrue: [ - snd _ (sounds at: currentIndex). - [(remaining _ snd samplesRemaining) <= 0] whileTrue: [ - "find next undone sound" - currentIndex < sounds size - ifTrue: [ - currentIndex _ currentIndex + 1. - snd _ (sounds at: currentIndex)] - ifFalse: [ - currentIndex _ 0. - ^ self]]. "no more sounds" - count _ (finalIndex - i) + 1. - remaining < count ifTrue: [count _ remaining]. - snd mixSampleCount: count into: aSoundBuffer startingAt: i leftVol: leftVol rightVol: rightVol. - i _ i + count]. -! ! -!SequentialSound methodsFor: 'copying' stamp: 'jmv 5/14/2015 09:58'! - postCopy - "Copy my component sounds." - - super postCopy. - self copySounds -! ! -!SequentialSound methodsFor: 'composition' stamp: 'jm 4/14/1999 10:05'! - pruneFinishedSounds - "Remove any sounds that have been completely played." - - | newSnds | - (currentIndex > 1 and: [currentIndex < sounds size]) ifFalse: [^ self]. - newSnds _ sounds copyFrom: currentIndex to: sounds size. - currentIndex _ 1. - sounds _ newSnds. -! ! -!SequentialSound methodsFor: 'composition' stamp: 'RAA 8/9/2000 16:27'! - removeFirstCompleteSoundOrNil - "Remove the first sound if it has been completely recorded." - - | firstSound | - - sounds size > 0 ifFalse: [^ nil]. - firstSound _ sounds first. - sounds _ sounds copyFrom: 2 to: sounds size. - ^firstSound -! ! -!SequentialSound methodsFor: 'sound generation' stamp: 'jm 12/15/97 22:47'! - reset - - super reset. - sounds do: [:snd | snd reset]. - sounds size > 0 ifTrue: [currentIndex _ 1]. -! ! -!SequentialSound methodsFor: 'sound generation' stamp: 'jm 12/15/97 22:47'! - samplesRemaining - - currentIndex = 0 - ifTrue: [^ 0] - ifFalse: [^ 1000000]. -! ! -!SequentialSound methodsFor: 'accessing' stamp: 'jm 2/4/98 13:36'! - sounds - - ^ sounds -! ! -!SequentialSound methodsFor: 'copying' stamp: 'jmv 8/5/2011 16:00'! - transformSounds: tfmBlock - "Private!! Support for copying. Copy my component sounds." - - sounds _ sounds collect: tfmBlock! ! -!StreamingMonoSound methodsFor: 'private' stamp: 'jm 10/18/2001 15:51'! - createMixer - "Create a mixed sound consisting of sampled sounds with one sound buffer's worth of samples." - - | snd | - mixer _ MixedSound new. - snd _ SampledSound - samples: (SoundBuffer newMonoSampleCount: 2) "buffer size will be adjusted dynamically" - samplingRate: streamSamplingRate. - mixer add: snd pan: 0.5 volume: volume. -! ! -!StreamingMonoSound methodsFor: 'private' stamp: 'jm 11/21/2001 09:05'! - currentSampleIndex - "Answer the index of the current sample." - - | bytePosition frameIndex | - bytePosition _ stream position - audioDataStart. - codec - ifNil: [^ bytePosition // 2] - ifNotNil: [ - frameIndex _ bytePosition // codec bytesPerEncodedFrame. - ^ (frameIndex * codec samplesPerFrame) - leftoverSamples monoSampleCount]. -! ! -!StreamingMonoSound methodsFor: 'accessing' stamp: 'jm 11/16/2001 17:12'! - duration - "Answer the duration of this sound in seconds." - - ^ totalSamples asFloat / streamSamplingRate -! ! -!StreamingMonoSound methodsFor: 'other' stamp: 'jmv 2/26/2016 16:02'! - extractFrom: startSecs to: endSecs - "Extract a portion of this sound between the given start and end times. The current implementation only works if the sound is uncompressed." - - | emptySound first last sampleCount byteStream sndBuf | - codec ifNotNil: [^ self error: 'only works on uncompressed sounds']. - emptySound _ SampledSound samples: SoundBuffer new samplingRate: streamSamplingRate. - first _ (startSecs * streamSamplingRate) truncated max: 0. - last _ ((endSecs * streamSamplingRate) truncated min: totalSamples) - 1. - first >= last ifTrue: [^ emptySound]. - codec ifNotNil: [self error: 'extracting from compressed sounds is not supported']. - sampleCount _ last + 1 - first. - stream position: audioDataStart + (2 * first). - byteStream _ ReadStream on: (stream next: 2 * sampleCount). - sndBuf _ SoundBuffer newMonoSampleCount: sampleCount. - 1 to: sampleCount do: [:i | sndBuf at: i put: (byteStream nextSignedInt16BigEndian: true)]. - ^ SampledSound samples: sndBuf samplingRate: streamSamplingRate -! ! -!StreamingMonoSound methodsFor: 'initialization' stamp: 'jm 11/16/2001 10:23'! - initStream: aStream headerStart: anInteger - "Initialize for streaming from the given stream. The audio file header starts at the given stream position." - - stream _ aStream. - volume _ 1.0. - repeat _ false. - headerStart _ anInteger. - self reset. -! ! -!StreamingMonoSound methodsFor: 'private' stamp: 'jm 11/21/2001 11:37'! -loadBuffer: aSoundBuffer compressedSampleCount: sampleCount - "Load the given sound buffer from the compressed sample stream." - "Details: Most codecs decode in multi-sample units called 'frames'. Since the requested sampleCount is typically not an even multiple of the frame size, we need to deal with partial frames. The unused samples from a partial frame are retained until the next call to this method." - - | n samplesNeeded frameCount encodedBytes r decodedCount buf j | - "first, use any leftover samples" - n _ self loadFromLeftovers: aSoundBuffer sampleCount: sampleCount. - samplesNeeded _ sampleCount - n. - samplesNeeded <= 0 ifTrue: [^ self]. - - "decode an integral number of full compression frames" - frameCount _ samplesNeeded // codec samplesPerFrame. - encodedBytes _ stream next: (frameCount * codec bytesPerEncodedFrame). - r _ codec decodeFrames: frameCount from: encodedBytes at: 1 into: aSoundBuffer at: n + 1. - decodedCount _ r last. - decodedCount >= samplesNeeded ifTrue: [^ self]. - - "decode one last compression frame to finish filling the buffer" - buf _ SoundBuffer newMonoSampleCount: codec samplesPerFrame. - encodedBytes _ stream next: codec bytesPerEncodedFrame. - codec decodeFrames: 1 from: encodedBytes at: 1 into: buf at: 1. - j _ 0. - (n + decodedCount + 1) to: sampleCount do: [:i | - aSoundBuffer at: i put: (buf at: (j _ j + 1))]. - - "save the leftover samples" - leftoverSamples _ buf copyFrom: (j + 1) to: buf monoSampleCount. -! ! -!StreamingMonoSound methodsFor: 'private' stamp: 'jmv 2/26/2016 16:03'! - loadBuffer: aSoundBuffer uncompressedSampleCount: sampleCount - "Load the given sound buffer from the uncompressed sample stream." - - "read directly into the sample buffer; count is in 32-bit words" - stream next: sampleCount // 2 into: aSoundBuffer startingAt: 1. - aSoundBuffer restoreEndianness. - - "read the final sample if sampleCount is odd:" - sampleCount odd ifTrue: [aSoundBuffer at: sampleCount put: (stream nextSignedInt16BigEndian: true)]. -! ! -!StreamingMonoSound methodsFor: 'private' stamp: 'jm 11/21/2001 08:02'! - loadBuffersForSampleCount: count - "Load the sound buffers from the stream." - - | snd buf sampleCount | - snd _ mixer sounds first. - buf _ snd samples. - buf monoSampleCount = count ifFalse: [ - buf _ SoundBuffer newMonoSampleCount: count. - snd setSamples: buf samplingRate: streamSamplingRate]. - sampleCount _ count min: (totalSamples - self currentSampleIndex). - sampleCount < count ifTrue: [buf primFill: 0]. - - codec - ifNil: [self loadBuffer: buf uncompressedSampleCount: sampleCount] - ifNotNil: [self loadBuffer: buf compressedSampleCount: sampleCount]. - - mixer reset. -! ! -!StreamingMonoSound methodsFor: 'private' stamp: 'jm 11/21/2001 09:09'! - loadFromLeftovers: aSoundBuffer sampleCount: sampleCount - "Load the given sound buffer from the samples leftover from the last frame. Answer the number of samples loaded, which typically is less than sampleCount." - - | leftoverCount n | - leftoverCount _ leftoverSamples monoSampleCount. - leftoverCount = 0 ifTrue: [^ 0]. - - n _ leftoverCount min: sampleCount. - 1 to: n do: [:i | aSoundBuffer at: i put: (leftoverSamples at: i)]. - n < sampleCount - ifTrue: [leftoverSamples _ SoundBuffer new] - ifFalse: [leftoverSamples _ leftoverSamples copyFrom: n + 1 to: leftoverSamples size]. - ^ n -! ! -!StreamingMonoSound methodsFor: 'playing' stamp: 'jmv 4/17/2013 12:11'! - millisecondsSinceStart - "Answer the number of milliseconds of this sound started playing." - - | mSecs | - (stream isNil or: [stream closed]) ifTrue: [^ 0]. - mSecs _ self currentSampleIndex * 1000 // streamSamplingRate. - (self isPlaying and: [lastBufferMSecs > 0]) ifTrue: [ - "adjust mSecs by the milliseconds since the last buffer" - mutex critical: [ - mSecs _ self currentSampleIndex * 1000 // streamSamplingRate. - mSecs _ mSecs + (Time localMillisecondClock - lastBufferMSecs)]]. - ^ mSecs + 350 - (2 * SoundPlayer bufferMSecs) -! ! -!StreamingMonoSound methodsFor: 'playing' stamp: 'jmv 4/17/2013 12:11'! -playSampleCount: n into: aSoundBuffer startingAt: startIndex - "Mix the next n samples of this sound into the given buffer starting at the given index" - - self repeat ifTrue: [ "loop if necessary" - (totalSamples - self currentSampleIndex) < n ifTrue: [self startOver]]. - - mutex critical: [ - lastBufferMSecs _ Time localMillisecondClock. - self loadBuffersForSampleCount: (n * streamSamplingRate) // SoundPlayer samplingRate. - mixer playSampleCount: n into: aSoundBuffer startingAt: startIndex]. -! ! -!StreamingMonoSound methodsFor: 'private' stamp: 'pb 5/25/2016 01:51'! - positionCodecTo: desiredSampleIndex - "Position to the closest frame before the given sample index when using a codec. If using the ADPCM codec, try to ensure that it is in sync with the compressed sample stream." - - | desiredFrameIndex desiredPosition tmpStream tmpCodec byteBuf bufFrames sampleBuf frameCount n startOffset | - (codec isKindOf: ADPCMCodec) ifFalse: [ - "stateless codecs (or relatively stateless ones, like GSM: just jump to frame boundary" - desiredFrameIndex _ desiredSampleIndex // codec samplesPerFrame. - stream position: audioDataStart + (desiredFrameIndex * codec bytesPerEncodedFrame). - codec reset. - ^ self]. - - "compute the desired stream position" - desiredFrameIndex _ desiredSampleIndex // codec samplesPerFrame. - desiredPosition _ audioDataStart + (desiredFrameIndex * codec bytesPerEncodedFrame). - - "copy stream and codec" - (stream isKindOf: FileStream) - ifTrue: [tmpStream _ (stream name asFileEntry readStream ) binary] - ifFalse: [tmpStream _ "stream deepCopy" stream contents readStream]. "To kill #deepCopy. Not sure if right, though (jmv)" - tmpCodec _ codec copy reset. - - "reset the codec and start back about 30 seconds to try to get codec in sync" - startOffset _ ((desiredFrameIndex - 80000) max: 0) * codec bytesPerEncodedFrame. - tmpStream position: audioDataStart + startOffset. - - "decode forward to the desired position" - byteBuf _ ByteArray new: (32000 roundTo: codec bytesPerEncodedFrame). - bufFrames _ byteBuf size // codec bytesPerEncodedFrame. - sampleBuf _ SoundBuffer newMonoSampleCount: bufFrames * codec samplesPerFrame. - frameCount _ (desiredPosition - tmpStream position) // codec bytesPerEncodedFrame. - [frameCount > 0] whileTrue: [ - n _ bufFrames min: frameCount. - tmpStream next: n * codec bytesPerEncodedFrame into: byteBuf startingAt: 1. - tmpCodec decodeFrames: n from: byteBuf at: 1 into: sampleBuf at: 1. - frameCount _ frameCount - n]. - - codec _ tmpCodec. - stream position: tmpStream position. - (tmpStream isKindOf: FileStream) ifTrue: [tmpStream close].! ! -!StreamingMonoSound methodsFor: 'private' stamp: 'jm 11/16/2001 10:23'! - readAIFFHeader - "Read an AIFF file header from stream." - - | aiffReader | - aiffReader _ AIFFFileReader new. - aiffReader readFromStream: stream mergeIfStereo: false skipDataChunk: true. - aiffReader channelCount = 1 ifFalse: [self error: 'not monophonic']. - aiffReader bitsPerSample = 16 ifFalse: [self error: 'not 16-bit']. - - audioDataStart _ headerStart + aiffReader channelDataOffset. - streamSamplingRate _ aiffReader samplingRate. - totalSamples _ aiffReader frameCount min: (stream size - audioDataStart) // 2. - codec _ nil. -! ! -!StreamingMonoSound methodsFor: 'private' stamp: 'jmv 10/5/2015 12:12'! - readHeader - "Read the sound file header from my stream." - - | id | - stream position: headerStart. - id _ (stream next: 4) asString. - stream position: headerStart. - id = 'FORM' ifTrue: [^ self readAIFFHeader]. - self error: 'unrecognized sound file format'. -! ! -!StreamingMonoSound methodsFor: 'accessing' stamp: 'jm 10/18/2001 15:46'! - repeat - "Answer the repeat flag." - - ^ repeat -! ! -!StreamingMonoSound methodsFor: 'accessing' stamp: 'jm 6/3/2001 18:39'! - repeat: aBoolean - "Set the repeat flag. If true, this sound will loop back to the beginning when it gets to the end." - - repeat _ aBoolean. -! ! -!StreamingMonoSound methodsFor: 'playing' stamp: 'jm 10/21/2001 09:45'! - reset - - super reset. - self startOver. - self createMixer. -! ! -!StreamingMonoSound methodsFor: 'playing' stamp: 'jmv 5/15/2013 08:09'! - samplesRemaining - "Answer the number of samples remaining to be played." - - | result | - (stream isNil or: [stream closed]) ifTrue: [^ 0]. - self repeat ifTrue: [^ 1000000]. - result _ (totalSamples - self currentSampleIndex) max: 0. - result <= 0 ifTrue: [ - stream close. - mixer _ nil. - codec _ nil ]. - ^ result! ! -!StreamingMonoSound methodsFor: 'accessing' stamp: 'jm 11/16/2001 17:05'! - soundPosition - "Answer the relative position of sound playback as a number between 0.0 and 1.0." - - (stream isNil or: [stream closed]) ifTrue: [^ 0.0]. - ^ self currentSampleIndex asFloat / totalSamples -! ! -!StreamingMonoSound methodsFor: 'accessing' stamp: 'jm 12/14/2001 11:29'! - soundPosition: fraction - "Jump to the position the given fraction through the sound file. The argument is a number between 0.0 and 1.0." - - | desiredSampleIndex | - (stream isNil or: [stream closed]) ifTrue: [^ self]. - desiredSampleIndex _ ((totalSamples * fraction) truncated max: 0) min: totalSamples. - codec - ifNil: [stream position: audioDataStart + (desiredSampleIndex * 2)] - ifNotNil: [self positionCodecTo: desiredSampleIndex]. - leftoverSamples _ SoundBuffer new. -! ! -!StreamingMonoSound methodsFor: 'private' stamp: 'jm 11/27/2001 07:36'! - startOver - "Jump back to the first sample." - - stream reopen; binary. - self readHeader. - stream position: audioDataStart. - leftoverSamples _ SoundBuffer new. - lastBufferMSecs _ 0. - mutex _ Semaphore forMutualExclusion. -! ! -!StreamingMonoSound methodsFor: 'accessing' stamp: 'jm 11/20/2001 16:59'! - streamSamplingRate - "Answer the sampling rate of the MP3 stream." - - ^ streamSamplingRate -! ! -!StreamingMonoSound methodsFor: 'accessing' stamp: 'jm 9/26/2000 07:49'! - volume - "Answer my volume." - - ^ volume -! ! -!StreamingMonoSound methodsFor: 'accessing' stamp: 'jm 5/30/2001 16:53'! - volume: aNumber - "Set my volume to the given number between 0.0 and 1.0." - - volume _ aNumber. - self createMixer. -! ! -!StreamingMonoSound class methodsFor: 'instance creation' stamp: 'jmv 10/14/2015 17:26'! - onFileNamed: fileName - "Answer an instance of me for playing the file with the given name." - - ^self onFileNamed: fileName headerStart: 0! ! -!StreamingMonoSound class methodsFor: 'instance creation' stamp: 'pb 5/25/2016 01:34'! - onFileNamed: fileName headerStart: anInteger - "Answer an instance of me for playing audio data starting at the given position in the file with the given name." - - | answer | - fileName asFileEntry readStreamDo: [ :f | - answer _ self new initStream: f headerStart: anInteger ]. - ^answer -! ! -!ScorePlayer methodsFor: 'volume' stamp: 'jmv 12/30/2009 11:33'! - adjustVolumeTo: vol overMSecs: mSecs - | normalizedVolume incr block | - normalizedVolume _ (vol asFloat min: 1.0) max: 0.0. - incr _ (self overallVolume - normalizedVolume) / mSecs * 50.0. - block _ normalizedVolume > 0.0 - ifTrue: [ - [[(normalizedVolume - self overallVolume) abs > 0.01] whileTrue: [self overallVolume: self overallVolume - incr. (Delay forMilliseconds: 50) wait]]] - ifFalse: [ - [[self overallVolume > 0.0] whileTrue: [self overallVolume: self overallVolume - incr. (Delay forMilliseconds: 50) wait]. self pause]]. - block fork -! ! -!ScorePlayer methodsFor: 'midi output' stamp: 'jm 10/12/1998 17:13'! - closeMIDIPort - "Stop using MIDI for output. Music will be played using the built-in sound synthesis." - - self pause. - midiPort _ nil. -! ! -!ScorePlayer methodsFor: 'copying' stamp: 'jm 1/29/98 18:32'! - copySounds - "Private!! Support for copying." - - instruments _ instruments copy. - leftVols _ leftVols copy. - rightVols _ rightVols copy. - muted _ muted copy. - self reset. -! ! -!ScorePlayer methodsFor: 'operating' stamp: 'jm 1/30/98 14:03'! - disableReverb: aBoolean - - aBoolean - ifTrue: [SoundPlayer stopReverb] - ifFalse: [SoundPlayer startReverb]. -! ! -!ScorePlayer methodsFor: 'sound generation' stamp: 'jm 9/10/1998 19:07'! - doControl - - super doControl. - 1 to: activeSounds size do: [:i | (activeSounds at: i) first doControl]. - ticksSinceStart _ ticksSinceStart + ticksClockIncr. - self processAllAtTick: ticksSinceStart asInteger. -! ! -!ScorePlayer methodsFor: 'accessing' stamp: 'jm 12/16/2001 11:59'! - duration - "Answer the duration in seconds of my MIDI score when played at the current rate. Take tempo changes into account." - - | totalSecs currentTempo lastTempoChangeTick | - totalSecs _ 0.0. - currentTempo _ 120.0. "quarter notes per minute" - lastTempoChangeTick _ 0. - score tempoMap ifNotNil: [ - score tempoMap do: [:tempoEvt | - "accumulate time up to this tempo change event" - secsPerTick _ 60.0 / (currentTempo * rate * score ticksPerQuarterNote). - totalSecs _ totalSecs + (secsPerTick * (tempoEvt time - lastTempoChangeTick)). - - "set the new tempo" - currentTempo _ (120.0 * (500000.0 / tempoEvt tempo)) roundTo: 0.01. - lastTempoChangeTick _ tempoEvt time]]. - - "add remaining time through end of score" - secsPerTick _ 60.0 / (currentTempo * rate * score ticksPerQuarterNote). - totalSecs _ totalSecs + (secsPerTick * (score durationInTicks - lastTempoChangeTick)). - ^ totalSecs -! ! -!ScorePlayer methodsFor: 'accessing' stamp: 'jmv 3/1/2010 13:17'! - durationInTicks - - durationInTicks ifNil: [^ 1000]. - ^ durationInTicks! ! -!ScorePlayer methodsFor: 'accessing' stamp: 'jm 3/3/98 12:14'! - infoForTrack: i - "Return the info string for the given track." - "Note: MIDI files follow varying conventions on their use of comment strings. Often, the first string in the track suggests the role of that track in the score, such as 'flute 1' or 'soprano'." - - ^ score trackInfo at: i -! ! -!ScorePlayer methodsFor: 'initialization' stamp: 'jmv 12/2/2011 10:49'! - initialize - - super initialize. - score _ MIDIScore new. - instruments _ #(). - overallVolume _ 0.5. - leftVols _ #(). - rightVols _ #(). - muted _ #(). - rate _ 1.0. - repeat _ false. - durationInTicks _ 100! ! -!ScorePlayer methodsFor: 'accessing' stamp: 'jm 1/3/98 09:37'! - instrumentForTrack: trackIndex - - ^ instruments at: trackIndex -! ! -!ScorePlayer methodsFor: 'accessing' stamp: 'jm 9/1/1999 20:33'! - instrumentForTrack: trackIndex put: aSoundProto - - trackIndex > instruments size ifTrue: [^ self]. - instruments at: trackIndex put: aSoundProto. -! ! -!ScorePlayer methodsFor: 'sound generation' stamp: 'jmv 4/6/2009 17:14'! - isDone - - | track | - activeSounds size > 0 ifTrue: [^ false]. - activeMIDINotes size > 0 ifTrue: [^ false]. - 1 to: score tracks size do: [:i | - track _ score tracks at: i. - (trackEventIndex at: i) <= track size ifTrue: [^ false]]. - ^ true -! ! -!ScorePlayer methodsFor: 'accessing' stamp: 'jm 12/16/2001 20:20'! - isStereo - - ^ true -! ! -!ScorePlayer methodsFor: 'sound generation' stamp: 'jmv 4/6/2009 17:14'! - jumpToTick: startTick - - | | - self reset. - self processTempoMapAtTick: startTick. - self skipNoteEventsThruTick: startTick. - ticksSinceStart _ startTick. -! ! -!ScorePlayer methodsFor: 'midi output' stamp: 'jmv 4/17/2013 12:09'! - midiPlayLoop - - | mSecsPerStep tStart mSecs | - mSecsPerStep _ 5. - [done] whileFalse: [ - tStart _ Time localMillisecondClock. - self processAllAtTick: ticksSinceStart asInteger. - (Delay forMilliseconds: mSecsPerStep) wait. - mSecs _ Time localMillisecondClock - tStart. - ticksSinceStart _ ticksSinceStart + (mSecs asFloat / (1000.0 * secsPerTick))]! ! -!ScorePlayer methodsFor: 'accessing' stamp: 'jm 9/28/1998 22:58'! - midiPort - - ^ midiPort -! ! -!ScorePlayer methodsFor: 'accessing' stamp: 'di 5/30/1999 12:46'! - millisecondsSinceStart - "Answer the approximate number of milliseconds of real time since the beginning of the score. Since this calculation uses the current tempo, which can change throughout the piece, it is safer to use ticksSinceStart for synchronization." - - ^ (secsPerTick * ticksSinceStart * 1000) asInteger -! ! -!ScorePlayer methodsFor: 'sound generation' stamp: 'jm 7/4/1998 08:21'! - mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol - "Play a number of sounds concurrently. The level of each sound can be set independently for the left and right channels." - - | myLeftVol myRightVol someSoundIsDone pair snd trk left right | - myLeftVol _ (leftVol * overallVolume) asInteger. - myRightVol _ (rightVol * overallVolume) asInteger. - someSoundIsDone _ false. - 1 to: activeSounds size do: [:i | - pair _ activeSounds at: i. - snd _ pair at: 1. - trk _ pair at: 2. - left _ (myLeftVol * (leftVols at: trk)) // ScaleFactor. - right _ (myRightVol * (rightVols at: trk)) // ScaleFactor. - snd samplesRemaining > 0 - ifTrue: [ - snd mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: left rightVol: right] - ifFalse: [someSoundIsDone _ true]]. - - someSoundIsDone ifTrue: [ - activeSounds _ activeSounds select: [:p | p first samplesRemaining > 0]]. -! ! -!ScorePlayer methodsFor: 'accessing' stamp: 'jm 1/29/98 18:33'! - mutedForTrack: trackIndex - - ^ muted at: trackIndex -! ! -!ScorePlayer methodsFor: 'accessing' stamp: 'jmv 3/2/2010 10:06'! - mutedForTrack: trackIndex put: aBoolean - - trackIndex > muted size ifTrue: [^ self]. - muted at: trackIndex put: aBoolean. - aBoolean ifFalse: [^ self]. - - "silence any currently sounding notes for this track" - activeSounds do: [:pair | - pair last = trackIndex ifTrue: [activeSounds remove: pair ifAbsent: nil]]. - midiPort ifNotNil: [ - activeMIDINotes do: [:pair | - pair last = trackIndex ifTrue: [ - pair first endNoteOnMidiPort: midiPort. - activeMIDINotes remove: pair ifAbsent: nil]]]. -! ! -!ScorePlayer methodsFor: 'accessing' stamp: 'jm 5/30/1999 17:16'! - mutedState - - ^ muted -! ! -!ScorePlayer methodsFor: 'initialization' stamp: 'di 6/15/1999 11:18'! -onScore: aMIDIScore - - | trackCount totalVol incr curr pan | - score _ aMIDIScore. - trackCount _ score tracks size. - durationInTicks _ score durationInTicks. - instruments _ (1 to: trackCount) collect: [:i | FMSound oboe1]. - leftVols _ Array new: trackCount. - rightVols _ Array new: trackCount. - muted _ Array new: trackCount withAll: false. - rate _ 1.0. - repeat _ false. - tempo _ 120.0. - - trackCount = 0 ifTrue: [^ self]. - 1 to: trackCount do: [:i | - leftVols at: i put: ScaleFactor // 4. - rightVols at: i put: ScaleFactor // 4]. - - "distribute inital panning of tracks left-to-right" - totalVol _ 1.0. - incr _ totalVol / (((trackCount // 2) + 1) * 2). - curr _ 0. - 1 to: trackCount do: [:t | - t even - ifTrue: [pan _ curr] - ifFalse: [ - curr _ curr + incr. - pan _ totalVol - curr]. - self panForTrack: t put: pan]. - -! ! -!ScorePlayer methodsFor: 'midi output' stamp: 'jm 10/12/1998 15:56'! - openMIDIPort: portNum - "Open the given MIDI port. Music will be played as MIDI commands to the given MIDI port." - - midiPort _ SimpleMIDIPort openOnPortNumber: portNum. -! ! -!ScorePlayer methodsFor: 'accessing' stamp: 'jm 7/4/1998 08:17'! - overallVolume - - ^ overallVolume -! ! -!ScorePlayer methodsFor: 'accessing' stamp: 'jm 7/4/1998 08:18'! - overallVolume: aNumber - "Set the overally playback volume to a value between 0.0 (off) and 1.0 (full blast)." - - overallVolume _ (aNumber asFloat min: 1.0) max: 0.0. - -! ! -!ScorePlayer methodsFor: 'accessing' stamp: 'jm 7/4/1998 09:32'! - panForTrack: i - - | left right fullVol pan | - left _ leftVols at: i. - right _ rightVols at: i. - left = right ifTrue: [^ 0.5]. "centered" - fullVol _ left max: right. - left < fullVol - ifTrue: [pan _ left asFloat / (2.0 * fullVol)] - ifFalse: [pan _ 1.0 - (right asFloat / (2.0 * fullVol))]. - ^ pan roundTo: 0.001 - -! ! -!ScorePlayer methodsFor: 'accessing' stamp: 'jm 9/2/1999 13:33'! - panForTrack: trackIndex put: aNumber - "Set the left-right pan for this track to a value in the range [0.0..1.0], where 0.0 means full-left." - - | fullVol pan left right | - trackIndex > leftVols size ifTrue: [^ self]. - fullVol _ (leftVols at: trackIndex) max: (rightVols at: trackIndex). - pan _ (aNumber asFloat min: 1.0) max: 0.0. - pan <= 0.5 - ifTrue: [ "attenuate right channel" - left _ fullVol. - right _ 2.0 * pan * fullVol] - ifFalse: [ "attenuate left channel" - left _ 2.0 * (1.0 - pan) * fullVol. - right _ fullVol]. - rightVols at: trackIndex put: right asInteger. - leftVols at: trackIndex put: left asInteger. -! ! -!ScorePlayer methodsFor: 'operating' stamp: 'jmv 4/6/2009 17:16'! - pause - "Pause this sound. It can be resumed from this point, or reset and resumed to start from the beginning." - - super pause. - activeSounds _ activeSounds species new. - midiPort ifNotNil: [self stopMIDIPlaying]. -! ! -!ScorePlayer methodsFor: 'accessing' stamp: 'di 6/20/1999 00:42'! - positionInScore - - ^ self ticksSinceStart asFloat / (self durationInTicks max: 1)! ! -!ScorePlayer methodsFor: 'accessing' stamp: 'jm 6/16/1999 22:50'! - positionInScore: pos - - self isPlaying ifTrue: [^ self "ignore rude intrusion"]. - ticksSinceStart _ pos * durationInTicks. - done _ false. - -! ! -!ScorePlayer methodsFor: 'copying' stamp: 'jmv 5/14/2015 09:58'! - postCopy - "Copy my component sounds." - - super postCopy. - self copySounds -! ! -!ScorePlayer methodsFor: 'sound generation' stamp: 'jmv 4/6/2009 17:10'! - processAllAtTick: scoreTick - - self processTempoMapAtTick: scoreTick. - midiPort - ifNil: [self processNoteEventsAtTick: scoreTick] - ifNotNil: [self processMIDIEventsAtTick: scoreTick]. - self isDone ifTrue: [ - repeat - ifTrue: [self reset] - ifFalse: [done _ true]]. -! ! -!ScorePlayer methodsFor: 'midi output' stamp: 'jmv 3/1/2010 14:06'! - processMIDIEventsAtTick: scoreTick - "Process note events through the given score tick using MIDI." - - | j evt | - 1 to: score tracks size do: [:i | - j _ trackEventIndex at: i. - [ - evt _ score eventForTrack: i after: j ticks: scoreTick. - evt notNil - ] whileTrue: [ - evt isNoteEvent - ifTrue: [ - (muted at: i) ifFalse: [ - evt startNoteOnMidiPort: midiPort. - activeMIDINotes add: (Array with: evt with: i)]] - ifFalse: [evt outputOnMidiPort: midiPort]. - j _ j + 1. - trackEventIndex at: i put: j]]. - self turnOffActiveMIDINotesAt: scoreTick. -! ! -!ScorePlayer methodsFor: 'sound generation' stamp: 'jmv 3/1/2010 14:06'! - processNoteEventsAtTick: scoreTick - "Process note events through the given score tick using internal Squeak sound synthesis." - - | instr j evt snd | - 1 to: score tracks size do: [:i | - instr _ instruments at: i. - j _ trackEventIndex at: i. - [ - evt _ score eventForTrack: i after: j ticks: scoreTick. - evt notNil - ] whileTrue: [ - (evt isNoteEvent and: [(muted at: i) not]) ifTrue: [ - snd _ instr - soundForMidiKey: evt midiKey - dur: secsPerTick * evt duration - loudness: evt velocity asFloat / 127.0. - activeSounds add: (Array with: snd with: i)]. - j _ j + 1. - trackEventIndex at: i put: j]]. -! ! -!ScorePlayer methodsFor: 'sound generation' stamp: 'jm 6/16/1999 21:04'! - processTempoMapAtTick: scoreTick - "Process tempo changes through the given score tick." - - | map tempoChanged | - map _ score tempoMap. - map ifNil: [^ self]. - tempoChanged _ false. - [(tempoMapIndex <= map size) and: - [(map at: tempoMapIndex) time <= scoreTick]] whileTrue: [ - tempoChanged _ true. - tempoMapIndex _ tempoMapIndex + 1]. - - tempoChanged ifTrue: [ - tempo _ (120.0 * (500000.0 / (map at: tempoMapIndex - 1) tempo)) roundTo: 0.01. - self tempoOrRateChanged]. - -! ! -!ScorePlayer methodsFor: 'accessing' stamp: 'jm 1/3/98 09:33'! - rate - - ^ rate -! ! -!ScorePlayer methodsFor: 'accessing' stamp: 'jm 1/4/98 10:07'! - rate: aNumber - "Set the playback rate. For example, a rate of 2.0 will playback at twice normal speed." - - rate _ aNumber asFloat. - self tempoOrRateChanged. -! ! -!ScorePlayer methodsFor: 'accessing' stamp: 'jm 3/4/98 09:30'! - repeat - "Return true if this player will repeat when it gets to the end of the score, false otherwise." - - ^ repeat -! ! -!ScorePlayer methodsFor: 'accessing' stamp: 'jm 3/4/98 09:31'! - repeat: aBoolean - "Turn repeat mode on or off." - - repeat _ aBoolean. -! ! -!ScorePlayer methodsFor: 'sound generation' stamp: 'jmv 4/6/2009 17:16'! - reset - - super reset. - tempo _ 120.0. - self tempoOrRateChanged. - done _ false. - ticksSinceStart _ 0. - "one index for each sound track, plus one for the ambient track..." - trackEventIndex _ Array new: score tracks size+1 withAll: 1. - tempoMapIndex _ 1. - activeSounds _ OrderedCollection new. - activeMIDINotes _ OrderedCollection new. - overallVolume ifNil: [overallVolume _ 0.5]. -! ! -!ScorePlayer methodsFor: 'operating' stamp: 'jmv 4/6/2009 17:16'! - resumePlaying - "Resume playing. Start over if done." - - done ifTrue: [self reset]. - self jumpToTick: ticksSinceStart. "Play up to here in case we got scrolled to new position." - midiPort - ifNil: [super resumePlaying] "let the sound player drive sound generation" - ifNotNil: [self startMIDIPlaying]. "start a process to drive MIDI output" -! ! -!ScorePlayer methodsFor: 'sound generation' stamp: 'jm 12/30/97 17:38'! - samplesRemaining - - done - ifTrue: [^ 0] - ifFalse: [^ 1000000]. -! ! -!ScorePlayer methodsFor: 'accessing' stamp: 'jm 1/3/98 09:33'! - score - - ^ score -! ! -!ScorePlayer methodsFor: 'accessing' stamp: 'di 10/19/2000 21:12'! - secsPerTick - - ^ secsPerTick! ! -!ScorePlayer methodsFor: 'accessing' stamp: 'jmv 3/13/2012 12:45'! - settingsString - - | s | - s _ WriteStream on: (String new: 1000). - s nextPutAll: 'player'; newLine. - s tab; nextPutAll: 'rate: ', self rate printString, ';'; newLine. - s tab; nextPutAll: 'overallVolume: ', self overallVolume printString, ';'; newLine. - 1 to: self trackCount do: [:t | - s tab; nextPutAll: 'instrumentForTrack: ', t printString, - ' put: (AbstractSound soundNamed: #default);'; newLine. - s tab; nextPutAll: 'mutedForTrack: ', t printString, - ' put: ', (self mutedForTrack: t) printString, ';'; newLine. - s tab; nextPutAll: 'volumeForTrack: ', t printString, - ' put: ', (self volumeForTrack: t) printString, ';'; newLine. - s tab; nextPutAll: 'panForTrack: ', t printString, - ' put: ', (self panForTrack: t) printString, ';'; newLine]. - s tab; nextPutAll: 'repeat: ', self repeat printString, '.'; newLine. - ^ s contents -! ! -!ScorePlayer methodsFor: 'sound generation' stamp: 'jmv 3/1/2010 13:18'! - skipNoteEventsThruTick: startTick - "Skip note events through the given score tick using internal Squeak sound synthesis." - - | j evt | - 1 to: score tracks size do: [:i | - j _ trackEventIndex at: i. - [evt _ score eventForTrack: i after: j ticks: startTick. - evt == nil] whileFalse: [ - evt isNoteEvent - ifTrue: [ - (((evt time + evt duration) > startTick) and: [(muted at: i) not]) ifTrue: [ - self startNote: evt forStartTick: startTick trackIndex: i]] - ifFalse: [ - midiPort ifNotNil: [evt outputOnMidiPort: midiPort]]. - j _ j + 1]. - trackEventIndex at: i put: j]. -! ! -!ScorePlayer methodsFor: 'midi output' stamp: 'jmv 10/8/2012 22:14'! - startMIDIPlaying - "Start up a process to play this score via MIDI." - - midiPort ensureOpen. - midiPlayerProcess ifNotNil: [midiPlayerProcess terminate]. - midiPlayerProcess _ [self midiPlayLoop] newProcess. - midiPlayerProcess - priority: Processor userInterruptPriority; - name: 'ScorePlayer'; - resume. -! ! -!ScorePlayer methodsFor: 'sound generation' stamp: 'jm 6/16/1999 20:30'! - startNote: noteEvent forStartTick: startTick trackIndex: trackIndex - "Prepare a note to begin playing at the given tick. Used to start playing at an arbitrary point in the score. Handle both MIDI and built-in synthesis cases." - - | snd | - midiPort - ifNil: [ - snd _ (instruments at: trackIndex) - soundForMidiKey: noteEvent midiKey - dur: secsPerTick * (noteEvent endTime - startTick) - loudness: noteEvent velocity asFloat / 127.0. - activeSounds add: (Array with: snd with: trackIndex)] - ifNotNil: [ - noteEvent startNoteOnMidiPort: midiPort. - activeMIDINotes add: (Array with: noteEvent with: trackIndex)]. -! ! -!ScorePlayer methodsFor: 'midi output' stamp: 'jm 9/10/1998 20:44'! - stopMIDIPlaying - "Terminate the MIDI player process and turn off any active notes." - - midiPlayerProcess ifNotNil: [midiPlayerProcess terminate]. - midiPlayerProcess _ nil. - activeMIDINotes do: [:pair | pair first endNoteOnMidiPort: midiPort]. - activeMIDINotes _ activeMIDINotes species new. -! ! -!ScorePlayer methodsFor: 'accessing' stamp: 'jm 1/4/98 10:10'! - tempo - "Return the current tempo in beats (quarter notes) per minute. The tempo at any given moment is defined by the score and cannot be changed by the client. To change the playback speed, the client may change the rate parameter." - - ^ tempo -! ! -!ScorePlayer methodsFor: 'operating' stamp: 'jm 9/10/1998 20:56'! - tempoOrRateChanged - "This method should be called after changing the tempo or rate." - - secsPerTick _ 60.0 / (tempo * rate * score ticksPerQuarterNote). - ticksClockIncr _ (1.0 / self controlRate) / secsPerTick. -! ! -!ScorePlayer methodsFor: 'accessing' stamp: 'jm 9/22/1998 09:32'! - ticksForMSecs: mSecs - - ^ (mSecs asFloat / (1000.0 * secsPerTick)) rounded -! ! -!ScorePlayer methodsFor: 'accessing' stamp: 'jm 9/10/1998 20:48'! - ticksSinceStart - "Answer the number of score ticks that have elapsed since this piece started playing. The duration of a tick is determined by the MIDI score." - - ^ ticksSinceStart -! ! -!ScorePlayer methodsFor: 'accessing' stamp: 'di 6/19/1999 10:45'! - ticksSinceStart: newTicks - "Adjust ticks to folow, eg, piano roll autoscrolling" - - self isPlaying ifFalse: [ticksSinceStart _ newTicks] -! ! -!ScorePlayer methodsFor: 'accessing' stamp: 'jm 1/3/98 09:35'! - trackCount - - ^ score tracks size -! ! -!ScorePlayer methodsFor: 'midi output' stamp: 'jm 9/10/1998 17:48'! - turnOffActiveMIDINotesAt: scoreTick - "Turn off any active MIDI notes that should be turned off at the given score tick." - - | evt someNoteEnded | - midiPort ifNil: [^ self]. - someNoteEnded _ false. - activeMIDINotes do: [:pair | - evt _ pair first. - evt endTime <= scoreTick ifTrue: [ - evt endNoteOnMidiPort: midiPort. - someNoteEnded _ true]]. - - someNoteEnded ifTrue: [ - activeMIDINotes _ activeMIDINotes select: [:p | p first endTime > scoreTick]]. -! ! -!ScorePlayer methodsFor: 'initialization' stamp: 'di 6/20/1999 00:46'! - updateDuration - - durationInTicks _ score durationInTicks. -! ! -!ScorePlayer methodsFor: 'accessing' stamp: 'jm 7/4/1998 09:16'! - volumeForTrack: i - - | vol | - vol _ (leftVols at: i) max: (rightVols at: i). - ^ (vol asFloat / ScaleFactor) roundTo: 0.0001 -! ! -!ScorePlayer methodsFor: 'accessing' stamp: 'jm 9/2/1999 13:34'! -volumeForTrack: trackIndex put: aNumber - - | newVol oldLeft oldRight oldFullVol left right | - trackIndex > leftVols size ifTrue: [^ self]. - newVol _ ((aNumber asFloat max: 0.0) min: 1.0) * ScaleFactor. - oldLeft _ leftVols at: trackIndex. - oldRight _ rightVols at: trackIndex. - oldFullVol _ oldLeft max: oldRight. - oldFullVol = 0 ifTrue: [oldFullVol _ 1.0]. - oldLeft < oldFullVol - ifTrue: [ - left _ newVol * oldLeft / oldFullVol. - right _ newVol] - ifFalse: [ - left _ newVol. - right _ newVol * oldRight / oldFullVol]. - leftVols at: trackIndex put: left asInteger. - rightVols at: trackIndex put: right asInteger. -! ! -!ScorePlayer class methodsFor: 'instance creation' stamp: 'jm 1/29/98 18:18'! - onScore: aMIDIScore - - ^ self new onScore: aMIDIScore -! ! -!CompressedSoundData methodsFor: 'asSound' stamp: 'di 2/17/1999 08:15'! - asSound - "Answer the result of decompressing the receiver." - - | codecClass | - codecClass _ Smalltalk at: codecName - ifAbsent: [^ self error: 'The codec for decompressing this sound is not available']. - ^ (codecClass new decompressSound: self) reset -! ! -!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 08:10'! - channels - "Answer an array of ByteArrays containing the compressed sound data for each channel." - - ^ channels -! ! -!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:34'! - channels: anArray - - channels _ anArray. -! ! -!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:34'! - codecName - "Answer the name of the sound codec used to compress this sound. Typically, this is the name of a class that can be used to decode the sound, but it is possible that the codec has not yet been implemented or is not filed into this image." - - ^ codecName -! ! -!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:45'! - codecName: aStringOrSymbol - - codecName _ aStringOrSymbol asSymbol. -! ! -!CompressedSoundData methodsFor: 'as yet unclassified' stamp: 'RAA 12/8/2000 09:50'! - compressWith: codecClass - - codecName == codecClass name asSymbol ifTrue: [^self]. - ^self asSound compressWith: codecClass! ! -!CompressedSoundData methodsFor: 'as yet unclassified' stamp: 'RAA 12/24/2000 08:53'! - compressWith: codecClass atRate: aSamplingRate - - (codecName == codecClass name asSymbol and: [samplingRate = aSamplingRate]) ifTrue: [^self]. - ^self asSound compressWith: codecClass atRate: aSamplingRate! ! -!CompressedSoundData methodsFor: 'asSound' stamp: 'di 2/17/1999 08:49'! - doControl - - cachedSound doControl -! ! -!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:56'! - firstSample - "Answer the firstSample of the original sound." - - ^ firstSample -! ! -!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:56'! - firstSample: anInteger - - firstSample _ anInteger. -! ! -!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:55'! - gain - "Answer the gain of the original sound." - - ^ gain -! ! -!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:56'! - gain: aNumber - - gain _ aNumber. -! ! -!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 08:11'! - loopEnd - "Answer index of the last sample of the loop, or nil if the original sound was not looped." - - ^ loopEnd -! ! -!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:35'! - loopEnd: anInteger - - loopEnd _ anInteger. -! ! -!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 08:11'! - loopLength - "Answer length of the loop, or nil if the original sound was not looped." - - ^ loopLength -! ! -!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:35'! - loopLength: anInteger - - loopLength _ anInteger. -! ! -!CompressedSoundData methodsFor: 'asSound' stamp: 'di 2/17/1999 08:49'! - mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol - - cachedSound mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol -! ! -!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:39'! - perceivedPitch - "Answer the perceived pitch of the original sound. By convention, unpitched sounds (like drum hits) are given an arbitrary pitch of 100.0." - - ^ perceivedPitch -! ! -!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:39'! - perceivedPitch: aNumber - - perceivedPitch _ aNumber. -! ! -!CompressedSoundData methodsFor: 'asSound' stamp: 'jmv 3/1/2010 09:47'! -reset - "This message is the cue to start behaving like a real sound in order to be played. - We do this by caching a decompressed version of this sound. - See also samplesRemaining." - - cachedSound - ifNil: [cachedSound _ self asSound]. - cachedSound reset -! ! -!CompressedSoundData methodsFor: 'asSound' stamp: 'di 2/17/1999 20:44'! - samples - - ^ self asSound samples! ! -!CompressedSoundData methodsFor: 'asSound' stamp: 'di 2/17/1999 20:49'! - samplesRemaining - "This message is the cue that the cached sound may no longer be needed. - We know it is done playing when samplesRemaining=0." - - | samplesRemaining | - samplesRemaining _ cachedSound samplesRemaining. - samplesRemaining <= 0 ifTrue: [cachedSound _ nil]. - ^ samplesRemaining! ! -!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 08:13'! - samplingRate - "Answer the samplingRate of the original sound." - - ^ samplingRate -! ! -!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:36'! - samplingRate: aNumber - - samplingRate _ aNumber. -! ! -!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:46'! - soundClassName - "Answer the class name of the uncompressed sound." - - ^ soundClassName -! ! -!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:46'! - soundClassName: aStringOrSymbol - - soundClassName _ aStringOrSymbol asSymbol. -! ! -!Envelope methodsFor: 'accessing' stamp: 'jm 8/17/1998 15:20'! - attackTime - "Return the time taken by the attack phase." - - ^ (points at: loopStartIndex) x -! ! -!Envelope methodsFor: 'accessing' stamp: 'jm 8/13/1998 18:10'! - centerPitch: aNumber - "Set the center pitch of a pitch-controlling envelope. This default implementation does nothing." -! ! -!Envelope methodsFor: 'private' stamp: 'jm 11/26/97 09:03'! - checkParameters - "Verify that the point array, loopStartIndex, and loopStopIndex obey the rules." - - | lastT t | - points size > 1 - ifFalse: [^ self error: 'the point list must contain at least two points']. - points first x = 0 - ifFalse: [^ self error: 'the time of the first point must be zero']. - lastT _ points first x. - 2 to: points size do: [:i | - t _ (points at: i) x. - t >= lastT - ifFalse: [^ self error: 'the points must be in ascending time order']]. - - (loopStartIndex isInteger and: - [(loopStartIndex > 0) and: [loopStartIndex <= points size]]) - ifFalse: [^ self error: 'loopStartIndex is not a valid point index']. - (loopEndIndex isInteger and: - [(loopEndIndex > 0) and: [loopEndIndex <= points size]]) - ifFalse: [^ self error: 'loopEndIndex is not a valid point index']. - loopStartIndex <= loopEndIndex - ifFalse: [^ self error: 'loopEndIndex must not precede loopStartIndex']. -! ! -!Envelope methodsFor: 'private' stamp: 'jm 2/4/98 20:20'! - computeIncrementAt: mSecs between: p1 and: p2 scale: combinedScale - "Compute the current and increment values for the given time between the given inflection points." - "Assume: p1 x <= mSecs <= p2 x" - - | valueRange timeRange | - valueRange _ (p2 y - p1 y) asFloat. - timeRange _ (p2 x - p1 x) asFloat. - currValue _ (p1 y + (((mSecs - p1 x) asFloat / timeRange) * valueRange)) * combinedScale. - valueIncr _ (((p2 y * combinedScale) - currValue) / (p2 x - mSecs)) * 10.0. - ^ currValue -! ! -!Envelope methodsFor: 'applying' stamp: 'jmv 3/1/2010 14:04'! - computeValueAtMSecs: mSecs - "Return the value of this envelope at the given number of milliseconds from its onset. Return zero for times outside the time range of this envelope." - "Note: Unlike the private method incrementalComputeValueAtMSecs:, this method does is not increment. Thus it is slower, but it doesn't depend on being called sequentially at fixed time intervals." - - | t i | - mSecs < 0 ifTrue: [^ 0.0]. - - (loopEndMSecs notNil and: [mSecs >= loopEndMSecs]) ifTrue: [ "decay phase" - t _ (points at: loopEndIndex) x + (mSecs - loopEndMSecs). - i _ self indexOfPointAfterMSecs: t startingAt: loopEndIndex. - i ifNil: [^ 0.0]. "past end" - ^ (self interpolate: t between: (points at: i - 1) and: (points at: i)) * decayScale]. - - mSecs < loopStartMSecs ifTrue: [ "attack phase" - i _ self indexOfPointAfterMSecs: mSecs startingAt: 1. - i = 1 ifTrue: [^ (points at: 1) y * scale]. - ^ self interpolate: mSecs between: (points at: i - 1) and: (points at: i)]. - - "sustain phase" - loopMSecs = 0 ifTrue: [^ (points at: loopEndIndex) y * scale]. "looping on a single point" - t _ loopStartMSecs + ((mSecs - loopStartMSecs) \\ loopMSecs). - i _ self indexOfPointAfterMSecs: t startingAt: loopStartIndex. - - ^ self interpolate: t between: (points at: i - 1) and: (points at: i) -! ! -!Envelope methodsFor: 'accessing' stamp: 'jm 2/4/98 10:21'! - decayEndIndex - - ^ points size -! ! -!Envelope methodsFor: 'accessing' stamp: 'jm 11/26/97 08:53'! -decayTime - "Return the time taken by the decay phase." - - ^ points last x - (points at: loopEndIndex) x -! ! -!Envelope methodsFor: 'accessing' stamp: 'jmv 3/1/2010 10:00'! - duration - "Return the time of the final point." - - loopEndMSecs - ifNil: [^ points last x]. - ^ loopEndMSecs + self decayTime -! ! -!Envelope methodsFor: 'accessing' stamp: 'jm 8/19/1998 09:07'! - duration: seconds - "Set the note duration to the given number of seconds." - "Details: The duration is reduced by 19 mSec to ensure proper cutoffs even when the sound starts playing between doControl epochs." - "Note: This is a hack. With a little additional work on the envelope logic, it should be possible to reduce or eliminate this fudge factor. In particular, an envelope should use the time remaining, rather than time-since-start to determine when to enter its decay phase. In addition, an envelope must be able to cut off in minimum time (~5-10 msec) if there isn't enough time to do their normal decay. All of this is to allow instruments with leisurely decays to play very short notes if necessary (say, when fast-forwarding through a score)." - - | attack decay endTime | - endMSecs _ (seconds * 1000.0) asInteger - 19. - attack _ self attackTime. - decay _ self decayTime. - endMSecs > (attack + decay) - ifTrue: [endTime _ endMSecs - decay] - ifFalse: [ - endMSecs >= attack - ifTrue: [endTime _ attack] - ifFalse: [endTime _ endMSecs]]. - - self sustainEnd: (endTime max: 0). -! ! -!Envelope methodsFor: 'private' stamp: 'jmv 3/1/2010 14:05'! -incrementalComputeValueAtMSecs: mSecs - "Compute the current value, per-step increment, and the time of the next inflection point." - "Note: This method is part of faster, but less general, way of computing envelope values. It depends on a known, fixed control updating rate." - - | t i | - (loopEndMSecs notNil and: [mSecs >= loopEndMSecs]) ifTrue: [ "decay phase" - t _ (points at: loopEndIndex) x + (mSecs - loopEndMSecs). - i _ self indexOfPointAfterMSecs: t startingAt: loopEndIndex. - i ifNil: [ "past end" - currValue _ points last y * scale * decayScale. - valueIncr _ 0.0. - nextRecomputeTime _ mSecs + 1000000. - ^ currValue]. - nextRecomputeTime _ mSecs + ((points at: i) x - t). - ^ self computeIncrementAt: t - between: (points at: i - 1) - and: (points at: i) - scale: scale * decayScale]. - - mSecs < loopStartMSecs - ifTrue: [ "attack phase" - t _ mSecs. - i _ self indexOfPointAfterMSecs: t startingAt: 1. - nextRecomputeTime _ mSecs + ((points at: i) x - t)] - ifFalse: [ "sustain (looping) phase" - noChangesDuringLoop ifTrue: [ - currValue _ (points at: loopEndIndex) y * scale. - valueIncr _ 0.0. - loopEndMSecs - ifNil: [nextRecomputeTime _ mSecs + 10] "unknown end time" - ifNotNil: [nextRecomputeTime _ loopEndMSecs]. - ^ currValue]. - t _ loopStartMSecs + ((mSecs - loopStartMSecs) \\ loopMSecs). - i _ self indexOfPointAfterMSecs: t startingAt: loopStartIndex. - nextRecomputeTime _ (mSecs + ((points at: i) x - t)) min: loopEndMSecs]. - - ^ self computeIncrementAt: t - between: (points at: i - 1) - and: (points at: i) - scale: scale. -! ! -!Envelope methodsFor: 'private' stamp: 'jm 12/16/97 16:51'! - indexOfPointAfterMSecs: mSecs startingAt: startIndex - "Return the index of the first point whose time is greater that mSecs, starting with the given index. Return nil if mSecs is after the last point's time." - - startIndex to: points size do: - [:i | (points at: i) x > mSecs ifTrue: [^ i]]. - ^ nil -! ! -!Envelope methodsFor: 'private' stamp: 'jm 2/4/98 21:05'! - interpolate: mSecs between: p1 and: p2 - "Return the scaled, interpolated value for the given time between the given time points." - "Assume: p1 x <= mSecs <= p2 x" - - | valueRange timeRange | - valueRange _ (p2 y - p1 y) asFloat. - valueRange = 0.0 ifTrue: [^ p1 y * scale]. - timeRange _ (p2 x - p1 x) asFloat. - ^ (p1 y + (((mSecs - p1 x) asFloat / timeRange) * valueRange)) * scale. -! ! -!Envelope methodsFor: 'accessing' stamp: 'jm 2/4/98 17:24'! - loopEndIndex - - ^ loopEndIndex -! ! -!Envelope methodsFor: 'accessing' stamp: 'jm 2/4/98 17:24'! - loopStartIndex - - ^ loopStartIndex -! ! -!Envelope methodsFor: 'accessing' stamp: 'jm 8/13/1998 17:03'! - name - - ^ self updateSelector allButLast -! ! -!Envelope methodsFor: 'accessing' stamp: 'jm 2/4/98 17:24'! - points - - ^ points -! ! -!Envelope methodsFor: 'applying' stamp: 'jm 2/4/98 21:15'! - reset - "Reset the state for this envelope." - - lastValue _ -100000.0. "impossible value" - nextRecomputeTime _ 0. - self updateTargetAt: 0. -! ! -!Envelope methodsFor: 'accessing' stamp: 'jm 11/24/97 14:36'! - scale: aNumber - - scale _ aNumber asFloat. -! ! -!Envelope methodsFor: 'private' stamp: 'jm 2/4/98 17:52'! - setPoints: pointList loopStart: startIndex loopEnd: endIndex - - | lastVal | - points _ pointList asArray collect: [:p | p x asInteger @ p y asFloat]. - loopStartIndex _ startIndex. - loopEndIndex _ endIndex. - self checkParameters. - loopStartMSecs _ (points at: loopStartIndex) x. - loopMSecs _ (points at: loopEndIndex) x - (points at: loopStartIndex) x. - loopEndMSecs _ nil. "unknown end time; sustain until end time is known" - scale ifNil: [scale _ 1.0]. - decayScale ifNil: [decayScale _ 1.0]. - - "note if there are no changes during the loop phase" - noChangesDuringLoop _ true. - lastVal _ (points at: loopStartIndex) y. - loopStartIndex to: loopEndIndex do: [:i | - (points at: i) y ~= lastVal ifTrue: [ - noChangesDuringLoop _ false. - ^ self]]. -! ! -!Envelope methodsFor: 'applying' stamp: 'jm 2/4/98 17:39'! - showOnDisplay - "Envelope example showOnDisplay" - - | xOrigin yOrigin minVal maxVal yScale step x v y | - xOrigin _ 30. - yOrigin _ 130. - minVal _ 1e100. - maxVal _ -1e100. - points do: [:p | - p y < minVal ifTrue: [minVal _ p y]. - p y > maxVal ifTrue: [maxVal _ p y]]. - - yScale _ 100.0 / ((maxVal - minVal) * scale). - step _ (self duration // 150) max: 1. - - Display fillBlack: ((xOrigin + ((points at: loopStartIndex) x // step))@(yOrigin - 100) extent: 1@100). - Display fillBlack: ((xOrigin + ((points at: loopEndIndex) x // step))@(yOrigin - 100) extent: 1@100). - Display fillBlack: (xOrigin@(yOrigin - 100) extent: 1@100). - x _ xOrigin. - step negated to: self duration + step by: step do: [:mSecs | - v _ self computeValueAtMSecs: mSecs. - y _ yOrigin - ((v - minVal) * yScale) asInteger. - Display fillBlack: ((x - 1)@(y - 1) extent: 2@2). - Display fillBlack: (x@yOrigin extent: 1@1). - x _ x + 1]. -! ! -!Envelope methodsFor: 'storing' stamp: 'di 2/1/98 15:45'! - storeOn: strm - strm nextPutAll: '((' , self class name; - nextPutAll: ' points: '; store: (points collect: [:p | p x @ (p y roundTo: 0.00001)]); - nextPutAll: ' loopStart: '; print: loopStartIndex; - nextPutAll: ' loopEnd: '; print: loopEndIndex; nextPutAll: ')'; - nextPutAll: ' updateSelector: '; store: self updateSelector; nextPutAll: ';'; - nextPutAll: ' scale: '; print: scale; nextPutAll: ')'. -! ! -!Envelope methodsFor: 'applying' stamp: 'jm 2/4/98 18:27'! - sustainEnd: mSecs - "Set the ending time of the sustain phase of this envelope; the decay phase will start this point. Typically derived from a note's duration." - "Details: to avoid a sharp transient, the decay phase is scaled so that the beginning of the decay matches the envelope's instantaneous value when the decay phase starts." - - | vIfSustaining firstVOfDecay | - loopEndMSecs _ nil. "pretend to be sustaining" - decayScale _ 1.0. - nextRecomputeTime _ 0. - vIfSustaining _ self computeValueAtMSecs: mSecs. "get value at end of sustain phase" - loopEndMSecs _ mSecs. - firstVOfDecay _ (points at: loopEndIndex) y * scale. - firstVOfDecay = 0.0 - ifTrue: [decayScale _ 1.0] - ifFalse: [decayScale _ vIfSustaining / firstVOfDecay]. -! ! -!Envelope methodsFor: 'accessing' stamp: 'jm 11/26/97 09:25'! - target - - ^ target -! ! -!Envelope methodsFor: 'accessing' stamp: 'jm 11/26/97 09:25'! - target: anObject - - target _ anObject. -! ! -!Envelope methodsFor: 'accessing' stamp: 'jm 11/24/97 14:34'! - updateSelector - - ^ updateSelector -! ! -!Envelope methodsFor: 'accessing' stamp: 'jm 11/26/97 08:52'! - updateSelector: aSymbol - - updateSelector _ aSymbol. -! ! -!Envelope methodsFor: 'applying' stamp: 'jm 2/4/98 19:46'! - updateTargetAt: mSecs - "Send my updateSelector to the given target object with the value of this envelope at the given number of milliseconds from its onset. Answer true if the value changed." - - | newValue | - newValue _ self valueAtMSecs: mSecs. - newValue = lastValue ifTrue: [^ false]. - target - perform: updateSelector - with: newValue. - lastValue _ newValue. - ^ true -! ! -!Envelope methodsFor: 'applying' stamp: 'jm 2/4/98 20:24'! - valueAtMSecs: mSecs - "Return the value of this envelope at the given number of milliseconds from its onset. Return zero for times outside the time range of this envelope." - - mSecs < 0 ifTrue: [^ 0.0]. - mSecs < nextRecomputeTime - ifTrue: [currValue _ currValue + valueIncr] - ifFalse: [currValue _ self incrementalComputeValueAtMSecs: mSecs]. - ^ currValue -! ! -!Envelope methodsFor: 'accessing' stamp: 'jm 8/13/1998 18:13'! - volume: aNumber - "Set the maximum volume of a volume-controlling envelope. This default implementation does nothing." -! ! -!Envelope class methodsFor: 'instance creation' stamp: 'jm 11/26/97 09:14'! - example - "Envelope example showOnDisplay" - - | p | - p _ Array with: 0@0 with: 100@1.0 with: 250@0.7 with: 400@1.0 with: 500@0. - ^ (self points: p loopStart: 2 loopEnd: 4) sustainEnd: 1200. -! ! -!Envelope class methodsFor: 'instance creation' stamp: 'jm 2/4/98 06:52'! - exponentialDecay: multiplier - "(Envelope exponentialDecay: 0.95) showOnDisplay" - - | mSecsPerStep pList t v last | - mSecsPerStep _ 10. - ((multiplier > 0.0) and: [multiplier < 1.0]) - ifFalse: [self error: 'multiplier must be greater than 0.0 and less than 1.0']. - pList _ OrderedCollection new. - pList add: 0@0.0. - last _ 0.0. - v _ 1.0. - t _ 10. - [v > 0.01] whileTrue: [ - (v - last) abs > 0.02 ifTrue: [ - "only record substatial changes" - pList add: t@v. - last _ v]. - t _ t + mSecsPerStep. - v _ v * multiplier]. - pList add: (t + mSecsPerStep)@0.0. - - ^ self points: pList asArray - loopStart: pList size - loopEnd: pList size -! ! -!Envelope class methodsFor: 'instance creation' stamp: 'jm 11/26/97 08:49'! - points: pList loopStart: loopStart loopEnd: loopEnd - - ^ self new setPoints: pList asArray - loopStart: loopStart - loopEnd: loopEnd -! ! -!PitchEnvelope methodsFor: 'as yet unclassified' stamp: 'jm 1/31/98 14:46'! - centerPitch - - ^ centerPitch -! ! -!PitchEnvelope methodsFor: 'as yet unclassified' stamp: 'jm 1/31/98 14:49'! - centerPitch: aNumber - - centerPitch _ aNumber. -! ! -!PitchEnvelope methodsFor: 'as yet unclassified' stamp: 'jm 2/4/98 07:30'! - updateSelector - "Needed by the envelope editor." - - ^ #pitch: -! ! -!PitchEnvelope methodsFor: 'as yet unclassified' stamp: 'jm 2/4/98 21:11'! - updateTargetAt: mSecs - "Update the pitch for my target. Answer true if the value changed." - "Details: Assume envelope range is 0.0..2.0, with 1 being the center pitch. Subtracting one yields the range -1.0..1.0. Raising two to this power yields pitches between half and double the center pitch; i.e. from an octave below to an octave about the center pitch." - - | newValue | - newValue _ self valueAtMSecs: mSecs. - newValue ~= lastValue ifTrue: [ - target pitch: (2.0 raisedTo: newValue - (scale / 2.0)) * centerPitch. - lastValue _ newValue. - ^ true]. - - ^ false -! ! -!RandomEnvelope methodsFor: 'accessing' stamp: 'jm 8/13/1998 18:18'! - centerPitch: aNumber - "If this envelope controls pitch, set its scale to the given number. Otherwise, do nothing." - - updateSelector = #pitch: ifTrue: [self scale: aNumber]. -! ! -!RandomEnvelope methodsFor: 'accessing' stamp: 'jm 8/13/1998 17:06'! - delta - - ^ delta -! ! -!RandomEnvelope methodsFor: 'accessing' stamp: 'jm 8/13/1998 17:06'! - delta: aNumber - - delta _ aNumber. -! ! -!RandomEnvelope methodsFor: 'envelope compatibility' stamp: 'jm 8/13/1998 17:29'! - duration - - ^ 1.0 -! ! -!RandomEnvelope methodsFor: 'envelope compatibility' stamp: 'jm 8/13/1998 17:25'! - duration: seconds - "Do nothing." -! ! -!RandomEnvelope methodsFor: 'accessing' stamp: 'jm 8/13/1998 17:06'! - highLimit - - ^ highLimit -! ! -!RandomEnvelope methodsFor: 'accessing' stamp: 'jm 8/13/1998 17:06'! - highLimit: aNumber - - highLimit _ aNumber. -! ! -!RandomEnvelope methodsFor: 'initialization' stamp: 'jm 1/14/1999 13:15'! - initialize - - rand _ Random new. - lowLimit _ 0.994. - highLimit _ 1.006. - delta _ 0.0002. - currValue _ 1.0. - scale _ 1.0. -! ! -!RandomEnvelope methodsFor: 'accessing' stamp: 'jm 8/13/1998 17:05'! - lowLimit - - ^ lowLimit -! ! -!RandomEnvelope methodsFor: 'accessing' stamp: 'jm 8/13/1998 17:06'! - lowLimit: aNumber - - lowLimit _ aNumber. -! ! -!RandomEnvelope methodsFor: 'envelope compatibility' stamp: 'jm 1/14/1999 13:17'! - name - - ^ 'random ', updateSelector -! ! -!RandomEnvelope methodsFor: 'envelopeEditor compatibility' stamp: 'jmv 3/2/2010 16:25'! - points - - | env | - points ifNil: [ - env _ self target envelopes first. - points _ OrderedCollection new. - points - add: 0@(self delta * 5 + 0.5); - add: (env points at: env loopStartIndex)x@(self highLimit -1 * 5 + 0.5); - add: (env points at: env loopEndIndex)x@(self highLimit -1 * 5 + 0.5); - add: (env points last)x@(self lowLimit -1 * 5 + 0.5). - loopStartIndex _ 2. - loopEndIndex _ 3. - ]. - ^points! ! -!RandomEnvelope methodsFor: 'envelopeEditor compatibility' stamp: 'JMV 1/9/2001 13:08'! - setPoints: pointList loopStart: startIndex loopEnd: endIndex - - self delta: pointList first y - 0.5 / 5. - self highLimit: (pointList at: startIndex) y - 0.5 / 5 + 1. - self lowLimit: pointList last y - 0.5 / 5 + 1. - ^super setPoints: pointList loopStart: startIndex loopEnd: endIndex! ! -!RandomEnvelope methodsFor: 'envelope compatibility' stamp: 'jm 8/13/1998 17:30'! - sustainEnd: seconds - "Do nothing." -! ! -!RandomEnvelope methodsFor: 'applying' stamp: 'jm 8/13/1998 18:25'! - updateTargetAt: mSecs - "Send my updateSelector to the given target object with the value of this envelope at the given number of milliseconds from its onset. Answer true if the value changed." - - | r | - r _ rand next. - r > 0.5 - ifTrue: [ - currValue _ currValue + delta. - currValue > highLimit ifTrue: [currValue _ highLimit]] - ifFalse: [ - currValue _ currValue - delta. - currValue < lowLimit ifTrue: [currValue _ lowLimit]]. - currValue = lastValue ifTrue: [^ false]. - ((target == nil) or: [updateSelector == nil]) ifTrue: [^ false]. - target - perform: updateSelector - with: scale * currValue. - lastValue _ currValue. - ^ true -! ! -!RandomEnvelope methodsFor: 'accessing' stamp: 'jm 8/13/1998 18:17'! - volume: aNumber - "If this envelope controls volume, set its scale to the given number. Otherwise, do nothing." - - updateSelector = #volume: ifTrue: [self scale: aNumber]. -! ! -!RandomEnvelope class methodsFor: 'instance creation' stamp: 'jm 8/13/1998 18:21'! - for: aSelector - "Answer a random envelope for the given selector." - - ^ self new updateSelector: aSelector -! ! -!VolumeEnvelope methodsFor: 'as yet unclassified' stamp: 'jmv 3/1/2010 14:17'! - computeSlopeAtMSecs: mSecs - "Private!! Find the next inflection point of this envelope and compute its target volume and the number of milliseconds until the inflection point is reached." - - | t i | - ((loopEndMSecs notNil) and: [mSecs >= loopEndMSecs]) ifTrue: [ "decay phase" - t _ (points at: loopEndIndex) x + (mSecs - loopEndMSecs). - i _ self indexOfPointAfterMSecs: t startingAt: loopEndIndex. - i ifNil: [ "past end" - targetVol _ points last y * decayScale. - mSecsForChange _ 0. - nextRecomputeTime _ mSecs + 1000000. - ^ self]. - targetVol _ (points at: i) y * decayScale. - mSecsForChange _ (((points at: i) x - t) min: (endMSecs - mSecs)) max: 4. - nextRecomputeTime _ mSecs + mSecsForChange. - ^ self]. - - mSecs < loopStartMSecs ifTrue: [ "attack phase" - i _ self indexOfPointAfterMSecs: mSecs startingAt: 1. - targetVol _ (points at: i) y. - mSecsForChange _ ((points at: i) x - mSecs) max: 4. - nextRecomputeTime _ mSecs + mSecsForChange. - ((loopEndMSecs notNil) and: [nextRecomputeTime > loopEndMSecs]) - ifTrue: [nextRecomputeTime _ loopEndMSecs]. - ^ self]. - - "sustain and loop phase" - noChangesDuringLoop ifTrue: [ - targetVol _ (points at: loopEndIndex) y. - mSecsForChange _ 10. - loopEndMSecs - ifNil: [nextRecomputeTime _ mSecs + 10] "unknown end time" - ifNotNil: [nextRecomputeTime _ loopEndMSecs]. - ^ self]. - - loopMSecs = 0 ifTrue: [^ (points at: loopEndIndex) y]. "looping on a single point" - t _ loopStartMSecs + ((mSecs - loopStartMSecs) \\ loopMSecs). - i _ self indexOfPointAfterMSecs: t startingAt: loopStartIndex. - targetVol _ (points at: i) y. - mSecsForChange _ ((points at: i) x - t) max: 4. - nextRecomputeTime _ (mSecs + mSecsForChange) min: loopEndMSecs. -! ! -!VolumeEnvelope methodsFor: 'as yet unclassified' stamp: 'jm 2/4/98 18:51'! - reset - "Reset the state for this envelope." - - super reset. - target initialVolume: points first y * scale. - nextRecomputeTime _ 0. -! ! -!VolumeEnvelope methodsFor: 'as yet unclassified' stamp: 'jm 2/4/98 07:27'! - updateSelector - "Needed by the envelope editor." - - ^ #volume: -! ! -!VolumeEnvelope methodsFor: 'as yet unclassified' stamp: 'jm 9/10/1998 07:04'! - updateTargetAt: mSecs - "Update the volume envelope slope and limit for my target. Answer false." - - mSecs < nextRecomputeTime ifTrue: [^ false]. - self computeSlopeAtMSecs: mSecs. - mSecsForChange < 5 ifTrue: [mSecsForChange _ 5]. "don't change instantly to avoid clicks" - target adjustVolumeTo: targetVol * scale overMSecs: mSecsForChange. - ^ false -! ! -!VolumeEnvelope methodsFor: 'as yet unclassified' stamp: 'jm 8/17/1998 08:00'! - volume: aNumber - "Set the maximum volume of a volume-controlling envelope." - - scale _ aNumber asFloat. -! ! -!SampledInstrument methodsFor: 'other' stamp: 'jmv 8/23/2010 10:10'! - allNotes - "Answer a collection containing of all the unique sampled sounds used by this instrument." - - | r | - r _ IdentitySet new. - r addAll: sustainedLoud. - sustainedSoft ~~ sustainedLoud ifTrue: [r addAll: sustainedSoft]. - staccatoLoud ~~ sustainedLoud ifTrue: [r addAll: staccatoLoud]. - staccatoSoft ~~ staccatoLoud ifTrue: [r addAll: staccatoSoft]. - ^ r asArray sort: [:n1 :n2 | n1 pitch < n2 pitch]! ! -!SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/3/1998 17:30'! - allSampleSets: sortedNotes - - | keyMap | - keyMap _ self midiKeyMapFor: sortedNotes. - sustainedSoft _ keyMap. - sustainedLoud _ keyMap. - staccatoSoft _ keyMap. - staccatoLoud _ keyMap. -! ! -!SampledInstrument methodsFor: 'other' stamp: 'jm 8/2/1998 12:55'! - chooseSamplesForPitch: pitchInHz from: sortedNotes - "From the given collection of LoopedSampledSounds, choose the best one to be pitch-shifted to produce the given pitch." - "Assume: the given collection is sorted in ascending pitch order." - - | i lower higher | - i _ 1. - [(i < sortedNotes size) and: [(sortedNotes at: i) pitch < pitchInHz]] - whileTrue: [i _ i + 1]. - i = 1 ifTrue: [^ sortedNotes at: 1]. - lower _ sortedNotes at: i - 1. - higher _ sortedNotes at: i. - "note: give slight preference for down-shifting a higher-pitched sample set" - (pitchInHz / lower pitch) < ((0.95 * higher pitch) / pitchInHz) - ifTrue: [^ lower] - ifFalse: [^ higher]. -! ! -!SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/3/1998 19:04'! - initialize - - sustainedThreshold _ 0.15. - loudThreshold _ 0.5. -! ! -!SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/4/1998 23:21'! - loudThreshold - - ^ loudThreshold -! ! -!SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/4/1998 23:22'! - loudThreshold: aNumber - - loudThreshold _ aNumber asFloat. -! ! -!SampledInstrument methodsFor: 'other' stamp: 'jm 9/8/1998 16:24'! - memorySpace - "Answer the number of bytes required to store the samples for this instrument." - - | total | - total _ 0. - self allNotes do: [:n | - total _ total + (n leftSamples monoSampleCount * 2). - n isStereo ifTrue: [total _ total + (n leftSamples monoSampleCount * 2)]]. - ^ total -! ! -!SampledInstrument methodsFor: 'other' stamp: 'jm 8/3/1998 16:42'! - midiKeyMapFor: sortedNotes - "Return a 128 element array that maps each MIDI key number to the sampled note from the given set with the closests pitch. A precise match isn't necessary because the selected note will be pitch shifted to play at the correct pitch." - - ^ (0 to: 127) collect: [:k | - self - chooseSamplesForPitch: (AbstractSound pitchForMIDIKey: k) - from: sortedNotes]. -! ! -!SampledInstrument methodsFor: 'other' stamp: 'jm 8/18/1998 10:57'! - playChromaticRunFrom: startPitch to: endPitch - - (AbstractSound chromaticRunFrom: startPitch to: endPitch on: self) play. -! ! -!SampledInstrument methodsFor: 'other' stamp: 'jm 8/11/1998 15:52'! - pruneNoteList: aNoteList notesPerOctave: notesPerOctave - "Return a pruned version of the given note list with only the given number of notes per octave. Assume the given notelist is in sorted order." - - | r interval lastPitch | - r _ OrderedCollection new: aNoteList size. - interval _ (2.0 raisedTo: (1.0 / notesPerOctave)) * 0.995. - lastPitch _ 0.0. - aNoteList do: [:n | - n pitch > (lastPitch * interval) ifTrue: [ - r addLast: n. - lastPitch _ n pitch]]. - ^ r -! ! -!SampledInstrument methodsFor: 'other' stamp: 'jm 8/6/1998 00:39'! - pruneToNotesPerOctave: notesPerOctave - "Prune all my keymaps to the given number of notes per octave." - - sustainedLoud _ self midiKeyMapFor: - (self pruneNoteList: sustainedLoud notesPerOctave: notesPerOctave). - sustainedSoft _ self midiKeyMapFor: - (self pruneNoteList: sustainedSoft notesPerOctave: notesPerOctave). - staccatoLoud _ self midiKeyMapFor: - (self pruneNoteList: staccatoLoud notesPerOctave: notesPerOctave). - staccatoSoft _ self midiKeyMapFor: - (self pruneNoteList: staccatoSoft notesPerOctave: notesPerOctave). -! ! -!SampledInstrument methodsFor: 'other' stamp: 'jm 8/11/1998 14:44'! - pruneToSingleNote: aNote - "Fill all my keymaps with the given note." - - | oneNoteMap | - oneNoteMap _ Array new: 128 withAll: aNote. - sustainedLoud _ oneNoteMap. - sustainedSoft _ oneNoteMap. - staccatoLoud _ oneNoteMap. - staccatoSoft _ oneNoteMap. -! ! -!SampledInstrument methodsFor: 'other' stamp: 'jmv 10/14/2015 17:46'! - readSampleSetFrom: dirName - "Answer a collection of sounds read from AIFF files in the given directory and sorted in ascending pitch order." - - | all dir fullName snd | - all _ SortedCollection sortBlock: [:s1 :s2 | s1 pitch < s2 pitch]. - dir _ dirName asDirectoryEntry. - dir fileNames do: [ :n | - fullName _ (dir / n) pathName. - Utilities - informUser: 'Reading AIFF file ', n - during: [ - snd _ LoopedSampledSound new - fromAIFFFileNamed: fullName - mergeIfStereo: true]. - all add: snd]. - ^ all asArray! ! -!SampledInstrument methodsFor: 'other' stamp: 'jmv 10/14/2015 17:47'! - readSampleSetInfoFrom: dirName - "MessageTally spyOn: [SampledInstrument new readSampleSetFrom: 'Tosh:Desktop Folder:AAA Squeak2.0 Beta:Organ Samples:Flute8'] timeToRun" - - | all dir fullName info | - all _ OrderedCollection new. - dir _ dirName asDirectoryEntry. - dir fileNames do: [ :n | - fullName _ (dir / n) pathName. - info _ AIFFFileReader new readFromFile: fullName - mergeIfStereo: false - skipDataChunk: true. - all add: n -> info]. - ^ all -! ! -!SampledInstrument methodsFor: 'playing' stamp: 'jm 8/3/1998 18:53'! - soundForMidiKey: midiKey dur: d loudness: l - "Answer an initialized sound object that generates a note for the given MIDI key (in the range 0..127), duration (in seconds), and loudness (in the range 0.0 to 1.0)." - - | keymap note | - l >= loudThreshold - ifTrue: [ - d >= sustainedThreshold - ifTrue: [keymap _ sustainedLoud] - ifFalse: [keymap _ staccatoLoud]] - ifFalse: [ - d >= sustainedThreshold - ifTrue: [keymap _ sustainedSoft] - ifFalse: [keymap _ staccatoSoft]]. - keymap ifNil: [keymap _ sustainedLoud]. - note _ (keymap at: midiKey) copy. - ^ note - setPitch: (AbstractSound pitchForMIDIKey: midiKey) - dur: d - loudness: (l * note gain) -! ! -!SampledInstrument methodsFor: 'playing' stamp: 'jm 8/3/1998 16:53'! - soundForPitch: pitchNameOrNumber dur: d loudness: l - "Answer an initialized sound object that generates a note of the given pitch, duration, and loudness. Pitch may be a numeric pitch or a string pitch name such as 'c4'. Duration is in seconds and loudness is in the range 0.0 to 1.0." - "Note: Generally, SampledInstruments are expected to be played via MIDI key numbers rather than by pitches, since finding the MIDI key for a given pitch is expensive." - - ^ self soundForMidiKey: (AbstractSound midiKeyForPitch: pitchNameOrNumber) - dur: d - loudness: l -! ! -!SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/2/1998 10:02'! - staccatoLoudAndSoftSampleSet: sortedNotes - - staccatoLoud _ self midiKeyMapFor: sortedNotes. - staccatoSoft _ staccatoLoud. -! ! -!SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/2/1998 09:54'! - staccatoLoudSampleSet: sortedNotes - - staccatoLoud _ self midiKeyMapFor: sortedNotes. -! ! -!SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/2/1998 09:54'! -staccatoSoftSampleSet: sortedNotes - - staccatoSoft _ self midiKeyMapFor: sortedNotes. -! ! -!SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/2/1998 09:54'! -sustainedLoudSampleSet: sortedNotes - - sustainedLoud _ self midiKeyMapFor: sortedNotes. -! ! -!SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/2/1998 09:54'! - sustainedSoftSampleSet: sortedNotes - - sustainedSoft _ self midiKeyMapFor: sortedNotes. -! ! -!SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/4/1998 23:21'! - sustainedThreshold - - ^ sustainedThreshold -! ! -!SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/4/1998 23:22'! - sustainedThreshold: aNumber - - sustainedThreshold _ aNumber asFloat. -! ! -!SampledInstrument methodsFor: 'other' stamp: 'jm 8/4/1998 23:13'! - testAtPitch: aPitch - "SampledInstrument testAtPitch: 'c4'" - - | pattern | - pattern _ (#( - (c4 0.64 100) - (c4 0.64 200) - (c4 0.64 400) - (c4 0.64 600) - (c4 0.64 800) - (c4 1.28 1000) - (c4 1.28 400) - (c4 0.32 500) - (c4 0.32 500) - (c4 0.32 500) - (c4 0.32 500) - (c4 0.16 500) - (c4 0.16 500) - (c4 0.16 500) - (c4 0.16 500) - (c4 0.16 500) - (c4 0.08 500) - (c4 0.08 500) - (c4 0.16 500) - (c4 0.08 500) - (c4 0.08 500) - (c4 0.64 500)) - collect: [:triple | triple copy at: 1 put: aPitch; yourself]). - (AbstractSound noteSequenceOn: self from: pattern) play. -! ! -!SampledInstrument methodsFor: 'other' stamp: 'jm 8/5/1998 15:16'! - trimAttackOf: sampleBuffer threshold: threshold - "Trim 'silence' off the initial attacks of the given sound buffer." - - (sustainedSoft, sustainedLoud, staccatoSoft, staccatoLoud) do: [:snd | - snd leftSamples: (self trimAttackOf: snd leftSamples threshold: threshold). - snd isStereo ifTrue: [ - snd rightSamples: - (self trimAttackOf: snd rightSamples threshold: threshold)]]. -! ! -!SampledInstrument methodsFor: 'other' stamp: 'jm 8/5/1998 11:07'! - trimAttacks: threshold - "Trim 'silence' off the initial attacks all my samples." - - (sustainedSoft, sustainedLoud, staccatoSoft, staccatoLoud) do: [:snd | - snd leftSamples: (self trimAttackOf: snd leftSamples threshold: threshold). - snd isStereo ifTrue: [ - snd rightSamples: - (self trimAttackOf: snd rightSamples threshold: threshold)]]. -! ! -!SampledInstrument class methodsFor: 'instance creation' stamp: 'jm 6/7/1999 11:26'! - buildSmallOrchestra - "Example of how to build a skeleton orchestra that uses less memory (about 14 MBytes)." - "SampledInstrument buildSmallOrchestra" - - | dir | - AbstractSound unloadSampledTimbres. - dir _ 'Tosh:Not Backed Up:Sample Library:Orchestra'. - #(clarinet oboe bassoon trombone tympani) do: [:instName | - SampledInstrument - readSimpleInstrument: instName - fromDirectory: dir. - (AbstractSound soundNamed: instName, '-f') pruneToNotesPerOctave: 1]. - #(flute bass) do: [:instName | - SampledInstrument - readSimpleInstrument: instName - fromDirectory: dir. - (AbstractSound soundNamed: instName, '-f') pruneToNotesPerOctave: 2]. - - (AbstractSound soundNamed: 'bass-f') allNotes do: [:n | - n firstSample: (n findStartPointForThreshold: 2500)]. - - (AbstractSound soundNamed: 'bassoon-f') allNotes do: [:n | - n beUnlooped. - n firstSample: (n findStartPointForThreshold: 0)]. - - (AbstractSound soundNamed: 'trombone-f') allNotes do: [:n | - n firstSample: (n findStartPointForThreshold: 1800)]. - - AbstractSound soundNamed: 'trumpet-f' put: (AbstractSound soundNamed: 'trombone-f'). - AbstractSound soundNamed: 'horn-f' put: (AbstractSound soundNamed: 'trombone-f'). - AbstractSound soundNamed: 'violin-f' put: (AbstractSound soundNamed: 'bass-f'). - AbstractSound soundNamed: 'viola-f' put: (AbstractSound soundNamed: 'bass-f'). - AbstractSound soundNamed: 'cello-f' put: (AbstractSound soundNamed: 'bass-f'). - - (AbstractSound soundNamed: 'bassoon-f') allNotes do: [:n | n beUnlooped]. - -! ! -!SampledInstrument class methodsFor: 'instance creation' stamp: 'jmv 3/13/2012 12:44'! - readLoudAndStaccatoInstrument: instName fromDirectory: orchestraDir - "SampledInstrument - readLoudAndStaccatoInstrument: 'oboe' - fromDirectory: 'Tosh:Sample Library:Orchestra'" - - | sampleSetDir memBefore memAfter loud short snd | - sampleSetDir _ orchestraDir, ':', instName. - memBefore _ Smalltalk garbageCollect. - loud _ SampledInstrument new readSampleSetFrom: sampleSetDir, ' f'. - short _ SampledInstrument new readSampleSetFrom: sampleSetDir, ' stacc'. - memAfter _ Smalltalk garbageCollect. - Transcript show: - instName, ': ', (memBefore - memAfter) printString, - ' bytes; ', memAfter printString, ' bytes left'; newLine. - AbstractSound soundNamed: instName, '-f&stacc' put: - (snd _ SampledInstrument new - allSampleSets: loud; - staccatoLoudAndSoftSampleSet: short). - "fix slow attacks" - snd allNotes do: [:n | n firstSample: (n findStartPointForThreshold: 500)]. - - AbstractSound soundNamed: instName, '-f' put: - (snd _ SampledInstrument new - allSampleSets: loud). - "fix slow attacks" - snd allNotes do: [:n | n firstSample: (n findStartPointForThreshold: 1000)]. -! ! -!SampledInstrument class methodsFor: 'instance creation' stamp: 'jmv 3/13/2012 12:44'! - readPizzInstrument: instName fromDirectory: orchestraDir - "SampledInstrument - readPizzInstrument: 'violin' - fromDirectory: 'Tosh:Sample Library:Orchestra'" - - | sampleSetDir memBefore memAfter sampleSet snd | - sampleSetDir _ orchestraDir, ':', instName, ' pizz'. - memBefore _ Smalltalk garbageCollect. - sampleSet _ SampledInstrument new readSampleSetFrom: sampleSetDir. - memAfter _ Smalltalk garbageCollect. - Transcript show: - instName, ': ', (memBefore - memAfter) printString, - ' bytes; ', memAfter printString, ' bytes left'; newLine. - AbstractSound soundNamed: instName, '-pizz' put: - (snd _ SampledInstrument new allSampleSets: sampleSet). - - "fix slow attacks" - snd allNotes do: [:n | - n firstSample: (n findStartPointForThreshold: 1000)]. - - ^ snd -! ! -!SampledInstrument class methodsFor: 'instance creation' stamp: 'jmv 3/13/2012 12:45'! - readSimpleInstrument: instName fromDirectory: orchestraDir - "SampledInstrument - readSimpleInstrument: 'oboe' - fromDirectory: 'Tosh:Sample Library:Orchestra'" - - | sampleSetDir memBefore memAfter sampleSet snd | - sampleSetDir _ orchestraDir, ':', instName, ' f'. - memBefore _ Smalltalk garbageCollect. - sampleSet _ SampledInstrument new readSampleSetFrom: sampleSetDir. - memAfter _ Smalltalk garbageCollect. - Transcript show: - instName, ': ', (memBefore - memAfter) printString, - ' bytes; ', memAfter printString, ' bytes left'; newLine. - AbstractSound soundNamed: instName, '-f' put: - (snd _ SampledInstrument new allSampleSets: sampleSet). - - "fix slow attacks" - snd allNotes do: [:n | - n firstSample: (n findStartPointForThreshold: 1000)]. - - ^ snd -! ! -!SoundCodec methodsFor: 'subclass responsibilities' stamp: 'di 2/8/1999 14:23'! - bytesPerEncodedFrame - "Answer the number of bytes required to hold one frame of compressed sound data. Answer zero if this codec produces encoded frames of variable size." - - self subclassResponsibility. -! ! -!SoundCodec methodsFor: 'compress/decompress' stamp: 'jm 2/2/1999 16:01'! - compressAndDecompress: aSound - "Compress and decompress the given sound. Useful for testing." - "(MuLawCodec new compressAndDecompress: (SampledSound soundNamed: 'camera')) play" - - ^ (self compressSound: aSound) asSound -! ! -!SoundCodec methodsFor: 'compress/decompress' stamp: 'jm 2/2/1999 16:01'! - compressSound: aSound - "Compress the entirety of the given sound with this codec. Answer a CompressedSoundData." - - | compressed channels | - compressed _ CompressedSoundData new - codecName: self class name; - soundClassName: aSound class name. - (aSound isKindOf: SampledSound) ifTrue: [ - channels _ Array new: 1. - channels at: 1 put: (self encodeSoundBuffer: aSound samples). - compressed - channels: channels; - samplingRate: aSound originalSamplingRate; - firstSample: 1; - loopEnd: aSound samples size; - loopLength: 0.0; - perceivedPitch: 100.0; - gain: aSound loudness. - ^ compressed]. - (aSound isKindOf: LoopedSampledSound) ifTrue: [ - aSound isStereo - ifTrue: [ - channels _ Array new: 2. - channels at: 1 put: (self encodeSoundBuffer: aSound leftSamples). - channels at: 2 put: (self encodeSoundBuffer: aSound rightSamples)] - ifFalse: [ - channels _ Array new: 1. - channels at: 1 put: (self encodeSoundBuffer: aSound leftSamples)]. - compressed - channels: channels; - samplingRate: aSound originalSamplingRate; - firstSample: aSound firstSample; - loopEnd: aSound loopEnd; - loopLength: aSound loopLength; - perceivedPitch: aSound perceivedPitch; - gain: aSound gain. - ^ compressed]. - self error: 'you can only compress sampled sounds'. -! ! -!SoundCodec methodsFor: 'compress/decompress' stamp: 'RAA 1/2/2001 10:17'! - compressSound: aSound atRate: desiredSampleRate - "Compress the entirety of the given sound with this codec. Answer a CompressedSoundData." - - | compressed channels samples newRate ratio buffer | - - compressed _ CompressedSoundData new - codecName: self class name; - soundClassName: aSound class name. - (aSound isKindOf: SampledSound) ifTrue: [ - (desiredSampleRate isNil or: - [(ratio _ aSound originalSamplingRate // desiredSampleRate) <= 1]) ifTrue: [ - samples _ aSound samples. - newRate _ aSound originalSamplingRate. - ] ifFalse: [ - buffer _ aSound samples. - samples _ SoundBuffer - averageEvery: ratio - from: buffer - upTo: buffer monoSampleCount. - newRate _ aSound originalSamplingRate / ratio. - ]. - - channels _ Array new: 1. - channels at: 1 put: (self encodeSoundBuffer: samples). - compressed - channels: channels; - samplingRate: newRate; - firstSample: 1; - loopEnd: samples size; - loopLength: 0.0; - perceivedPitch: 100.0; - gain: aSound loudness. - ^ compressed]. - (aSound isKindOf: LoopedSampledSound) ifTrue: [ - aSound isStereo - ifTrue: [ - channels _ Array new: 2. - channels at: 1 put: (self encodeSoundBuffer: aSound leftSamples). - channels at: 2 put: (self encodeSoundBuffer: aSound rightSamples)] - ifFalse: [ - channels _ Array new: 1. - channels at: 1 put: (self encodeSoundBuffer: aSound leftSamples)]. - compressed - channels: channels; - samplingRate: aSound originalSamplingRate; - firstSample: aSound firstSample; - loopEnd: aSound loopEnd; - loopLength: aSound loopLength; - perceivedPitch: aSound perceivedPitch; - gain: aSound gain. - ^ compressed]. - self error: 'you can only compress sampled sounds'. -! ! -!SoundCodec methodsFor: 'private' stamp: 'di 2/8/1999 19:53'! - decodeCompressedData: aByteArray - "Decode the entirety of the given encoded data buffer with this codec. Answer a monophonic SoundBuffer containing the uncompressed samples." - - | frameCount result increments | - frameCount _ self frameCount: aByteArray. - result _ SoundBuffer newMonoSampleCount: frameCount * self samplesPerFrame. - self reset. - increments _ self decodeFrames: frameCount from: aByteArray at: 1 into: result at: 1. - ((increments first = aByteArray size) and: [increments last = result size]) ifFalse: [ - self error: 'implementation problem; increment sizes should match buffer sizes']. - ^ result -! ! -!SoundCodec methodsFor: 'subclass responsibilities' stamp: 'jm 2/2/1999 15:38'! - decodeFrames: frameCount from: srcByteArray at: srcIndex into: dstSoundBuffer at: dstIndex - "Decode the given number of monophonic frames starting at the given index in the given ByteArray of compressed sound data and storing the decoded samples into the given SoundBuffer starting at the given destination index. Answer a pair containing the number of bytes of compressed data consumed and the number of decompressed samples produced." - "Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers." - - self subclassResponsibility. -! ! -!SoundCodec methodsFor: 'compress/decompress' stamp: 'jm 3/30/1999 08:03'! - decompressSound: aCompressedSound - "Decompress the entirety of the given compressed sound with this codec and answer the resulting sound." - - | channels sound | - channels _ aCompressedSound channels - collect: [:compressed | self decodeCompressedData: compressed]. - 'SampledSound' = aCompressedSound soundClassName ifTrue: [ - sound _ SampledSound - samples: channels first - samplingRate: (aCompressedSound samplingRate). - sound loudness: aCompressedSound gain. - ^ sound]. - 'LoopedSampledSound' = aCompressedSound soundClassName ifTrue: [ - aCompressedSound loopLength = 0 - ifTrue: [ - sound _ LoopedSampledSound - unloopedSamples: channels first - pitch: aCompressedSound perceivedPitch - samplingRate: aCompressedSound samplingRate] - ifFalse: [ - sound _ LoopedSampledSound - samples: channels first - loopEnd: aCompressedSound loopEnd - loopLength: aCompressedSound loopLength - pitch: aCompressedSound perceivedPitch - samplingRate: aCompressedSound samplingRate]. - channels size > 1 ifTrue: [sound rightSamples: channels last]. - sound - firstSample: aCompressedSound firstSample; - gain: aCompressedSound gain. - sound - setPitch: 100.0 - dur: (channels first size / aCompressedSound samplingRate) - loudness: 1.0. - ^ sound]. - self error: 'unknown sound class'. -! ! -!SoundCodec methodsFor: 'subclass responsibilities' stamp: 'jm 2/2/1999 15:39'! - encodeFrames: frameCount from: srcSoundBuffer at: srcIndex into: dstByteArray at: dstIndex - "Encode the given number of frames starting at the given index in the given monophonic SoundBuffer and storing the encoded sound data into the given ByteArray starting at the given destination index. Encode only as many complete frames as will fit into the destination. Answer a pair containing the number of samples consumed and the number of bytes of compressed data produced." - "Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers." - - self subclassResponsibility. -! ! -!SoundCodec methodsFor: 'private' stamp: 'di 2/8/1999 14:20'! -encodeSoundBuffer: aSoundBuffer - "Encode the entirety of the given monophonic SoundBuffer with this codec. Answer a ByteArray containing the compressed sound data." - - | codeFrameSize frameSize fullFrameCount lastFrameSamples result increments finalFrame i lastIncs | - frameSize _ self samplesPerFrame. - fullFrameCount _ aSoundBuffer monoSampleCount // frameSize. - lastFrameSamples _ aSoundBuffer monoSampleCount - (fullFrameCount * frameSize). - codeFrameSize _ self bytesPerEncodedFrame. - codeFrameSize = 0 ifTrue: - ["Allow room for 1 byte per sample for variable-length compression" - codeFrameSize _ frameSize]. - lastFrameSamples > 0 - ifTrue: [result _ ByteArray new: (fullFrameCount + 1) * codeFrameSize] - ifFalse: [result _ ByteArray new: fullFrameCount * codeFrameSize]. - self reset. - increments _ self encodeFrames: fullFrameCount from: aSoundBuffer at: 1 into: result at: 1. - lastFrameSamples > 0 ifTrue: [ - finalFrame _ SoundBuffer newMonoSampleCount: frameSize. - i _ fullFrameCount * frameSize. - 1 to: lastFrameSamples do: [:j | - finalFrame at: j put: (aSoundBuffer at: (i _ i + 1))]. - lastIncs _ self encodeFrames: 1 from: finalFrame at: 1 into: result at: 1 + increments second. - increments _ Array with: increments first + lastIncs first - with: increments second + lastIncs second]. - increments second < result size - ifTrue: [^ result copyFrom: 1 to: increments second] - ifFalse: [^ result] -! ! -!SoundCodec methodsFor: 'private' stamp: 'di 2/8/1999 19:54'! - frameCount: aByteArray - "Compute the frame count for this byteArray. This default computation will have to be overridden by codecs with variable frame sizes." - - | codeFrameSize | - codeFrameSize _ self bytesPerEncodedFrame. - (aByteArray size \\ codeFrameSize) = 0 ifFalse: - [self error: 'encoded buffer is not an even multiple of the encoded frame size']. - ^ aByteArray size // codeFrameSize! ! -!SoundCodec methodsFor: 'subclass responsibilities' stamp: 'jm 2/4/1999 11:30'! - reset - "Reset my encoding and decoding state. Optional. This default implementation does nothing." -! ! -!SoundCodec methodsFor: 'subclass responsibilities' stamp: 'jm 2/2/1999 15:45'! - samplesPerFrame - "Answer the number of sound samples per compression frame." - - self subclassResponsibility. -! ! -!ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 12/12/2001 17:57'! - bytesPerEncodedFrame - "Answer the number of bytes required to hold one frame of compressed sound data." - "Note: When used as a normal codec, the frame size is always 8 samples which results in (8 * bitsPerSample) / 8 = bitsPerSample bytes." - - | bitCount | - frameSizeMask = 0 ifTrue: [^ bitsPerSample]. - "Following assumes mono:" - bitCount _ 16 + 6 + ((self samplesPerFrame - 1) * bitsPerSample). - ^ (bitCount + 7) // 8 -! ! -!ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 7/2/1999 13:29'! - compressAndDecompress: aSound - "Compress and decompress the given sound. Overridden to use same bits per sample for both compressing and decompressing." - - | compressed decoder | - compressed _ self compressSound: aSound. - decoder _ self class new - initializeForBitsPerSample: bitsPerSample - samplesPerFrame: 0. - ^ decoder decompressSound: compressed - -! ! -!ADPCMCodec methodsFor: 'private' stamp: 'jm 3/28/1999 06:26'! - decode: aByteArray bitsPerSample: bits - - ^ self - decode: aByteArray - sampleCount: (aByteArray size * 8) // bits - bitsPerSample: bits - frameSize: 0 - stereo: false -! ! -!ADPCMCodec methodsFor: 'private' stamp: 'jm 3/28/1999 15:57'! - decode: aByteArray sampleCount: count bitsPerSample: bits frameSize: frameSize stereo: stereoFlag - - self initializeForBitsPerSample: bits samplesPerFrame: frameSize. - encodedBytes _ aByteArray. - byteIndex _ 0. - bitPosition _ 0. - currentByte _ 0. - stereoFlag - ifTrue: [ - self resetForStereo. - samples _ SoundBuffer newMonoSampleCount: count. - rightSamples _ SoundBuffer newMonoSampleCount: count. - sampleIndex _ 0. - self privateDecodeStereo: count. - ^ Array with: samples with: rightSamples] - ifFalse: [ - samples _ SoundBuffer newMonoSampleCount: count. - sampleIndex _ 0. - self privateDecodeMono: count. - ^ samples] -! ! -!ADPCMCodec methodsFor: 'private' stamp: 'jm 3/30/1999 08:56'! -decodeFlash: aByteArray sampleCount: sampleCount stereo: stereoFlag - - | bits | - encodedBytes _ aByteArray. - byteIndex _ 0. - bitPosition _ 0. - currentByte _ 0. - bits _ 2 + (self nextBits: 2). "bits per sample" - self initializeForBitsPerSample: bits samplesPerFrame: 4096. - stereoFlag - ifTrue: [ - self resetForStereo. - samples _ SoundBuffer newMonoSampleCount: sampleCount. - rightSamples _ SoundBuffer newMonoSampleCount: sampleCount. - sampleIndex _ 0. - self privateDecodeStereo: sampleCount. - ^ Array with: samples with: rightSamples] - ifFalse: [ - samples _ SoundBuffer newMonoSampleCount: sampleCount. - sampleIndex _ 0. - self privateDecodeMono: sampleCount. - ^ Array with: samples]. -! ! -!ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 3/28/1999 15:37'! - decodeFrames: frameCount from: srcByteArray at: srcIndex into: dstSoundBuffer at: dstIndex - "Decode the given number of monophonic frames starting at the given index in the given ByteArray of compressed sound data and storing the decoded samples into the given SoundBuffer starting at the given destination index. Answer a pair containing the number of bytes of compressed data consumed and the number of decompressed samples produced." - "Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers." - - encodedBytes _ srcByteArray. - byteIndex _ srcIndex - 1. - bitPosition _ 0. - currentByte _ 0. - samples _ dstSoundBuffer. - sampleIndex _ dstIndex - 1. - self privateDecodeMono: (frameCount * self samplesPerFrame). - ^ Array with: (byteIndex - (srcIndex - 1)) with: (sampleIndex - (dstIndex - 1)) -! ! -!ADPCMCodec methodsFor: 'private' stamp: 'jm 3/28/1999 08:59'! - encode: aSoundBuffer bitsPerSample: bits - - ^ self - encodeLeft: aSoundBuffer - right: nil - bitsPerSample: bits - frameSize: 0 - forFlash: false -! ! -!ADPCMCodec methodsFor: 'private' stamp: 'jm 3/28/1999 08:58'! - encodeFlashLeft: leftSoundBuffer right: rightSoundBuffer bitsPerSample: bits - - ^ self - encodeLeft: leftSoundBuffer - right: rightSoundBuffer - bitsPerSample: bits - frameSize: 4096 - forFlash: true -! ! -!ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 3/28/1999 15:28'! - encodeFrames: frameCount from: srcSoundBuffer at: srcIndex into: dstByteArray at: dstIndex - "Encode the given number of frames starting at the given index in the given monophonic SoundBuffer and storing the encoded sound data into the given ByteArray starting at the given destination index. Encode only as many complete frames as will fit into the destination. Answer a pair containing the number of samples consumed and the number of bytes of compressed data produced." - "Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers." - - samples _ srcSoundBuffer. - sampleIndex _ srcIndex - 1. - encodedBytes _ dstByteArray. - byteIndex _ dstIndex - 1. - bitPosition _ 0. - currentByte _ 0. - self privateEncodeMono: (frameCount * self samplesPerFrame). - ^ Array with: frameCount with: (byteIndex - (dstIndex - 1)) -! ! -!ADPCMCodec methodsFor: 'private' stamp: 'jm 11/21/2001 11:35'! - encodeLeft: leftSoundBuffer right: rightSoundBuffer bitsPerSample: bits frameSize: frameSize forFlash: flashFlag - - | stereoFlag sampleCount sampleBitCount bitCount | - self initializeForBitsPerSample: bits samplesPerFrame: frameSize. - stereoFlag _ rightSoundBuffer notNil. - sampleCount _ leftSoundBuffer monoSampleCount. - stereoFlag - ifTrue: [sampleBitCount _ 2 * (sampleCount * bitsPerSample)] - ifFalse: [sampleBitCount _ sampleCount * bitsPerSample]. - bitCount _ sampleBitCount + - (self headerBitsForSampleCount: sampleCount stereoFlag: stereoFlag). - - encodedBytes _ ByteArray new: ((bitCount / 8) ceiling roundUpTo: self bytesPerEncodedFrame). - byteIndex _ 0. - bitPosition _ 0. - currentByte _ 0. - flashFlag ifTrue: [self nextBits: 2 put: bits - 2]. - stereoFlag - ifTrue: [ - samples _ Array with: leftSoundBuffer with: rightSoundBuffer. - sampleIndex _ Array with: 0 with: 0. - self privateEncodeStereo: sampleCount] - ifFalse: [ - samples _ leftSoundBuffer. - sampleIndex _ 0. - self privateEncodeMono: sampleCount]. - - ^ encodedBytes -! ! -!ADPCMCodec methodsFor: 'private' stamp: 'jm 3/27/1999 12:14'! - headerBitsForSampleCount: sampleCount stereoFlag: stereoFlag - "Answer the number of extra header bits required for the given number of samples. This will be zero if I am not using frame headers." - - | frameCount bitsPerHeader | - frameSizeMask = 0 ifTrue: [^ 0]. - frameCount _ (sampleCount / self samplesPerFrame) ceiling. - bitsPerHeader _ 16 + 6. - stereoFlag ifTrue: [bitsPerHeader _ 2 * bitsPerHeader]. - ^ frameCount * bitsPerHeader -! ! -!ADPCMCodec methodsFor: 'private' stamp: 'jm 3/28/1999 16:08'! - indexForDeltaFrom: thisSample to: nextSample - "Answer the best index to use for the difference between the given samples." - "Details: Scan stepSizeTable for the first entry >= the absolute value of the difference between sample values. Since indexes are zero-based, the index used during decoding will be the one in the following stepSizeTable entry. Since the index field of a Flash frame header is only six bits, the maximum index value is 63." - "Note: Since there does not appear to be any documentation of how Flash acutally computes the indices used in its frame headers, this algorithm was guessed by reverse-engineering the Flash ADPCM decoder." - - | diff bestIndex | - self inline: true. - - diff _ nextSample - thisSample. - diff < 0 ifTrue: [diff _ 0 - diff]. - bestIndex _ 63. - 1 to: 62 do: [:j | - bestIndex = 63 ifTrue: [ - (stepSizeTable at: j) >= diff ifTrue: [bestIndex _ j]]]. - ^ bestIndex -! ! -!ADPCMCodec methodsFor: 'private' stamp: 'jm 3/28/1999 20:48'! - initializeForBitsPerSample: sampleBits samplesPerFrame: frameSize - - self resetForMono. - stepSizeTable _ #(7 8 9 10 11 12 13 14 16 17 19 21 23 25 28 31 34 37 41 45 50 55 60 66 73 80 88 97 107 118 130 143 157 173 190 209 230 253 279 307 337 371 408 449 494 544 598 658 724 796 876 963 1060 1166 1282 1411 1552 1707 1878 2066 2272 2499 2749 3024 3327 3660 4026 4428 4871 5358 5894 6484 7132 7845 8630 9493 10442 11487 12635 13899 15289 16818 18500 20350 22385 24623 27086 29794 32767). - - indexTable _ nil. - sampleBits = 2 ifTrue: [ - indexTable _ #(-1 2)]. - sampleBits = 3 ifTrue: [ - indexTable _ #(-1 -1 2 4)]. - sampleBits = 4 ifTrue: [ - indexTable _ #(-1 -1 -1 -1 2 4 6 8)]. - sampleBits = 5 ifTrue: [ - indexTable _ #(-1 -1 -1 -1 -1 -1 -1 -1 1 2 4 6 8 10 13 16)]. - indexTable ifNil: [self error: 'unimplemented bits/sample']. - - bitsPerSample _ sampleBits. - deltaSignMask _ 1 bitShift: bitsPerSample - 1. - deltaValueMask _ deltaSignMask - 1. - deltaValueHighBit _ deltaSignMask / 2. - - frameSize <= 1 - ifTrue: [frameSizeMask _ 0] - ifFalse: [ - (frameSize = (1 bitShift: frameSize highBit - 1)) - ifFalse: [self error: 'frameSize must be a power of two']. - frameSizeMask _ frameSize - 1]. - - "keep as SoundBuffer to allow fast access from primitive" - indexTable _ SoundBuffer fromArray: indexTable. - stepSizeTable _ SoundBuffer fromArray: stepSizeTable. -! ! -!ADPCMCodec methodsFor: 'bit streaming' stamp: 'jm 3/28/1999 16:24'! - nextBits: n - "Answer the next n bits of my bit stream as an unsigned integer." - - | result remaining shift | - self inline: true. - - result _ 0. - remaining _ n. - [true] whileTrue: [ - shift _ remaining - bitPosition. - result _ result + (currentByte bitShift: shift). - shift > 0 - ifTrue: [ "consumed currentByte buffer; fetch next byte" - remaining _ remaining - bitPosition. - currentByte _ (encodedBytes at: (byteIndex _ byteIndex + 1)). - bitPosition _ 8] - ifFalse: [ "still some bits left in currentByte buffer" - bitPosition _ bitPosition - remaining. - "mask out the consumed bits:" - currentByte _ currentByte bitAnd: (255 bitShift: (bitPosition - 8)). - ^ result]]. -! ! -!ADPCMCodec methodsFor: 'bit streaming' stamp: 'jm 3/28/1999 20:21'! -nextBits: n put: anInteger - "Write the next n bits to my bit stream." - - | buf bufBits bitsAvailable shift | - self inline: true. - - buf _ anInteger. - bufBits _ n. - [true] whileTrue: [ - bitsAvailable _ 8 - bitPosition. - shift _ bitsAvailable - bufBits. "either left or right shift" - "append high bits of buf to end of currentByte:" - currentByte _ currentByte + (buf bitShift: shift). - shift < 0 - ifTrue: [ "currentByte buffer filled; output it" - encodedBytes at: (byteIndex _ byteIndex + 1) put: currentByte. - bitPosition _ 0. - currentByte _ 0. - "clear saved high bits of buf:" - buf _ buf bitAnd: (1 bitShift: 0 - shift) - 1. - bufBits _ bufBits - bitsAvailable] - ifFalse: [ "still some bits available in currentByte buffer" - bitPosition _ bitPosition + bufBits. - ^ self]]. -! ! -!ADPCMCodec methodsFor: 'private' stamp: 'ar 4/23/2001 15:11'! - privateDecodeMono: count - - | delta step predictedDelta bit | - - self var: #stepSizeTable declareC: 'short int *stepSizeTable'. - self var: #indexTable declareC: 'short int *indexTable'. - self var: #samples declareC: 'short int *samples'. - self var: #encodedBytes declareC: 'unsigned char *encodedBytes'. - - 1 to: count do: [:i | - (i bitAnd: frameSizeMask) = 1 - ifTrue: [ "start of frame; read frame header" - predicted _ self nextBits: 16. - predicted > 32767 ifTrue: [predicted _ predicted - 65536]. - index _ self nextBits: 6. - samples at: (sampleIndex _ sampleIndex + 1) put: predicted] - ifFalse: [ - delta _ self nextBits: bitsPerSample. - step _ stepSizeTable at: index + 1. - predictedDelta _ 0. - bit _ deltaValueHighBit. - [bit > 0] whileTrue: [ - (delta bitAnd: bit) > 0 ifTrue: [predictedDelta _ predictedDelta + step]. - step _ step bitShift: -1. - bit _ bit bitShift: -1]. - predictedDelta _ predictedDelta + step. - - (delta bitAnd: deltaSignMask) > 0 - ifTrue: [predicted _ predicted - predictedDelta] - ifFalse: [predicted _ predicted + predictedDelta]. - predicted > 32767 - ifTrue: [predicted _ 32767] - ifFalse: [predicted < -32768 ifTrue: [predicted _ -32768]]. - - index _ index + (indexTable at: (delta bitAnd: deltaValueMask) + 1). - index < 0 - ifTrue: [index _ 0] - ifFalse: [index > 88 ifTrue: [index _ 88]]. - - samples at: (sampleIndex _ sampleIndex + 1) put: predicted]]. -! ! -!ADPCMCodec methodsFor: 'private' stamp: 'ar 4/23/2001 15:11'! - privateDecodeStereo: count - - | predictedLeft predictedRight indexLeft indexRight deltaLeft deltaRight - stepLeft stepRight predictedDeltaLeft predictedDeltaRight bit | - - - self var: #stepSizeTable declareC: 'short int *stepSizeTable'. - self var: #indexTable declareC: 'short int *indexTable'. - self var: #samples declareC: 'short int *samples'. - self var: #encodedBytes declareC: 'unsigned char *encodedBytes'. - self var: #rightSamples declareC: 'short int *rightSamples'. - self var: #predicted declareC: 'short int *predicted'. - self var: #index declareC: 'short int *index'. - - "make local copies of decoder state variables" - predictedLeft _ predicted at: 1. - predictedRight _ predicted at: 2. - indexLeft _ index at: 1. - indexRight _ index at: 2. - - 1 to: count do: [:i | - (i bitAnd: frameSizeMask) = 1 - ifTrue: [ "start of frame; read frame header" - predictedLeft _ self nextBits: 16. - indexLeft _ self nextBits: 6. - predictedRight _ self nextBits: 16. - indexRight _ self nextBits: 6. - predictedLeft > 32767 ifTrue: [predictedLeft _ predictedLeft - 65536]. - predictedRight > 32767 ifTrue: [predictedRight _ predictedRight - 65536]. - samples at: (sampleIndex _ sampleIndex + 1) put: predictedLeft. - rightSamples at: sampleIndex put: predictedRight] - ifFalse: [ - deltaLeft _ self nextBits: bitsPerSample. - deltaRight _ self nextBits: bitsPerSample. - stepLeft _ stepSizeTable at: indexLeft + 1. - stepRight _ stepSizeTable at: indexRight + 1. - predictedDeltaLeft _ predictedDeltaRight _ 0. - bit _ deltaValueHighBit. - [bit > 0] whileTrue: [ - (deltaLeft bitAnd: bit) > 0 ifTrue: [ - predictedDeltaLeft _ predictedDeltaLeft + stepLeft]. - (deltaRight bitAnd: bit) > 0 ifTrue: [ - predictedDeltaRight _ predictedDeltaRight + stepRight]. - stepLeft _ stepLeft bitShift: -1. - stepRight _ stepRight bitShift: -1. - bit _ bit bitShift: -1]. - predictedDeltaLeft _ predictedDeltaLeft + stepLeft. - predictedDeltaRight _ predictedDeltaRight + stepRight. - - (deltaLeft bitAnd: deltaSignMask) > 0 - ifTrue: [predictedLeft _ predictedLeft - predictedDeltaLeft] - ifFalse: [predictedLeft _ predictedLeft + predictedDeltaLeft]. - (deltaRight bitAnd: deltaSignMask) > 0 - ifTrue: [predictedRight _ predictedRight - predictedDeltaRight] - ifFalse: [predictedRight _ predictedRight + predictedDeltaRight]. - predictedLeft > 32767 - ifTrue: [predictedLeft _ 32767] - ifFalse: [predictedLeft < -32768 ifTrue: [predictedLeft _ -32768]]. - predictedRight > 32767 - ifTrue: [predictedRight _ 32767] - ifFalse: [predictedRight < -32768 ifTrue: [predictedRight _ -32768]]. - - indexLeft _ indexLeft + (indexTable at: (deltaLeft bitAnd: deltaValueMask) + 1). - indexLeft < 0 - ifTrue: [indexLeft _ 0] - ifFalse: [indexLeft > 88 ifTrue: [indexLeft _ 88]]. - indexRight _ indexRight + (indexTable at: (deltaRight bitAnd: deltaValueMask) + 1). - indexRight < 0 - ifTrue: [indexRight _ 0] - ifFalse: [indexRight > 88 ifTrue: [indexRight _ 88]]. - - samples at: (sampleIndex _ sampleIndex + 1) put: predictedLeft. - rightSamples at: sampleIndex put: predictedRight]]. - - "save local copies of decoder state variables" - predicted at: 1 put: predictedLeft. - predicted at: 2 put: predictedRight. - index at: 1 put: indexLeft. - index at: 2 put: indexRight. -! ! -!ADPCMCodec methodsFor: 'private' stamp: 'ar 4/23/2001 15:11'! - privateEncodeMono: count - - | step sign diff delta predictedDelta bit p | - - self var: #stepSizeTable declareC: 'short int *stepSizeTable'. - self var: #indexTable declareC: 'short int *indexTable'. - self var: #samples declareC: 'short int *samples'. - self var: #encodedBytes declareC: 'unsigned char *encodedBytes'. - - step _ stepSizeTable at: 1. - 1 to: count do: [:i | - (i bitAnd: frameSizeMask) = 1 ifTrue: [ - predicted _ samples at: (sampleIndex _ sampleIndex + 1). - (p _ predicted) < 0 ifTrue: [p _ p + 65536]. - self nextBits: 16 put: p. - i < count ifTrue: [ - index _ self indexForDeltaFrom: predicted to: (samples at: sampleIndex + 1)]. - self nextBits: 6 put: index. - ] ifFalse: [ - "compute sign and magnitude of difference from the predicted sample" - sign _ 0. - diff _ (samples at: (sampleIndex _ sampleIndex + 1)) - predicted. - diff < 0 ifTrue: [ - sign _ deltaSignMask. - diff _ 0 - diff]. - - "Compute encoded delta and the difference that this will cause in the predicted sample value during decoding. Note that this code approximates: - delta _ (4 * diff) / step. - predictedDelta _ ((delta + 0.5) * step) / 4; - but in the shift step bits are dropped. Thus, even if you have fast mul/div hardware you cannot use it since you would get slightly different bits what than the algorithm defines." - delta _ 0. - predictedDelta _ 0. - bit _ deltaValueHighBit. - [bit > 0] whileTrue: [ - diff >= step ifTrue: [ - delta _ delta + bit. - predictedDelta _ predictedDelta + step. - diff _ diff - step]. - step _ step bitShift: -1. - bit _ bit bitShift: -1]. - predictedDelta _ predictedDelta + step. - - "compute and clamp new prediction" - sign > 0 - ifTrue: [predicted _ predicted - predictedDelta] - ifFalse: [predicted _ predicted + predictedDelta]. - predicted > 32767 - ifTrue: [predicted _ 32767] - ifFalse: [predicted < -32768 ifTrue: [predicted _ -32768]]. - - "compute new index and step values" - index _ index + (indexTable at: delta + 1). - index < 0 - ifTrue: [index _ 0] - ifFalse: [index > 88 ifTrue: [index _ 88]]. - step _ stepSizeTable at: index + 1. - - "output encoded, signed delta" - self nextBits: bitsPerSample put: (sign bitOr: delta)]]. - - bitPosition > 0 ifTrue: [ "flush the last output byte, if necessary" - encodedBytes at: (byteIndex _ byteIndex + 1) put: currentByte]. -! ! -!ADPCMCodec methodsFor: 'private' stamp: 'ar 4/23/2001 15:12'! - privateEncodeStereo: count - - - "not yet implemented" - self inline: false. - self success: false.! ! -!ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 12/14/2001 11:21'! - reset - - self resetForMono. -! ! -!ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 3/28/1999 20:12'! - resetForMono - "Reset my encoding and decoding state for mono." - - predicted _ 0. - index _ 0. -! ! -!ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 3/28/1999 20:12'! - resetForStereo - "Reset my encoding and decoding state for stereo." - - "keep state as SoundBuffers to allow fast access from primitive" - predicted _ SoundBuffer new: 2. - index _ SoundBuffer new: 2. -! ! -!ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 3/27/1999 08:34'! - samplesPerFrame - "Answer the number of sound samples per compression frame." - - frameSizeMask > 0 ifTrue: [^ frameSizeMask + 1]. - ^ 8 "frame size when there are no running headers" -! ! -!ADPCMCodec class methodsFor: 'instance creation' stamp: 'jm 3/27/1999 11:15'! - new - - ^ super new - initializeForBitsPerSample: 4 - samplesPerFrame: 0. -! ! -!ADPCMCodec class methodsFor: 'instance creation' stamp: 'jm 11/15/2001 16:02'! - newBitsPerSample: bitsPerSample - - ^ super new - initializeForBitsPerSample: bitsPerSample - samplesPerFrame: 0. -! ! -!ADPCMCodec class methodsFor: 'primitive generation' stamp: 'ar 2/3/2001 15:50'! - translatedPrimitives - "Answer a string containing the translated C code for my primitives." - "Note: This code currently must be hand-edited to remove several methods that are inlined (thus not needed) but not pruned out by the ST-to-C translator." - - ^#( - (ADPCMCodec privateDecodeMono:) - (ADPCMCodec privateDecodeStereo:) - (ADPCMCodec privateEncodeMono:) - (ADPCMCodec privateEncodeStereo:) - (ADPCMCodec indexForDeltaFrom:to:) - (ADPCMCodec nextBits:) - (ADPCMCodec nextBits:put:)) -! ! -!GSMCodec methodsFor: 'subclass responsibilities' stamp: 'jm 2/4/1999 11:36'! - bytesPerEncodedFrame - - ^ 33 -! ! -!GSMCodec methodsFor: 'subclass responsibilities' stamp: 'jm 2/4/1999 11:44'! - decodeFrames: frameCount from: srcByteArray at: srcIndex into: dstSoundBuffer at: dstIndex - - | p | - p _ self primDecode: decodeState frames: frameCount - from: srcByteArray at: srcIndex - into: dstSoundBuffer at: dstIndex. - ^ Array with: p x with: p y -! ! -!GSMCodec methodsFor: 'subclass responsibilities' stamp: 'jm 2/4/1999 11:44'! - encodeFrames: frameCount from: srcSoundBuffer at: srcIndex into: dstByteArray at: dstIndex - - | p | - p _ self primEncode: encodeState frames: frameCount - from: srcSoundBuffer at: srcIndex - into: dstByteArray at: dstIndex. - ^ Array with: p x with: p y -! ! -!GSMCodec methodsFor: 'primitives' stamp: 'jm 2/4/1999 11:33'! - primDecode: state frames: frameCount from: srcSoundBuffer at: srcIndex into: dstByteArray at: dstIndex - - - self primitiveFailed. -! ! -!GSMCodec methodsFor: 'primitives' stamp: 'jm 2/4/1999 11:33'! - primEncode: state frames: frameCount from: srcSoundBuffer at: srcIndex into: dstByteArray at: dstIndex - - - self primitiveFailed. -! ! -!GSMCodec methodsFor: 'primitives' stamp: 'jm 2/4/1999 11:35'! - primNewState - - - self error: 'The SoundCodecPrims plugin is not available'. -! ! -!GSMCodec methodsFor: 'subclass responsibilities' stamp: 'jm 2/4/1999 11:32'! - reset - "Reset my encoding/decoding state to prepare to encode or decode a new sound stream." - - encodeState _ self primNewState. - decodeState _ self primNewState. -! ! -!GSMCodec methodsFor: 'subclass responsibilities' stamp: 'jm 2/4/1999 11:36'! - samplesPerFrame - - ^ 160 -! ! -!GSMCodec class methodsFor: 'instance creation' stamp: 'jm 10/21/2001 10:10'! - new - - ^ super new reset -! ! -!MuLawCodec methodsFor: 'subclass responsibility' stamp: 'jm 2/2/1999 09:15'! - bytesPerEncodedFrame - "Answer the number of bytes required to hold one frame of compressed sound data. Answer zero if this codec produces encoded frames of variable size." - - ^ 1 -! ! -!MuLawCodec methodsFor: 'subclass responsibility' stamp: 'jm 2/2/1999 14:10'! - decodeFrames: frameCount from: srcByteArray at: srcIndex into: dstSoundBuffer at: dstIndex - "Decode the given number of monophonic frames starting at the given index in the given ByteArray of compressed sound data and storing the decoded samples into the given SoundBuffer starting at the given destination index. Answer a pair containing the number of bytes of compressed data consumed and the number of decompressed samples produced." - "Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers." - - | dst | - dst _ dstIndex. - srcIndex to: srcIndex + frameCount - 1 do: [:src | - dstSoundBuffer at: dst put: (DecodingTable at: (srcByteArray at: src) + 1). - dst _ dst + 1]. - ^ Array with: frameCount with: frameCount -! ! -!MuLawCodec methodsFor: 'subclass responsibility' stamp: 'di 2/8/1999 22:25'! - encodeFrames: frameCount from: srcSoundBuffer at: srcIndex into: dstByteArray at: dstIndex - "Encode the given number of frames starting at the given index in the given monophonic SoundBuffer and storing the encoded sound data into the given ByteArray starting at the given destination index. Encode only as many complete frames as will fit into the destination. Answer a pair containing the number of samples consumed and the number of bytes of compressed data produced." - "Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers." - - srcIndex to: srcIndex + frameCount - 1 do: [:i | - dstByteArray at: i put: (self uLawEncodeSample: (srcSoundBuffer at: i))]. - ^ Array with: frameCount with: frameCount -! ! -!MuLawCodec methodsFor: 'subclass responsibility' stamp: 'jm 2/2/1999 09:11'! - samplesPerFrame - "Answer the number of sound samples per compression frame." - - ^ 1 -! ! -!MuLawCodec methodsFor: 'external access' stamp: 'di 2/8/1999 22:28'! - uLawDecodeSample: byte - "Decode a 16-bit signed sample from 8 bits using uLaw decoding" - - ^ DecodingTable at: byte + 1! ! -!MuLawCodec methodsFor: 'private' stamp: 'di 2/9/1999 13:25'! - uLawEncode12Bits: s - "Encode a 12-bit unsigned sample (0-4095) into 7 bits using uLaw encoding. - This gets called by a method that scales 16-bit signed integers down to a - 12-bit magnitude, and then ORs in 16r80 if they were negative. - Detail: May get called with s >= 4096, and this works fine." - - s < 496 ifTrue: [ - s < 112 ifTrue: [ - s < 48 ifTrue: [ - s < 16 - ifTrue: [^ 16r70 bitOr: (15 - s)] - ifFalse: [^ 16r60 bitOr: (15 - ((s - 16) bitShift: -1))]]. - ^ 16r50 bitOr: (15 - ((s - 48) bitShift: -2))]. - s < 240 - ifTrue: [^ 16r40 bitOr: (15 - ((s - 112) bitShift: -3))] - ifFalse: [^ 16r30 bitOr: (15 - ((s - 240) bitShift: -4))]]. - - s < 2032 ifTrue: [ - s < 1008 - ifTrue: [^ 16r20 bitOr: (15 - ((s - 496) bitShift: -5))] - ifFalse: [^ 16r10 bitOr: (15 - ((s - 1008) bitShift: -6))]]. - - s < 4080 - ifTrue: [^ 15 - ((s - 2032) bitShift: -7)] - ifFalse: [^ 0]. -! ! -!MuLawCodec methodsFor: 'external access' stamp: 'di 2/8/1999 22:30'! -uLawEncodeSample: sample - "Encode a 16-bit signed sample into 8 bits using uLaw encoding" - - | s | - s _ sample // 8. "drop 3 least significant bits" - s < 0 ifTrue: [^ (self uLawEncode12Bits: 0-s) + 16r80] - ifFalse: [^ (self uLawEncode12Bits: s)]. -! ! -!MuLawCodec class methodsFor: 'class initialization' stamp: 'di 2/9/1999 14:57'! - initialize - "Build the 256 entry table to be used to decode 8-bit uLaw-encoded samples." - "MuLawCodec initialize" - - | encoded codec lastEncodedPos lastEncodedNeg | - DecodingTable _ Array new: 256. - codec _ self new. - lastEncodedPos _ nil. - lastEncodedNeg _ nil. - 4095 to: 0 by: -1 do: [:s | - encoded _ codec uLawEncode12Bits: s. - lastEncodedPos = encoded - ifFalse: [ - DecodingTable at: (encoded + 1) put: (s bitShift: 3). - lastEncodedPos _ encoded]. - encoded _ encoded bitOr: 16r80. - lastEncodedNeg = encoded - ifFalse: [ - DecodingTable at: (encoded + 1) put: (s bitShift: 3) negated. - lastEncodedNeg _ encoded]]. -! ! -!SoundPlayer class methodsFor: 'primitive test' stamp: 'jm 9/13/97 20:01'! - boinkPitch: p dur: d loudness: l waveTable: waveTable pan: pan - "Play a decaying note on the given stream using the given wave table. Used for testing only." - - | decay tableSize amplitude increment cycles i | - decay _ 0.96. - tableSize _ waveTable size. - amplitude _ l asInteger min: 1000. - increment _ ((p asFloat * tableSize asFloat) / SamplingRate asFloat) asInteger. - increment _ (increment max: 1) min: (tableSize // 2). - cycles _ (d * SamplingRate asFloat) asInteger. - - i _ 1. - 1 to: cycles do: [:cycle | - (cycle \\ 100) = 0 - ifTrue: [amplitude _ (decay * amplitude asFloat) asInteger]. - i _ (((i - 1) + increment) \\ tableSize) + 1. - self playTestSample: (amplitude * (waveTable at: i)) // 1000 pan: pan]. -! ! -!SoundPlayer class methodsFor: 'primitive test' stamp: 'jm 1/5/98 17:56'! - boinkScale - "Tests the sound output primitives by playing a scale." - "SoundPlayer boinkScale" - - | sineTable pan | - self shutDown. - SamplingRate _ 11025. - Stereo _ true. - sineTable _ self sineTable: 1000. - Buffer _ SoundBuffer newStereoSampleCount: 1000. - BufferIndex _ 1. - self primSoundStartBufferSize: Buffer stereoSampleCount - rate: SamplingRate - stereo: Stereo. - pan _ 0. - #(261.626 293.665 329.628 349.229 391.996 440.001 493.884 523.252) do: [:p | - self boinkPitch: p dur: 0.3 loudness: 300 waveTable: sineTable pan: pan. - pan _ pan + 125]. - - self boinkPitch: 261.626 dur: 1.0 loudness: 300 waveTable: sineTable pan: 500. - self primSoundStop. - self shutDown. - SoundPlayer initialize. "reset sampling rate, buffer size, and stereo flag" -! ! -!SoundPlayer class methodsFor: 'accessing' stamp: 'jm 8/13/1998 15:00'! - bufferMSecs - - ^ BufferMSecs -! ! -!SoundPlayer class methodsFor: 'playing' stamp: 'ar 2/1/2001 15:20'! - canStartPlayer - "Some platforms do no support simultaneous record and play. If this is one of those platforms, return false if there is a running SoundRecorder." - - Preferences canRecordWhilePlaying ifTrue: [^ true]. - SoundRecorder anyActive ifTrue:[^false]. - ^ true -! ! -!SoundPlayer class methodsFor: 'initialization' stamp: 'jm 1/14/1999 13:13'! - initialize - "SoundPlayer initialize; shutDown; startUp" - "Details: BufferMSecs represents a tradeoff between latency and quality. If BufferMSecs is too low, the sound will not play smoothly, especially during long-running primitives such as large BitBlts. If BufferMSecs is too high, there will be a long time lag between when a sound buffer is submitted to be played and when that sound is actually heard. BufferMSecs is typically in the range 50-200." - - SamplingRate _ 22050. - BufferMSecs _ 120. - Stereo _ true. - UseReverb ifNil: [UseReverb _ true]. -! ! -!SoundPlayer class methodsFor: 'private' stamp: 'ar 1/31/2001 01:32'! - isAllSilence: buffer size: count - "return true if the buffer is all silence after reverb has ended" - | value | - value _ buffer at: 1. - 2 to: count do:[:i| (buffer at: i) = value ifFalse:[^false]]. - ^true! ! -!SoundPlayer class methodsFor: 'playing' stamp: 'di 8/5/1998 23:08'! - isPlaying: aSound - ^ ActiveSounds includes: aSound! ! -!SoundPlayer class methodsFor: 'player process' stamp: 'jmv 3/1/2010 14:07'! - isReverbOn - - ^ ReverbState notNil -! ! -!SoundPlayer class methodsFor: 'player process' stamp: 'ar 1/24/2002 18:41'! - lastPlayBuffer - ^LastBuffer! ! -!SoundPlayer class methodsFor: 'player process' stamp: 'jmv 3/1/2010 13:33'! - oldStylePlayLoop - "This version of the play loop is used if the VM does not yet support sound primitives that signal a semaphore when a sound buffer becomes available." - - | bytesPerSlice count | - bytesPerSlice _ Stereo ifTrue: [4] ifFalse: [2]. - [true] whileTrue: [ - [(count _ self primSoundAvailableBytes // bytesPerSlice) > 100] - whileFalse: [(Delay forMilliseconds: 1) wait]. - - count _ count min: Buffer stereoSampleCount. - PlayerSemaphore critical: [ - ActiveSounds _ ActiveSounds select: [:snd | snd samplesRemaining > 0]. - ActiveSounds do: [:snd | - snd ~~ SoundJustStarted ifTrue: [ - snd playSampleCount: count into: Buffer startingAt: 1]]. - ReverbState ifNotNil: [ - ReverbState applyReverbTo: Buffer startingAt: 1 count: count]. - self primSoundPlaySamples: count from: Buffer startingAt: 1. - Buffer primFill: 0. - SoundJustStarted _ nil]]. -! ! -!SoundPlayer class methodsFor: 'playing' stamp: 'jmv 3/2/2010 10:09'! - pauseSound: aSound - "Stop playing the given sound. Playing can be resumed from this point later." - - PlayerSemaphore critical: [ - ActiveSounds remove: aSound ifAbsent: nil]. -! ! -!SoundPlayer class methodsFor: 'player process' stamp: 'jmv 3/1/2010 13:34'! - playLoop - "The sound player process loop." - - | bytesPerSlice count willStop mayStop | - mayStop _ Preferences soundStopWhenDone. - bytesPerSlice _ Stereo ifTrue: [4] ifFalse: [2]. - [true] whileTrue: [ - [(count _ self primSoundAvailableBytes // bytesPerSlice) > 100] - whileFalse: [ReadyForBuffer wait]. - - count _ count min: Buffer stereoSampleCount. - PlayerSemaphore critical: [ - ActiveSounds _ ActiveSounds select: [:snd | snd samplesRemaining > 0]. - ActiveSounds do: [:snd | - snd ~~ SoundJustStarted ifTrue: [ - snd playSampleCount: count into: Buffer startingAt: 1]]. - ReverbState ifNotNil: [ - ReverbState applyReverbTo: Buffer startingAt: 1 count: count]. - self primSoundPlaySamples: count from: Buffer startingAt: 1. - willStop _ mayStop and:[ - (ActiveSounds size = 0) and:[ - self isAllSilence: Buffer size: count]]. - LastBuffer ifNotNil:[ - LastBuffer replaceFrom: 1 to: LastBuffer size with: Buffer startingAt: 1. - ]. - willStop - ifTrue:[self shutDown. PlayerProcess _ nil] - ifFalse:[Buffer primFill: 0]. - SoundJustStarted _ nil]. - willStop ifTrue:[^self]. - ]. -! ! -!SoundPlayer class methodsFor: 'playing' stamp: 'ar 2/19/2001 01:28'! - playSound: aSound - "Reset and start playing the given sound from its beginning." - - aSound reset. - aSound samplesRemaining = 0 ifTrue:[^self]. - self resumePlaying: aSound. -! ! -!SoundPlayer class methodsFor: 'primitive test' stamp: 'jm 9/17/97 12:55'! - playTestSample: s pan: pan - "Append the given sample in the range [-32767..32767] to the output buffer, playing the output buffer when it is full. Used for testing only." - - | sample leftSample | - BufferIndex >= Buffer size - ifTrue: [ - "current buffer is full; play it" - [self primSoundAvailableBytes > 0] - whileFalse. "wait for space to be available" - self primSoundPlaySamples: Buffer stereoSampleCount from: Buffer startingAt: 1. - Buffer primFill: 0. - BufferIndex _ 1]. - - sample _ s. - sample > 32767 ifTrue: [ sample _ 32767 ]. - sample < -32767 ifTrue: [ sample _ -32767 ]. - - Stereo - ifTrue: [ - leftSample _ (sample * pan) // 1000. - Buffer at: BufferIndex put: sample - leftSample. - Buffer at: BufferIndex + 1 put: leftSample] - ifFalse: [ - Buffer at: BufferIndex + 1 put: sample]. - BufferIndex _ BufferIndex + 2. -! ! -!SoundPlayer class methodsFor: 'player process' stamp: 'nk 2/16/2001 13:26'! - playerProcess - ^PlayerProcess! ! -!SoundPlayer class methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'! - primSoundAvailableBytes - "Return the number of bytes of available space in the sound output buffer." - "Note: Squeak always uses buffers containing 4-bytes per sample (2 channels at 2 bytes per channel) regardless of the state of the Stereo flag." - - - ^ self primitiveFailed -! ! -!SoundPlayer class methodsFor: 'private' stamp: 'JMM 11/6/2000 10:17'! - primSoundGetVolume - "Return sound as array of doubles left then right channel, range is 0.0 to 1.0 but may be overdriven" - - ^Array with: 1.0 with: 1.0! ! -!SoundPlayer class methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'! - primSoundInsertSamples: count from: aSoundBuffer samplesOfLeadTime: anInteger - "Mix the given number of sample frames from the given sound buffer into the queue of samples that has already been submitted to the sound driver. This primitive is used to start a sound playing with minimum latency, even if large sound output buffers are being used to ensure smooth sound output. Returns the number of samples consumed, or zero if the primitive is not implemented or fails." - - - ^ 0 -! ! -!SoundPlayer class methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'! - primSoundPlaySamples: count from: aSampleBuffer startingAt: index - "Copy count bytes into the current sound output buffer from the given sample buffer starting at the given index." - - - ^ self primitiveFailed -! ! -!SoundPlayer class methodsFor: 'private' stamp: 'JMM 11/6/2000 10:14'! - primSoundSetVolumeLeft: aLeftVolume volumeRight: aRightVolume - "Set sound pass in float 0.0-1.0 for left and right channel, with possible 2.0 or higher to overdrive sound channel " - -! ! -!SoundPlayer class methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'! - primSoundStartBufferSize: bufferSize rate: samplesPerSecond stereo: stereoFlag - "Start double-buffered sound output with the given buffer size and sampling rate. This version has been superceded by primitive 171 (primSoundStartBufferSize:rate:stereo:semaIndex:)." - "ar 12/5/1998 Turn off the sound if not supported" - - SoundSupported _ false.! ! -!SoundPlayer class methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'! - primSoundStartBufferSize: bufferSize rate: samplesPerSecond stereo: stereoFlag semaIndex: anInteger - "Start double-buffered sound output with the given buffer size and sampling rate. If the given semaphore index is > 0, it is taken to be the index of a Semaphore in the external objects array to be signalled when the sound driver is ready to accept another buffer of samples." - "Details: If this primitive fails, this method tries to use the older version instead." - - - UseReadySemaphore _ false. - self primSoundStartBufferSize: bufferSize rate: samplesPerSecond stereo: stereoFlag. -! ! -!SoundPlayer class methodsFor: 'private' stamp: 'tpr 2/2/2001 19:46'! - primSoundStop - "Stop double-buffered sound output. Must not raise an error because it is used inside error handling and at system shutdown" - - ! ! -!SoundPlayer class methodsFor: 'playing' stamp: 'jm 9/8/1998 17:54'! - resumePlaying: aSound - "Start playing the given sound without resetting it; it will resume playing from where it last stopped." - "Implementation detail: On virtual machines that don't support the quickstart primitive, you may need to edit this method to pass false to resumePlaying:quickStart:." - - self resumePlaying: aSound quickStart: true. -! ! -!SoundPlayer class methodsFor: 'playing' stamp: 'jmv 3/1/2010 13:34'! - resumePlaying: aSound quickStart: quickStart - "Start playing the given sound without resetting it; it will resume playing from where it last stopped. If quickStart is true, then try to start playing the given sound immediately." - - | doQuickStart | - Preferences soundsEnabled ifFalse: [^ self]. - doQuickStart _ quickStart. - Preferences soundQuickStart ifFalse: [doQuickStart _ false]. - PlayerProcess ifNil: [ - self canStartPlayer ifFalse: [^ self]. - ^self startUpWithSound: aSound]. - - PlayerSemaphore critical: [ - (ActiveSounds includes: aSound) - ifTrue: [doQuickStart _ false] - ifFalse: [ - doQuickStart ifFalse: [ActiveSounds add: aSound]]]. - - "quick-start the given sound, unless the sound player has just started" - doQuickStart ifTrue: [self startPlayingImmediately: aSound]. -! ! -!SoundPlayer class methodsFor: 'accessing' stamp: 'jm 1/27/98 09:28'! - reverbState - - ^ ReverbState! ! -!SoundPlayer class methodsFor: 'accessing'! - samplingRate - - ^ SamplingRate! ! -!SoundPlayer class methodsFor: 'accessing' stamp: 'JMM 11/6/2000 10:16'! - setVolumeLeft: aLeftVolume volumeRight: aRightVolume - "Set sound pass in float 0.0-1.0 for left and right channel, with possible 2.0 or higher to overdrive sound channel " - self primSoundSetVolumeLeft: aLeftVolume volumeRight: aRightVolume! ! -!SoundPlayer class methodsFor: 'snapshotting' stamp: 'jm 5/8/1998 18:48'! - shutDown - "Stop player process, for example before snapshotting." - - self stopPlayerProcess. - ReverbState _ nil. -! ! -!SoundPlayer class methodsFor: 'primitive test' stamp: 'jm 9/17/97 20:06'! - sineTable: size - "Compute a sine table of the given size. Used for testing only." - - | radiansPerStep table | - table _ Array new: size. - radiansPerStep _ (2.0 * Float pi) / table size asFloat. - 1 to: table size do: [:i | - table at: i put: - (32767.0 * (radiansPerStep * i) sin) asInteger]. - - ^ table -! ! -!SoundPlayer class methodsFor: 'accessing' stamp: 'JMM 11/6/2000 10:17'! - soundVolume - "Return sound as array of doubles left then right channel, range is 0.0 to 1.0 but may be overdriven" - ^self primSoundGetVolume! ! -!SoundPlayer class methodsFor: 'player process' stamp: 'ar 2/4/2001 18:01'! - startPlayerProcessBufferSize: bufferSize rate: samplesPerSecond stereo: stereoFlag - "Start the sound player process. Terminate the old process, if any." - "SoundPlayer startPlayerProcessBufferSize: 1000 rate: 11025 stereo: false" - ^self startPlayerProcessBufferSize: bufferSize - rate: samplesPerSecond - stereo: stereoFlag - sound: nil! ! -!SoundPlayer class methodsFor: 'player process' stamp: 'jmv 10/8/2012 22:14'! - startPlayerProcessBufferSize: bufferSize rate: samplesPerSecond stereo: stereoFlag sound: aSound - "Start the sound player process. Terminate the old process, if any." - "SoundPlayer startPlayerProcessBufferSize: 1000 rate: 11025 stereo: false" - - self stopPlayerProcess. - aSound - ifNil:[ActiveSounds _ OrderedCollection new] - ifNotNil:[ActiveSounds _ OrderedCollection with: aSound]. - Buffer _ SoundBuffer newStereoSampleCount: (bufferSize // 4) * 4. - LastBuffer ifNotNil:[LastBuffer _ SoundBuffer basicNew: Buffer basicSize]. - PlayerSemaphore _ Semaphore forMutualExclusion. - SamplingRate _ samplesPerSecond. - Stereo _ stereoFlag. - ReadyForBuffer _ Semaphore new. - SoundSupported _ true. "Assume so" - UseReadySemaphore _ true. "set to false if ready semaphore not supported by VM" - self primSoundStartBufferSize: Buffer stereoSampleCount - rate: samplesPerSecond - stereo: Stereo - semaIndex: (Smalltalk registerExternalObject: ReadyForBuffer). - "Check if sound start prim was successful" - SoundSupported ifFalse:[^self]. - UseReadySemaphore - ifTrue: [PlayerProcess _ [SoundPlayer playLoop] newProcess] - ifFalse: [PlayerProcess _ [SoundPlayer oldStylePlayLoop] newProcess]. - UseReverb ifTrue: [self startReverb]. - - PlayerProcess - priority: Processor userInterruptPriority; - name: 'Sound Player'; - resume! ! -!SoundPlayer class methodsFor: 'private' stamp: 'jmv 3/1/2010 13:34'! - startPlayingImmediately: aSound - "Private!! Start playing the given sound as soon as possible by mixing it into the sound output buffers of the underlying sound driver." - - | totalSamples buf n leftover src rest | - "first, fill a double-size buffer with samples" - "Note: The code below assumes that totalSamples contains two - buffers worth of samples, and the insertSamples primitive is - expected to consume at least one buffer's worth of these - samples. The remaining samples are guaranteed to fit into - a single buffer." - totalSamples _ Buffer stereoSampleCount * 2. "two buffer's worth" - buf _ SoundBuffer newStereoSampleCount: totalSamples. - aSound playSampleCount: totalSamples into: buf startingAt: 1. - ReverbState ifNotNil: [ - ReverbState applyReverbTo: buf startingAt: 1 count: totalSamples]. - - PlayerSemaphore critical: [ - "insert as many samples as possible into the sound driver's buffers" - n _ self primSoundInsertSamples: totalSamples - from: buf - samplesOfLeadTime: 1024. - n > 0 ifTrue:[ - leftover _ totalSamples - n. - - "copy the remainder of buf into Buffer" - "Note: the following loop iterates over 16-bit words, not two-word stereo slices" - "assert: 0 < leftover <= Buffer stereoSampleCount" - src _ 2 * n. - 1 to: 2 * leftover do: - [:dst | Buffer at: dst put: (buf at: (src _ src + 1))]. - - "generate enough additional samples to finish filling Buffer" - rest _ Buffer stereoSampleCount - leftover. - aSound playSampleCount: rest into: Buffer startingAt: leftover + 1. - ReverbState == nil ifFalse: [ - ReverbState applyReverbTo: Buffer startingAt: leftover + 1 count: rest]. - - "record the fact that this sound has already been played into Buffer so that we don't process it again this time around" - SoundJustStarted _ aSound. - ] ifFalse:[ - "quick start failed; reset the sound so we start over" - aSound reset. - ]. - ActiveSounds add: aSound]. -! ! -!SoundPlayer class methodsFor: 'player process' stamp: 'jm 6/7/1999 10:40'! - startReverb - "Start a delay-line style reverb with the given tap delays and gains. Tap delays are given in samples and should be prime integers; the following comment gives an expression that generates primes." - "Integer primesUpTo: 22050" - - UseReverb _ true. - ReverbState _ ReverbSound new - tapDelays: #(1601 7919) gains: #(0.12 0.07). -! ! -!SoundPlayer class methodsFor: 'snapshotting' stamp: 'jm 7/11/97 12:17'! - startUp - "Start up the player process." - - SoundPlayer initialize. - SoundPlayer - startPlayerProcessBufferSize: (BufferMSecs * SamplingRate) // 1000 - rate: SamplingRate - stereo: Stereo. -! ! -!SoundPlayer class methodsFor: 'snapshotting' stamp: 'ar 2/4/2001 17:59'! - startUpWithSound: aSound - "Start up the player process." - - SoundPlayer initialize. - SoundPlayer - startPlayerProcessBufferSize: (BufferMSecs * SamplingRate) // 1000 - rate: SamplingRate - stereo: Stereo - sound: aSound. -! ! -!SoundPlayer class methodsFor: 'accessing'! - stereo - - ^ Stereo -! ! -!SoundPlayer class methodsFor: 'player process' stamp: 'ar 1/31/2001 01:13'! - stopPlayerProcess - "Stop the sound player process." - "SoundPlayer stopPlayerProcess" - - (PlayerProcess == nil or:[PlayerProcess == Processor activeProcess]) - ifFalse:[PlayerProcess terminate]. - PlayerProcess _ nil. - self primSoundStop. - ActiveSounds _ OrderedCollection new. - Buffer _ nil. - PlayerSemaphore _ Semaphore forMutualExclusion. - ReadyForBuffer ifNotNil: - [Smalltalk unregisterExternalObject: ReadyForBuffer]. - ReadyForBuffer _ nil. -! ! -!SoundPlayer class methodsFor: 'playing' stamp: 'jm 1/27/98 09:47'! - stopPlayingAll - "Stop playing all sounds." - - PlayerSemaphore critical: [ - ActiveSounds _ ActiveSounds species new]. -! ! -!SoundPlayer class methodsFor: 'player process' stamp: 'jm 1/27/98 09:43'! - stopReverb - - UseReverb _ false. - ReverbState _ nil. -! ! -!SoundPlayer class methodsFor: 'initialization' stamp: 'ar 1/24/2002 18:40'! - useLastBuffer - ^LastBuffer notNil! ! -!SoundPlayer class methodsFor: 'initialization' stamp: 'ar 1/24/2002 18:47'! - useLastBuffer: aBool - Buffer ifNil:[^self]. - aBool - ifTrue:[LastBuffer _ SoundBuffer basicNew: Buffer basicSize] - ifFalse:[LastBuffer _ nil] ! ! -!SoundPlayer class methodsFor: 'initialization' stamp: 'jm 1/14/1999 13:14'! - useShortBuffer - "Experimental support for real-time MIDI input. This only works on platforms whose hardware allows very short buffer sizes. It has been tested on a Macintosh Powerbook G3." - "SoundPlayer useShortBuffer" - - self shutDown. - BufferMSecs _ 15. - SoundPlayer - startPlayerProcessBufferSize: (BufferMSecs * SamplingRate) // 1000 - rate: SamplingRate - stereo: Stereo. -! ! -!SoundPlayer class methodsFor: 'playing' stamp: 'jm 9/13/97 19:49'! -waitUntilDonePlaying: aSound - "Wait until the given sound is no longer playing." - - [PlayerSemaphore critical: [ActiveSounds includes: aSound]] - whileTrue: [(Delay forMilliseconds: 100) wait]. -! ! -!SoundRecorder methodsFor: 'private' stamp: 'di 2/17/1999 11:13'! - allocateBuffer - "Allocate a new buffer and reset nextIndex." - - | bufferTime | - bufferTime _ stereo "Buffer time = 1/2 second" - ifTrue: [self samplingRate asInteger] - ifFalse: [self samplingRate asInteger // 2]. - currentBuffer _ SoundBuffer newMonoSampleCount: - "Multiple of samplesPerFrame that is approx. bufferTime long" - (bufferTime truncateTo: self samplesPerFrame). - nextIndex _ 1. -! ! -!SoundRecorder methodsFor: 'recording controls' stamp: 'di 2/17/1999 10:54'! - clearRecordedSound - "Clear the sound recorded thus far. Go into pause mode if currently recording." - - paused _ true. - recordedSound _ SequentialSound new. - self allocateBuffer. -! ! -!SoundRecorder methodsFor: 'accessing' stamp: 'di 2/17/1999 11:08'! - codec: aSoundCodec - - codec _ aSoundCodec! ! -!SoundRecorder methodsFor: 'results' stamp: 'di 3/4/1999 21:40'! - condensedSamples - "Return a single SoundBuffer that is the contatenation of all my recorded buffers." - - | sz newBuf i | - recordedBuffers _ recordedSound sounds collect: [:snd | snd samples]. - recordedBuffers isEmpty ifTrue: [^ SoundBuffer new: 0]. - recordedBuffers size = 1 ifTrue: [^ recordedBuffers first copy]. - sz _ recordedBuffers inject: 0 into: [:tot :buff | tot + buff size]. - newBuf _ SoundBuffer newMonoSampleCount: sz. - i _ 1. - recordedBuffers do: [:b | - 1 to: b size do: [:j | - newBuf at: i put: (b at: j). - i _ i + 1]]. - recordedBuffers _ nil. - ^ newBuf -! ! -!SoundRecorder methodsFor: 'results' stamp: 'di 2/16/1999 20:49'! - condensedStereoSound - "Decompose my buffers into left and right channels and return a mixed sound consisting of the those two channels. This may be take a while, since the data must be copied into new buffers." - - | sz leftBuf rightBuf leftI rightI left | - sz _ recordedBuffers inject: 0 into: [:tot :buff | tot + buff size]. - leftBuf _ SoundBuffer newMonoSampleCount: (sz + 1) // 2. - rightBuf _ SoundBuffer newMonoSampleCount: (sz + 1) // 2. - leftI _ rightI _ 1. - left _ true. - recordedBuffers do: [:b | - 1 to: b size do: [:j | - left - ifTrue: [leftBuf at: leftI put: (b at: j). leftI _ leftI + 1. left _ false] - ifFalse: [rightBuf at: rightI put: (b at: j). rightI _ rightI + 1. left _ true]]]. - ^ MixedSound new - add: (SampledSound new setSamples: leftBuf samplingRate: samplingRate) pan: 0.0; - add: (SampledSound new setSamples: rightBuf samplingRate: samplingRate) pan: 1.0 -! ! -!SoundRecorder methodsFor: 'trimming' stamp: 'jm 10/17/97 17:43'! - copyFrom: startPlace to: endPlace normalize: nFactor dcOffset: dcOffset - "Return a new SoundBuffer containing the samples in the given range." - - | startBufIndex startSampleIndex endBufIndex endSampleIndex - count resultBuf j buf firstInBuf n | - startBufIndex _ startPlace at: 1. - startSampleIndex _ startPlace at: 2. - endBufIndex _ endPlace at: 1. - endSampleIndex _ endPlace at: 2. - - startBufIndex = endBufIndex - ifTrue: [count _ endSampleIndex + 1 - startSampleIndex] - ifFalse: [ - count _ ((recordedBuffers at: startBufIndex) size + 1 - startSampleIndex). "first buffer" - count _ count + endSampleIndex. "last buffer" - startBufIndex + 1 to: endBufIndex - 1 do: - [:i | count _ count + (recordedBuffers at: i) size]]. "middle buffers" - resultBuf _ SoundBuffer newMonoSampleCount: count. - - j _ 1. "next destination index in resultBuf" - startBufIndex to: endBufIndex do: [:i | - buf _ recordedBuffers at: i. - firstInBuf _ 1. - n _ buf size. - i = startBufIndex ifTrue: [ - n _ (recordedBuffers at: startBufIndex) size + 1 - startSampleIndex. - firstInBuf _ startSampleIndex]. - i = endBufIndex ifTrue: [ - i = startBufIndex - ifTrue: [n _ endSampleIndex + 1 - startSampleIndex] - ifFalse: [n _ endSampleIndex]]. - self copyTo: resultBuf from: j to: (j + n - 1) - from: buf startingAt: firstInBuf - normalize: nFactor dcOffset: dcOffset. - j _ j + n]. - ^ resultBuf -! ! -!SoundRecorder methodsFor: 'trimming' stamp: 'jm 10/18/97 11:23'! - copyTo: resultBuf from: startIndex to: endIndex from: buf startingAt: firstInBuf normalize: nFactor dcOffset: dcOffset - "Copy samples from buf to resultBuf removing the DC offset and normalizing their volume in the process." - - | indexOffset | - indexOffset _ firstInBuf - startIndex. - startIndex to: endIndex do: [:i | - resultBuf at: i put: (((buf at: (i + indexOffset)) - dcOffset) * nFactor) // 1000]. -! ! -!SoundRecorder methodsFor: 'accessing' stamp: 'RAA 12/30/2000 10:28'! - desiredSampleRate: newRate - - "use of this method indicates a strong desire for the specified rate, even if - the OS/hardware are not cooperative" - - desiredSampleRate _ samplingRate _ newRate "Best are 44100 22050 11025" -! ! -!SoundRecorder methodsFor: 'private' stamp: 'RAA 1/2/2001 10:17'! - emitBuffer: buffer - - | sound ratio resultBuf | - - "since some sound recording devices cannot (or will not) record below a certain sample rate, - trim the samples down if the user really wanted fewer samples" - - (desiredSampleRate isNil or: [(ratio _ samplingRate // desiredSampleRate) <= 1]) ifTrue: [ - sound _ SampledSound new setSamples: buffer samplingRate: samplingRate. - ] ifFalse: [ - resultBuf _ SoundBuffer - averageEvery: ratio - from: buffer - upTo: buffer monoSampleCount. - sound _ SampledSound new setSamples: resultBuf samplingRate: samplingRate / ratio. - ]. - - recordedSound add: (codec ifNil: [sound] ifNotNil: [codec compressSound: sound])! ! -!SoundRecorder methodsFor: 'private' stamp: 'di 2/17/1999 11:13'! - emitPartialBuffer - | s | - s _ self samplesPerFrame. - self emitBuffer: (currentBuffer copyFrom: 1 to: ((nextIndex-1) +( s-1) truncateTo: s))! ! -!SoundRecorder methodsFor: 'trimming' stamp: 'di 2/16/1999 22:11'! - endPlace - - ^ Array with: recordedBuffers size with: recordedBuffers last size! ! -!SoundRecorder methodsFor: 'trimming' stamp: 'di 2/16/1999 22:11'! - firstSampleOverThreshold: threshold dcOffset: dcOffset startingAt: startPlace - "Beginning at startPlace, this routine will return the first place at which a sample exceeds the given threshold." - - | buf s iStart jStart nThreshold | - nThreshold _ threshold negated. - iStart _ startPlace first. - jStart _ startPlace second. - iStart to: recordedBuffers size do: - [:i | buf _ recordedBuffers at: i. - jStart to: buf size do: - [:j | s _ (buf at: j) - dcOffset. - (s < nThreshold or: [s > threshold]) ifTrue: - ["found a sample over threshold" - ^ Array with: i with: j]]. - jStart _ 1]. - ^ self endPlace! ! -!SoundRecorder methodsFor: 'recording controls' stamp: 'sw 6/10/2003 12:34'! - hasRecordedSound - "Answer whether the receiver currently has any recorded sound" - - ^ self recordedSound notNil! ! -!SoundRecorder methodsFor: 'initialization' stamp: 'jm 4/22/1999 14:30'! - initialize - "SoundRecorder new" - - stereo _ false. - samplingRate _ 11025. - recordLevel _ 0.5. - self initializeRecordingState. -! ! -!SoundRecorder methodsFor: 'initialization' stamp: 'jhm 10/15/97 14:30'! - initializeRecordingState - - recordProcess _ nil. - bufferAvailableSema _ nil. - paused _ true. - meteringBuffer _ nil. - meterLevel _ 0. - soundPlaying _ nil. - currentBuffer _ nil. - nextIndex _ 1. -! ! -!SoundRecorder methodsFor: 'accessing' stamp: 'jm 9/2/97 16:16'! - isPaused - "Return true if recording is paused." - - ^ paused -! ! -!SoundRecorder methodsFor: 'private' stamp: 'jm 9/2/97 16:16'! - meterFrom: start count: count in: buffer - "Update the meter level with the maximum signal level in the given range of the given buffer." - - | last max sample | - count = 0 ifTrue: [^ self]. "no new samples" - last _ start + count - 1. - max _ 0. - start to: last do: [:i | - sample _ buffer at: i. - sample < 0 ifTrue: [sample _ sample negated]. - sample > max ifTrue: [max _ sample]]. - meterLevel _ max. -! ! -!SoundRecorder methodsFor: 'accessing' stamp: 'jm 9/18/97 19:19'! - meterLevel - "Return the meter level, an integer in the range [0..100] where zero is silence and 100 represents the maximum signal level possible without clipping." - - ^ (100 * meterLevel) // 32768 -! ! -!SoundRecorder methodsFor: 'trimming' stamp: 'jm 10/18/97 11:22'! - normalizeFactorFor: percentOfMaxVolume min: min max: max dcOffset: dcOffset - "Return a normalization factor for the range of sample values and DC offset. A normalization factor is a fixed-point number that will be divided by 1000 after multiplication with each sample value." - - | peak factor | - peak _ (max - dcOffset) max: (min - dcOffset) negated. - peak = 0 ifTrue: [^ 1000]. - factor _ (32767.0 * percentOfMaxVolume) / (100.0 * peak). - ^ (factor * 1000.0) asInteger -! ! -!SoundRecorder methodsFor: 'recording controls' stamp: 'jmv 3/1/2010 14:07'! - pause - "Go into pause mode. The record level continues to be updated, but no sound is recorded." - - paused _ true. - (currentBuffer notNil and: [nextIndex > 1]) - ifTrue: [ - self emitPartialBuffer. - self allocateBuffer]. - - soundPlaying ifNotNil: [ - soundPlaying pause. - soundPlaying _ nil]. - "Note: there can be problems if canRecordWhilePlaying is true. Recorders which only pause will inhibit other recorders from recording. I chose to make #stopPlaying unconditional in a subclass. The same might be appropriate here at the expense of making recorders resumable" - - Preferences canRecordWhilePlaying ifFalse: [self stopRecording]. -! ! -!SoundRecorder methodsFor: 'trimming' stamp: 'di 2/16/1999 23:01'! - place: startPlace plus: nSamples - "Return the place that is nSamples (may be negative) beyond thisPlace." - - | i j remaining buf | - i _ startPlace first. - j _ startPlace second. - nSamples >= 0 - ifTrue: [remaining _ nSamples. - [buf _ recordedBuffers at: i. - (j + remaining) <= buf size ifTrue: [^ Array with: i with: j + remaining]. - i < recordedBuffers size] - whileTrue: [remaining _ remaining - (buf size - j + 1). - i _ i+1. j _ 1]. - ^ self endPlace] - ifFalse: [remaining _ nSamples negated. - [buf _ recordedBuffers at: i. - (j - remaining) >= 1 ifTrue: [^ Array with: i with: j - remaining]. - i > 1] - whileTrue: [remaining _ remaining - j. - i _ i-1. j _ (recordedBuffers at: i) size]. - ^ #(1 1)]! ! -!SoundRecorder methodsFor: 'recording controls' stamp: 'jm 10/17/97 14:53'! - playback - "Playback the sound that has been recorded." - - self pause. - soundPlaying _ self recordedSound. - soundPlaying play. -! ! -!SoundRecorder methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! - primGetActualRecordingSampleRate - "Return the actual sample rate being used for recording. This primitive fails unless sound recording is currently in progress." - - - self primitiveFailed -! ! -!SoundRecorder methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! - primRecordSamplesInto: aWordArray startingAt: index - "Record a sequence of 16-bit sound samples into the given array starting at the given sample index. Return the number of samples recorded, which may be zero if no samples are currently available." - - - self primitiveFailed -! ! -!SoundRecorder methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! - primSetRecordLevel: anInteger - "Set the desired recording level to the given value in the range 0-1000, where 0 is the lowest recording level and 1000 is the maximum. Do nothing if the sound input hardware does not support changing the recording level." - - - self primitiveFailed -! ! -!SoundRecorder methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! -primStartRecordingDesiredSampleRate: samplesPerSec stereo: stereoFlag semaIndex: anInteger - "Start sound recording with the given stereo setting. Use a sampling rate as close to the desired rate as the underlying platform will support. If the given semaphore index is > 0, it is taken to be the index of a Semaphore in the external objects array to be signalled every time a recording buffer is filled." - - - self primitiveFailed -! ! -!SoundRecorder methodsFor: 'primitives' stamp: 'tpr 2/15/2001 17:13'! - primStopRecording - "Stop sound recording. Does nothing if recording is not currently in progress. Do not fail if plugin is not available" - - ! ! -!SoundRecorder methodsFor: 'accessing' stamp: 'jm 7/4/1998 15:03'! - recordLevel - - ^ recordLevel -! ! -!SoundRecorder methodsFor: 'accessing' stamp: 'jm 7/4/1998 15:04'! - recordLevel: level - "Set the desired recording level to the given value in the range 0.0 to 1.0, where 0.0 is the lowest recording level and 1.0 is the maximum. Do nothing if the sound input hardware does not support changing the recording level." - "Details: On the Macintosh, the lowest possible record level attenuates the input signal, but does not silence it entirely." - - recordLevel _ (level asFloat min: 1.0) max: 0.0. - recordProcess ifNotNil: [ - self primSetRecordLevel: (1000.0 * recordLevel) asInteger]. -! ! -!SoundRecorder methodsFor: 'private' stamp: 'di 2/16/1999 08:55'! - recordLoop - "Record process loop that records samples." - - | n sampleCount | - n _ 0. - [true] whileTrue: [ - n = 0 ifTrue: [bufferAvailableSema wait]. - paused - ifTrue: [ - n _ self primRecordSamplesInto: meteringBuffer startingAt: 1. - self meterFrom: 1 count: n in: meteringBuffer] - ifFalse: [ - n _ self primRecordSamplesInto: currentBuffer startingAt: nextIndex. - self meterFrom: nextIndex count: n in: currentBuffer. - nextIndex _ nextIndex + n. - stereo - ifTrue: [sampleCount _ currentBuffer stereoSampleCount] - ifFalse: [sampleCount _ currentBuffer monoSampleCount]. - nextIndex > sampleCount - ifTrue: [ - self emitBuffer: currentBuffer. - self allocateBuffer]]]. -! ! -!SoundRecorder methodsFor: 'results' stamp: 'di 2/17/1999 11:07'! - recordedSound - "Return the sound that was recorded." - - ^ recordedSound -! ! -!SoundRecorder methodsFor: 'recording controls' stamp: 'RAA 8/13/2000 11:41'! - resumeRecording - "Continue recording from the point at which it was last paused." - - self flag: #bob. - "Note: If canRecordWhilePlaying is true, then recordings may never get started (at least by this method). One possibility, used in a subclass, is to make the #startPlaying unconditional. Another would be to use #startPlaying instead of #resumePlaying in appropriate cases" - - Preferences canRecordWhilePlaying ifFalse: [self startRecording]. - paused _ false. -! ! -!SoundRecorder methodsFor: 'private' stamp: 'jmv 3/1/2010 13:35'! - samplesPerFrame - "Can be overridden to quantize buffer size for, eg, fixed-frame codecs" - - ^codec - ifNil: [1] - ifNotNil: [codec samplesPerFrame]! ! -!SoundRecorder methodsFor: 'accessing' stamp: 'jm 12/15/97 14:28'! - samplingRate - - ^ samplingRate -! ! -!SoundRecorder methodsFor: 'accessing' stamp: 'di 2/16/1999 09:58'! - samplingRate: newRate - - samplingRate _ newRate "Best are 44100 22050 11025" -! ! -!SoundRecorder methodsFor: 'trimming' stamp: 'di 2/16/1999 23:19'! - scanForEndThreshold: threshold dcOffset: dcOffset minLull: lull startingAt: startPlace - "Beginning at startPlace, this routine will find the last sound that exceeds threshold, such that if you look lull samples later you will not find another sound over threshold within the following block of lull samples. - Return the place that is lull samples beyond to that last sound. - If no end of sound is found, return endPlace." - - | buf s iStart jStart nThreshold n | - nThreshold _ threshold negated. - iStart _ startPlace first. - jStart _ startPlace second. - n _ 0. - iStart to: recordedBuffers size do: - [:i | buf _ recordedBuffers at: i. - jStart to: buf size do: - [:j | s _ (buf at: j) - dcOffset. - (s < nThreshold or: [s > threshold]) - ifTrue: ["found a sample over threshold" - n _ 0] - ifFalse: ["still not over threshold" - n _ n + 1. - n >= lull ifTrue: [^ Array with: i with: j]]]. - jStart _ 1]. - ^ self endPlace! ! -!SoundRecorder methodsFor: 'trimming' stamp: 'di 3/4/1999 22:13'! - scanForStartThreshold: threshold dcOffset: dcOffset minDur: duration startingAt: startPlace - "Beginning at startPlace, this routine will find the first sound that exceeds threshold, such that if you look duration samples later you will find another sound over threshold within the following block of duration samples. - Return the place that is duration samples prior to that first sound. - If no sound is found, return endPlace." - - | soundPlace lookPlace nextSoundPlace thirdPlace | - soundPlace _ self firstSampleOverThreshold: threshold dcOffset: dcOffset - startingAt: startPlace. - [soundPlace = self endPlace ifTrue: [^ soundPlace]. - "Found a sound -- look duration later" - lookPlace _ self place: soundPlace plus: duration. - nextSoundPlace _ self firstSampleOverThreshold: threshold dcOffset: dcOffset - startingAt: lookPlace. - thirdPlace _ self place: lookPlace plus: duration. - nextSoundPlace first < thirdPlace first - or: [nextSoundPlace first = thirdPlace first - and: [nextSoundPlace second < thirdPlace second]]] - whileFalse: [soundPlace _ nextSoundPlace]. - - "Yes, there is sound in the next interval as well" - ^ self place: soundPlace plus: 0-duration -! ! -!SoundRecorder methodsFor: 'trimming' stamp: 'jmv 3/1/2010 13:35'! - segmentsAbove: threshold normalizedVolume: percentOfMaxVolume - "Break the current recording up into a sequence of sound segments separated by silences." - - | max min sum totalSamples bufSize s dcOffset firstPlace endPlace resultBuf nFactor lastPlace segments gapSize minDur minLull soundSize restSize | - stereo ifTrue: [self error: 'stereo trimming is not yet supported']. - paused ifFalse: [self error: 'must stop recording before trimming']. - (recordedSound == nil or: [recordedSound sounds isEmpty]) ifTrue:[^ self]. - "Reconstruct buffers so old trimming code will work" - recordedBuffers _ recordedSound sounds collect: [:snd | snd samples]. - soundSize _ restSize _ 0. - - max _ min _ sum _ totalSamples _ 0. - recordedBuffers do: [:buf | - bufSize _ buf size. - totalSamples _ totalSamples + buf size. - 1 to: bufSize do: [:i | - s _ buf at: i. - s > max ifTrue: [max _ s]. - s < min ifTrue: [min _ s]. - sum _ sum + s]]. - dcOffset _ sum // totalSamples. - - minDur _ (samplingRate/20.0) asInteger. " 1/20 second " - minLull _ (samplingRate/4.0) asInteger. " 1/2 second " - segments _ SequentialSound new. - endPlace _ self endPlace. - lastPlace _ #(1 1). - [firstPlace _ self scanForStartThreshold: threshold - dcOffset: dcOffset - minDur: minDur - startingAt: lastPlace. - firstPlace = endPlace] - whileFalse: - [firstPlace = lastPlace ifFalse: - ["Add a silence equal to the gap size" - "Wasteful but simple way to get gap size..." - gapSize _ (self copyFrom: lastPlace to: firstPlace - normalize: 1000 dcOffset: dcOffset) size - 2. - "... -2 makes up for overlap of one sample on either end" - segments add: (RestSound dur: gapSize asFloat / samplingRate). - restSize _ restSize + gapSize. -"Transcript cr; print: firstPlace; space; print: lastPlace; space; print: gapSize; space; show: 'gap'." - ]. - lastPlace _ self scanForEndThreshold: threshold - dcOffset: dcOffset - minLull: minLull + minDur - startingAt: firstPlace. - "Allow room for lead time of next sound" - lastPlace _ self place: lastPlace plus: minDur negated. - nFactor _ self normalizeFactorFor: percentOfMaxVolume - min: min max: max dcOffset: dcOffset. - resultBuf _ self copyFrom: firstPlace to: lastPlace - normalize: nFactor dcOffset: dcOffset. - soundSize _ soundSize + resultBuf size. -"Transcript cr; print: firstPlace; space; print: lastPlace; space; print: resultBuf size; space; show: 'sound'." - segments add: (codec - ifNil: [SampledSound new setSamples: resultBuf samplingRate: samplingRate] - ifNotNil: [codec compressSound: (SampledSound new setSamples: resultBuf samplingRate: samplingRate)])]. - - "Final gap for consistency" - gapSize _ (self copyFrom: lastPlace to: self endPlace - normalize: 1000 dcOffset: dcOffset) size - 1. - segments add: (RestSound dur: gapSize asFloat / samplingRate). - restSize _ restSize + gapSize. - self inform: ((soundSize+restSize/samplingRate) roundTo: 0.1) printString , ' secs reduced to ' , ((soundSize/samplingRate) roundTo: 0.1) printString. - recordedBuffers _ nil. - ^ segments! ! -!SoundRecorder methodsFor: 'results' stamp: 'di 2/17/1999 21:24'! - soundSegments - - ^ self segmentsAbove: 1000 normalizedVolume: 80.0 -! ! -!SoundRecorder methodsFor: 'recording controls' stamp: 'jmv 10/8/2012 22:13'! - startRecording - "Turn of the sound input driver and start the recording process. Initially, recording is paused." - - | semaIndex | - recordLevel ifNil: [recordLevel _ 0.5]. "lazy initialization" - Preferences canRecordWhilePlaying ifFalse: [SoundPlayer shutDown]. - recordProcess ifNotNil: [self stopRecording]. - paused _ true. - meteringBuffer _ SoundBuffer newMonoSampleCount: 1024. - meterLevel _ 0. - self allocateBuffer. - bufferAvailableSema _ Semaphore new. - semaIndex _ Smalltalk registerExternalObject: bufferAvailableSema. - self primStartRecordingDesiredSampleRate: samplingRate asInteger - stereo: stereo - semaIndex: semaIndex. - RecorderActive _ true. - samplingRate _ self primGetActualRecordingSampleRate. - self primSetRecordLevel: (1000.0 * recordLevel) asInteger. - recordProcess _ [self recordLoop] newProcess. - recordProcess - priority: Processor userInterruptPriority; - name: 'Sound Recorder'; - resume. -! ! -!SoundRecorder methodsFor: 'recording controls' stamp: 'jmv 3/1/2010 14:08'! - stopRecording - "Stop the recording process and turn of the sound input driver." - - recordProcess ifNotNil: [recordProcess terminate]. - recordProcess _ nil. - self primStopRecording. - RecorderActive _ false. - Smalltalk unregisterExternalObject: bufferAvailableSema. - (currentBuffer notNil and: [nextIndex > 1]) - ifTrue: [self emitPartialBuffer]. - self initializeRecordingState. -! ! -!SoundRecorder methodsFor: 'trimming' stamp: 'di 2/17/1999 20:38'! - suppressSilence - - recordedSound _ self soundSegments! ! -!SoundRecorder methodsFor: 'trimming' stamp: 'di 3/4/1999 22:52'! - trim: threshold normalizedVolume: percentOfMaxVolume - "Remove the leading and trailing parts of this recording that are below the given threshold. Remove any DC offset and scale the recording so that its peaks are the given percent of the maximum volume." - - | max min sum totalSamples bufSize s dcOffset startPlace endPlace resultBuf nFactor | - stereo ifTrue: [self error: 'stereo trimming is not yet supported']. - paused ifFalse: [self error: 'must stop recording before trimming']. - recordedBuffers _ recordedSound sounds collect: [:snd | snd samples]. - recordedBuffers isEmpty ifTrue: [^ self]. - - max _ min _ sum _ totalSamples _ 0. - recordedBuffers do: [:buf | - bufSize _ buf size. - totalSamples _ totalSamples + buf size. - 1 to: bufSize do: [:i | - s _ buf at: i. - s > max ifTrue: [max _ s]. - s < min ifTrue: [min _ s]. - sum _ sum + s]]. - dcOffset _ sum // totalSamples. - - "a place is an array of " - startPlace _ self scanForStartThreshold: threshold - dcOffset: dcOffset - minDur: (samplingRate/60.0) asInteger "at least 1/60th of a second" - startingAt: #(1 1). - startPlace = self endPlace ifTrue: - ["no samples above threshold" - recordedBuffers _ nil. ^ self]. - - endPlace _ self scanForEndThreshold: threshold - dcOffset: dcOffset - minLull: (samplingRate/5) asInteger - startingAt: startPlace. - nFactor _ self normalizeFactorFor: percentOfMaxVolume min: min max: max dcOffset: dcOffset. - resultBuf _ self copyFrom: startPlace to: endPlace normalize: nFactor dcOffset: dcOffset. - recordedSound _ SampledSound new setSamples: resultBuf samplingRate: samplingRate. - recordedBuffers _ nil -! ! -!SoundRecorder methodsFor: 'recording controls' stamp: 'jmv 2/22/2011 22:51'! - verifyExistenceOfRecordedSound - "If the receiver has a recorded sound, answer true; if not, put up an informer and answer false" - - ^ self recordedSound - ifNotNil: - [true] - ifNil: [ - self inform: 'please record a sound first'. - false]! ! -!SoundRecorder class methodsFor: 'accessing' stamp: 'ar 2/1/2001 15:20'! - anyActive - "Return true if any sound recorder is actively recording" - ^RecorderActive == true! ! -!SoundRecorder class methodsFor: 'accessing' stamp: 'RAA 8/7/2000 19:23'! - canRecordWhilePlaying - "Return true if this platform supports simultaneous sound recording and playback." - - ^Preferences canRecordWhilePlaying. "now in preferences" -! ! -!SoundRecorder class methodsFor: 'class initialization' stamp: 'RAA 8/7/2000 19:23'! - initialize - "SoundRecorder initialize" - "Details: Some computers cannot record and playback sound at the same time. If CanRecordWhilePlaying is false, then the SoundRecorder alternates between recording and playing. If it is true, sounds can be playing during recording." - - CanRecordWhilePlaying _ #ignoredNowInPreferences. -! ! -!SoundInputStream methodsFor: 'private' stamp: 'jm 9/8/1999 15:24'! - allocateBuffer - "Allocate a new buffer and reset nextIndex. This message is sent by the sound input process." - - currentBuffer _ SoundBuffer newMonoSampleCount: bufferSize. - nextIndex _ 1. -! ! -!SoundInputStream methodsFor: 'accessing' stamp: 'jm 9/8/1999 15:26'! - bufferCount - "Answer the number of sound buffers that have been queued." - - | n | - mutex ifNil: [^ 0]. "not recording" - mutex critical: [n _ recordedBuffers size]. - ^ n -! ! -!SoundInputStream methodsFor: 'accessing' stamp: 'jm 9/6/1999 10:36'! - bufferSize - - ^ bufferSize -! ! -!SoundInputStream methodsFor: 'accessing' stamp: 'jm 9/8/1999 15:26'! - bufferSize: aNumber - "Set the sound buffer size. Buffers of this size will be queued for the client to process." - - bufferSize _ aNumber truncated. -! ! -!SoundInputStream methodsFor: 'private' stamp: 'jm 9/8/1999 15:24'! - emitBuffer: buffer - "Queue a buffer for later processing. This message is sent by the sound input process." - - mutex critical: [recordedBuffers addLast: buffer]. -! ! -!SoundInputStream methodsFor: 'initialization' stamp: 'jm 9/8/1999 15:22'! - initialize - - super initialize. - bufferSize _ 1024. - mutex _ nil. -! ! -!SoundInputStream methodsFor: 'accessing' stamp: 'jmv 3/1/2010 14:07'! - isRecording - "Answer true if the sound input process is running." - - ^ recordProcess notNil -! ! -!SoundInputStream methodsFor: 'accessing' stamp: 'jm 9/6/1999 10:32'! - nextBufferOrNil - "Answer the next input buffer or nil if no buffer is available." - - | result | - mutex ifNil: [^ nil]. "not recording" - mutex critical: [ - recordedBuffers size > 0 - ifTrue: [result _ recordedBuffers removeFirst] - ifFalse: [result _ nil]]. - ^ result -! ! -!SoundInputStream methodsFor: 'recording controls' stamp: 'jm 9/8/1999 15:23'! - startRecording - "Start the sound input process." - - recordProcess ifNotNil: [self stopRecording]. - recordedBuffers _ OrderedCollection new: 100. - mutex _ Semaphore forMutualExclusion. - super startRecording. - paused _ false. -! ! -!SoundInputStream methodsFor: 'recording controls' stamp: 'jm 9/8/1999 15:23'! - stopRecording - "Turn off the sound input process and close the driver." - - super stopRecording. - recordedBuffers _ nil. - mutex _ nil. -! ! -!AbstractScoreEvent methodsFor: 'accessing' stamp: 'di 6/17/1999 14:28'! - adjustTimeBy: delta - - time _ time + delta -! ! -!AbstractScoreEvent methodsFor: 'accessing' stamp: 'jm 8/27/1998 16:38'! - endTime - "Subclasses should override to return the ending time if the event has some duration." - - ^ time -! ! -!AbstractScoreEvent methodsFor: 'classification' stamp: 'jm 9/10/1998 09:43'! - isControlChange - - ^ false -! ! -!AbstractScoreEvent methodsFor: 'classification' stamp: 'jm 12/31/97 11:46'! - isNoteEvent - - ^ false -! ! -!AbstractScoreEvent methodsFor: 'classification' stamp: 'jm 9/10/1998 09:43'! - isPitchBend - - ^ false -! ! -!AbstractScoreEvent methodsFor: 'classification' stamp: 'jm 9/10/1998 09:43'! - isProgramChange - - ^ false -! ! -!AbstractScoreEvent methodsFor: 'classification' stamp: 'jm 12/31/97 11:46'! - isTempoEvent - - ^ false -! ! -!AbstractScoreEvent methodsFor: 'midi' stamp: 'jm 9/10/1998 18:31'! - outputOnMidiPort: aMidiPort - "Output this event to the given MIDI port. This default implementation does nothing." -! ! -!AbstractScoreEvent methodsFor: 'accessing' stamp: 'jm 12/31/97 11:43'! - time - - ^ time -! ! -!AbstractScoreEvent methodsFor: 'accessing' stamp: 'jm 12/31/97 11:43'! - time: aNumber - - time _ aNumber. -! ! -!ControlChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:47'! - channel - - ^ channel -! ! -!ControlChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:47'! - channel: midiChannel - - channel _ midiChannel. -! ! -!ControlChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:49'! - control - - ^ control -! ! -!ControlChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:48'! - control: midiControl - - control _ midiControl. -! ! -!ControlChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 08:03'! - control: midiControl value: midiControlValue channel: midiChannel - - control _ midiControl. - value _ midiControlValue. - channel _ midiChannel. -! ! -!ControlChangeEvent methodsFor: 'classification' stamp: 'jm 9/10/1998 09:45'! -isControlChange - - ^ true -! ! -!ControlChangeEvent methodsFor: 'midi' stamp: 'jm 9/10/1998 18:31'! - outputOnMidiPort: aMidiPort - "Output this event to the given MIDI port." - - aMidiPort - midiCmd: 16rB0 - channel: channel - byte: control - byte: value. -! ! -!ControlChangeEvent methodsFor: 'printing' stamp: 'sma 6/1/2000 09:34'! - printOn: aStream - aStream - nextPut: $(; - print: time; - nextPutAll: ': ctrl['; - print: control; - nextPutAll: ']='; - print: value; - nextPut: $)! ! -!ControlChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 08:02'! - value - - ^ value -! ! -!ControlChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 08:03'! - value: midiControlValue - - value _ midiControlValue. -! ! -!NoteEvent methodsFor: 'accessing' stamp: 'jm 12/30/97 22:02'! - channel - - ^ channel -! ! -!NoteEvent methodsFor: 'accessing' stamp: 'jm 12/30/97 22:02'! - channel: midiChannel - - channel _ midiChannel. -! ! -!NoteEvent methodsFor: 'accessing' stamp: 'jm 12/18/97 19:10'! - duration - - ^ duration -! ! -!NoteEvent methodsFor: 'accessing' stamp: 'jm 12/31/97 11:49'! - duration: aNumber - - duration _ aNumber. -! ! -!NoteEvent methodsFor: 'midi' stamp: 'jm 9/10/1998 15:58'! - endNoteOnMidiPort: aMidiPort - "Output a noteOff event to the given MIDI port. (Actually, output a noteOff event with zero velocity. This does the same thing, but allows running status to be used when sending a mixture of note on and off commands.)" - - aMidiPort - midiCmd: 16r90 - channel: channel - byte: midiKey - byte: 0. -! ! -!NoteEvent methodsFor: 'accessing' stamp: 'jm 8/27/1998 16:38'! - endTime - - ^ time + duration -! ! -!NoteEvent methodsFor: 'classification' stamp: 'jm 12/31/97 11:48'! - isNoteEvent - - ^ true -! ! -!NoteEvent methodsFor: 'accessing' stamp: 'jm 12/30/97 22:07'! - key: midiKeyNum velocity: midiVelocity channel: midiChannel - - midiKey _ midiKeyNum. - velocity _ midiVelocity. - channel _ midiChannel. -! ! -!NoteEvent methodsFor: 'printing' stamp: 'jm 1/3/98 08:58'! - keyName - "Return a note name for my pitch." - - | pitchName octave | - pitchName _ #(c cs d ef e f fs g af a bf b) at: (midiKey \\ 12) + 1. - octave _ (#(-1 0 1 2 3 4 5 6 7 8 9) at: (midiKey // 12) + 1) printString. - ^ pitchName, octave -! ! -!NoteEvent methodsFor: 'accessing' stamp: 'jm 12/18/97 20:58'! - midiKey - - ^ midiKey -! ! -!NoteEvent methodsFor: 'accessing' stamp: 'jm 12/30/97 09:35'! - midiKey: midiKeyNum - - midiKey _ midiKeyNum. -! ! -!NoteEvent methodsFor: 'accessing' stamp: 'jm 8/3/1998 17:06'! - pitch - "Convert my MIDI key number to a pitch and return it." - - ^ AbstractSound pitchForMIDIKey: midiKey -! ! -!NoteEvent methodsFor: 'printing' stamp: 'jm 1/3/98 08:59'! - printOn: aStream - - aStream nextPut: $(. - time printOn: aStream. - aStream nextPutAll: ': '. - aStream nextPutAll: self keyName. - aStream space. - duration printOn: aStream. - aStream nextPut: $). -! ! -!NoteEvent methodsFor: 'midi' stamp: 'jm 9/10/1998 15:56'! - startNoteOnMidiPort: aMidiPort - "Output a noteOn event to the given MIDI port." - - aMidiPort - midiCmd: 16r90 - channel: channel - byte: midiKey - byte: velocity. -! ! -!NoteEvent methodsFor: 'accessing' stamp: 'jm 12/30/97 09:32'! - velocity - - ^ velocity -! ! -!NoteEvent methodsFor: 'accessing' stamp: 'jm 12/31/97 11:51'! - velocity: midiVelocity - - velocity _ midiVelocity. -! ! -!PitchBendEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:49'! - bend - - ^ bend -! ! -!PitchBendEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:48'! - bend: midiPitchBend - - bend _ midiPitchBend. -! ! -!PitchBendEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:48'! - bend: midiPitchBend channel: midiChannel - - bend _ midiPitchBend. - channel _ midiChannel. -! ! -!PitchBendEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:47'! - channel - - ^ channel -! ! -!PitchBendEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:47'! - channel: midiChannel - - channel _ midiChannel. -! ! -!PitchBendEvent methodsFor: 'classification' stamp: 'jm 9/10/1998 09:45'! - isPitchBend - - ^ true -! ! -!PitchBendEvent methodsFor: 'midi' stamp: 'jm 9/10/1998 18:31'! - outputOnMidiPort: aMidiPort - "Output this event to the given MIDI port." - - aMidiPort - midiCmd: 16rE0 - channel: channel - byte: (bend bitAnd: 16r7F) - byte: (bend bitShift: -7). -! ! -!PitchBendEvent methodsFor: 'printing' stamp: 'jm 9/10/1998 09:42'! - printOn: aStream - - aStream nextPut: $(. - time printOn: aStream. - aStream nextPutAll: ': bend '. - bend printOn: aStream. - aStream nextPut: $). -! ! -!ProgramChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:47'! - channel - - ^ channel -! ! -!ProgramChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:47'! - channel: midiChannel - - channel _ midiChannel. -! ! -!ProgramChangeEvent methodsFor: 'classification' stamp: 'jm 9/10/1998 09:46'! -isProgramChange - - ^ true -! ! -!ProgramChangeEvent methodsFor: 'midi' stamp: 'jm 9/10/1998 18:31'! - outputOnMidiPort: aMidiPort - "Output this event to the given MIDI port." - - aMidiPort - midiCmd: 16rC0 - channel: channel - byte: program. -! ! -!ProgramChangeEvent methodsFor: 'printing' stamp: 'jm 9/10/1998 08:28'! - printOn: aStream - - aStream nextPut: $(. - time printOn: aStream. - aStream nextPutAll: ': prog '. - program printOn: aStream. - aStream nextPut: $). -! ! -!ProgramChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:49'! - program - - ^ program -! ! -!ProgramChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:48'! - program: midiProgramChange - - program _ midiProgramChange. -! ! -!ProgramChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:48'! - program: midiProgramChange channel: midiChannel - - program _ midiProgramChange. - channel _ midiChannel. -! ! -!TempoEvent methodsFor: 'as yet unclassified' stamp: 'jm 12/30/97 10:10'! - isTempoEvent - - ^ true -! ! -!TempoEvent methodsFor: 'as yet unclassified' stamp: 'jm 9/10/1998 08:37'! - printOn: aStream - - aStream nextPut: $(. - time printOn: aStream. - aStream nextPutAll: ': tempo '. - ((120.0 * (500000.0 / tempo)) roundTo: 0.01) printOn: aStream. - aStream nextPut: $). -! ! -!TempoEvent methodsFor: 'as yet unclassified' stamp: 'jm 12/30/97 10:09'! - tempo - - ^ tempo -! ! -!TempoEvent methodsFor: 'as yet unclassified' stamp: 'jm 12/30/97 10:09'! - tempo: anInteger - - tempo _ anInteger. -! ! -!MIDIFileReader methodsFor: 'chunk reading' stamp: 'jm 1/6/98 23:20'! - asScore - - ^ MIDIScore new - tracks: tracks; - trackInfo: trackInfo; - tempoMap: tempoMap; - ticksPerQuarterNote: ticksPerQuarter -! ! -!MIDIFileReader methodsFor: 'track reading' stamp: 'jm 3/28/98 05:44'! - endAllNotesAt: endTicks - "End of score; end any notes still sounding." - "Details: Some MIDI files have missing note-off events, resulting in very long notes. Truncate any such notes encountered." - - | dur | - activeEvents do: [:e | - dur _ endTicks - e time. - dur > maxNoteTicks ifTrue: [dur _ ticksPerQuarter]. "truncate long note" - e duration: dur]. - activeEvents _ activeEvents species new. -! ! -!MIDIFileReader methodsFor: 'track reading' stamp: 'jmv 3/2/2010 09:56'! - endNote: midiKey chan: channel at: endTicks - - | evt | - evt _ activeEvents - detect: [:e | (e midiKey = midiKey) and: [e channel = channel]] - ifNone: [^ self]. - evt duration: (endTicks - evt time). - activeEvents remove: evt ifAbsent: nil! ! -!MIDIFileReader methodsFor: 'private' stamp: 'jmv 3/2/2010 09:56'! - guessMissingInstrumentNames - "Attempt to guess missing instrument names from the first program change in that track." - - | progChange instrIndex instrName | - 1 to: tracks size do: [:i | - (trackInfo at: i) isEmpty ifTrue: [ - progChange _ (tracks at: i) detect: [:e | e isProgramChange] ifNone: nil. - progChange ifNotNil: [ - instrIndex _ progChange program + 1. - instrName _ self class standardMIDIInstrumentNames at: instrIndex. - trackInfo at: i put: instrName]]]. -! ! -!MIDIFileReader methodsFor: 'track reading' stamp: 'jm 1/3/98 09:45'! - isTempoTrack: anEventList - "Return true if the given event list is non-empty and contains only tempo change events." - - anEventList isEmpty ifTrue: [^ false]. - anEventList do: [:evt | evt isTempoEvent ifFalse: [^ false]]. - ^ true -! ! -!MIDIFileReader methodsFor: 'track reading' stamp: 'jm 9/27/1998 22:15'! - metaEventAt: ticks - "Read a meta event. Event types appear roughly in order of expected frequency." - - | type length tempo | - type _ trackStream next. - length _ self readVarLengthIntFrom: trackStream. - - type = 16r51 ifTrue: [ "tempo" - tempo _ 0. - length timesRepeat: [tempo _ (tempo bitShift: 8) + trackStream next]. - track add: (TempoEvent new tempo: tempo; time: ticks). - ^ self]. - - type = 16r2F ifTrue: [ "end of track" - length = 0 ifFalse: [self error: 'length of end-of-track chunk should be zero']. - self endAllNotesAt: ticks. - trackStream skip: length. - ^ self]. - - type = 16r58 ifTrue: [ "time signature" - length = 4 ifFalse: [self error: 'length of time signature chunk should be four']. - trackStream skip: length. - ^ self]. - - type = 16r59 ifTrue: [ "key signature" - length = 2 ifFalse: [self error: 'length of key signature chunk should be two']. - trackStream skip: length. - ^ self]. - - ((type >= 1) and: [type <= 7]) ifTrue: [ "string" - strings add: (trackStream next: length) asString. - ^ self]. - - ( type = 16r21 or: "mystery; found in MIDI files but not in MIDI File 1.0 Spec" - [(type = 16r7F) or: "sequencer specific meta event" - [(type = 16r00) or: "sequence number" - [(type = 16r20)]]]) "MIDI channel prefix" - ifTrue: [ - trackStream skip: length. - ^ self]. - - type = 16r54 ifTrue: [ - "SMPTE offset" - self report: 'Ignoring SMPTE offset'. - trackStream skip: length. - ^ self]. - - "skip unrecognized meta event" - self report: - 'skipping unrecognized meta event: ', (type printStringBase: 16), - ' (', length printString, ' bytes)'. - trackStream skip: length. -! ! -!MIDIFileReader methodsFor: 'private' stamp: 'jm 12/31/97 10:30'! - next16BitWord - "Read a 16-bit positive integer from the input stream, most significant byte first." - "Assume: Stream has at least two bytes left." - - | n | - n _ stream next. - ^ (n bitShift: 8) + stream next -! ! -!MIDIFileReader methodsFor: 'private' stamp: 'ar 1/27/98 17:27'! - next32BitWord: msbFirst - "Read a 32-bit positive integer from the input stream." - "Assume: Stream has at least four bytes left." - - | n | - n _ stream next: 4. - ^msbFirst - ifTrue:[((n at: 1) bitShift: 24) + ((n at: 2) bitShift: 16) + ((n at: 3) bitShift: 8) + (n at: 4)] - ifFalse:[((n at: 4) bitShift: 24) + ((n at: 3) bitShift: 16) + ((n at: 2) bitShift: 8) + (n at: 1)] -! ! -!MIDIFileReader methodsFor: 'private' stamp: 'jm 12/31/97 10:29'! - readChunkSize - "Read a 32-bit positive integer from the next 4 bytes, most significant byte first." - "Assume: Stream has at least four bytes left." - - | n | - n _ 0. - 1 to: 4 do: [:ignore | n _ (n bitShift: 8) + stream next]. - ^ n -! ! -!MIDIFileReader methodsFor: 'private' stamp: 'jm 9/12/1998 17:32'! - readChunkType - "Read a chunk ID string from the next 4 bytes." - "Assume: Stream has at least four bytes left." - - | s | - s _ String new: 4. - 1 to: 4 do: [:i | s at: i put: (stream next) asCharacter]. - ^ s -! ! -!MIDIFileReader methodsFor: 'chunk reading' stamp: 'jmv 3/13/2012 12:37'! - readHeaderChunk - - | chunkType chunkSize division | - chunkType _ self readChunkType. - chunkType = 'RIFF' ifTrue:[chunkType _ self riffSkipToMidiChunk]. - chunkType = 'MThd' ifFalse: [self scanForMIDIHeader]. - chunkSize _ self readChunkSize. - fileType _ self next16BitWord. - trackCount _ self next16BitWord. - division _ self next16BitWord. - (division anyMask: 16r8000) - ifTrue: [self error: 'SMPTE time formats are not yet supported'] - ifFalse: [ticksPerQuarter _ division]. - maxNoteTicks _ 12 * 4 * ticksPerQuarter. - "longest acceptable note; used to detect stuck notes" - - "sanity checks" - ((chunkSize < 6) or: [chunkSize > 100]) - ifTrue: [self error: 'unexpected MIDI header size ', chunkSize printString]. - (#(0 1 2) includes: fileType) - ifFalse: [self error: 'unknown MIDI file type ', fileType printString]. - - Transcript - show: 'Reading Type ', fileType printString, ' MIDI File ('; - show: trackCount printString, ' tracks, '; - show: ticksPerQuarter printString, ' ticks per quarter note)'; - newLine. -! ! -!MIDIFileReader methodsFor: 'chunk reading' stamp: 'jm 9/12/1998 19:08'! - readMIDIFrom: aBinaryStream - "Read one or more MIDI tracks from the given binary stream." - - stream _ aBinaryStream. - tracks _ OrderedCollection new. - trackInfo _ OrderedCollection new. - self readHeaderChunk. - trackCount timesRepeat: [self readTrackChunk]. - stream atEnd ifFalse: [self report: 'data beyond final track']. - fileType = 0 ifTrue: [self splitIntoTracks]. - self guessMissingInstrumentNames. -! ! -!MIDIFileReader methodsFor: 'chunk reading' stamp: 'jm 12/31/97 10:41'! - readTrackChunk - - | chunkType chunkSize | - chunkType _ self readChunkType. - [chunkType = 'MTrk'] whileFalse: [ - self report: 'skipping unexpected chunk type "', chunkType, '"'. - stream skip: (self readChunkSize). "skip it" - chunkType _ (stream next: 4) asString]. - chunkSize _ self readChunkSize. - chunkSize < 10000000 ifFalse: [ - self error: 'suspiciously large track chunk; this may not be MIDI file']. - - self readTrackContents: chunkSize. -! ! -!MIDIFileReader methodsFor: 'track reading' stamp: 'jmv 3/13/2012 12:37'! - readTrackContents: byteCount - - | info | - strings _ OrderedCollection new. - track _ OrderedCollection new. - trackStream _ ReadStream on: (stream next: byteCount). - activeEvents _ OrderedCollection new. - self readTrackEvents. - (tracks isEmpty and: [self isTempoTrack: track]) - ifTrue: [tempoMap _ track asArray] - ifFalse: [ - "Note: Tracks without note events are currently not saved to - eliminate clutter in the score player. In control applications, - this can be easily changed by modifying the following test." - (self trackContainsNotes: track) ifTrue: [ - tracks add: track asArray. - info _ WriteStream on: (String new: 100). - strings do: [:s | info nextPutAll: s; newLine]. - trackInfo add: info contents]]. - strings _ track _ trackStream _ activeEvents _ nil. -! ! -!MIDIFileReader methodsFor: 'track reading' stamp: 'jm 9/10/1998 09:57'! - readTrackEvents - "Read the events of the current track." - - | cmd chan key vel ticks byte length evt | - cmd _ #unknown. - chan _ key _ vel _ 0. - ticks _ 0. - [trackStream atEnd] whileFalse: [ - ticks _ ticks + (self readVarLengthIntFrom: trackStream). - byte _ trackStream next. - byte >= 16rF0 - ifTrue: [ "meta or system exclusive event" - byte = 16rFF ifTrue: [self metaEventAt: ticks]. - ((byte = 16rF0) or: [byte = 16rF7]) ifTrue: [ "system exclusive data" - length _ self readVarLengthIntFrom: trackStream. - trackStream skip: length]. - cmd _ #unknown] - ifFalse: [ "channel message event" - byte >= 16r80 - ifTrue: [ "new command" - cmd _ byte bitAnd: 16rF0. - chan _ byte bitAnd: 16r0F. - key _ trackStream next] - ifFalse: [ "use running status" - cmd == #unknown - ifTrue: [self error: 'undefined running status; bad MIDI file?']. - key _ byte]. - - ((cmd = 16rC0) or: [cmd = 16rD0]) ifFalse: [ - "all but program change and channel pressure have two data bytes" - vel _ trackStream next]. - - cmd = 16r80 ifTrue: [ "note off" - self endNote: key chan: chan at: ticks]. - - cmd = 16r90 ifTrue: [ "note on" - vel = 0 - ifTrue: [self endNote: key chan: chan at: ticks] - ifFalse: [self startNote: key vel: vel chan: chan at: ticks]]. - - "cmd = 16A0 -- polyphonic key pressure; skip" - - cmd = 16rB0 ifTrue: [ - evt _ ControlChangeEvent new control: key value: vel channel: chan. - evt time: ticks. - track add: evt]. - - cmd = 16rC0 ifTrue: [ - evt _ ProgramChangeEvent new program: key channel: chan. - evt time: ticks. - track add: evt]. - - "cmd = 16D0 -- channel aftertouch pressure; skip" - - cmd = 16rE0 ifTrue: [ - evt _ PitchBendEvent new bend: key + (vel bitShift: 7) channel: chan. - evt time: ticks. - track add: evt] - ]]. -! ! -!MIDIFileReader methodsFor: 'private' stamp: 'jm 12/31/97 11:33'! -readVarLengthIntFrom: aBinaryStream - "Read a one to four byte positive integer from the given stream, most significant byte first. Use only the lowest seven bits of each byte. The highest bit of a byte is set for all bytes except the last." - - | n byte | - n _ 0. - 1 to: 4 do: [:ignore | - byte _ aBinaryStream next. - byte < 128 ifTrue: [ - n = 0 - ifTrue: [^ byte] "optimization for one-byte lengths" - ifFalse: [^ (n bitShift: 7) + byte]]. - n _ (n bitShift: 7) + (byte bitAnd: 16r7F)]. - - self error: 'variable length quantity must not exceed four bytes'. -! ! -!MIDIFileReader methodsFor: 'private' stamp: 'jmv 3/13/2012 12:37'! - report: aString - - Transcript show: aString; newLine! ! -!MIDIFileReader methodsFor: 'private' stamp: 'jm 2/1/98 19:20'! - riffSkipToMidiChunk - "This file is a RIFF file which may (or may not) contain a MIDI chunk. Thanks to Andreas Raab for this code." - - | dwLength fourcc | - "Read length of all data" - dwLength := self next32BitWord: false. - "Get RIFF contents type " - fourcc := self readChunkType. - fourcc = 'RMID' ifFalse:[^fourcc]. "We can only read RMID files here" - "Search for data" - [[fourcc := self readChunkType. - dwLength := self next32BitWord: false. - fourcc = 'data'] whileFalse:[ - "Skip chunk - rounded to word boundary" - stream skip: (dwLength + 1 bitAnd: 16rFFFFFFFE). - stream atEnd ifTrue:[^'']]. - "Data chunk is raw - look into if it contains MIDI data and skip if not" - fourcc := self readChunkType. - fourcc = 'MThd'] whileFalse:[ - "Skip data (chunk - 4bytes) rounded to word boundary" - stream skip: (dwLength - 3 bitAnd: 16rFFFFFFFE)]. - ^fourcc! ! -!MIDIFileReader methodsFor: 'private' stamp: 'jmv 3/1/2010 14:05'! - scanForMIDIHeader - "Scan the first part of this file in search of the MIDI header string 'MThd'. Report an error if it is not found. Otherwise, leave the input stream positioned to the first byte after this string." - - | asciiM p lastSearchPosition byte restOfHeader | - asciiM _ $M asciiValue. - stream skip: -3. - p _ stream position. - lastSearchPosition _ p + 10000. "search only the first 10000 bytes of the file" - [p < lastSearchPosition and: [stream atEnd not]] whileTrue: [ - [(byte _ stream next) ~= asciiM and: [byte notNil]] whileTrue. "find the next 'M' or file end" - restOfHeader _ (stream next: 3) asString. - restOfHeader = 'Thd' - ifTrue: [^ self] - ifFalse: [restOfHeader size = 3 ifTrue: [stream skip: -3]]. - p _ stream position]. - - self error: 'MIDI header chunk not found'. -! ! -!MIDIFileReader methodsFor: 'private' stamp: 'jm 9/12/1998 20:10'! - splitIntoTracks - "Split a type zero MIDI file into separate tracks by channel number." - - | newTempoMap newTracks | - tracks size = 1 ifFalse: [self error: 'expected exactly one track in type 0 file']. - tempoMap ifNotNil: [self error: 'did not expect a tempo map in type 0 file']. - newTempoMap _ OrderedCollection new. - newTracks _ (1 to: 16) collect: [:i | OrderedCollection new]. - tracks first do: [:e | - e isTempoEvent - ifTrue: [newTempoMap addLast: e] - ifFalse: [(newTracks at: e channel + 1) addLast: e]]. - newTempoMap size > 0 ifTrue: [tempoMap _ newTempoMap asArray]. - newTracks _ newTracks select: [:t | self trackContainsNotes: t]. - tracks _ newTracks collect: [:t | t asArray]. - trackInfo _ trackInfo, ((2 to: tracks size) collect: [:i | '']). -! ! -!MIDIFileReader methodsFor: 'track reading' stamp: 'jmv 3/2/2010 09:56'! - startNote: midiKey vel: vel chan: chan at: startTicks - "Record the beginning of a note." - "Details: Some MIDI scores have missing note-off events, causing a note-on to be received for a (key, channel) that is already sounding. If the previous note is suspiciously long, truncate it." - - | newActiveEvents dur noteOnEvent | - newActiveEvents _ nil. - activeEvents do: [:e | - ((e midiKey = midiKey) and: [e channel = chan]) ifTrue: [ - "turn off key already sounding" - dur _ startTicks - e time. - dur > maxNoteTicks ifTrue: [dur _ ticksPerQuarter]. "truncate" - e duration: dur. - newActiveEvents ifNil: [newActiveEvents _ activeEvents copy]. - newActiveEvents remove: e ifAbsent: nil]]. - newActiveEvents ifNotNil: [activeEvents _ newActiveEvents]. - - noteOnEvent _ NoteEvent new key: midiKey velocity: vel channel: chan. - noteOnEvent time: startTicks. - track add: noteOnEvent. - activeEvents add: noteOnEvent! ! -!MIDIFileReader methodsFor: 'track reading' stamp: 'jm 9/12/1998 17:15'! - trackContainsNotes: eventList - "Answer true if the given track contains at least one note event." - - eventList do: [:e | e isNoteEvent ifTrue: [^ true]]. - ^ false -! ! -!MIDIFileReader class methodsFor: 'as yet unclassified' stamp: 'jmv 4/1/2009 21:42'! - playFileNamed: fileName -" - ScorePlayerMorph openOn: (self scoreFromFileNamed: fileName) - title: (FileDirectory localNameFor: fileName)"! ! -!MIDIFileReader class methodsFor: 'as yet unclassified' stamp: 'jmv 4/1/2009 21:43'! - playStream: binaryStream -" - ScorePlayerMorph openOn: (self scoreFromStream: binaryStream) - title: 'a MIDI stream'"! ! -!MIDIFileReader class methodsFor: 'as yet unclassified' stamp: 'jmv 4/1/2009 21:43'! - playURLNamed: urlString -" - | titleString | - titleString := urlString copyFrom: (urlString findLast: [:c | c = $/]) + 1 - to: urlString size. - ScorePlayerMorph openOn: (self scoreFromURL: urlString) - title: titleString"! ! -!MIDIFileReader class methodsFor: 'as yet unclassified' stamp: 'pb 5/25/2016 01:51'! - scoreFromFileNamed: fileName - - | f score | - f _ (fileName asFileEntry readStream) binary. - score _ (self new readMIDIFrom: f) asScore. - f close. - ^ score -! ! -!MIDIFileReader class methodsFor: 'as yet unclassified' stamp: 'ls 8/8/1998 03:14'! - scoreFromStream: binaryStream - - | score | - score _ (self new readMIDIFrom: binaryStream) asScore. - ^ score -! ! -!MIDIFileReader class methodsFor: 'as yet unclassified' stamp: 'jm 9/12/1998 19:57'! - standardMIDIInstrumentNames - "Answer an array of Standard MIDI instrument names." - - ^ #( - 'Grand Piano' - 'Bright Piano' - 'Electric Grand Piano' - 'Honky-tonk Piano' - 'Electric Piano 1' - 'Electric Piano 2' - 'Harpsichord' - 'Clavichord' - 'Celesta' - 'Glockenspiel' - 'Music Box' - 'Vibraphone' - 'Marimba' - 'Xylophone' - 'Tubular Bells' - 'Duclimer' - 'Drawbar Organ' - 'Percussive Organ' - 'Rock Organ' - 'Church Organ' - 'Reed Organ' - 'Accordion' - 'Harmonica' - 'Tango Accordion' - 'Nylon Guitar' - 'Steel Guitar' - 'Electric Guitar 1' - 'Electric Guitar 2' - 'Electric Guitar 3' - 'Overdrive Guitar' - 'Distorted Guitar' - 'Guitar Harmonics' - 'Acoustic Bass' - 'Electric Bass 1' - 'Electric Bass 2' - 'Fretless Bass' - 'Slap Bass 1' - 'Slap Bass 2' - 'Synth Bass 1' - 'Synth Bass 2' - 'Violin' - 'Viola' - 'Cello' - 'Contrabass' - 'Tremolo Strings' - 'Pizzicato Strings' - 'Orchestral Harp' - 'Timpani' - 'String Ensemble 1' - 'String Ensemble 2' - 'Synth Strings 1' - 'Synth Strings 2' - 'Choir Ahhs' - 'Choir Oohs' - 'Synth Voice' - 'Orchestra Hit' - 'Trumpet' - 'Trombone' - 'Tuba' - 'Muted Trumpet' - 'French Horn' - 'Brass Section' - 'Synth Brass 1' - 'Synth Brass 2' - 'Soprano Sax' - 'Alto Sax' - 'Tenor Sax' - 'Baritone Sax' - 'Oboe' - 'English Horn' - 'Bassoon' - 'Clarinet' - 'Piccolo' - 'Flute' - 'Recorder' - 'Pan Flute' - 'Blown Bottle' - 'Shakuhachi' - 'Whistle' - 'Ocarina' - 'Lead 1 (square)' - 'Lead 2 (sawtooth)' - 'Lead 3 (calliope)' - 'Lead 4 (chiff)' - 'Lead 5 (charang)' - 'Lead 6 (voice)' - 'Lead 7 (fifths)' - 'Lead 8 (bass+lead)' - 'Pad 1 (new age)' - 'Pad 2 (warm)' - 'Pad 3 (polysynth)' - 'Pad 4 (choir)' - 'Pad 5 (bowed)' - 'Pad 6 (metallic)' - 'Pad 7 (halo)' - 'Pad 8 (sweep)' - 'FX 1 (rain)' - 'FX 2 (soundtrack)' - 'FX 3 (crystals)' - 'FX 4 (atmosphere)' - 'FX 5 (brightness)' - 'FX 6 (goblins)' - 'FX 7 (echoes)' - 'FX 8 (sci-fi)' - 'Sitar' - 'Banjo' - 'Shamisen' - 'Koto' - 'Kalimba' - 'Bagpipe' - 'Fiddle' - 'Shanai' - 'Tinkle Bell' - 'Agogo' - 'Steel Drum' - 'Woodblock' - 'Taiko Drum' - 'Melodic Tom' - 'Synth Drum' - 'Reverse Cymbal' - 'Guitar Fret Noise' - 'Breath Noise' - 'Seashore' - 'Bird Tweet' - 'Telephone Ring' - 'Helicopter' - 'Applause' - 'Gunshot') -! ! -!MIDIInputParser methodsFor: 'recording' stamp: 'jmv 4/17/2013 12:05'! - clearBuffers - "Clear the MIDI record buffers. This should be called at the start of recording or real-time MIDI processing." - - received _ received species new: 5000. - rawDataBuffer _ ByteArray new: 1000. - sysExBuffer _ WriteStream on: (ByteArray new: 100). - midiPort ifNotNil: [midiPort ensureOpen; flushInput]. - startTime _ Time localMillisecondClock. - state _ #idle. -! ! -!MIDIInputParser methodsFor: 'private-state machine' stamp: 'jm 10/8/1998 18:34'! - endSysExclusive: cmdByte - "Error!! Received 'end system exclusive' command when not receiving system exclusive data." - - self error: 'unexpected ''End of System Exclusive'' command'. -! ! -!MIDIInputParser methodsFor: 'midi filtering' stamp: 'jm 10/8/1998 20:39'! - ignoreChannel: channel - "Don't record any events arriving on the given MIDI channel (in the range 1-16)." - - ((channel isInteger not) | (channel < 1) | (channel > 16)) - ifTrue: [^ self error: 'bad MIDI channel number', channel printString]. - - "two-arg channel messages" - #(128 144 160 176 224) do: [:i | cmdActionTable at: (i bitOr: channel - 1) put: #ignoreTwo:]. - - "one-arg channel messages" - #(192 208) do: [:i | cmdActionTable at: (i bitOr: channel - 1) put: #ignoreOne:]. -! ! -!MIDIInputParser methodsFor: 'midi filtering' stamp: 'jm 10/8/1998 20:40'! - ignoreCommand: midiCmd - "Don't record the given MIDI command on any channel." - - | cmd sel | - ((midiCmd isInteger not) | (midiCmd < 128) | (midiCmd > 255)) - ifTrue: [^ self error: 'bad MIDI command']. - - midiCmd < 240 ifTrue: [ "channel commands; ignore on all channels" - cmd _ midiCmd bitAnd: 2r11110000. - sel _ (#(128 144 160 176 224) includes: cmd) - ifTrue: [#ignoreTwo:] - ifFalse: [#ignoreOne:]. - 1 to: 16 do: [:ch | cmdActionTable at: (cmd bitOr: ch - 1) put: sel]. - ^ self]. - - (#(240 241 244 245 247 249 253) includes: midiCmd) ifTrue: [ - ^ self error: 'You can''t ignore the undefined MIDI command: ', midiCmd printString]. - - midiCmd = 242 ifTrue: [ "two-arg command" - cmdActionTable at: midiCmd put: #ignoreTwo:. - ^ self]. - - midiCmd = 243 ifTrue: [ "one-arg command" - cmdActionTable at: midiCmd put: #ignoreOne:. - ^ self]. - - (#(246 248 250 251 252 254 255) includes: midiCmd) ifTrue: [ "zero-arg command" - cmdActionTable at: midiCmd put: #ignore. - ^ self]. - - "we should not get here" - self error: 'implementation error'. -! ! -!MIDIInputParser methodsFor: 'private-state machine' stamp: 'jm 10/8/1998 19:24'! - ignoreOne: cmdByte - "Ignore a one argument command." - - lastCmdByte _ cmdByte. - lastSelector _ #ignoreOne:. - state _ #ignore1. -! ! -!MIDIInputParser methodsFor: 'midi filtering' stamp: 'jm 10/8/1998 20:38'! - ignoreSysEx: aBoolean - "If the argument is true, then ignore incoming system exclusive message." - - ignoreSysEx _ aBoolean. -! ! -!MIDIInputParser methodsFor: 'midi filtering' stamp: 'jm 10/9/1998 07:46'! - ignoreTuneAndRealTimeCommands - "Ignore tuning requests and real-time commands." - - cmdActionTable at: 246 put: #ignoreZero:. "tune request" - cmdActionTable at: 248 put: #ignoreZero:. "timing clock" - cmdActionTable at: 250 put: #ignoreZero:. "start" - cmdActionTable at: 251 put: #ignoreZero:. "continue" - cmdActionTable at: 252 put: #ignoreZero:. "stop/Clock" - cmdActionTable at: 254 put: #ignoreZero:. "active sensing" - cmdActionTable at: 255 put: #ignoreZero:. "system reset" -! ! -!MIDIInputParser methodsFor: 'private-state machine' stamp: 'jm 10/8/1998 19:24'! - ignoreTwo: cmdByte - "Ignore a two argument command." - - lastCmdByte _ cmdByte. - lastSelector _ #ignoreTwo:. - state _ #ignore2. -! ! -!MIDIInputParser methodsFor: 'private-state machine' stamp: 'jm 10/9/1998 07:45'! - ignoreZero: cmdByte - "Ignore a zero argument command, such as tune request or a real-time message. Stay in the current and don't change active status. Note that real-time messages can arrive between data bytes without disruption." - - "do nothing" -! ! -!MIDIInputParser methodsFor: 'real-time processing' stamp: 'jm 10/9/1998 07:53'! - midiDo: aBlock - "Poll the incoming MIDI stream in real time and call the given block for each complete command that has been received. The block takes one argument, which is an array of the form (